diff --git a/LeanPool/FLTEichlerShimura.lean b/LeanPool/FLTEichlerShimura.lean
new file mode 100644
index 0000000000..c0db5825a4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura.lean
@@ -0,0 +1,140 @@
+/-
+Copyright (c) 2026 Lean Pool contributors. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Lean Pool contributors
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_eichlerShimura_heckeEquivariant
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_isCompl_range_eichlerShimuraMap_range_conj
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_tateModuleRep_charpoly_frobenius
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_tateModuleRep_isUnramifiedAt_of_isGoodPrimeFor
+
+/-!
+# FLT Eichler-Shimura
+
+Source: url:https://github.com/loefflerd/KN-scratch
+Authors: David Loeffler
+Status: verified
+Main declarations: `HeckeEis.exists_eichlerShimura_heckeEquivariant`, `HeckeEis.isCompl_range_eichlerShimuraMap_range_conj`, `WeierstrassCurve.tateModuleRep_charpoly_frobenius`, `WeierstrassCurve.tateModuleRep_isUnramifiedAt_of_isGoodPrimeFor`
+Tags: number-theory, modular-forms, elliptic-curves, galois-representations
+MSC: 11F11
+-/
+
+/-!
+## Upstream attribution
+
+This project adapts material from David Loeffler’s loefflerd/KN-scratch fork and the original
+anthropics/fermats-last-theorem release at commit aa2d8b34692b16c70f699536de0d8e75b9a3e9ef.
+
+Fermat's Last Theorem in Lean 4
+Copyright 2026 Anthropic, PBC
+
+The original release is made available under the Apache License, Version 2.0. Its NOTICE and
+ATTRIBUTION.md identify material adapted from the Imperial College London FLT project and Mathlib.
+The applicable per-file notices below are reproduced from that frozen ATTRIBUTION.md; they
+supplement the notices already retained in the individual imported modules.
+
+Frozen source notices:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/NOTICE
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/ATTRIBUTION.md
+
+Path mapping: Definitions/Def_*.lean keeps the same suffix under
+LeanPool/FLTEichlerShimura/Definitions/. An original P2M/Sol/S_*.lean file is imported under
+LeanPool/FLTEichlerShimura/Theorems/Thm_*.lean with the same suffix.
+
+### Applicable FLT and Mathlib per-file notices
+
+- `Definitions/Def_DedekindDomain_AdicValuation_InlineSpecific.lean`
+  `FLT/DedekindDomain/AdicValuation.lean` — © 2025 Matthew Jasper; authors: Matthew Jasper
+  `FLT/Mathlib/RingTheory/Valuation/ValuationSubring.lean` — © 2025 Ruben Van de Velde; authors:
+  Ruben Van de Velde, Kevin Buzzard, Salvatore Mercuri
+  `FLT/Mathlib/RingTheory/DedekindDomain/AdicValuation.lean` — © 2025 Kevin Buzzard; authors:
+  Kevin Buzzard, Salvatore Mercuri
+
+- `P2M/Sol/S_AlgebraicCurve_residueTheoremK_of_isAlgClosed.lean`
+  `FLT/Mathlib/RingTheory/LocalRing/MaximalIdeal/Basic.lean` — © 2025 Salvatore Mercuri; authors:
+  Salvatore Mercuri, Kevin Buzzard
+
+- `P2M/Sol/S_AlgebraicCurve_tateAgreement.lean`
+  `FLT/Mathlib/RingTheory/LocalRing/MaximalIdeal/Basic.lean` — © 2025 Salvatore Mercuri; authors:
+  Salvatore Mercuri, Kevin Buzzard
+
+- `P2M/Sol/S_AlgebraicCurve_tateChainRule.lean`
+  `FLT/Mathlib/RingTheory/Valuation/ValuationSubring.lean` — © 2025 Ruben Van de Velde; authors:
+  Ruben Van de Velde, Kevin Buzzard, Salvatore Mercuri
+  `FLT/Mathlib/RingTheory/LocalRing/MaximalIdeal/Basic.lean` — © 2025 Salvatore Mercuri; authors:
+  Salvatore Mercuri, Kevin Buzzard
+
+- `P2M/Sol/S_AlgebraicCurve_tateCommFinite.lean`
+  `FLT/Mathlib/RingTheory/Valuation/ValuationSubring.lean` — © 2025 Ruben Van de Velde; authors:
+  Ruben Van de Velde, Kevin Buzzard, Salvatore Mercuri
+  `FLT/Mathlib/RingTheory/LocalRing/MaximalIdeal/Basic.lean` — © 2025 Salvatore Mercuri; authors:
+  Salvatore Mercuri, Kevin Buzzard
+
+- `P2M/Sol/S_AlgebraicCurve_tateTraceCompat_of_isSeparable.lean`
+  `FLT/Mathlib/RingTheory/Valuation/ValuationSubring.lean` — © 2025 Ruben Van de Velde; authors:
+  Ruben Van de Velde, Kevin Buzzard, Salvatore Mercuri
+  `FLT/Mathlib/RingTheory/LocalRing/MaximalIdeal/Basic.lean` — © 2025 Salvatore Mercuri; authors:
+  Salvatore Mercuri, Kevin Buzzard
+
+- `P2M/Sol/S_WeierstrassCurve_exists_intermediateField_countable_map_eq_and_finrankAlong_eq.lean`
+  `FLT/Mathlib/LinearAlgebra/Countable.lean` — © 2025 Kevin Buzzard; authors: Kevin Buzzard
+
+- `Definitions/Def_FLTPrelim_FreyPackage.lean`
+  `FLT/Basic/FreyPackage.lean` — authors recorded in our intermediate port: Kevin Buzzard, Ruben
+  Van de Velde, Pietro Monticone (path as recorded in our port)
+
+- `Definitions/Def_FLTPrelim_GaloisRep.lean`
+  `FLT/EllipticCurve/Torsion.lean` (commit 7a87d3b25db1) — © 2024 Kevin Buzzard; authors: Kevin
+  Buzzard (path as recorded in our port; the notice retained inside our file is our May port's
+  generic one, the upstream notice is reproduced here)
+
+- `P2M/Sol/S_EisensteinSeries_exists_modularForm_coe_eq_eisensteinG.lean`
+  `Mathlib/NumberTheory/ModularForms/EisensteinSeries/IsBoundedAtImInfty.lean` — Copyright (c)
+  2024 Chris Birkbeck; Authors: Chris Birkbeck
+  Material identified by upstream: the proof of
+  `EisensteinSeries.isBoundedAtImInfty_eisensteinSeriesSIF` with its auxiliary norm bound, adapted
+  to this repository's `eisensteinG` (≈15 lines)
+
+- `P2M/Sol/S_EisensteinSeries_qExpansion_eisensteinG_coeff.lean`
+  `Mathlib/NumberTheory/ModularForms/EisensteinSeries/IsBoundedAtImInfty.lean` — Copyright (c)
+  2024 Chris Birkbeck; Authors: Chris Birkbeck
+  Material identified by upstream: the same proof of
+  `EisensteinSeries.isBoundedAtImInfty_eisensteinSeriesSIF`, adapted (≈15 lines)
+
+### Mathlib compatibility copies
+
+Definitions/Def_Compat_Mathlib430.lean also carries the Mathlib compatibility material listed in
+the first table of upstream ATTRIBUTION.md §4. Its source comments identify the copied or adapted
+blocks and Mathlib v4.30.0 commit c5ea00351c28e24afc9f0f84379aa41082b1188f. The notices for those
+eight source files are:
+
+- `Mathlib/RepresentationTheory/Basic.lean`
+  Copyright (c) 2022 Antoine Labelle; Authors: Antoine Labelle
+- `Mathlib/RepresentationTheory/Rep/Basic.lean`
+  Copyright (c) 2026 Yunzhou Xie; Authors: Edison Xie, Kim Morrison
+- `Mathlib/Algebra/Group/End.lean`
+  Copyright (c) 2018 Johannes Hölzl; Authors: Johannes Hölzl, Callum Sutton, Yury Kudryashov
+- `Mathlib/Algebra/GroupWithZero/Action/Basic.lean`
+  Copyright (c) 2018 Chris Hughes; Authors: Chris Hughes, Yury Kudryashov
+- `Mathlib/Algebra/Ring/AddAut.lean`
+  Copyright (c) 2022 Yury Kudryashov; Authors: Yury Kudryashov
+- `Mathlib/Algebra/Ring/Action/Submonoid.lean`
+  Copyright (c) 2024 David Ang; Authors: David Ang
+- `Mathlib/NumberTheory/EllipticDivisibilitySequence.lean`
+  Copyright (c) 2024 David Kurniadi Angdinata; Authors: David Kurniadi Angdinata
+- `Mathlib/NumberTheory/RamificationInertia/Galois.lean`
+  Copyright (c) 2024 Yongle Hu; Authors: Yongle Hu, Jiedong Jiang
+
+These Mathlib file notices continue: All rights reserved. Released under Apache 2.0 license as
+described in the file LICENSE.
+
+The frozen upstream table records approximate extents and acknowledges incomplete detection of
+small passages. Its §2 paths and author lists are recorded intermediate-port notes, except that
+the FLT/EllipticCurve/Torsion.lean notice was checked at commit
+7a87d3b25db19d008cd45b29edd2b92803e785b1. The table records the main FLT source snapshot as
+2026-05-21 without a commit hash. This attribution preserves those limits; it is not an
+independent completeness certificate for the historical provenance search.
+-/
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AdicCompletionLocalRing.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AdicCompletionLocalRing.lean
new file mode 100644
index 0000000000..f146295da9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AdicCompletionLocalRing.lean
@@ -0,0 +1,270 @@
+/-
+Based on Prove2Me node AdicCompletionLocalRing
+(5df31c27-9646-52af-886e-7d5db1e0c5e5) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.AdicCompletion.Completeness
+public import Mathlib.RingTheory.AdicCompletion.LocalRing
+public import Mathlib.RingTheory.LocalRing.MaximalIdeal.Basic
+public import Mathlib.RingTheory.Ideal.Quotient.Operations
+public import Mathlib.RingTheory.Noetherian.Defs
+
+/-!
+# Adic completion of a Noetherian local ring
+
+Definition: `AdicCompletionLocalRing` (`5df31c27-9646-52af-886e-7d5db1e0c5e5`), by Claude,
+2026-09-05.
+
+Throughout, $A$ is a commutative ring and the objects are Mathlib's $I$-adic completion $\widehat{A}
+=$ `AdicCompletion I A` together with its level-$n$ evaluation maps `eval I A n` (linear) and `evalₐ
+I n` (as a ring/algebra map onto $A/I^n$).
+
+The first group of results identifies the kernels. `evalₐ_algebraMap` records that the composite of
+the structure map $A \to \widehat{A}$ with `evalₐ I n` is reduction modulo $I^n$;
+`mem_ker_evalₐ_iff` identifies the ring-theoretic kernel of `evalₐ I n` with the module-theoretic
+kernel of `eval I A n`; and, for $I$ finitely generated, `ker_evalₐ_eq_map_pow` states that this
+kernel is the ideal of $\widehat{A}$ generated by the image of $I^n$. Consequently
+`exists_eq_algebraMap_add` writes any $x \in \widehat{A}$ as $a + y$ with $a \in A$ and $y$ in the
+extension of $I^n$. For $I$ finitely generated, `isUnit_one_add_of_mem_map` shows $1+x$ is a unit
+when $x$ lies in the extension of $I$ (the extended ideal lies in the Jacobson radical,
+$\widehat{A}$ being adically complete), and `isUnit_add_of_mem_map` extends this to $u+x$ for $u$ a
+unit.
+
+In the local section $A$ is local with maximal ideal $\mathfrak m$, and then Noetherian.
+`isUnit_of_isUnit_algebraMap` descends unitness along $A \to \widehat{A}$; `maximalIdeal_fg` records
+that $\mathfrak m$ is finitely generated; an instance makes $\widehat{A}$ a local ring.
+`maximalIdeal_pow_eq_ker_evalₐ` states that the $n$-th power of the maximal ideal of $\widehat{A}$
+is the kernel of `evalₐ (maximalIdeal A) n`, with the cases $n=1$ and the membership criterion $x
+\in \mathfrak m_{\widehat A} \iff$ `evalₐ … 1 x = 0` spelled out separately. For a base ring $k$
+with $A$ a $k$-algebra, `quotientMaximalIdealPowAlgHom` is the induced $k$-algebra map
+$\widehat{A}/\mathfrak m_{\widehat A}^n \to A/\mathfrak m^n$; it is bijective, and
+`quotientMaximalIdealPowAlgEquiv` is the resulting $k$-algebra isomorphism, which sends the class of
+the image of $a \in A$ to the class of $a$.
+
+The transport section fixes a $k$-algebra isomorphism $\Phi : \widehat{A} \xrightarrow{\sim} B$ with
+$B$ a local ring. It records that $\Phi$ preserves unitness, that the maximal ideal of $B$ is the
+contraction-free image (and contraction) of $\mathfrak m_{\widehat A}$, that $\mathfrak m_B^n$ is
+the ideal generated by the image of $\mathfrak m^n$ under $A \to \widehat{A} \xrightarrow{\Phi} B$,
+that $\Phi$ carries the image of $\mathfrak m$ into $\mathfrak m_B$, and finally gives a $k$-algebra
+isomorphism `quotientMaximalIdealPowAlgEquivOfAlgEquiv` $: B/\mathfrak m_B^n \simeq A/\mathfrak m^n$
+sending the class of $\Phi(a)$ to the class of $a$.
+
+**Relation to Mathlib.** All of this is built on Mathlib's `AdicCompletion`, its evaluation maps
+`eval` and `evalₐ`, and Mathlib's local-ring results for adic completions (`isLocalRing_of_fg`,
+`maximalIdeal_eq_map`, `IsAdicComplete.le_jacobson_bot`); what is added here are the level-$n$
+kernel identifications, the unit criteria for $1+x$ and $u+x$, the $k$-algebra isomorphisms
+$\widehat{A}/\mathfrak m_{\widehat A}^n \simeq A/\mathfrak m^n$, and their transport along an
+algebra isomorphism of $\widehat A$ with another local algebra.
+
+**Where it is used.** These identifications are the basic bookkeeping for working with complete
+Noetherian local coefficient and deformation rings: they let one compute in $\widehat{A}$ modulo
+powers of its maximal ideal by computing in $A/\mathfrak m^n$, and to move such computations across
+an abstract presentation $\widehat{A} \simeq B$ of the completion.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open IsLocalRing
+
+namespace AdicCompletion
+
+variable {A : Type*} [CommRing A]
+
+section Kernel
+
+variable (I : Ideal A)
+
+theorem evalₐ_algebraMap (n : ℕ) (a : A) :
+    evalₐ I n (algebraMap A (AdicCompletion I A) a) = Ideal.Quotient.mk _ a := by
+  rw [algebraMap_apply, Algebra.algebraMap_self, RingHom.id_apply, evalₐ_of]
+
+theorem mem_ker_evalₐ_iff (n : ℕ) (x : AdicCompletion I A) :
+    x ∈ RingHom.ker (evalₐ I n) ↔ x ∈ LinearMap.ker (eval I A n) := by
+  have h : (I ^ n • ⊤ : Ideal A) = I ^ n := by rw [smul_eq_mul, Ideal.mul_top]
+  rw [RingHom.mem_ker, LinearMap.mem_ker]
+  constructor
+  · intro hx; rw [← factor_evalₐ_eq_eval I x h.ge, hx]; exact RingHom.map_zero _
+  · intro hx; rw [← factor_eval_eq_evalₐ I x h.le, hx]; exact LinearMap.map_zero _
+
+theorem ker_evalₐ_eq_map_pow (hI : I.FG) (n : ℕ) :
+    RingHom.ker (evalₐ I n) = (I ^ n).map (algebraMap A (AdicCompletion I A)) := by
+  ext x
+  rw [mem_ker_evalₐ_iff, ← pow_smul_top_eq_ker_eval hI, Ideal.smul_top_eq_map,
+    Submodule.restrictScalars_mem]
+
+theorem exists_eq_algebraMap_add (hI : I.FG) (n : ℕ) (x : AdicCompletion I A) :
+    ∃ a : A, ∃ y ∈ (I ^ n).map (algebraMap A (AdicCompletion I A)),
+      x = algebraMap A (AdicCompletion I A) a + y := by
+  obtain ⟨a, ha⟩ := Ideal.Quotient.mk_surjective (evalₐ I n x)
+  refine ⟨a, x - algebraMap A _ a, ?_, by ring⟩
+  rw [← ker_evalₐ_eq_map_pow I hI, RingHom.mem_ker, map_sub, evalₐ_algebraMap, ha, sub_self]
+
+theorem isUnit_one_add_of_mem_map (hI : I.FG) {x : AdicCompletion I A}
+    (hx : x ∈ I.map (algebraMap A (AdicCompletion I A))) : IsUnit (1 + x) := by
+  have : IsAdicComplete (I.map (algebraMap A (AdicCompletion I A))) (AdicCompletion I A) :=
+    (IsAdicComplete.map_algebraMap_iff I (AdicCompletion I A)).mpr (isAdicComplete hI)
+  have h := Ideal.mem_jacobson_bot.mp (IsAdicComplete.le_jacobson_bot _ hx) 1
+  rwa [mul_one, add_comm] at h
+
+theorem isUnit_add_of_mem_map (hI : I.FG) {u x : AdicCompletion I A} (hu : IsUnit u)
+    (hx : x ∈ I.map (algebraMap A (AdicCompletion I A))) : IsUnit (u + x) := by
+  have e : u + x = u * (1 + ↑hu.unit⁻¹ * x) := by
+    rw [mul_add, mul_one, ← mul_assoc, IsUnit.mul_val_inv, one_mul]
+  rw [e]
+  exact hu.mul (isUnit_one_add_of_mem_map I hI (Ideal.mul_mem_left _ _ hx))
+
+end Kernel
+
+section Local
+
+variable [IsLocalRing A]
+
+theorem isUnit_of_isUnit_algebraMap {a : A}
+    (h : IsUnit (algebraMap A (AdicCompletion (maximalIdeal A) A) a)) : IsUnit a := by
+  by_contra ha
+  have hmem : a ∈ maximalIdeal A ^ 1 := by
+    rw [pow_one]; exact (mem_maximalIdeal a).mpr ha
+  have h1 := h.map (evalₐ (maximalIdeal A) 1)
+  rw [evalₐ_algebraMap, Ideal.Quotient.eq_zero_iff_mem.mpr hmem, isUnit_zero_iff] at h1
+  exact (maximalIdeal.isMaximal A).ne_top
+    ((pow_one (maximalIdeal A)).symm.trans (Ideal.Quotient.zero_eq_one_iff.mp h1))
+
+theorem isUnit_one_add_of_mem_map_maximalIdeal (h𝔪 : (maximalIdeal A).FG)
+    {x : AdicCompletion (maximalIdeal A) A}
+    (hx : x ∈ (maximalIdeal A).map (algebraMap A (AdicCompletion (maximalIdeal A) A))) :
+    IsUnit (1 + x) :=
+  isUnit_one_add_of_mem_map _ h𝔪 hx
+
+variable [IsNoetherianRing A]
+
+theorem maximalIdeal_fg : (maximalIdeal A).FG := IsNoetherian.noetherian _
+
+instance instIsLocalRingMaximalIdeal : IsLocalRing (AdicCompletion (maximalIdeal A) A) :=
+  isLocalRing_of_fg maximalIdeal_fg
+
+theorem maximalIdeal_pow_eq_ker_evalₐ (n : ℕ) :
+    maximalIdeal (AdicCompletion (maximalIdeal A) A) ^ n = RingHom.ker (evalₐ (maximalIdeal A) n) :=
+      by
+  rw [maximalIdeal_eq_map, ← Ideal.map_pow, ker_evalₐ_eq_map_pow _ maximalIdeal_fg]
+
+theorem maximalIdeal_eq_ker_evalₐ_one :
+    maximalIdeal (AdicCompletion (maximalIdeal A) A) = RingHom.ker (evalₐ (maximalIdeal A) 1) := by
+  rw [← maximalIdeal_pow_eq_ker_evalₐ, pow_one]
+
+theorem mem_maximalIdeal_iff (x : AdicCompletion (maximalIdeal A) A) :
+    x ∈ maximalIdeal (AdicCompletion (maximalIdeal A) A) ↔ evalₐ (maximalIdeal A) 1 x = 0 := by
+  rw [maximalIdeal_eq_ker_evalₐ_one, RingHom.mem_ker]
+
+section Scalars
+
+variable (k : Type*) [CommRing k] [Algebra k A]
+
+noncomputable def quotientMaximalIdealPowAlgHom (n : ℕ) :
+    (AdicCompletion (maximalIdeal A) A ⧸ maximalIdeal (AdicCompletion (maximalIdeal A) A) ^ n)
+      →ₐ[k] A ⧸ maximalIdeal A ^ n :=
+  Ideal.Quotient.liftₐ _ ((evalₐ (maximalIdeal A) n).restrictScalars k) fun x hx => by
+    rwa [maximalIdeal_pow_eq_ker_evalₐ, RingHom.mem_ker] at hx
+
+theorem quotientMaximalIdealPowAlgHom_mk (n : ℕ) (x : AdicCompletion (maximalIdeal A) A) :
+    quotientMaximalIdealPowAlgHom k n (Ideal.Quotient.mk _ x) = evalₐ (maximalIdeal A) n x :=
+  rfl
+
+theorem quotientMaximalIdealPowAlgHom_bijective (n : ℕ) :
+    Function.Bijective (quotientMaximalIdealPowAlgHom (A := A) k n) := by
+  constructor
+  · intro x y hxy
+    obtain ⟨x, rfl⟩ := Ideal.Quotient.mk_surjective x
+    obtain ⟨y, rfl⟩ := Ideal.Quotient.mk_surjective y
+    rw [quotientMaximalIdealPowAlgHom_mk, quotientMaximalIdealPowAlgHom_mk] at hxy
+    refine Ideal.Quotient.eq.mpr ?_
+    rw [maximalIdeal_pow_eq_ker_evalₐ, RingHom.mem_ker, map_sub, hxy, sub_self]
+  · intro z
+    obtain ⟨x, rfl⟩ := surjective_evalₐ (maximalIdeal A) n z
+    exact ⟨Ideal.Quotient.mk _ x, rfl⟩
+
+noncomputable def quotientMaximalIdealPowAlgEquiv (n : ℕ) :
+    (AdicCompletion (maximalIdeal A) A ⧸ maximalIdeal (AdicCompletion (maximalIdeal A) A) ^ n)
+      ≃ₐ[k] A ⧸ maximalIdeal A ^ n :=
+  AlgEquiv.ofBijective _ (quotientMaximalIdealPowAlgHom_bijective k n)
+
+theorem quotientMaximalIdealPowAlgEquiv_mk (n : ℕ) (x : AdicCompletion (maximalIdeal A) A) :
+    quotientMaximalIdealPowAlgEquiv k n (Ideal.Quotient.mk _ x) = evalₐ (maximalIdeal A) n x :=
+  rfl
+
+theorem quotientMaximalIdealPowAlgEquiv_mk_algebraMap (n : ℕ) (a : A) :
+    quotientMaximalIdealPowAlgEquiv k n (Ideal.Quotient.mk _ (algebraMap A _ a))
+      = Ideal.Quotient.mk _ a := by
+  rw [quotientMaximalIdealPowAlgEquiv_mk, evalₐ_algebraMap]
+
+end Scalars
+
+end Local
+
+section Transport
+
+variable [IsLocalRing A] [IsNoetherianRing A]
+variable {k : Type*} [CommRing k] [Algebra k A] {B : Type*} [CommRing B] [IsLocalRing B]
+    [Algebra k B]
+variable (Φ : AdicCompletion (maximalIdeal A) A ≃ₐ[k] B)
+
+omit [IsNoetherianRing A] [IsLocalRing B] in
+theorem isUnit_algEquiv_iff (x : AdicCompletion (maximalIdeal A) A) : IsUnit (Φ x) ↔ IsUnit x :=
+  ⟨fun h => by simpa using h.map Φ.symm, fun h => h.map Φ⟩
+
+theorem comap_maximalIdeal_algEquiv :
+    (maximalIdeal B).comap (Φ : AdicCompletion (maximalIdeal A) A →+* B)
+      = maximalIdeal (AdicCompletion (maximalIdeal A) A) := by
+  ext x
+  change Φ x ∈ maximalIdeal B ↔ x ∈ maximalIdeal _
+  rw [mem_maximalIdeal, mem_maximalIdeal, mem_nonunits_iff, mem_nonunits_iff, isUnit_algEquiv_iff]
+
+theorem map_maximalIdeal_algEquiv :
+    (maximalIdeal (AdicCompletion (maximalIdeal A) A)).map
+        (Φ : AdicCompletion (maximalIdeal A) A →+* B) = maximalIdeal B := by
+  rw [← comap_maximalIdeal_algEquiv Φ]
+  exact Ideal.map_comap_of_surjective _ Φ.surjective _
+
+theorem maximalIdeal_eq_map_algEquiv :
+    maximalIdeal B = (maximalIdeal A).map
+      ((Φ : AdicCompletion (maximalIdeal A) A →+* B).comp
+        (algebraMap A (AdicCompletion (maximalIdeal A) A))) := by
+  rw [← Ideal.map_map, ← maximalIdeal_eq_map, map_maximalIdeal_algEquiv]
+
+theorem maximalIdeal_pow_eq_map_algEquiv (n : ℕ) :
+    maximalIdeal B ^ n = (maximalIdeal A ^ n).map
+      ((Φ : AdicCompletion (maximalIdeal A) A →+* B).comp
+        (algebraMap A (AdicCompletion (maximalIdeal A) A))) := by
+  rw [Ideal.map_pow, ← maximalIdeal_eq_map_algEquiv]
+
+theorem algEquiv_algebraMap_mem_maximalIdeal {a : A} (ha : a ∈ maximalIdeal A) :
+    Φ (algebraMap A _ a) ∈ maximalIdeal B := by
+  rw [maximalIdeal_eq_map_algEquiv Φ]
+  exact Ideal.mem_map_of_mem _ ha
+
+noncomputable def quotientMaximalIdealPowAlgEquivOfAlgEquiv (n : ℕ) :
+    (B ⧸ maximalIdeal B ^ n) ≃ₐ[k] A ⧸ maximalIdeal A ^ n :=
+  (Ideal.quotientEquivAlg (maximalIdeal (AdicCompletion (maximalIdeal A) A) ^ n) (maximalIdeal B ^
+    n)
+    Φ (by rw [Ideal.map_pow, map_maximalIdeal_algEquiv])).symm.trans
+    (quotientMaximalIdealPowAlgEquiv k n)
+
+theorem quotientMaximalIdealPowAlgEquivOfAlgEquiv_mk (n : ℕ) (a : A) :
+    quotientMaximalIdealPowAlgEquivOfAlgEquiv Φ n (Ideal.Quotient.mk _ (Φ (algebraMap A _ a)))
+      = Ideal.Quotient.mk _ a := by
+  rw [quotientMaximalIdealPowAlgEquivOfAlgEquiv, AlgEquiv.trans_apply,
+    ← Ideal.quotientEquivAlg_mk (I := maximalIdeal (AdicCompletion (maximalIdeal A) A) ^ n)
+      (J := maximalIdeal B ^ n) (f := Φ) (hIJ := by rw [Ideal.map_pow, map_maximalIdeal_algEquiv]),
+    AlgEquiv.symm_apply_apply, quotientMaximalIdealPowAlgEquiv_mk_algebraMap]
+
+end Transport
+
+end AdicCompletion
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_AdelicIndex.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_AdelicIndex.lean
new file mode 100644
index 0000000000..75aaa8bf29
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_AdelicIndex.lean
@@ -0,0 +1,486 @@
+/-
+Based on Prove2Me node AlgebraicCurve_AdelicIndex
+(bf01c86f-e5ba-5a8f-a6af-7e543af941ac) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Order.Ring.Star
+public import Mathlib.Data.Int.Star
+public import Mathlib.Order.CompletePartialOrder
+public import Mathlib.RingTheory.Henselian
+public import Mathlib.RingTheory.RegularLocalRing.Defs
+public import Mathlib.RingTheory.SimpleRing.Principal
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Repartitions
+
+/-!
+# Adelic vocabulary for Riemann–Roch: L-spaces, Weil differentials
+
+Definition: `AlgebraicCurve_AdelicIndex` (`bf01c86f-e5ba-5a8f-a6af-7e543af941ac`), by Claude,
+2026-09-05.
+
+Throughout, $F/K$ is an extension of fields, with `Place K F` the project's places of $F/K$
+(valuation subrings of $F$ containing the image of $K$, proper and principal), $v.\mathrm{ord}$ the
+associated normalised order function, and `Divisor K F` the finitely supported $\mathbb{Z}$-valued
+functions on places. `LSpace D` abbreviates the project's `riemannRochSpace D`, the $K$-subspace
+$\{f \in F : v(f) \le \exp(D(v))\ \forall v\}$, equivalently $f = 0$ or $\mathrm{ord}_v f \ge -D(v)$
+for all $v$; `ell D` is its $K$-dimension. It is monotone in $D$ and contains the image of $K$;
+`ConstantsAreBase K F` is the predicate $L(0) = \operatorname{range}(K \to F)$, under which
+$\ell(0)=1$.
+
+On the full product $\prod_v F$ the module defines $\mathbb{A}(D) =$ `adeleBdd D`, the $K$-submodule
+of families $\alpha$ with $v(\alpha_v) \le \exp(D(v))$ for all $v$, the diagonal map `diagonalHom`,
+the adèle space `adeleSpace K F` $= \bigsqcup_D \mathbb{A}(D)$ (a supremum, shown directed, so
+membership means lying in some $\mathbb{A}(D)$), and `globalSub K F`, the range of the diagonal.
+Then $L(D) \cong \mathbb{A}(D) \cap F$ as $K$-spaces, `adeleBddPrincipal K F D` is the sum of the
+preimages of $\mathbb{A}(D)$ and of $F$ inside the adèle space, and `indexOfSpecialty D` is the
+$K$-dimension of the quotient by it. `omegaSpace D` is the annihilator of that sum in the $K$-dual
+of the adèle space, so a Weil differential of $D$ is a functional vanishing on $\mathbb{A}(D)$ and
+on diagonal elements; its dimension equals the index of specialty, and `weilDifferentialModule K F`
+is the (directed) supremum over $D$. Multiplication by $f \in F$ acts componentwise (`mulAdele`,
+`adeleSpaceMul` under `HasPrincipalDivisors`), and `weilSmul` is the dual action, multiplicative in
+the contravariant sense and injective for $f \ne 0$; it carries $\Omega(W)$ into $\Omega(D)$
+whenever $g \in L(W-D)$, giving the injective `residuePairing` $L(W-D) \to \Omega(D)$ and the
+inequality $\ell(W-D) \le i(D)$.
+
+Finally, `WeilDifferentialRankOne` (every Weil differential is uniquely $f \cdot \varphi$ for a
+fixed nonzero $\varphi$), `HasWeilCanonicalDivisor` (each nonzero Weil differential lies in
+$\Omega(W)$ for a largest $W$), the structure `RiemannGenusReachedAt γ D₀` (carrying
+finite-dimensionality of $L(D_0)$, the equality $\deg D_0 - \ell(D_0) = \gamma - 1$ and maximality
+of this quantity over all divisors), and the predicates `RiemannGenusReached`,
+`StichtenothGenusExists`, `RiemannGenusBounded`, `IndexOfSpecialtyFinite` are named hypotheses;
+nothing about their validity is asserted here.
+
+**Relation to Mathlib.** The adèle-type objects are built directly as $K$-submodules of the product
+$\prod_v F$ over the project's `Place K F`, not from Mathlib's finite adèle ring; places, divisors
+and `riemannRochSpace` are the project's own notions, and `LSpace` is an abbreviation for the
+latter.
+
+**Where it is used.** This module fixes the vocabulary in which Riemann–Roch for the function field
+of a curve is stated and proved adelically: $L$-spaces and their dimensions, the adèle space with
+its bounded pieces, the index of specialty, Weil differentials with the multiplication action of
+$F$, and named genus hypotheses. It is imported widely by the curve-theoretic part of the
+development.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open IsDedekindDomain WithZero Module
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+abbrev LSpace (D : Divisor K F) : Submodule K F := riemannRochSpace D
+
+abbrev ell (D : Divisor K F) : ℕ := Module.finrank K (LSpace D)
+
+variable {D E : Divisor K F}
+
+theorem mem_lSpace_iff {f : F} :
+    f ∈ LSpace D ↔ ∀ v : Place K F, v.adicValuation f ≤ WithZero.exp (D v) := Iff.rfl
+
+theorem mem_lSpace_iff_ord {f : F} :
+    f ∈ LSpace D ↔ f = 0 ∨ ∀ v : Place K F, -D v ≤ v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · exact ⟨fun _ => Or.inl rfl, fun _ => (LSpace D).zero_mem⟩
+  · refine Iff.trans ?_ (or_iff_right hf).symm
+    refine forall_congr' fun v => ?_
+    have hne : v.adicValuation f ≠ 0 := v.adicValuation_ne_zero hf
+    rw [show v.adicValuation f = WithZero.exp (-v.ord f) by
+          rw [Place.ord, neg_neg, WithZero.exp_log hne],
+      WithZero.exp_le_exp, neg_le]
+
+theorem lSpace_mono (hDE : D ≤ E) : LSpace D ≤ LSpace E := fun _ hf v =>
+  (hf v).trans (WithZero.exp_le_exp.mpr (hDE v))
+
+theorem algebraMap_mem_lSpace_zero (c : K) :
+    algebraMap K F c ∈ LSpace (0 : Divisor K F) := fun v => by
+  rw [Finsupp.coe_zero, Pi.zero_apply, WithZero.exp_zero]
+  exact v.adicValuation_algebraMap_le_one c
+
+theorem one_mem_lSpace_zero : (1 : F) ∈ LSpace (0 : Divisor K F) := by
+  simpa using algebraMap_mem_lSpace_zero (K := K) (F := F) 1
+
+def ConstantsAreBase (K F : Type*) [Field K] [Field F] [Algebra K F] : Prop :=
+  LSpace (0 : Divisor K F) = LinearMap.range (Algebra.linearMap K F)
+
+theorem ell_zero_eq_one_of_constantsAreBase (h : ConstantsAreBase K F) :
+    ell (0 : Divisor K F) = 1 := by
+  rw [ell, h, LinearMap.finrank_range_of_inj (f := Algebra.linearMap K F)
+    (algebraMap K F).injective, Module.finrank_self]
+
+def adeleBdd (D : Divisor K F) : Submodule K (Place K F → F) where
+  carrier := {α | ∀ v : Place K F, v.adicValuation (α v) ≤ WithZero.exp (D v)}
+  add_mem' := fun {α β} hα hβ v =>
+    (v.adicValuation.map_add (α v) (β v)).trans (max_le (hα v) (hβ v))
+  zero_mem' := fun v => by rw [Pi.zero_apply, Valuation.map_zero]; exact zero_le
+  smul_mem' := fun c α hα v => by
+    rw [Pi.smul_apply, Algebra.smul_def, Valuation.map_mul]
+    calc v.adicValuation (algebraMap K F c) * v.adicValuation (α v)
+        ≤ 1 * v.adicValuation (α v) := by gcongr; exact v.adicValuation_algebraMap_le_one c
+      _ = v.adicValuation (α v) := one_mul _
+      _ ≤ WithZero.exp (D v) := hα v
+
+variable {D E : Divisor K F}
+
+@[simp]
+theorem mem_adeleBdd {α : Place K F → F} :
+    α ∈ adeleBdd D ↔ ∀ v : Place K F, v.adicValuation (α v) ≤ WithZero.exp (D v) := Iff.rfl
+
+theorem adeleBdd_mono (hDE : D ≤ E) : adeleBdd D ≤ adeleBdd E := fun _ hα v =>
+  (hα v).trans (WithZero.exp_le_exp.mpr (hDE v))
+
+variable (K F) in
+def diagonalHom : F →ₗ[K] (Place K F → F) where
+  toFun f := fun _ => f
+  map_add' _ _ := rfl
+  map_smul' _ _ := rfl
+
+@[simp]
+theorem diagonalHom_apply (f : F) (v : Place K F) : diagonalHom K F f v = f := rfl
+
+theorem diagonalHom_injective [Nonempty (Place K F)] :
+    Function.Injective (diagonalHom K F) := fun f g h => by
+  simpa using congrFun h (Classical.arbitrary (Place K F))
+
+theorem diagonal_mem_adeleBdd_iff {f : F} :
+    diagonalHom K F f ∈ adeleBdd D ↔ f ∈ LSpace D := by
+  simp only [mem_adeleBdd, diagonalHom_apply, mem_lSpace_iff]
+
+variable (K F) in
+def adeleSpace : Submodule K (Place K F → F) := ⨆ D : Divisor K F, adeleBdd D
+
+theorem adeleBdd_le_adeleSpace : adeleBdd D ≤ adeleSpace K F := le_iSup adeleBdd D
+
+theorem diagonal_mem_adeleSpace [HasPrincipalDivisors K F] (f : F) :
+    diagonalHom K F f ∈ adeleSpace K F := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · rw [map_zero]; exact (adeleSpace K F).zero_mem
+  · obtain ⟨P, hPord, _⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf
+    refine adeleBdd_le_adeleSpace (D := -P) ?_
+    intro v
+    rw [diagonalHom_apply,
+      show ((-P : Divisor K F) v) = -v.ord f by rw [Finsupp.neg_apply, hPord v]]
+    exact le_of_eq (by rw [Place.ord, neg_neg, WithZero.exp_log (v.adicValuation_ne_zero hf)])
+
+variable (K F) in
+def globalSub : Submodule K (Place K F → F) := LinearMap.range (diagonalHom K F)
+
+theorem diagonal_mem_globalSub (f : F) : diagonalHom K F f ∈ globalSub K F :=
+  LinearMap.mem_range_self _ f
+
+theorem map_diagonal_lSpace (D : Divisor K F) :
+    (LSpace D).map (diagonalHom K F) = adeleBdd D ⊓ globalSub K F := by
+  ext α
+  rw [Submodule.mem_map, Submodule.mem_inf]
+  constructor
+  · rintro ⟨f, hf, rfl⟩
+    exact ⟨diagonal_mem_adeleBdd_iff.mpr hf, diagonal_mem_globalSub f⟩
+  · rintro ⟨hbdd, hglob⟩
+    obtain ⟨f, hf⟩ := LinearMap.mem_range.mp hglob
+    exact ⟨f, diagonal_mem_adeleBdd_iff.mp (by rw [hf]; exact hbdd), hf⟩
+
+def lSpaceEquivAdeleBddInfGlobal [Nonempty (Place K F)] (D : Divisor K F) :
+    LSpace D ≃ₗ[K] (adeleBdd D ⊓ globalSub K F : Submodule K (Place K F → F)) :=
+  (Submodule.equivMapOfInjective (diagonalHom K F) diagonalHom_injective (LSpace D)).trans
+    (LinearEquiv.ofEq _ _ (map_diagonal_lSpace D))
+
+theorem finrank_adeleBdd_inf_global_eq_ell [Nonempty (Place K F)] (D : Divisor K F) :
+    Module.finrank K (adeleBdd D ⊓ globalSub K F : Submodule K (Place K F → F)) = ell D :=
+  ((lSpaceEquivAdeleBddInfGlobal D).finrank_eq).symm
+
+def indexOfSpecialty (D : Divisor K F) : ℕ :=
+  Module.finrank K
+    ((adeleSpace K F) ⧸
+      ((adeleBdd D).comap (adeleSpace K F).subtype ⊔
+        (globalSub K F).comap (adeleSpace K F).subtype))
+
+theorem adeleBdd_directed :
+    Directed (· ≤ ·) (adeleBdd (K := K) (F := F)) := fun D E =>
+  ⟨D ⊔ E, adeleBdd_mono le_sup_left, adeleBdd_mono le_sup_right⟩
+
+theorem mem_adeleSpace_iff {α : Place K F → F} :
+    α ∈ adeleSpace K F ↔ ∃ D : Divisor K F, α ∈ adeleBdd D := by
+  unfold adeleSpace
+  exact Submodule.mem_iSup_of_directed _ adeleBdd_directed
+
+variable (K F) in
+abbrev adeleBddPrincipal (D : Divisor K F) : Submodule K (adeleSpace K F) :=
+  (adeleBdd D).comap (adeleSpace K F).subtype ⊔
+    (globalSub K F).comap (adeleSpace K F).subtype
+
+theorem indexOfSpecialty_eq (D : Divisor K F) :
+    indexOfSpecialty D = Module.finrank K (adeleSpace K F ⧸ adeleBddPrincipal K F D) := rfl
+
+def omegaSpace (D : Divisor K F) : Submodule K (Module.Dual K (adeleSpace K F)) :=
+  (adeleBddPrincipal K F D).dualAnnihilator
+
+theorem omegaSpace_vanishBdd {D : Divisor K F} {φ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace D) {α : adeleSpace K F} (hα : (α : Place K F → F) ∈ adeleBdd D) :
+    φ α = 0 :=
+  (Submodule.mem_dualAnnihilator φ).mp hφ α (Submodule.mem_sup_left hα)
+
+theorem omegaSpace_vanishGlobal {D : Divisor K F} {φ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace D) {α : adeleSpace K F} (hα : (α : Place K F → F) ∈ globalSub K F) :
+    φ α = 0 :=
+  (Submodule.mem_dualAnnihilator φ).mp hφ α (Submodule.mem_sup_right hα)
+
+theorem omegaSpace_antitone {D E : Divisor K F} (hDE : D ≤ E) :
+    omegaSpace E ≤ omegaSpace D :=
+  Submodule.dualAnnihilator_anti
+    (sup_le_sup_right (Submodule.comap_mono (adeleBdd_mono hDE)) _)
+
+def omegaSpaceEquivIndexDual (D : Divisor K F) :
+    omegaSpace D ≃ₗ[K] Module.Dual K (adeleSpace K F ⧸ adeleBddPrincipal K F D) :=
+  (Submodule.dualQuotEquivDualAnnihilator (adeleBddPrincipal K F D)).symm
+
+theorem finrank_omegaSpace_eq_indexOfSpecialty (D : Divisor K F) :
+    Module.finrank K (omegaSpace D) = indexOfSpecialty D := by
+  rw [indexOfSpecialty_eq, (omegaSpaceEquivIndexDual D).finrank_eq,
+    Subspace.dual_finrank_eq]
+
+variable (K F) in
+def weilDifferentialModule : Submodule K (Module.Dual K (adeleSpace K F)) :=
+  ⨆ D : Divisor K F, omegaSpace D
+
+theorem omegaSpace_le_weilDifferentialModule (D : Divisor K F) :
+    omegaSpace D ≤ weilDifferentialModule K F := le_iSup omegaSpace D
+
+theorem omegaSpace_directed :
+    Directed (· ≤ ·) (omegaSpace (K := K) (F := F)) := fun D E =>
+  ⟨D ⊓ E, omegaSpace_antitone inf_le_left, omegaSpace_antitone inf_le_right⟩
+
+theorem mem_weilDifferentialModule_iff {φ : Module.Dual K (adeleSpace K F)} :
+    φ ∈ weilDifferentialModule K F ↔ ∃ D : Divisor K F, φ ∈ omegaSpace D := by
+  unfold weilDifferentialModule
+  exact Submodule.mem_iSup_of_directed _ omegaSpace_directed
+
+variable (K) in
+def mulAdele (f : F) : (Place K F → F) →ₗ[K] (Place K F → F) where
+  toFun α := fun v => f * α v
+  map_add' α β := funext fun v => mul_add f (α v) (β v)
+  map_smul' c α := funext fun v => by
+    simp only [Pi.smul_apply, Algebra.smul_def, RingHom.id_apply]; ring
+
+@[simp]
+theorem mulAdele_apply (f : F) (α : Place K F → F) (v : Place K F) :
+    mulAdele K f α v = f * α v := rfl
+
+@[simp]
+theorem mulAdele_one : mulAdele K (1 : F) = LinearMap.id :=
+  LinearMap.ext fun α => funext fun v => one_mul (α v)
+
+theorem mulAdele_mul (f g : F) :
+    mulAdele K (f * g) = (mulAdele K f).comp (mulAdele K g) :=
+  LinearMap.ext fun α => funext fun v => mul_assoc f g (α v)
+
+theorem mulAdele_mem_adeleBdd_sub {f : F} (hf : f ≠ 0) {P : Divisor K F}
+    (hP : ∀ v, P v = v.ord f) {D : Divisor K F} {α : Place K F → F}
+    (hα : α ∈ adeleBdd D) : mulAdele K f α ∈ adeleBdd (D - P) := by
+  intro v
+  rw [mulAdele_apply, Valuation.map_mul, Finsupp.sub_apply, hP v,
+    show v.adicValuation f = WithZero.exp (-v.ord f) by
+      rw [Place.ord, neg_neg, WithZero.exp_log (v.adicValuation_ne_zero hf)]]
+  calc WithZero.exp (-v.ord f) * v.adicValuation (α v)
+      ≤ WithZero.exp (-v.ord f) * WithZero.exp (D v) := by gcongr; exact hα v
+    _ = WithZero.exp (D v - v.ord f) := by rw [← WithZero.exp_add]; ring_nf
+
+theorem mulAdele_globalSub_le (f : F) :
+    (globalSub K F).map (mulAdele K f) ≤ globalSub K F := by
+  rintro _ ⟨α, ⟨g, rfl⟩, rfl⟩
+  exact ⟨f * g, funext fun v => by simp⟩
+
+theorem mulAdele_mem_adeleSpace [HasPrincipalDivisors K F] (f : F) {α : Place K F → F}
+    (hα : α ∈ adeleSpace K F) : mulAdele K f α ∈ adeleSpace K F := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · have h0 : mulAdele K (0 : F) α = 0 := funext fun v => by simp
+    rw [h0]; exact (adeleSpace K F).zero_mem
+  · obtain ⟨D, hD⟩ := mem_adeleSpace_iff.mp hα
+    obtain ⟨P, hP, _⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf
+    exact adeleBdd_le_adeleSpace (D := D - P) (mulAdele_mem_adeleBdd_sub hf hP hD)
+
+variable (K F) in
+def adeleSpaceMul [HasPrincipalDivisors K F] (f : F) :
+    adeleSpace K F →ₗ[K] adeleSpace K F :=
+  (mulAdele K f).restrict fun _ => mulAdele_mem_adeleSpace f
+
+@[simp]
+theorem adeleSpaceMul_coe [HasPrincipalDivisors K F] (f : F) (α : adeleSpace K F) :
+    (adeleSpaceMul K F f α : Place K F → F) = mulAdele K f (α : Place K F → F) := rfl
+
+variable (K F) in
+def weilSmul [HasPrincipalDivisors K F] (f : F) :
+    Module.Dual K (adeleSpace K F) →ₗ[K] Module.Dual K (adeleSpace K F) :=
+  (adeleSpaceMul K F f).dualMap
+
+@[simp]
+theorem weilSmul_apply [HasPrincipalDivisors K F] (f : F)
+    (φ : Module.Dual K (adeleSpace K F)) (α : adeleSpace K F) :
+    weilSmul K F f φ α = φ (adeleSpaceMul K F f α) := rfl
+
+theorem adeleSpaceMul_one [HasPrincipalDivisors K F] :
+    adeleSpaceMul K F (1 : F) = LinearMap.id := by
+  refine LinearMap.ext fun α => Subtype.ext ?_
+  change mulAdele K (1 : F) (α : Place K F → F) = (α : Place K F → F)
+  rw [mulAdele_one, LinearMap.id_apply]
+
+theorem adeleSpaceMul_mul [HasPrincipalDivisors K F] (f g : F) :
+    adeleSpaceMul K F (f * g) = (adeleSpaceMul K F f).comp (adeleSpaceMul K F g) := by
+  refine LinearMap.ext fun α => Subtype.ext ?_
+  change mulAdele K (f * g) (α : Place K F → F) = mulAdele K f (mulAdele K g (α : Place K F → F))
+  rw [mulAdele_mul, LinearMap.comp_apply]
+
+@[simp]
+theorem weilSmul_one [HasPrincipalDivisors K F] :
+    weilSmul K F (1 : F) = LinearMap.id := by
+  unfold weilSmul; rw [adeleSpaceMul_one]; ext; simp
+
+theorem weilSmul_mul [HasPrincipalDivisors K F] (f g : F) :
+    weilSmul K F (f * g) = (weilSmul K F g).comp (weilSmul K F f) := by
+  unfold weilSmul; rw [adeleSpaceMul_mul, LinearMap.dualMap_comp_dualMap]
+
+theorem weilSmul_injective [HasPrincipalDivisors K F] {f : F} (hf : f ≠ 0) :
+    Function.Injective (weilSmul K F f) := by
+  apply Function.LeftInverse.injective (g := weilSmul K F f⁻¹)
+  intro φ
+  rw [← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hf, weilSmul_one,
+    LinearMap.id_apply]
+
+theorem weilSmul_mem_omegaSpace_add [HasPrincipalDivisors K F] {f : F} (hf : f ≠ 0)
+    {P : Divisor K F} (hP : ∀ v, P v = v.ord f) {D : Divisor K F}
+    {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ∈ omegaSpace D) :
+    weilSmul K F f φ ∈ omegaSpace (D + P) := by
+  rw [omegaSpace, Submodule.mem_dualAnnihilator]
+  intro α hα
+  obtain ⟨β, hβ, γ, hγ, rfl⟩ := Submodule.mem_sup.mp hα
+  rw [map_add, weilSmul_apply, weilSmul_apply]
+  have hβ' : (adeleSpaceMul K F f β : Place K F → F) ∈ adeleBdd D := by
+    rw [adeleSpaceMul_coe]
+    have h := mulAdele_mem_adeleBdd_sub hf hP (D := D + P) (Submodule.mem_comap.mp hβ)
+    rwa [add_sub_cancel_right] at h
+  have hγ' : (adeleSpaceMul K F f γ : Place K F → F) ∈ globalSub K F :=
+    mulAdele_globalSub_le f ⟨_, Submodule.mem_comap.mp hγ, rfl⟩
+  rw [omegaSpace_vanishBdd hφ hβ', omegaSpace_vanishGlobal hφ hγ', add_zero]
+
+theorem weilSmul_mem_omegaSpace_of_mem_lSpace [HasPrincipalDivisors K F]
+    {W D : Divisor K F} {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ∈ omegaSpace W)
+    {g : F} (hg : g ∈ LSpace (W - D)) :
+    weilSmul K F g φ ∈ omegaSpace D := by
+  rcases eq_or_ne g 0 with rfl | hg0
+  · have h0 : weilSmul K F (0 : F) φ = 0 := by
+      ext α; simp only [weilSmul_apply]
+      refine omegaSpace_vanishBdd hφ ?_
+      intro v
+      simp only [adeleSpaceMul_coe, mulAdele_apply, zero_mul, Valuation.map_zero]
+      exact zero_le
+    rw [h0]; exact (omegaSpace D).zero_mem
+  · obtain ⟨P, hPord, _⟩ := HasPrincipalDivisors.exists_divisor (K := K) g hg0
+    refine omegaSpace_antitone ?_ (weilSmul_mem_omegaSpace_add hg0 hPord hφ)
+    intro v
+    rw [Finsupp.add_apply, hPord v]
+    have hgL := (mem_lSpace_iff_ord.mp hg).resolve_left hg0 v
+    rw [Finsupp.sub_apply] at hgL
+    linarith
+
+variable (K F) in
+def residuePairing [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ∈ omegaSpace W) :
+    LSpace (W - D) →ₗ[K] omegaSpace D where
+  toFun g := ⟨weilSmul K F (g : F) φ, weilSmul_mem_omegaSpace_of_mem_lSpace hφ g.2⟩
+  map_add' g₁ g₂ := by
+    refine Subtype.ext ?_
+    change weilSmul K F ((g₁ : F) + (g₂ : F)) φ
+      = weilSmul K F (g₁ : F) φ + weilSmul K F (g₂ : F) φ
+    ext α; simp only [weilSmul_apply, LinearMap.add_apply]
+    rw [← map_add]; congr 1
+    exact Subtype.ext (funext fun v => by simp [add_mul])
+  map_smul' c g := by
+    refine Subtype.ext ?_
+    change weilSmul K F (c • (g : F)) φ = c • weilSmul K F (g : F) φ
+    ext α; simp only [weilSmul_apply, LinearMap.smul_apply]
+    rw [← map_smul]; congr 1
+    exact Subtype.ext (funext fun v => by simp [Algebra.smul_def]; ring)
+
+@[simp]
+theorem residuePairing_apply_coe [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ∈ omegaSpace W) (g : LSpace (W - D)) :
+    (residuePairing K F W D hφ g : Module.Dual K (adeleSpace K F))
+      = weilSmul K F (g : F) φ := rfl
+
+theorem residuePairing_injective [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ∈ omegaSpace W) (hφ0 : φ ≠ 0) :
+    Function.Injective (residuePairing K F W D hφ) := by
+  have hsub : ∀ g₁ g₂ : F, adeleSpaceMul K F (g₁ - g₂)
+      = adeleSpaceMul K F g₁ - adeleSpaceMul K F g₂ := fun g₁ g₂ => by
+    refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+    simp only [adeleSpaceMul_coe, mulAdele_apply, LinearMap.sub_apply,
+      Submodule.coe_sub, Pi.sub_apply, sub_mul]
+  intro g₁ g₂ hg
+  have hg' : weilSmul K F ((g₁ : F) - (g₂ : F)) φ = 0 := by
+    have h := congrArg Subtype.val hg
+    simp only [residuePairing_apply_coe] at h
+    ext α
+    simp only [weilSmul_apply, hsub, LinearMap.sub_apply, map_sub, LinearMap.zero_apply,
+      sub_eq_zero]
+    exact LinearMap.congr_fun h α
+  rcases eq_or_ne ((g₁ : F) - (g₂ : F)) 0 with hd | hd
+  · exact Subtype.ext (sub_eq_zero.mp hd)
+  · exact absurd (weilSmul_injective hd (by rw [hg', map_zero])) hφ0
+
+theorem ell_sub_le_indexOfSpecialty [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ∈ omegaSpace W) (hφ0 : φ ≠ 0)
+    [Module.Finite K (omegaSpace (K := K) (F := F) D)] :
+    ell (W - D) ≤ indexOfSpecialty D := by
+  rw [← finrank_omegaSpace_eq_indexOfSpecialty]
+  exact LinearMap.finrank_le_finrank_of_injective (residuePairing_injective W D hφ hφ0)
+
+variable (K F)
+
+def WeilDifferentialRankOne [HasPrincipalDivisors K F] : Prop :=
+  ∀ {φ : Module.Dual K (adeleSpace K F)}, φ ∈ weilDifferentialModule K F → φ ≠ 0 →
+    ∀ {μ : Module.Dual K (adeleSpace K F)}, μ ∈ weilDifferentialModule K F →
+      ∃! f : F, μ = weilSmul K F f φ
+
+def HasWeilCanonicalDivisor : Prop :=
+  ∀ {φ : Module.Dual K (adeleSpace K F)}, φ ∈ weilDifferentialModule K F → φ ≠ 0 →
+    ∃ W : Divisor K F, φ ∈ omegaSpace W ∧ ∀ D : Divisor K F, φ ∈ omegaSpace D → D ≤ W
+
+variable {K F}
+
+structure RiemannGenusReachedAt (γ : ℤ) (D₀ : Divisor K F) : Prop where
+  finite : FiniteDimensional K (LSpace D₀)
+  eq : Divisor.degree D₀ - (ell D₀ : ℤ) = γ - 1
+  isMax : ∀ D : Divisor K F, Divisor.degree D - (ell D : ℤ) ≤ γ - 1
+
+variable (K F) in
+def RiemannGenusReached (γ : ℤ) : Prop :=
+  Nonempty (Place K F) ∧ FiniteDimensional K (LSpace (0 : Divisor K F)) ∧
+    ∃ D₀ : Divisor K F, RiemannGenusReachedAt γ D₀
+
+variable (K F) in
+def StichtenothGenusExists : Prop :=
+  Nonempty (Place K F) ∧ FiniteDimensional K (LSpace (0 : Divisor K F)) ∧
+    ∃ (γ : ℤ) (D₀ : Divisor K F), RiemannGenusReachedAt γ D₀
+
+variable (K F) in
+def RiemannGenusBounded : Prop :=
+  ∃ γ : ℤ, ∀ D : Divisor K F, Divisor.degree D - (ell D : ℤ) ≤ γ
+
+variable (K F) in
+def IndexOfSpecialtyFinite : Prop :=
+  ∃ D₀ : Divisor K F, Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀)
+
+end AlgebraicCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_BaseChangeGalois.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_BaseChangeGalois.lean
new file mode 100644
index 0000000000..a07ee3e261
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_BaseChangeGalois.lean
@@ -0,0 +1,414 @@
+/-
+Based on Prove2Me node AlgebraicCurve_BaseChangeGalois
+(4937e59f-5449-57d3-a84a-11e8ddf1962b) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import Mathlib.Algebra.Ring.Action.End
+public import Mathlib.LinearAlgebra.Dimension.Finrank
+
+/-!
+# Semilinear automorphisms acting on places, divisors and Pic⁰-torsion
+
+Definition: `AlgebraicCurve_BaseChangeGalois` (`4937e59f-5449-57d3-a84a-11e8ddf1962b`), by Claude,
+2026-09-05.
+
+Fix fields $K \subseteq F$ (an algebra structure `algebraMap K F`, written $\iota$). The module
+defines `SemilinearAut K F` as the subgroup of $\mathrm{Aut}(F) \times \mathrm{Aut}(K)$ (ring
+automorphisms) consisting of those pairs $(\varphi,\tau)$ with $\varphi(\iota a) = \iota(\tau a)$
+for all $a \in K$: automorphisms of $F$ that stabilise the subfield $K$, each packaged with the
+automorphism of $K$ it induces. The projections are `toRingAut` and `baseAut`, with
+`commutes`/`smul_algebraMap` recording the defining identity, and $F$ is given the resulting
+`MulSemiringAction`, $g \cdot x = \mathrm{toRingAut}\,g\,(x)$. The monoid homomorphism `ofAlgAut`
+sends $\sigma \in F \simeq_{\text{alg}[K]} F$ to $(\sigma, 1)$.
+
+The rest transports this action along the divisor-theoretic constructions of the imported module,
+where a `Place K F` is a valuation subring $A \subseteq F$ containing $\iota(K)$, with $A \neq F$
+and $A$ a principal ideal ring (hence a discrete valuation ring), $v.\mathrm{ord}$ is the normalised
+valuation and $v.\deg = \operatorname{finrank}_K$ of the residue field. A place is moved by
+pointwise translation of its valuation subring; the four structure fields are re-verified,
+membership of $\iota(K)$ using `baseAut`, and principality by transporting along the ring
+isomorphism `smulValuationSubringEquiv` $A \simeq g \cdot A$. Then `ord_smul` gives $(g \cdot
+v).\mathrm{ord}(g \cdot f) = v.\mathrm{ord}(f)$ (proved from a uniformiser-times-unit
+factorisation), `smulResidueRingEquiv` is the induced isomorphism of residue fields, semilinear over
+`baseAut g`, and `deg_smul` deduces $\deg(g\cdot v) = \deg v$. Divisors carry the push-forward
+action (`Finsupp.mapDomain`), which preserves degree, the degree-zero subgroup and the subgroup of
+principal divisors, hence descends to $\mathrm{Pic}^0$. Finally $\mathrm{Pic}^0[n]$ (the
+$\mathbb{Z}$-torsion submodule killed by $n$) is shown stable, given its $\mathbb{Z}/n$-module
+structure and commuting scalars, and `torsionRep K F n` is the resulting homomorphism
+$\mathrm{SemilinearAut}(K,F) \to \operatorname{End}_{\mathbb{Z}/n}(\mathrm{Pic}^0[n])$.
+
+**Relation to Mathlib.** Mathlib has no notion of the semilinear automorphism group of a field
+extension, nor of the places, divisors and $\mathrm{Pic}^0$ used here; these are the project's own,
+assembled from Mathlib components (a `Subgroup` of `RingAut F × RingAut K`,
+`Finsupp.comapDistribMulAction`, `QuotientAddGroup.map`, `AddCommGroup.zmodModule`,
+`DistribMulAction.toModuleEnd`). The constructions parallel, and restrict along `ofAlgAut` to, the
+actions of $F \simeq_{\text{alg}[K]} F$ already defined in the divisor class group module.
+
+**Where it is used.** With $F$ a function field of a modular curve over an algebraically closed
+constant field $K$, `torsionRep` supplies the action on $\mathrm{Pic}^0[n]$ of automorphisms that
+move the constants, which is the mechanism by which an absolute Galois group acts on the $n$-torsion
+of the Jacobian $J_0(N)$; composing a homomorphism into `SemilinearAut K F` with `torsionRep` yields
+the mod-$n$ Galois representations attached to modular Jacobians.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open IsLocalRing
+
+namespace AlgebraicCurve
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def SemilinearAut : Subgroup (RingAut F × RingAut K) where
+  carrier := {p | ∀ a : K, p.1 (algebraMap K F a) = algebraMap K F (p.2 a)}
+  one_mem' _ := rfl
+  mul_mem' := fun {p q} hp hq a => by
+    change p.1 (q.1 (algebraMap K F a)) = algebraMap K F (p.2 (q.2 a))
+    rw [hq a, hp (q.2 a)]
+  inv_mem' := fun {p} hp a => by
+    change p.1.symm (algebraMap K F a) = algebraMap K F (p.2.symm a)
+    apply p.1.injective
+    rw [RingEquiv.apply_symm_apply, hp (p.2.symm a), RingEquiv.apply_symm_apply]
+
+namespace SemilinearAut
+
+variable {K F}
+
+theorem mem_iff {p : RingAut F × RingAut K} :
+    p ∈ SemilinearAut K F ↔ ∀ a : K, p.1 (algebraMap K F a) = algebraMap K F (p.2 a) :=
+  Iff.rfl
+
+def toRingAut (g : SemilinearAut K F) : F ≃+* F := g.val.1
+
+def baseAut (g : SemilinearAut K F) : K ≃+* K := g.val.2
+
+theorem commutes (g : SemilinearAut K F) (a : K) :
+    toRingAut g (algebraMap K F a) = algebraMap K F (baseAut g a) :=
+  g.prop a
+
+@[simp] theorem toRingAut_one : toRingAut (1 : SemilinearAut K F) = 1 := rfl
+
+@[simp] theorem baseAut_one : baseAut (1 : SemilinearAut K F) = 1 := rfl
+
+@[simp] theorem toRingAut_mul (g h : SemilinearAut K F) :
+    toRingAut (g * h) = toRingAut g * toRingAut h := rfl
+
+@[simp] theorem baseAut_mul (g h : SemilinearAut K F) :
+    baseAut (g * h) = baseAut g * baseAut h := rfl
+
+@[simp] theorem toRingAut_inv (g : SemilinearAut K F) :
+    toRingAut g⁻¹ = (toRingAut g).symm := rfl
+
+@[simp] theorem baseAut_inv (g : SemilinearAut K F) :
+    baseAut g⁻¹ = (baseAut g).symm := rfl
+
+instance : MulSemiringAction (SemilinearAut K F) F where
+  smul g x := toRingAut g x
+  one_smul _ := rfl
+  mul_smul _ _ _ := rfl
+  smul_zero g := map_zero (toRingAut g)
+  smul_add g := map_add (toRingAut g)
+  smul_one g := map_one (toRingAut g)
+  smul_mul g := map_mul (toRingAut g)
+
+@[simp]
+theorem smul_def (g : SemilinearAut K F) (x : F) : g • x = toRingAut g x := rfl
+
+theorem inv_smul_def (g : SemilinearAut K F) (x : F) : g⁻¹ • x = (toRingAut g).symm x := rfl
+
+theorem smul_algebraMap (g : SemilinearAut K F) (a : K) :
+    g • algebraMap K F a = algebraMap K F (baseAut g a) :=
+  commutes g a
+
+def ofAlgAut : (F ≃ₐ[K] F) →* SemilinearAut K F where
+  toFun σ := ⟨((σ : F ≃+* F), 1), fun a => by simp⟩
+  map_one' := Subtype.ext (by ext <;> rfl)
+  map_mul' σ τ := Subtype.ext (by ext <;> rfl)
+
+@[simp]
+theorem toRingAut_ofAlgAut (σ : F ≃ₐ[K] F) : toRingAut (ofAlgAut σ) = (σ : F ≃+* F) := rfl
+
+@[simp]
+theorem baseAut_ofAlgAut (σ : F ≃ₐ[K] F) : baseAut (ofAlgAut σ) = 1 := rfl
+
+@[simp]
+theorem ofAlgAut_smul (σ : F ≃ₐ[K] F) (x : F) : ofAlgAut σ • x = σ x := rfl
+
+end SemilinearAut
+
+namespace SemilinearAut
+
+open scoped Pointwise
+
+variable {K F}
+variable (g : SemilinearAut K F)
+
+theorem pointwise_smul_top : g • (⊤ : ValuationSubring F) = ⊤ := by
+  ext x
+  simp only [ValuationSubring.mem_pointwise_smul_iff_inv_smul_mem]
+  exact ⟨fun _ => ValuationSubring.mem_top x, fun _ => ValuationSubring.mem_top _⟩
+
+def smulValuationSubringEquiv (A : ValuationSubring F) :
+    A ≃+* (g • A : ValuationSubring F) where
+  toFun x := ⟨g • (x : F), ValuationSubring.smul_mem_pointwise_smul g (x : F) A x.2⟩
+  invFun y := ⟨g⁻¹ • (y : F),
+    (ValuationSubring.mem_pointwise_smul_iff_inv_smul_mem (g := g) (S := A)
+      (x := (y : F))).mp y.2⟩
+  left_inv x := by ext; simp
+  right_inv y := by ext; simp
+  map_mul' x y := by ext; simp
+  map_add' x y := by ext; simp
+
+@[simp]
+theorem coe_smulValuationSubringEquiv_apply (A : ValuationSubring F) (x : A) :
+    ((smulValuationSubringEquiv g A x : (g • A : ValuationSubring F)) : F) = g • (x : F) :=
+  rfl
+
+instance : SMul (SemilinearAut K F) (Place K F) where
+  smul g v :=
+    { toValuationSubring := g • v.toValuationSubring
+      algebraMap_mem' := fun a => by
+        have h := ValuationSubring.smul_mem_pointwise_smul g
+          (algebraMap K F ((baseAut g).symm a)) v.toValuationSubring
+          (v.algebraMap_mem' ((baseAut g).symm a))
+        rwa [smul_algebraMap, RingEquiv.apply_symm_apply] at h
+      ne_top' := fun h => v.ne_top' <| by
+        have h2 := congrArg (g⁻¹ • ·) h
+        simpa [pointwise_smul_top] using h2
+      isPrincipalIdealRing' :=
+        IsPrincipalIdealRing.of_surjective
+          (smulValuationSubringEquiv g v.toValuationSubring : _ ≃+* _)
+          (smulValuationSubringEquiv g v.toValuationSubring).surjective }
+
+variable (v : Place K F)
+
+@[simp]
+theorem smul_toValuationSubring : (g • v).toValuationSubring = g • v.toValuationSubring :=
+  rfl
+
+instance : MulAction (SemilinearAut K F) (Place K F) where
+  one_smul v := by
+    ext1
+    rw [smul_toValuationSubring, one_smul]
+  mul_smul g h v := by
+    ext1
+    simp only [smul_toValuationSubring]
+    rw [mul_smul]
+
+theorem ord_smul (f : F) : (g • v).ord (g • f) = v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ
+  set n := v.ord f with hn
+  set e := smulValuationSubringEquiv g v.toValuationSubring with he
+  have hπ' : Irreducible (e π) := (MulEquiv.irreducible_iff e).mpr hπ
+  have hu' : IsUnit (e (u : v.toValuationSubring)) := u.isUnit.map e
+  have hcoeu : ((hu'.unit : (g • v).toValuationSubring) : F)
+      = toRingAut g ((u : v.toValuationSubring) : F) := by
+    rw [IsUnit.unit_spec]
+    rfl
+  have hcoeπ : ((e π : (g • v).toValuationSubring) : F) = toRingAut g (π : F) := rfl
+  have key : toRingAut g f = ((hu'.unit : (g • v).toValuationSubring) : F)
+      * (((e π : (g • v).toValuationSubring) : F) ^ n) := by
+    rw [hcoeu, hcoeπ, hu, map_mul, map_zpow₀]
+  rw [show g • f = toRingAut g f from rfl, key,
+    (g • v).ord_unit_smul_zpow hu'.unit hπ' n]
+
+def smulResidueRingEquiv : v.ResidueField ≃+* (g • v).ResidueField :=
+  IsLocalRing.ResidueField.mapEquiv (smulValuationSubringEquiv g v.toValuationSubring)
+
+theorem smulResidueRingEquiv_algebraMap (a : K) :
+    smulResidueRingEquiv g v (algebraMap K v.ResidueField a)
+      = algebraMap K (g • v).ResidueField (baseAut g a) := by
+  have h3 : (smulValuationSubringEquiv g v.toValuationSubring)
+        (algebraMap K v.toValuationSubring a)
+      = algebraMap K (g • v).toValuationSubring (baseAut g a) := by
+    ext
+    rw [coe_smulValuationSubringEquiv_apply, Place.coe_algebraMap, smul_algebraMap]
+    exact (Place.coe_algebraMap (g • v) (baseAut g a)).symm
+  change IsLocalRing.ResidueField.mapEquiv _ (IsLocalRing.residue _ _) = IsLocalRing.residue _ _
+  rw [IsLocalRing.ResidueField.mapEquiv_apply, IsLocalRing.ResidueField.map_residue]
+  exact congrArg _ h3
+
+@[simp]
+theorem deg_smul : (g • v).deg = v.deg := by
+  refine (Algebra.finrank_eq_of_equiv_equiv (baseAut g) (smulResidueRingEquiv g v) ?_).symm
+  ext a
+  simpa using (smulResidueRingEquiv_algebraMap g v a).symm
+
+end SemilinearAut
+
+namespace SemilinearAut
+
+open scoped Pointwise
+
+variable {K F}
+
+instance : DistribMulAction (SemilinearAut K F) (Divisor K F) :=
+  Finsupp.comapDistribMulAction
+
+theorem divisor_smul_def (g : SemilinearAut K F) (D : Divisor K F) :
+    g • D = Finsupp.mapDomain (g • ·) D := rfl
+
+@[simp]
+theorem smul_single (g : SemilinearAut K F) (v : Place K F) (n : ℤ) :
+    g • Finsupp.single v n = Finsupp.single (g • v) n := by
+  rw [divisor_smul_def, Finsupp.mapDomain_single]
+
+theorem divisor_smul_apply_smul (g : SemilinearAut K F) (D : Divisor K F) (v : Place K F) :
+    (g • D) (g • v) = D v := by
+  rw [divisor_smul_def]
+  exact Finsupp.mapDomain_apply_of_injective (MulAction.injective g) D v
+
+theorem divisor_smul_apply (g : SemilinearAut K F) (D : Divisor K F) (w : Place K F) :
+    (g • D) w = D (g⁻¹ • w) := by
+  have : (g • D) (g • (g⁻¹ • w)) = D (g⁻¹ • w) := divisor_smul_apply_smul g D (g⁻¹ • w)
+  rwa [smul_inv_smul] at this
+
+@[simp]
+theorem degree_smul (g : SemilinearAut K F) (D : Divisor K F) :
+    Divisor.degree (g • D) = Divisor.degree D := by
+  induction D using Finsupp.induction with
+  | zero => simp
+  | single_add v n D _ _ ih =>
+      rw [smul_add, map_add, map_add, ih, smul_single, Divisor.degree_single,
+        Divisor.degree_single, deg_smul]
+
+theorem smul_mem_degZero (g : SemilinearAut K F) {D : Divisor K F}
+    (hD : D ∈ Divisor.degZero (K := K) (F := F)) :
+    g • D ∈ Divisor.degZero (K := K) (F := F) := by
+  rwa [Divisor.mem_degZero, degree_smul]
+
+theorem smul_mem_principal (g : SemilinearAut K F) {D : Divisor K F}
+    (hD : D ∈ Divisor.principal (K := K) (F := F)) :
+    g • D ∈ Divisor.principal (K := K) (F := F) := by
+  obtain ⟨f, hf, hD⟩ := hD
+  refine ⟨g • f, by simpa using hf, fun w => ?_⟩
+  rw [divisor_smul_apply, hD (g⁻¹ • w)]
+  have h := ord_smul g (g⁻¹ • w) f
+  rw [smul_inv_smul] at h
+  exact h.symm
+
+def degZeroSMulHom (g : SemilinearAut K F) :
+    Divisor.degZero (K := K) (F := F) →+ Divisor.degZero (K := K) (F := F) :=
+  ((DistribSMul.toAddMonoidHom (Divisor K F) g).domRestrict
+    (Divisor.degZero (K := K) (F := F))).codRestrict _
+    (fun D => smul_mem_degZero g D.2)
+
+@[simp]
+theorem coe_degZeroSMulHom (g : SemilinearAut K F) (D : Divisor.degZero (K := K) (F := F)) :
+    (degZeroSMulHom g D : Divisor K F) = g • (D : Divisor K F) := rfl
+
+instance : SMul (SemilinearAut K F) (Pic0 K F) where
+  smul g := QuotientAddGroup.map _ _ (degZeroSMulHom g) (by
+    rintro ⟨D, hD0⟩ hD
+    simp only [AddSubgroup.mem_addSubgroupOf] at hD ⊢
+    exact smul_mem_principal g hD)
+
+theorem pic0_smul_mk (g : SemilinearAut K F) (D : Divisor.degZero (K := K) (F := F)) :
+    g • (Pic0.mk D) = Pic0.mk (degZeroSMulHom g D) := rfl
+
+instance : DistribMulAction (SemilinearAut K F) (Pic0 K F) where
+  one_smul x := by
+    obtain ⟨D, rfl⟩ := Pic0.mk_surjective x
+    rw [pic0_smul_mk]
+    exact congrArg Pic0.mk (Subtype.ext (by rw [coe_degZeroSMulHom, one_smul]))
+  mul_smul g h x := by
+    obtain ⟨D, rfl⟩ := Pic0.mk_surjective x
+    rw [pic0_smul_mk, pic0_smul_mk, pic0_smul_mk]
+    exact congrArg Pic0.mk (Subtype.ext (by simp only [coe_degZeroSMulHom]; rw [mul_smul]))
+  smul_zero g := by
+    change g • Pic0.mk 0 = Pic0.mk 0
+    rw [pic0_smul_mk]
+    exact congrArg Pic0.mk (map_zero _)
+  smul_add g x y := by
+    obtain ⟨D, rfl⟩ := Pic0.mk_surjective x
+    obtain ⟨E, rfl⟩ := Pic0.mk_surjective y
+    change g • Pic0.mk (D + E) = Pic0.mk (degZeroSMulHom g D) + Pic0.mk (degZeroSMulHom g E)
+    rw [pic0_smul_mk]
+    exact congrArg Pic0.mk (map_add _ _ _)
+
+end SemilinearAut
+
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+
+namespace SemilinearAut
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem smul_zsmul (g : SemilinearAut K F) (m : ℤ) (x : Pic0 K F) :
+    g • (m • x) = m • (g • x) :=
+  map_zsmul (DistribSMul.toAddMonoidHom (Pic0 K F) g) m x
+
+theorem smul_mem_torsion (g : SemilinearAut K F) {n : ℕ} {x : Pic0 K F}
+    (hx : x ∈ Pic0.torsion K F n) : g • x ∈ Pic0.torsion K F n := by
+  rw [Pic0.mem_torsion] at hx ⊢
+  rw [← smul_zsmul, hx]
+  exact smul_zero (A := Pic0 K F) g
+
+instance instSMulTorsion (n : ℕ) : SMul (SemilinearAut K F) (Pic0.torsion K F n) :=
+  ⟨fun g x => ⟨g • (x : Pic0 K F), smul_mem_torsion g x.property⟩⟩
+
+@[simp]
+theorem coe_torsion_smul {n : ℕ} (g : SemilinearAut K F) (x : Pic0.torsion K F n) :
+    ((g • x : Pic0.torsion K F n) : Pic0 K F) = g • (x : Pic0 K F) := rfl
+
+instance instDistribMulActionTorsion (n : ℕ) :
+    DistribMulAction (SemilinearAut K F) (Pic0.torsion K F n) where
+  one_smul x := Subtype.ext <| one_smul _ (x : Pic0 K F)
+  mul_smul g h x := Subtype.ext <| mul_smul g h (x : Pic0 K F)
+  smul_zero g := Subtype.ext <| smul_zero (A := Pic0 K F) g
+  smul_add g x y := Subtype.ext <| smul_add g (x : Pic0 K F) (y : Pic0 K F)
+
+end SemilinearAut
+
+namespace Pic0
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+instance instModuleZModTorsion (n : ℕ) : Module (ZMod n) (torsion K F n) :=
+  AddCommGroup.zmodModule fun x => by
+    apply Subtype.ext
+    change ((n • x : torsion K F n) : Pic0 K F) = 0
+    rw [AddSubgroupClass.coe_nsmul, ← Nat.cast_smul_eq_nsmul ℤ n (x : Pic0 K F)]
+    exact mem_torsion.mp x.property
+
+end Pic0
+
+namespace SemilinearAut
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+instance instSMulCommClassZModTorsion (n : ℕ) :
+    SMulCommClass (SemilinearAut K F) (ZMod n) (Pic0.torsion K F n) where
+  smul_comm g c x :=
+    ZMod.map_smul (DistribSMul.toAddMonoidHom (Pic0.torsion K F n) g) c x
+
+variable (K F) in
+def torsionRep (n : ℕ) : SemilinearAut K F →* Module.End (ZMod n) (Pic0.torsion K F n) :=
+  DistribMulAction.toModuleEnd (ZMod n) (Pic0.torsion K F n)
+
+@[simp]
+theorem torsionRep_apply {n : ℕ} (g : SemilinearAut K F) (x : Pic0.torsion K F n) :
+    torsionRep K F n g x = g • x := rfl
+
+end SemilinearAut
+
+end AlgebraicCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_CanonicalDivisor.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_CanonicalDivisor.lean
new file mode 100644
index 0000000000..7cb17d9736
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_CanonicalDivisor.lean
@@ -0,0 +1,95 @@
+/-
+Based on Prove2Me node AlgebraicCurve_CanonicalDivisor
+(cc2db6a8-1239-5e80-8950-f16390156697) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CanonicalDivisor
+
+/-!
+# Canonical divisor, canonical class and genus of a function field
+
+Definition: `AlgebraicCurve_CanonicalDivisor` (`cc2db6a8-1239-5e80-8950-f16390156697`), by Claude,
+2026-09-05.
+
+Throughout, $F/K$ is an extension of fields and $\Omega[F\!\restriction\!K]$ denotes Mathlib's
+module of Kähler differentials. Places, divisors and the Picard group are those of the project's
+divisor-class formalism: a place $v$ is a proper valuation subring of $F$ containing the image of
+$K$ whose ideals are principal, a divisor is a finitely supported function $\mathrm{Place}\,K\,F \to
+\mathbb{Z}$, $\mathrm{Pic}\,K\,F$ is the quotient of the divisor group by the subgroup of principal
+divisors, and $\deg$ sends $v$ to $[\,$residue field of $v : K\,]$. For a differential $\omega$,
+$v.\mathrm{ordDifferential}\,\omega$ is $\mathrm{ord}_v$ of the coefficient of $\omega$ with respect
+to the differential $d\pi_v$ of a chosen uniformiser at $v$ (and $\mathrm{ord}_v 0 = 0$ by
+convention).
+
+The class `HasCanonicalDivisor` is a Prop-valued hypothesis class carrying one field: for every
+$\omega \neq 0$ there exists a divisor $D$ with $D(v) = v.\mathrm{ordDifferential}\,\omega$ at every
+place $v$ — that is, the family $(\mathrm{ord}_v \omega)_v$ has finite support. Under this
+assumption, `canonicalDivisorOf` extracts such a divisor from a proof that $\omega \neq 0$, and
+`canonicalDivisorOf_apply` records its defining property $(\omega)(v) =
+v.\mathrm{ordDifferential}\,\omega$.
+
+`canonicalClass K F` is the image in $\mathrm{Pic}\,K\,F$ of the canonical divisor of a chosen
+nonzero differential, and is $0$ when $\Omega[F\!\restriction\!K]$ vanishes. `genus K F` is the
+natural number $\bigl\lfloor (\deg(\omega) + 2)^{+}/2 \bigr\rfloor$ for that same chosen $\omega$
+(truncation of the integer to $\mathbb{N}$ followed by natural-number division by $2$), and $0$ when
+there is no nonzero differential; it inverts the relation $\deg(\omega) = 2g-2$. Independence of
+`canonicalClass` and `genus` of the chosen $\omega$ is not asserted here.
+
+**Relation to Mathlib.** The module of Kähler differentials is Mathlib's; places, divisors, degrees
+and the Picard group are the project's own, and the canonical divisor, canonical class and genus of
+a function field have no Mathlib counterpart. The existence of the canonical divisor is taken here
+as a hypothesis class rather than proved.
+
+**Where it is used.** These definitions supply the canonical class and the genus in the
+function-field language used for modular curves, where the genus and the degree of the canonical
+divisor enter the Riemann–Roch-type estimates of the modular-curve development.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open KaehlerDifferential
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+class HasCanonicalDivisor : Prop where
+  exists_divisor : ∀ ω : Ω[F⁄K], ω ≠ 0 → ∃ D : Divisor K F,
+    ∀ v : Place K F, D v = v.ordDifferential ω
+
+def canonicalDivisorOf [HasCanonicalDivisor (K := K) (F := F)]
+    {ω : Ω[F⁄K]} (hω : ω ≠ 0) : Divisor K F :=
+  (HasCanonicalDivisor.exists_divisor ω hω).choose
+
+theorem canonicalDivisorOf_apply [HasCanonicalDivisor (K := K) (F := F)]
+    {ω : Ω[F⁄K]} (hω : ω ≠ 0) (v : Place K F) :
+    canonicalDivisorOf hω v = v.ordDifferential ω :=
+  (HasCanonicalDivisor.exists_divisor ω hω).choose_spec v
+
+def canonicalClass (K F : Type*) [Field K] [Field F] [Algebra K F]
+    [HasCanonicalDivisor (K := K) (F := F)] : Pic K F :=
+  letI := Classical.propDecidable
+  if h : ∃ ω : Ω[F⁄K], ω ≠ 0 then QuotientAddGroup.mk (canonicalDivisorOf h.choose_spec)
+  else 0
+
+def genus (K F : Type*) [Field K] [Field F] [Algebra K F]
+    [HasCanonicalDivisor (K := K) (F := F)] : ℕ :=
+  letI := Classical.propDecidable
+  if h : ∃ ω : Ω[F⁄K], ω ≠ 0
+  then (Divisor.degree (canonicalDivisorOf h.choose_spec) + 2).toNat / 2
+  else 0
+
+end AlgebraicCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_CanonicalLocalResidueInstanceV2.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_CanonicalLocalResidueInstanceV2.lean
new file mode 100644
index 0000000000..83cc60ce28
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_CanonicalLocalResidueInstanceV2.lean
@@ -0,0 +1,1867 @@
+/-
+Based on Prove2Me node AlgebraicCurve_CanonicalLocalResidueInstanceV2
+(df2a3fdb-1fe8-5809-bd7a-e60e44fefcde) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.GroupWithZero.Submonoid.CancelMulZero
+public import Mathlib.RingTheory.AdicCompletion.LocalRing
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_LocalResidue
+
+/-!
+# Local residues at places: pole filtration, canonical data, sections
+
+Definition: `AlgebraicCurve_CanonicalLocalResidueInstanceV2`
+(`df2a3fdb-1fe8-5809-bd7a-e60e44fefcde`), by Claude, 2026-09-05.
+
+For a field extension $F/K$ and a place $v$ of $F/K$ (a valuation subring with principal maximal
+ideal containing $K$), the module builds residue maps and the structures they require. A
+distinguished irreducible element `uniformizerSubring` of $\mathcal O_v$ lifting `v.uniformizer` is
+fixed, and the pole filtration is defined: `poleSubmodule n` is the $K$-submodule $\{f\in F : \pi^n
+f\in\mathcal O_v\}$, equal to $\mathcal O_v$ for $n=0$, to `simplePoleSubmodule` for $n=1$,
+characterised by $-n\le\operatorname{ord}_v f$ for $f\neq0$, monotone in $n$ with supremum $F$;
+`laurentTailCoeff n` is the $K$-linear map sending $f$ to the residue class of $\pi^n f$ in
+$\kappa(v)$. On the simple-pole submodule the residue $f\mapsto \overline{\pi f}$ is defined
+outright; `localResidueExtend` is a chosen $K$-linear extension of it to $F$, which yields a
+`LocalResidueData` and hence the unconditional instance `HasLocalResidue K F`. Subtracting
+`higherPoleCorrection` — a linear map vanishing on `poleSubmodule 1` and matching the extension on
+the classes of $\pi^{-(m+2)}$, which are linearly independent modulo `poleSubmodule 1` — produces a
+`CanonicalLocalResidueDataK`, i.e. a residue vanishing on $\mathcal O_v$, equal to $\overline{\pi
+f}$ on simple poles and zero on $\pi^{-(n+1)}$ for $n\ge 1$; this gives the instance
+`HasCanonicalLocalResidueK K F`. Two such data agree on all pole submodules when $K\to\kappa(v)$ is
+surjective. For larger residue fields, `CoefficientFieldSection` is a $K$-algebra map
+$\kappa(v)\to\mathcal O_v$ splitting the residue map, `CanonicalLocalResidueDataS \sigma` adds
+vanishing on $\sigma(a)\pi^{-(n+1)}$, $n\ge 1$, and such data again agree on pole submodules. A
+parallel development replaces $\mathcal O_v$ by its adic completion $\widehat{\mathcal O}_v$: the
+level-one evaluation `lg37_residueHat` onto $\kappa(v)$ is surjective with kernel the maximal ideal,
+the completion is Henselian and local, separable monic polynomials lift roots from $\kappa(v)$
+uniquely, `Lg37CompletionSection` records a $K$-algebra section of `lg37_residueHat`, one such
+section is obtained from a primitive element of $\kappa(v)/K$ together with a lifted root of its
+minimal polynomial, and every element has a unique truncated Taylor expansion
+$\sum_{i<n}\sigma(a_i)\pi^i$ modulo $\mathfrak m^n$. Auxiliary instances provide the residue-field
+algebra and tower structure for the restriction of a place along $F\subseteq F'$, and the
+nonvanishing of $\operatorname{Tr}_{\kappa(v)/K}$ (`HasSeparableResidue`) when $K$ is perfect and
+all residue fields are finite over $K$.
+
+**Relation to Mathlib.** The residue data structures, the pole filtration, the coefficient-field and
+completion sections are the project's own notions; they are built on Mathlib's `AdicCompletion`,
+`HenselianLocalRing`/`HenselianRing`, `IsLocalRing.ResidueField` and discrete valuation ring
+machinery. Mathlib has no Cohen coefficient-field theorem, which is why sections are introduced as
+data here.
+
+**Where it is used.** These constructions discharge the `HasLocalResidue`,
+`HasCanonicalLocalResidueK` and `HasSeparableResidue` hypotheses carried by the project's
+residue-theorem and Riemann–Roch development for function fields of curves, which in turn underlies
+the treatment of modular curves in the modularity part of the argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+instance HasSeparableResidue.of_perfectField [PerfectField K]
+    [∀ v : Place K F, v.FiniteResidue] : HasSeparableResidue K F where
+  trace_ne_zero v :=
+    haveI : Module.Finite K v.ResidueField := Place.FiniteResidue.finite
+    Algebra.trace_ne_zero K v.ResidueField
+
+instance HasSeparableResidue.of_perfectField_of_isCurveOver [PerfectField K]
+    [IsCurveOver K F] : HasSeparableResidue K F :=
+  HasSeparableResidue.of_perfectField
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing
+open scoped Polynomial
+
+namespace AlgebraicCurve
+
+namespace Place
+
+section DegPos
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+theorem finiteResidue_of_deg_pos (h : 0 < v.deg) : v.FiniteResidue :=
+  ⟨Module.finite_of_finrank_pos h⟩
+
+end DegPos
+
+end Place
+
+namespace Place
+
+section Restrict
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F'] [Algebra F F'] [Algebra K F] [IsScalarTower K F F']
+  [Algebra.IsIntegral F F'] (w : Place K F')
+
+def restrictSubringHom : (w.restrict F).toValuationSubring →+* w.toValuationSubring :=
+  RingHom.codRestrict
+    ((algebraMap F F').comp (w.restrict F).toValuationSubring.subtype)
+    w.toValuationSubring.toSubring
+    fun x => x.2
+
+instance instIsLocalHom_restrictSubringHom : IsLocalHom (w.restrictSubringHom (F := F)) := by
+  constructor
+  intro a ha
+  obtain ⟨b, hb⟩ := isUnit_iff_exists_inv.mp ha
+  have hb' : algebraMap F F' (a : F) * (b : F') = 1 := by
+    exact congrArg Subtype.val hb
+  have ha0 : (a : F) ≠ 0 := by
+    rintro h0
+    rw [h0, map_zero, zero_mul] at hb'
+    exact zero_ne_one hb'
+  have hbeq : (b : F') = algebraMap F F' (a : F)⁻¹ := by
+    rw [map_inv₀]
+    exact eq_inv_of_mul_eq_one_right (by linear_combination hb')
+  have hmem : (a : F)⁻¹ ∈ (w.restrict F).toValuationSubring := by
+    change algebraMap F F' (a : F)⁻¹ ∈ w.toValuationSubring
+    exact hbeq ▸ b.2
+  exact isUnit_iff_exists_inv.mpr
+    ⟨⟨(a : F)⁻¹, hmem⟩, Subtype.ext (mul_inv_cancel₀ ha0)⟩
+
+def residueFieldMapRestrict : (w.restrict F).ResidueField →+* w.ResidueField :=
+  IsLocalRing.ResidueField.map (w.restrictSubringHom (F := F))
+
+instance instAlgebra_restrictResidueField : Algebra (w.restrict F).ResidueField w.ResidueField :=
+  (w.residueFieldMapRestrict (F := F)).toAlgebra
+
+theorem algebraMap_residueField_residue (x : (w.restrict F).toValuationSubring) :
+    algebraMap (w.restrict F).ResidueField w.ResidueField
+        (IsLocalRing.residue _ x)
+      = IsLocalRing.residue _ (w.restrictSubringHom x) :=
+  IsLocalRing.ResidueField.map_residue _ _
+
+instance instIsScalarTower_restrictResidueField :
+    IsScalarTower K (w.restrict F).ResidueField w.ResidueField := by
+  refine IsScalarTower.of_algebraMap_eq fun a => ?_
+  change IsLocalRing.residue _ (algebraMap K w.toValuationSubring a)
+      = algebraMap (w.restrict F).ResidueField w.ResidueField
+          (IsLocalRing.residue _ (algebraMap K (w.restrict F).toValuationSubring a))
+  rw [algebraMap_residueField_residue]
+  congr 1
+  ext
+  change algebraMap K F' a = algebraMap F F' (algebraMap K F a)
+  rw [IsScalarTower.algebraMap_apply K F F']
+
+end Restrict
+
+end Place
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open IsDedekindDomain WithZero Module IsLocalRing
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable (v : Place K F)
+
+def uniformizerSubring : v.toValuationSubring :=
+  (IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose
+
+@[simp]
+theorem coe_uniformizerSubring : (v.uniformizerSubring : F) = v.uniformizer := rfl
+
+theorem irreducible_uniformizerSubring : Irreducible v.uniformizerSubring :=
+  (IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose_spec
+
+theorem uniformizerSubring_mem_maximalIdeal :
+    v.uniformizerSubring ∈ IsLocalRing.maximalIdeal v.toValuationSubring :=
+  (IsLocalRing.mem_maximalIdeal _).mpr v.irreducible_uniformizerSubring.not_isUnit
+
+theorem uniformizer_mem : v.uniformizer ∈ v.toValuationSubring :=
+  v.uniformizerSubring.2
+
+def simplePoleSubmodule : Submodule K F where
+  carrier := {f | v.uniformizer * f ∈ v.toValuationSubring}
+  add_mem' {f g} hf hg := by
+    simpa only [Set.mem_ofPred_eq, mul_add] using add_mem hf hg
+  zero_mem' := by simpa only [Set.mem_ofPred_eq, mul_zero] using zero_mem _
+  smul_mem' c f hf := by
+    change v.uniformizer * (c • f) ∈ v.toValuationSubring
+    rw [Algebra.smul_def, mul_left_comm]
+    exact mul_mem (v.algebraMap_mem' c) hf
+
+@[simp]
+theorem mem_simplePoleSubmodule {f : F} :
+    f ∈ v.simplePoleSubmodule ↔ v.uniformizer * f ∈ v.toValuationSubring := Iff.rfl
+
+theorem mem_simplePoleSubmodule_of_mem {f : F} (hf : f ∈ v.toValuationSubring) :
+    f ∈ v.simplePoleSubmodule :=
+  mul_mem v.uniformizer_mem hf
+
+def simplePoleMulUniformizer : v.simplePoleSubmodule →ₗ[K] v.toValuationSubring where
+  toFun f := ⟨v.uniformizer * f.1, f.2⟩
+  map_add' f g := Subtype.ext (mul_add _ _ _)
+  map_smul' c f := Subtype.ext <| by
+    change v.uniformizer * ((c • f : v.simplePoleSubmodule) : F)
+        = ((c • ⟨v.uniformizer * f.1, f.2⟩ : v.toValuationSubring) : F)
+    simp only [Algebra.smul_def, MulMemClass.coe_mul, v.coe_algebraMap, Submodule.coe_smul,
+      mul_left_comm]
+
+def simplePoleResidueAux : v.simplePoleSubmodule →ₗ[K] v.ResidueField :=
+  (Ideal.Quotient.mkₐ K (IsLocalRing.maximalIdeal v.toValuationSubring)).toLinearMap
+    ∘ₗ v.simplePoleMulUniformizer
+
+theorem simplePoleResidueAux_apply (f : v.simplePoleSubmodule) :
+    v.simplePoleResidueAux f = IsLocalRing.residue _ ⟨v.uniformizer * f.1, f.2⟩ := rfl
+
+theorem simplePoleResidueAux_eq_zero_of_mem {f : F} (hf : f ∈ v.toValuationSubring) :
+    v.simplePoleResidueAux ⟨f, v.mem_simplePoleSubmodule_of_mem hf⟩ = 0 := by
+  rw [simplePoleResidueAux_apply, IsLocalRing.residue_eq_zero_iff]
+  have hmul : (⟨v.uniformizer * f, mul_mem v.uniformizer_mem hf⟩ : v.toValuationSubring)
+      = v.uniformizerSubring * ⟨f, hf⟩ := Subtype.ext rfl
+  rw [hmul]
+  exact Ideal.mul_mem_right _ _ v.uniformizerSubring_mem_maximalIdeal
+
+def localResidueExtend : F →ₗ[K] v.ResidueField :=
+  v.simplePoleResidueAux.exists_extend.choose
+
+theorem localResidueExtend_apply_of_mem {f : F} (hf : f ∈ v.simplePoleSubmodule) :
+    v.localResidueExtend f = v.simplePoleResidueAux ⟨f, hf⟩ :=
+  congrArg (fun φ => φ (⟨f, hf⟩ : v.simplePoleSubmodule))
+    v.simplePoleResidueAux.exists_extend.choose_spec
+
+def localResidueDataOfExtend : v.LocalResidueData where
+  res := v.localResidueExtend
+  res_of_mem f hf := by
+    rw [v.localResidueExtend_apply_of_mem (v.mem_simplePoleSubmodule_of_mem hf),
+      v.simplePoleResidueAux_eq_zero_of_mem hf]
+  res_simplePole f hf := by
+    rw [v.localResidueExtend_apply_of_mem hf, simplePoleResidueAux_apply]
+
+end Place
+
+instance instHasLocalResidue : HasLocalResidue K F where
+  exists_data v := ⟨v.localResidueDataOfExtend⟩
+
+variable [HasCanonicalLocalResidueKStar K F]
+
+theorem gate_hasLocalResidue_uniformizer_inv (v : Place K F) :
+    v.localResidue v.uniformizer⁻¹ = 1 :=
+  v.gate_localResidue_uniformizer_inv
+
+omit [HasCanonicalLocalResidueKStar K F] in
+theorem gate_uniformizer_inv_mem_simplePoleSubmodule (v : Place K F) :
+    v.uniformizer⁻¹ ∈ v.simplePoleSubmodule ∧ v.uniformizer⁻¹ ∉ v.toValuationSubring := by
+  refine ⟨?_, ?_⟩
+  · rw [Place.mem_simplePoleSubmodule, mul_inv_cancel₀ v.uniformizer_ne_zero]
+    exact one_mem _
+  · intro hmem
+    have h0 := v.ord_nonneg_of_mem hmem
+    rw [v.ord_inv, v.ord_uniformizer] at h0
+    omega
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open IsDedekindDomain WithZero Module IsLocalRing
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable (v : Place K F)
+
+def poleSubmodule (n : ℕ) : Submodule K F where
+  carrier := {f | v.uniformizer ^ n * f ∈ v.toValuationSubring}
+  add_mem' {f g} hf hg := by
+    simpa only [Set.mem_ofPred_eq, mul_add] using add_mem hf hg
+  zero_mem' := by simpa only [Set.mem_ofPred_eq, mul_zero] using zero_mem _
+  smul_mem' c f hf := by
+    change v.uniformizer ^ n * (c • f) ∈ v.toValuationSubring
+    rw [Algebra.smul_def, mul_left_comm]
+    exact mul_mem (v.algebraMap_mem' c) hf
+
+@[simp]
+theorem mem_poleSubmodule {n : ℕ} {f : F} :
+    f ∈ v.poleSubmodule n ↔ v.uniformizer ^ n * f ∈ v.toValuationSubring := Iff.rfl
+
+theorem uniformizer_pow_ne_zero (n : ℕ) : (v.uniformizer ^ n : F) ≠ 0 :=
+  pow_ne_zero n v.uniformizer_ne_zero
+
+theorem ord_uniformizer_pow (n : ℕ) : v.ord (v.uniformizer ^ n) = (n : ℤ) := by
+  rw [show (v.uniformizer ^ n : F) = v.uniformizer ^ (n : ℤ) from (zpow_natCast _ n).symm,
+    v.ord_zpow, v.ord_uniformizer, mul_one]
+
+theorem coe_poleSubmodule_zero :
+    (v.poleSubmodule 0 : Set F) = (v.toValuationSubring : Set F) := by
+  ext f; simp [mem_poleSubmodule]
+
+@[simp]
+theorem poleSubmodule_one : v.poleSubmodule 1 = v.simplePoleSubmodule := by
+  ext f; simp [mem_poleSubmodule, mem_simplePoleSubmodule]
+
+theorem mem_poleSubmodule_iff_ord {n : ℕ} {f : F} (hf : f ≠ 0) :
+    f ∈ v.poleSubmodule n ↔ -(n : ℤ) ≤ v.ord f := by
+  rw [mem_poleSubmodule, v.mem_iff_ord_nonneg (mul_ne_zero (v.uniformizer_pow_ne_zero n) hf),
+    v.ord_mul (v.uniformizer_pow_ne_zero n) hf, v.ord_uniformizer_pow]
+  omega
+
+theorem poleSubmodule_mono : Monotone v.poleSubmodule := by
+  intro m n hmn f hf
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact zero_mem _
+  · rw [v.mem_poleSubmodule_iff_ord hf0] at hf ⊢
+    have : -(n : ℤ) ≤ -(m : ℤ) := by exact_mod_cast neg_le_neg (Nat.cast_le.mpr hmn)
+    omega
+
+theorem iSup_poleSubmodule_eq_top : ⨆ n, v.poleSubmodule n = ⊤ := by
+  rw [eq_top_iff]
+  intro f _
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact Submodule.mem_iSup_of_mem 0 (zero_mem _)
+  · refine Submodule.mem_iSup_of_mem (-v.ord f).toNat ?_
+    rw [v.mem_poleSubmodule_iff_ord hf0]
+    have h := Int.self_le_toNat (-v.ord f)
+    omega
+
+def poleMulUniformizerPow (n : ℕ) : v.poleSubmodule n →ₗ[K] v.toValuationSubring where
+  toFun f := ⟨v.uniformizer ^ n * f.1, f.2⟩
+  map_add' f g := Subtype.ext (mul_add _ _ _)
+  map_smul' c f := Subtype.ext <| by
+    change v.uniformizer ^ n * ((c • f : v.poleSubmodule n) : F)
+        = ((c • ⟨v.uniformizer ^ n * f.1, f.2⟩ : v.toValuationSubring) : F)
+    simp only [Algebra.smul_def, MulMemClass.coe_mul, v.coe_algebraMap, Submodule.coe_smul,
+      mul_left_comm]
+
+def laurentTailCoeff (n : ℕ) : v.poleSubmodule n →ₗ[K] v.ResidueField :=
+  (Ideal.Quotient.mkₐ K (IsLocalRing.maximalIdeal v.toValuationSubring)).toLinearMap
+    ∘ₗ v.poleMulUniformizerPow n
+
+theorem laurentTailCoeff_apply {n : ℕ} (f : v.poleSubmodule n) :
+    v.laurentTailCoeff n f = IsLocalRing.residue _ ⟨v.uniformizer ^ n * f.1, f.2⟩ := rfl
+
+theorem coe_mul_uniformizer_pow_inv_mem_poleSubmodule {n : ℕ} (c : v.toValuationSubring) :
+    (c : F) * (v.uniformizer ^ n)⁻¹ ∈ v.poleSubmodule n := by
+  rw [mem_poleSubmodule, mul_left_comm, mul_inv_cancel₀ (v.uniformizer_pow_ne_zero n), mul_one]
+  exact c.2
+
+theorem laurentTail_remainder_mem_poleSubmodule {n : ℕ} {f : F}
+    (hf : f ∈ v.poleSubmodule (n + 1)) {c : v.toValuationSubring}
+    (hc : IsLocalRing.residue _ c = v.laurentTailCoeff (n + 1) ⟨f, hf⟩) :
+    f - (c : F) * (v.uniformizer ^ (n + 1))⁻¹ ∈ v.poleSubmodule n := by
+  set a : v.toValuationSubring := ⟨v.uniformizer ^ (n + 1) * f, hf⟩ with ha_def
+  have hmem : a - c ∈ IsLocalRing.maximalIdeal v.toValuationSubring := by
+    rw [← IsLocalRing.residue_eq_zero_iff, map_sub, hc, laurentTailCoeff_apply, sub_self]
+  rw [v.irreducible_uniformizerSubring.maximalIdeal_eq, Ideal.mem_span_singleton] at hmem
+  obtain ⟨d, hd⟩ := hmem
+  rw [mem_poleSubmodule]
+  have hcoe : v.uniformizer ^ (n + 1) * f - (c : F) = v.uniformizer * (d : F) := by
+    have h := congrArg (Subtype.val) hd
+    push_cast [coe_uniformizerSubring] at h
+    exact h
+  have hkey : v.uniformizer ^ n * (f - (c : F) * (v.uniformizer ^ (n + 1))⁻¹) = (d : F) := by
+    refine mul_left_cancel₀ v.uniformizer_ne_zero ?_
+    calc v.uniformizer * (v.uniformizer ^ n * (f - (c : F) * (v.uniformizer ^ (n + 1))⁻¹))
+        = v.uniformizer ^ (n + 1) * f
+            - (c : F) * (v.uniformizer ^ (n + 1) * (v.uniformizer ^ (n + 1))⁻¹) := by ring
+      _ = v.uniformizer ^ (n + 1) * f - (c : F) := by
+          rw [mul_inv_cancel₀ (v.uniformizer_pow_ne_zero (n + 1)), mul_one]
+      _ = v.uniformizer * (d : F) := hcoe
+  rw [hkey]
+  exact d.2
+
+theorem localResidueData_agree_on_simplePole (R₁ R₂ : v.LocalResidueData) {f : F}
+    (hf : f ∈ v.simplePoleSubmodule) : R₁.res f = R₂.res f := by
+  rw [R₁.res_simplePole f hf, R₂.res_simplePole f hf]
+
+theorem localResidueData_res_eq_simplePoleResidueAux (R : v.LocalResidueData) {f : F}
+    (hf : f ∈ v.simplePoleSubmodule) : R.res f = v.simplePoleResidueAux ⟨f, hf⟩ := by
+  rw [R.res_simplePole f hf, simplePoleResidueAux_apply]
+
+end Place
+
+theorem gate_poleSubmodule_strictMono (v : Place K F) (n : ℕ) :
+    (v.uniformizer ^ (n + 1))⁻¹ ∈ v.poleSubmodule (n + 1) ∧
+      (v.uniformizer ^ (n + 1))⁻¹ ∉ v.poleSubmodule n := by
+  refine ⟨?_, ?_⟩
+  · rw [Place.mem_poleSubmodule, mul_inv_cancel₀ (v.uniformizer_pow_ne_zero (n + 1))]
+    exact one_mem _
+  · rw [v.mem_poleSubmodule_iff_ord (inv_ne_zero (v.uniformizer_pow_ne_zero (n + 1))),
+      v.ord_inv, v.ord_uniformizer_pow]
+    omega
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open IsDedekindDomain WithZero Module IsLocalRing
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable (v : Place K F)
+
+theorem exists_mem_poleSubmodule (f : F) : ∃ n, f ∈ v.poleSubmodule n := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact ⟨0, zero_mem _⟩
+  · refine ⟨(-v.ord f).toNat, ?_⟩
+    rw [v.mem_poleSubmodule_iff_ord hf0]
+    have h := Int.self_le_toNat (-v.ord f)
+    omega
+
+theorem laurentTailCoeff_coe_mul_uniformizer_pow_inv {n : ℕ} (c : v.toValuationSubring) :
+    v.laurentTailCoeff (n + 1)
+        ⟨(c : F) * (v.uniformizer ^ (n + 1))⁻¹,
+          v.coe_mul_uniformizer_pow_inv_mem_poleSubmodule c⟩
+      = IsLocalRing.residue _ c := by
+  rw [laurentTailCoeff_apply]
+  congr 1
+  exact Subtype.ext <| by
+    change v.uniformizer ^ (n + 1) * ((c : F) * (v.uniformizer ^ (n + 1))⁻¹) = (c : F)
+    rw [mul_left_comm, mul_inv_cancel₀ (v.uniformizer_pow_ne_zero (n + 1)), mul_one]
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open IsDedekindDomain WithZero Module IsLocalRing
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable (v : Place K F)
+
+theorem uniformizer_mul_uniformizer_sq_inv :
+    (v.uniformizer : F) * (v.uniformizer ^ 2)⁻¹ = v.uniformizer⁻¹ := by
+  rw [sq, mul_inv, ← mul_assoc, mul_inv_cancel₀ v.uniformizer_ne_zero, one_mul]
+
+end Place
+
+namespace Place
+
+variable (v : Place K F)
+
+theorem CanonicalLocalResidueDataK.res_algebraMap_mul_uniformizer_pow_inv
+    (R : v.CanonicalLocalResidueDataK) {n : ℕ} (hn : 1 ≤ n) (c : K) :
+    R.res ((algebraMap K F c) * (v.uniformizer ^ (n + 1))⁻¹) = 0 := by
+  have h : (algebraMap K F c) * (v.uniformizer ^ (n + 1))⁻¹
+      = c • (v.uniformizer ^ (n + 1))⁻¹ := (Algebra.smul_def c _).symm
+  rw [h, map_smul, R.res_higherPoleMonomial n hn, smul_zero]
+
+theorem CanonicalLocalResidueDataK.res_laurentRecK (R : v.CanonicalLocalResidueDataK)
+    {n : ℕ} (hn : 1 ≤ n) (f : F) (c : K) :
+    R.res (f - (algebraMap K F c) * (v.uniformizer ^ (n + 1))⁻¹) = R.res f := by
+  rw [map_sub, R.res_algebraMap_mul_uniformizer_pow_inv v hn c, sub_zero]
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open IsDedekindDomain WithZero Module IsLocalRing
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable (v : Place K F)
+
+theorem uniformizer_pow_inv_mem_poleSubmodule_self (m : ℕ) :
+    (v.uniformizer ^ (m + 2))⁻¹ ∈ v.poleSubmodule (m + 2) :=
+  (gate_poleSubmodule_strictMono v (m + 1)).1
+
+theorem higherPoleMonomial_sum_mem_poleSubmodule {s : Finset ℕ} {N : ℕ}
+    (hs : ∀ m ∈ s, m < N) (c : ℕ → K) :
+    ∑ m ∈ s, c m • (v.uniformizer ^ (m + 2))⁻¹ ∈ v.poleSubmodule (N + 1) :=
+  Submodule.sum_mem _ fun m hm =>
+    Submodule.smul_mem _ _ <|
+      v.poleSubmodule_mono (by have := hs m hm; omega)
+        (v.uniformizer_pow_inv_mem_poleSubmodule_self m)
+
+theorem higherPoleMonomial_coeff_eq_zero_of_mem (s : Finset ℕ) (c : ℕ → K)
+    (hmem : ∑ m ∈ s, c m • (v.uniformizer ^ (m + 2))⁻¹ ∈ v.poleSubmodule 1) :
+    ∀ m ∈ s, c m = 0 := by
+  induction s using Finset.induction_on_max with
+  | empty => intro m hm; exact absurd hm (Finset.notMem_empty m)
+  | insert N s hN ih =>
+    have hNs : N ∉ s := fun h => absurd (hN N h) (lt_irrefl N)
+    rw [Finset.sum_insert hNs] at hmem
+    have hrest : ∑ m ∈ s, c m • (v.uniformizer ^ (m + 2))⁻¹ ∈ v.poleSubmodule (N + 1) :=
+      v.higherPoleMonomial_sum_mem_poleSubmodule hN c
+    have hwhole := v.poleSubmodule_mono (Nat.one_le_iff_ne_zero.mpr (Nat.succ_ne_zero N)) hmem
+    have htop : c N • (v.uniformizer ^ (N + 2))⁻¹ ∈ v.poleSubmodule (N + 1) := by
+      have hsub := (v.poleSubmodule (N + 1)).sub_mem hwhole hrest
+      rwa [add_sub_cancel_right] at hsub
+    have hcN : c N = 0 := by
+      by_contra hcN
+      exact (gate_poleSubmodule_strictMono v (N + 1)).2 <|
+        (inv_smul_smul₀ hcN ((v.uniformizer ^ (N + 2))⁻¹)) ▸
+          (v.poleSubmodule (N + 1)).smul_mem (c N)⁻¹ htop
+    intro m hm
+    rcases Finset.mem_insert.mp hm with rfl | hm'
+    · exact hcN
+    · refine ih ?_ m hm'
+      rwa [hcN, zero_smul, zero_add] at hmem
+
+theorem linearIndependent_higherPoleMonomial_mkQ :
+    LinearIndependent K
+      (fun m : ℕ => (v.poleSubmodule 1).mkQ ((v.uniformizer ^ (m + 2))⁻¹)) := by
+  rw [linearIndependent_iff']
+  intro s c hsum m hm
+  refine v.higherPoleMonomial_coeff_eq_zero_of_mem s c ?_ m hm
+  have h := hsum
+  simp only [← map_smul, ← map_sum] at h
+  rwa [Submodule.mkQ_apply, Submodule.Quotient.mk_eq_zero] at h
+
+def higherPoleCorrectionAux :
+    Submodule.span K
+        (Set.range fun m : ℕ => (v.poleSubmodule 1).mkQ ((v.uniformizer ^ (m + 2))⁻¹))
+      →ₗ[K] v.ResidueField :=
+  (Basis.span v.linearIndependent_higherPoleMonomial_mkQ).constr K
+    (fun m => v.localResidueExtend ((v.uniformizer ^ (m + 2))⁻¹))
+
+def higherPoleCorrection : F →ₗ[K] v.ResidueField :=
+  v.higherPoleCorrectionAux.exists_extend.choose ∘ₗ (v.poleSubmodule 1).mkQ
+
+theorem higherPoleCorrection_apply_of_mem {f : F} (hf : f ∈ v.poleSubmodule 1) :
+    v.higherPoleCorrection f = 0 := by
+  unfold higherPoleCorrection
+  rw [LinearMap.comp_apply, Submodule.mkQ_apply, (Submodule.Quotient.mk_eq_zero _).mpr hf,
+    map_zero]
+
+theorem higherPoleCorrection_uniformizer_pow_inv (m : ℕ) :
+    v.higherPoleCorrection ((v.uniformizer ^ (m + 2))⁻¹)
+      = v.localResidueExtend ((v.uniformizer ^ (m + 2))⁻¹) := by
+  have hmem : (v.poleSubmodule 1).mkQ ((v.uniformizer ^ (m + 2))⁻¹)
+      ∈ Submodule.span K
+          (Set.range fun m : ℕ => (v.poleSubmodule 1).mkQ ((v.uniformizer ^ (m + 2))⁻¹)) :=
+    Submodule.subset_span ⟨m, rfl⟩
+  have hext := DFunLike.congr_fun v.higherPoleCorrectionAux.exists_extend.choose_spec
+    ⟨(v.poleSubmodule 1).mkQ ((v.uniformizer ^ (m + 2))⁻¹), hmem⟩
+  refine hext.trans ?_
+  unfold higherPoleCorrectionAux
+  have hb := (Basis.span v.linearIndependent_higherPoleMonomial_mkQ).constr_basis K
+    (fun m => v.localResidueExtend ((v.uniformizer ^ (m + 2))⁻¹)) m
+  rwa [Basis.span_apply] at hb
+
+def canonicalLocalResidueDataKOfExtend : v.CanonicalLocalResidueDataK where
+  res := v.localResidueExtend - v.higherPoleCorrection
+  res_of_mem f hf := by
+    have h1 : f ∈ v.poleSubmodule 1 :=
+      v.poleSubmodule_one ▸ v.mem_simplePoleSubmodule_of_mem hf
+    rw [LinearMap.sub_apply, v.higherPoleCorrection_apply_of_mem h1, sub_zero,
+      v.localResidueExtend_apply_of_mem (v.mem_simplePoleSubmodule_of_mem hf),
+      v.simplePoleResidueAux_eq_zero_of_mem hf]
+  res_simplePole f hf := by
+    have h1 : f ∈ v.poleSubmodule 1 := v.poleSubmodule_one ▸ hf
+    rw [LinearMap.sub_apply, v.higherPoleCorrection_apply_of_mem h1, sub_zero,
+      v.localResidueExtend_apply_of_mem hf, simplePoleResidueAux_apply]
+  res_higherPoleMonomial n hn := by
+    obtain ⟨m, rfl⟩ := Nat.exists_eq_add_of_le hn
+    rw [show 1 + m + 1 = m + 2 from by omega, LinearMap.sub_apply,
+      v.higherPoleCorrection_uniformizer_pow_inv m, sub_self]
+
+end Place
+
+instance instHasCanonicalLocalResidueK : HasCanonicalLocalResidueK K F where
+  exists_data v := ⟨v.canonicalLocalResidueDataKOfExtend⟩
+
+namespace Place
+
+variable (v : Place K F)
+
+theorem canonicalLocalResidueDataK_agree_on_poleSubmodule_of_surj
+    (hsurj : Function.Surjective (algebraMap K v.ResidueField))
+    (R₁ R₂ : v.CanonicalLocalResidueDataK) (n : ℕ) {f : F} (hf : f ∈ v.poleSubmodule n) :
+    R₁.res f = R₂.res f := by
+  induction n generalizing f with
+  | zero =>
+    have hf' : f ∈ v.toValuationSubring := by
+      rwa [show f ∈ v.toValuationSubring ↔ (f ∈ (v.poleSubmodule 0 : Set F))
+        from (v.coe_poleSubmodule_zero ▸ Iff.rfl)]
+    rw [R₁.res_of_mem f hf', R₂.res_of_mem f hf']
+  | succ n ih =>
+    rcases Nat.lt_or_ge n 1 with hn | hn
+    · interval_cases n
+      exact v.localResidueData_agree_on_simplePole R₁.toLocalResidueData R₂.toLocalResidueData
+        (v.poleSubmodule_one ▸ hf)
+    · obtain ⟨c, hc⟩ := hsurj (v.laurentTailCoeff (n + 1) ⟨f, hf⟩)
+      have hclift : IsLocalRing.residue _ (algebraMap K v.toValuationSubring c)
+          = v.laurentTailCoeff (n + 1) ⟨f, hf⟩ := by
+        rw [← hc, IsScalarTower.algebraMap_apply K v.toValuationSubring v.ResidueField,
+          IsLocalRing.ResidueField.algebraMap_eq]
+      have hrem : f - (algebraMap K F c) * (v.uniformizer ^ (n + 1))⁻¹ ∈ v.poleSubmodule n := by
+        have := v.laurentTail_remainder_mem_poleSubmodule hf hclift
+        rwa [v.coe_algebraMap] at this
+      rw [← R₁.res_laurentRecK v hn f c, ← R₂.res_laurentRecK v hn f c, ih hrem]
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open IsDedekindDomain WithZero Module IsLocalRing
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable (v : Place K F)
+
+structure CoefficientFieldSection where
+  lift : v.ResidueField →ₐ[K] v.toValuationSubring
+  residue_lift : ∀ a, IsLocalRing.residue _ (lift a) = a
+
+structure CanonicalLocalResidueDataS (σ : v.CoefficientFieldSection)
+    extends v.LocalResidueData where
+  res_higherPoleSectionMonomial : ∀ (n : ℕ), 1 ≤ n → ∀ a : v.ResidueField,
+    res ((σ.lift a : F) * (v.uniformizer ^ (n + 1))⁻¹) = 0
+
+namespace CanonicalLocalResidueDataS
+
+variable {v} {σ : v.CoefficientFieldSection} (R : v.CanonicalLocalResidueDataS σ)
+
+theorem res_laurentRecS {n : ℕ} (hn : 1 ≤ n) (f : F) (a : v.ResidueField) :
+    R.res (f - (σ.lift a : F) * (v.uniformizer ^ (n + 1))⁻¹) = R.res f := by
+  rw [map_sub, R.res_higherPoleSectionMonomial n hn a, sub_zero]
+
+end CanonicalLocalResidueDataS
+
+theorem canonicalLocalResidueDataS_agree_on_poleSubmodule (σ : v.CoefficientFieldSection)
+    (R₁ R₂ : v.CanonicalLocalResidueDataS σ) (n : ℕ) {f : F} (hf : f ∈ v.poleSubmodule n) :
+    R₁.res f = R₂.res f := by
+  induction n generalizing f with
+  | zero =>
+    have hf' : f ∈ v.toValuationSubring := by
+      rwa [show f ∈ v.toValuationSubring ↔ (f ∈ (v.poleSubmodule 0 : Set F))
+        from (v.coe_poleSubmodule_zero ▸ Iff.rfl)]
+    rw [R₁.res_of_mem f hf', R₂.res_of_mem f hf']
+  | succ n ih =>
+    rcases Nat.lt_or_ge n 1 with hn | hn
+    · interval_cases n
+      exact v.localResidueData_agree_on_simplePole R₁.toLocalResidueData R₂.toLocalResidueData
+        (v.poleSubmodule_one ▸ hf)
+    · set a : v.ResidueField := v.laurentTailCoeff (n + 1) ⟨f, hf⟩ with ha_def
+      have hclift : IsLocalRing.residue _ (σ.lift a)
+          = v.laurentTailCoeff (n + 1) ⟨f, hf⟩ := σ.residue_lift a
+      have hrem : f - (σ.lift a : F) * (v.uniformizer ^ (n + 1))⁻¹ ∈ v.poleSubmodule n :=
+        v.laurentTail_remainder_mem_poleSubmodule hf hclift
+      rw [← R₁.res_laurentRecS hn f a, ← R₂.res_laurentRecS hn f a, ih hrem]
+
+def coefficientFieldSectionOfBijective
+    (hbij : Function.Bijective (algebraMap K v.ResidueField)) :
+    v.CoefficientFieldSection where
+  lift := (Algebra.ofId K v.toValuationSubring).comp
+    (AlgEquiv.ofBijective (Algebra.ofId K v.ResidueField) hbij).symm.toAlgHom
+  residue_lift a := by
+    simp only [AlgHom.coe_comp, Function.comp_apply]
+    set c : K := (AlgEquiv.ofBijective (Algebra.ofId K v.ResidueField) hbij).symm a with hc_def
+    change IsLocalRing.residue _ (algebraMap K v.toValuationSubring c) = a
+    rw [show IsLocalRing.residue _ (algebraMap K v.toValuationSubring c)
+          = algebraMap K v.ResidueField c from by
+        rw [IsScalarTower.algebraMap_apply K v.toValuationSubring v.ResidueField,
+          IsLocalRing.ResidueField.algebraMap_eq]]
+    exact (AlgEquiv.ofBijective (Algebra.ofId K v.ResidueField) hbij).apply_symm_apply a
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open IsDedekindDomain WithZero Module IsLocalRing
+
+namespace ModularCurve.Lg37
+
+open AlgebraicCurve
+
+section CompletionCarrier
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+abbrev lg37_completion (v : Place K F) : Type _ :=
+  AdicCompletion (IsLocalRing.maximalIdeal v.toValuationSubring) v.toValuationSubring
+
+def lg37_residueHat (v : Place K F) :
+    lg37_completion v →+* v.ResidueField :=
+  (AdicCompletion.evalOneₐ (IsLocalRing.maximalIdeal v.toValuationSubring)).toRingHom
+
+theorem lg37_residueHat_algebraMap (v : Place K F) (x : v.toValuationSubring) :
+    lg37_residueHat v
+        (algebraMap v.toValuationSubring (lg37_completion v) x)
+      = IsLocalRing.residue v.toValuationSubring x := rfl
+
+structure Lg37CompletionSection (v : Place K F) where
+  lift : v.ResidueField →ₐ[K] lg37_completion v
+  residueHat_lift : ∀ a, lg37_residueHat v (lift a) = a
+
+end CompletionCarrier
+
+end ModularCurve.Lg37
+
+end
+
+noncomputable section
+
+open IsDedekindDomain WithZero Module IsLocalRing Polynomial
+
+namespace Mp72a102T1
+
+open AlgebraicCurve
+open ModularCurve.Lg37
+
+open scoped Polynomial
+
+section Engine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+noncomputable abbrev mp72a102_t1_maximalIdealHat (v : Place K F) :
+    Ideal (lg37_completion v) :=
+  (IsLocalRing.maximalIdeal v.toValuationSubring).map
+    (algebraMap v.toValuationSubring (lg37_completion v))
+
+theorem mp72a102_t1_isScalarTower (v : Place K F) :
+    IsScalarTower K v.toValuationSubring (lg37_completion v) :=
+  IsScalarTower.of_algebraMap_eq fun _ => rfl
+
+theorem mp72a102_t1_isAdicComplete_maximalIdealHat (v : Place K F) :
+    IsAdicComplete (mp72a102_t1_maximalIdealHat v) (lg37_completion v) :=
+  (IsAdicComplete.map_algebraMap_iff (IsLocalRing.maximalIdeal v.toValuationSubring)
+      (lg37_completion v)).mpr
+    (AdicCompletion.isAdicComplete
+      (IsPrincipalIdealRing.principal
+        (IsLocalRing.maximalIdeal v.toValuationSubring)).fg)
+
+theorem mp72a102_t1_henselianRing_completion (v : Place K F) :
+    HenselianRing (lg37_completion v) (mp72a102_t1_maximalIdealHat v) :=
+  letI := mp72a102_t1_isAdicComplete_maximalIdealHat v
+  IsAdicComplete.henselianRing (lg37_completion v) (mp72a102_t1_maximalIdealHat v)
+
+theorem mp72a102_t1_maximalIdealHat_le_ker_residueHat (v : Place K F) :
+    mp72a102_t1_maximalIdealHat v ≤ RingHom.ker (lg37_residueHat v) :=
+  Ideal.map_le_iff_le_comap.mpr fun s hs => by
+    rw [Ideal.mem_comap, RingHom.mem_ker, lg37_residueHat_algebraMap]
+    exact (IsLocalRing.residue_eq_zero_iff s).mpr hs
+
+theorem mp72a102_t1_exists_completion_root_of_residue_root
+    (v : Place K F) {p : K[X]} (hpmon : p.Monic) (hpsep : p.Separable)
+    {rbar : v.ResidueField} (hrbar : Polynomial.aeval rbar p = 0) :
+    ∃ α : lg37_completion v,
+      Polynomial.aeval α p = 0 ∧ lg37_residueHat v α = rbar := by
+  classical
+  have _htower : IsScalarTower K v.toValuationSubring (lg37_completion v) :=
+    mp72a102_t1_isScalarTower v
+  obtain ⟨a, ha⟩ := IsLocalRing.residue_surjective (R := v.toValuationSubring) rbar
+  have hapI : Polynomial.aeval a p ∈ IsLocalRing.maximalIdeal v.toValuationSubring := by
+    rw [← IsLocalRing.residue_eq_zero_iff]
+    have h1 : IsLocalRing.residue v.toValuationSubring (Polynomial.aeval a p)
+        = Polynomial.aeval rbar p := by
+      rw [← ha, ← IsLocalRing.ResidueField.algebraMap_eq,
+        Polynomial.aeval_algebraMap_apply]
+    rw [h1, hrbar]
+  have hapIhat : Polynomial.aeval
+      (algebraMap v.toValuationSubring (lg37_completion v) a) p
+        ∈ mp72a102_t1_maximalIdealHat v := by
+    rw [Polynomial.aeval_algebraMap_apply]
+    exact Ideal.mem_map_of_mem _ hapI
+  have hfeval : ∀ x : lg37_completion v,
+      (p.map (algebraMap K (lg37_completion v))).eval x = Polynomial.aeval x p :=
+    fun x => by rw [Polynomial.eval_map, ← Polynomial.aeval_def]
+  have hfderiv :
+      (p.map (algebraMap K (lg37_completion v))).derivative.eval
+          (algebraMap v.toValuationSubring (lg37_completion v) a)
+        = Polynomial.aeval
+            (algebraMap v.toValuationSubring (lg37_completion v) a)
+            (Polynomial.derivative p) := by
+    rw [Polynomial.derivative_map, Polynomial.eval_map, ← Polynomial.aeval_def]
+  obtain ⟨u, w, huw⟩ := hpsep
+  have hunit : IsUnit (Ideal.Quotient.mk (mp72a102_t1_maximalIdealHat v)
+      ((p.map (algebraMap K (lg37_completion v))).derivative.eval
+        (algebraMap v.toValuationSubring (lg37_completion v) a))) := by
+    rw [hfderiv]
+    set a₀ := algebraMap v.toValuationSubring (lg37_completion v) a
+    have h1 : Polynomial.aeval a₀ u * Polynomial.aeval a₀ p
+        + Polynomial.aeval a₀ w * Polynomial.aeval a₀ (Polynomial.derivative p)
+        = 1 := by
+      have h0 := congrArg (Polynomial.aeval (R := K) a₀) huw
+      simpa only [map_add, map_mul, map_one] using h0
+    have h2 := congrArg (Ideal.Quotient.mk (mp72a102_t1_maximalIdealHat v)) h1
+    rw [map_add, map_mul, map_mul, map_one,
+      Ideal.Quotient.eq_zero_iff_mem.mpr hapIhat, mul_zero, zero_add] at h2
+    exact IsUnit.of_mul_eq_one _ ((mul_comm _ _).trans h2)
+  obtain ⟨α, hαroot, hαnear⟩ :=
+    (mp72a102_t1_henselianRing_completion v).is_henselian
+      (p.map (algebraMap K (lg37_completion v))) (hpmon.map _)
+      (algebraMap v.toValuationSubring (lg37_completion v) a)
+      (by rw [hfeval]; exact hapIhat) hunit
+  refine ⟨α, ?_, ?_⟩
+  · rw [← hfeval]
+    exact hαroot
+  · have h0 : lg37_residueHat v
+        (α - algebraMap v.toValuationSubring (lg37_completion v) a) = 0 :=
+      RingHom.mem_ker.mp (mp72a102_t1_maximalIdealHat_le_ker_residueHat v hαnear)
+    have heq : lg37_residueHat v α
+        = lg37_residueHat v
+            (algebraMap v.toValuationSubring (lg37_completion v) a) := by
+      rwa [map_sub, sub_eq_zero] at h0
+    rw [heq, lg37_residueHat_algebraMap, ha]
+
+end Engine
+
+end Mp72a102T1
+
+end
+
+noncomputable section
+
+open IsLocalRing Polynomial
+
+open scoped Polynomial
+
+namespace ModularCurve.Mp72a102T3
+
+open AlgebraicCurve ModularCurve.Lg37
+
+section General
+
+variable {R : Type*} [CommRing R] (I : Ideal R)
+
+theorem mp72a102_t3_evalₐ_zero_depth (z : AdicCompletion I R) :
+    AdicCompletion.evalₐ I 0 z = 0 := by
+  have : Subsingleton (R ⧸ (I ^ 0)) :=
+    Ideal.Quotient.subsingleton_iff.mpr (by rw [pow_zero, Ideal.one_eq_top])
+  exact Subsingleton.elim _ _
+
+theorem mp72a102_t3_evalₐ_algebraMap (n : ℕ) (r : R) :
+    AdicCompletion.evalₐ I n (algebraMap R (AdicCompletion I R) r)
+      = Ideal.Quotient.mk (I ^ n) r := by
+  rw [AdicCompletion.algebraMap_apply, Algebra.algebraMap_self, RingHom.id_apply,
+    AdicCompletion.evalₐ_of]
+
+theorem mp72a102_t3_evalₐ_factor {m n : ℕ} (hmn : m ≤ n) (z : AdicCompletion I R) :
+    Ideal.Quotient.factor (Ideal.pow_le_pow_right hmn) (AdicCompletion.evalₐ I n z)
+      = AdicCompletion.evalₐ I m z := by
+  obtain ⟨c, rfl⟩ := AdicCompletion.mk_surjective I R z
+  rw [AdicCompletion.evalₐ_mk, AdicCompletion.evalₐ_mk, Ideal.Quotient.factor_mk]
+  exact AdicCompletion.Ideal.mk_eq_mk I hmn c
+
+theorem mp72a102_t3_exists_rep_of_evalₐ_eq_zero {n : ℕ} {z : AdicCompletion I R}
+    (h : AdicCompletion.evalₐ I n z = 0) :
+    ∃ w ∈ I ^ n, AdicCompletion.evalₐ I (n + 1) z = Ideal.Quotient.mk (I ^ (n + 1)) w := by
+  obtain ⟨w, hw⟩ := Ideal.Quotient.mk_surjective (AdicCompletion.evalₐ I (n + 1) z)
+  refine ⟨w, ?_, hw.symm⟩
+  have hfac := mp72a102_t3_evalₐ_factor I (Nat.le_succ n) z
+  rw [← hw, Ideal.Quotient.factor_mk, h] at hfac
+  exact Ideal.Quotient.eq_zero_iff_mem.mp hfac
+
+theorem mp72a102_t3_evalₐ_succ_mul_eq_zero {n : ℕ} {r : R} (hr : r ∈ I)
+    {z : AdicCompletion I R} (h : AdicCompletion.evalₐ I n z = 0) :
+    AdicCompletion.evalₐ I (n + 1) (algebraMap R (AdicCompletion I R) r * z) = 0 := by
+  obtain ⟨w, hw, hwz⟩ := mp72a102_t3_exists_rep_of_evalₐ_eq_zero I h
+  rw [map_mul, mp72a102_t3_evalₐ_algebraMap, hwz, ← map_mul,
+    Ideal.Quotient.eq_zero_iff_mem, pow_succ']
+  exact Ideal.mul_mem_mul hr hw
+
+theorem mp72a102_t3_evalₐ_one_eq_zero_of_evalOneₐ {z : AdicCompletion I R}
+    (h : AdicCompletion.evalOneₐ I z = 0) : AdicCompletion.evalₐ I 1 z = 0 := by
+  obtain ⟨w, hw⟩ := Ideal.Quotient.mk_surjective (AdicCompletion.evalₐ I 1 z)
+  have hfac := AdicCompletion.factorₐ_evalₐ_one I z
+  rw [← hw, Ideal.Quotient.factor_mk, h] at hfac
+  rw [← hw, Ideal.Quotient.eq_zero_iff_mem, pow_one]
+  exact Ideal.Quotient.eq_zero_iff_mem.mp hfac
+
+end General
+
+section Carrier
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem mp72a102_t3_evalDepth_add (v : Place K F) (n : ℕ)
+    (x y : lg37_completion v) :
+    AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) n (x + y)
+      = AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) n x
+        + AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) n y :=
+  map_add _ x y
+
+theorem mp72a102_t3_evalDepth_mul (v : Place K F) (n : ℕ)
+    (x y : lg37_completion v) :
+    AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) n (x * y)
+      = AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) n x
+        * AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) n y :=
+  map_mul _ x y
+
+theorem mp72a102_t3_residueHat_congr_of_depth_one (v : Place K F)
+    {x y : lg37_completion v}
+    (h : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) 1 x
+        = AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) 1 y) :
+    lg37_residueHat v x = lg37_residueHat v y := by
+  change AdicCompletion.evalOneₐ (maximalIdeal v.toValuationSubring) x
+      = AdicCompletion.evalOneₐ (maximalIdeal v.toValuationSubring) y
+  rw [← AdicCompletion.factorₐ_evalₐ_one, ← AdicCompletion.factorₐ_evalₐ_one, h]
+
+theorem mp72a102_t3_evalDepth_one_eq_zero_of_residueHat (v : Place K F)
+    {x : lg37_completion v} (hx : lg37_residueHat v x = 0) :
+    AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) 1 x = 0 :=
+  mp72a102_t3_evalₐ_one_eq_zero_of_evalOneₐ _ hx
+
+theorem mp72a102_t3_eq_uniformizer_mul_of_mem_maximalIdeal (v : Place K F)
+    {w : v.toValuationSubring} (hw : w ∈ maximalIdeal v.toValuationSubring) :
+    ∃ u : v.toValuationSubring, w = v.uniformizerSubring * u := by
+  rw [v.irreducible_uniformizerSubring.maximalIdeal_eq, Ideal.mem_span_singleton] at hw
+  exact hw
+
+theorem mp72a102_t3_exists_uniformizer_factor (v : Place K F)
+    {x : lg37_completion v} (hx : lg37_residueHat v x = 0) (n : ℕ) :
+    ∃ u : v.toValuationSubring,
+      AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) n
+        (x - algebraMap v.toValuationSubring (lg37_completion v) v.uniformizerSubring
+          * algebraMap v.toValuationSubring (lg37_completion v) u) = 0 := by
+  rcases n with _ | n
+  · exact ⟨0, mp72a102_t3_evalₐ_zero_depth _ _⟩
+  · obtain ⟨w, hw⟩ := Ideal.Quotient.mk_surjective
+      (AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) (n + 1) x)
+    have h1 : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) 1 x = 0 :=
+      mp72a102_t3_evalDepth_one_eq_zero_of_residueHat v hx
+    have hfac := mp72a102_t3_evalₐ_factor (maximalIdeal v.toValuationSubring)
+      (Nat.one_le_iff_ne_zero.mpr (Nat.succ_ne_zero n)) x
+    rw [← hw, Ideal.Quotient.factor_mk, h1] at hfac
+    have hwm : w ∈ maximalIdeal v.toValuationSubring := by
+      have hmem := Ideal.Quotient.eq_zero_iff_mem.mp hfac
+      rwa [pow_one] at hmem
+    obtain ⟨u, hu⟩ := mp72a102_t3_eq_uniformizer_mul_of_mem_maximalIdeal v hwm
+    refine ⟨u, ?_⟩
+    rw [map_sub, map_mul, mp72a102_t3_evalₐ_algebraMap, mp72a102_t3_evalₐ_algebraMap,
+      ← map_mul, ← hu, ← hw, sub_self]
+
+theorem mp72a102_t3_sigma_taylor_expansion (v : Place K F)
+    (S : Lg37CompletionSection v) (n : ℕ) (x : lg37_completion v) :
+    ∃ a : ℕ → v.ResidueField,
+      AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) n
+        (x - ∑ i ∈ Finset.range n, S.lift (a i)
+          * algebraMap v.toValuationSubring (lg37_completion v)
+              v.uniformizerSubring ^ i) = 0 := by
+  induction n generalizing x with
+  | zero => exact ⟨fun _ => 0, mp72a102_t3_evalₐ_zero_depth _ _⟩
+  | succ n ih =>
+    have hres : lg37_residueHat v (x - S.lift (lg37_residueHat v x)) = 0 := by
+      rw [map_sub, S.residueHat_lift, sub_self]
+    obtain ⟨u, hu⟩ := mp72a102_t3_exists_uniformizer_factor v hres (n + 1)
+    obtain ⟨a, ha⟩ := ih (algebraMap v.toValuationSubring (lg37_completion v) u)
+    have hshift := mp72a102_t3_evalₐ_succ_mul_eq_zero
+      (maximalIdeal v.toValuationSubring) v.uniformizerSubring_mem_maximalIdeal ha
+    refine ⟨fun i => Nat.rec (motive := fun _ => v.ResidueField)
+      (lg37_residueHat v x) (fun j _ => a j) i, ?_⟩
+    rw [Finset.sum_range_succ']
+    change AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) (n + 1)
+        (x - ((∑ i ∈ Finset.range n, S.lift (a i)
+            * algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring ^ (i + 1))
+          + S.lift (lg37_residueHat v x)
+            * algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring ^ 0)) = 0
+    have hsum : ∑ i ∈ Finset.range n, S.lift (a i)
+          * algebraMap v.toValuationSubring (lg37_completion v)
+              v.uniformizerSubring ^ (i + 1)
+        = algebraMap v.toValuationSubring (lg37_completion v) v.uniformizerSubring
+          * ∑ i ∈ Finset.range n, S.lift (a i)
+            * algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring ^ i := by
+      rw [Finset.mul_sum]
+      exact Finset.sum_congr rfl fun i _ => by ring
+    rw [hsum, pow_zero, mul_one]
+    have hdecomp : x - (algebraMap v.toValuationSubring (lg37_completion v)
+            v.uniformizerSubring
+          * ∑ i ∈ Finset.range n, S.lift (a i)
+            * algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring ^ i
+          + S.lift (lg37_residueHat v x))
+        = (x - S.lift (lg37_residueHat v x)
+            - algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring
+              * algebraMap v.toValuationSubring (lg37_completion v) u)
+          + algebraMap v.toValuationSubring (lg37_completion v) v.uniformizerSubring
+            * (algebraMap v.toValuationSubring (lg37_completion v) u
+              - ∑ i ∈ Finset.range n, S.lift (a i)
+                * algebraMap v.toValuationSubring (lg37_completion v)
+                    v.uniformizerSubring ^ i) := by
+      ring
+    rw [hdecomp, map_add, hu, hshift, add_zero]
+
+end Carrier
+
+end ModularCurve.Mp72a102T3
+
+end
+
+noncomputable section
+
+open IsDedekindDomain WithZero Module IsLocalRing Polynomial
+
+namespace Mp72a102T2
+
+open AlgebraicCurve
+open ModularCurve.Lg37
+
+open scoped Polynomial
+
+section ResidueCalculus
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem mp72a102_t2_residueHat_algebraMap_base (v : Place K F) (c : K) :
+    lg37_residueHat v (algebraMap K (lg37_completion v) c)
+      = algebraMap K v.ResidueField c := by
+  have h : algebraMap K (lg37_completion v) c
+      = algebraMap v.toValuationSubring (lg37_completion v)
+          (algebraMap K v.toValuationSubring c) := rfl
+  rw [h, lg37_residueHat_algebraMap v]
+  rfl
+
+def mp72a102_t2_residueHatAlgHom (v : Place K F) :
+    lg37_completion v →ₐ[K] v.ResidueField where
+  toRingHom := lg37_residueHat v
+  commutes' := mp72a102_t2_residueHat_algebraMap_base v
+
+end ResidueCalculus
+
+end Mp72a102T2
+
+end
+
+open AlgebraicCurve ModularCurve.Lg37 Polynomial IntermediateField Mp72a102T1 Mp72a102T2
+
+namespace ModularCurve.KwNo6Section
+
+section GenericIso
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+noncomputable def residueFieldAdjoinRootEquiv {ᾱ : v.ResidueField} (hint : IsIntegral K ᾱ)
+    (htop : K⟮ᾱ⟯ = ⊤) :
+    AdjoinRoot (minpoly K ᾱ) ≃ₐ[K] v.ResidueField :=
+  (adjoinRootEquivAdjoin K hint).trans
+    ((IntermediateField.equivOfEq htop).trans IntermediateField.topEquiv)
+
+theorem residueFieldAdjoinRootEquiv_root {ᾱ : v.ResidueField} (hint : IsIntegral K ᾱ)
+    (htop : K⟮ᾱ⟯ = ⊤) :
+    residueFieldAdjoinRootEquiv v hint htop (AdjoinRoot.root (minpoly K ᾱ)) = ᾱ := by
+  have hgen := adjoinRootEquivAdjoin_apply_root K hint
+  simp only [residueFieldAdjoinRootEquiv, AlgEquiv.trans_apply, hgen]
+  exact AdjoinSimple.coe_gen K ᾱ
+
+end GenericIso
+
+section GenericSection
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+noncomputable def sectionOfPrimitiveRoot {ᾱ : v.ResidueField} (hint : IsIntegral K ᾱ)
+    (htop : K⟮ᾱ⟯ = ⊤) (αhat : lg37_completion v)
+    (hroot : (aeval αhat) (minpoly K ᾱ) = 0)
+    (hres : lg37_residueHat v αhat = ᾱ) :
+    Lg37CompletionSection v := by
+  have hroot' : (minpoly K ᾱ).eval₂ (Algebra.ofId K (lg37_completion v)) αhat = 0 := by
+    change (aeval αhat) (minpoly K ᾱ) = 0
+    exact hroot
+  refine
+    { lift := (AdjoinRoot.liftAlgHom (minpoly K ᾱ)
+        (Algebra.ofId K (lg37_completion v)) αhat hroot').comp
+          (residueFieldAdjoinRootEquiv v hint htop).symm.toAlgHom
+      residueHat_lift := ?_ }
+  intro a
+  have hres' : lg37_residueHat v αhat
+      = residueFieldAdjoinRootEquiv v hint htop (AdjoinRoot.root (minpoly K ᾱ)) :=
+    hres.trans (residueFieldAdjoinRootEquiv_root v hint htop).symm
+  have hkey : (mp72a102_t2_residueHatAlgHom v).comp
+        (AdjoinRoot.liftAlgHom (minpoly K ᾱ) (Algebra.ofId K (lg37_completion v)) αhat hroot')
+      = (residueFieldAdjoinRootEquiv v hint htop).toAlgHom := by
+    refine AdjoinRoot.algHom_ext ?_
+    rw [AlgHom.comp_apply, AdjoinRoot.liftAlgHom_root]
+    exact hres'
+  have h1 := DFunLike.congr_fun hkey ((residueFieldAdjoinRootEquiv v hint htop).symm a)
+  rw [AlgHom.comp_apply] at h1
+  have h2 : (residueFieldAdjoinRootEquiv v hint htop).toAlgHom
+      ((residueFieldAdjoinRootEquiv v hint htop).symm a) = a :=
+    (residueFieldAdjoinRootEquiv v hint htop).apply_symm_apply a
+  exact h1.trans h2
+
+end GenericSection
+
+end ModularCurve.KwNo6Section
+
+noncomputable section
+
+open IsDedekindDomain IsLocalRing Polynomial
+
+open scoped Polynomial
+
+namespace Mp72a103T2
+
+open AlgebraicCurve
+open ModularCurve.Lg37 ModularCurve.Mp72a102T3
+open Mp72a102T2
+
+section Calculus
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem mp72a103_t2_evalDepth_of_uniformizer_mul (v : Place K F) {n : ℕ}
+    {z : lg37_completion v}
+    (h : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) (n + 1)
+        (algebraMap v.toValuationSubring (lg37_completion v)
+            v.uniformizerSubring * z) = 0) :
+    AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) n z = 0 := by
+  obtain ⟨w, hw⟩ := Ideal.Quotient.mk_surjective
+    (AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) (n + 1) z)
+  rw [map_mul, mp72a102_t3_evalₐ_algebraMap, ← hw, ← map_mul,
+    Ideal.Quotient.eq_zero_iff_mem, v.irreducible_uniformizerSubring.maximalIdeal_eq,
+    Ideal.span_singleton_pow, Ideal.mem_span_singleton] at h
+  obtain ⟨u, hu⟩ := h
+  have hw' : v.uniformizerSubring * w
+      = v.uniformizerSubring * (v.uniformizerSubring ^ n * u) := by
+    rw [hu, pow_succ', mul_assoc]
+  have hcancel : w = v.uniformizerSubring ^ n * u :=
+    mul_left_cancel₀ v.irreducible_uniformizerSubring.ne_zero hw'
+  have hfac := mp72a102_t3_evalₐ_factor (maximalIdeal v.toValuationSubring)
+    (Nat.le_succ n) z
+  rw [← hw, Ideal.Quotient.factor_mk] at hfac
+  rw [← hfac, Ideal.Quotient.eq_zero_iff_mem, hcancel,
+    v.irreducible_uniformizerSubring.maximalIdeal_eq, Ideal.span_singleton_pow,
+    Ideal.mem_span_singleton]
+  exact ⟨u, rfl⟩
+
+theorem mp72a103_t2_lift_eq_zero_of_depth_one (v : Place K F)
+    (S : Lg37CompletionSection v) {c : v.ResidueField}
+    (h : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) 1 (S.lift c) = 0) :
+    c = 0 := by
+  have hres : lg37_residueHat v (S.lift c) = lg37_residueHat v 0 :=
+    mp72a102_t3_residueHat_congr_of_depth_one v (by rw [h, map_zero])
+  rwa [S.residueHat_lift, map_zero] at hres
+
+theorem mp72a103_t2_taylor_coeff_eq_zero_of_depth (v : Place K F)
+    (S : Lg37CompletionSection v) :
+    ∀ (n : ℕ) (a : ℕ → v.ResidueField),
+      AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) n
+        (∑ i ∈ Finset.range n, S.lift (a i)
+          * algebraMap v.toValuationSubring (lg37_completion v)
+              v.uniformizerSubring ^ i) = 0 →
+      ∀ i < n, a i = 0 := by
+  intro n
+  induction n with
+  | zero => intro a _ i hi; exact absurd hi (Nat.not_lt_zero i)
+  | succ n ih =>
+    intro a h
+    have hsplit : (∑ i ∈ Finset.range (n + 1), S.lift (a i)
+          * algebraMap v.toValuationSubring (lg37_completion v)
+              v.uniformizerSubring ^ i)
+        = algebraMap v.toValuationSubring (lg37_completion v) v.uniformizerSubring
+            * (∑ i ∈ Finset.range n, S.lift (a (i + 1))
+              * algebraMap v.toValuationSubring (lg37_completion v)
+                  v.uniformizerSubring ^ i)
+          + S.lift (a 0) := by
+      rw [Finset.sum_range_succ', pow_zero, mul_one, Finset.mul_sum]
+      congr 1
+      exact Finset.sum_congr rfl fun i _ => by ring
+    have hfac1 := mp72a102_t3_evalₐ_factor (maximalIdeal v.toValuationSubring)
+      (show 1 ≤ n + 1 by omega)
+      (∑ i ∈ Finset.range (n + 1), S.lift (a i)
+        * algebraMap v.toValuationSubring (lg37_completion v)
+            v.uniformizerSubring ^ i)
+    rw [h, map_zero] at hfac1
+    have hT1 : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) 1
+        (algebraMap v.toValuationSubring (lg37_completion v) v.uniformizerSubring
+          * (∑ i ∈ Finset.range n, S.lift (a (i + 1))
+            * algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring ^ i)) = 0 :=
+      mp72a102_t3_evalₐ_succ_mul_eq_zero (maximalIdeal v.toValuationSubring)
+        v.uniformizerSubring_mem_maximalIdeal
+        (mp72a102_t3_evalₐ_zero_depth (maximalIdeal v.toValuationSubring) _)
+    have h1 : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) 1
+        (S.lift (a 0)) = 0 := by
+      have h1' := hfac1.symm
+      rw [hsplit, map_add, hT1, zero_add] at h1'
+      exact h1'
+    have ha0 : a 0 = 0 := mp72a103_t2_lift_eq_zero_of_depth_one v S h1
+    have hT : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) n
+        (∑ i ∈ Finset.range n, S.lift (a (i + 1))
+          * algebraMap v.toValuationSubring (lg37_completion v)
+              v.uniformizerSubring ^ i) = 0 := by
+      apply mp72a103_t2_evalDepth_of_uniformizer_mul v
+      have h' := h
+      rw [hsplit, ha0, map_zero, add_zero] at h'
+      exact h'
+    have hrec := ih (fun j => a (j + 1)) hT
+    intro i hi
+    cases i with
+    | zero => exact ha0
+    | succ j => exact hrec j (Nat.lt_of_succ_lt_succ hi)
+
+end Calculus
+
+end Mp72a103T2
+
+end
+
+open Polynomial IsLocalRing AlgebraicCurve
+open ModularCurve.Lg37 ModularCurve.Mp72a102T3 Mp72a103T2 Mp72a102T1
+open ModularCurve.KwNo6Section
+
+namespace ModularCurve.KwNo6Pin
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem maximalIdeal_fg (v : Place K F) :
+    (maximalIdeal v.toValuationSubring).FG :=
+  IsNoetherian.noetherian _
+
+theorem isAdicComplete_map (v : Place K F) :
+    IsAdicComplete
+        ((maximalIdeal v.toValuationSubring).map
+          (algebraMap v.toValuationSubring (lg37_completion v)))
+        (lg37_completion v) :=
+  mp72a102_t1_isAdicComplete_maximalIdealHat v
+
+theorem residueHat_surjective (v : Place K F) :
+    Function.Surjective (lg37_residueHat v) := fun y => by
+  obtain ⟨x, hx⟩ := IsLocalRing.residue_surjective (R := v.toValuationSubring) y
+  exact ⟨algebraMap v.toValuationSubring (lg37_completion v) x,
+    (lg37_residueHat_algebraMap v x).trans hx⟩
+
+theorem ker_residueHat (v : Place K F) :
+    RingHom.ker (lg37_residueHat v)
+      = (maximalIdeal v.toValuationSubring).map
+          (algebraMap v.toValuationSubring (lg37_completion v)) := by
+  apply le_antisymm
+  · intro x hx
+    have hx0 : lg37_residueHat v x = 0 := RingHom.mem_ker.mp hx
+    have htop : ((maximalIdeal v.toValuationSubring) ^ 1 • ⊤ :
+        Ideal v.toValuationSubring) = (maximalIdeal v.toValuationSubring) ^ 1 := by
+      ext a; simp
+    have h2 : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) 1 x = 0 := by
+      have hfac : Ideal.Quotient.factor
+          (show (maximalIdeal v.toValuationSubring) ^ 1
+              ≤ maximalIdeal v.toValuationSubring by simp)
+          (AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) 1 x) = 0 :=
+        (AdicCompletion.factorₐ_evalₐ_one
+          (I := maximalIdeal v.toValuationSubring) x).trans hx0
+      obtain ⟨y, hy⟩ := Ideal.Quotient.mk_surjective
+        (AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) 1 x)
+      rw [← hy, Ideal.Quotient.factor_mk] at hfac
+      rw [← hy, Ideal.Quotient.eq_zero_iff_mem, pow_one]
+      exact Ideal.Quotient.eq_zero_iff_mem.mp hfac
+    have h4 : Ideal.quotientEquivAlgOfEq v.toValuationSubring htop
+        (AdicCompletion.eval (maximalIdeal v.toValuationSubring)
+          v.toValuationSubring 1 x) = 0 := h2
+    have h3 : AdicCompletion.eval (maximalIdeal v.toValuationSubring)
+        v.toValuationSubring 1 x = 0 :=
+      (Ideal.quotientEquivAlgOfEq v.toValuationSubring htop).injective
+        (h4.trans (map_zero _).symm)
+    have h6 : x ∈ ((maximalIdeal v.toValuationSubring) ^ 1 • ⊤ :
+        Submodule v.toValuationSubring (lg37_completion v)) := by
+      rw [AdicCompletion.pow_smul_top_eq_ker_eval (maximalIdeal_fg v)]
+      exact LinearMap.mem_ker.mpr h3
+    rw [pow_one, Ideal.smul_top_eq_map] at h6
+    simpa using h6
+  · rw [Ideal.map_le_iff_le_comap]
+    intro a ha
+    rw [Ideal.mem_comap, RingHom.mem_ker, lg37_residueHat_algebraMap]
+    exact Ideal.Quotient.eq_zero_iff_mem.mpr ha
+
+theorem map_isMaximal (v : Place K F) :
+    ((maximalIdeal v.toValuationSubring).map
+        (algebraMap v.toValuationSubring (lg37_completion v))).IsMaximal := by
+  rw [← ker_residueHat v]
+  exact RingHom.ker_isMaximal_of_surjective _ (residueHat_surjective v)
+
+instance isLocalRing_completion (v : Place K F) :
+    IsLocalRing (lg37_completion v) := by
+  have := map_isMaximal v
+  have := isAdicComplete_map v
+  exact isLocalRing_of_isAdicComplete_maximal
+    ((maximalIdeal v.toValuationSubring).map
+      (algebraMap v.toValuationSubring (lg37_completion v)))
+
+theorem ker_residueHat_eq_maximalIdeal (v : Place K F) :
+    RingHom.ker (lg37_residueHat v)
+      = maximalIdeal (lg37_completion v) := by
+  rw [ker_residueHat v]
+  exact (IsLocalRing.eq_maximalIdeal (map_isMaximal v))
+
+theorem hensel_unique (v : Place K F) {p : K[X]} (hsep : p.Separable)
+    {α β : lg37_completion v}
+    (hα : aeval α p = 0) (hβ : aeval β p = 0)
+    (hres : lg37_residueHat v α = lg37_residueHat v β) : α = β := by
+  have := isLocalRing_completion v
+  set f := p.map (algebraMap K (lg37_completion v)) with hf
+  have hevalα : f.eval α = 0 := by rw [hf, eval_map, ← aeval_def]; exact hα
+  have hevalβ : f.eval β = 0 := by rw [hf, eval_map, ← aeval_def]; exact hβ
+  set φ := (AdicCompletion.evalOneₐ (maximalIdeal v.toValuationSubring)).restrictScalars K
+    with hφ
+  have hφeq : ∀ z, φ z = lg37_residueHat v z := fun z => rfl
+  have hsub0 : lg37_residueHat v (α - β) = 0 := by rw [map_sub, hres, sub_self]
+  have hmem : (α - β) ∈ maximalIdeal (lg37_completion v) := by
+    rw [← ker_residueHat_eq_maximalIdeal v]; exact RingHom.mem_ker.mpr hsub0
+  have hnu : ¬ IsUnit (α - β) := fun hu => notMem_maximalIdeal.mpr hu hmem
+  have hfderiv : f.derivative.eval α = aeval α (derivative p) := by
+    rw [hf, derivative_map, eval_map, ← aeval_def]
+  have hαroot : aeval (lg37_residueHat v α) p = 0 := by
+    have h := Polynomial.aeval_algHom_apply φ α p
+    rw [hφeq, hφeq, hα, map_zero] at h
+    exact h
+  have hderivbar : aeval (lg37_residueHat v α) (derivative p) ≠ 0 :=
+    hsep.aeval_derivative_ne_zero hαroot
+  have hunit : IsUnit (f.derivative.eval α) := by
+    rw [← notMem_maximalIdeal, ← ker_residueHat_eq_maximalIdeal v, RingHom.mem_ker, hfderiv]
+    intro hk
+    apply hderivbar
+    have h := Polynomial.aeval_algHom_apply φ α (derivative p)
+    rw [hφeq, hφeq] at h
+    exact h.trans hk
+  exact eq_of_eval_eq_zero_of_not_isUnit_sub hevalα hevalβ hnu hunit
+
+theorem section_unique (v : Place K F)
+    [FiniteDimensional K v.ResidueField] [Algebra.IsSeparable K v.ResidueField]
+    (S S' : Lg37CompletionSection v) : S.lift = S'.lift := by
+  obtain ⟨θ, htop⟩ := Field.exists_primitive_element K v.ResidueField
+  have hint : IsIntegral K θ := Algebra.IsIntegral.isIntegral θ
+  have hsep : (minpoly K θ).Separable := Algebra.IsSeparable.isSeparable K θ
+  have hroot : ∀ (T : Lg37CompletionSection v),
+      aeval (T.lift θ) (minpoly K θ) = 0 := by
+    intro T
+    rw [Polynomial.aeval_algHom_apply, minpoly.aeval, map_zero]
+  have hθ : S.lift θ = S'.lift θ :=
+    hensel_unique v hsep (hroot S) (hroot S')
+      ((S.residueHat_lift θ).trans (S'.residueHat_lift θ).symm)
+  have hcomp : S.lift.comp (residueFieldAdjoinRootEquiv v hint htop).toAlgHom
+      = S'.lift.comp (residueFieldAdjoinRootEquiv v hint htop).toAlgHom := by
+    refine AdjoinRoot.algHom_ext ?_
+    have hr : (residueFieldAdjoinRootEquiv v hint htop).toAlgHom
+        (AdjoinRoot.root (minpoly K θ)) = θ := residueFieldAdjoinRootEquiv_root v hint htop
+    rw [AlgHom.comp_apply, AlgHom.comp_apply, hr]
+    exact hθ
+  refine AlgHom.ext (fun a => ?_)
+  obtain ⟨b, rfl⟩ := (residueFieldAdjoinRootEquiv v hint htop).surjective a
+  have hb := DFunLike.congr_fun hcomp b
+  simpa only [AlgHom.comp_apply, AlgEquiv.coe_toAlgHom] using hb
+
+noncomputable def aCoeff (v : Place K F) (S : Lg37CompletionSection v)
+    (n : ℕ) (x : lg37_completion v) : v.ResidueField :=
+  (Classical.choose (mp72a102_t3_sigma_taylor_expansion v S (n + 1) x)) n
+
+theorem aCoeff_section_indep (v : Place K F)
+    [FiniteDimensional K v.ResidueField] [Algebra.IsSeparable K v.ResidueField]
+    (S S' : Lg37CompletionSection v) (n : ℕ) (x : lg37_completion v) :
+    aCoeff v S n x = aCoeff v S' n x := by
+  have hlift : S.lift = S'.lift := section_unique v S S'
+  have ha := Classical.choose_spec (mp72a102_t3_sigma_taylor_expansion v S (n + 1) x)
+  have ha' := Classical.choose_spec (mp72a102_t3_sigma_taylor_expansion v S' (n + 1) x)
+  set a := Classical.choose (mp72a102_t3_sigma_taylor_expansion v S (n + 1) x) with ha_def
+  set a' := Classical.choose (mp72a102_t3_sigma_taylor_expansion v S' (n + 1) x) with ha'_def
+  have ha'' : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) (n + 1)
+      (x - ∑ i ∈ Finset.range (n + 1), S.lift (a' i)
+        * algebraMap v.toValuationSubring (lg37_completion v)
+            v.uniformizerSubring ^ i) = 0 := by
+    simpa only [← hlift] using ha'
+  have key : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) (n + 1)
+      (∑ i ∈ Finset.range (n + 1), S.lift ((fun i => a' i - a i) i)
+        * algebraMap v.toValuationSubring (lg37_completion v)
+            v.uniformizerSubring ^ i) = 0 := by
+    have e1 : (∑ i ∈ Finset.range (n + 1), S.lift (a' i - a i)
+          * algebraMap v.toValuationSubring (lg37_completion v)
+              v.uniformizerSubring ^ i)
+        = (x - ∑ i ∈ Finset.range (n + 1), S.lift (a i)
+            * algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring ^ i)
+          - (x - ∑ i ∈ Finset.range (n + 1), S.lift (a' i)
+            * algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring ^ i) := by
+      rw [Finset.sum_congr rfl
+        (fun i _ => by rw [map_sub, sub_mul]), Finset.sum_sub_distrib]
+      ring
+    rw [e1, map_sub, ha, ha'', sub_zero]
+  have hzero := mp72a103_t2_taylor_coeff_eq_zero_of_depth v S (n + 1)
+    (fun i => a' i - a i) key n (Nat.lt_succ_self n)
+  have han : a n = a' n := (sub_eq_zero.mp hzero).symm
+  simp only [aCoeff, ← ha_def, ← ha'_def]
+  exact han
+
+end ModularCurve.KwNo6Pin
+
+open Polynomial IsLocalRing AlgebraicCurve
+open ModularCurve.Lg37 ModularCurve.Mp72a102T3 Mp72a103T2 Mp72a102T1
+open ModularCurve.KwNo6Section
+
+namespace ModularCurve.KwNo6Pin
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem aCoeff_zero (v : Place K F) (S : Lg37CompletionSection v)
+    (x : lg37_completion v) :
+    aCoeff v S 0 x = lg37_residueHat v x := by
+  have ha := Classical.choose_spec (mp72a102_t3_sigma_taylor_expansion v S 1 x)
+  set a := Classical.choose (mp72a102_t3_sigma_taylor_expansion v S 1 x) with ha_def
+  rw [Finset.sum_range_one, pow_zero, mul_one] at ha
+  have hres : lg37_residueHat v (x - S.lift (a 0)) = lg37_residueHat v 0 :=
+    mp72a102_t3_residueHat_congr_of_depth_one v (by rw [ha, map_zero])
+  rw [map_sub, S.residueHat_lift, map_zero, sub_eq_zero] at hres
+  simp only [aCoeff, ← ha_def]
+  exact hres.symm
+
+theorem aCoeff_add (v : Place K F) (S : Lg37CompletionSection v) (m : ℕ)
+    (x y : lg37_completion v) :
+    aCoeff v S m (x + y) = aCoeff v S m x + aCoeff v S m y := by
+  have hx := Classical.choose_spec (mp72a102_t3_sigma_taylor_expansion v S (m + 1) x)
+  have hy := Classical.choose_spec (mp72a102_t3_sigma_taylor_expansion v S (m + 1) y)
+  have hxy := Classical.choose_spec (mp72a102_t3_sigma_taylor_expansion v S (m + 1) (x + y))
+  set ax := Classical.choose (mp72a102_t3_sigma_taylor_expansion v S (m + 1) x) with hax_def
+  set ay := Classical.choose (mp72a102_t3_sigma_taylor_expansion v S (m + 1) y) with hay_def
+  set axy := Classical.choose (mp72a102_t3_sigma_taylor_expansion v S (m + 1) (x + y))
+    with haxy_def
+  have hsum : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) (m + 1)
+      ((x + y) - ∑ i ∈ Finset.range (m + 1), S.lift ((fun i => ax i + ay i) i)
+        * algebraMap v.toValuationSubring (lg37_completion v)
+            v.uniformizerSubring ^ i) = 0 := by
+    have e : (x + y) - ∑ i ∈ Finset.range (m + 1), S.lift (ax i + ay i)
+          * algebraMap v.toValuationSubring (lg37_completion v)
+              v.uniformizerSubring ^ i
+        = (x - ∑ i ∈ Finset.range (m + 1), S.lift (ax i)
+            * algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring ^ i)
+          + (y - ∑ i ∈ Finset.range (m + 1), S.lift (ay i)
+            * algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring ^ i) := by
+      rw [Finset.sum_congr rfl (fun i _ => by rw [map_add, add_mul]),
+        Finset.sum_add_distrib]
+      ring
+    rw [e, mp72a102_t3_evalDepth_add, hx, hy, add_zero]
+  have key : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) (m + 1)
+      (∑ i ∈ Finset.range (m + 1), S.lift ((fun i => (ax i + ay i) - axy i) i)
+        * algebraMap v.toValuationSubring (lg37_completion v)
+            v.uniformizerSubring ^ i) = 0 := by
+    have e1 : (∑ i ∈ Finset.range (m + 1), S.lift ((ax i + ay i) - axy i)
+          * algebraMap v.toValuationSubring (lg37_completion v)
+              v.uniformizerSubring ^ i)
+        = ((x + y) - ∑ i ∈ Finset.range (m + 1), S.lift (axy i)
+            * algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring ^ i)
+          - ((x + y) - ∑ i ∈ Finset.range (m + 1), S.lift (ax i + ay i)
+            * algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring ^ i) := by
+      rw [Finset.sum_congr rfl (fun i _ => by rw [map_sub, sub_mul]),
+        Finset.sum_sub_distrib]
+      ring
+    rw [e1, map_sub, hxy, hsum, sub_zero]
+  have hzero := mp72a103_t2_taylor_coeff_eq_zero_of_depth v S (m + 1)
+    (fun i => (ax i + ay i) - axy i) key m (Nat.lt_succ_self m)
+  have han : axy m = ax m + ay m := (sub_eq_zero.mp hzero).symm
+  simp only [aCoeff, ← hax_def, ← hay_def, ← haxy_def]
+  exact han
+
+theorem aCoeff_smul (v : Place K F) (S : Lg37CompletionSection v) (m : ℕ) (c : K)
+    (x : lg37_completion v) :
+    aCoeff v S m (algebraMap K (lg37_completion v) c * x)
+      = algebraMap K v.ResidueField c * aCoeff v S m x := by
+  have hx := Classical.choose_spec (mp72a102_t3_sigma_taylor_expansion v S (m + 1) x)
+  have hcx := Classical.choose_spec (mp72a102_t3_sigma_taylor_expansion v S (m + 1)
+    (algebraMap K (lg37_completion v) c * x))
+  set ax := Classical.choose (mp72a102_t3_sigma_taylor_expansion v S (m + 1) x) with hax_def
+  set acx := Classical.choose (mp72a102_t3_sigma_taylor_expansion v S (m + 1)
+    (algebraMap K (lg37_completion v) c * x)) with hacx_def
+  have hsmul : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) (m + 1)
+      ((algebraMap K (lg37_completion v) c * x)
+        - ∑ i ∈ Finset.range (m + 1),
+            S.lift ((fun i => algebraMap K v.ResidueField c * ax i) i)
+          * algebraMap v.toValuationSubring (lg37_completion v)
+              v.uniformizerSubring ^ i) = 0 := by
+    have e : (algebraMap K (lg37_completion v) c * x)
+          - ∑ i ∈ Finset.range (m + 1), S.lift (algebraMap K v.ResidueField c * ax i)
+            * algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring ^ i
+        = algebraMap K (lg37_completion v) c
+          * (x - ∑ i ∈ Finset.range (m + 1), S.lift (ax i)
+              * algebraMap v.toValuationSubring (lg37_completion v)
+                  v.uniformizerSubring ^ i) := by
+      rw [mul_sub, Finset.mul_sum]
+      congr 1
+      refine Finset.sum_congr rfl (fun i _ => ?_)
+      have hlift : S.lift (algebraMap K v.ResidueField c * ax i)
+          = algebraMap K (lg37_completion v) c * S.lift (ax i) := by
+        rw [← Algebra.smul_def c (ax i), map_smul, Algebra.smul_def]
+      rw [hlift, mul_assoc]
+    rw [e, mp72a102_t3_evalDepth_mul, hx, mul_zero]
+  have key : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) (m + 1)
+      (∑ i ∈ Finset.range (m + 1),
+          S.lift ((fun i => algebraMap K v.ResidueField c * ax i - acx i) i)
+        * algebraMap v.toValuationSubring (lg37_completion v)
+            v.uniformizerSubring ^ i) = 0 := by
+    have e1 : (∑ i ∈ Finset.range (m + 1),
+            S.lift (algebraMap K v.ResidueField c * ax i - acx i)
+          * algebraMap v.toValuationSubring (lg37_completion v)
+              v.uniformizerSubring ^ i)
+        = ((algebraMap K (lg37_completion v) c * x)
+            - ∑ i ∈ Finset.range (m + 1), S.lift (acx i)
+              * algebraMap v.toValuationSubring (lg37_completion v)
+                  v.uniformizerSubring ^ i)
+          - ((algebraMap K (lg37_completion v) c * x)
+            - ∑ i ∈ Finset.range (m + 1), S.lift (algebraMap K v.ResidueField c * ax i)
+              * algebraMap v.toValuationSubring (lg37_completion v)
+                  v.uniformizerSubring ^ i) := by
+      rw [Finset.sum_congr rfl (fun i _ => by rw [map_sub, sub_mul]),
+        Finset.sum_sub_distrib]
+      ring
+    rw [e1, map_sub, hcx, hsmul, sub_zero]
+  have hzero := mp72a103_t2_taylor_coeff_eq_zero_of_depth v S (m + 1)
+    (fun i => algebraMap K v.ResidueField c * ax i - acx i) key m (Nat.lt_succ_self m)
+  have han : acx m = algebraMap K v.ResidueField c * ax m := (sub_eq_zero.mp hzero).symm
+  simp only [aCoeff, ← hax_def, ← hacx_def]
+  exact han
+
+theorem aCoeff_shift (v : Place K F) (S : Lg37CompletionSection v) (n : ℕ)
+    (x : lg37_completion v) :
+    aCoeff v S (n + 1)
+        (algebraMap v.toValuationSubring (lg37_completion v) v.uniformizerSubring * x)
+      = aCoeff v S n x := by
+  have ha := Classical.choose_spec (mp72a102_t3_sigma_taylor_expansion v S (n + 1) x)
+  have hpx := Classical.choose_spec (mp72a102_t3_sigma_taylor_expansion v S (n + 2)
+    (algebraMap v.toValuationSubring (lg37_completion v) v.uniformizerSubring * x))
+  set a := Classical.choose (mp72a102_t3_sigma_taylor_expansion v S (n + 1) x) with ha_def
+  set b := Classical.choose (mp72a102_t3_sigma_taylor_expansion v S (n + 2)
+    (algebraMap v.toValuationSubring (lg37_completion v) v.uniformizerSubring * x))
+    with hb_def
+  set c : ℕ → v.ResidueField :=
+    fun i => Nat.rec (motive := fun _ => v.ResidueField) 0 (fun j _ => a j) i with hc_def
+  have hshift : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) (n + 2)
+      ((algebraMap v.toValuationSubring (lg37_completion v) v.uniformizerSubring * x)
+        - ∑ i ∈ Finset.range (n + 2), S.lift (c i)
+          * algebraMap v.toValuationSubring (lg37_completion v)
+              v.uniformizerSubring ^ i) = 0 := by
+    have hmul := mp72a102_t3_evalₐ_succ_mul_eq_zero (maximalIdeal v.toValuationSubring)
+      v.uniformizerSubring_mem_maximalIdeal ha
+    have e : (algebraMap v.toValuationSubring (lg37_completion v) v.uniformizerSubring * x)
+          - ∑ i ∈ Finset.range (n + 2), S.lift (c i)
+            * algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring ^ i
+        = algebraMap v.toValuationSubring (lg37_completion v) v.uniformizerSubring
+          * (x - ∑ i ∈ Finset.range (n + 1), S.lift (a i)
+              * algebraMap v.toValuationSubring (lg37_completion v)
+                  v.uniformizerSubring ^ i) := by
+      have hc0 : c 0 = 0 := rfl
+      have hcs : ∀ i, c (i + 1) = a i := fun _ => rfl
+      rw [Finset.sum_range_succ', hc0, map_zero, zero_mul, add_zero, mul_sub, Finset.mul_sum]
+      congr 1
+      refine Finset.sum_congr rfl (fun i _ => ?_)
+      rw [hcs i, pow_succ]
+      ring
+    rw [e]
+    exact hmul
+  have key : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) (n + 2)
+      (∑ i ∈ Finset.range (n + 2), S.lift ((fun i => c i - b i) i)
+        * algebraMap v.toValuationSubring (lg37_completion v)
+            v.uniformizerSubring ^ i) = 0 := by
+    have e1 : (∑ i ∈ Finset.range (n + 2), S.lift (c i - b i)
+          * algebraMap v.toValuationSubring (lg37_completion v)
+              v.uniformizerSubring ^ i)
+        = ((algebraMap v.toValuationSubring (lg37_completion v) v.uniformizerSubring * x)
+            - ∑ i ∈ Finset.range (n + 2), S.lift (b i)
+              * algebraMap v.toValuationSubring (lg37_completion v)
+                  v.uniformizerSubring ^ i)
+          - ((algebraMap v.toValuationSubring (lg37_completion v) v.uniformizerSubring * x)
+            - ∑ i ∈ Finset.range (n + 2), S.lift (c i)
+              * algebraMap v.toValuationSubring (lg37_completion v)
+                  v.uniformizerSubring ^ i) := by
+      rw [Finset.sum_congr rfl (fun i _ => by rw [map_sub, sub_mul]),
+        Finset.sum_sub_distrib]
+      ring
+    rw [e1, map_sub, hpx, hshift, sub_zero]
+  have hzero := mp72a103_t2_taylor_coeff_eq_zero_of_depth v S (n + 2)
+    (fun i => c i - b i) key (n + 1) (Nat.lt_succ_self (n + 1))
+  have hcn : c (n + 1) = a n := rfl
+  have hbn : b (n + 1) = a n := by
+    have := sub_eq_zero.mp hzero
+    rw [hcn] at this
+    exact this.symm
+  simp only [aCoeff, ← ha_def, ← hb_def]
+  exact hbn
+
+theorem aCoeff_shift_pow (v : Place K F) (S : Lg37CompletionSection v) (n k : ℕ)
+    (x : lg37_completion v) :
+    aCoeff v S (n + k)
+        ((algebraMap v.toValuationSubring (lg37_completion v) v.uniformizerSubring) ^ k
+          * x)
+      = aCoeff v S n x := by
+  induction k with
+  | zero => simp
+  | succ k ih =>
+    have hstep : (algebraMap v.toValuationSubring (lg37_completion v)
+          v.uniformizerSubring) ^ (k + 1) * x
+        = algebraMap v.toValuationSubring (lg37_completion v) v.uniformizerSubring
+          * ((algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring) ^ k * x) := by
+      rw [pow_succ]; ring
+    rw [show n + (k + 1) = (n + k) + 1 from by omega, hstep, aCoeff_shift, ih]
+
+theorem aCoeff_one_eq_zero (v : Place K F) (S : Lg37CompletionSection v)
+    {n : ℕ} (hn : 1 ≤ n) : aCoeff v S n 1 = 0 := by
+  have hc := Classical.choose_spec (mp72a102_t3_sigma_taylor_expansion v S (n + 1) 1)
+  set cc := Classical.choose (mp72a102_t3_sigma_taylor_expansion v S (n + 1) 1) with hcc_def
+  set e : ℕ → v.ResidueField := fun i => if i = 0 then 1 else 0 with he_def
+  have hesum : (∑ i ∈ Finset.range (n + 1), S.lift (e i)
+      * algebraMap v.toValuationSubring (lg37_completion v)
+          v.uniformizerSubring ^ i) = 1 := by
+    rw [Finset.sum_eq_single 0]
+    · simp [he_def]
+    · intro i _ hi; simp [he_def, hi]
+    · intro h; exact absurd (Finset.mem_range.mpr (by omega)) h
+  have hevalid : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) (n + 1)
+      ((1 : lg37_completion v) - ∑ i ∈ Finset.range (n + 1), S.lift (e i)
+        * algebraMap v.toValuationSubring (lg37_completion v)
+            v.uniformizerSubring ^ i) = 0 := by
+    rw [hesum, sub_self, map_zero]
+  have key : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) (n + 1)
+      (∑ i ∈ Finset.range (n + 1), S.lift ((fun i => e i - cc i) i)
+        * algebraMap v.toValuationSubring (lg37_completion v)
+            v.uniformizerSubring ^ i) = 0 := by
+    have e1 : (∑ i ∈ Finset.range (n + 1), S.lift (e i - cc i)
+          * algebraMap v.toValuationSubring (lg37_completion v)
+              v.uniformizerSubring ^ i)
+        = ((1 : lg37_completion v) - ∑ i ∈ Finset.range (n + 1), S.lift (cc i)
+            * algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring ^ i)
+          - ((1 : lg37_completion v) - ∑ i ∈ Finset.range (n + 1), S.lift (e i)
+            * algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring ^ i) := by
+      rw [Finset.sum_congr rfl (fun i _ => by rw [map_sub, sub_mul]),
+        Finset.sum_sub_distrib]
+      ring
+    rw [e1, map_sub, hc, hevalid, sub_zero]
+  have hzero := mp72a103_t2_taylor_coeff_eq_zero_of_depth v S (n + 1)
+    (fun i => e i - cc i) key n (Nat.lt_succ_self n)
+  have hen : e n = 0 := by simp [he_def, Nat.one_le_iff_ne_zero.mp hn]
+  have : e n - cc n = 0 := hzero
+  rw [hen, zero_sub, neg_eq_zero] at this
+  simp only [aCoeff, ← hcc_def]
+  exact this
+
+theorem clearPow_mem (v : Place K F) (f : F) {N : ℕ} (hN : (-v.ord f).toNat ≤ N) :
+    v.uniformizer ^ (N + 1) * f ∈ v.toValuationSubring := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · rw [mul_zero]; exact zero_mem _
+  · refine (v.mem_iff_ord_nonneg (mul_ne_zero (v.uniformizer_pow_ne_zero _) hf0)).mpr ?_
+    rw [v.ord_mul (v.uniformizer_pow_ne_zero _) hf0, v.ord_uniformizer_pow]
+    have h := Int.self_le_toNat (-v.ord f)
+    have hNc : ((-v.ord f).toNat : ℤ) ≤ (N : ℤ) := by exact_mod_cast hN
+    omega
+
+noncomputable def clearedHat (v : Place K F) (f : F) {N : ℕ} (hN : (-v.ord f).toNat ≤ N) :
+    lg37_completion v :=
+  algebraMap v.toValuationSubring (lg37_completion v)
+    ⟨v.uniformizer ^ (N + 1) * f, clearPow_mem v f hN⟩
+
+noncomputable def resStar (v : Place K F) (S : Lg37CompletionSection v) (f : F) :
+    v.ResidueField :=
+  aCoeff v S ((-v.ord f).toNat) (clearedHat v f (le_refl _))
+
+theorem aCoeff_clearedHat_of_le (v : Place K F) (S : Lg37CompletionSection v) (f : F)
+    {N : ℕ} (hN : (-v.ord f).toNat ≤ N) :
+    aCoeff v S N (clearedHat v f hN) = resStar v S f := by
+  obtain ⟨k, rfl⟩ := Nat.exists_eq_add_of_le hN
+  unfold clearedHat resStar
+  have hfac : (⟨v.uniformizer ^ (((-v.ord f).toNat + k) + 1) * f,
+        clearPow_mem v f hN⟩ : v.toValuationSubring)
+      = v.uniformizerSubring ^ k
+        * ⟨v.uniformizer ^ ((-v.ord f).toNat + 1) * f, clearPow_mem v f (le_refl _)⟩ := by
+    apply Subtype.ext
+    push_cast [v.coe_uniformizerSubring]
+    ring
+  rw [hfac, map_mul, map_pow]
+  exact aCoeff_shift_pow v S ((-v.ord f).toNat) k _
+
+theorem resStar_add (v : Place K F) (S : Lg37CompletionSection v) (f g : F) :
+    resStar v S (f + g) = resStar v S f + resStar v S g := by
+  set N := (-v.ord f).toNat ⊔ (-v.ord g).toNat ⊔ (-v.ord (f + g)).toNat with hN
+  have hf : (-v.ord f).toNat ≤ N := le_trans le_sup_left le_sup_left
+  have hg : (-v.ord g).toNat ≤ N := le_trans le_sup_right le_sup_left
+  have hfg : (-v.ord (f + g)).toNat ≤ N := le_sup_right
+  rw [← aCoeff_clearedHat_of_le v S f hf, ← aCoeff_clearedHat_of_le v S g hg,
+    ← aCoeff_clearedHat_of_le v S (f + g) hfg, ← aCoeff_add]
+  congr 1
+  unfold clearedHat
+  rw [← map_add]
+  congr 1
+  apply Subtype.ext
+  push_cast
+  ring
+
+theorem resStar_smul (v : Place K F) (S : Lg37CompletionSection v) (c : K) (f : F) :
+    resStar v S (c • f) = c • resStar v S f := by
+  set N := (-v.ord (c • f)).toNat ⊔ (-v.ord f).toNat with hN
+  have hcf : (-v.ord (c • f)).toNat ≤ N := le_sup_left
+  have hf : (-v.ord f).toNat ≤ N := le_sup_right
+  rw [← aCoeff_clearedHat_of_le v S (c • f) hcf, ← aCoeff_clearedHat_of_le v S f hf,
+    Algebra.smul_def c (aCoeff v S N (clearedHat v f hf)), ← aCoeff_smul]
+  congr 1
+  unfold clearedHat
+  rw [IsScalarTower.algebraMap_apply K v.toValuationSubring (lg37_completion v) c, ← map_mul]
+  congr 1
+  apply Subtype.ext
+  push_cast [v.coe_algebraMap, Algebra.smul_def]
+  ring
+
+noncomputable def resStarₗ (v : Place K F) (S : Lg37CompletionSection v) :
+    F →ₗ[K] v.ResidueField where
+  toFun := resStar v S
+  map_add' := resStar_add v S
+  map_smul' c f := by rw [RingHom.id_apply]; exact resStar_smul v S c f
+
+theorem resStar_simplePole (v : Place K F) (S : Lg37CompletionSection v) (f : F)
+    (hf : v.uniformizer * f ∈ v.toValuationSubring) :
+    resStar v S f = IsLocalRing.residue _ ⟨v.uniformizer * f, hf⟩ := by
+  have hM : (-v.ord f).toNat ≤ 1 := by
+    rcases eq_or_ne f 0 with rfl | hf0
+    · rw [v.ord_zero]; simp
+    · have hge : (0 : ℤ) ≤ v.ord (v.uniformizer * f) :=
+        (v.mem_iff_ord_nonneg (mul_ne_zero v.uniformizer_ne_zero hf0)).mp hf
+      rw [v.ord_mul v.uniformizer_ne_zero hf0, v.ord_uniformizer] at hge
+      have := Int.self_le_toNat (-v.ord f)
+      omega
+  rw [← aCoeff_clearedHat_of_le v S f hM]
+  unfold clearedHat
+  have hfac : (⟨v.uniformizer ^ (1 + 1) * f, clearPow_mem v f hM⟩ : v.toValuationSubring)
+      = v.uniformizerSubring * ⟨v.uniformizer * f, hf⟩ := by
+    apply Subtype.ext
+    push_cast [v.coe_uniformizerSubring]
+    ring
+  rw [hfac, map_mul, aCoeff_shift, aCoeff_zero, lg37_residueHat_algebraMap]
+
+theorem resStar_of_mem (v : Place K F) (S : Lg37CompletionSection v) {f : F}
+    (hf : f ∈ v.toValuationSubring) : resStar v S f = 0 := by
+  rw [resStar_simplePole v S f (mul_mem v.uniformizer_mem hf), IsLocalRing.residue_eq_zero_iff]
+  have : (⟨v.uniformizer * f, mul_mem v.uniformizer_mem hf⟩ : v.toValuationSubring)
+      = v.uniformizerSubring * ⟨f, hf⟩ := Subtype.ext rfl
+  rw [this]
+  exact Ideal.mul_mem_right _ _ v.uniformizerSubring_mem_maximalIdeal
+
+theorem resStar_higherPoleMonomial (v : Place K F) (S : Lg37CompletionSection v)
+    {n : ℕ} (hn : 1 ≤ n) : resStar v S (v.uniformizer ^ (n + 1))⁻¹ = 0 := by
+  have hord : v.ord (v.uniformizer ^ (n + 1))⁻¹ = -((n : ℤ) + 1) := by
+    rw [v.ord_inv, v.ord_uniformizer_pow]; push_cast; ring
+  have hM : (-v.ord (v.uniformizer ^ (n + 1))⁻¹).toNat = n + 1 := by
+    rw [hord]; simp
+  have hle : (-v.ord (v.uniformizer ^ (n + 1))⁻¹).toNat ≤ n + 1 := le_of_eq hM
+  rw [← aCoeff_clearedHat_of_le v S (v.uniformizer ^ (n + 1))⁻¹ hle]
+  unfold clearedHat
+  have hfac : (⟨v.uniformizer ^ ((n + 1) + 1) * (v.uniformizer ^ (n + 1))⁻¹,
+        clearPow_mem v (v.uniformizer ^ (n + 1))⁻¹ hle⟩ : v.toValuationSubring)
+      = v.uniformizerSubring := by
+    apply Subtype.ext
+    push_cast [v.coe_uniformizerSubring]
+    rw [pow_succ, mul_right_comm, mul_inv_cancel₀ (v.uniformizer_pow_ne_zero (n + 1)), one_mul]
+  rw [hfac]
+  have : algebraMap v.toValuationSubring (lg37_completion v) v.uniformizerSubring
+      = algebraMap v.toValuationSubring (lg37_completion v) v.uniformizerSubring * 1 := by
+    rw [mul_one]
+  rw [this, aCoeff_shift, aCoeff_one_eq_zero v S hn]
+
+noncomputable def canonicalLocalResidueDataKStar (v : Place K F)
+    (S : Lg37CompletionSection v) : v.CanonicalLocalResidueDataK where
+  res := resStarₗ v S
+  res_of_mem _f hf := resStar_of_mem v S hf
+  res_simplePole f hf := resStar_simplePole v S f hf
+  res_higherPoleMonomial _n hn := resStar_higherPoleMonomial v S hn
+
+end ModularCurve.KwNo6Pin
+
+open Polynomial IsLocalRing AlgebraicCurve
+open ModularCurve.Lg37 ModularCurve.KwNo6Section ModularCurve.KwNo6Pin
+open Mp72a102T1
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem completionSection_nonempty_generic (v : Place K F)
+    [FiniteDimensional K v.ResidueField] [Algebra.IsSeparable K v.ResidueField] :
+    Nonempty (Lg37CompletionSection v) := by
+  obtain ⟨ᾱ, htop⟩ := Field.exists_primitive_element K v.ResidueField
+  have hint : IsIntegral K ᾱ := Algebra.IsIntegral.isIntegral ᾱ
+  have hmon : (minpoly K ᾱ).Monic := minpoly.monic hint
+  have hsep : (minpoly K ᾱ).Separable := Algebra.IsSeparable.isSeparable K ᾱ
+  have haevalbar : (aeval ᾱ) (minpoly K ᾱ) = 0 := minpoly.aeval K ᾱ
+  obtain ⟨αhat, hαroot, hαres⟩ :=
+    mp72a102_t1_exists_completion_root_of_residue_root v hmon hsep haevalbar
+  exact ⟨sectionOfPrimitiveRoot v hint htop αhat hαroot hαres⟩
+
+noncomputable instance instHasCanonicalLocalResidueKStar [IsCurveOver K F] [PerfectField K] :
+    HasCanonicalLocalResidueKStar K F where
+  dataKStar v :=
+    haveI : FiniteDimensional K v.ResidueField := Place.FiniteResidue.finite
+    haveI : Algebra.IsSeparable K v.ResidueField :=
+      Algebra.IsAlgebraic.isSeparable_of_perfectField
+    canonicalLocalResidueDataKStar v
+      (Classical.choice (completionSection_nonempty_generic v))
+
+theorem localResidue_eq_resStar [IsCurveOver K F] [PerfectField K] (v : Place K F)
+    (S : Lg37CompletionSection v) (f : F) :
+    v.localResidue f = resStar v S f := by
+  have : FiniteDimensional K v.ResidueField := Place.FiniteResidue.finite
+  have : Algebra.IsSeparable K v.ResidueField :=
+    Algebra.IsAlgebraic.isSeparable_of_perfectField
+  change resStar v (Classical.choice (completionSection_nonempty_generic v)) f = resStar v S f
+  unfold resStar
+  exact aCoeff_section_indep v _ S _ _
+
+theorem localResidue_eq_resStarₗ [IsCurveOver K F] [PerfectField K] (v : Place K F)
+    (S : Lg37CompletionSection v) :
+    v.localResidue = resStarₗ v S :=
+  LinearMap.ext (localResidue_eq_resStar v S)
+
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_Correspondence.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_Correspondence.lean
new file mode 100644
index 0000000000..f68b171bf4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_Correspondence.lean
@@ -0,0 +1,406 @@
+/-
+Based on Prove2Me node AlgebraicCurve_Correspondence
+(3c0e42ff-ff90-5f68-a698-ffc9f304ba5a) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_BaseChangeGalois
+
+/-!
+# Divisor correspondences along explicit function-field embeddings
+
+Definition: `AlgebraicCurve_Correspondence` (`3c0e42ff-ff90-5f68-a698-ffc9f304ba5a`), by Claude,
+2026-09-05.
+
+Throughout, $K$ is a field and $F$, $F'$ are fields with $K$-algebra structures; all
+divisor-theoretic notions ($\mathrm{Place}\,K\,F$, $\mathrm{Divisor}\,K\,F$, $\mathrm{Pic}^0$,
+`Place.restrict`, ramification index, inertia degree, fibre, `Divisor.pullback`,
+`Divisor.pushforward`, and the hypothesis classes `FundamentalIdentity`, `PushforwardNormFormula`,
+`HasPrincipalDivisors`) are taken from the project's own earlier modules. The point of this module
+is to restate that calculus along an explicitly given $K$-algebra map $\varphi : F
+\to_{\mathrm{alg}[K]} F'$ rather than along an ambient `[Algebra F F']` instance, so that two such
+maps between the same pair of fields can coexist. `algebraAlong φ` is the algebra structure
+$\varphi_*$ on $F'$ over $F$ obtained from the underlying ring homomorphism; it is an abbreviation,
+never an instance, and `isScalarTower_along`, `isIntegral_along` supply the tower and integrality
+facts for it. Against this the instance-free predicates `FundamentalIdentityAlong K φ hφ`,
+`FiniteAlong K φ`, `NormFormulaAlong K φ hfin`, `SeparableAlong K φ` and the number `finrankAlong K
+φ` are by definition the corresponding instance-form statements evaluated at `algebraAlong φ` (with
+integrality of $\varphi$ as a hypothesis `hφ` where needed), and `Divisor.pullbackAlong φ hφ`,
+`Divisor.pushforwardAlong φ hφ` are the group homomorphisms `Divisor.pullback`,
+`Divisor.pushforward` taken there.
+
+For a pair $\varphi, \psi : F \to_{\mathrm{alg}[K]} F'$ of integral maps, `Divisor.correspondence φ
+ψ hφ hψ` is the additive endomorphism $\psi_* \circ \varphi^*$ of $\mathrm{Divisor}\,K\,F$: pull
+back along $\varphi$, push forward along $\psi$. Its degree satisfies $\deg =
+(\operatorname{finrankAlong} K\,\varphi)\cdot\deg$ under the fundamental identity along the
+pull-back leg; it preserves degree-zero divisors under the same hypothesis, and preserves principal
+divisors given finiteness and the norm formula along the push-forward leg. Combining these,
+`Pic0.degZeroCorrespondence` restricts it to degree-zero divisors and `Pic0.correspondence φ ψ hφ hψ
+hFI hfin hN` descends it to an additive endomorphism of $\mathrm{Pic}^0\,K\,F$; note the hypothesis
+split, the fundamental identity on $\varphi$ and finiteness plus norm formula on $\psi$. The
+remaining declarations are the place calculus along $\varphi$ (`Place.restrictAlong`,
+`ramificationIndexAlong`, `inertiaDegAlong`, `fiberAlong`, the valuation identity
+$\operatorname{ord}_w(\varphi f) = e_w \cdot \operatorname{ord}_{w|_F}(f)$, and the single-place
+formulas for pull-back and push-forward), plus `SemilinearAut.IntertwinesAlong ι g g'`, the
+predicate $g'(\iota x) = \iota(g x)$ for all $x$, together with its closure under inversion,
+identity and multiplication.
+
+**Relation to Mathlib.** `algebraAlong` is Mathlib's `RingHom.toAlgebra` applied to the underlying
+ring homomorphism, deliberately kept as a non-instance abbreviation; the divisor, place and
+$\mathrm{Pic}^0$ notions it is applied to, and the correspondence operator $\psi_*\circ\varphi^*$,
+are the project's own and have no Mathlib counterpart.
+
+**Where it is used.** Applied to the two degeneracy maps of a modular curve, the correspondence
+$\psi_*\circ\varphi^*$ gives the Hecke operators acting on $J_0(N)$, which is where this general
+machinery is used; nothing in the module itself refers to modular curves, levels or primes.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+section AlongHom
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+
+abbrev algebraAlong (φ : F →ₐ[K] F') : Algebra F F' := φ.toRingHom.toAlgebra
+
+theorem isScalarTower_along (φ : F →ₐ[K] F') :
+    letI := algebraAlong φ; IsScalarTower K F F' :=
+  letI := algebraAlong φ
+  IsScalarTower.of_algebraMap_eq fun k => (φ.commutes k).symm
+
+theorem isIntegral_along (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral) :
+    letI := algebraAlong φ; Algebra.IsIntegral F F' :=
+  letI := algebraAlong φ
+  ⟨hφ⟩
+
+variable (K) in
+def FundamentalIdentityAlong (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    [HasPrincipalDivisors K F'] : Prop :=
+  letI := algebraAlong φ
+  haveI := isScalarTower_along φ
+  haveI := isIntegral_along φ hφ
+  FundamentalIdentity K F F'
+
+variable (K) in
+def FiniteAlong (φ : F →ₐ[K] F') : Prop :=
+  letI := algebraAlong φ
+  Module.Finite F F'
+
+variable (K) in
+def NormFormulaAlong (φ : F →ₐ[K] F') (hfin : FiniteAlong K φ) : Prop :=
+  letI := algebraAlong φ
+  haveI := isScalarTower_along φ
+  haveI : Module.Finite F F' := hfin
+  Divisor.PushforwardNormFormula K F F'
+
+variable (K) in
+def finrankAlong (φ : F →ₐ[K] F') : ℕ :=
+  letI := algebraAlong φ
+  Module.finrank F F'
+
+end AlongHom
+
+namespace Divisor
+
+section AlongHom
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+
+section Pullback
+
+variable [HasPrincipalDivisors K F'] (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+
+def pullbackAlong : Divisor K F →+ Divisor K F' :=
+  letI := algebraAlong φ
+  haveI := isScalarTower_along φ
+  haveI := isIntegral_along φ hφ
+  Divisor.pullback F'
+
+theorem isPrincipal_pullbackAlong {D : Divisor K F} (hD : D.IsPrincipal) :
+    (pullbackAlong φ hφ D).IsPrincipal := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  exact Divisor.isPrincipal_pullback hD
+
+theorem degree_pullbackAlong (hFI : FundamentalIdentityAlong K φ hφ) (D : Divisor K F) :
+    degree (pullbackAlong φ hφ D) = (finrankAlong K φ : ℤ) * degree D := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  have : FundamentalIdentity K F F' := hFI
+  exact Divisor.degree_pullback D
+
+theorem pullbackAlong_mem_degZero (hFI : FundamentalIdentityAlong K φ hφ) {D : Divisor K F}
+    (hD : D ∈ degZero (K := K) (F := F)) :
+    pullbackAlong φ hφ D ∈ degZero (K := K) (F := F') := by
+  rw [mem_degZero, degree_pullbackAlong φ hφ hFI, mem_degZero.mp hD, mul_zero]
+
+end Pullback
+
+section Pushforward
+
+variable (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+
+def pushforwardAlong : Divisor K F' →+ Divisor K F :=
+  letI := algebraAlong φ
+  haveI := isScalarTower_along φ
+  haveI := isIntegral_along φ hφ
+  Divisor.pushforward F
+
+@[simp]
+theorem degree_pushforwardAlong (D : Divisor K F') :
+    degree (pushforwardAlong φ hφ D) = degree D := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  exact Divisor.degree_pushforward D
+
+theorem pushforwardAlong_mem_degZero {D : Divisor K F'}
+    (hD : D ∈ degZero (K := K) (F := F')) :
+    pushforwardAlong φ hφ D ∈ degZero (K := K) (F := F) := by
+  rwa [mem_degZero, degree_pushforwardAlong]
+
+theorem isPrincipal_pushforwardAlong (hfin : FiniteAlong K φ)
+    (hN : NormFormulaAlong K φ hfin) {D : Divisor K F'} (hD : D.IsPrincipal) :
+    (pushforwardAlong φ hφ D).IsPrincipal := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  have : Module.Finite F F' := hfin
+  exact Divisor.isPrincipal_pushforward_of_normFormula hN hD
+
+end Pushforward
+
+end AlongHom
+
+section Correspondence
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+variable [HasPrincipalDivisors K F']
+variable (φ ψ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral) (hψ : ψ.toRingHom.IsIntegral)
+
+def correspondence : Divisor K F →+ Divisor K F :=
+  (pushforwardAlong ψ hψ).comp (pullbackAlong φ hφ)
+
+theorem correspondence_apply (D : Divisor K F) :
+    correspondence φ ψ hφ hψ D = pushforwardAlong ψ hψ (pullbackAlong φ hφ D) :=
+  rfl
+
+theorem degree_correspondence (hFI : FundamentalIdentityAlong K φ hφ) (D : Divisor K F) :
+    Divisor.degree (correspondence φ ψ hφ hψ D) = (finrankAlong K φ : ℤ) * Divisor.degree D := by
+  rw [correspondence_apply, degree_pushforwardAlong, degree_pullbackAlong φ hφ hFI]
+
+theorem correspondence_mem_degZero (hFI : FundamentalIdentityAlong K φ hφ) {D : Divisor K F}
+    (hD : D ∈ degZero (K := K) (F := F)) :
+    correspondence φ ψ hφ hψ D ∈ degZero (K := K) (F := F) :=
+  pushforwardAlong_mem_degZero ψ hψ (pullbackAlong_mem_degZero φ hφ hFI hD)
+
+theorem correspondence_mem_principal (hfin : FiniteAlong K ψ)
+    (hN : NormFormulaAlong K ψ hfin) {D : Divisor K F}
+    (hD : D ∈ principal (K := K) (F := F)) :
+    correspondence φ ψ hφ hψ D ∈ principal (K := K) (F := F) :=
+  isPrincipal_pushforwardAlong ψ hψ hfin hN (isPrincipal_pullbackAlong φ hφ hD)
+
+end Correspondence
+
+end Divisor
+
+namespace Pic0
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+variable [HasPrincipalDivisors K F']
+variable (φ ψ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral) (hψ : ψ.toRingHom.IsIntegral)
+variable (hFI : FundamentalIdentityAlong K φ hφ)
+variable (hfin : FiniteAlong K ψ) (hN : NormFormulaAlong K ψ hfin)
+
+def degZeroCorrespondence :
+    Divisor.degZero (K := K) (F := F) →+ Divisor.degZero (K := K) (F := F) :=
+  ((Divisor.correspondence φ ψ hφ hψ).domRestrict
+    (Divisor.degZero (K := K) (F := F))).codRestrict _
+    (fun D => Divisor.correspondence_mem_degZero φ ψ hφ hψ hFI D.2)
+
+@[simp]
+theorem coe_degZeroCorrespondence (D : Divisor.degZero (K := K) (F := F)) :
+    (degZeroCorrespondence φ ψ hφ hψ hFI D : Divisor K F) =
+      Divisor.correspondence φ ψ hφ hψ (D : Divisor K F) :=
+  rfl
+
+def correspondence : Pic0 K F →+ Pic0 K F :=
+  QuotientAddGroup.map _ _ (degZeroCorrespondence φ ψ hφ hψ hFI) (by
+    rintro ⟨D, hD0⟩ hD
+    simp only [AddSubgroup.mem_addSubgroupOf] at hD ⊢
+    exact Divisor.correspondence_mem_principal φ ψ hφ hψ hfin hN hD)
+
+theorem correspondence_mk (D : Divisor.degZero (K := K) (F := F)) :
+    correspondence φ ψ hφ hψ hFI hfin hN (mk D) =
+      mk (degZeroCorrespondence φ ψ hφ hψ hFI D) :=
+  rfl
+
+end Pic0
+
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+
+section AlongPlaces
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+
+def Place.restrictAlong (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral) (w : Place K F') :
+    Place K F :=
+  letI := algebraAlong φ
+  haveI := isScalarTower_along φ
+  haveI := isIntegral_along φ hφ
+  w.restrict F
+
+def Place.ramificationIndexAlong (φ : F →ₐ[K] F') (w : Place K F') : ℕ :=
+  letI := algebraAlong φ
+  w.ramificationIndex F
+
+def Place.inertiaDegAlong (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral) (w : Place K F') :
+    ℕ :=
+  letI := algebraAlong φ
+  haveI := isScalarTower_along φ
+  haveI := isIntegral_along φ hφ
+  w.inertiaDeg F
+
+theorem Place.ord_restrictAlong (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') (f : F) :
+    w.ord (φ f) = Place.ramificationIndexAlong φ w * (w.restrictAlong φ hφ).ord f := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  exact w.ord_restrict f
+
+theorem Divisor.pullbackAlong_apply [HasPrincipalDivisors K F'] (φ : F →ₐ[K] F')
+    (hφ : φ.toRingHom.IsIntegral) (D : Divisor K F) (w : Place K F') :
+    Divisor.pullbackAlong φ hφ D w
+      = Place.ramificationIndexAlong φ w * D (w.restrictAlong φ hφ) := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  exact Divisor.pullback_apply D w
+
+theorem Divisor.pushforwardAlong_single (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') (n : ℤ) :
+    Divisor.pushforwardAlong φ hφ (Finsupp.single w n)
+      = Finsupp.single (w.restrictAlong φ hφ) (n * w.inertiaDegAlong φ hφ) := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  exact Divisor.pushforward_single w n
+
+end AlongPlaces
+
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+
+variable {K F F₁ Z : Type*} [Field K] [Field F] [Field F₁] [Field Z]
+  [Algebra K F] [Algebra K F₁] [Algebra K Z]
+
+namespace Place
+
+theorem restrictAlong_congr {φ φ' : F →ₐ[K] F₁} (h : φ = φ')
+    (hφ : φ.toRingHom.IsIntegral) (hφ' : φ'.toRingHom.IsIntegral) (w : Place K F₁) :
+    w.restrictAlong φ hφ = w.restrictAlong φ' hφ' := by
+  subst h
+  rfl
+
+section Fiber
+
+variable [HasPrincipalDivisors K Z]
+
+def fiberAlong (u : F₁ →ₐ[K] Z) (hu : u.toRingHom.IsIntegral) (w₁ : Place K F₁) :
+    Finset (Place K Z) :=
+  letI := algebraAlong u
+  haveI := isScalarTower_along u
+  haveI := isIntegral_along u hu
+  Place.fiber Z w₁
+
+@[simp]
+theorem mem_fiberAlong {u : F₁ →ₐ[K] Z} {hu : u.toRingHom.IsIntegral} {w₁ : Place K F₁}
+    {W : Place K Z} : W ∈ fiberAlong u hu w₁ ↔ W.restrictAlong u hu = w₁ := by
+  let := algebraAlong u
+  have := isScalarTower_along u
+  have := isIntegral_along u hu
+  exact Place.mem_fiber
+
+theorem _root_.AlgebraicCurve.Divisor.pullbackAlong_single (u : F₁ →ₐ[K] Z)
+    (hu : u.toRingHom.IsIntegral) (w₁ : Place K F₁) (n : ℤ) :
+    Divisor.pullbackAlong u hu (Finsupp.single w₁ n)
+      = ∑ W ∈ fiberAlong u hu w₁,
+          Finsupp.single W (n * W.ramificationIndexAlong u) := by
+  let := algebraAlong u
+  have := isScalarTower_along u
+  have := isIntegral_along u hu
+  exact Divisor.pullback_single w₁ n
+
+end Fiber
+
+end Place
+
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+
+section AlongTransport
+
+variable {K F F₁ : Type*} [Field K] [Field F] [Field F₁] [Algebra K F] [Algebra K F₁]
+
+variable (K) in
+def SeparableAlong (φ : F →ₐ[K] F₁) : Prop :=
+  letI := algebraAlong φ
+  Algebra.IsSeparable F F₁
+
+end AlongTransport
+
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+
+namespace SemilinearAut
+
+section Intertwines
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+
+def IntertwinesAlong (ι : F →+* F') (g : SemilinearAut K F) (g' : SemilinearAut K F') : Prop :=
+  ∀ x : F, g' • (ι x) = ι (g • x)
+
+theorem IntertwinesAlong.inv {ι : F →+* F'} {g : SemilinearAut K F} {g' : SemilinearAut K F'}
+    (h : IntertwinesAlong ι g g') : IntertwinesAlong ι g⁻¹ g'⁻¹ := fun x => by
+  have hx := h (g⁻¹ • x)
+  rw [smul_inv_smul] at hx
+  rw [← hx, inv_smul_smul]
+
+theorem IntertwinesAlong.one (ι : F →+* F') :
+    IntertwinesAlong ι (1 : SemilinearAut K F) (1 : SemilinearAut K F') := fun x => by
+  rw [one_smul, one_smul]
+
+theorem IntertwinesAlong.mul {ι : F →+* F'} {g₁ g₂ : SemilinearAut K F}
+    {g₁' g₂' : SemilinearAut K F'} (h₁ : IntertwinesAlong ι g₁ g₁')
+    (h₂ : IntertwinesAlong ι g₂ g₂') : IntertwinesAlong ι (g₁ * g₂) (g₁' * g₂') := fun x => by
+  rw [mul_smul, mul_smul, h₂ x, h₁ (g₂ • x)]
+
+end Intertwines
+
+end SemilinearAut
+
+end AlgebraicCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_DifferentialPushPull.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_DifferentialPushPull.lean
new file mode 100644
index 0000000000..1c5c189555
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_DifferentialPushPull.lean
@@ -0,0 +1,133 @@
+/-
+Based on Prove2Me node AlgebraicCurve_DifferentialPushPull
+(c1a9dbd1-ced2-5613-9372-5611e8b36dea) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.Etale.Field
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+
+/-!
+# Pull-back, trace and correspondence maps on Kähler differentials
+
+Definition: `AlgebraicCurve_DifferentialPushPull` (`c1a9dbd1-ced2-5613-9372-5611e8b36dea`), by
+Claude, 2026-09-05.
+
+Throughout, $K$, $F$, $F'$ are fields with $F$, $F'$ algebras over $K$, and the maps considered are
+$K$-algebra homomorphisms $\varphi:F\to F'$; no `Algebra F F'` instance is fixed globally, so that
+two embeddings of the same pair of fields can be used simultaneously. Each $\varphi$ determines an
+$F$-algebra structure on $F'$ (`algebraAlong`, the algebra given by $\varphi$ viewed as a ring
+homomorphism) together with the tower $K\subseteq F\subseteq F'$, and the constructions here are
+made relative to that structure. `pullbackAlong φ` is the $K$-linear map
+$\Omega_{F/K}\to\Omega_{F'/K}$ obtained from Mathlib's functoriality of Kähler differentials; it is
+characterised by $D_{F/K}f\mapsto D_{F'/K}(\varphi f)$ and satisfies
+$\varphi^*(f\cdot\omega)=\varphi(f)\cdot\varphi^*\omega$. `traceAlong φ` is the $K$-linear map
+$\Omega_{F'/K}\to\Omega_{F/K}$ defined by a case distinction on the predicate `SeparableAlong K φ`,
+which says that $F'$ is a separable $F$-algebra for the structure induced by $\varphi$: in that case
+$F'$ is formally étale over $F$, so the canonical base-change map identifies
+$F'\otimes_F\Omega_{F/K}$ with $\Omega_{F'/K}$, and `traceAlong φ` is the composite of the inverse
+of this identification with $\mathrm{Tr}_{F'/F}\otimes\mathrm{id}$ and the identification
+$F\otimes_F\Omega_{F/K}\cong\Omega_{F/K}$; otherwise it is the zero map. Its characteristic property
+is recorded as $\operatorname{tr}_\varphi(u\cdot\varphi^*\omega)=\mathrm{Tr}_{F'/F}(u)\cdot\omega$
+for $u\in F'$ and $\omega\in\Omega_{F/K}$, under the separability hypothesis. Finally, for two
+$K$-algebra homomorphisms $\varphi,\psi:F\to F'$, `correspondence φ ψ` is the $K$-endomorphism
+$\operatorname{tr}_\varphi\circ\psi^*$ of $\Omega_{F/K}$, with the pull-back taken along $\psi$ and
+the trace along $\varphi$; a companion lemma states this pointwise. No further properties
+(invariance of regular differentials, compatibility with composition) are asserted here.
+
+**Relation to Mathlib.** The pull-back is Mathlib's `KaehlerDifferential.map`, and the separable
+case of the trace uses Mathlib's `KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale` together
+with `Algebra.trace`; what is new is the packaging along a $K$-algebra homomorphism rather than a
+registered `Algebra F F'` instance, and the resulting trace map on differentials, which Mathlib does
+not provide.
+
+**Where it is used.** These maps supply the action on differentials of a correspondence between
+curves whose function-field legs are $\varphi$ and $\psi$, matching in argument order the divisor-
+and $\mathrm{Pic}^0$-level correspondence $\psi_*\varphi^*$ defined for the same pair of embeddings.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open KaehlerDifferential TensorProduct
+
+namespace AlgebraicCurve
+
+namespace Differential
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+
+def pullbackAlong (φ : F →ₐ[K] F') : Ω[F⁄K] →ₗ[K] Ω[F'⁄K] :=
+  letI := algebraAlong φ
+  haveI := isScalarTower_along φ
+  (KaehlerDifferential.map K K F F').restrictScalars K
+
+theorem pullbackAlong_D (φ : F →ₐ[K] F') (f : F) :
+    pullbackAlong φ (D K F f) = D K F' (φ f) := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  exact KaehlerDifferential.map_D K K F F' f
+
+theorem pullbackAlong_smul (φ : F →ₐ[K] F') (f : F) (ω : Ω[F⁄K]) :
+    pullbackAlong φ (f • ω) = φ f • pullbackAlong φ ω := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  change KaehlerDifferential.map K K F F' (f • ω) = _
+  rw [LinearMap.map_smul_of_tower]
+  rfl
+
+open Classical in
+def traceAlong (φ : F →ₐ[K] F') : Ω[F'⁄K] →ₗ[K] Ω[F⁄K] :=
+  if h : SeparableAlong K φ then
+    letI := algebraAlong φ
+    haveI := isScalarTower_along φ
+    haveI : Algebra.IsSeparable F F' := h
+    haveI : Algebra.FormallyEtale F F' := Algebra.FormallyEtale.of_isSeparable F F'
+    ((TensorProduct.lid F Ω[F⁄K]).toLinearMap ∘ₗ
+      (Algebra.trace F F').rTensor Ω[F⁄K] ∘ₗ
+      (KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale K F
+        F').symm.toLinearMap).restrictScalars K
+  else 0
+
+theorem traceAlong_smul_pullbackAlong (φ : F →ₐ[K] F') (h : SeparableAlong K φ) (u : F')
+    (ω : Ω[F⁄K]) :
+    traceAlong φ (u • pullbackAlong φ ω) =
+      (letI := algebraAlong φ; Algebra.trace F F' u) • ω := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have : Algebra.IsSeparable F F' := h
+  have : Algebra.FormallyEtale F F' := Algebra.FormallyEtale.of_isSeparable F F'
+  rw [traceAlong, dite_eq_left h]
+  simp only [LinearMap.coe_restrictScalars, LinearMap.coe_comp, LinearEquiv.coe_coe,
+    Function.comp_apply]
+  have hsymm : (KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale K F F').symm
+      (u • pullbackAlong φ ω) = u ⊗ₜ ω := by
+    rw [LinearEquiv.symm_apply_eq, KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale_apply,
+      KaehlerDifferential.mapBaseChange_tmul]
+    rfl
+  rw [hsymm, LinearMap.rTensor_tmul, TensorProduct.lid_tmul]
+
+theorem traceAlong_of_not (φ : F →ₐ[K] F') (h : ¬ SeparableAlong K φ) : traceAlong φ = 0 := by
+  rw [traceAlong, dite_eq_right h]
+
+def correspondence (φ ψ : F →ₐ[K] F') : Ω[F⁄K] →ₗ[K] Ω[F⁄K] :=
+  traceAlong φ ∘ₗ pullbackAlong ψ
+
+theorem correspondence_apply (φ ψ : F →ₐ[K] F') (ω : Ω[F⁄K]) :
+    correspondence φ ψ ω = traceAlong φ (pullbackAlong ψ ω) := rfl
+
+end Differential
+
+end AlgebraicCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_Differentials.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_Differentials.lean
new file mode 100644
index 0000000000..c1e36fb826
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_Differentials.lean
@@ -0,0 +1,138 @@
+/-
+Based on Prove2Me node AlgebraicCurve_Differentials
+(78e3bfe6-b445-5d4f-83bb-7a59516bb321) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import Mathlib.RingTheory.Kaehler.Basic
+
+/-!
+# Order of a differential at a place; regular differentials
+
+Definition: `AlgebraicCurve_Differentials` (`78e3bfe6-b445-5d4f-83bb-7a59516bb321`), by Claude,
+2026-09-05.
+
+The module works over a field extension $K \subseteq F$ and takes the differentials of $F/K$ to be
+Mathlib's module of Kähler differentials $\Omega[F\!\mid\!K]$ with its universal derivation $D =$
+`KaehlerDifferential.D K F`; the places of $F/K$ and their $\mathbb{Z}$-valued order function
+`Place.ord` (normalised so that an irreducible element of the valuation ring has order $1$, and with
+$\operatorname{ord} 0 = 0$) are those of the divisor-class-group module. Four total, choice-based
+definitions are made. For a place $v$, `Place.uniformizer_alt` is a chosen $t \in F$ with
+$v.\mathrm{ord}\,t = 1$ when such a $t$ exists and $0$ otherwise; `ord_uniformizer_alt` records that
+under the hypothesis that some element of order $1$ exists, the chosen element has order $1$. For $t
+\in F$ and $\omega \in \Omega[F\!\mid\!K]$, `Place.diffCoeff t ω` is a chosen $g \in F$ with $\omega
+= g \cdot D t$ when $\omega$ lies in the $F$-line through $D t$, and $0$ otherwise;
+`diffCoeff_smul_D` and `diffCoeff_of_not_exists` are the two defining cases. The order of $\omega$
+at $v$ is then $v.\mathrm{ordDiff}\,\omega = v.\mathrm{ord}\big(\mathrm{diffCoeff}\
+v.\mathrm{uniformizer\_alt}\ \omega\big)$, a total $\mathbb{Z}$-valued quantity which takes the
+default value $0$ in the degenerate cases; accordingly the existence of a uniformizer, the
+uniqueness of the coefficient $g$ and the independence of `ordDiff` of the chosen uniformizer are
+assertions external to these definitions. A differential is regular, `IsRegularDiff K F ω`, when $0
+\le v.\mathrm{ordDiff}\,\omega$ for every place $v$, and `regularDiffs K F` is defined as the
+$K$-span of the set of regular differentials, a $K$-submodule of $\Omega[F\!\mid\!K]$ containing
+every regular differential. Finally, for a $K$-algebra map $\varphi : F \to F'$ into a second field,
+`pullbackDiff φ` is the $K$-linear map $\Omega[F\!\mid\!K] \to \Omega[F'\!\mid\!K]$ coming from
+`KaehlerDifferential.map` for the $F$-algebra structure on $F'$ given by $\varphi$; it sends
+$D_{F/K}x$ to $D_{F'/K}(\varphi x)$.
+
+**Relation to Mathlib.** The carrier and universal derivation are Mathlib's `KaehlerDifferential`
+module $\Omega[F⁄K]$, and `pullbackDiff` is `KaehlerDifferential.map` for the algebra structure
+induced by a $K$-algebra map, restricted to $K$-scalars. The order of a differential at a place, the
+predicate of regularity and the submodule of regular differentials are the project's own notions,
+built on the places and order function of the project's divisor module.
+
+**Where it is used.** These notions belong to the project's self-contained divisor and differential
+theory of function fields, alongside places, divisors, the degree map and the torsion of
+$\mathrm{Pic}^0$; the regular differentials and the order function at a place are the objects over
+which the genus-type statements used in the curve-theoretic part of the development are formulated.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open KaehlerDifferential
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable (v : Place K F)
+
+open Classical in
+def uniformizer_alt : F :=
+  if h : ∃ t : F, v.ord t = 1 then h.choose else 0
+
+theorem ord_uniformizer_alt (h : ∃ t : F, v.ord t = 1) : v.ord v.uniformizer_alt = 1 := by
+  rw [uniformizer_alt, dite_eq_left h]
+  exact h.choose_spec
+
+open Classical in
+def diffCoeff (t : F) (ω : Ω[F⁄K]) : F :=
+  if h : ∃ g : F, ω = g • D K F t then h.choose else 0
+
+theorem diffCoeff_smul_D {t : F} {ω : Ω[F⁄K]} (h : ∃ g : F, ω = g • D K F t) :
+    diffCoeff t ω • D K F t = ω := by
+  rw [diffCoeff, dite_eq_left h]
+  exact h.choose_spec.symm
+
+theorem diffCoeff_of_not_exists {t : F} {ω : Ω[F⁄K]} (h : ¬ ∃ g : F, ω = g • D K F t) :
+    diffCoeff t ω = 0 := by
+  rw [diffCoeff, dite_eq_right h]
+
+def ordDiff (ω : Ω[F⁄K]) : ℤ :=
+  v.ord (diffCoeff v.uniformizer_alt ω)
+
+theorem ordDiff_def (ω : Ω[F⁄K]) : v.ordDiff ω = v.ord (diffCoeff v.uniformizer_alt ω) := rfl
+
+end Place
+
+variable (K F) in
+def IsRegularDiff (ω : Ω[F⁄K]) : Prop :=
+  ∀ v : Place K F, 0 ≤ v.ordDiff ω
+
+theorem isRegularDiff_iff (ω : Ω[F⁄K]) :
+    IsRegularDiff K F ω ↔ ∀ v : Place K F, 0 ≤ v.ordDiff ω := Iff.rfl
+
+variable (K F) in
+def regularDiffs : Submodule K Ω[F⁄K] :=
+  Submodule.span K {ω : Ω[F⁄K] | IsRegularDiff K F ω}
+
+theorem mem_regularDiffs_of_isRegularDiff {ω : Ω[F⁄K]} (h : IsRegularDiff K F ω) :
+    ω ∈ regularDiffs K F :=
+  Submodule.subset_span h
+
+theorem regularDiffs_eq_span :
+    regularDiffs K F = Submodule.span K {ω : Ω[F⁄K] | IsRegularDiff K F ω} := rfl
+
+section Pullback
+
+variable {F' : Type*} [Field F'] [Algebra K F']
+
+def pullbackDiff (φ : F →ₐ[K] F') : Ω[F⁄K] →ₗ[K] Ω[F'⁄K] :=
+  letI : Algebra F F' := φ.toRingHom.toAlgebra
+  haveI : IsScalarTower K F F' := IsScalarTower.of_algebraMap_eq fun k => (φ.commutes k).symm
+  (KaehlerDifferential.map K K F F').restrictScalars K
+
+theorem pullbackDiff_D (φ : F →ₐ[K] F') (x : F) :
+    pullbackDiff φ (D K F x) = D K F' (φ x) := by
+  let : Algebra F F' := φ.toRingHom.toAlgebra
+  have : IsScalarTower K F F' := IsScalarTower.of_algebraMap_eq fun k => (φ.commutes k).symm
+  exact KaehlerDifferential.map_D K K F F' x
+
+end Pullback
+
+end AlgebraicCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_DivisorClassGroup.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_DivisorClassGroup.lean
new file mode 100644
index 0000000000..fc0b88bc2e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_DivisorClassGroup.lean
@@ -0,0 +1,521 @@
+/-
+Based on Prove2Me node AlgebraicCurve_DivisorClassGroup
+(10001017-d65a-5012-a2fd-602421b3ec65) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.Valuation.Discrete.IsDiscreteValuationRing
+
+/-!
+# Places, divisors and the divisor class group of F/K
+
+Definition: `AlgebraicCurve_DivisorClassGroup` (`10001017-d65a-5012-a2fd-602421b3ec65`), by Claude,
+2026-09-05.
+
+Fix fields $K\subseteq F$ (an arbitrary algebra of fields, with no function-field hypothesis
+imposed). A `Place K F` is a structure with four fields: a valuation subring $\mathcal{O}\subseteq
+F$; the requirement that $\mathcal{O}$ contain the image of $K$; the requirement
+$\mathcal{O}\neq\top$, i.e. $\mathcal{O}\neq F$; and the requirement that $\mathcal{O}$ be a
+principal ideal ring. Since a proper valuation subring is not a field
+([`ValuationSubring.not_isField_of_ne_top`](../def/AlgebraicCurve_DivisorClassGroup.html#L32),
+proved here in Mathlib's root namespace), these data yield instances making $\mathcal{O}$ a discrete
+valuation ring, a $K$-algebra, and part of a tower $K\subseteq\mathcal{O}\subseteq F$. Attached to
+$v$ are its residue field $\kappa(v)$, the degree `deg v` $=\operatorname{finrank}_K\kappa(v)$ (a
+natural number, hence $0$ when $\kappa(v)/K$ is infinite), the class `FiniteResidue` asserting
+$\kappa(v)/K$ finite, the $\mathfrak{m}_v$-adic valuation `adicValuation` with values in
+$\mathbb{Z}^{m0}$, and `ord v f := -\log` of that valuation, normalised so that a uniformiser has
+order $1$ and, by convention, $\operatorname{ord}_v 0=0$; the accompanying lemmas give additivity on
+nonzero elements, behaviour under inverses and integer powers, vanishing on units, and the
+factorisation $f=u\pi^{\operatorname{ord}_v f}$.
+
+`Divisor K F` is the abbreviation for finitely supported functions
+$\mathrm{Place}\,K\,F\to\mathbb{Z}$; `degree` is the additive map $D\mapsto\sum_v D(v)\deg v$,
+`degZero` its kernel, `IsPrincipal D` says that some $f\neq 0$ has $D(v)=\operatorname{ord}_v f$ for
+all $v$, and `principal` is the resulting subgroup. The class `HasPrincipalDivisors` carries, as a
+hypothesis rather than a theorem, the assertion that each $f\neq 0$ has such a finitely supported
+divisor of degree $0$. `Pic` and `Pic0` are the quotients of all divisors, resp. of degree-zero
+divisors, by principal divisors, with `Pic0.torsion K F n` the $n$-torsion $\{x : n\cdot x=0\}$.
+`AbelJacobiCard K F p g` is the predicate (not proved here) that $\#\mathrm{Pic}^0[p^n]=p^{2gn}$ for
+all $n$. Finally, $F\simeq_K F$ acts on places by pointwise transport of the valuation subring,
+preserving `ord` and `deg`, hence acts on divisors by pushforward of support, preserving degree,
+`degZero` and `principal`, and so acts on `Pic0`. `Place.ofHeightOneSpectrum` produces a place from
+a height-one prime of a Dedekind domain $R$ with $K\subseteq R$ and fraction field $F$.
+
+**Relation to Mathlib.** Mathlib supplies valuation subrings, height-one spectra of Dedekind domains
+and their adic valuations, but no notion of place, divisor or divisor class group of a field
+extension; those are the project's own, built on Mathlib's `ValuationSubring`, `Finsupp` and
+`QuotientAddGroup`. Two auxiliary lemmas,
+[`ValuationSubring.not_isField_of_ne_top`](../def/AlgebraicCurve_DivisorClassGroup.html#L32) and
+[`ValuationSubring.pointwise_smul_top`](../def/AlgebraicCurve_DivisorClassGroup.html#L279), are
+declared in Mathlib's root namespace.
+
+**Where it is used.** This is the generic divisor-theoretic layer for an algebraic treatment of
+modular curves: places, divisors and $\mathrm{Pic}^0$ of the function field of $X_0(N)$, together
+with the automorphism action used to carry Hecke and Galois actions on the Jacobian and its
+$p$-power torsion. By itself it proves nothing about any particular curve.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public noncomputable section publicSection
+
+open IsDedekindDomain WithZero IsLocalRing
+
+namespace AlgebraicCurve
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+structure Place where
+  toValuationSubring : ValuationSubring F
+  algebraMap_mem' : ∀ a : K, algebraMap K F a ∈ toValuationSubring
+  ne_top' : toValuationSubring ≠ ⊤
+  isPrincipalIdealRing' : IsPrincipalIdealRing toValuationSubring
+
+theorem _root_.ValuationSubring.not_isField_of_ne_top {A : ValuationSubring F} (hA : A ≠ ⊤) :
+    ¬IsField A := by
+  intro hf
+  apply hA
+  refine SetLike.ext fun x => ⟨fun _ => ValuationSubring.mem_top x, fun _ => ?_⟩
+  by_cases hx : x ∈ A
+  · exact hx
+  · exfalso
+    have hx0 : x ≠ 0 := fun h => hx (h ▸ A.zero_mem)
+    have hxi : x⁻¹ ∈ A := (A.mem_or_inv_mem x).resolve_left hx
+    have hxi0 : (⟨x⁻¹, hxi⟩ : A) ≠ 0 := by
+      simp only [ne_eq, Subtype.ext_iff]
+      exact inv_ne_zero hx0
+    obtain ⟨b, hb⟩ := hf.mul_inv_cancel hxi0
+    have hb' : x⁻¹ * (b : F) = 1 := by
+      have h := congrArg (Subtype.val) hb
+      simpa using h
+    grind
+
+namespace Place
+
+variable {K F}
+
+theorem toValuationSubring_injective :
+    Function.Injective (toValuationSubring (K := K) (F := F)) := by
+  rintro ⟨a, _, _, _⟩ ⟨b, _, _, _⟩ (rfl : a = b)
+  rfl
+
+@[ext]
+theorem ext {v w : Place K F} (h : v.toValuationSubring = w.toValuationSubring) : v = w :=
+  toValuationSubring_injective h
+
+variable (v : Place K F)
+
+instance : IsPrincipalIdealRing v.toValuationSubring := v.isPrincipalIdealRing'
+
+instance : IsDiscreteValuationRing v.toValuationSubring where
+  not_a_field' := by
+    rw [ne_eq, ← IsLocalRing.isField_iff_maximalIdeal_eq]
+    exact ValuationSubring.not_isField_of_ne_top F v.ne_top'
+
+instance : Algebra K v.toValuationSubring :=
+  ((algebraMap K F).codRestrict v.toValuationSubring.toSubring v.algebraMap_mem').toAlgebra
+
+@[simp]
+theorem coe_algebraMap (a : K) :
+    (algebraMap K v.toValuationSubring a : F) = algebraMap K F a := rfl
+
+instance : IsScalarTower K v.toValuationSubring F :=
+  IsScalarTower.of_algebraMap_eq fun a => (v.coe_algebraMap a).symm
+
+abbrev ResidueField : Type _ := IsLocalRing.ResidueField v.toValuationSubring
+
+def deg : ℕ := Module.finrank K v.ResidueField
+
+class FiniteResidue : Prop where
+  finite : Module.Finite K v.ResidueField
+
+def heightOneSpectrum : HeightOneSpectrum v.toValuationSubring :=
+  IsDiscreteValuationRing.maximalIdeal _
+
+@[simp]
+theorem heightOneSpectrum_asIdeal :
+    v.heightOneSpectrum.asIdeal = IsLocalRing.maximalIdeal v.toValuationSubring := rfl
+
+def adicValuation : Valuation F ℤᵐ⁰ := v.heightOneSpectrum.valuation F
+
+theorem adicValuation_ne_zero {f : F} (hf : f ≠ 0) : v.adicValuation f ≠ 0 :=
+  (Valuation.ne_zero_iff _).mpr hf
+
+theorem adicValuation_coe (a : v.toValuationSubring) :
+    v.adicValuation (a : F) = v.heightOneSpectrum.intValuation a := by
+  simpa [adicValuation] using v.heightOneSpectrum.valuation_of_algebraMap (K := F) a
+
+theorem adicValuation_coe_eq_one_iff (a : v.toValuationSubring) :
+    v.adicValuation (a : F) = 1 ↔ IsUnit a := by
+  rw [v.adicValuation_coe, HeightOneSpectrum.intValuation_eq_one_iff, heightOneSpectrum_asIdeal,
+    IsLocalRing.mem_maximalIdeal, mem_nonunits_iff, not_not]
+
+theorem adicValuation_coe_irreducible {π : v.toValuationSubring} (hπ : Irreducible π) :
+    v.adicValuation (π : F) = exp (-1 : ℤ) := by
+  rw [v.adicValuation_coe]
+  exact HeightOneSpectrum.intValuation_singleton _ hπ.ne_zero
+    (by rw [heightOneSpectrum_asIdeal, hπ.maximalIdeal_eq])
+
+def ord (f : F) : ℤ := -(WithZero.log (v.adicValuation f))
+
+@[simp]
+theorem ord_zero : v.ord (0 : F) = 0 := by simp [ord]
+
+@[simp]
+theorem ord_one : v.ord (1 : F) = 0 := by simp [ord]
+
+theorem ord_mul {f g : F} (hf : f ≠ 0) (hg : g ≠ 0) :
+    v.ord (f * g) = v.ord f + v.ord g := by
+  simp only [ord, map_mul]
+  rw [WithZero.log_mul (v.adicValuation_ne_zero hf) (v.adicValuation_ne_zero hg)]
+  ring
+
+theorem ord_inv (f : F) : v.ord f⁻¹ = -v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · simp
+  · simp only [ord, map_inv₀, WithZero.log_inv, neg_neg]
+
+theorem ord_coe_unit (u : v.toValuationSubringˣ) :
+    v.ord ((u : v.toValuationSubring) : F) = 0 := by
+  simp [ord, (v.adicValuation_coe_eq_one_iff _).mpr u.isUnit]
+
+theorem ord_coe_irreducible {π : v.toValuationSubring} (hπ : Irreducible π) :
+    v.ord (π : F) = 1 := by
+  simp [ord, v.adicValuation_coe_irreducible hπ]
+
+theorem ord_zpow (f : F) (n : ℤ) : v.ord (f ^ n) = n * v.ord f := by
+  simp only [ord, map_zpow₀, WithZero.log_zpow, smul_eq_mul]
+  ring
+
+theorem ord_unit_smul_zpow (u : v.toValuationSubringˣ) {π : v.toValuationSubring}
+    (hπ : Irreducible π) (n : ℤ) :
+    v.ord (((u : v.toValuationSubring) : F) * ((π : F) ^ n)) = n := by
+  have hπF : (π : F) ≠ 0 := by
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have hu : ((u : v.toValuationSubring) : F) ≠ 0 := by
+    simp [ne_eq, ZeroMemClass.coe_eq_zero]
+  rw [v.ord_mul hu (zpow_ne_zero n hπF), v.ord_coe_unit u, zero_add,
+    v.ord_zpow _ _, v.ord_coe_irreducible hπ, mul_one]
+
+theorem exists_unit_mul_zpow {f : F} (hf : f ≠ 0) {π : v.toValuationSubring}
+    (hπ : Irreducible π) :
+    ∃ u : v.toValuationSubringˣ,
+      f = ((u : v.toValuationSubring) : F) * ((π : F) ^ (v.ord f)) := by
+  obtain ⟨n, u, hu⟩ :=
+    IsDiscreteValuationRing.exists_units_eq_smul_zpow_of_irreducible (K := F) hπ hf
+  rw [Units.smul_def, Algebra.smul_def] at hu
+  have hcoe : algebraMap v.toValuationSubring F (u : v.toValuationSubring)
+      = ((u : v.toValuationSubring) : F) := rfl
+  have hcoe' : algebraMap v.toValuationSubring F π = (π : F) := rfl
+  rw [hcoe, hcoe'] at hu
+  have hn : v.ord f = n := by
+    rw [hu]
+    exact v.ord_unit_smul_zpow u hπ n
+  grind
+
+end Place
+
+abbrev Divisor : Type _ := Place K F →₀ ℤ
+
+namespace Divisor
+
+variable {K F}
+
+def degree : Divisor K F →+ ℤ :=
+  Finsupp.liftAddHom fun v => AddMonoidHom.mulRight (v.deg : ℤ)
+
+@[simp]
+theorem degree_single (v : Place K F) (n : ℤ) :
+    degree (Finsupp.single v n) = n * v.deg := by
+  simp [degree]
+
+def degZero : AddSubgroup (Divisor K F) := degree.ker
+
+theorem mem_degZero {D : Divisor K F} : D ∈ degZero (K := K) (F := F) ↔ degree D = 0 :=
+  Iff.rfl
+
+def IsPrincipal (D : Divisor K F) : Prop := ∃ f : F, f ≠ 0 ∧ ∀ v : Place K F, D v = v.ord f
+
+def principal : AddSubgroup (Divisor K F) where
+  carrier := {D | IsPrincipal D}
+  zero_mem' := ⟨1, one_ne_zero, fun v => by simp⟩
+  add_mem' := by
+    rintro D E ⟨f, hf, hD⟩ ⟨g, hg, hE⟩
+    exact ⟨f * g, mul_ne_zero hf hg, fun v => by
+      rw [Finsupp.add_apply, hD v, hE v, v.ord_mul hf hg]⟩
+  neg_mem' := by
+    rintro D ⟨f, hf, hD⟩
+    exact ⟨f⁻¹, inv_ne_zero hf, fun v => by
+      rw [Finsupp.neg_apply, hD v, v.ord_inv]⟩
+
+theorem mem_principal {D : Divisor K F} :
+    D ∈ principal (K := K) (F := F) ↔ IsPrincipal D := Iff.rfl
+
+end Divisor
+
+class HasPrincipalDivisors : Prop where
+  exists_divisor : ∀ f : F, f ≠ 0 → ∃ D : Divisor K F,
+    (∀ v : Place K F, D v = v.ord f) ∧ Divisor.degree D = 0
+
+abbrev Pic : Type _ := Divisor K F ⧸ Divisor.principal (K := K) (F := F)
+
+abbrev Pic0 : Type _ :=
+  Divisor.degZero (K := K) (F := F) ⧸
+    (Divisor.principal (K := K) (F := F)).addSubgroupOf (Divisor.degZero (K := K) (F := F))
+
+namespace Pic0
+
+variable {K F}
+
+def mk (D : Divisor.degZero (K := K) (F := F)) : Pic0 K F := QuotientAddGroup.mk D
+
+theorem mk_surjective : Function.Surjective (mk (K := K) (F := F)) :=
+  QuotientAddGroup.mk_surjective
+
+@[simp]
+theorem mk_add (D E : Divisor.degZero (K := K) (F := F)) : mk (D + E) = mk D + mk E := rfl
+
+@[simp]
+theorem mk_zero : mk (0 : Divisor.degZero (K := K) (F := F)) = 0 := rfl
+
+variable (K F) in
+def torsion (n : ℕ) : AddSubgroup (Pic0 K F) :=
+  (Submodule.torsionBy ℤ (Pic0 K F) (n : ℤ)).toAddSubgroup
+
+theorem mem_torsion {n : ℕ} {x : Pic0 K F} : x ∈ torsion K F n ↔ (n : ℤ) • x = 0 :=
+  Submodule.mem_torsionBy_iff _ _
+
+end Pic0
+
+def AbelJacobiCard (p : ℕ) (g : ℕ) : Prop :=
+  ∀ n : ℕ, Nat.card (Pic0.torsion K F (p ^ n)) = p ^ (2 * g * n)
+
+namespace Place
+
+open scoped Pointwise
+
+variable {K F}
+variable (σ : F ≃ₐ[K] F)
+
+def smulRingEquiv (A : ValuationSubring F) : A ≃+* (σ • A : ValuationSubring F) where
+  toFun x := ⟨σ x, by
+    simpa [AlgEquiv.smul_def] using
+      ValuationSubring.smul_mem_pointwise_smul σ (x : F) A x.2⟩
+  invFun y := ⟨σ.symm y, by
+    have := (ValuationSubring.mem_pointwise_smul_iff_inv_smul_mem (g := σ)
+      (S := A) (x := (y : F))).mp y.2
+    simpa [AlgEquiv.smul_def, AlgEquiv.aut_inv] using this⟩
+  left_inv x := by ext; simp
+  right_inv y := by ext; simp
+  map_mul' x y := by ext; simp
+  map_add' x y := by ext; simp
+
+@[simp]
+theorem coe_smulRingEquiv_apply (A : ValuationSubring F) (x : A) :
+    ((smulRingEquiv σ A x : (σ • A : ValuationSubring F)) : F) = σ x := rfl
+
+theorem _root_.ValuationSubring.pointwise_smul_top :
+    σ • (⊤ : ValuationSubring F) = ⊤ := by
+  ext x
+  simp only [ValuationSubring.mem_pointwise_smul_iff_inv_smul_mem]
+  exact ⟨fun _ => ValuationSubring.mem_top x, fun _ => ValuationSubring.mem_top _⟩
+
+instance : SMul (F ≃ₐ[K] F) (Place K F) where
+  smul σ v :=
+    { toValuationSubring := σ • v.toValuationSubring
+      algebraMap_mem' := fun a => by
+        have h := ValuationSubring.smul_mem_pointwise_smul σ (algebraMap K F a)
+          v.toValuationSubring (v.algebraMap_mem' a)
+        rwa [AlgEquiv.smul_def, σ.commutes] at h
+      ne_top' := fun h => v.ne_top' <| by
+        have := congrArg (σ⁻¹ • ·) h
+        simpa [ValuationSubring.pointwise_smul_top] using this
+      isPrincipalIdealRing' :=
+        IsPrincipalIdealRing.of_surjective
+          (smulRingEquiv σ v.toValuationSubring : _ ≃+* _)
+          (smulRingEquiv σ v.toValuationSubring).surjective }
+
+variable (v : Place K F)
+
+@[simp]
+theorem smul_toValuationSubring : (σ • v).toValuationSubring = σ • v.toValuationSubring := rfl
+
+instance : MulAction (F ≃ₐ[K] F) (Place K F) where
+  one_smul v := by
+    ext1
+    rw [smul_toValuationSubring, one_smul]
+  mul_smul σ τ v := by
+    ext1
+    simp only [smul_toValuationSubring]
+    rw [mul_smul]
+
+theorem ord_smul (f : F) : (σ • v).ord (σ f) = v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ
+  set n := v.ord f with hn
+  set e := smulRingEquiv σ v.toValuationSubring with he
+  have hπ' : Irreducible (e π) := (MulEquiv.irreducible_iff e).mpr hπ
+  have hu' : IsUnit (e (u : v.toValuationSubring)) := u.isUnit.map e
+  have hcoeu : ((hu'.unit : (σ • v).toValuationSubring) : F)
+      = σ ((u : v.toValuationSubring) : F) := by
+    rw [IsUnit.unit_spec]
+    rfl
+  have hcoeπ : ((e π : (σ • v).toValuationSubring) : F) = σ (π : F) := rfl
+  have key : σ f = ((hu'.unit : (σ • v).toValuationSubring) : F)
+      * (((e π : (σ • v).toValuationSubring) : F) ^ n) := by
+    rw [hcoeu, hcoeπ, hu, map_mul, map_zpow₀]
+  rw [key, (σ • v).ord_unit_smul_zpow hu'.unit hπ' n]
+
+def smulResidueAlgEquiv : v.ResidueField ≃ₐ[K] (σ • v).ResidueField :=
+  AlgEquiv.ofRingEquiv (f := IsLocalRing.ResidueField.mapEquiv
+      (smulRingEquiv σ v.toValuationSubring)) <| fun a => by
+    have h3 : (smulRingEquiv σ v.toValuationSubring) (algebraMap K v.toValuationSubring a)
+        = algebraMap K (σ • v).toValuationSubring a := by
+      ext
+      rw [coe_smulRingEquiv_apply, coe_algebraMap, σ.commutes]
+      rfl
+    change IsLocalRing.ResidueField.mapEquiv _ (IsLocalRing.residue _ _) = IsLocalRing.residue _ _
+    rw [IsLocalRing.ResidueField.mapEquiv_apply, IsLocalRing.ResidueField.map_residue]
+    exact congrArg _ h3
+
+@[simp]
+theorem deg_smul : (σ • v).deg = v.deg :=
+  ((smulResidueAlgEquiv σ v).toLinearEquiv.finrank_eq).symm
+
+end Place
+
+namespace Divisor
+
+open scoped Pointwise
+
+variable {K F}
+
+instance : DistribMulAction (F ≃ₐ[K] F) (Divisor K F) := Finsupp.comapDistribMulAction
+
+theorem smul_def (σ : F ≃ₐ[K] F) (D : Divisor K F) :
+    σ • D = Finsupp.mapDomain (σ • ·) D := rfl
+
+@[simp]
+theorem smul_single (σ : F ≃ₐ[K] F) (v : Place K F) (n : ℤ) :
+    σ • Finsupp.single v n = Finsupp.single (σ • v) n := by
+  rw [smul_def, Finsupp.mapDomain_single]
+
+theorem smul_apply_smul (σ : F ≃ₐ[K] F) (D : Divisor K F) (v : Place K F) :
+    (σ • D) (σ • v) = D v := by
+  rw [smul_def]
+  exact Finsupp.mapDomain_apply_of_injective (MulAction.injective σ) D v
+
+theorem smul_apply (σ : F ≃ₐ[K] F) (D : Divisor K F) (w : Place K F) :
+    (σ • D) w = D (σ⁻¹ • w) := by
+  have : (σ • D) (σ • (σ⁻¹ • w)) = D (σ⁻¹ • w) := smul_apply_smul σ D (σ⁻¹ • w)
+  rwa [smul_inv_smul] at this
+
+@[simp]
+theorem degree_smul (σ : F ≃ₐ[K] F) (D : Divisor K F) : degree (σ • D) = degree D := by
+  induction D using Finsupp.induction with
+  | zero => simp
+  | single_add v n D _ _ ih =>
+      rw [smul_add, map_add, map_add, ih, smul_single, degree_single, degree_single,
+        Place.deg_smul]
+
+theorem smul_mem_degZero (σ : F ≃ₐ[K] F) {D : Divisor K F}
+    (hD : D ∈ degZero (K := K) (F := F)) : σ • D ∈ degZero (K := K) (F := F) := by
+  rwa [mem_degZero, degree_smul]
+
+theorem smul_mem_principal (σ : F ≃ₐ[K] F) {D : Divisor K F}
+    (hD : D ∈ principal (K := K) (F := F)) : σ • D ∈ principal (K := K) (F := F) := by
+  obtain ⟨f, hf, hD⟩ := hD
+  refine ⟨σ f, by simpa, fun w ↦ ?_⟩
+  have := Place.ord_smul σ (σ⁻¹ • w) f
+  grind [smul_apply, smul_inv_smul]
+
+end Divisor
+
+namespace Pic0
+
+open scoped Pointwise
+
+variable {K F}
+
+def degZeroSMulHom (σ : F ≃ₐ[K] F) :
+    Divisor.degZero (K := K) (F := F) →+ Divisor.degZero (K := K) (F := F) :=
+  ((DistribSMul.toAddMonoidHom (Divisor K F) σ).domRestrict
+    (Divisor.degZero (K := K) (F := F))).codRestrict _
+    (fun D => Divisor.smul_mem_degZero σ D.2)
+
+@[simp]
+theorem coe_degZeroSMulHom (σ : F ≃ₐ[K] F) (D : Divisor.degZero (K := K) (F := F)) :
+    (degZeroSMulHom σ D : Divisor K F) = σ • (D : Divisor K F) := rfl
+
+instance : SMul (F ≃ₐ[K] F) (Pic0 K F) where
+  smul σ := QuotientAddGroup.map _ _ (degZeroSMulHom σ) (by
+    rintro ⟨D, hD0⟩ hD
+    simp only [AddSubgroup.mem_addSubgroupOf] at hD ⊢
+    exact Divisor.smul_mem_principal σ hD)
+
+theorem smul_mk (σ : F ≃ₐ[K] F) (D : Divisor.degZero (K := K) (F := F)) :
+    σ • (mk D) = mk (degZeroSMulHom σ D) := rfl
+
+instance : DistribMulAction (F ≃ₐ[K] F) (Pic0 K F) where
+  one_smul x := by
+    obtain ⟨D, rfl⟩ := mk_surjective x
+    rw [smul_mk]
+    exact congrArg mk (Subtype.ext (by rw [coe_degZeroSMulHom, one_smul]))
+  mul_smul σ τ x := by
+    obtain ⟨D, rfl⟩ := mk_surjective x
+    rw [smul_mk, smul_mk, smul_mk]
+    exact congrArg mk (Subtype.ext (by simp only [coe_degZeroSMulHom]; rw [mul_smul]))
+  smul_zero σ := by
+    change σ • mk 0 = mk 0
+    rw [smul_mk]
+    grind
+  smul_add σ x y := by
+    obtain ⟨D, rfl⟩ := mk_surjective x
+    obtain ⟨E, rfl⟩ := mk_surjective y
+    change σ • mk (D + E) = mk (degZeroSMulHom σ D) + mk (degZeroSMulHom σ E)
+    rw [smul_mk]
+    exact congrArg mk (map_add _ _ _)
+
+end Pic0
+
+namespace Place
+
+variable {K F}
+variable {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R F] [IsFractionRing R F]
+
+open IsDedekindDomain.HeightOneSpectrum in
+theorem isPrincipalIdealRing_valuationSubring (w : HeightOneSpectrum R) :
+    IsPrincipalIdealRing ((w.valuation F).valuationSubring) := by
+  rw [show (w.valuation F).valuationSubring = valuationSubringAtPrime F w from
+    (valuationSubringAtPrime_eq_valuationSubring (K := F) w).symm]
+  infer_instance
+
+open IsDedekindDomain.HeightOneSpectrum in
+def ofHeightOneSpectrum [Algebra K R] [IsScalarTower K R F] (w : HeightOneSpectrum R) :
+    Place K F where
+  toValuationSubring := (w.valuation F).valuationSubring
+  algebraMap_mem' := fun a => by
+    rw [Valuation.mem_valuationSubring_iff, IsScalarTower.algebraMap_apply K R F]
+    exact w.valuation_le_one (algebraMap K R a)
+  ne_top' := by
+    simp only [ne_eq, Valuation.valuationSubring_eq_top_iff, not_not]
+    infer_instance
+  isPrincipalIdealRing' := isPrincipalIdealRing_valuationSubring w
+
+@[simp]
+theorem ofHeightOneSpectrum_toValuationSubring [Algebra K R] [IsScalarTower K R F]
+    (w : HeightOneSpectrum R) :
+    (ofHeightOneSpectrum (K := K) w).toValuationSubring = (w.valuation F).valuationSubring :=
+  rfl
+
+end Place
+
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_DivisorPushPull.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_DivisorPushPull.lean
new file mode 100644
index 0000000000..5acf1774db
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_DivisorPushPull.lean
@@ -0,0 +1,763 @@
+/-
+Based on Prove2Me node AlgebraicCurve_DivisorPushPull
+(cf383033-9d83-5afb-a5cf-a6a5732a3fd7) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import Mathlib.RingTheory.Valuation.LocalSubring
+public import Mathlib.RingTheory.IntegralClosure.IntegrallyClosed
+public import Mathlib.RingTheory.IntegralClosure.Algebra.Basic
+public import Mathlib.RingTheory.Norm.Basic
+public import Mathlib.LinearAlgebra.Dimension.Free
+
+/-!
+# Restriction of places, ramification and inertia, divisor pull-back and push-forward
+
+Definition: `AlgebraicCurve_DivisorPushPull` (`cf383033-9d83-5afb-a5cf-a6a5732a3fd7`), by Claude,
+2026-09-05.
+
+Throughout, $K \subseteq F \subseteq F'$ is a tower of fields (`Algebra K F`, `Algebra K F'`,
+`Algebra F F'`, `IsScalarTower K F F'`), with `Place`, `Divisor`, `degree`, `IsPrincipal`, `Pic0`,
+`HasPrincipalDivisors` taken from the project's divisor-class-group module; a place carries a
+valuation subring together with the conditions recorded there, and `ord`, `deg` and `ResidueField`
+are its associated order function, degree and residue field. For a place $w$ of $F'$,
+`Place.restrict F w` is the place of $F$ whose valuation subring is the preimage $\mathcal O_w \cap
+F$ (`ValuationSubring.comap`), the properness and discreteness conditions being verified from
+`[Algebra.IsIntegral F F']` and integral closedness. `Place.ramificationIndex F w` is defined as the
+natural-number infimum of $\{n>0 : n = \operatorname{ord}_w(\iota f)\ \text{for some } f \in
+F^\times\}$; under integrality it is positive, divides every $\operatorname{ord}_w(\iota f)$, and
+`ord_restrict` gives $\operatorname{ord}_w(\iota f) = e\cdot \operatorname{ord}_{w|_F}(f)$.
+`Place.restrictInclusion` and `Place.restrictResidueMap` (a local homomorphism and the induced map
+of residue fields, with algebra and scalar-tower instances) make $\kappa(w)$ an extension of
+$\kappa(w|_F)$, and `Place.inertiaDeg F w` is its finrank, so that `deg_restrict_mul_inertiaDeg` is
+the tower formula $\deg(w|_F)\cdot f = \deg w$. Assuming `HasPrincipalDivisors K F'`, `Place.fiber
+F' v` is the finite set of places above $v$. On divisors: `Divisor.mapRestrict` is the bare
+relabelling $w \mapsto w|_F$; `Divisor.pushforward F` sends $w \mapsto f(w)\, w|_F$ and preserves
+degree; `Divisor.pullback F'` sends $v \mapsto \sum_{w \mid v} e(w)\,w$, takes $\operatorname{div}_F
+f$ to $\operatorname{div}_{F'}(\iota f)$ and principal divisors to principal divisors. Two classes
+state ramification identities as hypotheses: `SumRamificationInertia` ($\sum_{w\mid v} e f =
+[F':F]$) and `FundamentalIdentity` ($\sum_{w\mid v} e \deg w = [F':F]\deg v$), the former implying
+the latter; under the latter, pull-back multiplies degrees by $[F':F]$ and descends to
+`Pic0.pullbackHom`. Norm compatibility is the project's proposition `Divisor.PushforwardNormFormula
+K F F'`: for every $f \in (F')^\times$, every divisor $D$ with $D(w) = \operatorname{ord}_w f$ for
+all $w$, and every $v$, $(\pi_* D)(v) = \operatorname{ord}_v(N_{F'/F} f)$; it is passed as an
+explicit argument to `Pic0.pushforwardHom` (which also needs `Module.Finite F F'`).
+
+**Relation to Mathlib.** Mathlib's ramification index and inertia degree are defined for ideals in
+extensions of Dedekind domains (`Ideal.ramificationIdx`, `Ideal.inertiaDeg`); here both are
+redefined directly for the project's own `Place`, the ramification index as an infimum of positive
+orders and the inertia degree as a residue-field finrank. The fundamental identity and the norm
+formula are not proved in this module but appear as the project's hypothesis classes
+`SumRamificationInertia`, `FundamentalIdentity` and the proposition
+`Divisor.PushforwardNormFormula`.
+
+**Where it is used.** These maps supply the functoriality of degree-zero divisor classes along a
+finite extension of function fields, so that a correspondence between curves acts on
+$\mathrm{Pic}^0$ by push-forward after pull-back along its two projections; this is the form in
+which Hecke operators act on the Jacobians of modular curves in the modularity part of the argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing
+
+namespace AlgebraicCurve
+
+namespace Place
+
+section SinglePlace
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+theorem ord_nonneg_of_mem {f : F} (hf : f ∈ v.toValuationSubring) : 0 ≤ v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨n, u, hu⟩ :=
+    IsDiscreteValuationRing.eq_unit_mul_pow_irreducible
+      (x := (⟨f, hf⟩ : v.toValuationSubring)) (by simpa [Subtype.ext_iff] using hf0) hπ
+  have hcoe : f = ((u : v.toValuationSubring) : F) * ((π : F) ^ (n : ℤ)) := by
+    have h := congrArg (Subtype.val) hu
+    push_cast at h
+    rw [zpow_natCast]
+    exact h
+  rw [hcoe, v.ord_unit_smul_zpow u hπ (n : ℤ)]
+  exact Int.natCast_nonneg n
+
+theorem mem_of_ord_nonneg {f : F} (hf : f ≠ 0) (h : 0 ≤ v.ord f) :
+    f ∈ v.toValuationSubring := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ
+  rw [hu, show v.ord f = (((v.ord f).toNat : ℕ) : ℤ) from (Int.toNat_of_nonneg h).symm,
+    zpow_natCast]
+  exact mul_mem (u : v.toValuationSubring).2 (pow_mem (π : v.toValuationSubring).2 _)
+
+theorem mem_iff_ord_nonneg {f : F} (hf : f ≠ 0) :
+    f ∈ v.toValuationSubring ↔ 0 ≤ v.ord f :=
+  ⟨v.ord_nonneg_of_mem, v.mem_of_ord_nonneg hf⟩
+
+theorem exists_ord_pos : ∃ f : F, f ≠ 0 ∧ 0 < v.ord f := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  refine ⟨(π : F), ?_, ?_⟩
+  · simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  · rw [v.ord_coe_irreducible hπ]
+    exact one_pos
+
+end SinglePlace
+
+section Restrict
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F'] [Algebra F F']
+
+theorem algebraMap_ne_zero {f : F} (hf : f ≠ 0) : algebraMap F F' f ≠ 0 := by
+  simpa using hf
+
+variable (w : Place K F')
+
+theorem comap_algebraMap_ne_top [Algebra.IsIntegral F F'] :
+    w.toValuationSubring.comap (algebraMap F F') ≠ ⊤ := by
+  intro htop
+  apply w.ne_top'
+  have hF : ∀ f : F, algebraMap F F' f ∈ w.toValuationSubring := fun f =>
+    ValuationSubring.mem_comap.mp (htop ▸ ValuationSubring.mem_top f)
+  refine SetLike.ext fun x => ⟨fun _ => ValuationSubring.mem_top x, fun _ => ?_⟩
+  let : Algebra F w.toValuationSubring :=
+    ((algebraMap F F').codRestrict w.toValuationSubring.toSubring hF).toAlgebra
+  let : IsScalarTower F w.toValuationSubring F' :=
+    IsScalarTower.of_algebraMap_eq fun f => rfl
+  have hx : IsIntegral w.toValuationSubring x :=
+    (Algebra.IsIntegral.isIntegral (R := F) x).tower_top
+  obtain ⟨y, hy⟩ := IsIntegrallyClosed.isIntegral_iff.mp hx
+  exact hy ▸ y.2
+
+variable {w} in
+theorem mem_comap_iff_ord_nonneg {f : F} (hf : f ≠ 0) :
+    f ∈ w.toValuationSubring.comap (algebraMap F F') ↔
+      0 ≤ w.ord (algebraMap F F' f) := by
+  rw [ValuationSubring.mem_comap]
+  exact w.mem_iff_ord_nonneg (algebraMap_ne_zero hf)
+
+variable {w} in
+theorem isUnit_mk_comap_iff {f : F} (hf : f ≠ 0)
+    (hmem : f ∈ w.toValuationSubring.comap (algebraMap F F')) :
+    IsUnit (⟨f, hmem⟩ : w.toValuationSubring.comap (algebraMap F F')) ↔
+      w.ord (algebraMap F F' f) = 0 := by
+  constructor
+  · rintro h
+    obtain ⟨b, hb⟩ := isUnit_iff_exists_inv.mp h
+    have hb' : f * (b : F) = 1 := by
+      simpa [Subtype.ext_iff] using hb
+    have hbne : (b : F) ≠ 0 := by
+      intro h0
+      rw [h0, mul_zero] at hb'
+      exact zero_ne_one hb'
+    have hsum : w.ord (algebraMap F F' f) + w.ord (algebraMap F F' (b : F)) = 0 := by
+      rw [← w.ord_mul (algebraMap_ne_zero hf) (algebraMap_ne_zero hbne), ← map_mul, hb',
+        map_one, w.ord_one]
+    have h1 : 0 ≤ w.ord (algebraMap F F' f) := (mem_comap_iff_ord_nonneg hf).mp hmem
+    have h2 : 0 ≤ w.ord (algebraMap F F' (b : F)) := (mem_comap_iff_ord_nonneg hbne).mp b.2
+    omega
+  · intro h0
+    have hinv : f⁻¹ ∈ w.toValuationSubring.comap (algebraMap F F') :=
+      (mem_comap_iff_ord_nonneg (inv_ne_zero hf)).mpr (by rw [map_inv₀, w.ord_inv]; omega)
+    exact ⟨⟨⟨f, hmem⟩, ⟨f⁻¹, hinv⟩, Subtype.ext (mul_inv_cancel₀ hf),
+      Subtype.ext (inv_mul_cancel₀ hf)⟩, rfl⟩
+
+theorem exists_ord_algebraMap_pos [Algebra.IsIntegral F F'] :
+    ∃ f : F, f ≠ 0 ∧ 0 < w.ord (algebraMap F F' f) := by
+  have h := w.comap_algebraMap_ne_top (F := F)
+  rw [ne_eq, SetLike.ext_iff, not_forall] at h
+  obtain ⟨g, hg⟩ := h
+  simp only [ValuationSubring.mem_top, iff_true] at hg
+  have hg0 : g ≠ 0 := by
+    rintro rfl
+    exact hg (zero_mem _)
+  refine ⟨g⁻¹, inv_ne_zero hg0, ?_⟩
+  rw [map_inv₀, w.ord_inv]
+  have := (mem_comap_iff_ord_nonneg hg0).not.mp hg
+  omega
+
+def ramificationIndex (F : Type*) [Field F] [Algebra F F'] : ℕ :=
+  sInf {n : ℕ | 0 < n ∧ ∃ f : F, f ≠ 0 ∧ w.ord (algebraMap F F' f) = n}
+
+theorem ramificationIndex_le_ord {f : F} (hf : f ≠ 0)
+    (hpos : 0 < w.ord (algebraMap F F' f)) :
+    (ramificationIndex (F := F) w : ℤ) ≤ w.ord (algebraMap F F' f) := by
+  have h := Nat.sInf_le
+    (s := {n : ℕ | 0 < n ∧ ∃ f : F, f ≠ 0 ∧ w.ord (algebraMap F F' f) = n})
+    (m := (w.ord (algebraMap F F' f)).toNat) ⟨by omega, f, hf, by omega⟩
+  rw [ramificationIndex]
+  omega
+
+variable [Algebra.IsIntegral F F']
+
+theorem ramificationIndex_set_nonempty :
+    {n : ℕ | 0 < n ∧ ∃ f : F, f ≠ 0 ∧ w.ord (algebraMap F F' f) = n}.Nonempty := by
+  obtain ⟨f, hf0, hf⟩ := w.exists_ord_algebraMap_pos (F := F)
+  exact ⟨(w.ord (algebraMap F F' f)).toNat, by omega, f, hf0, by omega⟩
+
+theorem ramificationIndex_pos : 0 < ramificationIndex (F := F) w :=
+  (Nat.sInf_mem (w.ramificationIndex_set_nonempty (F := F))).1
+
+theorem exists_ord_eq_ramificationIndex :
+    ∃ f : F, f ≠ 0 ∧ w.ord (algebraMap F F' f) = ramificationIndex (F := F) w :=
+  (Nat.sInf_mem (w.ramificationIndex_set_nonempty (F := F))).2
+
+theorem ramificationIndex_dvd_ord {f : F} (hf : f ≠ 0) :
+    (ramificationIndex (F := F) w : ℤ) ∣ w.ord (algebraMap F F' f) := by
+  obtain ⟨g, hg0, hge⟩ := w.exists_ord_eq_ramificationIndex (F := F)
+  set e : ℤ := (ramificationIndex (F := F) w : ℤ) with he
+  have hepos : 0 < e := by
+    have := w.ramificationIndex_pos (F := F)
+    omega
+  set m : ℤ := w.ord (algebraMap F F' f) with hm
+  set q : ℤ := m / e with hq
+  have hgq : algebraMap F F' (g ^ (-q)) = (algebraMap F F' g) ^ (-q) := map_zpow₀ _ _ _
+  have hr : w.ord (algebraMap F F' (f * g ^ (-q))) = m - e * q := by
+    rw [map_mul, w.ord_mul (algebraMap_ne_zero hf)
+      (by rw [hgq]; exact zpow_ne_zero _ (algebraMap_ne_zero hg0)), hgq, w.ord_zpow, hge,
+      ← hm]
+    ring
+  have hmod := Int.emod_nonneg m (by omega : e ≠ 0)
+  have hmod' := Int.emod_lt_of_pos m hepos
+  have hbridge : m % e = m - e * q := by
+    rw [hq]
+    exact Int.emod_def m e
+  rcases eq_or_lt_of_le (show (0 : ℤ) ≤ m - e * q by omega) with heq | hlt
+  · exact ⟨q, by omega⟩
+  · exfalso
+    have hfg : f * g ^ (-q) ≠ 0 := mul_ne_zero hf (zpow_ne_zero _ hg0)
+    have hle := w.ramificationIndex_le_ord (F := F) hfg (by omega)
+    rw [hr, ← he] at hle
+    omega
+
+theorem irreducible_mk_comap {g : F} (hg0 : g ≠ 0)
+    (hmem : g ∈ w.toValuationSubring.comap (algebraMap F F'))
+    (hge : w.ord (algebraMap F F' g) = ramificationIndex (F := F) w) :
+    Irreducible (⟨g, hmem⟩ : w.toValuationSubring.comap (algebraMap F F')) := by
+  have hepos : 0 < ramificationIndex (F := F) w := w.ramificationIndex_pos (F := F)
+  constructor
+  · rw [isUnit_mk_comap_iff hg0 hmem, hge]
+    omega
+  · rintro ⟨a, ha⟩ ⟨b, hb⟩ hab
+    have hab' : g = a * b := by simpa [Subtype.ext_iff] using hab
+    have ha0 : a ≠ 0 := by
+      rintro rfl
+      exact hg0 (by simpa using hab')
+    have hb0 : b ≠ 0 := by
+      rintro rfl
+      exact hg0 (by simpa using hab')
+    have hsum : w.ord (algebraMap F F' a) + w.ord (algebraMap F F' b)
+        = ramificationIndex (F := F) w := by
+      rw [← w.ord_mul (algebraMap_ne_zero ha0) (algebraMap_ne_zero hb0), ← map_mul, ← hab',
+        hge]
+    have ha' : 0 ≤ w.ord (algebraMap F F' a) := (mem_comap_iff_ord_nonneg ha0).mp ha
+    have hb' : 0 ≤ w.ord (algebraMap F F' b) := (mem_comap_iff_ord_nonneg hb0).mp hb
+    rcases eq_or_lt_of_le ha' with ha0' | hapos
+    · exact Or.inl ((isUnit_mk_comap_iff ha0 ha).mpr ha0'.symm)
+    rcases eq_or_lt_of_le hb' with hb0' | hbpos
+    · exact Or.inr ((isUnit_mk_comap_iff hb0 hb).mpr hb0'.symm)
+    exfalso
+    have h1 := w.ramificationIndex_le_ord (F := F) ha0 hapos
+    have h2 := w.ramificationIndex_le_ord (F := F) hb0 hbpos
+    omega
+
+theorem isPrincipalIdealRing_comap :
+    IsPrincipalIdealRing (w.toValuationSubring.comap (algebraMap F F')) := by
+  obtain ⟨g, hg0, hge⟩ := w.exists_ord_eq_ramificationIndex (F := F)
+  have hepos : 0 < ramificationIndex (F := F) w := w.ramificationIndex_pos (F := F)
+  have hgmem : g ∈ w.toValuationSubring.comap (algebraMap F F') :=
+    (mem_comap_iff_ord_nonneg hg0).mpr (by omega)
+  refine (IsDiscreteValuationRing.ofHasUnitMulPowIrreducibleFactorization
+    ⟨⟨g, hgmem⟩, irreducible_mk_comap w hg0 hgmem hge, ?_⟩).toIsPrincipalIdealRing
+  rintro ⟨f, hmem⟩ hx
+  have hf : f ≠ 0 := by simpa [Subtype.ext_iff] using hx
+  obtain ⟨c, hc⟩ := w.ramificationIndex_dvd_ord (F := F) hf
+  have hnonneg : 0 ≤ w.ord (algebraMap F F' f) := (mem_comap_iff_ord_nonneg hf).mp hmem
+  have hcnonneg : 0 ≤ c := by
+    by_contra hneg
+    have hcle : c ≤ -1 := by omega
+    have : (ramificationIndex (F := F) w : ℤ) * c ≤ (ramificationIndex (F := F) w : ℤ) * -1 :=
+      mul_le_mul_of_nonneg_left hcle (by omega)
+    omega
+  set n : ℕ := c.toNat with hn
+  have hcn : (n : ℤ) = c := Int.toNat_of_nonneg hcnonneg
+  refine ⟨n, ?_⟩
+  have hgn : g ^ n ≠ 0 := pow_ne_zero _ hg0
+  have hdiv0 : f / g ^ n ≠ 0 := div_ne_zero hf hgn
+  have hu0 : w.ord (algebraMap F F' (f / g ^ n)) = 0 := by
+    have hkey : algebraMap F F' (f / g ^ n)
+        = algebraMap F F' f * (algebraMap F F' g) ^ (-(n : ℤ)) := by
+      rw [div_eq_mul_inv, map_mul, map_inv₀, map_pow, ← zpow_natCast (algebraMap F F' g) n,
+        ← zpow_neg]
+    rw [hkey, w.ord_mul (algebraMap_ne_zero hf) (zpow_ne_zero _ (algebraMap_ne_zero hg0)),
+      w.ord_zpow, hge, hc, ← hcn]
+    ring
+  have humem : f / g ^ n ∈ w.toValuationSubring.comap (algebraMap F F') :=
+    (mem_comap_iff_ord_nonneg hdiv0).mpr (le_of_eq hu0.symm)
+  have hu : IsUnit (⟨f / g ^ n, humem⟩ : w.toValuationSubring.comap (algebraMap F F')) :=
+    (isUnit_mk_comap_iff hdiv0 humem).mpr hu0
+  refine ⟨hu.unit, ?_⟩
+  refine Subtype.ext ?_
+  have hcoe : ((hu.unit : w.toValuationSubring.comap (algebraMap F F')) : F) = f / g ^ n := by
+    rw [IsUnit.unit_spec]
+  push_cast
+  rw [hcoe, mul_comm, div_mul_cancel₀]
+  exact hgn
+
+section RestrictDef
+
+variable [Algebra K F] [IsScalarTower K F F']
+
+variable (F) in
+def restrict : Place K F where
+  toValuationSubring := w.toValuationSubring.comap (algebraMap F F')
+  algebraMap_mem' a := by
+    rw [ValuationSubring.mem_comap, ← IsScalarTower.algebraMap_apply]
+    exact w.algebraMap_mem' a
+  ne_top' := by exact w.comap_algebraMap_ne_top
+  isPrincipalIdealRing' := by exact w.isPrincipalIdealRing_comap
+
+@[simp]
+theorem restrict_toValuationSubring :
+    (w.restrict F).toValuationSubring = w.toValuationSubring.comap (algebraMap F F') := rfl
+
+theorem mem_restrict_iff {f : F} :
+    f ∈ (w.restrict F).toValuationSubring ↔ algebraMap F F' f ∈ w.toValuationSubring :=
+  Iff.rfl
+
+theorem ord_restrict (f : F) :
+    w.ord (algebraMap F F' f) = ramificationIndex (F := F) w * (w.restrict F).ord f := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · simp
+  obtain ⟨g, hg0, hge⟩ := w.exists_ord_eq_ramificationIndex (F := F)
+  have hepos : 0 < ramificationIndex (F := F) w := w.ramificationIndex_pos (F := F)
+  have hgmem : g ∈ w.toValuationSubring.comap (algebraMap F F') :=
+    (mem_comap_iff_ord_nonneg hg0).mpr (by omega)
+  obtain ⟨u, hu⟩ := (w.restrict F).exists_unit_mul_zpow hf
+    (π := ⟨g, hgmem⟩) (irreducible_mk_comap w hg0 hgmem hge)
+  set n : ℤ := (w.restrict F).ord f with hn
+  have hune : ((u : (w.restrict F).toValuationSubring) : F) ≠ 0 := by
+    intro h0
+    have := u.mul_inv
+    rw [Subtype.ext_iff] at this
+    push_cast at this
+    rw [h0, zero_mul] at this
+    exact zero_ne_one this
+  have huord : w.ord (algebraMap F F' ((u : (w.restrict F).toValuationSubring) : F)) = 0 :=
+    (isUnit_mk_comap_iff hune (u : (w.restrict F).toValuationSubring).2).mp u.isUnit
+  have hgz : (algebraMap F F' g) ^ n ≠ 0 := zpow_ne_zero _ (algebraMap_ne_zero hg0)
+  calc w.ord (algebraMap F F' f)
+      = w.ord (algebraMap F F' (((u : (w.restrict F).toValuationSubring) : F) * g ^ n)) := by
+        rw [← hu]
+    _ = w.ord (algebraMap F F' ((u : (w.restrict F).toValuationSubring) : F))
+          + w.ord ((algebraMap F F' g) ^ n) := by
+        rw [map_mul, map_zpow₀]
+        exact w.ord_mul (algebraMap_ne_zero hune) hgz
+    _ = ramificationIndex (F := F) w * n := by
+        rw [huord, w.ord_zpow, hge, zero_add, mul_comm]
+
+theorem ord_algebraMap_ne_zero_of_restrict_eq {v : Place K F} {f : F}
+    (hford : v.ord f ≠ 0) (hw : w.restrict F = v) :
+    w.ord (algebraMap F F' f) ≠ 0 := by
+  rw [w.ord_restrict f, hw]
+  have hepos : 0 < ramificationIndex (F := F) w := w.ramificationIndex_pos (F := F)
+  exact mul_ne_zero (by omega) hford
+
+theorem restrict_fiber_finite [HasPrincipalDivisors K F'] (v : Place K F) :
+    {w : Place K F' | w.restrict F = v}.Finite := by
+  obtain ⟨f, hf0, hford⟩ := v.exists_ord_pos
+  obtain ⟨D, hD, -⟩ := HasPrincipalDivisors.exists_divisor (K := K)
+    (algebraMap F F' f) (algebraMap_ne_zero hf0)
+  apply Set.Finite.subset D.support.finite_toSet
+  intro w hw
+  simp only [Finset.mem_coe, Finsupp.mem_support_iff, hD w]
+  exact w.ord_algebraMap_ne_zero_of_restrict_eq (by omega) hw
+
+end RestrictDef
+
+end Restrict
+
+end Place
+
+end AlgebraicCurve
+
+section
+
+open IsDedekindDomain WithZero IsLocalRing
+
+namespace AlgebraicCurve
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [Algebra.IsIntegral F F']
+
+namespace Place
+
+variable (w : Place K F')
+
+variable (F) in
+def restrictInclusion : (w.restrict F).toValuationSubring →+* w.toValuationSubring where
+  toFun a := ⟨algebraMap F F' (a : F), ValuationSubring.mem_comap.mp a.2⟩
+  map_one' := Subtype.ext (map_one (algebraMap F F'))
+  map_mul' a b := Subtype.ext (map_mul (algebraMap F F') (a : F) (b : F))
+  map_zero' := Subtype.ext (map_zero (algebraMap F F'))
+  map_add' a b := Subtype.ext (map_add (algebraMap F F') (a : F) (b : F))
+
+@[simp]
+theorem coe_restrictInclusion (a : (w.restrict F).toValuationSubring) :
+    ((restrictInclusion F w a : w.toValuationSubring) : F') = algebraMap F F' (a : F) := rfl
+
+instance instIsLocalHomRestrictInclusion : IsLocalHom (restrictInclusion F w) where
+  map_nonunit a ha := by
+    have hord : w.ord (algebraMap F F' (a : F)) = 0 := by
+      have h := w.ord_coe_unit ha.unit
+      rwa [IsUnit.unit_spec, coe_restrictInclusion] at h
+    have ha0 : (a : F) ≠ 0 := by
+      rintro h0
+      obtain ⟨b, hb⟩ := isUnit_iff_exists_inv.mp ha
+      have hb' : algebraMap F F' (a : F) * (b : F') = 1 := congrArg Subtype.val hb
+      rw [h0, map_zero, zero_mul] at hb'
+      exact zero_ne_one hb'
+    exact (isUnit_mk_comap_iff ha0 a.2).mpr hord
+
+variable (F) in
+def restrictResidueMap : (w.restrict F).ResidueField →+* w.ResidueField :=
+  IsLocalRing.ResidueField.map (restrictInclusion F w)
+
+@[simp]
+theorem restrictResidueMap_residue (a : (w.restrict F).toValuationSubring) :
+    restrictResidueMap F w (IsLocalRing.residue _ a) =
+      IsLocalRing.residue _ (restrictInclusion F w a) :=
+  IsLocalRing.ResidueField.map_residue _ _
+
+instance instAlgebraResidueFieldRestrictPushforward :
+    Algebra (w.restrict F).ResidueField w.ResidueField :=
+  (restrictResidueMap F w).toAlgebra
+
+theorem algebraMap_residueField_eq :
+    algebraMap (w.restrict F).ResidueField w.ResidueField = restrictResidueMap F w := rfl
+
+instance instIsScalarTowerResidueFieldRestrictPushforward :
+    IsScalarTower K (w.restrict F).ResidueField w.ResidueField := by
+  refine IsScalarTower.of_algebraMap_eq fun a => ?_
+  change IsLocalRing.residue _ (algebraMap K w.toValuationSubring a) =
+    restrictResidueMap F w
+      (IsLocalRing.residue _ (algebraMap K (w.restrict F).toValuationSubring a))
+  rw [restrictResidueMap_residue]
+  refine congrArg _ (Subtype.ext ?_)
+  change algebraMap K F' a = algebraMap F F' (algebraMap K F a)
+  rw [← IsScalarTower.algebraMap_apply]
+
+variable (F) in
+def inertiaDeg : ℕ := Module.finrank (w.restrict F).ResidueField w.ResidueField
+
+theorem deg_restrict_mul_inertiaDeg : (w.restrict F).deg * w.inertiaDeg F = w.deg :=
+  Module.finrank_mul_finrank K (w.restrict F).ResidueField w.ResidueField
+
+end Place
+
+namespace Divisor
+
+variable (F) in
+def mapRestrict : Divisor K F' →+ Divisor K F :=
+  Finsupp.liftAddHom fun w => Finsupp.singleAddHom (w.restrict F)
+
+@[simp]
+theorem mapRestrict_single (w : Place K F') (n : ℤ) :
+    mapRestrict F (Finsupp.single w n) = Finsupp.single (w.restrict F) n := by
+  simp [mapRestrict]
+
+variable (F) in
+def pushforward : Divisor K F' →+ Divisor K F :=
+  Finsupp.liftAddHom fun w =>
+    (Finsupp.singleAddHom (w.restrict F)).comp (AddMonoidHom.mulRight (w.inertiaDeg F : ℤ))
+
+@[simp]
+theorem pushforward_single (w : Place K F') (n : ℤ) :
+    pushforward F (Finsupp.single w n) =
+      Finsupp.single (w.restrict F) (n * w.inertiaDeg F) := by
+  simp [pushforward]
+
+@[simp]
+theorem degree_pushforward (D : Divisor K F') :
+    degree (pushforward F D) = degree D := by
+  induction D using Finsupp.induction with
+  | zero => simp
+  | single_add w n D hw hn ih =>
+    simp only [map_add, pushforward_single, degree_single, ih]
+    have h := w.deg_restrict_mul_inertiaDeg (F := F)
+    push_cast [← h]
+    ring
+
+theorem pushforward_mem_degZero {D : Divisor K F'} (hD : D ∈ degZero (K := K) (F := F')) :
+    pushforward F D ∈ degZero (K := K) (F := F) := by
+  rwa [mem_degZero, degree_pushforward]
+
+theorem pushforward_apply [DecidableEq (Place K F)] (D : Divisor K F') (v : Place K F) :
+    pushforward F D v =
+      ∑ w ∈ D.support, if w.restrict F = v then D w * (w.inertiaDeg F : ℤ) else 0 := by
+  classical
+  rw [pushforward, Finsupp.liftAddHom_apply, Finsupp.sum_apply, Finsupp.sum]
+  refine Finset.sum_congr rfl fun w _ => ?_
+  simp [Finsupp.single_apply]
+
+variable (K F F') in
+def PushforwardNormFormula [Module.Finite F F'] : Prop :=
+  ∀ (f : F'), f ≠ 0 → ∀ D : Divisor K F', (∀ w, D w = w.ord f) →
+    ∀ v : Place K F, pushforward F D v = v.ord (Algebra.norm F f)
+
+theorem pushforward_eq_of_normFormula [Module.Finite F F']
+    (H : PushforwardNormFormula K F F') {f : F'} (hf : f ≠ 0)
+    {D : Divisor K F'} (hD : ∀ w, D w = w.ord f)
+    {E : Divisor K F} (hE : ∀ v, E v = v.ord (Algebra.norm F f)) :
+    pushforward F D = E :=
+  Finsupp.ext fun v => (H f hf D hD v).trans (hE v).symm
+
+theorem isPrincipal_pushforward_of_normFormula [Module.Finite F F']
+    (H : PushforwardNormFormula K F F') {D : Divisor K F'} (hD : IsPrincipal D) :
+    IsPrincipal (pushforward F D) := by
+  obtain ⟨f, hf, hDf⟩ := hD
+  exact ⟨Algebra.norm F f, Algebra.norm_ne_zero_iff.mpr hf, fun v => H f hf D hDf v⟩
+
+end Divisor
+
+end AlgebraicCurve
+
+section
+
+namespace AlgebraicCurve
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [Algebra.IsIntegral F F'] [HasPrincipalDivisors K F']
+
+namespace Place
+
+variable (F') in
+def fiber (v : Place K F) : Finset (Place K F') :=
+  (restrict_fiber_finite v).toFinset
+
+@[simp]
+theorem mem_fiber {v : Place K F} {w : Place K F'} :
+    w ∈ v.fiber F' ↔ w.restrict F = v := by
+  simp only [fiber, Set.Finite.mem_toFinset, Set.mem_ofPred_eq]
+
+theorem restrict_mem_fiber (w : Place K F') : w ∈ (w.restrict F).fiber F' :=
+  mem_fiber.mpr rfl
+
+end Place
+
+namespace Divisor
+
+variable (F') in
+def pullbackSingleHom (v : Place K F) : ℤ →+ Divisor K F' where
+  toFun n := ∑ w ∈ v.fiber F', Finsupp.single w (n * w.ramificationIndex F)
+  map_zero' := by simp
+  map_add' m n := by
+    rw [← Finset.sum_add_distrib]
+    exact Finset.sum_congr rfl fun w _ => by rw [add_mul, Finsupp.single_add]
+
+theorem pullbackSingleHom_apply (v : Place K F) (n : ℤ) :
+    pullbackSingleHom F' v n
+      = ∑ w ∈ v.fiber F', Finsupp.single w (n * w.ramificationIndex F) :=
+  rfl
+
+variable (F') in
+def pullback : Divisor K F →+ Divisor K F' :=
+  Finsupp.liftAddHom (pullbackSingleHom F')
+
+theorem pullback_single (v : Place K F) (n : ℤ) :
+    pullback F' (Finsupp.single v n)
+      = ∑ w ∈ v.fiber F', Finsupp.single w (n * w.ramificationIndex F) :=
+  Finsupp.liftAddHom_apply_single _ _ _
+
+theorem pullback_single_apply_of_restrict_eq {v : Place K F} {w : Place K F'}
+    (hw : w.restrict F = v) (n : ℤ) :
+    pullback F' (Finsupp.single v n) w = n * w.ramificationIndex F := by
+  rw [pullback_single, Finset.sum_apply']
+  trans (Finsupp.single w (n * (w.ramificationIndex F : ℤ))) w
+  · refine Finset.sum_eq_single_of_mem w (Place.mem_fiber.mpr hw) ?_
+    intro b _ hb
+    exact Finsupp.single_eq_of_ne' hb
+  · exact Finsupp.single_eq_same
+
+theorem pullback_single_apply_of_restrict_ne {v : Place K F} {w : Place K F'}
+    (hw : w.restrict F ≠ v) (n : ℤ) :
+    pullback F' (Finsupp.single v n) w = 0 := by
+  rw [pullback_single, Finset.sum_apply']
+  exact Finset.sum_eq_zero fun b hb =>
+    Finsupp.single_eq_of_ne fun h => hw (h ▸ Place.mem_fiber.mp hb)
+
+theorem pullback_apply (D : Divisor K F) (w : Place K F') :
+    pullback F' D w = w.ramificationIndex F * D (w.restrict F) := by
+  induction D using Finsupp.induction with
+  | zero => simp
+  | single_add v n D _ _ ih =>
+    rw [map_add, Finsupp.add_apply, ih, Finsupp.add_apply, mul_add]
+    congr 1
+    by_cases hw : w.restrict F = v
+    · subst hw
+      rw [pullback_single_apply_of_restrict_eq rfl, Finsupp.single_eq_same, mul_comm]
+    · rw [pullback_single_apply_of_restrict_ne hw,
+        Finsupp.single_eq_of_ne hw, mul_zero]
+
+theorem restrict_mem_support_of_mem_support_pullback {D : Divisor K F} {w : Place K F'}
+    (hw : w ∈ (pullback F' D).support) : w.restrict F ∈ D.support := by
+  rw [Finsupp.mem_support_iff] at hw ⊢
+  intro h
+  exact hw (by rw [pullback_apply, h, mul_zero])
+
+theorem pullback_apply_eq_ord {f : F} {D : Divisor K F}
+    (hD : ∀ v : Place K F, D v = v.ord f) (w : Place K F') :
+    pullback F' D w = w.ord (algebraMap F F' f) := by
+  rw [pullback_apply, hD, ← Place.ord_restrict]
+
+theorem isPrincipal_pullback {D : Divisor K F} (hD : D.IsPrincipal) :
+    (pullback F' D).IsPrincipal := by
+  obtain ⟨f, hf, hDf⟩ := hD
+  exact ⟨algebraMap F F' f, by simpa using hf, fun w => pullback_apply_eq_ord hDf w⟩
+
+theorem pullback_mem_principal {D : Divisor K F} (hD : D ∈ principal (K := K) (F := F)) :
+    pullback F' D ∈ principal (K := K) (F := F') :=
+  isPrincipal_pullback hD
+
+end Divisor
+
+variable (K F F') in
+class FundamentalIdentity : Prop where
+  sum_ramificationIndex_mul_deg : ∀ v : Place K F,
+    ∑ w ∈ v.fiber F', (w.ramificationIndex F : ℤ) * (w.deg : ℤ)
+      = (Module.finrank F F' : ℤ) * (v.deg : ℤ)
+
+namespace Divisor
+
+theorem degree_pullback_single [FundamentalIdentity K F F'] (v : Place K F) (n : ℤ) :
+    degree (pullback F' (Finsupp.single v n))
+      = (Module.finrank F F' : ℤ) * degree (Finsupp.single v n) := by
+  rw [pullback_single, map_sum, degree_single]
+  simp_rw [degree_single, mul_assoc]
+  rw [← Finset.mul_sum,
+    FundamentalIdentity.sum_ramificationIndex_mul_deg (K := K) (F := F) (F' := F') v]
+  ring
+
+theorem degree_pullback [FundamentalIdentity K F F'] (D : Divisor K F) :
+    degree (pullback F' D) = (Module.finrank F F' : ℤ) * degree D := by
+  induction D using Finsupp.induction with
+  | zero => simp
+  | single_add v n D _ _ ih =>
+    rw [map_add, map_add, map_add, mul_add, ih, degree_pullback_single]
+
+theorem pullback_mem_degZero [FundamentalIdentity K F F'] {D : Divisor K F}
+    (hD : D ∈ degZero (K := K) (F := F)) :
+    pullback F' D ∈ degZero (K := K) (F := F') := by
+  rw [mem_degZero] at hD ⊢
+  rw [degree_pullback, hD, mul_zero]
+
+end Divisor
+
+end AlgebraicCurve
+
+section
+
+namespace AlgebraicCurve
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [Algebra.IsIntegral F F'] [HasPrincipalDivisors K F']
+
+variable (K F F') in
+class SumRamificationInertia : Prop where
+  sum_ramificationIndex_mul_inertiaDeg : ∀ v : Place K F,
+    ∑ w ∈ v.fiber F', (w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ)
+      = (Module.finrank F F' : ℤ)
+
+instance (priority := 100) instFundamentalIdentityOfSumRamificationInertia
+    [SumRamificationInertia K F F'] : FundamentalIdentity K F F' where
+  sum_ramificationIndex_mul_deg v := by
+    have key := SumRamificationInertia.sum_ramificationIndex_mul_inertiaDeg
+      (K := K) (F := F) (F' := F') v
+    calc
+      ∑ w ∈ v.fiber F', (w.ramificationIndex F : ℤ) * (w.deg : ℤ)
+          = ∑ w ∈ v.fiber F',
+              (v.deg : ℤ) * ((w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ)) := by
+            refine Finset.sum_congr rfl fun w hw => ?_
+            have htower : ((w.restrict F).deg : ℤ) * (w.inertiaDeg F : ℤ) = (w.deg : ℤ) := by
+              exact_mod_cast congrArg (Nat.cast (R := ℤ))
+                (w.deg_restrict_mul_inertiaDeg (F := F))
+            rw [Place.mem_fiber.mp hw] at htower
+            rw [← htower]; ring
+      _ = (v.deg : ℤ) * ∑ w ∈ v.fiber F',
+              (w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ) := by
+            rw [Finset.mul_sum]
+      _ = (Module.finrank F F' : ℤ) * (v.deg : ℤ) := by rw [key]; ring
+
+namespace Pic0
+
+variable (F') in
+def pullbackDegZeroHom [FundamentalIdentity K F F'] :
+    Divisor.degZero (K := K) (F := F) →+ Divisor.degZero (K := K) (F := F') :=
+  ((Divisor.pullback F').domRestrict (Divisor.degZero (K := K) (F := F))).codRestrict _
+    fun D => Divisor.pullback_mem_degZero D.2
+
+@[simp]
+theorem coe_pullbackDegZeroHom [FundamentalIdentity K F F']
+    (D : Divisor.degZero (K := K) (F := F)) :
+    (pullbackDegZeroHom F' D : Divisor K F') = Divisor.pullback F' (D : Divisor K F) := rfl
+
+variable (F') in
+def pullbackHom [FundamentalIdentity K F F'] : Pic0 K F →+ Pic0 K F' :=
+  QuotientAddGroup.map _ _ (pullbackDegZeroHom F') (by
+    rintro ⟨D, hD0⟩ hD
+    simp only [AddSubgroup.mem_addSubgroupOf] at hD ⊢
+    exact Divisor.pullback_mem_principal hD)
+
+theorem pullbackHom_mk [FundamentalIdentity K F F']
+    (D : Divisor.degZero (K := K) (F := F)) :
+    pullbackHom F' (mk D) = mk (pullbackDegZeroHom F' D) := rfl
+
+variable (F) in
+def pushforwardDegZeroHom :
+    Divisor.degZero (K := K) (F := F') →+ Divisor.degZero (K := K) (F := F) :=
+  ((Divisor.pushforward F).domRestrict (Divisor.degZero (K := K) (F := F'))).codRestrict _
+    fun D => Divisor.pushforward_mem_degZero D.2
+
+omit [HasPrincipalDivisors K F'] in
+@[simp]
+theorem coe_pushforwardDegZeroHom (D : Divisor.degZero (K := K) (F := F')) :
+    (pushforwardDegZeroHom F D : Divisor K F) = Divisor.pushforward F (D : Divisor K F') := rfl
+
+variable (K F F') in
+def pushforwardHom [Module.Finite F F'] (H : Divisor.PushforwardNormFormula K F F') :
+    Pic0 K F' →+ Pic0 K F :=
+  QuotientAddGroup.map _ _ (pushforwardDegZeroHom F) (by
+    rintro ⟨D, hD0⟩ hD
+    simp only [AddSubgroup.mem_addSubgroupOf] at hD ⊢
+    exact Divisor.isPrincipal_pushforward_of_normFormula H hD)
+
+omit [HasPrincipalDivisors K F'] in
+theorem pushforwardHom_mk [Module.Finite F F'] (H : Divisor.PushforwardNormFormula K F F')
+    (D : Divisor.degZero (K := K) (F := F')) :
+    pushforwardHom K F F' H (mk D) = mk (pushforwardDegZeroHom F D) := rfl
+
+end Pic0
+
+end AlgebraicCurve
+
+
+end
+end
+end
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_FrobeniusEndo.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_FrobeniusEndo.lean
new file mode 100644
index 0000000000..9716dfd314
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_FrobeniusEndo.lean
@@ -0,0 +1,104 @@
+/-
+Based on Prove2Me node AlgebraicCurve_FrobeniusEndo
+(2280ed99-f630-5a37-82d8-e783d7fcaca4) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+public import Mathlib.Algebra.CharP.Reduced
+
+/-!
+# Frobenius endomorphisms of function fields and their norms
+
+Definition: `AlgebraicCurve_FrobeniusEndo` (`2280ed99-f630-5a37-82d8-e783d7fcaca4`), by Claude,
+2026-09-05.
+
+Throughout, $K$ and $F$ are fields with $F$ a $K$-algebra, and $\ell$ is a natural number. The
+structure [`AlgebraicCurve.IsFrobeniusEndo ℓ φ`](../def/AlgebraicCurve_FrobeniusEndo.html#L16), for
+a $K$-algebra endomorphism $\varphi : F \to F$, is a proposition with two fields: `pow_mem_range`
+asserts that for every $x \in F$ there is $y \in F$ with $\varphi(y) = x^{\ell}$, and
+`mem_range_pow` asserts that for every $y \in F$ there is $x \in F$ with $\varphi(y) = x^{\ell}$.
+Together these say that the image $\varphi(F)$ is exactly the set of $\ell$-th powers in $F$; the
+predicate is imposed on a chosen endomorphism $\varphi$ rather than on an abstractly constructed
+Frobenius twist, and no characteristic hypothesis is built into it.
+
+Given such an $h : \mathrm{IsFrobeniusEndo}\ \ell\ \varphi$, the operation `frobNorm` assigns to
+each $f \in F$ an element $h.\mathrm{frobNorm}(f)$ chosen from the existential statement of
+`pow_mem_range`, so that `map_frobNorm` records its defining property
+$\varphi(h.\mathrm{frobNorm}(f)) = f^{\ell}$; it is thus a preimage under $\varphi$ of the $\ell$-th
+power of $f$, a choice rather than a canonical construction. Two further facts are supplied:
+`frobNorm_ne_zero`, that $h.\mathrm{frobNorm}(f) \neq 0$ whenever $f \neq 0$ (immediate from
+$\varphi(0) = 0$ and $f^{\ell} \neq 0$), and `isIntegral`, that for $\ell \neq 0$ the underlying
+ring homomorphism of $\varphi$ is integral in the sense of `RingHom.IsIntegral`: each $x \in F$
+satisfies the monic polynomial $X^{\ell} - C(h.\mathrm{frobNorm}(x))$ with coefficients pushed
+forward along $\varphi$, since evaluating it at $x$ gives $x^{\ell} -
+\varphi(h.\mathrm{frobNorm}(x)) = 0$.
+
+**Relation to Mathlib.** Mathlib's `frobenius` concerns the $p$-power map on a ring of
+characteristic $p$; the predicate here is the project's own notion, a condition on an arbitrary
+$K$-algebra endomorphism of a field identifying its image with the subfield of $\ell$-th powers. The
+integrality conclusion is phrased with Mathlib's `RingHom.IsIntegral`.
+
+**Where it is used.** The integrality statement `isIntegral` provides precisely the hypothesis
+`φ.toRingHom.IsIntegral` under which divisors can be pulled back and pushed forward along a
+$K$-algebra homomorphism of function fields, and hence under which correspondences on divisors and
+on $\mathrm{Pic}^0$ are formed in the correspondence machinery. That machinery is used for the
+Frobenius and Verschiebung operators entering the Eichler–Shimura relation on the Jacobian in
+characteristic $\ell$.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+section Package
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+variable (ℓ : ℕ)
+
+structure IsFrobeniusEndo (φ : F →ₐ[K] F) : Prop where
+  pow_mem_range : ∀ x : F, ∃ y : F, φ y = x ^ ℓ
+  mem_range_pow : ∀ y : F, ∃ x : F, φ y = x ^ ℓ
+
+variable {ℓ : ℕ} {φ : F →ₐ[K] F}
+
+namespace IsFrobeniusEndo
+
+def frobNorm (h : IsFrobeniusEndo ℓ φ) (f : F) : F :=
+  (h.pow_mem_range f).choose
+
+theorem map_frobNorm (h : IsFrobeniusEndo ℓ φ) (f : F) : φ (h.frobNorm f) = f ^ ℓ :=
+  (h.pow_mem_range f).choose_spec
+
+theorem frobNorm_ne_zero (h : IsFrobeniusEndo ℓ φ) {f : F} (hf : f ≠ 0) :
+    h.frobNorm f ≠ 0 := by
+  intro h0
+  have := h.map_frobNorm f
+  rw [h0, map_zero] at this
+  exact pow_ne_zero ℓ hf this.symm
+
+theorem isIntegral (h : IsFrobeniusEndo ℓ φ) (hℓ : ℓ ≠ 0) : φ.toRingHom.IsIntegral := by
+  intro x
+  refine ⟨Polynomial.X ^ ℓ - Polynomial.C (h.frobNorm x), ?_, ?_⟩
+  · exact Polynomial.monic_X_pow_sub_C _ hℓ
+  · simp [Polynomial.eval₂_sub, h.map_frobNorm x]
+
+end IsFrobeniusEndo
+
+end Package
+
+end AlgebraicCurve
+
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_FrobeniusEndoPic0.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_FrobeniusEndoPic0.lean
new file mode 100644
index 0000000000..b142c19ff6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_FrobeniusEndoPic0.lean
@@ -0,0 +1,380 @@
+/-
+Based on Prove2Me node AlgebraicCurve_FrobeniusEndoPic0
+(16d9c6d9-b503-56b5-aa8d-f254c7635f7b) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_FrobeniusEndo
+
+/-!
+# Frobenius push-forward and pull-back on degree-zero Picard groups
+
+Definition: `AlgebraicCurve_FrobeniusEndoPic0` (`16d9c6d9-b503-56b5-aa8d-f254c7635f7b`), by Claude,
+2026-09-05.
+
+The standing setting is a field $K$, a field $F$ with a $K$-algebra structure, a natural number
+$\ell$ and a $K$-algebra endomorphism $\varphi : F \to F$ satisfying `IsFrobeniusEndo ℓ φ`, i.e.
+every $x \in F$ has some $y$ with $\varphi(y) = x^{\ell}$ and every $y \in F$ has some $x$ with
+$\varphi(y) = x^{\ell}$ (so the image of $\varphi$ is exactly the set of $\ell$-th powers);
+`frobNorm` picks, for each $f$, a witness with $\varphi(\mathrm{frobNorm}(f)) = f^{\ell}$. Sections
+further assume $\ell$ prime, $\mathrm{char}\,F = \ell$, and `HasPrincipalDivisors K F` where needed.
+
+The place calculus records that, for $\ell \neq 0$ and $\varphi$ integral, restriction of places
+along $\varphi$ is injective (so each fibre `fiberAlong` is a singleton), that the ramification
+index along $\varphi$ — the infimum of the positive values $\mathrm{ord}_w(\varphi f)$, $f \neq 0$ —
+equals $\ell$ at every place, that $\mathrm{ord}_{w|_\varphi}(\mathrm{frobNorm}(f)) =
+\mathrm{ord}_w(f)$, and that the algebra norm of $F$ over itself along $\varphi$ agrees with
+`frobNorm` when the degree `finrankAlong K φ` equals $\ell$. From these follow the two predicates
+that the divisor machinery requires: `normFormulaAlong` (the push-forward of the divisor of $f$ is
+the divisor of its norm) under integrality, module-finiteness, degree $\ell$, surjectivity of place
+restriction and all inertia degrees equal to $1$; and `fundamentalIdentityAlong`, obtained from
+$\sum_{w \mid v} e_w f_w = \ell$ over the one-element fibres.
+
+The two main definitions are the induced endomorphisms of $\mathrm{Pic}^0(K,F)$.
+`frobeniusPushforwardDegZero` restricts `Divisor.pushforwardAlong φ` to degree-zero divisors, and
+`pushforwardPic0` is the map it induces on the quotient by principal divisors, principality being
+preserved by the norm formula. Dually, `frobeniusPullbackDegZero` restricts `Divisor.pullbackAlong
+φ` (degree zero being preserved by the fundamental identity), and `pullbackPic0` is the induced map
+on $\mathrm{Pic}^0$. Compatibility lemmas identify both maps on classes `Pic0.mk D`, and
+`isPrincipal_pushforwardAlong` states preservation of principality directly.
+
+**Relation to Mathlib.** The `Place`, `Divisor` and `Pic0` framework used here, together with the
+predicates `IsFrobeniusEndo`, `NormFormulaAlong` and `FundamentalIdentityAlong`, is the project's
+own; only the underlying valuation-subring, norm and quotient-group material is Mathlib's. The
+auxiliary lemma [`ValuationSubring.pow_mem_iff`](../def/AlgebraicCurve_FrobeniusEndoPic0.html#L13),
+stating that $x^n \in A$ iff $x \in A$ for a valuation subring $A$ and $n \neq 0$, is placed in
+Mathlib's root namespace.
+
+**Where it is used.** These two operators on the degree-zero Picard group of a function field in
+characteristic $\ell$ are the geometric Frobenius and its transpose on the Jacobian of a modular
+curve in characteristic $\ell$; their sum is the shape of the Eichler–Shimura relation used to
+compare Hecke operators with Frobenius in the study of the Galois representations attached to
+modular forms.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+section PlaceCalculus
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem _root_.ValuationSubring.pow_mem_iff (A : ValuationSubring F) {n : ℕ} (hn : n ≠ 0)
+    (x : F) :
+    x ^ n ∈ A ↔ x ∈ A := by
+  refine ⟨fun hxn => ?_, fun hx => pow_mem hx n⟩
+  rcases A.mem_or_inv_mem x with hx | hxi
+  · exact hx
+  · rcases eq_or_ne x 0 with rfl | hx0
+    · exact zero_mem A
+    · have hkey : x = x ^ n * (x⁻¹) ^ (n - 1) := by
+        rw [inv_pow, eq_comm, mul_inv_eq_iff_eq_mul₀ (pow_ne_zero _ hx0), ← pow_succ']
+        congr 1
+        omega
+      rw [hkey]
+      exact mul_mem hxn (pow_mem hxi _)
+
+private theorem Place.ord_pow (v : Place K F) (f : F) (n : ℕ) :
+    v.ord (f ^ n) = n * v.ord f := by
+  have := v.ord_zpow f (n : ℤ)
+  rwa [zpow_natCast] at this
+
+variable {φ : F →ₐ[K] F} {ℓ : ℕ}
+
+theorem IsFrobeniusEndo.restrictAlong_injective (h : IsFrobeniusEndo ℓ φ) (hℓ : ℓ ≠ 0)
+    (hφ : φ.toRingHom.IsIntegral) :
+    Function.Injective (Place.restrictAlong φ hφ) := by
+  intro w₁ w₂ hw
+  have hval : ∀ w : Place K F, (w.restrictAlong φ hφ).toValuationSubring =
+      w.toValuationSubring.comap φ.toRingHom := by
+    intro w
+    rfl
+  refine Place.ext (SetLike.ext fun x => ?_)
+  obtain ⟨y, hy⟩ := h.pow_mem_range x
+  have key : ∀ w : Place K F,
+      x ∈ w.toValuationSubring ↔ y ∈ (w.restrictAlong φ hφ).toValuationSubring := by
+    intro w
+    rw [hval, ValuationSubring.mem_comap]
+    change x ∈ w.toValuationSubring ↔ φ y ∈ w.toValuationSubring
+    rw [hy]
+    exact (w.toValuationSubring.pow_mem_iff hℓ x).symm
+  rw [key w₁, key w₂, hw]
+
+theorem IsFrobeniusEndo.ramificationIndexAlong_eq (h : IsFrobeniusEndo ℓ φ)
+    (hℓ : ℓ ≠ 0) (w : Place K F) :
+    Place.ramificationIndexAlong φ w = ℓ := by
+  let := algebraAlong φ
+  change w.ramificationIndex F = ℓ
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  have hπF : (π : F) ≠ 0 := by
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  obtain ⟨y, hy⟩ := h.pow_mem_range (π : F)
+  have hy0 : y ≠ 0 := by
+    intro h0
+    rw [h0, map_zero] at hy
+    exact pow_ne_zero ℓ hπF hy.symm
+  have hyord : w.ord (algebraMap F F y) = (ℓ : ℤ) := by
+    change w.ord (φ y) = (ℓ : ℤ)
+    rw [hy, w.ord_pow, w.ord_coe_irreducible hπ, mul_one]
+  have hℓmem : ℓ ∈ {n : ℕ | 0 < n ∧ ∃ f : F, f ≠ 0 ∧ w.ord (algebraMap F F f) = n} :=
+    ⟨Nat.pos_of_ne_zero hℓ, y, hy0, hyord⟩
+  have hlb : ∀ n ∈ {n : ℕ | 0 < n ∧ ∃ f : F, f ≠ 0 ∧ w.ord (algebraMap F F f) = n}, ℓ ≤ n := by
+    rintro n ⟨hn, f, hf, hford⟩
+    obtain ⟨x, hx⟩ := h.mem_range_pow f
+    have hford' : (n : ℤ) = ℓ * w.ord x := by
+      rw [← hford]
+      change w.ord (φ f) = ℓ * w.ord x
+      rw [hx, w.ord_pow]
+    have hxpos : 1 ≤ w.ord x := by
+      by_cases hx1 : 1 ≤ w.ord x
+      · exact hx1
+      · exfalso
+        have hle : (ℓ : ℤ) * w.ord x ≤ 0 :=
+          mul_nonpos_iff.mpr (Or.inl ⟨by positivity, by omega⟩)
+        omega
+    have : (ℓ : ℤ) ≤ (n : ℤ) := by
+      rw [hford']
+      exact le_mul_of_one_le_right (by positivity) hxpos
+    exact_mod_cast this
+  exact le_antisymm (Nat.sInf_le hℓmem)
+    (hlb _ (Nat.sInf_mem (Set.nonempty_of_mem hℓmem)))
+
+theorem IsFrobeniusEndo.ord_restrictAlong_frobNorm (h : IsFrobeniusEndo ℓ φ) (hℓ : ℓ ≠ 0)
+    (hφ : φ.toRingHom.IsIntegral) (w : Place K F) (f : F) :
+    (w.restrictAlong φ hφ).ord (h.frobNorm f) = w.ord f := by
+  have hkey : (ℓ : ℤ) * (w.restrictAlong φ hφ).ord (h.frobNorm f) = ℓ * w.ord f := by
+    calc (ℓ : ℤ) * (w.restrictAlong φ hφ).ord (h.frobNorm f)
+        = (Place.ramificationIndexAlong φ w : ℤ) *
+            (w.restrictAlong φ hφ).ord (h.frobNorm f) := by
+          rw [h.ramificationIndexAlong_eq hℓ]
+      _ = w.ord (φ (h.frobNorm f)) := (w.ord_restrictAlong φ hφ (h.frobNorm f)).symm
+      _ = w.ord (f ^ ℓ) := by rw [h.map_frobNorm]
+      _ = ℓ * w.ord f := w.ord_pow f ℓ
+  have hℓ0 : (ℓ : ℤ) ≠ 0 := Int.natCast_ne_zero.mpr hℓ
+  exact mul_left_cancel₀ hℓ0 hkey
+
+end PlaceCalculus
+
+section NormFormula
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP F ℓ]
+variable {φ : F →ₐ[K] F}
+
+theorem IsFrobeniusEndo.norm_eq_frobNorm (h : IsFrobeniusEndo ℓ φ)
+    (hrank : finrankAlong K φ = ℓ) (f : F) :
+    (letI := algebraAlong φ; Algebra.norm F f) = h.frobNorm f := by
+  let := algebraAlong φ
+  have hpow : (Algebra.norm F f) ^ ℓ = (h.frobNorm f) ^ ℓ := by
+    have h3 : Algebra.norm F (algebraMap F F (h.frobNorm f))
+        = h.frobNorm f ^ finrankAlong K φ :=
+      Algebra.norm_algebraMap (h.frobNorm f)
+    calc (Algebra.norm F f) ^ ℓ
+        = Algebra.norm F (f ^ ℓ) := (map_pow (Algebra.norm F) f ℓ).symm
+      _ = Algebra.norm F (algebraMap F F (h.frobNorm f)) := by
+          rw [show algebraMap F F (h.frobNorm f) = φ (h.frobNorm f) from rfl,
+            h.map_frobNorm f]
+      _ = h.frobNorm f ^ finrankAlong K φ := h3
+      _ = h.frobNorm f ^ ℓ := by rw [hrank]
+  exact frobenius_inj F ℓ hpow
+
+theorem IsFrobeniusEndo.normFormulaAlong (h : IsFrobeniusEndo ℓ φ)
+    (hφ : φ.toRingHom.IsIntegral) (hfin : FiniteAlong K φ)
+    (hrank : finrankAlong K φ = ℓ)
+    (hsurj : Function.Surjective (Place.restrictAlong φ hφ))
+    (hf1 : ∀ w : Place K F, Place.inertiaDegAlong φ hφ w = 1) :
+    NormFormulaAlong K φ hfin := by
+  have hℓ : ℓ ≠ 0 := (Fact.out : ℓ.Prime).ne_zero
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  intro f hf D hD v
+  classical
+  obtain ⟨w₀, hw₀⟩ := hsurj v
+  rw [Divisor.pushforward_apply]
+  have hw₀' : Place.restrict F w₀ = v := hw₀
+  have hf1' : (Place.inertiaDeg F w₀ : ℤ) = 1 := by
+    have := hf1 w₀
+    exact_mod_cast (show Place.inertiaDeg F w₀ = 1 from this)
+  have hcollapse : (∑ w ∈ D.support,
+      if Place.restrict F w = v then D w * (Place.inertiaDeg F w : ℤ) else 0)
+        = D w₀ * (Place.inertiaDeg F w₀ : ℤ) := by
+    refine (Finset.sum_eq_single w₀ ?_ ?_).trans (ite_eq_left hw₀')
+    · intro w _ hwne
+      rw [ite_eq_right]
+      intro hwv
+      exact hwne (h.restrictAlong_injective hℓ hφ
+        ((show Place.restrictAlong φ hφ w = v from hwv).trans hw₀.symm))
+    · intro hw₀mem
+      rw [Finsupp.notMem_support_iff.mp hw₀mem, zero_mul, ite_self]
+  rw [hcollapse, hD w₀, hf1', mul_one]
+  rw [h.norm_eq_frobNorm hrank f]
+  rw [show v = w₀.restrictAlong φ hφ from hw₀.symm]
+  exact (h.ord_restrictAlong_frobNorm hℓ hφ w₀ f).symm
+
+end NormFormula
+
+section Descent
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP F ℓ]
+variable (φ : F →ₐ[K] F)
+
+def frobeniusPushforwardDegZero (hφ : φ.toRingHom.IsIntegral) :
+    Divisor.degZero (K := K) (F := F) →+ Divisor.degZero (K := K) (F := F) :=
+  ((Divisor.pushforwardAlong φ hφ).domRestrict
+    (Divisor.degZero (K := K) (F := F))).codRestrict _
+    (fun D => Divisor.pushforwardAlong_mem_degZero φ hφ D.2)
+
+@[simp]
+theorem coe_frobeniusPushforwardDegZero (hφ : φ.toRingHom.IsIntegral)
+    (D : Divisor.degZero (K := K) (F := F)) :
+    (frobeniusPushforwardDegZero φ hφ D : Divisor K F)
+      = Divisor.pushforwardAlong φ hφ (D : Divisor K F) :=
+  rfl
+
+def IsFrobeniusEndo.pushforwardPic0 (h : IsFrobeniusEndo ℓ φ)
+    (hφ : φ.toRingHom.IsIntegral) (hfin : FiniteAlong K φ)
+    (hrank : finrankAlong K φ = ℓ)
+    (hsurj : Function.Surjective (Place.restrictAlong φ hφ))
+    (hf1 : ∀ w : Place K F, Place.inertiaDegAlong φ hφ w = 1) :
+    Pic0 K F →+ Pic0 K F :=
+  QuotientAddGroup.map _ _ (frobeniusPushforwardDegZero φ hφ) (by
+    rintro ⟨D, hD0⟩ hD
+    simp only [AddSubgroup.mem_addSubgroupOf] at hD ⊢
+    exact Divisor.isPrincipal_pushforwardAlong φ hφ hfin
+      (h.normFormulaAlong hφ hfin hrank hsurj hf1) hD)
+
+theorem IsFrobeniusEndo.pushforwardPic0_mk (h : IsFrobeniusEndo ℓ φ)
+    (hφ : φ.toRingHom.IsIntegral) (hfin : FiniteAlong K φ)
+    (hrank : finrankAlong K φ = ℓ)
+    (hsurj : Function.Surjective (Place.restrictAlong φ hφ))
+    (hf1 : ∀ w : Place K F, Place.inertiaDegAlong φ hφ w = 1)
+    (D : Divisor.degZero (K := K) (F := F)) :
+    (h.pushforwardPic0 φ hφ hfin hrank hsurj hf1) (Pic0.mk D)
+      = Pic0.mk (frobeniusPushforwardDegZero φ hφ D) := by
+  rfl
+
+theorem IsFrobeniusEndo.isPrincipal_pushforwardAlong (h : IsFrobeniusEndo ℓ φ)
+    (hφ : φ.toRingHom.IsIntegral) (hfin : FiniteAlong K φ)
+    (hrank : finrankAlong K φ = ℓ)
+    (hsurj : Function.Surjective (Place.restrictAlong φ hφ))
+    (hf1 : ∀ w : Place K F, Place.inertiaDegAlong φ hφ w = 1)
+    {D : Divisor K F} (hD : D.IsPrincipal) :
+    (Divisor.pushforwardAlong φ hφ D).IsPrincipal :=
+  Divisor.isPrincipal_pushforwardAlong φ hφ hfin
+    (h.normFormulaAlong hφ hfin hrank hsurj hf1) hD
+
+end Descent
+
+section LocalConstant
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] [HasPrincipalDivisors K F]
+variable {φ : F →ₐ[K] F} {ℓ : ℕ}
+
+theorem IsFrobeniusEndo.fiberAlong_eq_singleton (h : IsFrobeniusEndo ℓ φ) (hℓ : ℓ ≠ 0)
+    (hφ : φ.toRingHom.IsIntegral)
+    (hsurj : Function.Surjective (Place.restrictAlong φ hφ)) (v : Place K F) :
+    ∃ w₀ : Place K F, Place.fiberAlong φ hφ v = {w₀} := by
+  obtain ⟨w₀, hw₀⟩ := hsurj v
+  refine ⟨w₀, ?_⟩
+  ext w
+  simp only [Place.mem_fiberAlong, Finset.mem_singleton]
+  constructor
+  · intro hw
+    exact h.restrictAlong_injective hℓ hφ (hw.trans hw₀.symm)
+  · rintro rfl
+    exact hw₀
+
+theorem IsFrobeniusEndo.sum_fiberAlong_eq (h : IsFrobeniusEndo ℓ φ) (hℓ : ℓ ≠ 0)
+    (hφ : φ.toRingHom.IsIntegral)
+    (hsurj : Function.Surjective (Place.restrictAlong φ hφ))
+    (hf1 : ∀ w : Place K F, Place.inertiaDegAlong φ hφ w = 1) (v : Place K F) :
+    ∑ w ∈ Place.fiberAlong φ hφ v,
+        (Place.ramificationIndexAlong φ w : ℤ) * (Place.inertiaDegAlong φ hφ w : ℤ)
+      = (ℓ : ℤ) := by
+  obtain ⟨w₀, hfib⟩ := h.fiberAlong_eq_singleton hℓ hφ hsurj v
+  rw [hfib, Finset.sum_singleton, h.ramificationIndexAlong_eq hℓ w₀, hf1 w₀]
+  simp
+
+theorem IsFrobeniusEndo.fundamentalIdentityAlong (h : IsFrobeniusEndo ℓ φ) (hℓ : ℓ ≠ 0)
+    (hφ : φ.toRingHom.IsIntegral) (hrank : finrankAlong K φ = ℓ)
+    (hsurj : Function.Surjective (Place.restrictAlong φ hφ))
+    (hf1 : ∀ w : Place K F, Place.inertiaDegAlong φ hφ w = 1) :
+    FundamentalIdentityAlong K φ hφ := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  have : SumRamificationInertia K F F := by
+    refine ⟨fun v => ?_⟩
+    have hloc : ∑ w ∈ Place.fiberAlong φ hφ v,
+        (Place.ramificationIndexAlong φ w : ℤ) * (Place.inertiaDegAlong φ hφ w : ℤ)
+          = ((finrankAlong K φ : ℕ) : ℤ) := by
+      rw [hrank]
+      exact h.sum_fiberAlong_eq hℓ hφ hsurj hf1 v
+    exact hloc
+  exact instFundamentalIdentityOfSumRamificationInertia
+
+end LocalConstant
+
+section PullbackDescent
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] [HasPrincipalDivisors K F]
+variable {ℓ : ℕ} [Fact ℓ.Prime] {φ : F →ₐ[K] F}
+
+def IsFrobeniusEndo.frobeniusPullbackDegZero (h : IsFrobeniusEndo ℓ φ)
+    (hφ : φ.toRingHom.IsIntegral) (hrank : finrankAlong K φ = ℓ)
+    (hsurj : Function.Surjective (Place.restrictAlong φ hφ))
+    (hf1 : ∀ w : Place K F, Place.inertiaDegAlong φ hφ w = 1) :
+    Divisor.degZero (K := K) (F := F) →+ Divisor.degZero (K := K) (F := F) :=
+  ((Divisor.pullbackAlong φ hφ).domRestrict
+    (Divisor.degZero (K := K) (F := F))).codRestrict _
+    (fun D => Divisor.pullbackAlong_mem_degZero φ hφ
+      (h.fundamentalIdentityAlong (Fact.out : ℓ.Prime).ne_zero hφ hrank hsurj hf1) D.2)
+
+@[simp]
+theorem IsFrobeniusEndo.coe_frobeniusPullbackDegZero (h : IsFrobeniusEndo ℓ φ)
+    (hφ : φ.toRingHom.IsIntegral) (hrank : finrankAlong K φ = ℓ)
+    (hsurj : Function.Surjective (Place.restrictAlong φ hφ))
+    (hf1 : ∀ w : Place K F, Place.inertiaDegAlong φ hφ w = 1)
+    (D : Divisor.degZero (K := K) (F := F)) :
+    (h.frobeniusPullbackDegZero hφ hrank hsurj hf1 D : Divisor K F)
+      = Divisor.pullbackAlong φ hφ (D : Divisor K F) :=
+  rfl
+
+def IsFrobeniusEndo.pullbackPic0 (h : IsFrobeniusEndo ℓ φ)
+    (hφ : φ.toRingHom.IsIntegral) (hrank : finrankAlong K φ = ℓ)
+    (hsurj : Function.Surjective (Place.restrictAlong φ hφ))
+    (hf1 : ∀ w : Place K F, Place.inertiaDegAlong φ hφ w = 1) :
+    Pic0 K F →+ Pic0 K F :=
+  QuotientAddGroup.map _ _ (h.frobeniusPullbackDegZero hφ hrank hsurj hf1) (by
+    rintro ⟨D, hD0⟩ hD
+    simp only [AddSubgroup.mem_addSubgroupOf] at hD ⊢
+    exact Divisor.isPrincipal_pullbackAlong φ hφ hD)
+
+theorem IsFrobeniusEndo.pullbackPic0_mk (h : IsFrobeniusEndo ℓ φ)
+    (hφ : φ.toRingHom.IsIntegral) (hrank : finrankAlong K φ = ℓ)
+    (hsurj : Function.Surjective (Place.restrictAlong φ hφ))
+    (hf1 : ∀ w : Place K F, Place.inertiaDegAlong φ hφ w = 1)
+    (D : Divisor.degZero (K := K) (F := F)) :
+    h.pullbackPic0 hφ hrank hsurj hf1 (Pic0.mk D)
+      = Pic0.mk (h.frobeniusPullbackDegZero hφ hrank hsurj hf1 D) := by
+  rfl
+
+end PullbackDescent
+
+end AlgebraicCurve
+
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_IsCurveOver.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_IsCurveOver.lean
new file mode 100644
index 0000000000..fa2f2fc9e9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_IsCurveOver.lean
@@ -0,0 +1,128 @@
+/-
+Based on Prove2Me node AlgebraicCurve_IsCurveOver
+(60ada695-533a-5c10-a2be-8aa441728240) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import Mathlib.RingTheory.Kaehler.Basic
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+
+/-!
+# The curve axioms `IsCurveOver` for a function field
+
+Definition: `AlgebraicCurve_IsCurveOver` (`60ada695-533a-5c10-a2be-8aa441728240`), by Claude,
+2026-09-05.
+
+Throughout, $K$ and $F$ are fields with $F$ a $K$-algebra. A place of $F/K$ (the structure `Place K
+F` of the divisor-class module) is a valuation subring $A \subseteq F$ containing the image of $K$,
+with $A \neq F$ and with $A$ a principal ideal ring, so that $A$ is a discrete valuation ring; its
+residue field $\kappa(v)$ is a $K$-algebra, $v.\mathrm{deg}$ is $\dim_K \kappa(v)$, and
+$\mathrm{ord}_v$ is the associated normalised valuation on $F$. The class `HasPrincipalDivisors K F`
+asserts that for every $f \in F^{\times}$ there is a finitely supported function $D :
+\mathrm{Place}\,K\,F \to \mathbb{Z}$ with $D(v) = \mathrm{ord}_v(f)$ for every place $v$ and with
+$\deg D = \sum_v D(v)\,v.\mathrm{deg} = 0$; that is, the divisor of $f$ exists as a divisor and has
+degree zero.
+
+The class defined here, `IsCurveOver K F`, extends `HasPrincipalDivisors K F` by two further fields:
+every place $v$ of $F/K$ has residue field finite over $K$, and the module of Kähler differentials
+$\Omega_{F/K}$ is free of rank one over $F$. The accessors record these as separately usable facts:
+the underlying principal-divisors structure, finiteness of each residue field (also registered as
+the `Place.FiniteResidue` property at every place), freeness of $\Omega_{F/K}$, $\dim_F \Omega_{F/K}
+= 1$, and hence nontriviality of $\Omega_{F/K}$. Finally, if $K$ is algebraically closed and
+$\kappa(v)$ is finite over $K$, then $K \to \kappa(v)$ is integral and therefore bijective, so
+$v.\mathrm{deg} = 1$; consequently, over an algebraically closed $K$ every place of a curve $F/K$
+has degree one, stated both pointwise and as a universally quantified statement.
+
+**Relation to Mathlib.** Mathlib has no axiomatisation of the function field of a curve of this
+shape; `Place`, `HasPrincipalDivisors` and `IsCurveOver` are the project's own, built on Mathlib's
+valuation subrings, discrete valuation rings and Kähler differentials `Ω[F⁄K]`.
+
+**Where it is used.** This package is the hypothesis discharged wherever a function field is treated
+as the function field of a curve: it supplies degree-zero divisors and the group $\mathrm{Pic}^0$,
+the finiteness of residue fields needed for the degree map, and the rank-one differential module
+underlying canonical-divisor and Riemann–Roch arguments. These are used in the study of modular
+curves and of the special fibre of $X_0(N)$, where the base field is algebraically closed and all
+places have degree one.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open KaehlerDifferential
+
+namespace AlgebraicCurve
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+class IsCurveOver : Prop extends HasPrincipalDivisors K F where
+  finiteResidue : ∀ v : Place K F, Module.Finite K v.ResidueField
+  kaehler_free_rank_one : Module.Free F Ω[F⁄K] ∧ Module.finrank F Ω[F⁄K] = 1
+
+namespace IsCurveOver
+
+variable {K F}
+
+theorem hasPrincipalDivisors [h : IsCurveOver K F] : HasPrincipalDivisors K F :=
+  h.toHasPrincipalDivisors
+
+theorem finite_residueField [IsCurveOver K F] (v : Place K F) :
+    Module.Finite K v.ResidueField :=
+  IsCurveOver.finiteResidue v
+
+instance instFiniteResidue [IsCurveOver K F] (v : Place K F) : v.FiniteResidue :=
+  ⟨IsCurveOver.finiteResidue v⟩
+
+instance instFreeKaehler [h : IsCurveOver K F] : Module.Free F Ω[F⁄K] :=
+  h.kaehler_free_rank_one.1
+
+theorem finrank_kaehler [h : IsCurveOver K F] : Module.finrank F Ω[F⁄K] = 1 :=
+  h.kaehler_free_rank_one.2
+
+instance instNontrivialKaehler [IsCurveOver K F] : Nontrivial Ω[F⁄K] :=
+  Module.nontrivial_of_finrank_eq_succ (n := 0) finrank_kaehler
+
+end IsCurveOver
+
+namespace Place
+
+variable {K F}
+
+theorem deg_eq_one_of_isAlgClosed_of_finite [IsAlgClosed K] (v : Place K F)
+    [Module.Finite K v.ResidueField] : v.deg = 1 := by
+  have : Algebra.IsIntegral K v.ResidueField := Algebra.IsIntegral.of_finite K v.ResidueField
+  have hbij : Function.Bijective (algebraMap K v.ResidueField) :=
+    IsAlgClosed.algebraMap_bijective_of_isIntegral
+  change Module.finrank K v.ResidueField = 1
+  rw [← Module.finrank_self K]
+  exact ((AlgEquiv.ofBijective (Algebra.ofId K v.ResidueField) hbij).toLinearEquiv.finrank_eq).symm
+
+end Place
+
+namespace IsCurveOver
+
+variable {K F}
+
+theorem deg_eq_one_of_isAlgClosed [IsAlgClosed K] [IsCurveOver K F] (v : Place K F) :
+    v.deg = 1 :=
+  haveI : Module.Finite K v.ResidueField := IsCurveOver.finiteResidue v
+  v.deg_eq_one_of_isAlgClosed_of_finite
+
+theorem forall_deg_eq_one_of_isAlgClosed [IsAlgClosed K] [IsCurveOver K F] :
+    ∀ w : Place K F, w.deg = 1 :=
+  deg_eq_one_of_isAlgClosed
+
+end IsCurveOver
+
+end AlgebraicCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_LocalResidue.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_LocalResidue.lean
new file mode 100644
index 0000000000..4019a35e42
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_LocalResidue.lean
@@ -0,0 +1,360 @@
+/-
+Based on Prove2Me node AlgebraicCurve_LocalResidue
+(80b50a9e-396b-5f9e-b983-af43c676526a) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_CanonicalDivisor
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CanonicalDivisorUniformizer
+
+/-!
+# Local residues at places and Weil differentials of Kähler forms
+
+Definition: `AlgebraicCurve_LocalResidue` (`80b50a9e-396b-5f9e-b983-af43c676526a`), by Claude,
+2026-09-05.
+
+Throughout, $F/K$ is an extension of fields and a place $v$ of $F/K$ is the project's structure: a
+valuation subring $\mathcal O_v \subsetneq F$ containing the image of $K$ and a principal ideal ring
+(hence a discrete valuation ring), with normalised valuation $\operatorname{ord}_v$, residue field
+$\kappa(v)$ and uniformiser $\pi_v$ (a chosen irreducible of $\mathcal O_v$, so
+$\operatorname{ord}_v \pi_v = 1$). A `LocalResidueData` for $v$ is a structure carrying a $K$-linear
+map $\operatorname{res} : F \to \kappa(v)$ together with two properties as fields:
+$\operatorname{res} f = 0$ for $f \in \mathcal O_v$, and $\operatorname{res} f = \overline{\pi_v f}$
+whenever $\pi_v f \in \mathcal O_v$ (the class of $\pi_v f$ in $\kappa(v)$); informally,
+$\operatorname{res}$ is the residue of $f\,d\pi_v$. `CanonicalLocalResidueDataK` extends this by the
+further field $\operatorname{res}(\pi_v^{-(n+1)}) = 0$ for all $n \ge 1$. Three classes package the
+availability of such data: `HasLocalResidue` and `HasCanonicalLocalResidueK` are propositions
+asserting that each place admits (respectively, canonical) data, while
+`HasCanonicalLocalResidueKStar` is data-valued, choosing `CanonicalLocalResidueDataK` at every
+place; the evident implications between them are instances. Under the last class,
+`Place.localResidue` is the chosen map, and lemmas record its vanishing on $\mathcal O_v$, the
+simple-pole formula, the vanishing on $\pi_v^{-(n+1)}$ ($n\ge 1$), its vanishing whenever $f = 0$ or
+$\operatorname{ord}_v f \ge 0$, and $\operatorname{res}_v(\pi_v^{-1}) = 1$.
+
+For a Kähler differential $\omega \in \Omega[F\!\mid\!K]$ with local coefficient $\partial_v\omega$
+(the coefficient in $\omega = \partial_v\omega \cdot d\pi_v$), the local term is
+$\operatorname{Tr}_{\kappa(v)/K}\operatorname{res}_v(\alpha_v\,\partial_v\omega)$, defined both for
+the chosen family (`kaehlerResidueTerm`) and for an explicitly given family $R$ of canonical data
+(`Place.kaehlerResidueTermK`, `kaehlerResidueTermKFam`). Assuming a canonical divisor exists and
+every place satisfies `DCoordGenerates`, the support of $v \mapsto$ term is contained in the support
+of $D - \operatorname{div}(\omega)$ for $\alpha \in$ `adeleBdd D`, hence finite for adèles, and
+`weilOfKaehlerK` is the resulting $K$-linear functional $\alpha \mapsto \sum_v^{\mathrm f}$ (terms)
+on `adeleSpace K F`; it vanishes on `adeleBdd (canonicalDivisorOf hω)`. Auxiliary declarations show
+$\operatorname{ord}_v f \ge 0$ forces $f \in \mathcal O_v$, that $\partial_v\omega \neq 0$ for
+$\omega \neq 0$ at a place with `DCoordGenerates`, and that $\operatorname{Pi.single} v\, g$ lies in
+`adeleBdd D` (given $v$-adic bound) and in `adeleSpace K F` (`adeleSingle`). `HasSeparableResidue`
+asserts that $\operatorname{Tr}_{\kappa(v)/K} \neq 0$ as a $K$-linear map at every place. Finally
+`ResidueTheoremK K F` is the proposition that for every family of canonical data, assuming principal
+divisors exist, every nonzero $\omega$ and every $f \in F$, the functional `weilOfKaehlerK`
+annihilates the diagonal adèle of $f$.
+
+**Relation to Mathlib.** The local residue maps, the classes supplying them at all places, and the
+induced functional on the adèle space are the project's own notions; the ambient ingredients
+(valuation subrings and their residue fields, Kähler differentials $\Omega[F\!\mid\!K]$,
+`Algebra.trace`, `Module.Dual`) are Mathlib's.
+
+**Where it is used.** These residues provide the link between Kähler differentials of a function
+field and Weil differentials, i.e. functionals on the adèle space annihilating the diagonal and a
+bounded subspace; the residue theorem in this form is what supplies a nonzero Weil differential and
+hence the Riemann–Roch theorem for the curves occurring in the modular-curve part of the argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open IsDedekindDomain WithZero Module IsLocalRing KaehlerDifferential
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable (v : Place K F)
+
+structure LocalResidueData where
+  res : F →ₗ[K] v.ResidueField
+  res_of_mem : ∀ f : F, f ∈ v.toValuationSubring → res f = 0
+  res_simplePole : ∀ (f : F) (hf : v.uniformizer * f ∈ v.toValuationSubring),
+    res f = IsLocalRing.residue _ ⟨v.uniformizer * f, hf⟩
+
+structure CanonicalLocalResidueDataK extends v.LocalResidueData where
+  res_higherPoleMonomial : ∀ (n : ℕ), 1 ≤ n → res (v.uniformizer ^ (n + 1))⁻¹ = 0
+
+end Place
+
+variable (K F) in
+class HasLocalResidue : Prop where
+  exists_data : ∀ v : Place K F, Nonempty v.LocalResidueData
+
+variable (K F) in
+class HasCanonicalLocalResidueK : Prop where
+  exists_data : ∀ v : Place K F, Nonempty v.CanonicalLocalResidueDataK
+
+instance (priority := 100) instHasLocalResidue_of_hasCanonicalLocalResidueK
+    [HasCanonicalLocalResidueK K F] : HasLocalResidue K F :=
+  ⟨fun v => (HasCanonicalLocalResidueK.exists_data v).map (·.toLocalResidueData)⟩
+
+variable (K F) in
+class HasCanonicalLocalResidueKStar where
+  dataKStar : ∀ v : Place K F, v.CanonicalLocalResidueDataK
+
+instance (priority := 100) instHasCanonicalLocalResidueK_of_hasCanonicalLocalResidueKStar
+    [HasCanonicalLocalResidueKStar K F] : HasCanonicalLocalResidueK K F :=
+  ⟨fun v => ⟨HasCanonicalLocalResidueKStar.dataKStar v⟩⟩
+
+namespace Place
+
+variable (v : Place K F)
+
+private theorem mem_of_ord_nonneg_localResidueAux {f : F} (hf : f ≠ 0) (h : 0 ≤ v.ord f) :
+    f ∈ v.toValuationSubring := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ
+  rw [hu, show v.ord f = (((v.ord f).toNat : ℕ) : ℤ) from (Int.toNat_of_nonneg h).symm,
+    zpow_natCast]
+  exact mul_mem (u : v.toValuationSubring).2 (pow_mem (π : v.toValuationSubring).2 _)
+
+noncomputable def localResidue [HasCanonicalLocalResidueKStar K F] :
+    F →ₗ[K] v.ResidueField :=
+  (HasCanonicalLocalResidueKStar.dataKStar v).res
+
+theorem localResidue_of_mem [HasCanonicalLocalResidueKStar K F] {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    v.localResidue f = 0 :=
+  (HasCanonicalLocalResidueKStar.dataKStar v).res_of_mem f hf
+
+theorem localResidue_simplePole [HasCanonicalLocalResidueKStar K F] (f : F)
+    (hf : v.uniformizer * f ∈ v.toValuationSubring) :
+    v.localResidue f = IsLocalRing.residue _ ⟨v.uniformizer * f, hf⟩ :=
+  (HasCanonicalLocalResidueKStar.dataKStar v).res_simplePole f hf
+
+theorem localResidue_higherPoleMonomial [HasCanonicalLocalResidueKStar K F]
+    (n : ℕ) (hn : 1 ≤ n) :
+    v.localResidue (v.uniformizer ^ (n + 1))⁻¹ = 0 :=
+  (HasCanonicalLocalResidueKStar.dataKStar v).res_higherPoleMonomial n hn
+
+theorem localResidue_eq_zero_of_ord_nonneg [HasCanonicalLocalResidueKStar K F] {f : F}
+    (hf : f = 0 ∨ 0 ≤ v.ord f) : v.localResidue f = 0 := by
+  rcases hf with rfl | hf
+  · exact map_zero _
+  · rcases eq_or_ne f 0 with rfl | hf0
+    · exact map_zero _
+    · exact v.localResidue_of_mem (v.mem_of_ord_nonneg_localResidueAux hf0 hf)
+
+theorem gate_localResidue_uniformizer_inv [HasCanonicalLocalResidueKStar K F] :
+    v.localResidue v.uniformizer⁻¹ = 1 := by
+  have hmem : v.uniformizer * v.uniformizer⁻¹ ∈ v.toValuationSubring := by
+    rw [mul_inv_cancel₀ v.uniformizer_ne_zero]; exact one_mem _
+  rw [v.localResidue_simplePole _ hmem]
+  have h1 : (⟨v.uniformizer * v.uniformizer⁻¹, hmem⟩ : v.toValuationSubring) = 1 :=
+    Subtype.ext (mul_inv_cancel₀ v.uniformizer_ne_zero)
+  rw [h1, map_one]
+
+end Place
+
+def kaehlerResidueTerm [HasCanonicalLocalResidueKStar K F]
+    (ω : Ω[F⁄K]) (α : Place K F → F) (v : Place K F) : K :=
+  Algebra.trace K v.ResidueField (v.localResidue (α v * v.differentialCoeff ω))
+
+theorem kaehlerResidueTerm_eq_zero_of_ord_nonneg
+    [HasCanonicalLocalResidueKStar K F]
+    {ω : Ω[F⁄K]} {α : Place K F → F}
+    {v : Place K F} (h : α v * v.differentialCoeff ω = 0 ∨
+      0 ≤ v.ord (α v * v.differentialCoeff ω)) :
+    kaehlerResidueTerm ω α v = 0 := by
+  unfold kaehlerResidueTerm
+  rw [v.localResidue_eq_zero_of_ord_nonneg h, map_zero]
+
+theorem Place.differentialCoeff_ne_zero (v : Place K F) [v.DCoordGenerates]
+    {ω : Ω[F⁄K]} (hω : ω ≠ 0) : v.differentialCoeff ω ≠ 0 := fun h =>
+  hω (by rw [← v.differentialCoeff_smul_dCoord ω, h, zero_smul])
+
+namespace Place
+
+theorem LocalResidueData.res_eq_zero_of_ord_nonneg {v : Place K F} (R : v.LocalResidueData)
+    {f : F} (hf : f = 0 ∨ 0 ≤ v.ord f) : R.res f = 0 := by
+  rcases hf with rfl | hf
+  · exact map_zero _
+  · rcases eq_or_ne f 0 with rfl | hf0
+    · exact map_zero _
+    · exact R.res_of_mem f (v.mem_of_ord_nonneg_localResidueAux hf0 hf)
+
+theorem CanonicalLocalResidueDataK.res_eq_zero_of_ord_nonneg {v : Place K F}
+    (R : v.CanonicalLocalResidueDataK) {f : F} (hf : f = 0 ∨ 0 ≤ v.ord f) : R.res f = 0 :=
+  R.toLocalResidueData.res_eq_zero_of_ord_nonneg hf
+
+end Place
+
+section Single
+
+theorem single_mem_adeleBdd [DecidableEq (Place K F)]
+    (v : Place K F) (g : F) (D : Divisor K F)
+    (hg : v.adicValuation g ≤ WithZero.exp (D v)) :
+    Pi.single v g ∈ adeleBdd D := by
+  intro w
+  rcases eq_or_ne w v with rfl | hw
+  · simpa only [Pi.single_eq_same] using hg
+  · rw [Pi.single_eq_of_ne hw, Valuation.map_zero]; exact zero_le
+
+theorem single_mem_adeleSpace [DecidableEq (Place K F)]
+    (v : Place K F) (g : F) :
+    Pi.single v g ∈ adeleSpace K F := by
+  rcases eq_or_ne g 0 with rfl | hg
+  · simpa only [Pi.single_zero] using (adeleSpace K F).zero_mem
+  · refine adeleBdd_le_adeleSpace
+      (single_mem_adeleBdd v g (Finsupp.single v (-v.ord g)) ?_)
+    rw [v.adicValuation_eq_exp_neg_ord hg, Finsupp.single_eq_same]
+
+def adeleSingle [DecidableEq (Place K F)]
+    (v : Place K F) (g : F) : adeleSpace K F :=
+  ⟨Pi.single v g, single_mem_adeleSpace v g⟩
+
+@[simp]
+theorem adeleSingle_coe [DecidableEq (Place K F)]
+    (v : Place K F) (g : F) :
+    (adeleSingle v g : Place K F → F) = Pi.single v g := rfl
+
+end Single
+
+variable (K F) in
+class HasSeparableResidue : Prop where
+  trace_ne_zero : ∀ v : Place K F, (Algebra.trace K v.ResidueField : _ →ₗ[K] K) ≠ 0
+
+section CanonicalKResidueTerm
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+def Place.kaehlerResidueTermK (v : Place K F) (R : v.CanonicalLocalResidueDataK)
+    (ω : Ω[F⁄K]) (f : F) : K :=
+  Algebra.trace K v.ResidueField (R.res (f * v.differentialCoeff ω))
+
+def kaehlerResidueTermKFam (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK)
+    (ω : Ω[F⁄K]) (α : Place K F → F) (v : Place K F) : K :=
+  v.kaehlerResidueTermK (Rfam v) ω (α v)
+
+@[simp]
+theorem kaehlerResidueTermKFam_apply (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK)
+    (ω : Ω[F⁄K]) (α : Place K F → F) (v : Place K F) :
+    kaehlerResidueTermKFam Rfam ω α v
+      = Algebra.trace K v.ResidueField ((Rfam v).res (α v * v.differentialCoeff ω)) := rfl
+
+theorem kaehlerResidueTermKFam_eq_zero_of_ord_nonneg
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK) {ω : Ω[F⁄K]}
+    {α : Place K F → F} {v : Place K F}
+    (h : α v * v.differentialCoeff ω = 0 ∨ 0 ≤ v.ord (α v * v.differentialCoeff ω)) :
+    kaehlerResidueTermKFam Rfam ω α v = 0 := by
+  rw [kaehlerResidueTermKFam_apply, (Rfam v).res_eq_zero_of_ord_nonneg h, map_zero]
+
+section SupportMachinery
+
+variable [HasCanonicalDivisor (K := K) (F := F)] [∀ v : Place K F, v.DCoordGenerates]
+
+theorem kaehlerResidueTermKFam_eq_zero_of_adeleBdd_canonical
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK) {ω : Ω[F⁄K]} (hω : ω ≠ 0)
+    {α : Place K F → F} (hα : α ∈ adeleBdd (canonicalDivisorOf hω)) (v : Place K F) :
+    kaehlerResidueTermKFam Rfam ω α v = 0 := by
+  refine kaehlerResidueTermKFam_eq_zero_of_ord_nonneg Rfam ?_
+  rcases eq_or_ne (α v) 0 with h0 | h0
+  · exact Or.inl (by rw [h0, zero_mul])
+  · refine Or.inr ?_
+    have hg := v.differentialCoeff_ne_zero hω
+    rw [v.ord_mul h0 hg]
+    have hαv : -(canonicalDivisorOf hω v) ≤ v.ord (α v) := by
+      have hval := hα v
+      rw [v.adicValuation_eq_exp_neg_ord h0] at hval
+      exact neg_le_of_neg_le (WithZero.exp_le_exp.mp hval)
+    rw [canonicalDivisorOf_apply hω v, Place.ordDifferential] at hαv
+    linarith
+
+theorem kaehlerResidueTermKFam_support_subset
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK) {ω : Ω[F⁄K]} (hω : ω ≠ 0)
+    {D : Divisor K F} {α : Place K F → F} (hα : α ∈ adeleBdd D) :
+    Function.support (kaehlerResidueTermKFam Rfam ω α)
+      ⊆ ↑(D - canonicalDivisorOf hω).support := by
+  intro v hv
+  rw [Finset.mem_coe, Finsupp.mem_support_iff, Finsupp.sub_apply, ne_eq, sub_eq_zero]
+  intro hDω
+  apply hv
+  refine kaehlerResidueTermKFam_eq_zero_of_ord_nonneg Rfam ?_
+  rcases eq_or_ne (α v) 0 with h0 | h0
+  · exact Or.inl (by rw [h0, zero_mul])
+  · refine Or.inr ?_
+    have hg := v.differentialCoeff_ne_zero hω
+    rw [v.ord_mul h0 hg]
+    have hαv : -(D v) ≤ v.ord (α v) := by
+      have hval := hα v
+      rw [v.adicValuation_eq_exp_neg_ord h0] at hval
+      exact neg_le_of_neg_le (WithZero.exp_le_exp.mp hval)
+    rw [hDω, canonicalDivisorOf_apply hω v, Place.ordDifferential] at hαv
+    linarith
+
+theorem kaehlerResidueTermKFam_support_finite
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK) {ω : Ω[F⁄K]} (hω : ω ≠ 0)
+    {D : Divisor K F} {α : Place K F → F} (hα : α ∈ adeleBdd D) :
+    (Function.support (kaehlerResidueTermKFam Rfam ω α)).Finite :=
+  Set.Finite.subset (Finset.finite_toSet _)
+    (kaehlerResidueTermKFam_support_subset Rfam hω hα)
+
+theorem kaehlerResidueTermKFam_support_finite_of_adeleSpace
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK) {ω : Ω[F⁄K]} (hω : ω ≠ 0)
+    {α : Place K F → F} (hα : α ∈ adeleSpace K F) :
+    (Function.support (kaehlerResidueTermKFam Rfam ω α)).Finite := by
+  obtain ⟨D, hD⟩ := mem_adeleSpace_iff.mp hα
+  exact kaehlerResidueTermKFam_support_finite Rfam hω hD
+
+def weilOfKaehlerK (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK)
+    {ω : Ω[F⁄K]} (hω : ω ≠ 0) : Module.Dual K (adeleSpace K F) where
+  toFun α := ∑ᶠ v, kaehlerResidueTermKFam Rfam ω (α : Place K F → F) v
+  map_add' α β := by
+    have hsupα := kaehlerResidueTermKFam_support_finite_of_adeleSpace Rfam hω α.2
+    have hsupβ := kaehlerResidueTermKFam_support_finite_of_adeleSpace Rfam hω β.2
+    rw [← finsum_add_distrib hsupα hsupβ]
+    refine finsum_congr fun v => ?_
+    simp only [kaehlerResidueTermKFam_apply]
+    rw [Submodule.coe_add, Pi.add_apply, add_mul, map_add, map_add]
+  map_smul' c α := by
+    simp only [RingHom.id_apply]
+    rw [smul_finsum]
+    refine finsum_congr fun v => ?_
+    simp only [kaehlerResidueTermKFam_apply]
+    rw [Submodule.coe_smul, Pi.smul_apply, Algebra.smul_def, mul_assoc,
+      ← Algebra.smul_def, map_smul, map_smul]
+
+theorem weilOfKaehlerK_apply (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK)
+    {ω : Ω[F⁄K]} (hω : ω ≠ 0) (α : adeleSpace K F) :
+    weilOfKaehlerK Rfam hω α
+      = ∑ᶠ v, kaehlerResidueTermKFam Rfam ω (α : Place K F → F) v := rfl
+
+theorem weilOfKaehlerK_vanish_adeleBdd_canonical
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK) {ω : Ω[F⁄K]} (hω : ω ≠ 0)
+    {α : adeleSpace K F} (hα : (α : Place K F → F) ∈ adeleBdd (canonicalDivisorOf hω)) :
+    weilOfKaehlerK Rfam hω α = 0 := by
+  rw [weilOfKaehlerK_apply]
+  exact finsum_eq_zero_of_forall_eq_zero
+    (kaehlerResidueTermKFam_eq_zero_of_adeleBdd_canonical Rfam hω hα)
+
+variable (K F)
+
+def ResidueTheoremK : Prop :=
+  ∀ (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK) [HasPrincipalDivisors K F]
+    {ω : Ω[F⁄K]} (hω : ω ≠ 0) (f : F),
+    weilOfKaehlerK Rfam hω ⟨diagonalHom K F f, diagonal_mem_adeleSpace f⟩ = 0
+
+end SupportMachinery
+
+end CanonicalKResidueTerm
+
+end AlgebraicCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_PlaceCompletion.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_PlaceCompletion.lean
new file mode 100644
index 0000000000..cc309566b7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_PlaceCompletion.lean
@@ -0,0 +1,568 @@
+/-
+Based on Prove2Me node AlgebraicCurve_PlaceCompletion
+(167709dd-ccd9-51e3-a47c-f878cec56c75) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Order.Ring.Star
+public import Mathlib.Algebra.Order.Star.Real
+public import Mathlib.Data.Int.Star
+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.SimpleRing.Principal
+public import Mathlib.Topology.Algebra.Module.FiniteDimension
+public import Mathlib.Topology.Algebra.Valued.NormedValued
+public import Mathlib.Topology.UniformSpace.Uniformizable
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import LeanPool.FLTEichlerShimura.Definitions.Def_DedekindDomain_AdicValuation_InlineSpecific
+
+/-!
+# Adic completions at places and their functoriality
+
+Definition: `AlgebraicCurve_PlaceCompletion` (`167709dd-ccd9-51e3-a47c-f878cec56c75`), by Claude,
+2026-09-05.
+
+Throughout, a place $V$ of a field extension $F/K$ is the project's `Place K F`: a valuation subring
+$\mathcal O_V\subseteq F$ containing $\operatorname{im}(K\to F)$, proper in $F$ and a principal
+ideal ring, hence a discrete valuation ring, with `heightOneSpectrum` its maximal ideal,
+`adicValuation` the induced $\mathbb Z^{m0}$-valued valuation on $F$ and `ord` minus its logarithm.
+Here `adicCompletion` and `adicCompletionIntegers` name the completion $\hat F_V$ of $F$ at that
+height-one prime and its valuation subring $\hat{\mathcal O}_V$, in Mathlib's sense.
+
+For $K\subseteq F\subseteq F'$ with $F'/F$ integral and a place $W$ of $F'$, write
+$V=W.\mathrm{restrict}\,F$ (the contraction of $\mathcal O_W$ along $F\to F'$) and
+$e=W.\mathrm{ramificationIndex}\,F$ (the least positive value attained by $\mathrm{ord}_W$ on
+nonzero elements of $F$). The valuation identity $v_W(\iota x)=v_V(x)^e$ is proved on $F$, then on
+the `WithVal` models, where the induced map is shown uniformly continuous; completing it gives the
+ring homomorphism `kw_ffgc_adicCompletionComap` $\hat F_V\to\hat{F'}_W$, continuous, compatible with
+the coercions from $F$, and satisfying $v(\varphi x)=v(x)^e$; it carries $\hat{\mathcal O}_V$ into
+$\hat{\mathcal O}_W$, whence a map of integer rings and the corresponding algebra structures, scalar
+towers and continuity of scalar multiplication. Further declarations: a rank-one structure on the
+valuation of $\hat F_V$ coming from its discreteness (base $2$), the real absolute value
+$y\mapsto\lVert y\rVert^{1/e}$ on $\hat{F'}_W$, compatibility of the two algebra maps out of $F$,
+the $\hat F_V$-linear map sending a family of coefficients to the corresponding combination of the
+images of an $F$-basis of $F'$, its dense range, finite-dimensionality of $\hat{F'}_W$ over $\hat
+F_V$ when $[F':F]<\infty$, the trace $\operatorname{Tr}_{\hat{F'}_W/\hat F_V}$ and its $F$-linear
+restriction along $F'\to\hat{F'}_W$. Finally: $v_V$ of the image of $x\in F$ equals
+$V.\mathrm{adicValuation}\,x$; the image lies in $\hat{\mathcal O}_V$ exactly when $x\in\mathcal
+O_V$; every element of $\hat F_V$ differs from an element of $F$ by an element of $\hat{\mathcal
+O}_V$; and $K$ maps into $\hat{\mathcal O}_V$, giving $\hat{\mathcal O}_V$ a $K$-algebra structure.
+A general instance makes any $K$-algebra an algebra over a valuation subring of $K$.
+
+**Relation to Mathlib.** The completion and its integers are Mathlib's
+`IsDedekindDomain.HeightOneSpectrum.adicCompletion` for the maximal ideal of the valuation ring of a
+`Place`; `Place`, its `restrict` and `ramificationIndex` are the project's own notions, and the map
+between completions along `restrict`, together with the associated algebra and trace structure, is
+built here.
+
+**Where it is used.** These definitions supply the local vocabulary (completions at places,
+ramification indices, local traces and approximation by global elements) used in the project's
+treatment of divisors and residues on curves, which feeds the modular-curve part of the argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+instance {K L : Type*} [Field K] [Semiring L] (O : ValuationSubring K) [Algebra K L] :
+    Algebra O L where
+  smul r x := r.1 • x
+  algebraMap := (algebraMap K L).comp (algebraMap O K)
+  commutes' _ _ := by simp [Algebra.commutes]
+  smul_def' _ _ := by simp [← Algebra.smul_def]; rfl
+
+noncomputable section
+
+open IsDedekindDomain IsDedekindDomain.HeightOneSpectrum IsLocalRing WithZero MonoidWithZeroHom
+
+namespace AlgebraicCurve.Place
+
+section AdicCompletion
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (V : Place K F)
+
+abbrev adicCompletion : Type _ := V.heightOneSpectrum.adicCompletion F
+
+abbrev adicCompletionIntegers : ValuationSubring V.adicCompletion :=
+  V.heightOneSpectrum.adicCompletionIntegers F
+
+end AdicCompletion
+
+section WithValLevel
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+variable (F)
+variable [Algebra F F'] [IsScalarTower K F F'] [Algebra.IsIntegral F F'] (W : Place K F')
+
+theorem kw_ffgc_adicValuation_algebraMap (x : F) :
+    W.adicValuation (algebraMap F F' x)
+      = (W.restrict F).adicValuation x ^ W.ramificationIndex F := by
+  rcases eq_or_ne x 0 with rfl | hx
+  · simp [adicValuation, zero_pow (W.ramificationIndex_pos (F := F)).ne']
+  · have hord := W.ord_restrict (F := F) x
+    have hax : algebraMap F F' x ≠ 0 :=
+      (map_ne_zero_iff _ (algebraMap F F').injective).mpr hx
+    have hV0 : (W.restrict F).adicValuation x ≠ 0 := (W.restrict F).adicValuation_ne_zero hx
+    have hW0 : W.adicValuation (algebraMap F F' x) ≠ 0 := W.adicValuation_ne_zero hax
+    unfold ord at hord
+    have hlog : WithZero.log (W.adicValuation (algebraMap F F' x))
+        = WithZero.log ((W.restrict F).adicValuation x ^ W.ramificationIndex F) := by
+      rw [← zpow_natCast, log_zpow, zsmul_eq_mul, Int.cast_natCast]; linarith
+    rw [← exp_log hW0, hlog, exp_log (pow_ne_zero _ hV0)]
+
+theorem kw_ffgc_valued_withValMapAlgebraMap
+    (x : WithVal ((W.restrict F).heightOneSpectrum.valuation F)) :
+    Valued.v (WithVal.map ((W.restrict F).heightOneSpectrum.valuation F)
+      (W.heightOneSpectrum.valuation F') (algebraMap F F') x)
+        = Valued.v x ^ W.ramificationIndex F := by
+  rw [WithVal.map_apply, WithVal.valued_toVal]
+  exact kw_ffgc_adicValuation_algebraMap F W x.ofVal
+
+theorem kw_ffgc_uniformContinuous_withValMapAlgebraMap :
+    UniformContinuous (WithVal.map ((W.restrict F).heightOneSpectrum.valuation F)
+      (W.heightOneSpectrum.valuation F') (algebraMap F F')) := by
+  refine uniformContinuous_of_continuousAt_zero _ ?_
+  simp_rw [ContinuousAt, map_zero, (Valued.hasBasis_nhds_zero _ _).tendsto_iff
+    (Valued.hasBasis_nhds_zero _ _), true_and, forall_const]
+  intro γ
+  have hγ0 : (ValueGroup₀.embedding (γ.val) : ℤᵐ⁰) ≠ 0 :=
+    (γ.isUnit.map ValueGroup₀.embedding).ne_zero
+  have hc0 : min (ValueGroup₀.embedding γ.val) (1 : ℤᵐ⁰) ≠ 0 :=
+    (lt_min (zero_lt_iff.mpr hγ0) zero_lt_one).ne'
+  obtain ⟨x₀, hx₀⟩ :=
+    (W.restrict F).heightOneSpectrum.valuation_surjective F
+      (min (ValueGroup₀.embedding γ.val) 1)
+  have hx₀v : Valued.v (WithVal.toVal ((W.restrict F).heightOneSpectrum.valuation F) x₀) =
+      min (ValueGroup₀.embedding γ.val) 1 := by
+    rw [WithVal.valued_toVal, hx₀]
+  have hδ0 : Valued.v.restrict
+      (WithVal.toVal ((W.restrict F).heightOneSpectrum.valuation F) x₀) ≠ 0 := by
+    rw [ne_eq, Valuation.restrict_eq_zero_iff, hx₀v]
+    exact hc0
+  refine ⟨Units.mk0 _ hδ0, fun x hx => ?_⟩
+  simp only [Set.mem_ofPred_eq, Units.val_mk0] at hx ⊢
+  rw [Valuation.restrict_lt_iff, hx₀v] at hx
+  rw [Valuation.restrict_lt_iff_lt_embedding, kw_ffgc_valued_withValMapAlgebraMap F W x]
+  calc Valued.v x ^ W.ramificationIndex F
+      ≤ Valued.v x ^ 1 :=
+        pow_le_pow_right_of_le_one' (hx.trans_le (min_le_right _ _)).le
+          (W.ramificationIndex_pos (F := F))
+    _ = Valued.v x := pow_one _
+    _ < ValueGroup₀.embedding γ.val := hx.trans_le (min_le_left _ _)
+
+end WithValLevel
+
+section CompletionComap
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+variable (F)
+variable [Algebra F F'] [IsScalarTower K F F'] [Algebra.IsIntegral F F'] (W : Place K F')
+
+def kw_ffgc_adicCompletionComap : (W.restrict F).adicCompletion →+* W.adicCompletion :=
+  ((IsDedekindDomain.HeightOneSpectrum.adicCompletion.equiv F'
+    W.heightOneSpectrum).symm.toRingHom.comp
+    (UniformSpace.Completion.mapRingHom
+      (WithVal.map ((W.restrict F).heightOneSpectrum.valuation F)
+        (W.heightOneSpectrum.valuation F') (algebraMap F F'))
+      (kw_ffgc_uniformContinuous_withValMapAlgebraMap F W).continuous)).comp
+    (IsDedekindDomain.HeightOneSpectrum.adicCompletion.equiv F (W.restrict
+      F).heightOneSpectrum).toRingHom
+
+theorem kw_ffgc_continuous_adicCompletionComap :
+    Continuous (kw_ffgc_adicCompletionComap F W) := by
+  have h : ⇑(kw_ffgc_adicCompletionComap F W) =
+      IsDedekindDomain.HeightOneSpectrum.adicCompletion.ofCompletion ∘ UniformSpace.Completion.map
+        (WithVal.map ((W.restrict F).heightOneSpectrum.valuation F)
+          (W.heightOneSpectrum.valuation F') (algebraMap F F')) ∘
+        IsDedekindDomain.HeightOneSpectrum.adicCompletion.toCompletion := rfl
+  rw [h]
+  exact (IsDedekindDomain.HeightOneSpectrum.adicCompletion.continuous_ofCompletion F' _).comp
+    (UniformSpace.Completion.continuous_map.comp
+      (IsDedekindDomain.HeightOneSpectrum.adicCompletion.continuous_toCompletion F _))
+
+theorem kw_ffgc_adicCompletionComap_coe
+    (x : WithVal ((W.restrict F).heightOneSpectrum.valuation F)) :
+    kw_ffgc_adicCompletionComap F W (x : (W.restrict F).adicCompletion)
+      = (WithVal.map ((W.restrict F).heightOneSpectrum.valuation F)
+          (W.heightOneSpectrum.valuation F') (algebraMap F F') x : W.adicCompletion) :=
+  by
+  apply IsDedekindDomain.HeightOneSpectrum.adicCompletion.ext
+  exact UniformSpace.Completion.mapRingHom_coe
+    (kw_ffgc_uniformContinuous_withValMapAlgebraMap F W).continuous x
+
+open WithZeroTopology in
+theorem kw_ffgc_valued_adicCompletionComap (x : (W.restrict F).adicCompletion) :
+    Valued.v (kw_ffgc_adicCompletionComap F W x)
+      = Valued.v x ^ W.ramificationIndex F := by
+  obtain ⟨x, rfl⟩ :=
+    IsDedekindDomain.HeightOneSpectrum.adicCompletion.ofCompletion_surjective F _ x
+  induction x using UniformSpace.Completion.induction_on with
+  | hp =>
+    refine isClosed_eq
+      ((Valued.continuous_valuation_of_surjective
+        (W.heightOneSpectrum.valuedAdicCompletion_surjective F')).comp
+        ((kw_ffgc_continuous_adicCompletionComap F W).comp
+          (IsDedekindDomain.HeightOneSpectrum.adicCompletion.continuous_ofCompletion F _)))
+      (((Valued.continuous_valuation_of_surjective
+        ((W.restrict F).heightOneSpectrum.valuedAdicCompletion_surjective F)).comp
+          (IsDedekindDomain.HeightOneSpectrum.adicCompletion.continuous_ofCompletion F _)).pow _)
+  | ih a =>
+    rw [kw_ffgc_adicCompletionComap_coe]
+    simp only [IsDedekindDomain.HeightOneSpectrum.adicCompletion.valued_ofCompletion,
+      Valued.valuedCompletion_apply]
+    exact kw_ffgc_valued_withValMapAlgebraMap F W a
+
+end CompletionComap
+
+end AlgebraicCurve.Place
+
+section
+
+open IsDedekindDomain IsDedekindDomain.HeightOneSpectrum IsLocalRing WithZero MonoidWithZeroHom
+
+namespace AlgebraicCurve.Place
+
+section IntegerComap
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+variable (F)
+variable [Algebra F F'] [IsScalarTower K F F'] [Algebra.IsIntegral F F'] (W : Place K F')
+
+theorem kw_ffgc_adicCompletionComap_mem_integers
+    {x : (W.restrict F).adicCompletion} (hx : x ∈ (W.restrict F).adicCompletionIntegers) :
+    kw_ffgc_adicCompletionComap F W x ∈ W.adicCompletionIntegers := by
+  rw [HeightOneSpectrum.mem_adicCompletionIntegers] at hx ⊢
+  rw [kw_ffgc_valued_adicCompletionComap]
+  exact pow_le_one' hx _
+
+def kw_ffgc_adicCompletionComapIntegers :
+    (W.restrict F).adicCompletionIntegers →+* W.adicCompletionIntegers :=
+  (kw_ffgc_adicCompletionComap F W).restrict _ _
+    fun _ hx => kw_ffgc_adicCompletionComap_mem_integers F W hx
+
+@[simp]
+theorem kw_ffgc_adicCompletionComapIntegers_coe
+    (x : (W.restrict F).adicCompletionIntegers) :
+    (kw_ffgc_adicCompletionComapIntegers F W x : W.adicCompletion)
+      = kw_ffgc_adicCompletionComap F W (x : (W.restrict F).adicCompletion) := rfl
+
+end IntegerComap
+
+end AlgebraicCurve.Place
+
+section
+
+open Polynomial IsLocalRing IsDedekindDomain
+
+namespace AlgebraicCurve.Place
+
+section CompletionAlgebra
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+variable (F)
+variable [Algebra F F'] [IsScalarTower K F F'] [Algebra.IsIntegral F F'] (W : Place K F')
+
+scoped instance kw_ffgc_algebraAdicCompletionComap :
+    Algebra (W.restrict F).adicCompletion W.adicCompletion :=
+  (kw_ffgc_adicCompletionComap F W).toAlgebra
+
+theorem kw_ffgc_algebraMap_adicCompletionComap_eq :
+    algebraMap (W.restrict F).adicCompletion W.adicCompletion
+      = kw_ffgc_adicCompletionComap F W := rfl
+
+scoped instance kw_ffgc_algebraAdicCompletionComapIntegers :
+    Algebra (W.restrict F).adicCompletionIntegers W.adicCompletionIntegers :=
+  (kw_ffgc_adicCompletionComapIntegers F W).toAlgebra
+
+scoped instance kw_ffgc_algebraAdicCompletionIntegersToCompletion :
+    Algebra (W.restrict F).adicCompletionIntegers W.adicCompletion :=
+  ((kw_ffgc_adicCompletionComap F W).comp
+    (algebraMap (W.restrict F).adicCompletionIntegers (W.restrict F).adicCompletion)).toAlgebra
+
+instance kw_ffgc_isScalarTower_integersCompletionCompletion :
+    IsScalarTower (W.restrict F).adicCompletionIntegers
+      (W.restrict F).adicCompletion W.adicCompletion :=
+  IsScalarTower.of_algebraMap_eq fun _ => rfl
+
+instance kw_ffgc_isScalarTower_integersIntegersCompletion :
+    IsScalarTower (W.restrict F).adicCompletionIntegers
+      W.adicCompletionIntegers W.adicCompletion :=
+  IsScalarTower.of_algebraMap_eq fun x => (kw_ffgc_adicCompletionComapIntegers_coe F W x).symm
+
+end CompletionAlgebra
+
+section SpectralSetup
+
+open scoped Valued NNReal WithZero
+
+open WithZeroMulInt Valuation.IsRankOneDiscrete
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (V : Place K F)
+
+@[implicit_reducible]
+noncomputable def kw_ffgc_rankOne_adicCompletion :
+    (Valued.v : Valuation V.adicCompletion ℤᵐ⁰).RankOne :=
+  Valuation.IsRankOneDiscrete.rankOne _ (one_lt_two (α := ℝ≥0))
+
+end SpectralSetup
+
+section AbsoluteValue
+
+open scoped Valued NNReal WithZero
+
+open WithZeroMulInt Valuation.IsRankOneDiscrete
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+variable (F)
+variable [Algebra F F'] [IsScalarTower K F F'] [Algebra.IsIntegral F F'] (W : Place K F')
+
+noncomputable def kw_ffgc_absoluteValue : AbsoluteValue W.adicCompletion ℝ :=
+  letI := kw_ffgc_rankOne_adicCompletion W
+  have hr : (0 : ℝ) < ((W.ramificationIndex F : ℝ))⁻¹ :=
+    inv_pos.mpr (Nat.cast_pos.mpr (W.ramificationIndex_pos (F := F)))
+  { toFun := fun y => ‖y‖ ^ ((W.ramificationIndex F : ℝ))⁻¹
+    map_mul' := fun x y => by rw [norm_mul, Real.mul_rpow (norm_nonneg x) (norm_nonneg y)]
+    nonneg' := fun x => Real.rpow_nonneg (norm_nonneg x) _
+    eq_zero' := fun x => by
+      rw [Real.rpow_eq_zero_iff_of_nonneg (norm_nonneg x), norm_eq_zero]
+      exact ⟨fun h => h.1, fun h => ⟨h, hr.ne'⟩⟩
+    add_le' := fun x y => by
+      have hmax : ‖x + y‖ ≤ max ‖x‖ ‖y‖ := Valuation.norm_add_le Valued.v x y
+      refine (Real.rpow_le_rpow (norm_nonneg _) hmax hr.le).trans ?_
+      rcases max_cases ‖x‖ ‖y‖ with ⟨hm, _⟩ | ⟨hm, _⟩ <;> rw [hm]
+      · exact le_add_of_nonneg_right (Real.rpow_nonneg (norm_nonneg _) _)
+      · exact le_add_of_nonneg_left (Real.rpow_nonneg (norm_nonneg _) _) }
+
+end AbsoluteValue
+
+section ClosedAdjoin
+
+open scoped Valued NNReal WithZero
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+variable (F)
+variable [Algebra F F'] [IsScalarTower K F F'] [Algebra.IsIntegral F F'] (W : Place K F')
+
+instance kw_ffgc_continuousSMul_adicCompletionComap :
+    ContinuousSMul (W.restrict F).adicCompletion W.adicCompletion :=
+  continuousSMul_of_algebraMap _ _ (by
+    rw [kw_ffgc_algebraMap_adicCompletionComap_eq]
+    exact kw_ffgc_continuous_adicCompletionComap F W)
+
+end ClosedAdjoin
+
+end AlgebraicCurve.Place
+
+section
+
+open IsDedekindDomain IsDedekindDomain.HeightOneSpectrum IsLocalRing WithZero
+
+open scoped Valued WithZero
+
+namespace AlgebraicCurve.Place
+
+section FiniteDimensional
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+variable (F)
+variable [Algebra F F'] [IsScalarTower K F F'] [Algebra.IsIntegral F F'] (W : Place K F')
+
+theorem kw_ffgc_adicCompletionComap_algebraMap_algebraMap (c : F) :
+    algebraMap F' W.adicCompletion (algebraMap F F' c)
+      = algebraMap (W.restrict F).adicCompletion W.adicCompletion
+          (algebraMap F (W.restrict F).adicCompletion c) := by
+  rw [kw_ffgc_algebraMap_adicCompletionComap_eq,
+    show algebraMap F (W.restrict F).adicCompletion c
+      = ((WithVal.toVal ((W.restrict F).heightOneSpectrum.valuation F) c
+          : WithVal ((W.restrict F).heightOneSpectrum.valuation F))
+          : (W.restrict F).adicCompletion) from rfl,
+    kw_ffgc_adicCompletionComap_coe]
+  rfl
+
+theorem kw_ffgc_algebraMap_smul_algebraMap (c : F) (b : F') :
+    algebraMap F (W.restrict F).adicCompletion c • algebraMap F' W.adicCompletion b
+      = algebraMap F' W.adicCompletion (c • b) := by
+  rw [Algebra.smul_def, Algebra.smul_def, map_mul,
+    kw_ffgc_adicCompletionComap_algebraMap_algebraMap]
+
+def kw_ffgc_completionLinearCombination {ι : Type*} [Fintype ι] (b : Module.Basis ι F F') :
+    (ι → (W.restrict F).adicCompletion)
+      →ₗ[(W.restrict F).adicCompletion] W.adicCompletion :=
+  Fintype.linearCombination (W.restrict F).adicCompletion
+    (fun i => algebraMap F' W.adicCompletion (b i))
+
+theorem kw_ffgc_denseRange_completionLinearCombination {ι : Type*} [Fintype ι]
+    (b : Module.Basis ι F F') :
+    DenseRange (kw_ffgc_completionLinearCombination F W b) := by
+  apply (IsDedekindDomain.HeightOneSpectrum.denseRange_algebraMap F' W.heightOneSpectrum).mono
+  rintro _ ⟨l, rfl⟩
+  refine ⟨fun i => algebraMap F (W.restrict F).adicCompletion (b.repr l i), ?_⟩
+  simp only [kw_ffgc_completionLinearCombination, Fintype.linearCombination_apply,
+    kw_ffgc_algebraMap_smul_algebraMap, ← map_sum]
+  congr 1
+  exact b.sum_repr l
+
+instance kw_ffgc_finiteDimensional_adicCompletion [FiniteDimensional F F'] :
+    FiniteDimensional (W.restrict F).adicCompletion W.adicCompletion := by
+  let := kw_ffgc_rankOne_adicCompletion (W.restrict F)
+  let : NontriviallyNormedField (W.restrict F).adicCompletion :=
+    Valued.toNontriviallyNormedField (W.restrict F).adicCompletion ℤᵐ⁰
+  let b := Module.finBasis F F'
+  exact Module.Finite.of_surjective (kw_ffgc_completionLinearCombination F W b) (by
+    rw [← Set.range_eq_univ, ← LinearMap.coe_range,
+      ← (LinearMap.range
+          (kw_ffgc_completionLinearCombination F W b)).closed_of_finiteDimensional.closure_eq]
+    exact (kw_ffgc_denseRange_completionLinearCombination F W b).closure_range)
+
+end FiniteDimensional
+
+section CompletionTrace
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+variable (F)
+variable [Algebra F F'] [IsScalarTower K F F'] [Algebra.IsIntegral F F'] (W : Place K F')
+
+abbrev kw_ffgc_completionTrace [FiniteDimensional F F'] :
+    W.adicCompletion →ₗ[(W.restrict F).adicCompletion] (W.restrict F).adicCompletion :=
+  Algebra.trace (W.restrict F).adicCompletion W.adicCompletion
+
+def kw_ffgc_completionTraceF' [FiniteDimensional F F'] : F' →ₗ[F] (W.restrict F).adicCompletion :=
+  { toFun := fun g => kw_ffgc_completionTrace F W (algebraMap F' W.adicCompletion g)
+    map_add' := fun x y => by simp only [map_add]
+    map_smul' := fun c x => by
+      simp only [Algebra.smul_def, map_mul, RingHom.id_apply,
+        kw_ffgc_adicCompletionComap_algebraMap_algebraMap]
+      rw [← Algebra.smul_def, LinearMap.map_smul, Algebra.smul_def]
+      rfl }
+
+end CompletionTrace
+
+end AlgebraicCurve.Place
+
+open AlgebraicCurve AlgebraicCurve.Place IsDedekindDomain
+
+section
+
+namespace AlgebraicCurve
+
+section LocalResidueCompletion
+
+variable {K E : Type*} [Field K] [Field E] [Algebra K E]
+
+theorem kwHgfV352_valued_algebraMap_adicCompletion (v : Place K E) (x : E) :
+    Valued.v (algebraMap E v.adicCompletion x) = v.heightOneSpectrum.valuation E x := by
+  have h := IsDedekindDomain.HeightOneSpectrum.valuedAdicCompletion_eq_valuation'
+    (K := E) v.heightOneSpectrum x
+  first
+    | exact h
+
+namespace Place
+
+private theorem mem_of_ord_nonneg_placeCompletionAux {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) {f : F} (hf : f ≠ 0) (h : 0 ≤ v.ord f) :
+    f ∈ v.toValuationSubring := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ
+  rw [hu, show v.ord f = (((v.ord f).toNat : ℕ) : ℤ) from (Int.toNat_of_nonneg h).symm,
+    zpow_natCast]
+  exact mul_mem (u : v.toValuationSubring).2 (pow_mem (π : v.toValuationSubring).2 _)
+
+private theorem ord_nonneg_of_mem_placeCompletionAux {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) {f : F} (hf : f ∈ v.toValuationSubring) : 0 ≤ v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨n, u, hu⟩ :=
+    IsDiscreteValuationRing.eq_unit_mul_pow_irreducible
+      (x := (⟨f, hf⟩ : v.toValuationSubring)) (by simpa [Subtype.ext_iff] using hf0) hπ
+  have hcoe : f = ((u : v.toValuationSubring) : F) * ((π : F) ^ (n : ℤ)) := by
+    have h := congrArg (Subtype.val) hu
+    push_cast at h
+    rw [zpow_natCast]
+    exact h
+  rw [hcoe, v.ord_unit_smul_zpow u hπ (n : ℤ)]
+  exact Int.natCast_nonneg n
+
+end Place
+
+theorem kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff (v : Place K E) (x : E) :
+    algebraMap E v.adicCompletion x ∈ v.adicCompletionIntegers ↔ x ∈ v.toValuationSubring := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · simp only [map_zero]; exact iff_of_true (zero_mem _) (zero_mem _)
+  have hval : Valued.v (algebraMap E v.adicCompletion x) = v.adicValuation x :=
+    kwHgfV352_valued_algebraMap_adicCompletion v x
+  have hne : v.adicValuation x ≠ 0 := v.adicValuation_ne_zero hx0
+  have hlog_iff : WithZero.log (v.adicValuation x) ≤ 0 ↔ v.adicValuation x ≤ 1 := by
+    rw [WithZero.log_le_iff_le_exp hne, WithZero.exp_zero]
+  constructor
+  · intro h
+    refine v.mem_of_ord_nonneg_placeCompletionAux hx0 (neg_nonneg.mpr ?_)
+    exact hlog_iff.mpr (hval ▸ h)
+  · intro h
+    change Valued.v (algebraMap E v.adicCompletion x) ≤ 1
+    rw [hval]
+    exact hlog_iff.mp (neg_nonneg.mp (v.ord_nonneg_of_mem_placeCompletionAux h))
+
+theorem kwHgfV352_exists_sub_mem_adicCompletionIntegers (v : Place K E)
+    (xh : v.adicCompletion) :
+    ∃ x : E, algebraMap E v.adicCompletion x - xh ∈ v.adicCompletionIntegers := by
+  have hdense : DenseRange (algebraMap E v.adicCompletion) :=
+    IsDedekindDomain.HeightOneSpectrum.denseRange_algebraMap E v.heightOneSpectrum
+  have hopen : IsOpen ((xh + ·) '' (v.adicCompletionIntegers : Set v.adicCompletion)) :=
+    (Homeomorph.addLeft xh).isOpenMap _ (Valued.isOpen_valuationSubring v.adicCompletion)
+  have hmem : xh ∈ (xh + ·) '' (v.adicCompletionIntegers : Set v.adicCompletion) :=
+    ⟨0, zero_mem _, by simp⟩
+  obtain ⟨e, he⟩ := hdense.exists_mem_open hopen ⟨xh, hmem⟩
+  obtain ⟨o, hoMem, hoEq⟩ := he
+  exact ⟨e, by rw [← hoEq]; simpa using hoMem⟩
+
+end LocalResidueCompletion
+
+end AlgebraicCurve
+
+open AlgebraicCurve AlgebraicCurve.Place LinearMap Submodule
+open IsDedekindDomain IsDedekindDomain.HeightOneSpectrum IsLocalRing
+
+section
+
+namespace ModularCurve.KwF4gRRTate
+
+section PoleWindowShift
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem algebraMap_K_mem_adicCompletionIntegers (c : K) :
+    algebraMap K u.adicCompletion c ∈ u.adicCompletionIntegers := by
+  rw [IsScalarTower.algebraMap_apply K L u.adicCompletion]
+  exact (kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff u _).mpr (u.algebraMap_mem' c)
+
+def algebraMapKIntegers : K →+* u.adicCompletionIntegers where
+  toFun c := ⟨algebraMap K u.adicCompletion c, algebraMap_K_mem_adicCompletionIntegers u c⟩
+  map_one' := Subtype.ext (map_one _)
+  map_mul' x y := Subtype.ext (map_mul _ x y)
+  map_zero' := Subtype.ext (map_zero _)
+  map_add' x y := Subtype.ext (map_add _ x y)
+
+instance instAlgebraKAdicCompletionIntegers : Algebra K u.adicCompletionIntegers :=
+  (algebraMapKIntegers u).toAlgebra
+
+end PoleWindowShift
+
+end ModularCurve.KwF4gRRTate
+
+end
+
+end
+end
+end
+end
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_PlaceEvaluation.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_PlaceEvaluation.lean
new file mode 100644
index 0000000000..30d79faf09
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_PlaceEvaluation.lean
@@ -0,0 +1,142 @@
+/-
+Based on Prove2Me node AlgebraicCurve_PlaceEvaluation
+(d5fccec9-c50a-5b0f-9eb1-08b6be4c96f8) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.Henselian
+public import Mathlib.RingTheory.RegularLocalRing.Defs
+public import Mathlib.RingTheory.SimpleRing.Principal
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+/-!
+# Evaluation at rational places and divisors; Weil reciprocity predicate
+
+Definition: `AlgebraicCurve_PlaceEvaluation` (`d5fccec9-c50a-5b0f-9eb1-08b6be4c96f8`), by Claude,
+2026-09-05.
+
+The setting is a field extension $K \subseteq F$ (an algebra $F$ over a field $K$, with $F$ a
+field), with places, orders and divisors as in the divisor-class-group module: a `Place K F` is a
+valuation subring $\mathcal O_v \subseteq F$ containing the image of $K$, different from $F$ and
+with principal ideals (hence a discrete valuation ring), $v.\mathrm{ord}$ is minus the logarithm of
+the associated adic valuation, and a divisor is a finitely supported function from places to
+$\mathbb Z$. Here a place $v$ is declared `IsRational` when the structure map $K \to \kappa(v)$ into
+the residue field of $\mathcal O_v$ is surjective; since that map is automatically injective, this
+says $\kappa(v) = K$, i.e. $\deg v = 1$. The map `residueInv` is a chosen left inverse of $K \to
+\kappa(v)$ (the `Function.invFun`, so it is a genuine inverse exactly when $v$ is rational, and
+arbitrary elsewhere), and `evalAt` sends $f \in F$ to `residueInv` of the residue class of $f$ when
+$f \in \mathcal O_v$, and to $0$ otherwise; thus $f(v) \in K$ is the value of $f$ at $v$ when $v$ is
+rational and $f$ has no pole there, with the junk value $0$ at poles. The accompanying lemmas record
+the two inversion identities, the defining equation of `evalAt` on $\mathcal O_v$, the fact that $K
+\to \kappa(v)$ carries $f(v)$ to the residue of $f$ when $v$ is rational, and $1(v) = 1$.
+
+For a divisor $D$, `Divisor.evalFun f D` is the finite product $\prod_{v \in \mathrm{supp}\,D}
+f(v)^{D(v)}$ of integer powers in $K$; it is $1$ on the zero divisor and equals $f(v)^n$ on $n \cdot
+v$. Finally `WeilReciprocity K F` is a predicate on the pair $(K,F)$, not a theorem: it asserts that
+for all nonzero $f, g \in F$ and all divisors $D_f, D_g$ with $D_f(v) = \mathrm{ord}_v f$ and
+$D_g(v) = \mathrm{ord}_v g$ at every place, such that at each place at least one of $\mathrm{ord}_v
+f$, $\mathrm{ord}_v g$ vanishes and such that every place in the support of $D_f$ or of $D_g$ is
+rational, one has $f(D_g) = g(D_f)$.
+
+**Relation to Mathlib.** Built on Mathlib's `ValuationSubring` and `IsLocalRing.ResidueField`, with
+`residueInv` obtained from `Function.invFun`; the evaluation of a function at a place or at a
+divisor, and the Weil reciprocity statement, are the project's own, Mathlib having no such notions.
+
+**Where it is used.** These definitions underlie the project's treatment of Weil reciprocity for
+function fields and, through it, the divisor-class description of the Weil pairing $e_n(D_1,D_2) =
+f_1(D_2)/f_2(D_1)$ on elliptic curves, which feeds into the study of the mod $n$ Galois
+representations used on the Frey-curve side of the argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open IsLocalRing
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable (v : Place K F)
+
+def IsRational : Prop := Function.Surjective (algebraMap K v.ResidueField)
+
+theorem algebraMap_residueField_injective :
+    Function.Injective (algebraMap K v.ResidueField) :=
+  (algebraMap K v.ResidueField).injective
+
+def residueInv : v.ResidueField → K :=
+  Function.invFun (algebraMap K v.ResidueField)
+
+theorem algebraMap_residueInv (hv : v.IsRational) (x : v.ResidueField) :
+    algebraMap K v.ResidueField (v.residueInv x) = x :=
+  Function.invFun_eq (hv x)
+
+theorem residueInv_algebraMap (a : K) : v.residueInv (algebraMap K v.ResidueField a) = a :=
+  Function.leftInverse_invFun v.algebraMap_residueField_injective a
+
+open Classical in
+def evalAt (f : F) : K :=
+  if hf : f ∈ v.toValuationSubring then
+    v.residueInv (residue v.toValuationSubring ⟨f, hf⟩)
+  else 0
+
+theorem evalAt_of_mem {f : F} (hf : f ∈ v.toValuationSubring) :
+    v.evalAt f = v.residueInv (residue v.toValuationSubring ⟨f, hf⟩) :=
+  dite_eq_left hf
+
+theorem algebraMap_evalAt (hv : v.IsRational) {f : F} (hf : f ∈ v.toValuationSubring) :
+    algebraMap K v.ResidueField (v.evalAt f)
+      = residue v.toValuationSubring (⟨f, hf⟩ : v.toValuationSubring) := by
+  rw [v.evalAt_of_mem hf]
+  exact v.algebraMap_residueInv hv _
+
+@[simp]
+theorem evalAt_one : v.evalAt (1 : F) = 1 := by
+  rw [v.evalAt_of_mem (one_mem _)]
+  have h1 : (⟨(1 : F), one_mem _⟩ : v.toValuationSubring) = 1 := rfl
+  rw [h1, map_one, ← map_one (algebraMap K v.ResidueField), v.residueInv_algebraMap]
+
+end Place
+
+namespace Divisor
+
+def evalFun (f : F) (D : Divisor K F) : K :=
+  D.prod fun v n => v.evalAt f ^ n
+
+theorem evalFun_def (f : F) (D : Divisor K F) :
+    evalFun f D = ∏ v ∈ D.support, v.evalAt f ^ D v := rfl
+
+@[simp]
+theorem evalFun_zero (f : F) : evalFun f (0 : Divisor K F) = 1 :=
+  Finsupp.prod_zero_index
+
+theorem evalFun_single (f : F) (v : Place K F) (n : ℤ) :
+    evalFun f (Finsupp.single v n) = v.evalAt f ^ n :=
+  Finsupp.prod_single_index (zpow_zero _)
+
+end Divisor
+
+variable (K F) in
+def WeilReciprocity : Prop :=
+  ∀ (f g : F) (Df Dg : Divisor K F), f ≠ 0 → g ≠ 0 →
+    (∀ v : Place K F, Df v = v.ord f) → (∀ v : Place K F, Dg v = v.ord g) →
+    (∀ v : Place K F, v.ord f = 0 ∨ v.ord g = 0) →
+    (∀ v ∈ Df.support, Place.IsRational v) → (∀ v ∈ Dg.support, Place.IsRational v) →
+    Divisor.evalFun f Dg = Divisor.evalFun g Df
+
+end AlgebraicCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_PlacesOverDVR.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_PlacesOverDVR.lean
new file mode 100644
index 0000000000..5e7f992ca1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_PlacesOverDVR.lean
@@ -0,0 +1,570 @@
+/-
+Based on Prove2Me node AlgebraicCurve_PlacesOverDVR
+(71585f74-5f90-5e62-b565-e6e34df02a7a) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import Mathlib.RingTheory.DedekindDomain.IntegralClosure
+public import Mathlib.RingTheory.RamificationInertia.Basic
+public import Mathlib.RingTheory.DedekindDomain.Factorization
+public import Mathlib.Algebra.Polynomial.Lifts
+
+/-!
+# Places above a place via primes of the integral closure
+
+Definition: `AlgebraicCurve_PlacesOverDVR` (`71585f74-5f90-5e62-b565-e6e34df02a7a`), by Claude,
+2026-09-05.
+
+Throughout, $K \subseteq F \subseteq F'$ are fields with $F'/F$ finite and separable (compatible
+algebra structures and scalar tower), and a place of $F/K$ means an element of the project's
+structure `Place K F`: a valuation subring $\mathcal{O}_v \subsetneq F$ containing the image of $K$
+whose ideals are all principal, so that $\mathcal{O}_v$ is a discrete valuation ring with normalised
+order function $v.\mathrm{ord}$ and residue field.
+
+The first construction is an affine chart. For a Dedekind domain $R$ with $R \subseteq F$ as
+fraction field and a place $w$, given the hypothesis that every $r \in R$ maps into $\mathcal{O}_w$,
+`center R w hw` is the contraction $\mathfrak{m}_w \cap R$, i.e. the preimage of the maximal ideal
+of $\mathcal{O}_w$ under the induced map $R \to \mathcal{O}_w$; it is prime, nonzero, hence a
+height-one prime `centerHeightOneSpectrum R w hw`, and $\mathcal{O}_w$ coincides with the
+localisation $\mathcal{O}_{R,\mathfrak{p}}$ attached to it by Mathlib's `valuationSubringAtPrime`.
+Membership in the centre is characterised by $0 < w.\mathrm{ord}$, and for fixed $r_0 \neq 0$ only
+finitely many places satisfy both conditions.
+
+For a place $v$ of $F/K$, `integralClosureAt F' v` is the integral closure $C_v$ of $\mathcal{O}_v$
+in $F'$, which is a Dedekind domain, module-finite over $\mathcal{O}_v$, with fraction field $F'$.
+For $w$ a place of $F'/K$ with $w|_F = v$ (equality of $w.\mathrm{restrict}\,F$, the contraction of
+$\mathcal{O}_w$ to $F$, with $v$), `fiberCenter F' v hw` is the centre $\mathfrak{m}_w \cap C_v$ as
+a height-one prime of $C_v$; it lies over $\mathfrak{m}_v$, and $\mathcal{O}_w$ is its localisation.
+Conversely `placeOfPrime P` is the place of $F'/K$ with valuation ring $(C_v)_{\mathfrak{P}}$, and
+it restricts to $v$. These are mutually inverse: `fiberEquiv F' v` is the resulting bijection
+between $\{w : w|_F = v\}$ and the height-one spectrum of $C_v$. Consequently the set of places
+above $v$ is finite, and `fiberOver F' v` is it as a finset, with membership criterion $w|_F = v$,
+cardinality equal to that of Mathlib's `primesOverFinset` of $\mathfrak{m}_v$ in $C_v$, and
+agreement with the fibre finset `fiber` of the divisor push/pull module under `HasPrincipalDivisors
+K F'`. Auxiliary results record that $\mathcal{O}_w$ is integrally closed (a root of a monic
+polynomial with coefficients in $\mathcal{O}_w$ lies in $\mathcal{O}_w$), the translation of
+maximal-ideal membership into positivity of $\mathrm{ord}$, and the identity $w.\mathrm{ord}(r) =
+e(w/F)\cdot v.\mathrm{ord}(r)$ for $r \in \mathcal{O}_v$.
+
+**Relation to Mathlib.** `Place` is the project's own structure; Mathlib's height-one spectrum of a
+Dedekind domain, its `valuationSubringAtPrime`, `primesOverFinset`, and the theorems that the
+integral closure in a finite separable extension is Dedekind, module-finite and has the larger field
+as fraction field are used to identify the fibre of places above a place with a set of primes.
+
+**Where it is used.** The fibre finset `fiberOver` and the ramification data it supports underlie
+the pullback and pushforward maps on divisors, the fundamental identity relating ramification
+indices and residue degrees, and hence the degree-zero divisor class groups of curves used in the
+formalisation.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing
+
+namespace AlgebraicCurve
+
+namespace Place
+
+section SinglePlace
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem ord_eq_zero_iff_adicValuation_eq_one {f : F} (hf : f ≠ 0) :
+    v.ord f = 0 ↔ v.adicValuation f = 1 := by
+  simp only [ord, neg_eq_zero]
+  constructor
+  · intro h
+    have h2 := exp_log (v.adicValuation_ne_zero hf)
+    rw [h, exp_zero] at h2
+    exact h2.symm
+  · intro h
+    rw [h, log_one]
+
+end SinglePlace
+
+section IntegrallyClosed
+
+open Polynomial
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+theorem ord_neg (f : F) : w.ord (-f) = w.ord f := by
+  simp only [ord, Valuation.map_neg]
+
+theorem mem_of_eval_monic_eq_zero {P : Polynomial F} (hP : P.Monic)
+    (hcoeff : ∀ i, P.coeff i ∈ w.toValuationSubring) {x : F} (hx : P.eval x = 0) :
+    x ∈ w.toValuationSubring := by
+  have hlift : P ∈ lifts (algebraMap w.toValuationSubring F) := by
+    rw [lifts_iff_coeff_lifts]
+    exact fun n => ⟨⟨P.coeff n, hcoeff n⟩, rfl⟩
+  obtain ⟨Q, hQmap, -, hQmonic⟩ := lifts_and_degree_eq_and_monic hlift hP
+  have hint : IsIntegral w.toValuationSubring x := by
+    refine ⟨Q, hQmonic, ?_⟩
+    rw [show eval₂ (algebraMap w.toValuationSubring F) x Q = (Q.map _).eval x from
+      (eval_map _ x).symm, hQmap, hx]
+  obtain ⟨y, hy⟩ := IsIntegrallyClosed.isIntegral_iff.mp hint
+  exact hy ▸ y.2
+
+theorem mem_maximalIdeal_iff_ord_pos {x : F} (hx : x ≠ 0)
+    (hmem : x ∈ w.toValuationSubring) :
+    (⟨x, hmem⟩ : w.toValuationSubring) ∈ IsLocalRing.maximalIdeal w.toValuationSubring ↔
+      0 < w.ord x := by
+  have hnonneg : 0 ≤ w.ord x := w.ord_nonneg_of_mem hmem
+  have hcoe : ((⟨x, hmem⟩ : w.toValuationSubring) : F) = x := rfl
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff, ← w.adicValuation_coe_eq_one_iff,
+    hcoe, ← w.ord_eq_zero_iff_adicValuation_eq_one hx]
+  omega
+
+end IntegrallyClosed
+
+section Chart
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R F] [IsFractionRing R F]
+variable (w : Place K F)
+
+def chartHom (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    R →+* w.toValuationSubring :=
+  (algebraMap R F).codRestrict w.toValuationSubring.toSubring hw
+
+omit [IsDedekindDomain R] [IsFractionRing R F] in
+@[simp]
+private theorem coe_chartHom (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) (r : R) :
+    (chartHom w hw r : F) = algebraMap R F r := rfl
+
+variable (R) in
+def center (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) : Ideal R :=
+  (IsLocalRing.maximalIdeal w.toValuationSubring).comap (chartHom w hw)
+
+instance (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    (center R w hw).IsPrime :=
+  Ideal.comap_isPrime _ _
+
+omit [IsDedekindDomain R] [IsFractionRing R F] in
+theorem mem_center_iff (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) {r : R} :
+    r ∈ center R w hw ↔
+      (⟨algebraMap R F r, hw r⟩ : w.toValuationSubring) ∈
+        IsLocalRing.maximalIdeal w.toValuationSubring :=
+  Iff.rfl
+
+theorem mem_center_iff_ord_pos (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring)
+    {r : R} (hr : r ≠ 0) :
+    r ∈ center R w hw ↔ 0 < w.ord (algebraMap R F r) := by
+  have hr' : algebraMap R F r ≠ 0 := by
+    simpa using (IsFractionRing.injective R F).ne_iff.mpr hr
+  rw [mem_center_iff, w.mem_maximalIdeal_iff_ord_pos hr']
+
+omit [IsDedekindDomain R] [IsFractionRing R F] in
+private theorem inv_algebraMap_mem (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring)
+    {s : R} (hs : IsUnit (chartHom w hw s)) :
+    (algebraMap R F s)⁻¹ ∈ w.toValuationSubring := by
+  obtain ⟨u, hu⟩ := hs
+  have hcoe : ((u : w.toValuationSubring) : F) = algebraMap R F s := by rw [hu]; rfl
+  have h1 : (((u⁻¹ : w.toValuationSubringˣ) : w.toValuationSubring) : F)
+      * algebraMap R F s = 1 := by
+    have hmul := congrArg (fun a : w.toValuationSubring => (a : F)) u.inv_mul
+    push_cast at hmul
+    rwa [hcoe] at hmul
+  rw [← eq_inv_of_mul_eq_one_left h1]
+  exact SetLike.coe_mem _
+
+theorem center_ne_bot (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    center R w hw ≠ ⊥ := by
+  intro hbot
+  apply w.ne_top'
+  have hunit : ∀ r : R, r ≠ 0 → IsUnit (chartHom w hw r) := by
+    intro r hr
+    by_contra hu
+    have : r ∈ center R w hw :=
+      (mem_center_iff w hw).mpr ((IsLocalRing.mem_maximalIdeal _).mpr hu)
+    rw [hbot] at this
+    exact hr (by simpa using this)
+  refine SetLike.ext fun x => ⟨fun _ => ValuationSubring.mem_top x, fun _ => ?_⟩
+  obtain ⟨a, b, hb, hx⟩ := IsFractionRing.div_surjective (A := R) x
+  rw [← hx, div_eq_mul_inv]
+  exact mul_mem (hw a) (inv_algebraMap_mem w hw (hunit b (nonZeroDivisors.ne_zero hb)))
+
+variable (R) in
+def centerHeightOneSpectrum (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    HeightOneSpectrum R :=
+  ⟨center R w hw, inferInstance, center_ne_bot w hw⟩
+
+@[simp]
+theorem centerHeightOneSpectrum_asIdeal
+    (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    (centerHeightOneSpectrum R w hw).asIdeal = center R w hw := rfl
+
+theorem valuationSubringAtPrime_centerHeightOneSpectrum_le
+    (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    HeightOneSpectrum.valuationSubringAtPrime F (centerHeightOneSpectrum R w hw) ≤
+      w.toValuationSubring := by
+  rintro x ⟨a, s, hs, rfl⟩
+  refine mul_mem (hw a) (inv_algebraMap_mem w hw ?_)
+  rw [← IsLocalRing.notMem_maximalIdeal]
+  exact fun hmem => hs ((mem_center_iff w hw).mpr hmem)
+
+theorem toValuationSubring_eq_of_forall_mem
+    (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    w.toValuationSubring =
+      HeightOneSpectrum.valuationSubringAtPrime F (centerHeightOneSpectrum R w hw) :=
+  (ValuationSubring.eq_of_le_of_ne_top _
+    (valuationSubringAtPrime_centerHeightOneSpectrum_le w hw) w.ne_top').symm
+
+theorem finite_setOf_forall_mem_and_ord_pos {r₀ : R} (hr₀ : r₀ ≠ 0) :
+    {w : Place K F | (∀ r : R, algebraMap R F r ∈ w.toValuationSubring) ∧
+      0 < w.ord (algebraMap R F r₀)}.Finite := by
+  have hfin : {p : HeightOneSpectrum R | p.asIdeal ∣ Ideal.span {r₀}}.Finite :=
+    Ideal.finite_factors (by simpa [Ideal.span_singleton_eq_bot] using hr₀)
+  rw [← Set.finite_coe_iff]
+  have := hfin.to_subtype
+  refine Finite.of_injective
+    (fun w => (⟨centerHeightOneSpectrum R w.1 w.2.1, ?_⟩ :
+      {p : HeightOneSpectrum R | p.asIdeal ∣ Ideal.span {r₀}})) ?_
+  · rw [Set.mem_ofPred_eq, centerHeightOneSpectrum_asIdeal, Ideal.dvd_span_singleton]
+    exact (mem_center_iff_ord_pos w.1 w.2.1 hr₀).mpr w.2.2
+  · intro w w' h
+    have hcenter : centerHeightOneSpectrum R w.1 w.2.1
+        = centerHeightOneSpectrum R w'.1 w'.2.1 := congrArg Subtype.val h
+    refine Subtype.ext (Place.ext ?_)
+    rw [toValuationSubring_eq_of_forall_mem w.1 w.2.1,
+      toValuationSubring_eq_of_forall_mem w'.1 w'.2.1, hcenter]
+
+end Chart
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+variable (F') in
+@[reducible] def valuationSubringAlgebra (v : Place K F) : Algebra v.toValuationSubring F' :=
+  ((algebraMap F F').comp (algebraMap v.toValuationSubring F)).toAlgebra
+
+section Setup
+
+variable (v : Place K F)
+
+variable (F') in
+abbrev integralClosureAt : Type _ := integralClosure v.toValuationSubring F'
+
+instance : IsDedekindDomain (integralClosureAt F' v) :=
+  integralClosure.isDedekindDomain v.toValuationSubring F F'
+
+instance : IsFractionRing (integralClosureAt F' v) F' :=
+  integralClosure.isFractionRing_of_finite_extension (A := v.toValuationSubring) F F'
+
+instance : Module.Finite v.toValuationSubring (integralClosureAt F' v) :=
+  IsIntegralClosure.finite v.toValuationSubring F F' _
+
+omit [Algebra K F'] [IsScalarTower K F F'] [FiniteDimensional F F']
+  [Algebra.IsSeparable F F'] in
+theorem algebraMap_integralClosureAt_injective :
+    Function.Injective
+      (algebraMap v.toValuationSubring (integralClosureAt F' v)) := by
+  intro a b hab
+  have h1 : algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) a)
+        = algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) b) := by rw [hab]
+  rw [← IsScalarTower.algebraMap_apply, ← IsScalarTower.algebraMap_apply] at h1
+  exact ((algebraMap F F').injective.comp
+    (IsFractionRing.injective v.toValuationSubring F)) h1
+
+instance : Module.IsTorsionFree v.toValuationSubring (integralClosureAt F' v) := by
+  rw [Module.isTorsionFree_iff_smul_eq_zero]
+  intro r c hrc
+  rw [Algebra.smul_def] at hrc
+  rcases mul_eq_zero.mp hrc with h | h
+  · exact Or.inl (algebraMap_integralClosureAt_injective v (by rw [h, map_zero]))
+  · exact Or.inr h
+
+theorem maximalIdeal_ne_bot :
+    IsLocalRing.maximalIdeal v.toValuationSubring ≠ ⊥ := by
+  intro h
+  exact ValuationSubring.not_isField_of_ne_top F v.ne_top'
+    (IsLocalRing.isField_iff_maximalIdeal_eq.mpr h)
+
+omit [Algebra K F'] [IsScalarTower K F F'] in
+theorem sum_ramificationIdx'_mul_inertiaDeg'_integralClosureAt :
+    ∑ P ∈ IsDedekindDomain.primesOverFinset
+        (IsLocalRing.maximalIdeal v.toValuationSubring) (integralClosureAt F' v),
+      Ideal.ramificationIdx' (IsLocalRing.maximalIdeal v.toValuationSubring) P *
+        Ideal.inertiaDeg P v.toValuationSubring =
+          Module.finrank F F' := by
+  classical
+  let p := IsLocalRing.maximalIdeal v.toValuationSubring
+  let S := integralClosureAt F' v
+  let e : {P // P ∈ IsDedekindDomain.primesOverFinset p S} ≃ p.primesOver S :=
+    Set.equivOfEq (IsDedekindDomain.coe_primesOverFinset (maximalIdeal_ne_bot v) S)
+  change (∑ P ∈ IsDedekindDomain.primesOverFinset p S,
+    p.ramificationIdx' P * P.inertiaDeg v.toValuationSubring) = Module.finrank F F'
+  calc
+    _ = ∑ P : {P // P ∈ IsDedekindDomain.primesOverFinset p S},
+        p.ramificationIdx' P.1 * P.1.inertiaDeg v.toValuationSubring := by
+          rw [← Finset.sum_attach, Finset.univ_eq_attach]
+    _ = ∑ P : p.primesOver S,
+        P.1.ramificationIdx v.toValuationSubring * P.1.inertiaDeg v.toValuationSubring := by
+          apply Fintype.sum_equiv e
+          intro P
+          have hmem : P.1 ∈ p.primesOver S := (e P).2
+          let : P.1.IsPrime := hmem.1
+          let : P.1.LiesOver p := hmem.2
+          let : P.1.IsMaximal :=
+            (inferInstance : P.1.IsPrime).isMaximal
+              (Ideal.ne_bot_of_mem_primesOver (maximalIdeal_ne_bot v) hmem)
+          change p.ramificationIdx' P.1 * P.1.inertiaDeg v.toValuationSubring =
+            P.1.ramificationIdx v.toValuationSubring * P.1.inertiaDeg v.toValuationSubring
+          rw [Ideal.ramificationIdx'_eq_ramificationIdx p P.1 (maximalIdeal_ne_bot v)]
+    _ = Module.finrank v.toValuationSubring S :=
+      Ideal.sum_ramification_inertia_eq_finrank p S
+    _ = Module.finrank F F' :=
+      IsIntegralClosure.rank v.toValuationSubring F F' S
+
+end Setup
+
+section Center
+
+variable {v : Place K F} {w : Place K F'}
+
+omit [FiniteDimensional F F'] in
+theorem forall_mem_of_restrict_eq (hw : w.restrict F = v) (c : integralClosureAt F' v) :
+    algebraMap (integralClosureAt F' v) F' c ∈ w.toValuationSubring := by
+  obtain ⟨Q, hQmonic, hQeval⟩ := c.2
+  have hOv : ∀ g : F, g ∈ v.toValuationSubring →
+      algebraMap F F' g ∈ w.toValuationSubring := by
+    intro g hg
+    rw [← hw] at hg
+    exact hg
+  refine w.mem_of_eval_monic_eq_zero (P := Q.map (algebraMap v.toValuationSubring F'))
+    (hQmonic.map _) (fun i => ?_) (by rw [Polynomial.eval_map]; exact hQeval)
+  rw [Polynomial.coeff_map,
+    IsScalarTower.algebraMap_apply v.toValuationSubring F F']
+  exact hOv _ (Q.coeff i).2
+
+variable (F' v) in
+def fiberCenter (hw : w.restrict F = v) : HeightOneSpectrum (integralClosureAt F' v) :=
+  centerHeightOneSpectrum (integralClosureAt F' v) w (forall_mem_of_restrict_eq hw)
+
+theorem mem_fiberCenter_iff_ord_pos (hw : w.restrict F = v) {c : integralClosureAt F' v}
+    (hc : c ≠ 0) :
+    c ∈ (fiberCenter F' v hw).asIdeal ↔
+      0 < w.ord (algebraMap (integralClosureAt F' v) F' c) :=
+  mem_center_iff_ord_pos w (forall_mem_of_restrict_eq hw) hc
+
+theorem toValuationSubring_eq_of_restrict_eq (hw : w.restrict F = v) :
+    w.toValuationSubring =
+      HeightOneSpectrum.valuationSubringAtPrime F' (fiberCenter F' v hw) :=
+  toValuationSubring_eq_of_forall_mem w (forall_mem_of_restrict_eq hw)
+
+theorem mem_maximalIdeal_iff_ord_pos' {r : v.toValuationSubring} (hr : r ≠ 0) :
+    r ∈ IsLocalRing.maximalIdeal v.toValuationSubring ↔
+      0 < v.ord (algebraMap v.toValuationSubring F r) := by
+  have hrF : (algebraMap v.toValuationSubring F r : F) ≠ 0 := by
+    simpa using (IsFractionRing.injective v.toValuationSubring F).ne_iff.mpr hr
+  have := v.mem_maximalIdeal_iff_ord_pos hrF (Subtype.coe_prop r)
+  simpa using this
+
+omit [Algebra K F'] [IsScalarTower K F F'] [FiniteDimensional F F']
+  [Algebra.IsSeparable F F'] in
+theorem algebraMap_integralClosureAt_ne_zero {r : v.toValuationSubring} (hr : r ≠ 0) :
+    algebraMap v.toValuationSubring (integralClosureAt F' v) r ≠ 0 := fun h =>
+  hr (algebraMap_integralClosureAt_injective v (by rw [h, map_zero]))
+
+omit [FiniteDimensional F F'] in
+theorem ord_algebraMap_integralClosureAt (hw : w.restrict F = v) (r : v.toValuationSubring) :
+    w.ord (algebraMap (integralClosureAt F' v) F'
+        (algebraMap v.toValuationSubring (integralClosureAt F' v) r))
+      = w.ramificationIndex F * v.ord (algebraMap v.toValuationSubring F r) := by
+  rw [← IsScalarTower.algebraMap_apply,
+    IsScalarTower.algebraMap_apply v.toValuationSubring F F', w.ord_restrict, hw]
+
+theorem fiberCenter_liesOver (hw : w.restrict F = v) :
+    (fiberCenter F' v hw).asIdeal.LiesOver
+      (IsLocalRing.maximalIdeal v.toValuationSubring) := by
+  refine ⟨?_⟩
+  rw [Ideal.under_def]
+  ext r
+  rcases eq_or_ne r 0 with rfl | hr
+  · simp
+  rw [Ideal.mem_comap,
+    mem_fiberCenter_iff_ord_pos hw (algebraMap_integralClosureAt_ne_zero hr),
+    ord_algebraMap_integralClosureAt hw, mem_maximalIdeal_iff_ord_pos' hr]
+  have hepos : 0 < ramificationIndex (F := F) w := w.ramificationIndex_pos
+  constructor
+  · intro h
+    positivity
+  · intro h
+    rcases mul_pos_iff.mp h with ⟨_, h2⟩ | ⟨h1, _⟩
+    · exact h2
+    · omega
+
+end Center
+
+section Bijection
+
+variable {v : Place K F}
+
+def placeOfPrime (P : HeightOneSpectrum (integralClosureAt F' v)) : Place K F' where
+  toValuationSubring := HeightOneSpectrum.valuationSubringAtPrime F' P
+  algebraMap_mem' := fun a => by
+    rw [HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring,
+      Valuation.mem_valuationSubring_iff]
+    have h1 : algebraMap K F' a = algebraMap (integralClosureAt F' v) F'
+        (algebraMap v.toValuationSubring (integralClosureAt F' v)
+          (algebraMap K v.toValuationSubring a)) := by
+      rw [← IsScalarTower.algebraMap_apply,
+        IsScalarTower.algebraMap_apply v.toValuationSubring F F',
+        ← IsScalarTower.algebraMap_apply K v.toValuationSubring F,
+        ← IsScalarTower.algebraMap_apply K F F']
+    rw [h1]
+    exact P.valuation_le_one _
+  ne_top' := by
+    rw [HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+    simp only [ne_eq, Valuation.valuationSubring_eq_top_iff, not_not]
+    infer_instance
+  isPrincipalIdealRing' := by
+    rw [HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+    exact isPrincipalIdealRing_valuationSubring P
+
+@[simp]
+theorem placeOfPrime_toValuationSubring (P : HeightOneSpectrum (integralClosureAt F' v)) :
+    (placeOfPrime P).toValuationSubring = HeightOneSpectrum.valuationSubringAtPrime F' P :=
+  rfl
+
+theorem restrict_placeOfPrime (P : HeightOneSpectrum (integralClosureAt F' v)) :
+    (placeOfPrime P).restrict F = v := by
+  have hle : v.toValuationSubring ≤ ((placeOfPrime P).restrict F).toValuationSubring := by
+    intro g hg
+    rw [restrict_toValuationSubring, ValuationSubring.mem_comap,
+      placeOfPrime_toValuationSubring,
+      HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring,
+      Valuation.mem_valuationSubring_iff]
+    have h1 : algebraMap F F' g = algebraMap (integralClosureAt F' v) F'
+        (algebraMap v.toValuationSubring (integralClosureAt F' v) ⟨g, hg⟩) := by
+      rw [← IsScalarTower.algebraMap_apply,
+        IsScalarTower.algebraMap_apply v.toValuationSubring F F']
+      rfl
+    rw [h1]
+    exact P.valuation_le_one _
+  exact (Place.ext (ValuationSubring.eq_of_le_of_ne_top _ hle
+    ((placeOfPrime P).restrict F).ne_top')).symm
+
+theorem fiberCenter_placeOfPrime (P : HeightOneSpectrum (integralClosureAt F' v)) :
+    fiberCenter F' v (restrict_placeOfPrime P) = P := by
+  have h1 : HeightOneSpectrum.valuationSubringAtPrime F'
+      (fiberCenter F' v (restrict_placeOfPrime P))
+        = HeightOneSpectrum.valuationSubringAtPrime F' P := by
+    rw [← toValuationSubring_eq_of_restrict_eq (restrict_placeOfPrime P),
+      placeOfPrime_toValuationSubring]
+  refine HeightOneSpectrum.eq_of_valuation_isEquiv_valuation (K := F') ?_
+  rw [Valuation.isEquiv_iff_valuationSubring,
+    ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring,
+    ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring, h1]
+
+theorem eq_of_fiberCenter_eq {w w' : Place K F'} (hw : w.restrict F = v)
+    (hw' : w'.restrict F = v)
+    (h : fiberCenter F' v hw = fiberCenter F' v hw') : w = w' := by
+  refine Place.ext ?_
+  rw [toValuationSubring_eq_of_restrict_eq hw, toValuationSubring_eq_of_restrict_eq hw', h]
+
+end Bijection
+
+section Fiber
+
+variable (v : Place K F)
+
+variable (F') in
+def fiberEquiv :
+    {w : Place K F' // w.restrict F = v} ≃ HeightOneSpectrum (integralClosureAt F' v) where
+  toFun w := fiberCenter F' v w.2
+  invFun P := ⟨placeOfPrime P, restrict_placeOfPrime P⟩
+  left_inv w := Subtype.ext (eq_of_fiberCenter_eq (restrict_placeOfPrime _) w.2
+    (fiberCenter_placeOfPrime (fiberCenter F' v w.2)))
+  right_inv P := fiberCenter_placeOfPrime P
+
+@[simp]
+theorem fiberEquiv_apply (w : {w : Place K F' // w.restrict F = v}) :
+    fiberEquiv F' v w = fiberCenter F' v w.2 := rfl
+
+@[simp]
+theorem fiberEquiv_symm_apply (P : HeightOneSpectrum (integralClosureAt F' v)) :
+    ((fiberEquiv F' v).symm P : Place K F') = placeOfPrime P := rfl
+
+theorem finite_setOf_restrict_eq : {w : Place K F' | w.restrict F = v}.Finite := by
+  classical
+  let c : {w : Place K F' | w.restrict F = v} →
+      (IsDedekindDomain.primesOverFinset (IsLocalRing.maximalIdeal v.toValuationSubring)
+        (integralClosureAt F' v) : Set (Ideal (integralClosureAt F' v))) :=
+    fun w => ⟨(fiberCenter F' v w.2).asIdeal, by
+      rw [Finset.mem_coe, IsDedekindDomain.mem_primesOverFinset_iff (maximalIdeal_ne_bot v)]
+      exact ⟨(fiberCenter F' v w.2).isPrime, fiberCenter_liesOver w.2⟩⟩
+  have hc : Function.Injective c := fun w w' h =>
+    Subtype.ext (eq_of_fiberCenter_eq w.2 w'.2 (HeightOneSpectrum.ext (congrArg Subtype.val h)))
+  have : Finite {w : Place K F' | w.restrict F = v} := Finite.of_injective c hc
+  exact Set.toFinite _
+
+variable (F') in
+def fiberOver : Finset (Place K F') :=
+  (finite_setOf_restrict_eq (F' := F') v).toFinset
+
+@[simp]
+theorem mem_fiberOver {w : Place K F'} : w ∈ v.fiberOver F' ↔ w.restrict F = v := by
+  rw [fiberOver, Set.Finite.mem_toFinset, Set.mem_ofPred_eq]
+
+theorem restrict_mem_fiberOver (w : Place K F') : w ∈ (w.restrict F).fiberOver F' :=
+  (mem_fiberOver _).mpr rfl
+
+theorem restrict_eq_of_mem_fiberOver {w : Place K F'} (hw : w ∈ v.fiberOver F') :
+    w.restrict F = v :=
+  (mem_fiberOver v).mp hw
+
+theorem subset_fiberOver_of_forall_restrict_eq {S : Finset (Place K F')}
+    (hS : ∀ w ∈ S, w.restrict F = v) : S ⊆ v.fiberOver F' :=
+  fun w hw => (mem_fiberOver v).mpr (hS w hw)
+
+theorem card_fiberOver_eq :
+    (v.fiberOver F').card =
+      (IsDedekindDomain.primesOverFinset (IsLocalRing.maximalIdeal v.toValuationSubring)
+        (integralClosureAt F' v)).card := by
+  classical
+  refine Finset.card_bij (fun w hw => (fiberCenter F' v ((mem_fiberOver v).mp hw)).asIdeal) ?_ ?_ ?_
+  · intro w hw
+    rw [IsDedekindDomain.mem_primesOverFinset_iff (maximalIdeal_ne_bot v)]
+    exact ⟨(fiberCenter F' v _).isPrime, fiberCenter_liesOver _⟩
+  · intro w hw w' hw' h
+    exact eq_of_fiberCenter_eq ((mem_fiberOver v).mp hw) ((mem_fiberOver v).mp hw')
+      (HeightOneSpectrum.ext h)
+  · intro P hP
+    rw [IsDedekindDomain.mem_primesOverFinset_iff (maximalIdeal_ne_bot v)] at hP
+    obtain ⟨hP1, hP2⟩ := hP
+    have hPne : P ≠ ⊥ := by
+      intro h
+      apply maximalIdeal_ne_bot v
+      have h2 := hP2.over
+      rw [h, Ideal.under_def, Ideal.comap_bot_of_injective _
+        (algebraMap_integralClosureAt_injective v)] at h2
+      exact h2
+    exact ⟨placeOfPrime ⟨P, hP1, hPne⟩, (mem_fiberOver v).mpr (restrict_placeOfPrime _),
+      congrArg HeightOneSpectrum.asIdeal (fiberCenter_placeOfPrime (⟨P, hP1, hPne⟩ :
+        HeightOneSpectrum (integralClosureAt F' v)))⟩
+
+theorem fiber_eq_fiberOver [HasPrincipalDivisors K F'] : v.fiber F' = v.fiberOver F' :=
+  Finset.ext fun w => by rw [mem_fiber, mem_fiberOver]
+
+end Fiber
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_PoleDivisorPackage.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_PoleDivisorPackage.lean
new file mode 100644
index 0000000000..95bb00bc47
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_PoleDivisorPackage.lean
@@ -0,0 +1,139 @@
+/-
+Based on Prove2Me node AlgebraicCurve_PoleDivisorPackage
+(341b2ae3-6c58-5e65-ba80-ec071e24ed27) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+
+/-!
+# Pole-divisor packages and transcendence towers for function fields
+
+Definition: `AlgebraicCurve_PoleDivisorPackage` (`341b2ae3-6c58-5e65-ba80-ec071e24ed27`), by Claude,
+2026-09-05.
+
+Two bundles of data for the divisor theory of a function field $F$ over a base field $K$, in the
+project's framework where a place $v$ of $F/K$ is a proper valuation subring containing $K$ whose
+ring is a principal ideal domain, $\mathrm{Divisor}\,K\,F$ is the free abelian group on places,
+$v.\mathrm{ord}$ is the normalised valuation, $\deg$ is $\sum_v D(v)\,[\kappa(v):K]$, and `LSpace D`
+is the space of $f$ with $\mathrm{ord}_v f \ge -D(v)$ for all $v$.
+
+`PoleDivisorPackage K F` carries: an element $x \in F$; an effective divisor $B \ge 0$ with $x \in
+L(B)$; a positive natural number $n$ with $\deg B = n$; a natural number $c$; a family
+$u_1,\dots,u_n \in L(cB)$; and, as a field of the structure, the assertion that the doubly indexed
+family $(x^{j}u_i)_{j \in \mathbb{N},\, i \le n}$ is $K$-linearly independent. Note that $n$ is tied
+to $\deg B$ only, not to $[F:K(x)]$, and the transcendence of $x$ is encoded implicitly in the
+independence field. `HasPoleDivisorPackage` is its nonemptiness.
+
+`TranscendenceTower K E F`, for a tower $K \subseteq E \subseteq F$, carries $x \in E$ whose powers
+$(x^{j})_{j \in \mathbb{N}}$ are $K$-linearly independent, together with a place $v$ of $E/K$ with
+$\deg v = 1$, $\mathrm{ord}_v x = -1$, and $\mathrm{ord}_u x \ge 0$ for every other place $u$ of
+$E/K$; so $x$ has a single simple pole, at a rational place. Its `poleDivisor` is the pullback to
+$F$ (a sum over places above $v$ weighted by the ramification indices, defined as the least positive
+value of $\mathrm{ord}_w$ on $E^{\times}$) of the divisor $1\cdot v$, available under separability
+of $F/E$ and the existence of principal divisors on $F$; `xF` is the image of $x$ in $F$, and
+`RegularOutside A T` says that every element of a ring $A$ mapping to $E$ lies in the valuation
+subring of each place $u \ne v$.
+
+The remaining declarations are predicates on such a tower: `IntegralBasisInLSpace` (and its
+nonemptiness `HasIntegralBasisInLSpace`) asks for some $c \in \mathbb{N}$ and an $E$-linearly
+independent family of $[F:E]$ elements of $F$ lying in $L(c \cdot \mathrm{poleDivisor})$;
+`HasIntegralBasisRegularOutside` asks instead for an $E$-linearly independent family of $[F:E]$
+elements regular at every place $w$ of $F/K$ whose restriction to $E$ is not $v$; and
+`HasRegularFractionSubring` asks for a $K$-subalgebra $A \subseteq E$ with $E$ as fraction field all
+of whose elements are regular away from $v$.
+
+**Relation to Mathlib.** Mathlib has no theory of places and divisors of a function field in this
+shape; these structures are built on the project's own `Place`, `Divisor`, ramification index,
+pullback and `LSpace` (the Riemann–Roch space) rather than on Mathlib's `Ideal.ramificationIdx` and
+Dedekind-domain machinery.
+
+**Where it is used.** These data types package the hypotheses used in the project's treatment of
+Riemann's inequality for a function field — bounding $\deg D - \ell(D)$ and thereby producing the
+genus and the finiteness of the index of specialty — which underlies the Riemann–Roch theory applied
+to modular curves.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+structure PoleDivisorPackage (K F : Type*) [Field K] [Field F] [Algebra K F] where
+  x : F
+  B : Divisor K F
+  hB_eff : 0 ≤ B
+  hx_mem : x ∈ LSpace B
+  n : ℕ
+  hn_pos : 0 < n
+  degB_eq : Divisor.degree B = n
+  c : ℕ
+  u : Fin n → F
+  hu_mem : ∀ i, u i ∈ LSpace (c • B)
+  lin_indep : LinearIndependent K (fun p : ℕ × Fin n => x ^ p.1 * u p.2)
+
+def HasPoleDivisorPackage (K F : Type*) [Field K] [Field F] [Algebra K F] : Prop :=
+  Nonempty (PoleDivisorPackage K F)
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+
+structure TranscendenceTower (K E F : Type*) [Field K] [Field E] [Field F]
+    [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F] where
+  x : E
+  hx_indep : LinearIndependent K (fun j : ℕ => x ^ j)
+  v : Place K E
+  hvdeg : v.deg = 1
+  hxv : v.ord x = -1
+  hxreg : ∀ u : Place K E, u ≠ v → 0 ≤ u.ord x
+
+namespace TranscendenceTower
+
+variable (T : TranscendenceTower K E F)
+
+abbrev xF : F := algebraMap E F T.x
+
+def poleDivisor [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] : Divisor K F :=
+  Divisor.pullback F (Finsupp.single T.v 1)
+
+def RegularOutside (A : Type*) [CommRing A] [Algebra A E] (T : TranscendenceTower K E F) : Prop :=
+  ∀ u : Place K E, u ≠ T.v → ∀ a : A, algebraMap A E a ∈ u.toValuationSubring
+
+end TranscendenceTower
+
+structure IntegralBasisInLSpace [Algebra.IsSeparable E F] [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F) where
+  c : ℕ
+  u : Fin (Module.finrank E F) → F
+  hu_indep : LinearIndependent E u
+  hu_mem : ∀ i, u i ∈ LSpace (c • T.poleDivisor)
+
+variable (K E F) in
+def HasIntegralBasisInLSpace [Algebra.IsSeparable E F] [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F) : Prop :=
+  Nonempty (IntegralBasisInLSpace T)
+
+variable (K E F) in
+def HasIntegralBasisRegularOutside [Algebra.IsSeparable E F] (T : TranscendenceTower K E F) :
+    Prop :=
+  ∃ u : Fin (Module.finrank E F) → F, LinearIndependent E u ∧
+    ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)
+
+variable (K E F) in
+def HasRegularFractionSubring (T : TranscendenceTower K E F) : Prop :=
+  ∃ (A : Subalgebra K E), IsFractionRing A E ∧
+    ∀ u : Place K E, u ≠ T.v → ∀ a ∈ A, a ∈ u.toValuationSubring
+
+end AlgebraicCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_RatFuncPlaceClassification.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_RatFuncPlaceClassification.lean
new file mode 100644
index 0000000000..d9929086cb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_RatFuncPlaceClassification.lean
@@ -0,0 +1,185 @@
+/-
+Based on Prove2Me node AlgebraicCurve_RatFuncPlaceClassification
+(b8a68eea-2ede-5e05-8b00-dfa35fbba255) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.RatFunc.Ostrowski
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceInfty
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+
+/-!
+# Classification of places of the rational function field
+
+Definition: `AlgebraicCurve_RatFuncPlaceClassification` (`b8a68eea-2ede-5e05-8b00-dfa35fbba255`), by
+Claude, 2026-09-05.
+
+Throughout, $K$ is a field and places are taken in the project's sense: a `Place K F` is a valuation
+subring of $F$ containing the image of $K$, distinct from $F$ itself, and whose underlying ring is a
+principal ideal ring (hence a discrete valuation ring); two places are equal exactly when their
+valuation subrings coincide. For $F = \mathrm{RatFunc}\,K$ the two sources of places are
+`Place.ofHeightOneSpectrum w`, the valuation subring of the $w$-adic valuation attached to a
+height-one prime $w$ of $K[X]$, and `placeInfty K`, the valuation subring of Mathlib's
+`RatFunc.inftyValuation`. An instance records that the value group of `RatFunc.inftyValuation K` is
+nontrivial, the witness being $X$.
+
+The separation statement `placeInfty_ne_ofHeightOneSpectrum` says that `placeInfty K` differs from
+`Place.ofHeightOneSpectrum w` for every height-one prime $w$ of $K[X]$, and
+`placeOfPoint_ne_placeInfty` specialises this to the place $\mathrm{placeOfPoint}\,K\,a$ cut out by
+the prime $(X - a)$. The classification `eq_ofHeightOneSpectrum_or_eq_placeInfty` asserts that every
+place $v$ of $\mathrm{RatFunc}\,K$ over $K$ is either of the form `Place.ofHeightOneSpectrum w` for
+some height-one prime $w$ of $K[X]$, or equals `placeInfty K`; the proof compares valuation subrings
+through $v$'s associated $\mathbb{Z}^{m0}$-valued adic valuation and invokes Mathlib's dichotomy
+`RatFunc.valuation_isEquiv_infty_or_adic`. When $K$ is algebraically closed,
+`exists_eq_placeOfPoint` identifies each `Place.ofHeightOneSpectrum w` with some
+$\mathrm{placeOfPoint}\,K\,a$, via a generator of $w$, necessarily associate to $X - a$ for a root
+$a$; combining these gives `eq_placeOfPoint_or_eq_placeInfty`. These facts are packaged as
+`placeEquivOption K`, an explicit bijection $\mathrm{Place}\,K\,(\mathrm{RatFunc}\,K) \simeq
+\mathrm{Option}\,K$ sending $\mathrm{placeOfPoint}\,K\,a$ to `some a` and `placeInfty K` to `none`,
+with the four corresponding rewriting lemmas.
+
+**Relation to Mathlib.** `Place` is the project's own structure (a valuation subring of $F$
+containing $K$, proper, and principal), not a Mathlib notion; the inputs used here —
+`RatFunc.inftyValuation`, the adic valuations of the height-one spectrum of $K[X]$, and the
+dichotomy `RatFunc.valuation_isEquiv_infty_or_adic` — are Mathlib's, and the content of this module
+is their translation into statements about `Place`.
+
+**Where it is used.** The resulting bijection $\mathrm{Place}\,K(t) \simeq K \sqcup \{\infty\}$ is
+the place-theoretic form of $\mathbb{P}^1(K) = K \sqcup \{\infty\}$ for algebraically closed $K$,
+and is used in the project's description of the $j$-line over an algebraically closed field, its
+affine points and its single cusp, which underlies the divisor-theoretic treatment of Hecke
+correspondences in the special fibre.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open Polynomial IsDedekindDomain WithZero IsLocalRing
+open scoped Polynomial
+
+namespace AlgebraicCurve
+
+namespace RationalFunctionField
+
+variable (K : Type*) [Field K]
+
+section PlaceInfty
+
+variable [DecidableEq (RatFunc K)]
+
+instance :
+    Nontrivial (MonoidWithZeroHom.valueGroup (MonoidWithZeroHom.ofClass (RatFunc.inftyValuation K)))
+      := by
+  rw [Subgroup.nontrivial_iff_exists_ne_one]
+  refine ⟨Units.mk0 (RatFunc.inftyValuation K RatFunc.X)
+    (by rw [RatFunc.inftyValuation.X]; exact exp_ne_zero), ?_, ?_⟩
+  · exact MonoidWithZeroHom.mem_valueGroup _ ⟨RatFunc.X, rfl⟩
+  · rw [ne_eq, Units.ext_iff, Units.val_mk0, Units.val_one, RatFunc.inftyValuation.X]
+    simp
+
+theorem placeInfty_ne_ofHeightOneSpectrum (w : HeightOneSpectrum K[X]) :
+    placeInfty K ≠ Place.ofHeightOneSpectrum w := by
+  intro h
+  refine RatFunc.adicValuation_not_isEquiv_infty_valuation w
+    ((Valuation.isEquiv_iff_valuationSubring _ _).mpr ?_)
+  have h2 := congrArg Place.toValuationSubring h
+  rw [placeInfty_toValuationSubring, Place.ofHeightOneSpectrum_toValuationSubring] at h2
+  exact h2.symm
+
+end PlaceInfty
+
+variable {K}
+
+theorem eq_ofHeightOneSpectrum_or_eq_placeInfty [DecidableEq (RatFunc K)]
+    (v : Place K (RatFunc K)) :
+    (∃ w : HeightOneSpectrum K[X], v = Place.ofHeightOneSpectrum w) ∨ v = placeInfty K := by
+  rcases (RatFunc.valuation_isEquiv_infty_or_adic (v := v.adicValuation)).or with h | h
+  · exact Or.inr (Place.ext (v.adicValuation_valuationSubring.symm.trans
+      ((Valuation.isEquiv_iff_valuationSubring _ _).mp h)))
+  · obtain ⟨w, hw, -⟩ := h
+    exact Or.inl ⟨w, Place.ext (v.adicValuation_valuationSubring.symm.trans
+      ((Valuation.isEquiv_iff_valuationSubring _ _).mp hw))⟩
+
+variable (K)
+
+theorem placeOfPoint_ne_placeInfty [DecidableEq (RatFunc K)] (a : K) :
+    placeOfPoint K a ≠ placeInfty K := by
+  rw [placeOfPoint_eq_ofHeightOneSpectrum]
+  exact fun h => placeInfty_ne_ofHeightOneSpectrum K _ h.symm
+
+theorem exists_eq_placeOfPoint [IsAlgClosed K] (w : HeightOneSpectrum K[X]) :
+    ∃ a : K, Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w = placeOfPoint K a := by
+  obtain ⟨p, hp, hwp⟩ := exists_irreducible_span K w
+  have hdeg : p.degree ≠ 0 := by
+    rw [IsAlgClosed.degree_eq_one_of_irreducible K hp]; exact one_ne_zero
+  obtain ⟨a, ha⟩ := IsAlgClosed.exists_root p hdeg
+  refine ⟨a, ?_⟩
+  have hassoc : Associated ((X : K[X]) - C a) p :=
+    (irreducible_X_sub_C a).associated_of_dvd hp (dvd_iff_isRoot.mpr ha)
+  have hideal : w = heightOneSpectrumOfIrreducible K (irreducible_X_sub_C a) :=
+    HeightOneSpectrum.ext (by
+      rw [hwp, heightOneSpectrumOfIrreducible_asIdeal]
+      exact (Ideal.span_singleton_eq_span_singleton.mpr hassoc).symm)
+  rw [hideal, placeOfPoint_eq_ofHeightOneSpectrum]
+
+theorem eq_placeOfPoint_or_eq_placeInfty [IsAlgClosed K] [DecidableEq (RatFunc K)]
+    (v : Place K (RatFunc K)) :
+    (∃ a : K, v = placeOfPoint K a) ∨ v = placeInfty K := by
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, hw⟩ | hw
+  · obtain ⟨a, ha⟩ := exists_eq_placeOfPoint K w
+    exact Or.inl ⟨a, hw.trans ha⟩
+  · exact Or.inr hw
+
+def ofOption [DecidableEq (RatFunc K)] : Option K → Place K (RatFunc K) :=
+  fun o => o.elim (placeInfty K) (placeOfPoint K)
+
+private theorem ofOption_bijective [IsAlgClosed K] [DecidableEq (RatFunc K)] :
+    Function.Bijective (ofOption K) := by
+  constructor
+  · rintro (_ | a) (_ | b) h
+    · rfl
+    · exact absurd h.symm (placeOfPoint_ne_placeInfty K b)
+    · exact absurd h (placeOfPoint_ne_placeInfty K a)
+    · exact congrArg some (placeOfPoint_injective K h)
+  · intro v
+    rcases eq_placeOfPoint_or_eq_placeInfty K v with ⟨a, ha⟩ | ha
+    · exact ⟨some a, ha.symm⟩
+    · exact ⟨none, ha.symm⟩
+
+def placeEquivOption [IsAlgClosed K] [DecidableEq (RatFunc K)] :
+    Place K (RatFunc K) ≃ Option K :=
+  (Equiv.ofBijective (ofOption K) (by exact ofOption_bijective K)).symm
+
+@[simp]
+theorem placeEquivOption_symm_some [IsAlgClosed K] [DecidableEq (RatFunc K)] (a : K) :
+    (placeEquivOption K).symm (some a) = placeOfPoint K a := rfl
+
+@[simp]
+theorem placeEquivOption_symm_none [IsAlgClosed K] [DecidableEq (RatFunc K)] :
+    (placeEquivOption K).symm none = placeInfty K := rfl
+
+@[simp]
+theorem placeEquivOption_placeOfPoint [IsAlgClosed K] [DecidableEq (RatFunc K)] (a : K) :
+    placeEquivOption K (placeOfPoint K a) = some a :=
+  (Equiv.ofBijective (ofOption K) (ofOption_bijective K)).symm_apply_apply (some a)
+
+@[simp]
+theorem placeEquivOption_placeInfty [IsAlgClosed K] [DecidableEq (RatFunc K)] :
+    placeEquivOption K (placeInfty K) = none :=
+  (Equiv.ofBijective (ofOption K) (ofOption_bijective K)).symm_apply_apply none
+
+end RationalFunctionField
+
+end AlgebraicCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_RatFuncPlaceInfty.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_RatFuncPlaceInfty.lean
new file mode 100644
index 0000000000..627d1a6096
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_RatFuncPlaceInfty.lean
@@ -0,0 +1,96 @@
+/-
+Based on Prove2Me node AlgebraicCurve_RatFuncPlaceInfty
+(95864536-1573-56f9-9f83-efe538f03ec0) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Valuation
+public import Mathlib.RingTheory.SimpleRing.Principal
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+/-!
+# The place at infinity of a rational function field
+
+Definition: `AlgebraicCurve_RatFuncPlaceInfty` (`95864536-1573-56f9-9f83-efe538f03ec0`), by Claude,
+2026-09-05.
+
+Let $K$ be a field. Mathlib's valuation $v_\infty =$ `RatFunc.inftyValuation K` on $K(t)$ sends $0$
+to $0$ and a nonzero $f$ to $\exp(\deg_{\mathrm{int}} f)$, so that $p/q \mapsto \exp(\deg p - \deg
+q)$; its valuation subring is $\{f : v_\infty(f) \le 1\} = \{p/q : \deg p \le \deg q\}$. The module
+first records `nontrivial_valueGroup_inftyValuation`: the value group of (the monoid-with-zero-hom
+class of) $v_\infty$ is nontrivial, witnessed by the image $\exp(1)$ of $t$, which is a nonzero
+non-identity element of that group.
+
+The main definition, `placeInfty K`, exhibits this valuation subring as a term of the project's
+structure `Place K (RatFunc K)`, whose fields are: a valuation subring of the ambient field; the
+requirement that the image of every element of the base field $K$ lie in it, verified here from
+triviality of $v_\infty$ on constants; the requirement that the subring be distinct from the whole
+field, which follows from the nontriviality just proved; and the requirement that it be a principal
+ideal ring, obtained from discreteness of $v_\infty$ (the `Place` structure then supplies, for any
+such place, a discrete valuation ring structure, an order function $\mathrm{ord}$, a residue field
+and a degree). A simp lemma identifies the underlying valuation subring of `placeInfty K` with that
+of $v_\infty$.
+
+**Relation to Mathlib.** Mathlib supplies the valuation `RatFunc.inftyValuation` and its valuation
+subring; the structure `Place` packaging a valuation subring of an extension $F/K$ containing $K$,
+proper and principal, is the project's own, and this module produces the corresponding term for the
+place at infinity.
+
+**Where it is used.** Together with the places `Place.ofHeightOneSpectrum` attached to the
+height-one primes of $K[t]$, this is the remaining place of $K(t)/K$, so it enters the project's
+computations of divisors, degrees and degree-zero divisor class groups for the rational function
+field.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+
+namespace RationalFunctionField
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+
+theorem nontrivial_valueGroup_inftyValuation :
+    Nontrivial (MonoidWithZeroHom.valueGroup (.ofClass (RatFunc.inftyValuation K))) := by
+  rw [Subgroup.nontrivial_iff_exists_ne_one]
+  refine ⟨Units.mk0 (RatFunc.inftyValuation K RatFunc.X)
+    (by rw [RatFunc.inftyValuation.X]; exact exp_ne_zero), ?_, ?_⟩
+  · exact MonoidWithZeroHom.mem_valueGroup _ ⟨RatFunc.X, rfl⟩
+  · rw [ne_eq, Units.ext_iff, Units.val_mk0, Units.val_one, RatFunc.inftyValuation.X]
+    simp
+
+def placeInfty : Place K (RatFunc K) :=
+  haveI := nontrivial_valueGroup_inftyValuation K
+  { toValuationSubring := (RatFunc.inftyValuation K).valuationSubring
+    algebraMap_mem' := fun a => by
+      rw [Valuation.mem_valuationSubring_iff]
+      exact Valuation.IsTrivialOn.valuation_algebraMap_le_one (v := RatFunc.inftyValuation K) a
+    ne_top' := by
+      simp only [ne_eq, Valuation.valuationSubring_eq_top_iff, not_not]
+      infer_instance
+    isPrincipalIdealRing' :=
+      (Valuation.valuationSubring_isDiscreteValuationRing
+        (RatFunc.inftyValuation K)).toIsPrincipalIdealRing }
+
+@[simp]
+theorem placeInfty_toValuationSubring :
+    (placeInfty K).toValuationSubring = (RatFunc.inftyValuation K).valuationSubring := rfl
+
+end RationalFunctionField
+
+end AlgebraicCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_RatFuncPlaces.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_RatFuncPlaces.lean
new file mode 100644
index 0000000000..11af09b873
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_RatFuncPlaces.lean
@@ -0,0 +1,456 @@
+/-
+Based on Prove2Me node AlgebraicCurve_RatFuncPlaces
+(07390cff-bcbe-57c5-95cb-48ea897f5c4d) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import Mathlib.RingTheory.Henselian
+public import Mathlib.RingTheory.RegularLocalRing.Defs
+public import Mathlib.RingTheory.SimpleRing.Principal
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+/-!
+# Places of rational function fields, and transport along field isomorphisms
+
+Definition: `AlgebraicCurve_RatFuncPlaces` (`07390cff-bcbe-57c5-95cb-48ea897f5c4d`), by Claude,
+2026-09-05.
+
+Throughout, a `Place` of a field extension $F/K$ is (as defined in the divisor class group module) a
+valuation subring $V \subseteq F$ containing the image of $K$, distinct from $F$, and a principal
+ideal ring; `adicValuation` is the $\mathbb{Z}^{\mathrm{m}0}$-valued valuation attached to the
+maximal ideal of $V$, `ord` is $-\log$ of it, and `deg` is $\dim_K$ of the residue field of $V$. The
+first group of results is the dictionary between these data: the valuation subring of
+`adicValuation` is $V$ itself, so $f \in V \iff v(f) \le 1$, an element of $V$ lies in the maximal
+ideal iff its value is $<1$, any valuation on $F$ with valuation subring $V$ is equivalent to
+`adicValuation`, and for $f \ne 0$ one has $\operatorname{ord}_v f = 0 \iff v(f) = 1$;
+`adicValuation` is registered as rank-one discrete and as trivial on $K$. For a Dedekind domain $R$
+with fraction field $F$ sitting in a tower $K \to R \to F$, the place `ofHeightOneSpectrum w`
+attached to a height-one prime $w$ has $w$-adic valuation equivalent to its `adicValuation`; the map
+$w \mapsto$ place is injective, and for $q \in R$ nonzero, $\operatorname{ord}(q) \ne 0 \iff q \in
+w$.
+
+Specialising to $R = K[X]$ and $F = K(X)$: `heightOneSpectrumOfIrreducible` is the height-one prime
+$(p)$ of an irreducible $p$, every height-one prime of $K[X]$ arises this way, and `finitePlace hp`
+is the corresponding place of $K(X)$. The composite of $K[X] \to V \to V/\mathfrak m$ has kernel $w$
+and is surjective, giving a $K$-algebra isomorphism $K[X]/w \cong$ residue field, whence $\deg =
+\deg p$ when $w = (p)$. `placeOfPoint a` is the place at $X - a$; it is injective in $a$ and has
+degree $1$.
+
+Finally, for a ring isomorphism $e : F \cong F'$ commuting with the structure maps from $K$,
+`congrRingEquiv` transports a place to the place with valuation subring the preimage of $V$ under
+$e^{-1}$ (i.e. $e(V)$), with $\operatorname{ord}_{e_*v}(e f) = \operatorname{ord}_v f$, a
+$K$-algebra isomorphism of residue fields, equality of degrees, and `congrEquiv`, the resulting
+bijection $\mathrm{Place}\,K\,F \simeq \mathrm{Place}\,K\,F'$ with inverse induced by $e^{-1}$.
+
+**Relation to Mathlib.** Mathlib supplies the $w$-adic valuations of a Dedekind domain
+(`IsDedekindDomain.HeightOneSpectrum`), valuation subrings and `RatFunc`; the `Place` structure is
+the project's own, and this module provides the comparison between the two descriptions, the
+classification of places of $K(X)$ coming from $K[X]$, and the transport of places along an
+isomorphism of extensions of $K$.
+
+**Where it is used.** These places supply the local data on rational function fields used when a
+genus-zero modular curve is presented as a $j$-line: the places of $K(j)$ at $K$-rational points are
+obtained from `placeOfPoint` and carried across the identification of the function field with $K(X)$
+by `congrEquiv`, feeding the divisor and degree computations built on the divisor class group
+module.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open Polynomial IsDedekindDomain WithZero IsLocalRing
+
+open scoped Polynomial
+
+namespace AlgebraicCurve
+
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+theorem adicValuation_valuationSubring :
+    v.adicValuation.valuationSubring = v.toValuationSubring := by
+  ext x
+  rw [Valuation.mem_valuationSubring_iff]
+  constructor
+  · intro hx
+    obtain ⟨a, rfl⟩ := IsDiscreteValuationRing.exists_lift_of_le_one hx
+    exact a.2
+  · intro hx
+    exact v.heightOneSpectrum.valuation_le_one (⟨x, hx⟩ : v.toValuationSubring)
+
+theorem mem_iff_adicValuation_le_one {f : F} :
+    f ∈ v.toValuationSubring ↔ v.adicValuation f ≤ 1 := by
+  rw [← v.adicValuation_valuationSubring]
+  exact Valuation.mem_valuationSubring_iff _ _
+
+instance : v.adicValuation.IsRankOneDiscrete :=
+  IsDiscreteValuationRing.isRankOneDiscrete v.toValuationSubring F
+
+instance : v.adicValuation.IsTrivialOn K :=
+  Valuation.IsTrivialOn.of_le_one v.adicValuation fun a =>
+    v.mem_iff_adicValuation_le_one.mp (v.algebraMap_mem' a)
+
+theorem isEquiv_adicValuation_of_valuationSubring_eq {Γ : Type*}
+    [LinearOrderedCommGroupWithZero Γ] {w : Valuation F Γ}
+    (h : w.valuationSubring = v.toValuationSubring) : w.IsEquiv v.adicValuation :=
+  (Valuation.isEquiv_iff_valuationSubring _ _).mpr
+    (h.trans v.adicValuation_valuationSubring.symm)
+
+theorem mem_maximalIdeal_iff_adicValuation_lt_one (a : v.toValuationSubring) :
+    a ∈ IsLocalRing.maximalIdeal v.toValuationSubring ↔ v.adicValuation (a : F) < 1 := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff, ← v.adicValuation_coe_eq_one_iff,
+    lt_iff_le_and_ne]
+  have hle : v.adicValuation (a : F) ≤ 1 := v.mem_iff_adicValuation_le_one.mp a.2
+  tauto
+
+theorem ord_eq_zero_iff_adicValuation_eq_one {f : F} (hf : f ≠ 0) :
+    v.ord f = 0 ↔ v.adicValuation f = 1 := by
+  simp only [ord, neg_eq_zero]
+  constructor
+  · intro h
+    have h2 := exp_log (v.adicValuation_ne_zero hf)
+    rw [h, exp_zero] at h2
+    exact h2.symm
+  · intro h
+    rw [h, log_one]
+
+section OfHeightOneSpectrum
+
+variable {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R F] [IsFractionRing R F]
+  [Algebra K R] [IsScalarTower K R F]
+
+theorem isEquiv_adicValuation_ofHeightOneSpectrum (w : HeightOneSpectrum R) :
+    (w.valuation F).IsEquiv (ofHeightOneSpectrum (K := K) w).adicValuation :=
+  (ofHeightOneSpectrum (K := K) w).isEquiv_adicValuation_of_valuationSubring_eq rfl
+
+theorem ofHeightOneSpectrum_injective :
+    Function.Injective (ofHeightOneSpectrum (K := K) (F := F) (R := R)) := by
+  intro w w' h
+  refine HeightOneSpectrum.eq_of_valuation_isEquiv_valuation (K := F) ?_
+  refine (isEquiv_adicValuation_ofHeightOneSpectrum (K := K) (F := F) w).trans ?_
+  rw [h]
+  exact (isEquiv_adicValuation_ofHeightOneSpectrum (K := K) (F := F) w').symm
+
+theorem ord_ofHeightOneSpectrum_ne_zero_iff (w : HeightOneSpectrum R) {q : R} (hq : q ≠ 0) :
+    (ofHeightOneSpectrum (K := K) (F := F) w).ord (algebraMap R F q) ≠ 0 ↔ q ∈ w.asIdeal := by
+  have hq' : algebraMap R F q ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective R F)).mpr hq
+  rw [ne_eq, (ofHeightOneSpectrum (K := K) w).ord_eq_zero_iff_adicValuation_eq_one hq',
+    ← (isEquiv_adicValuation_ofHeightOneSpectrum (K := K) (F := F) w).eq_one_iff_eq_one,
+    HeightOneSpectrum.valuation_eq_one_iff_notMem, not_not]
+
+end OfHeightOneSpectrum
+
+end Place
+
+namespace RationalFunctionField
+
+variable (K : Type*) [Field K]
+
+def heightOneSpectrumOfIrreducible {p : K[X]} (hp : Irreducible p) :
+    HeightOneSpectrum K[X] where
+  asIdeal := Ideal.span {p}
+  isPrime := (PrincipalIdealRing.isMaximal_of_irreducible hp).isPrime
+  ne_bot := by simpa [Ideal.span_singleton_eq_bot] using hp.ne_zero
+
+@[simp]
+theorem heightOneSpectrumOfIrreducible_asIdeal {p : K[X]} (hp : Irreducible p) :
+    (heightOneSpectrumOfIrreducible K hp).asIdeal = Ideal.span {p} := rfl
+
+theorem exists_irreducible_span (w : HeightOneSpectrum K[X]) :
+    ∃ p : K[X], Irreducible p ∧ w.asIdeal = Ideal.span {p} := by
+  obtain ⟨p, hp⟩ := (IsPrincipalIdealRing.principal w.asIdeal).principal
+  rw [Ideal.submodule_span_eq] at hp
+  refine ⟨p, ?_, hp⟩
+  have hp0 : p ≠ 0 := by
+    rintro rfl
+    exact w.ne_bot (hp.trans (by simp))
+  have hpr := w.isPrime
+  rw [hp] at hpr
+  exact ((Ideal.span_singleton_prime hp0).mp hpr).irreducible
+
+def finitePlace {p : K[X]} (hp : Irreducible p) : Place K (RatFunc K) :=
+  Place.ofHeightOneSpectrum (heightOneSpectrumOfIrreducible K hp)
+
+theorem finitePlace_def {p : K[X]} (hp : Irreducible p) :
+    finitePlace K hp = Place.ofHeightOneSpectrum (heightOneSpectrumOfIrreducible K hp) := rfl
+
+section ResidueDegree
+
+theorem algebraMap_mem_ofHeightOneSpectrum (w : HeightOneSpectrum K[X]) (q : K[X]) :
+    algebraMap K[X] (RatFunc K) q ∈
+      (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).toValuationSubring :=
+  (Place.mem_iff_adicValuation_le_one _).mpr
+    ((Place.isEquiv_adicValuation_ofHeightOneSpectrum (K := K)
+      (F := RatFunc K) w).le_one_iff_le_one.mp (w.valuation_le_one q))
+
+def residueOfHeightOneSpectrum (w : HeightOneSpectrum K[X]) :
+    K[X] →+* (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ResidueField :=
+  (IsLocalRing.residue _).comp
+    ((algebraMap K[X] (RatFunc K)).codRestrict
+      (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).toValuationSubring.toSubring
+      (algebraMap_mem_ofHeightOneSpectrum K w))
+
+theorem residueOfHeightOneSpectrum_apply (w : HeightOneSpectrum K[X]) (q : K[X]) :
+    residueOfHeightOneSpectrum K w q = IsLocalRing.residue _
+      ⟨algebraMap K[X] (RatFunc K) q, algebraMap_mem_ofHeightOneSpectrum K w q⟩ := rfl
+
+theorem ker_residueOfHeightOneSpectrum (w : HeightOneSpectrum K[X]) :
+    RingHom.ker (residueOfHeightOneSpectrum K w) = w.asIdeal := by
+  ext q
+  rw [RingHom.mem_ker, residueOfHeightOneSpectrum_apply, IsLocalRing.residue_eq_zero_iff,
+    Place.mem_maximalIdeal_iff_adicValuation_lt_one,
+    ← (Place.isEquiv_adicValuation_ofHeightOneSpectrum (K := K)
+      (F := RatFunc K) w).lt_one_iff_lt_one]
+  exact HeightOneSpectrum.valuation_lt_one_iff_mem w q
+
+theorem surjective_residueOfHeightOneSpectrum (w : HeightOneSpectrum K[X]) :
+    Function.Surjective (residueOfHeightOneSpectrum K w) := by
+  intro y
+  obtain ⟨⟨x, hx⟩, rfl⟩ := IsLocalRing.residue_surjective y
+  have hxval : w.valuation (RatFunc K) x ≤ 1 :=
+    (Place.isEquiv_adicValuation_ofHeightOneSpectrum (K := K)
+      (F := RatFunc K) w).le_one_iff_le_one.mpr ((Place.mem_iff_adicValuation_le_one _).mp hx)
+  have hden_ne : algebraMap K[X] (RatFunc K) x.denom ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr x.denom_ne_zero
+  have hmul : x * algebraMap K[X] (RatFunc K) x.denom = algebraMap K[X] (RatFunc K) x.num :=
+    ((div_eq_iff hden_ne).mp x.num_div_denom).symm
+  have hden : x.denom ∉ w.asIdeal := by
+    intro hd
+    have hnum : x.num ∉ w.asIdeal := by
+      intro hn
+      refine w.isPrime.ne_top ((Ideal.eq_top_iff_one _).mpr ?_)
+      obtain ⟨a, b, hab⟩ := RatFunc.isCoprime_num_denom x
+      exact hab ▸ Ideal.add_mem _ (Ideal.mul_mem_left _ _ hn) (Ideal.mul_mem_left _ _ hd)
+    have h1 : w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) x.num) = 1 :=
+      (HeightOneSpectrum.valuation_eq_one_iff_notMem w).mpr hnum
+    refine absurd h1 (ne_of_lt ?_)
+    calc w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) x.num)
+        = w.valuation (RatFunc K) x
+            * w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) x.denom) := by
+          rw [← map_mul, hmul]
+      _ ≤ w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) x.denom) :=
+          mul_le_of_le_one_left' hxval
+      _ < 1 := (HeightOneSpectrum.valuation_lt_one_iff_mem w x.denom).mpr hd
+  have hmax : w.asIdeal.IsMaximal := IsPrime.to_maximal_ideal w.ne_bot
+  obtain ⟨t, ht⟩ : ∃ t : K[X], x.denom * t - 1 ∈ w.asIdeal := by
+    obtain ⟨b, c, hc, hbc⟩ := hmax.exists_inv hden
+    refine ⟨b, ?_⟩
+    rw [show x.denom * b - 1 = -c by linear_combination hbc]
+    exact neg_mem hc
+  refine ⟨x.num * t, ?_⟩
+  rw [residueOfHeightOneSpectrum_apply, ← sub_eq_zero, ← map_sub,
+    IsLocalRing.residue_eq_zero_iff, Place.mem_maximalIdeal_iff_adicValuation_lt_one]
+  change (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).adicValuation
+    (algebraMap K[X] (RatFunc K) (x.num * t) - x) < 1
+  rw [← (Place.isEquiv_adicValuation_ofHeightOneSpectrum (K := K)
+      (F := RatFunc K) w).lt_one_iff_lt_one]
+  have key : algebraMap K[X] (RatFunc K) (x.num * t) - x
+      = x * algebraMap K[X] (RatFunc K) (x.denom * t - 1) := by
+    rw [map_sub, map_mul, map_mul, map_one, mul_sub, mul_one, ← mul_assoc, hmul]
+  rw [key, map_mul]
+  calc w.valuation (RatFunc K) x
+        * w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) (x.denom * t - 1))
+      ≤ w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) (x.denom * t - 1)) :=
+        mul_le_of_le_one_left' hxval
+    _ < 1 := (HeightOneSpectrum.valuation_lt_one_iff_mem w _).mpr ht
+
+def residueFieldEquivOfHeightOneSpectrum (w : HeightOneSpectrum K[X]) :
+    (K[X] ⧸ w.asIdeal) ≃ₐ[K]
+      (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ResidueField := by
+  refine AlgEquiv.ofRingEquiv (f := (Ideal.quotEquivOfEq
+    (ker_residueOfHeightOneSpectrum K w).symm).trans
+    (RingHom.quotientKerEquivOfSurjective (surjective_residueOfHeightOneSpectrum K w))) ?_
+  intro a
+  rw [show (algebraMap K (K[X] ⧸ w.asIdeal)) a
+      = Ideal.Quotient.mk w.asIdeal (algebraMap K K[X] a) from rfl]
+  rw [RingEquiv.trans_apply, Ideal.quotEquivOfEq_mk,
+    RingHom.quotientKerEquivOfSurjective_apply_mk, residueOfHeightOneSpectrum_apply]
+  exact congrArg (IsLocalRing.residue _)
+    (Subtype.ext (IsScalarTower.algebraMap_apply K K[X] (RatFunc K) a).symm)
+
+theorem deg_ofHeightOneSpectrum {w : HeightOneSpectrum K[X]} {p : K[X]}
+    (hw : w.asIdeal = Ideal.span {p}) :
+    (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).deg = p.natDegree := by
+  rw [Place.deg, ← (residueFieldEquivOfHeightOneSpectrum K w).toLinearEquiv.finrank_eq, hw]
+  exact finrank_quotient_span_eq_natDegree
+
+theorem deg_finitePlace {p : K[X]} (hp : Irreducible p) :
+    (finitePlace K hp).deg = p.natDegree :=
+  deg_ofHeightOneSpectrum K (heightOneSpectrumOfIrreducible_asIdeal K hp)
+
+end ResidueDegree
+
+def placeOfPoint (a : K) : Place K (RatFunc K) :=
+  finitePlace K (irreducible_X_sub_C a)
+
+theorem placeOfPoint_def (a : K) :
+    placeOfPoint K a = finitePlace K (irreducible_X_sub_C a) := rfl
+
+theorem placeOfPoint_eq_ofHeightOneSpectrum (a : K) :
+    placeOfPoint K a
+      = Place.ofHeightOneSpectrum (heightOneSpectrumOfIrreducible K (irreducible_X_sub_C a)) :=
+  rfl
+
+theorem placeOfPoint_injective : Function.Injective (placeOfPoint K) := by
+  intro a b h
+  have h2 : heightOneSpectrumOfIrreducible K (irreducible_X_sub_C a)
+      = heightOneSpectrumOfIrreducible K (irreducible_X_sub_C b) :=
+    Place.ofHeightOneSpectrum_injective (K := K) (F := RatFunc K) h
+  have h3 : Ideal.span {(X : K[X]) - C a} = Ideal.span {(X : K[X]) - C b} := by
+    have := congrArg HeightOneSpectrum.asIdeal h2
+    simpa using this
+  have h4 : ((X : K[X]) - C a) ∣ (X - C b) :=
+    (Ideal.span_singleton_eq_span_singleton.mp h3).dvd
+  have h5 : (X - C b).IsRoot a := dvd_iff_isRoot.mp h4
+  have h6 : a - b = 0 := by simpa [IsRoot] using h5
+  exact sub_eq_zero.mp h6
+
+@[simp]
+theorem deg_placeOfPoint (a : K) : (placeOfPoint K a).deg = 1 := by
+  rw [placeOfPoint, deg_finitePlace, natDegree_X_sub_C]
+
+end RationalFunctionField
+
+namespace Place
+
+section Congr
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+variable (e : F ≃+* F')
+
+def comapSymmRingEquiv (V : ValuationSubring F) :
+    V ≃+* (V.comap (e.symm : F' →+* F)) where
+  toFun x := ⟨e x, by
+    rw [ValuationSubring.mem_comap]
+    change e.symm (e x) ∈ V
+    rw [e.symm_apply_apply]
+    exact x.2⟩
+  invFun y := ⟨e.symm y, y.2⟩
+  left_inv x := by
+    ext
+    exact e.symm_apply_apply x
+  right_inv y := by
+    ext
+    exact e.apply_symm_apply y
+  map_mul' x y := by
+    ext
+    exact e.map_mul x y
+  map_add' x y := by
+    ext
+    exact e.map_add x y
+
+@[simp]
+theorem coe_comapSymmRingEquiv_apply (V : ValuationSubring F) (x : V) :
+    ((comapSymmRingEquiv e V x : (V.comap (e.symm : F' →+* F))) : F') = e x := rfl
+
+variable (he : ∀ a : K, e (algebraMap K F a) = algebraMap K F' a)
+include he
+
+theorem symm_algebraMap_comm (a : K) : e.symm (algebraMap K F' a) = algebraMap K F a := by
+  rw [← he a, e.symm_apply_apply]
+
+def congrRingEquiv (v : Place K F) : Place K F' where
+  toValuationSubring := v.toValuationSubring.comap (e.symm : F' →+* F)
+  algebraMap_mem' a := by
+    rw [ValuationSubring.mem_comap]
+    change e.symm (algebraMap K F' a) ∈ v.toValuationSubring
+    rw [symm_algebraMap_comm e he a]
+    exact v.algebraMap_mem' a
+  ne_top' := fun h =>
+    v.ne_top' (SetLike.ext fun x =>
+      ⟨fun _ => ValuationSubring.mem_top x, fun _ => by
+        have hx : e x ∈ v.toValuationSubring.comap (e.symm : F' →+* F) := by
+          rw [h]
+          exact ValuationSubring.mem_top _
+        rw [ValuationSubring.mem_comap] at hx
+        have : e.symm (e x) ∈ v.toValuationSubring := hx
+        rwa [e.symm_apply_apply] at this⟩)
+  isPrincipalIdealRing' :=
+    IsPrincipalIdealRing.of_surjective
+      (comapSymmRingEquiv e v.toValuationSubring : _ ≃+* _)
+      (comapSymmRingEquiv e v.toValuationSubring).surjective
+
+@[simp]
+theorem congrRingEquiv_toValuationSubring (v : Place K F) :
+    (congrRingEquiv e he v).toValuationSubring
+      = v.toValuationSubring.comap (e.symm : F' →+* F) := rfl
+
+theorem ord_congrRingEquiv (v : Place K F) (f : F) :
+    (congrRingEquiv e he v).ord (e f) = v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ
+  have hπ' : Irreducible (comapSymmRingEquiv e v.toValuationSubring π) :=
+    (MulEquiv.irreducible_iff (comapSymmRingEquiv e v.toValuationSubring)).mpr hπ
+  have hu' : IsUnit (comapSymmRingEquiv e v.toValuationSubring (u : v.toValuationSubring)) :=
+    u.isUnit.map (comapSymmRingEquiv e v.toValuationSubring)
+  have key : e f
+      = ((hu'.unit : (v.toValuationSubring.comap (e.symm : F' →+* F))) : F')
+        * (((comapSymmRingEquiv e v.toValuationSubring π :
+            (v.toValuationSubring.comap (e.symm : F' →+* F))) : F') ^ (v.ord f)) := by
+    rw [IsUnit.unit_spec, coe_comapSymmRingEquiv_apply, coe_comapSymmRingEquiv_apply,
+      ← map_zpow₀, ← map_mul, ← hu]
+  rw [key]
+  exact (congrRingEquiv e he v).ord_unit_smul_zpow hu'.unit hπ' (v.ord f)
+
+def congrResidueAlgEquiv (v : Place K F) :
+    v.ResidueField ≃ₐ[K] (congrRingEquiv e he v).ResidueField := by
+  let f : v.toValuationSubring ≃+* (congrRingEquiv e he v).toValuationSubring :=
+    comapSymmRingEquiv e v.toValuationSubring
+  refine AlgEquiv.ofRingEquiv (f := IsLocalRing.ResidueField.mapEquiv f) ?_
+  intro a
+  have h3 : f (algebraMap K v.toValuationSubring a)
+      = algebraMap K (congrRingEquiv e he v).toValuationSubring a := by
+    ext
+    change e (algebraMap K F a) = algebraMap K F' a
+    exact he a
+  change IsLocalRing.ResidueField.mapEquiv _ (IsLocalRing.residue _ _)
+    = IsLocalRing.residue _ _
+  rw [IsLocalRing.ResidueField.mapEquiv_apply, IsLocalRing.ResidueField.map_residue]
+  exact congrArg _ h3
+
+theorem deg_congrRingEquiv (v : Place K F) : (congrRingEquiv e he v).deg = v.deg :=
+  ((congrResidueAlgEquiv e he v).toLinearEquiv.finrank_eq).symm
+
+def congrEquiv : Place K F ≃ Place K F' where
+  toFun := congrRingEquiv e he
+  invFun := congrRingEquiv e.symm (symm_algebraMap_comm e he)
+  left_inv v := by
+    ext1
+    refine SetLike.ext fun x => ?_
+    change e.symm (e.symm.symm x) ∈ v.toValuationSubring ↔ x ∈ v.toValuationSubring
+    rw [RingEquiv.symm_symm, e.symm_apply_apply]
+  right_inv v := by
+    ext1
+    refine SetLike.ext fun x => ?_
+    change e.symm.symm (e.symm x) ∈ v.toValuationSubring ↔ x ∈ v.toValuationSubring
+    rw [RingEquiv.symm_symm, e.apply_symm_apply]
+
+@[simp]
+theorem congrEquiv_apply (v : Place K F) : congrEquiv e he v = congrRingEquiv e he v := rfl
+
+@[simp]
+theorem congrEquiv_symm_apply (v : Place K F') :
+    (congrEquiv e he).symm v = congrRingEquiv e.symm (symm_algebraMap_comm e he) v := rfl
+
+end Congr
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_RegularDifferentials.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_RegularDifferentials.lean
new file mode 100644
index 0000000000..c5fa91a223
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_RegularDifferentials.lean
@@ -0,0 +1,105 @@
+/-
+Based on Prove2Me node AlgebraicCurve_RegularDifferentials
+(6fbce2f3-7d6c-547d-900c-03c3db044372) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CanonicalDivisor
+
+/-!
+# Everywhere-regular Kähler differentials of a function field
+
+Definition: `AlgebraicCurve_RegularDifferentials` (`6fbce2f3-7d6c-547d-900c-03c3db044372`), by
+Claude, 2026-09-05.
+
+Throughout, $K$ and $F$ are fields with $F$ a $K$-algebra, and a place of $F/K$ is an element of the
+project's structure `Place K F`: a valuation subring $\mathcal O_v \subseteq F$ containing the image
+of $K$, different from $F$ itself, and whose ideals are principal (so $\mathcal O_v$ is a discrete
+valuation ring, with associated order function $v.\mathrm{ord} : F \to \mathbb Z$ normalised so that
+an irreducible element has order $1$). For such a $v$, `v.dCoord` is the Kähler differential $d\pi
+\in \Omega[F\!\mid\!K]$ of a chosen irreducible element $\pi$ of $\mathcal O_v$.
+
+The module defines [`AlgebraicCurve.regularDifferentials K
+F`](../def/AlgebraicCurve_RegularDifferentials.html#L26), a $K$-submodule of $\Omega[F\!\mid\!K]$,
+whose elements are those $\omega$ such that for every place $v$ of $F/K$ there is $f \in \mathcal
+O_v$ with $\omega = f \cdot v.\mathrm{dCoord}$. Thus $\omega$ is required to be an $\mathcal
+O_v$-multiple of the differential of a uniformizer at each place simultaneously; when `v.dCoord`
+generates $\Omega[F\!\mid\!K]$ as an $F$-module, this is the condition $\mathrm{ord}_v \omega \ge
+0$. That this set is a $K$-submodule uses only that $\mathcal O_v$ is a subring containing
+$\mathrm{im}(K \to F)$. The companion lemma
+[`AlgebraicCurve.mem_regularDifferentials_iff`](../def/AlgebraicCurve_RegularDifferentials.html#L39)
+records the membership criterion in exactly this form.
+
+The module also proves
+[`AlgebraicCurve.Place.exists_ord_eq_one_and_dCoord_eq`]
+(../def/AlgebraicCurve_RegularDifferentials.html#L18):
+for each place $v$ there is $\pi \in F$ with $v.\mathrm{ord}\,\pi = 1$ and $v.\mathrm{dCoord} =
+d\pi$. This exposes, without reference to the internal choice made in defining `dCoord`, that
+`dCoord` is the differential of some element of order exactly one at $v$.
+
+No statement is made here about the dimension of `regularDifferentials K F`, about Hecke operators,
+or about $q$-expansions.
+
+**Relation to Mathlib.** Built on Mathlib's `KaehlerDifferential` module $\Omega[F\!\mid\!K]$ and on
+Mathlib's theory of valuation subrings and discrete valuation rings, but the notion of a place of
+$F/K$ and this submodule of everywhere-regular differentials are the project's own, defined in its
+own `AlgebraicCurve` namespace.
+
+**Where it is used.** For $F$ the function field of a curve over $K$, this submodule is the space of
+global regular differentials, which for modular curves is the space attached to weight-two cusp
+forms and the cotangent space of the Jacobian; it sits alongside the project's divisor, degree and
+Picard-group constructions for such function fields, which underlie the treatment of Jacobians of
+modular curves.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open KaehlerDifferential
+
+namespace AlgebraicCurve
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable {K F}
+
+theorem exists_ord_eq_one_and_dCoord_eq (v : Place K F) :
+    ∃ π : F, v.ord π = 1 ∧ v.dCoord = D K F π := by
+  refine ⟨((IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose : F), ?_, rfl⟩
+  exact v.ord_coe_irreducible
+    (IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose_spec
+
+end Place
+
+def regularDifferentials : Submodule K Ω[F⁄K] where
+  carrier := {ω | ∀ v : Place K F, ∃ f ∈ v.toValuationSubring, ω = f • v.dCoord}
+  zero_mem' v := ⟨0, v.toValuationSubring.zero_mem, by rw [zero_smul]⟩
+  add_mem' {ω η} hω hη v := by
+    obtain ⟨f, hf, rfl⟩ := hω v
+    obtain ⟨g, hg, hη'⟩ := hη v
+    exact ⟨f + g, v.toValuationSubring.add_mem _ _ hf hg, by rw [hη', add_smul]⟩
+  smul_mem' c {ω} hω v := by
+    obtain ⟨f, hf, rfl⟩ := hω v
+    refine ⟨algebraMap K F c * f, v.toValuationSubring.mul_mem _ _ (v.algebraMap_mem' c) hf, ?_⟩
+    rw [mul_smul, algebraMap_smul]
+
+variable {K F} in
+theorem mem_regularDifferentials_iff {ω : Ω[F⁄K]} :
+    ω ∈ regularDifferentials K F ↔
+      ∀ v : Place K F, ∃ f ∈ v.toValuationSubring, ω = f • v.dCoord :=
+  Iff.rfl
+
+end AlgebraicCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_Repartitions.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_Repartitions.lean
new file mode 100644
index 0000000000..db0366e8c4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_Repartitions.lean
@@ -0,0 +1,200 @@
+/-
+Based on Prove2Me node AlgebraicCurve_Repartitions
+(c6658b18-2512-5a01-9ac0-4b2e22e679b0) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+/-!
+# Repartitions, Riemann–Roch spaces and the genus
+
+Definition: `AlgebraicCurve_Repartitions` (`c6658b18-2512-5a01-9ac0-4b2e22e679b0`), by Claude,
+2026-09-05.
+
+Throughout, $F$ is a field extension of a field $K$, and a place of $F/K$ is a valuation subring of
+$F$ containing the image of $K$, different from $F$ and a principal ideal ring, hence a discrete
+valuation ring; `Place.adicValuation` is the associated $\mathbb{Z}^{m0}$-valued valuation of $F$
+and `Place.ord` is $-\log$ of it. A group of helper lemmas records the basic translation between the
+two: the valuation is $\le 1$ on the valuation subring, in particular on the image of $K$; for $f
+\neq 0$ one has $v(f) = \exp(-\operatorname{ord}_v f)$; and $v(f) \le \exp n$ holds exactly when $f
+= 0$ or $-n \le \operatorname{ord}_v f$, with the specialisations $n = 0$ and the negated form
+$\neg(v(f) \le 1) \leftrightarrow \operatorname{ord}_v f < 0$.
+
+`repartitions K F` is the $F$-subalgebra of the product $\prod_v F$ generated by those families
+$\alpha$ for which $\{v : \neg\, v(\alpha_v) \le 1\}$ is finite, i.e. the subalgebra generated by
+the families integral at all but finitely many places; membership is recorded for families with
+finitely many places where $\operatorname{ord}_v(\alpha_v) < 0$, and for families bounded by a
+divisor. For a divisor $D$ (a finitely supported integer-valued function on places) `repartitionsOf
+D` is the $K$-submodule of `repartitions K F` cut out by $v(\alpha_v) \le \exp(D v)$ for every $v$,
+equivalently $\alpha_v = 0$ or $-D v \le \operatorname{ord}_v(\alpha_v)$ at each $v$; it is monotone
+in $D$. `riemannRochSpace D` is the corresponding $K$-submodule $\{f \in F : \forall v,\ v(f) \le
+\exp(D v)\}$ of $F$, with the same $\operatorname{ord}$-form description. `principalRepartitions K
+F` is the diagonal copy of $F$ inside `repartitions K F`, viewed as a $K$-submodule; membership
+means precisely that the family is constant. Finally `H1 D` is the quotient $K$-module of
+`repartitions K F` by `repartitionsOf D ⊔ principalRepartitions K F`, and `genusFF K F` is the
+$K$-dimension of `H1 0`, so zero when that dimension is infinite.
+
+**Relation to Mathlib.** Mathlib supplies the valuation machinery used here (valuation subrings, the
+adic valuation of a height-one prime, `WithZero.exp`/`log`); the repartitions (adele) algebra, the
+spaces $L(D)$, the quotients `H1` and the genus are the project's own, built on its `Place` and
+`Divisor` notions.
+
+**Where it is used.** These definitions provide the Riemann–Roch apparatus attached to the project's
+places and divisors of $F/K$, alongside the divisor class groups `Pic`, `Pic0` and their $p$-power
+torsion on which the Abel–Jacobi counting predicate is formulated.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open WithZero
+
+namespace AlgebraicCurve
+
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+theorem adicValuation_le_one_of_mem {x : F} (hx : x ∈ v.toValuationSubring) :
+    v.adicValuation x ≤ 1 := by
+  have h := (v.adicValuation_coe ⟨x, hx⟩).trans_le
+    (v.heightOneSpectrum.intValuation_le_one ⟨x, hx⟩)
+  simpa using h
+
+theorem adicValuation_algebraMap_le_one (a : K) :
+    v.adicValuation (algebraMap K F a) ≤ 1 :=
+  v.adicValuation_le_one_of_mem (v.algebraMap_mem' a)
+
+theorem adicValuation_eq_exp_neg_ord {f : F} (hf : f ≠ 0) :
+    v.adicValuation f = exp (-v.ord f) := by
+  unfold ord
+  rw [neg_neg, exp_log (v.adicValuation_ne_zero hf)]
+
+theorem adicValuation_le_exp_iff {f : F} {n : ℤ} :
+    v.adicValuation f ≤ exp n ↔ f = 0 ∨ -n ≤ v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · simp
+  · rw [v.adicValuation_eq_exp_neg_ord hf, exp_le_exp, neg_le, or_iff_right hf]
+
+theorem adicValuation_le_one_iff {f : F} :
+    v.adicValuation f ≤ 1 ↔ f = 0 ∨ 0 ≤ v.ord f := by
+  simpa using v.adicValuation_le_exp_iff (n := 0)
+
+theorem not_adicValuation_le_one_iff {f : F} :
+    ¬v.adicValuation f ≤ 1 ↔ v.ord f < 0 := by
+  rw [v.adicValuation_le_one_iff, not_or, not_le]
+  constructor
+  · exact fun h => h.2
+  · exact fun h => ⟨fun h0 => by simp [h0] at h, h⟩
+
+end Place
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def repartitions : Subalgebra F (Place K F → F) :=
+  Algebra.adjoin F
+    {α : Place K F → F | {v : Place K F | ¬v.adicValuation (α v) ≤ 1}.Finite}
+
+variable {K F}
+
+theorem mem_repartitions_of_finite {α : Place K F → F}
+    (hα : {v : Place K F | ¬v.adicValuation (α v) ≤ 1}.Finite) :
+    α ∈ repartitions K F :=
+  Algebra.subset_adjoin hα
+
+theorem mem_repartitions_of_finite_ord {α : Place K F → F}
+    (hα : {v : Place K F | v.ord (α v) < 0}.Finite) :
+    α ∈ repartitions K F :=
+  mem_repartitions_of_finite <| by
+    rwa [show {v : Place K F | ¬v.adicValuation (α v) ≤ 1}
+        = {v : Place K F | v.ord (α v) < 0} from
+      Set.ext fun v => v.not_adicValuation_le_one_iff]
+
+theorem mem_repartitions_of_forall_le_exp (D : Divisor K F) (α : Place K F → F)
+    (h : ∀ v : Place K F, v.adicValuation (α v) ≤ exp (D v)) :
+    α ∈ repartitions K F :=
+  mem_repartitions_of_finite <| D.support.finite_toSet.subset fun v hv => by
+    rw [Finset.mem_coe, Finsupp.mem_support_iff]
+    intro hD0
+    exact hv ((h v).trans (by rw [hD0]; simp))
+
+def repartitionsOf (D : Divisor K F) : Submodule K ↥(repartitions K F) where
+  carrier :=
+    {α | ∀ v : Place K F, v.adicValuation ((α : Place K F → F) v) ≤ exp (D v)}
+  zero_mem' := by
+    intro v
+    change v.adicValuation (0 : F) ≤ exp (D v)
+    simp
+  add_mem' := by
+    intro α β hα hβ v
+    exact (Valuation.map_add _ _ _).trans (max_le (hα v) (hβ v))
+  smul_mem' := by
+    intro c α hα v
+    change v.adicValuation (c • (α : Place K F → F) v) ≤ exp (D v)
+    rw [Algebra.smul_def, map_mul]
+    exact (mul_le_of_le_one_left' (v.adicValuation_algebraMap_le_one c)).trans (hα v)
+
+theorem mem_repartitionsOf_iff {D : Divisor K F} {α : ↥(repartitions K F)} :
+    α ∈ repartitionsOf D ↔
+      ∀ v : Place K F,
+        (α : Place K F → F) v = 0 ∨ -D v ≤ v.ord ((α : Place K F → F) v) := by
+  change (∀ v : Place K F, v.adicValuation ((α : Place K F → F) v) ≤ exp (D v)) ↔ _
+  exact forall_congr' fun v => v.adicValuation_le_exp_iff
+
+theorem repartitionsOf_mono {D D' : Divisor K F} (h : D ≤ D') :
+    repartitionsOf D ≤ repartitionsOf D' := fun _ hα v =>
+  (hα v).trans (exp_le_exp.mpr (Finsupp.le_def.mp h v))
+
+def riemannRochSpace (D : Divisor K F) : Submodule K F where
+  carrier := {f | ∀ v : Place K F, v.adicValuation f ≤ exp (D v)}
+  zero_mem' := by
+    intro v
+    simp
+  add_mem' := by
+    intro f g hf hg v
+    exact (Valuation.map_add _ _ _).trans (max_le (hf v) (hg v))
+  smul_mem' := by
+    intro c f hf v
+    change v.adicValuation (c • f) ≤ exp (D v)
+    rw [Algebra.smul_def, map_mul]
+    exact (mul_le_of_le_one_left' (v.adicValuation_algebraMap_le_one c)).trans (hf v)
+
+theorem mem_riemannRochSpace_iff {D : Divisor K F} {f : F} :
+    f ∈ riemannRochSpace D ↔ ∀ v : Place K F, f = 0 ∨ -D v ≤ v.ord f := by
+  change (∀ v : Place K F, v.adicValuation f ≤ exp (D v)) ↔ _
+  exact forall_congr' fun v => v.adicValuation_le_exp_iff
+
+variable (K F) in
+def principalRepartitions : Submodule K ↥(repartitions K F) :=
+  (LinearMap.range (Algebra.linearMap F ↥(repartitions K F))).restrictScalars K
+
+theorem mem_principalRepartitions_iff {α : ↥(repartitions K F)} :
+    α ∈ principalRepartitions K F ↔
+      ∃ f : F, (α : Place K F → F) = fun _ => f := by
+  simp only [principalRepartitions, Submodule.restrictScalars_mem, LinearMap.mem_range,
+    Algebra.linearMap_apply]
+  constructor
+  · rintro ⟨f, rfl⟩
+    exact ⟨f, rfl⟩
+  · rintro ⟨f, hf⟩
+    exact ⟨f, Subtype.ext hf.symm⟩
+
+abbrev H1 (D : Divisor K F) : Type _ :=
+  ↥(repartitions K F) ⧸ (repartitionsOf D ⊔ principalRepartitions K F)
+
+variable (K F) in
+def genusFF : ℕ := Module.finrank K (H1 (0 : Divisor K F))
+
+end AlgebraicCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_RiemannRochRows.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_RiemannRochRows.lean
new file mode 100644
index 0000000000..070e452a8b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_RiemannRochRows.lean
@@ -0,0 +1,118 @@
+/-
+Based on Prove2Me node AlgebraicCurve_RiemannRochRows
+(90ed69fe-fa05-5464-88c3-c4394623f621) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_CanonicalDivisor
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+/-!
+# Riemann–Roch rows for function fields: named statements
+
+Definition: `AlgebraicCurve_RiemannRochRows` (`90ed69fe-fa05-5464-88c3-c4394623f621`), by Claude,
+2026-09-05.
+
+For a field extension $F/K$ this module names, as `Prop`-valued statements, the successive rows of
+the Riemann–Roch programme; none of them is asserted here. Each of the six definitions quantifies
+internally over the curve hypotheses: `IsCurveOver K F` (existence of principal divisors, residue
+field $K$-finite at every place, and $\Omega[F/K]$ free of rank one over $F$), `HasCanonicalDivisor`
+(every nonzero $\omega\in\Omega[F/K]$ has a finitely supported divisor with coefficient
+$v.\mathrm{ordDifferential}\,\omega$ at each place $v$), and for the duality rows the condition that
+every place's chosen differential $d\pi_v$ spans $\Omega[F/K]$ over $F$. Throughout, $\ell(D)=\dim_K
+L(D)$ with $L(D)=\{f\in F:\ v(f)\le \exp(D v)\text{ for all }v\}$, the index of specialty $i(D)$ is
+the $K$-dimension of the quotient of the adele space by the sum of the $D$-bounded adeles and the
+diagonal copy of $F$, $\Omega(D)$ is the annihilator of that sum in the $K$-dual of the adele space,
+$(\omega)$ is `canonicalDivisorOf` applied to a nonzero differential, and $g$ is the genus defined
+as $\lfloor(\deg(\omega)+2)^{+}/2\rfloor$ for a chosen nonzero differential.
+
+The rows are: `RiemannInequality`, $\deg D+1-g\le\ell(D)$; `RiemannIndexFormula`,
+$i(D)=\ell(D)-(\deg D+1-g)$; `WeilDualityAdelic`, $i(D)=\ell((\omega)-D)$; `WeilDuality`,
+$\ell(D)-(\deg D+1-g)=\ell((\omega)-D)$; `WeilOmegaEllAgrees`, $\dim_K\Omega(D)=\ell((\omega)-D)$
+(the imported identity $\dim_K\Omega(D)=i(D)$ makes this a restatement of the previous row); and
+`FunctionFieldRiemannRoch`, $\ell(D)-\ell((\omega)-D)=\deg D+1-g$, each for all divisors $D$ and all
+nonzero $\omega$. Two short theorems record the linear rearrangements between them:
+`FunctionFieldRiemannRoch` follows from `WeilDuality`, and `WeilDuality` from `RiemannIndexFormula`
+together with `WeilDualityAdelic`. The constant $1$ in these rows is the one appropriate when $K$ is
+the full field of constants.
+
+**Relation to Mathlib.** Mathlib has no Riemann–Roch theorem for function fields; the vocabulary
+used here (places as valuation subrings, divisors, $L$-spaces, adeles, index of specialty, canonical
+divisor and genus) is the project's own, built on Mathlib's valuation subrings, adic valuations of
+Dedekind domains and Kähler differentials.
+
+**Where it is used.** These named rows are the interface through which downstream statements about
+curves and their function fields — in particular modular curves — may take Riemann–Roch, Weil
+duality or the Riemann inequality as an explicit hypothesis rather than re-deriving it.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open KaehlerDifferential
+
+namespace AlgebraicCurve
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def RiemannInequality : Prop :=
+  ∀ [IsCurveOver K F] [HasCanonicalDivisor (K := K) (F := F)],
+    ∀ D : Divisor K F, Divisor.degree D + 1 - (genus K F : ℤ) ≤ (ell D : ℤ)
+
+def RiemannIndexFormula : Prop :=
+  ∀ [IsCurveOver K F] [HasCanonicalDivisor (K := K) (F := F)],
+    ∀ D : Divisor K F,
+      (indexOfSpecialty D : ℤ) = (ell D : ℤ) - (Divisor.degree D + 1 - (genus K F : ℤ))
+
+def WeilDualityAdelic : Prop :=
+  ∀ [IsCurveOver K F] [HasCanonicalDivisor (K := K) (F := F)]
+    [∀ v : Place K F, v.DCoordGenerates],
+    ∀ {ω : Ω[F⁄K]} (hω : ω ≠ 0) (D : Divisor K F),
+      (indexOfSpecialty D : ℤ) = (ell (canonicalDivisorOf hω - D) : ℤ)
+
+def WeilDuality : Prop :=
+  ∀ [IsCurveOver K F] [HasCanonicalDivisor (K := K) (F := F)]
+    [∀ v : Place K F, v.DCoordGenerates],
+    ∀ {ω : Ω[F⁄K]} (hω : ω ≠ 0) (D : Divisor K F),
+      (ell D : ℤ) - (Divisor.degree D + 1 - (genus K F : ℤ))
+        = (ell (canonicalDivisorOf hω - D) : ℤ)
+
+def WeilOmegaEllAgrees : Prop :=
+  ∀ [IsCurveOver K F] [HasCanonicalDivisor (K := K) (F := F)]
+    [∀ v : Place K F, v.DCoordGenerates],
+    ∀ {ω : Ω[F⁄K]} (hω : ω ≠ 0) (D : Divisor K F),
+      (Module.finrank K ↥(omegaSpace D) : ℤ) = (ell (canonicalDivisorOf hω - D) : ℤ)
+
+def FunctionFieldRiemannRoch : Prop :=
+  ∀ [IsCurveOver K F] [HasCanonicalDivisor (K := K) (F := F)]
+    [∀ v : Place K F, v.DCoordGenerates],
+    ∀ {ω : Ω[F⁄K]} (hω : ω ≠ 0) (D : Divisor K F),
+      (ell D : ℤ) - (ell (canonicalDivisorOf hω - D) : ℤ)
+        = Divisor.degree D + 1 - (genus K F : ℤ)
+
+theorem functionFieldRiemannRoch_of_riemann_and_duality
+    (hWD : WeilDuality K F) : FunctionFieldRiemannRoch K F := by
+  intro _ _ _ ω hω D
+  linarith [hWD hω D]
+
+theorem weilDuality_of_riemannIndex_of_adelic
+    (hRI : RiemannIndexFormula K F) (hWD : WeilDualityAdelic K F) :
+    WeilDuality K F := by
+  intro _ _ _ ω hω D
+  have h1 := hRI D
+  have h2 := hWD hω D
+  linarith
+
+end AlgebraicCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_TateResidueCurrency.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_TateResidueCurrency.lean
new file mode 100644
index 0000000000..4e80586ca4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_TateResidueCurrency.lean
@@ -0,0 +1,470 @@
+/-
+Based on Prove2Me node AlgebraicCurve_TateResidueCurrency
+(35d75f9d-aa25-58cf-9143-abc1acade7fe) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_LocalResidue
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceCompletion
+
+/-!
+# Tate's abstract residue and cotrace–residue identities
+
+Definition: `AlgebraicCurve_TateResidueCurrency` (`35d75f9d-aa25-58cf-9143-abc1acade7fe`), by
+Claude, 2026-09-05.
+
+Throughout, a `Place` of an extension $F/K$ is a valuation subring of $F$ containing the image of
+$K$, proper in $F$ and a principal ideal ring, hence a discrete valuation ring, with associated
+order function `ord`, residue field and uniformizer.
+
+The first group of definitions sets up Tate's construction over a base field $K$. For a $K$-linear
+endomorphism $\varphi$ of a $K$-vector space whose image is finite dimensional, `finrankTrace` is
+the trace of $\varphi$ restricted to $\operatorname{range}\varphi$. For three endomorphisms,
+`tateComm pA φ ψ` is the composite $p_A\varphi p_A\psi - p_A\psi p_A\varphi$ (in diagrammatic order
+as written); its values lie in $\operatorname{range} p_A$, it is antisymmetric in $\varphi,\psi$,
+and `tateCommRestrict` is the induced endomorphism of $\operatorname{range} p_A$, whose
+`finrankTrace` is `tateCommTrace`. When $\varphi\psi=\psi\varphi$, `tateComm_eq_of_commute` rewrites
+the commutator as $p_A\psi(\varphi a-p_A\varphi a)-p_A\varphi(\psi a-p_A\psi a)$. For a place $u$ of
+$L/K$, `adicIntegersKSubmod` is the ring of integers of the completion $\hat L_u$ viewed as a
+$K$-submodule, `tateProj` is the projection of $\hat L_u$ onto it along a chosen complement, `lmulK`
+is multiplication by an element of $\hat L_u$ as a $K$-endomorphism, and `tateRes u fh gh` is
+`tateCommTrace` of the two multiplication operators against this projector, defined when the
+relevant range is finite dimensional.
+
+Four `Prop`-valued predicates record the expected properties: `KwF4gRRTateCommFinite` (that
+finiteness always holds), `KwF4gRRTateAgreement` (`tateRes` against a uniformizer equals the
+$K$-trace from the residue field of `kwHgfV352_localResidueCompletion`, the local residue of an
+integral approximant of an element of the completion), `KwF4gRRTateChainRule` (replacing a
+uniformizer pulled back from $E$ by the uniformizer at $w$ at the cost of multiplying by the
+differential coefficient of the pullback of $v$'s $\mathrm{d}$-coordinate), and
+`KwF4gRRTateTraceCompat` (compatibility with `kwHgfV352_completionTraceAt`, the local trace of $g\in
+F$ at $w\mid v$ read in $\hat E_v$).
+
+The remaining predicates concern Kähler differentials: `kaehlerPullback` and `kaehlerCotrace` are
+`KaehlerDifferential.map K K E F` applied to an element, resp. as an $E$-linear map
+$\Omega_{E/K}\to\Omega_{F/K}$; `Place.regularSubmodule w ωF` is the $K$-submodule of $f\in F$ with
+$f\cdot w.\mathrm{differentialCoeff}\,\omega_F$ in the valuation ring at $w$.
+`KwHgfV352CompletionTraceSum` asserts that the image of $\mathrm{Tr}_{F/E}g$ in $\hat E_v$ is the
+sum of the local completion traces over the fibre of $v$; `KwHgfV352R3MPGKPowBasisLocal` asserts the
+corresponding residue-term identity for the elements $\theta^j(\pi^{k+1})^{-1}$ of a local power
+basis, and `KwF4R1V391aResidueTraceCompletionCommute` the same identity for arbitrary $g\in F$ with
+$\omega_E=v.\mathrm{dCoord}$. Finally `FiberKaehlerCotraceResidueIdentityK` asserts that, given
+canonical local residue data at each place of $F$ and a nonzero $\omega_E$ with nonzero pullback,
+there is a family of such data at the places of $E$ for which the sum of residue terms over the
+fibre of $v$ equals the residue term of $\omega_E$ at the trace $\mathrm{Tr}_{F/E}f$;
+`CotraceResidueIdentityOnFiberLocalizedK` is the variant restricted to those $p\in F$ failing to lie
+in `regularSubmodule` at at most one place of the fibre.
+
+**Relation to Mathlib.** The trace, the module of Kähler differentials and the functoriality map
+`KaehlerDifferential.map` are Mathlib's; `Place`, the places' completions and all residue notions,
+as well as Tate's commutator residue, are the project's own.
+
+**Where it is used.** These definitions organise the proof of the residue theorem for function
+fields along Tate's route, which underlies the Riemann–Roch theory used for modular curves and their
+Jacobians in the Frey curve argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open LinearMap Submodule
+
+noncomputable section
+
+namespace ModularCurve.KwF4gRRTate
+
+section FinrankTrace
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+def finrankTrace (φ : V →ₗ[K] V) [FiniteDimensional K (LinearMap.range φ)] : K :=
+  LinearMap.trace K (LinearMap.range φ)
+    (φ.restrict (fun x _ => LinearMap.mem_range_self φ x))
+
+end FinrankTrace
+
+section TateComm
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+def tateComm (pA φ ψ : V →ₗ[K] V) : V →ₗ[K] V :=
+  pA ∘ₗ φ ∘ₗ pA ∘ₗ ψ - pA ∘ₗ ψ ∘ₗ pA ∘ₗ φ
+
+theorem tateComm_apply (pA φ ψ : V →ₗ[K] V) (x : V) :
+    tateComm pA φ ψ x = pA (φ (pA (ψ x))) - pA (ψ (pA (φ x))) := rfl
+
+theorem tateComm_mem_range (pA φ ψ : V →ₗ[K] V) (x : V) :
+    tateComm pA φ ψ x ∈ LinearMap.range pA :=
+  sub_mem (LinearMap.mem_range_self pA _) (LinearMap.mem_range_self pA _)
+
+theorem tateComm_antisymm (pA φ ψ : V →ₗ[K] V) :
+    tateComm pA φ ψ = - tateComm pA ψ φ := by
+  unfold tateComm; rw [neg_sub]
+
+def tateCommRestrict (pA φ ψ : V →ₗ[K] V) :
+    LinearMap.range pA →ₗ[K] LinearMap.range pA :=
+  (tateComm pA φ ψ).restrict (fun x _ => tateComm_mem_range pA φ ψ x)
+
+theorem tateCommRestrict_apply (pA φ ψ : V →ₗ[K] V) (a : LinearMap.range pA) :
+    (tateCommRestrict pA φ ψ a : V) = tateComm pA φ ψ (a : V) := rfl
+
+def tateCommTrace (pA φ ψ : V →ₗ[K] V)
+    [FiniteDimensional K (LinearMap.range (tateCommRestrict pA φ ψ))] : K :=
+  finrankTrace (tateCommRestrict pA φ ψ)
+
+end TateComm
+
+section TateFactoring
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+theorem tateComm_eq_of_commute {pA φ ψ : V →ₗ[K] V}
+    (hcomm : φ ∘ₗ ψ = ψ ∘ₗ φ) (a : V) :
+    tateComm pA φ ψ a
+      = pA (ψ (φ a - pA (φ a))) - pA (φ (ψ a - pA (ψ a))) := by
+  have hφψ : φ (ψ a) = ψ (φ a) := by
+    have := congrArg (fun f => f a) (congrArg DFunLike.coe hcomm)
+    simpa using this
+  rw [tateComm_apply, map_sub, map_sub, map_sub, map_sub, hφψ]
+  abel
+
+end TateFactoring
+
+end ModularCurve.KwF4gRRTate
+
+end
+
+noncomputable section
+
+open IsDedekindDomain WithZero Module IsLocalRing
+
+namespace AlgebraicCurve
+
+section CorrectedCarrier
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+variable (E : Type*) [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+
+def kaehlerPullback (ωE : Ω[E⁄K]) : Ω[F⁄K] :=
+  KaehlerDifferential.map K K E F ωE
+
+end CorrectedCarrier
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open IsDedekindDomain WithZero Module IsLocalRing
+
+namespace AlgebraicCurve
+
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+def regularSubmodule (w : Place K F) (ωF : Ω[F⁄K]) : Submodule K F where
+  carrier := {f : F | f * w.differentialCoeff ωF ∈ w.toValuationSubring}
+  zero_mem' := by simp only [Set.mem_ofPred_eq, zero_mul]; exact zero_mem _
+  add_mem' {f g} hf hg := by
+    simp only [Set.mem_ofPred_eq, add_mul]; exact add_mem hf hg
+  smul_mem' c f hf := by
+    simp only [Set.mem_ofPred_eq, Algebra.smul_def, mul_assoc]
+    exact mul_mem (w.algebraMap_mem' c) hf
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open IsDedekindDomain WithZero Module IsLocalRing
+
+namespace AlgebraicCurve
+
+section KaehlerCotrace
+
+variable (K E F : Type*) [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+
+abbrev kaehlerCotrace : Ω[E⁄K] →ₗ[E] Ω[F⁄K] :=
+  KaehlerDifferential.map K K E F
+
+end KaehlerCotrace
+
+end AlgebraicCurve
+
+end
+
+open AlgebraicCurve AlgebraicCurve.Place IsDedekindDomain
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+section LocalResidueCompletion
+
+variable {K E : Type*} [Field K] [Field E] [Algebra K E]
+
+variable [HasCanonicalLocalResidueKStar K E]
+
+def kwHgfV352_localResidueCompletion (v : Place K E) (xh : v.adicCompletion) :
+    v.ResidueField :=
+  v.localResidue (kwHgfV352_exists_sub_mem_adicCompletionIntegers v xh).choose
+
+end LocalResidueCompletion
+
+section CompletionTraceAt
+
+variable {K : Type*} [Field K] {F : Type*} [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F] [HasPrincipalDivisors K E] [HasPrincipalDivisors K F]
+
+def kwHgfV352_completionTraceAt [FiniteDimensional E F]
+    (v : Place K E) (w' : Place K F) (hw' : w' ∈ v.fiber F) (g : F) :
+    v.adicCompletion :=
+  Place.mem_fiber.mp hw' ▸ kw_ffgc_completionTraceF' E w' g
+
+end CompletionTraceAt
+
+section MPGKPowBasisLocalMint
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+variable (E : Type*) [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [HasCanonicalLocalResidueKStar K E] [HasCanonicalLocalResidueKStar K F]
+variable [Algebra.IsIntegral E F]
+
+def KwHgfV352R3MPGKPowBasisLocal : Prop :=
+  ∀ [HasPrincipalDivisors K E] [HasPrincipalDivisors K F] [∀ w : Place K F, w.FiniteResidue]
+    [FiniteDimensional E F]
+    {ωE : Ω[E⁄K]} (_ : ωE ≠ 0) (_ : kaehlerPullback K F E ωE ≠ 0)
+    (v : Place K E) (w : Place K F) (hw : w ∈ v.fiber F)
+    (_ : ∀ w'' ∈ v.fiber F,
+      w''.differentialCoeff (kaehlerPullback K F E ωE) ∈ w''.toValuationSubring)
+    (θ : F) (_ : ∀ w' ∈ v.fiber F, θ ∈ w'.toValuationSubring)
+    (π : F) (_ : π ≠ 0) (_ : w.ord π = 1)
+    (_ : ∀ w' ∈ v.fiber F, w' ≠ w → w'.ord π = 0)
+    (j : ℕ) (_ : j < Module.finrank K w.ResidueField) (k : ℕ),
+    kaehlerResidueTerm (kaehlerPullback K F E ωE)
+        (diagonalHom K F (θ ^ j * (π ^ (k + 1))⁻¹)) w
+      = Algebra.trace K v.ResidueField
+          (kwHgfV352_localResidueCompletion v
+            (kwHgfV352_completionTraceAt v w hw (θ ^ j * (π ^ (k + 1))⁻¹)
+              * algebraMap E v.adicCompletion (v.differentialCoeff ωE)))
+
+end MPGKPowBasisLocalMint
+
+section CompletionTraceSumMint
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+variable (E : Type*) [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+def KwHgfV352CompletionTraceSum : Prop :=
+  ∀ [HasPrincipalDivisors K E] [HasPrincipalDivisors K F] [FiniteDimensional E F]
+    (v : Place K E) (g : F),
+    algebraMap E v.adicCompletion (Algebra.trace E F g)
+      = ∑ w' ∈ (v.fiber F).attach, kwHgfV352_completionTraceAt v w'.1 w'.2 g
+
+end CompletionTraceSumMint
+
+end AlgebraicCurve
+
+open AlgebraicCurve AlgebraicCurve.Place LinearMap Submodule
+open ModularCurve.KwF4gRRTate
+
+section
+
+namespace ModularCurve.KwF4gRRTate
+
+section TateProj
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+def adicIntegersKSubmod : Submodule K u.adicCompletion where
+  carrier := u.adicCompletionIntegers
+  add_mem' := add_mem
+  zero_mem' := zero_mem _
+  smul_mem' c x hx := by
+    rw [Algebra.smul_def]
+    exact mul_mem (by
+      rw [IsScalarTower.algebraMap_apply K L u.adicCompletion]
+      exact (kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff u _).mpr
+        (u.algebraMap_mem' c)) hx
+
+def tateProj : u.adicCompletion →ₗ[K] u.adicCompletion :=
+  letI B := Classical.choose (Submodule.exists_isCompl (adicIntegersKSubmod u))
+  (adicIntegersKSubmod u).subtype ∘ₗ
+    Submodule.projectionOnto (adicIntegersKSubmod u) B
+      (Classical.choose_spec (Submodule.exists_isCompl (adicIntegersKSubmod u)))
+
+end TateProj
+
+section TateResDef
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+abbrev lmulK (fh : u.adicCompletion) : u.adicCompletion →ₗ[K] u.adicCompletion :=
+  (Algebra.lmul K u.adicCompletion) fh
+
+def tateRes (fh gh : u.adicCompletion)
+    [FiniteDimensional K (LinearMap.range
+      (tateCommRestrict (tateProj u) (lmulK u fh) (lmulK u gh)))] : K :=
+  tateCommTrace (tateProj u) (lmulK u fh) (lmulK u gh)
+
+end TateResDef
+
+section TateAtoms
+
+variable (K L : Type*) [Field K] [Field L] [Algebra K L]
+
+def KwF4gRRTateCommFinite : Prop :=
+  ∀ (u : Place K L) (fh gh : u.adicCompletion),
+    FiniteDimensional K (LinearMap.range
+      (tateCommRestrict (tateProj u) (lmulK u fh) (lmulK u gh)))
+
+variable [HasCanonicalLocalResidueKStar K L]
+
+def KwF4gRRTateAgreement (hfin : KwF4gRRTateCommFinite K L) : Prop :=
+  ∀ (u : Place K L) [u.FiniteResidue] (fh : u.adicCompletion),
+    haveI := hfin u fh (algebraMap L u.adicCompletion u.uniformizer)
+    tateRes u fh (algebraMap L u.adicCompletion u.uniformizer)
+      = Algebra.trace K u.ResidueField (kwHgfV352_localResidueCompletion u fh)
+
+variable (F E : Type*) [Field F] [Algebra K F] [Field E] [Algebra K E]
+variable [Algebra E F] [IsScalarTower K E F] [Algebra.IsIntegral E F]
+variable [HasCanonicalLocalResidueKStar K F] [HasCanonicalLocalResidueKStar K E]
+
+def KwF4gRRTateChainRule (hfinF : KwF4gRRTateCommFinite K F) : Prop :=
+  ∀ [HasPrincipalDivisors K E] [HasPrincipalDivisors K F] [FiniteDimensional E F]
+    [Nontrivial Ω[E⁄K]] [Nontrivial Ω[F⁄K]]
+    (v : Place K E) [v.DCoordGenerates] (w : Place K F) [w.DCoordGenerates]
+    (_ : w ∈ v.fiber F) (fh : w.adicCompletion),
+    haveI := hfinF w fh (algebraMap F w.adicCompletion (algebraMap E F v.uniformizer))
+    haveI := hfinF w (fh * algebraMap F w.adicCompletion
+      (w.differentialCoeff (kaehlerPullback K F E v.dCoord)))
+      (algebraMap F w.adicCompletion w.uniformizer)
+    tateRes w fh (algebraMap F w.adicCompletion (algebraMap E F v.uniformizer))
+      = tateRes w (fh * algebraMap F w.adicCompletion
+          (w.differentialCoeff (kaehlerPullback K F E v.dCoord)))
+          (algebraMap F w.adicCompletion w.uniformizer)
+
+def KwF4gRRTateTraceCompat (hfinF : KwF4gRRTateCommFinite K F)
+    (hfinE : KwF4gRRTateCommFinite K E) : Prop :=
+  ∀ [HasPrincipalDivisors K E] [HasPrincipalDivisors K F] [FiniteDimensional E F]
+    (v : Place K E) (w : Place K F) (hw : w ∈ v.fiber F) (g : F),
+    haveI := hfinF w (algebraMap F w.adicCompletion g)
+      (algebraMap F w.adicCompletion (algebraMap E F v.uniformizer))
+    haveI := hfinE v (kwHgfV352_completionTraceAt v w hw g)
+      (algebraMap E v.adicCompletion v.uniformizer)
+    tateRes w (algebraMap F w.adicCompletion g)
+        (algebraMap F w.adicCompletion (algebraMap E F v.uniformizer))
+      = tateRes v (kwHgfV352_completionTraceAt v w hw g)
+          (algebraMap E v.adicCompletion v.uniformizer)
+
+end TateAtoms
+
+end ModularCurve.KwF4gRRTate
+
+end
+
+open AlgebraicCurve AlgebraicCurve.Place KaehlerDifferential
+
+section
+
+namespace ModularCurve.KwF4R1V391a
+
+section Mint
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+variable (E : Type*) [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+variable [HasCanonicalLocalResidueKStar K E] [HasCanonicalLocalResidueKStar K F]
+
+def KwF4R1V391aResidueTraceCompletionCommute
+    [HasPrincipalDivisors K E] [HasPrincipalDivisors K F] : Prop :=
+  ∀ [∀ w : Place K F, w.FiniteResidue] [FiniteDimensional E F]
+    [Nontrivial Ω[E⁄K]] (v : Place K E) [v.DCoordGenerates]
+    (w : Place K F) [w.DCoordGenerates] (_ : w ∈ v.fiber F) (g : F),
+    kaehlerResidueTerm (kaehlerPullback K F E v.dCoord) (diagonalHom K F g) w
+      = Algebra.trace K v.ResidueField
+          (kwHgfV352_localResidueCompletion v
+            (kwHgfV352_completionTraceAt v w ‹w ∈ v.fiber F› g))
+
+end Mint
+
+end ModularCurve.KwF4R1V391a
+
+section
+
+namespace AlgebraicCurve
+
+open scoped Polynomial
+
+section KCurrencyRow
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+variable (E : Type*) [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [HasCanonicalLocalResidueKStar K E] [HasCanonicalLocalResidueKStar K F]
+variable [Algebra.IsIntegral E F]
+
+def FiberKaehlerCotraceResidueIdentityK : Prop :=
+  ∀ [HasPrincipalDivisors K E] [HasPrincipalDivisors K F]
+    (RfamF : ∀ w : Place K F, w.CanonicalLocalResidueDataK)
+    {ωE : Ω[E⁄K]} (_ : ωE ≠ 0) (_ : kaehlerPullback K F E ωE ≠ 0),
+    ∃ RfamE : ∀ v : Place K E, v.CanonicalLocalResidueDataK,
+      ∀ (v : Place K E) (f : F),
+        ∑ w ∈ v.fiber F, kaehlerResidueTermKFam RfamF (kaehlerPullback K F E ωE)
+            (diagonalHom K F f) w
+          = kaehlerResidueTermKFam RfamE ωE (diagonalHom K E (Algebra.trace E F f)) v
+
+end KCurrencyRow
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+open scoped Polynomial
+
+section KCurrencyRowA
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+variable (E : Type*) [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [HasCanonicalLocalResidueKStar K E] [HasCanonicalLocalResidueKStar K F]
+variable [Algebra.IsIntegral E F]
+
+def CotraceResidueIdentityOnFiberLocalizedK : Prop :=
+  ∀ [HasPrincipalDivisors K E] [HasPrincipalDivisors K F]
+    (RfamF : ∀ w : Place K F, w.CanonicalLocalResidueDataK)
+    {ωE : Ω[E⁄K]} (_ : ωE ≠ 0) (_ : kaehlerPullback K F E ωE ≠ 0),
+    ∃ RfamE : ∀ v : Place K E, v.CanonicalLocalResidueDataK,
+      ∀ (v : Place K E) (p : F),
+        (∀ w₁ ∈ v.fiber F, ∀ w₂ ∈ v.fiber F,
+          p ∉ w₁.regularSubmodule (kaehlerPullback K F E ωE) →
+          p ∉ w₂.regularSubmodule (kaehlerPullback K F E ωE) → w₁ = w₂) →
+        ∑ w ∈ v.fiber F, kaehlerResidueTermKFam RfamF (kaehlerPullback K F E ωE)
+            (diagonalHom K F p) w
+          = kaehlerResidueTermKFam RfamE ωE (diagonalHom K E (Algebra.trace E F p)) v
+
+end KCurrencyRowA
+
+end AlgebraicCurve
+
+end
+
+end
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_WeilOfKaehler.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_WeilOfKaehler.lean
new file mode 100644
index 0000000000..f3f2c80f1b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AlgebraicCurve_WeilOfKaehler.lean
@@ -0,0 +1,178 @@
+/-
+Based on Prove2Me node AlgebraicCurve_WeilOfKaehler
+(fb3e70f4-0b96-5310-bd7f-172f850356e7) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_LocalResidue
+public import Mathlib.RingTheory.Etale.Weakly
+public import Mathlib.RingTheory.TotallySplit
+
+/-!
+# Traced Kähler residue functional on adèles; residue-theorem predicates
+
+Definition: `AlgebraicCurve_WeilOfKaehler` (`fb3e70f4-0b96-5310-bd7f-172f850356e7`), by Claude,
+2026-09-05.
+
+Throughout, $F$ is a field extension of a field $K$ equipped with a chosen family of canonical local
+residue data $\mathrm{res}_v : F \to_{K} \kappa(v)$ at every place $v$ (each $K$-linear, vanishing
+on the valuation subring, computing simple poles via the residue of $\pi_v f$, and killing
+$\pi_v^{-(n+1)}$ for $n \ge 1$), with the standing assumptions that every nonzero $\omega \in
+\Omega_{F/K}$ has a canonical divisor, that $d\pi_v$ spans $\Omega_{F/K}$ over $F$ at each place,
+and that $\Omega_{F/K}$ is nontrivial. For such $\omega$ the local term is
+$\mathrm{Tr}_{\kappa(v)/K}\bigl(\mathrm{res}_v(\alpha_v \cdot g_v(\omega))\bigr)$, where
+$g_v(\omega)$ is the coefficient with $\omega = g_v(\omega)\, d\pi_v$. The first group of results
+shows this term vanishes at every place when $\alpha$ lies in the bounded adèles $\mathrm{adeleBdd}$
+of $\mathrm{canonicalDivisorOf}\ h\omega$ (the divisor $v \mapsto \mathrm{ord}_v g_v(\omega)$), that
+for $\alpha$ bounded by $D$ the terms are supported in the finite support of $D -
+\mathrm{canonicalDivisorOf}\ h\omega$, and hence that the support is finite for any adèle.
+
+`weilOfKaehler K F hω` is then the element of $\mathrm{Dual}_K(\mathbb{A}_F)$ sending an adèle
+$\alpha$ to the finitely supported sum $\sum_v \mathrm{Tr}_{\kappa(v)/K}(\mathrm{res}_v(\alpha_v
+g_v(\omega)))$; it vanishes on adèles bounded by the canonical divisor. Three further declarations
+are Prop-valued statements, asserting nothing by themselves: `ResidueTheorem K F` says that, given
+principal divisors, this functional kills every diagonal (global) adèle $f \in F$; `WeilKaehlerAgree
+K F` says it is nonzero, lies in $\mathrm{omegaSpace}(\mathrm{canonicalDivisorOf}\ h\omega)$, and
+that $\mathrm{canonicalDivisorOf}\ h\omega$ is maximal among divisors $D$ with the functional in
+$\mathrm{omegaSpace}\ D$; `ResiduePairingSurjective K F` says that for divisors $W, D$ and a nonzero
+$\varphi \in \mathrm{omegaSpace}\ W$ whose bounding divisor $W$ is maximal, the map
+$\mathrm{residuePairing}$ from $L(W-D)$ to $\mathrm{omegaSpace}\ D$, $g \mapsto g\varphi$, is
+surjective.
+
+**Relation to Mathlib.** Mathlib supplies $\Omega_{F/K}$ (`KaehlerDifferential`) and `Module.Dual`;
+the places, divisors, adèle spaces, local residues and Weil differentials used here are the
+project's own notions.
+
+**Where it is used.** These definitions form the residue-theoretic bridge between Kähler
+differentials and Weil differentials for a function field over a not necessarily algebraically
+closed base, the per-place trace allowing places of arbitrary residue degree. They feed the adelic
+Riemann–Roch machinery applied to function fields of modular curves.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open IsDedekindDomain WithZero Module IsLocalRing
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+variable [HasCanonicalLocalResidueKStar K F]
+
+theorem kaehlerResidueTerm_eq_zero_of_adeleBdd_canonical
+    [HasCanonicalDivisor (K := K) (F := F)] [∀ v : Place K F, v.DCoordGenerates]
+    [Nontrivial Ω[F⁄K]] {ω : Ω[F⁄K]} (hω : ω ≠ 0)
+    {α : Place K F → F} (hα : α ∈ adeleBdd (canonicalDivisorOf hω)) (v : Place K F) :
+    kaehlerResidueTerm ω α v = 0 := by
+  refine kaehlerResidueTerm_eq_zero_of_ord_nonneg ?_
+  rcases eq_or_ne (α v) 0 with h0 | h0
+  · exact Or.inl (by rw [h0, zero_mul])
+  · refine Or.inr ?_
+    have hg := v.differentialCoeff_ne_zero hω
+    rw [v.ord_mul h0 hg]
+    have hαv : -(canonicalDivisorOf hω v) ≤ v.ord (α v) := by
+      have hval := hα v
+      rw [v.adicValuation_eq_exp_neg_ord h0] at hval
+      exact neg_le_of_neg_le (WithZero.exp_le_exp.mp hval)
+    rw [canonicalDivisorOf_apply hω v, Place.ordDifferential] at hαv
+    linarith
+
+theorem kaehlerResidueTerm_support_subset
+    [HasCanonicalDivisor (K := K) (F := F)] [∀ v : Place K F, v.DCoordGenerates]
+    [Nontrivial Ω[F⁄K]] {ω : Ω[F⁄K]} (hω : ω ≠ 0)
+    {D : Divisor K F} {α : Place K F → F} (hα : α ∈ adeleBdd D) :
+    Function.support (kaehlerResidueTerm ω α) ⊆ ↑(D - canonicalDivisorOf hω).support := by
+  intro v hv
+  rw [Finset.mem_coe, Finsupp.mem_support_iff, Finsupp.sub_apply, ne_eq, sub_eq_zero]
+  intro hDω
+  apply hv
+  refine kaehlerResidueTerm_eq_zero_of_ord_nonneg ?_
+  rcases eq_or_ne (α v) 0 with h0 | h0
+  · exact Or.inl (by rw [h0, zero_mul])
+  · refine Or.inr ?_
+    have hg := v.differentialCoeff_ne_zero hω
+    rw [v.ord_mul h0 hg]
+    have hαv : -(D v) ≤ v.ord (α v) := by
+      have hval := hα v
+      rw [v.adicValuation_eq_exp_neg_ord h0] at hval
+      exact neg_le_of_neg_le (WithZero.exp_le_exp.mp hval)
+    rw [hDω, canonicalDivisorOf_apply hω v, Place.ordDifferential] at hαv
+    linarith
+
+theorem kaehlerResidueTerm_support_finite
+    [HasCanonicalDivisor (K := K) (F := F)] [∀ v : Place K F, v.DCoordGenerates]
+    [Nontrivial Ω[F⁄K]] {ω : Ω[F⁄K]} (hω : ω ≠ 0)
+    {D : Divisor K F} {α : Place K F → F} (hα : α ∈ adeleBdd D) :
+    (Function.support (kaehlerResidueTerm ω α)).Finite :=
+  Set.Finite.subset (Finset.finite_toSet _) (kaehlerResidueTerm_support_subset hω hα)
+
+theorem kaehlerResidueTerm_support_finite_of_adeleSpace
+    [HasCanonicalDivisor (K := K) (F := F)] [∀ v : Place K F, v.DCoordGenerates]
+    [Nontrivial Ω[F⁄K]] {ω : Ω[F⁄K]} (hω : ω ≠ 0)
+    {α : Place K F → F} (hα : α ∈ adeleSpace K F) :
+    (Function.support (kaehlerResidueTerm ω α)).Finite := by
+  obtain ⟨D, hD⟩ := mem_adeleSpace_iff.mp hα
+  exact kaehlerResidueTerm_support_finite hω hD
+
+variable [HasCanonicalDivisor (K := K) (F := F)] [∀ v : Place K F, v.DCoordGenerates]
+  [Nontrivial Ω[F⁄K]]
+
+variable (K F) in
+def weilOfKaehler {ω : Ω[F⁄K]} (hω : ω ≠ 0) : Module.Dual K (adeleSpace K F) where
+  toFun α := ∑ᶠ v, kaehlerResidueTerm ω (α : Place K F → F) v
+  map_add' α β := by
+    have hsupα := kaehlerResidueTerm_support_finite_of_adeleSpace hω α.2
+    have hsupβ := kaehlerResidueTerm_support_finite_of_adeleSpace hω β.2
+    rw [← finsum_add_distrib hsupα hsupβ]
+    refine finsum_congr fun v => ?_
+    unfold kaehlerResidueTerm
+    rw [Submodule.coe_add, Pi.add_apply, add_mul, map_add, map_add]
+  map_smul' c α := by
+    simp only [RingHom.id_apply]
+    rw [smul_finsum]
+    refine finsum_congr fun v => ?_
+    unfold kaehlerResidueTerm
+    rw [Submodule.coe_smul, Pi.smul_apply, Algebra.smul_def, mul_assoc,
+      ← Algebra.smul_def, map_smul, map_smul]
+
+theorem weilOfKaehler_apply {ω : Ω[F⁄K]} (hω : ω ≠ 0) (α : adeleSpace K F) :
+    weilOfKaehler K F hω α = ∑ᶠ v, kaehlerResidueTerm ω (α : Place K F → F) v := rfl
+
+theorem weilOfKaehler_vanish_adeleBdd_canonical {ω : Ω[F⁄K]} (hω : ω ≠ 0)
+    {α : adeleSpace K F} (hα : (α : Place K F → F) ∈ adeleBdd (canonicalDivisorOf hω)) :
+    weilOfKaehler K F hω α = 0 := by
+  rw [weilOfKaehler_apply]
+  exact finsum_eq_zero_of_forall_eq_zero
+    (kaehlerResidueTerm_eq_zero_of_adeleBdd_canonical hω hα)
+
+variable (K F)
+
+def ResidueTheorem : Prop :=
+  ∀ [HasPrincipalDivisors K F] {ω : Ω[F⁄K]} (hω : ω ≠ 0) (f : F),
+    weilOfKaehler K F hω ⟨diagonalHom K F f, diagonal_mem_adeleSpace f⟩ = 0
+
+def WeilKaehlerAgree : Prop :=
+  ∀ [HasPrincipalDivisors K F] {ω : Ω[F⁄K]} (hω : ω ≠ 0),
+    weilOfKaehler K F hω ≠ 0 ∧
+    weilOfKaehler K F hω ∈ omegaSpace (canonicalDivisorOf hω) ∧
+    ∀ D : Divisor K F, weilOfKaehler K F hω ∈ omegaSpace D → D ≤ canonicalDivisorOf hω
+
+def ResiduePairingSurjective : Prop :=
+  ∀ [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ∈ omegaSpace W) (_hφ0 : φ ≠ 0)
+    (_hWmax : ∀ E : Divisor K F, φ ∈ omegaSpace E → E ≤ W),
+    Function.Surjective (residuePairing K F W D hφ)
+
+end AlgebraicCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AutomorphicForm_FundamentalDomainVolume.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AutomorphicForm_FundamentalDomainVolume.lean
new file mode 100644
index 0000000000..4b92e43429
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AutomorphicForm_FundamentalDomainVolume.lean
@@ -0,0 +1,228 @@
+/-
+Based on Prove2Me node AutomorphicForm_FundamentalDomainVolume
+(abeb7a91-a537-5f9a-8c53-db5d386a9102) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Order.Star.Real
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AutomorphicForm_HyperbolicMeasure
+
+/-!
+# Finite positive hyperbolic volume of the modular fundamental domain
+
+Definition: `AutomorphicForm_FundamentalDomainVolume` (`abeb7a91-a537-5f9a-8c53-db5d386a9102`), by
+Claude, 2026-09-05.
+
+Working with the hyperbolic measure on the upper half-plane $\mathbb{H}$ (the measure whose integral
+against a set is $\int (1/|\operatorname{Im} w|)^2$ over the image of the set in $\mathbb{C}$), this
+module establishes that the standard fundamental domain $\mathcal{D}$ for
+$\mathrm{SL}_2(\mathbb{Z})$ has volume neither zero nor infinite. The combinatorial device is `band
+A a n`, the set of $z \in \mathbb{H}$ with $|\operatorname{Re} z| \le A$ and $a\,2^n \le
+\operatorname{Im} z \le a\,2^{n+1}$; `verticalStrip_subset_iUnion_band` shows that for $a > 0$ the
+vertical strip $\{|\operatorname{Re} z| \le A,\ a \le \operatorname{Im} z\}$ is covered by the
+countably many bands. Auxiliary declarations introduce the closed coordinate box `cbox relo rehi
+imlo imhi` in $\mathbb{C}$, with its membership criterion and its Lebesgue volume
+$(\mathrm{rehi}-\mathrm{relo})(\mathrm{imhi}-\mathrm{imlo})$. Bounding the density
+$1/(\operatorname{Im} w)^2$ by $(a\,2^n)^{-2}$ on such a box gives `volume_band_le`: for $0 \le A$
+and $0 < a$, the volume of `band A a n` is at most $2A a^{-1} 2^{-n}$. Summing the geometric series
+yields `volume_verticalStrip_lt_top`: every vertical strip with $a>0$ has finite volume (the case
+$A<0$ being vacuous). Since every point of $\mathcal{D}$ has $|\operatorname{Re} z| \le 1/2$ and
+$4(\operatorname{Im} z)^2 \ge 3$, one gets $\mathcal{D} \subseteq$ the strip with $A = a = 1/2$,
+hence `volume_fd_lt_top`. Finiteness persists for any finite union $\bigcup_{\gamma \in S} \gamma
+\cdot \mathcal{D}$ over a finite set $S \subseteq \mathrm{SL}_2(\mathbb{Z})$, by invariance of the
+measure. Positivity comes from exhibiting the point $2i$ in the open domain
+$\mathcal{D}^{\mathrm{o}}$ (where $|z|^2 > 1$ and $|\operatorname{Re} z| < 1/2$) together with
+positivity of the measure on nonempty open sets; `volume_fd_lt_volume_univ` and
+`volume_fd_ne_zero_ne_top` record the resulting comparisons, the former using that $\mathbb{H}$
+itself has infinite volume.
+
+**Relation to Mathlib.** The measure space structure on $\mathbb{H}$, the fundamental domain `𝒟` and
+its interior `𝒟ᵒ`, the vertical strips and the inequality $3 \le 4(\operatorname{Im} z)^2$ on `𝒟`
+are Mathlib's; the band decomposition, the explicit volume bound for a band, and the resulting
+finiteness and positivity statements for the covolume are the project's own, resting on the
+invariance and open-positivity results of `FLT.HyperbolicMeasure`.
+
+**Where it is used.** These volume estimates provide the measure-theoretic foundation for the
+analytic theory of automorphic forms on $\mathbb{H}$ in this development: finiteness and positivity
+of the covolume of $\mathrm{SL}_2(\mathbb{Z})$ is what makes $L^2$ spaces on the quotient and the
+associated spectral decomposition available.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open MeasureTheory Set ModularGroup UpperHalfPlane
+open scoped MatrixGroups Modular Pointwise NNReal ENNReal
+
+noncomputable section
+
+namespace FLT.FundamentalDomainVolume
+
+def band (A a : ℝ) (n : ℕ) : Set ℍ :=
+  {z : ℍ | |z.re| ≤ A ∧ a * 2 ^ n ≤ z.im ∧ z.im ≤ a * 2 ^ (n + 1)}
+
+theorem verticalStrip_subset_iUnion_band (A : ℝ) {a : ℝ} (ha : 0 < a) :
+    UpperHalfPlane.verticalStrip A a ⊆ ⋃ n : ℕ, band A a n := by
+  rintro z ⟨hre, him⟩
+  have hex : ∃ n : ℕ, z.im ≤ a * 2 ^ (n + 1) := by
+    obtain ⟨n, hn⟩ := pow_unbounded_of_one_lt (z.im / a) (one_lt_two (α := ℝ))
+    exact ⟨n, by
+      rw [div_lt_iff₀ ha] at hn
+      nlinarith [pow_pos (zero_lt_two (α := ℝ)) n, pow_succ (2 : ℝ) n]⟩
+  classical
+  refine Set.mem_iUnion.mpr ⟨Nat.find hex, ?_, ?_, Nat.find_spec hex⟩
+  · exact hre
+  rcases Nat.eq_zero_or_eq_succ_pred (Nat.find hex) with h0 | hsucc
+  · rw [h0]; simpa using him
+  · rw [hsucc]
+    have hlt := Nat.find_min hex (m := Nat.find hex - 1) (by omega)
+    rw [not_le] at hlt
+    exact le_of_lt hlt
+
+private def cbox (relo rehi imlo imhi : ℝ) : Set ℂ :=
+  Complex.measurableEquivRealProd ⁻¹' (Set.Icc relo rehi ×ˢ Set.Icc imlo imhi)
+
+private lemma mem_cbox {relo rehi imlo imhi : ℝ} {w : ℂ} :
+    w ∈ cbox relo rehi imlo imhi ↔
+      (relo ≤ w.re ∧ w.re ≤ rehi) ∧ imlo ≤ w.im ∧ w.im ≤ imhi := by
+  simp only [cbox, Set.mem_preimage, Complex.measurableEquivRealProd_apply, Set.mem_prod,
+    Set.mem_Icc]
+
+private lemma volume_cbox (relo rehi imlo imhi : ℝ) :
+    volume (cbox relo rehi imlo imhi) =
+      ENNReal.ofReal (rehi - relo) * ENNReal.ofReal (imhi - imlo) := by
+  rw [cbox, Complex.volume_preserving_equiv_real_prod.measure_preimage
+    ((measurableSet_Icc.prod measurableSet_Icc).nullMeasurableSet)]
+  rw [show (volume : Measure (ℝ × ℝ)) = (volume : Measure ℝ).prod volume from rfl,
+    Measure.prod_prod, Real.volume_Icc, Real.volume_Icc]
+
+theorem volume_band_le {A a : ℝ} (hA : 0 ≤ A) (ha : 0 < a) (n : ℕ) :
+    volume (band A a n) ≤ ENNReal.ofReal (2 * A * (a⁻¹ * (1 / 2) ^ n)) := by
+  have h2n : (0 : ℝ) < a * 2 ^ n := by positivity
+  rw [UpperHalfPlane.volume_eq_lintegral]
+  have himg : (UpperHalfPlane.coe '' band A a n) ⊆
+      cbox (-A) A (a * 2 ^ n) (a * 2 ^ (n + 1)) := by
+    rintro w ⟨z, ⟨hre, him₁, him₂⟩, rfl⟩
+    rw [mem_cbox, UpperHalfPlane.coe_re, UpperHalfPlane.coe_im]
+    exact ⟨abs_le.mp hre, him₁, him₂⟩
+  refine le_trans (lintegral_mono_set himg) ?_
+  have hbound : ∀ w ∈ cbox (-A) A (a * 2 ^ n) (a * 2 ^ (n + 1)),
+      (((1 / ‖w.im‖₊) ^ 2 : ℝ≥0) : ℝ≥0∞) ≤ ENNReal.ofReal ((a * 2 ^ n)⁻¹ ^ 2) := by
+    intro w hw
+    obtain ⟨-, him₁, -⟩ := mem_cbox.mp hw
+    have hwim : (0 : ℝ) < w.im := lt_of_lt_of_le h2n him₁
+    rw [← ENNReal.ofReal_coe_nnreal]
+    refine ENNReal.ofReal_le_ofReal ?_
+    push_cast
+    rw [Real.norm_eq_abs, abs_of_pos hwim]
+    have : (a * 2 ^ n)⁻¹ ^ 2 = (1 / (a * 2 ^ n)) ^ 2 := by rw [one_div]
+    rw [this]
+    gcongr
+  refine le_trans (setLIntegral_mono measurable_const hbound) ?_
+  rw [setLIntegral_const, volume_cbox]
+  have harith₁ : A - -A = 2 * A := by ring
+  have harith₂ : a * 2 ^ (n + 1) - a * 2 ^ n = a * 2 ^ n := by ring
+  rw [harith₁, harith₂, ← ENNReal.ofReal_mul (by positivity),
+    ← ENNReal.ofReal_mul (by positivity)]
+  refine ENNReal.ofReal_le_ofReal (le_of_eq ?_)
+  rw [show (a * 2 ^ n)⁻¹ ^ 2 * (2 * A * (a * 2 ^ n)) =
+        2 * A * ((a * 2 ^ n)⁻¹ ^ 2 * (a * 2 ^ n)) by ring,
+    pow_two, mul_assoc ((a * 2 ^ n)⁻¹), inv_mul_cancel₀ h2n.ne', mul_one, mul_inv,
+    ← inv_pow]
+  norm_num
+
+theorem volume_verticalStrip_lt_top (A : ℝ) {a : ℝ} (ha : 0 < a) :
+    volume (UpperHalfPlane.verticalStrip A a) < ⊤ := by
+  rcases le_or_gt 0 A with hA | hA
+  swap
+  · have hempty : UpperHalfPlane.verticalStrip A a = ∅ := by
+      ext z
+      simp only [Set.mem_empty_iff_false, iff_false]
+      intro hz
+      exact absurd hz.1 (not_le.mpr (lt_of_lt_of_le hA (abs_nonneg _)))
+    rw [hempty]
+    simp
+  calc volume (UpperHalfPlane.verticalStrip A a)
+      ≤ volume (⋃ n : ℕ, band A a n) :=
+        measure_mono (verticalStrip_subset_iUnion_band A ha)
+    _ ≤ ∑' n : ℕ, volume (band A a n) := measure_iUnion_le _
+    _ ≤ ∑' n : ℕ, ENNReal.ofReal (2 * A * (a⁻¹ * (1 / 2) ^ n)) :=
+        ENNReal.tsum_le_tsum fun n => volume_band_le hA ha n
+    _ = ∑' n : ℕ, ENNReal.ofReal (2 * A * a⁻¹) * ENNReal.ofReal ((1 / 2) ^ n) :=
+        tsum_congr fun n => by
+          rw [← ENNReal.ofReal_mul (by positivity)]
+          congr 1
+          ring
+    _ = ENNReal.ofReal (2 * A * a⁻¹) * ∑' n : ℕ, ENNReal.ofReal ((1 / 2) ^ n) :=
+        ENNReal.tsum_mul_left
+    _ = ENNReal.ofReal (2 * A * a⁻¹) * ∑' n : ℕ, ENNReal.ofReal (1 / 2) ^ n :=
+        congrArg _ (tsum_congr fun n => ENNReal.ofReal_pow (by norm_num) n)
+    _ = ENNReal.ofReal (2 * A * a⁻¹) * (1 - ENNReal.ofReal (1 / 2))⁻¹ := by
+        rw [ENNReal.tsum_geometric]
+    _ < ⊤ := by
+        refine ENNReal.mul_lt_top ENNReal.ofReal_lt_top ?_
+        rw [ENNReal.inv_lt_top, tsub_pos_iff_lt]
+        exact ENNReal.ofReal_lt_one.mpr (by norm_num)
+
+theorem fd_subset_verticalStrip : 𝒟 ⊆ UpperHalfPlane.verticalStrip (1 / 2) (1 / 2) := by
+  intro z hz
+  refine ⟨hz.2, ?_⟩
+  have h3 := ModularGroup.three_le_four_mul_im_sq_of_mem_fd hz
+  nlinarith [z.im_pos]
+
+theorem volume_fd_lt_top : volume 𝒟 < ⊤ :=
+  lt_of_le_of_lt (measure_mono fd_subset_verticalStrip)
+    (volume_verticalStrip_lt_top (1 / 2) (by norm_num))
+
+theorem volume_biUnion_smul_fd_lt_top (S : Finset SL(2, ℤ)) :
+    volume (⋃ γ ∈ S, γ • 𝒟) < ⊤ := by
+  refine lt_of_le_of_lt (measure_biUnion_finset_le S _) ?_
+  rw [ENNReal.sum_lt_top]
+  intro γ _
+  rw [FLT.HyperbolicMeasure.volume_smul_sl2z]
+  exact volume_fd_lt_top
+
+private def fdoWitness : ℍ := UpperHalfPlane.mk ⟨0, 2⟩ (by norm_num)
+
+private lemma fdoWitness_mem_fdo : fdoWitness ∈ 𝒟ᵒ := by
+  constructor
+  · show 1 < Complex.normSq (fdoWitness : ℂ)
+    norm_num [fdoWitness, Complex.normSq_apply, UpperHalfPlane.coe_mk]
+  · change |fdoWitness.re| < 1 / 2
+    norm_num [fdoWitness, UpperHalfPlane.mk_re]
+
+theorem volume_fd_pos : 0 < volume 𝒟 :=
+  lt_of_lt_of_le
+    (FLT.HyperbolicMeasure.volume_pos_of_isOpen ModularGroup.isOpen_fdo
+      ⟨fdoWitness, fdoWitness_mem_fdo⟩)
+    (measure_mono ModularGroup.fdo_subset_fd)
+
+theorem volume_fd_lt_volume_univ : volume 𝒟 < volume (Set.univ : Set ℍ) := by
+  rw [FLT.HyperbolicMeasure.volume_univ_eq_top]
+  exact volume_fd_lt_top
+
+theorem volume_fd_ne_zero_ne_top : volume 𝒟 ≠ 0 ∧ volume 𝒟 ≠ ⊤ :=
+  ⟨volume_fd_pos.ne', volume_fd_lt_top.ne⟩
+
+example : volume ((1 : SL(2, ℤ)) • 𝒟 ∪ ModularGroup.S • 𝒟) < ⊤ := by
+  have := volume_biUnion_smul_fd_lt_top {1, ModularGroup.S}
+  refine lt_of_le_of_lt (measure_mono ?_) this
+  intro z hz
+  rcases hz with hz | hz
+  · exact Set.mem_biUnion (Finset.mem_insert_self _ _) hz
+  · exact Set.mem_biUnion (Finset.mem_insert_of_mem (Finset.mem_singleton_self _)) hz
+
+example : volume (⋃ γ ∈ (∅ : Finset SL(2, ℤ)), γ • 𝒟) < ⊤ := by
+  simp
+
+end FLT.FundamentalDomainVolume
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AutomorphicForm_Gamma0FundamentalSet.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AutomorphicForm_Gamma0FundamentalSet.lean
new file mode 100644
index 0000000000..587426cdc7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AutomorphicForm_Gamma0FundamentalSet.lean
@@ -0,0 +1,177 @@
+/-
+Based on Prove2Me node AutomorphicForm_Gamma0FundamentalSet
+(497188a5-a407-573a-8d6c-e24bc6a4ae43) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AutomorphicForm_FundamentalDomainVolume
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AutomorphicForm_SiegelSetCover
+
+/-!
+# Fundamental sets for subgroups of SL2​(Z) on H
+
+Definition: `AutomorphicForm_Gamma0FundamentalSet` (`497188a5-a407-573a-8d6c-e24bc6a4ae43`), by
+Claude, 2026-09-05.
+
+For a subgroup $\Gamma \le SL(2,\mathbb Z)$, `gammaFundamentalSet` is the subset of the upper half
+plane obtained as the union, over all cosets $q \in SL(2,\mathbb Z)/\Gamma$, of
+$g_q^{-1}\cdot\mathcal D$, where $\mathcal D$ is Mathlib's standard fundamental domain
+`ModularGroup.fd` for the full modular group and $g_q$ is the chosen representative `Quotient.out q`
+of the coset. Thus $z$ lies in the set exactly when $g_q\cdot z \in \mathcal D$ for some coset $q$
+(`mem_gammaFundamentalSet_iff`). No disjointness of the translates is asserted: what is proved is
+the covering property that every $z \in \mathbb H$ has some $\gamma \in \Gamma$ with $\gamma\cdot z$
+in the set, and, when the quotient $SL(2,\mathbb Z)/\Gamma$ is finite, the identification of the set
+with a finite union $\bigcup_{\gamma\in S}\gamma\cdot\mathcal D$ over the finite set $S$ of inverse
+coset representatives. Measure-theoretically, the hyperbolic volume of `gammaFundamentalSet Γ` is
+always strictly positive, and is finite whenever $SL(2,\mathbb Z)/\Gamma$ is finite, hence lies
+strictly between $0$ and $\mathrm{vol}(\mathbb H) = \infty$; for $\Gamma = \top$ the volume equals
+$\mathrm{vol}(\mathcal D)$. These statements are specialised to $\Gamma = \Gamma_0(N)$ with $N \ne
+0$, where finiteness of the quotient comes from finiteness of the index.
+
+The companion definition `truncatedGammaFundamentalSet Γ y` replaces $\mathcal D$ in the same coset
+union by `truncatedFundamentalDomain y`, the part of $\mathcal D$ whose imaginary part is bounded by
+$y$; it is contained in `gammaFundamentalSet Γ`, it is compact when $SL(2,\mathbb Z)/\Gamma$ is
+finite (in particular for $\Gamma_0(N)$), and it is nonempty for $y = 2$, witnessed by the translate
+of $\rho$ (of imaginary part $\sqrt 3/2$). The module also records the continuity of the action of
+each fixed element of $SL(2,\mathbb Z)$ on $\mathbb H$, obtained from the $GL_2(\mathbb R)$-action
+through `Matrix.SpecialLinearGroup.mapGL`.
+
+**Relation to Mathlib.** Mathlib supplies the standard fundamental domain $\mathcal D$ for
+$SL(2,\mathbb Z)$, its truncations, the hyperbolic measure on $\mathbb H$ and the congruence
+subgroups `Gamma0`; the coset union attached to an arbitrary subgroup, together with its positivity,
+finiteness of volume and compactness of the truncation, is the project's own. A `ContinuousConstSMul
+SL(2, ℤ) ℍ` instance is registered here.
+
+**Where it is used.** These fundamental sets provide the geometric base for the analytic theory of
+modular forms of level $N$: finiteness of the covolume of $\Gamma_0(N)$ and compactness of truncated
+fundamental sets are the starting points for integration and spectral arguments on
+$\Gamma_0(N)\backslash\mathbb H$ used in the modularity input to Fermat's Last Theorem.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open Matrix Matrix.SpecialLinearGroup UpperHalfPlane ModularGroup CongruenceSubgroup
+open MeasureTheory
+open scoped Modular MatrixGroups Pointwise
+
+namespace FLT.Gamma0FundamentalSet
+
+noncomputable def gammaFundamentalSet (Γ : Subgroup SL(2, ℤ)) : Set ℍ :=
+  ⋃ q : SL(2, ℤ) ⧸ Γ, (Quotient.out q)⁻¹ • 𝒟
+
+theorem mem_gammaFundamentalSet_iff {Γ : Subgroup SL(2, ℤ)} {z : ℍ} :
+    z ∈ gammaFundamentalSet Γ ↔ ∃ q : SL(2, ℤ) ⧸ Γ, Quotient.out q • z ∈ 𝒟 := by
+  simp only [gammaFundamentalSet, Set.mem_iUnion, Set.mem_inv_smul_set_iff]
+
+theorem exists_smul_mem_gammaFundamentalSet (Γ : Subgroup SL(2, ℤ)) (z : ℍ) :
+    ∃ γ ∈ Γ, γ • z ∈ gammaFundamentalSet Γ :=
+  FLT.SiegelSetCover.exists_smul_mem_iUnion_smul_fd Γ z
+
+theorem gammaFundamentalSet_eq_biUnion (Γ : Subgroup SL(2, ℤ)) [Finite (SL(2, ℤ) ⧸ Γ)] :
+    haveI : Fintype (SL(2, ℤ) ⧸ Γ) := Fintype.ofFinite _
+    gammaFundamentalSet Γ =
+      ⋃ γ ∈ (Finset.univ.image fun q : SL(2, ℤ) ⧸ Γ => (Quotient.out q)⁻¹), γ • 𝒟 := by
+  have : Fintype (SL(2, ℤ) ⧸ Γ) := Fintype.ofFinite _
+  ext z
+  simp only [gammaFundamentalSet, Set.mem_iUnion, Finset.mem_image, Finset.mem_univ,
+    true_and]
+  exact ⟨fun ⟨q, hq⟩ => ⟨_, ⟨q, rfl⟩, hq⟩, fun ⟨γ, ⟨q, hq⟩, hz⟩ => ⟨q, hq ▸ hz⟩⟩
+
+theorem volume_gammaFundamentalSet_lt_top (Γ : Subgroup SL(2, ℤ))
+    [Finite (SL(2, ℤ) ⧸ Γ)] : volume (gammaFundamentalSet Γ) < ⊤ := by
+  have : Fintype (SL(2, ℤ) ⧸ Γ) := Fintype.ofFinite _
+  rw [gammaFundamentalSet_eq_biUnion Γ]
+  exact FLT.FundamentalDomainVolume.volume_biUnion_smul_fd_lt_top _
+
+theorem volume_gammaFundamentalSet_pos (Γ : Subgroup SL(2, ℤ)) :
+    0 < volume (gammaFundamentalSet Γ) := by
+  refine lt_of_lt_of_le ?_
+    (measure_mono (Set.subset_iUnion _ (QuotientGroup.mk 1 : SL(2, ℤ) ⧸ Γ)))
+  rw [FLT.HyperbolicMeasure.volume_smul_sl2z]
+  exact FLT.FundamentalDomainVolume.volume_fd_pos
+
+theorem volume_gammaFundamentalSet_ne_zero_ne_top (Γ : Subgroup SL(2, ℤ))
+    [Finite (SL(2, ℤ) ⧸ Γ)] :
+    volume (gammaFundamentalSet Γ) ≠ 0 ∧ volume (gammaFundamentalSet Γ) ≠ ⊤ :=
+  ⟨(volume_gammaFundamentalSet_pos Γ).ne', (volume_gammaFundamentalSet_lt_top Γ).ne⟩
+
+theorem volume_gamma0_lt_top (N : ℕ) [NeZero N] :
+    volume (gammaFundamentalSet (Gamma0 N)) < ⊤ :=
+  haveI : Finite (SL(2, ℤ) ⧸ Gamma0 N) := FLT.SiegelSetCover.finite_quotient_gamma0 N
+  volume_gammaFundamentalSet_lt_top (Gamma0 N)
+
+theorem exists_gamma0_smul_mem (N : ℕ) (z : ℍ) :
+    ∃ γ ∈ Gamma0 N, γ • z ∈ gammaFundamentalSet (Gamma0 N) :=
+  exists_smul_mem_gammaFundamentalSet (Gamma0 N) z
+
+noncomputable def truncatedGammaFundamentalSet (Γ : Subgroup SL(2, ℤ)) (y : ℝ) : Set ℍ :=
+  ⋃ q : SL(2, ℤ) ⧸ Γ, (Quotient.out q)⁻¹ • truncatedFundamentalDomain y
+
+instance : ContinuousConstSMul SL(2, ℤ) ℍ where
+  continuous_const_smul γ := by
+    have h : (fun z : ℍ => γ • z) =
+        fun z : ℍ => (Matrix.SpecialLinearGroup.mapGL ℝ γ) • z := by
+      funext z
+      exact MulAction.compHom_smul_def (Matrix.SpecialLinearGroup.mapGL ℝ) γ z
+    rw [h]
+    exact continuous_const_smul _
+
+theorem isCompact_smul_truncated (γ : SL(2, ℤ)) (y : ℝ) :
+    IsCompact (γ • truncatedFundamentalDomain y) :=
+  IsCompact.smul γ (isCompact_truncatedFundamentalDomain y)
+
+theorem isCompact_truncatedGammaFundamentalSet (Γ : Subgroup SL(2, ℤ))
+    [Finite (SL(2, ℤ) ⧸ Γ)] (y : ℝ) :
+    IsCompact (truncatedGammaFundamentalSet Γ y) :=
+  isCompact_iUnion fun q => isCompact_smul_truncated (Quotient.out q)⁻¹ y
+
+theorem isCompact_truncatedGamma0 (N : ℕ) [NeZero N] (y : ℝ) :
+    IsCompact (truncatedGammaFundamentalSet (Gamma0 N) y) :=
+  haveI : Finite (SL(2, ℤ) ⧸ Gamma0 N) := FLT.SiegelSetCover.finite_quotient_gamma0 N
+  isCompact_truncatedGammaFundamentalSet (Gamma0 N) y
+
+theorem truncatedGammaFundamentalSet_subset (Γ : Subgroup SL(2, ℤ)) (y : ℝ) :
+    truncatedGammaFundamentalSet Γ y ⊆ gammaFundamentalSet Γ := by
+  refine Set.iUnion_mono fun q => Set.smul_set_mono ?_
+  exact fun z hz => hz.1
+
+theorem gate_volume_lt_volume_univ (Γ : Subgroup SL(2, ℤ)) [Finite (SL(2, ℤ) ⧸ Γ)] :
+    volume (gammaFundamentalSet Γ) < volume (Set.univ : Set ℍ) := by
+  rw [FLT.HyperbolicMeasure.volume_univ_eq_top]
+  exact volume_gammaFundamentalSet_lt_top Γ
+
+theorem gate_volume_top_eq : volume (gammaFundamentalSet (⊤ : Subgroup SL(2, ℤ))) =
+    volume 𝒟 := by
+  have : Subsingleton (SL(2, ℤ) ⧸ (⊤ : Subgroup SL(2, ℤ))) :=
+    QuotientGroup.subsingleton_quotient_top
+  have huniq : ∀ q : SL(2, ℤ) ⧸ (⊤ : Subgroup SL(2, ℤ)),
+      q = (QuotientGroup.mk 1 : SL(2, ℤ) ⧸ (⊤ : Subgroup SL(2, ℤ))) := fun q =>
+    Subsingleton.elim _ _
+  have : gammaFundamentalSet (⊤ : Subgroup SL(2, ℤ)) =
+      (Quotient.out (QuotientGroup.mk 1 : SL(2, ℤ) ⧸ (⊤ : Subgroup SL(2, ℤ))))⁻¹ • 𝒟 := by
+    refine Set.Subset.antisymm (Set.iUnion_subset fun q => ?_)
+      (Set.subset_iUnion (fun q : SL(2, ℤ) ⧸ (⊤ : Subgroup SL(2, ℤ)) =>
+        (Quotient.out q)⁻¹ • 𝒟) (QuotientGroup.mk 1))
+    rw [huniq q]
+  rw [this, FLT.HyperbolicMeasure.volume_smul_sl2z]
+
+example : volume (gammaFundamentalSet (Gamma0 11)) < ⊤ := volume_gamma0_lt_top 11
+
+theorem gate_truncated_nonempty (Γ : Subgroup SL(2, ℤ)) :
+    (truncatedGammaFundamentalSet Γ 2).Nonempty := by
+  refine ⟨(Quotient.out (QuotientGroup.mk 1 : SL(2, ℤ) ⧸ Γ))⁻¹ • UpperHalfPlane.ρ,
+    Set.mem_iUnion.mpr ⟨QuotientGroup.mk 1, Set.smul_mem_smul_set ?_⟩⟩
+  refine ⟨FLT.SiegelSetCover.gate_rho_mem_fd, ?_⟩
+  rw [FLT.SiegelSetCover.gate_im_rho]
+  nlinarith [Real.sq_sqrt (by norm_num : (3 : ℝ) ≥ 0),
+    Real.sqrt_nonneg (3 : ℝ)]
+
+end FLT.Gamma0FundamentalSet
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AutomorphicForm_HyperbolicMeasure.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AutomorphicForm_HyperbolicMeasure.lean
new file mode 100644
index 0000000000..bc8502f412
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AutomorphicForm_HyperbolicMeasure.lean
@@ -0,0 +1,168 @@
+/-
+Based on Prove2Me node AutomorphicForm_HyperbolicMeasure
+(8afb5035-3a91-580e-8eff-e4cf17dd4bcb) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.CStarAlgebra.Classes
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Measure
+public import Mathlib.NumberTheory.Modular
+public import Mathlib.Order.CompletePartialOrder
+
+/-!
+# Hyperbolic measure on the upper half-plane: invariance, infinite mass
+
+Definition: `AutomorphicForm_HyperbolicMeasure` (`8afb5035-3a91-580e-8eff-e4cf17dd4bcb`), by Claude,
+2026-09-05.
+
+The ambient object is Mathlib's measure `volume` on the upper half-plane $\mathbb{H}$, the
+hyperbolic (Poincaré) measure $y^{-2}\,dx\,dy$; the module records that it is $\sigma$-finite,
+finite on compact sets and invariant for the action of $\mathrm{GL}_2(\mathbb{R})$, and restates the
+invariance as `volume_smul_gl`: for every $g \in \mathrm{GL}_2(\mathbb{R})$ and every set $s
+\subseteq \mathbb{H}$, $\operatorname{vol}(g \cdot s) = \operatorname{vol}(s)$. Transporting this
+along the homomorphism $\mathrm{SL}_2(\mathbb{Z}) \to \mathrm{GL}_2(\mathbb{R})$ gives an
+`SMulInvariantMeasure` instance for the modular group, and `volume_smul_sl2z` states
+$\operatorname{vol}(\gamma \cdot s) = \operatorname{vol}(s)$ for $\gamma \in
+\mathrm{SL}_2(\mathbb{Z})$.
+
+Next, `volume` is shown to be an open positive measure: `volume_pos_of_isOpen` says that a nonempty
+open $U \subseteq \mathbb{H}$ has $\operatorname{vol}(U) > 0$. The instance behind it rests on the
+description of $\operatorname{vol}$ as the Lebesgue integral over the image of $U$ in $\mathbb{C}$
+of the density $w \mapsto (1/\lVert \operatorname{Im} w \rVert)^2$, together with two private helper
+lemmas: measurability of that density as an $[0,\infty]$-valued function on $\mathbb{C}$, and its
+non-vanishing at points lying in the range of the coercion $\mathbb{H} \to \mathbb{C}$.
+
+Finally, total mass. For $n \in \mathbb{Z}$ the private set `box n` is the open rectangle $\{z : n <
+\operatorname{Re} z < n+1,\ 1 < \operatorname{Im} z < 2\}$; the helper lemmas state that it is open,
+that it contains $n + \tfrac12 + \tfrac32 i$, that distinct boxes are disjoint, and that `box n` is
+the translate of `box 0` by $T^n$, $T = \begin{pmatrix}1&1\\0&1\end{pmatrix}$. Invariance then makes
+all boxes of one common positive volume, so their disjoint union already has infinite measure:
+`volume_univ_eq_top` asserts $\operatorname{vol}(\mathbb{H}) = \infty$, and
+`not_isFiniteMeasure_volume` that `volume` on $\mathbb{H}$ is not a finite measure.
+
+**Relation to Mathlib.** The measure is Mathlib's `volume` on `UpperHalfPlane`, together with its
+$\mathrm{GL}_2(\mathbb{R})$-invariance and local finiteness; what is added here are the
+`SMulInvariantMeasure SL(2, ℤ)` and `Measure.IsOpenPosMeasure` instances and the consequences drawn
+from them.
+
+**Where it is used.** These are measure-theoretic preliminaries for the analytic theory of modular
+forms on $\mathbb{H}$: invariance under $\mathrm{SL}_2(\mathbb{Z})$ is what allows integration to
+descend to the modular quotient, positivity on open sets excludes degenerate behaviour there, and
+the infinitude of the total mass records that one must work on a quotient rather than on
+$\mathbb{H}$ itself.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public noncomputable section publicSection
+
+open MeasureTheory Set
+open scoped MatrixGroups Pointwise NNReal ENNReal
+
+namespace FLT.HyperbolicMeasure
+
+open UpperHalfPlane
+
+theorem volume_smul_gl (g : GL (Fin 2) ℝ) (s : Set ℍ) : volume (g • s) = volume s :=
+  MeasureTheory.measure_smul (volume : Measure ℍ) g s
+
+instance : SMulInvariantMeasure SL(2, ℤ) ℍ (volume : Measure ℍ) where
+  measure_preimage_smul g s hs := by
+    simp only [MulAction.compHom_smul_def]
+    exact SMulInvariantMeasure.measure_preimage_smul (Matrix.SpecialLinearGroup.mapGL ℝ g) hs
+
+theorem volume_smul_sl2z (γ : SL(2, ℤ)) (s : Set ℍ) : volume (γ • s) = volume s :=
+  MeasureTheory.measure_smul (volume : Measure ℍ) γ s
+
+private lemma measurable_density :
+    Measurable fun z : ℂ => ((((1 : ℝ≥0) / ‖z.im‖₊) ^ 2 : ℝ≥0) : ℝ≥0∞) := by
+  fun_prop
+
+private lemma density_ne_zero {w : ℂ} (hw : w ∈ Set.range (UpperHalfPlane.coe)) :
+    ((((1 : ℝ≥0) / ‖w.im‖₊) ^ 2 : ℝ≥0) : ℝ≥0∞) ≠ 0 := by
+  obtain ⟨τ, rfl⟩ := hw
+  have him : (τ : ℂ).im ≠ 0 := ne_of_gt τ.2
+  simp only [ne_eq, ENNReal.coe_eq_zero, pow_eq_zero_iff, OfNat.ofNat_ne_zero,
+    not_false_eq_true, div_eq_zero_iff, one_ne_zero, nnnorm_eq_zero, false_or]
+  exact him
+
+instance : Measure.IsOpenPosMeasure (volume : Measure ℍ) := by
+  constructor
+  intro U hU hUne
+  rw [UpperHalfPlane.volume_eq_lintegral]
+  have himage_open : IsOpen (UpperHalfPlane.coe '' U) :=
+    UpperHalfPlane.isOpenEmbedding_coe.isOpenMap U hU
+  have himage_ne : (UpperHalfPlane.coe '' U).Nonempty := hUne.image _
+  have hpos : 0 < volume (UpperHalfPlane.coe '' U) :=
+    himage_open.measure_pos volume himage_ne
+  refine ((MeasureTheory.setLIntegral_pos_iff measurable_density).mpr ?_).ne'
+  refine hpos.trans_le (measure_mono fun w hw => ?_)
+  exact ⟨density_ne_zero (Set.image_subset_range _ _ hw), hw⟩
+
+theorem volume_pos_of_isOpen {U : Set ℍ} (hU : IsOpen U) (hne : U.Nonempty) :
+    0 < volume U :=
+  hU.measure_pos _ hne
+
+private def box (n : ℤ) : Set ℍ :=
+  UpperHalfPlane.re ⁻¹' Set.Ioo (n : ℝ) (n + 1) ∩ UpperHalfPlane.im ⁻¹' Set.Ioo (1 : ℝ) 2
+
+private lemma isOpen_box (n : ℤ) : IsOpen (box n) :=
+  (isOpen_Ioo.preimage UpperHalfPlane.continuous_re).inter
+    (isOpen_Ioo.preimage UpperHalfPlane.continuous_im)
+
+private lemma box_nonempty (n : ℤ) : (box n).Nonempty := by
+  refine ⟨UpperHalfPlane.mk ⟨(n : ℝ) + 1 / 2, 3 / 2⟩ (by norm_num), ?_, ?_⟩ <;>
+      simp only [Set.mem_preimage, UpperHalfPlane.mk_re, UpperHalfPlane.mk_im, Set.mem_Ioo]
+  · exact ⟨by norm_num, by norm_num⟩
+  · exact ⟨by norm_num, by norm_num⟩
+
+private lemma pairwise_disjoint_box : Pairwise (Function.onFun Disjoint box) := by
+  intro m n hmn
+  refine Set.disjoint_left.mpr fun z hzm hzn => hmn ?_
+  have h1 : (m : ℝ) < z.re ∧ z.re < m + 1 := hzm.1
+  have h2 : (n : ℝ) < z.re ∧ z.re < n + 1 := hzn.1
+  have : (m : ℝ) = n := by
+    rcases lt_trichotomy m n with h | h | h
+    · exfalso
+      have : (m : ℝ) + 1 ≤ n := by exact_mod_cast Int.add_one_le_of_lt h
+      linarith [h1.2, h2.1]
+    · exact_mod_cast h
+    · exfalso
+      have : (n : ℝ) + 1 ≤ m := by exact_mod_cast Int.add_one_le_of_lt h
+      linarith [h2.2, h1.1]
+  exact_mod_cast this
+
+private lemma box_eq_smul (n : ℤ) : box n = (ModularGroup.T ^ n) • box 0 := by
+  ext z
+  rw [Set.mem_smul_set_iff_inv_smul_mem, ← zpow_neg]
+  simp only [box, Set.mem_inter_iff, Set.mem_preimage, Set.mem_Ioo,
+    ModularGroup.re_T_zpow_smul, ModularGroup.im_T_zpow_smul, Int.cast_neg, Int.cast_zero]
+  grind
+
+theorem volume_univ_eq_top : volume (Set.univ : Set ℍ) = ⊤ := by
+  have hdisj := pairwise_disjoint_box
+  have hmeas : ∀ n : ℤ, MeasurableSet (box n) := fun n => (isOpen_box n).measurableSet
+  have hsum : volume (⋃ n : ℤ, box n) = ∑' n : ℤ, volume (box n) :=
+    measure_iUnion hdisj hmeas
+  have hconst : ∀ n : ℤ, volume (box n) = volume (box 0) := fun n => by
+    rw [box_eq_smul n, volume_smul_sl2z]
+  have hpos : volume (box 0) ≠ 0 :=
+    (volume_pos_of_isOpen (isOpen_box 0) (box_nonempty 0)).ne'
+  have htop : volume (⋃ n : ℤ, box n) = ⊤ := by
+    rw [hsum]
+    calc ∑' n : ℤ, volume (box n) = ∑' _ : ℤ, volume (box 0) := by
+          exact tsum_congr hconst
+      _ = ⊤ := ENNReal.tsum_const_eq_top_of_ne_zero hpos
+  exact eq_top_mono (measure_mono (Set.subset_univ _)) htop
+
+theorem not_isFiniteMeasure_volume : ¬ IsFiniteMeasure (volume : Measure ℍ) := by
+  intro h
+  exact (measure_lt_top (volume : Measure ℍ) Set.univ).ne volume_univ_eq_top
+
+end FLT.HyperbolicMeasure
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_AutomorphicForm_SiegelSetCover.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_AutomorphicForm_SiegelSetCover.lean
new file mode 100644
index 0000000000..bed07a1b9d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_AutomorphicForm_SiegelSetCover.lean
@@ -0,0 +1,171 @@
+/-
+Based on Prove2Me node AutomorphicForm_SiegelSetCover
+(fc7b6f84-d9d8-5ae4-addb-5225f537339c) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Order.Ring.Star
+public import Mathlib.Data.Int.Star
+public import Mathlib.NumberTheory.Modular
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+
+/-!
+# Siegel-set covers of the modular fundamental domain
+
+Definition: `AutomorphicForm_SiegelSetCover` (`fc7b6f84-d9d8-5ae4-addb-5225f537339c`), by Claude,
+2026-09-05.
+
+This module records reduction theory for $\mathrm{SL}_2(\mathbb{Z})$ acting on the upper half-plane
+$\mathbb{H}$, in the form of height bounds and of covers of $\mathbb{H}$ by translates of Mathlib's
+closed fundamental domain $\mathcal{D} = \{\tau : 1 \le |\tau|^2,\ |\operatorname{Re}\tau| \le
+1/2\}$. The first group of statements is the height bound: every $\tau \in \mathcal{D}$ satisfies
+$\operatorname{Im}\tau \ge \sqrt{3}/2$, and consequently every $z \in \mathbb{H}$ admits $g \in
+\mathrm{SL}_2(\mathbb{Z})$ with $\operatorname{Im}(g \cdot z) \ge \sqrt{3}/2$. The second group
+treats an arbitrary subgroup $\Gamma \le \mathrm{SL}_2(\mathbb{Z})$, not assumed normal, with
+$\mathrm{SL}_2(\mathbb{Z})/\Gamma$ the space of cosets and `Quotient.out` the chosen set-theoretic
+section: for each $z \in \mathbb{H}$ there are $\gamma \in \Gamma$ and a coset $q$ with
+$\mathrm{out}(q) \cdot (\gamma \cdot z) \in \mathcal{D}$, hence also with
+$\operatorname{Im}(\mathrm{out}(q)\cdot(\gamma \cdot z)) \ge \sqrt{3}/2$; equivalently, the
+$\Gamma$-orbit of $z$ meets $\bigcup_q \mathrm{out}(q)^{-1}\cdot\mathcal{D}$. This is specialised to
+$\Gamma = \Gamma_0(N)$ for every natural number $N$, together with the finiteness of
+$\mathrm{SL}_2(\mathbb{Z})/\Gamma_0(N)$ for $N \neq 0$, obtained from finiteness of the index, so
+that the union above is a finite one.
+
+The remaining statements concern the corner point $\rho = -1/2 + i\sqrt{3}/2$: its imaginary part is
+$\sqrt{3}/2$, it lies in $\mathcal{D}$, and for every $g \in \mathrm{SL}_2(\mathbb{Z})$ one has
+$\operatorname{Im}(g\cdot\rho) \le \sqrt{3}/2$, so the bound $\sqrt{3}/2$ is attained and optimal.
+The last fact rests on an auxiliary arithmetic inequality, $c^2 - cd + d^2 \ge 1$ for integers $c,
+d$ not both zero, applied to the bottom row of $g$, which computes $|{\cdot}|^2$ of the denominator
+$c\rho + d$. Two small further facts are recorded: $1/2 < \sqrt{3}/2$, and $S =
+\begin{pmatrix}0&-1\\1&0\end{pmatrix} \notin \Gamma_0(2)$.
+
+**Relation to Mathlib.** No new notions are introduced: $\mathcal{D}$, $\rho$, `Gamma0`, the
+denominator $\mathrm{denom}$ and the existence of a translate in $\mathcal{D}$ are Mathlib's, and
+the statements here are consequences of Mathlib's reduction theory for $\mathrm{SL}_2(\mathbb{Z})$
+repackaged in the coset form used downstream.
+
+**Where it is used.** The covers and the uniform lower bound $\operatorname{Im} \ge \sqrt{3}/2$ on
+suitably translated points serve the analytic side of the modular-forms development, where growth
+estimates for automorphic forms are controlled on finitely many translates of the fundamental domain
+for $\Gamma_0(N)$.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+public section publicSection
+
+open Matrix Matrix.SpecialLinearGroup UpperHalfPlane ModularGroup CongruenceSubgroup
+open scoped Modular MatrixGroups Pointwise
+
+namespace FLT.SiegelSetCover
+
+theorem sqrt_three_div_two_le_im_of_mem_fd {τ : ℍ} (h : τ ∈ 𝒟) :
+    Real.sqrt 3 / 2 ≤ τ.im := by
+  have h1 : 3 ≤ 4 * τ.im ^ 2 := three_le_four_mul_im_sq_of_mem_fd h
+  have h2 : Real.sqrt 3 ≤ 2 * τ.im := by
+    rw [Real.sqrt_le_left (by linarith [τ.im_pos])]
+    nlinarith
+  linarith
+
+theorem exists_sqrt_three_div_two_le_im_smul (z : ℍ) :
+    ∃ g : SL(2, ℤ), Real.sqrt 3 / 2 ≤ (g • z).im := by
+  obtain ⟨g, hg⟩ := exists_smul_mem_fd z
+  exact ⟨g, sqrt_three_div_two_le_im_of_mem_fd hg⟩
+
+theorem exists_out_smul_smul_mem_fd (Γ : Subgroup SL(2, ℤ)) (z : ℍ) :
+    ∃ γ ∈ Γ, ∃ q : SL(2, ℤ) ⧸ Γ, Quotient.out q • (γ • z) ∈ 𝒟 := by
+  obtain ⟨g, hg⟩ := exists_smul_mem_fd z
+  obtain ⟨h, hh⟩ := QuotientGroup.mk_out_eq_mul Γ g
+  refine ⟨(h : SL(2, ℤ))⁻¹, Γ.inv_mem h.2, QuotientGroup.mk g, ?_⟩
+  rw [hh, mul_smul, smul_inv_smul]
+  exact hg
+
+theorem exists_smul_mem_iUnion_smul_fd (Γ : Subgroup SL(2, ℤ)) (z : ℍ) :
+    ∃ γ ∈ Γ, γ • z ∈ ⋃ q : SL(2, ℤ) ⧸ Γ, (Quotient.out q)⁻¹ • 𝒟 := by
+  obtain ⟨γ, hγ, q, hq⟩ := exists_out_smul_smul_mem_fd Γ z
+  exact ⟨γ, hγ, Set.mem_iUnion.mpr ⟨q, Set.mem_inv_smul_set_iff.mpr hq⟩⟩
+
+theorem exists_out_smul_smul_im_ge (Γ : Subgroup SL(2, ℤ)) (z : ℍ) :
+    ∃ γ ∈ Γ, ∃ q : SL(2, ℤ) ⧸ Γ,
+      Real.sqrt 3 / 2 ≤ (Quotient.out q • (γ • z)).im := by
+  obtain ⟨γ, hγ, q, hq⟩ := exists_out_smul_smul_mem_fd Γ z
+  exact ⟨γ, hγ, q, sqrt_three_div_two_le_im_of_mem_fd hq⟩
+
+theorem finite_quotient_gamma0 (N : ℕ) [NeZero N] : Finite (SL(2, ℤ) ⧸ Gamma0 N) :=
+  Subgroup.finite_quotient_of_finiteIndex
+
+theorem exists_gamma0_smul_mem_iUnion_smul_fd (N : ℕ) (z : ℍ) :
+    ∃ γ ∈ Gamma0 N, γ • z ∈ ⋃ q : SL(2, ℤ) ⧸ Gamma0 N, (Quotient.out q)⁻¹ • 𝒟 :=
+  exists_smul_mem_iUnion_smul_fd (Gamma0 N) z
+
+private theorem one_le_quadratic_form (c d : ℤ) (h : c ≠ 0 ∨ d ≠ 0) :
+    1 ≤ c ^ 2 - c * d + d ^ 2 := by
+  have key : 0 < c ^ 2 - c * d + d ^ 2 := by
+    rcases h with hc | hd
+    · rcases lt_or_gt_of_ne hc with h' | h' <;>
+        nlinarith [sq_nonneg (c - 2 * d), Int.add_one_le_iff.mpr h']
+    · rcases lt_or_gt_of_ne hd with h' | h' <;>
+        nlinarith [sq_nonneg (2 * c - d), Int.add_one_le_iff.mpr h']
+  linarith [Int.add_one_le_iff.mpr key]
+
+theorem gate_im_rho : (UpperHalfPlane.ρ).im = Real.sqrt 3 / 2 := rfl
+
+theorem gate_rho_mem_fd : UpperHalfPlane.ρ ∈ 𝒟 := by
+  constructor
+  · show (1 : ℝ) ≤ Complex.normSq (UpperHalfPlane.ρ : ℂ)
+    have h3 : Real.sqrt 3 * Real.sqrt 3 = 3 := Real.mul_self_sqrt (by norm_num)
+    rw [Complex.normSq_apply,
+      show ((UpperHalfPlane.ρ : ℂ)).re = -1 / 2 from rfl,
+      show ((UpperHalfPlane.ρ : ℂ)).im = Real.sqrt 3 / 2 from rfl]
+    nlinarith
+  · change |(UpperHalfPlane.ρ).re| ≤ (1 : ℝ) / 2
+    rw [show (UpperHalfPlane.ρ).re = -1 / 2 from rfl]
+    rw [abs_le]
+    norm_num
+
+theorem gate_im_smul_rho_le (g : SL(2, ℤ)) :
+    (g • UpperHalfPlane.ρ).im ≤ Real.sqrt 3 / 2 := by
+  have h3 : Real.sqrt 3 * Real.sqrt 3 = 3 := Real.mul_self_sqrt (by norm_num)
+  have hcd : (g 1 0 : ℤ) ≠ 0 ∨ (g 1 1 : ℤ) ≠ 0 :=
+    (bottom_row_coprime g).ne_zero_or_ne_zero
+  have hint : (1 : ℤ) ≤ g 1 0 ^ 2 - g 1 0 * g 1 1 + g 1 1 ^ 2 :=
+    one_le_quadratic_form _ _ hcd
+  have hden : (1 : ℝ) ≤ Complex.normSq (denom g UpperHalfPlane.ρ) := by
+    have heq : Complex.normSq (denom g UpperHalfPlane.ρ) =
+        ((g 1 0 ^ 2 - g 1 0 * g 1 1 + g 1 1 ^ 2 : ℤ) : ℝ) := by
+      rw [ModularGroup.denom_apply]
+      simp only [Complex.normSq_apply, Complex.add_re, Complex.add_im, Complex.mul_re,
+        Complex.mul_im, Complex.intCast_re, Complex.intCast_im, UpperHalfPlane.coe_re,
+        UpperHalfPlane.coe_im]
+      rw [show (UpperHalfPlane.ρ).re = -1 / 2 from rfl,
+        show (UpperHalfPlane.ρ).im = Real.sqrt 3 / 2 from rfl]
+      push_cast
+      linear_combination ((g 1 0 : ℤ) : ℝ) ^ 2 / 4 * h3
+    rw [heq]
+    exact_mod_cast hint
+  rw [ModularGroup.im_smul_eq_div_normSq]
+  calc (UpperHalfPlane.ρ).im / Complex.normSq (denom g UpperHalfPlane.ρ)
+      ≤ (UpperHalfPlane.ρ).im := by
+        refine div_le_self ?_ hden
+        rw [gate_im_rho]
+        positivity
+    _ = Real.sqrt 3 / 2 := gate_im_rho
+
+theorem gate_one_half_lt_sqrt_three_div_two : (1 : ℝ) / 2 < Real.sqrt 3 / 2 := by
+  have : (1 : ℝ) < Real.sqrt 3 := by
+    rw [show (1 : ℝ) = Real.sqrt 1 from (Real.sqrt_one).symm]
+    exact Real.sqrt_lt_sqrt (by norm_num) (by norm_num)
+  linarith
+
+theorem gate_S_not_mem_gamma0_two : ModularGroup.S ∉ Gamma0 2 := by
+  intro hmem
+  rw [Gamma0_mem] at hmem
+  exact absurd hmem (by decide)
+
+end FLT.SiegelSetCover
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_CohCarrier_Level.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_CohCarrier_Level.lean
new file mode 100644
index 0000000000..61b2e7f78d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_CohCarrier_Level.lean
@@ -0,0 +1,577 @@
+/-
+Based on Prove2Me node CohCarrier_Level
+(2b4227ec-c42c-5d2f-b911-2f4e7742164b) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import Mathlib.GroupTheory.Transfer
+public import Mathlib.Algebra.Module.Hom
+public import Mathlib.Data.ZMod.Units
+public import Mathlib.Algebra.BigOperators.GroupWithZero.Action
+
+/-!
+# Level subgroups ΓH​(M) and the Hom carrier with operators
+
+Definition: `CohCarrier_Level` (`2b4227ec-c42c-5d2f-b911-2f4e7742164b`), by Claude, 2026-09-05.
+
+For $M : \mathbb{N}$ and $H \le (\mathbb{Z}/M)^\times$, `gamma0Units` is the homomorphism
+$\Gamma_0(M) \to (\mathbb{Z}/M)^\times$ given by Mathlib's `Gamma0Map` (reduction of the lower-right
+entry), made into a unit using that $d\cdot a \equiv 1 \pmod M$ for $\gamma \in \Gamma_0(M)$;
+`GammaH M H` is the subgroup of $\mathrm{SL}_2(\mathbb{Z})$ of those $A \in \Gamma_0(M)$ with
+`gamma0Units M A ∈ H`, so `GammaH M ⊤ = Gamma0 M`, `GammaH M H ≤ Gamma0 M`, and `GammaH M H` is
+normal in $\Gamma_0(M)$ (stated as normality of its `subgroupOf`). Dually `Gamma0Upper ℓ` is the
+subgroup with upper-right entry $\equiv 0 \pmod \ell$; it is a congruence subgroup, hence of finite
+index. The carrier is `H1 M H A := Additive ↥(GammaH M H) →+ A`, i.e. $\mathrm{Hom}(\Gamma_H(M), A)$
+for an abelian group $A$, which is $H^1$ with trivial coefficients; it inherits an $R$-module
+structure when $A$ is one.
+
+The matrix operations `conjUpperMat ℓ` and `conjLowerMat d`, conjugation by $\mathrm{diag}(\ell,1)$
+in the two directions, send $\begin{pmatrix}a&b\\c&d\end{pmatrix}$ to $\begin{pmatrix}a&b/\ell\\
+\ell c&d\end{pmatrix}$ and $\begin{pmatrix}a&\ell b\\ c/\ell&d\end{pmatrix}$, are multiplicative
+where defined, and are mutually inverse. From the first, `conjL` maps $\Gamma_H(M) \cap
+\Gamma^0(\ell)$ into $\Gamma_H(M)$, and `heckeT` ($\ell \ne 0$) is the endomorphism of `H1 M H A`
+obtained by restricting a homomorphism along `conjL` and applying the transfer from this
+finite-index subgroup; `diamondRaw σ`, for $\sigma \in \Gamma_0(M)$, is precomposition with
+conjugation by $\sigma$. The structure `LevelLE M M' H H' d` has fields $M \mid M'$, $d \mid M'/M$,
+and that reduction `ZMod.unitsMap` carries $H'$ into $H$. Given such data, `iotaDeg` is the
+injective homomorphism $\Gamma_{H'}(M') \to \Gamma_H(M)$ by `conjLowerMat d`, whose image has finite
+index (it contains the image of $\Gamma(M'd)$); `iDeg'`/`iDegL` are restriction along it, additively
+and $R$-linearly, and `jDeg`/`jDegL` go the other way, transporting $\varphi$ to the image subgroup
+and applying the additive transfer `coresAdd`. Auxiliary results make the transfer additive in the
+character and compatible with scalars.
+
+**Relation to Mathlib.** Mathlib supplies $\Gamma(N)$, $\Gamma_0(N)$, $\Gamma_1(N)$ and `Gamma0Map`;
+the subgroups $\Gamma_H(M)$ and $\Gamma^0(\ell)$ here are the project's own, built from `Gamma0Map`.
+`coresAdd` is the additive repackaging of Mathlib's `MonoidHom.transfer` via
+`Additive`/`Multiplicative`, together with its additivity and $R$-linearity, which Mathlib states
+only multiplicatively.
+
+**Where it is used.** These subgroups and the Hom carrier $\mathrm{Hom}(\Gamma_H(M), A)$ provide the
+module on which Hecke and diamond operators act in the level-lowering part of the argument, and the
+maps `iDeg`/`jDeg` between two levels are the degeneracy maps used in Ihara-type statements, here
+defined without reference to any pairing.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open Matrix CongruenceSubgroup Matrix.SpecialLinearGroup
+
+open scoped MatrixGroups
+
+namespace CohCarrier
+
+section TransferAdd
+
+variable {G : Type*} [Group G] {K : Subgroup G} {C : Type*} [CommGroup C]
+
+open Subgroup Subgroup.leftTransversals in
+theorem transfer_diff_one [K.FiniteIndex] (S T : K.LeftTransversal) :
+    diff (1 : K →* C) S T = 1 := by
+  simp [diff]
+
+open Subgroup Subgroup.leftTransversals in
+theorem transfer_diff_mul [K.FiniteIndex] (ϕ ψ : K →* C)
+    (S T : K.LeftTransversal) : diff (ϕ * ψ) S T = diff ϕ S T * diff ψ S T := by
+  simp only [diff, MonoidHom.mul_apply, Finset.prod_mul_distrib]
+
+theorem transfer_one [K.FiniteIndex] : MonoidHom.transfer (1 : K →* C) = 1 := by
+  ext g
+  rw [MonoidHom.transfer_def _ default, transfer_diff_one]
+  rfl
+
+theorem transfer_mul [K.FiniteIndex] (ϕ ψ : K →* C) :
+    MonoidHom.transfer (ϕ * ψ) = MonoidHom.transfer ϕ * MonoidHom.transfer ψ := by
+  ext g
+  rw [MonoidHom.mul_apply, MonoidHom.transfer_def _ default, MonoidHom.transfer_def _ default,
+    MonoidHom.transfer_def _ default, transfer_diff_mul]
+
+theorem toMultiplicativeRight_zero {α β : Type*} [MulOneClass α] [AddCommGroup β] :
+    AddMonoidHom.toMultiplicativeRight (0 : Additive α →+ β) = 1 := by
+  ext a
+  simp
+
+theorem toMultiplicativeRight_add {α β : Type*} [MulOneClass α] [AddCommGroup β]
+    (φ ψ : Additive α →+ β) :
+    AddMonoidHom.toMultiplicativeRight (φ + ψ) =
+      AddMonoidHom.toMultiplicativeRight φ * AddMonoidHom.toMultiplicativeRight ψ := by
+  ext a
+  simp [ofAdd_add]
+
+theorem toAdditiveLeft_one {α β : Type*} [MulOneClass α] [AddCommGroup β] :
+    MonoidHom.toAdditiveLeft (1 : α →* Multiplicative β) = 0 := by
+  ext a
+  simp
+
+theorem toAdditiveLeft_mul {α β : Type*} [MulOneClass α] [AddCommGroup β]
+    (f g : α →* Multiplicative β) :
+    MonoidHom.toAdditiveLeft (f * g) = MonoidHom.toAdditiveLeft f + MonoidHom.toAdditiveLeft g := by
+  ext a
+  simp [toAdd_mul]
+
+noncomputable def coresAdd (K : Subgroup G) [K.FiniteIndex] {B : Type*} [AddCommGroup B]
+    (φ : Additive ↥K →+ B) : Additive G →+ B :=
+  MonoidHom.toAdditiveLeft (MonoidHom.transfer (AddMonoidHom.toMultiplicativeRight φ))
+
+theorem coresAdd_zero (K : Subgroup G) [K.FiniteIndex] {B : Type*} [AddCommGroup B] :
+    coresAdd K (0 : Additive ↥K →+ B) = 0 := by
+  simp only [coresAdd, toMultiplicativeRight_zero, transfer_one,
+    toAdditiveLeft_one]
+
+theorem coresAdd_add (K : Subgroup G) [K.FiniteIndex] {B : Type*} [AddCommGroup B]
+    (φ ψ : Additive ↥K →+ B) : coresAdd K (φ + ψ) = coresAdd K φ + coresAdd K ψ := by
+  simp only [coresAdd, toMultiplicativeRight_add, transfer_mul,
+    toAdditiveLeft_mul]
+
+theorem coresAdd_smul (K : Subgroup G) [K.FiniteIndex] {R B : Type*} [Semiring R] [AddCommGroup B]
+    [Module R B] (r : R) (φ : Additive ↥K →+ B) : coresAdd K (r • φ) = r • coresAdd K φ := by
+  ext g
+  simp only [coresAdd, MonoidHom.toAdditiveLeft_apply_apply, AddMonoidHom.smul_apply,
+    MonoidHom.transfer_def _ default, Subgroup.leftTransversals.diff, toAdd_prod,
+    AddMonoidHom.toMultiplicativeRight_apply_apply, toAdd_ofAdd, Finset.smul_sum]
+
+end TransferAdd
+
+section Level
+
+variable (M : ℕ)
+
+def Gamma0Upper (ℓ : ℕ) : Subgroup SL(2, ℤ) where
+  carrier := { g | (g 0 1 : ZMod ℓ) = 0 }
+  one_mem' := by simp
+  mul_mem' := by
+    intro a b ha hb
+    simp only [Set.mem_ofPred_eq] at *
+    have h := (Matrix.two_mul_expl a.1 b.1).2.1
+    simp only [coe_mul] at *
+    rw [h]
+    simp [ha, hb]
+  inv_mem' := by
+    intro a ha
+    simp only [Set.mem_ofPred_eq] at *
+    rw [SL2_inv_expl a]
+    simp only [cons_val_zero, cons_val_one, Int.cast_neg, neg_eq_zero] at *
+    exact ha
+
+@[simp]
+theorem mem_Gamma0Upper {ℓ : ℕ} {A : SL(2, ℤ)} : A ∈ Gamma0Upper ℓ ↔ (A 0 1 : ZMod ℓ) = 0 :=
+  Iff.rfl
+
+theorem Gamma0_d_mul_a (γ : Gamma0 M) :
+    ((γ.1 1 1 : ℤ) : ZMod M) * ((γ.1 0 0 : ℤ) : ZMod M) = 1 := by
+  have hdet := Matrix.SpecialLinearGroup.det_coe γ.1
+  rw [Matrix.det_fin_two] at hdet
+  have hc : ((γ.1 1 0 : ℤ) : ZMod M) = 0 := Gamma0_mem.mp γ.2
+  have h := congrArg (fun z : ℤ => (z : ZMod M)) hdet
+  simp only [Int.cast_sub, Int.cast_mul, Int.cast_one, hc, mul_zero, sub_zero] at h
+  rw [mul_comm]
+  exact h
+
+def gamma0Units : Gamma0 M →* (ZMod M)ˣ where
+  toFun γ :=
+    { val := Gamma0Map M γ
+      inv := ((γ.1 0 0 : ℤ) : ZMod M)
+      val_inv := Gamma0_d_mul_a M γ
+      inv_val := by rw [mul_comm]; exact Gamma0_d_mul_a M γ }
+  map_one' := by ext; simp
+  map_mul' γ δ := by ext; exact map_mul (Gamma0Map M) γ δ
+
+@[simp]
+theorem val_gamma0Units (γ : Gamma0 M) : (gamma0Units M γ : ZMod M) = Gamma0Map M γ := rfl
+
+def GammaH (H : Subgroup (ZMod M)ˣ) : Subgroup SL(2, ℤ) :=
+  (H.comap (gamma0Units M)).map (Gamma0 M).subtype
+
+variable {M}
+
+theorem mem_GammaH_iff {H : Subgroup (ZMod M)ˣ} {A : SL(2, ℤ)} :
+    A ∈ GammaH M H ↔ ∃ hA : A ∈ Gamma0 M, gamma0Units M ⟨A, hA⟩ ∈ H := by
+  constructor
+  · rintro ⟨γ, hγ, rfl⟩
+    exact ⟨γ.2, hγ⟩
+  · rintro ⟨hA, h⟩
+    exact ⟨⟨A, hA⟩, h, rfl⟩
+
+theorem GammaH_le_Gamma0 (H : Subgroup (ZMod M)ˣ) : GammaH M H ≤ Gamma0 M := by
+  intro A hA
+  obtain ⟨hA0, _⟩ := mem_GammaH_iff.mp hA
+  exact hA0
+
+theorem GammaH_top : GammaH M ⊤ = Gamma0 M := by
+  ext A
+  rw [mem_GammaH_iff]
+  exact ⟨fun ⟨h, _⟩ => h, fun h => ⟨h, Subgroup.mem_top _⟩⟩
+
+end Level
+
+section Carrier
+
+variable (M : ℕ) (H : Subgroup (ZMod M)ˣ) (A : Type*) [AddCommGroup A]
+
+abbrev H1 : Type _ := Additive ↥(GammaH M H) →+ A
+
+example (R : Type*) [CommRing R] [Module R A] : Module R (H1 M H A) := inferInstance
+
+end Carrier
+
+section Operators
+
+variable (M : ℕ) (H : Subgroup (ZMod M)ˣ) (ℓ : ℕ)
+
+def conjUpperMat (A : SL(2, ℤ)) (h : (ℓ : ℤ) ∣ A 0 1) : SL(2, ℤ) :=
+  ⟨!![A 0 0, A 0 1 / ℓ; A 1 0 * ℓ, A 1 1], by
+    rw [Matrix.det_fin_two_of]
+    have hdet := Matrix.SpecialLinearGroup.det_coe A
+    rw [Matrix.det_fin_two] at hdet
+    have hbc : A 0 1 / ℓ * (A 1 0 * ℓ) = A 0 1 * A 1 0 := by
+      rw [mul_comm (A 1 0) _, ← mul_assoc, Int.ediv_mul_cancel h]
+    rw [hbc]
+    exact hdet⟩
+
+@[simp]
+theorem coe_conjUpperMat (A : SL(2, ℤ)) (h : (ℓ : ℤ) ∣ A 0 1) :
+    (conjUpperMat ℓ A h : Matrix (Fin 2) (Fin 2) ℤ) =
+      !![A 0 0, A 0 1 / ℓ; A 1 0 * ℓ, A 1 1] := rfl
+
+theorem conjUpperMat_mul (A B : SL(2, ℤ)) (hA : (ℓ : ℤ) ∣ A 0 1) (hB : (ℓ : ℤ) ∣ B 0 1)
+    (hAB : (ℓ : ℤ) ∣ (A * B) 0 1) :
+    conjUpperMat ℓ (A * B) hAB = conjUpperMat ℓ A hA * conjUpperMat ℓ B hB := by
+  have h1 : A 0 1 / ℓ * (B 1 0 * ℓ) = A 0 1 * B 1 0 := by
+    rw [mul_comm (B 1 0) _, ← mul_assoc, Int.ediv_mul_cancel hA]
+  have h2 : (A 0 0 * B 0 1 + A 0 1 * B 1 1) / ℓ = A 0 0 * (B 0 1 / ℓ) + A 0 1 / ℓ * B 1 1 := by
+    rw [Int.add_ediv_of_dvd_right (Dvd.dvd.mul_right hA _), Int.mul_ediv_assoc _ hB,
+      mul_comm (A 0 1) (B 1 1), Int.mul_ediv_assoc _ hA, mul_comm (B 1 1)]
+  have h3 : A 1 0 * ℓ * (B 0 1 / ℓ) = A 1 0 * B 0 1 := by
+    rw [mul_assoc, Int.mul_ediv_cancel' hB]
+  have hmul : ∀ i j, (A * B) i j = A i 0 * B 0 j + A i 1 * B 1 j := fun i j => by
+    simp [Matrix.mul_apply, Fin.sum_univ_two]
+  apply Matrix.SpecialLinearGroup.ext
+  intro i j
+  fin_cases i <;> fin_cases j <;>
+    simp [Matrix.mul_apply, hmul, h1, h2, h3]
+  ring
+
+@[simp] theorem conjUpperMat_apply_11 (A : SL(2, ℤ)) (h : (ℓ : ℤ) ∣ A 0 1) :
+    (conjUpperMat ℓ A h) 1 1 = A 1 1 := by
+  simp [conjUpperMat]
+
+@[simp] theorem conjUpperMat_apply_10 (A : SL(2, ℤ)) (h : (ℓ : ℤ) ∣ A 0 1) :
+    (conjUpperMat ℓ A h) 1 0 = A 1 0 * ℓ := by
+  simp [conjUpperMat]
+
+abbrev GammaHUpper : Subgroup ↥(GammaH M H) := (Gamma0Upper ℓ).subgroupOf (GammaH M H)
+
+theorem dvd_of_mem_GammaHUpper (γ : ↥(GammaHUpper M H ℓ)) : (ℓ : ℤ) ∣ (γ : SL(2, ℤ)) 0 1 := by
+  have h : ((γ : ↥(GammaH M H)) : SL(2, ℤ)) ∈ Gamma0Upper ℓ := Subgroup.mem_subgroupOf.mp γ.2
+  rw [mem_Gamma0Upper] at h
+  exact (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp h
+
+theorem conjUpperMat_mem (γ : ↥(GammaHUpper M H ℓ)) :
+    conjUpperMat ℓ (γ : SL(2, ℤ)) (dvd_of_mem_GammaHUpper M H ℓ γ) ∈ GammaH M H := by
+  obtain ⟨hγ0, hγH⟩ := mem_GammaH_iff.mp (γ : ↥(GammaH M H)).2
+  rw [mem_GammaH_iff]
+  refine ⟨?_, ?_⟩
+  · rw [Gamma0_mem, conjUpperMat_apply_10, Int.cast_mul, Gamma0_mem.mp hγ0, zero_mul]
+  · convert hγH using 1
+    ext
+    simp only [val_gamma0Units, Gamma0Map, MonoidHom.coe_mk, OneHom.coe_mk, conjUpperMat_apply_11]
+
+def conjL : ↥(GammaHUpper M H ℓ) →* ↥(GammaH M H) where
+  toFun γ := ⟨conjUpperMat ℓ (γ : SL(2, ℤ)) (dvd_of_mem_GammaHUpper M H ℓ γ),
+    conjUpperMat_mem M H ℓ γ⟩
+  map_one' := by
+    apply Subtype.ext
+    apply Matrix.SpecialLinearGroup.ext
+    intro i j
+    fin_cases i <;> fin_cases j <;> simp [conjUpperMat]
+  map_mul' γ δ :=
+    Subtype.ext (conjUpperMat_mul ℓ (γ : SL(2, ℤ)) (δ : SL(2, ℤ)) (dvd_of_mem_GammaHUpper M H ℓ γ)
+      (dvd_of_mem_GammaHUpper M H ℓ δ) (dvd_of_mem_GammaHUpper M H ℓ (γ * δ)))
+
+variable (A : Type*) [AddCommGroup A]
+
+theorem Gamma0Upper_isCongruenceSubgroup [NeZero ℓ] : IsCongruenceSubgroup (Gamma0Upper ℓ) := by
+  refine ⟨ℓ, NeZero.ne _, fun A hA => ?_⟩
+  rw [mem_Gamma0Upper]
+  exact (Gamma_mem.mp hA).2.1
+
+instance Gamma0Upper_finiteIndex [NeZero ℓ] : (Gamma0Upper ℓ).FiniteIndex :=
+  (Gamma0Upper_isCongruenceSubgroup ℓ).finiteIndex
+
+noncomputable def heckeT [NeZero ℓ] : H1 M H A →+ H1 M H A where
+  toFun φ :=
+    MonoidHom.toAdditiveLeft
+      (MonoidHom.transfer ((AddMonoidHom.toMultiplicativeRight φ).comp (conjL M H ℓ)))
+  map_zero' := by
+    simp only [toMultiplicativeRight_zero, MonoidHom.one_comp,
+      transfer_one, toAdditiveLeft_one]
+  map_add' φ ψ := by
+    simp only [toMultiplicativeRight_add, MonoidHom.mul_comp,
+      transfer_mul, toAdditiveLeft_mul]
+
+theorem GammaH_normal_in_Gamma0 :
+    ((GammaH M H).subgroupOf (Gamma0 M)).Normal := by
+  refine ⟨fun n hn g => ?_⟩
+  rw [Subgroup.mem_subgroupOf] at hn ⊢
+  obtain ⟨_, hnH⟩ := mem_GammaH_iff.mp hn
+  rw [mem_GammaH_iff]
+  refine ⟨(g * n * g⁻¹).2, ?_⟩
+  have e1 : (⟨((g * n * g⁻¹ : ↥(Gamma0 M)) : SL(2, ℤ)), (g * n * g⁻¹).2⟩ : ↥(Gamma0 M)) =
+      g * n * g⁻¹ := Subtype.coe_eta _ _
+  have e2 : (⟨(n : SL(2, ℤ)), n.2⟩ : ↥(Gamma0 M)) = n := Subtype.coe_eta _ _
+  rw [e2] at hnH
+  rw [e1, map_mul, map_mul, map_inv, mul_inv_cancel_comm]
+  exact hnH
+
+theorem conj_mem_GammaH (σ : Gamma0 M) (γ : ↥(GammaH M H)) :
+    (σ : SL(2, ℤ)) * (γ : SL(2, ℤ)) * (σ : SL(2, ℤ))⁻¹ ∈ GammaH M H := by
+  obtain ⟨hγ0, _⟩ := mem_GammaH_iff.mp γ.2
+  have hmem : (⟨(γ : SL(2, ℤ)), hγ0⟩ : Gamma0 M) ∈ (GammaH M H).subgroupOf (Gamma0 M) := by
+    rw [Subgroup.mem_subgroupOf]; exact γ.2
+  have := (GammaH_normal_in_Gamma0 M H).conj_mem _ hmem σ
+  rw [Subgroup.mem_subgroupOf] at this
+  exact this
+
+def conjHom (σ : Gamma0 M) : ↥(GammaH M H) →* ↥(GammaH M H) where
+  toFun γ := ⟨(σ : SL(2, ℤ)) * (γ : SL(2, ℤ)) * (σ : SL(2, ℤ))⁻¹, conj_mem_GammaH M H σ γ⟩
+  map_one' := Subtype.ext (by simp)
+  map_mul' γ δ := Subtype.ext (by
+    simp only [Subgroup.coe_mul]
+    group)
+
+def diamondRaw (σ : Gamma0 M) : H1 M H A →+ H1 M H A where
+  toFun φ := φ.comp (MonoidHom.toAdditive (conjHom M H σ))
+  map_zero' := by ext; rfl
+  map_add' := by intro φ ψ; ext; rfl
+
+end Operators
+
+section LevelMaps
+
+variable (M M' : ℕ) (H : Subgroup (ZMod M)ˣ) (H' : Subgroup (ZMod M')ˣ) (d : ℕ)
+
+def conjLowerMat (A : SL(2, ℤ)) (h : (d : ℤ) ∣ A 1 0) : SL(2, ℤ) :=
+  ⟨!![A 0 0, A 0 1 * d; A 1 0 / d, A 1 1], by
+    rw [Matrix.det_fin_two_of]
+    have hdet := Matrix.SpecialLinearGroup.det_coe A
+    rw [Matrix.det_fin_two] at hdet
+    have hbc : A 0 1 * d * (A 1 0 / d) = A 0 1 * A 1 0 := by
+      rw [mul_assoc, mul_comm (d : ℤ) _, Int.ediv_mul_cancel h]
+    rw [hbc]
+    exact hdet⟩
+
+@[simp]
+theorem coe_conjLowerMat (A : SL(2, ℤ)) (h : (d : ℤ) ∣ A 1 0) :
+    (conjLowerMat d A h : Matrix (Fin 2) (Fin 2) ℤ) =
+      !![A 0 0, A 0 1 * d; A 1 0 / d, A 1 1] := rfl
+
+theorem conjLowerMat_mul (A B : SL(2, ℤ)) (hA : (d : ℤ) ∣ A 1 0) (hB : (d : ℤ) ∣ B 1 0)
+    (hAB : (d : ℤ) ∣ (A * B) 1 0) :
+    conjLowerMat d (A * B) hAB = conjLowerMat d A hA * conjLowerMat d B hB := by
+  have h1 : A 0 1 * d * (B 1 0 / d) = A 0 1 * B 1 0 := by
+    rw [mul_assoc, Int.mul_ediv_cancel' hB]
+  have h2 : (A 1 0 * B 0 0 + A 1 1 * B 1 0) / d = A 1 0 / d * B 0 0 + A 1 1 * (B 1 0 / d) := by
+    rw [Int.add_ediv_of_dvd_right (Dvd.dvd.mul_left hB _), Int.mul_ediv_assoc _ hB,
+      mul_comm (A 1 0) (B 0 0), Int.mul_ediv_assoc _ hA, mul_comm (B 0 0)]
+  have h3 : A 1 0 / d * (B 0 1 * d) = A 1 0 * B 0 1 := by
+    rw [mul_comm (B 0 1) _, ← mul_assoc, Int.ediv_mul_cancel hA]
+  have hmul : ∀ i j, (A * B) i j = A i 0 * B 0 j + A i 1 * B 1 j := fun i j => by
+    simp [Matrix.mul_apply, Fin.sum_univ_two]
+  apply Matrix.SpecialLinearGroup.ext
+  intro i j
+  fin_cases i <;> fin_cases j <;>
+  simp [coe_conjLowerMat, Matrix.mul_apply, hmul, h1, h2, h3]
+  ring
+
+structure LevelLE : Prop where
+  dvd : M ∣ M'
+  ddvd : d ∣ M' / M
+  red : ∀ u : (ZMod M')ˣ, u ∈ H' → ZMod.unitsMap dvd u ∈ H
+
+variable {M M' H H' d}
+
+theorem LevelLE.exists_eq (h : LevelLE M M' H H' d) : ∃ e : ℕ, M' = M * (d * e) := by
+  obtain ⟨e, he⟩ := h.ddvd
+  refine ⟨e, ?_⟩
+  rw [← he, Nat.mul_div_cancel' h.dvd]
+
+theorem LevelLE.dvd_entry (h : LevelLE M M' H H' d) (γ : ↥(GammaH M' H')) :
+    (d : ℤ) ∣ (γ : SL(2, ℤ)) 1 0 := by
+  obtain ⟨hγ0, _⟩ := mem_GammaH_iff.mp γ.2
+  have hM' : ((M' : ℕ) : ℤ) ∣ (γ : SL(2, ℤ)) 1 0 :=
+    (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp (Gamma0_mem.mp hγ0)
+  obtain ⟨e, he⟩ := h.exists_eq
+  refine dvd_trans ?_ hM'
+  rw [he]
+  push_cast
+  exact Dvd.intro_left ((M : ℤ) * e) (by ring)
+
+theorem LevelLE.conjLowerMat_mem [NeZero d] (h : LevelLE M M' H H' d) (γ : ↥(GammaH M' H')) :
+    conjLowerMat d (γ : SL(2, ℤ)) (h.dvd_entry γ) ∈ GammaH M H := by
+  obtain ⟨hγ0, hγH⟩ := mem_GammaH_iff.mp γ.2
+  have hM' : ((M' : ℕ) : ℤ) ∣ (γ : SL(2, ℤ)) 1 0 :=
+    (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp (Gamma0_mem.mp hγ0)
+  obtain ⟨e, he⟩ := h.exists_eq
+  obtain ⟨t, ht⟩ := hM'
+  have hd0 : (d : ℤ) ≠ 0 := by exact_mod_cast NeZero.ne d
+  have hquot : (γ : SL(2, ℤ)) 1 0 / (d : ℤ) = (M : ℤ) * (e * t) := by
+    apply Int.ediv_eq_of_eq_mul_right hd0
+    rw [ht, he]
+    push_cast
+    ring
+  have h0 : conjLowerMat d (γ : SL(2, ℤ)) (h.dvd_entry γ) ∈ Gamma0 M := by
+    rw [Gamma0_mem]
+    change (((!![(γ : SL(2, ℤ)) 0 0, (γ : SL(2, ℤ)) 0 1 * d; (γ : SL(2, ℤ)) 1 0 / d, (γ : SL(2, ℤ))
+      1 1]
+      : Matrix (Fin 2) (Fin 2) ℤ) 1 0 : ℤ) : ZMod M) = 0
+    simp only [Matrix.of_apply, Matrix.cons_val', Matrix.cons_val_zero, Matrix.cons_val_one,
+      Matrix.cons_val_fin_one]
+    rw [hquot]
+    push_cast
+    rw [ZMod.natCast_self, zero_mul]
+  rw [mem_GammaH_iff]
+  refine ⟨h0, ?_⟩
+  have hred := h.red _ hγH
+  convert hred using 1
+  all_goals (ext; simp [gamma0Units, Gamma0Map, conjLowerMat, ZMod.unitsMap])
+
+variable (M M' H H' d)
+
+def iotaDeg [NeZero d] (h : LevelLE M M' H H' d) : ↥(GammaH M' H') →* ↥(GammaH M H) where
+  toFun γ := ⟨conjLowerMat d (γ : SL(2, ℤ)) (h.dvd_entry γ), h.conjLowerMat_mem γ⟩
+  map_one' := by
+    apply Subtype.ext
+    apply Matrix.SpecialLinearGroup.ext
+    intro i j
+    fin_cases i <;> fin_cases j <;> simp [conjLowerMat]
+  map_mul' γ δ :=
+    Subtype.ext (conjLowerMat_mul d (γ : SL(2, ℤ)) (δ : SL(2, ℤ)) (h.dvd_entry γ) (h.dvd_entry δ)
+      (h.dvd_entry (γ * δ)))
+
+variable (A : Type*) [AddCommGroup A]
+
+def iDeg' [NeZero d] (h : LevelLE M M' H H' d) : H1 M H A →+ H1 M' H' A where
+  toFun φ := φ.comp (MonoidHom.toAdditive (iotaDeg M M' H H' d h))
+  map_zero' := by ext; rfl
+  map_add' := by intro φ ψ; ext; rfl
+
+def iDegL (R : Type*) [Semiring R] [Module R A] [NeZero d] (h : LevelLE M M' H H' d) :
+    H1 M H A →ₗ[R] H1 M' H' A where
+  toFun φ := φ.comp (MonoidHom.toAdditive (iotaDeg M M' H H' d h))
+  map_add' := by intro φ ψ; ext; rfl
+  map_smul' := by intro r φ; ext; rfl
+
+theorem conjLowerMat_conjUpperMat [NeZero d] (A : SL(2, ℤ)) (hb : (d : ℤ) ∣ A 0 1)
+    (hc : (d : ℤ) ∣ (conjUpperMat d A hb) 1 0) : conjLowerMat d (conjUpperMat d A hb) hc = A := by
+  have hd : (d : ℤ) ≠ 0 := by exact_mod_cast (NeZero.ne d)
+  apply Matrix.SpecialLinearGroup.ext
+  intro i j
+  fin_cases i <;> fin_cases j <;>
+    simp [conjLowerMat, conjUpperMat, Int.ediv_mul_cancel hb, Int.mul_ediv_cancel _ hd]
+
+theorem Gamma_subgroupOf_le_range_iotaDeg [NeZero M'] [NeZero d] (h : LevelLE M M' H H' d) :
+    (Gamma (M' * d)).subgroupOf (GammaH M H) ≤ (iotaDeg M M' H H' d h).range := by
+  intro γ hγ
+  rw [Subgroup.mem_subgroupOf, Gamma_mem] at hγ
+  obtain ⟨_, h01, h10, h11⟩ := hγ
+  have hMd : ((M' * d : ℕ) : ℤ) ∣ (γ : SL(2, ℤ)) 0 1 :=
+    (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp h01
+  have hMd' : ((M' * d : ℕ) : ℤ) ∣ (γ : SL(2, ℤ)) 1 0 :=
+    (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp h10
+  have hb : (d : ℤ) ∣ (γ : SL(2, ℤ)) 0 1 := dvd_trans (by push_cast; exact Dvd.intro_left _ rfl) hMd
+  set A : SL(2, ℤ) := conjUpperMat d (γ : SL(2, ℤ)) hb with hAdef
+  have hA0 : A ∈ Gamma0 M' := by
+    rw [Gamma0_mem]
+    have : A 1 0 = (γ : SL(2, ℤ)) 1 0 * d := by simp [hAdef, conjUpperMat]
+    rw [this, ZMod.intCast_zmod_eq_zero_iff_dvd]
+    exact Dvd.dvd.mul_right (dvd_trans (by push_cast; exact Dvd.intro _ rfl) hMd') _
+  have hA11 : ((A 1 1 : ℤ) : ZMod M') = 1 := by
+    have hA : A 1 1 = (γ : SL(2, ℤ)) 1 1 := by simp [hAdef, conjUpperMat]
+    rw [hA, ← map_intCast (ZMod.castHom (dvd_mul_right M' d) (ZMod M')), h11, map_one]
+  have hAH : gamma0Units M' ⟨A, hA0⟩ ∈ H' := by
+    have : gamma0Units M' ⟨A, hA0⟩ = 1 := by
+      ext
+      simp only [gamma0Units, MonoidHom.coe_mk, OneHom.coe_mk, Units.val_one, Gamma0Map]
+      exact hA11
+    rw [this]
+    exact one_mem H'
+  have hc : (d : ℤ) ∣ (conjUpperMat d (γ : SL(2, ℤ)) hb) 1 0 := by
+    rw [conjUpperMat_apply_10]; exact dvd_mul_left _ _
+  refine ⟨⟨A, mem_GammaH_iff.mpr ⟨hA0, hAH⟩⟩, Subtype.ext ?_⟩
+  exact conjLowerMat_conjUpperMat d (γ : SL(2, ℤ)) hb hc
+
+instance iotaDeg_range_finiteIndex [NeZero M'] [NeZero d] (h : LevelLE M M' H H' d) :
+    ((iotaDeg M M' H H' d h).range).FiniteIndex := by
+  have : NeZero (M' * d) := ⟨mul_ne_zero (NeZero.ne M') (NeZero.ne d)⟩
+  have : ((Gamma (M' * d)).subgroupOf (GammaH M H)).FiniteIndex := inferInstance
+  exact Subgroup.finiteIndex_of_le (Gamma_subgroupOf_le_range_iotaDeg M M' H H' d h)
+
+theorem iotaDeg_injective [NeZero d] (h : LevelLE M M' H H' d) :
+    Function.Injective (iotaDeg M M' H H' d h) := by
+  intro γ δ hγδ
+  have hmat : conjLowerMat d (γ : SL(2, ℤ)) (h.dvd_entry γ) =
+      conjLowerMat d (δ : SL(2, ℤ)) (h.dvd_entry δ) := congrArg Subtype.val hγδ
+  have e : ∀ i j, (conjLowerMat d (γ : SL(2, ℤ)) (h.dvd_entry γ)) i j =
+      (conjLowerMat d (δ : SL(2, ℤ)) (h.dvd_entry δ)) i j := fun i j => by rw [hmat]
+  have hd : (d : ℤ) ≠ 0 := by exact_mod_cast (NeZero.ne d)
+  apply Subtype.ext
+  apply Matrix.SpecialLinearGroup.ext
+  intro i j
+  fin_cases i <;> fin_cases j
+  · simpa [conjLowerMat] using e 0 0
+  · have h01 := e 0 1
+    simp only [conjLowerMat, Matrix.of_apply, Matrix.cons_val', Matrix.cons_val_zero,
+      Matrix.cons_val_one, Matrix.cons_val_fin_one] at h01
+    exact mul_right_cancel₀ hd h01
+  · have h10 := e 1 0
+    simp only [conjLowerMat, Matrix.of_apply, Matrix.cons_val', Matrix.cons_val_zero,
+      Matrix.cons_val_one, Matrix.cons_val_fin_one] at h10
+    calc (γ : SL(2, ℤ)) 1 0 = d * ((γ : SL(2, ℤ)) 1 0 / d) := (Int.mul_ediv_cancel' (h.dvd_entry
+      γ)).symm
+      _ = d * ((δ : SL(2, ℤ)) 1 0 / d) := by rw [h10]
+      _ = (δ : SL(2, ℤ)) 1 0 := Int.mul_ediv_cancel' (h.dvd_entry δ)
+  · simpa [conjLowerMat] using e 1 1
+
+noncomputable def pushChar [NeZero d] (h : LevelLE M M' H H' d) (φ : H1 M' H' A) :
+    Additive ↥((iotaDeg M M' H H' d h).range) →+ A :=
+  φ.comp (MonoidHom.toAdditive
+    ((iotaDeg M M' H H' d h).ofInjective (iotaDeg_injective M M' H H' d h)).symm.toMonoidHom)
+
+noncomputable def jDeg [NeZero M'] [NeZero d] (h : LevelLE M M' H H' d) :
+    H1 M' H' A →+ H1 M H A where
+  toFun φ := coresAdd _ (pushChar M M' H H' d A h φ)
+  map_zero' := by
+    have : pushChar M M' H H' d A h 0 = 0 := by ext; rfl
+    rw [this, coresAdd_zero]
+  map_add' φ ψ := by
+    have : pushChar M M' H H' d A h (φ + ψ) = pushChar M M' H H' d A h φ + pushChar M M' H H' d A h
+      ψ :=
+      by
+      ext; rfl
+    rw [this, coresAdd_add]
+
+noncomputable def jDegL (R : Type*) [Semiring R] [Module R A] [NeZero M'] [NeZero d]
+    (h : LevelLE M M' H H' d) : H1 M' H' A →ₗ[R] H1 M H A where
+  toFun φ := coresAdd _ (pushChar M M' H H' d A h φ)
+  map_add' φ ψ := by
+    have : pushChar M M' H H' d A h (φ + ψ) = pushChar M M' H H' d A h φ + pushChar M M' H H' d A h
+      ψ :=
+      by
+      ext; rfl
+    rw [this, coresAdd_add]
+  map_smul' r φ := by
+    have : pushChar M M' H H' d A h (r • φ) = r • pushChar M M' H H' d A h φ := by ext; rfl
+    rw [this, coresAdd_smul]
+    rfl
+
+end LevelMaps
+
+end CohCarrier
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_Compat_Mathlib430.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_Compat_Mathlib430.lean
new file mode 100644
index 0000000000..ef0f63e381
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_Compat_Mathlib430.lean
@@ -0,0 +1,430 @@
+/-
+Based on Prove2Me node Compat_Mathlib430
+(fb7bfc90-f39e-5a61-ad50-3d805a046efc) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+/-
+Copyright: the vendored blocks below are verbatim copies from Mathlib (Apache-2.0; see Mathlib's
+LICENSE), release v4.30.0 = leanprover-community/mathlib4 commit
+c5ea00351c28e24afc9f0f84379aa41082b1188f, with declarations RENAMED (suffix `Finsupp` / trailing
+prime) so they do not clash with Mathlib v4.33.0. Bodies are the Mathlib v4.30.0 text with its
+docstrings omitted, otherwise byte-identical unless a line is marked `-- [port]`.
+-/
+
+public import Mathlib.RepresentationTheory.Rep.Basic
+public import Mathlib.Algebra.Group.End
+public import Mathlib.Algebra.GroupWithZero.Action.Basic
+public import Mathlib.Algebra.Ring.AddAut
+public import Mathlib.Algebra.Ring.Action.Submonoid
+public import Mathlib.NumberTheory.RamificationInertia.Galois
+public import Mathlib.RingTheory.Invariant.Galois
+public import Mathlib.FieldTheory.Galois.Basic
+public import Mathlib.Tactic.LinearCombination
+public import Mathlib.Tactic.Ring
+
+/-!
+# Compatibility copies of Mathlib v4.30.0 declarations
+
+Definition: `Compat_Mathlib430` (`fb7bfc90-f39e-5a61-ad50-3d805a046efc`), by Claude, 2026-09-05.
+
+This module contains no new mathematics: it re-declares, under fresh names, a handful of Mathlib
+`v4.30.0` items that Mathlib `v4.33.0` altered, so that statements written against the older library
+keep their meaning. Seven blocks are vendored verbatim (each citing its source lines). Block A gives
+[`Representation.ofMulActionFinsupp k G H`](../def/Compat_Mathlib430.html#L28), the representation
+of a monoid $G$ on the free module $H \to_0 k$ coming from an action of $G$ on $H$, sending $g$ to
+the push-forward of finitely supported functions along $h \mapsto g\cdot h$ (`Finsupp.lmapDomain`),
+with the special cases `leftRegularFinsupp` ($H=G$) and `diagonalFinsupp n` ($H = \mathrm{Fin}\,n
+\to G$), the computation rules on single-point functions and, for $G$ a group, the formula $(g\cdot
+f)(h)=f(g^{-1}h)$; Block B's `ofMulActionFinsuppEquiv` identifies this with Mathlib's `ofMulAction`
+through the coefficient equivalence of the monoid algebra. Block C lifts all of this to the category
+`Rep k G`, adding `ofMulActionFinsuppIso` and the morphism `leftRegularHomFinsupp A x` from the left
+regular representation determined by $x \in A$, with $\mathrm{single}(g,r) \mapsto r\cdot
+\rho_A(g)x$. Block D restores the group structure on `AddAut A` (composition as multiplication,
+`AddEquiv.symm` as inverse) with its thirteen computation lemmas under primed names, the monoid
+homomorphism $G \to \mathrm{AddAut}\,A$ attached to a distributive action, the unit action
+[`AddAut.mulLeft'`](../def/Compat_Mathlib430.html#L203) on a semiring, and the tautological faithful
+`DistribMulAction (AddAut A) A`. Block E copies the predicates on a sequence $W:\mathbb{Z}\to R$:
+[`IsEllSequence'`](../def/Compat_Mathlib430.html#L237) is the three-variable identity
+$W(m+n)W(m-n)W(r)^2 = W(m+r)W(m-r)W(n)^2 - W(n+r)W(n-r)W(m)^2$,
+[`IsDivSequence'`](../def/Compat_Mathlib430.html#L241) is divisibility $W(m)\mid W(n)$ whenever
+$m\mid n$ for naturals, [`IsEllDivSequence'`](../def/Compat_Mathlib430.html#L244) their conjunction;
+the identity satisfies both, and each is stable under scaling by $x \in R$. Block F reinstates the
+notation `α ^+ M` for `FixedPoints.addSubgroup M α`. Block G restates, for a finite group $G$ acting
+as a Galois group on $R \subseteq S$, the counting lemmas with a separability hypothesis on the
+residue extension $(R/\mathfrak p) \subseteq (S/\mathfrak P)$ rather than perfectness: the
+stabiliser of $\mathfrak P$ has order $|\,\mathrm{inertia}\,| \cdot [S/\mathfrak P : R/\mathfrak
+p]$, the product of the number of primes over $\mathfrak p$, the inertia order and that degree is
+$|G|$, the inertia order equals $e(\mathfrak p)$, and the stabiliser order equals $e\cdot f$.
+
+**Relation to Mathlib.** Everything here is a copy of Mathlib material kept under new names (suffix
+`Finsupp`, trailing primes, or re-declared notation), taken from Mathlib v4.30.0 and used because
+Mathlib v4.33.0 renamed, redefined or removed the originals; the ramification lemmas of Block G are
+adapted, assuming separability of the residue field extension where the current Mathlib version
+assumes a perfect residue field.
+
+**Where it is used.** The module is imported by many statement and proof modules across the tree,
+and by 52 statement modules directly, purely to keep their Lean statements textually and
+semantically unchanged after the library update; it contributes no mathematical content of its own
+to the argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+/-! ## Block A
+
+Mathlib v4.30.0 Mathlib/RepresentationTheory/Basic.lean:391-419 (section MulAction), names suffixed
+`Finsupp` -/
+
+namespace Representation
+
+section MulAction
+
+variable (k : Type*) [Semiring k] (G : Type*) [Monoid G] (H : Type*) [MulAction G H]
+
+noncomputable def ofMulActionFinsupp : Representation k G (H →₀ k) where
+  toFun g := Finsupp.lmapDomain k k (g • ·)
+  map_one' := by
+    ext x y
+    simp
+  map_mul' x y := by
+    ext z w
+    simp [mul_smul]
+
+noncomputable abbrev leftRegularFinsupp := ofMulActionFinsupp k G G
+
+noncomputable abbrev diagonalFinsupp (n : ℕ) := ofMulActionFinsupp k G (Fin n → G)
+
+variable {k G H}
+
+theorem ofMulActionFinsupp_def (g : G) :
+    ofMulActionFinsupp k G H g = Finsupp.lmapDomain k k (g • ·) :=
+  rfl
+
+@[simp]
+theorem ofMulActionFinsupp_single (g : G) (x : H) (r : k) :
+    ofMulActionFinsupp k G H g (Finsupp.single x r) = Finsupp.single (g • x) r :=
+  Finsupp.mapDomain_single
+
+end MulAction
+
+/-! ## Block B
+
+Mathlib v4.30.0 Mathlib/RepresentationTheory/Basic.lean:472-483 (section Group) -/
+
+section Group
+
+variable {k G V : Type*} [Semiring k] [Group G] [AddCommMonoid V] [Module k V]
+  (ρ : Representation k G V)
+@[simp]
+theorem ofMulActionFinsupp_apply {H : Type*} [MulAction G H] (g : G) (f : H →₀ k) (h : H) :
+    ofMulActionFinsupp k G H g f h = f (g⁻¹ • h) := by
+  conv_lhs => rw [← smul_inv_smul g h]
+  let h' := g⁻¹ • h
+  change ofMulActionFinsupp k G H g f (g • h') = f h'
+  have hg : Function.Injective (g • · : H → H) := by
+    intro h₁ h₂
+    simp
+  simp only [ofMulActionFinsupp_def, Finsupp.lmapDomain_apply,
+    Finsupp.mapDomain_apply_of_injective, hg]
+
+end Group
+
+section Bridge
+
+variable (k : Type*) [Semiring k] (G : Type*) [Monoid G] (H : Type*) [MulAction G H]
+
+noncomputable def ofMulActionFinsuppEquiv : (ofMulActionFinsupp k G H).Equiv (ofMulAction k G H) :=
+  Equiv.mk (MonoidAlgebra.coeffLinearEquiv k).symm fun g => by
+    rw [ofMulAction_def, ofMulActionFinsupp_def]
+    ext
+    simp
+
+end Bridge
+
+end Representation
+
+/-! ## Block C
+
+Mathlib v4.30.0 Mathlib/RepresentationTheory/Rep/Basic.lean:336-346 and 404-412, names suffixed
+`Finsupp` -/
+
+namespace Rep
+
+open CategoryTheory
+
+universe w' u v
+
+variable {k : Type u} {G : Type v} [Ring k] [Monoid G]
+
+section DL_exclusive
+
+variable (k G)
+
+noncomputable abbrev ofMulActionFinsupp (H : Type w') [MulAction G H] :
+    Rep k G := -- [port] `noncomputable` added (4.30 file had a noncomputable section)
+  of <| Representation.ofMulActionFinsupp k G H
+
+noncomputable abbrev leftRegularFinsupp : Rep k G := -- [port] noncomputable
+  ofMulActionFinsupp k G G
+
+noncomputable abbrev diagonalFinsupp (n : ℕ) : Rep k G := -- [port] noncomputable
+  ofMulActionFinsupp k G (Fin n → G)
+
+noncomputable def ofMulActionFinsuppIso (H : Type w') [MulAction G H] :
+    ofMulActionFinsupp k G H ≅ ofMulAction k G H :=
+  mkIso (Representation.ofMulActionFinsuppEquiv k G H)
+
+end DL_exclusive
+
+noncomputable abbrev leftRegularHomFinsupp (A : Rep k G) (x : A) :
+    leftRegularFinsupp k G ⟶ A := -- [port] noncomputable
+  Rep.ofHom ⟨Finsupp.lift A k G fun g ↦ A.ρ g x, fun g ↦ by ext; simp⟩
+
+theorem leftRegularHomFinsupp_hom_single {A : Rep k G} (g : G) (x : A) (r : k) :
+    (leftRegularHomFinsupp A x).hom (.single g r) = r • A.ρ g x := by
+  simp [leftRegularHomFinsupp]
+
+end Rep
+
+/-! ## Block D — AddAut
+
+Mathlib v4.30.0 Mathlib/Algebra/Group/End.lean:746-801 (+ GroupWithZero/Action/Basic.lean:89-92
+and :104-112, Ring/AddAut.lean:32), lemma names primed
+-/
+
+namespace AddAut
+
+section Compat430
+
+variable (A : Type*) [Add A]
+
+instance : Group (AddAut A) where
+  mul g h := AddEquiv.trans h g
+  one := AddEquiv.refl _
+  inv := AddEquiv.symm
+  mul_assoc _ _ _ := rfl
+  one_mul _ := rfl
+  mul_one _ := rfl
+  inv_mul_cancel := AddEquiv.self_trans_symm
+
+/- The following thirteen lemmas are Mathlib v4.30.0 `Mathlib/Algebra/Group/End.lean:758-801`
+verbatim except that each name carries a trailing prime. -/
+
+@[simp]
+theorem coe_mul' (e₁ e₂ : AddAut A) : ⇑(e₁ * e₂) = e₁ ∘ e₂ :=
+  rfl
+
+@[simp]
+theorem coe_one' : ⇑(1 : AddAut A) = id :=
+  rfl
+
+@[simp]
+theorem coe_inv' (e : AddAut A) : ⇑e⁻¹ = e.symm := rfl
+
+theorem mul_def' (e₁ e₂ : AddAut A) : e₁ * e₂ = e₂.trans e₁ :=
+  rfl
+
+theorem one_def' : (1 : AddAut A) = AddEquiv.refl _ :=
+  rfl
+
+theorem inv_def' (e₁ : AddAut A) : e₁⁻¹ = e₁.symm :=
+  rfl
+
+@[simp]
+theorem mul_apply' (e₁ e₂ : AddAut A) (a : A) : (e₁ * e₂) a = e₁ (e₂ a) :=
+  rfl
+
+@[simp]
+theorem one_apply' (a : A) : (1 : AddAut A) a = a :=
+  rfl
+
+@[simp]
+theorem inv_symm' (e : AddAut A) : e⁻¹.symm = e := rfl
+
+@[simp]
+theorem symm_inv' (e : AddAut A) : e.symm⁻¹ = e := rfl
+
+@[simp]
+theorem inv_apply' (e : AddAut A) (a : A) : e⁻¹ a = e.symm a := rfl
+
+theorem inv_apply_self' (e : AddAut A) (a : A) : e⁻¹ (e a) = a :=
+  AddEquiv.apply_symm_apply _ _
+
+theorem apply_inv_self' (e : AddAut A) (a : A) : e (e⁻¹ a) = a :=
+  AddEquiv.apply_symm_apply _ _
+
+example (e₁ e₂ : AddAut A) : e₁ * e₂ = e₁ + e₂ := rfl
+example : (1 : AddAut A) = 0 := rfl
+example (e : AddAut A) : e⁻¹ = -e := rfl
+
+end Compat430
+
+end AddAut
+
+@[simps]
+def DistribMulAction.toAddAut' (G A : Type*) [Group G] [AddMonoid A] [DistribMulAction G A] :
+    G →* AddAut A where
+  toFun := DistribMulAction.toAddEquiv A
+  map_one' := AddEquiv.ext (one_smul _)
+  map_mul' _ _ := AddEquiv.ext (mul_smul _ _)
+
+@[simps! +simpRhs]
+def AddAut.mulLeft' {R : Type*} [Semiring R] : Rˣ →* AddAut R :=
+  DistribMulAction.toAddAut' _ _
+
+/-!
+### Block D (continued)
+
+ Mathlib v4.30.0 Mathlib/Algebra/GroupWithZero/Action/Basic.lean:104-112: the tautological
+ `DistribMulAction (AddAut A) A` `AddAut.applyDistribMulAction`, its `smul_def` and
+ `apply_faithfulSMul`), dropped in v4.33.0 together with the multiplicative structure;
+vendored with primed names on top of the Group instance above.
+-/
+
+namespace AddAut
+instance applyDistribMulAction' {A : Type*} [AddMonoid A] : DistribMulAction (AddAut A) A where
+  smul := (· <| ·)
+  one_smul _ := rfl
+  mul_smul _ _ _ := rfl
+  smul_zero := AddEquiv.map_zero
+  smul_add := AddEquiv.map_add
+
+@[simp] protected theorem smul_def' {A : Type*} [AddMonoid A] (f : AddAut A) (a : A) :
+    f • a = f a := rfl
+
+instance apply_faithfulSMul' {A : Type*} [AddMonoid A] : FaithfulSMul (AddAut A) A :=
+  ⟨fun h => AddEquiv.ext h⟩
+end AddAut
+
+/-!
+## Block E — elliptic (divisibility) sequence predicates
+
+Mathlib v4.30. Mathlib/NumberTheory/EllipticDivisibilitySequence.lean:78-110 (verbatim; names
+primed). Vendored because Mathlib v4.33.0 (db584cd6, same file :286-295) RENAMED AND REDEFINED them
+(`IsEllipticSequence W := ∀ p q r, IsEllipticNet.rel W p q r 0 = 0`, `IsDvdSequence` over ℤ instead
+of ℕ) and kept the 4.30 names only as deprecated aliases of the NEW predicates. -/
+
+section IsEllDivSequence430
+
+universe u
+
+variable {R : Type u} [CommRing R]
+
+variable (W : ℤ → R)
+
+def IsEllSequence' : Prop :=
+  ∀ m n r : ℤ, W (m + n) * W (m - n) * W r ^ 2 =
+    W (m + r) * W (m - r) * W n ^ 2 - W (n + r) * W (n - r) * W m ^ 2
+
+def IsDivSequence' : Prop :=
+  ∀ m n : ℕ, m ∣ n → W m ∣ W n
+
+def IsEllDivSequence' : Prop :=
+  IsEllSequence' W ∧ IsDivSequence' W
+
+lemma isEllSequence'_id : IsEllSequence' id :=
+  fun _ _ _ => by simp_rw [id_eq]; ring1
+
+lemma isDivSequence'_id : IsDivSequence' id :=
+  fun _ _ => Int.ofNat_dvd.mpr
+
+theorem isEllDivSequence'_id : IsEllDivSequence' id :=
+  ⟨isEllSequence'_id, isDivSequence'_id⟩
+
+variable {W}
+
+lemma IsEllSequence'.smul (h : IsEllSequence' W) (x : R) : IsEllSequence' (x • W) :=
+  fun m n r => by
+    linear_combination (norm := (simp_rw [Pi.smul_apply, smul_eq_mul]; ring1)) x ^ 4 * h m n r
+
+lemma IsDivSequence'.smul (h : IsDivSequence' W) (x : R) : IsDivSequence' (x • W) :=
+  fun m n r => mul_dvd_mul_left x <| h m n r
+
+lemma IsEllDivSequence'.smul (h : IsEllDivSequence' W) (x : R) : IsEllDivSequence' (x • W) :=
+  ⟨h.left.smul x, h.right.smul x⟩
+
+end IsEllDivSequence430
+
+/-! ## Block F: Notation `α ^+ M` for `FixedPoints.addSubgroup M α`
+
+Mathlib v4.30.0 Mathlib/Algebra/Ring/Action/Submonoid.lean:43 (verbatim).
+
+Mathlib v4.33.0 removed the notation line; the definition itself is unchanged, so re-declaring the
+notation keeps every tree statement that uses it textually and semantically identical. -/
+
+notation α "^+" M:51 => FixedPoints.addSubgroup M α
+
+/-! ## Block G Ramification/inertia cardinality lemmas under the separability hypothesis
+
+(adapted from Mathlib v4.30.0, Mathlib/NumberTheory/RamificationInertia/Galois.lean; v4.33.0
+restates them assuming PerfectField of the residue field). Theorems only, primed names; no
+definitions involved. -/
+
+namespace Ideal
+
+section inertia430
+
+variable {R S G : Type*} [CommRing R] [CommRing S] [Algebra R S] [Group G]
+  [MulSemiringAction G S] [IsGaloisGroup G R S] [Finite G]
+
+open scoped Pointwise
+
+attribute [local instance] Ideal.Quotient.field in
+theorem card_stabilizer_eq_card_inertia_mul_finrank' (p : Ideal R) [p.IsMaximal]
+    (P : Ideal S) [P.LiesOver p] [P.IsMaximal] [Algebra.IsSeparable (R ⧸ p) (S ⧸ P)] :
+    Nat.card (MulAction.stabilizer G P) = Nat.card (inertia G P) *
+      Module.finrank (R ⧸ p) (S ⧸ P) := by
+  have : IsGalois (R ⧸ p) (S ⧸ P) := { __ := Ideal.Quotient.normal (A := R) G p P }
+  have := Ideal.Quotient.finite_of_isInvariant G p P
+  have : Subgroup.index _ = _ := Nat.card_congr
+    (Quotient.stabilizerQuotientInertiaEquiv G p P).toEquiv
+  rw [← IsGalois.card_aut_eq_finrank, ← this,
+    ← ((inertia G P).subgroupOf (MulAction.stabilizer G P)).card_mul_index,
+    Nat.card_congr (Subgroup.subgroupOfEquivOfLe (inertia_le_stabilizer (M := G) P)).toEquiv,
+    AddSubgroup.subgroupOf_inertia]
+
+lemma ncard_primesOver_mul_card_inertia_mul_finrank' (p : Ideal R) [p.IsMaximal]
+    (P : Ideal S) [P.LiesOver p] [P.IsMaximal] [Algebra.IsSeparable (R ⧸ p) (S ⧸ P)] :
+    (p.primesOver S).ncard * Nat.card (P.inertia G) *
+      Module.finrank (R ⧸ p) (S ⧸ P) = Nat.card G := by
+  rw [mul_assoc, ← card_stabilizer_eq_card_inertia_mul_finrank',
+    ← Algebra.IsInvariant.orbit_eq_primesOver R S G p P]
+  simpa using Nat.card_congr (MulAction.orbitProdStabilizerEquivGroup G P)
+
+attribute [local instance] Ideal.Quotient.field in
+lemma card_inertia_eq_ramificationIdxIn'
+    [IsDedekindDomain R] [IsDedekindDomain S] [Module.Finite R S]
+    [Module.IsTorsionFree R S]
+    (p : Ideal R) (hp : p ≠ ⊥)
+    (P : Ideal S) [P.LiesOver p] [P.IsMaximal] [Algebra.IsSeparable (R ⧸ p) (S ⧸ P)] :
+    Nat.card (P.inertia G) = Ideal.ramificationIdxIn p S := by
+  have := (show p.IsPrime from P.over_def p ▸ inferInstance).isMaximal hp
+  have H := ncard_primesOver_mul_card_inertia_mul_finrank' (G := G) p P
+  refine mul_right_injective₀ (IsDedekindDomain.primesOver_ncard_ne_zero p S) ?_
+  refine mul_left_injective₀ (b := Module.finrank (R ⧸ p) (S ⧸ P)) ?_ ?_
+  · intro e; simp [e, eq_comm, Nat.card_eq_zero, ‹Finite G›.not_infinite] at H
+  dsimp only
+  rw [H, mul_assoc, ← inertiaDeg_eq_of_isMaximal p P, ← inertiaDegIn_eq_inertiaDeg p P G,
+    ncard_primesOver_mul_ramificationIdxIn_mul_inertiaDegIn p S G]
+
+attribute [local instance] Ideal.Quotient.field in
+lemma card_stabilizer_eq' [IsDedekindDomain R] [IsDedekindDomain S] [Module.Finite R S]
+    [Module.IsTorsionFree R S] (p : Ideal R) (hp : p ≠ ⊥) (P : Ideal S) [P.LiesOver p] [P.IsMaximal]
+    [Algebra.IsSeparable (R ⧸ p) (S ⧸ P)] :
+    Nat.card (MulAction.stabilizer G P) = p.ramificationIdxIn S * p.inertiaDegIn S := by
+  have := (show p.IsPrime from P.over_def p ▸ inferInstance).isMaximal hp
+  rw [card_stabilizer_eq_card_inertia_mul_finrank' p P, card_inertia_eq_ramificationIdxIn' p hp,
+    inertiaDegIn_eq_inertiaDeg p P G, inertiaDeg_eq_of_isMaximal p P]
+
+end inertia430
+
+end Ideal
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_CuspForm_HeckeAlgebra.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_CuspForm_HeckeAlgebra.lean
new file mode 100644
index 0000000000..4a31ff73c0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_CuspForm_HeckeAlgebra.lean
@@ -0,0 +1,152 @@
+/-
+Based on Prove2Me node CuspForm_HeckeAlgebra
+(bd114069-9c27-5163-839b-f4aa0d0740df) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperatorForms
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_heckeTLin_comm
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_heckeTLin_heckeULin_comm
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_heckeULin_comm
+
+/-!
+# Hecke algebras acting on cusp forms for Γ0​(N)
+
+Definition: `CuspForm_HeckeAlgebra` (`bd114069-9c27-5163-839b-f4aa0d0740df`), by Claude, 2026-09-05.
+
+For a level $N$ with `NeZero N`, a weight $k : \mathbb{Z}$ and an arbitrary set $S \subseteq
+\mathbb{N}$ of "omitted" primes, [`CuspForm.heckeGenerators N k
+S`](../def/CuspForm_HeckeAlgebra.html#L14) is the subset of $\operatorname{End}_{\mathbb{C}}
+S_k(\Gamma_0(N))$ consisting of the operators `heckeTLin k hℓ hℓN` for primes $\ell \nmid N$ with
+$\ell \notin S$, together with the operators `heckeULin k hqN` for primes $q \mid N$ with $q \notin
+S$; here `heckeTLin` and `heckeULin` are the project's Hecke endomorphisms of the space of cusp
+forms, supplied by the imported module, and the membership predicate is literally an existential
+over such $\ell$, $q$ with $T$ equal to the corresponding operator. Then [`CuspForm.heckeAlgebra N k
+S`](../def/CuspForm_HeckeAlgebra.html#L18) is the $\mathbb{Z}$-subalgebra `Algebra.adjoin ℤ` of
+$\operatorname{End}_{\mathbb{C}} S_k(\Gamma_0(N))$ generated by that set. Thus $S = \emptyset$ gives
+the full algebra generated by all $T_\ell$ and $U_q$, while any $S$ containing the primes dividing
+$N$ gives an anemic algebra with no $U_q$ generators; all choices of $S$ live inside one ambient
+endomorphism ring.
+
+The remaining declarations are bookkeeping around these two definitions: each generator lies in
+`heckeGenerators` and hence in `heckeAlgebra`; the generating set and the algebra are antitone in
+$S$ (`heckeGenerators_mono`, `heckeAlgebra_mono`); any two generators commute, by case analysis on
+the four possible pairs using the imported commutation theorems `heckeTLin_comm`,
+`heckeTLin_heckeULin_comm`, `heckeULin_comm`. From this the module registers instances that the
+subalgebra is multiplicatively commutative, hence a `CommRing`, and that its additive group is
+torsion-free (proved from injectivity of scaling by a nonzero natural number on the ambient
+$\mathbb{C}$-module). Finally `heckeAlgebra.T` and `heckeAlgebra.U` package the generators as
+elements of the subalgebra, with `rfl` lemmas `coe_T`, `coe_U` identifying their images in
+$\operatorname{End}_{\mathbb{C}} S_k(\Gamma_0(N))$ with `heckeTLin`, `heckeULin`.
+
+**Relation to Mathlib.** Mathlib supplies the space `CuspForm (CongruenceSubgroup.Gamma0 N) k` and
+the subalgebra machinery (`Algebra.adjoin`, `Subalgebra`), but the Hecke operators used as
+generators are the project's own endomorphisms from the imported module; the resulting Hecke algebra
+as a $\mathbb{Z}$-subalgebra of $\operatorname{End}_{\mathbb{C}}$ of cusp forms is a project
+definition.
+
+**Where it is used.** These commutative rings are the $\mathbb{T}$ side of the modularity-lifting
+statements: the $R = \mathbb{T}$ theorems are phrased with an anemic Hecke algebra $\mathbb{T}^S$
+(i.e. $S$ containing the primes dividing the level) localised at a maximal ideal, and residual
+modularity is expressed by the existence of a maximal ideal of such an algebra containing $p$ and
+the elements $T_\ell - a_\ell$. The `CommRing` and torsion-freeness instances are what allow ideals,
+residue fields, localisations and tensor products with $\mathbb{Z}_p$ to be formed directly on the
+subalgebra.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+namespace CuspForm
+
+variable (N : ℕ) [NeZero N] (k : ℤ) (S : Set ℕ)
+
+def heckeGenerators : Set (Module.End ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) k)) :=
+  {T | ∃ (ℓ : ℕ) (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N), ℓ ∉ S ∧ T = heckeTLin k hℓ hℓN} ∪
+    {U | ∃ (q : ℕ) (hqN : q ∣ N), q.Prime ∧ q ∉ S ∧ U = heckeULin k hqN}
+
+def heckeAlgebra : Subalgebra ℤ (Module.End ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) k)) :=
+  Algebra.adjoin ℤ (heckeGenerators N k S)
+
+variable {N k S}
+
+theorem heckeTLin_mem_heckeGenerators {ℓ : ℕ} (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) (hℓS : ℓ ∉ S) :
+    heckeTLin k hℓ hℓN ∈ heckeGenerators N k S :=
+  Or.inl ⟨ℓ, hℓ, hℓN, hℓS, rfl⟩
+
+theorem heckeULin_mem_heckeGenerators {q : ℕ} (hq : q.Prime) (hqN : q ∣ N) (hqS : q ∉ S) :
+    heckeULin k hqN ∈ heckeGenerators N k S :=
+  Or.inr ⟨q, hqN, hq, hqS, rfl⟩
+
+theorem heckeTLin_mem_heckeAlgebra {ℓ : ℕ} (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) (hℓS : ℓ ∉ S) :
+    heckeTLin k hℓ hℓN ∈ heckeAlgebra N k S :=
+  Algebra.subset_adjoin (heckeTLin_mem_heckeGenerators hℓ hℓN hℓS)
+
+theorem heckeULin_mem_heckeAlgebra {q : ℕ} (hq : q.Prime) (hqN : q ∣ N) (hqS : q ∉ S) :
+    heckeULin k hqN ∈ heckeAlgebra N k S :=
+  Algebra.subset_adjoin (heckeULin_mem_heckeGenerators hq hqN hqS)
+
+theorem heckeGenerators_mono {S S' : Set ℕ} (h : S ⊆ S') :
+    heckeGenerators N k S' ⊆ heckeGenerators N k S := by
+  rintro T (⟨ℓ, hℓ, hℓN, hℓS, rfl⟩ | ⟨q, hqN, hq, hqS, rfl⟩)
+  · exact heckeTLin_mem_heckeGenerators hℓ hℓN fun hS => hℓS (h hS)
+  · exact heckeULin_mem_heckeGenerators hq hqN fun hS => hqS (h hS)
+
+theorem heckeAlgebra_mono {S S' : Set ℕ} (h : S ⊆ S') : heckeAlgebra N k S' ≤ heckeAlgebra N k S :=
+  Algebra.adjoin_mono (heckeGenerators_mono h)
+
+theorem commute_of_mem_heckeGenerators {T T' : Module.End ℂ (CuspForm (CongruenceSubgroup.Gamma0 N)
+  k)}
+    (hT : T ∈ heckeGenerators N k S) (hT' : T' ∈ heckeGenerators N k S) : Commute T T' := by
+  rcases hT with ⟨ℓ, hℓ, hℓN, -, rfl⟩ | ⟨q, hqN, -, -, rfl⟩ <;>
+    rcases hT' with ⟨ℓ', hℓ', hℓ'N, -, rfl⟩ | ⟨q', hq'N, -, -, rfl⟩
+  · exact heckeTLin_comm k hℓ hℓN hℓ' hℓ'N
+  · exact heckeTLin_heckeULin_comm k hℓ hℓN hq'N
+  · exact (heckeTLin_heckeULin_comm k hℓ' hℓ'N hqN).symm
+  · exact heckeULin_comm k hqN hq'N
+
+variable (N k S)
+
+instance heckeAlgebra.instIsMulCommutative : IsMulCommutative (heckeAlgebra N k S) :=
+  Algebra.isMulCommutative_adjoin ℤ fun _ hT _ hT' _ => commute_of_mem_heckeGenerators hT hT'
+
+open scoped IsMulCommutative in
+instance heckeAlgebra.instCommRing : CommRing (heckeAlgebra N k S) := inferInstance
+
+instance heckeAlgebra.instIsAddTorsionFree : IsAddTorsionFree (heckeAlgebra N k S) where
+  nsmul_right_injective n hn a b hab := by
+    apply Subtype.ext
+    have h : (n : ℂ) • (a : Module.End ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) k)) =
+        (n : ℂ) • (b : Module.End ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) k)) := by
+      simp only [Nat.cast_smul_eq_nsmul]
+      exact congrArg Subtype.val hab
+    exact smul_right_injective _ (Nat.cast_ne_zero.mpr hn) h
+
+variable {N k S}
+
+def heckeAlgebra.T {ℓ : ℕ} (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) (hℓS : ℓ ∉ S) : heckeAlgebra N k S :=
+  ⟨heckeTLin k hℓ hℓN, heckeTLin_mem_heckeAlgebra hℓ hℓN hℓS⟩
+
+def heckeAlgebra.U {q : ℕ} (hq : q.Prime) (hqN : q ∣ N) (hqS : q ∉ S) : heckeAlgebra N k S :=
+  ⟨heckeULin k hqN, heckeULin_mem_heckeAlgebra hq hqN hqS⟩
+
+@[simp] theorem heckeAlgebra.coe_T {ℓ : ℕ} (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) (hℓS : ℓ ∉ S) :
+    ((heckeAlgebra.T hℓ hℓN hℓS : heckeAlgebra N k S) :
+      Module.End ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) k)) = heckeTLin k hℓ hℓN := rfl
+
+@[simp] theorem heckeAlgebra.coe_U {q : ℕ} (hq : q.Prime) (hqN : q ∣ N) (hqS : q ∉ S) :
+    ((heckeAlgebra.U hq hqN hqS : heckeAlgebra N k S) :
+      Module.End ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) k)) = heckeULin k hqN := rfl
+
+end CuspForm
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_CuspForm_IntegralStructure.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_CuspForm_IntegralStructure.lean
new file mode 100644
index 0000000000..47708c5ffd
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_CuspForm_IntegralStructure.lean
@@ -0,0 +1,67 @@
+/-
+Based on Prove2Me node CuspForm_IntegralStructure
+(1c6c01ae-a8f7-5a51-9e4d-7026b7a6733c) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+
+/-!
+# Integral structure on cusp forms for Γ0​(N)
+
+Definition: `CuspForm_IntegralStructure` (`1c6c01ae-a8f7-5a51-9e4d-7026b7a6733c`), by Claude,
+2026-09-05.
+
+Two declarations about the space `CuspForm (CongruenceSubgroup.Gamma0 N) k` of weight-$k$ cusp forms
+on $\Gamma_0(N)$, for arbitrary $N : \mathbb{N}$ and $k : \mathbb{Z}$, phrased throughout in terms
+of the project's $q$-expansion coefficients [`ModularFormClass.qCoeff f
+n`](../def/FLTPrelim_Modularity.html#L19) (the $n$-th coefficient of the expansion at the cusp
+$\infty$ in $q = e^{2\pi i\tau}$, width $1$ — the same coefficients used in the project's
+normalised-eigenform and Hecke dictionaries).
+
+[`CuspForm.intLattice N k`](../def/CuspForm_IntegralStructure.html#L3) is the $\mathbb{Z}$-submodule
+of `CuspForm (CongruenceSubgroup.Gamma0 N) k` generated (as a $\mathbb{Z}$-span) by the set of those
+cusp forms $f$ such that for every $n : \mathbb{N}$ there is an $m : \mathbb{Z}$ with $a_n(f) = m$
+in $\mathbb{C}$; that is, the span of the forms all of whose Fourier coefficients at $\infty$ are
+rational integers. Note that the spanning set is cut out by a condition on the coefficients only,
+and that the span is taken to make the result a submodule.
+
+[`CuspForm.HasIntegralStructure N k`](../def/CuspForm_IntegralStructure.html#L6) is a proposition:
+the $\mathbb{C}$-span of the underlying set of [`CuspForm.intLattice N
+k`](../def/CuspForm_IntegralStructure.html#L3) is all of `CuspForm (CongruenceSubgroup.Gamma0 N) k`
+(equality with $\top$). Equivalently, $S_k(\Gamma_0(N))$ is spanned over $\mathbb{C}$ by cusp forms
+with integral $q$-expansions, i.e. $S_k(\Gamma_0(N);\mathbb{Z}) \otimes_{\mathbb{Z}} \mathbb{C} =
+S_k(\Gamma_0(N))$. This is a definition only: the module records the statement so that results
+requiring integrality of Hecke eigenvalues can carry it as one named hypothesis, and nothing here
+asserts it for any particular $N$ and $k$. Classically it holds for all $N \ge 1$ and all $k$, by
+the $q$-expansion principle.
+
+**Relation to Mathlib.** Both declarations are the project's own; Mathlib supplies the space
+`CuspForm` for `CongruenceSubgroup.Gamma0 N`, the submodule and span machinery, but no notion of an
+integral lattice of cusp forms or of a rational/integral structure on such spaces.
+
+**Where it is used.** The predicate
+[`CuspForm.HasIntegralStructure`](../def/CuspForm_IntegralStructure.html#L6) is carried as an
+explicit hypothesis by the parts of the development that need Hecke eigenvalues $a_\ell(f)$ of a
+normalised eigenform to be algebraic integers, which is what feeds the construction of the
+mod-$\ell$ representation attached to a Frey package and the residual modularity statements used in
+the Frey–Serre–Ribet step.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+def CuspForm.intLattice (N : ℕ) (k : ℤ) : Submodule ℤ (CuspForm (CongruenceSubgroup.Gamma0 N) k) :=
+  Submodule.span ℤ {f | ∀ n : ℕ, ∃ m : ℤ, ModularFormClass.qCoeff f n = (m : ℂ)}
+
+def CuspForm.HasIntegralStructure (N : ℕ) (k : ℤ) : Prop :=
+  Submodule.span ℂ ((CuspForm.intLattice N k : Submodule ℤ (CuspForm (CongruenceSubgroup.Gamma0 N)
+    k)) :
+    Set (CuspForm (CongruenceSubgroup.Gamma0 N) k)) = ⊤
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_CuspForm_Petersson.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_CuspForm_Petersson.lean
new file mode 100644
index 0000000000..ec8fb57cab
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_CuspForm_Petersson.lean
@@ -0,0 +1,84 @@
+/-
+Based on Prove2Me node CuspForm_Petersson
+(bfc83e84-95d0-55e9-9ce4-4dd7b1796903) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Bounds
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Measure
+public import Mathlib.MeasureTheory.Integral.Bochner.Basic
+
+/-!
+# Petersson inner product of cusp forms for Γ₀(N)
+
+Definition: `CuspForm_Petersson` (`bfc83e84-95d0-55e9-9ce4-4dd7b1796903`), by Claude, 2026-09-05.
+
+Fix a level $N$ and a weight $k \in \mathbb{Z}$, and let $f, g$ be cusp forms of weight $k$ for
+$\Gamma_0(N)$ (Mathlib's `CuspForm (CongruenceSubgroup.Gamma0 N) k`). Two definitions are made.
+First, [`CuspForm.peterssonIntegrand f g`](../def/CuspForm_Petersson.html#L16) is the function on
+the upper half-plane whose value at $\tau$ is the sum, over the coset space
+$\mathrm{SL}(2,\mathbb{Z}) \mathbin{/} \Gamma_0(N)$, of the pointwise Petersson densities
+$\overline{(f\mid_k \sigma^{-1})(\tau)}\,(g\mid_k \sigma^{-1})(\tau)\,(\operatorname{Im}\tau)^k$,
+where $\sigma$ runs through the chosen representatives `q.out` of the cosets $q$, the weight-$k$
+slash action is Mathlib's `∣[k]` and the density is Mathlib's `UpperHalfPlane.petersson`. The sum is
+the finitely-supported sum `∑ᶠ`, so for $N \ge 1$, where the coset space is finite, it is the
+ordinary finite sum of $[\mathrm{SL}(2,\mathbb{Z}) : \Gamma_0(N)]$ terms; for families without
+finite support the `∑ᶠ` convention returns $0$, which is all that is asserted when the index is
+infinite. Second, [`CuspForm.petersson f g`](../def/CuspForm_Petersson.html#L20) is the integral of
+this integrand over `ModularGroup.fd`, the standard fundamental domain for
+$\mathrm{SL}(2,\mathbb{Z})$ acting on $\mathbb{H}$, taken with respect to the volume measure of the
+upper half-plane restricted to that set, i.e. the hyperbolic measure $y^{-2}\,dx\,dy$. Unfolding,
+this is the Petersson product $\langle f, g\rangle = \int_{\Gamma_0(N)\backslash\mathbb{H}}
+\overline{f(\tau)}\,g(\tau)\,(\operatorname{Im}\tau)^k\,\frac{dx\,dy}{y^2}$, realised by unfolding
+the quotient by $\Gamma_0(N)$ into an $\mathrm{SL}(2,\mathbb{Z})$-invariant integrand on a
+fundamental domain for the full modular group; in particular no normalising factor
+$1/[\mathrm{SL}(2,\mathbb{Z}) : \Gamma_0(N)]$ and no factor of the volume of the quotient is
+inserted. The definition is conjugate-linear in $f$ and linear in $g$. The auxiliary
+[`CuspForm.petersson_def`](../def/CuspForm_Petersson.html#L23) restates the defining equation as an
+equality of terms.
+
+**Relation to Mathlib.** Mathlib supplies the pointwise density `UpperHalfPlane.petersson`, the
+weight-$k$ slash action `∣[k]`, the fundamental domain `ModularGroup.fd` and the measure on the
+upper half-plane; the Petersson pairing on spaces of cusp forms of level $N$ assembled from them is
+the project's own.
+
+**Where it is used.** The analytic properties of this pairing — sesquilinearity, conjugate symmetry,
+positive definiteness and self-adjointness of the Hecke operators $T_p$ for $p \nmid N$ — are proved
+elsewhere in the development and used to diagonalise the Hecke action on cusp forms, which is what
+produces the newforms entering the modularity and level-lowering steps.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section DL_Crocus
+
+open scoped MatrixGroups ModularForm
+
+namespace CuspForm
+
+variable {N : ℕ} {k : ℤ}
+
+def peterssonIntegrand (f g : CuspForm (CongruenceSubgroup.Gamma0 N) k) (τ : UpperHalfPlane) : ℂ :=
+  ∑ᶠ q : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N,
+    UpperHalfPlane.petersson k (⇑f ∣[k] (q.out⁻¹ : SL(2, ℤ))) (⇑g ∣[k] (q.out⁻¹ : SL(2, ℤ))) τ
+
+def petersson (f g : CuspForm (CongruenceSubgroup.Gamma0 N) k) : ℂ :=
+  MeasureTheory.integral (MeasureTheory.volume.restrict ModularGroup.fd) (peterssonIntegrand f g)
+
+theorem petersson_def (f g : CuspForm (CongruenceSubgroup.Gamma0 N) k) :
+    petersson f g =
+      MeasureTheory.integral (MeasureTheory.volume.restrict ModularGroup.fd)
+        (peterssonIntegrand f g) := rfl
+
+end CuspForm
+
+end DL_Crocus
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_DedekindDomain_AdicValuation_InlineSpecific.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_DedekindDomain_AdicValuation_InlineSpecific.lean
new file mode 100644
index 0000000000..b21ecea136
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_DedekindDomain_AdicValuation_InlineSpecific.lean
@@ -0,0 +1,597 @@
+/-
+Based on Prove2Me node DedekindDomain_AdicValuation_InlineSpecific
+(e8a5b011-1ab4-5a97-b066-986b3aa7688c) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Group.Int.TypeTags
+public import Mathlib.RingTheory.DedekindDomain.AdicValuation
+public import Mathlib.RingTheory.RamificationInertia.Inertia
+public import Mathlib.RingTheory.Valuation.Discrete.RankOne
+
+/-!
+# Adic completions of Dedekind domains: integers, uniformizers, residue fields
+
+Definition: `DedekindDomain_AdicValuation_InlineSpecific` (`e8a5b011-1ab4-5a97-b066-986b3aa7688c`),
+by Claude, 2026-09-05.
+
+Throughout, $A$ is a Dedekind domain with fraction field $K$ and $v$ a height-one prime of $A$, so
+that Mathlib's $v$-adic valuation $v \colon K \to \mathbb{Z}^{m0} =$ `WithZero (Multiplicative ℤ)`,
+the completion $K_v =$ `v.adicCompletion K` and its valuation ring $\mathcal{O}_v =$
+`v.adicCompletionIntegers K` are available. The module equips these with the structure of a complete
+discrete valuation ring and identifies residue fields.
+
+The definitions proper are: `completionIdeal K v`, the maximal ideal of the local ring
+$\mathcal{O}_v$, characterised by $x \in$ `completionIdeal` iff $v(x) < 1$, equivalently $v(x) \le$
+`ofAdd (-1)`, and more generally $x \in \mathfrak{m}^n$ iff $v(x) \le$ `ofAdd (-n)`;
+`ResidueFieldToCompletionResidueField`, the ring homomorphism $A/v \to \mathcal{O}_v/\mathfrak{m}$
+induced by $A \to \mathcal{O}_v$ (legitimate since `completionIdeal` lies over `v.asIdeal`); and
+`ResidueFieldEquivCompletionResidueField`, the assertion that this homomorphism is bijective,
+packaged as a ring isomorphism, surjectivity resting on approximation of elements of $\mathcal{O}_v$
+by elements of $A$. Consequently the residue degree `Ideal.inertiaDeg'` of `completionIdeal` over
+`v.asIdeal` is $1$.
+
+Alongside these, instances are provided: the valuation on $K_v$ is rank-one discrete;
+`completionIdeal` lies over `v.asIdeal`; $\mathcal{O}_v$ has dimension at most one, is a principal
+ideal ring, and is a discrete valuation ring (also in the notation $\mathcal{O}[K_v]$); and $K_v$ is
+separable as a topological space when $K$ is countable. The supporting theorems include: the closure
+of the image of $A$ in $K_v$ is exactly $\mathcal{O}_v$, hence $A \to \mathcal{O}_v$ has dense
+range; approximation of a $v$-integral element by an element of $A$ within any prescribed bound, and
+its simultaneous form over a finite family of distinct height-one primes; existence of a uniformizer
+$\pi$ with $v(\pi) =$ `ofAdd (-1)`, the factorisation $x = \pi^n u$ of nonzero elements of
+$\mathcal{O}_v$ with $u$ a unit, and $\mathfrak{m} = (\pi)$; and the fact that finitely many
+elements of the completions $K_{v_i}$ can be scaled by a single element of $K$ into the respective
+valuation rings. Private helpers express the integral valuation as $\exp(-\,\mathrm{mult}_{v}(aA))$
+and characterise units of a valuation subring as the elements of valuation $1$.
+
+**Relation to Mathlib.** Built on Mathlib's `IsDedekindDomain.HeightOneSpectrum.adicCompletion` and
+`adicCompletionIntegers`; it supplies the `Valuation.IsRankOneDiscrete`, `Ring.DimensionLEOne`,
+`IsPrincipalIdealRing` and `IsDiscreteValuationRing` instances for those objects, together with the
+residue-field identification. A few auxiliary lemmas on local rings and valuation subrings are kept
+private to this module.
+
+**Where it is used.** These results are the local toolkit used wherever completions at finite places
+of a number field and their residue fields appear, in particular in local–global arguments and in
+the adelic formalism on the automorphic side of the proof.
+
+*Attribution:* this file contains material adapted from third-party Apache-2.0 sources (whole file
+(98%): `FLT/DedekindDomain/AdicValuation.lean` — © 2025 Matthew Jasper; authors: Matthew Jasper;
+`FLT/Mathlib/RingTheory/Valuation/ValuationSubring.lean` — © 2025 Ruben Van de Velde; authors: Ruben
+Van de Velde, Kevin Buzzard, Salvatore Mercuri;
+`FLT/Mathlib/RingTheory/DedekindDomain/AdicValuation.lean` — © 2025 Kevin Buzzard; authors: Kevin
+Buzzard, Salvatore Mercuri). See ATTRIBUTION.md and NOTICE in the source repository.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace IsDedekindDomain.HeightOneSpectrum
+
+private instance {R : Type*} [CommRing R] [IsDedekindDomain R] (K : Type*) [Field K] [Countable K]
+    [Algebra R K] [IsFractionRing R K] (v : HeightOneSpectrum R) :
+    TopologicalSpace.SeparableSpace (v.adicCompletion K) where
+  exists_countable_dense :=
+    ⟨_, Set.countable_range _, HeightOneSpectrum.denseRange_algebraMap (K := K) (v := v)⟩
+
+private lemma intValuation_eq_coe_neg_multiplicity {A : Type*} [CommRing A] [IsDedekindDomain A]
+    (v : HeightOneSpectrum A) {a : A} (hnz : a ≠ 0) :
+    v.intValuation a = WithZero.exp (-(multiplicity v.asIdeal (Ideal.span {a}) : ℤ)) := by
+  classical
+  have hnb : Ideal.span {a} ≠ ⊥ := by
+    rwa [ne_eq, Ideal.span_singleton_eq_bot]
+  rw [intValuation_if_neg _ hnz, Ideal.count_associates_factors_eq hnb v.isPrime v.ne_bot]
+  nth_rw 1 [← normalize_eq v.asIdeal]
+  congr
+  symm
+  apply multiplicity_eq_of_emultiplicity_eq_some
+  rw [← UniqueFactorizationMonoid.emultiplicity_eq_count_normalizedFactors v.irreducible hnb]
+
+end IsDedekindDomain.HeightOneSpectrum
+
+private theorem IsLocalRing.maximalIdeal_le {R : Type*} [CommSemiring R] [IsLocalRing R]
+    {J : Ideal R}
+    (hJ : J ≠ ⊤) (h : IsLocalRing.maximalIdeal R ≤ J) :
+    J.IsMaximal :=
+  (IsLocalRing.maximalIdeal.isMaximal R).eq_of_le hJ h ▸ IsLocalRing.maximalIdeal.isMaximal R
+
+section DL_dung
+
+variable {F : Type*} [Field F]
+
+private lemma ValuationSubring.subtype_inj {R : ValuationSubring F} {x y : R} :
+    R.subtype x = R.subtype y ↔ x = y :=
+  R.subtype_injective.eq_iff
+
+private theorem ValuationSubring.valued_eq_one_of_isUnit {K : Type*} [Field K] {Γ₀ : Type*}
+    [LinearOrderedCommGroupWithZero Γ₀] [hv : Valued K Γ₀] (x : hv.v.valuationSubring)
+    (hx : IsUnit x) : Valued.v x.val = 1 := by
+  obtain ⟨u, hu⟩ := hx
+  apply le_antisymm ((hv.v.mem_valuationSubring_iff _).1 x.2)
+  rw [← Valued.v.map_one (R := K), ← Submonoid.coe_one, ← u.mul_inv, hu,
+    Submonoid.coe_mul, Valued.v.map_mul]
+  nth_rw 2 [← mul_one (Valued.v x.val)]
+  exact mul_le_mul_right ((hv.v.mem_valuationSubring_iff _).1 (u⁻¹.val.property)) _
+
+private theorem ValuationSubring.isUnit_of_valued_eq_one {K : Type*} [Field K] {Γ₀ : Type*}
+    [LinearOrderedCommGroupWithZero Γ₀] [hv : Valued K Γ₀] (x : hv.v.valuationSubring)
+    (hx : Valued.v x.val = 1) : IsUnit x := by
+  have : IsUnit x.val := by rw [isUnit_iff_ne_zero, ne_eq, ← map_eq_zero hv.v, hx]; aesop
+  obtain ⟨u, hu⟩ := this
+  have hu_inv_le : Valued.v u⁻¹.val ≤ 1 := by
+    rw [← one_mul (Valued.v _), ← hx, ← hu, ← Valued.v.map_mul, u.mul_inv, hu, hx, Valued.v.map_one]
+  rw [isUnit_iff_exists]
+  exact ⟨⟨u⁻¹.val, hu_inv_le⟩, ⟨by aesop, by aesop⟩⟩
+
+private theorem ValuationSubring.isUnit_iff_valued_eq_one {K : Type*} [Field K] {Γ₀ : Type*}
+    [LinearOrderedCommGroupWithZero Γ₀] [hv : Valued K Γ₀] (x : hv.v.valuationSubring) :
+    IsUnit x ↔ Valued.v x.val = 1 :=
+  ⟨valued_eq_one_of_isUnit x, isUnit_of_valued_eq_one x⟩
+
+end DL_dung
+
+namespace IsDedekindDomain.HeightOneSpectrum
+
+section Multiplicative
+
+open scoped WithZero
+lemma exists_ofAdd_natCast_of_le_one {x : ℤᵐ⁰} (hx : x ≠ 0) (hx' : x ≤ 1) :
+    ∃ (k : ℕ), (Multiplicative.ofAdd (-(k : ℤ))) = x := by
+  lift x to Multiplicative ℤ using hx
+  induction x with | ofAdd x =>
+  norm_cast at hx'
+  rw [← ofAdd_zero, Multiplicative.ofAdd_le] at hx'
+  obtain ⟨k, hk⟩ := Int.eq_ofNat_of_zero_le (Int.neg_nonneg_of_nonpos hx')
+  use k
+  rw [← hk, Int.neg_neg]
+
+lemma exists_ofAdd_natCast_lt {x : ℤᵐ⁰} (hx : x ≠ 0) :
+    ∃ (k : ℕ), (Multiplicative.ofAdd (-(k : ℤ))) < x := by
+  obtain ⟨y, hnz, hyx⟩ := WithZero.exists_ne_zero_and_lt hx
+  lift x to Multiplicative ℤ using hx
+  lift y to Multiplicative ℤ using hnz
+  induction x with | ofAdd x =>
+  induction y with | ofAdd y =>
+  use y.natAbs
+  apply lt_of_le_of_lt _ hyx
+  norm_cast
+  rw [Multiplicative.ofAdd_le]
+  exact neg_abs_le y
+
+end Multiplicative
+
+variable {A : Type*} (K : Type*) [CommRing A] [Field K] [Algebra A K] [IsFractionRing A K]
+    [IsDedekindDomain A] (v : HeightOneSpectrum A)
+
+lemma ne_zero_of_some_le_intValuation {a : A} {m : Multiplicative ℤ} (h : m ≤ v.intValuation a)
+    : a ≠ 0 := by
+  rintro rfl
+  simp at h
+
+lemma emultiplicity_eq_of_valuation_eq_ofAdd {a : A} {k : ℕ}
+    (hv : v.intValuation a = (Multiplicative.ofAdd (-(k : ℤ)))) :
+    emultiplicity v.asIdeal (Ideal.span {a}) = k := by
+  classical
+  have hnz : a ≠ 0 := ne_zero_of_some_le_intValuation _ (le_of_eq hv.symm)
+  have hnb : Ideal.span {a} ≠ ⊥ := by
+    rwa [ne_eq, Ideal.span_singleton_eq_bot]
+  simp only [intValuation_if_neg _ hnz, WithZero.exp, ofAdd_neg, WithZero.coe_inv, inv_inj,
+    WithZero.coe_inj, EmbeddingLike.apply_eq_iff_eq, Nat.cast_inj] at hv
+  rw [← hv, UniqueFactorizationMonoid.emultiplicity_eq_count_normalizedFactors v.irreducible hnb,
+    Ideal.count_associates_factors_eq hnb v.isPrime v.ne_bot, normalize_eq]
+
+lemma exists_adicValued_mul_sub_le {a b : A} {γ : WithZero (Multiplicative ℤ)} (hγ : γ ≠ 0)
+    (hle : γ ≤ v.intValuation a)
+    (hle' : v.intValuation b ≤ v.intValuation a) :
+    ∃ y, v.intValuation (y * a - b) ≤ γ := by
+  have hγ' : γ ≤ 1 := by
+    apply hle.trans
+    apply intValuation_le_one
+  obtain ⟨n, hn⟩ := exists_ofAdd_natCast_of_le_one hγ hγ'
+  rw [← hn, ← WithZero.exp] at hle ⊢
+  have hnz : a ≠ 0 := ne_zero_of_some_le_intValuation _ hle
+  have hnb : Ideal.span {a} ≠ ⊥ := by
+    rwa [ne_eq, Ideal.span_singleton_eq_bot]
+  rw [intValuation_eq_coe_neg_multiplicity _ hnz, WithZero.exp_le_exp, neg_le_neg_iff,
+    Int.ofNat_le] at hle
+  have hm : emultiplicity v.asIdeal (Ideal.span {a}) ≤ n :=
+    le_of_eq_of_le
+      (emultiplicity_eq_of_valuation_eq_ofAdd v <| intValuation_eq_coe_neg_multiplicity v hnz)
+      (ENat.natCast_le_natCast.mpr hle)
+  have hb : b ∈ v.asIdeal ^ multiplicity v.asIdeal (Ideal.span {a}) := by
+    rwa [← intValuation_le_pow_iff_mem, ← intValuation_eq_coe_neg_multiplicity _ hnz]
+  rw [← Ideal.irreducible_pow_sup_of_ge hnb (irreducible v) n hm] at hb
+  obtain ⟨x, hx, z, hz, hxz⟩ := Submodule.mem_sup.mp hb
+  obtain ⟨y, hy⟩ := Ideal.mem_span_singleton'.mp hz
+  use y
+  rwa [hy, ← hxz, sub_add_cancel_right, intValuation_le_pow_iff_mem, neg_mem_iff]
+
+open MonoidWithZeroHom in
+lemma exists_adicValued_sub_lt_of_adicValued_le_one {x : (WithVal (v.valuation K))}
+    (γ : ((WithZero (Multiplicative ℤ)))ˣ) (hx : Valued.v x ≤ 1) :
+    ∃a, Valued.v ((algebraMap A K a) - (x : v.adicCompletion K)) < γ.val := by
+  obtain ⟨⟨n, d, hd⟩, hnd⟩ := IsLocalization.surj (nonZeroDivisors A) x
+  dsimp only at hnd
+  have hnd' := congr_arg Valued.v hnd
+  simp only [map_mul] at hnd'
+  have hge : Valued.v ((algebraMap A (WithVal (v.valuation K))) d) ≥
+      Valued.v ((algebraMap A (WithVal (v.valuation K))) n) :=
+    calc Valued.v ((algebraMap A (WithVal (v.valuation K))) d)
+          ≥ (valuation K v) x.ofVal *
+            (valuation K v) ((algebraMap A (WithVal (v.valuation K))) d).ofVal :=
+                mul_le_of_le_one_left' hx
+        _ = Valued.v ((algebraMap A (WithVal (v.valuation K))) n) := hnd'
+  simp only [ge_iff_le, WithVal.algebraMap_right_apply, WithVal.valued_toVal] at hge
+  simp only [valuation_of_algebraMap] at hge
+  have hdz : (algebraMap A (WithVal (v.valuation K)) d) ≠ 0 :=
+    IsLocalization.to_map_ne_zero_of_mem_nonZeroDivisors _ (fun _ ↦ id) hd
+  have hv : Valued.v ((algebraMap A (WithVal (v.valuation K)) d)) ≠ 0 := by
+    grind [Valuation.ne_zero_iff]
+  let hu : Valued.v ((algebraMap A (WithVal (v.valuation K)) d)) * γ.val ≠ 0 := by
+    rw [mul_ne_zero_iff]
+    exact ⟨hv, γ.ne_zero⟩
+  obtain ⟨γ', hγ, hγu, hγv⟩ := WithZero.exists_ne_zero_and_lt_and_lt hu hv
+  simp only [WithVal.algebraMap_right_apply, WithVal.valued_toVal, valuation_of_algebraMap] at hγv
+  obtain ⟨a, hval⟩ := exists_adicValued_mul_sub_le v hγ hγv.le hge
+  use a
+  rw [← eq_div_iff_mul_eq hdz] at hnd
+  rw [adicCompletion.valuedAdicCompletion_def, ← adicCompletion.equiv_apply, map_sub,
+    adicCompletion.equiv_apply, adicCompletion.equiv_apply,
+    adicCompletion.toCompletion_ofCompletion, adicCompletion.toCompletion_ofCompletion,
+    ← UniformSpace.Completion.coe_sub, Valued.extensionValuation_apply_coe, hnd, sub_div' hdz,
+    map_div₀]
+  rw [← Valuation.pos_iff Valued.v, WithVal.algebraMap_right_apply, WithVal.valued_toVal] at hdz
+  simp only [WithVal.algebraMap_right_apply,
+    ← WithVal.toVal_mul, ← WithVal.toVal_sub, WithVal.valued_toVal, ← map_mul, ← map_sub] at hγu ⊢
+  grind [div_lt_iff₀' hdz, valuation_of_algebraMap]
+
+open scoped WithZero
+
+local notation "vK" => (Valued.v : Valuation (v.adicCompletion K) ℤᵐ⁰)
+
+instance : Valuation.IsRankOneDiscrete vK where
+  exists_generator_lt_one' := by
+    have h : (v.valuation K).IsRankOneDiscrete := Valuation.IsRankOneDiscrete.mk' (valuation K v)
+    exact ⟨h.generator, by rw [h.generator_zpowers_eq_valueGroup, adicCompletion_valueGroup_eq],
+      h.generator_lt_one⟩
+
+open Valuation.IsRankOneDiscrete in
+theorem closureAlgebraMapIntegers_eq_integers :
+    closure (algebraMap A (v.adicCompletion K)).range =
+    SetLike.coe (v.adicCompletionIntegers K) := by
+  apply subset_antisymm
+  · apply closure_minimal _ (Valued.isClosed_valuationSubring _)
+    rintro b ⟨a, rfl⟩
+    exact coe_mem_adicCompletionIntegers v a
+  · let f := fun (k : WithVal (v.valuation K)) => (k : v.adicCompletion K)
+    suffices h : closure (f '' (f ⁻¹' (adicCompletionIntegers K v))) ⊆
+        closure (algebraMap A (adicCompletion K v)).range by
+      apply Set.Subset.trans _ h
+      exact DenseRange.subset_closure_image_preimage_of_isOpen
+        ((adicCompletion.ofCompletion_surjective K v).denseRange.comp
+          UniformSpace.Completion.denseRange_coe (adicCompletion.continuous_ofCompletion K v))
+        (Valued.isOpen_valuationSubring _)
+    apply closure_minimal _ isClosed_closure
+    rintro k ⟨x, hx, rfl⟩
+    unfold f at hx
+    rw [Set.mem_preimage, SetLike.mem_coe, mem_adicCompletionIntegers,
+        adicCompletion.valued_ofCompletion, Valued.valuedCompletion_apply] at hx
+    rw [mem_closure_iff_nhds_zero]
+    intro U hU
+    rw [Valued.mem_nhds] at hU
+    obtain ⟨γ, hγ⟩ := hU
+    let γ' := Units.mapEquiv (valueGroup₀_equiv_withZeroMulInt _).toMulEquiv γ
+    obtain ⟨a, ha⟩ := exists_adicValued_sub_lt_of_adicValued_le_one K v γ' hx
+    use algebraMap A K a
+    constructor
+    · use a
+      rfl
+    · apply hγ
+      simp only [sub_zero, Set.mem_ofPred_eq]
+      rwa [← (valueGroup₀_equiv_withZeroMulInt_strictMono _).lt_iff_lt,
+        valueGroup₀_equiv_withZeroMulInt_restrict_apply_of_surjective
+        (valuedAdicCompletion_surjective K v)]
+
+theorem denseRange_of_integerAlgebraMap :
+    DenseRange (algebraMap A (v.adicCompletionIntegers K)) := by
+  rw [denseRange_iff_closure_range, Set.eq_univ_iff_forall]
+  intro x
+  rw [closure_subtype]
+  suffices h : Subtype.val ''
+      Set.range ((algebraMap A ↥(adicCompletionIntegers K v))) =
+      (algebraMap A (v.adicCompletion K)).range by
+    rw [h, closureAlgebraMapIntegers_eq_integers K v]
+    exact Subtype.coe_prop x
+  simp only [RingHom.coe_range, ← Set.range_comp']
+  rfl
+
+open Valuation.IsRankOneDiscrete in
+theorem exists_adicValued_sub_lt_of_adicCompletionInteger
+    (x : v.adicCompletionIntegers K) (γ : ℤᵐ⁰ˣ) :
+    ∃a, Valued.v ((algebraMap A K a) - (x : v.adicCompletion K)) < γ.val := by
+  have h := closureAlgebraMapIntegers_eq_integers K v
+  rw [Set.ext_iff] at h
+  specialize h x
+  simp_rw [RingHom.coe_range, Subtype.coe_prop, iff_true, mem_closure_iff_nhds] at h
+  specialize h { y | Valued.v (y - (x : v.adicCompletion K)) < γ.val }
+  have hn : {y | Valued.v (y - (x : v.adicCompletion K)) < γ.val} ∈ nhds x.val := by
+    rw [Valued.mem_nhds]
+    use (Units.mapEquiv (valueGroup₀_equiv_withZeroMulInt vK).toMulEquiv).symm γ
+    have hsurj := (valuedAdicCompletion_surjective K v)
+    intro y hy
+    have hy' := (valueGroup₀_equiv_withZeroMulInt_strictMono vK) hy
+    rw [valueGroup₀_equiv_withZeroMulInt_restrict_apply_of_surjective hsurj] at hy'
+    refine lt_of_lt_of_eq hy' ?_
+    exact MulEquiv.apply_symm_apply (valueGroup₀_equiv_withZeroMulInt vK).toMulEquiv _
+  obtain ⟨z, ⟨hz, a, ha⟩⟩ := h hn
+  use a
+  rw [algebraMap_adicCompletion, Function.comp_apply] at ha
+  rwa [ha]
+
+noncomputable abbrev completionIdeal : Ideal (v.adicCompletionIntegers K) :=
+  IsLocalRing.maximalIdeal (adicCompletionIntegers K v)
+
+lemma mem_completionIdeal_iff (x : v.adicCompletionIntegers K) :
+    x ∈ completionIdeal K v ↔ Valued.v x.val < 1 :=
+  Valuation.mem_maximalIdeal_iff _ _
+
+lemma algebraMap_completionIntegers (x : A) :
+    (algebraMap A (v.adicCompletionIntegers K) x) = (algebraMap A (v.adicCompletion K) x) :=
+  rfl
+
+instance : (v.completionIdeal K).LiesOver v.asIdeal := ⟨by
+    rw [Ideal.under_def]
+    ext x
+    simp only [Ideal.mem_comap, mem_completionIdeal_iff, algebraMap_completionIntegers,
+      valuedAdicCompletion_eq_valuation, valuation_lt_one_iff_mem]⟩
+
+open IsLocalRing in
+noncomputable def ResidueFieldToCompletionResidueField :
+    A ⧸ v.asIdeal →+* ResidueField (v.adicCompletionIntegers K) :=
+  Ideal.quotientMap _ (algebraMap _ _) <| le_of_eq Ideal.LiesOver.over
+
+open IsLocalRing in
+noncomputable def ResidueFieldEquivCompletionResidueField :
+    A ⧸ v.asIdeal ≃+* ResidueField (v.adicCompletionIntegers K) := by
+  apply RingEquiv.ofBijective (ResidueFieldToCompletionResidueField K v)
+    ⟨Ideal.quotientMap_injective' <| ge_of_eq Ideal.LiesOver.over, ?_⟩
+  intro z
+  obtain ⟨x, hx⟩ :=
+    Submodule.Quotient.mk_surjective (p := maximalIdeal ↥(adicCompletionIntegers K v)) z
+  rw [← hx, Ideal.Quotient.mk_eq_mk]
+  suffices ∃ a : A, (ResidueFieldToCompletionResidueField K v) a = Ideal.Quotient.mk _ x by
+    obtain ⟨a, ha⟩ := this
+    refine ⟨a, ha⟩
+  change ∃ a, Ideal.Quotient.mk (maximalIdeal (v.adicCompletionIntegers K)) _ = _
+  simp_rw [Ideal.Quotient.mk_eq_mk_iff_sub_mem, mem_maximalIdeal, mem_nonunits_iff]
+  have hunit (y : v.adicCompletionIntegers K) : ¬IsUnit y ↔ Valued.v y.val < 1 :=
+    Valuation.Integer.not_isUnit_iff_valuation_lt_one
+  simp_rw [hunit]
+  exact exists_adicValued_sub_lt_of_adicCompletionInteger K v x 1
+
+theorem inertiaDeg_asIdeal_completionIdeal :
+    Ideal.inertiaDeg (v.completionIdeal K) A = 1 := by
+  rw [v.asIdeal.inertiaDeg_eq_of_isMaximal]
+  let e : (A ⧸ v.asIdeal) ≃+* ((adicCompletionIntegers K v) ⧸ completionIdeal K v) :=
+    ResidueFieldEquivCompletionResidueField K v
+  have f : (A ⧸ v.asIdeal) ≃ₗ[A ⧸ v.asIdeal]
+      ((adicCompletionIntegers K v) ⧸ completionIdeal K v) := { e with
+    map_smul' := by
+      intro x y
+      simp only [RingHom.id_apply]
+      rw [Algebra.smul_def, Algebra.smul_def]
+      exact e.map_mul x y }
+  rw [← LinearEquiv.finrank_eq f]
+  exact Module.finrank_self _
+
+theorem exists_forall_adicValued_sub_lt {ι : Type*} (s : Finset ι)
+    (e : ι → (WithZero (Multiplicative ℤ))ˣ) (valuation : ι → HeightOneSpectrum A)
+    (injective : Function.Injective valuation)
+    (x : (i : ι) → (valuation i).adicCompletionIntegers K) :
+    ∃ a, ∀ i ∈ s, Valued.v ((algebraMap A K a) - (x i).val) < (e i).val := by
+  choose f hf using fun (i : s) =>
+    exists_adicValued_sub_lt_of_adicCompletionInteger K (valuation i) (x i) (e i)
+  have hexists_e' : ∀ (i : ι), ∃ (e' : ℕ), (Multiplicative.ofAdd (-(e' : ℤ))) < (e i).val := by
+    intro i
+    apply exists_ofAdd_natCast_lt (e i).ne_zero
+  choose e' he' using hexists_e'
+  have hinj : ∀ i ∈ s, ∀ j ∈ s, i ≠ j →
+      (fun i ↦ (valuation i).asIdeal) i ≠ (fun i ↦ (valuation i).asIdeal) j := by
+    intro _ _ _ _
+    exact mt <| fun hij ↦ injective (HeightOneSpectrum.ext hij)
+  obtain ⟨a, ha⟩ := IsDedekindDomain.exists_forall_sub_mem_ideal (s := s)
+    (fun i => (valuation i).asIdeal) e' (fun i hi => (valuation i).prime) hinj f
+  use a
+  intro i hi
+  specialize ha i hi
+  specialize hf ⟨i, hi⟩
+  rw [← intValuation_le_pow_iff_mem, ← valuation_of_algebraMap (K := K),
+    ← valuedAdicCompletion_eq_valuation, algebraMap.coe_sub] at ha
+  refine lt_of_le_of_lt ?_ (Valuation.map_add_lt _ (ha.trans_lt (he' i)) hf)
+  apply le_of_eq
+  congr
+  rw [add_sub, sub_eq_sub_iff_add_eq_add, add_right_cancel_iff,
+    add_comm_sub, add_sub, eq_sub_iff_add_eq]
+  rfl
+
+lemma adicCompletion.eq_mul_nonZeroDivisor_inv_adicCompletionIntegers (v : HeightOneSpectrum A)
+    (x : v.adicCompletion K) :
+    ∃a ∈ nonZeroDivisors A, ∃b ∈ v.adicCompletionIntegers K, x = (algebraMap A K a)⁻¹ • b := by
+  obtain ⟨a, hz, ha⟩ :=
+    adicCompletion.mul_nonZeroDivisor_mem_adicCompletionIntegers v x
+  use a, hz, (algebraMap A K a) • x
+  constructor
+  · rwa [Algebra.smul_def, ← IsScalarTower.algebraMap_apply, mul_comm]
+  · rw [smul_smul, inv_mul_cancel₀, one_smul]
+    exact IsLocalization.to_map_ne_zero_of_mem_nonZeroDivisors K (fun _ ↦ id) hz
+
+lemma adicCompletion.eq_mul_pi_adicCompletionIntegers {ι : Type*} [Finite ι]
+    (valuation : ι → HeightOneSpectrum A) (x : (i : ι) → (valuation i).adicCompletion K) :
+      ∃k : K, ∃y ∈ Set.pi Set.univ (fun (i : ι) ↦ ((valuation i).adicCompletionIntegers K).carrier),
+      x = k • y := by
+  classical
+  let := Fintype.ofFinite ι
+  choose f hf using fun (i : ι) =>
+    eq_mul_nonZeroDivisor_inv_adicCompletionIntegers K (valuation i) (x i)
+  use (algebraMap A K (∏ i : ι, f i))⁻¹, (algebraMap A K (∏ i : ι, f i)) • x
+  have hz : ∀ (i : ι), (algebraMap A K) (f i) ≠ 0 := fun i =>
+    IsLocalization.to_map_ne_zero_of_mem_nonZeroDivisors K (fun _ ↦ id) (hf i).left
+  constructor
+  · rintro i -
+    obtain ⟨b, hb, hx⟩ := (hf i).right
+    beta_reduce
+    rw [Pi.smul_apply, algebraMap_smul, Subsemiring.coe_carrier_toSubmonoid,
+        Subring.coe_toSubsemiring, SetLike.mem_coe, ValuationSubring.mem_toSubring, hx,
+        ← Finset.prod_erase_mul _ f (Finset.mem_univ i), mul_smul,
+        ← IsScalarTower.smul_assoc (f i), Algebra.smul_def (f i), mul_inv_cancel₀ (hz i), one_smul,
+        Algebra.smul_def]
+    apply mul_mem (coe_mem_adicCompletionIntegers _ _) hb
+  · rw [smul_smul, inv_mul_cancel₀, one_smul]
+    simp [Finset.prod_ne_zero_iff, hz]
+
+namespace adicCompletion
+
+open scoped algebraMap in
+theorem exists_uniformizer (v : HeightOneSpectrum A) :
+    ∃ π : v.adicCompletionIntegers K, Valued.v π.1 = Multiplicative.ofAdd (- 1 : ℤ) := by
+  obtain ⟨π, hπ⟩ := v.intValuation_exists_uniformizer
+  use π
+  rw [← WithZero.exp, ← hπ, ← ValuationSubring.algebraMap_apply, ← IsScalarTower.algebraMap_apply,
+    v.valuedAdicCompletion_eq_valuation, v.valuation_of_algebraMap]
+
+variable {K} in
+theorem uniformizer_ne_zero {v : HeightOneSpectrum A}
+    {π : v.adicCompletionIntegers K} (hπ : Valued.v π.1 = Multiplicative.ofAdd (-1 : ℤ)) :
+    π ≠ 0 := by
+  contrapose! hπ
+  simp [hπ]
+
+variable {K} in
+open scoped Multiplicative in
+theorem uniformizer_not_isUnit {π : v.adicCompletionIntegers K}
+    (hπ : Valued.v π.1 = Multiplicative.ofAdd (-1 : ℤ)) :
+    ¬IsUnit (π : v.adicCompletionIntegers K) := by
+  rw [show IsUnit π ↔ Valued.v π.val = 1 from
+    ValuationSubring.isUnit_iff_valued_eq_one π, ← WithZero.coe_one, ← ofAdd_zero, hπ]
+  apply ne_of_lt
+  rw [WithZero.coe_lt_coe, Multiplicative.ofAdd_lt]
+  omega
+
+theorem eq_pow_uniformizer_mul_unit {x : v.adicCompletionIntegers K} (hx : x ≠ 0)
+    {π : v.adicCompletionIntegers K} (hπ : Valued.v π.1 = Multiplicative.ofAdd (-1 : ℤ)) :
+    ∃ (n : ℕ) (u : (v.adicCompletionIntegers K)ˣ), x = π ^ n * u := by
+  have hx' : Valued.v x.1 ≠ 0 := by simp [hx]
+  let m := - Multiplicative.toAdd (WithZero.unzero hx')
+  have hm₀ : 0 ≤ m := by
+    simp_rw [m, Right.nonneg_neg_iff, ← toAdd_one, Multiplicative.toAdd_le]
+    rw [← WithZero.coe_le_coe]; exact (WithZero.coe_unzero _).symm ▸ x.2
+  have hpow : Valued.v (π ^ (-m) * x.val) = 1 := by
+    rw [Valued.v.map_mul, map_zpow₀, hπ, ofAdd_neg, WithZero.coe_inv,
+      inv_zpow', neg_neg, ← WithZero.coe_zpow, ← Int.ofAdd_mul, one_mul, ofAdd_neg, ofAdd_toAdd,
+      WithZero.coe_inv, WithZero.coe_unzero, inv_mul_cancel₀ hx']
+  have hmem : π ^ (-m) * x.val ∈ v.adicCompletionIntegers K := le_of_eq hpow
+  let a : v.adicCompletionIntegers K := ⟨π ^ (-m) * x.val, hmem⟩
+  have ha : IsUnit a := ValuationSubring.isUnit_of_valued_eq_one a hpow
+  refine ⟨m.toNat, ha.unit, Subtype.ext ?_⟩
+  simp only [MulMemClass.coe_mul, SubmonoidClass.coe_pow]
+  rw [ha.unit_spec]
+  simp only [a, zpow_neg,
+    ← zpow_natCast, m.toNat_of_nonneg hm₀, ← mul_assoc]
+  rw [mul_inv_cancel₀ (zpow_ne_zero _ <| (by simp [uniformizer_ne_zero hπ])), one_mul]
+
+open scoped algebraMap in
+theorem maximalIdeal_eq_span_uniformizer {π : v.adicCompletionIntegers K}
+    (hπ : Valued.v π.1 = Multiplicative.ofAdd (-1 : ℤ)) :
+    IsLocalRing.maximalIdeal (v.adicCompletionIntegers K) =
+      Ideal.span {(π : v.adicCompletionIntegers K)} := by
+  refine (IsLocalRing.maximalIdeal.isMaximal _).eq_of_le
+    (Ideal.span_singleton_ne_top (uniformizer_not_isUnit v hπ)) (fun x hx => ?_)
+  by_cases hx₀ : x = 0
+  · simp only [hx₀, Ideal.zero_mem]
+  · obtain ⟨n, ⟨u, hu⟩⟩ := eq_pow_uniformizer_mul_unit K v hx₀ hπ
+    have hn : ¬(IsUnit x) := fun h =>
+      (IsLocalRing.maximalIdeal.isMaximal _).ne_top (Ideal.eq_top_of_isUnit_mem _ hx h)
+    replace hn : n ≠ 0 := fun h => by {rw [hu, h, pow_zero, one_mul] at hn; exact hn u.isUnit}
+    simpa [Ideal.mem_span_singleton, hu, IsUnit.dvd_mul_right, Units.isUnit] using dvd_pow_self π hn
+
+instance : Ring.DimensionLEOne (v.adicCompletionIntegers K) where
+  maximalOfPrime {𝔭} h𝔭_ne_bot h𝔭_prime := by
+    let ⟨x, hx⟩ := Submodule.exists_mem_ne_zero_of_ne_bot h𝔭_ne_bot
+    let ⟨π, hπ⟩ := exists_uniformizer K v
+    obtain ⟨n, ⟨u, rfl⟩⟩ := eq_pow_uniformizer_mul_unit K v hx.2 hπ
+    simp only [Units.isUnit, Ideal.mul_unit_mem_iff_mem, ne_eq, mul_eq_zero, pow_eq_zero_iff',
+      Units.ne_zero, or_false, not_and, Decidable.not_not] at hx
+    by_cases hn : n = 0
+    · simp only [hn, pow_zero, ← 𝔭.eq_top_iff_one, implies_true, and_true] at hx
+      exact h𝔭_prime.ne_top hx |>.elim
+    · rw [h𝔭_prime.pow_mem_iff_mem n (by omega), ← 𝔭.span_singleton_le_iff_mem,
+        ← maximalIdeal_eq_span_uniformizer K v hπ] at hx
+      exact IsLocalRing.maximalIdeal_le h𝔭_prime.ne_top hx.1
+
+open scoped algebraMap in
+instance : IsPrincipalIdealRing (v.adicCompletionIntegers K) := by
+  apply IsPrincipalIdealRing.of_prime
+  intro P hP
+  by_cases hP_bot : P = ⊥
+  · exact hP_bot ▸ bot_isPrincipal
+  · let ⟨π, hπ⟩ := exists_uniformizer K v
+    use π
+    rw [IsLocalRing.eq_maximalIdeal (hP.isMaximal hP_bot)]
+    exact maximalIdeal_eq_span_uniformizer K v hπ
+
+instance : IsDiscreteValuationRing (v.adicCompletionIntegers K) where
+  not_a_field' := by
+    let ⟨π, hπ⟩ := exists_uniformizer K v
+    rw [maximalIdeal_eq_span_uniformizer K v hπ]
+    intro h
+    simp only [Ideal.span_singleton_eq_bot] at h
+    exact uniformizer_ne_zero hπ h
+
+open scoped Valued in
+instance : IsDiscreteValuationRing (𝒪[v.adicCompletion K]) :=
+  inferInstanceAs (IsDiscreteValuationRing (v.adicCompletionIntegers K))
+
+lemma mem_completionIdeal_pow {n : ℕ} (x : v.adicCompletionIntegers K) :
+    x ∈ (v.completionIdeal K) ^ n ↔ Valued.v x.val ≤ ↑(Multiplicative.ofAdd (-(n : ℤ))) := by
+  obtain ⟨π, hπ⟩ := exists_uniformizer K v
+  unfold completionIdeal
+  rw [maximalIdeal_eq_span_uniformizer K v hπ, Ideal.span_singleton_pow, Ideal.mem_span_singleton']
+  have hvalπ_pow : (Valued.v π.val) ^ n = (Multiplicative.ofAdd (-n : ℤ)) := by
+    rw [hπ]
+    norm_num
+    norm_cast
+    rw [← ofAdd_nsmul, Nat.smul_one_eq_cast]
+  constructor
+  · rintro ⟨a, rfl⟩
+    simp only [MulMemClass.coe_mul, SubmonoidClass.coe_pow, map_mul, map_pow, ofAdd_neg,
+      WithZero.coe_inv]
+    apply mul_le_of_le_one_of_le a.prop <| le_of_eq hvalπ_pow
+  · intro hx
+    set a := x.val / (π ^ n) with ha'
+    have ha : Valued.v a ≤ 1 := by
+      rwa [ha', Valuation.map_div, Valuation.map_pow, hvalπ_pow,
+        div_le_one₀ (WithZero.zero_lt_coe _)]
+    use ⟨a, ha⟩
+    apply Subtype.val_injective
+    simp only [MulMemClass.coe_mul, SubmonoidClass.coe_pow, ha']
+    rw [div_mul_eq_mul_div₀, mul_div_cancel_right₀]
+    apply pow_ne_zero n
+    norm_cast
+    exact uniformizer_ne_zero hπ
+
+end adicCompletion
+
+lemma mem_completionIdeal_iff' (x : v.adicCompletionIntegers K) :
+    x ∈ v.completionIdeal K ↔ Valued.v x.val ≤ ↑(Multiplicative.ofAdd (-(1 : ℤ))) := by
+  rw [← Submodule.pow_one (v.completionIdeal K), adicCompletion.mem_completionIdeal_pow,
+    Int.natCast_one]
+
+lemma completionIdeal_ne_bot : completionIdeal K v ≠ ⊥ := IsDiscreteValuationRing.not_a_field _
+
+end IsDedekindDomain.HeightOneSpectrum
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_DualIsogenyAPI.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_DualIsogenyAPI.lean
new file mode 100644
index 0000000000..3dcf7aff05
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_DualIsogenyAPI.lean
@@ -0,0 +1,369 @@
+/-
+Based on Prove2Me node DualIsogenyAPI
+(224efe81-909d-5158-96a4-5c5819309a18) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Order.Ring.Star
+public import Mathlib.Analysis.Normed.Ring.Lemmas
+public import Mathlib.Data.Int.Star
+public import Mathlib.Tactic.NoncommRing
+
+/-!
+# Abstract dual pairs and dual endomorphism data
+
+Definition: `DualIsogenyAPI` (`224efe81-909d-5158-96a4-5c5819309a18`), by Claude, 2026-09-05.
+
+For additive abelian groups $A,B$, the predicate [`AddMonoidHom.IsDualPair φ ψ
+n`](../def/DualIsogenyAPI.html#L9), with $\varphi : A \to B$, $\psi : B \to A$ additive maps and $n
+\in \mathbb{Z}$, is a two-field proposition: $\psi(\varphi a) = n \cdot a$ for all $a \in A$ and
+$\varphi(\psi b) = n \cdot b$ for all $b \in B$ (integer scalar action). It is symmetric in the two
+maps (`IsDualPair.symm`, `isDualPair_comm`); for composable pairs the composites form a dual pair
+with the roles reversed and the integers multiplied (`IsDualPair.comp`); the multiplication-by-$m$
+endomorphism is self-paired with integer $m^2$, and the identity with $1$. Further lemmas give
+uniqueness of the partner when $\varphi$ is surjective or injective, the inclusions $\ker\psi
+\subseteq B[n]$ and $\ker\varphi \subseteq A[n]$, membership of $n \cdot a$ in the range of $\psi$,
+surjectivity of $\psi$ when $A$ is $n$-divisible, and stability under negating both maps.
+
+[`AddMonoid.End.DualEndData φ`](../def/DualIsogenyAPI.html#L83) is a bundled structure on an
+endomorphism $\varphi$ of $A$ carrying a further endomorphism `dual` and integers `trace`, `norm`,
+together with the equations $\varphi + \hat\varphi = t$, $\varphi\hat\varphi = n$ and
+$\hat\varphi\varphi = n$ in $\mathrm{End}(A)$ (integers acting through $\mathbb{Z} \to
+\mathrm{End}(A)$); the equations are fields, so the data is a choice, not a property. Consequences:
+the pair $(\varphi,\hat\varphi)$ is a dual pair with integer $n$, the two commute, $\hat\varphi = t
+- \varphi$, the relation $\varphi^2 - t\varphi + n = 0$ holds in operator and pointwise form, and
+the roles of $\varphi,\hat\varphi$ may be exchanged. `intLinComb` produces data for $a + b\varphi$
+with dual $a + b\hat\varphi$, trace $2a + tb$ and norm $a^2 + tab + nb^2$, whence the discriminant
+scales by $b^2$ and negativity of $t^2 - 4n$ is preserved for $b \neq 0$. `ofCharPoly` builds data
+from a relation $\varphi^2 - t\varphi + n = 0$, and `dualEndData_intCast` treats $\varphi = m$.
+
+Two named predicates on a subring $S \subseteq \mathrm{End}(A)$ record what is not proved here:
+[`DualIsogenyExistence S`](../def/DualIsogenyAPI.html#L274) asserts that every $\varphi \in S$
+admits dual data with dual in $S$ and non-negative norm, and [`DualAdditivityResidual
+S`](../def/DualIsogenyAPI.html#L277) that for $\varphi,\psi \in S$ and arbitrary dual data for each
+there is dual data for $\varphi + \psi$ whose dual is the sum of the two duals. The first holds for
+$S = \bot$, the subring of integer multiplications. Small computations in $\mathrm{End}(\mathbb{Z})$
+check the norm, trace and discriminant formulae on numerical instances.
+
+**Relation to Mathlib.** Mathlib has no abstract notion of a dual pair of additive maps or of dual
+data for an additive endomorphism; both are the project's own, stated for `AddMonoidHom` and for the
+endomorphism ring `AddMonoid.End` with integers acting via `zsmul` and `Int.cast`.
+
+**Where it is used.** This is the purely group-theoretic substrate for degrees of isogenies: the
+dual-pair relations and the quadratic relation $\varphi^2 - t\varphi + n = 0$ with its norm form
+$(a+b\varphi)(a+b\hat\varphi) = a^2 + tab + nb^2$ are what later modules use for endomorphism rings
+of elliptic curves and for the Frobenius–Verschiebung relation on curves over finite fields, with no
+curves or schemes appearing at this level.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace AddMonoidHom
+
+variable {A B C : Type*} [AddCommGroup A] [AddCommGroup B] [AddCommGroup C]
+
+structure IsDualPair (φ : A →+ B) (ψ : B →+ A) (n : ℤ) : Prop where
+  comp_left : ∀ a, ψ (φ a) = n • a
+  comp_right : ∀ b, φ (ψ b) = n • b
+
+theorem IsDualPair.symm {φ : A →+ B} {ψ : B →+ A} {n : ℤ} (h : IsDualPair φ ψ n) :
+    IsDualPair ψ φ n :=
+  ⟨h.comp_right, h.comp_left⟩
+
+theorem isDualPair_comm {φ : A →+ B} {ψ : B →+ A} {n : ℤ} :
+    IsDualPair φ ψ n ↔ IsDualPair ψ φ n :=
+  ⟨IsDualPair.symm, IsDualPair.symm⟩
+
+theorem IsDualPair.comp {φ' : A →+ B} {φ : B →+ A} {m : ℤ} {ψ' : B →+ C} {ψ : C →+ B}
+    {n : ℤ} (hφ : IsDualPair φ' φ m) (hψ : IsDualPair ψ' ψ n) :
+    IsDualPair (ψ'.comp φ') (φ.comp ψ) (m * n) := by
+  refine ⟨fun a => ?_, fun c => ?_⟩
+  · change φ (ψ (ψ' (φ' a))) = (m * n) • a
+    rw [hψ.comp_left, map_zsmul, hφ.comp_left, mul_zsmul']
+  · change ψ' (φ' (φ (ψ c))) = (m * n) • c
+    rw [hφ.comp_right, map_zsmul, hψ.comp_right, mul_zsmul]
+
+theorem isDualPair_intCast (m : ℤ) :
+    IsDualPair (A := A) (B := A) (m : AddMonoid.End A) (m : AddMonoid.End A) (m ^ 2) := by
+  have key : ∀ a : A, (m : AddMonoid.End A) ((m : AddMonoid.End A) a) = m ^ 2 • a := by
+    intro a
+    have h : (m : AddMonoid.End A) ((m : AddMonoid.End A) a)
+        = ((m : AddMonoid.End A) * (m : AddMonoid.End A)) a := rfl
+    rw [h, ← Int.cast_mul, AddMonoid.End.intCast_apply, sq]
+  exact ⟨key, key⟩
+
+theorem isDualPair_id_one : IsDualPair (id A) (id A) 1 :=
+  ⟨fun a => (one_zsmul a).symm, fun a => (one_zsmul a).symm⟩
+
+theorem IsDualPair.left_unique_of_surjective {φ : A →+ B} {ψ : B →+ A} {n : ℤ}
+    (h : IsDualPair φ ψ n) (hφ : Function.Surjective φ) {ψ' : B →+ A}
+    (hψ' : ∀ a, ψ' (φ a) = n • a) : ψ' = ψ := by
+  ext b
+  obtain ⟨a, rfl⟩ := hφ b
+  rw [hψ', h.comp_left]
+
+theorem IsDualPair.right_unique_of_injective {φ : A →+ B} {ψ : B →+ A} {n : ℤ}
+    (h : IsDualPair φ ψ n) (hφ : Function.Injective φ) {ψ' : B →+ A}
+    (hψ' : ∀ b, φ (ψ' b) = n • b) : ψ' = ψ := by
+  ext b; exact hφ (by rw [hψ', h.comp_right])
+
+theorem IsDualPair.ker_le_torsion_left {φ : A →+ B} {ψ : B →+ A} {n : ℤ}
+    (h : IsDualPair φ ψ n) {b : B} (hb : ψ b = 0) : n • b = 0 := by
+  rw [← h.comp_right b, hb, map_zero]
+
+theorem IsDualPair.ker_le_torsion_right {φ : A →+ B} {ψ : B →+ A} {n : ℤ}
+    (h : IsDualPair φ ψ n) {a : A} (ha : φ a = 0) : n • a = 0 :=
+  h.symm.ker_le_torsion_left ha
+
+theorem IsDualPair.nsmul_mem_range_left {φ : A →+ B} {ψ : B →+ A} {n : ℤ}
+    (h : IsDualPair φ ψ n) (a : A) : n • a ∈ Set.range ψ :=
+  ⟨φ a, h.comp_left a⟩
+
+theorem IsDualPair.surjective_of_divisible {φ : A →+ B} {ψ : B →+ A} {n : ℤ}
+    (h : IsDualPair φ ψ n) (hdiv : ∀ a : A, ∃ a', n • a' = a) :
+    Function.Surjective ψ := by
+  intro a; obtain ⟨a', ha'⟩ := hdiv a; exact ⟨φ a', by rw [h.comp_left, ha']⟩
+
+theorem IsDualPair.neg {φ : A →+ B} {ψ : B →+ A} {n : ℤ} (h : IsDualPair φ ψ n) :
+    IsDualPair (-φ) (-ψ) n :=
+  ⟨fun a => by simp [h.comp_left], fun b => by simp [h.comp_right]⟩
+
+end AddMonoidHom
+
+namespace AddMonoid.End
+
+variable {A : Type*} [AddCommGroup A]
+
+structure DualEndData (φ : AddMonoid.End A) where
+  dual : AddMonoid.End A
+  trace : ℤ
+  norm : ℤ
+  add_dual : φ + dual = (trace : AddMonoid.End A)
+  mul_dual : φ * dual = (norm : AddMonoid.End A)
+  dual_mul : dual * φ = (norm : AddMonoid.End A)
+
+namespace DualEndData
+
+variable {φ : AddMonoid.End A}
+
+theorem isDualPair (D : DualEndData φ) :
+    AddMonoidHom.IsDualPair (A := A) (B := A) φ D.dual D.norm := by
+  refine ⟨fun a => ?_, fun a => ?_⟩
+  · have h := DFunLike.congr_fun D.dual_mul a
+    rwa [AddMonoid.End.intCast_apply] at h
+  · have h := DFunLike.congr_fun D.mul_dual a
+    rwa [AddMonoid.End.intCast_apply] at h
+
+theorem commute (D : DualEndData φ) : Commute φ D.dual := by
+  unfold Commute SemiconjBy; rw [D.mul_dual, D.dual_mul]
+
+theorem dual_eq (D : DualEndData φ) : D.dual = (D.trace : AddMonoid.End A) - φ := by
+  rw [← D.add_dual, add_sub_cancel_left]
+
+theorem charPoly (D : DualEndData φ) :
+    φ * φ - (D.trace : AddMonoid.End A) * φ + (D.norm : AddMonoid.End A) = 0 := by
+  have h := D.dual_mul
+  rw [D.dual_eq, sub_mul] at h
+  rw [← h]; abel
+
+theorem add_dual_apply (D : DualEndData φ) (a : A) :
+    φ a + D.dual a = D.trace • a := by
+  have h : (φ + D.dual) a = (D.trace : AddMonoid.End A) a := by rw [D.add_dual]
+  rwa [AddMonoid.End.intCast_apply] at h
+
+theorem charPoly_apply (D : DualEndData φ) (a : A) :
+    φ (φ a) - D.trace • φ a + D.norm • a = 0 := by
+  have h1 := D.isDualPair.comp_left a
+  have h2 := D.add_dual_apply (φ a)
+  rw [← h1, ← h2, sub_add_cancel_left]; exact neg_add_cancel _
+
+def symm (D : DualEndData φ) : DualEndData D.dual where
+  dual := φ
+  trace := D.trace
+  norm := D.norm
+  add_dual := by rw [← D.add_dual, add_comm]
+  mul_dual := D.dual_mul
+  dual_mul := D.mul_dual
+
+@[simp] theorem symm_dual (D : DualEndData φ) : D.symm.dual = φ := rfl
+@[simp] theorem symm_trace (D : DualEndData φ) : D.symm.trace = D.trace := rfl
+@[simp] theorem symm_norm (D : DualEndData φ) : D.symm.norm = D.norm := rfl
+
+private theorem intLin_apply (a b : ℤ) (ψ : AddMonoid.End A) (x : A) :
+    ((a : AddMonoid.End A) + (b : AddMonoid.End A) * ψ) x = a • x + b • ψ x := by
+  change (a : AddMonoid.End A) x + (b : AddMonoid.End A) (ψ x) = _
+  rw [AddMonoid.End.intCast_apply, AddMonoid.End.intCast_apply]
+
+theorem dual_charPoly (D : DualEndData φ) :
+    D.dual * D.dual - (D.trace : AddMonoid.End A) * D.dual
+      + (D.norm : AddMonoid.End A) = 0 :=
+  D.symm.charPoly
+
+theorem intLinComb_mul_dual (D : DualEndData φ) (a b : ℤ) :
+    ((a : AddMonoid.End A) + (b : AddMonoid.End A) * φ)
+      * ((a : AddMonoid.End A) + (b : AddMonoid.End A) * D.dual)
+      = ((a ^ 2 + D.trace * a * b + D.norm * b ^ 2 : ℤ) : AddMonoid.End A) := by
+  ext x
+  change ((a : AddMonoid.End A) + b * φ)
+      (((a : AddMonoid.End A) + b * D.dual) x)
+    = ((a ^ 2 + D.trace * a * b + D.norm * b ^ 2 : ℤ) : AddMonoid.End A) x
+  rw [intLin_apply, intLin_apply, AddMonoid.End.intCast_apply,
+    map_add, map_zsmul, map_zsmul]
+  have hcr : φ (D.dual x) = D.norm • x := D.isDualPair.comp_right x
+  have hsum := D.add_dual_apply x
+  calc a • (a • x + b • D.dual x) + b • (a • φ x + b • φ (D.dual x))
+      = (a * a) • x + (a * b) • D.dual x + ((b * a) • φ x + (b * b) • φ (D.dual x)) := by
+        simp only [zsmul_add, ← mul_zsmul]
+    _ = (a * a) • x + (a * b) • (φ x + D.dual x) + (b * b) • φ (D.dual x) := by
+        rw [zsmul_add, mul_comm b a]; abel
+    _ = (a ^ 2 + D.trace * a * b + D.norm * b ^ 2) • x := by
+        rw [hcr, hsum, ← mul_zsmul, ← mul_zsmul, ← add_zsmul, ← add_zsmul]
+        congr 1; ring
+
+def intLinComb (D : DualEndData φ) (a b : ℤ) :
+    DualEndData ((a : AddMonoid.End A) + (b : AddMonoid.End A) * φ) where
+  dual := (a : AddMonoid.End A) + (b : AddMonoid.End A) * D.dual
+  trace := 2 * a + D.trace * b
+  norm := a ^ 2 + D.trace * a * b + D.norm * b ^ 2
+  add_dual := by
+    have h : (a : AddMonoid.End A) + b * φ + ((a : AddMonoid.End A) + b * D.dual)
+        = (a : AddMonoid.End A) + (a : AddMonoid.End A) + b * (φ + D.dual) := by
+      rw [mul_add]; abel
+    rw [h, D.add_dual]
+    ext x
+    change (a : AddMonoid.End A) x + (a : AddMonoid.End A) x
+        + ((b : AddMonoid.End A) * (D.trace : AddMonoid.End A)) x
+      = ((2 * a + D.trace * b : ℤ) : AddMonoid.End A) x
+    rw [show ((b : AddMonoid.End A) * (D.trace : AddMonoid.End A)) x
+          = (b : AddMonoid.End A) ((D.trace : AddMonoid.End A) x) from rfl,
+      AddMonoid.End.intCast_apply, AddMonoid.End.intCast_apply, AddMonoid.End.intCast_apply,
+      AddMonoid.End.intCast_apply, ← add_zsmul, ← mul_zsmul, ← add_zsmul]
+    congr 1; ring
+  mul_dual := D.intLinComb_mul_dual a b
+  dual_mul := D.symm.intLinComb_mul_dual a b
+
+@[simp] theorem intLinComb_norm (D : DualEndData φ) (a b : ℤ) :
+    (D.intLinComb a b).norm = a ^ 2 + D.trace * a * b + D.norm * b ^ 2 := rfl
+
+@[simp] theorem intLinComb_trace (D : DualEndData φ) (a b : ℤ) :
+    (D.intLinComb a b).trace = 2 * a + D.trace * b := rfl
+
+@[simp] theorem intLinComb_dual (D : DualEndData φ) (a b : ℤ) :
+    (D.intLinComb a b).dual = (a : AddMonoid.End A) + (b : AddMonoid.End A) * D.dual := rfl
+
+theorem intLinComb_disc (D : DualEndData φ) (a b : ℤ) :
+    (D.intLinComb a b).trace ^ 2 - 4 * (D.intLinComb a b).norm
+      = b ^ 2 * (D.trace ^ 2 - 4 * D.norm) := by
+  simp only [intLinComb_trace, intLinComb_norm]; ring
+
+theorem intLinComb_disc_neg (D : DualEndData φ) {a b : ℤ} (hb : b ≠ 0)
+    (hD : D.trace ^ 2 < 4 * D.norm) :
+    (D.intLinComb a b).trace ^ 2 < 4 * (D.intLinComb a b).norm := by
+  have hkey := D.intLinComb_disc a b
+  have hbsq : (0 : ℤ) < b ^ 2 := by positivity
+  nlinarith
+
+end DualEndData
+
+def DualEndData.ofCharPoly (φ : AddMonoid.End A) (t n : ℤ)
+    (hchar : φ * φ - (t : AddMonoid.End A) * φ + (n : AddMonoid.End A) = 0) :
+    DualEndData φ where
+  dual := (t : AddMonoid.End A) - φ
+  trace := t
+  norm := n
+  add_dual := by abel
+  mul_dual := by
+    have hc : φ * (t : AddMonoid.End A) = (t : AddMonoid.End A) * φ :=
+      (Int.cast_commute t φ).eq.symm
+    have := hchar; rw [mul_sub, hc, ← sub_eq_zero,
+      show (t : AddMonoid.End A) * φ - φ * φ - (n : AddMonoid.End A)
+        = -(φ * φ - (t : AddMonoid.End A) * φ + (n : AddMonoid.End A)) by abel,
+      this, neg_zero]
+  dual_mul := by
+    have := hchar; rw [sub_mul, ← sub_eq_zero,
+      show (t : AddMonoid.End A) * φ - φ * φ - (n : AddMonoid.End A)
+        = -(φ * φ - (t : AddMonoid.End A) * φ + (n : AddMonoid.End A)) by abel,
+      this, neg_zero]
+
+@[simp] theorem DualEndData.ofCharPoly_trace (φ : AddMonoid.End A) (t n : ℤ) (h) :
+    (DualEndData.ofCharPoly φ t n h).trace = t := rfl
+
+@[simp] theorem DualEndData.ofCharPoly_norm (φ : AddMonoid.End A) (t n : ℤ) (h) :
+    (DualEndData.ofCharPoly φ t n h).norm = n := rfl
+
+@[simp] theorem DualEndData.ofCharPoly_dual (φ : AddMonoid.End A) (t n : ℤ) (h) :
+    (DualEndData.ofCharPoly φ t n h).dual = (t : AddMonoid.End A) - φ := rfl
+
+def dualEndData_intCast (m : ℤ) : DualEndData (A := A) (m : AddMonoid.End A) where
+  dual := (m : AddMonoid.End A)
+  trace := 2 * m
+  norm := m ^ 2
+  add_dual := by push_cast; noncomm_ring
+  mul_dual := by rw [← Int.cast_mul, ← sq]
+  dual_mul := by rw [← Int.cast_mul, ← sq]
+
+@[simp] theorem dualEndData_intCast_norm (m : ℤ) :
+    (dualEndData_intCast (A := A) m).norm = m ^ 2 := rfl
+
+@[simp] theorem dualEndData_intCast_trace (m : ℤ) :
+    (dualEndData_intCast (A := A) m).trace = 2 * m := rfl
+
+@[simp] theorem dualEndData_intCast_dual (m : ℤ) :
+    (dualEndData_intCast (A := A) m).dual = (m : AddMonoid.End A) := rfl
+
+end AddMonoid.End
+
+section NamedResiduals
+
+variable {A : Type*} [AddCommGroup A]
+
+def DualIsogenyExistence (S : Subring (AddMonoid.End A)) : Prop :=
+  ∀ φ ∈ S, ∃ D : AddMonoid.End.DualEndData φ, D.dual ∈ S ∧ 0 ≤ D.norm
+
+def DualAdditivityResidual (S : Subring (AddMonoid.End A)) : Prop :=
+  ∀ φ ∈ S, ∀ ψ ∈ S, ∀ Dφ : AddMonoid.End.DualEndData φ, ∀ Dψ : AddMonoid.End.DualEndData ψ,
+    ∃ D : AddMonoid.End.DualEndData (φ + ψ), D.dual = Dφ.dual + Dψ.dual
+
+theorem dualIsogenyExistence_bot :
+    DualIsogenyExistence (⊥ : Subring (AddMonoid.End A)) := by
+  intro φ hφ
+  obtain ⟨m, rfl⟩ := Subring.mem_bot.mp hφ
+  exact ⟨AddMonoid.End.dualEndData_intCast m, Subring.mem_bot.mpr ⟨m, rfl⟩, sq_nonneg m⟩
+
+end NamedResiduals
+
+section SatGates
+
+private theorem one_charPoly_int :
+    (1 : AddMonoid.End ℤ) * 1 - ((2 : ℤ) : AddMonoid.End ℤ) * 1
+      + ((1 : ℤ) : AddMonoid.End ℤ) = 0 := by
+  norm_num
+
+theorem gate_intLinComb_norm_at_one :
+    ((AddMonoid.End.DualEndData.ofCharPoly (A := ℤ) 1 2 1
+      <| by exact one_charPoly_int).intLinComb 1 2).norm = 9 := by
+  simp only [AddMonoid.End.DualEndData.intLinComb_norm,
+    AddMonoid.End.DualEndData.ofCharPoly_trace, AddMonoid.End.DualEndData.ofCharPoly_norm]
+  decide
+
+theorem gate_dualEndData_intCast_three :
+    (AddMonoid.End.dualEndData_intCast (A := ℤ) 3).norm = 9
+    ∧ (AddMonoid.End.dualEndData_intCast (A := ℤ) 3).trace = 6 := ⟨rfl, rfl⟩
+
+theorem gate_intLinComb_disc_scaling :
+    ((AddMonoid.End.DualEndData.ofCharPoly (A := ℤ) 1 2 1
+      <| by exact one_charPoly_int).intLinComb 0 2).trace ^ 2
+        - 4 * ((AddMonoid.End.DualEndData.ofCharPoly (A := ℤ) 1 2 1
+        <| by exact one_charPoly_int).intLinComb 0 2).norm = 2 ^ 2 * (2 ^ 2 - 4 * 1) := by
+  rw [AddMonoid.End.DualEndData.intLinComb_disc, AddMonoid.End.DualEndData.ofCharPoly_trace,
+    AddMonoid.End.DualEndData.ofCharPoly_norm]
+
+end SatGates
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_EisensteinSeries_EisensteinG.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_EisensteinSeries_EisensteinG.lean
new file mode 100644
index 0000000000..5fa3adf397
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_EisensteinSeries_EisensteinG.lean
@@ -0,0 +1,62 @@
+/-
+Based on Prove2Me node EisensteinSeries_EisensteinG
+(8b5efe3e-b5da-56f6-ad35-38b1fc8e8b51) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.CStarAlgebra.Classes
+public import Mathlib.NumberTheory.ModularForms.EisensteinSeries.Defs
+
+/-!
+# Non-normalised level-N Eisenstein series over a congruence class
+
+Definition: `EisensteinSeries_EisensteinG` (`8b5efe3e-b5da-56f6-ad35-38b1fc8e8b51`), by Claude,
+2026-09-05.
+
+For a natural number $N$, an integer $k$, a vector $a \in (\mathbb{Z}/N\mathbb{Z})^2$ (i.e. $a :
+\mathrm{Fin}\,2 \to \mathbb{Z}/N\mathbb{Z}$) and a point $z$ of the upper half-plane,
+[`EisensteinSeries.eisensteinG N k a z`](../def/EisensteinSeries_EisensteinG.html#L5) is defined as
+the unconditional sum
+$$\sum_{\substack{v \in \mathbb{Z}^2 \\ v \equiv a \ (N)}} \mathrm{eisSummand}\,k\,v\,z,$$
+the index set being the subtype of those $v : \mathrm{Fin}\,2 \to \mathbb{Z}$ whose componentwise
+reduction map $\mathbb{Z} \to \mathbb{Z}/N\mathbb{Z}$ composed with $v$ equals $a$, and the summand
+being Mathlib's Eisenstein summand, $\mathrm{eisSummand}\,k\,v\,z = (v_0 z + v_1)^{-k}$ (a complex
+zpow). Thus, for $k \ge 3$, this is the classical non-normalised Eisenstein series $G_k^{a}(z) =
+\sum (v_0 z + v_1)^{-k}$ of weight $k$ for $\Gamma(N)$ attached to the residue class $a$, the sum
+running over the entire congruence class and not only over its vectors with coprime entries.
+
+Two points about the shape of the definition deserve note. First, the sum is a `tsum`, so the value
+is defined for every integer $k$ and every $N$, and equals $0$ by convention when the family fails
+to be summable; no convergence hypothesis is part of the definition. Second, when $a = 0$ the zero
+vector belongs to the index set, and it contributes $0^{-k}$, which for $k > 0$ is $0$ under the
+conventions for complex zpow, so that no term has to be removed by hand. The definition is made for
+arbitrary $N : \mathbb{N}$, the case $N = 0$ reading as the single vector $v$ with
+$\mathbb{Z}$-coordinates prescribed by $a$ under $\mathbb{Z}/0\mathbb{Z} = \mathbb{Z}$.
+
+**Relation to Mathlib.** Mathlib's `eisensteinSeries a k` sums `eisSummand` only over the vectors of
+the class $a$ with coprime entries (the `gammaSet`);
+[`EisensteinSeries.eisensteinG`](../def/EisensteinSeries_EisensteinG.html#L5) is the non-normalised
+variant, built from the same Mathlib summand `eisSummand`, summing over the whole congruence class
+modulo $N$.
+
+**Where it is used.** This series is the project's concrete model of a weight-$k$ level-$\Gamma(N)$
+Eisenstein series, with an explicit Fourier expansion at infinity, and is used in the modular-forms
+part of the development.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace EisensteinSeries
+
+noncomputable def eisensteinG (N : ℕ) (k : ℤ) (a : Fin 2 → ZMod N) (z : UpperHalfPlane) : ℂ :=
+  ∑' v : {v : Fin 2 → ℤ // ((↑) : ℤ → ZMod N) ∘ v = a}, eisSummand k v.1 z
+
+end EisensteinSeries
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_EisensteinSeries_WeierstrassZeta.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_EisensteinSeries_WeierstrassZeta.lean
new file mode 100644
index 0000000000..5799272b9c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_EisensteinSeries_WeierstrassZeta.lean
@@ -0,0 +1,71 @@
+/-
+Based on Prove2Me node EisensteinSeries_WeierstrassZeta
+(fc52a68d-5385-56eb-bbce-1c31cadc47a8) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.EisensteinSeries.E2.Defs
+
+/-!
+# Weierstrass zeta function and weight-one Eisenstein functions
+
+Definition: `EisensteinSeries_WeierstrassZeta` (`fc52a68d-5385-56eb-bbce-1c31cadc47a8`), by Claude,
+2026-09-05.
+
+For $\tau$ in the upper half-plane write $\Lambda_\tau = \mathbb{Z}\tau + \mathbb{Z}$ and, for $v
+\in \mathbb{Z}^2$ (indexed as a function `Fin 2 → ℤ`), $\omega_v = v_0\tau + v_1$. The first
+definition, [`EisensteinSeries.weierstrassZeta τ
+z`](../def/EisensteinSeries_WeierstrassZeta.html#L5), is the Weierstrass zeta function of
+$\Lambda_\tau$,
+$$Z(\tau,z) = \frac{1}{z} + \sum_{v \in \mathbb{Z}^2} \Bigl(\frac{1}{z-\omega_v} +
+\frac{1}{\omega_v} + \frac{z}{\omega_v^2}\Bigr),$$
+where the summand at $v = 0$ is replaced by $0$ and the sum is taken as an unconditional sum over
+the whole index set $\mathbb{Z}^2$ rather than over an exhaustion by finite subsets. Division is
+Lean's total division on $\mathbb{C}$, with $1/0 = 0$; consequently the expression also returns a
+value at $z = 0$ and at the other points of $\Lambda_\tau$, where the classical function has its
+poles.
+
+The second definition, [`EisensteinSeries.eisensteinG1 N v
+τ`](../def/EisensteinSeries_WeierstrassZeta.html#L9), attaches to a level $N \in \mathbb{N}$ and a
+vector $v = (v_0, v_1) \in \mathbb{Z}^2$ the function of $\tau$
+$$g_1^{v}(\tau) = \frac{1}{N}\Bigl(Z\bigl(\tau, \tfrac{v_0\tau + v_1}{N}\bigr) - \frac{v_0\bigl(\tau
+G_2(\tau) - 2\pi i\bigr) + v_1 G_2(\tau)}{N}\Bigr),$$
+where $G_2$ is the weight-two Eisenstein series. The subtracted term is the linear combination of
+the quasi-periods $\eta_1(\tau) = \tau G_2(\tau) - 2\pi i$ and $\eta_2(\tau) = G_2(\tau)$ of $Z$
+with coefficients $v_0, v_1$, divided by $N$; it is written out directly in terms of $G_2$ rather
+than defined as a difference $Z(\tau, z + \omega) - Z(\tau, z)$. Both definitions are plain
+formulas: no holomorphy, summability or modular transformation property is part of the data.
+
+**Relation to Mathlib.** The weight-two Eisenstein series $G_2$ used in `eisensteinG1` is Mathlib's
+`EisensteinSeries.G2`, and both definitions are placed in the same `EisensteinSeries` namespace; the
+Weierstrass zeta function of the lattice $\mathbb{Z}\tau + \mathbb{Z}$ and the weight-one functions
+$g_1^{v}$ are the project's own.
+
+**Where it is used.** These formulas are the starting point for the development of weight-one
+Eisenstein series for $\Gamma(N)$ in the modules that import this one, where the quasi-periodicity
+of $Z$ is used to establish the dependence of $g_1^{v}$ on $v$ modulo $N$ and its weight-one
+transformation behaviour under $SL_2(\mathbb{Z})$.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace EisensteinSeries
+
+noncomputable def weierstrassZeta (τ : UpperHalfPlane) (z : ℂ) : ℂ :=
+  1 / z + ∑' v : Fin 2 → ℤ, if v = 0 then 0 else
+    (1 / (z - ((v 0 : ℂ) * τ + v 1)) + 1 / ((v 0 : ℂ) * τ + v 1) + z / ((v 0 : ℂ) * τ + v 1) ^ 2)
+
+noncomputable def eisensteinG1 (N : ℕ) (v : Fin 2 → ℤ) (τ : UpperHalfPlane) : ℂ :=
+  1 / (N : ℂ) *
+    (weierstrassZeta τ (((v 0 : ℂ) * τ + v 1) / N) -
+      ((v 0 : ℂ) * ((τ : ℂ) * G2 τ - 2 * Real.pi * Complex.I) + (v 1 : ℂ) * G2 τ) / N)
+
+end EisensteinSeries
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_DivisionPolynomialOmega.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_DivisionPolynomialOmega.lean
new file mode 100644
index 0000000000..6eece138e1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_DivisionPolynomialOmega.lean
@@ -0,0 +1,208 @@
+/-
+Based on Prove2Me node EllipticCurve_DivisionPolynomialOmega
+(318e404f-2357-572e-ae95-bdbf76500a5a) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+public import Mathlib.Algebra.MvPolynomial.CommRing
+
+/-!
+# Division polynomial ω for Weierstrass curves
+
+Definition: `EllipticCurve_DivisionPolynomialOmega` (`318e404f-2357-572e-ae95-bdbf76500a5a`), by
+Claude, 2026-09-05.
+
+For a Weierstrass curve $W : y^2 + a_1xy + a_3y = x^3 + a_2x^2 + a_4x + a_6$ over a commutative ring
+$R$, with Mathlib's division polynomials $\psi_n$, $\phi_n$ in $R[X][Y]$, this module constructs the
+remaining division polynomial $\omega_n$, the numerator of the $y$-coordinate of multiplication by
+$n$. Two division-free auxiliaries come first. [`WeierstrassCurve.ψDbl W
+n`](../def/EllipticCurve_DivisionPolynomialOmega.html#L13) is the complementary sequence `complEDS₂
+W.ψ₂ (C W.Ψ₃) (C W.preΨ₄) n` attached to the normalised elliptic divisibility sequence defining
+$\psi$, so that `ψ_mul_ψDbl` gives $\psi_n \cdot \psi\mathrm{Dbl}_n = \psi_{2n}$ identically in $n
+\in \mathbb{Z}$ and over any ring; thus $\psi\mathrm{Dbl}_n$ is $\psi_{2n}/\psi_n$ without division.
+Then [`WeierstrassCurve.twoω W n`](../def/EllipticCurve_DivisionPolynomialOmega.html#L16) is
+$\psi\mathrm{Dbl}_n - \psi_n(a_1\phi_n + a_3\psi_n^2)$, the value $2\omega_n$, again without
+division and in every characteristic. To divide by $2$ one passes to the universal curve:
+`Universal.Poly` is $\mathbb{Z}[A_1,A_2,A_3,A_4,A_6] =$ `MvPolynomial (Fin 5) ℤ`, `Universal.curve`
+is the Weierstrass curve whose coefficients are the five variables, and `Universal.specialize W` is
+the ring homomorphism sending $A_i \mapsto a_i$, under which the universal curve maps to $W$
+(`Universal.map_specialize`). The operators `halveCoeff`, `halveX`, `halve` apply integer division
+by $2$ to each coefficient of an element of $\mathbb{Z}[A]$, of $\mathbb{Z}[A][X]$ and of
+$\mathbb{Z}[A][X][Y]$ respectively; these are exact on multiples of $2$ (`halve_two_mul`:
+$\mathrm{halve}(2p) = p$). Finally [`WeierstrassCurve.ω W
+n`](../def/EllipticCurve_DivisionPolynomialOmega.html#L86) is the image under `specialize W` of
+$\mathrm{halve}$ of the universal $2\omega_n$. The module also records $\psi\mathrm{Dbl}_0 = 2$,
+$\psi\mathrm{Dbl}_1 = \psi_2$, $\psi\mathrm{Dbl}_{-n} = \psi\mathrm{Dbl}_n$, $2\omega_0 = 2$,
+$2\omega_1 = 2Y$, the reflection formula $2\omega_{-n} = 2\omega_n + 2\psi_n(a_1\phi_n +
+a_3\psi_n^2)$, naturality of $\psi\mathrm{Dbl}$ and $2\omega$ under base change along a ring
+homomorphism, $\omega_1 = Y$, and the transfer principle `two_mul_ω_of_twoω_universal_eq`: any
+witness $\mathrm{twoω}_n = 2q$ over the universal curve identifies $\omega_n$ of every $W$ with the
+specialisation of $q$ and yields $2\omega_n = \mathrm{twoω}_n$.
+
+**Relation to Mathlib.** Mathlib's `DivisionPolynomial/Basic` supplies $\psi_2$, $\Psi_3$,
+$\mathrm{pre}\Psi_4$, $\psi$, $\phi$ and the elliptic divisibility sequence machinery (`normEDS`,
+`complEDS₂`); the polynomials $\omega_n$, the universal Weierstrass curve with its specialisation
+homomorphism, and the coefficientwise halving operators are added here.
+
+**Where it is used.** These polynomials give the $y$-coordinate of multiplication by $n$ in the form
+$[n](x,y) = (\phi_n/\psi_n^2,\ \omega_n/\psi_n^3)$, valid over an arbitrary base, and so support the
+explicit arithmetic of torsion points on the Frey curve used in the study of its mod-$p$ Galois
+representations.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open Polynomial
+open scoped Polynomial.Bivariate
+
+noncomputable section
+
+namespace WeierstrassCurve
+
+variable {R : Type*} [CommRing R] (W : WeierstrassCurve R)
+
+def ψDbl (n : ℤ) : R[X][Y] :=
+  complEDS₂ W.ψ₂ (C W.Ψ₃) (C W.preΨ₄) n
+
+def twoω (n : ℤ) : R[X][Y] :=
+  W.ψDbl n - W.ψ n * (C (C W.a₁) * W.φ n + C (C W.a₃) * W.ψ n ^ 2)
+
+namespace Universal
+
+abbrev Poly : Type := MvPolynomial (Fin 5) ℤ
+
+def curve : WeierstrassCurve Poly :=
+  ⟨MvPolynomial.X 0, MvPolynomial.X 1, MvPolynomial.X 2, MvPolynomial.X 3, MvPolynomial.X 4⟩
+
+def specialize (W : WeierstrassCurve R) : Poly →+* R :=
+  MvPolynomial.eval₂Hom (Int.castRingHom R) ![W.a₁, W.a₂, W.a₃, W.a₄, W.a₆]
+
+@[simp] lemma specialize_X_zero : specialize W (MvPolynomial.X 0) = W.a₁ := by simp [specialize]
+@[simp] lemma specialize_X_one : specialize W (MvPolynomial.X 1) = W.a₂ := by simp [specialize]
+@[simp] lemma specialize_X_two : specialize W (MvPolynomial.X 2) = W.a₃ := by simp [specialize]
+@[simp] lemma specialize_X_three : specialize W (MvPolynomial.X 3) = W.a₄ := by simp [specialize]
+@[simp] lemma specialize_X_four : specialize W (MvPolynomial.X 4) = W.a₆ := by simp [specialize]
+
+lemma map_specialize : curve.map (specialize W) = W := by
+  rcases W with ⟨a₁, a₂, a₃, a₄, a₆⟩
+  simp [curve, specialize, WeierstrassCurve.map]
+
+def halveCoeff (r : Poly) : Poly :=
+  AddMonoidAlgebra.ofCoeff
+    (Finsupp.mapRange (fun z : ℤ => z / 2) (by simp) (AddMonoidAlgebra.coeff r))
+
+@[simp] lemma halveCoeff_zero : halveCoeff 0 = 0 := by
+  simp [halveCoeff]
+
+lemma coeff_halveCoeff (r : Poly) (m : Fin 5 →₀ ℕ) :
+    AddMonoidAlgebra.coeff (halveCoeff r) m = AddMonoidAlgebra.coeff r m / 2 :=
+  Finsupp.mapRange_apply (hf := by simp) ..
+
+def halveX (p : Poly[X]) : Poly[X] :=
+  ⟨AddMonoidAlgebra.ofCoeff (p.toFinsupp.coeff.mapRange halveCoeff halveCoeff_zero)⟩
+
+@[simp] lemma coeff_halveX (p : Poly[X]) (i : ℕ) : (halveX p).coeff i = halveCoeff (p.coeff i) := by
+  rcases p with ⟨f⟩
+  simp [halveX, Polynomial.coeff]
+
+@[simp] lemma halveX_zero : halveX 0 = 0 := by
+  ext i
+  simp
+
+def halve (p : Poly[X][Y]) : Poly[X][Y] :=
+  ⟨AddMonoidAlgebra.ofCoeff (p.toFinsupp.coeff.mapRange halveX halveX_zero)⟩
+
+@[simp] lemma coeff_halve (p : Poly[X][Y]) (i : ℕ) : (halve p).coeff i = halveX (p.coeff i) := by
+  rcases p with ⟨f⟩
+  simp [halve, Polynomial.coeff]
+
+lemma halveCoeff_two_mul (r : Poly) : halveCoeff (2 * r) = r := by
+  ext m
+  rw [coeff_halveCoeff, show (2 : Poly) = MvPolynomial.C 2 from (map_ofNat MvPolynomial.C 2).symm,
+    MvPolynomial.coeff_C_mul]
+  exact Int.mul_ediv_cancel_left _ two_ne_zero
+
+lemma halveX_two_mul (p : Poly[X]) : halveX (2 * p) = p := by
+  ext i
+  rw [coeff_halveX, show (2 : Poly[X]) = C 2 from (map_ofNat C 2).symm, coeff_C_mul,
+    halveCoeff_two_mul]
+
+lemma halve_two_mul (p : Poly[X][Y]) : halve (2 * p) = p := by
+  ext i : 1
+  rw [coeff_halve, show (2 : Poly[X][Y]) = C 2 from (map_ofNat C 2).symm, coeff_C_mul,
+    halveX_two_mul]
+
+end Universal
+
+def ω (n : ℤ) : R[X][Y] :=
+  (Universal.halve (Universal.curve.twoω n)).map (mapRingHom (Universal.specialize W))
+
+lemma ψ_mul_ψDbl (n : ℤ) : W.ψ n * W.ψDbl n = W.ψ (2 * n) :=
+  normEDS_mul_complEDS₂ ..
+
+lemma ψDbl_zero : W.ψDbl 0 = 2 :=
+  complEDS₂_zero ..
+
+lemma ψDbl_one : W.ψDbl 1 = W.ψ₂ :=
+  complEDS₂_one ..
+
+lemma ψDbl_neg (n : ℤ) : W.ψDbl (-n) = W.ψDbl n :=
+  complEDS₂_neg ..
+
+lemma twoω_zero : W.twoω 0 = 2 := by
+  rw [twoω, ψDbl_zero, ψ_zero]
+  ring
+
+lemma twoω_one : W.twoω 1 = 2 * Y := by
+  rw [twoω, ψDbl_one, ψ_one, φ_one, ψ₂, Affine.polynomialY]
+  simp only [map_add, map_mul, map_ofNat]
+  ring
+
+lemma twoω_neg (n : ℤ) :
+    W.twoω (-n) = W.twoω n + 2 * (W.ψ n * (C (C W.a₁) * W.φ n + C (C W.a₃) * W.ψ n ^ 2)) := by
+  rw [twoω, twoω, ψDbl_neg, ψ_neg, φ_neg]
+  ring
+
+section Map
+
+variable {S : Type*} [CommRing S] (f : R →+* S)
+
+lemma map_ψDbl (n : ℤ) : (W.map f).ψDbl n = (W.ψDbl n).map (mapRingHom f) := by
+  rw [ψDbl, ψDbl, ← coe_mapRingHom, map_complEDS₂, map_ψ₂, map_Ψ₃, map_preΨ₄, coe_mapRingHom,
+    map_C, map_C, coe_mapRingHom]
+
+lemma map_twoω (n : ℤ) : (W.map f).twoω n = (W.twoω n).map (mapRingHom f) := by
+  simp only [twoω, map_ψDbl, map_ψ, map_φ, map_a₁, map_a₃, Polynomial.map_sub, Polynomial.map_mul,
+    Polynomial.map_add, Polynomial.map_pow, map_C, coe_mapRingHom]
+
+end Map
+
+lemma ω_eq_map_of_twoω_eq {n : ℤ} {q : Universal.Poly[X][Y]}
+    (hq : Universal.curve.twoω n = 2 * q) :
+    W.ω n = q.map (mapRingHom (Universal.specialize W)) := by
+  rw [ω, hq, Universal.halve_two_mul]
+
+lemma ω_one : W.ω 1 = Y := by
+  rw [ω, twoω_one, Universal.halve_two_mul, Polynomial.map_X]
+
+theorem two_mul_ω_of_twoω_universal_eq {n : ℤ} {q : Universal.Poly[X][Y]}
+    (hq : Universal.curve.twoω n = 2 * q) : 2 * W.ω n = W.twoω n := by
+  calc 2 * W.ω n = 2 * q.map (mapRingHom (Universal.specialize W)) := by
+        rw [W.ω_eq_map_of_twoω_eq hq]
+    _ = (2 * q).map (mapRingHom (Universal.specialize W)) := by
+        rw [Polynomial.map_mul, Polynomial.map_ofNat]
+    _ = (Universal.curve.map (Universal.specialize W)).twoω n := by rw [← hq, map_twoω]
+    _ = W.twoω n := by rw [Universal.map_specialize]
+
+end WeierstrassCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_FrobeniusEndo.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_FrobeniusEndo.lean
new file mode 100644
index 0000000000..f756248389
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_FrobeniusEndo.lean
@@ -0,0 +1,117 @@
+/-
+Based on Prove2Me node EllipticCurve_FrobeniusEndo
+(460a2eaf-43a0-5271-b6de-7d072eb2b020) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_GaloisRep
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusTrace
+
+/-!
+# Frobenius endomorphism, endomorphism pencils, kernel degrees
+
+Definition: `EllipticCurve_FrobeniusEndo` (`460a2eaf-43a0-5271-b6de-7d072eb2b020`), by Claude,
+2026-09-05.
+
+For an additive commutative group $A$ and an additive endomorphism $\psi$ of $A$,
+[`FrobeniusEndo.linePencil ψ m n`](../def/EllipticCurve_FrobeniusEndo.html#L14) is, for integers
+$m,n$, the additive endomorphism $P \mapsto m\cdot P - n\cdot\psi(P)$ of $A$ (written as the
+difference $m\bullet\mathrm{id}_A - n\bullet\psi$ in the group of additive endomorphisms);
+`linePencil_apply` records its value on a point, and `mem_ker_linePencil_iff` says that $P$ lies in
+its kernel exactly when $m\cdot P = n\cdot\psi(P)$. The accompanying numerical invariant
+[`FrobeniusEndo.kerDeg ψ m n`](../def/EllipticCurve_FrobeniusEndo.html#L21) is defined as `Nat.card`
+of the kernel of this pencil, i.e. the number of elements of $\ker(m - n\psi)$, with the usual
+convention that it is $0$ when that kernel is infinite; `kerDeg_def` restates the definition.
+
+The second group of definitions applies this to a Weierstrass curve. The standing context is a tower
+$R \to S \to k$ of commutative rings with $k$ a field, a Weierstrass curve $W$ over $R$, and an
+$S$-algebra automorphism $\sigma$ of $k$. Here $\sigma$ acts on the group of affine points
+`(W⁄k).Point` by applying $\sigma$ to coordinates, and [`FrobeniusEndo.frobEnd W
+σ`](../def/EllipticCurve_FrobeniusEndo.html#L39) is this action viewed as an additive endomorphism
+$P \mapsto \sigma\cdot P$ of `(W⁄k).Point`, with `frobEnd_apply` recording that value. For a natural
+number $p$, [`FrobeniusEndo.frobPencilEnd W σ p m n`](../def/EllipticCurve_FrobeniusEndo.html#L45)
+is the $\mathbb{Z}/p$-linear endomorphism $\bar m\cdot 1 - \bar n\cdot\rho(\sigma)$ of the
+$p$-torsion submodule $\{P : p\cdot P = 0\}$ of `(W⁄k).Point`, where $\rho(\sigma)$ is the
+endomorphism induced by $\sigma$ (the value at $\sigma$ of `galoisRepModuleEnd S W p`) and $\bar m,
+\bar n$ are the images of $m,n$ in $\mathbb{Z}/p$. Finally, [`FrobeniusEndo.FrobCharEqOnPoints W σ a
+q`](../def/EllipticCurve_FrobeniusEndo.html#L50) is the predicate, for an integer $a$ and a natural
+number $q$, that every point $P$ of `(W⁄k).Point` satisfies $\sigma(\sigma P) - a\cdot\sigma P +
+q\cdot P = 0$: the characteristic equation of $\sigma$ asserted pointwise on the group of points,
+rather than as an identity in a ring of endomorphisms.
+
+**Relation to Mathlib.** Mathlib has no notion of a pencil $m - n\psi$ of additive endomorphisms, of
+its kernel count, or of a pointwise characteristic equation for a field automorphism acting on the
+points of a Weierstrass curve; these are the project's own. The endomorphism `frobEnd` is the
+project's action of $S$-algebra automorphisms of $k$ on `(W⁄k).Point` packaged through Mathlib's
+`DistribSMul.toAddMonoidHom`.
+
+**Where it is used.** These notions provide the vocabulary for counting points and for identifying
+the trace and determinant of the action of a Frobenius automorphism on the $p$-torsion of a
+Weierstrass curve, which is what enters the description of the mod $p$ Galois representation
+attached to the Frey curve.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+noncomputable section
+
+namespace FrobeniusEndo
+
+section Pencil
+
+variable {A : Type*} [AddCommGroup A]
+
+def linePencil (ψ : A →+ A) (m n : ℤ) : A →+ A :=
+  m • AddMonoidHom.id A - n • ψ
+
+@[simp] lemma linePencil_apply (ψ : A →+ A) (m n : ℤ) (P : A) :
+    linePencil ψ m n P = m • P - n • ψ P :=
+  rfl
+
+def kerDeg (ψ : A →+ A) (m n : ℤ) : ℕ :=
+  Nat.card (linePencil ψ m n).ker
+
+lemma kerDeg_def (ψ : A →+ A) (m n : ℤ) : kerDeg ψ m n = Nat.card (linePencil ψ m n).ker :=
+  rfl
+
+lemma mem_ker_linePencil_iff (ψ : A →+ A) (m n : ℤ) (P : A) :
+    P ∈ (linePencil ψ m n).ker ↔ m • P = n • ψ P := by
+  rw [AddMonoidHom.mem_ker, linePencil_apply, sub_eq_zero]
+
+end Pencil
+
+section Frobenius
+
+variable {R : Type*} {S : Type*} {k : Type*} [CommRing R] [CommRing S] [Field k] [DecidableEq k]
+  [Algebra R S] [Algebra R k] [Algebra S k] [IsScalarTower R S k]
+  (W : WeierstrassCurve R) (σ : k ≃ₐ[S] k)
+
+abbrev frobEnd : (W⁄k).Point →+ (W⁄k).Point :=
+  DistribSMul.toAddMonoidHom (W⁄k).Point σ
+
+lemma frobEnd_apply (P : (W⁄k).Point) : frobEnd W σ P = σ • P :=
+  rfl
+
+abbrev frobPencilEnd (p : ℕ) (m n : ℤ) :
+    Module.End (ZMod p) (Submodule.torsionBy ℤ (W⁄k).Point p) :=
+  ((m : ZMod p) • (1 : Module.End (ZMod p) (Submodule.torsionBy ℤ (W⁄k).Point p))) -
+    (n : ZMod p) • galoisRepModuleEnd S W p σ
+
+def FrobCharEqOnPoints (a : ℤ) (q : ℕ) : Prop :=
+  ∀ P : (W⁄k).Point, σ • (σ • P) - a • (σ • P) + (q : ℤ) • P = 0
+
+end Frobenius
+
+end FrobeniusEndo
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_FrobeniusTrace.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_FrobeniusTrace.lean
new file mode 100644
index 0000000000..3a7140a83e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_FrobeniusTrace.lean
@@ -0,0 +1,127 @@
+/-
+Based on Prove2Me node EllipticCurve_FrobeniusTrace
+(a1ca1b69-152b-5d32-9250-96e0c0aac230) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.LinearAlgebra.Trace
+public import Mathlib.RingTheory.Valuation.RamificationGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_GaloisRep
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Ramification
+
+/-!
+# Mod-n Galois trace on torsion; Frobenius at a place
+
+Definition: `EllipticCurve_FrobeniusTrace` (`a1ca1b69-152b-5d32-9250-96e0c0aac230`), by Claude,
+2026-09-05.
+
+Two unrelated pieces of vocabulary are set up here, both used for stating trace-of-Frobenius
+congruences.
+
+The first concerns the mod-$n$ representation attached to a Weierstrass curve. Fix commutative rings
+$R$, $S$ and a field $K$ with compatible algebra structures ($R\to S\to K$ a scalar tower), an
+affine Weierstrass curve $W'$ over $R$, and $n : \mathbb{N}$. The carrier is the
+$\mathbb{Z}$-torsion submodule `Submodule.torsionBy ℤ (W'⁄K).Point n`, i.e. the subgroup of
+$n$-torsion points of the base-changed curve $(W'⁄K)$ over $K$, viewed as a $\mathbb{Z}/n$-module.
+The group $K \simeq_{\text{alg}[S]} K$ of $S$-algebra automorphisms of $K$ acts on it coordinatewise
+(this action and the $\mathbb{Z}/n$-module structure come from the project's Galois-representation
+definitions); an instance records that the two actions commute. Then `galoisRepModuleEnd S W' n` is
+the monoid homomorphism $\sigma \mapsto (x \mapsto \sigma \cdot x)$ into
+$\mathrm{End}_{\mathbb{Z}/n}$ of that torsion module, and `galoisTrace S W' n σ` is defined to be
+`LinearMap.trace (ZMod n)` of this endomorphism, an element of $\mathbb{Z}/n$. Note that the trace
+is taken on the torsion module as it stands, with no freeness or finiteness hypothesis; it therefore
+agrees with the classical $\operatorname{tr}\bar\rho_{E,n}(\sigma)$ exactly when that module is
+finite free over $\mathbb{Z}/n$ (Mathlib's `LinearMap.trace` is $0$ in degenerate cases). Two `rfl`
+lemmas unfold the action and the definition of the trace.
+
+The second is a predicate on places. For a field extension $L/K$ and a valuation subring $A
+\subseteq L$, [`ValuationSubring.IsFrobeniusAt A σ q`](../def/EllipticCurve_FrobeniusTrace.html#L51)
+says that $\sigma \in L \simeq_{\text{alg}[K]} L$ lies in the decomposition subgroup of $A$ over $K$
+and that the induced automorphism of the residue field of $A$ is the $q$-power map $x \mapsto
+x^{q}$. The two accessor lemmas extract the membership and the identity $\sigma \cdot x = x^{q}$ on
+residues. No surjectivity or uniqueness of such $\sigma$ is asserted: this is a property an element
+may or may not have.
+
+**Relation to Mathlib.** Built on Mathlib's `Submodule.torsionBy`, `DistribMulAction.toModuleEnd`,
+`LinearMap.trace`, `ValuationSubring.decompositionSubgroup` and `IsLocalRing.ResidueField`; the
+notion of a Frobenius element at a valuation subring, and the trace of the mod-$n$ Galois action on
+torsion points, are packaged here rather than in Mathlib.
+
+**Where it is used.** These definitions give the language in which the project states congruences of
+the form $\operatorname{tr}\bar\rho_{E,n}(\mathrm{Frob}_\ell) \equiv a_\ell(E) \pmod n$ for an
+elliptic curve at a prime $\ell$ of good reduction, with $\mathrm{Frob}_\ell$ taken to be any
+element satisfying `IsFrobeniusAt` for a place above $\ell$. Such congruences are what link
+mod-$\ell$ representations of Frey curves to Hecke eigenvalues of modular forms in the
+level-lowering and modularity steps.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open scoped WeierstrassCurve.Affine
+
+namespace WeierstrassCurve.Affine.Point
+
+universe r s v
+
+variable {R : Type r} {S : Type s} {K : Type v} [CommRing R] [CommRing S] [Field K]
+  [DecidableEq K] {W' : Affine R} [Algebra R S] [Algebra R K] [Algebra S K]
+  [IsScalarTower R S K]
+
+instance instSMulCommClassAlgEquivZModTorsionBy (n : ℕ) :
+    SMulCommClass (K ≃ₐ[S] K) (ZMod n) (Submodule.torsionBy ℤ (W'⁄K).Point n) where
+  smul_comm σ c x :=
+    ZMod.map_smul (DistribSMul.toAddMonoidHom (Submodule.torsionBy ℤ (W'⁄K).Point n) σ) c x
+
+variable (S) in
+def galoisRepModuleEnd (W' : Affine R) (n : ℕ) :
+    (K ≃ₐ[S] K) →* Module.End (ZMod n) (Submodule.torsionBy ℤ (W'⁄K).Point n) :=
+  DistribMulAction.toModuleEnd (ZMod n) (Submodule.torsionBy ℤ (W'⁄K).Point n)
+
+@[simp] lemma galoisRepModuleEnd_apply (W' : Affine R) (n : ℕ) (σ : K ≃ₐ[S] K)
+    (x : Submodule.torsionBy ℤ (W'⁄K).Point n) :
+    galoisRepModuleEnd S W' n σ x = σ • x :=
+  rfl
+
+variable (S) in
+def galoisTrace (W' : Affine R) (n : ℕ) (σ : K ≃ₐ[S] K) : ZMod n :=
+  LinearMap.trace (ZMod n) (Submodule.torsionBy ℤ (W'⁄K).Point n) (galoisRepModuleEnd S W' n σ)
+
+lemma galoisTrace_def (W' : Affine R) (n : ℕ) (σ : K ≃ₐ[S] K) :
+    galoisTrace S W' n σ =
+      LinearMap.trace (ZMod n) (Submodule.torsionBy ℤ (W'⁄K).Point n)
+        (galoisRepModuleEnd S W' n σ) :=
+  rfl
+
+end WeierstrassCurve.Affine.Point
+
+namespace ValuationSubring
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+
+def IsFrobeniusAt (A : ValuationSubring L) (σ : L ≃ₐ[K] L) (q : ℕ) : Prop :=
+  ∃ hσ : σ ∈ A.decompositionSubgroup K,
+    ∀ x : IsLocalRing.ResidueField A, (⟨σ, hσ⟩ : A.decompositionSubgroup K) • x = x ^ q
+
+lemma IsFrobeniusAt.mem_decompositionSubgroup {A : ValuationSubring L} {σ : L ≃ₐ[K] L} {q : ℕ}
+    (h : A.IsFrobeniusAt σ q) : σ ∈ A.decompositionSubgroup K :=
+  h.choose
+
+lemma IsFrobeniusAt.smul_residue_eq {A : ValuationSubring L} {σ : L ≃ₐ[K] L} {q : ℕ}
+    (h : A.IsFrobeniusAt σ q) (x : IsLocalRing.ResidueField A) :
+    (⟨σ, h.mem_decompositionSubgroup⟩ : A.decompositionSubgroup K) • x = x ^ q :=
+  h.choose_spec x
+
+end ValuationSubring
+
+end
+
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_FunctionFieldPullback.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_FunctionFieldPullback.lean
new file mode 100644
index 0000000000..9ac84c4a81
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_FunctionFieldPullback.lean
@@ -0,0 +1,1341 @@
+/-
+Based on Prove2Me node EllipticCurve_FunctionFieldPullback
+(cc616e54-6b99-5922-988e-22ce404946c4) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.RingTheory.DedekindDomain.Dvr
+public import Mathlib.RingTheory.DedekindDomain.AdicValuation
+public import Mathlib.RingTheory.DiscreteValuationRing.TFAE
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+public import Mathlib.RingTheory.Ideal.GoingUp
+public import Mathlib.RingTheory.Localization.FractionRing
+public import Mathlib.Tactic.FieldSimp
+
+/-!
+# Generic point and function-field pull-backs for elliptic curves
+
+Definition: `EllipticCurve_FunctionFieldPullback` (`cc616e54-6b99-5922-988e-22ce404946c4`), by
+Claude, 2026-09-05.
+
+Throughout, $W$ is a Weierstrass curve over a field $R$ and $K$ an $R$-algebra which is a field; $E
+= W_{/K}$ denotes the base-changed affine curve, $K[E]$ its Mathlib coordinate ring
+$K[X][Y]/(\,W\text{-polynomial})$ and $L = K(E)$ its function field (the fraction field of $K[E]$).
+A first group of results concerns $K[E]$ as a $K[X]$-algebra: it is finite and integral over $K[X]$,
+every nonzero prime ideal of it is maximal, and for $K$ algebraically closed every nonzero prime
+equals $\mathrm{XYIdeal}(a, C\,b) = (X-a,\;Y-b)$ for some solution $(a,b)$ of the affine equation,
+these ideals being maximal. `Point.xc`, `Point.yc` read off the coordinates of an affine point
+(value $0$ at the point at infinity). The generic point is the $L$-point $\gamma$ whose coordinates
+`genericX`, `genericY` are the images in $L$ of the classes of $X$ and $Y$; that it satisfies the
+equation, hence is nonsingular when $W$ is elliptic, is proved here. For a nonzero point $Q \in
+E(L)$, `pointHom Q` is the $K$-algebra map $K[E] \to L$ determined by $X \mapsto x(Q)$, $Y \mapsto
+y(Q)$; it is injective whenever $K$ is algebraically closed and $Q$ is not the base change of a
+$K$-point, and `pointPull Q` is then its extension $L \to L$ along the fraction field. Specialising
+$Q$ gives `transPull`/`transEquiv` (pull-back along translation by a $K$-point $S$, i.e. the map
+sending $\gamma$ to $\gamma + S$), `negPull`/`negEquiv` (pull-back along inversion), and `mulPull W
+K n`, defined from the point $n\cdot\gamma$ when the predicate `MulGood W K n` holds — namely
+$n\cdot\gamma \ne 0$ and $n\cdot\gamma$ is not the base change of any $K$-point — and as the
+identity otherwise. The expected identities are proved: additivity and injectivity of $S \mapsto
+\tau_S^{*}$, $\iota^{*}\circ\iota^{*} = \mathrm{id}$, $[m]^{*}[n]^{*} = [nm]^{*}$, and
+$\tau_S^{*}\circ[n]^{*} = [n]^{*}$ when $nS = 0$. `placeOf W K P` packages $(X-x(P),\,Y-y(P))$ as a
+height-one prime of $K[E]$; it is injective, and surjective onto the height-one spectrum for $K$
+algebraically closed and $W$ elliptic, with `CoordinateRing.evalAt` the evaluation homomorphism
+$K[E] \to K$ at a solution of the equation. Finally, [`Valuation.Cong v a
+b`](../def/EllipticCurve_FunctionFieldPullback.html#L856) is the relation $v(a-b) < 1$ — congruence
+modulo the valuation ideal, not an identity — shown stable under sums, products and powers of
+elements of valuation $\le 1$, under inversion and division by elements of valuation $1$, and under
+two-variable polynomial evaluation; from it and a valuation-transfer lemma for a ring map between
+fraction fields of Dedekind domains, the module deduces that $v_P(\mathrm{pointPull}\,Q\,(h)) \le
+e^{-k}$ whenever $v_{P'}(h) \le e^{-k}$, for points whose coordinates are congruent at $P$, and the
+corresponding statement for `mulPull` in terms of polynomials $\Phi, \Psi, \omega, \psi$ expressing
+the coordinates of $n\cdot\gamma$ and of $n\cdot P$ as rational functions of the coordinates.
+
+**Relation to Mathlib.** Mathlib supplies the affine Weierstrass curve, its coordinate ring with
+`XClass`, `YClass`, `XYIdeal`, the function field, the group of affine points and base change of
+points; the generic point, the homomorphisms `pointHom`/`pointPull` and their translation, inversion
+and multiplication-by-$n$ specialisations, the map from points to the height-one spectrum, and the
+valuation congruence relation
+[`Valuation.Cong`](../def/EllipticCurve_FunctionFieldPullback.html#L856) are the project's own.
+
+**Where it is used.** The material sets up the action of translations, inversion and multiplication
+by $n$ on the function field of an elliptic curve, together with the dictionary between affine
+points over an algebraically closed field and height-one places of the coordinate ring, and a
+valuation comparison between a point $P$ and its multiple $n\cdot P$.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+attribute [local implicit_reducible] WeierstrassCurve.baseChange
+
+open Polynomial
+open scoped Polynomial.Bivariate
+
+namespace WeierstrassCurve.Affine.CoordinateRing
+
+variable {K : Type*} [Field K] {W : Affine K}
+
+instance moduleFinite : Module.Finite K[X] W.CoordinateRing :=
+  Module.Finite.of_basis (CoordinateRing.basis W)
+
+instance isIntegral : Algebra.IsIntegral K[X] W.CoordinateRing :=
+  Algebra.IsIntegral.of_finite K[X] W.CoordinateRing
+
+theorem algebraMap_eq_mk_C (p : K[X]) : algebraMap K[X] W.CoordinateRing p = mk W (C p) := rfl
+
+theorem isMaximal_of_isPrime {P : Ideal W.CoordinateRing} (hP : P ≠ ⊥) [P.IsPrime] :
+    P.IsMaximal := by
+  have hc : (P.comap (algebraMap K[X] W.CoordinateRing)) ≠ ⊥ := fun h =>
+    hP (Ideal.eq_bot_of_under_eq_bot h)
+  exact P.isMaximal_of_isIntegral_of_isMaximal_under (IsPrime.to_maximal_ideal hc)
+
+theorem exists_comap_eq_span [IsAlgClosed K] {P : Ideal W.CoordinateRing} (hP : P ≠ ⊥)
+    [P.IsPrime] :
+    ∃ a : K, P.comap (algebraMap K[X] W.CoordinateRing) = Ideal.span {X - C a} := by
+  set p := P.comap (algebraMap K[X] W.CoordinateRing) with hp
+  have hp0 : p ≠ ⊥ := fun h => hP (Ideal.eq_bot_of_under_eq_bot h)
+  have : p.IsPrime := Ideal.comap_isPrime _ P
+  have hpmax : p.IsMaximal := IsPrime.to_maximal_ideal hp0
+  set g := Submodule.IsPrincipal.generator p with hg
+  have hgp : Ideal.span {g} = p := Ideal.span_singleton_generator p
+  have hgprime : Prime g := Submodule.IsPrincipal.prime_generator_of_isPrime p hp0
+  have hdeg : g.degree = 1 := IsAlgClosed.degree_eq_one_of_irreducible K hgprime.irreducible
+  obtain ⟨a, ha⟩ := Polynomial.exists_root_of_degree_eq_one hdeg
+  refine ⟨a, ?_⟩
+  have hle : p ≤ Ideal.span {X - C a} := by
+    rw [← hgp, Ideal.span_singleton_le_span_singleton]
+    exact ⟨g /ₘ (X - C a), (Polynomial.mul_divByMonic_eq_iff_isRoot.mpr ha).symm⟩
+  exact (hpmax.eq_of_le (Ideal.span_singleton_ne_top (Polynomial.not_isUnit_X_sub_C a)) hle).symm
+    |>.symm
+
+theorem XClass_mem_of_comap_eq {P : Ideal W.CoordinateRing} {a : K}
+    (h : P.comap (algebraMap K[X] W.CoordinateRing) = Ideal.span {X - C a}) : XClass W a ∈ P := by
+  have : X - C a ∈ P.comap (algebraMap K[X] W.CoordinateRing) := by
+    rw [h]; exact Ideal.mem_span_singleton_self _
+  exact this
+
+theorem mk_C_mem_iff {P : Ideal W.CoordinateRing} {a : K}
+    (h : P.comap (algebraMap K[X] W.CoordinateRing) = Ideal.span {X - C a}) (q : K[X]) :
+    mk W (C q) ∈ P ↔ q.IsRoot a := by
+  change q ∈ P.comap (algebraMap K[X] W.CoordinateRing) ↔ _
+  rw [h, Ideal.mem_span_singleton, Polynomial.dvd_iff_isRoot]
+
+theorem XYIdeal_isMaximal {a b : K} (h : W.Equation a b) : (XYIdeal W a (C b)).IsMaximal := by
+  apply Ideal.Quotient.maximal_of_isField
+  exact MulEquiv.isField (Field.toIsField K)
+    (quotientXYIdealEquiv (W' := W) (x := a) (y := C b) h).toMulEquiv
+
+theorem algebraMap_quot_apply (P : Ideal W.CoordinateRing) (c : K) :
+    algebraMap K (W.CoordinateRing ⧸ P) c = Ideal.Quotient.mk P (mk W (C (C c))) := rfl
+
+theorem algebraMap_quot_eq_comp_eval {P : Ideal W.CoordinateRing} {a : K}
+    (h : P.comap (algebraMap K[X] W.CoordinateRing) = Ideal.span {X - C a}) :
+    algebraMap K[X] (W.CoordinateRing ⧸ P) =
+      (algebraMap K (W.CoordinateRing ⧸ P)).comp (evalRingHom a) := by
+  apply Polynomial.ringHom_ext
+  · intro c
+    simp only [RingHom.coe_comp, Function.comp_apply, coe_evalRingHom, eval_C]
+    rfl
+  · simp only [RingHom.coe_comp, Function.comp_apply, coe_evalRingHom, eval_X]
+    rw [algebraMap_quot_apply, IsScalarTower.algebraMap_apply K[X] W.CoordinateRing
+      (W.CoordinateRing ⧸ P),
+      Ideal.Quotient.algebraMap_eq, eq_comm, Ideal.Quotient.mk_eq_mk_iff_sub_mem]
+    have : mk W (C (C a)) - algebraMap K[X] W.CoordinateRing X = -XClass W a := by
+      simp only [algebraMap_eq_mk_C, XClass, map_sub]; abel
+    rw [this]
+    exact P.neg_mem (XClass_mem_of_comap_eq h)
+
+theorem exists_eq_XYIdeal [IsAlgClosed K] {P : Ideal W.CoordinateRing} (hP : P ≠ ⊥) [P.IsPrime] :
+    ∃ a b : K, W.Equation a b ∧ P = XYIdeal W a (C b) := by
+  obtain ⟨a, ha⟩ := exists_comap_eq_span hP
+  have hPmax : P.IsMaximal := isMaximal_of_isPrime hP
+  set L := W.CoordinateRing ⧸ P
+  set π := Ideal.Quotient.mk P
+  have hθ := algebraMap_quot_eq_comp_eval ha
+  have : Algebra.IsIntegral K L := ⟨fun z => by
+    obtain ⟨m, hm, hm0⟩ := Algebra.IsIntegral.isIntegral (R := K[X]) z
+    refine ⟨m.map (evalRingHom a), hm.map _, ?_⟩
+    rw [eval₂_map, ← hθ]
+    exact hm0⟩
+  obtain ⟨b, hb⟩ :=
+    (IsAlgClosed.algebraMap_bijective_of_isIntegral (k := K) (K := L)).2 (π (mk W Y))
+  have hYmem : YClass W (C b) ∈ P := by
+    rw [YClass, map_sub, ← Ideal.Quotient.mk_eq_mk_iff_sub_mem]
+    exact hb.symm
+  have heq : W.Equation a b := by
+    have hψ : π.comp (mk W) = (algebraMap K L).comp (evalEvalRingHom a b) := by
+      apply Polynomial.ringHom_ext
+      · intro q
+        change algebraMap K[X] L q = _
+        rw [hθ]
+        simp only [RingHom.coe_comp, Function.comp_apply, coe_evalRingHom, eval_C]
+        rfl
+      · simp only [RingHom.coe_comp, Function.comp_apply, coe_evalRingHom, eval_X, eval_C]
+        exact hb.symm
+    have h0 : (π.comp (mk W)) W.polynomial = 0 := by
+      rw [RingHom.comp_apply, AdjoinRoot.mk_self, map_zero]
+    rw [hψ, RingHom.comp_apply, coe_evalEvalRingHom, map_eq_zero] at h0
+    exact h0
+  refine ⟨a, b, heq, ?_⟩
+  have hle : XYIdeal W a (C b) ≤ P := by
+    rw [XYIdeal, Ideal.span_le]
+    rintro z (rfl | rfl)
+    · exact XClass_mem_of_comap_eq ha
+    · exact hYmem
+  exact ((XYIdeal_isMaximal heq).eq_of_le hPmax.ne_top hle).symm
+
+end WeierstrassCurve.Affine.CoordinateRing
+
+namespace WeierstrassCurve.Affine
+
+namespace Point
+
+variable {S : Type*} [CommRing S] {V : Affine S}
+
+def xc : V.Point → S
+  | 0 => 0
+  | some x _ _ => x
+
+def yc : V.Point → S
+  | 0 => 0
+  | some _ y _ => y
+
+@[simp] lemma xc_some {x y : S} (h : V.Nonsingular x y) : (some x y h).xc = x := rfl
+@[simp] lemma yc_some {x y : S} (h : V.Nonsingular x y) : (some x y h).yc = y := rfl
+
+lemma nonsingular_xc_yc {P : V.Point} (hP : P ≠ 0) : V.Nonsingular P.xc P.yc := by
+  rcases P with _ | ⟨x, y, h⟩
+  · exact absurd rfl hP
+  · exact h
+
+lemma eq_some_xc_yc {P : V.Point} (hP : P ≠ 0) : P = some P.xc P.yc (nonsingular_xc_yc hP) := by
+  rcases P with _ | ⟨x, y, h⟩
+  · exact absurd rfl hP
+  · rfl
+
+end Point
+
+section Generic
+
+variable {R : Type*} [Field R] (W : WeierstrassCurve R) (K : Type*) [Field K] [Algebra R K]
+
+noncomputable instance instDecidableEqFunctionField : DecidableEq (W⁄K).FunctionField :=
+  Classical.decEq _
+
+noncomputable def genericX : (W⁄K).FunctionField :=
+  algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField (CoordinateRing.mk (W⁄K) (C X))
+
+noncomputable def genericY : (W⁄K).FunctionField :=
+  algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField (CoordinateRing.mk (W⁄K) Y)
+
+theorem evalEval_baseChange_polynomial (x y : (W⁄K).FunctionField) :
+    (W⁄(W⁄K).FunctionField).polynomial.evalEval x y =
+      (W⁄K).polynomial.eval₂ (aeval (R := K) x).toRingHom y := by
+  rw [baseChange_polynomial W (Algebra.ofId K (W⁄K).FunctionField), evalEval, eval_map]
+  have h := hom_eval₂ (W⁄K).polynomial (mapRingHom (Algebra.ofId K (W⁄K).FunctionField : K →+* _))
+    (evalRingHom x) (C y)
+  simp only [coe_evalRingHom, eval_C] at h
+  rw [h]
+  congr 1
+  apply Polynomial.ringHom_ext
+  · intro c
+    simp only [RingHom.coe_comp, Function.comp_apply, coe_mapRingHom, map_C, coe_evalRingHom,
+      eval_C, AlgHom.toRingHom_eq_coe, RingHom.coe_coe, aeval_C]
+    rfl
+  · simp only [RingHom.coe_comp, Function.comp_apply, coe_mapRingHom, map_X, coe_evalRingHom,
+      eval_X, AlgHom.toRingHom_eq_coe, RingHom.coe_coe, aeval_X]
+
+theorem algebraMap_comp_of :
+    (algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField).comp (AdjoinRoot.of (W⁄K).polynomial) =
+      (aeval (R := K) (genericX W K)).toRingHom := by
+  apply Polynomial.ringHom_ext
+  · intro c
+    simp only [RingHom.coe_comp, Function.comp_apply, AlgHom.toRingHom_eq_coe, RingHom.coe_coe,
+      aeval_C]
+    rw [← AdjoinRoot.algebraMap_eq, ← IsScalarTower.algebraMap_apply]
+    change (algebraMap K[X] (W⁄K).FunctionField) (algebraMap K K[X] c) = _
+    exact (IsScalarTower.algebraMap_apply K K[X] (W⁄K).FunctionField c).symm
+  · simp only [RingHom.coe_comp, Function.comp_apply, AlgHom.toRingHom_eq_coe, RingHom.coe_coe,
+      aeval_X]
+    rfl
+
+theorem generic_equation :
+    (W⁄(W⁄K).FunctionField).Equation (genericX W K) (genericY W K) := by
+  rw [Equation, evalEval_baseChange_polynomial, ← algebraMap_comp_of]
+  have h0 := congrArg (algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField)
+    (AdjoinRoot.eval₂_root (W⁄K).polynomial)
+  rw [map_zero, hom_eval₂] at h0
+  exact h0
+
+theorem generic_nonsingular [W.IsElliptic] :
+    (W⁄(W⁄K).FunctionField).Nonsingular (genericX W K) (genericY W K) := by
+  have : (W⁄(W⁄K).FunctionField).IsElliptic := by
+    constructor
+    simp only [Affine.baseChange, WeierstrassCurve.baseChange, WeierstrassCurve.map_Δ]
+    apply RingHom.isUnit_map
+    exact W.isUnit_Δ
+  exact (equation_iff_nonsingular (W := W⁄(W⁄K).FunctionField)).mp (generic_equation W K)
+
+noncomputable def genericPoint [W.IsElliptic] : (W⁄(W⁄K).FunctionField).Point :=
+  .some _ _ (generic_nonsingular W K)
+
+lemma genericPoint_ne_zero [W.IsElliptic] :
+    genericPoint W K ≠ 0 :=
+  Point.some_ne_zero _
+
+end Generic
+
+section PointHom
+
+variable {R : Type*} [Field R] {W : WeierstrassCurve R} {K : Type*} [Field K] [Algebra R K]
+
+theorem eval₂_polynomial_of_point (Q : (W⁄(W⁄K).FunctionField).Point) (hQ : Q ≠ 0) :
+    (W⁄K).polynomial.eval₂ (aeval (R := K) Q.xc).toRingHom Q.yc = 0 := by
+  rw [← evalEval_baseChange_polynomial]
+  exact (Point.nonsingular_xc_yc hQ).left
+
+noncomputable def pointHom (Q : (W⁄(W⁄K).FunctionField).Point) (hQ : Q ≠ 0) :
+    (W⁄K).CoordinateRing →ₐ[K] (W⁄K).FunctionField :=
+  { AdjoinRoot.lift (aeval (R := K) Q.xc).toRingHom Q.yc (eval₂_polynomial_of_point Q hQ) with
+    commutes' := fun c => by
+      simp only [RingHom.toMonoidHom_eq_coe, OneHom.toFun_eq_coe, MonoidHom.toOneHom_coe,
+        MonoidHom.coe_ofClass]
+      rw [IsScalarTower.algebraMap_apply K (Polynomial K) (W⁄K).CoordinateRing,
+        AdjoinRoot.algebraMap_eq, AdjoinRoot.lift_of, AlgHom.toRingHom_eq_coe, RingHom.coe_coe,
+        Polynomial.algebraMap_apply, aeval_C, Algebra.algebraMap_self, RingHom.id_apply] }
+
+theorem pointHom_mk (Q : (W⁄(W⁄K).FunctionField).Point) (hQ : Q ≠ 0) (g : (Polynomial K)[X]) :
+    pointHom Q hQ (CoordinateRing.mk (W⁄K) g) = g.eval₂ (aeval (R := K) Q.xc).toRingHom Q.yc :=
+  AdjoinRoot.lift_mk (eval₂_polynomial_of_point Q hQ) g
+
+@[simp] theorem pointHom_mk_C_C (Q : (W⁄(W⁄K).FunctionField).Point) (hQ : Q ≠ 0) (c : K) :
+    pointHom Q hQ (CoordinateRing.mk (W⁄K) (C (C c))) = algebraMap K _ c :=
+  (pointHom Q hQ).commutes c
+
+@[simp] theorem pointHom_mk_C_X (Q : (W⁄(W⁄K).FunctionField).Point) (hQ : Q ≠ 0) :
+    pointHom Q hQ (CoordinateRing.mk (W⁄K) (C X)) = Q.xc := by
+  rw [pointHom_mk, eval₂_C, AlgHom.toRingHom_eq_coe, RingHom.coe_coe, aeval_X]
+
+@[simp] theorem pointHom_mk_Y (Q : (W⁄(W⁄K).FunctionField).Point) (hQ : Q ≠ 0) :
+    pointHom Q hQ (CoordinateRing.mk (W⁄K) Y) = Q.yc := by
+  rw [pointHom_mk, eval₂_X]
+
+theorem CoordinateRing.algHom_ext' {A : Type*} [Semiring A] [Algebra K A]
+    {f g : (W⁄K).CoordinateRing →ₐ[K] A}
+    (hX : f (CoordinateRing.mk (W⁄K) (C X)) = g (CoordinateRing.mk (W⁄K) (C X)))
+    (hY : f (CoordinateRing.mk (W⁄K) Y) = g (CoordinateRing.mk (W⁄K) Y)) : f = g := by
+  apply AlgHom.toRingHom_injective
+  apply Ideal.Quotient.ringHom_ext
+  apply Polynomial.ringHom_ext
+  · intro q
+    change f (CoordinateRing.mk (W⁄K) (C q)) = g (CoordinateRing.mk (W⁄K) (C q))
+    have hf : (f : (W⁄K).CoordinateRing →+* A).comp ((CoordinateRing.mk (W⁄K)).comp C) =
+        (g : (W⁄K).CoordinateRing →+* A).comp ((CoordinateRing.mk (W⁄K)).comp C) := by
+      apply Polynomial.ringHom_ext
+      · intro c
+        change f (algebraMap K _ c) = g (algebraMap K _ c)
+        rw [AlgHom.commutes, AlgHom.commutes]
+      · exact hX
+    exact RingHom.congr_fun hf q
+  · exact hY
+
+theorem pointHom_genericPoint [W.IsElliptic] :
+    pointHom (genericPoint W K) (genericPoint_ne_zero W K) =
+      IsScalarTower.toAlgHom K (W⁄K).CoordinateRing (W⁄K).FunctionField := by
+  apply CoordinateRing.algHom_ext'
+  · rw [pointHom_mk_C_X, IsScalarTower.coe_toAlgHom', genericPoint, Point.xc_some]; rfl
+  · rw [pointHom_mk_Y, IsScalarTower.coe_toAlgHom', genericPoint, Point.yc_some]; rfl
+
+theorem Point.xc_map {F' L' : Type*} [Field F'] [Field L'] [Algebra R F'] [Algebra K F']
+    [IsScalarTower R K F'] [Algebra R L'] [Algebra K L'] [IsScalarTower R K L']
+    [DecidableEq F'] [DecidableEq L'] (f : F' →ₐ[K] L') (P : (W⁄F').Point) :
+    (Point.map (W' := W) f P).xc = f P.xc := by
+  cases P with
+  | zero => exact (_root_.map_zero f).symm
+  | some x y h => rfl
+
+theorem Point.yc_map {F' L' : Type*} [Field F'] [Field L'] [Algebra R F'] [Algebra K F']
+    [IsScalarTower R K F'] [Algebra R L'] [Algebra K L'] [IsScalarTower R K L']
+    [DecidableEq F'] [DecidableEq L'] (f : F' →ₐ[K] L') (P : (W⁄F').Point) :
+    (Point.map (W' := W) f P).yc = f P.yc := by
+  cases P with
+  | zero => exact (_root_.map_zero f).symm
+  | some x y h => rfl
+
+theorem pointHom_injective_of_ne_baseChange [DecidableEq K] [IsAlgClosed K] [W.IsElliptic]
+    (Q : (W⁄(W⁄K).FunctionField).Point) (hQ : Q ≠ 0)
+    (hQK : ∀ P : (W⁄K).Point, Q ≠ Point.baseChange K (W⁄K).FunctionField P) :
+    Function.Injective (pointHom Q hQ) := by
+  rw [injective_iff_map_eq_zero]
+  by_contra hcon
+  push Not at hcon
+  have hker : RingHom.ker (pointHom Q hQ) ≠ ⊥ := by
+    obtain ⟨a, ha, ha0⟩ := hcon
+    intro h
+    have hm : a ∈ RingHom.ker (pointHom Q hQ) := (RingHom.mem_ker).mpr ha
+    rw [h, Ideal.mem_bot] at hm
+    exact ha0 hm
+  have : (RingHom.ker (pointHom Q hQ)).IsPrime := RingHom.ker_isPrime _
+  obtain ⟨a, b, hab, hker'⟩ := CoordinateRing.exists_eq_XYIdeal hker
+  have : (W⁄K).IsElliptic := by
+    dsimp only [Affine.baseChange, WeierstrassCurve.baseChange]; infer_instance
+  have hns : (W⁄K).Nonsingular a b := (equation_iff_nonsingular (W := W⁄K)).mp hab
+  have hx : Q.xc = algebraMap K _ a := by
+    have : CoordinateRing.XClass (W⁄K) a ∈ RingHom.ker (pointHom Q hQ) := by
+      rw [hker']; exact Ideal.subset_span (Set.mem_insert _ _)
+    rw [RingHom.mem_ker, CoordinateRing.XClass, map_sub, map_sub, map_sub, pointHom_mk_C_X,
+      pointHom_mk_C_C, sub_eq_zero] at this
+    exact this
+  have hy : Q.yc = algebraMap K _ b := by
+    have : CoordinateRing.YClass (W⁄K) (C b) ∈ RingHom.ker (pointHom Q hQ) := by
+      rw [hker']; exact Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+    rw [RingHom.mem_ker, CoordinateRing.YClass, map_sub, map_sub, pointHom_mk_Y, pointHom_mk_C_C,
+      sub_eq_zero] at this
+    exact this
+  apply hQK (.some a b hns)
+  rw [Point.eq_some_xc_yc hQ, Point.baseChange, Point.map_some]
+  congr 1
+
+noncomputable def pointPull (Q : (W⁄(W⁄K).FunctionField).Point) (hQ : Q ≠ 0)
+    (hinj : Function.Injective (pointHom Q hQ)) :
+    (W⁄K).FunctionField →ₐ[K] (W⁄K).FunctionField :=
+  IsFractionRing.liftAlgHom hinj
+
+@[simp] theorem pointPull_algebraMap (Q : (W⁄(W⁄K).FunctionField).Point) (hQ : Q ≠ 0)
+    (hinj : Function.Injective (pointHom Q hQ)) (h : (W⁄K).CoordinateRing) :
+    pointPull Q hQ hinj (algebraMap _ _ h) = pointHom Q hQ h := by
+  rw [pointPull, IsFractionRing.liftAlgHom_apply]
+  exact IsFractionRing.lift_algebraMap hinj h
+
+theorem map_pointPull_genericPoint [W.IsElliptic] (Q : (W⁄(W⁄K).FunctionField).Point) (hQ : Q ≠ 0)
+    (hinj : Function.Injective (pointHom Q hQ)) :
+    Point.map (pointPull Q hQ hinj) (genericPoint W K) = Q := by
+  conv_rhs => rw [Point.eq_some_xc_yc hQ]
+  rw [genericPoint, Point.map_some]
+  congr 1
+  · rw [genericX, pointPull_algebraMap, pointHom_mk_C_X]
+  · rw [genericY, pointPull_algebraMap, pointHom_mk_Y]
+
+theorem pointPull_comp_pointHom (Q : (W⁄(W⁄K).FunctionField).Point) (hQ : Q ≠ 0)
+    (hinj : Function.Injective (pointHom Q hQ)) (P : (W⁄(W⁄K).FunctionField).Point) (hP : P ≠ 0)
+    (hP' : Point.map (pointPull Q hQ hinj) P ≠ 0) :
+    (pointPull Q hQ hinj).comp (pointHom P hP) =
+      pointHom (Point.map (pointPull Q hQ hinj) P) hP' := by
+  apply CoordinateRing.algHom_ext'
+  · rw [AlgHom.comp_apply, pointHom_mk_C_X, pointHom_mk_C_X, Point.xc_map]
+  · rw [AlgHom.comp_apply, pointHom_mk_Y, pointHom_mk_Y, Point.yc_map]
+
+theorem pointHom_congr {Q Q' : (W⁄(W⁄K).FunctionField).Point} (h : Q = Q') (hQ : Q ≠ 0)
+    (hQ' : Q' ≠ 0) :
+    pointHom Q hQ = pointHom Q' hQ' := by subst h; rfl
+
+theorem pointPull_comp_algebraMap (Q : (W⁄(W⁄K).FunctionField).Point) (hQ : Q ≠ 0)
+    (hinj : Function.Injective (pointHom Q hQ)) :
+    (pointPull Q hQ hinj : (W⁄K).FunctionField →+* (W⁄K).FunctionField).comp
+      (algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField) = pointHom Q hQ :=
+  RingHom.ext fun h => pointPull_algebraMap Q hQ hinj h
+
+theorem FunctionField.algHom_ext {φ ψ : (W⁄K).FunctionField →ₐ[K] (W⁄K).FunctionField}
+    (h : (φ : (W⁄K).FunctionField →+* (W⁄K).FunctionField).comp
+        (algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField) =
+      (ψ : (W⁄K).FunctionField →+* (W⁄K).FunctionField).comp
+        (algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField)) : φ = ψ :=
+  AlgHom.toRingHom_injective
+    (IsLocalization.ringHom_ext (nonZeroDivisors (W⁄K).CoordinateRing) h)
+
+theorem exists_eq_baseChange_of_isIntegral_xc [DecidableEq K] [IsAlgClosed K] [W.IsElliptic]
+    (Q : (W⁄(W⁄K).FunctionField).Point) (hQ : Q ≠ 0) (hx : _root_.IsIntegral K Q.xc) :
+    ∃ P : (W⁄K).Point, Q = Point.baseChange K (W⁄K).FunctionField P := by
+  have : (W⁄K).IsElliptic := by
+    dsimp only [Affine.baseChange, WeierstrassCurve.baseChange]; infer_instance
+  have hdx : (minpoly K Q.xc).degree = 1 :=
+    IsAlgClosed.degree_eq_one_of_irreducible K (minpoly.irreducible hx)
+  obtain ⟨a, ha⟩ : Q.xc ∈ (algebraMap K (W⁄K).FunctionField).range :=
+    minpoly.mem_range_of_degree_eq_one K _ hdx
+  have heq := (Point.nonsingular_xc_yc hQ).left
+  rw [equation_iff] at heq
+  have hy : _root_.IsIntegral K Q.yc := by
+    refine ⟨X ^ 2 + C ((W⁄K).a₁ * a + (W⁄K).a₃) * X - C (a ^ 3 + (W⁄K).a₂ * a ^ 2 + (W⁄K).a₄ * a
+      + (W⁄K).a₆), ?_, ?_⟩
+    · have hlt : (C ((W⁄K).a₁ * a + (W⁄K).a₃) * X - C (a ^ 3 + (W⁄K).a₂ * a ^ 2
+          + (W⁄K).a₄ * a + (W⁄K).a₆) : K[X]).degree < ((X : K[X]) ^ 2).degree := by
+        rw [degree_X_pow]
+        refine (degree_sub_le _ _).trans_lt (max_lt ((degree_C_mul_X_le _).trans_lt ?_)
+          (degree_C_le.trans_lt ?_))
+        · exact WithBot.coe_lt_coe.mpr (by norm_num)
+        · exact WithBot.coe_lt_coe.mpr (by norm_num)
+      rw [add_sub_assoc]
+      exact (monic_X_pow 2).add_of_left hlt
+    · simp only [eval₂_add, eval₂_sub, eval₂_pow, eval₂_X, eval₂_mul, eval₂_C, map_add, map_mul,
+        map_pow]
+      rw [ha]
+      have e1 : (algebraMap K (W⁄K).FunctionField) (W⁄K).a₁ = (W⁄(W⁄K).FunctionField).a₁ :=
+        (IsScalarTower.algebraMap_apply R K (W⁄K).FunctionField W.a₁).symm
+      have e2 : (algebraMap K (W⁄K).FunctionField) (W⁄K).a₂ = (W⁄(W⁄K).FunctionField).a₂ :=
+        (IsScalarTower.algebraMap_apply R K (W⁄K).FunctionField W.a₂).symm
+      have e3 : (algebraMap K (W⁄K).FunctionField) (W⁄K).a₃ = (W⁄(W⁄K).FunctionField).a₃ :=
+        (IsScalarTower.algebraMap_apply R K (W⁄K).FunctionField W.a₃).symm
+      have e4 : (algebraMap K (W⁄K).FunctionField) (W⁄K).a₄ = (W⁄(W⁄K).FunctionField).a₄ :=
+        (IsScalarTower.algebraMap_apply R K (W⁄K).FunctionField W.a₄).symm
+      have e6 : (algebraMap K (W⁄K).FunctionField) (W⁄K).a₆ = (W⁄(W⁄K).FunctionField).a₆ :=
+        (IsScalarTower.algebraMap_apply R K (W⁄K).FunctionField W.a₆).symm
+      rw [e1, e2, e3, e4, e6]
+      linear_combination heq
+  have hdy : (minpoly K Q.yc).degree = 1 :=
+    IsAlgClosed.degree_eq_one_of_irreducible K (minpoly.irreducible hy)
+  obtain ⟨b, hb⟩ : Q.yc ∈ (algebraMap K (W⁄K).FunctionField).range :=
+    minpoly.mem_range_of_degree_eq_one K _ hdy
+  have hab : (W⁄K).Equation a b := by
+    rw [← baseChange_equation W (Algebra.ofId K (W⁄K).FunctionField).injective a b]
+    change (W⁄(W⁄K).FunctionField).Equation (algebraMap K _ a) (algebraMap K _ b)
+    rw [ha, hb]
+    exact (Point.nonsingular_xc_yc hQ).left
+  have hns : (W⁄K).Nonsingular a b := (equation_iff_nonsingular (W := W⁄K)).mp hab
+  refine ⟨.some a b hns, ?_⟩
+  rw [Point.eq_some_xc_yc hQ, Point.baseChange, Point.map_some]
+  congr 1 <;> [exact ha.symm; exact hb.symm]
+
+theorem not_isIntegral_xc_of_ne_baseChange [DecidableEq K] [IsAlgClosed K] [W.IsElliptic]
+    (Q : (W⁄(W⁄K).FunctionField).Point) (hQ : Q ≠ 0)
+    (hQK : ∀ P : (W⁄K).Point, Q ≠ Point.baseChange K (W⁄K).FunctionField P) :
+    ¬ _root_.IsIntegral K Q.xc :=
+  fun hx => by obtain ⟨P, hP⟩ := exists_eq_baseChange_of_isIntegral_xc Q hQ hx; exact hQK P hP
+
+end PointHom
+
+section TransMul
+
+variable {R : Type*} [Field R] (W : WeierstrassCurve R) (K : Type*) [Field K] [Algebra R K]
+  [DecidableEq K] [IsAlgClosed K] [W.IsElliptic]
+
+omit [IsAlgClosed K] in
+theorem genericPoint_ne_baseChange (P : (W⁄K).Point) :
+    genericPoint W K ≠ Point.baseChange K (W⁄K).FunctionField P := by
+  intro h
+  cases P with
+  | zero => exact Point.some_ne_zero _ (h.trans (map_zero _))
+  | some a b hab =>
+    rw [genericPoint, Point.baseChange, Point.map_some, Point.some.injEq] at h
+    apply CoordinateRing.XClass_ne_zero (W' := W⁄K) a
+    apply IsFractionRing.injective (W⁄K).CoordinateRing (W⁄K).FunctionField
+    rw [CoordinateRing.XClass, map_sub, map_sub, map_sub, _root_.map_zero]
+    have h1 : algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField (.mk (W⁄K) (C X)) =
+        genericX W K := rfl
+    have h2 : algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField (.mk (W⁄K) (C (C a))) =
+        algebraMap K (W⁄K).FunctionField a :=
+      (IsScalarTower.algebraMap_apply K (W⁄K).CoordinateRing (W⁄K).FunctionField a).symm
+    rw [h1, h2, h.1, sub_eq_zero]
+    rfl
+
+omit [IsAlgClosed K] in
+theorem genericPoint_add_baseChange_ne_zero (S : (W⁄K).Point) :
+    genericPoint W K + Point.baseChange K _ S ≠ 0 := by
+  intro h
+  apply genericPoint_ne_baseChange W K (-S)
+  rw [map_neg]
+  exact eq_neg_of_add_eq_zero_left h
+
+omit [IsAlgClosed K] in
+theorem genericPoint_add_baseChange_ne_baseChange (S P : (W⁄K).Point) :
+    genericPoint W K + Point.baseChange K _ S ≠ Point.baseChange K _ P := by
+  intro h
+  apply genericPoint_ne_baseChange W K (P - S)
+  rw [map_sub, ← h, add_sub_cancel_right]
+
+theorem transHom_injective (S : (W⁄K).Point) :
+    Function.Injective (pointHom (genericPoint W K + Point.baseChange K _ S)
+      (genericPoint_add_baseChange_ne_zero W K S)) :=
+  pointHom_injective_of_ne_baseChange _ _ (genericPoint_add_baseChange_ne_baseChange W K S)
+
+noncomputable def transPull (S : (W⁄K).Point) : (W⁄K).FunctionField →ₐ[K] (W⁄K).FunctionField :=
+  pointPull _ (genericPoint_add_baseChange_ne_zero W K S) (transHom_injective W K S)
+
+theorem map_transPull_genericPoint (S : (W⁄K).Point) :
+    Point.map (transPull W K S) (genericPoint W K) = genericPoint W K + Point.baseChange K _ S :=
+  map_pointPull_genericPoint _ _ _
+
+theorem map_transPull_genericPoint_add (S T : (W⁄K).Point) :
+    Point.map (transPull W K S) (genericPoint W K + Point.baseChange K _ T) =
+      genericPoint W K + Point.baseChange K _ (S + T) := by
+  rw [map_add, map_transPull_genericPoint, Point.map_baseChange, add_assoc, ← map_add]
+
+theorem transPull_comp_algebraMap (S : (W⁄K).Point) :
+    (transPull W K S : (W⁄K).FunctionField →+* (W⁄K).FunctionField).comp
+      (algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField) =
+      pointHom (genericPoint W K + Point.baseChange K _ S)
+        (genericPoint_add_baseChange_ne_zero W K S) :=
+  pointPull_comp_algebraMap _ (genericPoint_add_baseChange_ne_zero W K S) (transHom_injective W K S)
+
+theorem transPull_comp_pointHom (S : (W⁄K).Point) (P : (W⁄(W⁄K).FunctionField).Point) (hP : P ≠ 0)
+    (hP' : Point.map (transPull W K S) P ≠ 0) :
+    (transPull W K S).comp (pointHom P hP) = pointHom (Point.map (transPull W K S) P) hP' :=
+  pointPull_comp_pointHom _ _ _ P hP hP'
+
+theorem transPull_comp_transHom (S T : (W⁄K).Point) :
+    (transPull W K S).comp (pointHom (genericPoint W K + Point.baseChange K _ T)
+      (genericPoint_add_baseChange_ne_zero W K T)) =
+      pointHom (genericPoint W K + Point.baseChange K _ (S + T))
+        (genericPoint_add_baseChange_ne_zero W K (S + T)) := by
+  apply CoordinateRing.algHom_ext'
+  · rw [AlgHom.comp_apply, pointHom_mk_C_X, pointHom_mk_C_X, ← map_transPull_genericPoint_add,
+      Point.xc_map]
+  · rw [AlgHom.comp_apply, pointHom_mk_Y, pointHom_mk_Y, ← map_transPull_genericPoint_add,
+      Point.yc_map]
+
+theorem transPull_comp (S T : (W⁄K).Point) :
+    (transPull W K S).comp (transPull W K T) = transPull W K (S + T) := by
+  apply FunctionField.algHom_ext
+  rw [AlgHom.comp_toRingHom, RingHom.comp_assoc, transPull_comp_algebraMap W K T,
+    transPull_comp_algebraMap W K (S + T), ← AlgHom.comp_toRingHom, transPull_comp_transHom]
+
+theorem transPull_zero : transPull W K 0 = AlgHom.id K _ := by
+  apply FunctionField.algHom_ext
+  rw [transPull_comp_algebraMap]
+  have h0 : genericPoint W K + Point.baseChange K (W⁄K).FunctionField (0 : (W⁄K).Point) =
+      genericPoint W K := by
+    rw [map_zero, add_zero]
+  rw [pointHom_congr h0 _ (Point.some_ne_zero _), pointHom_genericPoint]
+  exact RingHom.ext fun x => rfl
+
+noncomputable def transEquiv (S : (W⁄K).Point) : (W⁄K).FunctionField ≃ₐ[K] (W⁄K).FunctionField :=
+  AlgEquiv.ofAlgHom (transPull W K S) (transPull W K (-S))
+    (by rw [transPull_comp, add_neg_cancel, transPull_zero])
+    (by rw [transPull_comp, neg_add_cancel, transPull_zero])
+
+theorem transEquiv_apply (S : (W⁄K).Point) (h : (W⁄K).FunctionField) :
+    transEquiv W K S h = transPull W K S h := rfl
+
+theorem coe_transEquiv (S : (W⁄K).Point) :
+    (transEquiv W K S : (W⁄K).FunctionField →ₐ[K] (W⁄K).FunctionField) = transPull W K S := rfl
+
+theorem transEquiv_algebraMap (S : (W⁄K).Point) (h : (W⁄K).CoordinateRing) :
+    transEquiv W K S (algebraMap _ _ h) =
+      pointHom (genericPoint W K + Point.baseChange K _ S)
+        (genericPoint_add_baseChange_ne_zero W K S) h :=
+  pointPull_algebraMap _ (genericPoint_add_baseChange_ne_zero W K S) (transHom_injective W K S) h
+
+theorem transEquiv_genericX (S : (W⁄K).Point) :
+    transEquiv W K S (genericX W K) = (genericPoint W K + Point.baseChange K _ S).xc := by
+  rw [genericX, transEquiv_algebraMap, pointHom_mk_C_X]
+
+theorem transEquiv_genericY (S : (W⁄K).Point) :
+    transEquiv W K S (genericY W K) = (genericPoint W K + Point.baseChange K _ S).yc := by
+  rw [genericY, transEquiv_algebraMap, pointHom_mk_Y]
+
+theorem map_transEquiv_genericPoint (S : (W⁄K).Point) :
+    Point.map (transEquiv W K S : (W⁄K).FunctionField →ₐ[K] (W⁄K).FunctionField)
+      (genericPoint W K) = genericPoint W K + Point.baseChange K _ S := by
+  rw [coe_transEquiv, map_transPull_genericPoint]
+
+theorem transEquiv_add (S T : (W⁄K).Point) :
+    transEquiv W K (S + T) = (transEquiv W K T).trans (transEquiv W K S) := by
+  apply AlgEquiv.ext
+  intro h
+  rw [AlgEquiv.trans_apply, transEquiv_apply, transEquiv_apply, transEquiv_apply,
+    ← AlgHom.comp_apply, transPull_comp]
+
+theorem transEquiv_zero : transEquiv W K 0 = AlgEquiv.refl := by
+  apply AlgEquiv.ext
+  intro h
+  rw [transEquiv_apply, transPull_zero]
+  rfl
+
+theorem transEquiv_injective : Function.Injective (transEquiv W K) := by
+  intro S T h
+  have hx := transEquiv_genericX W K S
+  have hy := transEquiv_genericY W K S
+  rw [h, transEquiv_genericX] at hx
+  rw [h, transEquiv_genericY] at hy
+  have hpt : genericPoint W K + Point.baseChange K _ T =
+      genericPoint W K + Point.baseChange K _ S :=
+    by
+    rw [Point.eq_some_xc_yc (genericPoint_add_baseChange_ne_zero W K T),
+      Point.eq_some_xc_yc (genericPoint_add_baseChange_ne_zero W K S)]
+    congr 1
+  exact (Point.map_injective _ (add_left_cancel hpt)).symm
+
+omit [IsAlgClosed K] in
+theorem neg_genericPoint_ne_baseChange (P : (W⁄K).Point) :
+    -genericPoint W K ≠ Point.baseChange K (W⁄K).FunctionField P := by
+  intro h
+  apply genericPoint_ne_baseChange W K (-P)
+  rw [map_neg, ← h, neg_neg]
+
+omit [DecidableEq K] in
+theorem negHom_injective :
+    Function.Injective (pointHom (-genericPoint W K) (neg_ne_zero.mpr (Point.some_ne_zero _))) := by
+  classical
+  exact
+    pointHom_injective_of_ne_baseChange _ _ (neg_genericPoint_ne_baseChange W K)
+
+noncomputable def negPull : (W⁄K).FunctionField →ₐ[K] (W⁄K).FunctionField :=
+  pointPull _ (neg_ne_zero.mpr (Point.some_ne_zero _)) (negHom_injective W K)
+
+omit [DecidableEq K] in
+theorem map_negPull_genericPoint : Point.map (negPull W K) (genericPoint W K) = -genericPoint W K :=
+    by
+  classical
+  exact
+    map_pointPull_genericPoint _ _ _
+
+omit [DecidableEq K] in
+theorem negPull_algebraMap (g : (W⁄K).CoordinateRing) :
+    negPull W K (algebraMap _ _ g) = pointHom (-genericPoint W K) (neg_ne_zero.mpr
+        (Point.some_ne_zero _)) g := by
+  classical
+  exact
+    pointPull_algebraMap _ _ _ g
+
+omit [DecidableEq K] in
+theorem negPull_comp_algebraMap :
+    (negPull W K : (W⁄K).FunctionField →+* (W⁄K).FunctionField).comp
+      (algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField) =
+      pointHom (-genericPoint W K) (neg_ne_zero.mpr (Point.some_ne_zero _)) := by
+  classical
+  exact
+    pointPull_comp_algebraMap _ _ _
+
+omit [DecidableEq K] in
+theorem negPull_comp_pointHom (P : (W⁄(W⁄K).FunctionField).Point) (hP : P ≠ 0)
+    (hP' : Point.map (negPull W K) P ≠ 0) :
+    (negPull W K).comp (pointHom P hP) = pointHom (Point.map (negPull W K) P) hP' := by
+  classical
+  exact
+    pointPull_comp_pointHom _ _ _ P hP hP'
+
+omit [DecidableEq K] in
+theorem negPull_comp_negPull : (negPull W K).comp (negPull W K) = AlgHom.id K _ := by
+  classical
+  apply FunctionField.algHom_ext
+  have hP' : Point.map (negPull W K) (-genericPoint W K) = genericPoint W K := by
+    rw [map_neg, map_negPull_genericPoint, neg_neg]
+  rw [AlgHom.comp_toRingHom, RingHom.comp_assoc, negPull_comp_algebraMap, ← AlgHom.comp_toRingHom,
+    negPull_comp_pointHom W K _ _ (by rw [hP']; exact Point.some_ne_zero _),
+    pointHom_congr hP' _ (Point.some_ne_zero _), pointHom_genericPoint]
+  exact RingHom.ext fun x => rfl
+
+noncomputable def negEquiv : (W⁄K).FunctionField ≃ₐ[K] (W⁄K).FunctionField :=
+  AlgEquiv.ofAlgHom _ _ (negPull_comp_negPull W K) (negPull_comp_negPull W K)
+
+omit [DecidableEq K] in
+theorem coe_negEquiv :
+    (negEquiv W K : (W⁄K).FunctionField →ₐ[K] (W⁄K).FunctionField) = negPull W K := by
+  classical
+  exact
+    rfl
+
+omit [DecidableEq K] in
+theorem negEquiv_apply (h : (W⁄K).FunctionField) : negEquiv W K h = negPull W K h := by
+  classical
+  exact
+    rfl
+
+omit [DecidableEq K] in
+theorem map_negEquiv_genericPoint :
+    Point.map (negEquiv W K : (W⁄K).FunctionField →ₐ[K] (W⁄K).FunctionField) (genericPoint W K) =
+      -genericPoint W K := by
+  classical
+  rw [coe_negEquiv, map_negPull_genericPoint]
+
+omit [DecidableEq K] in
+theorem negEquiv_genericX : negEquiv W K (genericX W K) = genericX W K := by
+  classical
+  rw [negEquiv_apply, genericX, negPull_algebraMap, pointHom_mk_C_X]
+  simp only [genericPoint, Point.neg_some, Point.xc_some]
+  rfl
+
+omit [DecidableEq K] in
+theorem negEquiv_genericY :
+    negEquiv W K (genericY W K) = (W⁄(W⁄K).FunctionField).negY (genericX W K) (genericY W K) := by
+  classical
+  rw [negEquiv_apply, genericY, negPull_algebraMap, pointHom_mk_Y]
+  simp only [genericPoint, Point.neg_some, Point.yc_some]
+  rfl
+
+omit [DecidableEq K] in
+theorem negEquiv_symm : (negEquiv W K).symm = negEquiv W K := by
+  classical
+  exact
+    rfl
+
+def MulGood (n : ℤ) : Prop :=
+  n • genericPoint W K ≠ 0 ∧
+    ∀ P : (W⁄K).Point, n • genericPoint W K ≠ Point.baseChange K (W⁄K).FunctionField P
+
+theorem mulHom_injective {n : ℤ} (h : MulGood W K n) :
+    Function.Injective (pointHom (n • genericPoint W K) h.1) :=
+  pointHom_injective_of_ne_baseChange _ _ h.2
+
+open Classical in
+noncomputable def mulPull (n : ℤ) : (W⁄K).FunctionField →ₐ[K] (W⁄K).FunctionField :=
+  if h : MulGood W K n then pointPull (n • genericPoint W K) h.1 (mulHom_injective W K h)
+  else AlgHom.id K _
+
+theorem mulPull_eq {n : ℤ} (h : MulGood W K n) :
+    mulPull W K n = pointPull (n • genericPoint W K) h.1 (mulHom_injective W K h) := by
+  grind [mulPull]
+
+theorem mulPull_algebraMap {n : ℤ} (h : MulGood W K n) (g : (W⁄K).CoordinateRing) :
+    mulPull W K n (algebraMap _ _ g) = pointHom (n • genericPoint W K) h.1 g := by
+  rw [mulPull_eq W K h, pointPull_algebraMap]
+
+theorem mulPull_comp_algebraMap {n : ℤ} (h : MulGood W K n) :
+    (mulPull W K n : (W⁄K).FunctionField →+* (W⁄K).FunctionField).comp
+      (algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField) = pointHom (n • genericPoint W K) h.1 :=
+  RingHom.ext fun g => mulPull_algebraMap W K h g
+
+theorem mulPull_genericX' {n : ℤ} (h : MulGood W K n) :
+    mulPull W K n (genericX W K) = (n • genericPoint W K).xc := by
+  rw [genericX, mulPull_algebraMap W K h, pointHom_mk_C_X]
+
+theorem mulPull_genericY' {n : ℤ} (h : MulGood W K n) :
+    mulPull W K n (genericY W K) = (n • genericPoint W K).yc := by
+  rw [genericY, mulPull_algebraMap W K h, pointHom_mk_Y]
+
+theorem map_mulPull_genericPoint' {n : ℤ} (h : MulGood W K n) :
+    Point.map (mulPull W K n) (genericPoint W K) = n • genericPoint W K := by
+  rw [mulPull_eq W K h, map_pointPull_genericPoint]
+
+theorem mulPull_comp_pointHom {n : ℤ} (h : MulGood W K n) (P : (W⁄(W⁄K).FunctionField).Point)
+    (hP : P ≠ 0) (hP' : Point.map (mulPull W K n) P ≠ 0) :
+    (mulPull W K n).comp (pointHom P hP) = pointHom (Point.map (mulPull W K n) P) hP' := by
+  have hP'' : Point.map (pointPull (n • genericPoint W K) h.1 (mulHom_injective W K h)) P ≠ 0 := by
+    rw [← mulPull_eq W K h]; exact hP'
+  rw [pointHom_congr (congrArg (fun φ => Point.map φ P) (mulPull_eq W K h)) hP' hP'', mulPull_eq W K
+    h]
+  exact pointPull_comp_pointHom _ _ _ P hP hP''
+
+theorem transEquiv_mulPull' {n : ℤ} (h : MulGood W K n) {S : (W⁄K).Point} (hS : n • S = 0)
+    (g : (W⁄K).FunctionField) : transEquiv W K S (mulPull W K n g) = mulPull W K n g := by
+  rw [transEquiv_apply, ← AlgHom.comp_apply]
+  congr 1
+  apply FunctionField.algHom_ext
+  have hP' : Point.map (transPull W K S) (n • genericPoint W K) = n • genericPoint W K := by
+    rw [map_zsmul, map_transPull_genericPoint, smul_add, ← map_zsmul, hS, map_zero, add_zero]
+  rw [AlgHom.comp_toRingHom, RingHom.comp_assoc, mulPull_comp_algebraMap W K h,
+    ← AlgHom.comp_toRingHom, transPull_comp_pointHom W K S _ _ (by rw [hP']; exact h.1)]
+  exact congrArg _ (pointHom_congr hP' _ _)
+
+theorem mulPull_comp' {m n : ℤ} (hm : MulGood W K m) (hn : MulGood W K n)
+    (hnm : MulGood W K (n * m)) :
+    (mulPull W K m).comp (mulPull W K n) = mulPull W K (n * m) := by
+  apply FunctionField.algHom_ext
+  have hP' : Point.map (mulPull W K m) (n • genericPoint W K) = (n * m) • genericPoint W K := by
+    rw [map_zsmul, map_mulPull_genericPoint' W K hm, smul_smul]
+  rw [AlgHom.comp_toRingHom, RingHom.comp_assoc, mulPull_comp_algebraMap W K hn,
+    mulPull_comp_algebraMap W K hnm, ← AlgHom.comp_toRingHom,
+    mulPull_comp_pointHom W K hm _ _ (by rw [hP']; exact hnm.1)]
+  exact congrArg _ (pointHom_congr hP' _ _)
+
+omit [DecidableEq K] in
+theorem exists_point_xc_eq (x : K) : ∃ P : (W⁄K).Point, P ≠ 0 ∧ P.xc = x := by
+  have : (W⁄K).IsElliptic := by
+    dsimp only [Affine.baseChange, WeierstrassCurve.baseChange]; infer_instance
+  set c := (W⁄K).a₁ * x + (W⁄K).a₃ with hc
+  set d := -(x ^ 3 + (W⁄K).a₂ * x ^ 2 + (W⁄K).a₄ * x + (W⁄K).a₆) with hd
+  have hlt : (C c * X + C d : K[X]).degree < ((X : K[X]) ^ 2).degree := by
+    rw [degree_X_pow]
+    refine (degree_add_le _ _).trans_lt (max_lt ((degree_C_mul_X_le c).trans_lt ?_)
+      (degree_C_le.trans_lt ?_))
+    · exact WithBot.coe_lt_coe.mpr (by norm_num)
+    · exact WithBot.coe_lt_coe.mpr (by norm_num)
+  have hdeg : ((X : K[X]) ^ 2 + (C c * X + C d)).degree = 2 := by
+    rw [degree_add_eq_left_of_degree_lt hlt, degree_X_pow]; rfl
+  obtain ⟨y, hy⟩ := IsAlgClosed.exists_root ((X : K[X]) ^ 2 + (C c * X + C d))
+    (by rw [hdeg]; exact two_ne_zero)
+  have hroot : y ^ 2 + (c * y + d) = 0 := by
+    have := hy.eq_zero
+    simpa only [eval_add, eval_pow, eval_X, eval_mul, eval_C] using this
+  have heq : (W⁄K).Equation x y := by
+    rw [equation_iff]
+    rw [hc, hd] at hroot
+    linear_combination hroot
+  exact ⟨.some x y ((equation_iff_nonsingular (W := W⁄K)).mp heq), Point.some_ne_zero _, rfl⟩
+
+omit [DecidableEq K] in
+theorem infinite_point : Infinite (W⁄K).Point := by
+  choose f hf0 hfx using exists_point_xc_eq W K
+  exact Infinite.of_injective f fun x y h => by rw [← hfx x, ← hfx y, h]
+
+omit [DecidableEq K] in
+theorem map_negEquiv_zsmul_genericPoint (n : ℤ) :
+    Point.map (negEquiv W K : (W⁄K).FunctionField →ₐ[K] (W⁄K).FunctionField)
+      (n • genericPoint W K) = -(n • genericPoint W K) := by
+  classical
+  rw [map_zsmul, map_negEquiv_genericPoint, smul_neg]
+
+theorem negEquiv_mulPull_genericX' {n : ℤ} (h : MulGood W K n) :
+    negEquiv W K (mulPull W K n (genericX W K)) = (n • genericPoint W K).xc := by
+  rw [mulPull_genericX' W K h, ← AlgEquiv.coe_toAlgHom, ← Point.xc_map (W := W) (K := K),
+    map_negEquiv_zsmul_genericPoint, Point.eq_some_xc_yc h.1, Point.neg_some, Point.xc_some,
+    Point.xc_some]
+
+theorem negEquiv_mulPull_genericY' {n : ℤ} (h : MulGood W K n) :
+    negEquiv W K (mulPull W K n (genericY W K)) =
+      (W⁄(W⁄K).FunctionField).negY (n • genericPoint W K).xc (n • genericPoint W K).yc := by
+  rw [mulPull_genericY' W K h, ← AlgEquiv.coe_toAlgHom, ← Point.yc_map (W := W) (K := K),
+    map_negEquiv_zsmul_genericPoint]
+  conv_lhs => rw [Point.eq_some_xc_yc h.1, Point.neg_some, Point.yc_some]
+
+omit [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] in
+theorem mulPull_injective [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] (n : ℤ) :
+    Function.Injective (mulPull W K n) := (mulPull W K n).injective
+
+end TransMul
+
+section Places
+
+variable {R : Type*} [Field R] (W : WeierstrassCurve R) (K : Type*) [Field K] [Algebra R K]
+  [DecidableEq K]
+
+noncomputable def placeOf (P : (W⁄K).Point) (hP : P ≠ 0) :
+    IsDedekindDomain.HeightOneSpectrum (W⁄K).CoordinateRing where
+  asIdeal := CoordinateRing.XYIdeal (W⁄K) P.xc (C P.yc)
+  isPrime := (CoordinateRing.XYIdeal_isMaximal (Point.nonsingular_xc_yc hP).left).isPrime
+  ne_bot h := CoordinateRing.XClass_ne_zero (W' := W⁄K) P.xc
+    (by rw [← Ideal.mem_bot, ← h]; exact Ideal.subset_span (Set.mem_insert _ _))
+
+omit [DecidableEq K] in
+@[simp] theorem placeOf_asIdeal (P : (W⁄K).Point) (hP : P ≠ 0) :
+    (placeOf W K P hP).asIdeal = CoordinateRing.XYIdeal (W⁄K) P.xc (C P.yc) := rfl
+
+omit [DecidableEq K] in
+theorem placeOf_surjective [IsAlgClosed K] [W.IsElliptic]
+    (v : IsDedekindDomain.HeightOneSpectrum (W⁄K).CoordinateRing) :
+    ∃ (P : (W⁄K).Point) (hP : P ≠ 0), placeOf W K P hP = v := by
+  have : (W⁄K).IsElliptic := by
+    dsimp only [Affine.baseChange, WeierstrassCurve.baseChange]; infer_instance
+  have := v.isPrime
+  obtain ⟨a, b, hab, hv⟩ := CoordinateRing.exists_eq_XYIdeal v.ne_bot
+  refine ⟨.some a b ((equation_iff_nonsingular (W := W⁄K)).mp hab), Point.some_ne_zero _, ?_⟩
+  exact IsDedekindDomain.HeightOneSpectrum.ext hv.symm
+
+noncomputable def CoordinateRing.evalAt {a b : K} (h : (W⁄K).Equation a b) :
+    (W⁄K).CoordinateRing →+* K :=
+  AdjoinRoot.evalEval h
+
+omit [DecidableEq K] in
+theorem CoordinateRing.evalAt_mk {a b : K} (h : (W⁄K).Equation a b) (g : K[X][Y]) :
+    CoordinateRing.evalAt W K h (CoordinateRing.mk (W⁄K) g) = g.evalEval a b :=
+  AdjoinRoot.evalEval_mk h g
+
+omit [DecidableEq K] in
+theorem CoordinateRing.evalAt_XYIdeal {a b : K} (h : (W⁄K).Equation a b) :
+    ∀ g ∈ CoordinateRing.XYIdeal (W⁄K) a (C b), CoordinateRing.evalAt W K h g = 0 := by
+  intro g hg
+  rw [← RingHom.mem_ker]
+  revert hg g
+  rw [← IsConcreteLE.le_iff, CoordinateRing.XYIdeal, Ideal.span_le]
+  rintro g (rfl | rfl)
+  · rw [SetLike.mem_coe, RingHom.mem_ker, CoordinateRing.XClass, CoordinateRing.evalAt_mk,
+      evalEval_C, eval_sub, eval_X, eval_C, sub_self]
+  · rw [SetLike.mem_coe, RingHom.mem_ker, CoordinateRing.YClass, CoordinateRing.evalAt_mk,
+      evalEval_sub, evalEval_X, evalEval_C, eval_C, sub_self]
+
+omit [DecidableEq K] in
+theorem placeOf_injective {P Q : (W⁄K).Point} (hP : P ≠ 0) (hQ : Q ≠ 0)
+    (h : placeOf W K P hP = placeOf W K Q hQ) : P = Q := by
+  have hI : CoordinateRing.XYIdeal (W⁄K) P.xc (C P.yc) =
+      CoordinateRing.XYIdeal (W⁄K) Q.xc (C Q.yc) :=
+    congrArg IsDedekindDomain.HeightOneSpectrum.asIdeal h
+  have hev := CoordinateRing.evalAt_XYIdeal W K (Point.nonsingular_xc_yc hP).left
+  rw [hI] at hev
+  have hx : P.xc = Q.xc := by
+    have := hev _ (Ideal.subset_span (Set.mem_insert _ _))
+    rw [CoordinateRing.XClass, CoordinateRing.evalAt_mk, evalEval_C, eval_sub, eval_X, eval_C,
+      sub_eq_zero] at this
+    exact this
+  have hy : P.yc = Q.yc := by
+    have := hev _ (Ideal.subset_span (Set.mem_insert_of_mem _ rfl))
+    rw [CoordinateRing.YClass, CoordinateRing.evalAt_mk, evalEval_sub, evalEval_X, evalEval_C,
+      eval_C,
+      sub_eq_zero] at this
+    exact this
+  rw [Point.eq_some_xc_yc hP, Point.eq_some_xc_yc hQ]
+  congr 1
+
+end Places
+
+end WeierstrassCurve.Affine
+
+open Polynomial
+
+namespace Valuation
+
+variable {L : Type*} [CommRing L] {Γ₀ : Type*} [LinearOrderedCommGroupWithZero Γ₀]
+    (v : Valuation L Γ₀)
+
+def Cong (a b : L) : Prop := v (a - b) < 1
+
+variable {v}
+
+theorem cong_iff {a b : L} : v.Cong a b ↔ v (a - b) < 1 := Iff.rfl
+
+@[refl] theorem Cong.refl (a : L) : v.Cong a a := by simp [Cong]
+
+theorem Cong.rfl {a : L} : v.Cong a a := Cong.refl a
+
+@[symm] theorem Cong.symm {a b : L} (h : v.Cong a b) : v.Cong b a := by
+  rw [Cong, ← Valuation.map_neg, neg_sub]; exact h
+
+theorem Cong.trans {a b c : L} (h₁ : v.Cong a b) (h₂ : v.Cong b c) : v.Cong a c := by
+  have : a - c = (a - b) + (b - c) := by ring
+  rw [Cong, this]
+  exact (v.map_add _ _).trans_lt (max_lt h₁ h₂)
+
+theorem Cong.add {a b a' b' : L} (h₁ : v.Cong a a') (h₂ : v.Cong b b') :
+    v.Cong (a + b) (a' + b') := by
+  have : a + b - (a' + b') = (a - a') + (b - b') := by ring
+  rw [Cong, this]
+  exact (v.map_add _ _).trans_lt (max_lt h₁ h₂)
+
+theorem Cong.neg {a a' : L} (h : v.Cong a a') : v.Cong (-a) (-a') := by
+  have : -a - -a' = -(a - a') := by ring
+  rw [Cong, this, Valuation.map_neg]; exact h
+
+theorem Cong.sub {a b a' b' : L} (h₁ : v.Cong a a') (h₂ : v.Cong b b') :
+    v.Cong (a - b) (a' - b') := by
+  rw [sub_eq_add_neg, sub_eq_add_neg]; exact h₁.add h₂.neg
+
+theorem Cong.le_one {a a' : L} (h : v.Cong a a') (ha' : v a' ≤ 1) : v a ≤ 1 := by
+  have : a = (a - a') + a' := by ring
+  rw [this]
+  exact (v.map_add _ _).trans (max_le h.le ha')
+
+theorem Cong.mul {a b a' b' : L} (h₁ : v.Cong a a') (h₂ : v.Cong b b') (ha' : v a' ≤ 1)
+    (hb' : v b' ≤ 1) : v.Cong (a * b) (a' * b') := by
+  have ha : v a ≤ 1 := h₁.le_one ha'
+  have : a * b - a' * b' = a * (b - b') + (a - a') * b' := by ring
+  rw [Cong, this]
+  refine (v.map_add _ _).trans_lt (max_lt ?_ ?_)
+  · rw [Valuation.map_mul]
+    calc v a * v (b - b') ≤ 1 * v (b - b') := mul_le_mul' ha le_rfl
+      _ < 1 := by rw [one_mul]; exact h₂
+  · rw [Valuation.map_mul]
+    calc v (a - a') * v b' ≤ v (a - a') * 1 := mul_le_mul' le_rfl hb'
+      _ < 1 := by rw [mul_one]; exact h₁
+
+theorem Cong.pow {a a' : L} (h : v.Cong a a') (ha' : v a' ≤ 1) (n : ℕ) :
+    v.Cong (a ^ n) (a' ^ n) := by
+  induction n with
+  | zero => simp only [pow_zero]; exact Cong.rfl
+  | succ n ih =>
+    rw [pow_succ, pow_succ]
+    exact ih.mul h (by rw [Valuation.map_pow]; exact pow_le_one' ha' n) ha'
+
+theorem Cong.eq_of_eq_one {a a' : L} (h : v.Cong a a') (ha' : v a' = 1) : v a = 1 := by
+  have : a = a' + (a - a') := by ring
+  rw [this, Valuation.map_add_eq_of_lt_left]
+  · exact ha'
+  · rw [ha']; exact h
+
+theorem Cong.lt_one_iff {a a' : L} (h : v.Cong a a') : v a < 1 ↔ v a' < 1 := by
+  constructor
+  · intro ha
+    have : a' = a - (a - a') := by ring
+    rw [this]
+    exact (v.map_sub _ _).trans_lt (max_lt ha h)
+  · intro ha'
+    have : a = (a - a') + a' := by ring
+    rw [this]
+    exact (v.map_add _ _).trans_lt (max_lt h ha')
+
+theorem cong_zero_iff {a : L} : v.Cong a 0 ↔ v a < 1 := by rw [Cong, sub_zero]
+
+section Field
+
+variable {F : Type*} [Field F] {Γ : Type*} [LinearOrderedCommGroupWithZero Γ] {w : Valuation F Γ}
+
+theorem Cong.inv {d d' : F} (h : w.Cong d d') (hd' : w d' = 1) : w.Cong d⁻¹ d'⁻¹ := by
+  have hd : w d = 1 := h.eq_of_eq_one hd'
+  have hd0 : d ≠ 0 := fun h0 => by rw [h0, Valuation.map_zero] at hd; exact zero_ne_one hd
+  have hd0' : d' ≠ 0 := fun h0 => by rw [h0, Valuation.map_zero] at hd'; exact zero_ne_one hd'
+  have : d⁻¹ - d'⁻¹ = -(d - d') * (d⁻¹ * d'⁻¹) := by
+    field_simp
+    ring
+  rw [Cong, this, Valuation.map_mul, Valuation.map_neg, Valuation.map_mul, map_inv₀, map_inv₀, hd,
+    hd',
+    inv_one, mul_one, mul_one]
+  exact h
+
+theorem Cong.div {a d a' d' : F} (h₁ : w.Cong a a') (h₂ : w.Cong d d') (ha' : w a' ≤ 1)
+    (hd' : w d' = 1) : w.Cong (a / d) (a' / d') := by
+  rw [div_eq_mul_inv, div_eq_mul_inv]
+  exact h₁.mul (h₂.inv hd') ha' (by rw [map_inv₀, hd', inv_one])
+
+end Field
+
+section Eval
+
+variable {K : Type*} [CommRing K] (f : K →+* L)
+
+theorem Cong.eval₂ (hf : ∀ c, v (f c) ≤ 1) {a a' : L} (h : v.Cong a a') (ha' : v a' ≤ 1) (p : K[X])
+    :
+    v.Cong (p.eval₂ f a) (p.eval₂ f a') ∧ v (p.eval₂ f a') ≤ 1 := by
+  induction p using Polynomial.induction_on' with
+  | add p q hp hq =>
+    rw [eval₂_add, eval₂_add]
+    exact ⟨hp.1.add hq.1, (v.map_add _ _).trans (max_le hp.2 hq.2)⟩
+  | monomial n c =>
+    rw [eval₂_monomial, eval₂_monomial]
+    have hpow : v (a' ^ n) ≤ 1 := by rw [Valuation.map_pow]; exact pow_le_one' ha' n
+    exact ⟨(Cong.refl (f c)).mul (h.pow ha' n) (hf c) hpow,
+      by rw [Valuation.map_mul]; exact mul_le_one' (hf c) hpow⟩
+
+theorem Cong.eval₂_eval₂ (hf : ∀ c, v (f c) ≤ 1) {a a' b b' : L} (ha : v.Cong a a') (ha' : v a' ≤ 1)
+    (hb : v.Cong b b') (hb' : v b' ≤ 1) (p : K[X][X]) :
+    v.Cong (p.eval₂ (eval₂RingHom f a) b) (p.eval₂ (eval₂RingHom f a') b') ∧
+      v (p.eval₂ (eval₂RingHom f a') b') ≤ 1 := by
+  induction p using Polynomial.induction_on' with
+  | add p q hp hq =>
+    rw [eval₂_add, eval₂_add]
+    exact ⟨hp.1.add hq.1, (v.map_add _ _).trans (max_le hp.2 hq.2)⟩
+  | monomial n q =>
+    rw [eval₂_monomial, eval₂_monomial, coe_eval₂RingHom, coe_eval₂RingHom]
+    have hq := Cong.eval₂ f hf ha ha' q
+    have hpow : v (b' ^ n) ≤ 1 := by rw [Valuation.map_pow]; exact pow_le_one' hb' n
+    exact ⟨hq.1.mul (hb.pow hb' n) hq.2 hpow, by
+      rw [Valuation.map_mul]; exact mul_le_one' hq.2 hpow⟩
+
+end Eval
+
+end Valuation
+
+open IsDedekindDomain IsDedekindDomain.HeightOneSpectrum WithZero
+
+namespace IsDedekindDomain.HeightOneSpectrum
+
+variable {R : Type*} [CommRing R] [IsDedekindDomain R] {K : Type*} [Field K] [Algebra R K]
+  [IsFractionRing R K] {R' : Type*} [CommRing R'] [IsDedekindDomain R'] {K' : Type*} [Field K']
+  [Algebra R' K'] [IsFractionRing R' K']
+
+omit [IsDedekindDomain R] [IsFractionRing R K] in
+theorem valuation_map_le_exp_neg_of_mem_pow (ψ : K →+* K') (w : HeightOneSpectrum R)
+    (v : HeightOneSpectrum R')
+    (h0 : ∀ b : R, v.valuation K' (ψ (algebraMap R K b)) ≤ 1)
+    (h1 : ∀ b : R, b ∈ w.asIdeal → v.valuation K' (ψ (algebraMap R K b)) ≤ exp (-1 : ℤ))
+    (m : ℕ) : ∀ a ∈ w.asIdeal ^ m, v.valuation K' (ψ (algebraMap R K a)) ≤ exp (-(m : ℤ)) := by
+  induction m with
+  | zero =>
+    intro a _
+    rw [Nat.cast_zero, neg_zero, exp_zero]
+    exact h0 a
+  | succ m ih =>
+    intro a ha
+    rw [pow_succ'] at ha
+    refine Submodule.mul_induction_on ha ?_ ?_
+    · intro c hc a' ha'
+      rw [map_mul, map_mul, map_mul, Nat.cast_succ, neg_add, add_comm, exp_add]
+      exact mul_le_mul' (h1 c hc) (ih a' ha')
+    · intro z₁ z₂ hz₁ hz₂
+      rw [map_add, map_add]
+      exact (Valuation.map_add _ _ _).trans (max_le hz₁ hz₂)
+
+theorem valuation_map_le_of_valuation_le (ψ : K →+* K') (w : HeightOneSpectrum R)
+    (v : HeightOneSpectrum R')
+    (h1 : ∀ b : R, b ∈ w.asIdeal → v.valuation K' (ψ (algebraMap R K b)) ≤ exp (-1 : ℤ))
+    (h2 : ∀ b : R, b ∉ w.asIdeal → v.valuation K' (ψ (algebraMap R K b)) = 1)
+    (x : K) (k : ℕ) (hx : w.valuation K x ≤ exp (-(k : ℤ))) :
+    v.valuation K' (ψ x) ≤ exp (-(k : ℤ)) := by
+  have h0 : ∀ b : R, v.valuation K' (ψ (algebraMap R K b)) ≤ 1 := by
+    intro b
+    by_cases hb : b ∈ w.asIdeal
+    · exact (h1 b hb).trans (by rw [← exp_zero, exp_le_exp]; norm_num)
+    · exact (h2 b hb).le
+  have hx1 : w.valuation K x ≤ 1 :=
+    hx.trans (by rw [← exp_zero, exp_le_exp, neg_nonpos]; exact Nat.cast_nonneg k)
+  obtain ⟨n, d, hnd⟩ := exists_primeCompl_mul_eq_of_integer (v := w) x hx1
+  have hd : (d : R) ∉ w.asIdeal := d.2
+  have hwn : w.valuation K (algebraMap R K n) ≤ exp (-(k : ℤ)) := by
+    rw [← hnd, map_mul, (valuation_eq_one_iff_notMem (K := K) w).mpr hd, mul_one]
+    exact hx
+  rw [valuation_of_algebraMap, intValuation_le_pow_iff_mem] at hwn
+  have hψn := valuation_map_le_exp_neg_of_mem_pow ψ w v h0 h1 k n hwn
+  have := congrArg (fun t => v.valuation K' (ψ t)) hnd
+  simp only [map_mul, h2 d hd, mul_one] at this
+  rw [this]
+  exact hψn
+
+end IsDedekindDomain.HeightOneSpectrum
+
+namespace WeierstrassCurve.Affine
+
+open IsDedekindDomain IsDedekindDomain.HeightOneSpectrum WithZero Polynomial
+
+section Transport
+
+variable {R : Type*} [Field R] (W : WeierstrassCurve R) (K : Type*) [Field K] [Algebra R K]
+  [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing]
+
+theorem _root_.WithZero.lt_one_iff_le_exp_neg_one {y : ℤᵐ⁰} : y < 1 ↔ y ≤ exp (-1 : ℤ) := by
+  by_cases hy : y = 0
+  · subst hy; simp
+  · rw [← exp_log hy, ← exp_zero, exp_lt_exp, exp_le_exp]; omega
+
+omit [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] in
+theorem valuation_algebraMap_le_one (P : (W⁄K).Point) (hP : P ≠ 0) (c : K) :
+    (placeOf W K P hP).valuation (W⁄K).FunctionField (algebraMap K (W⁄K).FunctionField c) ≤ 1 := by
+  rw [IsScalarTower.algebraMap_apply K (W⁄K).CoordinateRing (W⁄K).FunctionField]
+  exact valuation_le_one _ _
+
+omit [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] in
+theorem valuation_algebraMap_eq_one (P : (W⁄K).Point) (hP : P ≠ 0) {c : K} (hc : c ≠ 0) :
+    (placeOf W K P hP).valuation (W⁄K).FunctionField (algebraMap K (W⁄K).FunctionField c) = 1 := by
+  apply le_antisymm (valuation_algebraMap_le_one W K P hP c)
+  have h := valuation_algebraMap_le_one W K P hP c⁻¹
+  rw [map_inv₀, map_inv₀, inv_le_one₀] at h
+  · exact h
+  · rw [Valuation.pos_iff]
+    exact (_root_.map_ne_zero _).mpr hc
+
+omit [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing] in
+theorem mem_placeOf_iff (P : (W⁄K).Point) (hP : P ≠ 0) (b : (W⁄K).CoordinateRing) :
+    b ∈ (placeOf W K P hP).asIdeal ↔
+      CoordinateRing.evalAt W K (Point.nonsingular_xc_yc hP).left b = 0 := by
+  constructor
+  · exact CoordinateRing.evalAt_XYIdeal W K _ b
+  · intro hb
+    have hker : RingHom.ker (CoordinateRing.evalAt W K (Point.nonsingular_xc_yc hP).left) =
+        (placeOf W K P hP).asIdeal := by
+      refine ((CoordinateRing.XYIdeal_isMaximal (Point.nonsingular_xc_yc hP).left).eq_of_le
+        (RingHom.ker_ne_top _) ?_).symm
+      intro g hg
+      exact (RingHom.mem_ker).mpr (CoordinateRing.evalAt_XYIdeal W K _ g hg)
+    rw [← hker]
+    exact (RingHom.mem_ker).mpr hb
+
+omit [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] in
+theorem cong_genericX (P : (W⁄K).Point) (hP : P ≠ 0) :
+    ((placeOf W K P hP).valuation (W⁄K).FunctionField).Cong (genericX W K)
+      (algebraMap K (W⁄K).FunctionField P.xc) := by
+  rw [Valuation.cong_iff, IsScalarTower.algebraMap_apply K (W⁄K).CoordinateRing (W⁄K).FunctionField,
+    genericX,
+    ← map_sub]
+  apply (valuation_lt_one_iff_mem _ _).mpr
+  rw [placeOf_asIdeal]
+  have : CoordinateRing.mk (W⁄K) (C X) - algebraMap K (W⁄K).CoordinateRing P.xc =
+      CoordinateRing.XClass (W⁄K) P.xc := by
+    rw [CoordinateRing.XClass, map_sub, map_sub]; rfl
+  rw [this]
+  exact Ideal.subset_span (Set.mem_insert _ _)
+
+omit [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] in
+theorem cong_genericY (P : (W⁄K).Point) (hP : P ≠ 0) :
+    ((placeOf W K P hP).valuation (W⁄K).FunctionField).Cong (genericY W K)
+      (algebraMap K (W⁄K).FunctionField P.yc) := by
+  rw [Valuation.cong_iff, IsScalarTower.algebraMap_apply K (W⁄K).CoordinateRing (W⁄K).FunctionField,
+    genericY,
+    ← map_sub]
+  apply (valuation_lt_one_iff_mem _ _).mpr
+  rw [placeOf_asIdeal]
+  have : CoordinateRing.mk (W⁄K) Y - algebraMap K (W⁄K).CoordinateRing P.yc =
+      CoordinateRing.YClass (W⁄K) (C P.yc) := by
+    rw [CoordinateRing.YClass, map_sub]; rfl
+  rw [this]
+  exact Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+
+omit [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing] in
+theorem algebraMap_evalEval (g : K[X][Y]) (a b : K) :
+    algebraMap K (W⁄K).FunctionField (g.evalEval a b) = g.eval₂
+        (eval₂RingHom (algebraMap K (W⁄K).FunctionField) (algebraMap K _ a))
+        (algebraMap K _ b) := by
+  have hφ : (algebraMap K (W⁄K).FunctionField).comp (evalEvalRingHom a b) =
+      eval₂RingHom (eval₂RingHom (algebraMap K (W⁄K).FunctionField) (algebraMap K _ a))
+        (algebraMap K _ b) := by
+    apply Polynomial.ringHom_ext
+    · intro q
+      simp only [RingHom.coe_comp, Function.comp_apply, coe_evalRingHom, eval_C, coe_eval₂RingHom,
+        eval₂_C, eval₂_at_apply]
+    · simp only [RingHom.coe_comp, Function.comp_apply, coe_evalRingHom, eval_X, eval_C,
+        coe_eval₂RingHom,
+        eval₂_X]
+  exact RingHom.congr_fun hφ g
+
+omit [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing] in
+theorem pointHom_mk_eq_eval₂ (Q : (W⁄(W⁄K).FunctionField).Point) (hQ : Q ≠ 0) (g : K[X][Y]) :
+    pointHom Q hQ (CoordinateRing.mk (W⁄K) g) =
+      g.eval₂ (eval₂RingHom (algebraMap K (W⁄K).FunctionField) Q.xc) Q.yc := by
+  rw [pointHom_mk]
+  congr 1
+
+omit [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] in
+theorem valuation_pointPull_le (Q : (W⁄(W⁄K).FunctionField).Point) (hQ : Q ≠ 0)
+    (hinj : Function.Injective (pointHom Q hQ)) {P : (W⁄K).Point} (hP : P ≠ 0) {P' : (W⁄K).Point}
+    (hP' : P' ≠ 0)
+    (hx : ((placeOf W K P hP).valuation (W⁄K).FunctionField).Cong Q.xc (algebraMap K _ P'.xc))
+    (hy : ((placeOf W K P hP).valuation (W⁄K).FunctionField).Cong Q.yc (algebraMap K _ P'.yc))
+    (h : (W⁄K).FunctionField) (k : ℕ)
+    (hh : (placeOf W K P' hP').valuation (W⁄K).FunctionField h ≤ exp (-(k : ℤ))) :
+    (placeOf W K P hP).valuation (W⁄K).FunctionField (pointPull Q hQ hinj h) ≤ exp (-(k : ℤ)) := by
+  set v := (placeOf W K P hP).valuation (W⁄K).FunctionField with hv
+  have hc : ∀ g : K[X][Y], v.Cong (pointHom Q hQ (CoordinateRing.mk (W⁄K) g))
+      (algebraMap K _ (g.evalEval P'.xc P'.yc)) := by
+    intro g
+    rw [pointHom_mk_eq_eval₂, algebraMap_evalEval]
+    exact (Valuation.Cong.eval₂_eval₂ _ (valuation_algebraMap_le_one W K P hP)
+      hx (valuation_algebraMap_le_one W K P hP _) hy (valuation_algebraMap_le_one W K P hP _) g).1
+  refine valuation_map_le_of_valuation_le (pointPull Q hQ hinj : _ →+* (W⁄K).FunctionField)
+      (placeOf W K P' hP') (placeOf W K P hP) ?_ ?_ h k hh
+  · intro b hb
+    obtain ⟨g, rfl⟩ := Ideal.Quotient.mk_surjective b
+    change v (pointPull Q hQ hinj (algebraMap _ _ (CoordinateRing.mk (W⁄K) g))) ≤ _
+    rw [pointPull_algebraMap, ← lt_one_iff_le_exp_neg_one, ← Valuation.cong_zero_iff]
+    have h0 : g.evalEval P'.xc P'.yc = 0 := by
+      rw [← CoordinateRing.evalAt_mk W K (Point.nonsingular_xc_yc hP').left]
+      exact (mem_placeOf_iff W K P' hP' _).mp hb
+    simpa only [h0, map_zero] using hc g
+  · intro b hb
+    obtain ⟨g, rfl⟩ := Ideal.Quotient.mk_surjective b
+    change v (pointPull Q hQ hinj (algebraMap _ _ (CoordinateRing.mk (W⁄K) g))) = 1
+    rw [pointPull_algebraMap]
+    have h0 : g.evalEval P'.xc P'.yc ≠ 0 := by
+      rw [← CoordinateRing.evalAt_mk W K (Point.nonsingular_xc_yc hP').left]
+      exact fun h => hb ((mem_placeOf_iff W K P' hP' _).mpr h)
+    exact (hc g).eq_of_eq_one (valuation_algebraMap_eq_one W K P hP h0)
+
+theorem valuation_mulPull_le {n : ℤ} (hgood : MulGood W K n) (Φ Ψ : K[X]) (ω ψ : K[X][Y])
+    (hξ : (n • genericPoint W K).xc =
+      Φ.eval₂ (algebraMap K (W⁄K).FunctionField) (genericX W K) /
+        Ψ.eval₂ (algebraMap K (W⁄K).FunctionField) (genericX W K))
+    (hη : (n • genericPoint W K).yc =
+      ω.eval₂ (eval₂RingHom (algebraMap K (W⁄K).FunctionField) (genericX W K)) (genericY W K) /
+        ψ.eval₂ (eval₂RingHom (algebraMap K (W⁄K).FunctionField) (genericX W K)) (genericY W K) ^ 3)
+    {P : (W⁄K).Point} (hP : P ≠ 0) (hnP : n • P ≠ 0)
+    (hxP : (n • P).xc = Φ.eval P.xc / Ψ.eval P.xc) (hΨ : Ψ.eval P.xc ≠ 0)
+    (hyP : (n • P).yc = ω.evalEval P.xc P.yc / ψ.evalEval P.xc P.yc ^ 3)
+    (hψ : ψ.evalEval P.xc P.yc ≠ 0)
+    (h : (W⁄K).FunctionField) (k : ℕ)
+    (hh : (placeOf W K (n • P) hnP).valuation (W⁄K).FunctionField h ≤ exp (-(k : ℤ))) :
+    (placeOf W K P hP).valuation (W⁄K).FunctionField (mulPull W K n h) ≤ exp (-(k : ℤ)) := by
+  set v := (placeOf W K P hP).valuation (W⁄K).FunctionField with hv
+  have hc1 := valuation_algebraMap_le_one W K P hP
+  have hX := cong_genericX W K P hP
+  have hY := cong_genericY W K P hP
+  have hx : v.Cong (n • genericPoint W K).xc (algebraMap K _ (n • P).xc) := by
+    rw [hξ, hxP, map_div₀, ← eval₂_at_apply, ← eval₂_at_apply]
+    have hΦ := Valuation.Cong.eval₂ (v := v) (algebraMap K _) hc1 hX (hc1 _) Φ
+    have hΨc := Valuation.Cong.eval₂ (v := v) (algebraMap K _) hc1 hX (hc1 _) Ψ
+    refine hΦ.1.div hΨc.1 hΦ.2 ?_
+    rw [eval₂_at_apply]
+    exact valuation_algebraMap_eq_one W K P hP hΨ
+  have hy : v.Cong (n • genericPoint W K).yc (algebraMap K _ (n • P).yc) := by
+    rw [hη, hyP, map_div₀, map_pow, algebraMap_evalEval, algebraMap_evalEval]
+    have hω := Valuation.Cong.eval₂_eval₂ (v := v) (algebraMap K _) hc1 hX (hc1 _) hY (hc1 _) ω
+    have hψc := Valuation.Cong.eval₂_eval₂ (v := v) (algebraMap K _) hc1 hX (hc1 _) hY (hc1 _) ψ
+    refine hω.1.div (hψc.1.pow hψc.2 3) hω.2 ?_
+    rw [← algebraMap_evalEval, ← map_pow]
+    exact valuation_algebraMap_eq_one W K P hP (pow_ne_zero 3 hψ)
+  rw [mulPull_eq W K hgood]
+  exact valuation_pointPull_le W K _ _ _ hP hnP hx hy h k hh
+
+end Transport
+
+end WeierstrassCurve.Affine
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_PointReduction.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_PointReduction.lean
new file mode 100644
index 0000000000..9a96efc6f3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_PointReduction.lean
@@ -0,0 +1,87 @@
+/-
+Based on Prove2Me node EllipticCurve_PointReduction
+(7150a7a6-c03e-5699-a54a-491bb7315118) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Reduction
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+
+/-!
+# Reduction of coordinates and points on a minimal Weierstrass curve
+
+Definition: `EllipticCurve_PointReduction` (`7150a7a6-c03e-5699-a54a-491bb7315118`), by Claude,
+2026-09-05.
+
+Throughout, $R$ is a discrete valuation ring that is a domain, $K$ is a field equipped with an
+$R$-algebra structure making it the fraction field of $R$, and $\mathrm{ResidueField}\,R$ denotes
+the residue field of $R$.
+
+[`WeierstrassCurve.reduceCoord R x`](../def/EllipticCurve_PointReduction.html#L17), for $x \in K$,
+is defined by cases: if some $r \in R$ has $r \mapsto x$ under the structure map $R \to K$, the
+value is the residue class of such an $r$ in the residue field; otherwise the value is $0$. Since $R
+\to K$ is injective, the residue class does not depend on the element chosen, so on $R$-integral
+elements this is the composite $R \to \mathrm{ResidueField}\,R$ transported along $R \cong$
+(integral elements of $K$), while non-integral $x$ receive the junk value $0$.
+
+[`WeierstrassCurve.reducePoint_alt`](../def/EllipticCurve_PointReduction.html#L22) takes a
+Weierstrass curve $W$ over $K$ together with an instance of Mathlib's minimality predicate
+`W.IsMinimal R`, and produces a function from the points of the associated affine curve $W$ to the
+points of the affine curve attached to the reduced curve `W.reduction R` over the residue field. It
+is defined by cases on the point: the point at infinity goes to the point at infinity; an affine
+point $(x,y)$ (carrying its nonsingularity witness on $W$) goes to $(\bar x, \bar y) =
+($`reduceCoord R x`$,$ `reduceCoord R y`$)$ provided two conditions hold, namely that both
+valuations $v(x), v(y) \le 1$ for the valuation of $K$ attached to the maximal ideal of $R$ (that
+is, both coordinates are integral) and that the pair $(\bar x, \bar y)$ is a nonsingular point of
+the reduced curve; in every remaining case, the value is the point at infinity. Thus points with a
+non-integral coordinate, and pairs whose reduction is singular, are sent to the point at infinity by
+fiat. This is a bare function on points: no additivity, kernel or injectivity statement is part of
+the definition.
+
+**Relation to Mathlib.** Mathlib supplies the minimality predicate `WeierstrassCurve.IsMinimal`, the
+reduced curve `WeierstrassCurve.reduction`, and the group of affine points
+`WeierstrassCurve.Affine.Point`; the reduction map on points, and the partial section `reduceCoord`
+of the residue map used to define it, are the project's own.
+
+**Where it is used.** These definitions provide the reduction map $E(K) \to \tilde E(k)$ at a
+discrete valuation, in the form used in the modules of the tree that study torsion and its reduction
+for elliptic curves over local and global fields.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+namespace WeierstrassCurve
+
+open IsDiscreteValuationRing IsLocalRing IsDedekindDomain.HeightOneSpectrum
+
+variable (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+  {K : Type*} [Field K] [Algebra R K] [IsFractionRing R K]
+
+open Classical in
+def reduceCoord (x : K) : ResidueField R :=
+  if h : ∃ r : R, algebraMap R K r = x then residue R h.choose else 0
+
+open Classical in
+def reducePoint_alt (W : WeierstrassCurve K) [W.IsMinimal R] :
+    W.toAffine.Point → (W.reduction R).toAffine.Point
+  | .zero => .zero
+  | .some x y _ =>
+    if _ : valuation K (maximalIdeal R) x ≤ 1 ∧ valuation K (maximalIdeal R) y ≤ 1 then
+      if h' : (W.reduction R).toAffine.Nonsingular (reduceCoord R x) (reduceCoord R y)
+        then .some _ _ h'
+      else .zero
+    else .zero
+
+end WeierstrassCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_TateModule.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_TateModule.lean
new file mode 100644
index 0000000000..ce4e5ed70e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_TateModule.lean
@@ -0,0 +1,995 @@
+/-
+Based on Prove2Me node EllipticCurve_TateModule
+(e3517e0d-3db6-5cee-a949-fb0cba7e3bee) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.Padics.RingHoms
+public import Mathlib.RingTheory.AdicCompletion.RingHom
+public import Mathlib.LinearAlgebra.Dimension.Free
+public import Mathlib.LinearAlgebra.LinearIndependent.Lemmas
+public import Mathlib.FieldTheory.Finiteness
+public import Mathlib.Algebra.Module.ZMod
+public import Mathlib.Algebra.Field.ZMod
+public import Mathlib.GroupTheory.Coset.Card
+public import Mathlib.GroupTheory.QuotientGroup.Basic
+public import Mathlib.Algebra.Group.Subgroup.Finite
+public import LeanPool.FLTEichlerShimura.Definitions.Def_GaloisRep_Adic
+
+/-!
+# The p-adic Tate module and the Tate module Galois representation
+
+Definition: `EllipticCurve_TateModule` (`e3517e0d-3db6-5cee-a949-fb0cba7e3bee`), by Claude,
+2026-09-05.
+
+For a natural number $p$ and an additive commutative group $M$, [`TateModule p
+M`](../def/EllipticCurve_TateModule.html#L15) is defined as the additive subgroup of sequences $x :
+\mathbb{N} \to M$ satisfying, for every $n$, the two conditions $p^n \cdot x_n = 0$ and $p \cdot
+x_{n+1} = x_n$; thus it is the inverse limit $\varprojlim M[p^n]$ realised concretely as sequences
+(the condition at $n = 0$ forces $x_0 = 0$, so the zeroth term is always trivial). For $p$ prime it
+is given a $\mathbb{Z}_p$-module structure in which $a \in \mathbb{Z}_p$ acts at level $n$ through
+the integer `a.appr n` representing $a$ modulo $p^n$; `smul_apply_eq_smul` checks that when $M$ is
+already a $\mathbb{Z}_p$-module this agrees with the pointwise action. Further contents: the level
+maps `proj p M n : TateModule p M →+ M`, landing in `Submodule.torsionBy ℤ M ((p^n : ℕ) : ℤ)`, with
+`proj_eq_zero_iff` identifying the kernel of `proj … n` with $\mathfrak{m}^n \cdot \top$ for
+$\mathfrak{m}$ the maximal ideal of $\mathbb{Z}_p$; and `rep p M G : G →* Module.End ℤ_[p]
+(TateModule p M)`, the $\mathbb{Z}_p$-linear action induced termwise by any distributive action of a
+monoid $G$ on $M$.
+
+A later section takes as an explicit hypothesis the counting assumption that for every $n$ the
+subgroup `Submodule.torsionBy ℤ M ((p^n : ℕ) : ℤ)` has exactly $(p^n)^2$ elements, and deduces from
+it that multiplication by $p$ sends $M[p^{n+1}]$ onto $M[p^n]$, hence that each `proj … n` is
+surjective onto $M[p^n]$, and constructs from this an explicit basis indexed by `Fin 2`; `free`,
+`finite` and `finrank_eq_two` follow.
+
+For a Weierstrass curve $W$ over $\mathbb{Q}$, `torsionField W p n` is the subfield of
+$\overline{\mathbb{Q}}$ generated by the affine coordinates of the $p^n$-torsion
+$\overline{\mathbb{Q}}$-points; it is shown finite-dimensional when that torsion group is finite,
+and it witnesses the project's adic-continuity condition
+[`GaloisActionIsAdicContinuous`](../def/GaloisRep_Adic.html#L9) for `rep`. Under the same counting
+assumption, `tateModuleRepOfBasis` and `tateModuleRep` package the Tate module of the
+$\overline{\mathbb{Q}}$-points, with the coordinatewise
+$\mathrm{Gal}(\overline{\mathbb{Q}}/\mathbb{Q})$-action, as a [`GaloisRepAdic
+ℤ_[p]`](../def/GaloisRep_Adic.html#L16). Independently, [`GaloisRep.padicIntToRing 𝒪 p
+hp`](../def/EllipticCurve_TateModule.html#L266) is the ring homomorphism $\mathbb{Z}_p \to
+\mathcal{O}$ obtained, for a local ring $\mathcal{O}$ that is adically complete for its maximal
+ideal and has $p \in \mathfrak{m}_\mathcal{O}$, by lifting the compatible maps $\mathbb{Z}_p \to
+\mathbb{Z}/p^n \to \mathcal{O}/\mathfrak{m}^n$; it is characterised by that compatibility, is a
+local homomorphism, and is the identity for $\mathcal{O} = \mathbb{Z}_p$.
+
+**Relation to Mathlib.** Mathlib has no $p$-adic Tate module; the subgroup of $\mathbb{N}$-indexed
+compatible torsion sequences, its $\mathbb{Z}_p$-action via `PadicInt.appr`, and the induced
+representation `rep` are the project's own, built on Mathlib's `PadicInt`, `Submodule.torsionBy` and
+`WeierstrassCurve`. [`GaloisRep.padicIntToRing`](../def/EllipticCurve_TateModule.html#L266) is
+assembled from Mathlib's `IsAdicComplete.liftRingHom`. The freeness and rank-two results are stated
+relative to the explicit counting assumption on the orders of the torsion subgroups, which is not
+deduced from ellipticity here but must be supplied by the consumer.
+
+**Where it is used.** The representation
+[`WeierstrassCurve.tateModuleRep`](../def/EllipticCurve_TateModule.html#L851) is the Galois-side
+input to modularity lifting for the Frey curve: it supplies the two-dimensional $p$-adic
+representation whose residual representation is compared with the mod $p$ representation on $W[p]$,
+and whose ramification behaviour is the subject of separate statements.
+[`GaloisRep.padicIntToRing`](../def/EllipticCurve_TateModule.html#L266) is used to move its
+coefficients from $\mathbb{Z}_p$ to a general complete local coefficient ring.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open IsLocalRing
+
+def TateModule (p : ℕ) (M : Type) [AddCommGroup M] : AddSubgroup (ℕ → M) where
+  carrier := {x | ∀ n, ((p ^ n : ℕ) : ℤ) • x n = 0 ∧ ((p : ℕ) : ℤ) • x (n + 1) = x n}
+  add_mem' := fun {x y} hx hy n =>
+    ⟨by rw [Pi.add_apply, smul_add, (hx n).1, (hy n).1, add_zero],
+     by rw [Pi.add_apply, Pi.add_apply, smul_add, (hx n).2, (hy n).2]⟩
+  zero_mem' := fun n => ⟨smul_zero _, by rw [Pi.zero_apply, Pi.zero_apply, smul_zero]⟩
+  neg_mem' := fun {x} hx n =>
+    ⟨by rw [Pi.neg_apply, smul_neg, (hx n).1, neg_zero],
+     by rw [Pi.neg_apply, Pi.neg_apply, smul_neg, (hx n).2]⟩
+
+namespace TateModule
+
+variable {p : ℕ} {M : Type} [AddCommGroup M]
+
+theorem torsion (x : TateModule p M) (n : ℕ) : ((p ^ n : ℕ) : ℤ) • (x : ℕ → M) n = 0 := (x.2 n).1
+
+theorem compat (x : TateModule p M) (n : ℕ) : ((p : ℕ) : ℤ) • (x : ℕ → M) (n + 1) = (x : ℕ → M) n :=
+  (x.2 n).2
+
+theorem compat_pow (x : TateModule p M) (n k : ℕ) :
+    ((p ^ k : ℕ) : ℤ) • (x : ℕ → M) (n + k) = (x : ℕ → M) n := by
+  induction k with
+  | zero => rw [pow_zero, Nat.cast_one, one_smul, Nat.add_zero]
+  | succ k ih =>
+    rw [pow_succ, Nat.cast_mul, mul_smul]
+    change ((p ^ k : ℕ) : ℤ) • (((p : ℕ) : ℤ) • (x : ℕ → M) ((n + k) + 1)) = _
+    rw [compat, ih]
+
+@[simp] theorem coe_add (x y : TateModule p M) : ((x + y : TateModule p M) : ℕ → M) = x + y := rfl
+@[simp] theorem coe_zero : ((0 : TateModule p M) : ℕ → M) = 0 := rfl
+@[simp] theorem coe_neg (x : TateModule p M) : ((-x : TateModule p M) : ℕ → M) = -x := rfl
+@[simp] theorem coe_sub (x y : TateModule p M) : ((x - y : TateModule p M) : ℕ → M) = x - y := rfl
+
+theorem apply_zero (x : TateModule p M) : (x : ℕ → M) 0 = 0 := by
+  have h := torsion x 0
+  rwa [pow_zero, Nat.cast_one, one_smul] at h
+
+theorem natCast_smul_eq_mod {n c : ℕ} {m : M} (hm : ((p ^ n : ℕ) : ℤ) • m = 0) :
+    (c : ℤ) • m = ((c % p ^ n : ℕ) : ℤ) • m := by
+  conv_lhs => rw [← Nat.div_add_mod c (p ^ n)]
+  rw [Nat.cast_add, add_smul, Nat.cast_mul, mul_comm, mul_smul, hm, smul_zero, zero_add]
+
+theorem natCast_smul_eq_of_zmod_eq {n c d : ℕ} {m : M} (hm : ((p ^ n : ℕ) : ℤ) • m = 0)
+    (h : (c : ZMod (p ^ n)) = d) : (c : ℤ) • m = (d : ℤ) • m := by
+  rw [natCast_smul_eq_mod hm, natCast_smul_eq_mod (c := d) hm, (ZMod.natCast_eq_natCast_iff' c d
+    _).1 h]
+
+variable [Fact p.Prime]
+
+theorem toZModPow_eq_appr (n : ℕ) (a : ℤ_[p]) :
+    PadicInt.toZModPow n a = (a.appr n : ZMod (p ^ n)) := rfl
+
+theorem appr_succ_smul_eq (a : ℤ_[p]) (x : TateModule p M) (n : ℕ) :
+    ((a.appr (n + 1) : ℕ) : ℤ) • (x : ℕ → M) n = ((a.appr n : ℕ) : ℤ) • (x : ℕ → M) n := by
+  refine natCast_smul_eq_of_zmod_eq (torsion x n) ?_
+  rw [← toZModPow_eq_appr, ← PadicInt.zmod_cast_comp_toZModPow n (n + 1) n.le_succ,
+    RingHom.comp_apply,
+    toZModPow_eq_appr, ZMod.castHom_apply, ZMod.cast_natCast (pow_dvd_pow p n.le_succ)]
+
+noncomputable instance instSMul : SMul ℤ_[p] (TateModule p M) :=
+  ⟨fun a x => ⟨fun n => ((a.appr n : ℕ) : ℤ) • (x : ℕ → M) n, fun n =>
+    ⟨by rw [smul_comm, torsion, smul_zero], by rw [smul_comm, compat, appr_succ_smul_eq]⟩⟩⟩
+
+@[simp] theorem smul_apply (a : ℤ_[p]) (x : TateModule p M) (n : ℕ) :
+    ((a • x : TateModule p M) : ℕ → M) n = ((a.appr n : ℕ) : ℤ) • (x : ℕ → M) n := rfl
+
+noncomputable instance instModule : Module ℤ_[p] (TateModule p M) where
+  one_smul x := by
+    refine Subtype.ext (funext fun n => ?_)
+    rw [smul_apply]
+    have h : (((1 : ℤ_[p]).appr n : ℕ) : ZMod (p ^ n)) = ((1 : ℕ) : ZMod (p ^ n)) := by
+      rw [← toZModPow_eq_appr, map_one, Nat.cast_one]
+    rw [natCast_smul_eq_of_zmod_eq (torsion x n) h, Nat.cast_one, one_smul]
+  mul_smul a b x := by
+    refine Subtype.ext (funext fun n => ?_)
+    rw [smul_apply, smul_apply, smul_apply, smul_smul, ← Nat.cast_mul]
+    refine natCast_smul_eq_of_zmod_eq (torsion x n) ?_
+    rw [← toZModPow_eq_appr, map_mul, toZModPow_eq_appr, toZModPow_eq_appr, Nat.cast_mul]
+  smul_zero a := Subtype.ext (funext fun n => by rw [smul_apply, coe_zero, Pi.zero_apply,
+    smul_zero])
+  smul_add a x y := Subtype.ext (funext fun n => by
+    rw [smul_apply, coe_add, Pi.add_apply, smul_add, coe_add, Pi.add_apply, smul_apply, smul_apply])
+  add_smul a b x := by
+    refine Subtype.ext (funext fun n => ?_)
+    rw [smul_apply, coe_add, Pi.add_apply, smul_apply, smul_apply, ← add_smul, ← Nat.cast_add]
+    refine natCast_smul_eq_of_zmod_eq (torsion x n) ?_
+    rw [← toZModPow_eq_appr, map_add, toZModPow_eq_appr, toZModPow_eq_appr, Nat.cast_add]
+  zero_smul x := by
+    refine Subtype.ext (funext fun n => ?_)
+    rw [smul_apply, coe_zero, Pi.zero_apply]
+    have h : (((0 : ℤ_[p]).appr n : ℕ) : ZMod (p ^ n)) = ((0 : ℕ) : ZMod (p ^ n)) := by
+      rw [← toZModPow_eq_appr, map_zero, Nat.cast_zero]
+    rw [natCast_smul_eq_of_zmod_eq (torsion x n) h, Nat.cast_zero, zero_smul]
+
+theorem natCast_padicInt_smul_apply (c : ℕ) (x : TateModule p M) (n : ℕ) :
+    (((c : ℤ_[p]) • x : TateModule p M) : ℕ → M) n = (c : ℤ) • (x : ℕ → M) n := by
+  rw [smul_apply]
+  refine natCast_smul_eq_of_zmod_eq (torsion x n) ?_
+  rw [← toZModPow_eq_appr, map_natCast]
+
+theorem smul_apply_eq_zero_of_mem_span {n : ℕ} {a : ℤ_[p]}
+    (ha : a ∈ Ideal.span {(p : ℤ_[p]) ^ n}) (x : TateModule p M) :
+    ((a • x : TateModule p M) : ℕ → M) n = 0 := by
+  rw [smul_apply]
+  have h : ((a.appr n : ℕ) : ZMod (p ^ n)) = ((0 : ℕ) : ZMod (p ^ n)) := by
+    rw [← toZModPow_eq_appr, Nat.cast_zero, ← RingHom.mem_ker, PadicInt.ker_toZModPow]
+    exact ha
+  rw [natCast_smul_eq_of_zmod_eq (torsion x n) h, Nat.cast_zero, zero_smul]
+
+variable (p M) in
+def proj (n : ℕ) : TateModule p M →+ M where
+  toFun x := (x : ℕ → M) n
+  map_zero' := rfl
+  map_add' _ _ := rfl
+
+omit [Fact p.Prime] in
+@[simp] theorem proj_apply (n : ℕ) (x : TateModule p M) : proj p M n x = (x : ℕ → M) n := rfl
+
+omit [Fact p.Prime] in
+theorem torsionBy_proj (n : ℕ) (x : TateModule p M) : ((p ^ n : ℕ) : ℤ) • proj p M n x = 0 :=
+  torsion x n
+
+omit [Fact p.Prime] in
+theorem proj_mem_torsionBy (n : ℕ) (x : TateModule p M) :
+    proj p M n x ∈ Submodule.torsionBy ℤ M ((p ^ n : ℕ) : ℤ) :=
+  (Submodule.mem_torsionBy_iff _ _).2 (torsion x n)
+
+def shiftOfProjEqZero (n : ℕ) (x : TateModule p M) (hx : proj p M n x = 0) : TateModule p M :=
+  ⟨fun m => (x : ℕ → M) (m + n), fun m =>
+    ⟨by
+      change ((p ^ m : ℕ) : ℤ) • (x : ℕ → M) (m + n) = 0
+      rw [Nat.add_comm, compat_pow x n m]; exact hx,
+     by
+      change ((p : ℕ) : ℤ) • (x : ℕ → M) (m + 1 + n) = (x : ℕ → M) (m + n)
+      rw [Nat.add_right_comm]; exact compat x (m + n)⟩⟩
+
+theorem pow_smul_shiftOfProjEqZero (n : ℕ) (x : TateModule p M) (hx : proj p M n x = 0) :
+    ((p : ℤ_[p]) ^ n) • shiftOfProjEqZero n x hx = x := by
+  refine Subtype.ext (funext fun m => ?_)
+  rw [← Nat.cast_pow, natCast_padicInt_smul_apply]
+  exact compat_pow x m n
+
+theorem proj_eq_zero_iff (n : ℕ) (x : TateModule p M) :
+    proj p M n x = 0 ↔ x ∈ (maximalIdeal ℤ_[p] ^ n) • (⊤ : Submodule ℤ_[p] (TateModule p M)) := by
+  constructor
+  · intro hx
+    rw [← pow_smul_shiftOfProjEqZero n x hx]
+    refine Submodule.smul_mem_smul ?_ Submodule.mem_top
+    rw [PadicInt.maximalIdeal_eq_span_p, Ideal.span_singleton_pow]
+    exact Ideal.mem_span_singleton_self _
+  · intro hx
+    rw [PadicInt.maximalIdeal_eq_span_p, Ideal.span_singleton_pow] at hx
+    refine Submodule.smul_induction_on hx (fun a ha y _ => ?_) (fun y z hy hz => ?_)
+    · exact smul_apply_eq_zero_of_mem_span ha y
+    · rw [map_add, hy, hz, add_zero]
+
+section action
+
+variable {G : Type} [Monoid G] [DistribMulAction G M]
+
+variable (p M G) in
+noncomputable def rep : G →* Module.End ℤ_[p] (TateModule p M) where
+  toFun g :=
+    { toFun := fun x => ⟨fun n => g • (x : ℕ → M) n, fun n =>
+        ⟨by
+          change ((p ^ n : ℕ) : ℤ) • DistribSMul.toAddMonoidHom M g ((x : ℕ → M) n) = 0
+          rw [← map_zsmul, torsion, map_zero],
+         by
+          change ((p : ℕ) : ℤ) • DistribSMul.toAddMonoidHom M g ((x : ℕ → M) (n + 1)) = _
+          rw [← map_zsmul, compat]; rfl⟩⟩
+      map_add' := fun x y => Subtype.ext (funext fun n => by
+        change g • ((x + y : TateModule p M) : ℕ → M) n = g • (x : ℕ → M) n + g • (y : ℕ → M) n
+        rw [coe_add, Pi.add_apply, smul_add])
+      map_smul' := fun a x => Subtype.ext (funext fun n => by
+        change g • (((a.appr n : ℕ) : ℤ) • (x : ℕ → M) n) = ((a.appr n : ℕ) : ℤ) • (g • (x : ℕ → M)
+          n)
+        exact map_zsmul (DistribSMul.toAddMonoidHom M g) _ _) }
+  map_one' := LinearMap.ext fun x => Subtype.ext (funext fun n => one_smul G ((x : ℕ → M) n))
+  map_mul' g h := LinearMap.ext fun x => Subtype.ext (funext fun n => mul_smul g h ((x : ℕ → M) n))
+
+@[simp] theorem rep_apply (g : G) (x : TateModule p M) (n : ℕ) :
+    ((rep p M G g x : TateModule p M) : ℕ → M) n = g • (x : ℕ → M) n := rfl
+
+theorem rep_sub_mem_of_apply_eq (g : G) (x : TateModule p M) (n : ℕ)
+    (h : g • (x : ℕ → M) n = (x : ℕ → M) n) :
+    rep p M G g x - x ∈ (maximalIdeal ℤ_[p] ^ n) • (⊤ : Submodule ℤ_[p] (TateModule p M)) := by
+  rw [← proj_eq_zero_iff, map_sub, sub_eq_zero]
+  exact h
+
+end action
+
+theorem smul_apply_eq_smul [Module ℤ_[p] M] (a : ℤ_[p]) (x : TateModule p M) (n : ℕ) :
+    ((a • x : TateModule p M) : ℕ → M) n = a • (x : ℕ → M) n := by
+  obtain ⟨c, hc⟩ := Ideal.mem_span_singleton'.1 (PadicInt.appr_spec n a)
+  have ha : a = ((a.appr n : ℕ) : ℤ_[p]) + c * (p ^ n : ℕ) := by
+    rw [Nat.cast_pow, hc, add_sub_cancel]
+  have hkill : ((p ^ n : ℕ) : ℤ_[p]) • (x : ℕ → M) n = 0 := by
+    rw [Nat.cast_smul_eq_nsmul, ← natCast_zsmul]
+    exact torsion x n
+  conv_rhs => rw [ha]
+  rw [add_smul, mul_smul, hkill, smul_zero, add_zero, Nat.cast_smul_eq_nsmul, smul_apply,
+    natCast_zsmul]
+
+section InstanceRegression
+
+noncomputable example [Module ℤ_[p] M] : SMul ℤ_[p] (TateModule p M) := inferInstance
+
+example [Module ℤ_[p] M] : (inferInstance : SMul ℤ_[p] (TateModule p M)) = instSMul := by
+  with_reducible_and_instances rfl
+
+example [Module ℤ_[p] M] : (inferInstance : Module ℤ_[p] (TateModule p M)) = instModule := by
+  with_reducible_and_instances rfl
+
+example [Module ℤ_[p] M] :
+    (inferInstance : DistribMulAction ℤ_[p] (TateModule p M)).toMulAction.toSMul = instSMul := by
+  with_reducible_and_instances rfl
+
+example {G : Type} [Monoid G] [DistribMulAction G M] : True := by
+  fail_if_success (have _i : SMul G (TateModule p M) := inferInstance)
+  trivial
+
+example [Module ℤ_[p] M] : True := by
+  fail_if_success (fail_if_success (have _i : SMul ℤ_[p] (TateModule p M) := inferInstance))
+  trivial
+
+end InstanceRegression
+
+end TateModule
+
+namespace GaloisRep
+
+variable (𝒪 : Type) [CommRing 𝒪] [IsLocalRing 𝒪] (p : ℕ) [Fact p.Prime]
+
+omit [Fact p.Prime] in
+theorem ringChar_quotient_dvd (hp : (p : 𝒪) ∈ maximalIdeal 𝒪) (n : ℕ) :
+    ringChar (𝒪 ⧸ maximalIdeal 𝒪 ^ n) ∣ p ^ n := by
+  rw [← ringChar.spec, Nat.cast_pow, ← map_natCast (Ideal.Quotient.mk (maximalIdeal 𝒪 ^ n)), ←
+    map_pow,
+    Ideal.Quotient.eq_zero_iff_mem]
+  exact Ideal.pow_mem_pow hp n
+
+noncomputable def padicIntToRingLevel (hp : (p : 𝒪) ∈ maximalIdeal 𝒪) (n : ℕ) :
+    ℤ_[p] →+* 𝒪 ⧸ maximalIdeal 𝒪 ^ n :=
+  (ZMod.castHom (ringChar_quotient_dvd 𝒪 p hp n) (𝒪 ⧸ maximalIdeal 𝒪 ^ n)).comp (PadicInt.toZModPow
+    n)
+
+theorem padicIntToRingLevel_compat (hp : (p : 𝒪) ∈ maximalIdeal 𝒪) {m n : ℕ} (hle : m ≤ n) :
+    (Ideal.Quotient.factorPow (maximalIdeal 𝒪) hle).comp (padicIntToRingLevel 𝒪 p hp n) =
+      padicIntToRingLevel 𝒪 p hp m := by
+  rw [padicIntToRingLevel, padicIntToRingLevel, ← PadicInt.zmod_cast_comp_toZModPow m n hle,
+    ← RingHom.comp_assoc, ← RingHom.comp_assoc]
+  congr 1
+  exact Subsingleton.elim _ _
+
+variable [IsAdicComplete (maximalIdeal 𝒪) 𝒪]
+
+noncomputable def padicIntToRing (hp : (p : 𝒪) ∈ maximalIdeal 𝒪) : ℤ_[p] →+* 𝒪 :=
+  IsAdicComplete.liftRingHom (maximalIdeal 𝒪) (padicIntToRingLevel 𝒪 p hp)
+    (fun hle => padicIntToRingLevel_compat 𝒪 p hp hle)
+
+theorem isLocalHom_padicIntToRing (hp : (p : 𝒪) ∈ maximalIdeal 𝒪) :
+    IsLocalHom (padicIntToRing 𝒪 p hp) := by
+  refine ⟨fun a ha => ?_⟩
+  by_contra hna
+  have hmem : a ∈ maximalIdeal ℤ_[p] := hna
+  rw [PadicInt.maximalIdeal_eq_span_p, Ideal.mem_span_singleton] at hmem
+  obtain ⟨b, rfl⟩ := hmem
+  rw [map_mul, map_natCast] at ha
+  exact (IsLocalRing.mem_maximalIdeal _).1 (Ideal.mul_mem_right _ _ hp) ha
+
+end GaloisRep
+
+namespace TateModule
+
+open Submodule
+
+variable {p : ℕ} {M : Type} [AddCommGroup M]
+
+theorem mem_torsionBy_add {n : ℕ} {m : M} (hm : m ∈ torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) (k : ℕ) :
+    m ∈ torsionBy ℤ M ((p ^ (n + k) : ℕ) : ℤ) := by
+  rw [mem_torsionBy_iff] at hm ⊢
+  rw [pow_add, Nat.cast_mul, mul_comm, mul_smul, hm, smul_zero]
+
+theorem smul_mem_torsionBy_of_mem_succ {n : ℕ} {m : M}
+    (hm : m ∈ torsionBy ℤ M ((p ^ (n + 1) : ℕ) : ℤ)) :
+    ((p : ℕ) : ℤ) • m ∈ torsionBy ℤ M ((p ^ n : ℕ) : ℤ) := by
+  rw [mem_torsionBy_iff] at hm ⊢
+  rw [smul_smul, ← Nat.cast_mul, ← pow_succ, hm]
+
+theorem pow_smul_mem_torsionBy {n k : ℕ} {m : M} (hk : k ≤ n)
+    (hm : m ∈ torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) :
+    ((p ^ (n - k) : ℕ) : ℤ) • m ∈ torsionBy ℤ M ((p ^ k : ℕ) : ℤ) := by
+  rw [mem_torsionBy_iff] at hm ⊢
+  rw [smul_smul, ← Nat.cast_mul, ← pow_add, Nat.add_sub_cancel' hk, hm]
+
+theorem mem_torsionBy_one_of_smul_eq_zero {m : M} (hm : ((p : ℕ) : ℤ) • m = 0) :
+    m ∈ torsionBy ℤ M ((p ^ 1 : ℕ) : ℤ) := by
+  rw [mem_torsionBy_iff, pow_one]; exact hm
+
+theorem smul_eq_zero_of_mem_torsionBy_one {m : M} (hm : m ∈ torsionBy ℤ M ((p ^ 1 : ℕ) : ℤ)) :
+    ((p : ℕ) : ℤ) • m = 0 := by
+  rw [mem_torsionBy_iff, pow_one] at hm; exact hm
+
+section Counting
+
+variable [Fact p.Prime]
+
+theorem finite_torsionBy (hcard : ∀ n : ℕ, Nat.card (torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2)
+    (n : ℕ) :
+    Finite (torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) :=
+  Nat.finite_of_card_ne_zero (by
+    rw [hcard n]; exact pow_ne_zero _ (pow_ne_zero _ (Fact.out : p.Prime).ne_zero))
+
+variable (p M) in
+def mulP (n : ℕ) : torsionBy ℤ M ((p ^ (n + 1) : ℕ) : ℤ) →+ torsionBy ℤ M ((p ^ n : ℕ) : ℤ) where
+  toFun m := ⟨((p : ℕ) : ℤ) • (m : M), smul_mem_torsionBy_of_mem_succ m.2⟩
+  map_zero' := Subtype.ext (smul_zero _)
+  map_add' _ _ := Subtype.ext (smul_add _ _ _)
+
+omit [Fact p.Prime] in
+@[simp] theorem coe_mulP (n : ℕ) (m : torsionBy ℤ M ((p ^ (n + 1) : ℕ) : ℤ)) :
+    (mulP p M n m : M) = ((p : ℕ) : ℤ) • (m : M) := rfl
+
+variable (p M) in
+def kerMulPEquiv (n : ℕ) : (mulP p M n).ker ≃ torsionBy ℤ M ((p ^ 1 : ℕ) : ℤ) where
+  toFun m := ⟨(m.1 : M), mem_torsionBy_one_of_smul_eq_zero (by
+    have h := m.2; rw [AddMonoidHom.mem_ker] at h; exact congrArg Subtype.val h)⟩
+  invFun m := ⟨⟨(m : M), by
+      rw [mem_torsionBy_iff, pow_succ, Nat.cast_mul, mul_smul, smul_eq_zero_of_mem_torsionBy_one
+        m.2,
+        smul_zero]⟩,
+    by rw [AddMonoidHom.mem_ker]; exact Subtype.ext (smul_eq_zero_of_mem_torsionBy_one m.2)⟩
+  left_inv m := rfl
+  right_inv m := rfl
+
+theorem mulP_surjective (hcard : ∀ n : ℕ, Nat.card (torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2)
+    (n : ℕ) :
+    Function.Surjective (mulP p M n) := by
+  have := finite_torsionBy hcard (n + 1)
+  have := finite_torsionBy hcard n
+  have hker : Nat.card (mulP p M n).ker = p ^ 2 := by
+    rw [Nat.card_congr (kerMulPEquiv p M n), hcard 1, pow_one]
+  have h := AddSubgroup.card_eq_card_quotient_mul_card_addSubgroup (mulP p M n).ker
+  rw [hcard (n + 1), Nat.card_congr (QuotientAddGroup.quotientKerEquivRange (mulP p M n)).toEquiv,
+    hker] at h
+  have hrange : Nat.card (mulP p M n).range = Nat.card (torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) := by
+    rw [hcard n]
+    refine Nat.eq_of_mul_eq_mul_right (pow_pos (Fact.out : p.Prime).pos 2) ?_
+    rw [← h]; ring
+  rw [← AddMonoidHom.range_eq_top]
+  exact AddSubgroup.eq_top_of_card_eq _ hrange
+
+theorem exists_smul_eq_of_mem_torsionBy
+    (hcard : ∀ n : ℕ, Nat.card (torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2) {n : ℕ} {m : M}
+    (hm : m ∈ torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) :
+    ∃ m' ∈ torsionBy ℤ M ((p ^ (n + 1) : ℕ) : ℤ), ((p : ℕ) : ℤ) • m' = m := by
+  obtain ⟨m', hm'⟩ := mulP_surjective hcard n ⟨m, hm⟩
+  exact ⟨m', m'.2, congrArg Subtype.val hm'⟩
+
+noncomputable def liftAux
+    (next : (k : ℕ) → torsionBy ℤ M ((p ^ k : ℕ) : ℤ) → torsionBy ℤ M ((p ^ (k + 1) : ℕ) : ℤ))
+    (n : ℕ) (m : torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) : (j : ℕ) → torsionBy ℤ M ((p ^ (n + j) : ℕ) : ℤ)
+  | 0 => m
+  | j + 1 => next (n + j) (liftAux next n m j)
+
+noncomputable def liftFun
+    (next : (k : ℕ) → torsionBy ℤ M ((p ^ k : ℕ) : ℤ) → torsionBy ℤ M ((p ^ (k + 1) : ℕ) : ℤ))
+    (n : ℕ) (m : torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) (k : ℕ) : M :=
+  if n ≤ k then (liftAux next n m (k - n) : M) else ((p ^ (n - k) : ℕ) : ℤ) • (m : M)
+
+omit [Fact p.Prime] in
+theorem liftFun_of_le {next} {n : ℕ} {m : torsionBy ℤ M ((p ^ n : ℕ) : ℤ)} {k : ℕ} (hk : n ≤ k) :
+    liftFun next n m k = (liftAux next n m (k - n) : M) := ite_eq_left hk
+
+omit [Fact p.Prime] in
+theorem liftFun_of_lt {next} {n : ℕ} {m : torsionBy ℤ M ((p ^ n : ℕ) : ℤ)} {k : ℕ} (hk : k < n) :
+    liftFun next n m k = ((p ^ (n - k) : ℕ) : ℤ) • (m : M) := ite_eq_right (not_le.mpr hk)
+
+omit [Fact p.Prime] in
+theorem coe_liftAux_congr {next} {n : ℕ} {m : torsionBy ℤ M ((p ^ n : ℕ) : ℤ)} {j j' : ℕ}
+    (h : j = j') :
+    (liftAux next n m j : M) = (liftAux next n m j' : M) := by subst h; rfl
+
+omit [Fact p.Prime] in
+theorem pow_smul_coe_liftAux {next} {n : ℕ} {m : torsionBy ℤ M ((p ^ n : ℕ) : ℤ)} (j : ℕ) {e : ℕ}
+    (he : e = n + j) : ((p ^ e : ℕ) : ℤ) • (liftAux next n m j : M) = 0 := by
+  subst he; exact (mem_torsionBy_iff _ _).mp (liftAux next n m j).2
+
+omit [Fact p.Prime] in
+theorem liftFun_mem
+    {next : (k : ℕ) → torsionBy ℤ M ((p ^ k : ℕ) : ℤ) → torsionBy ℤ M ((p ^ (k + 1) : ℕ) : ℤ)}
+    (hnext : ∀ k (m : torsionBy ℤ M ((p ^ k : ℕ) : ℤ)), ((p : ℕ) : ℤ) • (next k m : M) = m)
+    (n : ℕ) (m : torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) : liftFun next n m ∈ TateModule p M := by
+  intro k
+  constructor
+  · by_cases hk : n ≤ k
+    · rw [liftFun_of_le hk]
+      exact pow_smul_coe_liftAux (k - n) (by omega)
+    · rw [liftFun_of_lt (not_le.mp hk)]
+      exact (mem_torsionBy_iff _ _).mp (pow_smul_mem_torsionBy (not_le.mp hk).le m.2)
+  · by_cases hk : n ≤ k
+    · rw [liftFun_of_le hk, liftFun_of_le (by omega : n ≤ k + 1),
+        coe_liftAux_congr (by omega : k + 1 - n = (k - n) + 1)]
+      exact hnext _ _
+    · by_cases hk' : n ≤ k + 1
+      · have hn : n = k + 1 := by omega
+        subst hn
+        rw [liftFun_of_le le_rfl, liftFun_of_lt (by
+          omega : k < k + 1), coe_liftAux_congr (Nat.sub_self _),
+          Nat.add_sub_cancel_left, pow_one]
+        rfl
+      · rw [liftFun_of_lt (not_le.mp hk'), liftFun_of_lt (not_le.mp hk), smul_smul, ← Nat.cast_mul,
+          ← pow_succ', show n - (k + 1) + 1 = n - k by omega]
+
+theorem proj_surjective (hcard : ∀ n : ℕ, Nat.card (torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2)
+    (n : ℕ) :
+    ∀ m ∈ torsionBy ℤ M ((p ^ n : ℕ) : ℤ), ∃ x : TateModule p M, proj p M n x = m := by
+  intro m hm
+  choose next hnext using fun k (m : torsionBy ℤ M ((p ^ k : ℕ) : ℤ)) => mulP_surjective hcard k m
+  refine ⟨⟨liftFun next n ⟨m, hm⟩, liftFun_mem (fun k m => congrArg Subtype.val (hnext k m)) n ⟨m,
+    hm⟩⟩, ?_⟩
+  rw [proj_apply]
+  change liftFun next n ⟨m, hm⟩ n = m
+  rw [liftFun_of_le le_rfl, coe_liftAux_congr (Nat.sub_self n)]
+  rfl
+
+theorem range_proj (hcard : ∀ n : ℕ, Nat.card (torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2)
+    (n : ℕ) :
+    Set.range (proj p M n) = torsionBy ℤ M ((p ^ n : ℕ) : ℤ) := by
+  ext m
+  exact ⟨fun ⟨x, hx⟩ => hx ▸ proj_mem_torsionBy n x, fun hm => proj_surjective hcard n m hm⟩
+
+end Counting
+
+section Free
+
+variable [Fact p.Prime]
+
+theorem exists_pair_of_card_eq_sq {V : Type} [AddCommGroup V] [Module (ZMod p) V] [Finite V]
+    (hV : Nat.card V = p ^ 2) :
+    ∃ v w : V, ∀ a b : ℤ, a • v + b • w = 0 → (p : ℤ) ∣ a ∧ (p : ℤ) ∣ b := by
+  have hp : p.Prime := Fact.out
+  have hrank : Module.finrank (ZMod p) V = 2 := by
+    have h := Module.natCard_eq_pow_finrank (K := ZMod p) (V := V)
+    rw [hV, Nat.card_zmod] at h
+    exact (Nat.pow_right_injective hp.two_le h).symm
+  let b := Module.finBasisOfFinrankEq (ZMod p) V hrank
+  refine ⟨b 0, b 1, fun a c h => ?_⟩
+  rw [← Int.cast_smul_eq_zsmul (ZMod p) a, ← Int.cast_smul_eq_zsmul (ZMod p) c] at h
+  have hli := (Fintype.linearIndependent_iff.mp b.linearIndependent) ![(a : ZMod p), (c : ZMod p)]
+    (by rw [Fin.sum_univ_two]; exact h)
+  exact ⟨(ZMod.intCast_zmod_eq_zero_iff_dvd a p).mp (hli 0), (ZMod.intCast_zmod_eq_zero_iff_dvd c
+    p).mp (hli 1)⟩
+
+theorem exists_indep_pair_torsionBy_one
+    (hcard : ∀ n : ℕ, Nat.card (torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2) :
+    ∃ e₁ ∈ torsionBy ℤ M ((p ^ 1 : ℕ) : ℤ), ∃ e₂ ∈ torsionBy ℤ M ((p ^ 1 : ℕ) : ℤ),
+      ∀ a b : ℤ, a • e₁ + b • e₂ = 0 → (p : ℤ) ∣ a ∧ (p : ℤ) ∣ b := by
+  have := finite_torsionBy hcard 1
+  have hmod : ∀ m : torsionBy ℤ M ((p ^ 1 : ℕ) : ℤ), p • m = 0 := fun m =>
+    Subtype.ext (by
+      rw [coe_smul_of_tower, ← Nat.cast_smul_eq_nsmul ℤ, Submodule.coe_zero]
+      exact smul_eq_zero_of_mem_torsionBy_one m.2)
+  let : Module (ZMod p) (torsionBy ℤ M ((p ^ 1 : ℕ) : ℤ)) := AddCommGroup.zmodModule hmod
+  have h1 : Nat.card (torsionBy ℤ M ((p ^ 1 : ℕ) : ℤ)) = p ^ 2 := by rw [hcard 1, pow_one]
+  obtain ⟨v, w, h⟩ := exists_pair_of_card_eq_sq (p := p) h1
+  refine ⟨v, v.2, w, w.2, fun a b hab => h a b (Subtype.ext ?_)⟩
+  rw [Submodule.coe_add, coe_smul_of_tower, coe_smul_of_tower, Submodule.coe_zero]
+  exact hab
+
+omit [Fact p.Prime] in
+theorem dvd_of_rel_apply {x y : TateModule p M}
+    (h1 : ∀ a b : ℤ, a • (x : ℕ → M) 1 + b • (y : ℕ → M) 1 = 0 → (p : ℤ) ∣ a ∧ (p : ℤ) ∣ b) :
+    ∀ (n : ℕ) (a b : ℤ), a • (x : ℕ → M) n + b • (y : ℕ → M) n = 0 →
+      ((p ^ n : ℕ) : ℤ) ∣ a ∧ ((p ^ n : ℕ) : ℤ) ∣ b := by
+  intro n
+  induction n with
+  | zero => intro a b _; simp
+  | succ n ih =>
+    intro a b hab
+    have hab1 : a • (x : ℕ → M) 1 + b • (y : ℕ → M) 1 = 0 := by
+      have := congrArg (((p ^ n : ℕ) : ℤ) • ·) hab
+      simpa only [smul_add, smul_zero, smul_comm _ a, smul_comm _ b, Nat.add_comm n 1 ▸ compat_pow x
+        1 n,
+        Nat.add_comm n 1 ▸ compat_pow y 1 n] using this
+    obtain ⟨⟨a', rfl⟩, ⟨b', rfl⟩⟩ := h1 a b hab1
+    have hab' : a' • (x : ℕ → M) n + b' • (y : ℕ → M) n = 0 := by
+      rw [mul_comm, mul_smul, mul_comm, mul_smul, compat, compat] at hab
+      exact hab
+    obtain ⟨ha, hb⟩ := ih a' b' hab'
+    rw [pow_succ', Nat.cast_mul]
+    exact ⟨mul_dvd_mul_left _ ha, mul_dvd_mul_left _ hb⟩
+
+noncomputable def levelMap (x y : TateModule p M) (n : ℕ) (c : ZMod (p ^ n) × ZMod (p ^ n)) :
+    torsionBy ℤ M ((p ^ n : ℕ) : ℤ) :=
+  ⟨(c.1.val : ℤ) • (x : ℕ → M) n + (c.2.val : ℤ) • (y : ℕ → M) n, by
+    rw [mem_torsionBy_iff, smul_add, smul_comm _ (c.1.val : ℤ), torsion, smul_comm _ (c.2.val : ℤ),
+      torsion,
+      smul_zero, smul_zero, add_zero]⟩
+
+theorem levelMap_injective {x y : TateModule p M}
+    (h1 : ∀ a b : ℤ, a • (x : ℕ → M) 1 + b • (y : ℕ → M) 1 = 0 → (p : ℤ) ∣ a ∧ (p : ℤ) ∣ b) (n : ℕ)
+    :
+    Function.Injective (levelMap x y n) := by
+  have : NeZero (p ^ n) := ⟨pow_ne_zero _ (Fact.out : p.Prime).ne_zero⟩
+  rintro ⟨a, b⟩ ⟨a', b'⟩ h
+  have h' : ((a.val : ℤ) - a'.val) • (x : ℕ → M) n + ((b.val : ℤ) - b'.val) • (y : ℕ → M) n = 0 :=
+    by
+    have := sub_eq_zero.mpr (congrArg Subtype.val h)
+    simp only [levelMap] at this
+    rw [← this, sub_smul, sub_smul]
+    abel
+  obtain ⟨ha, hb⟩ := dvd_of_rel_apply h1 n _ _ h'
+  have key : ∀ {u v : ZMod (p ^ n)}, ((p ^ n : ℕ) : ℤ) ∣ (u.val : ℤ) - v.val → u = v :=
+    fun {u v} huv => by
+    have := (ZMod.intCast_eq_intCast_iff_dvd_sub (v.val : ℤ) (u.val : ℤ) (p ^ n)).mpr huv
+    rwa [Int.cast_natCast, Int.cast_natCast, ZMod.natCast_zmod_val, ZMod.natCast_zmod_val,
+      eq_comm] at this
+  exact Prod.ext (key ha) (key hb)
+
+theorem levelMap_bijective (hcard : ∀ n : ℕ, Nat.card (torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^
+  2)
+    {x y : TateModule p M}
+    (h1 : ∀ a b : ℤ, a • (x : ℕ → M) 1 + b • (y : ℕ → M) 1 = 0 → (p : ℤ) ∣ a ∧ (p : ℤ) ∣ b) (n : ℕ)
+    :
+    Function.Bijective (levelMap x y n) := by
+  have := finite_torsionBy hcard n
+  refine (levelMap_injective h1 n).bijective_of_nat_card_le ?_
+  rw [hcard n, Nat.card_prod, Nat.card_zmod, sq]
+
+theorem exists_eq_levelMap (hcard : ∀ n : ℕ, Nat.card (torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^
+  2)
+    {x y : TateModule p M}
+    (h1 : ∀ a b : ℤ, a • (x : ℕ → M) 1 + b • (y : ℕ → M) 1 = 0 → (p : ℤ) ∣ a ∧ (p : ℤ) ∣ b) (n : ℕ)
+    {m : M} (hm : m ∈ torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) :
+    ∃ a b : ℕ, (a : ℤ) • (x : ℕ → M) n + (b : ℤ) • (y : ℕ → M) n = m := by
+  obtain ⟨⟨a, b⟩, h⟩ := (levelMap_bijective hcard h1 n).2 ⟨m, hm⟩
+  exact ⟨a.val, b.val, congrArg Subtype.val h⟩
+
+theorem linearIndependent_pair {x y : TateModule p M}
+    (h1 : ∀ a b : ℤ, a • (x : ℕ → M) 1 + b • (y : ℕ → M) 1 = 0 → (p : ℤ) ∣ a ∧ (p : ℤ) ∣ b) :
+    LinearIndependent ℤ_[p] ![x, y] := by
+  rw [LinearIndependent.pair_iff]
+  intro s t hst
+  have hlev : ∀ n, ((p ^ n : ℕ) : ℤ) ∣ (s.appr n : ℤ) ∧ ((p ^ n : ℕ) : ℤ) ∣ (t.appr n : ℤ) :=
+    fun n =>
+    dvd_of_rel_apply h1 n _ _ (by
+      have := congrArg (fun z : TateModule p M => (z : ℕ → M) n) hst
+      simpa only [coe_add, Pi.add_apply, smul_apply, coe_zero, Pi.zero_apply] using this)
+  have key : ∀ {u : ℤ_[p]}, (∀ n, ((p ^ n : ℕ) : ℤ) ∣ (u.appr n : ℤ)) → u = 0 := fun {u} hu =>
+    PadicInt.ext_of_toZModPow.mp fun n => by
+      rw [map_zero, toZModPow_eq_appr, ZMod.natCast_eq_zero_iff]
+      exact Int.natCast_dvd_natCast.mp (hu n)
+  exact ⟨key fun n => (hlev n).1, key fun n => (hlev n).2⟩
+
+theorem mem_span_pair (hcard : ∀ n : ℕ, Nat.card (torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2)
+    {x y : TateModule p M}
+    (h1 : ∀ a b : ℤ, a • (x : ℕ → M) 1 + b • (y : ℕ → M) 1 = 0 → (p : ℤ) ∣ a ∧ (p : ℤ) ∣ b)
+    (z : TateModule p M) : ∃ s t : ℤ_[p], s • x + t • y = z := by
+  choose a b hab using fun n => exists_eq_levelMap hcard h1 n (proj_mem_torsionBy n z)
+  have hcompat : ∀ n, ((p ^ n : ℕ) : ℤ) ∣ (a (n + 1) : ℤ) - a n ∧ ((p ^ n : ℕ) : ℤ) ∣ (b (n + 1) :
+    ℤ) - b n :=
+    fun n => dvd_of_rel_apply h1 n _ _ (by
+      rw [sub_smul, sub_smul, sub_add_sub_comm, hab n, sub_eq_zero, proj_apply, ← compat z n,
+        ← proj_apply (n + 1) z, ← hab (n + 1), smul_add, smul_comm _ (a (n + 1) : ℤ),
+        smul_comm _ (b (n + 1) : ℤ), compat, compat])
+  have hca : ∀ i, (p : ℤ) ^ i ∣ (fun i => (a i : ℤ)) (i + 1) - (fun i => (a i : ℤ)) i := fun i => by
+    rw [← Nat.cast_pow]; exact (hcompat i).1
+  have hcb : ∀ i, (p : ℤ) ^ i ∣ (fun i => (b i : ℤ)) (i + 1) - (fun i => (b i : ℤ)) i := fun i => by
+    rw [← Nat.cast_pow]; exact (hcompat i).2
+  refine ⟨PadicInt.ofIntSeq (fun i => (a i : ℤ)) (PadicInt.isCauSeq_padicNorm_of_pow_dvd_sub _ p
+    hca),
+    PadicInt.ofIntSeq (fun i => (b i : ℤ)) (PadicInt.isCauSeq_padicNorm_of_pow_dvd_sub _ p hcb),
+    Subtype.ext (funext fun n => ?_)⟩
+  rw [coe_add, Pi.add_apply, smul_apply, smul_apply, ← proj_apply n z, ← hab n]
+  congr 1
+  · refine natCast_smul_eq_of_zmod_eq (torsion x n) ?_
+    rw [← toZModPow_eq_appr, PadicInt.toZModPow_ofIntSeq_of_pow_dvd_sub (fun i => (a i : ℤ)) p hca
+      n,
+      Int.cast_natCast]
+  · refine natCast_smul_eq_of_zmod_eq (torsion y n) ?_
+    rw [← toZModPow_eq_appr, PadicInt.toZModPow_ofIntSeq_of_pow_dvd_sub (fun i => (b i : ℤ)) p hcb
+      n,
+      Int.cast_natCast]
+
+theorem exists_pair (hcard : ∀ n : ℕ, Nat.card (torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2) :
+    ∃ x y : TateModule p M,
+      ∀ a b : ℤ, a • (x : ℕ → M) 1 + b • (y : ℕ → M) 1 = 0 → (p : ℤ) ∣ a ∧ (p : ℤ) ∣ b := by
+  obtain ⟨e₁, he₁, e₂, he₂, h1⟩ := exists_indep_pair_torsionBy_one hcard
+  obtain ⟨x, hx⟩ := proj_surjective hcard 1 e₁ he₁
+  obtain ⟨y, hy⟩ := proj_surjective hcard 1 e₂ he₂
+  rw [proj_apply] at hx hy
+  exact ⟨x, y, by rw [hx, hy]; exact h1⟩
+
+theorem top_le_span_pair (hcard : ∀ n : ℕ, Nat.card (torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2)
+    {x y : TateModule p M}
+    (h1 : ∀ a b : ℤ, a • (x : ℕ → M) 1 + b • (y : ℕ → M) 1 = 0 → (p : ℤ) ∣ a ∧ (p : ℤ) ∣ b) :
+    ⊤ ≤ span ℤ_[p] (Set.range ![x, y]) := by
+  intro z _
+  obtain ⟨s, t, hst⟩ := mem_span_pair hcard h1 z
+  rw [Matrix.range_cons_cons_empty, Submodule.mem_span_pair]
+  exact ⟨s, t, hst⟩
+
+noncomputable def basisOfCard (hcard : ∀ n : ℕ, Nat.card (torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) = (p ^ n)
+  ^ 2) :
+    Module.Basis (Fin 2) ℤ_[p] (TateModule p M) :=
+  Module.Basis.mk (v := ![(exists_pair hcard).choose, (exists_pair hcard).choose_spec.choose])
+    (linearIndependent_pair (exists_pair hcard).choose_spec.choose_spec)
+    (top_le_span_pair hcard (exists_pair hcard).choose_spec.choose_spec)
+
+theorem basisOfCard_rel_one (hcard : ∀ n : ℕ, Nat.card (torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^
+  2)
+    (a b : ℤ) (h : a • ((basisOfCard hcard 0 : TateModule p M) : ℕ → M) 1 +
+      b • ((basisOfCard hcard 1 : TateModule p M) : ℕ → M) 1 = 0) : (p : ℤ) ∣ a ∧ (p : ℤ) ∣ b := by
+  rw [basisOfCard, Module.Basis.coe_mk] at h
+  exact (exists_pair hcard).choose_spec.choose_spec a b h
+
+theorem dvd_of_rel_basisOfCard_apply
+    (hcard : ∀ n : ℕ, Nat.card (torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2) (n : ℕ) (a b : ℤ)
+    (h : a • ((basisOfCard hcard 0 : TateModule p M) : ℕ → M) n +
+      b • ((basisOfCard hcard 1 : TateModule p M) : ℕ → M) n = 0) :
+    ((p ^ n : ℕ) : ℤ) ∣ a ∧ ((p ^ n : ℕ) : ℤ) ∣ b :=
+  dvd_of_rel_apply (basisOfCard_rel_one hcard) n a b h
+
+theorem exists_eq_smul_basisOfCard_apply
+    (hcard : ∀ n : ℕ, Nat.card (torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2) (n : ℕ) {m : M}
+    (hm : m ∈ torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) :
+    ∃ a b : ℕ, (a : ℤ) • ((basisOfCard hcard 0 : TateModule p M) : ℕ → M) n +
+      (b : ℤ) • ((basisOfCard hcard 1 : TateModule p M) : ℕ → M) n = m :=
+  exists_eq_levelMap hcard (basisOfCard_rel_one hcard) n hm
+
+theorem free (hcard : ∀ n : ℕ, Nat.card (torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2) :
+    Module.Free ℤ_[p] (TateModule p M) :=
+  Module.Free.of_basis (basisOfCard hcard)
+
+theorem finite (hcard : ∀ n : ℕ, Nat.card (torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2) :
+    Module.Finite ℤ_[p] (TateModule p M) :=
+  Module.Finite.of_basis (basisOfCard hcard)
+
+theorem finrank_eq_two (hcard : ∀ n : ℕ, Nat.card (torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2) :
+    Module.finrank ℤ_[p] (TateModule p M) = 2 := by
+  rw [Module.finrank_eq_card_basis (basisOfCard hcard), Fintype.card_fin]
+
+end Free
+
+end TateModule
+
+namespace TateModule
+
+variable {p : ℕ} {M : Type} [AddCommGroup M] [Fact p.Prime]
+
+section action
+
+variable {G : Type} [Monoid G] [DistribMulAction G M]
+
+theorem rep_sub_mem_of_forall_torsionBy (g : G) (n : ℕ)
+    (h : ∀ m ∈ Submodule.torsionBy ℤ M ((p ^ n : ℕ) : ℤ), g • m = m) (x : TateModule p M) :
+    rep p M G g x - x ∈ (maximalIdeal ℤ_[p] ^ n) • (⊤ : Submodule ℤ_[p] (TateModule p M)) :=
+  rep_sub_mem_of_apply_eq g x n (h _ (proj_mem_torsionBy n x))
+
+theorem rep_eq_one_of_forall_torsionBy (g : G)
+    (h : ∀ n : ℕ, ∀ m ∈ Submodule.torsionBy ℤ M ((p ^ n : ℕ) : ℤ), g • m = m) :
+    rep p M G g = 1 := by
+  refine LinearMap.ext fun x => Subtype.ext (funext fun n => ?_)
+  rw [rep_apply, Module.End.one_apply]
+  exact h n _ (proj_mem_torsionBy n x)
+
+end action
+
+end TateModule
+
+namespace WeierstrassCurve
+
+open WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+def Affine.Point.coords {F : Type} [Field F] {W : WeierstrassCurve F} : W.toAffine.Point → Set F
+  | 0 => ∅
+  | @Affine.Point.some _ _ _ x y _ => {x, y}
+
+theorem Affine.Point.coords_finite {F : Type} [Field F] {W : WeierstrassCurve F}
+    (P : W.toAffine.Point) : P.coords.Finite := by
+  rcases P with _ | ⟨x, y, h⟩
+  · exact Set.finite_empty
+  · exact (Set.finite_singleton y).insert x
+
+theorem Affine.Point.algEquiv_smul_eq_self_of_forall_coords {F S : Type} [Field F] [CommRing S]
+    [Algebra S F] [DecidableEq F] {W : WeierstrassCurve S} (σ : F ≃ₐ[S] F)
+    (P : (W.toAffine⁄F).Point) (h : ∀ z ∈ Affine.Point.coords (W := W.baseChange F) P, σ z = z) :
+    σ • P = P := by
+  rcases P with _ | ⟨x, y, hP⟩
+  · rfl
+  · have hx : σ x = x := h x (Set.mem_insert x {y})
+    have hy : σ y = y := h y (Set.mem_insert_of_mem x (Set.mem_singleton y))
+    rw [algEquiv_smul_def, map_some, Affine.Point.some.injEq]
+    exact ⟨hx, hy⟩
+
+variable (W : WeierstrassCurve ℚ) (p : ℕ) [Fact p.Prime]
+
+noncomputable def torsionField (n : ℕ) : IntermediateField ℚ (AlgebraicClosure ℚ) :=
+  IntermediateField.adjoin ℚ
+    (⋃ P ∈ (Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) : ℤ) :
+        Set (W⁄(AlgebraicClosure ℚ)).Point),
+      Affine.Point.coords (W := W.baseChange (AlgebraicClosure ℚ)) P)
+
+omit [Fact p.Prime] in
+theorem coords_subset_torsionField (n : ℕ) {P : (W⁄(AlgebraicClosure ℚ)).Point}
+    (hP : P ∈ Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) : ℤ)) :
+    Affine.Point.coords (W := W.baseChange (AlgebraicClosure ℚ)) P ⊆ (W.torsionField p n : Set _) :=
+  fun _ hz => IntermediateField.subset_adjoin ℚ _ (Set.mem_biUnion hP hz)
+
+omit [Fact p.Prime] in
+theorem finiteDimensional_torsionField (n : ℕ)
+    (hfin : Finite (Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) : ℤ))) :
+    FiniteDimensional ℚ (W.torsionField p n) := by
+  have hS : (⋃ P ∈ (Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) : ℤ) :
+        Set (W⁄(AlgebraicClosure ℚ)).Point),
+      Affine.Point.coords (W := W.baseChange (AlgebraicClosure ℚ)) P).Finite :=
+    Set.Finite.biUnion (Set.finite_coe_iff.mp hfin) fun P _ => Affine.Point.coords_finite P
+  have := hS.to_subtype
+  exact IntermediateField.finiteDimensional_adjoin fun z _ => by
+    convert ((AlgebraicClosure.isAlgebraic ℚ).isAlgebraic z).isIntegral
+
+omit [Fact p.Prime] in
+theorem algEquiv_smul_eq_self_of_mem_torsionBy (n : ℕ)
+    (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ)
+    (hσ : ∀ z ∈ W.torsionField p n, σ z = z) {P : (W⁄(AlgebraicClosure ℚ)).Point}
+    (hP : P ∈ Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) : ℤ)) :
+    σ • P = P :=
+  Affine.Point.algEquiv_smul_eq_self_of_forall_coords σ P
+    fun z hz => hσ z (W.coords_subset_torsionField p n hP hz)
+
+theorem tateModule_isAdicContinuous
+    (hfin : ∀ n : ℕ, Finite (Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) :
+      ℤ))) :
+    GaloisActionIsAdicContinuous ℤ_[p]
+      (TateModule.rep p (W⁄(AlgebraicClosure ℚ)).Point (AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure
+        ℚ)) :=
+  fun n => ⟨W.torsionField p n, W.finiteDimensional_torsionField p n (hfin n), fun σ hσ x =>
+    TateModule.rep_sub_mem_of_forall_torsionBy σ n
+      (fun _ hP => W.algEquiv_smul_eq_self_of_mem_torsionBy p n σ hσ hP) x⟩
+
+omit [Fact p.Prime] in
+theorem finite_torsionBy_of_card (n : ℕ)
+    (hcard : Nat.card (Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) : ℤ))
+      = (p ^ n) ^ 2) (hp : p ≠ 0) :
+    Finite (Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) : ℤ)) :=
+  Nat.finite_of_card_ne_zero (by rw [hcard]; exact pow_ne_zero 2 (pow_ne_zero n hp))
+
+noncomputable def tateModuleRepOfBasis
+    (hcard : ∀ n : ℕ, Nat.card (Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) :
+      ℤ))
+      = (p ^ n) ^ 2)
+    (b : Module.Basis (Fin 2) ℤ_[p] (TateModule p (W⁄(AlgebraicClosure ℚ)).Point)) :
+    GaloisRepAdic ℤ_[p] where
+  V := TateModule p (W⁄(AlgebraicClosure ℚ)).Point
+  instFree := Module.Free.of_basis b
+  instFinite := Module.Finite.of_basis b
+  finrank_eq := by rw [Module.finrank_eq_card_basis b, Fintype.card_fin]
+  ρ := TateModule.rep p (W⁄(AlgebraicClosure ℚ)).Point (AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ)
+  isAdicContinuous := W.tateModule_isAdicContinuous p
+    fun n => W.finite_torsionBy_of_card p n (hcard n) (Nat.Prime.ne_zero Fact.out)
+
+@[simp] theorem tateModuleRepOfBasis_V
+    (hcard : ∀ n : ℕ, Nat.card (Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) :
+      ℤ))
+      = (p ^ n) ^ 2)
+    (b : Module.Basis (Fin 2) ℤ_[p] (TateModule p (W⁄(AlgebraicClosure ℚ)).Point)) :
+    (W.tateModuleRepOfBasis p hcard b).V = TateModule p (W⁄(AlgebraicClosure ℚ)).Point := rfl
+
+theorem tateModuleRepOfBasis_ρ
+    (hcard : ∀ n : ℕ, Nat.card (Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) :
+      ℤ))
+      = (p ^ n) ^ 2)
+    (b : Module.Basis (Fin 2) ℤ_[p] (TateModule p (W⁄(AlgebraicClosure ℚ)).Point)) :
+    (W.tateModuleRepOfBasis p hcard b).ρ
+      = TateModule.rep p (W⁄(AlgebraicClosure ℚ)).Point (AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure
+        ℚ) :=
+  rfl
+
+@[simp] theorem tateModuleRepOfBasis_ρ_apply
+    (hcard : ∀ n : ℕ, Nat.card (Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) :
+      ℤ))
+      = (p ^ n) ^ 2)
+    (b : Module.Basis (Fin 2) ℤ_[p] (TateModule p (W⁄(AlgebraicClosure ℚ)).Point))
+    (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ)
+    (x : TateModule p (W⁄(AlgebraicClosure ℚ)).Point)
+    (n : ℕ) :
+    ((show TateModule p (W⁄(AlgebraicClosure ℚ)).Point from (W.tateModuleRepOfBasis p hcard b).ρ σ
+      x) :
+        ℕ → (W⁄(AlgebraicClosure ℚ)).Point) n
+      = σ • (x : ℕ → (W⁄(AlgebraicClosure ℚ)).Point) n := rfl
+
+end WeierstrassCurve
+
+namespace GaloisRep
+
+variable (𝒪 : Type) [CommRing 𝒪] [IsLocalRing 𝒪] (p : ℕ) [Fact p.Prime]
+
+@[simp] theorem padicIntToRingLevel_apply (hp : (p : 𝒪) ∈ maximalIdeal 𝒪) (n : ℕ) (a : ℤ_[p]) :
+    padicIntToRingLevel 𝒪 p hp n a = ZMod.cast (PadicInt.toZModPow n a) := rfl
+
+theorem padicIntToRingLevel_natCast (hp : (p : 𝒪) ∈ maximalIdeal 𝒪) (n c : ℕ) :
+    padicIntToRingLevel 𝒪 p hp n c = c :=
+  map_natCast _ c
+
+variable [IsAdicComplete (maximalIdeal 𝒪) 𝒪]
+
+theorem mk_comp_padicIntToRing (hp : (p : 𝒪) ∈ maximalIdeal 𝒪) (n : ℕ) :
+    (Ideal.Quotient.mk (maximalIdeal 𝒪 ^ n)).comp (padicIntToRing 𝒪 p hp) =
+      padicIntToRingLevel 𝒪 p hp n :=
+  IsAdicComplete.mk_comp_liftRingHom (maximalIdeal 𝒪) _ _ n
+
+theorem mk_padicIntToRing (hp : (p : 𝒪) ∈ maximalIdeal 𝒪) (n : ℕ) (a : ℤ_[p]) :
+    Ideal.Quotient.mk (maximalIdeal 𝒪 ^ n) (padicIntToRing 𝒪 p hp a) =
+      padicIntToRingLevel 𝒪 p hp n a :=
+  IsAdicComplete.mk_liftRingHom (maximalIdeal 𝒪) _ _ n a
+
+theorem eq_padicIntToRing (hp : (p : 𝒪) ∈ maximalIdeal 𝒪) {φ : ℤ_[p] →+* 𝒪}
+    (hφ : ∀ n, (Ideal.Quotient.mk (maximalIdeal 𝒪 ^ n)).comp φ = padicIntToRingLevel 𝒪 p hp n) :
+    φ = padicIntToRing 𝒪 p hp :=
+  IsAdicComplete.eq_liftRingHom (maximalIdeal 𝒪) _ _ φ hφ
+
+omit [IsAdicComplete (maximalIdeal 𝒪) 𝒪] in
+theorem mk_comp_eq_padicIntToRingLevel_iff (hp : (p : 𝒪) ∈ maximalIdeal 𝒪) (φ : ℤ_[p] →+* 𝒪) (n : ℕ)
+    :
+    (Ideal.Quotient.mk (maximalIdeal 𝒪 ^ n)).comp φ = padicIntToRingLevel 𝒪 p hp n ↔
+      ∀ a : ℤ_[p], φ a - (a.appr n : 𝒪) ∈ maximalIdeal 𝒪 ^ n := by
+  constructor
+  · intro h a
+    have ha := RingHom.congr_fun h a
+    rw [RingHom.comp_apply, padicIntToRingLevel_apply, TateModule.toZModPow_eq_appr,
+      ZMod.cast_natCast (ringChar_quotient_dvd 𝒪 p hp n), ← map_natCast (Ideal.Quotient.mk _),
+      Ideal.Quotient.eq] at ha
+    exact ha
+  · intro h
+    refine RingHom.ext fun a => ?_
+    rw [RingHom.comp_apply, padicIntToRingLevel_apply, TateModule.toZModPow_eq_appr,
+      ZMod.cast_natCast (ringChar_quotient_dvd 𝒪 p hp n), ← map_natCast (Ideal.Quotient.mk _),
+      Ideal.Quotient.eq]
+    exact h a
+
+end GaloisRep
+
+namespace PadicInt
+
+variable (p : ℕ) [Fact p.Prime]
+
+theorem natCast_mem_maximalIdeal : (p : ℤ_[p]) ∈ maximalIdeal ℤ_[p] := by
+  rw [maximalIdeal_eq_span_p]
+  exact Ideal.mem_span_singleton_self _
+
+theorem padicIntToRing_self :
+    GaloisRep.padicIntToRing ℤ_[p] p (natCast_mem_maximalIdeal p) = RingHom.id ℤ_[p] := by
+  symm
+  refine GaloisRep.eq_padicIntToRing ℤ_[p] p (natCast_mem_maximalIdeal p) fun n => ?_
+  rw [GaloisRep.mk_comp_eq_padicIntToRingLevel_iff]
+  intro a
+  rw [RingHom.id_apply, maximalIdeal_eq_span_p, Ideal.span_singleton_pow]
+  exact appr_spec n a
+
+end PadicInt
+
+namespace WeierstrassCurve
+
+open WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+noncomputable def tateModuleRep (W : WeierstrassCurve ℚ) (p : ℕ) [Fact p.Prime]
+    (hcard : ∀ n : ℕ,
+      Nat.card (Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^
+        2) :
+    GaloisRepAdic ℤ_[p] :=
+  W.tateModuleRepOfBasis p hcard (TateModule.basisOfCard hcard)
+
+@[simp] theorem tateModuleRep_V (W : WeierstrassCurve ℚ) (p : ℕ) [Fact p.Prime]
+    (hcard : ∀ n : ℕ,
+      Nat.card (Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^
+        2) :
+    (W.tateModuleRep p hcard).V = TateModule p (W⁄(AlgebraicClosure ℚ)).Point := rfl
+
+theorem tateModuleRep_ρ (W : WeierstrassCurve ℚ) (p : ℕ) [Fact p.Prime]
+    (hcard : ∀ n : ℕ,
+      Nat.card (Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^
+        2) :
+    (W.tateModuleRep p hcard).ρ
+      = TateModule.rep p (W⁄(AlgebraicClosure ℚ)).Point (AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure
+        ℚ) :=
+  rfl
+
+@[simp] theorem tateModuleRep_ρ_apply (W : WeierstrassCurve ℚ) (p : ℕ) [Fact p.Prime]
+    (hcard : ∀ n : ℕ,
+      Nat.card (Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^
+        2)
+    (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ)
+    (x : TateModule p (W⁄(AlgebraicClosure ℚ)).Point)
+    (n : ℕ) :
+    ((show TateModule p (W⁄(AlgebraicClosure ℚ)).Point from (W.tateModuleRep p hcard).ρ σ x) : ℕ →
+      _) n
+      = σ • (x : ℕ → (W⁄(AlgebraicClosure ℚ)).Point) n := rfl
+
+theorem tateModuleRepOfBasis_eq_tateModuleRep (W : WeierstrassCurve ℚ) (p : ℕ) [Fact p.Prime]
+    (hcard : ∀ n : ℕ,
+      Nat.card (Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^
+        2)
+    (b : Module.Basis (Fin 2) ℤ_[p] (TateModule p (W⁄(AlgebraicClosure ℚ)).Point)) :
+    W.tateModuleRepOfBasis p hcard b = W.tateModuleRep p hcard := rfl
+
+end WeierstrassCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_WeilPairingFun.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_WeilPairingFun.lean
new file mode 100644
index 0000000000..cc62d8a85d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_WeilPairingFun.lean
@@ -0,0 +1,121 @@
+/-
+Based on Prove2Me node EllipticCurve_WeilPairingFun
+(1bf92a85-c3e9-5b97-802c-d79bf412e655) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+
+/-!
+# Weil functions and a point-level Weil pairing constant
+
+Definition: `EllipticCurve_WeilPairingFun` (`1bf92a85-c3e9-5b97-802c-d79bf412e655`), by Claude,
+2026-09-05.
+
+Throughout, $W$ is a Weierstrass curve over a field $R$ and $K$ is a field equipped with an
+$R$-algebra structure; $(W⁄K)$ denotes the base-changed affine curve, with its coordinate ring
+$(W⁄K)$`.CoordinateRing`, its function field $(W⁄K)$`.FunctionField` and its group of points
+$(W⁄K)$`.Point`. For a point $P$, `placeIdeal W K P` is the unit ideal when $P = 0$ and otherwise
+the underlying ideal of the height-one place `placeOf W K P`, namely the maximal ideal $(x - x_P,\,y
+- y_P)$ of the coordinate ring cut out by the affine point $P$; the two accompanying lemmas record
+these two cases. For $n \in \mathbb{Z}$ and a point $Q$, `fibSet W K n Q` is the set $\{P : n \cdot
+P = Q\}$, with membership unfolding by definition, and `fibIdeal W K n Q` is the product of
+`placeIdeal W K P` over that set when it is finite (the finite set being taken in the sense of
+`Set.Finite.toFinset`), and the unit ideal otherwise. `weilNum W K n T` is a chosen generator of
+`fibIdeal W K n T` when that ideal is principal, and $1$ otherwise; `span_weilNum` states that under
+principality the span of this element is the ideal. The Weil function `weilFun W K n T` is then the
+quotient, in the function field, of the images of `weilNum W K n T` and `weilNum W K n 0`.
+
+Assuming in addition that $K$ is algebraically closed and $W$ is elliptic, `weilPairing0 W K n S T`
+is defined to be a unit $c \in K^{\times}$ satisfying $\tau_S^{*}(g_{n,T}) = c \cdot g_{n,T}$, where
+$\tau_S^{*} =$ `transEquiv W K S` is the automorphism of the function field pulling back along
+translation by $S$ and $g_{n,T} =$ `weilFun W K n T`, and to be $1$ when no such unit exists. The
+defining relation (`transEquiv_weilFun`) and the fallback value (`weilPairing0_of_not`) are recorded
+as the two characterising lemmas; no bilinearity, alternation or non-degeneracy is asserted at this
+stage.
+
+**Relation to Mathlib.** Mathlib supplies the affine coordinate ring of a Weierstrass curve, its
+ideals `XYIdeal`/`XClass`/`YClass` and the group of affine points; the places attached to points,
+the translation automorphisms of the function field, and the Weil functions and pairing constant
+defined here are the project's own, Mathlib having no Weil pairing.
+
+**Where it is used.** These Weil functions and the constant $e_0$ attached to a pair of points are
+the basis for the project's treatment of the Weil pairing on $n$-torsion, whose bilinearity,
+alternation and Galois equivariance give the determinant of the mod-$n$ representation attached to
+an elliptic curve as the cyclotomic character.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace WeierstrassCurve.Affine
+
+section WeilPairingDefs
+
+variable {R : Type*} [Field R] (W : WeierstrassCurve R) (K : Type*) [Field K] [Algebra R K]
+  [DecidableEq K]
+
+open Classical in
+noncomputable def placeIdeal (P : (W⁄K).Point) : Ideal (W⁄K).CoordinateRing :=
+  if hP : P = 0 then ⊤ else (placeOf W K P hP).asIdeal
+
+theorem placeIdeal_zero : placeIdeal W K 0 = ⊤ := dite_eq_left rfl
+
+theorem placeIdeal_of_ne_zero {P : (W⁄K).Point} (hP : P ≠ 0) :
+    placeIdeal W K P = (placeOf W K P hP).asIdeal := dite_eq_right hP
+
+def fibSet (n : ℤ) (Q : (W⁄K).Point) : Set (W⁄K).Point := {P | n • P = Q}
+
+@[simp] theorem mem_fibSet {n : ℤ} {Q P : (W⁄K).Point} : P ∈ fibSet W K n Q ↔ n • P = Q := Iff.rfl
+
+open Classical in
+noncomputable def fibIdeal (n : ℤ) (Q : (W⁄K).Point) : Ideal (W⁄K).CoordinateRing :=
+  if h : (fibSet W K n Q).Finite then ∏ P ∈ h.toFinset, placeIdeal W K P else ⊤
+
+theorem fibIdeal_eq {n : ℤ} {Q : (W⁄K).Point} (h : (fibSet W K n Q).Finite) :
+    fibIdeal W K n Q = ∏ P ∈ h.toFinset, placeIdeal W K P := by
+  rw [fibIdeal, dite_eq_left h]
+
+open Classical in
+noncomputable def weilNum (n : ℤ) (T : (W⁄K).Point) : (W⁄K).CoordinateRing :=
+  if h : (fibIdeal W K n T).IsPrincipal then @Submodule.IsPrincipal.generator _ _ _ _ _ _ h else 1
+
+theorem span_weilNum {n : ℤ} {T : (W⁄K).Point} (h : (fibIdeal W K n T).IsPrincipal) :
+    Ideal.span {weilNum W K n T} = fibIdeal W K n T := by
+  rw [weilNum, dite_eq_left h]
+  exact @Ideal.span_singleton_generator _ _ _ h
+
+noncomputable def weilFun (n : ℤ) (T : (W⁄K).Point) : (W⁄K).FunctionField :=
+  algebraMap _ (W⁄K).FunctionField (weilNum W K n T) / algebraMap _ (W⁄K).FunctionField (weilNum W K
+    n 0)
+
+open Classical in
+noncomputable def weilPairing0 [IsAlgClosed K] [W.IsElliptic] (n : ℤ) (S T : (W⁄K).Point) : Kˣ :=
+  if h : ∃ c : Kˣ, transEquiv W K S (weilFun W K n T) =
+      algebraMap K (W⁄K).FunctionField (c : K) * weilFun W K n T
+  then h.choose else 1
+
+theorem transEquiv_weilFun [IsAlgClosed K] [W.IsElliptic] {n : ℤ} {S T : (W⁄K).Point}
+    (h : ∃ c : Kˣ, transEquiv W K S (weilFun W K n T) =
+      algebraMap K (W⁄K).FunctionField (c : K) * weilFun W K n T) :
+    transEquiv W K S (weilFun W K n T) =
+      algebraMap K (W⁄K).FunctionField (weilPairing0 W K n S T : K) * weilFun W K n T := by
+  rw [weilPairing0, dite_eq_left h]
+  exact h.choose_spec
+
+theorem weilPairing0_of_not [IsAlgClosed K] [W.IsElliptic] {n : ℤ} {S T : (W⁄K).Point}
+    (h : ¬ ∃ c : Kˣ, transEquiv W K S (weilFun W K n T) =
+      algebraMap K (W⁄K).FunctionField (c : K) * weilFun W K n T) :
+    weilPairing0 W K n S T = 1 := by
+  rw [weilPairing0, dite_eq_right h]
+
+end WeilPairingDefs
+
+end WeierstrassCurve.Affine
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_ZeroComponentAt.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_ZeroComponentAt.lean
new file mode 100644
index 0000000000..73bd8c0490
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_EllipticCurve_ZeroComponentAt.lean
@@ -0,0 +1,78 @@
+/-
+Based on Prove2Me node EllipticCurve_ZeroComponentAt
+(972b2a43-0d9d-5262-8073-36ca10ddb117) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.RingTheory.Valuation.ValuationSubring
+public import Mathlib.RingTheory.LocalRing.ResidueField.Basic
+public import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_GaloisRep
+
+/-!
+# Points in the identity component at a place of Q​
+
+Definition: `EllipticCurve_ZeroComponentAt` (`972b2a43-0d9d-5262-8073-36ca10ddb117`), by Claude,
+2026-09-05.
+
+The module defines a single predicate, [`WeierstrassCurve.InZeroComponentAt W A
+P`](../def/EllipticCurve_ZeroComponentAt.html#L13). Its data are: a Weierstrass curve $W$ over
+$\mathbb{Z}$ (a bare Weierstrass equation, with no minimality or nonsingularity assumption); a
+valuation subring $A$ of $\overline{\mathbb{Q}}$, i.e. a place of $\overline{\mathbb{Q}}$, with its
+maximal ideal and residue field $k_A =$ `IsLocalRing.ResidueField A`; and a point $P$ of the affine
+point type of $W$ base changed along $\mathbb{Z}\to\mathbb{Q}$ and then to $\overline{\mathbb{Q}}$.
+The predicate is the disjunction of the following cases. Either $P$ is the point at infinity $0$; or
+$P$ is an affine point `.some x y h` with coordinates $x,y\in\overline{\mathbb{Q}}$ and a proof $h$
+that $(x,y)$ is a nonsingular point of the base-changed affine equation, and then one of two further
+conditions holds: (i) $x\notin A$, i.e. the abscissa is not $A$-integral; or (ii) both $x\in A$ and
+$y\in A$, and the images $\bar x,\bar y$ of $x,y$ under the residue map $A\to k_A$ form a
+nonsingular point of the affine curve obtained by reducing the *integral* model $W$ modulo the
+maximal ideal of $A$ (that is, of $W$ mapped along $\mathbb{Z}\to k_A$).
+
+Thus the predicate is stated relative to the chosen integral Weierstrass model $W$ and to the chosen
+place $A$, and it is a bare `Prop`: nothing here asserts that the points satisfying it form a
+subgroup, nor that $A$-integrality of $x$ forces that of $y$ (condition (ii) demands both). For a
+model minimal at the residue characteristic of $A$, case (i) describes the kernel of reduction and
+case (ii) the points reducing into the smooth locus, so that the predicate cuts out the classical
+subgroup $E_0$ of points reducing to nonsingular points; the group-theoretic and reduction-theoretic
+properties are proved elsewhere as separate theorems.
+
+**Relation to Mathlib.** Built entirely from Mathlib notions — `WeierstrassCurve`, its base change
+and affine points, `Nonsingular`, `ValuationSubring` and `IsLocalRing.ResidueField` with its residue
+map — but Mathlib has no notion of the identity component or of the reduction of a point at a place,
+so this predicate is the project's own.
+
+**Where it is used.** The predicate is used in the local analysis of torsion points on the integral
+Frey model: at primes of multiplicative reduction and at $p$ one asks whether a point of order $p$
+lies on the identity component, and this feeds Mazur's Eisenstein-ideal argument showing that the
+mod-$p$ representation of the Frey curve has no cofixed line for $p\ge 17$ (including the global
+input
+[`WeierstrassCurve.mazurStepThree_not_inZeroComponentAt`]
+(../thm.html#WeierstrassCurve.mazurStepThree_not_inZeroComponentAt)).
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace WeierstrassCurve
+
+open scoped WeierstrassCurve.Affine
+
+def InZeroComponentAt (W : WeierstrassCurve ℤ) (A : ValuationSubring (AlgebraicClosure ℚ))
+    (P : ((W.map (Int.castRingHom ℚ))⁄(AlgebraicClosure ℚ)).Point) : Prop :=
+  P = 0 ∨ ∃ (x y : AlgebraicClosure ℚ)
+      (h : ((W.map (Int.castRingHom ℚ))⁄(AlgebraicClosure ℚ)).toAffine.Nonsingular x y),
+    P = .some x y h ∧
+      (x ∉ A ∨ ∃ (hx : x ∈ A) (hy : y ∈ A),
+        (W.map (Int.castRingHom (IsLocalRing.ResidueField A))).toAffine.Nonsingular
+          (IsLocalRing.residue A ⟨x, hx⟩) (IsLocalRing.residue A ⟨y, hy⟩))
+
+end WeierstrassCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_FLTPrelim_FreyPackage.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_FLTPrelim_FreyPackage.lean
new file mode 100644
index 0000000000..6d80a82c55
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_FLTPrelim_FreyPackage.lean
@@ -0,0 +1,148 @@
+/-
+Based on Prove2Me node FLTPrelim_FreyPackage
+(5ddaddde-4d33-536f-ad48-8f2946cbd54c) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+/-
+Copyright (c) 2024 Kevin Buzzard, Ruben Van de Velde, Pietro Monticone. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Ported from the Imperial College London FLT formalization
+(https://github.com/ImperialCollegeLondon/FLT, blueprint §2.5–2.6).
+-/
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Weierstrass
+public import Mathlib.Algebra.Field.ZMod
+public import Mathlib.Algebra.GCDMonoid.Nat
+public import Mathlib.Algebra.EuclideanDomain.Int
+public import Mathlib.Data.Nat.Prime.Basic
+public import Mathlib.RingTheory.Int.Basic
+public import Mathlib.Tactic.ModCases
+
+/-!
+# The Frey package and its Frey curve
+
+Definition: `FLTPrelim_FreyPackage` (`5ddaddde-4d33-536f-ad48-8f2946cbd54c`), by Claude, 2026-09-05.
+
+A [`FreyPackage`](../def/FLTPrelim_FreyPackage.html#L17) is a structure bundling a normalised
+putative counterexample to Fermat's Last Theorem: integers $a$, $b$, $c$, each assumed nonzero, a
+natural number $p$ together with proofs that $p$ is prime and $5 \le p$, a proof of the equation
+$a^p + b^p = c^p$, and the normalisation hypotheses $\gcd(a,b) = 1$ (as the $\mathbb{Z}$-valued
+`gcd` of the GCD monoid $\mathbb{Z}$), $a \equiv 3 \pmod 4$ (stated as an equation in `ZMod 4` on
+the image of $a$) and $b \equiv 0 \pmod 2$ (stated in `ZMod 2`). All of these are fields of the
+structure, so a term of type [`FreyPackage`](../def/FLTPrelim_FreyPackage.html#L17) carries the
+equation and the congruences as data.
+
+The accompanying lemmas record elementary consequences: $p > 0$, $p \ne 0$, $p$ odd (from primality
+and $p \ge 5$); `gcdab_eq_gcdac`, a standalone lemma that for any integers with $a^p + b^p = c^p$
+and $p > 0$ one has $\gcd(a,b) = \gcd(a,c)$; hence $\gcd(a,c) = 1$ and $\gcd(b,c) = 1$ for a
+package; $abc \ne 0$; and $2 \mid abc$, deduced from $2 \mid b$.
+
+Two Weierstrass curves are then defined from a package $P$, by giving the five coefficients
+$(a_1,a_2,a_3,a_4,a_6)$ directly: `freyCurve` over $\mathbb{Q}$ and `freyCurveInt` over
+$\mathbb{Z}$, both with $a_1 = 1$, $a_2 = (b^p - 1 - a^p)/4$, $a_3 = 0$, $a_4 = -a^p b^p/16$, $a_6 =
+0$. Thus the curve is $y^2 + xy = x^3 + \frac{b^p - 1 - a^p}{4}x^2 - \frac{a^p b^p}{16}x$, the
+standard integral model of $y^2 = x(x - a^p)(x + b^p)$. Note that in `freyCurveInt` the two
+divisions are integer division in $\mathbb{Z}$ (they are exact under the normalisation hypotheses,
+but the definition itself does not record this), whereas in `freyCurve` they are genuine division in
+$\mathbb{Q}$.
+
+**Relation to Mathlib.** Mathlib has no notion of a Frey package; the structure is the project's
+own. The curves are ordinary terms of Mathlib's `WeierstrassCurve` over `ℤ` and over `ℚ`, with the
+coefficients supplied explicitly.
+
+**Where it is used.** Every module of the main line of argument is phrased for a fixed
+[`FreyPackage`](../def/FLTPrelim_FreyPackage.html#L17): one is produced from an arbitrary
+counterexample to Fermat's Last Theorem with prime exponent $p \ge 5$, and the contradiction is
+obtained by studying the mod $p$ representation on the Frey curve `freyCurve` — irreducibility,
+modularity, level lowering, and the absence of weight-2 cusp forms on $\Gamma_0(2)$.
+
+*Attribution:* this file contains material adapted from third-party Apache-2.0 sources (adapted
+(upstream notice retained in place, from our May port): `FLT/Basic/FreyPackage.lean` — authors
+recorded in our intermediate port: Kevin Buzzard, Ruben Van de Velde, Pietro Monticone (path as
+recorded in our port)). See ATTRIBUTION.md and NOTICE in the source repository.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+structure FreyPackage where
+  a : ℤ
+  b : ℤ
+  c : ℤ
+  ha0 : a ≠ 0
+  hb0 : b ≠ 0
+  hc0 : c ≠ 0
+  p : ℕ
+  pp : Nat.Prime p
+  hp5 : 5 ≤ p
+  hFLT : a ^ p + b ^ p = c ^ p
+  hgcdab : gcd a b = 1
+  ha4 : (a : ZMod 4) = 3
+  hb2 : (b : ZMod 2) = 0
+
+namespace FreyPackage
+
+lemma hppos (P : FreyPackage) : 0 < P.p := lt_of_lt_of_le (by omega) P.hp5
+
+lemma hp0 (P : FreyPackage) : P.p ≠ 0 := P.hppos.ne'
+
+lemma hp_odd (P : FreyPackage) : Odd P.p :=
+  P.pp.odd_of_ne_two (by have := P.hp5; omega)
+
+lemma gcdab_eq_gcdac {a b c : ℤ} {p : ℕ} (hp : 0 < p) (h : a ^ p + b ^ p = c ^ p) :
+    gcd a b = gcd a c := by
+  have foo : gcd a b ∣ gcd a c := by
+    apply dvd_gcd (gcd_dvd_left a b)
+    rw [← Int.pow_dvd_pow_iff hp.ne', ← h]
+    apply dvd_add <;> rw [Int.pow_dvd_pow_iff hp.ne']
+    · exact gcd_dvd_left a b
+    · exact gcd_dvd_right a b
+  have bar : gcd a c ∣ gcd a b := by
+    apply dvd_gcd (gcd_dvd_left a c)
+    have h2 : b ^ p = c ^ p - a ^ p := eq_sub_of_add_eq' h
+    rw [← Int.pow_dvd_pow_iff hp.ne', h2]
+    apply dvd_add
+    · rw [Int.pow_dvd_pow_iff hp.ne']; exact gcd_dvd_right a c
+    · rw [dvd_neg, Int.pow_dvd_pow_iff hp.ne']; exact gcd_dvd_left a c
+  change _ ∣ (Int.gcd a c : ℤ) at foo
+  apply Int.ofNat_dvd.1 at bar
+  apply Int.ofNat_dvd.1 at foo
+  exact congr_arg ((↑) : ℕ → ℤ) <| Nat.dvd_antisymm foo bar
+
+lemma hgcdac (P : FreyPackage) : gcd P.a P.c = 1 := by
+  rw [← gcdab_eq_gcdac P.hppos P.hFLT, P.hgcdab]
+
+lemma hgcdbc (P : FreyPackage) : gcd P.b P.c = 1 := by
+  rw [← gcdab_eq_gcdac P.hppos, gcd_comm, P.hgcdab]
+  rw [add_comm]; exact P.hFLT
+
+lemma habc0 (P : FreyPackage) : P.a * P.b * P.c ≠ 0 :=
+  mul_ne_zero (mul_ne_zero P.ha0 P.hb0) P.hc0
+
+lemma two_dvd_abc (P : FreyPackage) : (2 : ℤ) ∣ P.a * P.b * P.c :=
+  dvd_mul_of_dvd_left (dvd_mul_of_dvd_right
+    ((ZMod.intCast_zmod_eq_zero_iff_dvd P.b 2).1 P.hb2) _) _
+
+def freyCurveInt (P : FreyPackage) : WeierstrassCurve ℤ where
+  a₁ := 1
+  a₂ := (P.b ^ P.p - 1 - P.a ^ P.p) / 4
+  a₃ := 0
+  a₄ := -(P.a ^ P.p) * (P.b ^ P.p) / 16
+  a₆ := 0
+
+def freyCurve (P : FreyPackage) : WeierstrassCurve ℚ where
+  a₁ := 1
+  a₂ := (P.b ^ P.p - 1 - P.a ^ P.p) / 4
+  a₃ := 0
+  a₄ := -(P.a ^ P.p) * (P.b ^ P.p) / 16
+  a₆ := 0
+
+end FreyPackage
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_FLTPrelim_GaloisRep.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_FLTPrelim_GaloisRep.lean
new file mode 100644
index 0000000000..a578dcb802
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_FLTPrelim_GaloisRep.lean
@@ -0,0 +1,140 @@
+/-
+Based on Prove2Me node FLTPrelim_GaloisRep
+(352cbb80-09ad-5c6e-9401-39871c32239e) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+/-
+Copyright (c) 2024 Imperial College London FLT project contributors.
+Released under Apache 2.0 license.
+Adapted from the Imperial College London FLT formalization
+(https://github.com/ImperialCollegeLondon/FLT).
+-/
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.Algebra.Module.Torsion.Basic
+public import Mathlib.Algebra.GroupWithZero.Action.Basic
+public import Mathlib.Algebra.Module.ZMod
+public import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure
+
+/-!
+# Galois action on n-torsion; irreducibility predicate
+
+Definition: `FLTPrelim_GaloisRep` (`352cbb80-09ad-5c6e-9401-39871c32239e`), by Claude, 2026-09-05.
+
+For a Weierstrass curve `W' : Affine R` and a tower of algebras $R \to S \to K$ with $K$ a field
+(with decidable equality), the module makes the group $K \simeq_{\mathrm{alg}[S]} K$ of $S$-algebra
+automorphisms of $K$ act on the group of points $(W'\!⁄K)$`.Point` of the base change of $W'$ to
+$K$: $\sigma \bullet P$ is defined to be `Point.map` of $\sigma$ viewed as an $S$-algebra
+homomorphism (`algEquiv_smul_def`), and this is upgraded to a `DistribMulAction`, so the action is
+by group automorphisms of the Mordell–Weil-type group $(W'\!⁄K)$`.Point`. Since the action commutes
+with integer multiples (`algEquiv_smul_zsmul`), it preserves `Submodule.torsionBy ℤ (W'⁄K).Point n`,
+the subgroup of points killed by $n$ (`smul_mem_torsionBy`), giving an induced `DistribMulAction` on
+that $n$-torsion subgroup; the $n$-torsion is also equipped with its canonical $\mathbb Z/n$-module
+structure, obtained from `AddCommGroup.zmodModule` using that $n$ annihilates it.
+
+Two predicates are then defined. `IsGaloisStable S N`, for $N$ a $\mathbb Z/n$-submodule of the
+$n$-torsion, says that $\sigma \bullet x \in N$ for every $S$-algebra automorphism $\sigma$ of $K$
+and every $x \in N$. `GaloisRepIsIrreducible S W' n` is the conjunction of: the $n$-torsion of
+$(W'\!⁄K)$`.Point` is `Nontrivial` (i.e. contains a nonzero point), and every $\mathbb
+Z/n$-submodule $N$ of it satisfying `IsGaloisStable S N` equals $\bot$ or $\top$. The formulation is
+basis-free: no identification of the $n$-torsion with $(\mathbb Z/n)^2$, no matrix representation,
+and no primality assumption on $n$ or algebraic-closedness assumption on $K$ is imposed; the acting
+group is literally the automorphism group $K \simeq_{\mathrm{alg}[S]} K$. A final instance supplies
+classical decidable equality on `AlgebraicClosure ℚ`, the case of $K$ used in the application.
+
+**Relation to Mathlib.** The curve, its affine points and `Point.map`, `Submodule.torsionBy` and
+`AddCommGroup.zmodModule` are Mathlib's; the action of $S$-algebra automorphisms of $K$ on the
+points, the induced action and $\mathbb Z/n$-module structure on the $n$-torsion, and the predicates
+`IsGaloisStable` and `GaloisRepIsIrreducible` are the project's own.
+
+**Where it is used.** These definitions carry the irreducibility step for the Frey curve: the
+statement proved about a Frey package $P$ is `GaloisRepIsIrreducible ℚ P.freyCurve P.p`, i.e. that
+$E_P[p]$ over an algebraic closure of $\mathbb Q$ is nonzero and has no Galois-stable $\mathbb
+Z/p$-submodule other than $0$ and everything, which is the hypothesis feeding the
+modularity/level-lowering part of the argument.
+
+*Attribution:* this file contains material adapted from third-party Apache-2.0 sources (adapted
+(upstream notice retained in place, from our May port): `FLT/EllipticCurve/Torsion.lean` (commit
+7a87d3b25db1) — © 2024 Kevin Buzzard; authors: Kevin Buzzard (path as recorded in our port; the
+notice retained inside our file is our May port's generic one, the upstream notice is reproduced
+here)). See ATTRIBUTION.md and NOTICE in the source repository.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+universe r s v
+
+namespace WeierstrassCurve.Affine.Point
+
+open WeierstrassCurve
+
+variable {R : Type r} {S : Type s} {K : Type v} [CommRing R] [CommRing S] [Field K]
+  [DecidableEq K] {W' : Affine R} [Algebra R S] [Algebra R K] [Algebra S K]
+  [IsScalarTower R S K]
+
+noncomputable instance instSMulAlgEquiv : SMul (K ≃ₐ[S] K) (W'⁄K).Point :=
+  ⟨fun σ P => Point.map σ.toAlgHom P⟩
+
+lemma algEquiv_smul_def (σ : K ≃ₐ[S] K) (P : (W'⁄K).Point) :
+    σ • P = Point.map σ.toAlgHom P :=
+  rfl
+
+noncomputable instance instDistribMulActionAlgEquiv :
+    DistribMulAction (K ≃ₐ[S] K) (W'⁄K).Point where
+  one_smul P := by cases P <;> rfl
+  mul_smul σ τ P := by cases P <;> rfl
+  smul_zero _ := rfl
+  smul_add σ P Q := (Point.map σ.toAlgHom).map_add P Q
+
+lemma algEquiv_smul_zsmul (σ : K ≃ₐ[S] K) (m : ℤ) (P : (W'⁄K).Point) :
+    σ • (m • P) = m • (σ • P) :=
+  (Point.map σ.toAlgHom).map_zsmul m P
+
+lemma smul_mem_torsionBy {n : ℕ} (σ : K ≃ₐ[S] K) {P : (W'⁄K).Point}
+    (hP : P ∈ Submodule.torsionBy ℤ (W'⁄K).Point n) :
+    σ • P ∈ Submodule.torsionBy ℤ (W'⁄K).Point n := by
+  rw [Submodule.mem_torsionBy_iff] at hP ⊢
+  rw [← algEquiv_smul_zsmul, hP, smul_zero]
+
+noncomputable instance instSMulTorsionBy (n : ℕ) :
+    SMul (K ≃ₐ[S] K) (Submodule.torsionBy ℤ (W'⁄K).Point n) :=
+  ⟨fun σ P => ⟨σ • (P : (W'⁄K).Point), smul_mem_torsionBy σ P.property⟩⟩
+
+noncomputable instance instDistribMulActionTorsionBy (n : ℕ) :
+    DistribMulAction (K ≃ₐ[S] K) (Submodule.torsionBy ℤ (W'⁄K).Point n) where
+  one_smul P := Subtype.ext <| one_smul _ (P : (W'⁄K).Point)
+  mul_smul σ τ P := Subtype.ext <| mul_smul σ τ (P : (W'⁄K).Point)
+  smul_zero σ := Subtype.ext <| smul_zero (A := (W'⁄K).Point) σ
+  smul_add σ P Q := Subtype.ext <| smul_add σ (P : (W'⁄K).Point) (Q : (W'⁄K).Point)
+
+noncomputable instance instModuleZModTorsionBy (n : ℕ) :
+    Module (ZMod n) (Submodule.torsionBy ℤ (W'⁄K).Point n) :=
+  AddCommGroup.zmodModule fun x => by
+    rw [← Nat.cast_smul_eq_nsmul ℤ n x]
+    exact Submodule.smul_torsionBy _ x
+
+variable (S) in
+def IsGaloisStable {n : ℕ}
+    (N : Submodule (ZMod n) (Submodule.torsionBy ℤ (W'⁄K).Point n)) : Prop :=
+  ∀ (σ : K ≃ₐ[S] K), ∀ x ∈ N, σ • x ∈ N
+
+variable (S) in
+def GaloisRepIsIrreducible (W' : Affine R) (n : ℕ) : Prop :=
+  Nontrivial (Submodule.torsionBy ℤ (W'⁄K).Point n) ∧
+    ∀ N : Submodule (ZMod n) (Submodule.torsionBy ℤ (W'⁄K).Point n),
+      IsGaloisStable S N → N = ⊥ ∨ N = ⊤
+
+end WeierstrassCurve.Affine.Point
+
+noncomputable instance instDecEqAlgebraicClosureRat :
+    DecidableEq (AlgebraicClosure ℚ) :=
+  Classical.decEq _
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_FLTPrelim_Modularity.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_FLTPrelim_Modularity.lean
new file mode 100644
index 0000000000..a7ee2ca6f8
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_FLTPrelim_Modularity.lean
@@ -0,0 +1,161 @@
+/-
+Based on Prove2Me node FLTPrelim_Modularity
+(ddd45b70-a042-5d79-93f9-c52e6062e9d4) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import Mathlib.NumberTheory.ModularForms.ArithmeticSubgroups
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.AlgebraicGeometry.EllipticCurve.VariableChange
+public import Mathlib.Data.ZMod.Basic
+public import Mathlib.SetTheory.Cardinal.NatCard
+
+/-!
+# Modularity of elliptic curves over ℚ via eigenform coefficients
+
+Definition: `FLTPrelim_Modularity` (`ddd45b70-a042-5d79-93f9-c52e6062e9d4`), by Claude, 2026-09-05.
+
+The module fixes the project's notion of modularity in terms of $q$-expansion coefficients and point
+counts on a chosen integral equation. For $f:\mathbb H\to\mathbb C$, [`ModularFormClass.qCoeff f
+n`](../def/FLTPrelim_Modularity.html#L19) is the $n$-th coefficient of Mathlib's $q$-expansion of
+$f$ at width $1$. [`CuspForm.IsNormalizedEigenform`](../def/FLTPrelim_Modularity.html#L28) is a
+structure on a weight-$2$ cusp form $f$ for $\Gamma_0(N)$ whose fields are exactly the arithmetic of
+the coefficients: $a_1=1$; $a_{mn}=a_ma_n$ for coprime $m,n$;
+$a_{p^{r+2}}=a_pa_{p^{r+1}}-p\,a_{p^r}$ for all primes $p\nmid N$; and $a_{p^{r+2}}=a_pa_{p^{r+1}}$
+for primes $p\mid N$. No Hecke operator appears: being an eigenform is encoded purely by these
+recursions. On the curve side, for a Weierstrass curve over a finite ring the point type is finite
+(proved by injecting points into `Option (R × R)`, the point at infinity going to `none`), the
+number of points of a Weierstrass curve over a commutative ring — Mathlib's affine point type, which
+includes the point at infinity — is given a name `card`, and `traceOfFrobenius` is $\#F+1$ minus
+that number. For $W$ over $\mathbb Z$, `reductionMod W p` is the coefficientwise reduction to
+$\mathbb Z/p$ and `apOfModel W p` its $p+1-\#W(\mathbb F_p)$. Three predicates on integral equations
+follow: `IsGoodPrimeFor W p` is simply $p\nmid\Delta(W)$; `IsSemistableModel W` says no prime
+divides both $\Delta(W)$ and $c_4(W)$; `IsIntegralModelOf W E` says some variable change over
+$\mathbb Q$ carries $E$ to the base change of $W$ to $\mathbb Q$. Finally `IsModularModelOfLevel W
+N` asserts the existence of a weight-$2$ cusp form on $\Gamma_0(N)$ satisfying the above recursions
+with $a_p(f)=a_p(W)$ for every prime $p$ with $p\nmid\Delta(W)$ and $p\nmid N$; `IsModularModel W`
+adds $N\ge 1$; and `IsModular E` says some integral model of $E$ is a modular model. Thus modularity
+is an equality of $L$-coefficients at good primes away from the level, not an assertion about a
+newform of the conductor, nor a Galois-representation isomorphism; semistability is a condition on
+the chosen equation rather than on $E$.
+
+**Relation to Mathlib.** `CuspForm`, `CongruenceSubgroup.Gamma0`, $q$-expansions, `WeierstrassCurve`
+with its invariants $c_4,\Delta$, `VariableChange` and affine points are Mathlib's; the eigenform
+recursions, the counting function and trace of Frobenius, reduction modulo $p$, and the
+semistability, integral-model and modularity predicates are the project's own, together with a
+`Finite` instance for affine points over a finite ring.
+
+**Where it is used.** These definitions give the statement of the modularity input to the proof:
+[`WeierstrassCurve.modularity_of_semistableModel`]
+(../thm.html#WeierstrassCurve.modularity_of_semistableModel)
+derives `IsModular` from `IsSemistableModel` (with $\Delta\ne0$), and
+[`FreyPackage.frey_isModular`]
+(../thm.html#FreyPackage.frey_isModular) applies it to the Frey curve
+attached to a counterexample to Fermat's Last Theorem. Nearly the whole tree below the modularity
+theorem is phrased in terms of these notions.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section DL_Makonde
+
+open UpperHalfPlane
+
+universe u
+
+namespace ModularFormClass
+
+def qCoeff (f : ℍ → ℂ) (n : ℕ) : ℂ :=
+  (qExpansion 1 f).coeff n
+
+end ModularFormClass
+
+namespace CuspForm
+
+open ModularFormClass
+
+structure IsNormalizedEigenform {N : ℕ} (f : CuspForm (CongruenceSubgroup.Gamma0 N) 2) :
+    Prop where
+  qCoeff_one : qCoeff f 1 = 1
+  qCoeff_mul_of_coprime : ∀ m n : ℕ, m.Coprime n →
+    qCoeff f (m * n) = qCoeff f m * qCoeff f n
+  qCoeff_prime_pow_of_not_dvd : ∀ p r : ℕ, p.Prime → ¬ p ∣ N →
+    qCoeff f (p ^ (r + 2)) = qCoeff f p * qCoeff f (p ^ (r + 1)) - p * qCoeff f (p ^ r)
+  qCoeff_prime_pow_of_dvd : ∀ p r : ℕ, p.Prime → p ∣ N →
+    qCoeff f (p ^ (r + 2)) = qCoeff f p * qCoeff f (p ^ (r + 1))
+
+end CuspForm
+
+namespace WeierstrassCurve
+
+namespace Affine
+
+variable {R : Type u} [CommRing R] {W' : Affine R}
+
+private def Point.toOptionPair : W'.Point → Option (R × R)
+  | .zero => none
+  | .some x y _ => Option.some (x, y)
+
+private lemma Point.toOptionPair_injective :
+    Function.Injective (Point.toOptionPair (W' := W')) := by
+  rintro (_ | ⟨x₁, y₁, h₁⟩) (_ | ⟨x₂, y₂, h₂⟩) h <;>
+    simp only [Point.toOptionPair, Option.some.injEq, Prod.mk.injEq, reduceCtorEq] at h
+  · rfl
+  · obtain ⟨rfl, rfl⟩ := h; rfl
+
+instance Point.instFinite [Finite R] : Finite W'.Point :=
+  Finite.of_injective _ Point.toOptionPair_injective
+
+end Affine
+
+section Card
+
+variable {F : Type u} [CommRing F] (W : WeierstrassCurve F)
+
+def card : ℕ := Nat.card W.toAffine.Point
+
+def traceOfFrobenius : ℤ := (Nat.card F : ℤ) + 1 - (W.card : ℤ)
+
+end Card
+
+def reductionMod (W : WeierstrassCurve ℤ) (p : ℕ) : WeierstrassCurve (ZMod p) :=
+  W.map (Int.castRingHom (ZMod p))
+
+def apOfModel (W : WeierstrassCurve ℤ) (p : ℕ) : ℤ :=
+  (W.reductionMod p).traceOfFrobenius
+
+def IsGoodPrimeFor (W : WeierstrassCurve ℤ) (p : ℕ) : Prop :=
+  ¬ (p : ℤ) ∣ W.Δ
+
+def IsSemistableModel (W : WeierstrassCurve ℤ) : Prop :=
+  ∀ p : ℕ, p.Prime → (p : ℤ) ∣ W.Δ → ¬ (p : ℤ) ∣ W.c₄
+
+def IsIntegralModelOf (W : WeierstrassCurve ℤ) (E : WeierstrassCurve ℚ) : Prop :=
+  ∃ C : VariableChange ℚ, C • E = W.map (Int.castRingHom ℚ)
+
+open CuspForm
+
+def IsModularModelOfLevel (W : WeierstrassCurve ℤ) (N : ℕ) : Prop :=
+  ∃ f : CuspForm (CongruenceSubgroup.Gamma0 N) 2, f.IsNormalizedEigenform ∧
+    ∀ p : ℕ, p.Prime → W.IsGoodPrimeFor p → ¬ p ∣ N →
+      ModularFormClass.qCoeff f p = (W.apOfModel p : ℂ)
+
+def IsModularModel (W : WeierstrassCurve ℤ) : Prop :=
+  ∃ N : ℕ, 0 < N ∧ W.IsModularModelOfLevel N
+
+def IsModular (E : WeierstrassCurve ℚ) : Prop :=
+  ∃ W : WeierstrassCurve ℤ, W.IsIntegralModelOf E ∧ W.IsModularModel
+
+end WeierstrassCurve
+
+end DL_Makonde
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_FLTPrelim_Ramification.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_FLTPrelim_Ramification.lean
new file mode 100644
index 0000000000..280a1fa1ec
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_FLTPrelim_Ramification.lean
@@ -0,0 +1,110 @@
+/-
+Based on Prove2Me node FLTPrelim_Ramification
+(2f679d60-0c74-5493-b36f-16da20baed9a) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.Valuation.RamificationGroup
+public import Mathlib.RingTheory.Valuation.ValuationSubring
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_FreyPackage
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_GaloisRep
+
+/-!
+# Unramifiedness at a prime of torsion Galois representations
+
+Definition: `FLTPrelim_Ramification` (`2f679d60-0c74-5493-b36f-16da20baed9a`), by Claude,
+2026-09-05.
+
+Three auxiliary notions and one instantiation. First, for a valuation subring $A$ of a field $L$ and
+a natural number $q$, [`ValuationSubring.LiesOverPrime A q`](../def/FLTPrelim_Ramification.html#L16)
+says simply that the image of $q$ in $L$ lies in `A.nonunits`, i.e. $q$ belongs to the maximal ideal
+of $A$; no primality of $q$ is required by the definition. Second, for an extension $L/K$,
+[`ValuationSubring.inertiaSubgroupIn K A`](../def/FLTPrelim_Ramification.html#L21) is the image of
+Mathlib's inertia subgroup `A.inertiaSubgroup K` (a subgroup of the decomposition subgroup, i.e. of
+the stabiliser of $A$ in $L \simeq_{\mathrm{alg}[K]} L$) under the inclusion
+`(A.decompositionSubgroup K).subtype`, so that inertia is presented as a subgroup of the full
+automorphism group $L \simeq_{\mathrm{alg}[K]} L$ rather than of the decomposition subgroup.
+
+Third, given a tower $R \to S \to K$ with $S$, $K$ fields and an affine Weierstrass curve $W'$ over
+$R$, [`WeierstrassCurve.Affine.Point.GaloisRepUnramifiedAt S K W' n
+q`](../def/FLTPrelim_Ramification.html#L35) asserts: for every valuation subring $A$ of $K$ with $q
+\in A.\mathrm{nonunits}$, every $\sigma$ in the inertia subgroup of $A$ over $S$ (viewed in $K
+\simeq_{\mathrm{alg}[S]} K$), and every $x$ in the $n$-torsion submodule `Submodule.torsionBy ℤ
+(W'⁄K).Point n` of the point group of the base change of $W'$ to $K$, one has $\sigma \bullet x =
+x$. The action $\sigma \bullet x$ of automorphisms on points is the one supplied by the project's
+Galois-representation module. Thus the predicate is the triviality of inertia on $n$-torsion, stated
+place by place rather than through a representation object.
+
+Finally, [`FreyPackage.GaloisRepUnramifiedAt P q`](../def/FLTPrelim_Ramification.html#L46) is this
+predicate for $R = S = \mathbb{Q}$, $K = \overline{\mathbb{Q}}$, the curve `P.freyCurve` and $n =
+P.p$: the mod-$p$ representation on $\overline{\mathbb{Q}}$-points of the Frey curve killed by $p$
+is unramified at $q$.
+
+**Relation to Mathlib.** [`ValuationSubring.LiesOverPrime`](../def/FLTPrelim_Ramification.html#L16)
+and [`ValuationSubring.inertiaSubgroupIn`](../def/FLTPrelim_Ramification.html#L21) are thin wrappers
+around Mathlib's valuation-subring API (`nonunits`, `inertiaSubgroup`, `decompositionSubgroup`), the
+latter only transporting Mathlib's inertia subgroup along the inclusion of the decomposition
+subgroup. The unramifiedness predicates for torsion points of a Weierstrass curve are the project's
+own; Mathlib has no such notion.
+
+**Where it is used.** These predicates express the local conditions on the mod-$p$ representation
+attached to a Frey package at primes $q$ not dividing the relevant level, which are what the
+Serre-type level-lowering and irreducibility arguments consume. The Frey-package instance is the
+form in which the unramifiedness of $E[p]$ outside the primes of bad reduction and $p$ enters the
+main line of the argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+universe u
+
+namespace ValuationSubring
+
+variable {L : Type u} [Field L]
+
+def LiesOverPrime (A : ValuationSubring L) (q : ℕ) : Prop :=
+  (q : L) ∈ A.nonunits
+
+variable (K : Type*) [Field K] [Algebra K L]
+
+def inertiaSubgroupIn (A : ValuationSubring L) : Subgroup (L ≃ₐ[K] L) :=
+  (A.inertiaSubgroup K).map (A.decompositionSubgroup K).subtype
+
+end ValuationSubring
+
+namespace WeierstrassCurve.Affine.Point
+
+open WeierstrassCurve
+
+variable {R : Type*} {S : Type*} {K : Type*} [CommRing R] [Field S] [Field K]
+  [DecidableEq K] [Algebra R S] [Algebra R K] [Algebra S K] [IsScalarTower R S K]
+
+variable (S K) in
+def GaloisRepUnramifiedAt (W' : Affine R) (n : ℕ) (q : ℕ) : Prop :=
+  ∀ A : ValuationSubring K, A.LiesOverPrime q →
+    ∀ σ ∈ A.inertiaSubgroupIn S,
+    ∀ x : Submodule.torsionBy ℤ (W'⁄K).Point n, σ • x = x
+
+end WeierstrassCurve.Affine.Point
+
+namespace FreyPackage
+
+open WeierstrassCurve.Affine.Point
+
+def GaloisRepUnramifiedAt (P : FreyPackage) (q : ℕ) : Prop :=
+  WeierstrassCurve.Affine.Point.GaloisRepUnramifiedAt (K := AlgebraicClosure ℚ) ℚ
+    P.freyCurve P.p q
+
+end FreyPackage
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_FieldTheory_RatAlgClosureGalois.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_FieldTheory_RatAlgClosureGalois.lean
new file mode 100644
index 0000000000..e8896f7b67
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_FieldTheory_RatAlgClosureGalois.lean
@@ -0,0 +1,61 @@
+/-
+Based on Prove2Me node FieldTheory_RatAlgClosureGalois
+(16da4bf0-16d1-56c6-b699-270c473bdfc2) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Algebra.Rat
+public import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure
+public import Mathlib.FieldTheory.Galois.Basic
+
+/-!
+# Galois instance for Q​ with the rational algebra structure
+
+Definition: `FieldTheory_RatAlgClosureGalois` (`16da4bf0-16d1-56c6-b699-270c473bdfc2`), by Claude,
+2026-09-05.
+
+This module contains a single instance declaration and no new mathematical notion. The field
+$\overline{\mathbb{Q}}$, realised as `AlgebraicClosure ℚ`, admits two $\mathbb{Q}$-algebra
+structures that are definitionally equal but syntactically distinct: `AlgebraicClosure.instAlgebra
+ℚ`, under which Mathlib records that the extension is Galois, and `DivisionRing.toRatAlgebra`, the
+canonical $\mathbb{Q}$-algebra structure carried by every division ring of characteristic zero. The
+declaration [`AlgebraicClosure.Rat.isGalois`](../def/FieldTheory_RatAlgClosureGalois.html#L5)
+asserts `IsGalois ℚ (AlgebraicClosure ℚ)` with the algebra argument pinned explicitly, using `@`, to
+`DivisionRing.toRatAlgebra`; that is, the extension $\mathbb{Q} \subseteq \overline{\mathbb{Q}}$,
+viewed through that second structure, is normal and separable in Mathlib's sense. Mathematically
+this is just the statement that an algebraic closure of a field of characteristic zero is a Galois
+extension of it; the content of the module is entirely that the statement is available with the
+algebra slot filled by the canonical $\mathbb{Q}$-algebra structure that Mathlib attaches to every
+characteristic-zero division ring (`Mathlib.Algebra.Algebra.Rat`). The proof is Mathlib's
+`IsAlgClosure.isGalois` applied with the other, `AlgebraicClosure.instAlgebra ℚ`, structure, the two
+being interchangeable by definitional unfolding. Once this instance is in scope, the derived facts
+keyed on `IsGalois` — normality, separability, the fixed-field correspondence, and (with the
+profinite material) the compactness, Hausdorffness and total disconnectedness of the
+Krull-topologised automorphism group `AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ` — are usable with
+either of the two $\mathbb{Q}$-algebra structures.
+
+**Relation to Mathlib.** Nothing here is new mathematics relative to Mathlib: the instance is
+Mathlib's `IsAlgClosure.isGalois` for $\mathbb{Q}$, restated with the $\mathbb{Q}$-algebra structure
+on `AlgebraicClosure ℚ` fixed to `DivisionRing.toRatAlgebra` rather than to
+`AlgebraicClosure.instAlgebra ℚ`.
+
+**Where it is used.** It sits at the bottom of the Galois-theoretic vocabulary of the development:
+the modules that speak of $G_{\mathbb{Q}} = \mathrm{Gal}(\overline{\mathbb{Q}}/\mathbb{Q})$, its
+profinite topology and its representations rely on this instance to obtain the Galois package on
+$\overline{\mathbb{Q}}$, and it is imported rather than re-declared by them.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+public section publicSection
+
+
+instance AlgebraicClosure.Rat.isGalois :
+    @IsGalois ℚ _ (AlgebraicClosure ℚ) _ DivisionRing.toRatAlgebra :=
+  @IsAlgClosure.isGalois ℚ (AlgebraicClosure ℚ) _ _ (AlgebraicClosure.instAlgebra ℚ) _ _
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_FreyPackage_GaloisRep.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_FreyPackage_GaloisRep.lean
new file mode 100644
index 0000000000..691c16703d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_FreyPackage_GaloisRep.lean
@@ -0,0 +1,98 @@
+/-
+Based on Prove2Me node FreyPackage_GaloisRep
+(b43ec0e4-4198-5de6-a26c-11717d13cd92) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_FreyPackage
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_GaloisRep
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusTrace
+public import Mathlib.LinearAlgebra.FiniteDimensional.Defs
+
+/-!
+# Mod-n Galois representation of a Weierstrass curve; Frey case
+
+Definition: `FreyPackage_GaloisRep` (`b43ec0e4-4198-5de6-a26c-11717d13cd92`), by Claude, 2026-09-05.
+
+For a Weierstrass curve `W'` in affine form over a commutative ring $R$, a commutative $R$-algebra
+$S$ and a field $K$ that is an $S$-algebra with $R \to S \to K$ a scalar tower (plus a `DecidableEq
+K` instance), [`WeierstrassCurve.Affine.Point.galoisRep W'
+n`](../def/FreyPackage_GaloisRep.html#L18) is the mod-$n$ representation attached to the $n$-torsion
+of the points of the base change $W'\!\mathord{⁄}K$. Concretely, the group $K
+\simeq_{\mathrm{alg}[S]} K$ of $S$-algebra automorphisms of $K$ acts on $(W'⁄K).\mathrm{Point}$ by
+transport of coordinates along $\sigma$ (the project's `Point.map` action), this action preserves
+the $\mathbb{Z}$-torsion submodule $\mathrm{torsionBy}\ \mathbb{Z}\ (W'⁄K).\mathrm{Point}\ n = \{P :
+nP = 0\}$, and that submodule carries a $\mathbb{Z}/n$-module structure because $n$ annihilates it.
+The definition is then obtained by applying Mathlib's `DistribMulAction.toModuleAut`, so `galoisRep
+W' n` is a monoid homomorphism from $K \simeq_{\mathrm{alg}[S]} K$ to the group of
+$\mathbb{Z}/n$-linear automorphisms of the $n$-torsion, and `galoisRep_apply` records that its value
+at $\sigma$ is the map $P \mapsto \sigma \bullet P$. Nothing is asserted here about freeness of the
+$n$-torsion or finite-dimensionality, so the representation is not presented as a map into
+$\mathrm{GL}_2(\mathbb{Z}/n)$; it is the abstract automorphism-group form.
+
+[`FreyPackage.freyGaloisRep P`](../def/FreyPackage_GaloisRep.html#L38) is the specialisation to a
+Frey package $P = (a,b,c,p)$: taking $R = S = \mathbb{Q}$, $K = \overline{\mathbb{Q}}$ (an algebraic
+closure of $\mathbb{Q}$, given a classical decidable-equality instance), `W'` the Frey curve $y^2 +
+xy = x^3 + \frac{b^p-1-a^p}{4}x^2 - \frac{a^pb^p}{16}x$ attached to $P$, and $n = p$, it is the
+monoid homomorphism from $\mathrm{Gal}(\overline{\mathbb{Q}}/\mathbb{Q})$ to the
+$\mathbb{Z}/p$-linear automorphisms of the $p$-torsion of the Frey curve over
+$\overline{\mathbb{Q}}$.
+
+**Relation to Mathlib.** Mathlib supplies the generic construction `DistribMulAction.toModuleAut`
+and the Weierstrass-curve point groups; the Galois action on points and on the $n$-torsion, and
+hence this mod-$n$ representation of an elliptic curve, are the project's own.
+
+**Where it is used.** This is the object denoted $\bar\rho_{E,p}$ for the Frey curve: the
+representation whose irreducibility and ramification behaviour are the subject of the
+Frey–Serre–Ribet part of the argument, and which the project's predicates `GaloisRepIsIrreducible`
+and `GaloisRepUnramifiedAt` describe in terms of the same action.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+universe r s v
+
+namespace WeierstrassCurve.Affine.Point
+
+open WeierstrassCurve
+
+variable {R : Type r} {S : Type s} {K : Type v} [CommRing R] [CommRing S] [Field K]
+  [DecidableEq K] {W' : Affine R} [Algebra R S] [Algebra R K] [Algebra S K]
+  [IsScalarTower R S K]
+
+noncomputable def galoisRep (W' : Affine R) (n : ℕ) :
+    (K ≃ₐ[S] K) →*
+      (Submodule.torsionBy ℤ (W'⁄K).Point n) ≃ₗ[ZMod n] (Submodule.torsionBy ℤ (W'⁄K).Point n) :=
+  DistribMulAction.toModuleAut (ZMod n) (Submodule.torsionBy ℤ (W'⁄K).Point n)
+
+@[simp]
+lemma galoisRep_apply {n : ℕ} (σ : K ≃ₐ[S] K) (P : Submodule.torsionBy ℤ (W'⁄K).Point n) :
+    galoisRep W' n σ P = σ • P :=
+  rfl
+
+end WeierstrassCurve.Affine.Point
+
+namespace FreyPackage
+
+open WeierstrassCurve.Affine.Point
+open scoped WeierstrassCurve.Affine
+
+noncomputable local instance instDecEqQbarRepresentation : DecidableEq (AlgebraicClosure ℚ) :=
+  Classical.decEq _
+
+noncomputable def freyGaloisRep (P : FreyPackage) :
+    (AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) →*
+      (Submodule.torsionBy ℤ (P.freyCurve⁄(AlgebraicClosure ℚ)).Point P.p) ≃ₗ[ZMod P.p]
+        (Submodule.torsionBy ℤ (P.freyCurve⁄(AlgebraicClosure ℚ)).Point P.p) :=
+  galoisRep P.freyCurve P.p
+
+end FreyPackage
+
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_FreyPackage_ModMCarrier_Rescale.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_FreyPackage_ModMCarrier_Rescale.lean
new file mode 100644
index 0000000000..50b34abc88
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_FreyPackage_ModMCarrier_Rescale.lean
@@ -0,0 +1,238 @@
+/-
+Based on Prove2Me node FreyPackage_ModMCarrier_Rescale
+(5a5580ba-bc45-5d78-87e6-3b66d0c19953) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_AtkinLehnerDatum
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+/-!
+# The rescaling degeneracy map Vd​ on cusp forms
+
+Definition: `FreyPackage_ModMCarrier_Rescale` (`5a5580ba-bc45-5d78-87e6-3b66d0c19953`), by Claude,
+2026-09-05.
+
+Fix natural numbers $R$, $M$, $d$. The module introduces `diagMatInt d`, the integral matrix
+$\begin{pmatrix} d & 0 \\ 0 & 1\end{pmatrix}$, and `heckeDiagMatrixQ`, its rational avatar in
+$\mathrm{GL}_2(\mathbb{Q})$ for $d \neq 0$, whose entrywise image under $\mathbb{Q} \to \mathbb{R}$
+is the matrix `heckeDiagMatrix d` of $\mathrm{GL}_2(\mathbb{R})$ already used to define the Hecke
+operators. The conjugation lemma `exists_cocycle_rescale` states that if $dR \mid M$ and $\gamma \in
+\Gamma_0(M)$, then there is $\delta \in \Gamma_0(R)$ with $\mathrm{diag}(d,1)\,\gamma =
+\delta\,\mathrm{diag}(d,1)$; explicitly, for $\gamma = \begin{pmatrix} a & b \\ c & e\end{pmatrix}$
+with $c = dRc'$ one takes $\delta = \begin{pmatrix} a & db \\ Rc' & e\end{pmatrix}$, of determinant
+$1$ and lower-left entry divisible by $R$. From this, `rescaleSlash_slash` deduces that for $M \neq
+0$, $dR \mid M$ and $f : \mathbb{H} \to \mathbb{C}$ invariant under the weight-$k$ slash action of
+the image of $\Gamma_0(R)$ in $\mathrm{GL}_2(\mathbb{R})$, the function $f \mid_k
+\mathrm{diag}(d,1)$ is invariant under the image of $\Gamma_0(M)$; and `rescaleSlash_isZeroAt` shows
+that if $f$ is zero at every cusp of $\Gamma_0(R)$ then $f \mid_k \mathrm{diag}(d,1)$ is zero at
+every cusp of $\Gamma_0(M)$, the cusp condition being transported because $\mathrm{diag}(d,1)$ is
+rational and hence carries $\mathrm{SL}_2(\mathbb{Z})$-cusps to $\mathrm{SL}_2(\mathbb{Z})$-cusps.
+
+These three facts, together with holomorphy of a slashed holomorphic function, supply the
+invariance, holomorphy and cusp-vanishing fields of `rescaleLin hdRM k`, the $\mathbb{C}$-linear map
+$\mathrm{CuspForm}(\Gamma_0(R), k) \to \mathrm{CuspForm}(\Gamma_0(M), k)$ sending $f$ to the
+function $f \mid_k \mathrm{heckeDiagMatrix}\ d$, i.e. $\tau \mapsto d^{k-1} f(d\tau)$ in the
+determinant-normalised slash action; `coe_rescaleLin_apply` records this formula for the underlying
+function. Finally, for an Atkin–Lehner datum $W$ at $(M, q')$, which carries the equation $M = q'
+\cdot W.R$ as a field, `q_mul_R_dvd` gives $q' \cdot W.R \mid M$ and `rescaleLinAL W k` is the
+resulting map $\mathrm{CuspForm}(\Gamma_0(W.R), k) \to \mathrm{CuspForm}(\Gamma_0(M), k)$.
+
+**Relation to Mathlib.** Mathlib provides the weight-$k$ slash action on functions on $\mathbb{H}$,
+the spaces `CuspForm` for arithmetic subgroups of $\mathrm{GL}_2(\mathbb{R})$ and the cusp
+predicates used here; the degeneracy map $V_d$ between levels, and the diagonal matrix
+`heckeDiagMatrix` it is built from, are the project's own.
+
+**Where it is used.** The map $V_{q'}$ attached to an Atkin–Lehner datum is one of the two
+degeneracy maps $S_k(\Gamma_0(R)) \to S_k(\Gamma_0(q'R))$, the other being the level inclusion; the
+pair is the source of the level-raising argument, where joint injectivity modulo a maximal ideal of
+the Hecke algebra is Ihara's lemma.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+open Matrix UpperHalfPlane CongruenceSubgroup ModularForm OnePoint
+open scoped MatrixGroups ModularForm Manifold
+
+namespace FreyPackage.ModMCarrier
+
+section Cocycle
+variable {R M d : ℕ}
+
+def diagMatInt (d : ℕ) : Matrix (Fin 2) (Fin 2) ℤ := !![(d : ℤ), 0; 0, 1]
+
+lemma exists_cocycle_rescale (hdRM : d * R ∣ M) {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 M) :
+    ∃ δ : SL(2, ℤ), δ ∈ Gamma0 R ∧
+      diagMatInt d * (γ : Matrix (Fin 2) (Fin 2) ℤ)
+        = (δ : Matrix (Fin 2) (Fin 2) ℤ) * diagMatInt d := by
+  have hdet : (γ : Matrix (Fin 2) (Fin 2) ℤ) 0 0 * (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 1 -
+      (γ : Matrix (Fin 2) (Fin 2) ℤ) 0 1 * (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 0 = 1 := by
+    have := γ.det_coe; rwa [Matrix.det_fin_two] at this
+  have hMc : (M : ℤ) ∣ (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 0 := by
+    have := Gamma0_mem.mp hγ; rwa [← ZMod.intCast_zmod_eq_zero_iff_dvd]
+  set a : ℤ := (γ : Matrix (Fin 2) (Fin 2) ℤ) 0 0 with ha
+  set b : ℤ := (γ : Matrix (Fin 2) (Fin 2) ℤ) 0 1 with hb
+  set c : ℤ := (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 0 with hc
+  set e : ℤ := (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 1 with he
+  have hγmat : (γ : Matrix (Fin 2) (Fin 2) ℤ) = !![a, b; c, e] := by
+    rw [ha, hb, hc, he]; exact Matrix.eta_fin_two _
+  have hdRMc : ((d * R : ℕ) : ℤ) ∣ c := dvd_trans (by exact_mod_cast hdRM) hMc
+  obtain ⟨c', hc'⟩ := hdRMc
+  rw [Nat.cast_mul] at hc'
+  have hdetδ : Matrix.det !![a, (d : ℤ) * b; (R : ℤ) * c', e] = 1 := by
+    rw [Matrix.det_fin_two_of]; linear_combination hdet + b * hc'
+  refine ⟨⟨_, hdetδ⟩, Gamma0_mem.mpr ?_, ?_⟩
+  · change ((R * c' : ℤ) : ZMod R) = 0
+    push_cast; rw [ZMod.natCast_self, zero_mul]
+  · change diagMatInt d * (γ : Matrix (Fin 2) (Fin 2) ℤ)
+      = !![a, (d : ℤ) * b; (R : ℤ) * c', e] * diagMatInt d
+    rw [hγmat]; unfold diagMatInt
+    rw [Matrix.mul_fin_two, Matrix.mul_fin_two]
+    refine Matrix.ext fun i j => ?_
+    fin_cases i <;> fin_cases j
+    · change ((d : ℤ) * a + 0 * c : ℤ) = a * (d : ℤ) + (d : ℤ) * b * 0; ring
+    · change ((d : ℤ) * b + 0 * e : ℤ) = a * 0 + (d : ℤ) * b * 1; ring
+    · change (0 * a + 1 * c : ℤ) = (R : ℤ) * c' * (d : ℤ) + e * 0; linear_combination hc'
+    · change (0 * b + 1 * e : ℤ) = (R : ℤ) * c' * 0 + e * 1; ring
+
+private lemma mapGL_coe_eq (s : SL(2, ℤ)) :
+    ((Matrix.SpecialLinearGroup.mapGL ℝ s : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ)
+      = (s : Matrix (Fin 2) (Fin 2) ℤ).map (algebraMap ℤ ℝ) := rfl
+
+private lemma map_int_mul_eq (A B : Matrix (Fin 2) (Fin 2) ℤ) :
+    (A * B).map (algebraMap ℤ ℝ) = A.map (algebraMap ℤ ℝ) * B.map (algebraMap ℤ ℝ) := by
+  rw [← RingHom.mapMatrix_apply, ← RingHom.mapMatrix_apply, ← RingHom.mapMatrix_apply, map_mul]
+
+lemma diagMatInt_map_eq (hd : d ≠ 0) :
+    (diagMatInt d).map (algebraMap ℤ ℝ)
+      = ((heckeDiagMatrix d : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) := by
+  rw [val_heckeDiagMatrix hd]; unfold diagMatInt
+  ext i j; fin_cases i <;> fin_cases j <;> simp
+
+lemma rescaleSlash_slash [NeZero M] (hdRM : d * R ∣ M) (k : ℤ) {f : ℍ → ℂ}
+    (hf : ∀ γ ∈ ((Gamma0 R : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)), f ∣[k] γ = f)
+    {γ : GL (Fin 2) ℝ}
+    (hγ : γ ∈ ((Gamma0 M : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ))) :
+    (f ∣[k] heckeDiagMatrix d) ∣[k] γ = f ∣[k] heckeDiagMatrix d := by
+  have hd : d ≠ 0 := by
+    rintro rfl; exact NeZero.ne M (Nat.eq_zero_of_zero_dvd ((zero_mul R ▸ hdRM)))
+  obtain ⟨g, hg, rfl⟩ := Subgroup.mem_map.mp hγ
+  obtain ⟨δ, hδ, hconj⟩ := exists_cocycle_rescale hdRM hg
+  have hGL : heckeDiagMatrix d * Matrix.SpecialLinearGroup.mapGL ℝ g
+      = Matrix.SpecialLinearGroup.mapGL ℝ δ * heckeDiagMatrix d := by
+    apply Units.ext
+    rw [Units.val_mul, Units.val_mul]
+    change (heckeDiagMatrix d : Matrix (Fin 2) (Fin 2) ℝ) *
+        ((Matrix.SpecialLinearGroup.mapGL ℝ g : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ)
+      = ((Matrix.SpecialLinearGroup.mapGL ℝ δ : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) *
+        (heckeDiagMatrix d : Matrix (Fin 2) (Fin 2) ℝ)
+    rw [← diagMatInt_map_eq hd, mapGL_coe_eq, mapGL_coe_eq, ← map_int_mul_eq, ← map_int_mul_eq,
+      hconj]
+  calc (f ∣[k] heckeDiagMatrix d) ∣[k] Matrix.SpecialLinearGroup.mapGL ℝ g
+      = f ∣[k] (heckeDiagMatrix d * Matrix.SpecialLinearGroup.mapGL ℝ g) :=
+        (SlashAction.slash_mul k _ _ f).symm
+    _ = f ∣[k] (Matrix.SpecialLinearGroup.mapGL ℝ δ * heckeDiagMatrix d) := by rw [hGL]
+    _ = (f ∣[k] Matrix.SpecialLinearGroup.mapGL ℝ δ) ∣[k] heckeDiagMatrix d :=
+        SlashAction.slash_mul k _ _ f
+    _ = f ∣[k] heckeDiagMatrix d := by
+        rw [hf (Matrix.SpecialLinearGroup.mapGL ℝ δ) (Subgroup.mem_map.mpr ⟨δ, hδ, rfl⟩)]
+
+end Cocycle
+
+section Cusps
+variable {R M d : ℕ}
+
+def heckeDiagMatrixQ (hd : d ≠ 0) : GL (Fin 2) ℚ :=
+  Matrix.GeneralLinearGroup.mkOfDetNeZero !![(d : ℚ), 0; 0, 1]
+    (by
+      rw [Matrix.det_fin_two_of]; simp only [mul_one, mul_zero, sub_zero, ne_eq, Nat.cast_eq_zero];
+        exact_mod_cast hd)
+
+lemma heckeDiagMatrixQ_map (hd : d ≠ 0) :
+    (heckeDiagMatrixQ hd).map (Rat.castHom ℝ) = heckeDiagMatrix d := by
+  apply Units.ext
+  rw [val_heckeDiagMatrix hd]
+  change (heckeDiagMatrixQ hd : Matrix (Fin 2) (Fin 2) ℚ).map (Rat.castHom ℝ) = _
+  unfold heckeDiagMatrixQ
+  ext i j; fin_cases i <;> fin_cases j <;> simp
+
+private lemma isCusp_smul_of_rat {c : OnePoint ℝ} (hc : IsCusp c 𝒮ℒ) {g : GL (Fin 2) ℝ}
+    (gQ : GL (Fin 2) ℚ) (hg : gQ.map (Rat.castHom ℝ) = g) : IsCusp (g • c) 𝒮ℒ := by
+  subst hg
+  rw [isCusp_SL2Z_iff] at hc ⊢
+  obtain ⟨c₀, rfl⟩ := hc
+  exact ⟨gQ • c₀, by rw [← Rat.coe_castHom, OnePoint.map_smul]⟩
+
+lemma rescaleSlash_isZeroAt [NeZero M] [NeZero R] (hd : d ≠ 0) (k : ℤ) {f : ℍ → ℂ}
+    (hf : ∀ c' : OnePoint ℝ,
+      IsCusp c' ((Gamma0 R : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) →
+      IsZeroAt c' f k)
+    {c : OnePoint ℝ}
+    (hc : IsCusp c ((Gamma0 M : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ))) :
+    IsZeroAt c (f ∣[k] heckeDiagMatrix d) k := by
+  refine IsZeroAt.smul_iff.mp (hf _ ?_)
+  rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z] at hc ⊢
+  exact isCusp_smul_of_rat hc (heckeDiagMatrixQ hd) (heckeDiagMatrixQ_map hd)
+
+end Cusps
+
+section Rescale
+variable {R M d : ℕ} [NeZero M]
+
+private lemma aux_neZero_d (hdRM : d * R ∣ M) : d ≠ 0 := by
+  rintro rfl; exact NeZero.ne M (Nat.eq_zero_of_zero_dvd (zero_mul R ▸ hdRM))
+
+private lemma aux_neZero_R (hdRM : d * R ∣ M) : NeZero R :=
+  ⟨by rintro rfl; exact NeZero.ne M (Nat.eq_zero_of_zero_dvd (mul_zero d ▸ hdRM))⟩
+
+def rescaleLin (hdRM : d * R ∣ M) (k : ℤ) :
+    CuspForm (Gamma0 R) k →ₗ[ℂ] CuspForm (Gamma0 M) k where
+  toFun f :=
+    haveI : NeZero R := by exact aux_neZero_R hdRM
+    { toFun := ⇑f ∣[k] heckeDiagMatrix d
+      slash_action_eq' := fun γ hγ => rescaleSlash_slash hdRM k
+        (fun γ hγ => SlashInvariantFormClass.slash_action_eq f γ hγ) hγ
+      holo' := (CuspFormClass.holo f).slash k (heckeDiagMatrix d)
+      zero_at_cusps' := fun {c} hc => rescaleSlash_isZeroAt (by exact aux_neZero_d hdRM) k
+        (fun c' hc' => CuspFormClass.zero_at_cusps f hc') hc }
+  map_add' f g := DFunLike.coe_injective <| by
+    change (⇑(f + g)) ∣[k] heckeDiagMatrix d
+      = (⇑f ∣[k] heckeDiagMatrix d) + (⇑g ∣[k] heckeDiagMatrix d)
+    rw [FunLike.coe_add, SlashAction.add_slash]
+  map_smul' c f := DFunLike.coe_injective <| by
+    change (⇑(c • f)) ∣[k] heckeDiagMatrix d = c • (⇑f ∣[k] heckeDiagMatrix d)
+    rw [FunLike.coe_smul]
+    simp only [ModularForm.smul_slash, σ_heckeDiagMatrix, ContinuousAlgEquiv.refl_apply]
+
+@[simp] lemma coe_rescaleLin_apply (hdRM : d * R ∣ M) (k : ℤ) (f : CuspForm (Gamma0 R) k) :
+    ⇑(rescaleLin hdRM k f) = ⇑f ∣[k] heckeDiagMatrix d := rfl
+
+end Rescale
+
+section AtkinLehnerSpecialization
+variable {M q' : ℕ} [NeZero M] (W : ModularForm.AtkinLehnerDatum M q')
+
+omit [NeZero M] in
+lemma _root_.ModularForm.AtkinLehnerDatum.q_mul_R_dvd : q' * W.R ∣ M :=
+  ⟨1, W.hM.trans (mul_one (q' * W.R)).symm⟩
+
+abbrev rescaleLinAL (k : ℤ) :
+    CuspForm (Gamma0 W.R) k →ₗ[ℂ] CuspForm (Gamma0 M) k :=
+  rescaleLin W.q_mul_R_dvd k
+
+end AtkinLehnerSpecialization
+
+end FreyPackage.ModMCarrier
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_GaloisRep_Adic.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_GaloisRep_Adic.lean
new file mode 100644
index 0000000000..5c255b90f0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_GaloisRep_Adic.lean
@@ -0,0 +1,266 @@
+/-
+Based on Prove2Me node GaloisRep_Adic
+(4658c4b2-4079-5082-a13b-6de985889cee) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.LinearAlgebra.Charpoly.BaseChange
+public import Mathlib.LinearAlgebra.Trace
+public import Mathlib.RingTheory.LocalRing.ResidueField.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_GaloisRep_Residual
+public import LeanPool.FLTEichlerShimura.Definitions.Def_GaloisRep_ResidualEquiv
+
+/-!
+# Rank-two Galois representations over a local coefficient ring
+
+Definition: `GaloisRep_Adic` (`4658c4b2-4079-5082-a13b-6de985889cee`), by Claude, 2026-09-05.
+
+Fix a commutative local ring $A$ with maximal ideal $\mathfrak m$. [`GaloisActionIsAdicContinuous A
+ρ`](../def/GaloisRep_Adic.html#L9), for a monoid homomorphism $\rho$ from
+$\mathrm{Gal}(\overline{\mathbb Q}/\mathbb Q)$ (realised as $\overline{\mathbb Q}\simeq_{\mathbb
+Q}\overline{\mathbb Q}$, with $\overline{\mathbb Q}=$ `AlgebraicClosure ℚ`) to $\mathrm{End}_A(V)$,
+asserts: for every $n$ there is an intermediate field $L$ of $\overline{\mathbb Q}/\mathbb Q$,
+finite-dimensional over $\mathbb Q$, such that every $\sigma$ fixing $L$ pointwise satisfies
+$\rho(\sigma)v-v\in\mathfrak m^n\cdot V$ for all $v$. No topology on $A$, on $V$ or on the Galois
+group is used; this is the project's own substitute for continuity. A [`GaloisRepAdic
+A`](../def/GaloisRep_Adic.html#L16) then bundles a type $V$ with an $A$-module structure that is
+free and finite, the equation $\operatorname{finrank}_A V=2$, a monoid homomorphism $\rho$ into
+$\mathrm{End}_A(V)$, and the above condition as a field.
+
+For $\rho :$ [`GaloisRepAdic A`](../def/GaloisRep_Adic.html#L16): `IsUnramifiedAt ρ q` says that for
+every valuation subring $P$ of $\overline{\mathbb Q}$ lying over the prime $q$ (predicate
+`LiesOverPrime`, from an imported module), every element of `P.inertiaSubgroupIn ℚ` acts as the
+identity; `det ρ` is the character $\mathrm{Gal}\to A^\times$ obtained from
+$\sigma\mapsto\det(\rho(\sigma))$ via `toHomUnits`, and `trace ρ σ` is
+$\operatorname{tr}_A(\rho(\sigma))$. `baseChangeAlong φ hφ` transports $\rho$ along an explicit ring
+homomorphism $\varphi:A\to B$ of local rings that is assumed local, with carrier $B\otimes_A V$ and
+$\rho(\sigma)$ replaced by its base change; `residual ρ` is the representation on $\kappa\otimes_A
+V$, $\kappa$ the residue field of $A$, as a
+[`ResidualGaloisRep`](../def/GaloisRep_Residual.html#L22), its finite-level field being deduced from
+adic continuity for $n=1$.
+
+Equivalence is data: `Equiv ρ₁ ρ₂` consists of an $A$-linear isomorphism $e:V_1\to V_2$ together
+with the intertwining identity $e(\rho_1(\sigma)x)=\rho_2(\sigma)(e(x))$ for all $\sigma,x$;
+`IsEquiv` is its `Nonempty`. Helper declarations give reflexivity, symmetry, transitivity,
+compatibility of `Equiv` with base change and with passage to the residual representation, and, when
+the coefficients form a field $k$, mutually inverse passages between [`GaloisRepAdic
+k`](../def/GaloisRep_Adic.html#L16) and [`ResidualGaloisRep k`](../def/GaloisRep_Residual.html#L22)
+on the same carrier.
+
+**Relation to Mathlib.** Mathlib has no notion of a Galois representation; the structures and the
+adic-continuity predicate are the project's own, built on Mathlib's `Module.Free`/`Module.Finite`,
+`Module.finrank`, `LinearMap.det`/`LinearMap.trace`, tensor-product base change,
+`IsLocalRing.ResidueField` and
+[`ValuationSubring.inertiaSubgroupIn`](../def/FLTPrelim_Ramification.html#L21). Change of
+coefficients is always along an explicit `φ : A →+* B` with an explicit `IsLocalHom φ` argument,
+never an ambient `Algebra A B` instance.
+
+**Where it is used.** These are the coefficient-ring-valued two-dimensional representations used
+throughout the lifting argument: representations with values in a localised Hecke algebra, universal
+deformations of a residual representation, and Tate modules of elliptic curves over $p$-adic rings.
+The module supplies the currency (unramifiedness, trace and determinant, base change, reduction to
+the residue field, and equivalence) on which the deformation-theoretic and Hecke-algebra modules
+that import it are phrased.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open scoped TensorProduct
+
+def GaloisActionIsAdicContinuous (A : Type) [CommRing A] [IsLocalRing A]
+    {V : Type} [AddCommGroup V] [Module A V]
+    (ρ : (AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) →* Module.End A V) : Prop :=
+  ∀ n : ℕ, ∃ L : IntermediateField ℚ (AlgebraicClosure ℚ), FiniteDimensional ℚ L ∧
+    ∀ σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ, (∀ x ∈ L, σ x = x) →
+      ∀ v : V, ρ σ v - v ∈ (IsLocalRing.maximalIdeal A ^ n) • (⊤ : Submodule A V)
+
+structure GaloisRepAdic (A : Type) [CommRing A] [IsLocalRing A] : Type 1 where
+  V : Type
+  [instAddCommGroup : AddCommGroup V]
+  [instModule : Module A V]
+  [instFree : Module.Free A V]
+  [instFinite : Module.Finite A V]
+  finrank_eq : Module.finrank A V = 2
+  ρ : (AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) →* Module.End A V
+  isAdicContinuous : GaloisActionIsAdicContinuous A ρ
+
+attribute [instance] GaloisRepAdic.instAddCommGroup GaloisRepAdic.instModule
+  GaloisRepAdic.instFree GaloisRepAdic.instFinite
+
+namespace GaloisRepAdic
+
+variable {A : Type} [CommRing A] [IsLocalRing A]
+
+def IsUnramifiedAt (ρ : GaloisRepAdic A) (q : ℕ) : Prop :=
+  ∀ P : ValuationSubring (AlgebraicClosure ℚ), P.LiesOverPrime q →
+    ∀ σ ∈ P.inertiaSubgroupIn ℚ, ρ.ρ σ = 1
+
+noncomputable def det (ρ : GaloisRepAdic A) : (AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) →* Aˣ :=
+  (LinearMap.det.comp ρ.ρ).toHomUnits
+
+noncomputable def trace (ρ : GaloisRepAdic A) (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) :
+    A :=
+  LinearMap.trace A ρ.V (ρ.ρ σ)
+
+noncomputable def baseChangeAlong {B : Type} [CommRing B] [IsLocalRing B] (φ : A →+* B)
+    (hφ : IsLocalHom φ) (ρ : GaloisRepAdic A) : GaloisRepAdic B :=
+  letI : Algebra A B := φ.toAlgebra
+  { V := B ⊗[A] ρ.V
+    finrank_eq := by rw [Module.finrank_baseChange, ρ.finrank_eq]
+    ρ := { toFun := fun σ => (ρ.ρ σ).baseChange B
+           map_one' := by rw [map_one, LinearMap.baseChange_one]
+           map_mul' := fun σ τ => by rw [map_mul, LinearMap.baseChange_mul] }
+    isAdicContinuous := by
+      intro n
+      obtain ⟨L, hL, h1⟩ := ρ.isAdicContinuous n
+      refine ⟨L, hL, fun σ hσ => ?_⟩
+      have hmap : (IsLocalRing.maximalIdeal A ^ n).map φ ≤ IsLocalRing.maximalIdeal B ^ n := by
+        rw [Ideal.map_pow]
+        exact Ideal.pow_right_mono (Ideal.map_le_iff_le_comap.mpr fun a ha =>
+          Ideal.mem_comap.mpr (haveI := hφ; map_nonunit φ a ha)) n
+      have hpure : ∀ (b : B) (v : ρ.V),
+          (ρ.ρ σ).baseChange B (b ⊗ₜ[A] v) - b ⊗ₜ[A] v ∈
+            (IsLocalRing.maximalIdeal B ^ n) • (⊤ : Submodule B (B ⊗[A] ρ.V)) := by
+        intro b v
+        rw [LinearMap.baseChange_tmul, ← TensorProduct.tmul_sub]
+        refine Submodule.smul_induction_on (p := fun x => b ⊗ₜ[A] x ∈
+          (IsLocalRing.maximalIdeal B ^ n) • (⊤ : Submodule B (B ⊗[A] ρ.V))) (h1 σ hσ v) ?_ ?_
+        · intro a ha w _
+          rw [TensorProduct.tmul_smul, TensorProduct.smul_tmul', Algebra.smul_def, ← smul_eq_mul,
+            ← TensorProduct.smul_tmul']
+          exact Submodule.smul_mem_smul (hmap (Ideal.mem_map_of_mem φ ha)) Submodule.mem_top
+        · intro x y hx hy
+          rw [TensorProduct.tmul_add]
+          exact Submodule.add_mem _ hx hy
+      intro w
+      induction w using TensorProduct.inductionOn with
+      | tmul b v => exact hpure b v
+      | add x y hx hy =>
+        rw [map_add, add_sub_add_comm]
+        exact Submodule.add_mem _ hx hy }
+
+noncomputable def residual (ρ : GaloisRepAdic A) :
+    ResidualGaloisRep (IsLocalRing.ResidueField A) :=
+  { V := IsLocalRing.ResidueField A ⊗[A] ρ.V
+    finrank_eq := by rw [Module.finrank_baseChange, ρ.finrank_eq]
+    ρ := { toFun := fun σ => (ρ.ρ σ).baseChange (IsLocalRing.ResidueField A)
+           map_one' := by rw [map_one, LinearMap.baseChange_one]
+           map_mul' := fun σ τ => by rw [map_mul, LinearMap.baseChange_mul] }
+    factorsThroughFiniteLevel := by
+      obtain ⟨L, hL, h1⟩ := ρ.isAdicContinuous 1
+      refine ⟨L, hL, fun σ hσ => ?_⟩
+      have hkill : ∀ x ∈ (IsLocalRing.maximalIdeal A ^ 1) • (⊤ : Submodule A ρ.V),
+          ∀ c : IsLocalRing.ResidueField A, c ⊗ₜ[A] x = 0 := by
+        intro x hx c
+        refine Submodule.smul_induction_on
+          (p := fun x => c ⊗ₜ[A] x = (0 : IsLocalRing.ResidueField A ⊗[A] ρ.V)) hx ?_ ?_
+        · intro a ha w _
+          rw [pow_one] at ha
+          rw [TensorProduct.tmul_smul, TensorProduct.smul_tmul', Algebra.smul_def,
+            IsLocalRing.ResidueField.algebraMap_eq, (IsLocalRing.residue_eq_zero_iff a).mpr ha,
+            zero_mul, TensorProduct.zero_tmul]
+        · intro x y hx hy
+          rw [TensorProduct.tmul_add, hx, hy, add_zero]
+      refine LinearMap.ext fun w => ?_
+      rw [MonoidHom.coe_mk, OneHom.coe_mk]
+      induction w using TensorProduct.inductionOn with
+      | tmul c v =>
+        rw [LinearMap.baseChange_tmul, Module.End.one_apply, ← sub_eq_zero,
+          ← TensorProduct.tmul_sub]
+        exact hkill _ (h1 σ hσ v) c
+      | add x y hx hy => rw [map_add, map_add, hx, hy] }
+
+structure Equiv (ρ₁ ρ₂ : GaloisRepAdic A) where
+  toLinearEquiv : ρ₁.V ≃ₗ[A] ρ₂.V
+  map_apply : ∀ (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) (x : ρ₁.V),
+    toLinearEquiv (ρ₁.ρ σ x) = ρ₂.ρ σ (toLinearEquiv x)
+
+def IsEquiv (ρ₁ ρ₂ : GaloisRepAdic A) : Prop :=
+  Nonempty (Equiv ρ₁ ρ₂)
+
+namespace Equiv
+
+def refl (ρ : GaloisRepAdic A) : Equiv ρ ρ :=
+  { toLinearEquiv := LinearEquiv.refl A ρ.V
+    map_apply := fun _ _ => rfl }
+
+def symm {ρ₁ ρ₂ : GaloisRepAdic A} (e : Equiv ρ₁ ρ₂) : Equiv ρ₂ ρ₁ :=
+  { toLinearEquiv := e.toLinearEquiv.symm
+    map_apply := fun σ y => e.toLinearEquiv.injective (by
+      rw [LinearEquiv.apply_symm_apply, e.map_apply, LinearEquiv.apply_symm_apply]) }
+
+def trans {ρ₁ ρ₂ ρ₃ : GaloisRepAdic A} (e : Equiv ρ₁ ρ₂) (e' : Equiv ρ₂ ρ₃) : Equiv ρ₁ ρ₃ :=
+  { toLinearEquiv := e.toLinearEquiv.trans e'.toLinearEquiv
+    map_apply := fun σ x => by
+      rw [LinearEquiv.trans_apply, LinearEquiv.trans_apply, e.map_apply, e'.map_apply] }
+
+noncomputable def baseChangeAlong {B : Type} [CommRing B] [IsLocalRing B] (φ : A →+* B)
+    (hφ : IsLocalHom φ) {ρ₁ ρ₂ : GaloisRepAdic A} (e : Equiv ρ₁ ρ₂) :
+    Equiv (ρ₁.baseChangeAlong φ hφ) (ρ₂.baseChangeAlong φ hφ) :=
+  letI : Algebra A B := φ.toAlgebra
+  { toLinearEquiv := e.toLinearEquiv.baseChange A B ρ₁.V ρ₂.V
+    map_apply := fun σ x => by
+      change e.toLinearEquiv.baseChange A B ρ₁.V ρ₂.V ((ρ₁.ρ σ).baseChange B x) =
+        (ρ₂.ρ σ).baseChange B (e.toLinearEquiv.baseChange A B ρ₁.V ρ₂.V x)
+      induction x using TensorProduct.inductionOn with
+      | tmul b v =>
+        rw [LinearMap.baseChange_tmul, LinearEquiv.baseChange_tmul, LinearEquiv.baseChange_tmul,
+          LinearMap.baseChange_tmul, e.map_apply]
+      | add x y hx hy => simp only [map_add, hx, hy] }
+
+end Equiv
+
+end GaloisRepAdic
+
+namespace GaloisRepAdic
+
+variable {A : Type} [CommRing A] [IsLocalRing A]
+
+noncomputable def Equiv.residual {ρ₁ ρ₂ : GaloisRepAdic A} (e : Equiv ρ₁ ρ₂) :
+    ResidualGaloisRep.Equiv ρ₁.residual ρ₂.residual :=
+  { toLinearEquiv :=
+      e.toLinearEquiv.baseChange A (IsLocalRing.ResidueField A) ρ₁.V ρ₂.V
+    map_apply := fun σ x => by
+      change e.toLinearEquiv.baseChange A (IsLocalRing.ResidueField A) ρ₁.V ρ₂.V
+          ((ρ₁.ρ σ).baseChange (IsLocalRing.ResidueField A) x) =
+        (ρ₂.ρ σ).baseChange (IsLocalRing.ResidueField A)
+          (e.toLinearEquiv.baseChange A (IsLocalRing.ResidueField A) ρ₁.V ρ₂.V x)
+      induction x using TensorProduct.inductionOn with
+      | tmul b v =>
+        rw [LinearMap.baseChange_tmul, LinearEquiv.baseChange_tmul, LinearEquiv.baseChange_tmul,
+          LinearMap.baseChange_tmul, e.map_apply]
+      | add x y hx hy => simp only [map_add, hx, hy] }
+
+def toResidualGaloisRep {k : Type} [Field k] (ρ : GaloisRepAdic k) : ResidualGaloisRep k :=
+  { V := ρ.V
+    finrank_eq := ρ.finrank_eq
+    ρ := ρ.ρ
+    factorsThroughFiniteLevel := by
+      obtain ⟨L, hL, h1⟩ := ρ.isAdicContinuous 1
+      refine ⟨L, hL, fun σ hσ => LinearMap.ext fun v => ?_⟩
+      have hbot : IsLocalRing.maximalIdeal k = ⊥ :=
+        (Ideal.eq_bot_or_top _).resolve_right (Ideal.IsMaximal.ne_top inferInstance)
+      have h := h1 σ hσ v
+      rw [hbot, pow_one, Submodule.bot_smul, Submodule.mem_bot, sub_eq_zero] at h
+      exact h }
+
+def ofResidualGaloisRep {k : Type} [Field k] (ρ : ResidualGaloisRep k) : GaloisRepAdic k :=
+  { V := ρ.V
+    finrank_eq := ρ.finrank_eq
+    ρ := ρ.ρ
+    isAdicContinuous := by
+      intro n
+      obtain ⟨L, hL, h1⟩ := ρ.factorsThroughFiniteLevel
+      refine ⟨L, hL, fun σ hσ v => ?_⟩
+      rw [h1 σ hσ, Module.End.one_apply, sub_self]
+      exact Submodule.zero_mem _ }
+
+end GaloisRepAdic
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_GaloisRep_LocalConditions.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_GaloisRep_LocalConditions.lean
new file mode 100644
index 0000000000..497c47718a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_GaloisRep_LocalConditions.lean
@@ -0,0 +1,98 @@
+/-
+Based on Prove2Me node GaloisRep_LocalConditions
+(e2590a6a-fcfd-5598-affa-e4bf9e60de00) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_GaloisRep_Adic
+
+/-!
+# Local conditions on adic Galois representations: determinant, ordinarity, inertia
+
+Definition: `GaloisRep_LocalConditions` (`e2590a6a-fcfd-5598-affa-e4bf9e60de00`), by Claude,
+2026-09-05.
+
+Four predicates on a Galois representation `ρ : GaloisRepAdic A` (the project's rank-two
+representation datum, with carrier `ρ.V` and action `ρ.ρ` of $\mathrm{Aut}_{\mathbb
+Q}(\overline{\mathbb Q})$) over a commutative local ring `A`; all are finite-level and
+topology-free. (1) `DetIsCyclotomic ρ p` asserts that $p$ lies in the maximal ideal of `A` and that,
+for every $n$, every $\sigma$ and every natural number $a$ such that $\sigma\mu=\mu^{a}$ for all
+$p^{n}$-th roots of unity $\mu$ in $\overline{\mathbb Q}$, one has $\det\rho(\sigma)-a \in
+(p^{n})A$. So the determinant is pinned down only by congruences modulo the principal ideals
+$(p^{n})$, not by an equality of characters; over a field of characteristic $p$ this says
+$\det\bar\rho$ is the mod-$p$ cyclotomic character. (2) `IsOrdinaryAt ρ p`: for every valuation
+subring $P$ of $\overline{\mathbb Q}$ with `P.LiesOverPrime p` there is a submodule `L` of `ρ.V`
+which is spanned by the first vector of some `A`-basis of `ρ.V` indexed by `Fin 2` (hence a free
+rank-one direct summand), is stable under the decomposition subgroup of $P$, and satisfies
+$\rho(\sigma)v-v\in L$ for all $v$ and all $\sigma$ in the inertia subgroup of $P$ (inertia acts
+trivially on `ρ.V/L`). (3) `IsUnipotentOnInertiaAt ρ q`: for every $P$ above $q$ and every inertia
+element $\sigma$, $\operatorname{charpoly}(\rho(\sigma))=(X-1)^{2}$ — an equality of characteristic
+polynomials, which over a non-reduced `A` is strictly stronger than $(\rho(\sigma)-1)^{2}=0$. (4)
+[`GaloisRep.ordinaryCondition 𝒪 p S`](../def/GaloisRep_LocalConditions.html#L28) and
+[`GaloisRep.minimalOrdinaryCondition 𝒪 p S`](../def/GaloisRep_LocalConditions.html#L33) package
+these as predicates on representations over varying coefficient rings (binder `⦃A⦄`, local
+`𝒪`-algebras): the former is `DetIsCyclotomic p` ∧ `IsOrdinaryAt p` ∧ unramified (`IsUnramifiedAt`)
+at every prime $q\notin S$, imposing nothing at the primes of $S$ other than $p$; the latter adds
+`IsUnipotentOnInertiaAt q` for every prime $q\in S$ with $q\neq p$. The names `LiesOverPrime`,
+`inertiaSubgroupIn` and `IsUnramifiedAt` are not defined here; they come from the imported
+definitions or from Mathlib. No representability, minimality or uniqueness statement is made in this
+module, and the `𝒪`-algebra structure enters only through the signature.
+
+**Relation to Mathlib.** The local data are phrased with Mathlib's valuation subrings of
+$\overline{\mathbb Q}$ and their decomposition subgroups; Mathlib has no notion of a deformation
+condition on a Galois representation, so `ordinaryCondition` and `minimalOrdinaryCondition`, like
+the underlying [`GaloisRepAdic`](../def/GaloisRep_Adic.html#L16), are the project's own.
+
+**Where it is used.** These predicates are the deformation conditions fed to the project's
+deformation-ring data: `minimalOrdinaryCondition 𝒪 p S` stands for the minimal ordinary problem used
+in the patching and numerical-criterion steps, while `ordinaryCondition 𝒪 p S` with $S$ containing
+$p$ and the bad primes is the weaker, type-$\Sigma$ problem through which the representation
+attached to a semistable elliptic curve is taken to factor.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace GaloisRepAdic
+
+variable {A : Type} [CommRing A] [IsLocalRing A]
+
+def DetIsCyclotomic (ρ : GaloisRepAdic A) (p : ℕ) : Prop :=
+  (p : A) ∈ IsLocalRing.maximalIdeal A ∧
+    ∀ (n : ℕ) (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) (a : ℕ),
+      (∀ μ : AlgebraicClosure ℚ, μ ^ p ^ n = 1 → σ μ = μ ^ a) →
+        LinearMap.det (ρ.ρ σ) - (a : A) ∈ Ideal.span {((p ^ n : ℕ) : A)}
+
+def IsOrdinaryAt (ρ : GaloisRepAdic A) (p : ℕ) : Prop :=
+  ∀ P : ValuationSubring (AlgebraicClosure ℚ), P.LiesOverPrime p →
+    ∃ L : Submodule A ρ.V,
+      (∃ b : Module.Basis (Fin 2) A ρ.V, L = A ∙ b 0) ∧
+      (∀ σ ∈ P.decompositionSubgroup ℚ, ∀ v ∈ L, ρ.ρ σ v ∈ L) ∧
+      (∀ σ ∈ P.inertiaSubgroupIn ℚ, ∀ v : ρ.V, ρ.ρ σ v - v ∈ L)
+
+def IsUnipotentOnInertiaAt (ρ : GaloisRepAdic A) (q : ℕ) : Prop :=
+  ∀ P : ValuationSubring (AlgebraicClosure ℚ), P.LiesOverPrime q →
+    ∀ σ ∈ P.inertiaSubgroupIn ℚ, LinearMap.charpoly (ρ.ρ σ) = (Polynomial.X - 1) ^ 2
+
+end GaloisRepAdic
+
+namespace GaloisRep
+
+def ordinaryCondition (𝒪 : Type) [CommRing 𝒪] (p : ℕ) (S : Finset ℕ) :
+    ∀ ⦃A : Type⦄ [CommRing A] [IsLocalRing A] [Algebra 𝒪 A], GaloisRepAdic A → Prop :=
+  fun _A _ _ _ ρ => ρ.DetIsCyclotomic p ∧ ρ.IsOrdinaryAt p ∧
+    ∀ q : ℕ, q.Prime → q ∉ S → ρ.IsUnramifiedAt q
+
+def minimalOrdinaryCondition (𝒪 : Type) [CommRing 𝒪] (p : ℕ) (S : Finset ℕ) :
+    ∀ ⦃A : Type⦄ [CommRing A] [IsLocalRing A] [Algebra 𝒪 A], GaloisRepAdic A → Prop :=
+  fun _A _ _ _ ρ => ordinaryCondition 𝒪 p S ρ ∧
+    ∀ q ∈ S, q.Prime → q ≠ p → ρ.IsUnipotentOnInertiaAt q
+
+end GaloisRep
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_GaloisRep_Residual.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_GaloisRep_Residual.lean
new file mode 100644
index 0000000000..c7f4d745f9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_GaloisRep_Residual.lean
@@ -0,0 +1,172 @@
+/-
+Based on Prove2Me node GaloisRep_Residual
+(9f203110-aa25-59ba-bd12-df090d83ea51) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusTrace
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+public import Mathlib.RingTheory.IntegralClosure.Algebra.Basic
+public import Mathlib.LinearAlgebra.Charpoly.Basic
+public import Mathlib.LinearAlgebra.Determinant
+public import Mathlib.LinearAlgebra.TensorProduct.Tower
+public import Mathlib.LinearAlgebra.Dimension.Constructions
+public import Mathlib.FieldTheory.Finiteness
+
+/-!
+# Two-dimensional residual Galois representations and their properties
+
+Definition: `GaloisRep_Residual` (`9f203110-aa25-59ba-bd12-df090d83ea51`), by Claude, 2026-09-05.
+
+[`GaloisFactorsThroughFiniteLevel ρ`](../def/GaloisRep_Residual.html#L17), for a monoid homomorphism
+$\rho$ from $\mathrm{Gal}(\overline{\mathbb{Q}}/\mathbb{Q}) =
+\mathrm{Aut}_{\mathbb{Q}}(\overline{\mathbb{Q}})$ to any monoid, asserts the existence of an
+intermediate field $L$ of $\overline{\mathbb{Q}}/\mathbb{Q}$, finite-dimensional over $\mathbb{Q}$,
+such that $\rho\sigma = 1$ whenever $\sigma$ fixes $L$ pointwise; this replaces continuity for the
+Krull topology with a discrete target, stated without any topology. [`ResidualGaloisRep
+k`](../def/GaloisRep_Residual.html#L22), for a field $k$, bundles a carrier type `V` with an abelian
+group and $k$-module structure, a field `finrank_eq` recording $\dim_k V = 2$, a monoid homomorphism
+$\rho$ from $\mathrm{Gal}(\overline{\mathbb{Q}}/\mathbb{Q})$ to $\mathrm{End}_k(V)$
+(multiplicativity forces each $\rho\sigma$ to be invertible), and a field asserting
+[`GaloisFactorsThroughFiniteLevel`](../def/GaloisRep_Residual.html#L17) for $\rho$. A
+`Module.Finite` instance is derived from the rank.
+
+The predicates on $\rho :$ [`ResidualGaloisRep k`](../def/GaloisRep_Residual.html#L22) are:
+`IsUnramifiedAt ρ q`, for an arbitrary natural number $q$ (no primality is assumed), saying that for
+every valuation subring $A$ of $\overline{\mathbb{Q}}$ with $q$ a nonunit of $A$, every element of
+the image of the inertia subgroup of $A$ over $\mathbb{Q}$ acts as the identity; `IsAttachedTo ρ f
+φ`, for a weight-two cusp form $f$ on $\Gamma_0(N)$ and a ring homomorphism $\varphi$ from the
+algebraic integers in $\mathbb{C}$ to $k$, saying that for every prime $\ell \nmid N$ with $\ell
+\neq 0$ in $k$, every valuation subring $A$ over $\ell$ and every $\sigma$ which is a Frobenius at
+$A$ for $\ell$ (in the decomposition group, acting on the residue field by $x \mapsto x^{\ell}$),
+the $\ell$-th $q$-expansion coefficient of $f$ is an algebraic integer $a$ and $\rho\sigma$ has
+characteristic polynomial $X^2 - \varphi(a)X + \ell$ — nothing is required at $\ell \mid N$ or at
+the residue characteristic, and unramifiedness is not implied; `IsOdd`, that $\det \rho(c) = -1$ for
+every involution $c \neq 1$ of $\overline{\mathbb{Q}}/\mathbb{Q}$; `IsIrreducible`, that every
+$k$-submodule stable under all $\rho\sigma$ is $0$ or $V$; and `IsAbsolutelyIrreducible`,
+irreducibility after base change to $\overline{k}$. `baseChange k'` forms $k' \otimes_k V$ with
+$\rho\sigma$ base-changed (same finite level), `baseChangeAlong φ` does so along a ring
+homomorphism.
+
+Finally, [`WeierstrassCurve.residualGaloisRepOf W p hcard hker`](../def/GaloisRep_Residual.html#L87)
+packages, for a Weierstrass curve $W$ over $\mathbb{Q}$ and a prime $p$, the Galois action on the
+$p$-torsion of $W(\overline{\mathbb{Q}})$ as a [`ResidualGaloisRep (ZMod
+p)`](../def/GaloisRep_Residual.html#L22): the carrier is `Submodule.torsionBy ℤ (W⁄(AlgebraicClosure
+ℚ)).Point p`, the homomorphism is the action of $\mathrm{Gal}(\overline{\mathbb{Q}}/\mathbb{Q})$ on
+torsion points by functoriality of $W$-points, and the two arithmetic inputs — that the $p$-torsion
+has exactly $p^2$ elements (whence rank $2$ over $\mathbb{Z}/p$) and that the action factors through
+a finite level — are taken as hypotheses rather than proved here.
+
+**Relation to Mathlib.** Mathlib has no notion of Galois representation; the structure and all of
+these predicates are the project's own, as is the Galois action on the torsion of the points of a
+Weierstrass curve. Mathlib supplies the ambient ingredients: decomposition and inertia subgroups of
+a valuation subring, `CuspForm` on congruence subgroups with its $q$-expansion,
+`LinearMap.charpoly`, `LinearMap.det` and `LinearMap.baseChange`.
+
+**Where it is used.** These definitions are the interface through which the mod-$p$ representation
+attached to the $p$-torsion of the Frey curve is handled: irreducibility and oddness of that
+representation, its unramifiedness away from the bad primes, and its attachment to a weight-two cusp
+form on $\Gamma_0(N)$ are the hypotheses and conclusions of the modularity and level-lowering steps.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open scoped WeierstrassCurve.Affine TensorProduct
+open Polynomial
+
+def GaloisFactorsThroughFiniteLevel {M : Type} [MulOneClass M]
+    (ρ : (AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) →* M) : Prop :=
+  ∃ L : IntermediateField ℚ (AlgebraicClosure ℚ), FiniteDimensional ℚ L ∧
+    ∀ σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ, (∀ x ∈ L, σ x = x) → ρ σ = 1
+
+structure ResidualGaloisRep (k : Type) [Field k] : Type 1 where
+  V : Type
+  [instAddCommGroup : AddCommGroup V]
+  [instModule : Module k V]
+  finrank_eq : Module.finrank k V = 2
+  ρ : (AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) →* Module.End k V
+  factorsThroughFiniteLevel : GaloisFactorsThroughFiniteLevel ρ
+
+attribute [instance] ResidualGaloisRep.instAddCommGroup ResidualGaloisRep.instModule
+
+instance ResidualGaloisRep.instModuleFinite {k : Type} [Field k] (ρ : ResidualGaloisRep k) :
+    Module.Finite k ρ.V :=
+  Module.finite_of_finrank_eq_succ ρ.finrank_eq
+
+namespace ResidualGaloisRep
+
+variable {k : Type} [Field k]
+
+def IsUnramifiedAt (ρ : ResidualGaloisRep k) (q : ℕ) : Prop :=
+  ∀ A : ValuationSubring (AlgebraicClosure ℚ), A.LiesOverPrime q →
+    ∀ σ ∈ A.inertiaSubgroupIn ℚ, ρ.ρ σ = 1
+
+def IsAttachedTo (ρ : ResidualGaloisRep k) {N : ℕ}
+    (f : CuspForm (CongruenceSubgroup.Gamma0 N) 2)
+    (φ : integralClosure ℤ ℂ →+* k) : Prop :=
+  ∀ ℓ : ℕ, ℓ.Prime → ¬ ℓ ∣ N → (ℓ : k) ≠ 0 →
+    ∀ A : ValuationSubring (AlgebraicClosure ℚ), A.LiesOverPrime ℓ →
+      ∀ σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ, A.IsFrobeniusAt σ ℓ →
+        ∃ a : integralClosure ℤ ℂ, (a : ℂ) = ModularFormClass.qCoeff f ℓ ∧
+          LinearMap.charpoly (ρ.ρ σ) = X ^ 2 - C (φ a) * X + C ((ℓ : k))
+
+def IsOdd (ρ : ResidualGaloisRep k) : Prop :=
+  ∀ c : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ, c * c = 1 → c ≠ 1 →
+    LinearMap.det (ρ.ρ c) = -1
+
+def IsIrreducible (ρ : ResidualGaloisRep k) : Prop :=
+  ∀ W : Submodule k ρ.V, (∀ σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ,
+    ∀ x ∈ W, ρ.ρ σ x ∈ W) → W = ⊥ ∨ W = ⊤
+
+abbrev baseChange (k' : Type) [Field k'] [Algebra k k'] (ρ : ResidualGaloisRep k) :
+    ResidualGaloisRep k' :=
+  { V := k' ⊗[k] ρ.V
+    finrank_eq := by rw [Module.finrank_baseChange, ρ.finrank_eq]
+    ρ := { toFun := fun σ => (ρ.ρ σ).baseChange k'
+           map_one' := by rw [map_one, LinearMap.baseChange_one]
+           map_mul' := fun σ τ => by rw [map_mul, LinearMap.baseChange_mul] }
+    factorsThroughFiniteLevel := by
+      obtain ⟨L, hL, h1⟩ := ρ.factorsThroughFiniteLevel
+      exact ⟨L, hL, fun σ hσ => by
+        rw [MonoidHom.coe_mk, OneHom.coe_mk, h1 σ hσ, LinearMap.baseChange_one]⟩ }
+
+def baseChangeAlong {k' : Type} [Field k'] (φ : k →+* k') (ρ : ResidualGaloisRep k) :
+    ResidualGaloisRep k' :=
+  letI : Algebra k k' := φ.toAlgebra
+  ρ.baseChange k'
+
+def IsAbsolutelyIrreducible (ρ : ResidualGaloisRep k) : Prop :=
+  (ρ.baseChange (AlgebraicClosure k)).IsIrreducible
+
+end ResidualGaloisRep
+
+def WeierstrassCurve.residualGaloisRepOf (W : WeierstrassCurve ℚ) (p : ℕ) [Fact p.Prime]
+    (hcard : Nat.card (Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point p) = p ^ 2)
+    (hker : GaloisFactorsThroughFiniteLevel
+      (WeierstrassCurve.Affine.Point.galoisRepModuleEnd (K := AlgebraicClosure ℚ) ℚ W p)) :
+    ResidualGaloisRep (ZMod p) :=
+  haveI hfin : Finite (Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point p) :=
+    Nat.finite_of_card_ne_zero
+      (hcard ▸ pow_ne_zero 2 (Fact.out (p := p.Prime)).pos.ne')
+  { V := Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point p
+    finrank_eq := by
+      have hp : p.Prime := Fact.out
+      have h := Module.natCard_eq_pow_finrank (K := ZMod p)
+        (V := Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point p)
+      rw [hcard, Nat.card_zmod] at h
+      exact (Nat.pow_right_injective hp.two_le h).symm
+    ρ := WeierstrassCurve.Affine.Point.galoisRepModuleEnd (K := AlgebraicClosure ℚ) ℚ W p
+    factorsThroughFiniteLevel := hker }
+
+end
+
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_GaloisRep_ResidualEquiv.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_GaloisRep_ResidualEquiv.lean
new file mode 100644
index 0000000000..b6efe21461
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_GaloisRep_ResidualEquiv.lean
@@ -0,0 +1,110 @@
+/-
+Based on Prove2Me node GaloisRep_ResidualEquiv
+(43cdbff2-2ba9-5395-86b0-6f024efc3f12) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_GaloisRep_Residual
+
+/-!
+# Equivalence of residual Galois representations, and base change
+
+Definition: `GaloisRep_ResidualEquiv` (`43cdbff2-2ba9-5395-86b0-6f024efc3f12`), by Claude,
+2026-09-05.
+
+Fix a field $k$ and two residual Galois representations $\rho_1,\rho_2$ over $k$, i.e. two terms of
+the project's own type [`ResidualGaloisRep k`](../def/GaloisRep_Residual.html#L22) (defined in the
+imported module, and whose data is used here through the carrier `ρ.V`, a $k$-module, and the
+assignment `ρ.ρ` sending each $\mathbb{Q}$-algebra automorphism $\sigma$ of `AlgebraicClosure ℚ` to
+a $k$-linear map on `ρ.V`). The structure [`ResidualGaloisRep.Equiv ρ₁
+ρ₂`](../def/GaloisRep_ResidualEquiv.html#L9) packages an intertwining isomorphism as data: a field
+`toLinearEquiv`, which is a $k$-linear equivalence $e : \rho_1.V \simeq \rho_2.V$, together with a
+field `map_apply` asserting the intertwining relation in *pointwise* form, $e(\rho_1(\sigma)x) =
+\rho_2(\sigma)(e\,x)$ for every $\sigma$ in the Galois group as spelled above and every $x \in
+\rho_1.V$. Thus the theorem-like condition is carried as a field of the structure, and an `Equiv` is
+a chosen isomorphism rather than the mere assertion that one exists. The latter is the separate
+proposition [`ResidualGaloisRep.IsEquiv ρ₁ ρ₂`](../def/GaloisRep_ResidualEquiv.html#L16), defined as
+`Nonempty (Equiv ρ₁ ρ₂)`.
+
+The remaining declarations are the groupoid operations: `Equiv.refl` (the identity linear
+equivalence), `Equiv.symm` (the inverse linear equivalence, whose intertwining property is obtained
+by applying injectivity of $e$), and `Equiv.trans` (composition), so that `IsEquiv` is reflexive,
+symmetric and transitive, although no `Equiv`-relation instance is registered here. Finally
+`Equiv.baseChangeAlong` transports an equivalence along a ring homomorphism $\psi : k \to k'$ of
+fields: regarding $k'$ as a $k$-algebra via $\psi$, it produces an equivalence between the
+base-changed representations `ρ₁.baseChangeAlong ψ` and `ρ₂.baseChangeAlong ψ`, with underlying map
+$e \otimes \mathrm{id}$ (Mathlib's `LinearEquiv.baseChange`), the intertwining relation being
+checked on pure tensors and extended additively. Nothing else is declared.
+
+**Relation to Mathlib.** Mathlib has no type of residual Galois representations, so this notion of
+equivalence between them is the project's own; its underlying maps are Mathlib's `LinearEquiv`, and
+the base-change construction is built from Mathlib's `LinearEquiv.baseChange` and
+`LinearMap.baseChange`.
+
+**Where it is used.** This is the single notion in which statements comparing residual
+representations are phrased: that the mod-$\mathfrak{m}$ representation attached to a modular form
+and the mod-$p$ representation of an elliptic curve agree (after extension of the coefficient field,
+via `Equiv.baseChangeAlong`), and that the reduction of a deformation is the given residual
+representation. It is imported by the great majority of the statement modules on the Galois side of
+the argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open scoped TensorProduct
+
+namespace ResidualGaloisRep
+
+variable {k : Type} [Field k]
+
+structure Equiv (ρ₁ ρ₂ : ResidualGaloisRep k) where
+  toLinearEquiv : ρ₁.V ≃ₗ[k] ρ₂.V
+  map_apply : ∀ (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) (x : ρ₁.V),
+    toLinearEquiv (ρ₁.ρ σ x) = ρ₂.ρ σ (toLinearEquiv x)
+
+def IsEquiv (ρ₁ ρ₂ : ResidualGaloisRep k) : Prop :=
+  Nonempty (Equiv ρ₁ ρ₂)
+
+namespace Equiv
+
+def refl (ρ : ResidualGaloisRep k) : Equiv ρ ρ where
+  toLinearEquiv := LinearEquiv.refl k ρ.V
+  map_apply _ _ := rfl
+
+def symm {ρ₁ ρ₂ : ResidualGaloisRep k} (e : Equiv ρ₁ ρ₂) : Equiv ρ₂ ρ₁ where
+  toLinearEquiv := e.toLinearEquiv.symm
+  map_apply σ x := by
+    apply e.toLinearEquiv.injective
+    rw [e.map_apply, LinearEquiv.apply_symm_apply, LinearEquiv.apply_symm_apply]
+
+def trans {ρ₁ ρ₂ ρ₃ : ResidualGaloisRep k} (e₁₂ : Equiv ρ₁ ρ₂) (e₂₃ : Equiv ρ₂ ρ₃) :
+    Equiv ρ₁ ρ₃ where
+  toLinearEquiv := e₁₂.toLinearEquiv.trans e₂₃.toLinearEquiv
+  map_apply σ x := by
+    rw [LinearEquiv.trans_apply, e₁₂.map_apply, e₂₃.map_apply, LinearEquiv.trans_apply]
+
+noncomputable def baseChangeAlong {k' : Type} [Field k'] (ψ : k →+* k')
+    {ρ₁ ρ₂ : ResidualGaloisRep k} (e : Equiv ρ₁ ρ₂) :
+    Equiv (ρ₁.baseChangeAlong ψ) (ρ₂.baseChangeAlong ψ) :=
+  letI : Algebra k k' := ψ.toAlgebra
+  { toLinearEquiv := e.toLinearEquiv.baseChange k k' ρ₁.V ρ₂.V
+    map_apply := fun σ x => by
+      change e.toLinearEquiv.baseChange k k' ρ₁.V ρ₂.V ((ρ₁.ρ σ).baseChange k' x) =
+        (ρ₂.ρ σ).baseChange k' (e.toLinearEquiv.baseChange k k' ρ₁.V ρ₂.V x)
+      induction x using TensorProduct.inductionOn with
+      | tmul b v =>
+        rw [LinearMap.baseChange_tmul, LinearEquiv.baseChange_tmul, LinearEquiv.baseChange_tmul,
+          LinearMap.baseChange_tmul, e.map_apply]
+      | add x y hx hy => simp only [map_add, hx, hy] }
+
+end Equiv
+
+end ResidualGaloisRep
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_Gamma0CoeffCohomology.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_Gamma0CoeffCohomology.lean
new file mode 100644
index 0000000000..3a813c9fcf
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_Gamma0CoeffCohomology.lean
@@ -0,0 +1,220 @@
+/-
+Based on Prove2Me node Gamma0CoeffCohomology
+(077b1ce7-afc1-5e0a-bf2d-900e8ab21871) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RepresentationTheory.Basic
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0HeckeOperatorHom
+
+/-!
+# Parabolic group cohomology in degree one, with Hecke cochain operator
+
+Definition: `Gamma0CoeffCohomology` (`077b1ce7-afc1-5e0a-bf2d-900e8ab21871`), by Claude, 2026-09-05.
+
+Over a commutative ring $K$, for a group $G$ and a representation $\rho \colon G \to
+\mathrm{GL}_K(V)$ on a $K$-module $V$, the module
+[`HeckeEis.coeffCocycles`](../def/Gamma0CoeffCohomology.html#L13) is the submodule of $K$-valued
+functions $z \colon G \to V$ satisfying the inhomogeneous cocycle identity $z(gh) = z(g) +
+\rho(g)\,z(h)$ for all $g,h$, and
+[`HeckeEis.coeffCoboundaryMap`](../def/Gamma0CoeffCohomology.html#L30) is the $K$-linear map sending
+$v \in V$ to the function $g \mapsto \rho(g)v - v$, whose range is
+[`HeckeEis.coeffCoboundaries`](../def/Gamma0CoeffCohomology.html#L45); the coboundaries lie in the
+cocycles. In the parabolic section $\Gamma$ is a subgroup of $\mathrm{SL}_2(\mathbb Z)$ and $\rho$ a
+representation of $\Gamma$. The predicate
+[`HeckeEis.IsParabolicCocycle`](../def/Gamma0CoeffCohomology.html#L71) applies to an arbitrary
+function $z \colon \Gamma \to V$ and asserts that for every $\gamma \in \Gamma$ whose underlying
+integer matrix has $\operatorname{tr}(\gamma)^2 = 4$ the value $z(\gamma)$ lies in the image of the
+endomorphism $\rho(\gamma) - 1$. Conjoining this with the cocycle condition gives the submodule
+[`HeckeEis.coeffParabolicCocycles`](../def/Gamma0CoeffCohomology.html#L75), which contains the
+coboundaries and is contained in the cocycles. The $K$-module
+[`HeckeEis.coeffH1par`](../def/Gamma0CoeffCohomology.html#L100) is defined as the quotient of
+`coeffParabolicCocycles` by the preimage of `coeffCoboundaries` under the inclusion, with
+[`HeckeEis.coeffH1parMk`](../def/Gamma0CoeffCohomology.html#L111) the quotient map: it is
+surjective, and a parabolic cocycle has trivial class exactly when it is a coboundary.
+
+Finally, for $N, \ell$ natural numbers with $\ell \neq 0$, a representation $\rho$ of $\Gamma_0(N)$,
+a $K$-linear endomorphism $a$ of $V$ and a function $z \colon \Gamma_0(N) \to V$, the function
+[`HeckeEis.coeffHeckeFun`](../def/Gamma0CoeffCohomology.html#L129) is defined by
+$$(T z)(g) = \sum_{q \in \Gamma_0(N)/\Gamma_\alpha} \rho\bigl(r_{g\cdot q}\bigr)\, a\bigl(z(\alpha\,
+r_{g\cdot q}^{-1} g\, r_q\, \alpha^{-1})\bigr),$$
+where $\Gamma_\alpha =$ `heckeUpper N ℓ` is the finite-index subgroup of $\Gamma_0(N)$ cut out by
+$\ell \mid b$, the chosen coset representatives $r_q$ and the transfer element $r_{g\cdot q}^{-1}
+g\, r_q \in \Gamma_\alpha$ come from `transferAux`, and conjugation by $\alpha =
+\operatorname{diag}(1,\ell)$ is `heckeConj N ℓ`. This is the cochain-level operator only;
+[`HeckeEis.coeffHeckeFun_trivial`](../def/Gamma0CoeffCohomology.html#L144) identifies it, for the
+trivial one-dimensional representation on $K$ and $a = \mathrm{id}$, with the additive-character
+operator [`HeckeEis.heckeOperatorHom N ℓ K`](../def/Gamma0HeckeOperatorHom.html#L285).
+
+**Relation to Mathlib.** Mathlib develops group cohomology for objects of `Rep`; here the degree-one
+inhomogeneous cocycles and coboundaries are set up directly as submodules of $G \to V$ attached to a
+`Representation K G V`, and the parabolic condition, the parabolic subspace and the quotient
+$H^1_{\mathrm{par}}$ have no Mathlib counterpart.
+
+**Where it is used.** These modules provide the group-cohomological model of modular symbols for
+$\Gamma_0(N)$ used to carry Hecke actions; in the trivial-coefficient case the parabolic classes are
+the parabolic additive characters of $\Gamma_0(N)$, and the cochain operator here is the coefficient
+version of the Hecke operator on those characters.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace HeckeEis
+
+open CongruenceSubgroup
+open scoped MatrixGroups
+
+section Cocycles
+
+variable {G : Type*} [Group G] {K : Type*} [CommRing K] {V : Type*} [AddCommGroup V] [Module K V]
+
+def coeffCocycles (ρ : Representation K G V) : Submodule K (G → V) where
+  carrier := {z | ∀ g h : G, z (g * h) = z g + ρ g (z h)}
+  zero_mem' := by
+    intro g h
+    simp
+  add_mem' := by
+    intro z w hz hw g h
+    simp only [Pi.add_apply, hz g h, hw g h, map_add]
+    abel
+  smul_mem' := by
+    intro c z hz g h
+    simp only [Pi.smul_apply, hz g h, smul_add, map_smul]
+
+theorem mem_coeffCocycles_iff (ρ : Representation K G V) (z : G → V) :
+    z ∈ coeffCocycles ρ ↔ ∀ g h : G, z (g * h) = z g + ρ g (z h) :=
+  Iff.rfl
+
+def coeffCoboundaryMap (ρ : Representation K G V) : V →ₗ[K] (G → V) where
+  toFun v := fun g => ρ g v - v
+  map_add' v w := by
+    ext g
+    simp only [map_add, Pi.add_apply]
+    abel
+  map_smul' c v := by
+    ext g
+    simp only [map_smul, Pi.smul_apply, RingHom.id_apply, smul_sub]
+
+@[simp]
+theorem coeffCoboundaryMap_apply (ρ : Representation K G V) (v : V) (g : G) :
+    coeffCoboundaryMap ρ v g = ρ g v - v :=
+  rfl
+
+def coeffCoboundaries (ρ : Representation K G V) : Submodule K (G → V) :=
+  LinearMap.range (coeffCoboundaryMap ρ)
+
+theorem mem_coeffCoboundaries_iff (ρ : Representation K G V) (z : G → V) :
+    z ∈ coeffCoboundaries ρ ↔ ∃ v : V, (fun g => ρ g v - v) = z := by
+  simp only [coeffCoboundaries, LinearMap.mem_range]
+  constructor
+  · rintro ⟨v, hv⟩
+    exact ⟨v, by rw [← hv]; rfl⟩
+  · rintro ⟨v, hv⟩
+    exact ⟨v, by rw [← hv]; rfl⟩
+
+theorem coeffCoboundaries_le_coeffCocycles (ρ : Representation K G V) :
+    coeffCoboundaries ρ ≤ coeffCocycles ρ := by
+  rintro z ⟨v, rfl⟩ g h
+  change ρ (g * h) v - v = (ρ g v - v) + ρ g (ρ h v - v)
+  rw [map_mul, map_sub]
+  simp only [Module.End.mul_apply]
+  abel
+
+end Cocycles
+
+section Parabolic
+
+variable {Γ : Subgroup SL(2, ℤ)} {K : Type*} [CommRing K] {V : Type*} [AddCommGroup V] [Module K V]
+
+def IsParabolicCocycle (ρ : Representation K Γ V) (z : Γ → V) : Prop :=
+  ∀ γ : Γ, ((γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace ^ 2 = 4 →
+    z γ ∈ LinearMap.range (ρ γ - 1)
+
+def coeffParabolicCocycles (ρ : Representation K Γ V) : Submodule K (Γ → V) where
+  carrier := {z | z ∈ coeffCocycles ρ ∧ IsParabolicCocycle ρ z}
+  zero_mem' := ⟨Submodule.zero_mem _, fun γ _ => by simp⟩
+  add_mem' := by
+    rintro z w ⟨hz, hz'⟩ ⟨hw, hw'⟩
+    exact ⟨Submodule.add_mem _ hz hw, fun γ hγ => Submodule.add_mem _ (hz' γ hγ) (hw' γ hγ)⟩
+  smul_mem' := by
+    rintro c z ⟨hz, hz'⟩
+    exact ⟨Submodule.smul_mem _ c hz, fun γ hγ => Submodule.smul_mem _ c (hz' γ hγ)⟩
+
+theorem mem_coeffParabolicCocycles_iff (ρ : Representation K Γ V) (z : Γ → V) :
+    z ∈ coeffParabolicCocycles ρ ↔ z ∈ coeffCocycles ρ ∧ IsParabolicCocycle ρ z :=
+  Iff.rfl
+
+theorem coeffParabolicCocycles_le_coeffCocycles (ρ : Representation K Γ V) :
+    coeffParabolicCocycles ρ ≤ coeffCocycles ρ :=
+  fun _ hz => hz.1
+
+theorem coeffCoboundaries_le_coeffParabolicCocycles (ρ : Representation K Γ V) :
+    coeffCoboundaries ρ ≤ coeffParabolicCocycles ρ := by
+  intro z hz
+  refine ⟨coeffCoboundaries_le_coeffCocycles ρ hz, fun γ _ => ?_⟩
+  obtain ⟨v, rfl⟩ := hz
+  exact ⟨v, by simp [coeffCoboundaryMap]⟩
+
+def coeffH1par (ρ : Representation K Γ V) : Type _ :=
+  ↥(coeffParabolicCocycles ρ) ⧸ (coeffCoboundaries ρ).comap (coeffParabolicCocycles ρ).subtype
+
+instance instAddCommGroupCoeffH1par (ρ : Representation K Γ V) : AddCommGroup (coeffH1par ρ) :=
+  inferInstanceAs (AddCommGroup
+    (↥(coeffParabolicCocycles ρ) ⧸ (coeffCoboundaries ρ).comap (coeffParabolicCocycles ρ).subtype))
+
+instance instModuleCoeffH1par (ρ : Representation K Γ V) : Module K (coeffH1par ρ) :=
+  inferInstanceAs (Module K
+    (↥(coeffParabolicCocycles ρ) ⧸ (coeffCoboundaries ρ).comap (coeffParabolicCocycles ρ).subtype))
+
+def coeffH1parMk (ρ : Representation K Γ V) : ↥(coeffParabolicCocycles ρ) →ₗ[K] coeffH1par ρ :=
+  ((coeffCoboundaries ρ).comap (coeffParabolicCocycles ρ).subtype).mkQ
+
+theorem coeffH1parMk_surjective (ρ : Representation K Γ V) :
+    Function.Surjective (coeffH1parMk ρ) :=
+  Submodule.mkQ_surjective _
+
+theorem coeffH1parMk_eq_zero_iff (ρ : Representation K Γ V) (z : ↥(coeffParabolicCocycles ρ)) :
+    coeffH1parMk ρ z = 0 ↔ (z : Γ → V) ∈ coeffCoboundaries ρ :=
+  (Submodule.Quotient.mk_eq_zero _).trans Submodule.mem_comap
+
+end Parabolic
+
+section Hecke
+
+variable (N : ℕ) (ℓ : ℕ) [NeZero ℓ]
+variable {K : Type*} [CommRing K] {V : Type*} [AddCommGroup V] [Module K V]
+
+noncomputable def coeffHeckeFun (ρ : Representation K (Gamma0 N) V) (a : V →ₗ[K] V)
+    (z : Gamma0 N → V) : Gamma0 N → V :=
+  fun g =>
+    letI := (heckeUpper N ℓ).fintypeQuotientOfFiniteIndex
+    ∑ q : Gamma0 N ⧸ heckeUpper N ℓ,
+      ρ (g • q).out (a (z (heckeConj N ℓ (transferAux (heckeUpper N ℓ) g q))))
+
+theorem coeffHeckeFun_apply (ρ : Representation K (Gamma0 N) V) (a : V →ₗ[K] V)
+    (z : Gamma0 N → V) (g : Gamma0 N) :
+    coeffHeckeFun N ℓ ρ a z g =
+      letI := (heckeUpper N ℓ).fintypeQuotientOfFiniteIndex
+      ∑ q : Gamma0 N ⧸ heckeUpper N ℓ,
+        ρ (g • q).out (a (z (heckeConj N ℓ (transferAux (heckeUpper N ℓ) g q)))) :=
+  rfl
+
+theorem coeffHeckeFun_trivial (φ : Additive (Gamma0 N) →+ K) (g : Gamma0 N) :
+    coeffHeckeFun N ℓ (1 : Representation K (Gamma0 N) K) LinearMap.id
+        (fun h => φ (Additive.ofMul h)) g
+      = heckeOperatorHom N ℓ K φ (Additive.ofMul g) := by
+  rw [coeffHeckeFun_apply, heckeOperatorHom_apply]
+  simp
+
+end Hecke
+
+end HeckeEis
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_Gamma0HeckeOperatorHom.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_Gamma0HeckeOperatorHom.lean
new file mode 100644
index 0000000000..170ace2110
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_Gamma0HeckeOperatorHom.lean
@@ -0,0 +1,363 @@
+/-
+Based on Prove2Me node Gamma0HeckeOperatorHom
+(28f733ff-028e-55e7-b8ef-e2f1bceef18f) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import Mathlib.GroupTheory.Index
+public import Mathlib.GroupTheory.GroupAction.Quotient
+public import Mathlib.Tactic.Group
+public import Mathlib.Tactic.LinearCombination
+public import Mathlib.Tactic.FinCases
+
+/-!
+# Hecke operators on homomorphisms out of Γ0​(N) via transfer
+
+Definition: `Gamma0HeckeOperatorHom` (`28f733ff-028e-55e7-b8ef-e2f1bceef18f`), by Claude,
+2026-09-05.
+
+For natural numbers $N,\ell$ with $\ell\neq 0$ and an additively written abelian group $A$, this
+module constructs an endomorphism `heckeOperatorHom N ℓ A` of the group of additive homomorphisms
+$\mathrm{Hom}(\Gamma_0(N),A)$ (in Lean, `Additive ↥(Gamma0 N) →+ A`, so for trivial coefficients
+this is $H^1(\Gamma_0(N),A)$), realising the double-coset recipe for
+$\alpha=\begin{pmatrix}1&0\\0&\ell\end{pmatrix}$ entirely inside $\Gamma_0(N)$. Three ingredients
+are defined. First, `heckeUpperSL ℓ` is the subgroup of $\mathrm{SL}_2(\mathbb{Z})$ cut out by
+$\ell\mid g_{01}$, and `heckeUpper N ℓ` is its preimage in $\Gamma_0(N)$; it contains the kernel of
+the reduction homomorphism `gammaZeroRed N ℓ : Gamma0 N →* SL(2, ZMod ℓ)` and is therefore of finite
+index. Second, `heckeConjMat ℓ g` is the integer matrix $\begin{pmatrix}g_{00}&g_{01}/\ell\\ \ell
+g_{10}&g_{11}\end{pmatrix}$ (with `Int` division), characterised when $\ell\mid g_{01}$ by the
+denominator-free identity $(\mathrm{heckeConjMat}\,\ell\,g)\cdot\alpha=\alpha\cdot g$, whence it is
+multiplicative, determinant-preserving and injective on matrices with $\ell\mid g_{01}$; it yields
+an injective group homomorphism `heckeConj N ℓ : heckeUpper N ℓ →* Gamma0 N`,
+$\gamma\mapsto\alpha\gamma\alpha^{-1}$, the level being preserved because the lower-left entry is
+multiplied by $\ell$. Third, a transfer is set up at the level of homomorphisms: `resHom H` is
+restriction along $H\hookrightarrow G$, `transferAux H g q` $=\overline{g\cdot
+q}^{\,-1}(g\,\overline{q})\in H$ is the transfer cocycle formed with the canonical section
+$q\mapsto\overline q$ of $G\to G\,⧸\,H$ (satisfying the cocycle identity `transferAux_mul`), and,
+for $H$ of finite index, `coresHom H` sends $\varphi\in\mathrm{Hom}(H,A)$ to $g\mapsto\sum_{q\in
+G⧸H}\varphi(\mathrm{transferAux}\,H\,g\,q)$. The Hecke operator is pullback along `heckeConj N ℓ`
+followed by corestriction from `heckeUpper N ℓ` to $\Gamma_0(N)$, with `heckeOperatorHom_apply`
+giving the explicit sum over $\Gamma_0(N)⧸\mathrm{heckeUpper}\,N\,\ell$; `uOperatorHom N A q` is the
+same operator under a $U_q$-style name. Finally `HeckeIndexEq N ℓ` is the proposition, not a
+theorem, that $[\Gamma_0(N):\mathrm{heckeUpper}\,N\,\ell]=\ell+1$.
+
+**Relation to Mathlib.** Built on Mathlib's congruence subgroup `Gamma0` and `Subgroup.subgroupOf`,
+`Subgroup.FiniteIndex` machinery; the Hecke subgroup, the conjugation homomorphism by
+$\mathrm{diag}(1,\ell)$ and the transfer/corestriction on $\mathrm{Hom}(-,A)$ used here are the
+project's own, and the resulting operator acts on homomorphisms out of $\Gamma_0(N)$ rather than on
+a space of modular forms.
+
+**Where it is used.** These operators supply the Hecke (and $U_q$) action on
+$\mathrm{Hom}(\Gamma_0(N),A)$, i.e. on degree-one cohomology of $\Gamma_0(N)$ with trivial
+coefficients, which is the shape in which the Hecke action at level $N$ is used on the modular side
+of the argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace HeckeEis
+
+open CongruenceSubgroup Subgroup Matrix
+open scoped MatrixGroups
+
+section ConjMatrix
+
+def alphaMat (ℓ : ℕ) : Matrix (Fin 2) (Fin 2) ℤ := !![1, 0; 0, (ℓ : ℤ)]
+
+@[simp] theorem alphaMat_apply_zero_zero (ℓ : ℕ) : alphaMat ℓ 0 0 = 1 := rfl
+@[simp] theorem alphaMat_apply_zero_one (ℓ : ℕ) : alphaMat ℓ 0 1 = 0 := rfl
+@[simp] theorem alphaMat_apply_one_zero (ℓ : ℕ) : alphaMat ℓ 1 0 = 0 := rfl
+@[simp] theorem alphaMat_apply_one_one (ℓ : ℕ) : alphaMat ℓ 1 1 = (ℓ : ℤ) := rfl
+
+theorem det_alphaMat (ℓ : ℕ) : (alphaMat ℓ).det = (ℓ : ℤ) := by
+  rw [alphaMat, det_fin_two_of]; ring
+
+theorem eq_of_mul_alphaMat_eq {ℓ : ℕ} (hℓ : (ℓ : ℤ) ≠ 0) {A B : Matrix (Fin 2) (Fin 2) ℤ}
+    (h : A * alphaMat ℓ = B * alphaMat ℓ) : A = B := by
+  ext i j
+  have h0 := congrFun (congrFun h i) 0
+  have h1 := congrFun (congrFun h i) 1
+  simp only [Matrix.mul_apply, Fin.sum_univ_two, alphaMat_apply_zero_zero,
+    alphaMat_apply_zero_one, alphaMat_apply_one_zero, alphaMat_apply_one_one,
+    mul_one, mul_zero, add_zero, zero_add] at h0 h1
+  fin_cases j
+  · exact h0
+  · exact mul_right_cancel₀ hℓ h1
+
+def heckeConjMat (ℓ : ℕ) (g : Matrix (Fin 2) (Fin 2) ℤ) : Matrix (Fin 2) (Fin 2) ℤ :=
+  !![g 0 0, g 0 1 / (ℓ : ℤ); g 1 0 * (ℓ : ℤ), g 1 1]
+
+@[simp] theorem heckeConjMat_apply_zero_zero (ℓ : ℕ) (g : Matrix (Fin 2) (Fin 2) ℤ) :
+    heckeConjMat ℓ g 0 0 = g 0 0 := rfl
+@[simp] theorem heckeConjMat_apply_zero_one (ℓ : ℕ) (g : Matrix (Fin 2) (Fin 2) ℤ) :
+    heckeConjMat ℓ g 0 1 = g 0 1 / (ℓ : ℤ) := rfl
+@[simp] theorem heckeConjMat_apply_one_zero (ℓ : ℕ) (g : Matrix (Fin 2) (Fin 2) ℤ) :
+    heckeConjMat ℓ g 1 0 = g 1 0 * (ℓ : ℤ) := rfl
+@[simp] theorem heckeConjMat_apply_one_one (ℓ : ℕ) (g : Matrix (Fin 2) (Fin 2) ℤ) :
+    heckeConjMat ℓ g 1 1 = g 1 1 := rfl
+
+theorem heckeConjMat_mul_alphaMat {ℓ : ℕ} {g : Matrix (Fin 2) (Fin 2) ℤ}
+    (hg : (ℓ : ℤ) ∣ g 0 1) :
+    heckeConjMat ℓ g * alphaMat ℓ = alphaMat ℓ * g := by
+  ext i j
+  fin_cases i <;> fin_cases j <;>
+    simp only [Matrix.mul_apply, Fin.sum_univ_two, alphaMat_apply_zero_zero,
+      alphaMat_apply_zero_one, alphaMat_apply_one_zero, alphaMat_apply_one_one,
+      heckeConjMat_apply_zero_zero, heckeConjMat_apply_zero_one, heckeConjMat_apply_one_zero,
+      heckeConjMat_apply_one_one, Fin.zero_eta, Fin.mk_one, Fin.isValue, mul_zero,
+      one_mul, zero_mul, add_zero, zero_add] <;>
+    first
+      | exact Int.ediv_mul_cancel hg
+      | ring1
+
+theorem dvd_mul_apply_zero_one {ℓ : ℕ} {g h : Matrix (Fin 2) (Fin 2) ℤ}
+    (hg : (ℓ : ℤ) ∣ g 0 1) (hh : (ℓ : ℤ) ∣ h 0 1) : (ℓ : ℤ) ∣ (g * h) 0 1 := by
+  rw [(Matrix.two_mul_expl g h).2.1]
+  exact dvd_add (hh.mul_left _) (hg.mul_right _)
+
+theorem heckeConjMat_mul {ℓ : ℕ} (hℓ : (ℓ : ℤ) ≠ 0) {g h : Matrix (Fin 2) (Fin 2) ℤ}
+    (hg : (ℓ : ℤ) ∣ g 0 1) (hh : (ℓ : ℤ) ∣ h 0 1) :
+    heckeConjMat ℓ (g * h) = heckeConjMat ℓ g * heckeConjMat ℓ h := by
+  have key : (heckeConjMat ℓ g * heckeConjMat ℓ h) * alphaMat ℓ = alphaMat ℓ * (g * h) := by
+    rw [mul_assoc, heckeConjMat_mul_alphaMat hh, ← mul_assoc, heckeConjMat_mul_alphaMat hg,
+      mul_assoc]
+  exact eq_of_mul_alphaMat_eq hℓ
+    ((heckeConjMat_mul_alphaMat (dvd_mul_apply_zero_one hg hh)).trans key.symm)
+
+theorem det_heckeConjMat {ℓ : ℕ} (hℓ : (ℓ : ℤ) ≠ 0) {g : Matrix (Fin 2) (Fin 2) ℤ}
+    (hg : (ℓ : ℤ) ∣ g 0 1) : (heckeConjMat ℓ g).det = g.det := by
+  have h := congrArg Matrix.det (heckeConjMat_mul_alphaMat hg)
+  rw [Matrix.det_mul, Matrix.det_mul, det_alphaMat] at h
+  exact mul_right_cancel₀ hℓ (by linear_combination h)
+
+theorem heckeConjMat_one (ℓ : ℕ) : heckeConjMat ℓ (1 : Matrix (Fin 2) (Fin 2) ℤ) = 1 := by
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp [heckeConjMat]
+
+theorem heckeConjMat_injective {ℓ : ℕ} (hℓ : (ℓ : ℤ) ≠ 0) {g h : Matrix (Fin 2) (Fin 2) ℤ}
+    (hg : (ℓ : ℤ) ∣ g 0 1) (hh : (ℓ : ℤ) ∣ h 0 1)
+    (e : heckeConjMat ℓ g = heckeConjMat ℓ h) : g = h := by
+  have key : alphaMat ℓ * g = alphaMat ℓ * h := by
+    rw [← heckeConjMat_mul_alphaMat hg, ← heckeConjMat_mul_alphaMat hh, e]
+  ext i j
+  have h0 := congrFun (congrFun key 0) j
+  have h1 := congrFun (congrFun key 1) j
+  simp only [Matrix.mul_apply, Fin.sum_univ_two, alphaMat_apply_zero_zero,
+    alphaMat_apply_zero_one, alphaMat_apply_one_zero, alphaMat_apply_one_one,
+    one_mul, zero_mul, add_zero, zero_add] at h0 h1
+  fin_cases i
+  · exact h0
+  · exact mul_left_cancel₀ hℓ h1
+
+end ConjMatrix
+
+section HeckeSubgroup
+
+def heckeUpperSL (ℓ : ℕ) : Subgroup SL(2, ℤ) where
+  carrier := {g | (ℓ : ℤ) ∣ g 0 1}
+  one_mem' := by simp
+  mul_mem' := by
+    intro a b ha hb
+    simp only [Set.mem_ofPred_eq] at *
+    have h : (ℓ : ℤ) ∣ (a.1 * b.1) 0 1 := by
+      rw [(Matrix.two_mul_expl a.1 b.1).2.1]
+      exact dvd_add (hb.mul_left _) (ha.mul_right _)
+    exact h
+  inv_mem' := by
+    intro a ha
+    simp only [Set.mem_ofPred_eq] at *
+    rw [Matrix.SpecialLinearGroup.SL2_inv_expl a]
+    simpa using ha
+
+@[simp]
+theorem mem_heckeUpperSL {ℓ : ℕ} {g : SL(2, ℤ)} : g ∈ heckeUpperSL ℓ ↔ (ℓ : ℤ) ∣ g 0 1 :=
+  Iff.rfl
+
+variable (N ℓ : ℕ)
+
+def heckeUpper : Subgroup (Gamma0 N) := (heckeUpperSL ℓ).subgroupOf (Gamma0 N)
+
+theorem mem_heckeUpper {γ : Gamma0 N} :
+    γ ∈ heckeUpper N ℓ ↔ (ℓ : ℤ) ∣ (γ : SL(2, ℤ)) 0 1 :=
+  Iff.rfl
+
+def gammaZeroRed : Gamma0 N →* SL(2, ZMod ℓ) :=
+  (Matrix.SpecialLinearGroup.map (n := Fin 2) (Int.castRingHom (ZMod ℓ))).comp
+    (Gamma0 N).subtype
+
+theorem ker_gammaZeroRed_le_heckeUpper : (gammaZeroRed N ℓ).ker ≤ heckeUpper N ℓ := by
+  intro γ hγ
+  rw [MonoidHom.mem_ker] at hγ
+  rw [mem_heckeUpper]
+  have h01 : ((((γ : SL(2, ℤ)) 0 1 : ℤ) : ZMod ℓ)) = 0 := by
+    have h := congrArg (fun A : SL(2, ZMod ℓ) => A 0 1) hγ
+    simpa [gammaZeroRed, Matrix.one_apply] using h
+  exact_mod_cast (ZMod.intCast_zmod_eq_zero_iff_dvd _ ℓ).mp h01
+
+instance instFiniteIndexHeckeUpper [NeZero ℓ] : (heckeUpper N ℓ).FiniteIndex :=
+  haveI : (gammaZeroRed N ℓ).ker.FiniteIndex := Subgroup.finiteIndex_ker _
+  Subgroup.finiteIndex_of_le (ker_gammaZeroRed_le_heckeUpper N ℓ)
+
+variable [NeZero ℓ]
+
+def heckeConjSL (γ : heckeUpper N ℓ) : SL(2, ℤ) :=
+  ⟨heckeConjMat ℓ ((γ : Gamma0 N) : SL(2, ℤ)), by
+    rw [det_heckeConjMat (Int.natCast_ne_zero.mpr (NeZero.ne ℓ)) ((mem_heckeUpper N ℓ).mp γ.2)]
+    exact ((γ : Gamma0 N) : SL(2, ℤ)).2⟩
+
+@[simp]
+theorem coe_heckeConjSL (γ : heckeUpper N ℓ) :
+    (heckeConjSL N ℓ γ : Matrix (Fin 2) (Fin 2) ℤ) =
+      heckeConjMat ℓ ((γ : Gamma0 N) : SL(2, ℤ)) :=
+  rfl
+
+theorem heckeConjSL_mem_Gamma0 (γ : heckeUpper N ℓ) : heckeConjSL N ℓ γ ∈ Gamma0 N := by
+  rw [Gamma0_mem]
+  change (((heckeConjMat ℓ ((γ : Gamma0 N) : SL(2, ℤ))) 1 0 : ℤ) : ZMod N) = 0
+  rw [heckeConjMat_apply_one_zero, Int.cast_mul]
+  have hc : ((((γ : Gamma0 N) : SL(2, ℤ)) 1 0 : ℤ) : ZMod N) = 0 :=
+    Gamma0_mem.mp (γ : Gamma0 N).2
+  rw [hc, zero_mul]
+
+def heckeConj : heckeUpper N ℓ →* Gamma0 N where
+  toFun γ := ⟨heckeConjSL N ℓ γ, heckeConjSL_mem_Gamma0 N ℓ γ⟩
+  map_one' := by
+    refine Subtype.ext (Subtype.ext ?_)
+    change heckeConjMat ℓ (1 : Matrix (Fin 2) (Fin 2) ℤ) = (1 : Matrix (Fin 2) (Fin 2) ℤ)
+    exact heckeConjMat_one ℓ
+  map_mul' γ δ := by
+    refine Subtype.ext (Subtype.ext ?_)
+    change heckeConjMat ℓ
+        ((((γ : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) *
+          (((δ : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)) =
+      heckeConjMat ℓ (((γ : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) *
+        heckeConjMat ℓ (((δ : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)
+    exact heckeConjMat_mul (Int.natCast_ne_zero.mpr (NeZero.ne ℓ))
+      ((mem_heckeUpper N ℓ).mp γ.2) ((mem_heckeUpper N ℓ).mp δ.2)
+
+@[simp]
+theorem coe_heckeConj (γ : heckeUpper N ℓ) :
+    ((heckeConj N ℓ γ : Gamma0 N) : SL(2, ℤ)) = heckeConjSL N ℓ γ :=
+  rfl
+
+theorem heckeConj_injective : Function.Injective (heckeConj N ℓ) := by
+  intro γ δ h
+  have hmat : heckeConjMat ℓ (((γ : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) =
+      heckeConjMat ℓ (((δ : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) :=
+    congrArg (fun x : Gamma0 N => ((x : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)) h
+  exact Subtype.ext (Subtype.ext (Subtype.ext (heckeConjMat_injective
+    (Int.natCast_ne_zero.mpr (NeZero.ne ℓ)) ((mem_heckeUpper N ℓ).mp γ.2)
+    ((mem_heckeUpper N ℓ).mp δ.2) hmat)))
+
+end HeckeSubgroup
+
+section Transfer
+
+variable {G : Type*} [Group G] (H : Subgroup G) {A : Type*} [AddCommGroup A]
+
+def resHom : (Additive G →+ A) →+ (Additive H →+ A) :=
+  AddMonoidHom.mk' (fun φ => φ.comp (MonoidHom.toAdditive H.subtype)) fun _ _ => rfl
+
+@[simp]
+theorem resHom_apply (φ : Additive G →+ A) (γ : H) :
+    resHom H φ (Additive.ofMul γ) = φ (Additive.ofMul (γ : G)) :=
+  rfl
+
+noncomputable def transferAux (g : G) (q : G ⧸ H) : H :=
+  ⟨(g • q).out⁻¹ * (g * q.out), by
+    refine QuotientGroup.eq.mp ?_
+    rw [QuotientGroup.out_eq']
+    show g • q = ((g * q.out : G) : G ⧸ H)
+    rw [show ((g * q.out : G) : G ⧸ H) = g • ((q.out : G) : G ⧸ H) from rfl,
+      QuotientGroup.out_eq']⟩
+
+@[simp]
+theorem coe_transferAux (g : G) (q : G ⧸ H) :
+    (transferAux H g q : G) = (g • q).out⁻¹ * (g * q.out) :=
+  rfl
+
+theorem transferAux_mul (g₁ g₂ : G) (q : G ⧸ H) :
+    transferAux H (g₁ * g₂) q = transferAux H g₁ (g₂ • q) * transferAux H g₂ q := by
+  ext
+  push_cast [coe_transferAux]
+  rw [mul_smul]
+  group
+
+variable [H.FiniteIndex]
+
+noncomputable def coresHom : (Additive H →+ A) →+ (Additive G →+ A) :=
+  AddMonoidHom.mk'
+    (fun φ =>
+      let := H.fintypeQuotientOfFiniteIndex
+      AddMonoidHom.mk'
+        (fun g => ∑ q : G ⧸ H, φ (Additive.ofMul (transferAux H g.toMul q)))
+        (fun g₁ g₂ => by
+          change ∑ q : G ⧸ H, φ (Additive.ofMul (transferAux H (g₁.toMul * g₂.toMul) q)) =
+            (∑ q : G ⧸ H, φ (Additive.ofMul (transferAux H g₁.toMul q))) +
+              ∑ q : G ⧸ H, φ (Additive.ofMul (transferAux H g₂.toMul q))
+          simp_rw [transferAux_mul, ofMul_mul, map_add]
+          rw [Finset.sum_add_distrib]
+          exact congrArg₂ (· + ·)
+            (Fintype.sum_bijective (g₂.toMul • ·) (MulAction.bijective g₂.toMul)
+              (fun q => φ (Additive.ofMul (transferAux H g₁.toMul (g₂.toMul • q))))
+              (fun q => φ (Additive.ofMul (transferAux H g₁.toMul q))) fun q => rfl) rfl))
+    (fun φ ψ => by
+      let := H.fintypeQuotientOfFiniteIndex
+      ext g
+      exact Finset.sum_add_distrib)
+
+theorem coresHom_apply (φ : Additive H →+ A) (g : G) :
+    letI := H.fintypeQuotientOfFiniteIndex
+    coresHom H φ (Additive.ofMul g) =
+      ∑ q : G ⧸ H, φ (Additive.ofMul (transferAux H g q)) :=
+  rfl
+
+end Transfer
+
+section Pullback
+
+variable {G K : Type*} [Group G] [Group K] {A : Type*} [AddCommGroup A]
+
+def pullbackHom (f : G →* K) : (Additive K →+ A) →+ (Additive G →+ A) :=
+  AddMonoidHom.mk' (fun φ => φ.comp (MonoidHom.toAdditive f)) fun _ _ => rfl
+
+@[simp]
+theorem pullbackHom_apply (f : G →* K) (φ : Additive K →+ A) (g : G) :
+    pullbackHom f φ (Additive.ofMul g) = φ (Additive.ofMul (f g)) :=
+  rfl
+
+end Pullback
+
+section HeckeOperator
+
+variable (N ℓ : ℕ) [NeZero ℓ] (A : Type*) [AddCommGroup A]
+
+noncomputable def heckeOperatorHom :
+    (Additive (Gamma0 N) →+ A) →+ (Additive (Gamma0 N) →+ A) :=
+  (coresHom (heckeUpper N ℓ)).comp (pullbackHom (heckeConj N ℓ))
+
+theorem heckeOperatorHom_apply (φ : Additive (Gamma0 N) →+ A) (g : Gamma0 N) :
+    letI := (heckeUpper N ℓ).fintypeQuotientOfFiniteIndex
+    heckeOperatorHom N ℓ A φ (Additive.ofMul g) =
+      ∑ q : Gamma0 N ⧸ heckeUpper N ℓ,
+        φ (Additive.ofMul ((heckeConj N ℓ (transferAux (heckeUpper N ℓ) g q) : Gamma0 N))) :=
+  rfl
+
+noncomputable abbrev uOperatorHom (q : ℕ) [NeZero q] :
+    (Additive (Gamma0 N) →+ A) →+ (Additive (Gamma0 N) →+ A) :=
+  heckeOperatorHom N q A
+
+def HeckeIndexEq : Prop := (heckeUpper N ℓ).index = ℓ + 1
+
+end HeckeOperator
+
+end HeckeEis
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_HahnSeries_Monodromy.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_HahnSeries_Monodromy.lean
new file mode 100644
index 0000000000..766e99a973
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_HahnSeries_Monodromy.lean
@@ -0,0 +1,285 @@
+/-
+Based on Prove2Me node HahnSeries_Monodromy
+(6d32962d-7068-5001-a021-41e07293fd91) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.HahnSeries.PowerSeries
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+
+/-!
+# Character twists of Hahn series; point transport along fixing automorphisms
+
+Definition: `HahnSeries_Monodromy` (`6d32962d-7068-5001-a021-41e07293fd91`), by Claude, 2026-09-05.
+
+Let $R$ be a commutative ring. For a character $\chi \colon \mathrm{Multiplicative}\,\mathbb{Q} \to
+R^{\times}$, [`HahnSeries.hahnTwistFun`](../def/HahnSeries_Monodromy.html#L10) sends a Hahn series
+$x$ with value group $\mathbb{Q}$ to the series whose coefficient in degree $a \in \mathbb{Q}$ is
+$\chi(a)\,x_a$; since the multipliers are units, the support is unchanged and remains partially
+well-ordered. [`HahnSeries.hahnTwist`](../def/HahnSeries_Monodromy.html#L35) packages this as an
+$R$-algebra automorphism of `HahnSeries ℚ R` (relative to the power-series algebra structure), with
+inverse the twist by $\chi^{-1}$; multiplicativity comes from $\chi(a+b)=\chi(a)\chi(b)$ on the
+antidiagonal, and $\chi(0)=1$ gives compatibility with the algebra map. A lemma layer records the
+coefficients, the action on a monomial $\mathrm{single}\ a\ r \mapsto \mathrm{single}\ a\
+(\chi(a)r)$, and the invariance of the support and of the order.
+[`HahnSeries.hahnTwistHom`](../def/HahnSeries_Monodromy.html#L102) is the resulting monoid
+homomorphism from the character group to the group of $R$-algebra automorphisms.
+[`HahnSeries.MonoChar R`](../def/HahnSeries_Monodromy.html#L95) is the subgroup of characters
+normalised by $\chi(1)=1$, i.e. the kernel of evaluation at the element $1 \in \mathbb{Q}$, and
+[`HahnSeries.monodromy R`](../def/HahnSeries_Monodromy.html#L121) is its image under `hahnTwistHom`;
+consequently every element of `monodromy R` fixes the monomial $\mathrm{single}\ 1\ 1$.
+
+The second part concerns a Weierstrass curve $E$ over a field $K$ which is an algebra over a field
+$k$, together with an automorphism $\sigma \in \mathrm{Aut}_k(K)$ satisfying $E^{\sigma} = E$, i.e.
+the coefficientwise image of $E$ under $\sigma$ is $E$ itself. Then $\sigma$ preserves nonsingular
+affine solutions, and
+[`WeierstrassCurve.Affine.Point.fixedTransport`](../def/HahnSeries_Monodromy.html#L199) is the
+induced additive automorphism of the group of affine points: it fixes the point at infinity and
+sends $(x,y)$ to $(\sigma x, \sigma y)$. Additivity rests on the compatibility of $\mathrm{negY}$,
+the slope and the addition formulas with $\sigma$ under the invariance hypothesis, with the case
+distinction of the chord–tangent law handled through the auxiliary declarations.
+
+**Relation to Mathlib.** Hahn series with their power-series algebra structure, and the affine point
+group of a Weierstrass curve together with the behaviour of the addition formulas under a ring
+homomorphism, are Mathlib's; the character twist, the normalised character subgroup and the
+monodromy subgroup are the project's own, as is the transport of points along an automorphism fixing
+the curve (Mathlib's point maps go along a base change of the curve rather than from invariance of a
+fixed curve).
+
+**Where it is used.** These constructions supply, on the one hand, a group of automorphisms of
+fractional-power expansions that acts trivially on the distinguished monomial of degree $1$, and on
+the other hand the action of a field automorphism fixing a Weierstrass curve on its group of affine
+points; both are used by later modules of the development.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+public noncomputable section publicSection
+
+namespace HahnSeries
+
+variable {R : Type*} [CommRing R]
+
+def hahnTwistFun (χ : Multiplicative ℚ →* Rˣ) (x : HahnSeries ℚ R) : HahnSeries ℚ R where
+  coeff a := χ (Multiplicative.ofAdd a) * x.coeff a
+  isPWO_support' := x.isPWO_support'.mono fun a ha => by
+    simp only [Function.mem_support] at ha ⊢
+    exact fun h => ha (by rw [h, mul_zero])
+
+theorem coeff_hahnTwistFun (χ : Multiplicative ℚ →* Rˣ) (x : HahnSeries ℚ R) (a : ℚ) :
+    (hahnTwistFun χ x).coeff a = χ (Multiplicative.ofAdd a) * x.coeff a :=
+  (rfl)
+
+theorem support_hahnTwistFun (χ : Multiplicative ℚ →* Rˣ) (x : HahnSeries ℚ R) :
+    (hahnTwistFun χ x).support = x.support := by
+  ext a
+  rw [mem_support, mem_support, coeff_hahnTwistFun]
+  exact not_congr (Units.mul_right_eq_zero _)
+
+theorem hahnTwistFun_single (χ : Multiplicative ℚ →* Rˣ) (a : ℚ) (r : R) :
+    hahnTwistFun χ (single a r) = single a (χ (Multiplicative.ofAdd a) * r) := by
+  ext b
+  rw [coeff_hahnTwistFun]
+  by_cases hb : b = a
+  · subst hb
+    rw [coeff_single_same, coeff_single_same]
+  · rw [coeff_single_of_ne hb, coeff_single_of_ne hb, mul_zero]
+
+def hahnTwist (χ : Multiplicative ℚ →* Rˣ) : HahnSeries ℚ R ≃ₐ[R] HahnSeries ℚ R where
+  toFun := hahnTwistFun χ
+  invFun := hahnTwistFun χ⁻¹
+  left_inv x := by
+    ext a
+    rw [coeff_hahnTwistFun, coeff_hahnTwistFun, ← mul_assoc, ← Units.val_mul,
+      MonoidHom.inv_apply, inv_mul_cancel, Units.val_one, one_mul]
+  right_inv x := by
+    ext a
+    rw [coeff_hahnTwistFun, coeff_hahnTwistFun, ← mul_assoc, ← Units.val_mul,
+      MonoidHom.inv_apply, mul_inv_cancel, Units.val_one, one_mul]
+  map_mul' x y := by
+    ext a
+    have hset : Finset.antidiagonal (hahnTwistFun χ x).isPWO_support
+        (hahnTwistFun χ y).isPWO_support a =
+        Finset.antidiagonal x.isPWO_support y.isPWO_support a := by
+      ext ij
+      simp only [Finset.mem_antidiagonal, support_hahnTwistFun]
+    rw [coeff_hahnTwistFun, coeff_mul, coeff_mul, hset, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun ij hij => ?_
+    obtain ⟨-, -, hsum⟩ := Finset.mem_antidiagonal.mp hij
+    rw [coeff_hahnTwistFun, coeff_hahnTwistFun, mul_mul_mul_comm, ← Units.val_mul, ← map_mul,
+      ← ofAdd_add, hsum]
+  map_add' x y := by
+    ext a
+    rw [coeff_hahnTwistFun, coeff_add, coeff_add, coeff_hahnTwistFun, coeff_hahnTwistFun,
+      mul_add]
+  commutes' r := by
+    have hC : algebraMap R (HahnSeries ℚ R) r = HahnSeries.C r := by
+      rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_eq, HahnSeries.ofPowerSeries_C]
+    have hCs : (HahnSeries.C r : HahnSeries ℚ R) = single (0 : ℚ) r := rfl
+    change hahnTwistFun χ _ = _
+    rw [hC, hCs, hahnTwistFun_single, ofAdd_zero, map_one, Units.val_one, one_mul]
+
+@[simp]
+theorem coeff_hahnTwist (χ : Multiplicative ℚ →* Rˣ) (x : HahnSeries ℚ R) (a : ℚ) :
+    (hahnTwist χ x).coeff a = χ (Multiplicative.ofAdd a) * x.coeff a :=
+  (rfl)
+
+theorem hahnTwist_single (χ : Multiplicative ℚ →* Rˣ) (a : ℚ) (r : R) :
+    hahnTwist χ (single a r) = single a (χ (Multiplicative.ofAdd a) * r) :=
+  hahnTwistFun_single χ a r
+
+theorem support_hahnTwist (χ : Multiplicative ℚ →* Rˣ) (x : HahnSeries ℚ R) :
+    (hahnTwist χ x).support = x.support :=
+  support_hahnTwistFun χ x
+
+theorem order_hahnTwist (χ : Multiplicative ℚ →* Rˣ) (x : HahnSeries ℚ R) :
+    (hahnTwist χ x).order = x.order := by
+  by_cases hx : x = 0
+  · rw [hx, map_zero]
+  · have hx' : hahnTwist χ x ≠ 0 := fun h =>
+      hx ((hahnTwist χ).injective (by rw [h, map_zero]))
+    refine le_antisymm (order_le_of_coeff_ne_zero ?_) (order_le_of_coeff_ne_zero ?_)
+    · rw [coeff_hahnTwist]
+      exact fun h0 => hx (coeff_order_eq_zero.mp ((Units.mul_right_eq_zero _).mp h0))
+    · exact fun h0 => hx' (coeff_order_eq_zero.mp (by rw [coeff_hahnTwist, h0, mul_zero]))
+
+variable (R) in
+def MonoChar : Subgroup (Multiplicative ℚ →* Rˣ) :=
+  (MonoidHom.eval (Multiplicative.ofAdd (1 : ℚ))).ker
+
+theorem mem_monoChar_iff {χ : Multiplicative ℚ →* Rˣ} :
+    χ ∈ MonoChar R ↔ χ (Multiplicative.ofAdd (1 : ℚ)) = 1 :=
+  Iff.rfl
+
+def hahnTwistHom : (Multiplicative ℚ →* Rˣ) →* (HahnSeries ℚ R ≃ₐ[R] HahnSeries ℚ R) where
+  toFun := hahnTwist
+  map_one' := by
+    refine AlgEquiv.ext fun x => ?_
+    ext a
+    rw [coeff_hahnTwist, MonoidHom.one_apply, Units.val_one, one_mul, AlgEquiv.one_apply]
+  map_mul' χ₁ χ₂ := by
+    refine AlgEquiv.ext fun x => ?_
+    ext a
+    rw [coeff_hahnTwist, AlgEquiv.mul_apply, coeff_hahnTwist, coeff_hahnTwist,
+      MonoidHom.mul_apply, Units.val_mul, mul_assoc]
+
+theorem hahnTwistHom_apply (χ : Multiplicative ℚ →* Rˣ) :
+    (hahnTwistHom : (Multiplicative ℚ →* Rˣ) →* (HahnSeries ℚ R ≃ₐ[R] HahnSeries ℚ R)) χ =
+      hahnTwist χ :=
+  (rfl)
+
+variable (R) in
+@[expose] def monodromy : Subgroup (HahnSeries ℚ R ≃ₐ[R] HahnSeries ℚ R) :=
+  (MonoChar R).map hahnTwistHom
+
+theorem fixes_single_one_of_mem_monodromy {m : HahnSeries ℚ R ≃ₐ[R] HahnSeries ℚ R}
+    (hm : m ∈ monodromy R) :
+    m (single (1 : ℚ) (1 : R)) = single (1 : ℚ) (1 : R) := by
+  obtain ⟨χ, hχ, rfl⟩ := hm
+  rw [hahnTwistHom_apply, hahnTwist_single, mem_monoChar_iff.mp hχ, Units.val_one, one_mul]
+
+end HahnSeries
+
+namespace WeierstrassCurve.Affine.Point
+
+open WeierstrassCurve
+
+variable {k K : Type*} [Field k] [Field K] [Algebra k K]
+
+theorem nonsingular_of_fixed (σ : K ≃ₐ[k] K) (E : WeierstrassCurve K)
+    (hE : E.map (σ : K →+* K) = E) {x y : K} (h : E.toAffine.Nonsingular x y) :
+    E.toAffine.Nonsingular (σ x) (σ y) := by
+  have hE2 : E.toAffine.map (σ : K →+* K) = E.toAffine := hE
+  have h' := (Affine.map_nonsingular (W := E.toAffine) (f := (σ : K →+* K))
+    σ.injective x y).mpr h
+  rwa [hE2] at h'
+
+private def fixedFun (σ : K ≃ₐ[k] K) (E : WeierstrassCurve K)
+    (hE : E.map (σ : K →+* K) = E) : E.toAffine.Point → E.toAffine.Point := fun P =>
+  match P with
+  | 0 => 0
+  | some x y h => some (σ x) (σ y) (nonsingular_of_fixed σ E hE h)
+
+private theorem map_symm_eq (σ : K ≃ₐ[k] K) (E : WeierstrassCurve K)
+    (hE : E.map (σ : K →+* K) = E) : E.map (σ.symm : K →+* K) = E := by
+  conv_lhs => rw [← hE]
+  rw [WeierstrassCurve.map_map]
+  have h : (σ.symm : K →+* K).comp (σ : K →+* K) = RingHom.id K := by
+    ext z
+    exact σ.symm_apply_apply z
+  rw [h, WeierstrassCurve.map_id]
+
+private theorem fixedFun_add [DecidableEq K] (σ : K ≃ₐ[k] K) (E : WeierstrassCurve K)
+    (hE : E.map (σ : K →+* K) = E) (P Q : E.toAffine.Point) :
+    fixedFun σ E hE (P + Q) = fixedFun σ E hE P + fixedFun σ E hE Q := by
+  have hE2 : E.toAffine.map (σ : K →+* K) = E.toAffine := hE
+  have hneg : ∀ x y : K, E.toAffine.negY (σ x) (σ y) = σ (E.toAffine.negY x y) := by
+    intro x y
+    conv_lhs => rw [← hE2]
+    exact Affine.map_negY (W' := E.toAffine) (σ : K →+* K) x y
+  have hslope : ∀ x₁ x₂ y₁ y₂ : K,
+      E.toAffine.slope (σ x₁) (σ x₂) (σ y₁) (σ y₂) = σ (E.toAffine.slope x₁ x₂ y₁ y₂) := by
+    intro x₁ x₂ y₁ y₂
+    conv_lhs => rw [← hE2]
+    exact Affine.map_slope (W := E.toAffine) (σ : K →+* K) x₁ x₂ y₁ y₂
+  have haddX : ∀ x₁ x₂ ℓ : K,
+      E.toAffine.addX (σ x₁) (σ x₂) (σ ℓ) = σ (E.toAffine.addX x₁ x₂ ℓ) := by
+    intro x₁ x₂ ℓ
+    conv_lhs => rw [← hE2]
+    exact Affine.map_addX (W' := E.toAffine) (σ : K →+* K) x₁ x₂ ℓ
+  have haddY : ∀ x₁ x₂ y₁ ℓ : K,
+      E.toAffine.addY (σ x₁) (σ x₂) (σ y₁) (σ ℓ) = σ (E.toAffine.addY x₁ x₂ y₁ ℓ) := by
+    intro x₁ x₂ y₁ ℓ
+    conv_lhs => rw [← hE2]
+    exact Affine.map_addY (W' := E.toAffine) (f := (σ : K →+* K)) (x₁ := x₁) (x₂ := x₂)
+      (y₁ := y₁) (ℓ := ℓ)
+  rcases P with _ | ⟨x₁, y₁, h₁⟩ <;> rcases Q with _ | ⟨x₂, y₂, h₂⟩
+  any_goals rfl
+  by_cases hxy : x₁ = x₂ ∧ y₁ = E.toAffine.negY x₂ y₂
+  · rw [add_of_Y_eq hxy.1 hxy.2]
+    exact (add_of_Y_eq (congrArg σ hxy.1) (by rw [hxy.2, hneg])).symm
+  · have hxy' : ¬(σ x₁ = σ x₂ ∧ σ y₁ = E.toAffine.negY (σ x₂) (σ y₂)) := fun h =>
+      hxy ⟨σ.injective h.1, σ.injective (by rw [hneg] at h; exact h.2)⟩
+    rw [add_some hxy]
+    change some _ _ _ = some _ _ _ + some _ _ _
+    rw [add_some hxy']
+    congr 1
+    · rw [hslope, haddX]
+    · rw [hslope, haddY]
+
+def fixedTransport [DecidableEq K] (σ : K ≃ₐ[k] K) (E : WeierstrassCurve K)
+    (hE : E.map (σ : K →+* K) = E) : E.toAffine.Point ≃+ E.toAffine.Point where
+  toFun := fixedFun σ E hE
+  invFun := fixedFun σ.symm E (map_symm_eq σ E hE)
+  left_inv P := by
+    rcases P with _ | ⟨x, y, h⟩
+    · rfl
+    · change some _ _ _ = some x y h
+      congr 1
+      · exact σ.symm_apply_apply x
+      · exact σ.symm_apply_apply y
+  right_inv P := by
+    rcases P with _ | ⟨x, y, h⟩
+    · rfl
+    · change some _ _ _ = some x y h
+      congr 1
+      · exact σ.apply_symm_apply x
+      · exact σ.apply_symm_apply y
+  map_add' := fixedFun_add σ E hE
+
+theorem fixedTransport_zero [DecidableEq K] (σ : K ≃ₐ[k] K) (E : WeierstrassCurve K)
+    (hE : E.map (σ : K →+* K) = E) : fixedTransport σ E hE 0 = 0 :=
+  (rfl)
+
+theorem fixedTransport_some [DecidableEq K] (σ : K ≃ₐ[k] K) (E : WeierstrassCurve K)
+    (hE : E.map (σ : K →+* K) = E) (x y : K) (h : E.toAffine.Nonsingular x y) :
+    fixedTransport σ E hE (some x y h) = some (σ x) (σ y) (nonsingular_of_fixed σ E hE h) :=
+  (rfl)
+
+end WeierstrassCurve.Affine.Point
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_HahnSeries_RamificationBound.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_HahnSeries_RamificationBound.lean
new file mode 100644
index 0000000000..e7fbc20dd0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_HahnSeries_RamificationBound.lean
@@ -0,0 +1,90 @@
+/-
+Based on Prove2Me node HahnSeries_RamificationBound
+(46a98065-ba27-5e49-92c5-717ae9810d43) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Field.Subfield.Basic
+public import Mathlib.Algebra.Order.Ring.Star
+public import Mathlib.Data.Rat.Star
+public import Mathlib.RingTheory.HahnSeries.Summable
+
+/-!
+# Ramification bounds and e-ramified Puiseux subfields of Hahn series
+
+Definition: `HahnSeries_RamificationBound` (`46a98065-ba27-5e49-92c5-717ae9810d43`), by Claude,
+2026-09-05.
+
+Over a field $K$, the Hahn series field $\mathrm{HahnSeries}\ \mathbb{Q}\ K$ plays the role of the
+field of Puiseux series $K((t^{\mathbb Q}))$, and this module records the apparatus for exponents
+with denominator dividing a fixed natural number $e$. First, `ramScale e` is the additive monoid
+homomorphism $\mathbb Z \to \mathbb Q$ given by $k \mapsto k/e$ (so, by the convention $k/0 = 0$, it
+is the zero map when $e = 0$); `ramScale_apply` records its value, `ramScale_injective` states that
+it is injective when $e > 0$, and `ramScale_le_iff` states that for $e > 0$ it reflects and
+preserves the order, $k/e \le l/e \iff k \le l$. Using these two facts, `puiseuxRamEmb` is the ring
+homomorphism $\mathrm{HahnSeries}\ \mathbb Z\ K \to \mathrm{HahnSeries}\ \mathbb Q\ K$ obtained by
+reindexing the exponent group along $k \mapsto k/e$, that is, the embedding $K((s)) \hookrightarrow
+K((t^{\mathbb Q}))$ sending $s$ to $t^{1/e}$.
+
+Second, `HasRamBound e y` is the predicate on a Hahn series $y$ with rational exponents asserting
+that its support is contained in the image of $k \mapsto k/e$, i.e. that all exponents occurring in
+$y$ lie in $\tfrac1e\mathbb Z$; for $e = 0$ this reads as support contained in $\{0\}$. Third, for
+$e > 0$, `puiseuxRamSubfield K he` is the subfield of $\mathrm{HahnSeries}\ \mathbb Q\ K$ given by
+the field range of `puiseuxRamEmb`, i.e. $K((t^{1/e}))$ realised inside $K((t^{\mathbb Q}))$. The
+definition is by image, not by the support condition: the identification of this subfield with the
+set of series satisfying `HasRamBound e` is a separate assertion and is not built into the
+definitions here.
+
+**Relation to Mathlib.** The ambient objects are Mathlib's `HahnSeries` and its exponent-reindexing
+ring homomorphism `HahnSeries.embDomainRingHom`; the scaling map `ramScale`, the ramification-bound
+predicate and the $e$-ramified subfield are the project's own notions.
+
+**Where it is used.** These definitions provide the series-theoretic language for Puiseux expansions
+of bounded ramification index, used in the treatment of the $j$-line covering by modular curves,
+where local branches have ramification index dividing $3$ above $j=0$, dividing $2$ above $j=1728$,
+and $1$ elsewhere.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public noncomputable section publicSection
+
+namespace HahnSeries
+
+variable {K : Type*} [Field K]
+
+def ramScale (e : ℕ) : ℤ →+ ℚ where
+  toFun k := (k : ℚ) / e
+  map_zero' := by simp
+  map_add' a b := by simp only [Int.cast_add]; rw [add_div]
+
+@[simp] theorem ramScale_apply (e : ℕ) (k : ℤ) : ramScale e k = (k : ℚ) / e := rfl
+
+theorem ramScale_injective {e : ℕ} (he : 0 < e) : Function.Injective (ramScale e) := by
+  intro a b hab
+  have he' : (e : ℚ) ≠ 0 := Nat.cast_ne_zero.mpr he.ne'
+  simp only [ramScale_apply, div_eq_div_iff he' he'] at hab
+  exact_mod_cast mul_right_cancel₀ he' hab
+
+theorem ramScale_le_iff {e : ℕ} (he : 0 < e) (a b : ℤ) :
+    ramScale e a ≤ ramScale e b ↔ a ≤ b := by
+  have he' : (0 : ℚ) < e := Nat.cast_pos.mpr he
+  simp only [ramScale_apply, div_le_div_iff_of_pos_right he', Int.cast_le]
+
+def puiseuxRamEmb {e : ℕ} (he : 0 < e) : HahnSeries ℤ K →+* HahnSeries ℚ K :=
+  HahnSeries.embDomainRingHom (ramScale e) (ramScale_injective he) (ramScale_le_iff he)
+
+def HasRamBound (e : ℕ) (y : HahnSeries ℚ K) : Prop :=
+  y.support ⊆ Set.range (fun k : ℤ => (k : ℚ) / e)
+
+variable (K) in
+def puiseuxRamSubfield {e : ℕ} (he : 0 < e) : Subfield (HahnSeries ℚ K) :=
+  (puiseuxRamEmb (K := K) he).fieldRange
+
+end HahnSeries
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_HeckeEis_BinaryFormRep.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_HeckeEis_BinaryFormRep.lean
new file mode 100644
index 0000000000..04a4b9cf9e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_HeckeEis_BinaryFormRep.lean
@@ -0,0 +1,206 @@
+/-
+Based on Prove2Me node HeckeEis_BinaryFormRep
+(b7d27b98-8127-543a-b6fd-ba1172da24bf) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.Finite.Basic
+public import Mathlib.RepresentationTheory.Basic
+public import Mathlib.RingTheory.MvPolynomial.IrreducibleQuadratic
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ProjectiveLine
+
+/-!
+# Binary forms: substitution action and evaluation on the projective line
+
+Definition: `HeckeEis_BinaryFormRep` (`b7d27b98-8127-543a-b6fd-ba1172da24bf`), by Claude,
+2026-09-05.
+
+Over a commutative ring $K$, `BinaryForm K n` abbreviates the degree-$n$ homogeneous component
+`MvPolynomial.homogeneousSubmodule (Fin 2) K n`, i.e. the submodule of $K[X_0,X_1]$ spanned by the
+monomials of total degree $n$. For an integral $2\times 2$ matrix $M$, `binarySubst K M` is the
+$K$-algebra endomorphism of $K[X_0,X_1]$ determined by $X_j \mapsto \sum_i (M_{ij} \bmod K)\,X_i$;
+in classical notation $F \mapsto F\bigl((X_0,X_1)M\bigr)$, the row-vector convention. It fixes
+constants, is the identity for $M = 1$, satisfies $\mathrm{binarySubst}(MM') =
+\mathrm{binarySubst}(M)\circ\mathrm{binarySubst}(M')$, and maps each `BinaryForm K n` into itself.
+Restricting it therefore gives `binaryFormRepSL K n`, a representation of $SL_2(\mathbb{Z})$ on the
+degree-$n$ binary forms (a model of $\mathrm{Sym}^n$ of the standard rank-two module), and, for a
+natural number $\ell$, the $K$-linear endomorphism `binaryFormAlphaAdj K n ℓ` given by substitution
+of $\mathrm{diag}(\ell,1)$, that is $F(X_0,X_1)\mapsto F(\ell X_0, X_1)$.
+
+In the second part $p$ is a prime and $K$ a commutative ring of characteristic $p$. For $F \in
+K[X_0,X_1]$ and a unimodular row $v = (a,c)$ over $\mathbb{Z}/p$ (a pair with $xa+yc=1$ for some
+$x,y$), `evalRow p K F v` is the value of $F$ at the images of $a$ and $c$ in $K$ under
+`ZMod.castHom`. When $F$ is homogeneous of degree $p-1$, this value is unchanged if $v$ is rescaled
+by a unit of $\mathbb{Z}/p$, since such a unit satisfies $u^{p-1}=1$; accordingly `binaryFormEval p
+K` is the $K$-linear map from `BinaryForm K (p-1)` to functions on the projective line
+$\mathbb{P}^1(\mathbb{Z}/p)$ — the quotient of unimodular rows by unit scaling — whose value on the
+class of $v=(a,c)$ is $F(a,c)$. A general auxiliary identity records $F(c\,x) = c^n F(x)$ for $F$
+homogeneous of degree $n$ over any commutative ring.
+
+**Relation to Mathlib.** `BinaryForm` is an abbreviation for Mathlib's
+`MvPolynomial.homogeneousSubmodule`, `binarySubst` is Mathlib's `MvPolynomial.aeval` for a linear
+substitution, and the group actions are packaged as Mathlib `Representation`s; the index set
+$\mathbb{P}^1(\mathbb{Z}/p)$ is the project's own quotient of unimodular rows, not a Mathlib
+projectivization.
+
+**Where it is used.** These two coefficient modules, $\mathrm{Sym}^{p-1}$ in characteristic $p$ and
+the functions on $\mathbb{P}^1(\mathbb{F}_p)$, together with the evaluation map intertwining the
+$SL_2(\mathbb{Z})$-actions and the $\mathrm{diag}(\ell,1)$ operators, provide the dictionary between
+weight $p+1$ at level $N$ and weight $2$ at level $Np$ that is used in the mod-$p$ weight and level
+comparisons of the argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace HeckeEis
+
+open MvPolynomial ModularCurve
+open scoped MatrixGroups
+
+theorem eval_smul_of_isHomogeneous {σ : Type*} {R : Type*} [CommRing R] {φ : MvPolynomial σ R}
+    {n : ℕ}
+    (hφ : φ.IsHomogeneous n) (c : R) (x : σ → R) :
+    MvPolynomial.eval (c • x) φ = c ^ n * MvPolynomial.eval x φ := by
+  classical
+  rw [MvPolynomial.eval_eq, MvPolynomial.eval_eq, Finset.mul_sum]
+  refine Finset.sum_congr rfl fun d hd => ?_
+  have hdeg : ∑ i ∈ d.support, d i = n := by
+    have h := hφ (MvPolynomial.mem_support_iff.mp hd)
+    simpa [Finsupp.degree, Finsupp.weight, Finsupp.sum, Finsupp.linearCombination,
+      Finsupp.lsum] using h
+  simp only [Pi.smul_apply, smul_eq_mul, mul_pow, Finset.prod_mul_distrib,
+    Finset.prod_pow_eq_pow_sum, hdeg]
+  ring
+
+section BinaryForms
+
+variable (K : Type*) [CommRing K]
+
+abbrev BinaryForm (n : ℕ) : Submodule K (MvPolynomial (Fin 2) K) :=
+  MvPolynomial.homogeneousSubmodule (Fin 2) K n
+
+noncomputable def binarySubst (M : Matrix (Fin 2) (Fin 2) ℤ) :
+    MvPolynomial (Fin 2) K →ₐ[K] MvPolynomial (Fin 2) K :=
+  MvPolynomial.aeval fun j => ∑ i : Fin 2, C ((M i j : ℤ) : K) * X i
+
+theorem binarySubst_X (M : Matrix (Fin 2) (Fin 2) ℤ) (j : Fin 2) :
+    binarySubst K M (X j) = ∑ i : Fin 2, C ((M i j : ℤ) : K) * X i :=
+  MvPolynomial.aeval_X _ _
+
+theorem binarySubst_C (M : Matrix (Fin 2) (Fin 2) ℤ) (r : K) : binarySubst K M (C r) = C r := by
+  rw [binarySubst, MvPolynomial.aeval_C, MvPolynomial.algebraMap_eq]
+
+theorem binarySubst_one : binarySubst K (1 : Matrix (Fin 2) (Fin 2) ℤ) = AlgHom.id K _ := by
+  refine MvPolynomial.algHom_ext fun j => ?_
+  rw [binarySubst_X, AlgHom.id_apply, Fin.sum_univ_two]
+  fin_cases j <;> simp [Matrix.one_apply]
+
+theorem binarySubst_mul (M M' : Matrix (Fin 2) (Fin 2) ℤ) :
+    binarySubst K (M * M') = (binarySubst K M).comp (binarySubst K M') := by
+  refine MvPolynomial.algHom_ext fun j => ?_
+  rw [AlgHom.comp_apply, binarySubst_X, binarySubst_X]
+  simp only [Fin.sum_univ_two, Matrix.mul_apply, map_add, map_mul, binarySubst_C, binarySubst_X,
+    Int.cast_add, Int.cast_mul]
+  ring
+
+theorem binarySubst_mem {n : ℕ} (M : Matrix (Fin 2) (Fin 2) ℤ) {F : MvPolynomial (Fin 2) K}
+    (hF : F ∈ BinaryForm K n) : binarySubst K M F ∈ BinaryForm K n := by
+  rw [MvPolynomial.mem_homogeneousSubmodule] at hF ⊢
+  have h := hF.aeval (fun j => ∑ i : Fin 2, C ((M i j : ℤ) : K) * X i)
+    (fun j => MvPolynomial.IsHomogeneous.sum _ _ _ fun i _ => (MvPolynomial.isHomogeneous_X K
+      i).C_mul _)
+  simpa only [binarySubst, one_mul] using h
+
+variable (n : ℕ)
+
+noncomputable def binaryFormRepSL : Representation K SL(2, ℤ) (BinaryForm K n) where
+  toFun g := (binarySubst K (g : Matrix (Fin 2) (Fin 2) ℤ)).toLinearMap.restrict
+    fun F hF => binarySubst_mem K _ hF
+  map_one' := by
+    refine LinearMap.ext fun F => Subtype.ext ?_
+    change binarySubst K ((1 : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) F.1 = F.1
+    rw [Matrix.SpecialLinearGroup.coe_one, binarySubst_one]
+    rfl
+  map_mul' g h := by
+    refine LinearMap.ext fun F => Subtype.ext ?_
+    change binarySubst K ((g * h : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) F.1
+      = binarySubst K (g : Matrix (Fin 2) (Fin 2) ℤ) (binarySubst K (h : Matrix (Fin 2) (Fin 2) ℤ)
+        F.1)
+    rw [Matrix.SpecialLinearGroup.coe_mul, binarySubst_mul]
+    rfl
+
+@[simp]
+theorem binaryFormRepSL_apply_coe (g : SL(2, ℤ)) (F : BinaryForm K n) :
+    ((binaryFormRepSL K n g F : BinaryForm K n) : MvPolynomial (Fin 2) K)
+      = binarySubst K (g : Matrix (Fin 2) (Fin 2) ℤ) F :=
+  rfl
+
+noncomputable def binaryFormAlphaAdj (ℓ : ℕ) : BinaryForm K n →ₗ[K] BinaryForm K n :=
+  (binarySubst K !![(ℓ : ℤ), 0; 0, 1]).toLinearMap.restrict fun _F hF => binarySubst_mem K _ hF
+
+@[simp]
+theorem binaryFormAlphaAdj_apply_coe (ℓ : ℕ) (F : BinaryForm K n) :
+    ((binaryFormAlphaAdj K n ℓ F : BinaryForm K n) : MvPolynomial (Fin 2) K)
+      = binarySubst K !![(ℓ : ℤ), 0; 0, 1] F :=
+  rfl
+
+end BinaryForms
+
+section Eval
+
+variable (p : ℕ) [Fact p.Prime] (K : Type*) [CommRing K] [CharP K p]
+
+noncomputable def evalRow (F : MvPolynomial (Fin 2) K) (v : UnimodularRow (ZMod p)) : K :=
+  MvPolynomial.eval ![ZMod.castHom (dvd_refl p) K v.1.1, ZMod.castHom (dvd_refl p) K v.1.2] F
+
+theorem evalRow_eq_of_unit_mul {F : MvPolynomial (Fin 2) K} (hF : F ∈ BinaryForm K (p - 1))
+    (u : (ZMod p)ˣ) (v w : UnimodularRow (ZMod p))
+    (h1 : (u : ZMod p) * v.1.1 = w.1.1) (h2 : (u : ZMod p) * v.1.2 = w.1.2) :
+    evalRow p K F w = evalRow p K F v := by
+  have hu : (ZMod.castHom (dvd_refl p) K (u : ZMod p)) ^ (p - 1) = 1 := by
+    rw [← map_pow, ZMod.pow_card_sub_one_eq_one (Units.ne_zero u), map_one]
+  have hvec : (![ZMod.castHom (dvd_refl p) K w.1.1, ZMod.castHom (dvd_refl p) K w.1.2] : Fin 2 → K)
+      = (ZMod.castHom (dvd_refl p) K (u : ZMod p)) •
+          ![ZMod.castHom (dvd_refl p) K v.1.1, ZMod.castHom (dvd_refl p) K v.1.2] := by
+    funext i
+    fin_cases i <;> simp [← h1, ← h2, map_mul]
+  unfold evalRow
+  rw [hvec, eval_smul_of_isHomogeneous ((MvPolynomial.mem_homogeneousSubmodule _ _).mp hF), hu,
+    one_mul]
+
+noncomputable def binaryFormEval : BinaryForm K (p - 1) →ₗ[K] (ProjectiveLine (ZMod p) → K) where
+  toFun F := Quotient.lift (evalRow p K (F : MvPolynomial (Fin 2) K)) fun v w hvw => by
+    obtain ⟨u, h1, h2⟩ := hvw
+    exact (evalRow_eq_of_unit_mul p K F.2 u v w h1 h2).symm
+  map_add' F G := by
+    funext P
+    induction P using Quotient.inductionOn with
+    | h v =>
+      change evalRow p K ((F + G : BinaryForm K (p - 1)) : MvPolynomial (Fin 2) K) v
+        = evalRow p K (F : MvPolynomial (Fin 2) K) v + evalRow p K (G : MvPolynomial (Fin 2) K) v
+      simp [evalRow]
+  map_smul' c F := by
+    funext P
+    induction P using Quotient.inductionOn with
+    | h v =>
+      change evalRow p K ((c • F : BinaryForm K (p - 1)) : MvPolynomial (Fin 2) K) v
+        = c • evalRow p K (F : MvPolynomial (Fin 2) K) v
+      simp [evalRow, MvPolynomial.smul_eval]
+
+@[simp]
+theorem binaryFormEval_mk (F : BinaryForm K (p - 1)) (v : UnimodularRow (ZMod p)) :
+    binaryFormEval p K F (⟦v⟧ : ProjectiveLine (ZMod p)) = evalRow p K F v :=
+  rfl
+
+end Eval
+
+end HeckeEis
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_HeckeEis_EichlerIntegral.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_HeckeEis_EichlerIntegral.lean
new file mode 100644
index 0000000000..26f45ba827
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_HeckeEis_EichlerIntegral.lean
@@ -0,0 +1,227 @@
+/-
+Based on Prove2Me node HeckeEis_EichlerIntegral
+(a1929313-e50f-5d4e-a2be-44140ef5f33e) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.CStarAlgebra.Classes
+public import Mathlib.Analysis.Calculus.Deriv.Basic
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Topology
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+
+/-!
+# Eichler integrals and the Eichler–Shimura map to parabolic cohomology
+
+Definition: `HeckeEis_EichlerIntegral` (`a1929313-e50f-5d4e-a2be-44140ef5f33e`), by Claude,
+2026-09-05.
+
+Fix $n \ge 0$ and work with the submodule $\mathrm{BinaryForm}\,\mathbb{C}\,n$ of degree-$n$
+homogeneous elements of $\mathbb{C}[X_0,X_1]$, carrying the representation `binaryFormRepSL` of
+$SL_2(\mathbb{Z})$ by the substitution $X_j \mapsto \sum_i M_{ij} X_i$. Three layers are defined.
+First, `linePow n τ` is the form $(\tau X_0 + X_1)^n$ (homogeneity being checked in the accompanying
+lemmas), and `jFactor g τ` is $c\tau + d$ for $g$ with bottom row $(c,d)$; it is identified with
+Mathlib's `denom` of the image of $g$ in $GL_2(\mathbb{R})$ and shown nonzero, and the automorphy
+relation `binaryFormRepSL_linePow` reads $\rho_n(g)\bigl((\tau X_0+X_1)^n\bigr) =
+(c\tau+d)^n\,\bigl((g\tau)X_0 + X_1\bigr)^n$ for $g \in SL_2(\mathbb{Z})$, $\tau \in \mathfrak{H}$.
+Second, for a subgroup $\Gamma \le SL_2(\mathbb{Z})$, a representation $\rho$ of $\Gamma$ on a
+$K$-module $V$ and $F : \mathfrak{H} \to V$, the predicate `IsEquivariantPrimitiveWith ρ F` says
+that for every $\gamma \in \Gamma$ the function $\tau \mapsto F(\gamma\tau) - \rho(\gamma)F(\tau)$
+is constant on $\mathfrak{H}$. Its `cocycle` is defined by evaluation at the base point $i$,
+$z_F(\gamma) = F(\gamma i) - \rho(\gamma)F(i)$; the lemmas record that $z_F(\gamma)$ equals the
+constant value at every $\tau$, that $F(\gamma\tau) = z_F(\gamma) + \rho(\gamma)F(\tau)$, and that
+$z_F$ lies in `coeffCocycles ρ`, i.e. $z_F(\gamma\delta) = z_F(\gamma) + \rho(\gamma)z_F(\delta)$.
+
+Third, `IsEichlerIntegral n f F`, for $f : \mathfrak{H} \to \mathbb{C}$ and $F : \mathfrak{H} \to
+\mathrm{BinaryForm}\,\mathbb{C}\,n$, is the coefficientwise condition: for every multidegree $d$ and
+every $\tau \in \mathfrak{H}$, the function $z \mapsto \mathrm{coeff}_d\, F(\mathrm{ofComplex}\,z)$
+on $\mathbb{C}$ has complex derivative $f(\tau)\cdot \mathrm{coeff}_d\bigl((\tau X_0+X_1)^n\bigr)$
+at $\tau$; thus $F' (\tau) = f(\tau)(\tau X_0+X_1)^n$. Finally `eichlerShimuraMap n N f` takes
+values in `coeffH1par` of $\rho_n$ restricted to $\Gamma_0(N)$ (parabolic cocycles modulo
+coboundaries, parabolicity meaning $z(\gamma) \in \mathrm{range}(\rho(\gamma)-1)$ whenever
+$\mathrm{tr}(\gamma)^2 = 4$): it is defined by choice as the class of $z_F$ for some $F$ which is an
+Eichler integral of $f$, an equivariant primitive for that representation, and has parabolic
+cocycle, and as $0$ when no such $F$ exists. The two accompanying lemmas make this precise: if one
+such $F$ is given then the value is the class of the cocycle of some (chosen) such $F_0$, and in the
+negative case the value is $0$. Independence of the choice is not part of the definition.
+
+**Relation to Mathlib.** Mathlib has no notion of Eichler integral, equivariant primitive, or
+parabolic group cohomology of a subgroup of $SL_2(\mathbb{Z})$; these are the project's own, built
+on Mathlib's `MvPolynomial.homogeneousSubmodule`, `Representation`, `UpperHalfPlane` and
+`CongruenceSubgroup.Gamma0`. The automorphy factor `jFactor` is proved to agree with Mathlib's
+`UpperHalfPlane.denom`.
+
+**Where it is used.** These definitions supply the weight-$k = n+2$ vocabulary attaching to a
+modular form the class of its Eichler integral cocycle in parabolic cohomology with $\mathrm{Sym}^n$
+coefficients, the coefficient-module analogue of the weight-two period map; such cohomological
+models of spaces of forms underlie the comparison of Hecke eigensystems in different weights and
+levels used in the level-lowering step.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+namespace HeckeEis
+
+open UpperHalfPlane MvPolynomial CongruenceSubgroup
+open scoped MatrixGroups
+
+section LinePow
+
+variable (n : ℕ)
+
+theorem isHomogeneous_line (τ : ℂ) : (C τ * X 0 + X 1 : MvPolynomial (Fin 2) ℂ).IsHomogeneous 1 :=
+  ((isHomogeneous_X ℂ 0).C_mul τ).add (isHomogeneous_X ℂ 1)
+
+theorem isHomogeneous_linePow (τ : ℂ) :
+    ((C τ * X 0 + X 1 : MvPolynomial (Fin 2) ℂ) ^ n).IsHomogeneous n := by
+  simpa using (isHomogeneous_line τ).pow n
+
+def linePow (τ : ℂ) : ↥(BinaryForm ℂ n) :=
+  ⟨(C τ * X 0 + X 1) ^ n, (mem_homogeneousSubmodule n _).mpr (isHomogeneous_linePow n τ)⟩
+
+@[simp] theorem coe_linePow (τ : ℂ) :
+    ((linePow n τ : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) = (C τ * X 0 + X 1) ^ n := rfl
+
+def jFactor (g : SL(2, ℤ)) (τ : ℍ) :
+    ℂ := ((g : Matrix (Fin 2) (Fin 2) ℤ) 1 0 : ℂ) * (τ : ℂ) + ((g : Matrix (Fin 2) (Fin 2) ℤ) 1 1 :
+      ℂ)
+
+theorem jFactor_eq_denom (g : SL(2, ℤ)) (τ : ℍ) :
+    jFactor g τ = denom (Matrix.SpecialLinearGroup.mapGL ℝ g) (τ : ℂ) := by
+  rw [jFactor, Matrix.SpecialLinearGroup.mapGL, MonoidHom.comp_apply,
+    show (algebraMap ℤ ℝ) = Int.castRingHom ℝ from rfl, ModularGroup.denom_apply]
+
+theorem jFactor_ne_zero (g : SL(2, ℤ)) (τ : ℍ) : jFactor g τ ≠ 0 := by
+  rw [jFactor_eq_denom]
+  exact denom_ne_zero _ τ
+
+theorem coe_smul_mul_jFactor (g : SL(2, ℤ)) (τ : ℍ) :
+    ((g • τ : ℍ) : ℂ) * jFactor g τ
+      = ((g : Matrix (Fin 2) (Fin 2) ℤ) 0 0 : ℂ) * (τ : ℂ) + ((g : Matrix (Fin 2) (Fin 2) ℤ) 0 1 :
+        ℂ) := by
+  rw [coe_specialLinearGroup_apply]
+  have hj := jFactor_ne_zero g τ
+  simp only [jFactor, eq_intCast, Complex.ofReal_intCast] at hj ⊢
+  rw [div_mul_cancel₀ _ hj]
+
+theorem binarySubst_line (M : Matrix (Fin 2) (Fin 2) ℤ) (τ : ℂ) :
+    binarySubst ℂ M (C τ * X 0 + X 1)
+      = C ((M 0 0 : ℂ) * τ + (M 0 1 : ℂ)) * X 0 + C ((M 1 0 : ℂ) * τ + (M 1 1 : ℂ)) * X 1 := by
+  simp only [map_add, map_mul, binarySubst_C, binarySubst_X, Fin.sum_univ_two, Fin.isValue]
+  ring
+
+theorem binaryFormRepSL_linePow (g : SL(2, ℤ)) (τ : ℍ) :
+    binaryFormRepSL ℂ n g (linePow n (τ : ℂ)) = (jFactor g τ) ^ n • linePow n ((g • τ : ℍ) : ℂ) :=
+      by
+  apply Subtype.ext
+  rw [binaryFormRepSL_apply_coe, Submodule.coe_smul, coe_linePow, coe_linePow, map_pow,
+    binarySubst_line,
+    smul_eq_C_mul, map_pow, ← mul_pow]
+  congr 1
+  rw [mul_add, ← mul_assoc, ← map_mul, mul_comm (jFactor g τ), coe_smul_mul_jFactor]
+  rfl
+
+end LinePow
+
+section Equivariant
+
+variable {K : Type*} [CommRing K] {Γ : Subgroup SL(2, ℤ)} {V : Type*} [AddCommGroup V] [Module K V]
+
+def IsEquivariantPrimitiveWith (ρ : Representation K Γ V) (F : ℍ → V) : Prop :=
+  ∀ γ : Γ, ∃ c : V, ∀ τ : ℍ, F ((γ : SL(2, ℤ)) • τ) - ρ γ (F τ) = c
+
+namespace IsEquivariantPrimitiveWith
+
+variable {ρ : Representation K Γ V} {F : ℍ → V}
+
+def cocycle (_hF : IsEquivariantPrimitiveWith ρ F) (γ : Γ) : V :=
+  F ((γ : SL(2, ℤ)) • I) - ρ γ (F I)
+
+theorem sub_eq_cocycle (hF : IsEquivariantPrimitiveWith ρ F) (γ : Γ) (τ : ℍ) :
+    F ((γ : SL(2, ℤ)) • τ) - ρ γ (F τ) = hF.cocycle γ := by
+  obtain ⟨c, hc⟩ := hF γ
+  rw [cocycle, hc τ, hc I]
+
+theorem apply_smul (hF : IsEquivariantPrimitiveWith ρ F) (γ : Γ) (τ : ℍ) :
+    F ((γ : SL(2, ℤ)) • τ) = hF.cocycle γ + ρ γ (F τ) := by
+  rw [← hF.sub_eq_cocycle γ τ, sub_add_cancel]
+
+theorem cocycle_mem_coeffCocycles (hF : IsEquivariantPrimitiveWith ρ F) :
+    hF.cocycle ∈ coeffCocycles ρ := by
+  intro γ δ
+  have h := hF.apply_smul (γ * δ) I
+  rw [Subgroup.coe_mul, mul_smul, hF.apply_smul γ, hF.apply_smul δ, map_add, map_mul,
+    Module.End.mul_apply] at h
+  have := congrArg (fun v => v - ρ γ (ρ δ (F I))) h
+  simp only [add_sub_cancel_right] at this
+  rw [← this]
+  abel
+
+end IsEquivariantPrimitiveWith
+
+end Equivariant
+
+section EichlerIntegral
+
+variable (n : ℕ)
+
+def IsEichlerIntegral (f : ℍ → ℂ) (F : ℍ → ↥(BinaryForm ℂ n)) : Prop :=
+  ∀ (d : Fin 2 →₀ ℕ) (τ : ℍ),
+    HasDerivAt (fun z : ℂ => AddMonoidAlgebra.coeff ((F (ofComplex z) : ↥(BinaryForm ℂ n)) :
+      MvPolynomial (Fin 2) ℂ) d)
+      (f τ * AddMonoidAlgebra.coeff ((linePow n (τ : ℂ) : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2)
+        ℂ) d) (τ : ℂ)
+
+variable (N : ℕ)
+
+open Classical in
+def eichlerShimuraMap (f : ℍ → ℂ) :
+    coeffH1par ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) :=
+  if h : ∃ F : ℍ → ↥(BinaryForm ℂ n), IsEichlerIntegral n f F ∧
+      ∃ hF : IsEquivariantPrimitiveWith ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) F,
+        IsParabolicCocycle ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) hF.cocycle
+  then coeffH1parMk _ ⟨h.choose_spec.2.choose.cocycle,
+    ⟨h.choose_spec.2.choose.cocycle_mem_coeffCocycles, h.choose_spec.2.choose_spec⟩⟩
+  else 0
+
+theorem eichlerShimuraMap_def (f : ℍ → ℂ) {F : ℍ → ↥(BinaryForm ℂ n)}
+    (hEI : IsEichlerIntegral n f F)
+    (hF : IsEquivariantPrimitiveWith ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) F)
+    (hpar : IsParabolicCocycle ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) hF.cocycle) :
+    ∃ (F₀ : ℍ → ↥(BinaryForm ℂ n)) (_ : IsEichlerIntegral n f F₀)
+      (h₀ : IsEquivariantPrimitiveWith ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) F₀)
+      (hpar₀ : IsParabolicCocycle ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) h₀.cocycle),
+      eichlerShimuraMap n N f = coeffH1parMk _ ⟨h₀.cocycle, ⟨h₀.cocycle_mem_coeffCocycles, hpar₀⟩⟩
+        := by
+  classical
+  have h : ∃ F : ℍ → ↥(BinaryForm ℂ n), IsEichlerIntegral n f F ∧
+      ∃ hF : IsEquivariantPrimitiveWith ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) F,
+        IsParabolicCocycle ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) hF.cocycle := ⟨F, hEI,
+          hF, hpar⟩
+  exact ⟨h.choose, h.choose_spec.1, h.choose_spec.2.choose, h.choose_spec.2.choose_spec,
+    dite_eq_left h⟩
+
+theorem eichlerShimuraMap_of_not_exists (f : ℍ → ℂ)
+    (h : ¬ ∃ F : ℍ → ↥(BinaryForm ℂ n), IsEichlerIntegral n f F ∧
+      ∃ hF : IsEquivariantPrimitiveWith ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) F,
+        IsParabolicCocycle ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) hF.cocycle) :
+    eichlerShimuraMap n N f = 0 := by
+  classical
+  exact dite_eq_right h
+
+end EichlerIntegral
+
+end HeckeEis
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_HeckeGalois_EichlerShimura.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_HeckeGalois_EichlerShimura.lean
new file mode 100644
index 0000000000..8bb65d11fe
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_HeckeGalois_EichlerShimura.lean
@@ -0,0 +1,298 @@
+/-
+Based on Prove2Me node HeckeGalois_EichlerShimura
+(6eec19f8-57d2-57fe-a22d-e0bfac2f9a00) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Ramification
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusTrace
+public import Mathlib.Algebra.MvPolynomial.CommRing
+public import Mathlib.Algebra.Module.Torsion.Basic
+public import Mathlib.LinearAlgebra.Determinant
+public import Mathlib.LinearAlgebra.Dimension.Finrank
+
+/-!
+# Hecke polynomial algebra, mod-𝔪 Galois action, Eichler–Shimura hypotheses
+
+Definition: `HeckeGalois_EichlerShimura` (`6eec19f8-57d2-57fe-a22d-e0bfac2f9a00`), by Claude,
+2026-09-05.
+
+The ambient ring is `HeckeAlg`, defined as the polynomial ring $\mathbb{Z}[X_\ell]$ over the type of
+primes (`MvPolynomial Nat.Primes ℤ`), with `heckeGen ℓ` the variable indexed by $\ell$; it is thus a
+free presentation on symbols $T_\ell$, carrying no Hecke relations, and `adjoin_range_heckeGen`
+records that the generators generate it. For a system of eigenvalues $a : \mathrm{Primes} \to k$ in
+a commutative ring $k$, `eigenIdeal a` is the kernel of the $\mathbb{Z}$-algebra map sending $T_\ell
+\mapsto a_\ell$; `eisensteinSystem N` is the system $a_\ell = 1$ for $\ell \mid N$ and $a_\ell =
+1+\ell$ otherwise, and `eisensteinIdeal N` is its eigen-ideal. For a `HeckeAlg`-module $J$ and an
+ideal $\mathfrak m$, `heckeTorsion J 𝔪` is $J[\mathfrak m] = \{x : t\cdot x = 0 \text{ for all } t
+\in \mathfrak m\}$ (Mathlib's `torsionBySet`), needing no group action; when a group $G$ acts
+distributively on $J$ commuting with `HeckeAlg`, `smul_mem_heckeTorsion` shows $J[\mathfrak m]$ is
+$G$-stable and `mTorsionGaloisRep` is the resulting monoid homomorphism $G \to
+\mathrm{End}_{\mathrm{HeckeAlg}/\mathfrak m}(J[\mathfrak m])$. `eisensteinKernel J I` is the ideal
+of $t$ for which some $i \in I$ makes $(1+i)t$ annihilate all of $J$, and
+`EisensteinQuotientInvariantsFinite` asserts that the image in $J/\gamma_I J$ of $\{x : \sigma x - x
+\in \gamma_I J \text{ for all } \sigma\}$ is finite.
+
+The local clauses are stated for a field extension $L/K$, integers $N,p$, and $J$ with commuting
+actions of $\mathrm{Gal}(L/K) = L \simeq_{\mathrm{alg}[K]} L$ and `HeckeAlg`, quantified over primes
+$\ell \nmid Np$ and valuation subrings $A \subseteq L$ with $\ell$ a non-unit of $A$:
+`UnramifiedOutside` says inertia at $A$ fixes every $p$-power-torsion element of $J$;
+`FrobeniusQuadratic` says $\sigma^2 x - T_\ell\cdot(\sigma x) + \ell x = 0$ for each arithmetic
+Frobenius $\sigma$ at $A$ (acting as $x \mapsto x^\ell$ on the residue field) and each
+$p$-power-torsion $x$; `DetFrobeniusMod 𝔪` says $\det(\mathrm{mTorsionGaloisRep}\,\sigma) = \ell$ in
+$\mathrm{HeckeAlg}/\mathfrak m$. `MTorsionNeBot` says $J[\mathfrak m] \neq 0$, `EigenformSupport p J
+IsEig` requires this for every $\mathfrak m$ satisfying the parameter predicate `IsEig` with $p \in
+\mathfrak m$, and `MultiplicityOneData` is the three-field structure '$\mathfrak m$ maximal, $p \in
+\mathfrak m$, $\dim_{\mathrm{HeckeAlg}/\mathfrak m} J[\mathfrak m] = 2$'.
+`EichlerShimuraDataReduced` bundles the first two local clauses with `EigenformSupport` (not the
+determinant clause). Finally `IsSpecialization p J J' A ℓ sp F` is a four-field structure on an
+additive map $sp : J \to J'$ and an endomorphism $F$ of $J'$: $sp$ commutes with all Hecke
+operators, kills the inertia action ($sp(\sigma x) = sp(x)$ for $\sigma$ in inertia at $A$),
+intertwines Frobenius at $A$ with $F$, and is injective on $p$-power torsion; `SpecialFibreRelation`
+asserts $F^2 - T_\ell F + \ell = 0$ on $J'$, and `SpecializationExists` asserts such data exist for
+every prime $\ell \nmid Np$ and every $A$ over $\ell$. All of these are predicates on an abstract
+module and acquire their intended content only upon instantiation.
+
+**Relation to Mathlib.** `HeckeAlg` is literally Mathlib's `MvPolynomial Nat.Primes ℤ` and
+`heckeTorsion` an abbreviation for `Submodule.torsionBySet`; Mathlib has no Hecke algebra,
+Eichler–Shimura relation or Eisenstein ideal, so those notions are the project's own. The
+valuation-theoretic vocabulary used in the local clauses (`LiesOverPrime`, `inertiaSubgroupIn`,
+`IsFrobeniusAt`) is defined in the project on top of Mathlib's valuation subrings and ramification
+groups.
+
+**Where it is used.** These are the hypothesis interfaces through which the modular-curve input
+enters the Frey–Serre–Ribet route: instantiated with the $p$-power torsion of $J_0(N)$ and the
+Galois group of an algebraic closure of $\mathbb{Q}$, the Eichler–Shimura clauses give the
+mod-$\mathfrak m$ representations attached to eigenforms together with their local behaviour at
+primes of good reduction, the multiplicity-one datum gives two-dimensionality, and the
+Eisenstein-kernel finiteness clause is the form in which Mazur's Eisenstein-ideal argument is
+invoked.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+namespace ModularCurve
+
+abbrev HeckeAlg : Type := MvPolynomial Nat.Primes ℤ
+
+def heckeGen (ℓ : Nat.Primes) : HeckeAlg := MvPolynomial.X ℓ
+
+@[simp] lemma aeval_heckeGen {A : Type*} [CommSemiring A] [Algebra ℤ A]
+    (a : Nat.Primes → A) (ℓ : Nat.Primes) :
+    MvPolynomial.aeval a (heckeGen ℓ) = a ℓ :=
+  MvPolynomial.aeval_X a ℓ
+
+lemma adjoin_range_heckeGen : Algebra.adjoin ℤ (Set.range heckeGen) = ⊤ :=
+  MvPolynomial.adjoin_range_X
+
+section EigenIdeal
+
+variable {k : Type*} [CommRing k]
+
+def eigenIdeal (a : Nat.Primes → k) : Ideal HeckeAlg :=
+  RingHom.ker (MvPolynomial.aeval (R := ℤ) a)
+
+lemma mem_eigenIdeal_iff (a : Nat.Primes → k) (t : HeckeAlg) :
+    t ∈ eigenIdeal a ↔ MvPolynomial.aeval a t = 0 :=
+  RingHom.mem_ker
+
+lemma heckeGen_sub_mem_eigenIdeal (a : Nat.Primes → k) (ℓ : Nat.Primes) (b : ℤ)
+    (hb : algebraMap ℤ k b = a ℓ) :
+    heckeGen ℓ - MvPolynomial.C b ∈ eigenIdeal a := by
+  rw [mem_eigenIdeal_iff, map_sub, aeval_heckeGen, MvPolynomial.aeval_C, hb, sub_self]
+
+end EigenIdeal
+
+section Divisorial
+
+variable {G : Type*} [Group G] (J : Type*) [AddCommGroup J] [Module HeckeAlg J]
+  [DistribMulAction G J] [SMulCommClass G HeckeAlg J]
+
+abbrev heckeTorsion (𝔪 : Ideal HeckeAlg) : Submodule HeckeAlg J :=
+  Submodule.torsionBySet HeckeAlg J (𝔪 : Set HeckeAlg)
+
+lemma mem_heckeTorsion_iff (𝔪 : Ideal HeckeAlg) (x : J) :
+    x ∈ heckeTorsion J 𝔪 ↔ ∀ t ∈ 𝔪, t • x = 0 := by
+  rw [Submodule.mem_torsionBySet_iff]
+  exact ⟨fun h t ht => h ⟨t, ht⟩, fun h t => h t.1 t.2⟩
+
+theorem smul_mem_heckeTorsion {𝔪 : Ideal HeckeAlg} (g : G) {x : J}
+    (hx : x ∈ heckeTorsion J 𝔪) : g • x ∈ heckeTorsion J 𝔪 := by
+  rw [Submodule.mem_torsionBySet_iff] at hx ⊢
+  intro t
+  rw [← smul_comm g (t : HeckeAlg) x, hx t, smul_zero]
+
+def mTorsionGaloisRep (𝔪 : Ideal HeckeAlg) :
+    G →* Module.End (HeckeAlg ⧸ 𝔪) (heckeTorsion J 𝔪) where
+  toFun g :=
+    { toFun := fun x => ⟨g • (x : J), smul_mem_heckeTorsion J g x.2⟩
+      map_add' := fun x y => by
+        ext
+        simp [smul_add]
+      map_smul' := fun r x => by
+        obtain ⟨a, rfl⟩ := Ideal.Quotient.mk_surjective r
+        ext
+        simp only [Submodule.torsionBySet.mk_smul, RingHom.id_apply, Submodule.coe_smul]
+        exact smul_comm g a (x : J) }
+  map_one' := by
+    ext x
+    simp
+  map_mul' g h := by
+    ext x
+    simp [mul_smul]
+
+@[simp] theorem coe_mTorsionGaloisRep_apply (𝔪 : Ideal HeckeAlg) (g : G)
+    (x : heckeTorsion J 𝔪) :
+    ((mTorsionGaloisRep J 𝔪 g x : heckeTorsion J 𝔪) : J) = g • (x : J) := rfl
+
+def eisensteinKernel (I : Ideal HeckeAlg) : Ideal HeckeAlg where
+  carrier := {t | ∃ i ∈ I, ∀ x : J, ((1 + i) * t) • x = 0}
+  zero_mem' := ⟨0, I.zero_mem, fun x => by simp⟩
+  add_mem' := by
+    rintro t t' ⟨i, hi, ht⟩ ⟨i', hi', ht'⟩
+    refine ⟨i + i' + i * i', I.add_mem (I.add_mem hi hi') (I.mul_mem_left i hi'), fun x => ?_⟩
+    have h1 : ((1 + i') * ((1 + i) * t)) • x = 0 := by rw [mul_smul, ht x, smul_zero]
+    have h2 : ((1 + i) * ((1 + i') * t')) • x = 0 := by rw [mul_smul, ht' x, smul_zero]
+    have : (1 + (i + i' + i * i')) * (t + t')
+        = (1 + i') * ((1 + i) * t) + (1 + i) * ((1 + i') * t') := by
+      ring
+    rw [this, add_smul, h1, h2, add_zero]
+  smul_mem' := by
+    rintro c t ⟨i, hi, ht⟩
+    refine ⟨i, hi, fun x => ?_⟩
+    have : (1 + i) * (c • t) = c * ((1 + i) * t) := by rw [smul_eq_mul]; ring
+    rw [this, mul_smul, ht x, smul_zero]
+
+def EisensteinQuotientInvariantsFinite (I : Ideal HeckeAlg) : Prop :=
+  Set.Finite ((eisensteinKernel J I • (⊤ : Submodule HeckeAlg J)).mkQ ''
+    {x : J | ∀ σ : G, σ • x - x ∈ eisensteinKernel J I • (⊤ : Submodule HeckeAlg J)})
+
+end Divisorial
+
+section Forms
+
+variable (𝕋 : Type*) [CommRing 𝕋] (J : Type*) [AddCommGroup J] [Module 𝕋 J] (𝔪 : Ideal 𝕋)
+
+def MTorsionNeBot : Prop :=
+  Submodule.torsionBySet 𝕋 J 𝔪 ≠ ⊥
+
+end Forms
+
+section LocalClauses
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable (N p : ℕ) (J : Type*) [AddCommGroup J] [Module HeckeAlg J]
+  [DistribMulAction (L ≃ₐ[K] L) J] [SMulCommClass (L ≃ₐ[K] L) HeckeAlg J]
+
+def UnramifiedOutside : Prop :=
+  ∀ ℓ : ℕ, ℓ.Prime → ¬ ℓ ∣ N * p →
+    ∀ A : ValuationSubring L, A.LiesOverPrime ℓ →
+      ∀ σ ∈ A.inertiaSubgroupIn K, ∀ x : J, (∃ n : ℕ, p ^ n • x = 0) → σ • x = x
+
+def FrobeniusQuadratic : Prop :=
+  ∀ ℓ : ℕ, (hℓ : ℓ.Prime) → ¬ ℓ ∣ N * p →
+    ∀ A : ValuationSubring L, A.LiesOverPrime ℓ →
+      ∀ σ : L ≃ₐ[K] L, A.IsFrobeniusAt σ ℓ →
+        ∀ x : J, (∃ n : ℕ, p ^ n • x = 0) →
+          σ • σ • x - heckeGen ⟨ℓ, hℓ⟩ • (σ • x) + ℓ • x = 0
+
+def DetFrobeniusMod (𝔪 : Ideal HeckeAlg) : Prop :=
+  ∀ ℓ : ℕ, ℓ.Prime → ¬ ℓ ∣ N * p →
+    ∀ A : ValuationSubring L, A.LiesOverPrime ℓ →
+      ∀ σ : L ≃ₐ[K] L, A.IsFrobeniusAt σ ℓ →
+        LinearMap.det (mTorsionGaloisRep J 𝔪 σ) = ((ℓ : HeckeAlg ⧸ 𝔪))
+
+end LocalClauses
+
+section MultiplicityOne
+
+variable (p : ℕ) (J : Type*) [AddCommGroup J] [Module HeckeAlg J]
+
+structure MultiplicityOneData (𝔪 : Ideal HeckeAlg) : Prop where
+  isMaximal : 𝔪.IsMaximal
+  resChar : (p : HeckeAlg) ∈ 𝔪
+  finrank_two : Module.finrank (HeckeAlg ⧸ 𝔪) (heckeTorsion J 𝔪) = 2
+
+end MultiplicityOne
+
+def eisensteinSystem (N : ℕ) : Nat.Primes → ℤ :=
+  fun ℓ => if (ℓ : ℕ) ∣ N then 1 else 1 + (ℓ : ℕ)
+
+@[simp] lemma eisensteinSystem_of_not_dvd {N : ℕ} {ℓ : Nat.Primes} (h : ¬ (ℓ : ℕ) ∣ N) :
+    eisensteinSystem N ℓ = 1 + (ℓ : ℕ) := ite_eq_right h
+
+@[simp] lemma eisensteinSystem_of_dvd {N : ℕ} {ℓ : Nat.Primes} (h : (ℓ : ℕ) ∣ N) :
+    eisensteinSystem N ℓ = 1 := ite_eq_left h
+
+def eisensteinIdeal (N : ℕ) : Ideal HeckeAlg :=
+  eigenIdeal (eisensteinSystem N)
+
+section Support
+
+variable (p : ℕ) (J : Type*) [AddCommGroup J] [Module HeckeAlg J]
+
+def EigenformSupport (IsEig : Ideal HeckeAlg → Prop) : Prop :=
+  ∀ 𝔪 : Ideal HeckeAlg, IsEig 𝔪 → ((p : HeckeAlg)) ∈ 𝔪 → MTorsionNeBot HeckeAlg J 𝔪
+
+end Support
+
+section Bundle
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable (N p : ℕ) (J : Type*) [AddCommGroup J] [Module HeckeAlg J]
+  [DistribMulAction (L ≃ₐ[K] L) J] [SMulCommClass (L ≃ₐ[K] L) HeckeAlg J]
+
+structure EichlerShimuraDataReduced (IsEig : Ideal HeckeAlg → Prop) : Prop where
+  unramifiedOutside : UnramifiedOutside (K := K) (L := L) N p J
+  frobeniusQuadratic : FrobeniusQuadratic (K := K) (L := L) N p J
+  eigenformSupport : EigenformSupport p J IsEig
+
+end Bundle
+
+section Datum
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable (p : ℕ) (J : Type*) [AddCommGroup J] [Module HeckeAlg J]
+  [DistribMulAction (L ≃ₐ[K] L) J] [SMulCommClass (L ≃ₐ[K] L) HeckeAlg J]
+variable (J' : Type*) [AddCommGroup J'] [Module HeckeAlg J']
+
+structure IsSpecialization (A : ValuationSubring L) (ℓ : ℕ) (sp : J →+ J') (F : J' →+ J') :
+    Prop where
+  hecke_comm : ∀ (T : HeckeAlg) (x : J), sp (T • x) = T • sp x
+  inertia_comm : ∀ σ ∈ A.inertiaSubgroupIn K, ∀ x : J, sp (σ • x) = sp x
+  frobenius_comm : ∀ σ : L ≃ₐ[K] L, A.IsFrobeniusAt σ ℓ → ∀ x : J, sp (σ • x) = F (sp x)
+  injective_torsion : ∀ x : J, (∃ n : ℕ, p ^ n • x = 0) → sp x = 0 → x = 0
+
+def SpecialFibreRelation (ℓ : ℕ) (hℓ : ℓ.Prime) (F : J' →+ J') : Prop :=
+  ∀ y : J', F (F y) - heckeGen ⟨ℓ, hℓ⟩ • F y + ℓ • y = 0
+
+end Datum
+
+section Citation
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable (N p : ℕ) (J : Type*) [AddCommGroup J] [Module HeckeAlg J]
+  [DistribMulAction (L ≃ₐ[K] L) J] [SMulCommClass (L ≃ₐ[K] L) HeckeAlg J]
+
+def SpecializationExists : Prop :=
+  ∀ ℓ : ℕ, (hℓ : ℓ.Prime) → ¬ ℓ ∣ N * p →
+    ∀ A : ValuationSubring L, A.LiesOverPrime ℓ →
+      ∃ (J' : Type) (_ : AddCommGroup J') (_ : Module HeckeAlg J') (sp : J →+ J')
+        (F : J' →+ J'),
+        IsSpecialization (K := K) p J J' A ℓ sp F ∧ SpecialFibreRelation J' ℓ hℓ F
+
+end Citation
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_Isogeny_ConditionalCurrency.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_Isogeny_ConditionalCurrency.lean
new file mode 100644
index 0000000000..5a6a720d3b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_Isogeny_ConditionalCurrency.lean
@@ -0,0 +1,301 @@
+/-
+Based on Prove2Me node Isogeny_ConditionalCurrency
+(6adae51b-807c-5e9f-ae0b-da141c66671a) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePic0
+
+/-!
+# Pic⁰ pushforward along function-field maps; isogeny data on points
+
+Definition: `Isogeny_ConditionalCurrency` (`6adae51b-807c-5e9f-ae0b-da141c66671a`), by Claude,
+2026-09-05.
+
+The first part descends the divisor pushforward along an integral $K$-algebra map $\varphi : F \to
+F'$ of fields to divisor classes.
+[`AlgebraicCurve.Pic0.pushforwardAlongDegZero`](../def/Isogeny_ConditionalCurrency.html#L20)
+restricts `Divisor.pushforwardAlong φ hφ` (on places: $w \mapsto f(w)\,[w|_F]$, where $w|_F$ is the
+restriction of the valuation subring and $f(w)$ the residue-extension degree) to the degree-zero
+subgroups, which is legitimate because pushforward preserves degree; `pushforwardAlongHom` then
+quotients by principal divisors, using two extra explicit hypotheses: `hfin : FiniteAlong K φ`, i.e.
+$F'$ is a finite $F$-module via $\varphi$, and `hN : NormFormulaAlong K φ hfin`, the project's
+predicate asserting that for every $f \in F'^\times$ the pushforward of $\mathrm{div}(f)$ is
+$\mathrm{div}(N_{F'/F}f)$ — a hypothesis, not a theorem.
+`Place.deg_restrictAlong_mul_inertiaDegAlong` records $\deg(w|_F)\cdot f(w) = \deg(w)$.
+
+The second part fixes an algebraically closed field $F$ of characteristic zero, elliptic $V,W$ in
+affine Weierstrass form carrying the classes `GenusOnePlaceGate` (data: a bijection $W(F) \simeq$
+places of $F(W)$, all residue degrees $1$) and `AbelTheorem` (a degree-zero divisor is principal iff
+its image under `divisorSum` vanishes), and an integral $F$-algebra map $\iota : F(V) \to F(W)$.
+Since all residue degrees are $1$, all inertia degrees are $1$ and pushforward carries $n[w]$ to
+$n[w|_{F(V)}]$. Conjugating `pushforwardAlongHom` by the Abel–Jacobi isomorphisms
+`genusOnePic0Equiv` gives `pointMapOfPushforward : W.Point →+ V.Point`. A group of three lemmas in a
+common shape says that any map $g$ of point sets with $g(0)=0$ which matches $\iota$ on places,
+$(\mathrm{place}\,P)|_{F(V)} = \mathrm{place}\,g(P)$, equals this homomorphism, hence is additive,
+and that $g(P)=0$ exactly when the class of $(P)-(0)$ pushes forward to zero. Finally
+`IsogenyEndDatum W` and `IsogenyHomDatum V₀ V₁` bundle $(\iota,\ \text{integrality},\
+\text{finiteness})$ — note the contravariance: the latter has $\iota : F(V_1) \to F(V_0)$ and yields
+`pointHom : V₀.Point →+ V₁.Point`; `isogenyEndSubring` is the subring of `AddMonoid.End W.Point`
+generated by all `pointEnd`, given norm-formula witnesses for every datum.
+
+**Relation to Mathlib.** Places, divisors, principal divisors and $\mathrm{Pic}^0$ of a function
+field in this valuation-subring formulation are the project's own; Mathlib supplies the ambient
+algebra (`Finsupp`, `QuotientAddGroup`, `AddMonoid.End`, `Subring.closure`, `Algebra.norm`, residue
+fields of local rings) and `WeierstrassCurve.Affine` with its group of points, but no divisor-class
+theory for curves and no isogeny-induced maps of this kind.
+
+**Where it is used.** This is the mechanism by which an inclusion of function fields of elliptic
+curves is turned into an additive map of point groups, so that endomorphism rings and
+isogeny-induced homomorphisms can be manipulated group-theoretically. The `GenusOnePlaceGate` datum
+is an arbitrary point–place bijection with all residue degrees one, so statements identifying these
+maps with named geometric maps require further hypotheses pinning the dictionary.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section IsogenyCurrency
+
+section Delta
+
+namespace AlgebraicCurve
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+
+namespace Pic0
+
+variable (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+variable (hfin : FiniteAlong K φ) (hN : NormFormulaAlong K φ hfin)
+
+def pushforwardAlongDegZero :
+    Divisor.degZero (K := K) (F := F') →+ Divisor.degZero (K := K) (F := F) :=
+  ((Divisor.pushforwardAlong φ hφ).domRestrict
+    (Divisor.degZero (K := K) (F := F'))).codRestrict _
+    (fun D => Divisor.pushforwardAlong_mem_degZero φ hφ D.2)
+
+@[simp]
+theorem coe_pushforwardAlongDegZero (D : Divisor.degZero (K := K) (F := F')) :
+    (pushforwardAlongDegZero φ hφ D : Divisor K F) =
+      Divisor.pushforwardAlong φ hφ (D : Divisor K F') :=
+  rfl
+
+def pushforwardAlongHom : Pic0 K F' →+ Pic0 K F :=
+  QuotientAddGroup.map _ _ (pushforwardAlongDegZero φ hφ) (by
+    rintro ⟨D, hD0⟩ hD
+    simp only [AddSubgroup.mem_addSubgroupOf] at hD ⊢
+    exact Divisor.isPrincipal_pushforwardAlong φ hφ hfin hN hD)
+
+theorem pushforwardAlongHom_mk (D : Divisor.degZero (K := K) (F := F')) :
+    pushforwardAlongHom φ hφ hfin hN (mk D) = mk (pushforwardAlongDegZero φ hφ D) :=
+  rfl
+
+end Pic0
+
+end AlgebraicCurve
+
+end Delta
+
+open AlgebraicCurve
+
+namespace AlgebraicCurve
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+
+theorem Place.deg_restrictAlong_mul_inertiaDegAlong (φ : F →ₐ[K] F')
+    (hφ : φ.toRingHom.IsIntegral) (w : Place K F') :
+    (w.restrictAlong φ hφ).deg * w.inertiaDegAlong φ hφ = w.deg := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  exact w.deg_restrict_mul_inertiaDeg
+
+end AlgebraicCurve
+
+namespace WeierstrassCurve.Affine
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {V W : Affine F} [V.IsElliptic] [W.IsElliptic]
+variable [GenusOnePlaceGate V] [AbelTheorem V] [GenusOnePlaceGate W] [AbelTheorem W]
+variable (ι : V.FunctionField →ₐ[F] W.FunctionField) (hι : ι.toRingHom.IsIntegral)
+
+omit [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic V] [WeierstrassCurve.IsElliptic W]
+  [V.AbelTheorem] [W.AbelTheorem] in
+omit [DecidableEq F] in
+theorem inertiaDegAlong_eq_one (w : AlgebraicCurve.Place F W.FunctionField) :
+    w.inertiaDegAlong ι hι = 1 := by
+  have h := AlgebraicCurve.Place.deg_restrictAlong_mul_inertiaDegAlong ι hι w
+  rw [deg_eq_one (W := V) (w.restrictAlong ι hι), deg_eq_one (W := W) w, one_mul] at h
+  exact h
+
+omit [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic V] [WeierstrassCurve.IsElliptic W]
+  [V.AbelTheorem] [W.AbelTheorem] in
+omit [DecidableEq F] in
+theorem pushforwardAlong_single_eq (w : AlgebraicCurve.Place F W.FunctionField) (n : ℤ) :
+    Divisor.pushforwardAlong ι hι (Finsupp.single w n)
+      = Finsupp.single (w.restrictAlong ι hι) n := by
+  rw [Divisor.pushforwardAlong_single, inertiaDegAlong_eq_one ι hι w, Nat.cast_one, mul_one]
+
+variable (hfin : FiniteAlong F ι) (hN : NormFormulaAlong F ι hfin)
+
+omit [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic V] [WeierstrassCurve.IsElliptic W]
+  [V.AbelTheorem] [W.AbelTheorem] [DecidableEq F] in
+theorem pushforwardAlongDegZero_pointDivisor {P : W.Point} {Q : V.Point}
+    (hP : (placeOfPoint P).restrictAlong ι hι = placeOfPoint Q)
+    (h0 : (placeOfPoint (0 : W.Point)).restrictAlong ι hι = placeOfPoint (0 : V.Point)) :
+    Pic0.pushforwardAlongDegZero ι hι (pointDivisor P) = pointDivisor Q := by
+  refine Subtype.ext ?_
+  rw [Pic0.coe_pushforwardAlongDegZero, coe_pointDivisor, coe_pointDivisor, map_sub,
+    pushforwardAlong_single_eq ι hι, pushforwardAlong_single_eq ι hι, hP, h0]
+
+omit [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic V] [WeierstrassCurve.IsElliptic W]
+  [V.AbelTheorem] [W.AbelTheorem] [DecidableEq F] in
+theorem pushforwardAlongHom_pointClass {P : W.Point} {Q : V.Point}
+    (hP : (placeOfPoint P).restrictAlong ι hι = placeOfPoint Q)
+    (h0 : (placeOfPoint (0 : W.Point)).restrictAlong ι hι = placeOfPoint (0 : V.Point)) :
+    Pic0.pushforwardAlongHom ι hι hfin hN (pointClass P) = pointClass Q := by
+  change Pic0.pushforwardAlongHom ι hι hfin hN (Pic0.mk (pointDivisor P))
+      = Pic0.mk (pointDivisor Q)
+  rw [Pic0.pushforwardAlongHom_mk, pushforwardAlongDegZero_pointDivisor ι hι hP h0]
+
+def pointMapOfPushforward : W.Point →+ V.Point :=
+  ((genusOnePic0Equiv V).toAddMonoidHom.comp
+      (Pic0.pushforwardAlongHom ι hι hfin hN)).comp
+    (genusOnePic0Equiv W).symm.toAddMonoidHom
+
+omit [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic V] [WeierstrassCurve.IsElliptic W] in
+@[simp]
+theorem pointMapOfPushforward_apply (P : W.Point) :
+    pointMapOfPushforward ι hι hfin hN P
+      = genusOnePic0Equiv V (Pic0.pushforwardAlongHom ι hι hfin hN (pointClass P)) := by
+  rw [← genusOnePic0Equiv_symm_apply]
+  rfl
+
+omit [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic V] [WeierstrassCurve.IsElliptic W] in
+theorem pointMapOfPushforward_eq_of_seam (g : W.Point → V.Point) (hg0 : g 0 = 0)
+    (hg : ∀ P, (placeOfPoint P).restrictAlong ι hι = placeOfPoint (g P)) (P : W.Point) :
+    pointMapOfPushforward ι hι hfin hN P = g P := by
+  rw [pointMapOfPushforward_apply,
+    pushforwardAlongHom_pointClass ι hι hfin hN (hg P) ((hg 0).trans (by rw [hg0])),
+    genusOnePic0Equiv_apply, pic0ToPoint_pointClass]
+
+include hfin hN in
+omit [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic V] [WeierstrassCurve.IsElliptic W] in
+theorem map_add_of_seam (g : W.Point → V.Point) (hg0 : g 0 = 0)
+    (hg : ∀ P, (placeOfPoint P).restrictAlong ι hι = placeOfPoint (g P)) (P Q : W.Point) :
+    g (P + Q) = g P + g Q := by
+  rw [← pointMapOfPushforward_eq_of_seam ι hι hfin hN g hg0 hg (P + Q),
+    ← pointMapOfPushforward_eq_of_seam ι hι hfin hN g hg0 hg P,
+    ← pointMapOfPushforward_eq_of_seam ι hι hfin hN g hg0 hg Q, map_add]
+
+omit [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic V] [WeierstrassCurve.IsElliptic W] in
+theorem eq_zero_iff_of_seam (g : W.Point → V.Point) (hg0 : g 0 = 0)
+    (hg : ∀ P, (placeOfPoint P).restrictAlong ι hι = placeOfPoint (g P)) (P : W.Point) :
+    g P = 0 ↔ Pic0.pushforwardAlongHom ι hι hfin hN (pointClass P) = 0 := by
+  rw [← pointMapOfPushforward_eq_of_seam ι hι hfin hN g hg0 hg P, pointMapOfPushforward_apply]
+  constructor
+  · intro h
+    exact (genusOnePic0Equiv V).injective (by rw [h, map_zero])
+  · intro h
+    rw [h, map_zero]
+
+end WeierstrassCurve.Affine
+
+namespace WeierstrassCurve.Affine
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [GenusOnePlaceGate W] [AbelTheorem W]
+
+structure IsogenyEndDatum where
+  ι : W.FunctionField →ₐ[F] W.FunctionField
+  hι : ι.toRingHom.IsIntegral
+  hfin : FiniteAlong F ι
+
+namespace IsogenyEndDatum
+
+variable {W}
+
+def pointEnd (D : IsogenyEndDatum W) (hN : NormFormulaAlong F D.ι D.hfin) :
+    AddMonoid.End W.Point :=
+  pointMapOfPushforward D.ι D.hι D.hfin hN
+
+omit [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd_apply (D : IsogenyEndDatum W) (hN : NormFormulaAlong F D.ι D.hfin)
+    (P : W.Point) :
+    D.pointEnd hN P
+      = genusOnePic0Equiv W
+          (Pic0.pushforwardAlongHom D.ι D.hι D.hfin hN (pointClass P)) :=
+  pointMapOfPushforward_apply D.ι D.hι D.hfin hN P
+
+omit [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd_eq_of_seam (D : IsogenyEndDatum W) (hN : NormFormulaAlong F D.ι D.hfin)
+    (g : W.Point → W.Point) (hg0 : g 0 = 0)
+    (hg : ∀ P, (placeOfPoint P).restrictAlong D.ι D.hι = placeOfPoint (g P)) (P : W.Point) :
+    D.pointEnd hN P = g P :=
+  pointMapOfPushforward_eq_of_seam D.ι D.hι D.hfin hN g hg0 hg P
+
+end IsogenyEndDatum
+
+def isogenyEndSubring (hNs : ∀ D : IsogenyEndDatum W, NormFormulaAlong F D.ι D.hfin) :
+    Subring (AddMonoid.End W.Point) :=
+  Subring.closure (Set.range (fun D => IsogenyEndDatum.pointEnd D (hNs D)))
+
+omit [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W] in
+theorem IsogenyEndDatum.pointEnd_mem_isogenyEndSubring
+    (hNs : ∀ D : IsogenyEndDatum W, NormFormulaAlong F D.ι D.hfin) (D : IsogenyEndDatum W) :
+    D.pointEnd (hNs D) ∈ isogenyEndSubring W hNs :=
+  Subring.subset_closure ⟨D, rfl⟩
+
+structure IsogenyHomDatum (V₀ V₁ : Affine F) where
+  ι : V₁.FunctionField →ₐ[F] V₀.FunctionField
+  hι : ι.toRingHom.IsIntegral
+  hfin : FiniteAlong F ι
+
+namespace IsogenyHomDatum
+
+variable {V₀ V₁ : Affine F} [V₀.IsElliptic] [V₁.IsElliptic]
+variable [GenusOnePlaceGate V₀] [AbelTheorem V₀] [GenusOnePlaceGate V₁] [AbelTheorem V₁]
+
+def pointHom (D : IsogenyHomDatum V₀ V₁) (hN : NormFormulaAlong F D.ι D.hfin) :
+    V₀.Point →+ V₁.Point :=
+  pointMapOfPushforward D.ι D.hι D.hfin hN
+
+omit [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic V₀] [WeierstrassCurve.IsElliptic V₁]
+  in
+theorem pointHom_apply (D : IsogenyHomDatum V₀ V₁) (hN : NormFormulaAlong F D.ι D.hfin)
+    (P : V₀.Point) :
+    D.pointHom hN P = genusOnePic0Equiv V₁
+      (Pic0.pushforwardAlongHom D.ι D.hι D.hfin hN (pointClass P)) :=
+  pointMapOfPushforward_apply D.ι D.hι D.hfin hN P
+
+omit [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic V₀] [WeierstrassCurve.IsElliptic V₁]
+  in
+theorem pointHom_eq_of_seam (D : IsogenyHomDatum V₀ V₁) (hN : NormFormulaAlong F D.ι D.hfin)
+    (g : V₀.Point → V₁.Point) (hg0 : g 0 = 0)
+    (hg : ∀ P, (placeOfPoint P).restrictAlong D.ι D.hι = placeOfPoint (g P))
+    (P : V₀.Point) :
+    D.pointHom hN P = g P :=
+  pointMapOfPushforward_eq_of_seam D.ι D.hι D.hfin hN g hg0 hg P
+
+def ofEndDatum {W' : Affine F} (D : IsogenyEndDatum W') : IsogenyHomDatum W' W' where
+  ι := D.ι
+  hι := D.hι
+  hfin := D.hfin
+
+end IsogenyHomDatum
+
+end WeierstrassCurve.Affine
+
+end IsogenyCurrency
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_LanglandsTunnell_TowerCounting.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_LanglandsTunnell_TowerCounting.lean
new file mode 100644
index 0000000000..b1c3f73d47
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_LanglandsTunnell_TowerCounting.lean
@@ -0,0 +1,100 @@
+/-
+Based on Prove2Me node LanglandsTunnell_TowerCounting
+(deadb51d-8400-5fb0-afbc-e41308b9eb67) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_TaylorWiles_Primes
+public import Mathlib.FieldTheory.Galois.IsGaloisGroup
+
+/-!
+# Frobenius-labelled prime counts over a cyclic subgroup
+
+Definition: `LanglandsTunnell_TowerCounting` (`deadb51d-8400-5fb0-afbc-e41308b9eb67`), by Claude,
+2026-09-05.
+
+Throughout, $L$ is a number field that is Galois over $\mathbb{Q}$. Three counting objects are
+defined. First, `oddJ` is the finite set $\{1,3,5,7\}\subseteq\mathbb{N}$ of odd residues modulo
+$8$. Second, `labelledCount` takes $\sigma\in\operatorname{Gal}(L/\mathbb{Q})$, a finite set $S_0$
+of naturals, a label $m\in\mathbb{Z}/8$ and a natural number $\ell$, and returns a natural number:
+it is $0$ when $\ell\in S_0$ and when $\ell$ is not prime; otherwise it is the number (as
+`Set.ncard`) of primes $\mathfrak{q}$ of the ring of integers of the fixed field
+$L^{\langle\sigma\rangle}$ — the intermediate field of invariants of the subgroup `Subgroup.zpowers
+σ` generated by $\sigma$ — that lie over the ideal $\ell\mathbb{Z}$, subject to two conditions: the
+residue ring at $\mathfrak{q}$ has exactly $\ell$ elements (so $\mathfrak{q}$ has residue degree one
+over $\ell$), and there exists a prime ideal $Q$ of $\mathcal{O}_L$ lying over both $\mathfrak{q}$
+and $\ell\mathbb{Z}$ whose inertia subgroup in $\operatorname{Gal}(L/\mathbb{Q})$ is trivial and
+whose arithmetic Frobenius `arithFrobAt ℤ (L ≃ₐ[ℚ] L) Q` is equal, on the nose and not merely up to
+conjugacy, to $\sigma^{m}$ for the natural number underlying $m$. Third, `classIndicator` takes
+$\sigma$ and $\ell$ and returns $1$ or $0$ according as $\ell$ is prime and some prime $Q$ of
+$\mathcal{O}_L$ over $\ell\mathbb{Z}$ has trivial inertia subgroup in
+$\operatorname{Gal}(L/\mathbb{Q})$ and arithmetic Frobenius conjugate to $\sigma$, or not. Two
+accompanying lemmas record the evident bounds: `labelledCount_of_mem_S₀` states that `labelledCount
+σ S₀ m ℓ` vanishes for $\ell\in S_0$, and `classIndicator_le_one` that `classIndicator σ ℓ \le 1`.
+The finiteness of the residue rings needed to speak of Frobenius is supplied by the prime $Q$ lying
+over $\ell\mathbb{Z}$ with $\ell$ prime.
+
+**Relation to Mathlib.** The two counting functions are the project's own; they are assembled from
+Mathlib's arithmetic Frobenius `arithFrobAt`, the inertia subgroup of a prime, `Ideal.primesOver`
+and `FixedPoints.intermediateField`, together with the project's abbreviation `ratPrimeIdeal ℓ` for
+the ideal $\ell\mathbb{Z}$.
+
+**Where it is used.** These counts are the bookkeeping for the Galois-side density argument that
+produces auxiliary primes with prescribed Frobenius behaviour: the statement that for every $\sigma$
+and every finite set $S$ of primes there is $\ell\notin S$ at which $\sigma$ is realised, up to
+conjugacy and up to a power coprime to its order, by a Frobenius element. That existence statement
+is what feeds the construction of Taylor–Wiles primes $q\equiv 1 \pmod{p^n}$ at which the residual
+representation has distinct rational eigenvalues.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace LanglandsTunnell
+
+open NumberField Ideal FrobeniusDensity
+
+def oddJ : Finset ℕ := {1, 3, 5, 7}
+
+variable {L : Type*} [Field L] [NumberField L] [IsGalois ℚ L]
+
+open scoped Classical in
+noncomputable def labelledCount (σ : L ≃ₐ[ℚ] L) (S₀ : Finset ℕ) (m : Fin 8) (ℓ : ℕ) : ℕ :=
+  if ℓ ∈ S₀ then 0 else
+  if hℓ : ℓ.Prime then
+    {𝔮 ∈ (ratPrimeIdeal ℓ).primesOver
+          (𝓞 (FixedPoints.intermediateField
+              (Subgroup.zpowers σ) : IntermediateField ℚ L)) |
+      Nat.card ((𝓞 (FixedPoints.intermediateField
+          (Subgroup.zpowers σ) : IntermediateField ℚ L)) ⧸ 𝔮) = ℓ ∧
+      ∃ (Q : Ideal (𝓞 L)) (_ : Q.IsPrime) (_ : Q.LiesOver 𝔮)
+        (_ : Q.LiesOver (ratPrimeIdeal ℓ)) (_ : Q.inertia (L ≃ₐ[ℚ] L) = ⊥),
+        haveI : Finite ((𝓞 L) ⧸ Q) :=
+          finite_quotient_of_ne_bot (ne_bot_of_liesOver_ratPrimeIdeal hℓ)
+        arithFrobAt ℤ (L ≃ₐ[ℚ] L) Q = σ ^ (m : ℕ)}.ncard
+  else 0
+
+theorem labelledCount_of_mem_S₀ (σ : L ≃ₐ[ℚ] L) (S₀ : Finset ℕ) (m : Fin 8) {ℓ : ℕ}
+    (h : ℓ ∈ S₀) : labelledCount σ S₀ m ℓ = 0 := by
+  simp [labelledCount, h]
+
+open scoped Classical in
+noncomputable def classIndicator (σ : L ≃ₐ[ℚ] L) (ℓ : ℕ) : ℕ :=
+  if ∃ _ : ℓ.Prime, ∃ (Q : Ideal (𝓞 L)) (_ : Q.IsPrime) (_ : Q.LiesOver (ratPrimeIdeal ℓ))
+        (_ : Q.inertia (L ≃ₐ[ℚ] L) = ⊥),
+      haveI : Finite ((𝓞 L) ⧸ Q) :=
+        finite_quotient_of_ne_bot (ne_bot_of_liesOver_ratPrimeIdeal ‹ℓ.Prime›)
+      IsConj σ (arithFrobAt ℤ (L ≃ₐ[ℚ] L) Q)
+  then 1 else 0
+
+theorem classIndicator_le_one (σ : L ≃ₐ[ℚ] L) (ℓ : ℕ) : classIndicator σ ℓ ≤ 1 := by
+  unfold classIndicator; split <;> simp
+
+end LanglandsTunnell
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_ArithmeticGalois.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_ArithmeticGalois.lean
new file mode 100644
index 0000000000..9cb6564709
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_ArithmeticGalois.lean
@@ -0,0 +1,203 @@
+/-
+Based on Prove2Me node ModularCurve_ArithmeticGalois
+(c3f06811-4d0c-5470-a95b-b2a84dae4304) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_BaseChangeGalois
+public import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure
+
+/-!
+# Coefficientwise Galois action on base-changed Laurent subfields; J0​(N)
+
+Definition: `ModularCurve_ArithmeticGalois` (`c3f06811-4d0c-5470-a95b-b2a84dae4304`), by Claude,
+2026-09-05.
+
+Fix a field $L$ with a $\mathbb{Q}$-algebra structure and an intermediate field $F_0$ of
+$\mathbb{Q}((q))/\mathbb{Q}$, and let $L\cdot F_0 =$ `laurentBaseChange L F₀` be the intermediate
+field of $L((q))/L$ generated over $L$ by the coefficientwise image of $F_0$ under $\mathbb{Q}\to
+L$. For $\sigma : L \simeq_{\mathbb{Q}} L$, `arithmeticRingAut F₀ σ` is the ring automorphism of
+$L\cdot F_0$ obtained by applying $\sigma$ to each Laurent coefficient (`coeffMap`), with inverse
+given by $\sigma^{-1}$; stability of $L\cdot F_0$ under this operation is inherited from
+`coeffMap_mem_laurentBaseChange`, and `arithmeticRingAut_algebraMap` records that it covers $\sigma$
+on the constants. `arithmeticGalois F₀` packages this as a monoid homomorphism from $L
+\simeq_{\mathbb{Q}} L$ into `SemilinearAut L (L·F₀)`, the project's group of pairs (automorphism of
+the big field, automorphism of the constant field) commuting with the structure map: $\sigma \mapsto
+(\mathrm{arithmeticRingAut}\,\sigma,\ \sigma)$. Accompanying lemmas identify its two components and
+the induced scalar action.
+
+Pulling back along `arithmeticGalois` gives `SMul` and `DistribMulAction` instances of
+$L\simeq_{\mathbb{Q}}L$ on `Pic0 L (L·F₀)`, the group of degree-zero divisors (finitely supported
+$\mathbb{Z}$-combinations of the project's places of $L\cdot F_0/L$) modulo principal divisors.
+
+Specialising to $\overline{\mathbb{Q}} =$ `AlgebraicClosure ℚ` and $F_0 =$ `modularFunctionFieldFull
+N` (the field generated over $\mathbb{Q}$ by the $q$-expansions $j(q^d)$ for $d \mid N$), the
+abbreviations `modularFunctionFieldBar N` and `JZero N` name the base-changed field and its
+degree-zero divisor class group; `JZero.torsionGaloisRep N n` is `SemilinearAut.torsionRep` composed
+with `arithmeticGalois`, a homomorphism from $\overline{\mathbb{Q}} \simeq_{\mathbb{Q}}
+\overline{\mathbb{Q}}$ to the $\mathbb{Z}/n$-linear endomorphisms of the $n$-torsion of `JZero N`.
+Nothing about genus, dimension or finiteness is asserted; $J_0(N)$ is here *defined* as this divisor
+class group, with no geometric modular curve intervening. $N$ is an arbitrary natural number.
+
+**Relation to Mathlib.** Mathlib supplies `LaurentSeries`, `IntermediateField` and
+`AlgebraicClosure`; the notions of place, degree-zero divisor class group `Pic0`, semilinear
+automorphism group `SemilinearAut` and modular function field used here are the project's own, as is
+the coefficientwise ring homomorphism `coeffMap` (a packaging of `HahnSeries.map`). Mathlib declares
+no action of $L\simeq_{\mathbb{Q}}L$ on an intermediate field of $L((q))/L$ or on its divisor class
+group.
+
+**Where it is used.** The mod $n$ representation `JZero.torsionGaloisRep` is the form in which the
+Galois action on torsion of the Jacobian of $X_0(N)$ enters the argument: it is the source of the
+two-dimensional mod $\ell$ representations attached to modular forms that are compared, via level
+lowering and Ribet's theorem, with the representation on $\ell$-torsion of a Frey curve.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open IntermediateField HahnSeries AlgebraicCurve
+
+namespace ModularCurve
+
+section ArithmeticGalois
+
+variable {L : Type*} [Field L] [Algebra ℚ L]
+variable (F₀ : IntermediateField ℚ (LaurentSeries ℚ))
+
+def arithmeticRingAut (σ : L ≃ₐ[ℚ] L) :
+    (laurentBaseChange L F₀) ≃+* (laurentBaseChange L F₀) where
+  toFun x := ⟨coeffMap (σ : L →+* L) (x : LaurentSeries L),
+    coeffMap_mem_laurentBaseChange σ x.2⟩
+  invFun x := ⟨coeffMap (σ.symm : L →+* L) (x : LaurentSeries L),
+    coeffMap_mem_laurentBaseChange σ.symm x.2⟩
+  left_inv x := Subtype.ext <| by
+    change coeffMap (σ.symm : L →+* L) (coeffMap (σ : L →+* L) (x : LaurentSeries L))
+      = (x : LaurentSeries L)
+    rw [coeffMap_coeffMap,
+      coeffMap_congr (g := RingHom.id L) (RingHom.ext fun a => σ.symm_apply_apply a)
+        (x : LaurentSeries L),
+      coeffMap_id]
+  right_inv x := Subtype.ext <| by
+    change coeffMap (σ : L →+* L) (coeffMap (σ.symm : L →+* L) (x : LaurentSeries L))
+      = (x : LaurentSeries L)
+    rw [coeffMap_coeffMap,
+      coeffMap_congr (g := RingHom.id L) (RingHom.ext fun a => σ.apply_symm_apply a)
+        (x : LaurentSeries L),
+      coeffMap_id]
+  map_mul' x y :=
+    Subtype.ext (map_mul (coeffMap (σ : L →+* L)) (x : LaurentSeries L) (y : LaurentSeries L))
+  map_add' x y :=
+    Subtype.ext (map_add (coeffMap (σ : L →+* L)) (x : LaurentSeries L) (y : LaurentSeries L))
+
+@[simp]
+theorem coe_arithmeticRingAut_apply (σ : L ≃ₐ[ℚ] L) (x : laurentBaseChange L F₀) :
+    (arithmeticRingAut F₀ σ x : LaurentSeries L) = coeffMap (σ : L →+* L) (x : LaurentSeries L) :=
+  rfl
+
+theorem arithmeticRingAut_algebraMap (σ : L ≃ₐ[ℚ] L) (a : L) :
+    arithmeticRingAut F₀ σ (algebraMap L (laurentBaseChange L F₀) a)
+      = algebraMap L (laurentBaseChange L F₀) (σ a) :=
+  Subtype.ext (coeffMap_algebraMap (σ : L →+* L) a)
+
+def arithmeticGalois : (L ≃ₐ[ℚ] L) →* SemilinearAut L (laurentBaseChange L F₀) where
+  toFun σ := ⟨(arithmeticRingAut F₀ σ, σ.toRingEquiv), fun a => arithmeticRingAut_algebraMap F₀ σ a⟩
+  map_one' := by
+    refine Subtype.ext (Prod.ext (RingEquiv.ext fun x => Subtype.ext ?_) rfl)
+    change coeffMap ((1 : L ≃ₐ[ℚ] L) : L →+* L) (x : LaurentSeries L) = (x : LaurentSeries L)
+    rw [show ((1 : L ≃ₐ[ℚ] L) : L →+* L) = RingHom.id L from RingHom.ext fun _ => rfl,
+      coeffMap_id]
+  map_mul' σ τ := by
+    refine Subtype.ext (Prod.ext (RingEquiv.ext fun x => Subtype.ext ?_) rfl)
+    change coeffMap ((σ * τ : L ≃ₐ[ℚ] L) : L →+* L) (x : LaurentSeries L)
+      = coeffMap (σ : L →+* L) (coeffMap (τ : L →+* L) (x : LaurentSeries L))
+    rw [coeffMap_coeffMap]
+    exact coeffMap_congr (RingHom.ext fun _ => rfl) _
+
+@[simp]
+theorem toRingAut_arithmeticGalois (σ : L ≃ₐ[ℚ] L) :
+    SemilinearAut.toRingAut (arithmeticGalois F₀ σ) = arithmeticRingAut F₀ σ :=
+  rfl
+
+@[simp]
+theorem baseAut_arithmeticGalois (σ : L ≃ₐ[ℚ] L) :
+    SemilinearAut.baseAut (arithmeticGalois F₀ σ) = σ.toRingEquiv :=
+  rfl
+
+theorem coe_arithmeticGalois_smul (σ : L ≃ₐ[ℚ] L) (x : laurentBaseChange L F₀) :
+    ((arithmeticGalois F₀ σ • x : laurentBaseChange L F₀) : LaurentSeries L)
+      = coeffMap (σ : L →+* L) (x : LaurentSeries L) :=
+  rfl
+
+end ArithmeticGalois
+
+section PicAction
+
+variable {L : Type*} [Field L] [Algebra ℚ L]
+variable (F₀ : IntermediateField ℚ (LaurentSeries ℚ))
+
+instance : SMul (L ≃ₐ[ℚ] L) (Pic0 L (laurentBaseChange L F₀)) where
+  smul σ x := arithmeticGalois F₀ σ • x
+
+theorem galois_smul_pic0_def (σ : L ≃ₐ[ℚ] L) (x : Pic0 L (laurentBaseChange L F₀)) :
+    σ • x = arithmeticGalois F₀ σ • x :=
+  rfl
+
+instance : DistribMulAction (L ≃ₐ[ℚ] L) (Pic0 L (laurentBaseChange L F₀)) where
+  one_smul x := by rw [galois_smul_pic0_def, map_one, one_smul]
+  mul_smul σ τ x := by
+    rw [galois_smul_pic0_def, galois_smul_pic0_def, galois_smul_pic0_def, map_mul, mul_smul]
+  smul_zero σ := by rw [galois_smul_pic0_def, smul_zero]
+  smul_add σ x y := by
+    rw [galois_smul_pic0_def, galois_smul_pic0_def, galois_smul_pic0_def, smul_add]
+
+end PicAction
+
+section ModularInstance
+
+variable (N : ℕ)
+
+abbrev modularFunctionFieldBar : IntermediateField (AlgebraicClosure ℚ)
+    (LaurentSeries (AlgebraicClosure ℚ)) :=
+  laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)
+
+abbrev JZero : Type _ :=
+  Pic0 (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+
+example : DistribMulAction (AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) (JZero N) :=
+  inferInstance
+
+def JZero.torsionGaloisRep (n : ℕ) :
+    (AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) →*
+      Module.End (ZMod n) (Pic0.torsion (AlgebraicClosure ℚ) (modularFunctionFieldBar N) n) :=
+  (SemilinearAut.torsionRep _ _ n).comp (arithmeticGalois (modularFunctionFieldFull N))
+
+@[simp]
+theorem JZero.torsionGaloisRep_apply {n : ℕ} (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ)
+    (x : Pic0.torsion (AlgebraicClosure ℚ) (modularFunctionFieldBar N) n) :
+    JZero.torsionGaloisRep N n σ x = arithmeticGalois (modularFunctionFieldFull N) σ • x :=
+  rfl
+
+theorem JZero.coe_torsionGaloisRep_apply {n : ℕ} (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ)
+    (x : Pic0.torsion (AlgebraicClosure ℚ) (modularFunctionFieldBar N) n) :
+    ((JZero.torsionGaloisRep N n σ x : Pic0.torsion (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+      n) :
+        JZero N) = σ • (x : JZero N) :=
+  rfl
+
+end ModularInstance
+
+end ModularCurve
+
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_AtkinLehner.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_AtkinLehner.lean
new file mode 100644
index 0000000000..e5e57b7e0f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_AtkinLehner.lean
@@ -0,0 +1,168 @@
+/-
+Based on Prove2Me node ModularCurve_AtkinLehner
+(7b7a4e1c-636d-5264-8d4e-84450502362a) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlace
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ArithmeticGalois
+
+/-!
+# Fricke involution and the cusps 0 and ∞ on X0​(N)
+
+Definition: `ModularCurve_AtkinLehner` (`7b7a4e1c-636d-5264-8d4e-84450502362a`), by Claude,
+2026-09-05.
+
+Fix $N$ with `[NeZero N]`. Throughout, `modularFunctionField N`, `modularFunctionFieldFull N`,
+`modularFunctionFieldBar N`, the elements `jq`, `jqN N`, the operator `qExpand`, the coefficient
+embedding `coeffEmb`, the places `cuspInfty N`, `cuspInftyFull N`, `qInftyPlaceBar`, `qIntegersBar`,
+the subalgebra `laurentBaseChange` and the type `Place` are the project's own notions, defined in
+the imported modules.
+
+On the two-generator model, `IsFrickeAut N σ` is a predicate on a $\mathbb{Q}$-algebra automorphism
+$\sigma$ of `modularFunctionField N`: it asserts exactly the two equations $\sigma(jq) = jqN\,N$ and
+$\sigma(jqN\,N) = jq$, i.e. that $\sigma$ exchanges the two distinguished generators (classically
+$j(q)\leftrightarrow j(q^N)$, the effect of $\tau\mapsto -1/(N\tau)$); the generators are written as
+the subtype literals $\langle jq, jq\_mem\,N\rangle$, $\langle jqN\,N, jqN\_mem\,N\rangle$.
+`frickeInvolution N` is then a total, closed term: a classically chosen automorphism satisfying
+`IsFrickeAut N` if one exists, and `AlgEquiv.refl` otherwise. The two normal forms
+`isFrickeAut_frickeInvolution` and `frickeInvolution_eq_refl` record precisely these two cases, each
+taking only the (non-)existence hypothesis; no existence, uniqueness or involutivity is asserted
+here. `cuspZero N` is defined as the translate `frickeInvolution N • cuspInfty N` of the place at
+$q=0$ under the action of field automorphisms on places, with `cuspZero_def` the definitional
+unfolding.
+
+The `Full` section repeats this on the all-divisors model: `IsFrickeAutFull N σ` says that for every
+factorisation $a\cdot b = N$ with $a,b$ nonzero, $\sigma$ sends `qExpand ℚ a jq` to `qExpand ℚ b jq`
+(the product form, avoiding natural-number division), and `frickeInvolutionFull N`, its two normal
+forms and `cuspZeroFull N := frickeInvolutionFull N • cuspInftyFull N` are the exact analogues; the
+two choices are made independently.
+
+Finally, `order_coeffEmb_jq` computes that the Hahn-series order of `coeffEmb L jq` is $-1$ for any
+field $L$ over $\mathbb{Q}$ (from $q^{-1}$ having coefficient $1$), and `cuspInftyBar N` uses this
+to instantiate `qInftyPlaceBar` at `coeffEmb (AlgebraicClosure ℚ) jq`, giving a place of
+`modularFunctionFieldBar N` over $\overline{\mathbb{Q}}$; `cuspInftyBar_toValuationSubring` states
+that its valuation subring is `qIntegersBar`, by `rfl`.
+
+**Relation to Mathlib.** Mathlib has no modular function fields, no Atkin–Lehner or Fricke
+involutions and no places of curves; all of those are the project's own. Only general Mathlib
+machinery is used here: $\mathbb{Q}$-algebra equivalences (`AlgEquiv`), classical choice, and the
+order of a Hahn series.
+
+**Where it is used.** These definitions fix the meaning of the Fricke involution and of the cusp $0$
+on both $\mathbb{Q}$-models of the function field of $X_0(N)$, and of the cusp $\infty$ over
+$\overline{\mathbb{Q}}$ on the field carrying the project's $J_0(N)$ data. They are the base for the
+statements about $J_0(N)$ — its cusps, reduction at primes $\ell \nmid Np$ and the Eichler–Shimura
+relation — which feed the modularity and level-lowering part of the argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open IntermediateField AlgebraicCurve
+
+namespace ModularCurve
+
+section Fricke
+
+variable (N : ℕ) [NeZero N]
+
+def IsFrickeAut (σ : modularFunctionField N ≃ₐ[ℚ] modularFunctionField N) : Prop :=
+  σ ⟨jq, jq_mem N⟩ = ⟨jqN N, jqN_mem N⟩ ∧ σ ⟨jqN N, jqN_mem N⟩ = ⟨jq, jq_mem N⟩
+
+open Classical in
+def frickeInvolution : modularFunctionField N ≃ₐ[ℚ] modularFunctionField N :=
+  if h : ∃ σ : modularFunctionField N ≃ₐ[ℚ] modularFunctionField N, IsFrickeAut N σ
+  then h.choose else AlgEquiv.refl
+
+theorem isFrickeAut_frickeInvolution
+    (h : ∃ σ : modularFunctionField N ≃ₐ[ℚ] modularFunctionField N, IsFrickeAut N σ) :
+    IsFrickeAut N (frickeInvolution N) := by
+  rw [frickeInvolution, dite_eq_left h]
+  exact h.choose_spec
+
+theorem frickeInvolution_eq_refl
+    (h : ¬ ∃ σ : modularFunctionField N ≃ₐ[ℚ] modularFunctionField N, IsFrickeAut N σ) :
+    frickeInvolution N = AlgEquiv.refl := by
+  rw [frickeInvolution, dite_eq_right h]
+
+def cuspZero : Place ℚ (modularFunctionField N) := frickeInvolution N • cuspInfty N
+
+theorem cuspZero_def : cuspZero N = frickeInvolution N • cuspInfty N := rfl
+
+end Fricke
+
+section Full
+
+def IsFrickeAutFull (N : ℕ) [NeZero N]
+    (σ : modularFunctionFieldFull N ≃ₐ[ℚ] modularFunctionFieldFull N) : Prop :=
+  ∀ (a b : ℕ) (hab : a * b = N) (_ : NeZero a) (_ : NeZero b),
+    σ ⟨qExpand ℚ a jq, jqd_mem_full N (Dvd.intro b hab)⟩
+      = ⟨qExpand ℚ b jq, jqd_mem_full N (Dvd.intro_left a hab)⟩
+
+open Classical in
+def frickeInvolutionFull (N : ℕ) [NeZero N] :
+    modularFunctionFieldFull N ≃ₐ[ℚ] modularFunctionFieldFull N :=
+  if h : ∃ σ : modularFunctionFieldFull N ≃ₐ[ℚ] modularFunctionFieldFull N, IsFrickeAutFull N σ
+  then h.choose else AlgEquiv.refl
+
+theorem isFrickeAutFull_frickeInvolutionFull (N : ℕ) [NeZero N]
+    (h : ∃ σ : modularFunctionFieldFull N ≃ₐ[ℚ] modularFunctionFieldFull N,
+      IsFrickeAutFull N σ) :
+    IsFrickeAutFull N (frickeInvolutionFull N) := by
+  rw [frickeInvolutionFull, dite_eq_left h]
+  exact h.choose_spec
+
+theorem frickeInvolutionFull_eq_refl (N : ℕ) [NeZero N]
+    (h : ¬ ∃ σ : modularFunctionFieldFull N ≃ₐ[ℚ] modularFunctionFieldFull N,
+      IsFrickeAutFull N σ) :
+    frickeInvolutionFull N = AlgEquiv.refl := by
+  rw [frickeInvolutionFull, dite_eq_right h]
+
+variable (N : ℕ) [NeZero N]
+
+def cuspZeroFull : Place ℚ (modularFunctionFieldFull N) :=
+  frickeInvolutionFull N • cuspInftyFull N
+
+theorem cuspZeroFull_def : cuspZeroFull N = frickeInvolutionFull N • cuspInftyFull N := rfl
+
+end Full
+
+section Bar
+
+theorem order_coeffEmb_jq (L : Type*) [Field L] [Algebra ℚ L] : (coeffEmb L jq).order = -1 := by
+  have h1 : (coeffEmb L jq).coeff (-1) ≠ 0 := by
+    rw [coeffEmb_coeff, coeff_jq_neg_one, map_one]
+    exact one_ne_zero
+  have h0 : coeffEmb L jq ≠ 0 := fun h => h1 (by rw [h, HahnSeries.coeff_zero])
+  refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero h1) ?_
+  by_contra! h
+  exact HahnSeries.coeff_order_eq_zero.not.mpr h0
+    (by rw [coeffEmb_coeff, coeff_jq_of_lt h, map_zero])
+
+variable (N : ℕ) [NeZero N]
+
+def cuspInftyBar : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) :=
+  qInftyPlaceBar (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+    ⟨⟨coeffEmb (AlgebraicClosure ℚ) jq,
+      coeffEmb_mem_laurentBaseChange (L := AlgebraicClosure ℚ) (hx := jq_mem_full N)⟩,
+      order_coeffEmb_jq (AlgebraicClosure ℚ)⟩
+
+theorem cuspInftyBar_toValuationSubring :
+    (cuspInftyBar N).toValuationSubring
+      = qIntegersBar (AlgebraicClosure ℚ) (modularFunctionFieldBar N) := rfl
+
+end Bar
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CanonicalDivisor.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CanonicalDivisor.lean
new file mode 100644
index 0000000000..c7d92154bf
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CanonicalDivisor.lean
@@ -0,0 +1,155 @@
+/-
+Based on Prove2Me node ModularCurve_CanonicalDivisor
+(9e0b4190-0a8e-59ea-9ad4-416e20b30bfb) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.Flat.FaithfullyFlat.Basic
+public import Mathlib.RingTheory.Flat.TorsionFree
+public import Mathlib.RingTheory.Kaehler.Basic
+public import Mathlib.RingTheory.SimpleRing.Principal
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+/-!
+# Order of a Kähler differential at a place of a function field
+
+Definition: `ModularCurve_CanonicalDivisor` (`9e0b4190-0a8e-59ea-9ad4-416e20b30bfb`), by Claude,
+2026-09-05.
+
+Throughout, $K \subseteq F$ are fields with $F$ a $K$-algebra and $v$ is a place of $F$ over $K$ in
+the sense of [`AlgebraicCurve.Place`](../def/AlgebraicCurve_DivisorClassGroup.html#L22): a valuation
+subring of $F$ containing the image of $K$, different from $\top$, whose ideals are principal, so
+that it is a discrete valuation ring and $v$ carries the normalised order function $v.ord$ on $F$
+with $v.ord$ of a uniformizer equal to $1$ and $v.ord\,0 = 0$. A uniformizer of $v$ is fixed (by a
+choice of an irreducible element of the valuation ring) and used only internally; from it
+[`AlgebraicCurve.Place.dCoord`](../def/ModularCurve_CanonicalDivisor.html#L30) is the Kähler
+differential $d\pi_v \in \Omega[F\!\restriction\!K]$, the image of the chosen uniformizer under
+Mathlib's universal derivation. The class
+[`AlgebraicCurve.Place.DCoordGenerates`](../def/ModularCurve_CanonicalDivisor.html#L32) is the
+single-field hypothesis that the $F$-submodule of $\Omega[F\!\restriction\!K]$ spanned by
+$\{d\pi_v\}$ is everything; it is thus a hypothesis on the chosen uniformizer, asserting that
+$d\pi_v$ is a generator of the module of differentials, not a theorem proved here. Under it every
+$\omega$ is of the form $f\cdot d\pi_v$, and `differentialCoeff` returns such an $f$ (and $0$ when
+no such $f$ exists); when $\Omega[F\!\restriction\!K]$ is nontrivial, $d\pi_v \neq 0$ and the
+coefficient is unique, so `differentialCoeff` is $F$-homogeneous, sends $d\pi_v$ to $1$ and $0$ to
+$0$.
+
+Finally [`AlgebraicCurve.Place.ordDifferential`](../def/ModularCurve_CanonicalDivisor.html#L82) is
+defined by $\operatorname{ord}_v(\omega) := v.ord(\,\mathrm{differentialCoeff}\ \omega\,)$, an
+integer; since $v.ord$ vanishes at $0$, this convention assigns the value $0$ rather than $+\infty$
+to the zero differential. Two basic properties are recorded: the order of $d\pi_v$ itself is $0$,
+and for $c \neq 0$ with $\omega$ of nonzero coefficient, $\operatorname{ord}_v(c\,\omega) = v.ord(c)
++ \operatorname{ord}_v(\omega)$.
+
+**Relation to Mathlib.** The module of differentials is Mathlib's `KaehlerDifferential`
+$\Omega[F\!\restriction\!K]$; Mathlib has no notion of the order of a differential at a place of a
+function field, and `DCoordGenerates` and the coefficient and order functions are the project's own.
+
+**Where it is used.** These notions supply the local order of a differential, hence the data needed
+to form canonical divisors and to study the Cartier operator and Hasse–Witt matrix of a modular
+curve in the project's treatment of divisors on curves.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open KaehlerDifferential
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable {K F}
+variable (v : Place K F)
+
+def uniformizer : F :=
+  ((IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose : F)
+
+private theorem ord_uniformizer : v.ord v.uniformizer = 1 := by
+  have hirr := (IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose_spec
+  simpa [uniformizer] using v.ord_coe_irreducible hirr
+
+private theorem uniformizer_ne_zero : v.uniformizer ≠ 0 := by
+  intro h
+  simpa [h, v.ord_zero] using v.ord_uniformizer
+
+def dCoord : Ω[F⁄K] := KaehlerDifferential.D K F v.uniformizer
+
+class DCoordGenerates : Prop where
+  span_eq_top : Submodule.span F {v.dCoord} = ⊤
+
+theorem dCoord_ne_zero [v.DCoordGenerates] [Nontrivial Ω[F⁄K]] : v.dCoord ≠ 0 := by
+  intro h0
+  have htop := DCoordGenerates.span_eq_top (v := v)
+  obtain ⟨x, hx⟩ := exists_ne (0 : Ω[F⁄K])
+  have hx_mem : x ∈ Submodule.span F {v.dCoord} := htop ▸ Submodule.mem_top
+  rw [h0, Submodule.span_zero_singleton] at hx_mem
+  exact hx hx_mem
+
+def differentialCoeff (ω : Ω[F⁄K]) : F :=
+  letI := Classical.propDecidable
+  if h : ∃ f : F, ω = f • v.dCoord then h.choose else 0
+
+theorem exists_eq_smul_dCoord [v.DCoordGenerates] (ω : Ω[F⁄K]) :
+    ∃ f : F, ω = f • v.dCoord := by
+  have hω : ω ∈ (⊤ : Submodule F Ω[F⁄K]) := Submodule.mem_top
+  rw [← DCoordGenerates.span_eq_top (v := v), Submodule.mem_span_singleton] at hω
+  exact hω.imp fun _ hf => hf.symm
+
+theorem differentialCoeff_smul_dCoord [v.DCoordGenerates] (ω : Ω[F⁄K]) :
+    v.differentialCoeff ω • v.dCoord = ω := by
+  rw [differentialCoeff, dite_eq_left (v.exists_eq_smul_dCoord ω)]
+  exact (v.exists_eq_smul_dCoord ω).choose_spec.symm
+
+theorem differentialCoeff_unique [v.DCoordGenerates] [Nontrivial Ω[F⁄K]]
+    {ω : Ω[F⁄K]} {f : F} (hf : ω = f • v.dCoord) : v.differentialCoeff ω = f := by
+  have key : (v.differentialCoeff ω - f) • v.dCoord = 0 := by
+    rw [sub_smul, v.differentialCoeff_smul_dCoord ω, hf, sub_self]
+  rcases smul_eq_zero.mp key with h | h
+  · exact sub_eq_zero.mp h
+  · exact absurd h v.dCoord_ne_zero
+
+@[simp]
+theorem differentialCoeff_dCoord [v.DCoordGenerates] [Nontrivial Ω[F⁄K]] :
+    v.differentialCoeff v.dCoord = 1 :=
+  v.differentialCoeff_unique (one_smul F v.dCoord).symm
+
+@[simp]
+theorem differentialCoeff_zero [v.DCoordGenerates] [Nontrivial Ω[F⁄K]] :
+    v.differentialCoeff (0 : Ω[F⁄K]) = 0 :=
+  v.differentialCoeff_unique (zero_smul F v.dCoord).symm
+
+theorem differentialCoeff_smul [v.DCoordGenerates] [Nontrivial Ω[F⁄K]]
+    (c : F) (ω : Ω[F⁄K]) :
+    v.differentialCoeff (c • ω) = c * v.differentialCoeff ω :=
+  v.differentialCoeff_unique
+    (by rw [mul_smul, v.differentialCoeff_smul_dCoord])
+
+def ordDifferential (ω : Ω[F⁄K]) : ℤ := v.ord (v.differentialCoeff ω)
+
+theorem gate_ordDifferential_dCoord [v.DCoordGenerates] [Nontrivial Ω[F⁄K]] :
+    v.ordDifferential v.dCoord = 0 := by
+  rw [ordDifferential, v.differentialCoeff_dCoord, v.ord_one]
+
+theorem ordDifferential_smul [v.DCoordGenerates] [Nontrivial Ω[F⁄K]]
+    {c : F} (hc : c ≠ 0) {ω : Ω[F⁄K]} (hω : v.differentialCoeff ω ≠ 0) :
+    v.ordDifferential (c • ω) = v.ord c + v.ordDifferential ω := by
+  rw [ordDifferential, ordDifferential, v.differentialCoeff_smul, v.ord_mul hc hω]
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CanonicalDivisorUniformizer.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CanonicalDivisorUniformizer.lean
new file mode 100644
index 0000000000..b737da70be
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CanonicalDivisorUniformizer.lean
@@ -0,0 +1,86 @@
+/-
+Based on Prove2Me node ModularCurve_CanonicalDivisorUniformizer
+(e1d77d25-d6e7-5030-a528-709608c934a0) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CanonicalDivisor
+
+/-!
+# Chosen uniformizer at a place and its order
+
+Definition: `ModularCurve_CanonicalDivisorUniformizer` (`e1d77d25-d6e7-5030-a528-709608c934a0`), by
+Claude, 2026-09-05.
+
+The setting is a field extension $F/K$ of fields and a place $v : \mathrm{Place}\ K\ F$, i.e. (in
+the project's sense) a valuation subring $\mathcal{O}_v \subseteq F$ containing
+$\mathrm{algebraMap}\ K\ F$ of all of $K$, distinct from $F$ itself, and a principal ideal ring;
+such a ring is then a discrete valuation ring, $v.\mathrm{ord}$ is the associated normalised
+additive valuation on $F$ (minus the logarithm of the $\mathfrak{m}_v$-adic valuation, with the
+convention $v.\mathrm{ord}\,0 = 0$), and $v.\mathrm{dCoord} \in \Omega[F\,\vert\,K]$ is the Kähler
+differential of a uniformizer at $v$.
+
+[`AlgebraicCurve.Place.uniformizer`](../def/ModularCurve_CanonicalDivisor.html#L19) makes this
+choice available as a public definition: it is the element of $F$ obtained by coercing the
+irreducible element of $\mathcal{O}_v$ whose existence is given by the discrete valuation ring
+structure on $\mathcal{O}_v$. Thus it is a chosen generator of the maximal ideal, canonical only up
+to a unit. Three facts accompany it. `ord_uniformizer` states $v.\mathrm{ord}(\pi_v) = 1$, so the
+chosen element does have order exactly one at $v$; it follows from the computation of $\mathrm{ord}$
+on the image of an irreducible element of $\mathcal{O}_v$. `uniformizer_ne_zero` states $\pi_v \neq
+0$ in $F$, obtained from the previous statement together with $v.\mathrm{ord}\,0 = 0$. Finally
+`dCoord_eq` identifies the differential used for the canonical-divisor formalism with the
+differential of this element: $v.\mathrm{dCoord} = D_{K/F}(\pi_v)$ in the module of Kähler
+differentials $\Omega[F\,\vert\,K]$, where $D$ is Mathlib's universal derivation. The point of the
+module is therefore to expose, under a stable name and with its basic properties, the same chosen
+irreducible element that is used privately in the definition of `dCoord`, so that the differential
+coefficient and order-of-differential constructions can be computed against an explicit local
+parameter.
+
+**Relation to Mathlib.** The notion of `Place` of $F/K$ as a valuation subring containing $K$,
+proper and principal, together with its `ord`, is the project's own; the existence of an irreducible
+element and the module of Kähler differentials $\Omega[F\,\vert\,K]$ with its universal derivation
+`KaehlerDifferential.D` are taken from Mathlib.
+
+**Where it is used.** These declarations serve the divisor-theoretic treatment of curves, in
+particular of modular curves, where orders of functions and of differentials at a place are computed
+against a local parameter; they underlie the definitions of the differential coefficient, the order
+of a differential and hence of the canonical divisor.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open KaehlerDifferential
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable (v : Place K F)
+
+theorem ord_uniformizer : v.ord v.uniformizer = 1 := by
+  have hirr := (IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose_spec
+  simpa [uniformizer] using v.ord_coe_irreducible hirr
+
+theorem uniformizer_ne_zero : v.uniformizer ≠ 0 := by
+  intro h
+  simpa [h, v.ord_zero] using v.ord_uniformizer
+
+theorem dCoord_eq : v.dCoord = KaehlerDifferential.D K F v.uniformizer := rfl
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CharLFrobeniusGeomLevel.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CharLFrobeniusGeomLevel.lean
new file mode 100644
index 0000000000..70b6d6e5b6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CharLFrobeniusGeomLevel.lean
@@ -0,0 +1,1355 @@
+/-
+Based on Prove2Me node ModularCurve_CharLFrobeniusGeomLevel
+(ab79ccd6-b062-520c-a291-c05b75df1a27) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Data.Finsupp.Pointwise
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_FrobeniusEndoPic0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeGalois_EichlerShimura
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_KroneckerTransport
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_frobenius_identity_geom_unconditional
+
+/-!
+# Characteristic-ℓ Frobenius and Hecke operators on modular function fields
+
+Definition: `ModularCurve_CharLFrobeniusGeomLevel` (`ab79ccd6-b062-520c-a291-c05b75df1a27`), by
+Claude, 2026-09-05.
+
+Fix a field $K$ of characteristic $\ell$ ($\ell$ prime), an integer $N \neq 0$, a datum `data :
+ModularPolynomialData ℓ` and a hypothesis `hKr : KroneckerCongruence ℓ data`. Inside $K((q))$ the
+field `modularFunctionFieldC K N` is the intermediate field generated over $K$ by `jqModC K` (the
+Laurent series $q^{-1}$ times the reduction of the integral power series `jNum`, i.e. the
+$q$-expansion of $j$) and by `jqNModC K N`, its image under the substitution $q \mapsto q^N$. The
+substitution $q \mapsto q^\ell$, packaged as a $K$-algebra endomorphism `qExpandAlgC K ℓ` of
+$K((q))$, raises each of these two generators to the $\ell$-th power, by the identity $j(q^\ell) =
+j(q)^\ell$ recorded in `ModularPolynomialData.frobenius_identity_geom`; hence it maps the field into
+itself, and `frobeniusGeomLevel` is the resulting injective $K$-algebra endomorphism, with
+`frobeniusGeomLevelImage` its image and `frobeniusGeomLevelEquiv` the isomorphism onto that image.
+Every $\ell$-th power lies in the image, so the extension is purely inseparable of exponent dividing
+$\ell$: `isFrobeniusEndo_frobeniusGeomLevel` verifies both clauses of `IsFrobeniusEndo ℓ`, namely
+that each $x^\ell$ is a value and each value is an $\ell$-th power, given that $K$ is closed under
+$\ell$-th roots.
+
+On places, `frobOnPlacesGeomLevel` sends $w$ to the place whose valuation subring consists of the
+$x$ with `frobeniusGeomLevel x` in that of $w$; it is injective, and surjective under the same
+perfectness hypothesis, via `IsFrobeniusEndo.extendPlace`, which pulls a place back along the ring
+homomorphism `frobNormRingHom` given by the inverse-image map `frobNorm`. `verOnPlacesGeomLevel` is
+a classically chosen one-sided inverse. Ramification is computed: $\mathrm{ord}_w(\mathrm{Frob}\,g)
+= \ell\,\mathrm{ord}_{\mathrm{Frob}(w)}(g)$.
+
+On divisors, `frobeniusPushforwardGeomLevel` transports supports along `frobOnPlacesGeomLevel`,
+`frobeniusPullbackGeomLevel` sends $\langle v, n\rangle$ to $\langle \mathrm{Ver}(v), n\ell\rangle$,
+and `heckeFibreGeomLevel` is their sum. Their composite satisfies $\mathrm{Frob}^*\mathrm{Frob}_* =
+\ell$, degrees are multiplied by $1$, $\ell$ and $\ell+1$ when all places have degree one, and all
+three preserve principality; they therefore descend to degree-zero divisors and to `Pic0`, where
+`eichlerShimura_special_fibre_pic0_level` gives $\mathrm{Frob}_*^2 - T\,\mathrm{Frob}_* + \ell = 0$.
+The `…OfIsCurveOver` variants supply the perfectness and degree-one hypotheses from $K$
+algebraically closed together with `IsCurveOver K (modularFunctionFieldC K N)`.
+
+**Relation to Mathlib.** The framework of places, divisors, degree-zero divisors and `Pic0` for a
+function field, the predicate `IsCurveOver`, and `IsFrobeniusEndo` are the project's own; Mathlib
+supplies the ambient `LaurentSeries`, `IntermediateField`, `ValuationSubring` and `Finsupp`
+material. Some general lemmas on valuation subrings and on ramification indices of restricted places
+are proved here alongside.
+
+**Where it is used.** These operators model the Frobenius and Verschiebung morphisms, and the Hecke
+correspondence $T_\ell$, on the characteristic-$\ell$ fibre of the modular curve of level $N$, the
+Eichler–Shimura congruence relation on its Jacobian being what links Hecke eigenvalues to traces of
+Frobenius in the Galois representations attached to modular forms.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public noncomputable section publicSection
+
+open AlgebraicCurve Polynomial
+
+namespace ModularCurve
+
+section ConstantEmbedding
+variable {R : Type*} [CommRing R]
+
+theorem algebraMap_laurentSeries_apply_eq_single (c : R) :
+    algebraMap R (LaurentSeries R) c = HahnSeries.single 0 c := by
+  have h1 : algebraMap R (PowerSeries R) c = PowerSeries.C c := by simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+  rfl
+
+end ConstantEmbedding
+
+section QExpandAlg
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+
+def qExpandAlgC : LaurentSeries K →ₐ[K] LaurentSeries K where
+  __ := qExpand K N
+  commutes' r := by
+    change qExpand K N (algebraMap K (LaurentSeries K) r) = algebraMap K (LaurentSeries K) r
+    rw [algebraMap_laurentSeries_apply_eq_single, qExpand_single, mul_zero]
+
+@[simp]
+theorem qExpandAlgC_apply (f : LaurentSeries K) : qExpandAlgC K N f = qExpand K N f := rfl
+
+end QExpandAlg
+
+section FrobId
+variable (K : Type*) [Field K] {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+
+theorem ModularPolynomialData.frobenius_identity_geom (_data : ModularPolynomialData ℓ)
+    (_hK : KroneckerCongruence ℓ _data) :
+    jqNModC K ℓ = (jqModC K) ^ ℓ :=
+  frobenius_identity_geom_unconditional K
+
+end FrobId
+
+section DegOneBridge
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N] [IsAlgClosed K]
+    [IsCurveOver K (modularFunctionFieldC K N)]
+
+theorem deg_eq_one_modularFunctionFieldC :
+    ∀ w : Place K (modularFunctionFieldC K N), w.deg = 1 :=
+  IsCurveOver.forall_deg_eq_one_of_isAlgClosed
+
+end DegOneBridge
+
+section FrobeniusEndomorphism
+
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+variable (data : ModularPolynomialData ℓ) (hKr : KroneckerCongruence ℓ data)
+
+include data hKr in
+theorem qExpand_jqModC_eq_pow : qExpand K ℓ (jqModC K) = (jqModC K) ^ ℓ :=
+  data.frobenius_identity_geom K hKr
+
+include data hKr in
+theorem qExpand_jqNModC_eq_pow : qExpand K ℓ (jqNModC K N) = (jqNModC K N) ^ ℓ := by
+  rw [jqNModC, qExpand_qExpand, qExpand_congr (mul_comm ℓ N), ← qExpand_qExpand,
+    qExpand_jqModC_eq_pow K data hKr, map_pow]
+
+include data hKr in
+theorem frobeniusGeomLevel_map_le :
+    (modularFunctionFieldC K N).map (qExpandAlgC K ℓ) ≤ modularFunctionFieldC K N := by
+  change (IntermediateField.adjoin K {jqModC K, jqNModC K N}).map (qExpandAlgC K ℓ) ≤ _
+  rw [IntermediateField.adjoin_map, Set.image_pair, IntermediateField.adjoin_le_iff]
+  rintro x (rfl | rfl)
+  · change qExpandAlgC K ℓ (jqModC K) ∈ modularFunctionFieldC K N
+    rw [qExpandAlgC_apply, qExpand_jqModC_eq_pow K data hKr]
+    exact pow_mem (jqModC_mem K N) ℓ
+  · change qExpandAlgC K ℓ (jqNModC K N) ∈ modularFunctionFieldC K N
+    rw [qExpandAlgC_apply, qExpand_jqNModC_eq_pow K N data hKr]
+    exact pow_mem (jqNModC_mem K N) ℓ
+
+def frobeniusGeomLevelImage : IntermediateField K (LaurentSeries K) :=
+  (modularFunctionFieldC K N).map (qExpandAlgC K ℓ)
+
+def frobeniusGeomLevelEquiv :
+    (modularFunctionFieldC K N) ≃ₐ[K] (frobeniusGeomLevelImage K N (ℓ := ℓ)) :=
+  (modularFunctionFieldC K N).equivMap (qExpandAlgC K ℓ)
+
+omit [CharP K ℓ] in
+@[simp]
+theorem coe_frobeniusGeomLevelEquiv_apply (x : modularFunctionFieldC K N) :
+    (frobeniusGeomLevelEquiv K N (ℓ := ℓ) x : LaurentSeries K)
+      = qExpand K ℓ (x : LaurentSeries K) :=
+  IntermediateField.coe_equivMap_apply _ _ x
+
+include data hKr in
+def frobeniusGeomLevel : modularFunctionFieldC K N →ₐ[K] modularFunctionFieldC K N :=
+  (IntermediateField.inclusion (frobeniusGeomLevel_map_le K N data hKr)).comp
+    (frobeniusGeomLevelEquiv K N (ℓ := ℓ)).toAlgHom
+
+@[simp]
+theorem frobeniusGeomLevel_apply_coe (x : modularFunctionFieldC K N) :
+    (frobeniusGeomLevel K N data hKr x : LaurentSeries K)
+      = qExpand K ℓ (x : LaurentSeries K) := by
+  refine (IntermediateField.coe_inclusion (frobeniusGeomLevel_map_le K N data hKr)
+    _).trans ?_
+  exact coe_frobeniusGeomLevelEquiv_apply K N x
+
+theorem frobeniusGeomLevel_jq :
+    frobeniusGeomLevel K N data hKr ⟨jqModC K, jqModC_mem K N⟩
+      = (⟨jqModC K, jqModC_mem K N⟩ : modularFunctionFieldC K N) ^ ℓ := by
+  refine Subtype.ext ?_
+  rw [frobeniusGeomLevel_apply_coe]
+  push_cast
+  exact qExpand_jqModC_eq_pow K data hKr
+
+theorem frobeniusGeomLevel_jqN :
+    frobeniusGeomLevel K N data hKr ⟨jqNModC K N, jqNModC_mem K N⟩
+      = (⟨jqNModC K N, jqNModC_mem K N⟩ : modularFunctionFieldC K N) ^ ℓ := by
+  refine Subtype.ext ?_
+  rw [frobeniusGeomLevel_apply_coe]
+  push_cast
+  exact qExpand_jqNModC_eq_pow K N data hKr
+
+theorem frobeniusGeomLevel_injective :
+    Function.Injective (frobeniusGeomLevel K N data hKr) := by
+  intro x y h
+  have h' := congrArg (fun z : modularFunctionFieldC K N => (z : LaurentSeries K)) h
+  simp only [frobeniusGeomLevel_apply_coe] at h'
+  exact Subtype.ext (qExpand_injective _ h')
+
+theorem exists_frobeniusGeomLevel_eq_iff (x : modularFunctionFieldC K N) :
+    (∃ y, frobeniusGeomLevel K N data hKr y = x)
+      ↔ (x : LaurentSeries K) ∈ frobeniusGeomLevelImage K N (ℓ := ℓ) := by
+  constructor
+  · rintro ⟨y, rfl⟩
+    rw [frobeniusGeomLevel_apply_coe]
+    exact ⟨(y : LaurentSeries K), y.2, rfl⟩
+  · rintro ⟨y, hy, hyx⟩
+    refine ⟨⟨y, hy⟩, Subtype.ext ?_⟩
+    rw [frobeniusGeomLevel_apply_coe]
+    exact hyx
+
+end FrobeniusEndomorphism
+
+section PurelyInseparable
+
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+variable (data : ModularPolynomialData ℓ) (hKr : KroneckerCongruence ℓ data)
+
+omit [Fact ℓ.Prime] in
+theorem charP_laurentSeries : CharP (LaurentSeries K) ℓ :=
+  charP_of_injective_algebraMap (algebraMap K (LaurentSeries K)).injective ℓ
+
+include data hKr in
+theorem pow_mem_frobeniusGeomLevelImage
+    {x : LaurentSeries K} (hx : x ∈ modularFunctionFieldC K N) :
+    x ^ ℓ ∈ frobeniusGeomLevelImage K N (ℓ := ℓ) := by
+  have : CharP (LaurentSeries K) ℓ := charP_laurentSeries K
+  induction hx using IntermediateField.adjoin_induction with
+  | mem y hy =>
+    rcases hy with rfl | rfl
+    · rw [← qExpand_jqModC_eq_pow K data hKr]
+      exact ⟨jqModC K, jqModC_mem K N, rfl⟩
+    · rw [← qExpand_jqNModC_eq_pow K N data hKr]
+      exact ⟨jqNModC K N, jqNModC_mem K N, rfl⟩
+  | algebraMap c =>
+    rw [← map_pow]
+    exact (frobeniusGeomLevelImage K N (ℓ := ℓ)).algebraMap_mem (c ^ ℓ)
+  | add y z _ _ hy hz =>
+    rw [add_pow_char]
+    exact add_mem hy hz
+  | inv y _ hy =>
+    rw [inv_pow]
+    exact inv_mem hy
+  | mul y z _ _ hy hz =>
+    rw [mul_pow]
+    exact mul_mem hy hz
+
+theorem exists_frobeniusGeomLevel_eq_pow (x : modularFunctionFieldC K N) :
+    ∃ y, frobeniusGeomLevel K N data hKr y = x ^ ℓ := by
+  rw [exists_frobeniusGeomLevel_eq_iff]
+  change (x : LaurentSeries K) ^ ℓ ∈ frobeniusGeomLevelImage K N (ℓ := ℓ)
+  exact pow_mem_frobeniusGeomLevelImage K N data hKr x.2
+
+theorem _root_.ValuationSubring.mem_of_pow_mem' {F : Type*} [Field F]
+    (A : ValuationSubring F) {x : F} {n : ℕ} (hn : n ≠ 0) (h : x ^ n ∈ A) : x ∈ A := by
+  rcases A.mem_or_inv_mem x with hx | hx
+  · exact hx
+  rcases eq_or_ne x 0 with rfl | hx0
+  · exact A.zero_mem
+  have hpow : x ^ n = x * x ^ (n - 1) := by
+    rw [← pow_succ']
+    exact congrArg (x ^ ·) (by omega)
+  have hkey : x ^ n * (x⁻¹) ^ (n - 1) = x := by
+    rw [hpow, inv_pow, mul_assoc, mul_inv_cancel₀ (pow_ne_zero _ hx0), mul_one]
+  rw [← hkey]
+  exact A.mul_mem _ _ h (pow_mem hx _)
+
+theorem mem_valuationSubring_iff_pow_mem {F : Type*} [Field F] (A : ValuationSubring F)
+    (x : F) : x ∈ A ↔ x ^ ℓ ∈ A :=
+  ⟨fun h => pow_mem h ℓ,
+    fun h => ValuationSubring.mem_of_pow_mem' A (Fact.out : ℓ.Prime).pos.ne' h⟩
+
+end PurelyInseparable
+
+section PlaceLevel
+
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+variable (data : ModularPolynomialData ℓ) (hKr : KroneckerCongruence ℓ data)
+
+include data hKr in
+@[reducible] def frobImageAlgebra :
+    Algebra (frobeniusGeomLevelImage K N (ℓ := ℓ)) (modularFunctionFieldC K N) :=
+  (IntermediateField.inclusion (frobeniusGeomLevel_map_le K N data hKr)).toRingHom.toAlgebra
+
+theorem frobImageTower :
+    letI := frobImageAlgebra K N data hKr
+    IsScalarTower K (frobeniusGeomLevelImage K N (ℓ := ℓ)) (modularFunctionFieldC K N) :=
+  letI := frobImageAlgebra K N data hKr
+  IsScalarTower.of_algebraMap_eq fun _ => Subtype.ext rfl
+
+theorem frobImageIsIntegral :
+    letI := frobImageAlgebra K N data hKr
+    Algebra.IsIntegral (frobeniusGeomLevelImage K N (ℓ := ℓ))
+      (modularFunctionFieldC K N) := by
+  let := frobImageAlgebra K N data hKr
+  refine ⟨fun x => ?_⟩
+  refine ⟨Polynomial.X ^ ℓ - Polynomial.C
+    ⟨(x : LaurentSeries K) ^ ℓ, pow_mem_frobeniusGeomLevelImage K N data hKr x.2⟩,
+    Polynomial.monic_X_pow_sub_C _ (Fact.out : ℓ.Prime).pos.ne', ?_⟩
+  rw [Polynomial.eval₂_sub, Polynomial.eval₂_X_pow, Polynomial.eval₂_C, sub_eq_zero]
+  exact Subtype.ext rfl
+
+include data hKr in
+def frobOnPlacesGeomLevel (w : Place K (modularFunctionFieldC K N)) :
+    Place K (modularFunctionFieldC K N) :=
+  letI := frobImageAlgebra K N data hKr
+  letI := frobImageTower K N data hKr
+  letI := frobImageIsIntegral K N data hKr
+  (Place.congrEquiv (frobeniusGeomLevelEquiv K N (ℓ := ℓ)).toRingEquiv
+    (fun a => (frobeniusGeomLevelEquiv K N (ℓ := ℓ)).commutes a)).symm
+    (w.restrict (frobeniusGeomLevelImage K N (ℓ := ℓ)))
+
+theorem mem_frobOnPlacesGeomLevel_iff (w : Place K (modularFunctionFieldC K N))
+    (x : modularFunctionFieldC K N) :
+    x ∈ (frobOnPlacesGeomLevel K N data hKr w).toValuationSubring
+      ↔ frobeniusGeomLevel K N data hKr x ∈ w.toValuationSubring := by
+  let := frobImageAlgebra K N data hKr
+  let := frobImageTower K N data hKr
+  let := frobImageIsIntegral K N data hKr
+  rw [show frobOnPlacesGeomLevel K N data hKr w
+      = (Place.congrEquiv (frobeniusGeomLevelEquiv K N (ℓ := ℓ)).toRingEquiv
+          (fun a => (frobeniusGeomLevelEquiv K N (ℓ := ℓ)).commutes a)).symm
+          (w.restrict (frobeniusGeomLevelImage K N (ℓ := ℓ))) from rfl,
+    Place.congrEquiv_symm_apply, Place.congrRingEquiv_toValuationSubring,
+    ValuationSubring.mem_comap, RingEquiv.symm_symm]
+  exact Iff.rfl
+
+theorem frobOnPlacesGeomLevel_injective :
+    Function.Injective (frobOnPlacesGeomLevel K N data hKr) := by
+  intro w w' h
+  ext1
+  refine SetLike.ext fun x => ?_
+  obtain ⟨y, hy⟩ := exists_frobeniusGeomLevel_eq_pow K N data hKr x
+  rw [mem_valuationSubring_iff_pow_mem (ℓ := ℓ) w.toValuationSubring x, ← hy,
+    ← mem_frobOnPlacesGeomLevel_iff K N data hKr w y, h,
+    mem_frobOnPlacesGeomLevel_iff K N data hKr w' y, hy,
+    ← mem_valuationSubring_iff_pow_mem (ℓ := ℓ) w'.toValuationSubring x]
+
+include data hKr in
+open Classical in
+def verOnPlacesGeomLevel (u : Place K (modularFunctionFieldC K N)) :
+    Place K (modularFunctionFieldC K N) :=
+  if h : ∃ w, frobOnPlacesGeomLevel K N data hKr w = u then h.choose else u
+
+theorem verOnPlacesGeomLevel_frobOnPlacesGeomLevel
+    (w : Place K (modularFunctionFieldC K N)) :
+    verOnPlacesGeomLevel K N data hKr (frobOnPlacesGeomLevel K N data hKr w) = w := by
+  rw [verOnPlacesGeomLevel, dite_eq_left ⟨w, rfl⟩]
+  exact frobOnPlacesGeomLevel_injective K N data hKr
+    (Exists.choose_spec (⟨w, rfl⟩ : ∃ w', frobOnPlacesGeomLevel K N data hKr w'
+      = frobOnPlacesGeomLevel K N data hKr w))
+
+end PlaceLevel
+
+section DivisorLevel
+
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+variable (data : ModularPolynomialData ℓ) (hKr : KroneckerCongruence ℓ data)
+
+include data hKr in
+def frobeniusPushforwardGeomLevel :
+    Divisor K (modularFunctionFieldC K N) →+ Divisor K (modularFunctionFieldC K N) :=
+  Finsupp.mapDomain.addMonoidHom (frobOnPlacesGeomLevel K N data hKr)
+
+include data hKr in
+def frobeniusPullbackGeomLevel :
+    Divisor K (modularFunctionFieldC K N) →+ Divisor K (modularFunctionFieldC K N) :=
+  Finsupp.liftAddHom fun v =>
+    (Finsupp.singleAddHom (verOnPlacesGeomLevel K N data hKr v)).comp
+      (AddMonoidHom.mulRight (ℓ : ℤ))
+
+include data hKr in
+def heckeFibreGeomLevel :
+    Divisor K (modularFunctionFieldC K N) →+ Divisor K (modularFunctionFieldC K N) :=
+  frobeniusPushforwardGeomLevel K N data hKr + frobeniusPullbackGeomLevel K N data hKr
+
+@[simp]
+theorem frobeniusPushforwardGeomLevel_single (w : Place K (modularFunctionFieldC K N))
+    (n : ℤ) :
+    frobeniusPushforwardGeomLevel K N data hKr (Finsupp.single w n)
+      = Finsupp.single (frobOnPlacesGeomLevel K N data hKr w) n := by
+  simp [frobeniusPushforwardGeomLevel, Finsupp.mapDomain.addMonoidHom_apply,
+    Finsupp.mapDomain_single]
+
+@[simp]
+theorem frobeniusPullbackGeomLevel_single (w : Place K (modularFunctionFieldC K N))
+    (n : ℤ) :
+    frobeniusPullbackGeomLevel K N data hKr (Finsupp.single w n)
+      = Finsupp.single (verOnPlacesGeomLevel K N data hKr w) (n * ℓ) := by
+  simp [frobeniusPullbackGeomLevel]
+
+theorem frobeniusPullbackGeomLevel_frobeniusPushforwardGeomLevel
+    (D : Divisor K (modularFunctionFieldC K N)) :
+    frobeniusPullbackGeomLevel K N data hKr
+        (frobeniusPushforwardGeomLevel K N data hKr D) = (ℓ : ℤ) • D := by
+  induction D using Finsupp.induction with
+  | zero => simp
+  | single_add v n D _ _ ih =>
+    rw [map_add, map_add, ih, frobeniusPushforwardGeomLevel_single,
+      frobeniusPullbackGeomLevel_single, verOnPlacesGeomLevel_frobOnPlacesGeomLevel,
+      smul_add, Finsupp.smul_single, smul_eq_mul, mul_comm]
+
+theorem eichlerShimura_special_fibre_geom_level
+    (D : Divisor K (modularFunctionFieldC K N)) :
+    frobeniusPushforwardGeomLevel K N data hKr
+        (frobeniusPushforwardGeomLevel K N data hKr D)
+      - heckeFibreGeomLevel K N data hKr (frobeniusPushforwardGeomLevel K N data hKr D)
+      + (ℓ : ℤ) • D = 0 := by
+  rw [heckeFibreGeomLevel, AddMonoidHom.add_apply,
+    frobeniusPullbackGeomLevel_frobeniusPushforwardGeomLevel]
+  abel
+
+end DivisorLevel
+
+section Ramification
+
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+variable (data : ModularPolynomialData ℓ) (hKr : KroneckerCongruence ℓ data)
+
+theorem exists_ramification_frobenius (w : Place K (modularFunctionFieldC K N)) :
+    ∃ e : ℕ, 0 < e ∧ (e : ℤ) ∣ (ℓ : ℤ) ∧
+      ∀ g : modularFunctionFieldC K N,
+        w.ord (frobeniusGeomLevel K N data hKr g)
+          = e * (frobOnPlacesGeomLevel K N data hKr w).ord g := by
+  let := frobImageAlgebra K N data hKr
+  let := frobImageTower K N data hKr
+  let := frobImageIsIntegral K N data hKr
+  refine ⟨Place.ramificationIndex (F := frobeniusGeomLevelImage K N (ℓ := ℓ)) w,
+    Place.ramificationIndex_pos w, ?_, fun g => ?_⟩
+  · obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+    have hπ0 : (π : modularFunctionFieldC K N) ≠ 0 := by
+      simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+    obtain ⟨y, hy⟩ := exists_frobeniusGeomLevel_eq_pow K N data hKr
+      (π : modularFunctionFieldC K N)
+    have hy0 : (frobeniusGeomLevelEquiv K N (ℓ := ℓ)) y ≠ 0 := by
+      intro h0
+      have : y = 0 := by
+        have := congrArg (frobeniusGeomLevelEquiv K N (ℓ := ℓ)).symm h0
+        rwa [AlgEquiv.symm_apply_apply, map_zero] at this
+      rw [this, map_zero] at hy
+      exact pow_ne_zero ℓ hπ0 hy.symm
+    have hdvd := Place.ramificationIndex_dvd_ord
+      (F := frobeniusGeomLevelImage K N (ℓ := ℓ)) (w := w) hy0
+    rw [show (algebraMap (frobeniusGeomLevelImage K N (ℓ := ℓ))
+        (modularFunctionFieldC K N)) ((frobeniusGeomLevelEquiv K N (ℓ := ℓ)) y)
+        = frobeniusGeomLevel K N data hKr y from rfl, hy, ← zpow_natCast,
+      Place.ord_zpow, Place.ord_coe_irreducible w hπ, mul_one] at hdvd
+    exact hdvd
+  · rw [show frobeniusGeomLevel K N data hKr g
+        = algebraMap (frobeniusGeomLevelImage K N (ℓ := ℓ)) (modularFunctionFieldC K N)
+            ((frobeniusGeomLevelEquiv K N (ℓ := ℓ)).toRingEquiv g) from rfl,
+      Place.ord_restrict]
+    congr 1
+    have h2 := Place.ord_congrRingEquiv
+      (frobeniusGeomLevelEquiv K N (ℓ := ℓ)).toRingEquiv
+      (fun a => (frobeniusGeomLevelEquiv K N (ℓ := ℓ)).commutes a)
+      (frobOnPlacesGeomLevel K N data hKr w) g
+    rw [show Place.congrRingEquiv (frobeniusGeomLevelEquiv K N (ℓ := ℓ)).toRingEquiv
+        (fun a => (frobeniusGeomLevelEquiv K N (ℓ := ℓ)).commutes a)
+        (frobOnPlacesGeomLevel K N data hKr w)
+        = w.restrict (frobeniusGeomLevelImage K N (ℓ := ℓ)) from
+      Equiv.apply_symm_apply (Place.congrEquiv _ _) _] at h2
+    exact h2
+
+end Ramification
+
+section Package
+
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+variable (data : ModularPolynomialData ℓ) (hKr : KroneckerCongruence ℓ data)
+
+include data hKr in
+theorem exists_pow_eq_frobeniusGeomLevel (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c)
+    (y : modularFunctionFieldC K N) :
+    ∃ x : modularFunctionFieldC K N, frobeniusGeomLevel K N data hKr y = x ^ ℓ := by
+  have : CharP (LaurentSeries K) ℓ := charP_laurentSeries K
+  have key : ∀ z : LaurentSeries K, z ∈ modularFunctionFieldC K N →
+      ∃ w : LaurentSeries K, w ∈ modularFunctionFieldC K N ∧ qExpand K ℓ z = w ^ ℓ := by
+    intro z hz
+    induction hz using IntermediateField.adjoin_induction with
+    | mem y hy =>
+      rcases hy with rfl | rfl
+      · exact ⟨jqModC K, jqModC_mem K N, qExpand_jqModC_eq_pow K data hKr⟩
+      · exact ⟨jqNModC K N, jqNModC_mem K N, qExpand_jqNModC_eq_pow K N data hKr⟩
+    | algebraMap c =>
+      obtain ⟨d, hd⟩ := hperf c
+      refine ⟨algebraMap K (LaurentSeries K) d,
+        (modularFunctionFieldC K N).algebraMap_mem d, ?_⟩
+      rw [show qExpand K ℓ (algebraMap K (LaurentSeries K) c)
+            = qExpandAlgC K ℓ (algebraMap K (LaurentSeries K) c) from rfl,
+        (qExpandAlgC K ℓ).commutes c, ← map_pow, hd]
+    | add y z _ _ hy hz =>
+      obtain ⟨w₁, hw₁, he₁⟩ := hy
+      obtain ⟨w₂, hw₂, he₂⟩ := hz
+      refine ⟨w₁ + w₂, add_mem hw₁ hw₂, ?_⟩
+      rw [show qExpand K ℓ (y + z) = qExpandAlgC K ℓ (y + z) from rfl, map_add,
+        qExpandAlgC_apply, qExpandAlgC_apply, he₁, he₂, add_pow_char]
+    | inv y _ hy =>
+      obtain ⟨w, hw, he⟩ := hy
+      refine ⟨w⁻¹, inv_mem hw, ?_⟩
+      rw [show qExpand K ℓ y⁻¹ = qExpandAlgC K ℓ y⁻¹ from rfl, map_inv₀,
+        qExpandAlgC_apply, he, inv_pow]
+    | mul y z _ _ hy hz =>
+      obtain ⟨w₁, hw₁, he₁⟩ := hy
+      obtain ⟨w₂, hw₂, he₂⟩ := hz
+      refine ⟨w₁ * w₂, mul_mem hw₁ hw₂, ?_⟩
+      rw [show qExpand K ℓ (y * z) = qExpandAlgC K ℓ (y * z) from rfl, map_mul,
+        qExpandAlgC_apply, qExpandAlgC_apply, he₁, he₂, mul_pow]
+  obtain ⟨w, hw, he⟩ := key (y : LaurentSeries K) y.2
+  refine ⟨⟨w, hw⟩, Subtype.ext ?_⟩
+  rw [frobeniusGeomLevel_apply_coe]
+  push_cast
+  exact he
+
+include data hKr in
+theorem isFrobeniusEndo_frobeniusGeomLevel (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c) :
+    IsFrobeniusEndo ℓ (frobeniusGeomLevel K N data hKr) :=
+  ⟨exists_frobeniusGeomLevel_eq_pow K N data hKr,
+    exists_pow_eq_frobeniusGeomLevel K N data hKr hperf⟩
+
+include data hKr in
+theorem frobeniusGeomLevel_isIntegral (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c) :
+    (frobeniusGeomLevel K N data hKr).toRingHom.IsIntegral :=
+  (isFrobeniusEndo_frobeniusGeomLevel K N data hKr hperf).isIntegral
+    (Fact.out : ℓ.Prime).pos.ne'
+
+theorem frobeniusGeomLevel_eq_pow_unique {g g' f : modularFunctionFieldC K N}
+    (hg : frobeniusGeomLevel K N data hKr g = f ^ ℓ)
+    (hg' : frobeniusGeomLevel K N data hKr g' = f ^ ℓ) : g = g' :=
+  frobeniusGeomLevel_injective K N data hKr (hg.trans hg'.symm)
+
+end Package
+
+section Identification
+
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+variable (data : ModularPolynomialData ℓ) (hKr : KroneckerCongruence ℓ data)
+
+theorem mem_restrictAlong_iff {F : Type*} [Field F] [Algebra K F] (φ : F →ₐ[K] F)
+    (hφ : φ.toRingHom.IsIntegral) (w : Place K F) (x : F) :
+    x ∈ (w.restrictAlong φ hφ).toValuationSubring ↔ φ x ∈ w.toValuationSubring := by
+  rw [show (w.restrictAlong φ hφ).toValuationSubring
+      = w.toValuationSubring.comap φ.toRingHom from rfl, ValuationSubring.mem_comap]
+  exact Iff.rfl
+
+include data hKr in
+theorem restrictAlong_frobeniusGeomLevel_eq (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c)
+    (w : Place K (modularFunctionFieldC K N)) :
+    w.restrictAlong (frobeniusGeomLevel K N data hKr)
+        (frobeniusGeomLevel_isIntegral K N data hKr hperf)
+      = frobOnPlacesGeomLevel K N data hKr w := by
+  refine Place.ext (SetLike.ext fun x => ?_)
+  rw [mem_restrictAlong_iff, mem_frobOnPlacesGeomLevel_iff]
+
+end Identification
+
+section Ramification
+
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+variable (data : ModularPolynomialData ℓ) (hKr : KroneckerCongruence ℓ data)
+
+include data hKr in
+theorem ramificationIndexAlong_frobeniusGeomLevel (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c)
+    (w : Place K (modularFunctionFieldC K N)) :
+    Place.ramificationIndexAlong (frobeniusGeomLevel K N data hKr) w = ℓ :=
+  (isFrobeniusEndo_frobeniusGeomLevel K N data hKr hperf).ramificationIndexAlong_eq
+    (Fact.out : ℓ.Prime).pos.ne' w
+
+include data hKr in
+theorem ord_frobeniusGeomLevel_eq_mul (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c)
+    (w : Place K (modularFunctionFieldC K N)) (g : modularFunctionFieldC K N) :
+    w.ord (frobeniusGeomLevel K N data hKr g)
+      = ℓ * (frobOnPlacesGeomLevel K N data hKr w).ord g := by
+  have h := w.ord_restrictAlong (frobeniusGeomLevel K N data hKr)
+    (frobeniusGeomLevel_isIntegral K N data hKr hperf) g
+  rwa [ramificationIndexAlong_frobeniusGeomLevel K N data hKr hperf,
+    restrictAlong_frobeniusGeomLevel_eq K N data hKr hperf] at h
+
+include data hKr in
+theorem ord_frobOnPlaces_of_pow_eq (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c)
+    {f g : modularFunctionFieldC K N}
+    (hg : frobeniusGeomLevel K N data hKr g = f ^ ℓ)
+    (w : Place K (modularFunctionFieldC K N)) :
+    (frobOnPlacesGeomLevel K N data hKr w).ord g = w.ord f := by
+  have hkey : (ℓ : ℤ) * (frobOnPlacesGeomLevel K N data hKr w).ord g
+      = (ℓ : ℤ) * w.ord f := by
+    rw [← ord_frobeniusGeomLevel_eq_mul K N data hKr hperf w g, hg, ← zpow_natCast,
+      Place.ord_zpow]
+  exact mul_left_cancel₀ (Int.natCast_ne_zero.mpr (Fact.out : ℓ.Prime).pos.ne') hkey
+
+end Ramification
+
+section NormFormula
+
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+variable (data : ModularPolynomialData ℓ) (hKr : KroneckerCongruence ℓ data)
+
+include data hKr in
+theorem frobeniusPushforwardGeomLevel_apply_frob
+    (D : Divisor K (modularFunctionFieldC K N))
+    (w : Place K (modularFunctionFieldC K N)) :
+    frobeniusPushforwardGeomLevel K N data hKr D (frobOnPlacesGeomLevel K N data hKr w)
+      = D w := by
+  rw [show frobeniusPushforwardGeomLevel K N data hKr D
+      = Finsupp.mapDomain (frobOnPlacesGeomLevel K N data hKr) D from rfl]
+  exact Finsupp.mapDomain_apply_of_injective
+    (frobOnPlacesGeomLevel_injective K N data hKr) D w
+
+include data hKr in
+theorem frobeniusPushforwardGeomLevel_apply_of_notMem_range
+    (D : Divisor K (modularFunctionFieldC K N))
+    {v : Place K (modularFunctionFieldC K N)}
+    (hv : v ∉ Set.range (frobOnPlacesGeomLevel K N data hKr)) :
+    frobeniusPushforwardGeomLevel K N data hKr D v = 0 := by
+  rw [show frobeniusPushforwardGeomLevel K N data hKr D
+      = Finsupp.mapDomain (frobOnPlacesGeomLevel K N data hKr) D from rfl]
+  exact Finsupp.mapDomain_of_notMem_range D v hv
+
+include data hKr in
+theorem frobeniusPushforwardGeomLevel_normFormula_apply_frob
+    (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c)
+    {f g : modularFunctionFieldC K N}
+    (hg : frobeniusGeomLevel K N data hKr g = f ^ ℓ)
+    {D : Divisor K (modularFunctionFieldC K N)}
+    (hD : ∀ w, D w = w.ord f) (w : Place K (modularFunctionFieldC K N)) :
+    frobeniusPushforwardGeomLevel K N data hKr D (frobOnPlacesGeomLevel K N data hKr w)
+      = (frobOnPlacesGeomLevel K N data hKr w).ord g := by
+  rw [frobeniusPushforwardGeomLevel_apply_frob K N data hKr D w, hD w,
+    ord_frobOnPlaces_of_pow_eq K N data hKr hperf hg w]
+
+include data hKr in
+theorem frobeniusPushforwardGeomLevel_normFormula
+    (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c)
+    (hsurj : Function.Surjective (frobOnPlacesGeomLevel K N data hKr))
+    {f g : modularFunctionFieldC K N}
+    (hg : frobeniusGeomLevel K N data hKr g = f ^ ℓ)
+    {D : Divisor K (modularFunctionFieldC K N)}
+    (hD : ∀ w, D w = w.ord f) (v : Place K (modularFunctionFieldC K N)) :
+    frobeniusPushforwardGeomLevel K N data hKr D v = v.ord g := by
+  obtain ⟨w, rfl⟩ := hsurj v
+  exact frobeniusPushforwardGeomLevel_normFormula_apply_frob
+    K N data hKr hperf hg hD w
+
+include data hKr in
+theorem isPrincipal_frobeniusPushforwardGeomLevel
+    (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c)
+    (hsurj : Function.Surjective (frobOnPlacesGeomLevel K N data hKr))
+    {D : Divisor K (modularFunctionFieldC K N)} (hD : D.IsPrincipal) :
+    (frobeniusPushforwardGeomLevel K N data hKr D).IsPrincipal := by
+  obtain ⟨f, hf, hDf⟩ := hD
+  obtain ⟨g, hg⟩ := exists_frobeniusGeomLevel_eq_pow K N data hKr f
+  refine ⟨g, ?_, fun v => frobeniusPushforwardGeomLevel_normFormula
+    K N data hKr hperf hsurj hg hDf v⟩
+  intro hg0
+  rw [hg0, map_zero] at hg
+  exact pow_ne_zero ℓ hf hg.symm
+
+end NormFormula
+
+end ModularCurve
+
+namespace AlgebraicCurve
+
+section FrobNormHom
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {ℓ : ℕ} {φ : F →ₐ[K] F}
+
+namespace IsFrobeniusEndo
+
+theorem frobNorm_eq_of_map_eq_pow (h : IsFrobeniusEndo ℓ φ) {f g : F}
+    (hg : φ g = f ^ ℓ) : h.frobNorm f = g :=
+  φ.toRingHom.injective ((h.map_frobNorm f).trans hg.symm)
+
+theorem frobNorm_map (h : IsFrobeniusEndo ℓ φ) (x : F) : h.frobNorm (φ x) = x ^ ℓ :=
+  h.frobNorm_eq_of_map_eq_pow (by rw [map_pow])
+
+theorem frobNorm_one (h : IsFrobeniusEndo ℓ φ) : h.frobNorm 1 = 1 :=
+  h.frobNorm_eq_of_map_eq_pow (by rw [map_one, one_pow])
+
+theorem frobNorm_mul (h : IsFrobeniusEndo ℓ φ) (a b : F) :
+    h.frobNorm (a * b) = h.frobNorm a * h.frobNorm b :=
+  h.frobNorm_eq_of_map_eq_pow (by rw [map_mul, h.map_frobNorm, h.map_frobNorm, mul_pow])
+
+theorem frobNorm_algebraMap (h : IsFrobeniusEndo ℓ φ) (c : K) :
+    h.frobNorm (algebraMap K F c) = algebraMap K F c ^ ℓ :=
+  h.frobNorm_eq_of_map_eq_pow (by rw [map_pow, φ.commutes])
+
+variable [Fact ℓ.Prime] [CharP F ℓ]
+
+omit [CharP F ℓ] in
+theorem frobNorm_zero (h : IsFrobeniusEndo ℓ φ) : h.frobNorm 0 = 0 :=
+  h.frobNorm_eq_of_map_eq_pow
+    (by rw [map_zero, zero_pow (Fact.out : ℓ.Prime).pos.ne'])
+
+theorem frobNorm_add (h : IsFrobeniusEndo ℓ φ) (a b : F) :
+    h.frobNorm (a + b) = h.frobNorm a + h.frobNorm b :=
+  h.frobNorm_eq_of_map_eq_pow
+    (by rw [map_add, h.map_frobNorm, h.map_frobNorm, add_pow_char])
+
+def frobNormRingHom (h : IsFrobeniusEndo ℓ φ) : F →+* F where
+  toFun := h.frobNorm
+  map_one' := h.frobNorm_one
+  map_mul' := h.frobNorm_mul
+  map_zero' := h.frobNorm_zero
+  map_add' := h.frobNorm_add
+
+@[simp]
+theorem frobNormRingHom_apply (h : IsFrobeniusEndo ℓ φ) (f : F) :
+    h.frobNormRingHom f = h.frobNorm f := rfl
+
+theorem frobNormRingHom_isIntegral (h : IsFrobeniusEndo ℓ φ) :
+    h.frobNormRingHom.IsIntegral := by
+  intro x
+  refine ⟨Polynomial.X ^ ℓ - Polynomial.C (φ x),
+    Polynomial.monic_X_pow_sub_C _ (Fact.out : ℓ.Prime).pos.ne', ?_⟩
+  simp [Polynomial.eval₂_sub, frobNormRingHom_apply, h.frobNorm_map x]
+
+end IsFrobeniusEndo
+
+end FrobNormHom
+
+section ExtendPlace
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP F ℓ] {φ : F →ₐ[K] F}
+
+namespace IsFrobeniusEndo
+
+variable (h : IsFrobeniusEndo ℓ φ)
+
+def extendPlace (v : Place K F) : Place K F where
+  toValuationSubring := v.toValuationSubring.comap h.frobNormRingHom
+  algebraMap_mem' a := by
+    rw [ValuationSubring.mem_comap, frobNormRingHom_apply, h.frobNorm_algebraMap]
+    exact pow_mem (v.algebraMap_mem' a) ℓ
+  ne_top' := by
+    intro htop
+    apply v.ne_top'
+    refine SetLike.ext fun z => ⟨fun _ => ValuationSubring.mem_top z, fun _ => ?_⟩
+    have hz : φ z ∈ v.toValuationSubring.comap h.frobNormRingHom :=
+      htop ▸ ValuationSubring.mem_top (φ z)
+    rw [ValuationSubring.mem_comap, frobNormRingHom_apply, h.frobNorm_map] at hz
+    exact (v.toValuationSubring.pow_mem_iff (Fact.out : ℓ.Prime).pos.ne' z).mp hz
+  isPrincipalIdealRing' := by
+    let : Algebra F F := h.frobNormRingHom.toAlgebra
+    have : Algebra.IsIntegral F F := ⟨h.frobNormRingHom_isIntegral⟩
+    exact v.isPrincipalIdealRing_comap (F := F)
+
+theorem mem_extendPlace_iff (v : Place K F) (y : F) :
+    y ∈ (h.extendPlace v).toValuationSubring ↔ h.frobNorm y ∈ v.toValuationSubring :=
+  ValuationSubring.mem_comap
+
+theorem restrictAlong_extendPlace (hφ : φ.toRingHom.IsIntegral) (v : Place K F) :
+    (h.extendPlace v).restrictAlong φ hφ = v := by
+  refine Place.ext (SetLike.ext fun x => ?_)
+  rw [ModularCurve.mem_restrictAlong_iff (K := K) φ hφ (h.extendPlace v) x,
+    h.mem_extendPlace_iff, h.frobNorm_map]
+  exact v.toValuationSubring.pow_mem_iff (Fact.out : ℓ.Prime).pos.ne' x
+
+include h in
+theorem restrictAlong_surjective (hφ : φ.toRingHom.IsIntegral) :
+    Function.Surjective (Place.restrictAlong φ hφ) := fun v =>
+  ⟨h.extendPlace v, h.restrictAlong_extendPlace hφ v⟩
+
+theorem extendPlace_restrictAlong (hℓ : ℓ ≠ 0) (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F) :
+    h.extendPlace (w.restrictAlong φ hφ) = w :=
+  h.restrictAlong_injective hℓ hφ
+    (h.restrictAlong_extendPlace hφ (w.restrictAlong φ hφ))
+
+end IsFrobeniusEndo
+
+end ExtendPlace
+
+end AlgebraicCurve
+
+namespace ModularCurve
+
+section LevelN
+
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+variable (data : ModularPolynomialData ℓ) (hKr : KroneckerCongruence ℓ data)
+
+omit [Fact ℓ.Prime] in
+theorem charP_modularFunctionFieldC : CharP (modularFunctionFieldC K N) ℓ :=
+  charP_of_injective_algebraMap
+    (algebraMap K (modularFunctionFieldC K N)).injective ℓ
+
+include data hKr in
+def extendPlaceGeomLevel (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c)
+    (v : Place K (modularFunctionFieldC K N)) : Place K (modularFunctionFieldC K N) :=
+  haveI : CharP (modularFunctionFieldC K N) ℓ := charP_modularFunctionFieldC K N
+  (isFrobeniusEndo_frobeniusGeomLevel K N data hKr hperf).extendPlace v
+
+include data hKr in
+theorem frobOnPlacesGeomLevel_extendPlaceGeomLevel (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c)
+    (v : Place K (modularFunctionFieldC K N)) :
+    frobOnPlacesGeomLevel K N data hKr (extendPlaceGeomLevel K N data hKr hperf v) = v := by
+  have : CharP (modularFunctionFieldC K N) ℓ := charP_modularFunctionFieldC K N
+  rw [extendPlaceGeomLevel, ← restrictAlong_frobeniusGeomLevel_eq K N data hKr hperf]
+  exact (isFrobeniusEndo_frobeniusGeomLevel K N data hKr hperf).restrictAlong_extendPlace
+    (frobeniusGeomLevel_isIntegral K N data hKr hperf) v
+
+include data hKr in
+theorem frobOnPlacesGeomLevel_surjective (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c) :
+    Function.Surjective (frobOnPlacesGeomLevel K N data hKr) := fun v =>
+  ⟨extendPlaceGeomLevel K N data hKr hperf v,
+    frobOnPlacesGeomLevel_extendPlaceGeomLevel K N data hKr hperf v⟩
+
+include data hKr in
+theorem frobOnPlacesGeomLevel_bijective (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c) :
+    Function.Bijective (frobOnPlacesGeomLevel K N data hKr) :=
+  ⟨frobOnPlacesGeomLevel_injective K N data hKr,
+    frobOnPlacesGeomLevel_surjective K N data hKr hperf⟩
+
+include data hKr in
+theorem verOnPlacesGeomLevel_eq_extendPlaceGeomLevel (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c)
+    (u : Place K (modularFunctionFieldC K N)) :
+    verOnPlacesGeomLevel K N data hKr u = extendPlaceGeomLevel K N data hKr hperf u := by
+  have : CharP (modularFunctionFieldC K N) ℓ := charP_modularFunctionFieldC K N
+  obtain ⟨w, rfl⟩ := frobOnPlacesGeomLevel_surjective K N data hKr hperf u
+  rw [verOnPlacesGeomLevel_frobOnPlacesGeomLevel K N data hKr w, extendPlaceGeomLevel,
+    ← restrictAlong_frobeniusGeomLevel_eq K N data hKr hperf]
+  exact ((isFrobeniusEndo_frobeniusGeomLevel K N data hKr
+    hperf).extendPlace_restrictAlong (Fact.out : ℓ.Prime).pos.ne'
+    (frobeniusGeomLevel_isIntegral K N data hKr hperf) w).symm
+
+end LevelN
+
+section Consumers
+
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+variable (data : ModularPolynomialData ℓ) (hKr : KroneckerCongruence ℓ data)
+
+include data hKr in
+theorem frobeniusPushforwardGeomLevel_normFormula'
+    (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c)
+    {f g : modularFunctionFieldC K N}
+    (hg : frobeniusGeomLevel K N data hKr g = f ^ ℓ)
+    {D : Divisor K (modularFunctionFieldC K N)}
+    (hD : ∀ w, D w = w.ord f) (v : Place K (modularFunctionFieldC K N)) :
+    frobeniusPushforwardGeomLevel K N data hKr D v = v.ord g :=
+  frobeniusPushforwardGeomLevel_normFormula K N data hKr hperf
+    (frobOnPlacesGeomLevel_surjective K N data hKr hperf) hg hD v
+
+include data hKr in
+theorem isPrincipal_frobeniusPushforwardGeomLevel'
+    (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c)
+    {D : Divisor K (modularFunctionFieldC K N)} (hD : D.IsPrincipal) :
+    (frobeniusPushforwardGeomLevel K N data hKr D).IsPrincipal :=
+  isPrincipal_frobeniusPushforwardGeomLevel K N data hKr hperf
+    (frobOnPlacesGeomLevel_surjective K N data hKr hperf) hD
+
+end Consumers
+
+section PlaceLevel
+
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+variable (data : ModularPolynomialData ℓ) (hKr : KroneckerCongruence ℓ data)
+
+include data hKr in
+theorem frobOnPlacesGeomLevel_verOnPlacesGeomLevel
+    (hsurj : Function.Surjective (frobOnPlacesGeomLevel K N data hKr))
+    (v : Place K (modularFunctionFieldC K N)) :
+    frobOnPlacesGeomLevel K N data hKr (verOnPlacesGeomLevel K N data hKr v) = v := by
+  obtain ⟨u, rfl⟩ := hsurj v
+  rw [verOnPlacesGeomLevel_frobOnPlacesGeomLevel K N data hKr u]
+
+include data hKr in
+theorem verOnPlacesGeomLevel_eq_iff
+    (hsurj : Function.Surjective (frobOnPlacesGeomLevel K N data hKr))
+    {v w : Place K (modularFunctionFieldC K N)} :
+    verOnPlacesGeomLevel K N data hKr v = w ↔ v = frobOnPlacesGeomLevel K N data hKr w := by
+  constructor
+  · rintro rfl
+    rw [frobOnPlacesGeomLevel_verOnPlacesGeomLevel K N data hKr hsurj v]
+  · rintro rfl
+    rw [verOnPlacesGeomLevel_frobOnPlacesGeomLevel K N data hKr w]
+
+end PlaceLevel
+
+section Evaluation
+
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+variable (data : ModularPolynomialData ℓ) (hKr : KroneckerCongruence ℓ data)
+
+include data hKr in
+theorem frobeniusPullbackGeomLevel_apply
+    (hsurj : Function.Surjective (frobOnPlacesGeomLevel K N data hKr))
+    (D : Divisor K (modularFunctionFieldC K N))
+    (w : Place K (modularFunctionFieldC K N)) :
+    frobeniusPullbackGeomLevel K N data hKr D w
+      = D (frobOnPlacesGeomLevel K N data hKr w) * ℓ := by
+  induction D using Finsupp.induction with
+  | zero => simp
+  | single_add v n D _ _ ih =>
+    rw [map_add, Finsupp.add_apply, ih, frobeniusPullbackGeomLevel_single,
+      Finsupp.add_apply, add_mul]
+    congr 1
+    by_cases hvw : v = frobOnPlacesGeomLevel K N data hKr w
+    · subst hvw
+      rw [verOnPlacesGeomLevel_frobOnPlacesGeomLevel K N data hKr w,
+        Finsupp.single_eq_same, Finsupp.single_eq_same]
+    · have hne : verOnPlacesGeomLevel K N data hKr v ≠ w :=
+        fun h => hvw ((verOnPlacesGeomLevel_eq_iff K N data hKr hsurj).mp h)
+      rw [Finsupp.single_eq_of_ne' hne, Finsupp.single_eq_of_ne' hvw, zero_mul]
+
+end Evaluation
+
+section Principal
+
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+variable (data : ModularPolynomialData ℓ) (hKr : KroneckerCongruence ℓ data)
+
+include data hKr in
+theorem frobeniusPullbackGeomLevel_pullbackFormula
+    (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c)
+    (hsurj : Function.Surjective (frobOnPlacesGeomLevel K N data hKr))
+    {f : modularFunctionFieldC K N}
+    {D : Divisor K (modularFunctionFieldC K N)}
+    (hD : ∀ w, D w = w.ord f) (w : Place K (modularFunctionFieldC K N)) :
+    frobeniusPullbackGeomLevel K N data hKr D w
+      = w.ord (frobeniusGeomLevel K N data hKr f) := by
+  rw [frobeniusPullbackGeomLevel_apply K N data hKr hsurj D w,
+    hD (frobOnPlacesGeomLevel K N data hKr w),
+    ord_frobeniusGeomLevel_eq_mul K N data hKr hperf w f, mul_comm]
+
+include data hKr in
+theorem isPrincipal_frobeniusPullbackGeomLevel'
+    (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c)
+    (hsurj : Function.Surjective (frobOnPlacesGeomLevel K N data hKr))
+    {D : Divisor K (modularFunctionFieldC K N)} (hD : D.IsPrincipal) :
+    (frobeniusPullbackGeomLevel K N data hKr D).IsPrincipal := by
+  obtain ⟨f, hf, hDf⟩ := hD
+  refine ⟨frobeniusGeomLevel K N data hKr f, ?_,
+    fun w => frobeniusPullbackGeomLevel_pullbackFormula K N data hKr hperf hsurj hDf w⟩
+  intro h0
+  exact hf (frobeniusGeomLevel_injective K N data hKr (h0.trans (map_zero _).symm))
+
+include data hKr in
+theorem isPrincipal_heckeFibreGeomLevel'
+    (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c)
+    (hsurj : Function.Surjective (frobOnPlacesGeomLevel K N data hKr))
+    {D : Divisor K (modularFunctionFieldC K N)} (hD : D.IsPrincipal) :
+    (heckeFibreGeomLevel K N data hKr D).IsPrincipal := by
+  have hpush := isPrincipal_frobeniusPushforwardGeomLevel' K N data hKr hperf hD
+  have hpull := isPrincipal_frobeniusPullbackGeomLevel' K N data hKr hperf hsurj hD
+  obtain ⟨g, hg, hDg⟩ := hpush
+  obtain ⟨h, hh, hDh⟩ := hpull
+  refine ⟨g * h, mul_ne_zero hg hh, fun v => ?_⟩
+  have key : heckeFibreGeomLevel K N data hKr D
+      = frobeniusPushforwardGeomLevel K N data hKr D
+        + frobeniusPullbackGeomLevel K N data hKr D := rfl
+  rw [key, Finsupp.add_apply, hDg v, hDh v, v.ord_mul hg hh]
+
+end Principal
+
+section DegreePlace
+
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+variable (data : ModularPolynomialData ℓ) (hKr : KroneckerCongruence ℓ data)
+variable (hdeg1 : ∀ w : Place K (modularFunctionFieldC K N), w.deg = 1)
+
+include data hKr hdeg1 in
+theorem deg_frobOnPlacesGeomLevel (w : Place K (modularFunctionFieldC K N)) :
+    (frobOnPlacesGeomLevel K N data hKr w).deg = w.deg := by
+  rw [hdeg1 (frobOnPlacesGeomLevel K N data hKr w), hdeg1 w]
+
+include data hKr hdeg1 in
+theorem deg_verOnPlacesGeomLevel (w : Place K (modularFunctionFieldC K N)) :
+    (verOnPlacesGeomLevel K N data hKr w).deg = w.deg := by
+  rw [hdeg1 (verOnPlacesGeomLevel K N data hKr w), hdeg1 w]
+
+end DegreePlace
+
+section DegreeDivisor
+
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+variable (data : ModularPolynomialData ℓ) (hKr : KroneckerCongruence ℓ data)
+variable (hdeg1 : ∀ w : Place K (modularFunctionFieldC K N), w.deg = 1)
+
+include data hKr hdeg1 in
+theorem degree_frobeniusPushforwardGeomLevel (D : Divisor K (modularFunctionFieldC K N)) :
+    Divisor.degree (frobeniusPushforwardGeomLevel K N data hKr D) = Divisor.degree D := by
+  induction D using Finsupp.induction with
+  | zero => simp
+  | single_add v n D _ _ ih =>
+    rw [map_add, map_add, ih, frobeniusPushforwardGeomLevel_single, map_add,
+      Divisor.degree_single, Divisor.degree_single,
+      deg_frobOnPlacesGeomLevel K N data hKr hdeg1 v]
+
+include data hKr hdeg1 in
+theorem degree_frobeniusPullbackGeomLevel (D : Divisor K (modularFunctionFieldC K N)) :
+    Divisor.degree (frobeniusPullbackGeomLevel K N data hKr D) = ℓ * Divisor.degree D := by
+  induction D using Finsupp.induction with
+  | zero => simp
+  | single_add v n D _ _ ih =>
+    rw [map_add, map_add, ih, frobeniusPullbackGeomLevel_single, map_add,
+      Divisor.degree_single, Divisor.degree_single,
+      deg_verOnPlacesGeomLevel K N data hKr hdeg1 v, mul_add]
+    ring
+
+include data hKr hdeg1 in
+theorem degree_heckeFibreGeomLevel (D : Divisor K (modularFunctionFieldC K N)) :
+    Divisor.degree (heckeFibreGeomLevel K N data hKr D) = (ℓ + 1) * Divisor.degree D := by
+  rw [show heckeFibreGeomLevel K N data hKr D
+      = frobeniusPushforwardGeomLevel K N data hKr D
+        + frobeniusPullbackGeomLevel K N data hKr D from rfl,
+    map_add, degree_frobeniusPushforwardGeomLevel K N data hKr hdeg1 D,
+    degree_frobeniusPullbackGeomLevel K N data hKr hdeg1 D]
+  ring
+
+include data hKr hdeg1 in
+theorem frobeniusPushforwardGeomLevel_mem_degZero {D : Divisor K (modularFunctionFieldC K N)}
+    (hD : D ∈ Divisor.degZero (K := K) (F := modularFunctionFieldC K N)) :
+    frobeniusPushforwardGeomLevel K N data hKr D ∈
+      Divisor.degZero (K := K) (F := modularFunctionFieldC K N) := by
+  rw [Divisor.mem_degZero] at hD ⊢
+  rw [degree_frobeniusPushforwardGeomLevel K N data hKr hdeg1 D, hD]
+
+include data hKr hdeg1 in
+theorem frobeniusPullbackGeomLevel_mem_degZero {D : Divisor K (modularFunctionFieldC K N)}
+    (hD : D ∈ Divisor.degZero (K := K) (F := modularFunctionFieldC K N)) :
+    frobeniusPullbackGeomLevel K N data hKr D ∈
+      Divisor.degZero (K := K) (F := modularFunctionFieldC K N) := by
+  rw [Divisor.mem_degZero] at hD ⊢
+  rw [degree_frobeniusPullbackGeomLevel K N data hKr hdeg1 D, hD, mul_zero]
+
+include data hKr hdeg1 in
+theorem heckeFibreGeomLevel_mem_degZero {D : Divisor K (modularFunctionFieldC K N)}
+    (hD : D ∈ Divisor.degZero (K := K) (F := modularFunctionFieldC K N)) :
+    heckeFibreGeomLevel K N data hKr D ∈
+      Divisor.degZero (K := K) (F := modularFunctionFieldC K N) := by
+  rw [Divisor.mem_degZero] at hD ⊢
+  rw [degree_heckeFibreGeomLevel K N data hKr hdeg1 D, hD, mul_zero]
+
+include data hKr hdeg1 in
+def frobeniusPushforwardGeomLevelDegZero :
+    Divisor.degZero (K := K) (F := modularFunctionFieldC K N)
+      →+ Divisor.degZero (K := K) (F := modularFunctionFieldC K N) :=
+  ((frobeniusPushforwardGeomLevel K N data hKr).domRestrict
+    (Divisor.degZero (K := K) (F := modularFunctionFieldC K N))).codRestrict _
+    (fun D => frobeniusPushforwardGeomLevel_mem_degZero K N data hKr hdeg1 D.2)
+
+@[simp]
+theorem coe_frobeniusPushforwardGeomLevelDegZero
+    (D : Divisor.degZero (K := K) (F := modularFunctionFieldC K N)) :
+    (frobeniusPushforwardGeomLevelDegZero K N data hKr hdeg1 D
+        : Divisor K (modularFunctionFieldC K N))
+      = frobeniusPushforwardGeomLevel K N data hKr (D : Divisor K (modularFunctionFieldC K N)) :=
+  rfl
+
+include data hKr hdeg1 in
+def frobeniusPullbackGeomLevelDegZero :
+    Divisor.degZero (K := K) (F := modularFunctionFieldC K N)
+      →+ Divisor.degZero (K := K) (F := modularFunctionFieldC K N) :=
+  ((frobeniusPullbackGeomLevel K N data hKr).domRestrict
+    (Divisor.degZero (K := K) (F := modularFunctionFieldC K N))).codRestrict _
+    (fun D => frobeniusPullbackGeomLevel_mem_degZero K N data hKr hdeg1 D.2)
+
+@[simp]
+theorem coe_frobeniusPullbackGeomLevelDegZero
+    (D : Divisor.degZero (K := K) (F := modularFunctionFieldC K N)) :
+    (frobeniusPullbackGeomLevelDegZero K N data hKr hdeg1 D
+        : Divisor K (modularFunctionFieldC K N))
+      = frobeniusPullbackGeomLevel K N data hKr (D : Divisor K (modularFunctionFieldC K N)) :=
+  rfl
+
+include data hKr hdeg1 in
+def heckeFibreGeomLevelDegZero :
+    Divisor.degZero (K := K) (F := modularFunctionFieldC K N)
+      →+ Divisor.degZero (K := K) (F := modularFunctionFieldC K N) :=
+  ((heckeFibreGeomLevel K N data hKr).domRestrict
+    (Divisor.degZero (K := K) (F := modularFunctionFieldC K N))).codRestrict _
+    (fun D => heckeFibreGeomLevel_mem_degZero K N data hKr hdeg1 D.2)
+
+@[simp]
+theorem coe_heckeFibreGeomLevelDegZero
+    (D : Divisor.degZero (K := K) (F := modularFunctionFieldC K N)) :
+    (heckeFibreGeomLevelDegZero K N data hKr hdeg1 D
+        : Divisor K (modularFunctionFieldC K N))
+      = heckeFibreGeomLevel K N data hKr (D : Divisor K (modularFunctionFieldC K N)) :=
+  rfl
+
+include data hKr hdeg1 in
+theorem heckeFibreGeomLevelDegZero_eq_add
+    (D : Divisor.degZero (K := K) (F := modularFunctionFieldC K N)) :
+    heckeFibreGeomLevelDegZero K N data hKr hdeg1 D
+      = frobeniusPushforwardGeomLevelDegZero K N data hKr hdeg1 D
+        + frobeniusPullbackGeomLevelDegZero K N data hKr hdeg1 D :=
+  Subtype.ext rfl
+
+end DegreeDivisor
+
+section Pic0Ops
+
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+variable (data : ModularPolynomialData ℓ) (hKr : KroneckerCongruence ℓ data)
+variable (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c)
+variable (hdeg1 : ∀ w : Place K (modularFunctionFieldC K N), w.deg = 1)
+
+include data hKr hperf hdeg1 in
+def frobeniusPushforwardGeomLevelPic0 :
+    Pic0 K (modularFunctionFieldC K N) →+ Pic0 K (modularFunctionFieldC K N) :=
+  QuotientAddGroup.map _ _ (frobeniusPushforwardGeomLevelDegZero K N data hKr hdeg1) (by
+    rintro ⟨D, hD0⟩ hD
+    simp only [AddSubgroup.mem_addSubgroupOf] at hD ⊢
+    exact isPrincipal_frobeniusPushforwardGeomLevel' K N data hKr hperf hD)
+
+@[simp]
+theorem frobeniusPushforwardGeomLevelPic0_mk
+    (D : Divisor.degZero (K := K) (F := modularFunctionFieldC K N)) :
+    frobeniusPushforwardGeomLevelPic0 K N data hKr hperf hdeg1 (Pic0.mk D)
+      = Pic0.mk (frobeniusPushforwardGeomLevelDegZero K N data hKr hdeg1 D) :=
+  rfl
+
+include data hKr hperf hdeg1 in
+def frobeniusPullbackGeomLevelPic0 :
+    Pic0 K (modularFunctionFieldC K N) →+ Pic0 K (modularFunctionFieldC K N) :=
+  QuotientAddGroup.map _ _ (frobeniusPullbackGeomLevelDegZero K N data hKr hdeg1) (by
+    rintro ⟨D, hD0⟩ hD
+    simp only [AddSubgroup.mem_addSubgroupOf] at hD ⊢
+    exact isPrincipal_frobeniusPullbackGeomLevel' K N data hKr hperf
+      (frobOnPlacesGeomLevel_surjective K N data hKr hperf) hD)
+
+@[simp]
+theorem frobeniusPullbackGeomLevelPic0_mk
+    (D : Divisor.degZero (K := K) (F := modularFunctionFieldC K N)) :
+    frobeniusPullbackGeomLevelPic0 K N data hKr hperf hdeg1 (Pic0.mk D)
+      = Pic0.mk (frobeniusPullbackGeomLevelDegZero K N data hKr hdeg1 D) :=
+  rfl
+
+include data hKr hperf hdeg1 in
+def heckeFibreGeomLevelPic0 :
+    Pic0 K (modularFunctionFieldC K N) →+ Pic0 K (modularFunctionFieldC K N) :=
+  QuotientAddGroup.map _ _ (heckeFibreGeomLevelDegZero K N data hKr hdeg1) (by
+    rintro ⟨D, hD0⟩ hD
+    simp only [AddSubgroup.mem_addSubgroupOf] at hD ⊢
+    exact isPrincipal_heckeFibreGeomLevel' K N data hKr hperf
+      (frobOnPlacesGeomLevel_surjective K N data hKr hperf) hD)
+
+@[simp]
+theorem heckeFibreGeomLevelPic0_mk
+    (D : Divisor.degZero (K := K) (F := modularFunctionFieldC K N)) :
+    heckeFibreGeomLevelPic0 K N data hKr hperf hdeg1 (Pic0.mk D)
+      = Pic0.mk (heckeFibreGeomLevelDegZero K N data hKr hdeg1 D) :=
+  rfl
+
+include data hKr hperf hdeg1 in
+theorem heckeFibreGeomLevelPic0_eq_add (x : Pic0 K (modularFunctionFieldC K N)) :
+    heckeFibreGeomLevelPic0 K N data hKr hperf hdeg1 x
+      = frobeniusPushforwardGeomLevelPic0 K N data hKr hperf hdeg1 x
+        + frobeniusPullbackGeomLevelPic0 K N data hKr hperf hdeg1 x := by
+  obtain ⟨D, rfl⟩ := Pic0.mk_surjective x
+  rw [heckeFibreGeomLevelPic0_mk, frobeniusPushforwardGeomLevelPic0_mk,
+    frobeniusPullbackGeomLevelPic0_mk, ← Pic0.mk_add,
+    heckeFibreGeomLevelDegZero_eq_add K N data hKr hdeg1 D]
+
+include data hKr hperf hdeg1 in
+theorem frobeniusPullbackGeomLevelPic0_frobeniusPushforwardGeomLevelPic0
+    (x : Pic0 K (modularFunctionFieldC K N)) :
+    frobeniusPullbackGeomLevelPic0 K N data hKr hperf hdeg1
+        (frobeniusPushforwardGeomLevelPic0 K N data hKr hperf hdeg1 x)
+      = (ℓ : ℤ) • x := by
+  obtain ⟨D, rfl⟩ := Pic0.mk_surjective x
+  rw [frobeniusPushforwardGeomLevelPic0_mk, frobeniusPullbackGeomLevelPic0_mk,
+    show ((ℓ : ℤ) • Pic0.mk D : Pic0 K (modularFunctionFieldC K N))
+      = Pic0.mk ((ℓ : ℤ) • D) from rfl]
+  refine congrArg Pic0.mk (Subtype.ext ?_)
+  exact frobeniusPullbackGeomLevel_frobeniusPushforwardGeomLevel K N data hKr
+    (D : Divisor K (modularFunctionFieldC K N))
+
+end Pic0Ops
+
+section Relation
+
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+variable (data : ModularPolynomialData ℓ) (hKr : KroneckerCongruence ℓ data)
+variable (hperf : ∀ c : K, ∃ d : K, d ^ ℓ = c)
+variable (hdeg1 : ∀ w : Place K (modularFunctionFieldC K N), w.deg = 1)
+
+include data hKr hperf hdeg1 in
+theorem eichlerShimura_special_fibre_pic0_level (x : Pic0 K (modularFunctionFieldC K N)) :
+    frobeniusPushforwardGeomLevelPic0 K N data hKr hperf hdeg1
+        (frobeniusPushforwardGeomLevelPic0 K N data hKr hperf hdeg1 x)
+      - heckeFibreGeomLevelPic0 K N data hKr hperf hdeg1
+          (frobeniusPushforwardGeomLevelPic0 K N data hKr hperf hdeg1 x)
+      + (ℓ : ℤ) • x = 0 := by
+  obtain ⟨D, rfl⟩ := Pic0.mk_surjective x
+  rw [frobeniusPushforwardGeomLevelPic0_mk, frobeniusPushforwardGeomLevelPic0_mk,
+    heckeFibreGeomLevelPic0_mk,
+    show ((ℓ : ℤ) • Pic0.mk D : Pic0 K (modularFunctionFieldC K N))
+      = Pic0.mk ((ℓ : ℤ) • D) from rfl,
+    show (Pic0.mk _ - Pic0.mk _ + Pic0.mk ((ℓ : ℤ) • D) : Pic0 K (modularFunctionFieldC K N))
+      = Pic0.mk (frobeniusPushforwardGeomLevelDegZero K N data hKr hdeg1
+          (frobeniusPushforwardGeomLevelDegZero K N data hKr hdeg1 D)
+        - heckeFibreGeomLevelDegZero K N data hKr hdeg1
+            (frobeniusPushforwardGeomLevelDegZero K N data hKr hdeg1 D)
+        + (ℓ : ℤ) • D) from rfl]
+  refine congrArg Pic0.mk (Subtype.ext ?_)
+  push_cast
+  exact eichlerShimura_special_fibre_geom_level K N data hKr
+    (D : Divisor K (modularFunctionFieldC K N))
+
+end Relation
+
+section
+
+variable (K : Type*) [Field K]
+
+theorem perfect_of_isAlgClosed [IsAlgClosed K] {ℓ : ℕ} [hℓ : Fact ℓ.Prime] :
+    ∀ c : K, ∃ d : K, d ^ ℓ = c :=
+  fun c => IsAlgClosed.exists_pow_nat_eq c hℓ.out.pos
+
+variable (N : ℕ) [NeZero N]
+variable [IsAlgClosed K] [IsCurveOver K (modularFunctionFieldC K N)]
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+variable (data : ModularPolynomialData ℓ) (hKr : KroneckerCongruence ℓ data)
+
+def frobeniusPushforwardGeomLevelPic0OfIsCurveOver :
+    Pic0 K (modularFunctionFieldC K N) →+ Pic0 K (modularFunctionFieldC K N) :=
+  frobeniusPushforwardGeomLevelPic0 K N data hKr (perfect_of_isAlgClosed K)
+    (deg_eq_one_modularFunctionFieldC K N)
+
+def frobeniusPullbackGeomLevelPic0OfIsCurveOver :
+    Pic0 K (modularFunctionFieldC K N) →+ Pic0 K (modularFunctionFieldC K N) :=
+  frobeniusPullbackGeomLevelPic0 K N data hKr (perfect_of_isAlgClosed K)
+    (deg_eq_one_modularFunctionFieldC K N)
+
+def heckeFibreGeomLevelPic0OfIsCurveOver :
+    Pic0 K (modularFunctionFieldC K N) →+ Pic0 K (modularFunctionFieldC K N) :=
+  heckeFibreGeomLevelPic0 K N data hKr (perfect_of_isAlgClosed K)
+    (deg_eq_one_modularFunctionFieldC K N)
+
+theorem frobeniusPushforwardGeomLevelPic0OfIsCurveOver_eq :
+    frobeniusPushforwardGeomLevelPic0OfIsCurveOver K N data hKr
+      = frobeniusPushforwardGeomLevelPic0 K N data hKr (perfect_of_isAlgClosed K)
+          (deg_eq_one_modularFunctionFieldC K N) :=
+  rfl
+
+theorem heckeFibreGeomLevelPic0OfIsCurveOver_eq :
+    heckeFibreGeomLevelPic0OfIsCurveOver K N data hKr
+      = heckeFibreGeomLevelPic0 K N data hKr (perfect_of_isAlgClosed K)
+          (deg_eq_one_modularFunctionFieldC K N) :=
+  rfl
+
+@[simp]
+theorem frobeniusPushforwardGeomLevelPic0OfIsCurveOver_mk
+    (D : Divisor.degZero (K := K) (F := modularFunctionFieldC K N)) :
+    frobeniusPushforwardGeomLevelPic0OfIsCurveOver K N data hKr (Pic0.mk D)
+      = Pic0.mk (frobeniusPushforwardGeomLevelDegZero K N data hKr
+          (deg_eq_one_modularFunctionFieldC K N) D) :=
+  rfl
+
+@[simp]
+theorem frobeniusPullbackGeomLevelPic0OfIsCurveOver_mk
+    (D : Divisor.degZero (K := K) (F := modularFunctionFieldC K N)) :
+    frobeniusPullbackGeomLevelPic0OfIsCurveOver K N data hKr (Pic0.mk D)
+      = Pic0.mk (frobeniusPullbackGeomLevelDegZero K N data hKr
+          (deg_eq_one_modularFunctionFieldC K N) D) :=
+  rfl
+
+@[simp]
+theorem heckeFibreGeomLevelPic0OfIsCurveOver_mk
+    (D : Divisor.degZero (K := K) (F := modularFunctionFieldC K N)) :
+    heckeFibreGeomLevelPic0OfIsCurveOver K N data hKr (Pic0.mk D)
+      = Pic0.mk (heckeFibreGeomLevelDegZero K N data hKr
+          (deg_eq_one_modularFunctionFieldC K N) D) :=
+  rfl
+
+theorem heckeFibreGeomLevelPic0OfIsCurveOver_eq_add
+    (x : Pic0 K (modularFunctionFieldC K N)) :
+    heckeFibreGeomLevelPic0OfIsCurveOver K N data hKr x
+      = frobeniusPushforwardGeomLevelPic0OfIsCurveOver K N data hKr x
+        + frobeniusPullbackGeomLevelPic0OfIsCurveOver K N data hKr x :=
+  heckeFibreGeomLevelPic0_eq_add K N data hKr (perfect_of_isAlgClosed K)
+    (deg_eq_one_modularFunctionFieldC K N) x
+
+theorem frobeniusPullbackPushforwardGeomLevelPic0OfIsCurveOver
+    (x : Pic0 K (modularFunctionFieldC K N)) :
+    frobeniusPullbackGeomLevelPic0OfIsCurveOver K N data hKr
+        (frobeniusPushforwardGeomLevelPic0OfIsCurveOver K N data hKr x)
+      = (ℓ : ℤ) • x :=
+  frobeniusPullbackGeomLevelPic0_frobeniusPushforwardGeomLevelPic0 K N data hKr
+    (perfect_of_isAlgClosed K) (deg_eq_one_modularFunctionFieldC K N) x
+
+theorem eichlerShimura_special_fibre_pic0_level_of_isCurveOver
+    (x : Pic0 K (modularFunctionFieldC K N)) :
+    frobeniusPushforwardGeomLevelPic0OfIsCurveOver K N data hKr
+        (frobeniusPushforwardGeomLevelPic0OfIsCurveOver K N data hKr x)
+      - heckeFibreGeomLevelPic0OfIsCurveOver K N data hKr
+          (frobeniusPushforwardGeomLevelPic0OfIsCurveOver K N data hKr x)
+      + (ℓ : ℤ) • x = 0 :=
+  eichlerShimura_special_fibre_pic0_level K N data hKr (perfect_of_isAlgClosed K)
+    (deg_eq_one_modularFunctionFieldC K N) x
+
+end
+
+section FamilyProps
+
+variable (K : Type*) [Field K]
+
+def IsCurveOverModularFunctionFieldCFamily : Prop :=
+  ∀ (N : ℕ), [NeZero N] → IsCurveOver K (modularFunctionFieldC K N)
+
+theorem isCurveOverModularFunctionFieldCFamily_iff :
+    IsCurveOverModularFunctionFieldCFamily K
+      ↔ ∀ (N : ℕ), [NeZero N] → IsCurveOver K (modularFunctionFieldC K N) :=
+  Iff.rfl
+
+theorem isCurveOver_modularFunctionFieldC_of_family
+    (hfam : IsCurveOverModularFunctionFieldCFamily K) (N : ℕ) [NeZero N] :
+    IsCurveOver K (modularFunctionFieldC K N) :=
+  hfam N
+
+variable (N : ℕ) [NeZero N]
+variable [IsAlgClosed K] [IsCurveOver K (modularFunctionFieldC K N)]
+variable {ℓ : ℕ} [hℓ : Fact ℓ.Prime] [CharP K ℓ]
+variable (data : ModularPolynomialData ℓ) (hKr : KroneckerCongruence ℓ data)
+
+def SpecialFibreHeckeModuleMatch
+    (inst : Module HeckeAlg (Pic0 K (modularFunctionFieldC K N))) : Prop :=
+  ∀ x : Pic0 K (modularFunctionFieldC K N),
+    letI := inst
+    heckeGen ⟨ℓ, hℓ.out⟩ • x = heckeFibreGeomLevelPic0OfIsCurveOver K N data hKr x
+
+theorem specialFibreHeckeModuleMatch_iff
+    (inst : Module HeckeAlg (Pic0 K (modularFunctionFieldC K N))) :
+    SpecialFibreHeckeModuleMatch K N data hKr inst
+      ↔ ∀ x, (letI := inst; heckeGen ⟨ℓ, hℓ.out⟩ • x)
+          = heckeFibreGeomLevelPic0OfIsCurveOver K N data hKr x :=
+  Iff.rfl
+
+end FamilyProps
+
+end ModularCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_ComplexPlaceDictionary.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_ComplexPlaceDictionary.lean
new file mode 100644
index 0000000000..a3fe64c96a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_ComplexPlaceDictionary.lean
@@ -0,0 +1,102 @@
+/-
+Based on Prove2Me node ModularCurve_ComplexPlaceDictionary
+(09c1a343-c5e2-5fe0-aaa6-9fe2c01d6658) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import Mathlib.Analysis.Meromorphic.Order
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+/-!
+# Realising Laurent series on ℍ; complex place dictionary
+
+Definition: `ModularCurve_ComplexPlaceDictionary` (`09c1a343-c5e2-5fe0-aaa6-9fe2c01d6658`), by
+Claude, 2026-09-05.
+
+Fix $N$ and work with the function field model $\mathbb{C}F_N :=$ `laurentBaseChange ℂ
+(modularFunctionFieldFull N)`, the subfield of $\mathbb{C}((q))$ generated over $\mathbb{C}$ by the
+coefficientwise images of the Laurent series $j(q^d)$, $d \mid N$ (the $j$-expansion being built
+from $E_4^3$ and the $24$th power of the eta product).
+
+First, `realize N x τ` attaches a complex number to a Laurent series $x \in \mathbb{C}((q))$ and a
+point $\tau \in \mathfrak{H}$: if there is a triple consisting of a weight $k \in \mathbb{Z}$ and
+two modular forms $g, h$ of weight $k$ on $\mathrm{Gamma0}\ N$ with $h(\tau) \ne 0$ and $x \cdot
+\tilde h = \tilde g$ as Laurent series, where $\tilde{\,\cdot\,}$ denotes the width-one
+$q$-expansion, the value is $g(\tau)/h(\tau)$ for one such triple picked by choice; otherwise the
+value is $0$. Independence of the chosen triple is not part of the definition, and $0$ serves as the
+value at poles and for series admitting no such presentation.
+
+Second, `ComplexPlaceDictionary N` (for $N \neq 0$) is a structure carrying data together with its
+defining properties as fields: a map $\mathrm{pt} : \mathfrak{H} \to$ [`AlgebraicCurve.Place
+ℂ`](../def/AlgebraicCurve_DivisorClassGroup.html#L22) $(\mathbb{C}F_N)$, i.e. to valuation subrings
+of $\mathbb{C}F_N$ that contain $\mathbb{C}$, are not everything, and are principal (hence discrete
+valuation rings); a map $\mathrm{ramification} : \mathfrak{H} \to \mathbb{N}$; positivity of
+$\mathrm{ramification}$; invariance $\mathrm{pt}(\gamma \cdot \tau) = \mathrm{pt}(\tau)$ for $\gamma
+\in \mathrm{Gamma0}\ N$ acting through $\mathrm{SL}_2(\mathbb{Z})$; the characterisation that $x$
+lies in the valuation subring of $\mathrm{pt}(\tau)$ exactly when $z \mapsto \lVert
+\mathrm{realize}\ N\ x\ z \rVert$ is bounded along the punctured neighbourhood filter of $\tau$ in
+$\mathfrak{H}$; and, for $x \ne 0$, the order formula stating that the meromorphic order at $\tau
+\in \mathbb{C}$ of $z \mapsto \mathrm{realize}\ N\ x\ (\mathrm{ofComplex}\ z)$ equals
+$\mathrm{ramification}(\tau) \cdot \mathrm{ord}_{\mathrm{pt}(\tau)}(x)$, with $\mathrm{ord}$ the
+normalised additive valuation of the place. No existence of such a dictionary is asserted here.
+
+**Relation to Mathlib.** Mathlib supplies the ingredients on the analytic side (`ModularForm`,
+`CongruenceSubgroup.Gamma0`, the width-$h$ `qExpansion`, `meromorphicOrderAt`,
+`UpperHalfPlane.ofComplex`); the function field of $X_0(N)$ presented by $q$-expansions, the notion
+of place of a function field used here, and the dictionary structure are the project's own.
+
+**Where it is used.** The dictionary is the interface between the algebraic model of $X_0(N)$ by its
+field of $q$-expansions — where places, divisors, degree-zero divisor classes and Abel–Jacobi
+statements are formulated — and the analytic picture on the upper half-plane, where modular forms,
+elliptic points and cusps live. It is used wherever facts about modular curves and their Jacobians
+have to be transported between these two descriptions.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open UpperHalfPlane
+open scoped MatrixGroups Topology
+
+namespace ModularCurve
+
+def realize (N : ℕ) (x : LaurentSeries ℂ) (τ : ℍ) : ℂ := by
+  classical
+  exact
+    if H : ∃ p : (k : ℤ) × (ModularForm (CongruenceSubgroup.Gamma0 N) k ×
+          ModularForm (CongruenceSubgroup.Gamma0 N) k),
+        (p.2.2 : ℍ → ℂ) τ ≠ 0 ∧
+          x * ((qExpansion 1 (p.2.2 : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+            ((qExpansion 1 (p.2.1 : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+    then (H.choose.2.1 : ℍ → ℂ) τ / (H.choose.2.2 : ℍ → ℂ) τ
+    else 0
+
+structure ComplexPlaceDictionary (N : ℕ) [NeZero N] where
+  pt : ℍ → AlgebraicCurve.Place ℂ (laurentBaseChange ℂ (modularFunctionFieldFull N))
+  ramification : ℍ → ℕ
+  ramification_pos : ∀ τ : ℍ, 0 < ramification τ
+  pt_smul : ∀ (γ : CongruenceSubgroup.Gamma0 N) (τ : ℍ), pt ((γ : SL(2, ℤ)) • τ) = pt τ
+  mem_pt_iff : ∀ (τ : ℍ) (x : laurentBaseChange ℂ (modularFunctionFieldFull N)),
+    x ∈ (pt τ).toValuationSubring ↔
+      Filter.IsBoundedUnder (· ≤ ·) (𝓝[≠] τ) (fun z : ℍ => ‖realize N (x : LaurentSeries ℂ) z‖)
+  meromorphicOrderAt_realize : ∀ (τ : ℍ) (x : laurentBaseChange ℂ (modularFunctionFieldFull N)),
+    x ≠ 0 →
+      meromorphicOrderAt (fun z : ℂ => realize N (x : LaurentSeries ℂ) (ofComplex z)) (τ : ℂ) =
+        (((ramification τ : ℤ) * (pt τ).ord x : ℤ) : WithTop ℤ)
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_ComplexPlaceDictionaryOf.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_ComplexPlaceDictionaryOf.lean
new file mode 100644
index 0000000000..ae829790e1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_ComplexPlaceDictionaryOf.lean
@@ -0,0 +1,173 @@
+/-
+Based on Prove2Me node ModularCurve_ComplexPlaceDictionaryOf
+(24b06735-4f54-5fc7-ae5d-49f06216b2ad) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.CStarAlgebra.Classes
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ComplexPlaceDictionary
+
+/-!
+# Realisation of Laurent series and places dictionary for general level
+
+Definition: `ModularCurve_ComplexPlaceDictionaryOf` (`24b06735-4f54-5fc7-ae5d-49f06216b2ad`), by
+Claude, 2026-09-05.
+
+Two things are defined, for an arbitrary subgroup $\Gamma\le\mathrm{SL}_2(\mathbb{Z})$ and an
+arbitrary intermediate field $F_0$ of $\mathbb{Q}((q))/\mathbb{Q}$.
+
+First, `realizeOf Γ x τ`, for $x\in\mathbb{C}((q))$ and $\tau\in\mathfrak H$: if there exists a
+triple consisting of a weight $k\in\mathbb{Z}$ and a pair $(g,h)$ of modular forms of weight $k$ on
+$\Gamma$ with $h(\tau)\neq0$ and $x\cdot \tilde h=\tilde g$ in $\mathbb{C}((q))$, where $\tilde f$
+denotes the period-one $q$-expansion `qExpansion 1` of $f$ viewed as a Laurent series, then the
+value is $g(\tau)/h(\tau)$ for one such triple, picked by choice from the existence statement;
+otherwise the value is $0$. Thus the definition does not assert independence of the choice, and
+`realizeOf_of_not` records the value $0$ in the degenerate case. For $\Gamma=\Gamma_0(N)$ this
+agrees with the fixed-level function `realize N`.
+
+Second, the structure `ComplexPlaceDictionaryOf Γ F₀`, whose carrier field is $\mathbb{C}F_0=$
+`laurentBaseChange ℂ F₀`, the subfield of $\mathbb{C}((q))$ generated over $\mathbb{C}$ by the
+coefficientwise image of $F_0$. A member consists of maps $\mathrm{pt}:\mathfrak H\to$ places of
+$\mathbb{C}F_0$ over $\mathbb{C}$ (valuation subrings containing $\mathbb{C}$, proper, and
+principal, hence discrete) and $e:\mathfrak H\to\mathbb{N}$, together with the following as fields:
+$e_\tau>0$; $\mathrm{pt}(\gamma\tau)=\mathrm{pt}(\tau)$ for $\gamma\in\Gamma$; for every $\tau$ and
+$x\in\mathbb{C}F_0$, membership $x\in\mathcal O_{\mathrm{pt}(\tau)}$ holds precisely when
+$z\mapsto\lVert\mathrm{realizeOf}\,\Gamma\,x\,z\rVert$ is bounded along the punctured neighbourhood
+filter of $\tau$ in $\mathfrak H$; and for $x\neq0$ the meromorphic order at $\tau\in\mathbb{C}$ of
+$z\mapsto \mathrm{realizeOf}\,\Gamma\,x\,(\mathrm{ofComplex}\,z)$ equals
+$e_\tau\cdot\mathrm{ord}_{\mathrm{pt}(\tau)}(x)$ in $\mathbb{Z}\cup\{\infty\}$. Auxiliary
+declarations restate invariance for an element of $\mathrm{SL}_2(\mathbb{Z})$ lying in $\Gamma$ and
+$e_\tau\neq0$, and translate back and forth between this structure and `ComplexPlaceDictionary N` in
+the case $\Gamma=\Gamma_0(N)$, $F_0=$ `modularFunctionFieldFull N`, field by field.
+
+**Relation to Mathlib.** Mathlib supplies `ModularForm`, `qExpansion`, `meromorphicOrderAt` and
+`UpperHalfPlane.ofComplex`; the notion of a place of a function field used here
+([`AlgebraicCurve.Place`](../def/AlgebraicCurve_DivisorClassGroup.html#L22)) and the dictionary
+relating points of the upper half plane to such places are the project's own.
+`ComplexPlaceDictionaryOf` is the level-$\Gamma$, general-presentation form of the project's
+`ComplexPlaceDictionary N`, which it reduces to for $\Gamma_0(N)$ and the field
+`modularFunctionFieldFull N`.
+
+**Where it is used.** The dictionary is the interface through which complex-analytic information
+about modular curves — orders of vanishing, ramification at elliptic points, boundedness near a
+point — is transferred to valuation-theoretic statements about the function field presented by
+$q$-expansions at the cusp $\infty$, as needed for the algebraic geometry of modular curves in the
+modularity route to Fermat's Last Theorem. Keeping the subgroup $\Gamma$ and the rational subfield
+$F_0$ as parameters allows one dictionary notion to serve the several presentations of these
+function fields used later.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open UpperHalfPlane
+open scoped MatrixGroups Topology
+
+namespace ModularCurve
+
+def realizeOf (Γ : Subgroup SL(2, ℤ)) (x : LaurentSeries ℂ) (τ : ℍ) : ℂ := by
+  classical
+  exact
+    if H : ∃ p : (k : ℤ) × (ModularForm Γ k × ModularForm Γ k),
+        (p.2.2 : ℍ → ℂ) τ ≠ 0 ∧
+          x * ((qExpansion 1 (p.2.2 : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+            ((qExpansion 1 (p.2.1 : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+    then (H.choose.2.1 : ℍ → ℂ) τ / (H.choose.2.2 : ℍ → ℂ) τ
+    else 0
+
+theorem realizeOf_def (Γ : Subgroup SL(2, ℤ)) (x : LaurentSeries ℂ) (τ : ℍ) :
+    realizeOf Γ x τ = by
+      classical
+      exact
+        if H : ∃ p : (k : ℤ) × (ModularForm Γ k × ModularForm Γ k),
+            (p.2.2 : ℍ → ℂ) τ ≠ 0 ∧
+              x * ((qExpansion 1 (p.2.2 : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+                ((qExpansion 1 (p.2.1 : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+        then (H.choose.2.1 : ℍ → ℂ) τ / (H.choose.2.2 : ℍ → ℂ) τ
+        else 0 :=
+  rfl
+
+theorem realizeOf_of_not (Γ : Subgroup SL(2, ℤ)) (x : LaurentSeries ℂ) (τ : ℍ)
+    (h : ¬ ∃ p : (k : ℤ) × (ModularForm Γ k × ModularForm Γ k),
+        (p.2.2 : ℍ → ℂ) τ ≠ 0 ∧
+          x * ((qExpansion 1 (p.2.2 : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+            ((qExpansion 1 (p.2.1 : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)) :
+    realizeOf Γ x τ = 0 := by
+  classical
+  rw [realizeOf_def]
+  exact dite_eq_right h
+
+structure ComplexPlaceDictionaryOf (Γ : Subgroup SL(2, ℤ))
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) where
+  pt : ℍ → AlgebraicCurve.Place ℂ (laurentBaseChange ℂ F₀)
+  ramification : ℍ → ℕ
+  ramification_pos : ∀ τ : ℍ, 0 < ramification τ
+  pt_smul : ∀ (γ : Γ) (τ : ℍ), pt ((γ : SL(2, ℤ)) • τ) = pt τ
+  mem_pt_iff : ∀ (τ : ℍ) (x : laurentBaseChange ℂ F₀),
+    x ∈ (pt τ).toValuationSubring ↔
+      Filter.IsBoundedUnder (· ≤ ·) (𝓝[≠] τ)
+        (fun z : ℍ => ‖realizeOf Γ (x : LaurentSeries ℂ) z‖)
+  meromorphicOrderAt_realizeOf : ∀ (τ : ℍ) (x : laurentBaseChange ℂ F₀), x ≠ 0 →
+    meromorphicOrderAt (fun z : ℂ => realizeOf Γ (x : LaurentSeries ℂ) (ofComplex z)) (τ : ℂ) =
+      (((ramification τ : ℤ) * (pt τ).ord x : ℤ) : WithTop ℤ)
+
+namespace ComplexPlaceDictionaryOf
+
+variable {Γ : Subgroup SL(2, ℤ)} {F₀ : IntermediateField ℚ (LaurentSeries ℚ)}
+
+theorem pt_smul_of_mem (D : ComplexPlaceDictionaryOf Γ F₀) {γ : SL(2, ℤ)} (hγ : γ ∈ Γ) (τ : ℍ) :
+    D.pt (γ • τ) = D.pt τ :=
+  D.pt_smul ⟨γ, hγ⟩ τ
+
+theorem ramification_ne_zero (D : ComplexPlaceDictionaryOf Γ F₀) (τ : ℍ) : D.ramification τ ≠ 0 :=
+  (D.ramification_pos τ).ne'
+
+end ComplexPlaceDictionaryOf
+
+theorem realizeOf_gamma0 (N : ℕ) (x : LaurentSeries ℂ) (τ : ℍ) :
+    realizeOf (CongruenceSubgroup.Gamma0 N) x τ = realize N x τ :=
+  rfl
+
+def ComplexPlaceDictionaryOf.ofGamma0 {N : ℕ} [NeZero N] (D : ComplexPlaceDictionary N) :
+    ComplexPlaceDictionaryOf (CongruenceSubgroup.Gamma0 N) (modularFunctionFieldFull N) where
+  pt := D.pt
+  ramification := D.ramification
+  ramification_pos := D.ramification_pos
+  pt_smul := D.pt_smul
+  mem_pt_iff := D.mem_pt_iff
+  meromorphicOrderAt_realizeOf := D.meromorphicOrderAt_realize
+
+def ComplexPlaceDictionaryOf.toGamma0 {N : ℕ} [NeZero N]
+    (D : ComplexPlaceDictionaryOf (CongruenceSubgroup.Gamma0 N) (modularFunctionFieldFull N)) :
+    ComplexPlaceDictionary N where
+  pt := D.pt
+  ramification := D.ramification
+  ramification_pos := D.ramification_pos
+  pt_smul := D.pt_smul
+  mem_pt_iff := D.mem_pt_iff
+  meromorphicOrderAt_realize := D.meromorphicOrderAt_realizeOf
+
+@[simp]
+theorem ComplexPlaceDictionaryOf.pt_ofGamma0 {N : ℕ} [NeZero N] (D : ComplexPlaceDictionary N) :
+    (ComplexPlaceDictionaryOf.ofGamma0 D).pt = D.pt :=
+  rfl
+
+@[simp]
+theorem ComplexPlaceDictionaryOf.pt_toGamma0 {N : ℕ} [NeZero N]
+    (D : ComplexPlaceDictionaryOf (CongruenceSubgroup.Gamma0 N) (modularFunctionFieldFull N)) :
+    D.toGamma0.pt = D.pt :=
+  rfl
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CuspSpace.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CuspSpace.lean
new file mode 100644
index 0000000000..bdb7db41bb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CuspSpace.lean
@@ -0,0 +1,431 @@
+/-
+Based on Prove2Me node ModularCurve_CuspSpace
+(8b660599-7f86-55c8-b423-b8852b58036c) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Cusps
+
+/-!
+# Cusps of Γ0​(N): orbit space, denominator, width
+
+Definition: `ModularCurve_CuspSpace` (`8b660599-7f86-55c8-b423-b8852b58036c`), by Claude,
+2026-09-05.
+
+Working with $\mathbb{P}^1(\mathbb{Q})$ realised as `OnePoint ℚ`, the module first introduces
+homogeneous integer coordinates: `ratPoint a c` is $\infty$ when $c = 0$ and the image of $a/c$
+otherwise. Small lemmas record that every point of `OnePoint ℚ` is `ratPoint a c` for a coprime pair
+$(a,c)$ (numerator and denominator of a rational, $(1,0)$ for $\infty$), that `ratPoint` is
+unchanged by scaling both coordinates by a nonzero integer, that the Möbius action of the image of
+$\gamma \in \mathrm{SL}_2(\mathbb{Z})$ under `mapGL ℚ` sends `ratPoint a c` to `ratPoint (γ₀₀a +
+γ₀₁c) (γ₁₀a + γ₁₁c)`, and that coprimality of the pair is preserved. `Gamma0Q N` is the image of
+$\Gamma_0(N)$ in $\mathrm{GL}_2(\mathbb{Q})$ under `mapGL ℚ`, and `CuspSpace N` is the orbit space
+of `OnePoint ℚ` under this subgroup, with quotient map `mk`; `mk N x = mk N y` exactly when $y$ is
+carried to $x$ by some element of $\Gamma_0(N)$. The map `fromCoset` sends the coset of $g$ in
+$\mathrm{SL}_2(\mathbb{Z})/\Gamma_0(N)$ to the class of $g^{-1}\infty$; it is surjective, whence
+`CuspSpace N` is finite for $N \neq 0$, is always nonempty, and is a subsingleton for $N = 1$.
+
+The denominator invariant is defined on representatives by `cuspDenomAux N x = N` for $x = \infty$
+and $\gcd(\mathrm{den}\,q, N)$ for $x = q \in \mathbb{Q}$; it is $\Gamma_0(N)$-invariant, hence
+descends to `cuspDenom N : CuspSpace N → ℕ`, equals $\gcd(c,N)$ on `ratPoint a c` for coprime $a,
+c$, divides $N$, is positive for $N \neq 0$, and takes the value $e$ at the class of `ratPoint 1 e`
+whenever $e \mid N$. The width is `cuspWidthOfDenom` $N\,d = N/\gcd(d^2,N)$ and `cuspWidth x` is
+this applied to `cuspDenom N x`; accompanying arithmetic gives $\gcd(d^2,N)\cdot N/\gcd(d^2,N) = N$,
+divisibility of the width by $N$, positivity, the form $(N/d)/\gcd(d,N/d)$ for $d \mid N$,
+invariance under replacing $d$ by $\gcd(d,N)$, and the values $1$ at $d = N$ and $N$ at $d = 1$; on
+cusps, the width of the class of `ratPoint a c` ($a,c$ coprime) is $N/\gcd(|c|^2,N)$, the width at
+$\infty$ is $1$ for $N \neq 0$, and the width at $0$ is $N$. Finally two Props package classical
+statements about this model: `NormalFormCriterion N` asserts that for all integers $a, a'$ and $e
+\mid N$ with $a, a'$ coprime to $e$, the classes of `ratPoint a e` and `ratPoint a' e` agree if and
+only if $a \equiv a' \bmod \gcd(e, N/e)$, and `Classification N` asserts merely the existence (a
+`Nonempty` of an equivalence, not a chosen one) of a bijection between `CuspSpace N` and $\coprod_{d
+\mid N} (\mathbb{Z}/\gcd(d,N/d))^\times$. Also included is the reformulation $\gamma \in \Gamma_0(N)
+\iff N \mid \gamma_{1 0}$, stated in the `CongruenceSubgroup` namespace.
+
+**Relation to Mathlib.** Built on Mathlib's `OnePoint ℚ`, `CongruenceSubgroup.Gamma0`, the
+homomorphism `mapGL` into $\mathrm{GL}_2(\mathbb{Q})$ and `MulAction.orbitRel.Quotient`; the cusp
+set of $\Gamma_0(N)$ as an orbit space on $\mathbb{P}^1(\mathbb{Q})$, together with the denominator
+and width invariants, is the project's own.
+
+**Where it is used.** These definitions provide the combinatorial data of the cusps of $X_0(N)$ —
+their number, their denominators and their widths — used in the numerical computations attached to
+modular curves of small level in the level-lowering part of the argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open Matrix Matrix.SpecialLinearGroup OnePoint CongruenceSubgroup
+
+open scoped MatrixGroups
+
+namespace ModularCurve
+
+noncomputable section DL_portligature
+
+def ratPoint (a c : ℤ) : OnePoint ℚ :=
+  if c = 0 then ∞ else (((a : ℚ) / (c : ℚ) : ℚ) : OnePoint ℚ)
+
+@[simp] lemma ratPoint_zero_right (a : ℤ) : ratPoint a 0 = ∞ := ite_eq_left rfl
+
+lemma ratPoint_of_ne_zero (a : ℤ) {c : ℤ} (hc : c ≠ 0) :
+    ratPoint a c = (((a : ℚ) / (c : ℚ) : ℚ) : OnePoint ℚ) := ite_eq_right hc
+
+@[simp] lemma ratPoint_one_zero : ratPoint 1 0 = ∞ := ite_eq_left rfl
+
+@[simp] lemma ratPoint_zero_one : ratPoint 0 1 = ((0 : ℚ) : OnePoint ℚ) := by
+  simp [ratPoint]
+
+lemma ratPoint_eq_infty_iff {a c : ℤ} : ratPoint a c = ∞ ↔ c = 0 := by
+  rcases eq_or_ne c 0 with rfl | hc
+  · simp
+  · simp [ratPoint_of_ne_zero a hc, hc]
+
+lemma ratPoint_mul_left {l : ℤ} (hl : l ≠ 0) (a c : ℤ) :
+    ratPoint (l * a) (l * c) = ratPoint a c := by
+  rcases eq_or_ne c 0 with rfl | hc
+  · simp
+  · rw [ratPoint_of_ne_zero _ (mul_ne_zero hl hc), ratPoint_of_ne_zero _ hc]
+    push_cast
+    rw [mul_div_mul_left _ _ (by exact_mod_cast hl)]
+
+lemma ratPoint_neg_neg (a c : ℤ) : ratPoint (-a) (-c) = ratPoint a c := by
+  simpa using ratPoint_mul_left (l := -1) (by norm_num) a c
+
+lemma exists_ratPoint_eq (x : OnePoint ℚ) : ∃ a c : ℤ, IsCoprime a c ∧ ratPoint a c = x := by
+  cases x with
+  | infty => exact ⟨1, 0, isCoprime_one_left, rfl⟩
+  | coe q =>
+    refine ⟨q.num, (q.den : ℤ), ?_, ?_⟩
+    · rw [Int.isCoprime_iff_gcd_eq_one]
+      simpa [Int.gcd] using q.reduced
+    · rw [ratPoint_of_ne_zero _ (by exact_mod_cast q.den_nz), OnePoint.coe_eq_coe,
+        show ((q.den : ℤ) : ℚ) = (q.den : ℚ) by push_cast; ring, Rat.num_div_den]
+
+@[simp] lemma mapGL_apply_coe (γ : SL(2, ℤ)) (i j : Fin 2) :
+    (mapGL ℚ γ) i j = ((γ i j : ℤ) : ℚ) := by
+  simp [mapGL]
+
+lemma mapGL_smul_infty (γ : SL(2, ℤ)) :
+    mapGL ℚ γ • (∞ : OnePoint ℚ) = ratPoint (γ 0 0) (γ 1 0) := by
+  rw [smul_infty_eq_ite, mapGL_apply_coe, mapGL_apply_coe]
+  rcases eq_or_ne (γ 1 0) 0 with h | h
+  · simp [h]
+  · rw [ite_eq_right (by exact_mod_cast h), ratPoint_of_ne_zero _ h]
+
+lemma mapGL_smul_ratPoint (γ : SL(2, ℤ)) {a c : ℤ} (h : a ≠ 0 ∨ c ≠ 0) :
+    mapGL ℚ γ • ratPoint a c =
+      ratPoint (γ 0 0 * a + γ 0 1 * c) (γ 1 0 * a + γ 1 1 * c) := by
+  rcases eq_or_ne c 0 with rfl | hc
+  · replace h : a ≠ 0 := h.resolve_right (by simp)
+    rw [ratPoint_zero_right, mapGL_smul_infty]
+    simp only [mul_zero, add_zero]
+    rw [mul_comm (γ 0 0) a, mul_comm (γ 1 0) a, ratPoint_mul_left h]
+  · rw [ratPoint_of_ne_zero _ hc, smul_some_eq_ite]
+    have hcQ : (c : ℚ) ≠ 0 := by exact_mod_cast hc
+    have hden : (mapGL ℚ γ) 1 0 * ((a : ℚ) / c) + (mapGL ℚ γ) 1 1
+        = (((γ 1 0 * a + γ 1 1 * c : ℤ) : ℚ)) / (c : ℚ) := by
+      simp only [mapGL_apply_coe]
+      field_simp
+      push_cast
+      ring
+    have hnum : (mapGL ℚ γ) 0 0 * ((a : ℚ) / c) + (mapGL ℚ γ) 0 1
+        = (((γ 0 0 * a + γ 0 1 * c : ℤ) : ℚ)) / (c : ℚ) := by
+      simp only [mapGL_apply_coe]
+      field_simp
+      push_cast
+      ring
+    rcases eq_or_ne (γ 1 0 * a + γ 1 1 * c) 0 with h0 | h0
+    · rw [ite_eq_left (by rw [hden, h0]; simp), h0, ratPoint_zero_right]
+    · rw [ite_eq_right (by rw [hden]; exact div_ne_zero (by exact_mod_cast h0) hcQ),
+        ratPoint_of_ne_zero _ h0, hnum, hden, OnePoint.coe_eq_coe,
+        div_div_div_cancel_right₀ hcQ]
+
+lemma isCoprime_smul_pair (γ : SL(2, ℤ)) {a c : ℤ} (h : IsCoprime a c) :
+    IsCoprime (γ 0 0 * a + γ 0 1 * c) (γ 1 0 * a + γ 1 1 * c) := by
+  have := IsCoprime.mulVecSL (v := ![a, c]) (by simpa using h) γ
+  simpa [Matrix.mulVec_fin_two] using this
+
+variable (N : ℕ)
+
+def Gamma0Q : Subgroup (GL (Fin 2) ℚ) := (Gamma0 N).map (mapGL ℚ)
+
+lemma mem_Gamma0Q {g : GL (Fin 2) ℚ} :
+    g ∈ Gamma0Q N ↔ ∃ γ ∈ Gamma0 N, mapGL ℚ γ = g := Iff.rfl
+
+abbrev CuspSpace : Type := MulAction.orbitRel.Quotient (Gamma0Q N) (OnePoint ℚ)
+
+namespace CuspSpace
+
+def mk (x : OnePoint ℚ) : CuspSpace N := ⟦x⟧
+
+lemma mk_surjective : Function.Surjective (mk N) := by
+  rintro ⟨x⟩; exact ⟨x, rfl⟩
+
+variable {N}
+
+lemma mk_eq_mk_iff {x y : OnePoint ℚ} :
+    mk N x = mk N y ↔ ∃ γ ∈ Gamma0 N, mapGL ℚ γ • y = x := by
+  rw [mk, mk, Quotient.eq, MulAction.orbitRel_apply, MulAction.mem_orbit_iff]
+  constructor
+  · rintro ⟨⟨g, γ, hγ, rfl⟩, hg⟩
+    exact ⟨γ, hγ, hg⟩
+  · rintro ⟨γ, hγ, hg⟩
+    exact ⟨⟨mapGL ℚ γ, γ, hγ, rfl⟩, hg⟩
+
+lemma mk_smul {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 N) (x : OnePoint ℚ) :
+    mk N (mapGL ℚ γ • x) = mk N x :=
+  mk_eq_mk_iff.mpr ⟨γ, hγ, rfl⟩
+
+variable (N)
+
+lemma mk_smul_infty_eq_of_mem {a b : SL(2, ℤ)} (hab : a⁻¹ * b ∈ Gamma0 N) :
+    mk N (mapGL ℚ a⁻¹ • ∞) = mk N (mapGL ℚ b⁻¹ • ∞) := by
+  have key : mapGL ℚ b⁻¹ • (∞ : OnePoint ℚ)
+      = mapGL ℚ (a⁻¹ * b)⁻¹ • (mapGL ℚ a⁻¹ • (∞ : OnePoint ℚ)) := by
+    have h1 : (a⁻¹ * b)⁻¹ * a⁻¹ = b⁻¹ := by group
+    rw [← mul_smul, ← map_mul, h1]
+  rw [key]
+  exact (mk_smul (inv_mem hab) _).symm
+
+def fromCoset : SL(2, ℤ) ⧸ Gamma0 N → CuspSpace N :=
+  Quotient.lift (fun g => mk N (mapGL ℚ g⁻¹ • ∞))
+    (fun _ _ hab => mk_smul_infty_eq_of_mem N (QuotientGroup.leftRel_apply.mp hab))
+
+@[simp] lemma fromCoset_mk (g : SL(2, ℤ)) :
+    fromCoset N ((g : SL(2, ℤ) ⧸ Gamma0 N)) = mk N (mapGL ℚ g⁻¹ • ∞) := rfl
+
+lemma fromCoset_surjective : Function.Surjective (fromCoset N) := by
+  rintro ⟨x⟩
+  obtain ⟨g, hg⟩ := OnePoint.exists_mem_SL2 ℤ x
+  exact ⟨(g⁻¹ : SL(2, ℤ)), by rw [fromCoset_mk, inv_inv, hg]; rfl⟩
+
+instance instFinite [NeZero N] : Finite (CuspSpace N) :=
+  Finite.of_surjective _ (fromCoset_surjective N)
+
+instance instNonempty : Nonempty (CuspSpace N) := ⟨mk N ∞⟩
+
+instance instSubsingletonOfOne : Subsingleton (CuspSpace 1) := by
+  constructor
+  rintro ⟨x⟩ ⟨y⟩
+  obtain ⟨g, hg⟩ := OnePoint.exists_mem_SL2 ℤ x
+  obtain ⟨h, hh⟩ := OnePoint.exists_mem_SL2 ℤ y
+  change mk 1 x = mk 1 y
+  have hmem : ∀ γ : SL(2, ℤ), γ ∈ Gamma0 1 := fun γ => by
+    rw [Gamma0_mem]; exact Subsingleton.elim _ _
+  rw [← hg, ← hh]
+  symm
+  rw [show (mapGL ℚ h • (∞ : OnePoint ℚ)) = mapGL ℚ (h * g⁻¹) • (mapGL ℚ g • (∞ : OnePoint ℚ))
+    by rw [← mul_smul, ← map_mul, inv_mul_cancel_right]]
+  exact mk_smul (hmem _) _
+
+def cuspDenomAux (x : OnePoint ℚ) : ℕ :=
+  x.elim N fun q => Nat.gcd q.den N
+
+@[simp] lemma cuspDenomAux_infty : cuspDenomAux N ∞ = N := rfl
+
+@[simp] lemma cuspDenomAux_coe (q : ℚ) : cuspDenomAux N (q : OnePoint ℚ) = Nat.gcd q.den N :=
+  rfl
+
+variable {N}
+
+lemma cuspDenomAux_ratPoint {a c : ℤ} (h : IsCoprime a c) :
+    cuspDenomAux N (ratPoint a c) = Int.gcd c N := by
+  rcases eq_or_ne c 0 with rfl | hc
+  · simp [Int.gcd]
+  · rw [ratPoint_of_ne_zero _ hc, cuspDenomAux_coe]
+    have hcop : Nat.Coprime a.natAbs c.natAbs := Int.isCoprime_iff_gcd_eq_one.mp h
+    have hden : (((a : ℚ) / (c : ℚ)).den : ℤ) = (c.natAbs : ℤ) := by
+      rcases lt_or_gt_of_ne hc with hneg | hpos
+      · have : ((a : ℚ) / (c : ℚ)) = (((-a : ℤ) : ℚ) / ((-c : ℤ) : ℚ)) := by
+          push_cast; rw [neg_div_neg_eq]
+        rw [this, Rat.den_div_eq_of_coprime (by omega) (by simpa using hcop)]
+        omega
+      · rw [Rat.den_div_eq_of_coprime hpos hcop]
+        omega
+    have : ((a : ℚ) / (c : ℚ)).den = c.natAbs := by exact_mod_cast hden
+    rw [this]
+    rfl
+
+lemma _root_.CongruenceSubgroup.Gamma0_mem_iff_dvd {N : ℕ} {γ : SL(2, ℤ)} :
+    γ ∈ Gamma0 N ↔ (N : ℤ) ∣ γ 1 0 := by
+  rw [Gamma0_mem, ZMod.intCast_zmod_eq_zero_iff_dvd]
+
+lemma cuspDenomAux_dvd_smul {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 N) (x : OnePoint ℚ) :
+    cuspDenomAux N x ∣ cuspDenomAux N (mapGL ℚ γ • x) := by
+  obtain ⟨a, c, hac, rfl⟩ := exists_ratPoint_eq x
+  have hac' : a ≠ 0 ∨ c ≠ 0 := hac.ne_zero_or_ne_zero
+  rw [mapGL_smul_ratPoint γ hac', cuspDenomAux_ratPoint hac,
+    cuspDenomAux_ratPoint (isCoprime_smul_pair γ hac)]
+  have h1 : (Int.gcd c N : ℤ) ∣ γ 1 0 * a + γ 1 1 * c := by
+    refine dvd_add (Dvd.dvd.mul_right ?_ a) (Dvd.dvd.mul_left (Int.gcd_dvd_left ..) _)
+    exact (Int.gcd_dvd_right ..).trans (Gamma0_mem_iff_dvd.mp hγ)
+  exact Int.dvd_gcd h1 (Int.gcd_dvd_right ..)
+
+lemma cuspDenomAux_smul {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 N) (x : OnePoint ℚ) :
+    cuspDenomAux N (mapGL ℚ γ • x) = cuspDenomAux N x := by
+  refine Nat.dvd_antisymm ?_ (cuspDenomAux_dvd_smul hγ x)
+  have := cuspDenomAux_dvd_smul (inv_mem hγ) (mapGL ℚ γ • x)
+  rwa [← mul_smul, ← map_mul, inv_mul_cancel, map_one, one_smul] at this
+
+variable (N)
+
+def cuspDenom : CuspSpace N → ℕ :=
+  Quotient.lift (cuspDenomAux N) (by
+    rintro x y ⟨⟨g, γ, hγ, rfl⟩, rfl⟩
+    exact cuspDenomAux_smul hγ y)
+
+@[simp] lemma cuspDenom_mk (x : OnePoint ℚ) : cuspDenom N (mk N x) = cuspDenomAux N x := rfl
+
+variable {N}
+
+lemma cuspDenom_mk_ratPoint {a c : ℤ} (h : IsCoprime a c) :
+    cuspDenom N (mk N (ratPoint a c)) = Int.gcd c N :=
+  cuspDenomAux_ratPoint h
+
+@[simp] lemma cuspDenom_mk_infty : cuspDenom N (mk N ∞) = N := rfl
+
+@[simp] lemma cuspDenom_mk_zero : cuspDenom N (mk N ((0 : ℚ) : OnePoint ℚ)) = 1 := by
+  rw [← ratPoint_zero_one, cuspDenom_mk_ratPoint (isCoprime_zero_left.mpr isUnit_one)]
+  simp [Int.gcd]
+
+lemma cuspDenom_dvd (x : CuspSpace N) : cuspDenom N x ∣ N := by
+  obtain ⟨y, rfl⟩ := mk_surjective N x
+  obtain ⟨a, c, hac, rfl⟩ := exists_ratPoint_eq y
+  rw [cuspDenom_mk_ratPoint hac]
+  simpa using Int.gcd_dvd_natAbs_right c (N : ℤ)
+
+lemma cuspDenom_pos [NeZero N] (x : CuspSpace N) : 0 < cuspDenom N x :=
+  Nat.pos_of_dvd_of_pos (cuspDenom_dvd x) (Nat.pos_of_ne_zero (NeZero.ne N))
+
+lemma cuspDenom_mk_ratPoint_one_dvd {e : ℕ} (he : e ∣ N) :
+    cuspDenom N (mk N (ratPoint 1 e)) = e := by
+  rw [cuspDenom_mk_ratPoint isCoprime_one_left, Int.gcd_natCast_natCast, Nat.gcd_eq_left he]
+
+def NormalFormCriterion (N : ℕ) : Prop :=
+  ∀ (a a' : ℤ) (e : ℕ), e ∣ N → IsCoprime a (e : ℤ) → IsCoprime a' (e : ℤ) →
+    (mk N (ratPoint a e) = mk N (ratPoint a' e) ↔
+      (a : ZMod (Nat.gcd e (N / e))) = (a' : ZMod (Nat.gcd e (N / e))))
+
+def Classification (N : ℕ) : Prop :=
+  Nonempty (CuspSpace N ≃ (d : N.divisors) × (ZMod (Nat.gcd d (N / (d : ℕ))))ˣ)
+
+end CuspSpace
+
+end DL_portligature
+
+end ModularCurve
+
+open Matrix Matrix.SpecialLinearGroup OnePoint CongruenceSubgroup
+
+open scoped MatrixGroups
+
+namespace ModularCurve
+
+noncomputable section DL_tintometry
+
+theorem gcd_sq_eq_mul_gcd_div {N d : ℕ} (hd : d ∣ N) :
+    Nat.gcd (d ^ 2) N = d * Nat.gcd d (N / d) := by
+  conv_lhs => rw [pow_two, ← Nat.mul_div_cancel' hd]
+  exact Nat.gcd_mul_left d d (N / d)
+
+theorem gcd_sq_gcd_left (c N : ℕ) : Nat.gcd (Nat.gcd c N ^ 2) N = Nat.gcd (c ^ 2) N := by
+  rcases Nat.eq_zero_or_pos N with rfl | hN
+  · simp [Nat.gcd_zero_right]
+  rcases Nat.eq_zero_or_pos c with rfl | hc
+  · rw [Nat.gcd_zero_left, zero_pow two_ne_zero, Nat.gcd_zero_left,
+      Nat.gcd_eq_right (dvd_pow_self N two_ne_zero)]
+  set g : ℕ := Nat.gcd c N with hg
+  have hg0 : 0 < g := Nat.gcd_pos_of_pos_left N hc
+  have hgc : g ∣ c := Nat.gcd_dvd_left c N
+  have hgN : g ∣ N := Nat.gcd_dvd_right c N
+  have hcop : Nat.Coprime (c / g) (N / g) := Nat.coprime_div_gcd_div_gcd hg0
+  have hL : Nat.gcd (g ^ 2) N = g * Nat.gcd g (N / g) := gcd_sq_eq_mul_gcd_div hgN
+  have hR : Nat.gcd (c ^ 2) N = g * Nat.gcd g (N / g) := by
+    have h1 : c ^ 2 = g * (c / g * c) := by
+      rw [← mul_assoc, Nat.mul_div_cancel' hgc, ← pow_two]
+    have h2 : N = g * (N / g) := (Nat.mul_div_cancel' hgN).symm
+    rw [h1]
+    conv_lhs => rw [h2]
+    rw [Nat.gcd_mul_left]
+    congr 1
+    rw [Nat.Coprime.gcd_mul_left_cancel c hcop]
+    conv_lhs => rw [← Nat.div_mul_cancel hgc]
+    rw [Nat.Coprime.gcd_mul_left_cancel g hcop]
+  rw [hL, hR]
+
+def cuspWidthOfDenom (N d : ℕ) : ℕ := N / Nat.gcd (d ^ 2) N
+
+theorem gcd_mul_cuspWidthOfDenom (N d : ℕ) :
+    Nat.gcd (d ^ 2) N * cuspWidthOfDenom N d = N :=
+  Nat.mul_div_cancel' (Nat.gcd_dvd_right _ _)
+
+theorem cuspWidthOfDenom_dvd (N d : ℕ) : cuspWidthOfDenom N d ∣ N :=
+  Nat.div_dvd_of_dvd (Nat.gcd_dvd_right _ _)
+
+theorem cuspWidthOfDenom_pos {N : ℕ} (hN : N ≠ 0) (d : ℕ) : 0 < cuspWidthOfDenom N d :=
+  Nat.div_pos (Nat.le_of_dvd (Nat.pos_of_ne_zero hN) (Nat.gcd_dvd_right _ _))
+    (Nat.gcd_pos_of_pos_right _ (Nat.pos_of_ne_zero hN))
+
+theorem cuspWidthOfDenom_eq_div_div {N d : ℕ} (hd : d ∣ N) :
+    cuspWidthOfDenom N d = N / d / Nat.gcd d (N / d) := by
+  unfold cuspWidthOfDenom
+  rw [gcd_sq_eq_mul_gcd_div hd, Nat.div_div_eq_div_mul]
+
+theorem cuspWidthOfDenom_gcd (N d : ℕ) :
+    cuspWidthOfDenom N (Nat.gcd d N) = cuspWidthOfDenom N d := by
+  unfold cuspWidthOfDenom
+  rw [gcd_sq_gcd_left]
+
+theorem cuspWidthOfDenom_self {N : ℕ} (hN : N ≠ 0) : cuspWidthOfDenom N N = 1 := by
+  unfold cuspWidthOfDenom
+  rw [Nat.gcd_eq_right (dvd_pow_self N two_ne_zero), Nat.div_self (Nat.pos_of_ne_zero hN)]
+
+theorem cuspWidthOfDenom_one (N : ℕ) : cuspWidthOfDenom N 1 = N := by
+  unfold cuspWidthOfDenom
+  rw [one_pow, Nat.gcd_one_left, Nat.div_one]
+
+namespace CuspSpace
+
+variable {N : ℕ}
+
+def cuspWidth (x : CuspSpace N) : ℕ := cuspWidthOfDenom N (cuspDenom N x)
+
+theorem cuspWidth_mk_ratPoint {a c : ℤ} (h : IsCoprime a c) :
+    cuspWidth (mk N (ratPoint a c)) = N / Nat.gcd (c.natAbs ^ 2) N := by
+  have h1 : cuspDenom N (mk N (ratPoint a c)) = Nat.gcd c.natAbs N := by
+    rw [cuspDenom_mk_ratPoint h]
+    change Nat.gcd c.natAbs (N : ℤ).natAbs = _
+    rw [Int.natAbs_natCast]
+  change cuspWidthOfDenom N (cuspDenom N (mk N (ratPoint a c))) = _
+  rw [h1]
+  change N / Nat.gcd (Nat.gcd c.natAbs N ^ 2) N = _
+  rw [gcd_sq_gcd_left]
+
+theorem cuspWidth_mk_infty (hN : N ≠ 0) : cuspWidth (mk N ∞) = 1 := by
+  change cuspWidthOfDenom N (cuspDenom N (mk N ∞)) = 1
+  rw [cuspDenom_mk_infty]
+  exact cuspWidthOfDenom_self hN
+
+theorem cuspWidth_mk_zero : cuspWidth (mk N ((0 : ℚ) : OnePoint ℚ)) = N := by
+  change cuspWidthOfDenom N (cuspDenom N (mk N ((0 : ℚ) : OnePoint ℚ))) = N
+  rw [cuspDenom_mk_zero]
+  exact cuspWidthOfDenom_one N
+
+theorem cuspWidth_dvd (x : CuspSpace N) : cuspWidth x ∣ N := cuspWidthOfDenom_dvd _ _
+
+theorem cuspWidth_pos (hN : N ≠ 0) (x : CuspSpace N) : 0 < cuspWidth x :=
+  cuspWidthOfDenom_pos hN _
+
+end CuspSpace
+
+end DL_tintometry
+
+end ModularCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CuspidalClass.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CuspidalClass.lean
new file mode 100644
index 0000000000..6b814eccc6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CuspidalClass.lean
@@ -0,0 +1,109 @@
+/-
+Based on Prove2Me node ModularCurve_CuspidalClass
+(48ce548a-6006-5e9e-8985-bc39afd30e8f) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_AtkinLehner
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GeometricBaseChange
+
+/-!
+# Fricke involution, the cusps ∞, 0, and the cuspidal class
+
+Definition: `ModularCurve_CuspidalClass` (`48ce548a-6006-5e9e-8985-bc39afd30e8f`), by Claude,
+2026-09-05.
+
+Working with a fixed level $N\ge 1$ (`[NeZero N]`), this module produces closed terms, for every
+such $N$, for the Fricke involution and the cuspidal divisor class of $X_0(N)$ over
+$\overline{\mathbb{Q}}$, at the grain of function fields and places. First, `frickeInvolutionBar N`
+is the base change to $\overline{\mathbb{Q}}$, via the project's `geomAut`, of the all-divisors
+Fricke involution `frickeInvolutionFull N` of `modularFunctionFieldFull N`; it is an
+$\overline{\mathbb{Q}}$-algebra automorphism of `modularFunctionFieldBar N`. Next, `cuspZeroBar N`
+is defined as the image of the cusp at infinity under this automorphism, i.e. the place
+`frickeInvolutionBar N • cuspInftyBar N` of `modularFunctionFieldBar N` over $\overline{\mathbb{Q}}$
+— so the cusp $0$ is by definition $w_N(\infty)$, not characterised intrinsically. The divisor
+`cuspidalDivisor N` is the formal difference `Finsupp.single (cuspZeroBar N) 1 - Finsupp.single
+(cuspInftyBar N) 1`, that is $(0)-(\infty)$. The one substantive lemma, `degree_cuspidalDivisor`,
+shows its degree is $0$; the proof uses only that a place and its translate under an automorphism
+have equal degree (`Place.deg_smul`), the individual degrees being left uncomputed. Accordingly
+`cuspidalDivisor₀ N` bundles the divisor with a proof of membership in `Divisor.degZero`, and
+`cuspidalClass N : JZero N` is its class `Pic0.mk (cuspidalDivisor₀ N)` in the degree-zero divisor
+class group of `modularFunctionFieldBar N` over $\overline{\mathbb{Q}}$. The remaining declarations
+(`frickeInvolutionBar_def`, `cuspZeroBar_def`, `cuspidalDivisor_def`, `coe_cuspidalDivisor₀`,
+`cuspidalClass_def`) are unfolding lemmas restating the definitions. The definitions are total:
+nothing here asserts that `frickeInvolutionFull N` really is a Fricke involution, nor that the two
+cusps are distinct, so downstream statements about these objects must carry those hypotheses
+separately.
+
+**Relation to Mathlib.** Mathlib has no modular curves, cusps, Fricke involutions or divisor class
+groups of function fields in this form; the ambient notions (`Place`, `Divisor`, `Divisor.degZero`,
+`Pic0`, `geomAut`, `modularFunctionFieldFull`, `cuspInftyBar`) are all the project's own, built on
+Mathlib's `Finsupp` and `AlgEquiv`.
+
+**Where it is used.** The class $c_N=[(0)-(\infty)]$ in $J_0(N)(\overline{\mathbb{Q}})$ is the
+cuspidal class whose torsion order and Galois behaviour enter the level-lowering and
+Galois-representation arguments for $J_0(N)$; these terms are the objects on which the subsequent
+statements about the divisor of the Fricke-antiinvariant modular unit, the two-cusp enumeration at
+prime level, and the Hecke action on $J_0(N)$ are phrased.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open AlgebraicCurve
+
+namespace ModularCurve
+
+variable (N : ℕ) [NeZero N]
+
+def frickeInvolutionBar :
+    modularFunctionFieldBar N ≃ₐ[AlgebraicClosure ℚ] modularFunctionFieldBar N :=
+  geomAut (AlgebraicClosure ℚ) (modularFunctionFieldFull N) (frickeInvolutionFull N)
+
+theorem frickeInvolutionBar_def :
+    frickeInvolutionBar N =
+      geomAut (AlgebraicClosure ℚ) (modularFunctionFieldFull N) (frickeInvolutionFull N) :=
+  rfl
+
+def cuspZeroBar : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) :=
+  frickeInvolutionBar N • cuspInftyBar N
+
+theorem cuspZeroBar_def : cuspZeroBar N = frickeInvolutionBar N • cuspInftyBar N := rfl
+
+def cuspidalDivisor : Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N) :=
+  Finsupp.single (cuspZeroBar N) 1 - Finsupp.single (cuspInftyBar N) 1
+
+theorem cuspidalDivisor_def :
+    cuspidalDivisor N = Finsupp.single (cuspZeroBar N) 1 - Finsupp.single (cuspInftyBar N) 1 :=
+  rfl
+
+theorem degree_cuspidalDivisor : Divisor.degree (cuspidalDivisor N) = 0 := by
+  rw [cuspidalDivisor_def, map_sub, Divisor.degree_single, Divisor.degree_single, cuspZeroBar_def,
+    Place.deg_smul, sub_self]
+
+def cuspidalDivisor₀ :
+    Divisor.degZero (K := AlgebraicClosure ℚ) (F := modularFunctionFieldBar N) :=
+  ⟨cuspidalDivisor N, Divisor.mem_degZero.mpr (degree_cuspidalDivisor N)⟩
+
+@[simp]
+theorem coe_cuspidalDivisor₀ :
+    (cuspidalDivisor₀ N : Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) =
+      cuspidalDivisor N :=
+  rfl
+
+def cuspidalClass : JZero N := Pic0.mk (cuspidalDivisor₀ N)
+
+theorem cuspidalClass_def : cuspidalClass N = Pic0.mk (cuspidalDivisor₀ N) := rfl
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CycSubRootBridge.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CycSubRootBridge.lean
new file mode 100644
index 0000000000..11d3a403b4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CycSubRootBridge.lean
@@ -0,0 +1,253 @@
+/-
+Based on Prove2Me node ModularCurve_CycSubRootBridge
+(daa85f3b-17ec-5860-975e-25c24e3c9063) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Reduction
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_TatePoint
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_isAlgClosed_rat
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_isRoot_map_j_veluQuotient_j_of_addOrderOf_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_veluQuotient_oddOrderSummingSet_discriminant_ne_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_zmultiples_eq_of_veluQuotient_j_eq_of_transcendental
+
+/-!
+# Cyclic p-subgroups versus roots of the modular polynomial
+
+Definition: `ModularCurve_CycSubRootBridge` (`daa85f3b-17ec-5860-975e-25c24e3c9063`), by Claude,
+2026-09-05.
+
+Throughout, $H = \mathrm{HahnSeries}\,\mathbb{Q}\,\overline{\mathbb{Q}}$ is the Hahn-series field
+with rational exponents and coefficients in an algebraic closure of $\mathbb{Q}$; `isAlgClosed_H`
+and `charZero_H` record that it is algebraically closed of characteristic zero, and
+`transcendental_rat_of_transcendental_qbar` transfers transcendence over $\overline{\mathbb{Q}}$ to
+transcendence over $\mathbb{Q}$. For a Weierstrass curve $E$ over $H$ and $N \in \mathbb{N}$, an
+element of `CycSubH E N` is a subgroup $G$ of $E(H)$ together with the existence of $g \in E(H)$ of
+additive order $N$ with $G = \mathbb{Z}g$; `cycSubGen` chooses such a generator,
+`addOrderOf_cycSubGen` and `coe_eq_zmultiples_cycSubGen` state its two defining properties, and
+`CycSubH.ext` says such data are determined by the underlying subgroup. For a prime $p \neq 2$,
+`cycSubSummingSet E G` is the finite set of affine coordinate pairs of $g, 2g, \dots,
+\frac{p-1}{2}g$ (Vélu summing set of odd order), and `isElliptic_veluQuotient_cycSubSummingSet`
+shows the associated Vélu quotient $E/G$ has invertible discriminant. Given $\Phi$ of level $p$ (a
+`ModularPolynomialData p`: a monic $\Phi \in \mathbb{Z}[X][Y]$ of degree $\psi(p)$ vanishing on the
+pair $(j(q), j(q^p))$), `cycSubRoot E hp2 data G` is the element $j(E/G)$ of `RootsAt data E.j`, the
+subtype of $y \in H$ with $\Phi(j(E), y) = 0$ after mapping coefficients into $H$ via $X \mapsto
+j(E)$. If $j(E)$ is transcendental over $\overline{\mathbb{Q}}$ this map is injective
+(`cycSubRoot_injective`). The counting part establishes $\#\,$`CycSubH E p`$\, = \psi(p) = \sum_{d
+\mid p,\ d \text{ squarefree}} p/d$ (`natCard_cycSubH`, via a characterisation of the
+cyclic-subgroup condition as `IsAddCyclic` together with cardinality $p$), finiteness of both sides,
+and $\#\,$`RootsAt data E.j`$\, \le \psi(p)$ from $\deg_Y \Phi = \psi(p)$. Hence `cycSubRoot` is
+bijective, and `rootsEquivCycSubH` is its inverse equivalence $\mathrm{RootsAt}(\Phi, j(E)) \simeq
+\mathrm{CycSubH}(E,p)$, with the two computation rules $e^{-1}(G) = j(E/G)$ and $e(r) = G \iff r =
+j(E/G)$.
+
+**Relation to Mathlib.** Mathlib supplies the ambient objects — `HahnSeries`, `AlgebraicClosure`,
+`WeierstrassCurve` with its affine points and `AddSubgroup.zmultiples` — while the cyclic-subgroup
+type `CycSubH`, the root subtype `RootsAt`, the Vélu quotient and its odd summing sets, the
+modular-polynomial datum and the Dedekind $\psi$ function are the project's own definitions.
+
+**Where it is used.** The equivalence constructed here is exactly the data required by the predicate
+`ModuliDictionary` at prime level: over the Hahn-series field it identifies the roots of the
+level-$p$ modular polynomial at $j(E)$ with the order-$p$ cyclic subgroups of $E$, each root being
+the $j$-invariant of the corresponding Vélu quotient. This is part of the construction of modular
+curves and their modular equations used in the modularity route to Fermat's Last Theorem.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open ModularCurve WeierstrassCurve Polynomial
+open scoped Classical
+
+namespace ModularCurve.TatePoint
+
+theorem isAlgClosed_H : IsAlgClosed H := HahnSeries.isAlgClosed_rat
+
+theorem charZero_H : CharZero H :=
+  (RingHom.charZero_iff (HahnSeries.C (R := Qbar) (Γ := ℚ)).injective).mp inferInstance
+
+attribute [local instance] isAlgClosed_H charZero_H
+
+theorem transcendental_rat_of_transcendental_qbar {_ : Algebra ℚ H} {x : H}
+    (hx : Transcendental Qbar x) : Transcendental ℚ x := by
+  have := IsScalarTower.of_algebraMap_eq' (R := ℚ) (S := Qbar) (A := H) (Subsingleton.elim _ _)
+  exact hx.of_tower_top ℚ
+
+theorem two_mul_pred_div_two_add_one {p : ℕ} [Fact p.Prime] (hp2 : p ≠ 2) :
+    2 * ((p - 1) / 2) + 1 = p := by
+  rcases (Fact.out : p.Prime).eq_two_or_odd' with h | h
+  · exact absurd h hp2
+  · obtain ⟨m, rfl⟩ := h; omega
+
+section Gen
+
+variable (E : WeierstrassCurve H) {p : ℕ}
+
+def cycSubGen (G : CycSubH E p) : E.toAffine.Point := Classical.choose G.2
+
+theorem addOrderOf_cycSubGen (G : CycSubH E p) : addOrderOf (cycSubGen E G) = p :=
+  (Classical.choose_spec G.2).1
+
+theorem coe_eq_zmultiples_cycSubGen (G : CycSubH E p) :
+    G.1 = AddSubgroup.zmultiples (cycSubGen E G) :=
+  (Classical.choose_spec G.2).2
+
+theorem CycSubH.ext {G G' : CycSubH E p} (h : G.1 = G'.1) : G = G' := Subtype.ext h
+
+def cycSubSummingSet (G : CycSubH E p) : Finset (H × H) :=
+  E.oddOrderSummingSet (cycSubGen E G) ((p - 1) / 2)
+
+theorem cycSubSummingSet_def (G : CycSubH E p) :
+    cycSubSummingSet E G = E.oddOrderSummingSet (cycSubGen E G) ((p - 1) / 2) := rfl
+
+end Gen
+
+section Root
+
+variable (E : WeierstrassCurve H) [E.IsElliptic] {p : ℕ} [Fact p.Prime]
+
+theorem isElliptic_veluQuotient_cycSubSummingSet (hp2 : p ≠ 2) (G : CycSubH E p) :
+    (E.veluQuotient (cycSubSummingSet E G)).IsElliptic :=
+  ⟨isUnit_iff_ne_zero.mpr
+    (WeierstrassCurve.veluQuotient_oddOrderSummingSet_discriminant_ne_zero (L := H) two_ne_zero E
+      ((p - 1) / 2) (cycSubGen E G)
+      (by rw [addOrderOf_cycSubGen, two_mul_pred_div_two_add_one hp2]))⟩
+
+theorem isRoot_map_j_veluQuotient_j_of_eq {N : ℕ} [NeZero N] (n : ℕ) (hN : 2 * n + 1 = N)
+    (data : ModularPolynomialData N) (Q : E.toAffine.Point) (hQ : addOrderOf Q = N)
+    (hΔ : (E.veluQuotient (E.oddOrderSummingSet Q n)).Δ ≠ 0) :
+    haveI : (E.veluQuotient (E.oddOrderSummingSet Q n)).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom H) E.j)).IsRoot
+      (E.veluQuotient (E.oddOrderSummingSet Q n)).j := by
+  subst hN
+  exact ModularPolynomialData.isRoot_map_j_veluQuotient_j_of_addOrderOf_eq E n Q hQ hΔ data
+
+def cycSubRoot (hp2 : p ≠ 2) (data : ModularPolynomialData p) (G : CycSubH E p) :
+    RootsAt data E.j :=
+  ⟨@WeierstrassCurve.j H _ (E.veluQuotient (cycSubSummingSet E G))
+      (isElliptic_veluQuotient_cycSubSummingSet E hp2 G),
+    isRoot_map_j_veluQuotient_j_of_eq E ((p - 1) / 2) (two_mul_pred_div_two_add_one hp2) data
+      (cycSubGen E G) (addOrderOf_cycSubGen E G)
+      (isElliptic_veluQuotient_cycSubSummingSet E hp2 G).isUnit.ne_zero⟩
+
+theorem cycSubRoot_coe (hp2 : p ≠ 2) (data : ModularPolynomialData p) (G : CycSubH E p) :
+    (cycSubRoot E hp2 data G).1 =
+      @WeierstrassCurve.j H _ (E.veluQuotient (cycSubSummingSet E G))
+        (isElliptic_veluQuotient_cycSubSummingSet E hp2 G) := rfl
+
+theorem cycSubRoot_injective (hp2 : p ≠ 2) (data : ModularPolynomialData p)
+    (hj : Transcendental Qbar E.j) : Function.Injective (cycSubRoot E hp2 data) := by
+  intro G G' h
+  have hjj := congrArg Subtype.val h
+  simp only [cycSubRoot_coe] at hjj
+  apply CycSubH.ext
+  rw [coe_eq_zmultiples_cycSubGen, coe_eq_zmultiples_cycSubGen]
+  exact WeierstrassCurve.zmultiples_eq_of_veluQuotient_j_eq_of_transcendental E
+    (transcendental_rat_of_transcendental_qbar hj) ((p - 1) / 2) (cycSubGen E G) (cycSubGen E G')
+    (by rw [addOrderOf_cycSubGen, two_mul_pred_div_two_add_one hp2])
+    (by rw [addOrderOf_cycSubGen, two_mul_pred_div_two_add_one hp2])
+    (isElliptic_veluQuotient_cycSubSummingSet E hp2 G).isUnit.ne_zero
+    (isElliptic_veluQuotient_cycSubSummingSet E hp2 G').isUnit.ne_zero hjj
+
+end Root
+
+section Count
+
+variable (E : WeierstrassCurve H) {p : ℕ}
+
+theorem exists_addOrderOf_eq_and_eq_zmultiples_iff {A : Type*} [AddCommGroup A] {N : ℕ}
+    (G : AddSubgroup A) :
+    (∃ g : A, addOrderOf g = N ∧ G = AddSubgroup.zmultiples g) ↔ (IsAddCyclic G ∧ Nat.card G = N)
+      := by
+  constructor
+  · rintro ⟨g, hg, rfl⟩
+    exact ⟨inferInstance, by rw [Nat.card_zmultiples, hg]⟩
+  · rintro ⟨hc, hcard⟩
+    obtain ⟨g, hg⟩ := (AddSubgroup.isAddCyclic_iff_exists_zmultiples_eq_top G).mp hc
+    exact ⟨g, by rw [← Nat.card_zmultiples, hg, hcard], hg.symm⟩
+
+theorem natCard_cycSubH [E.IsElliptic] [NeZero p] : Nat.card (CycSubH E p) = dedekindPsi p := by
+  have h := WeierstrassCurve.natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed
+    (K := H) E (n := p) (by exact_mod_cast NeZero.ne p)
+  have hW : WeierstrassCurve.Affine.baseChange E H = E.toAffine := by
+    rw [WeierstrassCurve.Affine.baseChange, WeierstrassCurve.baseChange, Algebra.algebraMap_self,
+      WeierstrassCurve.map_id]
+  rw [hW] at h
+  rw [← h]
+  unfold CycSubH
+  exact Nat.card_congr (Equiv.subtypeEquivRight fun G =>
+    exists_addOrderOf_eq_and_eq_zmultiples_iff G)
+
+theorem le_dedekindPsi (N : ℕ) (hN : N ≠ 0) : N ≤ dedekindPsi N := by
+  unfold dedekindPsi
+  have h1 : (1 : ℕ) ∈ N.divisors.filter Squarefree :=
+    Finset.mem_filter.mpr ⟨Nat.one_mem_divisors.mpr hN, squarefree_one⟩
+  simpa using Finset.single_le_sum (f := fun d => N / d) (fun _ _ => Nat.zero_le _) h1
+
+theorem finite_cycSubH [E.IsElliptic] [NeZero p] : Finite (CycSubH E p) :=
+  Nat.finite_of_card_ne_zero (by
+    rw [natCard_cycSubH]
+    exact (Nat.lt_of_lt_of_le (Nat.pos_of_ne_zero (NeZero.ne p)) (le_dedekindPsi p (NeZero.ne
+      p))).ne')
+
+def rootsAtEquivMemRootsToFinset [NeZero p] (data : ModularPolynomialData p) (jv : H) :
+    RootsAt data jv ≃
+      {y : H // y ∈ (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom H) jv)).roots.toFinset}
+        := by
+  unfold RootsAt
+  exact Equiv.subtypeEquivRight fun y => by
+    rw [Multiset.mem_toFinset, Polynomial.mem_roots ((data.monic.map _).ne_zero)]
+
+theorem finite_rootsAt [NeZero p] (data : ModularPolynomialData p) (jv : H) :
+    Finite (RootsAt data jv) :=
+  Finite.of_equiv _ (rootsAtEquivMemRootsToFinset data jv).symm
+
+theorem natCard_rootsAt_le [NeZero p] (data : ModularPolynomialData p) (jv : H) :
+    Nat.card (RootsAt data jv) ≤ dedekindPsi p := by
+  rw [Nat.card_congr (rootsAtEquivMemRootsToFinset data jv), Nat.card_eq_finsetCard]
+  set f := data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom H) jv) with hf
+  calc f.roots.toFinset.card ≤ Multiset.card f.roots := Multiset.toFinset_card_le _
+    _ ≤ f.natDegree := Polynomial.card_roots' f
+    _ = dedekindPsi p := by rw [hf, data.monic.natDegree_map, data.natDegree_eq]
+
+end Count
+
+section Equiv
+
+variable (E : WeierstrassCurve H) [E.IsElliptic] {p : ℕ} [Fact p.Prime]
+
+theorem cycSubRoot_bijective (hp2 : p ≠ 2) (data : ModularPolynomialData p)
+    (hj : Transcendental Qbar E.j) : Function.Bijective (cycSubRoot E hp2 data) := by
+  have := finite_rootsAt data E.j
+  refine (cycSubRoot_injective E hp2 data hj).bijective_of_nat_card_le ?_
+  rw [natCard_cycSubH]
+  exact natCard_rootsAt_le data E.j
+
+def rootsEquivCycSubH (hp2 : p ≠ 2) (data : ModularPolynomialData p)
+    (hj : Transcendental Qbar E.j) : RootsAt data E.j ≃ CycSubH E p :=
+  (Equiv.ofBijective (cycSubRoot E hp2 data) (cycSubRoot_bijective E hp2 data hj)).symm
+
+theorem rootsEquivCycSubH_symm_apply (hp2 : p ≠ 2) (data : ModularPolynomialData p)
+    (hj : Transcendental Qbar E.j) (G : CycSubH E p) :
+    (rootsEquivCycSubH E hp2 data hj).symm G = cycSubRoot E hp2 data G := rfl
+
+theorem rootsEquivCycSubH_apply_eq_iff (hp2 : p ≠ 2) (data : ModularPolynomialData p)
+    (hj : Transcendental Qbar E.j) (r : RootsAt data E.j) (G : CycSubH E p) :
+    rootsEquivCycSubH E hp2 data hj r = G ↔ r = cycSubRoot E hp2 data G := by
+  rw [← rootsEquivCycSubH_symm_apply E hp2 data hj G, Equiv.eq_symm_apply]
+
+end Equiv
+
+end ModularCurve.TatePoint
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CycSubRootBridgeN.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CycSubRootBridgeN.lean
new file mode 100644
index 0000000000..94626ff62d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CycSubRootBridgeN.lean
@@ -0,0 +1,237 @@
+/-
+Based on Prove2Me node ModularCurve_CycSubRootBridgeN
+(133d926c-5a48-51a4-9773-4cb8b330ed18) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CycSubRootBridge
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FullKernelQuotient
+
+/-!
+# Roots of the modular polynomial versus cyclic subgroups
+
+Definition: `ModularCurve_CycSubRootBridgeN` (`133d926c-5a48-51a4-9773-4cb8b330ed18`), by Claude,
+2026-09-05.
+
+Throughout, $\bar{\mathbf Q}$ denotes an algebraic closure of $\mathbf Q$ and $H$ the field of Hahn
+series over $\bar{\mathbf Q}$ with value group $\mathbf Q$. For a Weierstrass curve $W$ over a field
+with decidable equality, a point $Q$ of its affine model and $N \in \mathbf N$, the curve
+`W.fullKernelQuotient Q N` is the Vélu-type curve with the same $a_1,a_2,a_3$ and with $a_4$ and
+$a_6$ corrected by $t = \sum_P G_x(P)$ and $w = \sum_P (x_P G_x(P) - y_P G_y(P))$, the sums running
+over the coordinates of $Q, 2Q, \dots, (N-1)Q$.
+
+Three propositions in the level $N$ alone are introduced as hypotheses. `FullKernelIsRootAt N` says:
+for every elliptic Weierstrass curve $W$ over $H$ and every point $Q$ of exact additive order $N$
+with $\Delta$ of the full-kernel quotient nonzero, and every datum `data : ModularPolynomialData N`
+(a monic $\Phi \in \mathbf Z[X][Y]$ of degree $\psi(N)$ vanishing on the pair $(j(q), j(q^N))$), the
+$j$-invariant of the quotient is a root of $\Phi(j(W), Y) \in H[Y]$. `FullKernelInjAt N` says: if
+moreover $j(W)$ is transcendental over $\mathbf Q$, two points $Q, Q'$ of exact order $N$ with
+nondegenerate quotients of equal $j$-invariant satisfy $\mathbf Z Q = \mathbf Z Q'$.
+`FullKernelDiscAt N` says: over any algebraically closed field with $2 \ne 0$, the full-kernel
+quotient at any point of exact order $N$ has nonzero discriminant.
+
+Granting these, `cycSubRootN` sends a subgroup $G$ of $E(H)$ admitting a generator of exact order
+$N$ to the $j$-invariant of the full-kernel quotient of $E$ by a chosen such generator, viewed as a
+root of $\Phi(j(E), Y)$; it is injective when $j(E)$ is transcendental over $\bar{\mathbf Q}$, and
+bijective because the source has exactly $\psi(N)$ elements while the root set has at most $\deg_Y
+\Phi = \psi(N)$. `rootsEquivCycSubHN` is the inverse equivalence, and `dictN` is its instance at the
+curve $\mathrm{ofJ}(j_0 + s)$, whose $j$-invariant is transcendental for every $j_0 \in \bar{\mathbf
+Q}$. Further lemmas record the underlying value of `cycSubRootN` and the characterisation of the
+equivalence by $e(r) = G \iff r =$ `cycSubRootN` $G$.
+
+**Relation to Mathlib.** Mathlib supplies Weierstrass curves, the $j$-invariant, `IsElliptic` and
+Hahn series; the full-kernel Vélu quotient, the type of cyclic $N$-subgroups, the type of roots of a
+modular polynomial datum and the datum itself (monic $\Phi$ of $Y$-degree $\psi(N)$ with the
+$q$-expansion relation) are the project's own notions.
+
+**Where it is used.** These definitions provide the moduli dictionary at level $N$: over the
+Hahn-series field the roots of $\Phi_N(j(E), Y)$ correspond bijectively to the cyclic subgroups of
+order $N$ of $E$, which is the form in which the modular interpretation of $X_0(N)$ is used in the
+argument. For odd $N$ the three hypotheses are available from the identification of the full-kernel
+quotient with the Vélu quotient over a half-system of the kernel.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open ModularCurve WeierstrassCurve Polynomial
+open scoped Classical
+
+namespace ModularCurve.TatePoint
+
+abbrev FullKernelIsRootAt (N : ℕ) [NeZero N] : Prop :=
+  ∀ [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    (Q : W.toAffine.Point) (_ : addOrderOf Q = N)
+    (hΔ : (W.fullKernelQuotient Q N).Δ ≠ 0)
+    (data : ModularCurve.ModularPolynomialData N),
+    haveI : (W.fullKernelQuotient Q N).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+    (data.Φ.map (Polynomial.eval₂RingHom
+      (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ))) W.j)).IsRoot
+      (W.fullKernelQuotient Q N).j
+
+abbrev FullKernelInjAt (N : ℕ) [NeZero N] : Prop :=
+  ∀ [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    (_ : Transcendental ℚ W.j) (Q Q' : W.toAffine.Point)
+    (_ : addOrderOf Q = N) (_ : addOrderOf Q' = N)
+    (hΔ : (W.fullKernelQuotient Q N).Δ ≠ 0)
+    (hΔ' : (W.fullKernelQuotient Q' N).Δ ≠ 0)
+    (_ : haveI : (W.fullKernelQuotient Q N).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+      haveI : (W.fullKernelQuotient Q' N).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ'⟩
+      (W.fullKernelQuotient Q N).j = (W.fullKernelQuotient Q' N).j),
+    AddSubgroup.zmultiples Q = AddSubgroup.zmultiples Q'
+
+abbrev FullKernelDiscAt (N : ℕ) [NeZero N] : Prop :=
+  ∀ {L : Type} [Field L] [DecidableEq L] [IsAlgClosed L], (2 : L) ≠ 0 →
+    ∀ (W : WeierstrassCurve L) [W.IsElliptic] (Q : W.toAffine.Point),
+      addOrderOf Q = N → (W.fullKernelQuotient Q N).Δ ≠ 0
+
+attribute [local instance] isAlgClosed_H charZero_H
+
+theorem isElliptic_fullKernelQuotient_cycSubGen (E : WeierstrassCurve H) [E.IsElliptic] {N : ℕ}
+    [NeZero N]
+    (hW3 : FullKernelDiscAt N) (G : CycSubH E N) :
+    (E.fullKernelQuotient (cycSubGen E G) N).IsElliptic :=
+  ⟨isUnit_iff_ne_zero.mpr (hW3 two_ne_zero E (cycSubGen E G) (addOrderOf_cycSubGen E G))⟩
+
+def cycSubRootN (E : WeierstrassCurve H) [E.IsElliptic] {N : ℕ} [NeZero N]
+    (hW1 : FullKernelIsRootAt N)
+    (hW3 : FullKernelDiscAt N) (data : ModularPolynomialData N) (G : CycSubH E N)
+    : RootsAt data E.j :=
+  ⟨@WeierstrassCurve.j H _ (E.fullKernelQuotient (cycSubGen E G) N)
+      (isElliptic_fullKernelQuotient_cycSubGen E hW3 G),
+    hW1 E (cycSubGen E G) (addOrderOf_cycSubGen E G)
+      (isElliptic_fullKernelQuotient_cycSubGen E hW3 G).isUnit.ne_zero data⟩
+
+theorem cycSubRootN_coe (E : WeierstrassCurve H) [E.IsElliptic] {N : ℕ} [NeZero N]
+    (hW1 : FullKernelIsRootAt N) (hW3 : FullKernelDiscAt N) (data : ModularPolynomialData N)
+    (G : CycSubH E N) :
+    (cycSubRootN E hW1 hW3 data G).1 =
+      @WeierstrassCurve.j H _ (E.fullKernelQuotient (cycSubGen E G) N)
+        (isElliptic_fullKernelQuotient_cycSubGen E hW3 G) := rfl
+
+theorem cycSubRootN_injective (E : WeierstrassCurve H) [E.IsElliptic] {N : ℕ} [NeZero N]
+    (hW1 : FullKernelIsRootAt N) (hW2 : FullKernelInjAt N) (hW3 : FullKernelDiscAt N)
+    (data : ModularPolynomialData N) (hj : Transcendental Qbar E.j) :
+    Function.Injective (cycSubRootN E hW1 hW3 data) := by
+  intro G G' h
+  have hjj := congrArg Subtype.val h
+  simp only [cycSubRootN_coe] at hjj
+  apply CycSubH.ext
+  rw [coe_eq_zmultiples_cycSubGen, coe_eq_zmultiples_cycSubGen]
+  exact hW2 E (transcendental_rat_of_transcendental_qbar hj) (cycSubGen E G) (cycSubGen E G')
+    (addOrderOf_cycSubGen E G) (addOrderOf_cycSubGen E G')
+    (isElliptic_fullKernelQuotient_cycSubGen E hW3 G).isUnit.ne_zero
+    (isElliptic_fullKernelQuotient_cycSubGen E hW3 G').isUnit.ne_zero hjj
+
+theorem cycSubRootN_bijective (E : WeierstrassCurve H) [E.IsElliptic] {N : ℕ} [NeZero N]
+    (hW1 : FullKernelIsRootAt N) (hW2 : FullKernelInjAt N) (hW3 : FullKernelDiscAt N)
+    (data : ModularPolynomialData N) (hj : Transcendental Qbar E.j) :
+    Function.Bijective (cycSubRootN E hW1 hW3 data) := by
+  have := finite_rootsAt data E.j
+  refine (cycSubRootN_injective E hW1 hW2 hW3 data hj).bijective_of_nat_card_le ?_
+  rw [natCard_cycSubH]
+  exact natCard_rootsAt_le data E.j
+
+def rootsEquivCycSubHN (E : WeierstrassCurve H) [E.IsElliptic] {N : ℕ} [NeZero N]
+    (hW1 : FullKernelIsRootAt N) (hW2 : FullKernelInjAt N) (hW3 : FullKernelDiscAt N)
+    (data : ModularPolynomialData N) (hj : Transcendental Qbar E.j)
+    : RootsAt data E.j ≃ CycSubH E N :=
+  (Equiv.ofBijective (cycSubRootN E hW1 hW3 data) (cycSubRootN_bijective E hW1 hW2 hW3 data
+    hj)).symm
+
+theorem rootsEquivCycSubHN_symm_apply (E : WeierstrassCurve H) [E.IsElliptic] {N : ℕ} [NeZero N]
+    (hW1 : FullKernelIsRootAt N) (hW2 : FullKernelInjAt N) (hW3 : FullKernelDiscAt N)
+    (data : ModularPolynomialData N) (hj : Transcendental Qbar E.j) (G : CycSubH E N) :
+    (rootsEquivCycSubHN E hW1 hW2 hW3 data hj).symm G = cycSubRootN E hW1 hW3 data G := rfl
+
+theorem rootsEquivCycSubHN_apply_eq_iff (E : WeierstrassCurve H) [E.IsElliptic] {N : ℕ} [NeZero N]
+    (hW1 : FullKernelIsRootAt N) (hW2 : FullKernelInjAt N) (hW3 : FullKernelDiscAt N)
+    (data : ModularPolynomialData N) (hj : Transcendental Qbar E.j) (r : RootsAt data E.j)
+    (G : CycSubH E N) :
+    rootsEquivCycSubHN E hW1 hW2 hW3 data hj r = G ↔ r = cycSubRootN E hW1 hW3 data G := by
+  rw [← rootsEquivCycSubHN_symm_apply E hW1 hW2 hW3 data hj G, Equiv.eq_symm_apply]
+
+def dictN (N : ℕ) [NeZero N] (data : ModularPolynomialData N) (j₀ : Qbar)
+    (hW1 : FullKernelIsRootAt N)
+    (hW2 : FullKernelInjAt N) (hW3 : FullKernelDiscAt N) :
+    RootsAt data (nearCurve j₀).j ≃ CycSubH (nearCurve j₀) N :=
+  rootsEquivCycSubHN (nearCurve j₀) hW1 hW2 hW3 data (nearCurve_j_transcendental j₀)
+
+theorem dictN_symm_apply_coe (N : ℕ) [NeZero N] (data : ModularPolynomialData N) (j₀ : Qbar)
+    (hW1 : FullKernelIsRootAt N) (hW2 : FullKernelInjAt N) (hW3 : FullKernelDiscAt N)
+    (G : CycSubH (nearCurve j₀) N) :
+    ((dictN N data j₀ hW1 hW2 hW3).symm G).1 =
+      @WeierstrassCurve.j H _ ((nearCurve j₀).fullKernelQuotient (cycSubGen (nearCurve j₀) G) N)
+        (isElliptic_fullKernelQuotient_cycSubGen (nearCurve j₀) hW3 G) := rfl
+
+theorem dictN_apply_eq_iff (N : ℕ) [NeZero N] (data : ModularPolynomialData N) (j₀ : Qbar)
+    (hW1 : FullKernelIsRootAt N) (hW2 : FullKernelInjAt N) (hW3 : FullKernelDiscAt N)
+    (r : RootsAt data (nearCurve j₀).j) (G : CycSubH (nearCurve j₀) N) :
+    dictN N data j₀ hW1 hW2 hW3 r = G ↔ r = cycSubRootN (nearCurve j₀) hW1 hW3 data G :=
+  rootsEquivCycSubHN_apply_eq_iff (nearCurve j₀) hW1 hW2 hW3 data (nearCurve_j_transcendental j₀) r
+    G
+
+end ModularCurve.TatePoint
+
+end
+
+example (N : ℕ) [NeZero N] (h : ∀ [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    (Q : W.toAffine.Point) (_ : addOrderOf Q = N)
+    (hΔ : (W.fullKernelQuotient Q N).Δ ≠ 0)
+    (data : ModularCurve.ModularPolynomialData N),
+    haveI : (W.fullKernelQuotient Q N).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+    (data.Φ.map (Polynomial.eval₂RingHom
+      (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ))) W.j)).IsRoot
+      (W.fullKernelQuotient Q N).j) : ModularCurve.TatePoint.FullKernelIsRootAt N := h
+example (N : ℕ) [NeZero N] (h : ModularCurve.TatePoint.FullKernelIsRootAt N)
+    [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    (Q : W.toAffine.Point) (hQ : addOrderOf Q = N) (hΔ : (W.fullKernelQuotient Q N).Δ ≠ 0)
+    (data : ModularCurve.ModularPolynomialData N) :
+    haveI : (W.fullKernelQuotient Q N).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+    (data.Φ.map (Polynomial.eval₂RingHom
+      (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ))) W.j)).IsRoot
+      (W.fullKernelQuotient Q N).j := h W Q hQ hΔ data
+example (N : ℕ) [NeZero N] (h : ∀ [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    (_ : Transcendental ℚ W.j) (Q Q' : W.toAffine.Point)
+    (_ : addOrderOf Q = N) (_ : addOrderOf Q' = N)
+    (hΔ : (W.fullKernelQuotient Q N).Δ ≠ 0)
+    (hΔ' : (W.fullKernelQuotient Q' N).Δ ≠ 0)
+    (_ : haveI : (W.fullKernelQuotient Q N).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+      haveI : (W.fullKernelQuotient Q' N).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ'⟩
+      (W.fullKernelQuotient Q N).j = (W.fullKernelQuotient Q' N).j),
+    AddSubgroup.zmultiples Q = AddSubgroup.zmultiples Q') : ModularCurve.TatePoint.FullKernelInjAt N
+      := h
+example (N : ℕ) [NeZero N] (h : ModularCurve.TatePoint.FullKernelInjAt N)
+    [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    (ht : Transcendental ℚ W.j) (Q Q' : W.toAffine.Point)
+    (hQ : addOrderOf Q = N) (hQ' : addOrderOf Q' = N)
+    (hΔ : (W.fullKernelQuotient Q N).Δ ≠ 0) (hΔ' : (W.fullKernelQuotient Q' N).Δ ≠ 0)
+    (hj : haveI : (W.fullKernelQuotient Q N).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+      haveI : (W.fullKernelQuotient Q' N).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ'⟩
+      (W.fullKernelQuotient Q N).j = (W.fullKernelQuotient Q' N).j) :
+    AddSubgroup.zmultiples Q = AddSubgroup.zmultiples Q' := h W ht Q Q' hQ hQ' hΔ hΔ' hj
+example (N : ℕ) [NeZero N] (h : ∀ {L : Type} [Field L] [DecidableEq L] [IsAlgClosed L], (2 : L) ≠ 0
+  →
+    ∀ (W : WeierstrassCurve L) [W.IsElliptic] (Q : W.toAffine.Point),
+      addOrderOf Q = N → (W.fullKernelQuotient Q N).Δ ≠ 0) : ModularCurve.TatePoint.FullKernelDiscAt
+        N := h
+example (N : ℕ) [NeZero N] (h : ModularCurve.TatePoint.FullKernelDiscAt N)
+    {L : Type} [Field L] [DecidableEq L] [IsAlgClosed L]
+    (h2 : (2 : L) ≠ 0) (W : WeierstrassCurve L) [W.IsElliptic] (Q : W.toAffine.Point)
+    (hQ : addOrderOf Q = N) :
+    (W.fullKernelQuotient Q N).Δ ≠ 0 := h h2 W Q hQ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CycSubRootBridgeOdd.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CycSubRootBridgeOdd.lean
new file mode 100644
index 0000000000..f7bc800e59
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_CycSubRootBridgeOdd.lean
@@ -0,0 +1,149 @@
+/-
+Based on Prove2Me node ModularCurve_CycSubRootBridgeOdd
+(9884d616-9c9a-5da3-a3e1-055dff993d49) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CycSubRootBridge
+
+/-!
+# Odd level: roots of the modular polynomial versus cyclic subgroups
+
+Definition: `ModularCurve_CycSubRootBridgeOdd` (`9884d616-9c9a-5da3-a3e1-055dff993d49`), by Claude,
+2026-09-05.
+
+The standing setting is the field $H$ of Hahn series with exponents in $\mathbb{Q}$ and coefficients
+in $\overline{\mathbb{Q}}$, which is here treated as an algebraically closed field of characteristic
+zero. For a Weierstrass curve $E$ over $H$ with invertible discriminant, a natural number $N \neq 0$
+that is odd, and $G$ an element of `CycSubH E N` — that is, a subgroup of $E(H)$ together with the
+property that it is the set of integer multiples of some point of additive order exactly $N$ — the
+module forms the Vélu quotient of $E$ by `cycSubSummingSet E G`, the finite set of coordinate pairs
+of $g, 2g, \dots, \tfrac{N-1}{2}g$ for the chosen generator $g$. The first theorem records that this
+quotient again has invertible discriminant; `cycSubRootOdd` then sends $G$ to the $j$-invariant of
+that quotient, regarded as an element of `RootsAt data E.j`, the roots in $H$ of the one-variable
+polynomial obtained from $\Phi$ of a `ModularPolynomialData N` (a monic $\Phi \in \mathbb{Z}[X][Y]$
+of $Y$-degree $\psi(N) = \sum_{d \mid N,\ d \text{ squarefree}} N/d$ vanishing on the pair $(j(q),
+j(q^N))$) by evaluating the coefficient polynomials at $j(E)$. Under the hypothesis that $j(E)$ is
+transcendental over $\overline{\mathbb{Q}}$, this map is injective, and bijective by comparing
+$\#\,$`CycSubH E N` $= \psi(N)$ with the bound $\#\,$`RootsAt` $\le \psi(N)$; `rootsEquivCycSubHOdd`
+is the resulting equivalence, taken in the direction roots $\to$ subgroups, with lemmas identifying
+its inverse and rewriting `e r = G` as `r = cycSubRootOdd … G`. Finally `dictOdd` specialises this
+to the curve `nearCurve j₀` of $j$-invariant $j_0 + s$, whose transcendence is available. The
+earlier version of these results assumes $N$ an odd prime; the present ones only that $N$ is odd and
+nonzero.
+
+**Relation to Mathlib.** Mathlib supplies `WeierstrassCurve`, `IsElliptic` and the $j$-invariant;
+the Vélu quotient curve, odd summing sets, the type of cyclic subgroups of prescribed order, modular
+polynomial data and the Dedekind $\psi$ used here are the project's own definitions.
+
+**Where it is used.** These equivalences are the moduli-theoretic reading of the modular polynomial:
+at a transcendental $j$-invariant, its roots correspond to the cyclic subgroups of order $N$ of the
+curve, as required by the `ModuliDictionary` predicate used in the construction of the modular
+curves entering the modularity argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open ModularCurve WeierstrassCurve Polynomial
+open scoped Classical
+
+namespace ModularCurve.TatePoint
+
+attribute [local instance] isAlgClosed_H charZero_H
+
+theorem two_mul_pred_div_two_add_one_of_odd {N : ℕ} (hN : Odd N) : 2 * ((N - 1) / 2) + 1 = N := by
+  obtain ⟨m, rfl⟩ := hN
+  omega
+
+theorem isElliptic_veluQuotient_cycSubSummingSet_of_odd (E : WeierstrassCurve H) [E.IsElliptic]
+    {N : ℕ}
+    (hN : Odd N) (G : CycSubH E N) :
+    (E.veluQuotient (cycSubSummingSet E G)).IsElliptic :=
+  ⟨isUnit_iff_ne_zero.mpr
+    (WeierstrassCurve.veluQuotient_oddOrderSummingSet_discriminant_ne_zero (L := H) two_ne_zero E
+      ((N - 1) / 2) (cycSubGen E G)
+      (by rw [addOrderOf_cycSubGen, two_mul_pred_div_two_add_one_of_odd hN]))⟩
+
+def cycSubRootOdd (E : WeierstrassCurve H) [E.IsElliptic] {N : ℕ} [NeZero N] (hN : Odd N)
+    (data : ModularPolynomialData N) (G : CycSubH E N) : RootsAt data E.j :=
+  ⟨@WeierstrassCurve.j H _ (E.veluQuotient (cycSubSummingSet E G))
+      (isElliptic_veluQuotient_cycSubSummingSet_of_odd E hN G),
+    isRoot_map_j_veluQuotient_j_of_eq E ((N - 1) / 2) (two_mul_pred_div_two_add_one_of_odd hN) data
+      (cycSubGen E G) (addOrderOf_cycSubGen E G)
+      (isElliptic_veluQuotient_cycSubSummingSet_of_odd E hN G).isUnit.ne_zero⟩
+
+theorem cycSubRootOdd_coe (E : WeierstrassCurve H) [E.IsElliptic] {N : ℕ} [NeZero N] (hN : Odd N)
+    (data : ModularPolynomialData N) (G : CycSubH E N) :
+    (cycSubRootOdd E hN data G).1 =
+      @WeierstrassCurve.j H _ (E.veluQuotient (cycSubSummingSet E G))
+        (isElliptic_veluQuotient_cycSubSummingSet_of_odd E hN G) := rfl
+
+theorem cycSubRootOdd_injective (E : WeierstrassCurve H) [E.IsElliptic] {N : ℕ} [NeZero N]
+    (hN : Odd N)
+    (data : ModularPolynomialData N) (hj : Transcendental Qbar E.j) :
+    Function.Injective (cycSubRootOdd E hN data) := by
+  intro G G' h
+  have hjj := congrArg Subtype.val h
+  simp only [cycSubRootOdd_coe] at hjj
+  apply CycSubH.ext
+  rw [coe_eq_zmultiples_cycSubGen, coe_eq_zmultiples_cycSubGen]
+  exact WeierstrassCurve.zmultiples_eq_of_veluQuotient_j_eq_of_transcendental E
+    (transcendental_rat_of_transcendental_qbar hj) ((N - 1) / 2) (cycSubGen E G) (cycSubGen E G')
+    (by rw [addOrderOf_cycSubGen, two_mul_pred_div_two_add_one_of_odd hN])
+    (by rw [addOrderOf_cycSubGen, two_mul_pred_div_two_add_one_of_odd hN])
+    (isElliptic_veluQuotient_cycSubSummingSet_of_odd E hN G).isUnit.ne_zero
+    (isElliptic_veluQuotient_cycSubSummingSet_of_odd E hN G').isUnit.ne_zero hjj
+
+theorem cycSubRootOdd_bijective (E : WeierstrassCurve H) [E.IsElliptic] {N : ℕ} [NeZero N]
+    (hN : Odd N)
+    (data : ModularPolynomialData N) (hj : Transcendental Qbar E.j) :
+    Function.Bijective (cycSubRootOdd E hN data) := by
+  have := finite_rootsAt data E.j
+  refine (cycSubRootOdd_injective E hN data hj).bijective_of_nat_card_le ?_
+  rw [natCard_cycSubH]
+  exact natCard_rootsAt_le data E.j
+
+def rootsEquivCycSubHOdd (E : WeierstrassCurve H) [E.IsElliptic] {N : ℕ} [NeZero N] (hN : Odd N)
+    (data : ModularPolynomialData N) (hj : Transcendental Qbar E.j)
+    : RootsAt data E.j ≃ CycSubH E N :=
+  (Equiv.ofBijective (cycSubRootOdd E hN data) (cycSubRootOdd_bijective E hN data hj)).symm
+
+theorem rootsEquivCycSubHOdd_symm_apply (E : WeierstrassCurve H) [E.IsElliptic] {N : ℕ} [NeZero N]
+    (hN : Odd N) (data : ModularPolynomialData N) (hj : Transcendental Qbar E.j) (G : CycSubH E N) :
+    (rootsEquivCycSubHOdd E hN data hj).symm G = cycSubRootOdd E hN data G := rfl
+
+theorem rootsEquivCycSubHOdd_apply_eq_iff (E : WeierstrassCurve H) [E.IsElliptic] {N : ℕ} [NeZero N]
+    (hN : Odd N) (data : ModularPolynomialData N) (hj : Transcendental Qbar E.j)
+    (r : RootsAt data E.j)
+    (G : CycSubH E N) :
+    rootsEquivCycSubHOdd E hN data hj r = G ↔ r = cycSubRootOdd E hN data G := by
+  rw [← rootsEquivCycSubHOdd_symm_apply E hN data hj G, Equiv.eq_symm_apply]
+
+def dictOdd (N : ℕ) [NeZero N] (hN : Odd N) (data : ModularPolynomialData N) (j₀ : Qbar) :
+    RootsAt data (nearCurve j₀).j ≃ CycSubH (nearCurve j₀) N :=
+  rootsEquivCycSubHOdd (nearCurve j₀) hN data (nearCurve_j_transcendental j₀)
+
+theorem dictOdd_symm_apply_coe (N : ℕ) [NeZero N] (hN : Odd N) (data : ModularPolynomialData N)
+    (j₀ : Qbar) (G : CycSubH (nearCurve j₀) N) :
+    ((dictOdd N hN data j₀).symm G).1 =
+      @WeierstrassCurve.j H _ ((nearCurve j₀).veluQuotient (cycSubSummingSet (nearCurve j₀) G))
+        (isElliptic_veluQuotient_cycSubSummingSet_of_odd (nearCurve j₀) hN G) := rfl
+
+theorem dictOdd_apply_eq_iff (N : ℕ) [NeZero N] (hN : Odd N) (data : ModularPolynomialData N)
+    (j₀ : Qbar) (r : RootsAt data (nearCurve j₀).j) (G : CycSubH (nearCurve j₀) N) :
+    dictOdd N hN data j₀ r = G ↔ r = cycSubRootOdd (nearCurve j₀) hN data G :=
+  rootsEquivCycSubHOdd_apply_eq_iff (nearCurve j₀) hN data (nearCurve_j_transcendental j₀) r G
+
+end ModularCurve.TatePoint
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_DegeneracyTower.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_DegeneracyTower.lean
new file mode 100644
index 0000000000..a18e1111a6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_DegeneracyTower.lean
@@ -0,0 +1,196 @@
+/-
+Based on Prove2Me node ModularCurve_DegeneracyTower
+(9317ce16-a703-5d04-b728-c5616cebf92c) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_HeckeOperator
+
+/-!
+# Degeneracy maps at arbitrary level and Hecke exchange identity
+
+Definition: `ModularCurve_DegeneracyTower` (`9317ce16-a703-5d04-b728-c5616cebf92c`), by Claude,
+2026-09-05.
+
+Throughout, $L$ is a field of characteristic zero containing $\mathbb{Q}$, and for a positive
+integer $N$ the field $L\cdot F_N$ denotes `laurentBaseChange L (modularFunctionFieldFull N)`, the
+intermediate field of $L((q))$ generated over $L$ by the coefficientwise image of
+`modularFunctionFieldFull N`, which is itself the subfield of $\mathbb{Q}((q))$ generated over
+$\mathbb{Q}$ by the series $\mathrm{qExpand}\,d\,(j)$ for all nonzero divisors $d \mid N$
+(substitution $q \mapsto q^{d}$ in the $q$-expansion of $j$). Two families of $L$-algebra maps are
+defined for an arbitrary target level, constrained only by a divisibility hypothesis, so that
+composites of Hecke maps become single maps between fixed types: `towerInclBar L (h : N ∣ M)`, the
+inclusion $L\cdot F_N \hookrightarrow L\cdot F_M$ which is the identity on underlying Laurent
+series; and `towerSubstBar L N ℓ (h : N*ℓ ∣ M)`, the composite of `heckeBetaBar L N ℓ` with such an
+inclusion, acting on underlying series as $\mathrm{qExpand}\,\ell$, i.e. $q \mapsto q^{\ell}$.
+Accompanying lemmas record the values on underlying series, invariance under replacing $\ell$ by an
+equal natural number, transitivity and reflexivity of the inclusions, the identifications of
+`heckeAlphaBar` and `heckeBetaBar` as instances of the two families at target level $N\ell$, the
+four composition rules with `heckeAlphaBar` and `heckeBetaBar` (including
+$\mathrm{subst}_{\ell}\circ\beta_{\ell'} = \mathrm{subst}_{\ell\ell'}$), and the resulting commuting
+square `heckeSquareBar_commutes`.
+
+For $M = N\ell\ell'$, `dvd_of_eq_roof` supplies the divisibilities $N\ell \mid M$ and $N\ell'\ell
+\mid M$. The predicate `HeckeExchangeAt L N ℓ ℓ' M hM` is a named input: assuming
+`HasPrincipalDivisors` at levels $N\ell$ and $M$ and integrality of the four maps $\beta_{\ell}$,
+$\alpha_{\ell'}$, $u =$ `towerInclBar` into level $M$ and $u' =$ `towerSubstBar L (N*ℓ') ℓ`, it
+asserts that for every divisor $D$ on $L\cdot F_{N\ell'}$ one has
+$\beta_{\ell}^{*}\big((\alpha_{\ell'})_{*}D\big) = u_{*}\big(u'^{*}D\big)$ in the divisor group of
+$L\cdot F_{N\ell}$, the pullbacks and pushforwards being those along algebra maps from the
+correspondence module.
+
+**Relation to Mathlib.** Modular function fields, their degeneracy maps and the divisor-level
+exchange identity are the project's own notions; only the underlying machinery
+(`IntermediateField.inclusion`, Laurent series, integrality of ring maps) is Mathlib's.
+
+**Where it is used.** These maps are the two degeneracy embeddings underlying the Hecke
+correspondences on the Jacobian $J_0(N)$, realised here as the degree-zero divisor class group of
+the base-changed modular function field; stating them with an arbitrary target level lets composites
+such as $T_{\ell}T_{\ell'}$ be formed inside one fixed field at the roof level $N\ell\ell'$. The
+exchange identity `HeckeExchangeAt` is the divisor-level input from which commutativity of the Hecke
+operators, and hence the Hecke module structure on the Jacobian used in the modularity argument, is
+derived.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+namespace ModularCurve
+
+open AlgebraicCurve
+
+section PrivateSupply
+
+variable (L : Type*) [Field L] [Algebra ℚ L]
+
+private theorem laurentBaseChange_mono'' {F₀ F₁ : IntermediateField ℚ (LaurentSeries ℚ)}
+    (h : F₀ ≤ F₁) : laurentBaseChange L F₀ ≤ laurentBaseChange L F₁ := by
+  rw [laurentBaseChange, IntermediateField.adjoin_le_iff]
+  rintro _ ⟨y, hy, rfl⟩
+  exact coeffEmb_mem_laurentBaseChange L (h hy)
+
+end PrivateSupply
+
+section TowerMaps
+
+variable (L : Type*) [Field L] [Algebra ℚ L] {N M : ℕ} [NeZero N] [NeZero M]
+
+def towerInclBar (h : N ∣ M) :
+    laurentBaseChange L (modularFunctionFieldFull N) →ₐ[L]
+      laurentBaseChange L (modularFunctionFieldFull M) :=
+  IntermediateField.inclusion (by exact laurentBaseChange_mono'' L (full_degeneracy_le h))
+
+@[simp]
+theorem coe_towerInclBar (h : N ∣ M) (x : laurentBaseChange L (modularFunctionFieldFull N)) :
+    (towerInclBar L h x : LaurentSeries L) = (x : LaurentSeries L) :=
+  IntermediateField.coe_inclusion _ x
+
+theorem towerInclBar_eq_inclusion (h : N ∣ M)
+    (h' : laurentBaseChange L (modularFunctionFieldFull N) ≤
+      laurentBaseChange L (modularFunctionFieldFull M)) :
+    towerInclBar L h = IntermediateField.inclusion h' :=
+  rfl
+
+theorem towerInclBar_comp_towerInclBar {M' : ℕ} [NeZero M'] (h₁ : N ∣ M') (h₂ : M' ∣ M)
+    (h : N ∣ M) : (towerInclBar L h₂).comp (towerInclBar L h₁) = towerInclBar L h := by
+  refine AlgHom.ext fun x => Subtype.ext ?_
+  rw [AlgHom.comp_apply, coe_towerInclBar, coe_towerInclBar, coe_towerInclBar]
+
+theorem towerInclBar_self (h : N ∣ N) (x : laurentBaseChange L (modularFunctionFieldFull N)) :
+    towerInclBar L h x = x :=
+  Subtype.ext (coe_towerInclBar L h x)
+
+variable (N) in
+def towerSubstBar (ℓ : ℕ) [NeZero ℓ] (h : N * ℓ ∣ M) :
+    laurentBaseChange L (modularFunctionFieldFull N) →ₐ[L]
+      laurentBaseChange L (modularFunctionFieldFull M) :=
+  (towerInclBar L h).comp (heckeBetaBar L N ℓ)
+
+@[simp]
+theorem coe_towerSubstBar (ℓ : ℕ) [NeZero ℓ] (h : N * ℓ ∣ M)
+    (x : laurentBaseChange L (modularFunctionFieldFull N)) :
+    (towerSubstBar L N ℓ h x : LaurentSeries L) = qExpand L ℓ (x : LaurentSeries L) :=
+  rfl
+
+theorem towerSubstBar_congr {ℓ ℓ' : ℕ} [NeZero ℓ] [NeZero ℓ'] (hℓ : ℓ = ℓ') (h : N * ℓ ∣ M)
+    (h' : N * ℓ' ∣ M) : towerSubstBar L N ℓ h = towerSubstBar L N ℓ' h' := by
+  subst hℓ
+  rfl
+
+end TowerMaps
+
+section Composites
+
+variable (L : Type*) [Field L] [Algebra ℚ L] {N M : ℕ} [NeZero N] [NeZero M] (ℓ ℓ' : ℕ)
+  [NeZero ℓ] [NeZero ℓ']
+
+theorem heckeAlphaBar_eq_towerInclBar : heckeAlphaBar L N ℓ = towerInclBar L (dvd_mul_right N ℓ) :=
+  rfl
+
+theorem heckeBetaBar_eq_towerSubstBar : heckeBetaBar L N ℓ = towerSubstBar L N ℓ dvd_rfl := by
+  refine AlgHom.ext fun x => Subtype.ext ?_
+  rw [coe_towerSubstBar, coe_heckeBetaBar]
+
+theorem towerInclBar_comp_heckeAlphaBar (h : N * ℓ ∣ M) (h' : N ∣ M) :
+    (towerInclBar L h).comp (heckeAlphaBar L N ℓ) = towerInclBar L h' := by
+  refine AlgHom.ext fun x => Subtype.ext ?_
+  rw [AlgHom.comp_apply, coe_towerInclBar, coe_heckeAlphaBar, coe_towerInclBar]
+
+theorem towerInclBar_comp_heckeBetaBar (h : N * ℓ ∣ M) :
+    (towerInclBar L h).comp (heckeBetaBar L N ℓ) = towerSubstBar L N ℓ h :=
+  rfl
+
+theorem towerSubstBar_comp_heckeAlphaBar (h : N * ℓ' * ℓ ∣ M) (h' : N * ℓ ∣ M) :
+    (towerSubstBar L (N * ℓ') ℓ h).comp (heckeAlphaBar L N ℓ') = towerSubstBar L N ℓ h' := by
+  refine AlgHom.ext fun x => Subtype.ext ?_
+  rw [AlgHom.comp_apply, coe_towerSubstBar, coe_heckeAlphaBar, coe_towerSubstBar]
+
+theorem towerSubstBar_comp_heckeBetaBar (h : N * ℓ' * ℓ ∣ M) (h' : N * (ℓ * ℓ') ∣ M) :
+    (towerSubstBar L (N * ℓ') ℓ h).comp (heckeBetaBar L N ℓ') = towerSubstBar L N (ℓ * ℓ') h' := by
+  refine AlgHom.ext fun x => Subtype.ext ?_
+  rw [AlgHom.comp_apply, coe_towerSubstBar, coe_heckeBetaBar, coe_towerSubstBar]
+  exact qExpand_qExpand ℓ' ℓ _
+
+theorem heckeSquareBar_commutes (h₁ : N * ℓ ∣ M) (h₂ : N * ℓ' * ℓ ∣ M) :
+    (towerInclBar L h₁).comp (heckeBetaBar L N ℓ) =
+      (towerSubstBar L (N * ℓ') ℓ h₂).comp (heckeAlphaBar L N ℓ') := by
+  rw [towerInclBar_comp_heckeBetaBar, towerSubstBar_comp_heckeAlphaBar]
+
+end Composites
+
+section Exchange
+
+variable (L : Type*) [Field L] [Algebra ℚ L] (N ℓ ℓ' M : ℕ) [NeZero N] [NeZero ℓ] [NeZero ℓ']
+  [NeZero M]
+
+omit [NeZero N] [NeZero ℓ] [NeZero ℓ'] [NeZero M] in
+theorem dvd_of_eq_roof (hM : M = N * ℓ * ℓ') : N * ℓ ∣ M ∧ N * ℓ' * ℓ ∣ M :=
+  ⟨⟨ℓ', hM⟩, ⟨1, by rw [hM]; ring⟩⟩
+
+def HeckeExchangeAt (hM : M = N * ℓ * ℓ') : Prop :=
+  ∀ [HasPrincipalDivisors L (laurentBaseChange L (modularFunctionFieldFull (N * ℓ)))]
+    [HasPrincipalDivisors L (laurentBaseChange L (modularFunctionFieldFull M))]
+    (hβ : (heckeBetaBar L N ℓ).toRingHom.IsIntegral)
+    (hα' : (heckeAlphaBar L N ℓ').toRingHom.IsIntegral)
+    (hu : (towerInclBar L (dvd_of_eq_roof N ℓ ℓ' M hM).1).toRingHom.IsIntegral)
+    (hu' : (towerSubstBar L (N * ℓ') ℓ (dvd_of_eq_roof N ℓ ℓ' M hM).2).toRingHom.IsIntegral)
+    (D : Divisor L (laurentBaseChange L (modularFunctionFieldFull (N * ℓ')))),
+    Divisor.pullbackAlong (heckeBetaBar L N ℓ) hβ
+        (Divisor.pushforwardAlong (heckeAlphaBar L N ℓ') hα' D)
+      = Divisor.pushforwardAlong (towerInclBar L (dvd_of_eq_roof N ℓ ℓ' M hM).1) hu
+          (Divisor.pullbackAlong (towerSubstBar L (N * ℓ') ℓ (dvd_of_eq_roof N ℓ ℓ' M hM).2) hu' D)
+
+end Exchange
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_EMD.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_EMD.lean
new file mode 100644
index 0000000000..ec34240b11
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_EMD.lean
@@ -0,0 +1,111 @@
+/-
+Based on Prove2Me node ModularCurve_EMD
+(2726b0fd-15d6-5aeb-aa2a-624ee5d18508) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ModuliPoint
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_MazurStepThreeInputs
+
+/-!
+# Embedding–moduli dictionary for the modular function field
+
+Definition: `ModularCurve_EMD` (`2726b0fd-15d6-5aeb-aa2a-624ee5d18508`), by Claude, 2026-09-05.
+
+Over a field $L$ with decidable equality, `pairStabCard` attaches to a $\Gamma_0(N)$-pair $P$ (a
+Weierstrass curve `P.toCurve` over $L$ that is elliptic, together with a point `P.gen` of exact
+additive order $N$) the cardinality, as a natural number, of the set of variable changes $\gamma$
+that fix the Weierstrass model, $\gamma \bullet P.\mathrm{toCurve} = P.\mathrm{toCurve}$, and for
+which `P.gen` is heterogeneously equal to $k \bullet$ (the image of `P.gen` under the point
+substitution attached to the inverse of $\gamma$) for some $k$ coprime to $N$; this is the
+stabiliser of $P$ for the relation `Gamma0Pair.Step` generating the moduli-point quotient, not the
+stabiliser of the curve alone. The remaining definitions set up a dictionary between series
+expansions and cyclic subgroups. For $N \neq 0$ and $j_0 \in \overline{\mathbb{Q}}$, `Emb N j₀` is
+the type of $\overline{\mathbb{Q}}$-algebra homomorphisms $\psi$ from `modularFunctionFieldBar N` to
+the Hahn series field $\overline{\mathbb{Q}}$ with rational exponents, normalised by $\psi(\bar{j})
+= j_0 + t$, where $\bar{j}$ is `jBar N`. `Induces ψ w` says that there is a rational $g > 0$ with $g
+\cdot \mathrm{ord}_w(x) = \mathrm{order}(\psi(x))$ for every $x$ in the field, i.e. the leading
+exponent of the series expansion is proportional to the valuation at the place $w$; `SamePlace ψ ψ'`
+asserts that one and the same place is induced by both. On the geometric side, `CycSub E₀ N` is the
+type of additive subgroups of the affine points of $E_0$ that are of the form $\langle g \rangle$
+for some point $g$ of exact order $N$, and `SameOrbit E₀ H H'` says that $H = \langle g \rangle$ and
+$H' = \langle g' \rangle$ for points $g, g'$ with $g'$ heterogeneously equal to the image of $g$
+under the point substitution attached to the inverse of some variable change $\gamma$ preserving
+$E_0$. Finally, `EMD N j₀` is the proposition that there exist a Weierstrass curve $E_0$ over
+$\overline{\mathbb{Q}}$, elliptic, with $j(E_0) = j_0$, and a bijection $\Phi$ from `Emb N j₀` to
+`CycSub E₀ N` transporting `SamePlace` into `SameOrbit`: $\psi$ and $\psi'$ induce a common place
+exactly when $\Phi(\psi)$ and $\Phi(\psi')$ lie in one orbit of the automorphisms of the model.
+
+**Relation to Mathlib.** Mathlib supplies the Weierstrass curves, variable changes and Hahn series
+(with their `order`) used here; the pair stabiliser count, the normalised embeddings, the
+induced-place and same-orbit relations and the dictionary statement `EMD` are the project's own
+notions, formulated for the project's places of a function field and its substitution maps on
+Weierstrass points.
+
+**Where it is used.** These notions express the moduli interpretation of the points of $X_0(N)$ over
+$\overline{\mathbb{Q}}$ in the shape needed in the Mazur part of the argument: places of
+`modularFunctionFieldBar N` lying over a given $j$-value correspond to cyclic subgroups of order $N$
+on a curve with that invariant, up to automorphisms. This is what allows a pair consisting of an
+elliptic curve and a point of order $p$ to be converted into a place of the modular function field
+with prescribed behaviour, the input to the Eisenstein-quotient specialisation argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+namespace ModularCurve
+
+open AlgebraicCurve WeierstrassCurve WeierstrassCurve.Affine
+
+section PairStab
+
+variable {N : ℕ} {L : Type*} [Field L] [DecidableEq L]
+
+noncomputable def pairStabCard (P : Gamma0Pair N L) : ℕ :=
+  Nat.card {γ : VariableChange L // γ • P.toCurve = P.toCurve ∧
+    ∃ k : ℕ, k.Coprime N ∧ HEq P.gen (k • Point.vcInvFun γ P.toCurve.toAffine P.gen)}
+
+end PairStab
+
+def Emb (N : ℕ) [NeZero N] (j₀ : AlgebraicClosure ℚ) : Type :=
+  {ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ] HahnSeries ℚ (AlgebraicClosure ℚ) //
+    ψ (jBar N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)}
+
+def Induces {N : ℕ} [NeZero N]
+    (ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ] HahnSeries ℚ (AlgebraicClosure ℚ))
+    (w : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)) : Prop :=
+  ∃ g : ℚ, 0 < g ∧ ∀ x : ↥(modularFunctionFieldBar N), (w.ord x : ℚ) * g = (ψ x).order
+
+def SamePlace {N : ℕ} [NeZero N]
+    (ψ ψ' : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ] HahnSeries ℚ (AlgebraicClosure ℚ)) :
+    Prop :=
+  ∃ w : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N), Induces ψ w ∧ Induces ψ' w
+
+def CycSub (E₀ : WeierstrassCurve (AlgebraicClosure ℚ)) (N : ℕ) : Type :=
+  {H : AddSubgroup E₀.toAffine.Point //
+    ∃ g : E₀.toAffine.Point, addOrderOf g = N ∧ H = AddSubgroup.zmultiples g}
+
+def SameOrbit (E₀ : WeierstrassCurve (AlgebraicClosure ℚ)) (H H' : AddSubgroup E₀.toAffine.Point) :
+    Prop :=
+  ∃ γ : VariableChange (AlgebraicClosure ℚ), ∃ _ : γ • E₀ = E₀, ∃ g g' : E₀.toAffine.Point,
+    H = AddSubgroup.zmultiples g ∧ H' = AddSubgroup.zmultiples g' ∧
+      HEq g' (Point.vcInvFun γ E₀.toAffine g)
+
+def EMD (N : ℕ) [NeZero N] (j₀ : AlgebraicClosure ℚ) : Prop :=
+  ∃ (E₀ : WeierstrassCurve (AlgebraicClosure ℚ)) (_ : E₀.IsElliptic), E₀.j = j₀ ∧
+    ∃ Φ : Emb N j₀ ≃ CycSub E₀ N, ∀ ψ ψ' : Emb N j₀,
+      SamePlace ψ.1 ψ'.1 ↔ SameOrbit E₀ (Φ ψ).1 (Φ ψ').1
+
+end ModularCurve
+
+end
+
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_EigenformIdeal.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_EigenformIdeal.lean
new file mode 100644
index 0000000000..fdacb6a115
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_EigenformIdeal.lean
@@ -0,0 +1,98 @@
+/-
+Based on Prove2Me node ModularCurve_EigenformIdeal
+(2182c6e0-629a-59cd-b0d3-24713a2ed475) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeGalois_EichlerShimura
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+
+/-!
+# Eigenform ideals of the free Hecke algebra
+
+Definition: `ModularCurve_EigenformIdeal` (`2182c6e0-629a-59cd-b0d3-24713a2ed475`), by Claude,
+2026-09-05.
+
+Throughout, the Hecke algebra is taken to be the free commutative ring `HeckeAlg`
+$=\mathbb{Z}[T_\ell : \ell \text{ prime}]$ (a multivariate polynomial ring indexed by `Nat.Primes`,
+with $T_\ell$ = `heckeGen` $\ell$ the corresponding variable), and for a family of elements $a_\ell$
+of a commutative ring `eigenIdeal a` is the kernel of the evaluation homomorphism $T_\ell \mapsto
+a_\ell$. The first definition, [`ModularCurve.IsEigenformIdeal N
+𝔪`](../def/ModularCurve_EigenformIdeal.html#L10), asserts that an ideal $\mathfrak m \subseteq
+\mathbb{Z}[T_\ell]$ arises from a normalised weight-$2$ eigenform on $\Gamma_0(N)$ reduced to a
+finite field: there exist a cusp form $f$ of weight $2$ for `CongruenceSubgroup.Gamma0 N`, a proof
+that $f$ satisfies [`CuspForm.IsNormalizedEigenform`](../def/FLTPrelim_Modularity.html#L28) (a
+structure whose fields are identities among the $q$-expansion coefficients $a_n(f) =$ `qCoeff f n`:
+$a_1 = 1$, multiplicativity $a_{mn} = a_m a_n$ for coprime $m,n$, the recursion $a_{p^{r+2}} = a_p
+a_{p^{r+1}} - p\,a_{p^r}$ for $p \nmid N$ and $a_{p^{r+2}} = a_p a_{p^{r+1}}$ for $p \mid N$ — so
+the eigenform condition is formulated purely through coefficients, not through Hecke operators), a
+finite field $k$, a subring $\mathcal O \subseteq \mathbb{C}$ containing $a_\ell(f)$ for every prime
+$\ell$, and a ring homomorphism $\varphi : \mathcal O \to k$, such that $\mathfrak m$ is the
+eigenvalue ideal of the system $\ell \mapsto \varphi(a_\ell(f))$. The subring $\mathcal O$ and the
+map $\varphi$ are part of the existential data; no comparison between $\mathbb{Z}[T_\ell]$ and the
+Hecke algebra acting on $S_2(\Gamma_0(N))$ is asserted.
+
+The remaining two declarations instantiate generic predicates with this notion of eigenform ideal.
+`EigenformSupportAt N p J`, for an abelian group $J$ with a `HeckeAlg`-module structure, says: every
+ideal $\mathfrak m$ which is an eigenform ideal of level $N$ and contains $p$ has nonzero $\mathfrak
+m$-torsion in $J$ (the submodule annihilated by all of $\mathfrak m$ is not $\bot$).
+`EichlerShimuraDataAt N p J`, for a field extension $L/K$ and $J$ carrying both a `HeckeAlg`-module
+structure and an action of $L \simeq_{\mathrm{alg}[K]} L$, is the bundled conjunction of three
+clauses: (i) for every prime $\ell \nmid Np$, every valuation subring $A$ of $L$ with $\ell$ a
+nonunit of $A$, every $\sigma$ in the inertia subgroup of $A$ over $K$ and every $p$-power-torsion
+$x \in J$, one has $\sigma \cdot x = x$; (ii) for such $\ell$ and $A$ and every $\sigma$ that is a
+Frobenius at $\ell$ for $A$ (in the decomposition group and inducing $x \mapsto x^\ell$ on the
+residue field), the Eichler–Shimura relation $\sigma^2 x - T_\ell \cdot (\sigma x) + \ell\, x = 0$
+holds for all $p$-power-torsion $x$; (iii) `EigenformSupportAt N p J`. This is the reduced bundle:
+the determinant clause on Frobenius and the multiplicity-one conditions available in the same family
+of definitions are not among its fields.
+
+**Relation to Mathlib.** Mathlib supplies the cusp forms, congruence subgroups and $q$-expansions
+used here, and the valuation-theoretic inertia and decomposition subgroups, but no Hecke operators
+on modular forms and no Hecke algebra: `HeckeAlg` is the project's free polynomial ring on symbols
+$T_\ell$, the eigenform condition is expressed by recursions among $q$-expansion coefficients, and
+[`ValuationSubring.LiesOverPrime`](../def/FLTPrelim_Ramification.html#L16),
+[`ValuationSubring.inertiaSubgroupIn`](../def/FLTPrelim_Ramification.html#L21) and
+[`ValuationSubring.IsFrobeniusAt`](../def/EllipticCurve_FrobeniusTrace.html#L51) are the project's
+own wrappers.
+
+**Where it is used.** These predicates package the input on the modular side of the argument: a
+Galois- and Hecke-module $J$ (in practice $p$-power torsion of a Jacobian) whose $\mathfrak
+m$-torsion for an eigenform ideal $\mathfrak m$ is nonzero and on which Frobenius elements away from
+$Np$ satisfy the Eichler–Shimura quadratic relation, which is what yields the mod $p$ representation
+attached to a weight-$2$ eigenform of level $\Gamma_0(N)$ used in the Frey curve, level-lowering and
+modularity steps.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+namespace ModularCurve
+
+def IsEigenformIdeal (N : ℕ) (𝔪 : Ideal HeckeAlg) : Prop :=
+  ∃ (f : CuspForm (CongruenceSubgroup.Gamma0 N) 2) (_ : f.IsNormalizedEigenform)
+    (k : Type) (_ : Field k) (_ : Finite k) (𝒪 : Subring ℂ)
+    (h𝒪 : ∀ ℓ : Nat.Primes, ModularFormClass.qCoeff f ℓ ∈ 𝒪) (φ : 𝒪 →+* k),
+      𝔪 = eigenIdeal (fun ℓ => φ ⟨ModularFormClass.qCoeff f ℓ, h𝒪 ℓ⟩)
+
+abbrev EigenformSupportAt (N p : ℕ) (J : Type*) [AddCommGroup J] [Module HeckeAlg J] : Prop :=
+  EigenformSupport p J (IsEigenformIdeal N)
+
+abbrev EichlerShimuraDataAt {K L : Type*} [Field K] [Field L] [Algebra K L] (N p : ℕ)
+    (J : Type*) [AddCommGroup J] [Module HeckeAlg J] [DistribMulAction (L ≃ₐ[K] L) J] :
+    Prop :=
+  EichlerShimuraDataReduced (K := K) (L := L) N p J (IsEigenformIdeal N)
+
+end ModularCurve
+
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_Eisenstein.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_Eisenstein.lean
new file mode 100644
index 0000000000..5ffcc4e41d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_Eisenstein.lean
@@ -0,0 +1,99 @@
+/-
+Based on Prove2Me node ModularCurve_Eisenstein
+(3999c6f9-f2ee-565f-9468-daa9d32b7c51) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeGalois_EichlerShimura
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_HeckeOperator
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CuspidalClass
+
+/-!
+# Named Eisenstein-ideal and cuspidal-class hypotheses on J0​(p)
+
+Definition: `ModularCurve_Eisenstein` (`3999c6f9-f2ee-565f-9468-daa9d32b7c51`), by Claude,
+2026-09-05.
+
+Four predicates (`def … : Prop`) in namespace `ModularCurve` that instantiate the generic
+Eisenstein/Hecke calculus of the project's `HeckeGalois_EichlerShimura` layer at the concrete
+carriers `JZero p`, `eisensteinIdeal p`, `heckePic0Bar` and `cuspidalClass p`. Each takes `p : ℕ`
+with only `[NeZero p]` (primality and size conditions are left to consuming theorems), and the
+first, second and fourth take an explicit binder `inst : Module HeckeAlg (JZero p)`, installed
+locally by `letI`, since no ambient Hecke-module structure on `JZero p` is assumed at this point.
+`EisensteinQuotientInvariantsFiniteAt p inst` is the project's generic predicate
+`EisensteinQuotientInvariantsFinite` applied with group $G$ the automorphism group $\bar{\mathbb
+Q}\simeq_{\mathbb Q}\bar{\mathbb Q}$, module `JZero p` and ideal `eisensteinIdeal p`; its intended
+reading is finiteness of the Galois invariants of the Eisenstein quotient, but what the Prop asserts
+is exactly the unfolding of that project notion, and no commutation of the Hecke action with $G$ is
+required by the binders. `SpecializationSlot p q inst` is the project's `SpecializationExists` at
+$K=\mathbb Q$, $L=\bar{\mathbb Q}$, the pair $(p,q)$ and the module `JZero p`.
+`HeckeKillsCuspidalClass p ℓ hα hβ hFI hfin hN` carries, in order, the inputs demanded by
+`heckePic0Bar`: integrality hypotheses `HeckeAlphaBarIntegral`/`HeckeBetaBarIntegral` for the two
+Hecke correspondence maps at level $p\ell$, a `HasPrincipalDivisors` instance for
+`modularFunctionFieldBar (p * ℓ)`, a fundamental identity `FundamentalIdentityAlong`, finiteness
+`FiniteAlong` and a norm formula `NormFormulaAlong`; its conclusion is the pointwise equation
+$\mathrm{heckePic0Bar}(\text{cuspidalClass } p) - (1+\ell)\cdot\text{cuspidalClass } p = 0$, i.e.
+$T_\ell$ acts on the cuspidal class by $1+\ell$, written as a subtraction rather than as an operator
+$T_\ell-(1+\ell)$. `EisensteinKernelKillsCuspidalClass p inst` says every $t$ in `eisensteinKernel
+(JZero p) (eisensteinIdeal p)` satisfies $t\cdot\text{cuspidalClass } p = 0$. None of the four is a
+theorem here: the module proves nothing about $X_0(N)$ and states nothing about the order of the
+cuspidal class.
+
+**Relation to Mathlib.** Mathlib has no Eisenstein ideal, cuspidal class or Hecke action on
+$J_0(p)$; all notions named here, including `JZero`, `eisensteinIdeal`, `eisensteinKernel`,
+`heckePic0Bar`, `cuspidalClass` and the generic
+`EisensteinQuotientInvariantsFinite`/`SpecializationExists` predicates, are the project's own.
+
+**Where it is used.** These named hypotheses form the interface through which the Mazur-style input
+on $J_0(p)$ — finiteness of the Galois invariants of the Eisenstein quotient, specialisation of
+$J_0(p)$ at an auxiliary prime, and the annihilation of the cuspidal class by $T_\ell-(1+\ell)$ and
+by the Eisenstein kernel — is supplied to the statement modules that depend on it; eleven downstream
+modules import them.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+namespace ModularCurve
+
+open AlgebraicCurve
+
+def EisensteinQuotientInvariantsFiniteAt (p : ℕ) [NeZero p]
+    (inst : Module HeckeAlg (JZero p)) : Prop :=
+  letI := inst
+  EisensteinQuotientInvariantsFinite
+    (G := AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) (JZero p) (eisensteinIdeal p)
+
+def SpecializationSlot (p q : ℕ) [NeZero p] (inst : Module HeckeAlg (JZero p)) : Prop :=
+  letI := inst
+  SpecializationExists (K := ℚ) (L := AlgebraicClosure ℚ) p q (JZero p)
+
+def HeckeKillsCuspidalClass (p ℓ : ℕ) [NeZero p] [NeZero ℓ]
+    (hα : HeckeAlphaBarIntegral (AlgebraicClosure ℚ) p ℓ)
+    (hβ : HeckeBetaBarIntegral (AlgebraicClosure ℚ) p ℓ)
+    [HasPrincipalDivisors (AlgebraicClosure ℚ) (modularFunctionFieldBar (p * ℓ))]
+    (hFI : FundamentalIdentityAlong (AlgebraicClosure ℚ)
+      (heckeBetaBar (AlgebraicClosure ℚ) p ℓ) hβ)
+    (hfin : FiniteAlong (AlgebraicClosure ℚ) (heckeAlphaBar (AlgebraicClosure ℚ) p ℓ))
+    (hN : NormFormulaAlong (AlgebraicClosure ℚ)
+      (heckeAlphaBar (AlgebraicClosure ℚ) p ℓ) hfin) : Prop :=
+  heckePic0Bar hα hβ hFI hfin hN (cuspidalClass p) - (1 + ℓ : ℤ) • cuspidalClass p = 0
+
+def EisensteinKernelKillsCuspidalClass (p : ℕ) [NeZero p]
+    (inst : Module HeckeAlg (JZero p)) : Prop :=
+  letI := inst
+  ∀ t ∈ eisensteinKernel (JZero p) (eisensteinIdeal p), t • cuspidalClass p = 0
+
+end ModularCurve
+
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_FibrePoly.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_FibrePoly.lean
new file mode 100644
index 0000000000..46f6832a17
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_FibrePoly.lean
@@ -0,0 +1,114 @@
+/-
+Based on Prove2Me node ModularCurve_FibrePoly
+(fd80fd74-7404-5f35-9983-7260f6a340c0) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_KroneckerTransport
+
+/-!
+# Fibre polynomials of a bivariate modular polynomial
+
+Definition: `ModularCurve_FibrePoly` (`fd80fd74-7404-5f35-9983-7260f6a340c0`), by Claude,
+2026-09-05.
+
+Throughout, $k$ is a field, $\ell$ a prime and $k$ has characteristic $\ell$; bivariate polynomials
+are taken in the iterated form $\mathbb{Z}[X][Y]$, with $X$ the inner and $Y$ the outer variable.
+
+For $\Phi \in \mathbb{Z}[X][Y]$ and $a \in k$, `fibrePoly` $\Phi\,a$ is the univariate polynomial
+$\Phi(a, Y) \in k[Y]$ obtained by applying to each coefficient of $\Phi$ the ring homomorphism
+$\mathbb{Z}[X] \to k$ that casts integer coefficients into $k$ and sends $X \mapsto a$. Thus the
+inner variable is specialised at $a$ and the outer variable is kept; the roots of `fibrePoly`
+$\Phi\,a$, with multiplicity, are the fibre over $a$ of the correspondence cut out by $\Phi$.
+
+Two identities record that this specialisation factors through reduction modulo $\ell$. First,
+`eval₂RingHom_intCast_eq_comp` states that the homomorphism $\mathbb{Z}[X] \to k$ just described
+equals coefficientwise reduction $\mathbb{Z}[X] \to \mathbb{F}_\ell[X]$ followed by evaluation at
+$a$ along the canonical map $\mathbb{F}_\ell \to k$ (`ZMod.castHom`). Consequently,
+`fibrePoly_eq_map_reduceModBivar` gives $\Phi(a,Y) = \bar{\Phi}(a,Y)$, where $\bar{\Phi} =$
+`reduceModBivar` $\ell\,\Phi$ is the coefficientwise reduction of $\Phi$ to $\mathbb{F}_\ell[X][Y]$:
+the fibre polynomial only depends on $\Phi \bmod \ell$. This is what allows a congruence for $\Phi$
+modulo $\ell$, such as the Kronecker congruence $\bar{\Phi} = (X^\ell - Y)(X - Y^\ell)$ encoded by
+`KroneckerCongruence`, to be used fibre by fibre.
+
+Finally, `C_sub_X_pow_eq_neg_pow` assumes in addition that $k$ is perfect of characteristic $\ell$
+and asserts, for $a \in k$, the identity $a - Y^{\ell} = -\bigl(Y - a^{1/\ell}\bigr)^{\ell}$ in
+$k[Y]$, where $a^{1/\ell}$ is the image of $a$ under the inverse of the Frobenius bijection. It
+exhibits the second Kronecker factor, specialised at $a$, as $\ell$ times the point $a^{1/\ell}$ up
+to sign.
+
+**Relation to Mathlib.** Mathlib supplies the ingredients (`Polynomial.map`,
+`Polynomial.eval₂RingHom`, `ZMod.castHom`, the freshman's dream `sub_pow_expChar`, and
+`frobeniusEquiv` for perfect rings); the specialisation operator `fibrePoly` on bivariate integral
+polynomials is the project's own packaging.
+
+**Where it is used.** These are the bridge between a congruence modulo $\ell$ for a modular
+polynomial, in the shape of the Kronecker congruence $\Phi \equiv (X^{\ell} - Y)(X - Y^{\ell})$, and
+the geometry of the fibres of the associated correspondence over a field of characteristic $\ell$.
+They are used in the analysis of the special fibre at $\ell$, where the two Kronecker factors give
+the Frobenius and Verschiebung parts of the Hecke correspondence, towards the Eichler–Shimura
+congruence relation that governs the Galois representations attached to modular forms.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open Polynomial
+
+namespace ModularCurve
+
+section FibrePoly
+
+variable {k : Type*} [Field k]
+
+def fibrePoly (Φ : Polynomial (Polynomial ℤ)) (a : k) : Polynomial k :=
+  Φ.map (Polynomial.eval₂RingHom (Int.castRingHom k) a)
+
+variable {ℓ : ℕ} [Fact ℓ.Prime] [CharP k ℓ]
+
+theorem eval₂RingHom_intCast_eq_comp (a : k) :
+    Polynomial.eval₂RingHom (Int.castRingHom k) a =
+      (Polynomial.eval₂RingHom (ZMod.castHom (dvd_refl ℓ) k) a).comp
+        (Polynomial.mapRingHom (Int.castRingHom (ZMod ℓ))) := by
+  refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+  rw [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X, RingHom.comp_apply,
+    Polynomial.coe_mapRingHom, Polynomial.map_X, Polynomial.coe_eval₂RingHom,
+    Polynomial.eval₂_X]
+
+theorem fibrePoly_eq_map_reduceModBivar (Φ : Polynomial (Polynomial ℤ)) (a : k) :
+    fibrePoly Φ a =
+      (reduceModBivar ℓ Φ).map
+        (Polynomial.eval₂RingHom (ZMod.castHom (dvd_refl ℓ) k) a) := by
+  rw [fibrePoly, eval₂RingHom_intCast_eq_comp (ℓ := ℓ),
+    show reduceModBivar ℓ Φ
+      = Φ.map (Polynomial.mapRingHom (Int.castRingHom (ZMod ℓ))) from rfl,
+    Polynomial.map_map]
+
+end FibrePoly
+
+section Factorization
+
+variable {k : Type*} [Field k] {ℓ : ℕ} [Fact ℓ.Prime] [CharP k ℓ] [PerfectRing k ℓ]
+
+theorem C_sub_X_pow_eq_neg_pow (a : k) :
+    Polynomial.C a - Polynomial.X ^ ℓ =
+      -((Polynomial.X - Polynomial.C ((frobeniusEquiv k ℓ).symm a)) ^ ℓ) := by
+  have hpoly : (Polynomial.X - Polynomial.C ((frobeniusEquiv k ℓ).symm a)) ^ ℓ =
+      Polynomial.X ^ ℓ - Polynomial.C ((frobeniusEquiv k ℓ).symm a) ^ ℓ :=
+    sub_pow_expChar _ _
+  rw [hpoly, ← Polynomial.C_pow, frobeniusEquiv_symm_pow_p, neg_sub]
+
+end Factorization
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_GenusNumerics.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_GenusNumerics.lean
new file mode 100644
index 0000000000..432c26e6a3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_GenusNumerics.lean
@@ -0,0 +1,81 @@
+/-
+Based on Prove2Me node ModularCurve_GenusNumerics
+(d362fb70-1fb8-5c19-baf5-2f61f99a0836) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.LegendreSymbol.Basic
+public import Mathlib.FieldTheory.Finite.Basic
+public import Mathlib.Data.Nat.Totient
+public import Mathlib.NumberTheory.Divisors
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+/-!
+# Elliptic point counts, cusp count and genus formula for X0​(N)
+
+Definition: `ModularCurve_GenusNumerics` (`d362fb70-1fb8-5c19-baf5-2f61f99a0836`), by Claude,
+2026-09-05.
+
+Four arithmetic functions of a natural number $N$ are introduced, together with one evaluation
+lemma.
+
+[`ModularCurve.nuTwo N`](../def/ModularCurve_GenusNumerics.html#L9) is the cardinality (as a
+`Nat.card`) of the subtype of $\mathbb{Z}/N$ consisting of those $x$ with $x^2+1=0$, and
+[`ModularCurve.nuThree N`](../def/ModularCurve_GenusNumerics.html#L11) is the cardinality of the
+subtype of $\mathbb{Z}/N$ consisting of those $x$ with $x^2+x+1=0$; classically these are the
+numbers of elliptic points of order $2$ and of order $3$ on $X_0(N)$. [`ModularCurve.cuspCount
+N`](../def/ModularCurve_GenusNumerics.html#L13) is defined as the finite sum $\sum_{d \mid N}
+\varphi\bigl(\gcd(d, N/d)\bigr)$ over the divisors of $N$, with $\varphi$ Euler's totient;
+[`ModularCurve.cuspCount_one`](../def/ModularCurve_GenusNumerics.html#L17) records that this equals
+$1$ for $N = 1$.
+
+[`ModularCurve.genusFormula N`](../def/ModularCurve_GenusNumerics.html#L20) is the rational number
+$$1 + \frac{\psi(N)}{12} - \frac{\nu_2(N)}{4} - \frac{\nu_3(N)}{3} - \frac{\nu_\infty(N)}{2},$$
+where $\nu_2, \nu_3, \nu_\infty$ are `nuTwo`, `nuThree`, `cuspCount` and $\psi(N)$ is
+[`ModularCurve.dedekindPsi N`](../def/ModularCurve_X0.html#L201), itself defined as the sum $\sum_{d
+\mid N,\ d \text{ squarefree}} N/d$, i.e. $N \prod_{p \mid N}(1 + 1/p)$, the index of $\Gamma_0(N)$
+in $\mathrm{SL}_2(\mathbb{Z})$.
+
+Thus `genusFormula` is a purely arithmetic expression in $N$, taking values in $\mathbb{Q}$; it is
+defined as the right-hand side of the classical Riemann–Hurwitz computation for the covering $X_0(N)
+\to X(1)$, and no integrality assertion, nor any identification with the genus of a curve, is part
+of the definitions themselves.
+
+**Relation to Mathlib.** Mathlib supplies the ingredients used here (`ZMod`, `Nat.divisors`,
+`Nat.totient`, `Nat.card`) but has no counts of elliptic points or cusps for $\Gamma_0(N)$ and no
+genus formula for $X_0(N)$; these functions, like
+[`ModularCurve.dedekindPsi`](../def/ModularCurve_X0.html#L201), are the project's own.
+
+**Where it is used.** These four functions are the numerical inputs to the genus and ramification
+computations for the modular curves $X_0(N)$ used throughout the project's treatment of $X_0(N)$, in
+particular for the small levels occurring after level lowering.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace ModularCurve
+
+noncomputable def nuTwo (N : ℕ) : ℕ := Nat.card {x : ZMod N // x ^ 2 + 1 = 0}
+
+noncomputable def nuThree (N : ℕ) : ℕ := Nat.card {x : ZMod N // x ^ 2 + x + 1 = 0}
+
+def cuspCount (N : ℕ) : ℕ :=
+  ∑ d ∈ N.divisors, Nat.totient (Nat.gcd d (N / d))
+
+@[simp]
+lemma cuspCount_one : cuspCount 1 = 1 := by
+  simp [cuspCount]
+
+noncomputable def genusFormula (N : ℕ) : ℚ :=
+  1 + (dedekindPsi N : ℚ) / 12 - (nuTwo N : ℚ) / 4 - (nuThree N : ℚ) / 3
+    - (cuspCount N : ℚ) / 2
+
+end ModularCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_GeometricBaseChange.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_GeometricBaseChange.lean
new file mode 100644
index 0000000000..4d3d848031
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_GeometricBaseChange.lean
@@ -0,0 +1,285 @@
+/-
+Based on Prove2Me node ModularCurve_GeometricBaseChange
+(74453c60-4a12-5ad9-801e-e55560e759df) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Algebra.Hom.Rat
+public import Mathlib.Algebra.Module.LinearMap.Rat
+public import Mathlib.FieldTheory.LinearDisjoint
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+
+/-!
+# Geometric base change of subfields of Q((q))
+
+Definition: `ModularCurve_GeometricBaseChange` (`74453c60-4a12-5ad9-801e-e55560e759df`), by Claude,
+2026-09-05.
+
+Fix a field $L$ with a $\mathbb{Q}$-algebra structure and an intermediate field $F_0$ of
+$\mathbb{Q}((q))/\mathbb{Q}$. Writing `coeffEmb L` for the project's coefficientwise embedding
+$\mathbb{Q}((q)) \hookrightarrow L((q))$ and `laurentBaseChange L F₀` for the intermediate field of
+$L((q))/L$ obtained by adjoining the image of $F_0$ to $L$ (both from the imported
+Laurent-coefficient module), the module constructs the comparison map between $L
+\otimes_{\mathbb{Q}} F_0$ and this compositum. First, `linearIndependent_coeffEmb` records linear
+disjointness in the form: any $\mathbb{Q}$-linearly independent family in $\mathbb{Q}((q))$ remains
+$L$-linearly independent in $L((q))$ after applying `coeffEmb L`; this holds for every field $L
+\supseteq \mathbb{Q}$, with no algebraicity hypothesis, and is proved by taking coordinates in a
+$\mathbb{Q}$-basis of $L$. Then `baseChangeRatAlgHom` is the $\mathbb{Q}$-algebra map obtained from
+`Algebra.TensorProduct.productMap` applied to $\operatorname{algebraMap} L\,L((q))$ and to `coeffEmb
+L` composed with the inclusion of $F_0$, and `baseChangeHom` is its upgrade to an $L$-algebra map $L
+\otimes_{\mathbb{Q}} F_0 \to L((q))$, so $c \otimes f \mapsto \operatorname{algebraMap}(c)\cdot
+\mathrm{coeffEmb}(f)$. It is injective (`baseChangeHom_injective`, from the linear disjointness
+statement and a basis of the tensor product) and takes values in `laurentBaseChange L F₀`
+(`baseChangeHom_mem`); hence the instance `instIsDomainTensorProduct` that $L \otimes_{\mathbb{Q}}
+F_0$ is a domain.
+
+Under the further hypothesis that $L/\mathbb{Q}$ is algebraic, $L \otimes_{\mathbb{Q}} F_0$ is a
+field (`isField_tensorProduct`, from Mathlib's tensor-product criterion), so the image of
+`baseChangeHom` is an intermediate field containing the generators of the compositum;
+`exists_baseChangeHom_eq` gives surjectivity onto `laurentBaseChange L F₀` and `baseChangeEquiv` is
+the resulting $L$-algebra isomorphism $L \otimes_{\mathbb{Q}} F_0 \simeq L\cdot F_0$, with lemmas
+computing its values on $1 \otimes f$ and $c \otimes f$ and its inverse. Finally `geomAut` is the
+monoid homomorphism sending a $\mathbb{Q}$-automorphism $\sigma$ of $F_0$ to the $L$-automorphism of
+`laurentBaseChange L F₀` conjugate, through `baseChangeEquiv`, to $\mathrm{id}_L \otimes \sigma$;
+`geomAut_coeffEmb` and `coe_geomAut_coeffEmb` say that it sends $\mathrm{coeffEmb}(f)$ to
+$\mathrm{coeffEmb}(\sigma f)$ for $f \in F_0$. Note that `geomAut` keeps the same $F_0$ on source
+and target.
+
+**Relation to Mathlib.** Mathlib supplies the tensor-product algebra API used here
+(`Algebra.TensorProduct.productMap`, `Algebra.TensorProduct.basis`,
+`Algebra.TensorProduct.isField_of_isAlgebraic`, `Algebra.TensorProduct.congr`) and a general notion
+of linear disjointness, but the Laurent-series coefficient embedding `coeffEmb` and the compositum
+`laurentBaseChange` are the project's own (from the imported module), as are all the declarations
+here.
+
+**Where it is used.** Taken with $L = \overline{\mathbb{Q}}$ (an algebraic closure of $\mathbb{Q}$)
+and $F_0$ the modular function field attached to $X_0(N)$, `baseChangeEquiv` identifies
+$\overline{\mathbb{Q}} \otimes_{\mathbb{Q}} F_0$ with the geometric function field, and `geomAut`
+transports $\mathbb{Q}$-automorphisms of the modular function field — the Atkin–Lehner and Fricke
+involutions, and twists of degeneracy maps — to $\overline{\mathbb{Q}}$-automorphisms of it, which
+then act on places of the curve and on $J_0(N)$. This is the mechanism by which the Fricke
+involution and the cusp $0$ are defined at the geometric level in the later cuspidal-class material.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public noncomputable section publicSection
+
+open scoped TensorProduct
+open IntermediateField
+
+namespace ModularCurve
+
+section LinearDisjoint
+
+variable (L : Type*) [Field L] [Algebra ℚ L]
+
+theorem linearIndependent_coeffEmb {ι : Type*} {v : ι → LaurentSeries ℚ}
+    (hv : LinearIndependent ℚ v) : LinearIndependent L (fun i => coeffEmb L (v i)) := by
+  classical
+  rw [linearIndependent_iff'] at hv ⊢
+  intro s g hg i hi
+  let b := Module.Free.chooseBasis ℚ L
+  refine b.forall_coord_eq_zero_iff.mp fun k => ?_
+  have hk : ∑ j ∈ s, (b.coord k (g j)) • v j = 0 := by
+    ext n
+    have hn := congrArg (fun x : LaurentSeries L => b.coord k (x.coeff n)) hg
+    simp only [HahnSeries.coeff_sum, HahnSeries.coeff_smul, coeffEmb_coeff, smul_eq_mul,
+      HahnSeries.coeff_zero, map_zero] at hn
+    simp only [HahnSeries.coeff_sum, HahnSeries.coeff_smul, smul_eq_mul, HahnSeries.coeff_zero]
+    rw [← hn, map_sum]
+    refine Finset.sum_congr rfl fun j _ => ?_
+    rw [mul_comm (g j), ← Algebra.smul_def, map_smul, smul_eq_mul, mul_comm]
+  exact hv s (fun j => b.coord k (g j)) hk i hi
+
+end LinearDisjoint
+
+section BaseChange
+
+variable (L : Type*) [Field L]
+
+private theorem algebraMap_mul_eq_smul (c : L) (y : LaurentSeries L) :
+    algebraMap L (LaurentSeries L) c * y = c • y := by
+  rw [algebraMap_laurentSeries_eq_single, HahnSeries.single_zero_mul_eq_smul]
+
+variable [Algebra ℚ L]
+variable (F₀ : IntermediateField ℚ (LaurentSeries ℚ))
+
+def baseChangeRatAlgHom : L ⊗[ℚ] F₀ →ₐ[ℚ] LaurentSeries L :=
+  Algebra.TensorProduct.productMap (algebraMap L (LaurentSeries L)).toRatAlgHom
+    ((coeffEmb L).comp (F₀.val : F₀ →+* LaurentSeries ℚ)).toRatAlgHom
+
+theorem baseChangeRatAlgHom_tmul (c : L) (f : F₀) :
+    baseChangeRatAlgHom L F₀ (c ⊗ₜ f) =
+      algebraMap L (LaurentSeries L) c * coeffEmb L (f : LaurentSeries ℚ) :=
+  Algebra.TensorProduct.productMap_apply_tmul _ _ c f
+
+def baseChangeHom : L ⊗[ℚ] F₀ →ₐ[L] LaurentSeries L :=
+  { baseChangeRatAlgHom L F₀ with
+    commutes' := fun c => by
+      change baseChangeRatAlgHom L F₀ (algebraMap L (L ⊗[ℚ] F₀) c) =
+        algebraMap L (LaurentSeries L) c
+      rw [Algebra.TensorProduct.algebraMap_apply, Algebra.algebraMap_self, RingHom.id_apply,
+        baseChangeRatAlgHom_tmul, OneMemClass.coe_one, map_one, mul_one] }
+
+@[simp]
+theorem baseChangeHom_tmul (c : L) (f : F₀) :
+    baseChangeHom L F₀ (c ⊗ₜ f) =
+      algebraMap L (LaurentSeries L) c * coeffEmb L (f : LaurentSeries ℚ) :=
+  baseChangeRatAlgHom_tmul L F₀ c f
+
+theorem baseChangeHom_one_tmul (f : F₀) :
+    baseChangeHom L F₀ (1 ⊗ₜ f) = coeffEmb L (f : LaurentSeries ℚ) := by
+  rw [baseChangeHom_tmul, map_one, one_mul]
+
+private def baseChangeLinear : L ⊗[ℚ] F₀ →ₗ[L] LaurentSeries L where
+  toFun := baseChangeHom L F₀
+  map_add' := map_add _
+  map_smul' c x := by
+    rw [RingHom.id_apply, ← algebraMap_mul_eq_smul, ← (baseChangeHom L F₀).commutes c,
+      ← map_mul, ← Algebra.smul_def]
+
+private theorem baseChangeLinear_apply (x : L ⊗[ℚ] F₀) :
+    baseChangeLinear L F₀ x = baseChangeHom L F₀ x := rfl
+
+private def valRatLinear : F₀ →ₗ[ℚ] LaurentSeries ℚ :=
+  ((F₀.val : F₀ →+* LaurentSeries ℚ) : F₀ →+ LaurentSeries ℚ).toRatLinearMap
+
+private theorem valRatLinear_apply (f : F₀) : valRatLinear F₀ f = (f : LaurentSeries ℚ) := rfl
+
+private theorem baseChangeLinear_injective : Function.Injective (baseChangeLinear L F₀) := by
+  classical
+  let bF := Module.Free.chooseBasis ℚ F₀
+  let B := Algebra.TensorProduct.basis L bF
+  have hli : LinearIndependent L (baseChangeLinear L F₀ ∘ B) := by
+    have h : (baseChangeLinear L F₀ ∘ B : _ → LaurentSeries L) =
+        fun i => coeffEmb L (valRatLinear F₀ (bF i)) := by
+      funext i
+      rw [Function.comp_apply, baseChangeLinear_apply, Algebra.TensorProduct.basis_apply,
+        baseChangeHom_one_tmul, valRatLinear_apply]
+    rw [h]
+    refine linearIndependent_coeffEmb L ?_
+    refine bF.linearIndependent.map' (valRatLinear F₀) (LinearMap.ker_eq_bot.mpr ?_)
+    exact Subtype.val_injective
+  rw [injective_iff_map_eq_zero]
+  intro x hx
+  have hrepr : Finsupp.linearCombination L (baseChangeLinear L F₀ ∘ B) (B.repr x) = 0 := by
+    rw [← Finsupp.apply_linearCombination, B.linearCombination_repr]
+    exact hx
+  have h0 : B.repr x = 0 := linearIndependent_iff.mp hli (B.repr x) hrepr
+  rw [← B.linearCombination_repr x, h0, map_zero]
+
+theorem baseChangeHom_injective : Function.Injective (baseChangeHom L F₀) :=
+  baseChangeLinear_injective L F₀
+
+theorem baseChangeHom_mem (x : L ⊗[ℚ] F₀) :
+    baseChangeHom L F₀ x ∈ laurentBaseChange L F₀ := by
+  induction x using TensorProduct.inductionOn with
+  | tmul c f =>
+      rw [baseChangeHom_tmul]
+      exact mul_mem ((laurentBaseChange L F₀).algebraMap_mem c)
+        (coeffEmb_mem_laurentBaseChange L f.2)
+  | add x y hx hy => rw [map_add]; exact add_mem hx hy
+
+instance instIsDomainTensorProduct : IsDomain (L ⊗[ℚ] F₀) :=
+  Function.Injective.isDomain (baseChangeHom L F₀).toRingHom (baseChangeHom_injective L F₀)
+
+variable [Algebra.IsAlgebraic ℚ L]
+
+theorem isField_tensorProduct : IsField (L ⊗[ℚ] F₀) :=
+  Algebra.TensorProduct.isField_of_isAlgebraic ℚ L F₀ (Or.inl inferInstance)
+
+private theorem isField_range_baseChangeHom : IsField (baseChangeHom L F₀).range :=
+  MulEquiv.isField (isField_tensorProduct L F₀)
+    (AlgEquiv.ofInjective _ (baseChangeHom_injective L F₀)).symm.toMulEquiv
+
+theorem exists_baseChangeHom_eq {y : LaurentSeries L} (hy : y ∈ laurentBaseChange L F₀) :
+    ∃ x : L ⊗[ℚ] F₀, baseChangeHom L F₀ x = y := by
+  let K : IntermediateField L (LaurentSeries L) :=
+    (baseChangeHom L F₀).range.toIntermediateField' (isField_range_baseChangeHom L F₀)
+  have hle : laurentBaseChange L F₀ ≤ K := by
+    change IntermediateField.adjoin L _ ≤ K
+    refine IntermediateField.adjoin_le_iff.mpr ?_
+    rintro _ ⟨f, hf, rfl⟩
+    exact ⟨(1 : L) ⊗ₜ ⟨f, hf⟩, baseChangeHom_one_tmul L F₀ ⟨f, hf⟩⟩
+  exact hle hy
+
+def baseChangeEquiv : L ⊗[ℚ] F₀ ≃ₐ[L] laurentBaseChange L F₀ :=
+  AlgEquiv.ofBijective
+    { toFun := fun x => ⟨baseChangeHom L F₀ x, baseChangeHom_mem L F₀ x⟩
+      map_one' := Subtype.ext (map_one _)
+      map_mul' := fun x y => Subtype.ext (map_mul _ x y)
+      map_zero' := Subtype.ext (map_zero _)
+      map_add' := fun x y => Subtype.ext (map_add _ x y)
+      commutes' := fun c => Subtype.ext ((baseChangeHom L F₀).commutes c) }
+    ⟨fun x y h => baseChangeHom_injective L F₀ (congrArg Subtype.val h), fun y => by
+      obtain ⟨x, hx⟩ := exists_baseChangeHom_eq L F₀ y.2
+      exact ⟨x, Subtype.ext hx⟩⟩
+
+@[simp]
+theorem coe_baseChangeEquiv_apply (x : L ⊗[ℚ] F₀) :
+    (baseChangeEquiv L F₀ x : LaurentSeries L) = baseChangeHom L F₀ x := rfl
+
+theorem baseChangeEquiv_one_tmul (f : F₀) :
+    baseChangeEquiv L F₀ (1 ⊗ₜ f) = ⟨coeffEmb L f, coeffEmb_mem_laurentBaseChange L f.2⟩ :=
+  Subtype.ext (baseChangeHom_one_tmul L F₀ f)
+
+theorem baseChangeEquiv_symm_coeffEmb (f : F₀) :
+    (baseChangeEquiv L F₀).symm ⟨coeffEmb L f, coeffEmb_mem_laurentBaseChange L f.2⟩ = 1 ⊗ₜ f := by
+  rw [← baseChangeEquiv_one_tmul, AlgEquiv.symm_apply_apply]
+
+theorem baseChangeEquiv_tmul (c : L) (f : F₀) :
+    baseChangeEquiv L F₀ (c ⊗ₜ f) =
+      algebraMap L (laurentBaseChange L F₀) c *
+        ⟨coeffEmb L f, coeffEmb_mem_laurentBaseChange L f.2⟩ := by
+  rw [show c ⊗ₜ[ℚ] f = algebraMap L (L ⊗[ℚ] F₀) c * (1 ⊗ₜ f) by
+      rw [Algebra.TensorProduct.algebraMap_apply, Algebra.algebraMap_self, RingHom.id_apply,
+        Algebra.TensorProduct.tmul_mul_tmul, mul_one, one_mul],
+    map_mul, AlgEquiv.commutes, baseChangeEquiv_one_tmul]
+
+def geomAut : (F₀ ≃ₐ[ℚ] F₀) →* (laurentBaseChange L F₀ ≃ₐ[L] laurentBaseChange L F₀) :=
+  MonoidHom.mk'
+    (fun σ => ((baseChangeEquiv L F₀).symm.trans
+      (Algebra.TensorProduct.congr (AlgEquiv.refl : L ≃ₐ[L] L) σ)).trans (baseChangeEquiv L F₀))
+    (fun σ τ => AlgEquiv.ext fun x => by
+      change baseChangeEquiv L F₀ (Algebra.TensorProduct.congr (AlgEquiv.refl : L ≃ₐ[L] L) (σ * τ)
+          ((baseChangeEquiv L F₀).symm x)) =
+        baseChangeEquiv L F₀ (Algebra.TensorProduct.congr (AlgEquiv.refl : L ≃ₐ[L] L) σ
+          ((baseChangeEquiv L F₀).symm (baseChangeEquiv L F₀
+            (Algebra.TensorProduct.congr (AlgEquiv.refl : L ≃ₐ[L] L) τ
+              ((baseChangeEquiv L F₀).symm x)))))
+      rw [AlgEquiv.symm_apply_apply]
+      congr 1
+      induction (baseChangeEquiv L F₀).symm x using TensorProduct.inductionOn with
+      | tmul c f => rfl
+      | add y z hy hz => simp only [map_add, hy, hz])
+
+theorem geomAut_apply (σ : F₀ ≃ₐ[ℚ] F₀) (x : laurentBaseChange L F₀) :
+    geomAut L F₀ σ x = baseChangeEquiv L F₀
+      (Algebra.TensorProduct.congr (AlgEquiv.refl : L ≃ₐ[L] L) σ ((baseChangeEquiv L F₀).symm x)) :=
+  rfl
+
+theorem geomAut_baseChangeEquiv_tmul (σ : F₀ ≃ₐ[ℚ] F₀) (c : L) (f : F₀) :
+    geomAut L F₀ σ (baseChangeEquiv L F₀ (c ⊗ₜ f)) = baseChangeEquiv L F₀ (c ⊗ₜ σ f) := by
+  rw [geomAut_apply, AlgEquiv.symm_apply_apply]
+  rfl
+
+theorem geomAut_coeffEmb (σ : F₀ ≃ₐ[ℚ] F₀) (f : F₀) :
+    geomAut L F₀ σ ⟨coeffEmb L f, coeffEmb_mem_laurentBaseChange L f.2⟩ =
+      ⟨coeffEmb L (σ f), coeffEmb_mem_laurentBaseChange L (σ f).2⟩ := by
+  rw [← baseChangeEquiv_one_tmul, geomAut_baseChangeEquiv_tmul, baseChangeEquiv_one_tmul]
+
+theorem coe_geomAut_coeffEmb (σ : F₀ ≃ₐ[ℚ] F₀) (f : F₀) :
+    (geomAut L F₀ σ ⟨coeffEmb L f, coeffEmb_mem_laurentBaseChange L f.2⟩ : LaurentSeries L) =
+      coeffEmb L (σ f) :=
+  congrArg Subtype.val (geomAut_coeffEmb L F₀ σ f)
+
+end BaseChange
+
+end ModularCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_HahnSpecialise.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_HahnSpecialise.lean
new file mode 100644
index 0000000000..9bf5376508
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_HahnSpecialise.lean
@@ -0,0 +1,389 @@
+/-
+Based on Prove2Me node ModularCurve_HahnSpecialise
+(dbd5f588-a201-5fd2-8c23-814aa2019875) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_ReduceHom
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_SpecialisationVocab
+public import Mathlib.RingTheory.LocalRing.ResidueField.Basic
+public import Mathlib.RingTheory.Ideal.Quotient.Operations
+public import Mathlib.GroupTheory.OrderOfElement
+
+/-!
+# Specialisation of points and cyclic subgroups over Hahn series
+
+Definition: `ModularCurve_HahnSpecialise` (`dbd5f588-a201-5fd2-8c23-814aa2019875`), by Claude,
+2026-09-05.
+
+Write $H=\bar{\mathbb Q}((s^{\mathbb Q}))$ for the Hahn-series field with rational exponents over
+$\bar{\mathbb Q}$. The module first supplies two facts about the reduction homomorphism `reduceHom`
+attached to a Weierstrass model $W$ over a valuation subring $A$ of a field $L$ whose reduction
+$W\bmod\mathfrak m$ has non-vanishing discriminant: a point $P$ of $W_L$ killed by $N$, with $N$
+invertible in the residue field, and with vanishing reduction is itself $0$; consequently
+`reduceHom` is injective on the set of points killed by $N$. Next, [`CycSubOf G
+N`](../def/ModularCurve_HahnSpecialise.html#L44) is the type of subgroups of an additive group $G$
+of the form $\langle g\rangle$ for some $g$ of additive order exactly $N$; for a homomorphism $f$
+injective on $N$-torsion,
+[`CycSubOf.addOrderOf_map_of_injOn`](../def/ModularCurve_HahnSpecialise.html#L54) shows orders are
+preserved and [`CycSubOf.map`](../def/ModularCurve_HahnSpecialise.html#L64) transports such
+subgroups along $f$.
+
+The bulk of the module sets up specialisation at $s=0$. `valuationSubringH` is the subring $\{x\in
+H:0\le\operatorname{orderTop}(x)\}$, upgraded to a valuation subring; `resH` is the constant-term
+ring homomorphism to $\bar{\mathbb Q}$, shown surjective with kernel the maximal ideal, whence
+`residueFieldEquiv` identifies the residue field with $\bar{\mathbb Q}$ (and `residueAlgEquiv` does
+so as an algebra, `algebraQbar` being the algebra structure via `resH`). A unit of the valuation
+subring is characterised by $\operatorname{orderTop}=0$. For $E$ over $H$ with `IntegralCoeffs E`
+(all $a_i$ of non-negative order), `liftModel` is the corresponding model over the valuation
+subring; its reduction, transported along `residueFieldEquiv`, is `specialFibre E` (coefficients
+$a_i(0)$), and the discriminant $\Delta$ of `specialFibre E` is non-zero exactly when
+$\operatorname{orderTop}(\Delta(E))=0$. Under that hypothesis, `specialise` is the group
+homomorphism from $E(H)$ to the group of $\bar{\mathbb Q}$-points of `specialFibre E`, reducing a
+point and applying the residue identification: it sends $0$ to $0$, sends $(x,y)$ with
+$0\le\operatorname{orderTop}(x)$ to $(x(0),y(0))$, and sends points with $x$ of negative order to
+$0$. It is injective on points killed by a non-zero $N$, preserves additive order $N$, and therefore
+induces `specialiseCycSub`, a map from cyclic subgroups of $E(H)$ with a generator of order $N$ to
+those of the special fibre, given on underlying subgroups by the image under `specialise`.
+
+**Relation to Mathlib.** Mathlib supplies the ambient notions (`HahnSeries`, `ValuationSubring`,
+residue fields, `WeierstrassCurve` and its affine point group);
+[`CycSubOf`](../def/ModularCurve_HahnSpecialise.html#L44) is a generic form of the project's
+`CycSub` and `CycSubH`, and the reduction homomorphism `reduceHom` on points of a Weierstrass model
+over a valuation subring is the project's own.
+
+**Where it is used.** The specialisation map is used to compare $\Gamma_0(N)$-structures on the
+generic deformation $E_{j_0+s}$ of an elliptic curve of invariant $j_0$ with those on the curve over
+$\bar{\mathbb Q}$ obtained at $s=0$: cyclic subgroups generated by a point of exact order $N$
+specialise injectively, which feeds the moduli dictionary for modular polynomials and level
+structures.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open IsLocalRing ValuationSubring
+open ModularCurve.TatePoint (Qbar H CycSubH)
+
+namespace WeierstrassCurve
+
+variable {L : Type*} [Field L] {A : ValuationSubring L} {W : WeierstrassCurve A}
+variable [DecidableEq L] [DecidableEq (ResidueField A)]
+variable (hΔ : (W.map (residue A)).Δ ≠ 0)
+
+omit [DecidableEq (ResidueField A)] in
+theorem eq_zero_of_nsmul_eq_zero_of_reducePoint_eq_zero' {N : ℕ} (hN : (N : ResidueField A) ≠ 0)
+    (P : (W.map A.subtype).toAffine.Point) (hP : N • P = 0) (h0 : reducePoint hΔ P = 0) :
+    P = 0 := by
+  cases P with
+  | zero => rfl
+  | some x y h =>
+    exfalso
+    have hx : x ∈ A := X_mem_of_nsmul_eq_zero' W hN h hP
+    rw [reducePoint_some_of_mem hΔ h hx] at h0
+    exact Affine.Point.some_ne_zero _ h0
+
+theorem reduceHom_injOn_nsmul_eq_zero {N : ℕ} (hN : (N : ResidueField A) ≠ 0)
+    {P Q : (W.map A.subtype).toAffine.Point} (hP : N • P = 0) (hQ : N • Q = 0)
+    (h : reduceHom hΔ P = reduceHom hΔ Q) : P = Q := by
+  have h1 : N • (P - Q) = 0 := by rw [nsmul_sub, hP, hQ, sub_zero]
+  have h2 : reducePoint hΔ (P - Q) = 0 := by
+    change reduceHom hΔ (P - Q) = 0
+    rw [map_sub, h, sub_self]
+  exact sub_eq_zero.mp (eq_zero_of_nsmul_eq_zero_of_reducePoint_eq_zero' hΔ hN _ h1 h2)
+
+end WeierstrassCurve
+
+def CycSubOf (G : Type*) [AddGroup G] (N : ℕ) : Type _ :=
+  {S : AddSubgroup G // ∃ g : G, addOrderOf g = N ∧ S = AddSubgroup.zmultiples g}
+
+namespace CycSubOf
+
+variable {G G' : Type*} [AddCommGroup G] [AddCommGroup G'] (f : G →+ G') {N : ℕ}
+variable (hf : ∀ ⦃P Q : G⦄, N • P = 0 → N • Q = 0 → f P = f Q → P = Q)
+
+include hf in
+theorem addOrderOf_map_of_injOn {g : G} (hg : addOrderOf g = N) : addOrderOf (f g) = N := by
+  apply Nat.dvd_antisymm
+  · apply addOrderOf_dvd_of_nsmul_eq_zero
+    rw [← map_nsmul, ← hg, addOrderOf_nsmul_eq_zero, map_zero]
+  · rw [← hg]
+    apply addOrderOf_dvd_of_nsmul_eq_zero
+    refine hf ?_ (smul_zero _) ?_
+    · rw [smul_comm, ← hg, addOrderOf_nsmul_eq_zero, smul_zero]
+    · rw [map_nsmul, addOrderOf_nsmul_eq_zero, map_zero]
+
+def map : CycSubOf G N → CycSubOf G' N := fun S =>
+  ⟨S.1.map f, by
+    obtain ⟨g, hg, hS⟩ := S.2
+    exact ⟨f g, addOrderOf_map_of_injOn f hf hg, by rw [hS, AddMonoidHom.map_zmultiples]⟩⟩
+
+@[simp] theorem coe_map (S : CycSubOf G N) : (map f hf S).1 = S.1.map f := rfl
+
+end CycSubOf
+
+namespace ModularCurve.HahnSpecialise
+
+open ModularCurve.B3
+
+open ModularCurve.TatePoint
+
+def valuationSubringH : ValuationSubring H :=
+  { integralO with
+  mem_or_inv_mem' := fun x => by
+    by_cases hx0 : x = 0
+    · left; simp [hx0]
+    rcases le_or_gt 0 x.orderTop with h | h
+    · exact Or.inl h
+    · right
+      change 0 ≤ x⁻¹.orderTop
+      have hinv : x⁻¹ ≠ 0 := inv_ne_zero hx0
+      have h1 : (x * x⁻¹).order = x.order + x⁻¹.order := HahnSeries.order_mul hx0 hinv
+      rw [mul_inv_cancel₀ hx0, HahnSeries.order_one] at h1
+      have hxord : x.order < 0 := by
+        have h' : ((x.order : ℚ) : WithTop ℚ) < 0 := by
+          rw [HahnSeries.order_eq_orderTop_of_ne_zero hx0]; exact h
+        exact_mod_cast h'
+      have h2 : 0 ≤ x⁻¹.order := by linarith
+      rw [← HahnSeries.order_eq_orderTop_of_ne_zero hinv]
+      exact_mod_cast h2 }
+
+theorem mem_valuationSubringH {x : H} : x ∈ valuationSubringH ↔ 0 ≤ x.orderTop := Iff.rfl
+
+def resH : valuationSubringH →+* Qbar where
+  toFun x := (x : H).coeff 0
+  map_one' := by simp
+  map_mul' x y := coeff_zero_mul_of_integral x.2 y.2
+  map_zero' := by simp
+  map_add' x y := by simp
+
+@[simp] theorem resH_apply (x : valuationSubringH) : resH x = (x : H).coeff 0 := rfl
+
+theorem resH_eq_resO (x : valuationSubringH) : resH x = resO ⟨(x : H), x.2⟩ := rfl
+
+theorem resH_surjective : Function.Surjective resH := fun c => by
+  refine ⟨⟨HahnSeries.C c, ?_⟩, ?_⟩
+  · change 0 ≤ (HahnSeries.C c : H).orderTop
+    by_cases hc : c = 0
+    · simp [hc]
+    · rw [HahnSeries.C_apply, HahnSeries.orderTop_single hc]; exact le_rfl
+  · change (HahnSeries.C c : H).coeff 0 = c
+    simp
+
+theorem ker_resH : RingHom.ker resH = maximalIdeal valuationSubringH :=
+  IsLocalRing.eq_maximalIdeal (RingHom.ker_isMaximal_of_surjective resH resH_surjective)
+
+def residueFieldEquiv : ResidueField valuationSubringH ≃+* Qbar :=
+  (Ideal.quotEquivOfEq ker_resH.symm).trans (RingHom.quotientKerEquivOfSurjective resH_surjective)
+
+theorem residueFieldEquiv_residue (x : valuationSubringH) :
+    residueFieldEquiv (residue valuationSubringH x) = (x : H).coeff 0 := rfl
+
+end ModularCurve.HahnSpecialise
+
+namespace ModularCurve.HahnSpecialise
+
+open ModularCurve.B3
+
+open WeierstrassCurve
+
+def liftModel (E : WeierstrassCurve H) (hE : IntegralCoeffs E) :
+    WeierstrassCurve valuationSubringH :=
+  ⟨⟨E.a₁, hE.1⟩, ⟨E.a₂, hE.2.1⟩, ⟨E.a₃, hE.2.2.1⟩, ⟨E.a₄, hE.2.2.2.1⟩, ⟨E.a₆, hE.2.2.2.2⟩⟩
+
+@[simp] theorem liftModel_map_subtype (E : WeierstrassCurve H) (hE : IntegralCoeffs E) :
+    (liftModel E hE).map valuationSubringH.subtype = E := by
+  cases E; rfl
+
+theorem liftModel_map_residue_map_equiv (E : WeierstrassCurve H) (hE : IntegralCoeffs E) :
+    ((liftModel E hE).map (residue valuationSubringH)).map residueFieldEquiv.toRingHom
+      = specialFibre E := by
+  cases E
+  rw [WeierstrassCurve.map_map]
+  rfl
+
+theorem isUnit_iff_orderTop_eq_zero (x : valuationSubringH) :
+    IsUnit x ↔ (x : H).orderTop = 0 := by
+  constructor
+  · intro hu
+    obtain ⟨y, hy⟩ := hu.exists_right_inv
+    have hxy : (x : H) * (y : H) = 1 := by
+      have := congrArg (fun z : valuationSubringH => (z : H)) hy
+      simpa using this
+    have hx0 : (x : H) ≠ 0 := left_ne_zero_of_mul_eq_one hxy
+    have hy0 : (y : H) ≠ 0 := right_ne_zero_of_mul_eq_one hxy
+    have h1 := HahnSeries.order_mul hx0 hy0
+    rw [hxy, HahnSeries.order_one] at h1
+    have hx' : 0 ≤ (x : H).order := by
+      have h : 0 ≤ (x : H).orderTop := x.2
+      rw [← HahnSeries.order_eq_orderTop_of_ne_zero hx0] at h
+      exact_mod_cast h
+    have hy' : 0 ≤ (y : H).order := by
+      have h : 0 ≤ (y : H).orderTop := y.2
+      rw [← HahnSeries.order_eq_orderTop_of_ne_zero hy0] at h
+      exact_mod_cast h
+    have h2 : (x : H).order = 0 := by linarith
+    rw [← HahnSeries.order_eq_orderTop_of_ne_zero hx0]
+    exact_mod_cast h2
+  · intro h0
+    have hx0 : (x : H) ≠ 0 := by
+      intro hx; rw [hx, HahnSeries.orderTop_zero] at h0; exact WithTop.top_ne_coe h0
+    have hinv : 0 ≤ (x : H)⁻¹.orderTop := by
+      have hi0 : (x : H)⁻¹ ≠ 0 := inv_ne_zero hx0
+      have h1 : ((x : H) * (x : H)⁻¹).order = (x : H).order + (x : H)⁻¹.order :=
+        HahnSeries.order_mul hx0 hi0
+      rw [mul_inv_cancel₀ hx0, HahnSeries.order_one] at h1
+      have hx : (x : H).order = 0 := by
+        have := (HahnSeries.order_eq_orderTop_of_ne_zero hx0).trans h0
+        exact_mod_cast this
+      rw [← HahnSeries.order_eq_orderTop_of_ne_zero hi0]
+      have : (x : H)⁻¹.order = 0 := by linarith
+      exact_mod_cast this.symm.le
+    exact ⟨⟨x, ⟨(x : H)⁻¹, hinv⟩, Subtype.ext (mul_inv_cancel₀ hx0),
+      Subtype.ext (inv_mul_cancel₀ hx0)⟩, rfl⟩
+
+theorem map_residue_Δ_ne_zero_of_specialFibre (E : WeierstrassCurve H) (hE : IntegralCoeffs E)
+    (hΔ : (specialFibre E).Δ ≠ 0) :
+    ((liftModel E hE).map (residue valuationSubringH)).Δ ≠ 0 := by
+  intro h0
+  apply hΔ
+  rw [← liftModel_map_residue_map_equiv E hE, WeierstrassCurve.map_Δ, h0, map_zero]
+
+theorem specialFibre_Δ_ne_zero_iff (E : WeierstrassCurve H) (hE : IntegralCoeffs E) :
+    (specialFibre E).Δ ≠ 0 ↔ E.Δ.orderTop = 0 := by
+  have h1 : ((liftModel E hE).map valuationSubringH.subtype).Δ =
+      valuationSubringH.subtype (liftModel E hE).Δ := by
+    simp only [WeierstrassCurve.map_Δ]
+  rw [liftModel_map_subtype] at h1
+  have h2 : (specialFibre E).Δ =
+      residueFieldEquiv (((liftModel E hE).map (residue valuationSubringH)).Δ) := by
+    rw [← liftModel_map_residue_map_equiv E hE, WeierstrassCurve.map_Δ]; rfl
+  rw [h2, residueFieldEquiv.map_ne_zero_iff, WeierstrassCurve.map_residue_Δ_ne_zero_iff,
+    isUnit_iff_orderTop_eq_zero, h1]
+  rfl
+
+end ModularCurve.HahnSpecialise
+
+namespace ModularCurve.HahnSpecialise
+
+open ModularCurve.B3
+
+open WeierstrassCurve
+open scoped Classical
+
+@[reducible] def algebraQbar : Algebra valuationSubringH Qbar := resH.toAlgebra
+
+attribute [local instance] algebraQbar
+
+@[simp] theorem algebraMap_Qbar_apply (x : valuationSubringH) :
+    algebraMap valuationSubringH Qbar x = (x : H).coeff 0 := rfl
+
+def residueAlgEquiv : ResidueField valuationSubringH ≃ₐ[valuationSubringH] Qbar :=
+  AlgEquiv.ofRingEquiv (f := residueFieldEquiv) (fun _ => rfl)
+
+variable (E : WeierstrassCurve H) (hE : IntegralCoeffs E)
+
+def specialFibrePointMap :
+    ((liftModel E hE).map (residue valuationSubringH)).toAffine.Point →+
+      (specialFibre E).toAffine.Point :=
+  (Affine.Point.map (W' := (liftModel E hE).toAffine)
+    (residueAlgEquiv : ResidueField valuationSubringH →ₐ[valuationSubringH] Qbar) :)
+
+theorem specialFibrePointMap_injective : Function.Injective (specialFibrePointMap E hE) :=
+  Affine.Point.map_injective _
+
+def specialise (hΔ : (specialFibre E).Δ ≠ 0) :
+    E.toAffine.Point →+ (specialFibre E).toAffine.Point :=
+  (specialFibrePointMap E hE).comp
+    ((reduceHom (map_residue_Δ_ne_zero_of_specialFibre E hE hΔ) :
+      ((liftModel E hE).map valuationSubringH.subtype).toAffine.Point →+ _) :)
+
+include hE in
+theorem nonsingular_specialFibre_coeff_zero (hΔ : (specialFibre E).Δ ≠ 0) {x y : H}
+    (h : E.toAffine.Nonsingular x y) (hx : 0 ≤ x.orderTop) :
+    (specialFibre E).toAffine.Nonsingular (x.coeff 0) (y.coeff 0) := by
+  have h' : ((liftModel E hE).map valuationSubringH.subtype).toAffine.Nonsingular x y := by
+    rw [liftModel_map_subtype]; exact h
+  have hy : y ∈ valuationSubringH := WeierstrassCurve.Affine.Y_mem_of_X_mem (liftModel E hE) h'.1 hx
+  have hres := WeierstrassCurve.Affine.nonsingular_residue (liftModel E hE)
+    (map_residue_Δ_ne_zero_of_specialFibre E hE hΔ) (x := ⟨x, hx⟩) (y := ⟨y, hy⟩) h'.1
+  have hmap := ((((liftModel E hE).map (residue valuationSubringH)).toAffine.map_nonsingular
+    (f := residueFieldEquiv.toRingHom) residueFieldEquiv.injective
+    (residue valuationSubringH ⟨x, hx⟩) (residue valuationSubringH ⟨y, hy⟩)).mpr hres)
+  rw [show ((liftModel E hE).map (residue valuationSubringH)).toAffine.map
+    residueFieldEquiv.toRingHom
+      = (specialFibre E).toAffine from liftModel_map_residue_map_equiv E hE] at hmap
+  exact hmap
+
+@[simp] theorem specialise_zero (hΔ : (specialFibre E).Δ ≠ 0) : specialise E hE hΔ 0 = 0 :=
+  map_zero _
+
+theorem specialise_some_of_nonneg (hΔ : (specialFibre E).Δ ≠ 0) {x y : H}
+    (h : E.toAffine.Nonsingular x y) (hx : 0 ≤ x.orderTop) :
+    specialise E hE hΔ (.some x y h) =
+      .some (x.coeff 0) (y.coeff 0) (nonsingular_specialFibre_coeff_zero E hE hΔ h hx) := by
+  have h' : ((liftModel E hE).map valuationSubringH.subtype).toAffine.Nonsingular x y := by
+    rw [liftModel_map_subtype]; exact h
+  change specialFibrePointMap E hE (reducePoint (map_residue_Δ_ne_zero_of_specialFibre E hE hΔ)
+    (.some x y h')) = _
+  rw [WeierstrassCurve.reducePoint_some_of_mem _ h' hx]
+  rfl
+
+theorem specialise_some_of_neg (hΔ : (specialFibre E).Δ ≠ 0) {x y : H}
+    (h : E.toAffine.Nonsingular x y) (hx : ¬ 0 ≤ x.orderTop) :
+    specialise E hE hΔ (.some x y h) = 0 := by
+  have h' : ((liftModel E hE).map valuationSubringH.subtype).toAffine.Nonsingular x y := by
+    rw [liftModel_map_subtype]; exact h
+  change specialFibrePointMap E hE (reducePoint (map_residue_Δ_ne_zero_of_specialFibre E hE hΔ)
+    (.some x y h')) = _
+  rw [WeierstrassCurve.reducePoint_some_of_notMem _ h' hx, map_zero]
+
+theorem natCast_residueField_ne_zero {N : ℕ} (hN : N ≠ 0) :
+    (N : ResidueField valuationSubringH) ≠ 0 := by
+  intro h
+  have := congrArg residueFieldEquiv h
+  rw [map_natCast, map_zero] at this
+  exact (Nat.cast_ne_zero.mpr hN) this
+
+theorem specialise_injOn_nsmul_eq_zero (hΔ : (specialFibre E).Δ ≠ 0) {N : ℕ} (hN : N ≠ 0)
+    {P Q : E.toAffine.Point} (hP : N • P = 0) (hQ : N • Q = 0)
+    (h : specialise E hE hΔ P = specialise E hE hΔ Q) : P = Q :=
+  reduceHom_injOn_nsmul_eq_zero (W := liftModel E hE) (map_residue_Δ_ne_zero_of_specialFibre E hE
+    hΔ)
+    (natCast_residueField_ne_zero hN) hP hQ (specialFibrePointMap_injective E hE h)
+
+theorem addOrderOf_specialise (hΔ : (specialFibre E).Δ ≠ 0) {N : ℕ} (hN : N ≠ 0)
+    {g : E.toAffine.Point} (hg : addOrderOf g = N) : addOrderOf (specialise E hE hΔ g) = N :=
+  CycSubOf.addOrderOf_map_of_injOn (specialise E hE hΔ)
+    (fun _ _ hP hQ h => specialise_injOn_nsmul_eq_zero E hE hΔ hN hP hQ h) hg
+
+end ModularCurve.HahnSpecialise
+
+namespace ModularCurve.HahnSpecialise
+
+open ModularCurve.B3
+
+open scoped Classical
+
+variable (E : WeierstrassCurve H) (hE : IntegralCoeffs E) (hΔ : (specialFibre E).Δ ≠ 0)
+
+def specialiseCycSub (N : ℕ) [NeZero N] : CycSubH E N → CycSub (specialFibre E) N :=
+  (CycSubOf.map (specialise E hE hΔ)
+    (fun _ _ hP hQ h => specialise_injOn_nsmul_eq_zero E hE hΔ (NeZero.ne N) hP hQ h) :)
+
+@[simp] theorem coe_specialiseCycSub (N : ℕ) [NeZero N] (S : CycSubH E N) :
+    (specialiseCycSub E hE hΔ N S).1 = S.1.map (specialise E hE hΔ) := rfl
+
+end ModularCurve.HahnSpecialise
+
+end
+
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_HeckeAlgebraHom.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_HeckeAlgebraHom.lean
new file mode 100644
index 0000000000..84576af688
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_HeckeAlgebraHom.lean
@@ -0,0 +1,172 @@
+/-
+Based on Prove2Me node ModularCurve_HeckeAlgebraHom
+(affb71a7-954b-5c76-8b0b-66bd68054c6a) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0HeckeOperatorHom
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodMap
+public import Mathlib.RingTheory.Finiteness.Subalgebra
+public import Mathlib.GroupTheory.Schreier
+public import Mathlib.LinearAlgebra.Matrix.FixedDetMatrices
+public import Mathlib.GroupTheory.Finiteness
+
+/-!
+# Integral Hecke algebra on characters of Γ0​(N)
+
+Definition: `ModularCurve_HeckeAlgebraHom` (`affb71a7-954b-5c76-8b0b-66bd68054c6a`), by Claude,
+2026-09-05.
+
+Throughout, additive characters of a congruence group are modelled as additive monoid homomorphisms
+$\mathrm{Additive}\,\Gamma \to \mathbb{Z}$, i.e. as elements of $\mathrm{Hom}(\Gamma,\mathbb{Z})$.
+The module first records that $\mathrm{SL}_2(\mathbb{Z})$ is finitely generated, by exhibiting
+$\{S,T\}$ as a generating set, and deduces the same for $\Gamma_0(N)$ with $N \neq 0$. For an
+arbitrary group $G$ and a subset $S \subseteq G$, `evalGen S` is the $\mathbb{Z}$-linear map
+$\mathrm{Hom}(\mathrm{Additive}\,G,\mathbb{Z}) \to (S \to \mathbb{Z})$ sending $\varphi$ to its
+family of values $\varphi(s)$, $s \in S$; `evalGen_injective` says it is injective whenever $S$
+generates $G$, and `addHom_int_moduleFinite` concludes that for finitely generated $G$ the module
+$\mathrm{Hom}(\mathrm{Additive}\,G,\mathbb{Z})$ is a finite $\mathbb{Z}$-module, hence (for $G =
+\Gamma_0(N)$) Noetherian; `moduleEnd_addHom_int_moduleFinite` upgrades this to finiteness of
+$\mathrm{End}_{\mathbb{Z}}\bigl(\mathrm{Hom}(\mathrm{Additive}\,G,\mathbb{Z})\bigr)$, by evaluating
+an endomorphism on a finite generating set of the module.
+
+The Hecke vocabulary is then set up inside this endomorphism ring. For $\ell \neq 0$,
+`heckeOperatorEndHom N ℓ` is the $\mathbb{Z}$-linear endomorphism of
+$\mathrm{Hom}(\mathrm{Additive}\,\Gamma_0(N),\mathbb{Z})$ underlying [`HeckeEis.heckeOperatorHom N ℓ
+ℤ`](../def/Gamma0HeckeOperatorHom.html#L285), that is: restrict a character along the finite-index
+subgroup of $\gamma \in \Gamma_0(N)$ with $\ell \mid \gamma_{01}$, pull back along the conjugation
+$\gamma \mapsto \alpha_\ell^{-1}\gamma\alpha_\ell$ by $\alpha_\ell = \mathrm{diag}(1,\ell)$, and
+then corestrict back to $\Gamma_0(N)$ by the transfer (a sum over the coset space). For $N \neq 0$
+and a set $S \subseteq \mathbb{N}$, `heckeAlgebraHom N S` is the $\mathbb{Z}$-subalgebra of
+$\mathrm{End}_{\mathbb{Z}}\bigl(\mathrm{Hom}(\mathrm{Additive}\,\Gamma_0(N),\mathbb{Z})\bigr)$
+generated by the operators `heckeOperatorEndHom N ℓ` for all primes $\ell \notin S$; thus $S =
+\varnothing$ gives the full algebra and excluding the primes dividing $N$ gives an anemic variant.
+Finally, the submodule `parabolicHoms ℤ (Gamma0 N) ℤ` of characters vanishing on every $\gamma$ with
+$(\operatorname{tr}\gamma)^2 = 4$ is recorded to be a finite $\mathbb{Z}$-module.
+
+**Relation to Mathlib.** Mathlib supplies the group-theoretic input (generators of
+$\mathrm{SL}_2(\mathbb{Z})$, `Group.FG`, Schreier's lemma for finite-index subgroups) and the
+module-finiteness machinery; the Hecke operators on $\mathrm{Hom}(\Gamma_0(N),\mathbb{Z})$ and the
+subalgebra they generate are the project's own notions, with no Mathlib counterpart.
+
+**Where it is used.** These operators and the algebra they generate provide the integral,
+group-theoretic model of the Hecke action used alongside the analytic Hecke algebra on cusp forms:
+finiteness over $\mathbb{Z}$ of the algebra and of the parabolic submodule is what makes eigenvalues
+integral and allows an eigenvector to be reduced modulo a prime, which is the starting point for
+attaching mod-$\ell$ representations to eigenforms.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open CongruenceSubgroup
+open scoped MatrixGroups
+
+namespace ModularCurve.Period
+
+section FGInfrastructure
+
+instance instGroupFG_SL2Z : Group.FG SL(2, ℤ) :=
+  Group.fg_iff.mpr ⟨{ModularGroup.S, ModularGroup.T},
+    SpecialLinearGroup.SL2Z_generators, (Set.finite_singleton _).insert _⟩
+
+instance instGroupFG_Gamma0 (N : ℕ) [NeZero N] : Group.FG (Gamma0 N) := inferInstance
+
+variable {G : Type*} [Group G]
+
+noncomputable def evalGen (S : Set G) : (Additive G →+ ℤ) →ₗ[ℤ] (S → ℤ) where
+  toFun φ s := φ (Additive.ofMul (s : G))
+  map_add' _ _ := rfl
+  map_smul' _ _ := rfl
+
+theorem evalGen_injective {S : Set G} (hS : Subgroup.closure S = ⊤) :
+    Function.Injective (evalGen S) := by
+  intro φ ψ h
+  refine AddMonoidHom.ext fun γ => ?_
+  have hmem : Additive.toMul γ ∈ Subgroup.closure S := hS ▸ Subgroup.mem_top _
+  suffices hkey : φ (Additive.ofMul (Additive.toMul γ)) = ψ (Additive.ofMul (Additive.toMul γ)) by
+    simpa using hkey
+  set g := Additive.toMul γ
+  clear_value g; clear γ
+  induction hmem using Subgroup.closure_induction with
+  | mem s hs => exact congrFun h ⟨s, hs⟩
+  | one => simp
+  | mul a b _ _ iha ihb =>
+      have hmul : (Additive.ofMul (a * b) : Additive G) = Additive.ofMul a + Additive.ofMul b := rfl
+      rw [hmul, map_add, map_add, iha, ihb]
+  | inv a _ iha =>
+      have hinv : (Additive.ofMul a⁻¹ : Additive G) = -Additive.ofMul a := rfl
+      rw [hinv, map_neg, map_neg, iha]
+
+theorem addHom_int_moduleFinite [Group.FG G] : Module.Finite ℤ (Additive G →+ ℤ) := by
+  obtain ⟨S, hS, hSfin⟩ := Group.fg_iff.mp ‹Group.FG G›
+  have : Finite S := hSfin
+  exact Module.Finite.of_injective (evalGen S) (evalGen_injective hS)
+
+instance instIsNoetherian_addHom_int (N : ℕ) [NeZero N] :
+    IsNoetherian ℤ (Additive (Gamma0 N) →+ ℤ) :=
+  have := addHom_int_moduleFinite (G := (Gamma0 N))
+  inferInstance
+
+theorem moduleEnd_addHom_int_moduleFinite [Group.FG G] :
+    Module.Finite ℤ (Module.End ℤ (Additive G →+ ℤ)) := by
+  have := addHom_int_moduleFinite (G := G)
+  set M := Additive G →+ ℤ
+  obtain ⟨s, hs⟩ := Module.Finite.fg_top (R := ℤ) (M := M)
+  let ev : Module.End ℤ M →ₗ[ℤ] (s → M) :=
+    { toFun := fun f i => f (i : M)
+      map_add' := fun _ _ => rfl
+      map_smul' := fun _ _ => rfl }
+  refine Module.Finite.of_injective ev ?_
+  rw [← LinearMap.ker_eq_bot, eq_bot_iff]
+  intro f hf
+  simp only [Submodule.mem_bot, LinearMap.mem_ker] at hf ⊢
+  refine LinearMap.ext fun m => ?_
+  have hm : m ∈ (⊤ : Submodule ℤ M) := Submodule.mem_top
+  rw [← hs] at hm
+  refine Submodule.span_induction ?_ ?_ ?_ ?_ hm
+  · intro x hx
+    exact congrFun hf ⟨x, hx⟩
+  · simp
+  · intro x y _ _ ihx ihy
+    simp [map_add, ihx, ihy]
+  · intro c x _ ihx
+    simp [map_smul, ihx]
+
+end FGInfrastructure
+
+section Vocabulary
+
+variable (N ℓ : ℕ) [NeZero ℓ]
+
+noncomputable def heckeOperatorEndHom : Module.End ℤ (Additive (Gamma0 N) →+ ℤ) :=
+  AddMonoidHom.toIntLinearMap (HeckeEis.heckeOperatorHom N ℓ ℤ)
+
+variable [NeZero N] (S : Set ℕ)
+
+noncomputable def heckeAlgebraHom :
+    Subalgebra ℤ (Module.End ℤ (Additive (Gamma0 N) →+ ℤ)) :=
+  Algebra.adjoin ℤ
+    {T | ∃ (ℓ : ℕ) (_ : NeZero ℓ), ℓ.Prime ∧ ℓ ∉ S ∧ T = heckeOperatorEndHom N ℓ}
+
+end Vocabulary
+
+section ParabolicFiniteness
+
+variable (N : ℕ) [NeZero N]
+
+instance parabolicHoms_int_moduleFinite :
+    Module.Finite ℤ (parabolicHoms ℤ (Gamma0 N) ℤ) :=
+  Module.Finite.of_injective (parabolicHoms ℤ (Gamma0 N) ℤ).subtype
+    (parabolicHoms ℤ (Gamma0 N) ℤ).injective_subtype
+
+end ParabolicFiniteness
+
+end ModularCurve.Period
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_HeckeDifferential.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_HeckeDifferential.lean
new file mode 100644
index 0000000000..f975efb3db
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_HeckeDifferential.lean
@@ -0,0 +1,250 @@
+/-
+Based on Prove2Me node ModularCurve_HeckeDifferential
+(d49f4f0c-8254-583b-afd9-67769d45a933) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DifferentialPushPull
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RegularDifferentials
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_HeckeOperator
+
+/-!
+# Euler derivation, q-expansion of differentials, Hecke action
+
+Definition: `ModularCurve_HeckeDifferential` (`d49f4f0c-8254-583b-afd9-67769d45a933`), by Claude,
+2026-09-05.
+
+Over a commutative ring $R$,
+[`ModularCurve.qEulerFun`](../def/ModularCurve_HeckeDifferential.html#L18) sends a Laurent series
+$x\in R((q))$ to the series with coefficients $n\,x_n$, and
+[`ModularCurve.qEuler`](../def/ModularCurve_HeckeDifferential.html#L40) packages this as a
+derivation of $R((q))$ over $R$, namely $\vartheta = q\,d/dq$; the Leibniz rule is verified
+coefficientwise, and `qEuler_single` records $\vartheta(rq^n) = n r q^n$. Auxiliary lemmas give the
+support inclusion $\operatorname{supp}(\vartheta x)\subseteq\operatorname{supp}(x)$ and the identity
+$\operatorname{algebraMap}(c)=\mathrm{single}\,0\,c$.
+
+For a field $L$ and an intermediate field $F$ of $L\subseteq L((q))$,
+[`ModularCurve.qEulerOn`](../def/ModularCurve_HeckeDifferential.html#L123) is the restriction of
+$\vartheta$ to $F$, viewed as an $L$-derivation $F\to L((q))$, and
+[`ModularCurve.diffQExp`](../def/ModularCurve_HeckeDifferential.html#L128) is its universal
+factorisation through the module of Kähler differentials: the $F$-linear map $\Omega_{F/L}\to
+L((q))$ with $d x\mapsto \vartheta x$, hence $f\,dx\mapsto f\cdot\vartheta x$. Thus a differential
+written as $h\,dq/q$ is sent to $h$. Instance declarations supply the $L$-algebra structure on $F$,
+the $L$-module structure and scalar tower on $\Omega_{F/L}$, and the scalar tower $L$–$F$–$L((q))$.
+
+In the modular setting, for a field $L$ containing $\mathbb{Q}$ and positive integers $N,\ell$,
+[`ModularCurve.heckeDiffAlong`](../def/ModularCurve_HeckeDifferential.html#L145) is the endomorphism
+of $\Omega_{L\cdot F_N/L}$ given by `Differential.correspondence` applied to the pair
+$(\beta,\alpha)$, i.e. the pullback along $\alpha$ (the inclusion of the base-changed full modular
+function field of level $N$ into that of level $N\ell$) followed by the trace along $\beta$ (the
+substitution $q\mapsto q^{\ell}$); the trace leg is defined via the formally étale base-change
+equivalence when the extension along $\beta$ is separable, and is $0$ otherwise.
+[`ModularCurve.heckeDiffBar`](../def/ModularCurve_HeckeDifferential.html#L163) specialises this to
+$L=\overline{\mathbb{Q}}$ and a prime $\ell$, an $\overline{\mathbb{Q}}$-linear endomorphism of
+$\Omega_{\overline{\mathbb{Q}}F_N/\overline{\mathbb{Q}}}$. Finally
+[`ModularCurve.diffQExpBar`](../def/ModularCurve_HeckeDifferential.html#L174) and
+[`ModularCurve.regularDifferentialsBar`](../def/ModularCurve_HeckeDifferential.html#L178)
+abbreviate, at $L=\overline{\mathbb{Q}}$, the $q$-expansion map and the submodule of differentials
+$\omega$ such that at every place $v$ one has $\omega = f\cdot d\pi_v$ with $f$ in the valuation
+ring of $v$ and $\pi_v$ the chosen uniformiser.
+
+**Relation to Mathlib.** Mathlib supplies `LaurentSeries`, `Derivation` and `KaehlerDifferential`;
+the derivation $q\,d/dq$ on $R((q))$, the induced $q$-expansion map on Kähler differentials, and the
+pullback/trace correspondence on differentials along an algebra map (from the project's
+`AlgebraicCurve.Differential`) are the project's own notions.
+
+**Where it is used.** The $q$-expansion map on differentials is what converts regular differentials
+on the modular curve into power series, giving the dictionary between $H^0(\Omega^1)$ and weight-two
+cusp forms; `heckeDiffBar` is the Hecke correspondence acting on differentials, the cotangent
+counterpart of the Hecke action on $\mathrm{Pic}^0$ of the modular curve used throughout the
+modularity and level-lowering arguments.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open HahnSeries KaehlerDifferential AlgebraicCurve
+
+namespace ModularCurve
+
+section Euler
+
+variable (R : Type*) [CommRing R]
+
+def qEulerFun (x : LaurentSeries R) : LaurentSeries R where
+  coeff n := (n : R) * x.coeff n
+  isPWO_support' := x.isPWO_support.mono fun n hn => by
+    simp only [Function.mem_support, ne_eq] at hn ⊢
+    intro h
+    exact hn (by rw [h, mul_zero])
+
+@[simp] theorem qEulerFun_coeff (x : LaurentSeries R) (n : ℤ) :
+    (qEulerFun R x).coeff n = (n : R) * x.coeff n := rfl
+
+theorem support_qEulerFun_subset (x : LaurentSeries R) :
+    (qEulerFun R x).support ⊆ x.support := fun n hn => by
+  contrapose! hn
+  simp only [mem_support, ne_eq, not_not] at hn ⊢
+  rw [qEulerFun_coeff, hn, mul_zero]
+
+theorem algebraMap_laurentSeries_apply_alt (c : R) :
+    algebraMap R (LaurentSeries R) c = single 0 c := by
+  have h1 : algebraMap R (PowerSeries R) c = PowerSeries.C c := by simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+  rfl
+
+def qEuler : Derivation R (LaurentSeries R) (LaurentSeries R) where
+  toFun := qEulerFun R
+  map_add' x y := by
+    ext n
+    simp only [qEulerFun_coeff, coeff_add, mul_add]
+  map_smul' r x := by
+    ext n
+    simp only [RingHom.id_apply, qEulerFun_coeff]
+    rw [Algebra.smul_def, algebraMap_laurentSeries_apply_alt, coeff_single_zero_mul,
+      HahnSeries.coeff_smul,
+      qEulerFun_coeff, smul_eq_mul]
+    ring
+  map_one_eq_zero' := by
+    ext n
+    simp only [LinearMap.coe_mk, AddHom.coe_mk, qEulerFun_coeff, coeff_zero]
+    by_cases hn : n = 0
+    · subst hn; simp
+    · rw [coeff_one, ite_eq_right hn, mul_zero]
+  leibniz' x y := by
+    ext a
+    simp only [LinearMap.coe_mk, AddHom.coe_mk, qEulerFun_coeff, coeff_add', Pi.add_apply,
+      smul_eq_mul]
+    rw [coeff_mul,
+      coeff_mul_right' (x := x) (y := qEulerFun R y) y.isPWO_support (support_qEulerFun_subset R y),
+      coeff_mul_right' (x := y) (y := qEulerFun R x) x.isPWO_support (support_qEulerFun_subset R x),
+      Finset.mul_sum]
+    have hswap : ∑ ij ∈ Finset.antidiagonal y.isPWO_support x.isPWO_support a,
+        y.coeff ij.1 * (qEulerFun R x).coeff ij.2
+        = ∑ ij ∈ Finset.antidiagonal x.isPWO_support y.isPWO_support a,
+            (ij.1 : R) * x.coeff ij.1 * y.coeff ij.2 := by
+      refine Finset.sum_nbij' Prod.swap Prod.swap ?_ ?_ ?_ ?_ ?_
+      · intro ij hij
+        exact Finset.swap_mem_antidiagonal.mpr hij
+      · intro ij hij
+        exact Finset.swap_mem_antidiagonal.mpr hij
+      · intro ij _; rfl
+      · intro ij _; rfl
+      · intro ij _
+        simp only [Prod.fst_swap, Prod.snd_swap, qEulerFun_coeff]
+        ring
+    rw [hswap, ← Finset.sum_add_distrib]
+    refine Finset.sum_congr rfl fun ij hij => ?_
+    rw [Finset.mem_antidiagonal] at hij
+    rw [qEulerFun_coeff, ← hij.2.2, Int.cast_add]
+    ring
+
+@[simp] theorem qEuler_coeff (x : LaurentSeries R) (n : ℤ) :
+    (qEuler R x).coeff n = (n : R) * x.coeff n := rfl
+
+theorem qEuler_single (n : ℤ) (r : R) :
+    qEuler R (single n r) = single n ((n : R) * r) := by
+  ext m
+  by_cases h : m = n
+  · subst h; simp
+  · simp [coeff_single_of_ne h]
+
+end Euler
+
+section Shortcuts
+
+variable {L : Type*} [Field L] (F : IntermediateField L (LaurentSeries L))
+
+instance instAlgebraIntermediateFieldLaurent : Algebra L F := inferInstance
+
+instance instModuleKaehlerIntermediateFieldLaurent : Module L Ω[F⁄L] := inferInstance
+
+instance instIsScalarTowerKaehlerIntermediateFieldLaurent : IsScalarTower L F Ω[F⁄L] :=
+  inferInstance
+
+instance instIsScalarTowerIntermediateFieldLaurent : IsScalarTower L F (LaurentSeries L) :=
+  ⟨fun c f x => by
+    change ((c • f : F) : LaurentSeries L) * x = c • ((f : LaurentSeries L) * x)
+    rw [IntermediateField.coe_smul, Algebra.smul_def, algebraMap_laurentSeries_eq_single,
+      ← C_apply, mul_assoc, C_mul_eq_smul]⟩
+
+end Shortcuts
+
+section QExpansion
+
+variable {L : Type*} [Field L] (F : IntermediateField L (LaurentSeries L))
+
+def qEulerOn : Derivation L F (LaurentSeries L) :=
+  (qEuler L).compAlgebraMap F
+
+@[simp] theorem qEulerOn_apply (x : F) : qEulerOn F x = qEuler L (x : LaurentSeries L) := rfl
+
+def diffQExp : Ω[F⁄L] →ₗ[F] LaurentSeries L :=
+  (qEulerOn F).liftKaehlerDifferential
+
+@[simp] theorem diffQExp_D (x : F) : diffQExp F (D L F x) = qEuler L (x : LaurentSeries L) :=
+  (qEulerOn F).liftKaehlerDifferential_comp_D x
+
+theorem diffQExp_smul_D (f x : F) :
+    diffQExp F (f • D L F x) = (f : LaurentSeries L) * qEuler L (x : LaurentSeries L) := by
+  rw [map_smul, diffQExp_D]
+  rfl
+
+end QExpansion
+
+section Hecke
+
+variable (L : Type*) [Field L] [Algebra ℚ L] (N ℓ : ℕ) [NeZero N] [NeZero ℓ]
+
+def heckeDiffAlong :
+    Ω[laurentBaseChange L (modularFunctionFieldFull N)⁄L] →ₗ[L]
+      Ω[laurentBaseChange L (modularFunctionFieldFull N)⁄L] :=
+  Differential.correspondence (heckeBetaBar L N ℓ) (heckeAlphaBar L N ℓ)
+
+theorem heckeDiffAlong_apply (ω : Ω[laurentBaseChange L (modularFunctionFieldFull N)⁄L]) :
+    heckeDiffAlong L N ℓ ω =
+      Differential.traceAlong (heckeBetaBar L N ℓ) (Differential.pullbackAlong (heckeAlphaBar L N ℓ)
+        ω) :=
+  rfl
+
+end Hecke
+
+section Bar
+
+variable (N : ℕ)
+
+variable [NeZero N]
+
+def heckeDiffBar (ℓ : Nat.Primes) :
+    Module.End (AlgebraicClosure ℚ) Ω[modularFunctionFieldBar N⁄AlgebraicClosure ℚ] :=
+  haveI : NeZero (ℓ : ℕ) := ⟨ℓ.2.ne_zero⟩
+  heckeDiffAlong (AlgebraicClosure ℚ) N ℓ
+
+theorem heckeDiffBar_eq (ℓ : Nat.Primes) :
+    heckeDiffBar N ℓ = (haveI : NeZero (ℓ : ℕ) := ⟨ℓ.2.ne_zero⟩;
+      Differential.correspondence (heckeBetaBar (AlgebraicClosure ℚ) N ℓ)
+        (heckeAlphaBar (AlgebraicClosure ℚ) N ℓ)) :=
+  rfl
+
+abbrev diffQExpBar : Ω[modularFunctionFieldBar N⁄AlgebraicClosure ℚ] →ₗ[modularFunctionFieldBar N]
+    LaurentSeries (AlgebraicClosure ℚ) :=
+  diffQExp (modularFunctionFieldBar N)
+
+abbrev regularDifferentialsBar : Submodule (AlgebraicClosure ℚ)
+    Ω[modularFunctionFieldBar N⁄AlgebraicClosure ℚ] :=
+  regularDifferentials (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+
+end Bar
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_HeckeModule.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_HeckeModule.lean
new file mode 100644
index 0000000000..14df97e2e9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_HeckeModule.lean
@@ -0,0 +1,177 @@
+/-
+Based on Prove2Me node ModularCurve_HeckeModule
+(26237ed0-0df1-5be8-a77f-32be668b2f33) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_HeckeOperatorTotal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeGalois_EichlerShimura
+
+/-!
+# Hecke algebra action on J0​(N)(Q​), guarded by commutation
+
+Definition: `ModularCurve_HeckeModule` (`26237ed0-0df1-5be8-a77f-32be668b2f33`), by Claude,
+2026-09-05.
+
+For $N\ge 1$ (a `NeZero N` fence, so level $0$ is unstatable) this module turns the project's
+individual Hecke operators on `JZero N` into a module structure over the project's Hecke algebra
+`HeckeAlg`. First, `heckeOperatorBar N ℓ : Module.End ℤ (JZero N)` is, for a prime $\ell$, the total
+operator `heckeOperatorAlong (AlgebraicClosure ℚ) N ℓ` of the imported module (so: the operator
+taken along $\overline{\mathbb{Q}}$, with the `NeZero` instance for $\ell$ supplied from primality)
+read as a $\mathbb{Z}$-linear endomorphism; `heckeOperatorBar_apply` records that this is
+definitionally the same map. Second, `HeckeOperatorsCommuteBar N` is the proposition that these
+endomorphisms commute pairwise, for all pairs of primes; it is only defined here, never proved here.
+Third, from such a hypothesis `h`, `isMulCommutative_adjoin_heckeOperatorBar` gives that the
+$\mathbb{Z}$-subalgebra of `Module.End ℤ (JZero N)` generated by the range of `heckeOperatorBar N`
+is commutative, whence `heckeEvalBarAux h` is the `MvPolynomial.aeval` map into that subalgebra
+sending the variable at $\ell$ to `heckeOperatorBar N ℓ`, and `heckeEvalBar h : HeckeAlg →+*
+Module.End ℤ (JZero N)` is its composite with the inclusion; `heckeEvalBar_heckeGen` and
+`heckeEvalBar_C` record the values on generators and on integer constants. (The use of
+`MvPolynomial.aeval`, `MvPolynomial.C` and `MvPolynomial.constantCoeff` on `HeckeAlg` exhibits it as
+the polynomial ring over $\mathbb{Z}$ on the primes, with `heckeGen ℓ` the variable at $\ell$.)
+Finally `heckeModuleBar N : Module HeckeAlg (JZero N)` is a total definition by cases on the
+decidable-by-classical-choice proposition `HeckeOperatorsCommuteBar N`: if it holds, the action is
+`Module.compHom` along `heckeEvalBar h`; otherwise it is the junk action through $t \mapsto$ its
+constant term, under which every `heckeGen ℓ` acts by $0$. The remaining lemmas are the normal forms
+for computing with this `dite`: $t \bullet x =$ `heckeEvalBar h t x` and `heckeGen ℓ • x =
+heckeOperatorBar N ℓ x` under `h`, the two junk-branch analogues, and `heckeModuleBar_C_smul`, which
+holds in both branches. Note that `heckeModuleBar` is a plain `def` (marked
+`@[implicit_reducible]`), not an instance.
+
+**Relation to Mathlib.** Mathlib has no Hecke algebra or Hecke action on Jacobians of modular
+curves; `HeckeAlg`, `heckeGen`, `JZero` and `heckeOperatorAlong` are the project's own, imported
+from other definition modules. The construction itself is assembled from Mathlib's
+`MvPolynomial.aeval`, `Algebra.adjoin`, `IsMulCommutative` and `Module.compHom`.
+
+**Where it is used.** This is the form in which the Hecke action on $J_0(N)$ is fed to the later
+parts of the argument: statements about the Eisenstein ideal, the cuspidal class and specialisation
+are phrased against an explicit `Module HeckeAlg (JZero N)` binder and instantiated at
+`heckeModuleBar N`. Since nothing about commutation is proved here, consumers of the non-junk normal
+forms must carry `HeckeOperatorsCommuteBar N` as a hypothesis.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+namespace ModularCurve
+
+open AlgebraicCurve
+
+section Operators
+
+variable (N : ℕ) [NeZero N]
+
+def heckeOperatorBar (ℓ : Nat.Primes) : Module.End ℤ (JZero N) :=
+  haveI : NeZero (ℓ : ℕ) := ⟨ℓ.2.ne_zero⟩
+  (heckeOperatorAlong (AlgebraicClosure ℚ) N ℓ).toIntLinearMap
+
+theorem heckeOperatorBar_apply (ℓ : Nat.Primes) (x : JZero N) :
+    heckeOperatorBar N ℓ x =
+      (haveI : NeZero (ℓ : ℕ) := ⟨ℓ.2.ne_zero⟩; heckeOperatorAlong (AlgebraicClosure ℚ) N ℓ x) :=
+  rfl
+
+def HeckeOperatorsCommuteBar : Prop :=
+  ∀ ℓ ℓ' : Nat.Primes,
+    heckeOperatorBar N ℓ * heckeOperatorBar N ℓ' = heckeOperatorBar N ℓ' * heckeOperatorBar N ℓ
+
+end Operators
+
+section Eval
+
+variable {N : ℕ} [NeZero N]
+
+theorem isMulCommutative_adjoin_heckeOperatorBar (h : HeckeOperatorsCommuteBar N) :
+    IsMulCommutative (Algebra.adjoin ℤ (Set.range (heckeOperatorBar N))) :=
+  Algebra.isMulCommutative_adjoin ℤ (by
+    rintro _ ⟨ℓ, rfl⟩ _ ⟨ℓ', rfl⟩ _
+    exact h ℓ ℓ')
+
+open scoped IsMulCommutative in
+def heckeEvalBarAux (h : HeckeOperatorsCommuteBar N) :
+    HeckeAlg →ₐ[ℤ] (Algebra.adjoin ℤ (Set.range (heckeOperatorBar N)) :
+      Subalgebra ℤ (Module.End ℤ (JZero N))) :=
+  haveI := isMulCommutative_adjoin_heckeOperatorBar h
+  MvPolynomial.aeval fun ℓ =>
+    (⟨heckeOperatorBar N ℓ, Algebra.subset_adjoin (Set.mem_range_self ℓ)⟩ :
+      Algebra.adjoin ℤ (Set.range (heckeOperatorBar N)))
+
+def heckeEvalBar (h : HeckeOperatorsCommuteBar N) : HeckeAlg →+* Module.End ℤ (JZero N) :=
+  ((Algebra.adjoin ℤ (Set.range (heckeOperatorBar N))).val.comp (heckeEvalBarAux h)).toRingHom
+
+theorem heckeEvalBar_apply (h : HeckeOperatorsCommuteBar N) (t : HeckeAlg) :
+    heckeEvalBar h t = (heckeEvalBarAux h t : Module.End ℤ (JZero N)) :=
+  rfl
+
+open scoped IsMulCommutative in
+theorem heckeEvalBarAux_heckeGen (h : HeckeOperatorsCommuteBar N) (ℓ : Nat.Primes) :
+    heckeEvalBarAux h (heckeGen ℓ) =
+      ⟨heckeOperatorBar N ℓ, Algebra.subset_adjoin (Set.mem_range_self ℓ)⟩ :=
+  haveI := isMulCommutative_adjoin_heckeOperatorBar h
+  MvPolynomial.aeval_X _ ℓ
+
+theorem heckeEvalBar_heckeGen (h : HeckeOperatorsCommuteBar N) (ℓ : Nat.Primes) :
+    heckeEvalBar h (heckeGen ℓ) = heckeOperatorBar N ℓ := by
+  rw [heckeEvalBar_apply, heckeEvalBarAux_heckeGen]
+
+theorem heckeEvalBar_C (h : HeckeOperatorsCommuteBar N) (a : ℤ) :
+    heckeEvalBar h (MvPolynomial.C a) = (a : Module.End ℤ (JZero N)) := by
+  rw [← MvPolynomial.algebraMap_eq, eq_intCast, map_intCast]
+
+end Eval
+
+section TheModule
+
+variable (N : ℕ) [NeZero N]
+
+open Classical in
+@[implicit_reducible]
+def heckeModuleBar : Module HeckeAlg (JZero N) :=
+  if h : HeckeOperatorsCommuteBar N then Module.compHom (JZero N) (heckeEvalBar h)
+  else Module.compHom (JZero N) (MvPolynomial.eval₂Hom (Int.castRingHom ℤ) (0 : Nat.Primes → ℤ))
+
+variable {N}
+
+theorem heckeModuleBar_smul_def (h : HeckeOperatorsCommuteBar N) (t : HeckeAlg) (x : JZero N) :
+    (letI := heckeModuleBar N; t • x) = heckeEvalBar h t x := by
+  have e : heckeModuleBar N = Module.compHom (JZero N) (heckeEvalBar h) := dite_eq_left h
+  rw [e]
+  rfl
+
+theorem heckeModuleBar_heckeGen_smul (h : HeckeOperatorsCommuteBar N) (ℓ : Nat.Primes)
+    (x : JZero N) : (letI := heckeModuleBar N; heckeGen ℓ • x) = heckeOperatorBar N ℓ x := by
+  rw [heckeModuleBar_smul_def h, heckeEvalBar_heckeGen]
+
+theorem heckeModuleBar_smul_of_not (h : ¬ HeckeOperatorsCommuteBar N) (t : HeckeAlg) (x : JZero N) :
+    (letI := heckeModuleBar N; t • x) = MvPolynomial.constantCoeff t • x := by
+  have e : heckeModuleBar N =
+      Module.compHom (JZero N)
+        (MvPolynomial.eval₂Hom (Int.castRingHom ℤ) (0 : Nat.Primes → ℤ)) :=
+    dite_eq_right h
+  rw [e]
+  change (MvPolynomial.eval₂Hom (Int.castRingHom ℤ) (0 : Nat.Primes → ℤ) t) • x = _
+  rw [MvPolynomial.eval₂Hom_zero_apply, eq_intCast, Int.cast_id]
+
+theorem heckeModuleBar_heckeGen_smul_of_not (h : ¬ HeckeOperatorsCommuteBar N) (ℓ : Nat.Primes)
+    (x : JZero N) : (letI := heckeModuleBar N; heckeGen ℓ • x) = 0 := by
+  rw [heckeModuleBar_smul_of_not h, heckeGen, MvPolynomial.constantCoeff_X, zero_zsmul]
+
+theorem heckeModuleBar_C_smul (a : ℤ) (x : JZero N) :
+    (letI := heckeModuleBar N; (MvPolynomial.C a : HeckeAlg) • x) = a • x := by
+  by_cases h : HeckeOperatorsCommuteBar N
+  · rw [heckeModuleBar_smul_def h, heckeEvalBar_C, Module.End.intCast_apply]
+  · rw [heckeModuleBar_smul_of_not h, MvPolynomial.constantCoeff_C]
+
+end TheModule
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_HeckeOperator.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_HeckeOperator.lean
new file mode 100644
index 0000000000..ec6c5d336a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_HeckeOperator.lean
@@ -0,0 +1,240 @@
+/-
+Based on Prove2Me node ModularCurve_HeckeOperator
+(3ee957fd-f3e0-5644-9c4f-61ba3a922f18) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ArithmeticGalois
+
+/-!
+# Hecke correspondences on base-changed modular function fields
+
+Definition: `ModularCurve_HeckeOperator` (`3ee957fd-f3e0-5644-9c4f-61ba3a922f18`), by Claude,
+2026-09-05.
+
+Fix a field $L$ of characteristic zero ($L$ a field with a $\mathbb{Q}$-algebra structure), a level
+$N$ and an index $\ell$, both nonzero. All objects live on the base change `laurentBaseChange L
+(modularFunctionFieldFull N)`, the intermediate field of $L((q))$ generated over $L$ by the
+coefficientwise image of the project's full modular function field of level $N$ (imported from
+`ModularCurve_ArithmeticGalois`); at $L=\overline{\mathbb{Q}}$ this is `modularFunctionFieldBar N`,
+whose `Pic0` is `JZero N`. Two $L$-algebra maps from level $N$ to level $N\ell$ are defined:
+`heckeAlphaBar`, which is literally `IntermediateField.inclusion` applied to the monotonicity of
+`laurentBaseChange` along the degeneracy inclusion for $N \mid N\ell$ (so it is the identity on
+underlying Laurent series, `coe_heckeAlphaBar`), and `heckeBetaBar`, the substitution $q \mapsto
+q^{\ell}$ given by the project's `qExpand L ℓ` on $L((q))$ (`coe_heckeBetaBar`), built from the ring
+homomorphism `heckeBetaBarRingHom` and shown to fix $L$; that $q \mapsto q^{\ell}$ maps the
+level-$N$ field into the level-$N\ell$ field is supplied by the private helpers `coeffMap_qExpand'`,
+`coeffEmb_qExpand'`, `laurentBaseChange_mono'` and `qExpand_mem_laurentBaseChange'`. Two predicates
+record integrality of these maps as ring homomorphisms: `HeckeAlphaBarIntegral`,
+`HeckeBetaBarIntegral`. Given these, `heckeDivBar` is `Divisor.correspondence (heckeBetaBar …)
+(heckeAlphaBar …)`, i.e. push-forward along $\alpha$ of pull-back along $\beta$, an additive
+endomorphism of the divisor group of the level-$N$ field over $L$; `heckePic0Bar` is the
+corresponding endomorphism of `Pic0`, taking as further explicit binders the fundamental identity
+along $\beta$ and the finiteness and norm formula along $\alpha$ from
+`AlgebraicCurve_Correspondence`, together with an instance binder `HasPrincipalDivisors L` at level
+$N\ell$. `heckeDivBarTranspose` and `heckePic0BarTranspose` are the same constructions with the
+roles of $\alpha$ and $\beta$ exchanged. The module only constructs these maps: no primality of
+$\ell$ is assumed, $\ell \mid N$ and $\ell = 1$ are permitted, nothing is proved about the
+operators, and neither orientation is identified with the classical action $a_n \mapsto a_{n\ell} +
+\ell a_{n/\ell}$ on $q$-expansions. Two `example`s check that at $L = \overline{\mathbb{Q}}$ the
+maps land on `modularFunctionFieldBar` and give an endomorphism of `JZero N`.
+
+**Relation to Mathlib.** Mathlib has no Hecke correspondence on Jacobians of modular curves; the
+function-field carriers (`modularFunctionFieldFull`, `laurentBaseChange`, `qExpand`), the divisor
+and `Pic0` formalism and `Divisor.correspondence`/`Pic0.correspondence` are the project's own,
+imported from its definition modules. Only `IntermediateField.inclusion` and the
+`RingHom.IsIntegral` predicate used in the integrality definitions come from Mathlib.
+
+**Where it is used.** These endomorphisms provide the Hecke action on the Jacobian $J_0(N)$ in the
+form used later for the Eichler–Shimura relation and for the Galois representations attached to
+modular forms, which is what the Frey curve route to Fermat's Last Theorem requires.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public noncomputable section publicSection
+
+open IsDedekindDomain
+
+namespace ModularCurve
+
+open AlgebraicCurve IntermediateField HahnSeries
+
+section PrivateSupply
+
+variable {L : Type*} [Field L] [Algebra ℚ L]
+
+private theorem coeffMap_qExpand' {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S) (n : ℕ)
+    [NeZero n] (x : LaurentSeries R) : coeffMap f (qExpand R n x) = qExpand S n (coeffMap f x) := by
+  ext k
+  by_cases hk : (n : ℤ) ∣ k
+  · obtain ⟨m, rfl⟩ := hk
+    rw [coeffMap_coeff, qExpand_coeff_mul, qExpand_coeff_mul, coeffMap_coeff]
+  · rw [coeffMap_coeff, qExpand_coeff_of_not_dvd n _ hk, qExpand_coeff_of_not_dvd n _ hk,
+      map_zero]
+
+private theorem coeffEmb_qExpand' (L : Type*) [Field L] [Algebra ℚ L] (n : ℕ) [NeZero n]
+    (x : LaurentSeries ℚ) : coeffEmb L (qExpand ℚ n x) = qExpand L n (coeffEmb L x) :=
+  coeffMap_qExpand' _ n x
+
+variable (L) in
+theorem laurentBaseChange_mono' {F₀ F₁ : IntermediateField ℚ (LaurentSeries ℚ)}
+    (h : F₀ ≤ F₁) : laurentBaseChange L F₀ ≤ laurentBaseChange L F₁ := by
+  rw [laurentBaseChange, IntermediateField.adjoin_le_iff]
+  rintro _ ⟨y, hy, rfl⟩
+  exact coeffEmb_mem_laurentBaseChange L (h hy)
+
+theorem qExpand_mem_laurentBaseChange' {F₀ : IntermediateField ℚ (LaurentSeries ℚ)} (n : ℕ)
+    [NeZero n] {F₁ : IntermediateField ℚ (LaurentSeries ℚ)} (hF : ∀ y ∈ F₀, qExpand ℚ n y ∈ F₁)
+    {x : LaurentSeries L} (hx : x ∈ laurentBaseChange L F₀) :
+    qExpand L n x ∈ laurentBaseChange L F₁ := by
+  rw [mem_laurentBaseChange_iff] at hx
+  induction hx using Subfield.closure_induction with
+  | mem y hy =>
+      rcases hy with ⟨a, rfl⟩ | ⟨z, hz, rfl⟩
+      · rw [algebraMap_laurentSeries_eq_single, qExpand_single, mul_zero,
+          ← algebraMap_laurentSeries_eq_single]
+        exact (laurentBaseChange L F₁).algebraMap_mem _
+      · rw [← coeffEmb_qExpand']
+        exact coeffEmb_mem_laurentBaseChange L (hF z hz)
+  | one => simp
+  | add x y _ _ hx hy => simpa using add_mem hx hy
+  | neg x _ hx => simpa using neg_mem hx
+  | inv x _ hx => simpa using inv_mem hx
+  | mul x y _ _ hx hy => simpa using mul_mem hx hy
+
+end PrivateSupply
+
+variable {L : Type*} [Field L] [Algebra ℚ L]
+variable (N ℓ : ℕ) [NeZero N] [NeZero ℓ]
+
+section DegeneracyMapsBar
+
+variable (L) in
+def heckeAlphaBar :
+    laurentBaseChange L (modularFunctionFieldFull N) →ₐ[L]
+      laurentBaseChange L (modularFunctionFieldFull (N * ℓ)) :=
+  IntermediateField.inclusion
+    (laurentBaseChange_mono' L (full_degeneracy_le (dvd_mul_right N ℓ)))
+
+@[simp]
+theorem coe_heckeAlphaBar (x : laurentBaseChange L (modularFunctionFieldFull N)) :
+    (heckeAlphaBar L N ℓ x : LaurentSeries L) = (x : LaurentSeries L) :=
+  IntermediateField.coe_inclusion _ x
+
+variable (L) in
+def heckeBetaBarRingHom :
+    laurentBaseChange L (modularFunctionFieldFull N) →+*
+      laurentBaseChange L (modularFunctionFieldFull (N * ℓ)) where
+  toFun x := ⟨qExpand L ℓ (x : LaurentSeries L),
+    qExpand_mem_laurentBaseChange' ℓ
+      (fun y hy => full_degeneracy_map_le (N := N) ℓ ⟨y, hy, rfl⟩) x.2⟩
+  map_one' := Subtype.ext (map_one (qExpand L ℓ))
+  map_mul' _ _ := Subtype.ext (map_mul (qExpand L ℓ) _ _)
+  map_zero' := Subtype.ext (map_zero (qExpand L ℓ))
+  map_add' _ _ := Subtype.ext (map_add (qExpand L ℓ) _ _)
+
+omit [NeZero N] in
+@[simp]
+theorem coe_heckeBetaBarRingHom (x : laurentBaseChange L (modularFunctionFieldFull N)) :
+    (heckeBetaBarRingHom L N ℓ x : LaurentSeries L) = qExpand L ℓ (x : LaurentSeries L) :=
+  rfl
+
+variable (L) in
+def heckeBetaBar :
+    laurentBaseChange L (modularFunctionFieldFull N) →ₐ[L]
+      laurentBaseChange L (modularFunctionFieldFull (N * ℓ)) :=
+  { heckeBetaBarRingHom L N ℓ with
+    commutes' := fun a => Subtype.ext <| by
+      change qExpand L ℓ (algebraMap L (LaurentSeries L) a) = algebraMap L (LaurentSeries L) a
+      rw [algebraMap_laurentSeries_eq_single, qExpand_single, mul_zero] }
+
+theorem heckeAlphaBar_eq_inclusion
+    (h : laurentBaseChange L (modularFunctionFieldFull N)
+      ≤ laurentBaseChange L (modularFunctionFieldFull (N * ℓ))) :
+    heckeAlphaBar L N ℓ = IntermediateField.inclusion h :=
+  rfl
+
+omit [NeZero N] in
+@[simp]
+theorem coe_heckeBetaBar (x : laurentBaseChange L (modularFunctionFieldFull N)) :
+    (heckeBetaBar L N ℓ x : LaurentSeries L) = qExpand L ℓ (x : LaurentSeries L) :=
+  rfl
+
+end DegeneracyMapsBar
+
+section HeckePic0Bar
+
+variable (L) in
+def HeckeAlphaBarIntegral : Prop :=
+  (heckeAlphaBar L N ℓ).toRingHom.IsIntegral
+
+variable (L) in
+def HeckeBetaBarIntegral : Prop :=
+  (heckeBetaBar L N ℓ).toRingHom.IsIntegral
+
+variable {N ℓ}
+variable (hα : HeckeAlphaBarIntegral L N ℓ) (hβ : HeckeBetaBarIntegral L N ℓ)
+variable [HasPrincipalDivisors L (laurentBaseChange L (modularFunctionFieldFull (N * ℓ)))]
+
+def heckeDivBar :
+    Divisor L (laurentBaseChange L (modularFunctionFieldFull N)) →+
+      Divisor L (laurentBaseChange L (modularFunctionFieldFull N)) :=
+  Divisor.correspondence (heckeBetaBar L N ℓ) (heckeAlphaBar L N ℓ) hβ hα
+
+def heckePic0Bar
+    (hFI : FundamentalIdentityAlong L (heckeBetaBar L N ℓ) hβ)
+    (hfin : FiniteAlong L (heckeAlphaBar L N ℓ))
+    (hN : NormFormulaAlong L (heckeAlphaBar L N ℓ) hfin) :
+    Pic0 L (laurentBaseChange L (modularFunctionFieldFull N)) →+
+      Pic0 L (laurentBaseChange L (modularFunctionFieldFull N)) :=
+  Pic0.correspondence (heckeBetaBar L N ℓ) (heckeAlphaBar L N ℓ) hβ hα hFI hfin hN
+
+end HeckePic0Bar
+
+section Transpose
+
+variable {N ℓ}
+variable (hα : HeckeAlphaBarIntegral L N ℓ) (hβ : HeckeBetaBarIntegral L N ℓ)
+variable [HasPrincipalDivisors L (laurentBaseChange L (modularFunctionFieldFull (N * ℓ)))]
+
+def heckeDivBarTranspose :
+    Divisor L (laurentBaseChange L (modularFunctionFieldFull N)) →+
+      Divisor L (laurentBaseChange L (modularFunctionFieldFull N)) :=
+  Divisor.correspondence (heckeAlphaBar L N ℓ) (heckeBetaBar L N ℓ) hα hβ
+
+def heckePic0BarTranspose
+    (hFI : FundamentalIdentityAlong L (heckeAlphaBar L N ℓ) hα)
+    (hfin : FiniteAlong L (heckeBetaBar L N ℓ))
+    (hN : NormFormulaAlong L (heckeBetaBar L N ℓ) hfin) :
+    Pic0 L (laurentBaseChange L (modularFunctionFieldFull N)) →+
+      Pic0 L (laurentBaseChange L (modularFunctionFieldFull N)) :=
+  Pic0.correspondence (heckeAlphaBar L N ℓ) (heckeBetaBar L N ℓ) hα hβ hFI hfin hN
+
+end Transpose
+
+section ModularInstance
+
+example :
+    (modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ] (modularFunctionFieldBar (N * ℓ)) :=
+  heckeAlphaBar (AlgebraicClosure ℚ) N ℓ
+
+example (hα : HeckeAlphaBarIntegral (AlgebraicClosure ℚ) N ℓ)
+    (hβ : HeckeBetaBarIntegral (AlgebraicClosure ℚ) N ℓ)
+    [HasPrincipalDivisors (AlgebraicClosure ℚ) (modularFunctionFieldBar (N * ℓ))]
+    (hFI : FundamentalIdentityAlong (AlgebraicClosure ℚ) (heckeBetaBar (AlgebraicClosure ℚ) N ℓ) hβ)
+    (hfin : FiniteAlong (AlgebraicClosure ℚ) (heckeAlphaBar (AlgebraicClosure ℚ) N ℓ))
+    (hN : NormFormulaAlong (AlgebraicClosure ℚ) (heckeAlphaBar (AlgebraicClosure ℚ) N ℓ) hfin) :
+    JZero N →+ JZero N :=
+  heckePic0Bar hα hβ hFI hfin hN
+
+end ModularInstance
+
+end ModularCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_HeckeOperatorTotal.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_HeckeOperatorTotal.lean
new file mode 100644
index 0000000000..d7f816459c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_HeckeOperatorTotal.lean
@@ -0,0 +1,112 @@
+/-
+Based on Prove2Me node ModularCurve_HeckeOperatorTotal
+(5c65374f-a473-5c7f-ba2a-c6ecb2be1802) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_HeckeOperator
+
+/-!
+# A total Hecke operator on Pic⁰ of modular function fields
+
+Definition: `ModularCurve_HeckeOperatorTotal` (`5c65374f-a473-5c7f-ba2a-c6ecb2be1802`), by Claude,
+2026-09-05.
+
+Fix a field $L$ with a $\mathbb{Q}$-algebra structure and positive integers $N,\ell$ (encoded by
+`NeZero`). The ambient curve is the intermediate field $L\cdot F_N :=$ `laurentBaseChange L
+(modularFunctionFieldFull N)` inside $\mathrm{LaurentSeries}\,L$, i.e. the field generated over $L$
+by the coefficientwise image of $\mathbb{Q}(q\text{-expansions } j(q^d) : d \mid N)$, and its group
+`Pic0` of degree-zero divisor classes in the project's place-theoretic sense. Two $L$-algebra maps
+$L\cdot F_N \to L\cdot F_{N\ell}$ are available: `heckeAlphaBar`, the inclusion coming from $F_N
+\subseteq F_{N\ell}$, and `heckeBetaBar`, induced by $q \mapsto q^{\ell}$ (the Laurent-exponent
+dilation `qExpand L ℓ`).
+
+The first definition, `HeckeInputsAlong L N ℓ`, is a single proposition bundling, as an iterated
+existential over proofs, exactly the five inputs needed to form the correspondence: integrality of
+the ring maps underlying `heckeAlphaBar` and `heckeBetaBar`; the property `HasPrincipalDivisors` at
+level $N\ell$; finiteness of $L\cdot F_{N\ell}$ as a module over $L\cdot F_N$ along `heckeAlphaBar`;
+and the conjunction of the fundamental identity $\sum_{w\mid v} e_w \deg w = [F':F]\deg v$ along
+`heckeBetaBar` with the norm formula for divisor pushforward along `heckeAlphaBar`. Note that the
+finiteness witness is packed before the fundamental identity.
+
+The second definition, `heckeOperatorAlong L N ℓ`, is a total closed term: an additive endomorphism
+of $\mathrm{Pic}^0(L\cdot F_N)$ equal, by a case split on `HeckeInputsAlong L N ℓ`, to the
+correspondence $\alpha_*\circ\beta^*$ (`heckePic0Bar`, pullback along `heckeBetaBar` followed by
+pushforward along `heckeAlphaBar`) when witnesses exist, and to the zero map otherwise. The three
+accompanying lemmas record the constructor for `HeckeInputsAlong` from the five inputs, the
+identification of `heckeOperatorAlong` with `heckePic0Bar` whenever the inputs are in hand, and the
+value $0$ in the absence of inputs. Nothing is asserted about the inputs themselves, and no
+identification with the classical $T_\ell$ or $U_\ell$ action on $q$-expansions is made here.
+
+**Relation to Mathlib.** Places, divisors, degree-zero classes, `Pic0`, pushforward/pullback and the
+fundamental identity used here are the project's own `AlgebraicCurve` development; Mathlib
+contributes the Laurent series, intermediate field and valuation-subring infrastructure, and has no
+notion of Hecke correspondence on a Jacobian.
+
+**Where it is used.** This total term gives a single input-free symbol for the Hecke operator on the
+Jacobian of the modular curve of level $N$, so that statements about the Hecke action (in particular
+at $L = \overline{\mathbb{Q}}$, where the target is `JZero N`) can be formulated without carrying
+the five analytic and arithmetic inputs as binders. It serves the modular side of the argument,
+where Hecke eigenvalues on cuspidal classes and the Galois action on torsion of $J_0(N)$ are
+compared.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+namespace ModularCurve
+
+open AlgebraicCurve
+
+variable (L : Type*) [Field L] [Algebra ℚ L] (N ℓ : ℕ) [NeZero N] [NeZero ℓ]
+
+def HeckeInputsAlong : Prop :=
+  ∃ (_ : HeckeAlphaBarIntegral L N ℓ) (hβ : HeckeBetaBarIntegral L N ℓ)
+    (_ : HasPrincipalDivisors L (laurentBaseChange L (modularFunctionFieldFull (N * ℓ))))
+    (hfin : FiniteAlong L (heckeAlphaBar L N ℓ)),
+    FundamentalIdentityAlong L (heckeBetaBar L N ℓ) hβ ∧
+      NormFormulaAlong L (heckeAlphaBar L N ℓ) hfin
+
+open Classical in
+def heckeOperatorAlong :
+    Pic0 L (laurentBaseChange L (modularFunctionFieldFull N)) →+
+      Pic0 L (laurentBaseChange L (modularFunctionFieldFull N)) :=
+  if h : HeckeInputsAlong L N ℓ then
+    haveI := h.snd.snd.fst
+    heckePic0Bar h.fst h.snd.fst h.snd.snd.snd.snd.1 h.snd.snd.snd.fst h.snd.snd.snd.snd.2
+  else 0
+
+variable {L N ℓ}
+
+theorem heckeInputsAlong_intro (hα : HeckeAlphaBarIntegral L N ℓ) (hβ : HeckeBetaBarIntegral L N ℓ)
+    [hP : HasPrincipalDivisors L (laurentBaseChange L (modularFunctionFieldFull (N * ℓ)))]
+    (hFI : FundamentalIdentityAlong L (heckeBetaBar L N ℓ) hβ)
+    (hfin : FiniteAlong L (heckeAlphaBar L N ℓ))
+    (hN : NormFormulaAlong L (heckeAlphaBar L N ℓ) hfin) : HeckeInputsAlong L N ℓ :=
+  ⟨hα, hβ, hP, hfin, hFI, hN⟩
+
+theorem heckeOperatorAlong_eq (hα : HeckeAlphaBarIntegral L N ℓ) (hβ : HeckeBetaBarIntegral L N ℓ)
+    [HasPrincipalDivisors L (laurentBaseChange L (modularFunctionFieldFull (N * ℓ)))]
+    (hFI : FundamentalIdentityAlong L (heckeBetaBar L N ℓ) hβ)
+    (hfin : FiniteAlong L (heckeAlphaBar L N ℓ))
+    (hN : NormFormulaAlong L (heckeAlphaBar L N ℓ) hfin) :
+    heckeOperatorAlong L N ℓ = heckePic0Bar hα hβ hFI hfin hN := by
+  have h : HeckeInputsAlong L N ℓ := heckeInputsAlong_intro hα hβ hFI hfin hN
+  rw [heckeOperatorAlong, dite_eq_left h]
+
+theorem heckeOperatorAlong_of_not (h : ¬ HeckeInputsAlong L N ℓ) :
+    heckeOperatorAlong L N ℓ = 0 := by
+  rw [heckeOperatorAlong, dite_eq_right h]
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_IgusaFunctionField.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_IgusaFunctionField.lean
new file mode 100644
index 0000000000..7284e45ae9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_IgusaFunctionField.lean
@@ -0,0 +1,140 @@
+/-
+Based on Prove2Me node ModularCurve_IgusaFunctionField
+(5a26bf6b-a90e-5878-8d91-7538c6279aff) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Field.ZMod
+public import Mathlib.Algebra.Lie.OfAssociative
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+
+/-!
+# Igusa function field, Kummer generators, diamond data
+
+Definition: `ModularCurve_IgusaFunctionField` (`5a26bf6b-a90e-5878-8d91-7538c6279aff`), by Claude,
+2026-09-05.
+
+Throughout, $\kappa$ is a field, $\Omega$ an extension field of $\kappa$ (intended to be a field of
+Laurent series in $q$), $K_0$ an intermediate field of $\Omega/\kappa$ and $a \in \Omega$. The field
+`igusaFunctionField K₀ a` is the intermediate field of $\Omega/\kappa$ obtained by adjoining to
+$\kappa$ the set $K_0 \cup \{a\}$; accompanying lemmas record that it contains $K_0$ and $a$, and
+that it equals the join $K_0 \sqcup \kappa(a)$ inside the lattice of intermediate fields. The map
+`incl` is the $\kappa$-algebra inclusion of $K_0$ into this field, and `qExpansion` is its
+tautological embedding into $\Omega$, which composed with `incl` is the inclusion $K_0 \subseteq
+\Omega$.
+
+`IsKummerGenerator n K₀ a` is a Prop-valued structure with exactly three fields: $n > 0$, $a \neq
+0$, and $a^n \in K_0$; it asserts no irreducibility or degree statement. For a place $w$ of $K_I =$
+`igusaFunctionField K₀ a` over $\kappa$ in the project's sense (a valuation subring of $K_I$
+containing $\kappa$, proper, and a principal ideal ring, hence a discrete valuation ring),
+`restrictToBase` is its restriction along `incl` — formed from the hypothesis that `incl` is an
+integral ring homomorphism — and `ramificationIndexOverBase w` is the ramification index along
+`incl`, i.e. the least positive $n$ of the form $w(\mathrm{ord})$ of the image of a nonzero element
+of $K_0$.
+
+For a prime $p$ with $\operatorname{char} \kappa = p$ and $k \in \mathbb{Z}$, `IgusaDiamondData p k
+K₀ a` is a structure carrying as data a monoid homomorphism $b \mapsto \langle b \rangle$ from
+$(\mathbb{Z}/p)^\times$ to the group of $\kappa$-automorphisms of $K_I$, together with two axioms:
+each $\langle b \rangle$ fixes every element of $K_I$ lying in $K_0$, and $\langle b \rangle a = b^k
+\cdot a$, where $b^k \in (\mathbb{Z}/p)^\times$ is mapped into $\kappa$ by the canonical
+homomorphism $\mathbb{Z}/p \to \kappa$ available in characteristic $p$. From such data, `actDiff` is
+the $\kappa$-linear endomorphism of the module of Kähler differentials $\Omega_{K_I/\kappa}$
+obtained by pulling back along $\langle b \rangle$, and `act_incl` restates that $\langle b \rangle$
+fixes the image of $K_0$. Existence of the action, the degree $[K_I : K_0]$, and ramification
+behaviour are not addressed here.
+
+**Relation to Mathlib.** `IntermediateField.adjoin` and the Kähler differential module
+$\Omega_{\cdot/\cdot}$ are Mathlib's; places of a function field, their restriction and ramification
+index along a $\kappa$-algebra map, and pull-back on differentials are the project's own notions.
+Mathlib has no notion of Igusa cover or of diamond operators on one.
+
+**Where it is used.** The intended reading is that $K_0$ is the function field of a modular curve
+over a field of characteristic $p$, $a$ a root of an equation extracted from the Hasse invariant, so
+that $K_I$ is the function field of the associated Igusa cover and `qExpansion` records
+$q$-expansions at a cusp where that root is rational. The diamond data provide the
+$(\mathbb{Z}/p)^\times$-action used in the analysis of the reduction modulo $p$ of modular curves
+and of their Jacobians.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+namespace ModularCurve.IgusaCover
+
+open AlgebraicCurve
+
+variable {κ : Type*} [Field κ] {Ω : Type*} [Field Ω] [Algebra κ Ω]
+
+def igusaFunctionField (K₀ : IntermediateField κ Ω) (a : Ω) : IntermediateField κ Ω :=
+  IntermediateField.adjoin κ ((K₀ : Set Ω) ∪ {a})
+
+variable (K₀ : IntermediateField κ Ω) (a : Ω)
+
+theorem le_igusaFunctionField : K₀ ≤ igusaFunctionField K₀ a :=
+  fun _ hx => IntermediateField.subset_adjoin κ _ (Or.inl hx)
+
+theorem mem_igusaFunctionField : a ∈ igusaFunctionField K₀ a :=
+  IntermediateField.subset_adjoin κ _ (Or.inr rfl)
+
+theorem igusaFunctionField_eq_sup :
+    igusaFunctionField K₀ a = K₀ ⊔ IntermediateField.adjoin κ {a} := by
+  rw [igusaFunctionField, IntermediateField.adjoin_union, IntermediateField.adjoin_self]
+
+def incl : K₀ →ₐ[κ] igusaFunctionField K₀ a :=
+  IntermediateField.inclusion (le_igusaFunctionField K₀ a)
+
+@[simp] theorem coe_incl (x : K₀) : ((incl K₀ a x : igusaFunctionField K₀ a) : Ω) = x := rfl
+
+def qExpansion : igusaFunctionField K₀ a →ₐ[κ] Ω := (igusaFunctionField K₀ a).val
+
+theorem qExpansion_incl (x : K₀) : qExpansion K₀ a (incl K₀ a x) = (x : Ω) := rfl
+
+structure IsKummerGenerator (n : ℕ) (K₀ : IntermediateField κ Ω) (a : Ω) : Prop where
+  pos : 0 < n
+  ne_zero : a ≠ 0
+  pow_mem : a ^ n ∈ K₀
+
+def restrictToBase (hint : (incl K₀ a).toRingHom.IsIntegral) (w : Place κ (igusaFunctionField K₀ a))
+    :
+    Place κ K₀ :=
+  w.restrictAlong (incl K₀ a) hint
+
+def ramificationIndexOverBase (w : Place κ (igusaFunctionField K₀ a)) : ℕ :=
+  w.ramificationIndexAlong (incl K₀ a)
+
+structure IgusaDiamondData (p : ℕ) [Fact p.Prime] [CharP κ p]
+    (k : ℤ) (K₀ : IntermediateField κ Ω) (a : Ω) where
+  act : (ZMod p)ˣ →* (igusaFunctionField K₀ a ≃ₐ[κ] igusaFunctionField K₀ a)
+  act_apply_of_mem : ∀ (b : (ZMod p)ˣ) (x : igusaFunctionField K₀ a), (x : Ω) ∈ K₀ → act b x = x
+  act_gen : ∀ b : (ZMod p)ˣ,
+    ((act b ⟨a, mem_igusaFunctionField K₀ a⟩ : igusaFunctionField K₀ a) : Ω) =
+      (ZMod.castHom (dvd_refl p) κ (((b ^ k : (ZMod p)ˣ) : ZMod p))) • a
+
+namespace IgusaDiamondData
+
+variable {K₀ a} {p : ℕ} [Fact p.Prime] [CharP κ p] {k : ℤ}
+
+def actDiff (d : IgusaDiamondData p k K₀ a) (b : (ZMod p)ˣ) :
+    Ω[igusaFunctionField K₀ a⁄κ] →ₗ[κ] Ω[igusaFunctionField K₀ a⁄κ] :=
+  pullbackDiff (d.act b : igusaFunctionField K₀ a →ₐ[κ] igusaFunctionField K₀ a)
+
+theorem act_incl (d : IgusaDiamondData p k K₀ a) (b : (ZMod p)ˣ) (x : K₀) :
+    d.act b (incl K₀ a x) = incl K₀ a x :=
+  d.act_apply_of_mem b _ x.2
+
+end IgusaDiamondData
+
+end ModularCurve.IgusaCover
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_IgusaFunctionFieldX1.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_IgusaFunctionFieldX1.lean
new file mode 100644
index 0000000000..12db766aae
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_IgusaFunctionFieldX1.lean
@@ -0,0 +1,103 @@
+/-
+Based on Prove2Me node ModularCurve_IgusaFunctionFieldX1
+(3a9ca178-5daa-5d7c-b964-993d1c37d27a) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_IgusaFunctionField
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+/-!
+# Igusa function field over X1​(M) from a weight-one form
+
+Definition: `ModularCurve_IgusaFunctionFieldX1` (`3a9ca178-5daa-5d7c-b964-993d1c37d27a`), by Claude,
+2026-09-05.
+
+Fix a field $\kappa$ and a level $M : \mathbb{N}$. The structure
+[`ModularCurve.IntegralWeightOneForm`](../def/ModularCurve_IgusaFunctionFieldX1.html#L16) packages,
+as data, a weight-one modular form together with an integral $q$-expansion whose reduction is
+nonzero: its fields are a `form` of weight $1$ for the image of $\Gamma_1(M)$ in
+$\mathrm{GL}_2(\mathbb{R})$, a power series `series` over $\mathbb{Z}$, a proof field
+`isIntegralQExp` asserting that pushing `series` forward along $\mathbb{Z} \to \mathbb{C}$ gives the
+$q$-expansion (of width $1$) of the form, and a proof field `intSeriesC_ne_zero` asserting that the
+Laurent series $\bar p \in \kappa((q))$ obtained by reducing `series` modulo the characteristic of
+$\kappa$ (via `intSeriesC`) is nonzero. For such a datum $w$, `IntegralWeightOneForm.hasseRootFn` is
+the Laurent series $\bar p^{-1} \in \kappa((q))$ — the $q$-expansion of the ratio of a $(p-1)$-st
+root of the Hasse invariant to the given weight-one form — and `hasseRootFn_ne_zero` records that it
+is nonzero.
+
+The Igusa function field `igusaFunctionFieldX1C κ M w` is then defined as the intermediate field
+$\kappa \subseteq K_0(\bar p^{-1}) \subseteq \kappa((q))$ generated over $\kappa$ by $K_0 \cup
+\{\bar p^{-1}\}$, where $K_0 =$ `x1FunctionFieldC κ M` is the field generated over $\kappa$ by all
+quotients $\bar p_f / \bar p_g$ of reductions of integral $q$-expansions of two modular forms of one
+and the same weight on $\Gamma_1(M)$, the denominator having nonzero reduction. The two accompanying
+lemmas state the inclusion $K_0 \le K_0(\bar p^{-1})$ and the membership $\bar p^{-1} \in K_0(\bar
+p^{-1})$. Finally, for a prime $p$ with $\kappa$ of characteristic $p$, `IgusaDiamondDataX1C`
+abbreviates the general Igusa diamond datum at exponent $k = -1$ for this pair $(K_0, \bar p^{-1})$:
+an action of $(\mathbb{Z}/p)^\times$ by $\kappa$-algebra automorphisms of $K_0(\bar p^{-1})$ fixing
+every element of $K_0$ and sending the generator $\bar p^{-1}$ to $b^{-1} \cdot \bar p^{-1}$, the
+scalar being the image of $b^{-1} \in (\mathbb{Z}/p)^\times$ in $\kappa$. The Kummer-generator
+property, the bounds on $p$ and $M$, and the existence of a weight-one datum are not asserted here;
+they are carried as data or hypotheses elsewhere.
+
+**Relation to Mathlib.** Mathlib supplies the ingredients — `ModularForm` for a subgroup of
+$\mathrm{GL}_2(\mathbb{R})$, `qExpansion`, `LaurentSeries` and `IntermediateField.adjoin` — while
+the notion of an integral weight-one datum, the associated generator $\bar p^{-1}$, and the Igusa
+function field and its diamond datum are the project's own.
+
+**Where it is used.** This is the fine-moduli ($\Gamma_1(M)$) instantiation of the general
+construction of the function field of an Igusa curve over $X_1(M)_\kappa$, obtained by adjoining a
+$(p-1)$-st root of the Hasse invariant divided by a weight-one form. It underlies the study of the
+Igusa tower and of the diamond operators $\langle b \rangle$ acting on it, used in the mod $p$
+analysis of modular curves in characteristic $p$.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public noncomputable section publicSection
+
+open CongruenceSubgroup
+open scoped MatrixGroups
+
+namespace ModularCurve
+
+variable (κ : Type*) [Field κ] (M : ℕ)
+
+structure IntegralWeightOneForm where
+  form : ModularForm (Gamma1 M : Subgroup (GL (Fin 2) ℝ)) 1
+  series : PowerSeries ℤ
+  isIntegralQExp : IsIntegralQExp form series
+  intSeriesC_ne_zero : intSeriesC κ series ≠ 0
+
+variable {κ M}
+
+def IntegralWeightOneForm.hasseRootFn (w : IntegralWeightOneForm κ M) : LaurentSeries κ :=
+  (intSeriesC κ w.series)⁻¹
+
+theorem IntegralWeightOneForm.hasseRootFn_ne_zero (w : IntegralWeightOneForm κ M) :
+    w.hasseRootFn ≠ 0 :=
+  inv_ne_zero w.intSeriesC_ne_zero
+
+variable (κ M)
+
+def igusaFunctionFieldX1C (w : IntegralWeightOneForm κ M) : IntermediateField κ (LaurentSeries κ) :=
+  IgusaCover.igusaFunctionField (x1FunctionFieldC κ M) w.hasseRootFn
+
+theorem x1FunctionFieldC_le_igusaFunctionFieldX1C (w : IntegralWeightOneForm κ M) :
+    x1FunctionFieldC κ M ≤ igusaFunctionFieldX1C κ M w :=
+  IgusaCover.le_igusaFunctionField _ _
+
+theorem hasseRootFn_mem_igusaFunctionFieldX1C (w : IntegralWeightOneForm κ M) :
+    w.hasseRootFn ∈ igusaFunctionFieldX1C κ M w :=
+  IgusaCover.mem_igusaFunctionField _ _
+
+abbrev IgusaDiamondDataX1C (w : IntegralWeightOneForm κ M) (p : ℕ) [Fact p.Prime] [CharP κ p] :=
+  IgusaCover.IgusaDiamondData p (-1) (x1FunctionFieldC κ M) w.hasseRootFn
+
+end ModularCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_JLinePlaces.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_JLinePlaces.lean
new file mode 100644
index 0000000000..258b3fd6d1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_JLinePlaces.lean
@@ -0,0 +1,120 @@
+/-
+Based on Prove2Me node ModularCurve_JLinePlaces
+(3b55d20f-0347-5a7a-8881-66be2f55acd2) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceInfty
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_RouteBCoordRing
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jq
+
+/-!
+# The j-line as a rational function field, with three places
+
+Definition: `ModularCurve_JLinePlaces` (`3b55d20f-0347-5a7a-8881-66be2f55acd2`), by Claude,
+2026-09-05.
+
+Fix $N\ge 1$. Here $\mathrm{jq}$ is the explicit Laurent series $q^{-1}E_4^3\eta^{-24}$ over
+$\mathbb{Q}$, $\mathbb{Q}\langle \mathrm{jq}\rangle$ the simple extension it generates inside
+$\mathbb{Q}((q))$, and `modularFunctionField N` the intermediate field $\mathbb{Q}(\mathrm{jq},\
+\mathrm{jq}(q^N))$ generated by $\mathrm{jq}$ and its $N$-fold $q$-substitution. The first group of
+declarations equips `modularFunctionField N` with the $\mathbb{Q}\langle \mathrm{jq}\rangle$-algebra
+structure coming from the inclusion ring homomorphism `jAdjoinRingHom N` (available as a reducible
+definition rather than a global instance), records that $\mathbb{Q}\subset\mathbb{Q}\langle
+\mathrm{jq}\rangle\subset$ `modularFunctionField N` is a scalar tower, and states that the generator
+`jGen` of $\mathbb{Q}\langle \mathrm{jq}\rangle$ maps to the Laurent series $\mathrm{jq}$.
+
+The second group identifies the $j$-line with the rational function field. Since $\mathrm{jq}$ is
+transcendental over $\mathbb{Q}$, Mathlib's algebra equivalence attached to a transcendental element
+is a bijection; `jLineRingEquiv` is the resulting ring isomorphism
+$\mathbb{Q}(T)\xrightarrow{\sim}\mathbb{Q}\langle \mathrm{jq}\rangle$, and it sends $T$ to `jGen`.
+
+Finally, three places of $\mathbb{Q}\langle \mathrm{jq}\rangle$ over $\mathbb{Q}$ are defined. In
+this development a place of $F/K$ is a valuation subring of $F$ which contains the image of $K$, is
+not all of $F$, and is a principal ideal ring (hence a discrete valuation ring). `jLinePlace1728`,
+`jLinePlaceZero` and `jLinePlaceInfty` are obtained by transporting along `jLineRingEquiv`, via the
+congruence operation on places (the valuation subring is pulled back along the inverse isomorphism),
+the place of $\mathbb{Q}(T)$ attached to the height-one prime $(T-1728)$, the place attached to
+$(T)$, and the place of the degree valuation at infinity. A classical decidable-equality helper for
+$\mathbb{Q}(T)$ is supplied, as the place at infinity is defined with such an assumption in scope.
+
+**Relation to Mathlib.** The notion of a place used here — a valuation subring of $F$ containing
+$K$, proper, and principal — is the project's own structure, as are the places of a rational
+function field at a point and at infinity; `jLineRingEquiv` repackages Mathlib's algebra equivalence
+$K(T)\simeq K(x)$ for a transcendental $x$ as a ring isomorphism.
+
+**Where it is used.** These definitions set up the function-field language for the covering
+$X_0(N)\to X(1)$: the tower $\mathbb{Q}\subset\mathbb{Q}(j)\subset\mathbb{Q}(j(q),j(q^N))$ lets one
+speak of restrictions of places, ramification indices and residue degrees for that cover, and the
+three distinguished places of the $j$-line at $j=1728$, $j=0$ and $j=\infty$ are the base points at
+which the covering's behaviour is analysed.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open IntermediateField AlgebraicCurve AlgebraicCurve.RationalFunctionField
+
+namespace ModularCurve
+
+section Tower
+
+variable (N : ℕ) [NeZero N]
+
+@[reducible] def jAdjoinAlgebra : Algebra ℚ⟮jq⟯ (modularFunctionField N) :=
+  (jAdjoinRingHom N).toAlgebra
+
+attribute [local instance] jAdjoinAlgebra
+
+instance instIsScalarTowerJAdjoin :
+    @IsScalarTower ℚ ℚ⟮jq⟯ (modularFunctionField N)
+      Algebra.toSMul Algebra.toSMul Algebra.toSMul :=
+  IsScalarTower.of_algebraMap_eq' (by apply RingHom.ext_rat)
+
+theorem algebraMap_jGen_val :
+    (algebraMap ℚ⟮jq⟯ (modularFunctionField N) jGen : LaurentSeries ℚ) = jq :=
+  rfl
+
+end Tower
+
+attribute [local instance 2000] RatFunc.instAlgebraOfPolynomial
+
+def jLineRingEquiv : RatFunc ℚ ≃+* ℚ⟮jq⟯ :=
+  RingEquiv.ofBijective (RatFunc.algEquivOfTranscendental jq transcendental_jq)
+    (EquivLike.bijective _)
+
+theorem jLineRingEquiv_apply (f : RatFunc ℚ) :
+    jLineRingEquiv f = RatFunc.algEquivOfTranscendental jq transcendental_jq f := rfl
+
+theorem jLineRingEquiv_X : jLineRingEquiv RatFunc.X = jGen :=
+  Subtype.ext (RatFunc.algEquivOfTranscendental_X jq transcendental_jq)
+
+@[reducible] def instDecidableEqRatFuncRat : DecidableEq (RatFunc ℚ) := Classical.decEq _
+
+attribute [local instance] instDecidableEqRatFuncRat
+
+def jLinePlace1728 : Place ℚ ℚ⟮jq⟯ :=
+  Place.congrRingEquiv jLineRingEquiv (RingHom.map_rat_algebraMap jLineRingEquiv.toRingHom)
+    (placeOfPoint ℚ 1728)
+
+def jLinePlaceZero : Place ℚ ℚ⟮jq⟯ :=
+  Place.congrRingEquiv jLineRingEquiv (RingHom.map_rat_algebraMap jLineRingEquiv.toRingHom)
+    (placeOfPoint ℚ 0)
+
+def jLinePlaceInfty : Place ℚ ℚ⟮jq⟯ :=
+  Place.congrRingEquiv jLineRingEquiv (RingHom.map_rat_algebraMap jLineRingEquiv.toRingHom)
+    (placeInfty ℚ)
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_JLinePlacesBar.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_JLinePlacesBar.lean
new file mode 100644
index 0000000000..dc0975b0cc
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_JLinePlacesBar.lean
@@ -0,0 +1,131 @@
+/-
+Based on Prove2Me node ModularCurve_JLinePlacesBar
+(6aeebaf5-0f23-5efe-ae81-9594bf701740) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceInfty
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ArithmeticGalois
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_coeffEmb_jq
+
+/-!
+# The j-line inside the base-changed modular function field
+
+Definition: `ModularCurve_JLinePlacesBar` (`6aeebaf5-0f23-5efe-ae81-9594bf701740`), by Claude,
+2026-09-05.
+
+Fix a level $N \ge 1$. The modular function field of level $N$ over $\overline{\mathbb Q}$ is here
+`modularFunctionFieldBar N`, the subfield of $\overline{\mathbb Q}((q))$ generated over
+$\overline{\mathbb Q}$ by the coefficientwise images (under `coeffEmb`, i.e. application of $\mathbb
+Q \to \overline{\mathbb Q}$ to each Laurent coefficient) of the field `modularFunctionFieldFull N`,
+which is the $\mathbb Q$-subfield of $\mathbb Q((q))$ generated by the series $q$-expansions
+$\mathrm{jq}$ rescaled by $q \mapsto q^{d}$ for all divisors $d \mid N$. Write $\bar j$ for the
+element of that field given by the coefficientwise image of the $q$-expansion $\mathrm{jq}$ of the
+modular invariant, with membership supplied by `jq_mem_full`. The abbreviation `jLineBar N` is the
+intermediate field $\overline{\mathbb Q}(\bar j)$, i.e. the $\overline{\mathbb Q}$-subfield of
+`modularFunctionFieldBar N` generated by $\bar j$, together with its $\overline{\mathbb Q}$-algebra
+and $\overline{\mathbb Q}$-module structures; `transcendental_jLineBar_gen` records that $\bar j$ is
+transcendental over $\overline{\mathbb Q}$, quoting `transcendental_coeffEmb_jq`. Consequently
+`jLineBarRingEquiv N` is a ring isomorphism $\overline{\mathbb Q}(T) \cong \overline{\mathbb Q}(\bar
+j)$, namely the underlying ring map of Mathlib's algebra isomorphism attached to a transcendental
+element; accompanying lemmas state that it acts as the identity on constants from $\overline{\mathbb
+Q}$ and sends $T$ to $\bar j$.
+
+Three places of $\overline{\mathbb Q}(\bar j)$ over $\overline{\mathbb Q}$ are then fixed. A `Place
+K F` is a valuation subring of $F$ containing the image of $K$, proper in $F$, and a principal ideal
+ring; `Place.congrRingEquiv` transports a place along a ring isomorphism compatible with the
+structure maps by pulling the valuation subring back along the inverse isomorphism. Applying this to
+`jLineBarRingEquiv N` gives `jLineBarPlace1728 N`, `jLineBarPlaceZero N` and `jLineBarPlaceInfty N`,
+the transports of the places of $\overline{\mathbb Q}(T)$ cut out by the primes $(T - 1728)$ and
+$(T)$ of $\overline{\mathbb Q}[T]$ and of the place at infinity given by the degree valuation. A
+classical decidable-equality helper for $\overline{\mathbb Q}(T)$ accompanies the last of these.
+
+**Relation to Mathlib.** `Place`, `placeOfPoint` and `placeInfty` are the project's own notions,
+built on Mathlib's height-one-spectrum adic valuations and on `RatFunc.inftyValuation`; the
+isomorphism with the rational function field comes from Mathlib's
+`RatFunc.algEquivOfTranscendental`.
+
+**Where it is used.** These objects provide the base of the $j$-cover of the modular curve of level
+$N$ over $\overline{\mathbb Q}$ in function-field language: the $j$-line sits inside the
+base-changed modular function field, and the three places at $j = 1728$, $j = 0$ and $j = \infty$
+are the ones over which the cover is studied, in the analysis of the divisor class group
+$\mathrm{Pic}^0$ and its torsion with its Galois action.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open IntermediateField AlgebraicCurve AlgebraicCurve.RationalFunctionField
+
+namespace ModularCurve
+
+variable (N : ℕ) [NeZero N]
+
+abbrev jLineBar : IntermediateField (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+  IntermediateField.adjoin (AlgebraicClosure ℚ)
+    {(⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+      (jq_mem_full N)⟩ :
+      ↥(modularFunctionFieldBar N))}
+
+instance instAlgebraJLineBar :
+    Algebra (AlgebraicClosure ℚ) ↥(jLineBar N) := IntermediateField.algebra' (jLineBar N)
+
+instance instModuleJLineBar : Module (AlgebraicClosure ℚ) ↥(jLineBar N) := Algebra.toModule
+
+theorem transcendental_jLineBar_gen :
+    Transcendental (AlgebraicClosure ℚ)
+      (⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+        (jq_mem_full N)⟩ :
+        ↥(modularFunctionFieldBar N)) :=
+  transcendental_coeffEmb_jq (AlgebraicClosure ℚ) N
+
+def jLineBarRingEquiv : RatFunc (AlgebraicClosure ℚ) ≃+* ↥(jLineBar N) :=
+  RingEquiv.ofBijective
+    (RatFunc.algEquivOfTranscendental _ (transcendental_jLineBar_gen N))
+    (EquivLike.bijective _)
+
+theorem jLineBarRingEquiv_apply (f : RatFunc (AlgebraicClosure ℚ)) :
+    jLineBarRingEquiv N f = RatFunc.algEquivOfTranscendental _ (transcendental_jLineBar_gen N) f :=
+      rfl
+
+theorem jLineBarRingEquiv_algebraMap (a : AlgebraicClosure ℚ) :
+    jLineBarRingEquiv N (algebraMap (AlgebraicClosure ℚ) (RatFunc (AlgebraicClosure ℚ)) a) =
+      algebraMap (AlgebraicClosure ℚ) ↥(jLineBar N) a :=
+  (RatFunc.algEquivOfTranscendental _ (transcendental_jLineBar_gen N)).commutes a
+
+theorem jLineBarRingEquiv_X :
+    (jLineBarRingEquiv N RatFunc.X : ↥(modularFunctionFieldBar N))
+      = ⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+        (jq_mem_full N)⟩ :=
+  RatFunc.algEquivOfTranscendental_X _ (transcendental_jLineBar_gen N)
+
+@[reducible] def instDecidableEqRatFuncAlgebraicClosure :
+    DecidableEq (RatFunc (AlgebraicClosure ℚ)) := Classical.decEq _
+
+attribute [local instance] instDecidableEqRatFuncAlgebraicClosure
+
+def jLineBarPlace1728 : Place (AlgebraicClosure ℚ) ↥(jLineBar N) :=
+  Place.congrRingEquiv (jLineBarRingEquiv N) (jLineBarRingEquiv_algebraMap N) (placeOfPoint
+    (AlgebraicClosure ℚ) 1728)
+
+def jLineBarPlaceZero : Place (AlgebraicClosure ℚ) ↥(jLineBar N) :=
+  Place.congrRingEquiv (jLineBarRingEquiv N) (jLineBarRingEquiv_algebraMap N) (placeOfPoint
+    (AlgebraicClosure ℚ) 0)
+
+def jLineBarPlaceInfty : Place (AlgebraicClosure ℚ) ↥(jLineBar N) :=
+  Place.congrRingEquiv (jLineBarRingEquiv N) (jLineBarRingEquiv_algebraMap N) (placeInfty
+    (AlgebraicClosure ℚ))
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_JZeroHeightForm.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_JZeroHeightForm.lean
new file mode 100644
index 0000000000..326b270467
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_JZeroHeightForm.lean
@@ -0,0 +1,261 @@
+/-
+Based on Prove2Me node ModularCurve_JZeroHeightForm
+(b58bc116-d3ca-5974-b42c-b4281663a9be) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JZeroNaiveHeight
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Repartitions
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Compat_Mathlib430
+
+/-!
+# Height form on divisors; divisor representatives in J_0(N)
+
+Definition: `ModularCurve_JZeroHeightForm` (`b58bc116-d3ca-5974-b42c-b4281663a9be`), by Claude,
+2026-09-05.
+
+The first half works with a function field $F$ over $\overline{\mathbb{Q}}$ in the project's
+`AlgebraicCurve` framework, where a `Place` is a valuation subring of $F$ containing the image of
+the base field, proper and with principal ideals, and a `Divisor` is a finitely supported
+$\mathbb{Z}$-valued function on places. For a finite family $x$ of algebraic numbers, `absLogHeight`
+is the logarithmic height of $x$, computed in the intermediate field
+$\mathbb{Q}(\operatorname{range} x)$ of $\overline{\mathbb{Q}}$, divided by
+$[\mathbb{Q}(\operatorname{range} x):\mathbb{Q}]$; that this field is finite over $\mathbb{Q}$ is
+`finiteDimensional_adjoin_range`. Given $s : \mathrm{Fin}\,r \to F$ and a place $v$, `pivotIndex`
+selects (when $r>0$) an index minimising $\operatorname{ord}_v(s_i)$, `evalVec s v` is the vector of
+residues $v(s_i/s_{\mathrm{piv}})$ under `Place.evalAt`, and `chordVec s v w` is the family of
+$2\times2$ minors $\,e_v(i)e_w(j)-e_v(j)e_w(i)$. Then `pointHt s v` is `absLogHeight` of `evalVec s
+v`, `pairHt s v w = pointHt v + pointHt w - absLogHeight (chordVec v w)`, and `baseHt s b v` is
+`pairHt s v b`, set to $0$ when $v=b$. For $\gamma \in \mathbb{Z}$, a base place $b$ and a divisor
+$D=\sum_v n_v v$, `heightFormAux` is $$\Big(\gamma+\sum_v n_v-1\Big)\sum_v
+n_v\,\mathrm{baseHt}(v)-\tfrac12\sum_{v\neq w \in \operatorname{supp} D} n_v
+n_w\,\mathrm{pairHt}(v,w)-(2-2\gamma)\sum_v \tfrac{n_v(n_v-1)}{2}\,\mathrm{baseHt}(v),$$ and
+`heightForm` applies this after erasing the coefficient at $b$. Hence the form is unchanged on
+adding any multiple of $b$ (`heightForm_add_single_base`) and satisfies $Q(2D)=4\,Q(D)$
+(`heightForm_two_smul`).
+
+The second half specialises to $N$ with `NeZero N`. With $g=$ `genusFF` of
+$\overline{\mathbb{Q}}$-function field `modularFunctionFieldBar N`, `embDegree` is $2g+1$,
+`embDivisor` is $(2g+1)\cdot\infty$ at the place `cuspInftyBar N`, and `IsEmbBasis s` says that $s$
+is linearly independent over $\overline{\mathbb{Q}}$ and spans `riemannRochSpace (embDivisor N)`,
+i.e. the space of functions with poles bounded by $(2g+1)\infty$. `JZero.heightForm N s D` is
+`heightForm` with $\gamma=g$ and base place `cuspInftyBar N`, inheriting both identities. Finally,
+for a number field $K \subset \overline{\mathbb{Q}}$ and a class $c$ in the additive fixed points of
+`JZero N` under `K.fixingSubgroup`, `JZero.IsRepOf N K n c D` asserts the existence of a degree-zero
+divisor $E$ with: $D$ effective, $E+n\cdot\infty=D$, $D$ invariant under the `arithmeticGalois`
+action of every $\sigma$ fixing $K$, and $\mathrm{Pic}^0$-class of $E$ equal to $c$.
+`JZero.mem_repHeights_iff` identifies `repHeights` with the set of `divNaiveHeight` values of such
+representatives; `IsRepOf.nsmul` gives $m\cdot$scaling ($m n$, $m\bullet c$, $m\bullet D$) and
+`IsRepOf.add_single` allows adding $p\cdot\infty$, raising $n$ to $n+p$, under the hypothesis that
+the cusp place itself is fixed by the relevant Galois elements.
+
+**Relation to Mathlib.** The normalised height `absLogHeight` is built from Mathlib's
+`Height.logHeight` for number fields by dividing by the degree of the field generated by the
+coordinates. Places, divisors, `Pic0`, `riemannRochSpace` and `genusFF` are the project's own
+function-field notions; Mathlib has no height form on divisors of a curve.
+
+**Where it is used.** The form defined here is the quadratic-form companion of the naive height
+`divNaiveHeight` on effective divisors of $X_0(N)$, and `IsRepOf` isolates exactly the Galois-stable
+effective representatives $E + n\cdot\infty$ of a class of $J_0(N)$ over which that naive height is
+minimised. Together they supply the height machinery used in the bounds on rational points and
+torsion of $J_0(N)$ entering the modular-curve side of the argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open AlgebraicCurve
+
+namespace AlgebraicCurve
+
+theorem finiteDimensional_adjoin_range {ι : Type} [Finite ι] (x : ι → AlgebraicClosure ℚ) :
+    FiniteDimensional ℚ (IntermediateField.adjoin ℚ (Set.range x)) :=
+  IntermediateField.finiteDimensional_adjoin fun y _ =>
+    ((AlgebraicClosure.isAlgebraic ℚ).isAlgebraic y).isIntegral
+
+def absLogHeight {ι : Type} [Finite ι] (x : ι → AlgebraicClosure ℚ) : ℝ :=
+  haveI := finiteDimensional_adjoin_range x
+  (Module.finrank ℚ (IntermediateField.adjoin ℚ (Set.range x)) : ℝ)⁻¹ *
+    Height.logHeight fun i =>
+      (⟨x i, IntermediateField.subset_adjoin ℚ (Set.range x) ⟨i, rfl⟩⟩ :
+        IntermediateField.adjoin ℚ (Set.range x))
+
+variable {F : Type} [Field F] [Algebra (AlgebraicClosure ℚ) F]
+
+open Classical in
+def pivotIndex {r : ℕ} (s : Fin r → F) (v : Place (AlgebraicClosure ℚ) F) (hr : 0 < r) : Fin r :=
+  if h : ∃ i : Fin r, ∀ j : Fin r, v.ord (s i) ≤ v.ord (s j) then Classical.choose h else ⟨0, hr⟩
+
+open Classical in
+def evalVec {r : ℕ} (s : Fin r → F) (v : Place (AlgebraicClosure ℚ) F) :
+    Fin r → AlgebraicClosure ℚ :=
+  fun i => if hr : 0 < r then v.evalAt (s i * (s (pivotIndex s v hr))⁻¹) else 0
+
+def chordVec {r : ℕ} (s : Fin r → F) (v w : Place (AlgebraicClosure ℚ) F) :
+    Fin r × Fin r → AlgebraicClosure ℚ :=
+  fun p => evalVec s v p.1 * evalVec s w p.2 - evalVec s v p.2 * evalVec s w p.1
+
+def pointHt {r : ℕ} (s : Fin r → F) (v : Place (AlgebraicClosure ℚ) F) : ℝ :=
+  absLogHeight (evalVec s v)
+
+def pairHt {r : ℕ} (s : Fin r → F) (v w : Place (AlgebraicClosure ℚ) F) : ℝ :=
+  pointHt s v + pointHt s w - absLogHeight (chordVec s v w)
+
+open Classical in
+def baseHt {r : ℕ} (s : Fin r → F) (b v : Place (AlgebraicClosure ℚ) F) : ℝ :=
+  if v = b then 0 else pairHt s v b
+
+def heightFormAux {r : ℕ} (s : Fin r → F) (γ : ℤ) (b : Place (AlgebraicClosure ℚ) F)
+    (D : Divisor (AlgebraicClosure ℚ) F) : ℝ :=
+  ((γ : ℝ) + (D.sum fun _ n => (n : ℝ)) - 1) * (D.sum fun v n => (n : ℝ) * baseHt s b v)
+    - (∑ p ∈ D.support.offDiag, ((D p.1 : ℝ) * (D p.2 : ℝ)) * pairHt s p.1 p.2) / 2
+    - (2 - 2 * (γ : ℝ)) * (D.sum fun v n => ((n : ℝ) * ((n : ℝ) - 1) / 2) * baseHt s b v)
+
+def heightForm {r : ℕ} (s : Fin r → F) (γ : ℤ) (b : Place (AlgebraicClosure ℚ) F)
+    (D : Divisor (AlgebraicClosure ℚ) F) : ℝ :=
+  heightFormAux s γ b (D.erase b)
+
+theorem heightFormAux_two_smul {r : ℕ} (s : Fin r → F) (γ : ℤ) (b : Place (AlgebraicClosure ℚ) F)
+    (D : Divisor (AlgebraicClosure ℚ) F) :
+    heightFormAux s γ b ((2 : ℤ) • D) = 4 * heightFormAux s γ b D := by
+  have hsupp : ((2 : ℤ) • D).support = D.support := Finsupp.support_smul_eq two_ne_zero
+  simp only [heightFormAux, Finsupp.sum, hsupp, Finsupp.smul_apply, smul_eq_mul, Int.cast_mul,
+    Int.cast_ofNat]
+  have h1 : ∑ x ∈ D.support, ((2 : ℝ) * (D x : ℝ)) = 2 * ∑ x ∈ D.support, (D x : ℝ) := by
+    rw [Finset.mul_sum]
+  have h2 : ∑ x ∈ D.support, (2 : ℝ) * (D x : ℝ) * baseHt s b x
+      = 2 * ∑ x ∈ D.support, (D x : ℝ) * baseHt s b x := by
+    rw [Finset.mul_sum]; exact Finset.sum_congr rfl fun x _ => by ring
+  have h3 :
+    ∑ p ∈ D.support.offDiag, (2 : ℝ) * (D p.1 : ℝ) * ((2 : ℝ) * (D p.2 : ℝ)) * pairHt s p.1 p.2
+      = 4 * ∑ p ∈ D.support.offDiag, (D p.1 : ℝ) * (D p.2 : ℝ) * pairHt s p.1 p.2 := by
+    rw [Finset.mul_sum]; exact Finset.sum_congr rfl fun x _ => by ring
+  have h4 : ∑ x ∈ D.support, (2 : ℝ) * (D x : ℝ) * ((2 : ℝ) * (D x : ℝ) - 1) / 2 * baseHt s b x
+      = 4 * (∑ x ∈ D.support, (D x : ℝ) * ((D x : ℝ) - 1) / 2 * baseHt s b x)
+        + ∑ x ∈ D.support, (D x : ℝ) * baseHt s b x := by
+    rw [Finset.mul_sum, ← Finset.sum_add_distrib]
+    exact Finset.sum_congr rfl fun x _ => by ring
+  rw [h1, h2, h3, h4]
+  ring
+
+theorem heightForm_two_smul {r : ℕ} (s : Fin r → F) (γ : ℤ) (b : Place (AlgebraicClosure ℚ) F)
+    (D : Divisor (AlgebraicClosure ℚ) F) :
+    heightForm s γ b ((2 : ℤ) • D) = 4 * heightForm s γ b D := by
+  unfold heightForm
+  rw [two_zsmul, Finsupp.erase_add, ← two_zsmul]
+  exact heightFormAux_two_smul s γ b _
+
+theorem heightForm_add_single_base {r : ℕ} (s : Fin r → F) (γ : ℤ)
+    (b : Place (AlgebraicClosure ℚ) F)
+    (D : Divisor (AlgebraicClosure ℚ) F) (m : ℤ) :
+    heightForm s γ b (D + Finsupp.single b m) = heightForm s γ b D := by
+  unfold heightForm
+  rw [Finsupp.erase_add, Finsupp.erase_single, add_zero]
+
+end AlgebraicCurve
+
+namespace ModularCurve
+
+variable (N : ℕ) [NeZero N]
+
+def embDegree : ℕ :=
+  2 * genusFF (AlgebraicClosure ℚ) (modularFunctionFieldBar N) + 1
+
+def embDivisor : Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N) :=
+  (embDegree N : ℤ) • Finsupp.single (cuspInftyBar N) 1
+
+def IsEmbBasis {r : ℕ} (s : Fin r → modularFunctionFieldBar N) : Prop :=
+  LinearIndependent (AlgebraicClosure ℚ) s ∧
+    Submodule.span (AlgebraicClosure ℚ) (Set.range s) = riemannRochSpace (embDivisor N)
+
+def JZero.heightForm {r : ℕ} (s : Fin r → modularFunctionFieldBar N)
+    (D : Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) : ℝ :=
+  AlgebraicCurve.heightForm s (genusFF (AlgebraicClosure ℚ) (modularFunctionFieldBar N))
+    (cuspInftyBar N) D
+
+theorem JZero.heightForm_two_smul {r : ℕ} (s : Fin r → modularFunctionFieldBar N)
+    (D : Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) :
+    JZero.heightForm N s ((2 : ℤ) • D) = 4 * JZero.heightForm N s D :=
+  AlgebraicCurve.heightForm_two_smul s _ _ D
+
+theorem JZero.heightForm_add_single_cuspInftyBar {r : ℕ} (s : Fin r → modularFunctionFieldBar N)
+    (D : Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) (m : ℤ) :
+    JZero.heightForm N s (D + Finsupp.single (cuspInftyBar N) m) = JZero.heightForm N s D :=
+  AlgebraicCurve.heightForm_add_single_base s _ _ D m
+
+variable (K : IntermediateField ℚ (AlgebraicClosure ℚ)) [FiniteDimensional ℚ K]
+
+def JZero.IsRepOf (n : ℕ) (c : ↥(JZero N^+↥K.fixingSubgroup))
+    (D : Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) : Prop :=
+  ∃ E : Divisor.degZero (K := AlgebraicClosure ℚ) (F := ↥(modularFunctionFieldBar N)),
+    (∀ v, 0 ≤ D v) ∧
+    (E : Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N))
+        + (n : ℤ) • Finsupp.single (cuspInftyBar N) 1 = D ∧
+    (∀ σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ, σ ∈ K.fixingSubgroup →
+        arithmeticGalois (modularFunctionFieldFull N) σ • D = D) ∧
+    Pic0.mk E = (c : JZero N)
+
+theorem JZero.mem_repHeights_iff (n : ℕ) (c : ↥(JZero N^+↥K.fixingSubgroup)) (x : ℝ) :
+    x ∈ JZero.repHeights N K n c ↔ ∃ D, JZero.IsRepOf N K n c D ∧ x = divNaiveHeight N K n D := by
+  constructor
+  · rintro ⟨D, E, h1, h2, h3, h4, h5⟩
+    exact ⟨D, ⟨E, h1, h2, h3, h4⟩, h5⟩
+  · rintro ⟨D, ⟨E, h1, h2, h3, h4⟩, h5⟩
+    exact ⟨D, E, h1, h2, h3, h4, h5⟩
+
+variable {N K}
+
+omit [FiniteDimensional ℚ K] in
+theorem JZero.IsRepOf.nsmul {n : ℕ} {c : ↥(JZero N^+↥K.fixingSubgroup)}
+    {D : Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N)} (h : JZero.IsRepOf N K n c D)
+    (m : ℕ) : JZero.IsRepOf N K (m * n) (m • c) (m • D) := by
+  obtain ⟨E, hD, hshape, hstab, hc⟩ := h
+  refine ⟨m • E, fun v => ?_, ?_, fun σ hσ => ?_, ?_⟩
+  · rw [Finsupp.smul_apply]
+    exact nsmul_nonneg (hD v) m
+  · rw [← hshape, smul_add, AddSubmonoidClass.coe_nsmul, Nat.cast_mul, mul_smul, natCast_zsmul]
+  · have key := map_nsmul (DistribSMul.toAddMonoidHom
+      (Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N))
+      (arithmeticGalois (modularFunctionFieldFull N) σ)) m D
+    simp only [DistribSMul.toAddMonoidHom_apply] at key
+    rw [key, hstab σ hσ]
+  · have key : Pic0.mk (m • E) = m • Pic0.mk E := QuotientAddGroup.mk_nsmul _ E m
+    rw [key, hc, AddSubmonoidClass.coe_nsmul]
+
+omit [FiniteDimensional ℚ K] in
+theorem JZero.IsRepOf.add_single {n : ℕ} {c : ↥(JZero N^+↥K.fixingSubgroup)}
+    {D : Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N)} (h : JZero.IsRepOf N K n c D)
+    (p : ℕ)
+    (hfix : ∀ σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ, σ ∈ K.fixingSubgroup →
+      arithmeticGalois (modularFunctionFieldFull N) σ • cuspInftyBar N = cuspInftyBar N) :
+    JZero.IsRepOf N K (n + p) c (D + (p : ℤ) • Finsupp.single (cuspInftyBar N) 1) := by
+  obtain ⟨E, hD, hshape, hstab, hc⟩ := h
+  refine ⟨E, fun v => ?_, ?_, fun σ hσ => ?_, hc⟩
+  · classical
+    have h0 : (0 : ℤ) ≤ ((p : ℤ) • Finsupp.single (cuspInftyBar N) (1 : ℤ)) v := by
+      rw [Finsupp.smul_apply, smul_eq_mul, Finsupp.single_apply]
+      split_ifs <;> simp
+    rw [Finsupp.add_apply]
+    exact add_nonneg (hD v) h0
+  · rw [← hshape, Nat.cast_add, add_smul, add_assoc]
+  · have key := map_zsmul (DistribSMul.toAddMonoidHom
+      (Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N))
+      (arithmeticGalois (modularFunctionFieldFull N) σ)) (p : ℤ)
+      (Finsupp.single (cuspInftyBar N) (1 : ℤ))
+    simp only [DistribSMul.toAddMonoidHom_apply] at key
+    rw [smul_add, hstab σ hσ, key, AlgebraicCurve.SemilinearAut.smul_single, hfix σ hσ]
+
+end ModularCurve
+
+end
+
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_JZeroNaiveHeight.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_JZeroNaiveHeight.lean
new file mode 100644
index 0000000000..94fd4f8d2d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_JZeroNaiveHeight.lean
@@ -0,0 +1,173 @@
+/-
+Based on Prove2Me node ModularCurve_JZeroNaiveHeight
+(fc3f0af4-9d6b-5020-a650-78322a7f42bb) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_AtkinLehner
+public import Mathlib.Algebra.Ring.Action.Submonoid
+public import Mathlib.FieldTheory.Galois.Basic
+public import Mathlib.NumberTheory.Height.NumberField
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Compat_Mathlib430
+
+/-!
+# Naive height on the modular Jacobian via j-coordinates
+
+Definition: `ModularCurve_JZeroNaiveHeight` (`fc3f0af4-9d6b-5020-a650-78322a7f42bb`), by Claude,
+2026-09-05.
+
+Fix $N \ge 1$ and work with $\bar F =$ `modularFunctionFieldBar N`, the base change to
+$\overline{\mathbb Q}$ of the field generated over $\mathbb Q$ by the $q$-expansions $j(q^d)$, $d
+\mid N$, inside Laurent series; write $j \in \bar F$ for the coefficientwise image of the series
+`jq`. For a place $v$ of $\bar F$ over $\overline{\mathbb Q}$, `jCoord N v` is a choice (via
+`Classical.epsilon`, hence unspecified when none exists) of $c \in \overline{\mathbb Q}$ with
+$v.\mathrm{ord}(j - c) > 0$, i.e. a value of $j$ at $v$; `jFactor N v` is $X -
+C(\mathrm{jCoord}\,N\,v)$ when $v.\mathrm{ord}(j) \ge 0$ and $1$ otherwise, so that places at which
+$j$ has a pole contribute trivially. For a divisor $D$, `symPoly N D` is the finitely supported
+product $\prod_v (\mathrm{jFactor}\,N\,v)^{\max(D(v),0)}$, and `symVec N g' D` is the vector in
+$\overline{\mathbb Q}^{\,g'+1}$ whose $k$-th entry is the coefficient of $X^{g'-k}$ (truncated
+subtraction in $\mathbb N$) of that polynomial.
+
+Let $K$ be an intermediate field of $\overline{\mathbb Q}/\mathbb Q$ of finite degree, made a number
+field by `numberField_of_finiteDimensional`. Then `divNaiveHeight N K g' D` is Mathlib's logarithmic
+height `Height.logHeight` of `symVec N g' D` regarded as a tuple over $K$, when all its entries lie
+in $K$, and $0$ otherwise. For a class $c$ in the fixed-point subgroup `JZero N ^+ K.fixingSubgroup`
+of the degree-zero divisor class group, `JZero.repHeights N K g' c` is the set of reals
+`divNaiveHeight N K g' D` taken over pairs $(D,E)$ with $D$ effective, $E$ of degree zero, $E + g'
+\cdot (\mathrm{cuspInftyBar}\,N) = D$, $D$ invariant under the arithmetic Galois action of every
+$\sigma$ fixing $K$ pointwise, and $[E] = c$; `JZero.naiveHeight` is the infimum of that set.
+Accompanying lemmas evaluate `jFactor` in the two cases, compute `symPoly` on $0$ and on a single
+place, and record that `divNaiveHeight` and hence `naiveHeight` are non-negative, that `naiveHeight`
+is at most the height of any admissible representative, and that it equals $0$ when no
+representative exists.
+
+**Relation to Mathlib.** The logarithmic height `Height.logHeight` over a number field is taken from
+Mathlib; places, divisors and the degree-zero class group `Pic0` belong to the project's own curve
+library, and the height on classes of `JZero` defined here has no Mathlib counterpart. The notation
+`α ^+ M` for `FixedPoints.addSubgroup M α` is re-declared in the project's compatibility module.
+
+**Where it is used.** These definitions provide the height function on Galois-invariant classes of
+the degree-zero divisor class group of the modular function field, the quantitative input for
+descent-type arguments on $J_0(N)(K)$ in the modular-curve part of the development.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open AlgebraicCurve Polynomial
+
+namespace ModularCurve
+
+variable (N : ℕ) [NeZero N]
+
+def jCoord (v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) : AlgebraicClosure ℚ :=
+  Classical.epsilon fun c : AlgebraicClosure ℚ =>
+    0 < v.ord ((⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange
+      (AlgebraicClosure ℚ) (jq_mem_full N)⟩ : modularFunctionFieldBar N)
+        - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) c)
+
+def jFactor (v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) :
+    Polynomial (AlgebraicClosure ℚ) :=
+  if 0 ≤ v.ord (⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange
+    (AlgebraicClosure ℚ) (jq_mem_full N)⟩ : modularFunctionFieldBar N)
+  then X - C (jCoord N v) else 1
+
+def symPoly (D : Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) :
+    Polynomial (AlgebraicClosure ℚ) :=
+  D.prod fun v n => jFactor N v ^ n.toNat
+
+def symVec (g' : ℕ) (D : Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) :
+    Fin (g' + 1) → AlgebraicClosure ℚ :=
+  fun k => (symPoly N D).coeff (g' - k)
+
+instance numberField_of_finiteDimensional (K : IntermediateField ℚ (AlgebraicClosure ℚ))
+    [FiniteDimensional ℚ K] : NumberField K :=
+  NumberField.mk
+
+variable (K : IntermediateField ℚ (AlgebraicClosure ℚ)) [FiniteDimensional ℚ K]
+
+open scoped Classical in
+def divNaiveHeight (g' : ℕ) (D : Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) : ℝ :=
+  if h : ∀ k, symVec N g' D k ∈ K then Height.logHeight fun k => (⟨symVec N g' D k, h k⟩ : K) else 0
+
+def JZero.repHeights (g' : ℕ) (c : ↥(JZero N^+↥K.fixingSubgroup)) : Set ℝ :=
+  {r | ∃ (D : Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N))
+      (E : Divisor.degZero (K := AlgebraicClosure ℚ) (F := ↥(modularFunctionFieldBar N))),
+      (∀ v, 0 ≤ D v) ∧
+      (E : Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N))
+          + (g' : ℤ) • Finsupp.single (cuspInftyBar N) 1 = D ∧
+      (∀ σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ, σ ∈ K.fixingSubgroup →
+          arithmeticGalois (modularFunctionFieldFull N) σ • D = D) ∧
+      Pic0.mk E = (c : JZero N) ∧
+      r = divNaiveHeight N K g' D}
+
+def JZero.naiveHeight (g' : ℕ) (c : ↥(JZero N^+↥K.fixingSubgroup)) : ℝ :=
+  sInf (JZero.repHeights N K g' c)
+
+variable {N K}
+
+theorem jFactor_of_nonneg {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)}
+    (hv : 0 ≤ v.ord (⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange
+      (AlgebraicClosure ℚ) (jq_mem_full N)⟩ : modularFunctionFieldBar N)) :
+    jFactor N v = X - C (jCoord N v) :=
+  ite_eq_left hv
+
+theorem jFactor_of_neg {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)}
+    (hv : v.ord (⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange
+      (AlgebraicClosure ℚ) (jq_mem_full N)⟩ : modularFunctionFieldBar N) < 0) :
+    jFactor N v = 1 :=
+  ite_eq_right (not_le.mpr hv)
+
+@[simp]
+theorem symPoly_zero : symPoly N 0 = 1 :=
+  Finsupp.prod_zero_index
+
+theorem symPoly_single (v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) (n : ℤ) :
+    symPoly N (Finsupp.single v n) = jFactor N v ^ n.toNat :=
+  Finsupp.prod_single_index (by simp)
+
+theorem divNaiveHeight_nonneg (g' : ℕ)
+    (D : Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) :
+    0 ≤ divNaiveHeight N K g' D := by
+  unfold divNaiveHeight
+  split_ifs with h
+  · exact Height.logHeight_nonneg _
+  · exact le_rfl
+
+theorem JZero.repHeights_nonneg {g' : ℕ} {c : ↥(JZero N^+↥K.fixingSubgroup)} {r : ℝ}
+    (hr : r ∈ JZero.repHeights N K g' c) : 0 ≤ r := by
+  obtain ⟨D, E, -, -, -, -, rfl⟩ := hr
+  exact divNaiveHeight_nonneg g' D
+
+theorem JZero.naiveHeight_nonneg (g' : ℕ) (c : ↥(JZero N^+↥K.fixingSubgroup)) :
+    0 ≤ JZero.naiveHeight N K g' c :=
+  Real.sInf_nonneg fun _ hr => JZero.repHeights_nonneg hr
+
+theorem JZero.naiveHeight_le (g' : ℕ) (c : ↥(JZero N^+↥K.fixingSubgroup))
+    (D : Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N))
+    (E : Divisor.degZero (K := AlgebraicClosure ℚ) (F := ↥(modularFunctionFieldBar N)))
+    (hD : ∀ v, 0 ≤ D v)
+    (hE : (E : Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N))
+        + (g' : ℤ) • Finsupp.single (cuspInftyBar N) 1 = D)
+    (hK : ∀ σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ, σ ∈ K.fixingSubgroup →
+        arithmeticGalois (modularFunctionFieldFull N) σ • D = D)
+    (hc : Pic0.mk E = (c : JZero N)) :
+    JZero.naiveHeight N K g' c ≤ divNaiveHeight N K g' D :=
+  csInf_le ⟨0, fun _ hr => JZero.repHeights_nonneg hr⟩ ⟨D, E, hD, hE, hK, hc, rfl⟩
+
+theorem JZero.naiveHeight_eq_zero (g' : ℕ) (c : ↥(JZero N^+↥K.fixingSubgroup))
+    (h : JZero.repHeights N K g' c = ∅) : JZero.naiveHeight N K g' c = 0 := by
+  rw [JZero.naiveHeight, h, Real.sInf_empty]
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_JZeroTateModule.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_JZeroTateModule.lean
new file mode 100644
index 0000000000..a3707aa79f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_JZeroTateModule.lean
@@ -0,0 +1,177 @@
+/-
+Based on Prove2Me node ModularCurve_JZeroTateModule
+(942e53fb-3055-526e-884e-7034fc31c653) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ArithmeticGalois
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeGalois_EichlerShimura
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_TateModule
+public import Mathlib.LinearAlgebra.TensorProduct.Tower
+public import Mathlib.Algebra.Algebra.Subalgebra.Lattice
+public import Mathlib.LinearAlgebra.Basis.Defs
+
+/-!
+# Rational Tate module, Hecke action, rank-two cyclotomic predicate
+
+Definition: `ModularCurve_JZeroTateModule` (`942e53fb-3055-526e-884e-7034fc31c653`), by Claude,
+2026-09-05.
+
+Throughout, $p$ is a prime and $J$ an abelian group; $\mathbb{T} =$ `HeckeAlg` is the polynomial
+ring $\mathbb{Z}[X_\ell : \ell \text{ prime}]$ on the set of primes, and [`TateModule p
+J`](../def/EllipticCurve_TateModule.html#L15) is the group of sequences $(x_n)_{n\in\mathbb{N}}$ in
+$J$ with $p^n x_n = 0$ and $p\,x_{n+1} = x_n$, a $\mathbb{Z}_p$-module. First, for $J$ a
+$\mathbb{T}$-module, `tateHeckeRep` upgrades the monoid homomorphism
+[`TateModule.rep`](../def/EllipticCurve_TateModule.html#L174) to a ring homomorphism $\mathbb{T} \to
+\operatorname{End}_{\mathbb{Z}_p}(T_pJ)$, acting coordinatewise by $t\cdot(x_n) = (t\cdot x_n)$; the
+two accompanying lemmas record this action componentwise. Next, `RationalTateModule p J` is $V =
+\mathbb{Q}_p \otimes_{\mathbb{Z}_p} T_pJ$. For a monoid $G$ acting distributively on $J$,
+`rationalGaloisRep` is the composite of
+[`TateModule.rep`](../def/EllipticCurve_TateModule.html#L174) with base change along $\mathbb{Z}_p
+\to \mathbb{Q}_p$, a monoid homomorphism $G \to \operatorname{End}_{\mathbb{Q}_p}(V)$ sending $g$ to
+$a \otimes x \mapsto a \otimes g\cdot x$; similarly `rationalHeckeRep` is the ring homomorphism
+$\mathbb{T} \to \operatorname{End}_{\mathbb{Q}_p}(V)$ obtained from `tateHeckeRep` by base change.
+The $\mathbb{Q}_p$-Hecke algebra `rationalHeckeAlgebra` is the $\mathbb{Q}_p$-subalgebra $A
+\subseteq \operatorname{End}_{\mathbb{Q}_p}(V)$ generated by the image of `rationalHeckeRep`, and
+each $\mathbb{T}$-operator lies in it.
+
+The main predicate `RationalRankTwoCyclotomicOf N p J`, formulated for an extension $L/K$ of fields
+with $J$ carrying actions of $\mathbb{T}$ and of $L \simeq_K L$, asserts the existence of a basis
+$b_0, b_1$ of $V$ as an $A$-module indexed by `Fin 2` such that for every prime $\ell \nmid Np$,
+every valuation subring $A'$ of $L$ with `LiesOverPrime` $\ell$ and every $\sigma : L \simeq_K L$
+that is a Frobenius at $\ell$ for $A'$ in the sense of `IsFrobeniusAt`, the four $A$-coordinates
+$c_{ji} = (b.\mathrm{repr}(\sigma b_j))_i$ of the images satisfy $c_{00}c_{11} - c_{10}c_{01} =
+\ell$ in $A$. Thus the assertion is freeness of rank two over $A$ together with a cyclotomic
+determinant condition stated as an identity in the coordinates of $\sigma b_0, \sigma b_1$; no
+commutation between the Galois and Hecke actions is imposed, so $\sigma$ need not act $A$-linearly.
+Finally `RationalRankTwoCyclotomic M p` is the instance $K = \mathbb{Q}$, $L =
+\overline{\mathbb{Q}}$, $N = M$ and $J =$ `JZero M`, the degree-zero divisor class group of the
+level-$M$ modular curve in the project's Laurent-series model, with its arithmetic Galois action and
+a given $\mathbb{T}$-module structure.
+
+**Relation to Mathlib.** Mathlib has neither Tate modules nor Hecke algebras in this form;
+[`TateModule`](../def/EllipticCurve_TateModule.html#L15) and `HeckeAlg` are the project's own, while
+the base-change homomorphisms (`Module.End.baseChangeHom`), `Algebra.adjoin` and `Module.Basis` are
+Mathlib's.
+
+**Where it is used.** The rational Tate module with its Hecke and Galois actions is the vehicle for
+the Eichler–Shimura input: the predicate `RationalRankTwoCyclotomic` expresses, for a chosen model
+of $J_0(M)$, that $V_p J_0(M)$ is free of rank two over the $\mathbb{Q}_p$-Hecke algebra with
+cyclotomic determinant on Frobenius elements, from which two-dimensional Galois representations
+attached to Hecke eigensystems occurring in $J_0(M)$ are obtained.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open scoped TensorProduct
+
+namespace ModularCurve
+
+section Integral
+
+variable (p : ℕ) [Fact p.Prime] (J : Type) [AddCommGroup J] [Module HeckeAlg J]
+
+def tateHeckeRep : HeckeAlg →+* Module.End ℤ_[p] (TateModule p J) where
+  toMonoidHom := TateModule.rep p J HeckeAlg
+  map_zero' := by
+    refine LinearMap.ext fun x => Subtype.ext (funext fun n => ?_)
+    change (0 : HeckeAlg) • (x : ℕ → J) n = 0
+    exact zero_smul HeckeAlg ((x : ℕ → J) n)
+  map_add' s t := by
+    refine LinearMap.ext fun x => Subtype.ext (funext fun n => ?_)
+    change (s + t) • (x : ℕ → J) n = s • (x : ℕ → J) n + t • (x : ℕ → J) n
+    exact add_smul s t ((x : ℕ → J) n)
+
+theorem tateHeckeRep_apply (t : HeckeAlg) :
+    tateHeckeRep p J t = TateModule.rep p J HeckeAlg t :=
+  rfl
+
+theorem coe_tateHeckeRep_apply_apply (t : HeckeAlg) (x : TateModule p J) (n : ℕ) :
+    ((tateHeckeRep p J t x : TateModule p J) : ℕ → J) n = t • (x : ℕ → J) n :=
+  rfl
+
+end Integral
+
+section Rational
+
+variable (p : ℕ) [Fact p.Prime] (J : Type) [AddCommGroup J]
+
+abbrev RationalTateModule : Type :=
+  ℚ_[p] ⊗[ℤ_[p]] TateModule p J
+
+def rationalGaloisRep (G : Type) [Monoid G] [DistribMulAction G J] :
+    G →* Module.End ℚ_[p] (RationalTateModule p J) :=
+  (Module.End.baseChangeHom ℤ_[p] ℚ_[p] (TateModule p J) :
+      Module.End ℤ_[p] (TateModule p J) →* Module.End ℚ_[p] (RationalTateModule p J)).comp
+    (TateModule.rep p J G)
+
+theorem rationalGaloisRep_apply (G : Type) [Monoid G] [DistribMulAction G J] (g : G) :
+    rationalGaloisRep p J G g = (TateModule.rep p J G g).baseChange ℚ_[p] :=
+  rfl
+
+theorem rationalGaloisRep_tmul (G : Type) [Monoid G] [DistribMulAction G J] (g : G) (a : ℚ_[p])
+    (x : TateModule p J) :
+    rationalGaloisRep p J G g (a ⊗ₜ x) = a ⊗ₜ TateModule.rep p J G g x :=
+  rfl
+
+variable [Module HeckeAlg J]
+
+def rationalHeckeRep : HeckeAlg →+* Module.End ℚ_[p] (RationalTateModule p J) :=
+  (Module.End.baseChangeHom ℤ_[p] ℚ_[p] (TateModule p J)).toRingHom.comp (tateHeckeRep p J)
+
+theorem rationalHeckeRep_apply (t : HeckeAlg) :
+    rationalHeckeRep p J t = (tateHeckeRep p J t).baseChange ℚ_[p] :=
+  rfl
+
+theorem rationalHeckeRep_tmul (t : HeckeAlg) (a : ℚ_[p]) (x : TateModule p J) :
+    rationalHeckeRep p J t (a ⊗ₜ x) = a ⊗ₜ tateHeckeRep p J t x :=
+  rfl
+
+def rationalHeckeAlgebra : Subalgebra ℚ_[p] (Module.End ℚ_[p] (RationalTateModule p J)) :=
+  Algebra.adjoin ℚ_[p] (Set.range (rationalHeckeRep p J))
+
+theorem rationalHeckeRep_mem_rationalHeckeAlgebra (t : HeckeAlg) :
+    rationalHeckeRep p J t ∈ rationalHeckeAlgebra p J :=
+  Algebra.subset_adjoin (Set.mem_range_self t)
+
+end Rational
+
+section Predicate
+
+variable {K L : Type} [Field K] [Field L] [Algebra K L]
+variable (N p : ℕ) [Fact p.Prime] (J : Type) [AddCommGroup J] [Module HeckeAlg J]
+  [DistribMulAction (L ≃ₐ[K] L) J]
+
+def RationalRankTwoCyclotomicOf : Prop :=
+  ∃ b : Module.Basis (Fin 2) (rationalHeckeAlgebra p J) (RationalTateModule p J),
+    ∀ ℓ : ℕ, ℓ.Prime → ¬ ℓ ∣ N * p →
+      ∀ A' : ValuationSubring L, A'.LiesOverPrime ℓ →
+        ∀ σ : L ≃ₐ[K] L, A'.IsFrobeniusAt σ ℓ →
+          (b.repr (rationalGaloisRep p J (L ≃ₐ[K] L) σ (b 0))) 0
+              * (b.repr (rationalGaloisRep p J (L ≃ₐ[K] L) σ (b 1))) 1
+            - (b.repr (rationalGaloisRep p J (L ≃ₐ[K] L) σ (b 1))) 0
+              * (b.repr (rationalGaloisRep p J (L ≃ₐ[K] L) σ (b 0))) 1
+            = (ℓ : rationalHeckeAlgebra p J)
+
+end Predicate
+
+section ModularInstance
+
+def RationalRankTwoCyclotomic (M p : ℕ) [Fact p.Prime] [Module HeckeAlg (JZero M)] : Prop :=
+  RationalRankTwoCyclotomicOf (K := ℚ) (L := AlgebraicClosure ℚ) M p (JZero M)
+
+end ModularInstance
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_JqCoeff.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_JqCoeff.lean
new file mode 100644
index 0000000000..6ebca7292a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_JqCoeff.lean
@@ -0,0 +1,139 @@
+/-
+Based on Prove2Me node ModularCurve_JqCoeff
+(21e203b4-817f-5557-90de-372a2e28e137) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+/-!
+# The j-expansion over any commutative ring, and K(j(q),j(qN))
+
+Definition: `ModularCurve_JqCoeff` (`21e203b4-817f-5557-90de-372a2e28e137`), by Claude, 2026-09-05.
+
+Two pieces of coefficient bookkeeping for the formal $q$-expansion of the modular $j$-invariant,
+carried out inside Laurent series rather than on any curve.
+
+First, for any commutative ring $K$, [`ModularCurve.jqModC K : LaurentSeries
+K`](../def/ModularCurve_JqCoeff.html#L15) is defined as `HahnSeries.single (-1) 1 *
+HahnSeries.ofPowerSeries ℤ K (jNum.map (Int.castRingHom K))`: the integral power series `jNum` of
+the imported module has its coefficients pushed along the unique ring map $\mathbb{Z} \to K$ and the
+result is shifted by $q^{-1}$, so that one obtains $q^{-1} + 744 + 196884\,q + \cdots$ read in $K$.
+By construction this is definitionally the project's rational series `jq` when $K = \mathbb{Q}$
+(`jqModC_rat`, proved by `rfl`), and it commutes with arbitrary change of coefficients: `map_jqModC`
+states `(jqModC K).map f = jqModC K'` for every ring homomorphism $f : K \to K'$, whence
+`jqModC_eq_map_intCast : jqModC K = (jqModC ℤ).map (Int.castRingHom K)`. For $N$ with `NeZero N`,
+`jqNModC K N := qExpand K N (jqModC K)` is the substitution $q \mapsto q^N$ applied to this series,
+i.e. $j(q^N)$, with `jqNModC_one` recording $N = 1$.
+
+Second, for a field $K$ and $N \geq 1$, [`ModularCurve.modularFunctionFieldC K
+N`](../def/ModularCurve_JqCoeff.html#L61) is the intermediate field `IntermediateField.adjoin K
+{jqModC K, jqNModC K N}` of $K((q))$, that is $K(j(q), j(q^N))$ generated by the two displayed
+Laurent series; `jqModC_mem` and `jqNModC_mem` record that the two generators lie in it,
+`modularFunctionFieldC_one` that for $N = 1$ it is the single-generator field, and
+`modularFunctionFieldC_rat` that over $\mathbb{Q}$ it is definitionally the two-generator field
+`modularFunctionField N` of the imported module (not the full modular function field). No property
+of these series — order of the pole, non-vanishing, transcendence, Frobenius identities in
+characteristic $\ell$ — is asserted here; the module is purely definitional.
+
+**Relation to Mathlib.** Built on Mathlib's `LaurentSeries`/`HahnSeries` and
+`IntermediateField.adjoin`; Mathlib has no $q$-expansion of $j$ with coefficients in an arbitrary
+commutative ring, so `jqModC` and the field it generates are the project's own, defined by
+transporting the project's integral series `jNum` along $\mathbb{Z} \to K$.
+
+**Where it is used.** These series provide the single definition of 'the $j$-expansion with
+coefficients in $K$' used throughout the project, allowing the characteristic-zero and
+characteristic-$\ell$ situations (e.g. $K = \mathbb{Z}$, $K = \mathbb{Q}$, $K = \mathbb{Z}/\ell$) to
+be compared through a common formula, and the fields $K(j(q),j(q^N))$ serve as the function-field
+model of the modular curve $X_0(N)$ used in the algebraic construction of modular curves and their
+Jacobians.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open HahnSeries
+
+namespace ModularCurve
+
+section JExpansion
+
+variable (K : Type*) [CommRing K]
+
+def jqModC : LaurentSeries K :=
+  HahnSeries.single (-1 : ℤ) 1 * HahnSeries.ofPowerSeries ℤ K (jNum.map (Int.castRingHom K))
+
+def jqNModC (N : ℕ) [NeZero N] : LaurentSeries K := qExpand K N (jqModC K)
+
+@[simp]
+theorem jqNModC_one : jqNModC K 1 = jqModC K := qExpand_one_apply _
+
+theorem jqModC_rat : jqModC ℚ = jq := rfl
+
+variable {K} in
+theorem map_jqModC {K' : Type*} [CommRing K'] (f : K →+* K') :
+    (jqModC K).map f = jqModC K' := by
+  have hmul : ∀ x y : LaurentSeries K, (x * y).map f = x.map f * y.map f :=
+    fun x y => HahnSeries.map_mul f.toNonUnitalRingHom
+  have hsingle : (HahnSeries.single (-1 : ℤ) (1 : K)).map f = HahnSeries.single (-1 : ℤ) 1 := by
+    ext g
+    rw [HahnSeries.map_coeff, HahnSeries.coeff_single, HahnSeries.coeff_single, apply_ite f,
+      map_one, map_zero]
+  have hseries : ∀ u : PowerSeries K,
+      (HahnSeries.ofPowerSeries ℤ K u).map f = HahnSeries.ofPowerSeries ℤ K' (u.map f) := by
+    intro u
+    ext k
+    rw [HahnSeries.map_coeff]
+    rcases le_or_gt 0 k with hk | hk
+    · lift k to ℕ using hk
+      rw [HahnSeries.ofPowerSeries_apply_coeff, HahnSeries.ofPowerSeries_apply_coeff,
+        PowerSeries.coeff_map]
+    · rw [ofPowerSeries_coeff_of_neg _ hk, ofPowerSeries_coeff_of_neg _ hk, map_zero]
+  rw [jqModC, jqModC, hmul, hsingle, hseries,
+    show (jNum.map (Int.castRingHom K)).map f = jNum.map (Int.castRingHom K') from by
+      rw [show PowerSeries.map f (PowerSeries.map (Int.castRingHom K) jNum)
+            = PowerSeries.map (f.comp (Int.castRingHom K)) jNum from
+          (congrFun (congrArg DFunLike.coe (PowerSeries.map_comp (Int.castRingHom K) f)) jNum).symm,
+        RingHom.ext_int (f.comp (Int.castRingHom K)) (Int.castRingHom K')]]
+
+theorem jqModC_eq_map_intCast : jqModC K = (jqModC ℤ).map (Int.castRingHom K) :=
+  (map_jqModC (Int.castRingHom K)).symm
+
+end JExpansion
+
+section FunctionField
+
+variable (K : Type*) [Field K]
+
+def modularFunctionFieldC (N : ℕ) [NeZero N] :
+    IntermediateField K (LaurentSeries K) :=
+  IntermediateField.adjoin K {jqModC K, jqNModC K N}
+
+theorem jqModC_mem (N : ℕ) [NeZero N] : jqModC K ∈ modularFunctionFieldC K N :=
+  IntermediateField.subset_adjoin _ _ (Set.mem_insert _ _)
+
+theorem jqNModC_mem (N : ℕ) [NeZero N] : jqNModC K N ∈ modularFunctionFieldC K N :=
+  IntermediateField.subset_adjoin _ _ (Set.mem_insert_of_mem _ rfl)
+
+theorem modularFunctionFieldC_rat (N : ℕ) [NeZero N] :
+    modularFunctionFieldC ℚ N = modularFunctionField N := rfl
+
+theorem modularFunctionFieldC_one :
+    modularFunctionFieldC K 1 = IntermediateField.adjoin K {jqModC K} := by
+  unfold modularFunctionFieldC
+  rw [jqNModC_one, Set.pair_eq_singleton]
+
+end FunctionField
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_KroneckerTransport.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_KroneckerTransport.lean
new file mode 100644
index 0000000000..38d56cd57d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_KroneckerTransport.lean
@@ -0,0 +1,276 @@
+/-
+Based on Prove2Me node ModularCurve_KroneckerTransport
+(a9cc1a9e-8ed9-5ab9-a586-fcc707ce2923) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Field.ZMod
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+/-!
+# Coefficient reduction of Laurent series and the Kronecker congruence
+
+Definition: `ModularCurve_KroneckerTransport` (`a9cc1a9e-8ed9-5ab9-a586-fcc707ce2923`), by Claude,
+2026-09-05.
+
+For a ring homomorphism $f : R \to S$ of commutative rings, `laurentMap f` is the coefficientwise
+map $R((q)) \to S((q))$ of Laurent (Hahn) series, packaged as a ring homomorphism; its basic
+properties record the value on a coefficient, on a monomial `HahnSeries.single k r`, on the image of
+a power series, compatibility with the substitution operator $q \mapsto q^N$ (`qExpand`),
+injectivity for injective $f$, and composition. Over $\mathbb{Z}$, `jqInt` is the integral
+$j$-expansion $q^{-1}\,\mathrm{jNum}$, where $\mathrm{jNum} = E_4^3 \cdot \eta$-unit${}^{-1}$ is the
+integral power series with constant term $1$ fixed in the $X_0$ definitions; `laurentMap` along
+$\mathbb{Z} \hookrightarrow \mathbb{Q}$ carries it to `jq`, and `jqIntN N` is its $q \mapsto q^N$
+substitute. The accompanying coefficient lemmas state that the coefficient of $q^{-1}$ in `jqInt` is
+$1$, that all lower coefficients vanish, and correspondingly that $(\mathrm{jqInt})^b$ has
+coefficient $1$ in degree $-b$ and vanishes below. Reducing along $\mathbb{Z} \to \mathbb{Z}/\ell$
+gives `jqMod ℓ` and `jqNMod ℓ N` with the same leading-coefficient statements, and `evalAtJInt`,
+`evalAtJMod ℓ` are the evaluation homomorphisms $\mathbb{Z}[X] \to \mathbb{Z}((q))$,
+$(\mathbb{Z}/\ell)[X] \to (\mathbb{Z}/\ell)((q))$ sending $X$ to `jqInt`, `jqMod ℓ`, compatible with
+reduction and with `evalAtJ`.
+
+`reduceModBivar ℓ` is coefficientwise reduction $\mathbb{Z}[X][Y] \to (\mathbb{Z}/\ell)[X][Y]$. For
+a prime-power-free datum, `KroneckerCongruence ℓ data` is a predicate on a chosen modular-equation
+datum `data : ModularPolynomialData ℓ` (a structure carrying a monic bivariate $\Phi$, its degree
+$\psi(\ell)$ in the outer variable, and the vanishing of $\Phi$ at $(j(q), j(q^\ell))$ as fields):
+it asserts the identity $\overline{\Phi} = (X^{\ell} - Y)(X - Y^{\ell})$ in
+$(\mathbb{Z}/\ell)[X][Y]$, with $X$ the inner variable (the $j(q)$ slot) and $Y$ the outer one (the
+$j(q^\ell)$ slot). Finally, for $\ell$ prime, `modularFunctionFieldMod ℓ N` is the intermediate
+field $(\mathbb{Z}/\ell)(\bar j(q), \bar j(q^N))$ of $(\mathbb{Z}/\ell)((q))$, with its two
+generators exhibited as members.
+
+**Relation to Mathlib.** Mathlib supplies `HahnSeries.map` together with its multiplicativity
+lemmas; `laurentMap` bundles these into a ring homomorphism of Laurent series rings, the analogue
+for Laurent series of `Polynomial.mapRingHom`. The Kronecker congruence and the integral and
+mod-$\ell$ $j$-expansions are the project's own notions.
+
+**Where it is used.** These definitions form the definitional layer for the Kronecker-congruence leg
+of the Eichler–Shimura relation: the modular equation for $X_0(\ell)$, established over
+$\mathbb{Q}((q))$, is transported coefficientwise to characteristic $\ell$, where its reduction is
+required to factor as $(X^{\ell} - Y)(X - Y^{\ell})$.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open PowerSeries HahnSeries IntermediateField
+
+namespace ModularCurve
+
+section LaurentMap
+
+variable {R S T : Type*} [CommRing R] [CommRing S] [CommRing T]
+
+def laurentMap (f : R →+* S) : LaurentSeries R →+* LaurentSeries S where
+  toFun x := x.map f
+  map_one' := HahnSeries.map_one (R := R) (S := S) f.toMonoidWithZeroHom
+  map_mul' _ _ := HahnSeries.map_mul (R := R) (S := S) f.toNonUnitalRingHom
+  map_zero' := by
+    ext k
+    change f ((0 : LaurentSeries R).coeff k) = (0 : LaurentSeries S).coeff k
+    rw [HahnSeries.coeff_zero, HahnSeries.coeff_zero, map_zero]
+  map_add' x y := by
+    ext k
+    change f ((x + y).coeff k) = (x.map f + y.map f).coeff k
+    rw [HahnSeries.coeff_add, HahnSeries.coeff_add, map_add]
+    rfl
+
+@[simp]
+theorem laurentMap_coeff (f : R →+* S) (x : LaurentSeries R) (k : ℤ) :
+    (laurentMap f x).coeff k = f (x.coeff k) := rfl
+
+@[simp]
+theorem laurentMap_single (f : R →+* S) (k : ℤ) (r : R) :
+    laurentMap f (HahnSeries.single k r) = HahnSeries.single k (f r) := by
+  ext g
+  rw [laurentMap_coeff, HahnSeries.coeff_single, HahnSeries.coeff_single, apply_ite f,
+    map_zero]
+
+theorem laurentMap_ofPowerSeries (f : R →+* S) (p : PowerSeries R) :
+    laurentMap f (HahnSeries.ofPowerSeries ℤ R p) =
+      HahnSeries.ofPowerSeries ℤ S (p.map f) := by
+  ext k
+  rw [laurentMap_coeff]
+  rcases le_or_gt 0 k with hk | hk
+  · lift k to ℕ using hk
+    rw [HahnSeries.ofPowerSeries_apply_coeff, HahnSeries.ofPowerSeries_apply_coeff,
+      PowerSeries.coeff_map]
+  · rw [ofPowerSeries_coeff_of_neg _ hk, ofPowerSeries_coeff_of_neg _ hk, map_zero]
+
+theorem laurentMap_qExpand (f : R →+* S) (N : ℕ) [NeZero N] (x : LaurentSeries R) :
+    laurentMap f (qExpand R N x) = qExpand S N (laurentMap f x) := by
+  ext k
+  rw [laurentMap_coeff]
+  by_cases hk : (N : ℤ) ∣ k
+  · obtain ⟨m, rfl⟩ := hk
+    rw [qExpand_coeff_mul, qExpand_coeff_mul, laurentMap_coeff]
+  · rw [qExpand_coeff_of_not_dvd N x hk, qExpand_coeff_of_not_dvd N _ hk, map_zero]
+
+theorem laurentMap_injective {f : R →+* S} (hf : Function.Injective f) :
+    Function.Injective (laurentMap f) := by
+  intro x y hxy
+  ext k
+  exact hf (by simpa using congrArg (fun z => z.coeff k) hxy)
+
+theorem laurentMap_laurentMap (f : R →+* S) (g : S →+* T) (x : LaurentSeries R) :
+    laurentMap g (laurentMap f x) = laurentMap (g.comp f) x := by
+  ext k
+  simp
+
+end LaurentMap
+
+section IntegralJ
+
+def jqInt : LaurentSeries ℤ :=
+  HahnSeries.single (-1 : ℤ) 1 * HahnSeries.ofPowerSeries ℤ ℤ jNum
+
+theorem laurentMap_jqInt : laurentMap (Int.castRingHom ℚ) jqInt = jq := by
+  rw [jqInt, map_mul, laurentMap_single, laurentMap_ofPowerSeries, jq, jNumQ, map_one]
+
+def jqIntN (N : ℕ) [NeZero N] : LaurentSeries ℤ := qExpand ℤ N jqInt
+
+theorem laurentMap_jqIntN (N : ℕ) [NeZero N] :
+    laurentMap (Int.castRingHom ℚ) (jqIntN N) = jqN N := by
+  rw [jqIntN, laurentMap_qExpand, laurentMap_jqInt, jqN]
+
+theorem coeff_jqInt_cast (k : ℤ) : ((jqInt.coeff k : ℤ) : ℚ) = jq.coeff k := by
+  rw [← laurentMap_jqInt, laurentMap_coeff]
+  rfl
+
+theorem coeff_jqInt_neg_one : jqInt.coeff (-1 : ℤ) = 1 :=
+  Int.cast_injective (α := ℚ) (by rw [coeff_jqInt_cast, coeff_jq_neg_one, Int.cast_one])
+
+theorem coeff_jqInt_of_lt {k : ℤ} (hk : k < -1) : jqInt.coeff k = 0 :=
+  Int.cast_injective (α := ℚ) (by rw [coeff_jqInt_cast, coeff_jq_of_lt hk, Int.cast_zero])
+
+theorem coeff_jqInt_pow_self (b : ℕ) : (jqInt ^ b).coeff (-(b : ℤ)) = 1 := by
+  refine Int.cast_injective (α := ℚ) ?_
+  have h : ((jqInt ^ b).coeff (-(b : ℤ)) : ℚ) = (jq ^ b).coeff (-(b : ℤ)) := by
+    rw [← laurentMap_jqInt, ← map_pow, laurentMap_coeff]; rfl
+  rw [h, coeff_jq_pow_self, Int.cast_one]
+
+theorem coeff_jqInt_pow_of_lt {b : ℕ} {m : ℤ} (hm : m < -(b : ℤ)) :
+    (jqInt ^ b).coeff m = 0 := by
+  refine Int.cast_injective (α := ℚ) ?_
+  have h : ((jqInt ^ b).coeff m : ℚ) = (jq ^ b).coeff m := by
+    rw [← laurentMap_jqInt, ← map_pow, laurentMap_coeff]; rfl
+  rw [h, coeff_jq_pow_of_lt hm, Int.cast_zero]
+
+end IntegralJ
+
+section ReduceModBivar
+
+def reduceModBivar (ℓ : ℕ) :
+    Polynomial (Polynomial ℤ) →+* Polynomial (Polynomial (ZMod ℓ)) :=
+  Polynomial.mapRingHom (Polynomial.mapRingHom (Int.castRingHom (ZMod ℓ)))
+
+@[simp] theorem reduceModBivar_X (ℓ : ℕ) :
+    reduceModBivar ℓ Polynomial.X = Polynomial.X := by
+  simp [reduceModBivar, Polynomial.coe_mapRingHom]
+
+@[simp] theorem reduceModBivar_C_X (ℓ : ℕ) :
+    reduceModBivar ℓ (Polynomial.C Polynomial.X) = Polynomial.C Polynomial.X := by
+  simp [reduceModBivar, Polynomial.coe_mapRingHom]
+
+end ReduceModBivar
+
+def KroneckerCongruence (ℓ : ℕ) [NeZero ℓ] (data : ModularPolynomialData ℓ) : Prop :=
+  reduceModBivar ℓ data.Φ =
+    (Polynomial.C Polynomial.X ^ ℓ - Polynomial.X) *
+      (Polynomial.C Polynomial.X - Polynomial.X ^ ℓ)
+
+section IntegralEquation
+
+def evalAtJInt : Polynomial ℤ →+* LaurentSeries ℤ :=
+  Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries ℤ)) jqInt
+
+@[simp]
+theorem evalAtJInt_X : evalAtJInt Polynomial.X = jqInt :=
+  Polynomial.eval₂_X _ _
+
+theorem laurentMap_comp_evalAtJInt :
+    (laurentMap (Int.castRingHom ℚ)).comp evalAtJInt = evalAtJ := by
+  refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+  rw [RingHom.comp_apply, evalAtJInt_X, laurentMap_jqInt, evalAtJ_X]
+
+end IntegralEquation
+
+section ModEquation
+
+variable (ℓ : ℕ)
+
+def jqMod : LaurentSeries (ZMod ℓ) := laurentMap (Int.castRingHom (ZMod ℓ)) jqInt
+
+def jqNMod (N : ℕ) [NeZero N] : LaurentSeries (ZMod ℓ) := qExpand (ZMod ℓ) N (jqMod ℓ)
+
+@[simp]
+theorem jqNMod_one : jqNMod ℓ 1 = jqMod ℓ := qExpand_one_apply _
+
+theorem laurentMap_jqIntN_mod (N : ℕ) [NeZero N] :
+    laurentMap (Int.castRingHom (ZMod ℓ)) (jqIntN N) = jqNMod ℓ N := by
+  rw [jqIntN, laurentMap_qExpand, jqNMod, jqMod]
+
+theorem coeff_jqMod (k : ℤ) : (jqMod ℓ).coeff k = (jqInt.coeff k : ZMod ℓ) := rfl
+
+theorem coeff_jqMod_neg_one : (jqMod ℓ).coeff (-1 : ℤ) = 1 := by
+  rw [coeff_jqMod, coeff_jqInt_neg_one, Int.cast_one]
+
+theorem coeff_jqMod_of_lt {k : ℤ} (hk : k < -1) : (jqMod ℓ).coeff k = 0 := by
+  rw [coeff_jqMod, coeff_jqInt_of_lt hk, Int.cast_zero]
+
+theorem coeff_jqMod_pow_self (b : ℕ) : ((jqMod ℓ) ^ b).coeff (-(b : ℤ)) = 1 := by
+  have h : ((jqMod ℓ) ^ b).coeff (-(b : ℤ)) = ((jqInt ^ b).coeff (-(b : ℤ)) : ZMod ℓ) := by
+    rw [jqMod, ← map_pow, laurentMap_coeff]; rfl
+  rw [h, coeff_jqInt_pow_self, Int.cast_one]
+
+theorem coeff_jqMod_pow_of_lt {b : ℕ} {m : ℤ} (hm : m < -(b : ℤ)) :
+    ((jqMod ℓ) ^ b).coeff m = 0 := by
+  have h : ((jqMod ℓ) ^ b).coeff m = ((jqInt ^ b).coeff m : ZMod ℓ) := by
+    rw [jqMod, ← map_pow, laurentMap_coeff]; rfl
+  rw [h, coeff_jqInt_pow_of_lt hm, Int.cast_zero]
+
+def evalAtJMod : Polynomial (ZMod ℓ) →+* LaurentSeries (ZMod ℓ) :=
+  Polynomial.eval₂RingHom (algebraMap (ZMod ℓ) (LaurentSeries (ZMod ℓ))) (jqMod ℓ)
+
+@[simp]
+theorem evalAtJMod_X : evalAtJMod ℓ Polynomial.X = jqMod ℓ :=
+  Polynomial.eval₂_X _ _
+
+theorem evalAtJMod_comp_map :
+    (evalAtJMod ℓ).comp (Polynomial.mapRingHom (Int.castRingHom (ZMod ℓ))) =
+      (laurentMap (Int.castRingHom (ZMod ℓ))).comp evalAtJInt := by
+  refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+  rw [RingHom.comp_apply, RingHom.comp_apply, Polynomial.coe_mapRingHom, Polynomial.map_X,
+    evalAtJMod_X, evalAtJInt_X, jqMod]
+
+end ModEquation
+
+section ModFunctionField
+
+variable (ℓ : ℕ) [Fact ℓ.Prime]
+
+def modularFunctionFieldMod (N : ℕ) [NeZero N] :
+    IntermediateField (ZMod ℓ) (LaurentSeries (ZMod ℓ)) :=
+  IntermediateField.adjoin (ZMod ℓ) {jqMod ℓ, jqNMod ℓ N}
+
+theorem jqMod_mem (N : ℕ) [NeZero N] : jqMod ℓ ∈ modularFunctionFieldMod ℓ N :=
+  IntermediateField.subset_adjoin _ _ (Set.mem_insert _ _)
+
+theorem jqNMod_mem (N : ℕ) [NeZero N] : jqNMod ℓ N ∈ modularFunctionFieldMod ℓ N :=
+  IntermediateField.subset_adjoin _ _ (Set.mem_insert_of_mem _ rfl)
+
+end ModFunctionField
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_LaurentCoeff.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_LaurentCoeff.lean
new file mode 100644
index 0000000000..df9c4586b3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_LaurentCoeff.lean
@@ -0,0 +1,198 @@
+/-
+Based on Prove2Me node ModularCurve_LaurentCoeff
+(df67c7d0-ce84-5e1b-8306-0205c75872d3) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.LaurentSeries
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+
+/-!
+# Coefficientwise maps of Laurent series; base change of subfields
+
+Definition: `ModularCurve_LaurentCoeff` (`df67c7d0-ce84-5e1b-8306-0205c75872d3`), by Claude,
+2026-09-05.
+
+Working in $\mathrm{LaurentSeries}\,R = \mathrm{HahnSeries}\,\mathbb{Z}\,R$, the module supplies
+three pieces of vocabulary. First, for commutative rings $R, S$ and a ring homomorphism $f : R \to
+S$, `coeffMap f : LaurentSeries R →+* LaurentSeries S` is Mathlib's `HahnSeries.map` applied
+coefficientwise, $\sum a_k q^k \mapsto \sum f(a_k) q^k$, packaged as a ring homomorphism; the
+accompanying lemmas record $(\mathrm{coeffMap}\,f\,x).\mathrm{coeff}\,k = f(x.\mathrm{coeff}\,k)$
+(true by definition), the effect on single terms `HahnSeries.single k r`, the composition law
+$\mathrm{coeffMap}\,g \circ \mathrm{coeffMap}\,f = \mathrm{coeffMap}\,(g \circ f)$, the identity
+case, and congruence in $f$.
+
+Second, for a field $L$: `algebraMap_laurentSeries_eq_single` identifies the image of $c \in L$
+under the algebra map $L \to L((q))$ (Mathlib's power-series algebra structure) with the series
+`HahnSeries.single 0 c`; `coeffMap_algebraMap` says a coefficientwise endomorphism $\varphi : L \to
+L$ carries constants to constants, covering $\varphi$. When moreover $L$ is a $\mathbb{Q}$-algebra,
+`coeffEmb L : LaurentSeries ℚ →+* LaurentSeries L` is by definition
+$\mathrm{coeffMap}(\mathrm{algebraMap}\,\mathbb{Q}\,L)$, with its coefficient formula, and
+`coeffMap_coeffEmb` states that every $\sigma \in L \simeq_{\mathbb{Q}} L$ acting coefficientwise
+fixes each series in the image of `coeffEmb L`.
+
+Third, for such an $L$ and an intermediate field $F_0$ of $\mathbb{Q}((q))/\mathbb{Q}$,
+`laurentBaseChange L F₀ : IntermediateField L (LaurentSeries L)` is defined as
+`IntermediateField.adjoin L` applied to the set $\mathrm{coeffEmb}_L(F_0)$, i.e. the compositum
+$L\cdot F_0$ inside $L((q))$. Three lemmas follow: the image of $F_0$ lies in it; membership
+unfolds, definitionally, to membership in the `Subfield.closure` of the union of the range of
+$\mathrm{algebraMap}\,L\,(L((q)))$ with $\mathrm{coeffEmb}_L(F_0)$; and $L\cdot F_0$ is stable under
+the coefficientwise action of every $\sigma \in L \simeq_{\mathbb{Q}} L$, proved by closure
+induction. Nothing here concerns modular curves; the material is pure field-theoretic vocabulary.
+
+**Relation to Mathlib.** `coeffMap` bundles Mathlib's `HahnSeries.map` as a ring homomorphism on
+`LaurentSeries`; `laurentBaseChange` is an application of Mathlib's `IntermediateField.adjoin`, and
+the `Algebra L (LaurentSeries L)` structure used is Mathlib's power-series algebra structure. The
+named combinations (`coeffEmb`, `laurentBaseChange`) are the project's own abbreviations.
+
+**Where it is used.** These constructions provide the coefficientwise ("arithmetic") Galois action
+on fields of formal $q$-expansions and the base change $F_0 \mapsto L\cdot F_0$ of a subfield of
+$\mathbb{Q}((q))$ to $L((q))$, used when modular function fields are presented via $q$-expansions
+and then extended to larger coefficient fields in the modular-curve layer feeding the study of
+$J_0(N)$.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section DL_provinculum
+
+open HahnSeries IntermediateField
+
+namespace ModularCurve
+
+section CoeffMap
+
+variable {R S T : Type*} [CommRing R] [CommRing S] [CommRing T]
+
+def coeffMap (f : R →+* S) : LaurentSeries R →+* LaurentSeries S where
+  toFun x := x.map f
+  map_zero' := by
+    ext k
+    simp
+  map_one' := by
+    ext k
+    simp [HahnSeries.coeff_one, apply_ite f]
+  map_add' x y := by
+    ext k
+    simp
+  map_mul' x y := by
+    have h := HahnSeries.map_mul (f := (f : R →ₙ+* S)) (x := x) (y := y)
+    have hx : ∀ z : LaurentSeries R, z.map (f : R →ₙ+* S) = z.map f := fun z =>
+      HahnSeries.ext rfl
+    rwa [hx, hx, hx] at h
+
+@[simp]
+theorem coeffMap_coeff (f : R →+* S) (x : LaurentSeries R) (k : ℤ) :
+    (coeffMap f x).coeff k = f (x.coeff k) :=
+  rfl
+
+@[simp]
+theorem coeffMap_single (f : R →+* S) (k : ℤ) (r : R) :
+    coeffMap f (HahnSeries.single k r) = HahnSeries.single k (f r) := by
+  ext m
+  rcases eq_or_ne m k with rfl | hm
+  · simp [HahnSeries.coeff_single_same]
+  · simp [HahnSeries.coeff_single_of_ne hm]
+
+theorem coeffMap_coeffMap (g : S →+* T) (f : R →+* S) (x : LaurentSeries R) :
+    coeffMap g (coeffMap f x) = coeffMap (g.comp f) x := by
+  ext k
+  simp
+
+@[simp]
+theorem coeffMap_id (x : LaurentSeries R) : coeffMap (RingHom.id R) x = x := by
+  ext k
+  simp
+
+theorem coeffMap_congr {f g : R →+* S} (h : f = g) (x : LaurentSeries R) :
+    coeffMap f x = coeffMap g x := by
+  subst h; rfl
+
+end CoeffMap
+
+section Constants
+
+variable (L : Type*) [Field L]
+
+theorem algebraMap_laurentSeries_eq_single (c : L) :
+    algebraMap L (LaurentSeries L) c = HahnSeries.single 0 c := by
+  have h1 : algebraMap L (PowerSeries L) c = PowerSeries.C c := by
+    simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+  rfl
+
+variable {L} in
+theorem coeffMap_algebraMap (φ : L →+* L) (c : L) :
+    coeffMap φ (algebraMap L (LaurentSeries L) c) = algebraMap L (LaurentSeries L) (φ c) := by
+  rw [algebraMap_laurentSeries_eq_single, algebraMap_laurentSeries_eq_single, coeffMap_single]
+
+variable [Algebra ℚ L]
+
+def coeffEmb : LaurentSeries ℚ →+* LaurentSeries L :=
+  coeffMap (algebraMap ℚ L)
+
+@[simp]
+theorem coeffEmb_coeff (x : LaurentSeries ℚ) (k : ℤ) :
+    (coeffEmb L x).coeff k = algebraMap ℚ L (x.coeff k) :=
+  rfl
+
+variable {L} in
+theorem coeffMap_coeffEmb (σ : L ≃ₐ[ℚ] L) (x : LaurentSeries ℚ) :
+    coeffMap (σ : L →+* L) (coeffEmb L x) = coeffEmb L x := by
+  rw [coeffEmb, coeffMap_coeffMap]
+  exact coeffMap_congr (RingHom.ext fun c => σ.commutes c) x
+
+end Constants
+
+section BaseChange
+
+variable (L : Type*) [Field L] [Algebra ℚ L]
+variable (F₀ : IntermediateField ℚ (LaurentSeries ℚ))
+
+def laurentBaseChange : IntermediateField L (LaurentSeries L) :=
+  IntermediateField.adjoin L (⇑(coeffEmb L) '' (F₀ : Set (LaurentSeries ℚ)))
+
+variable {F₀} in
+theorem coeffEmb_mem_laurentBaseChange {x : LaurentSeries ℚ} (hx : x ∈ F₀) :
+    coeffEmb L x ∈ laurentBaseChange L F₀ :=
+  IntermediateField.subset_adjoin L _ ⟨x, hx, rfl⟩
+
+variable {L F₀} in
+theorem mem_laurentBaseChange_iff {x : LaurentSeries L} :
+    x ∈ laurentBaseChange L F₀ ↔
+      x ∈ Subfield.closure
+        (Set.range (algebraMap L (LaurentSeries L)) ∪
+          (⇑(coeffEmb L) '' (F₀ : Set (LaurentSeries ℚ)))) :=
+  Iff.rfl
+
+variable {L F₀} in
+theorem coeffMap_mem_laurentBaseChange (σ : L ≃ₐ[ℚ] L) {x : LaurentSeries L}
+    (hx : x ∈ laurentBaseChange L F₀) :
+    coeffMap (σ : L →+* L) x ∈ laurentBaseChange L F₀ := by
+  rw [mem_laurentBaseChange_iff] at hx
+  induction hx using Subfield.closure_induction with
+  | mem y hy =>
+      rcases hy with ⟨a, rfl⟩ | ⟨z, hz, rfl⟩
+      · rw [coeffMap_algebraMap]
+        exact (laurentBaseChange L F₀).algebraMap_mem _
+      · rw [coeffMap_coeffEmb]
+        exact coeffEmb_mem_laurentBaseChange L hz
+  | one => simp
+  | add x y _ _ hx hy => simpa using add_mem hx hy
+  | neg x _ hx => simpa using neg_mem hx
+  | inv x _ hx => simpa using inv_mem hx
+  | mul x y _ _ hx hy => simpa using mul_mem hx hy
+
+end BaseChange
+
+end ModularCurve
+
+end DL_provinculum
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_LevelNFunctionField.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_LevelNFunctionField.lean
new file mode 100644
index 0000000000..b0be662743
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_LevelNFunctionField.lean
@@ -0,0 +1,112 @@
+/-
+Based on Prove2Me node ModularCurve_LevelNFunctionField
+(335f222f-fb10-52a8-85e2-9ca6908b27ec) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_PeriodPair_Uniformization
+
+/-!
+# Fricke functions and the level-N analytic coordinate ring
+
+Definition: `ModularCurve_LevelNFunctionField` (`335f222f-fb10-52a8-85e2-9ca6908b27ec`), by Claude,
+2026-09-05.
+
+Fix a natural number $N$. For $v = (v_0,v_1) \in (\mathbb{Z}/N\mathbb{Z})^2$ and $\tau$ in the upper
+half-plane, [`ModularCurve.LevelN.wp N v τ`](../def/ModularCurve_LevelNFunctionField.html#L14) is
+$((2\pi i)^2)^{-1}$ times the value of the Weierstrass function `PeriodPair.weierstrassP` of the
+period pair [`PeriodPair.ofTau τ`](../def/PeriodPair_Uniformization.html#L104) — the pair with
+periods $\omega_1 = \tau$, $\omega_2 = 1$, whose lattice is the $\mathbb{Z}$-span of $\{\tau, 1\}$ —
+at the argument $(v_0\tau + v_1)/N$, where the integers $v_0, v_1$ are the canonical representatives
+(`ZMod.val`) of the two coordinates of $v$. The Fricke function [`ModularCurve.LevelN.fricke N
+v`](../def/ModularCurve_LevelNFunctionField.html#L19) is the pointwise product of this with
+$-E_4(\tau)E_6(\tau)/\bigl(2592\,\Delta(\tau)\bigr)$, where $E_4$, $E_6$ and $\Delta$ are Mathlib's
+level-one Eisenstein series and discriminant;
+[`ModularCurve.LevelN.jAnalytic`](../def/ModularCurve_LevelNFunctionField.html#L22) is the function
+$\tau \mapsto E_4(\tau)^3/\Delta(\tau)$. No holomorphy, modularity or nonvanishing assertion is part
+of these definitions: each is simply a function $\mathbb{H} \to \mathbb{C}$, with the usual
+conventions for division by zero in $\mathbb{C}$.
+
+The set [`ModularCurve.LevelN.generators N`](../def/ModularCurve_LevelNFunctionField.html#L25) is
+obtained by inserting `jAnalytic` into the set of those functions $g : \mathbb{H} \to \mathbb{C}$
+for which there is a nonzero $v \in (\mathbb{Z}/N\mathbb{Z})^2$ with $g =$ `fricke N v`; and
+[`ModularCurve.LevelN.ring N`](../def/ModularCurve_LevelNFunctionField.html#L28) is the
+$\mathbb{C}$-subalgebra of the algebra of all functions $\mathbb{H} \to \mathbb{C}$ (pointwise
+operations) generated by this set, i.e. $\mathbb{C}[j, f_v : v \neq 0]$. The accompanying lemmas
+record that `jAnalytic` and each `fricke N v` with $v \neq 0$ lie in the generating set and hence in
+the subalgebra, and [`ModularCurve.LevelN.jGen N`](../def/ModularCurve_LevelNFunctionField.html#L44)
+packages `jAnalytic` as an element of that subalgebra, with its underlying function being
+`jAnalytic` again.
+
+**Relation to Mathlib.** The Eisenstein series `ModularForm.E₄`, `ModularForm.E₆` and
+`ModularForm.discriminant` and the upper half-plane are Mathlib's; the period-pair Weierstrass
+function is the project's own, and Mathlib has no Fricke functions or level-$N$ function field,
+which are introduced here.
+
+**Where it is used.** These functions provide the concrete analytic model of the modular curve of
+level $N$: the subalgebra `ring N` is the analytic coordinate ring whose fraction field serves as
+the field of modular functions of level $N$, and the Fricke functions are the coordinates in which
+the transformation law $f_v(\gamma\tau) = f_{v\gamma}(\tau)$ and the invariance under $\pm\Gamma(N)$
+are stated elsewhere in the development.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open UpperHalfPlane
+
+open scoped MatrixGroups
+
+namespace ModularCurve.LevelN
+
+def wp (N : ℕ) (v : Fin 2 → ZMod N) (τ : ℍ) : ℂ :=
+  ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+    PeriodPair.weierstrassP (PeriodPair.ofTau τ)
+      ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ))
+
+def fricke (N : ℕ) (v : Fin 2 → ZMod N) (τ : ℍ) : ℂ :=
+  -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * wp N v τ
+
+def jAnalytic (τ : ℍ) : ℂ :=
+  ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ
+
+def generators (N : ℕ) : Set (ℍ → ℂ) :=
+  insert jAnalytic {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke N v}
+
+def ring (N : ℕ) : Subalgebra ℂ (ℍ → ℂ) :=
+  Algebra.adjoin ℂ (generators N)
+
+theorem jAnalytic_mem_generators (N : ℕ) : jAnalytic ∈ generators N :=
+  Set.mem_insert _ _
+
+theorem fricke_mem_generators (N : ℕ) {v : Fin 2 → ZMod N} (hv : v ≠ 0) :
+    fricke N v ∈ generators N :=
+  Set.mem_insert_of_mem _ ⟨v, hv, rfl⟩
+
+theorem jAnalytic_mem (N : ℕ) : jAnalytic ∈ ring N :=
+  Algebra.subset_adjoin (jAnalytic_mem_generators N)
+
+theorem fricke_mem (N : ℕ) {v : Fin 2 → ZMod N} (hv : v ≠ 0) : fricke N v ∈ ring N :=
+  Algebra.subset_adjoin (fricke_mem_generators N hv)
+
+def jGen (N : ℕ) : ring N :=
+  ⟨jAnalytic, jAnalytic_mem N⟩
+
+@[simp]
+theorem coe_jGen (N : ℕ) : ((jGen N : ring N) : ℍ → ℂ) = jAnalytic :=
+  rfl
+
+end ModularCurve.LevelN
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_MazurStepThree.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_MazurStepThree.lean
new file mode 100644
index 0000000000..f92da90da6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_MazurStepThree.lean
@@ -0,0 +1,79 @@
+/-
+Based on Prove2Me node ModularCurve_MazurStepThree
+(bfab6254-0165-5ea1-ba1b-2c632ef97d41) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_ZeroComponentAt
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Ramification
+
+/-!
+# Mazur's Step Three as a named proposition
+
+Definition: `ModularCurve_MazurStepThree` (`bfab6254-0165-5ea1-ba1b-2c632ef97d41`), by Claude,
+2026-09-05.
+
+This module introduces a single Prop-valued definition, [`MazurStepThree
+p`](../def/ModularCurve_MazurStepThree.html#L8), indexed by a natural number $p$; nothing is proved
+here. Unfolded, [`MazurStepThree p`](../def/ModularCurve_MazurStepThree.html#L8) asserts: suppose
+$p$ is prime and $p \notin \{2,3,5,7,13\}$; let $W$ be a Weierstrass curve over $\mathbb Z$ with
+$\Delta \neq 0$ satisfying the semistability condition that no prime $q$ dividing $\Delta$ divides
+$c_4$; let $Q$ be a point of $W$ base-changed along $\mathbb Z \to \mathbb Q$ and then to
+$\overline{\mathbb Q}$ (the algebraic closure `AlgebraicClosure ℚ`), fixed by every $\mathbb
+Q$-algebra automorphism of $\overline{\mathbb Q}$ and of exact additive order $p$. Assume further
+that $2 \mid \Delta$ and $Q$ fails `W.InZeroComponentAt A` for every valuation subring $A \subseteq
+\overline{\mathbb Q}$ with $2$ a nonunit of $A$, and likewise that $3 \mid \Delta$ with $Q$ off the
+zero component at every valuation subring over $3$. The conclusion is that for every prime $\ell
+\notin \{2,3,p\}$ dividing $\Delta$ and every valuation subring $A$ of $\overline{\mathbb Q}$ with
+$\ell$ a nonunit (the predicate
+[`ValuationSubring.LiesOverPrime`](../def/FLTPrelim_Ramification.html#L16)), $Q$ again fails
+`W.InZeroComponentAt A`.
+
+Here `W.InZeroComponentAt A P` holds when $P = 0$, or $P = (x,y)$ with either $x \notin A$, or $x, y
+\in A$ and the images of $x,y$ in the residue field of $A$ give a nonsingular point of $W$ reduced
+to that residue field. Thus membership in the "zero component" is a condition on the chosen integral
+model $W$ and on the valuation subring, expressed by reduction into the smooth locus, not via a
+Néron model. The behaviour of $Q$ at $2$ and at $3$ is assumed rather than derived, so the statement
+is counting-free at those primes.
+
+**Relation to Mathlib.** Mathlib supplies Weierstrass curves, their affine points, valuation
+subrings and residue fields; the predicates
+[`WeierstrassCurve.InZeroComponentAt`](../def/EllipticCurve_ZeroComponentAt.html#L13) and
+[`ValuationSubring.LiesOverPrime`](../def/FLTPrelim_Ramification.html#L16), as well as the action of
+$\overline{\mathbb Q} \simeq_{\mathbb Q} \overline{\mathbb Q}$ on points used to express
+Galois-fixedness, are the project's own.
+
+**Where it is used.** The proposition packages the input from Mazur's work needed along the route:
+for a semistable integral model with a rational point of prime order $p \notin \{2,3,5,7,13\}$,
+nontrivial behaviour at the bad primes $2$ and $3$ propagates to all other bad primes away from $p$.
+It is stated as a named Prop so that it can be established from further named inputs and then
+applied in the analysis of the Frey curve's $p$-torsion.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open WeierstrassCurve WeierstrassCurve.Affine in
+def MazurStepThree (p : ℕ) : Prop :=
+  p.Prime → p ∉ ({2, 3, 5, 7, 13} : Finset ℕ) →
+  ∀ (W : WeierstrassCurve ℤ), W.Δ ≠ 0 →
+    (∀ q : ℕ, q.Prime → (q : ℤ) ∣ W.Δ → ¬ (q : ℤ) ∣ W.c₄) →
+    ∀ (Q : ((W.map (Int.castRingHom ℚ))⁄(AlgebraicClosure ℚ)).Point),
+      (∀ σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ, σ • Q = Q) →
+      addOrderOf Q = p →
+      (2 : ℤ) ∣ W.Δ →
+      (∀ A : ValuationSubring (AlgebraicClosure ℚ), A.LiesOverPrime 2 →
+        ¬ W.InZeroComponentAt A Q) →
+      (3 : ℤ) ∣ W.Δ →
+      (∀ A : ValuationSubring (AlgebraicClosure ℚ), A.LiesOverPrime 3 →
+        ¬ W.InZeroComponentAt A Q) →
+      ∀ (ℓ : ℕ), ℓ.Prime → ℓ ≠ 2 → ℓ ≠ 3 → ℓ ≠ p → (ℓ : ℤ) ∣ W.Δ →
+        ∀ A : ValuationSubring (AlgebraicClosure ℚ), A.LiesOverPrime ℓ →
+          ¬ W.InZeroComponentAt A Q
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_MazurStepThreeInputs.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_MazurStepThreeInputs.lean
new file mode 100644
index 0000000000..a63529f8e5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_MazurStepThreeInputs.lean
@@ -0,0 +1,201 @@
+/-
+Based on Prove2Me node ModularCurve_MazurStepThreeInputs
+(e3e6892f-f171-5eae-9a79-bf709f2cab60) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_Eisenstein
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_MazurStepThree
+
+/-!
+# Named inputs for Mazur's step three over X0​(p)
+
+Definition: `ModularCurve_MazurStepThreeInputs` (`e3e6892f-f171-5eae-9a79-bf709f2cab60`), by Claude,
+2026-09-05.
+
+Fix a prime-to-be $p$ with `NeZero p`, and let `JZero p` be the degree-zero divisor class group
+$\mathrm{Pic}^0$ of the geometric modular function field `modularFunctionFieldBar p` over
+$\overline{\mathbb Q}$. Throughout, the Hecke-module structure is an explicit binder `inst : Module
+HeckeAlg (JZero p)` rather than an instance, `HeckeAlg` being the polynomial ring $\mathbb Z[T_\ell
+: \ell \text{ prime}]$. First come the carriers: `eisensteinKernelSubmodule p inst` is
+$\gamma\cdot\top$, where $\gamma$ is the ideal `eisensteinKernel` attached to `eisensteinIdeal p`
+(the kernel of $T_\ell \mapsto 1$ for $\ell \mid p$, $T_\ell \mapsto 1+\ell$ otherwise);
+`EisensteinQuotient p inst` is the quotient of `JZero p` by it, `eisensteinQuotientMk` the quotient
+map, and `eisensteinQuotientRational` the image of the set of $x$ with $\sigma\cdot x - x \in
+\gamma\cdot\top$ for all $\sigma \in \mathrm{Gal}(\overline{\mathbb Q}/\mathbb Q)$, i.e. the
+"rational part" of the quotient. The theorem `eisensteinQuotientInvariantsFiniteAt_iff` records, by
+`Iff.rfl`, that the project's predicate `EisensteinQuotientInvariantsFiniteAt` is exactly finiteness
+of this set. `CuspidalClassSurvives` says the class of $(\bar 0)-(\bar\infty)$ does not lie in
+$\gamma\cdot\top$. Next, `jBar p` and `jpBar p` are the coefficientwise images in
+`modularFunctionFieldBar p` of the $q$-expansions $j(q)$ and $j(q^p)$, and `placeDiff p x y` is the
+divisor $(x)-(y)$.
+
+`MazurQuotientSpecialization p inst` asserts: for every prime $\ell \neq p$ and every valuation
+subring $A$ of $\overline{\mathbb Q}$ with $\ell$ a nonunit of $A$, there are an abelian group $T$
+and an additive map $s$ from the Eisenstein quotient such that (i) $s$ is injective on the
+prime-to-$\ell$ torsion of `eisensteinQuotientRational`, (ii) if $\ell \neq 2$, also on its
+$\ell$-power torsion, and (iii) $s$ annihilates the class of $(x)-(\bar\infty)$, resp. $(x)-(\bar
+0)$, for every place $x$ fixed by the arithmetic Galois action with $\mathrm{ord}_x(\,\bar j - j_1)
+> 0$, $\mathrm{ord}_x(\,\bar j_p - j_2) > 0$ and $v_A(j_1) > 1$, under $v_A(j_2) = v_A(j_1)^p$,
+resp. $v_A(j_2)^p = v_A(j_1)$ (the relevant divisors being assumed of degree zero).
+
+Finally, `jInt W` is $c_4^3/\Delta$ computed with Lean's total division (so $0$ when $\Delta = 0$;
+every use assumes $\Delta \neq 0$), and `JQuot` is the type of functions assigning to each integral
+Weierstrass curve $W$ and each $\overline{\mathbb Q}$-point of $W_{\mathbb Q}$ an element of
+$\overline{\mathbb Q}$ — an abstract stand-in for the $j$-invariant of the quotient, with no
+identification built in. For such a `jQuot`, `ModuliPointExists` says that for $p$ prime, $W$ with
+$\Delta \neq 0$ and $q \nmid c_4$ for every prime $q \mid \Delta$, and every Galois-fixed point $Q$
+of exact order $p$, there is a degree-one place of `modularFunctionFieldBar p`, fixed by the
+arithmetic Galois action, at which both $\bar j - \mathrm{jInt}\,W$ and $\bar j_p -
+\mathrm{jQuot}\,W\,Q$ have positive order. `TateCuspCriterion` says that in the same situation, at a
+prime $\ell \neq p$ with $\ell \mid \Delta$, $\ell \nmid c_4$ and $A$ over $\ell$, one has
+$v_A(\mathrm{jInt}\,W) > 1$, and that $Q$ lies in the zero component at $A$ (in the sense of the
+project's `InZeroComponentAt`: $Q = 0$, or $Q = (x,y)$ with $x \notin A$, or $x,y \in A$ with
+nonsingular reduction) implies $v_A(\mathrm{jQuot}\,W\,Q) = v_A(\mathrm{jInt}\,W)^p$, while failure
+of that condition implies $v_A(\mathrm{jQuot}\,W\,Q)^p = v_A(\mathrm{jInt}\,W)$; these are two
+one-directional implications, not stated as equivalences.
+
+**Relation to Mathlib.** Weierstrass curves, their invariants $c_4,\Delta$, affine points and
+`ValuationSubring` are Mathlib's; the curve-theoretic framework used here (places, divisors,
+$\mathrm{Pic}^0$, the modular function field as a subfield of Laurent series, the Hecke algebra and
+the Eisenstein ideal) is the project's own, as are `InZeroComponentAt` and `LiesOverPrime`.
+
+**Where it is used.** These predicates isolate, as propositions carrying no proof, the inputs from
+Mazur's study of the Eisenstein ideal and from Tate uniformisation that are consumed by the
+reduction proving [`MazurStepThree p`](../def/ModularCurve_MazurStepThree.html#L8): the finiteness
+of the rational part of the Eisenstein quotient, survival of the cuspidal class (which fails for $p
+\le 7$ and $p = 13$), the specialisation map with its injectivity and cusp-killing clauses,
+existence of the moduli point attached to a pair $(W, \langle Q\rangle)$, and the Tate-curve
+computation of the quotient $j$-invariant's valuation.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open AlgebraicCurve
+
+namespace ModularCurve
+
+variable (p : ℕ) [NeZero p]
+
+def eisensteinKernelSubmodule (inst : Module HeckeAlg (JZero p)) :
+    letI := inst; Submodule HeckeAlg (JZero p) :=
+  letI := inst
+  eisensteinKernel (JZero p) (eisensteinIdeal p) • (⊤ : Submodule HeckeAlg (JZero p))
+
+abbrev EisensteinQuotient (inst : Module HeckeAlg (JZero p)) : Type :=
+  letI := inst
+  JZero p ⧸ eisensteinKernelSubmodule p inst
+
+def eisensteinQuotientMk (inst : Module HeckeAlg (JZero p)) :
+    JZero p →+ EisensteinQuotient p inst :=
+  letI := inst
+  (eisensteinKernelSubmodule p inst).mkQ.toAddMonoidHom
+
+def eisensteinQuotientRational (inst : Module HeckeAlg (JZero p)) :
+    Set (EisensteinQuotient p inst) :=
+  letI := inst
+  eisensteinQuotientMk p inst ''
+    {x : JZero p | ∀ σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ,
+      σ • x - x ∈ eisensteinKernelSubmodule p inst}
+
+theorem eisensteinQuotientInvariantsFiniteAt_iff (inst : Module HeckeAlg (JZero p)) :
+    EisensteinQuotientInvariantsFiniteAt p inst ↔ (eisensteinQuotientRational p inst).Finite :=
+  Iff.rfl
+
+def CuspidalClassSurvives (inst : Module HeckeAlg (JZero p)) : Prop :=
+  letI := inst
+  cuspidalClass p ∉ eisensteinKernelSubmodule p inst
+
+abbrev jBar : modularFunctionFieldBar p :=
+  ⟨coeffEmb (AlgebraicClosure ℚ) jq,
+    coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full p)⟩
+
+abbrev jpBar : modularFunctionFieldBar p :=
+  ⟨coeffEmb (AlgebraicClosure ℚ) (qExpand ℚ p jq),
+    coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jqd_mem_full p (dvd_refl p))⟩
+
+def placeDiff (x y : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar p)) :
+    Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar p) :=
+  Finsupp.single x 1 - Finsupp.single y 1
+
+def MazurQuotientSpecialization (inst : Module HeckeAlg (JZero p)) : Prop :=
+  letI := inst
+  ∀ ℓ : ℕ, ℓ.Prime → ℓ ≠ p →
+    ∀ A : ValuationSubring (AlgebraicClosure ℚ), A.LiesOverPrime ℓ →
+      ∃ (T : Type) (_ : AddCommGroup T) (s : EisensteinQuotient p inst →+ T),
+        (∀ z ∈ eisensteinQuotientRational p inst,
+            (∃ m : ℕ, ¬ ℓ ∣ m ∧ m • z = 0) → s z = 0 → z = 0) ∧
+        (ℓ ≠ 2 → ∀ z ∈ eisensteinQuotientRational p inst,
+            (∃ k : ℕ, ℓ ^ k • z = 0) → s z = 0 → z = 0) ∧
+        (∀ (x : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar p))
+            (j₁ j₂ : AlgebraicClosure ℚ)
+            (hinf : placeDiff p x (cuspInftyBar p) ∈ Divisor.degZero)
+            (hzero : placeDiff p x (cuspZeroBar p) ∈ Divisor.degZero),
+          (∀ σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ,
+              arithmeticGalois (modularFunctionFieldFull p) σ • x = x) →
+          0 < x.ord (jBar p - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar p) j₁) →
+          0 < x.ord (jpBar p - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar p) j₂) →
+          1 < A.valuation j₁ →
+            (A.valuation j₂ = A.valuation j₁ ^ p →
+              s (eisensteinQuotientMk p inst
+                (Pic0.mk ⟨placeDiff p x (cuspInftyBar p), hinf⟩)) = 0) ∧
+            (A.valuation j₂ ^ p = A.valuation j₁ →
+              s (eisensteinQuotientMk p inst
+                (Pic0.mk ⟨placeDiff p x (cuspZeroBar p), hzero⟩)) = 0))
+
+end ModularCurve
+
+namespace ModularCurve
+
+open WeierstrassCurve WeierstrassCurve.Affine
+
+variable (p : ℕ) [NeZero p]
+
+def jInt (W : WeierstrassCurve ℤ) : AlgebraicClosure ℚ :=
+  ((W.c₄ : ℤ) : AlgebraicClosure ℚ) ^ 3 / ((W.Δ : ℤ) : AlgebraicClosure ℚ)
+
+abbrev JQuot : Type :=
+  (W : WeierstrassCurve ℤ) → ((W.map (Int.castRingHom ℚ))⁄(AlgebraicClosure ℚ)).Point →
+    AlgebraicClosure ℚ
+
+def ModuliPointExists (jQuot : JQuot) : Prop :=
+  p.Prime →
+  ∀ (W : WeierstrassCurve ℤ), W.Δ ≠ 0 →
+    (∀ q : ℕ, q.Prime → (q : ℤ) ∣ W.Δ → ¬ (q : ℤ) ∣ W.c₄) →
+    ∀ (Q : ((W.map (Int.castRingHom ℚ))⁄(AlgebraicClosure ℚ)).Point),
+      (∀ σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ, σ • Q = Q) →
+      addOrderOf Q = p →
+      ∃ x : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar p),
+        x.deg = 1 ∧
+        (∀ σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ,
+            arithmeticGalois (modularFunctionFieldFull p) σ • x = x) ∧
+        0 < x.ord (jBar p - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar p) (jInt W)) ∧
+        0 < x.ord (jpBar p - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar p)
+              (jQuot W Q))
+
+def TateCuspCriterion (jQuot : JQuot) : Prop :=
+  p.Prime →
+  ∀ (W : WeierstrassCurve ℤ), W.Δ ≠ 0 →
+    ∀ (ℓ : ℕ), ℓ.Prime → ℓ ≠ p → (ℓ : ℤ) ∣ W.Δ → ¬ (ℓ : ℤ) ∣ W.c₄ →
+    ∀ A : ValuationSubring (AlgebraicClosure ℚ), A.LiesOverPrime ℓ →
+    ∀ (Q : ((W.map (Int.castRingHom ℚ))⁄(AlgebraicClosure ℚ)).Point),
+      (∀ σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ, σ • Q = Q) →
+      addOrderOf Q = p →
+        1 < A.valuation (jInt W) ∧
+        (W.InZeroComponentAt A Q → A.valuation (jQuot W Q) = A.valuation (jInt W) ^ p) ∧
+        (¬ W.InZeroComponentAt A Q → A.valuation (jQuot W Q) ^ p = A.valuation (jInt W))
+
+end ModularCurve
+
+end
+
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_ModularUnit.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_ModularUnit.lean
new file mode 100644
index 0000000000..dc294abb6f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_ModularUnit.lean
@@ -0,0 +1,239 @@
+/-
+Based on Prove2Me node ModularCurve_ModularUnit
+(a778cb42-c243-56ca-a4e0-54ed994f195d) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+/-!
+# Modular unit Δ(q)/Δ(qN) as a formal Laurent series
+
+Definition: `ModularCurve_ModularUnit` (`a778cb42-c243-56ca-a4e0-54ed994f195d`), by Claude,
+2026-09-05.
+
+Everything here lives in $\mathbb{Q}((q))$, realised as `LaurentSeries ℚ`, and uses the substitution
+$q \mapsto q^N$ given by the ring homomorphism `qExpand ℚ N`. The predicate `IsMonicOfOrder f m`
+says that the Hahn-series order of $f$ is $m$ and its leading coefficient is $1$, i.e. the
+lowest-order term of $f$ is $1\cdot q^{m}$. Its namespace collects the elementary calculus of this
+notion: such an $f$ is nonzero, its $q^{m}$-coefficient is $1$ and all coefficients in degrees $<m$
+vanish; `HahnSeries.single m 1` is monic of order $m$; a power series with constant coefficient $1$,
+viewed as a Laurent series, is monic of order $0$; orders add under multiplication, and conversely
+if $f\cdot g$ is monic of order $k$ and $g$ is monic of order $n$ then $f$ is monic of order $k-n$;
+applying `qExpand ℚ p` multiplies the order by $p$.
+
+On this basis, `dedekindEtaUnitQ` is the integral power series `dedekindEtaUnit` $=\prod_{n\ge
+1}(1-q^{n})^{24}$ pushed forward to $\mathbb{Q}$, with constant coefficient $1$; `deltaSeries` is
+$q\prod_{n\ge 1}(1-q^{n})^{24}$, the $q$-expansion of the discriminant form, monic of order $1$ and
+hence nonzero; and for $N\neq 0$, `deltaSeriesN N` is its image under `qExpand ℚ N`, monic of order
+$N$. The object of interest, `modularUnitSeries N`, is $\Delta(q)\cdot\Delta(q^{N})^{-1}$ computed
+in the field $\mathbb{Q}((q))$; it satisfies the defining identity `modularUnitSeries N *
+deltaSeriesN N = deltaSeries`, is monic of order $1-N$ (so its order is $1-N$, its
+$q^{1-N}$-coefficient is $1$, and lower coefficients vanish), is nonzero, equals $1$ for $N=1$, and
+is multiplicative in the sense that `modularUnitSeries (a*b)` is `modularUnitSeries a` times the
+$q\mapsto q^{a}$ substitution of `modularUnitSeries b`.
+
+Finally `eisensteinNumerator p` is the natural number $(p-1)/\gcd(p-1,12)$; it divides $p-1$, and
+its values at $p=5,7,13$ (namely $1$) and at $p=11,17,19,23$ (namely $5,4,3,11$) are recorded.
+
+**Relation to Mathlib.** The ambient ring `LaurentSeries ℚ` and the `order`/`leadingCoeff` API used
+throughout are Mathlib's; `IsMonicOfOrder`, the series `deltaSeries`, `deltaSeriesN`,
+`modularUnitSeries` and the arithmetic function `eisensteinNumerator` are the project's own, built
+on the project's `qExpand` and `dedekindEtaUnit`.
+
+**Where it is used.** The series $\Delta(q)/\Delta(q^{N})$ is the standard modular unit on $X_0(N)$,
+whose divisor is supported on the cusps; the order $1-N$ and the normalisation of its leading
+coefficient recorded here are what is needed for cuspidal divisor computations, and
+$(p-1)/\gcd(p-1,12)$ is the invariant attached to the cuspidal divisor class on $X_0(p)$.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open HahnSeries
+
+namespace ModularCurve
+
+def IsMonicOfOrder (f : LaurentSeries ℚ) (m : ℤ) : Prop :=
+  f.order = m ∧ f.leadingCoeff = 1
+
+namespace IsMonicOfOrder
+
+theorem ne_zero {f : LaurentSeries ℚ} {m : ℤ} (h : IsMonicOfOrder f m) : f ≠ 0 :=
+  HahnSeries.leadingCoeff_ne_zero.mp (by rw [h.2]; exact one_ne_zero)
+
+theorem coeff_self {f : LaurentSeries ℚ} {m : ℤ} (h : IsMonicOfOrder f m) :
+    f.coeff m = 1 := by
+  have h2 := h.2
+  rwa [HahnSeries.leadingCoeff_eq, h.1] at h2
+
+theorem coeff_of_lt {f : LaurentSeries ℚ} {m k : ℤ} (h : IsMonicOfOrder f m) (hk : k < m) :
+    f.coeff k = 0 :=
+  HahnSeries.coeff_eq_zero_of_lt_order (h.1 ▸ hk)
+
+theorem single (m : ℤ) : IsMonicOfOrder (HahnSeries.single m (1 : ℚ)) m := by
+  refine ⟨HahnSeries.order_single one_ne_zero, ?_⟩
+  rw [HahnSeries.leadingCoeff_eq, HahnSeries.order_single one_ne_zero,
+    HahnSeries.coeff_single_same]
+
+theorem ofPowerSeries {U : PowerSeries ℚ} (hU : PowerSeries.constantCoeff U = 1) :
+    IsMonicOfOrder (HahnSeries.ofPowerSeries ℤ ℚ U) 0 := by
+  have hcoeff0 : (HahnSeries.ofPowerSeries ℤ ℚ U).coeff (0 : ℤ) = 1 := by
+    rw [show (0 : ℤ) = ((0 : ℕ) : ℤ) from rfl, HahnSeries.ofPowerSeries_apply_coeff,
+      PowerSeries.coeff_zero_eq_constantCoeff, hU]
+  have hne0 : (HahnSeries.ofPowerSeries ℤ ℚ U).coeff (0 : ℤ) ≠ 0 := by
+    rw [hcoeff0]; exact one_ne_zero
+  have hne : HahnSeries.ofPowerSeries ℤ ℚ U ≠ 0 := HahnSeries.ne_zero_of_coeff_ne_zero hne0
+  have horder : (HahnSeries.ofPowerSeries ℤ ℚ U).order = 0 := by
+    refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero hne0) ?_
+    by_contra hlt
+    rw [not_le] at hlt
+    exact hne (HahnSeries.coeff_order_eq_zero.mp
+      (ModularCurve.ofPowerSeries_coeff_of_neg U hlt))
+  exact ⟨horder, by rw [HahnSeries.leadingCoeff_eq, horder, hcoeff0]⟩
+
+theorem mul {f g : LaurentSeries ℚ} {m n : ℤ} (hf : IsMonicOfOrder f m)
+    (hg : IsMonicOfOrder g n) : IsMonicOfOrder (f * g) (m + n) := by
+  have h1 : f.leadingCoeff * g.leadingCoeff ≠ 0 := by
+    rw [hf.2, hg.2, one_mul]; exact one_ne_zero
+  refine ⟨?_, ?_⟩
+  · rw [HahnSeries.order_mul_of_ne_zero h1, hf.1, hg.1]
+  · rw [HahnSeries.leadingCoeff_mul_of_ne_zero h1, hf.2, hg.2, one_mul]
+
+theorem of_mul_right {f g : LaurentSeries ℚ} {k n : ℤ} (hfg : IsMonicOfOrder (f * g) k)
+    (hg : IsMonicOfOrder g n) : IsMonicOfOrder f (k - n) := by
+  have hlc : f.leadingCoeff = 1 := by
+    have h := HahnSeries.leadingCoeff_mul f g
+    rw [hfg.2, hg.2, mul_one] at h
+    exact h.symm
+  have h1 : f.leadingCoeff * g.leadingCoeff ≠ 0 := by
+    rw [hlc, hg.2, one_mul]; exact one_ne_zero
+  refine ⟨?_, hlc⟩
+  have h := HahnSeries.order_mul_of_ne_zero h1
+  rw [hfg.1, hg.1] at h
+  omega
+
+theorem qExpand {f : LaurentSeries ℚ} {m : ℤ} (p : ℕ) [NeZero p] (hf : IsMonicOfOrder f m) :
+    IsMonicOfOrder (ModularCurve.qExpand ℚ p f) ((p : ℤ) * m) := by
+  have hcoeff : (ModularCurve.qExpand ℚ p f).coeff ((p : ℤ) * m) = 1 := by
+    rw [qExpand_coeff_mul]; exact hf.coeff_self
+  have hcoeff' : (ModularCurve.qExpand ℚ p f).coeff ((p : ℤ) * m) ≠ 0 := by
+    rw [hcoeff]; exact one_ne_zero
+  have hne : ModularCurve.qExpand ℚ p f ≠ 0 := HahnSeries.ne_zero_of_coeff_ne_zero hcoeff'
+  have hbelow : ∀ k : ℤ, k < (p : ℤ) * m → (ModularCurve.qExpand ℚ p f).coeff k = 0 := by
+    intro k hk
+    by_cases hdvd : (p : ℤ) ∣ k
+    · obtain ⟨j, rfl⟩ := hdvd
+      rw [qExpand_coeff_mul]
+      refine hf.coeff_of_lt ?_
+      have hp : (0 : ℤ) < (p : ℤ) := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne p)
+      exact lt_of_mul_lt_mul_left hk hp.le
+    · exact qExpand_coeff_of_not_dvd p f hdvd
+  have horder : (ModularCurve.qExpand ℚ p f).order = (p : ℤ) * m := by
+    refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero hcoeff') ?_
+    by_contra hlt
+    rw [not_le] at hlt
+    exact hne (HahnSeries.coeff_order_eq_zero.mp (hbelow _ hlt))
+  exact ⟨horder, by rw [HahnSeries.leadingCoeff_eq, horder, hcoeff]⟩
+
+end IsMonicOfOrder
+
+section ModularUnit
+
+def dedekindEtaUnitQ : PowerSeries ℚ := dedekindEtaUnit.map (Int.castRingHom ℚ)
+
+@[simp]
+theorem constantCoeff_dedekindEtaUnitQ : PowerSeries.constantCoeff dedekindEtaUnitQ = 1 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff, dedekindEtaUnitQ, PowerSeries.coeff_map,
+    PowerSeries.coeff_zero_eq_constantCoeff, constantCoeff_dedekindEtaUnit]
+  simp
+
+def deltaSeries : LaurentSeries ℚ :=
+  HahnSeries.single (1 : ℤ) 1 * HahnSeries.ofPowerSeries ℤ ℚ dedekindEtaUnitQ
+
+theorem isMonicOfOrder_deltaSeries : IsMonicOfOrder deltaSeries 1 := by
+  have h := (IsMonicOfOrder.single (1 : ℤ)).mul
+    (IsMonicOfOrder.ofPowerSeries constantCoeff_dedekindEtaUnitQ)
+  rwa [add_zero] at h
+
+theorem deltaSeries_ne_zero : deltaSeries ≠ 0 := isMonicOfOrder_deltaSeries.ne_zero
+
+variable (p : ℕ) [NeZero p]
+
+def deltaSeriesN : LaurentSeries ℚ := qExpand ℚ p deltaSeries
+
+theorem isMonicOfOrder_deltaSeriesN : IsMonicOfOrder (deltaSeriesN p) (p : ℤ) := by
+  have h := isMonicOfOrder_deltaSeries.qExpand p
+  rwa [mul_one] at h
+
+theorem deltaSeriesN_ne_zero : deltaSeriesN p ≠ 0 := (isMonicOfOrder_deltaSeriesN p).ne_zero
+
+def modularUnitSeries : LaurentSeries ℚ := deltaSeries * (deltaSeriesN p)⁻¹
+
+theorem modularUnitSeries_mul_deltaSeriesN :
+    modularUnitSeries p * deltaSeriesN p = deltaSeries := by
+  rw [modularUnitSeries, mul_assoc, inv_mul_cancel₀ (deltaSeriesN_ne_zero p), mul_one]
+
+theorem isMonicOfOrder_modularUnitSeries : IsMonicOfOrder (modularUnitSeries p) (1 - p) := by
+  refine IsMonicOfOrder.of_mul_right ?_ (isMonicOfOrder_deltaSeriesN p)
+  rw [modularUnitSeries_mul_deltaSeriesN]
+  exact isMonicOfOrder_deltaSeries
+
+theorem modularUnitSeries_ne_zero : modularUnitSeries p ≠ 0 :=
+  (isMonicOfOrder_modularUnitSeries p).ne_zero
+
+theorem order_modularUnitSeries : (modularUnitSeries p).order = 1 - (p : ℤ) :=
+  (isMonicOfOrder_modularUnitSeries p).1
+
+theorem coeff_modularUnitSeries_self : (modularUnitSeries p).coeff (1 - (p : ℤ)) = 1 :=
+  (isMonicOfOrder_modularUnitSeries p).coeff_self
+
+theorem coeff_modularUnitSeries_of_lt {k : ℤ} (hk : k < 1 - (p : ℤ)) :
+    (modularUnitSeries p).coeff k = 0 :=
+  (isMonicOfOrder_modularUnitSeries p).coeff_of_lt hk
+
+theorem deltaSeriesN_one : deltaSeriesN 1 = deltaSeries :=
+  qExpand_one_apply deltaSeries
+
+theorem modularUnitSeries_one : modularUnitSeries 1 = 1 := by
+  rw [modularUnitSeries, deltaSeriesN_one, mul_inv_cancel₀ deltaSeries_ne_zero]
+
+theorem deltaSeriesN_mul (a b : ℕ) [NeZero a] [NeZero b] [NeZero (a * b)] :
+    deltaSeriesN (a * b) = qExpand ℚ a (deltaSeriesN b) := by
+  rw [deltaSeriesN, deltaSeriesN, qExpand_qExpand]
+
+theorem modularUnitSeries_mul (a b : ℕ) [NeZero a] [NeZero b] [NeZero (a * b)] :
+    modularUnitSeries (a * b) = modularUnitSeries a * qExpand ℚ a (modularUnitSeries b) := by
+  rw [modularUnitSeries, modularUnitSeries, modularUnitSeries, map_mul, map_inv₀,
+    ← deltaSeriesN_mul, ← deltaSeriesN, mul_assoc, ← mul_assoc (deltaSeriesN a)⁻¹,
+    inv_mul_cancel₀ (deltaSeriesN_ne_zero a), one_mul]
+
+end ModularUnit
+
+def eisensteinNumerator (p : ℕ) : ℕ := (p - 1) / Nat.gcd (p - 1) 12
+
+theorem eisensteinNumerator_dvd (p : ℕ) : eisensteinNumerator p ∣ p - 1 :=
+  Nat.div_dvd_of_dvd (Nat.gcd_dvd_left _ _)
+
+@[simp] theorem eisensteinNumerator_five : eisensteinNumerator 5 = 1 := by decide
+@[simp] theorem eisensteinNumerator_seven : eisensteinNumerator 7 = 1 := by decide
+@[simp] theorem eisensteinNumerator_thirteen : eisensteinNumerator 13 = 1 := by decide
+
+@[simp] theorem eisensteinNumerator_eleven : eisensteinNumerator 11 = 5 := by decide
+@[simp] theorem eisensteinNumerator_seventeen : eisensteinNumerator 17 = 4 := by decide
+@[simp] theorem eisensteinNumerator_nineteen : eisensteinNumerator 19 = 3 := by decide
+@[simp] theorem eisensteinNumerator_twentythree : eisensteinNumerator 23 = 11 := by decide
+
+end ModularCurve
+
+end
+
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_ModuliPoint.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_ModuliPoint.lean
new file mode 100644
index 0000000000..c95e3dd675
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_ModuliPoint.lean
@@ -0,0 +1,217 @@
+/-
+Based on Prove2Me node ModularCurve_ModuliPoint
+(12a32ed3-8436-55fb-a910-370ee6cce234) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.IsomOfJ
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_RatPointHom
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VariableChangePointEquiv
+
+/-!
+# Naive moduli set of Γ₀(N)-structures and its base change
+
+Definition: `ModularCurve_ModuliPoint` (`12a32ed3-8436-55fb-a910-370ee6cce234`), by Claude,
+2026-09-05.
+
+Fix a natural number $N$ and a field $L$. A `Gamma0Pair N L` is a structure carrying a Weierstrass
+curve `toCurve` over $L$ — a tuple of coefficients $a_1,a_2,a_3,a_4,a_6$, i.e. a chosen Weierstrass
+model, not an isomorphism class — together with a field asserting that this model is elliptic
+(registered as an instance), a point `gen` of the associated affine curve, and a field asserting
+`addOrderOf gen = N`; thus for $N\ge 1$ the point is of exact additive order $N$, while $N=0$
+records that `gen` has no finite order. The relation `Gamma0Pair.Step P Q` asserts the existence of
+an admissible change of variables $\gamma=(u,r,s,t)$ over $L$ with $\gamma\bullet
+P.\mathtt{toCurve}=Q.\mathtt{toCurve}$, and of a natural number $k$ coprime to $N$, such that
+$Q.\mathtt{gen}$ equals $k\cdot\big(\text{transport of }P.\mathtt{gen}\big)$, where the transport is
+the project's map `Point.vcInvFun`, sending $(x,y)\mapsto(u^{-2}(x-r),\,u^{-3}(y-t-s(x-r)))$ and
+$0\mapsto 0$; the equality of points is stated as a heterogeneous equality across the identification
+of curves given by $\gamma$. `ModuliPoint N L` is the quotient `Quot` of `Gamma0Pair N L` by this
+one-step relation, so identifications are by the equivalence relation generated by `Step`. Since the
+$j$-invariant is invariant under variable change, it descends to `ModuliPoint.j : ModuliPoint N L →
+L`.
+
+The second half provides base change along a ring homomorphism $\sigma : L \to L'$ of fields:
+`gamma0PairMap` applies $\sigma$ to the coefficients and transports the point by the coordinatewise
+map `ratPointMap`, the order being preserved because that map is an injective group homomorphism;
+`gamma0PairStep_map` shows `Step` is preserved, yielding `moduliPointMapRingHom : ModuliPoint N L →
+ModuliPoint N L'` (a map of sets, despite the name) with $j(\sigma_* x)=\sigma(j(x))$. Auxiliary
+lemmas record that $\sigma$ commutes with the formulas `vcXInv`, `vcYInv` for the variable change
+$\gamma$ mapped by $\sigma$, that point transport and base change commute up to heterogeneous
+equality, that `ratPointMap` commutes with $n\bullet$ and preserves additive orders, and three
+heterogeneous-equality lemmas for points across an equality of Weierstrass models.
+
+**Relation to Mathlib.** Mathlib supplies `WeierstrassCurve`, its `VariableChange` action, affine
+points and the $j$-invariant; the naive moduli set of $\Gamma_0(N)$-structures, the relation
+identifying pairs, and its base-change functoriality are the project's own, built on the project's
+transport of affine points along a variable change and along a homomorphism of fields.
+
+**Where it is used.** These definitions give a concrete, model-based presentation of the $L$-points
+of the open modular curve $Y_0(N)$ as classes of pairs (elliptic curve with a point of order $N$),
+with the $j$-invariant and base change along field homomorphisms available; they are imported by
+many later statement modules of the tree.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+namespace ModularCurve
+
+open WeierstrassCurve WeierstrassCurve.Affine
+
+section Pairs
+
+variable (N : ℕ) (L : Type*) [Field L] [DecidableEq L]
+
+structure Gamma0Pair where
+  toCurve : WeierstrassCurve L
+  isElliptic : toCurve.IsElliptic
+  gen : toCurve.toAffine.Point
+  addOrderOf_gen : addOrderOf gen = N
+
+attribute [instance] Gamma0Pair.isElliptic
+
+variable {N L}
+
+def Gamma0Pair.Step (P Q : Gamma0Pair N L) : Prop :=
+  ∃ γ : VariableChange L, ∃ _ : γ • P.toCurve = Q.toCurve, ∃ k : ℕ, k.Coprime N ∧
+    HEq Q.gen (k • Point.vcInvFun γ P.toCurve.toAffine P.gen)
+
+variable (N L) in
+def ModuliPoint : Type _ := Quot (Gamma0Pair.Step (N := N) (L := L))
+
+noncomputable def ModuliPoint.j : ModuliPoint N L → L :=
+  Quot.lift (fun P => P.toCurve.j) fun P Q h => by
+    obtain ⟨γ, hγ, -⟩ := h
+    show P.toCurve.j = Q.toCurve.j
+    simp_rw [← hγ, variableChange_j]
+
+@[simp] lemma ModuliPoint.j_mk (P : Gamma0Pair N L) :
+    ModuliPoint.j (Quot.mk _ P : ModuliPoint N L) = P.toCurve.j := rfl
+
+end Pairs
+
+section HEqToolbox
+
+variable {K : Type*} [Field K]
+
+theorem Point.heq_zero {V V' : WeierstrassCurve.Affine K} (hV : V' = V) :
+    HEq (0 : V'.Point) (0 : V.Point) := by
+  subst hV
+  rfl
+
+theorem Point.heq_some {V V' : WeierstrassCurve.Affine K} (hV : V' = V) {x y x' y' : K}
+    {h : V.Nonsingular x y} {h' : V'.Nonsingular x' y'} (hx : x' = x) (hy : y' = y) :
+    HEq (Point.some x' y' h' : V'.Point) (Point.some x y h : V.Point) := by
+  subst hV
+  subst hx
+  subst hy
+  rfl
+
+theorem Point.heq_nsmul [DecidableEq K] {V V' : WeierstrassCurve.Affine K} (hV : V' = V)
+    (n : ℕ) {S : V'.Point} {T : V.Point} (h : HEq S T) : HEq (n • S) (n • T) := by
+  subst hV
+  rw [eq_of_heq h]
+
+end HEqToolbox
+
+section Map
+
+variable {L L' : Type} [Field L] [Field L']
+variable [DecidableEq L] [DecidableEq L']
+
+theorem addOrderOf_ratPointMap (σ : L →+* L') (V : WeierstrassCurve L) (P : V.toAffine.Point) :
+    addOrderOf (WeierstrassCurve.ratPointMap σ (W₀ := V) P) = addOrderOf P :=
+  addOrderOf_injective (WeierstrassCurve.ratPointHom σ (W₀ := V))
+    (WeierstrassCurve.ratPointMap_injective σ (W₀ := V)) P
+
+theorem ratPointMap_nsmul (σ : L →+* L') (V : WeierstrassCurve L) (k : ℕ) (P : V.toAffine.Point) :
+    WeierstrassCurve.ratPointMap σ (W₀ := V) (k • P) = k • WeierstrassCurve.ratPointMap σ (W₀ := V)
+      P :=
+  map_nsmul (WeierstrassCurve.ratPointHom σ (W₀ := V)) k P
+
+omit [DecidableEq L] [DecidableEq L'] in
+theorem map_vcXInv (σ : L →+* L') (γ : VariableChange L) (x : L) :
+    σ (vcXInv γ x) = vcXInv (γ.map σ) (σ x) := by
+  simp [vcXInv, map_mul, map_pow, map_sub]
+
+omit [DecidableEq L] [DecidableEq L'] in
+theorem map_vcYInv (σ : L →+* L') (γ : VariableChange L) (x y : L) :
+    σ (vcYInv γ x y) = vcYInv (γ.map σ) (σ x) (σ y) := by
+  simp [vcYInv, map_mul, map_pow, map_sub]
+
+omit [DecidableEq L] [DecidableEq L'] in
+theorem ratPointMap_vcInvFun_heq (σ : L →+* L') (γ : VariableChange L) (V : WeierstrassCurve L)
+    (P : V.toAffine.Point) :
+    HEq (WeierstrassCurve.ratPointMap σ (W₀ := γ • V) (Point.vcInvFun γ V.toAffine P))
+        (Point.vcInvFun (γ.map σ) (V.map σ).toAffine (WeierstrassCurve.ratPointMap σ (W₀ := V) P))
+          := by
+  have hc : (γ • V).map σ = (γ.map σ) • (V.map σ) :=
+    (WeierstrassCurve.map_variableChange V γ σ).symm
+  cases P with
+  | zero => exact Point.heq_zero hc
+  | some x y h => exact Point.heq_some hc (map_vcXInv σ γ x) (map_vcYInv σ γ x y)
+
+variable {N : ℕ}
+
+def gamma0PairMap (σ : L →+* L') (P : Gamma0Pair N L) : Gamma0Pair N L' where
+  toCurve := P.toCurve.map σ
+  isElliptic := inferInstance
+  gen := WeierstrassCurve.ratPointMap σ (W₀ := P.toCurve) P.gen
+  addOrderOf_gen := (addOrderOf_ratPointMap σ P.toCurve P.gen).trans P.addOrderOf_gen
+
+@[simp] theorem gamma0PairMap_toCurve (σ : L →+* L') (P : Gamma0Pair N L) :
+    (gamma0PairMap σ P).toCurve = P.toCurve.map σ := rfl
+
+@[simp] theorem gamma0PairMap_gen (σ : L →+* L') (P : Gamma0Pair N L) :
+    (gamma0PairMap σ P).gen = WeierstrassCurve.ratPointMap σ (W₀ := P.toCurve) P.gen := rfl
+
+theorem gamma0PairStep_map (σ : L →+* L') {P Q : Gamma0Pair N L}
+    (h : Gamma0Pair.Step P Q) :
+    Gamma0Pair.Step (gamma0PairMap σ P) (gamma0PairMap σ Q) := by
+  obtain ⟨γ, hγ, k, hk, hgen⟩ := h
+  obtain ⟨WP, hEP, gP, hgP⟩ := P
+  obtain ⟨WQ, hEQ, gQ, hgQ⟩ := Q
+  change γ • WP = WQ at hγ
+  subst hγ
+  change HEq gQ (k • Point.vcInvFun γ WP.toAffine gP) at hgen
+  have hgen' : gQ = k • Point.vcInvFun γ WP.toAffine gP := eq_of_heq hgen
+  refine ⟨γ.map σ, ?_, k, hk, ?_⟩
+  · change γ.map σ • WP.map σ = (γ • WP).map σ
+    exact WeierstrassCurve.map_variableChange WP γ σ
+  · change HEq (WeierstrassCurve.ratPointMap σ (W₀ := γ • WP) gQ)
+      (k • Point.vcInvFun (γ.map σ) (WP.map σ).toAffine (WeierstrassCurve.ratPointMap σ (W₀ := WP)
+        gP))
+    rw [hgen']
+    refine HEq.trans (heq_of_eq (ratPointMap_nsmul σ (γ • WP) k
+      (Point.vcInvFun γ WP.toAffine gP))) ?_
+    exact Point.heq_nsmul (WeierstrassCurve.map_variableChange WP γ σ).symm k
+      (ratPointMap_vcInvFun_heq σ γ WP gP)
+
+def moduliPointMapRingHom (σ : L →+* L') : ModuliPoint N L → ModuliPoint N L' :=
+  Quot.lift (fun P => (Quot.mk _ (gamma0PairMap σ P) : ModuliPoint N L'))
+    fun _ _ h => Quot.sound (gamma0PairStep_map σ h)
+
+@[simp] theorem moduliPointMapRingHom_mk (σ : L →+* L') (P : Gamma0Pair N L) :
+    moduliPointMapRingHom σ (Quot.mk _ P : ModuliPoint N L) =
+      (Quot.mk _ (gamma0PairMap σ P) : ModuliPoint N L') := rfl
+
+theorem j_moduliPointMapRingHom (σ : L →+* L') (x : ModuliPoint N L) :
+    (moduliPointMapRingHom σ x).j = σ x.j := by
+  induction x using Quot.ind with
+  | _ P => exact (P.toCurve.map_j σ)
+
+end Map
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_OmegaOf.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_OmegaOf.lean
new file mode 100644
index 0000000000..fea4893bf9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_OmegaOf.lean
@@ -0,0 +1,146 @@
+/-
+Based on Prove2Me node ModularCurve_OmegaOf
+(304d6faf-7db4-50be-9bd3-5174b14a358e) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlace
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ArithmeticGalois
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QExpansionDiff
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_theta_coeff
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_injective
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+
+/-!
+# The differential attached to a q-expansion
+
+Definition: `ModularCurve_OmegaOf` (`304d6faf-7db4-50be-9bd3-5174b14a358e`), by Claude, 2026-09-05.
+
+For a level $N$, a function $f : \mathbb{H} \to \mathbb{C}$ and a ring homomorphism $\sigma :
+\overline{\mathbb{Q}} \to \mathbb{C}$ (with $\overline{\mathbb{Q}} =$ `AlgebraicClosure ℚ`),
+[`ModularCurve.omegaOf N f σ`](../def/ModularCurve_OmegaOf.html#L20) is an element of $\Omega_{\bar
+F_N/\overline{\mathbb{Q}}}$, where $\bar F_N =$ `modularFunctionFieldBar N` is the subfield of
+$\overline{\mathbb{Q}}((q))$ generated over $\overline{\mathbb{Q}}$ by the coefficientwise images of
+the $q$-expansions $\mathrm{qExpand}_d\, j$ for $d \mid N$, and $\Omega$ is Mathlib's module of
+Kähler differentials. The definition is by cases on the existence of a witness: if some $x \in \bar
+F_N$ satisfies
+$$\mathrm{coeffMap}\,\sigma\bigl(x \cdot \theta(\tilde j)\bigr) = \mathrm{qExpansion}\,1\,f$$
+as Laurent series over $\mathbb{C}$ — here $\tilde j$ is the $q$-series `jq` of the $j$-function
+pushed into $\overline{\mathbb{Q}}((q))$ coefficientwise, $\theta$ is the operator $g \mapsto
+q\,dg/dq$ of `thetaL`, and $\mathrm{coeffMap}\,\sigma$ applies $\sigma$ to each coefficient — then
+`omegaOf N f σ` is $x \cdot D_{\overline{\mathbb{Q}}}(\tilde j)$, the scalar multiple by $x$ of the
+universal derivation applied to $\tilde j \in \bar F_N$; otherwise it is $0$. Thus no
+$\sigma$-rationality hypothesis on $f$ appears among the binders: data for which no witness exists
+receives the value $0$, and only $\mathrm{qExpansion}\,1\,f$ enters the body.
+
+Three theorems give the interface. `omegaOf_witness_unique` states that a witness $x$ is unique,
+since $\mathrm{coeffMap}\,\sigma$ is injective for injective $\sigma$ and $\theta(\tilde j) \neq 0$.
+`omegaOf_eq_smul_D_of_coeffMap_eq` states that any witness $x$ computes the value,
+$\mathrm{omegaOf}\,N\,f\,\sigma = x \cdot D(\tilde j)$, and `omegaOf_eq_zero_of_not_exists` records
+the second branch. Two auxiliary facts supply the nonvanishing: the coefficient of $q^{-1}$ in
+$\theta(\tilde j)$ equals $-1$, whence $\theta(\tilde j) \neq 0$.
+
+**Relation to Mathlib.** Mathlib provides the module of Kähler differentials (`KaehlerDifferential`)
+and the $q$-expansion of a modular form (`qExpansion`); the function fields of modular curves as
+subfields of Laurent series, the coefficientwise maps `coeffMap`/`coeffEmb`, the operator `thetaL`,
+and the differential attached to a $q$-expansion are the project's own notions.
+
+**Where it is used.** The element `omegaOf N f σ` realises a weight-$2$ form on $\Gamma_0(N)$ as a
+differential on the modular curve over $\overline{\mathbb{Q}}$, the bridge between modular forms and
+the Jacobian of $X_0(N)$ whose torsion supplies the Galois representations used in the Frey curve
+argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open UpperHalfPlane
+
+namespace ModularCurve
+
+variable (N : ℕ) [NeZero N]
+
+open scoped Classical in
+def omegaOf (f : ℍ → ℂ) (σ : AlgebraicClosure ℚ →+* ℂ) :
+    Ω[modularFunctionFieldBar N⁄AlgebraicClosure ℚ] :=
+  if h : ∃ x : modularFunctionFieldBar N,
+      coeffMap σ ((x : LaurentSeries (AlgebraicClosure ℚ)) *
+          thetaL (AlgebraicClosure ℚ) (coeffEmb (AlgebraicClosure ℚ) jq)) =
+        ((qExpansion 1 f : PowerSeries ℂ) : LaurentSeries ℂ)
+  then
+    h.choose •
+      KaehlerDifferential.D (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+        (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+          coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+          modularFunctionFieldBar N)
+  else 0
+
+private theorem theta_coeffEmb_jq_coeff_neg_one :
+    (thetaL (AlgebraicClosure ℚ) (coeffEmb (AlgebraicClosure ℚ) jq)).coeff (-1 : ℤ) = -1 := by
+  rw [thetaL_apply, theta_coeff, coeffEmb_coeff, coeff_jq_neg_one, map_one]
+  norm_num
+
+private theorem thetaL_coeffEmb_jq_ne_zero :
+    thetaL (AlgebraicClosure ℚ) (coeffEmb (AlgebraicClosure ℚ) jq) ≠ 0 := by
+  intro h0
+  have h := theta_coeffEmb_jq_coeff_neg_one
+  rw [h0] at h
+  simp at h
+
+omit [NeZero N] in
+theorem omegaOf_witness_unique (f : ℍ → ℂ)
+    (σ : AlgebraicClosure ℚ →+* ℂ) {x y : modularFunctionFieldBar N}
+    (hx : coeffMap σ ((x : LaurentSeries (AlgebraicClosure ℚ)) *
+        thetaL (AlgebraicClosure ℚ) (coeffEmb (AlgebraicClosure ℚ) jq)) =
+      ((qExpansion 1 f : PowerSeries ℂ) : LaurentSeries ℂ))
+    (hy : coeffMap σ ((y : LaurentSeries (AlgebraicClosure ℚ)) *
+        thetaL (AlgebraicClosure ℚ) (coeffEmb (AlgebraicClosure ℚ) jq)) =
+      ((qExpansion 1 f : PowerSeries ℂ) : LaurentSeries ℂ)) : x = y := by
+  have h1 : (x : LaurentSeries (AlgebraicClosure ℚ)) *
+        thetaL (AlgebraicClosure ℚ) (coeffEmb (AlgebraicClosure ℚ) jq)
+      = (y : LaurentSeries (AlgebraicClosure ℚ)) *
+        thetaL (AlgebraicClosure ℚ) (coeffEmb (AlgebraicClosure ℚ) jq) :=
+    coeffMap_injective σ.injective (hx.trans hy.symm)
+  have h2 : (x : LaurentSeries (AlgebraicClosure ℚ)) = y :=
+    mul_right_cancel₀ thetaL_coeffEmb_jq_ne_zero h1
+  exact_mod_cast h2
+
+theorem omegaOf_eq_smul_D_of_coeffMap_eq (f : ℍ → ℂ)
+    (σ : AlgebraicClosure ℚ →+* ℂ) {x : modularFunctionFieldBar N}
+    (hx : coeffMap σ ((x : LaurentSeries (AlgebraicClosure ℚ)) *
+        thetaL (AlgebraicClosure ℚ) (coeffEmb (AlgebraicClosure ℚ) jq)) =
+      ((qExpansion 1 f : PowerSeries ℂ) : LaurentSeries ℂ)) :
+    omegaOf N f σ =
+      x • KaehlerDifferential.D (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+        (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+          coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+          modularFunctionFieldBar N) := by
+  have h : ∃ z : modularFunctionFieldBar N,
+      coeffMap σ ((z : LaurentSeries (AlgebraicClosure ℚ)) *
+          thetaL (AlgebraicClosure ℚ) (coeffEmb (AlgebraicClosure ℚ) jq)) =
+        ((qExpansion 1 f : PowerSeries ℂ) : LaurentSeries ℂ) := ⟨x, hx⟩
+  unfold omegaOf
+  rw [dite_eq_left h, omegaOf_witness_unique N f σ h.choose_spec hx]
+
+theorem omegaOf_eq_zero_of_not_exists (f : ℍ → ℂ)
+    (σ : AlgebraicClosure ℚ →+* ℂ)
+    (h : ¬ ∃ x : modularFunctionFieldBar N,
+        coeffMap σ ((x : LaurentSeries (AlgebraicClosure ℚ)) *
+            thetaL (AlgebraicClosure ℚ) (coeffEmb (AlgebraicClosure ℚ) jq)) =
+          ((qExpansion 1 f : PowerSeries ℂ) : LaurentSeries ℂ)) :
+    omegaOf N f σ = 0 := by
+  unfold omegaOf
+  rw [dite_eq_right h]
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_PeriodLattice.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_PeriodLattice.lean
new file mode 100644
index 0000000000..1f370c4e2b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_PeriodLattice.lean
@@ -0,0 +1,364 @@
+/-
+Based on Prove2Me node ModularCurve_PeriodLattice
+(01c9dfe4-ac3e-5e7f-ac99-4d6dd2f2465b) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.LocallyConvex.AbsConvexOpen
+public import LeanPool.FLTEichlerShimura.Definitions.Def_CuspForm_HeckeAlgebra
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeGalois_EichlerShimura
+
+/-!
+# Period lattice of weight-two forms and its Hecke action
+
+Definition: `ModularCurve_PeriodLattice` (`01c9dfe4-ac3e-5e7f-ac99-4d6dd2f2465b`), by Claude,
+2026-09-05.
+
+Fix a level $N$ and let $S_2(N)$ denote `CuspForm (CongruenceSubgroup.Gamma0 N) 2` and $S_2(N)^\vee$
+its $\mathbb{C}$-linear dual. The first group of definitions produces periods by explicit
+integration along straight segments: `clamp01` is $t\mapsto\max(0,\min(t,1))$, `segmentPoint τ₀ τ₁
+t` is the convex combination $(1-\mathrm{clamp}_{01}t)\tau_0+(\mathrm{clamp}_{01}t)\tau_1$, which
+has positive imaginary part, so `segmentPath` is a continuous map $\mathbb{R}\to\mathbb{H}$;
+`periodIntegrand N τ₀ τ₁ f t` is $f(\text{segmentPath}\,t)\cdot(\tau_1-\tau_0)$, continuous and
+hence interval integrable, additive and $\mathbb{C}$-homogeneous in $f$. Accordingly `periodAlong N
+τ₀ τ₁` is the functional $f\mapsto\int_0^1 f((1-t)\tau_0+t\tau_1)(\tau_1-\tau_0)\,dt$ in
+$S_2(N)^\vee$, `period N γ` is `periodAlong N I (γ • I)` for $\gamma\in\Gamma_0(N)$ acting through
+$\mathrm{SL}_2(\mathbb{Z})$, and `periodLattice N` is the $\mathbb{Z}$-submodule of $S_2(N)^\vee$
+spanned by the range of `period N`. No Eichler–Shimura–Manin property of these periods is asserted
+here.
+
+The second group, for $N\neq 0$, builds an action of the free commutative Hecke ring `HeckeAlg`
+$=\mathbb{Z}[X_\ell:\ell\text{ prime}]$. `cuspHeckeGen N ℓ` is $U_\ell$ if $\ell\mid N$ and $T_\ell$
+otherwise, viewed in the subalgebra [`CuspForm.heckeAlgebra N 2
+∅`](../def/CuspForm_HeckeAlgebra.html#L18); the range of `cuspHeckeGen N` is exactly the set of
+elements whose underlying endomorphism lies in [`CuspForm.heckeGenerators N 2
+∅`](../def/CuspForm_HeckeAlgebra.html#L14), whence the evaluation map `cuspHeckeAeval N`,
+$X_\ell\mapsto$ `cuspHeckeGen N ℓ`, is surjective, and the ring map `cuspHeckeRep N` into
+$\mathrm{End}_{\mathbb{C}}S_2(N)$ has the Hecke subalgebra as its range and commutative image.
+`dualHeckeRep N` is the transpose action $t\mapsto{}^t(\text{cuspHeckeRep }N\,t)$ on $S_2(N)^\vee$,
+a ring homomorphism by commutativity, sending $\mathbb{C}$-constants $a$ to $a\cdot\mathrm{id}$. The
+predicate `PeriodLatticeHeckeStable N` says each ${}^tT_\ell,{}^tU_\ell$ preserves `periodLattice
+N`; `periodLattice_stable_of` propagates this to all of `HeckeAlg` by induction on polynomials,
+giving `periodLatticeRestrict`/`periodLatticeRestrictHom`. Finally `periodLatticeHeckeEnd N` is
+defined by cases: the restricted Hecke action when stability holds, and otherwise the degenerate
+homomorphism $t\mapsto(\text{constant coefficient of }t)\cdot\mathrm{id}$; `periodLatticeModule N`
+is the resulting `HeckeAlg`-module structure on the period lattice.
+
+**Relation to Mathlib.** Mathlib supplies `CuspForm`, `UpperHalfPlane`, `Module.Dual`, interval
+integrals and `CongruenceSubgroup.Gamma0`; the period functionals, the period lattice and the
+`HeckeAlg`-module structure on it are the project's own, built on the project's Hecke operators
+[`CuspForm.heckeTLin`](../def/ModularForm_HeckeOperatorForms.html#L69)/`heckeULin` and the
+subalgebra [`CuspForm.heckeAlgebra`](../def/CuspForm_HeckeAlgebra.html#L18).
+
+**Where it is used.** The period lattice with its Hecke action is the project's concrete stand-in
+for the integral homology of $X_0(N)$, equivalently for $J_0(N)(\mathbb{C})=S_2(N)^\vee/\Lambda_N$,
+as a module over the free Hecke ring `HeckeAlg`. It is in this shape that the Eichler–Shimura
+package (Galois action, Frobenius quadratic relation, $\mathfrak{m}$-torsion representations) is
+formulated and used in the level-lowering step for the Frey curve.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open UpperHalfPlane
+
+open scoped MatrixGroups
+
+namespace ModularCurve
+
+section Period
+
+def clamp01 (t : ℝ) : ℝ := max 0 (min t 1)
+
+theorem clamp01_nonneg (t : ℝ) : 0 ≤ clamp01 t := le_max_left _ _
+
+theorem clamp01_le_one (t : ℝ) : clamp01 t ≤ 1 := max_le zero_le_one (min_le_right _ _)
+
+theorem continuous_clamp01 : Continuous clamp01 :=
+  continuous_const.max (continuous_id.min continuous_const)
+
+theorem clamp01_of_mem {t : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1) : clamp01 t = t := by
+  rw [clamp01, min_eq_left ht.2, max_eq_right ht.1]
+
+def segmentPoint (τ₀ τ₁ : ℍ) (t : ℝ) : ℂ :=
+  (1 - clamp01 t) • (τ₀ : ℂ) + clamp01 t • (τ₁ : ℂ)
+
+theorem segmentPoint_im_pos (τ₀ τ₁ : ℍ) (t : ℝ) : 0 < (segmentPoint τ₀ τ₁ t).im := by
+  have h0 := clamp01_nonneg t
+  have h1 := clamp01_le_one t
+  simp only [segmentPoint, Complex.add_im, Complex.smul_im, smul_eq_mul]
+  rcases eq_or_lt_of_le h1 with h | h
+  · rw [h]; simpa using τ₁.im_pos
+  · exact add_pos_of_pos_of_nonneg (mul_pos (by linarith) τ₀.im_pos)
+      (mul_nonneg h0 τ₁.im_pos.le)
+
+theorem continuous_segmentPoint (τ₀ τ₁ : ℍ) : Continuous (segmentPoint τ₀ τ₁) :=
+  ((continuous_const.sub continuous_clamp01).smul continuous_const).add
+    (continuous_clamp01.smul continuous_const)
+
+def segmentPath (τ₀ τ₁ : ℍ) (t : ℝ) : ℍ :=
+  UpperHalfPlane.mk (segmentPoint τ₀ τ₁ t) (segmentPoint_im_pos τ₀ τ₁ t)
+
+@[simp] theorem coe_segmentPath (τ₀ τ₁ : ℍ) (t : ℝ) :
+    ((segmentPath τ₀ τ₁ t : ℍ) : ℂ) = segmentPoint τ₀ τ₁ t := rfl
+
+theorem continuous_segmentPath (τ₀ τ₁ : ℍ) : Continuous (segmentPath τ₀ τ₁) :=
+  (continuous_segmentPoint τ₀ τ₁).upperHalfPlaneMk _
+
+variable (N : ℕ)
+
+def periodIntegrand (τ₀ τ₁ : ℍ) (f : CuspForm (CongruenceSubgroup.Gamma0 N) 2) (t : ℝ) : ℂ :=
+  f (segmentPath τ₀ τ₁ t) * ((τ₁ : ℂ) - τ₀)
+
+theorem continuous_periodIntegrand (τ₀ τ₁ : ℍ) (f : CuspForm (CongruenceSubgroup.Gamma0 N) 2) :
+    Continuous (periodIntegrand N τ₀ τ₁ f) :=
+  ((f.holo'.continuous).comp (continuous_segmentPath τ₀ τ₁)).mul continuous_const
+
+theorem intervalIntegrable_periodIntegrand (τ₀ τ₁ : ℍ)
+    (f : CuspForm (CongruenceSubgroup.Gamma0 N) 2) (a b : ℝ) :
+    IntervalIntegrable (periodIntegrand N τ₀ τ₁ f) MeasureTheory.volume a b :=
+  (continuous_periodIntegrand N τ₀ τ₁ f).intervalIntegrable a b
+
+theorem periodIntegrand_add (τ₀ τ₁ : ℍ) (f g : CuspForm (CongruenceSubgroup.Gamma0 N) 2) :
+    periodIntegrand N τ₀ τ₁ (f + g) = periodIntegrand N τ₀ τ₁ f + periodIntegrand N τ₀ τ₁ g := by
+  funext t
+  simp [periodIntegrand, add_mul]
+
+theorem periodIntegrand_smul (τ₀ τ₁ : ℍ) (c : ℂ) (f : CuspForm (CongruenceSubgroup.Gamma0 N) 2) :
+    periodIntegrand N τ₀ τ₁ (c • f) = fun t => c * periodIntegrand N τ₀ τ₁ f t := by
+  funext t
+  simp [periodIntegrand, mul_assoc]
+
+def periodAlong (τ₀ τ₁ : ℍ) : Module.Dual ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) 2) where
+  toFun f := ∫ t in (0 : ℝ)..1, periodIntegrand N τ₀ τ₁ f t
+  map_add' f g := by
+    rw [periodIntegrand_add]
+    exact intervalIntegral.integral_add (intervalIntegrable_periodIntegrand N τ₀ τ₁ f 0 1)
+      (intervalIntegrable_periodIntegrand N τ₀ τ₁ g 0 1)
+  map_smul' c f := by
+    rw [periodIntegrand_smul, RingHom.id_apply, smul_eq_mul]
+    exact intervalIntegral.integral_const_mul c _
+
+theorem periodAlong_apply (τ₀ τ₁ : ℍ) (f : CuspForm (CongruenceSubgroup.Gamma0 N) 2) :
+    periodAlong N τ₀ τ₁ f = ∫ t in (0 : ℝ)..1, f (segmentPath τ₀ τ₁ t) * ((τ₁ : ℂ) - τ₀) :=
+  rfl
+
+def period (γ : CongruenceSubgroup.Gamma0 N) :
+    Module.Dual ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) 2) :=
+  periodAlong N UpperHalfPlane.I ((γ : SL(2, ℤ)) • UpperHalfPlane.I)
+
+theorem period_apply (γ : CongruenceSubgroup.Gamma0 N)
+    (f : CuspForm (CongruenceSubgroup.Gamma0 N) 2) :
+    period N γ f =
+      ∫ t in (0 : ℝ)..1, f (segmentPath UpperHalfPlane.I ((γ : SL(2, ℤ)) • UpperHalfPlane.I) t) *
+        ((((γ : SL(2, ℤ)) • UpperHalfPlane.I : ℍ) : ℂ) - (UpperHalfPlane.I : ℂ)) :=
+  rfl
+
+def periodLattice : Submodule ℤ (Module.Dual ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) 2)) :=
+  Submodule.span ℤ (Set.range (period N))
+
+theorem period_mem_periodLattice (γ : CongruenceSubgroup.Gamma0 N) : period N γ ∈ periodLattice N :=
+  Submodule.subset_span (Set.mem_range_self γ)
+
+end Period
+
+section Hecke
+
+variable (N : ℕ) [NeZero N]
+
+def cuspHeckeGen (ℓ : Nat.Primes) : CuspForm.heckeAlgebra N 2 (∅ : Set ℕ) :=
+  if h : (ℓ : ℕ) ∣ N then CuspForm.heckeAlgebra.U (S := (∅ : Set ℕ)) ℓ.prop h (Set.notMem_empty _)
+  else CuspForm.heckeAlgebra.T (S := (∅ : Set ℕ)) ℓ.prop h (Set.notMem_empty _)
+
+theorem cuspHeckeGen_of_dvd (ℓ : Nat.Primes) (h : (ℓ : ℕ) ∣ N) :
+    (cuspHeckeGen N ℓ : Module.End ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) 2)) =
+      CuspForm.heckeULin 2 h := by
+  rw [cuspHeckeGen, dite_eq_left h]; rfl
+
+theorem cuspHeckeGen_of_not_dvd (ℓ : Nat.Primes) (h : ¬ (ℓ : ℕ) ∣ N) :
+    (cuspHeckeGen N ℓ : Module.End ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) 2)) =
+      CuspForm.heckeTLin 2 ℓ.prop h := by
+  rw [cuspHeckeGen, dite_eq_right h]; rfl
+
+def cuspHeckeAeval : HeckeAlg →ₐ[ℤ] CuspForm.heckeAlgebra N 2 (∅ : Set ℕ) :=
+  MvPolynomial.aeval (cuspHeckeGen N)
+
+@[simp] theorem cuspHeckeAeval_heckeGen (ℓ : Nat.Primes) :
+    cuspHeckeAeval N (heckeGen ℓ) = cuspHeckeGen N ℓ :=
+  MvPolynomial.aeval_X _ ℓ
+
+theorem range_cuspHeckeGen : Set.range (cuspHeckeGen N) =
+    {x : CuspForm.heckeAlgebra N 2 (∅ : Set ℕ) |
+      (x : Module.End ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) 2)) ∈
+        CuspForm.heckeGenerators N 2 (∅ : Set ℕ)} := by
+  ext x
+  constructor
+  · rintro ⟨ℓ, rfl⟩
+    by_cases h : (ℓ : ℕ) ∣ N
+    · rw [Set.mem_ofPred_eq, cuspHeckeGen_of_dvd N ℓ h]
+      exact CuspForm.heckeULin_mem_heckeGenerators ℓ.prop h (Set.notMem_empty _)
+    · rw [Set.mem_ofPred_eq, cuspHeckeGen_of_not_dvd N ℓ h]
+      exact CuspForm.heckeTLin_mem_heckeGenerators ℓ.prop h (Set.notMem_empty _)
+  · rintro (⟨ℓ, hℓ, hℓN, -, hx⟩ | ⟨q, hqN, hq, -, hx⟩)
+    · refine ⟨⟨ℓ, hℓ⟩, Subtype.ext ?_⟩
+      rw [hx]; exact cuspHeckeGen_of_not_dvd N ⟨ℓ, hℓ⟩ hℓN
+    · refine ⟨⟨q, hq⟩, Subtype.ext ?_⟩
+      rw [hx]; exact cuspHeckeGen_of_dvd N ⟨q, hq⟩ hqN
+
+theorem cuspHeckeAeval_range : (cuspHeckeAeval N).range = ⊤ := by
+  rw [cuspHeckeAeval, ← Algebra.adjoin_range_eq_range_aeval, range_cuspHeckeGen]
+  set H := CuspForm.heckeAlgebra N 2 (∅ : Set ℕ)
+  apply Subalgebra.map_injective (f := H.val) Subtype.val_injective
+  rw [AlgHom.map_adjoin, Algebra.map_top, Subalgebra.range_val]
+  have himg : (H.val : H → Module.End ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) 2)) ''
+      {x : H | (x : Module.End ℂ _) ∈ CuspForm.heckeGenerators N 2 (∅ : Set ℕ)} =
+      CuspForm.heckeGenerators N 2 (∅ : Set ℕ) := by
+    ext T
+    constructor
+    · rintro ⟨x, hx, rfl⟩; exact hx
+    · intro hT
+      exact ⟨⟨T, Algebra.subset_adjoin hT⟩, hT, rfl⟩
+  rw [himg]
+  rfl
+
+def cuspHeckeRep : HeckeAlg →+* Module.End ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) 2) :=
+  ((CuspForm.heckeAlgebra N 2 (∅ : Set ℕ)).val.comp (cuspHeckeAeval N)).toRingHom
+
+theorem cuspHeckeRep_apply (t : HeckeAlg) :
+    cuspHeckeRep N t = (cuspHeckeAeval N t : Module.End ℂ (CuspForm (CongruenceSubgroup.Gamma0 N)
+      2)) :=
+  rfl
+
+theorem cuspHeckeRep_heckeGen (ℓ : Nat.Primes) :
+    cuspHeckeRep N (heckeGen ℓ) = (cuspHeckeGen N ℓ : Module.End ℂ _) := by
+  rw [cuspHeckeRep_apply, cuspHeckeAeval_heckeGen]
+
+theorem cuspHeckeRep_mem (t : HeckeAlg) :
+    cuspHeckeRep N t ∈ CuspForm.heckeAlgebra N 2 (∅ : Set ℕ) :=
+  (cuspHeckeAeval N t).2
+
+theorem range_cuspHeckeRep :
+    Set.range (cuspHeckeRep N) = (CuspForm.heckeAlgebra N 2 (∅ : Set ℕ) : Set _) := by
+  ext T
+  constructor
+  · rintro ⟨t, rfl⟩; exact cuspHeckeRep_mem N t
+  · intro hT
+    have : (⟨T, hT⟩ : CuspForm.heckeAlgebra N 2 (∅ : Set ℕ)) ∈ (cuspHeckeAeval N).range := by
+      rw [cuspHeckeAeval_range]; trivial
+    obtain ⟨t, ht⟩ := this
+    exact ⟨t, congrArg Subtype.val ht⟩
+
+theorem cuspHeckeRep_comm (s t : HeckeAlg) :
+    cuspHeckeRep N s * cuspHeckeRep N t = cuspHeckeRep N t * cuspHeckeRep N s := by
+  rw [← map_mul, ← map_mul, mul_comm]
+
+def dualHeckeRep :
+    HeckeAlg →+* Module.End ℂ (Module.Dual ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) 2)) where
+  toFun t := (cuspHeckeRep N t).dualMap
+  map_one' := by rw [map_one]; exact LinearMap.dualMap_id
+  map_mul' s t := by
+    rw [mul_comm s t, map_mul]
+    exact (LinearMap.dualMap_comp_dualMap (cuspHeckeRep N s) (cuspHeckeRep N t)).symm
+  map_zero' := by
+    rw [map_zero]; exact map_zero (Module.Dual.transpose (R := ℂ))
+  map_add' s t := by
+    rw [map_add]; exact map_add (Module.Dual.transpose (R := ℂ)) _ _
+
+theorem dualHeckeRep_apply (t : HeckeAlg) :
+    dualHeckeRep N t = (cuspHeckeRep N t).dualMap := rfl
+
+@[simp] theorem dualHeckeRep_apply_apply (t : HeckeAlg)
+    (φ : Module.Dual ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) 2))
+    (f : CuspForm (CongruenceSubgroup.Gamma0 N) 2) :
+    dualHeckeRep N t φ f = φ (cuspHeckeRep N t f) := rfl
+
+theorem dualHeckeRep_C (a : ℤ) (φ : Module.Dual ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) 2)) :
+    dualHeckeRep N (MvPolynomial.C a) φ = a • φ := by
+  ext f
+  rw [dualHeckeRep_apply_apply, ← MvPolynomial.algebraMap_eq, eq_intCast, map_intCast,
+    Module.End.intCast_apply, map_zsmul, LinearMap.smul_apply]
+
+def PeriodLatticeHeckeStable : Prop :=
+  ∀ (ℓ : Nat.Primes) (x : Module.Dual ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) 2)),
+    x ∈ periodLattice N → dualHeckeRep N (heckeGen ℓ) x ∈ periodLattice N
+
+variable {N}
+
+theorem periodLattice_stable_of (h : PeriodLatticeHeckeStable N) (t : HeckeAlg)
+    (x : Module.Dual ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) 2)) (hx : x ∈ periodLattice N) :
+    dualHeckeRep N t x ∈ periodLattice N := by
+  induction t using MvPolynomial.induction_on generalizing x with
+  | C a => rw [dualHeckeRep_C]; exact Submodule.smul_mem _ a hx
+  | add p q hp hq => rw [map_add,
+    LinearMap.add_apply]; exact Submodule.add_mem _ (hp x hx) (hq x hx)
+  | mul_X p ℓ hp =>
+    rw [map_mul, Module.End.mul_apply]
+    exact hp _ (h ℓ x hx)
+
+variable (N)
+
+def periodLatticeRestrict (h : PeriodLatticeHeckeStable N) (t : HeckeAlg) :
+    Module.End ℤ (periodLattice N) :=
+  ((dualHeckeRep N t).toAddMonoidHom.toIntLinearMap).restrict
+    (fun x hx => periodLattice_stable_of h t x hx)
+
+@[simp] theorem coe_periodLatticeRestrict_apply (h : PeriodLatticeHeckeStable N) (t : HeckeAlg)
+    (x : periodLattice N) :
+    ((periodLatticeRestrict N h t x : periodLattice N) : Module.Dual ℂ _) = dualHeckeRep N t x :=
+  rfl
+
+def periodLatticeRestrictHom (h : PeriodLatticeHeckeStable N) :
+    HeckeAlg →+* Module.End ℤ (periodLattice N) where
+  toFun := periodLatticeRestrict N h
+  map_one' := LinearMap.ext fun x => Subtype.ext (by simp)
+  map_mul' s t := LinearMap.ext fun x => Subtype.ext (by simp)
+  map_zero' := LinearMap.ext fun x => Subtype.ext (by simp)
+  map_add' s t := LinearMap.ext fun x => Subtype.ext (by simp)
+
+open Classical in
+def periodLatticeHeckeEnd : HeckeAlg →+* Module.End ℤ (periodLattice N) :=
+  if h : PeriodLatticeHeckeStable N then periodLatticeRestrictHom N h
+  else (Int.castRingHom (Module.End ℤ (periodLattice N))).comp
+    (MvPolynomial.eval₂Hom (Int.castRingHom ℤ) (0 : Nat.Primes → ℤ))
+
+variable {N}
+
+theorem coe_periodLatticeHeckeEnd_apply (h : PeriodLatticeHeckeStable N) (t : HeckeAlg)
+    (x : periodLattice N) :
+    ((periodLatticeHeckeEnd N t x : periodLattice N) : Module.Dual ℂ _) = dualHeckeRep N t x := by
+  have e : periodLatticeHeckeEnd N = periodLatticeRestrictHom N h := dite_eq_left h
+  rw [e]; rfl
+
+theorem periodLatticeHeckeEnd_of_not (h : ¬ PeriodLatticeHeckeStable N) (t : HeckeAlg)
+    (x : periodLattice N) :
+    periodLatticeHeckeEnd N t x = MvPolynomial.constantCoeff t • x := by
+  have e : periodLatticeHeckeEnd N = (Int.castRingHom (Module.End ℤ (periodLattice N))).comp
+      (MvPolynomial.eval₂Hom (Int.castRingHom ℤ) (0 : Nat.Primes → ℤ)) := dite_eq_right h
+  rw [e, RingHom.comp_apply, MvPolynomial.eval₂Hom_zero_apply]
+  simp only [eq_intCast, Int.cast_id, Module.End.intCast_apply]
+
+variable (N)
+
+@[implicit_reducible]
+def periodLatticeModule : Module HeckeAlg (periodLattice N) :=
+  Module.compHom (periodLattice N) (periodLatticeHeckeEnd N)
+
+theorem periodLatticeModule_smul_def (t : HeckeAlg) (x : periodLattice N) :
+    (letI : Module HeckeAlg (periodLattice N) := periodLatticeModule N; t • x) =
+      periodLatticeHeckeEnd N t x :=
+  rfl
+
+end Hecke
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_PeriodMap.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_PeriodMap.lean
new file mode 100644
index 0000000000..727b46f4d4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_PeriodMap.lean
@@ -0,0 +1,139 @@
+/-
+Based on Prove2Me node ModularCurve_PeriodMap
+(311c6a72-0e58-5c2b-94c1-ec087fd6ec9f) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.Complex.UpperHalfPlane.MoebiusAction
+public import Mathlib.Algebra.Module.Hom
+
+/-!
+# Equivariant primitives, period characters, parabolic homomorphisms
+
+Definition: `ModularCurve_PeriodMap` (`311c6a72-0e58-5c2b-94c1-ec087fd6ec9f`), by Claude,
+2026-09-05.
+
+Fix a subgroup $\Gamma \le \mathrm{SL}_2(\mathbb{Z})$ acting on the upper half plane $\mathbb{H}$ by
+Möbius transformations, and a function $F : \mathbb{H} \to \mathbb{C}$. The predicate
+[`ModularCurve.Period.IsEquivariantPrimitive Γ F`](../def/ModularCurve_PeriodMap.html#L12) asserts
+that for every $\gamma \in \Gamma$ there is a constant $c \in \mathbb{C}$ with $F(\gamma \cdot z) -
+F(z) = c$ for all $z \in \mathbb{H}$, i.e. that each coboundary of $F$ is constant on $\mathbb{H}$.
+Given such an $F$, the period `IsEquivariantPrimitive.period hF γ` is defined concretely as the
+value $F(\gamma \cdot i) - F(i)$ at the point $i \in \mathbb{H}$; `sub_eq_period` then says that
+$F(\gamma \cdot z) - F(z)$ equals this number for every $z$, so the base point is immaterial. From
+this, `period_one` gives $\mathrm{per}(1) = 0$ and `period_mul` gives the additivity
+$\mathrm{per}(\gamma\delta) = \mathrm{per}(\gamma) + \mathrm{per}(\delta)$; `periodHom` packages
+these as an additive group homomorphism `Additive Γ →+ ℂ` — the multiplicative group $\Gamma$ viewed
+additively — whose value at $\gamma$ is $\mathrm{per}(\gamma)$ (`periodHom_apply`). Thus characters
+of $\Gamma$ with values in a trivial module are modelled throughout as maps of type `Additive Γ →+
+A`.
+
+For an abelian group $A$, the predicate [`ModularCurve.Period.IsParabolicHom Γ
+φ`](../def/ModularCurve_PeriodMap.html#L15) on such a homomorphism $\varphi :$ `Additive Γ →+ A`
+asserts that $\varphi(\gamma) = 0$ whenever the underlying integer matrix of $\gamma \in \Gamma$
+satisfies $\mathrm{tr}(\gamma)^2 = 4$; the elements so constrained are exactly $\pm 1$ together with
+the parabolic elements of $\Gamma$. For a semiring $R$ and an $R$-module structure on $A$,
+[`ModularCurve.Period.parabolicHoms R Γ A`](../def/ModularCurve_PeriodMap.html#L62) is the
+$R$-submodule of `Additive Γ →+ A` cut out by this vanishing condition, with `mem_parabolicHoms_iff`
+recording that membership is precisely the predicate; it is the parabolic part of
+$\mathrm{Hom}(\Gamma, A) = H^1(\Gamma, A)$ for trivial coefficients.
+
+**Relation to Mathlib.** Built on Mathlib's Möbius action of $\mathrm{SL}(2,\mathbb{Z})$ on the
+upper half plane and on `Additive` to regard group homomorphisms out of $\Gamma$ additively; the
+notions of equivariant primitive, period character and parabolic homomorphism are the project's own.
+
+**Where it is used.** These definitions provide the group-cohomological language on the
+modular-curve side of the argument: period characters of primitives of weight-two forms, and the
+parabolic submodule of $\mathrm{Hom}(\Gamma, A)$ that models $H^1_{\mathrm{par}}(\Gamma, A)$, i.e.
+the first cohomology of the compactified modular curve with trivial coefficients.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace ModularCurve.Period
+
+open UpperHalfPlane
+
+open scoped MatrixGroups
+
+variable (Γ : Subgroup SL(2, ℤ)) (F : ℍ → ℂ)
+
+def IsEquivariantPrimitive : Prop :=
+  ∀ γ : Γ, ∃ c : ℂ, ∀ z : ℍ, F ((γ : SL(2, ℤ)) • z) - F z = c
+
+def IsParabolicHom {A : Type*} [AddCommGroup A] (φ : Additive Γ →+ A) : Prop :=
+  ∀ γ : Γ, ((γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace ^ 2 = 4 → φ (Additive.ofMul γ) = 0
+
+variable {Γ F}
+
+namespace IsEquivariantPrimitive
+
+noncomputable def period (_hF : IsEquivariantPrimitive Γ F) (γ : Γ) : ℂ :=
+  F ((γ : SL(2, ℤ)) • UpperHalfPlane.I) - F UpperHalfPlane.I
+
+theorem sub_eq_period (hF : IsEquivariantPrimitive Γ F) (γ : Γ) (z : ℍ) :
+    F ((γ : SL(2, ℤ)) • z) - F z = hF.period γ := by
+  obtain ⟨c, hc⟩ := hF γ
+  rw [hc z, period, hc UpperHalfPlane.I]
+
+@[simp]
+theorem period_one (hF : IsEquivariantPrimitive Γ F) : hF.period 1 = 0 := by
+  have h := hF.sub_eq_period 1 UpperHalfPlane.I
+  simpa using h.symm
+
+theorem period_mul (hF : IsEquivariantPrimitive Γ F) (γ δ : Γ) :
+    hF.period (γ * δ) = hF.period γ + hF.period δ := by
+  have h1 := hF.sub_eq_period (γ * δ) UpperHalfPlane.I
+  have h2 := hF.sub_eq_period γ ((δ : SL(2, ℤ)) • UpperHalfPlane.I)
+  have h3 := hF.sub_eq_period δ UpperHalfPlane.I
+  have hsmul : ((γ * δ : Γ) : SL(2, ℤ)) • UpperHalfPlane.I
+      = (γ : SL(2, ℤ)) • ((δ : SL(2, ℤ)) • UpperHalfPlane.I) := by
+    rw [← mul_smul]; rfl
+  rw [hsmul] at h1
+  linear_combination h2 + h3 - h1
+
+noncomputable def periodHom (hF : IsEquivariantPrimitive Γ F) : Additive Γ →+ ℂ where
+  toFun γ := hF.period (Additive.toMul γ)
+  map_zero' := hF.period_one
+  map_add' γ δ := hF.period_mul (Additive.toMul γ) (Additive.toMul δ)
+
+@[simp]
+theorem periodHom_apply (hF : IsEquivariantPrimitive Γ F) (γ : Γ) :
+    hF.periodHom (Additive.ofMul γ) = hF.period γ :=
+  rfl
+
+end IsEquivariantPrimitive
+
+section ParabolicHoms
+
+variable (R : Type*) [Semiring R] (Γ : Subgroup SL(2, ℤ)) (A : Type*) [AddCommGroup A] [Module R A]
+
+def parabolicHoms : Submodule R (Additive Γ →+ A) where
+  carrier := {φ | IsParabolicHom Γ φ}
+  zero_mem' := fun _ _ => rfl
+  add_mem' := by
+    intro φ ψ hφ hψ γ hγ
+    change φ (Additive.ofMul γ) + ψ (Additive.ofMul γ) = 0
+    rw [hφ γ hγ, hψ γ hγ, add_zero]
+  smul_mem' := by
+    intro c φ hφ γ hγ
+    change c • φ (Additive.ofMul γ) = 0
+    rw [hφ γ hγ, smul_zero]
+
+variable {R Γ A}
+
+theorem mem_parabolicHoms_iff {φ : Additive Γ →+ A} :
+    φ ∈ parabolicHoms R Γ A ↔ IsParabolicHom Γ φ :=
+  Iff.rfl
+
+end ParabolicHoms
+
+end ModularCurve.Period
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_PeriodMapBundled.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_PeriodMapBundled.lean
new file mode 100644
index 0000000000..9562336b27
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_PeriodMapBundled.lean
@@ -0,0 +1,93 @@
+/-
+Based on Prove2Me node ModularCurve_PeriodMapBundled
+(d43bec83-2176-5d54-84a9-3d42beff39e5) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodMap
+public import Mathlib.Analysis.Complex.UpperHalfPlane.FunctionsBoundedAtInfty
+public import Mathlib.NumberTheory.ModularForms.Basic
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+
+/-!
+# Period homomorphism of a weight-two cusp form
+
+Definition: `ModularCurve_PeriodMapBundled` (`d43bec83-2176-5d54-84a9-3d42beff39e5`), by Claude,
+2026-09-05.
+
+Fix $N$ and a cusp form $f$ of weight $2$ for $\Gamma_0(N)$. The predicate
+[`ModularCurve.HasEquivariantPrimitive N f F`](../def/ModularCurve_PeriodMapBundled.html#L12), for
+$F : \mathbb{H} \to \mathbb{C}$, is the conjunction of four clauses: (i) for every $\tau \in
+\mathbb{H}$, the function $F \circ$ `ofComplex` (the extension of $F$ to $\mathbb{C}$ through
+Mathlib's partial inverse of the coercion $\mathbb{H} \to \mathbb{C}$) has derivative $f(\tau)$ at
+the point $\tau$; (ii) $F \to 0$ along the filter `atImInfty`, i.e. as $\operatorname{Im} \tau \to
+\infty$; (iii) `Period.IsEquivariantPrimitive (Gamma0 N) F`, which says that for each $\gamma \in
+\Gamma_0(N)$ there is a constant $c \in \mathbb{C}$ with $F(\gamma \cdot z) - F(z) = c$ for all $z
+\in \mathbb{H}$; (iv) for every $\delta \in \mathrm{SL}_2(\mathbb{Z})$ the function $w \mapsto
+F(\delta \cdot w)$ has a limit along `atImInfty`, that is, $F$ has a limit at every cusp. So $F$ is
+a primitive of $f$ vanishing at $i\infty$, with constant $\Gamma_0(N)$-coboundaries and limits at
+all cusps.
+
+From clause (iii) the imported module builds the period of $\gamma$, namely the constant $F(\gamma
+\cdot i) - F(i)$, and assembles these into an additive homomorphism `periodHom` from `Additive
+(Gamma0 N)` to $\mathbb{C}$, using $F(\gamma\delta\cdot z) - F(z) = (F(\gamma\cdot z)-F(z)) +
+(F(\delta\cdot z)-F(z))$. The definition [`ModularCurve.periodMap N f : Additive (Gamma0 N) →+
+ℂ`](../def/ModularCurve_PeriodMapBundled.html#L20) is then, by cases on whether some $F$ with
+`HasEquivariantPrimitive N f F` exists, the homomorphism `periodHom` attached to a classically
+chosen such $F$, and the zero homomorphism otherwise; the existence of an admissible primitive is
+not asserted here. The helper theorem `periodMap_def` records the unfolding in the non-degenerate
+case: given any $F$ with `HasEquivariantPrimitive N f F`, there are $F_0$ and a proof $h_0$ of
+`HasEquivariantPrimitive N f F₀` with `periodMap N f` equal to the period homomorphism determined by
+the third clause of $h_0$. The conclusion concerns the chosen $F_0$, not the given $F$; no claim
+that the period homomorphism is independent of the primitive is made at this point.
+
+The imported module also defines, for an abelian group $A$, the predicate `IsParabolicHom` on
+homomorphisms $\varphi :$ `Additive Γ` $\to_+ A$ — vanishing on every $\gamma \in \Gamma$ whose
+matrix trace satisfies $\operatorname{tr}(\gamma)^2 = 4$ — and the submodule `parabolicHoms` of
+homomorphisms satisfying it.
+
+**Relation to Mathlib.** Mathlib supplies the ingredients used here (`CuspForm`, `Gamma0`, the
+Möbius action on `ℍ`, the filter `atImInfty`, and `ofComplex`); the notions of equivariant
+primitive, period homomorphism and parabolic homomorphism, and the period map of a weight-two cusp
+form, are the project's own.
+
+**Where it is used.** The period homomorphism of a weight-two cusp form for $\Gamma_0(N)$ is the
+analytic input to the Eichler–Shimura description of the homology of the modular curve $X_0(N)$ and
+to the construction of period lattices and modular parametrisations used on the modularity side of
+the argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace ModularCurve
+
+open UpperHalfPlane CongruenceSubgroup Filter Topology Period
+
+open scoped MatrixGroups
+
+def HasEquivariantPrimitive (N : ℕ) (f : CuspForm (Gamma0 N) 2) (F : ℍ → ℂ) : Prop :=
+  (∀ τ : ℍ, HasDerivAt (F ∘ ofComplex) (f τ) ↑τ) ∧
+    Tendsto F atImInfty (𝓝 0) ∧
+    IsEquivariantPrimitive (Gamma0 N) F ∧
+    ∀ δ : SL(2, ℤ), ∃ L : ℂ, Tendsto (fun w : ℍ => F (δ • w)) atImInfty (𝓝 L)
+
+open Classical in
+noncomputable def periodMap (N : ℕ) (f : CuspForm (Gamma0 N) 2) : Additive (Gamma0 N) →+ ℂ :=
+  if h : ∃ F : ℍ → ℂ, HasEquivariantPrimitive N f F then h.choose_spec.2.2.1.periodHom else 0
+
+theorem periodMap_def (N : ℕ) (f : CuspForm (Gamma0 N) 2) {F : ℍ → ℂ}
+    (hF : HasEquivariantPrimitive N f F) :
+    ∃ (F₀ : ℍ → ℂ) (h₀ : HasEquivariantPrimitive N f F₀), periodMap N f = h₀.2.2.1.periodHom := by
+  classical
+  have h : ∃ F : ℍ → ℂ, HasEquivariantPrimitive N f F := ⟨F, hF⟩
+  exact ⟨h.choose, h.choose_spec, dite_eq_left h⟩
+
+end ModularCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_PeriodOf.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_PeriodOf.lean
new file mode 100644
index 0000000000..6c52b40765
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_PeriodOf.lean
@@ -0,0 +1,205 @@
+/-
+Based on Prove2Me node ModularCurve_PeriodOf
+(904c1b4e-c0ab-5de1-a189-92dd0af902d0) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_CuspForm_Petersson
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodLattice
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodMapBundled
+
+/-!
+# Periods, period lattice and Petersson product for general Γ
+
+Definition: `ModularCurve_PeriodOf` (`904c1b4e-c0ab-5de1-a189-92dd0af902d0`), by Claude, 2026-09-05.
+
+Fix a subgroup $\Gamma\le\mathrm{SL}_2(\mathbb Z)$. The first group of declarations sets up
+integration of a weight-two cusp form along a straight segment in the upper half-plane: for
+$\tau_0,\tau_1\in\mathfrak H$ and $f\in S_2(\Gamma)$ (Mathlib's `CuspForm Γ 2`),
+[`ModularCurve.periodIntegrandOf`](../def/ModularCurve_PeriodOf.html#L21) is the function $t\mapsto
+f\big((1-t)\tau_0+t\tau_1\big)(\tau_1-\tau_0)$, where the parameter is first clamped to $[0,1]$, so
+the integrand is globally continuous, hence interval integrable, and is additive and $\mathbb
+C$-homogeneous in $f$. Consequently $f\mapsto\int_0^1$ of this integrand is a $\mathbb C$-linear
+functional [`ModularCurve.periodAlongOf Γ τ₀ τ₁`](../def/ModularCurve_PeriodOf.html#L42) on
+$S_2(\Gamma)$, i.e. the functional $f\mapsto\int_{\tau_0}^{\tau_1}f(\tau)\,d\tau$ along the segment.
+[`ModularCurve.periodOf Γ γ`](../def/ModularCurve_PeriodOf.html#L56) is this functional for the
+segment from $i$ to $\gamma\cdot i$, and [`ModularCurve.periodLatticeOf
+Γ`](../def/ModularCurve_PeriodOf.html#L65) is the $\mathbb Z$-submodule of the dual
+$S_2(\Gamma)^\vee$ spanned by the range of $\gamma\mapsto\mathrm{periodOf}\,\Gamma\,\gamma$; each
+$\mathrm{periodOf}\,\Gamma\,\gamma$ lies in it.
+
+[`ModularCurve.HasEquivariantPrimitiveOf Γ f F`](../def/ModularCurve_PeriodOf.html#L71) is the
+conjunction of four conditions on $F:\mathfrak H\to\mathbb C$: $F$ has complex derivative $f(\tau)$
+at every $\tau$; $F\to 0$ as $\operatorname{Im}\tau\to\infty$; $F$ is an equivariant primitive in
+the sense of [`ModularCurve.Period.IsEquivariantPrimitive`](../def/ModularCurve_PeriodMap.html#L12),
+that is for each $\gamma\in\Gamma$ the difference $F(\gamma\cdot z)-F(z)$ is a constant independent
+of $z$; and for every $\delta\in\mathrm{SL}_2(\mathbb Z)$ the function $w\mapsto F(\delta\cdot w)$
+has a finite limit at $i\infty$. [`ModularCurve.periodMapOf Γ
+f`](../def/ModularCurve_PeriodOf.html#L79) is the additive character
+$\Gamma^{\mathrm{add}}\to\mathbb C$, $\gamma\mapsto F(\gamma\cdot i)-F(i)$, attached to a chosen
+such $F$ when one exists, and $0$ otherwise; `periodMapOf_def` records that the value is realised by
+some witness whenever one witness is given.
+
+For an integer weight $k$, [`CuspForm.peterssonIntegrandOf Γ f
+g`](../def/ModularCurve_PeriodOf.html#L112) is the (finitely supported) sum over the coset space
+$\mathrm{SL}_2(\mathbb Z)/\Gamma$ of the pointwise Petersson densities `UpperHalfPlane.petersson k`
+of the slash translates $f\mid_k q^{-1}$ and $g\mid_k q^{-1}$, taken at a chosen representative of
+each coset, and [`CuspForm.peterssonOf Γ f g`](../def/ModularCurve_PeriodOf.html#L116) is its
+integral over the standard fundamental domain `ModularGroup.fd` of $\mathrm{SL}_2(\mathbb Z)$ for
+the restricted volume measure; no normalisation by the index is inserted. Four comparison lemmas
+identify `periodAlongOf`, `periodOf`, `periodLatticeOf`, `HasEquivariantPrimitiveOf`, `periodMapOf`
+and `peterssonOf` at $\Gamma=\Gamma_0(N)$ with the corresponding level-$N$ objects `periodAlong`,
+`period`, `periodLattice`, `HasEquivariantPrimitive`, `periodMap` and `petersson`, these being the
+same formulas written for a general subgroup.
+
+**Relation to Mathlib.** Mathlib supplies the ambient notions used here — `CuspForm`, the weight-$k$
+slash action, the pointwise Petersson density `UpperHalfPlane.petersson` and the fundamental domain
+`ModularGroup.fd` — but not the period functionals, the period lattice, the notion of an equivariant
+primitive or the globally integrated Petersson product; those are the project's own, and are given
+here for an arbitrary subgroup of $\mathrm{SL}_2(\mathbb Z)$ alongside the project's
+level-$\Gamma_0(N)$ versions.
+
+**Where it is used.** The period lattice in the dual of $S_2(\Gamma_0(N))$ and the period map are
+the analytic input to the Eichler–Shimura construction of the Hecke-stable lattice on which the
+modular Galois representations are realised; the Petersson product serves as the pairing on spaces
+of cusp forms. The comparison lemmas let statements formulated for a general subgroup be applied
+verbatim at the levels $\Gamma_0(N)$ occurring in the level-lowering and modularity-lifting
+arguments.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open UpperHalfPlane Filter Topology
+
+open scoped MatrixGroups ModularForm
+
+namespace ModularCurve
+
+section Period
+
+variable (Γ : Subgroup SL(2, ℤ))
+
+def periodIntegrandOf (τ₀ τ₁ : ℍ) (f : CuspForm Γ 2) (t : ℝ) : ℂ :=
+  f (segmentPath τ₀ τ₁ t) * ((τ₁ : ℂ) - τ₀)
+
+theorem continuous_periodIntegrandOf (τ₀ τ₁ : ℍ) (f : CuspForm Γ 2) :
+    Continuous (periodIntegrandOf Γ τ₀ τ₁ f) :=
+  ((f.holo'.continuous).comp (continuous_segmentPath τ₀ τ₁)).mul continuous_const
+
+theorem intervalIntegrable_periodIntegrandOf (τ₀ τ₁ : ℍ) (f : CuspForm Γ 2) (a b : ℝ) :
+    IntervalIntegrable (periodIntegrandOf Γ τ₀ τ₁ f) MeasureTheory.volume a b :=
+  (continuous_periodIntegrandOf Γ τ₀ τ₁ f).intervalIntegrable a b
+
+theorem periodIntegrandOf_add (τ₀ τ₁ : ℍ) (f g : CuspForm Γ 2) :
+    periodIntegrandOf Γ τ₀ τ₁ (f + g) = periodIntegrandOf Γ τ₀ τ₁ f + periodIntegrandOf Γ τ₀ τ₁ g
+      := by
+  funext t
+  simp [periodIntegrandOf, add_mul]
+
+theorem periodIntegrandOf_smul (τ₀ τ₁ : ℍ) (c : ℂ) (f : CuspForm Γ 2) :
+    periodIntegrandOf Γ τ₀ τ₁ (c • f) = fun t => c * periodIntegrandOf Γ τ₀ τ₁ f t := by
+  funext t
+  simp [periodIntegrandOf, mul_assoc]
+
+def periodAlongOf (τ₀ τ₁ : ℍ) : Module.Dual ℂ (CuspForm Γ 2) where
+  toFun f := ∫ t in (0 : ℝ)..1, periodIntegrandOf Γ τ₀ τ₁ f t
+  map_add' f g := by
+    rw [periodIntegrandOf_add]
+    exact intervalIntegral.integral_add (intervalIntegrable_periodIntegrandOf Γ τ₀ τ₁ f 0 1)
+      (intervalIntegrable_periodIntegrandOf Γ τ₀ τ₁ g 0 1)
+  map_smul' c f := by
+    rw [periodIntegrandOf_smul, RingHom.id_apply, smul_eq_mul]
+    exact intervalIntegral.integral_const_mul c _
+
+theorem periodAlongOf_apply (τ₀ τ₁ : ℍ) (f : CuspForm Γ 2) :
+    periodAlongOf Γ τ₀ τ₁ f = ∫ t in (0 : ℝ)..1, f (segmentPath τ₀ τ₁ t) * ((τ₁ : ℂ) - τ₀) :=
+  rfl
+
+def periodOf (γ : Γ) : Module.Dual ℂ (CuspForm Γ 2) :=
+  periodAlongOf Γ UpperHalfPlane.I ((γ : SL(2, ℤ)) • UpperHalfPlane.I)
+
+theorem periodOf_apply (γ : Γ) (f : CuspForm Γ 2) :
+    periodOf Γ γ f =
+      ∫ t in (0 : ℝ)..1, f (segmentPath UpperHalfPlane.I ((γ : SL(2, ℤ)) • UpperHalfPlane.I) t) *
+        ((((γ : SL(2, ℤ)) • UpperHalfPlane.I : ℍ) : ℂ) - (UpperHalfPlane.I : ℂ)) :=
+  rfl
+
+def periodLatticeOf : Submodule ℤ (Module.Dual ℂ (CuspForm Γ 2)) :=
+  Submodule.span ℤ (Set.range (periodOf Γ))
+
+theorem periodOf_mem_periodLatticeOf (γ : Γ) : periodOf Γ γ ∈ periodLatticeOf Γ :=
+  Submodule.subset_span (Set.mem_range_self γ)
+
+def HasEquivariantPrimitiveOf (f : CuspForm Γ 2) (F : ℍ → ℂ) : Prop :=
+  (∀ τ : ℍ, HasDerivAt (F ∘ ofComplex) (f τ) ↑τ) ∧
+    Tendsto F atImInfty (𝓝 0) ∧
+    Period.IsEquivariantPrimitive Γ F ∧
+    ∀ δ : SL(2, ℤ), ∃ L : ℂ, Tendsto (fun w : ℍ => F (δ • w)) atImInfty (𝓝 L)
+
+open Classical in
+def periodMapOf (f : CuspForm Γ 2) : Additive Γ →+ ℂ :=
+  if h : ∃ F : ℍ → ℂ, HasEquivariantPrimitiveOf Γ f F then h.choose_spec.2.2.1.periodHom else 0
+
+theorem periodMapOf_def (f : CuspForm Γ 2) {F : ℍ → ℂ} (hF : HasEquivariantPrimitiveOf Γ f F) :
+    ∃ (F₀ : ℍ → ℂ) (h₀ : HasEquivariantPrimitiveOf Γ f F₀), periodMapOf Γ f = h₀.2.2.1.periodHom
+      := by
+  classical
+  have h : ∃ F : ℍ → ℂ, HasEquivariantPrimitiveOf Γ f F := ⟨F, hF⟩
+  exact ⟨h.choose, h.choose_spec, dite_eq_left h⟩
+
+theorem periodAlongOf_gamma0 (N : ℕ) (τ₀ τ₁ : ℍ) :
+    periodAlongOf (CongruenceSubgroup.Gamma0 N) τ₀ τ₁ = periodAlong N τ₀ τ₁ := rfl
+
+theorem periodOf_gamma0 (N : ℕ) (γ : CongruenceSubgroup.Gamma0 N) :
+    periodOf (CongruenceSubgroup.Gamma0 N) γ = period N γ := rfl
+
+theorem periodLatticeOf_gamma0 (N : ℕ) :
+    periodLatticeOf (CongruenceSubgroup.Gamma0 N) = periodLattice N := rfl
+
+theorem hasEquivariantPrimitiveOf_gamma0_iff (N : ℕ) (f : CuspForm (CongruenceSubgroup.Gamma0 N) 2)
+    (F : ℍ → ℂ) : HasEquivariantPrimitiveOf (CongruenceSubgroup.Gamma0 N) f F ↔
+      HasEquivariantPrimitive N f F := Iff.rfl
+
+theorem periodMapOf_gamma0 (N : ℕ) (f : CuspForm (CongruenceSubgroup.Gamma0 N) 2) :
+    periodMapOf (CongruenceSubgroup.Gamma0 N) f = periodMap N f := rfl
+
+end Period
+
+end ModularCurve
+
+namespace CuspForm
+
+variable (Γ : Subgroup SL(2, ℤ)) {k : ℤ}
+
+def peterssonIntegrandOf (f g : CuspForm Γ k) (τ : UpperHalfPlane) : ℂ :=
+  ∑ᶠ q : SL(2, ℤ) ⧸ Γ,
+    UpperHalfPlane.petersson k (⇑f ∣[k] (q.out⁻¹ : SL(2, ℤ))) (⇑g ∣[k] (q.out⁻¹ : SL(2, ℤ))) τ
+
+def peterssonOf (f g : CuspForm Γ k) : ℂ :=
+  MeasureTheory.integral (MeasureTheory.volume.restrict ModularGroup.fd) (peterssonIntegrandOf Γ f
+    g)
+
+theorem peterssonOf_def (f g : CuspForm Γ k) :
+    peterssonOf Γ f g =
+      MeasureTheory.integral (MeasureTheory.volume.restrict ModularGroup.fd)
+        (peterssonIntegrandOf Γ f g) := rfl
+
+theorem peterssonIntegrandOf_gamma0 {N : ℕ} (f g : CuspForm (CongruenceSubgroup.Gamma0 N) k) :
+    peterssonIntegrandOf (CongruenceSubgroup.Gamma0 N) f g = peterssonIntegrand f g := rfl
+
+theorem peterssonOf_gamma0 {N : ℕ} (f g : CuspForm (CongruenceSubgroup.Gamma0 N) k) :
+    peterssonOf (CongruenceSubgroup.Gamma0 N) f g = petersson f g := rfl
+
+end CuspForm
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_PhiGen.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_PhiGen.lean
new file mode 100644
index 0000000000..04e0dac803
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_PhiGen.lean
@@ -0,0 +1,366 @@
+/-
+Based on Prove2Me node ModularCurve_PhiGen
+(6c538294-6e83-5a61-acbf-af8f4937d322) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import Mathlib.Algebra.Polynomial.BigOperators
+
+/-!
+# Coset substitutions and the generic modular polynomial Φℓ​
+
+Definition: `ModularCurve_PhiGen` (`6c538294-6e83-5a61-acbf-af8f4937d322`), by Claude, 2026-09-05.
+
+Working with formal Laurent series (Hahn series over $\mathbb{Z}$), the module sets up the
+substitution calculus behind the modular equation. For a commutative ring $R$ and a unit $u \in
+R^\times$, `qTwist u` is the ring endomorphism of $R((t))$ with $(\mathrm{qTwist}\,u\,f)_k = u^k
+f_k$, i.e. the substitution $t \mapsto ut$; helper lemmas record its effect on monomials, that it
+preserves supports, is injective, that $\mathrm{qTwist}\,u \circ \mathrm{qTwist}\,v =
+\mathrm{qTwist}(uv)$, and that it commutes with the $N$-fold expansion `qExpand` at the cost of
+replacing $u$ by $u^N$. Over a field $K$, `cosetSubst ζ a b` is `qTwist (ζ ^ (a * b))` followed by
+`qExpand K (a * a)`, the formal substitution $q \mapsto \zeta^{ab} t^{a^2}$. With $\ell$ prime, $K$
+a $\mathbb{Q}$-algebra field and $\zeta \in K^\times$, the index functions `cosetA`, `cosetB` encode
+the pairs $(a,b) = (\ell,0)$ at index $0$ and $(1,b)$ at index $b+1$, and `conj ℓ ζ i` applies
+`cosetSubst ζ (cosetA ℓ i) (cosetB ℓ i)` to the base change `coeffEmb K jq` of $j(q)$; its normal
+forms are $j$ expanded in $t^{\ell^2}$ at index $0$ and $\mathrm{qTwist}(\zeta^b)$ of $j$ at index
+$b+1$. `phiProd ℓ conj` is $\prod_{i \in \mathrm{Fin}(\ell+1)}(X - C(\mathrm{conj}\,i))$ in
+$K((t))[X]$, shown monic of degree $\ell+1$, nonzero, and vanishing at each $\mathrm{conj}\,i$.
+Several predicates pin down the expected shape of this product: `PhiGenDescends c` says each
+coefficient of `phiProd ℓ (conj ℓ ζ)` is the base change of the $\ell$-fold expansion of $c_k \in
+\mathbb{Q}((q))$; `PoleOrderLE`/`TPoleOrderLE` (vanishing of all coefficients in degrees $< -n$),
+`JSimplePole` and `IntCoeffs` (every coefficient lies in $\mathbb{Z}$) are the pole and integrality
+conditions. Further auxiliary notions: `evalAtJqN N`, evaluation of $\mathbb{Z}[X]$ at $j(q^N)$;
+`EvalSymm Φ`, the assertion that the bivariate $\Phi \in \mathbb{Z}[X][Y]$ takes the same value on
+$(x,y)$ and $(y,x)$ for all $x,y \in \mathbb{Q}((q))$; `ModularPolynomialFamily`, the existence, for
+every prime $\ell$, of a `ModularPolynomialData ℓ` (a monic $\Phi$ of degree $\psi(\ell)$ with
+$\Phi(j, j(q^\ell)) = 0$) whose $\Phi$ is `EvalSymm`; `PhiIrreducible data`, irreducibility of
+$\Phi$ pushed into $\mathbb{Q}(j(q))[X]$; the subalgebra $\mathbb{Q}[j(q)] \subseteq
+\mathbb{Q}((q))$ with its distinguished element and evaluation map; and `swapBivar`, the involution
+of $\mathbb{Z}[X][Y]$ interchanging the two variables.
+
+**Relation to Mathlib.** Mathlib supplies the Laurent series ring as Hahn series over $\mathbb{Z}$
+together with `aeval`/`eval₂` evaluation; the substitutions $t \mapsto ut$ and $q \mapsto
+\zeta^{ab}t^{a^2}$, the family of conjugates of $j$, and modular polynomials are the project's own.
+
+**Where it is used.** These definitions provide the formal $q$-expansion vocabulary in which the
+modular equation $\Phi_\ell(X,Y)$ is produced, with its degree, symmetry, integrality and
+irreducibility properties, for the theory of the modular curves $X_0(N)$ entering the modularity and
+level-lowering steps.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open scoped PowerSeries.WithPiTopology
+open PowerSeries HahnSeries IntermediateField Polynomial
+
+namespace ModularCurve
+
+section QTwist
+
+variable {R : Type*} [CommRing R]
+
+def qTwistFun (u : Rˣ) (f : LaurentSeries R) : LaurentSeries R where
+  coeff k := (u ^ k : Rˣ) * f.coeff k
+  isPWO_support' := f.isPWO_support'.mono fun k hk => by
+    simp only [Function.mem_support] at hk ⊢
+    exact fun h => hk (by rw [h, mul_zero])
+
+@[simp]
+theorem qTwistFun_coeff (u : Rˣ) (f : LaurentSeries R) (k : ℤ) :
+    (qTwistFun u f).coeff k = (u ^ k : Rˣ) * f.coeff k := rfl
+
+theorem support_qTwistFun (u : Rˣ) (f : LaurentSeries R) :
+    (qTwistFun u f).support = f.support := by
+  ext k
+  rw [HahnSeries.mem_support, HahnSeries.mem_support, qTwistFun_coeff]
+  exact not_congr (Units.mul_right_eq_zero _)
+
+open Finset renaming antidiagonal → pwoAntidiagonal, mem_antidiagonal → mem_pwoAntidiagonal in
+def qTwist (u : Rˣ) : LaurentSeries R →+* LaurentSeries R where
+  toFun := qTwistFun u
+  map_one' := by
+    ext k
+    rw [qTwistFun_coeff, HahnSeries.coeff_one]
+    split_ifs with h
+    · subst h; simp
+    · rw [mul_zero]
+  map_mul' f g := by
+    ext k
+    have hset : pwoAntidiagonal (qTwistFun u f).isPWO_support
+        (qTwistFun u g).isPWO_support k =
+        pwoAntidiagonal f.isPWO_support g.isPWO_support k := by
+      ext ij
+      simp only [mem_pwoAntidiagonal, support_qTwistFun]
+    rw [qTwistFun_coeff, HahnSeries.coeff_mul, HahnSeries.coeff_mul, hset, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun ij hij => ?_
+    obtain ⟨-, -, hsum⟩ := mem_pwoAntidiagonal.mp hij
+    rw [qTwistFun_coeff, qTwistFun_coeff, mul_mul_mul_comm, ← Units.val_mul, ← zpow_add,
+      hsum]
+  map_zero' := by
+    ext k
+    rw [qTwistFun_coeff, HahnSeries.coeff_zero, mul_zero]
+  map_add' f g := by
+    ext k
+    rw [HahnSeries.coeff_add]
+    change (qTwistFun u (f + g)).coeff k = (qTwistFun u f).coeff k + (qTwistFun u g).coeff k
+    rw [qTwistFun_coeff, qTwistFun_coeff, qTwistFun_coeff, HahnSeries.coeff_add, mul_add]
+
+@[simp]
+theorem qTwist_coeff (u : Rˣ) (f : LaurentSeries R) (k : ℤ) :
+    (qTwist u f).coeff k = (u ^ k : Rˣ) * f.coeff k := rfl
+
+theorem support_qTwist (u : Rˣ) (f : LaurentSeries R) : (qTwist u f).support = f.support :=
+  support_qTwistFun u f
+
+@[simp]
+theorem qTwist_single (u : Rˣ) (k : ℤ) (r : R) :
+    qTwist u (HahnSeries.single k r) = HahnSeries.single k ((u ^ k : Rˣ) * r) := by
+  ext m
+  rw [qTwist_coeff, HahnSeries.coeff_single, HahnSeries.coeff_single]
+  split_ifs with h
+  · subst h; rfl
+  · rw [mul_zero]
+
+theorem qTwist_one_apply (f : LaurentSeries R) : qTwist (1 : Rˣ) f = f := by
+  ext k
+  rw [qTwist_coeff, one_zpow, Units.val_one, one_mul]
+
+theorem qTwist_qTwist (u v : Rˣ) (f : LaurentSeries R) :
+    qTwist u (qTwist v f) = qTwist (u * v) f := by
+  ext k
+  rw [qTwist_coeff, qTwist_coeff, qTwist_coeff, ← mul_assoc, ← Units.val_mul, ← mul_zpow]
+
+theorem qTwist_injective (u : Rˣ) : Function.Injective (qTwist u) := by
+  intro f g h
+  have := congrArg (qTwist u⁻¹) h
+  rwa [qTwist_qTwist, qTwist_qTwist, inv_mul_cancel, qTwist_one_apply, qTwist_one_apply]
+    at this
+
+theorem qTwist_qExpand (v : Rˣ) (N : ℕ) [NeZero N] (f : LaurentSeries R) :
+    qTwist v (qExpand R N f) = qExpand R N (qTwist (v ^ (N : ℤ)) f) := by
+  ext k
+  by_cases hk : (N : ℤ) ∣ k
+  · obtain ⟨m, rfl⟩ := hk
+    rw [qTwist_coeff, qExpand_coeff_mul, qExpand_coeff_mul, qTwist_coeff, ← zpow_mul]
+  · rw [qTwist_coeff, qExpand_coeff_of_not_dvd N f hk, mul_zero,
+      qExpand_coeff_of_not_dvd N _ hk]
+
+end QTwist
+
+section CosetSubst
+
+variable {K : Type*} [Field K]
+
+def cosetSubst (ζ : Kˣ) (a b : ℕ) [NeZero a] : LaurentSeries K →+* LaurentSeries K :=
+  haveI : NeZero (a * a) := ⟨Nat.mul_ne_zero (NeZero.ne a) (NeZero.ne a)⟩
+  (qExpand K (a * a)).comp (qTwist (ζ ^ (a * b)))
+
+end CosetSubst
+
+section EvalAtJqN
+
+variable (N : ℕ) [NeZero N]
+
+def evalAtJqN : Polynomial ℤ →+* LaurentSeries ℚ :=
+  (Polynomial.aeval (R := ℤ) (jqN N)).toRingHom
+
+@[simp]
+theorem evalAtJqN_X : evalAtJqN N Polynomial.X = jqN N := by
+  simp [evalAtJqN]
+
+theorem evalAtJqN_def : evalAtJqN N = (Polynomial.aeval (R := ℤ) (jqN N)).toRingHom := rfl
+
+theorem evalAtJ_def : evalAtJ = (Polynomial.aeval (R := ℤ) jq).toRingHom := rfl
+
+theorem evalAtJqN_one : evalAtJqN 1 = evalAtJ := by
+  rw [evalAtJqN_def, evalAtJ_def, jqN_one]
+
+end EvalAtJqN
+
+section Symmetry
+
+def EvalSymm (Φ : Polynomial (Polynomial ℤ)) : Prop :=
+  ∀ x y : LaurentSeries ℚ,
+    Φ.eval₂ (Polynomial.aeval (R := ℤ) x).toRingHom y
+      = Φ.eval₂ (Polynomial.aeval (R := ℤ) y).toRingHom x
+
+@[simp]
+theorem aeval_toRingHom_X (x : LaurentSeries ℚ) :
+    (Polynomial.aeval (R := ℤ) x).toRingHom Polynomial.X = x := by
+  simp
+
+end Symmetry
+
+def PoleOrderLE (f : LaurentSeries ℚ) (n : ℕ) : Prop :=
+  ∀ k : ℤ, k < -(n : ℤ) → f.coeff k = 0
+
+def ModularPolynomialFamily : Prop :=
+  ∀ (ℓ : ℕ) [NeZero ℓ], ℓ.Prime → ∃ data : ModularPolynomialData ℓ, EvalSymm data.Φ
+
+section Named
+
+variable {N : ℕ} [NeZero N]
+
+def PhiIrreducible (data : ModularPolynomialData N) : Prop :=
+  Irreducible data.toAdjoin
+
+end Named
+
+section AdjoinRing
+
+abbrev adjoinJq : Subalgebra ℚ (LaurentSeries ℚ) := Algebra.adjoin ℚ {jq}
+
+def jAdj : adjoinJq := ⟨jq, Algebra.self_mem_adjoin_singleton ℚ jq⟩
+
+def evalAtJAdj : Polynomial ℤ →+* adjoinJq :=
+  Polynomial.eval₂RingHom (Int.castRingHom adjoinJq) jAdj
+
+end AdjoinRing
+
+section SwapBivar
+
+def swapInner : Polynomial ℤ →+* Polynomial (Polynomial ℤ) :=
+  (Polynomial.aeval (R := ℤ) (Polynomial.X : Polynomial (Polynomial ℤ))).toRingHom
+
+def swapBivar : Polynomial (Polynomial ℤ) →+* Polynomial (Polynomial ℤ) :=
+  Polynomial.eval₂RingHom swapInner (Polynomial.C Polynomial.X)
+
+@[simp]
+theorem swapBivar_X : swapBivar Polynomial.X = Polynomial.C Polynomial.X :=
+  Polynomial.eval₂_X _ _
+
+@[simp]
+theorem swapBivar_C_X : swapBivar (Polynomial.C Polynomial.X) = Polynomial.X := by
+  change Polynomial.eval₂ swapInner (Polynomial.C Polynomial.X) (Polynomial.C Polynomial.X)
+    = Polynomial.X
+  rw [Polynomial.eval₂_C]
+  exact Polynomial.aeval_X _
+
+end SwapBivar
+
+namespace PhiGen
+
+section CosetIndex
+
+variable (ℓ : ℕ)
+
+def cosetA (i : Fin (ℓ + 1)) : ℕ := if i = 0 then ℓ else 1
+
+def cosetB (i : Fin (ℓ + 1)) : ℕ := if i = 0 then 0 else (i : ℕ) - 1
+
+@[simp]
+theorem cosetA_zero : cosetA ℓ (0 : Fin (ℓ + 1)) = ℓ := ite_eq_left rfl
+
+@[simp]
+theorem cosetB_zero : cosetB ℓ (0 : Fin (ℓ + 1)) = 0 := ite_eq_left rfl
+
+@[simp]
+theorem cosetA_succ (b : Fin ℓ) : cosetA ℓ b.succ = 1 := ite_eq_right (Fin.succ_ne_zero b)
+
+@[simp]
+theorem cosetB_succ (b : Fin ℓ) : cosetB ℓ b.succ = (b : ℕ) := by
+  rw [cosetB, ite_eq_right (Fin.succ_ne_zero b), Fin.val_succ, Nat.add_sub_cancel]
+
+instance instNeZeroPhiGenCosetA [hℓ : Fact (Nat.Prime ℓ)] (i : Fin (ℓ + 1)) :
+    NeZero (cosetA ℓ i) :=
+  ⟨by unfold cosetA; split <;> simp [hℓ.out.ne_zero]⟩
+
+end CosetIndex
+
+section ConjugateFamily
+
+variable {K : Type*} [Field K]
+
+theorem cosetSubst_congr (ζ : Kˣ) {a a' b b' : ℕ} [NeZero a] [NeZero a'] (ha : a = a')
+    (hb : b = b') (f : LaurentSeries K) : cosetSubst ζ a b f = cosetSubst ζ a' b' f := by
+  subst ha; subst hb; rfl
+
+variable [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+def conj (i : Fin (ℓ + 1)) : LaurentSeries K :=
+  cosetSubst ζ (cosetA ℓ i) (cosetB ℓ i) (coeffEmb K jq)
+
+theorem conj_zero : conj ℓ ζ (0 : Fin (ℓ + 1)) = qExpand K (ℓ * ℓ) (coeffEmb K jq) := by
+  have h1 : conj ℓ ζ (0 : Fin (ℓ + 1)) = cosetSubst ζ ℓ 0 (coeffEmb K jq) :=
+    cosetSubst_congr ζ (cosetA_zero ℓ) (cosetB_zero ℓ) (coeffEmb K jq)
+  rw [h1, cosetSubst, RingHom.comp_apply, mul_zero, pow_zero, qTwist_one_apply]
+
+theorem conj_succ (b : Fin ℓ) : conj ℓ ζ b.succ = qTwist (ζ ^ (b : ℕ)) (coeffEmb K jq) := by
+  have h1 : conj ℓ ζ b.succ = cosetSubst ζ 1 ((b : ℕ)) (coeffEmb K jq) :=
+    cosetSubst_congr ζ (cosetA_succ ℓ b) (cosetB_succ ℓ b) (coeffEmb K jq)
+  rw [h1, cosetSubst, RingHom.comp_apply,
+    qExpand_congr (show 1 * 1 = 1 by norm_num), qExpand_one_apply, one_mul]
+
+end ConjugateFamily
+
+section Product
+
+variable {K : Type*} [Field K] (ℓ : ℕ)
+
+def phiProd (conj : Fin (ℓ + 1) → LaurentSeries K) : Polynomial (LaurentSeries K) :=
+  ∏ i : Fin (ℓ + 1), (Polynomial.X - Polynomial.C (conj i))
+
+theorem phiProd_monic (conj : Fin (ℓ + 1) → LaurentSeries K) : (phiProd ℓ conj).Monic :=
+  monic_prod_of_monic _ _ fun i _ => monic_X_sub_C (conj i)
+
+theorem phiProd_natDegree (conj : Fin (ℓ + 1) → LaurentSeries K) :
+    (phiProd ℓ conj).natDegree = ℓ + 1 := by
+  rw [phiProd, natDegree_prod_of_monic _ _ fun i _ => monic_X_sub_C _]
+  simp
+
+theorem phiProd_ne_zero (conj : Fin (ℓ + 1) → LaurentSeries K) : phiProd ℓ conj ≠ 0 :=
+  (phiProd_monic ℓ conj).ne_zero
+
+theorem phiProd_eval_conj (conj : Fin (ℓ + 1) → LaurentSeries K) (i : Fin (ℓ + 1)) :
+    (phiProd ℓ conj).eval (conj i) = 0 := by
+  rw [phiProd, Polynomial.eval_prod]
+  exact Finset.prod_eq_zero (Finset.mem_univ i) (by simp)
+
+end Product
+
+section PoleDefs
+
+variable {K : Type*} [Field K]
+
+def TPoleOrderLE (f : LaurentSeries K) (n : ℕ) : Prop :=
+  ∀ m : ℤ, m < -(n : ℤ) → f.coeff m = 0
+
+theorem tPoleOrderLE_iff_poleOrderLE (f : LaurentSeries ℚ) (n : ℕ) :
+    TPoleOrderLE f n ↔ PoleOrderLE f n :=
+  Iff.rfl
+
+variable (J : LaurentSeries K)
+
+def JSimplePole : Prop := ∀ m : ℤ, m < -1 → J.coeff m = 0
+
+end PoleDefs
+
+def IntCoeffs (f : LaurentSeries ℚ) : Prop :=
+  ∀ m : ℤ, ∃ z : ℤ, f.coeff m = (z : ℚ)
+
+section Descends
+
+variable {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+def PhiGenDescends (c : ℕ → LaurentSeries ℚ) : Prop :=
+  ∀ k : ℕ, (phiProd ℓ (conj ℓ ζ)).coeff k = coeffEmb K (qExpand ℚ ℓ (c k))
+
+end Descends
+
+end PhiGen
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_PrimCosetReps.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_PrimCosetReps.lean
new file mode 100644
index 0000000000..f207fae974
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_PrimCosetReps.lean
@@ -0,0 +1,100 @@
+/-
+Based on Prove2Me node ModularCurve_PrimCosetReps
+(174fa83c-01fe-5ba1-9e74-0108f10e27bb) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+/-!
+# Primitive coset representatives and the coset product polynomial
+
+Definition: `ModularCurve_PrimCosetReps` (`174fa83c-01fe-5ba1-9e74-0108f10e27bb`), by Claude,
+2026-09-05.
+
+For a natural number $N$, `primCosetReps N` is the finite set of triples $(a,b,d)$ of natural
+numbers, carved out of $\{0,\dots,N\}^3$, satisfying $ad = N$, $b < d$ and $\gcd(a,\gcd(b,d)) = 1$;
+these are the usual representatives $\begin{pmatrix} a & b \\ 0 & d\end{pmatrix}$ of the primitive
+integral matrices of determinant $N$ modulo $\mathrm{SL}_2(\mathbb{Z})$. The companion lemma
+`mem_primCosetReps` states, for $N \neq 0$, that $(a,b,d)$ lies in `primCosetReps N` precisely when
+$ad = N$, $b < d$ and $\gcd(a,\gcd(b,d)) = 1$: the ambient bounds $a,b,d \le N$ used to make the set
+finite are automatic consequences of $ad = N$ and $b < d$.
+
+Over a field $K$, for a unit $\zeta \in K^\times$, a formal Laurent series $J$ over $K$ and a triple
+$t = (a,b,d)$, `cosetConj ζ J t` is defined to be $0$ when $a = 0$, and otherwise to be `cosetSubst
+ζ a b J`, that is the image of $J$ under the composite of the coefficientwise twist $c_k \mapsto
+(\zeta^{ab})^k c_k$ with the exponent rescaling $k \mapsto a^2 k$ — formally the substitution $J(t)
+\mapsto J(\zeta^{ab} t^{a^2})$. The third entry $d$ of the triple does not enter the formula. The
+lemma `cosetConj_eq` records the case $a \neq 0$ of this definition. Finally, `cosetTwoVarPoly ζ N
+J` is the polynomial
+$$\prod_{t \in \mathrm{primCosetReps}\ N} \bigl(X - C(\mathrm{cosetConj}\ \zeta\ J\ t)\bigr)$$
+in one variable over the field of formal Laurent series over $K$: a monic polynomial whose degree is
+the cardinality of `primCosetReps N`, and whose roots are the coset conjugates of $J$. When $J$ is
+the $q$-expansion of $j$ and $\zeta$ a primitive $N$-th root of unity, this is the right-hand side
+of the coset factorisation of the modular polynomial $\Phi_N$.
+
+**Relation to Mathlib.** Mathlib has no modular polynomial, nor coset representatives for primitive
+integral matrices of a given determinant; these are the project's own notions, built on Mathlib's
+`LaurentSeries`/`HahnSeries` and `Polynomial` API.
+
+**Where it is used.** These definitions supply the factorised side of the modular equation: the
+coset conjugates of the $q$-expansion of $j$ and their product polynomial are the input to the
+construction of a modular polynomial $\Phi_N$ and hence of the function field of $X_0(N)$, which
+underlies the modular-curve material used in the Frey–Serre–Ribet–Wiles–Taylor–Wiles argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace ModularCurve
+
+def primCosetReps (N : ℕ) : Finset (ℕ × ℕ × ℕ) :=
+  Finset.filter
+    (fun t => t.1 * t.2.2 = N ∧ t.2.1 < t.2.2 ∧ Nat.gcd t.1 (Nat.gcd t.2.1 t.2.2) = 1)
+    (Finset.range (N + 1) ×ˢ Finset.range (N + 1) ×ˢ Finset.range (N + 1))
+
+theorem mem_primCosetReps {N a b d : ℕ} (hN : N ≠ 0) :
+    (a, b, d) ∈ primCosetReps N ↔ a * d = N ∧ b < d ∧ Nat.gcd a (Nat.gcd b d) = 1 := by
+  simp only [primCosetReps, Finset.mem_filter, Finset.mem_product, Finset.mem_range]
+  constructor
+  · rintro ⟨_, had, hbd, hgcd⟩
+    exact ⟨had, hbd, hgcd⟩
+  · rintro ⟨had, hbd, hgcd⟩
+    have hd0 : d ≠ 0 := by
+      rintro rfl
+      exact hN (by simpa using had.symm)
+    have ha0 : a ≠ 0 := by
+      rintro rfl
+      exact hN (by simpa using had.symm)
+    have haN : a ≤ N := had ▸ Nat.le_mul_of_pos_right a (Nat.pos_of_ne_zero hd0)
+    have hdN : d ≤ N := had ▸ Nat.le_mul_of_pos_left d (Nat.pos_of_ne_zero ha0)
+    exact ⟨⟨by omega, by omega, by omega⟩, had, hbd, hgcd⟩
+
+section Conjugates
+
+variable {K : Type*} [Field K]
+
+noncomputable def cosetConj (ζ : Kˣ) (J : LaurentSeries K) (t : ℕ × ℕ × ℕ) : LaurentSeries K :=
+  if h : t.1 = 0 then 0 else
+    haveI : NeZero t.1 := ⟨h⟩
+    cosetSubst ζ t.1 t.2.1 J
+
+theorem cosetConj_eq (ζ : Kˣ) (J : LaurentSeries K) (a b d : ℕ) [NeZero a] :
+    cosetConj ζ J (a, b, d) = cosetSubst ζ a b J := by
+  unfold cosetConj
+  rw [dite_eq_right (NeZero.ne a)]
+
+noncomputable def cosetTwoVarPoly (ζ : Kˣ) (N : ℕ) (J : LaurentSeries K) :
+    Polynomial (LaurentSeries K) :=
+  (primCosetReps N).prod fun t => Polynomial.X - Polynomial.C (cosetConj ζ J t)
+
+end Conjugates
+
+end ModularCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_ProjectiveLine.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_ProjectiveLine.lean
new file mode 100644
index 0000000000..35f7a130f6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_ProjectiveLine.lean
@@ -0,0 +1,145 @@
+/-
+Based on Prove2Me node ModularCurve_ProjectiveLine
+(645d7c19-655a-5a1f-81d2-89ea49d002be) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.LinearAlgebra.Matrix.SpecialLinearGroup
+public import Mathlib.GroupTheory.GroupAction.Quotient
+public import Mathlib.Basic.Finite.Prod
+
+/-!
+# Projective line over a commutative ring; Borel subgroup of SL₂
+
+Definition: `ModularCurve_ProjectiveLine` (`645d7c19-655a-5a1f-81d2-89ea49d002be`), by Claude,
+2026-09-05.
+
+Over a commutative ring $R$, a pair $(a,c)\in R^2$ is called a unimodular row, `IsUnimodularRow a
+c`, when it admits a Bézout relation: there exist $x,y\in R$ with $xa+yc=1$. Two trivial instances
+are recorded, $(1,t)$ and $(m,1)$, together with the fact that unimodularity is preserved by any
+ring homomorphism $f:R\to S$, applied entrywise. The subtype `UnimodularRow R` consists of the pairs
+$v\in R\times R$ satisfying this predicate, and `unimodularRowSetoid R` equips it with the
+equivalence relation $v\sim w$ iff there is a unit $u\in R^\times$ with $u\,v_1=w_1$ and
+$u\,v_2=w_2$; reflexivity, symmetry and transitivity come from $1$, $u^{-1}$ and products of units.
+The projective line `ProjectiveLine R` is defined to be the quotient of `UnimodularRow R` by this
+relation, so $\mathbb{P}^1(R)$ is here the set of unimodular rows up to scaling by $R^\times$, a
+quotient of a chosen model by a congruence rather than an abstractly characterised object. It is
+finite whenever $R$ is. Functoriality is provided by `ProjectiveLine.map f`, induced by entrywise
+application of a ring homomorphism $f:R\to S$ (well defined because $f$ carries units to units),
+with the expected description of its value on the class of a unimodular row.
+
+The second section defines `borel R`, the subgroup of $\mathrm{SL}_2(R)$ whose carrier is the set of
+matrices $M$ with $M_{1,0}=0$ (indices in `Fin 2`), i.e. the upper-triangular matrices of
+determinant $1$; closure under multiplication and inversion is checked from the explicit formulae
+for $2\times 2$ products and for the inverse of an element of $\mathrm{SL}_2$. The membership
+criterion `mem_borel_iff` states that $A\in$ `borel R` is exactly the condition $A_{1,0}=0$.
+
+**Relation to Mathlib.** Mathlib's `Projectivization` is built for vector spaces over a division
+ring; the projective line of a commutative ring defined here is the project's own construction, as
+is the Borel subgroup of `Matrix.SpecialLinearGroup (Fin 2) R`.
+
+**Where it is used.** These definitions serve the computation of the index of $\Gamma_0(N)$: left
+cosets of `borel` in $\mathrm{SL}_2(R)$ correspond to points of $\mathbb{P}^1(R)$ through the class
+of the first column, and for $R=\mathbb{Z}/N$ one has $\#\mathbb{P}^1(\mathbb{Z}/N)=\psi(N)$, with
+$\Gamma_0(N)$ the preimage of `borel (ZMod N)` under reduction.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace ModularCurve
+
+open Matrix
+open scoped MatrixGroups
+
+section ProjectiveLine
+
+variable {R S : Type*} [CommRing R] [CommRing S]
+
+def IsUnimodularRow (a c : R) : Prop :=
+  ∃ x y : R, x * a + y * c = 1
+
+theorem isUnimodularRow_one_left (t : R) : IsUnimodularRow (1 : R) t :=
+  ⟨1, 0, by simp⟩
+
+theorem isUnimodularRow_one_right (m : R) : IsUnimodularRow m (1 : R) :=
+  ⟨0, 1, by simp⟩
+
+theorem IsUnimodularRow.map (f : R →+* S) {a c : R} (h : IsUnimodularRow a c) :
+    IsUnimodularRow (f a) (f c) := by
+  obtain ⟨x, y, hxy⟩ := h
+  exact ⟨f x, f y, by rw [← map_mul, ← map_mul, ← map_add, hxy, map_one]⟩
+
+abbrev UnimodularRow (R : Type*) [CommRing R] := { v : R × R // IsUnimodularRow v.1 v.2 }
+
+instance unimodularRowSetoid (R : Type*) [CommRing R] : Setoid (UnimodularRow R) where
+  r v w := ∃ u : Rˣ, (u : R) * v.1.1 = w.1.1 ∧ (u : R) * v.1.2 = w.1.2
+  iseqv := by
+    refine ⟨fun v => ⟨1, by simp, by simp⟩, ?_, ?_⟩
+    · rintro v w ⟨u, h1, h2⟩
+      exact ⟨u⁻¹, by rw [← h1, Units.inv_mul_cancel_left],
+        by rw [← h2, Units.inv_mul_cancel_left]⟩
+    · rintro v w z ⟨u, h1, h2⟩ ⟨u', h1', h2'⟩
+      exact ⟨u' * u, by rw [Units.val_mul, mul_assoc, h1, h1'],
+        by rw [Units.val_mul, mul_assoc, h2, h2']⟩
+
+def ProjectiveLine (R : Type*) [CommRing R] : Type _ :=
+  Quotient (unimodularRowSetoid R)
+
+instance instFiniteProjectiveLine [Finite R] : Finite (ProjectiveLine R) :=
+  Quotient.finite _
+
+def ProjectiveLine.map (f : R →+* S) : ProjectiveLine R → ProjectiveLine S :=
+  Quotient.lift (fun v => (⟦⟨(f v.1.1, f v.1.2), v.2.map f⟩⟧ : ProjectiveLine S)) <| by
+    rintro v w ⟨u, h1, h2⟩
+    refine Quotient.sound ⟨⟨f u, f ↑u⁻¹, ?_, ?_⟩, ?_, ?_⟩
+    · rw [← map_mul, Units.mul_inv, map_one]
+    · rw [← map_mul, Units.inv_mul, map_one]
+    · change f ↑u * f v.1.1 = f w.1.1
+      rw [← map_mul, h1]
+    · change f ↑u * f v.1.2 = f w.1.2
+      rw [← map_mul, h2]
+
+@[simp]
+theorem ProjectiveLine.map_mk (f : R →+* S) (v : UnimodularRow R) :
+    ProjectiveLine.map f ⟦v⟧ = ⟦⟨(f v.1.1, f v.1.2), v.2.map f⟩⟧ :=
+  rfl
+
+end ProjectiveLine
+
+section Borel
+
+variable {R : Type*} [CommRing R]
+
+def borel (R : Type*) [CommRing R] : Subgroup (SpecialLinearGroup (Fin 2) R) where
+  carrier := { M | M.1 1 0 = 0 }
+  one_mem' := by
+    change (1 : SpecialLinearGroup (Fin 2) R).1 1 0 = 0
+    simp
+  mul_mem' := by
+    intro A B hA hB
+    simp only [Set.mem_ofPred_eq] at *
+    change (A * B).1 1 0 = 0
+    rw [SpecialLinearGroup.coe_mul, (Matrix.two_mul_expl A.1 B.1).2.2.1, hA, hB]
+    ring
+  inv_mem' := by
+    intro A hA
+    simp only [Set.mem_ofPred_eq] at *
+    change (A⁻¹).1 1 0 = 0
+    rw [SpecialLinearGroup.SL2_inv_expl A]
+    simp only [Matrix.cons_val_one, Matrix.cons_val_zero, neg_eq_zero]
+    exact hA
+
+theorem mem_borel_iff {A : SpecialLinearGroup (Fin 2) R} : A ∈ borel R ↔ A.1 1 0 = 0 :=
+  Iff.rfl
+
+end Borel
+
+end ModularCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_QAdicPlace.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_QAdicPlace.lean
new file mode 100644
index 0000000000..b1806bfdc6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_QAdicPlace.lean
@@ -0,0 +1,440 @@
+/-
+Based on Prove2Me node ModularCurve_QAdicPlace
+(0bda3f58-0e08-5520-ba0b-617dc9e333ca) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+/-!
+# The q-adic place at infinity; cusps of modular function fields
+
+Definition: `ModularCurve_QAdicPlace` (`0bda3f58-0e08-5520-ba0b-617dc9e333ca`), by Claude,
+2026-09-05.
+
+Fix a field $L$ and an intermediate field $F$ of $L((q))/L$. `qSeriesBar L F f` is just the
+$q$-expansion of $f \in F$, i.e. the coercion of $f$ into `LaurentSeries L`; a dozen lemmas record
+that this coercion is a field homomorphism commuting with $0,1,+,-,\cdot,{}^{-1},/$, natural and
+integer powers, that it is injective at $0$, and that it sends $\mathrm{algebraMap}\,L\,F\,c$ to the
+Hahn series `HahnSeries.single 0 c`. `qIntegersBar L F` is the `ValuationSubring` of $F$ consisting
+of those $f$ whose $q$-expansion has order $\ge 0$ (order of the zero series being $0$); membership
+is definitionally this inequality, and a nonzero element is a unit exactly when its $q$-order is
+$0$. The remaining work is conditional on a witness $j \in F$ whose $q$-expansion has order exactly
+$-1$: then $j \ne 0$, $j \notin$ `qIntegersBar L F` (so this subring is not all of $F$),
+`uniformizerBar hj` is $j^{-1}$, of order $1$ and irreducible, and `qIntegersBar L F` is a principal
+ideal ring (proved by exhibiting the unit-times-power-of-irreducible factorisation, hence a discrete
+valuation ring). Consequently `qInftyPlaceBar L F h`, for `h : ∃ j : F, (qSeriesBar L F j).order =
+-1`, is a term of the project's structure [`AlgebraicCurve.Place L
+F`](../def/AlgebraicCurve_DivisorClassGroup.html#L22): valuation subring `qIntegersBar L F`,
+together with the three proof fields that it contains the image of $L$, is proper, and is a
+principal ideal ring. `qInftyPlaceRat F h` is the same object retyped for $L = \mathbb{Q}$ using the
+canonical $\mathbb{Q}$-algebra structure on $F$ (the two algebra structures agree, but only up to
+`Subsingleton.elim`). Specialising to the modular function fields of the $X_0$ module with witness
+$j(q)$ — `order_jq : jq.order = -1` is proved here — gives `cuspInfty N` and `cuspInftyFull N`.
+Finally `IsCusp j v` is defined as $j \notin v$.toValuationSubring, i.e. $v$ is a pole of $j$, and
+the four exhibits show the places just built are cusps for the corresponding $j$. No theorem about
+these places (order formula, residue degree, counting or classification of cusps) is asserted here.
+
+**Relation to Mathlib.** Built on Mathlib's `LaurentSeries`/`HahnSeries.order` and
+`ValuationSubring`; the helper lemmas `order_mul/inv/pow/zpow/div_of_ne_zero_bar` are convenience
+forms of Mathlib's Hahn-series order lemmas for Laurent series over a field. The target structure
+[`AlgebraicCurve.Place`](../def/AlgebraicCurve_DivisorClassGroup.html#L22) and the predicate
+`IsCusp` are the project's own, Mathlib having no such packaged notion of a place of a function
+field with a discrete-valuation-ring condition as a structure field.
+
+**Where it is used.** These definitions pin down what "the cusp $\infty$" of $X_0(N)$ (and of the
+full modular function field) means for the later statements about cuspidal divisors, the Eisenstein
+ideal and the Jacobian $J_0(N)$ that enter the Frey curve–Ribet–Wiles argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open IntermediateField HahnSeries AlgebraicCurve
+
+namespace ModularCurve
+
+theorem order_jq : jq.order = -1 := by
+  refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero (by
+    rw [coeff_jq_neg_one]; exact one_ne_zero)) ?_
+  by_contra! h
+  exact HahnSeries.coeff_order_eq_zero.not.mpr jq_ne_zero (coeff_jq_of_lt h)
+
+variable (L : Type*) [Field L]
+
+section OrderArithBar
+
+variable {L}
+
+theorem order_mul_of_ne_zero_bar {f g : LaurentSeries L} (hf : f ≠ 0) (hg : g ≠ 0) :
+    (f * g).order = f.order + g.order :=
+  HahnSeries.order_mul_of_ne_zero
+    (mul_ne_zero (HahnSeries.leadingCoeff_ne_zero.mpr hf)
+      (HahnSeries.leadingCoeff_ne_zero.mpr hg))
+
+theorem order_inv_of_ne_zero_bar {f : LaurentSeries L} (hf : f ≠ 0) :
+    (f⁻¹).order = -f.order := by
+  have h := order_mul_of_ne_zero_bar hf (inv_ne_zero hf)
+  rw [mul_inv_cancel₀ hf, HahnSeries.order_one] at h
+  omega
+
+theorem order_pow_of_ne_zero_bar {f : LaurentSeries L} (hf : f ≠ 0) (n : ℕ) :
+    (f ^ n).order = n * f.order := by
+  induction n with
+  | zero => simp [HahnSeries.order_one]
+  | succ k ih =>
+      rw [pow_succ, order_mul_of_ne_zero_bar (pow_ne_zero k hf) hf, ih]
+      push_cast
+      ring
+
+theorem order_zpow_of_ne_zero_bar {f : LaurentSeries L} (hf : f ≠ 0) (n : ℤ) :
+    (f ^ n).order = n * f.order := by
+  rcases Int.natAbs_eq n with h | h
+  · rw [h, zpow_natCast, order_pow_of_ne_zero_bar hf]
+  · rw [h, zpow_neg, zpow_natCast,
+      order_inv_of_ne_zero_bar (pow_ne_zero _ hf), order_pow_of_ne_zero_bar hf]
+    ring
+
+theorem order_div_of_ne_zero_bar {f g : LaurentSeries L} (hf : f ≠ 0) (hg : g ≠ 0) :
+    (f / g).order = f.order - g.order := by
+  rw [div_eq_mul_inv, order_mul_of_ne_zero_bar hf (inv_ne_zero hg),
+    order_inv_of_ne_zero_bar hg]
+  ring
+
+end OrderArithBar
+
+section QSeriesBar
+
+variable (F : IntermediateField L (LaurentSeries L))
+
+def qSeriesBar (f : F) : LaurentSeries L := (f : LaurentSeries L)
+
+variable {L F}
+
+@[simp] theorem qSeriesBar_zero : qSeriesBar L F 0 = 0 := rfl
+
+@[simp] theorem qSeriesBar_one : qSeriesBar L F 1 = 1 := rfl
+
+@[simp] theorem qSeriesBar_mul (f g : F) :
+    qSeriesBar L F (f * g) = qSeriesBar L F f * qSeriesBar L F g := rfl
+
+@[simp] theorem qSeriesBar_add (f g : F) :
+    qSeriesBar L F (f + g) = qSeriesBar L F f + qSeriesBar L F g := rfl
+
+@[simp] theorem qSeriesBar_neg (f : F) : qSeriesBar L F (-f) = -(qSeriesBar L F f) := rfl
+
+@[simp] theorem qSeriesBar_sub (f g : F) :
+    qSeriesBar L F (f - g) = qSeriesBar L F f - qSeriesBar L F g := rfl
+
+@[simp] theorem qSeriesBar_inv (f : F) : qSeriesBar L F f⁻¹ = (qSeriesBar L F f)⁻¹ := rfl
+
+@[simp] theorem qSeriesBar_div (f g : F) :
+    qSeriesBar L F (f / g) = qSeriesBar L F f / qSeriesBar L F g := rfl
+
+@[simp] theorem qSeriesBar_pow (f : F) (n : ℕ) :
+    qSeriesBar L F (f ^ n) = (qSeriesBar L F f) ^ n := by
+  induction n with
+  | zero => simp
+  | succ k ih => rw [pow_succ, pow_succ, qSeriesBar_mul, ih]
+
+theorem qSeriesBar_zpow (f : F) (n : ℤ) :
+    qSeriesBar L F (f ^ n) = (qSeriesBar L F f) ^ n := by
+  change ((f ^ n : F) : LaurentSeries L) = ((f : LaurentSeries L)) ^ n
+  rw [← IntermediateField.algebraMap_apply (x := f ^ n),
+    ← IntermediateField.algebraMap_apply (x := f), map_zpow₀]
+
+@[simp] theorem qSeriesBar_eq_zero_iff {f : F} : qSeriesBar L F f = 0 ↔ f = 0 :=
+  ZeroMemClass.coe_eq_zero
+
+theorem qSeriesBar_ne_zero {f : F} (hf : f ≠ 0) : qSeriesBar L F f ≠ 0 :=
+  fun h => hf (qSeriesBar_eq_zero_iff.mp h)
+
+theorem qSeriesBar_algebraMap (c : L) :
+    qSeriesBar L F (algebraMap L F c) = HahnSeries.single (0 : ℤ) c := by
+  have h : algebraMap L (LaurentSeries L) c
+      = algebraMap F (LaurentSeries L) (algebraMap L F c) :=
+    IsScalarTower.algebraMap_apply L F (LaurentSeries L) c
+  rw [IntermediateField.algebraMap_apply] at h
+  change ((algebraMap L F c : F) : LaurentSeries L) = _
+  rw [← h, HahnSeries.algebraMap_apply', show algebraMap L (PowerSeries L) c = PowerSeries.C c by
+    simp,
+    HahnSeries.ofPowerSeries_C]
+  rfl
+
+theorem order_qSeriesBar_mul {f g : F} (hf : f ≠ 0) (hg : g ≠ 0) :
+    (qSeriesBar L F (f * g)).order = (qSeriesBar L F f).order + (qSeriesBar L F g).order := by
+  rw [qSeriesBar_mul]
+  exact order_mul_of_ne_zero_bar (qSeriesBar_ne_zero hf) (qSeriesBar_ne_zero hg)
+
+end QSeriesBar
+
+section QAdicPlaceBar
+
+variable (F : IntermediateField L (LaurentSeries L))
+
+def qIntegersBar : ValuationSubring F where
+  carrier := {f : F | 0 ≤ (qSeriesBar L F f).order}
+  zero_mem' := by
+    simp only [Set.mem_ofPred_eq, qSeriesBar_zero, HahnSeries.order_zero, le_refl]
+  one_mem' := by
+    simp only [Set.mem_ofPred_eq, qSeriesBar_one]
+    rw [HahnSeries.order_one]
+  add_mem' := by
+    intro a b ha hb
+    simp only [Set.mem_ofPred_eq] at ha hb ⊢
+    rcases eq_or_ne (a + b) 0 with h0 | h0
+    · simp only [h0, qSeriesBar_zero, HahnSeries.order_zero, le_refl]
+    · have h := HahnSeries.min_order_le_order_add (x := qSeriesBar L F a)
+        (y := qSeriesBar L F b) (by rw [← qSeriesBar_add]; exact qSeriesBar_ne_zero h0)
+      rw [qSeriesBar_add]
+      exact le_trans (le_min ha hb) h
+  mul_mem' := by
+    intro a b ha hb
+    simp only [Set.mem_ofPred_eq] at ha hb ⊢
+    rcases eq_or_ne a 0 with rfl | ha0
+    · simp only [zero_mul, qSeriesBar_zero, HahnSeries.order_zero, le_refl]
+    rcases eq_or_ne b 0 with rfl | hb0
+    · simp only [mul_zero, qSeriesBar_zero, HahnSeries.order_zero, le_refl]
+    rw [order_qSeriesBar_mul ha0 hb0]
+    omega
+  neg_mem' := by
+    intro a ha
+    simp only [Set.mem_ofPred_eq] at ha ⊢
+    rw [qSeriesBar_neg, HahnSeries.order_neg]
+    exact ha
+  mem_or_inv_mem' := by
+    intro f
+    simp only [Set.mem_ofPred_eq]
+    rcases eq_or_ne f 0 with rfl | hf0
+    · left
+      simp only [qSeriesBar_zero, HahnSeries.order_zero, le_refl]
+    rcases lt_or_ge (qSeriesBar L F f).order 0 with h | h
+    · right
+      rw [qSeriesBar_inv, order_inv_of_ne_zero_bar (qSeriesBar_ne_zero hf0)]
+      omega
+    · exact Or.inl h
+
+variable {F}
+
+theorem mem_qIntegersBar_iff {f : F} :
+    f ∈ qIntegersBar L F ↔ 0 ≤ (qSeriesBar L F f).order := Iff.rfl
+
+variable {L} in
+theorem isUnit_qIntegersBar_iff {x : qIntegersBar L F} (hx : (x : F) ≠ 0) :
+    IsUnit x ↔ (qSeriesBar L F (x : F)).order = 0 := by
+  constructor
+  · rintro h
+    obtain ⟨b, hb⟩ := isUnit_iff_exists_inv.mp h
+    have hb' : (x : F) * (b : F) = 1 := by
+      have := congrArg (fun z : qIntegersBar L F => (z : F)) hb
+      simpa using this
+    have hbne : (b : F) ≠ 0 := by
+      intro h0
+      rw [h0, mul_zero] at hb'
+      exact zero_ne_one hb'
+    have hsum : (qSeriesBar L F (x : F)).order + (qSeriesBar L F (b : F)).order = 0 := by
+      rw [← order_qSeriesBar_mul hx hbne, hb', qSeriesBar_one, HahnSeries.order_one]
+    have h1 : (0 : ℤ) ≤ (qSeriesBar L F (x : F)).order := x.2
+    have h2 : (0 : ℤ) ≤ (qSeriesBar L F (b : F)).order := b.2
+    omega
+  · intro h0
+    have hinv : (x : F)⁻¹ ∈ qIntegersBar L F := by
+      rw [mem_qIntegersBar_iff, qSeriesBar_inv,
+        order_inv_of_ne_zero_bar (qSeriesBar_ne_zero hx)]
+      omega
+    refine isUnit_iff_exists_inv.mpr ⟨⟨(x : F)⁻¹, hinv⟩, ?_⟩
+    refine Subtype.ext ?_
+    push_cast
+    exact mul_inv_cancel₀ hx
+
+section Witness
+
+variable {L} {j : F} (hj : (qSeriesBar L F j).order = -1)
+include hj
+
+theorem ne_zero_of_order_eq_neg_one : j ≠ 0 := by
+  rintro rfl
+  rw [qSeriesBar_zero, HahnSeries.order_zero] at hj
+  omega
+
+theorem notMem_qIntegersBar_of_order_eq_neg_one : j ∉ qIntegersBar L F := by
+  rw [mem_qIntegersBar_iff, hj]
+  omega
+
+theorem qIntegersBar_ne_top : qIntegersBar L F ≠ ⊤ := fun h =>
+  notMem_qIntegersBar_of_order_eq_neg_one hj (h ▸ ValuationSubring.mem_top _)
+
+theorem order_inv_of_order_eq_neg_one : (qSeriesBar L F j⁻¹).order = 1 := by
+  rw [qSeriesBar_inv, order_inv_of_ne_zero_bar (qSeriesBar_ne_zero (ne_zero_of_order_eq_neg_one
+    hj)), hj]
+  omega
+
+theorem inv_mem_qIntegersBar_of_order_eq_neg_one : j⁻¹ ∈ qIntegersBar L F := by
+  rw [mem_qIntegersBar_iff, order_inv_of_order_eq_neg_one hj]
+  omega
+
+def uniformizerBar : qIntegersBar L F :=
+  ⟨j⁻¹, inv_mem_qIntegersBar_of_order_eq_neg_one hj⟩
+
+@[simp]
+theorem coe_uniformizerBar : ((uniformizerBar hj : qIntegersBar L F) : F) = j⁻¹ := rfl
+
+theorem uniformizerBar_ne_zero : ((uniformizerBar hj : qIntegersBar L F) : F) ≠ 0 :=
+  inv_ne_zero (ne_zero_of_order_eq_neg_one hj)
+
+theorem irreducible_uniformizerBar : Irreducible (uniformizerBar hj) := by
+  constructor
+  · rw [isUnit_qIntegersBar_iff (uniformizerBar_ne_zero hj), coe_uniformizerBar,
+      order_inv_of_order_eq_neg_one hj]
+    omega
+  · rintro a b hab
+    have hab' : j⁻¹ = (a : F) * (b : F) := by
+      have := congrArg (fun z : qIntegersBar L F => (z : F)) hab
+      simpa using this
+    have hj0 : j⁻¹ ≠ 0 := inv_ne_zero (ne_zero_of_order_eq_neg_one hj)
+    have ha0 : (a : F) ≠ 0 := by
+      intro h
+      exact hj0 (by rw [hab', h, zero_mul])
+    have hb0 : (b : F) ≠ 0 := by
+      intro h
+      exact hj0 (by rw [hab', h, mul_zero])
+    have hsum : (qSeriesBar L F (a : F)).order + (qSeriesBar L F (b : F)).order = 1 := by
+      rw [← order_qSeriesBar_mul ha0 hb0, ← hab', order_inv_of_order_eq_neg_one hj]
+    have ha' : (0 : ℤ) ≤ (qSeriesBar L F (a : F)).order := a.2
+    have hb' : (0 : ℤ) ≤ (qSeriesBar L F (b : F)).order := b.2
+    rcases eq_or_lt_of_le ha' with ha0' | hapos
+    · exact Or.inl ((isUnit_qIntegersBar_iff ha0).mpr ha0'.symm)
+    rcases eq_or_lt_of_le hb' with hb0' | hbpos
+    · exact Or.inr ((isUnit_qIntegersBar_iff hb0).mpr hb0'.symm)
+    omega
+
+theorem qIntegersBar_isPrincipalIdealRing : IsPrincipalIdealRing (qIntegersBar L F) := by
+  refine (IsDiscreteValuationRing.ofHasUnitMulPowIrreducibleFactorization
+    ⟨uniformizerBar hj, irreducible_uniformizerBar hj, ?_⟩).toIsPrincipalIdealRing
+  rintro x hx
+  have hf : (x : F) ≠ 0 := fun h => hx (Subtype.ext h)
+  have hmnonneg : (0 : ℤ) ≤ (qSeriesBar L F (x : F)).order := x.2
+  set n : ℕ := (qSeriesBar L F (x : F)).order.toNat with hn
+  have hmn : (n : ℤ) = (qSeriesBar L F (x : F)).order := Int.toNat_of_nonneg hmnonneg
+  refine ⟨n, ?_⟩
+  have hπ0 : j⁻¹ ≠ 0 := inv_ne_zero (ne_zero_of_order_eq_neg_one hj)
+  have hπn : j⁻¹ ^ n ≠ 0 := pow_ne_zero _ hπ0
+  have hdiv0 : (x : F) / j⁻¹ ^ n ≠ 0 := div_ne_zero hf hπn
+  have hπorder : (qSeriesBar L F (j⁻¹ ^ n)).order = n := by
+    rw [qSeriesBar_pow, order_pow_of_ne_zero_bar (qSeriesBar_ne_zero hπ0),
+      order_inv_of_order_eq_neg_one hj, mul_one]
+  have hu0 : (qSeriesBar L F ((x : F) / j⁻¹ ^ n)).order = 0 := by
+    rw [div_eq_mul_inv, order_qSeriesBar_mul hf (inv_ne_zero hπn), qSeriesBar_inv,
+      order_inv_of_ne_zero_bar (qSeriesBar_ne_zero hπn), hπorder, ← hmn]
+    ring
+  have humem : (x : F) / j⁻¹ ^ n ∈ qIntegersBar L F := by
+    rw [mem_qIntegersBar_iff, hu0]
+  have hu : IsUnit (⟨(x : F) / j⁻¹ ^ n, humem⟩ : qIntegersBar L F) :=
+    (isUnit_qIntegersBar_iff hdiv0).mpr hu0
+  refine ⟨hu.unit, ?_⟩
+  refine Subtype.ext ?_
+  have hcoe : ((hu.unit : qIntegersBar L F) : F) = (x : F) / j⁻¹ ^ n := by
+    rw [IsUnit.unit_spec]
+  push_cast
+  rw [hcoe, mul_comm, coe_uniformizerBar, div_mul_cancel₀]
+  exact hπn
+
+end Witness
+
+variable (F) in
+def qInftyPlaceBar (h : ∃ j : F, (qSeriesBar L F j).order = -1) : Place L F where
+  toValuationSubring := qIntegersBar L F
+  algebraMap_mem' := fun a => by
+    rw [mem_qIntegersBar_iff, qSeriesBar_algebraMap]
+    rcases eq_or_ne a 0 with rfl | ha
+    · simp only [HahnSeries.single_eq_zero, HahnSeries.order_zero, le_refl]
+    · rw [HahnSeries.order_single ha]
+  ne_top' := qIntegersBar_ne_top h.choose_spec
+  isPrincipalIdealRing' := qIntegersBar_isPrincipalIdealRing h.choose_spec
+
+@[simp]
+theorem qInftyPlaceBar_toValuationSubring (h : ∃ j : F, (qSeriesBar L F j).order = -1) :
+    (qInftyPlaceBar L F h).toValuationSubring = qIntegersBar L F := rfl
+
+end QAdicPlaceBar
+
+section RationalTwin
+
+variable (F : IntermediateField ℚ (LaurentSeries ℚ))
+
+def qInftyPlaceRat (h : ∃ j : F, (qSeriesBar ℚ F j).order = -1) : Place ℚ F where
+  toValuationSubring := qIntegersBar ℚ F
+  algebraMap_mem' a := by
+    have h' := @Place.algebraMap_mem' ℚ F _ _ (SubalgebraClass.toAlgebra F) (qInftyPlaceBar ℚ F h) a
+    have hi : (DivisionRing.toRatAlgebra : Algebra ℚ F) = SubalgebraClass.toAlgebra F :=
+      Subsingleton.elim _ _
+    rw [hi]
+    exact h'
+  ne_top' := qIntegersBar_ne_top h.choose_spec
+  isPrincipalIdealRing' := qIntegersBar_isPrincipalIdealRing h.choose_spec
+
+@[simp] theorem qInftyPlaceRat_toValuationSubring (h : ∃ j : F, (qSeriesBar ℚ F j).order = -1) :
+    (qInftyPlaceRat F h).toValuationSubring = qIntegersBar ℚ F := rfl
+
+variable (N : ℕ) [NeZero N]
+
+def cuspInfty : Place ℚ (modularFunctionField N) :=
+  qInftyPlaceRat _ ⟨⟨jq, jq_mem N⟩, order_jq⟩
+
+@[simp] theorem cuspInfty_toValuationSubring :
+    (cuspInfty N).toValuationSubring = qIntegersBar ℚ (modularFunctionField N) := rfl
+
+theorem jq_mem_full : jq ∈ modularFunctionFieldFull N :=
+  modularFunctionField_le_full N (jq_mem N)
+
+def cuspInftyFull : Place ℚ (modularFunctionFieldFull N) :=
+  qInftyPlaceRat _ ⟨⟨jq, jq_mem_full N⟩, order_jq⟩
+
+@[simp] theorem cuspInftyFull_toValuationSubring :
+    (cuspInftyFull N).toValuationSubring = qIntegersBar ℚ (modularFunctionFieldFull N) := rfl
+
+end RationalTwin
+
+section IsCusp
+
+variable {K : Type*} {E : Type*} [Field K] [Field E] [Algebra K E]
+
+def IsCusp (j : E) (v : Place K E) : Prop :=
+  j ∉ v.toValuationSubring
+
+theorem isCusp_iff (j : E) (v : Place K E) : IsCusp j v ↔ j ∉ v.toValuationSubring := Iff.rfl
+
+end IsCusp
+
+theorem isCusp_qInftyPlaceBar {F : IntermediateField L (LaurentSeries L)}
+    (h : ∃ j : F, (qSeriesBar L F j).order = -1)
+    {j : F} (hj : (qSeriesBar L F j).order = -1) : IsCusp j (qInftyPlaceBar L F h) :=
+  notMem_qIntegersBar_of_order_eq_neg_one hj
+
+theorem isCusp_qInftyPlaceRat {F : IntermediateField ℚ (LaurentSeries ℚ)}
+    (h : ∃ j : F, (qSeriesBar ℚ F j).order = -1)
+    {j : F} (hj : (qSeriesBar ℚ F j).order = -1) : IsCusp j (qInftyPlaceRat F h) :=
+  notMem_qIntegersBar_of_order_eq_neg_one hj
+
+theorem isCusp_cuspInfty (N : ℕ) [NeZero N] :
+    IsCusp (⟨jq, jq_mem N⟩ : modularFunctionField N) (cuspInfty N) :=
+  notMem_qIntegersBar_of_order_eq_neg_one order_jq
+
+theorem isCusp_cuspInftyFull (N : ℕ) [NeZero N] :
+    IsCusp (⟨jq, jq_mem_full N⟩ : modularFunctionFieldFull N) (cuspInftyFull N) :=
+  notMem_qIntegersBar_of_order_eq_neg_one order_jq
+
+end ModularCurve
+
+end
+
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_QAdicPlaceMod.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_QAdicPlaceMod.lean
new file mode 100644
index 0000000000..ca897cdea6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_QAdicPlaceMod.lean
@@ -0,0 +1,411 @@
+/-
+Based on Prove2Me node ModularCurve_QAdicPlaceMod
+(e1c47b72-223f-5a93-9105-e270f48ac033) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Field.ZMod
+public import Mathlib.RingTheory.Henselian
+public import Mathlib.RingTheory.RegularLocalRing.Defs
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlace
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_neg_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_pow_of_lt
+
+/-!
+# The cusp at infinity as a place over any coefficient field
+
+Definition: `ModularCurve_QAdicPlaceMod` (`e1c47b72-223f-5a93-9105-e270f48ac033`), by Claude,
+2026-09-05.
+
+Fix a field $K$. The module works inside $K((q))$, with $\bar j =$ `jqModC K` the Laurent series
+$q^{-1}\cdot\mathrm{ofPowerSeries}(\mathrm{jNum}_K)$, where $\mathrm{jNum}$ is the integral power
+series $E_4^3\cdot(\eta\text{-product})^{-24}$ with constant term $1$, base-changed to $K$; `jqNModC
+K N` is its image under `qExpand K N` (the ring endomorphism $q\mapsto q^N$ of Laurent series), and
+`modularFunctionFieldC K N` is the intermediate field $K(\bar j,\bar j_N)\subseteq K((q))$. First
+come order computations: $\bar j\neq 0$ and $\mathrm{ord}_q(\bar j)=-1$; for any nonzero $f$ and any
+$p\neq 0$, $\mathrm{ord}_q(\mathrm{qExpand}\,p\,f)=p\,\mathrm{ord}_q(f)$; hence $\bar j_N\neq0$ and
+$\mathrm{ord}_q(\bar j_N)=-N$.
+
+The main construction is `qInftyPlaceMod`: for an intermediate field $F$ of $K((q))/K$ containing
+$\bar j$, it is the place of $F$ over $K$ (a valuation subring of $F$ containing the image of $K$,
+proper, and a principal ideal ring) whose valuation subring is `qIntegersBar K F`, the set of $f\in
+F$ whose underlying Laurent series has nonnegative order. Properness comes from $\bar j\notin$
+`qIntegersBar K F`; principality is obtained by exhibiting `uniformizerMod`, the element $\bar
+j^{-1}$ of order $1$, as an irreducible element for which every nonzero non-unit is a unit times a
+power, so the subring is a discrete valuation ring. Further lemmas identify the associated order
+function, $\mathrm{ord}_{v}(f)=\mathrm{ord}_q(f)$ for all $f\in F$, show that the constant
+coefficient realises every residue class (each $f$ of nonnegative order is congruent to its
+$q^0$-coefficient modulo the maximal ideal), and conclude $\deg v=[\,\kappa(v):K\,]=1$.
+
+Specialising to $F=K(\bar j,\bar j_N)$ gives `cuspInftyGeom K N`, with $\mathrm{ord}_\infty(\bar
+j)=-1$, $\mathrm{ord}_\infty(\bar j_N)=-N$ and $\deg_\infty=1$, and in particular the type of places
+of this function field is nonempty. Two final lemmas record the instance $K=\overline{\mathbb F}_2$,
+$N=3$: there $\mathrm{ord}_\infty(\bar j)=-1$, hence is nonzero.
+
+**Relation to Mathlib.** Built on Mathlib's `LaurentSeries`/`HahnSeries.order`, `ValuationSubring`
+and `IsDiscreteValuationRing`, but the notions used here — the `Place` structure of a function field
+over a base field (valuation subring containing the base, proper, principal), the subring
+`qIntegersBar` of series of nonnegative order, and the $q$-expansion model of the modular function
+field — are the project's own; this is the arbitrary-coefficient-field counterpart of the
+characteristic-zero construction `qInftyPlaceBar`, with `jq` over $\mathbb{Q}$ replaced by `jqModC
+K`.
+
+**Where it is used.** These places supply the cusp $\infty$ on the geometric fibres of the modular
+curves of level $N$, with its order function and the fact that it is $K$-rational of degree one,
+which is what the divisor-theoretic arguments about the special fibre and its Hecke action require
+as input.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open HahnSeries AlgebraicCurve
+
+namespace ModularCurve
+
+variable (K : Type*) [Field K]
+
+section OrderJqModC
+
+theorem jqModC_ne_zero_def : jqModC K ≠ 0 := by
+  intro h
+  have h1 : (jqModC K).coeff (-1 : ℤ) = 1 := coeff_jqModC_neg_one K
+  rw [h, HahnSeries.coeff_zero] at h1
+  exact zero_ne_one h1
+
+theorem order_jqModC_def : (jqModC K).order = -1 := by
+  refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero ?_) ?_
+  · rw [coeff_jqModC_neg_one]
+    exact one_ne_zero
+  · by_contra hlt
+    rw [not_le] at hlt
+    refine HahnSeries.coeff_order_eq_zero.not.mpr (jqModC_ne_zero_def K) ?_
+    have h := coeff_jqModC_pow_of_lt K (b := 1) (m := (jqModC K).order)
+      (by simpa using hlt)
+    simpa using h
+
+theorem order_qExpandC (p : ℕ) [NeZero p] {f : LaurentSeries K} (hf : f ≠ 0) :
+    (qExpand K p f).order = (p : ℤ) * f.order := by
+  have hp : (0 : ℤ) < (p : ℤ) := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne p)
+  have hcoeff : (qExpand K p f).coeff ((p : ℤ) * f.order) = f.coeff f.order := by
+    rw [qExpand_coeff_mul]
+  have hcoeff' : (qExpand K p f).coeff ((p : ℤ) * f.order) ≠ 0 := by
+    rw [hcoeff]
+    exact HahnSeries.coeff_order_eq_zero.not.mpr hf
+  have hne : qExpand K p f ≠ 0 := HahnSeries.ne_zero_of_coeff_ne_zero hcoeff'
+  have hbelow : ∀ k : ℤ, k < (p : ℤ) * f.order → (qExpand K p f).coeff k = 0 := by
+    intro k hk
+    by_cases hdvd : (p : ℤ) ∣ k
+    · obtain ⟨j, rfl⟩ := hdvd
+      rw [qExpand_coeff_mul]
+      exact HahnSeries.coeff_eq_zero_of_lt_order (lt_of_mul_lt_mul_left hk hp.le)
+    · exact qExpand_coeff_of_not_dvd p f hdvd
+  refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero hcoeff') ?_
+  by_contra hlt
+  rw [not_le] at hlt
+  exact hne (HahnSeries.coeff_order_eq_zero.mp (hbelow _ hlt))
+
+theorem jqNModC_ne_zero (N : ℕ) [NeZero N] : jqNModC K N ≠ 0 := by
+  intro h
+  have := order_qExpandC K N (jqModC_ne_zero_def K)
+  rw [show qExpand K N (jqModC K) = jqNModC K N from rfl, h, HahnSeries.order_zero,
+    order_jqModC_def] at this
+  have hN : (N : ℤ) ≠ 0 := by exact_mod_cast NeZero.ne N
+  omega
+
+theorem order_jqNModC (N : ℕ) [NeZero N] : (jqNModC K N).order = -(N : ℤ) := by
+  rw [show jqNModC K N = qExpand K N (jqModC K) from rfl,
+    order_qExpandC K N (jqModC_ne_zero_def K), order_jqModC_def]
+  ring
+
+end OrderJqModC
+
+section QAdicPlaceMod
+
+variable (F : IntermediateField K (LaurentSeries K))
+
+variable {F} in
+def jModElt (hF : jqModC K ∈ F) : F := ⟨jqModC K, hF⟩
+
+variable {F} in
+@[simp]
+theorem qSeriesBar_jModElt (hF : jqModC K ∈ F) :
+    qSeriesBar K F (jModElt K hF) = jqModC K := rfl
+
+variable {F} in
+theorem jModElt_ne_zero (hF : jqModC K ∈ F) : jModElt K hF ≠ 0 := by
+  intro h
+  exact jqModC_ne_zero_def K (by simpa [jModElt, Subtype.ext_iff] using h)
+
+variable {F} in
+theorem jModElt_notMem_qIntegersBar (hF : jqModC K ∈ F) :
+    jModElt K hF ∉ qIntegersBar K F := by
+  rw [mem_qIntegersBar_iff, qSeriesBar_jModElt, order_jqModC_def]
+  omega
+
+variable {F} in
+theorem qIntegersBar_ne_top_of_jqModC_mem (hF : jqModC K ∈ F) : qIntegersBar K F ≠ ⊤ := by
+  intro h
+  exact jModElt_notMem_qIntegersBar K hF (h ▸ ValuationSubring.mem_top _)
+
+variable {F} in
+def jModInvElt (hF : jqModC K ∈ F) : F := (jModElt K hF)⁻¹
+
+variable {F} in
+theorem qSeriesBar_jModInvElt (hF : jqModC K ∈ F) :
+    qSeriesBar K F (jModInvElt K hF) = (jqModC K)⁻¹ := by
+  rw [jModInvElt, qSeriesBar_inv, qSeriesBar_jModElt]
+
+variable {F} in
+theorem jModInvElt_ne_zero (hF : jqModC K ∈ F) : jModInvElt K hF ≠ 0 :=
+  inv_ne_zero (jModElt_ne_zero K hF)
+
+variable {F} in
+theorem order_jModInvElt (hF : jqModC K ∈ F) :
+    (qSeriesBar K F (jModInvElt K hF)).order = 1 := by
+  rw [qSeriesBar_jModInvElt, order_inv_of_ne_zero_bar (jqModC_ne_zero_def K), order_jqModC_def]
+  omega
+
+variable {F} in
+theorem jModInvElt_mem_qIntegersBar (hF : jqModC K ∈ F) :
+    jModInvElt K hF ∈ qIntegersBar K F := by
+  rw [mem_qIntegersBar_iff, order_jModInvElt]
+  omega
+
+variable {F} in
+def uniformizerMod (hF : jqModC K ∈ F) : qIntegersBar K F :=
+  ⟨jModInvElt K hF, jModInvElt_mem_qIntegersBar K hF⟩
+
+variable {F} in
+@[simp]
+theorem coe_uniformizerMod (hF : jqModC K ∈ F) :
+    ((uniformizerMod K hF : qIntegersBar K F) : F) = jModInvElt K hF := rfl
+
+variable {F} in
+theorem uniformizerMod_ne_zero (hF : jqModC K ∈ F) :
+    ((uniformizerMod K hF : qIntegersBar K F) : F) ≠ 0 :=
+  jModInvElt_ne_zero K hF
+
+variable {F} in
+theorem irreducible_uniformizerMod (hF : jqModC K ∈ F) :
+    Irreducible (uniformizerMod K hF) := by
+  constructor
+  · rw [isUnit_qIntegersBar_iff (uniformizerMod_ne_zero K hF), coe_uniformizerMod,
+      order_jModInvElt]
+    omega
+  · rintro a b hab
+    have hab' : jModInvElt K hF = (a : F) * (b : F) := by
+      have := congrArg (fun z : qIntegersBar K F => (z : F)) hab
+      simpa using this
+    have ha0 : (a : F) ≠ 0 := by
+      intro h
+      exact jModInvElt_ne_zero K hF (by rw [hab', h, zero_mul])
+    have hb0 : (b : F) ≠ 0 := by
+      intro h
+      exact jModInvElt_ne_zero K hF (by rw [hab', h, mul_zero])
+    have hsum : (qSeriesBar K F (a : F)).order + (qSeriesBar K F (b : F)).order = 1 := by
+      rw [← order_qSeriesBar_mul ha0 hb0, ← hab', order_jModInvElt]
+    have ha' : (0 : ℤ) ≤ (qSeriesBar K F (a : F)).order := a.2
+    have hb' : (0 : ℤ) ≤ (qSeriesBar K F (b : F)).order := b.2
+    rcases eq_or_lt_of_le ha' with ha0' | hapos
+    · exact Or.inl ((isUnit_qIntegersBar_iff ha0).mpr ha0'.symm)
+    rcases eq_or_lt_of_le hb' with hb0' | hbpos
+    · exact Or.inr ((isUnit_qIntegersBar_iff hb0).mpr hb0'.symm)
+    omega
+
+variable {F} in
+theorem qIntegersBar_isPrincipalIdealRing_of_jqModC_mem (hF : jqModC K ∈ F) :
+    IsPrincipalIdealRing (qIntegersBar K F) := by
+  refine (IsDiscreteValuationRing.ofHasUnitMulPowIrreducibleFactorization
+    ⟨uniformizerMod K hF, irreducible_uniformizerMod K hF, ?_⟩).toIsPrincipalIdealRing
+  rintro x hx
+  have hf : (x : F) ≠ 0 := fun h => hx (Subtype.ext h)
+  have hmnonneg : (0 : ℤ) ≤ (qSeriesBar K F (x : F)).order := x.2
+  set n : ℕ := (qSeriesBar K F (x : F)).order.toNat with hn
+  have hmn : (n : ℤ) = (qSeriesBar K F (x : F)).order := Int.toNat_of_nonneg hmnonneg
+  refine ⟨n, ?_⟩
+  have hπn : (jModInvElt K hF) ^ n ≠ 0 := pow_ne_zero _ (jModInvElt_ne_zero K hF)
+  have hdiv0 : (x : F) / (jModInvElt K hF) ^ n ≠ 0 := div_ne_zero hf hπn
+  have hπorder : (qSeriesBar K F ((jModInvElt K hF) ^ n)).order = n := by
+    rw [qSeriesBar_pow, order_pow_of_ne_zero_bar (qSeriesBar_ne_zero (jModInvElt_ne_zero K hF)),
+      order_jModInvElt, mul_one]
+  have hu0 : (qSeriesBar K F ((x : F) / (jModInvElt K hF) ^ n)).order = 0 := by
+    rw [div_eq_mul_inv, order_qSeriesBar_mul hf (inv_ne_zero hπn), qSeriesBar_inv,
+      order_inv_of_ne_zero_bar (qSeriesBar_ne_zero hπn), hπorder, ← hmn]
+    ring
+  have humem : (x : F) / (jModInvElt K hF) ^ n ∈ qIntegersBar K F := by
+    rw [mem_qIntegersBar_iff, hu0]
+  have hu : IsUnit (⟨(x : F) / (jModInvElt K hF) ^ n, humem⟩ : qIntegersBar K F) :=
+    (isUnit_qIntegersBar_iff hdiv0).mpr hu0
+  refine ⟨hu.unit, ?_⟩
+  refine Subtype.ext ?_
+  have hcoe : ((hu.unit : qIntegersBar K F) : F) = (x : F) / (jModInvElt K hF) ^ n := by
+    rw [IsUnit.unit_spec]
+  push_cast
+  rw [hcoe, mul_comm, coe_uniformizerMod, div_mul_cancel₀]
+  exact hπn
+
+variable {F} in
+def qInftyPlaceMod (hF : jqModC K ∈ F) : Place K F where
+  toValuationSubring := qIntegersBar K F
+  algebraMap_mem' := fun a => by
+    rw [mem_qIntegersBar_iff, qSeriesBar_algebraMap]
+    rcases eq_or_ne a 0 with rfl | ha
+    · simp only [HahnSeries.single_eq_zero, HahnSeries.order_zero, le_refl]
+    · rw [HahnSeries.order_single ha]
+  ne_top' := qIntegersBar_ne_top_of_jqModC_mem K hF
+  isPrincipalIdealRing' := qIntegersBar_isPrincipalIdealRing_of_jqModC_mem K hF
+
+variable {F} in
+@[simp]
+theorem qInftyPlaceMod_toValuationSubring (hF : jqModC K ∈ F) :
+    (qInftyPlaceMod K hF).toValuationSubring = qIntegersBar K F := rfl
+
+variable {F} in
+theorem ord_qInftyPlaceMod (hF : jqModC K ∈ F) (f : F) :
+    (qInftyPlaceMod K hF).ord f = (qSeriesBar K F f).order := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · rw [Place.ord_zero, qSeriesBar_zero, HahnSeries.order_zero]
+  set n : ℤ := (qSeriesBar K F f).order with hn
+  have hjn : (jModInvElt K hF) ^ n ≠ 0 := zpow_ne_zero _ (jModInvElt_ne_zero K hF)
+  have huord : (qSeriesBar K F (f / (jModInvElt K hF) ^ n)).order = 0 := by
+    rw [qSeriesBar_div, qSeriesBar_zpow,
+      order_div_of_ne_zero_bar (qSeriesBar_ne_zero hf)
+        (zpow_ne_zero _ (qSeriesBar_ne_zero (jModInvElt_ne_zero K hF))),
+      order_zpow_of_ne_zero_bar (qSeriesBar_ne_zero (jModInvElt_ne_zero K hF)),
+      order_jModInvElt, mul_one, ← hn]
+    ring
+  have humem : f / (jModInvElt K hF) ^ n ∈ qIntegersBar K F := by
+    rw [mem_qIntegersBar_iff, huord]
+  have hune : f / (jModInvElt K hF) ^ n ≠ 0 := div_ne_zero hf hjn
+  have huu : IsUnit (⟨f / (jModInvElt K hF) ^ n, humem⟩ : qIntegersBar K F) :=
+    (isUnit_qIntegersBar_iff hune).mpr huord
+  have hdecomp : f = ((huu.unit : qIntegersBar K F) : F)
+      * (((uniformizerMod K hF : qIntegersBar K F) : F) ^ n) := by
+    have hcoe : ((huu.unit : qIntegersBar K F) : F) = f / (jModInvElt K hF) ^ n := by
+      rw [IsUnit.unit_spec]
+    rw [hcoe, coe_uniformizerMod]
+    exact (div_mul_cancel₀ f hjn).symm
+  rw [hdecomp]
+  exact (qInftyPlaceMod K hF).ord_unit_smul_zpow huu.unit (irreducible_uniformizerMod K hF) n
+
+variable {F} in
+theorem algebraMap_coeff_zero_sub_not_isUnit_mod (hF : jqModC K ∈ F)
+    (f : (qInftyPlaceMod K hF).toValuationSubring) :
+    ¬IsUnit (algebraMap K (qInftyPlaceMod K hF).toValuationSubring
+      ((qSeriesBar K F (f : F)).coeff 0) - f) := by
+  set c : K := (qSeriesBar K F (f : F)).coeff 0 with hc
+  have hcoe : qSeriesBar K F
+      ((algebraMap K (qInftyPlaceMod K hF).toValuationSubring c - f : _) : F)
+      = HahnSeries.single (0 : ℤ) c - qSeriesBar K F (f : F) := by
+    have h1 : ((algebraMap K (qInftyPlaceMod K hF).toValuationSubring c - f : _) : F)
+        = algebraMap K F c - (f : F) := by
+      push_cast
+      rw [Place.coe_algebraMap]
+    rw [h1, qSeriesBar_sub, qSeriesBar_algebraMap]
+  have hgcoeff : ∀ k : ℤ, k ≤ 0 →
+      (qSeriesBar K F
+        ((algebraMap K (qInftyPlaceMod K hF).toValuationSubring c - f : _) : F)).coeff k
+        = 0 := by
+    intro k hk
+    rw [hcoe, HahnSeries.coeff_sub]
+    rcases lt_or_eq_of_le hk with hk' | hk'
+    · rw [HahnSeries.coeff_single_of_ne (by omega : k ≠ 0),
+        HahnSeries.coeff_eq_zero_of_lt_order (lt_of_lt_of_le hk' f.2), sub_zero]
+    · subst hk'
+      rw [HahnSeries.coeff_single_same, hc, sub_self]
+  intro hunit
+  rcases eq_or_ne
+    (((algebraMap K (qInftyPlaceMod K hF).toValuationSubring c - f : _) : F)) 0
+    with hg0 | hg0
+  · have hzero : (algebraMap K (qInftyPlaceMod K hF).toValuationSubring c - f : _) = 0 :=
+      Subtype.ext hg0
+    rw [hzero] at hunit
+    exact not_isUnit_zero hunit
+  · have horder := (isUnit_qIntegersBar_iff hg0).mp hunit
+    have hne := HahnSeries.coeff_order_eq_zero.not.mpr (qSeriesBar_ne_zero hg0)
+    rw [horder] at hne
+    exact hne (hgcoeff 0 le_rfl)
+
+variable {F} in
+theorem surjective_algebraMap_residueField_mod (hF : jqModC K ∈ F) :
+    Function.Surjective (algebraMap K (qInftyPlaceMod K hF).ResidueField) := by
+  intro y
+  obtain ⟨f, rfl⟩ := Ideal.Quotient.mk_surjective
+    (I := IsLocalRing.maximalIdeal (qInftyPlaceMod K hF).toValuationSubring) y
+  refine ⟨(qSeriesBar K F (f : F)).coeff 0, ?_⟩
+  have hmem : algebraMap K (qInftyPlaceMod K hF).toValuationSubring
+      ((qSeriesBar K F (f : F)).coeff 0) - f ∈
+      IsLocalRing.maximalIdeal (qInftyPlaceMod K hF).toValuationSubring := by
+    rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+    exact algebraMap_coeff_zero_sub_not_isUnit_mod K hF f
+  exact (Ideal.Quotient.mk_eq_mk_iff_sub_mem
+    (I := IsLocalRing.maximalIdeal (qInftyPlaceMod K hF).toValuationSubring)
+    (algebraMap K (qInftyPlaceMod K hF).toValuationSubring
+      ((qSeriesBar K F (f : F)).coeff 0)) f).mpr hmem
+
+variable {F} in
+theorem deg_qInftyPlaceMod (hF : jqModC K ∈ F) : (qInftyPlaceMod K hF).deg = 1 := by
+  have hsurj := surjective_algebraMap_residueField_mod K hF
+  have hinj : Function.Injective (algebraMap K (qInftyPlaceMod K hF).ResidueField) :=
+    (algebraMap K (qInftyPlaceMod K hF).ResidueField).injective
+  have e : K ≃ₐ[K] (qInftyPlaceMod K hF).ResidueField :=
+    AlgEquiv.ofBijective (Algebra.ofId K _) ⟨hinj, hsurj⟩
+  change Module.finrank K (qInftyPlaceMod K hF).ResidueField = 1
+  rw [← e.toLinearEquiv.finrank_eq, Module.finrank_self]
+
+end QAdicPlaceMod
+
+section LevelN
+
+variable (N : ℕ) [NeZero N]
+
+def cuspInftyGeom : Place K (modularFunctionFieldC K N) :=
+  qInftyPlaceMod K (jqModC_mem K N)
+
+theorem nonempty_place_modularFunctionFieldC :
+    Nonempty (Place K (modularFunctionFieldC K N)) :=
+  ⟨cuspInftyGeom K N⟩
+
+theorem ord_cuspInftyGeom_jq :
+    (cuspInftyGeom K N).ord ⟨jqModC K, jqModC_mem K N⟩ = -1 := by
+  rw [cuspInftyGeom, ord_qInftyPlaceMod]
+  exact order_jqModC_def K
+
+theorem ord_cuspInftyGeom_jqN :
+    (cuspInftyGeom K N).ord ⟨jqNModC K N, jqNModC_mem K N⟩ = -(N : ℤ) := by
+  rw [cuspInftyGeom, ord_qInftyPlaceMod]
+  exact order_jqNModC K N
+
+theorem deg_cuspInftyGeom : (cuspInftyGeom K N).deg = 1 :=
+  deg_qInftyPlaceMod K (jqModC_mem K N)
+
+end LevelN
+
+section Gates
+
+theorem gate_ord_cuspInftyGeom_fbar_two :
+    (cuspInftyGeom (AlgebraicClosure (ZMod 2)) 3).ord
+      ⟨jqModC _, jqModC_mem _ 3⟩ = -1 :=
+  ord_cuspInftyGeom_jq _ 3
+
+theorem gate_ord_cuspInftyGeom_fbar_two_ne_zero :
+    (cuspInftyGeom (AlgebraicClosure (ZMod 2)) 3).ord
+      ⟨jqModC _, jqModC_mem _ 3⟩ ≠ 0 := by
+  rw [gate_ord_cuspInftyGeom_fbar_two]
+  omega
+
+end Gates
+
+end ModularCurve
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_QExpansionDiff.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_QExpansionDiff.lean
new file mode 100644
index 0000000000..a1cf8f0404
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_QExpansionDiff.lean
@@ -0,0 +1,126 @@
+/-
+Based on Prove2Me node ModularCurve_QExpansionDiff
+(38fd6064-f991-5bce-bdae-70602ca6412b) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.LaurentSeries
+public import Mathlib.RingTheory.Kaehler.Basic
+
+/-!
+# The operator θ=qd/dq, q-expansions of differentials, trace of differentials
+
+Definition: `ModularCurve_QExpansionDiff` (`38fd6064-f991-5bce-bdae-70602ca6412b`), by Claude,
+2026-09-05.
+
+Three pieces of vocabulary, all introduced as data together with the predicates that characterise
+them.
+
+For a field $L$, [`ModularCurve.thetaL`](../def/ModularCurve_QExpansionDiff.html#L16) is the
+$L$-linear endomorphism of the Laurent series field $L((q))$ sending $f$ to $q\cdot f'$, where $f'$
+is Mathlib's formal derivative of a Laurent series and $q$ denotes the Hahn-series monomial `single
+(1 : ℤ) (1 : L)`; `thetaL_apply` records this defining formula. Thus `thetaL` is the operator
+$\theta = q\,d/dq$.
+
+In a context of fields $K$, $F$, $L$ with $F$ and $L$ algebras over $K$,
+[`ModularCurve.IsQExpansionDiffAlong σ φ`](../def/ModularCurve_QExpansionDiff.html#L35) is a
+predicate on a $K$-algebra map $\sigma : F \to L((q))$ and a $K$-linear map $\varphi : \Omega_{F/K}
+\to L((q))$, asserting the conjunction of two conditions: $\varphi(\mathrm{d}x) = \theta(\sigma x)$
+for every $x \in F$, where $\mathrm{d}$ is the universal derivation `KaehlerDifferential.D K F`, and
+$\varphi(f \cdot \omega) = \sigma(f)\,\varphi(\omega)$ for all $f \in F$ and $\omega \in
+\Omega_{F/K}$, i.e. $\varphi$ is $\sigma$-semilinear over $F$. Informally, $\varphi(\omega)$ is the
+Laurent series $h$ with $\omega = h\,dq/q$ along $\sigma$. Then [`ModularCurve.qExpansionDiffAlong
+σ`](../def/ModularCurve_QExpansionDiff.html#L42) is defined to be some $\varphi$ with this property
+when one exists, and the zero map otherwise; neither existence nor uniqueness is asserted here, so
+the map is characterised only through the predicate.
+
+For a tower of fields $K \to F \to F'$, [`AlgebraicCurve.IsTraceDiff K F F'
+t`](../def/ModularCurve_QExpansionDiff.html#L56) is the predicate on an $F$-linear map $t :
+\Omega_{F'/K} \to \Omega_{F/K}$ that $t(y \cdot \iota(\omega)) = \mathrm{Tr}_{F'/F}(y)\cdot\omega$
+for all $y \in F'$ and $\omega \in \Omega_{F/K}$, where $\iota$ is `KaehlerDifferential.map K K F
+F'`. Again [`AlgebraicCurve.traceDiff`](../def/ModularCurve_QExpansionDiff.html#L62) is defined to
+be such a $t$ if one exists and the zero map otherwise.
+
+**Relation to Mathlib.** Built on Mathlib's Laurent series with their formal derivative, Mathlib's
+Kähler differentials `Ω[F⁄K]` with the universal derivation and the base-change map
+`KaehlerDifferential.map`, and `Algebra.trace`. The operator $\theta$, the notion of a $q$-expansion
+of a differential along an embedding into $L((q))$, and the trace (push-forward) map on
+differentials in a tower are the project's own notions.
+
+**Where it is used.** This module supplies vocabulary used throughout the tree: the $q$-expansion
+map attaches to a differential on a modular curve, via an embedding of its function field into
+$L((q))$ at a cusp, the Laurent series of the associated weight-two form, and `traceDiff` is the
+push-forward of differentials along a covering of curves, expressed through the field trace.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section DL_foulmouthedly
+
+open HahnSeries
+
+namespace ModularCurve
+
+section Theta
+
+variable (L : Type*) [Field L]
+
+def thetaL : LaurentSeries L →ₗ[L] LaurentSeries L where
+  toFun f := single (1 : ℤ) (1 : L) * LaurentSeries.derivative L f
+  map_add' f g := by rw [map_add, mul_add]
+  map_smul' c f := by
+    rw [map_smul, RingHom.id_apply, ← single_zero_mul_eq_smul, ← single_zero_mul_eq_smul,
+      mul_left_comm]
+
+variable {L} in
+theorem thetaL_apply (f : LaurentSeries L) :
+    thetaL L f = single (1 : ℤ) (1 : L) * LaurentSeries.derivative L f :=
+  rfl
+
+end Theta
+
+section QExpansionDiff
+
+variable {K F L : Type*} [Field K] [Field F] [Algebra K F] [Field L] [Algebra K L]
+
+def IsQExpansionDiffAlong (σ : F →ₐ[K] LaurentSeries L) (φ : Ω[F⁄K] →ₗ[K] LaurentSeries L) :
+    Prop :=
+  (∀ x : F, φ (KaehlerDifferential.D K F x) = thetaL L (σ x)) ∧
+    ∀ (f : F) (ω : Ω[F⁄K]), φ (f • ω) = σ f * φ ω
+
+open scoped Classical in
+def qExpansionDiffAlong (σ : F →ₐ[K] LaurentSeries L) : Ω[F⁄K] →ₗ[K] LaurentSeries L :=
+  if h : ∃ φ : Ω[F⁄K] →ₗ[K] LaurentSeries L, IsQExpansionDiffAlong σ φ then h.choose else 0
+
+end QExpansionDiff
+
+end ModularCurve
+
+namespace AlgebraicCurve
+
+section TraceDiff
+
+variable (K F F' : Type*) [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+  [Algebra F F'] [IsScalarTower K F F']
+
+def IsTraceDiff (t : Ω[F'⁄K] →ₗ[F] Ω[F⁄K]) : Prop :=
+  ∀ (y : F') (ω : Ω[F⁄K]),
+    t (y • KaehlerDifferential.map K K F F' ω) = Algebra.trace F F' y • ω
+
+open scoped Classical in
+def traceDiff : Ω[F'⁄K] →ₗ[F] Ω[F⁄K] :=
+  if h : ∃ t : Ω[F'⁄K] →ₗ[F] Ω[F⁄K], IsTraceDiff K F F' t then h.choose else 0
+
+end TraceDiff
+
+end AlgebraicCurve
+
+end DL_foulmouthedly
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_RouteBCoordRing.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_RouteBCoordRing.lean
new file mode 100644
index 0000000000..42ea44d5b5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_RouteBCoordRing.lean
@@ -0,0 +1,89 @@
+/-
+Based on Prove2Me node ModularCurve_RouteBCoordRing
+(e108f865-1331-521d-8b62-db56f6ba7e3a) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+/-!
+# Route-B coordinate ring: integral closure of Z[j]
+
+Definition: `ModularCurve_RouteBCoordRing` (`e108f865-1331-521d-8b62-db56f6ba7e3a`), by Claude,
+2026-09-05.
+
+Fix $N\ge 1$ (nonzero) and recall that `modularFunctionField N` is the intermediate field $\mathbb
+Q\bigl(j(q),\,j(q^N)\bigr)$ of $\mathbb Q(\!(q)\!)$, obtained by adjoining to $\mathbb Q$ the
+Laurent series `jq` and its $N$-fold $q$-substitution `qExpand ℚ N jq`. Three things are defined
+here. First, `jAdjoinRingHom N` is the ring homomorphism $\mathbb Q(j(q))\to\mathbb Q(j(q),j(q^N))$
+realising the inclusion of the simple extension $\mathbb Q\langle$`jq`$\rangle$ into
+`modularFunctionField N` provided by `adjoin_jq_le`; on underlying Laurent series it is the
+identity. Second, `algebraIntPolyModularFunctionField N` is the $\mathbb Z[X]$-algebra structure on
+`modularFunctionField N` whose structure map is `evalAtJGen` (evaluation of integer polynomials at
+`jGen`, the element `jq` of $\mathbb Q\langle$`jq`$\rangle$) followed by that inclusion; thus
+$X\mapsto j(q)$, and the polynomial ring $\mathbb Z[X]$ acts as $\mathbb Z[j]$, the coordinate ring
+of the affine $j$-line over $\mathbb Z$. Third, with this structure in force, `routeBCoordRing N` is
+the integral closure of $\mathbb Z[X]$ in `modularFunctionField N`, i.e. the subalgebra of those
+elements of $\mathbb Q(j(q),j(q^N))$ that are integral over $\mathbb Z[j]$ — the normalisation of
+the $j$-line in the function field, the affine coordinate ring of the intended integral model of
+$Y_0(N)$. Finally, for a commutative ring $L$ and a ring homomorphism $\varphi$ from
+`routeBCoordRing N` to $L$, `routeBJValue φ` is the element $\varphi(j(q))\in L$, the image under
+$\varphi$ of the distinguished coordinate coming from $X\in\mathbb Z[X]$; this is the $j$-invariant
+attached to the $L$-point $\varphi$.
+
+**Relation to Mathlib.** The integral closure itself is Mathlib's `integralClosure`; what is new
+here is the $\mathbb Z[X]$-algebra structure on the modular function field sending $X$ to the
+$q$-expansion of $j$, supplied as a named definition (the same field is also given other
+polynomial-algebra structures elsewhere, e.g. via $1/j$).
+
+**Where it is used.** This coordinate ring is the affine model of $Y_0(N)$ on which points valued in
+a commutative ring, and their $j$-invariants, are read off; it is the algebraic substitute used when
+the modularity input is turned into a statement about rational points and their $j$-values, as
+needed for the Frey curve attached to a solution of the Fermat equation.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open IntermediateField
+
+namespace ModularCurve
+
+section Tower
+
+variable (N : ℕ) [NeZero N]
+
+def jAdjoinRingHom : ℚ⟮jq⟯ →+* modularFunctionField N where
+  toFun x := ⟨(x : LaurentSeries ℚ), adjoin_jq_le N x.2⟩
+  map_one' := rfl
+  map_mul' _ _ := rfl
+  map_zero' := rfl
+  map_add' _ _ := rfl
+
+@[reducible] def algebraIntPolyModularFunctionField :
+    Algebra (Polynomial ℤ) (modularFunctionField N) :=
+  ((jAdjoinRingHom N).comp evalAtJGen).toAlgebra
+
+attribute [local instance] algebraIntPolyModularFunctionField
+
+abbrev routeBCoordRing : Subalgebra (Polynomial ℤ) (modularFunctionField N) :=
+  integralClosure (Polynomial ℤ) (modularFunctionField N)
+
+def routeBJValue {N : ℕ} [NeZero N] {L : Type*} [CommRing L] (φ : ↥(routeBCoordRing N) →+* L) : L :=
+  φ ⟨algebraMap (Polynomial ℤ) ↥(modularFunctionField N) Polynomial.X, Subalgebra.algebraMap_mem _
+    _⟩
+
+end Tower
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_SpecialisationBridge.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_SpecialisationBridge.lean
new file mode 100644
index 0000000000..87e21a513a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_SpecialisationBridge.lean
@@ -0,0 +1,367 @@
+/-
+Based on Prove2Me node ModularCurve_SpecialisationBridge
+(52ff15a8-6143-55a5-8df2-6a5dc3d7422f) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_SpecialisationVocab
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_TatePoint
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_Monodromy
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VariableChangePointEquiv
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_vcInvFun_add
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_B3_goodModel_zero_spec
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_B3_goodModel_1728_spec
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_B3_goodModel_generic_spec
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_B3_nearCurve_eq_ofJNe0Or1728
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_B3_exists_variableChange_specialFibre_goodModel
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_B3_isElliptic_specialFibre_goodModel
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_B3_isElliptic_specialFibre
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_B3_exists_torsionBy_reduction_addEquiv
+
+/-!
+# Reduction of points and specialisation of cyclic p-subgroups
+
+Definition: `ModularCurve_SpecialisationBridge` (`52ff15a8-6143-55a5-8df2-6a5dc3d7422f`), by Claude,
+2026-09-05.
+
+Throughout, $\bar{\mathbb Q}$ is an algebraic closure of $\mathbb Q$ and $H = \mathrm{HahnSeries}\
+\mathbb Q\ \bar{\mathbb Q}$ is the field of Hahn series with rational exponents; a Weierstrass curve
+$W$ over $H$ has `IntegralCoeffs` when each $a_i$ has non-negative `orderTop`, and `specialFibre W`
+is the Weierstrass curve over $\bar{\mathbb Q}$ whose coefficients are the degree-$0$ coefficients
+of the $a_i$. The first group of declarations is the coefficientwise reduction: if $x,y$ have
+non-negative order and $(x,y)$ satisfies (resp. is a nonsingular point of) the affine equation of
+$W$, then $(x_0,y_0)$ satisfies (resp. is nonsingular on) `specialFibre W`, the nonsingularity
+statement using that the special fibre is elliptic when $\Delta_W$ has order exactly $0$. The
+function `redPoint` sends the point at infinity to $0$, a point with both coordinates of
+non-negative order to its reduction, and every other affine point to $0$; it is defined as a
+function on points, no additivity being asserted.
+
+The second group manipulates the type `CycOf A N` of subgroups of an additive group $A$ of the form
+$\mathbb Z g$ with $g$ of additive order exactly $N$; the project's types `CycSubH E N` and `CycSub
+E₀ N` of cyclic $N$-subgroups of points are recorded as this type. Bijections of this type are
+produced from an additive equivalence (`cycOfCongr`, by pushing subgroups forward), and from the
+inclusion of the $N$-torsion submodule (`cycOfTorsionBy`, by pulling back along $\mathrm{torsionBy}\
+\mathbb Z\ A\ N \hookrightarrow A$), with small helpers on torsion membership and on comap of
+$\mathbb Z g$. Additive equivalences of point groups are supplied by `vcAddEquiv` (the inverse of
+the point bijection attached to a variable change, additive by `vcInvFun_add`) and by
+`pointAddEquivOfEq` (transport along an equality of curves).
+
+At a $j$-value $j_0 \in \bar{\mathbb Q}$, `nearCurve j₀` is the curve of invariant $j_0 + q$ and
+`goodModel j₀` is its twist by the variable change `scaleVC j₀` (a rescaling by a fractional power
+of $q$ when $j_0 = 0$ or $1728$, the identity otherwise); `goodModel_spec` records that this model
+has integral coefficients and discriminant of order $0$. `fibreVC` is a chosen variable change
+carrying `specialFibre (goodModel j₀)` to `ofJ j₀`, and `fibreAddEquiv` the resulting additive
+equivalence of point groups; `scaleAddEquiv` is the point equivalence between `nearCurve j₀` and
+`goodModel j₀`, and `cycScale` its effect on cyclic $p$-subgroups. `redTorsionEquiv` is a chosen
+additive equivalence between the $p$-torsion of $W$ and that of `specialFibre W`, characterised by
+`redTorsionEquiv_spec`: it acts on an affine $p$-torsion point $(x,y)$ by $(x_0,y_0)$. Composing
+gives `cycRed`, a bijection from cyclic $p$-subgroups of $W$ to those of `specialFibre W`, and
+`bridge3Specialise`, a bijection from cyclic $p$-subgroups of `nearCurve j₀` to those of `ofJ j₀`,
+for $p$ prime.
+
+The last group is the monodromy action. A ring endomorphism of $H$ fixing the constants $C(q)$ and
+the element $q = \mathrm{single}\ 1\ 1$ fixes $j_0 + q$ and hence `nearCurve j₀`; in particular
+every element of the monodromy subgroup of $\mathrm{Aut}_{\bar{\mathbb Q}}(H)$ (the group of twists
+$\mathrm{single}\ a\ r \mapsto \mathrm{single}\ a\ (\chi(a)r)$ with $\chi(1) = 1$) does.
+`nearTransport j₀ m` is the induced additive automorphism of the points of `nearCurve j₀`, acting
+coordinatewise, `b3Act j₀ m` is the induced map on subgroups of the point group, and it carries
+$\mathbb Z g$ to $\mathbb Z\,(\text{transport of } g)$.
+
+**Relation to Mathlib.** Mathlib provides `WeierstrassCurve`, its `VariableChange` action and affine
+point groups, but not the induced bijection of point groups under a variable change, nor the
+reduction of an integral Hahn-series model to its special fibre; both are project notions, as is the
+type of cyclic subgroups of a given order used here.
+
+**Where it is used.** These definitions form the specialisation half of the dictionary between roots
+of the modular polynomial and cyclic $p$-subgroups: they transfer the subgroup-counting statements
+proved for the near model over the Hahn-series field $H$, where the $j$-invariant is transcendental,
+to an arbitrary elliptic curve of given $j$-invariant over $\bar{\mathbb Q}$, and record the
+monodromy action under which that transfer is equivariant.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open scoped Classical
+
+noncomputable section
+
+open ModularCurve WeierstrassCurve Polynomial
+
+namespace ModularCurve.B3
+
+open ModularCurve.TatePoint
+
+theorem map_ofJNe0Or1728 {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S) (j : R) :
+    (WeierstrassCurve.ofJNe0Or1728 j).map f = WeierstrassCurve.ofJNe0Or1728 (f j) := by
+  simp only [WeierstrassCurve.ofJNe0Or1728, WeierstrassCurve.map, map_sub, map_ofNat, map_zero,
+    map_mul, map_neg, map_pow]
+
+theorem equation_specialFibre (W : WeierstrassCurve H) (hW : IntegralCoeffs W) {x y : H}
+    (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop) (h : W.toAffine.Equation x y) :
+    (specialFibre W).toAffine.Equation (x.coeff 0) (y.coeff 0) := by
+  rw [WeierstrassCurve.Affine.equation_iff] at h ⊢
+  obtain ⟨h₁, h₂, h₃, h₄, h₆⟩ := hW
+  let A₁ : integralO := ⟨W.a₁, h₁⟩
+  let A₂ : integralO := ⟨W.a₂, h₂⟩
+  let A₃ : integralO := ⟨W.a₃, h₃⟩
+  let A₄ : integralO := ⟨W.a₄, h₄⟩
+  let A₆ : integralO := ⟨W.a₆, h₆⟩
+  let X : integralO := ⟨x, hx⟩
+  let Y : integralO := ⟨y, hy⟩
+  have h₀ : Y ^ 2 + A₁ * X * Y + A₃ * Y = X ^ 3 + A₂ * X ^ 2 + A₄ * X + A₆ := by
+    apply Subtype.coe_injective
+    push_cast
+    exact h
+  have e := congrArg resO h₀
+  simp only [map_add, map_mul, map_pow, resO_apply] at e
+  exact e
+
+theorem nonsingular_specialFibre (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : W.toAffine.Nonsingular x y) :
+    (specialFibre W).toAffine.Nonsingular (x.coeff 0) (y.coeff 0) := by
+  have := isElliptic_specialFibre W hW hΔ
+  rw [← WeierstrassCurve.Affine.equation_iff_nonsingular]
+  exact equation_specialFibre W hW hx hy h.1
+
+def redPoint (W : WeierstrassCurve H) (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0) :
+    W.toAffine.Point → (specialFibre W).toAffine.Point
+  | .zero => 0
+  | .some x y h =>
+    if hxy : 0 ≤ x.orderTop ∧ 0 ≤ y.orderTop then
+      WeierstrassCurve.Affine.Point.some (x.coeff 0) (y.coeff 0)
+        (nonsingular_specialFibre W hW hΔ hxy.1 hxy.2 h)
+    else 0
+
+@[simp] theorem redPoint_zero (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) : redPoint W hW hΔ 0 = 0 := rfl
+
+theorem redPoint_some (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : W.toAffine.Nonsingular x y) :
+    redPoint W hW hΔ (WeierstrassCurve.Affine.Point.some x y h) =
+      WeierstrassCurve.Affine.Point.some (x.coeff 0) (y.coeff 0)
+        (nonsingular_specialFibre W hW hΔ hx hy h) := by
+  simp only [redPoint, dite_eq_left (And.intro hx hy)]
+
+universe u
+
+def CycOf (A : Type u) [AddGroup A] (N : ℕ) : Type u :=
+  {G : AddSubgroup A // ∃ g : A, addOrderOf g = N ∧ G = AddSubgroup.zmultiples g}
+
+theorem CycSubH_eq_CycOf (E : WeierstrassCurve H) (N : ℕ) :
+    CycSubH E N = CycOf E.toAffine.Point N := rfl
+
+theorem CycSub_eq_CycOf (E₀ : WeierstrassCurve Qbar) (N : ℕ) :
+    CycSub E₀ N = CycOf E₀.toAffine.Point N := rfl
+
+def cycOfCongr {A B : Type*} [AddCommGroup A] [AddCommGroup B] (e : A ≃+ B) (N : ℕ) :
+    CycOf A N ≃ CycOf B N where
+  toFun G := ⟨G.1.map (e : A →+ B), by
+    obtain ⟨g, hg, hG⟩ := G.2
+    exact ⟨(e : A →+ B) g, by rw [AddMonoidHom.coe_ofClass, AddEquiv.addOrderOf_eq, hg],
+      by rw [hG, AddMonoidHom.map_zmultiples]⟩⟩
+  invFun G := ⟨G.1.map (e.symm : B →+ A), by
+    obtain ⟨g, hg, hG⟩ := G.2
+    exact ⟨(e.symm : B →+ A) g, by rw [AddMonoidHom.coe_ofClass, AddEquiv.addOrderOf_eq, hg],
+      by rw [hG, AddMonoidHom.map_zmultiples]⟩⟩
+  left_inv G := Subtype.ext ((AddSubgroup.map_symm_eq_iff_map_eq (K := G.1)).mpr rfl)
+  right_inv G := Subtype.ext ((AddSubgroup.map_symm_eq_iff_map_eq (K := G.1) (e := e.symm)).mpr rfl)
+
+@[simp] theorem cycOfCongr_apply_coe {A B : Type*} [AddCommGroup A] [AddCommGroup B] (e : A ≃+ B)
+    (N : ℕ) (G : CycOf A N) : (cycOfCongr e N G).1 = G.1.map (e : A →+ B) := rfl
+
+theorem mem_torsionBy_of_addOrderOf_eq {A : Type*} [AddCommGroup A] {N : ℕ} {g : A}
+    (hg : addOrderOf g = N) : g ∈ Submodule.torsionBy ℤ A N := by
+  rw [Submodule.mem_torsionBy_iff, natCast_zsmul, ← hg, addOrderOf_nsmul_eq_zero]
+
+theorem comap_subtype_zmultiples {A : Type*} [AddCommGroup A] (S : Submodule ℤ A) {x : A}
+    (hx : x ∈ S) :
+    (AddSubgroup.zmultiples x).comap S.subtype.toAddMonoidHom = AddSubgroup.zmultiples ⟨x, hx⟩ := by
+  rw [show AddSubgroup.zmultiples x =
+      (AddSubgroup.zmultiples (⟨x, hx⟩ : S)).map S.subtype.toAddMonoidHom from
+        (AddMonoidHom.map_zmultiples S.subtype.toAddMonoidHom ⟨x, hx⟩).symm,
+    AddSubgroup.comap_map_eq_self_of_injective (Submodule.injective_subtype S)]
+
+def cycOfTorsionBy (A : Type*) [AddCommGroup A] (N : ℕ) :
+    CycOf A N ≃ CycOf (Submodule.torsionBy ℤ A N) N where
+  toFun G := ⟨G.1.comap (Submodule.torsionBy ℤ A N).subtype.toAddMonoidHom, by
+    obtain ⟨g, hg, hG⟩ := G.2
+    refine ⟨⟨g, mem_torsionBy_of_addOrderOf_eq hg⟩, ?_, by rw [hG, comap_subtype_zmultiples]⟩
+    rw [← addOrderOf_injective (Submodule.torsionBy ℤ A N).subtype.toAddMonoidHom
+      (Submodule.injective_subtype _) ⟨g, mem_torsionBy_of_addOrderOf_eq hg⟩]
+    exact hg⟩
+  invFun G := ⟨G.1.map (Submodule.torsionBy ℤ A N).subtype.toAddMonoidHom, by
+    obtain ⟨g, hg, hG⟩ := G.2
+    exact ⟨(Submodule.torsionBy ℤ A N).subtype.toAddMonoidHom g,
+      by rw [addOrderOf_injective _ (Submodule.injective_subtype _), hg],
+      by rw [hG, AddMonoidHom.map_zmultiples]⟩⟩
+  left_inv G := by
+    apply Subtype.ext
+    obtain ⟨g, hg, hG⟩ := G.2
+    change (G.1.comap _).map _ = G.1
+    apply AddSubgroup.map_comap_eq_self
+    rw [hG, AddSubgroup.zmultiples_le]
+    exact AddMonoidHom.mem_range.mpr ⟨⟨g, mem_torsionBy_of_addOrderOf_eq hg⟩, rfl⟩
+  right_inv G :=
+    Subtype.ext (AddSubgroup.comap_map_eq_self_of_injective (Submodule.injective_subtype _) _)
+
+@[simp] theorem cycOfTorsionBy_apply_coe (A : Type*) [AddCommGroup A] (N : ℕ) (G : CycOf A N) :
+    (cycOfTorsionBy A N G).1 = G.1.comap (Submodule.torsionBy ℤ A N).subtype.toAddMonoidHom := rfl
+
+@[simp] theorem cycOfTorsionBy_symm_apply_coe (A : Type*) [AddCommGroup A] (N : ℕ)
+    (G : CycOf (Submodule.torsionBy ℤ A N) N) :
+    ((cycOfTorsionBy A N).symm G).1 = G.1.map (Submodule.torsionBy ℤ A N).subtype.toAddMonoidHom :=
+  rfl
+
+def vcAddEquiv {K : Type*} [Field K] [DecidableEq K] (C : VariableChange K)
+    (W : WeierstrassCurve K) :
+    W.toAffine.Point ≃+ (C • W).toAffine.Point :=
+  AddEquiv.mk' (WeierstrassCurve.Affine.Point.variableChangeEquiv C W.toAffine).symm
+    (WeierstrassCurve.Affine.Point.vcInvFun_add C W.toAffine)
+
+@[simp] theorem vcAddEquiv_apply {K : Type*} [Field K] [DecidableEq K] (C : VariableChange K)
+    (W : WeierstrassCurve K) (P : W.toAffine.Point) :
+    vcAddEquiv C W P = WeierstrassCurve.Affine.Point.vcInvFun C W.toAffine P := rfl
+
+def pointAddEquivOfEq {K : Type*} [Field K] [DecidableEq K] {W V : WeierstrassCurve K} (h : W = V) :
+    W.toAffine.Point ≃+ V.toAffine.Point := by
+  subst h; exact AddEquiv.refl _
+
+@[simp] theorem pointAddEquivOfEq_rfl {K : Type*} [Field K] [DecidableEq K]
+    (W : WeierstrassCurve K) :
+    pointAddEquivOfEq (rfl : W = W) = AddEquiv.refl _ := rfl
+
+instance instIsElliptic_goodModel (j₀ : Qbar) : (goodModel j₀).IsElliptic := by
+  unfold goodModel; infer_instance
+
+theorem goodModel_spec (j₀ : Qbar) :
+    IntegralCoeffs (goodModel j₀) ∧ (goodModel j₀).Δ.orderTop = 0 := by
+  by_cases h0 : j₀ = 0
+  · subst h0; exact ⟨goodModel_zero_spec.1, goodModel_zero_spec.2.1⟩
+  · by_cases h1728 : j₀ = 1728
+    · subst h1728; exact ⟨goodModel_1728_spec.1, goodModel_1728_spec.2.1⟩
+    · exact ⟨(goodModel_generic_spec j₀ h0 h1728).1, (goodModel_generic_spec j₀ h0 h1728).2.1⟩
+
+attribute [instance] isElliptic_specialFibre_goodModel
+
+def fibreVC (j₀ : Qbar) : VariableChange Qbar :=
+  Classical.choose (exists_variableChange_specialFibre_goodModel j₀)
+
+theorem fibreVC_smul (j₀ : Qbar) :
+    fibreVC j₀ • specialFibre (goodModel j₀) = WeierstrassCurve.ofJ j₀ :=
+  Classical.choose_spec (exists_variableChange_specialFibre_goodModel j₀)
+
+def scaleAddEquiv (j₀ : Qbar) : (nearCurve j₀).toAffine.Point ≃+ (goodModel j₀).toAffine.Point :=
+  vcAddEquiv (scaleVC j₀) (nearCurve j₀)
+
+@[simp] theorem scaleAddEquiv_apply (j₀ : Qbar) (P : (nearCurve j₀).toAffine.Point) :
+    scaleAddEquiv j₀ P =
+      WeierstrassCurve.Affine.Point.vcInvFun (scaleVC j₀) (nearCurve j₀).toAffine P := rfl
+
+def cycScale (p : ℕ) (j₀ : Qbar) : CycSubH (nearCurve j₀) p ≃ CycSubH (goodModel j₀) p :=
+  cycOfCongr (scaleAddEquiv j₀) p
+
+def fibreAddEquiv (j₀ : Qbar) :
+    (specialFibre (goodModel j₀)).toAffine.Point ≃+ (WeierstrassCurve.ofJ j₀).toAffine.Point :=
+  (vcAddEquiv (fibreVC j₀) (specialFibre (goodModel j₀))).trans (pointAddEquivOfEq (fibreVC_smul
+    j₀))
+
+theorem fibreAddEquiv_apply (j₀ : Qbar) (P : (specialFibre (goodModel j₀)).toAffine.Point) :
+    fibreAddEquiv j₀ P =
+      pointAddEquivOfEq (fibreVC_smul j₀)
+        (WeierstrassCurve.Affine.Point.vcInvFun (fibreVC j₀)
+          (specialFibre (goodModel j₀)).toAffine P) := rfl
+
+def redTorsionEquiv (W : WeierstrassCurve H) [W.IsElliptic] (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) [(specialFibre W).IsElliptic] (p : ℕ) [Fact p.Prime] :
+    Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ) ≃+
+      Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ) :=
+  Classical.choose (exists_torsionBy_reduction_addEquiv W hW hΔ p)
+
+theorem redTorsionEquiv_spec (W : WeierstrassCurve H) [W.IsElliptic] (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) [(specialFibre W).IsElliptic] (p : ℕ) [Fact p.Prime]
+    (P : Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ)) (x y : H)
+    (h : W.toAffine.Nonsingular x y)
+    (hP : (P : W.toAffine.Point) = WeierstrassCurve.Affine.Point.some x y h) :
+    ∃ h₀ : (specialFibre W).toAffine.Nonsingular (x.coeff 0) (y.coeff 0),
+      ((redTorsionEquiv W hW hΔ p P :
+            Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ)) :
+          (specialFibre W).toAffine.Point) =
+        WeierstrassCurve.Affine.Point.some (x.coeff 0) (y.coeff 0) h₀ :=
+  Classical.choose_spec (exists_torsionBy_reduction_addEquiv W hW hΔ p) P x y h hP
+
+def cycRed (W : WeierstrassCurve H) [W.IsElliptic] (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0)
+    [(specialFibre W).IsElliptic] (p : ℕ) [Fact p.Prime] :
+    CycSubH W p ≃ CycSub (specialFibre W) p :=
+  (cycOfTorsionBy W.toAffine.Point p).trans <|
+    (cycOfCongr (redTorsionEquiv W hW hΔ p) p).trans
+      (cycOfTorsionBy (specialFibre W).toAffine.Point p).symm
+
+def bridge3Specialise (p : ℕ) [Fact p.Prime] [NeZero p] (j₀ : Qbar) :
+    CycSubH (nearCurve j₀) p ≃ CycSub (WeierstrassCurve.ofJ j₀) p :=
+  (cycScale p j₀).trans <|
+    (cycRed (goodModel j₀) (goodModel_spec j₀).1 (goodModel_spec j₀).2 p).trans
+      (cycOfCongr (fibreAddEquiv j₀) p)
+
+theorem algebraMap_H_apply (q : Qbar) : (algebraMap Qbar H) q = HahnSeries.C q := by
+  rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_eq, HahnSeries.ofPowerSeries_C]
+
+theorem map_jNear_of_fixes_C_of_fixes_single_one (j₀ : Qbar) (τ : H →+* H)
+    (hC : ∀ q : Qbar, τ (HahnSeries.C q) = HahnSeries.C q)
+    (h1 : τ (HahnSeries.single (1 : ℚ) (1 : Qbar)) = HahnSeries.single 1 1) :
+    τ (jNear j₀) = jNear j₀ := by
+  rw [jNear, map_add, hC, h1]
+
+theorem nearCurve_map_of_fixes_jNear (j₀ : Qbar) (τ : H →+* H)
+    (hj : τ (jNear j₀) = jNear j₀) :
+    (nearCurve j₀).map τ = nearCurve j₀ := by
+  rw [nearCurve_eq_ofJNe0Or1728, map_ofJNe0Or1728, hj, ← nearCurve_eq_ofJNe0Or1728]
+
+theorem nearCurve_map_of_fixes_C_of_fixes_single_one (j₀ : Qbar) (τ : H →+* H)
+    (hC : ∀ q : Qbar, τ (HahnSeries.C q) = HahnSeries.C q)
+    (h1 : τ (HahnSeries.single (1 : ℚ) (1 : Qbar)) = HahnSeries.single 1 1) :
+    (nearCurve j₀).map τ = nearCurve j₀ :=
+  nearCurve_map_of_fixes_jNear j₀ τ (map_jNear_of_fixes_C_of_fixes_single_one j₀ τ hC h1)
+
+theorem nearCurve_map_of_mem_monodromy (j₀ : Qbar) {m : H ≃ₐ[Qbar] H}
+    (hm : m ∈ HahnSeries.monodromy Qbar) :
+    (nearCurve j₀).map (m : H →+* H) = nearCurve j₀ :=
+  nearCurve_map_of_fixes_C_of_fixes_single_one j₀ (m : H →+* H)
+    (fun q => by rw [← algebraMap_H_apply]; exact m.commutes q)
+    (HahnSeries.fixes_single_one_of_mem_monodromy hm)
+
+def nearTransport (j₀ : Qbar) (m : HahnSeries.monodromy Qbar) :
+    (nearCurve j₀).toAffine.Point ≃+ (nearCurve j₀).toAffine.Point :=
+  WeierstrassCurve.Affine.Point.fixedTransport (m : H ≃ₐ[Qbar] H) (nearCurve j₀)
+    (nearCurve_map_of_mem_monodromy j₀ m.2)
+
+theorem nearTransport_some (j₀ : Qbar) (m : HahnSeries.monodromy Qbar) (x y : H)
+    (h : (nearCurve j₀).toAffine.Nonsingular x y) :
+    nearTransport j₀ m (.some x y h) =
+      .some ((m : H ≃ₐ[Qbar] H) x) ((m : H ≃ₐ[Qbar] H) y)
+        (WeierstrassCurve.Affine.Point.nonsingular_of_fixed _ _
+          (nearCurve_map_of_mem_monodromy j₀ m.2) h) :=
+  WeierstrassCurve.Affine.Point.fixedTransport_some
+    (m : H ≃ₐ[Qbar] H) (nearCurve j₀) (nearCurve_map_of_mem_monodromy j₀ m.2) x y h
+
+def b3Act (j₀ : Qbar) (m : HahnSeries.monodromy Qbar) :
+    AddSubgroup (nearCurve j₀).toAffine.Point → AddSubgroup (nearCurve j₀).toAffine.Point :=
+  AddSubgroup.map ((nearTransport j₀ m : _ ≃+ _) : _ →+ _)
+
+theorem b3Act_zmultiples (j₀ : Qbar) (m : HahnSeries.monodromy Qbar)
+    (g : (nearCurve j₀).toAffine.Point) :
+    b3Act j₀ m (AddSubgroup.zmultiples g) = AddSubgroup.zmultiples (nearTransport j₀ m g) :=
+  AddMonoidHom.map_zmultiples _ g
+
+end ModularCurve.B3
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_SpecialisationVocab.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_SpecialisationVocab.lean
new file mode 100644
index 0000000000..2adcf4eb91
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_SpecialisationVocab.lean
@@ -0,0 +1,204 @@
+/-
+Based on Prove2Me node ModularCurve_SpecialisationVocab
+(b5563856-e1cf-5d26-9984-b922e6dffa13) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EMD
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_TatePoint
+
+/-!
+# Integral Hahn series, specialisation and good Weierstrass models
+
+Definition: `ModularCurve_SpecialisationVocab` (`b5563856-e1cf-5d26-9984-b922e6dffa13`), by Claude,
+2026-09-05.
+
+The ambient field is $H = \mathrm{HahnSeries}\,\mathbb{Q}\,\bar{\mathbb{Q}}$, the field of Hahn
+series with rational exponents and coefficients in $\bar{\mathbb{Q}} =$ `AlgebraicClosure ℚ`.
+`integralO` is the subring of those $x \in H$ with $0 \le x.\mathrm{orderTop}$, i.e. series
+supported in nonnegative exponents, and `mem_integralO` records this membership criterion; `resO` is
+the ring homomorphism `integralO` $\to \bar{\mathbb{Q}}$ sending $x$ to its coefficient at exponent
+$0$. That this is multiplicative is the content of the preparatory lemmas
+`coeff_zero_mul_of_integral` and `coeff_zero_pow_of_integral` (with `leadingCoeff_eq_coeff_order`
+and `orderTop_pow_nonneg` as auxiliaries): for series of nonnegative order the $0$-th coefficient is
+multiplicative, and correspondingly on powers.
+
+For a Weierstrass curve $W$ over $H$, `IntegralCoeffs W` is the conjunction that each of $a_1, a_2,
+a_3, a_4, a_6$ has nonnegative `orderTop` — a predicate on the chosen Weierstrass presentation, not
+on an isomorphism class — and `specialFibre W` is the Weierstrass curve over $\bar{\mathbb{Q}}$
+whose coefficients are the $0$-th coefficients of those of $W$.
+
+`sU q` is the unit of $H$ given by the single monomial of exponent $q$ and coefficient $1$, with
+inverse the monomial of exponent $-q$. `scaleVC j₀` is a Mathlib variable change $(u, r, s, t)$ over
+$H$, defined by cases on $j_0$: for $j_0 = 0$ it is $\bigl(\mathrm{sU}(2/12),\ -(\mathrm{jNear}\,0 -
+1728)^2/12,\ -(\mathrm{jNear}\,0 - 1728)/2,\ (\mathrm{jNear}\,0 - 1728)^3/24\bigr)$; for $j_0 =
+1728$ it is $(\mathrm{sU}(9/12), 0, 0, 0)$; otherwise the identity. `goodModel j₀` is the result of
+applying `scaleVC j₀` to `nearCurve j₀`, the curve `ofJ (jNear j₀)` attached to the Hahn series $j_0
++ s$. The case lemmas `scaleVC_zero`, `scaleVC_1728`, `scaleVC_of_ne` and `goodModel_eq_nearCurve`
+evaluate these definitions, the last asserting that away from $j_0 \in \{0, 1728\}$ the good model
+is the near-curve itself.
+
+**Relation to Mathlib.** `WeierstrassCurve`, `VariableChange` and its action,
+`WeierstrassCurve.ofJ`, and the Hahn-series `order`/`orderTop`/`leadingCoeff` API are Mathlib's; the
+subring of Hahn series of nonnegative order, its residue map to the coefficient field, and the
+predicates and models `IntegralCoeffs`, `specialFibre`, `sU`, `scaleVC`, `goodModel` are the
+project's own.
+
+**Where it is used.** These notions provide the specialisation bridge for the embedding–moduli
+dictionary at a fixed $j$-invariant $j_0 \in \bar{\mathbb{Q}}$: the curve `nearCurve j₀` over $H$
+has $j$-invariant the transcendental series $j_0 + s$, and the variable change `scaleVC j₀` puts it
+into a model whose coefficients lie in `integralO`, so that `resO` applied coefficientwise (i.e.
+`specialFibre`) yields a Weierstrass curve over $\bar{\mathbb{Q}}$ with $j$-invariant $j_0$. This is
+the mechanism by which statements about cyclic subgroups and embeddings over the Hahn-series field
+are transported to an elliptic curve over $\bar{\mathbb{Q}}$, as required by the predicate `EMD`.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open scoped Classical
+
+noncomputable section
+
+open ModularCurve WeierstrassCurve Polynomial
+
+namespace ModularCurve.B3
+
+open ModularCurve.TatePoint
+
+theorem leadingCoeff_eq_coeff_order {x : H} (hx : x ≠ 0) :
+    x.leadingCoeff = x.coeff x.order := by
+  rw [HahnSeries.leadingCoeff_of_ne_zero hx]
+  congr 1
+  rw [WithTop.untop_eq_iff]
+  exact (HahnSeries.order_eq_orderTop_of_ne_zero hx).symm
+
+theorem coeff_zero_mul_of_integral {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop) :
+    (x * y).coeff 0 = x.coeff 0 * y.coeff 0 := by
+  rcases hx.lt_or_eq with h1 | h1
+  · have hx0 : x.coeff 0 = 0 := HahnSeries.coeff_eq_zero_of_lt_orderTop h1
+    have hxy : (0 : WithTop ℚ) < (x * y).orderTop := by
+      rw [HahnSeries.orderTop_mul]
+      exact lt_of_lt_of_le h1 (le_add_of_nonneg_right hy)
+    rw [HahnSeries.coeff_eq_zero_of_lt_orderTop hxy, hx0, zero_mul]
+  · rcases hy.lt_or_eq with h2 | h2
+    · have hy0 : y.coeff 0 = 0 := HahnSeries.coeff_eq_zero_of_lt_orderTop h2
+      have hxy : (0 : WithTop ℚ) < (x * y).orderTop := by
+        rw [HahnSeries.orderTop_mul]
+        exact lt_of_lt_of_le h2 (le_add_of_nonneg_left hx)
+      rw [HahnSeries.coeff_eq_zero_of_lt_orderTop hxy, hy0, mul_zero]
+    · have hx0 : x ≠ 0 := HahnSeries.orderTop_ne_top.mp (by rw [← h1]; simp)
+      have hy0 : y ≠ 0 := HahnSeries.orderTop_ne_top.mp (by rw [← h2]; simp)
+      have hordx : x.order = 0 := by
+        have h : (x.order : WithTop ℚ) = 0 :=
+          (HahnSeries.order_eq_orderTop_of_ne_zero hx0).trans h1.symm
+        exact_mod_cast h
+      have hordy : y.order = 0 := by
+        have h : (y.order : WithTop ℚ) = 0 :=
+          (HahnSeries.order_eq_orderTop_of_ne_zero hy0).trans h2.symm
+        exact_mod_cast h
+      have key := HahnSeries.coeff_mul_order_add_order x y
+      rw [hordx, hordy, add_zero] at key
+      rw [key, leadingCoeff_eq_coeff_order hx0, leadingCoeff_eq_coeff_order hy0,
+        hordx, hordy]
+
+theorem orderTop_pow_nonneg {x : H} (hx : 0 ≤ x.orderTop) (k : ℕ) :
+    0 ≤ (x ^ k : H).orderTop := by
+  induction k with
+  | zero => simp [HahnSeries.orderTop_one]
+  | succ k ih =>
+    rw [pow_succ, HahnSeries.orderTop_mul]
+    exact add_nonneg ih hx
+
+theorem coeff_zero_pow_of_integral {x : H} (hx : 0 ≤ x.orderTop) (k : ℕ) :
+    (x ^ k : H).coeff 0 = x.coeff 0 ^ k := by
+  induction k with
+  | zero => simp [HahnSeries.coeff_one]
+  | succ k ih =>
+    rw [pow_succ, pow_succ, coeff_zero_mul_of_integral (orderTop_pow_nonneg hx k) hx, ih]
+
+def integralO : Subring H where
+  carrier := {x : H | 0 ≤ x.orderTop}
+  zero_mem' := by
+    simp only [Set.mem_ofPred_eq, HahnSeries.orderTop_zero]
+    exact le_top
+  one_mem' := by
+    simp only [Set.mem_ofPred_eq, HahnSeries.orderTop_one, le_refl]
+  add_mem' := fun {a b} ha hb => by
+    simp only [Set.mem_ofPred_eq] at ha hb ⊢
+    exact le_trans (le_min ha hb) HahnSeries.min_orderTop_le_orderTop_add
+  mul_mem' := fun {a b} ha hb => by
+    simp only [Set.mem_ofPred_eq, HahnSeries.orderTop_mul]
+    exact add_nonneg ha hb
+  neg_mem' := fun {a} ha => by
+    simpa only [Set.mem_ofPred_eq, HahnSeries.orderTop_neg] using ha
+
+theorem mem_integralO {x : H} : x ∈ integralO ↔ 0 ≤ x.orderTop := by exact Iff.rfl
+
+def resO : integralO →+* Qbar where
+  toFun x := (x : H).coeff 0
+  map_one' := by
+    rw [OneMemClass.coe_one, HahnSeries.coeff_one, ite_eq_left rfl]
+  map_mul' x y := by
+    rw [Subring.coe_mul]
+    exact coeff_zero_mul_of_integral (mem_integralO.mp x.2) (mem_integralO.mp y.2)
+  map_zero' := by
+    rw [ZeroMemClass.coe_zero, HahnSeries.coeff_zero]
+  map_add' x y := by
+    rw [Subring.coe_add, HahnSeries.coeff_add]
+
+@[simp] theorem resO_apply (x : integralO) : resO x = (x : H).coeff 0 := rfl
+
+def IntegralCoeffs (W : WeierstrassCurve H) : Prop :=
+  0 ≤ W.a₁.orderTop ∧ 0 ≤ W.a₂.orderTop ∧ 0 ≤ W.a₃.orderTop ∧
+    0 ≤ W.a₄.orderTop ∧ 0 ≤ W.a₆.orderTop
+
+def specialFibre (W : WeierstrassCurve H) : WeierstrassCurve Qbar :=
+  ⟨W.a₁.coeff 0, W.a₂.coeff 0, W.a₃.coeff 0, W.a₄.coeff 0, W.a₆.coeff 0⟩
+
+def sU (q : ℚ) : Hˣ where
+  val := HahnSeries.single q 1
+  inv := HahnSeries.single (-q) 1
+  val_inv := by
+    rw [HahnSeries.single_mul_single, add_neg_cancel, mul_one, HahnSeries.single_zero_one]
+  inv_val := by
+    rw [HahnSeries.single_mul_single, neg_add_cancel, mul_one, HahnSeries.single_zero_one]
+
+@[simp] theorem val_sU (q : ℚ) : ((sU q : Hˣ) : H) = HahnSeries.single q 1 := rfl
+
+@[simp] theorem val_inv_sU (q : ℚ) : (((sU q)⁻¹ : Hˣ) : H) = HahnSeries.single (-q) 1 := rfl
+
+def scaleVC (j₀ : Qbar) : VariableChange H :=
+  if j₀ = 0 then
+    ⟨sU (2 / 12), -(jNear 0 - 1728) ^ 2 / 12, -(jNear 0 - 1728) / 2, (jNear 0 - 1728) ^ 3 / 24⟩
+  else if j₀ = 1728 then ⟨sU (9 / 12), 0, 0, 0⟩
+  else 1
+
+def goodModel (j₀ : Qbar) : WeierstrassCurve H := scaleVC j₀ • nearCurve j₀
+
+theorem scaleVC_zero : scaleVC 0 =
+    ⟨sU (2 / 12), -(jNear 0 - 1728) ^ 2 / 12, -(jNear 0 - 1728) / 2,
+      (jNear 0 - 1728) ^ 3 / 24⟩ := by
+  rw [scaleVC, ite_eq_left rfl]
+
+theorem scaleVC_1728 : scaleVC 1728 = ⟨sU (9 / 12), 0, 0, 0⟩ := by
+  rw [scaleVC, ite_eq_right (by norm_num), ite_eq_left rfl]
+
+theorem scaleVC_of_ne {j₀ : Qbar} (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) : scaleVC j₀ = 1 := by
+  rw [scaleVC, ite_eq_right h0, ite_eq_right h1728]
+
+theorem goodModel_eq_nearCurve {j₀ : Qbar} (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) :
+    goodModel j₀ = nearCurve j₀ := by
+  rw [goodModel, scaleVC_of_ne h0 h1728, one_smul]
+
+end ModularCurve.B3
+
+end
+
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_TateFormal.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_TateFormal.lean
new file mode 100644
index 0000000000..e59be257d6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_TateFormal.lean
@@ -0,0 +1,213 @@
+/-
+Based on Prove2Me node ModularCurve_TateFormal
+(20b0e9f1-9a86-5142-af49-1cf604496f7c) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Weierstrass
+
+/-!
+# Formal Tate curve over ℤ⟦q⟧ and over K((q))
+
+Definition: `ModularCurve_TateFormal` (`20b0e9f1-9a86-5142-af49-1cf604496f7c`), by Claude,
+2026-09-05.
+
+The module sets up the Tate Weierstrass model as a purely formal object. For a natural number $d$,
+`tateB d` is the integer quotient $(5d^3+7d^5)/12$, and `twelve_mul_tateB` records that the division
+is exact: $12\cdot\mathtt{tateB}\,d = 5d^3+7d^5$ for every $d$ (proved by a case analysis over
+residues modulo $12$). The two nonzero coefficients are power series over $\mathbb{Z}$: `tateA4` has
+$n$-th coefficient $-\sum_{d\mid n}5d^3 = -5\sigma_3(n)$ and `tateA6` has $n$-th coefficient
+$-\sum_{d\mid n}\mathtt{tateB}\,d$, i.e. $-(5\sigma_3(n)+7\sigma_5(n))/12$, the division by $12$
+being carried out divisor by divisor inside $\mathbb{Z}$. Since $0$ has no divisors, both constant
+coefficients vanish; the coefficient lemmas also give $-5$ and $-1$ in degree $1$. Alongside these,
+`eisenstein6` is the power series with constant coefficient $1$ and $n$-th coefficient
+$-504\sigma_5(n)$ for $n\ge 1$. The curve `tatePowerSeries` is the Mathlib `WeierstrassCurve` over
+$\mathbb{Z}\llbracket q\rrbracket$ with
+$(a_1,a_2,a_3,a_4,a_6)=(1,0,0,\mathtt{tateA4},\mathtt{tateA6})$, that is $y^2+xy=x^3+a_4x+a_6$, and
+simp lemmas expose its coefficients. For a commutative ring $K$, `laurentOfInt K` is the ring
+homomorphism $\mathbb{Z}\llbracket q\rrbracket \to K((q))$ obtained by reducing coefficients along
+$\mathbb{Z}\to K$ and viewing the result as a Laurent series, and `tateLaurent K` is the base change
+of `tatePowerSeries` along it. The instance `instIsElliptic_tateLaurent` asserts that `tateLaurent
+K` is elliptic in Mathlib's sense, the discriminant being a unit; it is obtained from $\Delta$
+having constant coefficient $0$ and coefficient $1$ in degree $1$, so that $\Delta =
+q\cdot(\text{unit})$ and $q$ is invertible in $K((q))$.
+
+**Relation to Mathlib.** Mathlib's `WeierstrassCurve`, its base change along a ring homomorphism,
+its discriminant and the predicate `IsElliptic` (discriminant a unit) are used as given; the Tate
+model itself, its integral coefficient series and the homomorphism $\mathbb{Z}\llbracket q\rrbracket
+\to K((q))$ are the project's own definitions.
+
+**Where it is used.** The model is formal throughout: nothing is evaluated at a value of $q$, and no
+uniformisation, point or torsion structure is introduced here. It supplies the integral Weierstrass
+model over $\mathbb{Z}\llbracket q\rrbracket$, specialising to every coefficient ring including
+residue characteristics $2$ and $3$, against which the $q$-expansion vocabulary of the modular-curve
+development (`eisenstein4`, `jNum`, `jq`) is later compared.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open PowerSeries HahnSeries
+
+namespace ModularCurve
+
+def tateB (d : ℕ) : ℤ := (5 * (d : ℤ) ^ 3 + 7 * (d : ℤ) ^ 5) / 12
+
+theorem twelve_mul_tateB (d : ℕ) : 12 * tateB d = 5 * (d : ℤ) ^ 3 + 7 * (d : ℤ) ^ 5 := by
+  have key : ∀ c : ℤ, (12 : ℤ) ∣ 5 * c ^ 3 + 7 * c ^ 5 := by
+    intro c
+    have hr : c % 12 ≡ c [ZMOD 12] := Int.mod_modEq c 12
+    have hcong : 5 * (c % 12) ^ 3 + 7 * (c % 12) ^ 5 ≡ 5 * c ^ 3 + 7 * c ^ 5 [ZMOD 12] :=
+      ((hr.pow 3).mul_left 5).add ((hr.pow 5).mul_left 7)
+    have h12 : c % 12 = 0 ∨ c % 12 = 1 ∨ c % 12 = 2 ∨ c % 12 = 3 ∨ c % 12 = 4 ∨ c % 12 = 5 ∨
+        c % 12 = 6 ∨ c % 12 = 7 ∨ c % 12 = 8 ∨ c % 12 = 9 ∨ c % 12 = 10 ∨ c % 12 = 11 := by
+      omega
+    have hres : 5 * (c % 12) ^ 3 + 7 * (c % 12) ^ 5 ≡ 0 [ZMOD 12] := by
+      rcases h12 with h | h | h | h | h | h | h | h | h | h | h | h <;> rw [h] <;> decide
+    exact Int.modEq_zero_iff_dvd.mp (hcong.symm.trans hres)
+  rw [tateB]
+  exact Int.mul_ediv_cancel' (key _)
+
+def tateA4 : PowerSeries ℤ :=
+  PowerSeries.mk fun n => -∑ d ∈ n.divisors, (5 * (d : ℤ) ^ 3)
+
+def tateA6 : PowerSeries ℤ :=
+  PowerSeries.mk fun n => -∑ d ∈ n.divisors, tateB d
+
+def eisenstein6 : PowerSeries ℤ :=
+  PowerSeries.mk fun n => if n = 0 then 1 else -504 * ∑ d ∈ n.divisors, (d : ℤ) ^ 5
+
+theorem coeff_tateA4 (n : ℕ) :
+    PowerSeries.coeff n tateA4 = -∑ d ∈ n.divisors, (5 * (d : ℤ) ^ 3) :=
+  PowerSeries.coeff_mk n _
+
+theorem coeff_tateA6 (n : ℕ) :
+    PowerSeries.coeff n tateA6 = -∑ d ∈ n.divisors, tateB d :=
+  PowerSeries.coeff_mk n _
+
+theorem coeff_zero_tateA4 : PowerSeries.coeff 0 tateA4 = 0 := by
+  rw [coeff_tateA4, Nat.divisors_zero, Finset.sum_empty, neg_zero]
+
+theorem coeff_zero_tateA6 : PowerSeries.coeff 0 tateA6 = 0 := by
+  rw [coeff_tateA6, Nat.divisors_zero, Finset.sum_empty, neg_zero]
+
+theorem constantCoeff_tateA4 : PowerSeries.constantCoeff tateA4 = 0 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff_apply]
+  exact coeff_zero_tateA4
+
+theorem constantCoeff_tateA6 : PowerSeries.constantCoeff tateA6 = 0 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff_apply]
+  exact coeff_zero_tateA6
+
+theorem constantCoeff_eisenstein6 : PowerSeries.constantCoeff eisenstein6 = 1 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff]
+  simp [eisenstein6]
+
+theorem coeff_one_tateA4 : PowerSeries.coeff 1 tateA4 = -5 := by
+  rw [coeff_tateA4, Nat.divisors_one, Finset.sum_singleton]
+  norm_num
+
+theorem coeff_one_tateA6 : PowerSeries.coeff 1 tateA6 = -1 := by
+  have h : tateB 1 = 1 := by norm_num [tateB]
+  rw [coeff_tateA6, Nat.divisors_one, Finset.sum_singleton, h]
+
+def tatePowerSeries : WeierstrassCurve (PowerSeries ℤ) := ⟨1, 0, 0, tateA4, tateA6⟩
+
+@[simp] theorem tatePowerSeries_a₁ : tatePowerSeries.a₁ = 1 := rfl
+@[simp] theorem tatePowerSeries_a₂ : tatePowerSeries.a₂ = 0 := rfl
+@[simp] theorem tatePowerSeries_a₃ : tatePowerSeries.a₃ = 0 := rfl
+@[simp] theorem tatePowerSeries_a₄ : tatePowerSeries.a₄ = tateA4 := rfl
+@[simp] theorem tatePowerSeries_a₆ : tatePowerSeries.a₆ = tateA6 := rfl
+
+def laurentOfInt (K : Type*) [CommRing K] : PowerSeries ℤ →+* LaurentSeries K :=
+  (HahnSeries.ofPowerSeries ℤ K).comp (PowerSeries.map (Int.castRingHom K))
+
+theorem laurentOfInt_apply (K : Type*) [CommRing K] (f : PowerSeries ℤ) :
+    laurentOfInt K f = HahnSeries.ofPowerSeries ℤ K (f.map (Int.castRingHom K)) := rfl
+
+def tateLaurent (K : Type*) [CommRing K] : WeierstrassCurve (LaurentSeries K) :=
+  tatePowerSeries.map (laurentOfInt K)
+
+@[simp] theorem tateLaurent_a₄ (K : Type*) [CommRing K] :
+    (tateLaurent K).a₄ = laurentOfInt K tateA4 := rfl
+
+@[simp] theorem tateLaurent_a₆ (K : Type*) [CommRing K] :
+    (tateLaurent K).a₆ = laurentOfInt K tateA6 := rfl
+
+instance instIsElliptic_tateLaurent (K : Type*) [CommRing K] : (tateLaurent K).IsElliptic := by
+  constructor
+  have hΔeq : tatePowerSeries.Δ =
+      -tateA6 + tateA4 ^ 2 - PowerSeries.C 64 * tateA4 ^ 3 - PowerSeries.C 432 * tateA6 ^ 2
+        + PowerSeries.C 72 * (tateA4 * tateA6) := by
+    rw [show (PowerSeries.C (64 : ℤ)) = (64 : PowerSeries ℤ) from map_ofNat _ 64,
+      show (PowerSeries.C (432 : ℤ)) = (432 : PowerSeries ℤ) from map_ofNat _ 432,
+      show (PowerSeries.C (72 : ℤ)) = (72 : PowerSeries ℤ) from map_ofNat _ 72]
+    simp only [WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄, WeierstrassCurve.b₆,
+      WeierstrassCurve.b₈, tatePowerSeries_a₁, tatePowerSeries_a₂, tatePowerSeries_a₃,
+      tatePowerSeries_a₄, tatePowerSeries_a₆]
+    ring
+  have hc0 : PowerSeries.constantCoeff tatePowerSeries.Δ = 0 := by
+    rw [hΔeq]
+    simp only [map_add, map_sub, map_neg, map_mul, map_pow, PowerSeries.constantCoeff_C,
+      constantCoeff_tateA4, constantCoeff_tateA6]
+    ring
+  have hmul1 : ∀ f g : PowerSeries ℤ, PowerSeries.coeff 1 (f * g) =
+      PowerSeries.coeff 0 f * PowerSeries.coeff 1 g +
+        PowerSeries.coeff 1 f * PowerSeries.coeff 0 g := by
+    intro f g
+    rw [PowerSeries.coeff_mul, Finset.Nat.sum_antidiagonal_eq_sum_range_succ_mk,
+      Finset.sum_range_succ, Finset.sum_range_succ, Finset.sum_range_zero]
+    norm_num
+  have h420 : PowerSeries.coeff 0 (tateA4 ^ 2) = 0 := by
+    rw [PowerSeries.coeff_zero_eq_constantCoeff_apply, map_pow, constantCoeff_tateA4]
+    norm_num
+  have hsq4 : PowerSeries.coeff 1 (tateA4 ^ 2) = 0 := by
+    rw [pow_two, hmul1, coeff_zero_tateA4]
+    norm_num
+  have hsq6 : PowerSeries.coeff 1 (tateA6 ^ 2) = 0 := by
+    rw [pow_two, hmul1, coeff_zero_tateA6]
+    norm_num
+  have hcb4 : PowerSeries.coeff 1 (tateA4 ^ 3) = 0 := by
+    rw [show tateA4 ^ 3 = tateA4 ^ 2 * tateA4 from pow_succ tateA4 2, hmul1, h420, hsq4,
+      coeff_zero_tateA4]
+    norm_num
+  have hprod : PowerSeries.coeff 1 (tateA4 * tateA6) = 0 := by
+    rw [hmul1, coeff_zero_tateA4, coeff_zero_tateA6]
+    norm_num
+  have hc1 : PowerSeries.coeff 1 tatePowerSeries.Δ = 1 := by
+    rw [hΔeq]
+    simp only [map_add, map_sub, map_neg, PowerSeries.coeff_C_mul, hsq4, hsq6, hcb4, hprod,
+      coeff_one_tateA6]
+    norm_num
+  obtain ⟨u, hXu⟩ : (PowerSeries.X : PowerSeries ℤ) ∣ tatePowerSeries.Δ :=
+    PowerSeries.X_dvd_iff.mpr hc0
+  have h1u : PowerSeries.coeff 1 tatePowerSeries.Δ = PowerSeries.constantCoeff u := by
+    rw [hXu, ← PowerSeries.coeff_zero_eq_constantCoeff_apply,
+      show (1 : ℕ) = 0 + 1 from rfl, PowerSeries.coeff_succ_X_mul]
+  have hu : IsUnit u := by
+    rw [PowerSeries.isUnit_iff_constantCoeff, ← h1u, hc1]
+    exact isUnit_one
+  have hΔL : (tateLaurent K).Δ = laurentOfInt K tatePowerSeries.Δ := by
+    rw [tateLaurent, WeierstrassCurve.map_Δ]
+  rw [hΔL, hXu, map_mul]
+  refine IsUnit.mul ?_ (hu.map (laurentOfInt K))
+  have hX : laurentOfInt K PowerSeries.X = HahnSeries.single (1 : ℤ) 1 := by
+    rw [laurentOfInt_apply, PowerSeries.map_X, HahnSeries.ofPowerSeries_X]
+  rw [hX]
+  exact ⟨⟨HahnSeries.single (1 : ℤ) 1, HahnSeries.single (-1 : ℤ) 1,
+    by simp [HahnSeries.single_mul_single], by simp [HahnSeries.single_mul_single]⟩, rfl⟩
+
+end ModularCurve
+
+end
+
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_TatePoint.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_TatePoint.lean
new file mode 100644
index 0000000000..4034509a43
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_TatePoint.lean
@@ -0,0 +1,163 @@
+/-
+Based on Prove2Me node ModularCurve_TatePoint
+(41bdf42f-e310-5610-9dd4-328644c4e5ee) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.ModelsWithJ
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_TateFormal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluQuotientMap
+
+/-!
+# Near curves over Hahn series, Tate-point Vélu slots, moduli dictionary
+
+Definition: `ModularCurve_TatePoint` (`41bdf42f-e310-5610-9dd4-328644c4e5ee`), by Claude,
+2026-09-05.
+
+Two families of objects are fixed. Over the field $H$ of Hahn series with rational exponents and
+coefficients in $\bar{\mathbb Q}$ (written `Qbar`), `jNear j₀` is the element $j_0 + s$ (constant
+term $j_0$ plus the monomial of exponent $1$ with coefficient $1$) and `nearCurve j₀` is Mathlib's
+`ofJ` at that value, an elliptic curve over $H$; `nearCurve_j` records that its $j$-invariant is
+$j_0+s$ and `nearCurve_j_transcendental` that this is transcendental over $\bar{\mathbb Q}$, since
+an element of $H$ algebraic over an algebraically closed coefficient field would be a constant. For
+a Weierstrass curve $E$ over $H$, `CycSubH E N` is the type of additive subgroups of the affine
+point group $E(H)$ of the form $\mathbb Z g$ with $g$ of additive order exactly $N$, and `RootsAt
+data jv` is the type of roots $y \in H$ of the one-variable polynomial obtained from the bivariate
+$\Phi$ of `data` by substituting $jv$ for the inner variable. `ModuliDictionary p data` asserts: for
+every elliptic $E/H$ with $j(E)$ transcendental over $\bar{\mathbb Q}$ there is a bijection $e$ from
+`RootsAt data E.j` to `CycSubH E p` such that each root $r$ admits a finite set $S$ of pairs which
+is an odd Vélu set for $E$ (points on the affine equation, $\mathrm{gy}\neq 0$, injective
+$x$-coordinates), whose members lie in the subgroup $e(r)$, and whose Vélu quotient is elliptic with
+$j$-invariant $r$.
+
+At the Tate point, over a field $K$ that is a $\mathbb Q$-algebra, with $p$ prime and $\zeta \in
+K^\times$: `basePoint K p` is the formal Tate curve over $K((q))$ with $q$ replaced by $q^p$, and
+for a family `veluSlotSet` of $p+1$ finite sets of pairs indexed by `Fin (p+1)`, `slotQuotient` is
+the corresponding Vélu quotient of `basePoint`. Under the hypothesis that each slot quotient is
+elliptic, `W4Conclusions data` is a `Prop`-valued structure whose fields assert: each slot set is an
+odd Vélu set; for $b : \mathrm{Fin}\,p$ the $\zeta^b$-twist of the Tate curve has $j$-invariant
+`PhiGen.conj p ζ b.succ`; the $q \mapsto q^{p^2}$ specialisation has $j$-invariant `PhiGen.conj p ζ
+0`; the $b$-th successor slot quotient equals that twisted Tate curve; the image of $\Phi$ under the
+composite of `evalAtJ`, $q\mapsto q^p$ and the coefficient embedding into $K((q))$ factors as
+$\prod_i (X - j(\mathrm{slotQuotient}\,i))$; and the $p+1$ slot $j$-invariants are pairwise
+distinct. `W3Proper` asserts that each slot set has exactly $(p-1)/2$ elements and consists of
+positive multiples $k\cdot g$ of a single point $g$ of additive order $p$ on `basePoint K p`.
+
+**Relation to Mathlib.** `HahnSeries`, `AlgebraicClosure`, `Transcendental`, `WeierstrassCurve.ofJ`
+and the affine point group law are Mathlib's; the Vélu notions used here (`veluQuotient`, `veluGy`,
+`IsOddVeluSet`) and the modular-polynomial data type are the project's own.
+
+**Where it is used.** These declarations fix the common vocabulary in which the level-$p$ moduli
+correspondence is both produced and consumed: the theorems supplying the $p+1$ cyclic subgroups of
+order $p$ on the formal Tate curve, and the theorems deducing the dictionary between roots of the
+modular polynomial at a $j$-value and cyclic $p$-subgroups, used in the modular-curve input to the
+argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open ModularCurve WeierstrassCurve Polynomial
+
+namespace ModularCurve.TatePoint
+
+abbrev Qbar : Type := AlgebraicClosure ℚ
+
+abbrev H : Type := HahnSeries ℚ Qbar
+
+def jNear (j₀ : Qbar) : H := HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : Qbar)
+
+open scoped Classical in
+def nearCurve (j₀ : Qbar) : WeierstrassCurve H := WeierstrassCurve.ofJ (jNear j₀)
+
+open scoped Classical in
+instance instIsElliptic_nearCurve (j₀ : Qbar) : (nearCurve j₀).IsElliptic := by
+  unfold nearCurve; infer_instance
+
+open scoped Classical in
+def CycSubH (E : WeierstrassCurve H) (N : ℕ) : Type :=
+  {G : AddSubgroup E.toAffine.Point //
+    ∃ g : E.toAffine.Point, addOrderOf g = N ∧ G = AddSubgroup.zmultiples g}
+
+def RootsAt {p : ℕ} [NeZero p] (data : ModularPolynomialData p) (jv : H) : Type :=
+  {y : H // (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom H) jv)).IsRoot y}
+
+open scoped Classical in
+theorem nearCurve_j (j₀ : Qbar) : (nearCurve j₀).j = jNear j₀ :=
+  WeierstrassCurve.ofJ_j (jNear j₀)
+
+theorem nearCurve_j_transcendental (j₀ : Qbar) : Transcendental Qbar (nearCurve j₀).j := by
+  rw [nearCurve_j]
+  intro halg
+  have hdeg := IsAlgClosed.degree_eq_one_of_irreducible Qbar (minpoly.irreducible halg.isIntegral)
+  obtain ⟨c, hc⟩ := minpoly.mem_range_of_degree_eq_one Qbar _ hdeg
+  have hC : algebraMap Qbar H c = HahnSeries.C c := by
+    rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_eq, HahnSeries.ofPowerSeries_C]
+  rw [hC] at hc
+  have h1 := congrArg (fun x : H => x.coeff (1 : ℚ)) hc
+  simp only [jNear, HahnSeries.C_apply, HahnSeries.coeff_add, HahnSeries.coeff_single_same,
+    HahnSeries.coeff_single_of_ne (one_ne_zero : (1 : ℚ) ≠ 0), zero_add] at h1
+  exact zero_ne_one h1
+
+section TatePoint
+
+variable (K : Type) [Field K] [Algebra ℚ K]
+variable (p : ℕ) [Fact (Nat.Prime p)] [NeZero p] (ζ : Kˣ)
+
+def basePoint : WeierstrassCurve (LaurentSeries K) := (tateLaurent K).map (qExpand K p)
+
+variable (veluSlotSet : Fin (p + 1) → Finset (LaurentSeries K × LaurentSeries K))
+
+def slotQuotient (i : Fin (p + 1)) : WeierstrassCurve (LaurentSeries K) :=
+  (basePoint K p).veluQuotient (veluSlotSet i)
+
+variable (instQ : ∀ i, (slotQuotient K p veluSlotSet i).IsElliptic)
+
+structure W4Conclusions (data : ModularPolynomialData p) : Prop where
+  oddVeluSet : ∀ i, (basePoint K p).IsOddVeluSet (veluSlotSet i)
+  slotCurve_succ : ∀ b : Fin p,
+    ((tateLaurent K).map (qTwist (ζ ^ (b : ℕ)))).j = PhiGen.conj p ζ b.succ
+  slotCurve_zero : ((tateLaurent K).map (qExpand K (p * p))).j = PhiGen.conj p ζ 0
+  nonToric : ∀ b : Fin p,
+    slotQuotient K p veluSlotSet b.succ = (tateLaurent K).map (qTwist (ζ ^ (b : ℕ)))
+  dictionary : data.Φ.map (((coeffEmb K).comp (qExpand ℚ p)).comp evalAtJ) =
+    ∏ i : Fin (p + 1),
+      (X - C (@WeierstrassCurve.j _ _ (slotQuotient K p veluSlotSet i) (instQ i)))
+  distinct : Function.Injective fun i : Fin (p + 1) =>
+    @WeierstrassCurve.j _ _ (slotQuotient K p veluSlotSet i) (instQ i)
+
+open scoped Classical in
+def W3Proper : Prop :=
+  ∀ i, (veluSlotSet i).card = (p - 1) / 2 ∧
+    ∃ g : (basePoint K p).toAffine.Point, addOrderOf g = p ∧
+      ∀ P ∈ veluSlotSet i, ∃ (k : ℕ) (h : (basePoint K p).toAffine.Nonsingular P.1 P.2),
+        0 < k ∧ (k • g : (basePoint K p).toAffine.Point) = WeierstrassCurve.Affine.Point.some P.1
+          P.2 h
+
+end TatePoint
+
+open scoped Classical in
+def ModuliDictionary (p : ℕ) [NeZero p] (data : ModularPolynomialData p) : Prop :=
+  ∀ (E : WeierstrassCurve H) [E.IsElliptic], Transcendental Qbar E.j →
+    Nonempty {e : RootsAt data E.j ≃ CycSubH E p //
+      ∀ r : RootsAt data E.j, ∃ S : Finset (H × H),
+        E.IsOddVeluSet S ∧
+        (∀ P ∈ S, ∃ h : E.toAffine.Nonsingular P.1 P.2,
+          WeierstrassCurve.Affine.Point.some P.1 P.2 h ∈ (e r).1) ∧
+        ∃ hQ : (E.veluQuotient S).IsElliptic,
+          @WeierstrassCurve.j H _ (E.veluQuotient S) hQ = r.1}
+
+end ModularCurve.TatePoint
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_X0.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_X0.lean
new file mode 100644
index 0000000000..4d1ff7940a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_X0.lean
@@ -0,0 +1,402 @@
+/-
+Based on Prove2Me node ModularCurve_X0
+(23b22550-cc5b-5ca8-a5e3-1c4c7dd76b29) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.LaurentSeries
+public import Mathlib.RingTheory.PowerSeries.PiTopology
+public import Mathlib.RingTheory.PowerSeries.Inverse
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+public import Mathlib.RingTheory.Algebraic.Basic
+public import Mathlib.NumberTheory.Divisors
+public import Mathlib.Data.Nat.Squarefree
+
+/-!
+# Function field of X0​(N) inside Q((q))
+
+Definition: `ModularCurve_X0` (`23b22550-cc5b-5ca8-a5e3-1c4c7dd76b29`), by Claude, 2026-09-05.
+
+The module presents the modular curve $X_0(N)$ over $\mathbb{Q}$ by its function field, realised
+concretely inside the formal Laurent series field `LaurentSeries ℚ` $=\mathbb{Q}((q))$. For a
+coefficient ring $R$ and $N\neq 0$, `qExpand R N` is the ring endomorphism of `LaurentSeries R`
+obtained by embedding the index domain along $k\mapsto Nk$, i.e. the substitution $q\mapsto q^{N}$;
+it is injective, is the identity for $N=1$, fixes constants, and composes as `qExpand M ∘ qExpand N
+= qExpand (M*N)`. Over $\mathbb{Q}$ the same map is packaged as the algebra endomorphism `qExpandₐ
+N`. The $q$-expansion of the $j$-invariant is built integrally: `eisenstein4` is the power series
+with constant term $1$ and $n$-th coefficient $240\sum_{d\mid n}d^{3}$; `etaProd` $=\prod_{n\ge
+1}(1-q^{n})$ (an infinite product in the product topology on power series); `dedekindEtaUnit` is its
+$24$-th power, with constant term $1$, and `dedekindEtaUnitInv` its power-series inverse. Then
+`jNum` $=E_4^{3}\prod_{n\ge1}(1-q^{n})^{-24}$ over $\mathbb{Z}$, `jNumQ` its image over
+$\mathbb{Q}$, and `jq` $=q^{-1}E_4^{3}\prod_{n\ge1}(1-q^{n})^{-24}$; the coefficient lemmas record
+that `jq` has leading term $q^{-1}$ with coefficient $1$ and vanishes below, and that `jq ≠ 0`.
+Further, `jqN N` $=$ `qExpand ℚ N jq`, i.e. $j(q^{N})$.
+
+The fields are `modularFunctionField N` $=\mathbb{Q}(j(q),j(q^{N}))$ and `modularFunctionFieldFull
+N`, the subfield generated by `divisorExpansions N` $=\{j(q^{d}) : 0\neq d\mid N\}$; there are the
+containments $\mathbb{Q}(j)\le$ `modularFunctionField N` $\le$ `modularFunctionFieldFull N`,
+monotonicity of the full field in $N$ under divisibility, and $(q\mapsto q^{\ell})$ sends
+`modularFunctionFieldFull N` into `modularFunctionFieldFull (N*ℓ)`. Two inputs are isolated rather
+than proved. `ModularPolynomialData N` is a structure carrying a polynomial
+$\Phi\in(\mathbb{Z}[X])[Y]$ together with proofs that it is monic, that its degree in $Y$ equals
+`dedekindPsi N` $=\sum_{d\mid N,\,d\text{ squarefree}}N/d$, and that $\Phi(j(q),j(q^{N}))=0$ under
+`evalAtJ : ℤ[X] →+* ℚ((q))`, $X\mapsto j(q)$; only the level-one instance $\Phi=Y-X$ is constructed.
+`FunctionFieldGeneration M` is the proposition that $j(q^{d})\in\mathbb{Q}(j(q),j(q^{M}))$ for every
+nonzero $d\mid M$, proved here only for $M=1$. Auxiliary items `jGen`, `evalAtJGen` and
+`ModularPolynomialData.toAdjoin` read $\Phi$ as a monic polynomial over $\mathbb{Q}(j(q))$.
+
+**Relation to Mathlib.** Mathlib has no modular curve, modular polynomial or Dedekind psi function;
+these are the project's own definitions, built on Mathlib's `HahnSeries`/`LaurentSeries` API
+(`embDomainRingHom`, `ofPowerSeries`), on `PowerSeries.invOfUnit` and on infinite products in the
+product topology on power series.
+
+**Where it is used.** This is the curve layer of an algebraic presentation of $X_0(N)$ over
+$\mathbb{Q}$ by its function field, on which the later construction of $J_0(N)$ and its Hecke action
+rests; by itself it says nothing about Jacobians or Galois representations. The modular polynomial
+data and the generation predicate are carried as hypotheses by the statements that use them, with
+only the level-one cases constructed here.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section DL_unincorporated
+
+open scoped PowerSeries.WithPiTopology
+
+open PowerSeries HahnSeries IntermediateField
+
+namespace ModularCurve
+
+section QExpand
+
+variable {R : Type*} [CommRing R]
+
+variable (R) in
+def qExpand (N : ℕ) [NeZero N] : LaurentSeries R →+* LaurentSeries R :=
+  HahnSeries.embDomainRingHom (AddMonoidHom.mulLeft (N : ℤ))
+    (mul_right_injective₀ (by exact_mod_cast NeZero.ne N))
+    (fun g g' => mul_le_mul_iff_of_pos_left
+      (by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)))
+
+variable (N : ℕ) [NeZero N]
+
+@[simp]
+theorem qExpand_coeff_mul (f : LaurentSeries R) (k : ℤ) :
+    (qExpand R N f).coeff ((N : ℤ) * k) = f.coeff k :=
+  HahnSeries.embDomain_coeff
+
+theorem qExpand_coeff_of_not_dvd (f : LaurentSeries R) {k : ℤ} (hk : ¬ (N : ℤ) ∣ k) :
+    (qExpand R N f).coeff k = 0 := by
+  refine HahnSeries.embDomain_of_notMem_range ?_
+  rintro ⟨m, rfl⟩
+  exact hk ⟨m, rfl⟩
+
+@[simp]
+theorem qExpand_single (k : ℤ) (r : R) :
+    qExpand R N (HahnSeries.single k r) = HahnSeries.single ((N : ℤ) * k) r :=
+  HahnSeries.embDomain_single
+
+@[simp]
+theorem qExpand_C (r : R) : qExpand R N (HahnSeries.C r) = HahnSeries.C r :=
+  HahnSeries.embDomainRingHom_C
+
+theorem qExpand_injective : Function.Injective (qExpand R N) :=
+  HahnSeries.embDomain_injective
+
+theorem qExpand_one_apply (f : LaurentSeries R) : qExpand R 1 f = f := by
+  ext k
+  have h : ((1 : ℕ) : ℤ) * k = k := by simp
+  conv_lhs => rw [← h]
+  rw [qExpand_coeff_mul]
+
+theorem qExpand_congr {M K : ℕ} [NeZero M] [NeZero K] (h : M = K) (f : LaurentSeries R) :
+    qExpand R M f = qExpand R K f := by
+  subst h; rfl
+
+theorem qExpand_qExpand (M : ℕ) [NeZero M] (f : LaurentSeries R) :
+    qExpand R M (qExpand R N f) = qExpand R (M * N) f := by
+  ext k
+  by_cases hk : ((M : ℤ) * N) ∣ k
+  · obtain ⟨m, rfl⟩ := hk
+    trans f.coeff m
+    · rw [show (M : ℤ) * N * m = (M : ℤ) * ((N : ℤ) * m) by ring, qExpand_coeff_mul,
+        qExpand_coeff_mul]
+    · rw [show (M : ℤ) * N * m = (((M * N : ℕ) : ℤ)) * m by push_cast; ring,
+        qExpand_coeff_mul]
+  · rw [qExpand_coeff_of_not_dvd (M * N) f (by push_cast; exact hk)]
+    by_cases hkM : (M : ℤ) ∣ k
+    · obtain ⟨m, rfl⟩ := hkM
+      rw [qExpand_coeff_mul M _ m]
+      refine qExpand_coeff_of_not_dvd N _ ?_
+      rintro ⟨c, hc⟩
+      exact hk ⟨c, by rw [hc]; ring⟩
+    · exact qExpand_coeff_of_not_dvd M _ hkM
+
+end QExpand
+
+section RatAlgebra
+
+variable (N : ℕ) [NeZero N]
+
+theorem algebraMap_apply_eq_single (c : ℚ) :
+    algebraMap ℚ (LaurentSeries ℚ) c = HahnSeries.single 0 c := by
+  have h1 : algebraMap ℚ (PowerSeries ℚ) c = PowerSeries.C c := by
+    simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+  rfl
+
+def qExpandₐ : LaurentSeries ℚ →ₐ[ℚ] LaurentSeries ℚ where
+  __ := qExpand ℚ N
+  commutes' r := by
+    change qExpand ℚ N (algebraMap ℚ (LaurentSeries ℚ) r) = algebraMap ℚ (LaurentSeries ℚ) r
+    rw [algebraMap_apply_eq_single, qExpand_single, mul_zero]
+
+@[simp]
+theorem qExpandₐ_apply (f : LaurentSeries ℚ) : qExpandₐ N f = qExpand ℚ N f := rfl
+
+end RatAlgebra
+
+section JFunction
+
+def eisenstein4 : PowerSeries ℤ :=
+  PowerSeries.mk fun n => if n = 0 then 1 else 240 * ∑ d ∈ n.divisors, (d : ℤ) ^ 3
+
+@[simp]
+theorem constantCoeff_eisenstein4 : PowerSeries.constantCoeff eisenstein4 = 1 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff]
+  simp [eisenstein4]
+
+def etaProd : PowerSeries ℤ :=
+  ∏' n : ℕ, (1 - PowerSeries.X ^ (n + 1))
+
+theorem constantCoeff_etaProd : PowerSeries.constantCoeff etaProd = 1 := by
+  rw [etaProd]
+  simp [(PowerSeries.WithPiTopology.multipliable_one_sub_X_pow ℤ).map_tprod _
+    (PowerSeries.WithPiTopology.continuous_constantCoeff ℤ)]
+
+def dedekindEtaUnit : PowerSeries ℤ := etaProd ^ 24
+
+theorem constantCoeff_dedekindEtaUnit : PowerSeries.constantCoeff dedekindEtaUnit = 1 := by
+  rw [dedekindEtaUnit, map_pow, constantCoeff_etaProd, one_pow]
+
+def dedekindEtaUnitInv : PowerSeries ℤ := dedekindEtaUnit.invOfUnit 1
+
+theorem dedekindEtaUnit_mul_inv : dedekindEtaUnit * dedekindEtaUnitInv = 1 :=
+  PowerSeries.mul_invOfUnit _ _ (by rw [constantCoeff_dedekindEtaUnit]; rfl)
+
+theorem constantCoeff_dedekindEtaUnitInv :
+    PowerSeries.constantCoeff dedekindEtaUnitInv = 1 := by
+  have h := congrArg (PowerSeries.constantCoeff (R := ℤ)) dedekindEtaUnit_mul_inv
+  rwa [map_mul, constantCoeff_dedekindEtaUnit, one_mul, map_one] at h
+
+def jNum : PowerSeries ℤ := eisenstein4 ^ 3 * dedekindEtaUnitInv
+
+@[simp]
+theorem constantCoeff_jNum : PowerSeries.constantCoeff jNum = 1 := by
+  rw [jNum, map_mul, map_pow, constantCoeff_eisenstein4, constantCoeff_dedekindEtaUnitInv,
+    one_pow, one_mul]
+
+def jNumQ : PowerSeries ℚ := jNum.map (Int.castRingHom ℚ)
+
+@[simp]
+theorem constantCoeff_jNumQ : PowerSeries.constantCoeff jNumQ = 1 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff, jNumQ, PowerSeries.coeff_map,
+    PowerSeries.coeff_zero_eq_constantCoeff, constantCoeff_jNum]
+  simp
+
+def jq : LaurentSeries ℚ :=
+  HahnSeries.single (-1 : ℤ) 1 * HahnSeries.ofPowerSeries ℤ ℚ jNumQ
+
+theorem ofPowerSeries_coeff_of_neg {R : Type*} [Semiring R] (f : PowerSeries R) {k : ℤ}
+    (hk : k < 0) : (HahnSeries.ofPowerSeries ℤ R f).coeff k = 0 := by
+  rw [HahnSeries.ofPowerSeries_apply]
+  refine HahnSeries.embDomain_of_notMem_range ?_
+  rintro ⟨m, rfl⟩
+  exact absurd hk (not_lt.mpr (Int.natCast_nonneg m))
+
+theorem jq_pow (n : ℕ) :
+    jq ^ n = HahnSeries.single (-(n : ℤ)) 1 * HahnSeries.ofPowerSeries ℤ ℚ (jNumQ ^ n) := by
+  have h : n • (-1 : ℤ) = -(n : ℤ) := by simp
+  rw [jq, mul_pow, HahnSeries.single_pow, one_pow, h, ← map_pow]
+
+theorem coeff_jq_pow_self (n : ℕ) : (jq ^ n).coeff (-(n : ℤ)) = 1 := by
+  rw [jq_pow, HahnSeries.coeff_single_mul, one_mul, sub_neg_eq_add, neg_add_cancel,
+    show (0 : ℤ) = ((0 : ℕ) : ℤ) from rfl, HahnSeries.ofPowerSeries_apply_coeff,
+    PowerSeries.coeff_zero_eq_constantCoeff, map_pow, constantCoeff_jNumQ, one_pow]
+
+theorem coeff_jq_pow_of_lt {n : ℕ} {m : ℤ} (hm : m < -(n : ℤ)) : (jq ^ n).coeff m = 0 := by
+  rw [jq_pow, HahnSeries.coeff_single_mul, one_mul]
+  exact ofPowerSeries_coeff_of_neg _ (by omega)
+
+@[simp]
+theorem coeff_jq_neg_one : jq.coeff (-1 : ℤ) = 1 := by
+  have h := coeff_jq_pow_self 1
+  simpa using h
+
+theorem coeff_jq_of_lt {k : ℤ} (hk : k < -1) : jq.coeff k = 0 := by
+  have h := coeff_jq_pow_of_lt (n := 1) (m := k) (by simpa using hk)
+  simpa using h
+
+theorem jq_ne_zero : jq ≠ 0 := fun h => by simpa [h] using coeff_jq_neg_one
+
+end JFunction
+
+def jqN (N : ℕ) [NeZero N] : LaurentSeries ℚ := qExpand ℚ N jq
+
+@[simp]
+theorem jqN_one : jqN 1 = jq := qExpand_one_apply jq
+
+section NamedInputs
+
+def dedekindPsi (N : ℕ) : ℕ := ∑ d ∈ N.divisors with Squarefree d, N / d
+
+@[simp]
+theorem dedekindPsi_one : dedekindPsi 1 = 1 := by
+  rw [dedekindPsi, Nat.divisors_one, Finset.filter_singleton, ite_eq_left squarefree_one]
+  simp
+
+def evalAtJ : Polynomial ℤ →+* LaurentSeries ℚ :=
+  (Polynomial.aeval (R := ℤ) jq).toRingHom
+
+@[simp]
+theorem evalAtJ_X : evalAtJ Polynomial.X = jq := by
+  simp [evalAtJ]
+
+structure ModularPolynomialData (N : ℕ) [NeZero N] : Type where
+  Φ : Polynomial (Polynomial ℤ)
+  monic : Φ.Monic
+  natDegree_eq : Φ.natDegree = dedekindPsi N
+  eval_eq_zero : Φ.eval₂ evalAtJ (jqN N) = 0
+
+def modularPolynomialDataOne : ModularPolynomialData 1 where
+  Φ := Polynomial.X - Polynomial.C Polynomial.X
+  monic := Polynomial.monic_X_sub_C _
+  natDegree_eq := by simp
+  eval_eq_zero := by
+    simp only [Polynomial.eval₂_sub, Polynomial.eval₂_X, Polynomial.eval₂_C, jqN_one,
+      evalAtJ_X, sub_self]
+
+def FunctionFieldGeneration (M : ℕ) [NeZero M] : Prop :=
+  ∀ d : ℕ, d ∣ M → ∀ (_ : NeZero d), qExpand ℚ d jq ∈
+    IntermediateField.adjoin ℚ {jq, qExpand ℚ M jq}
+
+theorem functionFieldGeneration_one : FunctionFieldGeneration 1 := by
+  intro d hd hne
+  have := hne
+  rw [Nat.dvd_one] at hd
+  subst hd
+  exact subset_adjoin ℚ _ (Set.mem_insert_of_mem _ rfl)
+
+end NamedInputs
+
+section FunctionField
+
+variable (N : ℕ) [NeZero N]
+
+def modularFunctionField : IntermediateField ℚ (LaurentSeries ℚ) :=
+  IntermediateField.adjoin ℚ {jq, qExpand ℚ N jq}
+
+theorem jq_mem : jq ∈ modularFunctionField N :=
+  IntermediateField.subset_adjoin ℚ _ (Set.mem_insert _ _)
+
+theorem jqN_mem : qExpand ℚ N jq ∈ modularFunctionField N :=
+  IntermediateField.subset_adjoin ℚ _ (Set.mem_insert_of_mem _ rfl)
+
+theorem modularFunctionField_one : modularFunctionField 1 = ℚ⟮jq⟯ := by
+  rw [modularFunctionField, qExpand_one_apply, Set.pair_eq_singleton]
+
+theorem adjoin_jq_le : ℚ⟮jq⟯ ≤ modularFunctionField N := by
+  rw [IntermediateField.adjoin_le_iff]
+  exact Set.singleton_subset_iff.mpr (jq_mem N)
+
+end FunctionField
+
+def jGen : ℚ⟮jq⟯ := ⟨jq, IntermediateField.mem_adjoin_simple_self ℚ jq⟩
+
+def evalAtJGen : Polynomial ℤ →+* ℚ⟮jq⟯ :=
+  Polynomial.eval₂RingHom (Int.castRingHom ℚ⟮jq⟯) jGen
+
+theorem algebraMap_comp_evalAtJGen :
+    (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)).comp evalAtJGen = evalAtJ := by
+  refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+  change algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ) (evalAtJGen Polynomial.X) = evalAtJ Polynomial.X
+  rw [evalAtJ_X]
+  change algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)
+    (Polynomial.eval₂ (Int.castRingHom ℚ⟮jq⟯) jGen Polynomial.X) = jq
+  rw [Polynomial.eval₂_X]
+  rfl
+
+namespace ModularPolynomialData
+
+variable {N : ℕ} [NeZero N] (data : ModularPolynomialData N)
+
+def toAdjoin : Polynomial ℚ⟮jq⟯ := data.Φ.map evalAtJGen
+
+theorem toAdjoin_monic : data.toAdjoin.Monic := data.monic.map _
+
+end ModularPolynomialData
+
+section AllDivisors
+
+variable (N : ℕ) [NeZero N]
+
+def divisorExpansions : Set (LaurentSeries ℚ) :=
+  {x | ∃ (d : ℕ) (_ : NeZero d), d ∣ N ∧ x = qExpand ℚ d jq}
+
+omit [NeZero N] in
+theorem mem_divisorExpansions {d : ℕ} [NeZero d] (hd : d ∣ N) :
+    qExpand ℚ d jq ∈ divisorExpansions N :=
+  ⟨d, ‹_›, hd, rfl⟩
+
+def modularFunctionFieldFull : IntermediateField ℚ (LaurentSeries ℚ) :=
+  IntermediateField.adjoin ℚ (divisorExpansions N)
+
+omit [NeZero N] in
+theorem jqd_mem_full {d : ℕ} [NeZero d] (hd : d ∣ N) :
+    qExpand ℚ d jq ∈ modularFunctionFieldFull N :=
+  subset_adjoin ℚ _ (mem_divisorExpansions N hd)
+
+theorem modularFunctionField_le_full :
+    modularFunctionField N ≤ modularFunctionFieldFull N := by
+  rw [modularFunctionField, adjoin_le_iff]
+  rintro x (rfl | rfl)
+  · have h := jqd_mem_full N (one_dvd N)
+    rwa [qExpand_one_apply] at h
+  · exact jqd_mem_full N dvd_rfl
+
+theorem full_degeneracy_le {N M : ℕ} [NeZero N] [NeZero M] (h : N ∣ M) :
+    modularFunctionFieldFull N ≤ modularFunctionFieldFull M := by
+  rw [modularFunctionFieldFull, adjoin_le_iff]
+  rintro x ⟨d, hne, hdvd, rfl⟩
+  have := hne
+  exact jqd_mem_full M (hdvd.trans h)
+
+omit [NeZero N] in
+theorem full_degeneracy_map_le (ℓ : ℕ) [NeZero ℓ] :
+    (modularFunctionFieldFull N).map (qExpandₐ ℓ) ≤ modularFunctionFieldFull (N * ℓ) := by
+  rw [modularFunctionFieldFull, adjoin_map, adjoin_le_iff]
+  rintro x ⟨y, ⟨d, hne, hdvd, rfl⟩, rfl⟩
+  have := hne
+  have : NeZero (ℓ * d) := ⟨Nat.mul_ne_zero (NeZero.ne ℓ) (NeZero.ne d)⟩
+  change qExpandₐ ℓ (qExpand ℚ d jq) ∈ _
+  rw [qExpandₐ_apply, qExpand_qExpand]
+  exact jqd_mem_full (N * ℓ) ((mul_dvd_mul_left ℓ hdvd).trans (dvd_of_eq (mul_comm ℓ N)))
+
+theorem qExpandₐ_comp (ℓ ℓ' : ℕ) [NeZero ℓ] [NeZero ℓ'] :
+    (qExpandₐ ℓ).comp (qExpandₐ ℓ') = qExpandₐ (ℓ * ℓ') := by
+  refine AlgHom.ext fun f => ?_
+  simp only [AlgHom.comp_apply, qExpandₐ_apply]
+  exact qExpand_qExpand ℓ' ℓ f
+
+end AllDivisors
+
+end ModularCurve
+end DL_unincorporated
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_X0ModL.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_X0ModL.lean
new file mode 100644
index 0000000000..bced50576a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_X0ModL.lean
@@ -0,0 +1,208 @@
+/-
+Based on Prove2Me node ModularCurve_X0ModL
+(8d529f3c-af58-58c3-8775-59af521964b5) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_neg_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_pow_of_lt
+
+/-!
+# j-expansions and modular function fields over an arbitrary field
+
+Definition: `ModularCurve_X0ModL` (`8d529f3c-af58-58c3-8775-59af521964b5`), by Claude, 2026-09-05.
+
+Working inside the field of formal Laurent series $K((q))$ over a field $K$ (and, for the
+coefficient lemmas, inside $R((q))$ for a commutative ring $R$), this module assembles the
+base-changed version of the project's characteristic-zero $q$-expansion picture. The series `jqModC
+R` of the imported definition module is $q^{-1}$ times the image in $R[[q]]$ of the integral power
+series `jNum` $= E_4^3\cdot\prod_{n\ge 1}(1-q^n)^{-24}$, and `jqNModC R N` is its image under
+$q\mapsto q^N$. The lemmas record that coefficientwise application of a ring homomorphism $f\colon
+R\to S$ sends `ofPowerSeries` to `ofPowerSeries` of the mapped power series, sends `jqModC R` to
+`jqModC S` and `jqNModC R N` to `jqNModC S N`; that every coefficient of `jqModC R` is the image of
+the corresponding integer coefficient of `jqModC ℤ`; that `jqModC R ^ n` equals $q^{-n}$ times the
+$n$-th power of the mapped `jNum`; that the coefficients in degrees $< -1$ vanish; and that `jqModC
+R` is non-zero when $R$ is non-trivial. Over $\mathbb{Q}$ these objects are the rational ones
+already defined: `jqNModC ℚ N = jqN N`.
+
+Three definitions are made. First, `qExpandAlgHomC K N` upgrades the substitution ring homomorphism
+$q\mapsto q^N$ on $K((q))$ to a $K$-algebra homomorphism, the constants $\mathrm{single}\;0\;c$
+being fixed. Second, `divisorExpansionsC K N` is the set of Laurent series $\bar j_K(q^d)$ for the
+non-zero divisors $d$ of $N$, and `modularFunctionFieldFullC K N` is the intermediate field of
+$K((q))/K$ generated by this set; at $K=\mathbb{Q}$ it is the field `modularFunctionFieldFull N`.
+The accompanying inclusions state that the two-generator field `modularFunctionFieldC K N` lies in
+it, that $N \mid M$ gives `modularFunctionFieldFullC K N ≤ modularFunctionFieldFullC K M`, and that
+the image of `modularFunctionFieldFullC K N` under `qExpandAlgHomC K ℓ` lies in
+`modularFunctionFieldFullC K (N * ℓ)`. Third, `JZeroC K N` is the group $\mathrm{Pic}^0$ of that
+field over $K$: degree-zero divisors supported on the places of `modularFunctionFieldFullC K N`
+(valuation subrings containing $K$, proper, with principal ideals; degree of a place the
+residue-field degree over $K$) modulo principal divisors. No identification with $X_0(N)$ or its
+Jacobian is asserted here; only the carriers are built, for a field $K$ of any characteristic.
+
+**Relation to Mathlib.** Mathlib supplies the ambient $K((q))$ as Hahn series over $\mathbb{Z}$ and
+the substitution homomorphism through `HahnSeries.embDomain`; the modular function field presented
+as a subfield of a Laurent series field, and the divisor class group attached to it, are the
+project's own notions.
+
+**Where it is used.** These carriers over a field of characteristic $\ell \nmid N$ are the targets
+of the reduction map on $J_0(N)$ and of the Eichler–Shimura relation on the special fibre, which
+enter the level-lowering step of the route to Fermat's Last Theorem.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open HahnSeries IntermediateField AlgebraicCurve
+
+namespace ModularCurve
+
+section CoeffMapSupply
+
+variable {R S : Type*} [CommRing R] [CommRing S]
+
+theorem coeffMap_ofPowerSeries (f : R →+* S) (p : PowerSeries R) :
+    coeffMap f (HahnSeries.ofPowerSeries ℤ R p) = HahnSeries.ofPowerSeries ℤ S (p.map f) := by
+  ext k
+  rw [coeffMap_coeff]
+  rcases le_or_gt 0 k with hk | hk
+  · lift k to ℕ using hk
+    rw [HahnSeries.ofPowerSeries_apply_coeff, HahnSeries.ofPowerSeries_apply_coeff,
+      PowerSeries.coeff_map]
+  · rw [ofPowerSeries_coeff_of_neg _ hk, ofPowerSeries_coeff_of_neg _ hk, map_zero]
+
+end CoeffMapSupply
+
+section JExpansion
+
+variable (R : Type*) [CommRing R]
+
+theorem jqNModC_rat (N : ℕ) [NeZero N] : jqNModC ℚ N = jqN N := rfl
+
+variable {R} in
+theorem coeffMap_jqModC {S : Type*} [CommRing S] (f : R →+* S) :
+    coeffMap f (jqModC R) = jqModC S := by
+  rw [jqModC, map_mul, coeffMap_single, map_one, coeffMap_ofPowerSeries,
+    ← RingHom.comp_apply (PowerSeries.map f) (PowerSeries.map (Int.castRingHom R)),
+    ← PowerSeries.map_comp, RingHom.ext_int (f.comp (Int.castRingHom R)) (Int.castRingHom S)]
+  rfl
+
+variable {R} in
+theorem coeffMap_jqNModC {S : Type*} [CommRing S] (f : R →+* S) (N : ℕ) [NeZero N] :
+    coeffMap f (jqNModC R N) = jqNModC S N := by
+  rw [jqNModC, coeffMap_qExpand, coeffMap_jqModC, jqNModC]
+
+variable {R} in
+theorem coeff_jqModC_eq_intCast (k : ℤ) : (jqModC R).coeff k = (((jqModC ℤ).coeff k : ℤ) : R) := by
+  conv_lhs => rw [← coeffMap_jqModC (Int.castRingHom R)]
+  rfl
+
+theorem jqModC_pow (n : ℕ) :
+    jqModC R ^ n = HahnSeries.single (-(n : ℤ)) 1 *
+      HahnSeries.ofPowerSeries ℤ R ((jNum.map (Int.castRingHom R)) ^ n) := by
+  have h : n • (-1 : ℤ) = -(n : ℤ) := by simp
+  rw [jqModC, mul_pow, HahnSeries.single_pow, one_pow, h, ← map_pow]
+
+theorem coeff_jqModC_of_lt {k : ℤ} (hk : k < -1) : (jqModC R).coeff k = 0 := by
+  simpa using coeff_jqModC_pow_of_lt R (b := 1) (m := k) (by simpa using hk)
+
+theorem jqModC_ne_zero_of_nontrivial [Nontrivial R] : jqModC R ≠ 0 := fun h => by
+  simpa [h] using coeff_jqModC_neg_one R
+
+end JExpansion
+
+section QExpandAlg
+
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+
+def qExpandAlgHomC : LaurentSeries K →ₐ[K] LaurentSeries K where
+  __ := qExpand K N
+  commutes' c := by
+    change qExpand K N (algebraMap K (LaurentSeries K) c) = algebraMap K (LaurentSeries K) c
+    rw [algebraMap_laurentSeries_eq_single, qExpand_single, mul_zero]
+
+@[simp]
+theorem qExpandAlgHomC_apply (f : LaurentSeries K) : qExpandAlgHomC K N f = qExpand K N f := rfl
+
+end QExpandAlg
+
+section FunctionField
+
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+
+def divisorExpansionsC : Set (LaurentSeries K) :=
+  {x | ∃ (d : ℕ) (_ : NeZero d), d ∣ N ∧ x = qExpand K d (jqModC K)}
+
+omit [NeZero N] in
+theorem mem_divisorExpansionsC {d : ℕ} [NeZero d] (hd : d ∣ N) :
+    qExpand K d (jqModC K) ∈ divisorExpansionsC K N :=
+  ⟨d, ‹_›, hd, rfl⟩
+
+def modularFunctionFieldFullC : IntermediateField K (LaurentSeries K) :=
+  IntermediateField.adjoin K (divisorExpansionsC K N)
+
+omit [NeZero N] in
+theorem modularFunctionFieldFullC_rat :
+    modularFunctionFieldFullC ℚ N = modularFunctionFieldFull N :=
+  rfl
+
+omit [NeZero N] in
+theorem jqModCd_mem_full {d : ℕ} [NeZero d] (hd : d ∣ N) :
+    qExpand K d (jqModC K) ∈ modularFunctionFieldFullC K N :=
+  subset_adjoin K _ (mem_divisorExpansionsC K N hd)
+
+omit [NeZero N] in
+theorem jqModC_mem_full : jqModC K ∈ modularFunctionFieldFullC K N := by
+  simpa [qExpand_one_apply] using jqModCd_mem_full K N (one_dvd N)
+
+theorem modularFunctionFieldC_le_full :
+    modularFunctionFieldC K N ≤ modularFunctionFieldFullC K N := by
+  rw [modularFunctionFieldC, adjoin_le_iff]
+  rintro x (rfl | rfl)
+  · exact jqModC_mem_full K N
+  · exact jqModCd_mem_full K N dvd_rfl
+
+theorem full_degeneracyC_le {N M : ℕ} [NeZero N] [NeZero M] (h : N ∣ M) :
+    modularFunctionFieldFullC K N ≤ modularFunctionFieldFullC K M := by
+  rw [modularFunctionFieldFullC, adjoin_le_iff]
+  rintro x ⟨d, hne, hdvd, rfl⟩
+  have := hne
+  exact jqModCd_mem_full K M (hdvd.trans h)
+
+omit [NeZero N] in
+theorem full_degeneracyC_map_le (ℓ : ℕ) [NeZero ℓ] :
+    (modularFunctionFieldFullC K N).map (qExpandAlgHomC K ℓ) ≤ modularFunctionFieldFullC K (N * ℓ)
+      := by
+  rw [modularFunctionFieldFullC, adjoin_map, adjoin_le_iff]
+  rintro x ⟨y, ⟨d, hne, hdvd, rfl⟩, rfl⟩
+  have := hne
+  have : NeZero (ℓ * d) := ⟨Nat.mul_ne_zero (NeZero.ne ℓ) (NeZero.ne d)⟩
+  change qExpandAlgHomC K ℓ (qExpand K d (jqModC K)) ∈ _
+  rw [qExpandAlgHomC_apply, qExpand_qExpand]
+  exact jqModCd_mem_full K (N * ℓ) ((mul_dvd_mul_left ℓ hdvd).trans (dvd_of_eq (mul_comm ℓ N)))
+
+end FunctionField
+
+section Jacobian
+
+variable (K : Type*) [Field K] (N : ℕ) [NeZero N]
+
+abbrev JZeroC : Type _ := Pic0 K (modularFunctionFieldFullC K N)
+
+example : AddCommGroup (JZeroC K N) := inferInstance
+
+end Jacobian
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_X1.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_X1.lean
new file mode 100644
index 0000000000..943ad13fb3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_X1.lean
@@ -0,0 +1,278 @@
+/-
+Based on Prove2Me node ModularCurve_X1
+(a97393e1-e3b4-528c-899e-0baec08e606f) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import Mathlib.RingTheory.Henselian
+public import Mathlib.RingTheory.RegularLocalRing.Defs
+public import Mathlib.RingTheory.SimpleRing.Principal
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ArithmeticGalois
+
+/-!
+# Function fields of X1​(M) via q-expansions, and J1​(M)
+
+Definition: `ModularCurve_X1` (`a97393e1-e3b4-528c-899e-0baec08e606f`), by Claude, 2026-09-05.
+
+Work inside the Laurent series field $K((q))$ over a field $K$. A power series $p\in\mathbb Z[[q]]$
+is an *integral $q$-expansion* of a function $f:\mathbb H\to\mathbb C$, written
+[`ModularCurve.IsIntegralQExp f p`](../def/ModularCurve_X1.html#L37), when the image of $p$ under
+$\mathbb Z\to\mathbb C$ equals Mathlib's `qExpansion 1 f`, the $q$-expansion of $f$ of width $1$;
+such a $p$ is unique, and $0$ and $1$ have the evident integral expansions. For $p\in\mathbb
+Z[[q]]$, `intSeriesC K p` denotes the Laurent series obtained by reducing the coefficients along
+$\mathbb Z\to K$; it is multiplicative and unital. For a subgroup $\Gamma\le\mathrm{SL}_2(\mathbb
+Z)$, `intFormRatiosC K Γ` is the set of quotients
+$\mathrm{intSeriesC}\,p_f/\mathrm{intSeriesC}\,p_g$ in $K((q))$ where, for some weight $k\in\mathbb
+Z$, $f,g$ are modular forms of weight $k$ for the image of $\Gamma$ in $\mathrm{GL}_2(\mathbb R)$
+admitting integral $q$-expansions $p_f,p_g$, with $\mathrm{intSeriesC}\,p_g\neq 0$; and
+`qExpFunctionFieldC K Γ` is the intermediate field of $K((q))/K$ generated by this set. This
+construction is antitone: $\Gamma'\le\Gamma$ gives $\mathrm{qExpFunctionFieldC}\,K\,\Gamma\le
+\mathrm{qExpFunctionFieldC}\,K\,\Gamma'$. Specialising, `x1FunctionFieldC K M` takes
+$\Gamma=\Gamma_1(M)$ (with `x1FunctionField M` the case $K=\mathbb Q$) and `x1x0FunctionFieldC K M
+t` takes $\Gamma_1(M)\cap\Gamma_0(t)$; the former is contained in the latter, equality holding for
+$t=1$, and $M\mid M'$ gives $\Gamma_1(M')\le\Gamma_1(M)$ and hence an inclusion of the corresponding
+fields. Finally `x1FunctionFieldBar M` is the compositum of $\overline{\mathbb Q}$ with
+`x1FunctionField M` inside $\overline{\mathbb Q}((q))$, `JOne M` is its degree-zero divisor class
+group $\mathrm{Pic}^0$ over $\overline{\mathbb Q}$ (divisors supported on places, i.e. proper
+valuation subrings containing the constants that are principal ideal rings, modulo principal
+divisors), carrying the action of $\mathrm{Gal}(\overline{\mathbb Q}/\mathbb Q)$ induced by
+coefficientwise action on Laurent series; `JOne.torsionGaloisRep M n` is the resulting homomorphism
+from that Galois group to $\mathbb Z/n$-linear endomorphisms of the $n$-torsion of $\mathrm{Pic}^0$.
+`JOneC M K` is the same $\mathrm{Pic}^0$ over an arbitrary base field $K$.
+
+**Relation to Mathlib.** Mathlib supplies `ModularForm`, the congruence subgroups
+$\Gamma_0,\Gamma_1$ and the $q$-expansion `qExpansion`; the integrality predicate for
+$q$-expansions, the realisation of modular function fields as intermediate fields of $K((q))$, and
+the divisor-class group $\mathrm{Pic}^0$ of a field over a base field with its semilinear Galois
+action are the project's own.
+
+**Where it is used.** The field `x1FunctionField M` is the model of the modular curve $X_1(M)$ used
+throughout, and `JOne M` plays the role of the Jacobian $J_1(M)$ over $\overline{\mathbb Q}$; the
+representations `JOne.torsionGaloisRep` on its $n$-torsion are the source of the mod $\ell$ Galois
+representations attached to modular forms, used in level lowering and modularity lifting.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+open UpperHalfPlane IntermediateField HahnSeries AlgebraicCurve CongruenceSubgroup
+
+open scoped MatrixGroups
+
+namespace ModularCurve
+
+section Restrict
+
+variable {Γ Γ' : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+def restrictForm (h : Γ' ≤ Γ) (f : ModularForm Γ k) : ModularForm Γ' k where
+  toFun := f
+  slash_action_eq' A hA := f.slash_action_eq' A (h hA)
+  holo' := f.holo'
+  bdd_at_cusps' hc := f.bdd_at_cusps' (hc.mono h)
+
+@[simp]
+theorem coe_restrictForm (h : Γ' ≤ Γ) (f : ModularForm Γ k) :
+    (⇑(restrictForm h f) : ℍ → ℂ) = f :=
+  rfl
+
+theorem restrictForm_apply (h : Γ' ≤ Γ) (f : ModularForm Γ k) (τ : ℍ) :
+    restrictForm h f τ = f τ :=
+  rfl
+
+end Restrict
+
+section Integral
+
+def IsIntegralQExp (f : ℍ → ℂ) (p : PowerSeries ℤ) : Prop :=
+  p.map (Int.castRingHom ℂ) = qExpansion 1 f
+
+theorem IsIntegralQExp.coeff {f : ℍ → ℂ} {p : PowerSeries ℤ} (h : IsIntegralQExp f p) (n : ℕ) :
+    ((PowerSeries.coeff n p : ℤ) : ℂ) = PowerSeries.coeff n (qExpansion 1 f) := by
+  rw [← h, PowerSeries.coeff_map, eq_intCast]
+
+theorem isIntegralQExp_iff {f : ℍ → ℂ} {p : PowerSeries ℤ} :
+    IsIntegralQExp f p ↔ ∀ n : ℕ, ((PowerSeries.coeff n p : ℤ) : ℂ) = PowerSeries.coeff n
+      (qExpansion 1 f) := by
+  refine ⟨fun h n => h.coeff n, fun h => ?_⟩
+  ext n
+  rw [PowerSeries.coeff_map, eq_intCast]
+  exact h n
+
+theorem IsIntegralQExp.unique {f : ℍ → ℂ} {p p' : PowerSeries ℤ} (h : IsIntegralQExp f p)
+    (h' : IsIntegralQExp f p') : p = p' := by
+  ext n
+  have := (h.coeff n).trans (h'.coeff n).symm
+  exact_mod_cast this
+
+theorem isIntegralQExp_one : IsIntegralQExp (1 : ℍ → ℂ) 1 := by
+  rw [IsIntegralQExp, map_one, qExpansion_one]
+
+theorem isIntegralQExp_zero : IsIntegralQExp (0 : ℍ → ℂ) 0 := by
+  rw [IsIntegralQExp, map_zero, qExpansion_zero]
+
+end Integral
+
+section FunctionField
+
+variable (K : Type*) [Field K] (Γ : Subgroup SL(2, ℤ))
+
+def intSeriesC (p : PowerSeries ℤ) : LaurentSeries K :=
+  HahnSeries.ofPowerSeries ℤ K (p.map (Int.castRingHom K))
+
+@[simp]
+theorem intSeriesC_one : intSeriesC K 1 = 1 := by
+  simp [intSeriesC]
+
+@[simp]
+theorem intSeriesC_zero : intSeriesC K 0 = 0 := by
+  simp [intSeriesC]
+
+theorem intSeriesC_mul (p p' : PowerSeries ℤ) :
+    intSeriesC K (p * p') = intSeriesC K p * intSeriesC K p' := by
+  simp [intSeriesC]
+
+def intFormRatiosC : Set (LaurentSeries K) :=
+  {x | ∃ (k : ℤ) (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (pf pg : PowerSeries ℤ),
+      IsIntegralQExp f pf ∧ IsIntegralQExp g pg ∧ intSeriesC K pg ≠ 0 ∧
+        x = intSeriesC K pf / intSeriesC K pg}
+
+variable {K Γ} in
+theorem mem_intFormRatiosC {k : ℤ} (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    {pf pg : PowerSeries ℤ} (hf : IsIntegralQExp f pf) (hg : IsIntegralQExp g pg)
+    (hg0 : intSeriesC K pg ≠ 0) :
+    intSeriesC K pf / intSeriesC K pg ∈ intFormRatiosC K Γ :=
+  ⟨k, f, g, pf, pg, hf, hg, hg0, rfl⟩
+
+theorem one_mem_intFormRatiosC : (1 : LaurentSeries K) ∈ intFormRatiosC K Γ := by
+  refine ⟨0, 1, 1, 1, 1, ?_, ?_, by simp, by simp⟩ <;>
+  · show IsIntegralQExp (⇑(1 : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 0)) 1
+    rw [ModularForm.one_coe_eq_one]
+    exact isIntegralQExp_one
+
+def qExpFunctionFieldC : IntermediateField K (LaurentSeries K) :=
+  IntermediateField.adjoin K (intFormRatiosC K Γ)
+
+theorem intFormRatiosC_subset :
+    intFormRatiosC K Γ ⊆ (qExpFunctionFieldC K Γ : Set (LaurentSeries K)) :=
+  IntermediateField.subset_adjoin K _
+
+variable {K Γ} in
+theorem div_mem_qExpFunctionFieldC {k : ℤ} (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    {pf pg : PowerSeries ℤ} (hf : IsIntegralQExp f pf) (hg : IsIntegralQExp g pg)
+    (hg0 : intSeriesC K pg ≠ 0) :
+    intSeriesC K pf / intSeriesC K pg ∈ qExpFunctionFieldC K Γ :=
+  intFormRatiosC_subset K Γ (mem_intFormRatiosC f g hf hg hg0)
+
+variable {Γ} in
+theorem intFormRatiosC_mono {Γ' : Subgroup SL(2, ℤ)} (h : Γ' ≤ Γ) :
+    intFormRatiosC K Γ ⊆ intFormRatiosC K Γ' := by
+  rintro x ⟨k, f, g, pf, pg, hf, hg, hg0, rfl⟩
+  have h' : (Γ' : Subgroup (GL (Fin 2) ℝ)) ≤ (Γ : Subgroup (GL (Fin 2) ℝ)) := Subgroup.map_mono h
+  exact ⟨k, restrictForm h' f, restrictForm h' g, pf, pg, hf, hg, hg0, rfl⟩
+
+variable {Γ} in
+theorem qExpFunctionFieldC_mono {Γ' : Subgroup SL(2, ℤ)} (h : Γ' ≤ Γ) :
+    qExpFunctionFieldC K Γ ≤ qExpFunctionFieldC K Γ' :=
+  IntermediateField.adjoin.mono K _ _ (intFormRatiosC_mono K h)
+
+end FunctionField
+
+section LevelOne
+
+variable (K : Type*) [Field K] (M : ℕ)
+
+def x1FunctionFieldC : IntermediateField K (LaurentSeries K) :=
+  qExpFunctionFieldC K (Gamma1 M)
+
+abbrev x1FunctionField : IntermediateField ℚ (LaurentSeries ℚ) :=
+  x1FunctionFieldC ℚ M
+
+theorem x1FunctionFieldC_rat : x1FunctionFieldC ℚ M = x1FunctionField M := rfl
+
+def x1x0FunctionFieldC (t : ℕ) : IntermediateField K (LaurentSeries K) :=
+  qExpFunctionFieldC K (Gamma1 M ⊓ Gamma0 t)
+
+theorem x1FunctionFieldC_le_x1x0 (t : ℕ) : x1FunctionFieldC K M ≤ x1x0FunctionFieldC K M t :=
+  qExpFunctionFieldC_mono K inf_le_left
+
+theorem x1x0FunctionFieldC_one : x1x0FunctionFieldC K M 1 = x1FunctionFieldC K M := by
+  have : Gamma1 M ⊓ Gamma0 1 = Gamma1 M := by
+    refine le_antisymm inf_le_left (le_inf le_rfl ?_)
+    intro A _
+    rw [Gamma0_mem]
+    exact Subsingleton.elim _ _
+  rw [x1x0FunctionFieldC, this, x1FunctionFieldC]
+
+variable {M} in
+theorem Gamma1_le_of_dvd {M' : ℕ} (h : M ∣ M') : Gamma1 M' ≤ Gamma1 M := by
+  intro A hA
+  rw [Gamma1_mem] at hA ⊢
+  obtain ⟨h00, h11, h10⟩ := hA
+  refine ⟨?_, ?_, ?_⟩
+  · have := congrArg (ZMod.castHom h (ZMod M)) h00
+    rwa [map_intCast, map_one] at this
+  · have := congrArg (ZMod.castHom h (ZMod M)) h11
+    rwa [map_intCast, map_one] at this
+  · have := congrArg (ZMod.castHom h (ZMod M)) h10
+    rwa [map_intCast, map_zero] at this
+
+variable {M} in
+theorem x1FunctionFieldC_le_of_dvd {M' : ℕ} (h : M ∣ M') :
+    x1FunctionFieldC K M ≤ x1FunctionFieldC K M' :=
+  qExpFunctionFieldC_mono K (Gamma1_le_of_dvd h)
+
+end LevelOne
+
+section Jacobian
+
+variable (M : ℕ)
+
+abbrev x1FunctionFieldBar :
+    IntermediateField (AlgebraicClosure ℚ) (LaurentSeries (AlgebraicClosure ℚ)) :=
+  laurentBaseChange (AlgebraicClosure ℚ) (x1FunctionField M)
+
+abbrev JOne : Type _ :=
+  Pic0 (AlgebraicClosure ℚ) (x1FunctionFieldBar M)
+
+example : DistribMulAction (AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) (JOne M) :=
+  inferInstance
+
+def JOne.torsionGaloisRep (n : ℕ) :
+    (AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) →*
+      Module.End (ZMod n) (Pic0.torsion (AlgebraicClosure ℚ) (x1FunctionFieldBar M) n) :=
+  (SemilinearAut.torsionRep _ _ n).comp (arithmeticGalois (x1FunctionField M))
+
+@[simp]
+theorem JOne.torsionGaloisRep_apply {n : ℕ} (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ)
+    (x : Pic0.torsion (AlgebraicClosure ℚ) (x1FunctionFieldBar M) n) :
+    JOne.torsionGaloisRep M n σ x = arithmeticGalois (x1FunctionField M) σ • x :=
+  rfl
+
+theorem JOne.coe_torsionGaloisRep_apply {n : ℕ} (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ)
+    (x : Pic0.torsion (AlgebraicClosure ℚ) (x1FunctionFieldBar M) n) :
+    ((JOne.torsionGaloisRep M n σ x : Pic0.torsion (AlgebraicClosure ℚ) (x1FunctionFieldBar M) n) :
+        JOne M) = σ • (x : JOne M) :=
+  rfl
+
+abbrev JOneC (K : Type*) [Field K] : Type _ :=
+  Pic0 K (x1FunctionFieldC K M)
+
+example (K : Type*) [Field K] : AddCommGroup (JOneC M K) := inferInstance
+
+end Jacobian
+
+end ModularCurve
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_XH.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_XH.lean
new file mode 100644
index 0000000000..92f74287db
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularCurve_XH.lean
@@ -0,0 +1,239 @@
+/-
+Based on Prove2Me node ModularCurve_XH
+(f4e764c3-3bd9-585d-b076-7f9256cec3ad) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_CohCarrier_Level
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_TateModule
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+/-!
+# Function fields and Jacobians of the modular curves XH​(M)
+
+Definition: `ModularCurve_XH` (`f4e764c3-3bd9-585d-b076-7f9256cec3ad`), by Claude, 2026-09-05.
+
+Fix a natural number $M$ and a subgroup $H \leq (\mathbb{Z}/M)^\times$. The underlying congruence
+subgroup is [`CohCarrier.GammaH M H`](../def/CohCarrier_Level.html#L133), the set of $A \in
+\mathrm{SL}_2(\mathbb{Z})$ with $A_{10} \equiv 0 \pmod M$ whose lower-right entry $A_{11}$, viewed
+as a unit of $\mathbb{Z}/M$ (its inverse being $A_{00}$), lies in $H$. The group-theoretic lemmas
+record that the translation $T = \begin{pmatrix}1&1\\0&1\end{pmatrix}$ belongs to it, that
+$\Gamma_1(M) \leq \Gamma_H(M)$ with equality when $H$ is trivial, and that $H \mapsto \Gamma_H(M)$
+is monotone.
+
+For a field $K$, `xHFunctionFieldC K M H` is the intermediate field of $K((q))$ over $K$ generated
+by the ratios $\bar p_f/\bar p_g$, where $f,g$ are modular forms of one common weight on the image
+of $\Gamma_H(M)$ in $\mathrm{GL}_2(\mathbb{R})$ admitting integral $q$-expansions $p_f,p_g \in
+\mathbb{Z}[[q]]$ at $\infty$ (i.e. $p$ maps to `qExpansion 1 f` over $\mathbb{C}$), reduced
+coefficientwise into $K$, with $\bar p_g \neq 0$; `xHFunctionField M H` is the case $K =
+\mathbb{Q}$. Alongside it, `xHTopFunctionFieldC K M H t` is the same construction for $\Gamma_H(M)
+\cap \Gamma_0(t)$. The inclusions proved are: $F_H \leq F_{H \cap \Gamma_0(t)}$ with equality for $t
+= 1$; $F_H \leq F_{\Gamma_1(M)}$; $F_{\Gamma_0(M)} \leq F_H$; antitonicity in $H$; and the two
+extreme cases $H = \top$ giving the $\Gamma_0(M)$ field and $H = \bot$ giving the $X_1(M)$ field.
+
+On the Jacobian side, `xHFunctionFieldBar M H` is the compositum of $\overline{\mathbb{Q}}$ with the
+rational field inside $\overline{\mathbb{Q}}((q))$, obtained by adjoining to $\overline{\mathbb{Q}}$
+the coefficientwise image of `xHFunctionField M H`, and `JH M H` is the group `Pic0` of the
+resulting extension, carrying an action of $\mathrm{Gal}(\overline{\mathbb{Q}}/\mathbb{Q})$ through
+the coefficients and an action of its own additive endomorphisms. `JH.torsionGaloisRep n` is the
+resulting representation of $\mathrm{Gal}(\overline{\mathbb{Q}}/\mathbb{Q})$ on the $n$-torsion
+`Pic0.torsion` by $\mathbb{Z}/n$-linear endomorphisms, obtained from `arithmeticGalois` followed by
+`SemilinearAut.torsionRep`, with two lemmas identifying its values with the semilinear action. For a
+prime $p$, `JH.tateGaloisRep` and `JH.tateEnd` are the $\mathbb{Z}_p$-linear representations of the
+Galois group and of `AddMonoid.End (JH M H)` on [`TateModule p (JH M
+H)`](../def/EllipticCurve_TateModule.html#L15), both given by
+[`TateModule.rep`](../def/EllipticCurve_TateModule.html#L174), acting levelwise on the defining
+sequences of torsion points. Finally `JHC M H K` is `Pic0 K (xHFunctionFieldC K M H)`, the class
+group of the field over an arbitrary base field $K$.
+
+**Relation to Mathlib.** Mathlib supplies $\Gamma_0(M)$, $\Gamma_1(M)$, the modular forms
+`ModularForm` for a subgroup of $\mathrm{GL}_2(\mathbb{R})$ and the $q$-expansion `qExpansion`; the
+intermediate groups $\Gamma_H(M)$, the presentation of the function field of a modular curve by
+integral $q$-expansion ratios, and the associated divisor class groups and Tate modules are the
+project's own.
+
+**Where it is used.** These function fields serve as the carriers of the modular curves $X_H(M)$ in
+the formalisation, and the groups `JH M H` with their mod-$n$ and $p$-adic representations provide
+the Galois modules on which the Hecke correspondences and diamond operators act, as needed for the
+construction of the Galois representations attached to modular forms in the modularity-lifting and
+level-lowering steps.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public noncomputable section publicSection
+
+open IntermediateField HahnSeries AlgebraicCurve CongruenceSubgroup
+
+open scoped MatrixGroups
+
+namespace ModularCurve
+
+section Groups
+
+variable (M : ℕ) (H : Subgroup (ZMod M)ˣ)
+
+theorem translation_mem_GammaH : ModularGroup.T ∈ CohCarrier.GammaH M H := by
+  rw [CohCarrier.mem_GammaH_iff]
+  have hT0 : ModularGroup.T ∈ Gamma0 M := by
+    rw [Gamma0_mem]
+    simp [ModularGroup.T]
+  refine ⟨hT0, ?_⟩
+  have : CohCarrier.gamma0Units M ⟨ModularGroup.T, hT0⟩ = 1 := by
+    ext
+    simp [CohCarrier.gamma0Units, Gamma0Map, ModularGroup.T]
+  rw [this]
+  exact one_mem H
+
+theorem Gamma1_le_GammaH : Gamma1 M ≤ CohCarrier.GammaH M H := by
+  intro A hA
+  rw [Gamma1_mem] at hA
+  obtain ⟨_, h11, h10⟩ := hA
+  rw [CohCarrier.mem_GammaH_iff]
+  have hA0 : A ∈ Gamma0 M := Gamma0_mem.mpr h10
+  refine ⟨hA0, ?_⟩
+  have : CohCarrier.gamma0Units M ⟨A, hA0⟩ = 1 := by
+    ext
+    simp only [CohCarrier.gamma0Units, MonoidHom.coe_mk, OneHom.coe_mk, Units.val_one, Gamma0Map]
+    exact h11
+  rw [this]
+  exact one_mem H
+
+theorem GammaH_bot : CohCarrier.GammaH M ⊥ = Gamma1 M := by
+  refine le_antisymm ?_ (Gamma1_le_GammaH M ⊥)
+  intro A hA
+  obtain ⟨hA0, hAH⟩ := CohCarrier.mem_GammaH_iff.mp hA
+  rw [Subgroup.mem_bot] at hAH
+  have h11 : ((A 1 1 : ℤ) : ZMod M) = 1 := by
+    have := congrArg (fun u : (ZMod M)ˣ => (u : ZMod M)) hAH
+    simpa [CohCarrier.gamma0Units, Gamma0Map] using this
+  have h10 : ((A 1 0 : ℤ) : ZMod M) = 0 := Gamma0_mem.mp hA0
+  rw [Gamma1_mem]
+  refine ⟨?_, h11, h10⟩
+  have hda := CohCarrier.Gamma0_d_mul_a M ⟨A, hA0⟩
+  simp only at hda
+  rw [h11, one_mul] at hda
+  exact hda
+
+variable {M} in
+theorem GammaH_mono {H H' : Subgroup (ZMod M)ˣ} (h : H ≤ H') :
+    CohCarrier.GammaH M H ≤ CohCarrier.GammaH M H' := by
+  intro A hA
+  obtain ⟨hA0, hAH⟩ := CohCarrier.mem_GammaH_iff.mp hA
+  exact CohCarrier.mem_GammaH_iff.mpr ⟨hA0, h hAH⟩
+
+end Groups
+
+section FunctionField
+
+variable (K : Type*) [Field K] (M : ℕ) (H : Subgroup (ZMod M)ˣ)
+
+def xHFunctionFieldC : IntermediateField K (LaurentSeries K) :=
+  qExpFunctionFieldC K (CohCarrier.GammaH M H)
+
+abbrev xHFunctionField : IntermediateField ℚ (LaurentSeries ℚ) :=
+  xHFunctionFieldC ℚ M H
+
+theorem xHFunctionFieldC_rat : xHFunctionFieldC ℚ M H = xHFunctionField M H := rfl
+
+def xHTopFunctionFieldC (t : ℕ) : IntermediateField K (LaurentSeries K) :=
+  qExpFunctionFieldC K (CohCarrier.GammaH M H ⊓ Gamma0 t)
+
+theorem xHFunctionFieldC_le_top (t : ℕ) : xHFunctionFieldC K M H ≤ xHTopFunctionFieldC K M H t :=
+  qExpFunctionFieldC_mono K inf_le_left
+
+theorem xHTopFunctionFieldC_one : xHTopFunctionFieldC K M H 1 = xHFunctionFieldC K M H := by
+  have : CohCarrier.GammaH M H ⊓ Gamma0 1 = CohCarrier.GammaH M H := by
+    refine le_antisymm inf_le_left (le_inf le_rfl ?_)
+    intro A _
+    rw [Gamma0_mem]
+    exact Subsingleton.elim _ _
+  rw [xHTopFunctionFieldC, this, xHFunctionFieldC]
+
+theorem xHFunctionFieldC_le_x1 : xHFunctionFieldC K M H ≤ x1FunctionFieldC K M :=
+  qExpFunctionFieldC_mono K (Gamma1_le_GammaH M H)
+
+theorem x0_le_xHFunctionFieldC : qExpFunctionFieldC K (Gamma0 M) ≤ xHFunctionFieldC K M H :=
+  qExpFunctionFieldC_mono K (CohCarrier.GammaH_le_Gamma0 H)
+
+variable {H} in
+theorem xHFunctionFieldC_antitone {H' : Subgroup (ZMod M)ˣ} (h : H ≤ H') :
+    xHFunctionFieldC K M H' ≤ xHFunctionFieldC K M H :=
+  qExpFunctionFieldC_mono K (GammaH_mono h)
+
+theorem xHFunctionFieldC_top : xHFunctionFieldC K M ⊤ = qExpFunctionFieldC K (Gamma0 M) := by
+  rw [xHFunctionFieldC, CohCarrier.GammaH_top]
+
+theorem xHFunctionFieldC_bot : xHFunctionFieldC K M ⊥ = x1FunctionFieldC K M := by
+  rw [xHFunctionFieldC, GammaH_bot]
+  rfl
+
+end FunctionField
+
+section Jacobian
+
+variable (M : ℕ) (H : Subgroup (ZMod M)ˣ)
+
+abbrev xHFunctionFieldBar :
+    IntermediateField (AlgebraicClosure ℚ) (LaurentSeries (AlgebraicClosure ℚ)) :=
+  laurentBaseChange (AlgebraicClosure ℚ) (xHFunctionField M H)
+
+abbrev JH : Type _ :=
+  Pic0 (AlgebraicClosure ℚ) (xHFunctionFieldBar M H)
+
+example : DistribMulAction (AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) (JH M H) :=
+  inferInstance
+
+example : DistribMulAction (AddMonoid.End (JH M H)) (JH M H) := inferInstance
+
+def JH.torsionGaloisRep (n : ℕ) :
+    (AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) →*
+      Module.End (ZMod n) (Pic0.torsion (AlgebraicClosure ℚ) (xHFunctionFieldBar M H) n) :=
+  (SemilinearAut.torsionRep _ _ n).comp (arithmeticGalois (xHFunctionField M H))
+
+@[simp]
+theorem JH.torsionGaloisRep_apply {n : ℕ} (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ)
+    (x : Pic0.torsion (AlgebraicClosure ℚ) (xHFunctionFieldBar M H) n) :
+    JH.torsionGaloisRep M H n σ x = arithmeticGalois (xHFunctionField M H) σ • x :=
+  rfl
+
+theorem JH.coe_torsionGaloisRep_apply {n : ℕ} (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ)
+    (x : Pic0.torsion (AlgebraicClosure ℚ) (xHFunctionFieldBar M H) n) :
+    ((JH.torsionGaloisRep M H n σ x : Pic0.torsion (AlgebraicClosure ℚ) (xHFunctionFieldBar M H)
+      n) :
+        JH M H) = σ • (x : JH M H) :=
+  rfl
+
+variable (p : ℕ) [Fact p.Prime]
+
+abbrev JH.tateGaloisRep :
+    (AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) →* Module.End ℤ_[p] (TateModule p (JH M H)) :=
+  TateModule.rep p (JH M H) (AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ)
+
+abbrev JH.tateEnd : AddMonoid.End (JH M H) →* Module.End ℤ_[p] (TateModule p (JH M H)) :=
+  TateModule.rep p (JH M H) (AddMonoid.End (JH M H))
+
+theorem JH.tateGaloisRep_apply_coe (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ)
+    (x : TateModule p (JH M H)) (n : ℕ) :
+    ((JH.tateGaloisRep M H p σ x : TateModule p (JH M H)) : ℕ → JH M H) n = σ • (x : ℕ → JH M H) n
+      :=
+  rfl
+
+theorem JH.tateEnd_apply_coe (f : AddMonoid.End (JH M H)) (x : TateModule p (JH M H)) (n : ℕ) :
+    ((JH.tateEnd M H p f x : TateModule p (JH M H)) : ℕ → JH M H) n = f ((x : ℕ → JH M H) n) :=
+  rfl
+
+abbrev JHC (K : Type*) [Field K] : Type _ :=
+  Pic0 K (xHFunctionFieldC K M H)
+
+example (K : Type*) [Field K] : AddCommGroup (JHC M H K) := inferInstance
+
+end Jacobian
+
+end ModularCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularForm_AtkinLehnerDatum.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularForm_AtkinLehnerDatum.lean
new file mode 100644
index 0000000000..d2ceaf73dc
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularForm_AtkinLehnerDatum.lean
@@ -0,0 +1,207 @@
+/-
+Based on Prove2Me node ModularForm_AtkinLehnerDatum
+(ff4232a8-950f-5603-8ddc-604eae2d909c) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import Mathlib.NumberTheory.ModularForms.SlashActions
+
+/-!
+# Atkin–Lehner data and the bare Atkin–Lehner slash operator
+
+Definition: `ModularForm_AtkinLehnerDatum` (`ff4232a8-950f-5603-8ddc-604eae2d909c`), by Claude,
+2026-09-05.
+
+For natural numbers $M$ and $q$, the structure [`ModularForm.AtkinLehnerDatum M
+q`](../def/ModularForm_AtkinLehnerDatum.html#L14) packages, as data, a cofactor `R : ℕ` together
+with a proof that $M = qR$, and a pair of integers $a, b$ together with a proof of the Bézout
+relation $qa - Rb = 1$ (such a datum exists exactly when $q$ divides $M$ exactly, i.e.
+$\gcd(q,R)=1$). Under a `NeZero M` assumption both $q$ and $R$ are positive. Attached to a datum $W$
+is the integral matrix
+$$W.\mathrm{mat} = \begin{pmatrix} qa & b \\ qR & q\end{pmatrix},$$
+whose determinant is $q$ (`det_mat`) and whose lower-left entry is $M$ (`mat_lowerLeft`). The square
+of this matrix is computed exactly: `mat_sq` states $W.\mathrm{mat}^2 = q \cdot W.\mathrm{sqUnit}$,
+where `sqUnit` is the explicit integral matrix $\begin{pmatrix} qa^2 + Rb & b(a+1) \\ qR(a+1) & Rb +
+q\end{pmatrix}$; its determinant is $1$ (`det_sqUnit`), so it defines an element `sqUnitSL` of
+$\mathrm{SL}_2(\mathbb{Z})$, and its lower-left entry is $M(a+1)$, whence `sqUnitSL_mem` places it
+in Mathlib's `Gamma0 M`.
+
+The same matrix is then transported to the real and rational general linear groups: `alGL : GL (Fin
+2) ℝ` and `alGLQ : GL (Fin 2) ℚ` are the entrywise images of $W.\mathrm{mat}$, invertible because
+the determinant $q$ is nonzero; `val_det_alGL` records that the determinant of `alGL` is $q$ as a
+real number, `det_alGL_pos` that it is positive, and consequently `σ_alGL_apply` that the twist
+$\sigma$ of Mathlib's slash action acts as the identity on $\mathbb{C}$ for this matrix.
+`alGLQ_map_castHom` identifies the image of `alGLQ` under $\mathbb{Q} \hookrightarrow \mathbb{R}$
+with `alGL`. Finally, for a weight $k \in \mathbb{Z}$ and an arbitrary function $f : \mathbb{H} \to
+\mathbb{C}$, [`ModularForm.alSlash W k f`](../def/ModularForm_AtkinLehnerDatum.html#L141) is defined
+to be the weight-$k$ slash $f \mid[k] W.\mathrm{alGL}$; this is additive in $f$ and, because
+$\sigma$ is trivial here, genuinely $\mathbb{C}$-linear: `alSlash_smul` gives $w(c \cdot f) = c
+\cdot w(f)$ with no conjugation.
+
+**Relation to Mathlib.** Mathlib supplies the ambient notions used here — the weight-$k$ slash
+action of `GL (Fin 2) ℝ` on functions on the upper half plane together with its conjugation twist
+`σ`, and the congruence subgroup `Gamma0` — but has no notion of Atkin–Lehner datum or Atkin–Lehner
+operator; the structure and the operator `alSlash` are the project's own.
+
+**Where it is used.** These definitions are the basis for the Atkin–Lehner operators on
+$M_k(\Gamma_0(M))$ and $S_k(\Gamma_0(M))$ used in the level-lowering part of the argument: the
+relation $W.\mathrm{mat}^2 = q\,\cdot$ (element of $\Gamma_0(M)$) yields $w_q^2 = q^{k-2}$, and
+together with the trace map from level $M$ to level $R$ this leads to the statement that a newform
+of level exactly divisible by $q$ has $a_q^2 = 1$. Note that the operator here is the slash by one
+specific chosen matrix, so it depends on the datum as data; independence of the choice is a
+statement about modular forms rather than about arbitrary functions.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public noncomputable section publicSection
+
+open Matrix UpperHalfPlane CongruenceSubgroup
+open scoped MatrixGroups ModularForm
+
+namespace ModularForm
+
+variable (M q : ℕ)
+
+structure AtkinLehnerDatum : Type where
+  R : ℕ
+  hM : M = q * R
+  a : ℤ
+  b : ℤ
+  bezout : (q : ℤ) * a - (R : ℤ) * b = 1
+
+namespace AtkinLehnerDatum
+
+variable {M q : ℕ} (W : AtkinLehnerDatum M q)
+
+lemma hM_int : (M : ℤ) = (q : ℤ) * (W.R : ℤ) := by exact_mod_cast W.hM
+
+include W in
+lemma q_pos [NeZero M] : 0 < q := by
+  rcases Nat.eq_zero_or_pos q with h | h
+  · exact absurd (W.hM.trans (Nat.mul_eq_zero.mpr (Or.inl h))) (NeZero.ne M)
+  · exact h
+
+include W in
+lemma R_pos [NeZero M] : 0 < W.R := by
+  rcases Nat.eq_zero_or_pos W.R with h | h
+  · exact absurd (W.hM.trans (Nat.mul_eq_zero.mpr (Or.inr h))) (NeZero.ne M)
+  · exact h
+
+def mat : Matrix (Fin 2) (Fin 2) ℤ := !![(q : ℤ) * W.a, W.b; (q : ℤ) * (W.R : ℤ), (q : ℤ)]
+
+@[simp] lemma det_mat : W.mat.det = (q : ℤ) := by
+  rw [mat, Matrix.det_fin_two_of]
+  linear_combination (q : ℤ) * W.bezout
+
+lemma mat_lowerLeft : W.mat 1 0 = (M : ℤ) := by
+  rw [mat, W.hM_int]
+  simp
+
+def sqUnit : Matrix (Fin 2) (Fin 2) ℤ :=
+  !![(q : ℤ) * W.a ^ 2 + (W.R : ℤ) * W.b, W.b * (W.a + 1);
+     (q : ℤ) * (W.R : ℤ) * (W.a + 1), (W.R : ℤ) * W.b + (q : ℤ)]
+
+theorem mat_sq : W.mat * W.mat = (q : ℤ) • W.sqUnit := by
+  rw [mat, sqUnit, Matrix.mul_fin_two]
+  refine Matrix.ext fun i j => ?_
+  fin_cases i <;> fin_cases j
+  · change (q : ℤ) * W.a * ((q : ℤ) * W.a) + W.b * ((q : ℤ) * (W.R : ℤ))
+      = (q : ℤ) * ((q : ℤ) * W.a ^ 2 + (W.R : ℤ) * W.b)
+    ring
+  · change (q : ℤ) * W.a * W.b + W.b * (q : ℤ) = (q : ℤ) * (W.b * (W.a + 1))
+    ring
+  · change (q : ℤ) * (W.R : ℤ) * ((q : ℤ) * W.a) + (q : ℤ) * ((q : ℤ) * (W.R : ℤ))
+      = (q : ℤ) * ((q : ℤ) * (W.R : ℤ) * (W.a + 1))
+    ring
+  · change (q : ℤ) * (W.R : ℤ) * W.b + (q : ℤ) * (q : ℤ)
+      = (q : ℤ) * ((W.R : ℤ) * W.b + (q : ℤ))
+    ring
+
+@[simp] lemma det_sqUnit : W.sqUnit.det = 1 := by
+  rw [sqUnit, Matrix.det_fin_two_of]
+  linear_combination ((q : ℤ) * W.a - (W.R : ℤ) * W.b + 1) * W.bezout
+
+def sqUnitSL : SL(2, ℤ) := ⟨W.sqUnit, W.det_sqUnit⟩
+
+@[simp] lemma sqUnitSL_coe : (W.sqUnitSL : Matrix (Fin 2) (Fin 2) ℤ) = W.sqUnit := rfl
+
+lemma sqUnitSL_mem : W.sqUnitSL ∈ Gamma0 M := by
+  rw [Gamma0_mem]
+  change (((W.sqUnit 1 0 : ℤ) : ZMod M) = 0)
+  have h : W.sqUnit 1 0 = (M : ℤ) * (W.a + 1) := by
+    rw [sqUnit, W.hM_int]; simp
+  rw [h]
+  push_cast
+  simp
+
+def alGL [NeZero M] : GL (Fin 2) ℝ :=
+  Matrix.GeneralLinearGroup.mkOfDetNeZero (W.mat.map (algebraMap ℤ ℝ)) (by
+    have h : ((W.mat).map (algebraMap ℤ ℝ)).det = (algebraMap ℤ ℝ) W.mat.det := by
+      rw [← RingHom.mapMatrix_apply, ← RingHom.map_det]
+    rw [h, W.det_mat]
+    simpa using W.q_pos.ne')
+
+@[simp] lemma alGL_coe [NeZero M] :
+    (W.alGL : Matrix (Fin 2) (Fin 2) ℝ) = (W.mat).map (algebraMap ℤ ℝ) := rfl
+
+lemma alGL_entry [NeZero M] (i j : Fin 2) :
+    W.alGL i j = algebraMap ℤ ℝ (W.mat i j) := by
+  show ((W.alGL : Matrix (Fin 2) (Fin 2) ℝ)) i j = _
+  rw [alGL_coe, Matrix.map_apply]
+
+lemma val_det_alGL [NeZero M] : ((W.alGL).det : ℝ) = (q : ℝ) := by
+  rw [Matrix.GeneralLinearGroup.val_det_apply, alGL_coe]
+  have h : ((W.mat).map (algebraMap ℤ ℝ)).det = (algebraMap ℤ ℝ) W.mat.det := by
+    rw [← RingHom.mapMatrix_apply, ← RingHom.map_det]
+  rw [h, W.det_mat]
+  simp
+
+lemma det_alGL_pos [NeZero M] : 0 < ((W.alGL).det : ℝ) := by
+  rw [val_det_alGL]
+  exact_mod_cast W.q_pos
+
+lemma σ_alGL_apply [NeZero M] (z : ℂ) : σ W.alGL z = z := by
+  rw [UpperHalfPlane.σ, ite_eq_left W.det_alGL_pos]
+  simp
+
+def alGLQ [NeZero M] : GL (Fin 2) ℚ :=
+  Matrix.GeneralLinearGroup.mkOfDetNeZero (W.mat.map (algebraMap ℤ ℚ)) (by
+    have h : ((W.mat).map (algebraMap ℤ ℚ)).det = (algebraMap ℤ ℚ) W.mat.det := by
+      rw [← RingHom.mapMatrix_apply, ← RingHom.map_det]
+    rw [h, W.det_mat]
+    simpa using W.q_pos.ne')
+
+lemma alGLQ_map_castHom [NeZero M] : (W.alGLQ).map (Rat.castHom ℝ) = W.alGL := by
+  apply Units.ext
+  change (Rat.castHom ℝ).mapMatrix ((W.alGLQ : Matrix (Fin 2) (Fin 2) ℚ))
+      = (W.alGL : Matrix (Fin 2) (Fin 2) ℝ)
+  change (Rat.castHom ℝ).mapMatrix ((W.mat).map (algebraMap ℤ ℚ))
+      = (W.mat).map (algebraMap ℤ ℝ)
+  rw [RingHom.mapMatrix_apply, Matrix.map_map]
+  congr 1
+
+end AtkinLehnerDatum
+
+def alSlash {M q : ℕ} (W : AtkinLehnerDatum M q) (k : ℤ) [NeZero M] (f : ℍ → ℂ) : ℍ → ℂ :=
+  f ∣[k] W.alGL
+
+lemma alSlash_def {M q : ℕ} (W : AtkinLehnerDatum M q) (k : ℤ) [NeZero M] (f : ℍ → ℂ) :
+    alSlash W k f = f ∣[k] W.alGL := rfl
+
+lemma alSlash_add {M q : ℕ} (W : AtkinLehnerDatum M q) (k : ℤ) [NeZero M] (f g : ℍ → ℂ) :
+    alSlash W k (f + g) = alSlash W k f + alSlash W k g := by
+  simp only [alSlash, SlashAction.add_slash]
+
+lemma alSlash_smul {M q : ℕ} (W : AtkinLehnerDatum M q) (k : ℤ) [NeZero M] (c : ℂ) (f : ℍ → ℂ) :
+    alSlash W k (c • f) = c • alSlash W k f := by
+  simp only [alSlash, ModularForm.smul_slash, AtkinLehnerDatum.σ_alGL_apply]
+
+end ModularForm
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularForm_EisensteinChiNegThree.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularForm_EisensteinChiNegThree.lean
new file mode 100644
index 0000000000..a4c8505900
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularForm_EisensteinChiNegThree.lean
@@ -0,0 +1,83 @@
+/-
+Based on Prove2Me node ModularForm_EisensteinChiNegThree
+(adc43756-9cf5-5205-863c-fe07d61abdf1) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.CStarAlgebra.Classes
+public import Mathlib.NumberTheory.ModularForms.Basic
+public import Mathlib.RingTheory.PowerSeries.Basic
+
+/-!
+# Weight-one level-three Eisenstein series: q-expansion and modularity
+
+Definition: `ModularForm_EisensteinChiNegThree` (`adc43756-9cf5-5205-863c-fe07d61abdf1`), by Claude,
+2026-09-05.
+
+The module fixes a concrete model for the weight-one Eisenstein series attached to the non-trivial
+Dirichlet character modulo $3$, working entirely with $q$-expansions. `chiNegThree : ℕ → ℤ` is that
+character written out by hand on residues: it sends $n$ to $1$ if $n \equiv 1 \pmod 3$, to $-1$ if
+$n \equiv 2 \pmod 3$, and to $0$ if $3 \mid n$; thus it is the Kronecker symbol
+$\left(\frac{-3}{\cdot}\right)$ as a function of natural numbers. `sigmaChi n` is the twisted
+divisor sum $\sum_{d \mid n} \chi_{-3}(d)$, the sum being over Mathlib's `Nat.divisors` (so
+`sigmaChi 0 = 0`, the divisor set of $0$ being empty). `e1Chi3 : PowerSeries ℤ` is then the formal
+power series whose $0$-th coefficient is $1$ and whose $n$-th coefficient for $n \ge 1$ is
+$6\,\sigma_{\chi}(n)$, i.e. $1 + 6\sum_{n \ge 1}\bigl(\sum_{d\mid n}\chi_{-3}(d)\bigr)q^n$; all
+coefficients beyond the constant term are divisible by $6$, in particular by $3$. For a commutative
+ring $R$, `e1Chi3In R` is the image of this series in $R[\![q]\!]$ under coefficientwise application
+of `Int.castRingHom R`.
+
+Finally `E1Chi3IsModular` is not a theorem but a `Prop`-valued definition, a named statement: it
+asserts the existence of a modular form $f$ of weight $1$ on the congruence subgroup $\Gamma_1(3)$
+such that for every point $z$ of the upper half-plane, $f(z)$ equals the sum $\sum_{n \ge 0} c_n
+e^{2\pi i n z}$, where $c_n$ is the $n$-th coefficient of `e1Chi3` pushed into $\mathbb{C}$. The sum
+is an unconditional `tsum` over $n : ℕ$, with no summability hypothesis recorded in the statement;
+the predicate thus says exactly that the formal series `e1Chi3` is realised as the $q$-expansion of
+some weight-one form on $\Gamma_1(3)$, and it is stated here as a hypothesis to be supplied
+elsewhere rather than proved in this module.
+
+**Relation to Mathlib.** The ambient notions `PowerSeries`, `ModularForm` and
+`CongruenceSubgroup.Gamma1` are Mathlib's; the character is not Mathlib's `DirichletCharacter` but a
+hand-written function `ℕ → ℤ` given by residues modulo $3$, and the Eisenstein series itself is
+introduced only through its integral $q$-expansion, with modularity packaged as the project's own
+proposition `E1Chi3IsModular`.
+
+**Where it is used.** Because every non-constant coefficient of `e1Chi3` is divisible by $3$, this
+series is congruent to $1$ modulo $3$, and multiplication by it is the weight-one-to-weight-two
+shift used in the Langlands–Tunnell part of the argument: a weight-one form is replaced by a
+weight-two form with the same mod-$3$ Hecke eigensystem. The definitions here are imported by the
+modules that set up that congruence.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace EisensteinWeightOne
+
+def chiNegThree (n : ℕ) : ℤ :=
+  if n % 3 = 1 then 1 else if n % 3 = 2 then -1 else 0
+
+def sigmaChi (n : ℕ) : ℤ :=
+  ∑ d ∈ n.divisors, chiNegThree d
+
+def e1Chi3 : PowerSeries ℤ :=
+  PowerSeries.mk fun n => if n = 0 then 1 else 6 * sigmaChi n
+
+noncomputable def e1Chi3In (R : Type*) [CommRing R] : PowerSeries R :=
+  PowerSeries.map (Int.castRingHom R) e1Chi3
+
+open CongruenceSubgroup in
+def E1Chi3IsModular : Prop :=
+  ∃ f : ModularForm (Gamma1 3) 1, ∀ z : UpperHalfPlane,
+    f z = ∑' n : ℕ,
+      ((PowerSeries.coeff n e1Chi3 : ℤ) : ℂ) *
+        Complex.exp (2 * (Real.pi : ℂ) * Complex.I * (n : ℂ) * (z : ℂ))
+
+end EisensteinWeightOne
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularForm_HeckeOperator.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularForm_HeckeOperator.lean
new file mode 100644
index 0000000000..a9a6806d15
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularForm_HeckeOperator.lean
@@ -0,0 +1,267 @@
+/-
+Based on Prove2Me node ModularForm_HeckeOperator
+(e1cf8d29-c1f1-569b-9fbd-05f00ec56b83) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.SlashActions
+
+/-!
+# Hecke operators Tp​, Up​ on functions on the upper half-plane
+
+Definition: `ModularForm_HeckeOperator` (`e1cf8d29-c1f1-569b-9fbd-05f00ec56b83`), by Claude,
+2026-09-05.
+
+The module sets up the weight-$k$ Hecke operators $T_p$ and $U_p$ as operators on arbitrary
+functions $f\colon\mathbb H\to\mathbb C$, using Mathlib's weight-$k$ slash action of
+$\mathrm{GL}_2(\mathbb R)$ (normalisation $|\det\gamma|^{k-1}\,\mathrm{denom}(\gamma,\tau)^{-k}$).
+First come the matrices: `upperTriangularGL a b d` is $\begin{pmatrix}a&b\\0&d\end{pmatrix}$ as an
+element of $\mathrm{GL}_2(\mathbb R)$, given $ad\neq 0$; `heckeMatrix p j` is
+$\begin{pmatrix}1&j\\0&p\end{pmatrix}$ and `heckeDiagMatrix p` is
+$\begin{pmatrix}p&0\\0&1\end{pmatrix}$, both defined for all natural $p$ with the junk value $1$ at
+$p=0$ so as to be total. Accompanying lemmas record their entries, that both determinants equal $p$
+and are positive, the values of `UpperHalfPlane.denom` ($p$, resp. $1$), the Möbius actions
+$\tau\mapsto(\tau+j)/p$ and $\tau\mapsto p\tau$, the triviality of the conjugation $\sigma$ attached
+to a positive determinant, and hence the pointwise slash formulas $(f\mid_k \texttt{heckeMatrix\ p\
+j})(\tau)=p^{-1}f((\tau+j)/p)$ and $(f\mid_k\texttt{heckeDiagMatrix\ p})(\tau)=p^{k-1}f(p\tau)$ for
+$p\neq 0$.
+
+Then `heckeU k p f` $=\sum_{j<p} f\mid_k\begin{pmatrix}1&j\\0&p\end{pmatrix}$ and `heckeT k p f` $=$
+`heckeU k p f` $+\,f\mid_k\begin{pmatrix}p&0\\0&1\end{pmatrix}$, with the pointwise formulas
+$(U_pf)(\tau)=p^{-1}\sum_{j<p}f((\tau+j)/p)$ and $(T_pf)(\tau)=(U_pf)(\tau)+p^{k-1}f(p\tau)$ for
+$p\neq 0$, the degenerate values `heckeU k 0 f = 0` and `heckeT k 0 f = f`, and additivity, $\mathbb
+C$-homogeneity, compatibility with negation and subtraction. Note that $p$ is an arbitrary natural
+number here: nothing in these definitions requires $p$ prime or imposes any modularity or growth
+condition on $f$.
+
+Finally the same operators are given on the coefficient side, as operators on sequences
+$a\colon\mathbb N\to\mathbb C$: `coeffHeckeU p a n = a (n * p)` and `coeffHeckeT k p a n = a (n * p)
++ p^{k-1} a (n / p)` when $p\mid n$, the second term being $0$ otherwise; these are shown additive
+and $\mathbb C$-homogeneous. No theorem in this module links the two sides; the coefficient
+operators are purely algebraic data.
+
+**Relation to Mathlib.** Mathlib supplies the upper half-plane, its $\mathrm{GL}_2(\mathbb
+R)$-action with `UpperHalfPlane.denom`, `UpperHalfPlane.σ` and the weight-$k$ slash action; the
+Hecke matrices and the operators $T_p$, $U_p$ built from them, together with their coefficient-side
+counterparts, are the project's own.
+
+**Where it is used.** These operators are the input to the notion of a normalised Hecke eigenform
+used throughout the modularity part of the argument; the coefficient-side versions `coeffHeckeT` and
+`coeffHeckeU` allow eigenform conditions on $q$-expansion coefficients to be stated without
+analysis. Separate modules prove that $T_p$ and $U_p$ preserve the spaces of modular and cusp forms
+for $\Gamma_0(N)$ and relate the two descriptions.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section DL_intactile
+
+open scoped MatrixGroups ModularForm
+
+namespace ModularForm
+
+def upperTriangularGL (a b d : ℝ) (had : a * d ≠ 0) : GL (Fin 2) ℝ :=
+  Matrix.GeneralLinearGroup.mkOfDetNeZero !![a, b; 0, d]
+    (by rwa [Matrix.det_fin_two_of, mul_zero, sub_zero])
+
+@[simp] theorem val_upperTriangularGL (a b d : ℝ) (had : a * d ≠ 0) :
+    ((upperTriangularGL a b d had : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) = !![a, b; 0, d] :=
+      rfl
+
+def heckeMatrix (p j : ℕ) : GL (Fin 2) ℝ :=
+  if hp : p = 0 then 1 else upperTriangularGL 1 j p (by rw [one_mul]; exact_mod_cast hp)
+
+def heckeDiagMatrix (p : ℕ) : GL (Fin 2) ℝ :=
+  if hp : p = 0 then 1 else upperTriangularGL p 0 1 (by rw [mul_one]; exact_mod_cast hp)
+
+@[simp] theorem val_heckeMatrix {p : ℕ} (hp : p ≠ 0) (j : ℕ) :
+    ((heckeMatrix p j : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) = !![(1 : ℝ), (j : ℝ); 0, (p : ℝ)]
+      := by
+  simp [heckeMatrix, hp]
+
+@[simp] theorem val_heckeDiagMatrix {p : ℕ} (hp : p ≠ 0) :
+    ((heckeDiagMatrix p : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) = !![(p : ℝ), 0; 0, 1] := by
+  simp [heckeDiagMatrix, hp]
+
+@[simp] theorem heckeMatrix_zero (j : ℕ) : heckeMatrix 0 j = 1 := by simp [heckeMatrix]
+
+@[simp] theorem heckeDiagMatrix_zero : heckeDiagMatrix 0 = 1 := by simp [heckeDiagMatrix]
+
+theorem det_heckeMatrix {p : ℕ} (hp : p ≠ 0) (j : ℕ) : ((heckeMatrix p j).det : ℝ) = p := by
+  rw [Matrix.GeneralLinearGroup.val_det_apply, val_heckeMatrix hp, Matrix.det_fin_two_of]
+  ring
+
+theorem det_heckeDiagMatrix {p : ℕ} (hp : p ≠ 0) : ((heckeDiagMatrix p).det : ℝ) = p := by
+  rw [Matrix.GeneralLinearGroup.val_det_apply, val_heckeDiagMatrix hp, Matrix.det_fin_two_of]
+  ring
+
+theorem det_heckeMatrix_pos (p j : ℕ) : 0 < ((heckeMatrix p j).det : ℝ) := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  · rw [det_heckeMatrix hp]; exact_mod_cast Nat.pos_of_ne_zero hp
+
+theorem det_heckeDiagMatrix_pos (p : ℕ) : 0 < ((heckeDiagMatrix p).det : ℝ) := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  · rw [det_heckeDiagMatrix hp]; exact_mod_cast Nat.pos_of_ne_zero hp
+
+theorem denom_heckeMatrix {p : ℕ} (hp : p ≠ 0) (j : ℕ) (τ : UpperHalfPlane) :
+    UpperHalfPlane.denom (heckeMatrix p j) τ = p := by
+  simp [UpperHalfPlane.denom, val_heckeMatrix hp]
+
+theorem denom_heckeDiagMatrix {p : ℕ} (hp : p ≠ 0) (τ : UpperHalfPlane) :
+    UpperHalfPlane.denom (heckeDiagMatrix p) τ = 1 := by
+  simp [UpperHalfPlane.denom, val_heckeDiagMatrix hp]
+
+theorem coe_heckeMatrix_smul {p : ℕ} (hp : p ≠ 0) (j : ℕ) (τ : UpperHalfPlane) :
+    ((heckeMatrix p j • τ : UpperHalfPlane) : ℂ) = ((τ : ℂ) + j) / p := by
+  rw [UpperHalfPlane.coe_smul_of_det_pos (det_heckeMatrix_pos p j)]
+  simp [UpperHalfPlane.num, UpperHalfPlane.denom, val_heckeMatrix hp]
+
+theorem coe_heckeDiagMatrix_smul {p : ℕ} (hp : p ≠ 0) (τ : UpperHalfPlane) :
+    ((heckeDiagMatrix p • τ : UpperHalfPlane) : ℂ) = (p : ℂ) * (τ : ℂ) := by
+  rw [UpperHalfPlane.coe_smul_of_det_pos (det_heckeDiagMatrix_pos p)]
+  simp [UpperHalfPlane.num, UpperHalfPlane.denom, val_heckeDiagMatrix hp]
+
+theorem σ_heckeMatrix (p j : ℕ) : UpperHalfPlane.σ (heckeMatrix p j) = .refl ℝ ℂ := by
+  rw [UpperHalfPlane.σ, ite_eq_left (det_heckeMatrix_pos p j)]
+
+theorem σ_heckeDiagMatrix (p : ℕ) : UpperHalfPlane.σ (heckeDiagMatrix p) = .refl ℝ ℂ := by
+  rw [UpperHalfPlane.σ, ite_eq_left (det_heckeDiagMatrix_pos p)]
+
+theorem slash_heckeMatrix_apply (k : ℤ) {p : ℕ} (hp : p ≠ 0) (j : ℕ) (f : UpperHalfPlane → ℂ)
+    (τ : UpperHalfPlane) :
+    (f ∣[k] heckeMatrix p j) τ = (p : ℂ)⁻¹ * f (heckeMatrix p j • τ) := by
+  have hp' : (p : ℂ) ≠ 0 := by exact_mod_cast hp
+  rw [ModularForm.slash_apply, σ_heckeMatrix, det_heckeMatrix hp, denom_heckeMatrix hp]
+  simp only [ContinuousAlgEquiv.refl_apply, Nat.abs_cast, Complex.ofReal_natCast]
+  rw [mul_assoc, ← zpow_add₀ hp', show k - 1 + -k = -1 by ring, zpow_neg_one, mul_comm]
+
+theorem slash_heckeDiagMatrix_apply (k : ℤ) {p : ℕ} (hp : p ≠ 0) (f : UpperHalfPlane → ℂ)
+    (τ : UpperHalfPlane) :
+    (f ∣[k] heckeDiagMatrix p) τ = (p : ℂ) ^ (k - 1) * f (heckeDiagMatrix p • τ) := by
+  rw [ModularForm.slash_apply, σ_heckeDiagMatrix, det_heckeDiagMatrix hp, denom_heckeDiagMatrix hp]
+  simp only [ContinuousAlgEquiv.refl_apply, Nat.abs_cast, Complex.ofReal_natCast, one_zpow, mul_one]
+  rw [mul_comm]
+
+def heckeU (k : ℤ) (p : ℕ) (f : UpperHalfPlane → ℂ) : UpperHalfPlane → ℂ :=
+  ∑ j ∈ Finset.range p, f ∣[k] heckeMatrix p j
+
+def heckeT (k : ℤ) (p : ℕ) (f : UpperHalfPlane → ℂ) : UpperHalfPlane → ℂ :=
+  heckeU k p f + f ∣[k] heckeDiagMatrix p
+
+theorem heckeU_def (k : ℤ) (p : ℕ) (f : UpperHalfPlane → ℂ) :
+    heckeU k p f = ∑ j ∈ Finset.range p, f ∣[k] heckeMatrix p j := rfl
+
+theorem heckeT_eq_heckeU_add (k : ℤ) (p : ℕ) (f : UpperHalfPlane → ℂ) :
+    heckeT k p f = heckeU k p f + f ∣[k] heckeDiagMatrix p := rfl
+
+theorem heckeT_def (k : ℤ) (p : ℕ) (f : UpperHalfPlane → ℂ) :
+    heckeT k p f = (∑ j ∈ Finset.range p, f ∣[k] heckeMatrix p j) + f ∣[k] heckeDiagMatrix p := rfl
+
+@[simp] theorem heckeU_zero_left (k : ℤ) (f : UpperHalfPlane → ℂ) : heckeU k 0 f = 0 := by
+  simp [heckeU]
+
+@[simp] theorem heckeT_zero_left (k : ℤ) (f : UpperHalfPlane → ℂ) : heckeT k 0 f = f := by
+  simp [heckeT]
+
+theorem heckeU_apply (k : ℤ) {p : ℕ} (hp : p ≠ 0) (f : UpperHalfPlane → ℂ) (τ : UpperHalfPlane) :
+    heckeU k p f τ = (p : ℂ)⁻¹ * ∑ j ∈ Finset.range p, f (heckeMatrix p j • τ) := by
+  simp only [heckeU, Finset.sum_apply, slash_heckeMatrix_apply k hp, Finset.mul_sum]
+
+theorem heckeT_apply (k : ℤ) {p : ℕ} (hp : p ≠ 0) (f : UpperHalfPlane → ℂ) (τ : UpperHalfPlane) :
+    heckeT k p f τ = (p : ℂ)⁻¹ * ∑ j ∈ Finset.range p, f (heckeMatrix p j • τ)
+      + (p : ℂ) ^ (k - 1) * f (heckeDiagMatrix p • τ) := by
+  rw [heckeT, Pi.add_apply, heckeU_apply k hp, slash_heckeDiagMatrix_apply k hp]
+
+@[simp] theorem heckeU_zero (k : ℤ) (p : ℕ) : heckeU k p (0 : UpperHalfPlane → ℂ) = 0 := by
+  simp [heckeU]
+
+@[simp] theorem heckeT_zero (k : ℤ) (p : ℕ) : heckeT k p (0 : UpperHalfPlane → ℂ) = 0 := by
+  simp [heckeT]
+
+theorem heckeU_add (k : ℤ) (p : ℕ) (f g : UpperHalfPlane → ℂ) :
+    heckeU k p (f + g) = heckeU k p f + heckeU k p g := by
+  simp [heckeU, Finset.sum_add_distrib]
+
+theorem heckeT_add (k : ℤ) (p : ℕ) (f g : UpperHalfPlane → ℂ) :
+    heckeT k p (f + g) = heckeT k p f + heckeT k p g := by
+  simp only [heckeT, heckeU_add, SlashAction.add_slash]
+  abel
+
+theorem heckeU_smul (k : ℤ) (p : ℕ) (c : ℂ) (f : UpperHalfPlane → ℂ) :
+    heckeU k p (c • f) = c • heckeU k p f := by
+  simp only [heckeU, ModularForm.smul_slash, σ_heckeMatrix, ContinuousAlgEquiv.refl_apply,
+    Finset.smul_sum]
+
+theorem heckeT_smul (k : ℤ) (p : ℕ) (c : ℂ) (f : UpperHalfPlane → ℂ) :
+    heckeT k p (c • f) = c • heckeT k p f := by
+  rw [heckeT, heckeT, heckeU_smul, ModularForm.smul_slash, σ_heckeDiagMatrix,
+    ContinuousAlgEquiv.refl_apply, smul_add]
+
+theorem heckeU_neg (k : ℤ) (p : ℕ) (f : UpperHalfPlane → ℂ) : heckeU k p (-f) = -heckeU k p f := by
+  simp [heckeU, Finset.sum_neg_distrib]
+
+theorem heckeT_neg (k : ℤ) (p : ℕ) (f : UpperHalfPlane → ℂ) : heckeT k p (-f) = -heckeT k p f := by
+  simp only [heckeT, heckeU_neg, SlashAction.neg_slash, neg_add]
+
+theorem heckeU_sub (k : ℤ) (p : ℕ) (f g : UpperHalfPlane → ℂ) :
+    heckeU k p (f - g) = heckeU k p f - heckeU k p g := by
+  rw [sub_eq_add_neg, heckeU_add, heckeU_neg, ← sub_eq_add_neg]
+
+theorem heckeT_sub (k : ℤ) (p : ℕ) (f g : UpperHalfPlane → ℂ) :
+    heckeT k p (f - g) = heckeT k p f - heckeT k p g := by
+  rw [sub_eq_add_neg, heckeT_add, heckeT_neg, ← sub_eq_add_neg]
+
+def coeffHeckeT (k : ℤ) (p : ℕ) (a : ℕ → ℂ) (n : ℕ) : ℂ :=
+  a (n * p) + if p ∣ n then (p : ℂ) ^ (k - 1) * a (n / p) else 0
+
+def coeffHeckeU (p : ℕ) (a : ℕ → ℂ) (n : ℕ) : ℂ :=
+  a (n * p)
+
+theorem coeffHeckeT_apply (k : ℤ) (p : ℕ) (a : ℕ → ℂ) (n : ℕ) :
+    coeffHeckeT k p a n = a (n * p) + if p ∣ n then (p : ℂ) ^ (k - 1) * a (n / p) else 0 := rfl
+
+theorem coeffHeckeU_apply (p : ℕ) (a : ℕ → ℂ) (n : ℕ) : coeffHeckeU p a n = a (n * p) := rfl
+
+theorem coeffHeckeT_of_dvd (k : ℤ) {p n : ℕ} (h : p ∣ n) (a : ℕ → ℂ) :
+    coeffHeckeT k p a n = a (n * p) + (p : ℂ) ^ (k - 1) * a (n / p) := by
+  rw [coeffHeckeT, ite_eq_left h]
+
+theorem coeffHeckeT_of_not_dvd (k : ℤ) {p n : ℕ} (h : ¬ p ∣ n) (a : ℕ → ℂ) :
+    coeffHeckeT k p a n = a (n * p) := by
+  rw [coeffHeckeT, ite_eq_right h, add_zero]
+
+theorem coeffHeckeT_eq_coeffHeckeU_add (k : ℤ) (p : ℕ) (a : ℕ → ℂ) (n : ℕ) :
+    coeffHeckeT k p a n = coeffHeckeU p a n + if p ∣ n then (p : ℂ) ^ (k - 1) * a (n / p) else 0 :=
+      rfl
+
+theorem coeffHeckeT_add (k : ℤ) (p : ℕ) (a b : ℕ → ℂ) :
+    coeffHeckeT k p (a + b) = coeffHeckeT k p a + coeffHeckeT k p b := by
+  funext n
+  simp only [coeffHeckeT, Pi.add_apply]
+  split_ifs <;> ring
+
+theorem coeffHeckeT_smul (k : ℤ) (p : ℕ) (c : ℂ) (a : ℕ → ℂ) :
+    coeffHeckeT k p (c • a) = c • coeffHeckeT k p a := by
+  funext n
+  simp only [coeffHeckeT, Pi.smul_apply, smul_eq_mul]
+  split_ifs <;> ring
+
+theorem coeffHeckeU_add (p : ℕ) (a b : ℕ → ℂ) :
+    coeffHeckeU p (a + b) = coeffHeckeU p a + coeffHeckeU p b := rfl
+
+theorem coeffHeckeU_smul (p : ℕ) (c : ℂ) (a : ℕ → ℂ) :
+    coeffHeckeU p (c • a) = c • coeffHeckeU p a := rfl
+
+end ModularForm
+
+end DL_intactile
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ModularForm_HeckeOperatorForms.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularForm_HeckeOperatorForms.lean
new file mode 100644
index 0000000000..b47fc85f27
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ModularForm_HeckeOperatorForms.lean
@@ -0,0 +1,173 @@
+/-
+Based on Prove2Me node ModularForm_HeckeOperatorForms
+(fade376f-2288-591a-bdb5-cbe38983f3ce) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_heckeT_slash_eq_self_of_mem_Gamma0
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_heckeU_slash_eq_self_of_mem_Gamma0
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_mdifferentiable_heckeT
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_mdifferentiable_heckeU
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularFormClass_isBoundedAt_heckeT
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularFormClass_isBoundedAt_heckeU
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspFormClass_isZeroAt_heckeT
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspFormClass_isZeroAt_heckeU
+
+/-!
+# Hecke operators Tp​, Up​ on modular and cusp forms
+
+Definition: `ModularForm_HeckeOperatorForms` (`fade376f-2288-591a-bdb5-cbe38983f3ce`), by Claude,
+2026-09-05.
+
+For a weight $k \in \mathbb{Z}$ and level $\Gamma_0(N)$, this module packages the raw Hecke
+operators of `ModularForm_HeckeOperator` as bundled $\mathbb{C}$-linear endomorphisms of the Mathlib
+spaces `ModularForm (CongruenceSubgroup.Gamma0 N) k` and `CuspForm (CongruenceSubgroup.Gamma0 N) k`.
+Recall the underlying operators on functions $f : \mathbb{H} \to \mathbb{C}$: with $\alpha_j =
+\begin{pmatrix}1 & j\\ 0 & p\end{pmatrix}$ and $\delta_p = \begin{pmatrix}p & 0\\ 0 &
+1\end{pmatrix}$ acting by the weight-$k$ slash action, `heckeU k p f` $= \sum_{j=0}^{p-1} f \mid_k
+\alpha_j$, i.e. $\tau \mapsto p^{-1}\sum_{j<p} f((\tau+j)/p)$, and `heckeT k p f` $=$ `heckeU k p f`
+$+\, f\mid_k \delta_p$, i.e. the extra term $p^{k-1}f(p\tau)$; on $q$-expansions these are the usual
+normalisations $a_n \mapsto a_{np}$ and $a_n \mapsto a_{np} + p^{k-1}a_{n/p}$.
+
+[`ModularForm.heckeTLin k hp hpN`](../def/ModularForm_HeckeOperatorForms.html#L20) takes $p$ prime
+and $p \nmid N$ (whence $N \neq 0$, since $p \mid 0$) and sends $f$ to the modular form whose
+underlying function is `heckeT k p ⇑f`; its three structure fields — $\Gamma_0(N)$-invariance under
+the weight-$k$ slash action, holomorphy as a map of the upper half-plane, and boundedness at the
+cusps — are filled in by the imported theorems `heckeT_slash_eq_self_of_mem_Gamma0`,
+`mdifferentiable_heckeT` and
+[`ModularFormClass.isBoundedAt_heckeT`](../thm.html#ModularFormClass.isBoundedAt_heckeT).
+[`ModularForm.heckeULin k hpN`](../def/ModularForm_HeckeOperatorForms.html#L34) does the same with
+`heckeU` under the hypotheses `[NeZero N]` and $p \mid N$; note that no primality of $p$ is assumed
+for $U_p$. [`CuspForm.heckeTLin`](../def/ModularForm_HeckeOperatorForms.html#L69) and
+[`CuspForm.heckeULin`](../def/ModularForm_HeckeOperatorForms.html#L83) are the parallel
+constructions on cusp forms, with the boundedness field replaced by vanishing at the cusps via
+[`CuspFormClass.isZeroAt_heckeT`](../thm.html#CuspFormClass.isZeroAt_heckeT)/`isZeroAt_heckeU`.
+Additivity and $\mathbb{C}$-homogeneity come from `heckeT_add`, `heckeT_smul`, `heckeU_add`,
+`heckeU_smul` through injectivity of the coercion to functions. Four `rfl` lemmas
+(`coe_heckeTLin_apply`, `coe_heckeULin_apply` and their pointwise forms) record that the coercion of
+the bundled operator is the raw operator. Only $T_p$ and $U_p$ at a single prime are constructed
+here: no $T_n$ for composite $n$, and no $\Gamma_1(N)$ or nebentypus variants.
+
+**Relation to Mathlib.** Built on Mathlib's `ModularForm`, `CuspForm`, `CongruenceSubgroup.Gamma0`
+and weight-$k$ slash action; Mathlib provides no Hecke operators on these spaces, so these linear
+endomorphisms are the project's own.
+
+**Where it is used.** These bundled operators make the Hecke action on $S_k(\Gamma_0(N))$
+expressible in Lean, and hence statements about commuting families, eigenforms and their eigenvalues
+— the input to the construction of the Galois representation attached to a weight-$2$ newform on
+$\Gamma_0(N)$ used in the Frey curve argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section
+
+namespace ModularForm
+
+variable {N : ℕ} {p : ℕ}
+
+def heckeTLin (k : ℤ) (hp : p.Prime) (hpN : ¬ p ∣ N) :
+    ModularForm (CongruenceSubgroup.Gamma0 N) k →ₗ[ℂ] ModularForm (CongruenceSubgroup.Gamma0 N) k :=
+  haveI : NeZero N := ⟨fun h => hpN (h ▸ dvd_zero p)⟩
+  { toFun := fun f =>
+      { toFun := heckeT k p ⇑f
+        slash_action_eq' := fun γ hγ => heckeT_slash_eq_self_of_mem_Gamma0 k hp hpN
+          (fun γ hγ => SlashInvariantFormClass.slash_action_eq f γ hγ) γ hγ
+        holo' := mdifferentiable_heckeT (ModularFormClass.holo f) k p
+        bdd_at_cusps' := fun hc => ModularFormClass.isBoundedAt_heckeT f p hc }
+    map_add' := fun f g => DFunLike.coe_injective <|
+      show heckeT k p ⇑(f + g) = heckeT k p ⇑f + heckeT k p ⇑g by rw [FunLike.coe_add, heckeT_add]
+    map_smul' := fun c f => DFunLike.coe_injective <|
+      show heckeT k p ⇑(c • f) = c • heckeT k p ⇑f by rw [FunLike.coe_smul, heckeT_smul] }
+
+def heckeULin (k : ℤ) [NeZero N] (hpN : p ∣ N) :
+    ModularForm (CongruenceSubgroup.Gamma0 N) k →ₗ[ℂ]
+      ModularForm (CongruenceSubgroup.Gamma0 N) k where
+  toFun f :=
+    { toFun := heckeU k p ⇑f
+      slash_action_eq' := fun γ hγ => heckeU_slash_eq_self_of_mem_Gamma0 k hpN
+        (fun γ hγ => SlashInvariantFormClass.slash_action_eq f γ hγ) γ hγ
+      holo' := mdifferentiable_heckeU (ModularFormClass.holo f) k p
+      bdd_at_cusps' := fun hc => ModularFormClass.isBoundedAt_heckeU f p hc }
+  map_add' f g := DFunLike.coe_injective <|
+    show heckeU k p ⇑(f + g) = heckeU k p ⇑f + heckeU k p ⇑g by rw [FunLike.coe_add, heckeU_add]
+  map_smul' c f := DFunLike.coe_injective <|
+    show heckeU k p ⇑(c • f) = c • heckeU k p ⇑f by rw [FunLike.coe_smul, heckeU_smul]
+
+@[simp] theorem coe_heckeTLin_apply (k : ℤ) (hp : p.Prime) (hpN : ¬ p ∣ N)
+    (f : ModularForm (CongruenceSubgroup.Gamma0 N) k) : ⇑(heckeTLin k hp hpN f) = heckeT k p ⇑f :=
+      rfl
+
+@[simp] theorem coe_heckeULin_apply (k : ℤ) [NeZero N] (hpN : p ∣ N)
+    (f : ModularForm (CongruenceSubgroup.Gamma0 N) k) : ⇑(heckeULin k hpN f) = heckeU k p ⇑f := rfl
+
+theorem heckeTLin_apply_apply (k : ℤ) (hp : p.Prime) (hpN : ¬ p ∣ N)
+    (f : ModularForm (CongruenceSubgroup.Gamma0 N) k) (τ : UpperHalfPlane) :
+    heckeTLin k hp hpN f τ = heckeT k p ⇑f τ := rfl
+
+theorem heckeULin_apply_apply (k : ℤ) [NeZero N] (hpN : p ∣ N)
+    (f : ModularForm (CongruenceSubgroup.Gamma0 N) k) (τ : UpperHalfPlane) :
+    heckeULin k hpN f τ = heckeU k p ⇑f τ := rfl
+
+end ModularForm
+
+namespace CuspForm
+
+open ModularForm
+
+variable {N : ℕ} {p : ℕ}
+
+def heckeTLin (k : ℤ) (hp : p.Prime) (hpN : ¬ p ∣ N) :
+    CuspForm (CongruenceSubgroup.Gamma0 N) k →ₗ[ℂ] CuspForm (CongruenceSubgroup.Gamma0 N) k :=
+  haveI : NeZero N := ⟨fun h => hpN (h ▸ dvd_zero p)⟩
+  { toFun := fun f =>
+      { toFun := heckeT k p ⇑f
+        slash_action_eq' := fun γ hγ => heckeT_slash_eq_self_of_mem_Gamma0 k hp hpN
+          (fun γ hγ => SlashInvariantFormClass.slash_action_eq f γ hγ) γ hγ
+        holo' := mdifferentiable_heckeT (CuspFormClass.holo f) k p
+        zero_at_cusps' := fun hc => CuspFormClass.isZeroAt_heckeT f p hc }
+    map_add' := fun f g => DFunLike.coe_injective <|
+      show heckeT k p ⇑(f + g) = heckeT k p ⇑f + heckeT k p ⇑g by rw [FunLike.coe_add, heckeT_add]
+    map_smul' := fun c f => DFunLike.coe_injective <|
+      show heckeT k p ⇑(c • f) = c • heckeT k p ⇑f by rw [FunLike.coe_smul, heckeT_smul] }
+
+def heckeULin (k : ℤ) [NeZero N] (hpN : p ∣ N) :
+    CuspForm (CongruenceSubgroup.Gamma0 N) k →ₗ[ℂ] CuspForm (CongruenceSubgroup.Gamma0 N) k where
+  toFun f :=
+    { toFun := heckeU k p ⇑f
+      slash_action_eq' := fun γ hγ => heckeU_slash_eq_self_of_mem_Gamma0 k hpN
+        (fun γ hγ => SlashInvariantFormClass.slash_action_eq f γ hγ) γ hγ
+      holo' := mdifferentiable_heckeU (CuspFormClass.holo f) k p
+      zero_at_cusps' := fun hc => CuspFormClass.isZeroAt_heckeU f p hc }
+  map_add' f g := DFunLike.coe_injective <|
+    show heckeU k p ⇑(f + g) = heckeU k p ⇑f + heckeU k p ⇑g by rw [FunLike.coe_add, heckeU_add]
+  map_smul' c f := DFunLike.coe_injective <|
+    show heckeU k p ⇑(c • f) = c • heckeU k p ⇑f by rw [FunLike.coe_smul, heckeU_smul]
+
+@[simp] theorem coe_heckeTLin_apply (k : ℤ) (hp : p.Prime) (hpN : ¬ p ∣ N)
+    (f : CuspForm (CongruenceSubgroup.Gamma0 N) k) : ⇑(heckeTLin k hp hpN f) = heckeT k p ⇑f := rfl
+
+@[simp] theorem coe_heckeULin_apply (k : ℤ) [NeZero N] (hpN : p ∣ N)
+    (f : CuspForm (CongruenceSubgroup.Gamma0 N) k) : ⇑(heckeULin k hpN f) = heckeU k p ⇑f := rfl
+
+theorem heckeTLin_apply_apply (k : ℤ) (hp : p.Prime) (hpN : ¬ p ∣ N)
+    (f : CuspForm (CongruenceSubgroup.Gamma0 N) k) (τ : UpperHalfPlane) :
+    heckeTLin k hp hpN f τ = heckeT k p ⇑f τ := rfl
+
+theorem heckeULin_apply_apply (k : ℤ) [NeZero N] (hpN : p ∣ N)
+    (f : CuspForm (CongruenceSubgroup.Gamma0 N) k) (τ : UpperHalfPlane) :
+    heckeULin k hpN f τ = heckeU k p ⇑f τ := rfl
+
+end CuspForm
+
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_P2M_Util.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_P2M_Util.lean
new file mode 100644
index 0000000000..dc2ff8cddc
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_P2M_Util.lean
@@ -0,0 +1,212 @@
+/-
+Based on Prove2Me node P2M_Util
+(217e943d-2223-5c63-9415-3c10daa2cd91) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Lean
+public meta import Lean.Elab.Tactic.ElabTerm
+
+
+/-!
+# P2M helper commands (scope and alias plumbing)
+
+Definition: `P2M_Util` (`217e943d-2223-5c63-9415-3c10daa2cd91`), by Claude, 2026-09-05.
+
+Helper commands used by the FLT proof files to restore namespace/scope context after the project was
+split into one-declaration modules. Defines only elaboration-time scope and alias commands plus one
+closing tactic; it adds no declarations or axioms.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+-- open Lean Elab Tactic Meta in
+-- /-- `p2m_exact_reverting e` reverts all non-implementation-detail local declarations,
+-- preserving their order, then checks `e` against the resulting generalized goal and closes it.
+-- Auxiliary declarations are cleared during reversion. Fails if expression metavariables remain.
+-- This lets a proof of the complete statement solve a goal whose binders were already introduced. -/
+-- elab "p2m_exact_reverting " e:term : tactic => do
+--   let g ← getMainGoal
+--   let lctx := (← g.getDecl).lctx
+--   let fvars := lctx.foldl (init := #[]) fun acc d =>
+--     if d.isImplementationDetail then acc else acc.push d.fvarId
+--   let (_, g') ← g.revert fvars (preserveOrder := true) (clearAuxDeclsInsteadOfRevert := true)
+--   g'.withContext do
+--     let tgt ← g'.getType
+--     let v ← Term.withSynthesize <| elabTermEnsuringType e tgt
+--     let v ← instantiateMVars v
+--     if v.hasExprMVar then throwError "p2m_exact_reverting: unassigned metavariables remain"
+--     g'.assign v
+--   replaceMainGoal []
+
+-- open Lean Elab Command Meta in
+-- /-- `#p2m_type_eq A B` checks that the types of declarations `A` and `B` are definitionally
+-- equal after universe unification. Treating `A` as the statement and `B` as its proof, it also
+-- rejects matches that specialize or identify universe parameters of `A`.
+-- Logs `P2M_TYPE_EQ` on success; errors on unknown constants, a type mismatch, or insufficient
+-- universe generality. Compares types, not proof bodies, and does not check for `sorry`. -/
+-- elab "#p2m_type_eq " a:ident b:ident : command => liftTermElabM do
+--   let some ia := (← getEnv).find? a.getId | throwError m!"#p2m_type_eq: unknown constant {a.getId}"
+--   let some ib := (← getEnv).find? b.getId | throwError m!"#p2m_type_eq: unknown constant {b.getId}"
+--   let la ← ia.levelParams.mapM fun _ => mkFreshLevelMVar
+--   let lb ← ib.levelParams.mapM fun _ => mkFreshLevelMVar
+--   let ta := ia.type.instantiateLevelParams ia.levelParams la
+--   let tb := ib.type.instantiateLevelParams ib.levelParams lb
+--   if ← isDefEq ta tb then
+--     let mut pinned : Array String := #[]
+--     let mut seen : Array Level := #[]
+--     for l in la, nm in ia.levelParams do
+--       let l' ← instantiateLevelMVars l
+--       match l' with
+--       | .mvar _ => if seen.contains l' then pinned := pinned.push s!"{nm} (identified with another)" else seen := seen.push l'
+--       | _ => pinned := pinned.push s!"{nm} := {l'}"
+--     if pinned.isEmpty then
+--       logInfo m!"P2M_TYPE_EQ {a.getId} {b.getId}"
+--     else
+--       throwError m!"P2M_UNDERGENERAL: the statement's universes {pinned} had to be specialised to match the proof — the proof is less general than the card"
+--   else
+--     throwError m!"P2M_TYPE_MISMATCH\n {a.getId} : {ta}\n {b.getId} : {tb}"
+
+-- open Lean Elab Command in
+-- /-- `p2m_ns "N"` registers `N` as a namespace without entering or opening it. -/
+-- elab "p2m_ns " s:str : command => modifyEnv fun env => env.registerNamespace s.getString.toName
+
+open Lean Elab Command in
+/-- Opens the space-separated namespaces in `s` and activates their scoped extensions.
+An entry `N~x~y` hides `x` and `y` from ordinary name lookup through this opening of `N`.
+Shared implementation of `p2m_open` and its command-local form. -/
+meta def p2mOpenCore (s : String) : CommandElabM Unit := do
+  for w in s.splitOn " " do
+    if w.isEmpty then continue
+    let parts := w.splitOn "~"
+    let ns := parts.head!.toName
+    let hidden := (parts.drop 1).filter (· ≠ "") |>.map (fun h => h.toName)
+    modifyScope fun sc => { sc with openDecls := OpenDecl.simple ns hidden :: sc.openDecls }
+    activateScoped ns
+
+open Lean Elab Command in
+/-- `p2m_open "N M"` opens the listed namespaces and activates their scoped extensions.
+Use `N~x~y` to hide names `x` and `y` when opening `N`. Empty entries are ignored.
+The openings last for the current scope; use `p2m_open "N M" in cmd` for one command. -/
+elab "p2m_open " s:str : command => p2mOpenCore s.getString
+
+-- open Lean Elab Command in
+-- /-- `p2m_export_all "N" "S"` aliases declarations below `N.S` under `S` in the current
+-- namespace, preserving their relative names. The scan uses user-facing names for private
+-- declarations and excludes internal-detail names and `N.S` itself.
+-- Creates name-resolution aliases, not copies of the declarations. -/
+-- elab "p2m_export_all " n:str s:str : command => do
+--   let env ← getEnv
+--   let short := s.getString.toName
+--   let base := n.getString.toName ++ short
+--   let cur ← getCurrNamespace
+--   let mut al : Array (Name × Name) := #[]
+--   for (c, _) in env.constants.map₂.toList do
+--     let u := (privateToUserName? c).getD c
+--     if base.isPrefixOf u && u != base && !u.isInternalDetail then
+--       al := al.push (cur ++ short ++ u.replacePrefix base Name.anonymous, c)
+--   modifyEnv fun env => al.foldl (fun env p => addAlias env p.1 p.2) env
+
+-- open Lean Elab Command Meta in
+-- /-- `#p2m_type_eq_warn A B` checks definitional equality of declaration types after universe
+-- unification. Logs `P2M_TYPE_EQ` on success and a non-fatal `P2M_DUP_TYPE_MISMATCH` warning on
+-- mismatch; unknown constants still cause errors. Unlike `#p2m_type_eq`, it does not check
+-- universe generality. Does not compare proof bodies or check for `sorry`. -/
+-- elab "#p2m_type_eq_warn " a:ident b:ident : command => liftTermElabM do
+--   let some ia := (← getEnv).find? a.getId | throwError m!"#p2m_type_eq_warn: unknown constant {a.getId}"
+--   let some ib := (← getEnv).find? b.getId | throwError m!"#p2m_type_eq_warn: unknown constant {b.getId}"
+--   let la ← ia.levelParams.mapM fun _ => mkFreshLevelMVar
+--   let lb ← ib.levelParams.mapM fun _ => mkFreshLevelMVar
+--   let ta := ia.type.instantiateLevelParams ia.levelParams la
+--   let tb := ib.type.instantiateLevelParams ib.levelParams lb
+--   if ← isDefEq ta tb then logInfo m!"P2M_TYPE_EQ {a.getId} {b.getId}"
+--   else logWarning m!"P2M_DUP_TYPE_MISMATCH (non-fatal)\n {a.getId} : {ta}\n {b.getId} : {tb}"
+
+-- open Lean Elab Command in
+-- /-- `p2m_alias "a" "N.b"` adds the name-resolution alias `a` for the existing declaration
+-- `N.b`. Uses the names as supplied, without prepending the current namespace. If the target
+-- is absent, tries its private name in the current module; silently skips a missing target. -/
+-- elab "p2m_alias " a:str n:str : command => do
+--   let env ← getEnv
+--   let full := n.getString.toName
+--   let tgt := if env.contains full then some full else (let p := mkPrivateName env full; if env.contains p then some p else none)
+--   match tgt with
+--   | some t => modifyEnv fun env => addAlias env a.getString.toName t
+--   | none => pure ()
+
+open Lean Elab Command in
+/-- `p2m_open_scoped "N M"` activates the listed namespaces' scoped extensions without
+opening ordinary names. Empty entries are ignored, and any `~...` suffix is discarded.
+Use `p2m_open_scoped "N M" in cmd` to restrict activation to one command. -/
+elab "p2m_open_scoped " s:str : command => do
+  for w in s.getString.splitOn " " do
+    if w.isEmpty then continue
+    activateScoped ((w.splitOn "~").head!).toName
+
+/-- `p2m_open "N M" in cmd` opens namespaces and activates their scoped extensions only
+within `cmd`, by wrapping the opening and command in a temporary section.
+Supports the same `N~x~y` hiding syntax as `p2m_open`. -/
+syntax (name := p2mOpenIn) "p2m_open " str " in" ppLine command : command
+open Lean in
+macro_rules | `(p2m_open $s:str in $c:command) => return mkNullNode #[← `(section), ← `(p2m_open $s:str), c, ← `(end)]
+
+open Lean Elab Command in
+/-- `p2m_export "N" "a b"` aliases `N.a` and `N.b` as `a` and `b` in the current namespace.
+For each target, tries the ordinary declaration name, then its private name in the current
+module. Silently skips missing targets and empty entries. Creates aliases, not new proofs. -/
+elab "p2m_export " n:str m:str : command => do
+  let env ← getEnv
+  let ns := n.getString.toName
+  let cur ← getCurrNamespace
+  let mut al : Array (Name × Name) := #[]
+  for w in m.getString.splitOn " " do
+    if w.isEmpty then continue
+    let full := ns ++ w.toName
+    if env.contains full then al := al.push (cur ++ w.toName, full)
+    else
+      let prv := mkPrivateName env full
+      if env.contains prv then al := al.push (cur ++ w.toName, prv)
+  modifyEnv fun env => al.foldl (fun env p => addAlias env p.1 p.2) env
+
+-- open Lean Elab Command in
+-- /-- `p2m_reactivate "N M"` forces the listed namespaces' scoped registrations to activate
+-- again. For each scoped environment extension, removes the namespace from the active-scope
+-- set at the top of its state stack, then reactivates it. This can restore registrations after
+-- environment changes even when the namespace was already marked active. -/
+-- elab "p2m_reactivate " s:str : command => do
+--   for w in s.getString.splitOn " " do
+--     if w.isEmpty then continue
+--     let ns := w.toName
+--     for ext in (← scopedEnvExtensionsRef.get) do
+--       modifyEnv fun env =>
+--         let st := ext.ext.getState env
+--         match st.stateStack with
+--         | top :: stack =>
+--           let top := { top with activeScopes := top.activeScopes.erase ns }
+--           ext.activateScoped (ext.ext.setState env { st with stateStack := top :: stack }) ns
+--         | _ => env
+
+/-- `p2m_open_scoped "N M" in cmd` activates scoped extensions only within `cmd`, using
+a temporary section. Does not open ordinary names. -/
+macro "p2m_open_scoped " s:str " in " c:command : command => `(section p2m_open_scoped $s $c end)
+
+-- open Lean Elab Command in
+-- /-- Tolerant attribute erasure: `p2m_attr_erase "simp" "a b c"` erases the attribute from each listed
+-- constant that exists in the environment and skips the others. In the original monolithic build every
+-- target existed; on the platform a target may be absent from the smaller import closure, where
+-- absence and erasure coincide. -/
+-- elab "p2m_attr_erase " attr:str names:str : command => do
+--   let attrName := attr.getString.toName
+--   for w in names.getString.splitOn " " do
+--     if w.isEmpty then continue
+--     let n := w.toName
+--     if (← getEnv).contains n then
+--       liftCoreM <| Lean.Attribute.erase n attrName
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_PeriodPair_Uniformization.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_PeriodPair_Uniformization.lean
new file mode 100644
index 0000000000..0e339e28ab
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_PeriodPair_Uniformization.lean
@@ -0,0 +1,205 @@
+/-
+Based on Prove2Me node PeriodPair_Uniformization
+(9f344b4d-52f5-57d1-93b5-645fe049391c) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.Analysis.CStarAlgebra.Classes
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Basic
+public import Mathlib.Analysis.SpecialFunctions.Elliptic.Weierstrass
+public import Mathlib.FieldTheory.Perfect
+public import Mathlib.RingTheory.Flat.FaithfullyFlat.Algebra
+public import Mathlib.RingTheory.Flat.TorsionFree
+public import Mathlib.RingTheory.SimpleRing.Principal
+
+/-!
+# Weierstrass curve, ℘-parametrisation and j-invariant of a lattice
+
+Definition: `PeriodPair_Uniformization` (`9f344b4d-52f5-57d1-93b5-645fe049391c`), by Claude,
+2026-09-05.
+
+The context is Mathlib's `PeriodPair` $L$, i.e. a pair of complex numbers $\omega_1,\omega_2$ that
+are linearly independent over $\mathbb R$, with its lattice $\Lambda = \mathbb Z\omega_1 + \mathbb
+Z\omega_2$, its Weierstrass function $\wp$ and derivative $\wp'$, and its invariants $g_2, g_3$.
+[`PeriodPair.weierstrassCurve`](../def/PeriodPair_Uniformization.html#L13) is the Weierstrass curve
+over $\mathbb C$ with $a_1=a_2=a_3=0$, $a_4=-g_2/4$, $a_6=-g_3/4$, that is $y^2 = x^3 - (g_2/4)x -
+(g_3/4)$; the accompanying computations give $\Delta = g_2^3 - 27g_3^2$ and $c_4 = 12 g_2$, and
+`equation_weierstrassP` says that for $z \notin \Lambda$ the point $(\wp(z), \wp'(z)/2)$ satisfies
+the affine equation of this curve (the normalisation $y = \wp'/2$ is what produces these unscaled
+formulae for $\Delta$ and $c_4$). `DiscriminantNeZero` is the predicate $g_2^3 - 27g_3^2 \neq 0$,
+equivalently $\Delta \neq 0$ for this model. Given that predicate, `toPoint` sends $z \in \Lambda$
+to the point at infinity and $z \notin \Lambda$ to the affine point $(\wp(z), \wp'(z)/2)$, which is
+nonsingular because $\Delta \neq 0$; `IsUniformization` is the conjunction of three assertions about
+this map: it is additive, it is surjective onto the points of the curve, and any $z$ with `toPoint`
+$z = 0$ lies in $\Lambda$. `jLattice` is $1728\,g_2^3/(g_2^3 - 27g_3^2)$, shown to equal
+$c_4^3/\Delta$ of the above model (both sides being $0$ when the denominator vanishes), and
+`JSurjective` asserts that every complex number is $j(\Lambda)$ for some period pair with
+nonvanishing discriminant. Finally, `ofTau` is the normalised pair $(\tau,1)$ for $\tau$ in the
+upper half-plane, with lattice the $\mathbb Z$-span of $\{\tau,1\}$; `scale` is the homothety
+$(\alpha\omega_1,\alpha\omega_2)$ by a unit $\alpha$; and `sublatticeIndex L L'`,
+`sublatticeQuotient L L'` are the index and the quotient of $\Lambda$ by the subgroup $\Lambda' \cap
+\Lambda$ of $\Lambda$.
+
+**Relation to Mathlib.** The structure `PeriodPair` itself, its lattice, $\wp$, $\wp'$, $g_2$, $g_3$
+and the differential equation for $\wp'^2$ are Mathlib's, as are `WeierstrassCurve` with its
+invariants $\Delta$, $c_4$ and the affine point group; what is added here is the passage from a
+period pair to a concrete Weierstrass model, the ℘-parametrisation of its points, the lattice
+$j$-invariant, and the predicates recording nonvanishing of the discriminant, the uniformization
+property and surjectivity of $j$.
+
+**Where it is used.** These definitions provide the analytic side of the theory of elliptic curves
+over $\mathbb C$: the dictionary between lattices up to homothety and complex elliptic curves via
+$j$, and between sublattices of finite index and isogenies, as used in the treatment of modular
+curves and modular forms in the modularity part of the argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section DL_lapidification
+
+open scoped PeriodPair UpperHalfPlane
+
+namespace PeriodPair
+
+variable (L : PeriodPair)
+
+def weierstrassCurve : WeierstrassCurve ℂ where
+  a₁ := 0
+  a₂ := 0
+  a₃ := 0
+  a₄ := -L.g₂ / 4
+  a₆ := -L.g₃ / 4
+
+@[simp] theorem weierstrassCurve_a₁ : L.weierstrassCurve.a₁ = 0 := rfl
+@[simp] theorem weierstrassCurve_a₂ : L.weierstrassCurve.a₂ = 0 := rfl
+@[simp] theorem weierstrassCurve_a₃ : L.weierstrassCurve.a₃ = 0 := rfl
+@[simp] theorem weierstrassCurve_a₄ : L.weierstrassCurve.a₄ = -L.g₂ / 4 := rfl
+@[simp] theorem weierstrassCurve_a₆ : L.weierstrassCurve.a₆ = -L.g₃ / 4 := rfl
+
+theorem weierstrassCurve_Δ : L.weierstrassCurve.Δ = L.g₂ ^ 3 - 27 * L.g₃ ^ 2 := by
+  simp only [WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄, WeierstrassCurve.b₆,
+    WeierstrassCurve.b₈, weierstrassCurve_a₁, weierstrassCurve_a₂, weierstrassCurve_a₃,
+    weierstrassCurve_a₄, weierstrassCurve_a₆]
+  ring
+
+theorem weierstrassCurve_c₄ : L.weierstrassCurve.c₄ = 12 * L.g₂ := by
+  simp only [WeierstrassCurve.c₄, WeierstrassCurve.b₂, WeierstrassCurve.b₄, weierstrassCurve_a₁,
+    weierstrassCurve_a₂, weierstrassCurve_a₃, weierstrassCurve_a₄]
+  ring
+
+theorem equation_weierstrassP {z : ℂ} (hz : z ∉ L.lattice) :
+    L.weierstrassCurve.toAffine.Equation (℘[L] z) (℘'[L] z / 2) := by
+  rw [WeierstrassCurve.Affine.equation_iff]
+  have h := L.derivWeierstrassP_sq z hz
+  change (℘'[L] z / 2) ^ 2 + L.weierstrassCurve.a₁ * ℘[L] z * (℘'[L] z / 2) +
+      L.weierstrassCurve.a₃ * (℘'[L] z / 2) = ℘[L] z ^ 3 + L.weierstrassCurve.a₂ * ℘[L] z ^ 2 +
+      L.weierstrassCurve.a₄ * ℘[L] z + L.weierstrassCurve.a₆
+  rw [weierstrassCurve_a₁, weierstrassCurve_a₂, weierstrassCurve_a₃, weierstrassCurve_a₄,
+    weierstrassCurve_a₆]
+  linear_combination (1 / 4 : ℂ) * h
+
+def DiscriminantNeZero : Prop :=
+  L.g₂ ^ 3 - 27 * L.g₃ ^ 2 ≠ 0
+
+theorem DiscriminantNeZero.weierstrassCurve_Δ_ne_zero {L : PeriodPair}
+    (h : L.DiscriminantNeZero) : L.weierstrassCurve.Δ ≠ 0 := by
+  rwa [L.weierstrassCurve_Δ]
+
+open Classical in
+def toPoint (h : L.DiscriminantNeZero) (z : ℂ) : L.weierstrassCurve.toAffine.Point :=
+  if hz : z ∈ L.lattice then 0
+  else .some _ _ ((WeierstrassCurve.Affine.equation_iff_nonsingular_of_Δ_ne_zero
+    h.weierstrassCurve_Δ_ne_zero).mp (L.equation_weierstrassP hz))
+
+@[simp]
+theorem toPoint_of_mem (h : L.DiscriminantNeZero) {z : ℂ} (hz : z ∈ L.lattice) :
+    L.toPoint h z = 0 := by simp [toPoint, hz]
+
+@[simp]
+theorem toPoint_zero (h : L.DiscriminantNeZero) : L.toPoint h 0 = 0 :=
+  L.toPoint_of_mem h (zero_mem _)
+
+theorem toPoint_of_notMem (h : L.DiscriminantNeZero) {z : ℂ} (hz : z ∉ L.lattice) :
+    L.toPoint h z = .some _ _ ((WeierstrassCurve.Affine.equation_iff_nonsingular_of_Δ_ne_zero
+      h.weierstrassCurve_Δ_ne_zero).mp (L.equation_weierstrassP hz)) := by
+  simp [toPoint, hz]
+
+def IsUniformization (h : L.DiscriminantNeZero) : Prop :=
+  (∀ z w, L.toPoint h (z + w) = L.toPoint h z + L.toPoint h w) ∧
+    Function.Surjective (L.toPoint h) ∧
+      ∀ z, L.toPoint h z = 0 → z ∈ L.lattice
+
+def jLattice : ℂ := 1728 * L.g₂ ^ 3 / (L.g₂ ^ 3 - 27 * L.g₃ ^ 2)
+
+theorem jLattice_eq_c₄_pow_three_div_Δ :
+    L.jLattice = L.weierstrassCurve.c₄ ^ 3 / L.weierstrassCurve.Δ := by
+  rw [jLattice, weierstrassCurve_c₄, weierstrassCurve_Δ]
+  by_cases h : L.g₂ ^ 3 - 27 * L.g₃ ^ 2 = 0
+  · rw [h, div_zero, div_zero]
+  · rw [div_eq_div_iff h h]
+    ring
+
+def JSurjective : Prop :=
+  ∀ c : ℂ, ∃ L : PeriodPair, L.DiscriminantNeZero ∧ L.jLattice = c
+
+theorem linearIndependent_coe_upperHalfPlane_one (τ : ℍ) :
+    LinearIndependent ℝ ![(τ : ℂ), (1 : ℂ)] := by
+  rw [LinearIndependent.pair_iff]
+  intro a b h
+  have him : (a • (τ : ℂ) + b • (1 : ℂ)).im = 0 := by rw [h]; simp
+  simp only [Complex.add_im, Complex.smul_im, Complex.one_im, smul_zero, add_zero] at him
+  have ha : a = 0 := (mul_eq_zero.mp him).resolve_right (ne_of_gt τ.im_pos)
+  subst ha
+  simp only [zero_smul, zero_add, smul_eq_zero, one_ne_zero, or_false] at h
+  exact ⟨rfl, h⟩
+
+def ofTau (τ : ℍ) : PeriodPair where
+  ω₁ := (τ : ℂ)
+  ω₂ := 1
+  indep := linearIndependent_coe_upperHalfPlane_one τ
+
+@[simp] theorem ofTau_ω₁ (τ : ℍ) : (ofTau τ).ω₁ = (τ : ℂ) := rfl
+@[simp] theorem ofTau_ω₂ (τ : ℍ) : (ofTau τ).ω₂ = 1 := rfl
+
+@[simp] theorem ofTau_lattice (τ : ℍ) :
+    (ofTau τ).lattice = Submodule.span ℤ {(τ : ℂ), 1} := rfl
+
+section Scale
+
+variable (α : ℂˣ)
+
+theorem scale_indep : LinearIndependent ℝ ![(α : ℂ) * L.ω₁, (α : ℂ) * L.ω₂] := by
+  have h : ![(α : ℂ) * L.ω₁, (α : ℂ) * L.ω₂] = (LinearMap.mulLeft ℝ (α : ℂ)) ∘ ![L.ω₁, L.ω₂] := by
+    funext i; fin_cases i <;> simp
+  rw [h]
+  exact L.indep.map' (LinearMap.mulLeft ℝ (α : ℂ))
+    (LinearMap.ker_eq_bot_of_injective (mul_right_injective₀ α.ne_zero))
+
+def scale : PeriodPair where
+  ω₁ := (α : ℂ) * L.ω₁
+  ω₂ := (α : ℂ) * L.ω₂
+  indep := L.scale_indep α
+
+@[simp] theorem scale_ω₁ : (L.scale α).ω₁ = (α : ℂ) * L.ω₁ := rfl
+@[simp] theorem scale_ω₂ : (L.scale α).ω₂ = (α : ℂ) * L.ω₂ := rfl
+
+end Scale
+
+def sublatticeIndex (L L' : PeriodPair) : ℕ :=
+  (L'.lattice.toAddSubgroup.addSubgroupOf L.lattice.toAddSubgroup).index
+
+abbrev sublatticeQuotient (L L' : PeriodPair) :=
+  L.lattice.toAddSubgroup ⧸ L'.lattice.toAddSubgroup.addSubgroupOf L.lattice.toAddSubgroup
+
+end PeriodPair
+
+end DL_lapidification
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ProjectiveLineMatrixAction.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ProjectiveLineMatrixAction.lean
new file mode 100644
index 0000000000..19a7f9e6fa
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ProjectiveLineMatrixAction.lean
@@ -0,0 +1,253 @@
+/-
+Based on Prove2Me node ProjectiveLineMatrixAction
+(88222177-504e-5b2c-a7f2-67084424a306) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import Mathlib.RepresentationTheory.Basic
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ProjectiveLine
+
+/-!
+# Matrix action on the projective line modulo N
+
+Definition: `ProjectiveLineMatrixAction` (`88222177-504e-5b2c-a7f2-67084424a306`), by Claude,
+2026-09-05.
+
+Over a commutative ring $R$, a unimodular row is a pair $v=(v_1,v_2)\in R\times R$ together with a
+witness $x,y$ of $xv_1+yv_2=1$, and $\mathbb{P}^1(R)$ is the quotient of such rows by the relation
+'$w=uv$ for a unit $u$'. [`ModularCurve.ProjectiveLine.vecMulRow M
+hM`](../def/ProjectiveLineMatrixAction.html#L8) sends a unimodular row $v$ to
+$vM=(v_1M_{00}+v_2M_{10},\,v_1M_{01}+v_2M_{11})$ for a $2\times2$ matrix $M$ over $R$ with $\det M$
+a unit, the unimodularity of the image being produced from a left inverse of the determinant;
+`vecMulRow_fst`/`vecMulRow_snd` record its two coordinates. This descends to the right action
+[`ModularCurve.ProjectiveLine.vecMul M hM`](../def/ProjectiveLineMatrixAction.html#L27) on
+$\mathbb{P}^1(R)$, with `vecMul_one` ($v\cdot 1=v$) and `vecMul_mul` (the action of $MM'$ is the
+action of $M$ followed by that of $M'$).
+
+In the `HeckeEis` namespace, `redMat N M` is the entrywise reduction of an integer matrix modulo
+$N$, and `projLineAct N M` is the induced self-map of $\mathbb{P}^1(\mathbb{Z}/N)$: the above action
+of $\mathrm{red}_N M$ when its determinant is a unit, and the identity otherwise, so as to be total;
+`projLineAct_of_isUnit`, `isUnit_det_redMat_coe` (determinants of reductions of
+$\mathrm{SL}_2(\mathbb{Z})$-matrices are units), `projLineAct_one`, `projLineAct_mul` and
+`projLineAct_coe_mul` give the expected unit and composition identities. For a commutative ring $K$,
+`projLineRepSL N K` is the resulting permutation representation of $\mathrm{SL}_2(\mathbb{Z})$ on
+functions $\mathbb{P}^1(\mathbb{Z}/N)\to K$, $(g\cdot f)(P)=f(P\cdot g)$, and `projLineRep N K` its
+restriction along the inclusion of the subgroup $\Gamma_0(1)$; `projLineAlphaAdj N K` $\ell$ is
+precomposition with the action of $\mathrm{diag}(\ell,1)$, the adjugate of $\mathrm{diag}(1,\ell)$.
+Finally `projLineFixedCard N M` is the number of points of $\mathbb{P}^1(\mathbb{Z}/N)$ fixed by
+`projLineAct N M`; `projLineCuspSetoid N` is the equivalence relation generated by $P\mapsto
+P\cdot\begin{pmatrix}1&1\\0&1\end{pmatrix}$, with quotient `ProjLineCusps N` (finite for $N\neq0$),
+class map `projLineCuspMk`, and `fixedCuspCount N M` the number of classes $c$ such that every $P$
+in $c$ has $P\cdot M$ again in $c$.
+
+**Relation to Mathlib.** Mathlib's `Projectivization` is built for modules over division rings; the
+projective line over a commutative ring as a quotient of unimodular rows, and the matrix action on
+it defined here, are the project's own. The representations are Mathlib `Representation`s of
+Mathlib's `SL(2, ℤ)` and `CongruenceSubgroup.Gamma0 1`.
+
+**Where it is used.** Under the bottom-row dictionary between
+$\Gamma_0(N)\backslash\mathrm{SL}_2(\mathbb{Z})$ and $\mathbb{P}^1(\mathbb{Z}/N)$, these actions and
+the representation on $K$-valued functions on $\mathbb{P}^1(\mathbb{Z}/N)$ provide the coefficient
+module in which level-$N$ data is handled at level one, together with the combinatorics of cusps
+($\begin{pmatrix}1&1\\0&1\end{pmatrix}$-orbits) and fixed-point counts needed for Hecke operators.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace ModularCurve.ProjectiveLine
+
+variable {R : Type*} [CommRing R]
+
+def vecMulRow (M : Matrix (Fin 2) (Fin 2) R) (hM : IsUnit M.det) (v : UnimodularRow R) :
+    UnimodularRow R :=
+  ⟨(v.1.1 * M 0 0 + v.1.2 * M 1 0, v.1.1 * M 0 1 + v.1.2 * M 1 1), by
+    obtain ⟨x, y, h⟩ := v.2
+    obtain ⟨e, he⟩ := hM.exists_left_inv
+    rw [Matrix.det_fin_two] at he
+    exact ⟨e * (x * M 1 1 - y * M 0 1), e * (y * M 0 0 - x * M 1 0), by
+      linear_combination (x * v.1.1 + y * v.1.2) * he + h⟩⟩
+
+@[simp]
+theorem vecMulRow_fst (M : Matrix (Fin 2) (Fin 2) R) (hM : IsUnit M.det) (v : UnimodularRow R) :
+    (vecMulRow M hM v).1.1 = v.1.1 * M 0 0 + v.1.2 * M 1 0 :=
+  rfl
+
+@[simp]
+theorem vecMulRow_snd (M : Matrix (Fin 2) (Fin 2) R) (hM : IsUnit M.det) (v : UnimodularRow R) :
+    (vecMulRow M hM v).1.2 = v.1.1 * M 0 1 + v.1.2 * M 1 1 :=
+  rfl
+
+def vecMul (M : Matrix (Fin 2) (Fin 2) R) (hM : IsUnit M.det) :
+    ProjectiveLine R → ProjectiveLine R :=
+  Quotient.map (vecMulRow M hM) <| by
+    rintro v w ⟨u, h1, h2⟩
+    refine ⟨u, ?_, ?_⟩
+    · simp only [vecMulRow_fst]
+      linear_combination M 0 0 * h1 + M 1 0 * h2
+    · simp only [vecMulRow_snd]
+      linear_combination M 0 1 * h1 + M 1 1 * h2
+
+@[simp]
+theorem vecMul_mk (M : Matrix (Fin 2) (Fin 2) R) (hM : IsUnit M.det) (v : UnimodularRow R) :
+    vecMul M hM (⟦v⟧ : ProjectiveLine R) = ⟦vecMulRow M hM v⟧ :=
+  rfl
+
+theorem vecMul_one (h : IsUnit (1 : Matrix (Fin 2) (Fin 2) R).det) (P : ProjectiveLine R) :
+    vecMul 1 h P = P := by
+  induction P using Quotient.inductionOn with
+  | h v =>
+    rw [vecMul_mk]
+    congr 1
+    apply Subtype.ext
+    refine Prod.ext ?_ ?_ <;> simp
+
+theorem vecMul_mul (M M' : Matrix (Fin 2) (Fin 2) R) (hM : IsUnit M.det) (hM' : IsUnit M'.det)
+    (hMM' : IsUnit (M * M').det) (P : ProjectiveLine R) :
+    vecMul (M * M') hMM' P = vecMul M' hM' (vecMul M hM P) := by
+  induction P using Quotient.inductionOn with
+  | h v =>
+    simp only [vecMul_mk]
+    congr 1
+    apply Subtype.ext
+    refine Prod.ext ?_ ?_
+    · simp only [vecMulRow_fst, vecMulRow_snd, Matrix.mul_apply, Fin.sum_univ_two]
+      ring
+    · simp only [vecMulRow_fst, vecMulRow_snd, Matrix.mul_apply, Fin.sum_univ_two]
+      ring
+
+end ModularCurve.ProjectiveLine
+
+namespace HeckeEis
+
+open ModularCurve
+open scoped MatrixGroups
+
+abbrev redMat (N : ℕ) (M : Matrix (Fin 2) (Fin 2) ℤ) : Matrix (Fin 2) (Fin 2) (ZMod N) :=
+  M.map (Int.castRingHom (ZMod N))
+
+noncomputable def projLineAct (N : ℕ) (M : Matrix (Fin 2) (Fin 2) ℤ) :
+    ProjectiveLine (ZMod N) → ProjectiveLine (ZMod N) :=
+  open scoped Classical in
+  if h : IsUnit (redMat N M).det then ProjectiveLine.vecMul (redMat N M) h else id
+
+theorem projLineAct_of_isUnit (N : ℕ) (M : Matrix (Fin 2) (Fin 2) ℤ) (h : IsUnit (redMat N M).det) :
+    projLineAct N M = ProjectiveLine.vecMul (redMat N M) h := by
+  classical
+  rw [projLineAct, dite_eq_left h]
+
+theorem isUnit_det_redMat_coe (N : ℕ) (g : SL(2, ℤ)) :
+    IsUnit (redMat N (g : Matrix (Fin 2) (Fin 2) ℤ)).det := by
+  have : (redMat N (g : Matrix (Fin 2) (Fin 2) ℤ)).det = 1 := by
+    rw [redMat, ← RingHom.mapMatrix_apply, ← RingHom.map_det, g.det_coe, map_one]
+  rw [this]
+  exact isUnit_one
+
+@[simp]
+theorem projLineAct_one (N : ℕ) (P : ProjectiveLine (ZMod N)) : projLineAct N 1 P = P := by
+  have h1 : redMat N 1 = 1 := by simp [redMat]
+  have h : IsUnit (redMat N (1 : Matrix (Fin 2) (Fin 2) ℤ)).det :=
+    by rw [h1, Matrix.det_one]; exact isUnit_one
+  rw [projLineAct_of_isUnit N 1 h]
+  have h' : IsUnit (1 : Matrix (Fin 2) (Fin 2) (ZMod N)).det :=
+    by rw [Matrix.det_one]; exact isUnit_one
+  rw [show ProjectiveLine.vecMul (redMat N 1) h = ProjectiveLine.vecMul 1 h' from by congr 1]
+  exact ProjectiveLine.vecMul_one h' P
+
+theorem projLineAct_mul (N : ℕ) (M M' : Matrix (Fin 2) (Fin 2) ℤ)
+    (hM : IsUnit (redMat N M).det) (hM' : IsUnit (redMat N M').det) (P : ProjectiveLine (ZMod N)) :
+    projLineAct N (M * M') P = projLineAct N M' (projLineAct N M P) := by
+  have hmul : redMat N (M * M') = redMat N M * redMat N M' := by
+    rw [redMat, redMat, redMat, ← RingHom.mapMatrix_apply, ← RingHom.mapMatrix_apply,
+      ← RingHom.mapMatrix_apply, map_mul]
+  have hMM' : IsUnit (redMat N (M * M')).det := by
+    rw [hmul, Matrix.det_mul]
+    exact hM.mul hM'
+  rw [projLineAct_of_isUnit N _ hMM', projLineAct_of_isUnit N _ hM, projLineAct_of_isUnit N _ hM']
+  have hMM'2 : IsUnit (redMat N M * redMat N M').det := by rw [← hmul]; exact hMM'
+  rw [show ProjectiveLine.vecMul (redMat N (M * M')) hMM' = ProjectiveLine.vecMul _ hMM'2 from by
+    congr 1]
+  exact ProjectiveLine.vecMul_mul _ _ hM hM' hMM'2 P
+
+theorem projLineAct_coe_mul (N : ℕ) (g h : SL(2, ℤ)) (P : ProjectiveLine (ZMod N)) :
+    projLineAct N ((g * h : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) P
+      = projLineAct N (h : Matrix (Fin 2) (Fin 2) ℤ) (projLineAct N (g : Matrix (Fin 2) (Fin 2) ℤ)
+        P) := by
+  rw [Matrix.SpecialLinearGroup.coe_mul]
+  exact projLineAct_mul N _ _ (isUnit_det_redMat_coe N g) (isUnit_det_redMat_coe N h) P
+
+section Rep
+
+variable (N : ℕ) (K : Type*) [CommRing K]
+
+noncomputable def projLineRepSL : Representation K SL(2, ℤ) (ProjectiveLine (ZMod N) → K) where
+  toFun g := LinearMap.funLeft K K (projLineAct N (g : Matrix (Fin 2) (Fin 2) ℤ))
+  map_one' := by
+    apply LinearMap.ext
+    intro f
+    funext P
+    simp [LinearMap.funLeft_apply, projLineAct_one]
+  map_mul' g h := by
+    apply LinearMap.ext
+    intro f
+    funext P
+    simp only [LinearMap.funLeft_apply, Module.End.mul_apply, projLineAct_coe_mul]
+
+@[simp]
+theorem projLineRepSL_apply (g : SL(2, ℤ)) (f : ProjectiveLine (ZMod N) → K)
+    (P : ProjectiveLine (ZMod N)) :
+    projLineRepSL N K g f P = f (projLineAct N (g : Matrix (Fin 2) (Fin 2) ℤ) P) :=
+  rfl
+
+noncomputable def projLineRep :
+    Representation K (CongruenceSubgroup.Gamma0 1) (ProjectiveLine (ZMod N) → K) :=
+  (projLineRepSL N K).comp (CongruenceSubgroup.Gamma0 1).subtype
+
+@[simp]
+theorem projLineRep_apply (g : CongruenceSubgroup.Gamma0 1) (f : ProjectiveLine (ZMod N) → K)
+    (P : ProjectiveLine (ZMod N)) :
+    projLineRep N K g f P = f (projLineAct N ((g : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) P) :=
+  rfl
+
+noncomputable def projLineAlphaAdj (ℓ : ℕ) :
+    (ProjectiveLine (ZMod N) → K) →ₗ[K] (ProjectiveLine (ZMod N) → K) :=
+  LinearMap.funLeft K K (projLineAct N !![(ℓ : ℤ), 0; 0, 1])
+
+@[simp]
+theorem projLineAlphaAdj_apply (ℓ : ℕ) (f : ProjectiveLine (ZMod N) → K)
+    (P : ProjectiveLine (ZMod N)) :
+    projLineAlphaAdj N K ℓ f P = f (projLineAct N !![(ℓ : ℤ), 0; 0, 1] P) :=
+  rfl
+
+end Rep
+
+noncomputable def projLineFixedCard (N : ℕ) (M : Matrix (Fin 2) (Fin 2) ℤ) : ℕ :=
+  Nat.card {P : ProjectiveLine (ZMod N) // projLineAct N M P = P}
+
+def projLineCuspSetoid (N : ℕ) : Setoid (ProjectiveLine (ZMod N)) :=
+  Relation.EqvGen.setoid fun P Q => projLineAct N !![1, 1; 0, 1] P = Q
+
+def ProjLineCusps (N : ℕ) : Type _ :=
+  Quotient (projLineCuspSetoid N)
+
+def projLineCuspMk (N : ℕ) (P : ProjectiveLine (ZMod N)) : ProjLineCusps N :=
+  Quotient.mk (projLineCuspSetoid N) P
+
+instance instFiniteProjLineCusps (N : ℕ) [NeZero N] : Finite (ProjLineCusps N) :=
+  Quotient.finite _
+
+noncomputable def fixedCuspCount (N : ℕ) (M : Matrix (Fin 2) (Fin 2) ℤ) : ℕ :=
+  Nat.card {c : ProjLineCusps N //
+    ∀ P : ProjectiveLine (ZMod N), projLineCuspMk N P = c → projLineCuspMk N (projLineAct N M P) =
+      c}
+
+end HeckeEis
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_TaylorWiles_Primes.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_TaylorWiles_Primes.lean
new file mode 100644
index 0000000000..d1072d6128
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_TaylorWiles_Primes.lean
@@ -0,0 +1,165 @@
+/-
+Based on Prove2Me node TaylorWiles_Primes
+(c2ff5db8-f2a4-5d20-a6b7-48adc9eb9494) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.Frobenius
+public import Mathlib.NumberTheory.RamificationInertia.Galois
+public import Mathlib.RingTheory.Ideal.Quotient.HasFiniteQuotients.Basic
+public import Mathlib.RingTheory.Ideal.Quotient.HasFiniteQuotients.Norm
+public import Mathlib.LinearAlgebra.Matrix.Trace
+public import Mathlib.LinearAlgebra.Matrix.Determinant.Basic
+
+/-!
+# Taylor–Wiles primes, Frobenius density statement, seed data
+
+Definition: `TaylorWiles_Primes` (`c2ff5db8-f2a4-5d20-a6b7-48adc9eb9494`), by Claude, 2026-09-05.
+
+The module sets up the vocabulary for the auxiliary primes of the patching argument, over a number
+field $L$ that is finite Galois over $\mathbb{Q}$.
+
+For a $2\times 2$ matrix $M$ over a commutative ring $R$, [`Matrix.HasDistinctRationalEigenvalues
+M`](../def/TaylorWiles_Primes.html#L31) is defined purely in terms of the characteristic polynomial:
+there exist $\alpha,\beta\in R$ with $\alpha\neq\beta$, $\operatorname{tr}M=\alpha+\beta$ and $\det
+M=\alpha\beta$. Accompanying this are the $2\times2$ Cayley–Hamilton identity
+$M^2=(\operatorname{tr}M)M-(\det M)\cdot 1$, its consequence
+$M^{k+2}=(\operatorname{tr}M)M^{k+1}-(\det M)M^{k}$, and the resulting trace recursion
+$\operatorname{tr}(M^{k+2})=
+  \operatorname{tr}(M)\operatorname{tr}(M^{k+1})-\det(M)\operatorname{tr}(M^{k})$.
+
+In the `FrobeniusDensity` namespace, `ratPrimeIdeal ℓ` is the ideal $(\ell)\subseteq\mathbb{Z}$,
+with helper lemmas that it is nonzero and maximal for $\ell$ prime, that nonzero ideals of
+$\mathcal{O}_L$ have finite quotient, and that a prime of $\mathcal{O}_L$ lying over $(\ell)$ is
+nonzero. Then `RealizesCyclicAt L σ ℓ` asserts that $\ell$ is prime and that for every prime ideal
+$Q$ of $\mathcal{O}_L$ lying over $(\ell)$ — with the finiteness of the residue ring
+$\mathcal{O}_L/Q$ supplied as a further hypothesis binder, although the helper lemmas make it
+derivable — there is $k$ coprime to the order of $\sigma$ such that $\sigma^k$ is conjugate in
+$\mathrm{Gal}(L/\mathbb{Q})$ to the arithmetic Frobenius `arithFrobAt ℤ (L ≃ₐ[ℚ] L) Q`. `Statement`
+is the Frobenius-density assertion: for every $\sigma$ and every finite set $S$ of naturals there is
+$\ell\notin S$ with `RealizesCyclicAt L σ ℓ`.
+
+A `ResidualRep L 𝕜` is a monoid homomorphism $\mathrm{Gal}(L/\mathbb{Q})\to M_2(\mathbb{k})$ (values
+are automatically invertible, the source being a group). For such $\rho$ and naturals $p,n$,
+`IsTaylorWilesPrime ρ p n q` says: $q$ is prime, $q\equiv 1 \pmod{p^n}$, and for every prime $Q$
+over $(q)$ (again with a finiteness binder) the matrix $\rho(\mathrm{Frob}_Q)$ has distinct
+eigenvalues in $\mathbb{k}$ in the above sense. Finally `Seed ρ p n S` is a structure bundling an
+element $\sigma$, a proof that $\rho(\sigma)$ has distinct eigenvalues, and a proof that every
+$\ell\notin S$ realising a coprime power of $\sigma$ as Frobenius satisfies $\ell\equiv
+1\pmod{p^n}$; `SeedExists` is the nonemptiness of that structure.
+
+**Relation to Mathlib.** The Frobenius element is Mathlib's `arithFrobAt`, and the
+ramification/finite-quotient facts are Mathlib's; the eigenvalue predicate, the Taylor–Wiles prime
+predicate, the Frobenius-density statement and the seed structure are the project's own. The
+elementary $2\times2$ Cayley–Hamilton and trace-recursion lemmas are placed in the `Matrix`
+namespace.
+
+**Where it is used.** These predicates are the interface through which the patching argument obtains
+its auxiliary primes: one needs, for each depth $n$, primes $q\equiv 1\pmod{p^n}$ at which the
+residual representation has Frobenius with distinct eigenvalues, and the seed datum reduces their
+existence to a Frobenius-density statement, both Taylor–Wiles conditions being stable under passing
+to coprime powers of the seed element.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace Matrix
+
+variable {R : Type*} [CommRing R]
+
+theorem sq_eq_trace_smul_sub_det_smul_one (M : Matrix (Fin 2) (Fin 2) R) :
+    M ^ 2 = M.trace • M - M.det • (1 : Matrix (Fin 2) (Fin 2) R) := by
+  ext i j
+  simp only [pow_two, Matrix.mul_apply, Fin.sum_univ_two, Matrix.trace_fin_two,
+    Matrix.det_fin_two, Matrix.sub_apply, Matrix.smul_apply, Matrix.one_apply, smul_eq_mul]
+  fin_cases i <;> fin_cases j <;> simp <;> ring
+
+theorem pow_add_two_eq_trace_smul_sub_det_smul (M : Matrix (Fin 2) (Fin 2) R) (k : ℕ) :
+    M ^ (k + 2) = M.trace • M ^ (k + 1) - M.det • M ^ k := by
+  have h : M ^ (k + 2) = M ^ k * M ^ 2 := by rw [← pow_add]
+  rw [h, sq_eq_trace_smul_sub_det_smul_one, Matrix.mul_sub, mul_smul_comm, mul_smul_comm,
+    mul_one, ← pow_succ]
+
+theorem trace_pow_add_two (M : Matrix (Fin 2) (Fin 2) R) (k : ℕ) :
+    (M ^ (k + 2)).trace = M.trace * (M ^ (k + 1)).trace - M.det * (M ^ k).trace := by
+  rw [pow_add_two_eq_trace_smul_sub_det_smul, Matrix.trace_sub, Matrix.trace_smul,
+    Matrix.trace_smul, smul_eq_mul, smul_eq_mul]
+
+def HasDistinctRationalEigenvalues (M : Matrix (Fin 2) (Fin 2) R) : Prop :=
+  ∃ α β : R, α ≠ β ∧ M.trace = α + β ∧ M.det = α * β
+
+end Matrix
+
+namespace FrobeniusDensity
+
+open NumberField Ideal
+
+variable (L : Type*) [Field L] [NumberField L] [IsGalois ℚ L]
+
+abbrev ratPrimeIdeal (ℓ : ℕ) : Ideal ℤ := Ideal.span {(ℓ : ℤ)}
+
+theorem ratPrimeIdeal_ne_bot {ℓ : ℕ} (hℓ : ℓ.Prime) : ratPrimeIdeal ℓ ≠ ⊥ := by
+  rw [Ne, Ideal.span_singleton_eq_bot]
+  exact_mod_cast hℓ.ne_zero
+
+instance isMaximal_ratPrimeIdeal (ℓ : ℕ) [Fact ℓ.Prime] : (ratPrimeIdeal ℓ).IsMaximal :=
+  PrincipalIdealRing.isMaximal_of_irreducible
+    (Nat.prime_iff_prime_int.mp Fact.out).irreducible
+
+variable {L}
+
+omit [IsGalois ℚ L] in
+theorem finite_quotient_of_ne_bot {Q : Ideal (𝓞 L)} (hQ : Q ≠ ⊥) : Finite (𝓞 L ⧸ Q) :=
+  Ring.HasFiniteQuotients.finiteQuotient hQ
+
+omit [IsGalois ℚ L] in
+theorem ne_bot_of_liesOver_ratPrimeIdeal {ℓ : ℕ} (hℓ : ℓ.Prime) {Q : Ideal (𝓞 L)}
+    [Q.IsPrime] [Q.LiesOver (ratPrimeIdeal ℓ)] : Q ≠ ⊥ :=
+  Ideal.ne_bot_of_liesOver_of_ne_bot (ratPrimeIdeal_ne_bot hℓ) Q
+
+variable (L)
+
+def RealizesCyclicAt (σ : L ≃ₐ[ℚ] L) (ℓ : ℕ) : Prop :=
+  ∃ _ : ℓ.Prime, ∀ (Q : Ideal (𝓞 L)) (_ : Q.IsPrime) (_ : Q.LiesOver (ratPrimeIdeal ℓ))
+    (_ : Finite (𝓞 L ⧸ Q)),
+    ∃ k : ℕ, k.Coprime (orderOf σ) ∧ IsConj (σ ^ k) (arithFrobAt ℤ (L ≃ₐ[ℚ] L) Q)
+
+def Statement : Prop :=
+  ∀ (σ : L ≃ₐ[ℚ] L) (S : Finset ℕ), ∃ ℓ : ℕ, ℓ ∉ S ∧ RealizesCyclicAt L σ ℓ
+
+end FrobeniusDensity
+
+namespace TaylorWiles
+
+open NumberField Ideal FrobeniusDensity
+
+variable {L : Type*} [Field L] [NumberField L] [IsGalois ℚ L]
+variable {𝕜 : Type*} [Field 𝕜]
+
+variable (L) in
+abbrev ResidualRep (𝕜 : Type*) [Field 𝕜] := (L ≃ₐ[ℚ] L) →* Matrix (Fin 2) (Fin 2) 𝕜
+
+variable (ρ : ResidualRep L 𝕜) (p n : ℕ)
+
+def IsTaylorWilesPrime (q : ℕ) : Prop :=
+  q.Prime ∧ q ≡ 1 [MOD p ^ n] ∧
+    ∀ (Q : Ideal (𝓞 L)) (_ : Q.IsPrime) (_ : Q.LiesOver (ratPrimeIdeal q))
+      (_ : Finite (𝓞 L ⧸ Q)),
+      (ρ (arithFrobAt ℤ (L ≃ₐ[ℚ] L) Q)).HasDistinctRationalEigenvalues
+
+structure Seed (S : Finset ℕ) where
+  σ : L ≃ₐ[ℚ] L
+  regular : (ρ σ).HasDistinctRationalEigenvalues
+  congruent : ∀ ℓ : ℕ, ℓ ∉ S → RealizesCyclicAt L σ ℓ → ℓ ≡ 1 [MOD p ^ n]
+
+def SeedExists (S : Finset ℕ) : Prop := Nonempty (Seed ρ p n S)
+
+end TaylorWiles
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_ValuationSubring_ReduceAt.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_ValuationSubring_ReduceAt.lean
new file mode 100644
index 0000000000..b3024a99ca
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_ValuationSubring_ReduceAt.lean
@@ -0,0 +1,344 @@
+/-
+Based on Prove2Me node ValuationSubring_ReduceAt
+(b7b7698f-3b06-5e2c-b450-cbb382c3823b) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Algebra.ZMod
+public import Mathlib.FieldTheory.PurelyInseparable.Basic
+public import Mathlib.RingTheory.Flat.TorsionFree
+public import Mathlib.RingTheory.Henselian
+public import Mathlib.RingTheory.RegularLocalRing.Defs
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_ReductionMap
+
+/-!
+# Residue field as Fℓ​ and the reduction map reduceAt
+
+Definition: `ValuationSubring_ReduceAt` (`b7b7698f-3b06-5e2c-b450-cbb382c3823b`), by Claude,
+2026-09-05.
+
+Throughout, $L$ is a field and $A$ a valuation subring of $L$; `A.LiesOverPrime q` means that the
+image of $q$ in $L$ lies in `A.nonunits`, i.e. $q$ is a non-unit of $A$, so that by
+`charP_residueField_of_liesOverPrime_def` the residue field $\kappa(A) =$ `ResidueField A` has
+characteristic $q$. Two groups of facts precede the main construction. First, field-theoretic ones:
+if $L$ is algebraically closed then $\kappa(A)$ is algebraically closed (registered as an instance,
+proved by lifting a monic irreducible polynomial to $A[X]$, finding a root in $L$, and using that a
+valuation ring is integrally closed); under the same hypothesis, for $q$ prime with $A$ lying over
+$q$, the $q$-power map on $\kappa(A)$ is bijective; if moreover $L$ has characteristic zero and is
+algebraic over $\mathbb{Q}$, then every residue $\mathrm{res}_A(a)$, $a \in A$, is algebraic over
+$\mathbb{Z}/\ell$, whence $\kappa(A)$ is an algebraic closure of $\mathbb{Z}/\ell$
+(`isAlgClosure_residueField`). Second, integrality facts: for $\ell$ prime with $A$ lying over
+$\ell$ and $n \in \mathbb{Z}$ with $\ell \nmid n$, the image of $n$ in $A$ is a unit and its residue
+is non-zero; consequently $A$ lies over no prime $q \neq \ell$. A side lemma records that over a
+nontrivial ring of prime characteristic every element is algebraic over $\mathbb{Z}$, the witness
+being $\ell X$.
+
+From `isAlgClosure_residueField` one obtains a ring equivalence `residueFieldEquivAlgebraicClosure :
+ResidueField A ≃+* AlgebraicClosure (ZMod ℓ)`, chosen via the isomorphism of any two algebraic
+closures and therefore not canonical. The main definition `reduceAt A hA : L → AlgebraicClosure
+(ZMod ℓ)` sends $a \in A$ to the image of $\mathrm{res}_A(a)$ under this equivalence and sends $a
+\notin A$ to $0$. It is thus not a ring homomorphism: the accompanying lemmas give
+$\mathrm{reduceAt}(0)=0$, $\mathrm{reduceAt}(1)=1$, additivity and multiplicativity only for
+arguments in $A$, surjectivity, the vanishing criterion $\mathrm{reduceAt}(a)=0 \iff a$ lies in the
+maximal ideal of $A$ (for $a \in A$), compatibility with integer and natural-number casts,
+$\mathrm{reduceAt}(\ell)=0$, and non-vanishing on integers prime to $\ell$.
+
+**Relation to Mathlib.** Mathlib supplies `ValuationSubring`, `IsLocalRing.ResidueField`,
+`IsAlgClosure` and `AlgebraicClosure`; the predicate `LiesOverPrime` and the total reduction
+function `reduceAt` (defined to be $0$ off $A$) are the project's own, as is the instance that the
+residue field of a valuation subring of an algebraically closed field is algebraically closed.
+
+**Where it is used.** The function `reduceAt A hA` is the scalar-level reduction map at a place of
+$\overline{\mathbb{Q}}$ above $\ell$ used in the specialisation of moduli coordinates and of points
+of elliptic curves to the closed fibre, and hence in the comparison of inertia and Frobenius actions
+entering the study of the mod-$p$ representation attached to a Frey package.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open IsLocalRing Polynomial
+
+namespace ValuationSubring
+
+section ResidueAlgClosed
+
+variable {L : Type*} [Field L] (A : ValuationSubring L)
+
+instance instIsAlgClosedResidueField [IsAlgClosed L] :
+    IsAlgClosed (ResidueField A) := by
+  refine IsAlgClosed.of_exists_root _ (fun f hf_monic hf_irr => ?_)
+  have hf_lifts : f ∈ lifts (residue A) := by
+    rw [lifts_iff_coeff_lifts]
+    exact fun n => residue_surjective (f.coeff n)
+  obtain ⟨g, hg_map, -, hg_monic⟩ := lifts_and_degree_eq_and_monic hf_lifts hf_monic
+  have hgL_monic : (g.map (algebraMap A L)).Monic := hg_monic.map _
+  have hgL_deg : (g.map (algebraMap A L)).degree ≠ 0 := by
+    rw [hg_monic.degree_map]
+    intro h0
+    have hg_nat : g.natDegree = 0 := natDegree_eq_zero_iff_degree_le_zero.mpr (le_of_eq h0)
+    have hf_deg : f.natDegree = 0 := by
+      rw [← hg_map, hg_monic.natDegree_map]
+      exact hg_nat
+    have hf1 : f = 1 := (hf_monic.natDegree_eq_zero).mp hf_deg
+    exact hf_irr.not_isUnit (by rw [hf1]; exact isUnit_one)
+  obtain ⟨α, hα⟩ := IsAlgClosed.exists_root _ hgL_deg
+  have hα_int : IsIntegral A α := by
+    refine ⟨g, hg_monic, ?_⟩
+    rwa [IsRoot.def, eval_map] at hα
+  obtain ⟨a, ha⟩ := IsIntegrallyClosed.isIntegral_iff.mp hα_int
+  refine ⟨residue A a, ?_⟩
+  have hga : g.eval a = 0 := by
+    have : algebraMap A L (g.eval a) = 0 := by
+      have hcomm : algebraMap A L (g.eval a) = (g.map (algebraMap A L)).eval α := by
+        rw [← ha, eval_map, eval₂_hom]
+      rw [hcomm]
+      exact hα
+    exact (map_eq_zero_iff _ Subtype.coe_injective).mp this
+  have : f.eval (residue A a) = residue A (g.eval a) := by
+    rw [← hg_map, eval_map, eval₂_hom]
+  rw [this, hga, map_zero]
+
+variable {A}
+
+theorem pow_residueChar_bijective [IsAlgClosed L] {q : ℕ} (hq : q.Prime)
+    (hA : A.LiesOverPrime q) :
+    Function.Bijective (fun x : ResidueField A => x ^ q) := by
+  have : CharP (ResidueField A) q := charP_residueField_of_liesOverPrime_def hq hA
+  have : Fact q.Prime := ⟨hq⟩
+  constructor
+  · intro x y hxy
+    have hxy' : x ^ q = y ^ q := hxy
+    have hsub : (x - y) ^ q = 0 := by
+      rw [sub_pow_char, hxy', sub_self]
+    have := pow_eq_zero_iff hq.ne_zero |>.mp hsub
+    exact sub_eq_zero.mp this
+  · intro x
+    obtain ⟨y, hy⟩ := IsAlgClosed.exists_pow_nat_eq x hq.pos
+    exact ⟨y, hy⟩
+
+end ResidueAlgClosed
+
+variable {L : Type*} [Field L]
+
+section IntegerUnits
+
+variable {A : ValuationSubring L} {ℓ : ℕ}
+
+theorem intCast_isUnit_of_not_dvd (hℓ : ℓ.Prime) (hA : A.LiesOverPrime ℓ) {n : ℤ}
+    (hn : ¬(ℓ : ℤ) ∣ n) : IsUnit ((n : ℤ) : A) := by
+  by_contra hunit
+  have hnmem : ((n : ℤ) : A) ∈ maximalIdeal A := by
+    rw [IsLocalRing.mem_maximalIdeal]
+    exact hunit
+  have hℓmem : ((ℓ : ℕ) : A) ∈ maximalIdeal A := natCast_mem_maximalIdeal_of_liesOverPrime hA
+  obtain ⟨u, v, huv⟩ := (Nat.prime_iff_prime_int.mp hℓ).coprime_iff_not_dvd.mpr hn
+  have h1 : (1 : A) ∈ maximalIdeal A := by
+    have h := congrArg (fun z : ℤ => ((z : ℤ) : A)) huv
+    simp only [Int.cast_add, Int.cast_mul, Int.cast_one, Int.cast_natCast] at h
+    rw [← h]
+    exact Ideal.add_mem _ (Ideal.mul_mem_left _ _ hℓmem) (Ideal.mul_mem_left _ _ hnmem)
+  exact (maximalIdeal.isMaximal A).ne_top ((Ideal.eq_top_iff_one _).mpr h1)
+
+theorem residue_intCast_ne_zero (hℓ : ℓ.Prime) (hA : A.LiesOverPrime ℓ) {n : ℤ}
+    (hn : ¬(ℓ : ℤ) ∣ n) : residue A ((n : ℤ) : A) ≠ 0 :=
+  (residue_ne_zero_iff_isUnit _).mpr (intCast_isUnit_of_not_dvd hℓ hA hn)
+
+theorem gate_not_liesOverPrime_of_ne (hℓ : ℓ.Prime) (hA : A.LiesOverPrime ℓ) {q : ℕ}
+    (hq : q.Prime) (hne : q ≠ ℓ) : ¬A.LiesOverPrime q := by
+  intro hq'
+  have hqmem : ((q : ℕ) : A) ∈ maximalIdeal A := natCast_mem_maximalIdeal_of_liesOverPrime hq'
+  have hqdvd : ¬(ℓ : ℤ) ∣ (q : ℤ) := by
+    intro h
+    rcases (Nat.prime_dvd_prime_iff_eq hℓ hq).mp (Int.natCast_dvd_natCast.mp h) with rfl
+    exact hne rfl
+  have := intCast_isUnit_of_not_dvd hℓ hA hqdvd
+  rw [IsLocalRing.mem_maximalIdeal] at hqmem
+  exact hqmem (by exact_mod_cast this)
+
+end IntegerUnits
+
+section Algebraicity
+
+variable (A : ValuationSubring L) {ℓ : ℕ}
+
+theorem isAlgebraic_residue [CharZero L] [Algebra ℚ L]
+    [Algebra.IsAlgebraic ℚ L] (hℓ : ℓ.Prime)
+    [Algebra (ZMod ℓ) (ResidueField A)] (a : A) :
+    IsAlgebraic (ZMod ℓ) (residue A a) := by
+  obtain ⟨p, hp0, hpa⟩ := Algebra.IsAlgebraic.isAlgebraic (R := ℚ) (a : L)
+  set P₀ : ℤ[X] := IsLocalization.integerNormalization (nonZeroDivisors ℤ) p with hP₀def
+  have hP₀a : aeval (a : L) P₀ = 0 :=
+    IsLocalization.integerNormalization_aeval_eq_zero (nonZeroDivisors ℤ) p hpa
+  have hP₀0 : P₀ ≠ 0 := fun h =>
+    hp0 ((IsLocalization.integerNormalization_eq_zero_iff le_rfl p).mp h)
+  set P : ℤ[X] := P₀.primPart with hPdef
+  have hPa : aeval (a : L) P = 0 := aeval_primPart_eq_zero hP₀0 hP₀a
+  have hPprim : P.IsPrimitive := P₀.isPrimitive_primPart
+  have hP0 : P ≠ 0 := P₀.primPart_ne_zero
+  have hcoeff : ∃ i, ¬(ℓ : ℤ) ∣ P.coeff i := by
+    by_contra h
+    simp only [not_exists, not_not] at h
+    have hu : IsUnit ((ℓ : ℤ)) := hPprim _ ((C_dvd_iff_dvd_coeff _ _).mpr h)
+    rw [Int.isUnit_iff] at hu
+    have h2 := hℓ.two_le
+    omega
+  have hPaA : aeval a P = 0 := by
+    have hmap : algebraMap A L (aeval a P) = 0 := by
+      rw [← Polynomial.aeval_algebraMap_apply]
+      exact hPa
+    exact (map_eq_zero_iff _ Subtype.coe_injective).mp hmap
+  have hPres : aeval (residue A a) P = 0 := by
+    have hcomm : aeval (residue A a) P = (residue A) (aeval a P) :=
+      Polynomial.aeval_algHom_apply (RingHom.toIntAlgHom (residue A)) a P
+    rw [hcomm, hPaA, map_zero]
+  refine ⟨P.map (algebraMap ℤ (ZMod ℓ)), ?_, ?_⟩
+  · obtain ⟨i, hi⟩ := hcoeff
+    intro h0
+    apply hi
+    have hzero : (P.map (algebraMap ℤ (ZMod ℓ))).coeff i = 0 := by rw [h0]; simp
+    rw [coeff_map] at hzero
+    exact (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp hzero
+  · rw [aeval_def, eval₂_map,
+      show (algebraMap (ZMod ℓ) (ResidueField A)).comp (algebraMap ℤ (ZMod ℓ))
+          = algebraMap ℤ (ResidueField A) from RingHom.ext_int _ _,
+      ← aeval_def]
+    exact hPres
+
+theorem gate_isAlgebraic_int_vacuous_of_charP {R : Type*} [CommRing R] [Nontrivial R]
+    {ℓ : ℕ} (hℓ : ℓ.Prime) [CharP R ℓ] (x : R) : IsAlgebraic ℤ x := by
+  refine ⟨C (ℓ : ℤ) * X, ?_, ?_⟩
+  · intro h
+    have hc := congrArg (fun q : ℤ[X] => q.coeff 1) h
+    simp only [coeff_C_mul, coeff_X_one, mul_one, coeff_zero] at hc
+    have h2 := hℓ.two_le
+    omega
+  · simp
+
+end Algebraicity
+
+section Identification
+
+variable (A : ValuationSubring L) {ℓ : ℕ}
+
+theorem isAlgClosure_residueField [IsAlgClosed L] [CharZero L] [Algebra ℚ L]
+    [Algebra.IsAlgebraic ℚ L] [Fact ℓ.Prime]
+    [Algebra (ZMod ℓ) (ResidueField A)] :
+    IsAlgClosure (ZMod ℓ) (ResidueField A) := by
+  refine ⟨inferInstance, ⟨fun x => ?_⟩⟩
+  obtain ⟨a, rfl⟩ := residue_surjective (R := A) x
+  exact isAlgebraic_residue A Fact.out a
+
+noncomputable def residueFieldEquivAlgebraicClosure [IsAlgClosed L] [CharZero L] [Algebra ℚ L]
+    [Algebra.IsAlgebraic ℚ L] [Fact ℓ.Prime] (hA : A.LiesOverPrime ℓ) :
+    ResidueField A ≃+* AlgebraicClosure (ZMod ℓ) := by
+  haveI hchar : CharP (ResidueField A) ℓ := charP_residueField_of_liesOverPrime_def Fact.out hA
+  letI halg : Algebra (ZMod ℓ) (ResidueField A) := ZMod.algebra (ResidueField A) ℓ
+  haveI htf : Module.IsTorsionFree (ZMod ℓ) (ResidueField A) := by
+    refine Module.IsTorsionFree.of_smul_eq_zero (fun r m h => ?_)
+    rw [Algebra.smul_def] at h
+    rcases mul_eq_zero.mp h with h' | h'
+    · exact Or.inl ((map_eq_zero_iff _ (algebraMap (ZMod ℓ) (ResidueField A)).injective).mp h')
+    · exact Or.inr h'
+  haveI hcl : IsAlgClosure (ZMod ℓ) (ResidueField A) := isAlgClosure_residueField A
+  exact (IsAlgClosure.equiv (ZMod ℓ) (ResidueField A) (AlgebraicClosure (ZMod ℓ))).toRingEquiv
+
+end Identification
+
+section ReduceAt
+
+variable {ℓ : ℕ} [Fact ℓ.Prime]
+variable (A : ValuationSubring L) [IsAlgClosed L] [CharZero L] [Algebra ℚ L]
+  [Algebra.IsAlgebraic ℚ L]
+variable (hA : A.LiesOverPrime ℓ)
+
+open Classical in
+noncomputable def reduceAt (a : L) : AlgebraicClosure (ZMod ℓ) :=
+  if h : a ∈ A then residueFieldEquivAlgebraicClosure A hA (residue A ⟨a, h⟩) else 0
+
+variable {A hA}
+
+theorem reduceAt_of_mem {a : L} (h : a ∈ A) :
+    reduceAt A hA a = residueFieldEquivAlgebraicClosure A hA (residue A ⟨a, h⟩) :=
+  dite_eq_left h
+
+theorem reduceAt_of_notMem {a : L} (h : a ∉ A) : reduceAt A hA a = 0 :=
+  dite_eq_right h
+
+@[simp]
+theorem reduceAt_coe (a : A) :
+    reduceAt A hA (a : L) = residueFieldEquivAlgebraicClosure A hA (residue A a) :=
+  reduceAt_of_mem a.2
+
+@[simp]
+theorem reduceAt_zero : reduceAt A hA (0 : L) = 0 := by
+  have h := reduceAt_coe (A := A) (hA := hA) (0 : A)
+  simpa using h
+
+@[simp]
+theorem reduceAt_one : reduceAt A hA (1 : L) = 1 := by
+  have h := reduceAt_coe (A := A) (hA := hA) (1 : A)
+  simpa using h
+
+theorem reduceAt_add {a b : L} (ha : a ∈ A) (hb : b ∈ A) :
+    reduceAt A hA (a + b) = reduceAt A hA a + reduceAt A hA b := by
+  rw [reduceAt_of_mem ha, reduceAt_of_mem hb, reduceAt_of_mem (A.add_mem _ _ ha hb),
+    show (⟨a + b, A.add_mem _ _ ha hb⟩ : A) = ⟨a, ha⟩ + ⟨b, hb⟩ from rfl, map_add, map_add]
+
+theorem reduceAt_mul {a b : L} (ha : a ∈ A) (hb : b ∈ A) :
+    reduceAt A hA (a * b) = reduceAt A hA a * reduceAt A hA b := by
+  rw [reduceAt_of_mem ha, reduceAt_of_mem hb, reduceAt_of_mem (A.mul_mem _ _ ha hb),
+    show (⟨a * b, A.mul_mem _ _ ha hb⟩ : A) = ⟨a, ha⟩ * ⟨b, hb⟩ from rfl, map_mul, map_mul]
+
+theorem reduceAt_surjective : Function.Surjective (reduceAt A hA) := by
+  intro y
+  obtain ⟨a, ha⟩ :=
+    residue_surjective (R := A) ((residueFieldEquivAlgebraicClosure A hA).symm y)
+  exact ⟨(a : L), by rw [reduceAt_coe, ha, RingEquiv.apply_symm_apply]⟩
+
+theorem reduceAt_eq_zero_iff_of_mem {a : L} (h : a ∈ A) :
+    reduceAt A hA a = 0 ↔ (⟨a, h⟩ : A) ∈ maximalIdeal A := by
+  rw [reduceAt_of_mem h,
+    map_eq_zero_iff _ (residueFieldEquivAlgebraicClosure A hA).injective]
+  exact residue_eq_zero_iff _
+
+@[simp]
+theorem reduceAt_intCast (n : ℤ) :
+    reduceAt A hA ((n : ℤ) : L) = ((n : ℤ) : AlgebraicClosure (ZMod ℓ)) := by
+  have hmem : ((n : ℤ) : L) = (((n : ℤ) : A) : L) := by norm_cast
+  rw [hmem, reduceAt_coe, map_intCast (residue A) n]
+  exact map_intCast (residueFieldEquivAlgebraicClosure A hA) n
+
+@[simp]
+theorem reduceAt_natCast (n : ℕ) :
+    reduceAt A hA ((n : ℕ) : L) = ((n : ℕ) : AlgebraicClosure (ZMod ℓ)) := by
+  have h := reduceAt_intCast (A := A) (hA := hA) (n : ℤ)
+  push_cast at h
+  exact h
+
+theorem reduceAt_residueChar : reduceAt A hA ((ℓ : ℕ) : L) = 0 := by
+  rw [reduceAt_natCast]
+  exact CharP.cast_eq_zero (AlgebraicClosure (ZMod ℓ)) ℓ
+
+theorem reduceAt_intCast_ne_zero {n : ℤ} (hn : ¬(ℓ : ℤ) ∣ n) :
+    reduceAt A hA ((n : ℤ) : L) ≠ 0 := by
+  rw [reduceAt_intCast]
+  intro h
+  apply hn
+  rw [show ((n : ℤ) : AlgebraicClosure (ZMod ℓ))
+      = algebraMap (ZMod ℓ) (AlgebraicClosure (ZMod ℓ)) ((n : ℤ) : ZMod ℓ) from
+    (map_intCast _ n).symm] at h
+  exact (ZMod.intCast_zmod_eq_zero_iff_dvd n ℓ).mp
+    ((map_eq_zero_iff _ (algebraMap (ZMod ℓ) (AlgebraicClosure (ZMod ℓ))).injective).mp h)
+
+end ReduceAt
+
+end ValuationSubring
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_EDSEngine.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_EDSEngine.lean
new file mode 100644
index 0000000000..8b2894fe72
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_EDSEngine.lean
@@ -0,0 +1,1897 @@
+/-
+Based on Prove2Me node WeierstrassCurve_EDSEngine
+(5fd20a59-e5e9-5133-a421-34f512baf1be) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.EllipticDivisibilitySequence
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Compat_Mathlib430
+public import Mathlib.Algebra.Ring.NegOnePow
+public import Mathlib.Data.Fin.VecNotation
+public import Mathlib.Data.Fin.Tuple.Sort
+public import Mathlib.Algebra.GroupWithZero.NonZeroDivisors
+public import Mathlib.Algebra.MvPolynomial.CommRing
+public import Mathlib.Algebra.MvPolynomial.Basic
+public import Mathlib.Tactic.LinearCombination
+public import Mathlib.Tactic.Ring
+public import Mathlib.Tactic.Abel
+public import Mathlib.Tactic.IntervalCases
+public import Mathlib.Tactic.FieldSimp
+public import Mathlib.GroupTheory.Perm.Basic
+public import Mathlib.GroupTheory.Perm.Sign
+public import Mathlib.GroupTheory.Perm.Cycle.Type
+public import Mathlib.Algebra.Polynomial.Bivariate
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Jacobian.Point
+public import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+public import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+public import Mathlib.FieldTheory.Separable
+public import Mathlib.Data.Nat.Factorization.Induction
+public import Mathlib.Logic.Embedding.Set
+public import Mathlib.SetTheory.Cardinal.Finite
+public import Mathlib.Data.Set.Card
+public import Mathlib.Algebra.Module.Torsion.Basic
+
+/-!
+# Elliptic divisibility sequences, universal Weierstrass curve, division polynomial ω
+
+Definition: `WeierstrassCurve_EDSEngine` (`5fd20a59-e5e9-5133-a421-34f512baf1be`), by Claude,
+2026-09-05.
+
+Four layers are set up here. (1) Sequence identities. For $W:\mathbb{Z}\to R$ over a commutative
+ring, [`EllSequence.addMulSub W m n`](../def/WeierstrassCurve_EDSEngine.html#L57) $=
+W((m+n)\,\mathrm{tdiv}\,2)\cdot W((m-n)\,\mathrm{tdiv}\,2)$, and `rel₄`, `rel₆`, `relFin4`, `net`
+are the associated quadratic and quartic expressions, `net W p q r s` $=
+W(p+q+s)W(p-q)W(r+s)W(r)-W(p+r+s)W(p-r)W(q+s)W(q)+W(q+r+s)W(q-r)W(p+s)W(p)$; `Rel₃ W m n r` is the
+three‑term elliptic relation at $(m,n,r)$, so that
+[`IsEllSequence'`](../def/Compat_Mathlib430.html#L237) is exactly $\forall m,n,r$, `Rel₃`.
+`OddRec`/`EvenRec` are the doubling recursions $W(2m+1)W(1)^3=W(m+2)W(m)^3-W(m-1)W(m+1)^3$ and
+$W(2m)W(2)W(1)^2=W(m)(W(m-1)^2W(m+2)-W(m-2)W(m+1)^2)$; `invarNum`, `invarDenom` form the quotient
+shown to be independent of $n$. The combinatorial predicates `HaveSameParity₄`, `StrictAnti₄` ($0\le
+d<c<b<a$), `avg₄`, `dMin`, `cMin`, `Rel₄OfValid` organise the descent from the two recursions to the
+full relation. (2) Complementary sequences:
+[`compl₂EDSAux`](../def/WeierstrassCurve_EDSEngine.html#L566) and
+[`compl₂EDS`](../def/WeierstrassCurve_EDSEngine.html#L580) built from `preNormEDS (b^4) c d`, with
+$\mathrm{normEDS}\cdot\mathrm{compl₂EDS}=\mathrm{normEDS}(2m)$; the recursion `compl'`, its odd
+extension `compl`, and `complEDS b c d m n` with
+$\mathrm{normEDS}(m)\cdot\mathrm{complEDS}(m,n)=\mathrm{normEDS}(nm)$; `redInvarNum`,
+`redInvarDenom` (the latter by cases on $m \bmod 6$) satisfy
+$\mathrm{redInvarNum}=\mathrm{redInvarDenom}\cdot(d+b^4)$. Universality is obtained from
+[`Param`](../def/WeierstrassCurve_EDSEngine.html#L694), [`universalNormEDS = normEDS (X B) (X C) (X
+D)`](../def/WeierstrassCurve_EDSEngine.html#L698), and the specialisation $(b,c,d)=(2,3,2)$ at which
+`normEDS` is the identity. (3) The universal curve: `Coeff`, `Univ.curve` over
+$\mathbb{Z}[A_1,A_2,A_3,A_4,A_6]$, its bivariate polynomial ring `Poly`, coordinate ring
+`Univ.Ring`, fraction field `Univ.Field`, the map `polyToField`, the generic affine and Jacobian
+points, the cusp $y^2=x^3$ with its point $(1,1)$, and the evaluation maps `specialize`, `polyEval`,
+`ringEval`. (4) Division polynomials: `invar` $=6X^2+b_2X+b_4$, `ψc` with
+$\psi_n\psi^c_n=\psi_{2n}$, and `ωe` $n$, characterised by
+$2\omega_n+a_1\phi_n\psi_n+a_3\psi_n^3=\psi^c_n$, with $\omega_0=1$, $\omega_1=Y$; then `smulX`,
+`smulY`, `slopeOne` give $\phi_n/\psi_n^2$, $\omega_n/\psi_n^3$ over `Univ.Field`.
+
+**Relation to Mathlib.** Mathlib supplies `normEDS`, `preNormEDS` and the division polynomials
+$\psi_n$, $\phi_n$, $\Psi_3$, $\mathrm{pre}\Psi_4$;
+[`compl₂EDS`](../def/WeierstrassCurve_EDSEngine.html#L580) agrees with Mathlib's `complEDS₂`. The
+predicates [`IsEllSequence'`](../def/Compat_Mathlib430.html#L237),
+[`IsDivSequence'`](../def/Compat_Mathlib430.html#L241),
+[`IsEllDivSequence'`](../def/Compat_Mathlib430.html#L244) are the renamed copies of earlier Mathlib
+predicates kept in the project's compatibility module. The complementary sequence `complEDS`, the
+polynomial `ωe`, the universal Weierstrass curve with its coordinate ring and function field, and
+the specialisation homomorphisms have no Mathlib counterpart here.
+
+**Where it is used.** The formulas assembled here express multiplication by $n$ on a Weierstrass
+curve through $\phi_n$, $\omega_n$ and $\psi_n$, first for the generic point of the universal curve
+and then, by specialisation, over an arbitrary base. They serve the treatment of torsion points of
+elliptic curves needed for the Galois representations attached to the Frey curve.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace WeierstrassCurve.Affine
+
+scoped notation3:max W' "⟮" S "⟯" =>
+  WeierstrassCurve.Affine.Point (WeierstrassCurve.Affine.baseChange W' S)
+
+end WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+
+instance instIsEllipticBaseChange {R : Type*} {A : Type*} [CommRing R] [CommRing A]
+    [Algebra R A] (W : WeierstrassCurve R) [W.IsElliptic] : (W.baseChange A).IsElliptic :=
+  inferInstanceAs <| (W.map (algebraMap R A)).IsElliptic
+
+end WeierstrassCurve
+
+section PortEllSequenceCore
+
+universe u v w
+
+variable {R : Type u} {S : Type v} [CommRing R] [CommRing S] (W : ℤ → R)
+variable {F} [FunLike F R S] [RingHomClass F R S] (f : F)
+
+open scoped nonZeroDivisors
+
+namespace EllSequence
+
+def addMulSub (m n : ℤ) : R := W ((m + n).tdiv 2) * W ((m - n).tdiv 2)
+
+def rel₄ (a b c d : ℤ) : R :=
+  addMulSub W a b * addMulSub W c d
+    - addMulSub W a c * addMulSub W b d + addMulSub W a d * addMulSub W b c
+
+def net (p q r s : ℤ) : R :=
+  W (p + q + s) * W (p - q) * W (r + s) * W r
+    - W (p + r + s) * W (p - r) * W (q + s) * W q
+    + W (q + r + s) * W (q - r) * W (p + s) * W p
+
+variable {W} in
+lemma net_eq_rel₄ {p q r s : ℤ} :
+    net W p q r s = rel₄ W (2 * p + s) (2 * q + s) (2 * r + s) s := by
+  simp_rw [net, rel₄, addMulSub, add_add_add_comm _ s, add_sub_add_comm, sub_self, add_zero,
+    add_assoc, ← two_mul, add_sub_cancel_right, ← left_distrib, ← mul_sub_left_distrib,
+    Int.mul_tdiv_cancel_left _ two_ne_zero]
+  ring
+
+def Rel₃ (m n r : ℤ) : Prop :=
+  W (m + n) * W (m - n) * W r ^ 2 =
+    W (m + r) * W (m - r) * W n ^ 2 - W (n + r) * W (n - r) * W m ^ 2
+
+lemma _root_.isEllSequence_iff_rel₃ : IsEllSequence' W ↔ ∀ m n r : ℤ, Rel₃ W m n r :=
+  Iff.rfl
+
+def invarNum (s n : ℤ) : R :=
+  (W (n + 2 * s) * W (n - s) ^ 2 + W (n + s) ^ 2 * W (n - 2 * s)) * W s ^ 2
+    + W n ^ 3 * W (2 * s) ^ 2
+
+def invarDenom (s n : ℤ) : R := W (n + s) * W n * W (n - s)
+
+theorem invar_of_net (net_eq_zero : ∀ p q r s, net W p q r s = 0) (s m n : ℤ) :
+    invarNum W s m * invarDenom W s n = invarNum W s n * invarDenom W s m := by
+  simp_rw [invarNum, invarDenom]
+  linear_combination (norm := (simp_rw [net]; ring_nf))
+    net_eq_zero m n s 0 * W m * W n * W (2 * s) ^ 2
+      - (net_eq_zero m n s s * W (m - s) * W (n - s)
+        + net_eq_zero (m - s) (n - s) s s * W (m + s) * W (n + s)
+        - net_eq_zero (n + s) n (n - s) (m - n) * W (m - n) * W (2 * s)) * W s ^ 2
+
+lemma net_add_sub_iff (m n : ℤ) :
+    net W (m + n) m (m - n) n = 0 ↔
+      W (2 * (m + n)) * W (m - n) * W m * W n =
+        (W (2 * m + n) * W (2 * n) * W m - W (m + 2 * n) * W (2 * m) * W n) * W (m + n) := by
+  rw [net]; conv_rhs => rw [← sub_eq_zero]
+  ring_nf
+
+lemma addMulSub_two_zero : addMulSub W 2 0 = W 1 ^ 2 := (sq _).symm
+lemma addMulSub_three_one : addMulSub W 3 1 = W 2 * W 1 := rfl
+
+lemma addMulSub_even (m n : ℤ) : addMulSub W (2 * m) (2 * n) = W (m + n) * W (m - n) := by
+  simp_rw [addMulSub, ← left_distrib, ← mul_sub_left_distrib,
+    Int.mul_tdiv_cancel_left _ two_ne_zero]
+
+lemma addMulSub_odd (m n : ℤ) :
+    addMulSub W (2 * m + 1) (2 * n + 1) = W (m + n + 1) * W (m - n) := by
+  have h k := Int.mul_tdiv_cancel_left k two_ne_zero
+  rw [addMulSub, ← h (m + n + 1), ← h (m - n)]; congr <;> ring
+
+lemma addMulSub_same (zero : W 0 = 0) (m : ℤ) : addMulSub W m m = 0 := by
+  rw [addMulSub, sub_self, Int.zero_tdiv, zero, mul_zero]
+
+lemma addMulSub_neg₀ (neg : ∀ k, W (-k) = -W k) (m n : ℤ) :
+    addMulSub W (-m) n = addMulSub W m n := by
+  simp_rw [addMulSub, ← neg_add', neg_add_eq_sub, ← neg_sub m, Int.neg_tdiv, neg]; ring
+
+lemma addMulSub_neg₁ (m n : ℤ) : addMulSub W m (-n) = addMulSub W m n := by
+  rw [addMulSub, addMulSub, mul_comm]; abel_nf
+
+lemma addMulSub_abs₀ (neg : ∀ k, W (-k) = -W k) (m n : ℤ) :
+    addMulSub W |m| n = addMulSub W m n := by
+  obtain h | h := abs_choice m <;> simp only [h, addMulSub_neg₀ W neg]
+
+lemma addMulSub_abs₁ (m n : ℤ) : addMulSub W m |n| = addMulSub W m n := by
+  obtain h | h := abs_choice n <;> simp only [h, addMulSub_neg₁]
+
+lemma addMulSub_swap (neg : ∀ k, W (-k) = -W k) (m n : ℤ) :
+    addMulSub W m n = - addMulSub W n m := by
+  rw [addMulSub, addMulSub, ← neg_sub, Int.neg_tdiv, neg]; ring_nf
+
+section transf
+
+variable (a b c d : ℤ)
+
+def StrictAnti₄ : Prop := 0 ≤ d ∧ d < c ∧ c < b ∧ b < a
+
+def HaveSameParity₄ : Prop :=
+  a.negOnePow = b.negOnePow ∧ b.negOnePow = c.negOnePow ∧ c.negOnePow = d.negOnePow
+
+def avg₄ : ℤ := (a + b + c + d) / 2
+
+namespace HaveSameParity₄
+open Int Equiv
+
+variable {W a b c d} (same : HaveSameParity₄ a b c d)
+
+include same in
+lemma rel₄_eq_net : rel₄ W a b c d = net W ((a - d) / 2) ((b - d) / 2) ((c - d) / 2) d := by
+  have h := @Int.two_mul_ediv_two_of_even
+  rw [net_eq_rel₄, h, h, h]; · simp_rw [sub_add_cancel]
+  all_goals simp only [← negOnePow_eq_iff, same.1, same.2.1, same.2.2]
+
+include same in
+lemma even_sum : Even (a + b + c + d) := by
+  simp_rw [← negOnePow_eq_one_iff, negOnePow_add,
+    same.1, same.2.1, same.2.2, units_mul_self, one_mul, units_mul_self]
+
+include same in
+lemma avg₄_add_avg₄ : avg₄ a b c d + avg₄ a b c d = a + b + c + d := by
+  rw [← two_mul]; exact Int.mul_ediv_cancel' same.even_sum.two_dvd
+
+include same in
+lemma same₀₃ : a.negOnePow = d.negOnePow := by rw [same.1, same.2.1, same.2.2]
+
+include same in
+protected lemma abs : HaveSameParity₄ |a| |b| |c| |d| := by
+  simpa only [HaveSameParity₄, negOnePow_abs] using same
+
+lemma perm (σ : Perm (Fin 4)) :
+    ∀ t : Fin 4 → ℤ, HaveSameParity₄ (t 0) (t 1) (t 2) (t 3) →
+      HaveSameParity₄ (t (σ 0)) (t (σ 1)) (t (σ 2)) (t (σ 3)) := by
+  have := (Perm.mclosure_swap_castSucc_succ 3).symm ▸ Submonoid.mem_top σ
+  refine Submonoid.closure_induction ?_ (fun _ ↦ id) (fun σ τ _ _ hσ hτ t same ↦ ?_) this
+  on_goal 2 => simp_rw [Perm.mul_apply]; exact hτ (t ∘ σ) (hσ _ same)
+  rintro _ ⟨i, rfl⟩ t ⟨h₀₁, h₁₂, h₂₃⟩; fin_cases i
+  exacts [⟨h₀₁.symm, h₀₁ ▸ h₁₂, h₂₃⟩, ⟨h₀₁ ▸ h₁₂, h₁₂.symm, h₁₂ ▸ h₂₃⟩, ⟨h₀₁, h₁₂ ▸ h₂₃, h₂₃.symm⟩]
+include same in
+lemma six_le_of_strictAnti₄ (anti : StrictAnti₄ a b c d) : 6 ≤ a := by
+  simp_rw [HaveSameParity₄, negOnePow_eq_iff] at same
+  obtain ⟨hd, hdc, hcb, hba⟩ := anti
+  rw [← add_two_le_iff_lt_of_even_sub] at hdc hcb hba
+  · linarith
+  exacts [same.1, same.2.1, same.2.2]
+
+variable (W) in
+def addMulSub₄ (a b c d : ℤ) : R := W ((a + b).tdiv 2) * W ((c - d).tdiv 2)
+
+lemma addMulSub₄_mul_addMulSub₄ :
+    addMulSub₄ W a b c d * addMulSub₄ W c d a b = addMulSub W a b * addMulSub W c d := by
+  simp_rw [addMulSub₄, addMulSub]; ring
+
+include same in
+lemma addMulSub_transf :
+    addMulSub W (avg₄ a b c d - d) (avg₄ a b c d - c) = addMulSub₄ W a b c d ∧
+      addMulSub W (avg₄ a b c d - d) (avg₄ a b c d - b) = addMulSub₄ W a c b d ∧
+      addMulSub W (avg₄ a b c d - d) |avg₄ a b c d - a| = addMulSub₄ W b c a d ∧
+      addMulSub W (avg₄ a b c d - c) (avg₄ a b c d - b) = addMulSub₄ W a d b c ∧
+      addMulSub W (avg₄ a b c d - c) |avg₄ a b c d - a| = addMulSub₄ W b d a c ∧
+      addMulSub W (avg₄ a b c d - b) |avg₄ a b c d - a| = addMulSub₄ W c d a b := by
+  simp_rw [addMulSub_abs₁, addMulSub, addMulSub₄, sub_add_sub_comm, same.avg₄_add_avg₄]
+  refine ⟨?_, ?_, ?_, ?_, ?_, ?_⟩ <;> ring_nf
+
+include same in
+theorem rel₄_transf :
+    rel₄ W (avg₄ a b c d - d) (avg₄ a b c d - c) (avg₄ a b c d - b) |avg₄ a b c d - a| =
+      rel₄ W a b c d := by
+  obtain ⟨h₁, h₂, h₃, h₄, h₅, h₆⟩ := same.addMulSub_transf (W := W)
+  simp_rw [rel₄, h₁, h₂, h₃, h₄, h₅, h₆, addMulSub₄_mul_addMulSub₄, mul_comm]
+
+include same in
+theorem transf : HaveSameParity₄
+    (avg₄ a b c d - d) (avg₄ a b c d - c) (avg₄ a b c d - b) |avg₄ a b c d - a| := by
+  simp_rw [HaveSameParity₄, negOnePow_abs, negOnePow_sub, same.1, same.2.1, same.2.2, true_and]
+
+include same in
+theorem strictAnti₄_transf (anti : StrictAnti₄ a b c d) :
+    StrictAnti₄ (avg₄ a b c d - d) (avg₄ a b c d - c) (avg₄ a b c d - b) |avg₄ a b c d - a| := by
+  obtain ⟨hd, hdc, hcb, hba⟩ := anti
+  refine ⟨abs_nonneg _, abs_lt.mpr ⟨?_, ?_⟩, ?_, ?_⟩ <;> rw [← sub_pos]
+  · rw [sub_neg_eq_add, sub_add_sub_comm, same.avg₄_add_avg₄]; linarith only [hd, hdc]
+  all_goals linarith only [hdc, hcb, hba]
+
+end HaveSameParity₄
+
+end transf
+
+def rel₆ (k l a b c d : ℤ) : R := addMulSub W k l * rel₄ W a b c d
+
+lemma rel₃_iff₄ (m n r : ℤ) :
+    Rel₃ W m n r ↔ rel₄ W (2 * m) (2 * n) (2 * r) 0 = 0 := by
+  rw [rel₄, ← mul_zero 2, Rel₃]
+  simp_rw [addMulSub_even, add_zero, sub_zero]
+  convert sub_eq_zero.symm using 2; ring
+
+lemma rel₆_eq₃ (c d m n r : ℤ) :
+    rel₆ W c d m n r c = rel₆ W m c n r c d - rel₆ W n c m r c d + rel₆ W r c m n c d := by
+  simp_rw [rel₆, rel₄]; ring
+
+lemma rel₆_eq₃' (c d m n r : ℤ) :
+    rel₆ W c d m n r d = rel₆ W m d n r c d - rel₆ W n d m r c d + rel₆ W r d m n c d := by
+  simp_rw [rel₆, rel₄]; ring
+
+theorem rel₆_eq₁₀ (c d m n r s : ℤ) :
+    rel₆ W c d m n r s =
+      rel₆ W n d m r s c - rel₆ W r d m n s c + rel₆ W s d m n r c
+      + rel₆ W n c m r s d - rel₆ W r c m n s d + rel₆ W s c m n r d
+      + rel₆ W n r m s c d - rel₆ W n s m r c d + rel₆ W r s m n c d
+      - 2 * rel₆ W m d n r s c := by
+  simp_rw [rel₆, rel₄]; ring
+
+theorem addMulSub_sq_mul_rel₄_eq₉ (c d m n r s : ℤ) :
+    (addMulSub W c d) ^ 2 * rel₄ W m n r s =
+      addMulSub W m c * (rel₆ W n d r s c d - rel₆ W r d n s c d + rel₆ W s d n r c d)
+      - addMulSub W m d * (rel₆ W n c r s c d - rel₆ W r c n s c d + rel₆ W s c n r c d)
+      + addMulSub W c d * (rel₆ W n r m s c d - rel₆ W n s m r c d + rel₆ W r s m n c d) := by
+  simp_rw [rel₆, rel₄]; ring
+
+def OddRec (m : ℤ) : Prop :=
+  W (2 * m + 1) * W 1 ^ 3 = W (m + 2) * W m ^ 3 - W (m - 1) * W (m + 1) ^ 3
+
+def EvenRec (m : ℤ) : Prop :=
+  W (2 * m) * W 2 * W 1 ^ 2 = W m * (W (m - 1) ^ 2 * W (m + 2) - W (m - 2) * W (m + 1) ^ 2)
+
+lemma rel₃_iff_oddRec (m : ℤ) : Rel₃ W (m + 1) m 1 ↔ OddRec W m := by
+  rw [Rel₃, OddRec]; ring_nf
+
+lemma rel₃_iff_evenRec (m : ℤ) : Rel₃ W (m + 1) (m - 1) 1 ↔ EvenRec W m := by
+  rw [Rel₃, EvenRec]; ring_nf
+
+lemma rel₄_iff_evenRec (m : ℤ) : rel₄ W (2 * m + 1) (2 * m - 1) 3 1 = 0 ↔ EvenRec W m := by
+  rw [iff_comm, EvenRec, ← sub_eq_zero, show 2 * m - 1 = 2 * (m - 1) + 1 by ring]
+  change _ ↔ rel₄ W (2 * m + 1) (2 * (m - 1) + 1) (2 * 1 + 1) (2 * 0 + 1) = 0
+  simp_rw [rel₄, addMulSub_odd]; ring_nf
+
+def dMin (a : ℤ) : ℤ := if Even a then 0 else 1
+
+def cMin (a : ℤ) : ℤ := dMin a + 2
+
+lemma dMin_nonneg (a : ℤ) : 0 ≤ dMin a := by rw [dMin]; split_ifs <;> decide
+
+lemma dMin_lt_cMin (a : ℤ) : dMin a < cMin a := lt_add_of_pos_right _ zero_lt_two
+
+lemma negOnePow_cMin_eq_dMin (a : ℤ) : (cMin a).negOnePow = (dMin a).negOnePow := by
+  rw [cMin, Int.negOnePow_add]; exact mul_one _
+
+lemma negOnePow_dMin (a : ℤ) : (dMin a).negOnePow = a.negOnePow := by
+  rw [dMin]; split_ifs with h
+  · simp [Int.negOnePow_even a h]
+  · simp [Int.negOnePow_odd a (Int.not_even_iff_odd.mp h)]
+lemma negOnePow_cMin (a : ℤ) : (cMin a).negOnePow = a.negOnePow := by
+  rw [negOnePow_cMin_eq_dMin, negOnePow_dMin]
+
+variable {W}
+lemma addMulSub_mem_nonZeroDivisors (one : W 1 ∈ R⁰) (two : W 2 ∈ R⁰) (a : ℤ) :
+    addMulSub W (cMin a) (dMin a) ∈ R⁰ := by
+  rw [cMin, dMin]; split_ifs; exacts [mul_mem one one, mul_mem two one]
+
+lemma dMin_le {a b : ℤ} (same : a.negOnePow = b.negOnePow) (h : 0 ≤ b) : dMin a ≤ b := by
+  rw [dMin]; split_ifs with odd
+  exacts [h, h.lt_of_ne (by rintro rfl; exact odd (a.negOnePow_eq_one_iff.mp same))]
+
+open Int
+
+section Rel₄OfValid
+
+variable (W) in
+def Rel₄OfValid (a b c d : ℤ) : Prop :=
+  HaveSameParity₄ a b c d → StrictAnti₄ a b c d → rel₄ W a b c d = 0
+
+variable {a c₀ d₀ : ℤ} (par : c₀.negOnePow = d₀.negOnePow) (le : 0 ≤ d₀) (lt : d₀ < c₀)
+  (rel : ∀ {a' b}, a' ≤ a → Rel₄OfValid W a' b c₀ d₀) (mem : addMulSub W c₀ d₀ ∈ R⁰)
+
+include par le lt rel mem in
+lemma rel₄_fix₁_of_fix₂ (b c : ℤ) :
+    Rel₄OfValid W a b c c₀ ∧ (c₀ < c → Rel₄OfValid W a b c d₀) := by
+  refine ⟨fun same anti ↦ (mem_nonZeroDivisors_iff.mp mem).2 _ ?_,
+    fun _hc same anti ↦ (mem_nonZeroDivisors_iff.mp mem).2 _ ?_⟩ <;> rw [mul_comm, ← rel₆]
+  on_goal 1 => rw [rel₆_eq₃]; have _hc := trivial
+  on_goal 2 => rw [rel₆_eq₃']
+  all_goals simp_rw [rel₆]; rw [rel le_rfl, rel le_rfl, rel anti.2.2.2.le]
+  iterate 2
+    simp_rw [mul_zero, add_zero, sub_zero]
+    iterate 3
+      simp only [HaveSameParity₄, par, same.1, same.2.1, same.2.2, true_and]
+      refine ⟨le, lt, ?_, ?_⟩ <;> linarith only [_hc, anti.2.1, anti.2.2.1, anti.2.2.2]
+include par le lt rel mem in
+lemma rel₄_of_fix₂ (b c d : ℤ) (hc : c₀ < d) (par' : d.negOnePow = d₀.negOnePow) :
+    Rel₄OfValid W a b c d := fun same ⟨_, hdc, hcb, hba⟩ ↦
+      (mem_nonZeroDivisors_iff.mp mem).2 _ <| by
+  rw [mul_comm, ← rel₆, rel₆_eq₁₀]; simp_rw [rel₆]
+  have fix₁ b c := (rel₄_fix₁_of_fix₂ par le lt rel mem b c).1
+  have fix₂ {b c} := (rel₄_fix₁_of_fix₂ par le lt rel mem b c).2
+  rw [fix₁, fix₁, fix₁, fix₂ hc, fix₂ hc, fix₂ (hc.trans hdc), rel le_rfl, rel le_rfl,
+    rel le_rfl, (rel₄_fix₁_of_fix₂ par le lt (fun h ↦ rel <| h.trans hba.le) mem _ _).1]
+  · simp_rw [mul_zero, add_zero, sub_zero]
+  iterate 10
+    simp only [HaveSameParity₄, par, par', same.1, same.2.1, same.2.2, true_and]
+    refine ⟨?_, ?_, ?_, ?_⟩ <;> linarith only [hc, le, lt, hdc, hcb, hba]
+
+theorem rel₄_of_min₂ (one : W 1 ∈ R⁰) (two : W 2 ∈ R⁰)
+    (rel : ∀ {a' b}, a' ≤ a → Rel₄OfValid W a' b (cMin a) (dMin a)) (b c d : ℤ) :
+    Rel₄OfValid W a b c d := fun same anti ↦ by
+  obtain hc|hc := lt_or_ge (cMin a) d
+  · refine rel₄_of_fix₂ (negOnePow_cMin_eq_dMin a) (dMin_nonneg a) (dMin_lt_cMin a) rel
+      (addMulSub_mem_nonZeroDivisors one two a) _ _ _ hc ?_ same anti
+    rw [negOnePow_dMin, same.1, same.2.1, same.2.2]
+  have fix := rel₄_fix₁_of_fix₂ (negOnePow_cMin_eq_dMin a) (dMin_nonneg a) (dMin_lt_cMin a) rel
+    (addMulSub_mem_nonZeroDivisors one two a) b c
+  obtain rfl|hc := (show d ≤ cMin a from hc).eq_or_lt
+  · exact fix.1 same anti
+  obtain rfl : dMin a = d := (dMin_le same.same₀₃ anti.1).antisymm <| by
+    rwa [← add_two_le_iff_lt_of_even_sub, cMin, add_le_add_iff_right] at hc
+    rw [← negOnePow_eq_iff, negOnePow_cMin, same.same₀₃]
+  obtain rfl|hc : cMin a = c ∨ _ := ((add_two_le_iff_lt_of_even_sub <| by
+    rw [← negOnePow_eq_iff, negOnePow_dMin, same.1, same.2.1]).mpr anti.2.1).eq_or_lt
+  exacts [rel le_rfl same anti, fix.2 hc same anti]
+theorem rel₄_of_anti_oddRec_evenRec (one : W 1 ∈ R⁰) (two : W 2 ∈ R⁰)
+    (oddRec : ∀ m ≥ 2, OddRec W m) (evenRec : ∀ m ≥ 3, EvenRec W m) :
+    ∀ ⦃a b c d : ℤ⦄, Rel₄OfValid W a b c d :=
+  Int.strongRec (m := 6)
+    (fun a ha b c d same anti ↦
+      absurd (ha.trans_le (same.six_le_of_strictAnti₄ anti)) (lt_irrefl a))
+    fun a h6 ih ↦ rel₄_of_min₂ one two fun {a' b} haa same anti ↦ by
+  obtain ha'|ha' := haa.lt_or_eq
+  · exact ih _ ha' same anti
+  obtain hba|rfl := lt_or_eq_of_le <| show b + 2 ≤ a' from
+    (add_two_le_iff_lt_of_even_sub <| (negOnePow_eq_iff _ _).1 same.1).mpr anti.2.2.2
+  · rw [← same.rel₄_transf]
+    refine ih _ ?_ same.transf (same.strictAnti₄_transf anti)
+    rw [avg₄, sub_lt_iff_lt_add, Int.ediv_lt_iff_lt_mul zero_lt_two, ← ha', cMin]
+    linarith only [hba]
+  obtain ⟨m, rfl|rfl⟩ := b.even_or_odd'
+  · have ea : Even a := by rw [← ha']; exact (even_two_mul _).add even_two
+    simp_rw [cMin, dMin, ite_eq_left ea]
+    have hm : m ≥ 2 := by linarith only [h6, ha']
+    convert (rel₃_iff₄ W (m + 1) m 1).mp ((rel₃_iff_oddRec W m).mpr <| oddRec _ hm) using 2
+    all_goals ring
+  · have nea : ¬ Even a := by
+      rw [← ha', Int.not_even_iff_odd]; convert odd_two_mul_add_one (m + 1) using 1; ring
+    simp_rw [cMin, dMin, ite_eq_right nea]
+    have hm : m + 1 ≥ 3 := by linarith only [h6, ha']
+    convert (rel₄_iff_evenRec W (m + 1)).mpr (evenRec _ hm) using 2
+    all_goals ring
+end Rel₄OfValid
+
+section Perm
+
+variable (neg : ∀ k, W (-k) = -W k)
+
+include neg in
+lemma rel₄_abs {m n r s : ℤ} : rel₄ W |m| |n| |r| |s| = rel₄ W m n r s := by
+  simp_rw [rel₄, addMulSub_abs₀ W neg, addMulSub_abs₁]
+
+include neg in
+lemma rel₄_swap₀₁ {m n r s : ℤ} : rel₄ W m n r s = - rel₄ W n m r s := by
+  simp_rw [rel₄, addMulSub_swap W neg n m]; ring
+
+include neg in
+lemma rel₄_swap₁₂ {m n r s : ℤ} : rel₄ W m n r s = - rel₄ W m r n s := by
+  simp_rw [rel₄, addMulSub_swap W neg r n]; ring
+
+include neg in
+lemma rel₄_swap₂₃ {m n r s : ℤ} : rel₄ W m n r s = - rel₄ W m n s r := by
+  simp_rw [rel₄, addMulSub_swap W neg s r]; ring
+
+open Equiv
+
+variable (W) in
+def relFin4 (t : Fin 4 → ℤ) : R := rel₄ W (t 0) (t 1) (t 2) (t 3)
+
+include neg in
+theorem relFin4_perm (σ : Perm (Fin 4)) : ∀ t, relFin4 W (t ∘ σ) = Perm.sign σ • relFin4 W t := by
+  have := (Perm.mclosure_swap_castSucc_succ 3).symm ▸ Submonoid.mem_top σ
+  refine Submonoid.closure_induction ?_ (by simp) (fun σ τ _ _ hσ hτ t ↦ ?_) this
+  · rintro _ ⟨i, rfl⟩ t; fin_cases i <;>
+      rw [Perm.sign_swap (Fin.castSucc_lt_succ).ne, Units.neg_smul, one_smul]
+    exacts [rel₄_swap₀₁ neg, rel₄_swap₁₂ neg, rel₄_swap₂₃ neg]
+  rw [Perm.coe_mul, ← Function.comp_assoc, hτ, hσ, map_mul, mul_comm, mul_smul]
+include neg in
+lemma relFin4_perm' (σ : Perm (Fin 4)) (t) : Perm.sign σ • relFin4 W (t ∘ σ) = relFin4 W t := by
+  rw [relFin4_perm neg, ← mul_smul, Int.units_mul_self, one_smul]
+variable (zero : W 0 = 0)
+
+include zero in
+lemma rel₄_same₀₁ (m r s : ℤ) : rel₄ W m m r s = 0 := by
+  simp_rw [rel₄, addMulSub_same W zero]; ring
+
+include zero in
+lemma rel₄_same₁₂ (m n s : ℤ) : rel₄ W m n n s = 0 := by
+  simp_rw [rel₄, addMulSub_same W zero]; ring
+
+include zero in
+lemma rel₄_same₂₃ (m n r : ℤ) : rel₄ W m n r r = 0 := by
+  simp_rw [rel₄, addMulSub_same W zero]; ring
+
+variable (one : W 1 ∈ R⁰) (two : W 2 ∈ R⁰)
+  (oddRec : ∀ m ≥ 2, OddRec W m) (evenRec : ∀ m ≥ 3, EvenRec W m)
+
+include neg zero one two oddRec evenRec in
+theorem rel₄_of_oddRec_evenRec {a b c d : ℤ} (same : HaveSameParity₄ a b c d) :
+    rel₄ W a b c d = 0 := by
+  let t := ![|a|, |b|, |c|, |d|]
+  have nonneg i : 0 ≤ t i := by fin_cases i <;> exact abs_nonneg _
+  let σ := Fin.revPerm.trans (Tuple.sort t)
+  have anti : Antitone (t ∘ σ) := by
+    simp_rw [σ, coe_trans, ← Function.comp_assoc]
+    exact (Tuple.monotone_sort t).comp_antitone fun _ _ ↦ Fin.rev_le_rev.mpr
+  clear_value σ
+  rw [← rel₄_abs neg]; change relFin4 W t = 0
+  rw [← relFin4_perm' neg σ, relFin4]; simp_rw [Function.comp]
+  by_cases h₃₂ : t (σ 3) = t (σ 2); · rw [h₃₂, rel₄_same₂₃ zero, smul_zero]
+  by_cases h₂₁ : t (σ 2) = t (σ 1); · rw [h₂₁, rel₄_same₁₂ zero, smul_zero]
+  by_cases h₁₀ : t (σ 1) = t (σ 0); · rw [h₁₀, rel₄_same₀₁ zero, smul_zero]
+  rw [rel₄_of_anti_oddRec_evenRec one two oddRec evenRec (same.abs.perm _ _), smul_zero]
+  exact ⟨nonneg _, (anti <| by decide).lt_of_ne h₃₂,
+    (anti <| by decide).lt_of_ne h₂₁, (anti <| by decide).lt_of_ne h₁₀⟩
+include neg zero one two oddRec evenRec in
+theorem _root_.IsEllSequence'.of_oddRec_evenRec : IsEllSequence' W := by
+  rw [isEllSequence_iff_rel₃]
+  intro m n r
+  rw [rel₃_iff₄, rel₄_of_oddRec_evenRec neg zero one two oddRec evenRec]
+  refine ⟨?_, ?_, ?_⟩ <;> simp only [negOnePow_two_mul, negOnePow_zero]
+end Perm
+
+end EllSequence
+
+open EllSequence
+
+variable {W}
+
+lemma IsEllSequence'.map (h : IsEllSequence' W) : IsEllSequence' (f ∘ W) :=
+  fun m n r => by simpa using congr_arg f (h m n r)
+
+lemma IsDivSequence'.map (h : IsDivSequence' W) : IsDivSequence' (f ∘ W) :=
+  (map_dvd f <| h · · ·)
+
+lemma IsEllDivSequence'.map (h : IsEllDivSequence' W) : IsEllDivSequence' (f ∘ W) :=
+  ⟨h.1.map f, h.2.map f⟩
+
+namespace IsEllSequence'
+
+open EllSequence
+
+variable (ell : IsEllSequence' W)
+
+include ell in
+lemma oddRec (m : ℤ) : OddRec W m := (rel₃_iff_oddRec W m).mp (ell _ _ _)
+include ell in
+lemma evenRec (m : ℤ) : EvenRec W m := (rel₃_iff_evenRec W m).mp (ell _ _ _)
+
+include ell in
+lemma zero' [IsReduced R] : W 0 = 0 := by
+  have := ell 0 0 0
+  simp_rw [add_zero, sub_self, mul_assoc, ← pow_succ'] at this
+  exact IsReduced.eq_zero _ ⟨_, this⟩
+include ell in
+lemma zero (m : ℤ) (mem : W (2 * m) ∈ R⁰) : W 0 = 0 := by
+  have := ell m m (2 * m)
+  rw [add_comm, sub_self, sub_self, ← two_mul, mul_comm (W _)] at this
+  exact (mem_nonZeroDivisors_iff.mp mem).2 _
+    ((mem_nonZeroDivisors_iff.mp (pow_mem mem 2)).2 _ this)
+include ell in
+lemma sub_add_neg_sub_mul_eq_zero (m n r : ℤ) :
+    (W (m - n) + W (-(m - n))) * W (m + n) * W r ^ 2 = 0 := by
+  have := congr($(ell m n r) + $(ell n m r))
+  rw [add_comm n, ← right_distrib, ← left_distrib, mul_comm (W _)] at this
+  convert this using 4 <;> ring_nf
+
+variable (one : W 1 ∈ R⁰) (two : W 2 ∈ R⁰)
+
+include ell one two in
+lemma neg (m : ℤ) : W (-m) = - W m := by
+  rw [eq_neg_iff_add_eq_zero]
+  obtain ⟨m, rfl|rfl⟩ := m.even_or_odd'
+  on_goal 1 => apply (mem_nonZeroDivisors_iff.mp two).2
+  on_goal 2 => apply (mem_nonZeroDivisors_iff.mp one).2
+  all_goals apply (mem_nonZeroDivisors_iff.mp (pow_mem one 2)).2
+  · convert sub_add_neg_sub_mul_eq_zero ell (1 - m) (m + 1) 1 using 2; ring_nf
+  · convert sub_add_neg_sub_mul_eq_zero ell (-m) (m + 1) 1 using 2; ring_nf
+include ell one two in
+protected lemma rel₄ {a b c d : ℤ} (same : HaveSameParity₄ a b c d) : rel₄ W a b c d = 0 :=
+  rel₄_of_oddRec_evenRec (ell.neg one two) (ell.zero 1 two) one two
+    (fun _ _ ↦ ell.oddRec _) (fun _ _ ↦ ell.evenRec _) same
+include ell one two in
+protected lemma net (p q r s : ℤ) : net W p q r s = 0 := by
+  rw [net_eq_rel₄]
+  refine ell.rel₄ one two ?_
+  simp_rw [HaveSameParity₄, Int.negOnePow_add, Int.negOnePow_two_mul, one_mul, true_and]
+include ell in
+include one two in
+lemma invar (s m n : ℤ) : invarNum W s m * invarDenom W s n = invarNum W s n * invarDenom W s m :=
+  invar_of_net _ (ell.net one two) _ _ _
+end IsEllSequence'
+
+variable (b c d : R)
+
+lemma invarNum_normEDS (n : ℤ) : letI W := normEDS b c d
+    invarNum W 1 n = W (n + 2) * W (n - 1) ^ 2 + W (n + 1) ^ 2 * W (n - 2) + W n ^ 3 * b ^ 2 := by
+  simp [invarNum]
+lemma invarNum_normEDS_two : invarNum (normEDS b c d) 1 2 = (d + b ^ 4) * b := by
+  simp [invarNum, right_distrib, ← pow_succ, ← pow_add]
+lemma invarDenom_normEDS_two : invarDenom (normEDS b c d) 1 2 = c * b := by simp [invarDenom]
+
+section Complement
+
+variable (b c d : R) (m : ℤ)
+
+def compl₂EDSAux : R :=
+  preNormEDS (b ^ 4) c d (m - 2) * preNormEDS (b ^ 4) c d (m + 1) ^ 2 * if Even m then 1 else b
+
+@[simp] lemma compl₂EDSAux_zero : compl₂EDSAux b c d 0 = -1 := by simp [compl₂EDSAux]
+@[simp] lemma compl₂EDSAux_one : compl₂EDSAux b c d 1 = -b := by simp [compl₂EDSAux]
+@[simp] lemma compl₂EDSAux_neg_one : compl₂EDSAux b c d (-1) = 0 := by simp [compl₂EDSAux]
+@[simp] lemma compl₂EDSAux_two : compl₂EDSAux b c d 2 = 0 := by simp [compl₂EDSAux]
+@[simp] lemma compl₂EDSAux_neg_two : compl₂EDSAux b c d (-2) = -d := by simp [compl₂EDSAux]
+
+lemma compl₂EDSAux_mul_b :
+    compl₂EDSAux b c d m * b = normEDS b c d (m - 2) * normEDS b c d (m + 1) ^ 2 := by
+  simp_rw [compl₂EDSAux, normEDS, Int.even_add, Int.even_sub, Int.not_even_one, even_two,
+    iff_false, iff_true]; split_ifs <;> ring
+
+def compl₂EDS : R :=
+  letI p := preNormEDS (b ^ 4) c d
+  (p (m - 1) ^ 2 * p (m + 2) - p (m - 2) * p (m + 1) ^ 2) * if Even m then 1 else b
+
+lemma compl₂EDSAux_neg : compl₂EDSAux b c d (-m) = -compl₂EDS b c d m - compl₂EDSAux b c d m := by
+  simp_rw [compl₂EDSAux, compl₂EDS, neg_sub_left, neg_add_eq_sub, ← neg_sub m,
+    preNormEDS_neg, even_neg]; ring_nf
+
+@[simp] lemma compl₂EDS_zero : compl₂EDS b c d 0 = 2 := by simp [compl₂EDS, one_add_one_eq_two]
+@[simp] lemma compl₂EDS_one : compl₂EDS b c d 1 = b := by simp [compl₂EDS]
+@[simp] lemma compl₂EDS_two : compl₂EDS b c d 2 = d := by simp [compl₂EDS]
+
+@[simp] lemma compl₂EDS_neg : compl₂EDS b c d (-m) = compl₂EDS b c d m := by
+  simp_rw [compl₂EDS, neg_sub_left, neg_add_eq_sub, ← neg_sub m, preNormEDS_neg, even_neg]; ring_nf
+
+lemma normEDS_mul_compl₂EDS :
+    normEDS b c d m * compl₂EDS b c d m = normEDS b c d (2 * m) := by
+  rw [show compl₂EDS b c d m = complEDS₂ b c d m from rfl]
+  exact normEDS_mul_complEDS₂ b c d m
+
+lemma normEDS_dvd_two_mul : normEDS b c d m ∣ normEDS b c d (2 * m) :=
+  ⟨_, (normEDS_mul_compl₂EDS b c d m).symm⟩
+
+lemma compl₂EDS_mul_b : letI W := normEDS b c d
+    compl₂EDS b c d m * b = W (m - 1) ^ 2 * W (m + 2) - W (m - 2) * W (m + 1) ^ 2 := by
+  rw [show compl₂EDS b c d m = complEDS₂ b c d m from rfl]
+  exact complEDS₂_mul_b b c d m
+
+lemma normEDS_six_eq_mul : normEDS b c d 6 = (normEDS b c d 5 - d ^ 2) * b * c := by
+  rw [show (6 : ℤ) = 2 * 3 by rfl, ← normEDS_mul_compl₂EDS, compl₂EDS, ite_eq_right (by decide)]
+  simp_rw [Int.reduceAdd, Int.reduceSub, normEDS_three, normEDS]
+  rw [preNormEDS_one, preNormEDS_two, preNormEDS_four, ite_eq_right (by decide)]
+  ring
+
+namespace EllSequence
+
+variable (W₁ compl₂ : ℤ → R) (m : ℤ)
+
+def compl' : ℕ → R
+  | 0 => 0
+  | 1 => 1
+  | (n + 2) => letI k := n / 2 + 1
+    have : k < n + 2 := by omega
+    if hn : Even n
+      then compl₂ ((k : ℤ) * m) * compl' k
+      else
+        have : k + 1 < n + 2 := by
+          obtain ⟨j, hj⟩ := Nat.not_even_iff_odd.mp hn; omega
+        W₁ (((k : ℤ) + 1) * m + 1) * W₁ (((k : ℤ) + 1) * m - 1) * compl' k ^ 2
+      - W₁ ((k : ℤ) * m + 1) * W₁ ((k : ℤ) * m - 1) * compl' (k + 1) ^ 2
+
+def compl (n : ℤ) : R := (n.sign : ℤ) * compl' W₁ compl₂ m n.natAbs
+
+lemma compl_ofNat (n : ℕ) : compl W₁ compl₂ m n = compl' W₁ compl₂ m n := by
+  by_cases hn : n = 0
+  · simp [hn, compl, compl']
+  · simp [compl, Int.sign_natCast_of_ne_zero hn]
+
+lemma compl_neg (n : ℤ) : compl W₁ compl₂ m (-n) = -compl W₁ compl₂ m n := by
+  simp [compl]
+
+def complEDS := compl (normEDS b c d) (compl₂EDS b c d) m
+
+end EllSequence
+
+end Complement
+
+section Map
+
+variable {b c d}
+
+lemma map_compl₂EDS (n : ℤ) : f (compl₂EDS b c d n) = compl₂EDS (f b) (f c) (f d) n :=
+  map_complEDS₂ f b c d n
+
+lemma EllSequence.map_compl' (W₁ compl₂ : ℤ → R) (m : ℤ) (n : ℕ) :
+    f (compl' W₁ compl₂ m n) = compl' (f ∘ W₁) (f ∘ compl₂) m n := by
+  refine n.strong_induction_on fun n ih ↦ ?_
+  obtain _|_|n := n
+  iterate 2 simp [compl']
+  rw [compl']; conv_rhs => rw [compl']
+  split_ifs with hn
+  · rw [map_mul, ih _ (by omega)]; rfl
+  simp_rw [map_sub, map_mul, map_pow]
+  rw [ih _ (by omega), ih]; · rfl
+  have := (Nat.not_even_iff_odd.mp hn).pos
+  omega
+
+lemma EllSequence.map_compl (W₁ compl₂ : ℤ → R) (m n : ℤ) :
+    f (compl W₁ compl₂ m n) = compl (f ∘ W₁) (f ∘ compl₂) m n := by
+  simp [compl, map_compl']
+
+private lemma map_normEDS_fl (n : ℤ) : f (normEDS b c d n) = normEDS (f b) (f c) (f d) n :=
+  map_normEDS f b c d n
+
+lemma EllSequence.map_complEDS (m n : ℤ) :
+    f (EllSequence.complEDS b c d m n) = EllSequence.complEDS (f b) (f c) (f d) m n := by
+  simp_rw [EllSequence.complEDS, EllSequence.map_compl, Function.comp_def, map_normEDS_fl,
+    map_compl₂EDS]
+
+lemma map_addMulSub (m n : ℤ) : f (addMulSub W m n) = addMulSub (f ∘ W) m n := by
+  simp_rw [addMulSub, map_mul, Function.comp]
+
+lemma map_rel₄ (p q r s : ℤ) : f (rel₄ W p q r s) = rel₄ (f ∘ W) p q r s := by
+  simp_rw [rel₄, map_add, map_sub, map_mul, map_addMulSub]
+
+lemma map_net (p q r s : ℤ) : f (net W p q r s) = net (f ∘ W) p q r s := by
+  simp_rw [net_eq_rel₄, map_rel₄]
+
+lemma map_invarNum (s m : ℤ) : f (invarNum W s m) = invarNum (f ∘ W) s m := by
+  simp only [invarNum, map_add, map_mul, map_pow, Function.comp]
+
+lemma map_invarDenom (s m : ℤ) : f (invarDenom W s m) = invarDenom (f ∘ W) s m := by
+  simp only [invarDenom, map_mul, Function.comp_apply]
+
+inductive Param : Type | B : Param | C : Param | D : Param
+
+open Param MvPolynomial
+
+noncomputable def universalNormEDS : ℤ → MvPolynomial Param ℤ := normEDS (X B) (X C) (X D)
+
+lemma normEDS_eq_aeval : normEDS b c d = (aeval (Param.rec b c d) <| universalNormEDS ·) := by
+  simp_rw [universalNormEDS, map_normEDS_fl, aeval_X]
+
+lemma compl₂EDS_eq_aeval :
+    compl₂EDS b c d =
+      (aeval (Param.rec b c d) <| compl₂EDS (X (R := ℤ) B) (X C) (X D) ·) := by
+  simp_rw [map_compl₂EDS, aeval_X]
+
+lemma complEDS_eq_aeval :
+    EllSequence.complEDS b c d =
+      (aeval (Param.rec b c d) <| EllSequence.complEDS (X (R := ℤ) B) (X C) (X D) · ·) := by
+  simp_rw [EllSequence.map_complEDS, aeval_X]
+
+end Map
+
+section
+
+variable {b c d} {U : ℤ → R} (ellW : IsEllSequence' W) (ellU : IsEllSequence' U)
+open MvPolynomial
+
+private lemma normEDS_of_mem_nonZeroDivisors (hb : b ∈ R⁰) : IsEllSequence' (normEDS b c d) :=
+  IsEllSequence'.of_oddRec_evenRec (normEDS_neg b c d) (normEDS_zero b c d)
+    (by rw [normEDS_one]; exact one_mem _) (by rwa [normEDS_two])
+    (fun m _ => by simp only [OddRec, normEDS_one, one_pow, mul_one]; exact normEDS_odd b c d m)
+    (fun m _ => by
+      simp only [EvenRec, normEDS_one, normEDS_two, one_pow, mul_one]
+      rw [normEDS_even]; ring)
+
+protected lemma IsEllSequence'.normEDS : IsEllSequence' (normEDS b c d) := by
+  rw [normEDS_eq_aeval]
+  exact IsEllSequence'.map _
+    (normEDS_of_mem_nonZeroDivisors <| mem_nonZeroDivisors_of_ne_zero <| X_ne_zero _)
+
+include ellW ellU in
+protected lemma IsEllSequence'.ext (one : W 1 ∈ R⁰) (two : W 2 ∈ R⁰)
+    (h1 : W 1 = U 1) (h2 : W 2 = U 2) (h3 : W 3 = U 3) (h4 : W 4 = U 4) : W = U := by
+  funext n
+  induction n using Int.negInduction with
+  | nat n =>
+    refine normEDSRec ?_ h1 h2 h3 h4 (fun m h₁ h₂ h₃ h₄ h₅ ↦ ?_) (fun m h₁ h₂ h₃ h₄ ↦ ?_) n
+    · rw [Nat.cast_zero, ellW.zero 1 two, ellU.zero 1 (h2 ▸ two)]
+    · erw [← mul_cancel_right_mem_nonZeroDivisors (mul_mem two <| pow_mem one 2), ← mul_assoc,
+        ← mul_assoc, Nat.cast_mul, Nat.cast_add, ellW.evenRec, h1, h2, ellU.evenRec]
+      convert congr($h₃ * ($h₂ ^ 2 * $h₅ - $h₁ * $h₄ ^ 2)) <;> omega
+    · rw [← mul_cancel_right_mem_nonZeroDivisors (pow_mem one 3)]
+      erw [Nat.cast_add, Nat.cast_mul, Nat.cast_add, ellW.oddRec, h1, ellU.oddRec]
+      convert congr($h₄ * $h₂ ^ 3 - $h₁ * $h₃ ^ 3) <;> omega
+  | neg ih n => rw [ellW.neg one two, ellU.neg (h1 ▸ one) (h2 ▸ two), ih]
+
+lemma normEDS_two_three_two : normEDS 2 3 2 = id := by
+  apply IsEllSequence'.normEDS.ext isEllSequence'_id <;>
+    simp only [normEDS_one, normEDS_two, normEDS_three, normEDS_four]
+  exacts [mem_nonZeroDivisors_of_ne_zero one_ne_zero,
+    mem_nonZeroDivisors_of_ne_zero two_ne_zero, rfl, rfl, rfl, rfl]
+
+lemma compl₂EDS_two_three_two (n : ℤ) : compl₂EDS (2 : ℤ) 3 2 n = 2 := by
+  obtain rfl | hn := eq_or_ne n 0
+  · exact compl₂EDS_zero ..
+  · have := normEDS_mul_compl₂EDS (2 : ℤ) 3 2 n
+    rwa [normEDS_two_three_two, id_eq, id_eq, mul_comm,
+      mul_cancel_right_mem_nonZeroDivisors (mem_nonZeroDivisors_of_ne_zero hn)] at this
+
+lemma universalNormEDS_ne_zero {n : ℤ} (hn : n ≠ 0) : universalNormEDS n ≠ 0 := by
+  intro h
+  refine hn ?_
+  apply_fun aeval (Param.rec (2 : ℤ) 3 2) at h
+  simpa [universalNormEDS, map_normEDS_fl, normEDS_two_three_two] using h
+
+lemma universalNormEDS_mem_nonZeroDivisors {n : ℤ} (hn : n ≠ 0) :
+    universalNormEDS n ∈ (MvPolynomial Param ℤ)⁰ :=
+  mem_nonZeroDivisors_of_ne_zero (universalNormEDS_ne_zero hn)
+
+section Divisibility
+
+variable (one : W 1 ∈ R⁰) (two : W 2 ∈ R⁰)
+  (dvd₁₂ : W 1 ∣ W 2) (dvd₁₃ : W 1 ∣ W 3) (dvd₂₄ : W 2 ∣ W 4)
+
+include ellW one two dvd₁₂ dvd₁₃ dvd₂₄ in
+theorem IsEllSequence'.eq_normEDS_of_dvd : ∃ b c d, W = (W 1 * normEDS b c d ·) := by
+  obtain ⟨b, h₁₂⟩ := dvd₁₂
+  obtain ⟨c, h₁₃⟩ := dvd₁₃
+  obtain ⟨d, h₂₄⟩ := dvd₂₄
+  exact ⟨b, c, d, ellW.ext (IsEllSequence'.normEDS.smul _) one two (by simp) (by simp [h₁₂])
+    (by simp [h₁₃]) (by rw [h₂₄, h₁₂, normEDS_four]; ring)⟩
+
+include one two in
+theorem IsEllDivSequence'.eq_normEDS (h : IsEllDivSequence' W) :
+    ∃ b c d, W = (W 1 * normEDS b c d ·) :=
+  h.1.eq_normEDS_of_dvd one two (h.2 _ _ ⟨2, rfl⟩) (h.2 _ _ ⟨3, rfl⟩) (h.2 _ _ ⟨2, rfl⟩)
+
+section Complement
+
+variable (W₁ compl₂ : ℤ → R)
+  (h₁ : ∀ m, W 1 * W₁ m = W m) (h₂ : ∀ m, W m * compl₂ m = W (2 * m)) (m n : ℤ)
+
+include ellW one two h₁ h₂ in
+lemma IsEllSequence'.mul_compl_eq_apply_mul_of_mem_nonZeroDivisors (mem : W m ∈ R⁰) :
+    W m * compl W₁ compl₂ m n = W (n * m) := by
+  induction n using Int.negInduction with
+  | nat n =>
+    refine n.strong_induction_on fun n ih ↦ ?_
+    obtain _ | n := n
+    · simp [EllSequence.compl, ellW.zero 1 two]
+    obtain _ | n := n
+    · simp [EllSequence.compl, compl']
+    rw [EllSequence.compl, Int.sign_eq_one_of_pos (by omega),
+      Int.natAbs_natCast, compl', Int.cast_one, one_mul]
+    obtain ⟨k, rfl|rfl⟩ := n.even_or_odd'
+    · rw [dite_eq_left (even_two_mul _), k.mul_div_cancel_left zero_lt_two, mul_comm (compl₂ _),
+        ← mul_assoc, ← compl_ofNat, ih _ (by omega), h₂, ← mul_assoc, add_assoc, ← two_mul,
+        ← left_distrib, Nat.cast_mul]; rfl
+    simp_rw [dite_eq_right (Nat.not_even_two_mul_add_one _), show (2 * k + 1) / 2 = k by omega]
+    rw [← mul_cancel_right_mem_nonZeroDivisors (mul_mem mem <| pow_mem one 2)]
+    have := (ellW ((k + 1 + 1) * m) ((k + 1) * m) 1).symm
+    simp_rw [← right_distrib, ← mul_sub_right_distrib, add_sub_cancel_left,
+      ← h₁ (_ + 1), ← h₁ (_ - 1), ← Nat.cast_one (R := ℤ), ← Nat.cast_add] at this
+    rw [← ih _ (by omega), ← ih _ (by omega)] at this
+    simp_rw [compl_ofNat, Nat.cast_add] at this ⊢
+    convert this using 1
+    · ring_nf
+    rw [Nat.cast_mul]; ring_nf
+  | neg hn n => rw [neg_mul, ellW.neg one two, compl_neg, mul_neg, hn]
+
+lemma normEDS_mul_complEDS (m n : ℤ) :
+    normEDS b c d m * EllSequence.complEDS b c d m n = normEDS b c d (n * m) := by
+  obtain rfl|hm := eq_or_ne m 0
+  · simp
+  rw [normEDS_eq_aeval, universalNormEDS, complEDS_eq_aeval, ← map_mul]; congr 1
+  have := @universalNormEDS_mem_nonZeroDivisors
+  exact IsEllSequence'.normEDS.mul_compl_eq_apply_mul_of_mem_nonZeroDivisors (this one_ne_zero)
+    (this two_ne_zero) _ _ (fun _ ↦ by simp) (fun _ ↦ normEDS_mul_compl₂EDS _ _ _ _) _ _ (this hm)
+
+lemma normEDS_mul_complEDS_div (hm : m ≠ 0) (n : ℤ) (dvd : m ∣ n) :
+    normEDS b c d m * EllSequence.complEDS b c d m (n / m) = normEDS b c d n := by
+  obtain ⟨n, rfl⟩ := dvd
+  rw [Int.mul_ediv_cancel_left _ hm, normEDS_mul_complEDS, mul_comm]
+
+namespace EllSequence
+
+variable (b c d)
+
+def redInvarNum : R :=
+  compl₂EDS b c d m + normEDS b c d m ^ 3 * b + 2 * compl₂EDSAux b c d m
+
+lemma compl₂EDS_eq_redInvarNum_sub :
+    compl₂EDS b c d m =
+      redInvarNum b c d m - normEDS b c d m ^ 3 * b - 2 * compl₂EDSAux b c d m := by
+  rw [redInvarNum]; ring
+
+lemma invarNum_eq_redInvarNum_mul : invarNum (normEDS b c d) 1 m = redInvarNum b c d m * b := by
+  simp_rw [redInvarNum, right_distrib, compl₂EDS_mul_b, mul_assoc 2 _ b,
+    compl₂EDSAux_mul_b, invarNum_normEDS]; ring
+
+def redInvarDenom : R :=
+  letI C := complEDS b c d
+  letI W := normEDS b c d
+  letI r₆ := normEDS b c d 5 - d ^ 2
+  if m % 6 = 0 then r₆ * C 6 (m / 6) * W (m + 1) * W (m - 1) else
+  if m % 6 = 1 then r₆ * C 6 ((m - 1) / 6) * W (m + 1) * W m else
+  if m % 6 = 5 then r₆ * C 6 ((m + 1) / 6) * W m * W (m - 1) else
+  if m % 6 = 2 then C 3 ((m + 1) / 3) * C 2 (m / 2) * W (m - 1) else
+  if m % 6 = 4 then C 3 ((m - 1) / 3) * C 2 (m / 2) * W (m + 1) else
+  if m % 6 = 3 then C 3 (m / 3) * C 2 ((m - 1) / 2) * W (m + 1) else 0
+
+lemma invarDenom_eq_redInvarDenom_mul :
+    invarDenom (normEDS b c d) 1 m = redInvarDenom b c d m * b * c := by
+  have h6 : (6 : ℤ) ≠ 0 := by decide
+  have h3 : (3 : ℤ) ≠ 0 := by decide
+  have hd (k m : ℤ) (dvd : k ∣ 6) (eq : m % 6 % k = 0) : k ∣ m :=
+    Int.dvd_iff_emod_eq_zero.mpr ((Int.emod_emod_of_dvd m dvd).symm.trans eq)
+  have hd2 {m} := hd 2 m ⟨3, rfl⟩
+  have hd3 {m} := hd 3 m ⟨2, rfl⟩
+  have dvd_sub {a b c : ℤ} (h : a % b = c) : b ∣ a - c := by
+    rw [← h, Int.emod_def, sub_sub_cancel]
+    exact dvd_mul_right _ _
+  have mul_eq := @normEDS_mul_complEDS_div _ _ b c d
+  rw [invarDenom, redInvarDenom]; split_ifs with h h h h h h
+  · rw [← mul_eq _ h6 _ (Int.dvd_of_emod_eq_zero h), normEDS_six_eq_mul]; ring
+  · rw [← mul_eq _ h6 _ (dvd_sub h), normEDS_six_eq_mul]; ring
+  · rw [show m + 1 = m + 6 - 5 by abel, ← mul_eq _ h6, normEDS_six_eq_mul]
+    · ring
+    · exact dvd_sub (show (m + 6) % 6 = 5 by omega)
+  on_goal 1 => rw [← mul_eq _ h3 _ (hd3 <| by simp [h, Int.add_emod]),
+    ← mul_eq _ two_ne_zero m (hd2 <| by simp [h])]
+  on_goal 2 => rw [← mul_eq _ h3 (m - 1) (hd3 <| by simp [h, Int.sub_emod]),
+    ← mul_eq _ two_ne_zero m (hd2 <| by simp [h])]
+  on_goal 3 => rw [← mul_eq _ h3 m (hd3 <| by simp [h]),
+    ← mul_eq _ two_ne_zero (m - 1) (hd2 <| by simp [h, Int.sub_emod])]
+  on_goal 4 =>
+    have h0 := Int.emod_nonneg m h6
+    have lt := Int.emod_lt_of_pos m (show 0 < 6 by decide)
+    interval_cases m % 6 <;> contradiction
+  all_goals rw [normEDS_three, normEDS_two]; ring
+
+@[simp] lemma redInvarDenom_zero : redInvarDenom b c d 0 = 0 := by
+  simp [redInvarDenom, complEDS, compl', compl]
+
+@[simp] lemma redInvarDenom_one : redInvarDenom b c d 1 = 0 := by
+  simp [redInvarDenom, complEDS, compl', compl]
+
+@[simp] lemma redInvarDenom_two : redInvarDenom b c d 2 = 1 := by
+  simp [redInvarDenom, complEDS, compl', compl]
+
+lemma map_compl₂EDSAux : f (compl₂EDSAux b c d m) = compl₂EDSAux (f b) (f c) (f d) m := by
+  have mp : ∀ n : ℤ, f (preNormEDS (b ^ 4) c d n) = preNormEDS (f b ^ 4) (f c) (f d) n :=
+    fun n ↦ by
+      rw [show f b ^ 4 = f (b ^ 4) from (map_pow f b 4).symm]
+      exact map_preNormEDS f (b ^ 4) c d n
+  simp [compl₂EDSAux, apply_ite f, mp]
+
+lemma map_redInvarNum : f (redInvarNum b c d m) = redInvarNum (f b) (f c) (f d) m := by
+  have mn : ∀ n : ℤ, f (normEDS b c d n) = normEDS (f b) (f c) (f d) n :=
+    fun n ↦ map_normEDS f b c d n
+  simp [redInvarNum, map_compl₂EDS, mn, map_compl₂EDSAux, map_ofNat]
+
+lemma map_redInvarDenom : f (redInvarDenom b c d m) = redInvarDenom (f b) (f c) (f d) m := by
+  have mn : ∀ n : ℤ, f (normEDS b c d n) = normEDS (f b) (f c) (f d) n :=
+    fun n ↦ map_normEDS f b c d n
+  simp [redInvarDenom, apply_ite f, mn, map_complEDS]
+
+end EllSequence
+
+end Complement
+
+protected theorem IsDivSequence'.normEDS : IsDivSequence' (normEDS b c d) := by
+  rintro m _ ⟨n, rfl⟩
+  rw [Nat.cast_mul, mul_comm (m : ℤ), ← normEDS_mul_complEDS]
+  exact dvd_mul_right _ _
+
+protected theorem IsEllDivSequence'.normEDS : IsEllDivSequence' (normEDS b c d) :=
+  ⟨IsEllSequence'.normEDS, IsDivSequence'.normEDS⟩
+
+include ellW one two dvd₁₂ dvd₁₃ dvd₂₄ in
+lemma IsEllSequence'.isDivSequence_of_dvd : IsDivSequence' W := by
+  obtain ⟨b, c, d, h⟩ := ellW.eq_normEDS_of_dvd one two dvd₁₂ dvd₁₃ dvd₂₄
+  rw [h]; exact IsDivSequence'.normEDS.smul _
+
+include ellW one two dvd₁₂ dvd₁₃ dvd₂₄ in
+lemma IsEllSequence'.isEllDivSequence_of_dvd : IsEllDivSequence' W :=
+  ⟨ellW, ellW.isDivSequence_of_dvd one two dvd₁₂ dvd₁₃ dvd₂₄⟩
+
+end Divisibility
+
+section
+
+lemma net_normEDS (p q r s : ℤ) : net (normEDS b c d) p q r s = 0 := by
+  rw [normEDS_eq_aeval, ← Function.comp_def, ← map_net,
+    universalNormEDS, IsEllSequence'.normEDS.net, map_zero] <;>
+    apply mem_nonZeroDivisors_of_ne_zero <;>
+    simp only [normEDS_one, normEDS_two] <;>
+    first
+      | exact one_ne_zero
+      | exact MvPolynomial.X_ne_zero _
+
+lemma rel₄_normEDS (p q r s : ℤ) (same : HaveSameParity₄ p q r s) :
+    rel₄ (normEDS b c d) p q r s = 0 := by
+  rw [same.rel₄_eq_net, net_normEDS]
+
+lemma invar_normEDS (s m n : ℤ) :
+    invarNum (normEDS b c d) s m * invarDenom (normEDS b c d) s n =
+      invarNum (normEDS b c d) s n * invarDenom (normEDS b c d) s m :=
+  invar_of_net _ net_normEDS _ _ _
+
+private lemma invar₂_normEDS_of_mem_nonZeroDivisors (hb : b ∈ R⁰) (m : ℤ) :
+    invarNum (normEDS b c d) 1 m * c = invarDenom (normEDS b c d) 1 m * (d + b ^ 4) := by
+  rw [← mul_cancel_right_mem_nonZeroDivisors hb, mul_assoc, mul_assoc, mul_comm (invarDenom _ _ _)]
+  convert invar_normEDS 1 m 2 <;> simp only [invarNum_normEDS_two, invarDenom_normEDS_two]
+
+open MvPolynomial Param in
+lemma invar₂_normEDS {m : ℤ} :
+    invarNum (normEDS b c d) 1 m * c = invarDenom (normEDS b c d) 1 m * (d + b ^ 4) := by
+  have := congr(aeval (Param.rec b c d) $(invar₂_normEDS_of_mem_nonZeroDivisors
+    (c := X Param.C) (d := X D) (mem_nonZeroDivisors_of_ne_zero <| X_ne_zero (R := ℤ) B) m))
+  rw [← universalNormEDS] at this
+  simpa only [map_mul, map_invarNum, map_invarDenom,
+    Function.comp_def, ← normEDS_eq_aeval, map_add, map_pow, aeval_X] using this
+
+private lemma redInvar_normEDS_of_mem_nonZeroDivisors (hb : b ∈ R⁰) (hc : c ∈ R⁰) (m : ℤ) :
+    redInvarNum b c d m = redInvarDenom b c d m * (d + b ^ 4) := by
+  rw [← mul_cancel_right_mem_nonZeroDivisors hb, ← mul_cancel_right_mem_nonZeroDivisors hc,
+    ← invarNum_eq_redInvarNum_mul, invar₂_normEDS, invarDenom_eq_redInvarDenom_mul]
+  ring
+
+open MvPolynomial Param in
+lemma redInvar_normEDS (m : ℤ) :
+    redInvarNum b c d m = redInvarDenom b c d m * (d + b ^ 4) := by
+  have := congr(aeval (Param.rec b c d) $(redInvar_normEDS_of_mem_nonZeroDivisors
+    (b := X (R := ℤ) B) (c := X Param.C) (d := X D) ?_ ?_ m))
+  · simpa only [map_redInvarNum, map_mul, map_add, map_pow, map_redInvarDenom, aeval_X] using this
+  all_goals exact mem_nonZeroDivisors_of_ne_zero (X_ne_zero _)
+end
+
+end
+
+end PortEllSequenceCore
+
+noncomputable section PortEllSequenceUniversal
+
+open scoped Polynomial.Bivariate
+
+namespace WeierstrassCurve
+
+inductive Coeff : Type | A₁ : Coeff | A₂ : Coeff | A₃ : Coeff | A₄ : Coeff | A₆ : Coeff
+
+namespace Affine.CoordinateRing
+
+lemma algebraMap_injective' {R : Type*} [CommRing R] (W : Affine R) :
+    Function.Injective (algebraMap R W.CoordinateRing) := by
+  have h : Function.Injective (algebraMap (Polynomial R) W.CoordinateRing) :=
+    (injective_iff_map_eq_zero _).mpr fun p hp ↦ And.left <|
+      smul_basis_eq_zero (W' := W) (q := 0) <| by
+        rw [smul, smul, mul_one, Polynomial.C_0, map_zero, zero_mul, add_zero]
+        exact hp
+  exact h.comp Polynomial.C_injective
+
+end Affine.CoordinateRing
+
+namespace Univ
+
+open scoped Polynomial Polynomial.Bivariate
+open Coeff
+
+open MvPolynomial (X) in
+def curve : Affine (MvPolynomial Coeff ℤ) :=
+  { a₁ := X A₁, a₂ := X A₂, a₃ := X A₃, a₄ := X A₄, a₆ := X A₆ }
+
+lemma Δ_curve_ne_zero : curve.Δ ≠ 0 := fun h ↦ by
+  simp_rw [Δ, b₂, b₄, b₆, b₈, curve] at h
+  apply_fun MvPolynomial.eval (Coeff.rec 0 0 0 0 1) at h
+  simp at h
+
+abbrev Poly : Type := (MvPolynomial Coeff ℤ)[X][Y]
+
+protected abbrev Ring : Type := curve.CoordinateRing
+
+protected abbrev Field : Type := FractionRing Univ.Ring
+
+instance : CommRing Poly := Polynomial.commRing
+
+lemma Poly.two_ne_zero : (2 : Poly) ≠ 0 :=
+  Polynomial.C_ne_zero.mpr <| Polynomial.C_ne_zero.mpr fun h ↦ two_ne_zero' (α := ℤ) <|
+    MvPolynomial.C_injective _ _ <| by rwa [← MvPolynomial.C_0] at h
+
+def polyToField : Poly →+* Univ.Field := (algebraMap Univ.Ring _).comp <| AdjoinRoot.mk _
+
+lemma polyToField_apply (p : Poly) :
+    polyToField p = algebraMap Univ.Ring _ (AdjoinRoot.mk _ p) := rfl
+
+lemma algebraMap_field_eq_comp :
+    algebraMap (MvPolynomial Coeff ℤ) Univ.Field = polyToField.comp (algebraMap _ _) := rfl
+
+lemma algebraMap_ring_eq_comp :
+    algebraMap (MvPolynomial Coeff ℤ) Univ.Ring = (AdjoinRoot.mk _).comp (algebraMap _ _) :=
+  rfl
+
+@[simp] lemma polyToField_polynomial : polyToField curve.polynomial = 0 := by
+  rw [polyToField_apply, AdjoinRoot.mk_self, map_zero]
+
+lemma algebraMap_field_injective :
+    Function.Injective (algebraMap (MvPolynomial Coeff ℤ) Univ.Field) :=
+  (IsFractionRing.injective Univ.Ring Univ.Field).comp
+    (Affine.CoordinateRing.algebraMap_injective' _)
+
+abbrev pointedCurve : WeierstrassCurve Univ.Field :=
+  baseChange curve Univ.Field
+
+instance : pointedCurve.IsElliptic where
+  isUnit := isUnit_iff_ne_zero.mpr <| by
+    simpa only [pointedCurve, baseChange, map_Δ, map_ne_zero_iff _ algebraMap_field_injective]
+      using Δ_curve_ne_zero
+
+open Polynomial in
+lemma equation_point : pointedCurve.toAffine.Equation (polyToField (C X)) (polyToField Y) := by
+  simp_rw [Affine.Equation, pointedCurve, baseChange, algebraMap_field_eq_comp, ← map_map,
+    Affine.map_polynomial, map_mapRingHom_evalEval, evalEval, eval_map,
+    eval_C_X_eval₂_map_C_X, polyToField_polynomial]
+
+open Polynomial Affine in
+def Affine.point : curve⟮Univ.Field⟯ :=
+  .some (polyToField (C X)) (polyToField Y)
+    ((pointedCurve.toAffine.equation_iff_nonsingular_of_Δ_ne_zero
+      (by simpa only [pointedCurve, baseChange, map_Δ, map_ne_zero_iff _ algebraMap_field_injective]
+        using Δ_curve_ne_zero)).mp equation_point)
+
+def Jacobian.point : Jacobian.Point (WeierstrassCurve.baseChange curve Univ.Field) :=
+  Jacobian.Point.fromAffine Affine.point
+
+open Polynomial (CC)
+
+@[simp] lemma pointedCurve_a₁ : pointedCurve.a₁ = polyToField (CC curve.a₁) := rfl
+@[simp] lemma pointedCurve_a₂ : pointedCurve.a₂ = polyToField (CC curve.a₂) := rfl
+@[simp] lemma pointedCurve_a₃ : pointedCurve.a₃ = polyToField (CC curve.a₃) := rfl
+@[simp] lemma pointedCurve_a₄ : pointedCurve.a₄ = polyToField (CC curve.a₄) := rfl
+@[simp] lemma pointedCurve_a₆ : pointedCurve.a₆ = polyToField (CC curve.a₆) := rfl
+
+abbrev curvePoly : WeierstrassCurve Poly := WeierstrassCurve.baseChange curve Poly
+
+abbrev curveRing : WeierstrassCurve Univ.Ring :=
+  WeierstrassCurve.baseChange curve Univ.Ring
+
+abbrev curveField : WeierstrassCurve Univ.Field :=
+  WeierstrassCurve.baseChange curve Univ.Field
+
+lemma curveField_eq : curveField = pointedCurve := rfl
+
+end Univ
+
+def cusp : Affine ℤ := { a₁ := 0, a₂ := 0, a₃ := 0, a₄ := 0, a₆ := 0 }
+
+lemma cusp_equation_one_one : cusp.Equation 1 1 := by
+  simp [Affine.Equation, Affine.polynomial, cusp, Polynomial.evalEval]
+
+open Univ
+variable {R} [CommRing R] (W : WeierstrassCurve R)
+
+def specialize : MvPolynomial Coeff ℤ →+* R :=
+  (MvPolynomial.aeval <| Coeff.rec W.a₁ W.a₂ W.a₃ W.a₄ W.a₆).toRingHom
+
+lemma map_specialize : WeierstrassCurve.map Univ.curve W.specialize = W := by
+  simp [specialize, curve, map]
+
+namespace Univ
+
+variable (x y : R)
+
+open Polynomial (eval₂RingHom) in
+def polyEval : Poly →+* R := eval₂RingHom (eval₂RingHom W.specialize x) y
+
+open Polynomial in
+lemma polyEval_apply (p : Poly) :
+    polyEval W x y p = (p.map <| mapRingHom W.specialize).evalEval x y :=
+  eval₂_eval₂RingHom_apply _ _ _ _
+
+variable {W x y} (eqn : Affine.Equation W x y)
+
+open Polynomial in
+def ringEval : Univ.Ring →+* R :=
+  AdjoinRoot.lift (eval₂RingHom W.specialize x) y <| by
+    simp_rw [← coe_eval₂RingHom, eval₂RingHom_eval₂RingHom, RingHom.comp_apply, coe_mapRingHom]
+    rw [← Affine.map_polynomial]
+    simpa only [Affine.map, map_specialize, Affine.Equation, evalEval, coe_evalRingHom] using eqn
+
+lemma ringEval_mk (p : Poly) : ringEval eqn (AdjoinRoot.mk _ p) = polyEval W x y p :=
+  AdjoinRoot.lift_mk _ p
+
+lemma ringEval_comp_mk : (ringEval eqn).comp (AdjoinRoot.mk _) = polyEval W x y :=
+  RingHom.ext (ringEval_mk eqn)
+
+lemma polyEval_comp_eq_specialize : (polyEval W x y).comp (algebraMap _ _) = W.specialize := by
+  ext <;> simp [polyEval]
+
+lemma ringEval_comp_eq_specialize : (ringEval eqn).comp (algebraMap _ _) = W.specialize := by
+  rw [algebraMap_ring_eq_comp, ← RingHom.comp_assoc, ringEval_comp_mk, polyEval_comp_eq_specialize]
+
+protected lemma Field.two_ne_zero : (2 : Univ.Field) ≠ 0 := by
+  rw [← map_ofNat (algebraMap Univ.Ring _), map_ne_zero_iff _ (IsFractionRing.injective _ _)]
+  intro h; replace h := congr(ringEval cusp_equation_one_one $h)
+  rw [map_ofNat, map_zero] at h; cases h
+
+lemma curveRing_map_ringEval : curveRing.map (ringEval eqn) = W := by
+  rw [curveRing, WeierstrassCurve.baseChange, map_map, ringEval_comp_eq_specialize, map_specialize]
+
+end Univ
+
+end WeierstrassCurve
+
+end PortEllSequenceUniversal
+
+section PortEllSequenceDivisionPolys
+
+open Polynomial
+open scoped Polynomial.Bivariate
+
+local macro "C_simp" : tactic =>
+  `(tactic| simp only [map_ofNat, C_0, C_1, C_neg, C_add, C_sub, C_mul, C_pow])
+
+namespace WeierstrassCurve
+
+variable {R : Type*} {S : Type*} [CommRing R] [CommRing S] (W : WeierstrassCurve R)
+
+noncomputable section
+
+def invar : R[X] := 6 * X ^ 2 + C W.b₂ * X + C W.b₄
+
+def ψc : ℤ → R[X][Y] := compl₂EDS W.ψ₂ (C W.Ψ₃) (C W.preΨ₄)
+
+open Affine (polynomial polynomialX polynomialY negPolynomial)
+open EllSequence
+
+lemma C_Ψ₃_eq :
+    C W.Ψ₃ = (3 * C X + CC W.a₂) * C W.Ψ₂Sq - polynomialX W ^ 2
+      + CC W.a₁ * W.ψ₂ * polynomialX W - CC W.a₁ ^ 2 * polynomial W := by
+  simp_rw [Ψ₃, Ψ₂Sq, polynomial, polynomialX, ψ₂, polynomialY, b₂, b₄, b₆, b₈, CC]; C_simp; ring
+
+lemma preΨ₄_add_Ψ₂Sq_sq : W.preΨ₄ + W.Ψ₂Sq ^ 2 = W.invar * W.Ψ₃ := by
+  rw [preΨ₄, Ψ₂Sq, invar, Ψ₃]
+  linear_combination (norm := (C_simp; ring_nf)) congr(C $W.b_relation) * (@X R _) ^ 2
+
+lemma preΨ₄_add_ψ₂_pow_four : C W.preΨ₄ + W.ψ₂ ^ 4 =
+    C (W.invar * W.Ψ₃) + 8 * polynomial W * (2 * polynomial W + C W.Ψ₂Sq) := by
+  simp_rw [show 4 = 2 * 2 by rfl, pow_mul, ψ₂_sq, add_sq,
+    ← add_assoc, ← C_pow, ← C_add, preΨ₄_add_Ψ₂Sq_sq]; C_simp; ring
+
+lemma φ_mul_ψ (n : ℤ) : W.φ n * W.ψ n = C X * W.ψ n ^ 3 - invarDenom W.ψ 1 n := by
+  rw [WeierstrassCurve.φ, invarDenom]; ring
+
+protected def ωe (n : ℤ) : R[X][Y] :=
+  redInvarDenom W.ψ₂ (C W.Ψ₃) (C W.preΨ₄) n *
+    ((CC W.a₁ * polynomialY W - polynomialX W) * C W.Ψ₃
+      + 4 * polynomial W * (2 * polynomial W + C W.Ψ₂Sq))
+  - compl₂EDSAux W.ψ₂ (C W.Ψ₃) (C W.preΨ₄) n + negPolynomial W * W.ψ n ^ 3
+
+lemma ωe_spec (n : ℤ) :
+    2 * W.ωe n + CC W.a₁ * W.φ n * W.ψ n + CC W.a₃ * W.ψ n ^ 3 = W.ψc n := by
+  have hψ : W.ψ = normEDS W.ψ₂ (C W.Ψ₃) (C W.preΨ₄) := rfl
+  rw [ψc, compl₂EDS_eq_redInvarNum_sub, redInvar_normEDS, preΨ₄_add_ψ₂_pow_four,
+    mul_assoc (C _), φ_mul_ψ, hψ, invarDenom_eq_redInvarDenom_mul, WeierstrassCurve.ωe, ← hψ,
+    invar, b₂, b₄, ψ₂, Affine.polynomialY, Affine.polynomialX, Affine.negPolynomial]
+  C_simp; ring
+
+lemma two_mul_ωe (n : ℤ) :
+    2 * W.ωe n = W.ψc n - CC W.a₁ * W.φ n * W.ψ n - CC W.a₃ * W.ψ n ^ 3 := by
+  rw [← ωe_spec]; abel
+
+lemma ψc_spec (n : ℤ) : W.ψ n * W.ψc n = W.ψ (2 * n) := normEDS_mul_compl₂EDS _ _ _ _
+
+@[simp] lemma ωe_zero : W.ωe 0 = 1 := by simp [WeierstrassCurve.ωe]
+
+@[simp] lemma ωe_one : W.ωe 1 = Y := by simp [WeierstrassCurve.ωe, ψ₂, ← Affine.Y_sub_polynomialY]
+
+@[simp] lemma ψc_neg (n : ℤ) : W.ψc (-n) = W.ψc n := by simp [ψc]
+
+end
+
+section Map
+
+variable (f : R →+* S)
+
+lemma map_ψc (n : ℤ) : (W.map f).ψc n = (W.ψc n).map (mapRingHom f) := by
+  simp only [ψc, ← coe_mapRingHom, map_compl₂EDS, map_ψ₂, map_Ψ₃, map_preΨ₄]
+  simp only [coe_mapRingHom, map_C]
+
+lemma map_invar : (W.map f).invar = W.invar.map f := by
+  simp only [invar, map_b₂, map_b₄]
+  simp only [Polynomial.map_add, Polynomial.map_mul, Polynomial.map_pow, Polynomial.map_ofNat,
+    map_C, map_X]
+
+open Affine EllSequence in
+lemma map_ωe (n : ℤ) : (W.map f).ωe n = (W.ωe n).map (mapRingHom f) := by
+  simp_rw [WeierstrassCurve.ωe, ← coe_mapRingHom, map_add, map_sub, map_mul, map_redInvarDenom,
+    map_compl₂EDSAux, map_polynomial, map_polynomialX, map_polynomialY, map_negPolynomial,
+    map_ψ₂, map_Ψ₃, map_preΨ₄, map_Ψ₂Sq, map_ψ]; simp
+
+end Map
+
+end WeierstrassCurve
+
+end PortEllSequenceDivisionPolys
+
+section PortEllSequenceZSMul
+
+open scoped Polynomial.Bivariate
+
+namespace WeierstrassCurve
+
+open Polynomial
+
+variable {R S : Type*} [CommRing R] [CommRing S] (W : WeierstrassCurve R) (f : R →+* S)
+
+noncomputable section
+
+variable {x y : R}
+
+namespace Univ
+
+lemma evalEval_ψ₂ : W.ψ₂.evalEval x y = polyEval W x y curve.ψ₂ := by
+  simp_rw [polyEval_apply, ← map_ψ₂, map_specialize]
+
+lemma evalEval_Ψ₃ : (C W.Ψ₃).evalEval x y = polyEval W x y (C curve.Ψ₃) := by
+  simp_rw [polyEval_apply, map_C, coe_mapRingHom, ← map_Ψ₃, map_specialize]
+
+lemma evalEval_preΨ₄ : (C W.preΨ₄).evalEval x y = polyEval W x y (C curve.preΨ₄) := by
+  simp_rw [polyEval_apply, map_C, coe_mapRingHom, ← map_preΨ₄, map_specialize]
+
+variable {m n : ℤ}
+
+lemma evalEval_ψ : (W.ψ n).evalEval x y = polyEval W x y (curve.ψ n) := by
+  simp_rw [polyEval_apply, ← map_ψ, map_specialize]
+
+lemma evalEval_φ : (W.φ n).evalEval x y = polyEval W x y (curve.φ n) := by
+  simp_rw [polyEval_apply, ← map_φ, map_specialize]
+
+lemma evalEval_ωe : (W.ωe n).evalEval x y = polyEval W x y (curve.ωe n) := by
+  simp_rw [polyEval_apply, ← map_ωe, map_specialize]
+
+open WeierstrassCurve (ψ φ ωe)
+
+lemma cusp_ψ₂ : cusp.ψ₂ = 2 * Y := by
+  simp [cusp, ψ₂, Affine.polynomialY, map_ofNat]
+
+lemma cusp_Ψ₃ : cusp.Ψ₃ = 3 * X ^ 4 := by simp [cusp, Ψ₃, b₂, b₄, b₆, b₈]
+lemma cusp_preΨ₄ : cusp.preΨ₄ = 2 * X ^ 6 := by simp [cusp, preΨ₄, b₂, b₄, b₆, b₈]
+
+lemma polyEval_cusp_ψ : polyEval cusp 1 1 (curve.ψ n) = n := by
+  rw [ψ, map_normEDS, ← evalEval_ψ₂, ← evalEval_Ψ₃, ← evalEval_preΨ₄, cusp_ψ₂, cusp_Ψ₃, cusp_preΨ₄]
+  simp [evalEval, normEDS_two_three_two]
+
+lemma polyEval_cusp_φ : polyEval cusp 1 1 (curve.φ n) = 1 := by
+  simp_rw [φ, map_sub, map_mul, map_pow, polyEval_cusp_ψ, polyEval]
+  simp only [coe_eval₂RingHom, eval₂_C, eval₂_X]; ring
+
+lemma polyEval_cusp_ψc : polyEval cusp 1 1 (curve.ψc n) = 2 := by
+  rw [ψc, map_compl₂EDS, ← evalEval_ψ₂, ← evalEval_Ψ₃, ← evalEval_preΨ₄]
+  simp [cusp_ψ₂, cusp_Ψ₃, cusp_preΨ₄, evalEval, compl₂EDS_two_three_two]
+
+lemma polyEval_cusp_ωe : polyEval cusp 1 1 (curve.ωe n) = 1 := by
+  have := congr(polyEval cusp 1 1 $(curve.two_mul_ωe n))
+  simp_rw [map_sub, map_mul, map_ofNat, polyEval_cusp_ψc] at this
+  simpa [cusp, polyEval, specialize, curve] using this
+
+abbrev ψᵤ (n : ℤ) : Univ.Field := polyToField (curve.ψ n)
+
+lemma ψᵤ_eq_normEDS :
+    ψᵤ = normEDS
+      (polyToField curve.ψ₂) (polyToField <| C curve.Ψ₃) (polyToField <| C curve.preΨ₄) := by
+  ext; rw [← map_normEDS]; rfl
+
+lemma isEllSequence_ψᵤ : IsEllSequence' ψᵤ := by rw [ψᵤ_eq_normEDS]; exact IsEllSequence'.normEDS
+lemma net_ψᵤ (p q r s) : EllSequence.net ψᵤ p q r s = 0 := by rw [ψᵤ_eq_normEDS]; apply net_normEDS
+
+lemma ψᵤ_ne_zero (h0 : n ≠ 0) : ψᵤ n ≠ 0 := fun h ↦ by
+  rw [ψᵤ, polyToField_apply, map_eq_zero_iff _ (IsFractionRing.injective _ _)] at h
+  replace h := congr(ringEval cusp_equation_one_one $h)
+  rw [ringEval_mk, polyEval_cusp_ψ, map_zero] at h
+  exact h0 h
+
+lemma polyToField_φ_ne_zero : polyToField (curve.φ n) ≠ 0 := fun h ↦ by
+  rw [polyToField_apply, map_eq_zero_iff _ (IsFractionRing.injective _ _)] at h
+  replace h := congr(ringEval cusp_equation_one_one $h)
+  rw [ringEval_mk, polyEval_cusp_φ, map_zero] at h
+  exact one_ne_zero h
+
+lemma polyToField_ψ₂Sq : polyToField (C curve.Ψ₂Sq) = ψᵤ 2 ^ 2 := by
+  rw [← map_pow, ψ_two, ψ₂_sq, map_add, map_mul, polyToField_polynomial, mul_zero, add_zero]
+
+namespace Affine
+
+variable (n)
+
+def smulX : Univ.Field := polyToField (curve.φ n) / (ψᵤ n) ^ 2
+
+def smulY : Univ.Field := polyToField (curve.ωe n) / (ψᵤ n) ^ 3
+variable {n}
+
+@[simp] lemma smulX_zero : smulX 0 = 0 := by simp [smulX, ψᵤ]
+@[simp] lemma smulY_zero : smulY 0 = 0 := by simp [smulY, ψᵤ]
+@[simp] lemma smulX_one : smulX 1 = polyToField (C X) := by simp [smulX, ψᵤ]
+@[simp] lemma smulY_one : smulY 1 = polyToField Y := by simp [smulY, ψᵤ]
+
+lemma smulX_eq (hn : n ≠ 0) :
+    smulX n = smulX 1 - ψᵤ (n + 1) * ψᵤ (n - 1) / (ψᵤ n) ^ 2 := by
+  rw [smulX, smulX_one, φ, map_sub, sub_div, map_mul, map_pow, mul_div_cancel_right₀, map_mul]
+  exact pow_ne_zero _ (ψᵤ_ne_zero hn)
+
+lemma smulX_two : smulX 2 = smulX 1 - ψᵤ 3 / (ψᵤ 2) ^ 2 := by
+  simp [smulX_eq two_ne_zero, ψᵤ]
+
+lemma smulX_sub_smulX (hm : m ≠ 0) (hn : n ≠ 0) :
+    smulX m - smulX n = (ψᵤ (n + m) * ψᵤ (n - m)) / (ψᵤ n * ψᵤ m) ^ 2 := by
+  rw [smulX_eq hm, smulX_eq hn, sub_sub_sub_cancel_left, div_sub_div]
+  · rw [mul_pow]; congr; convert (isEllSequence_ψᵤ n m 1).symm using 1
+    · ring
+    · simp [ψᵤ]
+  all_goals exact pow_ne_zero _ (ψᵤ_ne_zero <| by assumption)
+
+lemma smulX_sub_sub_smulX_add (add_ne : n + m ≠ 0) (sub_ne : n - m ≠ 0) :
+    smulX (n - m) - smulX (n + m) = (ψᵤ (2 * n) * ψᵤ (2 * m)) / (ψᵤ (n + m) * ψᵤ (n - m)) ^ 2 := by
+  rw [smulX_sub_smulX sub_ne add_ne]; ring_nf
+
+lemma smulX_neg : smulX (-n) = smulX n := by simp_rw [smulX, φ_neg, ψᵤ, ψ_neg, ← map_pow, neg_sq]
+
+lemma smulX_ne_zero (h0 : n ≠ 0) : smulX n ≠ 0 :=
+  div_ne_zero polyToField_φ_ne_zero (pow_ne_zero _ <| ψᵤ_ne_zero h0)
+
+lemma smulX_ne_smulX (ne : m ≠ n) (ne_neg : m ≠ -n) : smulX m ≠ smulX n := by
+  obtain rfl | hm := eq_or_ne m 0
+  · rw [smulX_zero]; exact (smulX_ne_zero ne.symm).symm
+  obtain rfl | hn := eq_or_ne n 0
+  · rw [smulX_zero]; exact smulX_ne_zero ne
+  rw [← sub_ne_zero, smulX_sub_smulX hm hn]
+  rw [ne_comm, ← sub_ne_zero] at ne
+  rw [Ne, ← add_eq_zero_iff_eq_neg, add_comm] at ne_neg
+  refine div_ne_zero (mul_ne_zero ?_ ?_) (pow_ne_zero _ <| mul_ne_zero ?_ ?_) <;>
+    apply ψᵤ_ne_zero <;> assumption
+
+lemma smulX_eq_smulX_iff : smulX m = smulX n ↔ m = n ∨ m = -n := by
+  refine ⟨fun h ↦ ?_, ?_⟩
+  · contrapose! h; exact smulX_ne_smulX h.1 h.2
+  · rintro (rfl|rfl); exacts [rfl, smulX_neg]
+
+private lemma smulY_sub_negY_aux {F} [Field F] {a₁ a₃ x y z : F} (h0 : z ≠ 0) :
+    y / z ^ 3 - (-(y / z ^ 3) - a₁ * (x / z ^ 2) - a₃) =
+      z * (2 * y + a₁ * x * z + a₃ * z ^ 3) / z ^ 4 := by
+  field_simp; ring
+
+lemma smulY_sub_negY (h0 : n ≠ 0) :
+    smulY n - pointedCurve.toAffine.negY (smulX n) (smulY n) = ψᵤ (2 * n) / (ψᵤ n) ^ 4 := by
+  simp_rw [Affine.negY, pointedCurve_a₁, pointedCurve_a₃, smulX, smulY, ψᵤ, ← ψc_spec, ← ωe_spec,
+    map_mul, map_add, map_mul, map_pow, map_ofNat]
+  exact smulY_sub_negY_aux (ψᵤ_ne_zero h0)
+
+lemma smulY_one_sub_negY :
+    smulY 1 - pointedCurve.toAffine.negY (smulX 1) (smulY 1) = ψᵤ 2 := by
+  rw [smulY_sub_negY one_ne_zero, mul_one, ψᵤ, ψᵤ, ψ_one, map_one, one_pow, div_one]
+
+lemma smulY_one_ne_negY : smulY 1 ≠ pointedCurve.toAffine.negY (smulX 1) (smulY 1) := by
+  rw [← sub_ne_zero, smulY_one_sub_negY]; exact ψᵤ_ne_zero two_ne_zero
+
+def slopeOne : Univ.Field :=
+  pointedCurve.toAffine.slope (smulX 1) (smulX 1) (smulY 1) (smulY 1)
+
+lemma slopeOne_eq_neg_div : slopeOne = -polyToField curve.polynomialX / ψᵤ 2 := by
+  rw [slopeOne, Affine.slope_of_Y_ne rfl smulY_one_ne_negY, smulY_one_sub_negY, Affine.polynomialX]
+  congr
+  simp [algebraMap_field_eq_comp, Polynomial.algebraMap_apply, map_ofNat]
+
+private lemma addX_smul_one_smul_one_aux {F} [Field F] {a₁ a₂ x dx dy : F} (h0 : dy ≠ 0) :
+    (-dx / dy) ^ 2 + a₁ * (-dx / dy) - a₂ - x - x - x =
+      (dx ^ 2 - a₁ * dx * dy - (3 * x + a₂) * dy ^ 2) / dy ^ 2 := by
+  field_simp; ring
+
+lemma addX_smul_one_smul_one :
+    pointedCurve.toAffine.addX (smulX 1) (smulX 1) slopeOne = smulX 2 := .symm <| by
+  rw [smulX_two, Affine.addX, sub_eq_neg_add, ← eq_sub_iff_add_eq, ← neg_div _ (polyToField _),
+    slopeOne_eq_neg_div, addX_smul_one_smul_one_aux (ψᵤ_ne_zero two_ne_zero)]
+  simp only [map_sub, map_add, map_mul, map_pow, map_ofNat, polyToField_ψ₂Sq, ψᵤ,
+    ψ_two, ψ_three, C_Ψ₃_eq, polyToField_polynomial, pointedCurve_a₁, pointedCurve_a₂, smulX_one]
+  ring
+
+private lemma addY_smul_one_smul_one_aux {F} [Field F] {a₁ a₃ dx dy x y ψ₃ t : F} (h0 : dy ≠ 0) :
+    ((a₁ * dy - dx) * ψ₃ + 0 * t + (-y - (a₁ * x + a₃)) * dy ^ 3) / dy ^ 3 =
+      -(-dx / dy * (x - ψ₃ / dy ^ 2 - x) + y) - a₁ * (x - ψ₃ / dy ^ 2) - a₃ := by
+  field_simp; ring
+
+open EllSequence in
+lemma addY_smul_one_smul_one :
+    pointedCurve.toAffine.addY (smulX 1) (smulX 1) (smulY 1) slopeOne = smulY 2 := .symm <| by
+  rw [smulY, ωe, redInvarDenom_two, one_mul, compl₂EDSAux_two, sub_zero, Affine.addY,
+    Affine.negAddY, addX_smul_one_smul_one, smulX_two, Affine.negY, Affine.negPolynomial,
+    slopeOne_eq_neg_div, ← ψ₂, ← ψ_two, smulX_one, smulY_one, ψᵤ, ψᵤ, ψ_three]
+  simp only [map_add, map_sub, map_mul, map_pow, map_neg, polyToField_polynomial, mul_zero]
+  exact addY_smul_one_smul_one_aux (ψᵤ_ne_zero two_ne_zero)
+
+private lemma smulY_neg_aux {F} [Field F] {a₁ a₃ x y z : F} (hz : z ≠ 0) :
+    (y + a₁ * x * z + a₃ * z ^ 3) / (-z) ^ 3 = -(y / z ^ 3) - a₁ * (x / z ^ 2) - a₃ := by
+  rw [neg_pow]; field_simp; ring
+
+open Polynomial (CC) in
+lemma ωe_neg' : curve.ωe (-n) =
+    curve.ωe n + CC curve.a₁ * curve.φ n * curve.ψ n + CC curve.a₃ * curve.ψ n ^ 3 := by
+  rw [← mul_cancel_left_mem_nonZeroDivisors (mem_nonZeroDivisors_of_ne_zero Poly.two_ne_zero)]
+  simp_rw [left_distrib, two_mul_ωe, ψc_neg, ψ_neg, φ_neg]; ring
+
+lemma smulY_neg (h0 : n ≠ 0) :
+    smulY (-n) = pointedCurve.toAffine.negY (smulX n) (smulY n) := by
+  simp only [Affine.negY, pointedCurve_a₁, pointedCurve_a₃, smulX, smulY, ψ_neg, ωe_neg',
+    map_add, map_neg, map_mul, map_pow, ψᵤ]
+  exact smulY_neg_aux (ψᵤ_ne_zero h0)
+
+private lemma smulX_add_aux {F} [Field F] {m n m₂ n₂ a s : F}
+    (hm : m ≠ 0) (hn : n ≠ 0) (ha : a ≠ 0) (hs : s ≠ 0) :
+    n₂ / n ^ 4 * (m₂ / m ^ 4) / (a * s / (n * m) ^ 2) ^ 2 = n₂ * m₂ / (a * s) ^ 2 := by
+  field_simp
+
+lemma smulX_add (hm : m ≠ 0) (hn : n ≠ 0) (add_ne : n + m ≠ 0) (sub_ne : n - m ≠ 0) :
+    let ψ₂ x y := y - pointedCurve.toAffine.negY x y
+    smulX (n + m) = smulX (n - m) -
+      ψ₂ (smulX n) (smulY n) * ψ₂ (smulX m) (smulY m) / (smulX m - smulX n) ^ 2 := by
+  rw [eq_sub_iff_add_eq, ← eq_sub_iff_add_eq', smulX_sub_sub_smulX_add add_ne sub_ne]
+  simp_rw [smulY_sub_negY hm, smulY_sub_negY hn, smulX_sub_smulX hm hn]
+  apply smulX_add_aux <;> apply ψᵤ_ne_zero <;> assumption
+
+private lemma smulY_add_sub_negY_aux {F} [Field F] {m n m₂ n₂ a s am an : F}
+    (hm : m ≠ 0) (hn : n ≠ 0) (ha : a ≠ 0) (hs : s ≠ 0) :
+    (m₂ / m ^ 4 * (an * m / (a * n) ^ 2) - n₂ / n ^ 4 * (am * n / (a * m) ^ 2))
+      / (a * s / (n * m) ^ 2)
+      = (an * m₂ * n - am * n₂ * m) * a / (s * n * m) / a ^ 4 := by
+  field_simp
+
+lemma smulY_add_sub_negY (hm : m ≠ 0) (hn : n ≠ 0) (add_ne : n + m ≠ 0) (sub_ne : n - m ≠ 0) :
+    let ψ₂ x y := y - pointedCurve.toAffine.negY x y
+    ψ₂ (smulX (n + m)) (smulY (n + m)) =
+      (ψ₂ (smulX m) (smulY m) * (smulX n - smulX (n + m))
+        - ψ₂ (smulX n) (smulY n) * (smulX m - smulX (n + m))) / (smulX m - smulX n) := by
+  simp_rw [smulY_sub_negY add_ne, smulY_sub_negY hm, smulY_sub_negY hn, smulX_sub_smulX hn add_ne,
+    smulX_sub_smulX hm add_ne, smulX_sub_smulX hm hn, add_sub_cancel_left, add_sub_cancel_right]
+  rw [smulY_add_sub_negY_aux]
+  · congr; rw [eq_div_iff]
+    · linear_combination (norm := ring_nf) (EllSequence.net_add_sub_iff _ n m).mp (net_ψᵤ _ _ _ _)
+    apply_rules [mul_ne_zero, ψᵤ_ne_zero]
+  all_goals apply ψᵤ_ne_zero; assumption
+
+open Affine.Point
+
+open WeierstrassCurve.Affine in
+instance : AddGroup (curve⟮Univ.Field⟯) := inferInstance
+
+theorem zsmul_point_eq_smulX_smulY : n ≠ 0 →
+    ∃ h : Affine.Nonsingular curveField (smulX n) (smulY n),
+      n • Affine.point = .some (smulX n) (smulY n) h := by
+  induction n using Int.negInduction with
+  | nat n =>
+    refine n.strong_induction_on fun n ih h0 ↦ ?_
+    obtain _|_|_|n := n
+    · exact (h0 rfl).elim
+    · simp_rw [zero_add, Nat.cast_one, one_zsmul, smulX_one, smulY_one]
+      exact ⟨(pointedCurve.toAffine.equation_iff_nonsingular_of_Δ_ne_zero
+        (by simpa only [pointedCurve, baseChange, map_Δ, map_ne_zero_iff _
+              algebraMap_field_injective] using Δ_curve_ne_zero)).mp equation_point, rfl⟩
+    all_goals obtain ⟨ns, eq⟩ := ih 1 (by omega) one_ne_zero
+    · erw [← addX_smul_one_smul_one, ← addY_smul_one_smul_one, zero_add, add_zsmul _ 1 1, eq]
+      exact ⟨Affine.nonsingular_add ns ns fun h ↦ smulY_one_ne_negY h.2,
+        dite_eq_right fun h ↦ smulY_one_ne_negY h.2⟩
+    set n2 := n + 1 + 1
+    obtain ⟨ns1, eq1⟩ := ih (n + 1) (by omega) (by omega)
+    obtain ⟨ns2, eq2⟩ := ih n2 (by omega) (by omega)
+    have ne : smulX n2 ≠ smulX 1 := smulX_ne_smulX (by omega) (by omega)
+    simp_rw [show (n + 1 : ℕ) = n2 + (-1 : ℤ) by omega, add_zsmul, neg_smul] at eq1
+    let _U := pointedCurve.toAffine
+    erw [eq2, eq, add_of_X_ne ne, Affine.Point.some.injEq] at eq1
+    let L := _U.slope (smulX n2) (smulX 1) (smulY n2) (smulY 1)
+    have X_eq : smulX (n2 + 1 : ℕ) = _U.addX (smulX n2) (smulX 1) L := by
+      rw [Nat.cast_add, Nat.cast_one, smulX_add one_ne_zero (by omega) (by omega) (by omega),
+        Affine.addX_eq_addX_negY_sub _ _ ne, sub_eq_add_neg (n2 : ℤ), ← eq1.1]; rfl
+    have Y_eq : smulY (n2 + 1 : ℕ) = _U.addY (smulX n2) (smulX 1) (smulY n2) L := by
+      rw [← mul_cancel_left_mem_nonZeroDivisors (mem_nonZeroDivisors_of_ne_zero Field.two_ne_zero),
+        ← add_right_cancel_iff (a := _U.a₁ * smulX (n2 + 1 : ℕ) + _U.a₃)]
+      convert smulY_add_sub_negY (n := n2) one_ne_zero (by omega) (by omega) (by omega) using 1
+      · simp_rw [Affine.negY, Nat.cast_add]; simp only [_U]; ring_nf
+      convert _U.addY_sub_negY_addY (smulY n2) (smulY 1) ne using 1
+      · rw [Affine.negY, ← X_eq]; ring
+      · rw [← X_eq]; rfl
+    rw [X_eq, Y_eq, n2.cast_add, add_zsmul, eq, eq2]
+    exact ⟨Affine.nonsingular_add ns2 ns fun h ↦ (ne h.1).elim, add_of_X_ne ne⟩
+  | neg hn n =>
+    rw [neg_ne_zero]; intro h0
+    obtain ⟨ns, eq⟩ := hn n h0
+    simp_rw [smulX_neg, smulY_neg h0, neg_smul, eq, neg_some]
+    exact ⟨(Affine.nonsingular_neg ..).mpr ns, trivial⟩
+
+lemma nonsingular_smulX_smulY (hn : n ≠ 0) : Affine.Nonsingular curveField (smulX n) (smulY n) := by
+  exact (zsmul_point_eq_smulX_smulY hn).1
+
+lemma zsmul_point_ne_zero (h0 : n ≠ 0) : n • Affine.point ≠ 0 := by
+  obtain ⟨ns, eq⟩ := zsmul_point_eq_smulX_smulY h0
+  rw [eq]; exact Affine.Point.some_ne_zero ns
+
+end Affine
+
+namespace Jacobian
+
+open WeierstrassCurve.Jacobian
+
+open Point in
+lemma zsmul_point_ne_zero (h0 : n ≠ 0) : n • Jacobian.point ≠ 0 := by
+  rw [Jacobian.point, ← toAffineAddEquiv_symm_apply, ← map_zsmul (toAffineAddEquiv _).symm,
+    Ne, map_eq_zero_iff _ (toAffineAddEquiv _).symm.injective]
+  exact Affine.zsmul_point_ne_zero h0
+
+lemma zsmul_point_ne (h : m ≠ n) : m • Jacobian.point ≠ n • Jacobian.point := by
+  rw [← sub_ne_zero, sub_eq_add_neg, ← sub_zsmul]
+  exact zsmul_point_ne_zero (sub_ne_zero.mpr h)
+
+lemma point_point : Jacobian.point.point = ⟦![polyToField (C X), polyToField Y, 1]⟧ := rfl
+
+abbrev smulPoly (n : ℤ) : Fin 3 → Poly := ![curve.φ n, curve.ωe n, curve.ψ n]
+
+abbrev smulRing (n : ℤ) : Fin 3 → Univ.Ring := AdjoinRoot.mk _ ∘ smulPoly n
+
+abbrev smulField (n : ℤ) : Fin 3 → Univ.Field := polyToField ∘ smulPoly n
+
+lemma algebraMap_comp_smulRing (n : ℤ) : algebraMap _ _ ∘ smulRing n = smulField n := by
+  ext i; fin_cases i <;> rfl
+
+theorem zsmul_point_eq_smulField : (n • Jacobian.point).point = ⟦smulField n⟧ := by
+  rw [← fin3_def (smulField n), smulField, smulPoly]
+  simp_rw [Function.comp, fin3_def_ext]
+  obtain rfl | hn := eq_or_ne n 0
+  · simp_rw [zero_zsmul, φ_zero, ωe_zero, ψ_zero, map_zero, map_one]; rfl
+  obtain ⟨ns, eq⟩ := Affine.zsmul_point_eq_smulX_smulY hn
+  change (n • (Point.toAffineAddEquiv _).symm Affine.point).point = _
+  rw [← map_zsmul, eq]
+  have := ψᵤ_ne_zero hn
+  refine Quotient.sound ⟨.mk0 _ (inv_ne_zero this), ?_⟩
+  simp_rw [Units.smul_def, Jacobian.smul_fin3]
+  ext i; fin_cases i <;>
+    simp only [Units.val_mk0, Fin.isValue, Matrix.cons_val_zero,
+      Matrix.cons_val_one, Matrix.cons_val_two, Matrix.head_cons, Matrix.tail_cons] <;>
+    field_simp [Affine.smulX, Affine.smulY, this] <;> rfl
+
+lemma dblZ_smulPoly : dblZ curvePoly (smulPoly n) = curve.ψ (2 * n) := by
+  simp_rw [dblZ, smulPoly, negY, fin3_def_ext, curvePoly, baseChange, map, coe_algebraMap_eq_CC]
+  rw [← ψc_spec _ n]; congr; convert curve.ωe_spec n using 1; ring
+
+lemma nonsingular_smulField : Nonsingular curveField (smulField n) := by
+  simpa only [zsmul_point_eq_smulField, Jacobian.nonsingularLift_iff]
+    using (n • Jacobian.point).nonsingular
+
+lemma dblXYZ_smulField : dblXYZ curveField (smulField n) = smulField (2 * n) := by
+  obtain rfl | hn := eq_or_ne n 0
+  · rw [mul_zero]
+    have h0 : smulField (0 : ℤ) = ![1, 1, 0] := by
+      ext i
+      fin_cases i <;> simp [smulField, smulPoly, φ_zero, ωe_zero, ψ_zero]
+    rw [h0, dblXYZ_of_Z_eq_zero equation_zero rfl]
+    simp
+  have h2 : ((2 : ℤ) • (n • Jacobian.point)).point =
+      ⟦dblXYZ curveField (smulField n)⟧ := by
+    rw [two_zsmul, Point.add_point, zsmul_point_eq_smulField, addMap_eq, add_self]
+  refine (equiv_iff_eq_of_Z_eq ?_ (ψᵤ_ne_zero <| mul_ne_zero two_ne_zero hn)).mp
+    (Quotient.exact ?_)
+  · simp only [smulField, smulPoly, fin3_def_ext, Function.comp, ← dblZ_smulPoly, ← map_dblZ]
+    rfl
+  rw [← h2, ← mul_zsmul]
+  exact zsmul_point_eq_smulField
+
+lemma dblXYZ_smulRing : dblXYZ curveRing (smulRing n) = smulRing (2 * n) :=
+  (IsFractionRing.injective _ Univ.Field).comp_left <| by
+    simp_rw [← map_dblXYZ]; exact dblXYZ_smulField
+
+lemma addZ_smulPoly : addZ (smulPoly m) (smulPoly n) = curve.ψ (n + m) * curve.ψ (n - m) := by
+  have hES : IsEllSequence' (WeierstrassCurve.ψ curve) := IsEllSequence'.normEDS
+  simp_rw [addZ, smulPoly, φ]; convert (hES n m 1).symm using 1
+  · simp only [fin3_def_ext]; ring
+  · rw [ψ_one]; ring
+
+lemma ωe_neg_eq_neg_negY : curve.ωe (-n) = -negY curvePoly (smulPoly n) := by
+  simp_rw [Affine.ωe_neg' (n := n), negY, smulPoly, fin3_def_ext, curvePoly, baseChange, map,
+    coe_algebraMap_eq_CC]
+  ring
+
+lemma smulPoly_neg : smulPoly (-n) = (-1 : Poly) • neg curvePoly (smulPoly n) := by
+  simp [smulPoly, ωe_neg_eq_neg_negY, neg, smul_fin3, (show Odd 3 by decide).neg_pow]
+
+lemma smulRing_neg : smulRing (-n) = (-1 : Univ.Ring) • neg curveRing (smulRing n) := by
+  simp_rw [smulRing, smulPoly_neg, Jacobian.comp_smul, ← Jacobian.map_neg, map_neg, map_one]; rfl
+
+lemma smulField_neg : smulField (-n) = (-1 : Univ.Field) • neg curveField (smulField n) := by
+  simp_rw [smulField, smulPoly_neg, Jacobian.comp_smul, ← Jacobian.map_neg, map_neg, map_one]; rfl
+
+lemma smulPoly_zero : smulPoly 0 = ![1, 1, 0] := by simp [smulPoly]
+lemma smulField_zero : smulField 0 = ![1, 1, 0] := by simp [smulField, smulPoly_zero, comp_fin3]
+
+lemma addXYZ_smulField :
+    addXYZ curveField (smulField m) (smulField n) =
+      polyToField (curve.ψ (n - m)) • smulField (n + m) := by
+  obtain rfl | h := eq_or_ne m n
+  · rw [sub_self, ψ_zero, map_zero, smul_fin3,
+      addXYZ_self nonsingular_smulField.1, zero_pow two_ne_zero, zero_pow (by decide)]
+    simp_rw [zero_mul]
+  obtain rfl | ne_neg := eq_or_ne n (-m)
+  · rw [← one_smul (M := Univ.Field) (smulField m), smulField_neg, neg_add_cancel,
+      addXYZ_smul, one_mul, neg_one_sq (R := Univ.Field), addXYZ_neg nonsingular_smulField.1,
+      one_smul, ← neg_add', ← two_mul, ψ_neg, map_neg, ← dblZ_smulPoly, ← map_dblZ, smulField_zero]
+    rfl
+  have hne : ¬ smulField m ≈ smulField n := fun heq ↦ zsmul_point_ne h <| by
+    rw [Point.ext_iff, zsmul_point_eq_smulField, zsmul_point_eq_smulField]
+    exact Quotient.sound heq
+  have key : (m • Jacobian.point + n • Jacobian.point).point =
+      ⟦addXYZ curveField (smulField m) (smulField n)⟧ := by
+    rw [Point.add_point, zsmul_point_eq_smulField, zsmul_point_eq_smulField, addMap_eq,
+      add_of_not_equiv hne]
+  erw [← equiv_iff_eq_of_Z_eq]
+  · exact Quotient.exact (by
+      rw [smul_eq _ (ψᵤ_ne_zero <| sub_ne_zero_of_ne h.symm).isUnit,
+        ← zsmul_point_eq_smulField, add_comm, add_zsmul, key])
+  · conv_rhs => rw [smulField, comp_fin3, smul_fin3, (fin3_def_ext _ _ _).2.2, mul_comm]
+    simp_rw [addXYZ, fin3_def_ext, ← map_mul, ← addZ_smulPoly, ← map_addZ]
+  · rw [(smul_fin3_ext _ _).2.2]
+    apply mul_ne_zero <;> apply ψᵤ_ne_zero <;> omega
+
+lemma addXYZ_smulRing :
+    addXYZ curveRing (smulRing m) (smulRing n) =
+      AdjoinRoot.mk curve.polynomial (curve.ψ (n - m)) • smulRing (n + m) :=
+  (IsFractionRing.injective Univ.Ring Univ.Field).comp_left <| by
+    simp_rw [← map_addXYZ, Jacobian.comp_smul]; exact addXYZ_smulField
+
+lemma addXYZ_smulField₁ :
+    addXYZ curveField (smulField n) (smulField (n + 1)) = smulField (2 * n + 1) := by
+  rw [addXYZ_smulField, add_sub_cancel_left, ψ_one, map_one, one_smul, two_mul, add_comm, add_assoc]
+
+lemma addXYZ_smulRing₁ :
+    addXYZ curveRing (smulRing n) (smulRing (n + 1)) = smulRing (2 * n + 1) := by
+  rw [addXYZ_smulRing, add_sub_cancel_left, ψ_one, map_one, one_smul, two_mul, add_comm, add_assoc]
+
+end Jacobian
+
+end Univ
+
+variable (x y) in
+abbrev smulEval (n : ℤ) : Fin 3 → R := evalEval x y ∘ ![W.φ n, W.ωe n, W.ψ n]
+
+variable {W} (eqn : W.toAffine.Equation x y)
+
+open Univ Jacobian
+
+lemma ringEval_comp_smulRing (n : ℤ) : ringEval eqn ∘ smulRing n = smulEval W x y n := by
+  conv_rhs => rw [smulEval, ← W.map_specialize, map_φ, map_ωe, map_ψ, ← coe_mapRingHom,
+    ← Jacobian.comp_fin3, ← Function.comp_assoc, ← smulPoly, ← coe_evalEvalRingHom,
+    ← RingHom.coe_comp, ← eval₂RingHom_eval₂RingHom]
+  rw [smulRing, ← Function.comp_assoc, ← RingHom.coe_comp, ringEval_comp_mk, polyEval]
+
+lemma ringEval_ψ (n : ℤ) :
+    ringEval eqn (AdjoinRoot.mk _ <| curve.ψ n) = evalEval x y (W.ψ n) :=
+  congr_fun (ringEval_comp_smulRing eqn n) 2
+
+include eqn in
+lemma dblXYZ_smulEval (n : ℤ) : dblXYZ W (smulEval W x y n) = smulEval W x y (2 * n) := by
+  simp_rw [← ringEval_comp_smulRing eqn, ← dblXYZ_smulRing, ← map_dblXYZ, curveRing_map_ringEval]
+
+include eqn in
+lemma addXYZ_smulEval (m n : ℤ) :
+    addXYZ W (smulEval W x y m) (smulEval W x y n) =
+      evalEval x y (W.ψ (n - m)) • smulEval W x y (n + m) := by
+  simp_rw [← ringEval_comp_smulRing eqn, ← ringEval_ψ eqn]
+  rw [← Jacobian.comp_smul, ← addXYZ_smulRing, ← map_addXYZ]
+  simp_rw [curveRing_map_ringEval]
+
+include eqn in
+lemma addXYZ_smulEval₁ (n : ℤ) :
+    addXYZ W (smulEval W x y n) (smulEval W x y (n + 1)) = smulEval W x y (2 * n + 1) := by
+  simp_rw [← ringEval_comp_smulRing eqn, ← addXYZ_smulRing₁, ← map_addXYZ, curveRing_map_ringEval]
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+open Univ
+
+theorem zsmul_eq_smulEval {x y : F} (h : Affine.Nonsingular W x y) (n : ℤ) :
+    (n • Point.fromAffine (Affine.Point.some x y h)).point = ⟦smulEval W x y n⟧ := by
+  have add_point_eq : ∀ (P Q : Jacobian.Point W) (P' Q' : Fin 3 → F),
+      P.point = ⟦P'⟧ → Q.point = ⟦Q'⟧ → (P + Q).point = ⟦Jacobian.add W P' Q'⟧ := by
+    intro P Q P' Q' hP hQ
+    rw [Point.add_point, hP, hQ, addMap_eq]
+  have two_zsmul_point : ∀ (P : Jacobian.Point W) (P' : Fin 3 → F), P.point = ⟦P'⟧ →
+      (2 • P).point = ⟦dblXYZ W P'⟧ := by
+    intro P P' hP
+    rw [two_smul, add_point_eq P P P' P' hP hP, Jacobian.add_self]
+  have add_point_of_ne : ∀ (P Q : Jacobian.Point W) (P' Q' : Fin 3 → F), P.point = ⟦P'⟧ →
+      Q.point = ⟦Q'⟧ → P ≠ Q → (P + Q).point = ⟦addXYZ W P' Q'⟧ := by
+    intro P Q P' Q' hP hQ ne
+    rw [add_point_eq P Q P' Q' hP hQ, Jacobian.add_of_not_equiv fun h' ↦
+      ne (Point.ext <| hP.trans <| (Quotient.sound h').trans hQ.symm)]
+  induction n using Int.negInduction with
+  | nat n =>
+    refine n.strong_induction_on fun n ih ↦ ?_
+    obtain _|_|n := n
+    · rw [Nat.cast_zero, zero_smul, smulEval, comp_fin3]; congrm(⟦?_⟧); simp [evalEval]
+    · rw [Nat.cast_one, one_smul, smulEval, comp_fin3]; congrm(⟦?_⟧); simp [evalEval]
+    obtain ⟨n, rfl|rfl⟩ := n.even_or_odd'
+    · rw [add_assoc, ← two_mul, ← left_distrib, Nat.cast_mul, mul_smul, natCast_zsmul,
+        two_zsmul_point _ _ (ih _ <| by omega), dblXYZ_smulEval h.1]; rfl
+    · rw [show 2 * n + 1 + 1 + 1 = (n + 1) + (n + 1 + 1) by omega, Nat.cast_add, add_smul,
+        add_point_of_ne _ _ _ _ (ih _ <| by omega) (ih _ <| by omega), Nat.cast_add (n + 1),
+        Nat.cast_one, addXYZ_smulEval₁ h.1, ← add_assoc, two_mul]
+      simp_rw [Nat.cast_add]
+      rw [ne_comm, ← sub_ne_zero, ← sub_smul, add_sub_cancel_left, Nat.cast_one, one_smul]
+      apply Point.fromAffine_some_ne_zero
+  | neg hn n =>
+    simp_rw [_root_.neg_smul, Point.neg_point, hn, eq_comm]
+    refine Quotient.sound ⟨-1, ?_⟩
+    simp_rw [← ringEval_comp_smulRing h.1, smulRing_neg, Jacobian.comp_smul, ← Jacobian.map_neg,
+      curveRing_map_ringEval, map_neg, map_one]
+    rfl
+
+end
+
+end WeierstrassCurve
+
+end PortEllSequenceZSMul
+
+section PortEllSequenceAffineBridge
+
+open Polynomial
+open scoped Polynomial.Bivariate
+
+namespace WeierstrassCurve
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+omit [DecidableEq F] in
+theorem evalEval_ψ_sq {x y : F} (h : W.toAffine.Equation x y) (n : ℤ) :
+    ((W.ψ n).evalEval x y) ^ 2 = (W.ΨSq n).eval x := by
+  have h0 : W.toAffine.polynomial.eval₂ (evalRingHom x) y = 0 := by
+    rw [eval₂_evalRingHom]; exact h
+  let e : W.toAffine.CoordinateRing →+* F := AdjoinRoot.lift (evalRingHom x) y h0
+  have he : ∀ p : F[X][Y], e (Affine.CoordinateRing.mk W p) = p.evalEval x y := fun p ↦ by
+    change AdjoinRoot.lift (evalRingHom x) y h0 (AdjoinRoot.mk _ p) = _
+    rw [AdjoinRoot.lift_mk, eval₂_evalRingHom]
+  calc ((W.ψ n).evalEval x y) ^ 2
+      = e (Affine.CoordinateRing.mk W (W.ψ n)) ^ 2 := by rw [he]
+    _ = e (Affine.CoordinateRing.mk W (W.ψ n) ^ 2) := (map_pow e _ 2).symm
+    _ = e (Affine.CoordinateRing.mk W (C (W.ΨSq n))) := by
+        rw [Affine.CoordinateRing.mk_ψ, Affine.CoordinateRing.mk_Ψ_sq]
+    _ = (C (W.ΨSq n)).evalEval x y := he _
+    _ = (W.ΨSq n).eval x := evalEval_C x y _
+
+omit [DecidableEq F] in
+theorem evalEval_φ {x y : F} (h : W.toAffine.Equation x y) (n : ℤ) :
+    (W.φ n).evalEval x y = (W.Φ n).eval x := by
+  obtain ⟨p, hp⟩ := AdjoinRoot.mk_eq_mk.mp (Affine.CoordinateRing.mk_φ W n)
+  have h0 : (W.toAffine.polynomial).evalEval x y = 0 := h
+  have h1 := congrArg (evalEval x y) hp
+  rw [evalEval_sub, evalEval_mul, h0, zero_mul, sub_eq_zero, evalEval_C] at h1
+  exact h1
+
+theorem smul_eq_zero_iff_evalEval_ψ {x y : F} (h : W.toAffine.Nonsingular x y) (n : ℤ) :
+    n • (Affine.Point.some x y h) = 0 ↔ (W.ψ n).evalEval x y = 0 := by
+  have key := zsmul_eq_smulEval (W := W) h n
+  have hQns := (n • Jacobian.Point.fromAffine (Affine.Point.some x y h)).nonsingular
+  rw [key] at hQns
+  calc n • (Affine.Point.some x y h) = 0
+      ↔ (Jacobian.Point.toAffineAddEquiv W).symm (n • Affine.Point.some x y h) =
+        (Jacobian.Point.toAffineAddEquiv W).symm 0 := (AddEquiv.injective _).eq_iff.symm
+    _ ↔ n • Jacobian.Point.fromAffine (Affine.Point.some x y h) = 0 := by
+        rw [map_zsmul, map_zero, Jacobian.Point.toAffineAddEquiv_symm_apply]
+    _ ↔ (⟦smulEval W x y n⟧ : Jacobian.PointClass F) = ⟦![1, 1, 0]⟧ := by
+        rw [Jacobian.Point.ext_iff, key, Jacobian.Point.zero_point]
+    _ ↔ (W.ψ n).evalEval x y = 0 := by
+        constructor
+        · intro heq
+          have hz := (Jacobian.Z_eq_zero_of_equiv (Quotient.eq.mp heq)).mpr rfl
+          simpa only [smulEval, Function.comp_apply, Matrix.cons_val_two, Matrix.tail_cons,
+            Matrix.head_cons] using hz
+        · intro hz
+          refine Quotient.eq.mpr (Jacobian.equiv_zero_of_Z_eq_zero
+            ((Jacobian.nonsingularLift_iff _).mp hQns) ?_)
+          simpa only [smulEval, Function.comp_apply, Matrix.cons_val_two, Matrix.tail_cons,
+            Matrix.head_cons] using hz
+
+end WeierstrassCurve
+
+end PortEllSequenceAffineBridge
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_FullKernelQuotient.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_FullKernelQuotient.lean
new file mode 100644
index 0000000000..a426cb0aef
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_FullKernelQuotient.lean
@@ -0,0 +1,204 @@
+/-
+Based on Prove2Me node WeierstrassCurve_FullKernelQuotient
+(1dc208c5-b2fb-5ab7-b488-cdd571f9c197) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_OddOrderSummingSet
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluQuotientOfSums
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluOrderTwo
+
+/-!
+# Vélu quotient by the full kernel of a point
+
+Definition: `WeierstrassCurve_FullKernelQuotient` (`1dc208c5-b2fb-5ab7-b488-cdd571f9c197`), by
+Claude, 2026-09-05.
+
+Let $W$ be a Weierstrass curve over a field $F$ and $Q$ a point of the associated affine curve. For
+$N : \mathbb{N}$, [`WeierstrassCurve.fullKernelQuotient W Q
+N`](../def/WeierstrassCurve_FullKernelQuotient.html#L9) is the Weierstrass curve obtained from $W$
+by `veluQuotientOfSums` applied to the two sums taken over the finite set `oddOrderSummingSet W Q (N
+- 1)` — the set of coordinate pairs $(x,y)$ of the multiples $Q, 2Q, \dots, (N-1)Q$, each pair
+occurring once, with the point at infinity recorded as $(0,0)$: the first sum is $\sum_P
+g_x(x_P,y_P)$ and the second is $\sum_P\bigl(x_P g_x(x_P,y_P) - y_P g_y(x_P,y_P)\bigr)$, where
+$g_x(x,y) = 3x^2 + 2a_2x + a_4 - a_1y$ and $g_y(x,y) = -(2y + a_1x + a_3)$. Thus $a_1,a_2,a_3$ are
+unchanged while $a_4$ and $a_6$ are decreased by $5t$ and by $b_2 t + 7w$ for those two sums $t,w$;
+the construction is a curve in a fixed Weierstrass presentation, not an isogeny.
+
+The arithmetic content is the identification of this one-sided sum with Vélu's symmetric one. Two
+polynomial identities show that $g_x(x,y) + g_x(x, -y-a_1x-a_3)$ equals $t_P = 2g_x - a_1g_y$ and
+that the corresponding pair of asymmetric weights sums to $w_P = g_y^2 + x\,t_P$. When $Q$ has exact
+additive order $2n+1$, the set of pairs for $Q,\dots,2nQ$ is the disjoint union of the pairs for
+$Q,\dots,nQ$ and their images under $(x,y) \mapsto (x, -y-a_1x-a_3)$, whence the two sums equal
+`veluTSum` and `veluWSum` of the half-system, and $\mathrm{fullKernelQuotient}(W,Q,2n+1) =
+\mathrm{veluQuotient}(W, S_n(Q))$. Supplementary cases: for $N = 1$ the sums are empty and the value
+is $W$; for $N = 2$ at a nonsingular point $(x,y)$ with $g_y(x,y) = 0$ the value is the order-two
+quotient `veluQuotient2 W x y`.
+
+**Relation to Mathlib.** Mathlib supplies `WeierstrassCurve` and its affine points; the Vélu data
+(`veluGx`, `veluGy`, `veluT`, `veluW`, `veluTSum`, `veluWSum`, `veluQuotient`, `veluQuotient2`), the
+coordinate map `coordsOrZero` and the summing sets are the project's own definitions.
+
+**Where it is used.** These constructions give an explicit Weierstrass model for the quotient of a
+curve by the cyclic subgroup generated by a torsion point, indexed either by a half-system of
+multiples or by the whole punctured kernel, and so provide the explicit isogenous curves used in the
+elliptic-curve part of the argument.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace WeierstrassCurve
+
+def fullKernelQuotient {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+    (Q : W.toAffine.Point) (N : ℕ) : WeierstrassCurve F :=
+  W.veluQuotientOfSums
+    (∑ P ∈ W.oddOrderSummingSet Q (N - 1), W.veluGx P.1 P.2)
+    (∑ P ∈ W.oddOrderSummingSet Q (N - 1),
+      (P.1 * W.veluGx P.1 P.2 - P.2 * W.veluGy P.1 P.2))
+
+theorem veluGx_add_veluGx_negY {R : Type*} [CommRing R] (W : WeierstrassCurve R) (x y : R) :
+    W.veluGx x y + W.veluGx x (W.toAffine.negY x y) = W.veluT x y := by
+  simp only [veluGx, veluGy, veluT, Affine.negY]
+  ring
+
+theorem asymWeight_add_asymWeight_negY {R : Type*} [CommRing R] (W : WeierstrassCurve R) (x y : R) :
+    (x * W.veluGx x y - y * W.veluGy x y) +
+        (x * W.veluGx x (W.toAffine.negY x y) -
+          W.toAffine.negY x y * W.veluGy x (W.toAffine.negY x y)) =
+      W.veluW x y := by
+  simp only [veluGx, veluGy, veluT, veluW, veluU, Affine.negY]
+  ring
+
+theorem coordsOrZero_neg {R : Type*} [CommRing R] {W : WeierstrassCurve R} (P : W.toAffine.Point)
+    (hP : P ≠ 0) :
+    (-P).coordsOrZero = (P.coordsOrZero.1, W.toAffine.negY P.coordsOrZero.1 P.coordsOrZero.2) := by
+  rcases P with _ | ⟨x, y, h⟩
+  · exact absurd rfl hP
+  · rfl
+
+theorem eq_of_coordsOrZero_eq {R : Type*} [CommRing R] {W : WeierstrassCurve R}
+    {P P' : W.toAffine.Point}
+    (hP : P ≠ 0) (hP' : P' ≠ 0) (h : P.coordsOrZero = P'.coordsOrZero) : P = P' := by
+  rcases P with _ | ⟨x, y, hx⟩
+  · exact absurd rfl hP
+  rcases P' with _ | ⟨x', y', hx'⟩
+  · exact absurd rfl hP'
+  simp only [Affine.Point.coordsOrZero_some, Prod.mk.injEq] at h
+  obtain ⟨rfl, rfl⟩ := h
+  rfl
+
+theorem negPair_injective {R : Type*} [CommRing R] (W : WeierstrassCurve R) :
+    Function.Injective (fun P : R × R => (P.1, W.toAffine.negY P.1 P.2)) := by
+  intro P P' h
+  simp only [Prod.mk.injEq] at h
+  obtain ⟨h1, h2⟩ := h
+  have h3 := congrArg (W.toAffine.negY P.1) h2
+  rw [Affine.negY_negY, h1, Affine.negY_negY] at h3
+  exact Prod.ext h1 h3
+
+theorem oddOrderSummingSet_two_mul {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+    (Q : W.toAffine.Point) (n : ℕ) (hQ : addOrderOf Q = 2 * n + 1) :
+    W.oddOrderSummingSet Q (2 * n) =
+      W.oddOrderSummingSet Q n ∪
+        (W.oddOrderSummingSet Q n).image (fun P => (P.1, W.toAffine.negY P.1 P.2)) := by
+  have hrefl : ∀ k, 1 ≤ k → k ≤ 2 * n → (2 * n + 1 - k) • Q = -(k • Q) := fun k hk1 hk2 => by
+    refine eq_neg_of_add_eq_zero_left ?_
+    rw [← add_nsmul, Nat.sub_add_cancel (by omega), ← hQ, addOrderOf_nsmul_eq_zero]
+  have hne : ∀ k, 1 ≤ k → k ≤ 2 * n → k • Q ≠ 0 := fun k hk1 hk2 =>
+    nsmul_ne_zero_of_lt_addOrderOf (by omega) (by rw [hQ]; omega)
+  ext P
+  simp only [Finset.mem_union, Finset.mem_image, mem_oddOrderSummingSet]
+  constructor
+  · rintro ⟨k, hk1, hk2, rfl⟩
+    by_cases hkn : k ≤ n
+    · exact Or.inl ⟨k, hk1, hkn, rfl⟩
+    · refine Or.inr ⟨((2 * n + 1 - k) • Q).coordsOrZero, ⟨2 * n + 1 - k, by
+      omega, by
+        omega, rfl⟩, ?_⟩
+      rw [hrefl k hk1 hk2, coordsOrZero_neg _ (hne k hk1 hk2), Affine.negY_negY]
+  · rintro (⟨k, hk1, hk2, rfl⟩ | ⟨P', ⟨k, hk1, hk2, rfl⟩, rfl⟩)
+    · exact ⟨k, hk1, by omega, rfl⟩
+    · refine ⟨2 * n + 1 - k, by omega, by omega, ?_⟩
+      rw [hrefl k hk1 (by omega), coordsOrZero_neg _ (hne k hk1 (by omega))]
+
+theorem disjoint_oddOrderSummingSet_image_neg {F : Type*} [Field F] [DecidableEq F]
+    (W : WeierstrassCurve F)
+    (Q : W.toAffine.Point) (n : ℕ) (hQ : addOrderOf Q = 2 * n + 1) :
+    Disjoint (W.oddOrderSummingSet Q n)
+      ((W.oddOrderSummingSet Q n).image (fun P => (P.1, W.toAffine.negY P.1 P.2))) := by
+  have hne : ∀ k, 1 ≤ k → k ≤ n → k • Q ≠ 0 := fun k hk1 hk2 =>
+    nsmul_ne_zero_of_lt_addOrderOf (by omega) (by rw [hQ]; omega)
+  rw [Finset.disjoint_left]
+  rintro P hP hP'
+  rw [mem_oddOrderSummingSet] at hP
+  simp only [Finset.mem_image, mem_oddOrderSummingSet] at hP'
+  obtain ⟨k, hk1, hk2, rfl⟩ := hP
+  obtain ⟨P', ⟨l, hl1, hl2, rfl⟩, h⟩ := hP'
+  rw [← coordsOrZero_neg _ (hne l hl1 hl2)] at h
+  have hkl : -(l • Q) = k • Q :=
+    eq_of_coordsOrZero_eq (neg_ne_zero.mpr (hne l hl1 hl2)) (hne k hk1 hk2) h
+  have h0 : (k + l) • Q = 0 := by rw [add_nsmul, ← hkl, neg_add_cancel]
+  have hdvd : addOrderOf Q ∣ k + l := addOrderOf_dvd_iff_nsmul_eq_zero.mpr h0
+  rw [hQ] at hdvd
+  exact absurd (Nat.le_of_dvd (by omega) hdvd) (by omega)
+
+theorem sum_oddOrderSummingSet_two_mul {F : Type*} [Field F] [DecidableEq F]
+    (W : WeierstrassCurve F)
+    (Q : W.toAffine.Point) (n : ℕ) (hQ : addOrderOf Q = 2 * n + 1) (f : F × F → F) :
+    ∑ P ∈ W.oddOrderSummingSet Q (2 * n), f P =
+      ∑ P ∈ W.oddOrderSummingSet Q n, (f P + f (P.1, W.toAffine.negY P.1 P.2)) := by
+  rw [oddOrderSummingSet_two_mul W Q n hQ, Finset.sum_union (disjoint_oddOrderSummingSet_image_neg W
+    Q n hQ),
+    Finset.sum_image (fun P _ P' _ h => negPair_injective W h), Finset.sum_add_distrib]
+
+theorem sum_veluGx_oddOrderSummingSet_two_mul {F : Type*} [Field F] [DecidableEq F]
+    (W : WeierstrassCurve F)
+    (Q : W.toAffine.Point) (n : ℕ) (hQ : addOrderOf Q = 2 * n + 1) :
+    ∑ P ∈ W.oddOrderSummingSet Q (2 * n), W.veluGx P.1 P.2 = W.veluTSum (W.oddOrderSummingSet Q n)
+      := by
+  rw [sum_oddOrderSummingSet_two_mul W Q n hQ (fun P => W.veluGx P.1 P.2), veluTSum]
+  exact Finset.sum_congr rfl fun P _ => veluGx_add_veluGx_negY W P.1 P.2
+
+theorem sum_asymWeight_oddOrderSummingSet_two_mul {F : Type*} [Field F] [DecidableEq F]
+    (W : WeierstrassCurve F) (Q : W.toAffine.Point) (n : ℕ) (hQ : addOrderOf Q = 2 * n + 1) :
+    ∑ P ∈ W.oddOrderSummingSet Q (2 * n), (P.1 * W.veluGx P.1 P.2 - P.2 * W.veluGy P.1 P.2) =
+      W.veluWSum (W.oddOrderSummingSet Q n) := by
+  rw [sum_oddOrderSummingSet_two_mul W Q n hQ (fun P => P.1 * W.veluGx P.1 P.2 - P.2 * W.veluGy P.1
+    P.2),
+    veluWSum]
+  exact Finset.sum_congr rfl fun P _ => asymWeight_add_asymWeight_negY W P.1 P.2
+
+theorem fullKernelQuotient_eq_veluQuotient_oddOrderSummingSet {F : Type*} [Field F] [DecidableEq F]
+    (W : WeierstrassCurve F) (Q : W.toAffine.Point) (n : ℕ) (hQ : addOrderOf Q = 2 * n + 1) :
+    W.fullKernelQuotient Q (2 * n + 1) = W.veluQuotient (W.oddOrderSummingSet Q n) := by
+  rw [fullKernelQuotient, Nat.add_sub_cancel, sum_veluGx_oddOrderSummingSet_two_mul W Q n hQ,
+    sum_asymWeight_oddOrderSummingSet_two_mul W Q n hQ]
+  exact (W.veluQuotient_eq_veluQuotientOfSums _).symm
+
+theorem fullKernelQuotient_one {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+    (Q : W.toAffine.Point) : W.fullKernelQuotient Q 1 = W := by
+  have h : W.oddOrderSummingSet Q (1 - 1) = ∅ := by
+    simp [oddOrderSummingSet]
+  rw [fullKernelQuotient, h, Finset.sum_empty, Finset.sum_empty]
+  ext <;> simp [veluQuotientOfSums]
+
+theorem fullKernelQuotient_two {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+    {x y : F}
+    (h : W.toAffine.Nonsingular x y) (hgy : W.veluGy x y = 0) :
+    W.fullKernelQuotient (.some x y h) 2 = W.veluQuotient2 x y := by
+  have hS : W.oddOrderSummingSet (.some x y h) (2 - 1) = {(x, y)} := by
+    simp [oddOrderSummingSet]
+  rw [fullKernelQuotient, hS]
+  simp only [Finset.sum_singleton]
+  rw [hgy, mul_zero, sub_zero]
+  rfl
+
+end WeierstrassCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_FunctionFieldQuadratic.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_FunctionFieldQuadratic.lean
new file mode 100644
index 0000000000..fa583965af
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_FunctionFieldQuadratic.lean
@@ -0,0 +1,204 @@
+/-
+Based on Prove2Me node WeierstrassCurve_FunctionFieldQuadratic
+(4002f263-afc3-568e-bdcd-dc58468b3d3a) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import Mathlib.RingTheory.Henselian
+public import Mathlib.RingTheory.RegularLocalRing.Defs
+public import Mathlib.RingTheory.SimpleRing.Principal
+
+/-!
+# Function field of a Weierstrass curve over F(x)
+
+Definition: `WeierstrassCurve_FunctionFieldQuadratic` (`4002f263-afc3-568e-bdcd-dc58468b3d3a`), by
+Claude, 2026-09-05.
+
+Fix a field $F$ and an affine Weierstrass curve $W : y^2 + a_1xy + a_3y = x^3 + a_2x^2 + a_4x + a_6$
+over $F$, with its coordinate ring `W.CoordinateRing` $= F[x,y]/(W)$ and function field
+`W.FunctionField`, the fraction field of that ring. The module sets up the tower $F \subset F(x)
+\subset F(W)$ and exhibits $F(W)$ as generated by a root of a monic quadratic over $F(x)$. First,
+`polyToFunctionField W : F[X] →+* W.FunctionField` is the composite of the structure maps $F[X] \to$
+`W.CoordinateRing` $\to$ `W.FunctionField`; it is shown to be injective (using that the coordinate
+ring is free over $F[X]$ on the basis $\{1, y\}$), to send a constant $C c$ to the image of $c$, to
+send nonzero polynomials to nonzero elements, and to agree with the canonical algebra map $F[X] \to$
+`W.FunctionField`; auxiliary lemmas compute the images of $p \cdot 1$ and $p \cdot 1 + q\,y$ in
+terms of it, and record that the image of $y$ is nonzero. Since $F[X] \to F(W)$ is injective and
+$F(x) =$ `RatFunc F` is the fraction field of $F[X]$, it extends to `ratFuncToFunctionField W :
+RatFunc F →+* W.FunctionField`, which is installed as an $F(x)$-algebra structure on $F(W)$
+compatible with the $F[X]$- and $F$-algebra structures. Next, `yCoord W` is the image of $y$ in
+$F(W)$, and `weierstrassQuadratic W` is the polynomial $T^2 + \bigl((a_1x+a_3)T -
+(x^3+a_2x^2+a_4x+a_6)\bigr)$ over $F(x)$, whose coefficients are images of polynomials in $x$. The
+remaining results show that the non-leading part has degree $< 2$, hence that this quadratic is
+monic, that `yCoord W` satisfies the Weierstrass relation $y^2 = (x^3+a_2x^2+a_4x+a_6) -
+(a_1x+a_3)y$ in $F(W)$, that it is therefore a root of `weierstrassQuadratic W`, and consequently
+that `yCoord W` is integral over $F(x)$.
+
+**Relation to Mathlib.** Everything is built directly on Mathlib's
+`WeierstrassCurve.Affine.CoordinateRing` and `WeierstrassCurve.Affine.FunctionField`, including the
+$F[X]$-basis $\{1, y\}$ of the coordinate ring. The $F(x)$-algebra structure on the function field,
+the associated scalar-tower instances, and the coordinate function `yCoord` with its quadratic
+equation over $F(x)$ are additions to that Mathlib material.
+
+**Where it is used.** These definitions are the basic dictionary for working with rational functions
+on a Weierstrass curve: they present $F(W)$ as a degree-two extension of the rational function field
+$F(x)$ generated by $y$. Downstream they support the study of principal divisors on $F(W)$, the
+place at infinity, and function-field comparisons between curves linked by isogenies, within the
+elliptic-curve input to the proof.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+noncomputable section DL_stragglingly
+
+open Polynomial
+
+open scoped Polynomial.Bivariate
+
+namespace WeierstrassCurve.Affine
+
+open CoordinateRing
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+def polyToFunctionField (W : Affine F) : F[X] →+* W.FunctionField :=
+  (algebraMap W.CoordinateRing W.FunctionField).comp (algebraMap F[X] W.CoordinateRing)
+
+theorem polyToFunctionField_apply (p : F[X]) :
+    polyToFunctionField W p
+      = algebraMap W.CoordinateRing W.FunctionField (algebraMap F[X] W.CoordinateRing p) := rfl
+
+theorem algebraMap_smul_one (p : F[X]) :
+    algebraMap W.CoordinateRing W.FunctionField (p • (1 : W.CoordinateRing))
+      = polyToFunctionField W p := by
+  rw [polyToFunctionField_apply, smul, mul_one]
+  rfl
+
+theorem polyToFunctionField_injective : Function.Injective (polyToFunctionField W) := by
+  intro p q h
+  rw [polyToFunctionField_apply, polyToFunctionField_apply] at h
+  have h2 := IsFractionRing.injective W.CoordinateRing W.FunctionField h
+  have h0 : (p - q) • (1 : W.CoordinateRing) + (0 : F[X]) • CoordinateRing.mk W Y = 0 := by
+    rw [zero_smul, add_zero, sub_smul, ← Algebra.algebraMap_eq_smul_one,
+      ← Algebra.algebraMap_eq_smul_one, h2, sub_self]
+  exact sub_eq_zero.mp (smul_basis_eq_zero h0).1
+
+theorem polyToFunctionField_C (c : F) :
+    polyToFunctionField W (C c) = algebraMap F W.FunctionField c := by
+  rw [polyToFunctionField_apply,
+    show algebraMap F[X] W.CoordinateRing (C c) = algebraMap F W.CoordinateRing c from
+      (IsScalarTower.algebraMap_apply F F[X] W.CoordinateRing c).symm]
+  exact (IsScalarTower.algebraMap_apply F W.CoordinateRing W.FunctionField c).symm
+
+theorem polyToFunctionField_ne_zero {p : F[X]} (hp : p ≠ 0) :
+    polyToFunctionField W p ≠ 0 := by
+  intro h
+  exact hp (polyToFunctionField_injective (by simpa using h))
+
+theorem algebraMap_smul_basis (p q : F[X]) :
+    algebraMap W.CoordinateRing W.FunctionField
+        (p • (1 : W.CoordinateRing) + q • CoordinateRing.mk W Y)
+      = polyToFunctionField W p + polyToFunctionField W q
+          * algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) := by
+  rw [map_add, algebraMap_smul_one, smul, map_mul, polyToFunctionField_apply]
+  rfl
+
+theorem Y_image_ne_zero :
+    algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) ≠ 0 := by
+  have h1 : (CoordinateRing.mk W Y) ≠ 0 := by
+    have h2 := YClass_ne_zero (W' := W) 0
+    simpa [YClass] using h2
+  exact (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr h1
+
+theorem algebraMap_polynomial_eq_polyToFunctionField :
+    algebraMap F[X] W.FunctionField = polyToFunctionField W :=
+  IsScalarTower.algebraMap_eq F[X] W.CoordinateRing W.FunctionField
+
+theorem algebraMap_polynomial_injective :
+    Function.Injective (algebraMap F[X] W.FunctionField) := by
+  rw [algebraMap_polynomial_eq_polyToFunctionField]
+  exact polyToFunctionField_injective
+
+variable (W) in
+def ratFuncToFunctionField : RatFunc F →+* W.FunctionField :=
+  IsFractionRing.lift algebraMap_polynomial_injective
+
+@[simp]
+theorem ratFuncToFunctionField_algebraMap (p : F[X]) :
+    ratFuncToFunctionField W (algebraMap F[X] (RatFunc F) p)
+      = algebraMap F[X] W.FunctionField p :=
+  IsFractionRing.lift_algebraMap algebraMap_polynomial_injective p
+
+instance : Algebra (RatFunc F) W.FunctionField :=
+  (ratFuncToFunctionField W).toAlgebra
+
+instance : IsScalarTower F[X] (RatFunc F) W.FunctionField :=
+  IsScalarTower.of_algebraMap_eq fun p => (ratFuncToFunctionField_algebraMap p).symm
+
+instance : IsScalarTower F (RatFunc F) W.FunctionField := by
+  refine IsScalarTower.of_algebraMap_eq fun c => ?_
+  rw [IsScalarTower.algebraMap_apply F F[X] (RatFunc F) c,
+    ← IsScalarTower.algebraMap_apply F[X] (RatFunc F) W.FunctionField,
+    Polynomial.algebraMap_eq, algebraMap_polynomial_eq_polyToFunctionField]
+  exact (polyToFunctionField_C c).symm
+
+variable (W) in
+def yCoord : W.FunctionField :=
+  algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+
+variable (W) in
+def weierstrassQuadratic : Polynomial (RatFunc F) :=
+  X ^ 2 + (C (algebraMap F[X] (RatFunc F) (C W.a₁ * X + C W.a₃)) * X
+    - C (algebraMap F[X] (RatFunc F) (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆)))
+
+theorem weierstrassQuadratic_sub_degree_lt :
+    (C (algebraMap F[X] (RatFunc F) (C W.a₁ * X + C W.a₃)) * X
+      - C (algebraMap F[X] (RatFunc F)
+        (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆))).degree < ((2 : ℕ) : WithBot ℕ) := by
+  rw [sub_eq_add_neg, ← Polynomial.C_neg]
+  exact lt_of_le_of_lt Polynomial.degree_linear_le (by exact_mod_cast Nat.one_lt_two)
+
+theorem weierstrassQuadratic_monic : (weierstrassQuadratic W).Monic :=
+  monic_X_pow_add weierstrassQuadratic_sub_degree_lt
+
+theorem yCoord_relation :
+    yCoord W * yCoord W
+      = polyToFunctionField W (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆)
+        - polyToFunctionField W (C W.a₁ * X + C W.a₃) * yCoord W := by
+  have h1 := smul_basis_mul_Y (W' := W) 0 1
+  rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at h1
+  have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) h1
+  rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+  exact h2
+
+theorem aeval_yCoord_weierstrassQuadratic :
+    Polynomial.aeval (yCoord W) (weierstrassQuadratic W) = 0 := by
+  have hc : ∀ p : F[X],
+      algebraMap (RatFunc F) W.FunctionField (algebraMap F[X] (RatFunc F) p)
+        = polyToFunctionField W p := fun p => by
+    rw [← IsScalarTower.algebraMap_apply F[X] (RatFunc F) W.FunctionField,
+      algebraMap_polynomial_eq_polyToFunctionField]
+  simp only [weierstrassQuadratic, map_add, map_sub, map_mul, map_pow, Polynomial.aeval_X,
+    Polynomial.aeval_C, hc]
+  rw [sq]
+  have hrel := yCoord_relation (W := W)
+  simp only [map_add, map_mul, map_pow] at hrel ⊢
+  linear_combination hrel
+
+theorem isIntegral_yCoord : _root_.IsIntegral (RatFunc F) (yCoord W) :=
+  ⟨weierstrassQuadratic W, weierstrassQuadratic_monic, by
+    rw [← Polynomial.aeval_def]; exact aeval_yCoord_weierstrassQuadratic⟩
+
+end WeierstrassCurve.Affine
+
+end DL_stragglingly
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_GenusOnePic0.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_GenusOnePic0.lean
new file mode 100644
index 0000000000..3e926d55e1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_GenusOnePic0.lean
@@ -0,0 +1,221 @@
+/-
+Based on Prove2Me node WeierstrassCurve_GenusOnePic0
+(5a1e5b22-326b-5b23-ac01-fa8e3f5a789f) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.RingTheory.SimpleRing.Principal
+
+/-!
+# Abel–Jacobi gate: degree-zero divisor classes versus Weierstrass points
+
+Definition: `WeierstrassCurve_GenusOnePic0` (`5a1e5b22-326b-5b23-ac01-fa8e3f5a789f`), by Claude,
+2026-09-05.
+
+Fix a field $F$ (with decidable equality) and an affine Weierstrass curve $W$ over $F$, and work
+with the function field `W.FunctionField` and with the places, divisors, degree, principal divisors
+and degree-zero class group
+[`AlgebraicCurve.Pic0`](../def/AlgebraicCurve_DivisorClassGroup.html#L223) supplied by the project's
+divisor-class-group module (those notions are the project's own). Two assumptions are packaged as
+typeclasses carrying data or a theorem as fields. `GenusOnePlaceGate W` carries an explicit
+bijection `pointEquivPlace : W.Point ≃ AlgebraicCurve.Place F W.FunctionField` between the points of
+$W$ (with its Mathlib group structure) and the places of the function field, together with the field
+`deg_eq_one` asserting that *every* place has degree $1$; `placeOfPoint` is the forward map of this
+bijection, and the place attached to the origin plays the role of the place at infinity.
+`AbelTheorem W` is a `Prop`-valued class whose single field is Abel's theorem in the form: for every
+divisor $D$ of degree $0$, $D$ is principal if and only if `divisorSum D = 0`.
+
+The remaining declarations are consequences. `degree_eq_sum` says that, all residue degrees being
+$1$, the degree of a divisor is the plain sum of its coefficients. `divisorSum` is the additive
+homomorphism from divisors to `W.Point` sending a single place $v$ with multiplicity $n$ to $n \cdot
+\mathrm{pointEquivPlace}^{-1}(v)$, i.e. the Abel–Jacobi sum $\sum_v n_v P_v$ computed in the group
+law of $W$. For a point $P$, `pointDivisor P` is the degree-zero divisor $(P) - (O)$ and `pointClass
+P` its class in `Pic0`. Given both gates, `divisorSum` descends along the quotient to `pic0ToPoint :
+Pic0 →+ W.Point`, which is shown surjective (using `pointClass`) and injective (using the converse
+direction of Abel's theorem), yielding the additive isomorphism `genusOnePic0Equiv : Pic0 F
+W.FunctionField ≃+ W.Point` with inverse $P \mapsto [(P) - (O)]$; `pointClass_add` records that $P
+\mapsto [(P)-(O)]$ is additive.
+
+**Relation to Mathlib.** `WeierstrassCurve.Affine`, its point group `W.Point` and `W.FunctionField`
+are Mathlib's; the places, divisors, degree, principality and `Pic0` used here come from the
+project's own algebraic-curve divisor module. Mathlib has no Abel–Jacobi identification of this
+kind, and neither the point–place dictionary nor Abel's theorem is proved here: both are hypotheses,
+stated as fields of the classes `GenusOnePlaceGate` and `AbelTheorem`.
+
+**Where it is used.** The isomorphism $\operatorname{Pic}^0(F(W)/F) \simeq W(F)$ provides the
+dictionary between divisor classes on a genus-one curve and points of the associated Weierstrass
+model, used in the parts of the development that compare Jacobians of modular curves with elliptic
+curves and that count points on reductions via the action on degree-zero divisor classes.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public noncomputable section publicSection
+
+open AlgebraicCurve
+
+namespace WeierstrassCurve.Affine
+
+universe u
+
+variable {F : Type u} [Field F]
+
+variable (W : Affine F) in
+class GenusOnePlaceGate : Type u where
+  pointEquivPlace : W.Point ≃ AlgebraicCurve.Place F W.FunctionField
+  deg_eq_one : ∀ v : AlgebraicCurve.Place F W.FunctionField, v.deg = 1
+
+variable {W : Affine F} [GenusOnePlaceGate W]
+
+abbrev pointEquivPlace : W.Point ≃ AlgebraicCurve.Place F W.FunctionField :=
+  GenusOnePlaceGate.pointEquivPlace (W := W)
+
+def placeOfPoint : W.Point → AlgebraicCurve.Place F W.FunctionField :=
+  pointEquivPlace (W := W)
+
+@[simp]
+theorem pointEquivPlace_apply (P : W.Point) :
+    (pointEquivPlace (W := W)) P = placeOfPoint P := rfl
+
+@[simp]
+theorem pointEquivPlace_symm_placeOfPoint (P : W.Point) :
+    (pointEquivPlace (W := W)).symm (placeOfPoint P) = P :=
+  (pointEquivPlace (W := W)).symm_apply_apply P
+
+theorem deg_eq_one (v : AlgebraicCurve.Place F W.FunctionField) : v.deg = 1 :=
+  GenusOnePlaceGate.deg_eq_one v
+
+@[simp]
+theorem deg_placeOfPoint (P : W.Point) : (placeOfPoint (W := W) P).deg = 1 :=
+  deg_eq_one _
+
+theorem degree_eq_sum (D : AlgebraicCurve.Divisor F W.FunctionField) :
+    Divisor.degree D = D.sum fun _ n => n := by
+  rw [Divisor.degree, Finsupp.liftAddHom_apply]
+  exact Finsupp.sum_congr fun v _ => by
+    rw [AddMonoidHom.mulRight_apply, deg_eq_one v, Nat.cast_one, mul_one]
+
+def divisorSum [DecidableEq F] :
+    AlgebraicCurve.Divisor F W.FunctionField →+ W.Point :=
+  Finsupp.liftAddHom fun v => zmultiplesHom W.Point ((pointEquivPlace (W := W)).symm v)
+
+@[simp]
+theorem divisorSum_single [DecidableEq F]
+    (v : AlgebraicCurve.Place F W.FunctionField) (n : ℤ) :
+    divisorSum (Finsupp.single v n) = n • (pointEquivPlace (W := W)).symm v :=
+  Finsupp.liftAddHom_apply_single _ v n
+
+theorem divisorSum_single_placeOfPoint [DecidableEq F]
+    (P : W.Point) (n : ℤ) :
+    divisorSum (Finsupp.single (placeOfPoint P) n) = n • P := by
+  rw [divisorSum_single, pointEquivPlace_symm_placeOfPoint]
+
+def pointDivisor (P : W.Point) : Divisor.degZero (K := F) (F := W.FunctionField) :=
+  ⟨Finsupp.single (placeOfPoint P) 1 - Finsupp.single (placeOfPoint (0 : W.Point)) 1, by
+    rw [Divisor.mem_degZero, map_sub, Divisor.degree_single, Divisor.degree_single,
+      deg_placeOfPoint, deg_placeOfPoint, sub_self]⟩
+
+@[simp]
+theorem coe_pointDivisor (P : W.Point) :
+    (pointDivisor P : AlgebraicCurve.Divisor F W.FunctionField)
+      = Finsupp.single (placeOfPoint P) 1 - Finsupp.single (placeOfPoint (0 : W.Point)) 1 :=
+  rfl
+
+@[simp]
+theorem pointDivisor_zero : pointDivisor (0 : W.Point) = 0 :=
+  Subtype.ext (sub_self _)
+
+theorem divisorSum_pointDivisor [DecidableEq F] (P : W.Point) :
+    divisorSum (pointDivisor P : AlgebraicCurve.Divisor F W.FunctionField) = P := by
+  rw [coe_pointDivisor, map_sub, divisorSum_single_placeOfPoint, divisorSum_single_placeOfPoint,
+    one_smul, one_smul, sub_zero]
+
+def pointClass (P : W.Point) : AlgebraicCurve.Pic0 F W.FunctionField :=
+  Pic0.mk (pointDivisor P)
+
+@[simp]
+theorem pointClass_zero : pointClass (0 : W.Point) = 0 := by
+  rw [pointClass, pointDivisor_zero, Pic0.mk_zero]
+
+variable (W) in
+class AbelTheorem [DecidableEq F] : Prop where
+  isPrincipal_iff_divisorSum_eq_zero :
+    ∀ D : AlgebraicCurve.Divisor F W.FunctionField, Divisor.degree D = 0 →
+      (Divisor.IsPrincipal D ↔ divisorSum D = 0)
+
+section AbelTheorem
+
+variable [DecidableEq F] [AbelTheorem W]
+
+theorem divisorSum_eq_zero_of_isPrincipal {D : AlgebraicCurve.Divisor F W.FunctionField}
+    (h0 : Divisor.degree D = 0) (hD : Divisor.IsPrincipal D) : divisorSum D = 0 :=
+  (AbelTheorem.isPrincipal_iff_divisorSum_eq_zero D h0).mp hD
+
+theorem isPrincipal_of_divisorSum_eq_zero {D : AlgebraicCurve.Divisor F W.FunctionField}
+    (h0 : Divisor.degree D = 0) (hD : divisorSum D = 0) : Divisor.IsPrincipal D :=
+  (AbelTheorem.isPrincipal_iff_divisorSum_eq_zero D h0).mpr hD
+
+def pic0ToPoint : AlgebraicCurve.Pic0 F W.FunctionField →+ W.Point :=
+  QuotientAddGroup.lift _
+    (divisorSum.comp (Divisor.degZero (K := F) (F := W.FunctionField)).subtype)
+    (by
+      rintro ⟨D, hD0⟩ hD
+      rw [AddSubgroup.mem_addSubgroupOf] at hD
+      rw [AddMonoidHom.mem_ker, AddMonoidHom.comp_apply, AddSubgroup.coe_subtype]
+      exact divisorSum_eq_zero_of_isPrincipal (Divisor.mem_degZero.mp hD0)
+        (Divisor.mem_principal.mp hD))
+
+@[simp]
+theorem pic0ToPoint_mk (D : Divisor.degZero (K := F) (F := W.FunctionField)) :
+    pic0ToPoint (Pic0.mk D) = divisorSum (D : AlgebraicCurve.Divisor F W.FunctionField) :=
+  rfl
+
+@[simp]
+theorem pic0ToPoint_pointClass (P : W.Point) : pic0ToPoint (pointClass P) = P := by
+  rw [pointClass, pic0ToPoint_mk, divisorSum_pointDivisor]
+
+theorem pic0ToPoint_surjective : Function.Surjective (pic0ToPoint (W := W)) := fun P =>
+  ⟨pointClass P, pic0ToPoint_pointClass P⟩
+
+theorem pic0ToPoint_injective : Function.Injective (pic0ToPoint (W := W)) := by
+  rw [injective_iff_map_eq_zero]
+  intro c
+  induction c using QuotientAddGroup.induction_on with
+  | H D =>
+    intro hD
+    obtain ⟨D, hD0⟩ := D
+    replace hD : divisorSum D = 0 := hD
+    rw [QuotientAddGroup.eq_zero_iff, AddSubgroup.mem_addSubgroupOf]
+    exact Divisor.mem_principal.mpr
+      (isPrincipal_of_divisorSum_eq_zero (Divisor.mem_degZero.mp hD0) hD)
+
+variable (W) in
+def genusOnePic0Equiv : AlgebraicCurve.Pic0 F W.FunctionField ≃+ W.Point :=
+  AddEquiv.ofBijective pic0ToPoint ⟨pic0ToPoint_injective, pic0ToPoint_surjective⟩
+
+@[simp]
+theorem genusOnePic0Equiv_apply (c : AlgebraicCurve.Pic0 F W.FunctionField) :
+    genusOnePic0Equiv W c = pic0ToPoint c := rfl
+
+@[simp]
+theorem genusOnePic0Equiv_symm_apply (P : W.Point) :
+    (genusOnePic0Equiv W).symm P = pointClass P :=
+  (genusOnePic0Equiv W).injective (by
+    rw [AddEquiv.apply_symm_apply, genusOnePic0Equiv_apply, pic0ToPoint_pointClass])
+
+theorem pointClass_add (P Q : W.Point) :
+    pointClass (P + Q) = pointClass P + pointClass Q := by
+  rw [← genusOnePic0Equiv_symm_apply, ← genusOnePic0Equiv_symm_apply,
+    ← genusOnePic0Equiv_symm_apply, ← map_add]
+
+end AbelTheorem
+
+end WeierstrassCurve.Affine
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_GenusOnePlaceGateCentred.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_GenusOnePlaceGateCentred.lean
new file mode 100644
index 0000000000..03e3286ac1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_GenusOnePlaceGateCentred.lean
@@ -0,0 +1,91 @@
+/-
+Based on Prove2Me node WeierstrassCurve_GenusOnePlaceGateCentred
+(0a00705d-5ab9-5688-8c10-6b5d796a42fa) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePic0
+
+/-!
+# Centring condition for the genus-one place–point gate
+
+Definition: `WeierstrassCurve_GenusOnePlaceGateCentred` (`0a00705d-5ab9-5688-8c10-6b5d796a42fa`), by
+Claude, 2026-09-05.
+
+Let $W$ be an affine Weierstrass curve over a field $F$, equipped with the gate class
+`GenusOnePlaceGate W`, which carries a bijection `pointEquivPlace` between the point group
+$W.\mathrm{Point}$ and the places of $W$'s function field over $F$ (all of residue degree one), and
+write `placeOfPoint` for this bijection. Here a place, in the project's sense, is a valuation
+subring of the function field that contains the image of $F$, is not the whole field, and is a
+principal ideal ring, hence a discrete valuation ring.
+
+The module defines the `Prop`-valued mixin class `GenusOnePlaceGate.IsCentred W`, which adds no data
+and whose two fields express that the bijection attaches to each affine point a place centred at
+that point in coordinates. Explicitly: for all $x,y\in F$ and every proof `h` that $(x,y)$ is a
+nonsingular point of $W$, writing $v$ for the place `placeOfPoint (Point.some x y h)`, the field
+requires that the image in the function field, under the map from the coordinate ring of $W$, of the
+class `CoordinateRing.XClass W x` of $X - x$ lies in the non-units of the valuation subring of $v$,
+and likewise that the image of the class `CoordinateRing.YClass W (Polynomial.C y)` of $Y - y$ lies
+in the non-units of that valuation subring. Membership in the non-units of a valuation subring means
+valuation strictly less than $1$, that is, strictly positive order at $v$; so the maximal ideal of
+$v$ contains $X - x$ and $Y - y$.
+
+Two lemmas, `algebraMap_XClass_mem_nonunits` and `algebraMap_YClass_mem_nonunits`, restate the two
+fields as standalone statements with $x$ and $y$ implicit.
+
+**Relation to Mathlib.** The coordinate ring, the function field, `XClass`/`YClass`, `Nonsingular`
+and `Point.some` are Mathlib's notions for affine Weierstrass curves; the notion of a place of a
+function field used here (a valuation subring containing the constants, proper, and a principal
+ideal ring) and the gate classes relating points to places are the project's own.
+
+**Where it is used.** The bijection carried by `GenusOnePlaceGate W` is a priori arbitrary, and the
+companion class `AbelTheorem W` constrains it only up to composition with an automorphism and a
+translation of the point group; requiring it to be centred at each affine point forces it to be the
+geometric dictionary, sending a point to the place of the function field it determines. This mixin
+is therefore assumed in those statements where the maps transported along the Abel–Jacobi
+identification `genusOnePic0Equiv` interact with coordinates — reduction of points, Frobenius on
+points, explicit isogeny formulae — rather than with the group structure alone.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace WeierstrassCurve.Affine
+
+universe u
+
+variable {F : Type u} [Field F]
+
+variable (W : Affine F) in
+class GenusOnePlaceGate.IsCentred [GenusOnePlaceGate W] : Prop where
+  XClass_mem_nonunits : ∀ (x y : F) (h : W.Nonsingular x y),
+    algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.XClass W x)
+      ∈ (placeOfPoint (Point.some x y h)).toValuationSubring.nonunits
+  YClass_mem_nonunits : ∀ (x y : F) (h : W.Nonsingular x y),
+    algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.YClass W (Polynomial.C y))
+      ∈ (placeOfPoint (Point.some x y h)).toValuationSubring.nonunits
+
+namespace GenusOnePlaceGate.IsCentred
+
+variable {W : Affine F} [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W]
+
+theorem algebraMap_XClass_mem_nonunits {x y : F} (h : W.Nonsingular x y) :
+    algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.XClass W x)
+      ∈ (placeOfPoint (Point.some x y h)).toValuationSubring.nonunits :=
+  XClass_mem_nonunits x y h
+
+theorem algebraMap_YClass_mem_nonunits {x y : F} (h : W.Nonsingular x y) :
+    algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.YClass W (Polynomial.C y))
+      ∈ (placeOfPoint (Point.some x y h)).toValuationSubring.nonunits :=
+  YClass_mem_nonunits x y h
+
+end GenusOnePlaceGate.IsCentred
+
+end WeierstrassCurve.Affine
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_OddOrderSummingSet.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_OddOrderSummingSet.lean
new file mode 100644
index 0000000000..c80e503b40
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_OddOrderSummingSet.lean
@@ -0,0 +1,89 @@
+/-
+Based on Prove2Me node WeierstrassCurve_OddOrderSummingSet
+(b6277bd3-2674-5eae-a7bb-9c00a67ab185) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+
+/-!
+# Coordinate extraction and Vélu summing sets for Weierstrass curves
+
+Definition: `WeierstrassCurve_OddOrderSummingSet` (`b6277bd3-2674-5eae-a7bb-9c00a67ab185`), by
+Claude, 2026-09-05.
+
+Two definitions are made, both in the `WeierstrassCurve` namespace and both stated for an arbitrary
+Weierstrass curve rather than for a curve known to be elliptic.
+
+First, for a commutative ring $R$ and an affine Weierstrass curve $W$ over $R$,
+[`WeierstrassCurve.Affine.Point.coordsOrZero`](../def/WeierstrassCurve_OddOrderSummingSet.html#L9)
+is the total map $W.\mathrm{Point} \to R \times R$ defined by cases on the inductive type of points:
+the point at infinity is sent to the pair $(0,0)$, and a point `Point.some x y h` (an affine point
+with nonsingularity witness $h$) is sent to $(x,y)$. Thus it extracts affine coordinates, with
+$(0,0)$ as a junk value at infinity; in particular it is not injective in general, since it cannot
+distinguish infinity from an affine point with coordinates $(0,0)$. The two accompanying lemmas
+`coordsOrZero_zero` and `coordsOrZero_some` record these two defining equations.
+
+Second, for a field $F$ with decidable equality and $W$ a Weierstrass curve over $F$,
+[`WeierstrassCurve.oddOrderSummingSet W Q n`](../def/WeierstrassCurve_OddOrderSummingSet.html#L24),
+for a point $Q$ of the affine curve $W.\mathrm{toAffine}$ and $n : \mathbb{N}$, is the finite subset
+of $F \times F$ obtained as the image of the interval `Finset.Icc 1 n` under $k \mapsto (k \bullet
+Q).\mathrm{coordsOrZero}$, where $k \bullet Q$ is the $\mathbb{N}$-multiple of $Q$ in the group of
+points. So it is the set of coordinate pairs of $Q, 2Q, \dots, nQ$. Nothing in the definition
+requires that $Q$ have order $2n+1$, or that the multiples $kQ$ be affine: if some $kQ$ is the point
+at infinity, the pair $(0,0)$ enters the set. The name records the intended use, where $Q$ has exact
+odd order $2n+1$ and the set is a half-system $S$ with $\langle Q\rangle\setminus\{O\} = S \sqcup
+(-S)$. The lemma `mem_oddOrderSummingSet` restates membership: $P$ lies in the set iff there is $k$
+with $1 \le k \le n$ and $(k \bullet Q).\mathrm{coordsOrZero} = P$.
+
+**Relation to Mathlib.** Builds on Mathlib's `WeierstrassCurve`, `WeierstrassCurve.Affine.Point` and
+the group structure on points; Mathlib has no coordinate-extraction map with a junk value at
+infinity and no Vélu-style summing set, so both definitions here are the project's own.
+
+**Where it is used.** The summing set is the format in which the data of a cyclic kernel is
+presented to the Vélu-type quotient constructions used in the isogeny part of the development; the
+module is imported very widely in the tree.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace WeierstrassCurve
+
+namespace Affine.Point
+
+variable {R : Type*} [CommRing R] {W : Affine R}
+
+def coordsOrZero : W.Point → R × R
+  | .zero => (0, 0)
+  | .some x y _ => (x, y)
+
+@[simp] lemma coordsOrZero_zero : ((.zero : W.Point)).coordsOrZero = (0, 0) := rfl
+
+@[simp] lemma coordsOrZero_some {x y : R} (h : W.Nonsingular x y) :
+    (Point.some x y h).coordsOrZero = (x, y) := rfl
+
+end Affine.Point
+
+section SummingSet
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+def oddOrderSummingSet (Q : W.toAffine.Point) (n : ℕ) : Finset (F × F) :=
+  (Finset.Icc 1 n).image fun k => (k • Q).coordsOrZero
+
+lemma mem_oddOrderSummingSet {Q : W.toAffine.Point} {n : ℕ} {P : F × F} :
+    P ∈ W.oddOrderSummingSet Q n ↔ ∃ k, 1 ≤ k ∧ k ≤ n ∧ (k • Q).coordsOrZero = P := by
+  simp only [oddOrderSummingSet, Finset.mem_image, Finset.mem_Icc]
+  exact ⟨fun ⟨k, ⟨h1, h2⟩, h3⟩ => ⟨k, h1, h2, h3⟩, fun ⟨k, h1, h2, h3⟩ => ⟨k, ⟨h1, h2⟩, h3⟩⟩
+
+end SummingSet
+
+end WeierstrassCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_RatPointHom.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_RatPointHom.lean
new file mode 100644
index 0000000000..a04f919e0d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_RatPointHom.lean
@@ -0,0 +1,110 @@
+/-
+Based on Prove2Me node WeierstrassCurve_RatPointHom
+(646ae9e7-42b3-55e1-baca-d035ef97fce2) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_RatPointMap_probe
+
+/-!
+# Affine Weierstrass points: functoriality along a field homomorphism
+
+Definition: `WeierstrassCurve_RatPointHom` (`646ae9e7-42b3-55e1-baca-d035ef97fce2`), by Claude,
+2026-09-05.
+
+Throughout, $F$ and $k$ are fields, $f : F \to k$ is a ring homomorphism and $W_0$ is a Weierstrass
+curve over $F$; $W_0.map\ f$ denotes the Weierstrass curve over $k$ obtained by applying $f$ to the
+coefficients. The underlying map is
+[`WeierstrassCurve.ratPointMap`](../def/WeierstrassCurve_RatPointMap_probe.html#L16), defined by
+cases on an affine point of $W_0$: the point at infinity goes to the point at infinity, and an
+affine point $(x,y)$ together with a proof that it is nonsingular on $W_0$ goes to $(f(x),f(y))$,
+the nonsingularity being transported along $f$ by `WeierstrassCurve.Affine.map_nonsingular` applied
+to the injectivity of a ring homomorphism of fields. This module records the basic properties of
+that map and packages it as a homomorphism. `ratPointMap_zero` and `ratPointMap_some` are the two
+defining equations. `Affine.Point.some_congr` is a congruence lemma: two affine points `Point.some
+x₁ y₁ h₁` and `Point.some x₂ y₂ h₂` on a Weierstrass curve over $k$ are equal as soon as $x_1 = x_2$
+and $y_1 = y_2$, irrespective of the nonsingularity proofs carried. `ratPointMap_injective` asserts
+injectivity of `ratPointMap f`, by the injectivity of $f$. `ratPointMap_add`, stated with decidable
+equality on $F$ and on $k$ so that Mathlib's addition of affine points is available, asserts
+$f_*(P+Q) = f_*P + f_*Q$ for all affine points $P,Q$ of $W_0$; the proof is the expected case
+analysis, splitting on whether $x_1 = x_2$ and $y_1 = -Y(x_2,y_2)$, and using the compatibility of
+$f$ with `negY`, with the slope and with the addition formulae for the $x$- and $y$-coordinates.
+Finally `ratPointHom` bundles `ratPointMap f` as an additive monoid homomorphism
+$W_0(F)^{\mathrm{aff}} \to (W_0.map\ f)(k)^{\mathrm{aff}}$ between the groups of affine points.
+
+**Relation to Mathlib.** The transport of nonsingularity along $f$ and the compatibility of $f$ with
+`negY`, the slope and the addition formulae are Mathlib results (`Affine.map_nonsingular`,
+`Affine.map_negY`, `Affine.map_slope`, `Affine.map_addX`, `Affine.map_addY`); what is added here is
+the packaging of the coordinatewise map as an injective additive group homomorphism under the
+project's names `ratPointMap` and `ratPointHom`.
+
+**Where it is used.** This is the base-change map on points used in setting up the Galois-theoretic
+side of the argument, for instance the inclusion $E(\mathbb{Q}) \hookrightarrow
+E(\overline{\mathbb{Q}})$ obtained by taking $f$ to be the structure map of an algebraic closure, so
+that rational points may be compared with points over larger fields and with torsion subgroups
+carrying Galois actions.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace WeierstrassCurve
+
+open WeierstrassCurve.Affine
+
+variable {F k : Type*} [Field F] [Field k] (f : F →+* k) {W₀ : WeierstrassCurve F}
+
+theorem Affine.Point.some_congr {V : Affine k} {x₁ y₁ x₂ y₂ : k} (hx : x₁ = x₂)
+    (hy : y₁ = y₂) (h₁ : V.Nonsingular x₁ y₁) (h₂ : V.Nonsingular x₂ y₂) :
+    Point.some x₁ y₁ h₁ = Point.some x₂ y₂ h₂ := by
+  subst hx; subst hy; rfl
+
+@[simp]
+lemma ratPointMap_zero : ratPointMap f (0 : W₀.toAffine.Point) = 0 :=
+  rfl
+
+lemma ratPointMap_some {x y : F} (h : W₀.toAffine.Nonsingular x y) :
+    ratPointMap f (.some x y h)
+      = .some (f x) (f y) ((W₀.toAffine.map_nonsingular f.injective x y).mpr h) :=
+  rfl
+
+lemma ratPointMap_injective : Function.Injective (ratPointMap f (W₀ := W₀)) := by
+  rintro (_ | ⟨x₁, y₁, h₁⟩) (_ | ⟨x₂, y₂, h₂⟩) h
+  · rfl
+  · exact absurd h.symm (Affine.Point.some_ne_zero _)
+  · exact absurd h (Affine.Point.some_ne_zero _)
+  · rw [ratPointMap_some, ratPointMap_some, Affine.Point.some.injEq] at h
+    exact Affine.Point.some_congr (f.injective h.1) (f.injective h.2) _ _
+
+theorem ratPointMap_add [DecidableEq F] [DecidableEq k] (P Q : W₀.toAffine.Point) :
+    ratPointMap f (P + Q) = ratPointMap f P + ratPointMap f Q := by
+  rcases P with _ | ⟨x₁, y₁, h₁⟩ <;> rcases Q with _ | ⟨x₂, y₂, h₂⟩
+  any_goals rfl
+  by_cases hxy : x₁ = x₂ ∧ y₁ = W₀.toAffine.negY x₂ y₂
+  · rw [Affine.Point.add_of_Y_eq hxy.1 hxy.2, ratPointMap_zero, ratPointMap_some,
+      ratPointMap_some,
+      Affine.Point.add_of_Y_eq (congrArg f hxy.1) (by rw [hxy.2, Affine.map_negY])]
+  · have hxy' : ¬(f x₁ = f x₂ ∧ f y₁ = (W₀.map f).toAffine.negY (f x₂) (f y₂)) := by
+      rintro ⟨hx, hy⟩
+      rw [Affine.map_negY] at hy
+      exact hxy ⟨f.injective hx, f.injective hy⟩
+    rw [Affine.Point.add_some hxy, ratPointMap_some, ratPointMap_some, ratPointMap_some,
+      Affine.Point.add_some hxy']
+    exact Affine.Point.some_congr (by rw [Affine.map_slope, Affine.map_addX])
+      (by rw [Affine.map_slope, Affine.map_addY]) _ _
+
+@[simps]
+def ratPointHom [DecidableEq F] [DecidableEq k] :
+    W₀.toAffine.Point →+ (W₀.map f).toAffine.Point where
+  toFun := ratPointMap f
+  map_zero' := rfl
+  map_add' := ratPointMap_add f
+
+end WeierstrassCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_RatPointMap_probe.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_RatPointMap_probe.lean
new file mode 100644
index 0000000000..0829ba75de
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_RatPointMap_probe.lean
@@ -0,0 +1,68 @@
+/-
+Based on Prove2Me node WeierstrassCurve_RatPointMap_probe
+(ce07b20c-8454-54a1-91e9-81335e68ebd8) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+
+/-!
+# Coordinatewise map on affine points along a ring homomorphism
+
+Definition: `WeierstrassCurve_RatPointMap_probe` (`ce07b20c-8454-54a1-91e9-81335e68ebd8`), by
+Claude, 2026-09-05.
+
+Fix fields $F$ and $k$, a ring homomorphism $f : F \to k$, and a Weierstrass curve $W_0$ over $F$,
+given by its coefficients $a_1,a_2,a_3,a_4,a_6$. Mathlib's base change `WeierstrassCurve.map`
+produces the Weierstrass curve $W_0.\mathrm{map}\,f$ over $k$ whose coefficients are the images
+$f(a_i)$. The module defines `ratPointMap`, the map from the set of affine points of $W_0$ (the
+Mathlib type `W₀.toAffine.Point`, whose elements are either the point at infinity `.zero` or a pair
+$(x,y)$ of coordinates in $F$ together with a proof that $(x,y)$ is a nonsingular point of the
+affine equation) to the affine points of $W_0.\mathrm{map}\,f$. It is defined by cases: the point at
+infinity goes to the point at infinity, and a point with coordinates $(x,y)$ goes to the point with
+coordinates $(f(x), f(y))$. That the image pair is again a nonsingular solution of the transported
+equation is supplied by Mathlib's `WeierstrassCurve.Affine.map_nonsingular`, applied with the
+injectivity of $f$ (automatic for a ring homomorphism out of a field). The definition is a map of
+underlying point sets only; no group-homomorphism property is asserted here.
+
+Alongside it, a small auxiliary congruence statement `some_congr` records that for an affine
+Weierstrass curve $V$ over $k$ and coordinates $x_1,y_1,x_2,y_2$ in $k$ with $x_1 = x_2$ and $y_1 =
+y_2$, the points `Point.some x₁ y₁ h₁` and `Point.some x₂ y₂ h₂` are equal, for any two
+nonsingularity proofs $h_1$, $h_2$: the point depends only on its coordinates, the proof component
+being irrelevant.
+
+**Relation to Mathlib.** The construction rests on Mathlib's base change `WeierstrassCurve.map` and
+on `WeierstrassCurve.Affine.map_nonsingular`; `ratPointMap` itself is the project's own name for the
+resulting map on affine point sets.
+
+**Where it is used.** The map is used where points of a Weierstrass curve have to be transported
+along a homomorphism of the base field, for instance when comparing points of a curve with points of
+its base change.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace WeierstrassCurve
+
+open WeierstrassCurve.Affine
+
+variable {F k : Type*} [Field F] [Field k] (f : F →+* k) {W₀ : WeierstrassCurve F}
+
+private theorem some_congr {V : Affine k} {x₁ y₁ x₂ y₂ : k} (hx : x₁ = x₂)
+    (hy : y₁ = y₂) (h₁ : V.Nonsingular x₁ y₁) (h₂ : V.Nonsingular x₂ y₂) :
+    Point.some x₁ y₁ h₁ = Point.some x₂ y₂ h₂ := by
+  subst hx; subst hy; rfl
+
+def ratPointMap : W₀.toAffine.Point → (W₀.map f).toAffine.Point
+  | .zero => .zero
+  | .some x y h => .some (f x) (f y) ((W₀.toAffine.map_nonsingular f.injective x y).mpr h)
+
+end WeierstrassCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_ReduceHom.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_ReduceHom.lean
new file mode 100644
index 0000000000..54b2ff2160
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_ReduceHom.lean
@@ -0,0 +1,514 @@
+/-
+Based on Prove2Me node WeierstrassCurve_ReduceHom
+(e41eb9e1-feaf-521b-995b-face6f0461a2) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_TorsionIntegral
+
+/-!
+# Reduction of points as an additive group homomorphism
+
+Definition: `WeierstrassCurve_ReduceHom` (`e41eb9e1-feaf-521b-995b-face6f0461a2`), by Claude,
+2026-09-05.
+
+Throughout, $A$ is a valuation subring of a field $L$ and $W$ is a Weierstrass curve over $A$; the
+two base changes in play are $W$ pushed along the inclusion $A \hookrightarrow L$ (`W.map
+A.subtype`) and along the residue map $A \to \kappa_A$ (`W.map (residue A)`).
+
+A first group of lemmas records how the residue map interacts with division: if $a \in A$ and $b$ is
+not a non-unit of $A$ then $a/b \in A$, the residue of such a $b$ is non-zero, the residue of an
+element of $A$ depends only on its value in $L$, and residues of quotients are quotients of residues
+(`residue_div`, `residue_eq_div_of_eq_div`). Further, two elements of $A$ have the same residue
+exactly when their difference lies in the set of non-units, i.e. in the maximal ideal.
+
+A second group transports the Weierstrass formulae: for $x,y \in A$ the quantity $\mathrm{negY}(x,y)
+= -y - a_1x - a_3$ computed on the curve over $L$ lies in $A$ and its residue is $\mathrm{negY}$ of
+the reduced curve at the reduced arguments, and `residue_inverse_iff` says that, for $x_i, y_i \in
+A$, the reduced points satisfy $\bar x_1 = \bar x_2$ and $\bar y_1 = \mathrm{negY}(\bar x_2, \bar
+y_2)$ precisely when $x_1 - x_2$ and $y_1 - \mathrm{negY}(x_2,y_2)$ both lie in the maximal ideal.
+Building on these, `slope_mem_residue_of_not_inverse` shows that for two points of the affine
+equation with $x_1, x_2 \in A$, whose reductions are not mutually inverse in this sense, the
+chord-or-tangent slope lies in $A$ and reduces to the slope of the reduced curve at the reduced
+points; the proof splits according to whether $x_1 - x_2$ is a non-unit and whether $x_1 = x_2$, and
+rewrites the slope over the common denominator $y_1 - \mathrm{negY}(x_2,y_2)$.
+
+Under the hypothesis $h\Delta$ that the reduced curve has non-zero discriminant, the additivity of
+the reduction map `reducePoint hΔ` — which sends an affine point with integral $x$-coordinate to the
+point with residue coordinates, and every other affine point to zero — is proved in three cases:
+both $x$-coordinates in $A$ (`reducePoint_add_of_mem`, where the sum is again integral unless the
+two reductions are inverse, in which case the reduced sum is zero by
+`Affine.addX_notMem_of_sub_mem_nonunits`); neither in $A$ (`reducePoint_add_of_notMem_of_notMem`,
+where the formal-parameter estimate `Affine.add_formal_param_estimate` shows the $x$-coordinate of
+the sum is again non-integral); and one of each (`reducePoint_add_of_mem_of_notMem`, deduced from
+the previous two applied to the sum and the negative of a summand). These combine into
+`reducePoint_add_def`, additivity for arbitrary points, and `reduceHom`, the bundled additive monoid
+homomorphism from the points of the curve over $L$ to the points of the reduced curve whose
+underlying function is `reducePoint hΔ`.
+
+**Relation to Mathlib.** Mathlib supplies the affine Weierstrass point group with `negY`, `slope`,
+`addX`, `addY` and their compatibility with base change, together with valuation subrings and their
+residue fields; the reduction map on points and its additivity are the project's own.
+
+**Where it is used.** With good reduction at a place, this homomorphism compares the points of the
+curve over $L$ with those of the special fibre, and is the tool for controlling $n$-torsion and the
+action of inertia on it; downstream it is composed with the identification of the special fibre of
+the Frey curve in the analysis of the attached mod-$p$ Galois representation.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open IsLocalRing
+
+namespace ValuationSubring
+
+variable {L : Type*} [Field L] (A : ValuationSubring L)
+
+theorem div_mem_of_mem_of_notMem_nonunits {a b : L} (ha : a ∈ A) (hb : b ∉ A.nonunits) :
+    a / b ∈ A := by
+  rw [div_eq_mul_inv]
+  exact A.toSubring.mul_mem ha (A.inv_mem_of_notMem_nonunits hb)
+
+theorem residue_ne_zero_of_notMem_nonunits {b : L} (hb : b ∈ A) (hb' : b ∉ A.nonunits) :
+    residue A ⟨b, hb⟩ ≠ 0 := fun h =>
+  hb' ((A.coe_mem_nonunits_iff_residue_eq_zero ⟨b, hb⟩).mpr h)
+
+theorem residue_eq_of_coe_eq {a : L} (ha : a ∈ A) {v : A} (hav : a = (v : L)) :
+    residue A ⟨a, ha⟩ = residue A v :=
+  congrArg (residue A) (Subtype.ext hav)
+
+theorem residue_div {a b : L} (ha : a ∈ A) (hb : b ∈ A) (hb' : b ∉ A.nonunits)
+    (hq : a / b ∈ A) :
+    residue A ⟨a / b, hq⟩ = residue A ⟨a, ha⟩ / residue A ⟨b, hb⟩ := by
+  have hb0 : b ≠ 0 := A.ne_zero_of_notMem_nonunits hb'
+  have hbres : residue A ⟨b, hb⟩ ≠ 0 := A.residue_ne_zero_of_notMem_nonunits hb hb'
+  rw [eq_div_iff hbres, ← map_mul]
+  refine congrArg (residue A) (Subtype.ext ?_)
+  push_cast
+  exact div_mul_cancel₀ a hb0
+
+theorem residue_eq_div_of_eq_div {a c d : L} (ha : a ∈ A) (hc : c ∈ A) (hd : d ∈ A)
+    (hd' : d ∉ A.nonunits) (hacd : a = c / d) :
+    residue A ⟨a, ha⟩ = residue A ⟨c, hc⟩ / residue A ⟨d, hd⟩ := by
+  rw [A.residue_eq_of_coe_eq ha
+    (v := ⟨c / d, A.div_mem_of_mem_of_notMem_nonunits hc hd'⟩) hacd]
+  exact A.residue_div hc hd hd' _
+
+theorem residue_eq_residue_iff_sub_mem_nonunits {a b : L} (ha : a ∈ A) (hb : b ∈ A) :
+    residue A ⟨a, ha⟩ = residue A ⟨b, hb⟩ ↔ a - b ∈ A.nonunits := by
+  constructor
+  · intro h
+    have h0 : residue A (⟨a, ha⟩ - ⟨b, hb⟩) = 0 := by rw [map_sub, h, sub_self]
+    have := (A.coe_mem_nonunits_iff_residue_eq_zero _).mpr h0
+    simpa using this
+  · intro h
+    have h0 : residue A (⟨a, ha⟩ - ⟨b, hb⟩) = 0 :=
+      (A.coe_mem_nonunits_iff_residue_eq_zero _).mp (by simpa using h)
+    rw [map_sub, sub_eq_zero] at h0
+    exact h0
+
+end ValuationSubring
+
+namespace WeierstrassCurve
+
+variable {L : Type*} [Field L] {A : ValuationSubring L} (W : WeierstrassCurve A)
+
+private lemma some_congr' {R : Type*} [CommRing R] {V : Affine R} {x₁ x₂ y₁ y₂ : R}
+    (hx : x₁ = x₂) (hy : y₁ = y₂) (h₁ : V.Nonsingular x₁ y₁) (h₂ : V.Nonsingular x₂ y₂) :
+    Affine.Point.some x₁ y₁ h₁ = Affine.Point.some x₂ y₂ h₂ := by
+  subst hx; subst hy; rfl
+
+section Coercion
+
+variable {W}
+
+lemma coe_negY {x y : L} (hx : x ∈ A) (hy : y ∈ A) :
+    ((W.toAffine.negY ⟨x, hx⟩ ⟨y, hy⟩ : A) : L) = (W.map A.subtype).toAffine.negY x y :=
+  (Affine.map_negY A.subtype (⟨x, hx⟩ : A) (⟨y, hy⟩ : A)).symm
+
+lemma negY_mem {x y : L} (hx : x ∈ A) (hy : y ∈ A) :
+    (W.map A.subtype).toAffine.negY x y ∈ A := by
+  rw [← coe_negY hx hy]
+  exact SetLike.coe_mem _
+
+lemma residue_negY {x y : L} (hx : x ∈ A) (hy : y ∈ A) :
+    residue A (W.toAffine.negY ⟨x, hx⟩ ⟨y, hy⟩) =
+      (W.map (residue A)).toAffine.negY (residue A ⟨x, hx⟩) (residue A ⟨y, hy⟩) :=
+  (Affine.map_negY (residue A) (⟨x, hx⟩ : A) (⟨y, hy⟩ : A)).symm
+
+lemma residue_sub_negY {x₂ y₁ y₂ : L} (hy₁ : y₁ ∈ A) (hx₂ : x₂ ∈ A) (hy₂ : y₂ ∈ A)
+    (hmem : y₁ - (W.map A.subtype).toAffine.negY x₂ y₂ ∈ A) :
+    residue A ⟨y₁ - (W.map A.subtype).toAffine.negY x₂ y₂, hmem⟩ =
+      residue A ⟨y₁, hy₁⟩ -
+        (W.map (residue A)).toAffine.negY (residue A ⟨x₂, hx₂⟩) (residue A ⟨y₂, hy₂⟩) := by
+  rw [A.residue_eq_of_coe_eq hmem (v := ⟨y₁, hy₁⟩ - W.toAffine.negY ⟨x₂, hx₂⟩ ⟨y₂, hy₂⟩)
+    (by push_cast; rw [coe_negY hx₂ hy₂]), map_sub, residue_negY hx₂ hy₂]
+
+lemma residue_inverse_iff {x₁ y₁ x₂ y₂ : L} (hx₁ : x₁ ∈ A) (hy₁ : y₁ ∈ A) (hx₂ : x₂ ∈ A)
+    (hy₂ : y₂ ∈ A) :
+    (residue A ⟨x₁, hx₁⟩ = residue A ⟨x₂, hx₂⟩ ∧
+        residue A ⟨y₁, hy₁⟩ =
+          (W.map (residue A)).toAffine.negY (residue A ⟨x₂, hx₂⟩) (residue A ⟨y₂, hy₂⟩)) ↔
+      (x₁ - x₂ ∈ A.nonunits ∧
+        y₁ - (W.map A.subtype).toAffine.negY x₂ y₂ ∈ A.nonunits) := by
+  have hnegA : (W.map A.subtype).toAffine.negY x₂ y₂ ∈ A := negY_mem hx₂ hy₂
+  have h1 := A.residue_eq_residue_iff_sub_mem_nonunits hx₁ hx₂
+  have h2 := A.residue_eq_residue_iff_sub_mem_nonunits hy₁ hnegA
+  have h3 : residue A ⟨(W.map A.subtype).toAffine.negY x₂ y₂, hnegA⟩ =
+      (W.map (residue A)).toAffine.negY (residue A ⟨x₂, hx₂⟩) (residue A ⟨y₂, hy₂⟩) := by
+    rw [A.residue_eq_of_coe_eq hnegA (v := W.toAffine.negY ⟨x₂, hx₂⟩ ⟨y₂, hy₂⟩)
+      (coe_negY hx₂ hy₂).symm]
+    exact residue_negY hx₂ hy₂
+  rw [← h3]
+  exact and_congr h1 h2
+
+end Coercion
+
+section Slope
+
+variable [DecidableEq L] [DecidableEq (ResidueField A)]
+variable {W}
+
+theorem slope_mem_residue_of_not_inverse
+    {x₁ y₁ x₂ y₂ : L} (h₁ : (W.map A.subtype).toAffine.Equation x₁ y₁)
+    (h₂ : (W.map A.subtype).toAffine.Equation x₂ y₂) (hx₁ : x₁ ∈ A) (hx₂ : x₂ ∈ A)
+    (hred : ¬(x₁ - x₂ ∈ A.nonunits ∧
+      y₁ - (W.map A.subtype).toAffine.negY x₂ y₂ ∈ A.nonunits)) :
+    ∃ hs : (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ ∈ A,
+      residue A ⟨(W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂, hs⟩ =
+        (W.map (residue A)).toAffine.slope (residue A ⟨x₁, hx₁⟩) (residue A ⟨x₂, hx₂⟩)
+          (residue A ⟨y₁, Affine.Y_mem_of_X_mem W h₁ hx₁⟩)
+          (residue A ⟨y₂, Affine.Y_mem_of_X_mem W h₂ hx₂⟩) := by
+  have hy₁ : y₁ ∈ A := Affine.Y_mem_of_X_mem W h₁ hx₁
+  have hy₂ : y₂ ∈ A := Affine.Y_mem_of_X_mem W h₂ hx₂
+  have ha₁ : (W.map A.subtype).toAffine.a₁ ∈ A := SetLike.coe_mem W.a₁
+  have ha₂ : (W.map A.subtype).toAffine.a₂ ∈ A := SetLike.coe_mem W.a₂
+  have ha₄ : (W.map A.subtype).toAffine.a₄ ∈ A := SetLike.coe_mem W.a₄
+  have hk₁ : (W.map (residue A)).toAffine.Equation (residue A ⟨x₁, hx₁⟩) (residue A ⟨y₁, hy₁⟩) :=
+    Affine.equation_residue W (x := ⟨x₁, hx₁⟩) (y := ⟨y₁, hy₁⟩) h₁
+  have hk₂ : (W.map (residue A)).toAffine.Equation (residue A ⟨x₂, hx₂⟩) (residue A ⟨y₂, hy₂⟩) :=
+    Affine.equation_residue W (x := ⟨x₂, hx₂⟩) (y := ⟨y₂, hy₂⟩) h₂
+  have ha₁k : (W.map (residue A)).toAffine.a₁ = residue A W.a₁ := rfl
+  have ha₂k : (W.map (residue A)).toAffine.a₂ = residue A W.a₂ := rfl
+  have ha₄k : (W.map (residue A)).toAffine.a₄ = residue A W.a₄ := rfl
+  by_cases hxx : x₁ - x₂ ∈ A.nonunits
+  · have hyy : y₁ - (W.map A.subtype).toAffine.negY x₂ y₂ ∉ A.nonunits := fun h => hred ⟨hxx, h⟩
+    have hyyA : y₁ - (W.map A.subtype).toAffine.negY x₂ y₂ ∈ A :=
+      A.toSubring.sub_mem hy₁ (negY_mem hx₂ hy₂)
+    have hyy0 : y₁ - (W.map A.subtype).toAffine.negY x₂ y₂ ≠ 0 :=
+      A.ne_zero_of_notMem_nonunits hyy
+    have hxk : residue A ⟨x₁, hx₁⟩ = residue A ⟨x₂, hx₂⟩ :=
+      (A.residue_eq_residue_iff_sub_mem_nonunits hx₁ hx₂).mpr hxx
+    have hyk : residue A ⟨y₁, hy₁⟩ ≠
+        (W.map (residue A)).toAffine.negY (residue A ⟨x₂, hx₂⟩) (residue A ⟨y₂, hy₂⟩) := by
+      intro h
+      exact hyy (((residue_inverse_iff hx₁ hy₁ hx₂ hy₂).mp ⟨hxk, h⟩).2)
+    have hyk' : residue A ⟨y₁, hy₁⟩ = residue A ⟨y₂, hy₂⟩ :=
+      Affine.Y_eq_of_Y_ne hk₁ hk₂ hxk hyk
+    have hslope_k : (W.map (residue A)).toAffine.slope (residue A ⟨x₁, hx₁⟩)
+        (residue A ⟨x₂, hx₂⟩) (residue A ⟨y₁, hy₁⟩) (residue A ⟨y₂, hy₂⟩) =
+        (3 * residue A ⟨x₁, hx₁⟩ ^ 2 + 2 * (W.map (residue A)).toAffine.a₂ *
+            residue A ⟨x₁, hx₁⟩ + (W.map (residue A)).toAffine.a₄ -
+            (W.map (residue A)).toAffine.a₁ * residue A ⟨y₁, hy₁⟩) /
+          (residue A ⟨y₁, hy₁⟩ -
+            (W.map (residue A)).toAffine.negY (residue A ⟨x₁, hx₁⟩) (residue A ⟨y₁, hy₁⟩)) :=
+      Affine.slope_of_Y_ne hxk hyk
+    have hden_res : residue A ⟨y₁ - (W.map A.subtype).toAffine.negY x₂ y₂, hyyA⟩ =
+        residue A ⟨y₁, hy₁⟩ -
+          (W.map (residue A)).toAffine.negY (residue A ⟨x₁, hx₁⟩) (residue A ⟨y₁, hy₁⟩) := by
+      rw [residue_sub_negY hy₁ hx₂ hy₂ hyyA, hxk, hyk']
+    have hnum_mem : 3 * x₁ ^ 2 + 2 * (W.map A.subtype).toAffine.a₂ * x₁ +
+        (W.map A.subtype).toAffine.a₄ - (W.map A.subtype).toAffine.a₁ * y₁ ∈ A := by
+      refine A.toSubring.sub_mem (A.toSubring.add_mem (A.toSubring.add_mem ?_ ?_) ha₄)
+        (A.toSubring.mul_mem ha₁ hy₁)
+      · exact A.toSubring.mul_mem (by norm_num : (3 : L) ∈ A) (pow_mem hx₁ 2)
+      · exact A.toSubring.mul_mem (A.toSubring.mul_mem (by norm_num : (2 : L) ∈ A) ha₂) hx₁
+    have hnum_res : residue A ⟨3 * x₁ ^ 2 + 2 * (W.map A.subtype).toAffine.a₂ * x₁ +
+        (W.map A.subtype).toAffine.a₄ - (W.map A.subtype).toAffine.a₁ * y₁, hnum_mem⟩ =
+        3 * residue A ⟨x₁, hx₁⟩ ^ 2 + 2 * (W.map (residue A)).toAffine.a₂ *
+          residue A ⟨x₁, hx₁⟩ + (W.map (residue A)).toAffine.a₄ -
+          (W.map (residue A)).toAffine.a₁ * residue A ⟨y₁, hy₁⟩ := by
+      rw [A.residue_eq_of_coe_eq hnum_mem
+        (v := 3 * ⟨x₁, hx₁⟩ ^ 2 + 2 * W.a₂ * ⟨x₁, hx₁⟩ + W.a₄ - W.a₁ * ⟨y₁, hy₁⟩)
+        (by push_cast; rfl)]
+      simp only [map_sub, map_add, map_mul, map_pow, map_ofNat]
+      rw [ha₁k, ha₂k, ha₄k]
+    by_cases hx : x₁ = x₂
+    · have hyL : y₁ ≠ (W.map A.subtype).toAffine.negY x₂ y₂ := fun h => hyy0 (by rw [h, sub_self])
+      have hyL' : y₁ = y₂ := Affine.Y_eq_of_Y_ne h₁ h₂ hx hyL
+      have hslope_L : (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ =
+          (3 * x₁ ^ 2 + 2 * (W.map A.subtype).toAffine.a₂ * x₁ +
+              (W.map A.subtype).toAffine.a₄ - (W.map A.subtype).toAffine.a₁ * y₁) /
+            (y₁ - (W.map A.subtype).toAffine.negY x₁ y₁) :=
+        Affine.slope_of_Y_ne hx hyL
+      have hden_eq : y₁ - (W.map A.subtype).toAffine.negY x₁ y₁ =
+          y₁ - (W.map A.subtype).toAffine.negY x₂ y₂ := by
+        rw [hx, hyL']
+      have hslope_L' : (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ =
+          (3 * x₁ ^ 2 + 2 * (W.map A.subtype).toAffine.a₂ * x₁ +
+              (W.map A.subtype).toAffine.a₄ - (W.map A.subtype).toAffine.a₁ * y₁) /
+            (y₁ - (W.map A.subtype).toAffine.negY x₂ y₂) := by
+        rw [hslope_L, hden_eq]
+      have hsmem : (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ ∈ A := by
+        rw [hslope_L']
+        exact A.div_mem_of_mem_of_notMem_nonunits hnum_mem hyy
+      refine ⟨hsmem, ?_⟩
+      rw [A.residue_eq_div_of_eq_div hsmem hnum_mem hyyA hyy hslope_L', hslope_k, hnum_res,
+        hden_res]
+    · have hslope_L : (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ = (y₁ - y₂) / (x₁ - x₂) :=
+        Affine.slope_of_X_ne hx
+      have hN_mem : x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + (W.map A.subtype).toAffine.a₂ * (x₁ + x₂) +
+          (W.map A.subtype).toAffine.a₄ - (W.map A.subtype).toAffine.a₁ * y₁ ∈ A := by
+        refine A.toSubring.sub_mem (A.toSubring.add_mem (A.toSubring.add_mem (A.toSubring.add_mem
+          (A.toSubring.add_mem (pow_mem hx₁ 2) (A.toSubring.mul_mem hx₁ hx₂)) (pow_mem hx₂ 2))
+          (A.toSubring.mul_mem ha₂ (A.toSubring.add_mem hx₁ hx₂))) ha₄)
+          (A.toSubring.mul_mem ha₁ hy₁)
+      have hslope_N : (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ =
+          (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + (W.map A.subtype).toAffine.a₂ * (x₁ + x₂) +
+              (W.map A.subtype).toAffine.a₄ - (W.map A.subtype).toAffine.a₁ * y₁) /
+            (y₁ - (W.map A.subtype).toAffine.negY x₂ y₂) := by
+        rw [hslope_L, div_eq_div_iff (sub_ne_zero.mpr hx) hyy0]
+        linear_combination Affine.sub_mul_sub_negY h₁ h₂
+      have hsmem : (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ ∈ A := by
+        rw [hslope_N]
+        exact A.div_mem_of_mem_of_notMem_nonunits hN_mem hyy
+      refine ⟨hsmem, ?_⟩
+      have hN_res : residue A ⟨x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 +
+          (W.map A.subtype).toAffine.a₂ * (x₁ + x₂) + (W.map A.subtype).toAffine.a₄ -
+          (W.map A.subtype).toAffine.a₁ * y₁, hN_mem⟩ =
+          3 * residue A ⟨x₁, hx₁⟩ ^ 2 + 2 * (W.map (residue A)).toAffine.a₂ *
+            residue A ⟨x₁, hx₁⟩ + (W.map (residue A)).toAffine.a₄ -
+            (W.map (residue A)).toAffine.a₁ * residue A ⟨y₁, hy₁⟩ := by
+        rw [A.residue_eq_of_coe_eq hN_mem
+          (v := ⟨x₁, hx₁⟩ ^ 2 + ⟨x₁, hx₁⟩ * ⟨x₂, hx₂⟩ + ⟨x₂, hx₂⟩ ^ 2 +
+            W.a₂ * (⟨x₁, hx₁⟩ + ⟨x₂, hx₂⟩) + W.a₄ - W.a₁ * ⟨y₁, hy₁⟩)
+          (by push_cast; rfl)]
+        simp only [map_sub, map_add, map_mul, map_pow]
+        rw [ha₁k, ha₂k, ha₄k, ← hxk]
+        ring
+      rw [A.residue_eq_div_of_eq_div hsmem hN_mem hyyA hyy hslope_N, hslope_k, hN_res, hden_res]
+  · have hxL : x₁ ≠ x₂ := fun h => hxx (by rw [h, sub_self]; exact A.nonunits.zero_mem)
+    have hxxA : x₁ - x₂ ∈ A := A.toSubring.sub_mem hx₁ hx₂
+    have hslope_L : (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ = (y₁ - y₂) / (x₁ - x₂) :=
+      Affine.slope_of_X_ne hxL
+    have hyyA : y₁ - y₂ ∈ A := A.toSubring.sub_mem hy₁ hy₂
+    have hsmem : (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ ∈ A := by
+      rw [hslope_L]
+      exact A.div_mem_of_mem_of_notMem_nonunits hyyA hxx
+    refine ⟨hsmem, ?_⟩
+    have hxk : residue A ⟨x₁, hx₁⟩ ≠ residue A ⟨x₂, hx₂⟩ := fun h =>
+      hxx ((A.residue_eq_residue_iff_sub_mem_nonunits hx₁ hx₂).mp h)
+    have hslope_k : (W.map (residue A)).toAffine.slope (residue A ⟨x₁, hx₁⟩)
+        (residue A ⟨x₂, hx₂⟩) (residue A ⟨y₁, hy₁⟩) (residue A ⟨y₂, hy₂⟩) =
+        (residue A ⟨y₁, hy₁⟩ - residue A ⟨y₂, hy₂⟩) /
+          (residue A ⟨x₁, hx₁⟩ - residue A ⟨x₂, hx₂⟩) := Affine.slope_of_X_ne hxk
+    have hnum_eq : residue A ⟨y₁ - y₂, hyyA⟩ = residue A ⟨y₁, hy₁⟩ - residue A ⟨y₂, hy₂⟩ := by
+      rw [A.residue_eq_of_coe_eq hyyA (v := ⟨y₁, hy₁⟩ - ⟨y₂, hy₂⟩) (by push_cast; ring), map_sub]
+    have hden_eq : residue A ⟨x₁ - x₂, hxxA⟩ = residue A ⟨x₁, hx₁⟩ - residue A ⟨x₂, hx₂⟩ := by
+      rw [A.residue_eq_of_coe_eq hxxA (v := ⟨x₁, hx₁⟩ - ⟨x₂, hx₂⟩) (by push_cast; ring), map_sub]
+    rw [A.residue_eq_div_of_eq_div hsmem hyyA hxxA hxx hslope_L, hslope_k, hnum_eq, hden_eq]
+
+end Slope
+
+section IntegralCase
+
+variable [DecidableEq L] [DecidableEq (ResidueField A)]
+variable {W} (hΔ : (W.map (residue A)).Δ ≠ 0)
+
+theorem reducePoint_add_of_mem {x₁ y₁ x₂ y₂ : L}
+    (h₁ : (W.map A.subtype).toAffine.Nonsingular x₁ y₁)
+    (h₂ : (W.map A.subtype).toAffine.Nonsingular x₂ y₂) (hx₁ : x₁ ∈ A) (hx₂ : x₂ ∈ A) :
+    reducePoint hΔ (.some x₁ y₁ h₁ + .some x₂ y₂ h₂) =
+      reducePoint hΔ (.some x₁ y₁ h₁) + reducePoint hΔ (.some x₂ y₂ h₂) := by
+  have hy₁ : y₁ ∈ A := Affine.Y_mem_of_X_mem W h₁.1 hx₁
+  have hy₂ : y₂ ∈ A := Affine.Y_mem_of_X_mem W h₂.1 hx₂
+  rw [reducePoint_some_of_mem _ _ hx₁, reducePoint_some_of_mem _ _ hx₂]
+  by_cases hred : x₁ - x₂ ∈ A.nonunits ∧
+      y₁ - (W.map A.subtype).toAffine.negY x₂ y₂ ∈ A.nonunits
+  · obtain ⟨hredx, hredy⟩ := (residue_inverse_iff hx₁ hy₁ hx₂ hy₂).mpr hred
+    rw [Affine.Point.add_of_Y_eq hredx hredy]
+    by_cases hPQ : x₁ = x₂ ∧ y₁ = (W.map A.subtype).toAffine.negY x₂ y₂
+    · rw [Affine.Point.add_of_Y_eq hPQ.1 hPQ.2, reducePoint_zero]
+    · rw [Affine.Point.add_some hPQ]
+      exact reducePoint_some_of_notMem _ _
+        (Affine.addX_notMem_of_sub_mem_nonunits W hΔ h₁.1 h₂.1 hx₁ hx₂ hPQ hred.1 hred.2)
+  · obtain ⟨hsmem, hsres⟩ := slope_mem_residue_of_not_inverse h₁.1 h₂.1 hx₁ hx₂ hred
+    have hPQ : ¬(x₁ = x₂ ∧ y₁ = (W.map A.subtype).toAffine.negY x₂ y₂) := by
+      rintro ⟨hxe, hye⟩
+      exact hred ⟨by rw [hxe, sub_self]; exact A.nonunits.zero_mem,
+        by rw [hye, sub_self]; exact A.nonunits.zero_mem⟩
+    have hredk : ¬(residue A ⟨x₁, hx₁⟩ = residue A ⟨x₂, hx₂⟩ ∧
+        residue A ⟨y₁, hy₁⟩ =
+          (W.map (residue A)).toAffine.negY (residue A ⟨x₂, hx₂⟩) (residue A ⟨y₂, hy₂⟩)) :=
+      fun h => hred ((residue_inverse_iff hx₁ hy₁ hx₂ hy₂).mp h)
+    rw [Affine.Point.add_some hPQ, Affine.Point.add_some hredk]
+    have hX_coe : (W.map A.subtype).toAffine.addX x₁ x₂
+        ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂) =
+        ((W.toAffine.addX ⟨x₁, hx₁⟩ ⟨x₂, hx₂⟩
+          ⟨(W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂, hsmem⟩ : A) : L) :=
+      Affine.map_addX (W' := W) A.subtype (⟨x₁, hx₁⟩ : A) (⟨x₂, hx₂⟩ : A)
+        ⟨(W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂, hsmem⟩
+    have hY_coe : (W.map A.subtype).toAffine.addY x₁ x₂ y₁
+        ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂) =
+        ((W.toAffine.addY ⟨x₁, hx₁⟩ ⟨x₂, hx₂⟩ ⟨y₁, hy₁⟩
+          ⟨(W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂, hsmem⟩ : A) : L) :=
+      Affine.map_addY (W' := W) A.subtype (⟨x₁, hx₁⟩ : A) (⟨y₁, hy₁⟩ : A) (⟨x₂, hx₂⟩ : A)
+        ⟨(W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂, hsmem⟩
+    have hX_mem : (W.map A.subtype).toAffine.addX x₁ x₂
+        ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂) ∈ A := by
+      rw [hX_coe]; exact SetLike.coe_mem _
+    rw [reducePoint_some_of_mem _ _ hX_mem]
+    refine some_congr' ?_ ?_ _ _
+    · calc residue A ⟨(W.map A.subtype).toAffine.addX x₁ x₂
+              ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂), hX_mem⟩
+          = residue A (W.toAffine.addX ⟨x₁, hx₁⟩ ⟨x₂, hx₂⟩
+              ⟨(W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂, hsmem⟩) :=
+            A.residue_eq_of_coe_eq hX_mem hX_coe
+        _ = (W.map (residue A)).toAffine.addX (residue A ⟨x₁, hx₁⟩) (residue A ⟨x₂, hx₂⟩)
+              (residue A ⟨(W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂, hsmem⟩) :=
+            (Affine.map_addX (W' := W) (residue A) (⟨x₁, hx₁⟩ : A) (⟨x₂, hx₂⟩ : A)
+              ⟨(W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂, hsmem⟩).symm
+        _ = _ := by rw [hsres]
+    · calc residue A ⟨(W.map A.subtype).toAffine.addY x₁ x₂ y₁
+              ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂),
+              Affine.Y_mem_of_X_mem W (Affine.nonsingular_add h₁ h₂ hPQ).1 hX_mem⟩
+          = residue A (W.toAffine.addY ⟨x₁, hx₁⟩ ⟨x₂, hx₂⟩ ⟨y₁, hy₁⟩
+              ⟨(W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂, hsmem⟩) :=
+            A.residue_eq_of_coe_eq _ hY_coe
+        _ = (W.map (residue A)).toAffine.addY (residue A ⟨x₁, hx₁⟩) (residue A ⟨x₂, hx₂⟩)
+              (residue A ⟨y₁, hy₁⟩)
+              (residue A ⟨(W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂, hsmem⟩) :=
+            (Affine.map_addY (W' := W) (residue A) (⟨x₁, hx₁⟩ : A) (⟨y₁, hy₁⟩ : A)
+              (⟨x₂, hx₂⟩ : A)
+              ⟨(W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂, hsmem⟩).symm
+        _ = _ := by rw [hsres]
+
+end IntegralCase
+
+section KernelCase
+
+variable [DecidableEq L] [DecidableEq (ResidueField A)]
+variable {W} (hΔ : (W.map (residue A)).Δ ≠ 0)
+
+theorem reducePoint_add_of_notMem_of_notMem {x₁ y₁ x₂ y₂ : L}
+    (h₁ : (W.map A.subtype).toAffine.Nonsingular x₁ y₁)
+    (h₂ : (W.map A.subtype).toAffine.Nonsingular x₂ y₂) (hx₁ : x₁ ∉ A) (hx₂ : x₂ ∉ A) :
+    reducePoint hΔ (.some x₁ y₁ h₁ + .some x₂ y₂ h₂) =
+      reducePoint hΔ (.some x₁ y₁ h₁) + reducePoint hΔ (.some x₂ y₂ h₂) := by
+  rw [reducePoint_some_of_notMem _ _ hx₁, reducePoint_some_of_notMem _ _ hx₂, add_zero]
+  by_cases hPQ : x₁ = x₂ ∧ y₁ = (W.map A.subtype).toAffine.negY x₂ y₂
+  · rw [Affine.Point.add_of_Y_eq hPQ.1 hPQ.2, reducePoint_zero]
+  · have hy₁0 : y₁ ≠ 0 := Affine.Y_ne_zero_of_X_notMem W h₁.1 hx₁
+    have hy₂0 : y₂ ≠ 0 := Affine.Y_ne_zero_of_X_notMem W h₂.1 hx₂
+    have hx₁0 : x₁ ≠ 0 := fun h => hx₁ (h ▸ A.zero_mem)
+    have hx₂0 : x₂ ≠ 0 := fun h => hx₂ (h ▸ A.zero_mem)
+    have ht₁m : x₁ / y₁ ∈ A.nonunits := Affine.X_div_Y_mem_nonunits W h₁.1 hx₁
+    have ht₂m : x₂ / y₂ ∈ A.nonunits := Affine.X_div_Y_mem_nonunits W h₂.1 hx₂
+    have ht₁0 : x₁ / y₁ ≠ 0 := div_ne_zero hx₁0 hy₁0
+    have ht₂0 : x₂ / y₂ ≠ 0 := div_ne_zero hx₂0 hy₂0
+    have haddX : (W.map A.subtype).toAffine.addX x₁ x₂
+        ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂) ∉ A := by
+      rcases A.mem_or_inv_mem ((x₁ / y₁) / (x₂ / y₂)) with hcase | hcase
+      · refine (Affine.add_formal_param_estimate h₁.1 h₂.1 hx₁ hx₂ hPQ ht₂m ht₂0 hcase ?_).1
+        rw [div_self ht₂0]
+        exact A.one_mem
+      · rw [show ((x₁ / y₁) / (x₂ / y₂))⁻¹ = (x₂ / y₂) / (x₁ / y₁) by rw [inv_div]] at hcase
+        refine (Affine.add_formal_param_estimate h₁.1 h₂.1 hx₁ hx₂ hPQ ht₁m ht₁0 ?_ hcase).1
+        rw [div_self ht₁0]
+        exact A.one_mem
+    rw [Affine.Point.add_some hPQ]
+    exact reducePoint_some_of_notMem _ _ haddX
+
+end KernelCase
+
+section MixedCase
+
+variable [DecidableEq L] [DecidableEq (ResidueField A)]
+variable {W} (hΔ : (W.map (residue A)).Δ ≠ 0)
+
+theorem reducePoint_add_of_mem_of_notMem {x₁ y₁ x₂ y₂ : L}
+    (h₁ : (W.map A.subtype).toAffine.Nonsingular x₁ y₁)
+    (h₂ : (W.map A.subtype).toAffine.Nonsingular x₂ y₂) (hx₁ : x₁ ∈ A) (hx₂ : x₂ ∉ A) :
+    reducePoint hΔ (.some x₁ y₁ h₁ + .some x₂ y₂ h₂) =
+      reducePoint hΔ (.some x₁ y₁ h₁) + reducePoint hΔ (.some x₂ y₂ h₂) := by
+  rw [reducePoint_some_of_notMem _ _ hx₂, add_zero]
+  have hPn : (W.map A.subtype).toAffine.Nonsingular x₁ ((W.map A.subtype).toAffine.negY x₁ y₁) :=
+    (Affine.nonsingular_neg _ _).mpr h₁
+  have hQn : (W.map A.subtype).toAffine.Nonsingular x₂ ((W.map A.subtype).toAffine.negY x₂ y₂) :=
+    (Affine.nonsingular_neg _ _).mpr h₂
+  have hPneg : (.some x₁ ((W.map A.subtype).toAffine.negY x₁ y₁) hPn :
+      (W.map A.subtype).toAffine.Point) = -(.some x₁ y₁ h₁) := (Affine.Point.neg_some h₁).symm
+  have hQneg : (.some x₂ ((W.map A.subtype).toAffine.negY x₂ y₂) hQn :
+      (W.map A.subtype).toAffine.Point) = -(.some x₂ y₂ h₂) := (Affine.Point.neg_some h₂).symm
+  cases hadd : (.some x₁ y₁ h₁ + .some x₂ y₂ h₂ : (W.map A.subtype).toAffine.Point) with
+  | zero =>
+    exfalso
+    have hP : (.some x₁ y₁ h₁ : (W.map A.subtype).toAffine.Point) = -(.some x₂ y₂ h₂) :=
+      eq_neg_of_add_eq_zero_left hadd
+    rw [← hQneg] at hP
+    simp only [Affine.Point.some.injEq] at hP
+    exact hx₂ (hP.1 ▸ hx₁)
+  | some X₃ Y₃ h₃ =>
+    by_cases hX₃ : X₃ ∈ A
+    · have hint := reducePoint_add_of_mem hΔ h₃ hPn hX₃ hx₁
+      have hSnegP : (.some X₃ Y₃ h₃ : (W.map A.subtype).toAffine.Point) +
+          .some x₁ ((W.map A.subtype).toAffine.negY x₁ y₁) hPn = .some x₂ y₂ h₂ := by
+        rw [hPneg, ← hadd]; abel
+      rw [hSnegP, reducePoint_some_of_notMem _ _ hx₂, hPneg, reducePoint_neg,
+        ← sub_eq_add_neg] at hint
+      exact (sub_eq_zero.mp hint.symm)
+    · exfalso
+      have hker := reducePoint_add_of_notMem_of_notMem hΔ h₃ hQn hX₃ hx₂
+      have hSnegQ : (.some X₃ Y₃ h₃ : (W.map A.subtype).toAffine.Point) +
+          .some x₂ ((W.map A.subtype).toAffine.negY x₂ y₂) hQn = .some x₁ y₁ h₁ := by
+        rw [hQneg, ← hadd]; abel
+      rw [hSnegQ, reducePoint_some_of_mem _ _ hx₁, reducePoint_some_of_notMem _ _ hX₃,
+        reducePoint_some_of_notMem _ _ hx₂, add_zero] at hker
+      injection hker
+
+end MixedCase
+
+section Homomorphism
+
+variable [DecidableEq L] [DecidableEq (ResidueField A)]
+variable {W} (hΔ : (W.map (residue A)).Δ ≠ 0)
+
+theorem reducePoint_add_def (P Q : (W.map A.subtype).toAffine.Point) :
+    reducePoint hΔ (P + Q) = reducePoint hΔ P + reducePoint hΔ Q := by
+  cases P with
+  | zero =>
+    change reducePoint hΔ ((0 : (W.map A.subtype).toAffine.Point) + Q) =
+      reducePoint hΔ (0 : (W.map A.subtype).toAffine.Point) + reducePoint hΔ Q
+    rw [zero_add, reducePoint_zero, zero_add]
+  | some x₁ y₁ h₁ =>
+    cases Q with
+    | zero =>
+      change reducePoint hΔ (.some x₁ y₁ h₁ + (0 : (W.map A.subtype).toAffine.Point)) =
+        reducePoint hΔ (.some x₁ y₁ h₁) + reducePoint hΔ (0 : (W.map A.subtype).toAffine.Point)
+      rw [add_zero, reducePoint_zero, add_zero]
+    | some x₂ y₂ h₂ =>
+      by_cases hx₁ : x₁ ∈ A <;> by_cases hx₂ : x₂ ∈ A
+      · exact reducePoint_add_of_mem hΔ h₁ h₂ hx₁ hx₂
+      · exact reducePoint_add_of_mem_of_notMem hΔ h₁ h₂ hx₁ hx₂
+      · rw [add_comm, add_comm (reducePoint hΔ (.some x₁ y₁ h₁))]
+        exact reducePoint_add_of_mem_of_notMem hΔ h₂ h₁ hx₂ hx₁
+      · exact reducePoint_add_of_notMem_of_notMem hΔ h₁ h₂ hx₁ hx₂
+
+noncomputable def reduceHom :
+    (W.map A.subtype).toAffine.Point →+ (W.map (residue A)).toAffine.Point where
+  toFun := reducePoint hΔ
+  map_zero' := reducePoint_zero hΔ
+  map_add' := reducePoint_add_def hΔ
+
+end Homomorphism
+
+end WeierstrassCurve
+
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_ReductionMap.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_ReductionMap.lean
new file mode 100644
index 0000000000..0fde8a4964
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_ReductionMap.lean
@@ -0,0 +1,297 @@
+/-
+Based on Prove2Me node WeierstrassCurve_ReductionMap
+(b2456017-3633-5aa3-a641-d221438b26e6) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Ramification
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FreyPackage_GaloisRep
+public import Mathlib.RingTheory.Valuation.RamificationGroup
+public import Mathlib.RingTheory.Valuation.LocalSubring
+
+/-!
+# Reduction of Weierstrass points along a valuation subring
+
+Definition: `WeierstrassCurve_ReductionMap` (`b2456017-3633-5aa3-a641-d221438b26e6`), by Claude,
+2026-09-05.
+
+Let $L$ be a field, $A \subseteq L$ a valuation subring with residue field $\kappa_A$, and $W$ a
+Weierstrass curve over $A$, i.e. a tuple $a_1,a_2,a_3,a_4,a_6 \in A$. Writing $W_L$ for the base
+change along the inclusion $A \to L$ and $\tilde W$ for the base change along the residue map $A \to
+\kappa_A$, the main definition
+[`WeierstrassCurve.reducePoint`](../def/WeierstrassCurve_ReductionMap.html#L157) takes a hypothesis
+$h_\Delta$ asserting $\Delta(\tilde W) \neq 0$ and produces a map from the affine points of $W_L$ to
+the affine points of $\tilde W$: the point at infinity goes to the point at infinity; an affine
+point $(x,y)$ goes to $(\bar x, \bar y)$ if $x \in A$, and to the point at infinity otherwise. This
+is a map of pointed sets defined by cases, not yet a homomorphism. Two facts make it well posed:
+`Affine.Y_mem_of_X_mem`, which says that a solution of the Weierstrass equation of $W_L$ with $x \in
+A$ automatically has $y \in A$ (otherwise $1$ would lie in the nonunits of $A$), and
+`Affine.nonsingular_residue`, which upgrades the reduced equation to nonsingularity using
+$\Delta(\tilde W) \neq 0$. The criterion `map_residue_Δ_ne_zero_iff` identifies that hypothesis with
+$\Delta(W)$ being a unit of $A$.
+
+The equational lemmas record the three branches, and `reducePoint_neg` states that reduction
+commutes with negation. Under a $K$-algebra structure on $L$,
+`reducePoint_some_apply_of_mem_inertia` states that if $\sigma : L \simeq_K L$ stabilises $A$ and
+acts trivially on $\kappa_A$, then $(\sigma x, \sigma y)$ and $(x,y)$ have the same reduction; this
+rests on `smul_mem_of_mem_decompositionSubgroup` ($\sigma$ preserves $A$) and
+`residue_smul_eq_of_mem_inertiaSubgroup`. Further supporting lemmas concern the predicate
+`LiesOverPrime A q`, which says that $q \in L$ is a nonunit of $A$: such an $A$ has $q$ in its
+maximal ideal and residue field of characteristic $q$ (`charP_residueField_of_liesOverPrime_def`),
+and for $L$ of characteristic zero and $q$ prime such an $A$ exists (`exists_liesOverPrime`).
+Finally, `mem_inertiaSubgroupIn` unfolds membership in the image of the inertia subgroup inside $L
+\simeq_K L$.
+
+**Relation to Mathlib.** Mathlib supplies `WeierstrassCurve`, affine points, base change, and the
+decomposition and inertia subgroups of a valuation subring; the reduction map on points along a
+valuation subring, the predicate `LiesOverPrime` and the subgroup `inertiaSubgroupIn` of $L \simeq_K
+L$ are the project's own.
+
+**Where it is used.** The reduction map is the basis for comparing the $p$-torsion of the Frey curve
+with the points of its special fibre, and `reducePoint_some_apply_of_mem_inertia` is the
+computational input to the statement that the mod $p$ Galois representation is unramified at a prime
+of good reduction.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open IsLocalRing
+
+namespace ValuationSubring
+
+variable {L : Type*} [Field L]
+
+lemma liesOverPrime_iff {A : ValuationSubring L} {q : ℕ} :
+    A.LiesOverPrime q ↔ (q : L) ∈ A.nonunits :=
+  Iff.rfl
+
+lemma natCast_mem' (A : ValuationSubring L) (q : ℕ) : (q : L) ∈ A :=
+  natCast_mem A.toSubring q
+
+lemma natCast_mem_maximalIdeal_of_liesOverPrime {A : ValuationSubring L} {q : ℕ}
+    (h : A.LiesOverPrime q) : (q : A) ∈ IsLocalRing.maximalIdeal A := by
+  have : ((q : A) : L) ∈ A.nonunits := by
+    simpa using liesOverPrime_iff.mp h
+  exact A.coe_mem_nonunits_iff.mp this
+
+theorem exists_liesOverPrime [CharZero L] {q : ℕ} (hq : q.Prime) :
+    ∃ A : ValuationSubring L, A.LiesOverPrime q := by
+  set R : Subring L := ⊥ with hR
+  have hqR : ¬IsUnit ((q : ℕ) : R) := by
+    rw [isUnit_iff_exists_inv]
+    rintro ⟨y, hy⟩
+    have hy' : (q : L) * (y : L) = 1 := by
+      have := congrArg (R.subtype) hy
+      simpa using this
+    obtain ⟨n, hn⟩ := Subring.mem_bot.mp y.2
+    rw [← hn] at hy'
+    have hqn : (q : ℤ) * n = 1 := by
+      have : (((q : ℤ) * n : ℤ) : L) = ((1 : ℤ) : L) := by push_cast; linear_combination hy'
+      exact_mod_cast this
+    have h1 : (q : ℤ) ≤ 1 := Int.le_of_dvd one_pos ⟨n, hqn.symm⟩
+    have h2 : 2 ≤ q := hq.two_le
+    omega
+  obtain ⟨B, -, hB⟩ :=
+    Ideal.image_subset_nonunits_valuationSubring (Ideal.span {((q : ℕ) : R)})
+      (fun h => hqR (Ideal.span_singleton_eq_top.mp h))
+  refine ⟨B, hB ⟨((q : ℕ) : R), Ideal.subset_span rfl, ?_⟩⟩
+  simp
+
+theorem charP_residueField_of_liesOverPrime_def {A : ValuationSubring L} {q : ℕ} (hq : q.Prime)
+    (h : A.LiesOverPrime q) : CharP (IsLocalRing.ResidueField A) q := by
+  rw [CharP.charP_iff_prime_eq_zero hq]
+  have : ((q : ℕ) : IsLocalRing.ResidueField A) = IsLocalRing.residue A ((q : ℕ) : A) := by
+    simp
+  rw [this]
+  exact Ideal.Quotient.eq_zero_iff_mem.mpr (natCast_mem_maximalIdeal_of_liesOverPrime h)
+
+variable (K : Type*) [Field K] [Algebra K L]
+
+lemma mem_inertiaSubgroupIn {A : ValuationSubring L} {σ : L ≃ₐ[K] L} :
+    σ ∈ A.inertiaSubgroupIn K ↔
+      ∃ h : σ ∈ A.decompositionSubgroup K, (⟨σ, h⟩ : A.decompositionSubgroup K) ∈
+        A.inertiaSubgroup K := by
+  constructor
+  · rintro ⟨⟨τ, hτ⟩, hτI, rfl⟩
+    exact ⟨hτ, hτI⟩
+  · rintro ⟨h, hI⟩
+    exact ⟨⟨σ, h⟩, hI, rfl⟩
+
+end ValuationSubring
+
+namespace ValuationSubring
+
+variable {L : Type*} [Field L] {A : ValuationSubring L}
+
+theorem mul_mem_nonunits {a x : L} (ha : a ∈ A) (hx : x ∈ A.nonunits) :
+    a * x ∈ A.nonunits := by
+  rw [mem_nonunits_iff] at hx ⊢
+  calc A.valuation (a * x) = A.valuation a * A.valuation x := map_mul _ _ _
+    _ ≤ 1 * A.valuation x := mul_le_mul_left ((A.valuation_le_one_iff a).mpr ha) _
+    _ = A.valuation x := one_mul _
+    _ < 1 := hx
+
+theorem one_notMem_nonunits : (1 : L) ∉ A.nonunits := by
+  simp [mem_nonunits_iff]
+
+end ValuationSubring
+
+namespace WeierstrassCurve
+
+variable {L : Type*} [Field L] {A : ValuationSubring L}
+
+private lemma some_congr {R : Type*} [CommRing R] {V : Affine R} {x₁ x₂ y₁ y₂ : R}
+    (hx : x₁ = x₂) (hy : y₁ = y₂) (h₁ : V.Nonsingular x₁ y₁) (h₂ : V.Nonsingular x₂ y₂) :
+    Affine.Point.some x₁ y₁ h₁ = Affine.Point.some x₂ y₂ h₂ := by
+  subst hx; subst hy; rfl
+
+variable (W : WeierstrassCurve A)
+
+theorem Affine.Y_mem_of_X_mem {x y : L}
+    (h : (W.map A.subtype).toAffine.Equation x y) (hx : x ∈ A) : y ∈ A := by
+  by_contra hy
+  have hy0 : y ≠ 0 := fun h0 => hy (h0 ▸ A.zero_mem)
+  have hyinv : y⁻¹ ∈ A.nonunits := A.inv_mem_nonunits_iff.mpr (Or.inr hy)
+  rw [equation_iff] at h
+  have key : (1 : L) =
+      (x ^ 3 + (W.map A.subtype).toAffine.a₂ * x ^ 2 + (W.map A.subtype).toAffine.a₄ * x
+          + (W.map A.subtype).toAffine.a₆) * (y⁻¹ * y⁻¹)
+        - (W.map A.subtype).toAffine.a₁ * x * y⁻¹
+        - (W.map A.subtype).toAffine.a₃ * y⁻¹ := by
+    field_simp
+    linear_combination h
+  refine A.one_notMem_nonunits ?_
+  rw [key]
+  have ha₁ : (W.map A.subtype).toAffine.a₁ ∈ A := SetLike.coe_mem W.a₁
+  have ha₂ : (W.map A.subtype).toAffine.a₂ ∈ A := SetLike.coe_mem W.a₂
+  have ha₃ : (W.map A.subtype).toAffine.a₃ ∈ A := SetLike.coe_mem W.a₃
+  have ha₄ : (W.map A.subtype).toAffine.a₄ ∈ A := SetLike.coe_mem W.a₄
+  have ha₆ : (W.map A.subtype).toAffine.a₆ ∈ A := SetLike.coe_mem W.a₆
+  have hcubic : x ^ 3 + (W.map A.subtype).toAffine.a₂ * x ^ 2
+      + (W.map A.subtype).toAffine.a₄ * x + (W.map A.subtype).toAffine.a₆ ∈ A :=
+    add_mem (add_mem (add_mem (pow_mem hx 3) (mul_mem ha₂ (pow_mem hx 2))) (mul_mem ha₄ hx)) ha₆
+  exact sub_mem (sub_mem (A.mul_mem_nonunits hcubic (mul_mem hyinv hyinv))
+      (A.mul_mem_nonunits (mul_mem ha₁ hx) hyinv))
+    (A.mul_mem_nonunits ha₃ hyinv)
+
+theorem map_residue_Δ_ne_zero_iff : (W.map (residue A)).Δ ≠ 0 ↔ IsUnit W.Δ := by
+  rw [map_Δ]
+  exact residue_ne_zero_iff_isUnit W.Δ
+
+theorem Affine.equation_residue {x y : A}
+    (h : (W.map A.subtype).toAffine.Equation (x : L) (y : L)) :
+    (W.map (residue A)).toAffine.Equation (residue A x) (residue A y) := by
+  have hA : W.toAffine.Equation x y := (W.toAffine.map_equation A.subtype_injective x y).mp h
+  exact hA.map (residue A)
+
+theorem Affine.nonsingular_residue (hΔ : (W.map (residue A)).Δ ≠ 0) {x y : A}
+    (h : (W.map A.subtype).toAffine.Equation (x : L) (y : L)) :
+    (W.map (residue A)).toAffine.Nonsingular (residue A x) (residue A y) :=
+  (Affine.equation_iff_nonsingular_of_Δ_ne_zero hΔ).mp (Affine.equation_residue W h)
+
+variable {W}
+
+open Classical in
+noncomputable def reducePoint (hΔ : (W.map (residue A)).Δ ≠ 0) :
+    (W.map A.subtype).toAffine.Point → (W.map (residue A)).toAffine.Point
+  | .zero => .zero
+  | .some x y h =>
+    if hx : x ∈ A then
+      .some (residue A ⟨x, hx⟩) (residue A ⟨y, Affine.Y_mem_of_X_mem W h.1 hx⟩)
+        (Affine.nonsingular_residue W hΔ h.1)
+    else
+      .zero
+
+variable (hΔ : (W.map (residue A)).Δ ≠ 0)
+
+@[simp]
+lemma reducePoint_zero : reducePoint hΔ (0 : (W.map A.subtype).toAffine.Point) = 0 :=
+  rfl
+
+lemma reducePoint_some_of_mem {x y : L} (h : (W.map A.subtype).toAffine.Nonsingular x y)
+    (hx : x ∈ A) :
+    reducePoint hΔ (.some x y h) =
+      .some (residue A ⟨x, hx⟩) (residue A ⟨y, Affine.Y_mem_of_X_mem W h.1 hx⟩)
+        (Affine.nonsingular_residue W hΔ h.1) := by
+  simp only [reducePoint]
+  exact dite_eq_left hx
+
+lemma reducePoint_some_of_notMem {x y : L} (h : (W.map A.subtype).toAffine.Nonsingular x y)
+    (hx : x ∉ A) : reducePoint hΔ (.some x y h) = 0 := by
+  simp only [reducePoint]
+  exact dite_eq_right hx
+
+theorem reducePoint_neg (P : (W.map A.subtype).toAffine.Point) :
+    reducePoint hΔ (-P) = -reducePoint hΔ P := by
+  cases P with
+  | zero => rfl
+  | some x y h =>
+    rw [Affine.Point.neg_some]
+    by_cases hx : x ∈ A
+    · have hy : y ∈ A := Affine.Y_mem_of_X_mem W h.1 hx
+      rw [reducePoint_some_of_mem _ _ hx, reducePoint_some_of_mem _ _ hx,
+        Affine.Point.neg_some]
+      refine some_congr rfl ?_ _ _
+      change residue A (W.toAffine.negY ⟨x, hx⟩ ⟨y, hy⟩) = _
+      exact (Affine.map_negY (residue A) (⟨x, hx⟩ : A) (⟨y, hy⟩ : A)).symm
+    · rw [reducePoint_some_of_notMem _ _ hx, reducePoint_some_of_notMem _ _ hx]
+      rfl
+
+section Inertia
+
+open scoped Pointwise
+
+variable (K : Type*) [Field K] [Algebra K L]
+
+theorem _root_.ValuationSubring.smul_mem_of_mem_decompositionSubgroup {σ : L ≃ₐ[K] L}
+    (hσ : σ ∈ A.decompositionSubgroup K) {z : L} (hz : z ∈ A) : σ z ∈ A := by
+  have h1 : σ • z ∈ σ • A := ValuationSubring.smul_mem_pointwise_smul σ z A hz
+  rwa [MulAction.mem_stabilizer_iff.mp hσ, AlgEquiv.smul_def] at h1
+
+variable {K}
+
+theorem _root_.ValuationSubring.residue_smul_eq_of_mem_inertiaSubgroup
+    {σ : L ≃ₐ[K] L} (hσ : σ ∈ A.decompositionSubgroup K)
+    (hσI : (⟨σ, hσ⟩ : A.decompositionSubgroup K) ∈ A.inertiaSubgroup K) (a : A) :
+    residue A ((⟨σ, hσ⟩ : A.decompositionSubgroup K) • a) = residue A a := by
+  have h1 : MulSemiringAction.toRingAut (A.decompositionSubgroup K) (ResidueField A)
+      ⟨σ, hσ⟩ = 1 := hσI
+  calc residue A ((⟨σ, hσ⟩ : A.decompositionSubgroup K) • a)
+      = (⟨σ, hσ⟩ : A.decompositionSubgroup K) • residue A a := rfl
+    _ = MulSemiringAction.toRingAut (A.decompositionSubgroup K) (ResidueField A)
+          ⟨σ, hσ⟩ (residue A a) := rfl
+    _ = residue A a := by rw [h1]; rfl
+
+theorem reducePoint_some_apply_of_mem_inertia {σ : L ≃ₐ[K] L}
+    (hσ : σ ∈ A.decompositionSubgroup K)
+    (hσI : (⟨σ, hσ⟩ : A.decompositionSubgroup K) ∈ A.inertiaSubgroup K)
+    {x y : L} (h : (W.map A.subtype).toAffine.Nonsingular x y)
+    (h' : (W.map A.subtype).toAffine.Nonsingular (σ x) (σ y)) :
+    reducePoint hΔ (.some (σ x) (σ y) h') = reducePoint hΔ (.some x y h) := by
+  by_cases hx : x ∈ A
+  · have hy : y ∈ A := Affine.Y_mem_of_X_mem W h.1 hx
+    have hσx : σ x ∈ A := A.smul_mem_of_mem_decompositionSubgroup K hσ hx
+    have hσy : σ y ∈ A := A.smul_mem_of_mem_decompositionSubgroup K hσ hy
+    rw [reducePoint_some_of_mem _ _ hσx, reducePoint_some_of_mem _ _ hx]
+    refine some_congr ?_ ?_ _ _
+    · calc residue A (⟨σ x, hσx⟩ : A)
+          = residue A ((⟨σ, hσ⟩ : A.decompositionSubgroup K) • (⟨x, hx⟩ : A)) := rfl
+        _ = residue A (⟨x, hx⟩ : A) := A.residue_smul_eq_of_mem_inertiaSubgroup hσ hσI _
+    · calc residue A (⟨σ y, hσy⟩ : A)
+          = residue A ((⟨σ, hσ⟩ : A.decompositionSubgroup K) • (⟨y, hy⟩ : A)) := rfl
+        _ = residue A (⟨y, hy⟩ : A) := A.residue_smul_eq_of_mem_inertiaSubgroup hσ hσI _
+  · have hσx : σ x ∉ A := fun hmem => hx (by
+      simpa using A.smul_mem_of_mem_decompositionSubgroup K (inv_mem hσ) hmem)
+    rw [reducePoint_some_of_notMem _ _ hσx, reducePoint_some_of_notMem _ _ hx]
+
+end Inertia
+
+end WeierstrassCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_TorsionIntegral.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_TorsionIntegral.lean
new file mode 100644
index 0000000000..49a564dcab
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_TorsionIntegral.lean
@@ -0,0 +1,1228 @@
+/-
+Based on Prove2Me node WeierstrassCurve_TorsionIntegral
+(85e72084-5eb9-57ab-91cc-e3a8d633f02a) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_ReductionMap
+
+/-!
+# Valuation estimates for Weierstrass points with non-integral coordinates
+
+Definition: `WeierstrassCurve_TorsionIntegral` (`85e72084-5eb9-57ab-91cc-e3a8d633f02a`), by Claude,
+2026-09-05.
+
+The module works with a field $L$, a valuation subring $A \subseteq L$ and a Weierstrass curve $W$
+over $A$, whose base change along the inclusion $A \hookrightarrow L$ is the curve $W.map A.subtype$
+over $L$ and whose reduction is $W.map (residue A)$ over the residue field. Two kinds of statements
+are proved. First, arithmetic of $A$ and its set of nonunits $A.nonunits$ (the elements of valuation
+$<1$): the sum of a non-element and an element, the product of two non-elements, and a quotient
+$a/b$ with $a \notin A.nonunits$ and $b \ne 0$ a nonunit all lie outside $A$ (`add_notMem`,
+`mul_notMem`, `div_notMem`); membership in $A.nonunits$ of an element of $A$ is equivalent to
+vanishing of its residue, and for a natural number $n$ to $(n : \mathrm{ResidueField}\,A) = 0$;
+inverses of nonunits of $A$, of non-elements and of units are located (`inv_mem_of_notMem_nonunits`,
+`inv_mem_nonunits_of_notMem`, `mul_notMem_nonunits`, `one_add_notMem_nonunits`).
+
+Second, estimates for affine points. For an affine point $(x,y)$ with $x \in A$ and $\Delta$ of the
+reduced curve nonzero, if $y - \mathrm{negY}(x,y)$ is a nonunit then the partial derivative $3x^2 +
+2a_2x + a_4 - a_1y$ is a unit; consequently, for two points $(x_1,y_1)$, $(x_2,y_2)$ with $x_1, x_2
+\in A$ such that $x_1 - x_2$ and $y_1 - \mathrm{negY}(x_2,y_2)$ are nonunits while $(x_1,y_1) \ne
+(x_2,\mathrm{negY}(x_2,y_2))$, the slope and the resulting $\mathrm{addX}$ lie outside $A$
+(`slope_notMem_of_sub_mem_nonunits`, `addX_notMem_of_sub_mem_nonunits`). For $x \notin A$ one gets
+$y \neq 0$, $y \notin A$, $x/y \in A.nonunits$ and $x^3/y^2$ a unit of $A$; the formal parameter $t
+= -x/y$ satisfies $t(-P) \equiv -t(P)$ and, via Vieta relations for $\mathrm{addX}$ and explicit
+secant and tangent identities, $t(P \oplus Q) - t(P) - t(Q)$ lies in $\tau\cdot A.nonunits$ whenever
+$t(P), t(Q) \in \tau A$ for a nonunit $\tau \neq 0$ (`add_formal_param_estimate`). Iterating,
+`formal_param_nsmul` shows for each $j$ that $j \cdot P = 0$ forces $(j : L)$ to be a nonunit, and
+that $j \cdot P = P'$ forces $x' \notin A$ and $t(P')/t(P) \equiv j$. Hence
+`X_mem_of_nsmul_eq_zero'`: if $n$ is invertible in the residue field and $P = (x,y)$ satisfies $n
+\cdot P = 0$, then $x \in A$. Finally, `some_eq_of_mem_inertia_of_nsmul_eq_zero'` and
+`fixed_of_mem_inertia_of_nsmul_eq_zero` state that an element $\sigma$ of the decomposition group of
+$A$ over a base field $K$ lying in the inertia subgroup fixes such an $n$-torsion point when the
+reduced discriminant is nonzero and $(\sigma x, \sigma y)$ is again $n$-torsion: $\sigma x = x$ and
+$\sigma y = y$.
+
+**Relation to Mathlib.** Mathlib supplies Weierstrass curves, their affine points with the
+chord–tangent group law, `slope`, `addX`, `addY`, `negY`, valuation subrings with their nonunits and
+residue field, and decomposition and inertia subgroups; the valuation estimates for points with
+non-integral coordinates, the formal-parameter congruences and the integrality of
+prime-to-residue-characteristic torsion proved here are the project's own.
+
+**Where it is used.** These estimates support the reduction map on points of a Weierstrass curve
+over a valuation subring: integrality of $n$-torsion when $n$ is invertible in the residue field,
+and the resulting triviality of the inertia action on such torsion, are what makes the mod-$p$
+Galois representation attached to the Frey curve unramified away from the relevant primes.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open IsLocalRing
+
+namespace ValuationSubring
+
+variable {L : Type*} [Field L] (A : ValuationSubring L)
+
+theorem add_notMem {x a : L} (hx : x ∉ A) (ha : a ∈ A) : x + a ∉ A := fun h =>
+  hx (by simpa using A.toSubring.sub_mem h ha)
+
+theorem mul_notMem {x y : L} (hx : x ∉ A) (hy : y ∉ A) : x * y ∉ A := fun h => by
+  rcases A.mem_or_inv_mem x with hx' | hx'
+  · exact hx hx'
+  · have hx0 : x ≠ 0 := fun h0 => hx (h0 ▸ A.zero_mem)
+    exact hy (by simpa [inv_mul_cancel_left₀ hx0] using A.toSubring.mul_mem hx' h)
+
+theorem div_notMem {a b : L} (ha' : a ∉ A.nonunits) (hb : b ∈ A.nonunits) (hb0 : b ≠ 0) :
+    a / b ∉ A := fun h => by
+  refine ha' ?_
+  rw [show a = a / b * b from (div_mul_cancel₀ a hb0).symm]
+  exact A.mul_mem_nonunits h hb
+
+theorem coe_mem_nonunits_iff_residue_eq_zero (e : A) :
+    (e : L) ∈ A.nonunits ↔ residue A e = 0 := by
+  rw [A.coe_mem_nonunits_iff, residue_eq_zero_iff]
+
+end ValuationSubring
+
+namespace WeierstrassCurve
+
+namespace Affine
+
+theorem sub_mul_sub_negY {R : Type*} [CommRing R] {V : Affine R} {x₁ x₂ y₁ y₂ : R}
+    (h₁ : V.Equation x₁ y₁) (h₂ : V.Equation x₂ y₂) :
+    (y₁ - y₂) * (y₁ - V.negY x₂ y₂) =
+      (x₁ - x₂) * (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + V.a₂ * (x₁ + x₂) + V.a₄ - V.a₁ * y₁) := by
+  rw [equation_iff] at h₁ h₂
+  rw [negY]
+  linear_combination h₁ - h₂
+
+end Affine
+
+variable {L : Type*} [Field L] {A : ValuationSubring L} (W : WeierstrassCurve A)
+
+theorem Affine.notMem_nonunits_of_sub_negY_mem_nonunits (hΔ : (W.map (residue A)).Δ ≠ 0)
+    {x y : L} (h : (W.map A.subtype).toAffine.Equation x y) (hx : x ∈ A)
+    (hY : y - (W.map A.subtype).toAffine.negY x y ∈ A.nonunits) :
+    3 * x ^ 2 + 2 * (W.map A.subtype).toAffine.a₂ * x + (W.map A.subtype).toAffine.a₄ -
+      (W.map A.subtype).toAffine.a₁ * y ∉ A.nonunits := by
+  have hy : y ∈ A := Affine.Y_mem_of_X_mem W h hx
+  set eX : A := 3 * ⟨x, hx⟩ ^ 2 + 2 * W.a₂ * ⟨x, hx⟩ + W.a₄ - W.a₁ * ⟨y, hy⟩ with heX
+  set eY : A := ⟨y, hy⟩ - W.toAffine.negY ⟨x, hx⟩ ⟨y, hy⟩ with heY
+  have hcoeX : (eX : L) = 3 * x ^ 2 + 2 * (W.map A.subtype).toAffine.a₂ * x +
+      (W.map A.subtype).toAffine.a₄ - (W.map A.subtype).toAffine.a₁ * y := by
+    push_cast [heX]
+    rfl
+  have hcoeY : (eY : L) = y - (W.map A.subtype).toAffine.negY x y := by
+    have h1 : ((W.toAffine.negY ⟨x, hx⟩ ⟨y, hy⟩ : A) : L) = (W.map A.subtype).toAffine.negY x y :=
+      (Affine.map_negY A.subtype (⟨x, hx⟩ : A) (⟨y, hy⟩ : A)).symm
+    rw [heY]
+    push_cast
+    rw [h1]
+  have hns := Affine.nonsingular_residue W hΔ (x := ⟨x, hx⟩) (y := ⟨y, hy⟩) h
+  rw [Affine.nonsingular_iff] at hns
+  have hY0 : residue A eY = 0 := by
+    rw [← A.coe_mem_nonunits_iff_residue_eq_zero, hcoeY]
+    exact hY
+  have hX0 : residue A eX ≠ 0 := by
+    rcases hns.2 with hX | hY'
+    · intro h0
+      apply hX
+      rw [heX] at h0
+      simp only [map_sub, map_add, map_mul, map_pow, map_ofNat] at h0
+      change residue A W.a₁ * residue A ⟨y, hy⟩ = 3 * residue A ⟨x, hx⟩ ^ 2 +
+        2 * residue A W.a₂ * residue A ⟨x, hx⟩ + residue A W.a₄
+      linear_combination -h0
+    · exact absurd (by
+        change residue A ⟨y, hy⟩ = -residue A ⟨y, hy⟩ - residue A W.a₁ * residue A ⟨x, hx⟩ -
+          residue A W.a₃
+        rw [heY] at hY0
+        simp only [Affine.negY, map_sub, map_neg, map_mul] at hY0
+        linear_combination hY0) hY'
+  rw [← hcoeX, A.coe_mem_nonunits_iff_residue_eq_zero]
+  exact hX0
+
+section Slope
+
+variable [DecidableEq L]
+
+theorem Affine.slope_notMem_of_sub_mem_nonunits (hΔ : (W.map (residue A)).Δ ≠ 0)
+    {x₁ x₂ y₁ y₂ : L} (h₁ : (W.map A.subtype).toAffine.Equation x₁ y₁)
+    (h₂ : (W.map A.subtype).toAffine.Equation x₂ y₂) (hx₁ : x₁ ∈ A) (hx₂ : x₂ ∈ A)
+    (hPQ : ¬(x₁ = x₂ ∧ y₁ = (W.map A.subtype).toAffine.negY x₂ y₂))
+    (hxx : x₁ - x₂ ∈ A.nonunits)
+    (hyy : y₁ - (W.map A.subtype).toAffine.negY x₂ y₂ ∈ A.nonunits) :
+    (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ ∉ A := by
+  have hy₁ : y₁ ∈ A := Affine.Y_mem_of_X_mem W h₁ hx₁
+  have hy₂ : y₂ ∈ A := Affine.Y_mem_of_X_mem W h₂ hx₂
+  have ha₁ : (W.map A.subtype).toAffine.a₁ ∈ A := SetLike.coe_mem W.a₁
+  have ha₂ : (W.map A.subtype).toAffine.a₂ ∈ A := SetLike.coe_mem W.a₂
+  have ha₃ : (W.map A.subtype).toAffine.a₃ ∈ A := SetLike.coe_mem W.a₃
+  have ha₄ : (W.map A.subtype).toAffine.a₄ ∈ A := SetLike.coe_mem W.a₄
+  have hnegY : (W.map A.subtype).toAffine.negY x₂ y₂ ∈ A := by
+    rw [Affine.negY]
+    exact A.toSubring.sub_mem (A.toSubring.sub_mem (A.toSubring.neg_mem hy₂)
+      (A.toSubring.mul_mem ha₁ hx₂)) ha₃
+  by_cases hx : x₁ = x₂
+  · have hy : y₁ ≠ (W.map A.subtype).toAffine.negY x₂ y₂ := fun h => hPQ ⟨hx, h⟩
+    have hy12 : y₁ = y₂ := (Affine.Y_eq_of_X_eq h₁ h₂ hx).resolve_right hy
+    rw [Affine.slope_of_Y_ne hx hy]
+    have hden : y₁ - (W.map A.subtype).toAffine.negY x₁ y₁ ∈ A.nonunits := by
+      rwa [← hx, ← hy12] at hyy
+    have hden0 : y₁ - (W.map A.subtype).toAffine.negY x₁ y₁ ≠ 0 := by
+      rw [sub_ne_zero]
+      intro hcon
+      exact hy (by rw [← hx, ← hy12]; exact hcon)
+    have hnum := Affine.notMem_nonunits_of_sub_negY_mem_nonunits W hΔ h₁ hx₁ hden
+    exact A.div_notMem hnum hden hden0
+  · by_cases hyy' : y₁ - y₂ ∈ A.nonunits
+    · rw [Affine.slope_of_X_ne hx]
+      have hden : y₁ - (W.map A.subtype).toAffine.negY x₁ y₁ ∈ A.nonunits := by
+        have key : y₁ - (W.map A.subtype).toAffine.negY x₁ y₁ =
+            (y₁ - (W.map A.subtype).toAffine.negY x₂ y₂) + (y₁ - y₂) +
+              (W.map A.subtype).toAffine.a₁ * (x₁ - x₂) := by
+          simp only [Affine.negY]
+          ring
+        rw [key]
+        exact add_mem (add_mem hyy hyy') (A.mul_mem_nonunits ha₁ hxx)
+      have hnum := Affine.notMem_nonunits_of_sub_negY_mem_nonunits W hΔ h₁ hx₁ hden
+      set N : L := x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + (W.map A.subtype).toAffine.a₂ * (x₁ + x₂) +
+        (W.map A.subtype).toAffine.a₄ - (W.map A.subtype).toAffine.a₁ * y₁ with hN
+      have hNunit : N ∉ A.nonunits := by
+        intro hmem
+        apply hnum
+        have key : 3 * x₁ ^ 2 + 2 * (W.map A.subtype).toAffine.a₂ * x₁ +
+            (W.map A.subtype).toAffine.a₄ - (W.map A.subtype).toAffine.a₁ * y₁ =
+            N - (x₁ + x₁ + x₂ + (W.map A.subtype).toAffine.a₂) * -(x₁ - x₂) := by
+          rw [hN]; ring
+        rw [key]
+        exact sub_mem hmem (A.mul_mem_nonunits
+          (add_mem (add_mem (add_mem hx₁ hx₁) hx₂) ha₂) (neg_mem hxx))
+      have hd0 : y₁ - (W.map A.subtype).toAffine.negY x₂ y₂ ≠ 0 := by
+        intro hd
+        apply hNunit
+        rw [hN]
+        have hid := Affine.sub_mul_sub_negY h₁ h₂
+        rw [hd, mul_zero] at hid
+        rcases mul_eq_zero.mp hid.symm with h | h
+        · exact absurd (sub_eq_zero.mp h) hx
+        · rw [h]
+          exact zero_mem _
+      have hslope : (y₁ - y₂) / (x₁ - x₂) = N / (y₁ - (W.map A.subtype).toAffine.negY x₂ y₂) := by
+        rw [div_eq_div_iff (sub_ne_zero.mpr hx) hd0, hN]
+        linear_combination Affine.sub_mul_sub_negY h₁ h₂
+      rw [hslope]
+      exact A.div_notMem hNunit hyy hd0
+    · rw [Affine.slope_of_X_ne hx]
+      exact A.div_notMem hyy' hxx (sub_ne_zero.mpr hx)
+
+theorem Affine.addX_notMem_of_sub_mem_nonunits (hΔ : (W.map (residue A)).Δ ≠ 0)
+    {x₁ x₂ y₁ y₂ : L} (h₁ : (W.map A.subtype).toAffine.Equation x₁ y₁)
+    (h₂ : (W.map A.subtype).toAffine.Equation x₂ y₂) (hx₁ : x₁ ∈ A) (hx₂ : x₂ ∈ A)
+    (hPQ : ¬(x₁ = x₂ ∧ y₁ = (W.map A.subtype).toAffine.negY x₂ y₂))
+    (hxx : x₁ - x₂ ∈ A.nonunits)
+    (hyy : y₁ - (W.map A.subtype).toAffine.negY x₂ y₂ ∈ A.nonunits) :
+    (W.map A.subtype).toAffine.addX x₁ x₂ ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂) ∉ A := by
+  have hℓ := Affine.slope_notMem_of_sub_mem_nonunits W hΔ h₁ h₂ hx₁ hx₂ hPQ hxx hyy
+  set ℓ : L := (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂
+  have ha₁ : (W.map A.subtype).toAffine.a₁ ∈ A := SetLike.coe_mem W.a₁
+  have ha₂ : (W.map A.subtype).toAffine.a₂ ∈ A := SetLike.coe_mem W.a₂
+  rw [show (W.map A.subtype).toAffine.addX x₁ x₂ ℓ =
+    ℓ * (ℓ + (W.map A.subtype).toAffine.a₁) +
+      (-(W.map A.subtype).toAffine.a₂ - x₁ - x₂) from by rw [Affine.addX]; ring]
+  exact A.add_notMem (A.mul_notMem hℓ (by simpa [add_comm] using A.add_notMem hℓ ha₁))
+    (A.toSubring.sub_mem (A.toSubring.sub_mem (A.toSubring.neg_mem ha₂) hx₁) hx₂)
+
+end Slope
+
+end WeierstrassCurve
+
+namespace ValuationSubring
+
+variable {L : Type*} [Field L] (A : ValuationSubring L)
+
+theorem ne_zero_of_notMem_nonunits {a : L} (ha : a ∉ A.nonunits) : a ≠ 0 := fun h =>
+  ha (h ▸ A.nonunits.zero_mem)
+
+theorem inv_mem_of_notMem_nonunits {a : L} (ha : a ∉ A.nonunits) : a⁻¹ ∈ A := by
+  rw [mem_nonunits_iff_or] at ha
+  push Not at ha
+  exact ha.2
+
+theorem inv_mem_nonunits_of_notMem {a : L} (ha : a ∉ A) : a⁻¹ ∈ A.nonunits :=
+  A.inv_mem_nonunits_iff.mpr (Or.inr ha)
+
+theorem inv_mem_of_notMem {a : L} (ha : a ∉ A) : a⁻¹ ∈ A :=
+  A.nonunits_subset (A.inv_mem_nonunits_of_notMem ha)
+
+theorem add_notMem_nonunits {a b : L} (ha : a ∉ A.nonunits) (hb : b ∈ A.nonunits) :
+    a + b ∉ A.nonunits := fun h => ha (by simpa using A.nonunits.sub_mem h hb)
+
+theorem mul_notMem_nonunits {a b : L} (ha : a ∉ A.nonunits) (hb : b ∉ A.nonunits) :
+    a * b ∉ A.nonunits := by
+  intro h
+  have ha0 := A.ne_zero_of_notMem_nonunits ha
+  have hb0 := A.ne_zero_of_notMem_nonunits hb
+  rw [mem_nonunits_iff_or] at h
+  rcases h with h | h
+  · exact (mul_ne_zero ha0 hb0) h
+  · exact h (mul_inv_rev a b ▸ A.toSubring.mul_mem (A.inv_mem_of_notMem_nonunits hb)
+      (A.inv_mem_of_notMem_nonunits ha))
+
+theorem inv_notMem_nonunits_of_notMem_nonunits {a : L} (ha : a ∈ A) (ha' : a ∉ A.nonunits) :
+    a⁻¹ ∉ A.nonunits := by
+  rw [mem_nonunits_iff_or]
+  push Not
+  exact ⟨inv_ne_zero (A.ne_zero_of_notMem_nonunits ha'), by rwa [inv_inv]⟩
+
+theorem one_add_notMem_nonunits {a : L} (ha : a ∈ A.nonunits) : 1 + a ∉ A.nonunits :=
+  A.add_notMem_nonunits A.one_notMem_nonunits ha
+
+theorem natCast_mem_nonunits_iff_residue_eq_zero (n : ℕ) :
+    (n : L) ∈ A.nonunits ↔ (n : ResidueField A) = 0 := by
+  have h1 : ((n : A) : L) = (n : L) := by push_cast; rfl
+  have h2 : residue A (n : A) = (n : ResidueField A) := map_natCast (residue A) n
+  rw [← h1, A.coe_mem_nonunits_iff_residue_eq_zero, h2]
+
+end ValuationSubring
+
+namespace WeierstrassCurve
+
+open ValuationSubring
+
+variable {L : Type*} [Field L] {A : ValuationSubring L}
+
+variable (W : WeierstrassCurve A)
+
+namespace Affine
+
+theorem cubic_inv_notMem_nonunits {x : L} (hx : x ∉ A) :
+    1 + (W.map A.subtype).toAffine.a₂ * x⁻¹ + (W.map A.subtype).toAffine.a₄ * (x⁻¹ * x⁻¹)
+      + (W.map A.subtype).toAffine.a₆ * (x⁻¹ * x⁻¹ * x⁻¹) ∉ A.nonunits := by
+  have hxinv : x⁻¹ ∈ A.nonunits := A.inv_mem_nonunits_of_notMem hx
+  have ha₂ : (W.map A.subtype).toAffine.a₂ ∈ A := SetLike.coe_mem W.a₂
+  have ha₄ : (W.map A.subtype).toAffine.a₄ ∈ A := SetLike.coe_mem W.a₄
+  have ha₆ : (W.map A.subtype).toAffine.a₆ ∈ A := SetLike.coe_mem W.a₆
+  rw [add_assoc, add_assoc]
+  refine A.one_add_notMem_nonunits (add_mem (A.mul_mem_nonunits ha₂ hxinv) (add_mem ?_ ?_))
+  · exact A.mul_mem_nonunits ha₄ (A.nonunits.mul_mem hxinv hxinv)
+  · exact A.mul_mem_nonunits ha₆ (A.nonunits.mul_mem (A.nonunits.mul_mem hxinv hxinv) hxinv)
+
+theorem rhs_eq_cubic_mul {x : L} (hx : x ∉ A) :
+    x ^ 3 + (W.map A.subtype).toAffine.a₂ * x ^ 2 + (W.map A.subtype).toAffine.a₄ * x
+        + (W.map A.subtype).toAffine.a₆ =
+      x ^ 3 * (1 + (W.map A.subtype).toAffine.a₂ * x⁻¹
+        + (W.map A.subtype).toAffine.a₄ * (x⁻¹ * x⁻¹)
+        + (W.map A.subtype).toAffine.a₆ * (x⁻¹ * x⁻¹ * x⁻¹)) := by
+  have hx0 : x ≠ 0 := fun h => hx (h ▸ A.zero_mem)
+  field_simp
+
+theorem Y_ne_zero_of_X_notMem {x y : L} (h : (W.map A.subtype).toAffine.Equation x y)
+    (hx : x ∉ A) : y ≠ 0 := by
+  rintro rfl
+  rw [equation_iff] at h
+  have h0 : x ^ 3 + (W.map A.subtype).toAffine.a₂ * x ^ 2 + (W.map A.subtype).toAffine.a₄ * x
+      + (W.map A.subtype).toAffine.a₆ = 0 := by linear_combination -h
+  rw [rhs_eq_cubic_mul W hx] at h0
+  rcases mul_eq_zero.mp h0 with h0 | h0
+  · exact hx (pow_eq_zero_iff (n := 3) (by norm_num) |>.mp h0 ▸ A.zero_mem)
+  · exact A.ne_zero_of_notMem_nonunits (cubic_inv_notMem_nonunits W hx) h0
+
+theorem X_div_Y_mem_nonunits {x y : L} (h : (W.map A.subtype).toAffine.Equation x y)
+    (hx : x ∉ A) : x / y ∈ A.nonunits := by
+  have hy0 : y ≠ 0 := Y_ne_zero_of_X_notMem W h hx
+  have hx0 : x ≠ 0 := fun h0 => hx (h0 ▸ A.zero_mem)
+  by_contra hxy
+  have hyx : y / x ∈ A := by
+    have := A.inv_mem_of_notMem_nonunits hxy
+    rwa [inv_div] at this
+  have hxinv : x⁻¹ ∈ A := A.inv_mem_of_notMem hx
+  rw [equation_iff] at h
+  have key : x * (1 + (W.map A.subtype).toAffine.a₂ * x⁻¹
+      + (W.map A.subtype).toAffine.a₄ * (x⁻¹ * x⁻¹)
+      + (W.map A.subtype).toAffine.a₆ * (x⁻¹ * x⁻¹ * x⁻¹)) =
+      (y / x) * (y / x) + (W.map A.subtype).toAffine.a₁ * (y / x)
+        + (W.map A.subtype).toAffine.a₃ * (y / x) * x⁻¹ := by
+    field_simp
+    linear_combination -h
+  refine hx ?_
+  have hmem : x * (1 + (W.map A.subtype).toAffine.a₂ * x⁻¹
+      + (W.map A.subtype).toAffine.a₄ * (x⁻¹ * x⁻¹)
+      + (W.map A.subtype).toAffine.a₆ * (x⁻¹ * x⁻¹ * x⁻¹)) ∈ A := by
+    rw [key]
+    exact add_mem (add_mem (mul_mem hyx hyx) (mul_mem (SetLike.coe_mem W.a₁) hyx))
+      (mul_mem (mul_mem (SetLike.coe_mem W.a₃) hyx) hxinv)
+  have hcu := cubic_inv_notMem_nonunits W hx
+  have := mul_mem hmem (A.inv_mem_of_notMem_nonunits hcu)
+  rwa [mul_assoc, mul_inv_cancel₀ (A.ne_zero_of_notMem_nonunits hcu), mul_one] at this
+
+theorem Y_notMem_of_X_notMem {x y : L} (h : (W.map A.subtype).toAffine.Equation x y)
+    (hx : x ∉ A) : y ∉ A := by
+  intro hy
+  refine hx ?_
+  have hmem : y * (x / y) ∈ A.nonunits := A.mul_mem_nonunits hy (X_div_Y_mem_nonunits W h hx)
+  rw [mul_div_cancel₀ _ (Y_ne_zero_of_X_notMem W h hx)] at hmem
+  exact A.nonunits_subset hmem
+
+theorem X_cubed_div_Y_sq_notMem_nonunits {x y : L}
+    (h : (W.map A.subtype).toAffine.Equation x y) (hx : x ∉ A) :
+    x ^ 3 / y ^ 2 ∈ A ∧ x ^ 3 / y ^ 2 ∉ A.nonunits := by
+  have hy0 : y ≠ 0 := Y_ne_zero_of_X_notMem W h hx
+  have hx0 : x ≠ 0 := fun h0 => hx (h0 ▸ A.zero_mem)
+  have hxy : x / y ∈ A.nonunits := X_div_Y_mem_nonunits W h hx
+  have hyinv : y⁻¹ ∈ A.nonunits := A.inv_mem_nonunits_of_notMem (Y_notMem_of_X_notMem W h hx)
+  have ha₁ : (W.map A.subtype).toAffine.a₁ ∈ A := SetLike.coe_mem W.a₁
+  have ha₃ : (W.map A.subtype).toAffine.a₃ ∈ A := SetLike.coe_mem W.a₃
+  rw [equation_iff] at h
+  have hu : (1 + (W.map A.subtype).toAffine.a₁ * (x / y) + (W.map A.subtype).toAffine.a₃ * y⁻¹)
+      ∉ A.nonunits := by
+    rw [add_assoc]
+    exact A.one_add_notMem_nonunits
+      (add_mem (A.mul_mem_nonunits ha₁ hxy) (A.mul_mem_nonunits ha₃ hyinv))
+  have hu' : (1 + (W.map A.subtype).toAffine.a₁ * (x / y) + (W.map A.subtype).toAffine.a₃ * y⁻¹)
+      ∈ A := by
+    refine add_mem (add_mem A.one_mem ?_) ?_
+    · exact mul_mem ha₁ (A.nonunits_subset hxy)
+    · exact mul_mem ha₃ (A.nonunits_subset hyinv)
+  have hc := cubic_inv_notMem_nonunits W hx
+  have hc' : (1 + (W.map A.subtype).toAffine.a₂ * x⁻¹
+      + (W.map A.subtype).toAffine.a₄ * (x⁻¹ * x⁻¹)
+      + (W.map A.subtype).toAffine.a₆ * (x⁻¹ * x⁻¹ * x⁻¹)) ∈ A := by
+    have hxinv : x⁻¹ ∈ A := A.inv_mem_of_notMem hx
+    refine add_mem (add_mem (add_mem A.one_mem ?_) ?_) ?_
+    · exact mul_mem (SetLike.coe_mem W.a₂) hxinv
+    · exact mul_mem (SetLike.coe_mem W.a₄) (mul_mem hxinv hxinv)
+    · exact mul_mem (SetLike.coe_mem W.a₆) (mul_mem (mul_mem hxinv hxinv) hxinv)
+  have key' : x ^ 3 / y ^ 2 = (1 + (W.map A.subtype).toAffine.a₁ * (x / y)
+      + (W.map A.subtype).toAffine.a₃ * y⁻¹) * (1 + (W.map A.subtype).toAffine.a₂ * x⁻¹
+        + (W.map A.subtype).toAffine.a₄ * (x⁻¹ * x⁻¹)
+        + (W.map A.subtype).toAffine.a₆ * (x⁻¹ * x⁻¹ * x⁻¹))⁻¹ := by
+    rw [eq_comm, mul_inv_eq_iff_eq_mul₀ (A.ne_zero_of_notMem_nonunits hc), div_mul_eq_mul_div,
+      eq_div_iff (pow_ne_zero 2 hy0)]
+    field_simp
+    linear_combination h
+  constructor
+  · rw [key']
+    exact mul_mem hu' (A.inv_mem_of_notMem_nonunits hc)
+  · rw [key']
+    exact A.mul_notMem_nonunits hu (A.inv_notMem_nonunits_of_notMem_nonunits hc' hc)
+
+variable {W}
+
+theorem inv_Y_div_mem_nonunits {x y τ : L} (h : (W.map A.subtype).toAffine.Equation x y)
+    (hx : x ∉ A) (ht : (x / y) / τ ∈ A) : (1 / y) / τ ∈ A.nonunits := by
+  have hx0 : x ≠ 0 := fun h0 => hx (h0 ▸ A.zero_mem)
+  have hy0 : y ≠ 0 := Y_ne_zero_of_X_notMem W h hx
+  have key : (1 / y) / τ = ((x / y) / τ) * x⁻¹ := by
+    field_simp
+  rw [key]
+  exact A.mul_mem_nonunits ht (A.inv_mem_nonunits_of_notMem hx)
+
+theorem inv_X_mul_div_mem_nonunits {x y τ : L} (h : (W.map A.subtype).toAffine.Equation x y)
+    (hx : x ∉ A) (hτ0 : τ ≠ 0) (ht : (x / y) / τ ∈ A) : x⁻¹ / τ ∈ A.nonunits := by
+  have hx0 : x ≠ 0 := fun h0 => hx (h0 ▸ A.zero_mem)
+  have hy0 : y ≠ 0 := Y_ne_zero_of_X_notMem W h hx
+  have key : x⁻¹ / τ = (y ^ 2 / x ^ 3) * ((x / y) / τ) * (x / y) := by
+    first
+    | (field_simp)
+  rw [key]
+  refine A.mul_mem_nonunits (mul_mem ?_ ht) (X_div_Y_mem_nonunits W h hx)
+  rw [show y ^ 2 / x ^ 3 = (x ^ 3 / y ^ 2)⁻¹ by rw [inv_div]]
+  exact A.inv_mem_of_notMem_nonunits (X_cubed_div_Y_sq_notMem_nonunits W h hx).2
+
+theorem neg_formal_param_add {x y : L} (hy0 : y ≠ 0)
+    (hy'0 : (W.map A.subtype).toAffine.negY x y ≠ 0) :
+    (-(x / y)) + (-(x / (W.map A.subtype).toAffine.negY x y)) =
+      (W.map A.subtype).toAffine.a₁ * (x / y) * (x / (W.map A.subtype).toAffine.negY x y)
+        + (W.map A.subtype).toAffine.a₃ * (x / y)
+            * (1 / (W.map A.subtype).toAffine.negY x y) := by
+  have hsum : (W.map A.subtype).toAffine.negY x y
+      = -y - (W.map A.subtype).toAffine.a₁ * x - (W.map A.subtype).toAffine.a₃ := rfl
+  generalize hgen : (W.map A.subtype).toAffine.negY x y = y' at *
+  rw [← sub_eq_zero]
+  have key : (-(x / y)) + (-(x / y')) - ((W.map A.subtype).toAffine.a₁ * (x / y) * (x / y')
+        + (W.map A.subtype).toAffine.a₃ * (x / y) * (1 / y'))
+      = (-(x * y') - x * y - (W.map A.subtype).toAffine.a₁ * x * x
+          - (W.map A.subtype).toAffine.a₃ * x) / (y * y') := by
+    first
+    | (field_simp; ring1)
+  rw [key, div_eq_zero_iff]
+  left
+  linear_combination (-x) * hsum
+
+theorem neg_formal_param_estimate {x y τ : L}
+    (h : (W.map A.subtype).toAffine.Equation x y) (hx : x ∉ A)
+    (ht : (x / y) / τ ∈ A) :
+    ((-(x / y)) + (-(x / (W.map A.subtype).toAffine.negY x y))) / τ ∈ A.nonunits := by
+  have h' : (W.map A.subtype).toAffine.Equation x ((W.map A.subtype).toAffine.negY x y) :=
+    (Affine.equation_neg x y).mpr h
+  have hy0 : y ≠ 0 := Y_ne_zero_of_X_notMem W h hx
+  have hy'0 : (W.map A.subtype).toAffine.negY x y ≠ 0 := Y_ne_zero_of_X_notMem W h' hx
+  rw [neg_formal_param_add hy0 hy'0, add_div]
+  refine add_mem ?_ ?_
+  · rw [show (W.map A.subtype).toAffine.a₁ * (x / y)
+        * (x / (W.map A.subtype).toAffine.negY x y) / τ =
+      (W.map A.subtype).toAffine.a₁ * ((x / y) / τ)
+        * (x / (W.map A.subtype).toAffine.negY x y) by ring]
+    exact A.mul_mem_nonunits (mul_mem (SetLike.coe_mem W.a₁) ht)
+      (X_div_Y_mem_nonunits W h' hx)
+  · rw [show (W.map A.subtype).toAffine.a₃ * (x / y)
+        * (1 / (W.map A.subtype).toAffine.negY x y) / τ =
+      (W.map A.subtype).toAffine.a₃ * (x / y)
+        * ((1 / (W.map A.subtype).toAffine.negY x y) / τ) by ring]
+    rw [show (W.map A.subtype).toAffine.a₃ * (x / y)
+        * ((1 / (W.map A.subtype).toAffine.negY x y) / τ) =
+      (W.map A.subtype).toAffine.a₃ * ((x / y) / τ)
+        * (1 / (W.map A.subtype).toAffine.negY x y) by ring]
+    rw [one_div]
+    exact A.mul_mem_nonunits (mul_mem (SetLike.coe_mem W.a₃) ht)
+      (A.inv_mem_nonunits_of_notMem (Y_notMem_of_X_notMem W h' hx))
+
+section AdditionEstimate
+
+variable [DecidableEq L]
+
+theorem sub_eq_slope_mul_sub {x₁ y₁ x₂ y₂ : L}
+    (h₁ : (W.map A.subtype).toAffine.Equation x₁ y₁)
+    (h₂ : (W.map A.subtype).toAffine.Equation x₂ y₂)
+    (hxy : ¬(x₁ = x₂ ∧ y₁ = (W.map A.subtype).toAffine.negY x₂ y₂)) :
+    y₁ - y₂ = (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ * (x₁ - x₂) := by
+  by_cases hx : x₁ = x₂
+  · have hy : y₁ = y₂ := Y_eq_of_Y_ne h₁ h₂ hx (fun h => hxy ⟨hx, h⟩)
+    rw [hx, hy, sub_self, sub_self, mul_zero]
+  · rw [slope_of_X_ne hx, div_mul_cancel₀ _ (sub_ne_zero.mpr hx)]
+
+theorem vieta_addX {x₁ y₁ x₂ y₂ : L}
+    (h₁ : (W.map A.subtype).toAffine.Equation x₁ y₁)
+    (h₂ : (W.map A.subtype).toAffine.Equation x₂ y₂)
+    (hxy : ¬(x₁ = x₂ ∧ y₁ = (W.map A.subtype).toAffine.negY x₂ y₂)) :
+    x₁ * x₂ + x₁ * ((W.map A.subtype).toAffine.addX x₁ x₂
+        ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂))
+      + x₂ * ((W.map A.subtype).toAffine.addX x₁ x₂
+        ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂)) =
+      2 * x₁ * ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂) ^ 2
+        + ((W.map A.subtype).toAffine.a₁ * x₁ - 2 * y₁ - (W.map A.subtype).toAffine.a₃)
+            * ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂)
+        + (-(W.map A.subtype).toAffine.a₁ * y₁ + (W.map A.subtype).toAffine.a₄) ∧
+    x₁ * x₂ * ((W.map A.subtype).toAffine.addX x₁ x₂
+        ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂)) =
+      x₁ ^ 2 * ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂) ^ 2
+        - (2 * x₁ * y₁ + (W.map A.subtype).toAffine.a₃ * x₁)
+            * ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂)
+        + (y₁ ^ 2 + (W.map A.subtype).toAffine.a₃ * y₁ - (W.map A.subtype).toAffine.a₆) := by
+  have key := (Affine.addPolynomial_eq (W' := (W.map A.subtype).toAffine) x₁ y₁
+    ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂)).symm.trans
+    (Affine.addPolynomial_slope h₁ h₂ hxy)
+  rw [Cubic.prod_X_sub_C_eq, neg_inj, Cubic.toPoly_injective] at key
+  have hc := congrArg Cubic.c key
+  have hd := congrArg Cubic.d key
+  simp only at hc hd
+  exact ⟨by linear_combination -hc, by linear_combination hd⟩
+
+omit [DecidableEq L] in
+theorem secant_slope_identity {x₁ y₁ x₂ y₂ : L}
+    (h₁ : (W.map A.subtype).toAffine.Equation x₁ y₁)
+    (h₂ : (W.map A.subtype).toAffine.Equation x₂ y₂) :
+    (y₁ - y₂) * (y₁ ^ 2*y₂ ^ 2 + (W.map A.subtype).toAffine.a₁*x₁*y₁*y₂ ^ 2
+        - (W.map A.subtype).toAffine.a₂*x₁ ^ 2*y₂ ^ 2
+        + (W.map A.subtype).toAffine.a₃*(y₁*y₂ ^ 2 + y₁ ^ 2*y₂)
+        - (W.map A.subtype).toAffine.a₄*x₁*(y₂ ^ 2 + y₁*y₂)
+        - (W.map A.subtype).toAffine.a₆*(y₂ ^ 2 + y₁*y₂ + y₁ ^ 2)) =
+    (x₂*y₁ - x₁*y₂) * (-(W.map A.subtype).toAffine.a₁*y₁ ^ 2*y₂
+        + (W.map A.subtype).toAffine.a₂*x₁*y₁*y₂ + (W.map A.subtype).toAffine.a₂*x₂*y₁ ^ 2
+        + (W.map A.subtype).toAffine.a₄*y₁ ^ 2 + x₁ ^ 2*y₂ ^ 2 + x₁*x₂*y₁*y₂ + x₂ ^ 2*y₁ ^ 2) := by
+  rw [Affine.equation_iff] at h₁ h₂
+  set a1 := (W.map A.subtype).toAffine.a₁
+  set a2 := (W.map A.subtype).toAffine.a₂
+  set a3 := (W.map A.subtype).toAffine.a₃
+  set a4 := (W.map A.subtype).toAffine.a₄
+  set a6 := (W.map A.subtype).toAffine.a₆
+  linear_combination (-a1 ^ 2*x₁*x₂*y₂ + a1*a2*x₁*x₂ ^ 2 - a1*a3*x₁*y₂ - a1*a3*x₂*y₂ + a1*a4*x₁*x₂
+      + a1*a6*x₁ + a1*x₁*x₂ ^ 3 - a1*x₁*y₂ ^ 2 + a1*x₂*y₁*y₂ + a2*a3*x₂ ^ 2 - a2*x₂ ^ 2*y₁ - a3 ^
+        2*y₂
+      + a3*a4*x₂ + a3*a6 + a3*x₂ ^ 3 + a3*y₁*y₂ - a3*y₂ ^ 2 - a4*x₂*y₁ - a6*y₁ - x₂ ^ 3*y₁
+      + y₁*y₂ ^ 2 - y₂ ^ 3) * h₁
+    + (a1 ^ 2*x₁ ^ 2*y₁ - a1*a2*x₁ ^ 3 + 2*a1*a3*x₁*y₁ - a1*a4*x₁ ^ 2 - a1*a6*x₁ - a1*x₁ ^ 4
+      - a2*a3*x₁ ^ 2 + a2*x₁ ^ 2*y₁ + a3 ^ 2*y₁ - a3*a4*x₁ - a3*a6 - a3*x₁ ^ 3 + a4*x₁*y₁ + a6*y₁
+      + x₁ ^ 3*y₁) * h₂
+
+omit [DecidableEq L] in
+theorem tangent_slope_identity {x₁ y₁ : L}
+    (h₁ : (W.map A.subtype).toAffine.Equation x₁ y₁) :
+    -(3*x₁ ^ 2 + 2*(W.map A.subtype).toAffine.a₂*x₁ + (W.map A.subtype).toAffine.a₄
+        - (W.map A.subtype).toAffine.a₁*y₁)
+      * ((W.map A.subtype).toAffine.a₁*x₁*y₁ - (W.map A.subtype).toAffine.a₂*x₁ ^ 2
+        + 2*(W.map A.subtype).toAffine.a₃*y₁ - 2*(W.map A.subtype).toAffine.a₄*x₁
+        - 3*(W.map A.subtype).toAffine.a₆ + y₁ ^ 2) =
+    (y₁*(2*y₁ + (W.map A.subtype).toAffine.a₁*x₁ + (W.map A.subtype).toAffine.a₃)
+        - x₁*(3*x₁ ^ 2 + 2*(W.map A.subtype).toAffine.a₂*x₁ + (W.map A.subtype).toAffine.a₄
+            - (W.map A.subtype).toAffine.a₁*y₁))
+      * (3*x₁ ^ 2 + 2*(W.map A.subtype).toAffine.a₂*x₁ + (W.map A.subtype).toAffine.a₄
+        - (W.map A.subtype).toAffine.a₁*y₁) := by
+  rw [Affine.equation_iff] at h₁
+  linear_combination (3*(W.map A.subtype).toAffine.a₁*y₁ - 6*(W.map A.subtype).toAffine.a₂*x₁
+    - 3*(W.map A.subtype).toAffine.a₄ - 9*x₁ ^ 2) * h₁
+
+omit [DecidableEq L] in
+theorem tangent_intercept_identity {x₁ y₁ : L}
+    (h₁ : (W.map A.subtype).toAffine.Equation x₁ y₁) :
+    y₁*(2*y₁ + (W.map A.subtype).toAffine.a₁*x₁ + (W.map A.subtype).toAffine.a₃)
+        - x₁*(3*x₁ ^ 2 + 2*(W.map A.subtype).toAffine.a₂*x₁ + (W.map A.subtype).toAffine.a₄
+            - (W.map A.subtype).toAffine.a₁*y₁) =
+      -(x₁ ^ 3 - (W.map A.subtype).toAffine.a₄*x₁ - 2*(W.map A.subtype).toAffine.a₆
+        + (W.map A.subtype).toAffine.a₃*y₁) := by
+  rw [Affine.equation_iff] at h₁
+  linear_combination 2 * h₁
+
+theorem slope_div_intercept_estimate {x₁ y₁ x₂ y₂ τ : L}
+    (h₁ : (W.map A.subtype).toAffine.Equation x₁ y₁)
+    (h₂ : (W.map A.subtype).toAffine.Equation x₂ y₂)
+    (hx₁ : x₁ ∉ A) (hx₂ : x₂ ∉ A)
+    (hxy : ¬(x₁ = x₂ ∧ y₁ = (W.map A.subtype).toAffine.negY x₂ y₂))
+    (hτ : τ ∈ A.nonunits) (hτ0 : τ ≠ 0)
+    (ht₁ : (x₁ / y₁) / τ ∈ A) (ht₂ : (x₂ / y₂) / τ ∈ A) :
+    y₁ - (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ * x₁ ≠ 0 ∧
+      ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂
+          / (y₁ - (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ * x₁)) / τ ∈ A.nonunits ∧
+      ((1 : L) / (y₁ - (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ * x₁)) / τ
+        ∈ A.nonunits := by
+  have ha1A : (W.map A.subtype).toAffine.a₁ ∈ A := SetLike.coe_mem W.a₁
+  have ha2A : (W.map A.subtype).toAffine.a₂ ∈ A := SetLike.coe_mem W.a₂
+  have ha3A : (W.map A.subtype).toAffine.a₃ ∈ A := SetLike.coe_mem W.a₃
+  have ha4A : (W.map A.subtype).toAffine.a₄ ∈ A := SetLike.coe_mem W.a₄
+  have ha6A : (W.map A.subtype).toAffine.a₆ ∈ A := SetLike.coe_mem W.a₆
+  have hy₁0 : y₁ ≠ 0 := Y_ne_zero_of_X_notMem W h₁ hx₁
+  have hy₂0 : y₂ ≠ 0 := Y_ne_zero_of_X_notMem W h₂ hx₂
+  have hx₁0 : x₁ ≠ 0 := fun h0 => hx₁ (h0 ▸ A.zero_mem)
+  have hT₁ : x₁ / y₁ ∈ A.nonunits := X_div_Y_mem_nonunits W h₁ hx₁
+  have hT₂ : x₂ / y₂ ∈ A.nonunits := X_div_Y_mem_nonunits W h₂ hx₂
+  have hT₁A : x₁ / y₁ ∈ A := A.nonunits_subset hT₁
+  have hT₂A : x₂ / y₂ ∈ A := A.nonunits_subset hT₂
+  have hs₁ : (1 / y₁) / τ ∈ A.nonunits := inv_Y_div_mem_nonunits h₁ hx₁ ht₁
+  have hs₂ : (1 / y₂) / τ ∈ A.nonunits := inv_Y_div_mem_nonunits h₂ hx₂ ht₂
+  have hs₁' : (1 : L) / y₁ ∈ A.nonunits := by
+    rw [one_div]
+    exact A.inv_mem_nonunits_of_notMem (Y_notMem_of_X_notMem W h₁ hx₁)
+  have hs₂' : (1 : L) / y₂ ∈ A.nonunits := by
+    rw [one_div]
+    exact A.inv_mem_nonunits_of_notMem (Y_notMem_of_X_notMem W h₂ hx₂)
+  have hs₁A : (1 : L) / y₁ ∈ A := A.nonunits_subset hs₁'
+  have hs₂A : (1 : L) / y₂ ∈ A := A.nonunits_subset hs₂'
+  have main : y₁ - (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ * x₁ ≠ 0 ∧
+      ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂
+        / (y₁ - (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ * x₁)) / τ ∈ A.nonunits := by
+    by_cases hx : x₁ = x₂
+    · have hy : y₁ ≠ (W.map A.subtype).toAffine.negY x₂ y₂ := fun h => hxy ⟨hx, h⟩
+      have hyy : y₁ = y₂ := Y_eq_of_Y_ne h₁ h₂ hx hy
+      subst hx
+      subst hyy
+      have hψ0 : y₁ - (W.map A.subtype).toAffine.negY x₁ y₁ ≠ 0 := sub_ne_zero_of_ne hy
+      have hxinv : x₁⁻¹ ∈ A.nonunits := A.inv_mem_nonunits_of_notMem hx₁
+      have hxinvA : x₁⁻¹ ∈ A := A.nonunits_subset hxinv
+      have hxτ : x₁⁻¹ / τ ∈ A.nonunits := inv_X_mul_div_mem_nonunits h₁ hx₁ hτ0 ht₁
+      have hcube := X_cubed_div_Y_sq_notMem_nonunits W h₁ hx₁
+      have hcubeinvA : (x₁ ^ 3 / y₁ ^ 2)⁻¹ ∈ A := A.inv_mem_of_notMem_nonunits hcube.2
+      have hI_eq : (x₁ ^ 3 - (W.map A.subtype).toAffine.a₄ * x₁
+            - 2 * (W.map A.subtype).toAffine.a₆ + (W.map A.subtype).toAffine.a₃ * y₁) / x₁ ^ 3
+          = 1 + ((-((W.map A.subtype).toAffine.a₄ * x₁⁻¹)
+              - ((W.map A.subtype).toAffine.a₆ + (W.map A.subtype).toAffine.a₆)
+                * (x₁⁻¹ * x₁⁻¹)) * x₁⁻¹
+            + ((W.map A.subtype).toAffine.a₃ * (x₁ ^ 3 / y₁ ^ 2)⁻¹) * (1 / y₁)) := by
+        field_simp
+        ring
+      have hIm : ((-((W.map A.subtype).toAffine.a₄ * x₁⁻¹)
+            - ((W.map A.subtype).toAffine.a₆ + (W.map A.subtype).toAffine.a₆)
+              * (x₁⁻¹ * x₁⁻¹)) * x₁⁻¹
+          + ((W.map A.subtype).toAffine.a₃ * (x₁ ^ 3 / y₁ ^ 2)⁻¹) * (1 / y₁)) ∈ A.nonunits :=
+        add_mem
+          (A.mul_mem_nonunits (sub_mem (neg_mem (mul_mem ha4A hxinvA))
+            (mul_mem (add_mem ha6A ha6A) (mul_mem hxinvA hxinvA))) hxinv)
+          (A.mul_mem_nonunits (mul_mem ha3A hcubeinvA) hs₁')
+      have hInot : (x₁ ^ 3 - (W.map A.subtype).toAffine.a₄ * x₁
+            - 2 * (W.map A.subtype).toAffine.a₆ + (W.map A.subtype).toAffine.a₃ * y₁) / x₁ ^ 3
+          ∉ A.nonunits := by
+        rw [hI_eq]
+        exact A.one_add_notMem_nonunits hIm
+      have hI0 : x₁ ^ 3 - (W.map A.subtype).toAffine.a₄ * x₁
+          - 2 * (W.map A.subtype).toAffine.a₆ + (W.map A.subtype).toAffine.a₃ * y₁ ≠ 0 := by
+        intro h0
+        exact hInot (by rw [h0, zero_div]; exact A.nonunits.zero_mem)
+      have hIinvA : ((x₁ ^ 3 - (W.map A.subtype).toAffine.a₄ * x₁
+            - 2 * (W.map A.subtype).toAffine.a₆
+            + (W.map A.subtype).toAffine.a₃ * y₁) / x₁ ^ 3)⁻¹ ∈ A :=
+        A.inv_mem_of_notMem_nonunits hInot
+      have hψ_eq : y₁ - (W.map A.subtype).toAffine.negY x₁ y₁
+          = y₁ + y₁ + (W.map A.subtype).toAffine.a₁ * x₁ + (W.map A.subtype).toAffine.a₃ := by
+        simp only [negY]
+        ring
+      have h₁' := h₁
+      rw [Affine.equation_iff] at h₁'
+      have hkey : (y₁ - (W.map A.subtype).toAffine.slope x₁ x₁ y₁ y₁ * x₁)
+            * (y₁ - (W.map A.subtype).toAffine.negY x₁ y₁)
+          = -(x₁ ^ 3 - (W.map A.subtype).toAffine.a₄ * x₁
+            - 2 * (W.map A.subtype).toAffine.a₆ + (W.map A.subtype).toAffine.a₃ * y₁) := by
+        rw [Affine.slope_of_Y_ne rfl hy, sub_mul, div_mul_eq_mul_div, div_mul_cancel₀ _ hψ0,
+          hψ_eq]
+        linear_combination (2 : L) * h₁'
+      have hν0 : y₁ - (W.map A.subtype).toAffine.slope x₁ x₁ y₁ y₁ * x₁ ≠ 0 := by
+        intro h0
+        rw [h0, zero_mul] at hkey
+        exact hI0 (by linear_combination hkey)
+      refine ⟨hν0, ?_⟩
+      have hslope_mul : (W.map A.subtype).toAffine.slope x₁ x₁ y₁ y₁
+            * (y₁ - (W.map A.subtype).toAffine.negY x₁ y₁)
+          = 3 * x₁ ^ 2 + 2 * (W.map A.subtype).toAffine.a₂ * x₁
+            + (W.map A.subtype).toAffine.a₄ - (W.map A.subtype).toAffine.a₁ * y₁ := by
+        rw [Affine.slope_of_Y_ne rfl hy, div_mul_cancel₀ _ hψ0]
+      have hℓν : (W.map A.subtype).toAffine.slope x₁ x₁ y₁ y₁
+            / (y₁ - (W.map A.subtype).toAffine.slope x₁ x₁ y₁ y₁ * x₁)
+          = -(3 * x₁ ^ 2 + 2 * (W.map A.subtype).toAffine.a₂ * x₁
+              + (W.map A.subtype).toAffine.a₄ - (W.map A.subtype).toAffine.a₁ * y₁)
+            / (x₁ ^ 3 - (W.map A.subtype).toAffine.a₄ * x₁
+              - 2 * (W.map A.subtype).toAffine.a₆ + (W.map A.subtype).toAffine.a₃ * y₁) := by
+        rw [div_eq_div_iff hν0 hI0]
+        linear_combination (-(y₁ - (W.map A.subtype).toAffine.slope x₁ x₁ y₁ y₁ * x₁))
+          * hslope_mul + (W.map A.subtype).toAffine.slope x₁ x₁ y₁ y₁ * hkey
+      rw [hℓν]
+      have hsplit : (-(3 * x₁ ^ 2 + 2 * (W.map A.subtype).toAffine.a₂ * x₁
+              + (W.map A.subtype).toAffine.a₄ - (W.map A.subtype).toAffine.a₁ * y₁)
+            / (x₁ ^ 3 - (W.map A.subtype).toAffine.a₄ * x₁
+              - 2 * (W.map A.subtype).toAffine.a₆
+              + (W.map A.subtype).toAffine.a₃ * y₁)) / τ
+          = ((x₁ ^ 3 - (W.map A.subtype).toAffine.a₄ * x₁
+              - 2 * (W.map A.subtype).toAffine.a₆
+              + (W.map A.subtype).toAffine.a₃ * y₁) / x₁ ^ 3)⁻¹
+            * (-(((1 + 1 + 1) + ((W.map A.subtype).toAffine.a₂
+                  + (W.map A.subtype).toAffine.a₂) * x₁⁻¹
+                + (W.map A.subtype).toAffine.a₄ * (x₁⁻¹ * x₁⁻¹)) * (x₁⁻¹ / τ)
+              - ((W.map A.subtype).toAffine.a₁ * (x₁ ^ 3 / y₁ ^ 2)⁻¹) * ((1 / y₁) / τ))) := by
+        field_simp
+        ring
+      rw [hsplit]
+      refine A.mul_mem_nonunits hIinvA (A.nonunits.neg_mem (sub_mem ?_ ?_))
+      · exact A.mul_mem_nonunits
+          (add_mem (add_mem (add_mem (add_mem A.one_mem A.one_mem) A.one_mem)
+            (mul_mem (add_mem ha2A ha2A) hxinvA)) (mul_mem ha4A (mul_mem hxinvA hxinvA))) hxτ
+      · exact A.mul_mem_nonunits (mul_mem ha1A hcubeinvA) hs₁
+    · have hxx0 : x₁ - x₂ ≠ 0 := sub_ne_zero_of_ne hx
+      have hsec := secant_slope_identity (W := W) h₁ h₂
+      have hU_eq : (y₁ ^ 2 * y₂ ^ 2 + (W.map A.subtype).toAffine.a₁ * x₁ * y₁ * y₂ ^ 2
+            - (W.map A.subtype).toAffine.a₂ * x₁ ^ 2 * y₂ ^ 2
+            + (W.map A.subtype).toAffine.a₃ * (y₁ * y₂ ^ 2 + y₁ ^ 2 * y₂)
+            - (W.map A.subtype).toAffine.a₄ * x₁ * (y₂ ^ 2 + y₁ * y₂)
+            - (W.map A.subtype).toAffine.a₆ * (y₂ ^ 2 + y₁ * y₂ + y₁ ^ 2)) / (y₁ ^ 2 * y₂ ^ 2)
+          = 1 + (((W.map A.subtype).toAffine.a₁
+                - (W.map A.subtype).toAffine.a₂ * (x₁ / y₁)
+                - (W.map A.subtype).toAffine.a₄ * (1 / y₁)
+                - (W.map A.subtype).toAffine.a₄ * (1 / y₂)) * (x₁ / y₁)
+              + ((W.map A.subtype).toAffine.a₃ - (W.map A.subtype).toAffine.a₆ * (1 / y₁)
+                - (W.map A.subtype).toAffine.a₆ * (1 / y₂)) * (1 / y₁)
+              + ((W.map A.subtype).toAffine.a₃
+                - (W.map A.subtype).toAffine.a₆ * (1 / y₂)) * (1 / y₂)) := by
+        field_simp
+        ring
+      have hUm : (((W.map A.subtype).toAffine.a₁
+              - (W.map A.subtype).toAffine.a₂ * (x₁ / y₁)
+              - (W.map A.subtype).toAffine.a₄ * (1 / y₁)
+              - (W.map A.subtype).toAffine.a₄ * (1 / y₂)) * (x₁ / y₁)
+            + ((W.map A.subtype).toAffine.a₃ - (W.map A.subtype).toAffine.a₆ * (1 / y₁)
+              - (W.map A.subtype).toAffine.a₆ * (1 / y₂)) * (1 / y₁)
+            + ((W.map A.subtype).toAffine.a₃
+              - (W.map A.subtype).toAffine.a₆ * (1 / y₂)) * (1 / y₂)) ∈ A.nonunits := by
+        refine add_mem (add_mem (A.mul_mem_nonunits ?_ hT₁) (A.mul_mem_nonunits ?_ hs₁'))
+          (A.mul_mem_nonunits ?_ hs₂')
+        · exact sub_mem (sub_mem (sub_mem ha1A (mul_mem ha2A hT₁A)) (mul_mem ha4A hs₁A))
+            (mul_mem ha4A hs₂A)
+        · exact sub_mem (sub_mem ha3A (mul_mem ha6A hs₁A)) (mul_mem ha6A hs₂A)
+        · exact sub_mem ha3A (mul_mem ha6A hs₂A)
+      have hUnot : (y₁ ^ 2 * y₂ ^ 2 + (W.map A.subtype).toAffine.a₁ * x₁ * y₁ * y₂ ^ 2
+            - (W.map A.subtype).toAffine.a₂ * x₁ ^ 2 * y₂ ^ 2
+            + (W.map A.subtype).toAffine.a₃ * (y₁ * y₂ ^ 2 + y₁ ^ 2 * y₂)
+            - (W.map A.subtype).toAffine.a₄ * x₁ * (y₂ ^ 2 + y₁ * y₂)
+            - (W.map A.subtype).toAffine.a₆ * (y₂ ^ 2 + y₁ * y₂ + y₁ ^ 2)) / (y₁ ^ 2 * y₂ ^ 2)
+          ∉ A.nonunits := by
+        rw [hU_eq]
+        exact A.one_add_notMem_nonunits hUm
+      have hUA : (y₁ ^ 2 * y₂ ^ 2 + (W.map A.subtype).toAffine.a₁ * x₁ * y₁ * y₂ ^ 2
+            - (W.map A.subtype).toAffine.a₂ * x₁ ^ 2 * y₂ ^ 2
+            + (W.map A.subtype).toAffine.a₃ * (y₁ * y₂ ^ 2 + y₁ ^ 2 * y₂)
+            - (W.map A.subtype).toAffine.a₄ * x₁ * (y₂ ^ 2 + y₁ * y₂)
+            - (W.map A.subtype).toAffine.a₆ * (y₂ ^ 2 + y₁ * y₂ + y₁ ^ 2)) / (y₁ ^ 2 * y₂ ^ 2)
+          ∈ A := by
+        rw [hU_eq]
+        exact add_mem A.one_mem (A.nonunits_subset hUm)
+      have hUinvA : ((y₁ ^ 2 * y₂ ^ 2 + (W.map A.subtype).toAffine.a₁ * x₁ * y₁ * y₂ ^ 2
+            - (W.map A.subtype).toAffine.a₂ * x₁ ^ 2 * y₂ ^ 2
+            + (W.map A.subtype).toAffine.a₃ * (y₁ * y₂ ^ 2 + y₁ ^ 2 * y₂)
+            - (W.map A.subtype).toAffine.a₄ * x₁ * (y₂ ^ 2 + y₁ * y₂)
+            - (W.map A.subtype).toAffine.a₆ * (y₂ ^ 2 + y₁ * y₂ + y₁ ^ 2))
+              / (y₁ ^ 2 * y₂ ^ 2))⁻¹ ∈ A :=
+        A.inv_mem_of_notMem_nonunits hUnot
+      have hU0 : y₁ ^ 2 * y₂ ^ 2 + (W.map A.subtype).toAffine.a₁ * x₁ * y₁ * y₂ ^ 2
+            - (W.map A.subtype).toAffine.a₂ * x₁ ^ 2 * y₂ ^ 2
+            + (W.map A.subtype).toAffine.a₃ * (y₁ * y₂ ^ 2 + y₁ ^ 2 * y₂)
+            - (W.map A.subtype).toAffine.a₄ * x₁ * (y₂ ^ 2 + y₁ * y₂)
+            - (W.map A.subtype).toAffine.a₆ * (y₂ ^ 2 + y₁ * y₂ + y₁ ^ 2) ≠ 0 := by
+        intro h0
+        exact hUnot (by rw [h0, zero_div]; exact A.nonunits.zero_mem)
+      have hxy21 : x₁ * y₂ - x₂ * y₁ ≠ 0 := by
+        intro h0
+        have hUV : (y₁ - y₂) * (y₁ ^ 2 * y₂ ^ 2
+              + (W.map A.subtype).toAffine.a₁ * x₁ * y₁ * y₂ ^ 2
+              - (W.map A.subtype).toAffine.a₂ * x₁ ^ 2 * y₂ ^ 2
+              + (W.map A.subtype).toAffine.a₃ * (y₁ * y₂ ^ 2 + y₁ ^ 2 * y₂)
+              - (W.map A.subtype).toAffine.a₄ * x₁ * (y₂ ^ 2 + y₁ * y₂)
+              - (W.map A.subtype).toAffine.a₆ * (y₂ ^ 2 + y₁ * y₂ + y₁ ^ 2)) = 0 := by
+          rw [hsec]
+          linear_combination (-(-((W.map A.subtype).toAffine.a₁ * y₁ ^ 2 * y₂)
+            + (W.map A.subtype).toAffine.a₂ * x₁ * y₁ * y₂
+            + (W.map A.subtype).toAffine.a₂ * x₂ * y₁ ^ 2
+            + (W.map A.subtype).toAffine.a₄ * y₁ ^ 2 + x₁ ^ 2 * y₂ ^ 2
+            + x₁ * x₂ * y₁ * y₂ + x₂ ^ 2 * y₁ ^ 2)) * h0
+        rcases mul_eq_zero.mp hUV with h | h
+        · refine hx ?_
+          have hy12 : y₁ = y₂ := by linear_combination h
+          have hxx : (x₁ - x₂) * y₁ = 0 := by linear_combination h0 + x₁ * hy12
+          rcases mul_eq_zero.mp hxx with h' | h'
+          · exact sub_eq_zero.mp h'
+          · exact absurd h' hy₁0
+        · exact hU0 h
+      have hkey : (y₁ - (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ * x₁) * (x₁ - x₂)
+          = x₁ * y₂ - x₂ * y₁ := by
+        rw [Affine.slope_of_X_ne hx]
+        field_simp
+        ring
+      have hν0 : y₁ - (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ * x₁ ≠ 0 := by
+        intro h0
+        exact hxy21 (by rw [← hkey, h0, zero_mul])
+      refine ⟨hν0, ?_⟩
+      have hℓν : (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂
+            / (y₁ - (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ * x₁)
+          = (y₁ - y₂) / (x₁ * y₂ - x₂ * y₁) := by
+        rw [div_eq_div_iff hν0 hxy21, Affine.slope_of_X_ne hx]
+        field_simp
+        ring
+      have hVU : (y₁ - y₂) / (x₁ * y₂ - x₂ * y₁)
+          = -((-((W.map A.subtype).toAffine.a₁ * y₁ ^ 2 * y₂)
+              + (W.map A.subtype).toAffine.a₂ * x₁ * y₁ * y₂
+              + (W.map A.subtype).toAffine.a₂ * x₂ * y₁ ^ 2
+              + (W.map A.subtype).toAffine.a₄ * y₁ ^ 2 + x₁ ^ 2 * y₂ ^ 2
+              + x₁ * x₂ * y₁ * y₂ + x₂ ^ 2 * y₁ ^ 2)
+            / (y₁ ^ 2 * y₂ ^ 2 + (W.map A.subtype).toAffine.a₁ * x₁ * y₁ * y₂ ^ 2
+              - (W.map A.subtype).toAffine.a₂ * x₁ ^ 2 * y₂ ^ 2
+              + (W.map A.subtype).toAffine.a₃ * (y₁ * y₂ ^ 2 + y₁ ^ 2 * y₂)
+              - (W.map A.subtype).toAffine.a₄ * x₁ * (y₂ ^ 2 + y₁ * y₂)
+              - (W.map A.subtype).toAffine.a₆ * (y₂ ^ 2 + y₁ * y₂ + y₁ ^ 2))) := by
+        rw [← neg_div, div_eq_div_iff hxy21 hU0]
+        linear_combination hsec
+      have hVsplit : ((y₁ - y₂) / (x₁ * y₂ - x₂ * y₁)) / τ
+          = ((y₁ ^ 2 * y₂ ^ 2 + (W.map A.subtype).toAffine.a₁ * x₁ * y₁ * y₂ ^ 2
+              - (W.map A.subtype).toAffine.a₂ * x₁ ^ 2 * y₂ ^ 2
+              + (W.map A.subtype).toAffine.a₃ * (y₁ * y₂ ^ 2 + y₁ ^ 2 * y₂)
+              - (W.map A.subtype).toAffine.a₄ * x₁ * (y₂ ^ 2 + y₁ * y₂)
+              - (W.map A.subtype).toAffine.a₆ * (y₂ ^ 2 + y₁ * y₂ + y₁ ^ 2))
+                / (y₁ ^ 2 * y₂ ^ 2))⁻¹
+            * (-((-(W.map A.subtype).toAffine.a₁
+                  + (W.map A.subtype).toAffine.a₂ * (x₁ / y₁)
+                  + (W.map A.subtype).toAffine.a₂ * (x₂ / y₂)
+                  + (W.map A.subtype).toAffine.a₄ * (1 / y₂)) * ((1 / y₂) / τ)
+                + ((x₁ / y₁) / τ) * (x₁ / y₁)
+                + ((x₂ / y₂) / τ) * (x₁ / y₁ + x₂ / y₂))) := by
+        rw [hVU]
+        first
+        | (field_simp; ring1)
+      rw [hℓν, hVsplit]
+      refine A.mul_mem_nonunits hUinvA (A.nonunits.neg_mem
+        (add_mem (add_mem (A.mul_mem_nonunits ?_ hs₂) (A.mul_mem_nonunits ht₁ hT₁))
+          (A.mul_mem_nonunits ht₂ (add_mem hT₁ hT₂))))
+      exact add_mem (add_mem (add_mem (neg_mem ha1A) (mul_mem ha2A hT₁A))
+        (mul_mem ha2A hT₂A)) (mul_mem ha4A hs₂A)
+  obtain ⟨hν0, hℓν⟩ := main
+  refine ⟨hν0, hℓν, ?_⟩
+  have hℓν' : (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂
+      / (y₁ - (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ * x₁) ∈ A.nonunits := by
+    rw [show (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂
+        / (y₁ - (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ * x₁)
+      = ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂
+        / (y₁ - (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ * x₁)) / τ * τ from
+      (div_mul_cancel₀ _ hτ0).symm]
+    exact A.mul_mem_nonunits (A.nonunits_subset hℓν) hτ
+  have hy₁0 : y₁ ≠ 0 := Y_ne_zero_of_X_notMem W h₁ hx₁
+  have hline : ((1 : L) / (y₁ - (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ * x₁)) / τ
+      = (1 / y₁) / τ + ((x₁ / y₁) / τ)
+          * ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂
+            / (y₁ - (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ * x₁)) := by
+    first
+    | (field_simp; ring1)
+  rw [hline]
+  exact add_mem (inv_Y_div_mem_nonunits h₁ hx₁ ht₁) (A.mul_mem_nonunits ht₁ hℓν')
+
+omit [DecidableEq L] in
+theorem collinear_prod_sum {x₁ y₁ x₂ y₂ x₃ y₃ ℓ ν : L}
+    (he₁ : x₁ + x₂ + x₃ = ℓ ^ 2 + (W.map A.subtype).toAffine.a₁ * ℓ
+      - (W.map A.subtype).toAffine.a₂)
+    (he₂ : x₁ * x₂ + x₁ * x₃ + x₂ * x₃ = 2 * x₁ * ℓ ^ 2
+      + ((W.map A.subtype).toAffine.a₁ * x₁ - 2 * y₁ - (W.map A.subtype).toAffine.a₃) * ℓ
+      + (-(W.map A.subtype).toAffine.a₁ * y₁ + (W.map A.subtype).toAffine.a₄))
+    (he₃ : x₁ * x₂ * x₃ = x₁ ^ 2 * ℓ ^ 2
+      - (2 * x₁ * y₁ + (W.map A.subtype).toAffine.a₃ * x₁) * ℓ
+      + (y₁ ^ 2 + (W.map A.subtype).toAffine.a₃ * y₁ - (W.map A.subtype).toAffine.a₆))
+    (hν : ν = y₁ - ℓ * x₁) (hy₂ : y₂ = ℓ * x₂ + ν) (hy₃ : y₃ = ℓ * x₃ + ν) :
+    y₁ * y₂ * y₃ = ν ^ 3 - (W.map A.subtype).toAffine.a₂ * ℓ * ν ^ 2
+        + (W.map A.subtype).toAffine.a₄ * ℓ ^ 2 * ν - (W.map A.subtype).toAffine.a₆ * ℓ ^ 3 ∧
+      x₁ * y₂ * y₃ + x₂ * y₁ * y₃ + x₃ * y₁ * y₂
+        = -((W.map A.subtype).toAffine.a₁ * ℓ * ν ^ 2)
+          - (W.map A.subtype).toAffine.a₂ * ν ^ 2 + (W.map A.subtype).toAffine.a₃ * ℓ ^ 2 * ν
+          + ((W.map A.subtype).toAffine.a₄ + (W.map A.subtype).toAffine.a₄) * ℓ * ν
+          - ((W.map A.subtype).toAffine.a₆ + (W.map A.subtype).toAffine.a₆
+            + (W.map A.subtype).toAffine.a₆) * ℓ ^ 2 := by
+  subst hy₂ hy₃ hν
+  constructor
+  · linear_combination (ℓ * (y₁ - ℓ * x₁) ^ 2) * he₁ + (ℓ ^ 2 * (y₁ - ℓ * x₁)) * he₂
+      + ℓ ^ 3 * he₃
+  · linear_combination ((y₁ - ℓ * x₁) ^ 2) * he₁ + (2 * ℓ * (y₁ - ℓ * x₁)) * he₂
+      + (3 * ℓ ^ 2) * he₃
+
+theorem add_formal_param_estimate {x₁ y₁ x₂ y₂ τ : L}
+    (h₁ : (W.map A.subtype).toAffine.Equation x₁ y₁)
+    (h₂ : (W.map A.subtype).toAffine.Equation x₂ y₂)
+    (hx₁ : x₁ ∉ A) (hx₂ : x₂ ∉ A)
+    (hxy : ¬(x₁ = x₂ ∧ y₁ = (W.map A.subtype).toAffine.negY x₂ y₂))
+    (hτ : τ ∈ A.nonunits) (hτ0 : τ ≠ 0)
+    (ht₁ : (x₁ / y₁) / τ ∈ A) (ht₂ : (x₂ / y₂) / τ ∈ A) :
+    (W.map A.subtype).toAffine.addX x₁ x₂ ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂) ∉ A ∧
+      ((-((W.map A.subtype).toAffine.addX x₁ x₂
+            ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂)
+          / (W.map A.subtype).toAffine.addY x₁ x₂ y₁
+            ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂)))
+        - (-(x₁ / y₁)) - (-(x₂ / y₂))) / τ ∈ A.nonunits := by
+  have ha1A : (W.map A.subtype).toAffine.a₁ ∈ A := SetLike.coe_mem W.a₁
+  have ha2A : (W.map A.subtype).toAffine.a₂ ∈ A := SetLike.coe_mem W.a₂
+  have ha3A : (W.map A.subtype).toAffine.a₃ ∈ A := SetLike.coe_mem W.a₃
+  have ha4A : (W.map A.subtype).toAffine.a₄ ∈ A := SetLike.coe_mem W.a₄
+  have ha6A : (W.map A.subtype).toAffine.a₆ ∈ A := SetLike.coe_mem W.a₆
+  have hy₁0 : y₁ ≠ 0 := Y_ne_zero_of_X_notMem W h₁ hx₁
+  have hy₂0 : y₂ ≠ 0 := Y_ne_zero_of_X_notMem W h₂ hx₂
+  obtain ⟨hν0, hℓντ, hsντ⟩ := slope_div_intercept_estimate h₁ h₂ hx₁ hx₂ hxy hτ hτ0 ht₁ ht₂
+  obtain ⟨hv₂, hv₃⟩ := vieta_addX (W := W) h₁ h₂ hxy
+  have hS := sub_eq_slope_mul_sub (W := W) h₁ h₂ hxy
+  have hR : (W.map A.subtype).toAffine.Equation
+      ((W.map A.subtype).toAffine.addX x₁ x₂ ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂))
+      ((W.map A.subtype).toAffine.negAddY x₁ x₂ y₁
+        ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂)) :=
+    equation_negAdd h₁ h₂ hxy
+  have he₁ : x₁ + x₂ + (W.map A.subtype).toAffine.addX x₁ x₂
+        ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂)
+      = ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂) ^ 2
+        + (W.map A.subtype).toAffine.a₁ * ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂)
+        - (W.map A.subtype).toAffine.a₂ := by
+    simp only [Affine.addX]
+    ring
+  have hy₃_line : (W.map A.subtype).toAffine.negAddY x₁ x₂ y₁
+        ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂)
+      = ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂)
+          * ((W.map A.subtype).toAffine.addX x₁ x₂
+            ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂))
+        + (y₁ - (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ * x₁) := by
+    simp only [Affine.negAddY]
+    ring
+  have hy₂_line : y₂ = ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂) * x₂
+      + (y₁ - (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ * x₁) := by
+    linear_combination -hS
+  obtain ⟨hD, hN⟩ := collinear_prod_sum he₁ hv₂ hv₃ rfl hy₂_line hy₃_line
+  rw [show (W.map A.subtype).toAffine.addY x₁ x₂ y₁
+        ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂)
+      = (W.map A.subtype).toAffine.negY
+          ((W.map A.subtype).toAffine.addX x₁ x₂
+            ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂))
+          ((W.map A.subtype).toAffine.negAddY x₁ x₂ y₁
+            ((W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂)) from rfl]
+  set ℓ := (W.map A.subtype).toAffine.slope x₁ x₂ y₁ y₂ with hℓ_def
+  set x₃ := (W.map A.subtype).toAffine.addX x₁ x₂ ℓ with hx₃_def
+  set y₃ := (W.map A.subtype).toAffine.negAddY x₁ x₂ y₁ ℓ with hy₃_def
+  set ν := y₁ - ℓ * x₁ with hν_def
+  have hℓν_m : ℓ / ν ∈ A.nonunits := by
+    rw [show ℓ / ν = ℓ / ν / τ * τ from (div_mul_cancel₀ _ hτ0).symm]
+    exact A.mul_mem_nonunits (A.nonunits_subset hℓντ) hτ
+  have hℓν_A : ℓ / ν ∈ A := A.nonunits_subset hℓν_m
+  have hsν_m : (1 : L) / ν ∈ A.nonunits := by
+    rw [show (1 : L) / ν = (1 : L) / ν / τ * τ from (div_mul_cancel₀ _ hτ0).symm]
+    exact A.mul_mem_nonunits (A.nonunits_subset hsντ) hτ
+  have hu_eq : (ν ^ 3 - (W.map A.subtype).toAffine.a₂ * ℓ * ν ^ 2
+        + (W.map A.subtype).toAffine.a₄ * ℓ ^ 2 * ν
+        - (W.map A.subtype).toAffine.a₆ * ℓ ^ 3) / ν ^ 3
+      = 1 + (-((W.map A.subtype).toAffine.a₂ * (ℓ / ν))
+        + ((W.map A.subtype).toAffine.a₄ * (ℓ / ν)) * (ℓ / ν)
+        - (((W.map A.subtype).toAffine.a₆ * (ℓ / ν)) * (ℓ / ν)) * (ℓ / ν)) := by
+    field_simp
+    ring
+  have hum : (-((W.map A.subtype).toAffine.a₂ * (ℓ / ν))
+      + ((W.map A.subtype).toAffine.a₄ * (ℓ / ν)) * (ℓ / ν)
+      - (((W.map A.subtype).toAffine.a₆ * (ℓ / ν)) * (ℓ / ν)) * (ℓ / ν)) ∈ A.nonunits :=
+    sub_mem (add_mem (A.nonunits.neg_mem (A.mul_mem_nonunits ha2A hℓν_m))
+      (A.mul_mem_nonunits (mul_mem ha4A hℓν_A) hℓν_m))
+      (A.mul_mem_nonunits (mul_mem (mul_mem ha6A hℓν_A) hℓν_A) hℓν_m)
+  have hu_not : (ν ^ 3 - (W.map A.subtype).toAffine.a₂ * ℓ * ν ^ 2
+        + (W.map A.subtype).toAffine.a₄ * ℓ ^ 2 * ν
+        - (W.map A.subtype).toAffine.a₆ * ℓ ^ 3) / ν ^ 3 ∉ A.nonunits := by
+    rw [hu_eq]
+    exact A.one_add_notMem_nonunits hum
+  have hu_invA : ((ν ^ 3 - (W.map A.subtype).toAffine.a₂ * ℓ * ν ^ 2
+        + (W.map A.subtype).toAffine.a₄ * ℓ ^ 2 * ν
+        - (W.map A.subtype).toAffine.a₆ * ℓ ^ 3) / ν ^ 3)⁻¹ ∈ A :=
+    A.inv_mem_of_notMem_nonunits hu_not
+  have hD0 : ν ^ 3 - (W.map A.subtype).toAffine.a₂ * ℓ * ν ^ 2
+      + (W.map A.subtype).toAffine.a₄ * ℓ ^ 2 * ν
+      - (W.map A.subtype).toAffine.a₆ * ℓ ^ 3 ≠ 0 := by
+    intro h0
+    exact hu_not (by rw [h0, zero_div]; exact A.nonunits.zero_mem)
+  have hy₃0 : y₃ ≠ 0 := by
+    intro h0
+    rw [h0, mul_zero] at hD
+    exact hD0 hD.symm
+  have hsum_frac : -(x₃ / y₃) + -(x₁ / y₁) + -(x₂ / y₂)
+      = -((x₁ * y₂ * y₃ + x₂ * y₁ * y₃ + x₃ * y₁ * y₂) / (y₁ * y₂ * y₃)) := by
+    field_simp
+    ring
+  have hsum_split : (-(x₃ / y₃) + -(x₁ / y₁) + -(x₂ / y₂)) / τ
+      = ((ν ^ 3 - (W.map A.subtype).toAffine.a₂ * ℓ * ν ^ 2
+          + (W.map A.subtype).toAffine.a₄ * ℓ ^ 2 * ν
+          - (W.map A.subtype).toAffine.a₆ * ℓ ^ 3) / ν ^ 3)⁻¹
+        * (((W.map A.subtype).toAffine.a₁ - (W.map A.subtype).toAffine.a₃ * (ℓ / ν))
+            * (ℓ / ν / τ)
+          + ((W.map A.subtype).toAffine.a₂
+              - ((W.map A.subtype).toAffine.a₄ + (W.map A.subtype).toAffine.a₄) * (ℓ / ν)
+              + (((W.map A.subtype).toAffine.a₆ + (W.map A.subtype).toAffine.a₆
+                + (W.map A.subtype).toAffine.a₆) * (ℓ / ν)) * (ℓ / ν))
+            * ((1 : L) / ν / τ)) := by
+    rw [hsum_frac, hN, hD]
+    field_simp
+    ring
+  have hsum_mem : (-(x₃ / y₃) + -(x₁ / y₁) + -(x₂ / y₂)) / τ ∈ A.nonunits := by
+    rw [hsum_split]
+    refine A.mul_mem_nonunits hu_invA (add_mem (A.mul_mem_nonunits ?_ hℓντ)
+      (A.mul_mem_nonunits ?_ hsντ))
+    · exact sub_mem ha1A (mul_mem ha3A hℓν_A)
+    · exact add_mem (sub_mem ha2A (mul_mem (add_mem ha4A ha4A) hℓν_A))
+        (mul_mem (mul_mem (add_mem (add_mem ha6A ha6A) ha6A) hℓν_A) hℓν_A)
+  have hT₃τ : (x₃ / y₃) / τ ∈ A := by
+    have key : (x₃ / y₃) / τ = -((-(x₃ / y₃) + -(x₁ / y₁) + -(x₂ / y₂)) / τ)
+        + (-((x₁ / y₁) / τ)) + (-((x₂ / y₂) / τ)) := by
+      ring
+    rw [key]
+    exact add_mem (add_mem (neg_mem (A.nonunits_subset hsum_mem)) (neg_mem ht₁)) (neg_mem ht₂)
+  have hT₃ : x₃ / y₃ ∈ A.nonunits := by
+    rw [show x₃ / y₃ = x₃ / y₃ / τ * τ from (div_mul_cancel₀ _ hτ0).symm]
+    exact A.mul_mem_nonunits hT₃τ hτ
+  have hy₃inv : y₃⁻¹ ∈ A.nonunits := by
+    have hν_alt : ν = y₃ - ℓ * x₃ := by linear_combination -hy₃_line
+    have expand : (1 : L) / ν - ℓ / ν * (x₃ / y₃) = (y₃ - ℓ * x₃) / (ν * y₃) := by
+      first
+      | (field_simp)
+    have key : y₃⁻¹ = (1 : L) / ν - ℓ / ν * (x₃ / y₃) := by
+      rw [expand, ← hν_alt, eq_div_iff (mul_ne_zero hν0 hy₃0), mul_comm ν y₃, ← mul_assoc,
+        inv_mul_cancel₀ hy₃0, one_mul]
+    rw [key]
+    exact sub_mem hsν_m (A.mul_mem_nonunits hℓν_A hT₃)
+  have hy₃notA : y₃ ∉ A := (A.inv_mem_nonunits_iff.mp hy₃inv).resolve_left hy₃0
+  have hx₃notA : x₃ ∉ A := fun hmem => hy₃notA (Y_mem_of_X_mem W hR hmem)
+  refine ⟨hx₃notA, ?_⟩
+  have hneg := neg_formal_param_estimate (W := W) hR hx₃notA hT₃τ
+  have key : (-(x₃ / (W.map A.subtype).toAffine.negY x₃ y₃) - -(x₁ / y₁) - -(x₂ / y₂)) / τ
+      = (-(x₃ / y₃) + -(x₃ / (W.map A.subtype).toAffine.negY x₃ y₃)) / τ
+        - (-(x₃ / y₃) + -(x₁ / y₁) + -(x₂ / y₂)) / τ := by
+    ring
+  rw [key]
+  exact sub_mem hneg hsum_mem
+
+end AdditionEstimate
+
+section Assembly
+
+variable [DecidableEq L]
+
+open Affine.Point in
+theorem formal_param_nsmul {x y : L} (h : (W.map A.subtype).toAffine.Nonsingular x y)
+    (hx : x ∉ A) (j : ℕ) :
+    (j • (some x y h : (W.map A.subtype).toAffine.Point) = 0 → (j : L) ∈ A.nonunits) ∧
+    (∀ x' y' (h' : (W.map A.subtype).toAffine.Nonsingular x' y'),
+      j • (some x y h : (W.map A.subtype).toAffine.Point) = some x' y' h' →
+        x' ∉ A ∧ (-(x' / y')) / (-(x / y)) - (j : L) ∈ A.nonunits) := by
+  have hy0 : y ≠ 0 := Affine.Y_ne_zero_of_X_notMem W h.1 hx
+  have hx0 : x ≠ 0 := fun h0 => hx (h0 ▸ A.zero_mem)
+  have hτ : -(x / y) ∈ A.nonunits := A.nonunits.neg_mem (Affine.X_div_Y_mem_nonunits W h.1 hx)
+  have hτ0 : -(x / y) ≠ 0 := neg_ne_zero.mpr (div_ne_zero hx0 hy0)
+  have hself : (x / y) / -(x / y) ∈ A := by
+    rw [div_neg, div_self (div_ne_zero hx0 hy0)]
+    exact A.toSubring.neg_mem A.one_mem
+  induction j with
+  | zero =>
+    refine ⟨fun _ => by simp, fun x' y' h' heq => ?_⟩
+    rw [zero_smul] at heq
+    exact absurd heq.symm (some_ne_zero h')
+  | succ j ih =>
+    rw [succ_nsmul]
+    rcases hP : (j • (some x y h : (W.map A.subtype).toAffine.Point)) with _ | @⟨xj, yj, hj⟩
+    · have hj0 : (j : L) ∈ A.nonunits := (ih.1) hP
+      rw [← Affine.Point.zero_def, zero_add]
+      refine ⟨fun h0 => absurd h0 (some_ne_zero h), fun x' y' h' heq => ?_⟩
+      obtain ⟨rfl, rfl⟩ : x = x' ∧ y = y' := by
+        rwa [Affine.Point.some.injEq] at heq
+      refine ⟨hx, ?_⟩
+      rw [div_self hτ0, Nat.cast_succ]
+      have : (1 : L) - (j + 1) = -j := by ring
+      rw [this]
+      exact A.nonunits.neg_mem hj0
+    · have hIH := (ih.2) xj yj hj hP
+      obtain ⟨hxj, hcong⟩ := hIH
+      have htj : (xj / yj) / -(x / y) ∈ A := by
+        have h1 : -(xj / yj) / -(x / y) ∈ A := by
+          have := add_mem (A.nonunits_subset hcong) (show ((j : L)) ∈ A from by
+            simp)
+          simpa using this
+        simpa [neg_div] using A.toSubring.neg_mem h1
+      by_cases hcond : xj = x ∧ yj = (W.map A.subtype).toAffine.negY x y
+      · rw [add_of_Y_eq hcond.1 hcond.2]
+        refine ⟨fun _ => ?_, fun x' y' h' heq => absurd heq.symm (some_ne_zero h')⟩
+        have hneg := Affine.neg_formal_param_estimate (W := W) h.1 hx hself
+        rw [hcond.1, hcond.2] at hcong
+        have key : ((j : L) + 1) =
+            ((-(x / y)) + (-(x / (W.map A.subtype).toAffine.negY x y))) / -(x / y)
+              - (-(x / (W.map A.subtype).toAffine.negY x y)) / -(x / y) + (j : L)
+              + (1 - (-(x / y)) / -(x / y)) := by
+          first
+          | (field_simp; ring1)
+        rw [Nat.cast_succ, key]
+        have h1 : (1 : L) - (-(x / y)) / -(x / y) = 0 := by
+          rw [div_self hτ0]; ring
+        rw [h1, add_zero]
+        have h2 : -(x / (W.map A.subtype).toAffine.negY x y) / -(x / y) - (j : L)
+            ∈ A.nonunits := hcong
+        have h3 := A.nonunits.sub_mem hneg h2
+        have heq : ((-(x / y)) + (-(x / (W.map A.subtype).toAffine.negY x y))) / -(x / y)
+              - (-(x / (W.map A.subtype).toAffine.negY x y)) / -(x / y) + (j : L)
+            = ((-(x / y)) + (-(x / (W.map A.subtype).toAffine.negY x y))) / -(x / y)
+              - ((-(x / (W.map A.subtype).toAffine.negY x y)) / -(x / y) - (j : L)) := by
+          ring
+        rw [heq]
+        exact h3
+      · rw [add_some hcond]
+        refine ⟨fun h0 => absurd h0 (some_ne_zero _), fun x' y' h' heq => ?_⟩
+        obtain ⟨hx', hy'⟩ : (W.map A.subtype).toAffine.addX xj x
+            ((W.map A.subtype).toAffine.slope xj x yj y) = x' ∧
+            (W.map A.subtype).toAffine.addY xj x yj
+              ((W.map A.subtype).toAffine.slope xj x yj y) = y' := by
+          rwa [Affine.Point.some.injEq] at heq
+        subst hx'
+        subst hy'
+        obtain ⟨hadd1, hadd2⟩ := add_formal_param_estimate (W := W) hj.1 h.1 hxj hx hcond hτ hτ0
+          htj hself
+        refine ⟨hadd1, ?_⟩
+        have key : (-((W.map A.subtype).toAffine.addX xj x
+              ((W.map A.subtype).toAffine.slope xj x yj y)
+            / (W.map A.subtype).toAffine.addY xj x yj
+              ((W.map A.subtype).toAffine.slope xj x yj y))) / -(x / y) - ((j : ℕ) + 1 : L) =
+            ((-((W.map A.subtype).toAffine.addX xj x
+                ((W.map A.subtype).toAffine.slope xj x yj y)
+              / (W.map A.subtype).toAffine.addY xj x yj
+                ((W.map A.subtype).toAffine.slope xj x yj y)))
+              - (-(xj / yj)) - (-(x / y))) / -(x / y)
+            + ((-(xj / yj)) / -(x / y) - (j : L))
+            + ((-(x / y)) / -(x / y) - 1) := by
+          first
+          | (field_simp; ring1)
+        rw [Nat.cast_succ, key]
+        refine add_mem (add_mem hadd2 ?_) ?_
+        · exact hcong
+        · rw [div_self hτ0, sub_self]
+          exact A.nonunits.zero_mem
+
+end Assembly
+
+end Affine
+
+open Affine Affine.Point in
+theorem X_mem_of_nsmul_eq_zero' [DecidableEq L] {n : ℕ}
+    (hn : (n : ResidueField A) ≠ 0) {x y : L}
+    (h : (W.map A.subtype).toAffine.Nonsingular x y)
+    (hP : n • (some x y h : (W.map A.subtype).toAffine.Point) = 0) : x ∈ A := by
+  by_contra hx
+  refine hn ?_
+  rw [← A.natCast_mem_nonunits_iff_residue_eq_zero]
+  exact (formal_param_nsmul (W := W) h hx n).1 hP
+
+theorem X_mem_of_nsmul_eq_zero'' [DecidableEq L] {n : ℕ}
+    (hn : (n : ResidueField A) ≠ 0) {x y : L}
+    (h : (W.map A.subtype).toAffine.Nonsingular x y)
+    (hP : n • (Affine.Point.some x y h : (W.map A.subtype).toAffine.Point) = 0) : x ∈ A :=
+  X_mem_of_nsmul_eq_zero' W hn h hP
+
+open Affine.Point in
+theorem some_eq_of_mem_inertia_of_nsmul_eq_zero' [DecidableEq L]
+    (hΔ : (W.map (residue A)).Δ ≠ 0)
+    {K : Type*} [Field K] [Algebra K L] {σ : L ≃ₐ[K] L} (hσ : σ ∈ A.decompositionSubgroup K)
+    (hσI : (⟨σ, hσ⟩ : A.decompositionSubgroup K) ∈ A.inertiaSubgroup K)
+    {n : ℕ} (hn : (n : ResidueField A) ≠ 0) {x y : L}
+    (h : (W.map A.subtype).toAffine.Nonsingular x y)
+    (h' : (W.map A.subtype).toAffine.Nonsingular (σ x) (σ y))
+    (hP : n • (some x y h : (W.map A.subtype).toAffine.Point) = 0)
+    (hP' : n • (some (σ x) (σ y) h' : (W.map A.subtype).toAffine.Point) = 0) :
+    (some (σ x) (σ y) h' : (W.map A.subtype).toAffine.Point) = some x y h := by
+  have hx : x ∈ A := X_mem_of_nsmul_eq_zero' W hn h hP
+  have hy : y ∈ A := Affine.Y_mem_of_X_mem W h.1 hx
+  have hσx : σ x ∈ A := A.smul_mem_of_mem_decompositionSubgroup K hσ hx
+  have hσy : σ y ∈ A := A.smul_mem_of_mem_decompositionSubgroup K hσ hy
+  have hresx : σ x - x ∈ A.nonunits := by
+    rw [show σ x - x = (((⟨σ x, hσx⟩ : A) - ⟨x, hx⟩ : A) : L) from rfl,
+      A.coe_mem_nonunits_iff_residue_eq_zero, map_sub, sub_eq_zero]
+    exact A.residue_smul_eq_of_mem_inertiaSubgroup hσ hσI ⟨x, hx⟩
+  have hresy : σ y - y ∈ A.nonunits := by
+    rw [show σ y - y = (((⟨σ y, hσy⟩ : A) - ⟨y, hy⟩ : A) : L) from rfl,
+      A.coe_mem_nonunits_iff_residue_eq_zero, map_sub, sub_eq_zero]
+    exact A.residue_smul_eq_of_mem_inertiaSubgroup hσ hσI ⟨y, hy⟩
+  by_contra hne
+  have hnegns : (W.map A.subtype).toAffine.Nonsingular x ((W.map A.subtype).toAffine.negY x y) :=
+    (Affine.nonsingular_neg ..).mpr h
+  have hPQ : ¬(σ x = x ∧ σ y = (W.map A.subtype).toAffine.negY x
+      ((W.map A.subtype).toAffine.negY x y)) := by
+    rw [Affine.negY_negY]
+    exact fun ⟨hx', hy'⟩ => hne (by simp only [Affine.Point.some.injEq]; exact ⟨hx', hy'⟩)
+  have hQdef : (some (σ x) (σ y) h' : (W.map A.subtype).toAffine.Point) - some x y h =
+      some _ _ (Affine.nonsingular_add h' hnegns hPQ) := by
+    rw [sub_eq_add_neg, neg_some, add_some hPQ]
+  have hQtor : n • ((some (σ x) (σ y) h' : (W.map A.subtype).toAffine.Point) - some x y h)
+      = 0 := by
+    rw [smul_sub, hP, hP', sub_zero]
+  have hQX : (W.map A.subtype).toAffine.addX (σ x) x
+      ((W.map A.subtype).toAffine.slope (σ x) x (σ y)
+        ((W.map A.subtype).toAffine.negY x y)) ∈ A := by
+    refine X_mem_of_nsmul_eq_zero' W hn (Affine.nonsingular_add h' hnegns hPQ) ?_
+    rw [← hQdef]
+    exact hQtor
+  refine Affine.addX_notMem_of_sub_mem_nonunits W hΔ h'.1 hnegns.1 hσx hx hPQ hresx ?_ hQX
+  rw [Affine.negY_negY]
+  exact hresy
+
+open Affine.Point in
+theorem fixed_of_mem_inertia_of_nsmul_eq_zero [DecidableEq L] {V : WeierstrassCurve L}
+    (W : WeierstrassCurve A) (hVW : W.map A.subtype = V)
+    (hΔ : (W.map (residue A)).Δ ≠ 0)
+    {K : Type*} [Field K] [Algebra K L] {σ : L ≃ₐ[K] L} (hσ : σ ∈ A.decompositionSubgroup K)
+    (hσI : (⟨σ, hσ⟩ : A.decompositionSubgroup K) ∈ A.inertiaSubgroup K)
+    {n : ℕ} (hn : (n : ResidueField A) ≠ 0) {x y : L}
+    (h : V.toAffine.Nonsingular x y)
+    (h' : V.toAffine.Nonsingular (σ x) (σ y))
+    (hP : n • (some x y h : V.toAffine.Point) = 0)
+    (hP' : n • (some (σ x) (σ y) h' : V.toAffine.Point) = 0) :
+    σ x = x ∧ σ y = y := by
+  subst hVW
+  have key := some_eq_of_mem_inertia_of_nsmul_eq_zero' W hΔ hσ hσI hn h h' hP hP'
+  rwa [Affine.Point.some.injEq] at key
+
+end WeierstrassCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_VariableChangePointEquiv.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_VariableChangePointEquiv.lean
new file mode 100644
index 0000000000..81fa6ee004
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_VariableChangePointEquiv.lean
@@ -0,0 +1,214 @@
+/-
+Based on Prove2Me node WeierstrassCurve_VariableChangePointEquiv
+(9717755e-d9aa-5201-ae3e-fa765185ea88) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.AlgebraicGeometry.EllipticCurve.VariableChange
+
+/-!
+# Point bijection induced by a Weierstrass variable change
+
+Definition: `WeierstrassCurve_VariableChangePointEquiv` (`9717755e-d9aa-5201-ae3e-fa765185ea88`), by
+Claude, 2026-09-05.
+
+Let $K$ be a field, $W$ an affine Weierstrass curve over $K$ with coefficients
+$a_1,a_2,a_3,a_4,a_6$, and $C=(u,r,s,t)$ a variable change over $K$ (so $u \in K^\times$), acting on
+Weierstrass curves by Mathlib's scalar action $C \bullet W$. The module first defines the four
+coordinate formulas $\mathtt{vcX}\,C\,x' = u^2 x' + r$, $\mathtt{vcY}\,C\,x'\,y' = u^3 y' + u^2 s x'
++ t$ and their inverses $\mathtt{vcXInv}\,C\,x = u^{-2}(x-r)$, $\mathtt{vcYInv}\,C\,x\,y =
+u^{-3}\bigl(y - t - s(x-r)\bigr)$, together with the four lemmas saying that the two pairs are
+mutually inverse on $K \times K$.
+
+The transport statements rest on three polynomial identities: substituting $(\mathtt{vcX},
+\mathtt{vcY})$ into the Weierstrass polynomial of $W$ multiplies the Weierstrass polynomial of $C
+\bullet W$ by $u^6$; the combination of the $x$-partial of $W$ with $s$ times the $y$-partial scales
+by $u^4$ to the $x$-partial of $C \bullet W$; and the $y$-partial scales by $u^3$. Since these
+powers of $u$ are nonzero, one obtains `equation_variableChange_iff`: $(x',y')$ satisfies the
+Weierstrass equation of $C \bullet W$ exactly when $(\mathtt{vcX}\,C\,x', \mathtt{vcY}\,C\,x'\,y')$
+satisfies that of $W$; and `nonsingular_variableChange_iff`, the same equivalence for Mathlib's
+`Nonsingular` predicate (equation together with non-vanishing of at least one partial derivative).
+
+From these, the maps `Point.vcFun` and `Point.vcInvFun` send the point at infinity to the point at
+infinity and act on affine points by the coordinate formulas; they are mutually inverse, giving
+`Point.variableChangeEquiv : (C \bullet W).toAffine.Point ≃ W.Point`. Finally
+`Point.equivOfVariableChangeEq` records the same bijection $V(K) \simeq W(K)$ whenever $C \bullet W
+= V$ for some Weierstrass curve $V$. Both are bijections of sets only; no compatibility with the
+group laws is asserted.
+
+**Relation to Mathlib.** Built entirely on Mathlib's `WeierstrassCurve.VariableChange`, its action
+on Weierstrass curves, and `WeierstrassCurve.Affine.Point` with its `Equation`/`Nonsingular`
+predicates; it supplies the explicit substitution formulas and the resulting bijection of point
+sets, stopping short of an additive isomorphism.
+
+**Where it is used.** The bijection is what makes point counts on a Weierstrass curve depend only on
+its isomorphism class of models, and hence makes the traces of Frobenius $a_q$ attached to an
+elliptic curve independent of the chosen Weierstrass presentation; this invariance is used
+throughout the passage from Frey curves to their Galois representations.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace WeierstrassCurve.Affine
+
+variable {K : Type*} [Field K]
+
+section Formulas
+
+variable (C : VariableChange K) (W : WeierstrassCurve.Affine K)
+
+def vcX (x' : K) : K := (C.u : K) ^ 2 * x' + C.r
+
+def vcY (x' y' : K) : K := (C.u : K) ^ 3 * y' + (C.u : K) ^ 2 * C.s * x' + C.t
+
+def vcXInv (x : K) : K := ((C.u⁻¹ : Kˣ) : K) ^ 2 * (x - C.r)
+
+def vcYInv (x y : K) : K := ((C.u⁻¹ : Kˣ) : K) ^ 3 * (y - C.t - C.s * (x - C.r))
+
+variable {C W}
+
+private lemma u_ne_zero : (C.u : K) ≠ 0 := C.u.ne_zero
+private lemma u_pow_ne_zero (n : ℕ) : ((C.u : K)) ^ n ≠ 0 := pow_ne_zero n C.u.ne_zero
+
+@[simp] lemma vcX_vcXInv (x : K) : vcX C (vcXInv C x) = x := by
+  have hu : (C.u : K) ≠ 0 := u_ne_zero
+  simp only [vcX, vcXInv, Units.val_inv_eq_inv_val]; field_simp; ring
+
+@[simp] lemma vcY_vcYInv (x y : K) : vcY C (vcXInv C x) (vcYInv C x y) = y := by
+  have hu : (C.u : K) ≠ 0 := u_ne_zero
+  simp only [vcY, vcXInv, vcYInv, Units.val_inv_eq_inv_val]; field_simp; ring
+
+@[simp] lemma vcXInv_vcX (x' : K) : vcXInv C (vcX C x') = x' := by
+  have hu : (C.u : K) ≠ 0 := u_ne_zero
+  simp only [vcX, vcXInv, Units.val_inv_eq_inv_val]; field_simp; ring
+
+@[simp] lemma vcYInv_vcY (x' y' : K) : vcYInv C (vcX C x') (vcY C x' y') = y' := by
+  have hu : (C.u : K) ≠ 0 := u_ne_zero
+  simp only [vcX, vcY, vcYInv, Units.val_inv_eq_inv_val]; field_simp; ring
+
+private lemma equation_aux (x' y' : K) :
+    vcY C x' y' ^ 2 + W.a₁ * vcX C x' * vcY C x' y' + W.a₃ * vcY C x' y'
+      - (vcX C x' ^ 3 + W.a₂ * vcX C x' ^ 2 + W.a₄ * vcX C x' + W.a₆)
+    = (C.u : K) ^ 6 *
+      (y' ^ 2 + (C • W).a₁ * x' * y' + (C • W).a₃ * y'
+        - (x' ^ 3 + (C • W).a₂ * x' ^ 2 + (C • W).a₄ * x' + (C • W).a₆)) := by
+  have hu : (C.u : K) ≠ 0 := u_ne_zero
+  simp only [vcX, vcY, variableChange_a₁, variableChange_a₂, variableChange_a₃,
+    variableChange_a₄, variableChange_a₆, Units.val_inv_eq_inv_val]
+  field_simp; ring
+
+private lemma partialX_aux (x' y' : K) :
+    W.a₁ * vcY C x' y' - (3 * vcX C x' ^ 2 + 2 * W.a₂ * vcX C x' + W.a₄)
+      + C.s * (2 * vcY C x' y' + W.a₁ * vcX C x' + W.a₃)
+    = (C.u : K) ^ 4 *
+      ((C • W).a₁ * y' - (3 * x' ^ 2 + 2 * (C • W).a₂ * x' + (C • W).a₄)) := by
+  have hu : (C.u : K) ≠ 0 := u_ne_zero
+  simp only [vcX, vcY, variableChange_a₁, variableChange_a₂, variableChange_a₄,
+    Units.val_inv_eq_inv_val]
+  field_simp; ring
+
+private lemma partialY_aux (x' y' : K) :
+    2 * vcY C x' y' + W.a₁ * vcX C x' + W.a₃
+      = (C.u : K) ^ 3 * (2 * y' + (C • W).a₁ * x' + (C • W).a₃) := by
+  have hu : (C.u : K) ≠ 0 := u_ne_zero
+  simp only [vcX, vcY, variableChange_a₁, variableChange_a₃, Units.val_inv_eq_inv_val]
+  field_simp; ring
+
+lemma equation_variableChange_iff (x' y' : K) :
+    (C • W).toAffine.Equation x' y' ↔ W.Equation (vcX C x') (vcY C x' y') := by
+  rw [equation_iff', equation_iff', equation_aux x' y', mul_eq_zero,
+    or_iff_right (u_pow_ne_zero 6)]
+
+private lemma partials_zero_iff (x' y' : K) :
+    ((C • W).a₁ * y' - (3 * x' ^ 2 + 2 * (C • W).a₂ * x' + (C • W).a₄) = 0
+        ∧ 2 * y' + (C • W).a₁ * x' + (C • W).a₃ = 0)
+      ↔ (W.a₁ * vcY C x' y' - (3 * vcX C x' ^ 2 + 2 * W.a₂ * vcX C x' + W.a₄) = 0
+        ∧ 2 * vcY C x' y' + W.a₁ * vcX C x' + W.a₃ = 0) := by
+  constructor
+  · rintro ⟨hX', hY'⟩
+    have hY : 2 * vcY C x' y' + W.a₁ * vcX C x' + W.a₃ = 0 := by
+      rw [partialY_aux x' y', hY', mul_zero]
+    refine ⟨?_, hY⟩
+    have hX := partialX_aux (C := C) (W := W) x' y'
+    rw [hX', mul_zero, hY, mul_zero, add_zero] at hX
+    exact hX
+  · rintro ⟨hX, hY⟩
+    have hY' : 2 * y' + (C • W).a₁ * x' + (C • W).a₃ = 0 := by
+      have h := partialY_aux (C := C) (W := W) x' y'
+      rw [hY] at h
+      exact (mul_eq_zero.mp h.symm).resolve_left (u_pow_ne_zero 3)
+    refine ⟨?_, hY'⟩
+    have h := partialX_aux (C := C) (W := W) x' y'
+    rw [hX, hY, mul_zero, add_zero] at h
+    exact (mul_eq_zero.mp h.symm).resolve_left (u_pow_ne_zero 4)
+
+lemma nonsingular_variableChange_iff (x' y' : K) :
+    (C • W).toAffine.Nonsingular x' y' ↔ W.Nonsingular (vcX C x') (vcY C x' y') := by
+  rw [nonsingular_iff', nonsingular_iff', equation_variableChange_iff x' y']
+  refine and_congr_right fun _ => not_iff_not.mp ?_
+  push Not
+  exact partials_zero_iff x' y'
+
+end Formulas
+
+section PointEquiv
+
+variable (C : VariableChange K) (W : WeierstrassCurve.Affine K)
+
+namespace Point
+
+def vcFun : (C • W).toAffine.Point → W.Point
+  | 0 => 0
+  | .some x' y' h => .some (vcX C x') (vcY C x' y')
+      ((nonsingular_variableChange_iff x' y').mp h)
+
+def vcInvFun : W.Point → (C • W).toAffine.Point
+  | 0 => 0
+  | .some x y h => .some (vcXInv C x) (vcYInv C x y)
+      ((nonsingular_variableChange_iff (vcXInv C x) (vcYInv C x y)).mpr
+        (by rwa [vcX_vcXInv, vcY_vcYInv]))
+
+variable {C W}
+
+@[simp] lemma vcFun_zero : vcFun C W 0 = 0 := rfl
+@[simp] lemma vcInvFun_zero : vcInvFun C W 0 = 0 := rfl
+
+private lemma some_eq_some {W' : WeierstrassCurve.Affine K} {x₁ y₁ x₂ y₂ : K}
+    (hx : x₁ = x₂) (hy : y₁ = y₂)
+    {h₁ : W'.Nonsingular x₁ y₁} {h₂ : W'.Nonsingular x₂ y₂} :
+    Point.some x₁ y₁ h₁ = Point.some x₂ y₂ h₂ := by subst hx hy; rfl
+
+lemma vcFun_leftInverse : Function.LeftInverse (vcInvFun C W) (vcFun C W) := by
+  rintro (_ | ⟨x', y', h⟩)
+  · rfl
+  · simp only [vcFun, vcInvFun]
+    exact some_eq_some (vcXInv_vcX x') (vcYInv_vcY x' y')
+
+lemma vcFun_rightInverse : Function.RightInverse (vcInvFun C W) (vcFun C W) := by
+  rintro (_ | ⟨x, y, h⟩)
+  · rfl
+  · simp only [vcFun, vcInvFun]
+    exact some_eq_some (vcX_vcXInv x) (vcY_vcYInv x y)
+
+variable (C W) in
+noncomputable def variableChangeEquiv : (C • W).toAffine.Point ≃ W.Point :=
+  ⟨vcFun C W, vcInvFun C W, vcFun_leftInverse, vcFun_rightInverse⟩
+
+noncomputable def equivOfVariableChangeEq {V : WeierstrassCurve.Affine K}
+    (h : C • W = V) : V.Point ≃ W.Point := by
+  subst h; exact variableChangeEquiv C W
+
+end Point
+
+end PointEquiv
+
+end WeierstrassCurve.Affine
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_Velu.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_Velu.lean
new file mode 100644
index 0000000000..d1240e7378
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_Velu.lean
@@ -0,0 +1,151 @@
+/-
+Based on Prove2Me node WeierstrassCurve_Velu
+(6a9eeeb8-96e5-531c-a7a4-97dae68a58d6) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Formula
+
+/-!
+# Vélu quantities and the Vélu quotient Weierstrass curve
+
+Definition: `WeierstrassCurve_Velu` (`6a9eeeb8-96e5-531c-a7a4-97dae68a58d6`), by Claude, 2026-09-05.
+
+For a Weierstrass curve $W$ over a commutative ring $R$, with coefficients $a_1,\dots,a_6$ and the
+usual $b$-invariants, the module introduces the per-point Vélu quantities attached to a pair $(x,y)
+\in R \times R$: `veluGx` $= 3x^2 + 2a_2x + a_4 - a_1y$ and `veluGy` $= -(2y + a_1x + a_3)$ (the two
+partial derivatives of the Weierstrass equation), then `veluT` $= 2\,g_x - a_1 g_y$, `veluU` $=
+g_y^2$ and `veluW` $= u + x\,t$. These are taken in a single uniform convention, with no case
+distinction at $2$-torsion. Three identities record their shape: `veluT_eq` gives the closed form $t
+= 6x^2 + b_2x + b_4$, which involves $x$ only; `veluU_eq_Ψ₂Sq_eval` says that for $(x,y)$ satisfying
+the affine Weierstrass equation, $u$ equals Mathlib's division-polynomial quantity `Ψ₂Sq` evaluated
+at $x$; and `veluGy_negY`, `veluT_negY`, `veluU_negY`, `veluW_negY` say that replacing $y$ by
+$-y-a_1x-a_3$ negates $g_y$ and leaves $t$, $u$, $w$ unchanged, while `veluGy_eq_zero_of_negY_eq`
+says $g_y = 0$ at a point fixed by this involution.
+
+For a finite set $S \subseteq R \times R$ one forms the sums `veluTSum` $t = \sum_{P \in S} t_P$ and
+`veluWSum` $w = \sum_{P \in S} w_P$, and defines `veluQuotient W S` to be the Weierstrass curve with
+coefficients $(a_1, a_2, a_3, a_4 - 5t, a_6 - b_2 t - 7w)$. Its $b$-invariants are computed: $b_2$
+is unchanged, $b_4 \mapsto b_4 - 10t$, $b_6 \mapsto b_6 - 4b_2t - 28w$, $b_8 \mapsto b_8 + (5b_4 -
+b_2^2)t - 7b_2w - 25t^2$; for $S = \emptyset$ the sums vanish and the quotient is $W$ itself.
+Finally `IsVeluSet W S` is a one-field structure asserting only that every $P \in S$ satisfies the
+affine equation of $W$; it imposes no subgroup, kernel or symmetry condition, and nothing here
+asserts the existence of an isogeny $W \to$ `veluQuotient W S`. The material is thus purely the
+coefficient formulas, not yet the isogeny theorem.
+
+**Relation to Mathlib.** Built entirely on Mathlib: the curves are Mathlib `WeierstrassCurve`s, the
+point condition is Mathlib's `Affine.Equation`, the involution is Mathlib's `Affine.negY`, and
+`Ψ₂Sq` is Mathlib's division polynomial. Mathlib has no isogenies or Vélu formulas, so the Vélu
+quantities, the quotient curve and `IsVeluSet` are the project's own definitions.
+
+**Where it is used.** These explicit formulas underlie the isogeny-quotient material used in the
+analysis of the Frey curve's mod-$p$ representation, where the quotient of a curve by the kernel of
+a putative rational $p$-isogeny has to be exhibited concretely.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open Polynomial
+
+namespace WeierstrassCurve
+
+variable {R : Type*} [CommRing R] (W : WeierstrassCurve R)
+
+def veluGx (x y : R) : R := 3 * x ^ 2 + 2 * W.a₂ * x + W.a₄ - W.a₁ * y
+
+def veluGy (x y : R) : R := -(2 * y + W.a₁ * x + W.a₃)
+
+def veluT (x y : R) : R := 2 * W.veluGx x y - W.a₁ * W.veluGy x y
+
+def veluU (x y : R) : R := W.veluGy x y ^ 2
+
+def veluW (x y : R) : R := W.veluU x y + x * W.veluT x y
+
+lemma veluT_eq (x y : R) : W.veluT x y = 6 * x ^ 2 + W.b₂ * x + W.b₄ := by
+  simp only [veluT, veluGx, veluGy, b₂, b₄]; ring
+
+lemma veluU_eq_Ψ₂Sq_eval {x y : R} (h : W.toAffine.Equation x y) :
+    W.veluU x y = W.Ψ₂Sq.eval x := by
+  rw [Affine.equation_iff] at h
+  simp only [veluU, veluGy, Ψ₂Sq, b₂, b₄, b₆, eval_add, eval_mul, eval_pow, eval_C, eval_X]
+  linear_combination 4 * h
+
+lemma veluGy_negY (x y : R) : W.veluGy x (W.toAffine.negY x y) = -W.veluGy x y := by
+  simp only [veluGy, Affine.negY]; ring
+
+lemma veluT_negY (x y : R) : W.veluT x (W.toAffine.negY x y) = W.veluT x y := by
+  simp only [veluT_eq]
+
+lemma veluU_negY (x y : R) : W.veluU x (W.toAffine.negY x y) = W.veluU x y := by
+  simp only [veluU, veluGy, Affine.negY]; ring
+
+lemma veluW_negY (x y : R) : W.veluW x (W.toAffine.negY x y) = W.veluW x y := by
+  simp only [veluW, veluU_negY, veluT_negY]
+
+lemma veluGy_eq_zero_of_negY_eq {x y : R} (h : W.toAffine.negY x y = y) :
+    W.veluGy x y = 0 := by
+  have : 2 * y + W.a₁ * x + W.a₃ = 0 := by
+    have := h
+    simp only [Affine.negY] at this
+    linear_combination -this
+  simp [veluGy, this]
+
+variable (S : Finset (R × R))
+
+def veluTSum : R := ∑ P ∈ S, W.veluT P.1 P.2
+
+def veluWSum : R := ∑ P ∈ S, W.veluW P.1 P.2
+
+@[simp] lemma veluTSum_empty : W.veluTSum ∅ = 0 := by simp [veluTSum]
+
+@[simp] lemma veluWSum_empty : W.veluWSum ∅ = 0 := by simp [veluWSum]
+
+def veluQuotient : WeierstrassCurve R where
+  a₁ := W.a₁
+  a₂ := W.a₂
+  a₃ := W.a₃
+  a₄ := W.a₄ - 5 * W.veluTSum S
+  a₆ := W.a₆ - W.b₂ * W.veluTSum S - 7 * W.veluWSum S
+
+@[simp] lemma veluQuotient_a₁ : (W.veluQuotient S).a₁ = W.a₁ := rfl
+@[simp] lemma veluQuotient_a₂ : (W.veluQuotient S).a₂ = W.a₂ := rfl
+@[simp] lemma veluQuotient_a₃ : (W.veluQuotient S).a₃ = W.a₃ := rfl
+lemma veluQuotient_a₄ : (W.veluQuotient S).a₄ = W.a₄ - 5 * W.veluTSum S := rfl
+lemma veluQuotient_a₆ :
+    (W.veluQuotient S).a₆ = W.a₆ - W.b₂ * W.veluTSum S - 7 * W.veluWSum S := rfl
+
+@[simp] lemma veluQuotient_empty : W.veluQuotient ∅ = W := by
+  ext <;> simp [veluQuotient]
+
+lemma veluQuotient_b₂ : (W.veluQuotient S).b₂ = W.b₂ := by
+  simp [b₂]
+
+lemma veluQuotient_b₄ : (W.veluQuotient S).b₄ = W.b₄ - 10 * W.veluTSum S := by
+  simp only [b₄, veluQuotient_a₃, veluQuotient_a₁, veluQuotient_a₄]; ring
+
+lemma veluQuotient_b₆ :
+    (W.veluQuotient S).b₆ = W.b₆ - 4 * W.b₂ * W.veluTSum S - 28 * W.veluWSum S := by
+  simp only [b₆, b₂, veluQuotient_a₃, veluQuotient_a₆]; ring
+
+lemma veluQuotient_b₈ :
+    (W.veluQuotient S).b₈ = W.b₈ + (5 * W.b₄ - W.b₂ ^ 2) * W.veluTSum S
+      - 7 * W.b₂ * W.veluWSum S - 25 * W.veluTSum S ^ 2 := by
+  simp only [b₈, b₂, b₄, veluQuotient_a₁, veluQuotient_a₂, veluQuotient_a₃, veluQuotient_a₄,
+    veluQuotient_a₆]
+  ring
+
+structure IsVeluSet : Prop where
+  equation : ∀ P ∈ S, W.toAffine.Equation P.1 P.2
+
+lemma isVeluSet_empty : W.IsVeluSet ∅ := ⟨by simp⟩
+
+end WeierstrassCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_VeluOrderTwo.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_VeluOrderTwo.lean
new file mode 100644
index 0000000000..b0e00dbc85
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_VeluOrderTwo.lean
@@ -0,0 +1,157 @@
+/-
+Based on Prove2Me node WeierstrassCurve_VeluOrderTwo
+(7eab6173-25e6-529c-9db6-95dd6f665b77) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_Velu
+public import Mathlib.AlgebraicGeometry.EllipticCurve.VariableChange
+
+/-!
+# Vélu quotient by an order-two point; quadratic cofactor discriminant
+
+Definition: `WeierstrassCurve_VeluOrderTwo` (`7eab6173-25e6-529c-9db6-95dd6f665b77`), by Claude,
+2026-09-05.
+
+Throughout, $R$ is a commutative ring and $W$ a Weierstrass curve over $R$ with coefficients
+$a_1,a_2,a_3,a_4,a_6$.
+
+The first definition,
+[`WeierstrassCurve.veluQuotient2`](../def/WeierstrassCurve_VeluOrderTwo.html#L12), attaches to a
+pair $(x_0,y_0)$ of elements of $R$ a new Weierstrass curve over $R$. Writing $t =$ `W.veluGx x₀ y₀`
+$= 3x_0^2 + 2a_2x_0 + a_4 - a_1y_0$ (the $X$-partial of the Weierstrass polynomial at $(x_0,y_0)$,
+up to sign), the new curve has the same $a_1,a_2,a_3$ as $W$, and
+$$a_4' = a_4 - 5t, \qquad a_6' = a_6 - b_2 t - 7x_0 t .$$
+This is the shape of [`WeierstrassCurve.veluQuotient`](../def/WeierstrassCurve_Velu.html#L59) for a
+Vélu set, with the sums $\sum \mathrm{t}_P$ and $\sum \mathrm{w}_P$ replaced by the single values
+$t$ and $x_0 t$; at a point of order two, where `veluGy` vanishes, this halves the uniform
+odd-kernel contributions $\mathrm{t} = 2t$ and $\mathrm{w} = 2x_0t$, which is the convention
+appropriate to a self-paired kernel point. The accompanying component lemmas record the five
+coefficients, and `veluQuotient2_b₂` records that $b_2 = a_1^2 + 4a_2$ is unchanged by the
+construction. No hypothesis relating $(x_0,y_0)$ to $W$ is imposed: the curve is defined for an
+arbitrary pair.
+
+The second definition,
+[`WeierstrassCurve.velu2QuadDisc`](../def/WeierstrassCurve_VeluOrderTwo.html#L32), is the element
+$$d(x_0) = b_2^2 - 8b_2x_0 - 48x_0^2 - 32b_4$$
+of $R$, again for arbitrary $x_0$. The lemma `velu2QuadDisc_eq_disc_cofactor` rewrites it as
+$(b_2+4x_0)^2 - 16\,(4x_0^2 + b_2x_0 + 2b_4)$, i.e. as the discriminant of the quadratic $4X^2 +
+(b_2+4x_0)X + (4x_0^2+b_2x_0+2b_4)$, which is the cofactor of $X - x_0$ in the $2$-division
+polynomial $4X^3 + b_2X^2 + 2b_4X + b_6$ when $x_0$ is a root of the latter. Finally,
+`map_velu2QuadDisc` states compatibility with base change: for a ring homomorphism $f \colon R \to
+S$, the invariant of $W.\mathrm{map}\,f$ at $f(x_0)$ is $f(d(x_0))$.
+
+Translating an order-two point $(x_0,y_0)$ to the origin gives the normal form
+$(a_1,a_2+3x_0,0,g_x,0)$. The same translation gives the quotient coefficients
+$(a_1,a_2+3x_0,0,-4g_x,-Bg_x)$, where $B=a_1^2+4(a_2+3x_0)$.
+The quadratic cofactor discriminant becomes $B^2-64g_x$. These identities use no division
+and support the discriminant formulas via Mathlib's invariance under variable changes.
+
+**Relation to Mathlib.** Mathlib supplies `WeierstrassCurve`, the invariants $b_2,b_4$, the
+$2$-division polynomial and base change along a ring homomorphism; the Vélu quotient curves and the
+quantity `velu2QuadDisc` are the project's own, built on the Vélu data (`veluGx`, `veluT`, `veluW`,
+`veluQuotient`) of the project's Vélu module.
+
+**Where it is used.** These definitions support the order-two branch of Vélu's isogeny construction,
+where the kernel is generated by a single affine $2$-torsion point and the odd-kernel convention
+would count it twice. The quantity `velu2QuadDisc` is the invariant through which the discriminants
+of $W$ and of its quotient by an order-two point are compared, as needed for the $2$-isogeny
+arguments about Frey curves.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace WeierstrassCurve
+
+section CommRing
+
+variable {R : Type*} [CommRing R] (W : WeierstrassCurve R)
+
+def veluQuotient2 (x₀ y₀ : R) : WeierstrassCurve R where
+  a₁ := W.a₁
+  a₂ := W.a₂
+  a₃ := W.a₃
+  a₄ := W.a₄ - 5 * W.veluGx x₀ y₀
+  a₆ := W.a₆ - W.b₂ * W.veluGx x₀ y₀ - 7 * (x₀ * W.veluGx x₀ y₀)
+
+variable (x₀ y₀ : R)
+
+@[simp] lemma veluQuotient2_a₁ : (W.veluQuotient2 x₀ y₀).a₁ = W.a₁ := rfl
+@[simp] lemma veluQuotient2_a₂ : (W.veluQuotient2 x₀ y₀).a₂ = W.a₂ := rfl
+@[simp] lemma veluQuotient2_a₃ : (W.veluQuotient2 x₀ y₀).a₃ = W.a₃ := rfl
+lemma veluQuotient2_a₄ : (W.veluQuotient2 x₀ y₀).a₄ = W.a₄ - 5 * W.veluGx x₀ y₀ := rfl
+lemma veluQuotient2_a₆ :
+    (W.veluQuotient2 x₀ y₀).a₆ = W.a₆ - W.b₂ * W.veluGx x₀ y₀ - 7 * (x₀ * W.veluGx x₀ y₀) :=
+  rfl
+
+lemma veluQuotient2_b₂ : (W.veluQuotient2 x₀ y₀).b₂ = W.b₂ := by
+  simp [b₂]
+
+def velu2QuadDisc (x₀ : R) : R :=
+  W.b₂ ^ 2 - 8 * W.b₂ * x₀ - 48 * x₀ ^ 2 - 32 * W.b₄
+
+lemma velu2QuadDisc_def (x₀ : R) :
+    W.velu2QuadDisc x₀ = W.b₂ ^ 2 - 8 * W.b₂ * x₀ - 48 * x₀ ^ 2 - 32 * W.b₄ := rfl
+
+lemma velu2QuadDisc_eq_disc_cofactor (x₀ : R) :
+    W.velu2QuadDisc x₀
+      = (W.b₂ + 4 * x₀) ^ 2 - 16 * (4 * x₀ ^ 2 + W.b₂ * x₀ + 2 * W.b₄) := by
+  simp only [velu2QuadDisc]; ring
+
+lemma map_velu2QuadDisc {S : Type*} [CommRing S] (f : R →+* S) (x₀ : R) :
+    (W.map f).velu2QuadDisc (f x₀) = f (W.velu2QuadDisc x₀) := by
+  simp only [velu2QuadDisc, map_b₂, map_b₄, map_sub, map_mul, map_pow, map_ofNat]
+
+variable {x₀ y₀}
+
+/-- Translate an order-two point to the origin without dividing by two. -/
+lemma velu2_variableChange (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) :
+    (⟨1, x₀, 0, y₀⟩ : VariableChange R) • W =
+      ⟨W.a₁, W.a₂ + 3 * x₀, 0, W.veluGx x₀ y₀, 0⟩ := by
+  have hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0 := by
+    simpa only [veluGy, neg_eq_zero] using hgy
+  rw [Affine.equation_iff] at hQ
+  rw [variableChange_def]
+  ext <;> simp only [inv_one, Units.val_one, one_pow, one_mul, zero_mul, mul_zero,
+    add_zero, sub_zero, zero_pow (by decide : (2 : ℕ) ≠ 0), veluGx]
+  · linear_combination hord
+  · ring
+  · linear_combination -hQ
+
+/-- The same translation puts the order-two quotient in its small normal form. -/
+lemma veluQuotient2_variableChange (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) :
+    (⟨1, x₀, 0, y₀⟩ : VariableChange R) • W.veluQuotient2 x₀ y₀ =
+      ⟨W.a₁, W.a₂ + 3 * x₀, 0, -4 * W.veluGx x₀ y₀,
+        -(W.a₁ ^ 2 + 4 * (W.a₂ + 3 * x₀)) * W.veluGx x₀ y₀⟩ := by
+  have hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0 := by
+    simpa only [veluGy, neg_eq_zero] using hgy
+  rw [Affine.equation_iff] at hQ
+  rw [variableChange_def]
+  ext <;> simp only [inv_one, Units.val_one, one_pow, one_mul, zero_mul, mul_zero,
+    add_zero, sub_zero, zero_pow (by decide : (2 : ℕ) ≠ 0), veluQuotient2, b₂, veluGx]
+  · linear_combination hord
+  · ring
+  · linear_combination -hQ
+
+/-- The quadratic cofactor discriminant in coordinates centred at the order-two point. -/
+lemma velu2QuadDisc_eq_shifted (hgy : W.veluGy x₀ y₀ = 0) :
+    W.velu2QuadDisc x₀ =
+      (W.a₁ ^ 2 + 4 * (W.a₂ + 3 * x₀)) ^ 2 - 64 * W.veluGx x₀ y₀ := by
+  have hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0 := by
+    simpa only [veluGy, neg_eq_zero] using hgy
+  simp only [velu2QuadDisc, b₂, b₄, veluGx]
+  linear_combination -32 * W.a₁ * hord
+
+end CommRing
+
+end WeierstrassCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_VeluPointMap.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_VeluPointMap.lean
new file mode 100644
index 0000000000..c051018fac
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_VeluPointMap.lean
@@ -0,0 +1,207 @@
+/-
+Based on Prove2Me node WeierstrassCurve_VeluPointMap
+(9adbe525-66e5-519e-9c37-3d600c11d1a1) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluQuotientMap
+
+/-!
+# Vélu point map for a singleton kernel
+
+Definition: `WeierstrassCurve_VeluPointMap` (`9adbe525-66e5-519e-9c37-3d600c11d1a1`), by Claude,
+2026-09-05.
+
+Throughout, $W$ is a Weierstrass curve over a commutative ring $R$, with the Vélu data of the
+imported modules: for a point $(x_0,y_0)$ one has $G_x = 3x_0^2 + 2a_2x_0 + a_4 - a_1y_0$, $G_y =
+-(2y_0 + a_1x_0 + a_3)$, $t = 2G_x - a_1G_y$, $u = G_y^2$, $w = u + x_0t$, and `veluQuotient
+{(x_0,y_0)}` is the curve with the same $a_1,a_2,a_3$ and with $a_4 - 5t$, $a_6 - b_2t - 7w$.
+
+Two polynomial numerators are defined: `veluXNum` $= x(x-x_0)^2 + t(x-x_0) + u$ and `veluYNum` $=
+y(x-x_0)^3 - \bigl(u(2y + a_1x + a_3) + t(a_1(x-x_0) + y - y_0)(x-x_0) + (a_1u -
+G_xG_y)(x-x_0)\bigr)$. Over a field, `veluY` is the corresponding $y$-coordinate map for a finite
+set $S$ of pairs: $y$ minus the sum over $Q \in S$ of $u_Q(2y+a_1x+a_3)/(x-Q_1)^3 +
+t_Q(a_1(x-Q_1)+y-Q_2)/(x-Q_1)^2 + (a_1u_Q - G_x(Q)G_y(Q))/(x-Q_1)^2$; it reduces to $y$ for $S =
+\emptyset$, and for a singleton it equals `veluYNum`$/(x-x_0)^3$ when $x \neq x_0$ (with the
+companion statement `veluX` $=$ `veluXNum`$/(x-x_0)^2$).
+
+The main identity `velu_singleton_equation_cleared` is the denominator-cleared form of the assertion
+that the pair lies on the quotient curve: if $(x,y)$ and $(x_0,y_0)$ satisfy the affine Weierstrass
+equation of $W$ and $x_0$ is a root of the division polynomial $\Psi_3$ of $W$, then with $X =$
+`veluXNum`, $Y =$ `veluYNum`,
+$$Y^2 + a_1XY(x-x_0) + a_3Y(x-x_0)^3 = X^3 + a_2X^2(x-x_0)^2 + (a_4-5t)X(x-x_0)^4 +
+(a_6-b_2t-7w)(x-x_0)^6,$$
+proved in coordinates centred at $(x_0,y_0)$. Writing $a=a_1$, $b=-G_y$, $c=a_2+3x_0$,
+$g=G_x$, $d=x-x_0$, $e=y-y_0$, the source equation becomes
+$e^2+ade+be=d^3+cd^2+gd$ and the three-division relation becomes $cb^2-abg-g^2=0$.
+The target residual is a combination of these two relations with factored multipliers.
+Over a field, `velu_singleton_map_equation` divides this
+by $(x-x_0)^6$: under the same hypotheses and $x \neq x_0$, the point
+$(\mathrm{veluX}\,\{(x_0,y_0)\}\,x,\ \mathrm{veluY}\,\{(x_0,y_0)\}\,x\,y)$ satisfies the affine
+equation of `veluQuotient` $\{(x_0,y_0)\}$.
+
+**Relation to Mathlib.** Mathlib supplies `WeierstrassCurve`, the affine equation `Affine.Equation`
+and the division polynomial $\Psi_3$; the Vélu quotient curve, the coordinate maps and their
+numerators are the project's own.
+
+**Where it is used.** These formulas make the Vélu quotient of a Weierstrass curve by a kernel with
+a single non-trivial $x$-coordinate explicit at the level of points, the hypothesis $\Psi_3(x_0)=0$
+selecting a kernel of order three; they are the point-map layer on which the project's explicit
+isogeny constructions build.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open Polynomial
+
+local macro "eval_simp" : tactic =>
+  `(tactic| simp only [eval_C, eval_X, eval_neg, eval_add, eval_sub, eval_mul, eval_pow,
+    eval_ofNat, evalEval])
+
+namespace WeierstrassCurve
+
+section CommRing
+
+variable {R : Type*} [CommRing R] (W : WeierstrassCurve R)
+
+private lemma eval_Ψ₃_eq (x : R) :
+    (W.Ψ₃).eval x = 3 * x ^ 4 + W.b₂ * x ^ 3 + 3 * W.b₄ * x ^ 2 + 3 * W.b₆ * x + W.b₈ := by
+  rw [Ψ₃]; eval_simp
+
+def veluXNum (x₀ y₀ x : R) : R :=
+  x * (x - x₀) ^ 2 + W.veluT x₀ y₀ * (x - x₀) + W.veluU x₀ y₀
+
+def veluYNum (x₀ y₀ x y : R) : R :=
+  y * (x - x₀) ^ 3 - (W.veluU x₀ y₀ * (2 * y + W.a₁ * x + W.a₃)
+    + W.veluT x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) * (x - x₀)
+    + (W.a₁ * W.veluU x₀ y₀ - W.veluGx x₀ y₀ * W.veluGy x₀ y₀) * (x - x₀))
+
+/-- Keep the curve equation and three-division relation in translated coordinates. -/
+private lemma velu_singleton_shifted_certificate (a b c g t u d e X Y : R)
+    (ht : t = 2 * g + a * b) (hu : u = b ^ 2)
+    (hX : X = d ^ 3 + t * d + u)
+    (hY : Y = e * (d ^ 3 - t * d - 2 * u) - a * t * d ^ 2
+      - (2 * a * u + g * b) * d - b * u)
+    (hcurve : e ^ 2 + a * d * e + b * e - d ^ 3 - c * d ^ 2 - g * d = 0)
+    (hΨ : c * b ^ 2 - a * b * g - g ^ 2 = 0) :
+    Y ^ 2 + a * X * Y * d + b * Y * d ^ 3 - X ^ 3 - c * X ^ 2 * d ^ 2
+      - (g - 5 * t) * X * d ^ 4 + ((a ^ 2 + 4 * c) * t + 7 * u) * d ^ 6 = 0 := by
+  rw [hY, hX, ht, hu]
+  linear_combination
+    (d ^ 3 - (2 * g + a * b) * d - 2 * b ^ 2) ^ 2 * hcurve
+      + d ^ 2 * (3 * b ^ 2 + 2 * (2 * g + a * b) * d - 6 * d ^ 3) * hΨ
+
+/-- Translate the target equation while keeping its numerator coordinates abstract. -/
+private lemma velu_singleton_equation_translate {x₀ y₀ : R}
+    (hQ : W.toAffine.Equation x₀ y₀) (d X Y : R) :
+    (Y ^ 2 + W.a₁ * X * Y * d + W.a₃ * Y * d ^ 3)
+        - (X ^ 3 + W.a₂ * X ^ 2 * d ^ 2
+          + (W.a₄ - 5 * W.veluT x₀ y₀) * X * d ^ 4
+          + (W.a₆ - W.b₂ * W.veluT x₀ y₀ - 7 * W.veluW x₀ y₀) * d ^ 6) =
+      (Y - y₀ * d ^ 3) ^ 2
+        + W.a₁ * (X - x₀ * d ^ 2) * (Y - y₀ * d ^ 3) * d
+        + (-W.veluGy x₀ y₀) * (Y - y₀ * d ^ 3) * d ^ 3
+        - (X - x₀ * d ^ 2) ^ 3 - (W.a₂ + 3 * x₀) * (X - x₀ * d ^ 2) ^ 2 * d ^ 2
+        - (W.veluGx x₀ y₀ - 5 * W.veluT x₀ y₀) * (X - x₀ * d ^ 2) * d ^ 4
+        + ((W.a₁ ^ 2 + 4 * (W.a₂ + 3 * x₀)) * W.veluT x₀ y₀
+          + 7 * W.veluU x₀ y₀) * d ^ 6 := by
+  rw [Affine.equation_iff] at hQ
+  simp only [veluGx, veluGy, veluW, b₂]
+  linear_combination d ^ 6 * hQ
+
+theorem velu_singleton_equation_cleared {x₀ y₀ x y : R}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hΨ : (W.Ψ₃).eval x₀ = 0) :
+    W.veluYNum x₀ y₀ x y ^ 2 + W.a₁ * W.veluXNum x₀ y₀ x * W.veluYNum x₀ y₀ x y * (x - x₀)
+        + W.a₃ * W.veluYNum x₀ y₀ x y * (x - x₀) ^ 3
+      = W.veluXNum x₀ y₀ x ^ 3 + W.a₂ * W.veluXNum x₀ y₀ x ^ 2 * (x - x₀) ^ 2
+        + (W.a₄ - 5 * W.veluT x₀ y₀) * W.veluXNum x₀ y₀ x * (x - x₀) ^ 4
+        + (W.a₆ - W.b₂ * W.veluT x₀ y₀ - 7 * W.veluW x₀ y₀) * (x - x₀) ^ 6 := by
+  have hcurve :
+      (y - y₀) ^ 2 + W.a₁ * (x - x₀) * (y - y₀) + (-W.veluGy x₀ y₀) * (y - y₀)
+        - (x - x₀) ^ 3 - (W.a₂ + 3 * x₀) * (x - x₀) ^ 2
+        - W.veluGx x₀ y₀ * (x - x₀) = 0 := by
+    rw [Affine.equation_iff] at hP hQ
+    simp only [veluGx, veluGy]
+    linear_combination hP - hQ
+  have hdivision :
+      (W.a₂ + 3 * x₀) * (-W.veluGy x₀ y₀) ^ 2
+        - W.a₁ * (-W.veluGy x₀ y₀) * W.veluGx x₀ y₀ - W.veluGx x₀ y₀ ^ 2 = 0 := by
+    rw [Affine.equation_iff] at hQ
+    rw [W.eval_Ψ₃_eq] at hΨ
+    simp only [b₂, b₄, b₆, b₈] at hΨ
+    simp only [veluGx, veluGy]
+    linear_combination hΨ + (W.a₁ ^ 2 + 4 * (W.a₂ + 3 * x₀)) * hQ
+  have ht : W.veluT x₀ y₀ = 2 * W.veluGx x₀ y₀ + W.a₁ * (-W.veluGy x₀ y₀) := by
+    simp only [veluT]
+    ring
+  have hu : W.veluU x₀ y₀ = (-W.veluGy x₀ y₀) ^ 2 := by
+    simp only [veluU, neg_sq]
+  have hX : W.veluXNum x₀ y₀ x - x₀ * (x - x₀) ^ 2 =
+      (x - x₀) ^ 3 + W.veluT x₀ y₀ * (x - x₀) + W.veluU x₀ y₀ := by
+    simp only [veluXNum]
+    ring
+  have hY : W.veluYNum x₀ y₀ x y - y₀ * (x - x₀) ^ 3 =
+      (y - y₀) * ((x - x₀) ^ 3 - W.veluT x₀ y₀ * (x - x₀) - 2 * W.veluU x₀ y₀)
+        - W.a₁ * W.veluT x₀ y₀ * (x - x₀) ^ 2
+        - (2 * W.a₁ * W.veluU x₀ y₀ + W.veluGx x₀ y₀ * (-W.veluGy x₀ y₀)) * (x - x₀)
+        - (-W.veluGy x₀ y₀) * W.veluU x₀ y₀ := by
+    simp only [veluYNum, veluGy]
+    ring
+  apply sub_eq_zero.mp
+  rw [velu_singleton_equation_translate W hQ]
+  exact velu_singleton_shifted_certificate W.a₁ (-W.veluGy x₀ y₀) (W.a₂ + 3 * x₀)
+    (W.veluGx x₀ y₀) (W.veluT x₀ y₀) (W.veluU x₀ y₀) (x - x₀) (y - y₀)
+    (W.veluXNum x₀ y₀ x - x₀ * (x - x₀) ^ 2)
+    (W.veluYNum x₀ y₀ x y - y₀ * (x - x₀) ^ 3) ht hu hX hY hcurve hdivision
+
+end CommRing
+
+section Field
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+noncomputable def veluY (S : Finset (F × F)) (x y : F) : F :=
+  y - ∑ Q ∈ S, (W.veluU Q.1 Q.2 * (2 * y + W.a₁ * x + W.a₃) / (x - Q.1) ^ 3
+    + W.veluT Q.1 Q.2 * (W.a₁ * (x - Q.1) + y - Q.2) / (x - Q.1) ^ 2
+    + (W.a₁ * W.veluU Q.1 Q.2 - W.veluGx Q.1 Q.2 * W.veluGy Q.1 Q.2) / (x - Q.1) ^ 2)
+
+@[simp] lemma veluY_empty (x y : F) : W.veluY ∅ x y = y := by simp [veluY]
+
+lemma veluX_singleton (x₀ y₀ : F) {x : F} (hx : x ≠ x₀) :
+    W.veluX {(x₀, y₀)} x = W.veluXNum x₀ y₀ x / (x - x₀) ^ 2 := by
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  simp only [veluX, Finset.sum_singleton, veluXNum]
+  field_simp
+  ring
+
+lemma veluY_singleton (x₀ y₀ : F) {x : F} (y : F) (hx : x ≠ x₀) :
+    W.veluY {(x₀, y₀)} x y = W.veluYNum x₀ y₀ x y / (x - x₀) ^ 3 := by
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  simp only [veluY, Finset.sum_singleton, veluYNum]
+  field_simp
+
+theorem velu_singleton_map_equation {x₀ y₀ x y : F}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hΨ : (W.Ψ₃).eval x₀ = 0) (hx : x ≠ x₀) :
+    (W.veluQuotient {(x₀, y₀)}).toAffine.Equation
+      (W.veluX {(x₀, y₀)} x) (W.veluY {(x₀, y₀)} x y) := by
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  have key := W.velu_singleton_equation_cleared hP hQ hΨ
+  rw [Affine.equation_iff, W.veluX_singleton x₀ y₀ hx, W.veluY_singleton x₀ y₀ y hx]
+  simp only [veluQuotient_a₁, veluQuotient_a₂, veluQuotient_a₃, veluQuotient_a₄,
+    veluQuotient_a₆, veluTSum, veluWSum, Finset.sum_singleton]
+  field_simp
+  linear_combination key
+
+end Field
+
+end WeierstrassCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_VeluPointMap2.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_VeluPointMap2.lean
new file mode 100644
index 0000000000..01dd840ac5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_VeluPointMap2.lean
@@ -0,0 +1,213 @@
+/-
+Based on Prove2Me node WeierstrassCurve_VeluPointMap2
+(1a793c0a-1dbf-54c6-a5d7-cecd4a9f07dd) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.SimpleRing.Principal
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluOrderTwo
+
+/-!
+# Vélu coordinate maps for a point of order two
+
+Definition: `WeierstrassCurve_VeluPointMap2` (`1a793c0a-1dbf-54c6-a5d7-cecd4a9f07dd`), by Claude,
+2026-09-05.
+
+Fix a Weierstrass curve $W$ over a commutative ring $R$ and a pair $(x_0,y_0)$, and write $g_x =
+3x_0^2 + 2a_2x_0 + a_4 - a_1y_0$ and $g_y = -(2y_0 + a_1x_0 + a_3)$ for the quantities `veluGx`,
+`veluGy`. Over $R$ the module defines the two numerator polynomials
+$$\mathtt{velu2XNum}(x) = x(x-x_0)^2 + g_x(x-x_0),\qquad \mathtt{velu2YNum}(x,y) = y(x-x_0)^3 -
+g_x\bigl(a_1(x-x_0)+y-y_0\bigr)(x-x_0),$$
+the first being visibly $(x-x_0)\bigl(x(x-x_0)+g_x\bigr)$. The identity
+`velu2_equation_cleared_four` asserts that, for $(x,y)$ and $(x_0,y_0)$ both satisfying the affine
+Weierstrass equation of $W$ and subject to $g_y = 0$, four times the homogenised left-hand side of
+the Weierstrass equation of the curve `veluQuotient2` evaluated at these numerators, with the powers
+$(x-x_0)^k$ supplying the denominators, equals four times the corresponding right-hand side; it is
+proved in coordinates centred at the kernel point, using a factored polynomial identity.
+Here `veluQuotient2` is the Weierstrass curve with the same $a_1,a_2,a_3$ and with
+$a_4 - 5g_x$, $a_6 - b_2g_x - 7x_0g_x$, the Vélu recipe with $t = g_x$, $w = x_0g_x$
+appropriate to a point of order two. The proof establishes the identity without the factor
+of four before multiplying both sides, so it requires no cancellation or characteristic assumption.
+
+Over a field $F$ the rational maps $\mathtt{velu2X} = x + g_x/(x-x_0)$ and $\mathtt{velu2Y} = y -
+g_x(a_1(x-x_0)+y-y_0)/(x-x_0)^2$ are defined, and identified for $x \neq x_0$ with the above
+numerators divided by $(x-x_0)^2$ and $(x-x_0)^3$. Assuming $2 \neq 0$ in $F$, `velu2_map_equation`
+states that these values satisfy the affine equation of `veluQuotient2` whenever $(x,y)$,
+$(x_0,y_0)$ lie on $W$, $g_y(x_0,y_0) = 0$ and $x \neq x_0$; adding the hypothesis that the
+discriminant of `veluQuotient2` is nonzero gives nonsingularity of the image point. Finally
+`veluPointMap2`, taking the hypotheses $2 \neq 0$, $(x_0,y_0)$ on $W$, $g_y(x_0,y_0) = 0$ and
+$\Delta \neq 0$ as arguments, is the function on affine points sending $0$ to $0$, sending any point
+with $x$-coordinate $x_0$ to $0$, and otherwise to the point with the Vélu coordinates; three lemmas
+record these three cases. No additivity is asserted at this stage.
+
+**Relation to Mathlib.** Mathlib supplies the Weierstrass curve data, the affine equation and
+nonsingularity predicates, the discriminant and the type of affine points; the Vélu formulas, the
+quotient curve `veluQuotient2` and the point map are the project's own additions.
+
+**Where it is used.** The construction gives the quotient of a Weierstrass curve by a rational point
+of order two in explicit coordinates, together with the induced map on affine points, for use where
+2-isogenies of elliptic curves (kernels, surjectivity, the dual isogeny) are needed.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace WeierstrassCurve
+
+section CommRing
+
+variable {R : Type*} [CommRing R] (W : WeierstrassCurve R) (x₀ y₀ : R)
+
+def velu2XNum (x : R) : R :=
+  x * (x - x₀) ^ 2 + W.veluGx x₀ y₀ * (x - x₀)
+
+def velu2YNum (x y : R) : R :=
+  y * (x - x₀) ^ 3 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) * (x - x₀)
+
+lemma velu2XNum_eq_mul (x : R) :
+    W.velu2XNum x₀ y₀ x = (x - x₀) * (x * (x - x₀) + W.veluGx x₀ y₀) := by
+  simp only [velu2XNum]; ring
+
+/-- In coordinates centred at the kernel point, the residual has a small factorisation. -/
+private lemma velu2_shifted_certificate (a c t d e : R)
+    (hcurve : e ^ 2 + a * d * e - d ^ 3 - c * d ^ 2 - t * d = 0) :
+    (d * (e * (d ^ 2 - t) - a * t * d)) ^ 2
+        + a * (d * (d ^ 2 + t)) * (d * (e * (d ^ 2 - t) - a * t * d)) * d
+        - (d * (d ^ 2 + t)) ^ 3 - c * (d * (d ^ 2 + t)) ^ 2 * d ^ 2
+        + 4 * t * (d * (d ^ 2 + t)) * d ^ 4 + (a ^ 2 + 4 * c) * t * d ^ 6 = 0 := by
+  linear_combination d ^ 2 * (d ^ 2 - t) ^ 2 * hcurve
+
+/-- Translate the homogeneous target equation without expanding its numerator coordinates. -/
+private lemma velu2_equation_translate
+    (hQ : W.toAffine.Equation x₀ y₀) (hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0)
+    (d X Y : R) :
+    (Y ^ 2 + W.a₁ * X * Y * d + W.a₃ * Y * d ^ 3)
+        - (X ^ 3 + W.a₂ * X ^ 2 * d ^ 2
+          + (W.a₄ - 5 * W.veluGx x₀ y₀) * X * d ^ 4
+          + (W.a₆ - W.b₂ * W.veluGx x₀ y₀ - 7 * (x₀ * W.veluGx x₀ y₀)) * d ^ 6) =
+      (Y - y₀ * d ^ 3) ^ 2
+        + W.a₁ * (X - x₀ * d ^ 2) * (Y - y₀ * d ^ 3) * d
+        - (X - x₀ * d ^ 2) ^ 3 - (W.a₂ + 3 * x₀) * (X - x₀ * d ^ 2) ^ 2 * d ^ 2
+        + 4 * W.veluGx x₀ y₀ * (X - x₀ * d ^ 2) * d ^ 4
+        + (W.a₁ ^ 2 + 4 * (W.a₂ + 3 * x₀)) * W.veluGx x₀ y₀ * d ^ 6 := by
+  rw [Affine.equation_iff] at hQ
+  simp only [veluGx, b₂]
+  linear_combination d ^ 6 * hQ + (Y - y₀ * d ^ 3) * d ^ 3 * hord
+
+theorem velu2_equation_cleared_four {x₀ y₀ x y : R}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) :
+    4 * (W.velu2YNum x₀ y₀ x y ^ 2
+        + W.a₁ * W.velu2XNum x₀ y₀ x * W.velu2YNum x₀ y₀ x y * (x - x₀)
+        + W.a₃ * W.velu2YNum x₀ y₀ x y * (x - x₀) ^ 3)
+      = 4 * (W.velu2XNum x₀ y₀ x ^ 3 + W.a₂ * W.velu2XNum x₀ y₀ x ^ 2 * (x - x₀) ^ 2
+        + (W.a₄ - 5 * W.veluGx x₀ y₀) * W.velu2XNum x₀ y₀ x * (x - x₀) ^ 4
+        + (W.a₆ - W.b₂ * W.veluGx x₀ y₀ - 7 * (x₀ * W.veluGx x₀ y₀)) * (x - x₀) ^ 6) := by
+  have hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0 := by
+    simpa only [veluGy, neg_eq_zero] using hgy
+  have hcurve :
+      (y - y₀) ^ 2 + W.a₁ * (x - x₀) * (y - y₀)
+        - (x - x₀) ^ 3 - (W.a₂ + 3 * x₀) * (x - x₀) ^ 2
+        - W.veluGx x₀ y₀ * (x - x₀) = 0 := by
+    rw [Affine.equation_iff] at hP hQ
+    simp only [veluGx]
+    linear_combination hP - hQ - (y - y₀) * hord
+  have hX : W.velu2XNum x₀ y₀ x - x₀ * (x - x₀) ^ 2 =
+      (x - x₀) * ((x - x₀) ^ 2 + W.veluGx x₀ y₀) := by
+    simp only [velu2XNum]
+    ring
+  have hY : W.velu2YNum x₀ y₀ x y - y₀ * (x - x₀) ^ 3 =
+      (x - x₀) * ((y - y₀) * ((x - x₀) ^ 2 - W.veluGx x₀ y₀)
+        - W.a₁ * W.veluGx x₀ y₀ * (x - x₀)) := by
+    simp only [velu2YNum]
+    ring
+  apply congrArg (4 * ·)
+  apply sub_eq_zero.mp
+  rw [velu2_equation_translate W x₀ y₀ hQ hord, hX, hY]
+  exact velu2_shifted_certificate W.a₁ (W.a₂ + 3 * x₀) (W.veluGx x₀ y₀)
+    (x - x₀) (y - y₀) hcurve
+
+end CommRing
+
+section Field
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+noncomputable def velu2X (x₀ y₀ x : F) : F :=
+  x + W.veluGx x₀ y₀ / (x - x₀)
+
+noncomputable def velu2Y (x₀ y₀ x y : F) : F :=
+  y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2
+
+lemma velu2X_eq_div (x₀ y₀ : F) {x : F} (hx : x ≠ x₀) :
+    W.velu2X x₀ y₀ x = W.velu2XNum x₀ y₀ x / (x - x₀) ^ 2 := by
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  simp only [velu2X, velu2XNum]
+  field_simp
+
+lemma velu2Y_eq_div (x₀ y₀ : F) {x : F} (y : F) (hx : x ≠ x₀) :
+    W.velu2Y x₀ y₀ x y = W.velu2YNum x₀ y₀ x y / (x - x₀) ^ 3 := by
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  simp only [velu2Y, velu2YNum]
+  field_simp
+
+theorem velu2_map_equation (hchar : (2 : F) ≠ 0) {x₀ y₀ x y : F}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hx : x ≠ x₀) :
+    (W.veluQuotient2 x₀ y₀).toAffine.Equation
+      (W.velu2X x₀ y₀ x) (W.velu2Y x₀ y₀ x y) := by
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  have h4 : (4 : F) ≠ 0 := fun hcon =>
+    hchar (mul_self_eq_zero.mp (by rw [show ((2 : F) * 2) = 4 from by norm_num, hcon]))
+  have key := mul_left_cancel₀ h4 (W.velu2_equation_cleared_four hP hQ hgy)
+  rw [Affine.equation_iff, W.velu2X_eq_div x₀ y₀ hx, W.velu2Y_eq_div x₀ y₀ y hx]
+  simp only [veluQuotient2_a₁, veluQuotient2_a₂, veluQuotient2_a₃, veluQuotient2_a₄,
+    veluQuotient2_a₆]
+  field_simp
+  linear_combination key
+
+variable {W} in
+theorem velu2_map_nonsingular (hchar : (2 : F) ≠ 0) {x₀ y₀ x y : F}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hx : x ≠ x₀) (hΔ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0) :
+    (W.veluQuotient2 x₀ y₀).toAffine.Nonsingular
+      (W.velu2X x₀ y₀ x) (W.velu2Y x₀ y₀ x y) :=
+  ((W.veluQuotient2 x₀ y₀).toAffine.equation_iff_nonsingular_of_Δ_ne_zero hΔ).mp
+    (W.velu2_map_equation hchar hP hQ hgy hx)
+
+variable {W}
+variable (hchar : (2 : F) ≠ 0) {x₀ y₀ : F} (hQ : W.toAffine.Equation x₀ y₀)
+  (hgy : W.veluGy x₀ y₀ = 0) (hΔ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0)
+
+open scoped Classical in
+noncomputable def veluPointMap2 :
+    W.toAffine.Point → (W.veluQuotient2 x₀ y₀).toAffine.Point
+  | .zero => .zero
+  | .some x _ h =>
+    if hx : x = x₀ then .zero
+    else .some _ _ (velu2_map_nonsingular hchar h.1 hQ hgy hx hΔ)
+
+@[simp] lemma veluPointMap2_zero : veluPointMap2 hchar hQ hgy hΔ .zero = .zero := rfl
+
+lemma veluPointMap2_some_of_eq {x y : F} (h : W.toAffine.Nonsingular x y) (hx : x = x₀) :
+    veluPointMap2 hchar hQ hgy hΔ (.some x y h) = .zero := by
+  simp only [veluPointMap2]
+  exact dite_eq_left hx
+
+lemma veluPointMap2_some_of_ne {x y : F} (h : W.toAffine.Nonsingular x y) (hx : x ≠ x₀) :
+    veluPointMap2 hchar hQ hgy hΔ (.some x y h)
+      = .some _ _ (velu2_map_nonsingular hchar h.1 hQ hgy hx hΔ) := by
+  simp only [veluPointMap2]
+  exact dite_eq_right hx
+
+end Field
+
+end WeierstrassCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_VeluQuotientMap.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_VeluQuotientMap.lean
new file mode 100644
index 0000000000..ac749703c4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_VeluQuotientMap.lean
@@ -0,0 +1,126 @@
+/-
+Based on Prove2Me node WeierstrassCurve_VeluQuotientMap
+(b645f572-4856-5e39-8df6-06a7fb7601ce) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_Velu
+
+/-!
+# Odd Vélu summing sets, Vélu's x-map, quotient discriminant
+
+Definition: `WeierstrassCurve_VeluQuotientMap` (`b645f572-4856-5e39-8df6-06a7fb7601ce`), by Claude,
+2026-09-05.
+
+The standing setting is a Weierstrass curve $W$ over a commutative ring $R$, with the auxiliary
+quantities $g_x(x,y)=3x^2+2a_2x+a_4-a_1y$, $g_y(x,y)=-(2y+a_1x+a_3)$, $t(x,y)=2g_x-a_1g_y$
+(equivalently $6x^2+b_2x+b_4$), $u(x,y)=g_y^2$ and $w(x,y)=u+xt$, and with $T(S)=\sum_{P\in S}t(P)$,
+$W(S)=\sum_{P\in S}w(P)$ for a finite set $S$ of pairs; the Vélu quotient curve `veluQuotient` has
+the same $a_1,a_2,a_3$ and $a_4-5T(S)$, $a_6-b_2T(S)-7W(S)$.
+
+The structure `IsOddVeluSet` is a predicate on a finite set $S\subseteq R\times R$ with three
+fields: every $P\in S$ satisfies the affine Weierstrass equation of $W$; $g_y(P)\neq 0$ for every
+$P\in S$ (so no point of $S$ is fixed by $y\mapsto -y-a_1x-a_3$); and the first-coordinate map is
+injective on $S$, in the form that $P,P'\in S$ with equal $x$-coordinates are equal. It implies the
+weaker predicate `IsVeluSet`, which asks only for the equation; the empty set and, given a point
+satisfying the equation with $g_y\neq0$, the singleton containing it are examples. A further lemma
+records that replacing $y$ by $\mathrm{negY}(x,y)$ in a singleton leaves the quotient curve
+unchanged, since $t$ and $w$ are invariant under that involution.
+
+Over a field $F$, `veluX` is the rational function $x\mapsto x+\sum_{Q\in
+S}\bigl(t(Q)/(x-x_Q)+u(Q)/(x-x_Q)^2\bigr)$, taken with Lean's convention that division by zero
+vanishes; it reduces to the identity for $S=\varnothing$, and for $x$ distinct from all $x_Q$ it
+equals $x+\sum_Q\bigl(t(Q)(x-x_Q)+u(Q)\bigr)/(x-x_Q)^2$. Finally, `veluQuotient_Δ` expresses the
+discriminant of the quotient curve as $\Delta(W)$ plus an explicit twelve-term polynomial in
+$b_2,b_4,b_6$, $T(S)$ and $W(S)$.
+
+**Relation to Mathlib.** Mathlib supplies the `WeierstrassCurve` structure, its $b$- and
+$\Delta$-invariants, the affine equation, `Affine.negY` and the division polynomial $\Psi_2^2$; the
+Vélu data ($g_x$, $g_y$, $t$, $u$, $w$, their sums, the quotient curve, and the summing-set
+predicates) are the project's own, Mathlib having no Vélu construction.
+
+**Where it is used.** These definitions belong to the project's treatment of isogenies by Vélu's
+formulas: `IsOddVeluSet` isolates the summing sets arising from kernels with no $2$-torsion, `veluX`
+is the $x$-coordinate of the induced map to the quotient curve, and the discriminant formula
+controls how $\Delta$ changes under the quotient. They are imported throughout the isogeny
+development built on top of this module.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+open Polynomial
+
+namespace WeierstrassCurve
+
+variable {R : Type*} [CommRing R] (W : WeierstrassCurve R)
+
+structure IsOddVeluSet (S : Finset (R × R)) : Prop where
+  equation : ∀ P ∈ S, W.toAffine.Equation P.1 P.2
+  gy_ne_zero : ∀ P ∈ S, W.veluGy P.1 P.2 ≠ 0
+  x_injOn : ∀ P ∈ S, ∀ P' ∈ S, P.1 = P'.1 → P = P'
+
+lemma IsOddVeluSet.isVeluSet {S : Finset (R × R)} (h : W.IsOddVeluSet S) : W.IsVeluSet S :=
+  ⟨h.equation⟩
+
+lemma isOddVeluSet_empty : W.IsOddVeluSet ∅ where
+  equation := by simp
+  gy_ne_zero := by simp
+  x_injOn := by simp
+
+lemma isOddVeluSet_singleton {x y : R} (h : W.toAffine.Equation x y)
+    (h2 : W.veluGy x y ≠ 0) : W.IsOddVeluSet {(x, y)} where
+  equation := by simpa using h
+  gy_ne_zero := by simpa using h2
+  x_injOn := by simp
+
+lemma veluQuotient_singleton_negY (x y : R) :
+    W.veluQuotient {(x, W.toAffine.negY x y)} = W.veluQuotient {(x, y)} := by
+  have ht : W.veluTSum {(x, W.toAffine.negY x y)} = W.veluTSum {(x, y)} := by
+    simp only [veluTSum, Finset.sum_singleton]
+    exact W.veluT_negY x y
+  have hw : W.veluWSum {(x, W.toAffine.negY x y)} = W.veluWSum {(x, y)} := by
+    simp only [veluWSum, Finset.sum_singleton]
+    exact W.veluW_negY x y
+  ext <;> simp only [veluQuotient_a₁, veluQuotient_a₂, veluQuotient_a₃, veluQuotient_a₄,
+    veluQuotient_a₆, ht, hw]
+
+section QuotientMap
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+noncomputable def veluX (S : Finset (F × F)) (x : F) : F :=
+  x + ∑ Q ∈ S, (W.veluT Q.1 Q.2 / (x - Q.1) + W.veluU Q.1 Q.2 / (x - Q.1) ^ 2)
+
+@[simp] lemma veluX_empty (x : F) : W.veluX ∅ x = x := by simp [veluX]
+
+lemma veluX_def_of_ne (S : Finset (F × F)) {x : F} (hx : ∀ Q ∈ S, x ≠ Q.1) :
+    W.veluX S x = x + ∑ Q ∈ S, (W.veluT Q.1 Q.2 * (x - Q.1) + W.veluU Q.1 Q.2)
+      / (x - Q.1) ^ 2 := by
+  unfold veluX
+  congr 1
+  refine Finset.sum_congr rfl fun Q hQ => ?_
+  have h0 : x - Q.1 ≠ 0 := sub_ne_zero.mpr (hx Q hQ)
+  field_simp
+
+end QuotientMap
+
+lemma veluQuotient_Δ (S : Finset (R × R)) :
+    (W.veluQuotient S).Δ = W.Δ +
+      (W.b₂ ^ 4 * W.veluTSum S + 7 * W.b₂ ^ 3 * W.veluWSum S
+        - 41 * W.b₂ ^ 2 * W.b₄ * W.veluTSum S - 47 * W.b₂ ^ 2 * W.veluTSum S ^ 2
+        - 252 * W.b₂ * W.b₄ * W.veluWSum S + 126 * W.b₂ * W.b₆ * W.veluTSum S
+        - 3528 * W.b₂ * W.veluTSum S * W.veluWSum S + 240 * W.b₄ ^ 2 * W.veluTSum S
+        - 2400 * W.b₄ * W.veluTSum S ^ 2 + 1512 * W.b₆ * W.veluWSum S
+        + 8000 * W.veluTSum S ^ 3 - 21168 * W.veluWSum S ^ 2) := by
+  simp only [Δ, veluQuotient_b₂, veluQuotient_b₄, veluQuotient_b₆, veluQuotient_b₈]
+  ring
+
+end WeierstrassCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_VeluQuotientOfSums.lean b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_VeluQuotientOfSums.lean
new file mode 100644
index 0000000000..9379883b7d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Def_WeierstrassCurve_VeluQuotientOfSums.lean
@@ -0,0 +1,84 @@
+/-
+Based on Prove2Me node WeierstrassCurve_VeluQuotientOfSums
+(a6a56964-a930-57a1-8a54-54ec73c35fbc) by Claude (2026-09-05).
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_Velu
+
+/-!
+# Vélu quotient curve with free total parameters
+
+Definition: `WeierstrassCurve_VeluQuotientOfSums` (`a6a56964-a930-57a1-8a54-54ec73c35fbc`), by
+Claude, 2026-09-05.
+
+Over a commutative ring $R$ and for a Weierstrass curve $W$ with coefficients $a_1,\dots,a_6$, this
+module introduces
+[`WeierstrassCurve.veluQuotientOfSums`](../def/WeierstrassCurve_VeluQuotientOfSums.html#L9): given
+two ring elements $t,w$, it is the Weierstrass curve with the same $a_1,a_2,a_3$ as $W$ and with
+$$a_4' = a_4 - 5t, \qquad a_6' = a_6 - b_2 t - 7w,$$
+where $b_2 = a_1^2 + 4a_2$ is Mathlib's invariant of $W$. This is the Vélu recipe for the
+coefficients of a quotient curve, but with the two totals $t$ and $w$ entering as free parameters
+instead of being computed from a kernel set. The five projection lemmas `veluQuotientOfSums_a₁`
+through `veluQuotientOfSums_a₆` record the five coefficients as just displayed.
+
+The remaining two statements link this with the `Finset`-indexed construction
+[`WeierstrassCurve.veluQuotient`](../def/WeierstrassCurve_Velu.html#L59) of the imported module,
+where for a finite set $S \subseteq R \times R$ of candidate points the totals are the sums $t =
+\sum_{(x,y) \in S} (6x^2 + b_2 x + b_4)$ (the function `veluT`, evaluated there as $2g_x - a_1 g_y$
+with $g_x = 3x^2 + 2a_2x + a_4 - a_1y$, $g_y = -(2y + a_1x + a_3)$) and $w = \sum_{(x,y) \in S}
+(g_y^2 + x \cdot \text{veluT}(x,y))$, these being `veluTSum S` and `veluWSum S`. The theorem
+`veluQuotient_eq_veluQuotientOfSums` states that `W.veluQuotient S` is `W.veluQuotientOfSums
+(W.veluTSum S) (W.veluWSum S)`, and `veluQuotient_eq_veluQuotientOfSums_of_sums` is its variant in
+which hypotheses $\text{veluTSum}(S) = t$ and $\text{veluWSum}(S) = w$ are supplied, concluding
+`W.veluQuotient S = W.veluQuotientOfSums t w`.
+
+**Relation to Mathlib.** Mathlib supplies the structure `WeierstrassCurve` and the invariants $b_2,
+b_4, b_6, b_8$ used here; the Vélu quotient construction, in both its `Finset`-indexed and its
+two-parameter form, is the project's own.
+
+**Where it is used.** The two-parameter form is what is needed when the totals fed into the Vélu
+coefficient formulae are not the uniform sums over a single finite set of points, as happens for
+kernels containing a point of order two, and it is the form on which the variable-change behaviour
+of the Vélu quotient is stated. These constructions serve the explicit isogeny computations on the
+curves occurring in the Frey curve analysis.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+@[expose] public section publicSection
+
+namespace WeierstrassCurve
+
+variable {R : Type*} [CommRing R] (W : WeierstrassCurve R)
+
+def veluQuotientOfSums (t w : R) : WeierstrassCurve R where
+  a₁ := W.a₁
+  a₂ := W.a₂
+  a₃ := W.a₃
+  a₄ := W.a₄ - 5 * t
+  a₆ := W.a₆ - W.b₂ * t - 7 * w
+
+@[simp] lemma veluQuotientOfSums_a₁ (t w : R) : (W.veluQuotientOfSums t w).a₁ = W.a₁ := rfl
+@[simp] lemma veluQuotientOfSums_a₂ (t w : R) : (W.veluQuotientOfSums t w).a₂ = W.a₂ := rfl
+@[simp] lemma veluQuotientOfSums_a₃ (t w : R) : (W.veluQuotientOfSums t w).a₃ = W.a₃ := rfl
+lemma veluQuotientOfSums_a₄ (t w : R) : (W.veluQuotientOfSums t w).a₄ = W.a₄ - 5 * t := rfl
+lemma veluQuotientOfSums_a₆ (t w : R) :
+    (W.veluQuotientOfSums t w).a₆ = W.a₆ - W.b₂ * t - 7 * w := rfl
+
+theorem veluQuotient_eq_veluQuotientOfSums (S : Finset (R × R)) :
+    W.veluQuotient S = W.veluQuotientOfSums (W.veluTSum S) (W.veluWSum S) := rfl
+
+theorem veluQuotient_eq_veluQuotientOfSums_of_sums {S : Finset (R × R)} {t w : R}
+    (ht : W.veluTSum S = t) (hw : W.veluWSum S = w) :
+    W.veluQuotient S = W.veluQuotientOfSums t w := by
+  subst ht hw; rfl
+
+end WeierstrassCurve
+
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Defs_AlgebraicCurve_residueTheorem_sharedLibrary.lean b/LeanPool/FLTEichlerShimura/Definitions/Defs_AlgebraicCurve_residueTheorem_sharedLibrary.lean
new file mode 100644
index 0000000000..571b8167b3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Defs_AlgebraicCurve_residueTheorem_sharedLibrary.lean
@@ -0,0 +1,1571 @@
+/-
+Copyright (c) 2026 David Loeffler. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: David Loeffler
+
+Extracted from Prove2Me proofs by Claude (2026-09-05):
+* AlgebraicCurve.residueTheoremK_of_isAlgClosed
+  (0b4c7479-cbcc-5c87-9c16-80c7c5d57ccc), submission
+  72e99470-19e3-5ea5-be87-5fc25dbfd308.
+* AlgebraicCurve.residueTheoremK_ratFunc_of_isAlgClosed
+  (74e12376-4ca7-54f2-9fc3-7fcedc86b3f2), submission
+  7ccd254a-780d-5a1a-a743-8b3c63a9deae.
+-/
+
+module
+
+public import Mathlib.Algebra.BigOperators.Field
+public import Mathlib.Algebra.GroupWithZero.Submonoid.CancelMulZero
+public import Mathlib.Algebra.Polynomial.PartialFractions
+public import Mathlib.Analysis.Normed.Ring.Lemmas
+public import Mathlib.FieldTheory.Galois.Abelian
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import Mathlib.NumberTheory.RatFunc.Ostrowski
+public import Mathlib.RingTheory.AdicCompletion.Completeness
+public import Mathlib.RingTheory.Artinian.Instances
+public import Mathlib.RingTheory.Norm.Transitivity
+public import Mathlib.RingTheory.PicardGroup
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_CanonicalLocalResidueInstanceV2
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_LocalResidue
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_instIsCurveOverRatFunc
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ramificationIndex_eq_ramificationIdx_fiberCenter
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_placeInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty_X
+
+/-!
+# Shared library for the residue theorems
+
+Common rational-function, valuation and differential helpers for the rational-function-field
+residue theorem and its extension to general algebraic curves.
+-/
+
+open AlgebraicCurve RationalFunctionField IsDedekindDomain KaehlerDifferential Module Polynomial
+  WithZero
+
+section privateSection
+
+noncomputable section
+
+section
+
+namespace AlgebraicCurve
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+@[expose] public def OrdDifferentialWellDefined : Prop :=
+  ∀ (v : Place K F) (π π' : F), v.ord π = 1 → v.ord π' = 1 →
+    ∃ u : F, v.ord u = 0 ∧
+      KaehlerDifferential.D K F π' = u • KaehlerDifferential.D K F π
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+public theorem ord_add_eq_min {f g : F} (hf : f ≠ 0) (hg : g ≠ 0) (h :
+  v.ord f ≠ v.ord g) :
+    v.ord (f + g) = min (v.ord f) (v.ord g) := by
+  have hval : v.adicValuation f ≠ v.adicValuation g := by
+    intro hcon
+    exact h (by simp only [ord, hcon])
+  have h1 : v.adicValuation (f + g) = max (v.adicValuation f) (v.adicValuation g) :=
+    Valuation.map_add_of_distinct_val _ hval
+  have hfg : f + g ≠ 0 := by
+    intro hcon
+    rw [hcon, _root_.map_zero] at h1
+    rcases max_cases (v.adicValuation f) (v.adicValuation g) with ⟨hmax, -⟩ | ⟨hmax, -⟩ <;>
+      rw [hmax] at h1
+    · exact v.adicValuation_ne_zero hf h1.symm
+    · exact v.adicValuation_ne_zero hg h1.symm
+  rcases max_cases (v.adicValuation f) (v.adicValuation g) with ⟨hmax, hle⟩ | ⟨hmax, hlt⟩ <;>
+    rw [hmax] at h1
+  · have hlog := (WithZero.log_le_log (v.adicValuation_ne_zero hg)
+      (v.adicValuation_ne_zero hf)).mpr hle
+    have h2 : v.ord (f + g) = v.ord f := by simp only [ord, h1]
+    simp only [ord] at hlog h2 ⊢
+    omega
+  · have hlog := (WithZero.log_le_log (v.adicValuation_ne_zero hf)
+      (v.adicValuation_ne_zero hg)).mpr hlt.le
+    have h2 : v.ord (f + g) = v.ord g := by simp only [ord, h1]
+    simp only [ord] at hlog h2 ⊢
+    omega
+
+end Place
+end AlgebraicCurve
+
+end
+
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+namespace Place
+
+section Ultrametric
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+theorem ord_add_eq_left {f g : F} (hf : f ≠ 0) (hg : g ≠ 0)
+    (h : v.ord f < v.ord g) :
+    v.ord (f + g) = v.ord f := by
+  have hfv := v.adicValuation_ne_zero hf
+  have hgv := v.adicValuation_ne_zero hg
+  have hlt : v.adicValuation g < v.adicValuation f := by
+    rw [← exp_log hfv, ← exp_log hgv]
+    have hlog : log (v.adicValuation g) < log (v.adicValuation f) := by
+      simp only [ord] at h
+      omega
+    exact lt_of_le_of_ne (exp_le_exp.mpr hlog.le)
+      fun hcon => hlog.ne (exp_injective hcon)
+  have h1 : v.adicValuation (f + g) = max (v.adicValuation f) (v.adicValuation g) :=
+    Valuation.map_add_of_distinct_val _ (ne_of_lt hlt).symm
+  rw [max_eq_left hlt.le] at h1
+  simp only [ord, h1]
+
+end Ultrametric
+
+end Place
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+namespace RationalFunctionField
+
+variable (K : Type*) [Field K]
+
+section PlaceInfty
+
+variable [DecidableEq (RatFunc K)]
+
+theorem inftyValuation_isEquiv_adicValuation :
+    (RatFunc.inftyValuation K).IsEquiv (placeInfty K).adicValuation :=
+  (placeInfty K).isEquiv_adicValuation_of_valuationSubring_eq rfl
+
+end PlaceInfty
+
+variable {K}
+
+theorem subsingleton_setOf_forall_ne_ofHeightOneSpectrum :
+    {v : Place K (RatFunc K) |
+      ∀ w : HeightOneSpectrum K[X], v ≠ Place.ofHeightOneSpectrum w}.Subsingleton := by
+  classical
+  intro v hv v' hv'
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, h⟩ | h
+  · exact absurd h (hv w)
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v' with ⟨w, h'⟩ | h'
+  · exact absurd h' (hv' w)
+  rw [h, h']
+
+theorem finite_setOf_valuation_ne_one {f : RatFunc K} (hf : f ≠ 0) :
+    {w : HeightOneSpectrum K[X] | w.valuation (RatFunc K) f ≠ 1}.Finite := by
+  have hnum : (Ideal.span {f.num} : Ideal K[X]) ≠ 0 := by
+    simpa [Ideal.span_singleton_eq_bot] using RatFunc.num_ne_zero hf
+  have hden : (Ideal.span {f.denom} : Ideal K[X]) ≠ 0 := by
+    simpa [Ideal.span_singleton_eq_bot] using f.denom_ne_zero
+  refine Set.Finite.subset ((Ideal.finite_factors hnum).union (Ideal.finite_factors hden))
+    fun w hw => ?_
+  by_contra hcon
+  simp only [Set.mem_union, Set.mem_ofPred_eq, not_or, Ideal.dvd_span_singleton] at hcon
+  refine hw ?_
+  have h1 : w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) f.num) = 1 :=
+    (HeightOneSpectrum.valuation_eq_one_iff_notMem w).mpr hcon.1
+  have h2 : w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) f.denom) = 1 :=
+    (HeightOneSpectrum.valuation_eq_one_iff_notMem w).mpr hcon.2
+  rw [show f = algebraMap K[X] (RatFunc K) f.num / algebraMap K[X] (RatFunc K) f.denom from
+    f.num_div_denom.symm, map_div₀, h1, h2]
+  exact div_one 1
+
+theorem finite_setOf_ord_ne_zero {f : RatFunc K} (hf : f ≠ 0) :
+    {v : Place K (RatFunc K) | v.ord f ≠ 0}.Finite := by
+  refine Set.Finite.subset
+    (Set.Finite.union
+      (Set.Finite.image (Place.ofHeightOneSpectrum (K := K))
+        (finite_setOf_valuation_ne_one hf))
+      (Set.Subsingleton.finite subsingleton_setOf_forall_ne_ofHeightOneSpectrum))
+    fun v hv => ?_
+  simp only [Set.mem_ofPred_eq] at hv
+  simp only [Set.mem_union, Set.mem_image, Set.mem_ofPred_eq]
+  by_cases hcase : ∃ w : HeightOneSpectrum K[X], v = Place.ofHeightOneSpectrum w
+  · obtain ⟨w, rfl⟩ := hcase
+    refine Or.inl ⟨w, fun hone => hv ?_, rfl⟩
+    exact ((Place.ofHeightOneSpectrum (K := K) w).ord_eq_zero_iff_adicValuation_eq_one hf).mpr
+      ((Place.isEquiv_adicValuation_ofHeightOneSpectrum (K := K) (F := RatFunc K)
+        w).eq_one_iff_eq_one.mp hone)
+  · exact Or.inr fun w h => hcase ⟨w, h⟩
+
+section DegInfty
+
+variable (K) [DecidableEq (RatFunc K)]
+
+theorem exists_sub_algebraMap_intDegree_neg {x : RatFunc K}
+    (hx : RatFunc.inftyValuation K x ≤ 1) :
+    ∃ c : K, x - algebraMap K (RatFunc K) c = 0 ∨
+      (x - algebraMap K (RatFunc K) c).intDegree < 0 := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · exact ⟨0, Or.inl (by simp)⟩
+  have hdeg : x.intDegree ≤ 0 := by
+    rw [RatFunc.inftyValuation_apply, RatFunc.inftyValuation_of_nonzero K hx0,
+      show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_le_exp] at hx
+    exact hx
+  have hnum0 : x.num ≠ 0 := RatFunc.num_ne_zero hx0
+  have hden0 : x.denom ≠ 0 := x.denom_ne_zero
+  rcases lt_or_eq_of_le hdeg with hlt | heq
+  · exact ⟨0, Or.inr (by simpa using hlt)⟩
+  have hndeg : x.num.natDegree = x.denom.natDegree := by
+    have h2 := heq
+    rw [RatFunc.intDegree, sub_eq_zero] at h2
+    exact_mod_cast h2
+  set c : K := x.num.leadingCoeff / x.denom.leadingCoeff with hc
+  have hc0 : c ≠ 0 := by
+    rw [hc]
+    exact div_ne_zero (Polynomial.leadingCoeff_ne_zero.mpr hnum0)
+      (Polynomial.leadingCoeff_ne_zero.mpr hden0)
+  refine ⟨c, ?_⟩
+  have hsub : x - algebraMap K (RatFunc K) c
+      = algebraMap K[X] (RatFunc K) (x.num - Polynomial.C c * x.denom)
+        / algebraMap K[X] (RatFunc K) x.denom := by
+    rw [map_sub, map_mul, sub_div, x.num_div_denom, mul_div_assoc,
+      div_self ((map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hden0),
+      mul_one, IsScalarTower.algebraMap_apply K K[X] (RatFunc K), Polynomial.algebraMap_eq]
+  rcases eq_or_ne (x.num - Polynomial.C c * x.denom) 0 with hzero | hnz
+  · exact Or.inl (by rw [hsub, hzero, _root_.map_zero, zero_div])
+  refine Or.inr ?_
+  rw [hsub, RatFunc.intDegree_div ((map_ne_zero_iff _
+      (IsFractionRing.injective K[X] (RatFunc K))).mpr hnz)
+    ((map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hden0),
+    RatFunc.intDegree_polynomial, RatFunc.intDegree_polynomial, sub_neg]
+  have hCdeg : (Polynomial.C c * x.denom).degree = x.denom.degree := by
+    rw [Polynomial.degree_mul, Polynomial.degree_C hc0, zero_add]
+  have hdegeq : x.num.degree = (Polynomial.C c * x.denom).degree := by
+    rw [hCdeg, Polynomial.degree_eq_natDegree hnum0, Polynomial.degree_eq_natDegree hden0,
+      hndeg]
+  have hlc : x.num.leadingCoeff = (Polynomial.C c * x.denom).leadingCoeff := by
+    rw [Polynomial.leadingCoeff_mul, Polynomial.leadingCoeff_C, hc,
+      div_mul_cancel₀ _ (Polynomial.leadingCoeff_ne_zero.mpr hden0)]
+  have hlt := Polynomial.degree_sub_lt_left hdegeq hnum0 hlc
+  rw [hdegeq, hCdeg] at hlt
+  exact_mod_cast Polynomial.natDegree_lt_natDegree hnz hlt
+
+end DegInfty
+
+end RationalFunctionField
+end AlgebraicCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+namespace RationalFunctionField
+
+variable (K : Type*) [Field K]
+
+section PlaceInfty
+
+variable [DecidableEq (RatFunc K)]
+
+theorem ord_placeInfty_eq_zero_of_intDegree_eq_zero {f : RatFunc K} (hf : f ≠ 0)
+    (h : f.intDegree = 0) : (placeInfty K).ord f = 0 := by
+  rw [(placeInfty K).ord_eq_zero_iff_adicValuation_eq_one hf,
+    ← (inftyValuation_isEquiv_adicValuation K).eq_one_iff_eq_one,
+    RatFunc.inftyValuation_apply, RatFunc.inftyValuation_of_nonzero K hf, h]
+  rfl
+
+public theorem ord_placeInfty_eq_intDegree_mul {f : RatFunc K} (hf : f ≠ 0) :
+    (placeInfty K).ord f = f.intDegree * (placeInfty K).ord (RatFunc.X) := by
+  have hinj := IsFractionRing.injective K[X] (RatFunc K)
+  have hpoly : ∀ q : K[X], q ≠ 0 →
+      (placeInfty K).ord (algebraMap K[X] (RatFunc K) q)
+        = (q.natDegree : ℤ) * (placeInfty K).ord (RatFunc.X) := by
+    intro q hq
+    have hq' : algebraMap K[X] (RatFunc K) q ≠ 0 := (map_ne_zero_iff _ hinj).mpr hq
+    have hX : (RatFunc.X : RatFunc K) ≠ 0 := RatFunc.X_ne_zero
+    have hXpow : (RatFunc.X : RatFunc K) ^ q.natDegree ≠ 0 := pow_ne_zero _ hX
+    have hXpoly : (RatFunc.X : RatFunc K) ^ q.natDegree
+        = algebraMap K[X] (RatFunc K) (Polynomial.X ^ q.natDegree) := by
+      rw [map_pow, RatFunc.algebraMap_X]
+    have hdeg : (algebraMap K[X] (RatFunc K) q / RatFunc.X ^ q.natDegree).intDegree = 0 := by
+      rw [RatFunc.intDegree_div hq' hXpow, RatFunc.intDegree_polynomial, hXpoly,
+        RatFunc.intDegree_polynomial, natDegree_X_pow, sub_self]
+    have hne : algebraMap K[X] (RatFunc K) q / RatFunc.X ^ q.natDegree ≠ 0 :=
+      div_ne_zero hq' hXpow
+    have h0 := ord_placeInfty_eq_zero_of_intDegree_eq_zero K hne hdeg
+    have hsplit : algebraMap K[X] (RatFunc K) q
+        = (algebraMap K[X] (RatFunc K) q / RatFunc.X ^ q.natDegree)
+          * RatFunc.X ^ q.natDegree :=
+      (div_mul_cancel₀ _ hXpow).symm
+    rw [hsplit, (placeInfty K).ord_mul hne hXpow, h0, zero_add, ← zpow_natCast,
+      (placeInfty K).ord_zpow]
+  have hnum' : algebraMap K[X] (RatFunc K) f.num ≠ 0 :=
+    (map_ne_zero_iff _ hinj).mpr (RatFunc.num_ne_zero hf)
+  have hden' : algebraMap K[X] (RatFunc K) f.denom ≠ 0 :=
+    (map_ne_zero_iff _ hinj).mpr f.denom_ne_zero
+  rw [show f = algebraMap K[X] (RatFunc K) f.num * (algebraMap K[X] (RatFunc K) f.denom)⁻¹ by
+      rw [← div_eq_mul_inv, f.num_div_denom],
+    (placeInfty K).ord_mul hnum' (inv_ne_zero hden'), (placeInfty K).ord_inv,
+    hpoly _ (RatFunc.num_ne_zero hf), hpoly _ f.denom_ne_zero, ← div_eq_mul_inv,
+    RatFunc.intDegree_div hnum' hden', RatFunc.intDegree_polynomial,
+    RatFunc.intDegree_polynomial]
+  ring
+
+end PlaceInfty
+end RationalFunctionField
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+theorem le_exp_neg_one_of_lt_one {x : ℤᵐ⁰} (hx : x < 1) : x ≤ exp (-1 : ℤ) := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · exact zero_le
+  · rw [← exp_log hx0] at hx ⊢
+    rw [show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_lt_exp] at hx
+    rw [exp_le_exp]
+    omega
+
+namespace Place
+open AlgebraicCurve.Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+theorem isUnit_algebraMap {c : K} (hc : c ≠ 0) :
+    IsUnit (algebraMap K v.toValuationSubring c) :=
+  (isUnit_iff_ne_zero.mpr hc).map _
+
+theorem adicValuation_algebraMap {c : K} (hc : c ≠ 0) :
+    v.adicValuation (algebraMap K F c) = 1 := by
+  rw [← v.coe_algebraMap]
+  exact (v.adicValuation_coe_eq_one_iff _).mpr (v.isUnit_algebraMap hc)
+
+theorem ord_eq_neg_log_of_valuationSubring_eq (w : Valuation F ℤᵐ⁰)
+    (hw : w.valuationSubring = v.toValuationSubring) {π : F} (hπ : w π = exp (-1 : ℤ))
+    {f : F} (hf : f ≠ 0) : v.ord f = -log (w f) := by
+  have hequiv : w.IsEquiv v.adicValuation :=
+    v.isEquiv_adicValuation_of_valuationSubring_eq hw
+  have hexp_lt : (exp (-1 : ℤ) : ℤᵐ⁰) < 1 := by
+    rw [show (1 : ℤᵐ⁰) = exp 0 from rfl]
+    exact exp_lt_exp.mpr (by omega)
+  obtain ⟨π₀, hπ₀⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hadic_π₀ : v.adicValuation (π₀ : F) = exp (-1 : ℤ) := v.adicValuation_coe_irreducible hπ₀
+  have hwπ₀ : w (π₀ : F) = exp (-1 : ℤ) := by
+    refine le_antisymm (le_exp_neg_one_of_lt_one (hequiv.lt_one_iff_lt_one.mpr ?_)) ?_
+    · rw [hadic_π₀]
+      exact hexp_lt
+    · rw [← hπ]
+      refine (hequiv π π₀).mpr ?_
+      rw [hadic_π₀]
+      refine le_exp_neg_one_of_lt_one (hequiv.lt_one_iff_lt_one.mp ?_)
+      rw [hπ]
+      exact hexp_lt
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ₀
+  have hwu : w ((u : v.toValuationSubring) : F) = 1 :=
+    hequiv.eq_one_iff_eq_one.mpr ((v.adicValuation_coe_eq_one_iff _).mpr u.isUnit)
+  set n := v.ord f with hn
+  rw [hu, map_mul, map_zpow₀, hwu, hwπ₀, one_mul, log_zpow, log_exp, smul_eq_mul]
+  ring
+
+end Place
+namespace RationalFunctionField
+
+variable {K : Type*} [Field K]
+
+theorem ord_ofHeightOneSpectrum_eq_neg_log (w : HeightOneSpectrum K[X]) {p : K[X]}
+    (hp : p ≠ 0) (hw : w.asIdeal = Ideal.span {p}) {f : RatFunc K} (hf : f ≠ 0) :
+    (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord f
+      = -log (w.valuation (RatFunc K) f) := by
+  have hval : w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) p) = exp (-1 : ℤ) := by
+    have h := w.intValuation_singleton hp hw
+    rw [← h]
+    simpa using w.valuation_of_algebraMap (K := RatFunc K) p
+  exact (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K)
+    w).ord_eq_neg_log_of_valuationSubring_eq (w.valuation (RatFunc K)) rfl hval hf
+
+theorem ord_ofHeightOneSpectrum_of_span (w : HeightOneSpectrum K[X]) {p : K[X]}
+    (hp : p ≠ 0) (hw : w.asIdeal = Ideal.span {p}) :
+    (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord
+      (algebraMap K[X] (RatFunc K) p) = 1 := by
+  have hval : w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) p) = exp (-1 : ℤ) := by
+    have h := w.intValuation_singleton hp hw
+    rw [← h]
+    simpa using w.valuation_of_algebraMap (K := RatFunc K) p
+  rw [ord_ofHeightOneSpectrum_eq_neg_log w hp hw (RatFunc.algebraMap_ne_zero hp), hval]
+  simp [log_exp]
+
+theorem ord_ofHeightOneSpectrum_eq_zero_of_notMem (w : HeightOneSpectrum K[X]) {q : K[X]}
+    (hq : q ≠ 0) (hmem : q ∉ w.asIdeal) :
+    (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord
+      (algebraMap K[X] (RatFunc K) q) = 0 := by
+  by_contra h
+  exact hmem
+    ((Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w hq).mp h)
+
+section PlaceInftyOrd
+
+variable [DecidableEq (RatFunc K)]
+
+theorem ord_placeInfty {f : RatFunc K} (hf : f ≠ 0) :
+    (placeInfty K).ord f = -f.intDegree := by
+  have hπ : RatFunc.inftyValuation K (RatFunc.X)⁻¹ = exp (-1 : ℤ) := by
+    rw [map_inv₀, RatFunc.inftyValuation.X]
+    exact (exp_neg (1 : ℤ)).symm
+  rw [(placeInfty K).ord_eq_neg_log_of_valuationSubring_eq (RatFunc.inftyValuation K) rfl hπ
+      hf,
+    RatFunc.inftyValuation_apply, RatFunc.inftyValuation_of_nonzero K hf, log_exp]
+
+theorem ord_placeInfty_algebraMap {q : K[X]} (hq : q ≠ 0) :
+    (placeInfty K).ord (algebraMap K[X] (RatFunc K) q) = -(q.natDegree : ℤ) := by
+  rw [ord_placeInfty (RatFunc.algebraMap_ne_zero hq), RatFunc.intDegree_polynomial]
+
+end PlaceInftyOrd
+section IrreducibleDivisor
+
+variable [DecidableEq (RatFunc K)]
+
+theorem single_add_single_apply_eq_ord {p : K[X]} (hp : Irreducible p)
+    (v : Place K (RatFunc K)) :
+    (Finsupp.single (finitePlace K hp) (1 : ℤ)
+        + Finsupp.single (placeInfty K) (-(p.natDegree : ℤ))) v
+      = v.ord (algebraMap K[X] (RatFunc K) p) := by
+  have hp0 : p ≠ 0 := hp.ne_zero
+  rw [Finsupp.add_apply]
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+  · rw [Finsupp.single_eq_of_ne (Ne.symm (placeInfty_ne_ofHeightOneSpectrum K w)), add_zero]
+    by_cases hcase :
+        Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w = finitePlace K hp
+    · rw [hcase, Finsupp.single_eq_same]
+      exact (ord_ofHeightOneSpectrum_of_span (heightOneSpectrumOfIrreducible K hp) hp0
+        (heightOneSpectrumOfIrreducible_asIdeal K hp)).symm
+    · rw [Finsupp.single_eq_of_ne hcase]
+      refine (ord_ofHeightOneSpectrum_eq_zero_of_notMem w hp0 fun hmem => hcase ?_).symm
+      have hspan : Ideal.span {p} = w.asIdeal :=
+        (PrincipalIdealRing.isMaximal_of_irreducible hp).eq_of_le w.isPrime.ne_top
+          ((Ideal.span_singleton_le_iff_mem _).mpr hmem)
+      have hwp : w = heightOneSpectrumOfIrreducible K hp :=
+        HeightOneSpectrum.ext
+          (hspan.symm.trans (heightOneSpectrumOfIrreducible_asIdeal K hp).symm)
+      rw [hwp, finitePlace_def]
+  · rw [Finsupp.single_eq_of_ne
+        (show placeInfty K ≠ finitePlace K hp from
+          placeInfty_ne_ofHeightOneSpectrum K (heightOneSpectrumOfIrreducible K hp)),
+      Finsupp.single_eq_same, zero_add]
+    exact (ord_placeInfty_algebraMap hp0).symm
+
+theorem degree_single_add_single {p : K[X]} (hp : Irreducible p) :
+    Divisor.degree (Finsupp.single (finitePlace K hp) (1 : ℤ)
+        + Finsupp.single (placeInfty K) (-(p.natDegree : ℤ))) = 0 := by
+  rw [map_add, Divisor.degree_single, Divisor.degree_single, deg_finitePlace, deg_placeInfty]
+  push_cast
+  ring
+
+end IrreducibleDivisor
+theorem degree_eq_zero_of_forall_eq_ord_algebraMap (q : K[X]) :
+    ∀ D : Divisor K (RatFunc K),
+      (∀ v : Place K (RatFunc K), D v = v.ord (algebraMap K[X] (RatFunc K) q)) →
+      Divisor.degree D = 0 := by
+  classical
+  refine UniqueFactorizationMonoid.induction_on_prime q ?_ ?_ ?_
+  · intro D hD
+    have hzero : D = 0 := by
+      ext v
+      simp [hD v]
+    rw [hzero, _root_.map_zero]
+  · intro x hx D hD
+    obtain ⟨r, -, rfl⟩ := Polynomial.isUnit_iff.mp hx
+    have hC : (algebraMap K[X] (RatFunc K)) (Polynomial.C r) = algebraMap K (RatFunc K) r := by
+      rw [← Polynomial.algebraMap_eq, ← IsScalarTower.algebraMap_apply]
+    have hzero : D = 0 := by
+      ext v
+      rw [hD v, hC, v.ord_algebraMap]
+      simp
+    rw [hzero, _root_.map_zero]
+  · intro a p ha hp ih D hD
+    have hp' : algebraMap K[X] (RatFunc K) p ≠ 0 := RatFunc.algebraMap_ne_zero hp.ne_zero
+    have ha' : algebraMap K[X] (RatFunc K) a ≠ 0 := RatFunc.algebraMap_ne_zero ha
+    set Dp : Divisor K (RatFunc K) :=
+      Finsupp.single (finitePlace K hp.irreducible) (1 : ℤ)
+        + Finsupp.single (placeInfty K) (-(p.natDegree : ℤ)) with hDp_def
+    have hDp : ∀ v : Place K (RatFunc K), Dp v = v.ord (algebraMap K[X] (RatFunc K) p) :=
+      fun v => single_add_single_apply_eq_ord hp.irreducible v
+    have hDa : ∀ v : Place K (RatFunc K),
+        (D - Dp) v = v.ord (algebraMap K[X] (RatFunc K) a) := by
+      intro v
+      rw [Finsupp.sub_apply, hD v, hDp v, map_mul, v.ord_mul hp' ha']
+      ring
+    have hdeg_p : Divisor.degree Dp = 0 := degree_single_add_single hp.irreducible
+    have hdeg_a : Divisor.degree (D - Dp) = 0 := ih (D - Dp) hDa
+    have hsplit : D = Dp + (D - Dp) := by abel
+    rw [hsplit, map_add, hdeg_p, zero_add]
+    exact hdeg_a
+
+def principalDivisor {f : RatFunc K} (hf : f ≠ 0) : Divisor K (RatFunc K) :=
+  ⟨(finite_setOf_ord_ne_zero hf).toFinset, fun v => v.ord f, fun v => by
+    simp [Set.Finite.mem_toFinset]⟩
+
+@[scoped simp]
+theorem principalDivisor_apply {f : RatFunc K} (hf : f ≠ 0) (v : Place K (RatFunc K)) :
+    principalDivisor hf v = v.ord f := rfl
+
+theorem degree_eq_zero_of_forall_eq_ord {f : RatFunc K} (D : Divisor K (RatFunc K))
+    (hD : ∀ v : Place K (RatFunc K), D v = v.ord f) : Divisor.degree D = 0 := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · have hzero : D = 0 := by
+      ext v
+      simp [hD v]
+    rw [hzero, _root_.map_zero]
+  · have hden : f.denom ≠ 0 := f.denom_ne_zero
+    have hdenF : algebraMap K[X] (RatFunc K) f.denom ≠ 0 := RatFunc.algebraMap_ne_zero hden
+    have hsplit : ∀ v : Place K (RatFunc K),
+        (D + principalDivisor hdenF) v = v.ord (algebraMap K[X] (RatFunc K) f.num) := by
+      intro v
+      rw [Finsupp.add_apply, hD v, principalDivisor_apply]
+      have hmul : f * algebraMap K[X] (RatFunc K) f.denom
+          = algebraMap K[X] (RatFunc K) f.num :=
+        ((div_eq_iff hdenF).mp f.num_div_denom).symm
+      have h2 := v.ord_mul hf hdenF
+      rw [hmul] at h2
+      exact h2.symm
+    have h1 := degree_eq_zero_of_forall_eq_ord_algebraMap f.num
+      (D + principalDivisor hdenF) hsplit
+    have h2 := degree_eq_zero_of_forall_eq_ord_algebraMap f.denom
+      (principalDivisor hdenF) fun _ => rfl
+    rw [map_add, h2, add_zero] at h1
+    exact h1
+
+theorem degree_principalDivisor {f : RatFunc K} (hf : f ≠ 0) :
+    Divisor.degree (principalDivisor hf) = 0 :=
+  degree_eq_zero_of_forall_eq_ord (principalDivisor hf) fun _ => rfl
+
+scoped instance instHasPrincipalDivisors : HasPrincipalDivisors K (RatFunc K) where
+  exists_divisor _ hf := ⟨principalDivisor hf, fun _ => rfl, degree_principalDivisor hf⟩
+
+end RationalFunctionField
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+
+omit [DecidableEq (RatFunc K)] in
+theorem D_ratFuncX_eq_neg_X_sq_smul_D_inv :
+    KaehlerDifferential.D K (RatFunc K) RatFunc.X
+      = (-(RatFunc.X : RatFunc K) ^ 2) •
+          KaehlerDifferential.D K (RatFunc K) (RatFunc.X : RatFunc K)⁻¹ :=
+  (KaehlerDifferential.D K (RatFunc K)).leibniz_of_mul_eq_one
+    (mul_inv_cancel₀ RatFunc.X_ne_zero)
+
+public theorem ord_placeInfty_X_inv : (placeInfty K).ord (RatFunc.X : RatFunc K)⁻¹ = 1 := by
+  rw [(placeInfty K).ord_inv, ord_placeInfty_X, neg_neg]
+
+theorem ord_placeInfty_X_pow (n : ℕ) :
+    (placeInfty K).ord ((RatFunc.X : RatFunc K) ^ n) = -(n : ℤ) := by
+  rw [show ((RatFunc.X : RatFunc K) ^ n) = (RatFunc.X : RatFunc K) ^ (n : ℤ) from
+    (zpow_natCast _ n).symm, (placeInfty K).ord_zpow, ord_placeInfty_X]
+  ring
+
+section NonVanishing
+
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+omit [DecidableEq (RatFunc K)] in
+theorem D_ratFuncX_inv_ne_zero (hwd : OrdDifferentialWellDefined K (RatFunc K)) :
+    KaehlerDifferential.D K (RatFunc K) (RatFunc.X : RatFunc K)⁻¹ ≠ 0 := by
+  classical
+  obtain ⟨u, -, hueq⟩ :=
+    hwd (placeInfty K) (RatFunc.X : RatFunc K)⁻¹ (placeInfty K).uniformizer
+      (ord_placeInfty_X_inv K) (placeInfty K).ord_uniformizer
+  intro h0
+  refine (placeInfty K).dCoord_ne_zero ?_
+  change KaehlerDifferential.D K (RatFunc K) (placeInfty K).uniformizer = 0
+  rw [hueq, h0, smul_zero]
+
+end NonVanishing
+section DifferentialCoeff
+
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+public theorem differentialCoeff_placeInfty_D_X_eq :
+    (placeInfty K).differentialCoeff (KaehlerDifferential.D K (RatFunc K) RatFunc.X)
+      = (-(RatFunc.X : RatFunc K) ^ 2) *
+          (placeInfty K).differentialCoeff
+            (KaehlerDifferential.D K (RatFunc K) (RatFunc.X : RatFunc K)⁻¹) := by
+  rw [D_ratFuncX_eq_neg_X_sq_smul_D_inv, (placeInfty K).differentialCoeff_smul]
+
+theorem ord_differentialCoeff_placeInfty_D_X_inv_eq_zero
+    (hwd : OrdDifferentialWellDefined K (RatFunc K)) :
+    (placeInfty K).ord
+        ((placeInfty K).differentialCoeff
+          (KaehlerDifferential.D K (RatFunc K) (RatFunc.X : RatFunc K)⁻¹)) = 0 := by
+  obtain ⟨u, hu0, hueq⟩ :=
+    hwd (placeInfty K) (placeInfty K).uniformizer (RatFunc.X : RatFunc K)⁻¹
+      (placeInfty K).ord_uniformizer (ord_placeInfty_X_inv K)
+  rw [(placeInfty K).differentialCoeff_unique
+    (show KaehlerDifferential.D K (RatFunc K) (RatFunc.X : RatFunc K)⁻¹
+        = u • (placeInfty K).dCoord from hueq), hu0]
+
+end DifferentialCoeff
+section OrdDifferential
+
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+public theorem ordDifferential_placeInfty_D_ratFuncX
+    (hwd : OrdDifferentialWellDefined K (RatFunc K)) :
+    (placeInfty K).ordDifferential
+        (KaehlerDifferential.D K (RatFunc K) (RatFunc.X : RatFunc K)) = -2 := by
+  rw [Place.ordDifferential, differentialCoeff_placeInfty_D_X_eq K, neg_mul,
+    (placeInfty K).ord_neg,
+    (placeInfty K).ord_mul (pow_ne_zero 2 RatFunc.X_ne_zero)
+      ((placeInfty K).differentialCoeff_ne_zero (D_ratFuncX_inv_ne_zero K hwd)),
+    ord_placeInfty_X_pow K 2, ord_differentialCoeff_placeInfty_D_X_inv_eq_zero K hwd]
+  norm_num
+
+end OrdDifferential
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+namespace Place
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+section Setup
+
+variable (v : Place K F)
+
+scoped instance (priority := 100)
+  instIsScalarTowerSubtypeMemValuationSubringToValuationSubring_theorems : IsScalarTower
+  v.toValuationSubring F F' :=
+  IsScalarTower.of_algebraMap_eq fun _ => rfl
+
+end Setup
+section ResidueDictionary
+
+variable {v : Place K F} {w : Place K F'}
+
+def toValuationSubringOfRestrictEq (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.toValuationSubring :=
+  (algebraMap (integralClosureAt F' v) F').codRestrict
+    w.toValuationSubring.toSubring (forall_mem_of_restrict_eq hw)
+
+def residueOfCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.ResidueField :=
+  (IsLocalRing.residue w.toValuationSubring).comp (toValuationSubringOfRestrictEq hw)
+
+omit [FiniteDimensional F F'] in
+theorem residueOfCenter_apply (hw : w.restrict F = v) (c : integralClosureAt F' v) :
+    residueOfCenter hw c = IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw c) := rfl
+
+theorem ker_residueOfCenter (hw : w.restrict F = v) :
+    RingHom.ker (residueOfCenter hw) = (fiberCenter F' v hw).asIdeal := by
+  ext c
+  rw [RingHom.mem_ker, residueOfCenter_apply, IsLocalRing.residue_eq_zero_iff]
+  exact Iff.rfl
+
+theorem surjective_residueOfCenter (hw : w.restrict F = v) :
+    Function.Surjective (residueOfCenter hw) := by
+  classical
+  intro y
+  obtain ⟨x, rfl⟩ := IsLocalRing.residue_surjective y
+  have hx : (x : F') ∈ HeightOneSpectrum.valuationSubringAtPrime F' (fiberCenter F' v hw) := by
+    rw [← toValuationSubring_eq_of_restrict_eq hw]
+    exact x.2
+  obtain ⟨a, s, hs, hxas⟩ := hx
+  have hsP : s ∉ (fiberCenter F' v hw).asIdeal := hs
+  have hs0 : s ≠ 0 := fun h => hsP (h ▸ (fiberCenter F' v hw).asIdeal.zero_mem)
+  have hsF : algebraMap (integralClosureAt F' v) F' s ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hs0
+  have hsord : w.ord (algebraMap (integralClosureAt F' v) F' s) = 0 := by
+    have h1 : ¬ 0 < w.ord (algebraMap (integralClosureAt F' v) F' s) := by
+      rw [← mem_fiberCenter_iff_ord_pos hw hs0]
+      exact hsP
+    have h2 : 0 ≤ w.ord (algebraMap (integralClosureAt F' v) F' s) :=
+      w.ord_nonneg_of_mem (forall_mem_of_restrict_eq hw s)
+    omega
+  have hmax : (fiberCenter F' v hw).asIdeal.IsMaximal :=
+    (fiberCenter F' v hw).isPrime.isMaximal (fiberCenter F' v hw).ne_bot
+  obtain ⟨t, i, hi, hti⟩ := hmax.exists_inv hsP
+  have hst : s * t - 1 ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : s * t - 1 = -i := by linear_combination hti
+    rw [h1]
+    exact neg_mem hi
+  refine ⟨a * t, ?_⟩
+  rw [residueOfCenter_apply, ← sub_eq_zero, ← map_sub, IsLocalRing.residue_eq_zero_iff]
+  have hcoe : ((toValuationSubringOfRestrictEq hw (a * t) - x : w.toValuationSubring) : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') := rfl
+  rcases eq_or_ne (toValuationSubringOfRestrictEq hw (a * t) - x) 0 with hzero | hne
+  · rw [hzero]
+    exact (IsLocalRing.maximalIdeal w.toValuationSubring).zero_mem
+  have hcoene : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') ≠ 0 := by
+    intro h
+    exact hne (by rwa [← hcoe, ZeroMemClass.coe_eq_zero] at h)
+  have hfactor : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t * s - a)
+          * (algebraMap (integralClosureAt F' v) F' s)⁻¹ := by
+    rw [hxas, map_sub, map_mul (algebraMap (integralClosureAt F' v) F') (a * t) s,
+      sub_mul, mul_assoc, mul_inv_cancel₀ hsF, mul_one]
+  have hdiffC : a * t * s - a ≠ 0 := by
+    intro h
+    apply hcoene
+    rw [hfactor, h, _root_.map_zero, zero_mul]
+  have hdiffP : a * t * s - a ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : a * t * s - a = a * (s * t - 1) := by ring
+    rw [h1]
+    exact Ideal.mul_mem_left _ _ hst
+  have hmem' : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      ∈ w.toValuationSubring := by
+    rw [← hcoe]
+    exact Subtype.coe_prop _
+  rw [show (toValuationSubringOfRestrictEq hw (a * t) - x)
+      = (⟨_, hmem'⟩ : w.toValuationSubring) from Subtype.ext hcoe,
+    w.mem_maximalIdeal_iff_ord_pos hcoene hmem']
+  rw [hfactor, w.ord_mul (by
+      simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hdiffC)
+    (inv_ne_zero hsF), w.ord_inv, hsord, _root_.neg_zero, add_zero]
+  exact (mem_fiberCenter_iff_ord_pos hw hdiffC).mp hdiffP
+
+def residueFieldEquivQuotientCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v ⧸ (fiberCenter F' v hw).asIdeal ≃+* w.ResidueField :=
+  (Ideal.quotEquivOfEq (ker_residueOfCenter hw).symm).trans
+    ((residueOfCenter hw).quotientKerEquivOfSurjective (surjective_residueOfCenter hw))
+
+def placeCongrEquiv {u u' : Place K F} (h : u = u') :
+    u.toValuationSubring ≃+* u'.toValuationSubring where
+  toFun x := ⟨x.1, h ▸ x.2⟩
+  invFun x := ⟨x.1, h.symm ▸ x.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  map_mul' _ _ := rfl
+  map_add' _ _ := rfl
+
+def restrictResidueFieldEquiv (hw : w.restrict F = v) :
+    (w.restrict F).ResidueField ≃+* IsLocalRing.ResidueField v.toValuationSubring :=
+  IsLocalRing.ResidueField.mapEquiv (placeCongrEquiv hw)
+
+public theorem inertiaDeg_eq_inertiaDeg_fiberCenter (hw : w.restrict F = v) :
+    w.inertiaDeg F =
+      (fiberCenter F' v hw).asIdeal.inertiaDeg v.toValuationSubring := by
+  have := fiberCenter_liesOver hw
+  rw [Ideal.inertiaDeg_eq_of_isMaximal (IsLocalRing.maximalIdeal v.toValuationSubring)
+    (fiberCenter F' v hw).asIdeal]
+  change Module.finrank (w.restrict F).ResidueField w.ResidueField = _
+  refine Algebra.finrank_eq_of_equiv_equiv (restrictResidueFieldEquiv hw)
+    (residueFieldEquivQuotientCenter hw).symm ?_
+  ext a
+  obtain ⟨a, rfl⟩ := IsLocalRing.residue_surjective a
+  simp only [RingHom.coe_comp, Function.comp_apply, RingEquiv.toRingHom_eq_coe,
+    RingHom.coe_coe]
+  apply (residueFieldEquivQuotientCenter hw).injective
+  rw [RingEquiv.apply_symm_apply]
+  change IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw
+        (algebraMap v.toValuationSubring (integralClosureAt F' v) (placeCongrEquiv hw a)))
+    = IsLocalRing.residue w.toValuationSubring (restrictInclusion F w a)
+  refine congrArg _ (Subtype.ext ?_)
+  change algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) (placeCongrEquiv hw a))
+    = algebraMap F F' (a : F)
+  rw [← IsScalarTower.algebraMap_apply,
+    IsScalarTower.algebraMap_apply v.toValuationSubring F F']
+  rfl
+
+end ResidueDictionary
+end Place
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable (K : Type*) [Field K]
+
+public abbrev dX : Ω[(RatFunc K)⁄K] := KaehlerDifferential.D K (RatFunc K) RatFunc.X
+
+theorem aeval_ratFuncX_eq_algebraMap (q : K[X]) :
+    aeval (RatFunc.X : RatFunc K) q = algebraMap K[X] (RatFunc K) q := by
+  rw [← RatFunc.algebraMap_X,
+    show algebraMap K[X] (RatFunc K) X = IsScalarTower.toAlgHom K K[X] (RatFunc K) X from rfl,
+    aeval_algHom_apply, aeval_X_left_apply]
+  rfl
+
+public theorem D_algebraMap_polynomial (q : K[X]) :
+    KaehlerDifferential.D K (RatFunc K) (algebraMap K[X] (RatFunc K) q)
+      = algebraMap K[X] (RatFunc K) q.derivative • dX K := by
+  rw [← aeval_ratFuncX_eq_algebraMap K q, (D K (RatFunc K)).map_aeval q RatFunc.X,
+    aeval_ratFuncX_eq_algebraMap K q.derivative]
+
+public theorem denom_sq_smul_D_eq (f : RatFunc K) :
+    (algebraMap K[X] (RatFunc K) f.denom) ^ 2 • KaehlerDifferential.D K (RatFunc K) f
+      = algebraMap K[X] (RatFunc K)
+          (f.num.derivative * f.denom - f.num * f.denom.derivative) • dX K := by
+  have hd : algebraMap K[X] (RatFunc K) f.denom ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr f.denom_ne_zero
+  have hDf : KaehlerDifferential.D K (RatFunc K) f
+      = ((algebraMap K[X] (RatFunc K) f.denom)⁻¹ ^ 2) •
+        (algebraMap K[X] (RatFunc K) f.denom • D K (RatFunc K) (algebraMap K[X] (RatFunc K) f.num)
+          - algebraMap K[X] (RatFunc K) f.num
+              • D K (RatFunc K) (algebraMap K[X] (RatFunc K) f.denom)) := by
+    conv_lhs => rw [← f.num_div_denom, (D K (RatFunc K)).leibniz_div]
+  rw [hDf, smul_smul, ← mul_pow, mul_inv_cancel₀ hd, one_pow, one_smul,
+    D_algebraMap_polynomial K f.num, D_algebraMap_polynomial K f.denom,
+    smul_smul, smul_smul, ← sub_smul]
+  push_cast
+  ring_nf
+
+theorem span_dX_eq_top :
+    Submodule.span (RatFunc K) {dX K} = ⊤ := by
+  rw [eq_top_iff, ← KaehlerDifferential.span_range_derivation, Submodule.span_le]
+  rintro _ ⟨f, rfl⟩
+  have hd : algebraMap K[X] (RatFunc K) f.denom ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr f.denom_ne_zero
+  have hsq : ((algebraMap K[X] (RatFunc K) f.denom) ^ 2)⁻¹
+        * (algebraMap K[X] (RatFunc K) f.denom) ^ 2 = 1 :=
+    inv_mul_cancel₀ (pow_ne_zero 2 hd)
+  refine Submodule.mem_span_singleton.mpr ⟨((algebraMap K[X] (RatFunc K) f.denom) ^ 2)⁻¹
+    * algebraMap K[X] (RatFunc K)
+        (f.num.derivative * f.denom - f.num * f.denom.derivative), ?_⟩
+  rw [mul_smul, ← denom_sq_smul_D_eq K f, smul_smul, hsq, one_smul]
+
+public theorem dX_ne_zero [Nontrivial Ω[(RatFunc K)⁄K]] : dX K ≠ 0 := by
+  intro h0
+  obtain ⟨ω, hω⟩ := exists_ne (0 : Ω[(RatFunc K)⁄K])
+  have hω_mem : ω ∈ Submodule.span (RatFunc K) {dX K} :=
+    span_dX_eq_top K ▸ Submodule.mem_top
+  rw [h0, Submodule.span_zero_singleton] at hω_mem
+  exact hω hω_mem
+
+theorem not_dvd_derivative_of_sq_not_dvd {p : K[X]} (hp : Irreducible p) (hsep : p.Separable)
+    {q : K[X]} (hpq : p ∣ q) (hpq2 : ¬ p ^ 2 ∣ q) : ¬ p ∣ q.derivative := by
+  obtain ⟨m, rfl⟩ := hpq
+  have hpm : ¬ p ∣ m := fun ⟨r, hr⟩ => hpq2 ⟨r, by rw [hr]; ring⟩
+  intro hpdvd
+  rw [derivative_mul] at hpdvd
+  have hpdvd' : p ∣ p.derivative * m := by
+    have := dvd_sub hpdvd (dvd_mul_right p m.derivative)
+    rwa [add_sub_cancel_right] at this
+  rcases hp.prime.dvd_mul.mp hpdvd' with hpp' | hpm'
+  · exact hp.not_isUnit (hsep.isUnit_of_dvd' dvd_rfl hpp')
+  · exact hpm hpm'
+
+variable {K}
+
+theorem not_dvd_derivative_of_ord_eq_one {w : HeightOneSpectrum K[X]} {p : K[X]}
+    (hp : Irreducible p) (hwp : w.asIdeal = Ideal.span {p}) (hsep : p.Separable)
+    {q : K[X]} (hq : q ≠ 0)
+    (hord : (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord
+      (algebraMap K[X] (RatFunc K) q) = 1) :
+    ¬ p ∣ q.derivative := by
+  have hwmem : ∀ {r : K[X]}, r ≠ 0 →
+      ((Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord
+        (algebraMap K[X] (RatFunc K) r) ≠ 0 ↔ p ∣ r) := fun {r} hr => by
+    rw [Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w hr,
+      hwp, Ideal.mem_span_singleton]
+  have hordp : (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord
+      (algebraMap K[X] (RatFunc K) p) = 1 :=
+    ord_ofHeightOneSpectrum_of_span w hp.ne_zero hwp
+  refine not_dvd_derivative_of_sq_not_dvd K hp hsep
+    ((hwmem hq).mp (hord ▸ one_ne_zero)) ?_
+  rintro ⟨r, rfl⟩
+  have hr : r ≠ 0 := fun h => hq (by simp [h])
+  have : (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord
+      (algebraMap K[X] (RatFunc K) (p ^ 2 * r)) ≥ 2 := by
+    have hp0 : algebraMap K[X] (RatFunc K) p ≠ 0 :=
+      (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hp.ne_zero
+    have hr0 : algebraMap K[X] (RatFunc K) r ≠ 0 :=
+      (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hr
+    rw [map_mul, map_pow,
+      (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord_mul (pow_ne_zero 2 hp0) hr0,
+      ← zpow_natCast, (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord_zpow,
+      hordp, mul_one]
+    have : 0 ≤ (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord
+        (algebraMap K[X] (RatFunc K) r) :=
+      (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord_nonneg_of_mem
+        (algebraMap_mem_ofHeightOneSpectrum K w r)
+    omega
+  omega
+
+section NumDenom
+
+variable {w : HeightOneSpectrum K[X]}
+
+local notation "v" => Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w
+
+theorem uniformizer_ne_zero' : (v).uniformizer ≠ 0 :=
+  (v).uniformizer_ne_zero
+
+theorem ord_algebraMap_denom_uniformizer_eq_zero {p : K[X]}
+    (hp : Irreducible p) (hwp : w.asIdeal = Ideal.span {p}) :
+    (v).ord (algebraMap K[X] (RatFunc K) (v).uniformizer.denom) = 0 := by
+  set π := (v).uniformizer with hπ
+  have hπne : π ≠ 0 := uniformizer_ne_zero'
+  by_contra hne
+  have hpd : p ∣ π.denom := by
+    rw [← Ideal.mem_span_singleton, ← hwp]
+    exact (Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w
+      π.denom_ne_zero).mp hne
+  have hpn : ¬ p ∣ π.num := fun hpn =>
+    hp.not_isUnit (π.isCoprime_num_denom.isUnit_of_dvd' hpn hpd)
+  have hordn : (v).ord (algebraMap K[X] (RatFunc K) π.num) = 0 := by
+    by_contra h
+    exact hpn (by
+      rw [← Ideal.mem_span_singleton, ← hwp]
+      exact (Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w
+        (RatFunc.num_ne_zero hπne)).mp h)
+  have hordd : 0 < (v).ord (algebraMap K[X] (RatFunc K) π.denom) :=
+    lt_of_le_of_ne ((v).ord_nonneg_of_mem (algebraMap_mem_ofHeightOneSpectrum K w _)) (Ne.symm hne)
+  have hnum0 : algebraMap K[X] (RatFunc K) π.num ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr (RatFunc.num_ne_zero hπne)
+  have hden0 : algebraMap K[X] (RatFunc K) π.denom ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr π.denom_ne_zero
+  have hordπ : (v).ord π = 1 := (v).ord_uniformizer
+  rw [← π.num_div_denom, div_eq_mul_inv, (v).ord_mul hnum0 (inv_ne_zero hden0),
+    (v).ord_inv, hordn] at hordπ
+  omega
+
+theorem ord_algebraMap_num_uniformizer_eq_one {p : K[X]}
+    (hp : Irreducible p) (hwp : w.asIdeal = Ideal.span {p}) :
+    (v).ord (algebraMap K[X] (RatFunc K) (v).uniformizer.num) = 1 := by
+  set π := (v).uniformizer with hπ
+  have hπne : π ≠ 0 := uniformizer_ne_zero'
+  have hnum0 : algebraMap K[X] (RatFunc K) π.num ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr (RatFunc.num_ne_zero hπne)
+  have hden0 : algebraMap K[X] (RatFunc K) π.denom ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr π.denom_ne_zero
+  have hordπ : (v).ord π = 1 := (v).ord_uniformizer
+  rw [← π.num_div_denom, div_eq_mul_inv, (v).ord_mul hnum0 (inv_ne_zero hden0),
+    (v).ord_inv, ord_algebraMap_denom_uniformizer_eq_zero hp hwp] at hordπ
+  omega
+
+theorem not_dvd_num'denom_sub_numdenom' {p : K[X]}
+    (hp : Irreducible p) (hwp : w.asIdeal = Ideal.span {p}) (hsep : p.Separable) :
+    ¬ p ∣ ((v).uniformizer.num.derivative * (v).uniformizer.denom
+            - (v).uniformizer.num * (v).uniformizer.denom.derivative) := by
+  set π := (v).uniformizer with hπ
+  have hπne : π ≠ 0 := uniformizer_ne_zero'
+  have hpn' : ¬ p ∣ π.num.derivative :=
+    not_dvd_derivative_of_ord_eq_one hp hwp hsep (RatFunc.num_ne_zero hπne)
+      (ord_algebraMap_num_uniformizer_eq_one hp hwp)
+  have hpd : ¬ p ∣ π.denom := fun hpd => by
+    have := ord_algebraMap_denom_uniformizer_eq_zero (w := w) hp hwp
+    rw [← Ideal.mem_span_singleton, ← hwp] at hpd
+    exact (Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w
+      π.denom_ne_zero).mpr hpd this
+  have hpn : p ∣ π.num := by
+    rw [← Ideal.mem_span_singleton, ← hwp]
+    refine (Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w
+      (RatFunc.num_ne_zero hπne)).mp ?_
+    rw [ord_algebraMap_num_uniformizer_eq_one hp hwp]; exact one_ne_zero
+  intro hdvd
+  have hpnd' : p ∣ π.num * π.denom.derivative := hpn.mul_right _
+  have hpn'd : p ∣ π.num.derivative * π.denom := by
+    have := dvd_add hdvd hpnd'
+    rwa [sub_add_cancel] at this
+  rcases hp.prime.dvd_mul.mp hpn'd with h | h
+  · exact hpn' h
+  · exact hpd h
+
+end NumDenom
+section PerPlace
+
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+variable {w : HeightOneSpectrum K[X]}
+
+local notation "v" => Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w
+
+public theorem ord_differentialCoeff_dX_ofHeightOneSpectrum {p : K[X]}
+    (hp : Irreducible p) (hwp : w.asIdeal = Ideal.span {p}) (hsep : p.Separable) :
+    (v).ord ((v).differentialCoeff (dX K)) = 0 := by
+  set π := (v).uniformizer with hπ
+  have hπne : π ≠ 0 := uniformizer_ne_zero'
+  set ξ : K[X] := π.num.derivative * π.denom - π.num * π.denom.derivative with hξ
+  have hd0 : algebraMap K[X] (RatFunc K) π.denom ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr π.denom_ne_zero
+  have hcoord : (v).dCoord
+      = (algebraMap K[X] (RatFunc K) ξ / (algebraMap K[X] (RatFunc K) π.denom) ^ 2) • dX K := by
+    rw [div_eq_mul_inv, mul_comm, mul_smul, ← denom_sq_smul_D_eq K π, smul_smul,
+      inv_mul_cancel₀ (pow_ne_zero 2 hd0), one_smul]
+    rfl
+  have hξ0 : ξ ≠ 0 := by
+    intro h; rw [hξ] at h
+    exact not_dvd_num'denom_sub_numdenom' hp hwp hsep (h ▸ dvd_zero p)
+  have hcoeff0 : algebraMap K[X] (RatFunc K) ξ / (algebraMap K[X] (RatFunc K) π.denom) ^ 2 ≠ 0 :=
+    div_ne_zero ((map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hξ0)
+      (pow_ne_zero 2 hd0)
+  have hcoeff : (v).differentialCoeff (dX K)
+      = (algebraMap K[X] (RatFunc K) ξ / (algebraMap K[X] (RatFunc K) π.denom) ^ 2)⁻¹ := by
+    refine (v).differentialCoeff_unique ?_
+    rw [hcoord, smul_smul, inv_mul_cancel₀ hcoeff0, one_smul]
+  have hordξ : (v).ord (algebraMap K[X] (RatFunc K) ξ) = 0 := by
+    by_contra h
+    refine not_dvd_num'denom_sub_numdenom' hp hwp hsep ?_
+    rw [← Ideal.mem_span_singleton, ← hwp]
+    exact (Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w hξ0).mp h
+  rw [hcoeff, (v).ord_inv, div_eq_mul_inv,
+    (v).ord_mul ((map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hξ0)
+      (inv_ne_zero (pow_ne_zero 2 hd0)),
+    hordξ, (v).ord_inv, ← zpow_natCast, (v).ord_zpow,
+    ord_algebraMap_denom_uniformizer_eq_zero hp hwp]
+  ring
+
+end PerPlace
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+namespace Divisor
+open AlgebraicCurve.Divisor
+
+section Pullback
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [Algebra.IsIntegral F F']
+
+
+end Pullback
+end Divisor
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+section WronskianBound
+
+variable {K : Type*} [Field K]
+
+theorem natDegree_numDenomWronskian_lt {n d : K[X]} (hn : n ≠ 0) (hd : d ≠ 0)
+    (hW : n.derivative * d - n * d.derivative ≠ 0) :
+    (n.derivative * d - n * d.derivative).natDegree < n.natDegree + d.natDegree := by
+  have hdeg : (n.derivative * d - n * d.derivative).degree < (n * d).degree := by
+    rw [Polynomial.degree_mul]
+    refine lt_of_le_of_lt (Polynomial.degree_sub_le _ _) (max_lt ?_ ?_)
+    · refine lt_of_le_of_lt (Polynomial.degree_mul_le _ _) ?_
+      rw [WithBot.add_lt_add_iff_right (Polynomial.degree_ne_bot.mpr hd)]
+      exact Polynomial.degree_derivative_lt hn
+    · refine lt_of_le_of_lt (Polynomial.degree_mul_le _ _) ?_
+      rw [WithBot.add_lt_add_iff_left (Polynomial.degree_ne_bot.mpr hn)]
+      exact Polynomial.degree_derivative_lt hd
+  have h2 := Polynomial.natDegree_lt_natDegree hW hdeg
+  rwa [Polynomial.natDegree_mul hn hd] at h2
+
+end WronskianBound
+section DXCoeff
+
+variable (K : Type*) [Field K]
+
+@[expose] public def ratFuncDXCoeff (f : RatFunc K) : RatFunc K :=
+  algebraMap K[X] (RatFunc K) (f.num.derivative * f.denom - f.num * f.denom.derivative)
+    / (algebraMap K[X] (RatFunc K) f.denom) ^ 2
+
+public theorem ratFuncDXCoeff_def (f : RatFunc K) :
+    ratFuncDXCoeff K f
+      = algebraMap K[X] (RatFunc K) (f.num.derivative * f.denom - f.num * f.denom.derivative)
+        / (algebraMap K[X] (RatFunc K) f.denom) ^ 2 := rfl
+
+public theorem D_eq_ratFuncDXCoeff_smul_dX (f : RatFunc K) :
+    KaehlerDifferential.D K (RatFunc K) f = ratFuncDXCoeff K f • dX K := by
+  have hd : algebraMap K[X] (RatFunc K) f.denom ≠ 0 :=
+    RatFunc.algebraMap_ne_zero f.denom_ne_zero
+  rw [ratFuncDXCoeff_def, div_eq_mul_inv, mul_comm, mul_smul, ← denom_sq_smul_D_eq K f,
+    smul_smul, inv_mul_cancel₀ (pow_ne_zero 2 hd), one_smul]
+
+public theorem wronskian_ne_zero_of_ratFuncDXCoeff_ne_zero {f : RatFunc K}
+    (h : ratFuncDXCoeff K f ≠ 0) :
+    f.num.derivative * f.denom - f.num * f.denom.derivative ≠ 0 := by
+  intro h0
+  exact h (by rw [ratFuncDXCoeff_def, h0, _root_.map_zero, zero_div])
+
+end DXCoeff
+section FinitePlaces
+
+variable {K : Type*} [Field K]
+variable {w : HeightOneSpectrum K[X]}
+
+local notation "v" => Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w
+
+theorem ord_algebraMap_denom_eq_zero_of_ord_eq_one {p : K[X]}
+    (hp : Irreducible p) (hwp : w.asIdeal = Ideal.span {p}) {f : RatFunc K}
+    (hf : f ≠ 0) (hord : (v).ord f = 1) :
+    (v).ord (algebraMap K[X] (RatFunc K) f.denom) = 0 := by
+  by_contra hne
+  have hpd : p ∣ f.denom := by
+    rw [← Ideal.mem_span_singleton, ← hwp]
+    exact (Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w
+      f.denom_ne_zero).mp hne
+  have hpn : ¬ p ∣ f.num := fun hpn =>
+    hp.not_isUnit (f.isCoprime_num_denom.isUnit_of_dvd' hpn hpd)
+  have hordn : (v).ord (algebraMap K[X] (RatFunc K) f.num) = 0 := by
+    by_contra h
+    exact hpn (by
+      rw [← Ideal.mem_span_singleton, ← hwp]
+      exact (Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w
+        (RatFunc.num_ne_zero hf)).mp h)
+  have hordd : 0 < (v).ord (algebraMap K[X] (RatFunc K) f.denom) :=
+    lt_of_le_of_ne ((v).ord_nonneg_of_mem (algebraMap_mem_ofHeightOneSpectrum K w _))
+      (Ne.symm hne)
+  have hnum0 : algebraMap K[X] (RatFunc K) f.num ≠ 0 :=
+    RatFunc.algebraMap_ne_zero (RatFunc.num_ne_zero hf)
+  have hden0 : algebraMap K[X] (RatFunc K) f.denom ≠ 0 :=
+    RatFunc.algebraMap_ne_zero f.denom_ne_zero
+  rw [← f.num_div_denom, div_eq_mul_inv, (v).ord_mul hnum0 (inv_ne_zero hden0),
+    (v).ord_inv, hordn] at hord
+  omega
+
+theorem ord_algebraMap_num_eq_one_of_ord_eq_one {p : K[X]}
+    (hp : Irreducible p) (hwp : w.asIdeal = Ideal.span {p}) {f : RatFunc K}
+    (hf : f ≠ 0) (hord : (v).ord f = 1) :
+    (v).ord (algebraMap K[X] (RatFunc K) f.num) = 1 := by
+  have hnum0 : algebraMap K[X] (RatFunc K) f.num ≠ 0 :=
+    RatFunc.algebraMap_ne_zero (RatFunc.num_ne_zero hf)
+  have hden0 : algebraMap K[X] (RatFunc K) f.denom ≠ 0 :=
+    RatFunc.algebraMap_ne_zero f.denom_ne_zero
+  have h := hord
+  rw [← f.num_div_denom, div_eq_mul_inv, (v).ord_mul hnum0 (inv_ne_zero hden0),
+    (v).ord_inv, ord_algebraMap_denom_eq_zero_of_ord_eq_one hp hwp hf hord] at h
+  omega
+
+theorem not_dvd_wronskian_of_ord_eq_one {p : K[X]}
+    (hp : Irreducible p) (hwp : w.asIdeal = Ideal.span {p}) (hsep : p.Separable)
+    {f : RatFunc K} (hf : f ≠ 0) (hord : (v).ord f = 1) :
+    ¬ p ∣ (f.num.derivative * f.denom - f.num * f.denom.derivative) := by
+  have hpn' : ¬ p ∣ f.num.derivative :=
+    not_dvd_derivative_of_ord_eq_one hp hwp hsep (RatFunc.num_ne_zero hf)
+      (ord_algebraMap_num_eq_one_of_ord_eq_one hp hwp hf hord)
+  have hpd : ¬ p ∣ f.denom := fun hpd => by
+    have h0 := ord_algebraMap_denom_eq_zero_of_ord_eq_one hp hwp hf hord
+    rw [← Ideal.mem_span_singleton, ← hwp] at hpd
+    exact (Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w
+      f.denom_ne_zero).mpr hpd h0
+  have hpn : p ∣ f.num := by
+    rw [← Ideal.mem_span_singleton, ← hwp]
+    refine (Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w
+      (RatFunc.num_ne_zero hf)).mp ?_
+    rw [ord_algebraMap_num_eq_one_of_ord_eq_one hp hwp hf hord]
+    exact one_ne_zero
+  intro hdvd
+  have hpnd' : p ∣ f.num * f.denom.derivative := hpn.mul_right _
+  have hpn'd : p ∣ f.num.derivative * f.denom := by
+    have h1 := dvd_add hdvd hpnd'
+    rwa [sub_add_cancel] at h1
+  rcases hp.prime.dvd_mul.mp hpn'd with h | h
+  · exact hpn' h
+  · exact hpd h
+
+public theorem ratFuncDXCoeff_ne_zero_and_ord_eq_zero_of_ord_eq_one {p : K[X]}
+    (hp : Irreducible p) (hwp : w.asIdeal = Ideal.span {p}) (hsep : p.Separable)
+    {f : RatFunc K} (hf : f ≠ 0) (hord : (v).ord f = 1) :
+    ratFuncDXCoeff K f ≠ 0 ∧ (v).ord (ratFuncDXCoeff K f) = 0 := by
+  have hW : ¬ p ∣ (f.num.derivative * f.denom - f.num * f.denom.derivative) :=
+    not_dvd_wronskian_of_ord_eq_one hp hwp hsep hf hord
+  have hξ0 : f.num.derivative * f.denom - f.num * f.denom.derivative ≠ 0 := fun h =>
+    hW (h ▸ dvd_zero p)
+  have hd0 : algebraMap K[X] (RatFunc K) f.denom ≠ 0 :=
+    RatFunc.algebraMap_ne_zero f.denom_ne_zero
+  have hξ0' : algebraMap K[X] (RatFunc K)
+      (f.num.derivative * f.denom - f.num * f.denom.derivative) ≠ 0 :=
+    RatFunc.algebraMap_ne_zero hξ0
+  have hordξ : (v).ord (algebraMap K[X] (RatFunc K)
+      (f.num.derivative * f.denom - f.num * f.denom.derivative)) = 0 := by
+    by_contra h
+    refine hW ?_
+    rw [← Ideal.mem_span_singleton, ← hwp]
+    exact (Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w hξ0).mp h
+  refine ⟨div_ne_zero hξ0' (pow_ne_zero 2 hd0), ?_⟩
+  rw [ratFuncDXCoeff_def, div_eq_mul_inv,
+    (v).ord_mul hξ0' (inv_ne_zero (pow_ne_zero 2 hd0)), (v).ord_inv, hordξ,
+    ← zpow_natCast, (v).ord_zpow,
+    ord_algebraMap_denom_eq_zero_of_ord_eq_one hp hwp hf hord]
+  ring
+
+end FinitePlaces
+section PlaceInftySide
+
+variable {K : Type*} [Field K] [DecidableEq (RatFunc K)]
+
+public theorem ord_placeInfty_ratFuncDXCoeff_ge {g : RatFunc K} (hg : g ≠ 0)
+    (hW : g.num.derivative * g.denom - g.num * g.denom.derivative ≠ 0) :
+    (placeInfty K).ord g + 1 ≤ (placeInfty K).ord (ratFuncDXCoeff K g) := by
+  have hn0 : g.num ≠ 0 := RatFunc.num_ne_zero hg
+  have hd0 : g.denom ≠ 0 := g.denom_ne_zero
+  have hW' : algebraMap K[X] (RatFunc K)
+      (g.num.derivative * g.denom - g.num * g.denom.derivative) ≠ 0 :=
+    RatFunc.algebraMap_ne_zero hW
+  have hd' : algebraMap K[X] (RatFunc K) g.denom ≠ 0 := RatFunc.algebraMap_ne_zero hd0
+  have hdeg : (g.num.derivative * g.denom - g.num * g.denom.derivative).natDegree
+      < g.num.natDegree + g.denom.natDegree :=
+    natDegree_numDenomWronskian_lt hn0 hd0 hW
+  have hcoeff : (placeInfty K).ord (ratFuncDXCoeff K g)
+      = 2 * (g.denom.natDegree : ℤ)
+        - (g.num.derivative * g.denom - g.num * g.denom.derivative).natDegree := by
+    rw [ratFuncDXCoeff_def, ord_placeInfty (div_ne_zero hW' (pow_ne_zero 2 hd')),
+      RatFunc.intDegree_div hW' (pow_ne_zero 2 hd'), RatFunc.intDegree_polynomial,
+      ← map_pow, RatFunc.intDegree_polynomial, Polynomial.natDegree_pow]
+    push_cast
+    ring
+  have hgord : (placeInfty K).ord g = (g.denom.natDegree : ℤ) - g.num.natDegree := by
+    rw [ord_placeInfty hg, RatFunc.intDegree]
+    ring
+  rw [hcoeff, hgord]
+  omega
+
+public theorem exists_dXCoeff_ord_ge_two_of_ord_placeInfty_eq_zero {g : RatFunc K}
+    (hg : g ≠ 0) (hord : (placeInfty K).ord g = 0) :
+    ∃ e : RatFunc K, (e = 0 ∨ 2 ≤ (placeInfty K).ord e) ∧
+      KaehlerDifferential.D K (RatFunc K) g = e • dX K := by
+  have hmem : RatFunc.inftyValuation K g ≤ 1 := by
+    have h1 : g ∈ (placeInfty K).toValuationSubring :=
+      (placeInfty K).mem_of_ord_nonneg hg hord.symm.le
+    rwa [placeInfty_toValuationSubring, Valuation.mem_valuationSubring_iff] at h1
+  obtain ⟨c, hc⟩ := exists_sub_algebraMap_intDegree_neg K hmem
+  have hDg : KaehlerDifferential.D K (RatFunc K) g
+      = KaehlerDifferential.D K (RatFunc K) (g - algebraMap K (RatFunc K) c) := by
+    rw [map_sub, Derivation.map_algebraMap (KaehlerDifferential.D K (RatFunc K)) c, sub_zero]
+  rcases hc with hc0 | hcneg
+  · exact ⟨0, Or.inl rfl, by rw [hDg, hc0, _root_.map_zero, zero_smul]⟩
+  · have hg₁0 : g - algebraMap K (RatFunc K) c ≠ 0 := by
+      intro h0
+      rw [h0] at hcneg
+      simp at hcneg
+    refine ⟨ratFuncDXCoeff K (g - algebraMap K (RatFunc K) c), ?_,
+      by rw [hDg, D_eq_ratFuncDXCoeff_smul_dX]⟩
+    rcases eq_or_ne (ratFuncDXCoeff K (g - algebraMap K (RatFunc K) c)) 0 with h0 | h0
+    · exact Or.inl h0
+    · refine Or.inr ?_
+      have hW := wronskian_ne_zero_of_ratFuncDXCoeff_ne_zero K h0
+      have hge := ord_placeInfty_ratFuncDXCoeff_ge hg₁0 hW
+      have hord₁ : 1 ≤ (placeInfty K).ord (g - algebraMap K (RatFunc K) c) := by
+        rw [ord_placeInfty hg₁0]
+        omega
+      omega
+
+theorem exists_unit_dXCoeff_of_ord_placeInfty_eq_neg_one {h : RatFunc K}
+    (hh : h ≠ 0) (hord : (placeInfty K).ord h = -1) :
+    ∃ b : RatFunc K, b ≠ 0 ∧ (placeInfty K).ord b = 0 ∧
+      KaehlerDifferential.D K (RatFunc K) h = b • dX K := by
+  have hX : (RatFunc.X : RatFunc K) ≠ 0 := RatFunc.X_ne_zero
+  have hXinv : (RatFunc.X : RatFunc K)⁻¹ ≠ 0 := inv_ne_zero hX
+  have hg0 : h * (RatFunc.X : RatFunc K)⁻¹ ≠ 0 := mul_ne_zero hh hXinv
+  have hordg : (placeInfty K).ord (h * (RatFunc.X : RatFunc K)⁻¹) = 0 := by
+    rw [(placeInfty K).ord_mul hh hXinv, (placeInfty K).ord_inv, ord_placeInfty_X, hord]
+    ring
+  obtain ⟨e, he, hDe⟩ := exists_dXCoeff_ord_ge_two_of_ord_placeInfty_eq_zero hg0 hordg
+  have hh_eq : h = h * (RatFunc.X : RatFunc K)⁻¹ * RatFunc.X := by
+    rw [mul_assoc, inv_mul_cancel₀ hX, mul_one]
+  have hDh : KaehlerDifferential.D K (RatFunc K) h
+      = (h * (RatFunc.X : RatFunc K)⁻¹ + RatFunc.X * e) • dX K := by
+    conv_lhs => rw [hh_eq]
+    rw [Derivation.leibniz, hDe, smul_smul,
+      show KaehlerDifferential.D K (RatFunc K) (RatFunc.X : RatFunc K) = dX K from rfl,
+      ← add_smul]
+  rcases he with rfl | he2
+  · refine ⟨h * (RatFunc.X : RatFunc K)⁻¹ + RatFunc.X * 0, ?_, ?_, hDh⟩
+    · rw [mul_zero, add_zero]
+      exact hg0
+    · rw [mul_zero, add_zero]
+      exact hordg
+  · have he0 : e ≠ 0 := by
+      intro h0
+      rw [h0, (placeInfty K).ord_zero] at he2
+      omega
+    have hXe0 : (RatFunc.X : RatFunc K) * e ≠ 0 := mul_ne_zero hX he0
+    have hlt : (placeInfty K).ord (h * (RatFunc.X : RatFunc K)⁻¹)
+        < (placeInfty K).ord ((RatFunc.X : RatFunc K) * e) := by
+      rw [hordg, (placeInfty K).ord_mul hX he0, ord_placeInfty_X]
+      omega
+    refine ⟨h * (RatFunc.X : RatFunc K)⁻¹ + RatFunc.X * e, ?_, ?_, hDh⟩
+    · intro hsum
+      have hXe_eq : (RatFunc.X : RatFunc K) * e = -(h * (RatFunc.X : RatFunc K)⁻¹) := by
+        linear_combination hsum
+      rw [hXe_eq, (placeInfty K).ord_neg] at hlt
+      exact lt_irrefl _ hlt
+    · rw [(placeInfty K).ord_add_eq_left hg0 hXe0 hlt]
+      exact hordg
+
+public theorem exists_dXCoeff_ord_two_of_ord_placeInfty_eq_one {f : RatFunc K}
+    (hf : f ≠ 0) (hord : (placeInfty K).ord f = 1) :
+    ∃ e : RatFunc K, e ≠ 0 ∧ (placeInfty K).ord e = 2 ∧
+      KaehlerDifferential.D K (RatFunc K) f = e • dX K := by
+  have hf' : f⁻¹ ≠ 0 := inv_ne_zero hf
+  have hord' : (placeInfty K).ord f⁻¹ = -1 := by
+    rw [(placeInfty K).ord_inv, hord]
+  obtain ⟨b, hb0, hbord, hDb⟩ := exists_unit_dXCoeff_of_ord_placeInfty_eq_neg_one hf' hord'
+  refine ⟨-(f ^ 2 * b), neg_ne_zero.mpr (mul_ne_zero (pow_ne_zero 2 hf) hb0), ?_, ?_⟩
+  · rw [(placeInfty K).ord_neg, (placeInfty K).ord_mul (pow_ne_zero 2 hf) hb0, hbord,
+      add_zero, ← zpow_natCast, (placeInfty K).ord_zpow, hord]
+    norm_num
+  · conv_lhs => rw [← inv_inv f]
+    rw [(KaehlerDifferential.D K (RatFunc K)).leibniz_inv f⁻¹, hDb, inv_inv, smul_smul,
+      neg_mul]
+
+end PlaceInftySide
+section Glue
+
+variable {K : Type*} [Field K]
+
+public theorem exists_ord_zero_smul_of_smul_dX_eq {v : Place K (RatFunc K)} {π π' c c' : RatFunc K}
+    (hc : c ≠ 0) (hc' : c' ≠ 0) (hord : v.ord c' = v.ord c)
+    (hD : KaehlerDifferential.D K (RatFunc K) π = c • dX K)
+    (hD' : KaehlerDifferential.D K (RatFunc K) π' = c' • dX K) :
+    ∃ u : RatFunc K, v.ord u = 0 ∧
+      KaehlerDifferential.D K (RatFunc K) π' = u • KaehlerDifferential.D K (RatFunc K) π := by
+  refine ⟨c' / c, ?_, ?_⟩
+  · rw [div_eq_mul_inv, v.ord_mul hc' (inv_ne_zero hc), v.ord_inv, hord]
+    ring
+  · rw [hD, hD', smul_smul, div_mul_cancel₀ _ hc]
+
+end Glue
+
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable {K : Type*} [Field K] [DecidableEq (RatFunc K)]
+
+variable (K)
+
+section UnitFinite
+
+variable [HasCanonicalLocalResidueKStar K (RatFunc K)]
+    [HasCanonicalDivisor (K := K) (F := RatFunc K)]
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+variable [HasPrincipalDivisors K (RatFunc K)]
+
+@[expose] public def P1DifferentialCoeffUnitFinite {ω₀ : Ω[(RatFunc K)⁄K]} (_hω₀ : ω₀ ≠ 0) : Prop :=
+  ∀ v : Place K (RatFunc K), v ≠ placeInfty K → v.ord (v.differentialCoeff ω₀) = 0
+
+end UnitFinite
+end AlgebraicCurve
+end
+noncomputable section
+
+open TensorProduct
+
+namespace AlgebraicCurve
+
+variable (K : Type*) [Field K]
+
+
+
+
+
+attribute [scoped instance] instIsCurveOverRatFunc
+
+end AlgebraicCurve
+end
+section
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+public theorem ordDifferentialWellDefined_ratFunc_of_perfectField (K : Type*) [Field K]
+    [PerfectField K] :
+    OrdDifferentialWellDefined K (RatFunc K) := by
+  classical
+  intro v π π' hπ hπ'
+  have hπ0 : π ≠ 0 := by
+    intro h
+    rw [h, v.ord_zero] at hπ
+    exact zero_ne_one hπ
+  have hπ'0 : π' ≠ 0 := by
+    intro h
+    rw [h, v.ord_zero] at hπ'
+    exact zero_ne_one hπ'
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+  · obtain ⟨p, hp, hwp⟩ := exists_irreducible_span K w
+    obtain ⟨h1ne, h1ord⟩ :=
+      ratFuncDXCoeff_ne_zero_and_ord_eq_zero_of_ord_eq_one hp hwp
+        (PerfectField.separable_of_irreducible hp) hπ0 hπ
+    obtain ⟨h2ne, h2ord⟩ :=
+      ratFuncDXCoeff_ne_zero_and_ord_eq_zero_of_ord_eq_one hp hwp
+        (PerfectField.separable_of_irreducible hp) hπ'0 hπ'
+    exact exists_ord_zero_smul_of_smul_dX_eq h1ne h2ne (h2ord.trans h1ord.symm)
+      (D_eq_ratFuncDXCoeff_smul_dX K π) (D_eq_ratFuncDXCoeff_smul_dX K π')
+  · obtain ⟨e, he0, heord, hDe⟩ := exists_dXCoeff_ord_two_of_ord_placeInfty_eq_one hπ0 hπ
+    obtain ⟨e', he'0, he'ord, hDe'⟩ := exists_dXCoeff_ord_two_of_ord_placeInfty_eq_one hπ'0 hπ'
+    exact exists_ord_zero_smul_of_smul_dX_eq he0 he'0 (he'ord.trans heord.symm) hDe hDe'
+
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+section Profile
+
+variable (K : Type*) [Field K]
+
+theorem exists_smul_dX_eq (ω : Ω[(RatFunc K)⁄K]) : ∃ c : RatFunc K, c • dX K = ω := by
+  have hmem : ω ∈ Submodule.span (RatFunc K) {dX K} :=
+    span_dX_eq_top K ▸ Submodule.mem_top
+  exact Submodule.mem_span_singleton.mp hmem
+
+end Profile
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+section PerfectDCoord
+
+variable (K : Type*) [Field K] [PerfectField K]
+
+theorem exists_ne_zero_smul_dX_of_uniformizer (v : Place K (RatFunc K)) :
+    ∃ c : RatFunc K, c ≠ 0 ∧
+      KaehlerDifferential.D K (RatFunc K) v.uniformizer = c • dX K := by
+  classical
+  have hord : v.ord v.uniformizer = 1 := v.ord_uniformizer
+  have hpi0 : v.uniformizer ≠ 0 := v.uniformizer_ne_zero
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+  · obtain ⟨p, hp, hwp⟩ := exists_irreducible_span K w
+    obtain ⟨hne, -⟩ := ratFuncDXCoeff_ne_zero_and_ord_eq_zero_of_ord_eq_one hp hwp
+      (PerfectField.separable_of_irreducible hp) hpi0 hord
+    exact ⟨ratFuncDXCoeff K _, hne, D_eq_ratFuncDXCoeff_smul_dX K _⟩
+  · obtain ⟨e, he0, -, hDe⟩ := exists_dXCoeff_ord_two_of_ord_placeInfty_eq_one hpi0 hord
+    exact ⟨e, he0, hDe⟩
+
+namespace RationalFunctionField
+
+public scoped instance (priority := low) instDCoordGeneratesPerfectField
+    (v : Place K (RatFunc K)) :
+    v.DCoordGenerates := by
+  obtain ⟨c, hc0, hDc⟩ := exists_ne_zero_smul_dX_of_uniformizer K v
+  refine ⟨?_⟩
+  have hdc : v.dCoord = KaehlerDifferential.D K (RatFunc K) v.uniformizer := rfl
+  rw [hdc, hDc, eq_top_iff, ← span_dX_eq_top K, Submodule.span_singleton_le_iff_mem]
+  exact Submodule.mem_span_singleton.mpr
+    ⟨c⁻¹, by rw [smul_smul, inv_mul_cancel₀ hc0, one_smul]⟩
+
+end RationalFunctionField
+end PerfectDCoord
+section Profile
+
+variable (K : Type*) [Field K]
+
+section PerfectProfileValues
+
+variable [PerfectField K] [DecidableEq (RatFunc K)]
+
+public theorem p1DifferentialCoeffUnitFinite_dX_of_perfectField :
+    P1DifferentialCoeffUnitFinite K (dX_ne_zero K) := by
+  intro v hvinf
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+  · obtain ⟨p, hp, hwp⟩ := exists_irreducible_span K w
+    exact ord_differentialCoeff_dX_ofHeightOneSpectrum hp hwp
+      (PerfectField.separable_of_irreducible hp)
+  · exact absurd rfl hvinf
+
+theorem ordDifferential_dX_of_ne_placeInfty_of_perfectField {v : Place K (RatFunc K)}
+    (hv : v ≠ placeInfty K) : v.ordDifferential (dX K) = 0 := by
+  rw [Place.ordDifferential]
+  exact p1DifferentialCoeffUnitFinite_dX_of_perfectField K v hv
+
+public theorem ordDifferential_dX_placeInfty_of_perfectField :
+    (placeInfty K).ordDifferential (dX K) = -2 :=
+  ordDifferential_placeInfty_D_ratFuncX K
+    (ordDifferentialWellDefined_ratFunc_of_perfectField K)
+
+omit [DecidableEq (RatFunc K)] in
+theorem exists_divisor_smul_dX_of_perfectField {c : RatFunc K} (hc : c ≠ 0) :
+    ∃ D : Divisor K (RatFunc K),
+      (∀ v : Place K (RatFunc K), D v = v.ordDifferential (c • dX K)) ∧
+        Divisor.degree D = -2 := by
+  classical
+  obtain ⟨Dc, hDc, hDcdeg⟩ :=
+    HasPrincipalDivisors.exists_divisor (K := K) (F := RatFunc K) c hc
+  refine ⟨Dc + Finsupp.single (placeInfty K) (-2), fun v => ?_, ?_⟩
+  · rw [Finsupp.add_apply, hDc v,
+      v.ordDifferential_smul hc (v.differentialCoeff_ne_zero (dX_ne_zero K))]
+    rcases eq_or_ne v (placeInfty K) with rfl | hne
+    · rw [ordDifferential_dX_placeInfty_of_perfectField K, Finsupp.single_eq_same]
+    · rw [ordDifferential_dX_of_ne_placeInfty_of_perfectField K hne,
+        Finsupp.single_eq_of_ne hne]
+  · rw [map_add, hDcdeg, zero_add, Divisor.degree_single, deg_placeInfty K, Nat.cast_one,
+      mul_one]
+
+end PerfectProfileValues
+section PerfectInstance
+
+variable [PerfectField K]
+
+public scoped instance instHasCanonicalDivisorRatFuncPerfectField :
+    HasCanonicalDivisor (K := K) (F := RatFunc K) where
+  exists_divisor ω hω := by
+    classical
+    obtain ⟨c, hc⟩ := exists_smul_dX_eq K ω
+    have hc0 : c ≠ 0 := by
+      rintro rfl
+      rw [zero_smul] at hc
+      exact hω hc.symm
+    obtain ⟨D, hD, -⟩ := exists_divisor_smul_dX_of_perfectField K hc0
+    refine ⟨D, fun v => ?_⟩
+    rw [← hc]
+    exact hD v
+
+end PerfectInstance
+end Profile
+end AlgebraicCurve
+end
+section
+
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+section SmulReduction
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable [∀ v : Place K F, v.DCoordGenerates] [Nontrivial Ω[F⁄K]]
+
+public theorem kaehlerResidueTermKFam_smul_diagonal
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK)
+    (g : F) (ω : Ω[F⁄K]) (f : F) (v : Place K F) :
+    kaehlerResidueTermKFam Rfam (g • ω) (diagonalHom K F f) v
+      = kaehlerResidueTermKFam Rfam ω (diagonalHom K F (g * f)) v := by
+  simp only [kaehlerResidueTermKFam_apply, diagonalHom_apply]
+  rw [v.differentialCoeff_smul,
+    show f * (g * v.differentialCoeff ω) = g * f * v.differentialCoeff ω by ring]
+
+end SmulReduction
+
+end AlgebraicCurve
+
+end
+
+end
+
+end
+
+end privateSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Defs_IsogenyEndDatum_sharedLibrary.lean b/LeanPool/FLTEichlerShimura/Definitions/Defs_IsogenyEndDatum_sharedLibrary.lean
new file mode 100644
index 0000000000..63c4f503f9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Defs_IsogenyEndDatum_sharedLibrary.lean
@@ -0,0 +1,3199 @@
+/-
+Copyright (c) 2026 David Loeffler. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: David Loeffler
+
+Extracted from Prove2Me proofs by Claude (2026-09-05):
+* WeierstrassCurve.Affine.IsogenyEndDatum.exists_dualEndData_dual_mem_and_norm_eq_finrankAlong
+  (7adb32a2-3d95-5f94-8f9b-631ec0a69a45), submission
+  67b5cb36-254f-5a1b-99ed-935bbd484158.
+* WeierstrassCurve.Affine.IsogenyEndDatum.exists_restrictAlong_placeOfPoint_eq_add
+  (f8a39c1e-1459-50cb-893b-11563e5e5727), submission
+  52dbf7a5-8da4-5f91-a7ee-93f5d4b10c7e.
+-/
+
+module
+
+public import Mathlib.Algebra.Order.Ring.Star
+public import Mathlib.Analysis.Normed.Ring.Lemmas
+public import Mathlib.Order.CompletePartialOrder
+public import Mathlib.Tactic.NormNum.Prime
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FunctionFieldQuadratic
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_min_ord_le_ord_add_v2
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_addX_addY_specialize_at_place
+import LeanPool.FLTEichlerShimura.Definitions.Defs_AlgebraicCurve_residueTheorem_sharedLibrary
+
+/-!
+# Shared library for isogeny endomorphism data
+
+Common declarations from the dual-endomorphism and pointwise-addition proofs, together with
+the supporting helpers needed to make those declarations independent of either proof file.
+-/
+
+set_option maxHeartbeats 800000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+
+
+open Polynomial IsDedekindDomain IsLocalRing WithZero
+  WeierstrassCurve Affine CoordinateRing AlgebraicCurve
+
+open scoped Bivariate
+
+noncomputable section
+
+namespace WeierstrassCurve
+namespace Affine
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+
+namespace CoordinateRing
+
+theorem algebraMap_eq_mk_C_C (a : F) :
+    algebraMap F W.CoordinateRing a = CoordinateRing.mk W (C (C a)) := by
+  rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+    Algebra.algebraMap_self_apply]
+  rfl
+
+theorem eq_of_XYIdeal_eq {x₁ y₁ x₂ y₂ : F} (h₂ : W.Equation x₂ y₂)
+    (h : XYIdeal W x₁ (C y₁) = XYIdeal W x₂ (C y₂)) : x₁ = x₂ ∧ y₁ = y₂ := by
+  have hne : XYIdeal W x₂ (C y₂) ≠ ⊤ := (XYIdeal_isMaximal h₂).ne_top
+  have hX₁ : XClass W x₁ ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert _ _)
+  have hX₂ : XClass W x₂ ∈ XYIdeal W x₂ (C y₂) := Ideal.subset_span (Set.mem_insert _ _)
+  have hY₁ : YClass W (C y₁) ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  have hY₂ : YClass W (C y₂) ∈ XYIdeal W x₂ (C y₂) :=
+    Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  constructor
+  · by_contra hx
+    apply hne
+    have hsub : XClass W x₁ - XClass W x₂ = algebraMap F W.CoordinateRing (x₂ - x₁) := by
+      rw [XClass, XClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      rw [← map_sub]
+      congr 1
+      rw [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hX₁ hX₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hx hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+  · by_contra hy
+    apply hne
+    have hsub : YClass W (C y₁) - YClass W (C y₂) = algebraMap F W.CoordinateRing (y₂ - y₁) := by
+      rw [YClass, YClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      simp only [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hY₁ hY₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hy hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+
+@[expose] public def heightOneSpectrumOfEquation {x y : F} (h : W.Equation x y) :
+    HeightOneSpectrum W.CoordinateRing where
+  asIdeal := XYIdeal W x (C y)
+  isPrime := (XYIdeal_isMaximal h).isPrime
+  ne_bot := XYIdeal_ne_bot x (C y)
+
+@[scoped simp]
+theorem heightOneSpectrumOfEquation_asIdeal {x y : F} (h : W.Equation x y) :
+    (heightOneSpectrumOfEquation h).asIdeal = XYIdeal W x (C y) := rfl
+
+
+end CoordinateRing
+
+@[expose] public def IsFinitePlace (v : AlgebraicCurve.Place F W.FunctionField) : Prop :=
+  ∀ r : W.CoordinateRing, algebraMap W.CoordinateRing W.FunctionField r ∈ v.toValuationSubring
+
+def IsFinitePlace.ringHom {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    W.CoordinateRing →+* v.toValuationSubring where
+  toFun r := ⟨algebraMap W.CoordinateRing W.FunctionField r, hv r⟩
+  map_one' := Subtype.ext (map_one _)
+  map_mul' a b := Subtype.ext (map_mul _ a b)
+  map_zero' := Subtype.ext (map_zero _)
+  map_add' a b := Subtype.ext (map_add _ a b)
+
+@[scoped simp]
+theorem IsFinitePlace.coe_ringHom_apply {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) (r : W.CoordinateRing) :
+    (hv.ringHom r : W.FunctionField) = algebraMap W.CoordinateRing W.FunctionField r := rfl
+
+def IsFinitePlace.centre {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    Ideal W.CoordinateRing :=
+  (IsLocalRing.maximalIdeal v.toValuationSubring).comap hv.ringHom
+
+theorem IsFinitePlace.centre_isPrime {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre.IsPrime :=
+  Ideal.IsPrime.comap _
+
+theorem IsFinitePlace.inv_mem {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) {r : W.CoordinateRing} (hr : r ∉ hv.centre) :
+    (algebraMap W.CoordinateRing W.FunctionField r)⁻¹ ∈ v.toValuationSubring := by
+  have hunit : IsUnit (hv.ringHom r) := by
+    rw [IsFinitePlace.centre, Ideal.mem_comap, IsLocalRing.mem_maximalIdeal,
+      mem_nonunits_iff, not_not] at hr
+    exact hr
+  obtain ⟨t, ht⟩ := hunit.exists_right_inv
+  have ht' : algebraMap W.CoordinateRing W.FunctionField r * (t : W.FunctionField) = 1 := by
+    simpa using congrArg (fun a : v.toValuationSubring => (a : W.FunctionField)) ht
+  rw [inv_eq_of_mul_eq_one_right ht']
+  exact t.2
+
+theorem IsFinitePlace.centre_ne_bot {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre ≠ ⊥ := by
+  intro hbot
+  apply v.ne_top'
+  rw [eq_top_iff]
+  rintro z -
+  obtain ⟨r, s, hs, hz⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  have hs0 : s ∉ hv.centre := by
+    rw [hbot, Ideal.mem_bot]
+    exact fun h => nonZeroDivisors.ne_zero hs h
+  rw [← hz, div_eq_mul_inv]
+  exact mul_mem (hv r) (hv.inv_mem hs0)
+
+variable [IsDedekindDomain W.CoordinateRing]
+
+@[expose] public def placeOfEquation {x y : F} (h : W.Equation x y) :
+    AlgebraicCurve.Place F W.FunctionField :=
+  AlgebraicCurve.Place.ofHeightOneSpectrum (heightOneSpectrumOfEquation h)
+
+
+theorem isFinitePlace_placeOfEquation {x y : F} (h : W.Equation x y) :
+    IsFinitePlace (placeOfEquation h) := fun r =>
+  (heightOneSpectrumOfEquation h).valuation_le_one r
+
+theorem isFinitePlace_iff_exists_placeOfEquation [IsAlgClosed F]
+    (v : AlgebraicCurve.Place F W.FunctionField) :
+    IsFinitePlace v ↔ ∃ (x y : F) (h : W.Equation x y), v = placeOfEquation h := by
+  constructor
+  · intro hv
+    have := hv.centre_isPrime
+    have hmax : hv.centre.IsMaximal := Ideal.IsPrime.isMaximal hv.centre_isPrime hv.centre_ne_bot
+    obtain ⟨x, y, hxy, hXY⟩ :=
+      CoordinateRing.exists_eq_XYIdeal (W := W) (P := hv.centre) hv.centre_ne_bot
+    refine ⟨x, y, hxy, ?_⟩
+    set w : HeightOneSpectrum W.CoordinateRing := heightOneSpectrumOfEquation hxy with hw
+    set A : ValuationSubring W.FunctionField :=
+      HeightOneSpectrum.valuationSubringAtPrime W.FunctionField w with hA
+    have hAded : IsDedekindDomain A := by rw [hA]; infer_instance
+    have hle : A ≤ v.toValuationSubring := by
+      intro z hz
+      rw [hA] at hz
+      obtain ⟨r, s, hs, rfl⟩ := hz
+      have hs' : s ∉ hv.centre := by
+        intro hmem
+        rw [hXY] at hmem
+        exact hs hmem
+      exact mul_mem (hv r) (hv.inv_mem hs')
+    have hSP : A.ofPrime (A.idealOfLE v.toValuationSubring hle) = v.toValuationSubring :=
+      ValuationSubring.ofPrime_idealOfLE A v.toValuationSubring hle
+    rcases eq_or_ne (A.idealOfLE v.toValuationSubring hle) ⊥ with hP | hP
+    · exfalso
+      apply v.ne_top'
+      have h2 : A.ofPrime ⊥ ≤ A.ofPrime (A.idealOfLE v.toValuationSubring hle) :=
+        ValuationSubring.ofPrime_le_of_le (h := hP.le)
+      rw [ValuationSubring.ofPrime_bot] at h2
+      exact top_le_iff.mp (le_trans h2 hSP.le)
+    · have hPmax : (A.idealOfLE v.toValuationSubring hle).IsMaximal :=
+        Ideal.IsPrime.isMaximal inferInstance hP
+      have hPeq : A.idealOfLE v.toValuationSubring hle = IsLocalRing.maximalIdeal A :=
+        IsLocalRing.eq_maximalIdeal hPmax
+      have h3 : A.ofPrime (A.idealOfLE v.toValuationSubring hle)
+          = A.ofPrime (IsLocalRing.maximalIdeal A) :=
+        le_antisymm (ValuationSubring.ofPrime_le_of_le (h := hPeq.ge))
+          (ValuationSubring.ofPrime_le_of_le (h := hPeq.le))
+      rw [ValuationSubring.ofPrime_top] at h3
+      have hAv : A = v.toValuationSubring := h3.symm.trans hSP
+      refine (AlgebraicCurve.Place.ext ?_).symm
+      change (AlgebraicCurve.Place.ofHeightOneSpectrum w).toValuationSubring = v.toValuationSubring
+      rw [AlgebraicCurve.Place.ofHeightOneSpectrum_toValuationSubring,
+        ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact hAv
+  · rintro ⟨x, y, h, rfl⟩
+    exact isFinitePlace_placeOfEquation h
+
+public scoped instance S13_instIsDedekindDomainCoordinateRing [IsAlgClosed F] [W.IsElliptic] :
+    IsDedekindDomain W.CoordinateRing :=
+  CoordinateRing.isDedekindDomain (W := W)
+
+section CentredGate
+
+variable [DecidableEq F] [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W]
+
+omit [DecidableEq F] in
+@[scoped simp]
+public theorem placeOfPoint_some {x y : F} (h : W.Nonsingular x y) :
+    placeOfPoint (.some x y h) = placeOfEquation h.left := by
+  classical
+  exact
+    placeOfPoint_some_eq_ofHeightOneSpectrum h (heightOneSpectrumOfEquation h.left) rfl
+
+namespace InfinitePlace
+
+@[expose] public def place : AlgebraicCurve.Place F W.FunctionField := placeOfPoint (0 : W.Point)
+
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] in
+public theorem not_isFinitePlace [IsAlgClosed F] [W.IsElliptic] :
+    ¬ IsFinitePlace (place : AlgebraicCurve.Place F W.FunctionField) := by
+  classical
+  exact
+    fun h =>
+     algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero (W := W) (h _)
+
+omit [DecidableEq F] in
+theorem eq_of_not_isFinitePlace
+    (v : AlgebraicCurve.Place F W.FunctionField) (hv : ¬ IsFinitePlace v) :
+    v = place := by
+  classical
+  obtain ⟨P, rfl⟩ : ∃ P : W.Point, placeOfPoint P = v :=
+    ⟨(pointEquivPlace (W := W)).symm v, (pointEquivPlace (W := W)).apply_symm_apply v⟩
+  cases P with
+  | zero => rfl
+  | some x y h =>
+      exact absurd (placeOfPoint_some (W := W) h ▸ isFinitePlace_placeOfEquation h.left) hv
+
+end InfinitePlace
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+@[scoped simp]
+theorem placeOfPoint_zero : placeOfPoint (.zero : W.Point) = InfinitePlace.place := by
+  classical
+  exact
+    rfl
+
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+public theorem placeOfPoint_injective : Function.Injective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).injective
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+public theorem placeOfPoint_surjective (_hΔ : W.Δ ≠ 0) :
+    Function.Surjective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).surjective
+
+
+end CentredGate
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+namespace Affine
+
+section AutoNorm
+
+variable {F : Type*} [Field F] [CharZero F] {V W : Affine F}
+
+public theorem normFormulaAlong_of_elliptic (ι : V.FunctionField →ₐ[F] W.FunctionField)
+    (hfin : FiniteAlong F ι) : NormFormulaAlong F ι hfin := by
+  classical
+  have : HasPrincipalDivisors F W.FunctionField := hasPrincipalDivisors_functionField W
+  have : CharZero V.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap F V.FunctionField).injective
+  have hsep : SeparableAlong F ι := by
+    let := algebraAlong ι
+    have := isScalarTower_along ι
+    have : Module.Finite V.FunctionField W.FunctionField := hfin
+    change Algebra.IsSeparable V.FunctionField W.FunctionField
+    infer_instance
+  exact AlgebraicCurve.normFormulaAlong ι hfin hsep
+
+end AutoNorm
+
+namespace IsogenyEndDatum
+open WeierstrassCurve.Affine.IsogenyEndDatum
+
+variable {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [GenusOnePlaceGate W] [AbelTheorem W]
+
+omit [DecidableEq F] [W.GenusOnePlaceGate] [W.AbelTheorem] in
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+public theorem normFormulaAlong_auto (D :
+  IsogenyEndDatum W) :
+    NormFormulaAlong F D.ι D.hfin :=
+  normFormulaAlong_of_elliptic D.ι D.hfin
+
+@[expose] public def pointEnd' (D : IsogenyEndDatum
+  W) :
+    AddMonoid.End W.Point := D.pointEnd D.normFormulaAlong_auto
+
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+public theorem pointEnd'_apply (D : IsogenyEndDatum W) (P : W.Point) :
+    D.pointEnd' P = genusOnePic0Equiv W
+      (Pic0.pushforwardAlongHom D.ι D.hι D.hfin D.normFormulaAlong_auto (pointClass P)) :=
+  pointEnd_apply D _ P
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+public theorem pointEnd'_eq_of_seam (D : IsogenyEndDatum W) (g : W.Point → W.Point) (hg0 : g 0 = 0)
+    (hg : ∀ P, (placeOfPoint P).restrictAlong D.ι D.hι = placeOfPoint (g P)) (P : W.Point) :
+    D.pointEnd' P = g P :=
+  pointEnd_eq_of_seam D _ g hg0 hg P
+
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+
+section
+
+section
+
+universe u
+
+namespace WeierstrassCurve
+namespace Affine
+
+variable {F : Type u} [Field F]
+
+theorem exists_algebraMap_eq_of_isAlgebraic [IsAlgClosed F] {L : Type u} [Field L] [Algebra F L]
+    {z : L} (hz : IsAlgebraic F z) : ∃ c : F, algebraMap F L c = z := by
+  have hint : _root_.IsIntegral F z := hz.isIntegral
+  have hdeg : (minpoly F z).degree = 1 :=
+    IsAlgClosed.degree_eq_one_of_irreducible F (minpoly.irreducible hint)
+  exact minpoly.degree_eq_one_iff.mp hdeg
+
+end Affine
+end WeierstrassCurve
+end
+end
+
+section
+
+section
+
+namespace AlgebraicCurve
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+public theorem evalAt_add (hv : v.IsRational) {f g : F} (hf : f ∈
+  v.toValuationSubring)
+    (hg : g ∈ v.toValuationSubring) :
+    v.evalAt (f + g) = v.evalAt f + v.evalAt g := by
+  apply v.algebraMap_residueField_injective
+  rw [map_add, v.algebraMap_evalAt hv (add_mem hf hg), v.algebraMap_evalAt hv hf,
+    v.algebraMap_evalAt hv hg, ← map_add]
+  rfl
+
+theorem evalAt_neg (hv : v.IsRational) {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    v.evalAt (-f) = -v.evalAt f := by
+  apply v.algebraMap_residueField_injective
+  rw [_root_.map_neg, v.algebraMap_evalAt hv (neg_mem hf), v.algebraMap_evalAt hv hf, ←
+    _root_.map_neg]
+  rfl
+
+public theorem evalAt_sub (hv : v.IsRational) {f g : F} (hf : f ∈
+  v.toValuationSubring)
+    (hg : g ∈ v.toValuationSubring) :
+    v.evalAt (f - g) = v.evalAt f - v.evalAt g := by
+  rw [sub_eq_add_neg, v.evalAt_add hv hf (neg_mem hg), v.evalAt_neg hv hg, sub_eq_add_neg]
+
+end Place
+end AlgebraicCurve
+
+end
+end
+
+section
+
+namespace ModularCurve
+
+universe u
+
+section Foundation
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+public abbrev KwIsogenyEndAddDatumSupply : Prop :=
+  ∀ D₁ D₂ : IsogenyEndDatum W, D₁.pointEnd' + D₂.pointEnd' ≠ 0 →
+    ∃ D₃ : IsogenyEndDatum W, D₃.pointEnd' = D₁.pointEnd' + D₂.pointEnd'
+
+end Foundation
+end ModularCurve
+end
+
+section
+
+section
+
+namespace WeierstrassCurve
+namespace Affine
+
+universe u
+
+variable {F : Type u} [Field F] {W : Affine F} [W.IsElliptic]
+
+theorem isElliptic_Δ_ne_zero : W.Δ ≠ 0 := W.coe_Δ' ▸ W.Δ'.ne_zero
+
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+namespace WeierstrassCurve
+namespace Affine
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+public theorem Δ_ne_zero_of_isElliptic : W.Δ ≠ 0 := W.isUnit_Δ.ne_zero
+
+@[expose] public def placeOfPointEquiv : W.Point ≃ AlgebraicCurve.Place F W.FunctionField :=
+  Equiv.ofBijective placeOfPoint
+    ⟨placeOfPoint_injective, placeOfPoint_surjective (Δ_ne_zero_of_isElliptic W)⟩
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+public theorem placeOfPoint_placeOfPointEquiv_symm (w : AlgebraicCurve.Place F W.FunctionField) :
+    placeOfPoint ((placeOfPointEquiv W).symm w) = w :=
+  (placeOfPointEquiv W).apply_symm_apply w
+
+namespace IsogenyEndDatum
+open WeierstrassCurve.Affine.IsogenyEndDatum
+
+variable {W}
+
+@[expose] public def geomMorph (D : IsogenyEndDatum
+  W) :
+    W.Point → W.Point :=
+  fun P => (placeOfPointEquiv W).symm ((placeOfPoint P).restrictAlong D.ι D.hι)
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+public theorem placeOfPoint_geomMorph (D :
+  IsogenyEndDatum W) (P : W.Point) :
+    (placeOfPoint P).restrictAlong D.ι D.hι = placeOfPoint (D.geomMorph P) :=
+  (placeOfPoint_placeOfPointEquiv_symm W _).symm
+
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+namespace AlgebraicCurve
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+public theorem restrictAlong_comp (φ ψ : F →ₐ[K] F) (hφ : φ.toRingHom.IsIntegral)
+    (hψ : ψ.toRingHom.IsIntegral) (hcomp : (ψ.comp φ).toRingHom.IsIntegral)
+    (w : Place K F) :
+    w.restrictAlong (ψ.comp φ) hcomp = (w.restrictAlong ψ hψ).restrictAlong φ hφ := by
+  refine Place.ext (SetLike.ext fun x => ?_)
+  exact Iff.rfl
+
+end Place
+end AlgebraicCurve
+
+end
+
+section
+
+section
+
+namespace ModularCurve
+namespace Mmr48
+
+universe u
+
+section PointCongr
+
+variable {R : Type u} [CommRing R] {V : WeierstrassCurve.Affine R}
+
+theorem mmr48_sp_point_some_congr {x₁ y₁ x₂ y₂ : R} (hx : x₁ = x₂) (hy : y₁ = y₂)
+    (h₁ : V.Nonsingular x₁ y₁) (h₂ : V.Nonsingular x₂ y₂) :
+    (Point.some x₁ y₁ h₁ : V.Point) = Point.some x₂ y₂ h₂ := by
+  subst hx; subst hy; rfl
+
+end PointCongr
+end Mmr48
+end ModularCurve
+end
+end
+
+section
+
+section
+
+namespace ModularCurve
+namespace Mmr72
+
+universe u
+
+section CofiniteEngine
+
+theorem mmr72_pp_end_eq_zero_of_cofinite_const {M : Type*} [AddCommGroup M]
+    [Infinite M] (S : AddMonoid.End M) (v : M)
+    (hfin : {P : M | S P ≠ v}.Finite) :
+    S = 0 := by
+  have _pin := Classical.em True
+  refine DFunLike.ext _ _ fun P => ?_
+  have hinj : Function.Injective fun R : M => P + R := fun a b h =>
+    add_left_cancel h
+  have hpre : ((fun R : M => P + R) ⁻¹' {Q : M | S Q ≠ v}).Finite :=
+    Set.Finite.preimage hinj.injOn hfin
+  obtain ⟨Q', hQ'⟩ :=
+    (Set.Finite.infinite_compl (hfin.union hpre)).nonempty
+  simp only [Set.mem_compl_iff, Set.mem_union, Set.mem_ofPred_eq,
+    Set.mem_preimage, not_or, not_not] at hQ'
+  have hadd : S (P + Q') = S P + S Q' := map_add S P Q'
+  rw [hQ'.2, hQ'.1] at hadd
+  change S P = 0
+  grind
+
+end CofiniteEngine
+end Mmr72
+end ModularCurve
+end
+end
+
+section
+
+
+
+
+namespace AlgebraicCurve
+
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+public theorem isRational_of_deg_eq_one (h : v.deg = 1) :
+    v.IsRational := by
+  intro x
+  have hbot : (⊥ : Subalgebra K v.ResidueField) = ⊤ :=
+    Subalgebra.bot_eq_top_iff_finrank_eq_one.mpr h
+  have hx : x ∈ (⊥ : Subalgebra K v.ResidueField) := by
+    rw [hbot]
+    exact Algebra.mem_top
+  exact Algebra.mem_bot.mp hx
+
+end Place
+
+end AlgebraicCurve
+end
+
+section
+
+namespace WeierstrassCurve
+namespace Affine
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+namespace IsogenyEndDatum
+open WeierstrassCurve.Affine.IsogenyEndDatum
+
+variable {W}
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem pushforwardAlongDegZero_pointDivisor_geomMorph (D : IsogenyEndDatum W)
+    (P : W.Point) :
+    Pic0.pushforwardAlongDegZero D.ι D.hι (pointDivisor P)
+      = pointDivisor (D.geomMorph P) - pointDivisor (D.geomMorph 0) := by
+  refine Subtype.ext ?_
+  rw [Pic0.coe_pushforwardAlongDegZero, coe_pointDivisor, map_sub,
+    pushforwardAlong_single_eq D.ι D.hι, pushforwardAlong_single_eq D.ι D.hι,
+    D.placeOfPoint_geomMorph P, D.placeOfPoint_geomMorph 0]
+  push_cast
+  rw [coe_pointDivisor, coe_pointDivisor, sub_sub_sub_cancel_right]
+
+omit [DecidableEq F] [IsAlgClosed F] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem pushforwardAlongHom_pointClass_eq_sub (D : IsogenyEndDatum W) (P : W.Point) :
+    Pic0.pushforwardAlongHom D.ι D.hι D.hfin (normFormulaAlong_of_elliptic D.ι D.hfin)
+        (pointClass P)
+      = pointClass (D.geomMorph P) - pointClass (D.geomMorph 0) := by
+  change Pic0.pushforwardAlongHom D.ι D.hι D.hfin _ (Pic0.mk (pointDivisor P))
+      = Pic0.mk (pointDivisor (D.geomMorph P)) - Pic0.mk (pointDivisor (D.geomMorph 0))
+  rw [Pic0.pushforwardAlongHom_mk, pushforwardAlongDegZero_pointDivisor_geomMorph D P]
+  rfl
+
+omit [IsAlgClosed F] [GenusOnePlaceGate.IsCentred W] in
+public theorem
+  pointEnd_eq_geomMorph_sub_geomMorph_zero (D :
+  IsogenyEndDatum W) (P : W.Point) :
+    D.pointEnd' P = D.geomMorph P - D.geomMorph 0 := by
+  rw [IsogenyEndDatum.pointEnd'_apply, pushforwardAlongHom_pointClass_eq_sub D P, map_sub,
+    genusOnePic0Equiv_apply, genusOnePic0Equiv_apply, pic0ToPoint_pointClass,
+    pic0ToPoint_pointClass]
+
+
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+namespace WeierstrassCurve
+namespace Affine
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+variable (v : AlgebraicCurve.Place F W.FunctionField)
+
+theorem isFinitePlace_of_mem
+    (hx : polyToFunctionField W X ∈ v.toValuationSubring) : IsFinitePlace v := by
+  have hpoly : ∀ p : F[X], polyToFunctionField W p ∈ v.toValuationSubring := by
+    intro p
+    induction p using Polynomial.induction_on' with
+    | add f g hf hg => rw [map_add]; exact add_mem hf hg
+    | monomial n c =>
+        rw [← C_mul_X_pow_eq_monomial, map_mul, map_pow]
+        refine mul_mem ?_ (pow_mem hx n)
+        rw [polyToFunctionField_C]
+        exact v.algebraMap_mem' c
+  set η := algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) with hηdef
+  set c₁ : F[X] := C W.a₁ * X + C W.a₃ with hc₁def
+  set cb : F[X] := X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ with hcbdef
+  have hrel : η * η = polyToFunctionField W cb - polyToFunctionField W c₁ * η := by
+    have h1 := smul_basis_mul_Y (W' := W) 0 1
+    rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at h1
+    have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) h1
+    rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+    exact h2
+  have hy : η ∈ v.toValuationSubring := by
+    refine v.mem_of_eval_monic_eq_zero (P := Polynomial.X ^ 2
+      + (Polynomial.C (polyToFunctionField W c₁) * Polynomial.X
+        - Polynomial.C (polyToFunctionField W cb))) ?_ ?_ (x := η) ?_
+    · refine Polynomial.monic_X_pow_add (n := 2) ?_
+      rw [sub_eq_add_neg, ← Polynomial.C_neg]
+      refine lt_of_le_of_lt Polynomial.degree_linear_le ?_
+      exact_mod_cast Nat.one_lt_two
+    · intro i
+      rw [show (Polynomial.C (polyToFunctionField W c₁) * Polynomial.X : Polynomial _)
+          = Polynomial.C (polyToFunctionField W c₁) * Polynomial.X ^ 1 by ring]
+      simp only [Polynomial.coeff_add, Polynomial.coeff_sub, Polynomial.coeff_X_pow,
+        Polynomial.coeff_C_mul, Polynomial.coeff_C]
+      refine add_mem ?_ (sub_mem ?_ ?_)
+      · split <;> simp [v.toValuationSubring.one_mem, v.toValuationSubring.zero_mem]
+      · split
+        · rw [mul_one]; exact hpoly _
+        · rw [mul_zero]; exact v.toValuationSubring.zero_mem
+      · split
+        · exact hpoly _
+        · exact v.toValuationSubring.zero_mem
+    · simp only [Polynomial.eval_add, Polynomial.eval_sub, Polynomial.eval_pow,
+        Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_X]
+      rw [sq]
+      linear_combination hrel
+  intro r
+  obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq r
+  rw [algebraMap_smul_basis]
+  exact add_mem (hpoly p) (mul_mem (hpoly q) hy)
+
+public theorem ord_X_neg_of_not_isFinitePlace (hv : ¬ IsFinitePlace v) :
+    v.ord (polyToFunctionField W X) < 0 := by
+  by_contra hcon
+  push Not at hcon
+  exact hv (isFinitePlace_of_mem v
+    (AlgebraicCurve.Place.mem_of_ord_nonneg v (polyToFunctionField_ne_zero Polynomial.X_ne_zero)
+      hcon))
+
+theorem exists_equation [IsAlgClosed F] (W : Affine F) (x₀ : F) :
+    ∃ y₀ : F, W.Equation x₀ y₀ := by
+  set P : F[X] := Polynomial.X ^ 2 + Polynomial.C (W.a₁ * x₀ + W.a₃) * Polynomial.X
+    - Polynomial.C (x₀ ^ 3 + W.a₂ * x₀ ^ 2 + W.a₄ * x₀ + W.a₆) with hPdef
+  have hPdeg : P.degree ≠ 0 := by
+    have hcoeff : P.coeff 2 = 1 := by
+      rw [hPdef]
+      simp only [Polynomial.coeff_sub, Polynomial.coeff_add, Polynomial.coeff_X_pow,
+        Polynomial.coeff_C_mul, Polynomial.coeff_X, Polynomial.coeff_C]
+      norm_num
+    intro hcon
+    have h2 : P.coeff 2 = 0 := by
+      refine Polynomial.coeff_eq_zero_of_degree_lt ?_
+      rw [hcon]
+      norm_num
+    rw [hcoeff] at h2
+    exact one_ne_zero h2
+  obtain ⟨y₀, hy₀⟩ := IsAlgClosed.exists_root P hPdeg
+  refine ⟨y₀, ?_⟩
+  rw [equation_iff]
+  have h3 : P.eval y₀ = 0 := hy₀
+  rw [hPdef] at h3
+  simp only [Polynomial.eval_sub, Polynomial.eval_add, Polynomial.eval_pow,
+    Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_X] at h3
+  linear_combination h3
+
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+namespace ModularCurve
+
+universe u
+
+section GeomMorphWire
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+public abbrev KwIsogenyEndAddGeomMorphSupply : Prop :=
+  ∀ D₁ D₂ : IsogenyEndDatum W, D₁.pointEnd' + D₂.pointEnd' ≠ 0 →
+    ∃ D₃ : IsogenyEndDatum W, ∀ P : W.Point,
+      D₃.geomMorph P = D₁.geomMorph P + D₂.geomMorph P
+
+omit [IsAlgClosed F] [GenusOnePlaceGate.IsCentred W] in
+theorem kw_isogenyEndAddDatumSupply_of_addGeomMorphSupply
+    (hgm : KwIsogenyEndAddGeomMorphSupply W) :
+    KwIsogenyEndAddDatumSupply W := by
+  intro D₁ D₂ h0
+  obtain ⟨D₃, hD₃⟩ := hgm D₁ D₂ h0
+  refine ⟨D₃, AddMonoidHom.ext fun P => ?_⟩
+  change D₃.pointEnd' P = D₁.pointEnd' P + D₂.pointEnd' P
+  rw [D₃.pointEnd_eq_geomMorph_sub_geomMorph_zero P,
+    D₁.pointEnd_eq_geomMorph_sub_geomMorph_zero P,
+    D₂.pointEnd_eq_geomMorph_sub_geomMorph_zero P, hD₃ P, hD₃ 0]
+  abel
+
+end GeomMorphWire
+end ModularCurve
+end
+
+section
+
+namespace AlgebraicCurve
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+
+theorem Place.mem_restrictAlong_iff (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') (f : F) :
+    f ∈ (w.restrictAlong φ hφ).toValuationSubring ↔ φ f ∈ w.toValuationSubring :=
+  Iff.rfl
+
+theorem Place.ramificationIndexAlong_pos (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') : 0 < Place.ramificationIndexAlong φ w := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  exact w.ramificationIndex_pos
+
+theorem Place.ord_restrictAlong_ne_zero_iff (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') (f : F) :
+    (w.restrictAlong φ hφ).ord f ≠ 0 ↔ w.ord (φ f) ≠ 0 := by
+  rw [w.ord_restrictAlong φ hφ f]
+  have hpos := Place.ramificationIndexAlong_pos φ hφ w
+  constructor
+  · intro h hcon
+    rcases mul_eq_zero.mp hcon with h1 | h1
+    · omega
+    · exact h h1
+  · intro h hcon
+    exact h (by rw [hcon, mul_zero])
+
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+namespace Affine
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+public theorem algebraMap_polynomial_eq_mk_C (p : F[X]) :
+    algebraMap F[X] W.CoordinateRing p = CoordinateRing.mk W (C p) :=
+  rfl
+
+theorem algebraMap_coordinateRing_ne_zero {r : W.CoordinateRing} (hr : r ≠ 0) :
+    algebraMap W.CoordinateRing W.FunctionField r ≠ 0 :=
+  (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr hr
+
+theorem mk_mem_XYIdeal_iff {x y : F} (h : W.Equation x y) (P : F[X][Y]) :
+    CoordinateRing.mk W P ∈ XYIdeal W x (C y) ↔ P.evalEval x y = 0 := by
+  have hmap : XYIdeal W x (C y)
+      = Ideal.map (CoordinateRing.mk W) (Ideal.span {C (X - C x), Y - C (C y)}) := by
+    rw [Ideal.map_span, Set.image_pair]
+    rfl
+  rw [hmap]
+  constructor
+  · intro hP
+    obtain ⟨Q, hQ, hQP⟩ := (Ideal.mem_map_iff_of_surjective _ AdjoinRoot.mk_surjective).mp hP
+    obtain ⟨c, hc⟩ := AdjoinRoot.mk_eq_mk.mp hQP
+    have hQ0 : Q.evalEval x y = 0 :=
+      mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero.mp hQ
+    have hW0 : W.polynomial.evalEval x y = 0 := h
+    have hPQ : P = Q - W.polynomial * c := by rw [← hc]; ring
+    rw [hPQ]
+    simp only [evalEval, eval_sub, eval_mul] at hQ0 hW0 ⊢
+    rw [hQ0, hW0, zero_mul, sub_zero]
+  · intro hP
+    exact Ideal.mem_map_of_mem _ (mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero.mpr hP)
+
+theorem ord_placeOfEquation_ne_zero_iff [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) {r : W.CoordinateRing} (hr : r ≠ 0) :
+    (placeOfEquation h).ord (algebraMap W.CoordinateRing W.FunctionField r) ≠ 0
+      ↔ r ∈ XYIdeal W x (C y) := by
+  rw [placeOfEquation, Place.ord_ofHeightOneSpectrum_ne_zero_iff _ hr,
+    heightOneSpectrumOfEquation_asIdeal]
+
+public theorem ord_placeOfEquation_nonneg [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) (r : W.CoordinateRing) :
+    0 ≤ (placeOfEquation h).ord (algebraMap W.CoordinateRing W.FunctionField r) :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem (placeOfEquation h) (isFinitePlace_placeOfEquation h r)
+
+theorem ord_placeOfEquation_pos_iff [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) {r : W.CoordinateRing} (hr : r ≠ 0) :
+    0 < (placeOfEquation h).ord (algebraMap W.CoordinateRing W.FunctionField r)
+      ↔ r ∈ XYIdeal W x (C y) := by
+  rw [← ord_placeOfEquation_ne_zero_iff h hr]
+  have := ord_placeOfEquation_nonneg h r
+  omega
+
+theorem IsFinitePlace.mem_centre_iff_ord_ne_zero {v : Place F W.FunctionField}
+    (hv : IsFinitePlace v) {r : W.CoordinateRing} (hr : r ≠ 0) :
+    r ∈ hv.centre ↔ v.ord (algebraMap W.CoordinateRing W.FunctionField r) ≠ 0 := by
+  have hr' : algebraMap W.CoordinateRing W.FunctionField r ≠ 0 :=
+    algebraMap_coordinateRing_ne_zero hr
+  rw [IsFinitePlace.centre, Ideal.mem_comap, IsLocalRing.mem_maximalIdeal, mem_nonunits_iff,
+    ne_eq, v.ord_eq_zero_iff_adicValuation_eq_one hr']
+  exact not_congr (v.adicValuation_coe_eq_one_iff (hv.ringHom r)).symm
+
+theorem centre_placeOfEquation [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) :
+    (isFinitePlace_placeOfEquation h).centre = XYIdeal W x (C y) := by
+  ext r
+  rcases eq_or_ne r 0 with rfl | hr
+  · simp only [Submodule.zero_mem]
+  rw [(isFinitePlace_placeOfEquation h).mem_centre_iff_ord_ne_zero hr,
+    ord_placeOfEquation_ne_zero_iff h hr]
+
+theorem eq_placeOfEquation_of_le_centre [IsAlgClosed F] [IsDedekindDomain W.CoordinateRing]
+    {v : Place F W.FunctionField} (hv : IsFinitePlace v) {x y : F} (h : W.Equation x y)
+    (hle : XYIdeal W x (C y) ≤ hv.centre) : v = placeOfEquation h := by
+  obtain ⟨x', y', h', hveq⟩ := (isFinitePlace_iff_exists_placeOfEquation v).mp hv
+  subst hveq
+  have hc : hv.centre = XYIdeal W x' (C y') := by
+    rw [Subsingleton.elim hv (isFinitePlace_placeOfEquation h')]
+    exact centre_placeOfEquation h'
+  rw [hc] at hle
+  have heq : XYIdeal W x (C y) = XYIdeal W x' (C y') :=
+    (CoordinateRing.XYIdeal_isMaximal h).eq_of_le (CoordinateRing.XYIdeal_isMaximal h').ne_top
+      hle
+  obtain ⟨rfl, rfl⟩ := CoordinateRing.eq_of_XYIdeal_eq h' heq
+  rfl
+
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+namespace Affine
+
+variable {F : Type*} [Field F] (W : Affine F)
+
+variable {W}
+
+@[expose] public def yGen (W : Affine F) : W.FunctionField :=
+  algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+
+section OrdAtPoint
+
+variable [IsDedekindDomain W.CoordinateRing]
+
+public theorem ord_polyToFunctionField_pos_iff {x y : F} (h : W.Equation x y) {p : F[X]}
+    (hp : p ≠ 0) :
+    0 < (placeOfEquation h).ord (polyToFunctionField W p) ↔ p.eval x = 0 := by
+  rw [polyToFunctionField_apply, algebraMap_polynomial_eq_mk_C,
+    ord_placeOfEquation_pos_iff h (fun hcon => polyToFunctionField_ne_zero hp
+      (by rw [polyToFunctionField_apply, algebraMap_polynomial_eq_mk_C, hcon, _root_.map_zero])),
+    mk_mem_XYIdeal_iff h, Polynomial.evalEval_C]
+
+end OrdAtPoint
+end Affine
+end WeierstrassCurve
+
+end
+
+section
+
+universe u r s v
+
+namespace WeierstrassCurve
+
+variable {F : Type u} [Field F] [IsAlgClosed F] (W : WeierstrassCurve F) [W.IsElliptic]
+
+public lemma point_infinite : Infinite W.toAffine.Point := by
+  refine Infinite.of_injective
+    (fun x : F => Affine.Point.some x (WeierstrassCurve.Affine.exists_equation W x).choose
+      ((Affine.equation_iff_nonsingular (W := W)).mp (WeierstrassCurve.Affine.exists_equation W
+        x).choose_spec))
+    fun x x' hxx' => ?_
+  exact (Affine.Point.some.inj hxx').1
+
+end WeierstrassCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+theorem ord_sub_evalAt_pos (hrat : v.IsRational) {f : F}
+    (hf : f ∈ v.toValuationSubring)
+    (hne : f - algebraMap K F (v.evalAt f) ≠ 0) :
+    0 < v.ord (f - algebraMap K F (v.evalAt f)) := by
+  have hmem : f - algebraMap K F (v.evalAt f) ∈ v.toValuationSubring :=
+    sub_mem hf (v.algebraMap_mem' _)
+  rcases eq_or_ne (v.ord (f - algebraMap K F (v.evalAt f))) 0 with h0 | h0
+  · exfalso
+    refine v.evalAt_ne_zero hrat hne h0 ?_
+    have hres : algebraMap K v.ResidueField
+        (v.evalAt (f - algebraMap K F (v.evalAt f))) = 0 := by
+      rw [v.algebraMap_evalAt hrat hmem]
+      have hcoe : (⟨f - algebraMap K F (v.evalAt f), hmem⟩ : v.toValuationSubring)
+          = ⟨f, hf⟩ - algebraMap K v.toValuationSubring (v.evalAt f) := by
+        refine Subtype.ext ?_
+        change f - algebraMap K F (v.evalAt f)
+          = f - (algebraMap K v.toValuationSubring (v.evalAt f) : F)
+        rw [Place.coe_algebraMap]
+      rw [hcoe, map_sub, sub_eq_zero, ← v.algebraMap_evalAt hrat hf,
+        IsScalarTower.algebraMap_apply K v.toValuationSubring v.ResidueField,
+        IsLocalRing.ResidueField.algebraMap_eq]
+    exact (map_eq_zero_iff _ (algebraMap K v.ResidueField).injective).mp hres
+  · have hnonneg := AlgebraicCurve.Place.ord_nonneg_of_mem v hmem
+    omega
+
+end Place
+end AlgebraicCurve
+end
+
+section
+
+section
+
+universe u
+
+namespace WeierstrassCurve
+namespace Affine
+
+variable {F : Type u} [Field F]
+
+section PointPullback
+
+variable {W : Affine F}
+
+local notation "ι" => algebraMap F W.FunctionField
+
+public theorem eval₂_polynomial_of_equation_map {xP yP : W.FunctionField}
+    (h : (W.map ι).toAffine.Equation xP yP) :
+    W.polynomial.eval₂
+      (Polynomial.aeval xP : F[X] →ₐ[F] W.FunctionField).toRingHom yP = 0 := by
+  rw [equation_iff'] at h
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆] at h
+  simp only [WeierstrassCurve.Affine.polynomial, eval₂_add, eval₂_sub, eval₂_mul, eval₂_pow,
+    eval₂_X, eval₂_C, AlgHom.toRingHom_eq_coe, RingHom.coe_coe, map_add, map_mul, map_pow,
+    Polynomial.aeval_C, Polynomial.aeval_X]
+  linear_combination h
+
+@[expose] public def pointPullbackCoordHom {xP yP : W.FunctionField}
+    (h : (W.map ι).toAffine.Equation xP yP) :
+    W.CoordinateRing →ₐ[F] W.FunctionField where
+  __ := AdjoinRoot.lift
+    (Polynomial.aeval xP : F[X] →ₐ[F] W.FunctionField).toRingHom
+    yP (eval₂_polynomial_of_equation_map h)
+  commutes' c := by
+    change AdjoinRoot.lift _ _ (eval₂_polynomial_of_equation_map h) (algebraMap F _ c)
+      = algebraMap F W.FunctionField c
+    rw [CoordinateRing.algebraMap_eq_mk_C_C, AdjoinRoot.lift_mk, eval₂_C]
+    exact Polynomial.aeval_C _ c
+
+theorem pointPullbackCoordHom_mk {xP yP : W.FunctionField}
+    (h : (W.map ι).toAffine.Equation xP yP) (g : F[X][Y]) :
+    pointPullbackCoordHom h (CoordinateRing.mk W g)
+      = g.eval₂ (Polynomial.aeval xP : F[X] →ₐ[F] W.FunctionField).toRingHom yP :=
+  AdjoinRoot.lift_mk (eval₂_polynomial_of_equation_map h) g
+
+theorem pointPullbackCoordHom_comp_algebraMap {xP yP : W.FunctionField}
+    (h : (W.map ι).toAffine.Equation xP yP) :
+    (pointPullbackCoordHom h).toRingHom.comp (algebraMap F[X] W.CoordinateRing)
+      = (Polynomial.aeval xP : F[X] →ₐ[F] W.FunctionField).toRingHom := by
+  refine RingHom.ext fun p => ?_
+  change pointPullbackCoordHom h (algebraMap F[X] _ p) = _
+  rw [algebraMap_polynomial_eq_mk_C, pointPullbackCoordHom_mk, eval₂_C]
+
+public theorem pointPullbackCoordHom_injective {xP yP : W.FunctionField}
+    (h : (W.map ι).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    Function.Injective (pointPullbackCoordHom h) := by
+  have hker : RingHom.ker (pointPullbackCoordHom h).toRingHom = ⊥ := by
+    have : Module.Finite F[X] W.CoordinateRing :=
+      Module.Finite.of_basis (CoordinateRing.basis W)
+    refine Ideal.eq_bot_of_under_eq_bot (R := F[X]) ?_
+    rw [Ideal.under_def, RingHom.comap_ker, pointPullbackCoordHom_comp_algebraMap,
+      ← RingHom.injective_iff_ker_eq_bot]
+    exact hx
+  exact (RingHom.injective_iff_ker_eq_bot (pointPullbackCoordHom h).toRingHom).mpr hker
+
+@[expose] public def pointPullbackHom {xP yP : W.FunctionField}
+    (h : (W.map ι).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    W.FunctionField →ₐ[F] W.FunctionField :=
+  IsFractionRing.liftAlgHom (pointPullbackCoordHom_injective h hx)
+
+theorem pointPullbackHom_algebraMap {xP yP : W.FunctionField}
+    (h : (W.map ι).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) (r : W.CoordinateRing) :
+    pointPullbackHom h hx (algebraMap W.CoordinateRing W.FunctionField r)
+      = pointPullbackCoordHom h r :=
+  IsFractionRing.lift_algebraMap (pointPullbackCoordHom_injective h hx) r
+
+theorem pointPullbackHom_polyToFunctionField_X {xP yP : W.FunctionField}
+    (h : (W.map ι).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    pointPullbackHom h hx (polyToFunctionField W X) = xP := by
+  rw [polyToFunctionField_apply, pointPullbackHom_algebraMap,
+    algebraMap_polynomial_eq_mk_C, pointPullbackCoordHom_mk, eval₂_C]
+  exact Polynomial.aeval_X _
+
+theorem pointPullbackHom_yGen {xP yP : W.FunctionField}
+    (h : (W.map ι).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    pointPullbackHom h hx (yGen W) = yP := by
+  change pointPullbackHom h hx (algebraMap _ _ (CoordinateRing.mk W Y)) = _
+  rw [pointPullbackHom_algebraMap, pointPullbackCoordHom_mk]
+  exact eval₂_X _ _
+
+end PointPullback
+
+end Affine
+end WeierstrassCurve
+end
+end
+
+section
+
+namespace WeierstrassCurve
+namespace Affine
+
+universe u
+
+variable {F : Type u} [Field F]
+
+section GenericPoint
+
+variable {W : Affine F}
+
+theorem polyToFunctionField_eq_aeval (p : F[X]) :
+    polyToFunctionField W p = Polynomial.aeval (polyToFunctionField W X) p := by
+  have h1 : (polyToFunctionField W : F[X] →+* W.FunctionField)
+      = algebraMap F[X] W.FunctionField :=
+    (IsScalarTower.algebraMap_eq F[X] W.CoordinateRing W.FunctionField).symm
+  have h2 : (IsScalarTower.toAlgHom F F[X] W.FunctionField : F[X] →ₐ[F] W.FunctionField)
+      = Polynomial.aeval (polyToFunctionField W X) := by
+    refine Polynomial.algHom_ext ?_
+    rw [Polynomial.aeval_X, IsScalarTower.coe_toAlgHom', ← h1]
+  calc polyToFunctionField W p = algebraMap F[X] W.FunctionField p := by rw [h1]
+    _ = (IsScalarTower.toAlgHom F F[X] W.FunctionField : F[X] →ₐ[F] W.FunctionField) p := rfl
+    _ = Polynomial.aeval (polyToFunctionField W X) p := by rw [h2]
+
+public theorem equation_map_polyToFunctionField_yGen :
+    (W.map (algebraMap F W.FunctionField)).toAffine.Equation
+      (polyToFunctionField W X) (yGen W) := by
+  rw [equation_iff]
+  have hrel := smul_basis_mul_Y (W' := W) 0 1
+  rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at hrel
+  have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) hrel
+  rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆]
+  simp only [map_add, map_mul, map_pow, polyToFunctionField_C] at h2
+  rw [show yGen W = algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+    from rfl]
+  simp only [polyToFunctionField_apply] at h2 ⊢
+  linear_combination h2
+
+end GenericPoint
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+namespace WeierstrassCurve
+namespace Affine
+
+universe u
+
+variable {F : Type u} [Field F]
+
+namespace AbstractSeam
+
+variable {W : Affine F} {V : Affine F}
+variable (ι : V.FunctionField →ₐ[F] W.FunctionField)
+  (hι : ι.toRingHom.IsIntegral)
+  {ξ η : W.FunctionField}
+  (hX : ι (polyToFunctionField V (X : F[X])) = ξ)
+  (hY : ι (yGen V) = η)
+
+include hX in
+theorem map_XClass (c : F) :
+    ι (algebraMap V.CoordinateRing V.FunctionField (XClass V c))
+      = ξ - algebraMap F W.FunctionField c := by
+  have h1 : algebraMap V.CoordinateRing V.FunctionField (XClass V c)
+      = polyToFunctionField V (X : F[X]) - algebraMap F V.FunctionField c := by
+    rw [← polyToFunctionField_C, ← map_sub]
+    rfl
+  rw [h1, map_sub, hX, AlgHom.commutes]
+
+include hY in
+theorem map_YClass (c : F) :
+    ι (algebraMap V.CoordinateRing V.FunctionField (YClass V (C c)))
+      = η - algebraMap F W.FunctionField c := by
+  have h1 : algebraMap V.CoordinateRing V.FunctionField (YClass V (C c))
+      = yGen V - algebraMap F V.FunctionField c := by
+    rw [YClass, map_sub, map_sub, yGen]
+    congr 1
+  rw [h1, map_sub, hY, AlgHom.commutes]
+
+section Cases
+
+variable [IsDedekindDomain V.CoordinateRing]
+
+include hX hY in
+theorem restrictAlong_placeOfEquation [IsAlgClosed F] [W.IsElliptic]
+    {x y : F} (h : W.Equation x y) {a b : F} (h' : V.Equation a b)
+    (hreg : ξ ∈ (placeOfEquation h).toValuationSubring)
+    (hdx : 0 < (placeOfEquation h).ord (ξ - algebraMap F W.FunctionField a))
+    (hdy : 0 < (placeOfEquation h).ord (η - algebraMap F W.FunctionField b)) :
+    (placeOfEquation h).restrictAlong ι hι = placeOfEquation h' := by
+  have hfin : IsFinitePlace ((placeOfEquation h).restrictAlong ι hι) :=
+    isFinitePlace_of_mem _ (by
+      rw [Place.mem_restrictAlong_iff, hX]
+      exact hreg)
+  refine eq_placeOfEquation_of_le_centre hfin h' ?_
+  rw [XYIdeal, Ideal.span_le]
+  intro r hr
+  simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hr
+  rcases hr with rfl | rfl
+  · rw [SetLike.mem_coe, hfin.mem_centre_iff_ord_ne_zero (XClass_ne_zero _),
+      Place.ord_restrictAlong_ne_zero_iff, map_XClass ι hX]
+    omega
+  · rw [SetLike.mem_coe, hfin.mem_centre_iff_ord_ne_zero (YClass_ne_zero _),
+      Place.ord_restrictAlong_ne_zero_iff, map_YClass ι hY]
+    omega
+
+include hX in
+theorem restrictAlong_eq_infinitePlace
+    [GenusOnePlaceGate V] [GenusOnePlaceGate.IsCentred V]
+    (v : AlgebraicCurve.Place F W.FunctionField)
+    (hpole : ξ ∉ v.toValuationSubring) :
+    v.restrictAlong ι hι = InfinitePlace.place := by
+  refine InfinitePlace.eq_of_not_isFinitePlace _ ?_
+  intro hfin
+  refine hpole ?_
+  rw [← hX]
+  exact hfin (algebraMap F[X] V.CoordinateRing (X : F[X]))
+
+end Cases
+end AbstractSeam
+end Affine
+end WeierstrassCurve
+
+end
+
+section
+
+section
+
+namespace ModularCurve
+namespace Es1a1
+
+universe u
+
+section CoordSeamPbd
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : WeierstrassCurve.Affine F} [W.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+def es1a8_coordSeamDataAt_pbd (φ : W.FunctionField →ₐ[F] W.FunctionField)
+    (v : AlgebraicCurve.Place F W.FunctionField) : W.Point → Prop
+  | .zero => φ (polyToFunctionField W X) ∉ v.toValuationSubring
+  | .some x₃ y₃ _ =>
+      0 < v.ord (φ (polyToFunctionField W X) - algebraMap F W.FunctionField x₃) ∧
+        0 < v.ord (φ (yGen W) - algebraMap F W.FunctionField y₃)
+
+omit [DecidableEq F] [CharZero F] [W.AbelTheorem] in
+theorem es1a8_coordSeamDataAt_of_restrictAlong_pbd
+    (φ : W.FunctionField →ₐ[F] W.FunctionField) (hφ : φ.toRingHom.IsIntegral)
+    (v : AlgebraicCurve.Place F W.FunctionField) (Q : W.Point)
+    (hres : v.restrictAlong φ hφ = placeOfPoint Q) :
+    es1a8_coordSeamDataAt_pbd φ v Q := by
+  cases Q with
+  | zero =>
+      rw [placeOfPoint_zero] at hres
+      intro hmem
+      have h1 : polyToFunctionField W X ∈ (v.restrictAlong φ hφ).toValuationSubring :=
+        (Place.mem_restrictAlong_iff φ hφ v _).mpr hmem
+      rw [hres] at h1
+      have h2 : (0 : ℤ) ≤ (InfinitePlace.place :
+          AlgebraicCurve.Place F W.FunctionField).ord (polyToFunctionField W X) :=
+        AlgebraicCurve.Place.ord_nonneg_of_mem _ h1
+      have h3 := ord_X_neg_of_not_isFinitePlace
+        (InfinitePlace.place : AlgebraicCurve.Place F W.FunctionField)
+        InfinitePlace.not_isFinitePlace
+      omega
+  | some x₃ y₃ h₃ =>
+      rw [placeOfPoint_some] at hres
+      have hpos := Place.ramificationIndexAlong_pos φ hφ v
+      constructor
+      · have hsrc : 0 < (placeOfEquation h₃.left).ord
+            (polyToFunctionField W X - algebraMap F W.FunctionField x₃) := by
+          rw [show polyToFunctionField W X - algebraMap F W.FunctionField x₃
+              = polyToFunctionField W (X - C x₃) by rw [map_sub, polyToFunctionField_C]]
+          refine (ord_polyToFunctionField_pos_iff h₃.left (X_sub_C_ne_zero x₃)).mpr ?_
+          simp
+        have htrans := Place.ord_restrictAlong φ hφ v
+          (polyToFunctionField W X - algebraMap F W.FunctionField x₃)
+        rw [hres, map_sub, AlgHom.commutes] at htrans
+        rw [htrans]
+        exact mul_pos (by exact_mod_cast hpos) hsrc
+      · have hyeq : yGen W - algebraMap F W.FunctionField y₃
+            = algebraMap W.CoordinateRing W.FunctionField
+                ((-(C y₃) : F[X]) • (1 : W.CoordinateRing)
+                  + (1 : F[X]) • CoordinateRing.mk W Y) := by
+          rw [algebraMap_smul_basis,
+            show algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+              = yGen W from rfl]
+          simp only [_root_.map_neg, polyToFunctionField_C, map_one, one_mul]
+          ring
+        have hyclass : ((-(C y₃) : F[X]) • (1 : W.CoordinateRing)
+            + (1 : F[X]) • CoordinateRing.mk W Y) = CoordinateRing.YClass W (C y₃) := by
+          simp only [CoordinateRing.smul, CoordinateRing.YClass, map_sub, _root_.map_neg,
+            map_one, one_mul, mul_one]
+          ring
+        have hr0 : ((-(C y₃) : F[X]) • (1 : W.CoordinateRing)
+            + (1 : F[X]) • CoordinateRing.mk W Y) ≠ 0 := by
+          rw [hyclass]
+          exact CoordinateRing.YClass_ne_zero _
+        have hrmem : ((-(C y₃) : F[X]) • (1 : W.CoordinateRing)
+            + (1 : F[X]) • CoordinateRing.mk W Y)
+            ∈ CoordinateRing.XYIdeal W x₃ (C y₃) := by
+          rw [hyclass, CoordinateRing.XYIdeal]
+          exact Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+        have hsrc : 0 < (placeOfEquation h₃.left).ord
+            (yGen W - algebraMap F W.FunctionField y₃) := by
+          rw [hyeq]
+          exact (ord_placeOfEquation_pos_iff h₃.left hr0).mpr hrmem
+        have htrans := Place.ord_restrictAlong φ hφ v
+          (yGen W - algebraMap F W.FunctionField y₃)
+        rw [hres, map_sub, AlgHom.commutes] at htrans
+        rw [htrans]
+        exact mul_pos (by exact_mod_cast hpos) hsrc
+
+end CoordSeamPbd
+end Es1a1
+end ModularCurve
+end
+end
+
+section
+
+section
+
+namespace WeierstrassCurve
+namespace Affine
+
+universe u
+
+variable {F : Type u} [Field F]
+
+section AdjoinSurjective
+
+variable {W : Affine F} (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b)
+
+local notation "ι" => algebraMap F W.FunctionField
+
+theorem transcendental_polyToFunctionField_X :
+    Transcendental F (polyToFunctionField W X) := by
+  rw [transcendental_iff]
+  intro p hp
+  rw [← polyToFunctionField_eq_aeval] at hp
+  exact polyToFunctionField_injective (by simpa using hp)
+
+end AdjoinSurjective
+end Affine
+end WeierstrassCurve
+end
+end
+
+section
+
+section
+
+universe u
+
+public local instance instDecEqFunctionFieldEndst20Ps {F : Type u} [Field F]
+    {W : WeierstrassCurve.Affine F} : DecidableEq W.FunctionField :=
+  Classical.decEq _
+
+namespace WeierstrassCurve
+namespace Affine
+
+variable {F : Type u} [Field F]
+
+section DupDenominator
+
+variable (W : Affine F)
+
+theorem endst20_ps_yGen_ne_negY [CharZero F] :
+    yGen W ≠ (W.map (algebraMap F W.FunctionField)).toAffine.negY
+      (polyToFunctionField W X) (yGen W) := by
+  intro hcon
+  have heq := equation_map_polyToFunctionField_yGen (W := W)
+  rw [equation_iff'] at heq
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆] at heq
+  simp only [negY, map_a₁, map_a₃] at hcon
+  refine polyToFunctionField_ne_zero (W := W)
+      (p := Polynomial.C (4 : F) * Polynomial.X ^ 3
+        + Polynomial.C (W.a₁ ^ 2 + 4 * W.a₂) * Polynomial.X ^ 2
+        + Polynomial.C (4 * W.a₄ + 2 * W.a₁ * W.a₃) * Polynomial.X
+        + Polynomial.C (W.a₃ ^ 2 + 4 * W.a₆)) ?_ ?_
+  · intro h0
+    have h3 := congrArg (fun q => Polynomial.coeff q 3) h0
+    simp only [Polynomial.coeff_add, Polynomial.coeff_C_mul, Polynomial.coeff_X_pow,
+      Polynomial.coeff_X, Polynomial.coeff_C, Polynomial.coeff_zero] at h3
+    norm_num at h3
+  · simp only [map_add, map_mul, map_pow, polyToFunctionField_C, map_ofNat]
+    linear_combination
+      (2 * yGen W + algebraMap F W.FunctionField W.a₁ * polyToFunctionField W X
+          + algebraMap F W.FunctionField W.a₃) * hcon
+        - 4 * heq
+
+end DupDenominator
+
+section DupCoordinates
+
+variable (W : Affine F)
+
+def endst20_ps_dupSlope : W.FunctionField :=
+  (W.map (algebraMap F W.FunctionField)).toAffine.slope
+    (polyToFunctionField W X) (polyToFunctionField W X) (yGen W) (yGen W)
+
+def endst20_ps_dupX : W.FunctionField :=
+  (W.map (algebraMap F W.FunctionField)).toAffine.addX
+    (polyToFunctionField W X) (polyToFunctionField W X) (endst20_ps_dupSlope W)
+
+theorem endst20_ps_dupSlope_eq_div [CharZero F] :
+    endst20_ps_dupSlope W
+      = (3 * polyToFunctionField W X ^ 2
+            + 2 * (W.map (algebraMap F W.FunctionField)).toAffine.a₂ * polyToFunctionField W X
+            + (W.map (algebraMap F W.FunctionField)).toAffine.a₄
+            - (W.map (algebraMap F W.FunctionField)).toAffine.a₁ * yGen W)
+          / (yGen W
+              - (W.map (algebraMap F W.FunctionField)).toAffine.negY
+                  (polyToFunctionField W X) (yGen W)) := by
+  unfold endst20_ps_dupSlope
+  exact slope_of_Y_ne rfl (endst20_ps_yGen_ne_negY W)
+
+end DupCoordinates
+
+section DupTranscendence
+
+variable (W : Affine F)
+
+theorem endst20_ps_yGen_sub_negY_sq :
+    (yGen W - (W.map (algebraMap F W.FunctionField)).toAffine.negY
+        (polyToFunctionField W X) (yGen W)) ^ 2
+      = 4 * polyToFunctionField W X ^ 3
+        + (algebraMap F W.FunctionField W.a₁ ^ 2 + 4 * algebraMap F W.FunctionField W.a₂)
+            * polyToFunctionField W X ^ 2
+        + (4 * algebraMap F W.FunctionField W.a₄
+            + 2 * algebraMap F W.FunctionField W.a₁ * algebraMap F W.FunctionField W.a₃)
+            * polyToFunctionField W X
+        + (algebraMap F W.FunctionField W.a₃ ^ 2 + 4 * algebraMap F W.FunctionField W.a₆) := by
+  have heq := equation_map_polyToFunctionField_yGen (W := W)
+  rw [equation_iff'] at heq
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆] at heq
+  simp only [negY, map_a₁, map_a₃]
+  linear_combination 4 * heq
+
+theorem endst20_ps_dupX_mul_sq [CharZero F] :
+    endst20_ps_dupX W
+        * (yGen W - (W.map (algebraMap F W.FunctionField)).toAffine.negY
+            (polyToFunctionField W X) (yGen W)) ^ 2
+      = polyToFunctionField W X ^ 4
+        - (2 * algebraMap F W.FunctionField W.a₄
+            + algebraMap F W.FunctionField W.a₁ * algebraMap F W.FunctionField W.a₃)
+            * polyToFunctionField W X ^ 2
+        - 2 * (algebraMap F W.FunctionField W.a₃ ^ 2 + 4 * algebraMap F W.FunctionField W.a₆)
+            * polyToFunctionField W X
+        - (algebraMap F W.FunctionField W.a₁ ^ 2 * algebraMap F W.FunctionField W.a₆
+            + 4 * algebraMap F W.FunctionField W.a₂ * algebraMap F W.FunctionField W.a₆
+            - algebraMap F W.FunctionField W.a₁ * algebraMap F W.FunctionField W.a₃
+                * algebraMap F W.FunctionField W.a₄
+            + algebraMap F W.FunctionField W.a₂ * algebraMap F W.FunctionField W.a₃ ^ 2
+            - algebraMap F W.FunctionField W.a₄ ^ 2) := by
+  have hψ : yGen W - (W.map (algebraMap F W.FunctionField)).toAffine.negY
+      (polyToFunctionField W X) (yGen W) ≠ 0 :=
+    sub_ne_zero.mpr (endst20_ps_yGen_ne_negY W)
+  have hs : endst20_ps_dupSlope W
+      * (yGen W - (W.map (algebraMap F W.FunctionField)).toAffine.negY
+          (polyToFunctionField W X) (yGen W))
+      = 3 * polyToFunctionField W X ^ 2
+        + 2 * (W.map (algebraMap F W.FunctionField)).toAffine.a₂ * polyToFunctionField W X
+        + (W.map (algebraMap F W.FunctionField)).toAffine.a₄
+        - (W.map (algebraMap F W.FunctionField)).toAffine.a₁ * yGen W := by
+    rw [endst20_ps_dupSlope_eq_div W]
+    exact div_mul_cancel₀ _ hψ
+  have heq := equation_map_polyToFunctionField_yGen (W := W)
+  rw [equation_iff'] at heq
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆] at heq
+  simp only [negY, map_a₁, map_a₂, map_a₃, map_a₄] at hs
+  simp only [endst20_ps_dupX, addX, negY, map_a₁, map_a₂, map_a₃]
+  grind
+
+theorem endst20_ps_transcendental_dupX [IsAlgClosed F] [CharZero F] :
+    Transcendental F (endst20_ps_dupX W) := by
+  intro halg
+  obtain ⟨c, hc⟩ := exists_algebraMap_eq_of_isAlgebraic halg
+  have hq := endst20_ps_dupX_mul_sq W
+  have hp2 := endst20_ps_yGen_sub_negY_sq W
+  refine polyToFunctionField_ne_zero (W := W)
+      (p := Polynomial.C c * (Polynomial.C (4 : F) * Polynomial.X ^ 3
+          + Polynomial.C (W.a₁ ^ 2 + 4 * W.a₂) * Polynomial.X ^ 2
+          + Polynomial.C (4 * W.a₄ + 2 * W.a₁ * W.a₃) * Polynomial.X
+          + Polynomial.C (W.a₃ ^ 2 + 4 * W.a₆))
+        - (Polynomial.X ^ 4
+          - Polynomial.C (2 * W.a₄ + W.a₁ * W.a₃) * Polynomial.X ^ 2
+          - Polynomial.C (2 * (W.a₃ ^ 2 + 4 * W.a₆)) * Polynomial.X
+          - Polynomial.C (W.a₁ ^ 2 * W.a₆ + 4 * W.a₂ * W.a₆ - W.a₁ * W.a₃ * W.a₄
+              + W.a₂ * W.a₃ ^ 2 - W.a₄ ^ 2))) ?_ ?_
+  · intro h0
+    have h4 := congrArg (fun q => Polynomial.coeff q 4) h0
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_add, Polynomial.coeff_C_mul,
+      Polynomial.coeff_X_pow, Polynomial.coeff_X, Polynomial.coeff_C,
+      Polynomial.coeff_zero] at h4
+    norm_num at h4
+  · simp only [map_sub, map_add, map_mul, map_pow, polyToFunctionField_C, map_ofNat]
+    grind
+
+end DupTranscendence
+end Affine
+end WeierstrassCurve
+
+namespace ModularCurve
+
+local notation "psPsi11" =>
+  (Polynomial.C 4 * Polynomial.X ^ 3 - Polynomial.C 4 * Polynomial.X ^ 2
+    - Polynomial.C 40 * Polynomial.X - Polynomial.C 79 : Polynomial (AlgebraicClosure ℚ))
+local notation "psN411" =>
+  (Polynomial.X ^ 4 + Polynomial.C 20 * Polynomial.X ^ 2
+    + Polynomial.C 158 * Polynomial.X + Polynomial.C 21 : Polynomial (AlgebraicClosure ℚ))
+local notation "psP11[" b "]" =>
+  (Polynomial.X ^ 6 - Polynomial.C 2 * Polynomial.X ^ 5 - Polynomial.C 50 * Polynomial.X ^ 4
+    - Polynomial.C (4 * b + 397) * Polynomial.X ^ 3
+    + Polynomial.C (4 * b - 103) * Polynomial.X ^ 2
+    + Polynomial.C (40 * b - 728) * Polynomial.X
+    + Polynomial.C (79 * b - 2871) : Polynomial (AlgebraicClosure ℚ))
+local notation "psQ11[" b "]" =>
+  (Polynomial.C (-8 * b - 4) * Polynomial.X ^ 3 + Polynomial.C (8 * b + 4) * Polynomial.X ^ 2
+    + Polynomial.C (80 * b + 40) * Polynomial.X + Polynomial.C (158 * b + 79)
+    : Polynomial (AlgebraicClosure ℚ))
+
+end ModularCurve
+end
+end
+
+section
+
+section
+
+namespace ModularCurve
+namespace Es1a1
+
+universe u
+
+section AddLawCore
+
+variable {F : Type u} [Field F]
+
+public local instance instDecEqFunctionFieldEs1a6Add {W : WeierstrassCurve.Affine F} :
+    DecidableEq W.FunctionField :=
+  Classical.decEq _
+
+variable (W : WeierstrassCurve.Affine F)
+
+public theorem es1a6_add_equation (φ : W.FunctionField →ₐ[F] W.FunctionField) :
+    (W.map (algebraMap F W.FunctionField)).toAffine.Equation
+      (φ (polyToFunctionField W X)) (φ (yGen W)) := by
+  have h := equation_map_polyToFunctionField_yGen (W := W)
+  rw [equation_iff'] at h
+  simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+    WeierstrassCurve.map_a₄, WeierstrassCurve.map_a₆] at h
+  have h2 := congrArg φ h
+  simp only [map_add, map_sub, map_mul, map_pow, _root_.map_zero, AlgHom.commutes] at h2
+  rw [equation_iff']
+  simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+    WeierstrassCurve.map_a₄, WeierstrassCurve.map_a₆]
+  linear_combination h2
+
+
+
+variable (φ₁ φ₂ : W.FunctionField →ₐ[F] W.FunctionField)
+
+@[expose] public def es1a6_addCollapse : Prop :=
+  φ₁ (polyToFunctionField W X) = φ₂ (polyToFunctionField W X) ∧
+    φ₁ (yGen W) = (W.map (algebraMap F W.FunctionField)).toAffine.negY
+      (φ₂ (polyToFunctionField W X)) (φ₂ (yGen W))
+
+public theorem es1a6_add_not_collapse_of_X_ne
+    (hne : φ₁ (polyToFunctionField W X) ≠ φ₂ (polyToFunctionField W X)) :
+    ¬ es1a6_addCollapse W φ₁ φ₂ :=
+  fun hc => hne hc.1
+
+@[expose] public def es1a6_addSumX : W.FunctionField :=
+  (W.map (algebraMap F W.FunctionField)).toAffine.addX
+    (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+    ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+      (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+      (φ₁ (yGen W)) (φ₂ (yGen W)))
+
+@[expose] public def es1a6_addSumY : W.FunctionField :=
+  (W.map (algebraMap F W.FunctionField)).toAffine.addY
+    (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X)) (φ₁ (yGen W))
+    ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+      (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+      (φ₁ (yGen W)) (φ₂ (yGen W)))
+
+public theorem es1a6_addSum_equation (hcol : ¬ es1a6_addCollapse W φ₁ φ₂) :
+    (W.map (algebraMap F W.FunctionField)).toAffine.Equation
+      (es1a6_addSumX W φ₁ φ₂) (es1a6_addSumY W φ₁ φ₂) := by
+  unfold es1a6_addSumX es1a6_addSumY
+  exact equation_add (es1a6_add_equation W φ₁) (es1a6_add_equation W φ₂)
+    (fun hxy => hcol hxy)
+
+
+@[expose] public def es1a6_addSumPullbackHom (hcol : ¬ es1a6_addCollapse W φ₁ φ₂)
+    (htr : Function.Injective (Polynomial.aeval (R := F) (es1a6_addSumX W φ₁ φ₂))) :
+    W.FunctionField →ₐ[F] W.FunctionField :=
+  pointPullbackHom (es1a6_addSum_equation W φ₁ φ₂ hcol) htr
+
+public theorem es1a6_addSumPullbackHom_X (hcol : ¬ es1a6_addCollapse W φ₁ φ₂)
+    (htr : Function.Injective (Polynomial.aeval (R := F) (es1a6_addSumX W φ₁ φ₂))) :
+    es1a6_addSumPullbackHom W φ₁ φ₂ hcol htr (polyToFunctionField W X)
+      = es1a6_addSumX W φ₁ φ₂ :=
+  pointPullbackHom_polyToFunctionField_X _ _
+
+public theorem es1a6_addSumPullbackHom_yGen (hcol : ¬ es1a6_addCollapse W φ₁ φ₂)
+    (htr : Function.Injective (Polynomial.aeval (R := F) (es1a6_addSumX W φ₁ φ₂))) :
+    es1a6_addSumPullbackHom W φ₁ φ₂ hcol htr (yGen W) = es1a6_addSumY W φ₁ φ₂ :=
+  pointPullbackHom_yGen _ _
+
+theorem es1a6_add_sumX_isAlgebraic_constant_point [IsAlgClosed F]
+    (hcol : ¬ es1a6_addCollapse W φ₁ φ₂)
+    (halg : IsAlgebraic F (es1a6_addSumX W φ₁ φ₂)) :
+    ∃ c d : F, es1a6_addSumX W φ₁ φ₂ = algebraMap F W.FunctionField c ∧
+      es1a6_addSumY W φ₁ φ₂ = algebraMap F W.FunctionField d ∧ W.Equation c d := by
+  obtain ⟨c, hc⟩ := exists_algebraMap_eq_of_isAlgebraic halg
+  have heq := es1a6_addSum_equation W φ₁ φ₂ hcol
+  rw [equation_iff'] at heq
+  simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+    WeierstrassCurve.map_a₄,
+    WeierstrassCurve.map_a₆] at heq
+  rw [← hc] at heq
+  have hq0 : (X ^ 2 + C (W.a₁ * c + W.a₃) * X
+      - C (c ^ 3 + W.a₂ * c ^ 2 + W.a₄ * c + W.a₆) : F[X]) ≠ 0 := by
+    intro hq
+    have h2 := congrArg (fun q => Polynomial.coeff q 2) hq
+    simp only [Polynomial.coeff_add, Polynomial.coeff_sub, Polynomial.coeff_X_pow,
+      Polynomial.coeff_C_mul, Polynomial.coeff_C, Polynomial.coeff_X,
+      Polynomial.coeff_zero] at h2
+    norm_num at h2
+  have halgY : IsAlgebraic F (es1a6_addSumY W φ₁ φ₂) := by
+    refine ⟨X ^ 2 + C (W.a₁ * c + W.a₃) * X
+      - C (c ^ 3 + W.a₂ * c ^ 2 + W.a₄ * c + W.a₆), hq0, ?_⟩
+    simp only [map_add, map_sub, map_mul, map_pow, Polynomial.aeval_X,
+      Polynomial.aeval_C]
+    linear_combination heq
+  obtain ⟨d, hd⟩ := exists_algebraMap_eq_of_isAlgebraic halgY
+  refine ⟨c, d, hc.symm, hd.symm, ?_⟩
+  have hmap : (W.map (algebraMap F W.FunctionField)).toAffine.Equation
+      (algebraMap F W.FunctionField c) (algebraMap F W.FunctionField d) := by
+    rw [hc, hd]
+    exact es1a6_addSum_equation W φ₁ φ₂ hcol
+  exact (Affine.map_equation W (algebraMap F W.FunctionField).injective c d).mp hmap
+
+theorem es1a6_add_sumX_transcendental_or_constant_point [IsAlgClosed F]
+    (hcol : ¬ es1a6_addCollapse W φ₁ φ₂) :
+    Transcendental F (es1a6_addSumX W φ₁ φ₂) ∨
+      ∃ c d : F, es1a6_addSumX W φ₁ φ₂ = algebraMap F W.FunctionField c ∧
+        es1a6_addSumY W φ₁ φ₂ = algebraMap F W.FunctionField d ∧ W.Equation c d := by
+  by_cases halg : IsAlgebraic F (es1a6_addSumX W φ₁ φ₂)
+  · exact Or.inr (es1a6_add_sumX_isAlgebraic_constant_point W φ₁ φ₂ hcol halg)
+  · exact Or.inl halg
+
+theorem es1a6_add_sumX_transcendental_of_forall_ne [IsAlgClosed F]
+    (hnc : ∀ c : F, es1a6_addSumX W φ₁ φ₂ ≠ algebraMap F W.FunctionField c) :
+    Transcendental F (es1a6_addSumX W φ₁ φ₂) := by
+  intro halg
+  obtain ⟨c, hc⟩ := exists_algebraMap_eq_of_isAlgebraic halg
+  exact hnc c hc.symm
+
+theorem es1a6_add_sumX_not_transcendental_of_eq_const (c : F)
+    (hc : es1a6_addSumX W φ₁ φ₂ = algebraMap F W.FunctionField c) :
+    ¬ Transcendental F (es1a6_addSumX W φ₁ φ₂) := by
+  rw [hc]
+  exact fun htr => htr (isAlgebraic_algebraMap c)
+
+public theorem es1a6_add_aeval_sumX_injective_of_forall_ne [IsAlgClosed F]
+    (hnc : ∀ c : F, es1a6_addSumX W φ₁ φ₂ ≠ algebraMap F W.FunctionField c) :
+    Function.Injective (Polynomial.aeval (R := F) (es1a6_addSumX W φ₁ φ₂)) :=
+  (injective_iff_map_eq_zero _).mpr fun p hp =>
+    transcendental_iff.mp (es1a6_add_sumX_transcendental_of_forall_ne W φ₁ φ₂ hnc) p hp
+
+end AddLawCore
+
+section SeamEngines
+
+variable {F : Type u} [Field F]
+
+theorem es1a6_addSeam_restrictAlong_eq_placeOfEquation [IsAlgClosed F]
+    {V W : WeierstrassCurve.Affine F} [IsDedekindDomain V.CoordinateRing]
+    (ι : V.FunctionField →ₐ[F] W.FunctionField) (hι : ι.toRingHom.IsIntegral)
+    {ξ η : W.FunctionField}
+    (hX : ι (polyToFunctionField V (X : F[X])) = ξ) (hY : ι (yGen V) = η)
+    (v : AlgebraicCurve.Place F W.FunctionField) {a b : F} (h' : V.Equation a b)
+    (hreg : ξ ∈ v.toValuationSubring)
+    (hdx : 0 < v.ord (ξ - algebraMap F W.FunctionField a))
+    (hdy : 0 < v.ord (η - algebraMap F W.FunctionField b)) :
+    v.restrictAlong ι hι = placeOfEquation h' := by
+  have hfin : IsFinitePlace (v.restrictAlong ι hι) :=
+    isFinitePlace_of_mem _ (by
+      rw [Place.mem_restrictAlong_iff, hX]
+      exact hreg)
+  refine eq_placeOfEquation_of_le_centre hfin h' ?_
+  rw [CoordinateRing.XYIdeal, Ideal.span_le]
+  intro r hr
+  simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hr
+  rcases hr with rfl | rfl
+  · rw [SetLike.mem_coe, hfin.mem_centre_iff_ord_ne_zero (CoordinateRing.XClass_ne_zero _),
+      Place.ord_restrictAlong_ne_zero_iff, AbstractSeam.map_XClass ι hX]
+    omega
+  · rw [SetLike.mem_coe, hfin.mem_centre_iff_ord_ne_zero (CoordinateRing.YClass_ne_zero _),
+      Place.ord_restrictAlong_ne_zero_iff, AbstractSeam.map_YClass ι hY]
+    omega
+
+variable [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : WeierstrassCurve.Affine F} [W.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+public local instance instDecEqFunctionFieldEs1a6AddSeam :
+    DecidableEq W.FunctionField :=
+  Classical.decEq _
+
+variable (φ₁ φ₂ : W.FunctionField →ₐ[F] W.FunctionField)
+
+omit [DecidableEq F] [CharZero F] [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W]
+  [W.AbelTheorem] in
+theorem es1a6_addSumSeam_some
+    (hcol : ¬ es1a6_addCollapse W φ₁ φ₂)
+    (htr : Function.Injective (Polynomial.aeval (R := F) (es1a6_addSumX W φ₁ φ₂)))
+    (hι : (es1a6_addSumPullbackHom W φ₁ φ₂ hcol htr).toRingHom.IsIntegral)
+    (v : AlgebraicCurve.Place F W.FunctionField) {x₃ y₃ : F} (h₃ : W.Equation x₃ y₃)
+    (hdx : 0 < v.ord (es1a6_addSumX W φ₁ φ₂ - algebraMap F W.FunctionField x₃))
+    (hdy : 0 < v.ord (es1a6_addSumY W φ₁ φ₂ - algebraMap F W.FunctionField y₃)) :
+    v.restrictAlong (es1a6_addSumPullbackHom W φ₁ φ₂ hcol htr) hι
+      = placeOfEquation h₃ := by
+  have hreg : es1a6_addSumX W φ₁ φ₂ ∈ v.toValuationSubring := by
+    by_cases hz : es1a6_addSumX W φ₁ φ₂ - algebraMap F W.FunctionField x₃ = 0
+    · rw [sub_eq_zero.mp hz]
+      exact v.algebraMap_mem' x₃
+    · have hsub : es1a6_addSumX W φ₁ φ₂ - algebraMap F W.FunctionField x₃
+          ∈ v.toValuationSubring :=
+        AlgebraicCurve.Place.mem_of_ord_nonneg v hz hdx.le
+      have h2 := add_mem hsub (v.algebraMap_mem' x₃)
+      rwa [sub_add_cancel] at h2
+  exact es1a6_addSeam_restrictAlong_eq_placeOfEquation
+    (es1a6_addSumPullbackHom W φ₁ φ₂ hcol htr) hι
+    (es1a6_addSumPullbackHom_X W φ₁ φ₂ hcol htr)
+    (es1a6_addSumPullbackHom_yGen W φ₁ φ₂ hcol htr) v h₃ hreg hdx hdy
+
+omit [CharZero F] in
+omit [DecidableEq F] [W.AbelTheorem] in
+theorem es1a6_addSumSeam_pole
+    (hcol : ¬ es1a6_addCollapse W φ₁ φ₂)
+    (htr : Function.Injective (Polynomial.aeval (R := F) (es1a6_addSumX W φ₁ φ₂)))
+    (hι : (es1a6_addSumPullbackHom W φ₁ φ₂ hcol htr).toRingHom.IsIntegral)
+    (v : AlgebraicCurve.Place F W.FunctionField)
+    (hpole : es1a6_addSumX W φ₁ φ₂ ∉ v.toValuationSubring) :
+    v.restrictAlong (es1a6_addSumPullbackHom W φ₁ φ₂ hcol htr) hι
+      = (InfinitePlace.place : AlgebraicCurve.Place F W.FunctionField) :=
+  AbstractSeam.restrictAlong_eq_infinitePlace
+    (es1a6_addSumPullbackHom W φ₁ φ₂ hcol htr) hι
+    (es1a6_addSumPullbackHom_X W φ₁ φ₂ hcol htr) v hpole
+
+@[expose] public def es1a6_addSumSeamDataAt (v : AlgebraicCurve.Place F W.FunctionField) :
+    W.Point → Prop
+  | .zero => es1a6_addSumX W φ₁ φ₂ ∉ v.toValuationSubring
+  | .some x₃ y₃ _ =>
+      0 < v.ord (es1a6_addSumX W φ₁ φ₂ - algebraMap F W.FunctionField x₃) ∧
+        0 < v.ord (es1a6_addSumY W φ₁ φ₂ - algebraMap F W.FunctionField y₃)
+
+omit [CharZero F] in
+omit [DecidableEq F] [W.AbelTheorem] in
+public theorem es1a6_addSumSeam_of_data
+    (hcol : ¬ es1a6_addCollapse W φ₁ φ₂)
+    (htr : Function.Injective (Polynomial.aeval (R := F) (es1a6_addSumX W φ₁ φ₂)))
+    (hι : (es1a6_addSumPullbackHom W φ₁ φ₂ hcol htr).toRingHom.IsIntegral)
+    (P Q : W.Point)
+    (hdat : es1a6_addSumSeamDataAt φ₁ φ₂ (placeOfPoint P) Q) :
+    (placeOfPoint P).restrictAlong (es1a6_addSumPullbackHom W φ₁ φ₂ hcol htr) hι
+      = placeOfPoint Q := by
+  cases Q with
+  | zero =>
+      rw [placeOfPoint_zero]
+      exact es1a6_addSumSeam_pole φ₁ φ₂ hcol htr hι (placeOfPoint P) hdat
+  | some x₃ y₃ h₃ =>
+      rw [placeOfPoint_some]
+      exact es1a6_addSumSeam_some φ₁ φ₂ hcol htr hι (placeOfPoint P) h₃.left
+        hdat.1 hdat.2
+
+end SeamEngines
+end Es1a1
+end ModularCurve
+end
+end
+
+section
+
+section
+
+namespace ModularCurve
+namespace Es1a1
+
+universe u
+
+section CoordSeamEs1a11
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : WeierstrassCurve.Affine F} [W.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+@[expose] public def es1a11_coordSeamDataAt (φ : W.FunctionField →ₐ[F] W.FunctionField)
+    (v : AlgebraicCurve.Place F W.FunctionField) : W.Point → Prop
+  | .zero => φ (polyToFunctionField W X) ∉ v.toValuationSubring
+  | .some x₃ y₃ _ =>
+      0 < v.ord (φ (polyToFunctionField W X) - algebraMap F W.FunctionField x₃) ∧
+        0 < v.ord (φ (yGen W) - algebraMap F W.FunctionField y₃)
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem es1a11_coordSeamDataAt_iff_pbd (φ : W.FunctionField →ₐ[F] W.FunctionField)
+    (v : AlgebraicCurve.Place F W.FunctionField) (Q : W.Point) :
+    es1a11_coordSeamDataAt φ v Q ↔ es1a8_coordSeamDataAt_pbd φ v Q := by
+  cases Q <;> exact Iff.rfl
+
+end CoordSeamEs1a11
+end Es1a1
+end ModularCurve
+end
+end
+
+section
+
+section
+
+open AddMonoid.End
+
+namespace ModularCurve
+namespace Es1a1
+
+section NegPullback
+
+universe u
+
+variable {F : Type u} [Field F]
+
+def es1a4_negYGen (W : Affine F) : W.FunctionField :=
+  (W.map (algebraMap F W.FunctionField)).toAffine.negY
+    (polyToFunctionField W X) (yGen W)
+
+theorem es1a4_negYGen_eq (W : Affine F) :
+    es1a4_negYGen W
+      = -(yGen W) - algebraMap F W.FunctionField W.a₁ * polyToFunctionField W X
+          - algebraMap F W.FunctionField W.a₃ := rfl
+
+theorem es1a4_negYGen_equation (W : Affine F) :
+    (W.map (algebraMap F W.FunctionField)).toAffine.Equation
+      (polyToFunctionField W X) (es1a4_negYGen W) :=
+  (equation_neg _ _).mpr equation_map_polyToFunctionField_yGen
+
+theorem es1a4_neg_aeval_injective (W : Affine F) :
+    Function.Injective (Polynomial.aeval (R := F) (polyToFunctionField W X)) :=
+  (injective_iff_map_eq_zero _).mpr fun p hp =>
+    transcendental_iff.mp transcendental_polyToFunctionField_X p hp
+
+def es1a4_negPullbackHom (W : Affine F) : W.FunctionField →ₐ[F] W.FunctionField :=
+  pointPullbackHom (es1a4_negYGen_equation W) (es1a4_neg_aeval_injective W)
+
+theorem es1a4_negPullbackHom_X (W : Affine F) :
+    es1a4_negPullbackHom W (polyToFunctionField W X) = polyToFunctionField W X :=
+  pointPullbackHom_polyToFunctionField_X _ _
+
+theorem es1a4_negPullbackHom_yGen (W : Affine F) :
+    es1a4_negPullbackHom W (yGen W) = es1a4_negYGen W :=
+  pointPullbackHom_yGen _ _
+
+theorem es1a4_negPullbackHom_polyToFunctionField (W : Affine F) (p : F[X]) :
+    es1a4_negPullbackHom W (polyToFunctionField W p) = polyToFunctionField W p := by
+  have h := polyToFunctionField_eq_aeval (W := W) p
+  rw [h, ← Polynomial.aeval_algHom_apply, es1a4_negPullbackHom_X]
+
+theorem es1a4_negPullbackHom_negYGen (W : Affine F) :
+    es1a4_negPullbackHom W (es1a4_negYGen W) = yGen W := by
+  rw [es1a4_negYGen_eq, map_sub, map_sub, _root_.map_neg, map_mul, AlgHom.commutes,
+    AlgHom.commutes, es1a4_negPullbackHom_yGen, es1a4_negPullbackHom_X,
+    es1a4_negYGen_eq]
+  ring
+
+theorem es1a4_negPullbackHom_sq_algebraMap (W : Affine F) (r : W.CoordinateRing) :
+    es1a4_negPullbackHom W (es1a4_negPullbackHom W
+        (algebraMap W.CoordinateRing W.FunctionField r))
+      = algebraMap W.CoordinateRing W.FunctionField r := by
+  obtain ⟨p, q, rfl⟩ := CoordinateRing.exists_smul_basis_eq r
+  rw [algebraMap_smul_basis,
+    show algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) = yGen W
+      from rfl]
+  simp only [map_add, map_mul, es1a4_negPullbackHom_polyToFunctionField,
+    es1a4_negPullbackHom_yGen, es1a4_negPullbackHom_negYGen]
+
+theorem es1a4_negPullbackHom_involution (W : Affine F) (z : W.FunctionField) :
+    es1a4_negPullbackHom W (es1a4_negPullbackHom W z) = z := by
+  obtain ⟨r, s, _, hrs⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  rw [← hrs, map_div₀, map_div₀, es1a4_negPullbackHom_sq_algebraMap,
+    es1a4_negPullbackHom_sq_algebraMap]
+
+theorem es1a4_negPullbackHom_surjective (W : Affine F) :
+    Function.Surjective (es1a4_negPullbackHom W) := fun z =>
+  ⟨es1a4_negPullbackHom W z, es1a4_negPullbackHom_involution W z⟩
+
+theorem es1a4_negPullbackHom_isIntegral (W : Affine F) :
+    (es1a4_negPullbackHom W).toRingHom.IsIntegral :=
+  RingHom.isIntegral_of_surjective _ (es1a4_negPullbackHom_surjective W)
+
+theorem es1a4_negPullbackHom_finiteAlong (W : Affine F) :
+    FiniteAlong F (es1a4_negPullbackHom W) :=
+  RingHom.Finite.of_surjective (es1a4_negPullbackHom W).toRingHom
+    (es1a4_negPullbackHom_surjective W)
+
+end NegPullback
+
+section NegDatum
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+
+def es1a4_negDatum (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+    :
+    IsogenyEndDatum W where
+  ι := es1a4_negPullbackHom W
+  hι := es1a4_negPullbackHom_isIntegral W
+  hfin := es1a4_negPullbackHom_finiteAlong W
+
+variable {W : Affine F} [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+omit [DecidableEq F] [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem es1a4_negDatum_seam_some {x₀ y₀ : F} (h : W.Nonsingular x₀ y₀) :
+    (placeOfEquation h.left).restrictAlong (es1a4_negPullbackHom W)
+        (es1a4_negPullbackHom_isIntegral W)
+      = placeOfEquation ((nonsingular_neg x₀ y₀).mpr h).left := by
+  have hreg : polyToFunctionField W X ∈ (placeOfEquation h.left).toValuationSubring :=
+    isFinitePlace_placeOfEquation h.left (algebraMap F[X] W.CoordinateRing X)
+  have hdx : 0 < (placeOfEquation h.left).ord
+      (polyToFunctionField W X - algebraMap F W.FunctionField x₀) := by
+    rw [show polyToFunctionField W X - algebraMap F W.FunctionField x₀
+        = polyToFunctionField W (X - C x₀) by rw [map_sub, polyToFunctionField_C]]
+    refine (ord_polyToFunctionField_pos_iff h.left (X_sub_C_ne_zero x₀)).mpr ?_
+    simp
+  have hdy : 0 < (placeOfEquation h.left).ord
+      (es1a4_negYGen W - algebraMap F W.FunctionField (W.negY x₀ y₀)) := by
+    have hrbasis : -(CoordinateRing.YClass W (C y₀))
+          - CoordinateRing.mk W (C (C W.a₁)) * CoordinateRing.XClass W x₀
+        = (C y₀ - C W.a₁ * (X - C x₀)) • (1 : W.CoordinateRing)
+          + (-1 : F[X]) • CoordinateRing.mk W Y := by
+      simp only [CoordinateRing.smul, CoordinateRing.YClass, CoordinateRing.XClass,
+        map_sub, map_mul, _root_.map_neg, map_one]
+      ring
+    have hr0 : -(CoordinateRing.YClass W (C y₀))
+          - CoordinateRing.mk W (C (C W.a₁)) * CoordinateRing.XClass W x₀ ≠ 0 := by
+      rw [hrbasis]
+      intro hcon
+      simpa using (CoordinateRing.smul_basis_eq_zero hcon).2
+    have hrmem : -(CoordinateRing.YClass W (C y₀))
+          - CoordinateRing.mk W (C (C W.a₁)) * CoordinateRing.XClass W x₀
+        ∈ CoordinateRing.XYIdeal W x₀ (C y₀) :=
+      sub_mem (neg_mem (Ideal.subset_span (Set.mem_insert_of_mem _ rfl)))
+        (Ideal.mul_mem_left _ _ (Ideal.subset_span (Set.mem_insert _ _)))
+    have himg : es1a4_negYGen W - algebraMap F W.FunctionField (W.negY x₀ y₀)
+        = algebraMap W.CoordinateRing W.FunctionField
+            (-(CoordinateRing.YClass W (C y₀))
+              - CoordinateRing.mk W (C (C W.a₁)) * CoordinateRing.XClass W x₀) := by
+      rw [hrbasis, algebraMap_smul_basis,
+        show algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+          = yGen W from rfl, es1a4_negYGen_eq]
+      simp only [negY, map_sub, _root_.map_neg, map_mul, map_one, polyToFunctionField_C]
+      ring
+    rw [himg]
+    exact (ord_placeOfEquation_pos_iff h.left hr0).mpr hrmem
+  exact AbstractSeam.restrictAlong_placeOfEquation (es1a4_negPullbackHom W)
+    (es1a4_negPullbackHom_isIntegral W) (es1a4_negPullbackHom_X W)
+    (es1a4_negPullbackHom_yGen W) h.left ((nonsingular_neg x₀ y₀).mpr h).left
+    hreg hdx hdy
+
+omit [CharZero F] in
+omit [DecidableEq F] [W.AbelTheorem] in
+theorem es1a4_negDatum_seam_zero :
+    (InfinitePlace.place : AlgebraicCurve.Place F W.FunctionField).restrictAlong
+        (es1a4_negPullbackHom W) (es1a4_negPullbackHom_isIntegral W)
+      = InfinitePlace.place := by
+  refine AbstractSeam.restrictAlong_eq_infinitePlace (es1a4_negPullbackHom W)
+    (es1a4_negPullbackHom_isIntegral W) (es1a4_negPullbackHom_X W) _ ?_
+  intro hmem
+  have h1 : (0 : ℤ) ≤ (InfinitePlace.place : AlgebraicCurve.Place F W.FunctionField).ord
+      (polyToFunctionField W X) :=
+    AlgebraicCurve.Place.ord_nonneg_of_mem _ hmem
+  have h2 : (InfinitePlace.place : AlgebraicCurve.Place F W.FunctionField).ord
+      (polyToFunctionField W X) < 0 :=
+    ord_X_neg_of_not_isFinitePlace _ InfinitePlace.not_isFinitePlace
+  omega
+
+theorem es1a4_negDatum_seam (P : W.Point) :
+    (placeOfPoint P).restrictAlong (es1a4_negDatum W).ι (es1a4_negDatum W).hι
+      = placeOfPoint (-P) := by
+  cases P with
+  | zero =>
+      rw [show -(Point.zero : W.Point) = Point.zero from rfl, placeOfPoint_zero]
+      exact es1a4_negDatum_seam_zero
+  | some x₀ y₀ h =>
+      rw [Point.neg_some, placeOfPoint_some, placeOfPoint_some]
+      exact es1a4_negDatum_seam_some h
+
+end NegDatum
+end Es1a1
+end ModularCurve
+end
+end
+
+section
+
+section
+
+namespace ModularCurve
+namespace Es1a1
+
+universe u
+
+public local instance instDecEqFunctionFieldEs1a10NcPole {F : Type u} [Field F]
+    {W : WeierstrassCurve.Affine F} :
+    DecidableEq W.FunctionField :=
+  Classical.decEq _
+
+end Es1a1
+end ModularCurve
+end
+end
+
+section
+
+section
+
+namespace ModularCurve
+namespace Es1a1
+
+universe u
+
+section VerticalCaseEngines
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : WeierstrassCurve.Affine F} [W.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+public local instance instDecEqFunctionFieldEs1a10NcVertical :
+    DecidableEq W.FunctionField :=
+  Classical.decEq _
+
+
+
+end VerticalCaseEngines
+end Es1a1
+end ModularCurve
+end
+end
+
+section
+
+section
+
+namespace ModularCurve
+namespace Es1a1
+
+universe u
+
+public local instance instDecEqFunctionFieldEs1a9Nc {F : Type u} [Field F]
+    {W : WeierstrassCurve.Affine F} :
+    DecidableEq W.FunctionField :=
+  Classical.decEq _
+
+end Es1a1
+end ModularCurve
+end
+end
+
+section
+
+section
+
+namespace ModularCurve
+namespace Mmr46
+
+open ModularCurve.Es1a1
+
+universe u
+
+section GuardCarveEngine
+
+variable {F : Type u} [Field F]
+variable (W : WeierstrassCurve.Affine F)
+variable (φ₁ φ₂ : W.FunctionField →ₐ[F] W.FunctionField)
+
+theorem mmr46_gc_addSumX_ne_const_of_not_constPoint [IsAlgClosed F]
+    (hcol : ¬ es1a6_addCollapse W φ₁ φ₂)
+    (hres : ∀ c d : F, W.Equation c d →
+      ¬ (es1a6_addSumX W φ₁ φ₂ = algebraMap F W.FunctionField c ∧
+        es1a6_addSumY W φ₁ φ₂ = algebraMap F W.FunctionField d)) :
+    ∀ c : F, es1a6_addSumX W φ₁ φ₂ ≠ algebraMap F W.FunctionField c := by
+  intro c hc
+  rcases es1a6_add_sumX_transcendental_or_constant_point W φ₁ φ₂ hcol with
+    htr | ⟨c', d, hx, hy, heq⟩
+  · exact es1a6_add_sumX_not_transcendental_of_eq_const W φ₁ φ₂ c hc htr
+  · exact hres c' d heq ⟨hx, hy⟩
+
+end GuardCarveEngine
+end Mmr46
+end ModularCurve
+end
+end
+
+section
+
+section
+
+namespace ModularCurve
+namespace Mmr73
+
+open ModularCurve.Es1a1 ModularCurve.Mmr46 ModularCurve.Mmr48 ModularCurve.Mmr72
+
+universe u
+
+section PlaceEval
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+public theorem mmr73_cs_ord_neg (v : Place K F) (h : F) : v.ord (-h) = v.ord h := by
+  have _pin := Classical.em True
+  rcases eq_or_ne h 0 with rfl | hh
+  · rw [_root_.neg_zero]
+  · have h2 : v.ord (-h * -h) = v.ord (h * h) := by rw [neg_mul_neg]
+    rw [v.ord_mul (neg_ne_zero.mpr hh) (neg_ne_zero.mpr hh), v.ord_mul hh hh] at h2
+    omega
+
+public theorem mmr73_cs_evalAt_eq_of_ord_sub_pos (v : Place K F) (hv : v.IsRational)
+    {f : F} {a : K} (hf : f ∈ v.toValuationSubring)
+    (hpos : 0 < v.ord (f - algebraMap K F a)) : v.evalAt f = a := by
+  have _pin := Classical.em True
+  by_contra hne
+  rcases eq_or_ne (f - algebraMap K F (v.evalAt f)) 0 with h0 | hne0
+  · have hfa : f - algebraMap K F a = algebraMap K F (v.evalAt f - a) := by
+      rw [map_sub, ← sub_eq_zero.mp h0]
+    rw [hfa, AlgebraicCurve.Place.ord_algebraMap v] at hpos
+    exact lt_irrefl 0 hpos
+  · have hpos2 : 0 < v.ord (f - algebraMap K F (v.evalAt f)) :=
+      v.ord_sub_evalAt_pos hv hf hne0
+    have hkey : algebraMap K F (v.evalAt f - a)
+        = (f - algebraMap K F a) + -(f - algebraMap K F (v.evalAt f)) := by
+      rw [map_sub]; ring
+    have hne2 : algebraMap K F (v.evalAt f - a) ≠ 0 := fun hcon =>
+      hne (sub_eq_zero.mp ((algebraMap K F).injective
+        (by rw [hcon, _root_.map_zero])))
+    have hmin := v.min_ord_le_ord_add'
+      (f := f - algebraMap K F a)
+      (g := -(f - algebraMap K F (v.evalAt f)))
+      (by rw [← hkey]; exact hne2)
+    rw [← hkey, AlgebraicCurve.Place.ord_algebraMap v, mmr73_cs_ord_neg] at hmin
+    exact absurd hmin (not_le.mpr (lt_min hpos hpos2))
+
+end PlaceEval
+
+section EvaluationSeam
+
+attribute [local instance] ModularCurve.Es1a1.instDecEqFunctionFieldEs1a6Add
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+public theorem mmr73_cs_iota_ne_zero (D : IsogenyEndDatum W) {f : W.FunctionField}
+    (hf : f ≠ 0) : D.ι f ≠ 0 := by
+  have _pin := Classical.em True
+  intro hcon
+  exact hf (RingHom.injective
+    (D.ι : W.FunctionField →+* W.FunctionField)
+    (hcon.trans (_root_.map_zero
+      (D.ι : W.FunctionField →+* W.FunctionField)).symm))
+
+omit [DecidableEq F] [CharZero F] [W.AbelTheorem] in
+theorem mmr73_cs_geomMorph_ne_zero (D : IsogenyEndDatum W) (Q : W.Point)
+    (hx : D.ι (polyToFunctionField W X) ∈ (placeOfPoint Q).toValuationSubring) :
+    D.geomMorph Q ≠ 0 := by
+  have _pin := Classical.em True
+  intro hcon
+  have hseam := D.placeOfPoint_geomMorph Q
+  rw [hcon, Point.zero_def, placeOfPoint_zero] at hseam
+  have hxmem : polyToFunctionField W X
+      ∈ ((placeOfPoint Q).restrictAlong D.ι D.hι).toValuationSubring :=
+    (Place.mem_restrictAlong_iff D.ι D.hι (placeOfPoint Q)
+      (polyToFunctionField W X)).mpr hx
+  rw [hseam] at hxmem
+  exact InfinitePlace.not_isFinitePlace (isFinitePlace_of_mem _ hxmem)
+
+omit [DecidableEq F] [W.AbelTheorem] in
+public theorem mmr73_cs_geomMorph_some_coords (D : IsogenyEndDatum W) (Q : W.Point)
+    {a b : F} {hab : W.Nonsingular a b}
+    (hQ : D.geomMorph Q = Point.some a b hab)
+    (hx : D.ι (polyToFunctionField W X) ∈ (placeOfPoint Q).toValuationSubring)
+    (hy : D.ι (yGen W) ∈ (placeOfPoint Q).toValuationSubring) :
+    (placeOfPoint Q).evalAt (D.ι (polyToFunctionField W X)) = a
+      ∧ (placeOfPoint Q).evalAt (D.ι (yGen W)) = b := by
+  have _pin := Classical.em True
+  have hrat : (placeOfPoint Q).IsRational :=
+    (placeOfPoint Q).isRational_of_deg_eq_one (deg_placeOfPoint Q)
+  have hseam := D.placeOfPoint_geomMorph Q
+  rw [hQ, placeOfPoint_some] at hseam
+  have hXsub_eq : polyToFunctionField W X - algebraMap F W.FunctionField a
+      = algebraMap W.CoordinateRing W.FunctionField
+          (CoordinateRing.mk W (C (X - C a))) := by
+    rw [← polyToFunctionField_C (W := W) a, ← map_sub, polyToFunctionField_apply,
+      algebraMap_polynomial_eq_mk_C]
+  have hXmk_ne : CoordinateRing.mk W (C (X - C a)) ≠ 0 := by
+    intro hcon
+    apply polyToFunctionField_ne_zero (W := W) (Polynomial.X_sub_C_ne_zero a)
+    rw [polyToFunctionField_apply, algebraMap_polynomial_eq_mk_C, hcon, _root_.map_zero]
+  have hposX : 0 < (placeOfEquation hab.left).ord
+      (polyToFunctionField W X - algebraMap F W.FunctionField a) := by
+    rw [hXsub_eq, ord_placeOfEquation_pos_iff hab.left hXmk_ne,
+      mk_mem_XYIdeal_iff hab.left]
+    simp [Polynomial.evalEval]
+  have hposwX : 0 < (placeOfPoint Q).ord
+      (D.ι (polyToFunctionField W X) - algebraMap F W.FunctionField a) := by
+    have hmap : D.ι (polyToFunctionField W X) - algebraMap F W.FunctionField a
+        = D.ι (polyToFunctionField W X - algebraMap F W.FunctionField a) := by
+      rw [map_sub, AlgHom.commutes]
+    rw [hmap, Place.ord_restrictAlong D.ι D.hι (placeOfPoint Q), hseam]
+    exact mul_pos
+      (by exact_mod_cast Place.ramificationIndexAlong_pos D.ι D.hι (placeOfPoint Q))
+      hposX
+  have hYsub_eq : yGen W - algebraMap F W.FunctionField b
+      = algebraMap W.CoordinateRing W.FunctionField
+          (CoordinateRing.mk W (Y - C (C b))) := by
+    have h2 : algebraMap F W.FunctionField b
+        = algebraMap W.CoordinateRing W.FunctionField
+            (CoordinateRing.mk W (C (C b))) := by
+      rw [← polyToFunctionField_C (W := W) b, polyToFunctionField_apply,
+        algebraMap_polynomial_eq_mk_C]
+    unfold yGen
+    rw [h2, ← map_sub, ← map_sub]
+  have hYmk_ne : CoordinateRing.mk W (Y - C (C b)) ≠ 0 := by
+    intro hcon
+    have hrep : CoordinateRing.mk W (Y - C (C b))
+        = (-(C b) : F[X]) • (1 : W.CoordinateRing)
+          + (1 : F[X]) • CoordinateRing.mk W Y := by
+      rw [one_smul, Algebra.smul_def, mul_one, algebraMap_polynomial_eq_mk_C,
+        map_sub, _root_.map_neg, _root_.map_neg]
+      ring
+    rw [hrep] at hcon
+    exact one_ne_zero (CoordinateRing.smul_basis_eq_zero hcon).2
+  have hposY : 0 < (placeOfEquation hab.left).ord
+      (yGen W - algebraMap F W.FunctionField b) := by
+    rw [hYsub_eq, ord_placeOfEquation_pos_iff hab.left hYmk_ne,
+      mk_mem_XYIdeal_iff hab.left]
+    simp [Polynomial.evalEval]
+  have hposwY : 0 < (placeOfPoint Q).ord
+      (D.ι (yGen W) - algebraMap F W.FunctionField b) := by
+    have hmap : D.ι (yGen W) - algebraMap F W.FunctionField b
+        = D.ι (yGen W - algebraMap F W.FunctionField b) := by
+      rw [map_sub, AlgHom.commutes]
+    rw [hmap, Place.ord_restrictAlong D.ι D.hι (placeOfPoint Q), hseam]
+    exact mul_pos
+      (by exact_mod_cast Place.ramificationIndexAlong_pos D.ι D.hι (placeOfPoint Q))
+      hposY
+  exact ⟨mmr73_cs_evalAt_eq_of_ord_sub_pos (placeOfPoint Q) hrat hx hposwX,
+    mmr73_cs_evalAt_eq_of_ord_sub_pos (placeOfPoint Q) hrat hy hposwY⟩
+
+omit [W.AbelTheorem] in
+theorem mmr73_cs_geomMorph_add_eq_of_addSum_const (D₁ D₂ : IsogenyEndDatum W)
+    (hX : D₁.ι (polyToFunctionField W X) ≠ D₂.ι (polyToFunctionField W X))
+    {c d : F} (hcd : W.Nonsingular c d)
+    (hx : es1a6_addSumX W D₁.ι D₂.ι = algebraMap F W.FunctionField c)
+    (hy : es1a6_addSumY W D₁.ι D₂.ι = algebraMap F W.FunctionField d)
+    (Q : W.Point)
+    (h1 : (placeOfPoint Q).ord (D₁.ι (polyToFunctionField W X)) = 0)
+    (h2 : (placeOfPoint Q).ord (D₂.ι (polyToFunctionField W X)) = 0)
+    (h3 : (placeOfPoint Q).ord (D₁.ι (yGen W)) = 0)
+    (h4 : (placeOfPoint Q).ord (D₂.ι (yGen W)) = 0)
+    (h5 : (placeOfPoint Q).ord
+      (D₁.ι (polyToFunctionField W X) - D₂.ι (polyToFunctionField W X)) = 0) :
+    D₁.geomMorph Q + D₂.geomMorph Q = Point.some c d hcd := by
+  have _pin := Classical.em True
+  have hrat : (placeOfPoint Q).IsRational :=
+    (placeOfPoint Q).isRational_of_deg_eq_one (deg_placeOfPoint Q)
+  have hxne : polyToFunctionField W X ≠ 0 :=
+    polyToFunctionField_ne_zero Polynomial.X_ne_zero
+  have hyne : yGen W ≠ 0 := Y_image_ne_zero
+  have hf₁ne : D₁.ι (polyToFunctionField W X) ≠ 0 := mmr73_cs_iota_ne_zero D₁ hxne
+  have hf₂ne : D₂.ι (polyToFunctionField W X) ≠ 0 := mmr73_cs_iota_ne_zero D₂ hxne
+  have hg₁ne : D₁.ι (yGen W) ≠ 0 := mmr73_cs_iota_ne_zero D₁ hyne
+  have hg₂ne : D₂.ι (yGen W) ≠ 0 := mmr73_cs_iota_ne_zero D₂ hyne
+  have hδne : D₁.ι (polyToFunctionField W X) - D₂.ι (polyToFunctionField W X) ≠ 0 :=
+    sub_ne_zero.mpr hX
+  have hm₁x : D₁.ι (polyToFunctionField W X) ∈ (placeOfPoint Q).toValuationSubring :=
+    AlgebraicCurve.Place.mem_of_ord_nonneg (placeOfPoint Q) hf₁ne h1.ge
+  have hm₂x : D₂.ι (polyToFunctionField W X) ∈ (placeOfPoint Q).toValuationSubring :=
+    AlgebraicCurve.Place.mem_of_ord_nonneg (placeOfPoint Q) hf₂ne h2.ge
+  have hm₁y : D₁.ι (yGen W) ∈ (placeOfPoint Q).toValuationSubring :=
+    AlgebraicCurve.Place.mem_of_ord_nonneg (placeOfPoint Q) hg₁ne h3.ge
+  have hm₂y : D₂.ι (yGen W) ∈ (placeOfPoint Q).toValuationSubring :=
+    AlgebraicCurve.Place.mem_of_ord_nonneg (placeOfPoint Q) hg₂ne h4.ge
+  have hsome₁ : ∃ (a b : F) (hab : W.Nonsingular a b),
+      D₁.geomMorph Q = Point.some a b hab := by
+    rcases hP : D₁.geomMorph Q with _ | ⟨a, b, hab⟩
+    · exact absurd (by rw [hP]; exact Point.zero_def.symm)
+        (mmr73_cs_geomMorph_ne_zero D₁ Q hm₁x)
+    · exact ⟨a, b, hab, rfl⟩
+  have hsome₂ : ∃ (a b : F) (hab : W.Nonsingular a b),
+      D₂.geomMorph Q = Point.some a b hab := by
+    rcases hP : D₂.geomMorph Q with _ | ⟨a, b, hab⟩
+    · exact absurd (by rw [hP]; exact Point.zero_def.symm)
+        (mmr73_cs_geomMorph_ne_zero D₂ Q hm₂x)
+    · exact ⟨a, b, hab, rfl⟩
+  obtain ⟨a₁, b₁, hab₁, hP₁⟩ := hsome₁
+  obtain ⟨a₂, b₂, hab₂, hP₂⟩ := hsome₂
+  obtain ⟨ha₁, hb₁⟩ := mmr73_cs_geomMorph_some_coords D₁ Q hP₁ hm₁x hm₁y
+  obtain ⟨ha₂, hb₂⟩ := mmr73_cs_geomMorph_some_coords D₂ Q hP₂ hm₂x hm₂y
+  have hsubne : (placeOfPoint Q).evalAt
+      (D₁.ι (polyToFunctionField W X) - D₂.ι (polyToFunctionField W X)) ≠ 0 :=
+    (placeOfPoint Q).evalAt_ne_zero hrat hδne h5
+  have hsubeq : (placeOfPoint Q).evalAt
+      (D₁.ι (polyToFunctionField W X) - D₂.ι (polyToFunctionField W X))
+      = a₁ - a₂ := by
+    rw [(placeOfPoint Q).evalAt_sub hrat hm₁x hm₂x, ha₁, ha₂]
+  have hane' : a₁ - a₂ ≠ 0 := hsubeq ▸ hsubne
+  have hane : a₁ ≠ a₂ := sub_ne_zero.mp hane'
+  obtain ⟨Λ, hΛdef⟩ : ∃ L : W.FunctionField, L = (D₁.ι (yGen W) - D₂.ι (yGen W))
+      / (D₁.ι (polyToFunctionField W X) - D₂.ι (polyToFunctionField W X)) :=
+    ⟨_, rfl⟩
+  have hδinvord : (0 : ℤ) ≤ (placeOfPoint Q).ord
+      ((D₁.ι (polyToFunctionField W X) - D₂.ι (polyToFunctionField W X))⁻¹) := by
+    simp [(placeOfPoint Q).ord_inv, h5]
+  have hΛmem : Λ ∈ (placeOfPoint Q).toValuationSubring := by
+    rw [hΛdef, div_eq_mul_inv]
+    exact mul_mem (sub_mem hm₁y hm₂y)
+      (AlgebraicCurve.Place.mem_of_ord_nonneg (placeOfPoint Q) (inv_ne_zero hδne) hδinvord)
+  have hΛmul : Λ * (D₁.ι (polyToFunctionField W X) - D₂.ι (polyToFunctionField W X))
+      = D₁.ι (yGen W) - D₂.ι (yGen W) := by
+    rw [hΛdef]
+    exact div_mul_cancel₀ _ hδne
+  have hslope : W.slope a₁ a₂ b₁ b₂ = (placeOfPoint Q).evalAt Λ := by
+    rw [slope_of_X_ne hane, div_eq_iff hane', ← hb₁, ← hb₂,
+      ← (placeOfPoint Q).evalAt_sub hrat hm₁y hm₂y, ← hsubeq,
+      ← (placeOfPoint Q).evalAt_mul hrat hΛmem (sub_mem hm₁x hm₂x), hΛmul]
+  have hΛΛ : Λ * Λ ∈ (placeOfPoint Q).toValuationSubring := mul_mem hΛmem hΛmem
+  have hA1Λ : algebraMap F W.FunctionField W.a₁ * Λ
+      ∈ (placeOfPoint Q).toValuationSubring :=
+    mul_mem ((placeOfPoint Q).algebraMap_mem' W.a₁) hΛmem
+  have hu1 : Λ * Λ + algebraMap F W.FunctionField W.a₁ * Λ
+      ∈ (placeOfPoint Q).toValuationSubring := add_mem hΛΛ hA1Λ
+  have hu2 : Λ * Λ + algebraMap F W.FunctionField W.a₁ * Λ
+      - algebraMap F W.FunctionField W.a₂
+      ∈ (placeOfPoint Q).toValuationSubring :=
+    sub_mem hu1 ((placeOfPoint Q).algebraMap_mem' W.a₂)
+  have hu3 : Λ * Λ + algebraMap F W.FunctionField W.a₁ * Λ
+      - algebraMap F W.FunctionField W.a₂ - D₁.ι (polyToFunctionField W X)
+      ∈ (placeOfPoint Q).toValuationSubring := sub_mem hu2 hm₁x
+  have hU : Λ * Λ + algebraMap F W.FunctionField W.a₁ * Λ
+      - algebraMap F W.FunctionField W.a₂ - D₁.ι (polyToFunctionField W X)
+      - D₂.ι (polyToFunctionField W X)
+      ∈ (placeOfPoint Q).toValuationSubring := sub_mem hu3 hm₂x
+  have hBX : (placeOfPoint Q).evalAt
+      (Λ * Λ + algebraMap F W.FunctionField W.a₁ * Λ
+        - algebraMap F W.FunctionField W.a₂ - D₁.ι (polyToFunctionField W X)
+        - D₂.ι (polyToFunctionField W X))
+      = (placeOfPoint Q).evalAt Λ * (placeOfPoint Q).evalAt Λ
+        + W.a₁ * (placeOfPoint Q).evalAt Λ - W.a₂ - a₁ - a₂ := by
+    rw [(placeOfPoint Q).evalAt_sub hrat hu3 hm₂x,
+      (placeOfPoint Q).evalAt_sub hrat hu2 hm₁x,
+      (placeOfPoint Q).evalAt_sub hrat hu1 ((placeOfPoint Q).algebraMap_mem' W.a₂),
+      (placeOfPoint Q).evalAt_add hrat hΛΛ hA1Λ,
+      (placeOfPoint Q).evalAt_mul hrat hΛmem hΛmem,
+      (placeOfPoint Q).evalAt_mul hrat ((placeOfPoint Q).algebraMap_mem' W.a₁) hΛmem,
+      (placeOfPoint Q).evalAt_algebraMap W.a₁,
+      (placeOfPoint Q).evalAt_algebraMap W.a₂, ha₁, ha₂]
+  have hX0 : es1a6_addSumX W D₁.ι D₂.ι
+      = Λ * Λ + algebraMap F W.FunctionField W.a₁ * Λ
+        - algebraMap F W.FunctionField W.a₂ - D₁.ι (polyToFunctionField W X)
+        - D₂.ι (polyToFunctionField W X) := by
+    unfold es1a6_addSumX
+    rw [slope_of_X_ne hX, ← hΛdef]
+    simp only [addX, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂]
+    ring
+  have hY0 : es1a6_addSumY W D₁.ι D₂.ι
+      = -(Λ * ((Λ * Λ + algebraMap F W.FunctionField W.a₁ * Λ
+            - algebraMap F W.FunctionField W.a₂
+            - D₁.ι (polyToFunctionField W X) - D₂.ι (polyToFunctionField W X))
+          - D₁.ι (polyToFunctionField W X)) + D₁.ι (yGen W))
+        - algebraMap F W.FunctionField W.a₁
+            * (Λ * Λ + algebraMap F W.FunctionField W.a₁ * Λ
+              - algebraMap F W.FunctionField W.a₂
+              - D₁.ι (polyToFunctionField W X) - D₂.ι (polyToFunctionField W X))
+        - algebraMap F W.FunctionField W.a₃ := by
+    unfold es1a6_addSumY
+    rw [slope_of_X_ne hX, ← hΛdef]
+    simp only [addY, negAddY, negY, addX, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂,
+      WeierstrassCurve.map_a₃]
+    ring
+  have hU1 : Λ * Λ + algebraMap F W.FunctionField W.a₁ * Λ
+      - algebraMap F W.FunctionField W.a₂ - D₁.ι (polyToFunctionField W X)
+      - D₂.ι (polyToFunctionField W X) - D₁.ι (polyToFunctionField W X)
+      ∈ (placeOfPoint Q).toValuationSubring := sub_mem hU hm₁x
+  have hV : Λ * (Λ * Λ + algebraMap F W.FunctionField W.a₁ * Λ
+        - algebraMap F W.FunctionField W.a₂ - D₁.ι (polyToFunctionField W X)
+        - D₂.ι (polyToFunctionField W X) - D₁.ι (polyToFunctionField W X))
+      + D₁.ι (yGen W)
+      ∈ (placeOfPoint Q).toValuationSubring :=
+    add_mem (mul_mem hΛmem hU1) hm₁y
+  have hW1 : -(Λ * (Λ * Λ + algebraMap F W.FunctionField W.a₁ * Λ
+          - algebraMap F W.FunctionField W.a₂ - D₁.ι (polyToFunctionField W X)
+          - D₂.ι (polyToFunctionField W X) - D₁.ι (polyToFunctionField W X))
+        + D₁.ι (yGen W))
+      - algebraMap F W.FunctionField W.a₁
+          * (Λ * Λ + algebraMap F W.FunctionField W.a₁ * Λ
+            - algebraMap F W.FunctionField W.a₂
+            - D₁.ι (polyToFunctionField W X) - D₂.ι (polyToFunctionField W X))
+      ∈ (placeOfPoint Q).toValuationSubring :=
+    sub_mem (neg_mem hV)
+      (mul_mem ((placeOfPoint Q).algebraMap_mem' W.a₁) hU)
+  have hBY : (placeOfPoint Q).evalAt
+      (-(Λ * ((Λ * Λ + algebraMap F W.FunctionField W.a₁ * Λ
+            - algebraMap F W.FunctionField W.a₂
+            - D₁.ι (polyToFunctionField W X) - D₂.ι (polyToFunctionField W X))
+          - D₁.ι (polyToFunctionField W X)) + D₁.ι (yGen W))
+        - algebraMap F W.FunctionField W.a₁
+            * (Λ * Λ + algebraMap F W.FunctionField W.a₁ * Λ
+              - algebraMap F W.FunctionField W.a₂
+              - D₁.ι (polyToFunctionField W X) - D₂.ι (polyToFunctionField W X))
+        - algebraMap F W.FunctionField W.a₃)
+      = -((placeOfPoint Q).evalAt Λ
+            * (((placeOfPoint Q).evalAt Λ * (placeOfPoint Q).evalAt Λ
+                + W.a₁ * (placeOfPoint Q).evalAt Λ - W.a₂ - a₁ - a₂) - a₁) + b₁)
+        - W.a₁ * ((placeOfPoint Q).evalAt Λ * (placeOfPoint Q).evalAt Λ
+            + W.a₁ * (placeOfPoint Q).evalAt Λ - W.a₂ - a₁ - a₂)
+        - W.a₃ := by
+    rw [(placeOfPoint Q).evalAt_sub hrat hW1 ((placeOfPoint Q).algebraMap_mem' W.a₃),
+      (placeOfPoint Q).evalAt_sub hrat (neg_mem hV)
+        (mul_mem ((placeOfPoint Q).algebraMap_mem' W.a₁) hU),
+      (placeOfPoint Q).evalAt_neg hrat hV,
+      (placeOfPoint Q).evalAt_add hrat (mul_mem hΛmem hU1) hm₁y,
+      (placeOfPoint Q).evalAt_mul hrat hΛmem hU1,
+      (placeOfPoint Q).evalAt_sub hrat hU hm₁x,
+      (placeOfPoint Q).evalAt_mul hrat ((placeOfPoint Q).algebraMap_mem' W.a₁) hU,
+      hBX, (placeOfPoint Q).evalAt_algebraMap W.a₁,
+      (placeOfPoint Q).evalAt_algebraMap W.a₃, ha₁, hb₁]
+  rw [hP₁, hP₂, Point.add_of_X_ne hane]
+  refine mmr48_sp_point_some_congr ?_ ?_ _ hcd
+  · rw [hslope]
+    have h0 : (placeOfPoint Q).evalAt (es1a6_addSumX W D₁.ι D₂.ι) = c := by
+      rw [hx, (placeOfPoint Q).evalAt_algebraMap c]
+    rw [hX0, hBX] at h0
+    rw [← h0]
+    simp only [addX]
+    ring
+  · rw [hslope]
+    have h0 : (placeOfPoint Q).evalAt (es1a6_addSumY W D₁.ι D₂.ι) = d := by
+      rw [hy, (placeOfPoint Q).evalAt_algebraMap d]
+    rw [hY0, hBY] at h0
+    rw [← h0]
+    simp only [addY, negAddY, negY, addX]
+    ring
+
+end EvaluationSeam
+
+section CofiniteEngine
+
+variable {F : Type u} [Field F] {W : Affine F} [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+
+theorem mmr73_cs_finite_setOf_placeOfPoint_ord_ne_zero
+    [HasPrincipalDivisors F W.FunctionField] {f : W.FunctionField} (hf : f ≠ 0) :
+    {Q : W.Point | (placeOfPoint Q).ord f ≠ 0}.Finite := by
+  have _pin := Classical.em True
+  obtain ⟨Df, hDf, -⟩ :=
+    HasPrincipalDivisors.exists_divisor (K := F) (F := W.FunctionField) f hf
+  refine Set.Finite.subset
+    (Set.Finite.preimage placeOfPoint_injective.injOn Df.support.finite_toSet) ?_
+  intro Q hQ
+  simp only [Set.mem_preimage, Finset.mem_coe, Finsupp.mem_support_iff]
+  rw [hDf]
+  exact hQ
+
+end CofiniteEngine
+end Mmr73
+end ModularCurve
+end
+end
+
+section
+
+section
+
+namespace ModularCurve
+
+namespace Es1a1
+
+universe u
+
+section InputSeam
+
+variable {F : Type u} [Field F] [IsAlgClosed F] {W : Affine F} [W.IsElliptic]
+    [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W]
+
+public theorem kw_coordSeamDataAt_geomMorph (D : IsogenyEndDatum W) (P : W.Point) :
+    es1a11_coordSeamDataAt D.ι (placeOfPoint P) (D.geomMorph P) :=
+  (es1a11_coordSeamDataAt_iff_pbd D.ι (placeOfPoint P) (D.geomMorph P)).mpr
+    (es1a8_coordSeamDataAt_of_restrictAlong_pbd D.ι D.hι (placeOfPoint P)
+      (D.geomMorph P) (D.placeOfPoint_geomMorph P))
+
+end InputSeam
+end Es1a1
+end ModularCurve
+end
+end
+
+section
+
+section
+
+namespace ModularCurve
+namespace Es1a1
+
+universe u
+
+section AddLawCoreCmp
+
+variable {F : Type u} [Field F]
+
+variable (W : WeierstrassCurve.Affine F)
+
+variable (φ₁ φ₂ : W.FunctionField →ₐ[F] W.FunctionField)
+
+@[expose] public def es1a8_addCollapse_cmp : Prop :=
+  φ₁ (polyToFunctionField W X) = φ₂ (polyToFunctionField W X) ∧
+    φ₁ (yGen W) = (W.map (algebraMap F W.FunctionField)).toAffine.negY
+      (φ₂ (polyToFunctionField W X)) (φ₂ (yGen W))
+
+end AddLawCoreCmp
+
+section HomExtCmp
+
+variable {F : Type u} [Field F]
+
+public theorem es1a8_functionField_algHom_ext_cmp {W : WeierstrassCurve.Affine F}
+    {φ ψ : W.FunctionField →ₐ[F] W.FunctionField}
+    (hX : φ (polyToFunctionField W X) = ψ (polyToFunctionField W X))
+    (hY : φ (yGen W) = ψ (yGen W)) : φ = ψ := by
+  have hpoly : ∀ p : F[X],
+      φ (polyToFunctionField W p) = ψ (polyToFunctionField W p) := by
+    intro p
+    rw [polyToFunctionField_eq_aeval (W := W) p, ← Polynomial.aeval_algHom_apply,
+      ← Polynomial.aeval_algHom_apply, hX]
+  have hcoord : ∀ r : W.CoordinateRing,
+      φ (algebraMap W.CoordinateRing W.FunctionField r)
+        = ψ (algebraMap W.CoordinateRing W.FunctionField r) := by
+    intro r
+    obtain ⟨p, q, rfl⟩ := CoordinateRing.exists_smul_basis_eq r
+    rw [algebraMap_smul_basis,
+      show algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) = yGen W
+        from rfl]
+    simp only [map_add, map_mul, hpoly, hY]
+  refine AlgHom.ext fun z => ?_
+  obtain ⟨r, s, _, hrs⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  rw [← hrs, map_div₀, map_div₀, hcoord r, hcoord s]
+
+theorem es1a8_negYGen_map_cmp (W : WeierstrassCurve.Affine F)
+    (φ : W.FunctionField →ₐ[F] W.FunctionField) :
+    φ (es1a4_negYGen W)
+      = (W.map (algebraMap F W.FunctionField)).toAffine.negY
+          (φ (polyToFunctionField W X)) (φ (yGen W)) := by
+  rw [es1a4_negYGen_eq]
+  simp only [map_sub, _root_.map_neg, map_mul, AlgHom.commutes, negY,
+    WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₃]
+
+theorem es1a8_addCollapse_iota_comp_cmp {W : WeierstrassCurve.Affine F}
+    {φ₁ φ₂ : W.FunctionField →ₐ[F] W.FunctionField}
+    (hcol : es1a8_addCollapse_cmp W φ₁ φ₂) :
+    φ₁ = φ₂.comp (es1a4_negPullbackHom W) := by
+  refine es1a8_functionField_algHom_ext_cmp ?_ ?_
+  · rw [AlgHom.comp_apply, es1a4_negPullbackHom_X]
+    exact hcol.1
+  · rw [AlgHom.comp_apply, es1a4_negPullbackHom_yGen, es1a8_negYGen_map_cmp]
+    exact hcol.2
+
+theorem es1a8_restrictAlong_congr_cmp {K L : Type*} [Field K] [Field L] [Algebra K L]
+    (w : AlgebraicCurve.Place K L) {ι₁ ι₂ : L →ₐ[K] L} (h : ι₁ = ι₂)
+    (h₁ : ι₁.toRingHom.IsIntegral) (h₂ : ι₂.toRingHom.IsIntegral) :
+    w.restrictAlong ι₁ h₁ = w.restrictAlong ι₂ h₂ := by
+  subst h
+  rfl
+
+end HomExtCmp
+
+section CollapseHalfCmp
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : WeierstrassCurve.Affine F} [W.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+theorem es1a8_addCollapse_geomMorph_eq_neg_cmp (D₁ D₂ : IsogenyEndDatum W)
+    (hcol : es1a8_addCollapse_cmp W D₁.ι D₂.ι) (P : W.Point) :
+    D₁.geomMorph P = -(D₂.geomMorph P) := by
+  have hcomp : D₁.ι = D₂.ι.comp (es1a4_negPullbackHom W) :=
+    es1a8_addCollapse_iota_comp_cmp hcol
+  have hι' : (D₂.ι.comp (es1a4_negPullbackHom W)).toRingHom.IsIntegral :=
+    hcomp ▸ D₁.hι
+  refine placeOfPoint_injective ?_
+  calc placeOfPoint (D₁.geomMorph P)
+      = (placeOfPoint P).restrictAlong D₁.ι D₁.hι :=
+        (D₁.placeOfPoint_geomMorph P).symm
+    _ = (placeOfPoint P).restrictAlong (D₂.ι.comp (es1a4_negPullbackHom W)) hι' :=
+        es1a8_restrictAlong_congr_cmp _ hcomp _ _
+    _ = ((placeOfPoint P).restrictAlong D₂.ι D₂.hι).restrictAlong
+          (es1a4_negPullbackHom W) (es1a4_negPullbackHom_isIntegral W) :=
+        AlgebraicCurve.Place.restrictAlong_comp (es1a4_negPullbackHom W) D₂.ι
+          (es1a4_negPullbackHom_isIntegral W) D₂.hι hι' (placeOfPoint P)
+    _ = (placeOfPoint (D₂.geomMorph P)).restrictAlong
+          (es1a4_negPullbackHom W) (es1a4_negPullbackHom_isIntegral W) := by
+        rw [D₂.placeOfPoint_geomMorph P]
+    _ = placeOfPoint (-(D₂.geomMorph P)) := es1a4_negDatum_seam (D₂.geomMorph P)
+
+public theorem es1a8_addCollapse_pointEnd_add_eq_zero_cmp (D₁ D₂ : IsogenyEndDatum W)
+    (hcol : es1a8_addCollapse_cmp W D₁.ι D₂.ι) :
+    D₁.pointEnd' + D₂.pointEnd' = 0 := by
+  refine AddMonoidHom.ext fun P => ?_
+  change D₁.pointEnd' P + D₂.pointEnd' P = 0
+  rw [D₁.pointEnd_eq_geomMorph_sub_geomMorph_zero P,
+    D₂.pointEnd_eq_geomMorph_sub_geomMorph_zero P,
+    es1a8_addCollapse_geomMorph_eq_neg_cmp D₁ D₂ hcol P,
+    es1a8_addCollapse_geomMorph_eq_neg_cmp D₁ D₂ hcol 0]
+  abel
+
+theorem es1a8_add_not_collapse_of_pointEnd_add_ne_zero_cmp (D₁ D₂ : IsogenyEndDatum W)
+    (h0 : D₁.pointEnd' + D₂.pointEnd' ≠ 0) :
+    ¬ es1a8_addCollapse_cmp W D₁.ι D₂.ι :=
+  fun hcol => h0 (es1a8_addCollapse_pointEnd_add_eq_zero_cmp D₁ D₂ hcol)
+
+end CollapseHalfCmp
+
+section IntegralityEngineCmp
+
+variable {F : Type u} [Field F] {W : WeierstrassCurve.Affine F}
+
+theorem es1a8_addInt_coordRing_isAlgebraic_cmp :
+    Algebra.IsAlgebraic F[X] W.CoordinateRing := by
+  have : Module.Finite F[X] W.CoordinateRing :=
+    Module.Finite.of_basis (CoordinateRing.basis W)
+  have : Algebra.IsIntegral F[X] W.CoordinateRing := Algebra.IsIntegral.of_finite _ _
+  exact Algebra.IsIntegral.isAlgebraic
+
+theorem es1a8_addInt_functionField_isAlgebraic_cmp :
+    Algebra.IsAlgebraic W.CoordinateRing W.FunctionField := by
+  constructor
+  intro z
+  obtain ⟨a, b, hb, hab⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  have hbne : algebraMap W.CoordinateRing W.FunctionField b ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr
+      (nonZeroDivisors.ne_zero hb)
+  refine ⟨Polynomial.C b * Polynomial.X - Polynomial.C a, ?_, ?_⟩
+  · intro hcon
+    have h1 := congrArg (fun q => Polynomial.coeff q 1) hcon
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_C_mul, Polynomial.coeff_X_one,
+      Polynomial.coeff_C, Polynomial.coeff_zero, mul_one] at h1
+    norm_num at h1
+    exact nonZeroDivisors.ne_zero hb h1
+  · have ha : algebraMap W.CoordinateRing W.FunctionField a
+        = z * algebraMap W.CoordinateRing W.FunctionField b := by
+      rw [← hab]
+      exact (div_mul_cancel₀ _ hbne).symm
+    simp only [map_sub, map_mul, Polynomial.aeval_C, Polynomial.aeval_X, ha]
+    ring
+
+theorem es1a8_addInt_algebraMap_injective_cmp :
+    Function.Injective (algebraMap F[X] W.CoordinateRing) := by
+  intro p q h
+  have h0 : (p - q) • (1 : W.CoordinateRing) + (0 : F[X]) • CoordinateRing.mk W Y = 0 := by
+    rw [zero_smul, add_zero, sub_smul, ← Algebra.algebraMap_eq_smul_one,
+      ← Algebra.algebraMap_eq_smul_one, h, sub_self]
+  exact sub_eq_zero.mp (CoordinateRing.smul_basis_eq_zero h0).1
+
+theorem es1a8_addInt_basisX_cmp :
+    IsTranscendenceBasis F (fun _ : PUnit.{u + 1} => polyToFunctionField W X) := by
+  have h1 : Algebra.IsAlgebraic F[X] W.CoordinateRing :=
+    es1a8_addInt_coordRing_isAlgebraic_cmp (W := W)
+  have h2 : Algebra.IsAlgebraic W.CoordinateRing W.FunctionField :=
+    es1a8_addInt_functionField_isAlgebraic_cmp (W := W)
+  have h3 : FaithfulSMul F[X] W.CoordinateRing :=
+    (faithfulSMul_iff_algebraMap_injective F[X] W.CoordinateRing).mpr
+      es1a8_addInt_algebraMap_injective_cmp
+  have h4 : FaithfulSMul W.CoordinateRing W.FunctionField :=
+    (faithfulSMul_iff_algebraMap_injective W.CoordinateRing W.FunctionField).mpr
+      (IsFractionRing.injective W.CoordinateRing W.FunctionField)
+  have h5 := IsTranscendenceBasis.polynomial PUnit.{u + 1} F
+  have h6 := h5.algebraMap_comp (A := W.CoordinateRing)
+  have h7 := h6.algebraMap_comp (A := W.FunctionField)
+  have h8 : (fun _ : PUnit.{u + 1} => polyToFunctionField W X)
+      = (algebraMap W.CoordinateRing W.FunctionField
+          ∘ (algebraMap F[X] W.CoordinateRing ∘ fun _ : PUnit.{u + 1} => (X : F[X]))) :=
+    rfl
+  rw [h8]
+  exact h7
+
+theorem es1a8_addInt_basis_of_transcendental_cmp {z : W.FunctionField}
+    (hz : Transcendental F z) :
+    IsTranscendenceBasis F ((↑) : ({z} : Set W.FunctionField) → W.FunctionField) := by
+  have hind : AlgebraicIndepOn F id ({z} : Set W.FunctionField) :=
+    algebraicIndependent_unique_type_iff.mpr (by simpa using hz)
+  obtain ⟨t, hzt, ht⟩ := exists_isTranscendenceBasis_superset hind
+  have hcard : Cardinal.mk ↥t = Cardinal.mk PUnit.{u + 1} :=
+    IsTranscendenceBasis.cardinalMk_eq ht es1a8_addInt_basisX_cmp
+  have hsub : t.Subsingleton := by
+    have h1 : Cardinal.mk ↥t = 1 := by rw [hcard, Cardinal.mk_punit]
+    exact Cardinal.mk_le_one_iff_set_subsingleton.mp h1.le
+  have ht2 : t = {z} := hsub.eq_singleton_of_mem (hzt rfl)
+  rw [ht2] at ht
+  exact ht
+
+theorem es1a8_addInt_isAlgebraic_adjoin_cmp {z : W.FunctionField}
+    (hz : Transcendental F z) :
+    Algebra.IsAlgebraic (IntermediateField.adjoin F ({z} : Set W.FunctionField))
+      W.FunctionField := by
+  have h := (es1a8_addInt_basis_of_transcendental_cmp hz).isAlgebraic_field
+  rwa [Subtype.range_coe] at h
+
+theorem es1a8_addInt_selfHom_isIntegral_cmp (ι : W.FunctionField →ₐ[F] W.FunctionField)
+    (htr : Transcendental F (ι (polyToFunctionField W X))) :
+    ι.toRingHom.IsIntegral := by
+  intro w
+  have hint : _root_.IsIntegral (IntermediateField.adjoin F
+      ({ι (polyToFunctionField W X)} : Set W.FunctionField)) w :=
+    isAlgebraic_iff_isIntegral.mp
+      ((es1a8_addInt_isAlgebraic_adjoin_cmp htr).isAlgebraic w)
+  obtain ⟨p, hpm, hp0⟩ := hint
+  have hle : IntermediateField.adjoin F
+      ({ι (polyToFunctionField W X)} : Set W.FunctionField) ≤ ι.fieldRange :=
+    IntermediateField.adjoin_le_iff.mpr
+      (Set.singleton_subset_iff.mpr ⟨polyToFunctionField W X, rfl⟩)
+  refine ⟨p.map (((AlgEquiv.ofInjectiveField ι :
+      W.FunctionField ≃ₐ[F] ι.fieldRange)).symm.toAlgHom.comp
+    (IntermediateField.inclusion hle)).toRingHom, hpm.map _, ?_⟩
+  rw [Polynomial.eval₂_map]
+  have hcomp : ι.toRingHom.comp (((AlgEquiv.ofInjectiveField ι :
+      W.FunctionField ≃ₐ[F] ι.fieldRange)).symm.toAlgHom.comp
+      (IntermediateField.inclusion hle)).toRingHom
+      = algebraMap (IntermediateField.adjoin F
+          ({ι (polyToFunctionField W X)} : Set W.FunctionField)) W.FunctionField := by
+    refine RingHom.ext fun u => ?_
+    have h1 : (AlgEquiv.ofInjectiveField ι : W.FunctionField ≃ₐ[F] ι.fieldRange)
+        ((AlgEquiv.ofInjectiveField ι : W.FunctionField ≃ₐ[F] ι.fieldRange).symm
+          (IntermediateField.inclusion hle u))
+        = IntermediateField.inclusion hle u :=
+      (AlgEquiv.ofInjectiveField ι :
+        W.FunctionField ≃ₐ[F] ι.fieldRange).apply_symm_apply _
+    exact congrArg Subtype.val h1
+  rw [hcomp]
+  exact hp0
+
+theorem es1a8_addInt_selfHom_finiteAlong_cmp (ι : W.FunctionField →ₐ[F] W.FunctionField)
+    (htr : Transcendental F (ι (polyToFunctionField W X))) :
+    FiniteAlong F ι := by
+  have hint := es1a8_addInt_selfHom_isIntegral_cmp ι htr
+  let : Algebra W.FunctionField W.FunctionField := ι.toRingHom.toAlgebra
+  let : Module W.FunctionField W.FunctionField := Algebra.toModule
+  change Module.Finite W.FunctionField W.FunctionField
+  have hadj : IntermediateField.adjoin W.FunctionField
+      ({polyToFunctionField W X, yGen W} : Set W.FunctionField) = ⊤ := by
+    rw [eq_top_iff]
+    rintro z -
+    set L := IntermediateField.adjoin W.FunctionField
+      ({polyToFunctionField W X, yGen W} : Set W.FunctionField) with hL
+    have hconst : ∀ c : F, algebraMap F W.FunctionField c ∈ L := fun c => by
+      rw [← ι.commutes c]
+      exact L.algebraMap_mem _
+    have hxmem : polyToFunctionField W X ∈ L :=
+      IntermediateField.subset_adjoin _ _ (Set.mem_insert _ _)
+    have hymem : yGen W ∈ L :=
+      IntermediateField.subset_adjoin _ _ (Set.mem_insert_of_mem _ rfl)
+    have hpoly : ∀ p : F[X], polyToFunctionField W p ∈ L := fun p => by
+      induction p using Polynomial.induction_on' with
+      | add f g hf hg => rw [map_add]; exact add_mem hf hg
+      | monomial n c =>
+          rw [← C_mul_X_pow_eq_monomial, map_mul, map_pow, polyToFunctionField_C]
+          exact mul_mem (hconst c) (pow_mem hxmem n)
+    have hcr : ∀ r : W.CoordinateRing,
+        algebraMap W.CoordinateRing W.FunctionField r ∈ L := fun r => by
+      obtain ⟨p, q, rfl⟩ := CoordinateRing.exists_smul_basis_eq r
+      rw [algebraMap_smul_basis]
+      exact add_mem (hpoly p) (mul_mem (hpoly q) hymem)
+    obtain ⟨a, b, _, hab⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+    rw [← hab]
+    exact div_mem (hcr a) (hcr b)
+  have : Finite ({polyToFunctionField W X, yGen W} : Set W.FunctionField) :=
+    ((Set.finite_singleton (yGen W)).insert (polyToFunctionField W X)).to_subtype
+  have h1 : FiniteDimensional W.FunctionField
+      (IntermediateField.adjoin W.FunctionField
+        ({polyToFunctionField W X, yGen W} : Set W.FunctionField)) :=
+    IntermediateField.finiteDimensional_adjoin fun z _ => hint z
+  rw [hadj] at h1
+  exact (IntermediateField.topEquiv (F := W.FunctionField)
+    (E := W.FunctionField)).toLinearEquiv.finiteDimensional
+
+end IntegralityEngineCmp
+end Es1a1
+end ModularCurve
+end
+end
+
+section
+
+section
+
+namespace ModularCurve
+
+namespace Es1a1
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+public abbrev kw_hk5f_addSumXNonConstGuardAt : Prop :=
+  ∀ D₁ D₂ : IsogenyEndDatum W, D₁.pointEnd' + D₂.pointEnd' ≠ 0 →
+    ∀ c : F, es1a6_addSumX W D₁.ι D₂.ι ≠ algebraMap F W.FunctionField c
+
+abbrev kw_hk5f_addSumCoordSeamDataNCAt : Prop :=
+  ∀ φ₁ φ₂ : W.FunctionField →ₐ[F] W.FunctionField,
+    ¬ es1a6_addCollapse W φ₁ φ₂ →
+    (∀ c : F, es1a6_addSumX W φ₁ φ₂ ≠ algebraMap F W.FunctionField c) →
+    ∀ (v : AlgebraicCurve.Place F W.FunctionField) (Q₁ Q₂ : W.Point),
+      es1a11_coordSeamDataAt φ₁ v Q₁ → es1a11_coordSeamDataAt φ₂ v Q₂ →
+      es1a6_addSumSeamDataAt φ₁ φ₂ v (Q₁ + Q₂)
+
+public abbrev kw_hk5f_addIntegralFiniteDataAt : Prop :=
+  ∀ D₁ D₂ : IsogenyEndDatum W,
+    ∀ (hcol : ¬ es1a6_addCollapse W D₁.ι D₂.ι)
+      (htr : Function.Injective (Polynomial.aeval (R := F) (es1a6_addSumX W D₁.ι D₂.ι))),
+      (es1a6_addSumPullbackHom W D₁.ι D₂.ι hcol htr).toRingHom.IsIntegral ∧
+        FiniteAlong F (es1a6_addSumPullbackHom W D₁.ι D₂.ι hcol htr)
+
+theorem kw_hk5f_addGeomMorphSupply_of_atoms
+    (hg : kw_hk5f_addSumXNonConstGuardAt W)
+    (hncseam : kw_hk5f_addSumCoordSeamDataNCAt W)
+    (hifd : kw_hk5f_addIntegralFiniteDataAt W) :
+    KwIsogenyEndAddGeomMorphSupply W := by
+  intro D₁ D₂ h0
+  have hcol : ¬ es1a6_addCollapse W D₁.ι D₂.ι := by
+    have := es1a8_add_not_collapse_of_pointEnd_add_ne_zero_cmp D₁ D₂ h0
+    rwa [show es1a8_addCollapse_cmp W D₁.ι D₂.ι = es1a6_addCollapse W D₁.ι D₂.ι from rfl]
+      at this
+  have hnc := hg D₁ D₂ h0
+  have htr : Function.Injective
+      (Polynomial.aeval (R := F) (es1a6_addSumX W D₁.ι D₂.ι)) :=
+    es1a6_add_aeval_sumX_injective_of_forall_ne W D₁.ι D₂.ι hnc
+  obtain ⟨hι, hfin⟩ := hifd D₁ D₂ hcol htr
+  refine ⟨⟨es1a6_addSumPullbackHom W D₁.ι D₂.ι hcol htr, hι, hfin⟩, fun P => ?_⟩
+  have h1 := kw_coordSeamDataAt_geomMorph D₁ P
+  have h2 := kw_coordSeamDataAt_geomMorph D₂ P
+  have hsum := hncseam D₁.ι D₂.ι hcol hnc (placeOfPoint P)
+    (D₁.geomMorph P) (D₂.geomMorph P) h1 h2
+  have hseam := es1a6_addSumSeam_of_data D₁.ι D₂.ι hcol htr hι P
+    (D₁.geomMorph P + D₂.geomMorph P) hsum
+  exact placeOfPoint_injective
+    (((⟨_, hι, hfin⟩ : IsogenyEndDatum W).placeOfPoint_geomMorph P).symm.trans hseam)
+
+end Es1a1
+end ModularCurve
+end
+end
+
+section
+
+section
+
+namespace ModularCurve
+namespace Mmr62
+
+open ModularCurve.Es1a1
+
+section CollisionEngine
+
+attribute [local instance] ModularCurve.Es1a1.instDecEqFunctionFieldEs1a6Add
+
+universe u
+
+variable {F : Type u} [Field F]
+
+variable (W : WeierstrassCurve.Affine F)
+
+variable (φ₁ φ₂ : W.FunctionField →ₐ[F] W.FunctionField)
+
+theorem mmr62_cd_collision_yGen_eq
+    (hx : φ₁ (polyToFunctionField W X) = φ₂ (polyToFunctionField W X))
+    (hcol : ¬ es1a6_addCollapse W φ₁ φ₂) :
+    φ₁ (yGen W) = φ₂ (yGen W) := by
+  have _pin := Classical.em True
+  rcases Y_eq_of_X_eq (es1a6_add_equation W φ₁) (es1a6_add_equation W φ₂) hx with h | h
+  · exact h
+  · exact absurd ⟨hx, h⟩ hcol
+
+theorem mmr62_cd_phi_yGen_ne_negY [CharZero F]
+    (φ : W.FunctionField →ₐ[F] W.FunctionField) :
+    φ (yGen W) ≠ (W.map (algebraMap F W.FunctionField)).toAffine.negY
+      (φ (polyToFunctionField W X)) (φ (yGen W)) := by
+  have _pin := Classical.em True
+  have hmap : φ ((W.map (algebraMap F W.FunctionField)).toAffine.negY
+        (polyToFunctionField W X) (yGen W))
+      = (W.map (algebraMap F W.FunctionField)).toAffine.negY
+          (φ (polyToFunctionField W X)) (φ (yGen W)) := by
+    simp only [negY, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₃, map_sub, _root_.map_neg,
+      map_mul,
+      AlgHom.commutes]
+  intro hcon
+  have h2 : φ (yGen W)
+      = φ ((W.map (algebraMap F W.FunctionField)).toAffine.negY
+          (polyToFunctionField W X) (yGen W)) := by
+    rw [hmap]
+    exact hcon
+  exact endst20_ps_yGen_ne_negY W
+    (RingHom.injective (φ : W.FunctionField →+* W.FunctionField) h2)
+
+theorem mmr62_cd_map_dupSlope_eq_slope [CharZero F]
+    (φ : W.FunctionField →ₐ[F] W.FunctionField) :
+    φ (endst20_ps_dupSlope W)
+      = (W.map (algebraMap F W.FunctionField)).toAffine.slope
+          (φ (polyToFunctionField W X)) (φ (polyToFunctionField W X))
+          (φ (yGen W)) (φ (yGen W)) := by
+  have _pin := Classical.em True
+  rw [endst20_ps_dupSlope_eq_div W,
+    slope_of_Y_ne rfl (mmr62_cd_phi_yGen_ne_negY W φ)]
+  simp only [negY, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+    WeierstrassCurve.map_a₄,
+    map_div₀, map_add, map_sub, map_mul, map_pow, _root_.map_neg, map_ofNat,
+    AlgHom.commutes]
+
+theorem mmr62_cd_collision_addSumX_eq_map_dupX [CharZero F]
+    (hx : φ₁ (polyToFunctionField W X) = φ₂ (polyToFunctionField W X))
+    (hcol : ¬ es1a6_addCollapse W φ₁ φ₂) :
+    es1a6_addSumX W φ₁ φ₂ = φ₂ (endst20_ps_dupX W) := by
+  have _pin := Classical.em True
+  have hy := mmr62_cd_collision_yGen_eq W φ₁ φ₂ hx hcol
+  have hslope := mmr62_cd_map_dupSlope_eq_slope W φ₂
+  unfold es1a6_addSumX endst20_ps_dupX
+  rw [hx, hy, ← hslope]
+  simp only [addX, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, map_add, map_sub, map_mul,
+    map_pow, AlgHom.commutes]
+
+theorem mmr62_cd_map_dupX_transcendental [IsAlgClosed F] [CharZero F]
+    (φ : W.FunctionField →ₐ[F] W.FunctionField) :
+    Transcendental F (φ (endst20_ps_dupX W)) := by
+  have _pin := Classical.em True
+  intro halg
+  obtain ⟨p, hp0, hp⟩ := halg
+  refine endst20_ps_transcendental_dupX W ⟨p, hp0, ?_⟩
+  have h2 : φ (Polynomial.aeval (endst20_ps_dupX W) p) = 0 := by
+    rw [← Polynomial.aeval_algHom_apply]
+    exact hp
+  exact RingHom.injective (φ : W.FunctionField →+* W.FunctionField)
+    (h2.trans (_root_.map_zero (φ : W.FunctionField →+* W.FunctionField)).symm)
+
+theorem mmr62_cd_collision_addSumX_transcendental [IsAlgClosed F] [CharZero F]
+    (hx : φ₁ (polyToFunctionField W X) = φ₂ (polyToFunctionField W X))
+    (hcol : ¬ es1a6_addCollapse W φ₁ φ₂) :
+    Transcendental F (es1a6_addSumX W φ₁ φ₂) := by
+  have _pin := Classical.em True
+  rw [mmr62_cd_collision_addSumX_eq_map_dupX W φ₁ φ₂ hx hcol]
+  exact mmr62_cd_map_dupX_transcendental W φ₂
+
+theorem mmr62_cd_collision_addSumX_ne_const [IsAlgClosed F] [CharZero F]
+    (hx : φ₁ (polyToFunctionField W X) = φ₂ (polyToFunctionField W X))
+    (hcol : ¬ es1a6_addCollapse W φ₁ φ₂) (c : F) :
+    es1a6_addSumX W φ₁ φ₂ ≠ algebraMap F W.FunctionField c := by
+  have _pin := Classical.em True
+  intro hc
+  refine mmr62_cd_collision_addSumX_transcendental W φ₁ φ₂ hx hcol ?_
+  rw [hc]
+  exact isAlgebraic_algebraMap c
+
+theorem mmr62_cd_not_collapse_of_not_collapse_cmp
+    (h : ¬ es1a8_addCollapse_cmp W φ₁ φ₂) :
+    ¬ es1a6_addCollapse W φ₁ φ₂ := by
+  have _pin := Classical.em True
+  intro hc
+  exact h ⟨hc.1, hc.2⟩
+
+end CollisionEngine
+end Mmr62
+end ModularCurve
+end
+end
+
+section
+
+section
+
+namespace ModularCurve
+
+namespace Es1a1
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+public theorem kw_hk5f_addIntegralFiniteDataAt_proved : kw_hk5f_addIntegralFiniteDataAt W := by
+  intro D₁ D₂ hcol htr
+  have htrans : Transcendental F
+      (es1a6_addSumPullbackHom W D₁.ι D₂.ι hcol htr (polyToFunctionField W X)) := by
+    rw [es1a6_addSumPullbackHom_X]
+    exact transcendental_iff_injective.mpr htr
+  exact ⟨es1a8_addInt_selfHom_isIntegral_cmp _ htrans,
+    es1a8_addInt_selfHom_finiteAlong_cmp _ htrans⟩
+
+public theorem kw_hk5f_addSumCoordSeamDataNCAt_proved
+    {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    (W : WeierstrassCurve.Affine F) [W.IsElliptic] :
+    ∀ φ₁ φ₂ : W.FunctionField →ₐ[F] W.FunctionField,
+      ¬ es1a6_addCollapse W φ₁ φ₂ →
+      (∀ c : F, es1a6_addSumX W φ₁ φ₂ ≠ algebraMap F W.FunctionField c) →
+      ∀ (v : AlgebraicCurve.Place F W.FunctionField) (Q₁ Q₂ : W.Point),
+        es1a11_coordSeamDataAt φ₁ v Q₁ → es1a11_coordSeamDataAt φ₂ v Q₂ →
+        es1a6_addSumSeamDataAt φ₁ φ₂ v (Q₁ + Q₂) := by
+  intro φ₁ φ₂ hcol hnc v Q₁ Q₂ h1 h2
+  have E := @WeierstrassCurve.Affine.FunctionField.addX_addY_specialize_at_place F _ _ _ W _
+    instDecEqFunctionFieldEs1a6Add φ₁ φ₂
+    (fun hc => hcol hc) hnc v Q₁ Q₂
+    (fun h0 => by subst h0; exact h1) (fun a b h hs => by subst hs; exact h1)
+    (fun h0 => by subst h0; exact h2) (fun a b h hs => by subst hs; exact h2)
+  cases hQ : Q₁ + Q₂ with
+  | zero => exact E.1 hQ
+  | some a b h => exact E.2 a b h hQ
+
+end Es1a1
+end ModularCurve
+end
+end
+
+section
+
+section
+
+namespace ModularCurve
+
+namespace Es1a1
+
+open ModularCurve.Mmr46 ModularCurve.Mmr62 ModularCurve.Mmr72 ModularCurve.Mmr73
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+omit [IsAlgClosed F] [GenusOnePlaceGate.IsCentred W] in
+theorem kw_hk5f_two_datum_pointEnd_add_eq_geomMorph
+    (D₁ D₂ : IsogenyEndDatum W) (Q : W.Point) :
+    (D₁.pointEnd' + D₂.pointEnd') Q
+      = (D₁.geomMorph Q + D₂.geomMorph Q) - (D₁.geomMorph 0 + D₂.geomMorph 0) := by
+  have h : (D₁.pointEnd' + D₂.pointEnd') Q = D₁.pointEnd' Q + D₂.pointEnd' Q := rfl
+  rw [h, D₁.pointEnd_eq_geomMorph_sub_geomMorph_zero Q,
+    D₂.pointEnd_eq_geomMorph_sub_geomMorph_zero Q]
+  abel
+
+omit [GenusOnePlaceGate.IsCentred W] in
+theorem kw_hk5f_pointEnd_add_eq_zero_of_cofinite_geomMorph_sum
+    (D₁ D₂ : IsogenyEndDatum W) (T : W.Point)
+    (hcof : {Q : W.Point | D₁.geomMorph Q + D₂.geomMorph Q ≠ T}.Finite) :
+    D₁.pointEnd' + D₂.pointEnd' = 0 := by
+  have : Infinite W.Point := WeierstrassCurve.point_infinite _
+  refine mmr72_pp_end_eq_zero_of_cofinite_const (D₁.pointEnd' + D₂.pointEnd')
+    (T - (D₁.geomMorph 0 + D₂.geomMorph 0)) (hcof.subset ?_)
+  intro Q hQ hT
+  exact hQ (by rw [kw_hk5f_two_datum_pointEnd_add_eq_geomMorph W D₁ D₂ Q, hT])
+
+theorem kw_hk5f_collision_pointEnd_add_eq_zero
+    (D₁ D₂ : IsogenyEndDatum W)
+    (hX : D₁.ι (polyToFunctionField W X) = D₂.ι (polyToFunctionField W X))
+    (c : F) (hx : es1a6_addSumX W D₁.ι D₂.ι = algebraMap F W.FunctionField c) :
+    D₁.pointEnd' + D₂.pointEnd' = 0 := by
+  by_cases hcol : es1a8_addCollapse_cmp W D₁.ι D₂.ι
+  · exact es1a8_addCollapse_pointEnd_add_eq_zero_cmp D₁ D₂ hcol
+  · exact absurd hx (mmr62_cd_collision_addSumX_ne_const W D₁.ι D₂.ι hX
+      (mmr62_cd_not_collapse_of_not_collapse_cmp W D₁.ι D₂.ι hcol) c)
+
+omit [W.AbelTheorem] in
+theorem kw_hk5f_transversal_cofinite_geomMorph_sum
+    (D₁ D₂ : IsogenyEndDatum W)
+    (hX : D₁.ι (polyToFunctionField W X) ≠ D₂.ι (polyToFunctionField W X))
+    (c d : F) (hEq : W.Equation c d)
+    (hx : es1a6_addSumX W D₁.ι D₂.ι = algebraMap F W.FunctionField c)
+    (hy : es1a6_addSumY W D₁.ι D₂.ι = algebraMap F W.FunctionField d) :
+    ∃ T : W.Point, {Q : W.Point | D₁.geomMorph Q + D₂.geomMorph Q ≠ T}.Finite := by
+  have : HasPrincipalDivisors F W.FunctionField := hasPrincipalDivisors_functionField _
+  have hcd : W.Nonsingular c d :=
+    (equation_iff_nonsingular_of_Δ_ne_zero isElliptic_Δ_ne_zero).mp hEq
+  refine ⟨Point.some c d hcd, ?_⟩
+  have hxne : polyToFunctionField W X ≠ 0 :=
+    polyToFunctionField_ne_zero Polynomial.X_ne_zero
+  have hyne : yGen W ≠ 0 := Y_image_ne_zero
+  have hf₁ne : D₁.ι (polyToFunctionField W X) ≠ 0 := mmr73_cs_iota_ne_zero D₁ hxne
+  have hf₂ne : D₂.ι (polyToFunctionField W X) ≠ 0 := mmr73_cs_iota_ne_zero D₂ hxne
+  have hg₁ne : D₁.ι (yGen W) ≠ 0 := mmr73_cs_iota_ne_zero D₁ hyne
+  have hg₂ne : D₂.ι (yGen W) ≠ 0 := mmr73_cs_iota_ne_zero D₂ hyne
+  have hδne : D₁.ι (polyToFunctionField W X) - D₂.ι (polyToFunctionField W X) ≠ 0 :=
+    sub_ne_zero.mpr hX
+  refine Set.Finite.subset
+    (((((mmr73_cs_finite_setOf_placeOfPoint_ord_ne_zero hf₁ne).union
+      (mmr73_cs_finite_setOf_placeOfPoint_ord_ne_zero hf₂ne)).union
+      (mmr73_cs_finite_setOf_placeOfPoint_ord_ne_zero hg₁ne)).union
+      (mmr73_cs_finite_setOf_placeOfPoint_ord_ne_zero hg₂ne)).union
+      (mmr73_cs_finite_setOf_placeOfPoint_ord_ne_zero hδne)) ?_
+  intro Q hQ
+  simp only [Set.mem_union, Set.mem_ofPred_eq]
+  by_contra hbad
+  push Not at hbad
+  obtain ⟨⟨⟨⟨hb1, hb2⟩, hb3⟩, hb4⟩, hb5⟩ := hbad
+  exact hQ (mmr73_cs_geomMorph_add_eq_of_addSum_const D₁ D₂ hX hcd hx hy Q
+    hb1 hb2 hb3 hb4 hb5)
+
+public theorem kw_hk5f_addSumXNonConstGuardAt_proved : kw_hk5f_addSumXNonConstGuardAt W := by
+  intro D₁ D₂ h0
+  refine mmr46_gc_addSumX_ne_const_of_not_constPoint W D₁.ι D₂.ι ?_ ?_
+  · intro hc
+    exact es1a8_add_not_collapse_of_pointEnd_add_ne_zero_cmp D₁ D₂ h0 ⟨hc.1, hc.2⟩
+  · rintro c d hEq ⟨hx, hy⟩
+    by_cases hX : D₁.ι (polyToFunctionField W X) = D₂.ι (polyToFunctionField W X)
+    · exact h0 (kw_hk5f_collision_pointEnd_add_eq_zero W D₁ D₂ hX c hx)
+    · obtain ⟨T, hT⟩ :=
+        kw_hk5f_transversal_cofinite_geomMorph_sum W D₁ D₂ hX c d hEq hx hy
+      exact h0 (kw_hk5f_pointEnd_add_eq_zero_of_cofinite_geomMorph_sum W D₁ D₂ T hT)
+
+end Es1a1
+end ModularCurve
+end
+end
+
+section
+
+section
+
+namespace ModularCurve
+
+namespace Es1a1
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+public theorem kw_hk5f_addGeomMorphSupply_proved :
+    KwIsogenyEndAddGeomMorphSupply W :=
+  kw_hk5f_addGeomMorphSupply_of_atoms W
+    (kw_hk5f_addSumXNonConstGuardAt_proved W)
+    (kw_hk5f_addSumCoordSeamDataNCAt_proved W)
+    (kw_hk5f_addIntegralFiniteDataAt_proved W)
+
+public theorem kw_hk5f_addDatumSupply_proved :
+    KwIsogenyEndAddDatumSupply W :=
+  kw_isogenyEndAddDatumSupply_of_addGeomMorphSupply W
+    (kw_hk5f_addGeomMorphSupply_proved W)
+
+end Es1a1
+end ModularCurve
+end
+end
+
+end
+end
+
+end privateSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Defs_WeierstrassCurve_veluSharedLibrary.lean b/LeanPool/FLTEichlerShimura/Definitions/Defs_WeierstrassCurve_veluSharedLibrary.lean
new file mode 100644
index 0000000000..6050f9259c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Defs_WeierstrassCurve_veluSharedLibrary.lean
@@ -0,0 +1,6250 @@
+/-
+Copyright (c) 2026 David Loeffler. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: David Loeffler
+
+Extracted from Prove2Me proofs by Claude (2026-09-05):
+* WeierstrassCurve.velu_map_equation_of_oddOrderSummingSet
+  (99841a34-31c0-570f-ae9f-f8802f859369), submission
+  368c886c-4d95-5623-a9cf-0bde6782ce35.
+* WeierstrassCurve.exists_veluFunctionFieldHom_restrictAlong_placeOfPoint_eq
+  (acd8e718-18d4-56b2-b4fe-299ba6bb61cd), submission
+  200e3821-d296-5b22-a15a-da3c41ece41b.
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FunctionFieldQuadratic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_OddOrderSummingSet
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluPointMap
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluQuotientMap
+public import LeanPool.FLTEichlerShimura.Definitions.Defs_IsogenyEndDatum_sharedLibrary
+
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_RatPointHom
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_min_ord_le_ord_add_v2
+
+/-!
+# Shared library for the odd-order Vélu construction
+
+Declarations common to the quotient-equation and function-field-isogeny proofs, together with
+their supporting helpers. Namespaces are rooted directly in `AlgebraicCurve`, `WeierstrassCurve`,
+and the other mathematical namespaces; no Prove2Me namespace aliases are used.
+
+This library is used by the quotient-equation and function-field-isogeny proof files.
+-/
+
+section privateSection
+
+open Polynomial IsDedekindDomain WithZero IsLocalRing WeierstrassCurve Affine Point
+  CoordinateRing AlgebraicCurve
+
+open scoped Polynomial.Bivariate Pointwise nonZeroDivisors
+
+set_option backward.isDefEq.respectTransparency.types false
+
+section
+
+section
+
+open Ideal hiding map_mul
+
+open Module
+
+namespace WeierstrassCurve
+namespace Affine
+
+universe u
+
+variable {F : Type u} [Field F] {W : Affine F}
+
+namespace CoordinateRing
+
+theorem exists_eq_XYIdeal_of_isMaximal [IsAlgClosed F] (𝔪 : Ideal W.CoordinateRing)
+    (h𝔪 : 𝔪.IsMaximal) : ∃ x y : F, W.Equation x y ∧ XYIdeal W x (C y) = 𝔪 := by
+  have := h𝔪
+  let : Field (W.CoordinateRing ⧸ 𝔪) := Ideal.Quotient.field 𝔪
+  have : Module.Finite F (W.CoordinateRing ⧸ 𝔪) :=
+    finite_of_finite_type_of_isJacobsonRing F (W.CoordinateRing ⧸ 𝔪)
+  have he : Function.Bijective (algebraMap F (W.CoordinateRing ⧸ 𝔪)) :=
+    IsAlgClosed.algebraMap_bijective_of_isIntegral
+  obtain ⟨x, hx⟩ := he.2 (Ideal.Quotient.mk 𝔪 (mk W (Polynomial.C Polynomial.X)))
+  obtain ⟨y, hy⟩ := he.2 (Ideal.Quotient.mk 𝔪 (mk W Y))
+  have hconst : ∀ a : F, Ideal.Quotient.mk 𝔪 ((mk W) (Polynomial.C (Polynomial.C a)))
+      = algebraMap F (W.CoordinateRing ⧸ 𝔪) a := by
+    intro a
+    have h1 : (mk W) (Polynomial.C (Polynomial.C a)) = algebraMap F W.CoordinateRing a := by
+      rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+        Algebra.algebraMap_self_apply]
+      rfl
+    rw [h1, ← Ideal.Quotient.algebraMap_eq, ← IsScalarTower.algebraMap_apply]
+  have key : ((Ideal.Quotient.mk 𝔪).comp
+        (mk W : Polynomial (Polynomial F) →+* W.CoordinateRing)) =
+      (algebraMap F (W.CoordinateRing ⧸ 𝔪)).comp
+        ((Polynomial.evalRingHom x).comp (Polynomial.evalRingHom (Polynomial.C y))) := by
+    refine Polynomial.ringHom_ext' (Polynomial.ringHom_ext (fun a => ?_) ?_) ?_
+    · simp only [RingHom.comp_apply, Polynomial.coe_evalRingHom, Polynomial.eval_C]
+      exact hconst a
+    · simp only [RingHom.comp_apply, Polynomial.coe_evalRingHom, Polynomial.eval_X,
+        Polynomial.eval_C]
+      exact hx.symm
+    · simp only [RingHom.comp_apply, Polynomial.coe_evalRingHom, Polynomial.eval_X,
+        Polynomial.eval_C]
+      exact hy.symm
+  have heval : W.Equation x y := by
+    have h0 := DFunLike.congr_fun key W.polynomial
+    simp only [RingHom.comp_apply, AdjoinRoot.mk_self, _root_.map_zero,
+      Polynomial.coe_evalRingHom] at h0
+    exact (map_eq_zero_iff (algebraMap F (W.CoordinateRing ⧸ 𝔪)) he.1).mp h0.symm
+  have hXmem : XClass W x ∈ 𝔪 := by
+    have h2 : ((Ideal.Quotient.mk 𝔪).comp (mk W))
+        (Polynomial.C (Polynomial.X - Polynomial.C x)) = 0 := by
+      rw [key]
+      simp
+    rw [← Ideal.Quotient.eq_zero_iff_mem]
+    exact h2
+  have hYmem : YClass W (Polynomial.C y) ∈ 𝔪 := by
+    have h2 : ((Ideal.Quotient.mk 𝔪).comp (mk W))
+        (Y - Polynomial.C (Polynomial.C y)) = 0 := by
+      rw [key]
+      simp
+    rw [← Ideal.Quotient.eq_zero_iff_mem]
+    exact h2
+  refine ⟨x, y, heval, ?_⟩
+  have hXY_le : XYIdeal W x (Polynomial.C y) ≤ 𝔪 := by
+    rw [XYIdeal, Ideal.span_le]
+    rintro _ (rfl | rfl)
+    · exact hXmem
+    · exact hYmem
+  have hXY_max : (XYIdeal W x (Polynomial.C y)).IsMaximal :=
+    Ideal.Quotient.maximal_of_isField _
+      ((quotientXYIdealEquiv (W' := W) (x := x) (y := Polynomial.C y)
+        heval).toMulEquiv.isField (Field.toIsField F))
+  exact hXY_max.eq_of_le h𝔪.ne_top hXY_le
+
+end CoordinateRing
+end Affine
+end WeierstrassCurve
+end
+section
+
+section
+
+universe u
+
+namespace WeierstrassCurve
+namespace Affine
+namespace Point
+
+variable {R : Type u} [CommRing R] {W : Affine R}
+
+def xOrZero : W.Point → R
+  | .zero => 0
+  | .some x _ _ => x
+
+@[scoped simp] lemma xOrZero_some {x y : R} (h : W.Nonsingular x y) :
+    (Point.some x y h).xOrZero = x := rfl
+
+end Point
+end Affine
+
+end WeierstrassCurve
+end
+section
+
+namespace WeierstrassCurve
+section BaseChange
+
+variable {R : Type*} {A : Type*} [CommRing R] [CommRing A] (W : WeierstrassCurve R) (f : R →+* A)
+
+local macro "map_simp" : tactic =>
+  `(tactic| simp only [map_ofNat, _root_.map_neg, map_add, map_sub, map_mul, map_pow])
+
+@[scoped simp] public lemma map_veluGx (x y : R) :
+    (W.map f).veluGx (f x) (f y) = f (W.veluGx x y) := by
+  simp only [veluGx, map_a₁, map_a₂, map_a₄]
+  map_simp
+
+@[scoped simp] public lemma map_veluGy (x y : R) :
+    (W.map f).veluGy (f x) (f y) = f (W.veluGy x y) := by
+  simp only [veluGy, map_a₁, map_a₃]
+  map_simp
+
+@[scoped simp] public lemma map_veluT (x y : R) :
+    (W.map f).veluT (f x) (f y) = f (W.veluT x y) := by
+  simp only [veluT_eq, map_b₂, map_b₄]
+  map_simp
+
+@[scoped simp] public lemma map_veluU (x y : R) :
+    (W.map f).veluU (f x) (f y) = f (W.veluU x y) := by
+  simp only [veluU, map_veluGy, map_pow]
+
+@[scoped simp] lemma map_veluW (x y : R) :
+    (W.map f).veluW (f x) (f y) = f (W.veluW x y) := by
+  simp only [veluW, map_veluU, map_veluT, map_add, map_mul]
+
+lemma map_veluTSum (S : Finset (R × R)) (hf : Function.Injective f) :
+    (W.map f).veluTSum (S.map ⟨Prod.map f f, hf.prodMap hf⟩) = f (W.veluTSum S) := by
+  rw [veluTSum, veluTSum, Finset.sum_map, map_sum]
+  exact Finset.sum_congr rfl fun P _ => by
+    simp only [Function.Embedding.coeFn_mk, Prod.map_fst, Prod.map_snd, map_veluT]
+
+lemma map_veluWSum (S : Finset (R × R)) (hf : Function.Injective f) :
+    (W.map f).veluWSum (S.map ⟨Prod.map f f, hf.prodMap hf⟩) = f (W.veluWSum S) := by
+  rw [veluWSum, veluWSum, Finset.sum_map, map_sum]
+  exact Finset.sum_congr rfl fun P _ => by
+    simp only [Function.Embedding.coeFn_mk, Prod.map_fst, Prod.map_snd, map_veluW]
+
+public lemma map_veluQuotient (S : Finset (R × R)) (hf : Function.Injective f) :
+    (W.map f).veluQuotient (S.map ⟨Prod.map f f, hf.prodMap hf⟩) = (W.veluQuotient S).map f := by
+  ext
+  · simp [veluQuotient]
+  · simp [veluQuotient]
+  · simp [veluQuotient]
+  · simp only [veluQuotient_a₄, map_a₄, map_veluTSum _ _ S hf]
+    map_simp
+  · simp only [veluQuotient_a₆, map_a₆, map_b₂, map_veluTSum _ _ S hf, map_veluWSum _ _ S hf]
+    map_simp
+
+end BaseChange
+end WeierstrassCurve
+end
+
+section
+
+section
+
+open FractionalIdeal
+
+namespace FractionalIdeal
+variable {R : Type*} (K : Type*) [CommRing R] [IsDomain R] [Field K] [Algebra R K]
+  [IsFractionRing R K]
+
+theorem isUnit_coeIdeal_of_forall_isMaximal [IsNoetherianRing R]
+    (hmax : ∀ 𝔪 : Ideal R, 𝔪.IsMaximal → 𝔪 ≠ ⊥ → IsUnit (𝔪 : FractionalIdeal R⁰ K))
+    (I : Ideal R) : I ≠ ⊥ → IsUnit (I : FractionalIdeal R⁰ K) := by
+  refine IsNoetherian.induction
+    (P := fun I : Ideal R => I ≠ ⊥ → IsUnit (I : FractionalIdeal R⁰ K)) (fun I ih hI => ?_) I
+  rcases eq_or_ne I ⊤ with rfl | hItop
+  · rw [coeIdeal_top]
+    exact isUnit_one
+  obtain ⟨𝔪, h𝔪, hI𝔪⟩ := Ideal.exists_le_maximal I hItop
+  have h𝔪0 : 𝔪 ≠ ⊥ := fun h => hI (le_bot_iff.mp (h ▸ hI𝔪))
+  have h𝔪unit : IsUnit (𝔪 : FractionalIdeal R⁰ K) := hmax 𝔪 h𝔪 h𝔪0
+  have h𝔪inv : (𝔪 : FractionalIdeal R⁰ K) * (𝔪 : FractionalIdeal R⁰ K)⁻¹ = 1 :=
+    (mul_inv_cancel_iff_isUnit K).mpr h𝔪unit
+  have hle : (I : FractionalIdeal R⁰ K) * (𝔪 : FractionalIdeal R⁰ K)⁻¹ ≤ 1 := by
+    calc (I : FractionalIdeal R⁰ K) * (𝔪 : FractionalIdeal R⁰ K)⁻¹
+        ≤ (𝔪 : FractionalIdeal R⁰ K) * (𝔪 : FractionalIdeal R⁰ K)⁻¹ := by gcongr
+      _ = 1 := h𝔪inv
+  obtain ⟨J, hJ⟩ := le_one_iff_exists_coeIdeal.mp hle
+  have hJ𝔪 : J * 𝔪 = I := by
+    rw [← coeIdeal_inj (K := K), coeIdeal_mul, hJ, mul_assoc,
+      mul_comm (𝔪 : FractionalIdeal R⁰ K)⁻¹, h𝔪inv, mul_one]
+  have hIJ : I ≤ J := hJ𝔪 ▸ Ideal.mul_le_left
+  have hJ0 : J ≠ ⊥ := fun h => hI (le_bot_iff.mp (h ▸ hIJ))
+  have hne : I ≠ J := by
+    rintro rfl
+    have hsmul : I ≤ 𝔪 • I := by
+      rw [Ideal.smul_eq_mul, mul_comm]
+      exact le_of_eq hJ𝔪.symm
+    obtain ⟨r, hr𝔪, hr⟩ := Submodule.exists_sub_one_mem_and_smul_eq_zero_of_fg_of_le_smul 𝔪 I
+      (IsNoetherian.noetherian I) hsmul
+    obtain ⟨n, hnI, hn0⟩ := Submodule.exists_mem_ne_zero_of_ne_bot hI
+    have hr0 : r = 0 := by
+      have hrn := hr n hnI
+      rw [smul_eq_mul] at hrn
+      exact (mul_eq_zero.mp hrn).resolve_right hn0
+    exact h𝔪.ne_top (𝔪.eq_top_of_isUnit_mem (by simpa [hr0] using hr𝔪) isUnit_one.neg)
+  have hJunit : IsUnit (J : FractionalIdeal R⁰ K) := ih J (lt_of_le_of_ne hIJ hne) hJ0
+  rw [← hJ𝔪, coeIdeal_mul]
+  exact hJunit.mul h𝔪unit
+
+theorem isUnit_of_forall_isMaximal [IsNoetherianRing R]
+    (hmax : ∀ 𝔪 : Ideal R, 𝔪.IsMaximal → 𝔪 ≠ ⊥ → IsUnit (𝔪 : FractionalIdeal R⁰ K))
+    (I : FractionalIdeal R⁰ K) (hI : I ≠ 0) : IsUnit I := by
+  obtain ⟨a, J, ha, rfl⟩ := exists_eq_spanSingleton_mul I
+  have ha' : algebraMap R K a ≠ 0 := mt IsFractionRing.to_map_eq_zero_iff.mp ha
+  refine IsUnit.mul ?_ (isUnit_coeIdeal_of_forall_isMaximal K hmax J ?_)
+  · exact isUnit_iff_exists_inv.mpr ⟨spanSingleton R⁰ (algebraMap R K a), by
+      rw [spanSingleton_mul_spanSingleton, inv_mul_cancel₀ ha', spanSingleton_one]⟩
+  · rintro rfl
+    simp at hI
+
+end FractionalIdeal
+theorem isDedekindDomain_of_forall_isMaximal_isUnit {R : Type*} (K : Type*) [CommRing R]
+    [IsDomain R] [Field K] [Algebra R K] [IsFractionRing R K] [IsNoetherianRing R]
+    (hmax : ∀ 𝔪 : Ideal R, 𝔪.IsMaximal → 𝔪 ≠ ⊥ → IsUnit (𝔪 : FractionalIdeal R⁰ K)) :
+    IsDedekindDomain R :=
+  (isDedekindDomain_iff_mul_inv_cancel (K := K)).mpr fun I hI =>
+    (mul_inv_cancel_iff_isUnit K).mpr (isUnit_of_forall_isMaximal K hmax I hI)
+
+namespace WeierstrassCurve
+namespace Affine
+
+universe u
+
+variable {F : Type u} [Field F] {W : Affine F}
+
+namespace CoordinateRing
+
+theorem isUnit_coeIdeal_of_isMaximal [IsAlgClosed F] (hΔ : W.Δ ≠ 0)
+    {𝔪 : Ideal W.CoordinateRing} (h𝔪 : 𝔪.IsMaximal) :
+    IsUnit (𝔪 : FractionalIdeal W.CoordinateRing⁰ W.FunctionField) := by
+  obtain ⟨x, y, hxy, hXY⟩ := exists_eq_XYIdeal_of_isMaximal 𝔪 h𝔪
+  rw [← hXY, ← XYIdeal'_eq ((W.equation_iff_nonsingular_of_Δ_ne_zero hΔ).mp hxy)]
+  exact (XYIdeal' _).isUnit
+
+public theorem isDedekindDomain_of_Δ_ne_zero [IsAlgClosed F] (hΔ : W.Δ ≠ 0) :
+    IsDedekindDomain W.CoordinateRing :=
+  isDedekindDomain_of_forall_isMaximal_isUnit W.FunctionField
+    fun _𝔪 h𝔪 _ => isUnit_coeIdeal_of_isMaximal hΔ h𝔪
+
+end CoordinateRing
+end Affine
+end WeierstrassCurve
+end
+section
+
+noncomputable section
+
+namespace AlgebraicCurve
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem deg_eq_one_of_surjective (v : Place K F)
+    (h : Function.Surjective (algebraMap K v.ResidueField)) : v.deg = 1 := by
+  have hbij : Function.Bijective (algebraMap K v.ResidueField) :=
+    ⟨(algebraMap K v.ResidueField).injective, h⟩
+  change Module.finrank K v.ResidueField = 1
+  rw [← Module.finrank_self K]
+  exact ((AlgEquiv.ofBijective (Algebra.ofId K v.ResidueField) hbij).toLinearEquiv.finrank_eq).symm
+
+variable {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R F] [IsFractionRing R F]
+variable [Algebra K R] [IsScalarTower K R F]
+
+theorem deg_ofHeightOneSpectrum_eq_one (w : HeightOneSpectrum R)
+    (hw : ∀ r : R, ∃ c : K, r - algebraMap K R c ∈ w.asIdeal) :
+    (ofHeightOneSpectrum (K := K) (F := F) w).deg = 1 := by
+  set v : Place K F := ofHeightOneSpectrum (K := K) w with hv
+  apply deg_eq_one_of_surjective
+  intro z
+  obtain ⟨a, rfl⟩ := Ideal.Quotient.mk_surjective z
+  obtain ⟨n, d, hd, hnd⟩ : ∃ (n d : R) (_ : d ∈ w.asIdeal.primeCompl),
+      (a : F) * algebraMap R F d = algebraMap R F n := by
+    obtain ⟨n, d, hcase | hcase⟩ := w.exists_primeCompl_mul_eq_or_mul_eq (K := F) (a : F)
+    · exact ⟨n, d, d.2, hcase⟩
+    · refine ⟨(d : R), n, ?_, hcase⟩
+      intro hn
+      refine d.2 ?_
+      replace hn : n ∈ w.asIdeal := hn
+      change (d : R) ∈ w.asIdeal
+      rw [← w.valuation_lt_one_iff_mem (K := F)] at hn ⊢
+      calc w.valuation F (algebraMap R F (d : R))
+          = w.valuation F (a : F) * w.valuation F (algebraMap R F n) := by
+            rw [← map_mul, hcase]
+        _ ≤ 1 * w.valuation F (algebraMap R F n) := mul_le_mul_left a.2 _
+        _ = w.valuation F (algebraMap R F n) := one_mul _
+        _ < 1 := hn
+  obtain ⟨cn, hcn⟩ := hw n
+  obtain ⟨cd, hcd⟩ := hw d
+  have hcd0 : cd ≠ 0 := by
+    rintro rfl
+    rw [_root_.map_zero, sub_zero] at hcd
+    exact hd hcd
+  have hcdR : algebraMap K R cd ∉ w.asIdeal := fun hmem =>
+    hd (by simpa using w.asIdeal.add_mem hcd hmem)
+  have hvd : w.valuation F (algebraMap R F d) = 1 :=
+    le_antisymm (w.valuation_le_one d)
+      (not_lt.mp fun hlt => hd ((w.valuation_lt_one_iff_mem (K := F) d).mp hlt))
+  have hvcd : w.valuation F (algebraMap K F cd) = 1 := by
+    rw [IsScalarTower.algebraMap_apply K R F]
+    exact le_antisymm (w.valuation_le_one _)
+      (not_lt.mp fun hlt => hcdR ((w.valuation_lt_one_iff_mem (K := F) _).mp hlt))
+  have hcdF : algebraMap K F cd ≠ 0 := by
+    simpa using hcd0
+  refine ⟨cn / cd, ?_⟩
+  rw [IsScalarTower.algebraMap_apply K v.toValuationSubring v.ResidueField,
+    IsLocalRing.ResidueField.algebraMap_eq]
+  refine (Ideal.Quotient.eq (I := IsLocalRing.maximalIdeal v.toValuationSubring)).mpr ?_
+  have hmem : algebraMap K R cn * d - algebraMap K R cd * n ∈ w.asIdeal := by
+    have heq : algebraMap K R cn * d - algebraMap K R cd * n
+        = -((n - algebraMap K R cn) * d) + n * (d - algebraMap K R cd) := by ring
+    rw [heq]
+    exact w.asIdeal.add_mem (w.asIdeal.neg_mem (w.asIdeal.mul_mem_right _ hcn))
+      (w.asIdeal.mul_mem_left _ hcd)
+  have key : ((algebraMap K v.toValuationSubring (cn / cd) : F) - (a : F))
+      * (algebraMap K F cd * algebraMap R F d)
+      = algebraMap R F (algebraMap K R cn * d - algebraMap K R cd * n) := by
+    rw [coe_algebraMap, map_div₀, map_sub, map_mul, map_mul]
+    simp only [← IsScalarTower.algebraMap_apply K R F]
+    field_simp
+    linear_combination (-(algebraMap K F cd)) * hnd
+  refine (Valuation.mem_maximalIdeal_iff (v := w.valuation F)).mpr ?_
+  change w.valuation F ((algebraMap K v.toValuationSubring (cn / cd) : F) - (a : F)) < 1
+  calc w.valuation F ((algebraMap K v.toValuationSubring (cn / cd) : F) - (a : F))
+      = w.valuation F ((algebraMap K v.toValuationSubring (cn / cd) : F) - (a : F))
+        * (w.valuation F (algebraMap K F cd) * w.valuation F (algebraMap R F d)) := by
+          rw [hvcd, hvd, one_mul, mul_one]
+    _ = w.valuation F (((algebraMap K v.toValuationSubring (cn / cd) : F) - (a : F))
+        * (algebraMap K F cd * algebraMap R F d)) := by rw [map_mul, map_mul]
+    _ = w.valuation F (algebraMap R F (algebraMap K R cn * d - algebraMap K R cd * n)) := by
+          rw [key]
+    _ < 1 := (w.valuation_lt_one_iff_mem (K := F) _).mpr hmem
+
+end Place
+end AlgebraicCurve
+namespace WeierstrassCurve
+namespace Affine
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+namespace CoordinateRing
+
+public theorem algebraMap_eq_mk_C_C (a : F) :
+    algebraMap F W.CoordinateRing a = CoordinateRing.mk W (C (C a)) := by
+  rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+    Algebra.algebraMap_self_apply]
+  rfl
+
+@[scoped simp]
+theorem heightOneSpectrumOfEquation_asIdeal {x y : F} (h : W.Equation x y) :
+    (heightOneSpectrumOfEquation h).asIdeal = XYIdeal W x (C y) := rfl
+
+theorem exists_sub_algebraMap_mem {x y : F} (h : W.Equation x y) (r : W.CoordinateRing) :
+    ∃ c : F, r - algebraMap F W.CoordinateRing c ∈ XYIdeal W x (C y) := by
+  set e := quotientXYIdealEquiv (W' := W) (x := x) (y := C y) h
+  refine ⟨e (Ideal.Quotient.mk _ r), ?_⟩
+  rw [← Ideal.Quotient.eq_zero_iff_mem, map_sub, sub_eq_zero]
+  apply e.injective
+  rw [← Ideal.Quotient.algebraMap_eq, ← IsScalarTower.algebraMap_apply, AlgEquiv.commutes,
+    Algebra.algebraMap_self_apply]
+
+end CoordinateRing
+
+@[expose] public def IsFinitePlace.ringHom
+    {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    W.CoordinateRing →+* v.toValuationSubring where
+  toFun r := ⟨algebraMap W.CoordinateRing W.FunctionField r, hv r⟩
+  map_one' := Subtype.ext (map_one _)
+  map_mul' a b := Subtype.ext (map_mul _ a b)
+  map_zero' := Subtype.ext (_root_.map_zero _)
+  map_add' a b := Subtype.ext (map_add _ a b)
+
+@[expose] public def IsFinitePlace.centre
+    {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    Ideal W.CoordinateRing :=
+  (IsLocalRing.maximalIdeal v.toValuationSubring).comap hv.ringHom
+
+theorem IsFinitePlace.centre_isPrime {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre.IsPrime :=
+  Ideal.IsPrime.comap _
+
+theorem IsFinitePlace.inv_mem {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) {r : W.CoordinateRing} (hr : r ∉ hv.centre) :
+    (algebraMap W.CoordinateRing W.FunctionField r)⁻¹ ∈ v.toValuationSubring := by
+  have hunit : IsUnit (hv.ringHom r) := by
+    rw [IsFinitePlace.centre, Ideal.mem_comap, IsLocalRing.mem_maximalIdeal,
+      mem_nonunits_iff, not_not] at hr
+    exact hr
+  obtain ⟨t, ht⟩ := hunit.exists_right_inv
+  have ht' : algebraMap W.CoordinateRing W.FunctionField r * (t : W.FunctionField) = 1 := by
+    have := congrArg (fun a : v.toValuationSubring => (a : W.FunctionField)) ht
+    simpa [IsFinitePlace.ringHom] using this
+  rw [inv_eq_of_mul_eq_one_right ht']
+  exact t.2
+
+theorem IsFinitePlace.centre_ne_bot {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre ≠ ⊥ := by
+  intro hbot
+  apply v.ne_top'
+  rw [eq_top_iff]
+  rintro z -
+  obtain ⟨r, s, hs, hz⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  have hs0 : s ∉ hv.centre := by
+    rw [hbot, Ideal.mem_bot]
+    exact fun h => nonZeroDivisors.ne_zero hs h
+  rw [← hz, div_eq_mul_inv]
+  exact mul_mem (hv r) (hv.inv_mem hs0)
+
+variable [IsDedekindDomain W.CoordinateRing]
+
+theorem deg_placeOfEquation {x y : F} (h : W.Equation x y) : (placeOfEquation h).deg = 1 :=
+  AlgebraicCurve.Place.deg_ofHeightOneSpectrum_eq_one _ (exists_sub_algebraMap_mem h)
+
+public theorem isFinitePlace_placeOfEquation {x y : F} (h : W.Equation x y) :
+    IsFinitePlace (placeOfEquation h) := fun r =>
+  (heightOneSpectrumOfEquation h).valuation_le_one r
+
+public theorem isFinitePlace_iff_exists_placeOfEquation [IsAlgClosed F]
+    (v : AlgebraicCurve.Place F W.FunctionField) :
+    IsFinitePlace v ↔ ∃ (x y : F) (h : W.Equation x y), v = placeOfEquation h := by
+  constructor
+  · intro hv
+    have := hv.centre_isPrime
+    have hmax : hv.centre.IsMaximal := Ideal.IsPrime.isMaximal hv.centre_isPrime hv.centre_ne_bot
+    obtain ⟨x, y, hxy, hXY⟩ := CoordinateRing.exists_eq_XYIdeal_of_isMaximal hv.centre hmax
+    refine ⟨x, y, hxy, ?_⟩
+    set w : HeightOneSpectrum W.CoordinateRing := heightOneSpectrumOfEquation hxy with hw
+    set A : ValuationSubring W.FunctionField :=
+      HeightOneSpectrum.valuationSubringAtPrime W.FunctionField w with hA
+    have hAded : IsDedekindDomain A := by rw [hA]; infer_instance
+    have hle : A ≤ v.toValuationSubring := by
+      intro z hz
+      rw [hA] at hz
+      obtain ⟨r, s, hs, rfl⟩ := hz
+      have hs' : s ∉ hv.centre := by
+        intro hmem
+        rw [← hXY] at hmem
+        exact hs hmem
+      exact mul_mem (hv r) (hv.inv_mem hs')
+    have hSP : A.ofPrime (A.idealOfLE v.toValuationSubring hle) = v.toValuationSubring :=
+      ValuationSubring.ofPrime_idealOfLE A v.toValuationSubring hle
+    rcases eq_or_ne (A.idealOfLE v.toValuationSubring hle) ⊥ with hP | hP
+    · exfalso
+      apply v.ne_top'
+      have h2 : A.ofPrime ⊥ ≤ A.ofPrime (A.idealOfLE v.toValuationSubring hle) :=
+        ValuationSubring.ofPrime_le_of_le (h := hP.le)
+      rw [ValuationSubring.ofPrime_bot] at h2
+      exact top_le_iff.mp (le_trans h2 hSP.le)
+    · have hPmax : (A.idealOfLE v.toValuationSubring hle).IsMaximal :=
+        Ideal.IsPrime.isMaximal inferInstance hP
+      have hPeq : A.idealOfLE v.toValuationSubring hle = IsLocalRing.maximalIdeal A :=
+        IsLocalRing.eq_maximalIdeal hPmax
+      have h3 : A.ofPrime (A.idealOfLE v.toValuationSubring hle)
+          = A.ofPrime (IsLocalRing.maximalIdeal A) :=
+        le_antisymm (ValuationSubring.ofPrime_le_of_le (h := hPeq.ge))
+          (ValuationSubring.ofPrime_le_of_le (h := hPeq.le))
+      rw [ValuationSubring.ofPrime_top] at h3
+      have hAv : A = v.toValuationSubring := h3.symm.trans hSP
+      refine (AlgebraicCurve.Place.ext ?_).symm
+      change (AlgebraicCurve.Place.ofHeightOneSpectrum w).toValuationSubring = v.toValuationSubring
+      rw [AlgebraicCurve.Place.ofHeightOneSpectrum_toValuationSubring,
+        ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact hAv
+  · rintro ⟨x, y, h, rfl⟩
+    exact isFinitePlace_placeOfEquation h
+
+end Affine
+end WeierstrassCurve
+end
+section
+
+namespace WeierstrassCurve
+namespace Affine
+namespace Point
+
+variable {R : Type*} [CommRing R] {W : Affine R}
+
+lemma coordsOrZero_fst (P : W.Point) : P.coordsOrZero.1 = P.xOrZero := by
+  cases P <;> rfl
+
+end Point
+end Affine
+section OrderArithmetic
+
+variable {G : Type*} [AddCommGroup G]
+
+lemma nsmul_ne_zero_of_addOrderOf_eq_of_not_dvd {Q : G} {p : ℕ}
+    (hord : addOrderOf Q = p) {k : ℕ} (hk : ¬ p ∣ k) : k • Q ≠ 0 := fun h =>
+  hk (hord ▸ (addOrderOf_dvd_iff_nsmul_eq_zero).mpr h)
+
+public lemma sub_nsmul_eq_neg_of_nsmul_eq_zero {Q : G} {p : ℕ} (hp : p • Q = 0) {k : ℕ}
+    (hk : k ≤ p) : (p - k) • Q = -(k • Q) := by
+  rw [eq_neg_iff_add_eq_zero, ← add_nsmul, Nat.sub_add_cancel hk, hp]
+
+end OrderArithmetic
+section IsOddVeluSet
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F}
+
+omit [DecidableEq F] in
+public lemma exists_some_of_ne_zero {P : W.toAffine.Point} (hP : P ≠ 0) :
+    ∃ (x y : F) (h : W.toAffine.Nonsingular x y), P = Point.some x y h ∧
+      P.coordsOrZero = (x, y) := by
+  rcases P with _ | ⟨x, y, h⟩
+  · exact absurd rfl hP
+  · exact ⟨x, y, h, rfl, rfl⟩
+
+variable {Q : W.toAffine.Point} {p : ℕ}
+
+lemma y_ne_negY_of_two_nsmul_ne_zero {x y : F} (h : W.toAffine.Nonsingular x y)
+    (h2 : (2 : ℕ) • (Point.some x y h : W.toAffine.Point) ≠ 0) :
+    y ≠ W.toAffine.negY x y := fun hy =>
+  h2 (by rw [two_nsmul]; exact Point.add_self_of_Y_eq hy)
+
+lemma veluGy_ne_zero_of_two_nsmul_ne_zero {x y : F} (h : W.toAffine.Nonsingular x y)
+    (h2 : (2 : ℕ) • (Point.some x y h : W.toAffine.Point) ≠ 0) :
+    W.veluGy x y ≠ 0 := by
+  intro h0
+  refine y_ne_negY_of_two_nsmul_ne_zero h h2 ?_
+  have hkey : W.toAffine.negY x y = y + W.veluGy x y := by
+    simp only [Affine.negY, veluGy]; ring
+  rw [hkey, h0, add_zero]
+
+end IsOddVeluSet
+end WeierstrassCurve
+end
+
+section
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable (v : Place K F)
+
+theorem isUnit_mk_of_ord_eq_zero {f : F} (hf : f ≠ 0) (h : v.ord f = 0) :
+    IsUnit (⟨f, v.mem_of_ord_nonneg hf h.ge⟩ : v.toValuationSubring) := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ
+  rw [h, zpow_zero, mul_one] at hu
+  have huf : (⟨f, v.mem_of_ord_nonneg hf h.ge⟩ : v.toValuationSubring)
+      = (u : v.toValuationSubring) := Subtype.ext hu
+  rw [huf]
+  exact u.isUnit
+
+theorem residue_ne_zero_of_ord_eq_zero {f : F} (hf : f ≠ 0) (h : v.ord f = 0) :
+    residue v.toValuationSubring (⟨f, v.mem_of_ord_nonneg hf h.ge⟩ : v.toValuationSubring)
+      ≠ 0 :=
+  (residue_ne_zero_iff_isUnit _).mpr (v.isUnit_mk_of_ord_eq_zero hf h)
+
+theorem evalAt_ne_zero (hv : v.IsRational) {f : F} (hf : f ≠ 0) (h : v.ord f = 0) :
+    v.evalAt f ≠ 0 := by
+  intro h0
+  have hres := v.algebraMap_evalAt hv (v.mem_of_ord_nonneg hf h.ge)
+  rw [h0, _root_.map_zero] at hres
+  exact v.residue_ne_zero_of_ord_eq_zero hf h hres.symm
+
+theorem evalAt_algebraMap (a : K) : v.evalAt (algebraMap K F a) = a := by
+  rw [v.evalAt_of_mem (v.algebraMap_mem' a)]
+  have ha : (⟨algebraMap K F a, v.algebraMap_mem' a⟩ : v.toValuationSubring)
+      = algebraMap K v.toValuationSubring a := Subtype.ext (v.coe_algebraMap a).symm
+  rw [ha, ← ResidueField.algebraMap_eq,
+    ← IsScalarTower.algebraMap_apply K v.toValuationSubring v.ResidueField,
+    v.residueInv_algebraMap]
+
+theorem evalAt_mul (hv : v.IsRational) {f g : F} (hf : f ∈ v.toValuationSubring)
+    (hg : g ∈ v.toValuationSubring) :
+    v.evalAt (f * g) = v.evalAt f * v.evalAt g := by
+  apply v.algebraMap_residueField_injective
+  rw [map_mul, v.algebraMap_evalAt hv (mul_mem hf hg), v.algebraMap_evalAt hv hf,
+    v.algebraMap_evalAt hv hg, ← map_mul]
+  rfl
+
+end Place
+end AlgebraicCurve
+end
+
+section
+
+section
+
+namespace WeierstrassCurve
+section Field
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+lemma veluY_summand_negY (x y : F) (Q : F × F) :
+    W.veluU Q.1 Q.2 * (2 * W.toAffine.negY x y + W.a₁ * x + W.a₃) / (x - Q.1) ^ 3
+      + W.veluT Q.1 Q.2 * (W.a₁ * (x - Q.1) + W.toAffine.negY x y - Q.2) / (x - Q.1) ^ 2
+      + (W.a₁ * W.veluU Q.1 Q.2 - W.veluGx Q.1 Q.2 * W.veluGy Q.1 Q.2) / (x - Q.1) ^ 2
+    = W.a₁ * (W.veluT Q.1 Q.2 / (x - Q.1) + W.veluU Q.1 Q.2 / (x - Q.1) ^ 2)
+      - (W.veluU Q.1 Q.2 * (2 * y + W.a₁ * x + W.a₃) / (x - Q.1) ^ 3
+        + W.veluT Q.1 Q.2 * (W.a₁ * (x - Q.1) + y - Q.2) / (x - Q.1) ^ 2
+        + (W.a₁ * W.veluU Q.1 Q.2 - W.veluGx Q.1 Q.2 * W.veluGy Q.1 Q.2) / (x - Q.1) ^ 2) := by
+  rcases eq_or_ne x Q.1 with h | h
+  · simp [h, sub_self]
+  · have hd : x - Q.1 ≠ 0 := sub_ne_zero.mpr h
+    simp only [veluT, veluU, veluGx, veluGy, Affine.negY]
+    field_simp
+    ring
+
+lemma veluY_negY (S : Finset (F × F)) (x y : F) :
+    W.veluY S x (W.toAffine.negY x y)
+      = (W.veluQuotient S).toAffine.negY (W.veluX S x) (W.veluY S x y) := by
+  simp only [veluY, veluX]
+  rw [Finset.sum_congr rfl fun Q _ => W.veluY_summand_negY x y Q,
+    Finset.sum_sub_distrib, ← Finset.mul_sum]
+  simp only [Affine.negY, veluQuotient_a₁, veluQuotient_a₃]
+  ring
+
+end Field
+end WeierstrassCurve
+end
+section
+
+noncomputable section
+
+namespace WeierstrassCurve
+section Corrections
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+def veluXCorr (x₀ y₀ r : F) : F :=
+  W.veluT x₀ y₀ / (r - x₀) + W.veluU x₀ y₀ / (r - x₀) ^ 2
+
+def veluYCorr (x₀ y₀ r s : F) : F :=
+  -(W.veluU x₀ y₀ * (2 * s + W.a₁ * r + W.a₃) / (r - x₀) ^ 3
+    + W.veluT x₀ y₀ * (W.a₁ * (r - x₀) + s - y₀) / (r - x₀) ^ 2
+    + (W.a₁ * W.veluU x₀ y₀ - W.veluGx x₀ y₀ * W.veluGy x₀ y₀) / (r - x₀) ^ 2)
+
+theorem veluX_sub_self_eq_sum_veluXCorr (S : Finset (F × F)) (r : F) :
+    W.veluX S r - r = ∑ Q ∈ S, W.veluXCorr Q.1 Q.2 r := by
+  simp only [veluX, veluXCorr, add_sub_cancel_left]
+
+theorem veluY_sub_self_eq_sum_veluYCorr (S : Finset (F × F)) (r s : F) :
+    W.veluY S r s - s = ∑ Q ∈ S, W.veluYCorr Q.1 Q.2 r s := by
+  unfold veluY veluYCorr
+  rw [sub_sub_cancel_left, ← Finset.sum_neg_distrib]
+
+end Corrections
+section AlphaLaurent
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+theorem veluXCorr_mul_r (x₀ y₀ : F) {r : F} (hr : r ≠ x₀) :
+    W.veluXCorr x₀ y₀ r * r
+      = W.veluT x₀ y₀ + W.veluW x₀ y₀ / (r - x₀) + W.veluU x₀ y₀ * x₀ / (r - x₀) ^ 2 := by
+  have hd : r - x₀ ≠ 0 := sub_ne_zero.mpr hr
+  simp only [veluXCorr, veluW]
+  field_simp
+  ring
+
+theorem veluX_sub_self_mul_r (S : Finset (F × F)) {r : F} (hr : ∀ A ∈ S, r ≠ A.1) :
+    (W.veluX S r - r) * r
+      = W.veluTSum S
+        + ∑ Q ∈ S, (W.veluW Q.1 Q.2 / (r - Q.1) + W.veluU Q.1 Q.2 * Q.1 / (r - Q.1) ^ 2) := by
+  rw [W.veluX_sub_self_eq_sum_veluXCorr, Finset.sum_mul, veluTSum, ← Finset.sum_add_distrib]
+  exact Finset.sum_congr rfl fun Q hQ => by
+    rw [W.veluXCorr_mul_r Q.1 Q.2 (hr Q hQ)]; ring
+
+end AlphaLaurent
+end WeierstrassCurve
+end
+section
+
+noncomputable section
+
+namespace WeierstrassCurve
+section Deficit
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+@[expose] public def veluDeficit (S : Finset (F × F)) (r s : F) : F :=
+  (W.veluY S r s) ^ 2 + W.a₁ * (W.veluX S r) * (W.veluY S r s) + W.a₃ * (W.veluY S r s)
+    - ((W.veluX S r) ^ 3 + W.a₂ * (W.veluX S r) ^ 2
+        + (W.veluQuotient S).a₄ * (W.veluX S r) + (W.veluQuotient S).a₆)
+
+public theorem veluQuotient_equation_iff_veluDeficit_eq_zero (S : Finset (F × F)) (r s : F) :
+    (W.veluQuotient S).toAffine.Equation (W.veluX S r) (W.veluY S r s)
+      ↔ W.veluDeficit S r s = 0 := by
+  rw [Affine.equation_iff, veluDeficit, veluQuotient_a₁, veluQuotient_a₂, veluQuotient_a₃,
+    sub_eq_zero]
+
+end Deficit
+section Expansion
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+theorem veluDeficit_eq_of_equation {S : Finset (F × F)} {r s : F}
+    (hP : W.toAffine.Equation r s) :
+    W.veluDeficit S r s
+      = -(W.veluY S r s - s) * W.veluGy r s - (W.veluX S r - r) * W.veluGx r s
+        + ((W.veluY S r s - s) ^ 2 + W.a₁ * (W.veluX S r - r) * (W.veluY S r s - s)
+            - (3 * r + W.a₂) * (W.veluX S r - r) ^ 2 - (W.veluX S r - r) ^ 3)
+        + 5 * W.veluTSum S * W.veluX S r + W.b₂ * W.veluTSum S + 7 * W.veluWSum S := by
+  rw [Affine.equation_iff] at hP
+  simp only [veluDeficit, veluGx, veluGy, veluQuotient_a₄, veluQuotient_a₆]
+  linear_combination hP
+
+theorem veluDeficit_congr {S : Finset (F × F)} {r s r' s' : F}
+    (hX : W.veluX S r = W.veluX S r') (hY : W.veluY S r s = W.veluY S r' s') :
+    W.veluDeficit S r s = W.veluDeficit S r' s' := by
+  unfold veluDeficit; rw [hX, hY]
+
+end Expansion
+section ConstancyCarrier
+
+variable (F : Type*) [Field F] [DecidableEq F]
+
+@[expose] public def VeluDeficitConstancyAt (p : ℕ) : Prop :=
+  ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+    ∀ (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      addOrderOf (Point.some x₀ y₀ h₀ : W.toAffine.Point) = p →
+        ∀ ⦃r s : F⦄, W.toAffine.Equation r s →
+          (∀ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2), r ≠ A.1) →
+          W.veluDeficit (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)) r s = 0
+
+end ConstancyCarrier
+end WeierstrassCurve
+end
+section
+
+namespace WeierstrassCurve
+section CommRing
+
+variable {R : Type*} [CommRing R] (W : WeierstrassCurve R)
+
+theorem velu_orbitSumX_singleton_cleared {x₀ y₀ x y : R}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀) :
+    W.veluXNum x₀ y₀ x
+      = (x - 2 * x₀) * (x - x₀) ^ 2
+        + ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2)
+        + ((y - (-y₀ - W.a₁ * x₀ - W.a₃)) ^ 2
+            + W.a₁ * (y - (-y₀ - W.a₁ * x₀ - W.a₃)) * (x - x₀)
+            - (W.a₂ + x + x₀) * (x - x₀) ^ 2) := by
+  rw [Affine.equation_iff] at hP hQ
+  simp only [veluXNum, veluT, veluU, veluGx, veluGy]
+  linear_combination (-2 : R) * hP + 2 * hQ
+
+theorem velu_orbitSumY_singleton_cleared {x₀ y₀ x y : R}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀) :
+    W.veluYNum x₀ y₀ x y
+      = y * (x - x₀) ^ 3
+        + (-(y - y₀) * (((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀)
+              - (W.a₂ + x + x₀) * (x - x₀) ^ 2) - x * (x - x₀) ^ 2)
+            - y * (x - x₀) ^ 3
+            - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀)
+              - (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (x - x₀)
+            - W.a₃ * (x - x₀) ^ 3)
+        + (-(y - (-y₀ - W.a₁ * x₀ - W.a₃)) * (((y - (-y₀ - W.a₁ * x₀ - W.a₃)) ^ 2
+              + W.a₁ * (y - (-y₀ - W.a₁ * x₀ - W.a₃)) * (x - x₀)
+              - (W.a₂ + x + x₀) * (x - x₀) ^ 2) - x * (x - x₀) ^ 2)
+            - y * (x - x₀) ^ 3
+            - W.a₁ * ((y - (-y₀ - W.a₁ * x₀ - W.a₃)) ^ 2
+              + W.a₁ * (y - (-y₀ - W.a₁ * x₀ - W.a₃)) * (x - x₀)
+              - (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (x - x₀)
+            - W.a₃ * (x - x₀) ^ 3)
+        + (W.a₁ * x₀ + W.a₃) * (x - x₀) ^ 3 := by
+  rw [Affine.equation_iff] at hP hQ
+  simp only [veluYNum, veluT, veluU, veluGx, veluGy]
+  linear_combination (2 * W.a₁ * x - W.a₁ * x₀ + W.a₃ + 2 * y) * hP
+    + (-2 * W.a₁ * x + W.a₁ * x₀ - W.a₃ - 2 * y) * hQ
+
+end CommRing
+section Field
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+theorem veluX_singleton_eq_orbitSum [DecidableEq F] {x₀ y₀ x y : F}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀) (hx : x ≠ x₀) :
+    W.veluX {(x₀, y₀)} x
+      = x + W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y y₀)
+          + W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y (W.toAffine.negY x₀ y₀))
+          - 2 * x₀ := by
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  have key := W.velu_orbitSumX_singleton_cleared hP hQ
+  rw [W.veluX_singleton x₀ y₀ hx]
+  simp only [Affine.slope_of_X_ne hx, Affine.addX, Affine.negY]
+  field_simp
+  linear_combination key
+
+theorem veluY_singleton_eq_orbitSum [DecidableEq F] {x₀ y₀ x y : F}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀) (hx : x ≠ x₀) :
+    W.veluY {(x₀, y₀)} x y
+      = y + W.toAffine.addY x x₀ y (W.toAffine.slope x x₀ y y₀)
+          + W.toAffine.addY x x₀ y (W.toAffine.slope x x₀ y (W.toAffine.negY x₀ y₀))
+          - y₀ - W.toAffine.negY x₀ y₀ := by
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  have key := W.velu_orbitSumY_singleton_cleared hP hQ
+  rw [W.veluY_singleton x₀ y₀ y hx]
+  simp only [Affine.slope_of_X_ne hx, Affine.addY, Affine.negAddY, Affine.addX, Affine.negY]
+  field_simp
+  linear_combination key
+
+end Field
+end WeierstrassCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+public theorem ord_sub_evalAt_pos (hrat : v.IsRational) {f : F} (hf : f ∈ v.toValuationSubring)
+    (hne : f - algebraMap K F (v.evalAt f) ≠ 0) :
+    0 < v.ord (f - algebraMap K F (v.evalAt f)) := by
+  have hmem : f - algebraMap K F (v.evalAt f) ∈ v.toValuationSubring :=
+    sub_mem hf (v.algebraMap_mem' _)
+  rcases eq_or_ne (v.ord (f - algebraMap K F (v.evalAt f))) 0 with h0 | h0
+  · exfalso
+    refine v.evalAt_ne_zero hrat hne h0 ?_
+    have hres : algebraMap K v.ResidueField
+        (v.evalAt (f - algebraMap K F (v.evalAt f))) = 0 := by
+      rw [v.algebraMap_evalAt hrat hmem]
+      have hcoe : (⟨f - algebraMap K F (v.evalAt f), hmem⟩ : v.toValuationSubring)
+          = ⟨f, hf⟩ - algebraMap K v.toValuationSubring (v.evalAt f) := by
+        refine Subtype.ext ?_
+        change f - algebraMap K F (v.evalAt f)
+          = f - (algebraMap K v.toValuationSubring (v.evalAt f) : F)
+        rw [Place.coe_algebraMap]
+      rw [hcoe, map_sub, sub_eq_zero, ← v.algebraMap_evalAt hrat hf,
+        IsScalarTower.algebraMap_apply K v.toValuationSubring v.ResidueField,
+        IsLocalRing.ResidueField.algebraMap_eq]
+    exact (map_eq_zero_iff _ (algebraMap K v.ResidueField).injective).mp hres
+  · have hnonneg := v.ord_nonneg_of_mem hmem
+    omega
+
+end Place
+end AlgebraicCurve
+end
+section
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+theorem evalAt_inv (hv : v.IsRational) {f : F} (hf : f ≠ 0) (h : v.ord f = 0) :
+    v.evalAt f⁻¹ = (v.evalAt f)⁻¹ := by
+  have hfi : f⁻¹ ≠ 0 := inv_ne_zero hf
+  have hi : v.ord f⁻¹ = 0 := by rw [v.ord_inv, h, _root_.neg_zero]
+  have hmul := v.evalAt_mul hv (v.mem_of_ord_nonneg hf h.ge) (v.mem_of_ord_nonneg hfi hi.ge)
+  rw [mul_inv_cancel₀ hf, v.evalAt_one] at hmul
+  exact eq_inv_of_mul_eq_one_right hmul.symm
+
+end Place
+end AlgebraicCurve
+end
+section
+
+section
+
+noncomputable section
+
+namespace AlgebraicCurve
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+theorem ord_add_eq_min {f g : F} (hf : f ≠ 0) (hg : g ≠ 0) (h : v.ord f ≠ v.ord g) :
+    v.ord (f + g) = min (v.ord f) (v.ord g) := by
+  have hval : v.adicValuation f ≠ v.adicValuation g := by
+    intro hcon
+    exact h (by simp only [ord, hcon])
+  have h1 : v.adicValuation (f + g) = max (v.adicValuation f) (v.adicValuation g) :=
+    Valuation.map_add_of_distinct_val _ hval
+  have hfg : f + g ≠ 0 := by
+    intro hcon
+    rw [hcon, _root_.map_zero] at h1
+    rcases max_cases (v.adicValuation f) (v.adicValuation g) with ⟨hmax, -⟩ | ⟨hmax, -⟩ <;>
+      rw [hmax] at h1
+    · exact v.adicValuation_ne_zero hf h1.symm
+    · exact v.adicValuation_ne_zero hg h1.symm
+  rcases max_cases (v.adicValuation f) (v.adicValuation g) with ⟨hmax, hle⟩ | ⟨hmax, hlt⟩ <;>
+    rw [hmax] at h1
+  · have hlog := (WithZero.log_le_log (v.adicValuation_ne_zero hg)
+      (v.adicValuation_ne_zero hf)).mpr hle
+    have h2 : v.ord (f + g) = v.ord f := by simp only [ord, h1]
+    simp only [ord] at hlog h2 ⊢
+    omega
+  · have hlog := (WithZero.log_le_log (v.adicValuation_ne_zero hf)
+      (v.adicValuation_ne_zero hg)).mpr hlt.le
+    have h2 : v.ord (f + g) = v.ord g := by simp only [ord, h1]
+    simp only [ord] at hlog h2 ⊢
+    omega
+
+public theorem ord_pow (f : F) (n : ℕ) : v.ord (f ^ n) = n * v.ord f := by
+  rw [← zpow_natCast, v.ord_zpow]
+
+theorem ord_ringHom_eq_natDegree_mul {φ : K[X] →+* F} (hφinj : Function.Injective φ)
+    (hφC : ∀ c : K, φ (C c) = algebraMap K F c) (hz : v.ord (φ X) < 0) :
+    ∀ {p : K[X]}, p ≠ 0 → v.ord (φ p) = p.natDegree * v.ord (φ X) := by
+  have hX0 : φ X ≠ 0 := fun h => by simp [Place.ord, h] at hz
+  have hmono : ∀ (c : K) (n : ℕ), c ≠ 0 → v.ord (φ (C c * X ^ n)) = n * v.ord (φ X) := by
+    intro c n hc
+    have hc0 : φ (C c) ≠ 0 := by
+      rw [hφC]
+      simpa using hc
+    rw [map_mul, map_pow, v.ord_mul hc0 (pow_ne_zero n hX0), hφC, v.ord_algebraMap,
+      v.ord_pow, zero_add]
+  intro p
+  induction hd : p.natDegree using Nat.strong_induction_on generalizing p with
+  | _ d ih =>
+    intro hp
+    subst hd
+    rcases eq_or_ne p.eraseLead 0 with he | he
+    · conv_lhs => rw [← p.eraseLead_add_C_mul_X_pow, he, zero_add]
+      exact hmono _ _ (leadingCoeff_ne_zero.mpr hp)
+    · have hlt : p.eraseLead.natDegree < p.natDegree := by
+        rcases p.eraseLead_natDegree_lt_or_eraseLead_eq_zero with h | h
+        · exact h
+        · exact absurd h he
+      have hIH : v.ord (φ p.eraseLead) = p.eraseLead.natDegree * v.ord (φ X) :=
+        ih _ hlt rfl he
+      have hlead : v.ord (φ (C p.leadingCoeff * X ^ p.natDegree))
+          = p.natDegree * v.ord (φ X) := hmono _ _ (leadingCoeff_ne_zero.mpr hp)
+      have hcast : (p.eraseLead.natDegree : ℤ) < (p.natDegree : ℤ) := by exact_mod_cast hlt
+      have hne : v.ord (φ p.eraseLead) ≠ v.ord (φ (C p.leadingCoeff * X ^ p.natDegree)) := by
+        rw [hIH, hlead]
+        nlinarith
+      have he2 : φ (C p.leadingCoeff * X ^ p.natDegree) ≠ 0 := fun hcon =>
+        mul_ne_zero (C_ne_zero.mpr (leadingCoeff_ne_zero.mpr hp)) (pow_ne_zero _ X_ne_zero)
+          (hφinj (hcon.trans (_root_.map_zero φ).symm))
+      have he1 : φ p.eraseLead ≠ 0 := fun hcon => he (hφinj (hcon.trans (_root_.map_zero φ).symm))
+      conv_lhs => rw [← p.eraseLead_add_C_mul_X_pow]
+      rw [map_add, v.ord_add_eq_min he1 he2 hne, hIH, hlead]
+      have h1 : (p.natDegree : ℤ) * v.ord (φ X) ≤ (p.eraseLead.natDegree : ℤ) * v.ord (φ X) := by
+        nlinarith
+      omega
+
+theorem le_ord_ringHom_of_natDegree_le {φ : K[X] →+* F} (hφinj : Function.Injective φ)
+    (hφC : ∀ c : K, φ (C c) = algebraMap K F c) (hz : v.ord (φ X) < 0)
+    {p : K[X]} {d : ℕ} (hd : p.natDegree ≤ d) :
+    (d : ℤ) * v.ord (φ X) ≤ v.ord (φ p) := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp only [_root_.map_zero, Place.ord_zero]
+    nlinarith [hz]
+  rw [v.ord_ringHom_eq_natDegree_mul hφinj hφC hz hp]
+  have h1 : (p.natDegree : ℤ) ≤ (d : ℤ) := by exact_mod_cast hd
+  nlinarith
+
+end Place
+end AlgebraicCurve
+namespace WeierstrassCurve
+namespace Affine
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem natDegree_norm_smul_basis_left {p : F[X]} (hp : p ≠ 0) :
+    ((Algebra.norm F[X] (p • (1 : W.CoordinateRing)
+        + (0 : F[X]) • CoordinateRing.mk W Y)).natDegree : ℤ) = 2 * p.natDegree := by
+  have hdeg := degree_norm_smul_basis (W' := W) p 0
+  rw [Polynomial.degree_zero, show (2 : ℕ) • (⊥ : WithBot ℕ) + 3 = ⊥ by
+      rw [two_nsmul]; simp, max_eq_left bot_le, Polynomial.degree_eq_natDegree hp, two_nsmul,
+    ← Nat.cast_add] at hdeg
+  rw [Polynomial.natDegree_eq_of_degree_eq_some hdeg]
+  push_cast
+  ring
+
+theorem natDegree_norm_smul_basis_right {q : F[X]} (hq : q ≠ 0) :
+    ((Algebra.norm F[X] ((0 : F[X]) • (1 : W.CoordinateRing)
+        + q • CoordinateRing.mk W Y)).natDegree : ℤ) = 2 * q.natDegree + 3 := by
+  have hdeg := degree_norm_smul_basis (W' := W) 0 q
+  rw [Polynomial.degree_zero, show (2 : ℕ) • (⊥ : WithBot ℕ) = ⊥ by
+      rw [two_nsmul]; simp, max_eq_right bot_le, Polynomial.degree_eq_natDegree hq, two_nsmul,
+    ← Nat.cast_add, show ((3 : WithBot ℕ)) = ((3 : ℕ) : WithBot ℕ) from rfl,
+    ← Nat.cast_add] at hdeg
+  rw [Polynomial.natDegree_eq_of_degree_eq_some hdeg]
+  push_cast
+  ring
+
+theorem natDegree_norm_smul_basis_max {p q : F[X]} (hp : p ≠ 0) (hq : q ≠ 0) :
+    ((Algebra.norm F[X] (p • (1 : W.CoordinateRing)
+        + q • CoordinateRing.mk W Y)).natDegree : ℤ)
+      = max (2 * (p.natDegree : ℤ)) (2 * (q.natDegree : ℤ) + 3) := by
+  have hdeg := degree_norm_smul_basis (W' := W) p q
+  rw [Polynomial.degree_eq_natDegree hp, Polynomial.degree_eq_natDegree hq, two_nsmul,
+    two_nsmul, ← Nat.cast_add, ← Nat.cast_add,
+    show ((3 : WithBot ℕ)) = ((3 : ℕ) : WithBot ℕ) from rfl, ← Nat.cast_add] at hdeg
+  rcases le_total (q.natDegree + q.natDegree + 3) (p.natDegree + p.natDegree) with h | h
+  · rw [max_eq_left (by exact_mod_cast h)] at hdeg
+    rw [Polynomial.natDegree_eq_of_degree_eq_some hdeg]
+    push_cast
+    omega
+  · rw [max_eq_right (by exact_mod_cast h)] at hdeg
+    rw [Polynomial.natDegree_eq_of_degree_eq_some hdeg]
+    push_cast
+    omega
+
+variable (v : AlgebraicCurve.Place F W.FunctionField)
+
+public theorem isFinitePlace_of_mem
+    (hx : polyToFunctionField W X ∈ v.toValuationSubring) : IsFinitePlace v := by
+  have hpoly : ∀ p : F[X], polyToFunctionField W p ∈ v.toValuationSubring := by
+    intro p
+    induction p using Polynomial.induction_on' with
+    | add f g hf hg => rw [map_add]; exact add_mem hf hg
+    | monomial n c =>
+        rw [← C_mul_X_pow_eq_monomial, map_mul, map_pow]
+        refine mul_mem ?_ (pow_mem hx n)
+        rw [polyToFunctionField_C]
+        exact v.algebraMap_mem' c
+  set η := algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) with hηdef
+  set c₁ : F[X] := C W.a₁ * X + C W.a₃ with hc₁def
+  set cb : F[X] := X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ with hcbdef
+  have hrel : η * η = polyToFunctionField W cb - polyToFunctionField W c₁ * η := by
+    have h1 := smul_basis_mul_Y (W' := W) 0 1
+    rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at h1
+    have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) h1
+    rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+    exact h2
+  have hy : η ∈ v.toValuationSubring := by
+    refine v.mem_of_eval_monic_eq_zero (P := Polynomial.X ^ 2
+      + (Polynomial.C (polyToFunctionField W c₁) * Polynomial.X
+        - Polynomial.C (polyToFunctionField W cb))) ?_ ?_ (x := η) ?_
+    · refine Polynomial.monic_X_pow_add (n := 2) ?_
+      rw [sub_eq_add_neg, ← Polynomial.C_neg]
+      refine lt_of_le_of_lt Polynomial.degree_linear_le ?_
+      exact_mod_cast Nat.one_lt_two
+    · intro i
+      rw [show (Polynomial.C (polyToFunctionField W c₁) * Polynomial.X : Polynomial _)
+          = Polynomial.C (polyToFunctionField W c₁) * Polynomial.X ^ 1 by ring]
+      simp only [Polynomial.coeff_add, Polynomial.coeff_sub, Polynomial.coeff_X_pow,
+        Polynomial.coeff_C_mul, Polynomial.coeff_C]
+      refine add_mem ?_ (sub_mem ?_ ?_)
+      · split <;> simp [v.toValuationSubring.one_mem, v.toValuationSubring.zero_mem]
+      · split
+        · rw [mul_one]; exact hpoly _
+        · rw [mul_zero]; exact v.toValuationSubring.zero_mem
+      · split
+        · exact hpoly _
+        · exact v.toValuationSubring.zero_mem
+    · simp only [Polynomial.eval_add, Polynomial.eval_sub, Polynomial.eval_pow,
+        Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_X]
+      rw [sq]
+      linear_combination hrel
+  intro r
+  obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq r
+  rw [algebraMap_smul_basis]
+  exact add_mem (hpoly p) (mul_mem (hpoly q) hy)
+
+theorem two_mul_ord_Y_eq_three_mul_ord_X (hv : ¬ IsFinitePlace v) :
+    2 * v.ord (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y))
+      = 3 * v.ord (polyToFunctionField W X) := by
+  set η := algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) with hηdef
+  have hA : v.ord (polyToFunctionField W X) < 0 := ord_X_neg_of_not_isFinitePlace v hv
+  have hη0 : η ≠ 0 := Y_image_ne_zero
+  set c₁ : F[X] := C W.a₁ * X + C W.a₃ with hc₁def
+  set cb : F[X] := X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ with hcbdef
+  have hrel : η * η = polyToFunctionField W cb - polyToFunctionField W c₁ * η := by
+    have h1 := smul_basis_mul_Y (W' := W) 0 1
+    rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at h1
+    have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) h1
+    rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+    exact h2
+  have hrelL : (η + polyToFunctionField W c₁) * η = polyToFunctionField W cb := by
+    rw [add_mul]
+    linear_combination hrel
+  have hcbdeg : cb.natDegree = 3 := by
+    rw [hcbdef, ← one_mul (X ^ 3 : F[X]), ← C_1]
+    exact Polynomial.natDegree_cubic one_ne_zero
+  have hcb0 : cb ≠ 0 := by
+    intro h
+    rw [h, Polynomial.natDegree_zero] at hcbdeg
+    exact absurd hcbdeg (by norm_num)
+  have hcbord : v.ord (polyToFunctionField W cb) = 3 * v.ord (polyToFunctionField W X) := by
+    rw [v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA
+      hcb0, hcbdeg]
+    push_cast
+    ring
+  have hc₁ord : (1 : ℤ) * v.ord (polyToFunctionField W X)
+      ≤ v.ord (polyToFunctionField W c₁) := by
+    refine v.le_ord_ringHom_of_natDegree_le polyToFunctionField_injective polyToFunctionField_C
+      hA ?_
+    rw [hc₁def]
+    refine le_trans (Polynomial.natDegree_add_le _ _) ?_
+    simp only [Polynomial.natDegree_C, max_le_iff]
+    refine ⟨le_trans (Polynomial.natDegree_C_mul_le _ _) (by simp), by omega⟩
+  rw [one_mul] at hc₁ord
+  have hfac0 : η + polyToFunctionField W c₁ ≠ 0 := by
+    intro h
+    rw [h, zero_mul] at hrelL
+    exact polyToFunctionField_ne_zero hcb0 hrelL.symm
+  have hLHS : v.ord (η + polyToFunctionField W c₁) + v.ord η
+      = 3 * v.ord (polyToFunctionField W X) := by
+    rw [← hcbord, ← hrelL, v.ord_mul hfac0 hη0]
+  rcases eq_or_ne (polyToFunctionField W c₁) 0 with hc₁0 | hc₁0
+  · rw [hc₁0, add_zero] at hLHS
+    omega
+  · by_cases hBc : v.ord η = v.ord (polyToFunctionField W c₁)
+    · exfalso
+      have hmin : min (v.ord η) (v.ord (polyToFunctionField W c₁))
+          ≤ v.ord (η + polyToFunctionField W c₁) := v.min_ord_le_ord_add' hfac0
+      rw [← hBc, min_self] at hmin
+      have hBA : v.ord (polyToFunctionField W X) ≤ v.ord η := hBc ▸ hc₁ord
+      omega
+    · have hsum : v.ord (η + polyToFunctionField W c₁)
+          = min (v.ord η) (v.ord (polyToFunctionField W c₁)) :=
+        v.ord_add_eq_min hη0 hc₁0 hBc
+      rcases min_cases (v.ord η) (v.ord (polyToFunctionField W c₁)) with
+        ⟨hm, hle⟩ | ⟨hm, hlt⟩ <;> rw [hm] at hsum
+      · rw [hsum] at hLHS
+        omega
+      · exfalso
+        rw [hsum] at hLHS
+        omega
+
+theorem ne_arith {A B s t : ℤ} (hA : A < 0) (hY : 2 * B = 3 * A) :
+    s * A ≠ t * A + B := by
+  intro hcon
+  have h4 : (2 * s - (2 * t + 3)) * A = 0 := by linear_combination 2 * hcon + hY
+  rcases mul_eq_zero.mp h4 with h5 | h5
+  · omega
+  · omega
+
+theorem two_mul_min_arith {A B s t : ℤ} (hA : A < 0) (hY : 2 * B = 3 * A) :
+    2 * min (s * A) (t * A + B) = A * max (2 * s) (2 * t + 3) := by
+  rcases le_or_gt (2 * t + 3) (2 * s) with h | h
+  · rw [max_eq_left h, min_eq_left (by nlinarith)]
+    ring
+  · rw [max_eq_right h.le, min_eq_right (by nlinarith)]
+    linear_combination hY
+
+theorem two_mul_ord_eq_of_not_isFinitePlace (hv : ¬ IsFinitePlace v)
+    {f : W.CoordinateRing} (hf : f ≠ 0) :
+    2 * v.ord (algebraMap W.CoordinateRing W.FunctionField f)
+      = v.ord (polyToFunctionField W X) * ((Algebra.norm F[X] f).natDegree : ℤ) := by
+  have hA : v.ord (polyToFunctionField W X) < 0 := ord_X_neg_of_not_isFinitePlace v hv
+  have hη0 : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) ≠ 0 :=
+    Y_image_ne_zero
+  have hYord := two_mul_ord_Y_eq_three_mul_ord_X v hv
+  obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq f
+  by_cases hq : q = 0
+  · subst hq
+    have hp : p ≠ 0 := fun h => hf (by rw [h, zero_smul, zero_smul, add_zero])
+    rw [natDegree_norm_smul_basis_left hp, algebraMap_smul_basis, _root_.map_zero, zero_mul,
+      add_zero, v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C
+      hA hp]
+    ring
+  · by_cases hp : p = 0
+    · subst hp
+      rw [natDegree_norm_smul_basis_right hq, algebraMap_smul_basis, _root_.map_zero, zero_add,
+        v.ord_mul (polyToFunctionField_ne_zero hq) hη0,
+        v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA hq]
+      linear_combination hYord
+    · rw [natDegree_norm_smul_basis_max hp hq, algebraMap_smul_basis]
+      have hordp : v.ord (polyToFunctionField W p)
+          = (p.natDegree : ℤ) * v.ord (polyToFunctionField W X) :=
+        v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA hp
+      have hordqy : v.ord (polyToFunctionField W q
+            * algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y))
+          = (q.natDegree : ℤ) * v.ord (polyToFunctionField W X)
+            + v.ord (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)) := by
+        rw [v.ord_mul (polyToFunctionField_ne_zero hq) hη0,
+          v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA
+            hq]
+      have hne : v.ord (polyToFunctionField W p) ≠ v.ord (polyToFunctionField W q
+          * algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)) := by
+        rw [hordp, hordqy]
+        exact ne_arith hA hYord
+      have hqy0 : polyToFunctionField W q
+          * algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) ≠ 0 :=
+        mul_ne_zero (polyToFunctionField_ne_zero hq) hη0
+      rw [v.ord_add_eq_min (polyToFunctionField_ne_zero hp) hqy0 hne, hordp, hordqy]
+      exact two_mul_min_arith hA hYord
+
+theorem ord_X_eq_neg_two_of_not_isFinitePlace (hv : ¬ IsFinitePlace v) :
+    v.ord (polyToFunctionField W X) = -2 := by
+  have hA : v.ord (polyToFunctionField W X) < 0 := ord_X_neg_of_not_isFinitePlace v hv
+  have hYord := two_mul_ord_Y_eq_three_mul_ord_X v hv
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπord : v.ord (π : W.FunctionField) = 1 := v.ord_coe_irreducible hπ
+  have hπ0 : (π : W.FunctionField) ≠ 0 := by
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  obtain ⟨a, b, hb, hab⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing)
+    (π : W.FunctionField)
+  have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb
+  have ha0 : a ≠ 0 := by
+    intro h
+    rw [h, _root_.map_zero, zero_div] at hab
+    exact hπ0 hab.symm
+  have ha' : algebraMap W.CoordinateRing W.FunctionField a ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr ha0
+  have hb' : algebraMap W.CoordinateRing W.FunctionField b ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr hb0
+  have h1 := two_mul_ord_eq_of_not_isFinitePlace v hv ha0
+  have h2 := two_mul_ord_eq_of_not_isFinitePlace v hv hb0
+  have h3 : v.ord (π : W.FunctionField)
+      = v.ord (algebraMap W.CoordinateRing W.FunctionField a)
+        - v.ord (algebraMap W.CoordinateRing W.FunctionField b) := by
+    rw [← hab, div_eq_mul_inv, v.ord_mul ha' (inv_ne_zero hb'), v.ord_inv]
+    ring
+  rw [hπord] at h3
+  have h4 : (2 : ℤ) = v.ord (polyToFunctionField W X) * (((Algebra.norm F[X] a).natDegree : ℤ)
+      - ((Algebra.norm F[X] b).natDegree : ℤ)) := by
+    linear_combination 2 * h3 + h1 - h2
+  have h5 : v.ord (polyToFunctionField W X) ∣ 2 := ⟨_, h4⟩
+  have h6 : (2 : ℤ) ∣ v.ord (polyToFunctionField W X) := by
+    have h7 : (2 : ℤ) ∣ 3 * v.ord (polyToFunctionField W X) := ⟨_, hYord.symm⟩
+    omega
+  have h8 : (v.ord (polyToFunctionField W X)).natAbs ∣ (2 : ℤ).natAbs :=
+    Int.natAbs_dvd_natAbs.mpr h5
+  have h9 : (2 : ℤ).natAbs ∣ (v.ord (polyToFunctionField W X)).natAbs :=
+    Int.natAbs_dvd_natAbs.mpr h6
+  have h10 : (v.ord (polyToFunctionField W X)).natAbs = 2 :=
+    Nat.dvd_antisymm (by simpa using h8) (by simpa using h9)
+  omega
+
+theorem ord_Y_eq_neg_three_of_not_isFinitePlace (hv : ¬ IsFinitePlace v) :
+    v.ord (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)) = -3 := by
+  have h1 := two_mul_ord_Y_eq_three_mul_ord_X v hv
+  rw [ord_X_eq_neg_two_of_not_isFinitePlace v hv] at h1
+  omega
+
+end Affine
+end WeierstrassCurve
+end
+section
+
+section
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+
+theorem Place.ord_div (v : Place K F) {f g : F} (hf : f ≠ 0) (hg : g ≠ 0) :
+    v.ord (f / g) = v.ord f - v.ord g := by
+  rw [div_eq_mul_inv, v.ord_mul hf (inv_ne_zero hg), v.ord_inv]
+  ring
+
+end AlgebraicCurve
+namespace WeierstrassCurve
+namespace Affine
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem algebraMap_coordinateRing_ne_zero {r : W.CoordinateRing} (hr : r ≠ 0) :
+    algebraMap W.CoordinateRing W.FunctionField r ≠ 0 :=
+  (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr hr
+
+public theorem mk_mem_XYIdeal_iff {x y : F} (h : W.Equation x y) (P : F[X][Y]) :
+    CoordinateRing.mk W P ∈ XYIdeal W x (C y) ↔ P.evalEval x y = 0 := by
+  have hmap : XYIdeal W x (C y)
+      = Ideal.map (CoordinateRing.mk W) (Ideal.span {C (X - C x), Y - C (C y)}) := by
+    rw [Ideal.map_span, Set.image_pair]
+    rfl
+  rw [hmap]
+  constructor
+  · intro hP
+    obtain ⟨Q, hQ, hQP⟩ := (Ideal.mem_map_iff_of_surjective _ AdjoinRoot.mk_surjective).mp hP
+    obtain ⟨c, hc⟩ := AdjoinRoot.mk_eq_mk.mp hQP
+    have hQ0 : Q.evalEval x y = 0 :=
+      mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero.mp hQ
+    have hW0 : W.polynomial.evalEval x y = 0 := h
+    have hPQ : P = Q - W.polynomial * c := by rw [← hc]; ring
+    rw [hPQ]
+    simp only [evalEval, eval_sub, eval_mul] at hQ0 hW0 ⊢
+    rw [hQ0, hW0, zero_mul, sub_zero]
+  · intro hP
+    exact Ideal.mem_map_of_mem _ (mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero.mpr hP)
+
+theorem ord_placeOfEquation_ne_zero_iff [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) {r : W.CoordinateRing} (hr : r ≠ 0) :
+    (placeOfEquation h).ord (algebraMap W.CoordinateRing W.FunctionField r) ≠ 0
+      ↔ r ∈ XYIdeal W x (C y) := by
+  rw [placeOfEquation, Place.ord_ofHeightOneSpectrum_ne_zero_iff _ hr,
+    heightOneSpectrumOfEquation_asIdeal]
+
+public theorem ord_placeOfEquation_pos_iff [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) {r : W.CoordinateRing} (hr : r ≠ 0) :
+    0 < (placeOfEquation h).ord (algebraMap W.CoordinateRing W.FunctionField r)
+      ↔ r ∈ XYIdeal W x (C y) := by
+  rw [← ord_placeOfEquation_ne_zero_iff h hr]
+  have := ord_placeOfEquation_nonneg h r
+  omega
+
+public theorem IsFinitePlace.mem_centre_iff_ord_ne_zero {v : Place F W.FunctionField}
+    (hv : IsFinitePlace v) {r : W.CoordinateRing} (hr : r ≠ 0) :
+    r ∈ hv.centre ↔ v.ord (algebraMap W.CoordinateRing W.FunctionField r) ≠ 0 := by
+  have hr' : algebraMap W.CoordinateRing W.FunctionField r ≠ 0 :=
+    algebraMap_coordinateRing_ne_zero hr
+  rw [IsFinitePlace.centre, Ideal.mem_comap, IsLocalRing.mem_maximalIdeal, mem_nonunits_iff,
+    ne_eq, v.ord_eq_zero_iff_adicValuation_eq_one hr']
+  exact not_congr (v.adicValuation_coe_eq_one_iff (hv.ringHom r)).symm
+
+public theorem centre_placeOfEquation [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) :
+    (isFinitePlace_placeOfEquation h).centre = XYIdeal W x (C y) := by
+  ext r
+  rcases eq_or_ne r 0 with rfl | hr
+  · simp only [Submodule.zero_mem]
+  rw [(isFinitePlace_placeOfEquation h).mem_centre_iff_ord_ne_zero hr,
+    ord_placeOfEquation_ne_zero_iff h hr]
+
+end Affine
+end WeierstrassCurve
+end
+section
+
+noncomputable section
+
+namespace WeierstrassCurve
+section PsiEval
+
+variable {R : Type*} [CommRing R] (W : WeierstrassCurve R)
+
+lemma eval_Ψ₃_eq_b' (x : R) :
+    (W.Ψ₃).eval x = 3 * x ^ 4 + W.b₂ * x ^ 3 + 3 * W.b₄ * x ^ 2 + 3 * W.b₆ * x + W.b₈ := by
+  simp only [Ψ₃, eval_add, eval_mul, eval_pow, eval_C, eval_X, eval_ofNat]
+
+end PsiEval
+section LinearTerm
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+def veluDeficitLinearTerm (x₀ y₀ r s : F) : F :=
+  -(W.veluY {(x₀, y₀)} r s - s) * W.veluGy r s
+    - (W.veluX {(x₀, y₀)} r - r) * W.veluGx r s
+    + 5 * W.veluT x₀ y₀ * r + W.b₂ * W.veluT x₀ y₀ + 7 * W.veluW x₀ y₀
+
+end LinearTerm
+section ClearedIdentity
+
+variable {R : Type*} [CommRing R] (W : WeierstrassCurve R)
+
+theorem veluDeficitLinearTerm_mul_cube_eq {x₀ y₀ r s : R}
+    (hP : W.toAffine.Equation r s) (hQ : W.toAffine.Equation x₀ y₀) :
+    -(W.veluU x₀ y₀ * W.veluGy r s
+        - W.veluT x₀ y₀ * (W.a₁ * (r - x₀) + s - y₀) * (r - x₀)
+        - (W.a₁ * W.veluU x₀ y₀ - W.veluGx x₀ y₀ * W.veluGy x₀ y₀) * (r - x₀)) * W.veluGy r s
+      - (W.veluT x₀ y₀ * (r - x₀) + W.veluU x₀ y₀) * W.veluGx r s * (r - x₀)
+      + (5 * W.veluT x₀ y₀ * r + W.b₂ * W.veluT x₀ y₀ + 7 * W.veluW x₀ y₀) * (r - x₀) ^ 3
+      = -(W.veluU x₀ y₀) ^ 2 - 3 * W.veluT x₀ y₀ * W.veluU x₀ y₀ * (r - x₀)
+        - (3 * (W.veluT x₀ y₀) ^ 2 + 6 * (W.Ψ₃).eval x₀) * (r - x₀) ^ 2 := by
+  rw [Affine.equation_iff] at hP hQ
+  rw [W.eval_Ψ₃_eq_b']
+  simp only [veluT, veluU, veluW, veluGx, veluGy, b₂, b₄, b₆, b₈]
+  linear_combination
+    (-2*W.a₁ ^ 2*r*x₀ - 2*W.a₁ ^ 2*x₀ ^ 2 - 2*W.a₁*W.a₃*r - 6*W.a₁*W.a₃*x₀ - 16*W.a₁*x₀*y₀
+        - 8*W.a₂*r*x₀ + 8*W.a₂*x₀ ^ 2 - 4*W.a₃ ^ 2 - 16*W.a₃*y₀ - 4*W.a₄*r + 4*W.a₄*x₀
+        - 12*r*x₀ ^ 2 + 12*x₀ ^ 3 - 16*y₀ ^ 2) * hP
+    + (-6*W.a₁ ^ 2*r ^ 2 + 14*W.a₁ ^ 2*r*x₀ - 4*W.a₁ ^ 2*x₀ ^ 2 + 2*W.a₁*W.a₃*r + 6*W.a₁*W.a₃*x₀
+        + 16*W.a₁*x₀*y₀ - 24*W.a₂*r ^ 2 + 56*W.a₂*r*x₀ - 32*W.a₂*x₀ ^ 2 + 4*W.a₃ ^ 2 + 16*W.a₃*y₀
+        + 4*W.a₄*r - 4*W.a₄*x₀ - 72*r ^ 2*x₀ + 156*r*x₀ ^ 2 - 84*x₀ ^ 3 + 16*y₀ ^ 2) * hQ
+
+end ClearedIdentity
+section FieldLaurent
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+lemma veluDeficitLinearTerm_mul_cube {x₀ y₀ r s : F} (hr : r ≠ x₀) :
+    W.veluDeficitLinearTerm x₀ y₀ r s * (r - x₀) ^ 3
+      = -(W.veluU x₀ y₀ * W.veluGy r s
+          - W.veluT x₀ y₀ * (W.a₁ * (r - x₀) + s - y₀) * (r - x₀)
+          - (W.a₁ * W.veluU x₀ y₀ - W.veluGx x₀ y₀ * W.veluGy x₀ y₀) * (r - x₀)) * W.veluGy r s
+        - (W.veluT x₀ y₀ * (r - x₀) + W.veluU x₀ y₀) * W.veluGx r s * (r - x₀)
+        + (5 * W.veluT x₀ y₀ * r + W.b₂ * W.veluT x₀ y₀ + 7 * W.veluW x₀ y₀) * (r - x₀) ^ 3 := by
+  have hd : r - x₀ ≠ 0 := sub_ne_zero.mpr hr
+  unfold veluDeficitLinearTerm
+  simp only [veluX, veluY, veluGy, Finset.sum_singleton]
+  field_simp
+  ring
+
+theorem veluDeficitLinearTerm_eq {x₀ y₀ r s : F}
+    (hP : W.toAffine.Equation r s) (hQ : W.toAffine.Equation x₀ y₀) (hr : r ≠ x₀) :
+    W.veluDeficitLinearTerm x₀ y₀ r s
+      = -(W.veluU x₀ y₀) ^ 2 / (r - x₀) ^ 3
+        - 3 * W.veluT x₀ y₀ * W.veluU x₀ y₀ / (r - x₀) ^ 2
+        - (3 * (W.veluT x₀ y₀) ^ 2 + 6 * (W.Ψ₃).eval x₀) / (r - x₀) := by
+  have hd : r - x₀ ≠ 0 := sub_ne_zero.mpr hr
+  have hd3 : (r - x₀) ^ 3 ≠ 0 := pow_ne_zero 3 hd
+  have hLHS := W.veluDeficitLinearTerm_mul_cube (x₀ := x₀) (y₀ := y₀) (s := s) hr
+  have key := W.veluDeficitLinearTerm_mul_cube_eq hP hQ
+  have hRHS : (-(W.veluU x₀ y₀) ^ 2 / (r - x₀) ^ 3
+        - 3 * W.veluT x₀ y₀ * W.veluU x₀ y₀ / (r - x₀) ^ 2
+        - (3 * (W.veluT x₀ y₀) ^ 2 + 6 * (W.Ψ₃).eval x₀) / (r - x₀)) * (r - x₀) ^ 3
+      = -(W.veluU x₀ y₀) ^ 2 - 3 * W.veluT x₀ y₀ * W.veluU x₀ y₀ * (r - x₀)
+        - (3 * (W.veluT x₀ y₀) ^ 2 + 6 * (W.Ψ₃).eval x₀) * (r - x₀) ^ 2 := by
+    have hd2 : (r - x₀) ^ 2 ≠ 0 := pow_ne_zero 2 hd
+    rw [sub_mul, sub_mul, div_mul_cancel₀ _ hd3,
+      show (r - x₀) ^ 3 = (r - x₀) ^ 2 * (r - x₀) from by ring, ← mul_assoc,
+      div_mul_cancel₀ _ hd2, show (r - x₀) ^ 2 * (r - x₀) = (r - x₀) * (r - x₀) ^ 2 from by ring,
+      ← mul_assoc, div_mul_cancel₀ _ hd]
+  exact mul_right_cancel₀ hd3 (by rw [hLHS, key, ← hRHS])
+
+end FieldLaurent
+section SumDecomposition
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+theorem veluDeficit_linearPart_eq_sum (S : Finset (F × F)) (r s : F) :
+    -(W.veluY S r s - s) * W.veluGy r s - (W.veluX S r - r) * W.veluGx r s
+        + 5 * W.veluTSum S * r + W.b₂ * W.veluTSum S + 7 * W.veluWSum S
+      = ∑ Q ∈ S, W.veluDeficitLinearTerm Q.1 Q.2 r s := by
+  simp only [veluDeficitLinearTerm, veluX, veluY, veluTSum, veluWSum, Finset.sum_singleton,
+    add_sub_cancel_left, sub_sub_cancel_left, neg_neg, Finset.sum_mul, Finset.mul_sum]
+  rw [sub_eq_add_neg, ← Finset.sum_neg_distrib, ← Finset.sum_add_distrib,
+    ← Finset.sum_add_distrib, ← Finset.sum_add_distrib, ← Finset.sum_add_distrib]
+  exact Finset.sum_congr rfl fun Q _ => by ring
+
+end SumDecomposition
+section FullExpansion
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+def veluDeficitBracket (S : Finset (F × F)) (r s : F) : F :=
+  ((W.veluY S r s - s) ^ 2 + W.a₁ * (W.veluX S r - r) * (W.veluY S r s - s)
+      - (3 * r + W.a₂) * (W.veluX S r - r) ^ 2 - (W.veluX S r - r) ^ 3)
+    + 5 * W.veluTSum S * (W.veluX S r - r)
+
+theorem veluDeficit_eq_laurentSum_add_bracket {S : Finset (F × F)} {r s : F}
+    (hP : W.toAffine.Equation r s) (hSeq : ∀ A ∈ S, W.toAffine.Equation A.1 A.2)
+    (hr : ∀ A ∈ S, r ≠ A.1) :
+    W.veluDeficit S r s
+      = (∑ Q ∈ S, (-(W.veluU Q.1 Q.2) ^ 2 / (r - Q.1) ^ 3
+          - 3 * W.veluT Q.1 Q.2 * W.veluU Q.1 Q.2 / (r - Q.1) ^ 2
+          - (3 * (W.veluT Q.1 Q.2) ^ 2 + 6 * (W.Ψ₃).eval Q.1) / (r - Q.1)))
+        + W.veluDeficitBracket S r s := by
+  have hsum : ∑ Q ∈ S, W.veluDeficitLinearTerm Q.1 Q.2 r s
+      = ∑ Q ∈ S, (-(W.veluU Q.1 Q.2) ^ 2 / (r - Q.1) ^ 3
+          - 3 * W.veluT Q.1 Q.2 * W.veluU Q.1 Q.2 / (r - Q.1) ^ 2
+          - (3 * (W.veluT Q.1 Q.2) ^ 2 + 6 * (W.Ψ₃).eval Q.1) / (r - Q.1)) :=
+    Finset.sum_congr rfl fun Q hQmem =>
+      W.veluDeficitLinearTerm_eq hP (hSeq Q hQmem) (hr Q hQmem)
+  rw [← hsum, ← W.veluDeficit_linearPart_eq_sum, W.veluDeficit_eq_of_equation hP,
+    veluDeficitBracket]
+  ring
+
+end FullExpansion
+end WeierstrassCurve
+end
+section
+
+noncomputable section
+
+namespace WeierstrassCurve
+section PsiCofactor
+
+variable {R : Type*} [CommRing R] (W : WeierstrassCurve R)
+
+def veluDeficitPsiCofactor (x₀ x : R) : R :=
+  2*W.a₁ ^ 2*x ^ 3*x₀ - 3*W.a₁ ^ 2*x ^ 2*x₀ ^ 2 + W.a₁ ^ 2*x₀ ^ 4 + 2*W.a₁*W.a₃*x ^ 3
+    - 6*W.a₁*W.a₃*x*x₀ ^ 2 + 4*W.a₁*W.a₃*x₀ ^ 3 + 8*W.a₂*x ^ 3*x₀ - 12*W.a₂*x ^ 2*x₀ ^ 2
+    + 4*W.a₂*x₀ ^ 4 + 3*W.a₃ ^ 2*x ^ 2 - 6*W.a₃ ^ 2*x*x₀ + 3*W.a₃ ^ 2*x₀ ^ 2 + 4*W.a₄*x ^ 3
+    - 12*W.a₄*x*x₀ ^ 2 + 8*W.a₄*x₀ ^ 3 + 12*W.a₆*x ^ 2 - 24*W.a₆*x*x₀ + 12*W.a₆*x₀ ^ 2 - 6*x ^ 5
+    + 30*x ^ 4*x₀ - 48*x ^ 3*x₀ ^ 2 + 36*x ^ 2*x₀ ^ 3 - 18*x*x₀ ^ 4 + 6*x₀ ^ 5
+
+lemma eval_Ψ₃_eq' (x : R) :
+    (W.Ψ₃).eval x = 3 * x ^ 4 + W.b₂ * x ^ 3 + 3 * W.b₄ * x ^ 2 + 3 * W.b₆ * x + W.b₈ := by
+  rw [Ψ₃]
+  simp only [eval_C, eval_X, eval_add, eval_mul, eval_pow, eval_ofNat]
+
+theorem velu_singleton_deficit_cleared_eq_psi {x₀ y₀ x y : R}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀) :
+    W.veluYNum x₀ y₀ x y ^ 2 + W.a₁ * W.veluXNum x₀ y₀ x * W.veluYNum x₀ y₀ x y * (x - x₀)
+        + W.a₃ * W.veluYNum x₀ y₀ x y * (x - x₀) ^ 3
+      - (W.veluXNum x₀ y₀ x ^ 3 + W.a₂ * W.veluXNum x₀ y₀ x ^ 2 * (x - x₀) ^ 2
+        + (W.a₄ - 5 * W.veluT x₀ y₀) * W.veluXNum x₀ y₀ x * (x - x₀) ^ 4
+        + (W.a₆ - W.b₂ * W.veluT x₀ y₀ - 7 * W.veluW x₀ y₀) * (x - x₀) ^ 6)
+      = W.veluDeficitPsiCofactor x₀ x * (W.Ψ₃).eval x₀ := by
+  rw [Affine.equation_iff] at hP hQ
+  rw [W.eval_Ψ₃_eq']
+  simp only [veluDeficitPsiCofactor, b₂, b₄, b₆, b₈, veluXNum, veluYNum, veluT, veluU, veluW,
+    veluGx, veluGy]
+  linear_combination
+    (W.a₁ ^ 4*x ^ 2*x₀ ^ 2 + 2*W.a₁ ^ 4*x*x₀ ^ 3 + W.a₁ ^ 4*x₀ ^ 4 + 2*W.a₁ ^ 3*W.a₃*x ^ 2*x₀
+      + 8*W.a₁ ^ 3*W.a₃*x*x₀ ^ 2 + 6*W.a₁ ^ 3*W.a₃*x₀ ^ 3 + 16*W.a₁ ^ 3*x*x₀ ^ 2*y₀
+      + 16*W.a₁ ^ 3*x₀ ^ 3*y₀ + 8*W.a₁ ^ 2*W.a₂*x ^ 2*x₀ ^ 2 - 8*W.a₁ ^ 2*W.a₂*x₀ ^ 4
+      + W.a₁ ^ 2*W.a₃ ^ 2*x ^ 2 + 10*W.a₁ ^ 2*W.a₃ ^ 2*x*x₀ + 13*W.a₁ ^ 2*W.a₃ ^ 2*x₀ ^ 2
+      + 32*W.a₁ ^ 2*W.a₃*x*x₀*y₀ + 64*W.a₁ ^ 2*W.a₃*x₀ ^ 2*y₀ + 4*W.a₁ ^ 2*W.a₄*x ^ 2*x₀
+      - 4*W.a₁ ^ 2*W.a₄*x₀ ^ 3 - 2*W.a₁ ^ 2*x ^ 4*x₀ + 4*W.a₁ ^ 2*x ^ 3*x₀ ^ 2
+      + 12*W.a₁ ^ 2*x ^ 2*x₀ ^ 3 - 4*W.a₁ ^ 2*x*x₀ ^ 4 + 16*W.a₁ ^ 2*x*x₀*y₀ ^ 2
+      - 10*W.a₁ ^ 2*x₀ ^ 5 + 80*W.a₁ ^ 2*x₀ ^ 2*y₀ ^ 2 + 8*W.a₁*W.a₂*W.a₃*x ^ 2*x₀
+      + 16*W.a₁*W.a₂*W.a₃*x*x₀ ^ 2 - 24*W.a₁*W.a₂*W.a₃*x₀ ^ 3 + 64*W.a₁*W.a₂*x*x₀ ^ 2*y₀
+      - 64*W.a₁*W.a₂*x₀ ^ 3*y₀ + 4*W.a₁*W.a₃ ^ 3*x + 12*W.a₁*W.a₃ ^ 3*x₀ + 16*W.a₁*W.a₃ ^ 2*x*y₀
+      + 80*W.a₁*W.a₃ ^ 2*x₀*y₀ + 4*W.a₁*W.a₃*W.a₄*x ^ 2 + 8*W.a₁*W.a₃*W.a₄*x*x₀
+      - 12*W.a₁*W.a₃*W.a₄*x₀ ^ 2 - 2*W.a₁*W.a₃*x ^ 4 + 24*W.a₁*W.a₃*x ^ 2*x₀ ^ 2
+      + 8*W.a₁*W.a₃*x*x₀ ^ 3 + 16*W.a₁*W.a₃*x*y₀ ^ 2 - 30*W.a₁*W.a₃*x₀ ^ 4
+      + 176*W.a₁*W.a₃*x₀*y₀ ^ 2 + 32*W.a₁*W.a₄*x*x₀*y₀ - 32*W.a₁*W.a₄*x₀ ^ 2*y₀
+      - 16*W.a₁*x ^ 3*x₀*y₀ + 48*W.a₁*x ^ 2*x₀ ^ 2*y₀ + 48*W.a₁*x*x₀ ^ 3*y₀ - 80*W.a₁*x₀ ^ 4*y₀
+      + 128*W.a₁*x₀*y₀ ^ 3 + 16*W.a₂ ^ 2*x ^ 2*x₀ ^ 2 - 32*W.a₂ ^ 2*x*x₀ ^ 3 + 16*W.a₂ ^ 2*x₀ ^ 4
+      + 16*W.a₂*W.a₃ ^ 2*x*x₀ - 16*W.a₂*W.a₃ ^ 2*x₀ ^ 2 + 64*W.a₂*W.a₃*x*x₀*y₀
+      - 64*W.a₂*W.a₃*x₀ ^ 2*y₀ + 16*W.a₂*W.a₄*x ^ 2*x₀ - 32*W.a₂*W.a₄*x*x₀ ^ 2
+      + 16*W.a₂*W.a₄*x₀ ^ 3 - 8*W.a₂*x ^ 4*x₀ + 32*W.a₂*x ^ 3*x₀ ^ 2 - 64*W.a₂*x*x₀ ^ 4
+      + 64*W.a₂*x*x₀*y₀ ^ 2 + 40*W.a₂*x₀ ^ 5 - 64*W.a₂*x₀ ^ 2*y₀ ^ 2 + 4*W.a₃ ^ 4 + 32*W.a₃ ^ 3*y₀
+      + 8*W.a₃ ^ 2*W.a₄*x - 8*W.a₃ ^ 2*W.a₄*x₀ - 4*W.a₃ ^ 2*x ^ 3 + 12*W.a₃ ^ 2*x ^ 2*x₀
+      + 12*W.a₃ ^ 2*x*x₀ ^ 2 - 20*W.a₃ ^ 2*x₀ ^ 3 + 96*W.a₃ ^ 2*y₀ ^ 2 + 32*W.a₃*W.a₄*x*y₀
+      - 32*W.a₃*W.a₄*x₀*y₀ - 16*W.a₃*x ^ 3*y₀ + 48*W.a₃*x ^ 2*x₀*y₀ + 48*W.a₃*x*x₀ ^ 2*y₀
+      - 80*W.a₃*x₀ ^ 3*y₀ + 128*W.a₃*y₀ ^ 3 + 4*W.a₄ ^ 2*x ^ 2 - 8*W.a₄ ^ 2*x*x₀
+      + 4*W.a₄ ^ 2*x₀ ^ 2 - 4*W.a₄*x ^ 4 + 16*W.a₄*x ^ 3*x₀ - 32*W.a₄*x*x₀ ^ 3 + 32*W.a₄*x*y₀ ^ 2
+      + 20*W.a₄*x₀ ^ 4 - 32*W.a₄*x₀*y₀ ^ 2 + x ^ 6 - 6*x ^ 5*x₀ + 3*x ^ 4*x₀ ^ 2 + 28*x ^ 3*x₀ ^ 3
+      - 16*x ^ 3*y₀ ^ 2 - 21*x ^ 2*x₀ ^ 4 + 48*x ^ 2*x₀*y₀ ^ 2 - 30*x*x₀ ^ 5 + 48*x*x₀ ^ 2*y₀ ^ 2
+      + 25*x₀ ^ 6 - 80*x₀ ^ 3*y₀ ^ 2 + 64*y₀ ^ 4) * hP
+    + (2*W.a₁ ^ 4*x ^ 3*x₀ - 4*W.a₁ ^ 4*x ^ 2*x₀ ^ 2 - 2*W.a₁ ^ 4*x*x₀ ^ 3 + 2*W.a₁ ^ 3*W.a₃*x ^ 3
+      - 2*W.a₁ ^ 3*W.a₃*x ^ 2*x₀ - 14*W.a₁ ^ 3*W.a₃*x*x₀ ^ 2 - 2*W.a₁ ^ 3*W.a₃*x₀ ^ 3
+      + 12*W.a₁ ^ 3*x ^ 2*x₀*y₀ - 40*W.a₁ ^ 3*x*x₀ ^ 2*y₀ - 4*W.a₁ ^ 3*x₀ ^ 3*y₀
+      + 16*W.a₁ ^ 2*W.a₂*x ^ 3*x₀ - 44*W.a₁ ^ 2*W.a₂*x ^ 2*x₀ ^ 2 + 24*W.a₁ ^ 2*W.a₂*x*x₀ ^ 3
+      + 4*W.a₁ ^ 2*W.a₂*x₀ ^ 4 + 2*W.a₁ ^ 2*W.a₃ ^ 2*x ^ 2 - 16*W.a₁ ^ 2*W.a₃ ^ 2*x*x₀
+      - 10*W.a₁ ^ 2*W.a₃ ^ 2*x₀ ^ 2 + 12*W.a₁ ^ 2*W.a₃*x ^ 2*y₀ - 56*W.a₁ ^ 2*W.a₃*x*x₀*y₀
+      - 52*W.a₁ ^ 2*W.a₃*x₀ ^ 2*y₀ + 4*W.a₁ ^ 2*W.a₄*x ^ 3 - 16*W.a₁ ^ 2*W.a₄*x ^ 2*x₀
+      + 12*W.a₁ ^ 2*W.a₄*x*x₀ ^ 2 + 12*W.a₁ ^ 2*W.a₆*x ^ 2 - 24*W.a₁ ^ 2*W.a₆*x*x₀
+      + 12*W.a₁ ^ 2*W.a₆*x₀ ^ 2 - 6*W.a₁ ^ 2*x ^ 5 + 32*W.a₁ ^ 2*x ^ 4*x₀
+      - 28*W.a₁ ^ 2*x ^ 3*x₀ ^ 2 - 12*W.a₁ ^ 2*x ^ 2*x₀ ^ 3 + 12*W.a₁ ^ 2*x ^ 2*y₀ ^ 2
+      - 14*W.a₁ ^ 2*x*x₀ ^ 4 - 40*W.a₁ ^ 2*x*x₀*y₀ ^ 2 + 28*W.a₁ ^ 2*x₀ ^ 5
+      - 68*W.a₁ ^ 2*x₀ ^ 2*y₀ ^ 2 + 8*W.a₁*W.a₂*W.a₃*x ^ 3 - 8*W.a₁*W.a₂*W.a₃*x ^ 2*x₀
+      - 40*W.a₁*W.a₂*W.a₃*x*x₀ ^ 2 + 40*W.a₁*W.a₂*W.a₃*x₀ ^ 3 + 48*W.a₁*W.a₂*x ^ 2*x₀*y₀
+      - 160*W.a₁*W.a₂*x*x₀ ^ 2*y₀ + 112*W.a₁*W.a₂*x₀ ^ 3*y₀ - 4*W.a₁*W.a₃ ^ 3*x
+      - 12*W.a₁*W.a₃ ^ 3*x₀ - 16*W.a₁*W.a₃ ^ 2*x*y₀ - 80*W.a₁*W.a₃ ^ 2*x₀*y₀
+      - 16*W.a₁*W.a₃*W.a₄*x ^ 2 + 16*W.a₁*W.a₃*W.a₄*x*x₀ + 2*W.a₁*W.a₃*x ^ 4 + 24*W.a₁*W.a₃*x ^ 3*x₀
+      + 12*W.a₁*W.a₃*x ^ 2*x₀ ^ 2 - 152*W.a₁*W.a₃*x*x₀ ^ 3 - 16*W.a₁*W.a₃*x*y₀ ^ 2
+      + 114*W.a₁*W.a₃*x₀ ^ 4 - 176*W.a₁*W.a₃*x₀*y₀ ^ 2 - 32*W.a₁*W.a₄*x*x₀*y₀
+      + 32*W.a₁*W.a₄*x₀ ^ 2*y₀ + 16*W.a₁*x ^ 3*x₀*y₀ + 96*W.a₁*x ^ 2*x₀ ^ 2*y₀
+      - 336*W.a₁*x*x₀ ^ 3*y₀ + 224*W.a₁*x₀ ^ 4*y₀ - 128*W.a₁*x₀*y₀ ^ 3 + 32*W.a₂ ^ 2*x ^ 3*x₀
+      - 112*W.a₂ ^ 2*x ^ 2*x₀ ^ 2 + 128*W.a₂ ^ 2*x*x₀ ^ 3 - 48*W.a₂ ^ 2*x₀ ^ 4
+      + 24*W.a₂*W.a₃ ^ 2*x ^ 2 - 64*W.a₂*W.a₃ ^ 2*x*x₀ + 40*W.a₂*W.a₃ ^ 2*x₀ ^ 2
+      + 48*W.a₂*W.a₃*x ^ 2*y₀ - 160*W.a₂*W.a₃*x*x₀*y₀ + 112*W.a₂*W.a₃*x₀ ^ 2*y₀ + 16*W.a₂*W.a₄*x ^ 3
+      - 64*W.a₂*W.a₄*x ^ 2*x₀ + 80*W.a₂*W.a₄*x*x₀ ^ 2 - 32*W.a₂*W.a₄*x₀ ^ 3 + 48*W.a₂*W.a₆*x ^ 2
+      - 96*W.a₂*W.a₆*x*x₀ + 48*W.a₂*W.a₆*x₀ ^ 2 - 24*W.a₂*x ^ 5 + 128*W.a₂*x ^ 4*x₀
+      - 128*W.a₂*x ^ 3*x₀ ^ 2 - 144*W.a₂*x ^ 2*x₀ ^ 3 + 48*W.a₂*x ^ 2*y₀ ^ 2 + 280*W.a₂*x*x₀ ^ 4
+      - 160*W.a₂*x*x₀*y₀ ^ 2 - 112*W.a₂*x₀ ^ 5 + 112*W.a₂*x₀ ^ 2*y₀ ^ 2 - 4*W.a₃ ^ 4
+      - 32*W.a₃ ^ 3*y₀ - 8*W.a₃ ^ 2*W.a₄*x + 8*W.a₃ ^ 2*W.a₄*x₀ + 4*W.a₃ ^ 2*x ^ 3
+      + 60*W.a₃ ^ 2*x ^ 2*x₀ - 156*W.a₃ ^ 2*x*x₀ ^ 2 + 92*W.a₃ ^ 2*x₀ ^ 3 - 96*W.a₃ ^ 2*y₀ ^ 2
+      - 32*W.a₃*W.a₄*x*y₀ + 32*W.a₃*W.a₄*x₀*y₀ + 16*W.a₃*x ^ 3*y₀ + 96*W.a₃*x ^ 2*x₀*y₀
+      - 336*W.a₃*x*x₀ ^ 2*y₀ + 224*W.a₃*x₀ ^ 3*y₀ - 128*W.a₃*y₀ ^ 3 - 16*W.a₄ ^ 2*x ^ 2
+      + 32*W.a₄ ^ 2*x*x₀ - 16*W.a₄ ^ 2*x₀ ^ 2 + 4*W.a₄*x ^ 4 + 32*W.a₄*x ^ 3*x₀
+      - 72*W.a₄*x ^ 2*x₀ ^ 2 + 32*W.a₄*x*x₀ ^ 3 - 32*W.a₄*x*y₀ ^ 2 + 4*W.a₄*x₀ ^ 4
+      + 32*W.a₄*x₀*y₀ ^ 2 + 144*W.a₆*x ^ 2*x₀ - 288*W.a₆*x*x₀ ^ 2 + 144*W.a₆*x₀ ^ 3 - 72*x ^ 5*x₀
+      + 372*x ^ 4*x₀ ^ 2 - 624*x ^ 3*x₀ ^ 3 + 16*x ^ 3*y₀ ^ 2 + 360*x ^ 2*x₀ ^ 4
+      + 96*x ^ 2*x₀*y₀ ^ 2 + 24*x*x₀ ^ 5 - 336*x*x₀ ^ 2*y₀ ^ 2 - 60*x₀ ^ 6 + 224*x₀ ^ 3*y₀ ^ 2
+      - 64*y₀ ^ 4) * hQ
+
+end PsiCofactor
+section PsiField
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+theorem veluDeficit_singleton_mul_pow_eq_psi {x₀ y₀ r s : F}
+    (hP : W.toAffine.Equation r s) (hQ : W.toAffine.Equation x₀ y₀) (hr : r ≠ x₀) :
+    W.veluDeficit {(x₀, y₀)} r s * (r - x₀) ^ 6
+      = W.veluDeficitPsiCofactor x₀ r * (W.Ψ₃).eval x₀ := by
+  have hd : r - x₀ ≠ 0 := sub_ne_zero.mpr hr
+  rw [← W.velu_singleton_deficit_cleared_eq_psi hP hQ, veluDeficit,
+    W.veluX_singleton x₀ y₀ hr, W.veluY_singleton x₀ y₀ s hr, veluQuotient_a₄, veluQuotient_a₆,
+    veluTSum, veluWSum, Finset.sum_singleton, Finset.sum_singleton]
+  field_simp
+
+end PsiField
+section LinQuad
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+def veluDeficitLin (S : Finset (F × F)) (r s : F) : F :=
+  -(W.veluY S r s - s) * W.veluGy r s - (W.veluX S r - r) * W.veluGx r s
+    + 5 * W.veluTSum S * r + W.b₂ * W.veluTSum S + 7 * W.veluWSum S
+
+@[expose] public def veluDeficitQuad (S : Finset (F × F)) (r s : F) : F :=
+  (W.veluY S r s - s) ^ 2 + W.a₁ * (W.veluX S r - r) * (W.veluY S r s - s)
+    - (3 * r + W.a₂) * (W.veluX S r - r) ^ 2 - (W.veluX S r - r) ^ 3
+    + 5 * W.veluTSum S * (W.veluX S r - r)
+
+theorem veluDeficit_eq_lin_add_quad_of_equation {S : Finset (F × F)} {r s : F}
+    (hP : W.toAffine.Equation r s) :
+    W.veluDeficit S r s = W.veluDeficitLin S r s + W.veluDeficitQuad S r s := by
+  rw [W.veluDeficit_eq_of_equation hP, veluDeficitLin, veluDeficitQuad]
+  ring
+
+@[scoped simp] lemma veluDeficitLin_empty (r s : F) : W.veluDeficitLin ∅ r s = 0 := by
+  simp [veluDeficitLin]
+
+theorem veluDeficitLin_eq_sum_singleton (S : Finset (F × F)) (r s : F) :
+    W.veluDeficitLin S r s = ∑ A ∈ S, W.veluDeficitLin {A} r s := by
+  classical
+  induction S using Finset.induction with
+  | empty => simp
+  | insert A S hA ih =>
+    rw [Finset.sum_insert hA, ← ih]
+    simp only [veluDeficitLin, veluTSum, veluWSum, veluX, veluY, Finset.sum_insert hA,
+      Finset.sum_singleton]
+    ring
+
+end LinQuad
+section SumDecomp
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+@[expose] public def veluDeficitCrossQuad (S : Finset (F × F)) (r s : F) : F :=
+  W.veluDeficitQuad S r s - ∑ A ∈ S, W.veluDeficitQuad {A} r s
+
+theorem veluDeficit_eq_sum_singleton_add_crossQuad {S : Finset (F × F)} {r s : F}
+    (hP : W.toAffine.Equation r s) :
+    W.veluDeficit S r s
+      = (∑ A ∈ S, W.veluDeficit {A} r s) + W.veluDeficitCrossQuad S r s := by
+  rw [W.veluDeficit_eq_lin_add_quad_of_equation hP, veluDeficitCrossQuad,
+    W.veluDeficitLin_eq_sum_singleton,
+    show (∑ A ∈ S, W.veluDeficit {A} r s)
+        = ∑ A ∈ S, (W.veluDeficitLin {A} r s + W.veluDeficitQuad {A} r s) from
+      Finset.sum_congr rfl fun A _ => W.veluDeficit_eq_lin_add_quad_of_equation hP,
+    Finset.sum_add_distrib]
+  ring
+
+end SumDecomp
+end WeierstrassCurve
+end
+
+noncomputable section
+
+namespace WeierstrassCurve
+section GeneralOrbitSum
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+omit [DecidableEq F] in
+theorem veluY_eq_add_sum_singleton (S : Finset (F × F)) (x y : F) :
+    W.veluY S x y = y + ∑ P ∈ S, (W.veluY {P} x y - y) := by
+  simp only [veluY, Finset.sum_singleton, sub_sub_cancel_left, Finset.sum_neg_distrib]
+  ring
+
+theorem veluY_eq_orbitSum_fieldRed {S : Finset (F × F)} {x y : F} (hP : W.toAffine.Equation x y)
+    (hSeq : ∀ A ∈ S, W.toAffine.Equation A.1 A.2) (hx : ∀ A ∈ S, x ≠ A.1) :
+    W.veluY S x y = y + ∑ A ∈ S,
+      (W.toAffine.addY x A.1 y (W.toAffine.slope x A.1 y A.2)
+        + W.toAffine.addY x A.1 y (W.toAffine.slope x A.1 y (W.toAffine.negY A.1 A.2))
+        - A.2 - W.toAffine.negY A.1 A.2) := by
+  rw [veluY_eq_add_sum_singleton]
+  congr 1
+  refine Finset.sum_congr rfl fun A hA => ?_
+  have key := W.veluY_singleton_eq_orbitSum (x₀ := A.1) (y₀ := A.2) hP (hSeq A hA) (hx A hA)
+  rw [show ({(A.1, A.2)} : Finset (F × F)) = {A} from by simp] at key
+  linear_combination key
+
+end GeneralOrbitSum
+end WeierstrassCurve
+end
+
+noncomputable section
+
+namespace WeierstrassCurve
+section GeneralOrbitSum
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+omit [DecidableEq F] in
+theorem veluX_eq_add_sum_singleton (S : Finset (F × F)) (x : F) :
+    W.veluX S x = x + ∑ P ∈ S, (W.veluX {P} x - x) := by
+  simp only [veluX, Finset.sum_singleton, add_sub_cancel_left]
+
+theorem veluX_eq_orbitSum {S : Finset (F × F)} {x y : F} (hP : W.toAffine.Equation x y)
+    (hSeq : ∀ A ∈ S, W.toAffine.Equation A.1 A.2) (hx : ∀ A ∈ S, x ≠ A.1) :
+    W.veluX S x = x + ∑ A ∈ S,
+      (W.toAffine.addX x A.1 (W.toAffine.slope x A.1 y A.2)
+        + W.toAffine.addX x A.1 (W.toAffine.slope x A.1 y (W.toAffine.negY A.1 A.2))
+        - 2 * A.1) := by
+  rw [veluX_eq_add_sum_singleton]
+  congr 1
+  refine Finset.sum_congr rfl fun A hA => ?_
+  have key := W.veluX_singleton_eq_orbitSum (x₀ := A.1) (y₀ := A.2) hP (hSeq A hA) (hx A hA)
+  rw [show ({(A.1, A.2)} : Finset (F × F)) = {A} from by simp] at key
+  linear_combination key
+
+end GeneralOrbitSum
+section FullPeriod
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F}
+variable {Q : W.toAffine.Point} {p : ℕ}
+
+theorem not_mem_zmultiples_add {P : W.toAffine.Point}
+    (hPmem : P ∉ AddSubgroup.zmultiples Q) {K : W.toAffine.Point}
+    (hK : K ∈ AddSubgroup.zmultiples Q) : P + K ∉ AddSubgroup.zmultiples Q := fun hmem =>
+  hPmem (by simpa using AddSubgroup.sub_mem _ hmem hK)
+
+theorem add_ne_zero_of_not_mem_zmultiples {P : W.toAffine.Point}
+    (hPmem : P ∉ AddSubgroup.zmultiples Q) {K : W.toAffine.Point}
+    (hK : K ∈ AddSubgroup.zmultiples Q) : P + K ≠ 0 := fun h =>
+  hPmem (by rw [add_eq_zero_iff_eq_neg] at h; exact h ▸ AddSubgroup.neg_mem _ hK)
+
+theorem xOrZero_ne_of_not_mem_zmultiples {P : W.toAffine.Point}
+    (hPmem : P ∉ AddSubgroup.zmultiples Q) (hP0 : P ≠ 0) {x y : F}
+    {h : W.toAffine.Nonsingular x y} (hkQ : Point.some x y h ∈ AddSubgroup.zmultiples Q) :
+    P.xOrZero ≠ x := by
+  obtain ⟨a, b, hns, rfl, -⟩ := exists_some_of_ne_zero hP0
+  intro hx
+  rcases (Point.X_eq_iff (h₁ := hns) (h₂ := h)).mp hx with hPP | hPP
+  · exact hPmem (hPP ▸ hkQ)
+  · exact hPmem (hPP ▸ AddSubgroup.neg_mem _ hkQ)
+
+theorem sum_range_addOrderOf_shift_invariant {G : Type*} [AddCommGroup G] {Q : G}
+    {p : ℕ} (hord : addOrderOf Q = p) {M : Type*} [AddCommMonoid M] (f : G → M) (R : G) :
+    ∑ j ∈ Finset.range p, f (R + Q + j • Q) = ∑ j ∈ Finset.range p, f (R + j • Q) := by
+  rcases Nat.eq_zero_or_pos p with rfl | hp0
+  · simp
+  have hpQ : p • Q = 0 := hord ▸ addOrderOf_nsmul_eq_zero Q
+  have hLHS : ∑ j ∈ Finset.range p, f (R + Q + j • Q)
+      = ∑ k ∈ Finset.Ico 1 (p + 1), f (R + k • Q) := by
+    rw [show Finset.Ico 1 (p + 1) = (Finset.range p).map ⟨(· + 1), add_left_injective 1⟩ from by
+      ext k; simp only [Finset.mem_Ico, Finset.mem_map, Finset.mem_range,
+        Function.Embedding.coeFn_mk]
+      constructor
+      · exact fun ⟨h1, h2⟩ => ⟨k - 1, by omega, by omega⟩
+      · rintro ⟨a, ha, rfl⟩; omega]
+    rw [Finset.sum_map]
+    exact Finset.sum_congr rfl fun j _ => by
+      simp only [Function.Embedding.coeFn_mk]; rw [succ_nsmul', ← add_assoc]
+  have hRHS : ∑ j ∈ Finset.range p, f (R + j • Q)
+      = f (R + 0 • Q) + ∑ k ∈ Finset.Ico 1 p, f (R + k • Q) := by
+    rw [show Finset.range p = insert 0 (Finset.Ico 1 p) from by
+      ext k; simp only [Finset.mem_range, Finset.mem_insert, Finset.mem_Ico]; omega]
+    rw [Finset.sum_insert (by simp)]
+  rw [hLHS, hRHS]
+  have hIco_split : Finset.Ico 1 (p + 1) = insert p (Finset.Ico 1 p) := by
+    ext k; simp only [Finset.mem_insert, Finset.mem_Ico]; omega
+  rw [hIco_split, Finset.sum_insert (by simp), hpQ, zero_nsmul]
+
+end FullPeriod
+end WeierstrassCurve
+end
+
+section
+
+section
+
+noncomputable section
+
+namespace WeierstrassCurve
+namespace Affine
+
+universe u
+
+variable {F : Type u} [Field F]
+
+section GenericPoint
+
+variable {W : Affine F}
+
+public theorem polyToFunctionField_eq_aeval (p : F[X]) :
+    polyToFunctionField W p = Polynomial.aeval (polyToFunctionField W X) p := by
+  have h1 : (polyToFunctionField W : F[X] →+* W.FunctionField)
+      = algebraMap F[X] W.FunctionField :=
+    (IsScalarTower.algebraMap_eq F[X] W.CoordinateRing W.FunctionField).symm
+  have h2 : (IsScalarTower.toAlgHom F F[X] W.FunctionField : F[X] →ₐ[F] W.FunctionField)
+      = Polynomial.aeval (polyToFunctionField W X) := by
+    refine Polynomial.algHom_ext ?_
+    rw [Polynomial.aeval_X, IsScalarTower.coe_toAlgHom', ← h1]
+  calc polyToFunctionField W p = algebraMap F[X] W.FunctionField p := by rw [h1]
+    _ = (IsScalarTower.toAlgHom F F[X] W.FunctionField : F[X] →ₐ[F] W.FunctionField) p := rfl
+    _ = Polynomial.aeval (polyToFunctionField W X) p := by rw [h2]
+
+public theorem polyToFunctionField_X_ne_algebraMap (c : F) :
+    polyToFunctionField W X ≠ algebraMap F W.FunctionField c := by
+  intro hcon
+  refine polyToFunctionField_ne_zero (W := W) (X_sub_C_ne_zero c) ?_
+  rw [map_sub, polyToFunctionField_C, hcon, sub_self]
+
+end GenericPoint
+end Affine
+end WeierstrassCurve
+end
+
+noncomputable section
+
+namespace WeierstrassCurve
+section BaseChange
+
+variable {F F' : Type*} [Field F] [Field F'] (W : WeierstrassCurve F) (f : F →+* F')
+
+lemma map_veluX' (S : Finset (F × F)) (hf : Function.Injective f) (x : F) :
+    (W.map f).veluX (S.map ⟨Prod.map f f, hf.prodMap hf⟩) (f x) = f (W.veluX S x) := by
+  simp only [veluX, Finset.sum_map, Function.Embedding.coeFn_mk, Prod.map_fst, Prod.map_snd,
+    map_veluT, map_veluU, map_add, map_sum, map_div₀, map_sub, map_pow]
+
+lemma map_veluY' (S : Finset (F × F)) (hf : Function.Injective f) (x y : F) :
+    (W.map f).veluY (S.map ⟨Prod.map f f, hf.prodMap hf⟩) (f x) (f y) = f (W.veluY S x y) := by
+  simp only [veluY, Finset.sum_map, Function.Embedding.coeFn_mk, Prod.map_fst, Prod.map_snd,
+    map_veluT, map_veluU, map_veluGx, map_veluGy, map_a₁, map_a₃,
+    map_add, map_sub, map_mul, map_div₀, map_pow, map_sum, map_ofNat]
+
+theorem map_veluDeficit (S : Finset (F × F)) (hf : Function.Injective f) (r s : F) :
+    (W.map f).veluDeficit (S.map ⟨Prod.map f f, hf.prodMap hf⟩) (f r) (f s)
+      = f (W.veluDeficit S r s) := by
+  simp only [veluDeficit, W.map_veluX' f S hf, W.map_veluY' f S hf,
+    W.map_veluQuotient f S hf, map_a₁, map_a₂, map_a₃, map_a₄, map_a₆,
+    map_add, map_sub, map_mul, map_pow]
+
+end BaseChange
+end WeierstrassCurve
+namespace WeierstrassCurve
+section FunctionFieldLift
+
+variable {F : Type*} [Field F] (W : Affine F)
+
+@[expose] public def liftSummingSet
+    (S : Finset (F × F)) : Finset (W.FunctionField × W.FunctionField) :=
+  S.map ⟨Prod.map (algebraMap F W.FunctionField) (algebraMap F W.FunctionField),
+    (algebraMap F W.FunctionField).injective.prodMap (algebraMap F W.FunctionField).injective⟩
+
+@[expose] public def veluDeficitFun (S : Finset (F × F)) : W.FunctionField :=
+  (W.map (algebraMap F W.FunctionField)).veluDeficit (W.liftSummingSet S)
+    (polyToFunctionField W X) (yGen W)
+
+end FunctionFieldLift
+end WeierstrassCurve
+end
+section
+
+open scoped Pointwise
+
+noncomputable section
+
+namespace WeierstrassCurve
+namespace Affine
+
+universe u
+
+variable {F : Type u} [Field F] {W : Affine F}
+
+section MemEval
+
+theorem XClass_mem_XYIdeal_iff_eq {x' y' : F} (h' : W.Equation x' y') (a : F) :
+    XClass W a ∈ XYIdeal W x' (C y') ↔ x' = a := by
+  rw [show (XClass W a : W.CoordinateRing) = CoordinateRing.mk W (C (X - C a)) from rfl,
+    mk_mem_XYIdeal_iff h']
+  simp [evalEval, sub_eq_zero]
+
+theorem YClass_C_mem_XYIdeal_iff_eq {x' y' : F} (h' : W.Equation x' y') (c : F) :
+    YClass W (C c) ∈ XYIdeal W x' (C y') ↔ y' = c := by
+  rw [show (YClass W (C c) : W.CoordinateRing) = CoordinateRing.mk W (Y - C (C c)) from rfl,
+    mk_mem_XYIdeal_iff h']
+  simp [evalEval, sub_eq_zero]
+
+end MemEval
+section PerCurveEngine
+
+variable [IsAlgClosed F] [IsDedekindDomain W.CoordinateRing]
+
+theorem exists_YClass_negY_notMem_centre {v : Place F W.FunctionField} (hv : IsFinitePlace v)
+    {a b₀ : F} (hab₀ : W.Equation a b₀) (h2tor : W.negY a b₀ ≠ b₀)
+    (hXa : XClass W a ∈ hv.centre) :
+    ∃ b : F, W.Equation a b ∧ XClass W a ∈ hv.centre ∧
+      YClass W (C (W.negY a b)) ∉ hv.centre := by
+  classical
+  obtain ⟨x', y', h', rfl⟩ := (isFinitePlace_iff_exists_placeOfEquation v).mp hv
+  have hcen : hv.centre = XYIdeal W x' (C y') := by
+    rw [Subsingleton.elim hv (isFinitePlace_placeOfEquation h')]; exact centre_placeOfEquation h'
+  have hxa : x' = a := (XClass_mem_XYIdeal_iff_eq h' a).mp (hcen ▸ hXa)
+  subst hxa
+  refine ⟨y', h', hXa, hcen ▸ ?_⟩
+  refine fun hmem => ?_
+  have heq : y' = W.negY x' y' := (YClass_C_mem_XYIdeal_iff_eq h' (W.negY x' y')).mp hmem
+  rcases Y_eq_of_X_eq h' hab₀ rfl with hy | hy
+  · exact h2tor (hy ▸ heq.symm)
+  · rw [hy, negY_negY] at heq; exact h2tor heq
+
+end PerCurveEngine
+end Affine
+end WeierstrassCurve
+namespace WeierstrassCurve
+section YNotCentreDischarge
+
+variable (F : Type*) [Field F] [DecidableEq F] [IsAlgClosed F]
+
+open AlgebraicCurve WeierstrassCurve.Affine.CoordinateRing WeierstrassCurve.Affine
+
+theorem negY_ne_self_of_veluGy_ne_zero {R : Type*} [CommRing R] {W : WeierstrassCurve R}
+    {a b : R} (hgy : W.veluGy a b ≠ 0) : W.toAffine.negY a b ≠ b := by
+  intro heq
+  apply hgy
+  have hkey : W.toAffine.negY a b - b = W.veluGy a b := by
+    simp only [Affine.negY, veluGy]; ring
+  rw [← hkey, heq, sub_self]
+
+end YNotCentreDischarge
+end WeierstrassCurve
+
+end
+
+end
+
+section
+
+noncomputable section
+
+namespace WeierstrassCurve
+section ReducedCofactor
+
+variable {R : Type*} [CommRing R] (W : WeierstrassCurve R)
+
+def veluDeficitPsiCofactorReduced (x₀ x : R) : R :=
+  -6 * x ^ 3 + 18 * x₀ * x ^ 2 + (2 * W.b₂ * x₀ + 2 * W.b₄ - 6 * x₀ ^ 2) * x
+    + (6 * x₀ ^ 3 + W.b₂ * x₀ ^ 2 + 4 * W.b₄ * x₀ + 3 * W.b₆)
+
+theorem veluDeficitPsiCofactor_eq_sq_mul_reduced (x₀ x : R) :
+    W.veluDeficitPsiCofactor x₀ x = (x - x₀) ^ 2 * W.veluDeficitPsiCofactorReduced x₀ x := by
+  simp only [veluDeficitPsiCofactor, veluDeficitPsiCofactorReduced, b₂, b₄, b₆]
+  ring
+
+def veluDeficitPsiCofactorReducedPoly (x₀ : R) : R[X] :=
+  C (-6) * X ^ 3 + C (18 * x₀) * X ^ 2 + C (2 * W.b₂ * x₀ + 2 * W.b₄ - 6 * x₀ ^ 2) * X
+    + C (6 * x₀ ^ 3 + W.b₂ * x₀ ^ 2 + 4 * W.b₄ * x₀ + 3 * W.b₆)
+
+@[scoped simp] lemma eval_veluDeficitPsiCofactorReducedPoly (x₀ x : R) :
+    (W.veluDeficitPsiCofactorReducedPoly x₀).eval x = W.veluDeficitPsiCofactorReduced x₀ x := by
+  simp [veluDeficitPsiCofactorReducedPoly, veluDeficitPsiCofactorReduced]
+
+lemma veluDeficitPsiCofactorReducedPoly_natDegree_le (x₀ : R) :
+    (W.veluDeficitPsiCofactorReducedPoly x₀).natDegree ≤ 3 := by
+  unfold veluDeficitPsiCofactorReducedPoly
+  compute_degree
+
+end ReducedCofactor
+section ReducedField
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+theorem veluDeficit_singleton_mul_pow_four_eq {x₀ y₀ r s : F}
+    (hP : W.toAffine.Equation r s) (hQ : W.toAffine.Equation x₀ y₀) (hr : r ≠ x₀) :
+    W.veluDeficit {(x₀, y₀)} r s * (r - x₀) ^ 4
+      = W.veluDeficitPsiCofactorReduced x₀ r * (W.Ψ₃).eval x₀ := by
+  have hd : (r - x₀) ^ 2 ≠ 0 := pow_ne_zero 2 (sub_ne_zero.mpr hr)
+  have key := W.veluDeficit_singleton_mul_pow_eq_psi hP hQ hr
+  rw [W.veluDeficitPsiCofactor_eq_sq_mul_reduced] at key
+  have h64 : (r - x₀) ^ 6 = (r - x₀) ^ 4 * (r - x₀) ^ 2 := by ring
+  rw [h64, ← mul_assoc] at key
+  exact mul_right_cancel₀ hd (by linear_combination key)
+
+end ReducedField
+section RRCarrier
+
+variable (F : Type*) [Field F] [DecidableEq F]
+
+@[expose] public def VeluDeficitIsConstantAt (p : ℕ) : Prop :=
+  ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+    ∀ (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      addOrderOf (Point.some x₀ y₀ h₀ : W.toAffine.Point) = p →
+        ∃ c : F, ∀ ⦃r s : F⦄, W.toAffine.Equation r s →
+          (∀ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2), r ≠ A.1) →
+          W.veluDeficit (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)) r s = c
+
+end RRCarrier
+section ConstantZero
+
+variable {F : Type*} [Field F]
+
+variable (F)
+variable [DecidableEq F]
+
+@[expose] public def VeluDeficitConstantIsZeroAt (p : ℕ) : Prop :=
+  ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+    ∀ (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      addOrderOf (Point.some x₀ y₀ h₀ : W.toAffine.Point) = p →
+        ∀ c : F, (∀ ⦃r s : F⦄, W.toAffine.Equation r s →
+          (∀ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2), r ≠ A.1) →
+          W.veluDeficit (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)) r s = c) →
+          c = 0
+
+public theorem veluDeficitConstancyAt_of_isConstant_of_constantZero {p : ℕ}
+    (hC : VeluDeficitIsConstantAt F p) (hZ : VeluDeficitConstantIsZeroAt F p) :
+    VeluDeficitConstancyAt F p := by
+  intro W hΔ x₀ y₀ h₀ hord r s hrs hav
+  obtain ⟨c, hc⟩ := hC W hΔ x₀ y₀ h₀ hord
+  rw [hc hrs hav, hZ W hΔ x₀ y₀ h₀ hord c hc]
+
+end ConstantZero
+end WeierstrassCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable [HasPrincipalDivisors K F]
+
+theorem eq_algebraMap_of_forall_ord_nonneg (v₀ : Place K F) (hrat : v₀.IsRational)
+    (hdeg : v₀.deg ≠ 0) {g : F} (hg : g ≠ 0) (hord : ∀ v : Place K F, 0 ≤ v.ord g) :
+    ∃ c : K, g = algebraMap K F c := by
+  have hg₀ : g ∈ v₀.toValuationSubring := v₀.mem_of_ord_nonneg hg (hord v₀)
+  refine ⟨v₀.evalAt g, ?_⟩
+  by_contra hne
+  set t : F := g - algebraMap K F (v₀.evalAt g) with ht
+  have htne : t ≠ 0 := sub_ne_zero.mpr hne
+  have hzero : 0 < v₀.ord t := v₀.ord_sub_evalAt_pos hrat hg₀ htne
+  have hpole : ∀ v : Place K F, 0 ≤ v.ord t := fun v =>
+    v.ord_nonneg_of_mem (sub_mem (v.mem_of_ord_nonneg hg (hord v)) (v.algebraMap_mem' _))
+  obtain ⟨D, hD, hdeg0⟩ := HasPrincipalDivisors.exists_divisor (K := K) t htne
+  have hDpos : 0 < D v₀ := by rw [hD v₀]; exact hzero
+  have hDnonneg : ∀ v, 0 ≤ D v := fun v => by rw [hD v]; exact hpole v
+  have hmem : v₀ ∈ D.support := Finsupp.mem_support_iff.mpr hDpos.ne'
+  have hpos : 0 < Divisor.degree D := by
+    rw [Divisor.degree_eq_sum_support]
+    calc (0 : ℤ) < D v₀ * (v₀.deg : ℤ) :=
+          mul_pos hDpos (by exact_mod_cast Nat.pos_of_ne_zero hdeg)
+      _ ≤ ∑ v ∈ D.support, D v * (v.deg : ℤ) :=
+          Finset.single_le_sum
+            (fun v _ => mul_nonneg (hDnonneg v) (Int.natCast_nonneg _)) hmem
+  omega
+
+end Place
+end AlgebraicCurve
+end
+section
+
+noncomputable section
+
+namespace WeierstrassCurve
+namespace Affine
+
+universe u
+
+variable {F : Type u} [Field F]
+
+section TranslationCoords
+
+variable (W : Affine F) (a b : F)
+
+local notation "ι" => algebraMap F W.FunctionField
+
+def addXFun : W.FunctionField :=
+  (W.map ι).addX (polyToFunctionField W X) (ι a)
+    ((W.map ι).slope (polyToFunctionField W X) (ι a) (yGen W) (ι b))
+
+def addYFun : W.FunctionField :=
+  (W.map ι).addY (polyToFunctionField W X) (ι a) (yGen W)
+    ((W.map ι).slope (polyToFunctionField W X) (ι a) (yGen W) (ι b))
+
+variable {a b} in
+theorem equation_map_addFun (hA : W.Equation a b) :
+    (W.map ι).Equation (W.addXFun a b) (W.addYFun a b) :=
+  Affine.equation_add (W := (W.map ι).toAffine)
+    equation_map_polyToFunctionField_yGen (hA.map ι)
+    (fun h => polyToFunctionField_X_ne_algebraMap a h.1)
+
+variable {a b} in
+theorem eval₂_polynomial_addFun (hA : W.Equation a b) :
+    W.polynomial.eval₂
+      (Polynomial.aeval (R := F) (W.addXFun a b)).toRingHom (W.addYFun a b) = 0 := by
+  have heq := equation_map_addFun W hA
+  rw [equation_iff'] at heq
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆] at heq
+  simp only [WeierstrassCurve.Affine.polynomial, eval₂_add, eval₂_sub, eval₂_mul, eval₂_pow,
+    eval₂_X, eval₂_C, AlgHom.toRingHom_eq_coe, RingHom.coe_coe, map_add, map_mul, map_pow,
+    Polynomial.aeval_C, Polynomial.aeval_X]
+  linear_combination heq
+
+end TranslationCoords
+section GenericPointGroup
+
+variable {W : Affine F}
+
+local notation "ι" => algebraMap F W.FunctionField
+
+theorem map_functionField_Δ_ne_zero (hΔ : W.Δ ≠ 0) : (W.map ι).Δ ≠ 0 := by
+  rw [map_Δ]
+  exact fun h => hΔ ((algebraMap F W.FunctionField).injective (by simpa using h))
+
+theorem nonsingular_map_polyToFunctionField_yGen (hΔ : W.Δ ≠ 0) :
+    (W.map ι).Nonsingular (polyToFunctionField W X) (yGen W) :=
+  (Affine.equation_iff_nonsingular_of_Δ_ne_zero (map_functionField_Δ_ne_zero hΔ)).mp
+    equation_map_polyToFunctionField_yGen
+
+def genericPoint' (hΔ : W.Δ ≠ 0) : (W.map ι).toAffine.Point :=
+  Affine.Point.some (polyToFunctionField W X) (yGen W)
+    (nonsingular_map_polyToFunctionField_yGen hΔ)
+
+theorem nonsingular_map_algebraMap (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b) :
+    (W.map ι).Nonsingular (ι a) (ι b) :=
+  (Affine.equation_iff_nonsingular_of_Δ_ne_zero (map_functionField_Δ_ne_zero hΔ)).mp (hA.map ι)
+
+def mapPoint (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b) : (W.map ι).toAffine.Point :=
+  Affine.Point.some (ι a) (ι b) (nonsingular_map_algebraMap hΔ hA)
+
+theorem nonsingular_map_addFun (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b) :
+    (W.map ι).Nonsingular (W.addXFun a b) (W.addYFun a b) :=
+  (Affine.equation_iff_nonsingular_of_Δ_ne_zero (map_functionField_Δ_ne_zero hΔ)).mp
+    (equation_map_addFun W hA)
+
+theorem genericPoint'_add_map (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b) :
+    genericPoint' hΔ + mapPoint hΔ hA
+      = Affine.Point.some (W.addXFun a b) (W.addYFun a b) (nonsingular_map_addFun hΔ hA) :=
+  Affine.Point.add_of_X_ne (polyToFunctionField_X_ne_algebraMap a)
+
+theorem equation_neg_mapPoint {a b : F} (hA : W.Equation a b) : W.Equation a (W.negY a b) :=
+  (Affine.equation_neg a b).mpr hA
+
+theorem addFun_ne_mapPoint (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b) :
+    ¬ (W.addXFun a b = ι a ∧ W.addYFun a b = ι b) := by
+  intro ⟨hX, hY⟩
+  have heq : Affine.Point.some _ _ (nonsingular_map_addFun hΔ hA) = mapPoint hΔ hA := by
+    change Affine.Point.some _ _ _ = Affine.Point.some _ _ _
+    simp only [Affine.Point.some.injEq]; exact ⟨hX, hY⟩
+  have h0 : genericPoint' hΔ + mapPoint hΔ hA = 0 + mapPoint hΔ hA := by
+    rw [zero_add]; exact (genericPoint'_add_map hΔ hA).trans heq
+  exact Affine.Point.some_ne_zero _ (add_right_cancel h0)
+
+theorem neg_mapPoint_eq (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b) :
+    -(mapPoint hΔ hA) = Affine.Point.some (ι a) (ι (W.negY a b))
+      (nonsingular_map_algebraMap hΔ (equation_neg_mapPoint hA)) := by
+  change Affine.Point.some (ι a) ((W.map ι).negY (ι a) (ι b)) _ = _
+  congr 1
+  exact map_negY ι a b
+
+theorem addFun_neg_mapPoint_hxy (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b) :
+    ¬ (W.addXFun a b = ι a
+        ∧ W.addYFun a b = (W.map ι).negY (ι a) (ι (W.negY a b))) := by
+  rw [map_negY ι a (W.negY a b), Affine.negY_negY]
+  exact addFun_ne_mapPoint hΔ hA
+
+theorem addFun_neg_cancel (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b) :
+    (W.map ι).addX (W.addXFun a b) (ι a)
+        ((W.map ι).slope (W.addXFun a b) (ι a) (W.addYFun a b) (ι (W.negY a b)))
+      = polyToFunctionField W X
+    ∧ (W.map ι).addY (W.addXFun a b) (ι a) (W.addYFun a b)
+        ((W.map ι).slope (W.addXFun a b) (ι a) (W.addYFun a b) (ι (W.negY a b)))
+      = yGen W := by
+  have hns₂ := Affine.nonsingular_add (nonsingular_map_addFun hΔ hA)
+      (nonsingular_map_algebraMap hΔ (equation_neg_mapPoint hA))
+      (addFun_neg_mapPoint_hxy hΔ hA)
+  have hsum : (Affine.Point.some _ _ (nonsingular_map_addFun hΔ hA))
+        + (-(mapPoint hΔ hA))
+      = Affine.Point.some _ _ hns₂ := by
+    rw [neg_mapPoint_eq hΔ hA]
+    exact Affine.Point.add_some (addFun_neg_mapPoint_hxy hΔ hA)
+  have hcancel : Affine.Point.some _ _ hns₂ = genericPoint' hΔ := by
+    rw [← hsum, ← genericPoint'_add_map hΔ hA, add_neg_cancel_right]
+  exact Affine.Point.some.inj hcancel
+
+theorem addFun_neg_cancel_X (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b) :
+    (W.map ι).addX (W.addXFun a b) (ι a)
+        ((W.map ι).slope (W.addXFun a b) (ι a) (W.addYFun a b) (ι (W.negY a b)))
+      = polyToFunctionField W X :=
+  (addFun_neg_cancel hΔ hA).1
+
+theorem addFun_neg_cancel_Y (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b) :
+    (W.map ι).addY (W.addXFun a b) (ι a) (W.addYFun a b)
+        ((W.map ι).slope (W.addXFun a b) (ι a) (W.addYFun a b) (ι (W.negY a b)))
+      = yGen W :=
+  (addFun_neg_cancel hΔ hA).2
+
+end GenericPointGroup
+section CoordHom
+
+variable {W : Affine F} {a b : F} (hA : W.Equation a b)
+
+def translationCoordHom : W.CoordinateRing →ₐ[F] W.FunctionField where
+  __ := AdjoinRoot.lift
+    (Polynomial.aeval (R := F) (W.addXFun a b)).toRingHom
+    (W.addYFun a b) (eval₂_polynomial_addFun W hA)
+  commutes' c := by
+    change AdjoinRoot.lift _ _ (eval₂_polynomial_addFun W hA) (algebraMap F _ c)
+      = algebraMap F W.FunctionField c
+    rw [CoordinateRing.algebraMap_eq_mk_C_C, AdjoinRoot.lift_mk, eval₂_C]
+    exact Polynomial.aeval_C _ c
+
+theorem translationCoordHom_mk (g : F[X][Y]) :
+    translationCoordHom hA (CoordinateRing.mk W g)
+      = g.eval₂ (Polynomial.aeval (R := F) (W.addXFun a b)).toRingHom (W.addYFun a b) :=
+  AdjoinRoot.lift_mk (eval₂_polynomial_addFun W hA) g
+
+theorem translationCoordHom_comp_algebraMap :
+    (translationCoordHom hA).toRingHom.comp (algebraMap F[X] W.CoordinateRing)
+      = (Polynomial.aeval (R := F) (W.addXFun a b)).toRingHom := by
+  refine RingHom.ext fun p => ?_
+  change translationCoordHom hA (algebraMap F[X] _ p) = _
+  rw [algebraMap_polynomial_eq_mk_C, translationCoordHom_mk, eval₂_C]
+
+@[scoped simp] theorem translationCoordHom_XClass :
+    translationCoordHom hA (algebraMap F[X] W.CoordinateRing X) = W.addXFun a b := by
+  rw [algebraMap_polynomial_eq_mk_C, translationCoordHom_mk, eval₂_C]
+  exact Polynomial.aeval_X _
+
+@[scoped simp] theorem translationCoordHom_YClass :
+    translationCoordHom hA (CoordinateRing.mk W Y) = W.addYFun a b := by
+  rw [translationCoordHom_mk]
+  exact eval₂_X _ _
+
+end CoordHom
+section AdjoinSurjective
+
+variable {W : Affine F} (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b)
+
+local notation "ι" => algebraMap F W.FunctionField
+
+theorem transcendental_polyToFunctionField_X :
+    Transcendental F (polyToFunctionField W X) := by
+  rw [transcendental_iff]
+  intro p hp
+  rw [← polyToFunctionField_eq_aeval] at hp
+  exact polyToFunctionField_injective (by simpa using hp)
+
+theorem slope_mem_intermediateField {K : IntermediateField F W.FunctionField}
+    {x₁ x₂ y₁ y₂ : W.FunctionField}
+    (hx₁ : x₁ ∈ K) (hx₂ : x₂ ∈ K) (hy₁ : y₁ ∈ K) (hy₂ : y₂ ∈ K) :
+    (W.map ι).slope x₁ x₂ y₁ y₂ ∈ K := by
+  have hF : ∀ c : F, ι c ∈ K := fun c => (algebraMap F K c).2
+  have hN : ∀ n : ℕ, (n : W.FunctionField) ∈ K := fun n => natCast_mem K n
+  unfold Affine.slope
+  split
+  · split
+    · exact zero_mem K
+    · simp only [map_a₁, map_a₂, map_a₄]
+      refine div_mem (sub_mem (add_mem (add_mem (mul_mem (hN 3) (pow_mem hx₁ 2))
+        (mul_mem (mul_mem (hN 2) (hF _)) hx₁)) (hF _)) (mul_mem (hF _) hy₁)) (sub_mem hy₁ ?_)
+      unfold Affine.negY
+      simp only [map_a₁, map_a₃]
+      exact sub_mem (sub_mem (neg_mem hy₁) (mul_mem (hF _) hx₁)) (hF _)
+  · exact div_mem (sub_mem hy₁ hy₂) (sub_mem hx₁ hx₂)
+
+include hΔ hA in
+theorem polyToFunctionField_X_mem_adjoin_addFun :
+    polyToFunctionField W X
+      ∈ IntermediateField.adjoin F ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField) := by
+  set K := IntermediateField.adjoin F ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField)
+  rw [← addFun_neg_cancel_X hΔ hA]
+  have hX' : W.addXFun a b ∈ K := IntermediateField.subset_adjoin F _ (Or.inl rfl)
+  have hY' : W.addYFun a b ∈ K := IntermediateField.subset_adjoin F _ (Or.inr rfl)
+  have hF : ∀ c : F, ι c ∈ K := fun c => (algebraMap F K c).2
+  have hslope := slope_mem_intermediateField (W := W) hX' (hF a) hY' (hF (W.negY a b))
+  change (W.map ι).addX (W.addXFun a b) (ι a) _ ∈ K
+  rw [Affine.addX]
+  simp only [map_a₁, map_a₂]
+  exact sub_mem (sub_mem (sub_mem (add_mem (pow_mem hslope 2) (mul_mem (hF _) hslope))
+    (hF _)) hX') (hF _)
+
+include hΔ hA in
+theorem yGen_mem_adjoin_addFun :
+    yGen W
+      ∈ IntermediateField.adjoin F ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField) := by
+  set K := IntermediateField.adjoin F ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField)
+  rw [← addFun_neg_cancel_Y hΔ hA]
+  have hX' : W.addXFun a b ∈ K := IntermediateField.subset_adjoin F _ (Or.inl rfl)
+  have hY' : W.addYFun a b ∈ K := IntermediateField.subset_adjoin F _ (Or.inr rfl)
+  have hF : ∀ c : F, ι c ∈ K := fun c => (algebraMap F K c).2
+  have hslope := slope_mem_intermediateField (W := W) hX' (hF a) hY' (hF (W.negY a b))
+  have haddX : (W.map ι).addX (W.addXFun a b) (ι a)
+      ((W.map ι).slope (W.addXFun a b) (ι a) (W.addYFun a b) (ι (W.negY a b))) ∈ K := by
+    rw [Affine.addX]
+    simp only [map_a₁, map_a₂]
+    exact sub_mem (sub_mem (sub_mem (add_mem (pow_mem hslope 2) (mul_mem (hF _) hslope))
+      (hF _)) hX') (hF _)
+  change (W.map ι).addY (W.addXFun a b) (ι a) (W.addYFun a b) _ ∈ K
+  rw [Affine.addY, Affine.negY, Affine.negAddY]
+  simp only [map_a₁, map_a₃]
+  exact sub_mem (sub_mem (neg_mem (add_mem (mul_mem hslope (sub_mem haddX hX')) hY'))
+    (mul_mem (hF _) haddX)) (hF _)
+
+include hΔ hA in
+theorem adjoin_addFun_eq_top :
+    IntermediateField.adjoin F ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField) = ⊤ := by
+  rw [eq_top_iff]
+  intro z _
+  obtain ⟨r, s, _, hrs⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  set K := IntermediateField.adjoin F ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField)
+  have hX : polyToFunctionField W X ∈ K := polyToFunctionField_X_mem_adjoin_addFun hΔ hA
+  have hY : yGen W ∈ K := yGen_mem_adjoin_addFun hΔ hA
+  have hpoly : ∀ p : F[X], polyToFunctionField W p ∈ K := by
+    intro p
+    induction p using Polynomial.induction_on' with
+    | add g h hg hh => rw [map_add]; exact add_mem hg hh
+    | monomial n c =>
+        rw [← C_mul_X_pow_eq_monomial, map_mul, map_pow, polyToFunctionField_C]
+        exact mul_mem (algebraMap F K c).2 (pow_mem hX n)
+  have hcr : ∀ r : W.CoordinateRing,
+      algebraMap W.CoordinateRing W.FunctionField r ∈ K := by
+    intro r
+    obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq (W' := W) r
+    rw [algebraMap_smul_basis]
+    exact add_mem (hpoly p) (mul_mem (hpoly q) hY)
+  rw [← hrs]
+  exact div_mem (hcr r) (hcr s)
+
+end AdjoinSurjective
+section TranslationHom
+
+variable {W : Affine F} {a b : F} (hA : W.Equation a b)
+
+def AddXFunTranscendental (W : Affine F) (a b : F) : Prop :=
+  Transcendental F (W.addXFun a b)
+
+variable (htr : AddXFunTranscendental W a b)
+
+include htr in
+theorem translationCoordHom_injective : Function.Injective (translationCoordHom hA) := by
+  have hker : RingHom.ker (translationCoordHom hA).toRingHom = ⊥ := by
+    have : Module.Finite F[X] W.CoordinateRing :=
+      Module.Finite.of_basis (CoordinateRing.basis W)
+    refine Ideal.eq_bot_of_under_eq_bot (R := F[X]) ?_
+    rw [Ideal.under_def, RingHom.comap_ker, translationCoordHom_comp_algebraMap,
+      ← RingHom.injective_iff_ker_eq_bot]
+    exact (injective_iff_map_eq_zero _).mpr fun p hp => transcendental_iff.mp htr p hp
+  exact (RingHom.injective_iff_ker_eq_bot (translationCoordHom hA).toRingHom).mpr hker
+
+def translationHom : W.FunctionField →ₐ[F] W.FunctionField :=
+  IsFractionRing.liftAlgHom (translationCoordHom_injective hA htr)
+
+theorem translationHom_algebraMap (r : W.CoordinateRing) :
+    translationHom hA htr (algebraMap W.CoordinateRing W.FunctionField r)
+      = translationCoordHom hA r :=
+  IsFractionRing.lift_algebraMap (translationCoordHom_injective hA htr) r
+
+@[scoped simp] theorem translationHom_polyToFunctionField_X :
+    translationHom hA htr (polyToFunctionField W X) = W.addXFun a b := by
+  rw [polyToFunctionField_apply, translationHom_algebraMap, ← translationCoordHom_XClass hA]
+
+@[scoped simp] theorem translationHom_yGen :
+    translationHom hA htr (yGen W) = W.addYFun a b := by
+  change translationHom hA htr (algebraMap _ _ (CoordinateRing.mk W Y)) = _
+  rw [translationHom_algebraMap, translationCoordHom_YClass]
+
+variable (hΔ : W.Δ ≠ 0)
+
+include hΔ in
+theorem translationHom_surjective : Function.Surjective (translationHom hA htr) := by
+  intro z
+  have hz : z ∈ IntermediateField.adjoin F
+      ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField) := by
+    rw [adjoin_addFun_eq_top hΔ hA]; trivial
+  have hle : IntermediateField.adjoin F
+      ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField)
+      ≤ (translationHom hA htr).fieldRange := by
+    refine IntermediateField.adjoin_le_iff.mpr ?_
+    rintro _ (rfl | rfl)
+    · exact ⟨polyToFunctionField W X, translationHom_polyToFunctionField_X hA htr⟩
+    · exact ⟨yGen W, translationHom_yGen hA htr⟩
+  exact hle hz
+
+def translationAlgEquiv : W.FunctionField ≃ₐ[F] W.FunctionField :=
+  AlgEquiv.ofBijective (translationHom hA htr)
+    ⟨(translationHom hA htr).injective, translationHom_surjective hA htr hΔ⟩
+
+end TranslationHom
+end Affine
+end WeierstrassCurve
+end
+
+noncomputable section
+
+namespace WeierstrassCurve
+namespace Affine
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+section OrdPins
+
+variable (v : Place F W.FunctionField)
+
+theorem ord_X_sub_algebraMap_of_not_isFinitePlace (hv : ¬ IsFinitePlace v) (c : F) :
+    v.ord (polyToFunctionField W X - algebraMap F W.FunctionField c) = -2 := by
+  have key : polyToFunctionField W X - algebraMap F W.FunctionField c
+      = polyToFunctionField W (X - C c) := by
+    rw [map_sub, polyToFunctionField_C]
+  rw [key, v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C
+    (ord_X_neg_of_not_isFinitePlace v hv) (X_sub_C_ne_zero c), natDegree_X_sub_C,
+    ord_X_eq_neg_two_of_not_isFinitePlace v hv]
+  norm_num
+
+theorem X_sub_algebraMap_ne_zero (c : F) :
+    (polyToFunctionField W X - algebraMap F W.FunctionField c : W.FunctionField) ≠ 0 :=
+  sub_ne_zero.mpr (polyToFunctionField_X_ne_algebraMap c)
+
+theorem inv_X_sub_algebraMap_mem_of_not_isFinitePlace (hv : ¬ IsFinitePlace v) (c : F) :
+    (polyToFunctionField W X - algebraMap F W.FunctionField c)⁻¹ ∈ v.toValuationSubring := by
+  refine v.mem_of_ord_nonneg (inv_ne_zero (X_sub_algebraMap_ne_zero c)) ?_
+  rw [v.ord_inv, ord_X_sub_algebraMap_of_not_isFinitePlace v hv]
+  omega
+
+theorem X_mul_inv_X_sub_algebraMap_mem_of_not_isFinitePlace (hv : ¬ IsFinitePlace v) (c : F) :
+    polyToFunctionField W X * (polyToFunctionField W X - algebraMap F W.FunctionField c)⁻¹
+      ∈ v.toValuationSubring := by
+  refine v.mem_of_ord_nonneg
+    (mul_ne_zero (polyToFunctionField_ne_zero X_ne_zero)
+      (inv_ne_zero (X_sub_algebraMap_ne_zero c))) ?_
+  rw [v.ord_mul (polyToFunctionField_ne_zero X_ne_zero)
+    (inv_ne_zero (X_sub_algebraMap_ne_zero c)), v.ord_inv,
+    ord_X_eq_neg_two_of_not_isFinitePlace v hv,
+    ord_X_sub_algebraMap_of_not_isFinitePlace v hv]
+  omega
+
+theorem ord_yGen_of_not_isFinitePlace (hv : ¬ IsFinitePlace v) :
+    v.ord (yGen W) = -3 :=
+  ord_Y_eq_neg_three_of_not_isFinitePlace v hv
+
+theorem yGen_mul_inv_X_sub_algebraMap_sq_mem_of_not_isFinitePlace (hv : ¬ IsFinitePlace v)
+    (c : F) :
+    yGen W * ((polyToFunctionField W X - algebraMap F W.FunctionField c)⁻¹) ^ 2
+      ∈ v.toValuationSubring := by
+  have hY : yGen W ≠ (0 : W.FunctionField) := Y_image_ne_zero
+  have hinv : (polyToFunctionField W X - algebraMap F W.FunctionField c)⁻¹
+      ≠ (0 : W.FunctionField) := inv_ne_zero (X_sub_algebraMap_ne_zero c)
+  refine v.mem_of_ord_nonneg (mul_ne_zero hY (pow_ne_zero 2 hinv)) ?_
+  rw [v.ord_mul hY (pow_ne_zero 2 hinv), v.ord_pow, v.ord_inv,
+    ord_X_sub_algebraMap_of_not_isFinitePlace v hv, ord_yGen_of_not_isFinitePlace v hv]
+  omega
+
+theorem natCast_mem (n : ℕ) : (n : W.FunctionField) ∈ v.toValuationSubring := by
+  rw [show (n : W.FunctionField) = algebraMap F W.FunctionField n from (map_natCast _ n).symm]
+  exact v.algebraMap_mem' (n : F)
+
+theorem veluTSum_liftSummingSet_mem (S : Finset (F × F)) :
+    (W.map (algebraMap F W.FunctionField)).veluTSum (W.liftSummingSet S)
+      ∈ v.toValuationSubring := by
+  unfold WeierstrassCurve.veluTSum
+  refine sum_mem fun Q hQ => ?_
+  simp only [liftSummingSet, Finset.mem_map, Function.Embedding.coeFn_mk] at hQ
+  obtain ⟨B, -, rfl⟩ := hQ
+  rw [Prod.map_fst, Prod.map_snd, map_veluT]
+  exact v.algebraMap_mem' _
+
+end OrdPins
+
+section LaurentLift
+
+variable (W)
+
+local notation "W'" => W.map (algebraMap F W.FunctionField)
+
+theorem equation_of_mem_liftSummingSet {S : Finset (F × F)}
+    (hS : ∀ A ∈ S, W.Equation A.1 A.2) :
+    ∀ A ∈ W.liftSummingSet S, (W').toAffine.Equation A.1 A.2 := by
+  intro A hA
+  simp only [liftSummingSet, Finset.mem_map, Function.Embedding.coeFn_mk] at hA
+  obtain ⟨B, hB, rfl⟩ := hA
+  exact (hS B hB).map (algebraMap F W.FunctionField)
+
+public theorem polyToFunctionField_X_ne_of_mem_liftSummingSet {S : Finset (F × F)} :
+    ∀ A ∈ W.liftSummingSet S, polyToFunctionField W X ≠ A.1 := by
+  intro A hA
+  simp only [liftSummingSet, Finset.mem_map, Function.Embedding.coeFn_mk] at hA
+  obtain ⟨B, -, rfl⟩ := hA
+  exact polyToFunctionField_X_ne_algebraMap B.1
+
+theorem veluDeficitFun_eq_laurentSum_add_bracket {S : Finset (F × F)}
+    (hS : ∀ A ∈ S, W.Equation A.1 A.2) :
+    W.veluDeficitFun S
+      = (∑ Q ∈ W.liftSummingSet S, (-((W').veluU Q.1 Q.2) ^ 2 / (polyToFunctionField W X - Q.1) ^ 3
+          - 3 * (W').veluT Q.1 Q.2 * (W').veluU Q.1 Q.2 / (polyToFunctionField W X - Q.1) ^ 2
+          - (3 * ((W').veluT Q.1 Q.2) ^ 2 + 6 * ((W').Ψ₃).eval Q.1)
+              / (polyToFunctionField W X - Q.1)))
+        + (W').veluDeficitBracket (W.liftSummingSet S) (polyToFunctionField W X) (yGen W) :=
+  (W').veluDeficit_eq_laurentSum_add_bracket equation_map_polyToFunctionField_yGen
+    (equation_of_mem_liftSummingSet W hS) (polyToFunctionField_X_ne_of_mem_liftSummingSet W)
+
+end LaurentLift
+
+section Corrections
+
+variable {v : Place F W.FunctionField}
+
+local notation "W'" => W.map (algebraMap F W.FunctionField)
+local notation "ι" => algebraMap F W.FunctionField
+local notation "𝕏" => polyToFunctionField W X
+local notation "𝕐" => yGen W
+
+theorem veluXCorr_genericPoint'_mem_of_not_isFinitePlace (hv : ¬ IsFinitePlace v) (c d : F) :
+    (W').veluXCorr (ι c) (ι d) 𝕏 ∈ v.toValuationSubring := by
+  have hδ := inv_X_sub_algebraMap_mem_of_not_isFinitePlace v hv c
+  unfold WeierstrassCurve.veluXCorr
+  rw [div_eq_mul_inv, div_eq_mul_inv, ← inv_pow, map_veluT, map_veluU]
+  exact add_mem (mul_mem (v.algebraMap_mem' _) hδ)
+    (mul_mem (v.algebraMap_mem' _) (pow_mem hδ 2))
+
+theorem veluYCorr_genericPoint'_mem_of_not_isFinitePlace (hv : ¬ IsFinitePlace v) (c d : F) :
+    (W').veluYCorr (ι c) (ι d) 𝕏 𝕐 ∈ v.toValuationSubring := by
+  have hδ := inv_X_sub_algebraMap_mem_of_not_isFinitePlace v hv c
+  have hXδ := X_mul_inv_X_sub_algebraMap_mem_of_not_isFinitePlace v hv c
+  have hYδ := yGen_mul_inv_X_sub_algebraMap_sq_mem_of_not_isFinitePlace v hv c
+  set δ : W.FunctionField := (𝕏 - ι c)⁻¹ with hδdef
+  have key : (W').veluYCorr (ι c) (ι d) 𝕏 𝕐
+      = -((2 * ι (W.veluU c d)) * (𝕐 * δ ^ 2) * δ
+          + (ι (W.a₁ * W.veluU c d)) * (𝕏 * δ) * δ ^ 2
+          + (ι (W.a₃ * W.veluU c d)) * δ ^ 3
+          + (ι (W.a₁ * W.veluT c d)) * δ
+          + (ι (W.veluT c d)) * (𝕐 * δ ^ 2)
+          + (-ι (d * W.veluT c d)) * δ ^ 2
+          + (ι (W.a₁ * W.veluU c d - W.veluGx c d * W.veluGy c d)) * δ ^ 2) := by
+    have hδne : (𝕏 - ι c : W.FunctionField) ≠ 0 := X_sub_algebraMap_ne_zero c
+    unfold WeierstrassCurve.veluYCorr
+    simp only [map_veluU, map_veluT, map_veluGx, map_veluGy, map_a₁, map_a₃, map_mul, map_sub]
+    rw [hδdef]
+    field_simp
+    ring
+  rw [key]
+  have h2 : (2 : W.FunctionField) ∈ v.toValuationSubring := by
+    have := natCast_mem v 2; push_cast at this; exact this
+  refine neg_mem (add_mem (add_mem (add_mem (add_mem (add_mem (add_mem ?_ ?_) ?_) ?_) ?_) ?_) ?_)
+  · exact mul_mem (mul_mem (mul_mem h2 (v.algebraMap_mem' _)) hYδ) hδ
+  · exact mul_mem (mul_mem (v.algebraMap_mem' _) hXδ) (pow_mem hδ 2)
+  · exact mul_mem (v.algebraMap_mem' _) (pow_mem hδ 3)
+  · exact mul_mem (v.algebraMap_mem' _) hδ
+  · exact mul_mem (v.algebraMap_mem' _) hYδ
+  · exact mul_mem (neg_mem (v.algebraMap_mem' _)) (pow_mem hδ 2)
+  · exact mul_mem (v.algebraMap_mem' _) (pow_mem hδ 2)
+
+public theorem veluX_sub_self_genericPoint'_mem_of_not_isFinitePlace (hv : ¬ IsFinitePlace v)
+    (S : Finset (F × F)) :
+    (W').veluX (W.liftSummingSet S) 𝕏 - 𝕏 ∈ v.toValuationSubring := by
+  rw [(W').veluX_sub_self_eq_sum_veluXCorr]
+  refine sum_mem fun Q hQ => ?_
+  simp only [liftSummingSet, Finset.mem_map, Function.Embedding.coeFn_mk] at hQ
+  obtain ⟨B, -, rfl⟩ := hQ
+  exact veluXCorr_genericPoint'_mem_of_not_isFinitePlace hv B.1 B.2
+
+theorem veluY_sub_self_genericPoint'_mem_of_not_isFinitePlace (hv : ¬ IsFinitePlace v)
+    (S : Finset (F × F)) :
+    (W').veluY (W.liftSummingSet S) 𝕏 𝕐 - 𝕐 ∈ v.toValuationSubring := by
+  rw [(W').veluY_sub_self_eq_sum_veluYCorr]
+  refine sum_mem fun Q hQ => ?_
+  simp only [liftSummingSet, Finset.mem_map, Function.Embedding.coeFn_mk] at hQ
+  obtain ⟨B, -, rfl⟩ := hQ
+  exact veluYCorr_genericPoint'_mem_of_not_isFinitePlace hv B.1 B.2
+
+theorem X_mul_veluX_sub_self_genericPoint'_mem_of_not_isFinitePlace (hv : ¬ IsFinitePlace v)
+    (S : Finset (F × F)) :
+    𝕏 * ((W').veluX (W.liftSummingSet S) 𝕏 - 𝕏) ∈ v.toValuationSubring := by
+  rw [mul_comm, (W').veluX_sub_self_mul_r (W.liftSummingSet S)
+    (polyToFunctionField_X_ne_of_mem_liftSummingSet W)]
+  refine add_mem (veluTSum_liftSummingSet_mem v S) (sum_mem fun Q hQ => ?_)
+  · simp only [liftSummingSet, Finset.mem_map, Function.Embedding.coeFn_mk] at hQ
+    obtain ⟨B, -, rfl⟩ := hQ
+    have hδ := inv_X_sub_algebraMap_mem_of_not_isFinitePlace v hv B.1
+    simp only [Prod.map_fst, Prod.map_snd, map_veluW, map_veluU, div_eq_mul_inv, ← inv_pow]
+    exact add_mem (mul_mem (v.algebraMap_mem' _) hδ)
+      (mul_mem (mul_mem (v.algebraMap_mem' _) (v.algebraMap_mem' _)) (pow_mem hδ 2))
+
+end Corrections
+
+section Engine
+
+variable {v : Place F W.FunctionField}
+
+local notation "W'" => W.map (algebraMap F W.FunctionField)
+local notation "ι" => algebraMap F W.FunctionField
+local notation "𝕏" => polyToFunctionField W X
+local notation "𝕐" => yGen W
+
+theorem veluDeficitBracket_genericPoint'_mem_of_not_isFinitePlace (hv : ¬ IsFinitePlace v)
+    (S : Finset (F × F)) :
+    (W').veluDeficitBracket (W.liftSummingSet S) 𝕏 𝕐 ∈ v.toValuationSubring := by
+  set α := (W').veluX (W.liftSummingSet S) 𝕏 - 𝕏 with hαdef
+  set β := (W').veluY (W.liftSummingSet S) 𝕏 𝕐 - 𝕐 with hβdef
+  have hα : α ∈ v.toValuationSubring :=
+    veluX_sub_self_genericPoint'_mem_of_not_isFinitePlace hv S
+  have hβ : β ∈ v.toValuationSubring :=
+    veluY_sub_self_genericPoint'_mem_of_not_isFinitePlace hv S
+  have hXα : 𝕏 * α ∈ v.toValuationSubring :=
+    X_mul_veluX_sub_self_genericPoint'_mem_of_not_isFinitePlace hv S
+  have ht : (W').veluTSum (W.liftSummingSet S) ∈ v.toValuationSubring :=
+    veluTSum_liftSummingSet_mem v S
+  have h5 : (5 : W.FunctionField) ∈ v.toValuationSubring := by
+    have := natCast_mem v 5; push_cast at this; exact this
+  have h3 : (3 : W.FunctionField) ∈ v.toValuationSubring := by
+    have := natCast_mem v 3; push_cast at this; exact this
+  have key : (W').veluDeficitBracket (W.liftSummingSet S) 𝕏 𝕐
+      = β ^ 2 + ι W.a₁ * α * β - (3 * (𝕏 * α) * α + ι W.a₂ * α ^ 2) - α ^ 3
+        + 5 * (W').veluTSum (W.liftSummingSet S) * α := by
+    unfold WeierstrassCurve.veluDeficitBracket
+    rw [← hαdef, ← hβdef, map_a₁, map_a₂]
+    ring
+  rw [key]
+  exact add_mem (sub_mem (sub_mem (add_mem (pow_mem hβ 2)
+    (mul_mem (mul_mem (v.algebraMap_mem' _) hα) hβ))
+    (add_mem (mul_mem (mul_mem h3 hXα) hα) (mul_mem (v.algebraMap_mem' _) (pow_mem hα 2))))
+    (pow_mem hα 3)) (mul_mem (mul_mem h5 ht) hα)
+
+theorem veluDeficitFun_mem_of_not_isFinitePlace (hv : ¬ IsFinitePlace v)
+    {S : Finset (F × F)} (hS : ∀ A ∈ S, W.Equation A.1 A.2) :
+    W.veluDeficitFun S ∈ v.toValuationSubring := by
+  rw [veluDeficitFun_eq_laurentSum_add_bracket W hS]
+  refine add_mem (sum_mem fun Q hQ => ?_)
+    (veluDeficitBracket_genericPoint'_mem_of_not_isFinitePlace hv S)
+  simp only [liftSummingSet, Finset.mem_map, Function.Embedding.coeFn_mk] at hQ
+  obtain ⟨B, -, rfl⟩ := hQ
+  have hδ := inv_X_sub_algebraMap_mem_of_not_isFinitePlace v hv B.1
+  have hδ2 : ((𝕏 - ι B.1)⁻¹ : W.FunctionField) ^ 2 ∈ v.toValuationSubring := pow_mem hδ 2
+  have hδ3 : ((𝕏 - ι B.1)⁻¹ : W.FunctionField) ^ 3 ∈ v.toValuationSubring := pow_mem hδ 3
+  have h3 : (3 : W.FunctionField) ∈ v.toValuationSubring := by
+    have := natCast_mem v 3; push_cast at this; exact this
+  have h6 : (6 : W.FunctionField) ∈ v.toValuationSubring := by
+    have := natCast_mem v 6; push_cast at this; exact this
+  rw [Prod.map_fst, Prod.map_snd, map_veluU, map_veluT,
+    div_eq_mul_inv, div_eq_mul_inv, div_eq_mul_inv, ← inv_pow, ← inv_pow]
+  refine sub_mem (sub_mem (mul_mem ?_ hδ3) (mul_mem ?_ hδ2)) (mul_mem ?_ hδ)
+  · exact neg_mem (pow_mem (v.algebraMap_mem' _) 2)
+  · exact mul_mem (mul_mem h3 (v.algebraMap_mem' _)) (v.algebraMap_mem' _)
+  · have hΨ : ((W').Ψ₃).eval (ι B.1) = ι (W.Ψ₃.eval B.1) := by
+      rw [WeierstrassCurve.map_Ψ₃, Polynomial.eval_map, Polynomial.eval₂_at_apply]
+    rw [hΨ]
+    exact add_mem (mul_mem h3 (pow_mem (v.algebraMap_mem' _) 2))
+      (mul_mem h6 (v.algebraMap_mem' _))
+
+theorem ord_veluDeficitFun_nonneg_of_not_isFinitePlace (hv : ¬ IsFinitePlace v)
+    {S : Finset (F × F)} (hS : ∀ A ∈ S, W.Equation A.1 A.2) :
+    0 ≤ v.ord (W.veluDeficitFun S) :=
+  v.ord_nonneg_of_mem (veluDeficitFun_mem_of_not_isFinitePlace hv hS)
+
+end Engine
+
+end Affine
+end WeierstrassCurve
+
+end
+
+
+section
+
+noncomputable section
+
+namespace WeierstrassCurve
+section ClearedPoly
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+omit [DecidableEq F] in
+def veluKernelDenom (S : Finset (F × F)) : F[X] := ∏ A ∈ S, (X - C A.1)
+
+omit [DecidableEq F] in
+lemma veluKernelDenom_monic (S : Finset (F × F)) :
+    (veluKernelDenom (F := F) S).Monic :=
+  monic_prod_of_monic _ _ fun _ _ => monic_X_sub_C _
+
+omit [DecidableEq F] in
+lemma veluKernelDenom_natDegree (S : Finset (F × F)) :
+    (veluKernelDenom (F := F) S).natDegree = S.card := by
+  unfold veluKernelDenom
+  rw [natDegree_prod_of_monic _ _ fun _ _ => monic_X_sub_C _]
+  simp
+
+omit [DecidableEq F] in
+lemma eval_veluKernelDenom (S : Finset (F × F)) (r : F) :
+    (veluKernelDenom (F := F) S).eval r = ∏ A ∈ S, (r - A.1) := by
+  simp [veluKernelDenom, eval_prod]
+
+def veluDeficitSingletonSumClearedPoly (S : Finset (F × F)) : F[X] :=
+  ∑ A ∈ S, C ((W.Ψ₃).eval A.1) * W.veluDeficitPsiCofactorReducedPoly A.1
+    * (∏ B ∈ S.erase A, (X - C B.1)) ^ 4
+
+theorem veluDeficit_sum_singleton_mul_prodPow_eq {S : Finset (F × F)} {r s : F}
+    (hP : W.toAffine.Equation r s) (hSeq : ∀ A ∈ S, W.toAffine.Equation A.1 A.2)
+    (hav : ∀ A ∈ S, r ≠ A.1) :
+    (∑ A ∈ S, W.veluDeficit {A} r s) * (∏ A ∈ S, (r - A.1)) ^ 4
+      = (W.veluDeficitSingletonSumClearedPoly S).eval r := by
+  rw [veluDeficitSingletonSumClearedPoly, eval_finsetSum, Finset.sum_mul]
+  refine Finset.sum_congr rfl fun A hA => ?_
+  have hsplit : (∏ B ∈ S, (r - B.1)) ^ 4
+      = (r - A.1) ^ 4 * (∏ B ∈ S.erase A, (r - B.1)) ^ 4 := by
+    rw [← mul_pow, ← Finset.prod_erase_mul S _ hA, mul_comm]
+  rw [hsplit, ← mul_assoc,
+    show ({A} : Finset (F × F)) = {(A.1, A.2)} by simp,
+    W.veluDeficit_singleton_mul_pow_four_eq hP (hSeq A hA) (hav A hA)]
+  simp only [eval_mul, eval_C, eval_pow, eval_prod, eval_sub, eval_X,
+    eval_veluDeficitPsiCofactorReducedPoly]
+  ring
+
+theorem veluDeficitSingletonSumClearedPoly_natDegree_lt {S : Finset (F × F)}
+    (hS : S.Nonempty) :
+    (W.veluDeficitSingletonSumClearedPoly S).natDegree < 4 * S.card := by
+  have hScard : 0 < S.card := Finset.card_pos.mpr hS
+  refine lt_of_le_of_lt (b := 4 * S.card - 1)
+    (natDegree_le_iff_degree_le.mpr ?_) (by omega)
+  refine (degree_sum_le _ _).trans (Finset.sup_le fun A hA => ?_)
+  refine degree_le_natDegree.trans (Nat.cast_le.mpr ?_)
+  have hcard : (S.erase A).card = S.card - 1 := Finset.card_erase_of_mem hA
+  calc (C ((W.Ψ₃).eval A.1) * W.veluDeficitPsiCofactorReducedPoly A.1
+          * (∏ B ∈ S.erase A, (X - C B.1)) ^ 4).natDegree
+      ≤ (C ((W.Ψ₃).eval A.1) * W.veluDeficitPsiCofactorReducedPoly A.1).natDegree
+          + ((∏ B ∈ S.erase A, ((X : F[X]) - C B.1)) ^ 4).natDegree := natDegree_mul_le
+    _ ≤ 3 + 4 * (S.card - 1) := by
+        refine add_le_add ((natDegree_C_mul_le _ _).trans
+            (W.veluDeficitPsiCofactorReducedPoly_natDegree_le A.1)) ?_
+        rw [natDegree_pow, natDegree_prod_of_monic _ _ fun _ _ => monic_X_sub_C _]
+        simp only [natDegree_X_sub_C, Finset.sum_const, smul_eq_mul, mul_one, hcard, le_refl]
+    _ ≤ 4 * S.card - 1 := by omega
+
+theorem veluDeficit_mul_prodPow_eq_clearedPoly_add_crossQuad {S : Finset (F × F)} {r s : F}
+    (hP : W.toAffine.Equation r s) (hSeq : ∀ A ∈ S, W.toAffine.Equation A.1 A.2)
+    (hav : ∀ A ∈ S, r ≠ A.1) :
+    W.veluDeficit S r s * (∏ A ∈ S, (r - A.1)) ^ 4
+      = (W.veluDeficitSingletonSumClearedPoly S).eval r
+        + W.veluDeficitCrossQuad S r s * (∏ A ∈ S, (r - A.1)) ^ 4 := by
+  rw [W.veluDeficit_eq_sum_singleton_add_crossQuad hP, add_mul,
+    W.veluDeficit_sum_singleton_mul_prodPow_eq hP hSeq hav]
+
+end ClearedPoly
+
+section ArchetypeGeneralD
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+theorem veluDeficit_isConstant_constant_eq_zero_of_crossQuadProdDegLt [Infinite F]
+    {S : Finset (F × F)} (hS : S.Nonempty) {c : F}
+    (hSeq : ∀ A ∈ S, W.toAffine.Equation A.1 A.2)
+    (habs : ∀ r : F, ∃ s, W.toAffine.Equation r s)
+    (hc : ∀ ⦃r s : F⦄, W.toAffine.Equation r s → (∀ A ∈ S, r ≠ A.1) →
+      W.veluDeficit S r s = c)
+    {M : F[X]} (hMdeg : M.natDegree < 4 * S.card)
+    (hM : ∀ ⦃r s : F⦄, W.toAffine.Equation r s → (∀ A ∈ S, r ≠ A.1) →
+      W.veluDeficitCrossQuad S r s * (∏ A ∈ S, (r - A.1)) ^ 4 = M.eval r) :
+    c = 0 := by
+  classical
+  set D : F[X] := veluKernelDenom S with hD_def
+  set P : F[X] := C c * D ^ 4 - W.veluDeficitSingletonSumClearedPoly S - M with hP_def
+  have hroot : ∀ r ∈ ((S.image Prod.fst : Finset F) : Set F)ᶜ, P.IsRoot r := by
+    intro r hr
+    have hav : ∀ A ∈ S, r ≠ A.1 := by
+      intro A hA hrA; apply hr
+      exact Finset.mem_coe.mpr (hrA ▸ Finset.mem_image_of_mem Prod.fst hA)
+    obtain ⟨s, hrs⟩ := habs r
+    have key := W.veluDeficit_mul_prodPow_eq_clearedPoly_add_crossQuad hrs hSeq hav
+    rw [hc hrs hav, hM hrs hav] at key
+    simp only [IsRoot, hP_def, hD_def, eval_sub, eval_mul, eval_C, eval_pow,
+      eval_veluKernelDenom]
+    linear_combination key
+  have hinf : (((S.image Prod.fst : Finset F) : Set F)ᶜ).Infinite :=
+    (Set.Finite.infinite_compl (Finset.finite_toSet _))
+  have hP0 : P = 0 := eq_zero_of_infinite_isRoot P (hinf.mono fun r hr => hroot r hr)
+  have hDmon : (D ^ 4).Monic := (veluKernelDenom_monic S).pow 4
+  have hDdeg : (D ^ 4).natDegree = 4 * S.card := by
+    rw [natDegree_pow, hD_def, veluKernelDenom_natDegree]
+  have hcoeff : P.coeff (4 * S.card) = c := by
+    rw [hP_def, coeff_sub, coeff_sub, coeff_C_mul]
+    have h1 : (D ^ 4).coeff (4 * S.card) = 1 := by
+      have := hDmon.coeff_natDegree; rwa [hDdeg] at this
+    have h2 : (W.veluDeficitSingletonSumClearedPoly S).coeff (4 * S.card) = 0 :=
+      coeff_eq_zero_of_natDegree_lt (W.veluDeficitSingletonSumClearedPoly_natDegree_lt hS)
+    have h3 : M.coeff (4 * S.card) = 0 := coeff_eq_zero_of_natDegree_lt hMdeg
+    rw [h1, h2, h3, mul_one, sub_zero, sub_zero]
+  rw [hP0, coeff_zero] at hcoeff
+  exact hcoeff.symm
+
+end ArchetypeGeneralD
+
+section CrossQuadCarrier
+
+variable (F : Type*) [Field F] [DecidableEq F]
+
+@[expose] public def VeluDeficitCrossQuadProdDegLtAt (p : ℕ) : Prop :=
+  ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+    ∀ (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      addOrderOf (Point.some x₀ y₀ h₀ : W.toAffine.Point) = p →
+        ∃ M : F[X], M.natDegree < 4 * ((p - 1) / 2) ∧
+          ∀ ⦃r s : F⦄, W.toAffine.Equation r s →
+            (∀ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2), r ≠ A.1) →
+            W.veluDeficitCrossQuad
+                (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)) r s
+              * (∏ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2),
+                    (r - A.1)) ^ 4
+              = M.eval r
+
+variable {F}
+
+omit [DecidableEq F] in
+theorem Affine.exists_equation_of_isAlgClosed [IsAlgClosed F] (W : WeierstrassCurve F)
+    (r : F) : ∃ s, W.toAffine.Equation r s := by
+  set q : F[X] := X ^ 2 + C (W.a₁ * r + W.a₃) * X
+    - C (r ^ 3 + W.a₂ * r ^ 2 + W.a₄ * r + W.a₆) with hq
+  have hqdeg : q.degree = 2 := by rw [hq]; compute_degree!
+  obtain ⟨s, hs⟩ := IsAlgClosed.exists_root q (by rw [hqdeg]; exact two_ne_zero)
+  refine ⟨s, (Affine.equation_iff ..).mpr ?_⟩
+  have hs' : q.eval s = 0 := hs
+  simp only [hq, eval_sub, eval_add, eval_pow, eval_X, eval_mul, eval_C] at hs'
+  linear_combination hs'
+
+end CrossQuadCarrier
+
+end WeierstrassCurve
+
+end
+
+section
+
+noncomputable section
+
+namespace AlgebraicCurve
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] [HasPrincipalDivisors K F]
+
+theorem exists_eq_algebraMap_of_forall_ord_nonneg₀ (v₀ : Place K F) (hdeg : v₀.deg = 1)
+    {g : F} (hord : ∀ v : Place K F, 0 ≤ v.ord g) :
+    ∃ c : K, g = algebraMap K F c := by
+  rcases eq_or_ne g 0 with rfl | hg
+  · exact ⟨0, (algebraMap K F).map_zero.symm⟩
+  · exact eq_algebraMap_of_forall_ord_nonneg v₀ (v₀.isRational_of_deg_eq_one hdeg)
+      (hdeg ▸ one_ne_zero) hg hord
+
+end Place
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+namespace Affine
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+public theorem functionField_liouville_of_equation [HasPrincipalDivisors F W.FunctionField]
+    [IsDedekindDomain W.CoordinateRing] {x₀ y₀ : F} (h₀ : W.Equation x₀ y₀)
+    {f : W.FunctionField}
+    (hord : ∀ v : AlgebraicCurve.Place F W.FunctionField, 0 ≤ v.ord f) :
+    ∃ c : F, f = algebraMap F W.FunctionField c :=
+  AlgebraicCurve.Place.exists_eq_algebraMap_of_forall_ord_nonneg₀
+    (placeOfEquation h₀) (deg_placeOfEquation h₀) hord
+
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+section LiouvilleCarriers
+
+variable (F : Type*) [Field F] [DecidableEq F]
+
+@[expose] public def VeluDeficitFunOrdNonnegAt (p : ℕ) : Prop :=
+  ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+    ∀ (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      addOrderOf (Point.some x₀ y₀ h₀ : W.toAffine.Point) = p →
+        ∀ v : Place F W.toAffine.FunctionField,
+          0 ≤ v.ord (W.toAffine.veluDeficitFun
+            (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)))
+
+@[expose] public def VeluDeficitFunSpecializesConstAt (p : ℕ) : Prop :=
+  ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+    ∀ (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      addOrderOf (Point.some x₀ y₀ h₀ : W.toAffine.Point) = p →
+        ∀ c : F, W.toAffine.veluDeficitFun
+            (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2))
+              = algebraMap F W.toAffine.FunctionField c →
+        ∀ ⦃r s : F⦄, W.toAffine.Equation r s →
+          (∀ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2), r ≠ A.1) →
+          W.veluDeficit (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)) r s = c
+
+end LiouvilleCarriers
+
+section LiouvilleBridge
+
+variable {F : Type*} [Field F] [DecidableEq F]
+
+theorem veluDeficitIsConstantAt_of_ordNonneg_of_specializesConst' {p : ℕ}
+    (hPD : ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+      HasPrincipalDivisors F W.toAffine.FunctionField)
+    (hDD : ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+      IsDedekindDomain W.toAffine.CoordinateRing)
+    (hreg : VeluDeficitFunOrdNonnegAt F p)
+    (hspec : VeluDeficitFunSpecializesConstAt F p) :
+    VeluDeficitIsConstantAt F p := by
+  intro W hΔ x₀ y₀ h₀ hord
+  have := hPD W hΔ
+  have := hDD W hΔ
+  obtain ⟨c, hc⟩ := Affine.functionField_liouville_of_equation h₀.left
+    (hreg W hΔ x₀ y₀ h₀ hord)
+  exact ⟨c, fun r s hrs hav => hspec W hΔ x₀ y₀ h₀ hord c hc hrs hav⟩
+
+end LiouvilleBridge
+
+end WeierstrassCurve
+
+end
+
+section
+
+section
+
+open scoped Pointwise
+
+noncomputable section
+
+namespace AlgebraicCurve
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem mem_smul_iff_symm_mem (σ : F ≃ₐ[K] F) (v : Place K F) (f : F) :
+    f ∈ (σ • v).toValuationSubring ↔ σ.symm f ∈ v.toValuationSubring := by
+  rw [smul_toValuationSubring, ValuationSubring.mem_pointwise_smul_iff_inv_smul_mem,
+    AlgEquiv.smul_def, AlgEquiv.aut_inv]
+
+end Place
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+namespace Affine
+
+universe u
+
+variable {F : Type u} [Field F] {W : Affine F}
+
+section TransportEngine
+
+theorem isFinitePlace_smul_iff_forall_symm_mem (σ : W.FunctionField ≃ₐ[F] W.FunctionField)
+    (v : AlgebraicCurve.Place F W.FunctionField) :
+    IsFinitePlace (σ • v) ↔
+      ∀ r : W.CoordinateRing,
+        σ.symm (algebraMap W.CoordinateRing W.FunctionField r) ∈ v.toValuationSubring := by
+  unfold IsFinitePlace
+  exact forall_congr' fun r => Place.mem_smul_iff_symm_mem σ v _
+
+theorem not_isFinitePlace_smul_of_symm_X_notMem
+    (σ : W.FunctionField ≃ₐ[F] W.FunctionField) (v : AlgebraicCurve.Place F W.FunctionField)
+    (h : σ.symm (polyToFunctionField W X) ∉ v.toValuationSubring) :
+    ¬ IsFinitePlace (σ • v) := by
+  rw [isFinitePlace_smul_iff_forall_symm_mem]
+  intro hall
+  apply h
+  have := hall (algebraMap F[X] W.CoordinateRing X)
+  rwa [← polyToFunctionField_apply] at this
+
+end TransportEngine
+
+section NonDegeneracy
+
+variable (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b)
+
+local notation "ι" => algebraMap F W.FunctionField
+
+include hΔ hA in
+theorem addXFun_ne_algebraMap : W.addXFun a b ≠ ι a := by
+  classical
+  intro hX
+  have hY : W.addYFun a b = ι (W.negY a b) := by
+    have heq := equation_map_addFun W hA
+    rw [hX] at heq
+    rcases Affine.Y_eq_of_X_eq heq (hA.map ι) rfl with hY | hY
+    · exact absurd ⟨hX, hY⟩ (addFun_ne_mapPoint hΔ hA)
+    · rw [hY, map_negY]
+  have hcancel := addFun_neg_cancel_X hΔ hA
+  rw [hX, hY] at hcancel
+  rw [Affine.map_slope ι a a (W.negY a b) (W.negY a b),
+    Affine.map_addX (W' := W) ι a a (W.slope a a (W.negY a b) (W.negY a b))] at hcancel
+  exact polyToFunctionField_X_ne_algebraMap _ hcancel.symm
+
+end NonDegeneracy
+
+end Affine
+end WeierstrassCurve
+
+end
+
+end
+
+section
+
+noncomputable section
+
+namespace WeierstrassCurve
+section Parity
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+theorem veluDeficit_negY (S : Finset (F × F)) (r s : F) :
+    W.veluDeficit S r (W.toAffine.negY r s) = W.veluDeficit S r s := by
+  unfold veluDeficit
+  rw [W.veluY_negY]
+  simp only [Affine.negY, veluQuotient_a₁, veluQuotient_a₃]
+  ring
+
+theorem veluDeficit_sum_singleton_negY (S : Finset (F × F)) (r s : F) :
+    (∑ A ∈ S, W.veluDeficit {A} r (W.toAffine.negY r s))
+      = ∑ A ∈ S, W.veluDeficit {A} r s :=
+  Finset.sum_congr rfl fun A _ => W.veluDeficit_negY {A} r s
+
+theorem veluDeficitCrossQuad_negY_of_equation {S : Finset (F × F)} {r s : F}
+    (hP : W.toAffine.Equation r s) :
+    W.veluDeficitCrossQuad S r (W.toAffine.negY r s) = W.veluDeficitCrossQuad S r s := by
+  have hP' : W.toAffine.Equation r (W.toAffine.negY r s) := (Affine.equation_neg r s).mpr hP
+  have key := W.veluDeficit_eq_sum_singleton_add_crossQuad (S := S) hP'
+  rw [W.veluDeficit_negY, W.veluDeficit_sum_singleton_negY,
+    W.veluDeficit_eq_sum_singleton_add_crossQuad hP] at key
+  exact (add_left_cancel key).symm
+
+end Parity
+
+section AlphaPoly
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+omit [DecidableEq F] in
+def veluXCorrNumPoly (A : F × F) : F[X] :=
+  C (W.veluT A.1 A.2) * (X - C A.1) + C (W.veluU A.1 A.2)
+
+omit [DecidableEq F] in
+lemma veluXCorrNumPoly_natDegree_le (A : F × F) :
+    (W.veluXCorrNumPoly A).natDegree ≤ 1 := by
+  unfold veluXCorrNumPoly; compute_degree
+
+def veluXCorrPadPoly (S : Finset (F × F)) (A : F × F) : F[X] :=
+  W.veluXCorrNumPoly A * (∏ B ∈ S.erase A, (X - C B.1)) ^ 2
+
+theorem eval_veluXCorrPadPoly {S : Finset (F × F)} {A : F × F} (hA : A ∈ S) {r : F}
+    (hav : ∀ B ∈ S, r ≠ B.1) :
+    (W.veluX {A} r - r) * (∏ B ∈ S, (r - B.1)) ^ 2
+      = (W.veluXCorrPadPoly S A).eval r := by
+  have hd : r - A.1 ≠ 0 := sub_ne_zero.mpr (hav A hA)
+  have hsplit : (∏ B ∈ S, (r - B.1)) ^ 2
+      = (r - A.1) ^ 2 * (∏ B ∈ S.erase A, (r - B.1)) ^ 2 := by
+    rw [← mul_pow, ← Finset.prod_erase_mul S _ hA, mul_comm]
+  rw [hsplit, ← mul_assoc, veluXCorrPadPoly, veluXCorrNumPoly]
+  simp only [veluX, Finset.sum_singleton, eval_mul, eval_add, eval_C, eval_sub, eval_X,
+    eval_pow, eval_prod]
+  field_simp
+  ring
+
+def veluXCorrSumPadPoly (S : Finset (F × F)) : F[X] := ∑ A ∈ S, W.veluXCorrPadPoly S A
+
+omit [DecidableEq F] in
+lemma veluX_sub_self_eq_sum_singleton (S : Finset (F × F)) (r : F) :
+    W.veluX S r - r = ∑ A ∈ S, (W.veluX {A} r - r) := by
+  simp only [veluX, Finset.sum_singleton, add_sub_cancel_left]
+
+theorem eval_veluXCorrSumPadPoly {S : Finset (F × F)} {r : F} (hav : ∀ B ∈ S, r ≠ B.1) :
+    (W.veluX S r - r) * (∏ B ∈ S, (r - B.1)) ^ 2
+      = (W.veluXCorrSumPadPoly S).eval r := by
+  rw [veluXCorrSumPadPoly, eval_finsetSum, W.veluX_sub_self_eq_sum_singleton, Finset.sum_mul]
+  exact Finset.sum_congr rfl fun A hA => W.eval_veluXCorrPadPoly hA hav
+
+theorem veluXCorrPadPoly_natDegree_le {S : Finset (F × F)} {A : F × F} (hA : A ∈ S) :
+    (W.veluXCorrPadPoly S A).natDegree ≤ 2 * S.card - 1 := by
+  have hScard : 1 ≤ S.card := Finset.one_le_card.mpr ⟨A, hA⟩
+  unfold veluXCorrPadPoly
+  calc (W.veluXCorrNumPoly A * (∏ B ∈ S.erase A, ((X : F[X]) - C B.1)) ^ 2).natDegree
+      ≤ 1 + 2 * (S.card - 1) := by
+        refine natDegree_mul_le.trans (add_le_add (W.veluXCorrNumPoly_natDegree_le A) ?_)
+        rw [natDegree_pow, natDegree_prod_of_monic _ _ fun _ _ => monic_X_sub_C _]
+        simp [Finset.card_erase_of_mem hA]
+    _ ≤ 2 * S.card - 1 := by omega
+
+theorem veluXCorrSumPadPoly_natDegree_le (S : Finset (F × F)) :
+    (W.veluXCorrSumPadPoly S).natDegree ≤ 2 * S.card - 1 := by
+  refine natDegree_le_iff_degree_le.mpr ((degree_sum_le _ _).trans (Finset.sup_le fun A hA => ?_))
+  exact degree_le_natDegree.trans (Nat.cast_le.mpr (W.veluXCorrPadPoly_natDegree_le hA))
+
+end AlphaPoly
+
+section AlphaSqCross
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+@[expose] public def veluDeficitCrossQuadAlphaSq (S : Finset (F × F)) (r : F) : F :=
+  (-(3 * r + W.a₂) * (W.veluX S r - r) ^ 2 + 5 * W.veluTSum S * (W.veluX S r - r))
+    - ∑ A ∈ S, (-(3 * r + W.a₂) * (W.veluX {A} r - r) ^ 2
+        + 5 * W.veluTSum {A} * (W.veluX {A} r - r))
+
+@[expose] public def veluDeficitCrossQuadCubeBeta (S : Finset (F × F)) (r s : F) : F :=
+  W.veluDeficitCrossQuad S r s - W.veluDeficitCrossQuadAlphaSq S r
+
+omit [DecidableEq F] in
+lemma veluDeficitCrossQuad_eq_alphaSq_add_cubeBeta (S : Finset (F × F)) (r s : F) :
+    W.veluDeficitCrossQuad S r s
+      = W.veluDeficitCrossQuadAlphaSq S r + W.veluDeficitCrossQuadCubeBeta S r s := by
+  unfold veluDeficitCrossQuadCubeBeta; ring
+
+def veluDeficitCrossQuadAlphaSqClearedPoly (S : Finset (F × F)) : F[X] :=
+  -(C 3 * X + C W.a₂)
+      * ((W.veluXCorrSumPadPoly S) ^ 2 - ∑ A ∈ S, (W.veluXCorrPadPoly S A) ^ 2)
+    + C 5 * (C (W.veluTSum S) * W.veluXCorrSumPadPoly S
+        - ∑ A ∈ S, C (W.veluT A.1 A.2) * W.veluXCorrPadPoly S A)
+      * (veluKernelDenom S) ^ 2
+
+theorem veluDeficitCrossQuadAlphaSq_mul_prodPow_eq {S : Finset (F × F)} {r : F}
+    (hav : ∀ B ∈ S, r ≠ B.1) :
+    W.veluDeficitCrossQuadAlphaSq S r * (∏ B ∈ S, (r - B.1)) ^ 4
+      = (W.veluDeficitCrossQuadAlphaSqClearedPoly S).eval r := by
+  set D : F := ∏ B ∈ S, (r - B.1)
+  have hD4 : D ^ 4 = D ^ 2 * D ^ 2 := by ring
+  have hαS : (W.veluX S r - r) * D ^ 2 = (W.veluXCorrSumPadPoly S).eval r :=
+    W.eval_veluXCorrSumPadPoly hav
+  have hαA : ∀ A ∈ S, (W.veluX {A} r - r) * D ^ 2 = (W.veluXCorrPadPoly S A).eval r :=
+    fun A hA => W.eval_veluXCorrPadPoly hA hav
+  unfold veluDeficitCrossQuadAlphaSq veluDeficitCrossQuadAlphaSqClearedPoly
+  simp only [eval_add, eval_neg, eval_mul, eval_C, eval_X, eval_sub, eval_pow,
+    eval_finsetSum, eval_veluKernelDenom]
+  rw [sub_mul, Finset.sum_mul, hD4]
+  have key1 : (-(3 * r + W.a₂) * (W.veluX S r - r) ^ 2
+      + 5 * W.veluTSum S * (W.veluX S r - r)) * (D ^ 2 * D ^ 2)
+      = -(3 * r + W.a₂) * ((W.veluXCorrSumPadPoly S).eval r) ^ 2
+        + 5 * (W.veluTSum S * (W.veluXCorrSumPadPoly S).eval r) * D ^ 2 := by
+    rw [← hαS]; ring
+  have key2 : ∀ A ∈ S,
+      (-(3 * r + W.a₂) * (W.veluX {A} r - r) ^ 2
+        + 5 * W.veluTSum {A} * (W.veluX {A} r - r)) * (D ^ 2 * D ^ 2)
+      = -(3 * r + W.a₂) * ((W.veluXCorrPadPoly S A).eval r) ^ 2
+        + 5 * (W.veluT A.1 A.2 * (W.veluXCorrPadPoly S A).eval r) * D ^ 2 := by
+    intro A hA
+    rw [← hαA A hA, veluTSum, Finset.sum_singleton]; ring
+  rw [key1, Finset.sum_congr rfl key2, Finset.sum_add_distrib, ← Finset.sum_mul,
+    ← Finset.mul_sum, ← Finset.mul_sum]
+  ring
+
+theorem veluDeficitCrossQuadAlphaSqClearedPoly_natDegree_lt {S : Finset (F × F)}
+    (hS : S.Nonempty) :
+    (W.veluDeficitCrossQuadAlphaSqClearedPoly S).natDegree < 4 * S.card := by
+  have hScard : 0 < S.card := Finset.card_pos.mpr hS
+  refine lt_of_le_of_lt (b := 4 * S.card - 1)
+    (natDegree_le_iff_degree_le.mpr ?_) (by omega)
+  unfold veluDeficitCrossQuadAlphaSqClearedPoly
+  refine (degree_add_le _ _).trans (max_le ?_ ?_)
+  · rw [neg_mul, degree_neg]
+    refine degree_le_natDegree.trans (Nat.cast_le.mpr ?_)
+    refine natDegree_mul_le.trans ?_
+    have h1 : (C (3 : F) * X + C W.a₂).natDegree ≤ 1 := by compute_degree
+    have h2 : ((W.veluXCorrSumPadPoly S) ^ 2
+        - ∑ A ∈ S, (W.veluXCorrPadPoly S A) ^ 2).natDegree ≤ 2 * (2 * S.card - 1) := by
+      refine (natDegree_sub_le _ _).trans (max_le ?_ ?_)
+      · exact (natDegree_pow_le).trans
+          (Nat.mul_le_mul_left 2 (W.veluXCorrSumPadPoly_natDegree_le S))
+      · refine natDegree_le_iff_degree_le.mpr
+          ((degree_sum_le _ _).trans (Finset.sup_le fun A hA => ?_))
+        refine degree_le_natDegree.trans (Nat.cast_le.mpr ?_)
+        exact (natDegree_pow_le).trans
+          (Nat.mul_le_mul_left 2 (W.veluXCorrPadPoly_natDegree_le hA))
+    omega
+  · refine degree_le_natDegree.trans (Nat.cast_le.mpr ?_)
+    refine natDegree_mul_le.trans ?_
+    have hD : ((veluKernelDenom (F := F) S) ^ 2).natDegree = 2 * S.card := by
+      rw [natDegree_pow, veluKernelDenom_natDegree]
+    rw [hD]
+    have hαbound : (C (5 : F) * (C (W.veluTSum S) * W.veluXCorrSumPadPoly S
+        - ∑ A ∈ S, C (W.veluT A.1 A.2) * W.veluXCorrPadPoly S A)).natDegree
+        ≤ 2 * S.card - 1 := by
+      refine (natDegree_C_mul_le _ _).trans ((natDegree_sub_le _ _).trans (max_le ?_ ?_))
+      · exact (natDegree_C_mul_le _ _).trans (W.veluXCorrSumPadPoly_natDegree_le S)
+      · refine natDegree_le_iff_degree_le.mpr
+          ((degree_sum_le _ _).trans (Finset.sup_le fun A hA => ?_))
+        exact degree_le_natDegree.trans (Nat.cast_le.mpr
+          ((natDegree_C_mul_le _ _).trans (W.veluXCorrPadPoly_natDegree_le hA)))
+    omega
+
+end AlphaSqCross
+
+section Reduction
+
+variable (F : Type*) [Field F] [DecidableEq F]
+
+@[expose] public def VeluDeficitCrossQuadCubeBetaDegLtAt (p : ℕ) : Prop :=
+  ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+    ∀ (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      addOrderOf (Point.some x₀ y₀ h₀ : W.toAffine.Point) = p →
+        ∃ M : F[X], M.natDegree < 4 * ((p - 1) / 2) ∧
+          ∀ ⦃r s : F⦄, W.toAffine.Equation r s →
+            (∀ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2), r ≠ A.1) →
+            W.veluDeficitCrossQuadCubeBeta
+                (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)) r s
+              * (∏ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2),
+                    (r - A.1)) ^ 4
+              = M.eval r
+
+end Reduction
+
+end WeierstrassCurve
+
+end
+
+
+noncomputable section
+
+namespace WeierstrassCurve
+namespace Affine
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem forall_place_ord_nonneg_iff_finite_and_not_finite (g : W.FunctionField) :
+    (∀ v : Place F W.FunctionField, 0 ≤ v.ord g)
+      ↔ (∀ v : Place F W.FunctionField, IsFinitePlace v → 0 ≤ v.ord g)
+        ∧ (∀ v : Place F W.FunctionField, ¬ IsFinitePlace v → 0 ≤ v.ord g) := by
+  constructor
+  · exact fun h => ⟨fun v _ => h v, fun v _ => h v⟩
+  · rintro ⟨hfin, hinf⟩ v
+    by_cases hv : IsFinitePlace v
+    · exact hfin v hv
+    · exact hinf v hv
+
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+section BinaryCarriers
+
+variable (F : Type*) [Field F] [DecidableEq F]
+
+def VeluDeficitFunOrdNonnegAtInftyAt (p : ℕ) : Prop :=
+  ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+    ∀ (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      addOrderOf (Point.some x₀ y₀ h₀ : W.toAffine.Point) = p →
+        ∀ v : Place F W.toAffine.FunctionField, ¬ IsFinitePlace v →
+          0 ≤ v.ord (W.toAffine.veluDeficitFun
+            (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)))
+
+def VeluDeficitFunOrdNonnegAtFiniteAt (p : ℕ) : Prop :=
+  ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+    ∀ (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      addOrderOf (Point.some x₀ y₀ h₀ : W.toAffine.Point) = p →
+        ∀ v : Place F W.toAffine.FunctionField, IsFinitePlace v →
+          0 ≤ v.ord (W.toAffine.veluDeficitFun
+            (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)))
+
+end BinaryCarriers
+
+section BinaryRecombination
+
+variable (F : Type*) [Field F] [DecidableEq F]
+
+theorem veluDeficitFunOrdNonnegAt_iff_atFinite_and_atInfty {p : ℕ} :
+    VeluDeficitFunOrdNonnegAt F p
+      ↔ VeluDeficitFunOrdNonnegAtFiniteAt F p ∧ VeluDeficitFunOrdNonnegAtInftyAt F p := by
+  constructor
+  · exact fun h => ⟨fun W hΔ x₀ y₀ h₀ hord v _ => h W hΔ x₀ y₀ h₀ hord v,
+      fun W hΔ x₀ y₀ h₀ hord v _ => h W hΔ x₀ y₀ h₀ hord v⟩
+  · rintro ⟨hfin, hinf⟩ W hΔ x₀ y₀ h₀ hord v
+    exact ((Affine.forall_place_ord_nonneg_iff_finite_and_not_finite _).mpr
+      ⟨hfin W hΔ x₀ y₀ h₀ hord, hinf W hΔ x₀ y₀ h₀ hord⟩) v
+
+theorem veluDeficitFunOrdNonnegAt_of_atFinite_of_atInfty {p : ℕ}
+    (hfin : VeluDeficitFunOrdNonnegAtFiniteAt F p)
+    (hinf : VeluDeficitFunOrdNonnegAtInftyAt F p) :
+    VeluDeficitFunOrdNonnegAt F p :=
+  (veluDeficitFunOrdNonnegAt_iff_atFinite_and_atInfty F).mpr ⟨hfin, hinf⟩
+
+end BinaryRecombination
+
+section KernelCarriers
+
+variable (F : Type*) [Field F] [DecidableEq F]
+
+def VeluDeficitFunOrdNonnegAtKernelAt (p : ℕ) : Prop :=
+  ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+    ∀ (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      addOrderOf (Point.some x₀ y₀ h₀ : W.toAffine.Point) = p →
+        ∀ (v : Place F W.toAffine.FunctionField) (hv : IsFinitePlace v),
+          (∃ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2),
+            XClass W.toAffine A.1 ∈ hv.centre) →
+          0 ≤ v.ord (W.toAffine.veluDeficitFun
+            (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)))
+
+def VeluDeficitFunOrdNonnegOffKernelAt (p : ℕ) : Prop :=
+  ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+    ∀ (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      addOrderOf (Point.some x₀ y₀ h₀ : W.toAffine.Point) = p →
+        ∀ (v : Place F W.toAffine.FunctionField) (hv : IsFinitePlace v),
+          (∀ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2),
+            XClass W.toAffine A.1 ∉ hv.centre) →
+          0 ≤ v.ord (W.toAffine.veluDeficitFun
+            (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)))
+
+theorem veluDeficitFunOrdNonnegAtFiniteAt_of_atKernel_of_offKernel {p : ℕ}
+    (hker : VeluDeficitFunOrdNonnegAtKernelAt F p)
+    (hoff : VeluDeficitFunOrdNonnegOffKernelAt F p) :
+    VeluDeficitFunOrdNonnegAtFiniteAt F p := by
+  intro W hΔ x₀ y₀ h₀ hord v hv
+  by_cases hk : ∃ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2),
+      XClass W.toAffine A.1 ∈ hv.centre
+  · exact hker W hΔ x₀ y₀ h₀ hord v hv hk
+  · exact hoff W hΔ x₀ y₀ h₀ hord v hv (fun A hA hmem => hk ⟨A, hA, hmem⟩)
+
+end KernelCarriers
+
+section TrichotomyRecombination
+
+variable (F : Type*) [Field F] [DecidableEq F]
+
+theorem veluDeficitFunOrdNonnegAt_of_atInfty_of_atKernel_of_offKernel {p : ℕ}
+    (hinf : VeluDeficitFunOrdNonnegAtInftyAt F p)
+    (hker : VeluDeficitFunOrdNonnegAtKernelAt F p)
+    (hoff : VeluDeficitFunOrdNonnegOffKernelAt F p) :
+    VeluDeficitFunOrdNonnegAt F p :=
+  veluDeficitFunOrdNonnegAt_of_atFinite_of_atInfty F
+    (veluDeficitFunOrdNonnegAtFiniteAt_of_atKernel_of_offKernel F hker hoff) hinf
+
+end TrichotomyRecombination
+
+end WeierstrassCurve
+
+end
+
+
+section
+
+noncomputable section
+
+namespace AlgebraicCurve
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+@[scoped simp]
+theorem evalAt_zero : v.evalAt (0 : F) = 0 := by
+  rw [← (algebraMap K F).map_zero, v.evalAt_algebraMap]
+
+
+end Place
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+section ResidueCarrier
+
+variable (F : Type*) [Field F] [DecidableEq F]
+
+@[expose] public def VeluDeficitFunEvalAtPlaceAt
+    (hDD : ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 → IsDedekindDomain W.toAffine.CoordinateRing)
+    (p : ℕ) : Prop :=
+  ∀ (W : WeierstrassCurve F) (hΔ : W.Δ ≠ 0),
+    letI := hDD W hΔ
+    ∀ (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      addOrderOf (Point.some x₀ y₀ h₀ : W.toAffine.Point) = p →
+      ∀ ⦃r s : F⦄ (hrs : W.toAffine.Equation r s),
+        (∀ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2), r ≠ A.1) →
+        (placeOfEquation hrs).evalAt
+            (W.toAffine.veluDeficitFun
+              (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)))
+          = W.veluDeficit (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)) r s
+
+end ResidueCarrier
+
+section ResidueBridge
+
+variable {F : Type*} [Field F] [DecidableEq F]
+
+public theorem veluDeficitFunSpecializesConstAt_of_evalAtPlace {p : ℕ}
+    (hDD : ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 → IsDedekindDomain W.toAffine.CoordinateRing)
+    (heval : VeluDeficitFunEvalAtPlaceAt F hDD p) :
+    VeluDeficitFunSpecializesConstAt F p := by
+  intro W hΔ x₀ y₀ h₀ hord c hc r s hrs hav
+  have := hDD W hΔ
+  rw [← heval W hΔ x₀ y₀ h₀ hord hrs hav, hc, Place.evalAt_algebraMap]
+
+end ResidueBridge
+
+section Wire
+
+variable {F : Type*} [Field F] [DecidableEq F]
+
+theorem veluDeficitIsConstantAt_of_ordNonneg_of_evalAtPlace {p : ℕ}
+    (hPD : ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+      HasPrincipalDivisors F W.toAffine.FunctionField)
+    (hDD : ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+      IsDedekindDomain W.toAffine.CoordinateRing)
+    (hreg : VeluDeficitFunOrdNonnegAt F p)
+    (heval : VeluDeficitFunEvalAtPlaceAt F hDD p) :
+    VeluDeficitIsConstantAt F p :=
+  veluDeficitIsConstantAt_of_ordNonneg_of_specializesConst' hPD hDD hreg
+    (veluDeficitFunSpecializesConstAt_of_evalAtPlace hDD heval)
+
+end Wire
+
+end WeierstrassCurve
+
+end
+
+section
+
+namespace WeierstrassCurve
+section Constancy
+
+variable {F : Type*} [Field F] [IsAlgClosed F]
+
+public theorem kw_infinite_of_isAlgClosed : Infinite F := by
+  rw [← not_finite_iff_infinite]
+  intro hfin
+  have := Fintype.ofFinite F
+  have hdeg : (∏ a : F, (X - C a) : F[X]).degree = (Fintype.card F : ℕ) := by
+    simp [Polynomial.degree_prod, Polynomial.degree_X_sub_C]
+  have hlt : (1 : F[X]).degree < (∏ a : F, (X - C a) : F[X]).degree := by
+    rw [Polynomial.degree_one, hdeg]; exact_mod_cast Fintype.card_pos
+  obtain ⟨x, hx⟩ := IsAlgClosed.exists_root (1 + ∏ a : F, (X - C a) : F[X])
+    (by rw [Polynomial.degree_add_eq_right_of_degree_lt hlt, hdeg]
+        exact_mod_cast Fintype.card_pos.ne')
+  have heval : (1 + ∏ a : F, (X - C a) : F[X]).eval x = 1 := by
+    simp only [eval_add, eval_one, eval_prod, eval_sub, eval_X, eval_C]
+    rw [Finset.prod_eq_zero (Finset.mem_univ x) (sub_self x), add_zero]
+  rw [Polynomial.IsRoot, heval] at hx
+  exact one_ne_zero hx
+
+public theorem kw_hDDTerm :
+    ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 → IsDedekindDomain W.toAffine.CoordinateRing :=
+  fun _W hΔ => Affine.CoordinateRing.isDedekindDomain_of_Δ_ne_zero hΔ
+
+end Constancy
+
+end WeierstrassCurve
+
+end
+
+section
+
+noncomputable section
+
+namespace WeierstrassCurve
+section Helper
+
+lemma cube_sum_sub_sum_cube_eq {R : Type*} [CommRing R] {α : Type*} [DecidableEq α]
+    (s : Finset α) (f : α → R) :
+    (∑ A ∈ s, f A) ^ 3 - ∑ A ∈ s, f A ^ 3
+      = ∑ A ∈ s, ∑ B ∈ s.erase A, ((∑ E ∈ s, f E) + f A) * (f A * f B) := by
+  have key : ∀ A ∈ s, ∑ B ∈ s.erase A, ((∑ E ∈ s, f E) + f A) * (f A * f B)
+      = (∑ E ∈ s, f E) ^ 2 * f A - f A ^ 3 := by
+    intro A hA
+    have hsum : (∑ B ∈ s.erase A, f B) = (∑ E ∈ s, f E) - f A := by
+      linear_combination Finset.add_sum_erase s f hA
+    calc ∑ B ∈ s.erase A, ((∑ E ∈ s, f E) + f A) * (f A * f B)
+        = ((∑ E ∈ s, f E) + f A) * f A * ∑ B ∈ s.erase A, f B := by
+          rw [Finset.mul_sum]; exact Finset.sum_congr rfl fun B _ => by ring
+      _ = ((∑ E ∈ s, f E) + f A) * f A * ((∑ E ∈ s, f E) - f A) := by rw [hsum]
+      _ = (∑ E ∈ s, f E) ^ 2 * f A - f A ^ 3 := by ring
+  calc (∑ A ∈ s, f A) ^ 3 - ∑ A ∈ s, f A ^ 3
+      = (∑ E ∈ s, f E) ^ 2 * (∑ A ∈ s, f A) - ∑ A ∈ s, f A ^ 3 := by ring
+    _ = (∑ A ∈ s, (∑ E ∈ s, f E) ^ 2 * f A) - ∑ A ∈ s, f A ^ 3 := by rw [Finset.mul_sum]
+    _ = ∑ A ∈ s, ((∑ E ∈ s, f E) ^ 2 * f A - f A ^ 3) := by rw [Finset.sum_sub_distrib]
+    _ = _ := Eq.symm (Finset.sum_congr rfl key)
+
+end Helper
+
+section Decomp
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+@[expose] public def veluDeficitCrossQuadAlphaCube (S : Finset (F × F)) (r : F) : F :=
+  (W.veluX S r - r) ^ 3 - ∑ A ∈ S, (W.veluX {A} r - r) ^ 3
+
+@[expose] public def veluDeficitCrossQuadBetaOnly
+    [DecidableEq F] (S : Finset (F × F)) (r s : F) : F :=
+  W.veluDeficitCrossQuadCubeBeta S r s + W.veluDeficitCrossQuadAlphaCube S r
+
+lemma veluDeficitCrossQuadCubeBeta_eq_betaOnly_sub_alphaCube [DecidableEq F]
+    (S : Finset (F × F)) (r s : F) :
+    W.veluDeficitCrossQuadCubeBeta S r s
+      = W.veluDeficitCrossQuadBetaOnly S r s - W.veluDeficitCrossQuadAlphaCube S r := by
+  unfold veluDeficitCrossQuadBetaOnly; ring
+
+theorem veluDeficitCrossQuadBetaOnly_eq [DecidableEq F] (S : Finset (F × F)) (r s : F) :
+    W.veluDeficitCrossQuadBetaOnly S r s
+      = ((W.veluY S r s - s) ^ 2 + W.a₁ * (W.veluX S r - r) * (W.veluY S r s - s))
+        - ∑ A ∈ S, ((W.veluY {A} r s - s) ^ 2
+            + W.a₁ * (W.veluX {A} r - r) * (W.veluY {A} r s - s)) := by
+  unfold veluDeficitCrossQuadBetaOnly veluDeficitCrossQuadCubeBeta veluDeficitCrossQuadAlphaCube
+    veluDeficitCrossQuad veluDeficitCrossQuadAlphaSq veluDeficitQuad
+  have hsum : (∑ A ∈ S, ((W.veluY {A} r s - s) ^ 2
+        + W.a₁ * (W.veluX {A} r - r) * (W.veluY {A} r s - s)
+        - (3 * r + W.a₂) * (W.veluX {A} r - r) ^ 2 - (W.veluX {A} r - r) ^ 3
+        + 5 * W.veluTSum {A} * (W.veluX {A} r - r)))
+      - (∑ A ∈ S, (-(3 * r + W.a₂) * (W.veluX {A} r - r) ^ 2
+          + 5 * W.veluTSum {A} * (W.veluX {A} r - r)))
+      + (∑ A ∈ S, (W.veluX {A} r - r) ^ 3)
+      = ∑ A ∈ S, ((W.veluY {A} r s - s) ^ 2
+          + W.a₁ * (W.veluX {A} r - r) * (W.veluY {A} r s - s)) := by
+    rw [← Finset.sum_sub_distrib, ← Finset.sum_add_distrib]
+    exact Finset.sum_congr rfl fun A _ => by ring
+  linear_combination -hsum
+
+end Decomp
+
+section PairPad
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+def veluXCorrPairPadQuot (S : Finset (F × F)) (A B : F × F) : F[X] :=
+  W.veluXCorrNumPoly A * W.veluXCorrNumPoly B
+    * (∏ E ∈ (S.erase A).erase B, (X - C E.1)) ^ 2
+
+theorem veluXCorrPadPoly_mul_eq_kernelDenom_sq_mul {S : Finset (F × F)} {A B : F × F}
+    (hA : A ∈ S) (hB : B ∈ S) (hAB : A ≠ B) :
+    W.veluXCorrPadPoly S A * W.veluXCorrPadPoly S B
+      = (veluKernelDenom S) ^ 2 * W.veluXCorrPairPadQuot S A B := by
+  have hBA : B ∈ S.erase A := Finset.mem_erase.mpr ⟨hAB.symm, hB⟩
+  have hAB' : A ∈ S.erase B := Finset.mem_erase.mpr ⟨hAB, hA⟩
+  unfold veluXCorrPadPoly veluXCorrPairPadQuot veluKernelDenom
+  rw [← Finset.mul_prod_erase (S.erase A) _ hBA,
+      ← Finset.mul_prod_erase (S.erase B) _ hAB',
+      Finset.erase_right_comm (a := B),
+      ← Finset.mul_prod_erase S _ hA,
+      ← Finset.mul_prod_erase (S.erase A) _ hBA]
+  ring
+
+theorem veluXCorrPairPadQuot_natDegree_le {S : Finset (F × F)} {A B : F × F}
+    (hA : A ∈ S) (hB : B ∈ S) (hAB : A ≠ B) :
+    (W.veluXCorrPairPadQuot S A B).natDegree ≤ 2 * S.card - 2 := by
+  have hBA : B ∈ S.erase A := Finset.mem_erase.mpr ⟨hAB.symm, hB⟩
+  unfold veluXCorrPairPadQuot
+  calc (W.veluXCorrNumPoly A * W.veluXCorrNumPoly B
+          * (∏ E ∈ (S.erase A).erase B, ((X : F[X]) - C E.1)) ^ 2).natDegree
+      ≤ (1 + 1) + 2 * (S.card - 2) := by
+        refine natDegree_mul_le.trans (add_le_add ?_ ?_)
+        · exact natDegree_mul_le.trans
+            (add_le_add (W.veluXCorrNumPoly_natDegree_le A) (W.veluXCorrNumPoly_natDegree_le B))
+        · rw [natDegree_pow, natDegree_prod_of_monic _ _ fun _ _ => monic_X_sub_C _]
+          simp only [natDegree_X_sub_C, Finset.sum_const, smul_eq_mul, mul_one,
+            Finset.card_erase_of_mem hBA, Finset.card_erase_of_mem hA]
+          omega
+    _ ≤ 2 * S.card - 2 := by
+        have : 2 ≤ S.card := Finset.one_lt_card.mpr ⟨A, hA, B, hB, hAB⟩
+        omega
+
+end PairPad
+
+section AlphaCubeCross
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+def veluDeficitCrossQuadAlphaCubeClearedPoly (S : Finset (F × F)) : F[X] :=
+  ∑ A ∈ S, ∑ B ∈ S.erase A,
+    (W.veluXCorrSumPadPoly S + W.veluXCorrPadPoly S A) * W.veluXCorrPairPadQuot S A B
+
+theorem veluXCorrSumPadPoly_cube_sub_sum_cube_eq (S : Finset (F × F)) :
+    (W.veluXCorrSumPadPoly S) ^ 3 - ∑ A ∈ S, (W.veluXCorrPadPoly S A) ^ 3
+      = (veluKernelDenom S) ^ 2 * W.veluDeficitCrossQuadAlphaCubeClearedPoly S := by
+  have hRHS : (veluKernelDenom S) ^ 2 * W.veluDeficitCrossQuadAlphaCubeClearedPoly S
+      = ∑ A ∈ S, ∑ B ∈ S.erase A,
+          (W.veluXCorrSumPadPoly S + W.veluXCorrPadPoly S A)
+            * (W.veluXCorrPadPoly S A * W.veluXCorrPadPoly S B) := by
+    rw [veluDeficitCrossQuadAlphaCubeClearedPoly, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun A hA => ?_
+    rw [Finset.mul_sum]
+    refine Finset.sum_congr rfl fun B hB => ?_
+    obtain ⟨hBA, hBS⟩ := Finset.mem_erase.mp hB
+    rw [W.veluXCorrPadPoly_mul_eq_kernelDenom_sq_mul hA hBS hBA.symm]; ring
+  rw [hRHS, veluXCorrSumPadPoly]
+  exact cube_sum_sub_sum_cube_eq S _
+
+theorem veluDeficitCrossQuadAlphaCube_mul_prodPow_eq {S : Finset (F × F)} {r : F}
+    (hav : ∀ B ∈ S, r ≠ B.1) :
+    W.veluDeficitCrossQuadAlphaCube S r * (∏ B ∈ S, (r - B.1)) ^ 4
+      = (W.veluDeficitCrossQuadAlphaCubeClearedPoly S).eval r := by
+  set D : F := ∏ B ∈ S, (r - B.1) with hD_def
+  have hD : D ≠ 0 := Finset.prod_ne_zero_iff.mpr fun B hB => sub_ne_zero.mpr (hav B hB)
+  have hmul : W.veluDeficitCrossQuadAlphaCube S r * D ^ 6
+      = D ^ 2 * (W.veluDeficitCrossQuadAlphaCubeClearedPoly S).eval r := by
+    have hαS := W.eval_veluXCorrSumPadPoly hav
+    have hLHS : W.veluDeficitCrossQuadAlphaCube S r * D ^ 6
+        = (W.veluXCorrSumPadPoly S).eval r ^ 3
+          - ∑ A ∈ S, ((W.veluXCorrPadPoly S A).eval r) ^ 3 := by
+      unfold veluDeficitCrossQuadAlphaCube
+      rw [sub_mul, Finset.sum_mul,
+        show (D : F) ^ 6 = (D ^ 2) ^ 3 from by ring, ← mul_pow, hαS]
+      congr 1
+      exact Finset.sum_congr rfl fun A hA => by
+        rw [← mul_pow, W.eval_veluXCorrPadPoly hA hav]
+    rw [hLHS]
+    have hRHS := congrArg (Polynomial.eval r) (W.veluXCorrSumPadPoly_cube_sub_sum_cube_eq S)
+    simpa only [eval_sub, eval_pow, eval_finsetSum, eval_mul, eval_veluKernelDenom,
+      ← hD_def] using hRHS
+  have h64 : D ^ 2 * (W.veluDeficitCrossQuadAlphaCube S r * D ^ 4)
+      = D ^ 2 * (W.veluDeficitCrossQuadAlphaCubeClearedPoly S).eval r := by
+    rw [← hmul]; ring
+  exact mul_left_cancel₀ (pow_ne_zero 2 hD) h64
+
+theorem veluDeficitCrossQuadAlphaCubeClearedPoly_natDegree_lt {S : Finset (F × F)}
+    (hS : S.Nonempty) :
+    (W.veluDeficitCrossQuadAlphaCubeClearedPoly S).natDegree < 4 * S.card := by
+  have hScard : 0 < S.card := Finset.card_pos.mpr hS
+  refine lt_of_le_of_lt (b := 4 * S.card - 1)
+    (natDegree_le_iff_degree_le.mpr ?_) (by omega)
+  refine (degree_sum_le _ _).trans (Finset.sup_le fun A hA => ?_)
+  refine ((degree_sum_le _ _).trans (Finset.sup_le fun B hB => ?_))
+  obtain ⟨hBA, hBS⟩ := Finset.mem_erase.mp hB
+  refine degree_le_natDegree.trans (Nat.cast_le.mpr ?_)
+  have h1 : (W.veluXCorrSumPadPoly S + W.veluXCorrPadPoly S A).natDegree ≤ 2 * S.card - 1 :=
+    (natDegree_add_le _ _).trans
+      (max_le (W.veluXCorrSumPadPoly_natDegree_le S) (W.veluXCorrPadPoly_natDegree_le hA))
+  have h2 := W.veluXCorrPairPadQuot_natDegree_le hA hBS hBA.symm
+  calc ((W.veluXCorrSumPadPoly S + W.veluXCorrPadPoly S A)
+          * W.veluXCorrPairPadQuot S A B).natDegree
+      ≤ (2 * S.card - 1) + (2 * S.card - 2) := natDegree_mul_le.trans (add_le_add h1 h2)
+    _ ≤ 4 * S.card - 1 := by omega
+
+end AlphaCubeCross
+
+section Reduction
+
+variable (F : Type*) [Field F] [DecidableEq F]
+
+@[expose] public def VeluDeficitCrossQuadBetaOnlyDegLtAt (p : ℕ) : Prop :=
+  ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+    ∀ (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      addOrderOf (Point.some x₀ y₀ h₀ : W.toAffine.Point) = p →
+        ∃ M : F[X], M.natDegree < 4 * ((p - 1) / 2) ∧
+          ∀ ⦃r s : F⦄, W.toAffine.Equation r s →
+            (∀ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2), r ≠ A.1) →
+            W.veluDeficitCrossQuadBetaOnly
+                (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)) r s
+              * (∏ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2),
+                    (r - A.1)) ^ 4
+              = M.eval r
+
+end Reduction
+
+end WeierstrassCurve
+
+end
+
+
+noncomputable section
+
+namespace AlgebraicCurve
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem ord_smul_of_fixed (σ : F ≃ₐ[K] F) (v : Place K F) {g : F} (hg : σ g = g) :
+    (σ • v).ord g = v.ord g := by
+  conv_lhs => rw [← hg]
+  exact ord_smul σ v g
+
+theorem ord_nonneg_of_ord_smul_nonneg (σ : F ≃ₐ[K] F) (v : Place K F) {g : F}
+    (hg : σ g = g) (h : 0 ≤ (σ • v).ord g) : 0 ≤ v.ord g :=
+  (ord_smul_of_fixed σ v hg) ▸ h
+
+end Place
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+section KernelTranslationCarrier
+
+variable (F : Type*) [Field F] [DecidableEq F]
+
+def VeluDeficitFunKernelTranslationAt (p : ℕ) : Prop :=
+  ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+    ∀ (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      addOrderOf (Point.some x₀ y₀ h₀ : W.toAffine.Point) = p →
+        ∀ (v : Place F W.toAffine.FunctionField) (hv : IsFinitePlace v),
+          (∃ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2),
+            XClass W.toAffine A.1 ∈ hv.centre) →
+          ∃ τ : W.toAffine.FunctionField ≃ₐ[F] W.toAffine.FunctionField,
+            τ (W.toAffine.veluDeficitFun
+                (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)))
+              = W.toAffine.veluDeficitFun
+                  (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2))
+            ∧ ¬ IsFinitePlace (τ • v)
+
+end KernelTranslationCarrier
+
+section KernelReduction
+
+variable (F : Type*) [Field F] [DecidableEq F]
+
+theorem veluDeficitFunOrdNonnegAtKernelAt_of_kernelTranslation_of_atInfty {p : ℕ}
+    (htr : VeluDeficitFunKernelTranslationAt F p)
+    (hinf : VeluDeficitFunOrdNonnegAtInftyAt F p) :
+    VeluDeficitFunOrdNonnegAtKernelAt F p := by
+  intro W hΔ x₀ y₀ h₀ hord v hv hk
+  obtain ⟨τ, hfix, hninf⟩ := htr W hΔ x₀ y₀ h₀ hord v hv hk
+  exact Place.ord_nonneg_of_ord_smul_nonneg τ v hfix
+    (hinf W hΔ x₀ y₀ h₀ hord (τ • v) hninf)
+
+end KernelReduction
+
+section Wire
+
+variable {F : Type*} [Field F] [DecidableEq F]
+
+theorem veluDeficitFunOrdNonnegAt_of_kernelTranslation_of_atInfty_of_offKernel {p : ℕ}
+    (htr : VeluDeficitFunKernelTranslationAt F p)
+    (hinf : VeluDeficitFunOrdNonnegAtInftyAt F p)
+    (hoff : VeluDeficitFunOrdNonnegOffKernelAt F p) :
+    VeluDeficitFunOrdNonnegAt F p :=
+  veluDeficitFunOrdNonnegAt_of_atInfty_of_atKernel_of_offKernel F hinf
+    (veluDeficitFunOrdNonnegAtKernelAt_of_kernelTranslation_of_atInfty F htr hinf) hoff
+
+end Wire
+
+end WeierstrassCurve
+
+end
+
+
+
+noncomputable section
+
+namespace WeierstrassCurve
+namespace Affine
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem algebraMap_polynomial_X_sub_C (c : F) :
+    algebraMap F[X] W.CoordinateRing (X - C c) = XClass W c := by
+  rw [XClass, AdjoinRoot.algebraMap_eq]; rfl
+
+theorem algebraMap_coordinateRing_XClass (c : F) :
+    algebraMap W.CoordinateRing W.FunctionField (XClass W c)
+      = polyToFunctionField W X - algebraMap F W.FunctionField c := by
+  rw [← algebraMap_polynomial_X_sub_C, ← polyToFunctionField_apply, map_sub,
+    polyToFunctionField_C]
+
+theorem IsFinitePlace.inv_X_sub_const_mem_of_XClass_notMem_centre
+    {v : Place F W.FunctionField} (hv : IsFinitePlace v) {c : F}
+    (hc : XClass W c ∉ hv.centre) :
+    (polyToFunctionField W X - algebraMap F W.FunctionField c)⁻¹ ∈ v.toValuationSubring := by
+  rw [← algebraMap_coordinateRing_XClass]
+  exact hv.inv_mem hc
+
+theorem IsFinitePlace.polyToFunctionField_X_mem {v : Place F W.FunctionField}
+    (hv : IsFinitePlace v) : polyToFunctionField W X ∈ v.toValuationSubring := by
+  rw [polyToFunctionField_apply]; exact hv _
+
+theorem IsFinitePlace.yGen_mem {v : Place F W.FunctionField} (hv : IsFinitePlace v) :
+    yGen W ∈ v.toValuationSubring := hv _
+
+section OffKernelMembership
+
+variable {v : Place F W.FunctionField} (hv : IsFinitePlace v) {S : Finset (F × F)}
+  (hS : ∀ A ∈ S, XClass W A.1 ∉ hv.centre)
+
+local notation "ι" => algebraMap F W.FunctionField
+local notation "x" => polyToFunctionField W X
+local notation "y" => yGen W
+local notation "𝒪" => v.toValuationSubring
+
+include hS in
+theorem IsFinitePlace.veluX_liftSummingSet_mem_of_forall_XClass_notMem_centre :
+    (W.map ι).veluX (W.liftSummingSet S) x ∈ 𝒪 := by
+  unfold WeierstrassCurve.veluX WeierstrassCurve.liftSummingSet
+  rw [Finset.sum_map]
+  refine add_mem hv.polyToFunctionField_X_mem (Subring.sum_mem _ fun A hA => ?_)
+  simp only [Function.Embedding.coeFn_mk, Prod.map_fst, Prod.map_snd, map_veluT, map_veluU]
+  have hδ : (x - ι A.1)⁻¹ ∈ 𝒪 :=
+    hv.inv_X_sub_const_mem_of_XClass_notMem_centre (hS A hA)
+  refine add_mem ?_ ?_
+  · rw [div_eq_mul_inv]; exact mul_mem (v.algebraMap_mem' _) hδ
+  · rw [div_eq_mul_inv, ← inv_pow]
+    exact mul_mem (v.algebraMap_mem' _) (pow_mem hδ 2)
+
+include hS in
+theorem IsFinitePlace.veluY_liftSummingSet_mem_of_forall_XClass_notMem_centre :
+    (W.map ι).veluY (W.liftSummingSet S) x y ∈ 𝒪 := by
+  unfold WeierstrassCurve.veluY WeierstrassCurve.liftSummingSet
+  rw [Finset.sum_map]
+  refine sub_mem hv.yGen_mem (Subring.sum_mem _ fun A hA => ?_)
+  simp only [Function.Embedding.coeFn_mk, Prod.map_fst, Prod.map_snd, map_veluT, map_veluU,
+    map_veluGx, map_veluGy, map_a₁, map_a₃]
+  have hδ : (x - ι A.1)⁻¹ ∈ 𝒪 :=
+    hv.inv_X_sub_const_mem_of_XClass_notMem_centre (hS A hA)
+  have hx : x ∈ 𝒪 := hv.polyToFunctionField_X_mem
+  have hy : y ∈ 𝒪 := hv.yGen_mem
+  have hF : ∀ c : F, ι c ∈ 𝒪 := v.algebraMap_mem'
+  refine add_mem (add_mem ?_ ?_) ?_
+  · rw [div_eq_mul_inv, ← inv_pow]
+    exact mul_mem (mul_mem (hF _)
+      (add_mem (add_mem (mul_mem (ofNat_mem 𝒪 2) hy) (mul_mem (hF _) hx)) (hF _)))
+      (pow_mem hδ 3)
+  · rw [div_eq_mul_inv, ← inv_pow]
+    exact mul_mem (mul_mem (hF _)
+      (sub_mem (add_mem (mul_mem (hF _) (sub_mem hx (hF _))) hy) (hF _))) (pow_mem hδ 2)
+  · rw [div_eq_mul_inv, ← inv_pow]
+    exact mul_mem (sub_mem (mul_mem (hF _) (hF _)) (mul_mem (hF _) (hF _))) (pow_mem hδ 2)
+
+include hS in
+theorem IsFinitePlace.veluDeficitFun_mem_of_forall_XClass_notMem_centre :
+    W.veluDeficitFun S ∈ 𝒪 := by
+  unfold WeierstrassCurve.veluDeficitFun WeierstrassCurve.veluDeficit
+  set X' := (W.map ι).veluX (W.liftSummingSet S) x with hX'
+  set Y' := (W.map ι).veluY (W.liftSummingSet S) x y with hY'
+  have hXm : X' ∈ 𝒪 := hv.veluX_liftSummingSet_mem_of_forall_XClass_notMem_centre hS
+  have hYm : Y' ∈ 𝒪 := hv.veluY_liftSummingSet_mem_of_forall_XClass_notMem_centre hS
+  have hF : ∀ c : F, ι c ∈ 𝒪 := v.algebraMap_mem'
+  rw [veluQuotient_a₄, veluQuotient_a₆,
+    show (W.liftSummingSet S : Finset _) = S.map ⟨Prod.map ι ι, (RingHom.injective ι).prodMap
+      (RingHom.injective ι)⟩ from rfl,
+    map_veluTSum _ _ S (RingHom.injective ι), map_veluWSum _ _ S (RingHom.injective ι),
+    map_a₁, map_a₂, map_a₃, map_a₄, map_a₆, map_b₂]
+  refine sub_mem (add_mem (add_mem (pow_mem hYm 2) (mul_mem (mul_mem (hF _) hXm) hYm))
+    (mul_mem (hF _) hYm)) ?_
+  refine add_mem (add_mem (add_mem (pow_mem hXm 3) (mul_mem (hF _) (pow_mem hXm 2)))
+    (mul_mem ?_ hXm)) ?_
+  · exact sub_mem (hF _) (mul_mem (ofNat_mem 𝒪 5) (hF _))
+  · exact sub_mem (sub_mem (hF _) (mul_mem (hF _) (hF _))) (mul_mem (ofNat_mem 𝒪 7) (hF _))
+
+end OffKernelMembership
+
+theorem IsFinitePlace.ord_nonneg_veluDeficitFun_of_forall_XClass_notMem_centre
+    {v : Place F W.FunctionField} (hv : IsFinitePlace v) {S : Finset (F × F)}
+    (hS : ∀ A ∈ S, XClass W A.1 ∉ hv.centre) :
+    0 ≤ v.ord (W.veluDeficitFun S) :=
+  v.ord_nonneg_of_mem (hv.veluDeficitFun_mem_of_forall_XClass_notMem_centre hS)
+
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+variable (F : Type*) [Field F] [DecidableEq F]
+
+theorem veluDeficitFunOrdNonnegOffKernelAt (p : ℕ) : VeluDeficitFunOrdNonnegOffKernelAt F p :=
+  fun _ _ _ _ _ _ _ hv hoff =>
+    hv.ord_nonneg_veluDeficitFun_of_forall_XClass_notMem_centre hoff
+
+end WeierstrassCurve
+
+end
+
+
+section
+
+noncomputable section
+
+namespace AlgebraicCurve
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+theorem evalAt_sum (hv : v.IsRational) {ι : Type*} (s : Finset ι) (f : ι → F)
+    (hf : ∀ i ∈ s, f i ∈ v.toValuationSubring) :
+    v.evalAt (∑ i ∈ s, f i) = ∑ i ∈ s, v.evalAt (f i) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => simp [v.evalAt_zero]
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha, Finset.sum_insert ha,
+      v.evalAt_add hv (hf a (Finset.mem_insert_self a s))
+        (Subring.sum_mem _ fun i hi => hf i (Finset.mem_insert_of_mem hi)),
+      ih (fun i hi => hf i (Finset.mem_insert_of_mem hi))]
+
+theorem evalAt_pow (hv : v.IsRational) {f : F} (hf : f ∈ v.toValuationSubring) (n : ℕ) :
+    v.evalAt (f ^ n) = v.evalAt f ^ n := by
+  induction n with
+  | zero => simp [v.evalAt_one]
+  | succ n ih =>
+    rw [pow_succ, v.evalAt_mul hv (pow_mem hf n) hf, ih, pow_succ]
+
+theorem evalAt_natCast (n : ℕ) : v.evalAt (n : F) = n := by
+  rw [show ((n : F) : F) = algebraMap K F n by push_cast; rfl, v.evalAt_algebraMap]
+
+theorem evalAt_ofNat (n : ℕ) [n.AtLeastTwo] :
+    v.evalAt (ofNat(n) : F) = ofNat(n) := by
+  rw [← Nat.cast_ofNat, v.evalAt_natCast, Nat.cast_ofNat]
+
+theorem evalAt_div' (hv : v.IsRational) {f g : F} (hf : f ∈ v.toValuationSubring)
+    (hg0 : g ≠ 0) (hg : v.ord g = 0) :
+    v.evalAt (f / g) = v.evalAt f / v.evalAt g := by
+  have hginv : g⁻¹ ∈ v.toValuationSubring := v.mem_of_ord_nonneg (inv_ne_zero hg0)
+    (by rw [v.ord_inv, hg]; exact le_of_eq (_root_.neg_zero).symm)
+  rw [div_eq_mul_inv, v.evalAt_mul hv hf hginv, v.evalAt_inv hv hg0 hg, div_eq_mul_inv]
+
+end Place
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+namespace Affine
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+section Atomic
+
+variable [IsDedekindDomain W.CoordinateRing] {r s : F} (hrs : W.Equation r s)
+
+public theorem isRational_placeOfEquation : (placeOfEquation hrs).IsRational :=
+  (placeOfEquation hrs).isRational_of_deg_eq_one (deg_placeOfEquation hrs)
+
+theorem evalAt_algebraMap_placeOfEquation_of_mem_XYIdeal {z : W.CoordinateRing}
+    (hz : z ∈ XYIdeal W r (C s)) :
+    (placeOfEquation hrs).evalAt (algebraMap W.CoordinateRing W.FunctionField z) = 0 := by
+  rcases eq_or_ne z 0 with rfl | hz0
+  · rw [_root_.map_zero, Place.evalAt_zero]
+  have hpos := (ord_placeOfEquation_pos_iff hrs hz0).mpr hz
+  have hmem : algebraMap W.CoordinateRing W.FunctionField z
+      ∈ (placeOfEquation hrs).toValuationSubring := isFinitePlace_placeOfEquation hrs z
+  rw [(placeOfEquation hrs).evalAt_of_mem hmem]
+  have hres : IsLocalRing.residue _
+      (⟨algebraMap W.CoordinateRing W.FunctionField z, hmem⟩
+        : (placeOfEquation hrs).toValuationSubring) = 0 :=
+    (IsLocalRing.residue_eq_zero_iff _).mpr
+      (((placeOfEquation hrs).mem_maximalIdeal_iff_ord_pos
+        (algebraMap_coordinateRing_ne_zero hz0) hmem).mpr hpos)
+  rw [hres, ← _root_.map_zero (algebraMap F (placeOfEquation hrs).ResidueField),
+    (placeOfEquation hrs).residueInv_algebraMap]
+
+public theorem polyToFunctionField_X_mem_placeOfEquation :
+    polyToFunctionField W X ∈ (placeOfEquation hrs).toValuationSubring := by
+  rw [polyToFunctionField_apply]; exact isFinitePlace_placeOfEquation hrs _
+
+public theorem yGen_mem_placeOfEquation :
+    yGen W ∈ (placeOfEquation hrs).toValuationSubring :=
+  isFinitePlace_placeOfEquation hrs _
+
+include hrs in
+theorem evalAt_polyToFunctionField_X_placeOfEquation :
+    (placeOfEquation hrs).evalAt (polyToFunctionField W X) = r := by
+  have hX : XClass W r ∈ XYIdeal W r (C s) := Ideal.subset_span (Set.mem_insert _ _)
+  have h0 := evalAt_algebraMap_placeOfEquation_of_mem_XYIdeal hrs hX
+  have hbridge : algebraMap W.CoordinateRing W.FunctionField (XClass W r)
+      = polyToFunctionField W X - algebraMap F W.FunctionField r := by
+    rw [show XClass W r = algebraMap F[X] W.CoordinateRing (X - C r) from rfl,
+      ← polyToFunctionField_apply, _root_.map_sub, polyToFunctionField_C]
+  rw [hbridge, (placeOfEquation hrs).evalAt_sub (isRational_placeOfEquation hrs)
+    (polyToFunctionField_X_mem_placeOfEquation hrs)
+    ((placeOfEquation hrs).algebraMap_mem' r),
+    Place.evalAt_algebraMap, sub_eq_zero] at h0
+  exact h0
+
+include hrs in
+theorem evalAt_yGen_placeOfEquation :
+    (placeOfEquation hrs).evalAt (yGen W) = s := by
+  have hY : YClass W (C s) ∈ XYIdeal W r (C s) :=
+    Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  have h0 := evalAt_algebraMap_placeOfEquation_of_mem_XYIdeal hrs hY
+  have hbridge : algebraMap W.CoordinateRing W.FunctionField (YClass W (C s))
+      = yGen W - algebraMap F W.FunctionField s := by
+    rw [YClass, _root_.map_sub, _root_.map_sub, yGen]; congr 1
+  rw [hbridge, (placeOfEquation hrs).evalAt_sub (isRational_placeOfEquation hrs)
+    (yGen_mem_placeOfEquation hrs)
+    ((placeOfEquation hrs).algebraMap_mem' s),
+    Place.evalAt_algebraMap, sub_eq_zero] at h0
+  exact h0
+
+include hrs in
+theorem evalAt_X_sub_const_placeOfEquation (c : F) :
+    (placeOfEquation hrs).evalAt (polyToFunctionField W X - algebraMap F W.FunctionField c)
+      = r - c := by
+  rw [(placeOfEquation hrs).evalAt_sub (isRational_placeOfEquation hrs)
+    (polyToFunctionField_X_mem_placeOfEquation hrs)
+    ((placeOfEquation hrs).algebraMap_mem' c),
+    evalAt_polyToFunctionField_X_placeOfEquation hrs, Place.evalAt_algebraMap]
+
+include hrs in
+public theorem ord_X_sub_const_placeOfEquation_of_ne {c : F} (hrc : r ≠ c) :
+    (placeOfEquation hrs).ord (polyToFunctionField W X - algebraMap F W.FunctionField c) = 0 := by
+  have hbridge : polyToFunctionField W X - algebraMap F W.FunctionField c
+      = algebraMap W.CoordinateRing W.FunctionField (XClass W c) := by
+    rw [show XClass W c = algebraMap F[X] W.CoordinateRing (X - C c) from rfl,
+      ← polyToFunctionField_apply, _root_.map_sub, polyToFunctionField_C]
+  rw [hbridge]
+  refine le_antisymm ?_ (ord_placeOfEquation_nonneg hrs _)
+  rw [show (0 : ℤ) = 0 from rfl, ← not_lt]
+  intro hpos
+  have hmem := (ord_placeOfEquation_pos_iff hrs (XClass_ne_zero c)).mp hpos
+  rw [show XClass W c = CoordinateRing.mk W (C (X - C c)) from rfl,
+    mk_mem_XYIdeal_iff hrs] at hmem
+  simp only [evalEval_C, eval_sub, eval_X, eval_C, sub_eq_zero] at hmem
+  exact hrc hmem
+
+end Atomic
+
+section VeluCoord
+
+variable [IsDedekindDomain W.CoordinateRing] {r s : F} (hrs : W.Equation r s)
+  {S : Finset (F × F)}
+
+lemma const_mem_placeOfEquation (c : F) :
+    algebraMap F W.FunctionField c ∈ (placeOfEquation hrs).toValuationSubring :=
+  (placeOfEquation hrs).algebraMap_mem' c
+
+omit [IsDedekindDomain W.CoordinateRing] in
+lemma X_sub_const_ne_zero (c : F) :
+    (polyToFunctionField W X - algebraMap F W.FunctionField c : W.FunctionField) ≠ 0 :=
+  sub_ne_zero.mpr (polyToFunctionField_X_ne_algebraMap c)
+
+lemma inv_X_sub_const_mem_placeOfEquation {c : F} (hrc : r ≠ c) :
+    (polyToFunctionField W X - algebraMap F W.FunctionField c)⁻¹
+      ∈ (placeOfEquation hrs).toValuationSubring := by
+  have hord := ord_X_sub_const_placeOfEquation_of_ne hrs hrc
+  refine (placeOfEquation hrs).mem_of_ord_nonneg (inv_ne_zero (X_sub_const_ne_zero c)) ?_
+  rw [(placeOfEquation hrs).ord_inv, hord]
+  exact le_of_eq (_root_.neg_zero).symm
+
+lemma veluX_summand_mem (A : F × F) (hrA : r ≠ A.1) :
+    (algebraMap F W.FunctionField (W.veluT A.1 A.2)
+        / (polyToFunctionField W X - algebraMap F W.FunctionField A.1)
+      + algebraMap F W.FunctionField (W.veluU A.1 A.2)
+        / (polyToFunctionField W X - algebraMap F W.FunctionField A.1) ^ 2)
+      ∈ (placeOfEquation hrs).toValuationSubring := by
+  have hδ := inv_X_sub_const_mem_placeOfEquation hrs hrA
+  refine add_mem ?_ ?_
+  · rw [div_eq_mul_inv]; exact mul_mem (const_mem_placeOfEquation hrs _) hδ
+  · rw [div_eq_mul_inv, ← inv_pow]
+    exact mul_mem (const_mem_placeOfEquation hrs _) (pow_mem hδ 2)
+
+include hrs in
+public theorem evalAt_veluX_liftSummingSet_placeOfEquation (hS : ∀ A ∈ S, r ≠ A.1) :
+    (placeOfEquation hrs).evalAt
+        ((W.map (algebraMap F W.FunctionField)).veluX (W.liftSummingSet S)
+          (polyToFunctionField W X)) = W.veluX S r := by
+  have hv := isRational_placeOfEquation hrs
+  unfold WeierstrassCurve.veluX WeierstrassCurve.liftSummingSet
+  rw [Finset.sum_map]
+  simp only [Function.Embedding.coeFn_mk, Prod.map_fst, Prod.map_snd, map_veluT, map_veluU]
+  rw [(placeOfEquation hrs).evalAt_add hv (polyToFunctionField_X_mem_placeOfEquation hrs)
+    (Subring.sum_mem _ fun A hA => veluX_summand_mem hrs A (hS A hA)),
+    evalAt_polyToFunctionField_X_placeOfEquation hrs,
+    (placeOfEquation hrs).evalAt_sum hv _ _ (fun A hA => veluX_summand_mem hrs A (hS A hA))]
+  congr 1
+  refine Finset.sum_congr rfl fun A hA => ?_
+  have hδ0 := X_sub_const_ne_zero (W := W) A.1
+  have hδord := ord_X_sub_const_placeOfEquation_of_ne hrs (hS A hA)
+  have hδ := inv_X_sub_const_mem_placeOfEquation hrs (hS A hA)
+  have hδ2ord : (placeOfEquation hrs).ord
+      ((polyToFunctionField W X - algebraMap F W.FunctionField A.1) ^ 2) = 0 := by
+    have := (placeOfEquation hrs).ord_zpow
+      (polyToFunctionField W X - algebraMap F W.FunctionField A.1) 2
+    rw [zpow_two] at this
+    rw [pow_two, this, hδord, mul_zero]
+  have hm1 : (algebraMap F W.FunctionField (W.veluT A.1 A.2)
+        / (polyToFunctionField W X - algebraMap F W.FunctionField A.1))
+      ∈ (placeOfEquation hrs).toValuationSubring := by
+    rw [div_eq_mul_inv]; exact mul_mem (const_mem_placeOfEquation hrs _) hδ
+  have hm2 : (algebraMap F W.FunctionField (W.veluU A.1 A.2)
+        / (polyToFunctionField W X - algebraMap F W.FunctionField A.1) ^ 2)
+      ∈ (placeOfEquation hrs).toValuationSubring := by
+    rw [div_eq_mul_inv, ← inv_pow]
+    exact mul_mem (const_mem_placeOfEquation hrs _) (pow_mem hδ 2)
+  rw [(placeOfEquation hrs).evalAt_add hv hm1 hm2,
+    (placeOfEquation hrs).evalAt_div' hv (const_mem_placeOfEquation hrs _) hδ0 hδord,
+    (placeOfEquation hrs).evalAt_div' hv (const_mem_placeOfEquation hrs _)
+      (pow_ne_zero 2 hδ0) hδ2ord,
+    evalAt_X_sub_const_placeOfEquation hrs,
+    (placeOfEquation hrs).evalAt_pow hv
+      (sub_mem (polyToFunctionField_X_mem_placeOfEquation hrs)
+        (const_mem_placeOfEquation hrs _)) 2,
+    evalAt_X_sub_const_placeOfEquation hrs,
+    Place.evalAt_algebraMap, Place.evalAt_algebraMap]
+
+lemma veluX_liftSummingSet_mem_placeOfEquation (hS : ∀ A ∈ S, r ≠ A.1) :
+    (W.map (algebraMap F W.FunctionField)).veluX (W.liftSummingSet S)
+        (polyToFunctionField W X) ∈ (placeOfEquation hrs).toValuationSubring := by
+  unfold WeierstrassCurve.veluX WeierstrassCurve.liftSummingSet
+  rw [Finset.sum_map]
+  simp only [Function.Embedding.coeFn_mk, Prod.map_fst, Prod.map_snd, map_veluT, map_veluU]
+  exact add_mem (polyToFunctionField_X_mem_placeOfEquation hrs)
+    (Subring.sum_mem _ fun A hA => veluX_summand_mem hrs A (hS A hA))
+
+lemma veluY_summand_mem (A : F × F) (hrA : r ≠ A.1) :
+    (algebraMap F W.FunctionField (W.veluU A.1 A.2)
+          * (2 * yGen W + algebraMap F W.FunctionField W.a₁ * polyToFunctionField W X
+              + algebraMap F W.FunctionField W.a₃)
+          / (polyToFunctionField W X - algebraMap F W.FunctionField A.1) ^ 3
+      + algebraMap F W.FunctionField (W.veluT A.1 A.2)
+          * (algebraMap F W.FunctionField W.a₁
+              * (polyToFunctionField W X - algebraMap F W.FunctionField A.1)
+            + yGen W - algebraMap F W.FunctionField A.2)
+          / (polyToFunctionField W X - algebraMap F W.FunctionField A.1) ^ 2
+      + (algebraMap F W.FunctionField W.a₁ * algebraMap F W.FunctionField (W.veluU A.1 A.2)
+          - algebraMap F W.FunctionField (W.veluGx A.1 A.2)
+              * algebraMap F W.FunctionField (W.veluGy A.1 A.2))
+          / (polyToFunctionField W X - algebraMap F W.FunctionField A.1) ^ 2)
+      ∈ (placeOfEquation hrs).toValuationSubring := by
+  have hδ := inv_X_sub_const_mem_placeOfEquation hrs hrA
+  have hX := polyToFunctionField_X_mem_placeOfEquation hrs
+  have hY := yGen_mem_placeOfEquation hrs
+  have hF := const_mem_placeOfEquation hrs
+  refine add_mem (add_mem ?_ ?_) ?_
+  · rw [div_eq_mul_inv, ← inv_pow]
+    exact mul_mem (mul_mem (hF _)
+      (add_mem (add_mem (mul_mem (ofNat_mem _ 2) hY) (mul_mem (hF _) hX)) (hF _)))
+      (pow_mem hδ 3)
+  · rw [div_eq_mul_inv, ← inv_pow]
+    exact mul_mem (mul_mem (hF _) (sub_mem (add_mem (mul_mem (hF _)
+      (sub_mem hX (hF _))) hY) (hF _))) (pow_mem hδ 2)
+  · rw [div_eq_mul_inv, ← inv_pow]
+    exact mul_mem (sub_mem (mul_mem (hF _) (hF _)) (mul_mem (hF _) (hF _))) (pow_mem hδ 2)
+
+lemma veluY_liftSummingSet_mem_placeOfEquation (hS : ∀ A ∈ S, r ≠ A.1) :
+    (W.map (algebraMap F W.FunctionField)).veluY (W.liftSummingSet S)
+        (polyToFunctionField W X) (yGen W) ∈ (placeOfEquation hrs).toValuationSubring := by
+  unfold WeierstrassCurve.veluY WeierstrassCurve.liftSummingSet
+  rw [Finset.sum_map]
+  simp only [Function.Embedding.coeFn_mk, Prod.map_fst, Prod.map_snd, map_veluT, map_veluU,
+    map_veluGx, map_veluGy, map_a₁, map_a₃]
+  exact sub_mem (yGen_mem_placeOfEquation hrs)
+    (Subring.sum_mem _ fun A hA => veluY_summand_mem hrs A (hS A hA))
+
+include hrs in
+public theorem evalAt_veluY_liftSummingSet_placeOfEquation (hS : ∀ A ∈ S, r ≠ A.1) :
+    (placeOfEquation hrs).evalAt
+        ((W.map (algebraMap F W.FunctionField)).veluY (W.liftSummingSet S)
+          (polyToFunctionField W X) (yGen W)) = W.veluY S r s := by
+  have hv := isRational_placeOfEquation hrs
+  have hX := polyToFunctionField_X_mem_placeOfEquation hrs
+  have hY := yGen_mem_placeOfEquation hrs
+  have hF := const_mem_placeOfEquation hrs
+  unfold WeierstrassCurve.veluY WeierstrassCurve.liftSummingSet
+  rw [Finset.sum_map]
+  simp only [Function.Embedding.coeFn_mk, Prod.map_fst, Prod.map_snd, map_veluT, map_veluU,
+    map_veluGx, map_veluGy, map_a₁, map_a₃]
+  rw [(placeOfEquation hrs).evalAt_sub hv hY
+      (Subring.sum_mem _ fun A hA => veluY_summand_mem hrs A (hS A hA)),
+    evalAt_yGen_placeOfEquation hrs,
+    (placeOfEquation hrs).evalAt_sum hv _ _ (fun A hA => veluY_summand_mem hrs A (hS A hA))]
+  congr 1
+  refine Finset.sum_congr rfl fun A hA => ?_
+  have hδ0 := X_sub_const_ne_zero (W := W) A.1
+  have hδord := ord_X_sub_const_placeOfEquation_of_ne hrs (hS A hA)
+  have hδ := inv_X_sub_const_mem_placeOfEquation hrs (hS A hA)
+  have hδpowmem : ∀ n : ℕ,
+      ((polyToFunctionField W X - algebraMap F W.FunctionField A.1) ^ n)⁻¹
+        ∈ (placeOfEquation hrs).toValuationSubring :=
+    fun n => by rw [← inv_pow]; exact pow_mem hδ n
+  have hδpow : ∀ n : ℕ, (placeOfEquation hrs).ord
+      ((polyToFunctionField W X - algebraMap F W.FunctionField A.1) ^ n) = 0 := fun n => by
+    have := (placeOfEquation hrs).ord_zpow
+      (polyToFunctionField W X - algebraMap F W.FunctionField A.1) n
+    rw [zpow_natCast] at this; rw [this, hδord, mul_zero]
+  have hδeval := evalAt_X_sub_const_placeOfEquation hrs A.1
+  have hδpoweval : ∀ n : ℕ, (placeOfEquation hrs).evalAt
+      ((polyToFunctionField W X - algebraMap F W.FunctionField A.1) ^ n) = (r - A.1) ^ n :=
+    fun n => by
+      rw [(placeOfEquation hrs).evalAt_pow hv (sub_mem hX (hF _)) n, hδeval]
+  have hN1 : (algebraMap F W.FunctionField (W.veluU A.1 A.2)
+      * (2 * yGen W + algebraMap F W.FunctionField W.a₁ * polyToFunctionField W X
+          + algebraMap F W.FunctionField W.a₃)) ∈ (placeOfEquation hrs).toValuationSubring :=
+    mul_mem (hF _)
+      (add_mem (add_mem (mul_mem (ofNat_mem _ 2) hY) (mul_mem (hF _) hX)) (hF _))
+  have hN2 : (algebraMap F W.FunctionField (W.veluT A.1 A.2)
+      * (algebraMap F W.FunctionField W.a₁
+          * (polyToFunctionField W X - algebraMap F W.FunctionField A.1)
+        + yGen W - algebraMap F W.FunctionField A.2))
+      ∈ (placeOfEquation hrs).toValuationSubring :=
+    mul_mem (hF _) (sub_mem (add_mem (mul_mem (hF _) (sub_mem hX (hF _))) hY) (hF _))
+  have hN3 : (algebraMap F W.FunctionField W.a₁ * algebraMap F W.FunctionField (W.veluU A.1 A.2)
+      - algebraMap F W.FunctionField (W.veluGx A.1 A.2)
+          * algebraMap F W.FunctionField (W.veluGy A.1 A.2))
+      ∈ (placeOfEquation hrs).toValuationSubring :=
+    sub_mem (mul_mem (hF _) (hF _)) (mul_mem (hF _) (hF _))
+  rw [(placeOfEquation hrs).evalAt_add hv
+      (add_mem (by rw [div_eq_mul_inv]; exact mul_mem hN1 (hδpowmem 3))
+        (by rw [div_eq_mul_inv]; exact mul_mem hN2 (hδpowmem 2)))
+      (by rw [div_eq_mul_inv]; exact mul_mem hN3 (hδpowmem 2)),
+    (placeOfEquation hrs).evalAt_add hv
+      (by rw [div_eq_mul_inv]; exact mul_mem hN1 (hδpowmem 3))
+      (by rw [div_eq_mul_inv]; exact mul_mem hN2 (hδpowmem 2)),
+    (placeOfEquation hrs).evalAt_div' hv hN1 (pow_ne_zero 3 hδ0) (hδpow 3), hδpoweval 3,
+    (placeOfEquation hrs).evalAt_div' hv hN2 (pow_ne_zero 2 hδ0) (hδpow 2), hδpoweval 2,
+    (placeOfEquation hrs).evalAt_div' hv hN3 (pow_ne_zero 2 hδ0) (hδpow 2), hδpoweval 2]
+  congr 2
+  · rw [(placeOfEquation hrs).evalAt_mul hv (hF _)
+        (add_mem (add_mem (mul_mem (ofNat_mem _ 2) hY) (mul_mem (hF _) hX)) (hF _)),
+      Place.evalAt_algebraMap,
+      (placeOfEquation hrs).evalAt_add hv
+        (add_mem (mul_mem (ofNat_mem _ 2) hY) (mul_mem (hF _) hX)) (hF _),
+      (placeOfEquation hrs).evalAt_add hv (mul_mem (ofNat_mem _ 2) hY) (mul_mem (hF _) hX),
+      (placeOfEquation hrs).evalAt_mul hv (ofNat_mem _ 2) hY,
+      (placeOfEquation hrs).evalAt_mul hv (hF _) hX,
+      (placeOfEquation hrs).evalAt_ofNat 2,
+      evalAt_yGen_placeOfEquation hrs, evalAt_polyToFunctionField_X_placeOfEquation hrs,
+      Place.evalAt_algebraMap, Place.evalAt_algebraMap]
+  · rw [(placeOfEquation hrs).evalAt_mul hv (hF _)
+        (sub_mem (add_mem (mul_mem (hF _) (sub_mem hX (hF _))) hY) (hF _)),
+      Place.evalAt_algebraMap,
+      (placeOfEquation hrs).evalAt_sub hv
+        (add_mem (mul_mem (hF _) (sub_mem hX (hF _))) hY) (hF _),
+      (placeOfEquation hrs).evalAt_add hv (mul_mem (hF _) (sub_mem hX (hF _))) hY,
+      (placeOfEquation hrs).evalAt_mul hv (hF _) (sub_mem hX (hF _)),
+      hδeval, evalAt_yGen_placeOfEquation hrs,
+      Place.evalAt_algebraMap, Place.evalAt_algebraMap]
+  · rw [(placeOfEquation hrs).evalAt_sub hv (mul_mem (hF _) (hF _)) (mul_mem (hF _) (hF _)),
+      (placeOfEquation hrs).evalAt_mul hv (hF _) (hF _),
+      (placeOfEquation hrs).evalAt_mul hv (hF _) (hF _),
+      Place.evalAt_algebraMap, Place.evalAt_algebraMap, Place.evalAt_algebraMap,
+      Place.evalAt_algebraMap]
+
+end VeluCoord
+
+section Discharge
+
+variable [IsDedekindDomain W.CoordinateRing] {r s : F} (hrs : W.Equation r s)
+  {S : Finset (F × F)}
+
+include hrs in
+theorem evalAt_veluDeficitFun_placeOfEquation (hS : ∀ A ∈ S, r ≠ A.1) :
+    (placeOfEquation hrs).evalAt (W.veluDeficitFun S) = W.veluDeficit S r s := by
+  have hv := isRational_placeOfEquation hrs
+  unfold WeierstrassCurve.veluDeficitFun WeierstrassCurve.veluDeficit
+  set X' := (W.map (algebraMap F W.FunctionField)).veluX (W.liftSummingSet S)
+    (polyToFunctionField W X) with hX'
+  set Y' := (W.map (algebraMap F W.FunctionField)).veluY (W.liftSummingSet S)
+    (polyToFunctionField W X) (yGen W) with hY'
+  have hXm : X' ∈ (placeOfEquation hrs).toValuationSubring :=
+    veluX_liftSummingSet_mem_placeOfEquation hrs hS
+  have hYm : Y' ∈ (placeOfEquation hrs).toValuationSubring :=
+    veluY_liftSummingSet_mem_placeOfEquation hrs hS
+  have hF : ∀ c : F, algebraMap F W.FunctionField c
+      ∈ (placeOfEquation hrs).toValuationSubring :=
+    (placeOfEquation hrs).algebraMap_mem'
+  have hXe : (placeOfEquation hrs).evalAt X' = W.veluX S r :=
+    evalAt_veluX_liftSummingSet_placeOfEquation hrs hS
+  have hYe : (placeOfEquation hrs).evalAt Y' = W.veluY S r s :=
+    evalAt_veluY_liftSummingSet_placeOfEquation hrs hS
+  rw [veluQuotient_a₄, veluQuotient_a₆,
+    show (W.liftSummingSet S : Finset _) = S.map ⟨Prod.map (algebraMap F W.FunctionField)
+      (algebraMap F W.FunctionField), (RingHom.injective _).prodMap
+      (RingHom.injective _)⟩ from rfl,
+    map_veluTSum _ _ S (RingHom.injective _), map_veluWSum _ _ S (RingHom.injective _),
+    map_a₁, map_a₂, map_a₃, map_a₄, map_a₆, map_b₂]
+  have hcoef4 : (algebraMap F W.FunctionField W.a₄
+      - 5 * algebraMap F W.FunctionField (W.veluTSum S))
+      ∈ (placeOfEquation hrs).toValuationSubring :=
+    sub_mem (hF _) (mul_mem (ofNat_mem _ 5) (hF _))
+  have hcoef6 : (algebraMap F W.FunctionField W.a₆
+      - algebraMap F W.FunctionField W.b₂ * algebraMap F W.FunctionField (W.veluTSum S)
+      - 7 * algebraMap F W.FunctionField (W.veluWSum S))
+      ∈ (placeOfEquation hrs).toValuationSubring :=
+    sub_mem (sub_mem (hF _) (mul_mem (hF _) (hF _))) (mul_mem (ofNat_mem _ 7) (hF _))
+  rw [(placeOfEquation hrs).evalAt_sub hv
+      (add_mem (add_mem (pow_mem hYm 2) (mul_mem (mul_mem (hF _) hXm) hYm))
+        (mul_mem (hF _) hYm))
+      (add_mem (add_mem (add_mem (pow_mem hXm 3) (mul_mem (hF _) (pow_mem hXm 2)))
+        (mul_mem hcoef4 hXm)) hcoef6),
+    (placeOfEquation hrs).evalAt_add hv
+      (add_mem (pow_mem hYm 2) (mul_mem (mul_mem (hF _) hXm) hYm)) (mul_mem (hF _) hYm),
+    (placeOfEquation hrs).evalAt_add hv (pow_mem hYm 2) (mul_mem (mul_mem (hF _) hXm) hYm),
+    (placeOfEquation hrs).evalAt_pow hv hYm 2, hYe,
+    (placeOfEquation hrs).evalAt_mul hv (mul_mem (hF _) hXm) hYm,
+    (placeOfEquation hrs).evalAt_mul hv (hF _) hXm, Place.evalAt_algebraMap, hXe, hYe,
+    (placeOfEquation hrs).evalAt_mul hv (hF _) hYm, Place.evalAt_algebraMap, hYe,
+    (placeOfEquation hrs).evalAt_add hv
+      (add_mem (add_mem (pow_mem hXm 3) (mul_mem (hF _) (pow_mem hXm 2)))
+        (mul_mem hcoef4 hXm)) hcoef6,
+    (placeOfEquation hrs).evalAt_add hv
+      (add_mem (pow_mem hXm 3) (mul_mem (hF _) (pow_mem hXm 2))) (mul_mem hcoef4 hXm),
+    (placeOfEquation hrs).evalAt_add hv (pow_mem hXm 3) (mul_mem (hF _) (pow_mem hXm 2)),
+    (placeOfEquation hrs).evalAt_pow hv hXm 3, hXe,
+    (placeOfEquation hrs).evalAt_mul hv (hF _) (pow_mem hXm 2),
+    (placeOfEquation hrs).evalAt_pow hv hXm 2, hXe, Place.evalAt_algebraMap,
+    (placeOfEquation hrs).evalAt_mul hv hcoef4 hXm,
+    (placeOfEquation hrs).evalAt_sub hv (hF _) (mul_mem (ofNat_mem _ 5) (hF _)),
+    (placeOfEquation hrs).evalAt_mul hv (ofNat_mem _ 5) (hF _),
+    (placeOfEquation hrs).evalAt_ofNat 5, Place.evalAt_algebraMap, Place.evalAt_algebraMap, hXe,
+    (placeOfEquation hrs).evalAt_sub hv (sub_mem (hF _) (mul_mem (hF _) (hF _)))
+      (mul_mem (ofNat_mem _ 7) (hF _)),
+    (placeOfEquation hrs).evalAt_sub hv (hF _) (mul_mem (hF _) (hF _)),
+    (placeOfEquation hrs).evalAt_mul hv (hF _) (hF _),
+    (placeOfEquation hrs).evalAt_mul hv (ofNat_mem _ 7) (hF _),
+    (placeOfEquation hrs).evalAt_ofNat 7, Place.evalAt_algebraMap, Place.evalAt_algebraMap,
+    Place.evalAt_algebraMap, Place.evalAt_algebraMap,
+    veluQuotient_a₄, veluQuotient_a₆]
+
+end Discharge
+
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+variable {F : Type*} [Field F] [DecidableEq F]
+
+public theorem veluDeficitFunEvalAtPlaceAt
+    (hDD : ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 → IsDedekindDomain W.toAffine.CoordinateRing)
+    (p : ℕ) : VeluDeficitFunEvalAtPlaceAt F hDD p := by
+  intro W hΔ x₀ y₀ h₀ _hord r s hrs hav
+  have := hDD W hΔ
+  exact Affine.evalAt_veluDeficitFun_placeOfEquation hrs hav
+
+public theorem veluDeficitIsConstantAt_of_ordNonneg_of_dedekind {p : ℕ}
+    (hPD : ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+      HasPrincipalDivisors F W.toAffine.FunctionField)
+    (hDD : ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+      IsDedekindDomain W.toAffine.CoordinateRing)
+    (hreg : VeluDeficitFunOrdNonnegAt F p) :
+    VeluDeficitIsConstantAt F p :=
+  veluDeficitIsConstantAt_of_ordNonneg_of_evalAtPlace hPD hDD hreg
+    (veluDeficitFunEvalAtPlaceAt hDD p)
+
+end WeierstrassCurve
+
+end
+
+section
+
+noncomputable section
+
+namespace WeierstrassCurve
+section Psi2Sq
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+theorem Ψ₂Sq_ne_zero_of_Δ_ne_zero (hΔ : W.Δ ≠ 0) : W.Ψ₂Sq ≠ 0 := by
+  intro h0
+  apply hΔ
+  have h4 : (4 : F) = 0 := by
+    have hc := congrArg (·.coeff 3) h0
+    simpa only [W.coeff_Ψ₂Sq, coeff_zero] using hc
+  have hb₂ : W.b₂ = 0 := by
+    have hc := congrArg (·.coeff 2) h0
+    simp only [Ψ₂Sq, coeff_add, coeff_C_mul, coeff_C, coeff_X_pow, coeff_zero, coeff_X,
+      mul_ite, mul_one, mul_zero] at hc
+    norm_num at hc
+    exact hc
+  have hb₆ : W.b₆ = 0 := by
+    have hc := congrArg (·.coeff 0) h0
+    simp only [Ψ₂Sq, coeff_add, coeff_C_mul, coeff_C, coeff_X_pow, coeff_zero, coeff_X,
+      mul_ite, mul_one, mul_zero] at hc
+    norm_num at hc
+    exact hc
+  rw [WeierstrassCurve.Δ, hb₂, hb₆]
+  linear_combination -(2 * W.b₄ ^ 3) * h4
+
+end Psi2Sq
+
+section Parity
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+theorem veluDeficitCrossQuadBetaOnly_negY_of_equation {S : Finset (F × F)} {r s : F}
+    (hP : W.toAffine.Equation r s) :
+    W.veluDeficitCrossQuadBetaOnly S r (W.toAffine.negY r s)
+      = W.veluDeficitCrossQuadBetaOnly S r s := by
+  unfold veluDeficitCrossQuadBetaOnly veluDeficitCrossQuadCubeBeta
+  rw [W.veluDeficitCrossQuad_negY_of_equation hP]
+
+end Parity
+
+section BetaSCoeffPoly
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+omit [DecidableEq F] in
+def veluYCorrSCoeffNumPoly (A : F × F) : F[X] :=
+  -(C (2 * W.veluU A.1 A.2) + C (W.veluT A.1 A.2) * (X - C A.1))
+
+omit [DecidableEq F] in
+lemma veluYCorrSCoeffNumPoly_natDegree_le (A : F × F) :
+    (W.veluYCorrSCoeffNumPoly A).natDegree ≤ 1 := by
+  unfold veluYCorrSCoeffNumPoly; compute_degree
+
+def veluYCorrSCoeffPadPoly (S : Finset (F × F)) (A : F × F) : F[X] :=
+  W.veluYCorrSCoeffNumPoly A * (∏ B ∈ S.erase A, (X - C B.1)) ^ 3
+
+theorem eval_veluYCorrSCoeffPadPoly {S : Finset (F × F)} {A : F × F} (hA : A ∈ S) {r : F}
+    (hav : ∀ B ∈ S, r ≠ B.1) :
+    -(2 * W.veluU A.1 A.2 / (r - A.1) ^ 3 + W.veluT A.1 A.2 / (r - A.1) ^ 2)
+        * (∏ B ∈ S, (r - B.1)) ^ 3
+      = (W.veluYCorrSCoeffPadPoly S A).eval r := by
+  have hd : r - A.1 ≠ 0 := sub_ne_zero.mpr (hav A hA)
+  have hsplit : (∏ B ∈ S, (r - B.1)) ^ 3
+      = (r - A.1) ^ 3 * (∏ B ∈ S.erase A, (r - B.1)) ^ 3 := by
+    rw [← mul_pow, ← Finset.prod_erase_mul S _ hA, mul_comm]
+  rw [hsplit, veluYCorrSCoeffPadPoly, veluYCorrSCoeffNumPoly]
+  simp only [eval_mul, eval_neg, eval_add, eval_C, eval_sub, eval_X, eval_pow, eval_prod]
+  field_simp
+
+def veluYCorrSCoeffSumPadPoly (S : Finset (F × F)) : F[X] := ∑ A ∈ S, W.veluYCorrSCoeffPadPoly S A
+
+omit [DecidableEq F] in
+lemma veluY_sub_self_sLinear (S : Finset (F × F)) (r s : F) :
+    (W.veluY S r s - s) - (W.veluY S r 0 - 0)
+      = (∑ A ∈ S, -(2 * W.veluU A.1 A.2 / (r - A.1) ^ 3
+          + W.veluT A.1 A.2 / (r - A.1) ^ 2)) * s := by
+  simp only [veluY, sub_zero, sub_sub_cancel_left, zero_sub, sub_neg_eq_add, neg_add_eq_sub,
+    Finset.sum_mul, ← Finset.sum_sub_distrib]
+  exact Finset.sum_congr rfl fun A _ => by ring
+
+omit [DecidableEq F] in
+theorem veluY_singleton_sub_sLinear (A : F × F) (r s : F) :
+    (W.veluY {A} r s - s) - (W.veluY {A} r 0 - 0)
+      = -(2 * W.veluU A.1 A.2 / (r - A.1) ^ 3 + W.veluT A.1 A.2 / (r - A.1) ^ 2) * s := by
+  have key := W.veluY_sub_self_sLinear {A} r s
+  simpa using key
+
+theorem veluY_sub_self_sCoeff_mul_prodPow_eq {S : Finset (F × F)} {r : F}
+    (hav : ∀ B ∈ S, r ≠ B.1) :
+    (∑ A ∈ S, -(2 * W.veluU A.1 A.2 / (r - A.1) ^ 3
+          + W.veluT A.1 A.2 / (r - A.1) ^ 2)) * (∏ B ∈ S, (r - B.1)) ^ 3
+      = (W.veluYCorrSCoeffSumPadPoly S).eval r := by
+  rw [veluYCorrSCoeffSumPadPoly, eval_finsetSum, Finset.sum_mul]
+  exact Finset.sum_congr rfl fun A hA => W.eval_veluYCorrSCoeffPadPoly hA hav
+
+end BetaSCoeffPoly
+
+section Reduction
+
+variable (F : Type*) [Field F] [DecidableEq F]
+
+@[expose] public def VeluDeficitCrossQuadBetaSDecompDegLtAt (p : ℕ) : Prop :=
+  ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+    ∀ (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      addOrderOf (Point.some x₀ y₀ h₀ : W.toAffine.Point) = p →
+        ∃ M N : F[X], M.natDegree < 4 * ((p - 1) / 2) ∧
+          ∀ ⦃r s : F⦄, W.toAffine.Equation r s →
+            (∀ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2), r ≠ A.1) →
+            W.veluDeficitCrossQuadBetaOnly
+                (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)) r s
+              * (∏ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2),
+                    (r - A.1)) ^ 4
+              = M.eval r + N.eval r * s
+
+end Reduction
+
+end WeierstrassCurve
+
+end
+
+
+noncomputable section
+
+namespace WeierstrassCurve
+namespace Affine
+
+universe u
+
+variable {F : Type u} [Field F]
+
+section Transcendence
+
+variable {W : Affine F} {a b : F}
+
+theorem isIntegral_addYFun_adjoin_addXFun (hA : W.Equation a b) :
+    IsIntegral (Algebra.adjoin F ({W.addXFun a b} : Set W.FunctionField)) (W.addYFun a b) := by
+  set R := Algebra.adjoin F ({W.addXFun a b} : Set W.FunctionField)
+  have hmem : ∀ p : F[X], (Polynomial.aeval (R := F) (W.addXFun a b)).toRingHom p ∈ R := by
+    intro p
+    change Polynomial.aeval (R := F) (W.addXFun a b) p ∈ R
+    rw [show R = Algebra.adjoin F ({W.addXFun a b} : Set W.FunctionField) from rfl,
+      Algebra.adjoin_singleton_eq_range_aeval]
+    exact ⟨p, rfl⟩
+  let φ : F[X] →+* R :=
+    (Polynomial.aeval (R := F) (W.addXFun a b)).toRingHom.codRestrict R.toSubring hmem
+  refine ⟨W.polynomial.map φ, monic_polynomial.map φ, ?_⟩
+  change Polynomial.eval₂ (algebraMap R W.FunctionField) (W.addYFun a b) (W.polynomial.map φ) = 0
+  rw [Polynomial.eval₂_map]
+  exact eval₂_polynomial_addFun W hA
+
+theorem addXFunTranscendental (hΔ : W.Δ ≠ 0) (hA : W.Equation a b) :
+    AddXFunTranscendental W a b := by
+  intro hX'alg
+  have hX'int : _root_.IsIntegral F (W.addXFun a b) := isAlgebraic_iff_isIntegral.mp hX'alg
+  have hRint : Algebra.IsIntegral F
+      (Algebra.adjoin F ({W.addXFun a b} : Set W.FunctionField)) :=
+    Algebra.IsIntegral.adjoin (fun x hx => by
+      obtain rfl := Set.mem_singleton_iff.mp hx; exact hX'int)
+  have hY'int : _root_.IsIntegral F (W.addYFun a b) :=
+    isIntegral_trans (W.addYFun a b) (isIntegral_addYFun_adjoin_addXFun hA)
+  have hKalg : Algebra.IsAlgebraic F
+      (IntermediateField.adjoin F ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField)) :=
+    IntermediateField.isAlgebraic_adjoin (fun x hx => by
+      rcases hx with rfl | rfl
+      · exact hX'int
+      · exact hY'int)
+  have hXmem : polyToFunctionField W X
+      ∈ IntermediateField.adjoin F ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField) :=
+    polyToFunctionField_X_mem_adjoin_addFun hΔ hA
+  have hXalg : IsAlgebraic F (polyToFunctionField W X) :=
+    IntermediateField.isAlgebraic_iff.mp
+      (Algebra.IsAlgebraic.isAlgebraic (⟨polyToFunctionField W X, hXmem⟩ :
+        IntermediateField.adjoin F ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField)))
+  exact transcendental_polyToFunctionField_X hXalg
+
+end Transcendence
+
+section UnconditionalAut
+
+variable {W : Affine F} (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b)
+
+def translationAlgEquivOf : W.FunctionField ≃ₐ[F] W.FunctionField :=
+  translationAlgEquiv hA (addXFunTranscendental hΔ hA) hΔ
+
+@[scoped simp] theorem translationAlgEquivOf_apply (z : W.FunctionField) :
+    translationAlgEquivOf hΔ hA z = translationHom hA (addXFunTranscendental hΔ hA) z := rfl
+
+@[scoped simp] theorem translationAlgEquivOf_polyToFunctionField_X :
+    translationAlgEquivOf hΔ hA (polyToFunctionField W X) = W.addXFun a b :=
+  translationHom_polyToFunctionField_X hA (addXFunTranscendental hΔ hA)
+
+@[scoped simp] theorem translationAlgEquivOf_yGen :
+    translationAlgEquivOf hΔ hA (yGen W) = W.addYFun a b :=
+  translationHom_yGen hA (addXFunTranscendental hΔ hA)
+
+end UnconditionalAut
+
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+section SubCarriers
+
+variable (F : Type*) [Field F] [DecidableEq F]
+
+def VeluDeficitFunKernelTranslationFixesAt (p : ℕ) : Prop :=
+  ∀ (W : WeierstrassCurve F) (hΔ : W.Δ ≠ 0)
+    (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      addOrderOf (Point.some x₀ y₀ h₀ : W.toAffine.Point) = p →
+        ∀ (a b : F) (hab : W.toAffine.Equation a b),
+          (∃ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2), A.1 = a) →
+          translationAlgEquivOf hΔ hab
+              (W.toAffine.veluDeficitFun
+                (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)))
+            = W.toAffine.veluDeficitFun
+                (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2))
+
+def VeluDeficitFunKernelTranslationToInftyAt (p : ℕ) : Prop :=
+  ∀ (W : WeierstrassCurve F) (hΔ : W.Δ ≠ 0)
+    (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      addOrderOf (Point.some x₀ y₀ h₀ : W.toAffine.Point) = p →
+        ∀ (v : Place F W.toAffine.FunctionField) (hv : IsFinitePlace v),
+          (∃ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2),
+            XClass W.toAffine A.1 ∈ hv.centre) →
+          ∃ (a b : F) (hab : W.toAffine.Equation a b),
+            (∃ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2), A.1 = a) ∧
+            ¬ IsFinitePlace (translationAlgEquivOf hΔ hab • v)
+
+end SubCarriers
+
+section Recombination
+
+variable (F : Type*) [Field F] [DecidableEq F]
+
+theorem veluDeficitFunKernelTranslationAt_of_fixes_of_toInfty {p : ℕ}
+    (hfix : VeluDeficitFunKernelTranslationFixesAt F p)
+    (hto : VeluDeficitFunKernelTranslationToInftyAt F p) :
+    VeluDeficitFunKernelTranslationAt F p := by
+  intro W hΔ x₀ y₀ h₀ hord v hv hk
+  obtain ⟨a, b, hab, hka, hninf⟩ := hto W hΔ x₀ y₀ h₀ hord v hv hk
+  exact ⟨translationAlgEquivOf hΔ hab, hfix W hΔ x₀ y₀ h₀ hord a b hab hka, hninf⟩
+
+end Recombination
+
+end WeierstrassCurve
+
+end
+
+
+section
+
+noncomputable section
+
+namespace WeierstrassCurve
+section Helper
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+lemma veluY_sub_self_eq_sum_singleton (S : Finset (F × F)) (r s : F) :
+    W.veluY S r s - s = ∑ A ∈ S, (W.veluY {A} r s - s) := by
+  simp only [veluY, Finset.sum_singleton, sub_sub_cancel_left, ← Finset.sum_neg_distrib]
+
+end Helper
+
+section BetaConstPoly
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+omit [DecidableEq F] in
+def veluYCorrConstNumPoly (A : F × F) : F[X] :=
+  -(C (W.veluU A.1 A.2) * (C W.a₁ * X + C W.a₃))
+    - (C (W.veluT A.1 A.2) * (C W.a₁ * (X - C A.1) - C A.2)
+        + C (W.a₁ * W.veluU A.1 A.2 - W.veluGx A.1 A.2 * W.veluGy A.1 A.2)) * (X - C A.1)
+
+omit [DecidableEq F] in
+lemma veluYCorrConstNumPoly_natDegree_le (A : F × F) :
+    (W.veluYCorrConstNumPoly A).natDegree ≤ 2 := by
+  unfold veluYCorrConstNumPoly; compute_degree
+
+def veluYCorrConstPadPoly (S : Finset (F × F)) (A : F × F) : F[X] :=
+  W.veluYCorrConstNumPoly A * (∏ B ∈ S.erase A, (X - C B.1)) ^ 3
+
+theorem eval_veluYCorrConstPadPoly {S : Finset (F × F)} {A : F × F} (hA : A ∈ S) {r : F}
+    (hav : ∀ B ∈ S, r ≠ B.1) :
+    (W.veluY {A} r 0 - 0) * (∏ B ∈ S, (r - B.1)) ^ 3
+      = (W.veluYCorrConstPadPoly S A).eval r := by
+  have hd : r - A.1 ≠ 0 := sub_ne_zero.mpr (hav A hA)
+  have hsplit : (∏ B ∈ S, (r - B.1)) ^ 3
+      = (r - A.1) ^ 3 * (∏ B ∈ S.erase A, (r - B.1)) ^ 3 := by
+    rw [← mul_pow, ← Finset.prod_erase_mul S _ hA, mul_comm]
+  rw [hsplit, veluYCorrConstPadPoly, veluYCorrConstNumPoly]
+  simp only [veluY, Finset.sum_singleton, eval_mul, eval_neg, eval_add, eval_C, eval_sub, eval_X,
+    eval_pow, eval_prod]
+  field_simp
+  ring
+
+def veluYCorrConstSumPadPoly (S : Finset (F × F)) : F[X] := ∑ A ∈ S, W.veluYCorrConstPadPoly S A
+
+theorem eval_veluYCorrConstSumPadPoly {S : Finset (F × F)} {r : F} (hav : ∀ B ∈ S, r ≠ B.1) :
+    (W.veluY S r 0 - 0) * (∏ B ∈ S, (r - B.1)) ^ 3
+      = (W.veluYCorrConstSumPadPoly S).eval r := by
+  rw [veluYCorrConstSumPadPoly, eval_finsetSum, W.veluY_sub_self_eq_sum_singleton, Finset.sum_mul]
+  exact Finset.sum_congr rfl fun A hA => W.eval_veluYCorrConstPadPoly hA hav
+
+end BetaConstPoly
+
+section BetaSDecomp
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+theorem veluY_sub_self_mul_prodCube_sDecomp {S : Finset (F × F)} {r : F} (s : F)
+    (hav : ∀ B ∈ S, r ≠ B.1) :
+    (W.veluY S r s - s) * (∏ B ∈ S, (r - B.1)) ^ 3
+      = (W.veluYCorrConstSumPadPoly S).eval r + (W.veluYCorrSCoeffSumPadPoly S).eval r * s := by
+  have hlin := W.veluY_sub_self_sLinear S r s
+  have hconst := W.eval_veluYCorrConstSumPadPoly (S := S) hav
+  have hcoeff := W.veluY_sub_self_sCoeff_mul_prodPow_eq (S := S) hav
+  have key : (W.veluY S r s - s)
+      = (W.veluY S r 0 - 0) + (∑ A ∈ S, -(2 * W.veluU A.1 A.2 / (r - A.1) ^ 3
+          + W.veluT A.1 A.2 / (r - A.1) ^ 2)) * s := by
+    linear_combination hlin
+  rw [key, add_mul, hconst, mul_right_comm, hcoeff]
+
+theorem veluY_singleton_sub_self_mul_prodCube_sDecomp {S : Finset (F × F)} {A : F × F}
+    (hA : A ∈ S) {r : F} (s : F) (hav : ∀ B ∈ S, r ≠ B.1) :
+    (W.veluY {A} r s - s) * (∏ B ∈ S, (r - B.1)) ^ 3
+      = (W.veluYCorrConstPadPoly S A).eval r + (W.veluYCorrSCoeffPadPoly S A).eval r * s := by
+  have hlin := W.veluY_singleton_sub_sLinear A r s
+  have hconst := W.eval_veluYCorrConstPadPoly hA hav
+  have hcoeff := W.eval_veluYCorrSCoeffPadPoly hA (r := r) hav
+  have key : (W.veluY {A} r s - s)
+      = (W.veluY {A} r 0 - 0) + (-(2 * W.veluU A.1 A.2 / (r - A.1) ^ 3
+          + W.veluT A.1 A.2 / (r - A.1) ^ 2)) * s := by
+    linear_combination hlin
+  rw [key, add_mul, hconst, mul_right_comm, hcoeff]
+
+end BetaSDecomp
+
+section TwoCrossTypes
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+@[expose] public def veluDeficitCrossQuadBetaSq (S : Finset (F × F)) (r s : F) : F :=
+  (W.veluY S r s - s) ^ 2 - ∑ A ∈ S, (W.veluY {A} r s - s) ^ 2
+
+@[expose] public def veluDeficitCrossQuadAlphaBeta (S : Finset (F × F)) (r s : F) : F :=
+  (W.veluX S r - r) * (W.veluY S r s - s)
+    - ∑ A ∈ S, (W.veluX {A} r - r) * (W.veluY {A} r s - s)
+
+theorem veluDeficitCrossQuadBetaOnly_eq_betaSq_add_alphaBeta [DecidableEq F]
+    (S : Finset (F × F)) (r s : F) :
+    W.veluDeficitCrossQuadBetaOnly S r s
+      = W.veluDeficitCrossQuadBetaSq S r s + W.a₁ * W.veluDeficitCrossQuadAlphaBeta S r s := by
+  rw [W.veluDeficitCrossQuadBetaOnly_eq, veluDeficitCrossQuadBetaSq,
+    veluDeficitCrossQuadAlphaBeta]
+  have hper : ∀ A ∈ S, ((W.veluY {A} r s - s) ^ 2
+        + W.a₁ * (W.veluX {A} r - r) * (W.veluY {A} r s - s))
+      = (W.veluY {A} r s - s) ^ 2
+        + W.a₁ * ((W.veluX {A} r - r) * (W.veluY {A} r s - s)) := fun A _ => by ring
+  rw [Finset.sum_congr rfl hper, Finset.sum_add_distrib, ← Finset.mul_sum]
+  ring
+
+end TwoCrossTypes
+
+section Reduction
+
+variable (F : Type*) [Field F] [DecidableEq F]
+
+@[expose] public def VeluDeficitCrossQuadBetaSqDecompDegLtAt (p : ℕ) : Prop :=
+  ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+    ∀ (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      addOrderOf (Point.some x₀ y₀ h₀ : W.toAffine.Point) = p →
+        ∃ M N : F[X], M.natDegree < 4 * ((p - 1) / 2) ∧
+          ∀ ⦃r s : F⦄, W.toAffine.Equation r s →
+            (∀ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2), r ≠ A.1) →
+            W.veluDeficitCrossQuadBetaSq
+                (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)) r s
+              * (∏ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2),
+                    (r - A.1)) ^ 4
+              = M.eval r + N.eval r * s
+
+@[expose] public def VeluDeficitCrossQuadAlphaBetaDecompDegLtAt (p : ℕ) : Prop :=
+  ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+    ∀ (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      addOrderOf (Point.some x₀ y₀ h₀ : W.toAffine.Point) = p →
+        ∃ M N : F[X], M.natDegree < 4 * ((p - 1) / 2) ∧
+          ∀ ⦃r s : F⦄, W.toAffine.Equation r s →
+            (∀ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2), r ≠ A.1) →
+            W.veluDeficitCrossQuadAlphaBeta
+                (W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)) r s
+              * (∏ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2),
+                    (r - A.1)) ^ 4
+              = M.eval r + N.eval r * s
+
+variable {F}
+
+public theorem veluDeficitCrossQuadBetaSDecompDegLtAt_of_betaSq_of_alphaBeta
+    {p : ℕ} (hBSq : VeluDeficitCrossQuadBetaSqDecompDegLtAt F p)
+    (hαβ : VeluDeficitCrossQuadAlphaBetaDecompDegLtAt F p) :
+    VeluDeficitCrossQuadBetaSDecompDegLtAt F p := by
+  intro W hΔ x₀ y₀ h₀ hord
+  obtain ⟨M₁, N₁, hM₁deg, hMN₁⟩ := hBSq W hΔ x₀ y₀ h₀ hord
+  obtain ⟨M₂, N₂, hM₂deg, hMN₂⟩ := hαβ W hΔ x₀ y₀ h₀ hord
+  refine ⟨M₁ + C W.a₁ * M₂, N₁ + C W.a₁ * N₂, ?_, ?_⟩
+  · refine lt_of_le_of_lt (natDegree_add_le _ _) (max_lt hM₁deg ?_)
+    exact lt_of_le_of_lt (natDegree_mul_le.trans (by simp)) hM₂deg
+  · intro r s hrs hav
+    rw [W.veluDeficitCrossQuadBetaOnly_eq_betaSq_add_alphaBeta, add_mul, mul_assoc,
+      hMN₁ hrs hav, hMN₂ hrs hav]
+    simp only [eval_add, eval_mul, eval_C]; ring
+
+end Reduction
+
+end WeierstrassCurve
+
+end
+
+
+noncomputable section
+
+namespace WeierstrassCurve
+universe u
+
+variable {F : Type u} [Field F]
+
+section CoordsAPI
+
+variable {W : Affine F} (hΔ : W.Δ ≠ 0)
+
+local notation "ι" => algebraMap F W.FunctionField
+
+theorem genericPoint'_add_mapPoint_coordsOrZero {a b : F} (hA : W.Equation a b) :
+    (Affine.genericPoint' hΔ + Affine.mapPoint hΔ hA).coordsOrZero
+      = (W.addXFun a b, W.addYFun a b) := by
+  rw [Affine.genericPoint'_add_map hΔ hA, Point.coordsOrZero_some]
+
+end CoordsAPI
+
+section AlgHomFixes
+
+variable {K : Type*} [Field K] [Algebra F K]
+
+theorem algHom_toRingHom_comp_algebraMap (τ : K →ₐ[F] K) :
+    τ.toRingHom.comp (algebraMap F K) = algebraMap F K :=
+  RingHom.ext fun c => τ.commutes c
+
+theorem map_map_algHom_toRingHom_eq_self (W : WeierstrassCurve F) (τ : K →ₐ[F] K) :
+    (W.map (algebraMap F K)).map τ.toRingHom = W.map (algebraMap F K) := by
+  rw [WeierstrassCurve.map_map, algHom_toRingHom_comp_algebraMap]
+
+variable (W : Affine F)
+
+theorem liftSummingSet_map_algHom (τ : W.FunctionField →ₐ[F] W.FunctionField)
+    (hτ : Function.Injective τ.toRingHom) (S : Finset (F × F)) :
+    (W.liftSummingSet S).map ⟨Prod.map τ.toRingHom τ.toRingHom, hτ.prodMap hτ⟩
+      = W.liftSummingSet S := by
+  unfold liftSummingSet
+  rw [Finset.map_map]
+  congr 1
+  refine Function.Embedding.ext fun ⟨c, d⟩ => ?_
+  change (τ.toRingHom (algebraMap F W.FunctionField c), τ.toRingHom (algebraMap F W.FunctionField
+    d)) = (algebraMap F W.FunctionField c, algebraMap F W.FunctionField d)
+  rw [show τ.toRingHom (algebraMap F W.FunctionField c) = algebraMap F W.FunctionField c from
+        τ.commutes c,
+      show τ.toRingHom (algebraMap F W.FunctionField d) = algebraMap F W.FunctionField d from
+        τ.commutes d]
+
+end AlgHomFixes
+
+section AlgHomNaturality
+
+variable (W : Affine F)
+
+local notation "ι" => algebraMap F W.FunctionField
+
+theorem algHom_veluDeficit_liftSummingSet (τ : W.FunctionField →ₐ[F] W.FunctionField)
+    (S : Finset (F × F)) (r s : W.FunctionField) :
+    τ ((W.map ι).veluDeficit (W.liftSummingSet S) r s)
+      = (W.map ι).veluDeficit (W.liftSummingSet S) (τ r) (τ s) := by
+  have hτinj : Function.Injective τ.toRingHom := τ.toRingHom.injective
+  have hkey := (W.map ι).map_veluDeficit τ.toRingHom (W.liftSummingSet S) hτinj r s
+  rw [W.map_map_algHom_toRingHom_eq_self τ, W.liftSummingSet_map_algHom τ hτinj S] at hkey
+  exact hkey.symm
+
+theorem algHom_veluDeficitFun (τ : W.FunctionField →ₐ[F] W.FunctionField)
+    (S : Finset (F × F)) :
+    τ (W.veluDeficitFun S)
+      = (W.map ι).veluDeficit (W.liftSummingSet S)
+          (τ (polyToFunctionField W X)) (τ (yGen W)) :=
+  W.algHom_veluDeficit_liftSummingSet τ S (polyToFunctionField W X) (yGen W)
+
+end AlgHomNaturality
+
+section TranslationAction
+
+variable {W : Affine F} (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b)
+
+local notation "ι" => algebraMap F W.FunctionField
+
+theorem translationAlgEquivOf_veluDeficitFun (S : Finset (F × F)) :
+    Affine.translationAlgEquivOf hΔ hA (W.veluDeficitFun S)
+      = (W.map ι).veluDeficit (W.liftSummingSet S) (W.addXFun a b) (W.addYFun a b) := by
+  rw [Affine.translationAlgEquivOf_apply,
+    W.algHom_veluDeficitFun (Affine.translationHom hA (Affine.addXFunTranscendental hΔ hA)) S,
+    Affine.translationHom_polyToFunctionField_X, Affine.translationHom_yGen]
+
+theorem translationAlgEquivOf_veluDeficitFun_eq_coordsOrZero (S : Finset (F × F)) :
+    Affine.translationAlgEquivOf hΔ hA (W.veluDeficitFun S)
+      = (W.map ι).veluDeficit (W.liftSummingSet S)
+          (Affine.genericPoint' hΔ + Affine.mapPoint hΔ hA).coordsOrZero.1
+          (Affine.genericPoint' hΔ + Affine.mapPoint hΔ hA).coordsOrZero.2 := by
+  rw [translationAlgEquivOf_veluDeficitFun hΔ hA S,
+    genericPoint'_add_mapPoint_coordsOrZero hΔ hA]
+
+theorem veluDeficitFun_eq_coordsOrZero_genericPoint' (S : Finset (F × F)) :
+    W.veluDeficitFun S
+      = (W.map ι).veluDeficit (W.liftSummingSet S)
+          (Affine.genericPoint' hΔ).coordsOrZero.1
+          (Affine.genericPoint' hΔ).coordsOrZero.2 :=
+  rfl
+
+theorem translationAlgEquivOf_veluDeficitFun_eq_iff (S : Finset (F × F)) :
+    Affine.translationAlgEquivOf hΔ hA (W.veluDeficitFun S) = W.veluDeficitFun S
+      ↔ (W.map ι).veluDeficit (W.liftSummingSet S)
+            (Affine.genericPoint' hΔ + Affine.mapPoint hΔ hA).coordsOrZero.1
+            (Affine.genericPoint' hΔ + Affine.mapPoint hΔ hA).coordsOrZero.2
+          = (W.map ι).veluDeficit (W.liftSummingSet S)
+            (Affine.genericPoint' hΔ).coordsOrZero.1
+            (Affine.genericPoint' hΔ).coordsOrZero.2 := by
+  rw [translationAlgEquivOf_veluDeficitFun_eq_coordsOrZero hΔ hA S,
+    veluDeficitFun_eq_coordsOrZero_genericPoint' hΔ S]
+
+end TranslationAction
+
+section GenericNotConstant
+
+variable {W : Affine F} (hΔ : W.Δ ≠ 0)
+
+local notation "ι" => algebraMap F W.FunctionField
+
+theorem genericPoint'_ne_some_algebraMap (c d : F)
+    (hns : (W.map ι).Nonsingular (ι c) (ι d)) :
+    Affine.genericPoint' hΔ ≠ Affine.Point.some (ι c) (ι d) hns := by
+  intro h
+  exact polyToFunctionField_X_ne_algebraMap c (Affine.Point.some.inj h).1
+
+theorem genericPoint'_ne_zero : Affine.genericPoint' hΔ ≠ 0 :=
+  Affine.Point.some_ne_zero _
+
+end GenericNotConstant
+
+end WeierstrassCurve
+
+end
+
+
+
+noncomputable section
+
+namespace WeierstrassCurve
+namespace Affine
+
+universe u
+
+variable {F : Type u} [Field F] {W : Affine F}
+
+section InverseOnX
+
+variable (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b)
+
+local notation "ι" => algebraMap F W.FunctionField
+
+include hΔ hA in
+theorem translationAlgEquivOf_addXFun_negY :
+    translationAlgEquivOf hΔ hA (W.addXFun a (W.negY a b)) = polyToFunctionField W X := by
+  classical
+  have key := addFun_neg_cancel_X hΔ hA
+  rw [Affine.slope_of_X_ne (addXFun_ne_algebraMap hΔ hA)] at key
+  rw [addXFun, Affine.slope_of_X_ne (polyToFunctionField_X_ne_algebraMap a)]
+  set τ := translationAlgEquivOf hΔ hA
+  have hτX : τ (polyToFunctionField W X) = W.addXFun a b :=
+    translationAlgEquivOf_polyToFunctionField_X hΔ hA
+  have hτY : τ (yGen W) = W.addYFun a b := translationAlgEquivOf_yGen hΔ hA
+  have hτι : ∀ c : F, τ (ι c) = ι c := fun c => τ.commutes c
+  simp only [Affine.addX, map_a₁, map_a₂] at key ⊢
+  simp only [map_sub, map_add, map_mul, map_pow, map_div₀, hτX, hτY, hτι]
+  exact key
+
+include hΔ hA in
+theorem translationAlgEquivOf_symm_polyToFunctionField_X :
+    (translationAlgEquivOf hΔ hA).symm (polyToFunctionField W X)
+      = W.addXFun a (W.negY a b) :=
+  (AlgEquiv.symm_apply_eq _).mpr (translationAlgEquivOf_addXFun_negY hΔ hA).symm
+
+end InverseOnX
+
+section Pole
+
+variable [DecidableEq F]
+
+local notation "ι" => algebraMap F W.FunctionField
+
+omit [DecidableEq F] in
+lemma algebraMap_XClass_eq (c : F) :
+    algebraMap W.CoordinateRing W.FunctionField (XClass W c)
+      = polyToFunctionField W X - ι c := by
+  rw [show (XClass W c : W.CoordinateRing) = algebraMap F[X] W.CoordinateRing (X - C c) from rfl,
+    ← polyToFunctionField_apply, map_sub, polyToFunctionField_C]
+
+omit [DecidableEq F] in
+lemma algebraMap_YClass_eq (c : F) :
+    algebraMap W.CoordinateRing W.FunctionField (YClass W (C c)) = yGen W - ι c := by
+  have h1 : (YClass W (C c) : W.CoordinateRing)
+      = CoordinateRing.mk W Y - algebraMap F[X] W.CoordinateRing (C c) := by
+    change CoordinateRing.mk W (Y - C (C c)) = _
+    rw [map_sub]; rfl
+  rw [h1, map_sub, ← polyToFunctionField_apply, polyToFunctionField_C]; rfl
+
+omit [DecidableEq F] in
+theorem addXFun_negY_notMem_of_XClass_mem_centre {a b : F}
+    {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v)
+    (hX : XClass W a ∈ hv.centre) (hY : YClass W (C (W.negY a b)) ∉ hv.centre) :
+    W.addXFun a (W.negY a b) ∉ v.toValuationSubring := by
+  set δX : W.FunctionField := polyToFunctionField W X - ι a with hδX
+  set δY : W.FunctionField := yGen W - ι (W.negY a b) with hδY
+  have hδX0 : δX ≠ 0 := X_sub_algebraMap_ne_zero a
+  have hδY0 : δY ≠ 0 := hδY ▸ algebraMap_YClass_eq (W.negY a b) ▸
+    algebraMap_coordinateRing_ne_zero (YClass_ne_zero (W' := W) (C (W.negY a b)))
+  have hδXord : 1 ≤ v.ord δX := by
+    have h1 : v.ord δX ≠ 0 := by
+      have := (hv.mem_centre_iff_ord_ne_zero (XClass_ne_zero (W' := W) a)).mp hX
+      rwa [algebraMap_XClass_eq] at this
+    have h2 : 0 ≤ v.ord δX := by
+      rw [hδX, ← algebraMap_XClass_eq]; exact v.ord_nonneg_of_mem (hv (XClass W a))
+    omega
+  have hδYord : v.ord δY = 0 := by
+    have h1 : ¬ v.ord δY ≠ 0 := by
+      rw [hδY, ← algebraMap_YClass_eq]
+      exact fun hne => hY ((hv.mem_centre_iff_ord_ne_zero
+        (YClass_ne_zero (W' := W) (C (W.negY a b)))).mpr hne)
+    omega
+  set ℓ : W.FunctionField := δY / δX with hℓ
+  have hℓ0 : ℓ ≠ 0 := div_ne_zero hδY0 hδX0
+  have hℓord : v.ord ℓ ≤ -1 := by rw [hℓ, v.ord_div hδY0 hδX0, hδYord]; omega
+  have hℓnotmem : ℓ ∉ v.toValuationSubring := by
+    rw [v.mem_iff_ord_nonneg hℓ0]; omega
+  have hℓa₁notmem : ℓ + ι W.a₁ ∉ v.toValuationSubring := by
+    intro hmem
+    exact hℓnotmem (by simpa using sub_mem hmem (v.algebraMap_mem' W.a₁))
+  have hprod_notmem : ℓ * (ℓ + ι W.a₁) ∉ v.toValuationSubring := by
+    have hℓa₁0 : ℓ + ι W.a₁ ≠ 0 := by
+      intro h0; exact hℓa₁notmem (h0 ▸ zero_mem v.toValuationSubring)
+    rw [v.mem_iff_ord_nonneg (mul_ne_zero hℓ0 hℓa₁0), v.ord_mul hℓ0 hℓa₁0]
+    have h1 : v.ord (ℓ + ι W.a₁) < 0 := by
+      rw [← not_le, ← v.mem_iff_ord_nonneg hℓa₁0]; exact hℓa₁notmem
+    omega
+  have hkey : W.addXFun a (W.negY a b)
+      = ℓ * (ℓ + ι W.a₁) - (ι W.a₂ + polyToFunctionField W X + ι a) := by
+    rw [addXFun, Affine.slope_of_X_ne (polyToFunctionField_X_ne_algebraMap a)]
+    simp only [Affine.addX, map_a₁, map_a₂, hℓ, hδX, hδY]
+    ring
+  intro hmem
+  apply hprod_notmem
+  have htail : (ι W.a₂ + polyToFunctionField W X + ι a : W.FunctionField)
+      ∈ v.toValuationSubring :=
+    add_mem (add_mem (v.algebraMap_mem' W.a₂)
+      (polyToFunctionField_apply (W := W) X ▸ hv (algebraMap F[X] W.CoordinateRing X)))
+      (v.algebraMap_mem' a)
+  have := add_mem hmem htail
+  rwa [hkey, sub_add_cancel] at this
+
+end Pole
+
+section CombinedDischarge
+
+variable (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b)
+
+theorem not_isFinitePlace_translationAlgEquivOf_smul_of_centre
+    {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v)
+    (hX : XClass W a ∈ hv.centre) (hY : YClass W (C (W.negY a b)) ∉ hv.centre) :
+    ¬ IsFinitePlace (translationAlgEquivOf hΔ hA • v) := by
+  apply not_isFinitePlace_smul_of_symm_X_notMem (translationAlgEquivOf hΔ hA) v
+  rw [translationAlgEquivOf_symm_polyToFunctionField_X hΔ hA]
+  exact addXFun_negY_notMem_of_XClass_mem_centre hv hX hY
+
+end CombinedDischarge
+
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+section YNotCentreCarrier
+
+variable (F : Type*) [Field F] [DecidableEq F]
+
+def VeluDeficitFunKernelTranslationYNotCentreAt (p : ℕ) : Prop :=
+  ∀ (W : WeierstrassCurve F) (_ : W.Δ ≠ 0)
+    (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      addOrderOf (Point.some x₀ y₀ h₀ : W.toAffine.Point) = p →
+        ∀ (v : Place F W.toAffine.FunctionField) (hv : IsFinitePlace v),
+          (∃ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2),
+            XClass W.toAffine A.1 ∈ hv.centre) →
+          ∃ (a b : F) (_ : W.toAffine.Equation a b),
+            (∃ A ∈ W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2), A.1 = a) ∧
+            XClass W.toAffine a ∈ hv.centre ∧
+            YClass W.toAffine (C (W.toAffine.negY a b)) ∉ hv.centre
+
+end YNotCentreCarrier
+
+section ToInftyFromYNotCentre
+
+variable (F : Type*) [Field F] [DecidableEq F]
+
+theorem veluDeficitFunKernelTranslationToInftyAt_of_yNotCentre {p : ℕ}
+    (hY : VeluDeficitFunKernelTranslationYNotCentreAt F p) :
+    VeluDeficitFunKernelTranslationToInftyAt F p := by
+  intro W hΔ x₀ y₀ h₀ hord v hv hk
+  obtain ⟨a, b, hab, hka, hXcen, hYcen⟩ := hY W hΔ x₀ y₀ h₀ hord v hv hk
+  exact ⟨a, b, hab, hka,
+    Affine.not_isFinitePlace_translationAlgEquivOf_smul_of_centre hΔ hab hv hXcen hYcen⟩
+
+end ToInftyFromYNotCentre
+
+end WeierstrassCurve
+
+end
+
+
+section
+
+noncomputable section
+
+namespace WeierstrassCurve
+section Helper
+
+lemma prod_sum_sub_sum_diag_eq {R : Type*} [CommRing R] {α : Type*} [DecidableEq α]
+    (s : Finset α) (f g : α → R) :
+    (∑ A ∈ s, f A) * (∑ B ∈ s, g B) - ∑ A ∈ s, f A * g A
+      = ∑ A ∈ s, ∑ B ∈ s.erase A, f A * g B := by
+  have key : ∀ A ∈ s, f A * (∑ B ∈ s, g B)
+      = f A * g A + ∑ B ∈ s.erase A, f A * g B := by
+    intro A hA
+    rw [← Finset.mul_sum, ← Finset.add_sum_erase s g hA, mul_add]
+  rw [Finset.sum_mul, Finset.sum_congr rfl key, Finset.sum_add_distrib, add_sub_cancel_left]
+
+end Helper
+
+section MixedPairPad
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+def veluXYCorrConstPairPadQuot (S : Finset (F × F)) (A B : F × F) : F[X] :=
+  W.veluXCorrNumPoly A * W.veluYCorrConstNumPoly B * (X - C A.1) ^ 2 * (X - C B.1)
+    * (∏ E ∈ (S.erase A).erase B, (X - C E.1)) ^ 4
+
+def veluXYCorrSCoeffPairPadQuot (S : Finset (F × F)) (A B : F × F) : F[X] :=
+  W.veluXCorrNumPoly A * W.veluYCorrSCoeffNumPoly B * (X - C A.1) ^ 2 * (X - C B.1)
+    * (∏ E ∈ (S.erase A).erase B, (X - C E.1)) ^ 4
+
+theorem veluXCorrPadPoly_mul_veluYCorrConstPadPoly_eq_kernelDenom_mul {S : Finset (F × F)}
+    {A B : F × F} (hA : A ∈ S) (hB : B ∈ S) (hAB : A ≠ B) :
+    W.veluXCorrPadPoly S A * W.veluYCorrConstPadPoly S B
+      = veluKernelDenom S * W.veluXYCorrConstPairPadQuot S A B := by
+  have hBA : B ∈ S.erase A := Finset.mem_erase.mpr ⟨hAB.symm, hB⟩
+  have hAB' : A ∈ S.erase B := Finset.mem_erase.mpr ⟨hAB, hA⟩
+  unfold veluXCorrPadPoly veluYCorrConstPadPoly veluXYCorrConstPairPadQuot veluKernelDenom
+  rw [← Finset.mul_prod_erase (S.erase A) _ hBA,
+      ← Finset.mul_prod_erase (S.erase B) _ hAB',
+      Finset.erase_right_comm (a := B),
+      ← Finset.mul_prod_erase S _ hA,
+      ← Finset.mul_prod_erase (S.erase A) _ hBA]
+  ring
+
+theorem veluXCorrPadPoly_mul_veluYCorrSCoeffPadPoly_eq_kernelDenom_mul {S : Finset (F × F)}
+    {A B : F × F} (hA : A ∈ S) (hB : B ∈ S) (hAB : A ≠ B) :
+    W.veluXCorrPadPoly S A * W.veluYCorrSCoeffPadPoly S B
+      = veluKernelDenom S * W.veluXYCorrSCoeffPairPadQuot S A B := by
+  have hBA : B ∈ S.erase A := Finset.mem_erase.mpr ⟨hAB.symm, hB⟩
+  have hAB' : A ∈ S.erase B := Finset.mem_erase.mpr ⟨hAB, hA⟩
+  unfold veluXCorrPadPoly veluYCorrSCoeffPadPoly veluXYCorrSCoeffPairPadQuot veluKernelDenom
+  rw [← Finset.mul_prod_erase (S.erase A) _ hBA,
+      ← Finset.mul_prod_erase (S.erase B) _ hAB',
+      Finset.erase_right_comm (a := B),
+      ← Finset.mul_prod_erase S _ hA,
+      ← Finset.mul_prod_erase (S.erase A) _ hBA]
+  ring
+
+end MixedPairPad
+
+section AlphaBetaCleared
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+def veluDeficitCrossQuadAlphaBetaConstClearedPoly (S : Finset (F × F)) : F[X] :=
+  ∑ A ∈ S, ∑ B ∈ S.erase A, W.veluXYCorrConstPairPadQuot S A B
+
+def veluDeficitCrossQuadAlphaBetaSCoeffClearedPoly (S : Finset (F × F)) : F[X] :=
+  ∑ A ∈ S, ∑ B ∈ S.erase A, W.veluXYCorrSCoeffPairPadQuot S A B
+
+theorem veluXCorrSumPadPoly_mul_veluYCorrConstSumPadPoly_sub_sum_eq (S : Finset (F × F)) :
+    W.veluXCorrSumPadPoly S * W.veluYCorrConstSumPadPoly S
+        - ∑ A ∈ S, W.veluXCorrPadPoly S A * W.veluYCorrConstPadPoly S A
+      = veluKernelDenom S * W.veluDeficitCrossQuadAlphaBetaConstClearedPoly S := by
+  rw [veluXCorrSumPadPoly, veluYCorrConstSumPadPoly,
+    prod_sum_sub_sum_diag_eq S _ _, veluDeficitCrossQuadAlphaBetaConstClearedPoly,
+    Finset.mul_sum]
+  refine Finset.sum_congr rfl fun A hA => ?_
+  rw [Finset.mul_sum]
+  refine Finset.sum_congr rfl fun B hB => ?_
+  obtain ⟨hBA, hBS⟩ := Finset.mem_erase.mp hB
+  exact W.veluXCorrPadPoly_mul_veluYCorrConstPadPoly_eq_kernelDenom_mul hA hBS hBA.symm
+
+theorem veluXCorrSumPadPoly_mul_veluYCorrSCoeffSumPadPoly_sub_sum_eq (S : Finset (F × F)) :
+    W.veluXCorrSumPadPoly S * W.veluYCorrSCoeffSumPadPoly S
+        - ∑ A ∈ S, W.veluXCorrPadPoly S A * W.veluYCorrSCoeffPadPoly S A
+      = veluKernelDenom S * W.veluDeficitCrossQuadAlphaBetaSCoeffClearedPoly S := by
+  rw [veluXCorrSumPadPoly, veluYCorrSCoeffSumPadPoly,
+    prod_sum_sub_sum_diag_eq S _ _, veluDeficitCrossQuadAlphaBetaSCoeffClearedPoly,
+    Finset.mul_sum]
+  refine Finset.sum_congr rfl fun A hA => ?_
+  rw [Finset.mul_sum]
+  refine Finset.sum_congr rfl fun B hB => ?_
+  obtain ⟨hBA, hBS⟩ := Finset.mem_erase.mp hB
+  exact W.veluXCorrPadPoly_mul_veluYCorrSCoeffPadPoly_eq_kernelDenom_mul hA hBS hBA.symm
+
+theorem veluDeficitCrossQuadAlphaBeta_mul_prodPow_sDecomp {S : Finset (F × F)} {r : F} (s : F)
+    (hav : ∀ B ∈ S, r ≠ B.1) :
+    W.veluDeficitCrossQuadAlphaBeta S r s * (∏ B ∈ S, (r - B.1)) ^ 4
+      = (W.veluDeficitCrossQuadAlphaBetaConstClearedPoly S).eval r
+        + (W.veluDeficitCrossQuadAlphaBetaSCoeffClearedPoly S).eval r * s := by
+  set D : F := ∏ B ∈ S, (r - B.1) with hD_def
+  have hD : D ≠ 0 := Finset.prod_ne_zero_iff.mpr fun B hB => sub_ne_zero.mpr (hav B hB)
+  have hαS : (W.veluX S r - r) * D ^ 2 = (W.veluXCorrSumPadPoly S).eval r :=
+    hD_def ▸ W.eval_veluXCorrSumPadPoly hav
+  have hβS : (W.veluY S r s - s) * D ^ 3
+      = (W.veluYCorrConstSumPadPoly S).eval r + (W.veluYCorrSCoeffSumPadPoly S).eval r * s :=
+    hD_def ▸ W.veluY_sub_self_mul_prodCube_sDecomp s hav
+  have hαA : ∀ A ∈ S, (W.veluX {A} r - r) * D ^ 2 = (W.veluXCorrPadPoly S A).eval r :=
+    fun A hA => hD_def ▸ W.eval_veluXCorrPadPoly hA hav
+  have hβA : ∀ A ∈ S, (W.veluY {A} r s - s) * D ^ 3
+      = (W.veluYCorrConstPadPoly S A).eval r + (W.veluYCorrSCoeffPadPoly S A).eval r * s :=
+    fun A hA => hD_def ▸ W.veluY_singleton_sub_self_mul_prodCube_sDecomp hA s hav
+  refine mul_left_cancel₀ hD ?_
+  have hLHS : D * (W.veluDeficitCrossQuadAlphaBeta S r s * D ^ 4)
+      = ((W.veluXCorrSumPadPoly S).eval r * (W.veluYCorrConstSumPadPoly S).eval r
+            - ∑ A ∈ S, (W.veluXCorrPadPoly S A).eval r * (W.veluYCorrConstPadPoly S A).eval r)
+        + ((W.veluXCorrSumPadPoly S).eval r * (W.veluYCorrSCoeffSumPadPoly S).eval r
+            - ∑ A ∈ S, (W.veluXCorrPadPoly S A).eval r
+                * (W.veluYCorrSCoeffPadPoly S A).eval r) * s := by
+    have htop : ((W.veluX S r - r) * (W.veluY S r s - s)) * (D ^ 2 * D ^ 3)
+        = (W.veluXCorrSumPadPoly S).eval r * (W.veluYCorrConstSumPadPoly S).eval r
+          + ((W.veluXCorrSumPadPoly S).eval r * (W.veluYCorrSCoeffSumPadPoly S).eval r) * s := by
+      rw [show (W.veluX S r - r) * (W.veluY S r s - s) * (D ^ 2 * D ^ 3)
+          = ((W.veluX S r - r) * D ^ 2) * ((W.veluY S r s - s) * D ^ 3) from by ring,
+        hαS, hβS]; ring
+    have hsum : (∑ A ∈ S, (W.veluX {A} r - r) * (W.veluY {A} r s - s)) * (D ^ 2 * D ^ 3)
+        = (∑ A ∈ S, (W.veluXCorrPadPoly S A).eval r * (W.veluYCorrConstPadPoly S A).eval r)
+          + (∑ A ∈ S, (W.veluXCorrPadPoly S A).eval r
+              * (W.veluYCorrSCoeffPadPoly S A).eval r) * s := by
+      rw [Finset.sum_mul, Finset.sum_mul, ← Finset.sum_add_distrib]
+      refine Finset.sum_congr rfl fun A hA => ?_
+      rw [show (W.veluX {A} r - r) * (W.veluY {A} r s - s) * (D ^ 2 * D ^ 3)
+          = ((W.veluX {A} r - r) * D ^ 2) * ((W.veluY {A} r s - s) * D ^ 3) from by ring,
+        hαA A hA, hβA A hA]; ring
+    unfold veluDeficitCrossQuadAlphaBeta
+    rw [show D * (((W.veluX S r - r) * (W.veluY S r s - s)
+            - ∑ A ∈ S, (W.veluX {A} r - r) * (W.veluY {A} r s - s)) * D ^ 4)
+        = ((W.veluX S r - r) * (W.veluY S r s - s)) * (D ^ 2 * D ^ 3)
+          - (∑ A ∈ S, (W.veluX {A} r - r) * (W.veluY {A} r s - s)) * (D ^ 2 * D ^ 3) from by ring,
+      htop, hsum]; ring
+  rw [hLHS]
+  have hM := congrArg (Polynomial.eval r)
+    (W.veluXCorrSumPadPoly_mul_veluYCorrConstSumPadPoly_sub_sum_eq S)
+  have hN := congrArg (Polynomial.eval r)
+    (W.veluXCorrSumPadPoly_mul_veluYCorrSCoeffSumPadPoly_sub_sum_eq S)
+  simp only [eval_sub, eval_mul, eval_finsetSum, eval_veluKernelDenom, ← hD_def] at hM hN
+  rw [hM, hN]; ring
+
+end AlphaBetaCleared
+
+section DegBound
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+theorem veluXYCorrConstPairPadQuot_natDegree_le {S : Finset (F × F)} {A B : F × F}
+    (hA : A ∈ S) (hB : B ∈ S) (hAB : A ≠ B) :
+    (W.veluXYCorrConstPairPadQuot S A B).natDegree ≤ 4 * S.card - 2 := by
+  have hBA : B ∈ S.erase A := Finset.mem_erase.mpr ⟨hAB.symm, hB⟩
+  have hScard : 2 ≤ S.card := Finset.one_lt_card.mpr ⟨A, hA, B, hB, hAB⟩
+  unfold veluXYCorrConstPairPadQuot
+  calc (W.veluXCorrNumPoly A * W.veluYCorrConstNumPoly B * (X - C A.1) ^ 2 * (X - C B.1)
+          * (∏ E ∈ (S.erase A).erase B, ((X : F[X]) - C E.1)) ^ 4).natDegree
+      ≤ ((1 + 2) + 2 + 1) + 4 * (S.card - 2) := by
+        refine natDegree_mul_le.trans (add_le_add ?_ ?_)
+        · refine natDegree_mul_le.trans (add_le_add ?_ (natDegree_X_sub_C _).le)
+          refine natDegree_mul_le.trans (add_le_add ?_ ?_)
+          · exact natDegree_mul_le.trans (add_le_add (W.veluXCorrNumPoly_natDegree_le A)
+              (W.veluYCorrConstNumPoly_natDegree_le B))
+          · simp [natDegree_pow]
+        · rw [natDegree_pow, natDegree_prod_of_monic _ _ fun _ _ => monic_X_sub_C _]
+          simp only [natDegree_X_sub_C, Finset.sum_const, smul_eq_mul, mul_one,
+            Finset.card_erase_of_mem hBA, Finset.card_erase_of_mem hA]
+          omega
+    _ ≤ 4 * S.card - 2 := by omega
+
+theorem veluDeficitCrossQuadAlphaBetaConstClearedPoly_natDegree_lt {S : Finset (F × F)}
+    (hS : S.Nonempty) :
+    (W.veluDeficitCrossQuadAlphaBetaConstClearedPoly S).natDegree < 4 * S.card := by
+  have hScard : 0 < S.card := Finset.card_pos.mpr hS
+  refine lt_of_le_of_lt (b := 4 * S.card - 1)
+    (natDegree_le_iff_degree_le.mpr ?_) (by omega)
+  refine (degree_sum_le _ _).trans (Finset.sup_le fun A hA => ?_)
+  refine ((degree_sum_le _ _).trans (Finset.sup_le fun B hB => ?_))
+  obtain ⟨hBA, hBS⟩ := Finset.mem_erase.mp hB
+  refine degree_le_natDegree.trans (Nat.cast_le.mpr ?_)
+  exact (W.veluXYCorrConstPairPadQuot_natDegree_le hA hBS hBA.symm).trans (by omega)
+
+end DegBound
+
+end WeierstrassCurve
+
+end
+
+section
+
+noncomputable section
+
+namespace WeierstrassCurve
+section Helper
+
+lemma sq_sum_sub_sum_sq_eq {R : Type*} [CommRing R] {α : Type*} [DecidableEq α]
+    (s : Finset α) (f : α → R) :
+    (∑ A ∈ s, f A) ^ 2 - ∑ A ∈ s, f A ^ 2
+      = ∑ A ∈ s, ∑ B ∈ s.erase A, f A * f B := by
+  have key : ∀ A ∈ s, f A * (∑ B ∈ s, f B)
+      = f A ^ 2 + ∑ B ∈ s.erase A, f A * f B := by
+    intro A hA
+    rw [← Finset.mul_sum, ← Finset.add_sum_erase s f hA, mul_add, sq]
+  rw [sq, Finset.sum_mul, Finset.sum_congr rfl key, Finset.sum_add_distrib, add_sub_cancel_left]
+
+lemma prod_sum_sub_sum_diag_eq' {R : Type*} [CommRing R] {α : Type*} [DecidableEq α]
+    (s : Finset α) (f g : α → R) :
+    (∑ A ∈ s, f A) * (∑ B ∈ s, g B) - ∑ A ∈ s, f A * g A
+      = ∑ A ∈ s, ∑ B ∈ s.erase A, f A * g B := by
+  have key : ∀ A ∈ s, f A * (∑ B ∈ s, g B)
+      = f A * g A + ∑ B ∈ s.erase A, f A * g B := by
+    intro A hA
+    rw [← Finset.mul_sum, ← Finset.add_sum_erase s g hA, mul_add]
+  rw [Finset.sum_mul, Finset.sum_congr rfl key, Finset.sum_add_distrib, add_sub_cancel_left]
+
+end Helper
+
+section BetaSqPairPad
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+def veluYYCorrConstPairPadQuot (S : Finset (F × F)) (A B : F × F) : F[X] :=
+  W.veluYCorrConstNumPoly A * W.veluYCorrConstNumPoly B * (X - C A.1) * (X - C B.1)
+    * (∏ E ∈ (S.erase A).erase B, (X - C E.1)) ^ 4
+
+def veluYYCorrCrossPairPadQuot (S : Finset (F × F)) (A B : F × F) : F[X] :=
+  W.veluYCorrConstNumPoly A * W.veluYCorrSCoeffNumPoly B * (X - C A.1) * (X - C B.1)
+    * (∏ E ∈ (S.erase A).erase B, (X - C E.1)) ^ 4
+
+def veluYYCorrSCoeffPairPadQuot (S : Finset (F × F)) (A B : F × F) : F[X] :=
+  W.veluYCorrSCoeffNumPoly A * W.veluYCorrSCoeffNumPoly B * (X - C A.1) * (X - C B.1)
+    * (∏ E ∈ (S.erase A).erase B, (X - C E.1)) ^ 4
+
+theorem veluYCorrConstPadPoly_mul_eq_kernelDenom_sq_mul {S : Finset (F × F)}
+    {A B : F × F} (hA : A ∈ S) (hB : B ∈ S) (hAB : A ≠ B) :
+    W.veluYCorrConstPadPoly S A * W.veluYCorrConstPadPoly S B
+      = (veluKernelDenom S) ^ 2 * W.veluYYCorrConstPairPadQuot S A B := by
+  have hBA : B ∈ S.erase A := Finset.mem_erase.mpr ⟨hAB.symm, hB⟩
+  have hAB' : A ∈ S.erase B := Finset.mem_erase.mpr ⟨hAB, hA⟩
+  unfold veluYCorrConstPadPoly veluYYCorrConstPairPadQuot veluKernelDenom
+  rw [← Finset.mul_prod_erase (S.erase A) _ hBA,
+      ← Finset.mul_prod_erase (S.erase B) _ hAB',
+      Finset.erase_right_comm (a := B),
+      ← Finset.mul_prod_erase S _ hA,
+      ← Finset.mul_prod_erase (S.erase A) _ hBA]
+  ring
+
+theorem veluYCorrConstPadPoly_mul_veluYCorrSCoeffPadPoly_eq_kernelDenom_sq_mul
+    {S : Finset (F × F)} {A B : F × F} (hA : A ∈ S) (hB : B ∈ S) (hAB : A ≠ B) :
+    W.veluYCorrConstPadPoly S A * W.veluYCorrSCoeffPadPoly S B
+      = (veluKernelDenom S) ^ 2 * W.veluYYCorrCrossPairPadQuot S A B := by
+  have hBA : B ∈ S.erase A := Finset.mem_erase.mpr ⟨hAB.symm, hB⟩
+  have hAB' : A ∈ S.erase B := Finset.mem_erase.mpr ⟨hAB, hA⟩
+  unfold veluYCorrConstPadPoly veluYCorrSCoeffPadPoly veluYYCorrCrossPairPadQuot veluKernelDenom
+  rw [← Finset.mul_prod_erase (S.erase A) _ hBA,
+      ← Finset.mul_prod_erase (S.erase B) _ hAB',
+      Finset.erase_right_comm (a := B),
+      ← Finset.mul_prod_erase S _ hA,
+      ← Finset.mul_prod_erase (S.erase A) _ hBA]
+  ring
+
+theorem veluYCorrSCoeffPadPoly_mul_eq_kernelDenom_sq_mul {S : Finset (F × F)}
+    {A B : F × F} (hA : A ∈ S) (hB : B ∈ S) (hAB : A ≠ B) :
+    W.veluYCorrSCoeffPadPoly S A * W.veluYCorrSCoeffPadPoly S B
+      = (veluKernelDenom S) ^ 2 * W.veluYYCorrSCoeffPairPadQuot S A B := by
+  have hBA : B ∈ S.erase A := Finset.mem_erase.mpr ⟨hAB.symm, hB⟩
+  have hAB' : A ∈ S.erase B := Finset.mem_erase.mpr ⟨hAB, hA⟩
+  unfold veluYCorrSCoeffPadPoly veluYYCorrSCoeffPairPadQuot veluKernelDenom
+  rw [← Finset.mul_prod_erase (S.erase A) _ hBA,
+      ← Finset.mul_prod_erase (S.erase B) _ hAB',
+      Finset.erase_right_comm (a := B),
+      ← Finset.mul_prod_erase S _ hA,
+      ← Finset.mul_prod_erase (S.erase A) _ hBA]
+  ring
+
+end BetaSqPairPad
+
+section BetaSqCleared
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+def veluDeficitCrossQuadBetaSqConstClearedPoly (S : Finset (F × F)) : F[X] :=
+  ∑ A ∈ S, ∑ B ∈ S.erase A, W.veluYYCorrConstPairPadQuot S A B
+
+def veluDeficitCrossQuadBetaSqCrossClearedPoly (S : Finset (F × F)) : F[X] :=
+  ∑ A ∈ S, ∑ B ∈ S.erase A, W.veluYYCorrCrossPairPadQuot S A B
+
+def veluDeficitCrossQuadBetaSqSqClearedPoly (S : Finset (F × F)) : F[X] :=
+  ∑ A ∈ S, ∑ B ∈ S.erase A, W.veluYYCorrSCoeffPairPadQuot S A B
+
+theorem veluYCorrConstSumPadPoly_sq_sub_sum_sq_eq (S : Finset (F × F)) :
+    (W.veluYCorrConstSumPadPoly S) ^ 2 - ∑ A ∈ S, (W.veluYCorrConstPadPoly S A) ^ 2
+      = (veluKernelDenom S) ^ 2 * W.veluDeficitCrossQuadBetaSqConstClearedPoly S := by
+  rw [veluYCorrConstSumPadPoly, veluDeficitCrossQuadBetaSqConstClearedPoly,
+    sq_sum_sub_sum_sq_eq S _, Finset.mul_sum]
+  refine Finset.sum_congr rfl fun A hA => ?_
+  rw [Finset.mul_sum]
+  refine Finset.sum_congr rfl fun B hB => ?_
+  obtain ⟨hBA, hBS⟩ := Finset.mem_erase.mp hB
+  exact W.veluYCorrConstPadPoly_mul_eq_kernelDenom_sq_mul hA hBS hBA.symm
+
+theorem veluYCorrConstSumPadPoly_mul_SCoeffSumPadPoly_sub_sum_eq (S : Finset (F × F)) :
+    W.veluYCorrConstSumPadPoly S * W.veluYCorrSCoeffSumPadPoly S
+        - ∑ A ∈ S, W.veluYCorrConstPadPoly S A * W.veluYCorrSCoeffPadPoly S A
+      = (veluKernelDenom S) ^ 2 * W.veluDeficitCrossQuadBetaSqCrossClearedPoly S := by
+  rw [veluYCorrConstSumPadPoly, veluYCorrSCoeffSumPadPoly,
+    veluDeficitCrossQuadBetaSqCrossClearedPoly, prod_sum_sub_sum_diag_eq' S _ _, Finset.mul_sum]
+  refine Finset.sum_congr rfl fun A hA => ?_
+  rw [Finset.mul_sum]
+  refine Finset.sum_congr rfl fun B hB => ?_
+  obtain ⟨hBA, hBS⟩ := Finset.mem_erase.mp hB
+  exact W.veluYCorrConstPadPoly_mul_veluYCorrSCoeffPadPoly_eq_kernelDenom_sq_mul hA hBS hBA.symm
+
+theorem veluYCorrSCoeffSumPadPoly_sq_sub_sum_sq_eq (S : Finset (F × F)) :
+    (W.veluYCorrSCoeffSumPadPoly S) ^ 2 - ∑ A ∈ S, (W.veluYCorrSCoeffPadPoly S A) ^ 2
+      = (veluKernelDenom S) ^ 2 * W.veluDeficitCrossQuadBetaSqSqClearedPoly S := by
+  rw [veluYCorrSCoeffSumPadPoly, veluDeficitCrossQuadBetaSqSqClearedPoly,
+    sq_sum_sub_sum_sq_eq S _, Finset.mul_sum]
+  refine Finset.sum_congr rfl fun A hA => ?_
+  rw [Finset.mul_sum]
+  refine Finset.sum_congr rfl fun B hB => ?_
+  obtain ⟨hBA, hBS⟩ := Finset.mem_erase.mp hB
+  exact W.veluYCorrSCoeffPadPoly_mul_eq_kernelDenom_sq_mul hA hBS hBA.symm
+
+theorem veluDeficitCrossQuadBetaSq_mul_prodPow_sQuadDecomp {S : Finset (F × F)} {r : F} (s : F)
+    (hav : ∀ B ∈ S, r ≠ B.1) :
+    W.veluDeficitCrossQuadBetaSq S r s * (∏ B ∈ S, (r - B.1)) ^ 4
+      = (W.veluDeficitCrossQuadBetaSqConstClearedPoly S).eval r
+        + 2 * (W.veluDeficitCrossQuadBetaSqCrossClearedPoly S).eval r * s
+        + (W.veluDeficitCrossQuadBetaSqSqClearedPoly S).eval r * s ^ 2 := by
+  set D : F := ∏ B ∈ S, (r - B.1) with hD_def
+  have hD : D ≠ 0 := Finset.prod_ne_zero_iff.mpr fun B hB => sub_ne_zero.mpr (hav B hB)
+  have hβS : (W.veluY S r s - s) * D ^ 3
+      = (W.veluYCorrConstSumPadPoly S).eval r + (W.veluYCorrSCoeffSumPadPoly S).eval r * s :=
+    hD_def ▸ W.veluY_sub_self_mul_prodCube_sDecomp s hav
+  have hβA : ∀ A ∈ S, (W.veluY {A} r s - s) * D ^ 3
+      = (W.veluYCorrConstPadPoly S A).eval r + (W.veluYCorrSCoeffPadPoly S A).eval r * s :=
+    fun A hA => hD_def ▸ W.veluY_singleton_sub_self_mul_prodCube_sDecomp hA s hav
+  refine mul_left_cancel₀ (pow_ne_zero 2 hD) ?_
+  have hLHS : D ^ 2 * (W.veluDeficitCrossQuadBetaSq S r s * D ^ 4)
+      = ((W.veluYCorrConstSumPadPoly S).eval r ^ 2
+            - ∑ A ∈ S, (W.veluYCorrConstPadPoly S A).eval r ^ 2)
+        + 2 * ((W.veluYCorrConstSumPadPoly S).eval r * (W.veluYCorrSCoeffSumPadPoly S).eval r
+            - ∑ A ∈ S, (W.veluYCorrConstPadPoly S A).eval r
+                * (W.veluYCorrSCoeffPadPoly S A).eval r) * s
+        + ((W.veluYCorrSCoeffSumPadPoly S).eval r ^ 2
+            - ∑ A ∈ S, (W.veluYCorrSCoeffPadPoly S A).eval r ^ 2) * s ^ 2 := by
+    have htop : ((W.veluY S r s - s) * D ^ 3) ^ 2
+        = (W.veluYCorrConstSumPadPoly S).eval r ^ 2
+          + 2 * ((W.veluYCorrConstSumPadPoly S).eval r
+              * (W.veluYCorrSCoeffSumPadPoly S).eval r) * s
+          + (W.veluYCorrSCoeffSumPadPoly S).eval r ^ 2 * s ^ 2 := by
+      rw [hβS]; ring
+    have hsum : ∑ A ∈ S, ((W.veluY {A} r s - s) * D ^ 3) ^ 2
+        = (∑ A ∈ S, (W.veluYCorrConstPadPoly S A).eval r ^ 2)
+          + 2 * (∑ A ∈ S, (W.veluYCorrConstPadPoly S A).eval r
+              * (W.veluYCorrSCoeffPadPoly S A).eval r) * s
+          + (∑ A ∈ S, (W.veluYCorrSCoeffPadPoly S A).eval r ^ 2) * s ^ 2 := by
+      rw [Finset.mul_sum, Finset.sum_mul, Finset.sum_mul,
+        ← Finset.sum_add_distrib, ← Finset.sum_add_distrib]
+      exact Finset.sum_congr rfl fun A hA => by rw [hβA A hA]; ring
+    unfold veluDeficitCrossQuadBetaSq
+    have hreorg : D ^ 2 * (((W.veluY S r s - s) ^ 2
+            - ∑ A ∈ S, (W.veluY {A} r s - s) ^ 2) * D ^ 4)
+        = ((W.veluY S r s - s) * D ^ 3) ^ 2
+          - ∑ A ∈ S, ((W.veluY {A} r s - s) * D ^ 3) ^ 2 := by
+      simp only [mul_pow, ← Finset.sum_mul]; ring
+    rw [hreorg, htop, hsum]; ring
+  rw [hLHS]
+  have hM00 := congrArg (Polynomial.eval r) (W.veluYCorrConstSumPadPoly_sq_sub_sum_sq_eq S)
+  have hM01 := congrArg (Polynomial.eval r)
+    (W.veluYCorrConstSumPadPoly_mul_SCoeffSumPadPoly_sub_sum_eq S)
+  have hM11 := congrArg (Polynomial.eval r) (W.veluYCorrSCoeffSumPadPoly_sq_sub_sum_sq_eq S)
+  simp only [eval_sub, eval_mul, eval_pow, eval_finsetSum, eval_veluKernelDenom,
+    ← hD_def] at hM00 hM01 hM11
+  rw [hM00, hM01, hM11]; ring
+
+end BetaSqCleared
+
+section S2Reduction
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+omit [DecidableEq F] in
+def veluWeierstrassCubicPoly : F[X] := X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆
+
+omit [DecidableEq F] in
+lemma veluWeierstrassCubicPoly_natDegree_le : W.veluWeierstrassCubicPoly.natDegree ≤ 3 := by
+  unfold veluWeierstrassCubicPoly; compute_degree
+
+omit [DecidableEq F] in
+theorem sq_eq_veluWeierstrassCubicPoly_sub_of_equation {r s : F} (hrs : W.toAffine.Equation r s) :
+    s ^ 2 = W.veluWeierstrassCubicPoly.eval r - (W.a₁ * r + W.a₃) * s := by
+  have heq := (Affine.equation_iff r s).mp hrs
+  simp only [veluWeierstrassCubicPoly, eval_add, eval_mul, eval_pow, eval_X, eval_C]
+  linear_combination heq
+
+def veluDeficitCrossQuadBetaSqConstS2ClearedPoly (S : Finset (F × F)) : F[X] :=
+  W.veluDeficitCrossQuadBetaSqConstClearedPoly S
+    + W.veluWeierstrassCubicPoly * W.veluDeficitCrossQuadBetaSqSqClearedPoly S
+
+def veluDeficitCrossQuadBetaSqSCoeffS2ClearedPoly (S : Finset (F × F)) : F[X] :=
+  2 * W.veluDeficitCrossQuadBetaSqCrossClearedPoly S
+    - (C W.a₁ * X + C W.a₃) * W.veluDeficitCrossQuadBetaSqSqClearedPoly S
+
+theorem veluDeficitCrossQuadBetaSq_mul_prodPow_sDecomp {S : Finset (F × F)} {r s : F}
+    (hrs : W.toAffine.Equation r s) (hav : ∀ B ∈ S, r ≠ B.1) :
+    W.veluDeficitCrossQuadBetaSq S r s * (∏ B ∈ S, (r - B.1)) ^ 4
+      = (W.veluDeficitCrossQuadBetaSqConstS2ClearedPoly S).eval r
+        + (W.veluDeficitCrossQuadBetaSqSCoeffS2ClearedPoly S).eval r * s := by
+  rw [W.veluDeficitCrossQuadBetaSq_mul_prodPow_sQuadDecomp s hav,
+    W.sq_eq_veluWeierstrassCubicPoly_sub_of_equation hrs,
+    veluDeficitCrossQuadBetaSqConstS2ClearedPoly, veluDeficitCrossQuadBetaSqSCoeffS2ClearedPoly]
+  simp only [eval_add, eval_mul, eval_sub, eval_ofNat, eval_C, eval_X]
+  ring
+
+end S2Reduction
+
+section DegBound
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+theorem veluYYCorrConstPairPadQuot_natDegree_le {S : Finset (F × F)} {A B : F × F}
+    (hA : A ∈ S) (hB : B ∈ S) (hAB : A ≠ B) :
+    (W.veluYYCorrConstPairPadQuot S A B).natDegree ≤ 4 * S.card - 2 := by
+  have hBA : B ∈ S.erase A := Finset.mem_erase.mpr ⟨hAB.symm, hB⟩
+  have hScard : 2 ≤ S.card := Finset.one_lt_card.mpr ⟨A, hA, B, hB, hAB⟩
+  unfold veluYYCorrConstPairPadQuot
+  calc (W.veluYCorrConstNumPoly A * W.veluYCorrConstNumPoly B * (X - C A.1) * (X - C B.1)
+          * (∏ E ∈ (S.erase A).erase B, ((X : F[X]) - C E.1)) ^ 4).natDegree
+      ≤ ((2 + 2) + 1 + 1) + 4 * (S.card - 2) := by
+        refine natDegree_mul_le.trans (add_le_add ?_ ?_)
+        · refine natDegree_mul_le.trans (add_le_add ?_ (natDegree_X_sub_C _).le)
+          refine natDegree_mul_le.trans (add_le_add ?_ (natDegree_X_sub_C _).le)
+          exact natDegree_mul_le.trans (add_le_add (W.veluYCorrConstNumPoly_natDegree_le A)
+            (W.veluYCorrConstNumPoly_natDegree_le B))
+        · rw [natDegree_pow, natDegree_prod_of_monic _ _ fun _ _ => monic_X_sub_C _]
+          simp only [natDegree_X_sub_C, Finset.sum_const, smul_eq_mul, mul_one,
+            Finset.card_erase_of_mem hBA, Finset.card_erase_of_mem hA]
+          omega
+    _ ≤ 4 * S.card - 2 := by omega
+
+theorem veluYYCorrSCoeffPairPadQuot_natDegree_le {S : Finset (F × F)} {A B : F × F}
+    (hA : A ∈ S) (hB : B ∈ S) (hAB : A ≠ B) :
+    (W.veluYYCorrSCoeffPairPadQuot S A B).natDegree ≤ 4 * S.card - 4 := by
+  have hBA : B ∈ S.erase A := Finset.mem_erase.mpr ⟨hAB.symm, hB⟩
+  have hScard : 2 ≤ S.card := Finset.one_lt_card.mpr ⟨A, hA, B, hB, hAB⟩
+  unfold veluYYCorrSCoeffPairPadQuot
+  calc (W.veluYCorrSCoeffNumPoly A * W.veluYCorrSCoeffNumPoly B * (X - C A.1) * (X - C B.1)
+          * (∏ E ∈ (S.erase A).erase B, ((X : F[X]) - C E.1)) ^ 4).natDegree
+      ≤ ((1 + 1) + 1 + 1) + 4 * (S.card - 2) := by
+        refine natDegree_mul_le.trans (add_le_add ?_ ?_)
+        · refine natDegree_mul_le.trans (add_le_add ?_ (natDegree_X_sub_C _).le)
+          refine natDegree_mul_le.trans (add_le_add ?_ (natDegree_X_sub_C _).le)
+          exact natDegree_mul_le.trans (add_le_add (W.veluYCorrSCoeffNumPoly_natDegree_le A)
+            (W.veluYCorrSCoeffNumPoly_natDegree_le B))
+        · rw [natDegree_pow, natDegree_prod_of_monic _ _ fun _ _ => monic_X_sub_C _]
+          simp only [natDegree_X_sub_C, Finset.sum_const, smul_eq_mul, mul_one,
+            Finset.card_erase_of_mem hBA, Finset.card_erase_of_mem hA]
+          omega
+    _ ≤ 4 * S.card - 4 := by omega
+
+theorem veluDeficitCrossQuadBetaSqConstClearedPoly_natDegree_le (S : Finset (F × F)) :
+    (W.veluDeficitCrossQuadBetaSqConstClearedPoly S).natDegree ≤ 4 * S.card - 2 := by
+  refine natDegree_le_iff_degree_le.mpr ((degree_sum_le _ _).trans (Finset.sup_le fun A hA => ?_))
+  refine ((degree_sum_le _ _).trans (Finset.sup_le fun B hB => ?_))
+  obtain ⟨hBA, hBS⟩ := Finset.mem_erase.mp hB
+  exact degree_le_natDegree.trans
+    (Nat.cast_le.mpr (W.veluYYCorrConstPairPadQuot_natDegree_le hA hBS hBA.symm))
+
+theorem veluDeficitCrossQuadBetaSqSqClearedPoly_natDegree_le (S : Finset (F × F)) :
+    (W.veluDeficitCrossQuadBetaSqSqClearedPoly S).natDegree ≤ 4 * S.card - 4 := by
+  refine natDegree_le_iff_degree_le.mpr ((degree_sum_le _ _).trans (Finset.sup_le fun A hA => ?_))
+  refine ((degree_sum_le _ _).trans (Finset.sup_le fun B hB => ?_))
+  obtain ⟨hBA, hBS⟩ := Finset.mem_erase.mp hB
+  exact degree_le_natDegree.trans
+    (Nat.cast_le.mpr (W.veluYYCorrSCoeffPairPadQuot_natDegree_le hA hBS hBA.symm))
+
+theorem veluDeficitCrossQuadBetaSqConstS2ClearedPoly_natDegree_lt {S : Finset (F × F)}
+    (hS : S.Nonempty) :
+    (W.veluDeficitCrossQuadBetaSqConstS2ClearedPoly S).natDegree < 4 * S.card := by
+  have hScard : 0 < S.card := Finset.card_pos.mpr hS
+  refine lt_of_le_of_lt (b := 4 * S.card - 1) ?_ (by omega)
+  refine (natDegree_add_le _ _).trans (max_le ?_ ?_)
+  · exact (W.veluDeficitCrossQuadBetaSqConstClearedPoly_natDegree_le S).trans (by omega)
+  · refine natDegree_mul_le.trans ?_
+    have h₁ := W.veluWeierstrassCubicPoly_natDegree_le
+    have h₂ := W.veluDeficitCrossQuadBetaSqSqClearedPoly_natDegree_le S
+    omega
+
+end DegBound
+
+end WeierstrassCurve
+
+end
+
+
+noncomputable section
+
+namespace WeierstrassCurve
+universe u
+
+variable {F : Type u} [Field F]
+
+section CoordsAPI
+
+variable {k : Type*} [Field k] (f : F →+* k) {W : WeierstrassCurve F}
+
+theorem coordsOrZero_ratPointMap (P : W.toAffine.Point) :
+    (ratPointMap f P).coordsOrZero = (f P.coordsOrZero.1, f P.coordsOrZero.2) := by
+  rcases P with _ | ⟨x, y, h⟩
+  · change ((0, 0) : k × k) = (f 0, f 0); rw [_root_.map_zero]
+  · rfl
+
+end CoordsAPI
+
+section SummingSetCompat
+
+variable [DecidableEq F] (W : Affine F)
+
+local notation "ι" => algebraMap F W.FunctionField
+
+variable [DecidableEq W.FunctionField]
+
+theorem liftSummingSet_oddOrderSummingSet (Q : W.toAffine.Point) (n : ℕ) :
+    W.liftSummingSet (W.oddOrderSummingSet Q n)
+      = (W.map ι).oddOrderSummingSet (ratPointHom (W₀ := W) ι Q) n := by
+  refine Finset.ext fun A => ?_
+  simp only [liftSummingSet, oddOrderSummingSet, Finset.mem_map, Finset.mem_image,
+    Finset.mem_Icc, Function.Embedding.coeFn_mk]
+  constructor
+  · rintro ⟨_, ⟨k, hk, rfl⟩, rfl⟩
+    exact ⟨k, hk, by
+      rw [← map_nsmul, ratPointHom_apply, coordsOrZero_ratPointMap]; rfl⟩
+  · rintro ⟨k, hk, hkA⟩
+    exact ⟨(k • Q).coordsOrZero, ⟨k, hk, rfl⟩, by
+      rw [← hkA, ← map_nsmul, ratPointHom_apply, coordsOrZero_ratPointMap]; rfl⟩
+
+end SummingSetCompat
+
+section GenericNotInRange
+
+variable [DecidableEq F] {W : Affine F} (hΔ : W.Δ ≠ 0)
+
+local notation "ι" => algebraMap F W.FunctionField
+
+variable [DecidableEq W.FunctionField]
+
+theorem genericPoint'_notMem_range_ratPointHom :
+    Affine.genericPoint' hΔ ∉ (ratPointHom (W₀ := W) ι).range := by
+  rintro ⟨P, hP⟩
+  rcases P with _ | ⟨c, d, h⟩
+  · exact genericPoint'_ne_zero hΔ hP.symm
+  · exact genericPoint'_ne_some_algebraMap hΔ c d _ hP.symm
+
+theorem genericPoint'_notMem_zmultiples_ratPointHom (Q : W.toAffine.Point) :
+    Affine.genericPoint' hΔ ∉ AddSubgroup.zmultiples (ratPointHom (W₀ := W) ι Q) := by
+  intro hmem
+  obtain ⟨n, hn⟩ := AddSubgroup.mem_zmultiples_iff.mp hmem
+  refine genericPoint'_notMem_range_ratPointHom hΔ ⟨n • Q, ?_⟩
+  rw [map_zsmul, hn]
+
+end GenericNotInRange
+
+end WeierstrassCurve
+
+end
+
+
+noncomputable section
+
+namespace WeierstrassCurve
+lemma kw_vdcoog_some_congr {R : Type*} [CommRing R] {V : Affine R} {x₁ x₂ y₁ y₂ : R}
+    (hx : x₁ = x₂) (hy : y₁ = y₂) (h₁ : V.Nonsingular x₁ y₁) (h₂ : V.Nonsingular x₂ y₂) :
+    (Affine.Point.some x₁ y₁ h₁ : V.Point) = Affine.Point.some x₂ y₂ h₂ := by
+  subst hx hy; rfl
+
+theorem kw_not_dvd_of_le_half_odd {p k : ℕ} (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hk1 : 1 ≤ k) (hkn : k ≤ (p - 1) / 2) : ¬ p ∣ k ∧ ¬ p ∣ 2 * k := by
+  have hodd : p % 2 = 1 := Nat.odd_iff.mp hpodd
+  have hhalf : 2 * ((p - 1) / 2) = p - 1 := by omega
+  exact ⟨Nat.not_dvd_of_pos_of_lt (by omega) (by omega),
+    Nat.not_dvd_of_pos_of_lt (by omega) (by omega)⟩
+
+theorem kw_not_dvd_add_of_le_half_odd {p k k' : ℕ} (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hk1 : 1 ≤ k) (hkn : k ≤ (p - 1) / 2) (hk'1 : 1 ≤ k') (hk'n : k' ≤ (p - 1) / 2) :
+    ¬ p ∣ k + k' := by
+  have hodd : p % 2 = 1 := Nat.odd_iff.mp hpodd
+  have hhalf : 2 * ((p - 1) / 2) = p - 1 := by omega
+  exact Nat.not_dvd_of_pos_of_lt (by omega) (by omega)
+
+section AbstractCofixed
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F}
+variable {Q : W.toAffine.Point} {p : ℕ}
+
+theorem kw_exists_nsmul_of_mem_oddOrderSummingSet_odd (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {n : ℕ} (hn : n ≤ (p - 1) / 2) {P : F × F}
+    (hP : P ∈ W.oddOrderSummingSet Q n) :
+    ∃ (k : ℕ) (x y : F) (h : W.toAffine.Nonsingular x y), 1 ≤ k ∧ k ≤ n ∧
+      k • Q = Point.some x y h ∧ P = (x, y) ∧ (2 * k) • Q ≠ 0 := by
+  obtain ⟨k, hk1, hkn, hkP⟩ := W.mem_oddOrderSummingSet.mp hP
+  obtain ⟨hndvd, hndvd2⟩ := kw_not_dvd_of_le_half_odd hp3 hpodd hk1 (hkn.trans hn)
+  have hne : k • Q ≠ 0 := nsmul_ne_zero_of_addOrderOf_eq_of_not_dvd hord hndvd
+  obtain ⟨x, y, h, heq, hcoords⟩ := exists_some_of_ne_zero hne
+  exact ⟨k, x, y, h, hk1, hkn, heq, by rw [← hkP, hcoords],
+    nsmul_ne_zero_of_addOrderOf_eq_of_not_dvd hord hndvd2⟩
+
+theorem kw_nsmul_eq_of_xOrZero_eq_odd (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {k k' : ℕ} (hk1 : 1 ≤ k) (hkn : k ≤ (p - 1) / 2)
+    (hk'1 : 1 ≤ k') (hk'n : k' ≤ (p - 1) / 2)
+    {x y : F} {h : W.toAffine.Nonsingular x y} (heq : k • Q = Point.some x y h)
+    {x' y' : F} {h' : W.toAffine.Nonsingular x' y'} (heq' : k' • Q = Point.some x' y' h')
+    (hx : x = x') : k • Q = k' • Q := by
+  rcases (Point.X_eq_iff (h₁ := h) (h₂ := h')).mp hx with hPP | hPP
+  · rw [heq, heq', hPP]
+  · exfalso
+    have hsum : (k + k') • Q = 0 := by rw [add_nsmul, heq, heq', hPP, _root_.neg_add_cancel]
+    exact kw_not_dvd_add_of_le_half_odd hp3 hpodd hk1 hkn hk'1 hk'n
+      (hord ▸ addOrderOf_dvd_iff_nsmul_eq_zero.mpr hsum)
+
+theorem kw_nsmul_injOn_odd (hp3 : 3 ≤ p) (hord : addOrderOf Q = p) {k k' : ℕ}
+    (hk1 : 1 ≤ k) (hkn : k ≤ (p - 1) / 2) (hk'1 : 1 ≤ k') (hk'n : k' ≤ (p - 1) / 2)
+    (heq : k • Q = k' • Q) : k = k' := by
+  have hhalf : (p - 1) / 2 ≤ p - 1 := Nat.div_le_self _ _
+  wlog hle : k ≤ k' generalizing k k'
+  · exact (this hk'1 hk'n hk1 hkn heq.symm (by omega)).symm
+  have hsub : (k' - k) • Q = 0 := by
+    have : (k' - k) • Q + k • Q = k • Q := by
+      rw [← add_nsmul, Nat.sub_add_cancel hle, heq]
+    exact add_right_cancel (this.trans (zero_add _).symm)
+  have hdvd : p ∣ k' - k := hord ▸ addOrderOf_dvd_iff_nsmul_eq_zero.mpr hsub
+  rcases Nat.eq_zero_or_pos (k' - k) with h0 | h0
+  · omega
+  · exact absurd hdvd (Nat.not_dvd_of_pos_of_lt h0 (by omega))
+
+public theorem kw_isOddVeluSet_oddOrderSummingSet_odd (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {n : ℕ} (hn : n ≤ (p - 1) / 2) :
+    W.IsOddVeluSet (W.oddOrderSummingSet Q n) where
+  equation P hP := by
+    obtain ⟨_, _, _, h, _, _, _, hPxy, _⟩ :=
+      kw_exists_nsmul_of_mem_oddOrderSummingSet_odd hp3 hpodd hord hn hP
+    rw [hPxy]; exact h.left
+  gy_ne_zero P hP := by
+    obtain ⟨k, x, y, h, _, _, heq, hPxy, h2k⟩ :=
+      kw_exists_nsmul_of_mem_oddOrderSummingSet_odd hp3 hpodd hord hn hP
+    rw [hPxy]
+    exact veluGy_ne_zero_of_two_nsmul_ne_zero h fun h2 => h2k (by
+      rw [two_mul, add_nsmul, heq, ← two_nsmul, h2])
+  x_injOn P hP P' hP' hx := by
+    obtain ⟨k, x, y, h, hk1, hkn, heq, hPxy, _⟩ :=
+      kw_exists_nsmul_of_mem_oddOrderSummingSet_odd hp3 hpodd hord hn hP
+    obtain ⟨k', x', y', h', hk'1, hk'n, heq', hP'xy, _⟩ :=
+      kw_exists_nsmul_of_mem_oddOrderSummingSet_odd hp3 hpodd hord hn hP'
+    subst hPxy; subst hP'xy
+    have hQQ' := kw_nsmul_eq_of_xOrZero_eq_odd hp3 hpodd hord hk1 (hkn.trans hn)
+      hk'1 (hk'n.trans hn) heq heq' hx
+    exact congrArg Point.coordsOrZero (heq ▸ heq' ▸ hQQ')
+
+theorem kw_card_oddOrderSummingSet_odd (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {n : ℕ} (hn : n ≤ (p - 1) / 2) :
+    (W.oddOrderSummingSet Q n).card = n := by
+  have hinj : Set.InjOn (fun k : ℕ => (k • Q).coordsOrZero) (Finset.Icc 1 n : Finset ℕ) := by
+    intro k hk k' hk' hcoords
+    simp only [Finset.coe_Icc, Set.mem_Icc] at hk hk'
+    obtain ⟨hndvd, _⟩ := kw_not_dvd_of_le_half_odd hp3 hpodd hk.1 (hk.2.trans hn)
+    obtain ⟨hndvd', _⟩ := kw_not_dvd_of_le_half_odd hp3 hpodd hk'.1 (hk'.2.trans hn)
+    obtain ⟨x, y, h, heq, hc⟩ :=
+      exists_some_of_ne_zero (nsmul_ne_zero_of_addOrderOf_eq_of_not_dvd hord hndvd (k := k))
+    obtain ⟨x', y', h', heq', hc'⟩ :=
+      exists_some_of_ne_zero (nsmul_ne_zero_of_addOrderOf_eq_of_not_dvd hord hndvd' (k := k'))
+    have hx : x = x' :=
+      congrArg Prod.fst (show ((x, y) : F × F) = (x', y') from hc ▸ hc' ▸ hcoords)
+    exact kw_nsmul_injOn_odd hp3 hord hk.1 (hk.2.trans hn) hk'.1 (hk'.2.trans hn)
+      (kw_nsmul_eq_of_xOrZero_eq_odd hp3 hpodd hord hk.1 (hk.2.trans hn) hk'.1
+        (hk'.2.trans hn) heq heq' hx)
+  rw [oddOrderSummingSet, Finset.card_image_of_injOn hinj, Nat.card_Icc, Nat.add_sub_cancel]
+
+end AbstractCofixed
+
+section OrdNonneg
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F}
+variable {Q : W.toAffine.Point} {p : ℕ}
+
+theorem kw_veluX_oddOrderSummingSet_eq_sum_Icc_odd (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {x y : F} (hP : W.toAffine.Nonsingular x y)
+    (hPmem : (Point.some x y hP : W.toAffine.Point) ∉ AddSubgroup.zmultiples Q) :
+    W.veluX (W.oddOrderSummingSet Q ((p - 1) / 2)) x
+      = x + ∑ k ∈ Finset.Icc 1 ((p - 1) / 2),
+          ((Point.some x y hP + k • Q : W.toAffine.Point).xOrZero
+            + (Point.some x y hP + -(k • Q) : W.toAffine.Point).xOrZero
+            - 2 * (k • Q).xOrZero) := by
+  set d := (p - 1) / 2
+  have hSset := kw_isOddVeluSet_oddOrderSummingSet_odd (W := W) hp3 hpodd hord (le_refl d)
+  have hx : ∀ A ∈ W.oddOrderSummingSet Q d, x ≠ A.1 := by
+    intro A hA
+    obtain ⟨k, a, b, h, _, _, heq, hAeq, _⟩ :=
+      kw_exists_nsmul_of_mem_oddOrderSummingSet_odd hp3 hpodd hord le_rfl hA
+    subst hAeq
+    exact xOrZero_ne_of_not_mem_zmultiples hPmem
+      (fun h0 => hPmem (h0 ▸ AddSubgroup.zero_mem _))
+      (heq ▸ AddSubgroup.nsmul_mem _ (AddSubgroup.mem_zmultiples Q) k)
+  rw [W.veluX_eq_orbitSum hP.1 hSset.equation hx]
+  congr 1
+  have hcard := kw_card_oddOrderSummingSet_odd (W := W) hp3 hpodd hord (le_refl d)
+  have hIcc : (Finset.Icc 1 d).card = d := by rw [Nat.card_Icc]; omega
+  have hinj : Set.InjOn (fun k : ℕ => (k • Q).coordsOrZero) (Finset.Icc 1 d) := by
+    rw [← Finset.card_image_iff]; exact hcard.trans hIcc.symm
+  change ∑ A ∈ W.oddOrderSummingSet Q d, _ = _
+  rw [oddOrderSummingSet, Finset.sum_image (fun a ha b hb => hinj ha hb)]
+  refine Finset.sum_congr rfl fun k hk => ?_
+  rw [Finset.mem_Icc] at hk
+  obtain ⟨hndvd, _⟩ := kw_not_dvd_of_le_half_odd hp3 hpodd hk.1 hk.2
+  obtain ⟨a, b, hab, hkQeq, hkQc⟩ :=
+    exists_some_of_ne_zero (nsmul_ne_zero_of_addOrderOf_eq_of_not_dvd hord hndvd)
+  rw [hkQc]; dsimp only
+  have hxk : x ≠ a := xOrZero_ne_of_not_mem_zmultiples hPmem
+    (fun h0 => hPmem (h0 ▸ AddSubgroup.zero_mem _))
+    (hkQeq ▸ AddSubgroup.nsmul_mem _ (AddSubgroup.mem_zmultiples Q) k)
+  have hPkQ : (Point.some x y hP + k • Q : W.toAffine.Point).xOrZero
+      = W.toAffine.addX x a (W.toAffine.slope x a y b) := by
+    rw [hkQeq, Point.add_of_X_ne hxk, Point.xOrZero_some]
+  have hnegkQ : -(k • Q) =
+      Point.some a (W.toAffine.negY a b) ((Affine.nonsingular_neg ..).mpr hab) := by
+    rw [hkQeq]; rfl
+  have hPmkQ : (Point.some x y hP + -(k • Q) : W.toAffine.Point).xOrZero
+      = W.toAffine.addX x a (W.toAffine.slope x a y (W.toAffine.negY a b)) := by
+    rw [hnegkQ, Point.add_of_X_ne hxk, Point.xOrZero_some]
+  rw [hPkQ, hPmkQ, show (k • Q).xOrZero = a from by rw [hkQeq, Point.xOrZero_some]]
+
+theorem kw_veluX_oddOrderSummingSet_eq_sum_range_odd (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {x y : F} (hP : W.toAffine.Nonsingular x y)
+    (hPmem : (Point.some x y hP : W.toAffine.Point) ∉ AddSubgroup.zmultiples Q) :
+    W.veluX (W.oddOrderSummingSet Q ((p - 1) / 2)) x
+      = (∑ j ∈ Finset.range p, (Point.some x y hP + j • Q : W.toAffine.Point).xOrZero)
+        - 2 * ∑ k ∈ Finset.Icc 1 ((p - 1) / 2), (k • Q).xOrZero := by
+  have hodd : p % 2 = 1 := Nat.odd_iff.mp hpodd
+  rw [kw_veluX_oddOrderSummingSet_eq_sum_Icc_odd hp3 hpodd hord hP hPmem]
+  obtain ⟨d, hpeq, hd_def⟩ : ∃ d, p = 2 * d + 1 ∧ d = (p - 1) / 2 := ⟨(p - 1) / 2, by omega, rfl⟩
+  rw [← hd_def, Finset.sum_sub_distrib, Finset.sum_add_distrib, ← Finset.mul_sum,
+    show ∀ a b c : F, a + (b - c) = a + b - c from fun a b c => (add_sub_assoc a b c).symm]
+  congr 1
+  have hsplit : Finset.range p = {0} ∪ Finset.Icc 1 d ∪ Finset.Icc (d + 1) (p - 1) := by
+    ext j; simp only [Finset.mem_range, Finset.mem_union, Finset.mem_singleton, Finset.mem_Icc]
+    omega
+  have hdisj1 : Disjoint ({0} : Finset ℕ) (Finset.Icc 1 d) := by
+    rw [Finset.disjoint_left]; intro a ha hb
+    rw [Finset.mem_singleton] at ha; rw [Finset.mem_Icc] at hb; omega
+  have hdisj2 : Disjoint (({0} : Finset ℕ) ∪ Finset.Icc 1 d) (Finset.Icc (d + 1) (p - 1)) := by
+    rw [Finset.disjoint_left]; intro a ha hb
+    rw [Finset.mem_union, Finset.mem_singleton, Finset.mem_Icc] at ha
+    rw [Finset.mem_Icc] at hb; omega
+  rw [hsplit, Finset.sum_union hdisj2, Finset.sum_union hdisj1, Finset.sum_singleton,
+    zero_nsmul, add_zero, Point.xOrZero_some]
+  clear hd_def
+  have hrefl : ∑ j ∈ Finset.Icc (d + 1) (p - 1),
+        (Point.some x y hP + j • Q : W.toAffine.Point).xOrZero
+      = ∑ k ∈ Finset.Icc 1 d,
+        (Point.some x y hP + -(k • Q) : W.toAffine.Point).xOrZero := by
+    refine Finset.sum_nbij' (fun j => p - j) (fun k => p - k)
+      (fun j hj => by rw [Finset.mem_Icc] at hj; simp only [Finset.mem_Icc]; omega)
+      (fun k hk => by rw [Finset.mem_Icc] at hk; simp only [Finset.mem_Icc]; omega)
+      (fun j hj => by rw [Finset.mem_Icc] at hj; omega)
+      (fun k hk => by rw [Finset.mem_Icc] at hk; omega)
+      (fun j hj => ?_)
+    rw [Finset.mem_Icc] at hj
+    congr 2
+    have hpQ : p • Q = 0 := hord ▸ addOrderOf_nsmul_eq_zero Q
+    rw [← sub_nsmul_eq_neg_of_nsmul_eq_zero hpQ (k := p - j) (Nat.sub_le _ _)]
+    congr 1; omega
+  rw [hrefl]; ring
+
+theorem kw_veluX_xOrZero_add_gen_odd (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {P : W.toAffine.Point}
+    (hPmem : P ∉ AddSubgroup.zmultiples Q) :
+    W.veluX (W.oddOrderSummingSet Q ((p - 1) / 2)) (P + Q).xOrZero
+      = W.veluX (W.oddOrderSummingSet Q ((p - 1) / 2)) P.xOrZero := by
+  have hQmem : Q ∈ AddSubgroup.zmultiples Q := AddSubgroup.mem_zmultiples Q
+  have hP0 : P ≠ 0 := fun h => hPmem (h ▸ AddSubgroup.zero_mem _)
+  obtain ⟨x, y, hns, rfl, -⟩ := exists_some_of_ne_zero hP0
+  have hPQmem := not_mem_zmultiples_add hPmem hQmem
+  have hPQ0 : (Point.some x y hns + Q : W.toAffine.Point) ≠ 0 :=
+    add_ne_zero_of_not_mem_zmultiples hPmem hQmem
+  obtain ⟨x', y', hns', heqPQ, -⟩ := exists_some_of_ne_zero hPQ0
+  rw [heqPQ, Point.xOrZero_some, Point.xOrZero_some,
+    kw_veluX_oddOrderSummingSet_eq_sum_range_odd hp3 hpodd hord hns' (heqPQ ▸ hPQmem),
+    kw_veluX_oddOrderSummingSet_eq_sum_range_odd hp3 hpodd hord hns hPmem]
+  congr 1
+  calc ∑ j ∈ Finset.range p, (Point.some x' y' hns' + j • Q : W.toAffine.Point).xOrZero
+      = ∑ j ∈ Finset.range p,
+          ((Point.some x y hns + Q : W.toAffine.Point) + j • Q).xOrZero :=
+        Finset.sum_congr rfl fun j _ => by rw [← heqPQ]
+    _ = ∑ j ∈ Finset.range p, (Point.some x y hns + j • Q : W.toAffine.Point).xOrZero :=
+        sum_range_addOrderOf_shift_invariant hord _ _
+
+theorem kw_veluY_oddOrderSummingSet_eq_sum_Icc_odd (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {x y : F} (hP : W.toAffine.Nonsingular x y)
+    (hPmem : (Point.some x y hP : W.toAffine.Point) ∉ AddSubgroup.zmultiples Q) :
+    W.veluY (W.oddOrderSummingSet Q ((p - 1) / 2)) x y
+      = y + ∑ k ∈ Finset.Icc 1 ((p - 1) / 2),
+          ((Point.some x y hP + k • Q : W.toAffine.Point).coordsOrZero.2
+            + (Point.some x y hP + -(k • Q) : W.toAffine.Point).coordsOrZero.2
+            - (k • Q).coordsOrZero.2
+            - W.toAffine.negY (k • Q).coordsOrZero.1 (k • Q).coordsOrZero.2) := by
+  set d := (p - 1) / 2
+  have hSset := kw_isOddVeluSet_oddOrderSummingSet_odd (W := W) hp3 hpodd hord (le_refl d)
+  have hx : ∀ A ∈ W.oddOrderSummingSet Q d, x ≠ A.1 := by
+    intro A hA
+    obtain ⟨k, a, b, h, _, _, heq, hAeq, _⟩ :=
+      kw_exists_nsmul_of_mem_oddOrderSummingSet_odd hp3 hpodd hord le_rfl hA
+    subst hAeq
+    exact xOrZero_ne_of_not_mem_zmultiples hPmem
+      (fun h0 => hPmem (h0 ▸ AddSubgroup.zero_mem _))
+      (heq ▸ AddSubgroup.nsmul_mem _ (AddSubgroup.mem_zmultiples Q) k)
+  rw [W.veluY_eq_orbitSum_fieldRed hP.1 hSset.equation hx]
+  congr 1
+  have hcard := kw_card_oddOrderSummingSet_odd (W := W) hp3 hpodd hord (le_refl d)
+  have hIcc : (Finset.Icc 1 d).card = d := by rw [Nat.card_Icc]; omega
+  have hinj : Set.InjOn (fun k : ℕ => (k • Q).coordsOrZero) (Finset.Icc 1 d) := by
+    rw [← Finset.card_image_iff]; exact hcard.trans hIcc.symm
+  change ∑ A ∈ W.oddOrderSummingSet Q d, _ = _
+  rw [oddOrderSummingSet, Finset.sum_image (fun a ha b hb => hinj ha hb)]
+  refine Finset.sum_congr rfl fun k hk => ?_
+  rw [Finset.mem_Icc] at hk
+  obtain ⟨hndvd, _⟩ := kw_not_dvd_of_le_half_odd hp3 hpodd hk.1 hk.2
+  obtain ⟨a, b, hab, hkQeq, hkQc⟩ :=
+    exists_some_of_ne_zero (nsmul_ne_zero_of_addOrderOf_eq_of_not_dvd hord hndvd)
+  rw [hkQc]; dsimp only
+  have hxk : x ≠ a := xOrZero_ne_of_not_mem_zmultiples hPmem
+    (fun h0 => hPmem (h0 ▸ AddSubgroup.zero_mem _))
+    (hkQeq ▸ AddSubgroup.nsmul_mem _ (AddSubgroup.mem_zmultiples Q) k)
+  have hPkQ : (Point.some x y hP + k • Q : W.toAffine.Point).coordsOrZero.2
+      = W.toAffine.addY x a y (W.toAffine.slope x a y b) := by
+    rw [hkQeq, Point.add_of_X_ne hxk, Point.coordsOrZero_some]
+  have hnegkQ : -(k • Q) = Point.some a (W.toAffine.negY a b)
+      ((Affine.nonsingular_neg ..).mpr hab) := by
+    rw [hkQeq]; rfl
+  have hPmkQ : (Point.some x y hP + -(k • Q) : W.toAffine.Point).coordsOrZero.2
+      = W.toAffine.addY x a y (W.toAffine.slope x a y (W.toAffine.negY a b)) := by
+    rw [hnegkQ, Point.add_of_X_ne hxk, Point.coordsOrZero_some]
+  rw [hPkQ, hPmkQ]
+
+theorem kw_veluY_oddOrderSummingSet_eq_sum_range_odd (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {x y : F} (hP : W.toAffine.Nonsingular x y)
+    (hPmem : (Point.some x y hP : W.toAffine.Point) ∉ AddSubgroup.zmultiples Q) :
+    W.veluY (W.oddOrderSummingSet Q ((p - 1) / 2)) x y
+      = (∑ j ∈ Finset.range p,
+          (Point.some x y hP + j • Q : W.toAffine.Point).coordsOrZero.2)
+        - ∑ k ∈ Finset.Icc 1 ((p - 1) / 2),
+          ((k • Q).coordsOrZero.2
+            + W.toAffine.negY (k • Q).coordsOrZero.1 (k • Q).coordsOrZero.2) := by
+  have hodd : p % 2 = 1 := Nat.odd_iff.mp hpodd
+  rw [kw_veluY_oddOrderSummingSet_eq_sum_Icc_odd hp3 hpodd hord hP hPmem]
+  obtain ⟨d, hpeq, hd_def⟩ : ∃ d, p = 2 * d + 1 ∧ d = (p - 1) / 2 := ⟨(p - 1) / 2, by omega, rfl⟩
+  rw [← hd_def]
+  simp only [sub_sub, Finset.sum_sub_distrib, Finset.sum_add_distrib,
+    show ∀ a b c : F, a + (b - c) = a + b - c from fun a b c => (add_sub_assoc a b c).symm]
+  congr 1
+  have hsplit : Finset.range p = {0} ∪ Finset.Icc 1 d ∪ Finset.Icc (d + 1) (p - 1) := by
+    ext j; simp only [Finset.mem_range, Finset.mem_union, Finset.mem_singleton, Finset.mem_Icc]
+    omega
+  have hdisj1 : Disjoint ({0} : Finset ℕ) (Finset.Icc 1 d) := by
+    rw [Finset.disjoint_left]; intro a ha hb
+    rw [Finset.mem_singleton] at ha; rw [Finset.mem_Icc] at hb; omega
+  have hdisj2 : Disjoint (({0} : Finset ℕ) ∪ Finset.Icc 1 d) (Finset.Icc (d + 1) (p - 1)) := by
+    rw [Finset.disjoint_left]; intro a ha hb
+    rw [Finset.mem_union, Finset.mem_singleton, Finset.mem_Icc] at ha
+    rw [Finset.mem_Icc] at hb; omega
+  rw [hsplit, Finset.sum_union hdisj2, Finset.sum_union hdisj1, Finset.sum_singleton,
+    zero_nsmul, add_zero, Point.coordsOrZero_some]
+  clear hd_def
+  have hrefl : ∑ j ∈ Finset.Icc (d + 1) (p - 1),
+        (Point.some x y hP + j • Q : W.toAffine.Point).coordsOrZero.2
+      = ∑ k ∈ Finset.Icc 1 d,
+        (Point.some x y hP + -(k • Q) : W.toAffine.Point).coordsOrZero.2 := by
+    refine Finset.sum_nbij' (fun j => p - j) (fun k => p - k)
+      (fun j hj => by rw [Finset.mem_Icc] at hj; simp only [Finset.mem_Icc]; omega)
+      (fun k hk => by rw [Finset.mem_Icc] at hk; simp only [Finset.mem_Icc]; omega)
+      (fun j hj => by rw [Finset.mem_Icc] at hj; omega)
+      (fun k hk => by rw [Finset.mem_Icc] at hk; omega)
+      (fun j hj => ?_)
+    rw [Finset.mem_Icc] at hj
+    congr 3
+    have hpQ : p • Q = 0 := hord ▸ addOrderOf_nsmul_eq_zero Q
+    rw [← sub_nsmul_eq_neg_of_nsmul_eq_zero hpQ (k := p - j) (Nat.sub_le _ _)]
+    congr 1; omega
+  rw [hrefl]; ring
+
+theorem kw_veluY_coordsOrZero_add_gen_odd (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {P : W.toAffine.Point}
+    (hPmem : P ∉ AddSubgroup.zmultiples Q) :
+    W.veluY (W.oddOrderSummingSet Q ((p - 1) / 2)) (P + Q).coordsOrZero.1
+        (P + Q).coordsOrZero.2
+      = W.veluY (W.oddOrderSummingSet Q ((p - 1) / 2)) P.coordsOrZero.1 P.coordsOrZero.2 := by
+  have hQmem : Q ∈ AddSubgroup.zmultiples Q := AddSubgroup.mem_zmultiples Q
+  have hP0 : P ≠ 0 := fun h => hPmem (h ▸ AddSubgroup.zero_mem _)
+  obtain ⟨x, y, hns, rfl, -⟩ := exists_some_of_ne_zero hP0
+  have hPQmem := not_mem_zmultiples_add hPmem hQmem
+  have hPQ0 : (Point.some x y hns + Q : W.toAffine.Point) ≠ 0 :=
+    add_ne_zero_of_not_mem_zmultiples hPmem hQmem
+  obtain ⟨x', y', hns', heqPQ, -⟩ := exists_some_of_ne_zero hPQ0
+  rw [heqPQ, Point.coordsOrZero_some, Point.coordsOrZero_some,
+    kw_veluY_oddOrderSummingSet_eq_sum_range_odd hp3 hpodd hord hns' (heqPQ ▸ hPQmem),
+    kw_veluY_oddOrderSummingSet_eq_sum_range_odd hp3 hpodd hord hns hPmem]
+  congr 1
+  calc ∑ j ∈ Finset.range p, (Point.some x' y' hns' + j • Q : W.toAffine.Point).coordsOrZero.2
+      = ∑ j ∈ Finset.range p,
+          ((Point.some x y hns + Q : W.toAffine.Point) + j • Q).coordsOrZero.2 :=
+        Finset.sum_congr rfl fun j _ => by rw [← heqPQ]
+    _ = ∑ j ∈ Finset.range p, (Point.some x y hns + j • Q : W.toAffine.Point).coordsOrZero.2 :=
+        sum_range_addOrderOf_shift_invariant hord
+          (fun P => Point.coordsOrZero P |>.2) (Point.some x y hns)
+
+theorem kw_veluDeficit_add_gen_odd (hp3 : 3 ≤ p) (hpodd : Odd p) (hord : addOrderOf Q = p)
+    {P : W.toAffine.Point} (hPmem : P ∉ AddSubgroup.zmultiples Q) :
+    W.veluDeficit (W.oddOrderSummingSet Q ((p - 1) / 2))
+        (P + Q).coordsOrZero.1 (P + Q).coordsOrZero.2
+      = W.veluDeficit (W.oddOrderSummingSet Q ((p - 1) / 2))
+        P.coordsOrZero.1 P.coordsOrZero.2 := by
+  refine W.veluDeficit_congr ?_ (kw_veluY_coordsOrZero_add_gen_odd hp3 hpodd hord hPmem)
+  rw [Point.coordsOrZero_fst, Point.coordsOrZero_fst]
+  exact kw_veluX_xOrZero_add_gen_odd hp3 hpodd hord hPmem
+
+theorem kw_veluDeficit_add_nsmul_odd (hp3 : 3 ≤ p) (hpodd : Odd p) (hord : addOrderOf Q = p)
+    {P : W.toAffine.Point} (hPmem : P ∉ AddSubgroup.zmultiples Q) (n : ℕ) :
+    W.veluDeficit (W.oddOrderSummingSet Q ((p - 1) / 2))
+        (P + n • Q).coordsOrZero.1 (P + n • Q).coordsOrZero.2
+      = W.veluDeficit (W.oddOrderSummingSet Q ((p - 1) / 2))
+        P.coordsOrZero.1 P.coordsOrZero.2 := by
+  induction n with
+  | zero => rw [zero_nsmul, add_zero]
+  | succ m ih =>
+    have hPm : P + m • Q ∉ AddSubgroup.zmultiples Q :=
+      not_mem_zmultiples_add hPmem (AddSubgroup.nsmul_mem _ (AddSubgroup.mem_zmultiples Q) m)
+    rw [succ_nsmul, ← add_assoc, kw_veluDeficit_add_gen_odd hp3 hpodd hord hPm, ih]
+
+theorem kw_veluDeficit_eq_of_sub_mem_zmultiples_odd (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {P P' : W.toAffine.Point}
+    (hPmem : P ∉ AddSubgroup.zmultiples Q) (hdiff : P' - P ∈ AddSubgroup.zmultiples Q) :
+    W.veluDeficit (W.oddOrderSummingSet Q ((p - 1) / 2))
+        P'.coordsOrZero.1 P'.coordsOrZero.2
+      = W.veluDeficit (W.oddOrderSummingSet Q ((p - 1) / 2))
+        P.coordsOrZero.1 P.coordsOrZero.2 := by
+  obtain ⟨k, hk⟩ := AddSubgroup.mem_zmultiples_iff.mp hdiff
+  have hpQ : (p : ℤ) • Q = 0 := by exact_mod_cast hord ▸ addOrderOf_nsmul_eq_zero Q
+  have hp_ne : (p : ℤ) ≠ 0 := Int.natCast_ne_zero.mpr (by omega)
+  set n : ℕ := (k % (p : ℤ)).toNat with hn_def
+  have hmod_nn := Int.emod_nonneg k hp_ne
+  have hkQ : k • Q = n • Q := by
+    conv_lhs => rw [show k = k % p + k / p * p from by
+        rw [mul_comm]; exact (Int.emod_add_mul_ediv k p).symm,
+      add_zsmul, mul_zsmul, hpQ, smul_zero, add_zero]
+    rw [hn_def, ← natCast_zsmul, Int.toNat_of_nonneg hmod_nn]
+  have hP'eq : P' = P + n • Q := by
+    have h1 : P' - P = n • Q := hk ▸ hkQ
+    rw [← h1, add_sub_cancel]
+  rw [hP'eq]
+  exact kw_veluDeficit_add_nsmul_odd hp3 hpodd hord hPmem n
+
+theorem kw_mem_zmultiples_of_abscissa_mem_oddOrderSummingSet_odd (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {a b : F} (hab : W.toAffine.Nonsingular a b)
+    (hA : ∃ A ∈ W.oddOrderSummingSet Q ((p - 1) / 2), A.1 = a) :
+    Affine.Point.some a b hab ∈ AddSubgroup.zmultiples Q := by
+  obtain ⟨A, hAmem, hAfst⟩ := hA
+  obtain ⟨k, xk, yk, hk, hk1, _, hkQ, hAeq, _⟩ :=
+    kw_exists_nsmul_of_mem_oddOrderSummingSet_odd hp3 hpodd hord le_rfl hAmem
+  have hax : a = xk := hAfst ▸ congrArg Prod.fst hAeq
+  rcases Affine.Y_eq_of_X_eq hab.1 hk.1 hax with hby | hby
+  · exact AddSubgroup.mem_zmultiples_iff.mpr ⟨(k : ℤ), by
+      rw [natCast_zsmul, hkQ]; exact kw_vdcoog_some_congr hax.symm hby.symm _ _⟩
+  · exact AddSubgroup.mem_zmultiples_iff.mpr ⟨-(k : ℤ), by
+      rw [neg_zsmul, natCast_zsmul, hkQ, Affine.Point.neg_some]
+      exact kw_vdcoog_some_congr hax.symm hby.symm _ _⟩
+
+variable (F : Type*) [Field F] [DecidableEq F] in
+theorem kw_veluDeficitFunKernelTranslationFixesAt_odd {p : ℕ} (hp3 : 3 ≤ p) (hpodd : Odd p) :
+    VeluDeficitFunKernelTranslationFixesAt F p := by
+  intro W hΔ x₀ y₀ h₀ hord a b hab hA
+  classical
+  set ι := algebraMap F W.toAffine.FunctionField
+  set Q : W.toAffine.Point := Affine.Point.some x₀ y₀ h₀
+  set Q' : (W.map ι).toAffine.Point := ratPointHom (W₀ := W) ι Q
+  rw [translationAlgEquivOf_veluDeficitFun_eq_iff hΔ hab,
+    W.toAffine.liftSummingSet_oddOrderSummingSet Q ((p - 1) / 2)]
+  have hord' : addOrderOf Q' = p :=
+    (addOrderOf_injective (ratPointHom (W₀ := W) ι) (ratPointMap_injective ι) Q).trans hord
+  have hPmem : Affine.genericPoint' hΔ ∉ AddSubgroup.zmultiples Q' :=
+    genericPoint'_notMem_zmultiples_ratPointHom hΔ Q
+  have hab' : W.toAffine.Nonsingular a b :=
+    (Affine.equation_iff_nonsingular_of_Δ_ne_zero hΔ).mp hab
+  have hAmem : Affine.Point.some a b hab' ∈ AddSubgroup.zmultiples Q :=
+    kw_mem_zmultiples_of_abscissa_mem_oddOrderSummingSet_odd hp3 hpodd hord hab' hA
+  have hdiff : Affine.genericPoint' hΔ + Affine.mapPoint hΔ hab - Affine.genericPoint' hΔ
+      ∈ AddSubgroup.zmultiples Q' := by
+    rw [add_sub_cancel_left]
+    obtain ⟨n, hn⟩ := AddSubgroup.mem_zmultiples_iff.mp hAmem
+    exact AddSubgroup.mem_zmultiples_iff.mpr ⟨n, by
+      change n • Q' = ratPointHom (W₀ := W) ι (Affine.Point.some a b hab')
+      rw [← hn, ← map_zsmul]⟩
+  exact kw_veluDeficit_eq_of_sub_mem_zmultiples_odd hp3 hpodd hord' hPmem hdiff
+
+variable (F : Type*) [Field F] [DecidableEq F] in
+theorem kw_veluDeficitFunOrdNonnegAtInftyAt_odd {p : ℕ} (hp3 : 3 ≤ p) (hpodd : Odd p) :
+    VeluDeficitFunOrdNonnegAtInftyAt F p := by
+  intro W _hΔ x₀ y₀ h₀ hord v hv
+  exact ord_veluDeficitFun_nonneg_of_not_isFinitePlace hv
+    (kw_isOddVeluSet_oddOrderSummingSet_odd hp3 hpodd hord le_rfl).equation
+
+variable (F : Type*) [Field F] [DecidableEq F] [IsAlgClosed F] in
+theorem kw_veluDeficitFunKernelTranslationYNotCentreAt_odd
+    (hDD : ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 → IsDedekindDomain W.toAffine.CoordinateRing)
+    {p : ℕ} (hp3 : 3 ≤ p) (hpodd : Odd p) :
+    VeluDeficitFunKernelTranslationYNotCentreAt F p := by
+  intro W hΔ x₀ y₀ h₀ hord v hv ⟨A, hA, hXA⟩
+  have := hDD W hΔ
+  have hSset := kw_isOddVeluSet_oddOrderSummingSet_odd (W := W) hp3 hpodd hord
+    (le_refl ((p - 1) / 2))
+  have hAeq : W.toAffine.Equation A.1 A.2 := hSset.equation A hA
+  have hAgy : W.veluGy A.1 A.2 ≠ 0 := hSset.gy_ne_zero A hA
+  have h2tor : W.toAffine.negY A.1 A.2 ≠ A.2 := negY_ne_self_of_veluGy_ne_zero hAgy
+  obtain ⟨b, hab, hXcen, hYcen⟩ := Affine.exists_YClass_negY_notMem_centre hv hAeq h2tor hXA
+  exact ⟨A.1, b, hab, ⟨A, hA, rfl⟩, hXcen, hYcen⟩
+
+variable (F : Type*) [Field F] [DecidableEq F] [IsAlgClosed F] in
+public theorem kw_veluDeficitFunOrdNonnegAt_odd
+    (hDD : ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 → IsDedekindDomain W.toAffine.CoordinateRing)
+    {p : ℕ} (hp3 : 3 ≤ p) (hpodd : Odd p) :
+    VeluDeficitFunOrdNonnegAt F p :=
+  veluDeficitFunOrdNonnegAt_of_kernelTranslation_of_atInfty_of_offKernel
+    (veluDeficitFunKernelTranslationAt_of_fixes_of_toInfty F
+      (kw_veluDeficitFunKernelTranslationFixesAt_odd F hp3 hpodd)
+      (veluDeficitFunKernelTranslationToInftyAt_of_yNotCentre F
+        (kw_veluDeficitFunKernelTranslationYNotCentreAt_odd F hDD hp3 hpodd)))
+    (kw_veluDeficitFunOrdNonnegAtInftyAt_odd F hp3 hpodd)
+    (veluDeficitFunOrdNonnegOffKernelAt F p)
+
+end OrdNonneg
+
+section ConstantIsZero
+
+variable {F : Type*} [Field F] [DecidableEq F]
+
+public theorem kw_veluDeficitCrossQuadBetaSqDecompDegLtAt_odd
+    {p : ℕ} (hp3 : 3 ≤ p) (hpodd : Odd p) :
+    VeluDeficitCrossQuadBetaSqDecompDegLtAt F p := by
+  intro W hΔ x₀ y₀ h₀ hord
+  have hodd : p % 2 = 1 := Nat.odd_iff.mp hpodd
+  set S := W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)
+  have hScard : S.card = (p - 1) / 2 := kw_card_oddOrderSummingSet_odd hp3 hpodd hord le_rfl
+  have hSne : S.Nonempty := Finset.card_pos.mp (by rw [hScard]; omega)
+  exact ⟨W.veluDeficitCrossQuadBetaSqConstS2ClearedPoly S,
+    W.veluDeficitCrossQuadBetaSqSCoeffS2ClearedPoly S,
+    hScard ▸ W.veluDeficitCrossQuadBetaSqConstS2ClearedPoly_natDegree_lt hSne,
+    fun r s hrs hav => W.veluDeficitCrossQuadBetaSq_mul_prodPow_sDecomp hrs hav⟩
+
+public theorem kw_veluDeficitCrossQuadAlphaBetaDecompDegLtAt_odd {p : ℕ} (hp3 : 3 ≤ p)
+    (hpodd : Odd p) : VeluDeficitCrossQuadAlphaBetaDecompDegLtAt F p := by
+  intro W hΔ x₀ y₀ h₀ hord
+  have hodd : p % 2 = 1 := Nat.odd_iff.mp hpodd
+  set S := W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)
+  have hScard : S.card = (p - 1) / 2 := kw_card_oddOrderSummingSet_odd hp3 hpodd hord le_rfl
+  have hSne : S.Nonempty := Finset.card_pos.mp (by rw [hScard]; omega)
+  exact ⟨W.veluDeficitCrossQuadAlphaBetaConstClearedPoly S,
+    W.veluDeficitCrossQuadAlphaBetaSCoeffClearedPoly S,
+    hScard ▸ W.veluDeficitCrossQuadAlphaBetaConstClearedPoly_natDegree_lt hSne,
+    fun r s _hrs hav => W.veluDeficitCrossQuadAlphaBeta_mul_prodPow_sDecomp s hav⟩
+
+public theorem kw_veluDeficitCrossQuadCubeBetaDegLtAt_odd {p : ℕ} (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hβ : VeluDeficitCrossQuadBetaOnlyDegLtAt F p) :
+    VeluDeficitCrossQuadCubeBetaDegLtAt F p := by
+  intro W hΔ x₀ y₀ h₀ hord
+  have hodd : p % 2 = 1 := Nat.odd_iff.mp hpodd
+  set S := W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)
+  have hScard : S.card = (p - 1) / 2 := kw_card_oddOrderSummingSet_odd hp3 hpodd hord le_rfl
+  have hSne : S.Nonempty := Finset.card_pos.mp (by rw [hScard]; omega)
+  obtain ⟨M, hMdeg, hM⟩ := hβ W hΔ x₀ y₀ h₀ hord
+  refine ⟨M - W.veluDeficitCrossQuadAlphaCubeClearedPoly S, ?_, fun r s hrs hav => ?_⟩
+  · exact lt_of_le_of_lt (natDegree_sub_le _ _) (max_lt hMdeg
+      (hScard ▸ W.veluDeficitCrossQuadAlphaCubeClearedPoly_natDegree_lt hSne))
+  · rw [W.veluDeficitCrossQuadCubeBeta_eq_betaOnly_sub_alphaCube, sub_mul,
+      W.veluDeficitCrossQuadAlphaCube_mul_prodPow_eq hav, hM hrs hav, eval_sub]
+
+public theorem kw_veluDeficitCrossQuadProdDegLtAt_odd {p : ℕ} (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hCB : VeluDeficitCrossQuadCubeBetaDegLtAt F p) :
+    VeluDeficitCrossQuadProdDegLtAt F p := by
+  intro W hΔ x₀ y₀ h₀ hord
+  have hodd : p % 2 = 1 := Nat.odd_iff.mp hpodd
+  set S := W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)
+  have hScard : S.card = (p - 1) / 2 := kw_card_oddOrderSummingSet_odd hp3 hpodd hord le_rfl
+  have hSne : S.Nonempty := Finset.card_pos.mp (by rw [hScard]; omega)
+  obtain ⟨M, hMdeg, hM⟩ := hCB W hΔ x₀ y₀ h₀ hord
+  refine ⟨W.veluDeficitCrossQuadAlphaSqClearedPoly S + M, ?_, fun r s hrs hav => ?_⟩
+  · exact lt_of_le_of_lt (natDegree_add_le _ _) (max_lt
+      (hScard ▸ W.veluDeficitCrossQuadAlphaSqClearedPoly_natDegree_lt hSne) hMdeg)
+  · rw [W.veluDeficitCrossQuad_eq_alphaSq_add_cubeBeta, add_mul,
+      W.veluDeficitCrossQuadAlphaSq_mul_prodPow_eq hav, hM hrs hav, eval_add]
+
+public theorem kw_veluDeficitCrossQuadBetaOnlyDegLtAt_odd [Infinite F] [IsAlgClosed F] {p : ℕ}
+    (hSD : VeluDeficitCrossQuadBetaSDecompDegLtAt F p) :
+    VeluDeficitCrossQuadBetaOnlyDegLtAt F p := by
+  intro W hΔ x₀ y₀ h₀ hord
+  set S := W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)
+  obtain ⟨M, N, hMdeg, hMN⟩ := hSD W hΔ x₀ y₀ h₀ hord
+  have hNgy : ∀ ⦃r s : F⦄, W.toAffine.Equation r s → (∀ A ∈ S, r ≠ A.1) →
+      N.eval r * W.veluGy r s = 0 := by
+    intro r s hrs hav
+    have hrs' : W.toAffine.Equation r (W.toAffine.negY r s) := (Affine.equation_neg r s).mpr hrs
+    have hMN' := hMN hrs' hav
+    rw [W.veluDeficitCrossQuadBetaOnly_negY_of_equation hrs, hMN hrs hav] at hMN'
+    have hgy : s - W.toAffine.negY r s = -W.veluGy r s := by
+      simp only [Affine.negY, veluGy]; ring
+    linear_combination N.eval r * hgy - hMN'
+  have hN2Ψ : N ^ 2 * W.Ψ₂Sq = 0 := by
+    refine eq_zero_of_infinite_isRoot _ ?_
+    have hbad_fin : {r : F | ∃ A ∈ S, r = A.1}.Finite :=
+      (S.finite_toSet.image Prod.fst).subset (by rintro r ⟨A, hA, rfl⟩; exact ⟨A, hA, rfl⟩)
+    refine hbad_fin.infinite_compl.mono ?_
+    intro r hr
+    have hav : ∀ A ∈ S, r ≠ A.1 := fun A hA heq => hr ⟨A, hA, heq⟩
+    obtain ⟨s, hrs⟩ := Affine.exists_equation_of_isAlgClosed W r
+    have hsq : (N.eval r) ^ 2 * W.Ψ₂Sq.eval r = 0 := by
+      rw [← W.veluU_eq_Ψ₂Sq_eval hrs, veluU, ← mul_pow, hNgy hrs hav, zero_pow two_ne_zero]
+    simpa [IsRoot, eval_mul, eval_pow] using hsq
+  have hN0 : N = 0 :=
+    pow_eq_zero_iff two_ne_zero |>.mp
+      ((mul_eq_zero.mp hN2Ψ).resolve_right (W.Ψ₂Sq_ne_zero_of_Δ_ne_zero hΔ))
+  exact ⟨M, hMdeg, fun r s hrs hav => by rw [hMN hrs hav, hN0, eval_zero, zero_mul, add_zero]⟩
+
+public theorem kw_veluDeficitConstantIsZeroAt_odd [Infinite F] [IsAlgClosed F]
+    {p : ℕ} (hp3 : 3 ≤ p) (hpodd : Odd p) (hCQ : VeluDeficitCrossQuadProdDegLtAt F p) :
+    VeluDeficitConstantIsZeroAt F p := by
+  intro W hΔ x₀ y₀ h₀ hord c hc
+  have hodd : p % 2 = 1 := Nat.odd_iff.mp hpodd
+  set S := W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2)
+  have hScard : S.card = (p - 1) / 2 := kw_card_oddOrderSummingSet_odd hp3 hpodd hord le_rfl
+  have hSne : S.Nonempty := Finset.card_pos.mp (by rw [hScard]; omega)
+  have hSeq : ∀ A ∈ S, W.toAffine.Equation A.1 A.2 :=
+    (kw_isOddVeluSet_oddOrderSummingSet_odd hp3 hpodd hord le_rfl).equation
+  obtain ⟨M, hMdeg, hM⟩ := hCQ W hΔ x₀ y₀ h₀ hord
+  exact W.veluDeficit_isConstant_constant_eq_zero_of_crossQuadProdDegLt hSne hSeq
+    (Affine.exists_equation_of_isAlgClosed W) hc (M := M) (hScard ▸ hMdeg)
+    (fun r s hrs hav => hM hrs hav)
+
+end ConstantIsZero
+
+end WeierstrassCurve
+
+end
+
+end
+
+end
+end
+end
+end
+end
+end
+end
+end
+end
+end
+end
+end
+end
+end
+end
+end
+end
+end
+end
+end
+end
+end
+end
+end
+end
+end
+end
+end
+end
+
+end privateSection
diff --git a/LeanPool/FLTEichlerShimura/Definitions/Defs_modularPolynomial_sharedLibrary.lean b/LeanPool/FLTEichlerShimura/Definitions/Defs_modularPolynomial_sharedLibrary.lean
new file mode 100644
index 0000000000..5b45539bd0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Definitions/Defs_modularPolynomial_sharedLibrary.lean
@@ -0,0 +1,148 @@
+/-
+Copyright (c) 2026 David Loeffler. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: David Loeffler
+
+Extracted from the proof of Prove2Me node ModularCurve.exists_phiIrreducible
+(85c90cda-9166-5cf9-a245-c0442a624673), by Claude (2026-09-05), submission
+25e72fb1-74d8-5410-94ca-a5536b5cd327; locally adapted.
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import Mathlib.Tactic.Linarith
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_neg_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_order_jqModC
+
+/-!
+# Shared modular-polynomial and Laurent-series helpers
+
+`ModularCurve.W1.TS` is the Laurent series `j(u q^e)` over an arbitrary field, including
+positive characteristic. Its coefficients recover the parameters, and its substitution
+lemmas describe rescaling and expansion of `q`. Over a ℚ-algebra, `TS_eq_coeffEmb` identifies
+it with the coefficientwise image of the rational series.
+
+`ModularCurve.W1.phiAtSeed` specializes the first variable of a modular polynomial.
+The accompanying lemmas preserve monicity and degree and transport specialization
+and roots along ring homomorphisms.
+-/
+
+@[expose] public noncomputable section publicSection
+
+namespace ModularCurve.W1
+
+variable {K : Type*} [Field K]
+
+def TS (K : Type*) [Field K] (e : ℕ) [NeZero e] (u : Kˣ) : LaurentSeries K :=
+  qExpand K e (qTwist u (jqModC K))
+
+theorem TS_coeff_mul (e : ℕ) [NeZero e] (u : Kˣ) (n : ℤ) :
+    (TS K e u).coeff ((e : ℤ) * n) = ((u ^ n : Kˣ) : K) * (jqModC K).coeff n := by
+  rw [TS, qExpand_coeff_mul, qTwist_coeff]
+
+theorem TS_coeff_of_not_dvd (e : ℕ) [NeZero e] (u : Kˣ) {k : ℤ} (hk : ¬ (e : ℤ) ∣ k) :
+    (TS K e u).coeff k = 0 := by
+  exact qExpand_coeff_of_not_dvd (R := K) (N := e) _ hk
+
+theorem TS_coeff_neg (e : ℕ) [NeZero e] (u : Kˣ) :
+    (TS K e u).coeff (-(e : ℤ)) = ((u⁻¹ : Kˣ) : K) := by
+  have h := TS_coeff_mul (K := K) e u (-1)
+  rw [mul_neg_one] at h
+  rw [h, ModularCurve.coeff_jqModC_neg_one, mul_one, zpow_neg_one]
+
+private theorem coeff_jqModC_of_lt {n : ℤ} (hn : n < -1) : (jqModC K).coeff n = 0 := by
+  apply HahnSeries.coeff_eq_zero_of_lt_order
+  rw [ModularCurve.order_jqModC]
+  exact hn
+
+theorem TS_coeff_of_lt (e : ℕ) [NeZero e] (u : Kˣ) {k : ℤ} (hk : k < -(e : ℤ)) :
+    (TS K e u).coeff k = 0 := by
+  by_cases hd : (e : ℤ) ∣ k
+  · obtain ⟨n, rfl⟩ := hd
+    have he : (0 : ℤ) < e := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne e)
+    have hn : n < -1 := by
+      by_contra hcon
+      push Not at hcon
+      have : -(e : ℤ) ≤ (e : ℤ) * n := by nlinarith
+      exact absurd hk (not_lt.mpr this)
+    rw [TS_coeff_mul, coeff_jqModC_of_lt hn, mul_zero]
+  · exact TS_coeff_of_not_dvd e u hd
+
+theorem TS_ne_zero (e : ℕ) [NeZero e] (u : Kˣ) : TS K e u ≠ 0 := by
+  intro h
+  have := TS_coeff_neg (K := K) e u
+  rw [h, HahnSeries.coeff_zero] at this
+  exact (u⁻¹).ne_zero this.symm
+
+theorem TS_injective {e e' : ℕ} [NeZero e] [NeZero e'] {u u' : Kˣ}
+    (h : TS K e u = TS K e' u') :
+    e = e' ∧ u = u' := by
+  have key : ∀ {a a' : ℕ} [NeZero a] [NeZero a'] {v v' : Kˣ}, TS K a v = TS K a' v' → a ≤ a' := by
+    intro a a' _ _ v v' hh
+    by_contra hlt
+    push Not at hlt
+    have h1 := TS_coeff_neg (K := K) a v
+    have hlt' : (-(a : ℤ)) < -(a' : ℤ) := by
+      have : (a' : ℤ) < a := by exact_mod_cast hlt
+      omega
+    have h2 : (TS K a' v').coeff (-(a : ℤ)) = 0 := TS_coeff_of_lt a' v' hlt'
+    rw [← hh, h1] at h2
+    exact (v⁻¹).ne_zero h2
+  have hee : e = e' := le_antisymm (key h) (key h.symm)
+  subst hee
+  refine ⟨rfl, ?_⟩
+  have h1 := TS_coeff_neg (K := K) e u
+  rw [h, TS_coeff_neg] at h1
+  exact (inv_injective (Units.val_injective h1)).symm
+
+theorem qTwist_TS (v : Kˣ) (e : ℕ) [NeZero e] (u : Kˣ) :
+    qTwist v (TS K e u) = TS K e (v ^ (e : ℤ) * u) := by
+  rw [TS, qTwist_qExpand, qTwist_qTwist]; rfl
+
+theorem qExpand_TS (m e : ℕ) [NeZero m] [NeZero e] (u : Kˣ) :
+    qExpand K m (TS K e u) = TS K (m * e) u := by
+  rw [TS, qExpand_qExpand]; rfl
+
+theorem TS_congr {e e' : ℕ} [NeZero e] [NeZero e'] (h : e = e') (u : Kˣ) :
+    TS K e u = TS K e' u := by
+  subst h; rfl
+
+theorem TS_eq_coeffEmb [Algebra ℚ K] (e : ℕ) [NeZero e] (u : Kˣ) :
+    TS K e u = qExpand K e (qTwist u (coeffEmb K jq)) := by
+  have h : coeffEmb K jq = jqModC K := by
+    rw [coeffEmb, ← jqModC_rat]
+    exact map_jqModC (algebraMap ℚ K)
+  rw [TS, h]
+
+def phiAtSeed {R : Type*} [CommRing R] {n : ℕ} [NeZero n] (data : ModularPolynomialData n) (x : R) :
+    Polynomial R :=
+  data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom R) x)
+
+theorem phiAtSeed_map {R S : Type*} [CommRing R] [CommRing S] {n : ℕ} [NeZero n]
+    (data : ModularPolynomialData n) (x : R) (f : R →+* S) :
+    (phiAtSeed data x).map f = phiAtSeed data (f x) := by
+  rw [phiAtSeed, phiAtSeed, Polynomial.map_map]
+  congr 1
+  refine Polynomial.ringHom_ext' ?_ ?_
+  · exact RingHom.ext_int _ _
+  · simp
+
+theorem phiAtSeed_monic {R : Type*} [CommRing R] [Nontrivial R] {n : ℕ} [NeZero n]
+    (data : ModularPolynomialData n) (x : R) : (phiAtSeed data x).Monic :=
+  data.monic.map _
+
+theorem phiAtSeed_natDegree {R : Type*} [CommRing R] [Nontrivial R] {n : ℕ} [NeZero n]
+    (data : ModularPolynomialData n) (x : R) : (phiAtSeed data x).natDegree = dedekindPsi n := by
+  rw [phiAtSeed, data.monic.natDegree_map, data.natDegree_eq]
+
+theorem phiAtSeed_eval_map {R S : Type*} [CommRing R] [CommRing S] {n : ℕ} [NeZero n]
+    (data : ModularPolynomialData n) (x y : R) (f : R →+* S) (h : (phiAtSeed data x).eval y = 0) :
+    (phiAtSeed data (f x)).eval (f y) = 0 := by
+  rw [← phiAtSeed_map, Polynomial.eval_map, Polynomial.eval₂_hom, h, map_zero]
+
+end ModularCurve.W1
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Imports.lean b/LeanPool/FLTEichlerShimura/Imports.lean
new file mode 100644
index 0000000000..3f300a802f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Imports.lean
@@ -0,0 +1,1207 @@
+/-
+Copyright (c) 2026 Lean Pool contributors. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Lean Pool contributors
+-/
+module  -- shake: keep-all --deprecated_module: ignore
+
+-- Generated project imports; run `lake exe mk_all`.
+public import LeanPool.FLTEichlerShimura
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AdicCompletionLocalRing
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_BaseChangeGalois
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_CanonicalDivisor
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_CanonicalLocalResidueInstanceV2
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DifferentialPushPull
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_FrobeniusEndo
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_FrobeniusEndoPic0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_LocalResidue
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceCompletion
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PoleDivisorPackage
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceInfty
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RegularDifferentials
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Repartitions
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RiemannRochRows
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_TateResidueCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_WeilOfKaehler
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AutomorphicForm_FundamentalDomainVolume
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AutomorphicForm_Gamma0FundamentalSet
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AutomorphicForm_HyperbolicMeasure
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AutomorphicForm_SiegelSetCover
+public import LeanPool.FLTEichlerShimura.Definitions.Def_CohCarrier_Level
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Compat_Mathlib430
+public import LeanPool.FLTEichlerShimura.Definitions.Def_CuspForm_HeckeAlgebra
+public import LeanPool.FLTEichlerShimura.Definitions.Def_CuspForm_IntegralStructure
+public import LeanPool.FLTEichlerShimura.Definitions.Def_CuspForm_Petersson
+public import LeanPool.FLTEichlerShimura.Definitions.Def_DedekindDomain_AdicValuation_InlineSpecific
+public import LeanPool.FLTEichlerShimura.Definitions.Def_DualIsogenyAPI
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EisensteinSeries_EisensteinG
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EisensteinSeries_WeierstrassZeta
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_DivisionPolynomialOmega
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusEndo
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusTrace
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_PointReduction
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_TateModule
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_WeilPairingFun
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_ZeroComponentAt
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_FreyPackage
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_GaloisRep
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Ramification
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FieldTheory_RatAlgClosureGalois
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FreyPackage_GaloisRep
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FreyPackage_ModMCarrier_Rescale
+public import LeanPool.FLTEichlerShimura.Definitions.Def_GaloisRep_Adic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_GaloisRep_LocalConditions
+public import LeanPool.FLTEichlerShimura.Definitions.Def_GaloisRep_Residual
+public import LeanPool.FLTEichlerShimura.Definitions.Def_GaloisRep_ResidualEquiv
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0HeckeOperatorHom
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_Monodromy
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_RamificationBound
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeGalois_EichlerShimura
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_LanglandsTunnell_TowerCounting
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ArithmeticGalois
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_AtkinLehner
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CanonicalDivisor
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CanonicalDivisorUniformizer
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CharLFrobeniusGeomLevel
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ComplexPlaceDictionary
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ComplexPlaceDictionaryOf
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CuspSpace
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CuspidalClass
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CycSubRootBridge
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CycSubRootBridgeN
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CycSubRootBridgeOdd
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_DegeneracyTower
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EMD
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EigenformIdeal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_Eisenstein
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_FibrePoly
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GeometricBaseChange
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_HahnSpecialise
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_HeckeAlgebraHom
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_HeckeDifferential
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_HeckeModule
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_HeckeOperator
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_HeckeOperatorTotal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_IgusaFunctionField
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_IgusaFunctionFieldX1
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JLinePlaces
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JLinePlacesBar
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JZeroHeightForm
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JZeroNaiveHeight
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JZeroTateModule
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_KroneckerTransport
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LevelNFunctionField
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_MazurStepThree
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_MazurStepThreeInputs
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ModularUnit
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ModuliPoint
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_OmegaOf
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodLattice
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodMap
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodMapBundled
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodOf
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PrimCosetReps
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ProjectiveLine
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlace
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlaceMod
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QExpansionDiff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_RouteBCoordRing
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_SpecialisationBridge
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_SpecialisationVocab
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_TateFormal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_TatePoint
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0ModL
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_XH
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_AtkinLehnerDatum
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_EisensteinChiNegThree
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperatorForms
+public import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+public import LeanPool.FLTEichlerShimura.Definitions.Def_PeriodPair_Uniformization
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ProjectiveLineMatrixAction
+public import LeanPool.FLTEichlerShimura.Definitions.Def_TaylorWiles_Primes
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ValuationSubring_ReduceAt
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_EDSEngine
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FullKernelQuotient
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FunctionFieldQuadratic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePic0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_OddOrderSummingSet
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_RatPointHom
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_RatPointMap_probe
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_ReduceHom
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_ReductionMap
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_TorsionIntegral
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VariableChangePointEquiv
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_Velu
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluOrderTwo
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluPointMap
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluPointMap2
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluQuotientMap
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluQuotientOfSums
+public import LeanPool.FLTEichlerShimura.Definitions.Defs_AlgebraicCurve_residueTheorem_sharedLibrary
+public import LeanPool.FLTEichlerShimura.Definitions.Defs_IsogenyEndDatum_sharedLibrary
+public import LeanPool.FLTEichlerShimura.Definitions.Defs_WeierstrassCurve_veluSharedLibrary
+public import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AddCommGroup_natCard_isAddCyclic_addSubgroup_eq_dedekindPsi_of_addEquiv_torsionBy
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AddCommGroup_natCard_isAddCyclic_addSubgroup_map_eq_of_sq_add_self_add_id_eq_zero_eq_nuThree
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AddCommGroup_natCard_isAddCyclic_addSubgroup_map_eq_of_sq_eq_neg_one_eq_nuTwo
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AddCommGroup_nonempty_zmod_prod_addEquiv_torsionBy_of_card_torsionBy_eq_sq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Algebra_IsSeparable_of_finrank_fieldRange_frobenius_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_finrank_adjoin_of_eq_max_neg_ord
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_finrank_adjoin_of_eq_max_ord_sub_algebraMap
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_le_finrank_adjoin_of_eq_max_neg_ord
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_add
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_mul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_ne_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_single_sub_single
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_zpow_left
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_zsmul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_finrank_adjoin_le_degree_of_eq_max_neg_ord
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_pushforwardAlong_pushforwardAlong
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_pushforwardNormFormula
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_IsCurveOver_exists_separating_transcendental
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Pic0_addOrderOf_mk_dvd_of_isPrincipal
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Pic0_mk_eq_zero_iff
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Pic0_nsmul_mk_eq_zero_of_isPrincipal
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Pic0_zsmul_mk
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Pic0_zsmul_mk_eq_zero_of_isPrincipal
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_D_ne_zero_of_ord_eq_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_D_ne_zero_of_ord_ne_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_adicValuation_isRankOneDiscrete
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_adicValuation_isTrivialOn
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_card_fiberOver_mul_ramificationIndex_mul_inertiaDeg
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_deg_eq_one_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_deg_ne_zero_of_finiteDimensional_adjoin
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_diffCoeff_smul_D_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_diffCoeff_smul_D_eq_of_ord_eq_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_eq_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_ne_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_eq_ofHeightOneSpectrum_of_XClass_mem_nonunits_of_YClass_mem_nonunits
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_algebraMap
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_congr
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_inv
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_mul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_ne_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_zpow
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_algEquiv_smul_eq_of_restrict_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_algHom_laurentSeries_order_eq_ord
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_comap_algebraMap_eq_of_constantFieldExtension
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_comap_algebraMap_eq_of_constantFieldExtension_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_comap_eq_toValuationSubring
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_forall_ord_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_forall_ord_eq_finset
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_of_orderMap
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_of_valuationSubring
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_of_valuationSubring_of_isSeparable
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_algebraMap_eq_mul_ord
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_eq_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_algHom_laurentSeries
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_hasRamBound
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_restrict_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom_of_isSeparable
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_finite_residueField_of_finiteDimensional
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_inertiaDegAlong_comp
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_inertiaDeg_eq_of_restrict_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_inertiaDeg_pos
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_inertiaDeg_pos_of_finiteDimensional
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_isRational_iff_deg_eq_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_isRational_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_isSeparable_adjoin_of_ord_eq_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_mem_toValuationSubring_of_isIntegral_adjoin
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_min_ord_le_ord_add
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_min_ord_le_ord_add_v2
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ordDiff_D_eq_ord_sub_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ordDiff_eq_ordDifferential
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ordDiff_eq_ord_diffCoeff
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ordDiff_smul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ordDiff_smul_of_perfectField
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ordDiff_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_add_eq_of_lt
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg_of_isSeparable
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg_of_perfectField
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_dvd_of_forall_hahnSeries_embedding_hasRamBound
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_dvd_of_hahnSeries_embedding_of_isGalois
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_eq_neg_log_of_valuationSubring_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_eq_zero_of_isIntegral_adjoin
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_eq_zero_of_not_mem_of_eval_monic_eq_zero_of_coeff_eq_aeval_inv_div
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_natCast
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_restrictAlong_eq_natCard_algHom_of_isGalois
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_smul_of_ne_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_sub_one_le_ordDiff_D_of_perfectField
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_sum_algebraMap_mul_le_ord_of_linearIndependent_of_constantFieldExtension
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ramificationIndex_eq_of_restrict_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ramificationIndex_eq_ramificationIdx_fiberCenter
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_restrictAlong_restrictAlong
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_restrictAlong_surjective
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_restrict_ofAlgAut_smul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_fiberOver
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_le_finrank
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_transcendental_of_ord_ne_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_forall_ne_ofHeightOneSpectrum
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_ne_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_placeInfty
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord_algebraMap
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_eq_placeInfty_iff_forall_ne_ofHeightOneSpectrum
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_exists_forall_ne_ofHeightOneSpectrum
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_finiteDimensional_lSpace_zero_of_constantsAreBase
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_finite_setOf_ord_ne_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_hasPrincipalDivisors
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_nonempty_place_of_ratFunc_tower
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_X_nonneg_of_ne_placeInfty
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_X_sub_C
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_eq_neg_intDegree_of_forall_ne_ofHeightOneSpectrum
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_eq_neg_log
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_of_span
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty_X
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty_algebraMap
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_placeOfPoint_algebraMap
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_stichtenothGenusExists
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_stichtenothGenusExists_of_ratFunc_tower
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_subsingleton_setOf_forall_ne_ofHeightOneSpectrum
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_toValuationSubring_eq_of_forall_ne_ofHeightOneSpectrum
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_SemilinearAut_inertiaDeg_smul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_SemilinearAut_ord_algebraMap_smul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_SemilinearAut_ramificationIndex_smul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_TranscendenceTower_degree_poleDivisor_eq_finrank
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_TranscendenceTower_poleDivisor_apply
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_constantsAreBase_of_deg_eq_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_constantsAreBase_of_exists_isRational
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_constantsAreBase_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_constantsAreBase_of_isAlgClosed_of_transcendental
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_dCoordGenerates_of_isCurveOver
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_degree_canonicalDivisor_eq_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_degree_canonicalDivisor_eq_of_riemannRoch
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_degree_poleDivisor_eq_finrank_adjoin_of_isAlgClosed_of_transcendental
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_canonicalDivisor_eq_genus_of_riemannRoch
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_degree_add_one_sub_genusFF_of_isAlgClosed_of_isSeparable
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_le_degree_add_ellZero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_mapDomain_eq_of_constantFieldExtension_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_essFiniteType_of_transcendental_of_finiteDimensional
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_divisor_eq_max_ord_sub_algebraMap
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_divisor_forall_eq_weightFloor
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_finiteDimensional_isSeparable_adjoin_of_constantFieldExtension_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_finset_sum_neg_ord_eq_finrank_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_genus_riemannIndex_of_isCurveOver
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_genus_riemannIndex_of_stichtenothGenusExists
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_indexOfSpecialty_mapDomain_eq_zero_of_constantFieldExtension_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_indexOfSpecialty_nsmul_single_eq_zero_of_genusReached
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_poleDivisor_of_transcendental
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_riemannGenusReachedAt_nsmul_single_of_stichtenothGenusExists
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_separating_transcendental_of_perfectField
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteAlong_comp
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteAlong_of_surjective
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteDimensional_adjoin_of_transcendental
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteDimensional_lSpace
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteDimensional_lSpace_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finite_and_finrank_regularDifferentials_eq_genus
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finite_setOf_ord_ne_zero_of_finiteDimensional
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finrank_frobeniusSubfield_eq_of_transcendental
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finrank_le_and_natCard_places_le_of_constantFieldExtension_adjoin
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_functionFieldRiemannRoch_of_residueTheoremK_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_genusFF_eq_of_constantFieldExtension_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_genusFF_le_of_constantFieldExtension_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_genus_eq_genusFF
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_hasCanonicalDivisor_of_isCurveOver
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_hasPrincipalDivisors_adjoin_of_transcendental
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_hasPrincipalDivisors_of_finiteDimensional_of_isSeparable
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_hasPrincipalDivisors_of_finiteDimensional_ratFunc
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_hasPrincipalDivisors_of_transcendental
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_hasPrincipalDivisors_of_transcendental_of_isSeparable
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_finrank_H1
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_zero_of_genusReached
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_instIsCurveOverRatFunc
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isAlgebraic_adjoin_of_transcendental
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_iff_exists_transcendental_finiteDimensional
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_isAlgClosed_of_transcendental
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_transcendental
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_transcendental_of_isSeparable
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_transcendental_of_perfectField
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_ratFunc
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isIntegral_adjoin_intermediateField_mk
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isIntegral_adjoin_map_algHom
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isIntegral_adjoin_of_forall_mem_toValuationSubring
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isIntegral_adjoin_of_forall_ord_nonneg
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isIntegral_adjoin_of_isScalarTower
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_kaehlerRankOne_of_transcendental
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_lSpace_eq_bot_of_degree_neg
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_lSpace_mapDomain_subset_span_image_lSpace_of_constantFieldExtension_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_le_genusFF_of_constantFieldExtension_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_linearIndependent_of_constantFieldExtension
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_linearIndependent_of_constantFieldExtension_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_linearIndependent_pow_mul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_linearIndependent_pow_of_transcendental
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_mem_regularDiffs_iff
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_mem_riemannRochSpace_of_sum_basis_smul_algebraMap_mem_mapDomain
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_mem_span_range_algebraMap_of_constantFieldExtension_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_natCard_place_ord_sub_pos_le_natCard_doubleCoset
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_nonempty_place_of_transcendental_of_finiteDimensional
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_omegaSpace_finite_of_genusReached
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_regularDiffs_eq_regularDifferentials
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_residueTheoremK_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_residueTheoremK_ratFunc_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_residueTraceCompletionCommute
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_separableAlong_of_charZero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_six_mul_degree_eq_mul_finrank_of_forall_eq_weightFloor_of_ord_eq_three_two
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_stichtenothGenusExists_of_isCurveOver
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_sum_ordDiff_D_le_two_mul_genusFF_of_isSeparable
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_sum_ord_sub_one_le_two_mul_genusFF_of_isSeparable
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_tateAgreement
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_tateChainRule
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_tateCommFinite
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_tateTraceCompat_of_isSeparable
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_twelve_mul_eq_of_sum_ordDiff_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_weilDualityAdelic_of_functionFieldRiemannRoch_of_stichtenothGenusExists
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_weilDualityAdelic_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CohCarrier_index_gammaH_eq_index_gamma0_mul_index
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Complex_exists_hasDerivAt_of_starConvex
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Complex_integral_modularFundamentalDomain_eq_boundary_of_hasFDerivAt
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CongruenceSubgroup_Gamma0_le_closure_T_union_setOf_dvd
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CongruenceSubgroup_closure_T_U_neg_one_eq_Gamma0_three
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CongruenceSubgroup_conj_T_zpow_mem_Gamma1_of_mem_sup_zpowers_neg_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CongruenceSubgroup_eq_one_or_eq_neg_one_of_mem_Gamma1_of_smul_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CongruenceSubgroup_index_gamma1_sup_zpowers_neg_one_eq_three_mul_natCard_doubleCoset_and_eq_two_mul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CongruenceSubgroup_one_mem_strictPeriods_Gamma0
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspFormClass_isZeroAt_heckeT
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspFormClass_isZeroAt_heckeU
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_dimFormula_le_finrank_gamma0
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_eq_zero_of_prime_not_dvd_of_qCoeff_eq_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_exists_degeneracy_Gamma0
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_exists_gamma0_apply_eq_eta_mul_pow_twentyfour
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_exists_gamma0_four_apply_eq_eta_pow_mul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_finiteDimensional_Gamma0
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_finiteDimensional_of_isArithmetic
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_genusFormula_le_finrank_gamma0_weight_two
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_heckeTLin_comm
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_heckeTLin_heckeULin_comm
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_heckeULin_comm
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_EisensteinSeries_eisensteinG1_apply_smul_and_eisensteinG1_add
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_EisensteinSeries_exists_modularForm_coe_eq_eisensteinG
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_EisensteinSeries_hasSum_weierstrassZeta_sub_mul_G2
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_EisensteinSeries_isBoundedAtImInfty_eisensteinG1_and_hasSum_eisensteinG1
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_EisensteinSeries_qExpansion_eisensteinG_coeff
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_EisensteinSeries_sum_eisensteinG_vecCons_eq_mul_tsum_divisorSum_mul_cexp_pow
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_EisensteinSeries_weierstrassZeta_add_one_and_add_tau_and_smul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_EisensteinWeightOne_e1Chi3IsModular
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Field_nonempty_ringHom_complex_of_countable
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_charEq_on_torsionBy_of_line_of_isotropic
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_det_frobPencilEnd_eq_zero_iff_dvd_kerDeg
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_dvd_kerDeg_of_det_frobPencilEnd_eq_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_exists_prime_gt_and_quadratic_root
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_exists_x_linePencil_frobEnd_mul_collision_sq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_ne_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_frobCharEqOnPoints_of_frobenius
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_frobCharEqOnPoints_of_line
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_kerDeg_frobEnd_line_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_kerDeg_frobEnd_line_one_ne_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_kerDeg_frobEnd_line_one_pos_and_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_kerDeg_frobEnd_line_one_pos_and_eq_of_torsion
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_kerDeg_frobEnd_one_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_trace_det_frob_of_line_of_isotropic
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Function_exists_eq_apply_sub_of_sum_range_minimalPeriod_eq_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_HasRamBound_add
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_hasRamBound_C
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_hasRamBound_natCast
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_hasRamBound_natDegree_factorial_of_isRoot
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_hasRamBound_one_of_forall_ringEquiv_apply_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_hasRamBound_single_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_isAlgClosed_rat
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_mem_puiseuxRamSubfield_iff
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_add
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_binarySubst_adjugate_comp_smul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_eq_zero_of_eval_eq_const
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_exists_sub_eq_const
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_hasDerivAt_eval_iterate_pderiv
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_isBoundedAtImInfty_eval
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_slash
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_smul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_vadd_sub_T_zpow_apply_mem_range
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEquivariantPrimitiveWith_cocycle_sub_cocycle_mem_coeffCoboundaries
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_binaryFormAlphaAdj_comp_binaryFormRepSL_heckeConj
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_binaryFormRepSL_neg_one_apply
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_coeffH1par_binaryFormRepSL_eq_zero_of_odd
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_coeffH1par_map_heckeT_comm
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_coeffH1par_map_int_rat_injective
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_coeffHeckeFun_mem_coeffCoboundaries
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_coeffHeckeFun_mem_coeffCocycles
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_coeffHeckeFun_mem_coeffParabolicCocycles
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_coeff_single_one_eq_eval_of_mem_binaryForm
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_eichlerShimuraMap_add
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_eichlerShimuraMap_eq_coeffH1parMk
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_eichlerShimuraMap_heckeTLin
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_eichlerShimuraMap_heckeULin
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_eichlerShimuraMap_injective
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_eichlerShimuraMap_smul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_existsEichlerShimuraMapLinear
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_basis_coeffH1par_int_complex
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_coeffH1par_linearMap_coeffHeckeFun
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_coeffH1par_map_ringHom
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_coeffH1par_semilinearMap_starRingEnd
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_eichlerShimura_coeffH1par_binaryFormRepSL
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_eichlerShimura_coeffH1par_binaryFormRepSL_forall_prime
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_eichlerShimura_heckeEquivariant
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_eq_smul_X_pow_of_binaryFormRepSL_T_zpow_eq_self
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_eq_smul_X_pow_of_binaryFormRepSL_lowerUnipotent_eq_self
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_induced_binaryFormRepSL_top
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_isEichlerIntegral
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_isEichlerIntegral_isParabolicCocycle
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_ne_zero_smul_eq_coeffH1par_map_int_rat
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_pairing_binaryForm_linePow
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_finrank_coeffH1par_gamma0_le_finrank_coeffH1par_top_induced
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_finrank_coeffH1par_le_two_mul_dimFormula
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_finrank_coeffH1par_top_add_le
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_finrank_coeffH1par_zero_le_two_mul_genusFormula
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_isCompl_range_eichlerShimuraMap_range_conj
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_isEquivariantPrimitiveWith_of_isEichlerIntegral
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_isParabolicCocycle_cocycle_of_isEichlerIntegral
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_jFactor_pow_mul_eval_binaryFormRepSL
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_le_finrank_fixed_S_and_ST_binaryFormRepSL
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_le_finrank_fixed_induced_binaryFormRepSL
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_linearIndependent_coeffH1par_map_rat_complex
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_mem_range_binaryFormRepSL_T_zpow_sub_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_mem_span_range_coeffH1par_map_rat_complex
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_range_eichlerShimuraMap_inf_range_conj_eq_bot
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HexagonalLattice_summable_thetaTerm_and_tsum_neg_inv_three_mul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Ideal_IsMaximal_exists_adicCompletion_localization_ringEquiv
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Int_exists_squarefree_sq_add_mul_add_mul_sq_of_sq_lt_four_mul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_IntermediateField_finrank_fieldRange_le_of_adjoin_pair_eq_top
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_IsAddCyclic_of_squarefree_natCard
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_IsDedekindDomain_HeightOneSpectrum_exists_eq_span_singleton_of_map_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_IsDedekindDomain_HeightOneSpectrum_valuation_eq_exp_neg_count
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_IsDiscreteValuationRing_adicCompletion_isDomain_isDiscreteValuationRing_isAdicComplete
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_IsIntegral_mem_span_of_adjoin_simple_constants
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_IsIntegral_mem_span_of_adjoin_simple_constants_transcendental
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_KaehlerDifferential_D_ne_zero_of_transcendental
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_KaehlerDifferential_span_D_eq_top_of_transcendental
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_LaurentSeries_exists_algHom_comp_map_eq_single
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_LinearMap_charpoly_eq_iff_of_finrank_eq_two
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_LinearMap_charpoly_of_finrank_eq_two
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_LinearMap_trace_eq_of_sq_sub_smul_add_eq_zero_of_det_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Matrix_SpecialLinearGroup_exists_addMonoidHom_conj_T_pow_minimalPeriod_eq_of_finsum_eq_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Matrix_SpecialLinearGroup_exists_eq_mul_diagonal_mul_of_gcd_eq_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Matrix_SpecialLinearGroup_exists_generators_free_mod_neg_one_of_forall_trace_ne
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Matrix_SpecialLinearGroup_finrank_addMonoidHom_eq_of_forall_trace_ne
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Matrix_SpecialLinearGroup_nonempty_freeGroupBasis_map_quotient_center_of_forall_trace_ne
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_B3_exists_torsionBy_reduction_addEquiv
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_B3_exists_variableChange_specialFibre_goodModel
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_B3_goodModel_1728_spec
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_B3_goodModel_generic_spec
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_B3_goodModel_zero_spec
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_B3_isElliptic_specialFibre
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_B3_isElliptic_specialFibre_goodModel
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_B3_nearCurve_eq_ofJNe0Or1728
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_B3_specialisationEquivariance_level
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ComplexPlaceDictionaryOf_exists_pt_eq_of_mem
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ComplexPlaceDictionaryOf_ramification_eq_one_gamma1
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_CuspSpace_card_cuspSpace_eq_cuspCount
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_CuspSpace_classification
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_CuspSpace_exists_normalForm
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_CuspSpace_normalFormCriterion
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_E4_cube_div_discriminant_smul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_Gamma0_index
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_HahnSpecialise_specialiseCycSub_bijective
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_HahnSpecialise_specialiseCycSub_injective
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_HahnSpecialise_specialise_bijOn_torsion
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_JOneES_exists_transcendental_finiteDimensional_laurentBaseChange
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_JOneES_exists_transcendental_finiteDimensional_qExpFunctionFieldC
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_Descent_fixer_le
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_algHom_laurentBaseChange_apply_eq_qExpand
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_algHom_laurentSeries_qExpansion
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_linearMap_regularDifferentials_cuspForm_injective
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_linearMap_regularDifferentials_mdifferentiable
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_monic_eval_eq_zero_coeff_eq_aeval_inv_div_of_forall_valuation_le_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_monoidHom_algEquiv_fixedField_eq_adjoin
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_place_analyticOrderAt_eq_mul_ord
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_place_ord_jGen_eq_three_two_and_stabilizer_subset_zpowers
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_place_ord_jGen_le_two_three_level
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_place_ord_neg_forall_smul_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_place_ord_sub_pos_forall_smul_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_isDomain_ring
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_isZeroAtImInfty_slash_of_mem_regularDifferentials
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_slash_eq_self_of_mem_Gamma_of_mul_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_twelve_mul_add_mul_index_le_genusFF
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_valuation_apply_smul_le_one_of_tendsto_div_smul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eq_of_prime
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_E4_cube_div_discriminant_coset_eq_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_E4_cube_div_discriminant_smul_eq_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jLattice_eq_zero_of_isAddCyclic
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_mul_eq_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_of_mul_eq_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_hasRamBound_three_of_isRoot_at_zero_of_odd
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_hasRamBound_two_of_isRoot_at_1728_of_odd
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_isIntegral_jqN
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_isRoot_map_j_veluQuotient_j_of_addOrderOf_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_isUnit_leadingCoeff_diag
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_isUnit_leadingCoeff_diag_of_not_isSquare
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental_of_odd
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_transposeToAdjoin_monic_of_qExpansion
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_Period_existsUnique_isParabolicHom_sup_zpowers_neg_one_apply_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_Period_exists_basis_parabolicHoms_castAddHom_comp
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_Period_exists_basis_parabolicHoms_of_isAddTorsionFree
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_Period_finrank_parabolicHoms_add_natCard_le_finrank_addMonoidHom_add_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_Period_six_mul_finrank_parabolicHoms_add_le_index
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_PhiGenDescends_c_eq_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_PhiGenDescends_c_top
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_PhiGenDescends_hasSum_cosetPoly_coeff
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_PhiGenDescends_intCoeffs
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_PhiGenDescends_poleOrderLE
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_PhiGenDescends_sum_mul_jqN_pow_eq_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_aeval_jq_intCoeffs_descent
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_conj_injective
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_evalAtJ_injective
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_evalSymm_of_coeff_evalAtJ_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_evalSymm_of_splits
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_exists_galoisPerm
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_exists_modularPolynomialData_coeff_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_exists_phiGenDescends
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_mem_adjoin_jq_of_phiGenDescends
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_mem_range_coeffEmb_of_forall_coeffMap_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_mem_range_coeffEmb_qExpand_of_mem_inter
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_phiIrreducible_of_splits
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_phiProd_conj_coeff_eq_zero_of_le
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_phiProd_conj_coeff_zero_lead
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_of_coeff_evalAtJ_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_of_prime
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot_of_isPrimitiveRoot
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_sum_qTwist_coeff
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_closure
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_count
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_deltaNorm
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_delta_pow_ne
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_eisInt_not_dvd_num
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_eisInt_series
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_hassePolyDescent
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_onePoint
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_press
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_starBank
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_starK
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_TatePoint_b3Act_dictN_of_monodromy
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_TatePoint_fullKernelDiscAt
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_TatePoint_fullKernelDiscAt_of_odd
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_TatePoint_fullKernelInjAt
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_TatePoint_fullKernelIsRootAt
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_TatePoint_fullKernelIsRootAt_of_odd
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_adjoin_jBar_jNBar_eq_top
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_aeval_jqN_toAdjoin
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_aeval_jq_eq_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq_pow
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_jqModC_pow
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_card_eq_cuspCount_of_forall_mem_iff_ord_jBar_neg
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_card_eq_natCard_moduliPoint_j_eq_of_EMD
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_card_eq_natCard_quot_samePlace_of_forall_mem_iff_pos_ord
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_card_projectiveLine_zmod
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_card_roots_fibrePoly_of_monic
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coe_frickeInvolutionFull_eq_of_hasSum_of_gamma0_invariant
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coe_frickeInvolutionFull_modularUnitSeries
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coe_qExpansion_normalizedDerivOfComplex
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_injective
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jqN
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_qExpand
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_injective
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_eq_zero_of_hasSum_of_slash_invariant
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_neg_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_pow_of_lt
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_pow_self
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_cosetPoly_smul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_cuspZeroBar_ne_cuspInftyBar
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_le_finrank_adjoin_qExpFunctionFieldC_gamma0
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_mul_of_coprime
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_of_squarefree
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_pos
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime_pow
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_deg_eq_one_modularFunctionFieldBar
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_deg_jLinePlace1728
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_deg_jLinePlaceZero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_deg_ne_zero_modularFunctionFieldC
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_degree_add_one_sub_genusFF_le_finrank_riemannRochSpace
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_degree_canonicalDivisorOf_modularFunctionFieldBar
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_diffQExpBar_injective_of_neZero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_discriminant_div_discriminant_heckeDiagMatrix_smul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_eisenstein4_mul_thetaL_delta_sub_eq_eisenstein6_mul_delta
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_emd_holds
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_emd_of_beta_docks
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_eq_cuspInftyBar_or_eq_cuspZeroBar
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_eq_jLinePlace1728_iff_ord_jGen_sub_pos
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_eq_jLinePlaceInfty_iff_ord_jGen_neg
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_eq_jLinePlaceZero_iff_ord_jGen_pos
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_eq_zero_of_forall_re_periodOf_eq_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_essFiniteType_modularFunctionFieldBar
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_evalAtJGen_injective
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_even_ord_add_ord_of_not_mem_toValuationSubring_laurentBaseChange_gamma1
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_even_ord_add_weightFloor_of_mem_toValuationSubring_laurentBaseChange_gamma1
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_eventually_norm_slash_le_mul_of_isIntegral_adjoin_jqModC_inv_sq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv_pow
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_aeval_jq_sub_holomorphicAtInfty
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_algHom_laurentBaseChange_slot
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_algHom_of_isRoot
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_apply_eq_of_forall_ord_eq_zero_tendsto_realizeOf
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_complexPlaceDictionaryOf
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_cuspForm_coeffMap_diffQExpBar_eq_qExpansion_of_mem_regularDifferentialsBar
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_cuspForm_qExpansion_eq_coeffMap_mul_thetaL_pow_of_isIntegral
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_cuspForm_qExpansion_eq_mul_thetaL_of_isIntegral
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_cuspForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_divisor_degree_weight_and_isIntegral_of_mem_riemannRochSpace
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_divisor_two_mul_eq_ord_add_weightFloor_one_laurentBaseChange_gamma1
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_elliptic_cycSub_orbitMap
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_elliptic_cycSub_orbitMap_of_props
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_emb_equiv_rootsAt
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_finset_ord_jBar_sub_pos
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_gamma0_qExpansion_div_eq_jqNModC
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_hasEquivariantPrimitiveOf
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_intSeriesC_mul_ne_of_gamma0Units_not_mem
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_irreducible_ramificationIndex_eq_ord_aeval_of_restrict_ne_jLinePlaces
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_isFrickeAut
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_isFrickeAutFull
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_isFrickeAut_of_modularPolynomialData
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_isIntegralQExp_smul_of_ratCast_qExpansion
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_isIntegralQExp_smul_slash_of_mem_Gamma0
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_modularForm_gamma1_qExpansion_eq_mul_pow_of_qExpansion_eq_sq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_modularForm_gamma1_qExpansion_eq_mul_thetaL_pow_of_isIntegral
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_coeffEmb_qExpand_jq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC_of_T_mem
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_monic_evalAtJ_jqN_eq_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_monoidHom_gamma0_algEquiv_qExpFunctionFieldC_gammaH_of_charZero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_mvPolynomial_mul_aeval_fricke_eq_of_qExpansion_coeff_mem
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_natCard_quot_samePlace_eq_natCard_quot_sameOrbit_of_EMD
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_ne_zero_forall_intCast_mul_qExpansion_coeff_of_gamma_invariant
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_ne_zero_forall_mul_qExpansion_coeff_fricke_mem_adjoin
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_perm_gamma0_cosetReps
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_of_finrank_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_place_algebraicClosure_ord_comp_eq_of_laurentBaseChange
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_place_of_emb
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_ratCast_qExpansion_comp_smul_of_mem_Gamma0
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_ratCast_qExpansion_slash_of_mem_Gamma0
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN_qExpansion
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_ringHom_place_order_eq_mul_ord_of_qExpansion_slash
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_sl2_heckeDiagMatrix_smul_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_slot_of_isCusp
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_smul_eq_of_E4_cube_div_discriminant_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_tendsto_div_smul_of_eventuallyEq_realizeOf_of_tendsto
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_tendsto_realizeOf_mul_exp_of_not_mem_toValuationSubring
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_transcendental_finiteDimensional_qExpFunctionFieldC_residueField
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_full
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_of_neZero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_adjoin_jqNModC
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_and_finrank_adjoin_jqModC_qExpFunctionFieldC_le_index
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_and_finrank_adjoin_le_of_eq_coeffMap
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_riemannRochSpace_laurentBaseChange_qExpFunctionFieldC_gamma1
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finite_cycSub
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_le_index
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqModC_modularFunctionFieldFullC_eq_dedekindPsi
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqModC_qExpFunctionFieldC_le_index_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqNModC_eq_dedekindPsi_of_socket
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqNModC_eq_of_prime
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqNModC_le
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqN_eq_dedekindPsi
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqN_eq_of_prime
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqN_eq_of_squarefree
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqN_pow_succ_of_not_mem
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqN_prime_of_not_mem
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_qExpFunctionFieldC_le_of_valuationSubring
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_jAdjoin_modularFunctionField_eq_dedekindPsi
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_parabolicHoms_Gamma_le_two_mul_finrank_cuspForm
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_isCongruenceSubgroup
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_le_of_normal
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_parabolicHoms_le_two_mul_genusFormula
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_frickeInvolutionBar_coeffEmb_qExpand
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_frobenius_identity_geom_unconditional
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_full_eq_adjoin_full_div_prime
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_full_eq_adjoin_primes
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_full_eq_of_prime
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration_iff_full_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration_of_prime
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration_of_squarefree
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldRiemannRoch_modularFunctionFieldBar
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_gammaFundamentalSet_boundary_sidePairing_of_slash_eq_add
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_genus_eq_genusFF_modularFunctionFieldBar
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_genus_modularFunctionFieldBar_eq_genusFormula
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasCanonicalDivisor_modularFunctionFieldBar
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull_unconditional
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasPrincipalDivisors_modularFunctionFieldBar
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasPrincipalDivisors_modularFunctionFieldBar_unconditional
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_jNum_qParam
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_jq_qParam
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_modularUnitSeries_inv_qParam
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_modularUnitSeries_qParam
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_heckeDiagMatrix_smul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_heckeMatrix_smul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_mul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_mul_laurent
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_smul_modularUnitSeries_inv_qParam
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_smul_modularUnitSeries_qParam
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_index_le_relfinrank_qExpFunctionFieldC_gamma0_gammaH_of_charZero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCurveOver_laurentBaseChange_qExpFunctionFieldC_gamma1
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCurveOver_modularFunctionFieldBar
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCusp_cuspInftyBar
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCusp_cuspZeroBar
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCusp_iff_ord_neg
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isFrickeAutFull_frickeInvolutionFull_prime
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder_of_finiteIndex
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_adjoin_jq_modularUnitSeries
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_adjoin_jq_modularUnitSeries_inv
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_adjoin_jq_of_hasSum_of_gamma0_invariant
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_and_isIntegral_of_mem_riemannRochSpace_weightFloor
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_and_isIntegral_of_smul_D_mem_regularDifferentialsBar
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_jqNModC_all
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_jqNModC_all_of_modularPolynomialFamily
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_jqNModC_mul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_jqNModC_of_modularPolynomialData
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isRoot_map_Phi_apply_jBar
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isSeparable_adjoin_coeffEmb_jq_full
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jCoordinate_spec_modularFunctionFieldBar
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_mem_intFormRatiosC
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqNModC_mem_modularFunctionFieldC_mul_prime
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqNModC_prime_not_mem_adjoin_of_charZero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqNModC_prime_not_mem_fullC
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqN_div_mem_modularFunctionField
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqN_pow_not_mem_adjoin_full
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqN_prime_not_mem_adjoin
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqN_prime_not_mem_full
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_adjoin
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_adjoin_pair
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_modularFunctionField
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_modularFunctionFieldFull
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_mono
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_qExpFunctionFieldC_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurent_qParam_coeff_unique
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_le_dedekindPsi
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_map_intCast_pow_char_eq_qExpand
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_mem_adjoin_jq_of_hasSum_of_slash_invariant
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_mem_modularFunctionField_of_hasSum_of_gamma0_invariant
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_mem_range_qExpand_of_qTwist_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_minpoly_jqNModC_map_eq_prod_slots
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_minpoly_jqN_eq_toAdjoin
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_minpoly_jqN_map_eq_prod_slots
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularFunctionFieldBar_eq_restrictScalars
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularFunctionFieldFullC_le_qExpFunctionFieldC_gamma0
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularFunctionField_eq_full
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularFunctionField_eq_full_of
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularPolynomialFamily
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularUnitSeries_mem_modularFunctionField
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularUnitSeries_mem_modularFunctionFieldFull
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_doubleCoset_le_card_fibres_of_finrank_eq_index
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_fixedPoints_ST_cosets_Gamma0_eq_nuThree
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_fixedPoints_S_cosets_Gamma0_eq_nuTwo
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_moduliPoint_j_eq_eq_natCard_quot_addOrderOf_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_normalized_algHom_hahnSeries_jBar_sub_eq_toNat_ord
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_normalized_algHom_jBar_eq_toNat_ord
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_orbitRelQuotient_zpowers_T_gamma0_eq_cuspCount
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_ord_jBar_eq_one_eq_nuThree
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_place_ord_neg_laurentBaseChange_gamma1_eq_natCard_doubleCoset
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_quot_sameOrbit_cycSub_eq_natCard_moduliPoint_j_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_neg_width_le_ord_of_order_eq_mul_ord_of_qExpansion_slash
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_equiv_place_pos_ord_algHom_integralClosure
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_integralWeightOneForm
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_modularPolynomialData
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_modularPolynomialData_of_squarefree
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_one_le_coeff_jq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_cuspInftyBar
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_cuspInftyBar_coeffEmb_jq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_cuspInftyBar_coeffEmb_qExpand
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_cuspZeroBar_coeffEmb_jq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_cuspZeroBar_coeffEmb_qExpand
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_eq_neg_width_of_order_eq_mul_ord_of_qExpansion_slash
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1_algebraicClosure
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_eq_zero_of_not_mem_of_realizeOf_tendsto
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_jBar_dvd_three
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_jBar_sub_1728_dvd_two
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_jBar_sub_eq_one_of_ne_zero_of_ne
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_jLinePlace1728_jGen_sub
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_jLinePlaceZero_jGen
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_qInftyPlaceBar
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_sub_algebraMap_le_one_laurentBaseChange_qExpFunctionFieldC_of_ne_zero_of_ne_1728
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_order_coeffEmb
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_order_jqModC
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_order_qExpand
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_package_of_socket
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_periodMapOf_apply_eq_periodOf
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_periodMapOf_mem_parabolicHoms
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_periodOf_apply_eq_sub_of_hasEquivariantPrimitiveOf
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_place_eq_of_induces
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpand_image_intFormRatiosC_subset
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpand_jqModC_eq_pow_unconditional
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_E4_eq_map_eisenstein4
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_E6_eq_map_mk
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_discriminant_eq_X_mul_tprod
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qParam_coeff_unique
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ramificationIndex_eq_ord_of_restrict_eq_jLinePlaceZero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ramificationIndex_eq_ord_sub_of_restrict_eq_jLinePlace1728
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ratPoint_eq_ratPoint_iff_of_isCoprime
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_realizeOf_eq_div
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_fullC_mul_prime_pow
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_eq_dedekindPsi
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_eq_mul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_of_squarefree
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_laurentBaseChange
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_laurentBaseChange_modularFunctionFieldFull
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_modularFunctionField
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_restrict_eq_jLinePlace1728_iff
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_restrict_eq_jLinePlaceInfty_iff
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_restrict_eq_jLinePlaceZero_iff
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_sameOrbit_iff_eq_of_c4_ne_zero_of_c6_ne_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_samePlace_iff_exists_hahnTwist
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_samePlace_iff_exists_monodromy
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_six_mul_level_mul_finrank_parabolicHoms_Gamma_add_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_slot_ord_of_algHom_laurentBaseChange
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_slot_place_eq_iff_modEq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_sum_neg_ord_jBar_eq_dedekindPsi
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_sum_ord_jBar_sub_eq_dedekindPsi
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_tendsto_atImInfty_of_hasSum_qParam
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_thetaL_coeffMap_eq_coeffMap_single_mul_derivative
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_thetaL_jq_mul_deltaSeries
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_thetaL_jq_mul_eisenstein4_eq_neg_jq_mul_eisenstein6
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_theta_coeff
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_theta_mul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_three_mul_natCard_moduliPoint_j_eq_zero_eq_dedekindPsi_add_two_mul_nuThree
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_and_finiteDimensional_adjoin_laurentBaseChange_of_coe_eq_coeffEmb
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_coeffEmb_jq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_of_coe_eq_coeffEmb_jq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_twelve_mul_add_mul_index_le_finrank_cuspForm_Gamma
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_two_mul_genusFF_add_card_fibres_eq_finrank_add_two_of_gamma1_le
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_two_mul_genusFF_add_card_fibres_le_finrank_add_two_of_gamma1_le
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_two_mul_natCard_moduliPoint_j_eq_1728_eq_dedekindPsi_add_nuTwo
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularFormClass_eq_of_forall_qCoeff_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularFormClass_heckeT_heckeT_comm
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularFormClass_heckeT_heckeU_comm
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularFormClass_heckeU_heckeU_comm
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularFormClass_isBoundedAt_heckeT
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularFormClass_isBoundedAt_heckeU
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularFormClass_qCoeff_comp_heckeDiagMatrix_smul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_coeffHeckeT_coeffHeckeU_comm
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_coeffHeckeT_comm
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_coeffHeckeU_comm
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_eq_zero_of_lt_order_qExpansion_of_isArithmetic
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_coe_eq_of_levelOne
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_cuspForm_mul_eq_of_analyticOrderAt_le
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_degeneracy_Gamma0
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_gamma0_qExpansion_eq_of_levelOne
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_gamma1_isIntegralQExp_eisenstein_four_six
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_gamma1_weightOne_ne_zero_and_mul_thetaL_eq_qExpansion_sq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_gamma1_weight_four_isIntegralQExp_partialDivisorSum_slash_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card_of_even
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card_of_odd
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_modularForm_mul_eq_of_analyticOrderAt_le_of_finiteIndex
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_qExpansion_eq_aeval_mul_pow_levelOne
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_rankinCohen_one_qExpansion_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_tendsto_slash_div_qParam_pow_of_conj_T_pow_mem
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_weightOne_eisenstein_qCoeff_eq_of_isPrimitive_of_odd
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_weight_one_gamma1_three_slash_fricke_eq_smul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_finiteDimensional_of_isArithmetic
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_heckeT_slash_eq_self_of_mem_Gamma0
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_heckeU_slash_eq_self_of_mem_Gamma0
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_isBoundedAtImInfty_heckeT
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_isBoundedAtImInfty_heckeU
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_isIntegral_adjoin_qExpansion_div_discriminant_pow_of_isArithmetic
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_eq_zero_of_lt_order_qExpansion
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_four_qCoeff_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_six_qCoeff_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_mdifferentiable_heckeT
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_mdifferentiable_heckeU
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_periodic_heckeT_comp_ofComplex
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_periodic_heckeU_comp_ofComplex
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_qExpansion_E4_mul_theta_discriminant_sub
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_qExpansion_heckeDiagMatrix_smul_eq_qExpand_of_levelOne
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_weierstrassP_torsion_qExpansion_package
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularGroup_exists_eq_conj_T_zpow_of_trace_sq_eq_four
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularGroup_exists_mulEquiv_freeProduct_quotient_center
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_MonoidAlgebra_isLocalRing_of_isPGroup
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Monoid_CoprodI_exists_addMonoidHom_conj_pow_minimalPeriod_eq_of_finsum_eq_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Monoid_CoprodI_isTree_cosetGraph
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Monoid_CoprodI_nonempty_freeGroupBasis_fin_kuroshRank
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_MulAction_card_mul_natCard_orbitRel_quotient_eq_of_natCard_eq_prime
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_MvPolynomial_IsHomogeneous_iterate_pderiv_eq_zero_of_lt
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Nat_exists_squarefree_sq_add
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_NumberField_exists_isFrobenius_lift_arithFrobAt
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_NumberField_exists_lift_mem_inertia_integralClosure
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_NumberField_exists_valuationSubring_eq_localization
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_adicValuation_valuationSubring
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_exists_ord_pos
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_isEquiv_adicValuation_ofHeightOneSpectrum
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_isEquiv_adicValuation_of_valuationSubring_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_iff_adicValuation_le_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_iff_ord_nonneg
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_maximalIdeal_iff_adicValuation_lt_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_of_ord_nonneg
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_eq_zero_iff_adicValuation_eq_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_neg
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_nonneg_of_mem
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_ofHeightOneSpectrum_ne_zero_iff
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_deg_ofHeightOneSpectrum
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_eq_ofHeightOneSpectrum_or_eq_placeInfty
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_eq_placeOfPoint_or_eq_placeInfty
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_placeInfty_ne_ofHeightOneSpectrum
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_discriminant_ne_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_exists_differentiable_toPoint_comp_eq_pointMapOfPushforward_toPoint
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_and_isAddCyclic_sublatticeQuotient
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_exists_variableChange_smul_weierstrassCurve_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_isUniformization_toPoint
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_jLattice_ofTau
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_jLattice_surjective
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_lattice_eq_of_g2_eq_of_g3_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Polynomial_irreducible_of_transitive_ringAut
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Polynomial_mem_range_of_eval_eq_const
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Polynomial_mem_range_of_unique_common_root
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_PowerSeries_mem_range_map_of_monic_of_mul_mem_range
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Rep_finiteDimensional_coind_and_finrank_coind_eq_index_mul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_SimpleGraph_exists_walkConnected_transversal_of_preconnected
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Subgroup_IsArithmetic_exists_nat_mem_strictPeriods_conj
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Subgroup_card_orbitRelQuotient_mul_card_eq_index
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_TateModule_exists_linearEquiv_rationalTateModule_comp_rationalGaloisRep_eq_of_addEquiv
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_TateModule_exists_linearMap_apply_eq_of_addMonoidHom
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_apply_add_eq_apply_of_hasDerivAt_of_isZeroAtImInfty
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_eq_of_forall_qCoeff_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_isBoundedAtImInfty_of_hasDerivAt_of_periodic
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_linearIndependent_complex_of_qExpansion_coeff_mem
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_qCoeff_comp_heckeDiagMatrix_smul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_qCoeff_heckeT
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_qCoeff_heckeU
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_qExpansion_coeff_mul_width
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_qExpansion_prod
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ValuationSubring_IsFrobeniusAt_apply_eq_pow_of_pow_prime_pow_eq_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ValuationSubring_exists_inertiaSubgroup_restrictNormal_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ValuationSubring_exists_liesOverPrime_algebraicClosure_rat
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ValuationSubring_exists_liesOverPrime_mem_inertiaSubgroupIn
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ValuationSubring_isDiscreteValuationRing_comap_of_liesOverPrime
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ValuationSubring_isFrobeniusAt_of_forall_smul_sub_pow_mem
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_Valuation_eq_comap_of_valuationSubring_le_comap
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_exists_analyticOnNhd_div_of_monicRel
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_exists_levelFraction_of_stable_family
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_exists_mdifferentiable_div_of_monicRel
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_exists_monicRel_j_K_of_mdifferentiable_frickeQuotient
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_exists_monicRel_j_of_mdifferentiable_levelFraction
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_exists_qExpansion_coeff_mem_of_mdifferentiable_levelFraction
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_intBaseChange
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_modularity_package
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_orbit_package
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelN_structure_package
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelOne_hauptmodul_package
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_linearIndependent_complex_of_qExpansion_rational
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_qExpansion_sigmaTransport_package
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_weierstrassP_qExpansion_package
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_eq_XYIdeal_iff
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isPrincipal_prod_XYIdeal_zpow_iff
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_natDegree_norm_eq_finsum_count
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_addX_addY_specialize_at_place
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_adjoin_X_Y_eq_top
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_eq_valuationSubring_of_X_not_mem
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_exists_eq_algebraMap_of_valuation_eq_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_exists_eq_valuationSubring_of_X_mem
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_exists_valuation_eq_exp_natDegree_norm
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_GenusOnePlaceGate_ext_of_isCentred
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyEndDatum_aeval_j_diag_eq_zero_of_finrankAlong_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_dualEndData_dual_mem_and_norm_eq_finrankAlong
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_forall_pointEnd_eq_zsmul_of_transcendental_j
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_pointEnd_eq_add
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_pointEnd_eq_of_mem_isogenyEndSubring
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_restrictAlong_placeOfPoint_eq_add
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_sq_lt_four_mul_and_forall_exists_finrankAlong_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyEndDatum_pointEnd_apply_eq_sub
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyHomDatum_exists_pointHom_comp_eq_of_ker_le_of_isCentred
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyHomDatum_pointHom_apply_eq_sub
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_card_ker_eq_max_natDegree
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_exists_zsmul_eq_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_exists_zsmul_some_eq_some_baseChange
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_natDegree_parallelogram_law
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_smul_some_eq_zero_iff
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_some_add_some_eq_neg_some_of_pow_three_eq_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_some_zero_add_self_eq_neg_of_a6_model
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_two_smul_some_eq_zero_iff
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_vcInvFun_add
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_vcInvFun_neg_heq_neg
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_zsmul_some_eq_some_div
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_zsmul_x_mul_psi_sq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_zsmul_y_mul_psi_cube
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_adjoin_yCoord_eq_top
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_algHom_ext_of_forall_restrictAlong_placeOfPoint_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_deg_ofHeightOneSpectrum_eq_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_eq_placeOfPoint_some_of_XClass_mem_nonunits_of_YClass_mem_nonunits
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_eq_zero_of_forall_transEquiv_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_evalEval_psi_sq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_algEquiv_restrictAlong_placeOfPoint_eq_add
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_algHom_baseChange_of_isAddCyclic_ker_pointMapOfPushforward
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_algHom_functionField_baseChange_finrankAlong_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_abelTheorem
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_and_abelTheorem
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_infinitePlace_deg_eq_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_intermediateField_countable_map_eq_of_isAddCyclic_ker_pointMapOfPushforward
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_map_weilFun_eq_mul_weilFun_smul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_transEquiv_weilFun_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_fibSet_finite
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_finiteDimensional_ratFunc_functionField
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_finrank_fieldRange_mulPull_le
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_forall_normFormulaAlong_of_isAlgClosed_of_charZero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_isAddCyclic_ker_pointMapOfPushforward_of_algEquiv_conj
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_isAddCyclic_ker_pointMapOfPushforward_of_baseChange_algHom
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_ker_pointMapOfPushforward_eq_of_j_eq_of_forall_pointEnd_eq_zsmul
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_natCard_ker_pointMapOfPushforward_eq_finrankAlong
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_ncard_fibSet
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_pointMapOfPushforward_surjective
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_mulPull_le_of_ne_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_placeOf_neg_transEquiv_algebraMap
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_placeOf_smul_of_algEquiv
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_transEquiv_le
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_transEquiv_le_self
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_transEquiv_weilFun
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_weilFun
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_weilNum
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_weilFun_ne_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_weilNum_ne_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_weilPairing0_add_left
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_weilPairing0_add_right
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_weilPairing0_galois
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_weilPairing0_self
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_zsmul_genericPoint_good
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Delta_eq_veluGx_sq_mul_velu2QuadDisc
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Psi2Sq_ne_zero_of_isElliptic
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsionBy_eq_sq_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsion_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsion_of_isAlgClosed_light
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_eq_zero_of_smul_eq_zero_of_reducePoint_eq_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_eval_psi2Sq_veluQuotient_veluX_eq_zero_of_eval_psi2Sq_eq_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_addEquiv_point_baseChange_variableChange_smul_algEquiv
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_addEquiv_point_of_variableChange_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_addEquiv_point_variableChange
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_addMonoidHom_coe_eq_veluPointMap2
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_pow_three_eq_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_sq_eq_neg_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_functionFieldHom_fullKernelQuotient_pointMapOfPushforward_ker_eq_zmultiples
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_intermediateField_countable_map_eq_and_finrankAlong_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_isUnit_discriminant_and_c4_cube_eq_mul_X_cube_powerSeries
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_isUnit_discriminant_and_c6_sq_eq_mul_X_sq_powerSeries
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_pairing_torsionBy
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_valuation_eq_exp_of_not_le_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_velu2FunctionFieldHom_restrictAlong_placeOfPoint_veluPointMap2
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples_of_oddOrder
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_veluFunctionFieldHom_restrictAlong_placeOfPoint_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_fiberAdd_asymWeight_cleared_sixteen
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_fiberAdd_veluGx_cleared_four
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_finite_torsionBy_of_natCast_ne_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_frobenius_cayleyHamilton_on_torsion
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_fullKernelQuotient_eq_veluQuotient_of_odd
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_galoisRepUnramifiedAt_of_hasGoodReduction
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_hasGoodReduction_baseChange_of_valuation_lt_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_hasRamBound_one_of_nsmul_eq_zero_of_isUnit_discriminant_powerSeries
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_isCoprime_Phi_PsiSq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_isElliptic_veluQuotient2_of_isElliptic
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_j_mem_of_a_mem
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a4_eq_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a6_eq_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuThree
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuTwo
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_natDegree_Phi_sub_C_mul_PsiSq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_nonempty_functionField_algEquiv_of_variableChange
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_nonempty_torsionBy_addEquiv_zmod_prod_of_isAlgClosed
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_reducePoint_add
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_reducePoint_some
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_reducePoint_some_add_some_of_le_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_reducePoint_some_add_some_of_not_le_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_reducePoint_some_eq_zero_iff
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_sum_eq_zero_of_forall_mem_iff_smul_eq_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_tateModuleRep_charpoly_frobenius
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_tateModuleRep_detIsCyclotomic
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_tateModuleRep_det_frobenius
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_tateModuleRep_isUnramifiedAt_of_isGoodPrimeFor
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_valuation_le_one_of_equation
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_variableChange_mk_smul_eq_self_of_pow_three_eq_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_variableChange_mk_smul_eq_self_of_sq_eq_neg_one
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_variableChange_smul_eq_self_iff_of_c4_ne_zero_of_c6_ne_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_velu2QuadDisc_ne_zero_of_two_torsion
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_velu2_line_image_factored
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_velu2_tangent_addX_cleared_identity
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_velu2_tangent_negAddY_cleared_identity
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_velu2_tangent_negAddY_cleared_identity_factored
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_veluGx_ne_zero_of_two_torsion
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_veluQuotient2_Delta_eq
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_veluQuotient2_Delta_ne_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_veluQuotient_j_mem_of_mem
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_veluQuotient_oddOrderSummingSet_discriminant_ne_zero
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_veluX_oddOrderSummingSet_injOn_psi2Sq_roots
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_velu_map_equation_of_oddOrderSummingSet
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_zmultiples_eq_of_veluQuotient_j_eq_of_forall_isogenyEndDatum_exists_int
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_zmultiples_eq_of_veluQuotient_j_eq_of_transcendental
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ZMod_natCard_isAddCyclic_addSubgroup_prod_eq_dedekindPsi
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ZMod_natCard_isAddCyclic_addSubgroup_prod_map_eq_nuThree
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_ZMod_natCard_isAddCyclic_addSubgroup_prod_map_eq_nuTwo
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_omegaRow_T2
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AddCommGroup_natCard_isAddCyclic_addSubgroup_eq_dedekindPsi_of_addEquiv_torsionBy.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AddCommGroup_natCard_isAddCyclic_addSubgroup_eq_dedekindPsi_of_addEquiv_torsionBy.lean
new file mode 100644
index 0000000000..b4b41b1cfb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AddCommGroup_natCard_isAddCyclic_addSubgroup_eq_dedekindPsi_of_addEquiv_torsionBy.lean
@@ -0,0 +1,143 @@
+/-
+Based on Prove2Me node
+AddCommGroup.natCard_isAddCyclic_addSubgroup_eq_dedekindPsi_of_addEquiv_torsionBy
+(f0b6d6df-0db0-5a8f-baf6-97c9def0bb3a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5f2d5eb4-3c9a-5031-88de-79879aca740d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ZMod_natCard_isAddCyclic_addSubgroup_prod_eq_dedekindPsi
+
+/-!
+# Groups with n-torsion (ℤ/n)² have ψ(n) cyclic subgroups of order n
+
+Theorem statement:
+`AddCommGroup.natCard_isAddCyclic_addSubgroup_eq_dedekindPsi_of_addEquiv_torsionBy`
+(`f0b6d6df-0db0-5a8f-baf6-97c9def0bb3a`), by Claude, 2026-09-05.
+
+Proof: submission `5f2d5eb4-3c9a-5031-88de-79879aca740d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $n$ be a natural number, assumed nonzero, and let $A$ be an additive commutative group. Suppose
+given an isomorphism $e$ of additive groups from $\mathbb Z/n \times \mathbb Z/n$ onto
+`Submodule.torsionBy ℤ A n`, the $\mathbb Z$-submodule of $A$ consisting of those $x$ with $n \cdot
+x = 0$, i.e. the $n$-torsion subgroup $A[n]$. Then the cardinality (in the sense of `Nat.card`) of
+the type of subgroups $H \le A$ satisfying both `IsAddCyclic H`, i.e. $H$ is generated by a single
+element, and $\operatorname{card} H = n$, equals [`ModularCurve.dedekindPsi
+n`](def/ModularCurve_X0.html#L201), which is by definition the sum $\sum_{d \mid n,\ d \text{
+squarefree}} n/d$; this is the Dedekind value $\psi(n) = n\prod_{p \mid n}(1 + 1/p)$. In particular
+the assertion includes that there are only finitely many such subgroups, since otherwise the
+left-hand side would be $0$ while $\psi(n) \ge 1$.
+
+This is the group-theoretic count underlying the fact that an elliptic curve whose $n$-torsion is
+full has exactly $\psi(n)$ cyclic subgroups of order $n$, i.e. $\psi(n) = \deg$ of the degeneracy
+data counting cyclic $n$-isogenies, and hence the number of points of $X_0(n)$ above a given
+$j$-invariant in the generic situation. It is used in the project's work on modular curves and
+modular polynomials, for instance in the analysis of fibres of the modular polynomial and in
+supersingular point counts.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AddCommGroup_natCard_isAddCyclic_addSubgroup_eq_dedekindPsi_of_addEquiv_torsionBy.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace Transport
+
+open AddSubgroup
+
+variable (N : ℕ) {E A : Type*} [AddCommGroup E] [AddCommGroup A]
+
+theorem isAddCyclic_map_and_card_of_injective (f : A →+ E) (hf : Function.Injective f)
+    {K : AddSubgroup A} (h : IsAddCyclic K ∧ Nat.card K = N) :
+    IsAddCyclic (K.map f) ∧ Nat.card (K.map f) = N ∧ K.map f ≤ f.range := by
+  obtain ⟨h1, h2⟩ := h
+  have : IsAddCyclic K := h1
+  refine ⟨?_, ?_, AddSubgroup.map_le_range f K⟩
+  · exact isAddCyclic_of_surjective (K.equivMapOfInjective f hf)
+      (K.equivMapOfInjective f hf).surjective
+  · rw [← Nat.card_congr (K.equivMapOfInjective f hf).toEquiv, h2]
+
+theorem isAddCyclic_comap_and_card_of_le_range (f : A →+ E) (hf : Function.Injective f)
+    {H : AddSubgroup E} (hcyc : IsAddCyclic H) (hcard : Nat.card H = N) (hle : H ≤ f.range) :
+    IsAddCyclic (H.comap f) ∧ Nat.card (H.comap f) = N := by
+  have hKmap : (H.comap f).map f = H := AddSubgroup.map_comap_eq_self hle
+  rw [← hKmap] at hcyc hcard
+  have : IsAddCyclic ((H.comap f).map f) := hcyc
+  constructor
+  · exact isAddCyclic_of_surjective ((H.comap f).equivMapOfInjective f hf).symm
+      ((H.comap f).equivMapOfInjective f hf).symm.surjective
+  · exact (Nat.card_congr ((H.comap f).equivMapOfInjective f hf).toEquiv).trans hcard
+
+def cyclicAddSubgroupMapEquiv (f : A →+ E) (hf : Function.Injective f) :
+    {C : AddSubgroup A // IsAddCyclic C ∧ Nat.card C = N} ≃
+      {H : AddSubgroup E // IsAddCyclic H ∧ Nat.card H = N ∧ H ≤ f.range} where
+  toFun C := ⟨C.1.map f, isAddCyclic_map_and_card_of_injective N f hf C.2⟩
+  invFun H := ⟨H.1.comap f,
+    isAddCyclic_comap_and_card_of_le_range N f hf H.2.1 H.2.2.1 H.2.2.2⟩
+  left_inv C := Subtype.ext (by
+    change (C.1.map f).comap f = C.1
+    exact AddSubgroup.comap_map_eq_self_of_injective hf C.1)
+  right_inv H := Subtype.ext (by
+    change (H.1.comap f).map f = H.1
+    exact AddSubgroup.map_comap_eq_self H.2.2.2)
+
+theorem le_of_card_eq_of_nsmul_mem {H T : AddSubgroup E} (hcard : Nat.card H = N)
+    (hT : ∀ x : E, N • x = 0 → x ∈ T) : H ≤ T := by
+  intro x hx
+  refine hT x (addOrderOf_dvd_iff_nsmul_eq_zero.mp ?_)
+  rw [← hcard]
+  exact AddSubgroup.addOrderOf_dvd_natCard H hx
+
+end Transport
+
+open Transport in
+theorem solution
+    (n : ℕ) [NeZero n] {A : Type*} [AddCommGroup A]
+    (e : ZMod n × ZMod n ≃+ Submodule.torsionBy ℤ A n) :
+    Nat.card {H : AddSubgroup A // IsAddCyclic H ∧ Nat.card H = n} = ModularCurve.dedekindPsi n :=
+      by
+  let ι : ZMod n × ZMod n →+ A :=
+    ((Submodule.torsionBy ℤ A n).toAddSubgroup.subtype).comp e.toAddMonoidHom
+  have hι : Function.Injective ι :=
+    (Submodule.torsionBy ℤ A n).toAddSubgroup.subtype_injective.comp e.injective
+  have hrange : ∀ x : A, n • x = 0 → x ∈ ι.range := by
+    intro x hx
+    have hx' : x ∈ Submodule.torsionBy ℤ A n := by
+      rw [Submodule.mem_torsionBy_iff, natCast_zsmul]; exact hx
+    refine ⟨e.symm ⟨x, hx'⟩, ?_⟩
+    simp [ι]
+  rw [← ZMod.natCard_isAddCyclic_addSubgroup_prod_eq_dedekindPsi n,
+    Nat.card_congr (cyclicAddSubgroupMapEquiv n ι hι)]
+  refine Nat.card_congr (Equiv.subtypeEquivRight fun H => ?_)
+  constructor
+  · rintro ⟨h1, h2⟩
+    exact ⟨h1, h2, le_of_card_eq_of_nsmul_mem n h2 hrange⟩
+  · rintro ⟨h1, h2, -⟩
+    exact ⟨h1, h2⟩
+
+end privateSection
+
+public section publicSection
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+theorem AddCommGroup.natCard_isAddCyclic_addSubgroup_eq_dedekindPsi_of_addEquiv_torsionBy
+    (n : ℕ) [NeZero n] {A : Type*} [AddCommGroup A]
+    (e : ZMod n × ZMod n ≃+ Submodule.torsionBy ℤ A n) :
+    Nat.card {H : AddSubgroup A // IsAddCyclic H ∧ Nat.card H = n} = ModularCurve.dedekindPsi n :=
+  solution n e
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AddCommGroup_natCard_isAddCyclic_addSubgroup_map_eq_of_sq_add_self_add_id_eq_zero_eq_nuThree.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AddCommGroup_natCard_isAddCyclic_addSubgroup_map_eq_of_sq_add_self_add_id_eq_zero_eq_nuThree.lean
new file mode 100644
index 0000000000..a8c4dbf919
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AddCommGroup_natCard_isAddCyclic_addSubgroup_map_eq_of_sq_add_self_add_id_eq_zero_eq_nuThree.lean
@@ -0,0 +1,173 @@
+/-
+Based on Prove2Me node
+AddCommGroup.natCard_isAddCyclic_addSubgroup_map_eq_of_sq_add_self_add_id_eq_zero_eq_nuThree
+(6f1fbd4e-9356-5c7c-af1d-b45c321f6444) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission bd4d0fff-00b0-52f9-86ac-7957cfc05baa
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ZMod_natCard_isAddCyclic_addSubgroup_prod_map_eq_nuThree
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Counting σ-stable cyclic n-subgroups: the count is ν₃(n)
+
+Theorem statement:
+`AddCommGroup.natCard_isAddCyclic_addSubgroup_map_eq_of_sq_add_self_add_id_eq_zero_eq_nuThree`
+(`6f1fbd4e-9356-5c7c-af1d-b45c321f6444`), by Claude, 2026-09-05.
+
+Proof: submission `bd4d0fff-00b0-52f9-86ac-7957cfc05baa`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $A$ be an additive abelian group and let $n$ be a nonzero natural number. Assume given an
+isomorphism of additive groups $e \colon \mathbb{Z}/n \times \mathbb{Z}/n \xrightarrow{\ \sim\ }
+A[n]$, where $A[n]$ is the $\mathbb{Z}$-torsion submodule `Submodule.torsionBy ℤ A n` of elements
+killed by $n$. Let $\sigma \colon A \to A$ be an additive endomorphism satisfying $\sigma(\sigma a)
++ \sigma a + a = 0$ for every $a \in A$, and assume that for every prime $p$ dividing $n$ there is
+an element $a \in A$ of additive order exactly $p$ such that $\sigma a \neq k \cdot a$ for every
+natural number $k$ (non-scalarity of $\sigma$ on $p$-torsion, formulated with natural rather than
+integral multipliers). The conclusion is that the number of subgroups $H \le A$ which are cyclic,
+have cardinality $n$, and satisfy $\sigma(H) = H$ (in the form $H.\mathrm{map}\,\sigma = H$) equals
+$\nu_3(n)$, defined as the number of $x \in \mathbb{Z}/n$ with $x^2 + x + 1 = 0$.
+
+This is the group-theoretic core of the count of elliptic points of order three on the modular curve
+$Y_0(N)$: for a group whose $n$-torsion is free of rank two over $\mathbb{Z}/n$ and an order-three
+automorphism acting non-scalarly on each $p$-torsion, the $\sigma$-stable cyclic subgroups of order
+$n$ correspond to roots of $x^2+x+1$ in $\mathbb{Z}/n$. It is applied to elliptic curves $y^2 = x^3
++ B$ with the automorphism coming from a primitive cube root of unity, and feeds the genus and
+elliptic-point formulae used downstream.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AddCommGroup_natCard_isAddCyclic_addSubgroup_map_eq_of_sq_add_self_add_id_eq_zero_eq_nuThree.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_ab69e50a
+
+
+open ModularCurve
+
+theorem l3x_transport {A : Type*} [AddCommGroup A] (n : ℕ) [NeZero n]
+    {M : Type*} [AddCommGroup M]
+    (ι : M →+ A) (hι : Function.Injective ι) (hιr : ∀ a : A, n • a = 0 → ∃ m, ι m = a)
+    (σ : A →+ A) (T : M →+ M) (hT : ∀ m, ι (T m) = σ (ι m)) :
+    Nat.card {H : AddSubgroup A // IsAddCyclic H ∧ Nat.card H = n ∧ H.map σ = H}
+      = Nat.card {H : AddSubgroup M // IsAddCyclic H ∧ Nat.card H = n ∧ H.map T = H} := by
+  have hcomm : σ.comp ι = ι.comp T := AddMonoidHom.ext fun m => (hT m).symm
+  have hΦ : ∀ L : AddSubgroup M, IsAddCyclic L ∧ Nat.card L = n ∧ L.map T = L →
+      IsAddCyclic (L.map ι) ∧ Nat.card (L.map ι) = n ∧ (L.map ι).map σ = L.map ι := by
+    rintro L ⟨hc, hcard, hst⟩
+    have := hc
+    refine ⟨isAddCyclic_of_surjective _ (L.equivMapOfInjective ι hι).surjective, ?_, ?_⟩
+    · rw [← Nat.card_congr (L.equivMapOfInjective ι hι).toEquiv, hcard]
+    · rw [AddSubgroup.map_map, hcomm, ← AddSubgroup.map_map, hst]
+  have hΨ : ∀ H : AddSubgroup A, IsAddCyclic H ∧ Nat.card H = n ∧ H.map σ = H →
+      (H.comap ι).map ι = H ∧
+      (IsAddCyclic (H.comap ι) ∧ Nat.card (H.comap ι) = n ∧ (H.comap ι).map T = H.comap ι) := by
+    rintro H ⟨hc, hcard, hst⟩
+    have hle : H ≤ ι.range := by
+      intro a ha
+      have hdvd : addOrderOf a ∣ n := hcard ▸ H.addOrderOf_dvd_natCard ha
+      obtain ⟨m, hm⟩ := hιr a (addOrderOf_dvd_iff_nsmul_eq_zero.mp hdvd)
+      exact ⟨m, hm⟩
+    have hmc : (H.comap ι).map ι = H := AddSubgroup.map_comap_eq_self hle
+    have := hc
+    refine ⟨hmc, ?_, ?_, ?_⟩
+    · have e := (H.comap ι).equivMapOfInjective ι hι
+      rw [hmc] at e
+      exact isAddCyclic_of_surjective _ e.symm.surjective
+    · have h := Nat.card_congr ((H.comap ι).equivMapOfInjective ι hι).toEquiv
+      rw [hmc] at h
+      rw [h, hcard]
+    · apply AddSubgroup.map_injective hι
+      rw [AddSubgroup.map_map, ← hcomm, ← AddSubgroup.map_map, hmc, hst]
+  symm
+  refine Nat.card_eq_of_bijective
+    (fun L : {H : AddSubgroup M // IsAddCyclic H ∧ Nat.card H = n ∧ H.map T = H} =>
+      (⟨L.1.map ι, hΦ L.1 L.2⟩ : {H : AddSubgroup A // IsAddCyclic H ∧ Nat.card H = n ∧ H.map σ =
+        H}))
+    ⟨?_, ?_⟩
+  · intro L₁ L₂ h
+    exact Subtype.ext (AddSubgroup.map_injective hι (congrArg Subtype.val h))
+  · intro H
+    obtain ⟨hmc, hrest⟩ := hΨ H.1 H.2
+    exact ⟨⟨H.1.comap ι, hrest⟩, Subtype.ext hmc⟩
+
+theorem solution
+    {A : Type*} [AddCommGroup A] (n : ℕ) [NeZero n]
+    (e : ZMod n × ZMod n ≃+ Submodule.torsionBy ℤ A n)
+    (σ : A →+ A) (hσ : ∀ a : A, σ (σ a) + σ a + a = 0)
+    (hns : ∀ p : ℕ, p.Prime → p ∣ n → ∃ a : A, addOrderOf a = p ∧ ∀ k : ℕ, σ a ≠ k • a) :
+    Nat.card {H : AddSubgroup A // IsAddCyclic H ∧ Nat.card H = n ∧ H.map σ = H}
+      = nuThree n := by
+  have memV : ∀ a : A, a ∈ Submodule.torsionBy ℤ A n ↔ n • a = 0 := fun a => by
+    rw [Submodule.mem_torsionBy_iff, natCast_zsmul]
+  have σV : ∀ a ∈ Submodule.torsionBy ℤ A n, σ a ∈ Submodule.torsionBy ℤ A n := fun a ha => by
+    rw [memV] at ha ⊢; rw [← map_nsmul, ha, map_zero]
+  let ι : ZMod n × ZMod n →+ A :=
+    (Submodule.torsionBy ℤ A n).subtype.toAddMonoidHom.comp e.toAddMonoidHom
+  have ι_apply : ∀ m, ι m = (e m : A) := fun m => rfl
+  have hι : Function.Injective ι := Subtype.val_injective.comp e.injective
+  have hιr : ∀ a : A, n • a = 0 → ∃ m, ι m = a := fun a ha =>
+    ⟨e.symm ⟨a, (memV a).mpr ha⟩, by rw [ι_apply, AddEquiv.apply_symm_apply]⟩
+  let σr : Submodule.torsionBy ℤ A n →+ Submodule.torsionBy ℤ A n :=
+    (σ.comp (Submodule.torsionBy ℤ A n).subtype.toAddMonoidHom).codRestrict
+      (Submodule.torsionBy ℤ A n) (fun x => σV x.1 x.2)
+  have σr_apply : ∀ x, ((σr x : Submodule.torsionBy ℤ A n) : A) = σ x := fun x => rfl
+  let T : ZMod n × ZMod n →+ ZMod n × ZMod n :=
+    e.symm.toAddMonoidHom.comp (σr.comp e.toAddMonoidHom)
+  have T_apply : ∀ m, T m = e.symm (σr (e m)) := fun m => rfl
+  have hT : ∀ m, ι (T m) = σ (ι m) := fun m => by
+    simp only [T_apply, ι_apply, AddEquiv.apply_symm_apply, σr_apply]
+  have hT2 : ∀ m, T (T m) + T m + m = 0 := fun m =>
+    hι (by rw [map_add, map_add, hT, hT, hσ, map_zero])
+  have hnsT : ∀ p : ℕ, p.Prime → p ∣ n →
+      ∃ v : ZMod n × ZMod n, addOrderOf v = p ∧ ∀ k : ℕ, T v ≠ k • v := by
+    intro p hp hpn
+    obtain ⟨a, ha, hane⟩ := hns p hp hpn
+    obtain ⟨m, rfl⟩ := hιr a (by
+      rw [← ha] at hpn
+      exact addOrderOf_dvd_iff_nsmul_eq_zero.mp hpn)
+    refine ⟨m, by rwa [addOrderOf_injective ι hι] at ha, fun k hk => hane k ?_⟩
+    rw [← hT, hk, map_nsmul]
+  rw [l3x_transport n ι hι hιr σ T hT]
+  exact ZMod.natCard_isAddCyclic_addSubgroup_prod_map_eq_nuThree n T hT2 hnsT
+
+end S_OVERLONG_ab69e50a
+end P2MW
+export
+  P2MW.S_OVERLONG_ab69e50a
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem AddCommGroup.natCard_isAddCyclic_addSubgroup_map_eq_of_sq_add_self_add_id_eq_zero_eq_nuThree
+    {A : Type*} [AddCommGroup A] (n : ℕ) [NeZero n]
+    (e : ZMod n × ZMod n ≃+ Submodule.torsionBy ℤ A n)
+    (σ : A →+ A) (hσ : ∀ a : A, σ (σ a) + σ a + a = 0)
+    (hns : ∀ p : ℕ, p.Prime → p ∣ n → ∃ a : A, addOrderOf a = p ∧ ∀ k : ℕ, σ a ≠ k • a) :
+    Nat.card {H : AddSubgroup A // IsAddCyclic H ∧ Nat.card H = n ∧ H.map σ = H}
+      = nuThree n :=
+  solution n e σ hσ hns
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AddCommGroup_natCard_isAddCyclic_addSubgroup_map_eq_of_sq_eq_neg_one_eq_nuTwo.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AddCommGroup_natCard_isAddCyclic_addSubgroup_map_eq_of_sq_eq_neg_one_eq_nuTwo.lean
new file mode 100644
index 0000000000..b0a1ae01cb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AddCommGroup_natCard_isAddCyclic_addSubgroup_map_eq_of_sq_eq_neg_one_eq_nuTwo.lean
@@ -0,0 +1,169 @@
+/-
+Based on Prove2Me node AddCommGroup.natCard_isAddCyclic_addSubgroup_map_eq_of_sq_eq_neg_one_eq_nuTwo
+(5ede15a5-3d29-577e-ad43-058697fc4a59) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ab259811-07dc-588f-93d1-10877c0e43c0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ZMod_natCard_isAddCyclic_addSubgroup_prod_map_eq_nuTwo
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# σ-stable cyclic subgroups of order n number ν₂(n)
+
+Theorem statement: `AddCommGroup.natCard_isAddCyclic_addSubgroup_map_eq_of_sq_eq_neg_one_eq_nuTwo`
+(`5ede15a5-3d29-577e-ad43-058697fc4a59`), by Claude, 2026-09-05.
+
+Proof: submission `ab259811-07dc-588f-93d1-10877c0e43c0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $A$ be an additive abelian group and let $n$ be a nonzero natural number. Suppose given an
+isomorphism of additive groups $e$ between $\mathbb{Z}/n \times \mathbb{Z}/n$ and the $n$-torsion
+submodule `Submodule.torsionBy ℤ A n` of $A$ viewed as a $\mathbb{Z}$-module, i.e. $A[n] \cong
+(\mathbb{Z}/n)^2$. Let $\sigma : A \to A$ be an additive endomorphism satisfying $\sigma(\sigma a) =
+-a$ for every $a \in A$, and assume that $\sigma$ is non-scalar at every prime dividing $n$ in the
+following sense: for each prime $p \mid n$ there exists $a \in A$ of additive order exactly $p$ such
+that $\sigma a \neq k \cdot a$ for every natural number $k$. Then the number of subgroups $H \leq A$
+that are additively cyclic, have cardinality $n$, and satisfy $\sigma(H) = H$ (as the image `H.map
+σ`) is finite and equal to $\nu_2(n)$, which by definition is the number of $x \in \mathbb{Z}/n$
+with $x^2 + 1 = 0$.
+
+This is the group-theoretic core of the count of elliptic points of order $2$ on the modular curve
+$Y_0(N)$: for an endomorphism with $\sigma^2 = -1$ acting non-scalarly on $p$-torsion for each $p
+\mid N$, the $\sigma$-stable cyclic subgroups of order $N$ correspond to the square roots of $-1$ in
+$\mathbb{Z}/N$. It is applied at the level of Weierstrass curves in the statements counting cyclic
+subgroups of order $N$ fixed by the automorphism $[i]$ of $y^2 = x^3 + Ax$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AddCommGroup_natCard_isAddCyclic_addSubgroup_map_eq_of_sq_eq_neg_one_eq_nuTwo.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AddCommGroup_natCard_isAddCyclic_addSubgroup_map_eq_of_sq_eq_neg_one_eq_nuTwo
+
+
+open ModularCurve
+
+theorem l3x_transport {A : Type*} [AddCommGroup A] (n : ℕ) [NeZero n]
+    {M : Type*} [AddCommGroup M]
+    (ι : M →+ A) (hι : Function.Injective ι) (hιr : ∀ a : A, n • a = 0 → ∃ m, ι m = a)
+    (σ : A →+ A) (T : M →+ M) (hT : ∀ m, ι (T m) = σ (ι m)) :
+    Nat.card {H : AddSubgroup A // IsAddCyclic H ∧ Nat.card H = n ∧ H.map σ = H}
+      = Nat.card {H : AddSubgroup M // IsAddCyclic H ∧ Nat.card H = n ∧ H.map T = H} := by
+  have hcomm : σ.comp ι = ι.comp T := AddMonoidHom.ext fun m => (hT m).symm
+  have hΦ : ∀ L : AddSubgroup M, IsAddCyclic L ∧ Nat.card L = n ∧ L.map T = L →
+      IsAddCyclic (L.map ι) ∧ Nat.card (L.map ι) = n ∧ (L.map ι).map σ = L.map ι := by
+    rintro L ⟨hc, hcard, hst⟩
+    have := hc
+    refine ⟨isAddCyclic_of_surjective _ (L.equivMapOfInjective ι hι).surjective, ?_, ?_⟩
+    · rw [← Nat.card_congr (L.equivMapOfInjective ι hι).toEquiv, hcard]
+    · rw [AddSubgroup.map_map, hcomm, ← AddSubgroup.map_map, hst]
+  have hΨ : ∀ H : AddSubgroup A, IsAddCyclic H ∧ Nat.card H = n ∧ H.map σ = H →
+      (H.comap ι).map ι = H ∧
+      (IsAddCyclic (H.comap ι) ∧ Nat.card (H.comap ι) = n ∧ (H.comap ι).map T = H.comap ι) := by
+    rintro H ⟨hc, hcard, hst⟩
+    have hle : H ≤ ι.range := by
+      intro a ha
+      have hdvd : addOrderOf a ∣ n := hcard ▸ H.addOrderOf_dvd_natCard ha
+      obtain ⟨m, hm⟩ := hιr a (addOrderOf_dvd_iff_nsmul_eq_zero.mp hdvd)
+      exact ⟨m, hm⟩
+    have hmc : (H.comap ι).map ι = H := AddSubgroup.map_comap_eq_self hle
+    have := hc
+    refine ⟨hmc, ?_, ?_, ?_⟩
+    · have e := (H.comap ι).equivMapOfInjective ι hι
+      rw [hmc] at e
+      exact isAddCyclic_of_surjective _ e.symm.surjective
+    · have h := Nat.card_congr ((H.comap ι).equivMapOfInjective ι hι).toEquiv
+      rw [hmc] at h
+      rw [h, hcard]
+    · apply AddSubgroup.map_injective hι
+      rw [AddSubgroup.map_map, ← hcomm, ← AddSubgroup.map_map, hmc, hst]
+  symm
+  refine Nat.card_eq_of_bijective
+    (fun L : {H : AddSubgroup M // IsAddCyclic H ∧ Nat.card H = n ∧ H.map T = H} =>
+      (⟨L.1.map ι, hΦ L.1 L.2⟩ : {H : AddSubgroup A // IsAddCyclic H ∧ Nat.card H = n ∧ H.map σ =
+        H}))
+    ⟨?_, ?_⟩
+  · intro L₁ L₂ h
+    exact Subtype.ext (AddSubgroup.map_injective hι (congrArg Subtype.val h))
+  · intro H
+    obtain ⟨hmc, hrest⟩ := hΨ H.1 H.2
+    exact ⟨⟨H.1.comap ι, hrest⟩, Subtype.ext hmc⟩
+
+theorem solution
+    {A : Type*} [AddCommGroup A] (n : ℕ) [NeZero n]
+    (e : ZMod n × ZMod n ≃+ Submodule.torsionBy ℤ A n)
+    (σ : A →+ A) (hσ : ∀ a : A, σ (σ a) = -a)
+    (hns : ∀ p : ℕ, p.Prime → p ∣ n → ∃ a : A, addOrderOf a = p ∧ ∀ k : ℕ, σ a ≠ k • a) :
+    Nat.card {H : AddSubgroup A // IsAddCyclic H ∧ Nat.card H = n ∧ H.map σ = H}
+      = nuTwo n := by
+  have memV : ∀ a : A, a ∈ Submodule.torsionBy ℤ A n ↔ n • a = 0 := fun a => by
+    rw [Submodule.mem_torsionBy_iff, natCast_zsmul]
+  have σV : ∀ a ∈ Submodule.torsionBy ℤ A n, σ a ∈ Submodule.torsionBy ℤ A n := fun a ha => by
+    rw [memV] at ha ⊢; rw [← map_nsmul, ha, map_zero]
+  let ι : ZMod n × ZMod n →+ A :=
+    (Submodule.torsionBy ℤ A n).subtype.toAddMonoidHom.comp e.toAddMonoidHom
+  have ι_apply : ∀ m, ι m = (e m : A) := fun m => rfl
+  have hι : Function.Injective ι := Subtype.val_injective.comp e.injective
+  have hιr : ∀ a : A, n • a = 0 → ∃ m, ι m = a := fun a ha =>
+    ⟨e.symm ⟨a, (memV a).mpr ha⟩, by rw [ι_apply, AddEquiv.apply_symm_apply]⟩
+  let σr : Submodule.torsionBy ℤ A n →+ Submodule.torsionBy ℤ A n :=
+    (σ.comp (Submodule.torsionBy ℤ A n).subtype.toAddMonoidHom).codRestrict
+      (Submodule.torsionBy ℤ A n) (fun x => σV x.1 x.2)
+  have σr_apply : ∀ x, ((σr x : Submodule.torsionBy ℤ A n) : A) = σ x := fun x => rfl
+  let T : ZMod n × ZMod n →+ ZMod n × ZMod n :=
+    e.symm.toAddMonoidHom.comp (σr.comp e.toAddMonoidHom)
+  have T_apply : ∀ m, T m = e.symm (σr (e m)) := fun m => rfl
+  have hT : ∀ m, ι (T m) = σ (ι m) := fun m => by
+    simp only [T_apply, ι_apply, AddEquiv.apply_symm_apply, σr_apply]
+  have hT2 : ∀ m, T (T m) = -m := fun m =>
+    hι (by rw [hT, hT, hσ, map_neg])
+  have hnsT : ∀ p : ℕ, p.Prime → p ∣ n →
+      ∃ v : ZMod n × ZMod n, addOrderOf v = p ∧ ∀ k : ℕ, T v ≠ k • v := by
+    intro p hp hpn
+    obtain ⟨a, ha, hane⟩ := hns p hp hpn
+    obtain ⟨m, rfl⟩ := hιr a (by
+      rw [← ha] at hpn
+      exact addOrderOf_dvd_iff_nsmul_eq_zero.mp hpn)
+    refine ⟨m, by rwa [addOrderOf_injective ι hι] at ha, fun k hk => hane k ?_⟩
+    rw [← hT, hk, map_nsmul]
+  rw [l3x_transport n ι hι hιr σ T hT]
+  exact ZMod.natCard_isAddCyclic_addSubgroup_prod_map_eq_nuTwo n T hT2 hnsT
+
+end S_AddCommGroup_natCard_isAddCyclic_addSubgroup_map_eq_of_sq_eq_neg_one_eq_nuTwo
+end P2MW
+export P2MW.S_AddCommGroup_natCard_isAddCyclic_addSubgroup_map_eq_of_sq_eq_neg_one_eq_nuTwo
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem AddCommGroup.natCard_isAddCyclic_addSubgroup_map_eq_of_sq_eq_neg_one_eq_nuTwo
+    {A : Type*} [AddCommGroup A] (n : ℕ) [NeZero n]
+    (e : ZMod n × ZMod n ≃+ Submodule.torsionBy ℤ A n)
+    (σ : A →+ A) (hσ : ∀ a : A, σ (σ a) = -a)
+    (hns : ∀ p : ℕ, p.Prime → p ∣ n → ∃ a : A, addOrderOf a = p ∧ ∀ k : ℕ, σ a ≠ k • a) :
+    Nat.card {H : AddSubgroup A // IsAddCyclic H ∧ Nat.card H = n ∧ H.map σ = H}
+      = nuTwo n :=
+  solution n e σ hσ hns
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AddCommGroup_nonempty_zmod_prod_addEquiv_torsionBy_of_card_torsionBy_eq_sq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AddCommGroup_nonempty_zmod_prod_addEquiv_torsionBy_of_card_torsionBy_eq_sq.lean
new file mode 100644
index 0000000000..c261d3cb6a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AddCommGroup_nonempty_zmod_prod_addEquiv_torsionBy_of_card_torsionBy_eq_sq.lean
@@ -0,0 +1,446 @@
+/-
+Based on Prove2Me node AddCommGroup.nonempty_zmod_prod_addEquiv_torsionBy_of_card_torsionBy_eq_sq
+(5c78d5a9-fd90-5289-b077-4e0b079a4d31) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f0db69f6-0492-59b1-aa10-a95c7b7fdfde
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Module.Torsion.Basic
+
+import Mathlib.Algebra.Field.ZMod
+import Mathlib.Algebra.Module.StablyFree.Basic
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import Mathlib.FieldTheory.Finiteness
+import Mathlib.LinearAlgebra.FreeModule.PID
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# #A[d]=d² for all d∣ n forces A[n]≅(ℤ/n)²
+
+Theorem statement: `AddCommGroup.nonempty_zmod_prod_addEquiv_torsionBy_of_card_torsionBy_eq_sq`
+(`5c78d5a9-fd90-5289-b077-4e0b079a4d31`), by Claude, 2026-09-05.
+
+Proof: submission `f0db69f6-0492-59b1-aa10-a95c7b7fdfde`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $A$ be an additive abelian group, regarded as a $\mathbb Z$-module, and let $n$ be a natural
+number with $n \neq 0$. For a natural number $d$ write $A[d] = \{x \in A : d \cdot x = 0\}$ for the
+$d$-torsion submodule `Submodule.torsionBy ℤ A d`. Assume that for every divisor $d$ of $n$ the
+natural cardinality of $A[d]$ equals $d^2$; since `Nat.card` is $0$ on infinite types and $d \neq 0$
+for each divisor of $n$, this hypothesis includes the assertion that each such $A[d]$ is finite, of
+order exactly $d^2$. The conclusion is that the type of additive group isomorphisms $\mathbb
+Z/n\mathbb Z \times \mathbb Z/n\mathbb Z \simeq A[n]$ is nonempty, that is, the $n$-torsion subgroup
+of $A$ is isomorphic, as an abelian group, to the direct square of the cyclic group of order $n$.
+The statement asserts only the existence of such an isomorphism; no canonical choice of isomorphism
+or of basis is produced.
+
+This is the "counting implies structure" step for abelian groups: the hypothesis on the orders of
+all $A[d]$, $d \mid n$, pins down the isomorphism type of $A[n]$ via the structure theorem for
+finite abelian groups together with the Chinese remainder decomposition. It is applied to turn
+cardinality counts of torsion subgroups (for instance $\#E[d] = d^2$ for elliptic curves over an
+algebraically closed field) into the existence of a torsion basis, and is used in this form by the
+statements about fake elliptic curves with extra level structure, relative group laws on Jacobians
+with good reduction, and fibres of modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AddCommGroup_nonempty_zmod_prod_addEquiv_torsionBy_of_card_torsionBy_eq_sq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AddCommGroup_nonempty_zmod_prod_addEquiv_torsionBy_of_card_torsionBy_eq_sq
+
+noncomputable section
+
+namespace P2MWs13
+namespace TorsionStructure
+
+theorem nonempty_zmodSqAddEquiv_of_card_eq_sq {p : ℕ} (hp : p.Prime)
+    (M : Type*) [AddCommGroup M] [Module (ZMod p) M]
+    (hcard : Nat.card M = p ^ 2) :
+    Nonempty ((ZMod p × ZMod p) ≃+ M) := by
+  have : Fact p.Prime := ⟨hp⟩
+  have : Finite M :=
+    Nat.finite_of_card_ne_zero (by rw [hcard]; exact pow_ne_zero 2 hp.ne_zero)
+  have : Module.Finite (ZMod p) M := Module.Finite.of_finite
+  have hfr : Module.finrank (ZMod p) M = 2 := by
+    have hcard2 := Module.natCard_eq_pow_finrank (K := ZMod p) (V := M)
+    rw [hcard, Nat.card_zmod] at hcard2
+    exact (Nat.pow_right_injective hp.two_le hcard2).symm
+  exact ⟨((Module.finBasisOfFinrankEq (ZMod p) M hfr).equivFun.trans
+    (LinearEquiv.finTwoArrow (R := ZMod p) (M := ZMod p))).symm.toAddEquiv⟩
+
+section AbstractEngine
+
+variable {A : Type*} [AddCommGroup A]
+
+private def pSmulHom (M : Type*) [AddCommGroup M] (p : ℕ) : M →+ M :=
+  AddMonoidHom.mk' (fun t => p • t) fun a b => smul_add p a b
+
+private lemma pSmulHom_apply (M : Type*) [AddCommGroup M] (p : ℕ) (t : M) :
+    pSmulHom M p t = p • t := rfl
+
+private def pSmulHomKerEquivTorsionBy (M : Type*) [AddCommGroup M] (p : ℕ) :
+    (pSmulHom M p).ker ≃ Submodule.torsionBy ℤ M (p : ℤ) where
+  toFun T := ⟨(T : M), by
+    have hT := T.2
+    rw [AddMonoidHom.mem_ker, pSmulHom_apply] at hT
+    rw [Submodule.mem_torsionBy_iff, Nat.cast_smul_eq_nsmul ℤ p ((T : M))]
+    exact hT⟩
+  invFun T := ⟨(T : M), by
+    have hT := T.2
+    rw [Submodule.mem_torsionBy_iff, Nat.cast_smul_eq_nsmul ℤ p ((T : M))] at hT
+    rw [AddMonoidHom.mem_ker, pSmulHom_apply]
+    exact hT⟩
+  left_inv _ := Subtype.ext rfl
+  right_inv _ := Subtype.ext rfl
+
+theorem forall_exists_zsmul_pair_of_step {M : Type*} [AddCommGroup M] {p k : ℕ} {x y : M}
+    (hexp : ∀ t : M, p ^ k • t = 0)
+    (hstep : ∀ t : M, ∃ (a b : ℤ) (s : M), t = a • x + b • y + (p : ℤ) • s) :
+    ∀ t : M, ∃ a b : ℤ, t = a • x + b • y := by
+  have hiter : ∀ (j : ℕ) (t : M), ∃ (a b : ℤ) (s : M),
+      t = a • x + b • y + ((p : ℤ)) ^ j • s := by
+    intro j
+    induction j with
+    | zero =>
+      intro t
+      exact ⟨0, 0, t, by simp⟩
+    | succ j ih =>
+      intro t
+      obtain ⟨a, b, s, hs⟩ := ih t
+      obtain ⟨a', b', s', hs'⟩ := hstep s
+      refine ⟨a + (p : ℤ) ^ j * a', b + (p : ℤ) ^ j * b', s', ?_⟩
+      calc t = a • x + b • y + (p : ℤ) ^ j • s := hs
+        _ = a • x + b • y + (p : ℤ) ^ j • (a' • x + b' • y + (p : ℤ) • s') := by rw [← hs']
+        _ = a • x + b • y + (((p : ℤ) ^ j * a') • x + ((p : ℤ) ^ j * b') • y
+              + ((p : ℤ) ^ j * (p : ℤ)) • s') := by
+            rw [smul_add, smul_add, smul_smul, smul_smul, smul_smul]
+        _ = (a + (p : ℤ) ^ j * a') • x + (b + (p : ℤ) ^ j * b') • y
+              + (p : ℤ) ^ (j + 1) • s' := by
+            rw [add_smul, add_smul, pow_succ]
+            abel
+  intro t
+  obtain ⟨a, b, s, hs⟩ := hiter k t
+  refine ⟨a, b, ?_⟩
+  have hzero : ((p : ℤ)) ^ k • s = 0 := by
+    have hcast : ((p : ℤ)) ^ k • s = (p ^ k : ℕ) • s := by
+      rw [← Nat.cast_pow, natCast_zsmul]
+    rw [hcast]
+    exact hexp s
+  rw [hs, hzero, add_zero]
+
+theorem nonempty_zmodPowSqAddEquiv_of_span_pair {n : ℕ} (hn : n ≠ 0)
+    (M : Type*) [AddCommGroup M] [Module (ZMod n) M]
+    (hcard : Nat.card M = n ^ 2) (x y : M)
+    (hgen : ∀ t : M, ∃ a b : ℤ, t = a • x + b • y) :
+    Nonempty ((ZMod n × ZMod n) ≃+ M) := by
+  have : NeZero n := ⟨hn⟩
+  have : Finite M := Nat.finite_of_card_ne_zero (by rw [hcard]; exact pow_ne_zero 2 hn)
+  let f : (ZMod n × ZMod n) →+ M := AddMonoidHom.mk' (fun c => c.1 • x + c.2 • y) (by
+    intro c d
+    change (c.1 + d.1) • x + (c.2 + d.2) • y = (c.1 • x + c.2 • y) + (d.1 • x + d.2 • y)
+    rw [add_smul, add_smul]
+    abel)
+  have hfsurj : Function.Surjective f := by
+    intro t
+    obtain ⟨a, b, ht⟩ := hgen t
+    refine ⟨((a : ZMod n), (b : ZMod n)), ?_⟩
+    change ((a : ℤ) : ZMod n) • x + ((b : ℤ) : ZMod n) • y = t
+    rw [Int.cast_smul_eq_zsmul (ZMod n) a x, Int.cast_smul_eq_zsmul (ZMod n) b y, ht]
+  have hcards : Nat.card (ZMod n × ZMod n) = Nat.card M := by
+    rw [Nat.card_prod, Nat.card_zmod, hcard]
+    ring
+  exact ⟨AddEquiv.ofBijective f
+    ((Nat.bijective_iff_surjective_and_card f).mpr ⟨hfsurj, hcards⟩)⟩
+
+theorem nonempty_zmodPowSqAddEquiv_of_card_pow {p : ℕ} (hp : p.Prime) (k : ℕ)
+    (M : Type*) [AddCommGroup M]
+    (hexp : ∀ t : M, p ^ k • t = 0)
+    (hcard : Nat.card M = p ^ (2 * k))
+    (hcardp : Nat.card (Submodule.torsionBy ℤ M (p : ℤ)) = p ^ 2) :
+    Nonempty ((ZMod (p ^ k) × ZMod (p ^ k)) ≃+ M) := by
+  have : Finite M :=
+    Nat.finite_of_card_ne_zero (by rw [hcard]; exact pow_ne_zero _ hp.ne_zero)
+  rcases Nat.eq_zero_or_pos k with rfl | hk
+  · exfalso
+    have h1 : Nat.card M = 1 := by simpa using hcard
+    have hle : Nat.card (Submodule.torsionBy ℤ M (p : ℤ)) ≤ Nat.card M :=
+      Nat.card_le_card_of_injective _ Subtype.val_injective
+    rw [hcardp, h1] at hle
+    exact absurd (le_trans (Nat.pow_le_pow_left hp.two_le 2) hle) (by norm_num)
+  · set K : AddSubgroup M := (pSmulHom M p).ker with hKdef
+    set R : AddSubgroup M := (pSmulHom M p).range with hRdef
+    have : Nonempty R := ⟨0⟩
+    have hKcard : Nat.card K = p ^ 2 := by
+      rw [hKdef, Nat.card_congr (pSmulHomKerEquivTorsionBy M p)]
+      exact hcardp
+    have hMK : Nat.card K * K.index = Nat.card M := AddSubgroup.card_mul_index K
+    have hKR : K.index = Nat.card R := by
+      rw [hKdef, hRdef]
+      exact AddSubgroup.index_ker (pSmulHom M p)
+    have hMR : Nat.card R * R.index = Nat.card M := AddSubgroup.card_mul_index R
+    have hRQ : R.index = Nat.card (M ⧸ R) := AddSubgroup.index_eq_card R
+    have hRpos : 0 < Nat.card R := Nat.card_pos
+    have hQcard : Nat.card (M ⧸ R) = p ^ 2 := by
+      have h1 : Nat.card K * Nat.card R = Nat.card M := by rw [← hKR]; exact hMK
+      have h2 : Nat.card R * Nat.card (M ⧸ R) = Nat.card M := by rw [← hRQ]; exact hMR
+      have h3 : Nat.card R * Nat.card (M ⧸ R) = Nat.card R * Nat.card K := by
+        rw [h2, ← h1, mul_comm]
+      rw [Nat.eq_of_mul_eq_mul_left hRpos h3, hKcard]
+    have hQkill : ∀ q : M ⧸ R, p • q = 0 := by
+      intro q
+      obtain ⟨t, rfl⟩ := QuotientAddGroup.mk'_surjective R q
+      rw [← map_nsmul]
+      have hmem : p • t ∈ R := by
+        rw [hRdef]
+        exact AddMonoidHom.mem_range.mpr ⟨t, pSmulHom_apply M p t⟩
+      rwa [← QuotientAddGroup.ker_mk' R, AddMonoidHom.mem_ker] at hmem
+    obtain ⟨E⟩ : Nonempty ((ZMod p × ZMod p) ≃+ (M ⧸ R)) := by
+      let : Module (ZMod p) (M ⧸ R) := AddCommGroup.zmodModule hQkill
+      exact nonempty_zmodSqAddEquiv_of_card_eq_sq hp (M ⧸ R) hQcard
+    obtain ⟨x, hx⟩ := QuotientAddGroup.mk'_surjective R (E ((1 : ZMod p), (0 : ZMod p)))
+    obtain ⟨y, hy⟩ := QuotientAddGroup.mk'_surjective R (E ((0 : ZMod p), (1 : ZMod p)))
+    have hstep : ∀ t : M, ∃ (a b : ℤ) (s : M), t = a • x + b • y + (p : ℤ) • s := by
+      intro t
+      obtain ⟨a, ha⟩ := ZMod.intCast_surjective ((E.symm ((QuotientAddGroup.mk' R) t)).1)
+      obtain ⟨b, hb⟩ := ZMod.intCast_surjective ((E.symm ((QuotientAddGroup.mk' R) t)).2)
+      have hxy : (QuotientAddGroup.mk' R) (a • x + b • y) = (QuotientAddGroup.mk' R) t := by
+        rw [map_add, map_zsmul, map_zsmul, hx, hy, ← map_zsmul E, ← map_zsmul E, ← map_add E]
+        have hpair : a • ((1 : ZMod p), (0 : ZMod p)) + b • ((0 : ZMod p), (1 : ZMod p))
+            = E.symm ((QuotientAddGroup.mk' R) t) := by
+          apply Prod.ext
+          · simpa [Int.smul_one_eq_cast] using ha
+          · simpa [Int.smul_one_eq_cast] using hb
+        rw [hpair, AddEquiv.apply_symm_apply]
+      have h0 : (QuotientAddGroup.mk' R) (t - (a • x + b • y)) = 0 := by
+        rw [map_sub, hxy, sub_self]
+      have hmem : t - (a • x + b • y) ∈ R := by
+        rwa [← QuotientAddGroup.ker_mk' R, AddMonoidHom.mem_ker]
+      rw [hRdef] at hmem
+      obtain ⟨s, hs⟩ := AddMonoidHom.mem_range.mp hmem
+      rw [pSmulHom_apply] at hs
+      refine ⟨a, b, s, ?_⟩
+      rw [natCast_zsmul, hs]
+      abel
+    have hgen : ∀ t : M, ∃ a b : ℤ, t = a • x + b • y :=
+      forall_exists_zsmul_pair_of_step hexp hstep
+    let : Module (ZMod (p ^ k)) M := AddCommGroup.zmodModule hexp
+    exact nonempty_zmodPowSqAddEquiv_of_span_pair (pow_ne_zero k hp.ne_zero) M
+      (by rw [hcard, show 2 * k = k * 2 from Nat.mul_comm 2 k, pow_mul]) x y hgen
+
+def torsionByPowPTorsionEquiv (p k : ℕ) (hk : k ≠ 0) :
+    (Submodule.torsionBy ℤ (Submodule.torsionBy ℤ A ((p ^ k : ℕ) : ℤ)) (p : ℤ)) ≃
+      (Submodule.torsionBy ℤ A (p : ℤ)) where
+  toFun T := ⟨((T : Submodule.torsionBy ℤ A ((p ^ k : ℕ) : ℤ)) : A), by
+    have hT := T.2
+    rw [Submodule.mem_torsionBy_iff] at hT
+    rw [Submodule.mem_torsionBy_iff]
+    exact congrArg Subtype.val hT⟩
+  invFun T := ⟨⟨(T : A), by
+      rw [Submodule.mem_torsionBy_iff]
+      have hT : (p : ℤ) • (T : A) = 0 := by
+        have := T.2
+        rwa [Submodule.mem_torsionBy_iff] at this
+      have hkk : ((p ^ k : ℕ) : ℤ) = ((p ^ (k - 1) : ℕ) : ℤ) * (p : ℤ) := by
+        push_cast
+        rw [← pow_succ]
+        congr 1
+        omega
+      rw [hkk, mul_smul, hT, smul_zero]⟩, by
+    rw [Submodule.mem_torsionBy_iff]
+    apply Subtype.ext
+    have hT : (p : ℤ) • (T : A) = 0 := by
+      have := T.2
+      rwa [Submodule.mem_torsionBy_iff] at this
+    exact hT⟩
+  left_inv _ := Subtype.ext (Subtype.ext rfl)
+  right_inv _ := Subtype.ext rfl
+
+theorem nonempty_zmodPowSqAddEquiv_torsionBy_of_card_pow {p : ℕ} (hp : p.Prime) {k : ℕ}
+    (hk : k ≠ 0)
+    (hcard : Nat.card (Submodule.torsionBy ℤ A ((p ^ k : ℕ) : ℤ)) = p ^ (2 * k))
+    (hcardp : Nat.card (Submodule.torsionBy ℤ A (p : ℤ)) = p ^ 2) :
+    Nonempty ((ZMod (p ^ k) × ZMod (p ^ k)) ≃+ Submodule.torsionBy ℤ A ((p ^ k : ℕ) : ℤ)) := by
+  refine nonempty_zmodPowSqAddEquiv_of_card_pow hp k _ ?_ hcard ?_
+  · intro t
+    rw [← Nat.cast_smul_eq_nsmul ℤ (p ^ k) t]
+    exact Submodule.smul_torsionBy _ t
+  · rw [← hcardp]
+    exact Nat.card_congr (torsionByPowPTorsionEquiv p k hk)
+
+end AbstractEngine
+
+section AbstractEngine
+
+variable {A : Type*} [AddCommGroup A]
+
+def torsionByMulCoprimeSplitAddEquiv (M N : ℕ) (a b : ℤ)
+    (hab : (M : ℤ) * a + (N : ℤ) * b = 1) :
+    Submodule.torsionBy ℤ A ((M * N : ℕ) : ℤ) ≃+
+      Submodule.torsionBy ℤ A (M : ℤ) × Submodule.torsionBy ℤ A (N : ℤ) where
+  toFun t :=
+    (⟨((N : ℤ) * b) • (t : A), by
+        have ht : ((M * N : ℕ) : ℤ) • (t : A) = 0 := by
+          have h2 := t.2
+          rwa [Submodule.mem_torsionBy_iff] at h2
+        rw [Submodule.mem_torsionBy_iff, smul_smul,
+          show (M : ℤ) * ((N : ℤ) * b) = b * ((M * N : ℕ) : ℤ) by push_cast; ring,
+          ← smul_smul, ht, smul_zero]⟩,
+     ⟨((M : ℤ) * a) • (t : A), by
+        have ht : ((M * N : ℕ) : ℤ) • (t : A) = 0 := by
+          have h2 := t.2
+          rwa [Submodule.mem_torsionBy_iff] at h2
+        rw [Submodule.mem_torsionBy_iff, smul_smul,
+          show (N : ℤ) * ((M : ℤ) * a) = a * ((M * N : ℕ) : ℤ) by push_cast; ring,
+          ← smul_smul, ht, smul_zero]⟩)
+  invFun uv := ⟨(uv.1 : A) + (uv.2 : A), by
+    have hu : (M : ℤ) • (uv.1 : A) = 0 := by
+      have h2 := uv.1.2
+      rwa [Submodule.mem_torsionBy_iff] at h2
+    have hv : (N : ℤ) • (uv.2 : A) = 0 := by
+      have h2 := uv.2.2
+      rwa [Submodule.mem_torsionBy_iff] at h2
+    rw [Submodule.mem_torsionBy_iff, smul_add,
+      show ((M * N : ℕ) : ℤ) • (uv.1 : A) = 0 by
+        rw [show ((M * N : ℕ) : ℤ) = (N : ℤ) * (M : ℤ) by push_cast; ring, ← smul_smul, hu,
+          smul_zero],
+      show ((M * N : ℕ) : ℤ) • (uv.2 : A) = 0 by
+        rw [show ((M * N : ℕ) : ℤ) = (M : ℤ) * (N : ℤ) by push_cast; ring, ← smul_smul, hv,
+          smul_zero],
+      add_zero]⟩
+  left_inv t := by
+    apply Subtype.ext
+    change ((N : ℤ) * b) • (t : A) + ((M : ℤ) * a) • (t : A) = (t : A)
+    rw [← add_smul, show (N : ℤ) * b + (M : ℤ) * a = 1 by linarith [hab], one_smul]
+  right_inv uv := by
+    have hu : (M : ℤ) • (uv.1 : A) = 0 := by
+      have h2 := uv.1.2
+      rwa [Submodule.mem_torsionBy_iff] at h2
+    have hv : (N : ℤ) • (uv.2 : A) = 0 := by
+      have h2 := uv.2.2
+      rwa [Submodule.mem_torsionBy_iff] at h2
+    apply Prod.ext
+    · apply Subtype.ext
+      change ((N : ℤ) * b) • ((uv.1 : A) + (uv.2 : A)) = (uv.1 : A)
+      rw [smul_add,
+        show ((N : ℤ) * b) • (uv.2 : A) = 0 by
+          rw [show (N : ℤ) * b = b * (N : ℤ) by ring, ← smul_smul, hv, smul_zero],
+        show ((N : ℤ) * b) • (uv.1 : A) = (uv.1 : A) by
+          rw [show (N : ℤ) * b = 1 - (M : ℤ) * a by linarith [hab], sub_smul, one_smul,
+            show (M : ℤ) * a = a * (M : ℤ) by ring, ← smul_smul, hu, smul_zero, sub_zero],
+        add_zero]
+    · apply Subtype.ext
+      change ((M : ℤ) * a) • ((uv.1 : A) + (uv.2 : A)) = (uv.2 : A)
+      rw [smul_add,
+        show ((M : ℤ) * a) • (uv.1 : A) = 0 by
+          rw [show (M : ℤ) * a = a * (M : ℤ) by ring, ← smul_smul, hu, smul_zero],
+        show ((M : ℤ) * a) • (uv.2 : A) = (uv.2 : A) by
+          rw [show (M : ℤ) * a = 1 - (N : ℤ) * b by linarith [hab], sub_smul, one_smul,
+            show (N : ℤ) * b = b * (N : ℤ) by ring, ← smul_smul, hv, smul_zero, sub_zero],
+        zero_add]
+  map_add' t s := by
+    apply Prod.ext
+    · apply Subtype.ext
+      change ((N : ℤ) * b) • ((t : A) + (s : A))
+        = ((N : ℤ) * b) • (t : A) + ((N : ℤ) * b) • (s : A)
+      rw [smul_add]
+    · apply Subtype.ext
+      change ((M : ℤ) * a) • ((t : A) + (s : A))
+        = ((M : ℤ) * a) • (t : A) + ((M : ℤ) * a) • (s : A)
+      rw [smul_add]
+
+theorem nonempty_torsionByMulAddEquiv_prod_of_coprime {M N : ℕ} (hcop : Nat.Coprime M N) :
+    Nonempty (Submodule.torsionBy ℤ A ((M * N : ℕ) : ℤ) ≃+
+      Submodule.torsionBy ℤ A (M : ℤ) × Submodule.torsionBy ℤ A (N : ℤ)) := by
+  have hbez : (M : ℤ) * Nat.gcdA M N + (N : ℤ) * Nat.gcdB M N = 1 := by
+    have h := Nat.gcd_eq_gcd_ab M N
+    rw [Nat.Coprime.gcd_eq_one hcop] at h
+    exact_mod_cast h.symm
+  exact ⟨torsionByMulCoprimeSplitAddEquiv M N (Nat.gcdA M N) (Nat.gcdB M N) hbez⟩
+
+def zmodSqCrtAddEquiv {M N : ℕ} (hcop : Nat.Coprime M N) :
+    (ZMod (M * N) × ZMod (M * N)) ≃+ (ZMod M × ZMod M) × (ZMod N × ZMod N) :=
+  (AddEquiv.prodCongr (ZMod.chineseRemainder hcop).toAddEquiv
+    (ZMod.chineseRemainder hcop).toAddEquiv).trans
+    (AddEquiv.prodProdProdComm (ZMod M) (ZMod N) (ZMod M) (ZMod N))
+
+theorem nonempty_zmodSqAddEquiv_torsionBy_mul_of_coprime {M N : ℕ} (hcop : Nat.Coprime M N)
+    (hM : Nonempty ((ZMod M × ZMod M) ≃+ Submodule.torsionBy ℤ A (M : ℤ)))
+    (hN : Nonempty ((ZMod N × ZMod N) ≃+ Submodule.torsionBy ℤ A (N : ℤ))) :
+    Nonempty ((ZMod (M * N) × ZMod (M * N)) ≃+ Submodule.torsionBy ℤ A ((M * N : ℕ) : ℤ)) := by
+  obtain ⟨eM⟩ := hM
+  obtain ⟨eN⟩ := hN
+  obtain ⟨eT⟩ := nonempty_torsionByMulAddEquiv_prod_of_coprime (A := A) hcop
+  exact ⟨((zmodSqCrtAddEquiv hcop).trans (AddEquiv.prodCongr eM eN)).trans eT.symm⟩
+
+end AbstractEngine
+
+theorem nonempty_zmodSqAddEquiv_torsionBy_one {A : Type*} [AddCommGroup A] :
+    Nonempty ((ZMod 1 × ZMod 1) ≃+ Submodule.torsionBy ℤ A ((1 : ℕ) : ℤ)) := by
+  have : Subsingleton (Submodule.torsionBy ℤ A ((1 : ℕ) : ℤ)) := by
+    refine ⟨fun x y => Subtype.ext ?_⟩
+    have hx := x.2; have hy := y.2
+    rw [Submodule.mem_torsionBy_iff] at hx hy
+    simp only [Nat.cast_one, one_smul] at hx hy
+    rw [hx, hy]
+  refine ⟨AddEquiv.ofBijective (0 : ZMod 1 × ZMod 1 →+ Submodule.torsionBy ℤ A ((1 : ℕ) : ℤ)) ⟨?_,
+    ?_⟩⟩
+  · intro a b _; exact Subsingleton.elim a b
+  · intro y; exact ⟨0, Subsingleton.elim _ _⟩
+
+end P2MWs13.TorsionStructure
+
+end
+
+open P2MWs13.TorsionStructure in
+theorem solution
+    {A : Type*} [AddCommGroup A] {n : ℕ} (hn : n ≠ 0)
+    (hcard : ∀ d : ℕ, d ∣ n → Nat.card (Submodule.torsionBy ℤ A d) = d ^ 2) :
+    Nonempty (ZMod n × ZMod n ≃+ Submodule.torsionBy ℤ A n) := by
+  induction n using Nat.recOnPosPrimePosCoprime with
+  | prime_pow p k hp hk =>
+      have hc : Nat.card (Submodule.torsionBy ℤ A ((p ^ k : ℕ) : ℤ)) = p ^ (2 * k) := by
+        rw [hcard (p ^ k) dvd_rfl, ← pow_mul, Nat.mul_comm]
+      have hcp : Nat.card (Submodule.torsionBy ℤ A (p : ℤ)) = p ^ 2 :=
+        hcard p (dvd_pow_self p hk.ne')
+      exact nonempty_zmodPowSqAddEquiv_torsionBy_of_card_pow hp hk.ne' hc hcp
+  | zero => exact absurd rfl hn
+  | one => exact nonempty_zmodSqAddEquiv_torsionBy_one
+  | coprime a b _ _ hab iha ihb =>
+      have ha0 : a ≠ 0 := left_ne_zero_of_mul hn
+      have hb0 : b ≠ 0 := right_ne_zero_of_mul hn
+      exact nonempty_zmodSqAddEquiv_torsionBy_mul_of_coprime hab
+        (iha ha0 fun d hd => hcard d (hd.mul_right b))
+        (ihb hb0 fun d hd => hcard d (hd.mul_left a))
+
+end S_AddCommGroup_nonempty_zmod_prod_addEquiv_torsionBy_of_card_torsionBy_eq_sq
+end P2MW
+export P2MW.S_AddCommGroup_nonempty_zmod_prod_addEquiv_torsionBy_of_card_torsionBy_eq_sq (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AddCommGroup.nonempty_zmod_prod_addEquiv_torsionBy_of_card_torsionBy_eq_sq
+    {A : Type*} [AddCommGroup A] {n : ℕ} (hn : n ≠ 0)
+    (hcard : ∀ d : ℕ, d ∣ n → Nat.card (Submodule.torsionBy ℤ A d) = d ^ 2) :
+    Nonempty (ZMod n × ZMod n ≃+ Submodule.torsionBy ℤ A n) :=
+  solution hn hcard
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Algebra_IsSeparable_of_finrank_fieldRange_frobenius_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Algebra_IsSeparable_of_finrank_fieldRange_frobenius_eq.lean
new file mode 100644
index 0000000000..6c3f4de508
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Algebra_IsSeparable_of_finrank_fieldRange_frobenius_eq.lean
@@ -0,0 +1,141 @@
+/-
+Based on Prove2Me node Algebra.IsSeparable.of_finrank_fieldRange_frobenius_eq
+(4238d103-c2af-5ec4-87f3-ba390c33456c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3d98fae7-eb35-5aab-9abf-45d281dfa828
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.CharP.Frobenius
+public import Mathlib.Algebra.Field.Subfield.Basic
+public import Mathlib.LinearAlgebra.Dimension.Finrank
+public import Mathlib.LinearAlgebra.FiniteDimensional.Defs
+public import Mathlib.FieldTheory.Separable
+
+import Mathlib.RingTheory.Unramified.Field
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Separability from [F:Fᵖ]=p and a non-p-th-power in E
+
+Theorem statement: `Algebra.IsSeparable.of_finrank_fieldRange_frobenius_eq`
+(`4238d103-c2af-5ec4-87f3-ba390c33456c`), by Claude, 2026-09-05.
+
+Proof: submission `3d98fae7-eb35-5aab-9abf-45d281dfa828`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $E$ and $F$ be fields with $F$ an $E$-algebra that is finite-dimensional over $E$, let $p$ be a
+prime, and suppose $F$ has characteristic $p$. Write
+$(\mathrm{frobenius}\,F\,p).\mathrm{fieldRange}$ for the image subfield $F^p = \{a^p : a \in F\}$ of
+the Frobenius endomorphism $a \mapsto a^p$ of $F$. Assume the degree of $F$ over this subfield is
+exactly $p$, i.e. $\mathrm{finrank}_{F^p} F = p$, and assume there is an element $y \in E$ whose
+image $\mathrm{algebraMap}\ E\ F\ y$ in $F$ does not lie in $F^p$, that is, is not a $p$-th power in
+$F$. The conclusion is that $F$ is a separable $E$-algebra, i.e. `Algebra.IsSeparable E F` holds:
+every element of $F$ is separable (algebraic with separable minimal polynomial) over $E$.
+
+This is the differential criterion for separability in the form used for function fields of curves
+over imperfect or positive-characteristic base fields: an imperfection hypothesis $[F:F^p]=p$
+together with one element of the base field that is not a $p$-th power forces $\Omega_{F/E}=0$ and
+hence separability. It is used to produce separating elements and separable coordinates, being cited
+in the construction of separating transcendental elements over perfect fields, in Weil reciprocity
+over algebraically closed fields, and in a separability statement for Hecke correspondences on
+modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Algebra_IsSeparable_of_finrank_fieldRange_frobenius_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_Algebra_IsSeparable_of_finrank_fieldRange_frobenius_eq
+
+theorem solution
+    {E F : Type*} [Field E] [Field F] [Algebra E F] [FiniteDimensional E F]
+    (p : ℕ) [Fact p.Prime] [CharP F p]
+    (hdeg : Module.finrank (frobenius F p).fieldRange F = p)
+    (y : E) (hy : algebraMap E F y ∉ (frobenius F p).fieldRange) :
+    Algebra.IsSeparable E F := by
+  set S : Subfield F := (frobenius F p).fieldRange with hS
+  have : IsSimpleOrder (IntermediateField S F) :=
+    IntermediateField.isSimpleOrder_of_finrank_prime S F (by rw [hdeg]; exact Fact.out)
+  set D := KaehlerDifferential.D E F with hD
+  have hDS : ∀ s : F, s ∈ S → D s = 0 := by
+    intro s hs
+    obtain ⟨a, rfl⟩ := RingHom.mem_fieldRange.mp hs
+    rw [frobenius_def, D.leibniz_pow, ← Nat.cast_smul_eq_nsmul F, CharP.cast_eq_zero, zero_smul]
+  have hDy : D (algebraMap E F y) = 0 := D.map_algebraMap y
+  let Z : IntermediateField S F :=
+    { carrier := {z | D z = 0}
+      mul_mem' := by
+        intro a b ha hb
+        simp only [Set.mem_ofPred_eq] at ha hb ⊢
+        rw [D.leibniz, ha, hb, smul_zero, smul_zero, add_zero]
+      one_mem' := D.map_one_eq_zero
+      add_mem' := by
+        intro a b ha hb
+        simp only [Set.mem_ofPred_eq] at ha hb ⊢
+        rw [map_add, ha, hb, add_zero]
+      zero_mem' := map_zero D
+      algebraMap_mem' := fun s => hDS _ s.2
+      inv_mem' := by
+        intro z hz
+        simp only [Set.mem_ofPred_eq] at hz ⊢
+        rw [D.leibniz_inv, hz, smul_zero] }
+  have hyZ : IntermediateField.adjoin S {algebraMap E F y} ≤ Z :=
+    IntermediateField.adjoin_le_iff.mpr (Set.singleton_subset_iff.mpr hDy)
+  have hZ : Z = ⊤ := by
+    rcases IsSimpleOrder.eq_bot_or_eq_top (IntermediateField.adjoin S {algebraMap E F y})
+      with h | h
+    · exfalso
+      apply hy
+      have hmem : algebraMap E F y ∈ (⊥ : IntermediateField S F) :=
+        h ▸ IntermediateField.mem_adjoin_simple_self S (algebraMap E F y)
+      obtain ⟨s, hs⟩ := IntermediateField.mem_bot.mp hmem
+      rw [← hs]
+      exact s.2
+    · rw [h] at hyZ
+      exact top_le_iff.mp hyZ
+  have hD0 : ∀ z : F, D z = 0 := fun z => by
+    have hz : z ∈ Z := hZ ▸ IntermediateField.mem_top
+    exact hz
+  have : Subsingleton (KaehlerDifferential E F) := by
+    refine subsingleton_of_forall_eq 0 fun ω => ?_
+    have hω : ω ∈ Submodule.span F (Set.range D) := by
+      rw [hD, KaehlerDifferential.span_range_derivation]
+      trivial
+    have hle : Submodule.span F (Set.range D) ≤ ⊥ := by
+      refine Submodule.span_le.mpr ?_
+      rintro _ ⟨z, rfl⟩
+      exact (Submodule.mem_bot F).mpr (hD0 z)
+    exact (Submodule.mem_bot F).mp (hle hω)
+  have : Algebra.FormallyUnramified E F := ⟨inferInstance⟩
+  exact Algebra.FormallyUnramified.isSeparable E F
+
+end S_Algebra_IsSeparable_of_finrank_fieldRange_frobenius_eq
+end P2MW
+export P2MW.S_Algebra_IsSeparable_of_finrank_fieldRange_frobenius_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem Algebra.IsSeparable.of_finrank_fieldRange_frobenius_eq {E F : Type*} [Field E] [Field F]
+    [Algebra E F] [FiniteDimensional E F] (p : ℕ) [Fact p.Prime] [CharP F p]
+    (hdeg : Module.finrank (frobenius F p).fieldRange F = p) (y : E)
+    (hy : algebraMap E F y ∉ (frobenius F p).fieldRange) :
+    Algebra.IsSeparable E F :=
+  solution p hdeg y hy
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_degree_eq_finrank_adjoin_of_eq_max_neg_ord.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_degree_eq_finrank_adjoin_of_eq_max_neg_ord.lean
new file mode 100644
index 0000000000..1274023481
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_degree_eq_finrank_adjoin_of_eq_max_neg_ord.lean
@@ -0,0 +1,94 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Divisor.degree_eq_finrank_adjoin_of_eq_max_neg_ord
+(57d2ada4-2ffa-5ce9-b741-bb0d72e2137a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 65f5b5e6-a519-5faa-8fc5-e6fe556f15b1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_finrank_adjoin_le_degree_of_eq_max_neg_ord
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_le_finrank_adjoin_of_eq_max_neg_ord
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree of the pole divisor of x equals [F:K(x)]
+
+Theorem statement: `AlgebraicCurve.Divisor.degree_eq_finrank_adjoin_of_eq_max_neg_ord`
+(`57d2ada4-2ffa-5ce9-b741-bb0d72e2137a`), by Claude, 2026-09-05.
+
+Proof: submission `65f5b5e6-a519-5faa-8fc5-e6fe556f15b1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K \subseteq F$ be fields with $F$ a $K$-algebra satisfying `IsCurveOver K F`, that is: every
+nonzero $f \in F$ admits a divisor $D$ with $D(v) = \operatorname{ord}_v f$ at every place and $\deg
+D = 0$; every place has residue field finite over $K$; and the module of Kähler differentials
+$\Omega[F/K]$ is free of rank one over $F$. Here a place $v$ is a valuation subring of $F$
+containing the image of $K$, different from $F$ itself, and a principal ideal ring;
+$\operatorname{ord}_v$ is minus the logarithm of the associated adic valuation; a divisor is a
+finitely supported integer-valued function on places, and its degree is $\sum_v D(v)\,\deg v$ with
+the project's place degrees. Assume in addition that the Riemann–Roch space $L(0) = \{f \in F : v(f)
+\le 1 \text{ for all } v\}$ is finite-dimensional over $K$. Let $x \in F$ be transcendental over $K$
+and suppose $F$ is finite-dimensional over the intermediate field $K(x)$ generated by $x$. Let $D$
+be a divisor with $D(v) = \max(0, -\operatorname{ord}_v x)$ for every place $v$, i.e. the pole
+divisor of $x$. Then $\deg D$ equals $[F : K(x)]$, viewed as an integer.
+
+This is the classical statement that the degree of the pole divisor of a non-constant function $x$
+on a curve equals the degree of the field extension $F/K(x)$, with no separability hypothesis. It is
+used in the construction of regular prolongations and the associated dimension counts, and in the
+companion statement for the divisor attached to $x - a$ for $a \in K$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Divisor_degree_eq_finrank_adjoin_of_eq_max_neg_ord.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Divisor_degree_eq_finrank_adjoin_of_eq_max_neg_ord
+
+open AlgebraicCurve
+
+theorem solution
+    {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (x : F) (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    (D : Divisor K F) (hD : ∀ v : Place K F, D v = max 0 (-v.ord x)) :
+    Divisor.degree D = (Module.finrank (IntermediateField.adjoin K ({x} : Set F)) F : ℤ) :=
+  le_antisymm
+    (Divisor.degree_le_finrank_adjoin_of_eq_max_neg_ord x hx D hD)
+    (Divisor.finrank_adjoin_le_degree_of_eq_max_neg_ord x hx D hD)
+
+end S_AlgebraicCurve_Divisor_degree_eq_finrank_adjoin_of_eq_max_neg_ord
+end P2MW
+export P2MW.S_AlgebraicCurve_Divisor_degree_eq_finrank_adjoin_of_eq_max_neg_ord (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Divisor.degree_eq_finrank_adjoin_of_eq_max_neg_ord
+    {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (x : F) (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    (D : Divisor K F) (hD : ∀ v : Place K F, D v = max 0 (-v.ord x)) :
+    Divisor.degree D = (Module.finrank (IntermediateField.adjoin K ({x} : Set F)) F : ℤ) :=
+  solution x hx D hD
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_degree_eq_finrank_adjoin_of_eq_max_ord_sub_algebraMap.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_degree_eq_finrank_adjoin_of_eq_max_ord_sub_algebraMap.lean
new file mode 100644
index 0000000000..52a92aa61a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_degree_eq_finrank_adjoin_of_eq_max_ord_sub_algebraMap.lean
@@ -0,0 +1,162 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Divisor.degree_eq_finrank_adjoin_of_eq_max_ord_sub_algebraMap
+(1781cf32-200c-5754-a230-e31ecb0c4e36) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c90ac65a-83dd-5dcf-b598-ad7f9519bc1f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_finrank_adjoin_of_eq_max_neg_ord
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Zero divisor of x-a has degree [F:K(x)]
+
+Theorem statement: `AlgebraicCurve.Divisor.degree_eq_finrank_adjoin_of_eq_max_ord_sub_algebraMap`
+(`1781cf32-200c-5754-a230-e31ecb0c4e36`), by Claude, 2026-09-05.
+
+Proof: submission `c90ac65a-83dd-5dcf-b598-ad7f9519bc1f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra satisfying `IsCurveOver K F`: every nonzero $f \in
+F$ admits a finitely supported divisor $P$ with $P(v) = \operatorname{ord}_v f$ at every place and
+$\deg P = 0$; each residue field $v.\mathrm{ResidueField}$ is finite over $K$; and $\Omega_{F/K}$ is
+free of rank $1$ over $F$. Here a place $v$ is a valuation subring of $F$ containing
+$\operatorname{im}(K \to F)$, distinct from $F$ itself and a principal ideal ring, with
+$\operatorname{ord}_v f = -\log v(f)$ for the adic valuation of the associated height-one prime.
+Assume also that $\mathrm{LSpace}\,0 = \{f : v(f) \le 1 \text{ for all } v\}$ is finite-dimensional
+over $K$. Let $x \in F$ be transcendental over $K$, with $F$ finite-dimensional over the
+intermediate field $K(x)$ generated by $x$, let $a \in K$, and let $D$ be a finitely supported
+$\mathbb{Z}$-valued function on places with $D(v) = \max(0, \operatorname{ord}_v(x - a))$ for all
+$v$, i.e. the divisor of zeros of $x - a$. Then $\deg D = \sum_v D(v)\cdot \deg v$ equals $[F :
+K(x)]$, viewed in $\mathbb{Z}$.
+
+This is the standard statement that the fibre of the map $x : X \to \mathbb{P}^1$ over a rational
+point $a \in K$, counted with multiplicities and residue degrees, has size the degree $[F : K(x)]$;
+it is the companion, over a finite point, of the corresponding statement for the pole divisor of
+$x$. It is used in counting places with prescribed behaviour over an algebraically closed base
+field, where every place has degree $1$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Divisor_degree_eq_finrank_adjoin_of_eq_max_ord_sub_algebraMap.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Divisor_degree_eq_finrank_adjoin_of_eq_max_ord_sub_algebraMap
+
+open AlgebraicCurve
+
+namespace FibreDegE96
+
+open AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem adicValuation_eq_exp (v : Place K F) {f : F} (hf : f ≠ 0) :
+    v.adicValuation f = WithZero.exp (-v.ord f) := by
+  rw [Place.ord, neg_neg, WithZero.exp_log (v.adicValuation_ne_zero hf)]
+
+theorem ord_sub_algebraMap_of_neg (v : Place K F) {x : F} (hx : x ≠ 0) (a : K)
+    (hxa : x - algebraMap K F a ≠ 0)
+    (h : v.ord x < 0) : v.ord (x - algebraMap K F a) = v.ord x := by
+  have hc : v.adicValuation (algebraMap K F a) ≤ 1 := v.adicValuation_algebraMap_le_one a
+  have hxv : 1 < v.adicValuation x := by
+    rw [adicValuation_eq_exp v hx, ← WithZero.exp_zero, WithZero.exp_lt_exp]; omega
+  have hlt : v.adicValuation (-algebraMap K F a) < v.adicValuation x := by
+    rw [Valuation.map_neg]; exact lt_of_le_of_lt hc hxv
+  have heq : v.adicValuation (x - algebraMap K F a) = v.adicValuation x := by
+    rw [sub_eq_add_neg, Valuation.map_add_eq_of_lt_left _ hlt]
+  rw [adicValuation_eq_exp v hxa, adicValuation_eq_exp v hx] at heq
+  have := WithZero.exp_injective heq
+  omega
+
+theorem ord_sub_algebraMap_nonneg (v : Place K F) {x : F} (hx : x ≠ 0) (a : K)
+    (hxa : x - algebraMap K F a ≠ 0)
+    (h : 0 ≤ v.ord x) : 0 ≤ v.ord (x - algebraMap K F a) := by
+  have hc : v.adicValuation (algebraMap K F a) ≤ 1 := v.adicValuation_algebraMap_le_one a
+  have hxv : v.adicValuation x ≤ 1 := by
+    rw [adicValuation_eq_exp v hx, ← WithZero.exp_zero, WithZero.exp_le_exp]; omega
+  have hle : v.adicValuation (x - algebraMap K F a) ≤ 1 :=
+    (Valuation.map_sub _ _ _).trans (max_le hxv hc)
+  rw [adicValuation_eq_exp v hxa, ← WithZero.exp_zero, WithZero.exp_le_exp] at hle
+  omega
+
+end FibreDegE96
+
+theorem solution
+    {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (x : F) (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    (a : K) (D : Divisor K F) (hD : ∀ v : Place K F, D v = max 0 (v.ord (x - algebraMap K F a))) :
+    Divisor.degree D = (Module.finrank (IntermediateField.adjoin K ({x} : Set F)) F : ℤ) := by
+  classical
+  have hxa : x - algebraMap K F a ≠ 0 := by
+    intro h
+    apply hx
+    rw [sub_eq_zero] at h
+    rw [h]
+    exact isAlgebraic_algebraMap a
+  have hx0 : x ≠ 0 := by
+    intro h; apply hx; rw [h]; exact isAlgebraic_zero
+  obtain ⟨P, hP, hP0⟩ := (IsCurveOver.hasPrincipalDivisors (K := K) (F := F)).exists_divisor _ hxa
+  let Dinf : Divisor K F := P.mapRange (fun n => max 0 (-n)) (by simp)
+  have hDinf : ∀ v : Place K F, Dinf v = max 0 (-v.ord x) := by
+    intro v
+    change max 0 (-P v) = _
+    rw [hP v]
+    rcases lt_or_ge (v.ord x) 0 with h | h
+    · rw [FibreDegE96.ord_sub_algebraMap_of_neg v hx0 a hxa h]
+    · have h' := FibreDegE96.ord_sub_algebraMap_nonneg v hx0 a hxa h
+      rw [max_eq_left (by
+        omega : -v.ord (x - algebraMap K F a) ≤ 0), max_eq_left (by
+          omega : -v.ord x ≤ 0)]
+  have hsplit : D - Dinf = P := by
+    ext v
+    rw [Finsupp.sub_apply, hD v]
+    change max 0 (v.ord (x - algebraMap K F a)) - max 0 (-P v) = P v
+    rw [hP v]
+    omega
+  have hdeg : Divisor.degree D = Divisor.degree Dinf := by
+    have := congrArg Divisor.degree hsplit
+    rw [map_sub, hP0] at this
+    omega
+  rw [hdeg]
+  exact AlgebraicCurve.Divisor.degree_eq_finrank_adjoin_of_eq_max_neg_ord x hx Dinf hDinf
+
+end S_AlgebraicCurve_Divisor_degree_eq_finrank_adjoin_of_eq_max_ord_sub_algebraMap
+end P2MW
+export P2MW.S_AlgebraicCurve_Divisor_degree_eq_finrank_adjoin_of_eq_max_ord_sub_algebraMap
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Divisor.degree_eq_finrank_adjoin_of_eq_max_ord_sub_algebraMap
+    {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (x : F) (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    (a : K) (D : Divisor K F) (hD : ∀ v : Place K F, D v = max 0 (v.ord (x - algebraMap K F a))) :
+    Divisor.degree D = (Module.finrank (IntermediateField.adjoin K ({x} : Set F)) F : ℤ) :=
+  solution x hx a D hD
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_degree_eq_sum.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_degree_eq_sum.lean
new file mode 100644
index 0000000000..4d3e2a3499
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_degree_eq_sum.lean
@@ -0,0 +1,82 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Divisor.degree_eq_sum
+(ea986e31-bd95-5fff-9fd4-4b9978eb1e45) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 97e6daa9-390a-571d-b1a0-087fab740c1a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree of a divisor as a sum over its support
+
+Theorem statement: `AlgebraicCurve.Divisor.degree_eq_sum` (`ea986e31-bd95-5fff-9fd4-4b9978eb1e45`),
+by Claude, 2026-09-05.
+
+Proof: submission `97e6daa9-390a-571d-b1a0-087fab740c1a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $D$ be a divisor of $F$ over $K$, that is,
+a finitely supported function from $\mathrm{Place}\ K\ F$ to $\mathbb{Z}$, where a place is a
+valuation subring of $F$ that contains the image of $K$ under the structure map, is not all of $F$,
+and is a principal ideal ring. For such a place $v$, its degree $v.\mathrm{deg}$ is the
+$K$-dimension $\operatorname{finrank}_K$ of the residue field of $v.\mathrm{toValuationSubring}$ as
+a local ring, an element of $\mathbb{N}$. The degree homomorphism $\mathrm{Divisor.degree}$ is
+defined as the additive homomorphism obtained from the family of maps $n \mapsto n \cdot
+v.\mathrm{deg}$ on $\mathbb{Z}$ by the universal property of finitely supported functions. The
+assertion is that this homomorphism is computed by the expected finite sum: $\mathrm{degree}\ D =
+\sum_{v \in \operatorname{supp} D} D(v) \cdot (v.\mathrm{deg} : \mathbb{Z})$, the sum being over the
+(finite) support of $D$ and the natural number $v.\mathrm{deg}$ being cast to $\mathbb{Z}$.
+
+This is the standard unfolding of the degree map on divisors of a function field into the explicit
+weighted sum of coefficients by residue degrees. It is the computational interface to
+$\mathrm{Divisor.degree}$, used in the treatment of degree-zero divisors and principal divisors (for
+instance in the statements about principality of degree-zero divisors on a rational function field,
+about the existence of principal divisors under finiteness and separability hypotheses, and in
+divisor bookkeeping for models of modular curves).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Divisor_degree_eq_sum.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Divisor_degree_eq_sum
+
+open IsDedekindDomain WithZero IsLocalRing
+
+open AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (D : Divisor K F) :
+    Divisor.degree D = ∑ v ∈ D.support, D v * (v.deg : ℤ) :=
+  Finsupp.liftAddHom_apply (fun v : Place K F => AddMonoidHom.mulRight (v.deg : ℤ)) D
+
+end S_AlgebraicCurve_Divisor_degree_eq_sum
+end P2MW
+export P2MW.S_AlgebraicCurve_Divisor_degree_eq_sum (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Divisor.degree_eq_sum {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (D : Divisor K F) :
+    Divisor.degree D = ∑ v ∈ D.support, D v * (v.deg : ℤ) :=
+  solution D
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_degree_eq_sum_support.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_degree_eq_sum_support.lean
new file mode 100644
index 0000000000..1ae1e872f7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_degree_eq_sum_support.lean
@@ -0,0 +1,143 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Divisor.degree_eq_sum_support
+(7b62f3d0-961d-566a-9c60-2ccdda7f0bd5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 98cdaffb-f12c-5d1e-9b38-d5d82cbcfe87
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree of a divisor as a sum over its support
+
+Theorem statement: `AlgebraicCurve.Divisor.degree_eq_sum_support`
+(`7b62f3d0-961d-566a-9c60-2ccdda7f0bd5`), by Claude, 2026-09-05.
+
+Proof: submission `98cdaffb-f12c-5d1e-9b38-d5d82cbcfe87`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $D$ be a divisor of $F/K$, i.e. a finitely
+supported function $D \colon \mathrm{Place}\,K\,F \to \mathbb{Z}$, where a place $v$ of $F/K$ is by
+definition a valuation subring $v$ of $F$ that contains $\mathrm{algebraMap}\,K\,F(a)$ for every $a
+\in K$, is not the whole of $F$, and is a principal ideal ring. For such a place, $v.\mathrm{deg}$
+is the $K$-dimension $\mathrm{finrank}_K$ of the residue field of the local ring $v$, and
+$\mathrm{Divisor.degree}$ is the additive homomorphism from divisors to $\mathbb{Z}$ obtained by
+lifting, place by place, the map 'multiply on the right by $(v.\mathrm{deg} : \mathbb{Z})$'. The
+theorem asserts that this homomorphism is computed by the expected finite sum: $$\mathrm{degree}\,D
+= \sum_{v \in \mathrm{supp}\,D} D(v)\cdot (v.\mathrm{deg} : \mathbb{Z}),$$ the sum being taken over
+the (finite) support of $D$ inside the type of places, with the natural number $v.\mathrm{deg}$ cast
+to $\mathbb{Z}$. No further hypotheses (finiteness of residue degrees, curve conditions,
+separability) are imposed.
+
+This is the unfolding of the divisor degree map of a function field $F/K$ into the classical formula
+$\deg D = \sum_v n_v\,[\kappa(v):K]$, and it is the computational entry point for all sign arguments
+about degrees: it is used to show that effective divisors have non-negative degree, whence that the
+Riemann–Roch space of a divisor of negative degree vanishes, and it is cited by several results on
+degrees of principal divisors and on points of curves over algebraically closed fields.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Divisor_degree_eq_sum_support.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Divisor_degree_eq_sum_support
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor Divisor.degree HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor IsCurveOver LSpace ell mem_lSpace_iff_ord \
+  WeilDifferentialRankOne StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "deg ord ord_unit_smul_zpow exists_unit_mul_zpow \
+  toValuationSubring"
+p2m_open "AlgebraicCurve.Place"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+p2m_export "AlgebraicCurve.Place" "ord_nonneg_of_mem"
+p2m_export "AlgebraicCurve.Place" "mem_of_ord_nonneg"
+theorem mem_iff_ord_nonneg {f : F} (hf : f ≠ 0) :
+    f ∈ v.toValuationSubring ↔ 0 ≤ v.ord f :=
+  ⟨v.ord_nonneg_of_mem, v.mem_of_ord_nonneg hf⟩
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor Divisor.degree HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor IsCurveOver LSpace ell mem_lSpace_iff_ord \
+  WeilDifferentialRankOne StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "degree"
+end Divisor
+p2m_open_scoped "AlgebraicCurve.Divisor" in
+theorem Divisor.degree_eq_sum_support_port (D : Divisor K F) :
+    Divisor.degree D = ∑ v ∈ D.support, D v * (v.deg : ℤ) := by
+  rw [Divisor.degree, Finsupp.liftAddHom_apply, Finsupp.sum]
+  rfl
+variable {D : Divisor K F}
+p2m_open_scoped "AlgebraicCurve.Divisor" in
+theorem Divisor.degree_nonneg_of_nonneg [IsCurveOver K F]
+    {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) : 0 ≤ Divisor.degree D := by
+  rw [Divisor.degree_eq_sum_support_port]
+  exact Finset.sum_nonneg fun v _ => mul_nonneg (hD v) (Int.natCast_nonneg _)
+theorem lSpace_eq_bot_of_degree_neg [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) : LSpace D = ⊥ := by
+  rw [eq_bot_iff]
+  intro f hf
+  rw [Submodule.mem_bot]
+  by_contra hf0
+  obtain ⟨P, hPord, hPdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+  have heff : ∀ v : Place K F, 0 ≤ (P + D) v := by
+    intro v
+    rw [Finsupp.add_apply, hPord]
+    rcases mem_lSpace_iff_ord.mp hf with rfl | h
+    · exact absurd rfl hf0
+    · linarith [h v]
+  have hdegPD : 0 ≤ Divisor.degree (P + D) := Divisor.degree_nonneg_of_nonneg heff
+  rw [map_add, hPdeg, zero_add] at hdegPD
+  exact absurd hdegPD (not_le.mpr hD)
+end AlgebraicCurve
+
+open _root_.AlgebraicCurve _root_.P2MW.S_AlgebraicCurve_Divisor_degree_eq_sum_support.AlgebraicCurve
+  in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (D : Divisor K F) :
+    Divisor.degree D = ∑ v ∈ D.support, D v * (v.deg : ℤ) :=
+  AlgebraicCurve.Divisor.degree_eq_sum_support_port (K := K) (F := F) (D := D)
+
+end S_AlgebraicCurve_Divisor_degree_eq_sum_support
+end P2MW
+export P2MW.S_AlgebraicCurve_Divisor_degree_eq_sum_support (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace AlgebraicCurve
+theorem Divisor.degree_eq_sum_support {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (D : Divisor K F) :
+    Divisor.degree D = ∑ v ∈ D.support, D v * (v.deg : ℤ) :=
+  solution D
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_degree_le_finrank_adjoin_of_eq_max_neg_ord.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_degree_le_finrank_adjoin_of_eq_max_neg_ord.lean
new file mode 100644
index 0000000000..09085f16c3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_degree_le_finrank_adjoin_of_eq_max_neg_ord.lean
@@ -0,0 +1,596 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Divisor.degree_le_finrank_adjoin_of_eq_max_neg_ord
+(874c1f23-9139-58ac-bea5-69dda441aeaf) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1164fb22-5272-5a31-bc88-20bd0fe26710
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import Mathlib.Analysis.Normed.Ring.Lemmas
+import Mathlib.RingTheory.Flat.TorsionFree
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_forall_ord_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Pole divisor degree at most [F:K(x)]
+
+Theorem statement: `AlgebraicCurve.Divisor.degree_le_finrank_adjoin_of_eq_max_neg_ord`
+(`874c1f23-9139-58ac-bea5-69dda441aeaf`), by Claude, 2026-09-05.
+
+Proof: submission `1164fb22-5272-5a31-bc88-20bd0fe26710`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra satisfying `IsCurveOver K F`: every nonzero $f \in
+F$ has a finitely supported divisor recording its orders, $D(v) = \operatorname{ord}_v f$ at every
+place $v$, of degree $0$; every place has residue field finite over $K$; and $\Omega[F/K]$ is free
+of rank one over $F$. Here a place $v$ of $F/K$ is a valuation subring of $F$ containing
+$\operatorname{im}(K \to F)$, distinct from $F$ itself, which is a principal ideal ring,
+$\operatorname{ord}_v$ is the associated normalised additive valuation, a divisor is a finitely
+supported $\mathbb{Z}$-valued function on places, and $\deg D = \sum_v D(v)\deg v$. Assume in
+addition that the Riemann–Roch space of the zero divisor, $\{f \in F : v(f) \le 1 \text{ for all }
+v\}$, is finite-dimensional over $K$. Let $x \in F$ be transcendental over $K$ and assume $F$ is
+finite-dimensional over the intermediate field $K(x)$ generated by $x$. Let $D$ be a divisor with
+$D(v) = \max(0, -\operatorname{ord}_v x)$ for every place $v$, i.e. the pole divisor of $x$. Then
+$\deg D \le [F : K(x)]$, the inequality taken in $\mathbb{Z}$.
+
+This is one half of the classical identity $\deg (x)_\infty = [F:K(x)]$ for a one-variable function
+field, the direction given by the fundamental inequality $\sum_{P \mid \infty} e_P f_P \le [F:K(x)]$
+for the extensions of the infinite place of $K(x)$, and it requires no separability assumption. It
+feeds into
+[`AlgebraicCurve.Divisor.degree_eq_finrank_adjoin_of_eq_max_neg_ord`]
+(thm.html#AlgebraicCurve.Divisor.degree_eq_finrank_adjoin_of_eq_max_neg_ord),
+where the two inequalities are combined into the equality.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Divisor_degree_le_finrank_adjoin_of_eq_max_neg_ord.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 8000000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Divisor_degree_le_finrank_adjoin_of_eq_max_neg_ord
+
+
+open AlgebraicCurve Polynomial WithZero IsDedekindDomain
+
+theorem solution
+    {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (x : F) (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    (D : Divisor K F) (hD : ∀ v : Place K F, D v = max 0 (-v.ord x)) :
+    Divisor.degree D ≤ (Module.finrank (IntermediateField.adjoin K ({x} : Set F)) F : ℤ) := by
+  classical
+  set E : IntermediateField K F := IntermediateField.adjoin K ({x} : Set F) with hE
+  set n : ℕ := Module.finrank E F with hn
+  have hx0 : x ≠ 0 := fun h => hx (h ▸ isAlgebraic_zero)
+  have hxE_mem : x ∈ E := IntermediateField.mem_adjoin_simple_self K x
+  set xE : E := ⟨x, hxE_mem⟩ with hxE_def
+  have hxE0 : xE ≠ 0 := fun h => hx0 (by rw [← show ((xE:F)=x) from rfl, h]; rfl)
+  set S : Finset (Place K F) := D.support with hS
+  have hSpole : ∀ v ∈ S, v.ord x < 0 := by
+    intro v hv; have := Finsupp.mem_support_iff.mp hv; rw [hD] at this; omega
+  have hDv : ∀ v ∈ S, D v = -v.ord x := by
+    intro v hv; rw [hD]; exact max_eq_right (by linarith [hSpole v hv])
+  have hDvpos : ∀ v ∈ S, 1 ≤ D v := by
+    intro v hv; have := hSpole v hv; rw [hDv v hv]; omega
+  have hdegD : Divisor.degree D = ∑ v ∈ S, D v * (v.deg : ℤ) := by
+    simp only [Divisor.degree, Finsupp.liftAddHom_apply, AddMonoidHom.mulRight_apply,
+      Finsupp.sum]
+    rfl
+  have hmem_max : ∀ (v : Place K F) (f : F) (hf : f ∈ v.toValuationSubring),
+      0 < v.ord f → (⟨f, hf⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal _ := by
+    intro v f hf hord
+    rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+    intro hu
+    have hval := (v.adicValuation_coe_eq_one_iff ⟨f, hf⟩).mpr hu
+    simp only [Place.ord, hval, WithZero.log_one, neg_zero] at hord
+    exact lt_irrefl 0 hord
+  have hunit_iff : ∀ (v : Place K F) (a : v.toValuationSubring),
+      IsUnit a ↔ IsLocalRing.residue _ a ≠ 0 := by
+    intro v a
+    rw [ne_eq, ← not_iff_not, not_not, ← mem_nonunits_iff, ← IsLocalRing.mem_maximalIdeal]
+    exact Ideal.Quotient.eq_zero_iff_mem.symm
+  have hres_K : ∀ (v : Place K F) (c : K),
+      IsLocalRing.residue _ (⟨algebraMap K F c, v.algebraMap_mem' c⟩ : v.toValuationSubring)
+        = algebraMap K v.ResidueField c := by
+    intro v c
+    rw [show (⟨algebraMap K F c, v.algebraMap_mem' c⟩ : v.toValuationSubring)
+          = algebraMap K v.toValuationSubring c from rfl,
+        IsScalarTower.algebraMap_apply K v.toValuationSubring v.ResidueField]
+    rfl
+  have hord_K : ∀ (v : Place K F) (c : K), c ≠ 0 → v.ord (algebraMap K F c) = 0 := by
+    intro v c hc
+    have hunit : IsUnit (⟨algebraMap K F c, v.algebraMap_mem' c⟩ : v.toValuationSubring) := by
+      rw [hunit_iff, hres_K]
+      exact (map_ne_zero_iff _ (algebraMap K v.ResidueField).injective).mpr hc
+    have := (v.adicValuation_coe_eq_one_iff _).mpr hunit
+    simp only [Place.ord, this, WithZero.log_one, neg_zero]
+  have hkey : ∀ v ∈ S, ∀ p : K[X], p ≠ 0 →
+      ∃ h : aeval x p * x ^ (-(p.natDegree : ℤ)) ∈ v.toValuationSubring,
+        IsUnit (⟨_, h⟩ : v.toValuationSubring) ∧
+        IsLocalRing.residue _ ⟨_, h⟩ = algebraMap K v.ResidueField p.leadingCoeff := by
+    intro v hv p hp
+    set d := p.natDegree with hd
+    have hld : p.leadingCoeff ≠ 0 := Polynomial.leadingCoeff_ne_zero.mpr hp
+    have hexpand : aeval x p * x ^ (-(d:ℤ)) =
+        algebraMap K F p.leadingCoeff +
+        ∑ i ∈ Finset.range d, algebraMap K F (p.coeff i) * x ^ ((i:ℤ) - d) := by
+      rw [Polynomial.aeval_eq_sum_range, Finset.sum_range_succ,
+          show p.coeff d = p.leadingCoeff from rfl, add_mul, Finset.sum_mul,
+          add_comm]
+      congr 1
+      · rw [Algebra.smul_def, mul_assoc, ← zpow_natCast x d, ← zpow_add₀ hx0,
+            add_neg_cancel, zpow_zero, mul_one]
+      · refine Finset.sum_congr rfl fun i hi => ?_
+        rw [Algebra.smul_def, mul_assoc, ← zpow_natCast x i, ← zpow_add₀ hx0]
+        ring_nf
+    have hterm_mem : ∀ i ∈ Finset.range d,
+        algebraMap K F (p.coeff i) * x ^ ((i:ℤ) - d) ∈ v.toValuationSubring := by
+      intro i hi
+      rcases eq_or_ne (p.coeff i) 0 with hci | hci
+      · simp [hci]
+      · refine v.mem_of_ord_nonneg
+          (mul_ne_zero ((map_ne_zero_iff _ (algebraMap K F).injective).mpr hci)
+            (zpow_ne_zero _ hx0)) ?_
+        rw [v.ord_mul ((map_ne_zero_iff _ (algebraMap K F).injective).mpr hci)
+              (zpow_ne_zero _ hx0), hord_K v _ hci, zero_add, v.ord_zpow]
+        have hlt : (i:ℤ) - d < 0 := by have := Finset.mem_range.mp hi; omega
+        exact le_of_lt (mul_pos_of_neg_of_neg hlt (hSpole v hv))
+    have hterm_max : ∀ (i : ℕ) (hi : i ∈ Finset.range d),
+        (⟨_, hterm_mem i hi⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal _ := by
+      intro i hi
+      rcases eq_or_ne (p.coeff i) 0 with hci | hci
+      · have : (⟨_, hterm_mem i hi⟩ : v.toValuationSubring) = 0 := by
+          refine Subtype.ext ?_; simp [hci]
+        rw [this]; exact Ideal.zero_mem _
+      · refine hmem_max v _ _ ?_
+        rw [v.ord_mul ((map_ne_zero_iff _ (algebraMap K F).injective).mpr hci)
+              (zpow_ne_zero _ hx0), hord_K v _ hci, zero_add, v.ord_zpow]
+        have hlt : (i:ℤ) - d < 0 := by have := Finset.mem_range.mp hi; omega
+        exact mul_pos_of_neg_of_neg hlt (hSpole v hv)
+    set r : F := ∑ i ∈ Finset.range d, algebraMap K F (p.coeff i) * x ^ ((i:ℤ) - d) with hrdef
+    have hrmem : r ∈ v.toValuationSubring := sum_mem hterm_mem
+    have hrmax : (⟨r, hrmem⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal _ := by
+      have : (⟨r, hrmem⟩ : v.toValuationSubring)
+          = ∑ i ∈ (Finset.range d).attach, ⟨_, hterm_mem i.1 i.2⟩ := by
+        refine Subtype.ext ?_
+        push_cast
+        rw [Finset.sum_attach (Finset.range d)
+          (fun i => algebraMap K F (p.coeff i) * x ^ ((i:ℤ) - d))]
+      rw [this]
+      exact Ideal.sum_mem _ fun i _ => hterm_max i.1 i.2
+    have hcmem : algebraMap K F p.leadingCoeff ∈ v.toValuationSubring := v.algebraMap_mem' _
+    have hsummem : aeval x p * x ^ (-(d:ℤ)) ∈ v.toValuationSubring := by
+      rw [hexpand]; exact add_mem hcmem hrmem
+    have hsplit : (⟨_, hsummem⟩ : v.toValuationSubring)
+        = ⟨algebraMap K F p.leadingCoeff, hcmem⟩ + ⟨r, hrmem⟩ :=
+      Subtype.ext hexpand
+    have hres_eq : IsLocalRing.residue _ (⟨_, hsummem⟩ : v.toValuationSubring)
+        = algebraMap K v.ResidueField p.leadingCoeff := by
+      rw [hsplit, map_add, hres_K]
+      have : IsLocalRing.residue _ (⟨r, hrmem⟩ : v.toValuationSubring) = 0 :=
+        (Ideal.Quotient.eq_zero_iff_mem).mpr hrmax
+      rw [this, add_zero]
+    exact ⟨hsummem,
+      (hunit_iff v _).mpr (hres_eq ▸
+        (map_ne_zero_iff _ (algebraMap K v.ResidueField).injective).mpr hld),
+      hres_eq⟩
+  have haeval_ne_zero : ∀ p : K[X], p ≠ 0 → aeval x p ≠ 0 :=
+    fun p hp h => hx ⟨p, hp, h⟩
+  have hord_aeval : ∀ v ∈ S, ∀ p : K[X], p ≠ 0 →
+      v.ord (aeval x p) = (p.natDegree : ℤ) * v.ord x := by
+    intro v hv p hp
+    obtain ⟨hmem, hunit, _⟩ := hkey v hv p hp
+    have hordu : v.ord (aeval x p * x ^ (-(p.natDegree:ℤ))) = 0 := by
+      have := (v.adicValuation_coe_eq_one_iff ⟨_, hmem⟩).mpr hunit
+      simp only [Place.ord, this, WithZero.log_one, neg_zero]
+    rw [v.ord_mul (haeval_ne_zero p hp) (zpow_ne_zero _ hx0), v.ord_zpow] at hordu
+    linarith
+  have hord_E : ∀ g : E, (g:F) ≠ 0 → ∃ q : ℤ, ∀ v ∈ S, v.ord (g:F) = q * D v := by
+    intro g hg0
+    obtain ⟨r, s, hgrs⟩ := (IntermediateField.mem_adjoin_simple_iff K (x := (g:F))).mp g.2
+    have hs0 : s ≠ 0 := by
+      rintro rfl; simp only [map_zero, div_zero] at hgrs; exact hg0 hgrs
+    have hr0 : r ≠ 0 := by
+      rintro rfl; simp only [map_zero, zero_div] at hgrs; exact hg0 hgrs
+    refine ⟨-(r.natDegree - s.natDegree), fun v hv => ?_⟩
+    rw [hgrs, div_eq_mul_inv,
+        v.ord_mul (haeval_ne_zero r hr0) (inv_ne_zero (haeval_ne_zero s hs0)),
+        v.ord_inv, hord_aeval v hv r hr0, hord_aeval v hv s hs0, hDv v hv]
+    ring
+  have hres_E : ∀ v ∈ S, ∀ g : E, (g:F) ≠ 0 → v.ord (g:F) = 0 →
+      ∃ c : K, c ≠ 0 ∧ ∀ hmem : (g:F) ∈ v.toValuationSubring,
+        IsLocalRing.residue _ (⟨(g:F), hmem⟩ : v.toValuationSubring) = algebraMap K v.ResidueField c
+          := by
+    intro v hv g hg0 hord0
+    obtain ⟨r, s, hgrs⟩ := (IntermediateField.mem_adjoin_simple_iff K (x := (g:F))).mp g.2
+    have hs0 : s ≠ 0 := by rintro rfl; simp only [map_zero, div_zero] at hgrs; exact hg0 hgrs
+    have hr0 : r ≠ 0 := by rintro rfl; simp only [map_zero, zero_div] at hgrs; exact hg0 hgrs
+    have hdeg : (r.natDegree : ℤ) = s.natDegree := by
+      have := hord_aeval v hv r hr0; have hs := hord_aeval v hv s hs0
+      have h1 : v.ord (g:F) = (r.natDegree - s.natDegree : ℤ) * v.ord x := by
+        rw [hgrs, div_eq_mul_inv, v.ord_mul (haeval_ne_zero r hr0)
+            (inv_ne_zero (haeval_ne_zero s hs0)), v.ord_inv, this, hs]; ring
+      rw [hord0] at h1
+      have hvx := hSpole v hv
+      have : (r.natDegree : ℤ) - s.natDegree = 0 := by
+        by_contra hne
+        exact absurd h1 (mul_ne_zero hne (ne_of_lt hvx)).symm
+      linarith
+    obtain ⟨hmr, hur, hresr⟩ := hkey v hv r hr0
+    obtain ⟨hms, hus, hress⟩ := hkey v hv s hs0
+    refine ⟨r.leadingCoeff / s.leadingCoeff,
+      div_ne_zero (Polynomial.leadingCoeff_ne_zero.mpr hr0) (Polynomial.leadingCoeff_ne_zero.mpr
+        hs0),
+      fun hmem => ?_⟩
+    have hgval : (⟨(g:F), hmem⟩ : v.toValuationSubring) * ⟨_, hms⟩ = ⟨_, hmr⟩ := by
+      refine Subtype.ext ?_
+      change (g:F) * (aeval x s * x ^ (-(s.natDegree:ℤ))) = aeval x r * x ^ (-(r.natDegree:ℤ))
+      rw [hgrs, div_mul_eq_mul_div, mul_div_assoc,
+          mul_div_cancel_left₀ _ (haeval_ne_zero s hs0),
+          show (r.natDegree:ℤ) = s.natDegree from hdeg]
+    have hres_mul := congrArg (IsLocalRing.residue v.toValuationSubring) hgval
+    rw [map_mul, hress, hresr] at hres_mul
+    rw [map_div₀]
+    exact (div_eq_of_eq_mul
+      ((map_ne_zero_iff _ (algebraMap K v.ResidueField).injective).mpr
+        (Polynomial.leadingCoeff_ne_zero.mpr hs0)) hres_mul.symm).symm
+  have hex_t : ∀ v ∈ S, ∃ t : F, t ≠ 0 ∧ v.ord t = 1 ∧ ∀ v' ∈ S, v' ≠ v → v'.ord t = 0 := by
+    intro v hv
+    obtain ⟨t, ht0, htord⟩ := Place.exists_forall_ord_eq S (fun w => if w = v then 1 else 0)
+    exact ⟨t, ht0, by simpa using htord v hv, fun v' hv' hne => by simpa [hne] using htord v' hv'⟩
+  choose! t ht0 htv htv' using hex_t
+  have hfinres : ∀ v : Place K F, Module.Finite K v.ResidueField := IsCurveOver.finiteResidue
+  have hex_z : ∀ (v : Place K F) (hv : v ∈ S),
+      ∃ (z : Fin v.deg → F) (hreg : ∀ k, ∀ v' ∈ S, z k ∈ v'.toValuationSubring),
+      (∀ k, IsUnit (⟨z k, hreg k v hv⟩ : v.toValuationSubring)) ∧
+      LinearIndependent K (fun k => IsLocalRing.residue _
+        (⟨z k, hreg k v hv⟩ : v.toValuationSubring)) := by
+    intro v hv
+    have := hfinres v
+    let bκ : Module.Basis (Fin v.deg) K v.ResidueField := Module.finBasis K v.ResidueField
+    choose z₀ hz₀ using fun k =>
+      Ideal.Quotient.mk_surjective (I := IsLocalRing.maximalIdeal v.toValuationSubring) (bκ k)
+    have hz₀' : ∀ k, IsLocalRing.residue _ (z₀ k) = bκ k := hz₀
+    set zF : Fin v.deg → F := fun k => (z₀ k : F) with hzF
+    have hzF_v : ∀ k, zF k ∈ v.toValuationSubring := fun k => (z₀ k).2
+    have hzF_z₀ : ∀ k, (⟨zF k, hzF_v k⟩ : v.toValuationSubring) = z₀ k := fun k => rfl
+    set N : ℕ := (Finset.univ : Finset (Fin v.deg)).sup fun k =>
+      S.sup fun v' => (-(v'.ord (zF k))).toNat with hN
+    obtain ⟨c, hc0, hcord⟩ := Place.exists_forall_ord_eq S
+      (fun w => if w = v then 0 else (N : ℤ))
+    have hcmem : ∀ v' ∈ S, c ∈ v'.toValuationSubring := by
+      intro v' hv'
+      refine v'.mem_of_ord_nonneg hc0 ?_
+      rw [hcord v' hv']; split_ifs <;> positivity
+    set cv : v.toValuationSubring := ⟨c, hcmem v hv⟩ with hcvdef
+    have hcunit : IsUnit cv := by
+      rw [← v.adicValuation_coe_eq_one_iff,
+          show v.adicValuation (cv:F) = WithZero.exp (-(v.ord c)) from by
+            rw [Place.ord, neg_neg, WithZero.exp_log (v.adicValuation_ne_zero hc0)],
+          hcord v hv, ite_eq_left rfl, neg_zero, WithZero.exp_zero]
+    have hresc_ne : IsLocalRing.residue _ cv ≠ 0 := (hunit_iff v _).mp hcunit
+    have hreg : ∀ k, ∀ v' ∈ S, c * zF k ∈ v'.toValuationSubring := by
+      intro k v' hv'
+      rcases eq_or_ne (zF k) 0 with hz0 | hz0
+      · simp [hz0]
+      refine v'.mem_of_ord_nonneg (mul_ne_zero hc0 hz0) ?_
+      rw [v'.ord_mul hc0 hz0, hcord v' hv']
+      split_ifs with heq
+      · rw [zero_add, heq]; exact v.ord_nonneg_of_mem (hzF_v k)
+      · have hle : (-(v'.ord (zF k))).toNat ≤ N := by
+          refine le_trans ?_ (Finset.le_sup (f := fun k => S.sup fun v' =>
+            (-(v'.ord (zF k))).toNat) (Finset.mem_univ k))
+          exact Finset.le_sup (f := fun w => (-(w.ord (zF k))).toNat) hv'
+        omega
+    refine ⟨fun k => c * zF k, hreg, ?_, ?_⟩
+    · intro k
+      rw [hunit_iff,
+          show (⟨c * zF k, hreg k v hv⟩ : v.toValuationSubring) = cv * z₀ k from Subtype.ext rfl,
+          map_mul, hz₀']
+      exact mul_ne_zero hresc_ne (bκ.ne_zero k)
+    · have heq : (fun k => IsLocalRing.residue _ (⟨c * zF k, hreg k v hv⟩ : v.toValuationSubring))
+          = (LinearMap.mulLeft K (IsLocalRing.residue _ cv)) ∘ bκ := by
+        funext k
+        rw [show (⟨c * zF k, hreg k v hv⟩ : v.toValuationSubring) = cv * z₀ k from Subtype.ext rfl,
+            map_mul, hz₀']
+        rfl
+      rw [heq]
+      exact bκ.linearIndependent.map' (LinearMap.mulLeft K (IsLocalRing.residue _ cv))
+        (LinearMap.ker_eq_bot.mpr (mul_right_injective₀ hresc_ne))
+  choose z hz_reg hz_unit hz_li using hex_z
+  let ι := (v : S) × Fin (D v.1).toNat × Fin v.1.deg
+  let T : ι → F := fun i => z i.1.1 i.1.2 i.2.2 * (t i.1.1) ^ (-((i.2.1:ℤ)+1))
+  have hz_ne0 : ∀ (v : Place K F) (hv : v ∈ S) (k : Fin v.deg), z v hv k ≠ 0 := by
+    intro v hv k h
+    have := (hz_unit v hv k)
+    rw [show (⟨z v hv k, hz_reg v hv k v hv⟩ : v.toValuationSubring) = 0 from
+      Subtype.ext (by simp [h])] at this
+    exact not_isUnit_zero this
+  have hT_ne0 : ∀ i : ι, T i ≠ 0 := fun i =>
+    mul_ne_zero (hz_ne0 i.1.1 i.1.2 i.2.2) (zpow_ne_zero _ (ht0 i.1.1 i.1.2))
+  have hz_ord0 : ∀ (v : Place K F) (hv : v ∈ S) (k : Fin v.deg), v.ord (z v hv k) = 0 := by
+    intro v hv k
+    have := (v.adicValuation_coe_eq_one_iff _).mpr (hz_unit v hv k)
+    simp only [Place.ord, this, WithZero.log_one, neg_zero]
+  have hT_ord_own : ∀ i : ι, i.1.1.ord (T i) = -((i.2.1:ℤ)+1) := by
+    intro i
+    simp only [T]
+    rw [i.1.1.ord_mul (hz_ne0 _ _ _) (zpow_ne_zero _ (ht0 _ i.1.2)),
+        hz_ord0, zero_add, i.1.1.ord_zpow, htv i.1.1 i.1.2, mul_one]
+  have hT_ord_other : ∀ (i : ι) (v' : Place K F) (hv' : v' ∈ S), v' ≠ i.1.1 →
+      0 ≤ v'.ord (T i) := by
+    intro i v' hv' hne
+    simp only [T]
+    rw [v'.ord_mul (hz_ne0 _ _ _) (zpow_ne_zero _ (ht0 _ i.1.2)),
+        v'.ord_zpow, htv' i.1.1 i.1.2 v' hv' hne, mul_zero, add_zero]
+    exact Place.ord_nonneg_of_mem v' (hz_reg _ _ _ v' hv')
+  have hTli : LinearIndependent E T := by
+    rw [Fintype.linearIndependent_iff]
+    intro φ hsum
+    by_contra hex
+    push Not at hex
+    obtain ⟨i₁, hφi₁⟩ := hex
+    set supp := (Finset.univ : Finset ι).filter (fun i => φ i ≠ 0) with hsupp
+    have hi₁supp : i₁ ∈ supp := Finset.mem_filter.mpr ⟨Finset.mem_univ _, hφi₁⟩
+    have hsupp_ne : supp.Nonempty := ⟨i₁, hi₁supp⟩
+    have hφne : ∀ i ∈ supp, ((φ i : E) : F) ≠ 0 := fun i hi =>
+      (map_ne_zero_iff _ (algebraMap E F).injective).mpr (Finset.mem_filter.mp hi).2
+    have hsumF : ∑ i, ((φ i : E) : F) * T i = 0 := by
+      rw [show (∑ i, ((φ i : E) : F) * T i) = ∑ i, (φ i) • T i from
+        Finset.sum_congr rfl fun i _ => (Algebra.smul_def (φ i) (T i)).symm]
+      exact hsum
+    have hq : ∀ i ∈ supp, ∃ q : ℤ, ∀ v ∈ S, v.ord ((φ i : E) : F) = q * D v :=
+      fun i hi => hord_E (φ i) (hφne i hi)
+    choose q hq using hq
+    obtain ⟨i₂, hi₂, hq₂min⟩ := Finset.exists_min_image supp
+      (fun i => if hi : i ∈ supp then q i hi else 0) hsupp_ne
+    set q₂ := q i₂ hi₂ with hq₂def
+    have hq₂le : ∀ (i) (hi : i ∈ supp), q₂ ≤ q i hi := by
+      intro i hi; have := hq₂min i hi; rwa [dite_eq_left hi₂, dite_eq_left hi] at this
+    set v₀ := i₂.1.1 with hv₀def
+    have hv₀ : v₀ ∈ S := i₂.1.2
+    have hψord : ∀ (i) (hi : i ∈ supp), ∀ v ∈ S,
+        v.ord (x ^ q₂ * ((φ i : E) : F)) = (q i hi - q₂) * D v := by
+      intro i hi v hv
+      rw [v.ord_mul (zpow_ne_zero _ hx0) (hφne i hi), v.ord_zpow, hq i hi v hv, hDv v hv]
+      ring
+    have hψord_nn : ∀ (i) (hi : i ∈ supp), ∀ v ∈ S,
+        0 ≤ v.ord (x ^ q₂ * ((φ i : E) : F)) := by
+      intro i hi v hv
+      rw [hψord i hi v hv]
+      exact mul_nonneg (by linarith [hq₂le i hi]) (by linarith [hDvpos v hv])
+    have hψT_sum : ∑ i, x ^ q₂ * ((φ i : E) : F) * T i = 0 := by
+      simp_rw [mul_assoc, ← Finset.mul_sum, hsumF, mul_zero]
+    have hψT_ord_ge0_other : ∀ (i) (hi : i ∈ supp), i.1.1 ≠ v₀ →
+        0 ≤ v₀.ord (x ^ q₂ * ((φ i : E) : F) * T i) := by
+      intro i hi hne
+      rw [v₀.ord_mul (mul_ne_zero (zpow_ne_zero _ hx0) (hφne i hi)) (hT_ne0 i)]
+      exact add_nonneg (hψord_nn i hi v₀ hv₀) (hT_ord_other i v₀ hv₀ (Ne.symm hne))
+    obtain ⟨i₃, hi₃, hmmin⟩ := Finset.exists_min_image supp
+      (fun i => if hi : i ∈ supp then v₀.ord (x ^ q₂ * ((φ i : E) : F) * T i) else 0) hsupp_ne
+    set m := v₀.ord (x ^ q₂ * ((φ i₃ : E) : F) * T i₃) with hmdef
+    have hmle : ∀ (i) (hi : i ∈ supp), m ≤ v₀.ord (x ^ q₂ * ((φ i : E) : F) * T i) := by
+      intro i hi; have := hmmin i hi; rwa [dite_eq_left hi₃, dite_eq_left hi] at this
+    have hm_neg : m < 0 := by
+      have h2 := hmle i₂ hi₂
+      rw [v₀.ord_mul (mul_ne_zero (zpow_ne_zero _ hx0) (hφne i₂ hi₂)) (hT_ne0 i₂),
+          hψord i₂ hi₂ v₀ hv₀, show q i₂ hi₂ - q₂ = 0 from by rw [hq₂def]; ring,
+          zero_mul, zero_add, show v₀.ord (T i₂) = -((i₂.2.1:ℤ)+1) from hT_ord_own i₂] at h2
+      linarith [Int.natCast_nonneg i₂.2.1.1]
+    have hi₃v₀ : i₃.1.1 = v₀ := by
+      by_contra hne
+      exact absurd (hψT_ord_ge0_other i₃ hi₃ hne) (by linarith)
+    clear_value v₀
+    subst hi₃v₀
+    set vv := i₃.1.1 with hvvdef
+    set a₃ : ℤ := (i₃.2.1 : ℤ) with ha₃def
+    have ha₃lt : a₃ < D vv := by
+      have h1 : (i₃.2.1 : ℕ) < (D vv).toNat := i₃.2.1.2
+      have h2 := hDvpos vv hv₀; omega
+    set Q := q i₃ hi₃ - q₂ with hQdef
+    have hQnn : 0 ≤ Q := by have := hq₂le i₃ hi₃; omega
+    have hmeq : m = Q * D vv - (a₃ + 1) := by
+      rw [hmdef, vv.ord_mul (mul_ne_zero (zpow_ne_zero _ hx0) (hφne i₃ hi₃)) (hT_ne0 i₃),
+          hψord i₃ hi₃ vv hv₀, ← hQdef, hT_ord_own i₃]; ring
+    have hmin_char : ∀ (i) (hi : i ∈ supp), i.1.1 = vv →
+        vv.ord (x ^ q₂ * ((φ i : E) : F) * T i) = m →
+        (i.2.1:ℤ) = a₃ ∧ q i hi - q₂ = Q := by
+      intro i hi hiv heq
+      have hai_lt : (i.2.1:ℤ) < D vv := by
+        have h1 : (i.2.1 : ℕ) < (D i.1.1).toNat := i.2.1.2
+        have h3 : D i.1.1 = D vv := by rw [hiv]
+        have h2 := hDvpos vv hv₀; omega
+      have heq2 : (q i hi - q₂) * D vv - ((i.2.1:ℤ)+1) = m := by
+        rw [← heq, vv.ord_mul (mul_ne_zero (zpow_ne_zero _ hx0) (hφne i hi)) (hT_ne0 i),
+            hψord i hi vv hv₀, show vv.ord (T i) = -((i.2.1:ℤ)+1) from hiv ▸ hT_ord_own i]
+        ring
+      rw [hmeq] at heq2
+      have hD1 := hDvpos vv hv₀
+      have hdiff : ((q i hi - q₂) - Q) * D vv = (i.2.1:ℤ) - a₃ := by linarith
+      have hbnd1 : -(D vv) < (i.2.1:ℤ) - a₃ := by
+        linarith [Int.natCast_nonneg i.2.1.1, ha₃lt]
+      have hbnd2 : (i.2.1:ℤ) - a₃ < D vv := by
+        linarith [hai_lt, Int.natCast_nonneg i₃.2.1.1]
+      have hzero : (q i hi - q₂) - Q = 0 := by
+        by_contra hne
+        rcases lt_or_gt_of_ne hne with hlt | hgt
+        · nlinarith
+        · nlinarith
+      have hieq : (i.2.1:ℤ) = a₃ := by
+        have h00 := hdiff; rw [hzero, zero_mul] at h00; linarith
+      exact ⟨hieq, by linarith [hzero]⟩
+    set μ := x ^ Q * (t vv) ^ (a₃ + 1) with hμdef
+    have hμne : μ ≠ 0 := mul_ne_zero (zpow_ne_zero _ hx0) (zpow_ne_zero _ (ht0 vv hv₀))
+    have hμord : vv.ord μ = -m := by
+      rw [hμdef, vv.ord_mul (zpow_ne_zero _ hx0) (zpow_ne_zero _ (ht0 vv hv₀)),
+          vv.ord_zpow, vv.ord_zpow, htv vv hv₀, mul_one, hmeq, hDv vv hv₀]
+      ring
+    have hμψT_mem : ∀ i, μ * (x ^ q₂ * ((φ i : E) : F) * T i) ∈ vv.toValuationSubring := by
+      intro i
+      by_cases hi : i ∈ supp
+      · refine vv.mem_of_ord_nonneg (mul_ne_zero hμne
+          (mul_ne_zero (mul_ne_zero (zpow_ne_zero _ hx0) (hφne i hi)) (hT_ne0 i))) ?_
+        rw [vv.ord_mul hμne (mul_ne_zero (mul_ne_zero (zpow_ne_zero _ hx0) (hφne i hi))
+              (hT_ne0 i)), hμord]
+        linarith [hmle i hi]
+      · have : φ i = 0 := by
+          by_contra h; exact hi (Finset.mem_filter.mpr ⟨Finset.mem_univ _, h⟩)
+        simp [this]
+    have hsum_O : (∑ i, (⟨_, hμψT_mem i⟩ : vv.toValuationSubring)) = 0 := by
+      refine Subtype.ext ?_
+      simp only [AddSubmonoidClass.coe_finsetSum, ZeroMemClass.coe_zero]
+      simp only [mul_assoc]
+      rw [← Finset.mul_sum, ← Finset.mul_sum, hsumF, mul_zero, mul_zero]
+    have hres_sum : ∑ i, IsLocalRing.residue _ (⟨_, hμψT_mem i⟩ : vv.toValuationSubring) = 0 := by
+      rw [← map_sum, hsum_O, map_zero]
+    have hres_zero : ∀ i, ¬(i ∈ supp ∧ vv.ord (x ^ q₂ * ((φ i : E) : F) * T i) = m) →
+        IsLocalRing.residue _ (⟨_, hμψT_mem i⟩ : vv.toValuationSubring) = 0 := by
+      intro i hnot
+      by_cases hi : i ∈ supp
+      · refine (Ideal.Quotient.eq_zero_iff_mem).mpr (hmem_max vv _ _ ?_)
+        rw [vv.ord_mul hμne
+            (mul_ne_zero (mul_ne_zero (zpow_ne_zero _ hx0) (hφne i hi)) (hT_ne0 i)), hμord]
+        have hgt : m < vv.ord (x ^ q₂ * ((φ i : E) : F) * T i) :=
+          lt_of_le_of_ne (hmle i hi) (fun heq => hnot ⟨hi, heq.symm⟩)
+        linarith
+      · have hφ0 : φ i = 0 := by
+          by_contra h; exact hi (Finset.mem_filter.mpr ⟨Finset.mem_univ _, h⟩)
+        rw [show (⟨_, hμψT_mem i⟩ : vv.toValuationSubring) = 0 from
+          Subtype.ext (by simp [hφ0]), map_zero]
+    let j : Fin vv.deg → ι := fun k => ⟨i₃.1, i₃.2.1, k⟩
+    have hreindex : ∑ i, IsLocalRing.residue _ (⟨_, hμψT_mem i⟩ : vv.toValuationSubring)
+        = ∑ k, IsLocalRing.residue _ (⟨_, hμψT_mem (j k)⟩ : vv.toValuationSubring) := by
+      rw [Fintype.sum_sigma]
+      have hside1 : ∀ w : ↥S, w ≠ i₃.1 →
+          ∑ p, IsLocalRing.residue _ (⟨_, hμψT_mem ⟨w,p⟩⟩ : vv.toValuationSubring) = 0 := by
+        intro w hw
+        refine Finset.sum_eq_zero fun p _ => hres_zero ⟨w, p⟩ ?_
+        rintro ⟨hisupp, heq⟩
+        have : (⟨w,p⟩ : ι).1.1 = vv := by
+          by_contra hne
+          exact absurd (hψT_ord_ge0_other ⟨w,p⟩ hisupp hne) (heq ▸ hm_neg).not_ge
+        exact hw (Subtype.ext this)
+      rw [Fintype.sum_eq_single i₃.1 hside1, Fintype.sum_prod_type]
+      have hside2 : ∀ a : Fin (D i₃.1.1).toNat, a ≠ i₃.2.1 →
+          ∑ k, IsLocalRing.residue _ (⟨_, hμψT_mem ⟨i₃.1, a, k⟩⟩ : vv.toValuationSubring) = 0 := by
+        intro a ha
+        refine Finset.sum_eq_zero fun k _ => hres_zero ⟨i₃.1, a, k⟩ ?_
+        rintro ⟨hisupp, heq⟩
+        obtain ⟨hai, _⟩ := hmin_char ⟨i₃.1, a, k⟩ hisupp rfl heq
+        refine ha (Fin.ext ?_)
+        have hai' : (a : ℤ) = (i₃.2.1 : ℤ) := by simpa [ha₃def] using hai
+        exact_mod_cast hai'
+      rw [Fintype.sum_eq_single i₃.2.1 hside2]
+    rw [hreindex] at hres_sum
+    have hjkvv : ∀ k, (j k).1.1 = vv := fun k => rfl
+    have hjk_T : ∀ k, T (j k) = z vv i₃.1.2 k * (t vv) ^ (-(a₃+1)) := fun k => rfl
+    have hjk_simp : ∀ k (hjk : j k ∈ supp)
+        (heq : vv.ord (x ^ q₂ * ((φ (j k) : E) : F) * T (j k)) = m),
+        μ * (x ^ q₂ * ((φ (j k) : E) : F) * T (j k))
+          = (x ^ (q (j k) hjk) * ((φ (j k) : E) : F)) * z vv i₃.1.2 k := by
+      intro k hjk heq
+      obtain ⟨_, hqeq⟩ := hmin_char (j k) hjk rfl heq
+      have hqjk : q (j k) hjk = q₂ + Q := by linarith
+      simp only [hμdef, hjk_T, hqjk]
+      have hxcan : x ^ Q * x ^ q₂ = x ^ (q₂ + Q) := by rw [← zpow_add₀ hx0]; ring_nf
+      have htcan : (t vv) ^ (a₃+1) * (t vv) ^ (-(a₃+1)) = 1 := by
+        rw [← zpow_add₀ (ht0 vv hv₀), add_neg_cancel, zpow_zero]
+      calc x ^ Q * (t vv) ^ (a₃+1) * (x ^ q₂ * ((φ (j k):E):F) * (z vv i₃.1.2 k * (t vv) ^
+        (-(a₃+1))))
+          = (x ^ Q * x ^ q₂) * ((φ (j k):E):F) * z vv i₃.1.2 k *
+            ((t vv) ^ (a₃+1) * (t vv) ^ (-(a₃+1))) := by ring
+        _ = x ^ (q₂+Q) * ((φ (j k):E):F) * z vv i₃.1.2 k := by rw [hxcan, htcan, mul_one]
+    have hxEpow : ∀ (r : ℤ), ((xE ^ r : E) : F) = x ^ r := fun r => by
+      rw [show ((xE ^ r : E) : F) = E.val (xE ^ r) from rfl, map_zpow₀]; rfl
+    have hEgk : ∀ k (hjk : j k ∈ supp),
+        ((xE ^ (q (j k) hjk) * φ (j k) : E) : F) = x ^ (q (j k) hjk) * ((φ (j k) : E) : F) := by
+      intro k hjk; push_cast; rw [hxEpow]
+    have hEgk_ne0 : ∀ k (hjk : j k ∈ supp), ((xE ^ (q (j k) hjk) * φ (j k) : E) : F) ≠ 0 := by
+      intro k hjk; rw [hEgk]; exact mul_ne_zero (zpow_ne_zero _ hx0) (hφne (j k) hjk)
+    have hEgk_ord0 : ∀ k (hjk : j k ∈ supp),
+        vv.ord ((xE ^ (q (j k) hjk) * φ (j k) : E) : F) = 0 := by
+      intro k hjk
+      rw [hEgk, vv.ord_mul (zpow_ne_zero _ hx0) (hφne (j k) hjk), vv.ord_zpow,
+          hq (j k) hjk vv hv₀, hDv vv hv₀]; ring
+    let γ : Fin vv.deg → K := fun k =>
+      if hjk : j k ∈ supp ∧ vv.ord (x ^ q₂ * ((φ (j k) : E) : F) * T (j k)) = m
+      then Classical.choose (hres_E vv hv₀ _ (hEgk_ne0 k hjk.1) (hEgk_ord0 k hjk.1))
+      else 0
+    have hγ_res : ∀ k, IsLocalRing.residue _ (⟨_, hμψT_mem (j k)⟩ : vv.toValuationSubring)
+        = γ k • IsLocalRing.residue _
+          (⟨z vv i₃.1.2 k, hz_reg vv i₃.1.2 k vv hv₀⟩ : vv.toValuationSubring) := by
+      intro k
+      by_cases hjk : j k ∈ supp ∧ vv.ord (x ^ q₂ * ((φ (j k) : E) : F) * T (j k)) = m
+      · have hgmem : ((xE ^ (q (j k) hjk.1) * φ (j k) : E) : F) ∈ vv.toValuationSubring :=
+          vv.mem_of_ord_nonneg (hEgk_ne0 k hjk.1) (hEgk_ord0 k hjk.1).ge
+        have hsplit : (⟨_, hμψT_mem (j k)⟩ : vv.toValuationSubring)
+            = ⟨_, hgmem⟩ * ⟨z vv i₃.1.2 k, hz_reg vv i₃.1.2 k vv hv₀⟩ := by
+          refine Subtype.ext ?_
+          change μ * (x ^ q₂ * ((φ (j k):E):F) * T (j k))
+            = ((xE ^ (q (j k) hjk.1) * φ (j k) : E) : F) * z vv i₃.1.2 k
+          rw [hjk_simp k hjk.1 hjk.2, hEgk k hjk.1]
+        rw [hsplit, map_mul]
+        simp only [γ, dite_eq_left hjk, Algebra.smul_def]
+        congr 1
+        exact (Classical.choose_spec
+          (hres_E vv hv₀ _ (hEgk_ne0 k hjk.1) (hEgk_ord0 k hjk.1))).2 hgmem
+      · rw [hres_zero (j k) hjk]; simp only [γ, dite_eq_right hjk, zero_smul]
+    rw [show (∑ k, IsLocalRing.residue _ (⟨_, hμψT_mem (j k)⟩ : vv.toValuationSubring))
+        = ∑ k, γ k • IsLocalRing.residue _
+            (⟨z vv i₃.1.2 k, hz_reg vv i₃.1.2 k vv hv₀⟩ : vv.toValuationSubring) from
+      Finset.sum_congr rfl fun k _ => hγ_res k] at hres_sum
+    have hγk0 := Fintype.linearIndependent_iff.mp (hz_li vv i₃.1.2) γ hres_sum i₃.2.2
+    have hji₃ : j i₃.2.2 = i₃ := rfl
+    have hi₃cond : j i₃.2.2 ∈ supp ∧
+        vv.ord (x ^ q₂ * ((φ (j i₃.2.2) : E) : F) * T (j i₃.2.2)) = m := by
+      rw [hji₃]; exact ⟨hi₃, hmdef.symm⟩
+    simp only [γ, dite_eq_left hi₃cond] at hγk0
+    exact (Classical.choose_spec
+      (hres_E vv hv₀ _ (hEgk_ne0 i₃.2.2 hi₃cond.1) (hEgk_ord0 i₃.2.2 hi₃cond.1))).1 hγk0
+  have hcard : (Fintype.card ι : ℤ) = Divisor.degree D := by
+    simp only [ι, Fintype.card_sigma, Fintype.card_prod, Fintype.card_fin]
+    rw [hdegD, ← Finset.sum_attach S (fun v => D v * (v.deg : ℤ))]
+    push_cast
+    refine Finset.sum_congr rfl fun v _ => ?_
+    rw [Int.toNat_of_nonneg (by linarith [hDvpos v.1 v.2])]
+  calc Divisor.degree D = (Fintype.card ι : ℤ) := hcard.symm
+    _ ≤ (n : ℤ) := by exact_mod_cast hTli.fintype_card_le_finrank
+
+end S_AlgebraicCurve_Divisor_degree_le_finrank_adjoin_of_eq_max_neg_ord
+end P2MW
+export P2MW.S_AlgebraicCurve_Divisor_degree_le_finrank_adjoin_of_eq_max_neg_ord (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Divisor.degree_le_finrank_adjoin_of_eq_max_neg_ord
+    {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (x : F) (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    (D : Divisor K F) (hD : ∀ v : Place K F, D v = max 0 (-v.ord x)) :
+    Divisor.degree D ≤ (Module.finrank (IntermediateField.adjoin K ({x} : Set F)) F : ℤ) :=
+  solution x hx D hD
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_evalFun_add.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_evalFun_add.lean
new file mode 100644
index 0000000000..d25b2c6cb9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_evalFun_add.lean
@@ -0,0 +1,91 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Divisor.evalFun_add
+(350164eb-20df-5284-b994-4d75854593e4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 17b60246-d0cd-5bff-80d9-393bc6abf435
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Multiplicativity of f ↦ f(D) in the divisor
+
+Theorem statement: `AlgebraicCurve.Divisor.evalFun_add` (`350164eb-20df-5284-b994-4d75854593e4`), by
+Claude, 2026-09-05.
+
+Proof: submission `17b60246-d0cd-5bff-80d9-393bc6abf435`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $f \in F$. A place of $F/K$ in the
+project's sense is a valuation subring $\mathcal{O}_v \subseteq F$ containing the image of $K$ under
+the structure map, different from $F$ itself, and whose underlying ring is a principal ideal ring; a
+divisor is an element of $\mathrm{Place}\,K\,F \to_{f_0} \mathbb{Z}$, i.e. a finitely supported
+family of integers indexed by such places. For a place $v$, $\mathrm{Place.evalAt}\,v\,f$ is defined
+to be $0$ when $f \notin \mathcal{O}_v$, and otherwise the image of the residue class of $f$ in the
+residue field of $\mathcal{O}_v$ under a chosen left inverse (`Function.invFun`) of the map $K \to
+\mathcal{O}_v/\mathfrak{m}_v$; and for a divisor $D$, $\mathrm{Divisor.evalFun}\,f\,D$ is the finite
+product $\prod_{v \in \mathrm{supp}\,D} (\mathrm{Place.evalAt}\,v\,f)^{D(v)}$, the exponents being
+integer powers in the field $K$. Given two divisors $D, E$ such that $\mathrm{Place.evalAt}\,v\,f
+\neq 0$ for every $v$ in the support of $D$ and for every $v$ in the support of $E$, the theorem
+states $\mathrm{Divisor.evalFun}\,f\,(D+E) = \mathrm{Divisor.evalFun}\,f\,D \cdot
+\mathrm{Divisor.evalFun}\,f\,E$.
+
+This is the additivity in the divisor variable of the local symbol $D \mapsto f(D)$, written
+multiplicatively; the non-vanishing hypotheses are exactly what is needed to allow negative
+exponents, since $\mathrm{Place.evalAt}$ takes the value $0$ both at poles of $f$ and at zeros. It
+is one of the basic manipulations in the layer of evaluation of functions at divisors that underlies
+Weil reciprocity and the bimultiplicativity of the Weil pairing, and is used for instance in the
+computation of $\mathrm{evalFun}$ on differences of single-place divisors and in the treatment of
+the rational function field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Divisor_evalFun_add.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Divisor_evalFun_add
+
+open AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (f : F) {D E : Divisor K F}
+    (hD : ∀ v ∈ D.support, Place.evalAt v f ≠ 0) (hE : ∀ v ∈ E.support, Place.evalAt v f ≠ 0) :
+    Divisor.evalFun f (D + E) = Divisor.evalFun f D * Divisor.evalFun f E := by
+  classical
+  refine Finsupp.prod_add_index (fun v _ => zpow_zero _) (fun v hv b₁ b₂ => ?_)
+  refine zpow_add₀ ?_ b₁ b₂
+  rcases Finset.mem_union.mp hv with h | h
+  · exact hD v h
+  · exact hE v h
+
+end S_AlgebraicCurve_Divisor_evalFun_add
+end P2MW
+export P2MW.S_AlgebraicCurve_Divisor_evalFun_add (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Divisor.evalFun_add {K F : Type*} [Field K] [Field F] [Algebra K F] (f : F)
+    {D E : Divisor K F} (hD : ∀ v ∈ D.support, Place.evalAt v f ≠ 0)
+    (hE : ∀ v ∈ E.support, Place.evalAt v f ≠ 0) :
+    Divisor.evalFun f (D + E) = Divisor.evalFun f D * Divisor.evalFun f E :=
+  solution f hD hE
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_evalFun_mul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_evalFun_mul.lean
new file mode 100644
index 0000000000..e31a3a85db
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_evalFun_mul.lean
@@ -0,0 +1,89 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Divisor.evalFun_mul
+(0855e902-069f-50bf-ba69-8866a1d7de0f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e0624130-76dc-55c8-b2ea-9d2cde60744a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_mul
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Multiplicativity of f ↦ f(D) at rational places
+
+Theorem statement: `AlgebraicCurve.Divisor.evalFun_mul` (`0855e902-069f-50bf-ba69-8866a1d7de0f`), by
+Claude, 2026-09-05.
+
+Proof: submission `e0624130-76dc-55c8-b2ea-9d2cde60744a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, let $f, g \in F$, and let $D$ be a divisor of
+$F/K$, that is, a finitely supported function from the type [`AlgebraicCurve.Place K
+F`](def/AlgebraicCurve_DivisorClassGroup.html#L22) of places of $F/K$ to $\mathbb{Z}$; here a place
+is a valuation subring of $F$ which contains the image of $K$, is not all of $F$, and is a principal
+ideal ring. Assume three conditions on the places $v$ in the support of $D$: each such $v$ satisfies
+`Place.IsRational`, i.e. the composite $K \to v \to \kappa(v)$ into the residue field of $v$ is
+surjective; and both $f$ and $g$ lie in the valuation subring attached to $v$. Then the conclusion
+is the identity $(fg)(D) = f(D)\,g(D)$ for the evaluation $h(D) := \prod_{v \in \operatorname{supp}
+D} \mathrm{ev}_v(h)^{D(v)} \in K$, the product over the support of $D$ of integral powers of the
+local values $\mathrm{ev}_v(h)$, where $\mathrm{ev}_v(h) \in K$ is, for $h$ in the valuation subring
+of $v$, the preimage in $K$ (via the chosen inverse `residueInv` of the surjection onto $\kappa(v)$)
+of the residue class of $h$, and is $0$ otherwise.
+
+This is multiplicativity in the function of the local symbol $f(D)$ attached to a divisor supported
+on rational places. It belongs to the layer of evaluation of functions at divisors underlying Weil
+reciprocity and the bilinearity of the Weil pairing, and is used in the computations for the
+rational function field, for instance in identifying values at the place at infinity and at places
+coming from points.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Divisor_evalFun_mul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Divisor_evalFun_mul
+
+open AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] {f g : F} {D : Divisor K F}
+    (hrat : ∀ v ∈ D.support, Place.IsRational v) (hf : ∀ v ∈ D.support, f ∈ v.toValuationSubring)
+    (hg : ∀ v ∈ D.support, g ∈ v.toValuationSubring) :
+    Divisor.evalFun (f * g) D = Divisor.evalFun f D * Divisor.evalFun g D := by
+  rw [show Divisor.evalFun (f * g) D = D.prod fun v n => v.evalAt f ^ n * v.evalAt g ^ n from
+    Finsupp.prod_congr fun v hv => by
+      rw [AlgebraicCurve.Place.evalAt_mul v (hrat v hv) (hf v hv) (hg v hv), mul_zpow]]
+  exact Finsupp.prod_mul
+
+end S_AlgebraicCurve_Divisor_evalFun_mul
+end P2MW
+export P2MW.S_AlgebraicCurve_Divisor_evalFun_mul (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Divisor.evalFun_mul {K F : Type*} [Field K] [Field F] [Algebra K F] {f g : F}
+    {D : Divisor K F} (hrat : ∀ v ∈ D.support, Place.IsRational v)
+    (hf : ∀ v ∈ D.support, f ∈ v.toValuationSubring)
+    (hg : ∀ v ∈ D.support, g ∈ v.toValuationSubring) :
+    Divisor.evalFun (f * g) D = Divisor.evalFun f D * Divisor.evalFun g D :=
+  solution hrat hf hg
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_evalFun_ne_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_evalFun_ne_zero.lean
new file mode 100644
index 0000000000..621c0829b4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_evalFun_ne_zero.lean
@@ -0,0 +1,83 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Divisor.evalFun_ne_zero
+(29cc4c02-b576-5ba0-87c4-3dccf09e4ec9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 014767c6-0e15-5ccc-b2df-7916e0dca41e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Non-vanishing of f(D) when f avoids the support of D
+
+Theorem statement: `AlgebraicCurve.Divisor.evalFun_ne_zero`
+(`29cc4c02-b576-5ba0-87c4-3dccf09e4ec9`), by Claude, 2026-09-05.
+
+Proof: submission `014767c6-0e15-5ccc-b2df-7916e0dca41e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, let $f \in F$, and let $D$ be a divisor of $F/K$,
+i.e. a finitely supported function from the type `Place K F` of places to $\mathbb{Z}$; here a place
+$v$ is a valuation subring of $F$ which contains $\operatorname{algebraMap} K F(a)$ for every $a \in
+K$, is not all of $F$, and is a principal ideal ring. For a place $v$, the evaluation
+$\operatorname{evalAt} v f \in K$ is defined to be the image of the residue class of $f$ in the
+residue field of $v$ under a fixed set-theoretic inverse (`Function.invFun`) of the structure map $K
+\to v$'s residue field, when $f$ lies in the valuation subring of $v$, and $0$ otherwise. The
+hypothesis is that $\operatorname{evalAt} v f \neq 0$ for every $v$ in the (finite) support of $D$.
+The conclusion is that $\operatorname{evalFun} f D \neq 0$, where $\operatorname{evalFun} f D =
+\prod_{v \in \operatorname{supp} D} (\operatorname{evalAt} v f)^{D(v)}$, the exponents being
+integers.
+
+This is the basic non-degeneracy statement for the evaluation $f(D)$ of a function at a divisor (the
+local symbol underlying Weil reciprocity), in the form needed to know that $f(D)$ lies in $K^\times$
+once $f$ is regular and non-vanishing at each place in the support of $D$. It is used in the
+function-field layer on which the rational function field computations rest, for instance in
+identifying evaluations at the place at infinity and at places coming from points, and in the degree
+computation over an algebraically closed field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Divisor_evalFun_ne_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Divisor_evalFun_ne_zero
+
+open AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] {f : F} {D : Divisor K F}
+    (h : ∀ v ∈ D.support, Place.evalAt v f ≠ 0) :
+    Divisor.evalFun f D ≠ 0 := by
+  rw [Divisor.evalFun_def]
+  exact Finset.prod_ne_zero_iff.mpr fun v hv => zpow_ne_zero _ (h v hv)
+
+end S_AlgebraicCurve_Divisor_evalFun_ne_zero
+end P2MW
+export P2MW.S_AlgebraicCurve_Divisor_evalFun_ne_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Divisor.evalFun_ne_zero {K F : Type*} [Field K] [Field F] [Algebra K F]
+    {f : F} {D : Divisor K F} (h : ∀ v ∈ D.support, Place.evalAt v f ≠ 0) :
+    Divisor.evalFun f D ≠ 0 :=
+  solution h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_evalFun_single_sub_single.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_evalFun_single_sub_single.lean
new file mode 100644
index 0000000000..a4c2979970
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_evalFun_single_sub_single.lean
@@ -0,0 +1,93 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Divisor.evalFun_single_sub_single
+(6377aa38-be7b-5094-af93-09470b9e8ee7) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ed888c75-a761-5ed9-a1e8-63d520b1acb7
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_add
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Evaluation of f at a two-point divisor (v₁)-(v₂)
+
+Theorem statement: `AlgebraicCurve.Divisor.evalFun_single_sub_single`
+(`6377aa38-be7b-5094-af93-09470b9e8ee7`), by Claude, 2026-09-05.
+
+Proof: submission `ed888c75-a761-5ed9-a1e8-63d520b1acb7`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $f \in F$. A place of $F$ over $K$, in the
+sense used here, is a valuation subring of $F$ containing the image of $K$ under the structure map,
+distinct from $F$ itself, and a principal ideal ring; for such a place $v$ the value
+$v.\mathrm{evalAt}\,f \in K$ is defined to be the preimage under the structure map $K \to \kappa(v)$
+(taken via a chosen left inverse) of the residue class of $f$ when $f$ lies in the valuation
+subring, and $0$ otherwise. A divisor is a finitely supported function from places to $\mathbb{Z}$,
+and the value $\mathrm{evalFun}\,f\,D$ is the finite product $\prod_{v}
+(v.\mathrm{evalAt}\,f)^{D(v)}$ over the support of $D$, with integer exponents. The assertion is:
+given places $v_1, v_2$ with $v_1.\mathrm{evalAt}\,f \neq 0$ and $v_2.\mathrm{evalAt}\,f \neq 0$,
+the value of $f$ at the divisor written as the sum of the single-point divisors $v_1 \mapsto 1$ and
+$v_2 \mapsto -1$ equals $(v_1.\mathrm{evalAt}\,f)/(v_2.\mathrm{evalAt}\,f)$. No assumption $v_1 \neq
+v_2$ is made.
+
+This is the evaluation of a function at a degree-zero two-point divisor, the basic case underlying
+local symbols and Weil reciprocity in the function-field layer of the development. It is used in the
+study of the rational function field, for instance in computing values at the place at infinity and
+at places attached to points, and in the proof that places have degree one over an algebraically
+closed field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Divisor_evalFun_single_sub_single.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Divisor_evalFun_single_sub_single
+
+open AlgebraicCurve AlgebraicCurve.Divisor
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (f : F) {v₁ v₂ : Place K F}
+    (h₁ : v₁.evalAt f ≠ 0) (h₂ : v₂.evalAt f ≠ 0) :
+    Divisor.evalFun f (Finsupp.single v₁ 1 + Finsupp.single v₂ (-1)) = v₁.evalAt f / v₂.evalAt f :=
+      by
+  have hsupp : ∀ (w : Place K F) (n : ℤ), w.evalAt f ≠ 0 →
+      ∀ v ∈ (Finsupp.single w n).support, Place.evalAt v f ≠ 0 := by
+    intro w n hw v hv
+    have := Finsupp.support_single_subset hv
+    rw [Finset.mem_singleton] at this
+    rw [this]
+    exact hw
+  rw [AlgebraicCurve.Divisor.evalFun_add f (hsupp v₁ 1 h₁) (hsupp v₂ (-1) h₂), evalFun_single,
+    evalFun_single,
+    zpow_one, zpow_neg_one, div_eq_mul_inv]
+
+end S_AlgebraicCurve_Divisor_evalFun_single_sub_single
+end P2MW
+export P2MW.S_AlgebraicCurve_Divisor_evalFun_single_sub_single (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Divisor.evalFun_single_sub_single {K F : Type*} [Field K] [Field F]
+    [Algebra K F] (f : F) {v₁ v₂ : Place K F} (h₁ : v₁.evalAt f ≠ 0) (h₂ : v₂.evalAt f ≠ 0) :
+    Divisor.evalFun f (Finsupp.single v₁ 1 + Finsupp.single v₂ (-1)) = v₁.evalAt f / v₂.evalAt f :=
+  solution f h₁ h₂
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_evalFun_zpow_left.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_evalFun_zpow_left.lean
new file mode 100644
index 0000000000..401e1cb87c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_evalFun_zpow_left.lean
@@ -0,0 +1,87 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Divisor.evalFun_zpow_left
+(c6a320b6-3073-55e3-85bd-f7ddd21c9292) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4f304260-cac9-5e72-8611-2903146d7f4b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_zpow
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Evaluation at a divisor is multiplicative in f ↦ fⁿ
+
+Theorem statement: `AlgebraicCurve.Divisor.evalFun_zpow_left`
+(`c6a320b6-3073-55e3-85bd-f7ddd21c9292`), by Claude, 2026-09-05.
+
+Proof: submission `4f304260-cac9-5e72-8611-2903146d7f4b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, let $f \in F$ be nonzero, let $D$ be a divisor of
+$F/K$, that is, a finitely supported function from the places of $F/K$ (valuation subrings of $F$
+containing the image of $K$, proper in $F$ and principal ideal rings) to $\mathbb{Z}$, and let $n
+\in \mathbb{Z}$. Assume that every place $v$ in the support of $D$ is rational, meaning that the
+induced map $K \to \kappa(v)$ to the residue field of the valuation subring of $v$ is surjective,
+and that $\mathrm{ord}_v f = 0$ for every $v$ in the support of $D$, where $\mathrm{ord}_v$ is the
+negative of the logarithm of the $v$-adic valuation. Then the evaluation of the $n$-th power $f^n$
+(an integer power in the field $F$) at $D$ equals the $n$-th power of the evaluation of $f$ at $D$:
+with $\mathrm{ev}(g, D) = \prod_{v \in \mathrm{supp}\,D} \mathrm{ev}_v(g)^{D(v)} \in K$, where
+$\mathrm{ev}_v(g)$ is the preimage in $K$ of the residue class of $g$ when $g$ lies in the valuation
+subring of $v$ and $0$ otherwise, one has $\mathrm{ev}(f^n, D) = \mathrm{ev}(f, D)^n$.
+
+This is the elementary multiplicativity of the pairing $(f, D) \mapsto f(D)$ in the first argument
+restricted to integer powers, at the level of the function-field foundations underlying Weil
+reciprocity and the Weil pairing. It is used in the computations of evaluations at places of the
+rational function field, for instance for the place at infinity and for places attached to rational
+points, and in the degree-one statement over an algebraically closed field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Divisor_evalFun_zpow_left.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Divisor_evalFun_zpow_left
+
+open AlgebraicCurve AlgebraicCurve.Divisor
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] {f : F} (hf : f ≠ 0)
+    {D : Divisor K F} (n : ℤ) (hrat : ∀ v ∈ D.support, Place.IsRational v)
+    (hord : ∀ v ∈ D.support, Place.ord v f = 0) :
+    Divisor.evalFun (f ^ n) D = Divisor.evalFun f D ^ n := by
+  rw [evalFun_def, evalFun_def, ← Finset.prod_zpow]
+  refine Finset.prod_congr rfl fun v hv => ?_
+  rw [AlgebraicCurve.Place.evalAt_zpow v (hrat v hv) hf (hord v hv) n, ← zpow_mul, ← zpow_mul,
+    mul_comm]
+
+end S_AlgebraicCurve_Divisor_evalFun_zpow_left
+end P2MW
+export P2MW.S_AlgebraicCurve_Divisor_evalFun_zpow_left (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Divisor.evalFun_zpow_left {K F : Type*} [Field K] [Field F] [Algebra K F]
+    {f : F} (hf : f ≠ 0) {D : Divisor K F} (n : ℤ) (hrat : ∀ v ∈ D.support, Place.IsRational v)
+    (hord : ∀ v ∈ D.support, Place.ord v f = 0) :
+    Divisor.evalFun (f ^ n) D = Divisor.evalFun f D ^ n :=
+  solution hf n hrat hord
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_evalFun_zsmul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_evalFun_zsmul.lean
new file mode 100644
index 0000000000..1c39879ef5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_evalFun_zsmul.lean
@@ -0,0 +1,84 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Divisor.evalFun_zsmul
+(e00a27aa-dcd1-508b-ae6b-bc3b897fda08) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission eadcb4a1-ca56-546b-b913-e134813d2bcd
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Evaluation at an integer multiple of a divisor
+
+Theorem statement: `AlgebraicCurve.Divisor.evalFun_zsmul` (`e00a27aa-dcd1-508b-ae6b-bc3b897fda08`),
+by Claude, 2026-09-05.
+
+Proof: submission `eadcb4a1-ca56-546b-b913-e134813d2bcd`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, let $f \in F$, let $D$ be a divisor of $F/K$, that
+is a finitely supported function $D \colon \mathrm{Place}\,K\,F \to \mathbb{Z}$ on the type of
+places, a place being a valuation subring $\mathcal{O}_v \subseteq F$ that contains the image of $K$
+under the structure map, is not all of $F$, and is a principal ideal ring, and let $n \in
+\mathbb{Z}$. Here the evaluation of $f$ at a divisor is $\mathrm{evalFun}\, f\, D = \prod_{v \in
+\operatorname{supp} D} (\mathrm{evalAt}_v f)^{D(v)}$, a finite product of integer powers in $K$,
+where $\mathrm{evalAt}_v f \in K$ is obtained, when $f \in \mathcal{O}_v$, by taking the image of
+$f$ in the residue field of $\mathcal{O}_v$ and transporting it to $K$ along `residueInv`, and is
+$0$ when $f \notin \mathcal{O}_v$. The assertion is $\mathrm{evalFun}\, f\, (n \bullet D) =
+(\mathrm{evalFun}\, f\, D)^{n}$, an identity of integer powers in the field $K$; no hypothesis
+excludes the value $\mathrm{evalAt}_v f = 0$, the powers being understood with the convention
+$0^{-k} = 0$.
+
+This is the homogeneity of the evaluation map $f \mapsto f(D)$ in the divisor variable, at the level
+of the local-symbol formalism underlying Weil reciprocity on a curve. It is used in the computations
+of evaluations at places of the rational function field, for instance at the place at infinity and
+at places attached to points, and in the determination of degrees over an algebraically closed base.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Divisor_evalFun_zsmul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Divisor_evalFun_zsmul
+
+open AlgebraicCurve AlgebraicCurve.Divisor
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (f : F) (D : Divisor K F) (n : ℤ) :
+    Divisor.evalFun f (n • D) = Divisor.evalFun f D ^ n := by
+  rw [show evalFun f (n • D) = ∏ v ∈ D.support, v.evalAt f ^ ((n • D) v) from
+      Finsupp.prod_of_support_subset _ Finsupp.support_smul _ fun v _ => zpow_zero _,
+    evalFun_def, ← Finset.prod_zpow]
+  refine Finset.prod_congr rfl fun v _ => ?_
+  rw [Finsupp.smul_apply, smul_eq_mul, mul_comm n (D v), zpow_mul]
+
+end S_AlgebraicCurve_Divisor_evalFun_zsmul
+end P2MW
+export P2MW.S_AlgebraicCurve_Divisor_evalFun_zsmul (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Divisor.evalFun_zsmul {K F : Type*} [Field K] [Field F] [Algebra K F] (f : F)
+    (D : Divisor K F) (n : ℤ) :
+    Divisor.evalFun f (n • D) = Divisor.evalFun f D ^ n :=
+  solution f D n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_finrank_adjoin_le_degree_of_eq_max_neg_ord.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_finrank_adjoin_le_degree_of_eq_max_neg_ord.lean
new file mode 100644
index 0000000000..f8192e0448
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_finrank_adjoin_le_degree_of_eq_max_neg_ord.lean
@@ -0,0 +1,269 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Divisor.finrank_adjoin_le_degree_of_eq_max_neg_ord
+(7f949eeb-7178-5695-85e6-febaed1964aa) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 07541cd1-ac46-5f4e-9439-7746b5036005
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import Mathlib.Algebra.Polynomial.Basis
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_mem_toValuationSubring_of_isIntegral_adjoin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_le_degree_add_ellZero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteDimensional_lSpace
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_linearIndependent_pow_mul
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Lower bound [F:K(x)] ≤ deg of the pole divisor
+
+Theorem statement: `AlgebraicCurve.Divisor.finrank_adjoin_le_degree_of_eq_max_neg_ord`
+(`7f949eeb-7178-5695-85e6-febaed1964aa`), by Claude, 2026-09-05.
+
+Proof: submission `07541cd1-ac46-5f4e-9439-7746b5036005`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra satisfying `IsCurveOver K F`, i.e. $F/K$ has
+principal divisors (every nonzero $f \in F$ is the divisor-valued datum of its orders
+$\operatorname{ord}_v f$ at all places, with total degree $0$), every place has residue field finite
+over $K$, and $\Omega[F/K]$ is free of rank $1$ over $F$; here a place is a valuation subring of $F$
+containing the image of $K$, distinct from $F$ itself, and a principal ideal ring, and
+$\operatorname{ord}_v$ is minus the logarithm of the associated $\mathbb{Z}^{m0}$-valued adic
+valuation. Assume further that $\mathcal L(0) = \{f \in F : v(f) \le 1 \text{ for all } v\}$ is
+finite-dimensional over $K$. Let $x \in F$ be transcendental over $K$, assume $F$ is
+finite-dimensional over the intermediate field $K(x)$ generated by $x$, and let $D$ be a (finitely
+supported) divisor with $D(v) = \max(0, -\operatorname{ord}_v x)$ at every place $v$. Then $[F :
+K(x)] \le \deg D$, where $\deg D = \sum_v D(v) \cdot \deg v$, as an inequality of integers.
+
+This is one half of the classical identity $\deg(x)_\infty = [F:K(x)]$ for a one-variable function
+field, the direction obtained by counting dimensions of Riemann–Roch spaces; no separability of
+$F/K(x)$ is required. It is cited in the proof of the corresponding equality
+[`AlgebraicCurve.Divisor.degree_eq_finrank_adjoin_of_eq_max_neg_ord`]
+(thm.html#AlgebraicCurve.Divisor.degree_eq_finrank_adjoin_of_eq_max_neg_ord).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Divisor_finrank_adjoin_le_degree_of_eq_max_neg_ord.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Divisor_finrank_adjoin_le_degree_of_eq_max_neg_ord
+
+
+open AlgebraicCurve
+
+theorem solution
+    {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (x : F) (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    (D : Divisor K F) (hD : ∀ v : Place K F, D v = max 0 (-v.ord x)) :
+    (Module.finrank (IntermediateField.adjoin K ({x} : Set F)) F : ℤ) ≤ Divisor.degree D := by
+  classical
+  set E : IntermediateField K F := IntermediateField.adjoin K ({x} : Set F) with hE
+  set n : ℕ := Module.finrank E F with hn
+  have hxE_mem : x ∈ E := IntermediateField.mem_adjoin_simple_self K x
+  set xE : E := ⟨x, hxE_mem⟩ with hxE
+  have hxE_coe : (xE : F) = x := rfl
+  have hx0 : x ≠ 0 := fun h => hx (h ▸ isAlgebraic_zero)
+  have hxE0 : xE ≠ 0 := fun h => hx0 (by rw [← hxE_coe, h]; rfl)
+  have hxE_trans : Transcendental K xE := by
+    intro halg
+    exact hx halg.algebraMap
+  set A : Subalgebra K E := Algebra.adjoin K ({xE} : Set E) with hA
+  have hA_dom : IsDomain A := inferInstance
+  have hfrac : IsFractionRing A E := by
+    refine IsFractionRing.of_field A E fun z => ?_
+    obtain ⟨r, s, hzrs⟩ :=
+      (IntermediateField.mem_adjoin_simple_iff K (x := (z : F))).mp z.2
+    have hrA : Polynomial.aeval xE r ∈ A := by
+      rw [hA, Algebra.adjoin_singleton_eq_range_aeval]; exact ⟨r, rfl⟩
+    have hsA : Polynomial.aeval xE s ∈ A := by
+      rw [hA, Algebra.adjoin_singleton_eq_range_aeval]; exact ⟨s, rfl⟩
+    refine ⟨⟨_, hrA⟩, ⟨_, hsA⟩, ?_⟩
+    apply Subtype.ext
+    have hcoeR : ((Polynomial.aeval xE r : E) : F) = Polynomial.aeval x r := by
+      have : xE = IntermediateField.AdjoinSimple.gen K x := rfl
+      rw [this]; exact IntermediateField.AdjoinSimple.coe_aeval_gen_apply (F := K) (α := x) (f := r)
+    have hcoeS : ((Polynomial.aeval xE s : E) : F) = Polynomial.aeval x s := by
+      have : xE = IntermediateField.AdjoinSimple.gen K x := rfl
+      rw [this]; exact IntermediateField.AdjoinSimple.coe_aeval_gen_apply (F := K) (α := x) (f := s)
+    change (z : F) = ((algebraMap A E ⟨_, hrA⟩ / algebraMap A E ⟨_, hsA⟩ : E) : F)
+    rw [show algebraMap A E ⟨_, hrA⟩ = Polynomial.aeval xE r from rfl,
+        show algebraMap A E ⟨_, hsA⟩ = Polynomial.aeval xE s from rfl,
+        IntermediateField.coe_div, hcoeR, hcoeS, hzrs]
+  obtain ⟨s, b, hint⟩ := FiniteDimensional.exists_is_basis_integral A E F
+  have hcard : Fintype.card s = n := (Module.finrank_eq_card_basis b).symm
+  let e : Fin n ≃ s := (Fintype.equivFinOfCardEq hcard).symm
+  set u : Fin n → F := fun i => b (e i) with hu
+  have hu_indep : LinearIndependent E u := (b.linearIndependent.comp e (e.injective))
+  have hu_int : ∀ i, IsIntegral A (u i) := fun i => hint (e i)
+  have hu_intF : ∀ i, IsIntegral (Algebra.adjoin K ({x} : Set F)) (u i) := by
+    intro i
+    have hrange : ∀ a : A, algebraMap A F a ∈ Algebra.adjoin K ({x} : Set F) := by
+      intro a
+      have hmap : (Algebra.adjoin K ({xE} : Set E)).map (IsScalarTower.toAlgHom K E F)
+          = Algebra.adjoin K ({x} : Set F) := by
+        rw [AlgHom.map_adjoin, Set.image_singleton]; rfl
+      have ha : algebraMap A F a = (IsScalarTower.toAlgHom K E F) (a : E) := rfl
+      rw [ha, ← hmap]
+      exact ⟨(a : E), hA ▸ a.2, rfl⟩
+    let φ : A →+* Algebra.adjoin K ({x} : Set F) :=
+      (algebraMap A F).codRestrict _ hrange
+    have hcomp : (algebraMap (Algebra.adjoin K ({x} : Set F)) F).comp φ = algebraMap A F := by
+      ext a; rfl
+    exact (hu_int i).map_of_comp_eq φ (RingHom.id F) (by rw [RingHom.id_comp, hcomp])
+  have hu_reg : ∀ i, ∀ v : Place K F, 0 ≤ v.ord x → 0 ≤ v.ord (u i) := by
+    intro i v hvx
+    have hxmem : x ∈ v.toValuationSubring := v.mem_of_ord_nonneg hx0 hvx
+    exact v.ord_nonneg_of_mem
+      (v.mem_toValuationSubring_of_isIntegral_adjoin hxmem (hu_intF i))
+  have hDeff : (0 : Divisor K F) ≤ D := by
+    intro v; rw [hD]; exact le_max_left 0 _
+  have hDeff' : ∀ m : ℕ, (0 : Divisor K F) ≤ m • D := fun m => nsmul_nonneg hDeff m
+  have hDsupp : ∀ v ∈ D.support, (1 : ℤ) ≤ D v := by
+    intro v hv
+    have hne : D v ≠ 0 := Finsupp.mem_support_iff.mp hv
+    have hge : 0 ≤ D v := hDeff v
+    omega
+  obtain ⟨c, hc⟩ : ∃ c : ℕ, ∀ i, u i ∈ LSpace (c • D) := by
+    refine ⟨(Finset.univ : Finset (Fin n)).sup fun i =>
+      D.support.sup fun v => (-(v.ord (u i))).toNat, fun i => ?_⟩
+    set c := (Finset.univ : Finset (Fin n)).sup fun i =>
+      D.support.sup fun v => (-(v.ord (u i))).toNat
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (u i) 0 with h0 | h0
+    · exact Or.inl h0
+    refine Or.inr fun v => ?_
+    simp only [Finsupp.coe_smul, Pi.smul_apply, nsmul_eq_mul]
+    rcases le_or_gt 0 (v.ord x) with hvx | hvx
+    · have hDv0 : D v = 0 := by rw [hD]; exact max_eq_left (by omega)
+      rw [hDv0, mul_zero, neg_zero]
+      exact hu_reg i v hvx
+    · have hvsupp : v ∈ D.support := Finsupp.mem_support_iff.mpr (by rw [hD]; omega)
+      have hDv1 : (1 : ℤ) ≤ D v := hDsupp v hvsupp
+      have hcle : (-(v.ord (u i))).toNat ≤ c := by
+        refine le_trans ?_ (Finset.le_sup (f := fun i => D.support.sup fun v => (-(v.ord (u
+          i))).toNat) (Finset.mem_univ i))
+        exact Finset.le_sup (f := fun w => (-(w.ord (u i))).toNat) hvsupp
+      have hcge : -(c : ℤ) ≤ v.ord (u i) := by
+        have := Int.toNat_le.mp hcle
+        omega
+      nlinarith [Int.natCast_nonneg c, hDv1]
+  have hx_li : LinearIndependent K (fun j : ℕ => xE ^ j) := by
+    apply LinearIndependent.of_comp (R := K) E.val.toLinearMap
+    have heq : E.val.toLinearMap ∘ (fun j : ℕ => xE ^ j) = fun j => x ^ j := by
+      ext j; simp only [Function.comp_apply, AlgHom.toLinearMap_apply, map_pow,
+        IntermediateField.coe_val, hxE_coe]
+    rw [heq]
+    have hinj := transcendental_iff_injective.mp hx
+    have := (Polynomial.basisMonomials K).linearIndependent.map'
+      (Polynomial.aeval (R := K) x).toLinearMap (LinearMap.ker_eq_bot.mpr hinj)
+    simpa only [Function.comp_def, AlgHom.toLinearMap_apply, Polynomial.coe_basisMonomials,
+      Polynomial.aeval_monomial, map_one, one_mul] using this
+  have hli : LinearIndependent K (fun p : ℕ × Fin n => x ^ p.1 * u p.2) := by
+    have := linearIndependent_pow_mul (K := K) (E := E) (F := F) hx_li hu_indep
+    simpa only [show algebraMap E F xE = x from hxE_coe] using this
+  have hmem : ∀ m, c ≤ m → ∀ (j : ℕ) (i : Fin n), j ≤ m - c → x ^ j * u i ∈ LSpace (m • D) := by
+    intro m hm j i hj
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (x ^ j * u i) 0 with h0 | h0
+    · exact Or.inl h0
+    refine Or.inr fun v => ?_
+    have hui0 : u i ≠ 0 := fun h => h0 (by rw [h, mul_zero])
+    have hxj0 : (x : F) ^ j ≠ 0 := pow_ne_zero j hx0
+    rw [v.ord_mul hxj0 hui0, show ((x : F) ^ j) = x ^ (j : ℤ) from (zpow_natCast x j).symm,
+      v.ord_zpow]
+    simp only [Finsupp.coe_smul, Pi.smul_apply, nsmul_eq_mul]
+    have huiL := (mem_lSpace_iff_ord.mp (hc i)).resolve_left hui0 v
+    simp only [Finsupp.coe_smul, Pi.smul_apply, nsmul_eq_mul] at huiL
+    rcases le_or_gt 0 (v.ord x) with hvx | hvx
+    · have hDv0 : D v = 0 := by rw [hD]; exact max_eq_left (by omega)
+      rw [hDv0, mul_zero, neg_zero]
+      exact add_nonneg (mul_nonneg (Int.natCast_nonneg j) hvx) (hu_reg i v hvx)
+    · have hDv : D v = -v.ord x := by rw [hD]; exact max_eq_right (by omega)
+      have hjc : (j : ℤ) + c ≤ m := by omega
+      have hDvpos : 0 ≤ D v := hDeff v
+      have hmj : (m : ℤ) - j ≥ c := by omega
+      nlinarith [huiL, mul_le_mul_of_nonneg_right hjc hDvpos, hDv]
+  have hlow : ∀ m, c ≤ m → (n : ℤ) * (m - c + 1) ≤ ell (m • D) := by
+    intro m hm
+    have : FiniteDimensional K (LSpace (m • D)) := finiteDimensional_lSpace (m • D)
+    set ι := Fin (m - c + 1) × Fin n
+    have hli' : LinearIndependent K (fun p : ι => (⟨x ^ (p.1 : ℕ) * u p.2,
+        hmem m hm p.1 p.2 (by omega)⟩ : LSpace (m • D))) := by
+      have hinj : Function.Injective
+          (fun p : ι => ((p.1 : ℕ), p.2) : ι → ℕ × Fin n) := by
+        intro p q hpq; simp only [Prod.mk.injEq, Fin.val_inj] at hpq
+        exact Prod.ext hpq.1 hpq.2
+      have hcomp := hli.comp _ hinj
+      rw [LinearIndependent] at hcomp ⊢
+      have hker := hcomp
+      refine LinearIndependent.of_comp (LSpace (m • D)).subtype ?_
+      exact hcomp
+    have hcard : Fintype.card ι = (m - c + 1) * n := by
+      simp [ι, Fintype.card_prod, Fintype.card_fin]
+    calc (n : ℤ) * (m - c + 1)
+        = ((m - c + 1) * n : ℕ) := by push_cast [Nat.cast_sub hm]; ring
+      _ = (Fintype.card ι : ℤ) := by rw [hcard]
+      _ ≤ (Module.finrank K (LSpace (m • D)) : ℤ) := by
+          exact_mod_cast hli'.fintype_card_le_finrank
+      _ = ell (m • D) := rfl
+  have hhigh : ∀ m : ℕ, (ell (m • D) : ℤ) ≤ m * Divisor.degree D + ell (0 : Divisor K F) := by
+    intro m
+    have := ell_le_degree_add_ellZero (hDeff' m)
+    rwa [Divisor.degree.map_nsmul, nsmul_eq_mul] at this
+  by_contra hlt
+  push Not at hlt
+  have hngt : (Divisor.degree D : ℤ) + 1 ≤ n := by omega
+  set m := c + n * c + ell (0 : Divisor K F) + 1 with hmdef
+  have hm_ge_c : c ≤ m := by omega
+  have hcombine := le_trans (hlow m hm_ge_c) (hhigh m)
+  have hdeg_le : Divisor.degree D ≤ (n : ℤ) - 1 := by omega
+  have hmZ : (m : ℤ) = c + n * c + ell (0 : Divisor K F) + 1 := by
+    simp only [hmdef]; push_cast; ring
+  have hmdd : (m : ℤ) * Divisor.degree D ≤ m * (n - 1) :=
+    mul_le_mul_of_nonneg_left hdeg_le (Int.natCast_nonneg m)
+  have hstep : (n : ℤ) * m - n * c + n ≤ m * n - m + ell (0 : Divisor K F) := by
+    have := le_trans hcombine (by linarith [hmdd])
+    nlinarith [this]
+  have hcontra : (m : ℤ) ≤ n * c - n + ell (0 : Divisor K F) := by linarith
+  linarith [hmZ, Int.natCast_nonneg c, Int.natCast_nonneg n, Int.natCast_nonneg (ell (0 : Divisor K
+    F))]
+
+end S_AlgebraicCurve_Divisor_finrank_adjoin_le_degree_of_eq_max_neg_ord
+end P2MW
+export P2MW.S_AlgebraicCurve_Divisor_finrank_adjoin_le_degree_of_eq_max_neg_ord (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Divisor.finrank_adjoin_le_degree_of_eq_max_neg_ord
+    {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (x : F) (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    (D : Divisor K F) (hD : ∀ v : Place K F, D v = max 0 (-v.ord x)) :
+    (Module.finrank (IntermediateField.adjoin K ({x} : Set F)) F : ℤ) ≤ Divisor.degree D :=
+  solution x hx D hD
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_pushforwardAlong_pushforwardAlong.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_pushforwardAlong_pushforwardAlong.lean
new file mode 100644
index 0000000000..f53e5cffd0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_pushforwardAlong_pushforwardAlong.lean
@@ -0,0 +1,99 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Divisor.pushforwardAlong_pushforwardAlong
+(bd1d7d23-52ed-54d1-b5fa-449c84c904d3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1c9fc3ae-866c-5271-b3b3-14d688758cdc
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_inertiaDegAlong_comp
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_restrictAlong_restrictAlong
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Functoriality of divisor push-forward along composites
+
+Theorem statement: `AlgebraicCurve.Divisor.pushforwardAlong_pushforwardAlong`
+(`bd1d7d23-52ed-54d1-b5fa-449c84c904d3`), by Claude, 2026-09-05.
+
+Proof: submission `1c9fc3ae-866c-5271-b3b3-14d688758cdc`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $F'$, $F''$ be fields, each of $F$, $F'$, $F''$ equipped with a $K$-algebra structure,
+let $\varphi \colon F \to F'$ and $\chi \colon F' \to F''$ be $K$-algebra homomorphisms, and assume
+that the underlying ring homomorphisms of $\varphi$, of $\chi$, and of the composite $\chi \circ
+\varphi$ are integral (the last being assumed separately, not deduced). Let $D$ be a divisor of
+$F''$ over $K$, that is, a finitely supported function with values in $\mathbb{Z}$ on the set of
+places of $F''$ over $K$, a place being a valuation subring of $F''$ that contains the image of $K$,
+is not all of $F''$, and is a principal ideal ring. Then pushing $D$ forward along $\chi$ and then
+pushing the result forward along $\varphi$ gives the same divisor of $F$ over $K$ as pushing $D$
+forward along $\chi \circ \varphi$. Here the push-forward along an integral $K$-algebra map is the
+additive map that sends a place $W$ of the larger field, with multiplicity $n$, to its restriction
+to the smaller field with multiplicity $n$ times the inertia degree of $W$ over that restriction.
+
+This is the transitivity (functoriality) of the push-forward of divisors in a tower of integral
+extensions of function fields over $K$, reflecting the multiplicativity of residue degrees in
+towers. It is used throughout the theory of divisor correspondences, for instance in the composition
+law for correspondences and in comparisons of a correspondence with a scalar multiple of another.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Divisor_pushforwardAlong_pushforwardAlong.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Divisor_pushforwardAlong_pushforwardAlong
+
+open IsDedekindDomain AlgebraicCurve
+
+theorem solution {K F F' F'' : Type*} [Field K] [Field F] [Field F'] [Field F''] [Algebra K F]
+    [Algebra K F'] [Algebra K F''] (φ : F →ₐ[K] F') (χ : F' →ₐ[K] F'') (hφ : φ.toRingHom.IsIntegral)
+    (hχ : χ.toRingHom.IsIntegral) (hχφ : (χ.comp φ).toRingHom.IsIntegral) (D : Divisor K F'') :
+    Divisor.pushforwardAlong φ hφ (Divisor.pushforwardAlong χ hχ D) = Divisor.pushforwardAlong
+      (χ.comp φ) hχφ D := by
+  have key : (Divisor.pushforwardAlong φ hφ).comp (Divisor.pushforwardAlong χ hχ)
+      = Divisor.pushforwardAlong (χ.comp φ) hχφ := by
+    refine Finsupp.addHom_ext fun W n => ?_
+    change Divisor.pushforwardAlong φ hφ (Divisor.pushforwardAlong χ hχ (Finsupp.single W n))
+        = Divisor.pushforwardAlong (χ.comp φ) hχφ (Finsupp.single W n)
+    rw [Divisor.pushforwardAlong_single, Divisor.pushforwardAlong_single,
+      Divisor.pushforwardAlong_single,
+      AlgebraicCurve.Place.restrictAlong_restrictAlong φ χ hφ hχ hχφ,
+      AlgebraicCurve.Place.inertiaDegAlong_comp φ χ hφ hχ hχφ W]
+    refine congrArg (Finsupp.single _) ?_
+    push_cast
+    ring
+  exact DFunLike.congr_fun key D
+
+end S_AlgebraicCurve_Divisor_pushforwardAlong_pushforwardAlong
+end P2MW
+export P2MW.S_AlgebraicCurve_Divisor_pushforwardAlong_pushforwardAlong (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Divisor.pushforwardAlong_pushforwardAlong {K F F' F'' : Type*} [Field K]
+    [Field F] [Field F'] [Field F''] [Algebra K F] [Algebra K F'] [Algebra K F''] (φ : F →ₐ[K] F')
+    (χ : F' →ₐ[K] F'') (hφ : φ.toRingHom.IsIntegral) (hχ : χ.toRingHom.IsIntegral)
+    (hχφ : (χ.comp φ).toRingHom.IsIntegral) (D : Divisor K F'') :
+    Divisor.pushforwardAlong φ hφ (Divisor.pushforwardAlong χ hχ D) = Divisor.pushforwardAlong
+      (χ.comp φ) hχφ D :=
+  solution φ χ hφ hχ hχφ D
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_pushforwardNormFormula.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_pushforwardNormFormula.lean
new file mode 100644
index 0000000000..68544b7367
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Divisor_pushforwardNormFormula.lean
@@ -0,0 +1,1284 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Divisor.pushforwardNormFormula
+(c9831641-b6b4-5dfc-bb99-5334e405eccd) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission cd5693b3-c78b-5c48-b417-36778dff9507
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+
+import Mathlib.RingTheory.DedekindDomain.IntegralClosure
+import Mathlib.RingTheory.DedekindDomain.Factorization
+import Mathlib.Algebra.Polynomial.Lifts
+import Mathlib.FieldTheory.Minpoly.Field
+import Mathlib.RingTheory.RamificationInertia.Basic
+import Mathlib.RingTheory.Ideal.Norm.RelNorm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_nonneg_of_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_of_ord_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_iff_ord_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_exists_ord_pos
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_eq_zero_iff_adicValuation_eq_one
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Push-forward of a principal divisor is the norm
+
+Theorem statement: `AlgebraicCurve.Divisor.pushforwardNormFormula`
+(`c9831641-b6b4-5dfc-bb99-5334e405eccd`), by Claude, 2026-09-05.
+
+Proof: submission `cd5693b3-c78b-5c48-b417-36778dff9507`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $F'$ be fields with $F$ and $F'$ algebras over $K$ and $F'$ an algebra over $F$, the
+three structures forming a scalar tower, with $F'/F$ finite-dimensional and separable, $F$ of
+characteristic zero, and assume `HasPrincipalDivisors K F'`, i.e. every nonzero $f \in F'$ admits a
+divisor $D$ (a finitely supported $\mathbb{Z}$-valued function on the places of $F'$ over $K$, a
+place being a valuation subring of $F'$ that contains the image of $K$, is not all of $F'$ and is a
+principal ideal ring) whose value at every place $w$ is $w.\mathrm{ord}\, f$ and whose degree
+$\sum_w D(w)\cdot \deg w$ vanishes. Then `Divisor.PushforwardNormFormula K F F'` holds: for every
+nonzero $f \in F'$, every divisor $D$ on the places of $F'$ over $K$ with $D(w) = w.\mathrm{ord}\,
+f$ for all $w$, and every place $v$ of $F$ over $K$, the push-forward of $D$ — the additive map
+sending a place $w$ to its restriction $w|_F$ weighted by the inertia degree of $w$ over $F$, so
+that its value at $v$ is $\sum_{w|_F = v} f(w|v)\, D(w)$ — takes at $v$ the value
+$v.\mathrm{ord}\big(N_{F'/F}(f)\big)$, the order at $v$ of the relative norm `Algebra.norm F f`.
+
+This is the classical compatibility of the inertia-weighted push-forward (norm) of divisors with the
+field norm, $\pi_*(\operatorname{div} f) = \operatorname{div}(N_{F'/F} f)$, for a finite separable
+extension of function fields. It is used to show that the push-forward carries principal divisors to
+principal divisors, and hence descends to divisor class groups, via
+[`AlgebraicCurve.Divisor.pushforward_div`](thm.html#AlgebraicCurve.Divisor.pushforward_div) and
+[`AlgebraicCurve.normFormulaAlong`](thm.html#AlgebraicCurve.normFormulaAlong).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Divisor_pushforwardNormFormula.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Divisor_pushforwardNormFormula
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_Divisor_pushforwardNormFormula.AlgebraicCurve"
+
+
+noncomputable section
+
+open IsDedekindDomain Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.restrict_fiber_finite Divisor.pushforward_apply \
+  Divisor.PushforwardNormFormula Place.mem_fiber FundamentalIdentity SumRamificationInertia Place \
+  Place.ext Divisor HasPrincipalDivisors Pic Pic0"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ramificationIndex ramificationIndex_pos restrict \
+  restrict_toValuationSubring ord_restrict restrict_fiber_finite restrictInclusion \
+  restrictResidueMap inertiaDeg fiber mem_fiber ext ResidueField deg adicValuation_coe_eq_one_iff \
+  ord ord_mul ord_inv ord_coe_irreducible ord_zpow ord_unit_smul_zpow \
+  isPrincipalIdealRing_valuationSubring ne_top' algebraMap_mem' toValuationSubring \
+  isPrincipalIdealRing' mk ord_nonneg_of_mem mem_of_ord_nonneg mem_iff_ord_nonneg exists_ord_pos \
+  ord_eq_zero_iff_adicValuation_eq_one"
+p2m_open "AlgebraicCurve.Place"
+
+section IntegrallyClosed
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.ord_neg (f : F) : w.ord (-f) = w.ord f := by
+  simp only [ord, Valuation.map_neg]
+
+p2m_export "AlgebraicCurve.Place" "ord_neg"
+
+private theorem _root_.AlgebraicCurve.Place.mem_of_eval_monic_eq_zero {P : Polynomial F}
+    (hP : P.Monic)
+    (hcoeff : ∀ i, P.coeff i ∈ w.toValuationSubring) {x : F} (hx : P.eval x = 0) :
+    x ∈ w.toValuationSubring := by
+  have hlift : P ∈ lifts (algebraMap w.toValuationSubring F) := by
+    rw [lifts_iff_coeff_lifts]
+    exact fun n => ⟨⟨P.coeff n, hcoeff n⟩, rfl⟩
+  obtain ⟨Q, hQmap, -, hQmonic⟩ := lifts_and_degree_eq_and_monic hlift hP
+  have hint : IsIntegral w.toValuationSubring x := by
+    refine ⟨Q, hQmonic, ?_⟩
+    rw [show eval₂ (algebraMap w.toValuationSubring F) x Q = (Q.map _).eval x from
+      (eval_map _ x).symm, hQmap, hx]
+  obtain ⟨y, hy⟩ := IsIntegrallyClosed.isIntegral_iff.mp hint
+  exact hy ▸ y.2
+
+p2m_export "AlgebraicCurve.Place" "mem_of_eval_monic_eq_zero"
+
+private theorem _root_.AlgebraicCurve.Place.mem_maximalIdeal_iff_ord_pos {x : F} (hx : x ≠ 0)
+    (hmem : x ∈ w.toValuationSubring) :
+    (⟨x, hmem⟩ : w.toValuationSubring) ∈ IsLocalRing.maximalIdeal w.toValuationSubring ↔
+      0 < w.ord x := by
+  have hnonneg : 0 ≤ w.ord x := w.ord_nonneg_of_mem hmem
+  have hcoe : ((⟨x, hmem⟩ : w.toValuationSubring) : F) = x := rfl
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff, ← w.adicValuation_coe_eq_one_iff,
+    hcoe, ← w.ord_eq_zero_iff_adicValuation_eq_one hx]
+  omega
+
+p2m_export "AlgebraicCurve.Place" "mem_maximalIdeal_iff_ord_pos"
+end IntegrallyClosed
+
+section SupportTransfer
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F'] [Algebra F F']
+  [FiniteDimensional F F']
+
+variable (w : Place K F')
+
+omit [FiniteDimensional F F'] in
+private theorem _root_.AlgebraicCurve.Place.aeval_mem {Q : Polynomial F} {x : F'}
+    (hcoeff : ∀ i, algebraMap F F' (Q.coeff i) ∈ w.toValuationSubring)
+    (hx : x ∈ w.toValuationSubring) :
+    Polynomial.aeval x Q ∈ w.toValuationSubring := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range]
+  exact sum_mem fun i _ => mul_mem (hcoeff i) (pow_mem hx i)
+
+p2m_export "AlgebraicCurve.Place" "aeval_mem"
+
+theorem exists_coeff_ord_ne_zero {f : F'} (hf : f ≠ 0) (hford : w.ord f ≠ 0) :
+    ∃ i < (minpoly F f).natDegree, (minpoly F f).coeff i ≠ 0 ∧
+      w.ord (algebraMap F F' ((minpoly F f).coeff i)) ≠ 0 := by
+  by_contra hcon
+  push Not at hcon
+  set P := minpoly F f with hPdef
+  have hint : IsIntegral F f := Algebra.IsIntegral.isIntegral f
+  have hmonic : P.Monic := minpoly.monic hint
+  have hdeg : 0 < P.natDegree := minpoly.natDegree_pos hint
+  have hc0 : P.coeff 0 ≠ 0 := minpoly.coeff_zero_ne_zero hint hf
+  have hcoeff : ∀ i, algebraMap F F' (P.coeff i) ∈ w.toValuationSubring := by
+    intro i
+    rcases lt_trichotomy i P.natDegree with hi | hi | hi
+    · rcases eq_or_ne (P.coeff i) 0 with h0 | h0
+      · simp [h0]
+      · exact w.mem_of_ord_nonneg (by simpa using h0) (by have := hcon i hi h0; omega)
+    · subst hi
+      simp [hmonic.coeff_natDegree]
+    · simp [Polynomial.coeff_eq_zero_of_natDegree_lt hi]
+  have hfmem : f ∈ w.toValuationSubring := by
+    refine w.mem_of_eval_monic_eq_zero (P := P.map (algebraMap F F')) (hmonic.map _)
+      (fun i => by simpa using hcoeff i) ?_
+    rw [Polynomial.eval_map, ← Polynomial.aeval_def, hPdef, minpoly.aeval]
+  have hfpos : 0 < w.ord f := lt_of_le_of_ne (w.ord_nonneg_of_mem hfmem) (Ne.symm hford)
+  have hkey : algebraMap F F' (P.coeff 0) = -(f * Polynomial.aeval f P.divX) := by
+    have hsplit : Polynomial.aeval f (Polynomial.X * P.divX + Polynomial.C (P.coeff 0))
+        = (0 : F') := by rw [P.X_mul_divX_add]; exact minpoly.aeval F f
+    rw [map_add, map_mul, Polynomial.aeval_X, Polynomial.aeval_C] at hsplit
+    linear_combination hsplit
+  have hcof_mem : Polynomial.aeval f P.divX ∈ w.toValuationSubring :=
+    w.aeval_mem (fun i => by rw [Polynomial.coeff_divX]; exact hcoeff (i + 1)) hfmem
+  have hcof_ne : Polynomial.aeval f P.divX ≠ 0 := by
+    intro h
+    rw [h, mul_zero, neg_zero] at hkey
+    exact hc0 (by simpa using hkey)
+  have hpos0 : 0 < w.ord (algebraMap F F' (P.coeff 0)) := by
+    rw [hkey, w.ord_neg, w.ord_mul hf hcof_ne]
+    have := w.ord_nonneg_of_mem hcof_mem
+    omega
+  have := hcon 0 hdeg hc0
+  omega
+
+end SupportTransfer
+
+section Chart
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R F] [IsFractionRing R F]
+variable (w : Place K F)
+
+private def chartHom (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    R →+* w.toValuationSubring :=
+  (algebraMap R F).codRestrict w.toValuationSubring.toSubring hw
+
+omit [IsDedekindDomain R] [IsFractionRing R F] in
+@[scoped simp]
+private theorem coe_chartHom (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) (r : R) :
+    (chartHom w hw r : F) = algebraMap R F r := rfl
+
+variable (R) in
+def center (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) : Ideal R :=
+  (IsLocalRing.maximalIdeal w.toValuationSubring).comap (chartHom w hw)
+
+scoped instance (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    (center R w hw).IsPrime :=
+  Ideal.comap_isPrime _ _
+
+omit [IsDedekindDomain R] [IsFractionRing R F] in
+theorem mem_center_iff (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) {r : R} :
+    r ∈ center R w hw ↔
+      (⟨algebraMap R F r, hw r⟩ : w.toValuationSubring) ∈
+        IsLocalRing.maximalIdeal w.toValuationSubring :=
+  Iff.rfl
+
+theorem mem_center_iff_ord_pos (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring)
+    {r : R} (hr : r ≠ 0) :
+    r ∈ center R w hw ↔ 0 < w.ord (algebraMap R F r) := by
+  have hr' : algebraMap R F r ≠ 0 := by
+    simpa using (IsFractionRing.injective R F).ne_iff.mpr hr
+  rw [mem_center_iff, w.mem_maximalIdeal_iff_ord_pos hr']
+
+omit [IsDedekindDomain R] [IsFractionRing R F] in
+private theorem inv_algebraMap_mem (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring)
+    {s : R} (hs : IsUnit (chartHom w hw s)) :
+    (algebraMap R F s)⁻¹ ∈ w.toValuationSubring := by
+  obtain ⟨u, hu⟩ := hs
+  have hcoe : ((u : w.toValuationSubring) : F) = algebraMap R F s := by rw [hu]; rfl
+  have h1 : (((u⁻¹ : w.toValuationSubringˣ) : w.toValuationSubring) : F)
+      * algebraMap R F s = 1 := by
+    have hmul := congrArg (fun a : w.toValuationSubring => (a : F)) u.inv_mul
+    push_cast at hmul
+    rwa [hcoe] at hmul
+  rw [← eq_inv_of_mul_eq_one_left h1]
+  exact SetLike.coe_mem _
+
+theorem center_ne_bot (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    center R w hw ≠ ⊥ := by
+  intro hbot
+  apply w.ne_top'
+  have hunit : ∀ r : R, r ≠ 0 → IsUnit (chartHom w hw r) := by
+    intro r hr
+    by_contra hu
+    have : r ∈ center R w hw :=
+      (mem_center_iff w hw).mpr ((IsLocalRing.mem_maximalIdeal _).mpr hu)
+    rw [hbot] at this
+    exact hr (by simpa using this)
+  refine SetLike.ext fun x => ⟨fun _ => ValuationSubring.mem_top x, fun _ => ?_⟩
+  obtain ⟨a, b, hb, hx⟩ := IsFractionRing.div_surjective (A := R) x
+  rw [← hx, div_eq_mul_inv]
+  exact mul_mem (hw a) (inv_algebraMap_mem w hw (hunit b (nonZeroDivisors.ne_zero hb)))
+
+variable (R) in
+def centerHeightOneSpectrum (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    HeightOneSpectrum R :=
+  ⟨center R w hw, inferInstance, center_ne_bot w hw⟩
+
+@[scoped simp]
+theorem centerHeightOneSpectrum_asIdeal
+    (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    (centerHeightOneSpectrum R w hw).asIdeal = center R w hw := rfl
+
+theorem valuationSubringAtPrime_centerHeightOneSpectrum_le
+    (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    HeightOneSpectrum.valuationSubringAtPrime F (centerHeightOneSpectrum R w hw) ≤
+      w.toValuationSubring := by
+  rintro x ⟨a, s, hs, rfl⟩
+  refine mul_mem (hw a) (inv_algebraMap_mem w hw ?_)
+  rw [← IsLocalRing.notMem_maximalIdeal]
+  exact fun hmem => hs ((mem_center_iff w hw).mpr hmem)
+
+theorem toValuationSubring_eq_of_forall_mem
+    (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    w.toValuationSubring =
+      HeightOneSpectrum.valuationSubringAtPrime F (centerHeightOneSpectrum R w hw) :=
+  (ValuationSubring.eq_of_le_of_ne_top _
+    (valuationSubringAtPrime_centerHeightOneSpectrum_le w hw) w.ne_top').symm
+
+theorem finite_setOf_forall_mem_and_ord_pos {r₀ : R} (hr₀ : r₀ ≠ 0) :
+    {w : Place K F | (∀ r : R, algebraMap R F r ∈ w.toValuationSubring) ∧
+      0 < w.ord (algebraMap R F r₀)}.Finite := by
+  have hfin : {p : HeightOneSpectrum R | p.asIdeal ∣ Ideal.span {r₀}}.Finite :=
+    Ideal.finite_factors (by simpa [Ideal.span_singleton_eq_bot] using hr₀)
+  rw [← Set.finite_coe_iff]
+  have := hfin.to_subtype
+  refine Finite.of_injective
+    (fun w => (⟨centerHeightOneSpectrum R w.1 w.2.1, ?_⟩ :
+      {p : HeightOneSpectrum R | p.asIdeal ∣ Ideal.span {r₀}})) ?_
+  · rw [Set.mem_ofPred_eq, centerHeightOneSpectrum_asIdeal, Ideal.dvd_span_singleton]
+    exact (mem_center_iff_ord_pos w.1 w.2.1 hr₀).mpr w.2.2
+  · intro w w' h
+    have hcenter : centerHeightOneSpectrum R w.1 w.2.1
+        = centerHeightOneSpectrum R w'.1 w'.2.1 := congrArg Subtype.val h
+    refine Subtype.ext (Place.ext ?_)
+    rw [toValuationSubring_eq_of_forall_mem w.1 w.2.1,
+      toValuationSubring_eq_of_forall_mem w'.1 w'.2.1, hcenter]
+
+end Chart
+
+section FiberFiniteness
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+  [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+theorem finite_setOf_restrict_eq (v : Place K F) :
+    {w : Place K F' | w.restrict F = v}.Finite := by
+  classical
+  let : Algebra v.toValuationSubring F' :=
+    ((algebraMap F F').comp (algebraMap v.toValuationSubring F)).toAlgebra
+  have : IsScalarTower v.toValuationSubring F F' :=
+    IsScalarTower.of_algebraMap_eq fun _ => rfl
+  have : IsDedekindDomain (integralClosure v.toValuationSubring F') :=
+    integralClosure.isDedekindDomain v.toValuationSubring F F'
+  have : IsFractionRing (integralClosure v.toValuationSubring F') F' :=
+    integralClosure.isFractionRing_of_finite_extension (A := v.toValuationSubring) F F'
+  obtain ⟨π, hπ0, hπpos⟩ := v.exists_ord_pos
+  have hπmem : π ∈ v.toValuationSubring := v.mem_of_ord_nonneg hπ0 hπpos.le
+  set C := integralClosure v.toValuationSubring F' with hC
+  set π' : C := algebraMap v.toValuationSubring C ⟨π, hπmem⟩ with hπ'
+  have hπ'F : algebraMap C F' π' = algebraMap F F' π := by
+    rw [hπ', ← IsScalarTower.algebraMap_apply, IsScalarTower.algebraMap_apply
+      v.toValuationSubring F F']
+    rfl
+  have hπ'0 : π' ≠ 0 := by
+    intro h
+    apply hπ0
+    have : algebraMap C F' π' = 0 := by rw [h, map_zero]
+    rw [hπ'F] at this
+    simpa using this
+  refine Set.Finite.subset (finite_setOf_forall_mem_and_ord_pos (R := C) hπ'0) ?_
+  rintro w (hw : w.restrict F = v)
+  have hOv : ∀ g : F, g ∈ v.toValuationSubring → algebraMap F F' g ∈ w.toValuationSubring := by
+    intro g hg
+    rw [← hw] at hg
+    exact hg
+  refine ⟨?_, ?_⟩
+  · intro c
+    obtain ⟨Q, hQmonic, hQeval⟩ := c.2
+    have : algebraMap C F' c = (c : F') := rfl
+    rw [this]
+    refine w.mem_of_eval_monic_eq_zero (P := Q.map (algebraMap v.toValuationSubring F'))
+      (hQmonic.map _) (fun i => ?_) (by rw [Polynomial.eval_map]; exact hQeval)
+    rw [Polynomial.coeff_map, IsScalarTower.algebraMap_apply v.toValuationSubring F F']
+    exact hOv _ (Q.coeff i).2
+  · rw [hπ'F, w.ord_restrict π, hw]
+    have hepos : 0 < w.ramificationIndex F := w.ramificationIndex_pos
+    positivity
+
+end FiberFiniteness
+
+end Place
+end AlgebraicCurve
+
+section
+
+open IsDedekindDomain WithZero IsLocalRing
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.restrict_fiber_finite Divisor.pushforward_apply \
+  Divisor.PushforwardNormFormula Place.mem_fiber FundamentalIdentity SumRamificationInertia Place \
+  Place.ext Divisor HasPrincipalDivisors Pic Pic0"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ramificationIndex ramificationIndex_pos restrict \
+  restrict_toValuationSubring ord_restrict restrict_fiber_finite restrictInclusion \
+  restrictResidueMap inertiaDeg fiber mem_fiber ext ResidueField deg adicValuation_coe_eq_one_iff \
+  ord ord_mul ord_inv ord_coe_irreducible ord_zpow ord_unit_smul_zpow \
+  isPrincipalIdealRing_valuationSubring ne_top' algebraMap_mem' toValuationSubring \
+  isPrincipalIdealRing' mk ord_nonneg_of_mem mem_of_ord_nonneg mem_iff_ord_nonneg exists_ord_pos \
+  ord_eq_zero_iff_adicValuation_eq_one"
+p2m_open "AlgebraicCurve.Place"
+
+section Uniqueness
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+theorem eq_ord_of_addHom_of_nonneg_iff (φ : F → ℤ)
+    (hmul : ∀ x y, x ≠ 0 → y ≠ 0 → φ (x * y) = φ x + φ y)
+    (hone : ∃ t, t ≠ 0 ∧ φ t = 1)
+    (hiff : ∀ x, x ≠ 0 → (0 ≤ φ x ↔ x ∈ w.toValuationSubring))
+    {x : F} (hx : x ≠ 0) : φ x = w.ord x := by
+  obtain ⟨t, ht0, ht1⟩ := hone
+  have hφ1 : φ 1 = 0 := by
+    have := hmul 1 1 one_ne_zero one_ne_zero
+    rw [mul_one] at this
+    omega
+  have hinv : ∀ y, y ≠ 0 → φ y⁻¹ = -φ y := by
+    intro y hy
+    have h1 : φ (y * y⁻¹) = φ y + φ y⁻¹ := hmul y y⁻¹ hy (inv_ne_zero hy)
+    rw [mul_inv_cancel₀ hy, hφ1] at h1
+    omega
+  have hpow : ∀ (y : F), y ≠ 0 → ∀ m : ℕ, φ (y ^ m) = m * φ y := by
+    intro y hy m
+    induction m with
+    | zero => simpa using hφ1
+    | succ m ih =>
+      rw [pow_succ, hmul _ _ (pow_ne_zero _ hy) hy, ih]
+      push_cast
+      ring
+  have hzpow : ∀ (y : F) (n : ℤ), y ≠ 0 → φ (y ^ n) = n * φ y := by
+    intro y n hy
+    rcases n with m | m
+    · simpa using hpow y hy m
+    · rw [zpow_negSucc, hinv _ (pow_ne_zero _ hy), hpow y hy, Int.negSucc_eq]
+      push_cast
+      ring
+  have hsign : ∀ y, y ≠ 0 → (0 ≤ φ y ↔ 0 ≤ w.ord y) := by
+    intro y hy
+    rw [hiff y hy, w.mem_iff_ord_nonneg hy]
+  have hzero : ∀ y, y ≠ 0 → (φ y = 0 ↔ w.ord y = 0) := by
+    intro y hy
+    have h1 := hsign y hy
+    have h2 := hsign y⁻¹ (inv_ne_zero hy)
+    rw [hinv y hy, w.ord_inv] at h2
+    omega
+  have htord : 0 < w.ord t := by
+    have h1 := (hsign t ht0).mp (by omega)
+    have h2 := (hzero t ht0).not.mp (by omega)
+    omega
+  have hcancel : ∀ y, y ≠ 0 → w.ord y = φ y * w.ord t := by
+    intro y hy
+    have hyt : y * t ^ (-(φ y)) ≠ 0 := mul_ne_zero hy (zpow_ne_zero _ ht0)
+    have h1 : φ (y * t ^ (-(φ y))) = 0 := by
+      rw [hmul _ _ hy (zpow_ne_zero _ ht0), hzpow t _ ht0, ht1]
+      ring
+    have h2 : w.ord (y * t ^ (-(φ y))) = 0 := (hzero _ hyt).mp h1
+    rw [w.ord_mul hy (zpow_ne_zero _ ht0), w.ord_zpow] at h2
+    linarith
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  have hπ0 : (π : F) ≠ 0 := by
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have hπcancel := hcancel (π : F) hπ0
+  rw [w.ord_coe_irreducible hπ] at hπcancel
+  have htord1 : w.ord t = 1 := by
+    have hdvd : w.ord t ∣ 1 := ⟨φ (π : F), by linarith⟩
+    have := Int.le_of_dvd one_pos hdvd
+    omega
+  have := hcancel x hx
+  rw [htord1, mul_one] at this
+  exact this.symm
+
+end Uniqueness
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+variable (F') in
+@[reducible] def valuationSubringAlgebra (v : Place K F) : Algebra v.toValuationSubring F' :=
+  ((algebraMap F F').comp (algebraMap v.toValuationSubring F)).toAlgebra
+
+attribute [local instance 0] valuationSubringAlgebra
+
+section Setup
+
+variable (v : Place K F)
+
+scoped instance (priority := 100) : IsScalarTower v.toValuationSubring F F' :=
+  IsScalarTower.of_algebraMap_eq fun _ => rfl
+
+variable (F') in
+abbrev integralClosureAt : Type _ := integralClosure v.toValuationSubring F'
+
+scoped instance : IsDedekindDomain (integralClosureAt F' v) :=
+  integralClosure.isDedekindDomain v.toValuationSubring F F'
+
+scoped instance : IsFractionRing (integralClosureAt F' v) F' :=
+  integralClosure.isFractionRing_of_finite_extension (A := v.toValuationSubring) F F'
+
+scoped instance : Module.Finite v.toValuationSubring (integralClosureAt F' v) :=
+  IsIntegralClosure.finite v.toValuationSubring F F' _
+
+omit [Algebra K F'] [IsScalarTower K F F'] [FiniteDimensional F F']
+  [Algebra.IsSeparable F F'] in
+theorem algebraMap_integralClosureAt_injective :
+    Function.Injective
+      (algebraMap v.toValuationSubring (integralClosureAt F' v)) := by
+  intro a b hab
+  have h1 : algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) a)
+        = algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) b) := by rw [hab]
+  rw [← IsScalarTower.algebraMap_apply, ← IsScalarTower.algebraMap_apply] at h1
+  exact ((algebraMap F F').injective.comp
+    (IsFractionRing.injective v.toValuationSubring F)) h1
+
+scoped instance : Module.IsTorsionFree v.toValuationSubring (integralClosureAt F' v) := by
+  rw [Module.isTorsionFree_iff_smul_eq_zero]
+  intro r c hrc
+  rw [Algebra.smul_def] at hrc
+  rcases mul_eq_zero.mp hrc with h | h
+  · exact Or.inl (algebraMap_integralClosureAt_injective v (by rw [h, map_zero]))
+  · exact Or.inr h
+
+theorem maximalIdeal_ne_bot :
+    IsLocalRing.maximalIdeal v.toValuationSubring ≠ ⊥ := by
+  intro h
+  exact ValuationSubring.not_isField_of_ne_top F v.ne_top'
+    (IsLocalRing.isField_iff_maximalIdeal_eq.mpr h)
+
+end Setup
+
+section Center
+
+variable {v : Place K F} {w : Place K F'}
+
+omit [FiniteDimensional F F'] in
+theorem forall_mem_of_restrict_eq (hw : w.restrict F = v) (c : integralClosureAt F' v) :
+    algebraMap (integralClosureAt F' v) F' c ∈ w.toValuationSubring := by
+  obtain ⟨Q, hQmonic, hQeval⟩ := c.2
+  have hOv : ∀ g : F, g ∈ v.toValuationSubring →
+      algebraMap F F' g ∈ w.toValuationSubring := by
+    intro g hg
+    rw [← hw] at hg
+    exact hg
+  refine w.mem_of_eval_monic_eq_zero (P := Q.map (algebraMap v.toValuationSubring F'))
+    (hQmonic.map _) (fun i => ?_) (by rw [Polynomial.eval_map]; exact hQeval)
+  rw [Polynomial.coeff_map,
+    IsScalarTower.algebraMap_apply v.toValuationSubring F F']
+  exact hOv _ (Q.coeff i).2
+
+variable (F' v) in
+def fiberCenter (hw : w.restrict F = v) : HeightOneSpectrum (integralClosureAt F' v) :=
+  centerHeightOneSpectrum (integralClosureAt F' v) w (forall_mem_of_restrict_eq hw)
+
+theorem mem_fiberCenter_iff_ord_pos (hw : w.restrict F = v) {c : integralClosureAt F' v}
+    (hc : c ≠ 0) :
+    c ∈ (fiberCenter F' v hw).asIdeal ↔
+      0 < w.ord (algebraMap (integralClosureAt F' v) F' c) :=
+  mem_center_iff_ord_pos w (forall_mem_of_restrict_eq hw) hc
+
+theorem toValuationSubring_eq_of_restrict_eq (hw : w.restrict F = v) :
+    w.toValuationSubring =
+      HeightOneSpectrum.valuationSubringAtPrime F' (fiberCenter F' v hw) :=
+  toValuationSubring_eq_of_forall_mem w (forall_mem_of_restrict_eq hw)
+
+theorem mem_maximalIdeal_iff_ord_pos' {r : v.toValuationSubring} (hr : r ≠ 0) :
+    r ∈ IsLocalRing.maximalIdeal v.toValuationSubring ↔
+      0 < v.ord (algebraMap v.toValuationSubring F r) := by
+  have hrF : (algebraMap v.toValuationSubring F r : F) ≠ 0 := by
+    simpa using (IsFractionRing.injective v.toValuationSubring F).ne_iff.mpr hr
+  have := v.mem_maximalIdeal_iff_ord_pos hrF (Subtype.coe_prop r)
+  simpa using this
+
+omit [Algebra K F'] [IsScalarTower K F F'] [FiniteDimensional F F']
+  [Algebra.IsSeparable F F'] in
+theorem algebraMap_integralClosureAt_ne_zero {r : v.toValuationSubring} (hr : r ≠ 0) :
+    algebraMap v.toValuationSubring (integralClosureAt F' v) r ≠ 0 := fun h =>
+  hr (algebraMap_integralClosureAt_injective v (by rw [h, map_zero]))
+
+omit [FiniteDimensional F F'] in
+theorem ord_algebraMap_integralClosureAt (hw : w.restrict F = v) (r : v.toValuationSubring) :
+    w.ord (algebraMap (integralClosureAt F' v) F'
+        (algebraMap v.toValuationSubring (integralClosureAt F' v) r))
+      = w.ramificationIndex F * v.ord (algebraMap v.toValuationSubring F r) := by
+  rw [← IsScalarTower.algebraMap_apply,
+    IsScalarTower.algebraMap_apply v.toValuationSubring F F', w.ord_restrict, hw]
+
+theorem fiberCenter_liesOver (hw : w.restrict F = v) :
+    (fiberCenter F' v hw).asIdeal.LiesOver
+      (IsLocalRing.maximalIdeal v.toValuationSubring) := by
+  refine ⟨?_⟩
+  rw [Ideal.under_def]
+  ext r
+  rcases eq_or_ne r 0 with rfl | hr
+  · simp
+  rw [Ideal.mem_comap,
+    mem_fiberCenter_iff_ord_pos hw (algebraMap_integralClosureAt_ne_zero hr),
+    ord_algebraMap_integralClosureAt hw, mem_maximalIdeal_iff_ord_pos' hr]
+  have hepos : 0 < ramificationIndex (F := F) w := w.ramificationIndex_pos
+  constructor
+  · intro h
+    positivity
+  · intro h
+    rcases mul_pos_iff.mp h with ⟨_, h2⟩ | ⟨h1, _⟩
+    · exact h2
+    · omega
+
+end Center
+
+section ValuationDictionary
+
+variable {v : Place K F} {w : Place K F'}
+
+theorem neg_log_valuation_fiberCenter_eq_ord (hw : w.restrict F = v) {x : F'} (hx : x ≠ 0) :
+    -log ((fiberCenter F' v hw).valuation F' x) = w.ord x := by
+  refine eq_ord_of_addHom_of_nonneg_iff w
+    (fun y => -log ((fiberCenter F' v hw).valuation F' y)) ?_ ?_ ?_ hx
+  · intro a b ha hb
+    show -log ((fiberCenter F' v hw).valuation F' (a * b)) =
+      -log ((fiberCenter F' v hw).valuation F' a) +
+        -log ((fiberCenter F' v hw).valuation F' b)
+    rw [map_mul, log_mul ((Valuation.ne_zero_iff _).mpr ha) ((Valuation.ne_zero_iff _).mpr hb)]
+    ring
+  · obtain ⟨t, ht⟩ := (fiberCenter F' v hw).valuation_exists_uniformizer F'
+    refine ⟨t, ?_, ?_⟩
+    · intro h
+      rw [h, map_zero] at ht
+      exact exp_ne_zero ht.symm
+    · show -log ((fiberCenter F' v hw).valuation F' t) = 1
+      rw [ht, log_exp]
+      ring
+  · intro y hy
+    have hy0 : (fiberCenter F' v hw).valuation F' y ≠ 0 := (Valuation.ne_zero_iff _).mpr hy
+    change 0 ≤ -log ((fiberCenter F' v hw).valuation F' y) ↔ y ∈ w.toValuationSubring
+    have hmem : y ∈ w.toValuationSubring ↔ (fiberCenter F' v hw).valuation F' y ≤ 1 := by
+      rw [toValuationSubring_eq_of_restrict_eq hw,
+        HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact Iff.rfl
+    rw [hmem]
+    constructor
+    · intro h
+      calc (fiberCenter F' v hw).valuation F' y
+          = exp (log ((fiberCenter F' v hw).valuation F' y)) := (exp_log hy0).symm
+        _ ≤ exp 0 := by rw [exp_le_exp]; omega
+        _ = 1 := exp_zero
+    · intro h
+      have h1 : exp (log ((fiberCenter F' v hw).valuation F' y)) ≤ exp 0 := by
+        rw [exp_log hy0, exp_zero]
+        exact h
+      rw [exp_le_exp] at h1
+      omega
+
+theorem le_ord_iff_mem_pow_fiberCenter (hw : w.restrict F = v)
+    {c : integralClosureAt F' v} (hc : c ≠ 0) (n : ℕ) :
+    (n : ℤ) ≤ w.ord (algebraMap (integralClosureAt F' v) F' c) ↔
+      c ∈ (fiberCenter F' v hw).asIdeal ^ n := by
+  have hcF : algebraMap (integralClosureAt F' v) F' c ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hc
+  rw [← neg_log_valuation_fiberCenter_eq_ord hw hcF,
+    HeightOneSpectrum.valuation_of_algebraMap,
+    ← HeightOneSpectrum.intValuation_le_pow_iff_mem]
+  have h0 : (fiberCenter F' v hw).intValuation c ≠ 0 :=
+    HeightOneSpectrum.intValuation_ne_zero _ c hc
+  constructor
+  · intro h
+    calc (fiberCenter F' v hw).intValuation c
+        = exp (log ((fiberCenter F' v hw).intValuation c)) := (exp_log h0).symm
+      _ ≤ exp (-(n : ℤ)) := by rw [exp_le_exp]; omega
+  · intro h
+    have h1 : exp (log ((fiberCenter F' v hw).intValuation c)) ≤ exp (-(n : ℤ)) := by
+      rw [exp_log h0]
+      exact h
+    rw [exp_le_exp] at h1
+    omega
+
+theorem ramificationIndex_eq_ramificationIdx_fiberCenter (hw : w.restrict F = v) :
+    w.ramificationIndex F =
+      (IsLocalRing.maximalIdeal v.toValuationSubring).ramificationIdx'
+        (fiberCenter F' v hw).asIdeal := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπ0 : π ≠ 0 := hπ.ne_zero
+  have hπC : algebraMap v.toValuationSubring (integralClosureAt F' v) π ≠ 0 :=
+    algebraMap_integralClosureAt_ne_zero hπ0
+  have hmap : (IsLocalRing.maximalIdeal v.toValuationSubring).map
+      (algebraMap v.toValuationSubring (integralClosureAt F' v))
+        = Ideal.span {algebraMap v.toValuationSubring (integralClosureAt F' v) π} := by
+    rw [hπ.maximalIdeal_eq, Ideal.map_span, Set.image_singleton]
+  have hord : w.ord (algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) π))
+        = w.ramificationIndex F := by
+    rw [ord_algebraMap_integralClosureAt hw, ValuationSubring.algebraMap_apply,
+      v.ord_coe_irreducible hπ, mul_one]
+  refine (Ideal.ramificationIdx'_spec ?_ ?_).symm
+  · rw [hmap, Ideal.span_singleton_le_iff_mem,
+      ← le_ord_iff_mem_pow_fiberCenter hw hπC, hord]
+  · rw [hmap, Ideal.span_singleton_le_iff_mem,
+      ← le_ord_iff_mem_pow_fiberCenter hw hπC, hord]
+    have : 0 < w.ramificationIndex F := w.ramificationIndex_pos
+    push_cast
+    omega
+
+end ValuationDictionary
+
+section ResidueDictionary
+
+variable {v : Place K F} {w : Place K F'}
+
+def toValuationSubringOfRestrictEq (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.toValuationSubring :=
+  (algebraMap (integralClosureAt F' v) F').codRestrict
+    w.toValuationSubring.toSubring (forall_mem_of_restrict_eq hw)
+
+omit [FiniteDimensional F F'] in
+@[scoped simp]
+theorem coe_toValuationSubringOfRestrictEq (hw : w.restrict F = v)
+    (c : integralClosureAt F' v) :
+    (toValuationSubringOfRestrictEq hw c : F')
+      = algebraMap (integralClosureAt F' v) F' c := rfl
+
+def residueOfCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.ResidueField :=
+  (IsLocalRing.residue w.toValuationSubring).comp (toValuationSubringOfRestrictEq hw)
+
+omit [FiniteDimensional F F'] in
+theorem residueOfCenter_apply (hw : w.restrict F = v) (c : integralClosureAt F' v) :
+    residueOfCenter hw c = IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw c) := rfl
+
+theorem ker_residueOfCenter (hw : w.restrict F = v) :
+    RingHom.ker (residueOfCenter hw) = (fiberCenter F' v hw).asIdeal := by
+  ext c
+  rw [RingHom.mem_ker, residueOfCenter_apply, IsLocalRing.residue_eq_zero_iff]
+  exact Iff.rfl
+
+theorem surjective_residueOfCenter (hw : w.restrict F = v) :
+    Function.Surjective (residueOfCenter hw) := by
+  classical
+  intro y
+  obtain ⟨x, rfl⟩ := IsLocalRing.residue_surjective y
+  have hx : (x : F') ∈ HeightOneSpectrum.valuationSubringAtPrime F' (fiberCenter F' v hw) := by
+    rw [← toValuationSubring_eq_of_restrict_eq hw]
+    exact x.2
+  obtain ⟨a, s, hs, hxas⟩ := hx
+  have hsP : s ∉ (fiberCenter F' v hw).asIdeal := hs
+  have hs0 : s ≠ 0 := fun h => hsP (h ▸ (fiberCenter F' v hw).asIdeal.zero_mem)
+  have hsF : algebraMap (integralClosureAt F' v) F' s ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hs0
+  have hsord : w.ord (algebraMap (integralClosureAt F' v) F' s) = 0 := by
+    have h1 : ¬ 0 < w.ord (algebraMap (integralClosureAt F' v) F' s) := by
+      rw [← mem_fiberCenter_iff_ord_pos hw hs0]
+      exact hsP
+    have h2 : 0 ≤ w.ord (algebraMap (integralClosureAt F' v) F' s) :=
+      w.ord_nonneg_of_mem (forall_mem_of_restrict_eq hw s)
+    omega
+  have hmax : (fiberCenter F' v hw).asIdeal.IsMaximal :=
+    (fiberCenter F' v hw).isPrime.isMaximal (fiberCenter F' v hw).ne_bot
+  obtain ⟨t, i, hi, hti⟩ := hmax.exists_inv hsP
+  have hst : s * t - 1 ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : s * t - 1 = -i := by linear_combination hti
+    rw [h1]
+    exact neg_mem hi
+  refine ⟨a * t, ?_⟩
+  rw [residueOfCenter_apply, ← sub_eq_zero, ← map_sub, IsLocalRing.residue_eq_zero_iff]
+  have hcoe : ((toValuationSubringOfRestrictEq hw (a * t) - x : w.toValuationSubring) : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') := rfl
+  rcases eq_or_ne (toValuationSubringOfRestrictEq hw (a * t) - x) 0 with hzero | hne
+  · rw [hzero]
+    exact (IsLocalRing.maximalIdeal w.toValuationSubring).zero_mem
+  have hcoene : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') ≠ 0 := by
+    intro h
+    exact hne (by rwa [← hcoe, ZeroMemClass.coe_eq_zero] at h)
+  have hfactor : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t * s - a)
+          * (algebraMap (integralClosureAt F' v) F' s)⁻¹ := by
+    rw [hxas, map_sub, map_mul (algebraMap (integralClosureAt F' v) F') (a * t) s,
+      sub_mul, mul_assoc, mul_inv_cancel₀ hsF, mul_one]
+  have hdiffC : a * t * s - a ≠ 0 := by
+    intro h
+    apply hcoene
+    rw [hfactor, h, map_zero, zero_mul]
+  have hdiffP : a * t * s - a ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : a * t * s - a = a * (s * t - 1) := by ring
+    rw [h1]
+    exact Ideal.mul_mem_left _ _ hst
+  have hmem' : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      ∈ w.toValuationSubring := by
+    rw [← hcoe]
+    exact Subtype.coe_prop _
+  rw [show (toValuationSubringOfRestrictEq hw (a * t) - x)
+      = (⟨_, hmem'⟩ : w.toValuationSubring) from Subtype.ext hcoe,
+    w.mem_maximalIdeal_iff_ord_pos hcoene hmem']
+  rw [hfactor, w.ord_mul (by
+      simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hdiffC)
+    (inv_ne_zero hsF), w.ord_inv, hsord, neg_zero, add_zero]
+  exact (mem_fiberCenter_iff_ord_pos hw hdiffC).mp hdiffP
+
+def residueFieldEquivQuotientCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v ⧸ (fiberCenter F' v hw).asIdeal ≃+* w.ResidueField :=
+  (Ideal.quotEquivOfEq (ker_residueOfCenter hw).symm).trans
+    ((residueOfCenter hw).quotientKerEquivOfSurjective (surjective_residueOfCenter hw))
+
+theorem residueFieldEquivQuotientCenter_mk (hw : w.restrict F = v)
+    (c : integralClosureAt F' v) :
+    residueFieldEquivQuotientCenter hw (Ideal.Quotient.mk _ c) = residueOfCenter hw c := by
+  change ((residueOfCenter hw).quotientKerEquivOfSurjective (surjective_residueOfCenter hw))
+    ((Ideal.quotEquivOfEq (ker_residueOfCenter hw).symm) (Ideal.Quotient.mk _ c))
+      = residueOfCenter hw c
+  rw [Ideal.quotEquivOfEq_mk]
+  exact RingHom.quotientKerEquivOfSurjective_apply_mk _ c
+
+def placeCongrEquiv {u u' : Place K F} (h : u = u') :
+    u.toValuationSubring ≃+* u'.toValuationSubring where
+  toFun x := ⟨x.1, h ▸ x.2⟩
+  invFun x := ⟨x.1, h.symm ▸ x.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  map_mul' _ _ := rfl
+  map_add' _ _ := rfl
+
+@[scoped simp]
+theorem coe_placeCongrEquiv {u u' : Place K F} (h : u = u') (x : u.toValuationSubring) :
+    (placeCongrEquiv h x : F) = (x : F) := rfl
+
+def restrictResidueFieldEquiv (hw : w.restrict F = v) :
+    (w.restrict F).ResidueField ≃+* IsLocalRing.ResidueField v.toValuationSubring :=
+  IsLocalRing.ResidueField.mapEquiv (placeCongrEquiv hw)
+
+omit [FiniteDimensional F F'] in
+theorem restrictResidueFieldEquiv_residue (hw : w.restrict F = v)
+    (a : (w.restrict F).toValuationSubring) :
+    restrictResidueFieldEquiv hw (IsLocalRing.residue _ a)
+      = IsLocalRing.residue _ (placeCongrEquiv hw a) := by
+  simp only [restrictResidueFieldEquiv, IsLocalRing.ResidueField.mapEquiv_apply,
+    IsLocalRing.ResidueField.map_residue, RingEquiv.coe_toRingHom]
+
+theorem inertiaDeg_eq_inertiaDeg_fiberCenter (hw : w.restrict F = v) :
+    w.inertiaDeg F =
+      (fiberCenter F' v hw).asIdeal.inertiaDeg v.toValuationSubring := by
+  have := fiberCenter_liesOver hw
+  rw [Ideal.inertiaDeg_eq_of_isMaximal (IsLocalRing.maximalIdeal v.toValuationSubring)
+    (fiberCenter F' v hw).asIdeal]
+  change Module.finrank (w.restrict F).ResidueField w.ResidueField = _
+  refine Algebra.finrank_eq_of_equiv_equiv (restrictResidueFieldEquiv hw)
+    (residueFieldEquivQuotientCenter hw).symm ?_
+  ext a
+  obtain ⟨a, rfl⟩ := IsLocalRing.residue_surjective a
+  simp only [RingHom.coe_comp, Function.comp_apply, RingEquiv.toRingHom_eq_coe,
+    RingHom.coe_coe]
+  apply (residueFieldEquivQuotientCenter hw).injective
+  rw [RingEquiv.apply_symm_apply]
+  change IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw
+        (algebraMap v.toValuationSubring (integralClosureAt F' v) (placeCongrEquiv hw a)))
+    = IsLocalRing.residue w.toValuationSubring (restrictInclusion F w a)
+  refine congrArg _ (Subtype.ext ?_)
+  change algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) (placeCongrEquiv hw a))
+    = algebraMap F F' (a : F)
+  rw [← IsScalarTower.algebraMap_apply,
+    IsScalarTower.algebraMap_apply v.toValuationSubring F F']
+  rfl
+
+end ResidueDictionary
+
+section Bijection
+
+variable {v : Place K F}
+
+def placeOfPrime (P : HeightOneSpectrum (integralClosureAt F' v)) : Place K F' where
+  toValuationSubring := HeightOneSpectrum.valuationSubringAtPrime F' P
+  algebraMap_mem' := fun a => by
+    rw [HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring,
+      Valuation.mem_valuationSubring_iff]
+    have h1 : algebraMap K F' a = algebraMap (integralClosureAt F' v) F'
+        (algebraMap v.toValuationSubring (integralClosureAt F' v)
+          (algebraMap K v.toValuationSubring a)) := by
+      rw [← IsScalarTower.algebraMap_apply,
+        IsScalarTower.algebraMap_apply v.toValuationSubring F F',
+        ← IsScalarTower.algebraMap_apply K v.toValuationSubring F,
+        ← IsScalarTower.algebraMap_apply K F F']
+    rw [h1]
+    exact P.valuation_le_one _
+  ne_top' := by
+    rw [HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+    simp only [ne_eq, Valuation.valuationSubring_eq_top_iff, not_not]
+    infer_instance
+  isPrincipalIdealRing' := by
+    rw [HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+    exact isPrincipalIdealRing_valuationSubring P
+
+@[scoped simp]
+theorem placeOfPrime_toValuationSubring (P : HeightOneSpectrum (integralClosureAt F' v)) :
+    (placeOfPrime P).toValuationSubring = HeightOneSpectrum.valuationSubringAtPrime F' P :=
+  rfl
+
+theorem restrict_placeOfPrime (P : HeightOneSpectrum (integralClosureAt F' v)) :
+    (placeOfPrime P).restrict F = v := by
+  have hle : v.toValuationSubring ≤ ((placeOfPrime P).restrict F).toValuationSubring := by
+    intro g hg
+    rw [restrict_toValuationSubring, ValuationSubring.mem_comap,
+      placeOfPrime_toValuationSubring,
+      HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring,
+      Valuation.mem_valuationSubring_iff]
+    have h1 : algebraMap F F' g = algebraMap (integralClosureAt F' v) F'
+        (algebraMap v.toValuationSubring (integralClosureAt F' v) ⟨g, hg⟩) := by
+      rw [← IsScalarTower.algebraMap_apply,
+        IsScalarTower.algebraMap_apply v.toValuationSubring F F']
+      rfl
+    rw [h1]
+    exact P.valuation_le_one _
+  exact (Place.ext (ValuationSubring.eq_of_le_of_ne_top _ hle
+    ((placeOfPrime P).restrict F).ne_top')).symm
+
+theorem fiberCenter_placeOfPrime (P : HeightOneSpectrum (integralClosureAt F' v)) :
+    fiberCenter F' v (restrict_placeOfPrime P) = P := by
+  have h1 : HeightOneSpectrum.valuationSubringAtPrime F'
+      (fiberCenter F' v (restrict_placeOfPrime P))
+        = HeightOneSpectrum.valuationSubringAtPrime F' P := by
+    rw [← toValuationSubring_eq_of_restrict_eq (restrict_placeOfPrime P),
+      placeOfPrime_toValuationSubring]
+  refine HeightOneSpectrum.eq_of_valuation_isEquiv_valuation (K := F') ?_
+  rw [Valuation.isEquiv_iff_valuationSubring,
+    ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring,
+    ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring, h1]
+
+theorem eq_of_fiberCenter_eq {w w' : Place K F'} (hw : w.restrict F = v)
+    (hw' : w'.restrict F = v)
+    (h : fiberCenter F' v hw = fiberCenter F' v hw') : w = w' := by
+  refine Place.ext ?_
+  rw [toValuationSubring_eq_of_restrict_eq hw, toValuationSubring_eq_of_restrict_eq hw', h]
+
+end Bijection
+
+section Assembly
+
+variable (v : Place K F)
+
+theorem sum_ramificationIndex_mul_inertiaDeg_infra [HasPrincipalDivisors K F'] :
+    ∑ w ∈ v.fiber F', (w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ)
+      = (Module.finrank F F' : ℤ) := by
+  classical
+  have hkey :
+      ∑ P ∈ IsDedekindDomain.primesOverFinset
+          (IsLocalRing.maximalIdeal v.toValuationSubring) (integralClosureAt F' v),
+        Ideal.ramificationIdx' (IsLocalRing.maximalIdeal v.toValuationSubring) P *
+          Ideal.inertiaDeg P v.toValuationSubring =
+            Module.finrank F F' := by
+    let p := IsLocalRing.maximalIdeal v.toValuationSubring
+    let S := integralClosureAt F' v
+    let e : {P // P ∈ IsDedekindDomain.primesOverFinset p S} ≃ p.primesOver S :=
+      Set.equivOfEq (IsDedekindDomain.coe_primesOverFinset (maximalIdeal_ne_bot v) S)
+    change (∑ P ∈ IsDedekindDomain.primesOverFinset p S,
+      p.ramificationIdx' P * P.inertiaDeg v.toValuationSubring) = Module.finrank F F'
+    calc
+      _ = ∑ P : {P // P ∈ IsDedekindDomain.primesOverFinset p S},
+          p.ramificationIdx' P.1 * P.1.inertiaDeg v.toValuationSubring := by
+            rw [← Finset.sum_attach, Finset.univ_eq_attach]
+      _ = ∑ P : p.primesOver S,
+          P.1.ramificationIdx v.toValuationSubring *
+            P.1.inertiaDeg v.toValuationSubring := by
+            apply Fintype.sum_equiv e
+            intro P
+            have hmem : P.1 ∈ p.primesOver S := (e P).2
+            let : P.1.IsPrime := hmem.1
+            let : P.1.LiesOver p := hmem.2
+            let : P.1.IsMaximal :=
+              (inferInstance : P.1.IsPrime).isMaximal
+                (Ideal.ne_bot_of_mem_primesOver (maximalIdeal_ne_bot v) hmem)
+            change p.ramificationIdx' P.1 * P.1.inertiaDeg v.toValuationSubring =
+              P.1.ramificationIdx v.toValuationSubring *
+                P.1.inertiaDeg v.toValuationSubring
+            rw [Ideal.ramificationIdx'_eq_ramificationIdx p P.1 (maximalIdeal_ne_bot v)]
+      _ = Module.finrank v.toValuationSubring S :=
+        Ideal.sum_ramification_inertia_eq_finrank p S
+      _ = Module.finrank F F' :=
+        IsIntegralClosure.rank v.toValuationSubring F F' S
+  rw [← hkey]
+  push_cast
+  refine Finset.sum_bij
+    (fun w hw => (fiberCenter F' v (Place.mem_fiber.mp hw)).asIdeal) ?_ ?_ ?_ ?_
+  · intro w hw
+    rw [IsDedekindDomain.mem_primesOverFinset_iff (maximalIdeal_ne_bot v)]
+    exact ⟨(fiberCenter F' v (Place.mem_fiber.mp hw)).isPrime,
+      fiberCenter_liesOver (Place.mem_fiber.mp hw)⟩
+  · intro w hw w' hw' h
+    exact eq_of_fiberCenter_eq (Place.mem_fiber.mp hw) (Place.mem_fiber.mp hw')
+      (HeightOneSpectrum.ext h)
+  · intro P hP
+    rw [IsDedekindDomain.mem_primesOverFinset_iff (maximalIdeal_ne_bot v)] at hP
+    obtain ⟨hP1, hP2⟩ := hP
+    have hPne : P ≠ ⊥ := by
+      intro h
+      apply maximalIdeal_ne_bot v
+      have h2 := hP2.over
+      rw [h, Ideal.under_def, Ideal.comap_bot_of_injective _
+        (algebraMap_integralClosureAt_injective v)] at h2
+      exact h2
+    refine ⟨placeOfPrime ⟨P, hP1, hPne⟩,
+      Place.mem_fiber.mpr (restrict_placeOfPrime ⟨P, hP1, hPne⟩), ?_⟩
+    exact congrArg HeightOneSpectrum.asIdeal
+      (fiberCenter_placeOfPrime (⟨P, hP1, hPne⟩ :
+        HeightOneSpectrum (integralClosureAt F' v)))
+  · intro w hw
+    rw [ramificationIndex_eq_ramificationIdx_fiberCenter (Place.mem_fiber.mp hw),
+      inertiaDeg_eq_inertiaDeg_fiberCenter (Place.mem_fiber.mp hw)]
+
+end Assembly
+end Place
+
+scoped instance instSumRamificationInertia {K F F' : Type*} [Field K] [Field F] [Field F']
+    [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+    [FiniteDimensional F F'] [Algebra.IsSeparable F F'] [HasPrincipalDivisors K F'] :
+    SumRamificationInertia K F F' :=
+  ⟨fun v => Place.sum_ramificationIndex_mul_inertiaDeg_infra v⟩
+
+end AlgebraicCurve
+
+section
+
+open IsDedekindDomain WithZero IsLocalRing UniqueFactorizationMonoid
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.restrict_fiber_finite Divisor.pushforward_apply \
+  Divisor.PushforwardNormFormula Place.mem_fiber FundamentalIdentity SumRamificationInertia Place \
+  Place.ext Divisor HasPrincipalDivisors Pic Pic0"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ramificationIndex ramificationIndex_pos restrict \
+  restrict_toValuationSubring ord_restrict restrict_fiber_finite restrictInclusion \
+  restrictResidueMap inertiaDeg fiber mem_fiber ext ResidueField deg adicValuation_coe_eq_one_iff \
+  ord ord_mul ord_inv ord_coe_irreducible ord_zpow ord_unit_smul_zpow \
+  isPrincipalIdealRing_valuationSubring ne_top' algebraMap_mem' toValuationSubring \
+  isPrincipalIdealRing' mk ord_nonneg_of_mem mem_of_ord_nonneg mem_iff_ord_nonneg exists_ord_pos \
+  ord_eq_zero_iff_adicValuation_eq_one"
+p2m_open "AlgebraicCurve.Place"
+
+section DVR
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+theorem ord_coe_eq_of_span_singleton_eq_pow_maximalIdeal {r : v.toValuationSubring} {n : ℕ}
+    (h : Ideal.span {r} = IsLocalRing.maximalIdeal v.toValuationSubring ^ n) :
+    v.ord (r : F) = n := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  rw [hπ.maximalIdeal_eq, Ideal.span_singleton_pow, Ideal.span_singleton_eq_span_singleton] at h
+  obtain ⟨u, hu⟩ := h
+  have hr : r = ((u⁻¹ : v.toValuationSubringˣ) : v.toValuationSubring) * π ^ n := by
+    rw [mul_comm, Units.eq_mul_inv_iff_mul_eq]
+    exact hu
+  have hcoe : (r : F) = (((u⁻¹ : v.toValuationSubringˣ) : v.toValuationSubring) : F)
+      * (π : F) ^ (n : ℤ) := by
+    rw [hr]
+    push_cast
+    rw [zpow_natCast]
+  rw [hcoe, v.ord_unit_smul_zpow u⁻¹ hπ (n : ℤ)]
+
+end DVR
+end Place
+
+attribute [local instance 0] Place.valuationSubringAlgebra
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F'] [CharZero F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ramificationIndex ramificationIndex_pos restrict \
+  restrict_toValuationSubring ord_restrict restrict_fiber_finite restrictInclusion \
+  restrictResidueMap inertiaDeg fiber mem_fiber ext ResidueField deg adicValuation_coe_eq_one_iff \
+  ord ord_mul ord_inv ord_coe_irreducible ord_zpow ord_unit_smul_zpow \
+  isPrincipalIdealRing_valuationSubring ne_top' algebraMap_mem' toValuationSubring \
+  isPrincipalIdealRing' mk ord_nonneg_of_mem mem_of_ord_nonneg mem_iff_ord_nonneg exists_ord_pos \
+  ord_eq_zero_iff_adicValuation_eq_one"
+p2m_open "AlgebraicCurve.Place"
+
+scoped instance (v : Place K F) : CharZero v.toValuationSubring :=
+  ⟨fun a b hab => Nat.cast_injective (R := F)
+    (by simpa using congrArg (Subtype.val : v.toValuationSubring → F) hab)⟩
+
+section IdealNorm
+
+variable {v : Place K F} {w : Place K F'}
+
+theorem relNorm_fiberCenter (hw : w.restrict F = v) :
+    Ideal.relNorm v.toValuationSubring (fiberCenter F' v hw).asIdeal
+      = IsLocalRing.maximalIdeal v.toValuationSubring ^ w.inertiaDeg F := by
+  have : (fiberCenter F' v hw).asIdeal.IsMaximal :=
+    (fiberCenter F' v hw).isPrime.isMaximal (fiberCenter F' v hw).ne_bot
+  have : (fiberCenter F' v hw).asIdeal.LiesOver
+      (IsLocalRing.maximalIdeal v.toValuationSubring) := fiberCenter_liesOver hw
+  rw [Ideal.relNorm_eq_pow_of_isMaximal (fiberCenter F' v hw).asIdeal
+    (IsLocalRing.maximalIdeal v.toValuationSubring), inertiaDeg_eq_inertiaDeg_fiberCenter hw]
+
+omit [CharZero F] in
+theorem count_normalizedFactors_span_singleton
+    (hw : w.restrict F = v) {c : integralClosureAt F' v} (hc : c ≠ 0) :
+    (normalizedFactors (Ideal.span {c})).count (fiberCenter F' v hw).asIdeal
+      = (w.ord (algebraMap (integralClosureAt F' v) F' c)).toNat := by
+  have : (fiberCenter F' v hw).asIdeal.IsPrime := (fiberCenter F' v hw).isPrime
+  have hord0 : 0 ≤ w.ord (algebraMap (integralClosureAt F' v) F' c) :=
+    w.ord_nonneg_of_mem (forall_mem_of_restrict_eq hw c)
+  refine Ideal.count_normalizedFactors_eq (p := (fiberCenter F' v hw).asIdeal)
+    (x := Ideal.span {c})
+    (n := (w.ord (algebraMap (integralClosureAt F' v) F' c)).toNat) ?_ ?_
+  · rw [Ideal.span_singleton_le_iff_mem, ← le_ord_iff_mem_pow_fiberCenter hw hc]
+    omega
+  · rw [Ideal.span_singleton_le_iff_mem, ← le_ord_iff_mem_pow_fiberCenter hw hc]
+    push_cast
+    omega
+
+theorem relNorm_span_singleton [HasPrincipalDivisors K F'] {c : integralClosureAt F' v}
+    (hc : c ≠ 0) :
+    Ideal.relNorm v.toValuationSubring (Ideal.span {c})
+      = IsLocalRing.maximalIdeal v.toValuationSubring
+          ^ (∑ w ∈ v.fiber F',
+              w.inertiaDeg F * (w.ord (algebraMap (integralClosureAt F' v) F' c)).toNat) := by
+  have hspan : (Ideal.span {c} : Ideal (integralClosureAt F' v)) ≠ ⊥ := by simpa using hc
+  set S : Multiset (Ideal (integralClosureAt F' v)) := normalizedFactors (Ideal.span {c})
+    with hS
+  have hfactor : ∀ Q ∈ S.toFinset, ∃ w' : Place K F', ∃ hw' : w'.restrict F = v,
+      (fiberCenter F' v hw').asIdeal = Q := by
+    intro Q hQ
+    rw [Multiset.mem_toFinset] at hQ
+    have hQprime : Prime Q := prime_of_normalized_factor Q hQ
+    have hQbot : Q ≠ ⊥ := hQprime.ne_zero
+    have : Q.IsPrime := Ideal.isPrime_of_prime hQprime
+    exact ⟨placeOfPrime ⟨Q, inferInstance, hQbot⟩, restrict_placeOfPrime _,
+      congrArg HeightOneSpectrum.asIdeal (fiberCenter_placeOfPrime
+        (⟨Q, inferInstance, hQbot⟩ : HeightOneSpectrum (integralClosureAt F' v)))⟩
+  set T : Finset (Ideal (integralClosureAt F' v)) := (v.fiber F').attach.image
+    (fun w' => (fiberCenter F' v (mem_fiber.mp w'.2)).asIdeal) with hT
+  have hsub : S.toFinset ⊆ T := by
+    intro Q hQ
+    obtain ⟨w', hw', rfl⟩ := hfactor Q hQ
+    exact Finset.mem_image.mpr ⟨⟨w', mem_fiber.mpr hw'⟩, Finset.mem_attach _ _, rfl⟩
+  have hinj : Set.InjOn (fun w' : {x // x ∈ v.fiber F'} =>
+      (fiberCenter F' v (mem_fiber.mp w'.2)).asIdeal) (v.fiber F').attach := by
+    intro w₁ _ w₂ _ h
+    exact Subtype.ext (eq_of_fiberCenter_eq (mem_fiber.mp w₁.2) (mem_fiber.mp w₂.2)
+      (HeightOneSpectrum.ext h))
+  calc
+    Ideal.relNorm v.toValuationSubring (Ideal.span {c})
+        = Ideal.relNorm v.toValuationSubring (∏ Q ∈ S.toFinset, Q ^ S.count Q) := by
+          rw [← Finset.prod_multiset_count, hS, Ideal.prod_normalizedFactors_eq_self hspan]
+    _ = ∏ Q ∈ S.toFinset, Ideal.relNorm v.toValuationSubring Q ^ S.count Q := by
+          rw [map_prod]
+          exact Finset.prod_congr rfl fun Q _ => map_pow _ Q _
+    _ = ∏ Q ∈ S.toFinset, IsLocalRing.maximalIdeal v.toValuationSubring
+          ^ (Q.inertiaDeg v.toValuationSubring * S.count Q) := by
+          refine Finset.prod_congr rfl fun Q hQ => ?_
+          obtain ⟨w', hw', rfl⟩ := hfactor Q hQ
+          rw [relNorm_fiberCenter hw', ← pow_mul, inertiaDeg_eq_inertiaDeg_fiberCenter hw']
+    _ = IsLocalRing.maximalIdeal v.toValuationSubring
+          ^ (∑ Q ∈ S.toFinset,
+              Q.inertiaDeg v.toValuationSubring * S.count Q) :=
+          Finset.prod_pow_eq_pow_sum S.toFinset
+            (fun Q => Q.inertiaDeg v.toValuationSubring * S.count Q)
+            (IsLocalRing.maximalIdeal v.toValuationSubring)
+    _ = IsLocalRing.maximalIdeal v.toValuationSubring
+          ^ (∑ w ∈ v.fiber F',
+              w.inertiaDeg F * (w.ord (algebraMap (integralClosureAt F' v) F' c)).toNat) := by
+          congr 1
+          calc
+            ∑ Q ∈ S.toFinset,
+                Q.inertiaDeg v.toValuationSubring * S.count Q
+                = ∑ Q ∈ T,
+                    Q.inertiaDeg v.toValuationSubring * S.count Q := by
+                  refine Finset.sum_subset hsub fun Q _ hQ => ?_
+                  rw [Multiset.count_eq_zero_of_notMem
+                    (fun h => hQ (Multiset.mem_toFinset.mpr h)), mul_zero]
+            _ = ∑ w' ∈ (v.fiber F').attach,
+                  (fiberCenter F' v (mem_fiber.mp w'.2)).asIdeal.inertiaDeg
+                      v.toValuationSubring
+                    * S.count (fiberCenter F' v (mem_fiber.mp w'.2)).asIdeal := by
+                  rw [hT, Finset.sum_image hinj]
+            _ = ∑ w' ∈ (v.fiber F').attach, (w'.1.inertiaDeg F
+                  * (w'.1.ord (algebraMap (integralClosureAt F' v) F' c)).toNat) := by
+                  refine Finset.sum_congr rfl fun w' _ => ?_
+                  rw [← inertiaDeg_eq_inertiaDeg_fiberCenter (mem_fiber.mp w'.2),
+                    count_normalizedFactors_span_singleton (mem_fiber.mp w'.2) hc]
+            _ = ∑ w ∈ v.fiber F',
+                  w.inertiaDeg F
+                    * (w.ord (algebraMap (integralClosureAt F' v) F' c)).toNat :=
+                  Finset.sum_attach (v.fiber F') fun w =>
+                    w.inertiaDeg F * (w.ord (algebraMap (integralClosureAt F' v) F' c)).toNat
+
+end IdealNorm
+
+section ElementNorm
+
+variable (v : Place K F)
+
+theorem ord_norm_algebraMap_integralClosureAt [HasPrincipalDivisors K F']
+    {c : integralClosureAt F' v} (hc : c ≠ 0) :
+    v.ord (Algebra.norm F (algebraMap (integralClosureAt F' v) F' c))
+      = ∑ w ∈ v.fiber F', (w.inertiaDeg F : ℤ)
+          * w.ord (algebraMap (integralClosureAt F' v) F' c) := by
+  rw [← Algebra.algebraMap_intNorm (A := v.toValuationSubring) (K := F) (L := F')
+    (B := integralClosureAt F' v)]
+  have hrel := relNorm_span_singleton (v := v) hc
+  rw [Ideal.relNorm_singleton] at hrel
+  rw [ValuationSubring.algebraMap_apply, ord_coe_eq_of_span_singleton_eq_pow_maximalIdeal v hrel]
+  push_cast
+  refine Finset.sum_congr rfl fun w hw => ?_
+  rw [Int.toNat_of_nonneg
+    (w.ord_nonneg_of_mem (forall_mem_of_restrict_eq (mem_fiber.mp hw) c))]
+
+theorem ord_norm_eq_sum_fiber [HasPrincipalDivisors K F'] {f : F'} (hf : f ≠ 0) :
+    v.ord (Algebra.norm F f) = ∑ w ∈ v.fiber F', (w.inertiaDeg F : ℤ) * w.ord f := by
+  obtain ⟨⟨c, s⟩, hcs⟩ := IsLocalization.surj
+    (nonZeroDivisors (integralClosureAt F' v)) f
+  have hs0 : (s : integralClosureAt F' v) ≠ 0 := nonZeroDivisors.coe_ne_zero s
+  have hsF : algebraMap (integralClosureAt F' v) F' (s : integralClosureAt F' v) ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective (integralClosureAt F' v) F')).mpr hs0
+  have hcF : algebraMap (integralClosureAt F' v) F' c ≠ 0 := by
+    rw [← hcs]
+    exact mul_ne_zero hf hsF
+  have hc0 : c ≠ 0 := fun h => hcF (by rw [h, map_zero])
+  have hintc := ord_norm_algebraMap_integralClosureAt v hc0
+  have hints := ord_norm_algebraMap_integralClosureAt v hs0
+  rw [← hcs, map_mul, v.ord_mul (Algebra.norm_ne_zero_iff.mpr hf)
+    (Algebra.norm_ne_zero_iff.mpr hsF), hints] at hintc
+  have hsplit : ∑ w ∈ v.fiber F', (w.inertiaDeg F : ℤ)
+      * w.ord (f * algebraMap (integralClosureAt F' v) F' (s : integralClosureAt F' v))
+        = (∑ w ∈ v.fiber F', (w.inertiaDeg F : ℤ) * w.ord f)
+          + ∑ w ∈ v.fiber F', (w.inertiaDeg F : ℤ)
+              * w.ord (algebraMap (integralClosureAt F' v) F' (s : integralClosureAt F' v)) := by
+    rw [← Finset.sum_add_distrib]
+    refine Finset.sum_congr rfl fun w _ => ?_
+    rw [w.ord_mul hf hsF]
+    ring
+  rw [hsplit] at hintc
+  omega
+
+end ElementNorm
+end Place
+
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "pushforward degree_pushforward pushforward_apply \
+  PushforwardNormFormula pushforward_eq_of_normFormula isPrincipal_pushforward_of_normFormula \
+  degree IsPrincipal principal smul_def"
+p2m_open "AlgebraicCurve.Divisor"
+
+theorem pushforwardNormFormula_infra [HasPrincipalDivisors K F'] :
+    Divisor.PushforwardNormFormula K F F' := by
+  intro f hf D hD v
+  classical
+  rw [Divisor.pushforward_apply, Place.ord_norm_eq_sum_fiber v hf]
+  calc
+    ∑ w ∈ D.support, (if w.restrict F = v then D w * (w.inertiaDeg F : ℤ) else 0)
+        = ∑ w ∈ D.support ∪ v.fiber F',
+            (if w.restrict F = v then D w * (w.inertiaDeg F : ℤ) else 0) := by
+          refine Finset.sum_subset Finset.subset_union_left fun w _ hw => ?_
+          rw [Finsupp.notMem_support_iff.mp hw, zero_mul, ite_self]
+    _ = ∑ w ∈ v.fiber F', (if w.restrict F = v then D w * (w.inertiaDeg F : ℤ) else 0) := by
+          refine (Finset.sum_subset Finset.subset_union_right fun w _ hw => ?_).symm
+          rw [ite_eq_right fun h => hw (Place.mem_fiber.mpr h)]
+    _ = ∑ w ∈ v.fiber F', (w.inertiaDeg F : ℤ) * w.ord f := by
+          refine Finset.sum_congr rfl fun w hw => ?_
+          rw [ite_eq_left (Place.mem_fiber.mp hw), hD w, mul_comm]
+
+variable (F) in
+theorem pushforward_div [HasPrincipalDivisors K F'] {f : F'} (hf : f ≠ 0)
+    {D : Divisor K F'} (hD : ∀ w, D w = w.ord f)
+    {E : Divisor K F} (hE : ∀ v, E v = v.ord (Algebra.norm F f)) :
+    pushforward F D = E :=
+  pushforward_eq_of_normFormula pushforwardNormFormula_infra hf hD hE
+
+variable (F) in
+theorem isPrincipal_pushforward_infra [HasPrincipalDivisors K F'] {D : Divisor K F'}
+    (hD : IsPrincipal D) : IsPrincipal (pushforward F D) :=
+  isPrincipal_pushforward_of_normFormula pushforwardNormFormula_infra hD
+
+end Divisor
+end AlgebraicCurve
+
+theorem solution {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+    [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+    [CharZero F] [HasPrincipalDivisors K F'] :
+    Divisor.PushforwardNormFormula K F F' :=
+  AlgebraicCurve.Divisor.pushforwardNormFormula_infra
+
+end
+end
+end
+end S_AlgebraicCurve_Divisor_pushforwardNormFormula
+end P2MW
+export P2MW.S_AlgebraicCurve_Divisor_pushforwardNormFormula (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Divisor.pushforwardNormFormula {K F F' : Type*} [Field K] [Field F]
+    [Field F'] [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+    [FiniteDimensional F F'] [Algebra.IsSeparable F F'] [CharZero F] [HasPrincipalDivisors K F'] :
+    Divisor.PushforwardNormFormula K F F' :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_IsCurveOver_exists_separating_transcendental.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_IsCurveOver_exists_separating_transcendental.lean
new file mode 100644
index 0000000000..b8f551d5c5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_IsCurveOver_exists_separating_transcendental.lean
@@ -0,0 +1,278 @@
+/-
+Based on Prove2Me node AlgebraicCurve.IsCurveOver.exists_separating_transcendental
+(532c00b1-0629-5b3f-9739-d3d27cbcbf36) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f6204aaa-e070-50ce-9afd-cc4c321cff10
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import Mathlib.Algebra.Lie.OfAssociative
+import Mathlib.FieldTheory.SeparablyGenerated
+import Mathlib.RingTheory.Etale.Field
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of a separating transcendental element on a curve
+
+Theorem statement: `AlgebraicCurve.IsCurveOver.exists_separating_transcendental`
+(`532c00b1-0629-5b3f-9739-d3d27cbcbf36`), by Claude, 2026-09-05.
+
+Proof: submission `f6204aaa-e070-50ce-9afd-cc4c321cff10`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, $K$ perfect, and $F$ essentially of finite type
+over $K$, and assume $F$ is a curve over $K$ in the sense of the predicate `IsCurveOver`: namely (i)
+$F/K$ has principal divisors, in that for every $f \in F$ with $f \neq 0$ there is a divisor $D$ on
+$F/K$ with $D(v) = \operatorname{ord}_v(f)$ at every place $v$ and $\deg D = 0$, where a place is a
+valuation subring of $F$ containing the image of $K$, distinct from $F$ itself, and a principal
+ideal ring; (ii) for every such place $v$ the residue field of the corresponding valuation subring
+is a finite $K$-module; and (iii) the module of Kähler differentials $\Omega_{F/K}$ is free of rank
+one over $F$. Then there exists $t \in F$ which is transcendental over $K$ and such that $F$ is
+finite-dimensional over the intermediate field $K\langle t\rangle$ generated by $t$ and is separable
+over $K\langle t\rangle$; that is, $F/K(t)$ is a finite separable extension.
+
+This is the existence of a separating element (equivalently, a separating transcendence basis of
+size one) for a curve over a perfect field, the direction of the standard characterisation of
+algebraic function fields in one variable that produces a rational subfield $K(t)$ over which $F$ is
+finite separable. It supplies the $K(t)$-tower presentation used throughout the development, and is
+invoked by the results on divisors, genus, residues and component charts built on `IsCurveOver`.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_IsCurveOver_exists_separating_transcendental.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_IsCurveOver_exists_separating_transcendental
+
+noncomputable section
+
+open KaehlerDifferential Algebra IntermediateField
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver IsCurveOver.finrank_kaehler"
+p2m_open "AlgebraicCurve"
+
+namespace IsCurveOver
+p2m_export "AlgebraicCurve.IsCurveOver" "finrank_kaehler instNontrivialKaehler"
+p2m_open "AlgebraicCurve.IsCurveOver"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem not_isSeparable [IsCurveOver K F] : ¬ Algebra.IsSeparable K F := by
+  intro hsep
+  have : Algebra.FormallyUnramified K F := Algebra.FormallyUnramified.of_isSeparable K F
+  exact false_of_nontrivial_of_subsingleton Ω[F⁄K]
+
+theorem not_isAlgebraic [PerfectField K] [IsCurveOver K F] :
+    ¬ Algebra.IsAlgebraic K F := by
+  intro halg
+  exact not_isSeparable (K := K) (F := F) Algebra.IsAlgebraic.isSeparable_of_perfectField
+
+scoped instance instTranscendental [PerfectField K] [IsCurveOver K F] :
+    Algebra.Transcendental K F :=
+  Algebra.transcendental_iff_not_isAlgebraic.mpr not_isAlgebraic
+
+theorem exists_transcendental [PerfectField K] [IsCurveOver K F] :
+    ∃ t : F, Transcendental K t :=
+  Algebra.Transcendental.transcendental
+
+theorem trdeg_pos [PerfectField K] [IsCurveOver K F] :
+    0 < Algebra.trdeg K F :=
+  _root_.trdeg_pos K F
+
+theorem trdeg_ne_zero [PerfectField K] [IsCurveOver K F] :
+    Algebra.trdeg K F ≠ 0 :=
+  trdeg_pos.ne'
+
+theorem one_le_trdeg [PerfectField K] [IsCurveOver K F] :
+    1 ≤ Algebra.trdeg K F :=
+  Cardinal.one_le_iff_pos.mpr trdeg_pos
+
+end IsCurveOver
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace IsCurveOver
+p2m_export "AlgebraicCurve.IsCurveOver" "finrank_kaehler instNontrivialKaehler"
+end IsCurveOver
+p2m_open_scoped "AlgebraicCurve.IsCurveOver" in
+theorem IsCurveOver.trdeg_eq_one [PerfectField K] [IsCurveOver K F]
+    (htrdeg : Algebra.trdeg K F ≤ 1) :
+    Algebra.trdeg K F = 1 :=
+  le_antisymm htrdeg IsCurveOver.one_le_trdeg
+
+end AlgebraicCurve
+
+section
+
+p2m_open "KaehlerDifferential IntermediateField TensorProduct Algebra.TensorProduct Module"
+open scoped IntermediateField.algebraAdjoinAdjoin
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver IsCurveOver.finrank_kaehler"
+p2m_open "AlgebraicCurve"
+
+universe u₁ u₂
+
+variable {K : Type u₁} {F : Type u₂} [Field K] [Field F] [Algebra K F]
+
+variable {ι : Type*} {v : ι → F}
+
+def kaehlerAdjoinBasis (hv : AlgebraicIndependent K v) :
+    Basis ι (IntermediateField.adjoin K (Set.range v))
+      Ω[(IntermediateField.adjoin K (Set.range v))⁄K] := by
+  let Kv : IntermediateField K F := IntermediateField.adjoin K (Set.range v)
+  letI : Algebra (MvPolynomial ι K) Kv :=
+    ((algebraMap (Algebra.adjoin K (Set.range v)) Kv).comp
+      (hv.aevalEquiv : MvPolynomial ι K →+* Algebra.adjoin K (Set.range v))).toAlgebra
+  haveI : IsScalarTower K (MvPolynomial ι K) Kv :=
+    IsScalarTower.of_algebraMap_eq fun a => by
+      change algebraMap K Kv a
+        = algebraMap (Algebra.adjoin K (Set.range v)) Kv (hv.aevalEquiv (algebraMap K _ a))
+      rw [AlgEquiv.commutes]; rfl
+  haveI : IsFractionRing (MvPolynomial ι K) Kv :=
+    IsFractionRing.of_ringEquiv_left hv.aevalEquiv.toRingEquiv (fun _ => rfl)
+  haveI : Algebra.FormallyEtale (MvPolynomial ι K) Kv :=
+    Algebra.FormallyEtale.of_isLocalization (nonZeroDivisors (MvPolynomial ι K))
+  exact ((KaehlerDifferential.mvPolynomialBasis K ι).baseChange Kv).map
+    (KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale K (MvPolynomial ι K) Kv)
+
+def kaehlerOfSeparatingTranscendentalBasis (hv : AlgebraicIndependent K v)
+    [Algebra.IsSeparable (IntermediateField.adjoin K (Set.range v)) F] : Basis ι F Ω[F⁄K] :=
+  haveI : Algebra.FormallyEtale (IntermediateField.adjoin K (Set.range v)) F :=
+    Algebra.FormallyEtale.of_isSeparable _ _
+  ((kaehlerAdjoinBasis hv).baseChange F).map
+    (KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale K
+      (IntermediateField.adjoin K (Set.range v)) F)
+
+theorem finrank_kaehler_eq_card_of_separating {s : Finset F}
+    (hs : AlgebraicIndependent K ((↑) : s → F))
+    [Algebra.IsSeparable (IntermediateField.adjoin K (Set.range ((↑) : s → F))) F] :
+    Module.finrank F Ω[F⁄K] = s.card := by
+  rw [Module.finrank_eq_card_basis (kaehlerOfSeparatingTranscendentalBasis hs),
+    Fintype.card_coe]
+
+theorem finrank_kaehler_eq_card_of_separating' {s : Finset F}
+    (hs : AlgebraicIndependent K ((↑) : s → F))
+    [hsep : Algebra.IsSeparable (IntermediateField.adjoin K (s : Set F)) F] :
+    Module.finrank F Ω[F⁄K] = s.card := by
+  have heq : IntermediateField.adjoin K (s : Set F)
+      = IntermediateField.adjoin K (Set.range ((↑) : s → F)) := by
+    rw [Subtype.range_coe]
+  let e : (IntermediateField.adjoin K (s : Set F)) ≃ₐ[K]
+      (IntermediateField.adjoin K (Set.range ((↑) : s → F))) :=
+    IntermediateField.equivOfEq heq
+  have : Algebra.IsSeparable (IntermediateField.adjoin K (Set.range ((↑) : s → F))) F :=
+    Algebra.IsSeparable.of_equiv_equiv e.toRingEquiv (RingEquiv.refl F)
+      (RingHom.ext fun x => rfl)
+  exact finrank_kaehler_eq_card_of_separating hs
+
+namespace IsCurveOver
+p2m_export "AlgebraicCurve.IsCurveOver" "finrank_kaehler instNontrivialKaehler"
+p2m_open "AlgebraicCurve.IsCurveOver"
+
+theorem trdeg_le_one [PerfectField K] [Algebra.EssFiniteType K F] [IsCurveOver K F] :
+    Algebra.trdeg K F ≤ 1 := by
+  obtain ⟨s, hs, hsep⟩ := exists_isTranscendenceBasis_and_isSeparable_of_perfectField K F
+  have := hsep
+  have hcard : s.card = 1 := by
+    rw [← finrank_kaehler_eq_card_of_separating' hs.1, IsCurveOver.finrank_kaehler]
+  have htr := hs.cardinalMk_eq_trdeg
+  rw [Cardinal.mk_coe_finset, hcard, Nat.cast_one] at htr
+  exact htr.symm.le
+
+theorem trdeg_eq_one_of_perfectField [PerfectField K] [Algebra.EssFiniteType K F]
+    [IsCurveOver K F] : Algebra.trdeg K F = 1 :=
+  IsCurveOver.trdeg_eq_one trdeg_le_one
+
+end IsCurveOver
+end AlgebraicCurve
+
+p2m_open "IntermediateField Algebra TensorProduct.Algebra Algebra.TensorProduct.Algebra"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver IsCurveOver.finrank_kaehler"
+p2m_open "AlgebraicCurve"
+
+universe u₁ u₂
+
+variable {K : Type u₁} {F : Type u₂} [Field K] [Field F] [Algebra K F]
+
+namespace IsCurveOver
+p2m_export "AlgebraicCurve.IsCurveOver" "finrank_kaehler instNontrivialKaehler"
+p2m_open "AlgebraicCurve.IsCurveOver"
+
+theorem exists_separating_transcendental_s6 [PerfectField K] [Algebra.EssFiniteType K F]
+    [IsCurveOver K F] :
+    ∃ t : F, Transcendental K t ∧ FiniteDimensional K⟮t⟯ F ∧ Algebra.IsSeparable K⟮t⟯ F := by
+  obtain ⟨s, hs, hsep⟩ := exists_isTranscendenceBasis_and_isSeparable_of_perfectField K F
+  have hcard : s.card = 1 := by
+    have htr := hs.cardinalMk_eq_trdeg
+    rw [Cardinal.mk_coe_finset, IsCurveOver.trdeg_eq_one_of_perfectField] at htr
+    exact_mod_cast htr
+  obtain ⟨t, rfl⟩ := Finset.card_eq_one.mp hcard
+  have htr : Transcendental K t := by
+    have h1 := hs.1
+    rw [show ((↑) : (↑({t} : Finset F)) → F) = fun _ => t from
+      funext fun x => (Finset.mem_singleton.mp x.2).symm ▸ rfl] at h1
+    exact (algebraicIndependent_unique_type_iff (ι := (↑({t} : Finset F)))).mp h1
+  have heq : IntermediateField.adjoin K (↑({t} : Finset F) : Set F) = K⟮t⟯ := by
+    rw [Finset.coe_singleton]
+  have hsep' : Algebra.IsSeparable K⟮t⟯ F :=
+    Algebra.IsSeparable.of_equiv_equiv
+      (IntermediateField.equivOfEq heq).toRingEquiv (RingEquiv.refl F)
+      (RingHom.ext fun _ => rfl)
+  have : Algebra.EssFiniteType K⟮t⟯ F := Algebra.EssFiniteType.of_comp K K⟮t⟯ F
+  exact ⟨t, htr, Algebra.finite_of_essFiniteType_of_isAlgebraic, hsep'⟩
+
+end IsCurveOver
+end AlgebraicCurve
+
+open IntermediateField _root_.Algebra _root_.TensorProduct.Algebra
+  _root_.Algebra.TensorProduct.Algebra in
+theorem solution
+    {K : Type*} {F : Type*} [Field K] [Field F] [Algebra K F]
+    [PerfectField K] [Algebra.EssFiniteType K F] [AlgebraicCurve.IsCurveOver K F] :
+    ∃ t : F, Transcendental K t ∧ FiniteDimensional K⟮t⟯ F ∧ Algebra.IsSeparable K⟮t⟯ F :=
+  AlgebraicCurve.IsCurveOver.exists_separating_transcendental_s6
+
+end
+end
+end S_AlgebraicCurve_IsCurveOver_exists_separating_transcendental
+end P2MW
+export P2MW.S_AlgebraicCurve_IsCurveOver_exists_separating_transcendental (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open IntermediateField Algebra
+
+namespace AlgebraicCurve
+namespace IsCurveOver
+theorem exists_separating_transcendental {K : Type*} {F : Type*} [Field K] [Field F] [Algebra K F]
+    [PerfectField K] [Algebra.EssFiniteType K F] [IsCurveOver K F] :
+    ∃ t : F, Transcendental K t ∧ FiniteDimensional K⟮t⟯ F ∧ Algebra.IsSeparable K⟮t⟯ F :=
+  solution
+end IsCurveOver
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Pic0_addOrderOf_mk_dvd_of_isPrincipal.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Pic0_addOrderOf_mk_dvd_of_isPrincipal.lean
new file mode 100644
index 0000000000..5c5e16811e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Pic0_addOrderOf_mk_dvd_of_isPrincipal.lean
@@ -0,0 +1,88 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Pic0.addOrderOf_mk_dvd_of_isPrincipal
+(070fa8d4-06f3-50d5-8dd3-8f0809acc39f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 42bfde03-b481-59de-a51b-039b903ab0d1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Pic0_nsmul_mk_eq_zero_of_isPrincipal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order of a divisor class divides m when mD is principal
+
+Theorem statement: `AlgebraicCurve.Pic0.addOrderOf_mk_dvd_of_isPrincipal`
+(`070fa8d4-06f3-50d5-8dd3-8f0809acc39f`), by Claude, 2026-09-05.
+
+Proof: submission `42bfde03-b481-59de-a51b-039b903ab0d1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K \subseteq F$ be fields, $F$ a $K$-algebra. A place of $F/K$ is a valuation subring of $F$
+containing the image of $K$, distinct from $F$ itself, and a principal ideal ring; a divisor is a
+finitely supported function from places to $\mathbb{Z}$, its degree is the sum of its values
+weighted by the residue degrees $v.\mathrm{deg}$, and $\mathrm{Divisor.degZero}$ is the subgroup of
+divisors of degree $0$. A divisor $E$ is principal when there is a nonzero $f \in F$ with $E(v) =
+v.\mathrm{ord}(f)$ for every place $v$; the principal divisors form a subgroup, and $\mathrm{Pic0}$
+is the quotient of $\mathrm{Divisor.degZero}$ by the intersection of that subgroup with the
+degree-zero divisors, with $\mathrm{Pic0.mk}$ the quotient map. The assertion: given a degree-zero
+divisor $D$ of $F/K$ and a natural number $m$ such that the divisor $m \bullet D$ (the underlying
+divisor of $D$, scaled by $m$) is principal, the additive order of the class $\mathrm{Pic0.mk}\,D$
+divides $m$. Since $\mathrm{addOrderOf}$ is $0$ for elements of infinite additive order, the case $m
+= 0$ carries no information.
+
+This is the standard bookkeeping step converting a function with prescribed divisor into a bound on
+the order of a divisor class: exhibiting $f \in F^{\times}$ with $\mathrm{div}(f) = mD$ shows that
+the order of $[D]$ in $\mathrm{Pic}^0(F/K)$ divides $m$. It is used in the treatment of cuspidal
+divisor classes on modular curves, for instance by
+[`ModularCurve.addOrderOf_cuspidalClass_dvd`](thm.html#ModularCurve.addOrderOf_cuspidalClass_dvd)
+and
+[`ModularCurve.addOrderOf_cuspidalClass_eq_eisensteinNumerator`]
+(thm.html#ModularCurve.addOrderOf_cuspidalClass_eq_eisensteinNumerator).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Pic0_addOrderOf_mk_dvd_of_isPrincipal.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Pic0_addOrderOf_mk_dvd_of_isPrincipal
+
+open AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (D : Divisor.degZero (K := K) (F := F)) (m : ℕ)
+    (hD : Divisor.IsPrincipal (m • (D : Divisor K F))) :
+    addOrderOf (Pic0.mk D) ∣ m :=
+  addOrderOf_dvd_of_nsmul_eq_zero (AlgebraicCurve.Pic0.nsmul_mk_eq_zero_of_isPrincipal D m hD)
+
+end S_AlgebraicCurve_Pic0_addOrderOf_mk_dvd_of_isPrincipal
+end P2MW
+export P2MW.S_AlgebraicCurve_Pic0_addOrderOf_mk_dvd_of_isPrincipal (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Pic0.addOrderOf_mk_dvd_of_isPrincipal {K F : Type*} [Field K] [Field F]
+    [Algebra K F] (D : Divisor.degZero (K := K) (F := F)) (m : ℕ)
+    (hD : Divisor.IsPrincipal (m • (D : Divisor K F))) :
+    addOrderOf (Pic0.mk D) ∣ m :=
+  solution D m hD
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Pic0_mk_eq_zero_iff.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Pic0_mk_eq_zero_iff.lean
new file mode 100644
index 0000000000..e35141424a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Pic0_mk_eq_zero_iff.lean
@@ -0,0 +1,82 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Pic0.mk_eq_zero_iff
+(e5aababf-e83b-5e51-80f1-1b615c3a646e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6476dcac-7276-5898-bc30-14b440ad54b3
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A class in Pic⁰ vanishes iff the divisor is principal
+
+Theorem statement: `AlgebraicCurve.Pic0.mk_eq_zero_iff` (`e5aababf-e83b-5e51-80f1-1b615c3a646e`), by
+Claude, 2026-09-05.
+
+Proof: submission `6476dcac-7276-5898-bc30-14b440ad54b3`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra. Here a place of $F/K$ is a valuation subring of
+$F$ that contains the image of $K$ under the structure map, is not all of $F$, and is a principal
+ideal ring; a divisor is a finitely supported function from places to $\mathbb{Z}$, its degree is
+the sum of its values weighted by the residue degrees $v.\mathrm{deg}$, and `Divisor.degZero` is the
+kernel of the degree homomorphism. A divisor $D$ satisfies `Divisor.IsPrincipal` when there is $f
+\in F$, $f \neq 0$, with $D v = v.\mathrm{ord}\, f$ for every place $v$; such divisors form the
+subgroup `Divisor.principal`. The group $\mathrm{Pic}^0$ is the quotient of `Divisor.degZero` by the
+intersection of `Divisor.principal` with it. The theorem asserts, for every element $D$ of
+`Divisor.degZero`, that the class `Pic0.mk D` is zero in this quotient if and only if the underlying
+divisor of $D$ is principal in the above sense.
+
+This is the basic identification of the kernel of the map from degree-zero divisors to the
+degree-zero divisor class group, and is the entry point for every argument showing that a particular
+class in $\mathrm{Pic}^0$ does or does not vanish. It is used, among other places, in the
+injectivity criteria for the divisorial Weil pairing and in the statement that a class killed by an
+integer has a suitable principal multiple.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Pic0_mk_eq_zero_iff.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Pic0_mk_eq_zero_iff
+
+open AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (D : Divisor.degZero (K := K) (F := F)) :
+    Pic0.mk D = 0 ↔ Divisor.IsPrincipal (D : Divisor K F) := by
+  rw [show Pic0.mk D = QuotientAddGroup.mk D from rfl, QuotientAddGroup.eq_zero_iff,
+    AddSubgroup.mem_addSubgroupOf]
+  exact Divisor.mem_principal
+
+end S_AlgebraicCurve_Pic0_mk_eq_zero_iff
+end P2MW
+export P2MW.S_AlgebraicCurve_Pic0_mk_eq_zero_iff (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Pic0.mk_eq_zero_iff {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (D : Divisor.degZero (K := K) (F := F)) :
+    Pic0.mk D = 0 ↔ Divisor.IsPrincipal (D : Divisor K F) :=
+  solution D
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Pic0_nsmul_mk_eq_zero_of_isPrincipal.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Pic0_nsmul_mk_eq_zero_of_isPrincipal.lean
new file mode 100644
index 0000000000..3e15a5c329
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Pic0_nsmul_mk_eq_zero_of_isPrincipal.lean
@@ -0,0 +1,86 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Pic0.nsmul_mk_eq_zero_of_isPrincipal
+(03382ee5-aa3a-5959-b9ac-481441661d0f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4bfa23e4-6f18-56d4-9f3f-df225cda99ed
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Pic0_zsmul_mk_eq_zero_of_isPrincipal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Natural-number form: mD principal implies m[D]=0
+
+Theorem statement: `AlgebraicCurve.Pic0.nsmul_mk_eq_zero_of_isPrincipal`
+(`03382ee5-aa3a-5959-b9ac-481441661d0f`), by Claude, 2026-09-05.
+
+Proof: submission `4bfa23e4-6f18-56d4-9f3f-df225cda99ed`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra. Here a place of $F/K$ is a valuation subring of
+$F$ which contains the image of $K$ under the structure map, is not all of $F$, and is a principal
+ideal ring; a divisor is a finitely supported function from the places of $F/K$ to $\mathbb{Z}$; the
+degree homomorphism sends a divisor to the sum of its coefficients weighted by the invariant `deg`
+of each place, and `Divisor.degZero` is its kernel; a divisor $E$ is principal when there is a
+nonzero $f \in F$ with $E(v) = v.\mathrm{ord}(f)$ at every place $v$; and $\mathrm{Pic}^0$ is the
+quotient of the degree-zero divisors by the subgroup of those that are principal, with `Pic0.mk` the
+quotient map. The assertion is: for a degree-zero divisor $D$ and a natural number $m$, if the
+divisor $m \cdot D$ (the $m$-fold sum of the underlying divisor of $D$) is principal, then $m \cdot
+\mathrm{mk}(D) = 0$ in $\mathrm{Pic}^0$, where the scalar action is the natural-number one given by
+repeated addition.
+
+This is the routine observation that the class of a degree-zero divisor is killed by any $m$ for
+which $mD$ is principal, recorded with natural-number scalars because the order of an element is
+expressed over $\mathbb{N}$ while divisor coefficients live in $\mathbb{Z}$. It is used to bound the
+order of a divisor class, in
+[`AlgebraicCurve.Pic0.addOrderOf_mk_dvd_of_isPrincipal`]
+(thm.html#AlgebraicCurve.Pic0.addOrderOf_mk_dvd_of_isPrincipal).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Pic0_nsmul_mk_eq_zero_of_isPrincipal.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Pic0_nsmul_mk_eq_zero_of_isPrincipal
+
+open AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (D : Divisor.degZero (K := K) (F := F)) (m : ℕ)
+    (hD : Divisor.IsPrincipal (m • (D : Divisor K F))) :
+    m • Pic0.mk D = 0 := by
+  have h := AlgebraicCurve.Pic0.zsmul_mk_eq_zero_of_isPrincipal D (m : ℤ) (by rwa [natCast_zsmul])
+  rwa [natCast_zsmul] at h
+
+end S_AlgebraicCurve_Pic0_nsmul_mk_eq_zero_of_isPrincipal
+end P2MW
+export P2MW.S_AlgebraicCurve_Pic0_nsmul_mk_eq_zero_of_isPrincipal (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Pic0.nsmul_mk_eq_zero_of_isPrincipal {K F : Type*} [Field K] [Field F]
+    [Algebra K F] (D : Divisor.degZero (K := K) (F := F)) (m : ℕ)
+    (hD : Divisor.IsPrincipal (m • (D : Divisor K F))) :
+    m • Pic0.mk D = 0 :=
+  solution D m hD
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Pic0_zsmul_mk.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Pic0_zsmul_mk.lean
new file mode 100644
index 0000000000..9dc13d8ca4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Pic0_zsmul_mk.lean
@@ -0,0 +1,81 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Pic0.zsmul_mk
+(233f8b8e-9734-5a46-b2fc-b00da497bc2c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 21ca4afd-e7bb-5aca-9a8c-05cb0aa0d9e7
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integer multiples commute with passage to divisor classes
+
+Theorem statement: `AlgebraicCurve.Pic0.zsmul_mk` (`233f8b8e-9734-5a46-b2fc-b00da497bc2c`), by
+Claude, 2026-09-05.
+
+Proof: submission `21ca4afd-e7bb-5aca-9a8c-05cb0aa0d9e7`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, let $m$ be an integer, and let $D$ be an element
+of `Divisor.degZero`, that is, a divisor of degree zero. Here a place of $F$ over $K$ is a valuation
+subring of $F$ that contains the image of $K$ under the structure map, is not all of $F$, and is a
+principal ideal ring; a divisor is a finitely supported function from the set of such places to
+$\mathbb{Z}$; the degree homomorphism sends a divisor to the sum of its coefficients weighted by the
+integer invariant `deg` of the corresponding place, and `Divisor.degZero` is its kernel. The group
+`Pic0` is the quotient of `Divisor.degZero` by the subgroup of those degree-zero divisors that are
+principal, i.e. that satisfy the predicate `IsPrincipal`: there is a nonzero $f \in F$ whose order
+at every place gives the coefficient of the divisor there, and `Pic0.mk` is the associated quotient
+map. The assertion is that $m \cdot \mathrm{mk}(D) = \mathrm{mk}(m \cdot D)$, the scalar
+multiplication on the left being that of the additive group `Pic0` and on the right that of
+`Divisor.degZero`.
+
+This is the routine compatibility of the divisor-class map with integer multiples, used whenever
+orders of divisor classes are computed from explicit multiples of a degree-zero divisor. It is cited
+in the proof that a class is trivial as soon as the corresponding multiple of the divisor is
+principal, and in the determination of the order of the cuspidal class on a modular curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Pic0_zsmul_mk.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Pic0_zsmul_mk
+
+open AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (m : ℤ)
+    (D : Divisor.degZero (K := K) (F := F)) :
+    m • Pic0.mk D = Pic0.mk (m • D) :=
+  (map_zsmul (QuotientAddGroup.mk' _) m D).symm
+
+end S_AlgebraicCurve_Pic0_zsmul_mk
+end P2MW
+export P2MW.S_AlgebraicCurve_Pic0_zsmul_mk (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Pic0.zsmul_mk {K F : Type*} [Field K] [Field F] [Algebra K F] (m : ℤ)
+    (D : Divisor.degZero (K := K) (F := F)) :
+    m • Pic0.mk D = Pic0.mk (m • D) :=
+  solution m D
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Pic0_zsmul_mk_eq_zero_of_isPrincipal.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Pic0_zsmul_mk_eq_zero_of_isPrincipal.lean
new file mode 100644
index 0000000000..e3f19bc3f2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Pic0_zsmul_mk_eq_zero_of_isPrincipal.lean
@@ -0,0 +1,89 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Pic0.zsmul_mk_eq_zero_of_isPrincipal
+(4f0e1d65-7950-5326-8f8f-b48a1d3ca923) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission eabc13e2-9b74-5665-97ad-9dcbaa8230da
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Pic0_mk_eq_zero_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Pic0_zsmul_mk
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Torsion criterion in Pic⁰: mD principal kills m[D]
+
+Theorem statement: `AlgebraicCurve.Pic0.zsmul_mk_eq_zero_of_isPrincipal`
+(`4f0e1d65-7950-5326-8f8f-b48a1d3ca923`), by Claude, 2026-09-05.
+
+Proof: submission `eabc13e2-9b74-5665-97ad-9dcbaa8230da`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra. A place of $F/K$, in the sense used here, is a
+valuation subring of $F$ that contains the image of $K$ under the structure map, is not all of $F$,
+and is a principal ideal ring; a divisor is a finitely supported function from places to
+$\mathbb{Z}$, its degree is $\sum_v D(v)\cdot v.\mathrm{deg}$, and `Divisor.degZero` is the subgroup
+of divisors of degree zero. A divisor $D$ is principal when there is $f \in F$, $f \neq 0$, with
+$D(v) = v.\mathrm{ord}(f)$ for every place $v$; the principal divisors form a subgroup, and `Pic0`
+is the quotient of `Divisor.degZero` by the intersection of that subgroup with `Divisor.degZero`,
+with `Pic0.mk` the quotient map. The assertion is: given a degree-zero divisor $D$ and an integer
+$m$ such that the divisor $m \cdot D$ is principal, i.e. $m \cdot D(v) = v.\mathrm{ord}(f)$ for all
+$v$ for some nonzero $f \in F$, one has $m \cdot \mathrm{Pic0.mk}(D) = 0$ in `Pic0`. Note that $m$
+is an arbitrary integer, not required to be positive, and $D$ is an arbitrary degree-zero divisor.
+
+This is the standard bookkeeping step by which an explicit function with divisor $mD$ exhibits the
+class of $D$ as $m$-torsion in the degree-zero divisor class group — the mechanism behind statements
+such as a modular unit with divisor $m((0)-(\infty))$ annihilating $m$ times the cuspidal class. It
+is used in the integral-form variant
+[`AlgebraicCurve.Pic0.nsmul_mk_eq_zero_of_isPrincipal`]
+(thm.html#AlgebraicCurve.Pic0.nsmul_mk_eq_zero_of_isPrincipal)
+and in the specialization arguments for modular curves that produce classes killed by a given
+integer.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Pic0_zsmul_mk_eq_zero_of_isPrincipal.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Pic0_zsmul_mk_eq_zero_of_isPrincipal
+
+open AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (D : Divisor.degZero (K := K) (F := F)) (m : ℤ)
+    (hD : Divisor.IsPrincipal (m • (D : Divisor K F))) :
+    m • Pic0.mk D = 0 := by
+  rw [AlgebraicCurve.Pic0.zsmul_mk, AlgebraicCurve.Pic0.mk_eq_zero_iff]
+  exact hD
+
+end S_AlgebraicCurve_Pic0_zsmul_mk_eq_zero_of_isPrincipal
+end P2MW
+export P2MW.S_AlgebraicCurve_Pic0_zsmul_mk_eq_zero_of_isPrincipal (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Pic0.zsmul_mk_eq_zero_of_isPrincipal {K F : Type*} [Field K] [Field F]
+    [Algebra K F] (D : Divisor.degZero (K := K) (F := F)) (m : ℤ)
+    (hD : Divisor.IsPrincipal (m • (D : Divisor K F))) :
+    m • Pic0.mk D = 0 :=
+  solution D m hD
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_D_ne_zero_of_ord_eq_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_D_ne_zero_of_ord_eq_one.lean
new file mode 100644
index 0000000000..fa8ee3e34a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_D_ne_zero_of_ord_eq_one.lean
@@ -0,0 +1,83 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.D_ne_zero_of_ord_eq_one
+(fe86f260-e2d6-5e72-9cd3-7282d3522a54) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7f52b57c-5ccf-50e9-adeb-7a6d9a0bcb1b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_isSeparable_adjoin_of_ord_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_KaehlerDifferential_D_ne_zero_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_transcendental_of_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A uniformiser at a place has nonzero differential
+
+Theorem statement: `AlgebraicCurve.Place.D_ne_zero_of_ord_eq_one`
+(`fe86f260-e2d6-5e72-9cd3-7282d3522a54`), by Claude, 2026-09-05.
+
+Proof: submission `7f52b57c-5ccf-50e9-adeb-7a6d9a0bcb1b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a perfect field and $F$ a field equipped with a $K$-algebra structure, and let $x \in F$
+be such that $F$ is algebraic over the intermediate field $K(x) =$ `IntermediateField.adjoin K {x}`.
+Let $v$ be a place of $F$ over $K$ in the sense of this development, that is, a valuation subring of
+$F$ which contains $\operatorname{algebraMap} K F (a)$ for every $a \in K$, is not all of $F$, and
+is a principal ideal ring; for $f \in F$ the integer $\operatorname{ord}_v f$ is defined as $-\log$
+of the value of $f$ under the $\mathbb{Z}^{m0}$-valued adic valuation attached to the height-one
+prime of that valuation subring. Let $t \in F$ satisfy $\operatorname{ord}_v t = 1$, i.e. $t$ is a
+uniformiser at $v$. Then the universal derivation of $t$ in the module of Kähler differentials
+$\Omega_{F/K}$, namely `KaehlerDifferential.D K F t`, is nonzero.
+
+This is the statement that over a perfect constant field a uniformiser at a place of a function
+field of one variable is a separating element, so that its differential does not vanish; it is the
+perfect-field counterpart of the characteristic-zero statement for elements of nonzero order. It is
+used in the construction of residues and pole-order estimates for differentials at a place, and in
+results comparing two differentials at a point of order one.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_D_ne_zero_of_ord_eq_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_D_ne_zero_of_ord_eq_one
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [PerfectField K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {t : F} (ht : v.ord t = 1) :
+    KaehlerDifferential.D K F t ≠ 0 :=
+  haveI := AlgebraicCurve.Place.isSeparable_adjoin_of_ord_eq_one x v ht
+  KaehlerDifferential.D_ne_zero_of_transcendental K t
+    (v.transcendental_of_ord_ne_zero (ht ▸ one_ne_zero))
+
+end S_AlgebraicCurve_Place_D_ne_zero_of_ord_eq_one
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_D_ne_zero_of_ord_eq_one (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.D_ne_zero_of_ord_eq_one {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [PerfectField K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {t : F} (ht : v.ord t = 1) :
+    KaehlerDifferential.D K F t ≠ 0 :=
+  solution x v ht
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_D_ne_zero_of_ord_ne_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_D_ne_zero_of_ord_ne_zero.lean
new file mode 100644
index 0000000000..a708da4987
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_D_ne_zero_of_ord_ne_zero.lean
@@ -0,0 +1,113 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.D_ne_zero_of_ord_ne_zero
+(0c5fd925-9073-5211-9d64-0c4fdf858df4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 927502ae-49f9-5886-a329-55b53d00cd7d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_transcendental_of_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isAlgebraic_adjoin_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_KaehlerDifferential_D_ne_zero_of_transcendental
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# dt≠ 0 for t of nonzero order at a place
+
+Theorem statement: `AlgebraicCurve.Place.D_ne_zero_of_ord_ne_zero`
+(`0c5fd925-9073-5211-9d64-0c4fdf858df4`), by Claude, 2026-09-05.
+
+Proof: submission `927502ae-49f9-5886-a329-55b53d00cd7d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra and $K$ of characteristic zero, and let $x\in F$ be
+an element such that $F$ is algebraic over the intermediate field $K(x)=\,$`IntermediateField.adjoin
+K {x}` (this is imposed as a typeclass hypothesis; $x$ itself is not assumed transcendental, so the
+hypothesis says that $F$ has transcendence degree at most one over $K$). Let $v$ be a place of $F$
+over $K$ in the sense of the project's structure [`AlgebraicCurve.Place K
+F`](def/AlgebraicCurve_DivisorClassGroup.html#L22): a valuation subring of $F$ which contains the
+image of $K$ under the structure map, is not the whole of $F$, and is a principal ideal ring; write
+$v.\mathrm{ord}$ for the associated order function on $F$ supplied by the project. Finally let $t\in
+F$ satisfy $v.\mathrm{ord}\,t\neq 0$ — for instance a uniformiser at $v$, or any element with a zero
+or pole there. The conclusion is that the image of $t$ under the universal derivation,
+$D_{K,F}(t)\in\Omega_{F/K}$ (Mathlib's `KaehlerDifferential.D K F`), is nonzero, i.e. $t$ is a
+separating element of $F/K$.
+
+This is the standard fact that, over a base field of characteristic zero, any element with nonzero
+order at a place of a function field of one variable is separating, so that $dt$ spans the
+one-dimensional space of differentials. It underlies the project's order function on differentials,
+being used for the computation of `ordDiff` of $D$ of a uniformiser and of its behaviour under a
+constant field extension.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_D_ne_zero_of_ord_ne_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_D_ne_zero_of_ord_ne_zero
+
+noncomputable section
+open KaehlerDifferential
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.diffCoeff Place.diffCoeff_smul_D Place.ordDiff_def Place \
+  isAlgebraic_adjoin_of_transcendental"
+namespace FF2R3
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] [CharZero K] (x : F)
+  [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+
+include x in
+private theorem isSeparable_adjoin (v : Place K F) {t : F} (ht : v.ord t ≠ 0) :
+    Algebra.IsSeparable (IntermediateField.adjoin K ({t} : Set F)) F := by
+  have : Algebra.IsAlgebraic (IntermediateField.adjoin K ({t} : Set F)) F :=
+    AlgebraicCurve.isAlgebraic_adjoin_of_transcendental x (v.transcendental_of_ord_ne_zero ht)
+  have : CharZero F := charZero_of_injective_algebraMap (algebraMap K F).injective
+  infer_instance
+
+include x in
+theorem D_ne_zero_of_ord_ne_zero (v : Place K F) {t : F} (ht : v.ord t ≠ 0) : D K F t ≠ 0 :=
+  haveI := isSeparable_adjoin x v ht
+  KaehlerDifferential.D_ne_zero_of_transcendental K t (v.transcendental_of_ord_ne_zero ht)
+
+end AlgebraicCurve.FF2R3
+
+end
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [CharZero K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {t : F} (ht : v.ord t ≠ 0) :
+    KaehlerDifferential.D K F t ≠ 0 :=
+  AlgebraicCurve.FF2R3.D_ne_zero_of_ord_ne_zero x v ht
+
+end S_AlgebraicCurve_Place_D_ne_zero_of_ord_ne_zero
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_D_ne_zero_of_ord_ne_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.D_ne_zero_of_ord_ne_zero {K F : Type*} [Field K] [Field F]
+    [Algebra K F] [CharZero K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {t : F} (ht : v.ord t ≠ 0) :
+    KaehlerDifferential.D K F t ≠ 0 :=
+  solution x v ht
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_adicValuation_isRankOneDiscrete.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_adicValuation_isRankOneDiscrete.lean
new file mode 100644
index 0000000000..147a0715af
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_adicValuation_isRankOneDiscrete.lean
@@ -0,0 +1,88 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.adicValuation_isRankOneDiscrete
+(e61cf2d8-b833-5852-a0ce-1d522102303e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission add10091-f0c0-5cd0-9479-26a5cf193138
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+/-!
+# The adic valuation of a place is rank one discrete
+
+Theorem statement: `AlgebraicCurve.Place.adicValuation_isRankOneDiscrete`
+(`e61cf2d8-b833-5852-a0ce-1d522102303e`), by Claude, 2026-09-05.
+
+Proof: submission `add10091-f0c0-5cd0-9479-26a5cf193138`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+sense of the project's structure `Place K F`: a valuation subring $\mathcal{O}_v \subseteq F$ which
+contains $\operatorname{algebraMap} K F (a)$ for every $a \in K$, which is not all of $F$, and which
+is a principal ideal ring. Since $\mathcal{O}_v$ is then a discrete valuation ring, its maximal
+ideal is a point of the height-one spectrum, and `v.adicValuation` is the associated
+$\mathbb{Z}^{m0}$-valued valuation on $F$ obtained from that height-one prime, i.e. the normalised
+valuation attached to $v$. The assertion is that this valuation satisfies
+`Valuation.IsRankOneDiscrete`: it is a rank one discrete valuation, its value group being nontrivial
+and generated by a single element. The statement is phrased as a theorem about an arbitrary place
+rather than as an instance, so that it can be introduced locally where needed.
+
+This records that the normalised valuation of a place of a function field $F/K$ is discrete of rank
+one, the basic fact underlying the definition of the order function $\operatorname{ord}_v$ and hence
+of divisors and the divisor class group. It is used in the identification of valuation subrings of a
+rational function field with the points of the height-one spectrum, namely in
+(`AlgebraicCurve.RationalFunctionField.toValuationSubring_eq_of_forall_ne_ofHeightOneSpectrum`).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_adicValuation_isRankOneDiscrete.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open IsDedekindDomain WithZero IsLocalRing
+
+noncomputable section
+
+namespace AlgebraicCurve
+open AlgebraicCurve
+
+namespace Place
+open AlgebraicCurve.Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem rowMain : v.adicValuation.IsRankOneDiscrete :=
+  IsDiscreteValuationRing.isRankOneDiscrete v.toValuationSubring F
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) :
+    v.adicValuation.IsRankOneDiscrete :=
+  AlgebraicCurve.Place.rowMain v
+
+end privateSection
+
+public section publicSection
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.adicValuation_isRankOneDiscrete
+    {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) :
+    v.adicValuation.IsRankOneDiscrete :=
+  solution v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_adicValuation_isTrivialOn.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_adicValuation_isTrivialOn.lean
new file mode 100644
index 0000000000..19b6eb77cb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_adicValuation_isTrivialOn.lean
@@ -0,0 +1,124 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.adicValuation_isTrivialOn
+(5ca17c5e-d2aa-5bb0-ad8c-7d8e397d95c6) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7d141da6-77db-5781-be8b-2fb2cd60d7ba
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The adic valuation of a place is trivial on the base field
+
+Theorem statement: `AlgebraicCurve.Place.adicValuation_isTrivialOn`
+(`5ca17c5e-d2aa-5bb0-ad8c-7d8e397d95c6`), by Claude, 2026-09-05.
+
+Proof: submission `7d141da6-77db-5781-be8b-2fb2cd60d7ba`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+sense of the structure [`AlgebraicCurve.Place`](def/AlgebraicCurve_DivisorClassGroup.html#L22): a
+valuation subring $\mathcal{O}_v \subseteq F$ which contains $\mathrm{algebraMap}\,K\,F(a)$ for
+every $a \in K$, which is not the whole of $F$, and whose ideals are all principal (so that
+$\mathcal{O}_v$ is a discrete valuation ring). Attached to $v$ is its height one prime
+[`AlgebraicCurve.Place.heightOneSpectrum`](def/AlgebraicCurve_DivisorClassGroup.html#L95), namely
+the maximal ideal of $\mathcal{O}_v$ viewed as a point of the height one spectrum, and the
+associated $\mathbb{Z}^{m0}$-valued adic valuation
+[`AlgebraicCurve.Place.adicValuation`](def/AlgebraicCurve_DivisorClassGroup.html#L102) on the
+fraction field $F$, i.e. the normalised valuation whose value group is $\mathbb{Z}$ with a zero
+adjoined. The theorem asserts that this valuation satisfies `Valuation.IsTrivialOn K`, that is, it
+is trivial on the image of the base field $K$ in $F$: no element of $K$ has a zero or a pole at $v$.
+
+This is the standard fact, in the language of algebraic function fields, that a place of $F/K$ is a
+place over $K$, so that the base field consists of $v$-units; it records the triviality of $v$ on
+$K$ in a form usable as an instance or hypothesis elsewhere. It is used in the analysis of valuation
+subrings of a rational function field, via
+(`AlgebraicCurve.RationalFunctionField.toValuationSubring_eq_of_forall_ne_ofHeightOneSpectrum`).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_adicValuation_isTrivialOn.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_adicValuation_isTrivialOn
+
+open IsDedekindDomain WithZero IsLocalRing
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext heightOneSpectrum adicValuation algebraMap_mem' \
+  toValuationSubring"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.adicValuation_valuationSubring :
+    v.adicValuation.valuationSubring = v.toValuationSubring := by
+  ext x
+  rw [Valuation.mem_valuationSubring_iff]
+  constructor
+  · intro hx
+    obtain ⟨a, rfl⟩ := IsDiscreteValuationRing.exists_lift_of_le_one hx
+    exact a.2
+  · intro hx
+    exact v.heightOneSpectrum.valuation_le_one (⟨x, hx⟩ : v.toValuationSubring)
+
+p2m_export "AlgebraicCurve.Place" "adicValuation_valuationSubring"
+private theorem _root_.AlgebraicCurve.Place.mem_iff_adicValuation_le_one {f : F} :
+    f ∈ v.toValuationSubring ↔ v.adicValuation f ≤ 1 := by
+  rw [← v.adicValuation_valuationSubring]
+  exact Valuation.mem_valuationSubring_iff _ _
+
+p2m_export "AlgebraicCurve.Place" "mem_iff_adicValuation_le_one"
+private theorem rowMain : v.adicValuation.IsTrivialOn K :=
+  Valuation.IsTrivialOn.of_le_one v.adicValuation fun a =>
+    v.mem_iff_adicValuation_le_one.mp (v.algebraMap_mem' a)
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_Place_adicValuation_isTrivialOn.AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) :
+    v.adicValuation.IsTrivialOn K :=
+  AlgebraicCurve.Place.rowMain v
+
+end S_AlgebraicCurve_Place_adicValuation_isTrivialOn
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_adicValuation_isTrivialOn (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.adicValuation_isTrivialOn {K F : Type*} [Field K] [Field F]
+    [Algebra K F] (v : Place K F) :
+    v.adicValuation.IsTrivialOn K :=
+  solution v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_card_fiberOver_mul_ramificationIndex_mul_inertiaDeg.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_card_fiberOver_mul_ramificationIndex_mul_inertiaDeg.lean
new file mode 100644
index 0000000000..da9084e049
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_card_fiberOver_mul_ramificationIndex_mul_inertiaDeg.lean
@@ -0,0 +1,120 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.card_fiberOver_mul_ramificationIndex_mul_inertiaDeg
+(474213da-7f42-522d-8919-ab513d241802) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 99c84934-8bda-5b5e-92c6-39f6b0579f42
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+public import Mathlib.FieldTheory.Galois.Basic
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ramificationIndex_eq_of_restrict_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_inertiaDeg_eq_of_restrict_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_fiberOver
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The identity r e f=[M:F'] for Galois extensions of places
+
+Theorem statement: `AlgebraicCurve.Place.card_fiberOver_mul_ramificationIndex_mul_inertiaDeg`
+(`474213da-7f42-522d-8919-ab513d241802`), by Claude, 2026-09-05.
+
+Proof: submission `99c84934-8bda-5b5e-92c6-39f6b0579f42`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F'$ and $M$ be fields with $F'$ and $M$ algebras over $K$ and $M$ an algebra over $F'$,
+the three structure maps forming a scalar tower, and assume $M$ is finite-dimensional over $F'$ and
+$M/F'$ is Galois. Let $w$ be a place of $F'$ over $K$, that is, a valuation subring of $F'$
+containing the image of $K$, different from all of $F'$, and a principal ideal ring, and let $W$ be
+such a place of $M$ over $K$ whose restriction to $F'$ — the preimage of its valuation subring under
+the structure map $F'\to M$ — is equal to $w$. Then the cardinality of the fibre of $w$ in $M$, the
+finite set of places of $M$ over $K$ restricting to $w$, multiplied by the product of the
+ramification index of $W$ over $F'$ (the least positive $n$ that is the order of $W$ at the image of
+some nonzero element of $F'$) and the inertia degree of $W$ over $F'$ (the degree of the residue
+field of $W$ over the residue field of its restriction to $F'$), equals $\operatorname{finrank}_{F'}
+M$. Note that the conclusion is an identity of natural numbers, and that it is stated for one
+arbitrary place $W$ above $w$.
+
+This is the fundamental identity $r\,e\,f=[M:F']$ in its Galois form: in a Galois extension the
+ramification index and inertia degree are constant along the fibre, so the general sum formula
+collapses to a product of the fibre size with a single common value $ef$. It is used in the study of
+the action of the Galois group on places, in particular in the computation of pullbacks and
+pushforwards of divisors and of the order of a place under restriction along a Galois extension.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_card_fiberOver_mul_ramificationIndex_mul_inertiaDeg.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_c0635b7f
+
+noncomputable section
+p2m_open "AlgebraicCurve \
+  P2MW.S_OVERLONG_c0635b7f.AlgebraicCurve \
+  IsDedekindDomain"
+open scoped Pointwise
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ramificationIndex_eq_of_restrict_eq \
+  Place.inertiaDeg_eq_of_restrict_eq"
+p2m_open "AlgebraicCurve"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "fiberOver restrict_eq_of_mem_fiberOver ramificationIndex \
+  restrict inertiaDeg ramificationIndex_eq_of_restrict_eq inertiaDeg_eq_of_restrict_eq \
+  sum_ramificationIndex_mul_inertiaDeg_fiberOver"
+end Place
+end AlgebraicCurve
+
+open _root_.AlgebraicCurve.Place
+  _root_.P2MW.S_OVERLONG_c0635b7f.AlgebraicCurve.Place
+  in
+theorem solution {K F' M : Type*} [Field K] [Field F'] [Field M]
+    [Algebra K F'] [Algebra K M] [Algebra F' M] [IsScalarTower K F' M]
+    [FiniteDimensional F' M] [IsGalois F' M] (w : Place K F') (W : Place K M)
+    (hW : W.restrict F' = w) :
+    (w.fiberOver M).card * (W.ramificationIndex F' * W.inertiaDeg F') = Module.finrank F' M := by
+  have hsum := sum_ramificationIndex_mul_inertiaDeg_fiberOver (F' := M) w
+  have hconst : ∀ W' ∈ w.fiberOver M,
+      (W'.ramificationIndex F' : ℤ) * (W'.inertiaDeg F' : ℤ)
+        = (W.ramificationIndex F' : ℤ) * (W.inertiaDeg F' : ℤ) := by
+    intro W' hW'
+    have h : W'.restrict F' = W.restrict F' :=
+      (restrict_eq_of_mem_fiberOver w hW').trans hW.symm
+    rw [Place.ramificationIndex_eq_of_restrict_eq W W' h, Place.inertiaDeg_eq_of_restrict_eq W W' h]
+  rw [Finset.sum_congr rfl hconst, Finset.sum_const, nsmul_eq_mul] at hsum
+  exact_mod_cast hsum
+
+end
+
+end S_OVERLONG_c0635b7f
+end P2MW
+export P2MW.S_OVERLONG_c0635b7f (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.card_fiberOver_mul_ramificationIndex_mul_inertiaDeg {K F' M : Type*}
+    [Field K] [Field F'] [Field M]
+    [Algebra K F'] [Algebra K M] [Algebra F' M] [IsScalarTower K F' M]
+    [FiniteDimensional F' M] [IsGalois F' M] (w : Place K F') (W : Place K M)
+    (hW : W.restrict F' = w) :
+    (w.fiberOver M).card * (W.ramificationIndex F' * W.inertiaDeg F') = Module.finrank F' M :=
+  solution w W hW
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_deg_eq_one_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_deg_eq_one_of_isAlgClosed.lean
new file mode 100644
index 0000000000..c1e7c1c856
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_deg_eq_one_of_isAlgClosed.lean
@@ -0,0 +1,87 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.deg_eq_one_of_isAlgClosed
+(30b3cd0c-85fb-53b0-8fd2-3ee7661282e8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 442ba989-4fc1-562c-83b1-188dec828189
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Places over an algebraically closed field have degree one
+
+Theorem statement: `AlgebraicCurve.Place.deg_eq_one_of_isAlgClosed`
+(`30b3cd0c-85fb-53b0-8fd2-3ee7661282e8`), by Claude, 2026-09-05.
+
+Proof: submission `442ba989-4fc1-562c-83b1-188dec828189`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and suppose $K$ is algebraically closed. Let $v$
+be a place of $F$ over $K$ in the sense of the project, that is, a valuation subring $\mathcal{O}_v
+\subseteq F$ which contains the image of $K$ under the structure map $K \to F$, is not all of $F$,
+and is a principal ideal ring. Write $\kappa(v) = \mathcal{O}_v / \mathfrak{m}_v$ for its residue
+field, a $K$-algebra, and let $v.\mathrm{deg}$ be the $K$-dimension $\operatorname{finrank}_K
+\kappa(v)$, which by Mathlib's convention is $0$ both when $\kappa(v)$ is the zero module and when
+it is infinite-dimensional over $K$. Assume $v.\mathrm{deg} \neq 0$, i.e. $\kappa(v)$ is a nonzero
+finite-dimensional $K$-vector space. The conclusion is that $v.\mathrm{deg} = 1$, i.e. the structure
+map $K \to \kappa(v)$ is an isomorphism. No hypothesis that $F$ is a function field over $K$, nor
+any finiteness or transcendence-degree condition on $F/K$, enters; the only finiteness used is the
+one encoded in $v.\mathrm{deg} \neq 0$.
+
+This is the standard remark that over an algebraically closed constant field every place of residue
+degree defined (i.e. with finite-dimensional residue field) has degree one, so that degrees of
+divisors over $\bar{K}$ are just counts of points. It is used throughout the divisor and
+divisor-class machinery for curves, for instance in the comparison of places under a finite
+extension and in the ramification estimates for Galois covers.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_deg_eq_one_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_deg_eq_one_of_isAlgClosed
+
+open AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [IsAlgClosed K] (v : Place K F)
+    (hv : v.deg ≠ 0) :
+    v.deg = 1 := by
+  have : Module.Finite K v.ResidueField := Module.finite_of_finrank_pos (Nat.pos_of_ne_zero hv)
+  have e : K ≃ₗ[K] v.ResidueField :=
+    LinearEquiv.ofBijective (Algebra.linearMap K v.ResidueField)
+      (IsAlgClosed.algebraMap_bijective_of_isIntegral)
+  unfold Place.deg
+  rw [← e.finrank_eq, Module.finrank_self]
+
+end S_AlgebraicCurve_Place_deg_eq_one_of_isAlgClosed
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_deg_eq_one_of_isAlgClosed (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.deg_eq_one_of_isAlgClosed {K F : Type*} [Field K] [Field F]
+    [Algebra K F] [IsAlgClosed K] (v : Place K F) (hv : v.deg ≠ 0) :
+    v.deg = 1 :=
+  solution v hv
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_deg_ne_zero_of_finiteDimensional_adjoin.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_deg_ne_zero_of_finiteDimensional_adjoin.lean
new file mode 100644
index 0000000000..ef42439e48
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_deg_ne_zero_of_finiteDimensional_adjoin.lean
@@ -0,0 +1,125 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.deg_ne_zero_of_finiteDimensional_adjoin
+(b965f4d0-d894-5026-be6d-4fc55a721bb9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4ea486c7-6c27-515b-8499-c3a84884c166
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_inertiaDeg_pos_of_finiteDimensional
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_ne_zero
+import Mathlib.RingTheory.Algebraic.Basic
+import Mathlib.FieldTheory.RatFunc.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Places of a function field in one variable have nonzero degree
+
+Theorem statement: `AlgebraicCurve.Place.deg_ne_zero_of_finiteDimensional_adjoin`
+(`b965f4d0-d894-5026-be6d-4fc55a721bb9`), by Claude, 2026-09-05.
+
+Proof: submission `4ea486c7-6c27-515b-8499-c3a84884c166`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $x \in F$ be transcendental over $K$, i.e.
+the evaluation map $K[T] \to F$ at $x$ is injective. Assume $F$ is finite-dimensional as a module
+over the intermediate field $K(x) =$ `IntermediateField.adjoin K {x}` of $F/K$. Let $v$ be a place
+of $F$ over $K$ in the sense of this development: a valuation subring $\mathcal{O}_v \subseteq F$
+which contains the image of $K$ under the structure map $K \to F$, is not all of $F$, and is a
+principal ideal ring. Then the degree of $v$, defined as the $K$-dimension $\operatorname{finrank}_K
+\kappa(v)$ of the residue field $\kappa(v) = \mathcal{O}_v/\mathfrak{m}_v$ of the local ring
+$\mathcal{O}_v$, is nonzero. Since Mathlib's `Module.finrank` vanishes on modules that are not
+finite-dimensional, and a field has dimension at least $1$ over a subfield, the assertion is
+equivalent to saying that $\kappa(v)$ is a finite-dimensional $K$-vector space.
+
+This is the classical finiteness of the residue degree of a place of an algebraic function field of
+one variable over its constant field, here in the form that the degree function on places, and hence
+on divisors, never degenerates to $0$. It underlies the divisor-theoretic apparatus of the
+development and is invoked throughout the manipulation of divisors and of function fields of curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_deg_ne_zero_of_finiteDimensional_adjoin.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_deg_ne_zero_of_finiteDimensional_adjoin
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (x : F) (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) : v.deg ≠ 0 := by
+  classical
+  have hinj : Function.Injective (Polynomial.aeval x : Polynomial K →ₐ[K] F) :=
+    transcendental_iff_injective.mp hx
+  let lift : RatFunc K →ₐ[K] F :=
+    RatFunc.liftAlgHom (Polynomial.aeval x) (nonZeroDivisors_le_comap_nonZeroDivisors_of_injective _
+      hinj)
+  have hlift : ∀ p : Polynomial K, lift (algebraMap (Polynomial K) (RatFunc K) p) = Polynomial.aeval
+    x p :=
+    fun p => by
+    have h := RatFunc.liftAlgHom_apply_div (Polynomial.aeval x)
+      (nonZeroDivisors_le_comap_nonZeroDivisors_of_injective _ hinj) p 1
+    rwa [map_one, div_one, map_one, div_one] at h
+  let : Algebra (RatFunc K) F := lift.toRingHom.toAlgebra
+  have : IsScalarTower K (RatFunc K) F :=
+    IsScalarTower.of_algebraMap_eq' (lift.comp_algebraMap).symm
+  have hFD : FiniteDimensional (RatFunc K) F := by
+    obtain ⟨s, hs⟩ :=
+      Module.finite_def.mp ‹FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F›
+    refine ⟨⟨s, ?_⟩⟩
+    rw [eq_top_iff]
+    rintro z -
+    have hz : z ∈ Submodule.span (IntermediateField.adjoin K ({x} : Set F)) (s : Set F) := by
+      rw [hs]; trivial
+    induction hz using Submodule.span_induction with
+    | mem y hy => exact Submodule.subset_span hy
+    | zero => exact Submodule.zero_mem _
+    | add a b _ _ ha hb => exact Submodule.add_mem _ ha hb
+    | smul c y _ hy =>
+        have hrange : IntermediateField.adjoin K ({x} : Set F) ≤ lift.fieldRange := by
+          rw [IntermediateField.adjoin_le_iff]
+          rintro y' rfl
+          exact ⟨algebraMap (Polynomial K) (RatFunc K) Polynomial.X, (hlift _).trans
+            (Polynomial.aeval_X _)⟩
+        obtain ⟨c', hc'⟩ := hrange c.2
+        have hcc : c • y = c' • y := by
+          change (c : F) * y = lift.toRingHom c' * y
+          rw [← hc']
+        rw [hcc]
+        exact Submodule.smul_mem _ c' hy
+  have h1 := AlgebraicCurve.RationalFunctionField.deg_ne_zero (v.restrict (RatFunc K))
+  have h2 := AlgebraicCurve.Place.inertiaDeg_pos_of_finiteDimensional (F := RatFunc K) v
+  rw [← AlgebraicCurve.Place.deg_restrict_mul_inertiaDeg (F := RatFunc K)]
+  exact mul_ne_zero h1 h2.ne'
+
+end S_AlgebraicCurve_Place_deg_ne_zero_of_finiteDimensional_adjoin
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_deg_ne_zero_of_finiteDimensional_adjoin (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.deg_ne_zero_of_finiteDimensional_adjoin {K F : Type*} [Field K]
+    [Field F] [Algebra K F]
+    (x : F) (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) : v.deg ≠ 0 :=
+  solution x hx v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_diffCoeff_smul_D_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_diffCoeff_smul_D_eq.lean
new file mode 100644
index 0000000000..6e378915b5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_diffCoeff_smul_D_eq.lean
@@ -0,0 +1,124 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.diffCoeff_smul_D_eq
+(c96609bb-aa30-5ef8-9162-8ae441a6ce18) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3ff0e943-cca4-5dd1-9ddd-263952b8893d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_transcendental_of_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isAlgebraic_adjoin_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_KaehlerDifferential_D_ne_zero_of_transcendental
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Uniqueness of the coefficient against dt
+
+Theorem statement: `AlgebraicCurve.Place.diffCoeff_smul_D_eq`
+(`c96609bb-aa30-5ef8-9162-8ae441a6ce18`), by Claude, 2026-09-05.
+
+Proof: submission `3ff0e943-cca4-5dd1-9ddd-263952b8893d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $K$ have characteristic zero. Let $x \in
+F$ be an element such that $F$ is algebraic over the intermediate field $K(x) =$
+`IntermediateField.adjoin K {x}` (no transcendence of $x$ itself is assumed). Let $v$ be a place of
+$F$ over $K$ in the sense of the structure
+[`AlgebraicCurve.Place`](def/AlgebraicCurve_DivisorClassGroup.html#L22): a valuation subring of $F$
+containing the image of $K$ under the structure map, different from $F$ itself, and whose underlying
+ring is a principal ideal ring. Write $\operatorname{ord}_v f = -\log\, v_{\mathrm{adic}}(f)$ for
+the associated integer-valued order function, built from the valuation attached to the height-one
+prime of the valuation subring. Let $t \in F$ satisfy $\operatorname{ord}_v t \neq 0$, and let $g
+\in F$ be arbitrary. Then $\mathrm{diffCoeff}\,t\,(g \cdot D_{K/F} t) = g$, where
+$\mathrm{diffCoeff}\,t\,\omega$ is defined to be a chosen $h \in F$ with $\omega = h \cdot D_{K/F}
+t$ when such an $h$ exists and $0$ otherwise, and $D_{K/F}$ is the universal $K$-derivation of $F$
+into the module of Kähler differentials $\Omega[F/K]$.
+
+This is the uniqueness half of the statement that $\Omega[F/K]$ is a one-dimensional $F$-vector
+space with basis $dt$ for any $t$ of nonzero order at a place, in characteristic zero; it makes the
+coefficient extraction $\mathrm{diffCoeff}$ well behaved, and hence the order of a differential at a
+place well defined. It is used in the computation of the order of a differential at $v$, for
+instance in
+[`AlgebraicCurve.Place.ordDiff_D_eq_ord_sub_one`]
+(thm.html#AlgebraicCurve.Place.ordDiff_D_eq_ord_sub_one)
+and [`AlgebraicCurve.Place.ordDiff_D_nonneg`](thm.html#AlgebraicCurve.Place.ordDiff_D_nonneg), and
+in the comparison of regular differentials under extension of the constant field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_diffCoeff_smul_D_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_diffCoeff_smul_D_eq
+
+noncomputable section
+open KaehlerDifferential
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.diffCoeff Place.diffCoeff_smul_D Place.ordDiff_def Place \
+  isAlgebraic_adjoin_of_transcendental"
+namespace FF2R3
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] [CharZero K] (x : F)
+  [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+
+include x in
+private theorem isSeparable_adjoin (v : Place K F) {t : F} (ht : v.ord t ≠ 0) :
+    Algebra.IsSeparable (IntermediateField.adjoin K ({t} : Set F)) F := by
+  have : Algebra.IsAlgebraic (IntermediateField.adjoin K ({t} : Set F)) F :=
+    AlgebraicCurve.isAlgebraic_adjoin_of_transcendental x (v.transcendental_of_ord_ne_zero ht)
+  have : CharZero F := charZero_of_injective_algebraMap (algebraMap K F).injective
+  infer_instance
+
+include x in
+theorem D_ne_zero_of_ord_ne_zero (v : Place K F) {t : F} (ht : v.ord t ≠ 0) : D K F t ≠ 0 :=
+  haveI := isSeparable_adjoin x v ht
+  KaehlerDifferential.D_ne_zero_of_transcendental K t (v.transcendental_of_ord_ne_zero ht)
+
+include x in
+theorem diffCoeff_smul_of_ord_ne_zero (v : Place K F) {t : F} (ht : v.ord t ≠ 0) (g : F) :
+    Place.diffCoeff t (g • D K F t) = g :=
+  smul_left_injective F (D_ne_zero_of_ord_ne_zero x v ht)
+    (Place.diffCoeff_smul_D ⟨g, rfl⟩)
+
+end AlgebraicCurve.FF2R3
+
+end
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [CharZero K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {t : F} (ht : v.ord t ≠ 0) (g : F) :
+    AlgebraicCurve.Place.diffCoeff t (g • KaehlerDifferential.D K F t) = g :=
+  AlgebraicCurve.FF2R3.diffCoeff_smul_of_ord_ne_zero x v ht g
+
+end S_AlgebraicCurve_Place_diffCoeff_smul_D_eq
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_diffCoeff_smul_D_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.diffCoeff_smul_D_eq {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [CharZero K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {t : F} (ht : v.ord t ≠ 0) (g : F) :
+    AlgebraicCurve.Place.diffCoeff t (g • KaehlerDifferential.D K F t) = g :=
+  solution x v ht g
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_diffCoeff_smul_D_eq_of_ord_eq_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_diffCoeff_smul_D_eq_of_ord_eq_one.lean
new file mode 100644
index 0000000000..e96a3432d3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_diffCoeff_smul_D_eq_of_ord_eq_one.lean
@@ -0,0 +1,96 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.diffCoeff_smul_D_eq_of_ord_eq_one
+(e246bf28-163c-589b-a3ca-8b9beef53498) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c413ac80-f57b-5f53-bd3b-4a05e9905c11
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_isSeparable_adjoin_of_ord_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_KaehlerDifferential_D_ne_zero_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_transcendental_of_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Uniformiser coordinate of a differential over a perfect field
+
+Theorem statement: `AlgebraicCurve.Place.diffCoeff_smul_D_eq_of_ord_eq_one`
+(`e246bf28-163c-589b-a3ca-8b9beef53498`), by Claude, 2026-09-05.
+
+Proof: submission `c413ac80-f57b-5f53-bd3b-4a05e9905c11`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a perfect field and $F$ a field extension of $K$, and suppose an element $x \in F$ is
+given such that $F$ is algebraic over the intermediate field $K(x)$ generated by $x$. Let $v$ be a
+place of $F$ over $K$, that is, a valuation subring of $F$ containing the image of $K$, distinct
+from $F$ itself and a principal ideal ring; write $\operatorname{ord}_v$ for the associated
+integer-valued order function, the negative of the logarithm of the $v$-adic valuation. Let $t \in
+F$ satisfy $\operatorname{ord}_v t = 1$, and let $g \in F$ be arbitrary. The assertion is that
+$\operatorname{diffCoeff} t\,(g \cdot D_{K/F}t) = g$, where $D$ is the universal $K$-derivation of
+$F$ into $\Omega_{F/K}$ and, for $t \in F$, $\operatorname{diffCoeff} t$ sends a differential
+$\omega$ to a chosen $h \in F$ with $\omega = h \cdot D t$ when such an $h$ exists, and to $0$
+otherwise. Thus for a uniformiser $t$ at $v$ the coefficient function with respect to $t$ recovers
+the scalar $g$ exactly.
+
+This is the statement that a uniformiser at a place of a function field over a perfect constant
+field is a separating element, so that $Dt$ spans the one-dimensional space of Kähler differentials
+and the coordinate map with respect to $Dt$ is well behaved. It is the perfect-field counterpart of
+the characteristic-zero statement for elements of nonzero order, and it underlies the computations
+of the order of a differential at a place and the behaviour of that order under scaling.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_diffCoeff_smul_D_eq_of_ord_eq_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_diffCoeff_smul_D_eq_of_ord_eq_one
+
+noncomputable section
+
+private theorem D_ne_zero {K F : Type*} [Field K] [Field F] [Algebra K F] [PerfectField K]
+    (x : F) [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {t : F} (ht : v.ord t = 1) :
+    KaehlerDifferential.D K F t ≠ 0 :=
+  haveI := AlgebraicCurve.Place.isSeparable_adjoin_of_ord_eq_one x v ht
+  KaehlerDifferential.D_ne_zero_of_transcendental K t
+    (v.transcendental_of_ord_ne_zero (ht ▸ one_ne_zero))
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [PerfectField K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {t : F} (ht : v.ord t = 1) (g : F) :
+    AlgebraicCurve.Place.diffCoeff t (g • KaehlerDifferential.D K F t) = g :=
+  smul_left_injective F (D_ne_zero x v ht)
+    (AlgebraicCurve.Place.diffCoeff_smul_D ⟨g, rfl⟩)
+
+end
+
+end S_AlgebraicCurve_Place_diffCoeff_smul_D_eq_of_ord_eq_one
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_diffCoeff_smul_D_eq_of_ord_eq_one (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.diffCoeff_smul_D_eq_of_ord_eq_one {K F : Type*} [Field K] [Field F]
+    [Algebra K F] [PerfectField K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {t : F} (ht : v.ord t = 1) (g : F) :
+    AlgebraicCurve.Place.diffCoeff t (g • KaehlerDifferential.D K F t) = g :=
+  solution x v ht g
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_eq_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_eq_one.lean
new file mode 100644
index 0000000000..aa2f58bac5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_eq_one.lean
@@ -0,0 +1,101 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.diffCoeff_smul_D_of_ord_eq_one
+(7307b5be-2f4e-5309-9a33-edbe19cf9d59) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f9a6304e-2f27-594c-bb88-daa7b77f7136
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_isSeparable_adjoin_of_ord_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_KaehlerDifferential_span_D_eq_top_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_transcendental_of_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A uniformiser's differential spans Ω_{F/K} over a perfect field
+
+Theorem statement: `AlgebraicCurve.Place.diffCoeff_smul_D_of_ord_eq_one`
+(`7307b5be-2f4e-5309-9a33-edbe19cf9d59`), by Claude, 2026-09-05.
+
+Proof: submission `f9a6304e-2f27-594c-bb88-daa7b77f7136`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a perfect field and $F$ a field extension of $K$, and let $x \in F$ be an element such
+that $F$ is algebraic over the intermediate field $K(x)$ generated by $x$. Let $v$ be a place of $F$
+over $K$, that is, a valuation subring of $F$ containing the image of $K$, different from $F$
+itself, and whose underlying ring is a principal ideal ring, and let $t \in F$ be an element with
+$\operatorname{ord}_v(t) = 1$, where $\operatorname{ord}_v(f)$ denotes the negative of the logarithm
+of the value of $f$ under the $\mathbb{Z}^{m0}$-valued adic valuation attached to the height-one
+prime of $v$. Then for every Kähler differential $\omega \in \Omega_{F/K}$ one has
+$$\operatorname{diffCoeff}(t,\omega) \cdot d_{K/F}t = \omega,$$ where
+$\operatorname{diffCoeff}(t,\omega)$ is defined to be a chosen $g \in F$ with $\omega = g \cdot dt$
+if such a $g$ exists and $0$ otherwise. Equivalently: for a uniformiser $t$ at $v$, every
+differential of $F$ over $K$ is an $F$-multiple of $dt$, and the coefficient function returns such a
+multiplier.
+
+This is the statement that an element with a simple zero at a place is a separating element, so that
+$dt$ generates the one-dimensional $F$-vector space $\Omega_{F/K}$, in the form needed to evaluate
+the coefficient function $\operatorname{diffCoeff}$; it is the perfect-constant-field analogue of
+the corresponding characteristic-zero result, where the hypothesis $\operatorname{ord}_v(t) \neq 0$
+must be strengthened to $\operatorname{ord}_v(t) = 1$. It feeds the local theory of differentials on
+a curve, in particular the computation of the order of a differential at a place and the comparison
+of the differential divisor with the canonical divisor.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_eq_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_eq_one
+
+noncomputable section
+
+private theorem exists_eq_smul_D {K F : Type*} [Field K] [Field F] [Algebra K F] [PerfectField K]
+    (x : F) [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {t : F} (ht : v.ord t = 1) (ω : Ω[F⁄K]) :
+    ∃ g : F, ω = g • KaehlerDifferential.D K F t := by
+  have := AlgebraicCurve.Place.isSeparable_adjoin_of_ord_eq_one x v ht
+  have hspan := KaehlerDifferential.span_D_eq_top_of_transcendental K t
+    (v.transcendental_of_ord_ne_zero (ht ▸ one_ne_zero))
+  have hω : ω ∈ Submodule.span F {KaehlerDifferential.D K F t} := by rw [hspan]; trivial
+  obtain ⟨g, hg⟩ := Submodule.mem_span_singleton.mp hω
+  exact ⟨g, hg.symm⟩
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [PerfectField K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {t : F} (ht : v.ord t = 1) (ω : Ω[F⁄K]) :
+    AlgebraicCurve.Place.diffCoeff t ω • KaehlerDifferential.D K F t = ω :=
+  AlgebraicCurve.Place.diffCoeff_smul_D (exists_eq_smul_D x v ht ω)
+
+end
+
+end S_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_eq_one
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_eq_one (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.diffCoeff_smul_D_of_ord_eq_one {K F : Type*} [Field K] [Field F]
+    [Algebra K F] [PerfectField K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {t : F} (ht : v.ord t = 1) (ω : Ω[F⁄K]) :
+    AlgebraicCurve.Place.diffCoeff t ω • KaehlerDifferential.D K F t = ω :=
+  solution x v ht ω
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_ne_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_ne_zero.lean
new file mode 100644
index 0000000000..fd5b5b1f1b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_ne_zero.lean
@@ -0,0 +1,124 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.diffCoeff_smul_D_of_ord_ne_zero
+(fdd7becf-e61a-5010-81c7-31870dd97e68) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission af346ffc-5ef4-51ad-8871-c347ac5677eb
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_transcendental_of_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isAlgebraic_adjoin_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_KaehlerDifferential_span_D_eq_top_of_transcendental
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The chosen coefficient reproduces ω: diffCoeff(t,ω) dt=ω
+
+Theorem statement: `AlgebraicCurve.Place.diffCoeff_smul_D_of_ord_ne_zero`
+(`fdd7becf-e61a-5010-81c7-31870dd97e68`), by Claude, 2026-09-05.
+
+Proof: submission `af346ffc-5ef4-51ad-8871-c347ac5677eb`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field of characteristic zero and $F$ a field extension of $K$. Let $x \in F$ be an
+element such that $F$ is algebraic over the intermediate field $K(x) =$ `IntermediateField.adjoin K
+{x}`. Let $v$ be a place of $F/K$ in the sense of the project's structure
+[`AlgebraicCurve.Place`](def/AlgebraicCurve_DivisorClassGroup.html#L22), that is, a valuation
+subring of $F$ containing the image of $K$ under the structure map, different from all of $F$, and
+whose ideals are all principal; let $v.\mathrm{ord}$ denote the associated integer valuation, the
+negative of the logarithm of the $\mathbb{Z}^{m0}$-valued adic valuation attached to the height-one
+prime of $v$. Let $t \in F$ satisfy $v.\mathrm{ord}\,t \neq 0$, and let $\omega$ be a Kähler
+differential in $\Omega_{F/K}$. Then $\mathrm{diffCoeff}(t, \omega) \cdot dt = \omega$, where $dt$
+is `KaehlerDifferential.D K F t` and $\mathrm{diffCoeff}(t,\omega)$ is defined as a choice of $g \in
+F$ with $\omega = g \cdot dt$ when such a $g$ exists, and $0$ otherwise. In other words, under these
+hypotheses the defining case of `diffCoeff` is the one that applies, and the chosen scalar is
+genuinely a coefficient of $\omega$ against $dt$.
+
+This is the formal counterpart of the statement that, for a function field of transcendence degree
+one in characteristic zero, every element of nonzero order at a place is separating, so that
+$\Omega_{F/K}$ is a one-dimensional $F$-space with basis $dt$. It is the fact underlying the
+well-definedness of the order of a differential at a place, and is used by the results computing
+$v.\mathrm{ordDiff}$ of $dt$ and its lower bounds.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_ne_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_ne_zero
+
+noncomputable section
+open KaehlerDifferential
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.diffCoeff Place.diffCoeff_smul_D Place.ordDiff_def Place \
+  isAlgebraic_adjoin_of_transcendental"
+namespace FF2R3
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] [CharZero K] (x : F)
+  [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+
+include x in
+private theorem isSeparable_adjoin (v : Place K F) {t : F} (ht : v.ord t ≠ 0) :
+    Algebra.IsSeparable (IntermediateField.adjoin K ({t} : Set F)) F := by
+  have : Algebra.IsAlgebraic (IntermediateField.adjoin K ({t} : Set F)) F :=
+    AlgebraicCurve.isAlgebraic_adjoin_of_transcendental x (v.transcendental_of_ord_ne_zero ht)
+  have : CharZero F := charZero_of_injective_algebraMap (algebraMap K F).injective
+  infer_instance
+
+include x in
+theorem exists_eq_smul_D_of_ord_ne_zero (v : Place K F) {t : F} (ht : v.ord t ≠ 0) (ω : Ω[F⁄K]) :
+    ∃ g : F, ω = g • D K F t := by
+  have := isSeparable_adjoin x v ht
+  have hspan :=
+    KaehlerDifferential.span_D_eq_top_of_transcendental K t (v.transcendental_of_ord_ne_zero ht)
+  have hω : ω ∈ Submodule.span F {D K F t} := by rw [hspan]; trivial
+  obtain ⟨g, hg⟩ := Submodule.mem_span_singleton.mp hω
+  exact ⟨g, hg.symm⟩
+
+include x in
+theorem diffCoeff_smul_D_of_ord_ne_zero (v : Place K F) {t : F} (ht : v.ord t ≠ 0) (ω : Ω[F⁄K]) :
+    Place.diffCoeff t ω • D K F t = ω :=
+  Place.diffCoeff_smul_D (exists_eq_smul_D_of_ord_ne_zero x v ht ω)
+
+end AlgebraicCurve.FF2R3
+
+end
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [CharZero K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {t : F} (ht : v.ord t ≠ 0) (ω : Ω[F⁄K]) :
+    AlgebraicCurve.Place.diffCoeff t ω • KaehlerDifferential.D K F t = ω :=
+  AlgebraicCurve.FF2R3.diffCoeff_smul_D_of_ord_ne_zero x v ht ω
+
+end S_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_ne_zero
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_ne_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.diffCoeff_smul_D_of_ord_ne_zero {K F : Type*} [Field K] [Field F]
+    [Algebra K F] [CharZero K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {t : F} (ht : v.ord t ≠ 0) (ω : Ω[F⁄K]) :
+    AlgebraicCurve.Place.diffCoeff t ω • KaehlerDifferential.D K F t = ω :=
+  solution x v ht ω
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_eq_ofHeightOneSpectrum_of_XClass_mem_nonunits_of_YClass_mem_nonunits.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_eq_ofHeightOneSpectrum_of_XClass_mem_nonunits_of_YClass_mem_nonunits.lean
new file mode 100644
index 0000000000..fff355dbb3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_eq_ofHeightOneSpectrum_of_XClass_mem_nonunits_of_YClass_mem_nonunits.lean
@@ -0,0 +1,155 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.Place.eq_ofHeightOneSpectrum_of_XClass_mem_nonunits_of_YClass_mem_nonunits
+(719fe46e-a7ed-5a9e-b7d7-c19777574935) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9d89dec3-40df-5919-86a2-b424db66fe70
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_exists_eq_valuationSubring_of_X_mem
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A place centred at an affine point is the point's place
+
+Theorem statement:
+`AlgebraicCurve.Place.eq_ofHeightOneSpectrum_of_XClass_mem_nonunits_of_YClass_mem_nonunits`
+(`719fe46e-a7ed-5a9e-b7d7-c19777574935`), by Claude, 2026-09-05.
+
+Proof: submission `9d89dec3-40df-5919-86a2-b424db66fe70`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field and let $W$ be an affine Weierstrass curve over $F$ whose coordinate ring $F[W]
+=$ `W.CoordinateRing` is a Dedekind domain, and let $x, y \in F$. Let $v$ be a place of the function
+field $W.FunctionField$ over $F$, that is: a valuation subring $\mathcal{O}_v$ of the function field
+which contains the image of $F$ under the structure map, is not the whole function field, and is a
+principal ideal ring. Assume that the images in the function field of the two classes
+$\mathrm{XClass}\,W\,x$ (the class of $X - x$) and $\mathrm{YClass}\,W\,(C\,y)$ (the class of $Y -
+y$) in $F[W]$ both lie in the set of non-units of $\mathcal{O}_v$, i.e. in its maximal ideal. Let
+$w$ be a height-one prime of $F[W]$ whose underlying ideal is $\mathrm{XYIdeal}\,W\,x\,(C\,y)$, the
+ideal generated by those two classes. Then $v$ equals the place attached to $w$, whose valuation
+subring is the valuation subring of the $w$-adic valuation on the function field.
+
+This is the statement that a place of the function field whose valuation ring has $X - x$ and $Y -
+y$ in its maximal ideal — a place centred at the affine point $(x,y)$ — is the place given by the
+order of vanishing at the corresponding height-one prime of the coordinate ring. It is used to
+identify the place attached to an affine point of a Weierstrass curve with an adic place, in
+[`WeierstrassCurve.Affine.eq_placeOfPoint_some_of_XClass_mem_nonunits_of_YClass_mem_nonunits`]
+(thm.html#WeierstrassCurve.Affine.
+eq_placeOfPoint_some_of_XClass_mem_nonunits_of_YClass_mem_nonunits),
+[`WeierstrassCurve.Affine.placeOfPoint_some_eq_ofHeightOneSpectrum`]
+(thm.html#WeierstrassCurve.Affine.placeOfPoint_some_eq_ofHeightOneSpectrum)
+and in the comparison of places under a variable change.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_eq_ofHeightOneSpectrum_of_XClass_mem_nonunits_of_YClass_mem_nonunits.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_d1e0a4c0
+
+open AlgebraicCurve WeierstrassCurve WeierstrassCurve.Affine Polynomial
+
+universe u
+
+namespace S13Bridge
+
+variable {F : Type u} [Field F] {W : WeierstrassCurve.Affine F}
+
+theorem algebraMap_F_coordinateRing (c : F) :
+    algebraMap F W.CoordinateRing c = CoordinateRing.mk W (C (C c)) := rfl
+
+theorem mk_C_X_eq (x : F) :
+    CoordinateRing.mk W (C X) = CoordinateRing.XClass W x + algebraMap F W.CoordinateRing x := by
+  rw [algebraMap_F_coordinateRing, CoordinateRing.XClass, map_sub, map_sub, sub_add_cancel]
+
+theorem adic_lt_one_of_mem_nonunits [IsDedekindDomain W.CoordinateRing]
+    (w : IsDedekindDomain.HeightOneSpectrum W.CoordinateRing) {f : W.FunctionField}
+    (hf : f ∈ ((w.valuation W.FunctionField).valuationSubring).nonunits) :
+    w.valuation W.FunctionField f < 1 := by
+  rw [ValuationSubring.mem_nonunits_iff] at hf
+  exact (Valuation.isEquiv_valuation_valuationSubring _).lt_one_iff_lt_one.mpr hf
+
+end S13Bridge
+
+open S13Bridge in
+theorem solution
+    {F : Type u} [Field F] {W : WeierstrassCurve.Affine F} [IsDedekindDomain W.CoordinateRing]
+    {x y : F} (v : AlgebraicCurve.Place F W.FunctionField)
+    (hX : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.XClass W x)
+      ∈ v.toValuationSubring.nonunits)
+    (hY : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.YClass W (Polynomial.C y))
+      ∈ v.toValuationSubring.nonunits)
+    (w : IsDedekindDomain.HeightOneSpectrum W.CoordinateRing)
+    (hw : w.asIdeal = CoordinateRing.XYIdeal W x (Polynomial.C y)) :
+    v = Place.ofHeightOneSpectrum (K := F) w := by
+  have hXO : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W (C X))
+      ∈ v.toValuationSubring := by
+    rw [mk_C_X_eq x, map_add, ← IsScalarTower.algebraMap_apply]
+    refine add_mem ?_ (v.algebraMap_mem' x)
+    exact (ValuationSubring.valuation_le_one_iff _ _).mp
+      (le_of_lt ((ValuationSubring.mem_nonunits_iff _).mp hX))
+  obtain ⟨w', hw'⟩ := WeierstrassCurve.Affine.FunctionField.exists_eq_valuationSubring_of_X_mem
+    W v.toValuationSubring v.ne_top' v.algebraMap_mem' hXO
+  have hXmem : CoordinateRing.XClass W x ∈ w'.asIdeal := by
+    refine (IsDedekindDomain.HeightOneSpectrum.valuation_lt_one_iff_mem (K := W.FunctionField) w'
+      _).mp ?_
+    exact adic_lt_one_of_mem_nonunits w' (hw' ▸ hX)
+  have hYmem : CoordinateRing.YClass W (C y) ∈ w'.asIdeal := by
+    refine (IsDedekindDomain.HeightOneSpectrum.valuation_lt_one_iff_mem (K := W.FunctionField) w'
+      _).mp ?_
+    exact adic_lt_one_of_mem_nonunits w' (hw' ▸ hY)
+  have hle : w.asIdeal ≤ w'.asIdeal := by
+    rw [hw, CoordinateRing.XYIdeal, Ideal.span_le]
+    rintro z (rfl | rfl)
+    · exact hXmem
+    · exact hYmem
+  have hmax : w.asIdeal.IsMaximal := w.isPrime.isMaximal w.ne_bot
+  have heq : w = w' := IsDedekindDomain.HeightOneSpectrum.ext (hmax.eq_of_le w'.isPrime.ne_top hle)
+  subst heq
+  exact AlgebraicCurve.Place.ext (by rw [Place.ofHeightOneSpectrum_toValuationSubring]; exact hw')
+
+end S_OVERLONG_d1e0a4c0
+end P2MW
+export
+  P2MW.S_OVERLONG_d1e0a4c0
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve WeierstrassCurve WeierstrassCurve.Affine
+
+universe u
+theorem AlgebraicCurve.Place.eq_ofHeightOneSpectrum_of_XClass_mem_nonunits_of_YClass_mem_nonunits
+    {F : Type u} [Field F] {W : WeierstrassCurve.Affine F} [IsDedekindDomain W.CoordinateRing]
+    {x y : F} (v : AlgebraicCurve.Place F W.FunctionField)
+    (hX : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.XClass W x)
+      ∈ v.toValuationSubring.nonunits)
+    (hY : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.YClass W (Polynomial.C y))
+      ∈ v.toValuationSubring.nonunits)
+    (w : IsDedekindDomain.HeightOneSpectrum W.CoordinateRing)
+    (hw : w.asIdeal = CoordinateRing.XYIdeal W x (Polynomial.C y)) :
+    v = Place.ofHeightOneSpectrum (K := F) w :=
+  solution v hX hY w hw
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_evalAt_algebraMap.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_evalAt_algebraMap.lean
new file mode 100644
index 0000000000..41c5f4bba5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_evalAt_algebraMap.lean
@@ -0,0 +1,84 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.evalAt_algebraMap
+(530bce27-196e-589d-a3d0-19d0844fb39d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 65a760dc-d291-5a56-972f-85ebaf7b8b07
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Evaluation of a constant at a place returns the constant
+
+Theorem statement: `AlgebraicCurve.Place.evalAt_algebraMap`
+(`530bce27-196e-589d-a3d0-19d0844fb39d`), by Claude, 2026-09-05.
+
+Proof: submission `65a760dc-d291-5a56-972f-85ebaf7b8b07`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+sense of this development: a valuation subring $v.\mathrm{toValuationSubring}$ of $F$ which contains
+$\mathrm{algebraMap}_{K,F}(a)$ for every $a \in K$, is not all of $F$, and is a principal ideal
+ring. For $f \in F$ the evaluation $v.\mathrm{evalAt}(f) \in K$ is defined to be $0$ when $f$ does
+not lie in $v.\mathrm{toValuationSubring}$, and otherwise the image of the residue class of $f$ in
+the residue field of the local ring $v.\mathrm{toValuationSubring}$ under `residueInv`, the chosen
+inverse function (`Function.invFun`) of the structure map $K \to v.\mathrm{ResidueField}$. The
+assertion is that for every $a \in K$ one has $v.\mathrm{evalAt}(\mathrm{algebraMap}_{K,F}(a)) = a$;
+that is, the evaluation of the constant $a$, viewed as an element of $F$, recovers $a$ itself. No
+hypothesis beyond the place structure is required, in particular no assumption that the residue
+field equals $K$.
+
+This is the statement that constants are evaluated to themselves at any place of $F/K$, the base
+case of the evaluation-of-functions layer used in the treatment of divisors, Weil reciprocity and
+the Weil pairing; it is invoked throughout that layer, for instance in the computations on annuli
+and component charts.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_evalAt_algebraMap.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_evalAt_algebraMap
+
+open IsLocalRing AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) (a : K) :
+    v.evalAt (algebraMap K F a) = a := by
+  rw [v.evalAt_of_mem (v.algebraMap_mem' a)]
+  have ha : (⟨algebraMap K F a, v.algebraMap_mem' a⟩ : v.toValuationSubring)
+      = algebraMap K v.toValuationSubring a := Subtype.ext (v.coe_algebraMap a).symm
+  rw [ha, ← ResidueField.algebraMap_eq,
+    ← IsScalarTower.algebraMap_apply K v.toValuationSubring v.ResidueField,
+    v.residueInv_algebraMap]
+
+end S_AlgebraicCurve_Place_evalAt_algebraMap
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_evalAt_algebraMap (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.evalAt_algebraMap {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) (a : K) :
+    v.evalAt (algebraMap K F a) = a :=
+  solution v a
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_evalAt_congr.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_evalAt_congr.lean
new file mode 100644
index 0000000000..15ff613584
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_evalAt_congr.lean
@@ -0,0 +1,97 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.evalAt_congr
+(3a35d3f2-9ecf-570d-a8df-cf65818da0f0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f7e2886f-311b-5b13-ac48-211cc6da7ce4
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_maximalIdeal_iff_adicValuation_lt_one
+
+/-!
+# Values at a place agree for functions congruent modulo mathfrak mᵥ
+
+Theorem statement: `AlgebraicCurve.Place.evalAt_congr` (`3a35d3f2-9ecf-570d-a8df-cf65818da0f0`), by
+Claude, 2026-09-05.
+
+Proof: submission `f7e2886f-311b-5b13-ac48-211cc6da7ce4`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+sense of [`AlgebraicCurve.Place`](def/AlgebraicCurve_DivisorClassGroup.html#L22): a valuation
+subring $\mathcal O_v =$ `v.toValuationSubring` of $F$ which contains the image of $K$ under the
+structure map, is not all of $F$, and is a principal ideal ring. Let $f, g \in F$ be elements of
+$\mathcal O_v$, and suppose that either $f - g = 0$ or $0 < \operatorname{ord}_v(f-g)$, where
+$\operatorname{ord}_v(x) = -\log\bigl(\mathrm{v.adicValuation}(x)\bigr)$ is minus the $\mathbb
+Z^{m0}$-logarithm of the valuation of the height-one prime attached to $v$. Then
+$\mathrm{v.evalAt}\,f = \mathrm{v.evalAt}\,g$, where for $x \in \mathcal O_v$ the value
+$\mathrm{v.evalAt}\,x \in K$ is obtained by taking the residue of $x$ in the residue field of
+$\mathcal O_v$ and applying `v.residueInv`, a fixed left inverse (chosen via `Function.invFun`) of
+the structure map $K \to \mathcal O_v/\mathfrak m_v$, and $\mathrm{v.evalAt}\,x = 0$ for $x \notin
+\mathcal O_v$. The separate disjunct $f-g=0$ is needed because $\operatorname{ord}_v 0 = 0$ with the
+conventions in force.
+
+This is the congruence property of evaluation at a place: functions regular at $v$ and congruent
+modulo the maximal ideal have the same value at $v$. It is the bridge between the abstract
+residue-field definition of $f(v)$ and concrete formulae for values, and is used throughout the
+function-field layer, for instance in computing values at the places of a rational function field,
+including the place at infinity.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_evalAt_congr.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open IsDedekindDomain WithZero IsLocalRing AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) {f g : F}
+    (hf : f ∈ v.toValuationSubring) (hg : g ∈ v.toValuationSubring)
+    (h : f - g = 0 ∨ 0 < v.ord (f - g)) :
+    v.evalAt f = v.evalAt g := by
+  rcases h with h | h
+  · rw [sub_eq_zero] at h
+    rw [h]
+  have hsub : f - g ∈ v.toValuationSubring := sub_mem hf hg
+  have hmax : ∀ {x : F} (hx : x ∈ v.toValuationSubring), 0 < v.ord x →
+      (⟨x, hx⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring := by
+    intro x hx hpos
+    rcases eq_or_ne x 0 with rfl | hx0
+    · exact Submodule.zero_mem _
+    rw [v.mem_maximalIdeal_iff_adicValuation_lt_one]
+    have hne : v.adicValuation x ≠ 0 := v.adicValuation_ne_zero hx0
+    rw [← exp_log hne, show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_lt_exp]
+    have : v.ord x = -log (v.adicValuation x) := rfl
+    omega
+  have hmem : (⟨f, hf⟩ : v.toValuationSubring) - ⟨g, hg⟩ ∈
+      IsLocalRing.maximalIdeal v.toValuationSubring := by
+    have : (⟨f, hf⟩ : v.toValuationSubring) - ⟨g, hg⟩ = ⟨f - g, hsub⟩ := rfl
+    rw [this]
+    exact hmax hsub h
+  have hres : residue v.toValuationSubring (⟨f, hf⟩ : v.toValuationSubring)
+      = residue v.toValuationSubring (⟨g, hg⟩ : v.toValuationSubring) := by
+    rw [← sub_eq_zero, ← map_sub]
+    exact (IsLocalRing.residue_eq_zero_iff _).mpr hmem
+  rw [v.evalAt_of_mem hf, v.evalAt_of_mem hg, hres]
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.evalAt_congr {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) {f g : F} (hf : f ∈ v.toValuationSubring) (hg : g ∈ v.toValuationSubring)
+    (h : f - g = 0 ∨ 0 < v.ord (f - g)) : v.evalAt f = v.evalAt g :=
+  solution v hf hg h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_evalAt_inv.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_evalAt_inv.lean
new file mode 100644
index 0000000000..fcbe99ac38
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_evalAt_inv.lean
@@ -0,0 +1,86 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.evalAt_inv
+(9baa1fd8-1922-59dd-b731-2eb081e17700) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e7128a7d-864f-54ec-a284-b804fe552843
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_of_ord_nonneg
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Value of an inverse at a rational place
+
+Theorem statement: `AlgebraicCurve.Place.evalAt_inv` (`9baa1fd8-1922-59dd-b731-2eb081e17700`), by
+Claude, 2026-09-05.
+
+Proof: submission `e7128a7d-864f-54ec-a284-b804fe552843`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+project's sense: a valuation subring $\mathcal{O}_v \subseteq F$ that contains the image of $K$, is
+not all of $F$, and is a principal ideal ring. Assume $v$ is rational, i.e. the induced map $K \to
+\mathcal{O}_v/\mathfrak{m}_v$ into the residue field is surjective; evaluation $v.\mathrm{evalAt}$
+is then defined on $\mathcal{O}_v$ by composing the residue map with a chosen set-theoretic inverse
+of $K \to \mathcal{O}_v/\mathfrak{m}_v$, and is set to $0$ off $\mathcal{O}_v$. Let $f \in F$ with
+$f \neq 0$ and with $\operatorname{ord}_v(f) = 0$, where $\operatorname{ord}_v$ is minus the
+logarithm of the $\mathbb{Z}^{m0}$-valued adic valuation attached to $v$, so that $f$ has neither a
+zero nor a pole at $v$. The conclusion is the equality in $K$
+$$v.\mathrm{evalAt}(f^{-1}) = \big(v.\mathrm{evalAt}(f)\big)^{-1}.$$
+
+This is the compatibility of evaluation at a rational place with inversion, for functions that are
+units at the place; it belongs to the layer of elementary properties of evaluating functions at
+places, underneath the treatment of Weil reciprocity. It is used in the computations with annuli and
+parameters, for instance when comparing evaluations of a function and of its residue against powers
+of a parameter.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_evalAt_inv.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_evalAt_inv
+
+open AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) (hv : v.IsRational)
+    {f : F} (hf : f ≠ 0) (h : v.ord f = 0) :
+    v.evalAt f⁻¹ = (v.evalAt f)⁻¹ := by
+  have hfi : f⁻¹ ≠ 0 := inv_ne_zero hf
+  have hi : v.ord f⁻¹ = 0 := by rw [v.ord_inv, h, neg_zero]
+  have hmul := v.evalAt_mul hv (v.mem_of_ord_nonneg hf h.ge) (v.mem_of_ord_nonneg hfi hi.ge)
+  rw [mul_inv_cancel₀ hf, v.evalAt_one] at hmul
+  exact eq_inv_of_mul_eq_one_right hmul.symm
+
+end S_AlgebraicCurve_Place_evalAt_inv
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_evalAt_inv (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.evalAt_inv {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) (hv : v.IsRational) {f : F} (hf : f ≠ 0) (h : v.ord f = 0) :
+    v.evalAt f⁻¹ = (v.evalAt f)⁻¹ :=
+  solution v hv hf h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_evalAt_mul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_evalAt_mul.lean
new file mode 100644
index 0000000000..302061d007
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_evalAt_mul.lean
@@ -0,0 +1,85 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.evalAt_mul
+(7f4b84de-8c77-5726-b122-34154855c5c6) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 467c254b-dd3e-5763-b0af-12829f96a933
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Evaluation at a rational place is multiplicative
+
+Theorem statement: `AlgebraicCurve.Place.evalAt_mul` (`7f4b84de-8c77-5726-b122-34154855c5c6`), by
+Claude, 2026-09-05.
+
+Proof: submission `467c254b-dd3e-5763-b0af-12829f96a933`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$, i.e. a
+valuation subring $\mathcal O_v =$ `v.toValuationSubring` of $F$ which contains the image of $K$
+under the structure map, is not all of $F$, and is a principal ideal ring. Write $\kappa(v)$ for the
+residue field of the local ring $\mathcal O_v$, and let $\mathrm{ev}_v \colon F \to K$ be the
+evaluation map that sends $f$ to the image of the residue class of $f$ under a fixed set-theoretic
+inverse of the structure map $K \to \kappa(v)$ when $f \in \mathcal O_v$, and to $0$ otherwise.
+Assume $v$ is rational, meaning that the map $K \to \kappa(v)$ is surjective, so that this inverse
+is a genuine section. Then for all $f, g \in F$ lying in $\mathcal O_v$ one has $\mathrm{ev}_v(fg) =
+\mathrm{ev}_v(f)\,\mathrm{ev}_v(g)$ in $K$. (No hypothesis is placed on $fg$ beyond what follows
+from $f, g \in \mathcal O_v$.)
+
+This is the multiplicativity of the evaluation-at-a-place map $f \mapsto f(v)$ on functions regular
+at $v$, i.e. the statement that evaluation is the composite of the residue homomorphism $\mathcal
+O_v \to \kappa(v)$ with the inverse of the identification $\kappa(v) \cong K$ furnished by
+rationality of $v$. It belongs to the function-field layer underlying the theory of divisors, Weil
+reciprocity and the Weil pairing on modular curves, and is used throughout the computations with
+functions on annuli and charts in that layer.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_evalAt_mul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_evalAt_mul
+
+open IsLocalRing AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) (hv : v.IsRational)
+    {f g : F} (hf : f ∈ v.toValuationSubring) (hg : g ∈ v.toValuationSubring) :
+    v.evalAt (f * g) = v.evalAt f * v.evalAt g := by
+  apply v.algebraMap_residueField_injective
+  rw [map_mul, v.algebraMap_evalAt hv (mul_mem hf hg), v.algebraMap_evalAt hv hf,
+    v.algebraMap_evalAt hv hg, ← map_mul]
+  rfl
+
+end S_AlgebraicCurve_Place_evalAt_mul
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_evalAt_mul (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.evalAt_mul {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) (hv : v.IsRational) {f g : F} (hf : f ∈ v.toValuationSubring)
+    (hg : g ∈ v.toValuationSubring) :
+    v.evalAt (f * g) = v.evalAt f * v.evalAt g :=
+  solution v hv hf hg
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_evalAt_ne_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_evalAt_ne_zero.lean
new file mode 100644
index 0000000000..2cf388881b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_evalAt_ne_zero.lean
@@ -0,0 +1,97 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.evalAt_ne_zero
+(9189b191-17b0-53c0-9c16-e7bdb3ea4356) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ca31e76d-fe15-55fc-8317-e7055379da18
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_of_ord_nonneg
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Nonvanishing of the value at a rational place of a function of order zero
+
+Theorem statement: `AlgebraicCurve.Place.evalAt_ne_zero` (`9189b191-17b0-53c0-9c16-e7bdb3ea4356`),
+by Claude, 2026-09-05.
+
+Proof: submission `ca31e76d-fe15-55fc-8317-e7055379da18`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$, i.e. a
+valuation subring $\mathcal{O}_v =$ `v.toValuationSubring` of $F$ which contains the image of $K$
+under the structure map, is not all of $F$, and is a principal ideal ring. Assume $v$ is rational in
+the sense of the predicate `IsRational`, namely that the induced map from $K$ to the residue field
+$\mathcal{O}_v/\mathfrak{m}_v$ is surjective. Let $f \in F$ be nonzero and suppose that
+$\operatorname{ord}_v(f) = 0$, where $\operatorname{ord}_v(f)$ is minus the logarithm of the value
+of $f$ under the valuation attached to the height one prime of $\mathcal{O}_v$. Then the value
+$\operatorname{evalAt}_v(f) \in K$ is nonzero, where $\operatorname{evalAt}_v(f)$ is defined to be a
+chosen preimage in $K$, under the map $K \to \mathcal{O}_v/\mathfrak{m}_v$, of the residue class of
+$f$ when $f \in \mathcal{O}_v$, and $0$ otherwise (so that the value is, in particular, a genuine
+preimage exactly when $v$ is rational and $f$ lies in $\mathcal{O}_v$).
+
+This is the statement that a nonzero function with neither a zero nor a pole at a rational place has
+nonzero value there; equivalently, a nonzero element of order zero is a unit of the local ring and
+so has nonzero residue. It underlies the evaluation of functions at divisors, $f(D) = \prod_v
+f(v)^{D(v)}$, being nonzero when the divisor avoids the support of $\operatorname{div} f$, and is
+used throughout the evaluation-at-divisors layer, for instance by
+[`AlgebraicCurve.Divisor.evalFun_algebraMap_pushforward`]
+(thm.html#AlgebraicCurve.Divisor.evalFun_algebraMap_pushforward).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_evalAt_ne_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_evalAt_ne_zero
+
+open IsLocalRing AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) (hv : v.IsRational)
+    {f : F} (hf : f ≠ 0) (h : v.ord f = 0) :
+    v.evalAt f ≠ 0 := by
+  have hmem : f ∈ v.toValuationSubring := v.mem_of_ord_nonneg hf h.ge
+  have hunit : IsUnit (⟨f, hmem⟩ : v.toValuationSubring) := by
+    obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+    obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ
+    rw [h, zpow_zero, mul_one] at hu
+    have huf : (⟨f, hmem⟩ : v.toValuationSubring) = (u : v.toValuationSubring) := Subtype.ext hu
+    rw [huf]
+    exact u.isUnit
+  have hres : residue v.toValuationSubring (⟨f, hmem⟩ : v.toValuationSubring) ≠ 0 :=
+    (residue_ne_zero_iff_isUnit _).mpr hunit
+  intro h0
+  have key := v.algebraMap_evalAt hv hmem
+  rw [h0, map_zero] at key
+  exact hres key.symm
+
+end S_AlgebraicCurve_Place_evalAt_ne_zero
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_evalAt_ne_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.evalAt_ne_zero {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) (hv : v.IsRational) {f : F} (hf : f ≠ 0) (h : v.ord f = 0) :
+    v.evalAt f ≠ 0 :=
+  solution v hv hf h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_evalAt_zpow.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_evalAt_zpow.lean
new file mode 100644
index 0000000000..7c9356b3a5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_evalAt_zpow.lean
@@ -0,0 +1,100 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.evalAt_zpow
+(094e6dff-f7be-58f6-880c-e2157f644670) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9333e6b0-3fd4-5043-a565-840e4b05ffee
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_inv
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_of_ord_nonneg
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Evaluation at a rational place respects integer powers
+
+Theorem statement: `AlgebraicCurve.Place.evalAt_zpow` (`094e6dff-f7be-58f6-880c-e2157f644670`), by
+Claude, 2026-09-05.
+
+Proof: submission `9333e6b0-3fd4-5043-a565-840e4b05ffee`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$, i.e. a
+valuation subring $\mathcal O_v \subseteq F$ that contains the image of $K$ under the structure map,
+is not all of $F$, and is a principal ideal ring. Assume $v$ is rational, meaning that the composite
+$K \to \mathcal O_v \to \mathcal O_v/\mathfrak m_v$ into the residue field is surjective, so that
+the evaluation map $\mathrm{evalAt}$ — which sends $f \in \mathcal O_v$ to a chosen preimage in $K$
+(via `Function.invFun`) of the residue class of $f$, and sends every $f \notin \mathcal O_v$ to $0$
+— is a genuine value map with values in $K$. Let $f \in F$ be nonzero and suppose $\mathrm{ord}_v(f)
+= 0$, where $\mathrm{ord}_v$ is minus the logarithm of the $\mathbb Z^{m0}$-valued valuation
+attached to the height one prime of $\mathcal O_v$; thus $f$ is a unit of $\mathcal O_v$. Then for
+every integer $n$, $\mathrm{evalAt}_v(f^{\,n}) = \bigl(\mathrm{evalAt}_v(f)\bigr)^{n}$, the power on
+the right being taken in $K$.
+
+This is the multiplicativity of evaluation at a rational place on integer powers of a $v$-unit, i.e.
+the statement that $f \mapsto f(v)$ is a homomorphism $\mathcal O_v^{\times} \to K^{\times}$ tested
+against $\mathbb Z$-powers. It belongs to the function-field layer of evaluating functions at places
+and divisors, and is used in the computation of evaluation along divisors and in the results on
+residues of evaluations at annuli.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_evalAt_zpow.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_evalAt_zpow
+
+open AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) (hv : v.IsRational)
+    {f : F} (hf : f ≠ 0) (h : v.ord f = 0) (n : ℤ) :
+    v.evalAt (f ^ n) = v.evalAt f ^ n := by
+  have hpow : ∀ m : ℕ, v.evalAt (f ^ m) = v.evalAt f ^ m := by
+    intro m
+    induction m with
+    | zero => simp [v.evalAt_one]
+    | succ m ih =>
+      have hm : v.ord (f ^ (m : ℤ)) = 0 := by rw [v.ord_zpow, h, mul_zero]
+      rw [pow_succ, v.evalAt_mul hv ?_ (v.mem_of_ord_nonneg hf h.ge), ih, pow_succ]
+      have : (f ^ m : F) = f ^ (m : ℤ) := by rw [zpow_natCast]
+      rw [this]
+      exact v.mem_of_ord_nonneg (zpow_ne_zero _ hf) hm.ge
+  rcases n with m | m
+  · rw [Int.ofNat_eq_natCast, zpow_natCast, zpow_natCast]
+    exact hpow m
+  · rw [zpow_negSucc, zpow_negSucc, ← hpow (m + 1)]
+    refine v.evalAt_inv hv (pow_ne_zero _ hf) ?_
+    have : (f ^ (m + 1) : F) = f ^ ((m + 1 : ℕ) : ℤ) := by rw [zpow_natCast]
+    rw [this, v.ord_zpow, h, mul_zero]
+
+end S_AlgebraicCurve_Place_evalAt_zpow
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_evalAt_zpow (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.evalAt_zpow {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) (hv : v.IsRational) {f : F} (hf : f ≠ 0) (h : v.ord f = 0) (n : ℤ) :
+    v.evalAt (f ^ n) = v.evalAt f ^ n :=
+  solution v hv hf h n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_algEquiv_smul_eq_of_restrict_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_algEquiv_smul_eq_of_restrict_eq.lean
new file mode 100644
index 0000000000..08c759e83c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_algEquiv_smul_eq_of_restrict_eq.lean
@@ -0,0 +1,166 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.exists_algEquiv_smul_eq_of_restrict_eq
+(9ea03254-6b5d-589d-bb5a-022f38b24842) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission cc476d19-98fa-5aff-9d17-bb942ecd7655
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_BaseChangeGalois
+public import Mathlib.FieldTheory.Galois.Basic
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import Mathlib.NumberTheory.RamificationInertia.Galois
+import Mathlib.RingTheory.Invariant.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Galois transitivity on places above a fixed place
+
+Theorem statement: `AlgebraicCurve.Place.exists_algEquiv_smul_eq_of_restrict_eq`
+(`9ea03254-6b5d-589d-bb5a-022f38b24842`), by Claude, 2026-09-05.
+
+Proof: submission `cc476d19-98fa-5aff-9d17-bb942ecd7655`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F'$ and $M$ be fields with $K$-algebra structures on $F'$ and on $M$ and an $F'$-algebra
+structure on $M$ forming a scalar tower over $K$, and suppose $M$ is a finite Galois extension of
+$F'$. Here a place of $M$ over $K$ is a valuation subring of $M$ that contains the image of $K$
+under the structure map, is not all of $M$, and is a principal ideal ring; the restriction of such a
+place to $F'$ is the valuation subring of $F'$ obtained by pulling back along
+$\operatorname{algebraMap} F' M$, which is again a place of $F'$ over $K$. Let $W$ and $W'$ be
+places of $M$ over $K$ whose restrictions to $F'$ coincide, $W'|_{F'} = W|_{F'}$. The assertion is
+that there exists an $F'$-algebra automorphism $\sigma$ of $M$ such that the semilinear automorphism
+associated with $\sigma$ viewed as a $K$-algebra automorphism — namely the pair consisting of
+$\sigma$ as a ring automorphism of $M$ together with the identity on $K$, an element of the group of
+pairs compatible with $\operatorname{algebraMap} K M$ — carries $W$ to $W'$; concretely, the
+valuation subring of $W'$ is the image under $\sigma$ of that of $W$.
+
+This is the classical conjugacy statement for extensions of a valuation in a normal extension: the
+Galois group of $M/F'$ acts transitively on the places of $M$ lying over a given place of $F'$. It
+underlies the comparison of ramification and residue data along $M/F'$ and the
+pull-back/push-forward identities for divisors, being cited for instance by the invariance of the
+inertia degree under the Galois action and by the formula expressing the pull-back of the
+push-forward of a divisor as a sum over Galois conjugates.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_exists_algEquiv_smul_eq_of_restrict_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_exists_algEquiv_smul_eq_of_restrict_eq
+
+noncomputable section
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_Place_exists_algEquiv_smul_eq_of_restrict_eq.AlgebraicCurve \
+  IsDedekindDomain"
+open scoped Pointwise
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ext SemilinearAut SemilinearAut.inv_smul_def \
+  SemilinearAut.ofAlgAut SemilinearAut.toRingAut_ofAlgAut SemilinearAut.smul_toValuationSubring \
+  SemilinearAut.ord_smul"
+p2m_open "AlgebraicCurve"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "integralClosureAt fiberCenter mem_fiberCenter_iff_ord_pos \
+  fiberCenter_liesOver eq_of_fiberCenter_eq restrict restrict_toValuationSubring ext ord \
+  smul_toValuationSubring ord_smul toValuationSubring"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F' M : Type*} [Field K] [Field F'] [Field M] [Algebra K F'] [Algebra K M]
+  [Algebra F' M] [IsScalarTower K F' M]
+
+section Restrict
+variable [Algebra.IsIntegral F' M]
+
+private theorem restrict_ofAlgAut_restrictScalars_smul (σ : M ≃ₐ[F'] M) (W : Place K M) :
+    (SemilinearAut.ofAlgAut (σ.restrictScalars K) • W).restrict F' = W.restrict F' := by
+  refine Place.ext ?_
+  ext x
+  rw [restrict_toValuationSubring, restrict_toValuationSubring, ValuationSubring.mem_comap,
+    ValuationSubring.mem_comap, SemilinearAut.smul_toValuationSubring,
+    ValuationSubring.mem_pointwise_smul_iff_inv_smul_mem, SemilinearAut.inv_smul_def,
+    SemilinearAut.toRingAut_ofAlgAut]
+  have : ((σ.restrictScalars K : M ≃+* M).symm (algebraMap F' M x)) = algebraMap F' M x := by
+    rw [RingEquiv.symm_apply_eq]
+    exact (σ.commutes x).symm
+  rw [this]
+
+private theorem ord_smul_eq (g : SemilinearAut K M) (W : Place K M) (y : M) :
+    (g • W).ord y = W.ord (g⁻¹ • y) := by
+  conv_lhs => rw [← smul_inv_smul g y]
+  exact SemilinearAut.ord_smul g W (g⁻¹ • y)
+
+end Restrict
+
+end Place
+end AlgebraicCurve
+
+open _root_.AlgebraicCurve.Place
+  _root_.P2MW.S_AlgebraicCurve_Place_exists_algEquiv_smul_eq_of_restrict_eq.AlgebraicCurve.Place in
+theorem solution {K F' M : Type*} [Field K] [Field F'] [Field M]
+    [Algebra K F'] [Algebra K M] [Algebra F' M] [IsScalarTower K F' M]
+    [FiniteDimensional F' M] [IsGalois F' M] (W W' : Place K M)
+    (h : W'.restrict F' = W.restrict F') :
+    ∃ σ : M ≃ₐ[F'] M, SemilinearAut.ofAlgAut (σ.restrictScalars K) • W = W' := by
+  set w : Place K F' := W.restrict F'
+  have hW : W.restrict F' = w := rfl
+  let := IsIntegralClosure.MulSemiringAction w.toValuationSubring F' M (integralClosureAt M w)
+  have : IsGaloisGroup Gal(M/F') w.toValuationSubring (integralClosureAt M w) :=
+    IsGaloisGroup.of_isFractionRing Gal(M/F') w.toValuationSubring (integralClosureAt M w) F' M
+  have hp : (fiberCenter M w hW).asIdeal.IsPrime := (fiberCenter M w hW).isPrime
+  have hp' : (fiberCenter M w h).asIdeal.IsPrime := (fiberCenter M w h).isPrime
+  have := fiberCenter_liesOver (F' := M) hW
+  have := fiberCenter_liesOver (F' := M) h
+  obtain ⟨σ, hσ'⟩ := Ideal.exists_smul_eq_of_isGaloisGroup
+    (IsLocalRing.maximalIdeal w.toValuationSubring) (fiberCenter M w hW).asIdeal
+    (fiberCenter M w h).asIdeal Gal(M/F')
+  refine ⟨σ, eq_of_fiberCenter_eq (restrict_ofAlgAut_restrictScalars_smul σ W) h ?_⟩
+  refine HeightOneSpectrum.ext (Ideal.ext fun c => ?_)
+  rw [← hσ', Ideal.mem_pointwise_smul_iff_inv_smul_mem]
+  by_cases hc : c = 0
+  · simp [hc]
+  have hc' : σ⁻¹ • c ≠ 0 := fun h0 => hc (by simpa using congrArg (σ • ·) h0)
+  rw [mem_fiberCenter_iff_ord_pos _ hc, mem_fiberCenter_iff_ord_pos _ hc', ord_smul_eq,
+    SemilinearAut.inv_smul_def, SemilinearAut.toRingAut_ofAlgAut]
+  have key : algebraMap (integralClosureAt M w) M (σ⁻¹ • c)
+      = ((σ.restrictScalars K : M ≃+* M)).symm (algebraMap (integralClosureAt M w) M c) := by
+    rw [show σ⁻¹ • c = galRestrict w.toValuationSubring F' M (integralClosureAt M w) σ⁻¹ c
+      from rfl, algebraMap_galRestrict_apply, AlgEquiv.aut_inv]
+    rfl
+  rw [key]
+
+end
+
+end S_AlgebraicCurve_Place_exists_algEquiv_smul_eq_of_restrict_eq
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_exists_algEquiv_smul_eq_of_restrict_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.exists_algEquiv_smul_eq_of_restrict_eq {K F' M : Type*} [Field K]
+    [Field F'] [Field M]
+    [Algebra K F'] [Algebra K M] [Algebra F' M] [IsScalarTower K F' M]
+    [FiniteDimensional F' M] [IsGalois F' M] (W W' : Place K M)
+    (h : W'.restrict F' = W.restrict F') :
+    ∃ σ : M ≃ₐ[F'] M, SemilinearAut.ofAlgAut (σ.restrictScalars K) • W = W' :=
+  solution W W' h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_algHom_laurentSeries_order_eq_ord.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_algHom_laurentSeries_order_eq_ord.lean
new file mode 100644
index 0000000000..c3ba800186
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_algHom_laurentSeries_order_eq_ord.lean
@@ -0,0 +1,594 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.exists_algHom_laurentSeries_order_eq_ord
+(49bda154-3acd-5949-acc1-5437a9b8a76e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 95b3d368-b415-51ac-bd92-31e448758833
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+
+import Mathlib.RingTheory.PowerSeries.Trunc
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree-one places arise from embeddings into K((T))
+
+Theorem statement: `AlgebraicCurve.Place.exists_algHom_laurentSeries_order_eq_ord`
+(`49bda154-3acd-5949-acc1-5437a9b8a76e`), by Claude, 2026-09-05.
+
+Proof: submission `95b3d368-b415-51ac-bd92-31e448758833`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $w$ be a place of $F$ over $K$ in the
+sense of the project: a valuation subring $w$ of $F$ which contains $\mathrm{algebraMap}\,K\,F(a)$
+for every $a \in K$, is not the whole of $F$, and whose underlying ring is a principal ideal ring.
+Assume $w.\mathrm{deg} = 1$, that is, the residue field of the local ring $w$ has $K$-dimension $1$.
+Then there exists a $K$-algebra homomorphism $\varphi : F \to K((T))$ into the field of formal
+Laurent series over $K$ such that for every $x \in F$ the order of the Laurent series $\varphi(x)$
+(its lowest exponent with nonzero coefficient, taken to be $0$ for $x = 0$) equals
+$w.\mathrm{ord}\,x$, where $w.\mathrm{ord}\,x$ is minus the logarithm of the value of $x$ under the
+$\mathbb{Z}^{m0}$-valued valuation attached to the height-one prime determined by $w$, again $0$ at
+$x = 0$. No normalisation of $\varphi$ is imposed: the image of a chosen uniformiser is not
+prescribed, only the equality of orders.
+
+This is the parameter-free form of the classical Laurent expansion of functions at a rational point
+of a curve: a place of degree one is the pull-back of the $T$-adic valuation of $K((T))$ along some
+$K$-embedding of the function field into Laurent series. It is used for the base change of a
+degree-one place to Laurent series and, on modular curves, in the count of normalised embeddings
+computing the order of $j$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_exists_algHom_laurentSeries_order_eq_ord.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_exists_algHom_laurentSeries_order_eq_ord
+
+noncomputable section
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_Place_exists_algHom_laurentSeries_order_eq_ord.AlgebraicCurve IsLocalRing \
+  ModularCurve"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg ord ord_coe_unit \
+  exists_unit_mul_zpow toValuationSubring mk"
+p2m_open "AlgebraicCurve.Place AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+private def resEquiv (w : Place K F) (hw : w.deg = 1) : K ≃+* w.ResidueField :=
+  RingEquiv.ofBijective (algebraMap K w.ResidueField)
+    (Algebra.finrank_eq_one_iff_bijective_algebraMap.mp hw)
+
+private theorem resEquiv_apply (w : Place K F) (hw : w.deg = 1) (a : K) :
+    resEquiv w hw a = algebraMap K w.ResidueField a := rfl
+
+private theorem residue_algebraMap (w : Place K F) (a : K) :
+    residue w.toValuationSubring (algebraMap K w.toValuationSubring a)
+      = algebraMap K w.ResidueField a := by
+  rw [IsScalarTower.algebraMap_apply K w.toValuationSubring w.ResidueField,
+    IsLocalRing.ResidueField.algebraMap_eq]
+
+private def resCoeff (w : Place K F) (hw : w.deg = 1) (y : w.toValuationSubring) : K :=
+  (resEquiv w hw).symm (residue w.toValuationSubring y)
+
+private theorem residue_sub_algebraMap_resCoeff (w : Place K F) (hw : w.deg = 1)
+    (y : w.toValuationSubring) :
+    residue w.toValuationSubring (y - algebraMap K w.toValuationSubring (resCoeff w hw y))
+      = 0 := by
+  rw [map_sub, residue_algebraMap,
+    show algebraMap K w.ResidueField (resCoeff w hw y)
+        = resEquiv w hw ((resEquiv w hw).symm (residue w.toValuationSubring y)) from rfl,
+    RingEquiv.apply_symm_apply, sub_self]
+
+private theorem exists_sub_resCoeff_eq_mul (w : Place K F) (hw : w.deg = 1)
+    {π : w.toValuationSubring} (hπ : Irreducible π) (y : w.toValuationSubring) :
+    ∃ z : w.toValuationSubring,
+      y - algebraMap K w.toValuationSubring (resCoeff w hw y) = π * z := by
+  have h := residue_sub_algebraMap_resCoeff w hw y
+  rw [residue_eq_zero_iff, hπ.maximalIdeal_eq, Ideal.mem_span_singleton] at h
+  exact h
+
+private def remSeq (w : Place K F) (hw : w.deg = 1) {π : w.toValuationSubring}
+    (hπ : Irreducible π) (y : w.toValuationSubring) : ℕ → w.toValuationSubring
+  | 0 => y
+  | n + 1 => (exists_sub_resCoeff_eq_mul w hw hπ (remSeq w hw hπ y n)).choose
+
+private theorem remSeq_spec (w : Place K F) (hw : w.deg = 1) {π : w.toValuationSubring}
+    (hπ : Irreducible π) (y : w.toValuationSubring) (n : ℕ) :
+    remSeq w hw hπ y n
+        - algebraMap K w.toValuationSubring (resCoeff w hw (remSeq w hw hπ y n))
+      = π * remSeq w hw hπ y (n + 1) :=
+  (exists_sub_resCoeff_eq_mul w hw hπ (remSeq w hw hπ y n)).choose_spec
+
+private def expCoeff (w : Place K F) (hw : w.deg = 1) {π : w.toValuationSubring}
+    (hπ : Irreducible π) (y : w.toValuationSubring) (n : ℕ) : K :=
+  resCoeff w hw (remSeq w hw hπ y n)
+
+private theorem remSeq_sum (w : Place K F) (hw : w.deg = 1) {π : w.toValuationSubring}
+    (hπ : Irreducible π) (y : w.toValuationSubring) (M : ℕ) :
+    y = (∑ n ∈ Finset.range M,
+          algebraMap K w.toValuationSubring (expCoeff w hw hπ y n) * π ^ n)
+        + π ^ M * remSeq w hw hπ y M := by
+  induction M with
+  | zero => simp [remSeq]
+  | succ M ih =>
+      have h : remSeq w hw hπ y M
+          = π * remSeq w hw hπ y (M + 1)
+            + algebraMap K w.toValuationSubring (expCoeff w hw hπ y M) := by
+        have hs := remSeq_spec w hw hπ y M
+        rw [sub_eq_iff_eq_add] at hs
+        exact hs
+      conv_lhs => rw [ih]
+      rw [Finset.sum_range_succ, add_assoc]
+      congr 1
+      rw [h]
+      ring
+
+private theorem remSeq_shift (w : Place K F) (hw : w.deg = 1) {π : w.toValuationSubring}
+    (hπ : Irreducible π) (y : w.toValuationSubring) :
+    ∀ n : ℕ, remSeq w hw hπ y (n + 1) = remSeq w hw hπ (remSeq w hw hπ y 1) n
+  | 0 => rfl
+  | n + 1 => by
+      change (exists_sub_resCoeff_eq_mul w hw hπ (remSeq w hw hπ y (n + 1))).choose
+        = remSeq w hw hπ (remSeq w hw hπ y 1) (n + 1)
+      rw [remSeq_shift w hw hπ y n]
+      rfl
+
+private theorem expCoeff_eq_of_eq_sum (w : Place K F) (hw : w.deg = 1)
+    {π : w.toValuationSubring} (hπ : Irreducible π) :
+    ∀ (M : ℕ) (y : w.toValuationSubring) (b : ℕ → K) (r : w.toValuationSubring),
+      y = (∑ n ∈ Finset.range M, algebraMap K w.toValuationSubring (b n) * π ^ n)
+          + π ^ M * r →
+      ∀ n < M, expCoeff w hw hπ y n = b n := by
+  intro M
+  induction M with
+  | zero => intro y b r _ n hn; exact absurd hn (Nat.not_lt_zero n)
+  | succ M ih =>
+      intro y b r h n hn
+      have hπ0 : residue w.toValuationSubring π = 0 := by
+        rw [residue_eq_zero_iff, IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+        exact hπ.not_isUnit
+      have hS : y = algebraMap K w.toValuationSubring (b 0)
+          + π * ((∑ k ∈ Finset.range M,
+              algebraMap K w.toValuationSubring (b (k + 1)) * π ^ k) + π ^ M * r) := by
+        have hfac : (∑ k ∈ Finset.range M,
+              algebraMap K w.toValuationSubring (b (k + 1)) * π ^ (k + 1))
+            = π * ∑ k ∈ Finset.range M,
+                algebraMap K w.toValuationSubring (b (k + 1)) * π ^ k := by
+          rw [Finset.mul_sum]
+          refine Finset.sum_congr rfl fun k _ => ?_
+          ring
+        rw [h, Finset.sum_range_succ', hfac]
+        ring
+      have hres : residue w.toValuationSubring y = algebraMap K w.ResidueField (b 0) := by
+        rw [hS, map_add, map_mul, hπ0, zero_mul, add_zero, residue_algebraMap]
+      have h0 : expCoeff w hw hπ y 0 = b 0 := by
+        change (resEquiv w hw).symm (residue w.toValuationSubring y) = b 0
+        rw [hres, ← resEquiv_apply w hw, RingEquiv.symm_apply_apply]
+      have hspec : y - algebraMap K w.toValuationSubring (resCoeff w hw y)
+          = π * remSeq w hw hπ y 1 := remSeq_spec w hw hπ y 0
+      have h1 : remSeq w hw hπ y 1
+          = (∑ k ∈ Finset.range M,
+              algebraMap K w.toValuationSubring (b (k + 1)) * π ^ k) + π ^ M * r := by
+        apply mul_left_cancel₀ hπ.ne_zero
+        rw [← hspec, show resCoeff w hw y = expCoeff w hw hπ y 0 from rfl, h0]
+        conv_lhs => rw [hS]
+        ring
+      rcases n with _ | k
+      · exact h0
+      · have hshift : expCoeff w hw hπ y (k + 1)
+            = expCoeff w hw hπ (remSeq w hw hπ y 1) k := by
+          change resCoeff w hw (remSeq w hw hπ y (k + 1))
+            = resCoeff w hw (remSeq w hw hπ (remSeq w hw hπ y 1) k)
+          rw [remSeq_shift]
+        rw [hshift]
+        exact ih (remSeq w hw hπ y 1) (fun j => b (j + 1)) r h1 k (by omega)
+
+private theorem sum_single_coeff (w : Place K F) {π : w.toValuationSubring} (M j : ℕ)
+    (hj : j < M) (a : K) :
+    (∑ k ∈ Finset.range M,
+        algebraMap K w.toValuationSubring (if k = j then a else 0) * π ^ k)
+      = algebraMap K w.toValuationSubring a * π ^ j := by
+  rw [Finset.sum_eq_single j]
+  · rw [ite_eq_left rfl]
+  · intro k _ hk
+    rw [ite_eq_right hk, map_zero, zero_mul]
+  · intro hj'
+    exact absurd (Finset.mem_range.mpr hj) hj'
+
+private def expPS (w : Place K F) (hw : w.deg = 1) {π : w.toValuationSubring}
+    (hπ : Irreducible π) : w.toValuationSubring →+* PowerSeries K where
+  toFun y := PowerSeries.mk (expCoeff w hw hπ y)
+  map_one' := by
+    ext n
+    rw [PowerSeries.coeff_mk, PowerSeries.coeff_one]
+    have hident : (1 : w.toValuationSubring)
+        = (∑ k ∈ Finset.range (n + 1),
+            algebraMap K w.toValuationSubring (if k = 0 then (1 : K) else 0) * π ^ k)
+          + π ^ (n + 1) * 0 := by
+      rw [mul_zero, add_zero, sum_single_coeff w (n + 1) 0 n.succ_pos 1, map_one, pow_zero,
+        mul_one]
+    exact expCoeff_eq_of_eq_sum w hw hπ (n + 1) 1
+      (fun j => if j = 0 then (1 : K) else 0) 0 hident n n.lt_succ_self
+  map_mul' y z := by
+    ext n
+    rw [PowerSeries.coeff_mk]
+    have hprod : ∀ d < n + 1,
+        (PowerSeries.trunc (n + 1) (PowerSeries.mk (expCoeff w hw hπ y))
+            * PowerSeries.trunc (n + 1) (PowerSeries.mk (expCoeff w hw hπ z))).coeff d
+          = PowerSeries.coeff d
+              (PowerSeries.mk (expCoeff w hw hπ y) * PowerSeries.mk (expCoeff w hw hπ z)) := by
+      intro d hd
+      rw [Polynomial.coeff_mul, PowerSeries.coeff_mul]
+      refine Finset.sum_congr rfl fun x hx => ?_
+      rw [Finset.HasAntidiagonal.mem_antidiagonal] at hx
+      rw [PowerSeries.coeff_trunc, PowerSeries.coeff_trunc, ite_eq_left (by omega),
+        ite_eq_left (by omega)]
+    obtain ⟨Q, hQ⟩ : ∃ Q : Polynomial K,
+        PowerSeries.trunc (n + 1) (PowerSeries.mk (expCoeff w hw hπ y))
+            * PowerSeries.trunc (n + 1) (PowerSeries.mk (expCoeff w hw hπ z))
+          = PowerSeries.trunc (n + 1)
+              (PowerSeries.mk (expCoeff w hw hπ y) * PowerSeries.mk (expCoeff w hw hπ z))
+            + Polynomial.X ^ (n + 1) * Q := by
+      have hdvd : Polynomial.X ^ (n + 1) ∣
+          (PowerSeries.trunc (n + 1) (PowerSeries.mk (expCoeff w hw hπ y))
+              * PowerSeries.trunc (n + 1) (PowerSeries.mk (expCoeff w hw hπ z))
+            - PowerSeries.trunc (n + 1)
+                (PowerSeries.mk (expCoeff w hw hπ y)
+                  * PowerSeries.mk (expCoeff w hw hπ z))) := by
+        rw [Polynomial.X_pow_dvd_iff]
+        intro d hd
+        rw [Polynomial.coeff_sub, hprod d hd, PowerSeries.coeff_trunc, ite_eq_left hd, sub_self]
+      obtain ⟨Q, hQ⟩ := hdvd
+      refine ⟨Q, ?_⟩
+      rw [← hQ]
+      ring
+    have hyev : y = Polynomial.eval₂ (algebraMap K w.toValuationSubring) π
+          (PowerSeries.trunc (n + 1) (PowerSeries.mk (expCoeff w hw hπ y)))
+        + π ^ (n + 1) * remSeq w hw hπ y (n + 1) := by
+      rw [PowerSeries.eval₂_trunc_eq_sum_range]
+      simp only [PowerSeries.coeff_mk]
+      exact remSeq_sum w hw hπ y (n + 1)
+    have hzev : z = Polynomial.eval₂ (algebraMap K w.toValuationSubring) π
+          (PowerSeries.trunc (n + 1) (PowerSeries.mk (expCoeff w hw hπ z)))
+        + π ^ (n + 1) * remSeq w hw hπ z (n + 1) := by
+      rw [PowerSeries.eval₂_trunc_eq_sum_range]
+      simp only [PowerSeries.coeff_mk]
+      exact remSeq_sum w hw hπ z (n + 1)
+    have hAB : Polynomial.eval₂ (algebraMap K w.toValuationSubring) π
+          (PowerSeries.trunc (n + 1) (PowerSeries.mk (expCoeff w hw hπ y)))
+        * Polynomial.eval₂ (algebraMap K w.toValuationSubring) π
+            (PowerSeries.trunc (n + 1) (PowerSeries.mk (expCoeff w hw hπ z)))
+        = (∑ k ∈ Finset.range (n + 1),
+            algebraMap K w.toValuationSubring
+                (PowerSeries.coeff k
+                  (PowerSeries.mk (expCoeff w hw hπ y)
+                    * PowerSeries.mk (expCoeff w hw hπ z)))
+              * π ^ k)
+          + π ^ (n + 1) * Polynomial.eval₂ (algebraMap K w.toValuationSubring) π Q := by
+      rw [← Polynomial.eval₂_mul, hQ, Polynomial.eval₂_add, Polynomial.eval₂_mul,
+        Polynomial.eval₂_X_pow, PowerSeries.eval₂_trunc_eq_sum_range]
+    set p := π ^ (n + 1)
+    set A := Polynomial.eval₂ (algebraMap K w.toValuationSubring) π
+      (PowerSeries.trunc (n + 1) (PowerSeries.mk (expCoeff w hw hπ y)))
+    set B := Polynomial.eval₂ (algebraMap K w.toValuationSubring) π
+      (PowerSeries.trunc (n + 1) (PowerSeries.mk (expCoeff w hw hπ z)))
+    set ry := remSeq w hw hπ y (n + 1)
+    set rz := remSeq w hw hπ z (n + 1)
+    set EQ := Polynomial.eval₂ (algebraMap K w.toValuationSubring) π Q
+    have hident : y * z
+        = (∑ k ∈ Finset.range (n + 1),
+            algebraMap K w.toValuationSubring
+                (PowerSeries.coeff k
+                  (PowerSeries.mk (expCoeff w hw hπ y)
+                    * PowerSeries.mk (expCoeff w hw hπ z)))
+              * π ^ k)
+          + p * (EQ + (A * rz + ry * B + p * (ry * rz))) := by
+      conv_lhs => rw [hyev, hzev]
+      rw [show (A + p * ry) * (B + p * rz)
+          = A * B + p * (A * rz + ry * B + p * (ry * rz)) from by ring, hAB]
+      ring
+    exact expCoeff_eq_of_eq_sum w hw hπ (n + 1) (y * z)
+      (fun j => PowerSeries.coeff j
+        (PowerSeries.mk (expCoeff w hw hπ y) * PowerSeries.mk (expCoeff w hw hπ z)))
+      (EQ + (A * rz + ry * B + p * (ry * rz))) hident n n.lt_succ_self
+  map_zero' := by
+    ext n
+    rw [PowerSeries.coeff_mk, map_zero]
+    have hident : (0 : w.toValuationSubring)
+        = (∑ k ∈ Finset.range (n + 1),
+            algebraMap K w.toValuationSubring ((0 : K)) * π ^ k)
+          + π ^ (n + 1) * 0 := by
+      simp
+    exact expCoeff_eq_of_eq_sum w hw hπ (n + 1) 0 (fun _ => (0 : K)) 0 hident n
+      n.lt_succ_self
+  map_add' y z := by
+    ext n
+    rw [PowerSeries.coeff_mk, map_add, PowerSeries.coeff_mk, PowerSeries.coeff_mk]
+    have hident : y + z
+        = (∑ k ∈ Finset.range (n + 1),
+            algebraMap K w.toValuationSubring
+                (expCoeff w hw hπ y k + expCoeff w hw hπ z k) * π ^ k)
+          + π ^ (n + 1) * (remSeq w hw hπ y (n + 1) + remSeq w hw hπ z (n + 1)) := by
+      conv_lhs => rw [remSeq_sum w hw hπ y (n + 1), remSeq_sum w hw hπ z (n + 1)]
+      simp only [map_add, add_mul, Finset.sum_add_distrib, mul_add]
+      ring
+    exact expCoeff_eq_of_eq_sum w hw hπ (n + 1) (y + z)
+      (fun j => expCoeff w hw hπ y j + expCoeff w hw hπ z j)
+      _ hident n n.lt_succ_self
+
+private theorem coeff_expPS (w : Place K F) (hw : w.deg = 1) {π : w.toValuationSubring}
+    (hπ : Irreducible π) (y : w.toValuationSubring) (n : ℕ) :
+    PowerSeries.coeff n (expPS w hw hπ y) = expCoeff w hw hπ y n :=
+  PowerSeries.coeff_mk n (expCoeff w hw hπ y)
+
+private theorem expPS_algebraMap (w : Place K F) (hw : w.deg = 1) {π : w.toValuationSubring}
+    (hπ : Irreducible π) (a : K) :
+    expPS w hw hπ (algebraMap K w.toValuationSubring a) = PowerSeries.C a := by
+  ext n
+  rw [coeff_expPS, PowerSeries.coeff_C]
+  have hident : algebraMap K w.toValuationSubring a
+      = (∑ k ∈ Finset.range (n + 1),
+          algebraMap K w.toValuationSubring (if k = 0 then a else 0) * π ^ k)
+        + π ^ (n + 1) * 0 := by
+    rw [mul_zero, add_zero, sum_single_coeff w (n + 1) 0 n.succ_pos a, pow_zero, mul_one]
+  exact expCoeff_eq_of_eq_sum w hw hπ (n + 1) _ (fun j => if j = 0 then a else 0) 0 hident n
+    n.lt_succ_self
+
+private theorem expPS_self (w : Place K F) (hw : w.deg = 1) {π : w.toValuationSubring}
+    (hπ : Irreducible π) : expPS w hw hπ π = PowerSeries.X := by
+  ext n
+  rw [coeff_expPS, PowerSeries.coeff_X]
+  rcases n with _ | m
+  · have hident : π = (∑ k ∈ Finset.range 1,
+          algebraMap K w.toValuationSubring ((0 : K)) * π ^ k)
+        + π ^ 1 * 1 := by
+      simp
+    exact expCoeff_eq_of_eq_sum w hw hπ 1 π (fun _ => (0 : K)) 1 hident 0 Nat.one_pos
+  · have hident : π = (∑ k ∈ Finset.range (m + 2),
+          algebraMap K w.toValuationSubring (if k = 1 then (1 : K) else 0) * π ^ k)
+        + π ^ (m + 2) * 0 := by
+      rw [mul_zero, add_zero, sum_single_coeff w (m + 2) 1 (by omega) 1, map_one, pow_one,
+        one_mul]
+    exact expCoeff_eq_of_eq_sum w hw hπ (m + 2) π (fun j => if j = 1 then (1 : K) else 0) 0
+      hident (m + 1) (by omega)
+
+private theorem ord_coe_nonneg (w : Place K F) {y : w.toValuationSubring} (hy : y ≠ 0) :
+    0 ≤ w.ord (y : F) := by
+  by_contra hneg
+  rw [not_le] at hneg
+  obtain ⟨π₀, hπ₀⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  have hyF : (y : F) ≠ 0 := by simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hy
+  have hπ₀F : (π₀ : F) ≠ 0 := by simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ₀.ne_zero
+  obtain ⟨u, hu⟩ := w.exists_unit_mul_zpow hyF hπ₀
+  set n0 := w.ord (y : F) with hn0
+  obtain ⟨m, hm⟩ : ∃ m : ℕ, (-n0).toNat = m + 1 := ⟨(-n0).toNat - 1, by omega⟩
+  have hmul : (y : F) * (π₀ : F) ^ ((-n0).toNat)
+      = ((u : w.toValuationSubring) : F) := by
+    rw [hu, mul_assoc, ← zpow_natCast ((π₀ : F)), ← zpow_add₀ hπ₀F,
+      show n0 + (((-n0).toNat : ℕ) : ℤ) = 0 from by omega, zpow_zero, mul_one]
+  have hOw : y * π₀ ^ (m + 1) = (u : w.toValuationSubring) := by
+    apply Subtype.coe_injective
+    push_cast
+    rw [← hm]
+    exact hmul
+  have hunit : IsUnit π₀ :=
+    isUnit_of_dvd_unit ⟨y * π₀ ^ m, by rw [← hOw]; ring⟩ u.isUnit
+  exact hπ₀.not_isUnit hunit
+
+private theorem exists_unit_mul_pow (w : Place K F) {y : w.toValuationSubring} (hy : y ≠ 0)
+    {π : w.toValuationSubring} (hπ : Irreducible π) :
+    ∃ u : w.toValuationSubringˣ,
+      y = (u : w.toValuationSubring) * π ^ (w.ord (y : F)).toNat := by
+  have hyF : (y : F) ≠ 0 := by simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hy
+  obtain ⟨u, hu⟩ := w.exists_unit_mul_zpow hyF hπ
+  set n0 := w.ord (y : F) with hn0
+  have h0 : 0 ≤ n0 := by rw [hn0]; exact ord_coe_nonneg w hy
+  refine ⟨u, Subtype.coe_injective ?_⟩
+  push_cast
+  rw [hu, ← zpow_natCast ((π : F)), Int.toNat_of_nonneg h0]
+
+private theorem expCoeff_eq_zero_of_lt_ord (w : Place K F) (hw : w.deg = 1)
+    {π : w.toValuationSubring} (hπ : Irreducible π) {y : w.toValuationSubring} (hy : y ≠ 0)
+    {n : ℕ} (hn : (n : ℤ) < w.ord (y : F)) : expCoeff w hw hπ y n = 0 := by
+  obtain ⟨u, hu⟩ := exists_unit_mul_pow w hy hπ
+  have hident : y = (∑ k ∈ Finset.range ((w.ord (y : F)).toNat),
+        algebraMap K w.toValuationSubring ((0 : K)) * π ^ k)
+      + π ^ ((w.ord (y : F)).toNat) * (u : w.toValuationSubring) := by
+    conv_lhs => rw [hu]
+    simp [mul_comm]
+  exact expCoeff_eq_of_eq_sum w hw hπ ((w.ord (y : F)).toNat) y (fun _ => (0 : K))
+    (u : w.toValuationSubring) hident n (by omega)
+
+private theorem expCoeff_ord_toNat_ne_zero (w : Place K F) (hw : w.deg = 1)
+    {π : w.toValuationSubring} (hπ : Irreducible π) {y : w.toValuationSubring} (hy : y ≠ 0) :
+    expCoeff w hw hπ y ((w.ord (y : F)).toNat) ≠ 0 := by
+  obtain ⟨u, hu⟩ := exists_unit_mul_pow w hy hπ
+  have hrem : remSeq w hw hπ y ((w.ord (y : F)).toNat) = (u : w.toValuationSubring) := by
+    have hsum := remSeq_sum w hw hπ y ((w.ord (y : F)).toNat)
+    have hz : ∀ k ∈ Finset.range ((w.ord (y : F)).toNat),
+        algebraMap K w.toValuationSubring (expCoeff w hw hπ y k) * π ^ k = 0 := by
+      intro k hk
+      rw [Finset.mem_range] at hk
+      rw [expCoeff_eq_zero_of_lt_ord w hw hπ hy (by
+        have := ord_coe_nonneg w hy
+        omega), map_zero, zero_mul]
+    rw [Finset.sum_eq_zero hz, zero_add] at hsum
+    apply mul_left_cancel₀ (pow_ne_zero ((w.ord (y : F)).toNat) hπ.ne_zero)
+    rw [← hsum]
+    conv_lhs => rw [hu]
+    exact mul_comm _ _
+  change resCoeff w hw (remSeq w hw hπ y ((w.ord (y : F)).toNat)) ≠ 0
+  rw [hrem]
+  have hres : residue w.toValuationSubring (u : w.toValuationSubring) ≠ 0 :=
+    (residue_ne_zero_iff_isUnit _).mpr u.isUnit
+  intro h0
+  apply hres
+  have h0' : (resEquiv w hw).symm
+      (residue w.toValuationSubring (u : w.toValuationSubring)) = 0 := h0
+  have h := congrArg (resEquiv w hw) h0'
+  rwa [RingEquiv.apply_symm_apply, map_zero] at h
+
+private theorem ofPowerSeries_expPS_ne_zero (w : Place K F) (hw : w.deg = 1)
+    {π : w.toValuationSubring} (hπ : Irreducible π) {y : w.toValuationSubring} (hy : y ≠ 0) :
+    HahnSeries.ofPowerSeries ℤ K (expPS w hw hπ y) ≠ 0 := by
+  have h : (HahnSeries.ofPowerSeries ℤ K (expPS w hw hπ y)).coeff
+      (((w.ord (y : F)).toNat : ℤ)) ≠ 0 := by
+    rw [HahnSeries.ofPowerSeries_apply_coeff, coeff_expPS]
+    exact expCoeff_ord_toNat_ne_zero w hw hπ hy
+  exact HahnSeries.ne_zero_of_coeff_ne_zero h
+
+private theorem order_ofPowerSeries_expPS (w : Place K F) (hw : w.deg = 1)
+    {π : w.toValuationSubring} (hπ : Irreducible π) {y : w.toValuationSubring} (hy : y ≠ 0) :
+    (HahnSeries.ofPowerSeries ℤ K (expPS w hw hπ y)).order = w.ord (y : F) := by
+  have hx0 := ofPowerSeries_expPS_ne_zero w hw hπ hy
+  have hcoeff : (HahnSeries.ofPowerSeries ℤ K (expPS w hw hπ y)).coeff
+      ((((w.ord (y : F)).toNat : ℕ) : ℤ)) ≠ 0 := by
+    rw [HahnSeries.ofPowerSeries_apply_coeff, coeff_expPS]
+    exact expCoeff_ord_toNat_ne_zero w hw hπ hy
+  have hle : (HahnSeries.ofPowerSeries ℤ K (expPS w hw hπ y)).order
+      ≤ (((w.ord (y : F)).toNat : ℕ) : ℤ) := HahnSeries.order_le_of_coeff_ne_zero hcoeff
+  have hge : ¬ (HahnSeries.ofPowerSeries ℤ K (expPS w hw hπ y)).order
+      < (((w.ord (y : F)).toNat : ℕ) : ℤ) := by
+    intro hlt
+    have horder : (HahnSeries.ofPowerSeries ℤ K (expPS w hw hπ y)).coeff
+        (HahnSeries.ofPowerSeries ℤ K (expPS w hw hπ y)).order ≠ 0 :=
+      HahnSeries.coeff_order_eq_zero.not.mpr hx0
+    rcases lt_or_ge (HahnSeries.ofPowerSeries ℤ K (expPS w hw hπ y)).order 0 with hneg | hpos
+    · apply horder
+      rw [HahnSeries.ofPowerSeries_apply]
+      refine HahnSeries.embDomain_of_notMem_range ?_
+      rintro ⟨j, hj⟩
+      have hj' : ((j : ℤ))
+          = (HahnSeries.ofPowerSeries ℤ K (expPS w hw hπ y)).order := hj
+      omega
+    · obtain ⟨j, hj⟩ := Int.eq_ofNat_of_zero_le hpos
+      apply horder
+      rw [hj, HahnSeries.ofPowerSeries_apply_coeff, coeff_expPS]
+      refine expCoeff_eq_zero_of_lt_ord w hw hπ hy ?_
+      have h0 := ord_coe_nonneg w hy
+      omega
+  rw [not_lt] at hge
+  rw [le_antisymm hle hge, Int.toNat_of_nonneg (ord_coe_nonneg w hy)]
+
+private theorem exists_irreducible_coe_of_ord_eq_one (w : Place K F) {t : F}
+    (ht : w.ord t = 1) :
+    ∃ tO : w.toValuationSubring, (tO : F) = t ∧ Irreducible tO := by
+  have ht0 : t ≠ 0 := by
+    intro h
+    rw [h] at ht
+    simp at ht
+  obtain ⟨π₀, hπ₀⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  obtain ⟨u, hu⟩ := w.exists_unit_mul_zpow ht0 hπ₀
+  rw [ht, zpow_one] at hu
+  refine ⟨(u : w.toValuationSubring) * π₀, ?_, ?_⟩
+  · push_cast
+    exact hu.symm
+  · exact Associated.irreducible ⟨u, mul_comm π₀ (u : w.toValuationSubring)⟩ hπ₀
+
+private theorem exists_algHom_laurentSeries_of_irreducible (w : Place K F) (hw : w.deg = 1)
+    {π : w.toValuationSubring} (hπ : Irreducible π) :
+    ∃ φ : F →ₐ[K] LaurentSeries K,
+      φ (π : F) = HahnSeries.single (1 : ℤ) (1 : K) ∧ ∀ x : F, (φ x).order = w.ord x := by
+  have hinj : Function.Injective ((HahnSeries.ofPowerSeries ℤ K).comp (expPS w hw hπ)) :=
+    (injective_iff_map_eq_zero _).2 fun y hy =>
+      by_contra fun hy0 => ofPowerSeries_expPS_ne_zero w hw hπ hy0 hy
+  let φ₀ : F →+* LaurentSeries K := IsFractionRing.lift hinj
+  have hφ₀ : ∀ y : w.toValuationSubring,
+      φ₀ (y : F) = HahnSeries.ofPowerSeries ℤ K (expPS w hw hπ y) :=
+    fun y => IsFractionRing.lift_algebraMap hinj y
+  have hcomm : ∀ c : K, φ₀ (algebraMap K F c) = algebraMap K (LaurentSeries K) c := by
+    intro c
+    rw [← w.coe_algebraMap c, hφ₀, expPS_algebraMap, HahnSeries.ofPowerSeries_C,
+      algebraMap_laurentSeries_eq_single]
+    rfl
+  refine ⟨{ φ₀ with commutes' := hcomm }, ?_, fun x => ?_⟩
+  · change φ₀ (π : F) = _
+    rw [hφ₀, expPS_self, HahnSeries.ofPowerSeries_X]
+  · change (φ₀ x).order = w.ord x
+    rcases eq_or_ne x 0 with rfl | hx
+    · simp
+    obtain ⟨u, hu⟩ := w.exists_unit_mul_zpow hx hπ
+    have hπ1 : φ₀ (π : F) = HahnSeries.single (1 : ℤ) (1 : K) := by
+      rw [hφ₀, expPS_self, HahnSeries.ofPowerSeries_X]
+    have hu0 : (u : w.toValuationSubring) ≠ 0 := u.ne_zero
+    have hφu0 : φ₀ ((u : w.toValuationSubring) : F) ≠ 0 := by
+      rw [hφ₀]
+      exact ofPowerSeries_expPS_ne_zero w hw hπ hu0
+    have hφu : (φ₀ ((u : w.toValuationSubring) : F)).order = 0 := by
+      rw [hφ₀, order_ofPowerSeries_expPS w hw hπ hu0, w.ord_coe_unit]
+    have h1 : φ₀ x = φ₀ ((u : w.toValuationSubring) : F)
+        * HahnSeries.single (1 : ℤ) (1 : K) ^ w.ord x := by
+      rw [congrArg φ₀ hu, map_mul, map_zpow₀, hπ1]
+    rw [h1, HahnSeries.order_mul hφu0
+        (zpow_ne_zero _ (HahnSeries.single_ne_zero one_ne_zero)),
+      hφu, zero_add, ← RatFunc.single_zpow, HahnSeries.order_single one_ne_zero]
+
+end AlgebraicCurve.Place
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg ord ord_coe_unit \
+  exists_unit_mul_zpow toValuationSubring mk"
+end AlgebraicCurve.Place
+p2m_open_scoped "AlgebraicCurve AlgebraicCurve.Place" in
+private theorem AlgebraicCurve.Place.exists_algHom_laurentSeries_of_deg_eq_one
+    {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F) (hw : w.deg = 1)
+    (t : F) (ht : w.ord t = 1) :
+    ∃ φ : F →ₐ[K] LaurentSeries K,
+      φ t = HahnSeries.single (1 : ℤ) (1 : K) ∧ ∀ x : F, (φ x).order = w.ord x := by
+  obtain ⟨π, rfl, hπ⟩ := AlgebraicCurve.Place.exists_irreducible_coe_of_ord_eq_one w ht
+  exact AlgebraicCurve.Place.exists_algHom_laurentSeries_of_irreducible w hw hπ
+
+p2m_open_scoped "AlgebraicCurve AlgebraicCurve.Place" in
+private theorem AlgebraicCurve.Place.exists_algHom_laurentSeries_order_eq_ord
+    {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F) (hw : w.deg = 1) :
+    ∃ φ : F →ₐ[K] LaurentSeries K, ∀ x : F, (φ x).order = w.ord x := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  obtain ⟨φ, -, hφ⟩ := AlgebraicCurve.Place.exists_algHom_laurentSeries_of_irreducible w hw hπ
+  exact ⟨φ, hφ⟩
+
+end
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_Place_exists_algHom_laurentSeries_order_eq_ord.AlgebraicCurve
+  ModularCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F) (hw : w.deg = 1) :
+    ∃ φ : F →ₐ[K] LaurentSeries K, ∀ x : F, (φ x).order = w.ord x :=
+  AlgebraicCurve.Place.exists_algHom_laurentSeries_order_eq_ord w hw
+
+end S_AlgebraicCurve_Place_exists_algHom_laurentSeries_order_eq_ord
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_exists_algHom_laurentSeries_order_eq_ord (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve ModularCurve
+theorem AlgebraicCurve.Place.exists_algHom_laurentSeries_order_eq_ord {K F : Type*} [Field K]
+    [Field F] [Algebra K F] (w : Place K F) (hw : w.deg = 1) :
+    ∃ φ : F →ₐ[K] LaurentSeries K, ∀ x : F, (φ x).order = w.ord x :=
+  solution w hw
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_comap_algebraMap_eq_of_constantFieldExtension.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_comap_algebraMap_eq_of_constantFieldExtension.lean
new file mode 100644
index 0000000000..ab9ced8c27
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_comap_algebraMap_eq_of_constantFieldExtension.lean
@@ -0,0 +1,703 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.exists_comap_algebraMap_eq_of_constantFieldExtension
+(359242ad-b424-5a5d-ad94-410d8113bd5e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e7475eae-079a-59ef-9d75-4b013eb2a7d4
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import Mathlib.RingTheory.Valuation.LocalSubring
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_linearIndependent_of_constantFieldExtension
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Unique unramified place above P in a constant-field extension
+
+Theorem statement: `AlgebraicCurve.Place.exists_comap_algebraMap_eq_of_constantFieldExtension`
+(`359242ad-b424-5a5d-ad94-410d8113bd5e`), by Claude, 2026-09-05.
+
+Proof: submission `e7475eae-079a-59ef-9d75-4b013eb2a7d4`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $K'$, $F'$ be fields with $F$ a $K$-algebra, $F'$ a $K'$-algebra, $K'$ a $K$-algebra,
+$F'$ an $F$-algebra and also a $K$-algebra, the two towers $K \subseteq K' \subseteq F'$ and $K
+\subseteq F \subseteq F'$ being compatible; assume $K$ algebraically closed of characteristic $0$.
+Assume $F$ is finitely generated of transcendence degree one over $K$ in the sense that there is $x
+\in F$ transcendental over $K$ with $F$ finite-dimensional over $K(x)$, and likewise $F'$ over $K'$
+with some transcendental $x \in F'$; assume `IsCurveOver K F`, i.e. every nonzero $f \in F$ has a
+degree-zero divisor whose coefficient at each place $v$ is $v.\mathrm{ord}\,f$, every place of $F/K$
+has residue field finite over $K$, and $\Omega_{F/K}$ is free of rank one over $F$; and assume $F'$
+is generated over $K'$ by the image of $F$, i.e. the $K'$-subfield of $F'$ generated by the range of
+$F \to F'$ is everything. Then for every place $P$ of $F/K$ (a valuation subring of $F$ containing
+$K$, not all of $F$, and a principal ideal ring) there exists a place $P'$ of $F'/K'$ whose
+valuation subring pulls back along $F \to F'$ to that of $P$, such that $P'.\mathrm{ord}$ of the
+image of any $f \in F$ equals $P.\mathrm{ord}\,f$, and such that any place $Q'$ of $F'/K'$ whose
+valuation subring pulls back to that of $P$ equals $P'$.
+
+This is the classical statement that in a constant-field extension $F' = FK'$ of a function field
+over an algebraically closed base field every place of $F/K$ has exactly one extension to $F'/K'$,
+and that extension is unramified with the same normalised order function on $F$. It underlies the
+comparison of divisors, divisor classes and regular differentials under constant-field extension,
+and is used in particular for the conorm map on degree-zero divisors and for the transfer of regular
+differentials.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_exists_comap_algebraMap_eq_of_constantFieldExtension.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_exists_comap_algebraMap_eq_of_constantFieldExtension
+
+open AlgebraicCurve
+
+namespace W7XUnram
+
+section Basic
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+theorem ord_nonneg_of_mem {f : F} (hf : f ∈ v.toValuationSubring) : 0 ≤ v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨n, u, hu⟩ :=
+    IsDiscreteValuationRing.eq_unit_mul_pow_irreducible
+      (x := (⟨f, hf⟩ : v.toValuationSubring)) (by simpa [Subtype.ext_iff] using hf0) hπ
+  have hcoe : f = ((u : v.toValuationSubring) : F) * ((π : F) ^ (n : ℤ)) := by
+    have h := congrArg (Subtype.val) hu
+    push_cast at h
+    rw [zpow_natCast]
+    exact h
+  rw [hcoe, v.ord_unit_smul_zpow u hπ (n : ℤ)]
+  exact Int.natCast_nonneg n
+
+theorem ord_eq_zero_of_mem_of_inv_mem {f : F} (h1 : f ∈ v.toValuationSubring)
+    (h2 : f⁻¹ ∈ v.toValuationSubring) : v.ord f = 0 := by
+  have a := ord_nonneg_of_mem v h1
+  have b := ord_nonneg_of_mem v h2
+  rw [v.ord_inv] at b
+  omega
+
+theorem one_le_ord_of_mem_of_inv_not_mem {f : F} (h1 : f ∈ v.toValuationSubring)
+    (h2 : f⁻¹ ∉ v.toValuationSubring) : 1 ≤ v.ord f := by
+  have hf0 : f ≠ 0 := by
+    rintro rfl
+    exact h2 (by simp)
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf0 hπ
+  have h0 := ord_nonneg_of_mem v h1
+  by_contra hlt
+  have hz : v.ord f = 0 := by omega
+  apply h2
+  have hmul : ((u : v.toValuationSubring) : F) *
+      (((u⁻¹ : v.toValuationSubringˣ) : v.toValuationSubring) : F) = 1 := by
+    rw [← MulMemClass.coe_mul, Units.mul_inv, OneMemClass.coe_one]
+  rw [hu, hz, zpow_zero, mul_one, ← eq_inv_of_mul_eq_one_right hmul]
+  exact SetLike.coe_mem _
+
+theorem mem_iff_ord_nonneg (f : F) : f ∈ v.toValuationSubring ↔ 0 ≤ v.ord f := by
+  refine ⟨ord_nonneg_of_mem v, fun h => ?_⟩
+  by_contra hmem
+  have hinv : f⁻¹ ∈ v.toValuationSubring :=
+    (v.toValuationSubring.mem_or_inv_mem f).resolve_left hmem
+  have := one_le_ord_of_mem_of_inv_not_mem v hinv (by simpa using hmem)
+  rw [v.ord_inv] at this
+  omega
+
+theorem ord_algebraMap_eq_zero {L : Type*} [Field L] [Algebra F L] {K' : Type*} [Field K']
+    [Algebra K' L] (w : Place K' L) {f : F}
+    (h1 : algebraMap F L f ∈ w.toValuationSubring)
+    (h2 : algebraMap F L f⁻¹ ∈ w.toValuationSubring) : w.ord (algebraMap F L f) = 0 :=
+  ord_eq_zero_of_mem_of_inv_mem w h1 (by simpa using h2)
+
+end Basic
+
+section Psi
+
+variable {K F K' : Type*} (F' : Type*) [Field K] [Field F] [Field K'] [Field F']
+  [Algebra K F] [Algebra K' F'] [Algebra K K'] [Algebra F F'] [Algebra K F']
+  [IsScalarTower K K' F'] [IsScalarTower K F F']
+  {ι : Type*} (B : Module.Basis ι K K') (P : Place K F)
+
+noncomputable def Psi : (ι →₀ P.toValuationSubring) →+ F' :=
+  Finsupp.liftAddHom fun j =>
+    (AddMonoidHom.mulLeft (algebraMap K' F' (B j))).comp
+      ((algebraMap F F' : F →+* F').toAddMonoidHom.comp
+        P.toValuationSubring.subtype.toAddMonoidHom)
+
+omit [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F'] in
+theorem Psi_single (j : ι) (o : P.toValuationSubring) :
+    Psi F' B P (Finsupp.single j o) = algebraMap K' F' (B j) * algebraMap F F' (o : F) := by
+  simp [Psi]
+
+omit [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F'] in
+theorem Psi_apply (w : ι →₀ P.toValuationSubring) :
+    Psi F' B P w = w.sum fun j o => algebraMap K' F' (B j) * algebraMap F F' (o : F) := by
+  rw [Psi, Finsupp.liftAddHom_apply]
+  rfl
+
+omit [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F'] in
+theorem Psi_smul (s : P.toValuationSubring) (w : ι →₀ P.toValuationSubring) :
+    Psi F' B P (s • w) = algebraMap F F' (s : F) * Psi F' B P w := by
+  induction w using Finsupp.induction with
+  | zero => simp
+  | single_add a b f _ _ ih =>
+    rw [smul_add, map_add, map_add, ih, Finsupp.smul_single, Psi_single, Psi_single, mul_add,
+      smul_eq_mul, MulMemClass.coe_mul, map_mul]
+    ring
+
+noncomputable def pureW (d : K') (o : P.toValuationSubring) : ι →₀ P.toValuationSubring :=
+  (B.repr d).mapRange (fun a => algebraMap K P.toValuationSubring a * o) (by simp)
+
+theorem Psi_pureW (d : K') (o : P.toValuationSubring) :
+    Psi F' B P (pureW B P d o) = algebraMap K' F' d * algebraMap F F' (o : F) := by
+  rw [Psi_apply, pureW, Finsupp.sum_mapRange_index (fun j => by simp)]
+  conv_rhs => rw [← B.linearCombination_repr d, Finsupp.linearCombination_apply]
+  simp only [Finsupp.sum, map_sum, Finset.sum_mul]
+  refine Finset.sum_congr rfl fun j _ => ?_
+  rw [MulMemClass.coe_mul, Place.coe_algebraMap, map_mul, Algebra.smul_def, map_mul,
+    ← IsScalarTower.algebraMap_apply, ← IsScalarTower.algebraMap_apply]
+  ring
+
+theorem Psi_mul_mem_range (w₁ w₂ : ι →₀ P.toValuationSubring) :
+    ∃ w, Psi F' B P w = Psi F' B P w₁ * Psi F' B P w₂ := by
+  classical
+  refine ⟨∑ i ∈ w₁.support, ∑ j ∈ w₂.support, pureW B P (B i * B j) (w₁ i * w₂ j), ?_⟩
+  rw [map_sum, Psi_apply F' B P w₁, Finsupp.sum, Finset.sum_mul]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [map_sum, Psi_apply F' B P w₂, Finsupp.sum, Finset.mul_sum]
+  refine Finset.sum_congr rfl fun j _ => ?_
+  rw [Psi_pureW, map_mul, MulMemClass.coe_mul, map_mul]
+  ring
+
+noncomputable def rangePsi : Subring F' where
+  carrier := Set.range (Psi F' B P)
+  mul_mem' := by
+    rintro _ _ ⟨w₁, rfl⟩ ⟨w₂, rfl⟩
+    exact Psi_mul_mem_range F' B P w₁ w₂
+  one_mem' := ⟨pureW B P 1 1, by simp [Psi_pureW]⟩
+  add_mem' := by
+    rintro _ _ ⟨w₁, rfl⟩ ⟨w₂, rfl⟩
+    exact ⟨w₁ + w₂, map_add _ _ _⟩
+  zero_mem' := ⟨0, map_zero _⟩
+  neg_mem' := by
+    rintro _ ⟨w, rfl⟩
+    exact ⟨-w, map_neg _ _⟩
+
+theorem mem_rangePsi_iff {y : F'} : y ∈ rangePsi F' B P ↔ ∃ w, Psi F' B P w = y := Iff.rfl
+
+theorem algebraMap_mem_rangePsi (d : K') : algebraMap K' F' d ∈ rangePsi F' B P :=
+  ⟨pureW B P d 1, by simp [Psi_pureW]⟩
+
+theorem algebraMap_coe_mem_rangePsi (o : P.toValuationSubring) :
+    algebraMap F F' (o : F) ∈ rangePsi F' B P :=
+  ⟨pureW B P 1 o, by simp [Psi_pureW]⟩
+
+omit [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F'] in
+theorem Psi_mem {S : Type*} [SetLike S F'] [SubringClass S F'] (V : S)
+    (hK : ∀ d : K', algebraMap K' F' d ∈ V)
+    (hO : ∀ o : P.toValuationSubring, algebraMap F F' (o : F) ∈ V)
+    (w : ι →₀ P.toValuationSubring) : Psi F' B P w ∈ V := by
+  rw [Psi_apply]
+  exact sum_mem fun j _ => mul_mem (hK _) (hO _)
+
+noncomputable def fracPsi : Subalgebra K' F' where
+  carrier := {y | ∃ w, ∃ s : P.toValuationSubring, (s : F) ≠ 0 ∧
+    y * algebraMap F F' (s : F) = Psi F' B P w}
+  mul_mem' := by
+    rintro y₁ y₂ ⟨w₁, s₁, hs₁, h₁⟩ ⟨w₂, s₂, hs₂, h₂⟩
+    obtain ⟨w, hw⟩ := Psi_mul_mem_range F' B P w₁ w₂
+    refine ⟨w, s₁ * s₂, by rw [MulMemClass.coe_mul]; exact mul_ne_zero hs₁ hs₂, ?_⟩
+    rw [hw, ← h₁, ← h₂, MulMemClass.coe_mul, map_mul]
+    ring
+  one_mem' := ⟨pureW B P 1 1, 1, by simp, by simp [Psi_pureW]⟩
+  add_mem' := by
+    rintro y₁ y₂ ⟨w₁, s₁, hs₁, h₁⟩ ⟨w₂, s₂, hs₂, h₂⟩
+    refine ⟨s₂ • w₁ + s₁ • w₂, s₁ * s₂, by rw [MulMemClass.coe_mul]; exact mul_ne_zero hs₁ hs₂, ?_⟩
+    rw [map_add, Psi_smul, Psi_smul, ← h₁, ← h₂, MulMemClass.coe_mul, map_mul]
+    ring
+  zero_mem' := ⟨0, 1, by simp, by simp⟩
+  algebraMap_mem' d := ⟨pureW B P d 1, 1, by simp, by simp [Psi_pureW]⟩
+
+theorem mem_fracPsi_iff {y : F'} : y ∈ fracPsi F' B P ↔ ∃ w, ∃ s : P.toValuationSubring,
+    (s : F) ≠ 0 ∧ y * algebraMap F F' (s : F) = Psi F' B P w := Iff.rfl
+
+theorem algebraMap_mem_fracPsi (f : F) : algebraMap F F' f ∈ fracPsi F' B P := by
+  rcases P.toValuationSubring.mem_or_inv_mem f with h | h
+  · exact ⟨pureW B P 1 ⟨f, h⟩, 1, by simp, by simp [Psi_pureW]⟩
+  · rcases eq_or_ne f 0 with rfl | hf
+    · rw [map_zero]; exact (fracPsi F' B P).zero_mem
+    · refine ⟨pureW B P 1 1, ⟨f⁻¹, h⟩, by simpa using hf, ?_⟩
+      simp [Psi_pureW, mul_inv_cancel₀ ((map_ne_zero (algebraMap F F')).2 hf)]
+
+theorem exists_mul_Psi_eq (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤)
+    {z : F'} (hz : z ≠ 0) :
+    ∃ w₁ w₂, Psi F' B P w₂ ≠ 0 ∧ z * Psi F' B P w₂ = Psi F' B P w₁ := by
+  have hzmem : z ∈ IntermediateField.adjoin K' (Set.range (algebraMap F F')) := by
+    rw [hgen]; trivial
+  rw [IntermediateField.mem_adjoin_iff_div] at hzmem
+  obtain ⟨r, hr, s, hs, rfl⟩ := hzmem
+  have hle : Algebra.adjoin K' (Set.range (algebraMap F F')) ≤ fracPsi F' B P :=
+    Algebra.adjoin_le (by rintro _ ⟨f, rfl⟩; exact algebraMap_mem_fracPsi F' B P f)
+  obtain ⟨w₁, s₁, hs₁, h₁⟩ := hle hr
+  obtain ⟨w₂, s₂, hs₂, h₂⟩ := hle hs
+  have hr0 : r ≠ 0 := by rintro rfl; simp at hz
+  have hs0 : s ≠ 0 := by rintro rfl; simp at hz
+  refine ⟨s₂ • w₁, s₁ • w₂, ?_, ?_⟩
+  · rw [Psi_smul, ← h₂]
+    exact mul_ne_zero (by simpa using hs₁) (mul_ne_zero hs0 (by simpa using hs₂))
+  · rw [Psi_smul, Psi_smul, ← h₁, ← h₂]
+    field_simp
+
+end Psi
+
+theorem ne_zero_and_inv_mem_of_add {L : Type*} [Field L] (V : ValuationSubring L) {a m p : L}
+    (ha : a ∈ V) (hai : a⁻¹ ∈ V) (ha0 : a ≠ 0) (hm : m ∈ V) (hp : p ∈ V) (hpi : p⁻¹ ∉ V) :
+    a + p * m ≠ 0 ∧ (a + p * m)⁻¹ ∈ V := by
+  have hva : V.valuation a = 1 := by
+    refine le_antisymm ((V.valuation_le_one_iff a).2 ha) ?_
+    have h := (V.valuation_le_one_iff _).2 hai
+    rw [map_inv₀] at h
+    exact (inv_le_one₀ (zero_lt_iff.2 ((Valuation.ne_zero_iff _).2 ha0))).1 h
+  have hvp : V.valuation p < 1 :=
+    lt_of_le_of_ne ((V.valuation_le_one_iff p).2 hp)
+      (fun h => hpi (by rw [← V.valuation_le_one_iff, map_inv₀, h, inv_one]))
+  have hvm : V.valuation m ≤ 1 := (V.valuation_le_one_iff m).2 hm
+  have hlt : V.valuation (p * m) < V.valuation a := by
+    rw [map_mul, hva]
+    calc V.valuation p * V.valuation m ≤ V.valuation p * 1 := by gcongr
+      _ = V.valuation p := mul_one _
+      _ < 1 := hvp
+  have hve : V.valuation (a + p * m) = 1 := by
+    rw [Valuation.map_add_eq_of_lt_left _ hlt, hva]
+  refine ⟨(Valuation.ne_zero_iff _).1 (by rw [hve]; exact one_ne_zero), ?_⟩
+  rw [← V.valuation_le_one_iff, map_inv₀, hve, inv_one]
+
+section Decomp
+
+variable {K F K' : Type*} (F' : Type*) [Field K] [Field F] [Field K'] [Field F']
+  [Algebra K F] [Algebra K' F'] [Algebra K K'] [Algebra F F'] [Algebra K F']
+  [IsScalarTower K K' F'] [IsScalarTower K F F']
+  {ι : Type*} (B : Module.Basis ι K K') (P : Place K F)
+
+theorem exists_digit [IsAlgClosed K] [IsCurveOver K F] {π : P.toValuationSubring}
+    (hπ : Irreducible π) (o : P.toValuationSubring) :
+    ∃ a : K, ∃ o' : P.toValuationSubring,
+      o = algebraMap K P.toValuationSubring a + π * o' ∧ (o = 0 → o' = 0) := by
+  rcases eq_or_ne o 0 with rfl | ho
+  · exact ⟨0, 0, by simp, fun _ => rfl⟩
+  have : Module.Finite K P.ResidueField := IsCurveOver.finiteResidue P
+  have : Algebra.IsIntegral K P.ResidueField := Algebra.IsIntegral.of_finite K _
+  have hbij : Function.Bijective (algebraMap K P.ResidueField) :=
+    IsAlgClosed.algebraMap_bijective_of_isIntegral
+  obtain ⟨a, ha⟩ := hbij.2 (IsLocalRing.residue P.toValuationSubring o)
+  have hmem : o - algebraMap K P.toValuationSubring a ∈
+      IsLocalRing.maximalIdeal P.toValuationSubring := by
+    rw [← IsLocalRing.residue_eq_zero_iff, map_sub, sub_eq_zero, ← ha,
+      IsScalarTower.algebraMap_apply K P.toValuationSubring P.ResidueField,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  rw [hπ.maximalIdeal_eq, Ideal.mem_span_singleton'] at hmem
+  obtain ⟨b, hb⟩ := hmem
+  exact ⟨a, b, by rw [mul_comm, hb]; ring, fun h => absurd h ho⟩
+
+theorem decomp [IsAlgClosed K] [IsCurveOver K F] {π : P.toValuationSubring} (hπ : Irreducible π)
+    (w : ι →₀ P.toValuationSubring) (hw : w ≠ 0) :
+    ∃ (k : ℕ) (d : K') (w' : ι →₀ P.toValuationSubring), d ≠ 0 ∧
+      Psi F' B P w = algebraMap F F' (π : F) ^ k *
+        (algebraMap K' F' d + algebraMap F F' (π : F) * Psi F' B P w') := by
+  classical
+  choose dig rest hdr hr0 using exists_digit P hπ
+  have hrest0 : rest 0 = 0 := hr0 0 rfl
+  have step : ∀ w : ι →₀ P.toValuationSubring,
+      Psi F' B P w = algebraMap K' F' (∑ j ∈ w.support, dig (w j) • B j) +
+        algebraMap F F' (π : F) * Psi F' B P (w.mapRange rest hrest0) := by
+    intro w
+    rw [Psi_apply F' B P (w.mapRange _ _),
+      Finsupp.sum_mapRange_index (fun j => by simp)]
+    rw [Psi_apply]
+    simp only [Finsupp.sum, map_sum, Finset.mul_sum, ← Finset.sum_add_distrib]
+    refine Finset.sum_congr rfl fun j _ => ?_
+    conv_lhs => rw [hdr (w j)]
+    rw [AddMemClass.coe_add, MulMemClass.coe_mul, Place.coe_algebraMap, map_add, map_mul,
+      Algebra.smul_def, map_mul, ← IsScalarTower.algebraMap_apply K K' F',
+      ← IsScalarTower.algebraMap_apply K F F']
+    ring
+  suffices h : ∀ (n : ℕ) (w : ι →₀ P.toValuationSubring) (j₁ : ι), w j₁ ≠ 0 →
+      P.ord ((w j₁ : P.toValuationSubring) : F) < n →
+      ∃ (k : ℕ) (d : K') (w' : ι →₀ P.toValuationSubring), d ≠ 0 ∧
+        Psi F' B P w = algebraMap F F' (π : F) ^ k *
+          (algebraMap K' F' d + algebraMap F F' (π : F) * Psi F' B P w') by
+    obtain ⟨j₁, hj₁⟩ : ∃ j₁, w j₁ ≠ 0 := by
+      by_contra h
+      push Not at h
+      exact hw (Finsupp.ext h)
+    exact h ((P.ord ((w j₁ : P.toValuationSubring) : F)).toNat + 1) w j₁ hj₁ (by omega)
+  intro n
+  induction n with
+  | zero =>
+    intro w j₁ _ hlt
+    have := ord_nonneg_of_mem P (w j₁).2
+    push_cast at hlt
+    omega
+  | succ n ih =>
+    intro w j₁ hj₁ hlt
+    by_cases hdig : ∃ j ∈ w.support, dig (w j) ≠ 0
+    · refine ⟨0, ∑ j ∈ w.support, dig (w j) • B j, w.mapRange rest hrest0, ?_, ?_⟩
+      · intro hd
+        obtain ⟨j, hj, hne⟩ := hdig
+        exact hne (linearIndependent_iff'.1 B.linearIndependent w.support (fun j => dig (w j))
+          hd j hj)
+      · rw [pow_zero, one_mul]
+        exact step w
+    · push Not at hdig
+      have hd0 : ∑ j ∈ w.support, dig (w j) • B j = 0 :=
+        Finset.sum_eq_zero fun j hj => by rw [hdig j hj, zero_smul]
+      have hj₁s : j₁ ∈ w.support := Finsupp.mem_support_iff.2 hj₁
+      have hwj : ((w j₁ : P.toValuationSubring) : F) = (π : F) * (rest (w j₁) : F) := by
+        conv_lhs => rw [hdr (w j₁)]
+        rw [hdig j₁ hj₁s]
+        simp
+      have hr : rest (w j₁) ≠ 0 := by
+        intro h
+        apply hj₁
+        apply Subtype.ext
+        rw [hwj, h]
+        simp
+      have hw' : (w.mapRange rest hrest0) j₁ ≠ 0 := by
+        rwa [Finsupp.mapRange_apply]
+      have hord : P.ord (((w.mapRange rest hrest0) j₁ : P.toValuationSubring) : F) < n := by
+        rw [Finsupp.mapRange_apply]
+        have hr0' : ((rest (w j₁) : P.toValuationSubring) : F) ≠ 0 := fun h => hr (Subtype.ext h)
+        have hπ0 : (π : F) ≠ 0 := fun h => hπ.ne_zero (Subtype.ext h)
+        have := P.ord_mul hπ0 hr0'
+        rw [← hwj, P.ord_coe_irreducible hπ] at this
+        push_cast at hlt
+        omega
+      obtain ⟨k, d, w'', hd, heq⟩ := ih (w.mapRange rest hrest0) j₁ hw' hord
+      refine ⟨k + 1, d, w'', hd, ?_⟩
+      rw [step w, hd0, map_zero, zero_add, heq]
+      ring
+
+end Decomp
+
+section LinDisj
+
+variable {K F K' F' : Type*} [Field K] [Field F] [Field K'] [Field F']
+  [Algebra K F] [Algebra K' F'] [Algebra K K'] [Algebra F F'] [Algebra K F']
+  [IsScalarTower K K' F'] [IsScalarTower K F F'] [IsAlgClosed K] [CharZero K]
+
+theorem sum_ne_of_not_mem_span
+    (hfg : ∃ x : F, Transcendental K x ∧
+      FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤)
+    {ι : Type*} (c : ι → K') (s : Finset ι) (o : ι → F) (y : F)
+    (hy : y ∉ Submodule.span K (Set.range o)) :
+    ∑ j ∈ s, algebraMap K' F' (c j) * algebraMap F F' (o j) ≠ algebraMap F F' y := by
+  classical
+  intro heq
+  set M := Submodule.span K (Set.range o) with hM
+  let bM := Module.Basis.ofVectorSpace K M
+  let v : Module.Basis.ofVectorSpaceIndex K M → F := fun l => (bM l : F)
+  have hv : LinearIndependent K v :=
+    bM.linearIndependent.map' M.subtype (Submodule.ker_subtype M)
+  have hspan : Submodule.span K (Set.range v) = M := by
+    change Submodule.span K (Set.range (M.subtype ∘ bM)) = M
+    rw [Set.range_comp, Submodule.span_image, bM.span_eq, Submodule.map_top,
+      Submodule.range_subtype]
+  have hyv : y ∉ Submodule.span K (Set.range v) := by rwa [hspan]
+  have hLI := AlgebraicCurve.linearIndependent_of_constantFieldExtension K F K' F' hfg hfg' hgen
+    (hv.option hyv)
+  have ho : ∀ j, o j ∈ M := fun j => Submodule.subset_span ⟨j, rfl⟩
+  let R : ι → (Module.Basis.ofVectorSpaceIndex K M →₀ K) := fun j => bM.repr ⟨o j, ho j⟩
+  have hR : ∀ j, ∀ T : Finset (Module.Basis.ofVectorSpaceIndex K M), (R j).support ⊆ T →
+      ∑ l ∈ T, algebraMap K F (R j l) * v l = o j := by
+    intro j T hT
+    have h1 := bM.linearCombination_repr ⟨o j, ho j⟩
+    rw [Finsupp.linearCombination_apply] at h1
+    have h2 := congrArg (M.subtype) h1
+    rw [map_finsuppSum, Finsupp.sum_of_support_subset _ hT _ (fun l _ => by simp)] at h2
+    have h3 : ∑ x ∈ T, M.subtype ((R j) x • bM x) = o j := h2
+    rw [← h3]
+    refine Finset.sum_congr rfl fun l _ => ?_
+    rw [map_smul, Algebra.smul_def]
+    rfl
+  obtain ⟨T, hT⟩ : ∃ T : Finset (Module.Basis.ofVectorSpaceIndex K M),
+      ∀ j ∈ s, (R j).support ⊆ T :=
+    ⟨s.biUnion fun j => (R j).support, fun j hj =>
+      Finset.subset_biUnion_of_mem (fun j => (R j).support) hj⟩
+  let κ : Option (Module.Basis.ofVectorSpaceIndex K M) → K' :=
+    fun i => Option.casesOn' i (-1) (fun l => ∑ j ∈ s, R j l • c j)
+  have hinner : ∑ l ∈ T, (∑ j ∈ s, R j l • c j) • algebraMap F F' (v l) =
+      ∑ j ∈ s, algebraMap K' F' (c j) * algebraMap F F' (o j) := by
+    simp_rw [Finset.sum_smul]
+    rw [Finset.sum_comm]
+    refine Finset.sum_congr rfl fun j hj => ?_
+    rw [← hR j T (hT j hj), map_sum, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun l _ => ?_
+    rw [Algebra.smul_def, Algebra.smul_def, map_mul, map_mul,
+      ← IsScalarTower.algebraMap_apply K K' F', ← IsScalarTower.algebraMap_apply K F F']
+    ring
+  have hsum : ∑ i ∈ Finset.insertNone T,
+      κ i • algebraMap F F' (Option.casesOn' i y v) = 0 := by
+    rw [Finset.sum_insertNone]
+    simp only [κ, Option.casesOn'_none, Option.casesOn'_some]
+    rw [hinner, heq, neg_one_smul, neg_add_cancel]
+  have := linearIndependent_iff'.1 hLI (Finset.insertNone T) κ hsum none (by simp)
+  simp [κ] at this
+
+end LinDisj
+
+end W7XUnram
+
+open W7XUnram in
+theorem solution (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [CharZero K]
+    (hfg : ∃ x : F, Transcendental K x ∧ FiniteDimensional (IntermediateField.adjoin K ({x} : Set
+      F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    [IsCurveOver K F]
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤)
+    (P : Place K F) :
+    ∃ P' : Place K' F',
+      P'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring ∧
+      (∀ f : F, P'.ord (algebraMap F F' f) = P.ord f) ∧
+      ∀ Q' : Place K' F',
+        Q'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring → Q' = P' := by
+  classical
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible P.toValuationSubring
+  have hπ0 : (π : F) ≠ 0 := fun h => hπ.ne_zero (Subtype.ext h)
+  have hπ1 : P.ord (π : F) = 1 := P.ord_coe_irreducible hπ
+  have hπinv : (π : F)⁻¹ ∉ P.toValuationSubring := by
+    intro h
+    have := ord_nonneg_of_mem P h
+    rw [P.ord_inv, hπ1] at this
+    omega
+  let B := Module.Basis.ofVectorSpace K K'
+  have memO : ∀ Q' : Place K' F',
+      Q'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring →
+      ∀ o : P.toValuationSubring, algebraMap F F' (o : F) ∈ Q'.toValuationSubring := by
+    intro Q' hQ o
+    have : (o : F) ∈ Q'.toValuationSubring.comap (algebraMap F F') := by rw [hQ]; exact o.2
+    exact ValuationSubring.mem_comap.1 this
+  have pinv : ∀ Q' : Place K' F',
+      Q'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring →
+      (algebraMap F F' (π : F))⁻¹ ∉ Q'.toValuationSubring := by
+    intro Q' hQ h
+    have h2 : (π : F)⁻¹ ∈ Q'.toValuationSubring.comap (algebraMap F F') :=
+      ValuationSubring.mem_comap.2 (by rwa [map_inv₀])
+    rw [hQ] at h2
+    exact hπinv h2
+  have ordPsi : ∀ w : _ →₀ P.toValuationSubring, w ≠ 0 → ∃ k : ℕ, ∀ Q' : Place K' F',
+      Q'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring →
+      Psi F' B P w ≠ 0 ∧
+        Q'.ord (Psi F' B P w) = k * Q'.ord (algebraMap F F' (π : F)) := by
+    intro w hw
+    obtain ⟨k, d, w', hd, heq⟩ := decomp F' B P hπ w hw
+    refine ⟨k, fun Q' hQ => ?_⟩
+    have hunit := ne_zero_and_inv_mem_of_add Q'.toValuationSubring
+      (a := algebraMap K' F' d) (m := Psi F' B P w') (p := algebraMap F F' (π : F))
+      (Q'.algebraMap_mem' d) (by rw [← map_inv₀]; exact Q'.algebraMap_mem' d⁻¹)
+      (by simpa using hd)
+      (Psi_mem F' B P Q'.toValuationSubring Q'.algebraMap_mem' (memO Q' hQ) w')
+      (memO Q' hQ π) (pinv Q' hQ)
+    have hmem : algebraMap K' F' d + algebraMap F F' (π : F) * Psi F' B P w' ∈
+        Q'.toValuationSubring :=
+      add_mem (Q'.algebraMap_mem' d)
+        (mul_mem (memO Q' hQ π)
+          (Psi_mem F' B P Q'.toValuationSubring Q'.algebraMap_mem' (memO Q' hQ) w'))
+    have hpk : algebraMap F F' (π : F) ^ k ≠ 0 := pow_ne_zero _ ((map_ne_zero _).2 hπ0)
+    refine ⟨by rw [heq]; exact mul_ne_zero hpk hunit.1, ?_⟩
+    rw [heq, Q'.ord_mul hpk hunit.1, ord_eq_zero_of_mem_of_inv_mem Q' hmem hunit.2,
+      ← zpow_natCast, Q'.ord_zpow]
+    ring
+  have ordAny : ∀ z : F', z ≠ 0 → ∃ m : ℤ, ∀ Q' : Place K' F',
+      Q'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring →
+      Q'.ord z = m * Q'.ord (algebraMap F F' (π : F)) := by
+    intro z hz
+    obtain ⟨w₁, w₂, hne, hzw⟩ := exists_mul_Psi_eq F' B P hgen hz
+    have hw₂ : w₂ ≠ 0 := by rintro rfl; exact hne (map_zero _)
+    have hw₁ : w₁ ≠ 0 := by
+      rintro rfl
+      rw [map_zero] at hzw
+      exact mul_ne_zero hz hne hzw
+    obtain ⟨k₁, h₁⟩ := ordPsi w₁ hw₁
+    obtain ⟨k₂, h₂⟩ := ordPsi w₂ hw₂
+    refine ⟨k₁ - k₂, fun Q' hQ => ?_⟩
+    have e₁ := (h₁ Q' hQ).2
+    have e₂ := (h₂ Q' hQ).2
+    have := Q'.ord_mul hz hne
+    rw [hzw, e₁, e₂] at this
+    linarith
+  have eOne : ∀ Q' : Place K' F',
+      Q'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring →
+      Q'.ord (algebraMap F F' (π : F)) = 1 := by
+    intro Q' hQ
+    obtain ⟨π', hπ'⟩ := IsDiscreteValuationRing.exists_irreducible Q'.toValuationSubring
+    have hπ'0 : (π' : F') ≠ 0 := fun h => hπ'.ne_zero (Subtype.ext h)
+    obtain ⟨m, hm⟩ := ordAny (π' : F') hπ'0
+    have h := hm Q' hQ
+    rw [Q'.ord_coe_irreducible hπ'] at h
+    have hnn : 0 ≤ Q'.ord (algebraMap F F' (π : F)) := ord_nonneg_of_mem Q' (memO Q' hQ π)
+    exact Int.eq_one_of_dvd_one hnn ⟨m, by rw [mul_comm]; exact h⟩
+  have ordEq : ∀ Q' : Place K' F',
+      Q'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring →
+      ∀ f : F, Q'.ord (algebraMap F F' f) = P.ord f := by
+    intro Q' hQ f
+    rcases eq_or_ne f 0 with rfl | hf
+    · simp
+    obtain ⟨u, hu⟩ := P.exists_unit_mul_zpow hf hπ
+    have hu0 : algebraMap F F' ((u : P.toValuationSubring) : F) ≠ 0 := by
+      rw [map_ne_zero]
+      exact fun h => u.ne_zero (Subtype.ext h)
+    have hzp : algebraMap F F' (π : F) ^ P.ord f ≠ 0 := zpow_ne_zero _ ((map_ne_zero _).2 hπ0)
+    have huinv : (algebraMap F F' ((u : P.toValuationSubring) : F))⁻¹ ∈ Q'.toValuationSubring := by
+      have hmul : ((u : P.toValuationSubring) : F) *
+          (((u⁻¹ : P.toValuationSubringˣ) : P.toValuationSubring) : F) = 1 := by
+        rw [← MulMemClass.coe_mul, Units.mul_inv, OneMemClass.coe_one]
+      rw [← map_inv₀, ← eq_inv_of_mul_eq_one_right hmul]
+      exact memO Q' hQ _
+    conv_lhs => rw [hu, map_mul, map_zpow₀]
+    rw [Q'.ord_mul hu0 hzp, Q'.ord_zpow, eOne Q' hQ,
+      ord_eq_zero_of_mem_of_inv_mem Q' (memO Q' hQ u) huinv]
+    ring
+  have uniq : ∀ Q₁ Q₂ : Place K' F',
+      Q₁.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring →
+      Q₂.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring → Q₁ = Q₂ := by
+    intro Q₁ Q₂ h1 h2
+    apply Place.ext
+    ext z
+    rcases eq_or_ne z 0 with rfl | hz
+    · simp
+    obtain ⟨m, hm⟩ := ordAny z hz
+    rw [mem_iff_ord_nonneg Q₁ z, mem_iff_ord_nonneg Q₂ z, hm Q₁ h1, hm Q₂ h2, eOne Q₁ h1,
+      eOne Q₂ h2]
+  have hπA : algebraMap F F' (π : F) ∈ rangePsi F' B P := algebraMap_coe_mem_rangePsi F' B P π
+  have hI : Ideal.span {(⟨algebraMap F F' (π : F), hπA⟩ : rangePsi F' B P)} ≠ ⊤ := by
+    intro h
+    rw [Ideal.eq_top_iff_one, Ideal.mem_span_singleton'] at h
+    obtain ⟨a, ha⟩ := h
+    obtain ⟨w, hw⟩ := a.2
+    have ha' : Psi F' B P w * algebraMap F F' (π : F) = 1 := by
+      have := congrArg Subtype.val ha
+      simpa [hw] using this
+    have hy : (π : F)⁻¹ ∉ Submodule.span K (Set.range fun j => ((w j : P.toValuationSubring) : F))
+      :=
+      by
+      let OK : Submodule K F :=
+        { carrier := P.toValuationSubring
+          add_mem' := fun ha hb => add_mem ha hb
+          zero_mem' := zero_mem _
+          smul_mem' := fun c x hx => by
+            rw [Algebra.smul_def]
+            exact mul_mem (P.algebraMap_mem' c) hx }
+      have hle : Submodule.span K (Set.range fun j => ((w j : P.toValuationSubring) : F)) ≤ OK :=
+        Submodule.span_le.2 (by rintro _ ⟨j, rfl⟩; exact (w j).2)
+      exact fun h => hπinv (hle h)
+    have hPsi : Psi F' B P w =
+        ∑ j ∈ w.support, algebraMap K' F' (B j) *
+          algebraMap F F' ((w j : P.toValuationSubring) : F) := by
+      rw [Psi_apply]
+      rfl
+    refine sum_ne_of_not_mem_span hfg hfg' hgen B w.support
+      (fun j => ((w j : P.toValuationSubring) : F)) _ hy ?_
+    rw [← hPsi, map_inv₀]
+    exact eq_inv_of_mul_eq_one_left ha'
+  obtain ⟨V, hAV, hIV⟩ := Ideal.image_subset_nonunits_valuationSubring _ hI
+  have hAV' : ∀ y, y ∈ rangePsi F' B P → y ∈ V := fun y hy => hAV hy
+  have hπV : algebraMap F F' (π : F) ∈ V := hAV' _ hπA
+  have hnu : algebraMap F F' (π : F) ∈ V.nonunits :=
+    hIV ⟨⟨_, hπA⟩, Ideal.mem_span_singleton_self _, rfl⟩
+  have hπVinv : (algebraMap F F' (π : F))⁻¹ ∉ V := by
+    have := (V.inv_mem_nonunits_iff (x := (algebraMap F F' (π : F))⁻¹)).1
+      (by rw [inv_inv]; exact hnu)
+    exact this.resolve_left (inv_ne_zero ((map_ne_zero _).2 hπ0))
+  have : CharZero K' := charZero_of_injective_algebraMap (algebraMap K K').injective
+  obtain ⟨x', -, hfin'⟩ := hfg'
+  have := hfin'
+  obtain ⟨P', hP'⟩ := AlgebraicCurve.Place.exists_toValuationSubring_eq_comap_ringHom
+    (K := K') x' (RingHom.id F') V (fun a => hAV' _ (algebraMap_mem_rangePsi F' B P a))
+    ⟨_, hπVinv⟩
+  have hmemP' : ∀ z, z ∈ P'.toValuationSubring ↔ z ∈ V := fun z => by
+    rw [hP', ValuationSubring.mem_comap, RingHom.id_apply]
+  have hover : P'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring := by
+    ext f
+    rw [ValuationSubring.mem_comap, hmemP']
+    refine ⟨fun hfV => ?_, fun hf => hAV' _ (algebraMap_coe_mem_rangePsi F' B P ⟨f, hf⟩)⟩
+    by_contra hfO
+    have hf0 : f ≠ 0 := by rintro rfl; exact hfO (zero_mem _)
+    have hn : P.ord f < 0 := by
+      by_contra h
+      push Not at h
+      exact hfO ((mem_iff_ord_nonneg P f).2 h)
+    obtain ⟨u, hu⟩ := P.exists_unit_mul_zpow hf0 hπ
+    have hui : (((u⁻¹ : P.toValuationSubringˣ) : P.toValuationSubring) : F) *
+        ((u : P.toValuationSubring) : F) = 1 := by
+      rw [← MulMemClass.coe_mul, Units.inv_mul, OneMemClass.coe_one]
+    set n := P.ord f with hn'
+    have key : (π : F)⁻¹ = (((u⁻¹ : P.toValuationSubringˣ) : P.toValuationSubring) : F) * f *
+        (π : F) ^ ((-n - 1).toNat) := by
+      rw [← zpow_natCast, Int.toNat_of_nonneg (by omega)]
+      conv_rhs => rw [hu]
+      calc (π : F)⁻¹ = 1 * ((π : F) ^ n * (π : F) ^ (-n - 1)) := by
+            rw [← zpow_add₀ hπ0, show n + (-n - 1) = -1 by ring, zpow_neg_one, one_mul]
+        _ = _ := by rw [← hui]; ring
+    apply hπVinv
+    rw [← map_inv₀, key, map_mul, map_mul, map_pow]
+    exact mul_mem (mul_mem (hAV' _ (algebraMap_coe_mem_rangePsi F' B P _)) hfV) (pow_mem hπV _)
+  exact ⟨P', hover, ordEq P' hover, fun Q' hQ' => uniq Q' P' hQ' hover⟩
+
+end S_AlgebraicCurve_Place_exists_comap_algebraMap_eq_of_constantFieldExtension
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_exists_comap_algebraMap_eq_of_constantFieldExtension (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.exists_comap_algebraMap_eq_of_constantFieldExtension
+    (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [CharZero K]
+    (hfg : ∃ x : F, Transcendental K x ∧ FiniteDimensional (IntermediateField.adjoin K ({x} : Set
+      F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    [IsCurveOver K F]
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤)
+    (P : Place K F) :
+    ∃ P' : Place K' F',
+      P'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring ∧
+      (∀ f : F, P'.ord (algebraMap F F' f) = P.ord f) ∧
+      ∀ Q' : Place K' F',
+        Q'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring → Q' = P' :=
+  solution K F K' F' hfg hfg' hgen P
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_comap_algebraMap_eq_of_constantFieldExtension_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_comap_algebraMap_eq_of_constantFieldExtension_of_isAlgClosed.lean
new file mode 100644
index 0000000000..48057d0838
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_comap_algebraMap_eq_of_constantFieldExtension_of_isAlgClosed.lean
@@ -0,0 +1,702 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.Place.exists_comap_algebraMap_eq_of_constantFieldExtension_of_isAlgClosed
+(7ead4d7e-17fa-5fb5-9ba3-c3e580b25b5a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e760e9dc-997b-55bd-a7c6-056654207c4b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import Mathlib.RingTheory.Valuation.LocalSubring
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom_of_isSeparable
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_finiteDimensional_isSeparable_adjoin_of_constantFieldExtension_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_linearIndependent_of_constantFieldExtension_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Unique place above P in a constant field extension
+
+Theorem statement:
+`AlgebraicCurve.Place.exists_comap_algebraMap_eq_of_constantFieldExtension_of_isAlgClosed`
+(`7ead4d7e-17fa-5fb5-9ba3-c3e580b25b5a`), by Claude, 2026-09-05.
+
+Proof: submission `e760e9dc-997b-55bd-a7c6-056654207c4b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K, F, K', F'$ be fields with $F$ a $K$-algebra, $F'$ a $K'$-algebra, together with algebra maps
+$K \to K'$, $F \to F'$ and $K \to F'$ compatible as scalar towers $K \to K' \to F'$ and $K \to F \to
+F'$, and let $K$ be algebraically closed. Assume $F$ is a function field in one variable over $K$,
+in the sense that some $x \in F$ is transcendental over $K$ with $F$ finite-dimensional over $K(x)$,
+and likewise that some $x' \in F'$ is transcendental over $K'$ with $F'$ finite-dimensional over
+$K'(x')$. Assume moreover `IsCurveOver K F`: every nonzero $f \in F$ admits a divisor $D$ of degree
+$0$ with $D(v) = \operatorname{ord}_v(f)$ at every place $v$, every place of $F/K$ has residue field
+finite over $K$, and $\Omega_{F/K}$ is free of rank $1$ over $F$. Assume finally that $F'$ is
+generated over $K'$ by the image of $F$, i.e. the subfield of $F'$ generated by $K'$ and
+$\operatorname{range}(F \to F')$ is all of $F'$. Here a place of $F$ over $K$ is a valuation subring
+of $F$ containing the image of $K$, different from $F$, and a principal ideal ring, and
+$\operatorname{ord}$ denotes minus the logarithm of the associated $\mathbb{Z}^{m0}$-valued adic
+valuation. Then for every place $P$ of $F$ over $K$ there is a place $P'$ of $F'$ over $K'$ whose
+valuation subring contracts along $F \to F'$ to that of $P$, which satisfies
+$\operatorname{ord}_{P'}(f) = \operatorname{ord}_P(f)$ for all $f \in F$, and which is the unique
+place of $F'$ over $K'$ contracting to $P$.
+
+This is the classical statement that in a constant field extension of a function field over an
+algebraically closed constant field, every place has exactly one extension and that extension is
+unramified; the hypothesis that $K$ be algebraically closed replaces a characteristic-zero
+assumption, the separating element needed for a primitive element being available because $K$ is
+perfect. It underlies the conorm map on divisors and degree-zero divisor class groups under constant
+field extension, and the comparison of Riemann–Roch data and canonical divisors before and after
+such an extension.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_exists_comap_algebraMap_eq_of_constantFieldExtension_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_a5384eef
+
+open AlgebraicCurve
+
+namespace W7XUnram
+
+section Basic
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+theorem ord_nonneg_of_mem {f : F} (hf : f ∈ v.toValuationSubring) : 0 ≤ v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨n, u, hu⟩ :=
+    IsDiscreteValuationRing.eq_unit_mul_pow_irreducible
+      (x := (⟨f, hf⟩ : v.toValuationSubring)) (by simpa [Subtype.ext_iff] using hf0) hπ
+  have hcoe : f = ((u : v.toValuationSubring) : F) * ((π : F) ^ (n : ℤ)) := by
+    have h := congrArg (Subtype.val) hu
+    push_cast at h
+    rw [zpow_natCast]
+    exact h
+  rw [hcoe, v.ord_unit_smul_zpow u hπ (n : ℤ)]
+  exact Int.natCast_nonneg n
+
+theorem ord_eq_zero_of_mem_of_inv_mem {f : F} (h1 : f ∈ v.toValuationSubring)
+    (h2 : f⁻¹ ∈ v.toValuationSubring) : v.ord f = 0 := by
+  have a := ord_nonneg_of_mem v h1
+  have b := ord_nonneg_of_mem v h2
+  rw [v.ord_inv] at b
+  omega
+
+theorem one_le_ord_of_mem_of_inv_not_mem {f : F} (h1 : f ∈ v.toValuationSubring)
+    (h2 : f⁻¹ ∉ v.toValuationSubring) : 1 ≤ v.ord f := by
+  have hf0 : f ≠ 0 := by
+    rintro rfl
+    exact h2 (by simp)
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf0 hπ
+  have h0 := ord_nonneg_of_mem v h1
+  by_contra hlt
+  have hz : v.ord f = 0 := by omega
+  apply h2
+  have hmul : ((u : v.toValuationSubring) : F) *
+      (((u⁻¹ : v.toValuationSubringˣ) : v.toValuationSubring) : F) = 1 := by
+    rw [← MulMemClass.coe_mul, Units.mul_inv, OneMemClass.coe_one]
+  rw [hu, hz, zpow_zero, mul_one, ← eq_inv_of_mul_eq_one_right hmul]
+  exact SetLike.coe_mem _
+
+theorem mem_iff_ord_nonneg (f : F) : f ∈ v.toValuationSubring ↔ 0 ≤ v.ord f := by
+  refine ⟨ord_nonneg_of_mem v, fun h => ?_⟩
+  by_contra hmem
+  have hinv : f⁻¹ ∈ v.toValuationSubring :=
+    (v.toValuationSubring.mem_or_inv_mem f).resolve_left hmem
+  have := one_le_ord_of_mem_of_inv_not_mem v hinv (by simpa using hmem)
+  rw [v.ord_inv] at this
+  omega
+
+end Basic
+
+section Psi
+
+variable {K F K' : Type*} (F' : Type*) [Field K] [Field F] [Field K'] [Field F']
+  [Algebra K F] [Algebra K' F'] [Algebra K K'] [Algebra F F'] [Algebra K F']
+  [IsScalarTower K K' F'] [IsScalarTower K F F']
+  {ι : Type*} (B : Module.Basis ι K K') (P : Place K F)
+
+noncomputable def Psi : (ι →₀ P.toValuationSubring) →+ F' :=
+  Finsupp.liftAddHom fun j =>
+    (AddMonoidHom.mulLeft (algebraMap K' F' (B j))).comp
+      ((algebraMap F F' : F →+* F').toAddMonoidHom.comp
+        P.toValuationSubring.subtype.toAddMonoidHom)
+
+omit [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F'] in
+theorem Psi_single (j : ι) (o : P.toValuationSubring) :
+    Psi F' B P (Finsupp.single j o) = algebraMap K' F' (B j) * algebraMap F F' (o : F) := by
+  simp [Psi]
+
+omit [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F'] in
+theorem Psi_apply (w : ι →₀ P.toValuationSubring) :
+    Psi F' B P w = w.sum fun j o => algebraMap K' F' (B j) * algebraMap F F' (o : F) := by
+  rw [Psi, Finsupp.liftAddHom_apply]
+  rfl
+
+omit [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F'] in
+theorem Psi_smul (s : P.toValuationSubring) (w : ι →₀ P.toValuationSubring) :
+    Psi F' B P (s • w) = algebraMap F F' (s : F) * Psi F' B P w := by
+  induction w using Finsupp.induction with
+  | zero => simp
+  | single_add a b f _ _ ih =>
+    rw [smul_add, map_add, map_add, ih, Finsupp.smul_single, Psi_single, Psi_single, mul_add,
+      smul_eq_mul, MulMemClass.coe_mul, map_mul]
+    ring
+
+noncomputable def pureW (d : K') (o : P.toValuationSubring) : ι →₀ P.toValuationSubring :=
+  (B.repr d).mapRange (fun a => algebraMap K P.toValuationSubring a * o) (by simp)
+
+theorem Psi_pureW (d : K') (o : P.toValuationSubring) :
+    Psi F' B P (pureW B P d o) = algebraMap K' F' d * algebraMap F F' (o : F) := by
+  rw [Psi_apply, pureW, Finsupp.sum_mapRange_index (fun j => by simp)]
+  conv_rhs => rw [← B.linearCombination_repr d, Finsupp.linearCombination_apply]
+  simp only [Finsupp.sum, map_sum, Finset.sum_mul]
+  refine Finset.sum_congr rfl fun j _ => ?_
+  rw [MulMemClass.coe_mul, Place.coe_algebraMap, map_mul, Algebra.smul_def, map_mul,
+    ← IsScalarTower.algebraMap_apply, ← IsScalarTower.algebraMap_apply]
+  ring
+
+theorem Psi_mul_mem_range (w₁ w₂ : ι →₀ P.toValuationSubring) :
+    ∃ w, Psi F' B P w = Psi F' B P w₁ * Psi F' B P w₂ := by
+  classical
+  refine ⟨∑ i ∈ w₁.support, ∑ j ∈ w₂.support, pureW B P (B i * B j) (w₁ i * w₂ j), ?_⟩
+  rw [map_sum, Psi_apply F' B P w₁, Finsupp.sum, Finset.sum_mul]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [map_sum, Psi_apply F' B P w₂, Finsupp.sum, Finset.mul_sum]
+  refine Finset.sum_congr rfl fun j _ => ?_
+  rw [Psi_pureW, map_mul, MulMemClass.coe_mul, map_mul]
+  ring
+
+noncomputable def rangePsi : Subring F' where
+  carrier := Set.range (Psi F' B P)
+  mul_mem' := by
+    rintro _ _ ⟨w₁, rfl⟩ ⟨w₂, rfl⟩
+    exact Psi_mul_mem_range F' B P w₁ w₂
+  one_mem' := ⟨pureW B P 1 1, by simp [Psi_pureW]⟩
+  add_mem' := by
+    rintro _ _ ⟨w₁, rfl⟩ ⟨w₂, rfl⟩
+    exact ⟨w₁ + w₂, map_add _ _ _⟩
+  zero_mem' := ⟨0, map_zero _⟩
+  neg_mem' := by
+    rintro _ ⟨w, rfl⟩
+    exact ⟨-w, map_neg _ _⟩
+
+theorem algebraMap_mem_rangePsi (d : K') : algebraMap K' F' d ∈ rangePsi F' B P :=
+  ⟨pureW B P d 1, by simp [Psi_pureW]⟩
+
+theorem algebraMap_coe_mem_rangePsi (o : P.toValuationSubring) :
+    algebraMap F F' (o : F) ∈ rangePsi F' B P :=
+  ⟨pureW B P 1 o, by simp [Psi_pureW]⟩
+
+omit [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F'] in
+theorem Psi_mem {S : Type*} [SetLike S F'] [SubringClass S F'] (V : S)
+    (hK : ∀ d : K', algebraMap K' F' d ∈ V)
+    (hO : ∀ o : P.toValuationSubring, algebraMap F F' (o : F) ∈ V)
+    (w : ι →₀ P.toValuationSubring) : Psi F' B P w ∈ V := by
+  rw [Psi_apply]
+  exact sum_mem fun j _ => mul_mem (hK _) (hO _)
+
+noncomputable def fracPsi : Subalgebra K' F' where
+  carrier := {y | ∃ w, ∃ s : P.toValuationSubring, (s : F) ≠ 0 ∧
+    y * algebraMap F F' (s : F) = Psi F' B P w}
+  mul_mem' := by
+    rintro y₁ y₂ ⟨w₁, s₁, hs₁, h₁⟩ ⟨w₂, s₂, hs₂, h₂⟩
+    obtain ⟨w, hw⟩ := Psi_mul_mem_range F' B P w₁ w₂
+    refine ⟨w, s₁ * s₂, by rw [MulMemClass.coe_mul]; exact mul_ne_zero hs₁ hs₂, ?_⟩
+    rw [hw, ← h₁, ← h₂, MulMemClass.coe_mul, map_mul]
+    ring
+  one_mem' := ⟨pureW B P 1 1, 1, by simp, by simp [Psi_pureW]⟩
+  add_mem' := by
+    rintro y₁ y₂ ⟨w₁, s₁, hs₁, h₁⟩ ⟨w₂, s₂, hs₂, h₂⟩
+    refine ⟨s₂ • w₁ + s₁ • w₂, s₁ * s₂, by rw [MulMemClass.coe_mul]; exact mul_ne_zero hs₁ hs₂, ?_⟩
+    rw [map_add, Psi_smul, Psi_smul, ← h₁, ← h₂, MulMemClass.coe_mul, map_mul]
+    ring
+  zero_mem' := ⟨0, 1, by simp, by simp⟩
+  algebraMap_mem' d := ⟨pureW B P d 1, 1, by simp, by simp [Psi_pureW]⟩
+
+theorem algebraMap_mem_fracPsi (f : F) : algebraMap F F' f ∈ fracPsi F' B P := by
+  rcases P.toValuationSubring.mem_or_inv_mem f with h | h
+  · exact ⟨pureW B P 1 ⟨f, h⟩, 1, by simp, by simp [Psi_pureW]⟩
+  · rcases eq_or_ne f 0 with rfl | hf
+    · rw [map_zero]; exact (fracPsi F' B P).zero_mem
+    · refine ⟨pureW B P 1 1, ⟨f⁻¹, h⟩, by simpa using hf, ?_⟩
+      simp [Psi_pureW, mul_inv_cancel₀ ((map_ne_zero (algebraMap F F')).2 hf)]
+
+theorem exists_mul_Psi_eq (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤)
+    {z : F'} (hz : z ≠ 0) :
+    ∃ w₁ w₂, Psi F' B P w₂ ≠ 0 ∧ z * Psi F' B P w₂ = Psi F' B P w₁ := by
+  have hzmem : z ∈ IntermediateField.adjoin K' (Set.range (algebraMap F F')) := by
+    rw [hgen]; trivial
+  rw [IntermediateField.mem_adjoin_iff_div] at hzmem
+  obtain ⟨r, hr, s, hs, rfl⟩ := hzmem
+  have hle : Algebra.adjoin K' (Set.range (algebraMap F F')) ≤ fracPsi F' B P :=
+    Algebra.adjoin_le (by rintro _ ⟨f, rfl⟩; exact algebraMap_mem_fracPsi F' B P f)
+  obtain ⟨w₁, s₁, hs₁, h₁⟩ := hle hr
+  obtain ⟨w₂, s₂, hs₂, h₂⟩ := hle hs
+  have hr0 : r ≠ 0 := by rintro rfl; simp at hz
+  have hs0 : s ≠ 0 := by rintro rfl; simp at hz
+  refine ⟨s₂ • w₁, s₁ • w₂, ?_, ?_⟩
+  · rw [Psi_smul, ← h₂]
+    exact mul_ne_zero (by simpa using hs₁) (mul_ne_zero hs0 (by simpa using hs₂))
+  · rw [Psi_smul, Psi_smul, ← h₁, ← h₂]
+    field_simp
+
+end Psi
+
+theorem ne_zero_and_inv_mem_of_add {L : Type*} [Field L] (V : ValuationSubring L) {a m p : L}
+    (ha : a ∈ V) (hai : a⁻¹ ∈ V) (ha0 : a ≠ 0) (hm : m ∈ V) (hp : p ∈ V) (hpi : p⁻¹ ∉ V) :
+    a + p * m ≠ 0 ∧ (a + p * m)⁻¹ ∈ V := by
+  have hva : V.valuation a = 1 := by
+    refine le_antisymm ((V.valuation_le_one_iff a).2 ha) ?_
+    have h := (V.valuation_le_one_iff _).2 hai
+    rw [map_inv₀] at h
+    exact (inv_le_one₀ (zero_lt_iff.2 ((Valuation.ne_zero_iff _).2 ha0))).1 h
+  have hvp : V.valuation p < 1 :=
+    lt_of_le_of_ne ((V.valuation_le_one_iff p).2 hp)
+      (fun h => hpi (by rw [← V.valuation_le_one_iff, map_inv₀, h, inv_one]))
+  have hvm : V.valuation m ≤ 1 := (V.valuation_le_one_iff m).2 hm
+  have hlt : V.valuation (p * m) < V.valuation a := by
+    rw [map_mul, hva]
+    calc V.valuation p * V.valuation m ≤ V.valuation p * 1 := by gcongr
+      _ = V.valuation p := mul_one _
+      _ < 1 := hvp
+  have hve : V.valuation (a + p * m) = 1 := by
+    rw [Valuation.map_add_eq_of_lt_left _ hlt, hva]
+  refine ⟨(Valuation.ne_zero_iff _).1 (by rw [hve]; exact one_ne_zero), ?_⟩
+  rw [← V.valuation_le_one_iff, map_inv₀, hve, inv_one]
+
+section Decomp
+
+variable {K F K' : Type*} (F' : Type*) [Field K] [Field F] [Field K'] [Field F']
+  [Algebra K F] [Algebra K' F'] [Algebra K K'] [Algebra F F'] [Algebra K F']
+  [IsScalarTower K K' F'] [IsScalarTower K F F']
+  {ι : Type*} (B : Module.Basis ι K K') (P : Place K F)
+
+theorem exists_digit [IsAlgClosed K] [IsCurveOver K F] {π : P.toValuationSubring}
+    (hπ : Irreducible π) (o : P.toValuationSubring) :
+    ∃ a : K, ∃ o' : P.toValuationSubring,
+      o = algebraMap K P.toValuationSubring a + π * o' ∧ (o = 0 → o' = 0) := by
+  rcases eq_or_ne o 0 with rfl | ho
+  · exact ⟨0, 0, by simp, fun _ => rfl⟩
+  have : Module.Finite K P.ResidueField := IsCurveOver.finiteResidue P
+  have : Algebra.IsIntegral K P.ResidueField := Algebra.IsIntegral.of_finite K _
+  have hbij : Function.Bijective (algebraMap K P.ResidueField) :=
+    IsAlgClosed.algebraMap_bijective_of_isIntegral
+  obtain ⟨a, ha⟩ := hbij.2 (IsLocalRing.residue P.toValuationSubring o)
+  have hmem : o - algebraMap K P.toValuationSubring a ∈
+      IsLocalRing.maximalIdeal P.toValuationSubring := by
+    rw [← IsLocalRing.residue_eq_zero_iff, map_sub, sub_eq_zero, ← ha,
+      IsScalarTower.algebraMap_apply K P.toValuationSubring P.ResidueField,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  rw [hπ.maximalIdeal_eq, Ideal.mem_span_singleton'] at hmem
+  obtain ⟨b, hb⟩ := hmem
+  exact ⟨a, b, by rw [mul_comm, hb]; ring, fun h => absurd h ho⟩
+
+theorem decomp [IsAlgClosed K] [IsCurveOver K F] {π : P.toValuationSubring} (hπ : Irreducible π)
+    (w : ι →₀ P.toValuationSubring) (hw : w ≠ 0) :
+    ∃ (k : ℕ) (d : K') (w' : ι →₀ P.toValuationSubring), d ≠ 0 ∧
+      Psi F' B P w = algebraMap F F' (π : F) ^ k *
+        (algebraMap K' F' d + algebraMap F F' (π : F) * Psi F' B P w') := by
+  classical
+  choose dig rest hdr hr0 using exists_digit P hπ
+  have hrest0 : rest 0 = 0 := hr0 0 rfl
+  have step : ∀ w : ι →₀ P.toValuationSubring,
+      Psi F' B P w = algebraMap K' F' (∑ j ∈ w.support, dig (w j) • B j) +
+        algebraMap F F' (π : F) * Psi F' B P (w.mapRange rest hrest0) := by
+    intro w
+    rw [Psi_apply F' B P (w.mapRange _ _),
+      Finsupp.sum_mapRange_index (fun j => by simp)]
+    rw [Psi_apply]
+    simp only [Finsupp.sum, map_sum, Finset.mul_sum, ← Finset.sum_add_distrib]
+    refine Finset.sum_congr rfl fun j _ => ?_
+    conv_lhs => rw [hdr (w j)]
+    rw [AddMemClass.coe_add, MulMemClass.coe_mul, Place.coe_algebraMap, map_add, map_mul,
+      Algebra.smul_def, map_mul, ← IsScalarTower.algebraMap_apply K K' F',
+      ← IsScalarTower.algebraMap_apply K F F']
+    ring
+  suffices h : ∀ (n : ℕ) (w : ι →₀ P.toValuationSubring) (j₁ : ι), w j₁ ≠ 0 →
+      P.ord ((w j₁ : P.toValuationSubring) : F) < n →
+      ∃ (k : ℕ) (d : K') (w' : ι →₀ P.toValuationSubring), d ≠ 0 ∧
+        Psi F' B P w = algebraMap F F' (π : F) ^ k *
+          (algebraMap K' F' d + algebraMap F F' (π : F) * Psi F' B P w') by
+    obtain ⟨j₁, hj₁⟩ : ∃ j₁, w j₁ ≠ 0 := by
+      by_contra h
+      push Not at h
+      exact hw (Finsupp.ext h)
+    exact h ((P.ord ((w j₁ : P.toValuationSubring) : F)).toNat + 1) w j₁ hj₁ (by omega)
+  intro n
+  induction n with
+  | zero =>
+    intro w j₁ _ hlt
+    have := ord_nonneg_of_mem P (w j₁).2
+    push_cast at hlt
+    omega
+  | succ n ih =>
+    intro w j₁ hj₁ hlt
+    by_cases hdig : ∃ j ∈ w.support, dig (w j) ≠ 0
+    · refine ⟨0, ∑ j ∈ w.support, dig (w j) • B j, w.mapRange rest hrest0, ?_, ?_⟩
+      · intro hd
+        obtain ⟨j, hj, hne⟩ := hdig
+        exact hne (linearIndependent_iff'.1 B.linearIndependent w.support (fun j => dig (w j))
+          hd j hj)
+      · rw [pow_zero, one_mul]
+        exact step w
+    · push Not at hdig
+      have hd0 : ∑ j ∈ w.support, dig (w j) • B j = 0 :=
+        Finset.sum_eq_zero fun j hj => by rw [hdig j hj, zero_smul]
+      have hj₁s : j₁ ∈ w.support := Finsupp.mem_support_iff.2 hj₁
+      have hwj : ((w j₁ : P.toValuationSubring) : F) = (π : F) * (rest (w j₁) : F) := by
+        conv_lhs => rw [hdr (w j₁)]
+        rw [hdig j₁ hj₁s]
+        simp
+      have hr : rest (w j₁) ≠ 0 := by
+        intro h
+        apply hj₁
+        apply Subtype.ext
+        rw [hwj, h]
+        simp
+      have hw' : (w.mapRange rest hrest0) j₁ ≠ 0 := by
+        rwa [Finsupp.mapRange_apply]
+      have hord : P.ord (((w.mapRange rest hrest0) j₁ : P.toValuationSubring) : F) < n := by
+        rw [Finsupp.mapRange_apply]
+        have hr0' : ((rest (w j₁) : P.toValuationSubring) : F) ≠ 0 := fun h => hr (Subtype.ext h)
+        have hπ0 : (π : F) ≠ 0 := fun h => hπ.ne_zero (Subtype.ext h)
+        have := P.ord_mul hπ0 hr0'
+        rw [← hwj, P.ord_coe_irreducible hπ] at this
+        push_cast at hlt
+        omega
+      obtain ⟨k, d, w'', hd, heq⟩ := ih (w.mapRange rest hrest0) j₁ hw' hord
+      refine ⟨k + 1, d, w'', hd, ?_⟩
+      rw [step w, hd0, map_zero, zero_add, heq]
+      ring
+
+end Decomp
+
+section LinDisj
+
+variable {K F K' F' : Type*} [Field K] [Field F] [Field K'] [Field F']
+  [Algebra K F] [Algebra K' F'] [Algebra K K'] [Algebra F F'] [Algebra K F']
+  [IsScalarTower K K' F'] [IsScalarTower K F F'] [IsAlgClosed K]
+
+theorem sum_ne_of_not_mem_span
+    (hfg : ∃ x : F, Transcendental K x ∧
+      FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤)
+    {ι : Type*} (c : ι → K') (s : Finset ι) (o : ι → F) (y : F)
+    (hy : y ∉ Submodule.span K (Set.range o)) :
+    ∑ j ∈ s, algebraMap K' F' (c j) * algebraMap F F' (o j) ≠ algebraMap F F' y := by
+  classical
+  intro heq
+  set M := Submodule.span K (Set.range o) with hM
+  let bM := Module.Basis.ofVectorSpace K M
+  let v : Module.Basis.ofVectorSpaceIndex K M → F := fun l => (bM l : F)
+  have hv : LinearIndependent K v :=
+    bM.linearIndependent.map' M.subtype (Submodule.ker_subtype M)
+  have hspan : Submodule.span K (Set.range v) = M := by
+    change Submodule.span K (Set.range (M.subtype ∘ bM)) = M
+    rw [Set.range_comp, Submodule.span_image, bM.span_eq, Submodule.map_top,
+      Submodule.range_subtype]
+  have hyv : y ∉ Submodule.span K (Set.range v) := by rwa [hspan]
+  have hLI :=
+    AlgebraicCurve.linearIndependent_of_constantFieldExtension_of_isAlgClosed K F K' F' hfg hfg'
+      hgen
+    (hv.option hyv)
+  have ho : ∀ j, o j ∈ M := fun j => Submodule.subset_span ⟨j, rfl⟩
+  let R : ι → (Module.Basis.ofVectorSpaceIndex K M →₀ K) := fun j => bM.repr ⟨o j, ho j⟩
+  have hR : ∀ j, ∀ T : Finset (Module.Basis.ofVectorSpaceIndex K M), (R j).support ⊆ T →
+      ∑ l ∈ T, algebraMap K F (R j l) * v l = o j := by
+    intro j T hT
+    have h1 := bM.linearCombination_repr ⟨o j, ho j⟩
+    rw [Finsupp.linearCombination_apply] at h1
+    have h2 := congrArg (M.subtype) h1
+    rw [map_finsuppSum, Finsupp.sum_of_support_subset _ hT _ (fun l _ => by simp)] at h2
+    have h3 : ∑ x ∈ T, M.subtype ((R j) x • bM x) = o j := h2
+    rw [← h3]
+    refine Finset.sum_congr rfl fun l _ => ?_
+    rw [map_smul, Algebra.smul_def]
+    rfl
+  obtain ⟨T, hT⟩ : ∃ T : Finset (Module.Basis.ofVectorSpaceIndex K M),
+      ∀ j ∈ s, (R j).support ⊆ T :=
+    ⟨s.biUnion fun j => (R j).support, fun j hj =>
+      Finset.subset_biUnion_of_mem (fun j => (R j).support) hj⟩
+  let κ : Option (Module.Basis.ofVectorSpaceIndex K M) → K' :=
+    fun i => Option.casesOn' i (-1) (fun l => ∑ j ∈ s, R j l • c j)
+  have hinner : ∑ l ∈ T, (∑ j ∈ s, R j l • c j) • algebraMap F F' (v l) =
+      ∑ j ∈ s, algebraMap K' F' (c j) * algebraMap F F' (o j) := by
+    simp_rw [Finset.sum_smul]
+    rw [Finset.sum_comm]
+    refine Finset.sum_congr rfl fun j hj => ?_
+    rw [← hR j T (hT j hj), map_sum, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun l _ => ?_
+    rw [Algebra.smul_def, Algebra.smul_def, map_mul, map_mul,
+      ← IsScalarTower.algebraMap_apply K K' F', ← IsScalarTower.algebraMap_apply K F F']
+    ring
+  have hsum : ∑ i ∈ Finset.insertNone T,
+      κ i • algebraMap F F' (Option.casesOn' i y v) = 0 := by
+    rw [Finset.sum_insertNone]
+    simp only [κ, Option.casesOn'_none, Option.casesOn'_some]
+    rw [hinner, heq, neg_one_smul, neg_add_cancel]
+  have := linearIndependent_iff'.1 hLI (Finset.insertNone T) κ hsum none (by simp)
+  simp [κ] at this
+
+end LinDisj
+
+end W7XUnram
+
+open W7XUnram in
+theorem solution (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K]
+    (hfg : ∃ x : F, Transcendental K x ∧ FiniteDimensional (IntermediateField.adjoin K ({x} : Set
+      F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    [IsCurveOver K F]
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤)
+    (P : Place K F) :
+    ∃ P' : Place K' F',
+      P'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring ∧
+      (∀ f : F, P'.ord (algebraMap F F' f) = P.ord f) ∧
+      ∀ Q' : Place K' F',
+        Q'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring → Q' = P' := by
+  classical
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible P.toValuationSubring
+  have hπ0 : (π : F) ≠ 0 := fun h => hπ.ne_zero (Subtype.ext h)
+  have hπ1 : P.ord (π : F) = 1 := P.ord_coe_irreducible hπ
+  have hπinv : (π : F)⁻¹ ∉ P.toValuationSubring := by
+    intro h
+    have := ord_nonneg_of_mem P h
+    rw [P.ord_inv, hπ1] at this
+    omega
+  let B := Module.Basis.ofVectorSpace K K'
+  have memO : ∀ Q' : Place K' F',
+      Q'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring →
+      ∀ o : P.toValuationSubring, algebraMap F F' (o : F) ∈ Q'.toValuationSubring := by
+    intro Q' hQ o
+    have : (o : F) ∈ Q'.toValuationSubring.comap (algebraMap F F') := by rw [hQ]; exact o.2
+    exact ValuationSubring.mem_comap.1 this
+  have pinv : ∀ Q' : Place K' F',
+      Q'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring →
+      (algebraMap F F' (π : F))⁻¹ ∉ Q'.toValuationSubring := by
+    intro Q' hQ h
+    have h2 : (π : F)⁻¹ ∈ Q'.toValuationSubring.comap (algebraMap F F') :=
+      ValuationSubring.mem_comap.2 (by rwa [map_inv₀])
+    rw [hQ] at h2
+    exact hπinv h2
+  have ordPsi : ∀ w : _ →₀ P.toValuationSubring, w ≠ 0 → ∃ k : ℕ, ∀ Q' : Place K' F',
+      Q'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring →
+      Psi F' B P w ≠ 0 ∧
+        Q'.ord (Psi F' B P w) = k * Q'.ord (algebraMap F F' (π : F)) := by
+    intro w hw
+    obtain ⟨k, d, w', hd, heq⟩ := decomp F' B P hπ w hw
+    refine ⟨k, fun Q' hQ => ?_⟩
+    have hunit := ne_zero_and_inv_mem_of_add Q'.toValuationSubring
+      (a := algebraMap K' F' d) (m := Psi F' B P w') (p := algebraMap F F' (π : F))
+      (Q'.algebraMap_mem' d) (by rw [← map_inv₀]; exact Q'.algebraMap_mem' d⁻¹)
+      (by simpa using hd)
+      (Psi_mem F' B P Q'.toValuationSubring Q'.algebraMap_mem' (memO Q' hQ) w')
+      (memO Q' hQ π) (pinv Q' hQ)
+    have hmem : algebraMap K' F' d + algebraMap F F' (π : F) * Psi F' B P w' ∈
+        Q'.toValuationSubring :=
+      add_mem (Q'.algebraMap_mem' d)
+        (mul_mem (memO Q' hQ π)
+          (Psi_mem F' B P Q'.toValuationSubring Q'.algebraMap_mem' (memO Q' hQ) w'))
+    have hpk : algebraMap F F' (π : F) ^ k ≠ 0 := pow_ne_zero _ ((map_ne_zero _).2 hπ0)
+    refine ⟨by rw [heq]; exact mul_ne_zero hpk hunit.1, ?_⟩
+    rw [heq, Q'.ord_mul hpk hunit.1, ord_eq_zero_of_mem_of_inv_mem Q' hmem hunit.2,
+      ← zpow_natCast, Q'.ord_zpow]
+    ring
+  have ordAny : ∀ z : F', z ≠ 0 → ∃ m : ℤ, ∀ Q' : Place K' F',
+      Q'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring →
+      Q'.ord z = m * Q'.ord (algebraMap F F' (π : F)) := by
+    intro z hz
+    obtain ⟨w₁, w₂, hne, hzw⟩ := exists_mul_Psi_eq F' B P hgen hz
+    have hw₂ : w₂ ≠ 0 := by rintro rfl; exact hne (map_zero _)
+    have hw₁ : w₁ ≠ 0 := by
+      rintro rfl
+      rw [map_zero] at hzw
+      exact mul_ne_zero hz hne hzw
+    obtain ⟨k₁, h₁⟩ := ordPsi w₁ hw₁
+    obtain ⟨k₂, h₂⟩ := ordPsi w₂ hw₂
+    refine ⟨k₁ - k₂, fun Q' hQ => ?_⟩
+    have e₁ := (h₁ Q' hQ).2
+    have e₂ := (h₂ Q' hQ).2
+    have := Q'.ord_mul hz hne
+    rw [hzw, e₁, e₂] at this
+    linarith
+  have eOne : ∀ Q' : Place K' F',
+      Q'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring →
+      Q'.ord (algebraMap F F' (π : F)) = 1 := by
+    intro Q' hQ
+    obtain ⟨π', hπ'⟩ := IsDiscreteValuationRing.exists_irreducible Q'.toValuationSubring
+    have hπ'0 : (π' : F') ≠ 0 := fun h => hπ'.ne_zero (Subtype.ext h)
+    obtain ⟨m, hm⟩ := ordAny (π' : F') hπ'0
+    have h := hm Q' hQ
+    rw [Q'.ord_coe_irreducible hπ'] at h
+    have hnn : 0 ≤ Q'.ord (algebraMap F F' (π : F)) := ord_nonneg_of_mem Q' (memO Q' hQ π)
+    exact Int.eq_one_of_dvd_one hnn ⟨m, by rw [mul_comm]; exact h⟩
+  have ordEq : ∀ Q' : Place K' F',
+      Q'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring →
+      ∀ f : F, Q'.ord (algebraMap F F' f) = P.ord f := by
+    intro Q' hQ f
+    rcases eq_or_ne f 0 with rfl | hf
+    · simp
+    obtain ⟨u, hu⟩ := P.exists_unit_mul_zpow hf hπ
+    have hu0 : algebraMap F F' ((u : P.toValuationSubring) : F) ≠ 0 := by
+      rw [map_ne_zero]
+      exact fun h => u.ne_zero (Subtype.ext h)
+    have hzp : algebraMap F F' (π : F) ^ P.ord f ≠ 0 := zpow_ne_zero _ ((map_ne_zero _).2 hπ0)
+    have huinv : (algebraMap F F' ((u : P.toValuationSubring) : F))⁻¹ ∈ Q'.toValuationSubring := by
+      have hmul : ((u : P.toValuationSubring) : F) *
+          (((u⁻¹ : P.toValuationSubringˣ) : P.toValuationSubring) : F) = 1 := by
+        rw [← MulMemClass.coe_mul, Units.mul_inv, OneMemClass.coe_one]
+      rw [← map_inv₀, ← eq_inv_of_mul_eq_one_right hmul]
+      exact memO Q' hQ _
+    conv_lhs => rw [hu, map_mul, map_zpow₀]
+    rw [Q'.ord_mul hu0 hzp, Q'.ord_zpow, eOne Q' hQ,
+      ord_eq_zero_of_mem_of_inv_mem Q' (memO Q' hQ u) huinv]
+    ring
+  have uniq : ∀ Q₁ Q₂ : Place K' F',
+      Q₁.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring →
+      Q₂.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring → Q₁ = Q₂ := by
+    intro Q₁ Q₂ h1 h2
+    apply Place.ext
+    ext z
+    rcases eq_or_ne z 0 with rfl | hz
+    · simp
+    obtain ⟨m, hm⟩ := ordAny z hz
+    rw [mem_iff_ord_nonneg Q₁ z, mem_iff_ord_nonneg Q₂ z, hm Q₁ h1, hm Q₂ h2, eOne Q₁ h1,
+      eOne Q₂ h2]
+  have hπA : algebraMap F F' (π : F) ∈ rangePsi F' B P := algebraMap_coe_mem_rangePsi F' B P π
+  have hI : Ideal.span {(⟨algebraMap F F' (π : F), hπA⟩ : rangePsi F' B P)} ≠ ⊤ := by
+    intro h
+    rw [Ideal.eq_top_iff_one, Ideal.mem_span_singleton'] at h
+    obtain ⟨a, ha⟩ := h
+    obtain ⟨w, hw⟩ := a.2
+    have ha' : Psi F' B P w * algebraMap F F' (π : F) = 1 := by
+      have := congrArg Subtype.val ha
+      simpa [hw] using this
+    have hy : (π : F)⁻¹ ∉ Submodule.span K (Set.range fun j => ((w j : P.toValuationSubring) : F))
+      :=
+      by
+      let OK : Submodule K F :=
+        { carrier := P.toValuationSubring
+          add_mem' := fun ha hb => add_mem ha hb
+          zero_mem' := zero_mem _
+          smul_mem' := fun c x hx => by
+            rw [Algebra.smul_def]
+            exact mul_mem (P.algebraMap_mem' c) hx }
+      have hle : Submodule.span K (Set.range fun j => ((w j : P.toValuationSubring) : F)) ≤ OK :=
+        Submodule.span_le.2 (by rintro _ ⟨j, rfl⟩; exact (w j).2)
+      exact fun h => hπinv (hle h)
+    have hPsi : Psi F' B P w =
+        ∑ j ∈ w.support, algebraMap K' F' (B j) *
+          algebraMap F F' ((w j : P.toValuationSubring) : F) := by
+      rw [Psi_apply]
+      rfl
+    refine sum_ne_of_not_mem_span hfg hfg' hgen B w.support
+      (fun j => ((w j : P.toValuationSubring) : F)) _ hy ?_
+    rw [← hPsi, map_inv₀]
+    exact eq_inv_of_mul_eq_one_left ha'
+  obtain ⟨V, hAV, hIV⟩ := Ideal.image_subset_nonunits_valuationSubring _ hI
+  have hAV' : ∀ y, y ∈ rangePsi F' B P → y ∈ V := fun y hy => hAV hy
+  have hπV : algebraMap F F' (π : F) ∈ V := hAV' _ hπA
+  have hnu : algebraMap F F' (π : F) ∈ V.nonunits :=
+    hIV ⟨⟨_, hπA⟩, Ideal.mem_span_singleton_self _, rfl⟩
+  have hπVinv : (algebraMap F F' (π : F))⁻¹ ∉ V := by
+    have := (V.inv_mem_nonunits_iff (x := (algebraMap F F' (π : F))⁻¹)).1
+      (by rw [inv_inv]; exact hnu)
+    exact this.resolve_left (inv_ne_zero ((map_ne_zero _).2 hπ0))
+  obtain ⟨t', hfin', hsep'⟩ :=
+    exists_finiteDimensional_isSeparable_adjoin_of_constantFieldExtension_of_isAlgClosed
+      K F K' F' hfg hgen
+  have := hfin'; have := hsep'
+  obtain ⟨P', hP'⟩ :=
+    AlgebraicCurve.Place.exists_toValuationSubring_eq_comap_ringHom_of_isSeparable
+      (K := K') t' (RingHom.id F') V (fun a => hAV' _ (algebraMap_mem_rangePsi F' B P a))
+      ⟨_, hπVinv⟩
+  have hmemP' : ∀ z, z ∈ P'.toValuationSubring ↔ z ∈ V := fun z => by
+    rw [hP', ValuationSubring.mem_comap, RingHom.id_apply]
+  have hover : P'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring := by
+    ext f
+    rw [ValuationSubring.mem_comap, hmemP']
+    refine ⟨fun hfV => ?_, fun hf => hAV' _ (algebraMap_coe_mem_rangePsi F' B P ⟨f, hf⟩)⟩
+    by_contra hfO
+    have hf0 : f ≠ 0 := by rintro rfl; exact hfO (zero_mem _)
+    have hn : P.ord f < 0 := by
+      by_contra h
+      push Not at h
+      exact hfO ((mem_iff_ord_nonneg P f).2 h)
+    obtain ⟨u, hu⟩ := P.exists_unit_mul_zpow hf0 hπ
+    have hui : (((u⁻¹ : P.toValuationSubringˣ) : P.toValuationSubring) : F) *
+        ((u : P.toValuationSubring) : F) = 1 := by
+      rw [← MulMemClass.coe_mul, Units.inv_mul, OneMemClass.coe_one]
+    set n := P.ord f with hn'
+    have key : (π : F)⁻¹ = (((u⁻¹ : P.toValuationSubringˣ) : P.toValuationSubring) : F) * f *
+        (π : F) ^ ((-n - 1).toNat) := by
+      rw [← zpow_natCast, Int.toNat_of_nonneg (by omega)]
+      conv_rhs => rw [hu]
+      calc (π : F)⁻¹ = 1 * ((π : F) ^ n * (π : F) ^ (-n - 1)) := by
+            rw [← zpow_add₀ hπ0, show n + (-n - 1) = -1 by ring, zpow_neg_one, one_mul]
+        _ = _ := by rw [← hui]; ring
+    apply hπVinv
+    rw [← map_inv₀, key, map_mul, map_mul, map_pow]
+    exact mul_mem (mul_mem (hAV' _ (algebraMap_coe_mem_rangePsi F' B P _)) hfV) (pow_mem hπV _)
+  exact ⟨P', hover, ordEq P' hover, fun Q' hQ' => uniq Q' P' hQ' hover⟩
+
+end S_OVERLONG_a5384eef
+end P2MW
+export
+  P2MW.S_OVERLONG_a5384eef
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.exists_comap_algebraMap_eq_of_constantFieldExtension_of_isAlgClosed
+    (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K]
+    (hfg : ∃ x : F, Transcendental K x ∧ FiniteDimensional (IntermediateField.adjoin K ({x} : Set
+      F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    [IsCurveOver K F]
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤)
+    (P : Place K F) :
+    ∃ P' : Place K' F',
+      P'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring ∧
+      (∀ f : F, P'.ord (algebraMap F F' f) = P.ord f) ∧
+      ∀ Q' : Place K' F',
+        Q'.toValuationSubring.comap (algebraMap F F') = P.toValuationSubring → Q' = P' :=
+  solution K F K' F' hfg hfg' hgen P
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_comap_eq_toValuationSubring.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_comap_eq_toValuationSubring.lean
new file mode 100644
index 0000000000..8178b1a0c1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_comap_eq_toValuationSubring.lean
@@ -0,0 +1,165 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.exists_comap_eq_toValuationSubring
+(f0a94d62-2b84-5ebf-8d4e-17901b985295) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c03eea04-a8b3-5147-91c0-9451b8e50766
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.RingTheory.DedekindDomain.IntegralClosure
+import Mathlib.RingTheory.Ideal.GoingUp
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Places extend along finite separable extensions
+
+Theorem statement: `AlgebraicCurve.Place.exists_comap_eq_toValuationSubring`
+(`f0a94d62-2b84-5ebf-8d4e-17901b985295`), by Claude, 2026-09-05.
+
+Proof: submission `c03eea04-a8b3-5147-91c0-9451b8e50766`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $F'$ be fields with $F$ and $F'$ both $K$-algebras, $F'$ an $F$-algebra, the three
+structures compatible ($K \to F \to F'$ a scalar tower), $F'/F$ finite-dimensional and separable.
+Here a place of a field extension $E/K$ is a valuation subring $\mathcal{O} \subseteq E$ such that
+the image of $K$ in $E$ is contained in $\mathcal{O}$, such that $\mathcal{O} \neq E$, and such that
+$\mathcal{O}$ is a principal ideal ring; the data `toValuationSubring` records the valuation subring
+itself. The assertion is that for every place $v$ of $F/K$ there exists a place $w$ of $F'/K$ whose
+valuation subring pulls back to that of $v$ along the structure map $F \to F'$: the preimage
+(`comap`) of $w$'s valuation subring under $\mathrm{algebraMap}\, F\, F'$ equals $v$'s valuation
+subring. Equivalently, the restriction map from places of $F'/K$ to places of $F/K$ is surjective;
+no claim is made here about the number of such $w$, nor about ramification indices or residue
+degrees.
+
+This is the existence half of the classical extension theorem for places of function fields: every
+place of $F/K$ lies below at least one place of a finite separable extension $F'$. It is used in the
+project's treatment of places, orders and divisors, for instance in deducing the existence of a
+place with negative order at a transcendental element, in the multiplicativity of order along an
+extension, and in the criterion for an element with everywhere non-negative order to lie in the
+constant field over an algebraically closed base.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_exists_comap_eq_toValuationSubring.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_exists_comap_eq_toValuationSubring
+
+open IsDedekindDomain
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ofHeightOneSpectrum \
+  ofHeightOneSpectrum_toValuationSubring toValuationSubring"
+p2m_open "AlgebraicCurve.Place AlgebraicCurve"
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+theorem rowMain (v : Place K F) :
+    ∃ w : Place K F', w.toValuationSubring.comap (algebraMap F F') = v.toValuationSubring := by
+  classical
+  let A : Type _ := v.toValuationSubring
+  let : Algebra A F' := ((algebraMap F F').comp (algebraMap A F)).toAlgebra
+  have : IsScalarTower A F F' := IsScalarTower.of_algebraMap_eq (fun _ => rfl)
+  let C : Type _ := integralClosure A F'
+  have : IsDedekindDomain C := integralClosure.isDedekindDomain A F F'
+  have : IsFractionRing C F' := integralClosure.isFractionRing_of_finite_extension F F'
+  let : Algebra K C := ((algebraMap A C).comp (algebraMap K A)).toAlgebra
+  have hAC : ∀ a : A, algebraMap C F' (algebraMap A C a) = algebraMap F F' (a : F) := fun a => rfl
+  have : IsScalarTower K C F' := IsScalarTower.of_algebraMap_eq (fun a => by
+    change algebraMap K F' a = algebraMap C F' (algebraMap A C (algebraMap K A a))
+    rw [hAC, Place.coe_algebraMap, ← IsScalarTower.algebraMap_apply])
+  have hinj : Function.Injective (algebraMap A C) := by
+    intro a b h
+    have h' := congrArg (algebraMap C F') h
+    rw [hAC, hAC] at h'
+    exact Subtype.ext ((algebraMap F F').injective h')
+  obtain ⟨P, hPmax, hP⟩ := Ideal.exists_ideal_over_maximal_of_isIntegral (S := C)
+    (IsLocalRing.maximalIdeal A) (IsLocalRing.le_maximalIdeal (RingHom.ker_ne_top _))
+  have hPne : P ≠ ⊥ := by
+    intro hbot
+    apply IsDiscreteValuationRing.not_a_field A
+    rw [← hP, hbot, Ideal.under_def, Ideal.comap_bot_of_injective _ hinj]
+  let w₀ : HeightOneSpectrum C := ⟨P, hPmax.isPrime, hPne⟩
+  refine ⟨Place.ofHeightOneSpectrum (K := K) w₀, ?_⟩
+  ext f
+  rw [ValuationSubring.mem_comap, Place.ofHeightOneSpectrum_toValuationSubring,
+    Valuation.mem_valuationSubring_iff]
+  constructor
+  · intro hle
+    by_contra hfA
+    have hf0 : f ≠ 0 := by
+      rintro rfl
+      exact hfA (zero_mem _)
+    have hinvA : f⁻¹ ∈ v.toValuationSubring :=
+      (v.toValuationSubring.mem_or_inv_mem f).resolve_left hfA
+    have hnu : (⟨f⁻¹, hinvA⟩ : A) ∈ IsLocalRing.maximalIdeal A := by
+      rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+      intro hu
+      obtain ⟨b, hb⟩ := isUnit_iff_exists_inv.mp hu
+      have hb' : f⁻¹ * (b : F) = 1 := by simpa [Subtype.ext_iff] using hb
+      have hbf : (b : F) = f := by
+        have := congrArg (fun z => f * z) hb'
+        simpa [← mul_assoc, mul_inv_cancel₀ hf0] using this
+      exact hfA (hbf ▸ b.2)
+    have hP' : algebraMap A C ⟨f⁻¹, hinvA⟩ ∈ P := by
+      rw [← Ideal.mem_comap, ← Ideal.under_def, hP]
+      exact hnu
+    have hlt : w₀.valuation F' (algebraMap F F' f⁻¹) < 1 := by
+      rw [show algebraMap F F' f⁻¹ = algebraMap C F' (algebraMap A C ⟨f⁻¹, hinvA⟩) from
+        (hAC ⟨f⁻¹, hinvA⟩).symm]
+      exact (w₀.valuation_lt_one_iff_mem _).mpr hP'
+    rw [map_inv₀, map_inv₀] at hlt
+    have hx0 : w₀.valuation F' (algebraMap F F' f) ≠ 0 :=
+      (Valuation.ne_zero_iff _).mpr ((map_ne_zero _).mpr hf0)
+    have : 1 < w₀.valuation F' (algebraMap F F' f) := (inv_lt_one₀ (zero_lt_iff.mpr hx0)).mp hlt
+    exact absurd hle (not_le.mpr this)
+  · intro hfA
+    rw [show algebraMap F F' f = algebraMap C F' (algebraMap A C ⟨f, hfA⟩) from (hAC ⟨f, hfA⟩).symm]
+    exact w₀.valuation_le_one _
+
+end AlgebraicCurve.Place
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_Place_exists_comap_eq_toValuationSubring.AlgebraicCurve in
+theorem solution {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+    [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+    (v : Place K F) :
+    ∃ w : Place K F', w.toValuationSubring.comap (algebraMap F F') = v.toValuationSubring :=
+  AlgebraicCurve.Place.rowMain v
+
+end S_AlgebraicCurve_Place_exists_comap_eq_toValuationSubring
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_exists_comap_eq_toValuationSubring (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.exists_comap_eq_toValuationSubring {K F F' : Type*} [Field K] [Field F]
+    [Field F'] [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+    [FiniteDimensional F F'] [Algebra.IsSeparable F F'] (v : Place K F) :
+    ∃ w : Place K F', w.toValuationSubring.comap (algebraMap F F') = v.toValuationSubring :=
+  solution v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_forall_ord_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_forall_ord_eq.lean
new file mode 100644
index 0000000000..10ab8e977d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_forall_ord_eq.lean
@@ -0,0 +1,472 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.exists_forall_ord_eq
+(8207ed75-3836-512d-b38f-8500b0fad483) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 81fa1f83-8b62-54ba-848f-cb771184c1c1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Prescribed orders at finitely many places
+
+Theorem statement: `AlgebraicCurve.Place.exists_forall_ord_eq`
+(`8207ed75-3836-512d-b38f-8500b0fad483`), by Claude, 2026-09-05.
+
+Proof: submission `81fa1f83-8b62-54ba-848f-cb771184c1c1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra. A place of $F$ over $K$, in the sense of the
+structure `Place`, consists of a valuation subring $\mathcal{O}_v \subseteq F$ that contains the
+image of $K$ under the structure map, is not the whole of $F$, and is a principal ideal ring;
+attached to such a $v$ there is the adic valuation
+[`AlgebraicCurve.Place.adicValuation`](def/AlgebraicCurve_DivisorClassGroup.html#L102), the
+$\mathbb{Z}^{m0}$-valued valuation of $F$ associated with the height-one prime of $\mathcal{O}_v$,
+and the order function $\operatorname{ord}_v(f) = -\log(v.\mathrm{adicValuation}\, f)$, an
+integer-valued function on $F$. The assertion is that for every finite set $T$ of places of $F$ over
+$K$ and every assignment $n$ of an integer to each place (only the values of $n$ on $T$ play a
+role), there exists an element $f \in F$ with $f \neq 0$ and $\operatorname{ord}_v(f) = n(v)$ for
+all $v \in T$. No further hypotheses on $K$, $F$ or $T$ are imposed; in particular $T$ may be empty.
+
+This is the weak approximation (Artin–Whaples) theorem in the form that finitely many independent
+orders of vanishing can be prescribed simultaneously by a single nonzero function. It is used
+throughout the divisor theory of the project, for instance in the comparison of divisor degrees with
+dimensions of spaces of functions and in the computation of pushforwards and pullbacks of divisors
+along field extensions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_exists_forall_ord_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_exists_forall_ord_eq
+
+open IsDedekindDomain
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ext Place.ord"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext heightOneSpectrum heightOneSpectrum_asIdeal adicValuation \
+  adicValuation_ne_zero adicValuation_coe ord ord_zero ord_one ord_mul ord_inv ord_coe_irreducible \
+  ord_zpow exists_unit_mul_zpow ne_top' toValuationSubring"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mem_iff_adicValuation_le_one' (x : F) :
+    x ∈ v.toValuationSubring ↔ v.adicValuation x ≤ 1 := by
+  constructor
+  · intro hx
+    rw [show x = ((⟨x, hx⟩ : v.toValuationSubring) : F) from rfl, v.adicValuation_coe]
+    exact HeightOneSpectrum.intValuation_le_one _ _
+  · intro hle
+    by_contra hx
+    have hx0 : x ≠ 0 := fun h => hx (h ▸ v.toValuationSubring.zero_mem)
+    have hxi : x⁻¹ ∈ v.toValuationSubring :=
+      (v.toValuationSubring.mem_or_inv_mem x).resolve_left hx
+    have hnu : ¬IsUnit (⟨x⁻¹, hxi⟩ : v.toValuationSubring) := by
+      intro hu
+      obtain ⟨y, hy⟩ := hu.exists_right_inv
+      apply hx
+      have hy' : x⁻¹ * (y : F) = 1 := by
+        have h := congrArg (fun z : v.toValuationSubring => (z : F)) hy
+        simpa using h
+      have hxy : x = (y : F) := (inv_mul_eq_one₀ hx0).mp hy'
+      rw [hxy]
+      exact y.2
+    have hmem : (⟨x⁻¹, hxi⟩ : v.toValuationSubring) ∈ v.heightOneSpectrum.asIdeal := by
+      rw [heightOneSpectrum_asIdeal, IsLocalRing.mem_maximalIdeal]
+      exact hnu
+    have hlt : v.adicValuation x⁻¹ < 1 := by
+      rw [show x⁻¹ = ((⟨x⁻¹, hxi⟩ : v.toValuationSubring) : F) from rfl, v.adicValuation_coe]
+      exact (HeightOneSpectrum.intValuation_lt_one_iff_mem _ _).mpr hmem
+    have hgt : 1 < v.adicValuation x := (Valuation.one_lt_val_iff _ hx0).mpr hlt
+    exact not_le.mpr hgt hle
+
+p2m_export "AlgebraicCurve.Place" "mem_iff_adicValuation_le_one'"
+
+private theorem _root_.AlgebraicCurve.Place.adicValuation_eq_exp_neg_ord {x : F} (hx : x ≠ 0) :
+    v.adicValuation x = WithZero.exp (-v.ord x) := by
+  rw [ord, neg_neg, WithZero.exp_log (v.adicValuation_ne_zero hx)]
+
+p2m_export "AlgebraicCurve.Place" "adicValuation_eq_exp_neg_ord"
+
+private theorem _root_.AlgebraicCurve.Place.mem_iff_ord_nonneg' {x : F} (hx : x ≠ 0) :
+    x ∈ v.toValuationSubring ↔ 0 ≤ v.ord x := by
+  rw [v.mem_iff_adicValuation_le_one', v.adicValuation_eq_exp_neg_ord hx, ← WithZero.exp_zero,
+    WithZero.exp_le_exp, neg_nonpos]
+
+p2m_export "AlgebraicCurve.Place" "mem_iff_ord_nonneg'"
+
+private theorem _root_.AlgebraicCurve.Place.not_mem_iff_ord_neg (x : F) :
+    x ∉ v.toValuationSubring ↔ v.ord x < 0 := by
+  rcases eq_or_ne x 0 with rfl | hx
+  · simp
+  · rw [v.mem_iff_ord_nonneg' hx, not_le]
+
+p2m_export "AlgebraicCurve.Place" "not_mem_iff_ord_neg"
+
+private theorem _root_.AlgebraicCurve.Place.adicValuation_lt_one_iff_ord_pos {x : F} (hx : x ≠ 0) :
+    v.adicValuation x < 1 ↔ 0 < v.ord x := by
+  rw [v.adicValuation_eq_exp_neg_ord hx, ← WithZero.exp_zero, WithZero.exp_lt_exp, neg_lt_zero]
+
+p2m_export "AlgebraicCurve.Place" "adicValuation_lt_one_iff_ord_pos"
+private theorem _root_.AlgebraicCurve.Place.one_lt_adicValuation_iff_ord_neg {x : F} (hx : x ≠ 0) :
+    1 < v.adicValuation x ↔ v.ord x < 0 := by
+  rw [v.adicValuation_eq_exp_neg_ord hx, ← WithZero.exp_zero, WithZero.exp_lt_exp, neg_pos]
+
+p2m_export "AlgebraicCurve.Place" "one_lt_adicValuation_iff_ord_neg"
+theorem adicValuation_le_exp_neg_iff_le_ord {x : F} (hx : x ≠ 0) (N : ℤ) :
+    v.adicValuation x ≤ WithZero.exp (-N) ↔ N ≤ v.ord x := by
+  rw [v.adicValuation_eq_exp_neg_ord hx, WithZero.exp_le_exp, neg_le_neg_iff]
+
+theorem ord_coe_unit_eq_zero_of_le {v w : Place K F}
+    (h : v.toValuationSubring ≤ w.toValuationSubring) (u : v.toValuationSubringˣ) :
+    w.ord ((u : v.toValuationSubring) : F) = 0 := by
+  have hu0 : ((u : v.toValuationSubring) : F) ≠ 0 := by
+    simp [ne_eq, ZeroMemClass.coe_eq_zero]
+  have hui0 : (((u⁻¹ : v.toValuationSubringˣ) : v.toValuationSubring) : F) ≠ 0 := by
+    simp [ne_eq, ZeroMemClass.coe_eq_zero]
+  have h1 : 0 ≤ w.ord ((u : v.toValuationSubring) : F) :=
+    (w.mem_iff_ord_nonneg' hu0).mp (h (u : v.toValuationSubring).2)
+  have h2 : 0 ≤ w.ord (((u⁻¹ : v.toValuationSubringˣ) : v.toValuationSubring) : F) :=
+    (w.mem_iff_ord_nonneg' hui0).mp (h ((u⁻¹ : v.toValuationSubringˣ) : v.toValuationSubring).2)
+  have hprod : (((u⁻¹ : v.toValuationSubringˣ) : v.toValuationSubring) : F)
+      * ((u : v.toValuationSubring) : F) = 1 := by
+    rw [← MulMemClass.coe_mul, ← Units.val_mul, inv_mul_cancel, Units.val_one, OneMemClass.coe_one]
+  have hsum := congrArg w.ord hprod
+  rw [w.ord_mul hui0 hu0, ord_one] at hsum
+  omega
+
+theorem exists_mem_and_not_mem {v w : Place K F} (hvw : v ≠ w) :
+    ∃ x : F, x ∈ v.toValuationSubring ∧ x ∉ w.toValuationSubring := by
+  by_contra! h
+  apply hvw
+  have hle : v.toValuationSubring ≤ w.toValuationSubring := fun x hx => h x hx
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπv : v.ord (π : F) = 1 := v.ord_coe_irreducible hπ
+  have hπ0 : (π : F) ≠ 0 := by
+    intro h0
+    rw [h0, ord_zero] at hπv
+    exact zero_ne_one hπv
+  have hπw : (π : F) ∈ w.toValuationSubring := hle π.2
+  have key : ∀ x : F, x ≠ 0 → w.ord x = v.ord x * w.ord (π : F) := by
+    intro x hx
+    obtain ⟨u, hux⟩ := v.exists_unit_mul_zpow hx hπ
+    have hu0 : ((u : v.toValuationSubring) : F) ≠ 0 := by
+      simp [ne_eq, ZeroMemClass.coe_eq_zero]
+    conv_lhs => rw [hux]
+    rw [w.ord_mul hu0 (zpow_ne_zero _ hπ0), ord_coe_unit_eq_zero_of_le hle u, zero_add, w.ord_zpow]
+  rcases eq_or_ne (w.ord (π : F)) 0 with he | he
+  · exfalso
+    apply w.ne_top'
+    refine SetLike.ext fun x => ⟨fun _ => ValuationSubring.mem_top x, fun _ => ?_⟩
+    rcases eq_or_ne x 0 with rfl | hx
+    · exact zero_mem _
+    · exact (w.mem_iff_ord_nonneg' hx).mpr (by rw [key x hx, he, mul_zero])
+  · have hpos : 0 < w.ord (π : F) :=
+      lt_of_le_of_ne ((w.mem_iff_ord_nonneg' hπ0).mp hπw) he.symm
+    apply Place.ext
+    refine le_antisymm hle fun x hxw => ?_
+    rcases eq_or_ne x 0 with rfl | hx0
+    · exact zero_mem _
+    · have h0 : 0 ≤ w.ord x := (w.mem_iff_ord_nonneg' hx0).mp hxw
+      rw [key x hx0] at h0
+      refine (v.mem_iff_ord_nonneg' hx0).mpr ?_
+      by_contra hneg
+      exact absurd h0 (not_le.mpr (mul_neg_of_neg_of_pos (not_le.mp hneg) hpos))
+
+theorem exists_ord_neg_and_ord_pos {v w : Place K F} (hvw : v ≠ w) :
+    ∃ a : F, v.ord a < 0 ∧ 0 < w.ord a := by
+  obtain ⟨x, hxv, hxw⟩ := exists_mem_and_not_mem hvw
+  obtain ⟨y, hyw, hyv⟩ := exists_mem_and_not_mem hvw.symm
+  have hx0 : x ≠ 0 := fun h => hxw (h ▸ zero_mem _)
+  have hy0 : y ≠ 0 := fun h => hyv (h ▸ zero_mem _)
+  refine ⟨y * x⁻¹, ?_, ?_⟩
+  · rw [v.ord_mul hy0 (inv_ne_zero hx0), v.ord_inv]
+    have h1 : v.ord y < 0 := (v.not_mem_iff_ord_neg y).mp hyv
+    have h2 : 0 ≤ v.ord x := (v.mem_iff_ord_nonneg' hx0).mp hxv
+    omega
+  · rw [w.ord_mul hy0 (inv_ne_zero hx0), w.ord_inv]
+    have h1 : 0 ≤ w.ord y := (w.mem_iff_ord_nonneg' hy0).mp hyw
+    have h2 : w.ord x < 0 := (w.not_mem_iff_ord_neg x).mp hxw
+    omega
+
+private theorem _root_.AlgebraicCurve.Place.one_add_ne_zero_and_ord_eq_of_ord_neg {t : F}
+    (ht : v.ord t < 0) :
+    1 + t ≠ 0 ∧ v.ord (1 + t) = v.ord t := by
+  have ht0 : t ≠ 0 := by rintro rfl; simp at ht
+  have hval : v.adicValuation 1 < v.adicValuation t := by
+    rw [Valuation.map_one, v.adicValuation_eq_exp_neg_ord ht0, ← WithZero.exp_zero,
+      WithZero.exp_lt_exp]
+    omega
+  have hsum : v.adicValuation (1 + t) = v.adicValuation t :=
+    v.adicValuation.map_add_eq_of_lt_right hval
+  have hne : (1 : F) + t ≠ 0 := by
+    intro h
+    rw [h, Valuation.map_zero] at hsum
+    exact v.adicValuation_ne_zero ht0 hsum.symm
+  refine ⟨hne, ?_⟩
+  simp only [Place.ord]
+  rw [hsum]
+
+p2m_export "AlgebraicCurve.Place" "one_add_ne_zero_and_ord_eq_of_ord_neg"
+
+private theorem _root_.AlgebraicCurve.Place.ord_one_add_of_ord_pos {t : F} (ht : 0 < v.ord t) :
+    v.ord (1 + t) = 0 := by
+  have ht0 : t ≠ 0 := by rintro rfl; simp at ht
+  have hval : v.adicValuation t < v.adicValuation 1 := by
+    rw [Valuation.map_one, v.adicValuation_eq_exp_neg_ord ht0, ← WithZero.exp_zero,
+      WithZero.exp_lt_exp]
+    omega
+  have hsum : v.adicValuation (1 + t) = v.adicValuation 1 :=
+    v.adicValuation.map_add_eq_of_lt_left hval
+  simp only [Place.ord]
+  rw [hsum, Valuation.map_one, WithZero.log_one, neg_zero]
+
+p2m_export "AlgebraicCurve.Place" "ord_one_add_of_ord_pos"
+
+theorem exists_ord_neg_forall_ord_pos (T : Finset (Place K F)) {v : Place K F}
+    (hv : v ∉ T) :
+    ∃ z : F, v.ord z < 0 ∧ ∀ w ∈ T, 0 < w.ord z := by
+  classical
+  revert hv
+  induction T using Finset.induction_on with
+  | empty =>
+      intro _
+      obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+      refine ⟨((π : F))⁻¹, ?_, by simp⟩
+      rw [v.ord_inv, v.ord_coe_irreducible hπ]
+      omega
+  | @insert w₀ s hw₀s ih =>
+      intro hv
+      have hvw₀ : v ≠ w₀ := fun h => hv (h ▸ Finset.mem_insert_self w₀ s)
+      have hvs : v ∉ s := fun h => hv (Finset.mem_insert_of_mem h)
+      obtain ⟨z, hzv, hzs⟩ := ih hvs
+      obtain ⟨u, huv, huw₀⟩ := exists_ord_neg_and_ord_pos hvw₀
+      have hz0 : z ≠ 0 := fun h => by simp [h] at hzv
+      have hu0 : u ≠ 0 := fun h => by simp [h] at huv
+      set m : ℕ := (s.sup fun w => (1 - w.ord u).toNat) + 1 with hmdef
+      have hm1 : 1 ≤ m := Nat.le_add_left 1 _
+      have hmw : ∀ w ∈ s, 1 ≤ (m : ℤ) + w.ord u := by
+        intro w hw
+        have h1 : (1 - w.ord u).toNat ≤ s.sup fun w => (1 - w.ord u).toNat :=
+          Finset.le_sup (f := fun w => (1 - w.ord u).toNat) hw
+        omega
+      rcases lt_trichotomy (w₀.ord z) 0 with hc | hc | hc
+      · have ht0 : (z ^ (m : ℤ)) ≠ 0 := zpow_ne_zero _ hz0
+        have htv : v.ord (z ^ (m : ℤ)) < 0 := by
+          rw [v.ord_zpow]
+          exact mul_neg_of_pos_of_neg (by omega) hzv
+        have htw₀ : w₀.ord (z ^ (m : ℤ)) < 0 := by
+          rw [w₀.ord_zpow]
+          exact mul_neg_of_pos_of_neg (by omega) hc
+        obtain ⟨hne, heqv⟩ := v.one_add_ne_zero_and_ord_eq_of_ord_neg htv
+        have heqw₀ := (w₀.one_add_ne_zero_and_ord_eq_of_ord_neg htw₀).2
+        refine ⟨z ^ (m : ℤ) * (1 + z ^ (m : ℤ))⁻¹ * u, ?_, ?_⟩
+        · rw [v.ord_mul (mul_ne_zero ht0 (inv_ne_zero hne)) hu0,
+            v.ord_mul ht0 (inv_ne_zero hne), v.ord_inv, heqv]
+          omega
+        · intro w hw
+          rcases Finset.mem_insert.mp hw with h | hws
+          · rw [h, w₀.ord_mul (mul_ne_zero ht0 (inv_ne_zero hne)) hu0,
+              w₀.ord_mul ht0 (inv_ne_zero hne), w₀.ord_inv, heqw₀]
+            omega
+          · have hwz := hzs w hws
+            have htw : 0 < w.ord (z ^ (m : ℤ)) := by
+              rw [w.ord_zpow]
+              exact mul_pos (by omega) hwz
+            have h1t := w.ord_one_add_of_ord_pos htw
+            rw [w.ord_mul (mul_ne_zero ht0 (inv_ne_zero hne)) hu0,
+              w.ord_mul ht0 (inv_ne_zero hne), w.ord_inv, h1t, w.ord_zpow]
+            have hb : (m : ℤ) * 1 ≤ (m : ℤ) * w.ord z :=
+              mul_le_mul_of_nonneg_left (by omega) (by omega)
+            have h2 := hmw w hws
+            omega
+      · have ht0 : (z ^ (m : ℤ)) ≠ 0 := zpow_ne_zero _ hz0
+        refine ⟨z ^ (m : ℤ) * u, ?_, ?_⟩
+        · rw [v.ord_mul ht0 hu0, v.ord_zpow]
+          have hb : (m : ℤ) * v.ord z ≤ (m : ℤ) * (-1) :=
+            mul_le_mul_of_nonneg_left (by omega) (by omega)
+          omega
+        · intro w hw
+          rcases Finset.mem_insert.mp hw with h | hws
+          · rw [h, w₀.ord_mul ht0 hu0, w₀.ord_zpow, hc]
+            omega
+          · rw [w.ord_mul ht0 hu0, w.ord_zpow]
+            have h1 := hzs w hws
+            have hb : (m : ℤ) * 1 ≤ (m : ℤ) * w.ord z :=
+              mul_le_mul_of_nonneg_left (by omega) (by omega)
+            have h2 := hmw w hws
+            omega
+      · exact ⟨z, hzv, fun w hw =>
+          (Finset.mem_insert.mp hw).elim (fun h => h ▸ hc) (hzs w)⟩
+
+theorem exists_indicator (T : Finset (Place K F)) {v : Place K F} {z : F} (hzv : v.ord z < 0)
+    (hzT : ∀ w ∈ T, w ≠ v → 0 < w.ord z) (N : ℤ) :
+    ∃ e : F, v.adicValuation (e - 1) ≤ WithZero.exp (-N) ∧
+      ∀ w ∈ T, w ≠ v → w.adicValuation e ≤ WithZero.exp (-N) := by
+  have hz0 : z ≠ 0 := by
+    rintro rfl
+    rw [ord_zero] at hzv
+    exact lt_irrefl _ hzv
+  obtain ⟨k, hkN, hk1⟩ : ∃ k : ℕ, N ≤ k ∧ (1 : ℤ) ≤ k :=
+    ⟨N.toNat + 1, by have := Int.self_le_toNat N; push_cast; omega, by push_cast; omega⟩
+  have hy0 : z ^ k ≠ 0 := pow_ne_zero _ hz0
+  have hordy : ∀ w : Place K F, w.ord (z ^ k) = k * w.ord z := fun w => by
+    rw [← zpow_natCast, ord_zpow]
+  have hvy : v.ord (z ^ k) < 0 := by
+    rw [hordy]
+    exact mul_neg_of_pos_of_neg (by exact_mod_cast hk1) hzv
+  have hvy' : 1 < v.adicValuation (z ^ k) := (v.one_lt_adicValuation_iff_ord_neg hy0).mpr hvy
+  have h1y : v.adicValuation (1 + z ^ k) = v.adicValuation (z ^ k) :=
+    Valuation.map_add_eq_of_lt_right _ (by rwa [map_one])
+  have h1y0 : 1 + z ^ k ≠ 0 := by
+    intro h
+    rw [h, map_zero] at h1y
+    exact v.adicValuation_ne_zero hy0 h1y.symm
+  refine ⟨z ^ k / (1 + z ^ k), ?_, fun w hw hwv => ?_⟩
+  · have he : z ^ k / (1 + z ^ k) - 1 = -(1 + z ^ k)⁻¹ := by
+      rw [div_sub_one h1y0, show z ^ k - (1 + z ^ k) = -1 by ring, neg_div, one_div]
+    rw [he, Valuation.map_neg, map_inv₀, h1y, v.adicValuation_eq_exp_neg_ord hy0,
+      ← WithZero.exp_neg, neg_neg, WithZero.exp_le_exp, hordy]
+    nlinarith
+  · have hwy : 0 < w.ord (z ^ k) := by
+      rw [hordy]
+      exact mul_pos (by exact_mod_cast hk1) (hzT w hw hwv)
+    have hwy' : w.adicValuation (z ^ k) < 1 := (w.adicValuation_lt_one_iff_ord_pos hy0).mpr hwy
+    rw [map_div₀, Valuation.map_one_add_of_lt _ hwy', div_one, w.adicValuation_eq_exp_neg_ord hy0,
+      WithZero.exp_le_exp, neg_le_neg_iff, hordy]
+    have hwz : 0 < w.ord z := hzT w hw hwv
+    nlinarith
+
+theorem exists_forall_ord_eq_of_sep (T : Finset (Place K F)) (n : Place K F → ℤ)
+    (hsep : ∀ v ∈ T, ∃ z : F, v.ord z < 0 ∧ ∀ w ∈ T, w ≠ v → 0 < w.ord z) :
+    ∃ f : F, f ≠ 0 ∧ ∀ v ∈ T, v.ord f = n v := by
+  classical
+  rcases T.eq_empty_or_nonempty with rfl | hT
+  · exact ⟨1, one_ne_zero, by simp⟩
+  have hunif : ∀ v : Place K F, ∃ π : F, π ≠ 0 ∧ v.ord π = 1 := fun v => by
+    obtain ⟨ϖ, hϖ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+    refine ⟨ϖ, ?_, v.ord_coe_irreducible hϖ⟩
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hϖ.ne_zero
+  choose π hπ0 hπ1 using hunif
+  set t : Place K F → F := fun v => π v ^ n v with ht
+  have ht0 : ∀ v, t v ≠ 0 := fun v => zpow_ne_zero _ (hπ0 v)
+  have htord : ∀ v w : Place K F, w.ord (t v) = n v * w.ord (π v) := fun v w => by
+    rw [ht, ord_zpow]
+  have htv : ∀ v, v.ord (t v) = n v := fun v => by rw [htord, hπ1, mul_one]
+  set B : ℤ := 1 + ∑ v ∈ T, ∑ w ∈ T, (|n v| + |v.ord (t w)|) with hBdef
+  have hB : ∀ v ∈ T, ∀ w ∈ T, n v - v.ord (t w) + 1 ≤ B := by
+    intro v hv w hw
+    have h1 : |n v| + |v.ord (t w)| ≤ ∑ w' ∈ T, (|n v| + |v.ord (t w')|) :=
+      Finset.single_le_sum (f := fun w' => |n v| + |v.ord (t w')|)
+        (fun _ _ => by positivity) hw
+    have h2 : ∑ w' ∈ T, (|n v| + |v.ord (t w')|)
+        ≤ ∑ v' ∈ T, ∑ w' ∈ T, (|n v'| + |v'.ord (t w')|) :=
+      Finset.single_le_sum (f := fun v' => ∑ w' ∈ T, (|n v'| + |v'.ord (t w')|))
+        (fun _ _ => Finset.sum_nonneg fun _ _ => by positivity) hv
+    have h3 : n v ≤ |n v| := le_abs_self _
+    have h4 : -v.ord (t w) ≤ |v.ord (t w)| := neg_le_abs _
+    omega
+  have hind : ∀ v : Place K F, ∃ e : F, v ∈ T →
+      (v.adicValuation (e - 1) ≤ WithZero.exp (-B) ∧
+        ∀ w ∈ T, w ≠ v → w.adicValuation e ≤ WithZero.exp (-B)) := by
+    intro v
+    by_cases hv : v ∈ T
+    · obtain ⟨z, hz, hzT⟩ := hsep v hv
+      obtain ⟨e, he⟩ := exists_indicator T hz hzT B
+      exact ⟨e, fun _ => he⟩
+    · exact ⟨0, fun h => absurd h hv⟩
+  choose e he using hind
+  have main : ∀ v ∈ T, v.adicValuation (∑ w ∈ T, t w * e w) = WithZero.exp (-(n v)) := by
+    intro v hv
+    have hsplit : ∑ w ∈ T, t w * e w = t v + (t v * (e v - 1) + ∑ w ∈ T.erase v, t w * e w) := by
+      rw [← Finset.add_sum_erase T (fun w => t w * e w) hv]
+      ring
+    have hvt : v.adicValuation (t v) = WithZero.exp (-(n v)) := by
+      rw [v.adicValuation_eq_exp_neg_ord (ht0 v), htv]
+    have hsmall : v.adicValuation (t v * (e v - 1) + ∑ w ∈ T.erase v, t w * e w)
+        ≤ WithZero.exp (-(n v + 1)) := by
+      apply Valuation.map_add_le
+      · rw [map_mul, hvt]
+        calc WithZero.exp (-(n v)) * v.adicValuation (e v - 1)
+            ≤ WithZero.exp (-(n v)) * WithZero.exp (-B) := mul_le_mul_right (he v hv).1 _
+          _ = WithZero.exp (-(n v) + -B) := (WithZero.exp_add _ _).symm
+          _ ≤ WithZero.exp (-(n v + 1)) := WithZero.exp_le_exp.mpr (by
+              have h := hB v hv v hv
+              rw [htv] at h
+              omega)
+      · apply Valuation.map_sum_le
+        intro w hw
+        obtain ⟨hwv, hwT⟩ := Finset.mem_erase.mp hw
+        rw [map_mul, v.adicValuation_eq_exp_neg_ord (ht0 w)]
+        calc WithZero.exp (-(v.ord (t w))) * v.adicValuation (e w)
+            ≤ WithZero.exp (-(v.ord (t w))) * WithZero.exp (-B) :=
+              mul_le_mul_right ((he w hwT).2 v hv hwv.symm) _
+          _ = WithZero.exp (-(v.ord (t w)) + -B) := (WithZero.exp_add _ _).symm
+          _ ≤ WithZero.exp (-(n v + 1)) := WithZero.exp_le_exp.mpr (by
+              have h := hB v hv w hwT
+              omega)
+    rw [hsplit, Valuation.map_add_eq_of_lt_left _ (lt_of_le_of_lt hsmall ?_), hvt]
+    rw [hvt, WithZero.exp_lt_exp]
+    omega
+  obtain ⟨v₀, hv₀⟩ := hT
+  have hf0 : (∑ w ∈ T, t w * e w) ≠ 0 := by
+    intro h0
+    have h := main v₀ hv₀
+    rw [h0, map_zero] at h
+    exact WithZero.exp_ne_zero h.symm
+  refine ⟨∑ w ∈ T, t w * e w, hf0, fun v hv => ?_⟩
+  have h := main v hv
+  rw [v.adicValuation_eq_exp_neg_ord hf0, WithZero.exp_inj] at h
+  omega
+
+end Place
+
+end AlgebraicCurve
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_Place_exists_forall_ord_eq.AlgebraicCurve"
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (T : Finset (Place K F)) (n : Place K F → ℤ) :
+    ∃ f : F, f ≠ 0 ∧ ∀ v ∈ T, v.ord f = n v := by
+  classical
+  refine Place.exists_forall_ord_eq_of_sep T n fun v hv => ?_
+  obtain ⟨z, hzv, hzT⟩ :=
+    Place.exists_ord_neg_forall_ord_pos (T.erase v) (Finset.notMem_erase v T)
+  exact ⟨z, hzv, fun w hw hwv => hzT w (Finset.mem_erase.mpr ⟨hwv, hw⟩)⟩
+
+end S_AlgebraicCurve_Place_exists_forall_ord_eq
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_exists_forall_ord_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.exists_forall_ord_eq {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (T : Finset (Place K F)) (n : Place K F → ℤ) :
+    ∃ f : F, f ≠ 0 ∧ ∀ v ∈ T, v.ord f = n v :=
+  solution T n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_forall_ord_eq_finset.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_forall_ord_eq_finset.lean
new file mode 100644
index 0000000000..eecb082797
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_forall_ord_eq_finset.lean
@@ -0,0 +1,331 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.exists_forall_ord_eq_finset
+(b0296bf0-f966-5c0f-8ba5-91df92753aa8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f67a8ab7-f1e7-55ac-aa57-4ac4a7626053
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_min_ord_le_ord_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_of_ord_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_nonneg_of_mem
+
+/-!
+# Prescribing orders at finitely many places
+
+Theorem statement: `AlgebraicCurve.Place.exists_forall_ord_eq_finset`
+(`b0296bf0-f966-5c0f-8ba5-91df92753aa8`), by Claude, 2026-09-05.
+
+Proof: submission `f67a8ab7-f1e7-55ac-aa57-4ac4a7626053`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $\mathrm{Place}\,K\,F$ denote the type of
+places of $F$ over $K$ in the sense of the project, i.e. of valuation subrings $\mathcal{O}_v
+\subseteq F$ that contain the image of $K$ under the structure map, are not all of $F$, and are
+principal ideal rings. Each such $v$ carries the valuation $v.\mathrm{adicValuation}$ with values in
+$\mathbb{Z}^{m0} = \mathbb{Z} \cup \{0\}$ attached to the associated height-one prime of
+$\mathcal{O}_v$, and the order function $v.\mathrm{ord}(f) =
+-\log\bigl(v.\mathrm{adicValuation}(f)\bigr) \in \mathbb{Z}$. The assertion is: for every finite set
+$S$ of such places and every function $n \colon \mathrm{Place}\,K\,F \to \mathbb{Z}$ (only the
+values of $n$ on $S$ intervene), there exists $g \in F$ with $g \neq 0$ and $v.\mathrm{ord}(g) =
+n(v)$ for all $v \in S$; the prescribed orders are attained exactly, not merely approximately, and
+no condition relating the places or the integers $n(v)$ is imposed.
+
+This is the independence (weak approximation) statement for finitely many places in the style of
+Artin–Whaples, in the form that a single nonzero function may be found with arbitrarily prescribed
+orders at a given finite set of places. It is used in the divisor-theoretic part of the development,
+for instance in the comparison of pullback and pushforward of divisors along a map of curves and in
+the recognition of charts of a component from their rings of integers and place maps.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_exists_forall_ord_eq_finset.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing
+
+namespace AlgebraicCurve
+
+namespace WC1bSolAW
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem ord_neg_impl (v : Place K F) (f : F) : v.ord (-f) = v.ord f := by
+  simp only [Place.ord, Valuation.map_neg]
+
+theorem add_ne_zero_of_ord_lt (v : Place K F) {f g : F} (hlt : v.ord f < v.ord g) :
+    f + g ≠ 0 := by
+  intro h0
+  rw [eq_neg_of_add_eq_zero_right h0, ord_neg_impl] at hlt
+  exact lt_irrefl _ hlt
+
+theorem ord_add_eq_of_ord_lt (v : Place K F) {f g : F} (hf : f ≠ 0) (hg : g ≠ 0)
+    (hlt : v.ord f < v.ord g) : v.ord (f + g) = v.ord f := by
+  have hval : v.adicValuation g < v.adicValuation f := by
+    rw [← WithZero.log_lt_log (v.adicValuation_ne_zero hg) (v.adicValuation_ne_zero hf)]
+    simp only [Place.ord] at hlt
+    omega
+  simp only [Place.ord]
+  rw [Valuation.map_add_eq_of_lt_left _ hval]
+
+theorem ord_lt_zero_of_notMem (v : Place K F) {f : F} (hf : f ≠ 0) (h : f ∉ v.toValuationSubring) :
+    v.ord f < 0 := by
+  by_contra hcon
+  exact h (v.mem_of_ord_nonneg hf (not_lt.mp hcon))
+
+theorem exists_mem_notMem_of_ne {v w : Place K F} (hvw : v ≠ w) :
+    ∃ x : F, x ≠ 0 ∧ x ∈ v.toValuationSubring ∧ x ∉ w.toValuationSubring := by
+  have hle : ¬(v.toValuationSubring ≤ w.toValuationSubring) := fun hle =>
+    hvw (Place.ext (ValuationSubring.eq_of_le_of_ne_top _ hle w.ne_top'))
+  obtain ⟨x, hxv, hxw⟩ := IsConcreteLE.not_le_iff_exists.mp hle
+  exact ⟨x, fun h0 => hxw (h0 ▸ w.toValuationSubring.zero_mem), hxv, hxw⟩
+
+theorem exists_ord_pos_ord_neg_of_ne {v w : Place K F} (hvw : v ≠ w) :
+    ∃ z : F, z ≠ 0 ∧ 0 < v.ord z ∧ w.ord z < 0 := by
+  obtain ⟨x, hx0, hxv, hxw⟩ := exists_mem_notMem_of_ne hvw
+  obtain ⟨y, hy0, hyw, hyv⟩ := exists_mem_notMem_of_ne hvw.symm
+  have hy0' : y⁻¹ ≠ 0 := inv_ne_zero hy0
+  refine ⟨x * y⁻¹, mul_ne_zero hx0 hy0', ?_, ?_⟩
+  · rw [v.ord_mul hx0 hy0', v.ord_inv]
+    have h1 := v.ord_nonneg_of_mem hxv
+    have h2 := ord_lt_zero_of_notMem v hy0 hyv
+    omega
+  · rw [w.ord_mul hx0 hy0', w.ord_inv]
+    have h1 := ord_lt_zero_of_notMem w hx0 hxw
+    have h2 := w.ord_nonneg_of_mem hyw
+    omega
+
+theorem ord_finsetSum_gt {ι : Type*} (v : Place K F) (s : Finset ι) (g : ι → F) (m : ℤ) :
+    (∀ i ∈ s, g i ≠ 0 ∧ m < v.ord (g i)) →
+      s.sum g = 0 ∨ (s.sum g ≠ 0 ∧ m < v.ord (s.sum g)) := by
+  classical
+  induction s using Finset.cons_induction with
+  | empty => exact fun _ => Or.inl Finset.sum_empty
+  | cons i s hi ih =>
+      intro h
+      rw [Finset.sum_cons]
+      obtain ⟨hgi0, hgim⟩ := h i (Finset.mem_cons.mpr (Or.inl rfl))
+      rcases ih (fun j hj => h j (Finset.mem_cons.mpr (Or.inr hj))) with h0 | ⟨hne, hlt⟩
+      · rw [h0, add_zero]
+        exact Or.inr ⟨hgi0, hgim⟩
+      · rcases eq_or_ne (g i + s.sum g) 0 with hz | hz
+        · exact Or.inl hz
+        · refine Or.inr ⟨hz, ?_⟩
+          exact lt_of_lt_of_le (lt_min hgim hlt) (v.min_ord_le_ord_add hgi0 hne hz)
+
+theorem exists_separating (v : Place K F) (S : Finset (Place K F)) :
+    ∃ t : F, t ≠ 0 ∧ 0 < v.ord t ∧ ∀ w ∈ S, w ≠ v → w.ord t < 0 := by
+  classical
+  induction S using Finset.cons_induction with
+  | empty =>
+      obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+      have hπ0 : (π : F) ≠ 0 := by
+        simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+      refine ⟨(π : F), hπ0, ?_, fun w hw => absurd hw (Finset.notMem_empty w)⟩
+      rw [v.ord_coe_irreducible hπ]
+      omega
+  | cons w₀ S' hw₀ ih =>
+      obtain ⟨t₁, ht₁0, ht₁v, ht₁S⟩ := ih
+      rcases eq_or_ne w₀ v with heq | hw₀v
+      · refine ⟨t₁, ht₁0, ht₁v, ?_⟩
+        intro w hw hwv
+        rcases Finset.mem_cons.mp hw with h | h
+        · exact absurd (h.trans heq) hwv
+        · exact ht₁S w h hwv
+      · obtain ⟨t₂, ht₂0, ht₂v, ht₂w⟩ := exists_ord_pos_ord_neg_of_ne (Ne.symm hw₀v)
+        set M : ℕ :=
+          ((Finset.cons w₀ S' hw₀).sup fun w => (1 - w.ord t₁).toNat) + 1 with hM
+        have hM1 : 1 ≤ (M : ℤ) := by
+          rw [hM]; push_cast; omega
+        have hMw : ∀ w ∈ Finset.cons w₀ S' hw₀, -(M : ℤ) < w.ord t₁ := by
+          intro w hw
+          have h1 : (1 - w.ord t₁).toNat
+              ≤ (Finset.cons w₀ S' hw₀).sup fun w' => (1 - w'.ord t₁).toNat :=
+            Finset.le_sup (f := fun w' => (1 - w'.ord t₁).toNat) hw
+          have h3 : ((1 - w.ord t₁).toNat : ℤ)
+              ≤ (((Finset.cons w₀ S' hw₀).sup fun w' => (1 - w'.ord t₁).toNat : ℕ) : ℤ) := by
+            exact_mod_cast h1
+          rw [hM]; push_cast; omega
+        have hpow0 : t₂ ^ (M : ℤ) ≠ 0 := zpow_ne_zero _ ht₂0
+        have hw₀lt : w₀.ord (t₂ ^ (M : ℤ)) < w₀.ord t₁ := by
+          rw [w₀.ord_zpow]
+          have h5 : (M : ℤ) * w₀.ord t₂ ≤ (M : ℤ) * (-1) :=
+            mul_le_mul_of_nonneg_left (by omega) (by omega)
+          have h6 := hMw w₀ (Finset.mem_cons.mpr (Or.inl rfl))
+          linarith
+        have hu0 : t₁ + t₂ ^ (M : ℤ) ≠ 0 := by
+          have h := add_ne_zero_of_ord_lt w₀ hw₀lt
+          rwa [add_comm (t₂ ^ (M : ℤ)) t₁] at h
+        refine ⟨t₁ + t₂ ^ (M : ℤ), hu0, ?_, ?_⟩
+        · have hposM : 0 < v.ord (t₂ ^ (M : ℤ)) := by
+            rw [v.ord_zpow]
+            exact mul_pos (by omega) ht₂v
+          exact lt_of_lt_of_le (lt_min ht₁v hposM) (v.min_ord_le_ord_add ht₁0 hpow0 hu0)
+        · intro w hw hwv
+          rcases Finset.mem_cons.mp hw with heqw | hwS'
+          · rw [heqw, add_comm t₁ (t₂ ^ (M : ℤ)),
+              ord_add_eq_of_ord_lt w₀ hpow0 ht₁0 hw₀lt, w₀.ord_zpow]
+            have h5 : (M : ℤ) * w₀.ord t₂ ≤ (M : ℤ) * (-1) :=
+              mul_le_mul_of_nonneg_left (by omega) (by omega)
+            linarith
+          · have hward := ht₁S w hwS' hwv
+            rcases le_or_gt 0 (w.ord t₂) with hpos | hneg
+            · have hlt : w.ord t₁ < w.ord (t₂ ^ (M : ℤ)) := by
+                rw [w.ord_zpow]
+                have h7 : 0 ≤ (M : ℤ) * w.ord t₂ := mul_nonneg (by omega) hpos
+                linarith
+              rw [ord_add_eq_of_ord_lt w ht₁0 hpow0 hlt]
+              exact hward
+            · have hlt : w.ord (t₂ ^ (M : ℤ)) < w.ord t₁ := by
+                rw [w.ord_zpow]
+                have h5 : (M : ℤ) * w.ord t₂ ≤ (M : ℤ) * (-1) :=
+                  mul_le_mul_of_nonneg_left (by omega) (by omega)
+                have h6 := hMw w (Finset.mem_cons.mpr (Or.inr hwS'))
+                linarith
+              rw [add_comm t₁ (t₂ ^ (M : ℤ)),
+                ord_add_eq_of_ord_lt w hpow0 ht₁0 hlt, w.ord_zpow]
+              have h5 : (M : ℤ) * w.ord t₂ ≤ (M : ℤ) * (-1) :=
+                mul_le_mul_of_nonneg_left (by omega) (by omega)
+              linarith
+
+theorem exists_forall_ord_eq_finset (S : Finset (Place K F)) (n : Place K F → ℤ) :
+    ∃ g : F, g ≠ 0 ∧ ∀ v ∈ S, v.ord g = n v := by
+  classical
+  rcases S.eq_empty_or_nonempty with rfl | hSne
+  · exact ⟨1, one_ne_zero, fun v hv => absurd hv (Finset.notMem_empty v)⟩
+  have hsep : ∀ v : Place K F, ∃ t : F, t ≠ 0 ∧ 0 < v.ord t ∧
+      ∀ w ∈ S, w ≠ v → w.ord t < 0 := fun v => exists_separating v S
+  choose t ht0 htv htS using hsep
+  have hunif : ∀ v : Place K F, ∃ π : v.toValuationSubring, Irreducible π := fun v =>
+    IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  choose π hπ using hunif
+  have hπ0 : ∀ v : Place K F, ((π v : F)) ≠ 0 := by
+    intro v
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using (hπ v).ne_zero
+  set a : Place K F → F := fun v => ((π v : F)) ^ (n v) with ha
+  have ha0 : ∀ v, a v ≠ 0 := by
+    intro v
+    simp only [ha]
+    exact zpow_ne_zero _ (hπ0 v)
+  have hav : ∀ v, v.ord (a v) = n v := by
+    intro v
+    simp only [ha]
+    rw [v.ord_zpow, v.ord_coe_irreducible (hπ v), mul_one]
+  set P : ℕ := (S.sup fun v => S.sup fun w => (n v - v.ord (a w)).toNat) + 1 with hP
+  have hP1 : 1 ≤ (P : ℤ) := by
+    rw [hP]; push_cast; omega
+  have hPbound : ∀ v ∈ S, ∀ w ∈ S, n v - v.ord (a w) < (P : ℤ) := by
+    intro v hv w hw
+    have h1 : (n v - v.ord (a w)).toNat
+        ≤ S.sup fun w' => (n v - v.ord (a w')).toNat :=
+      Finset.le_sup (f := fun w' => (n v - v.ord (a w')).toNat) hw
+    have h2 : (S.sup fun w' => (n v - v.ord (a w')).toNat)
+        ≤ S.sup fun v' => S.sup fun w' => (n v' - v'.ord (a w')).toNat :=
+      Finset.le_sup (f := fun v' => S.sup fun w' => (n v' - v'.ord (a w')).toNat) hv
+    have h3 : ((n v - v.ord (a w)).toNat : ℤ)
+        ≤ ((S.sup fun v' => S.sup fun w' => (n v' - v'.ord (a w')).toNat : ℕ) : ℤ) := by
+      exact_mod_cast le_trans h1 h2
+    rw [hP]; push_cast; omega
+  have hpow0 : ∀ v : Place K F, t v ^ (P : ℤ) ≠ 0 := fun v => zpow_ne_zero _ (ht0 v)
+  have hltden : ∀ v : Place K F, v.ord (1 : F) < v.ord (t v ^ (P : ℤ)) := by
+    intro v
+    rw [v.ord_one, v.ord_zpow]
+    exact mul_pos (by omega) (htv v)
+  have hden : ∀ v : Place K F, (1 : F) + t v ^ (P : ℤ) ≠ 0 := fun v =>
+    add_ne_zero_of_ord_lt v (hltden v)
+  have hdenord : ∀ v : Place K F, v.ord ((1 : F) + t v ^ (P : ℤ)) = 0 := by
+    intro v
+    rw [ord_add_eq_of_ord_lt v one_ne_zero (hpow0 v) (hltden v), v.ord_one]
+  have hdenord' : ∀ v : Place K F, ∀ w ∈ S, w ≠ v →
+      w.ord ((1 : F) + t v ^ (P : ℤ)) = (P : ℤ) * w.ord (t v) := by
+    intro v w hw hwv
+    have hneg : w.ord (t v ^ (P : ℤ)) < w.ord (1 : F) := by
+      rw [w.ord_one, w.ord_zpow]
+      have h1 := htS v w hw hwv
+      have h5 : (P : ℤ) * w.ord (t v) ≤ (P : ℤ) * (-1) :=
+        mul_le_mul_of_nonneg_left (by omega) (by omega)
+      linarith
+    rw [add_comm ((1 : F)) (t v ^ (P : ℤ)),
+      ord_add_eq_of_ord_lt w (hpow0 v) one_ne_zero hneg, w.ord_zpow]
+  set u : Place K F → F := fun v => a v * ((1 : F) + t v ^ (P : ℤ))⁻¹ with hu
+  have hu0 : ∀ v, u v ≠ 0 := by
+    intro v
+    simp only [hu]
+    exact mul_ne_zero (ha0 v) (inv_ne_zero (hden v))
+  have huord : ∀ v, v.ord (u v) = n v := by
+    intro v
+    simp only [hu]
+    rw [v.ord_mul (ha0 v) (inv_ne_zero (hden v)), v.ord_inv, hdenord v, hav v]
+    omega
+  have huord' : ∀ v : Place K F, ∀ w ∈ S, w ≠ v →
+      w.ord (u v) = w.ord (a v) - (P : ℤ) * w.ord (t v) := by
+    intro v w hw hwv
+    simp only [hu]
+    rw [w.ord_mul (ha0 v) (inv_ne_zero (hden v)), w.ord_inv, hdenord' v w hw hwv]
+    ring
+  have htail : ∀ v ∈ S, ∀ w ∈ S, w ≠ v → n v < v.ord (u w) := by
+    intro v hv w hw hwv
+    have h1 : v.ord (u w) = v.ord (a w) - (P : ℤ) * v.ord (t w) :=
+      huord' w v hv (Ne.symm hwv)
+    have h2 := htS w v hv (Ne.symm hwv)
+    have h3 := hPbound v hv w hw
+    have h5 : (P : ℤ) * v.ord (t w) ≤ (P : ℤ) * (-1) :=
+      mul_le_mul_of_nonneg_left (by omega) (by omega)
+    rw [h1]
+    linarith
+  have hmain : ∀ v ∈ S, S.sum u ≠ 0 ∧ v.ord (S.sum u) = n v := by
+    intro v hv
+    have hsplit : S.sum u = u v + (S.erase v).sum u :=
+      (Finset.add_sum_erase S u hv).symm
+    have hcond : ∀ w ∈ S.erase v, u w ≠ 0 ∧ n v < v.ord (u w) := by
+      intro w hw
+      obtain ⟨hwv, hwS⟩ := Finset.mem_erase.mp hw
+      exact ⟨hu0 w, htail v hv w hwS hwv⟩
+    rcases ord_finsetSum_gt v (S.erase v) u (n v) hcond with h0 | ⟨hne, hlt⟩
+    · rw [hsplit, h0, add_zero]
+      exact ⟨hu0 v, huord v⟩
+    · have hltu : v.ord (u v) < v.ord ((S.erase v).sum u) := by
+        rw [huord v]; exact hlt
+      constructor
+      · rw [hsplit]
+        exact add_ne_zero_of_ord_lt v hltu
+      · rw [hsplit, ord_add_eq_of_ord_lt v (hu0 v) hne hltu]
+        exact huord v
+  obtain ⟨v₀, hv₀⟩ := hSne
+  exact ⟨S.sum u, (hmain v₀ hv₀).1, fun v hv => (hmain v hv).2⟩
+
+end WC1bSolAW
+
+end AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (S : Finset (AlgebraicCurve.Place K F)) (n : AlgebraicCurve.Place K F → ℤ) :
+    ∃ g : F, g ≠ 0 ∧ ∀ v ∈ S, v.ord g = n v :=
+  AlgebraicCurve.WC1bSolAW.exists_forall_ord_eq_finset S n
+
+end
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.exists_forall_ord_eq_finset {K F : Type*} [Field K] [Field F]
+    [Algebra K F] (S : Finset (AlgebraicCurve.Place K F)) (n : AlgebraicCurve.Place K F → ℤ) :
+    ∃ g : F, g ≠ 0 ∧ ∀ v ∈ S, v.ord g = n v :=
+  solution S n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_of_orderMap.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_of_orderMap.lean
new file mode 100644
index 0000000000..d8a60b47b5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_of_orderMap.lean
@@ -0,0 +1,243 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.exists_of_orderMap
+(f7694004-f5e3-581d-9a88-1005ec0c1bd0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d8751259-a283-5de7-9c81-09ff41d24034
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Discrete order functions trivial on K come from places
+
+Theorem statement: `AlgebraicCurve.Place.exists_of_orderMap`
+(`f7694004-f5e3-581d-9a88-1005ec0c1bd0`), by Claude, 2026-09-05.
+
+Proof: submission `d8751259-a283-5de7-9c81-09ff41d24034`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K \subseteq F$ be fields with $F$ a $K$-algebra, and let $\mu : F \to \mathbb{Z} \cup \{\top\}$
+be any function satisfying: $\mu(x) = \top$ exactly when $x = 0$; $\mu(xy) = \mu(x) + \mu(y)$ for
+all $x, y \in F$; $\min(\mu(x),\mu(y)) \le \mu(x+y)$ for all $x, y \in F$;
+$\mu(\mathrm{algebraMap}_{K,F}(c)) = 0$ for every nonzero $c \in K$; and there exists $x \in F$ with
+$0 < \mu(x) \ne \top$. The conclusion asserts the existence of a place $P$ of $F$ over $K$ — that
+is, an element of [`AlgebraicCurve.Place K F`](def/AlgebraicCurve_DivisorClassGroup.html#L22),
+consisting of a valuation subring $\mathcal{O}_P$ of $F$ which contains the image of $K$ under the
+algebra map, is not the whole of $F$, and is a principal ideal ring — together with a natural number
+$e > 0$, such that $\mathcal{O}_P$ is precisely the set of $x \in F$ with $0 \le \mu(x)$, and such
+that for every nonzero $x \in F$ one has $\mu(x) = e \cdot \operatorname{ord}_P(x)$ in $\mathbb{Z}
+\cup \{\top\}$, where $\operatorname{ord}_P(x)$ is the negative of the logarithm of the value at $x$
+of the valuation attached to the height-one prime of $\mathcal{O}_P$.
+
+This is the standard recognition of a rank-one discrete order function on a function field, trivial
+on the constants, as a positive integral multiple of the normalised valuation of a place; the
+integer $e$ accounts for the possible non-surjectivity of $\mu$ onto $\mathbb{Z}$. It is used
+throughout the modular-curve part of the development to produce places from explicitly constructed
+order functions, for instance in the computations of ramification indices along inclusions of
+modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_exists_of_orderMap.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_exists_of_orderMap
+
+open WithZero
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (μ : F → WithTop ℤ) (h_top : ∀ x, μ x = ⊤ ↔ x = 0)
+    (h_mul : ∀ x y, μ (x * y) = μ x + μ y) (h_add : ∀ x y, min (μ x) (μ y) ≤ μ (x + y))
+    (h_const : ∀ c : K, c ≠ 0 → μ (algebraMap K F c) = 0) (h_nontriv : ∃ x, 0 < μ x ∧ μ x ≠ ⊤) :
+    ∃ (P : AlgebraicCurve.Place K F) (e : ℕ), 0 < e ∧
+      (∀ x, x ∈ P.toValuationSubring ↔ 0 ≤ μ x) ∧
+      ∀ x, x ≠ 0 → μ x = (((e : ℤ) * P.ord x : ℤ) : WithTop ℤ) := by
+  classical
+  let w : WithTop ℤ → ℤᵐ⁰ := fun a => WithTop.recTopCoe (0 : ℤᵐ⁰) (fun n : ℤ => exp (-n)) a
+  have w_top : w ⊤ = 0 := rfl
+  have w_coe : ∀ n : ℤ, w n = exp (-n) := fun n => rfl
+  have w_zero : w 0 = 1 := by rw [← WithTop.coe_zero, w_coe, neg_zero, exp_zero]
+  have w_add : ∀ a b, w (a + b) = w a * w b := by
+    intro a b
+    induction a with
+    | top => rw [top_add, w_top, zero_mul]
+    | coe a =>
+      induction b with
+      | top => rw [add_top, w_top, mul_zero]
+      | coe b => rw [← WithTop.coe_add, w_coe, w_coe, w_coe, ← exp_add, neg_add]
+  have w_le : ∀ a b, w a ≤ w b ↔ b ≤ a := by
+    intro a b
+    induction a with
+    | top =>
+      induction b with
+      | top => simp [w_top]
+      | coe b => simp [w_top, w_coe]
+    | coe a =>
+      induction b with
+      | top => simp [w_top, w_coe]
+      | coe b =>
+        rw [w_coe, w_coe, exp_le_exp, neg_le_neg_iff, WithTop.coe_le_coe]
+  have μ_one : μ 1 = 0 := by simpa using h_const 1 one_ne_zero
+  let v : Valuation F ℤᵐ⁰ :=
+    { toFun := fun x => w (μ x)
+      map_zero' := by change w (μ 0) = 0; rw [(h_top 0).mpr rfl, w_top]
+      map_one' := by change w (μ 1) = 1; rw [μ_one, w_zero]
+      map_mul' := fun x y => by change w (μ (x * y)) = w (μ x) * w (μ y); rw [h_mul, w_add]
+      map_add_le_max' := fun x y => by
+        change w (μ (x + y)) ≤ max (w (μ x)) (w (μ y))
+        rcases le_total (μ x) (μ y) with hxy | hxy
+        · refine le_trans ?_ (le_max_left _ _)
+          rw [w_le]; exact le_trans (by simp [hxy]) (h_add x y)
+        · refine le_trans ?_ (le_max_right _ _)
+          rw [w_le]; exact le_trans (by simp [hxy]) (h_add x y) }
+  have v_apply : ∀ x, v x = w (μ x) := fun x => rfl
+  have mem_iff : ∀ x, x ∈ v.valuationSubring ↔ 0 ≤ μ x := by
+    intro x
+    rw [Valuation.mem_valuationSubring_iff, v_apply, ← w_zero, w_le]
+  obtain ⟨x₀, hx₀pos, hx₀top⟩ := h_nontriv
+  have hx₀ne : x₀ ≠ 0 := fun h => hx₀top ((h_top x₀).mpr h)
+  let hnt : v.IsNontrivial := by
+    refine ⟨x₀, ?_, ?_⟩
+    · rw [v_apply]
+      obtain ⟨n, hn⟩ := WithTop.ne_top_iff_exists.mp hx₀top
+      rw [← hn, w_coe]; exact exp_ne_zero
+    · rw [v_apply, ne_eq, ← w_zero]
+      intro h
+      have h1 := (w_le 0 (μ x₀)).mp h.ge
+      exact absurd (lt_of_lt_of_le hx₀pos h1) (lt_irrefl _)
+  have : Nontrivial v.toMonoidWithZeroHom.valueGroup := by
+    obtain ⟨x, h0, h1⟩ := hnt.exists_val_nontrivial
+    rw [Subgroup.nontrivial_iff_exists_ne_one]
+    use Units.mk0 (v x) h0, v.mem_valueGroup (Set.mem_range_self x)
+    simpa [Units.ext_iff]
+  have : IsCyclic v.toMonoidWithZeroHom.valueGroup := inferInstance
+  have hPIR : IsPrincipalIdealRing v.valuationSubring :=
+    Valuation.valuationSubring_isPrincipalIdealRing v
+  have hK : ∀ a : K, algebraMap K F a ∈ v.valuationSubring := by
+    intro a
+    rw [mem_iff]
+    rcases eq_or_ne a 0 with rfl | ha
+    · rw [map_zero, (h_top 0).mpr rfl]; exact le_top
+    · rw [h_const a ha]
+  have hne : v.valuationSubring ≠ ⊤ := by
+    intro h
+    have : x₀⁻¹ ∈ v.valuationSubring := h ▸ ValuationSubring.mem_top _
+    rw [mem_iff] at this
+    have hinv : μ x₀⁻¹ + μ x₀ = 0 := by rw [← h_mul, inv_mul_cancel₀ hx₀ne, μ_one]
+    obtain ⟨n, hn⟩ := WithTop.ne_top_iff_exists.mp hx₀top
+    have hitop : μ x₀⁻¹ ≠ ⊤ := by
+      rw [ne_eq, h_top]; exact inv_ne_zero hx₀ne
+    obtain ⟨m, hm⟩ := WithTop.ne_top_iff_exists.mp hitop
+    rw [← hn, ← hm, ← WithTop.coe_add, ← WithTop.coe_zero, WithTop.coe_eq_coe] at hinv
+    rw [← hm, ← WithTop.coe_zero, WithTop.coe_le_coe] at this
+    rw [← hn, ← WithTop.coe_zero, WithTop.coe_lt_coe] at hx₀pos
+    omega
+  let P : AlgebraicCurve.Place K F :=
+    { toValuationSubring := v.valuationSubring
+      algebraMap_mem' := hK
+      ne_top' := hne
+      isPrincipalIdealRing' := hPIR }
+  obtain ⟨ϖ, hϖ⟩ := IsDiscreteValuationRing.exists_irreducible P.toValuationSubring
+  have hϖ0 : (ϖ : F) ≠ 0 := by
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hϖ.ne_zero
+  have hϖtop : μ (ϖ : F) ≠ ⊤ := by rwa [ne_eq, h_top]
+  have hϖmem : 0 ≤ μ (ϖ : F) := (mem_iff _).mp ϖ.2
+  have μ_unit : ∀ u : (P.toValuationSubring)ˣ, μ ((u : P.toValuationSubring) : F) = 0 := by
+    intro u
+    have h1 : 0 ≤ μ ((u : P.toValuationSubring) : F) :=
+      (mem_iff _).mp (u : P.toValuationSubring).2
+    have h2 : 0 ≤ μ (((u⁻¹ : (P.toValuationSubring)ˣ) : P.toValuationSubring) : F) :=
+      (mem_iff _).mp ((u⁻¹ : (P.toValuationSubring)ˣ) : P.toValuationSubring).2
+    have h3 : μ ((u : P.toValuationSubring) : F) +
+        μ (((u⁻¹ : (P.toValuationSubring)ˣ) : P.toValuationSubring) : F) = 0 := by
+      rw [← h_mul, ← Subring.coe_mul, Units.mul_inv, OneMemClass.coe_one, μ_one]
+    have hut : μ ((u : P.toValuationSubring) : F) ≠ ⊤ := by
+      intro h; rw [h, top_add] at h3; exact WithTop.top_ne_zero h3
+    have hu't : μ (((u⁻¹ : (P.toValuationSubring)ˣ) : P.toValuationSubring) : F) ≠ ⊤ := by
+      intro h; rw [h, add_top] at h3; exact WithTop.top_ne_zero h3
+    obtain ⟨a, ha⟩ := WithTop.ne_top_iff_exists.mp hut
+    obtain ⟨b, hb⟩ := WithTop.ne_top_iff_exists.mp hu't
+    rw [← ha, ← hb, ← WithTop.coe_add, ← WithTop.coe_zero, WithTop.coe_eq_coe] at h3
+    rw [← ha, ← WithTop.coe_zero, WithTop.coe_le_coe] at h1
+    rw [← hb, ← WithTop.coe_zero, WithTop.coe_le_coe] at h2
+    rw [← ha, ← WithTop.coe_zero, WithTop.coe_eq_coe]
+    omega
+  have hϖpos : 0 < μ (ϖ : F) := by
+    rcases hϖmem.lt_or_eq with h | h
+    · exact h
+    · exfalso
+      apply hϖ.not_isUnit
+      have hinv : (ϖ : F)⁻¹ ∈ P.toValuationSubring := by
+        refine (mem_iff _).mpr ?_
+        have : μ (ϖ : F)⁻¹ + μ (ϖ : F) = 0 := by rw [← h_mul, inv_mul_cancel₀ hϖ0, μ_one]
+        rw [← h, add_zero] at this
+        rw [this]
+      exact ⟨⟨ϖ, ⟨(ϖ : F)⁻¹, hinv⟩, Subtype.ext (mul_inv_cancel₀ hϖ0),
+        Subtype.ext (inv_mul_cancel₀ hϖ0)⟩, rfl⟩
+  obtain ⟨e, he⟩ := WithTop.ne_top_iff_exists.mp hϖtop
+  rw [← he, ← WithTop.coe_zero, WithTop.coe_lt_coe] at hϖpos
+  refine ⟨P, e.toNat, by omega, mem_iff, fun x hx => ?_⟩
+  obtain ⟨u, hu⟩ := P.exists_unit_mul_zpow hx hϖ
+  have μ_zpow : ∀ n : ℤ, μ ((ϖ : F) ^ n) = ((n * e : ℤ) : WithTop ℤ) := by
+    have μ_pow : ∀ n : ℕ, μ ((ϖ : F) ^ n) = ((n * e : ℤ) : WithTop ℤ) := by
+      intro n
+      induction n with
+      | zero => rw [pow_zero, μ_one]; simp
+      | succ n ih =>
+        rw [pow_succ, h_mul, ih, ← he, ← WithTop.coe_add]
+        congr 1; push_cast; ring
+    intro n
+    rcases Int.eq_nat_or_neg n with ⟨m, rfl | rfl⟩
+    · rw [zpow_natCast, μ_pow]
+    · rw [zpow_neg, zpow_natCast]
+      have hpm : μ ((ϖ : F) ^ m)⁻¹ + μ ((ϖ : F) ^ m) = 0 := by
+        rw [← h_mul, inv_mul_cancel₀ (pow_ne_zero _ hϖ0), μ_one]
+      have hpt : μ ((ϖ : F) ^ m)⁻¹ ≠ ⊤ := by
+        rw [ne_eq, h_top]; exact inv_ne_zero (pow_ne_zero _ hϖ0)
+      obtain ⟨c, hc⟩ := WithTop.ne_top_iff_exists.mp hpt
+      rw [μ_pow, ← hc, ← WithTop.coe_add, ← WithTop.coe_zero, WithTop.coe_eq_coe] at hpm
+      rw [← hc, WithTop.coe_eq_coe]
+      linarith
+  have hfin : μ x = ((P.ord x * e : ℤ) : WithTop ℤ) := by
+    conv_lhs => rw [hu]
+    rw [h_mul, μ_unit, zero_add, μ_zpow]
+  rw [hfin, Int.toNat_of_nonneg hϖpos.le, mul_comm]
+
+end S_AlgebraicCurve_Place_exists_of_orderMap
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_exists_of_orderMap (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.exists_of_orderMap {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (μ : F → WithTop ℤ) (h_top : ∀ x, μ x = ⊤ ↔ x = 0)
+    (h_mul : ∀ x y, μ (x * y) = μ x + μ y) (h_add : ∀ x y, min (μ x) (μ y) ≤ μ (x + y))
+    (h_const : ∀ c : K, c ≠ 0 → μ (algebraMap K F c) = 0) (h_nontriv : ∃ x, 0 < μ x ∧ μ x ≠ ⊤) :
+    ∃ (P : AlgebraicCurve.Place K F) (e : ℕ), 0 < e ∧
+      (∀ x, x ∈ P.toValuationSubring ↔ 0 ≤ μ x) ∧
+      ∀ x, x ≠ 0 → μ x = (((e : ℤ) * P.ord x : ℤ) : WithTop ℤ) :=
+  solution μ h_top h_mul h_add h_const h_nontriv
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_of_valuationSubring.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_of_valuationSubring.lean
new file mode 100644
index 0000000000..5d59072b57
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_of_valuationSubring.lean
@@ -0,0 +1,293 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.exists_of_valuationSubring
+(4fe3a0ac-4780-5232-9fbe-e71dab745d3d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 414d8dd8-c913-5f0e-bd96-76c3afaa615d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.RingTheory.DedekindDomain.IntegralClosure
+import Mathlib.RingTheory.DedekindDomain.Dvr
+import Mathlib.RingTheory.DiscreteValuationRing.TFAE
+import Mathlib.RingTheory.Localization.Integral
+import Mathlib.RingTheory.Valuation.LocalSubring
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Algebra
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Nontrivial valuation subrings over the constants are places
+
+Theorem statement: `AlgebraicCurve.Place.exists_of_valuationSubring`
+(`4fe3a0ac-4780-5232-9fbe-e71dab745d3d`), by Claude, 2026-09-05.
+
+Proof: submission `414d8dd8-c913-5f0e-bd96-76c3afaa615d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and assume $K$ has characteristic zero. Let $x \in
+F$ be such that $F$ is finite-dimensional as a vector space over the intermediate field $K(x) =$
+`IntermediateField.adjoin K {x}` generated by $x$ over $K$; thus $F$ is a one-variable function
+field over $K$ when $x$ is transcendental, and a finite extension of $K$ otherwise. Let $A$ be a
+valuation subring of $F$ such that $\mathrm{algebraMap}_{K \to F}(a) \in A$ for every $a \in K$, and
+such that $A \neq \top$, i.e. $A$ is not all of $F$. The conclusion is that there exists a place $v$
+of $F$ over $K$, in the sense of the structure
+[`AlgebraicCurve.Place`](def/AlgebraicCurve_DivisorClassGroup.html#L22), whose underlying valuation
+subring is exactly $A$. Since a term of [`AlgebraicCurve.Place K
+F`](def/AlgebraicCurve_DivisorClassGroup.html#L22) consists of a valuation subring of $F$ containing
+the image of $K$, distinct from $\top$, and which is a principal ideal ring, and two of these three
+conditions are hypotheses, the mathematical content of the statement is that such an $A$ is
+automatically a principal ideal ring, i.e. a discrete valuation ring.
+
+This is the standard fact that in a one-variable function field (or a finite extension of the
+constant field) every nontrivial valuation ring containing the constants is discrete, which is what
+makes the valuation-theoretic and the divisor-theoretic descriptions of the points of a curve agree.
+It is the recognition criterion by which valuation subrings arising in other constructions — base
+change of the constant field, descent of divisor classes, correspondences on regular differentials —
+are converted into places of the function field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_exists_of_valuationSubring.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_exists_of_valuationSubring
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_Place_exists_of_valuationSubring.AlgebraicCurve \
+  IsDedekindDomain"
+open scoped IntermediateField.algebraAdjoinAdjoin
+
+section Crux
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] [CharZero K]
+variable (x : F) [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+variable (A : ValuationSubring F) (hAK : ∀ a : K, algebraMap K F a ∈ A) (hA : A ≠ ⊤)
+variable (hx : Transcendental K x) (hxA : x ∈ A)
+
+local notation3 "Kx" => Algebra.adjoin K ({x} : Set F)
+local notation3 "Kxfield" => IntermediateField.adjoin K ({x} : Set F)
+
+omit [CharZero K] [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] in
+include hx in
+private theorem isDedekindDomain_Kx : IsDedekindDomain (Kx) := by
+  have hinj : Function.Injective (Polynomial.aeval x : Polynomial K →ₐ[K] F) :=
+    transcendental_iff_injective.mp hx
+  have hrange : (Polynomial.aeval x : Polynomial K →ₐ[K] F).range = Kx :=
+    (Algebra.adjoin_singleton_eq_range_aeval K x).symm
+  let e : Polynomial K ≃ₐ[K] Kx :=
+    (AlgEquiv.ofInjective _ hinj).trans (Subalgebra.equivOfEq _ _ hrange)
+  have : IsPrincipalIdealRing (Kx) :=
+    IsPrincipalIdealRing.of_surjective (e : Polynomial K →+* Kx) e.surjective
+  infer_instance
+
+include hx in
+private theorem isDedekindDomain_integralClosure :
+    IsDedekindDomain (integralClosure (Kx) F) := by
+  have := isDedekindDomain_Kx x hx
+  have : Algebra.IsSeparable (Kxfield) F := Algebra.IsSeparable.of_integral _ _
+  exact integralClosure.isDedekindDomain (Kx) (Kxfield) F
+
+omit [CharZero K] in
+private theorem isFractionRing_integralClosure :
+    IsFractionRing (integralClosure (Kx) F) F :=
+  integralClosure.isFractionRing_of_finite_extension (A := Kx) (Kxfield) F
+
+omit [CharZero K] [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] in
+include hxA hAK in
+private theorem Kx_le_A : (Kx).toSubring ≤ A.toSubring := by
+  intro y hy
+  induction hy using Algebra.adjoin_induction with
+  | mem z hz => obtain rfl : z = x := hz; exact hxA
+  | algebraMap a => exact hAK a
+  | add a b _ _ ha hb => exact add_mem ha hb
+  | mul a b _ _ ha hb => exact mul_mem ha hb
+
+private scoped instance : IsFractionRing (A : ValuationSubring F).toSubring F := by
+  rw [← A.integer_valuation]; infer_instance
+
+private scoped instance : IsFractionRing (A : ValuationSubring F) F :=
+  inferInstanceAs (IsFractionRing A.toSubring F)
+
+omit [CharZero K] [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] in
+include hxA hAK in
+private theorem integralClosure_Kx_le_A :
+    (integralClosure (Kx) F).toSubring ≤ A.toSubring := by
+  intro y hy
+  have hyI : IsIntegral (Kx) y := hy
+  let : Algebra (Kx) A :=
+    (Subring.inclusion (Kx_le_A x A hAK hxA)).toAlgebra
+  have : IsScalarTower (Kx) A F :=
+    IsScalarTower.of_algebraMap_eq fun _ => rfl
+  have hyA : IsIntegral A y := hyI.tower_top
+  obtain ⟨z, hz⟩ := (isIntegrallyClosed_iff F).mp inferInstance hyA
+  exact hz ▸ z.2
+
+omit [CharZero K] [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] in
+include hxA hAK in
+private theorem inv_mem_of_notMem_maximalIdeal {b : integralClosure (Kx) F}
+    (hb : Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA) b
+        ∉ IsLocalRing.maximalIdeal A) :
+    ((b : F))⁻¹ ∈ A := by
+  have hbA : (b : F) ∈ A := integralClosure_Kx_le_A x A hAK hxA b.2
+  have hbU : IsUnit (⟨(b : F), hbA⟩ : A) := IsLocalRing.notMem_maximalIdeal.mp hb
+  obtain ⟨u, hu⟩ := hbU
+  have hcoe : (((u⁻¹ : Aˣ) : A) : F) * (b : F) = 1 := by
+    have h1 : ((u⁻¹ : Aˣ) : A) * ⟨(b : F), hbA⟩ = 1 := by rw [← hu]; exact u.inv_mul
+    have := congrArg (Subtype.val : A → F) h1; simpa using this
+  exact (eq_inv_of_mul_eq_one_left hcoe) ▸ ((u⁻¹ : Aˣ) : A).2
+
+omit [CharZero K] in
+include hxA hAK hA in
+private theorem idealOfA_ne_bot :
+    (IsLocalRing.maximalIdeal A).comap
+        (Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA)) ≠ ⊥ := by
+  have : IsFractionRing (integralClosure (Kx) F) F := isFractionRing_integralClosure x
+  intro hP
+  apply hA
+  rw [eq_top_iff]
+  intro y _
+  obtain ⟨a, b, hb, hab⟩ := IsFractionRing.div_surjective (A := integralClosure (Kx) F) y
+  have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb
+  have haA : (a : F) ∈ A := integralClosure_Kx_le_A x A hAK hxA a.2
+  have hbm : Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA) b
+      ∉ IsLocalRing.maximalIdeal A := by
+    intro hbm
+    have hmem : b ∈ (IsLocalRing.maximalIdeal A).comap
+        (Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA)) := hbm
+    rw [hP, Ideal.mem_bot] at hmem
+    exact hb0 hmem
+  rw [← hab, div_eq_mul_inv]
+  exact mul_mem haA (inv_mem_of_notMem_maximalIdeal x A hAK hxA hbm)
+
+omit [CharZero K] [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] in
+include hxA hAK in
+private theorem place_of_idealOfA_le (P : HeightOneSpectrum (integralClosure (Kx) F))
+    [IsDedekindDomain (integralClosure (Kx) F)] [IsFractionRing (integralClosure (Kx) F) F]
+    (hP : P.asIdeal = (IsLocalRing.maximalIdeal A).comap
+        (Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA))) :
+    (Place.ofHeightOneSpectrum (K := K) (F := F) P).toValuationSubring ≤ A := by
+  rw [Place.ofHeightOneSpectrum_toValuationSubring,
+    ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+  rintro y ⟨a, s, hs, rfl⟩
+  have haA : (a : F) ∈ A := integralClosure_Kx_le_A x A hAK hxA a.2
+  have hsm : Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA) s
+      ∉ IsLocalRing.maximalIdeal A := by
+    intro h
+    exact hs (hP ▸ h : s ∈ P.asIdeal)
+  exact mul_mem haA (inv_mem_of_notMem_maximalIdeal x A hAK hxA hsm)
+
+include hx hxA hAK hA in
+private theorem exists_place_of_mem :
+    ∃ v : Place K F, v.toValuationSubring = A := by
+  have := isDedekindDomain_integralClosure x hx
+  have : IsFractionRing (integralClosure (Kx) F) F := isFractionRing_integralClosure x
+  let P : HeightOneSpectrum (integralClosure (Kx) F) :=
+    ⟨(IsLocalRing.maximalIdeal A).comap
+        (Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA)),
+      inferInstance, idealOfA_ne_bot x A hAK hA hxA⟩
+  let V : Place K F := Place.ofHeightOneSpectrum P
+  have hVA : V.toValuationSubring ≤ A := place_of_idealOfA_le x A hAK hxA P rfl
+  exact ⟨V, ValuationSubring.eq_of_le_of_ne_top _ hVA hA⟩
+
+end Crux
+
+section Roots
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ord ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring \
+  toValuationSubring"
+end AlgebraicCurve.Place
+p2m_open_scoped "AlgebraicCurve AlgebraicCurve.Place" in
+private theorem AlgebraicCurve.Place.exists_of_valuationSubring {K F : Type*} [Field K] [Field F]
+    [Algebra K F] [CharZero K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (A : ValuationSubring F)
+    (hAK : ∀ a : K, algebraMap K F a ∈ A) (hA : A ≠ ⊤) :
+    ∃ v : AlgebraicCurve.Place K F, v.toValuationSubring = A := by
+  by_cases hx : Transcendental K x
+  · rcases A.mem_or_inv_mem x with hxA | hxiA
+    · exact exists_place_of_mem x A hAK hA hx hxA
+    · have hx0 : x ≠ 0 := by
+        rintro rfl; exact hx (isAlgebraic_zero (R := K))
+      have hxinv : Transcendental K x⁻¹ := by
+        rw [Transcendental, IsAlgebraic.inv_iff]; exact hx
+      have hadj : IntermediateField.adjoin K ({x⁻¹} : Set F) =
+          IntermediateField.adjoin K ({x} : Set F) := by
+        refine le_antisymm (IntermediateField.adjoin_le_iff.mpr ?_)
+          (IntermediateField.adjoin_le_iff.mpr ?_)
+        · intro z hz; rw [show z = x⁻¹ from hz]
+          exact inv_mem (IntermediateField.mem_adjoin_simple_self K x)
+        · intro z hz; rw [show z = x from hz]
+          have h : x⁻¹⁻¹ ∈ IntermediateField.adjoin K ({x⁻¹} : Set F) :=
+            inv_mem (IntermediateField.mem_adjoin_simple_self K x⁻¹)
+          rwa [inv_inv] at h
+      have : FiniteDimensional (IntermediateField.adjoin K ({x⁻¹} : Set F)) F := by
+        rw [hadj]; infer_instance
+      exact exists_place_of_mem x⁻¹ A hAK hA hxinv hxiA
+  · rw [Transcendental, not_not] at hx
+    refine absurd ?_ hA
+    rw [eq_top_iff]
+    intro y _
+    have : FiniteDimensional K (IntermediateField.adjoin K ({x} : Set F)) :=
+      IntermediateField.adjoin.finiteDimensional hx.isIntegral
+    have : FiniteDimensional K F :=
+      FiniteDimensional.trans K (IntermediateField.adjoin K ({x} : Set F)) F
+    have : Algebra.IsAlgebraic K F := Algebra.IsAlgebraic.of_finite K F
+    have hyI : IsIntegral K y := (Algebra.IsAlgebraic.isAlgebraic y).isIntegral
+    let : Algebra K A :=
+      ((algebraMap K F).codRestrict A.toSubring hAK).toAlgebra
+    have : IsScalarTower K A F := IsScalarTower.of_algebraMap_eq fun _ => rfl
+    have hyA : IsIntegral A y := hyI.tower_top
+    obtain ⟨z, hz⟩ := (isIntegrallyClosed_iff F).mp inferInstance hyA
+    exact hz ▸ z.2
+
+p2m_open_scoped "AlgebraicCurve AlgebraicCurve.Place" in
+private theorem AlgebraicCurve.Place.exists_toValuationSubring_eq_comap_ringHom {K F F' : Type*}
+    [Field K] [Field F] [Field F'] [Algebra K F] [CharZero K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (φ : F →+* F')
+    (w : ValuationSubring F') (hwK : ∀ a : K, φ (algebraMap K F a) ∈ w) (hwx : ∃ y : F, φ y ∉ w) :
+    ∃ v : AlgebraicCurve.Place K F, v.toValuationSubring = w.comap φ := by
+  refine AlgebraicCurve.Place.exists_of_valuationSubring x (w.comap φ)
+    (fun a => hwK a) ?_
+  intro h
+  obtain ⟨y, hy⟩ := hwx
+  exact hy (h ▸ ValuationSubring.mem_top y : y ∈ w.comap φ)
+
+end Roots
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [CharZero K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (A : ValuationSubring F)
+    (hAK : ∀ a : K, algebraMap K F a ∈ A) (hA : A ≠ ⊤) :
+    ∃ v : AlgebraicCurve.Place K F, v.toValuationSubring = A :=
+  AlgebraicCurve.Place.exists_of_valuationSubring x A hAK hA
+
+end S_AlgebraicCurve_Place_exists_of_valuationSubring
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_exists_of_valuationSubring (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.exists_of_valuationSubring {K F : Type*} [Field K] [Field F]
+    [Algebra K F] [CharZero K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (A : ValuationSubring F)
+    (hAK : ∀ a : K, algebraMap K F a ∈ A) (hA : A ≠ ⊤) :
+    ∃ v : AlgebraicCurve.Place K F, v.toValuationSubring = A :=
+  solution x A hAK hA
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_of_valuationSubring_of_isSeparable.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_of_valuationSubring_of_isSeparable.lean
new file mode 100644
index 0000000000..f17d9fb68f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_of_valuationSubring_of_isSeparable.lean
@@ -0,0 +1,282 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.exists_of_valuationSubring_of_isSeparable
+(f1b88959-3e78-5f9c-8580-6bf9743c30cb) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4056ec96-0132-5403-8448-f717048c5ec5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import Mathlib.RingTheory.Valuation.LocalSubring
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Proper valuation subrings over K are discrete
+
+Theorem statement: `AlgebraicCurve.Place.exists_of_valuationSubring_of_isSeparable`
+(`f1b88959-3e78-5f9c-8580-6bf9743c30cb`), by Claude, 2026-09-05.
+
+Proof: submission `4056ec96-0132-5403-8448-f717048c5ec5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $x \in F$ be such that $F$ is
+finite-dimensional over the intermediate field $K(x) =$ `IntermediateField.adjoin K {x}` and
+separable over it. Let $A$ be a valuation subring of $F$ such that $\mathrm{algebraMap}_{K \to F}(a)
+\in A$ for every $a \in K$, and such that $A \neq \top$, i.e. $A$ is not all of $F$. The assertion
+is that there exists a place $v$ of $F$ over $K$ in the sense of the structure
+[`AlgebraicCurve.Place`](def/AlgebraicCurve_DivisorClassGroup.html#L22), i.e. a valuation subring of
+$F$ containing the image of $K$, different from $F$, and whose ring is a principal ideal ring, whose
+underlying valuation subring `v.toValuationSubring` is exactly $A$. Since the first two defining
+conditions of a place are hypotheses of the statement and the third follows from them, the
+mathematical content is that $A$ itself is a principal ideal ring, i.e. that the valuation attached
+to $A$ is discrete.
+
+This is the classical statement that every proper valuation ring of a function field in one variable
+which contains the constant field is a discrete valuation ring, hence a place of the function field,
+here in a form requiring only that $F$ be finite and separable over some $K(x)$ rather than a
+hypothesis on the characteristic. It supplies places from valuation subrings for the
+divisor-theoretic machinery, and is used in establishing integrality of elements lying in all the
+valuation subrings in question and in producing places at which a chosen element has positive order.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_exists_of_valuationSubring_of_isSeparable.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_exists_of_valuationSubring_of_isSeparable
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_Place_exists_of_valuationSubring_of_isSeparable.AlgebraicCurve \
+  IsDedekindDomain"
+open scoped IntermediateField.algebraAdjoinAdjoin
+
+section Crux
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable (x : F) [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+variable (A : ValuationSubring F) (hAK : ∀ a : K, algebraMap K F a ∈ A) (hA : A ≠ ⊤)
+variable (hx : Transcendental K x) (hxA : x ∈ A)
+
+local notation3 "Kx" => Algebra.adjoin K ({x} : Set F)
+local notation3 "Kxfield" => IntermediateField.adjoin K ({x} : Set F)
+
+omit [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] in
+include hx in
+private theorem isDedekindDomain_Kx : IsDedekindDomain (Kx) := by
+  have hinj : Function.Injective (Polynomial.aeval x : Polynomial K →ₐ[K] F) :=
+    transcendental_iff_injective.mp hx
+  have hrange : (Polynomial.aeval x : Polynomial K →ₐ[K] F).range = Kx :=
+    (Algebra.adjoin_singleton_eq_range_aeval K x).symm
+  let e : Polynomial K ≃ₐ[K] Kx :=
+    (AlgEquiv.ofInjective _ hinj).trans (Subalgebra.equivOfEq _ _ hrange)
+  have : IsPrincipalIdealRing (Kx) :=
+    IsPrincipalIdealRing.of_surjective (e : Polynomial K →+* Kx) e.surjective
+  infer_instance
+
+include hx in
+private theorem isDedekindDomain_integralClosure [Algebra.IsSeparable (Kxfield) F] :
+    IsDedekindDomain (integralClosure (Kx) F) := by
+  have := isDedekindDomain_Kx x hx
+  exact integralClosure.isDedekindDomain (Kx) (Kxfield) F
+
+private theorem isFractionRing_integralClosure :
+    IsFractionRing (integralClosure (Kx) F) F :=
+  integralClosure.isFractionRing_of_finite_extension (A := Kx) (Kxfield) F
+
+omit [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] in
+include hxA hAK in
+private theorem Kx_le_A : (Kx).toSubring ≤ A.toSubring := by
+  intro y hy
+  induction hy using Algebra.adjoin_induction with
+  | mem z hz => obtain rfl : z = x := hz; exact hxA
+  | algebraMap a => exact hAK a
+  | add a b _ _ ha hb => exact add_mem ha hb
+  | mul a b _ _ ha hb => exact mul_mem ha hb
+
+private scoped instance : IsFractionRing (A : ValuationSubring F).toSubring F := by
+  rw [← A.integer_valuation]; infer_instance
+
+private scoped instance : IsFractionRing (A : ValuationSubring F) F :=
+  inferInstanceAs (IsFractionRing A.toSubring F)
+
+omit [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] in
+include hxA hAK in
+private theorem integralClosure_Kx_le_A :
+    (integralClosure (Kx) F).toSubring ≤ A.toSubring := by
+  intro y hy
+  have hyI : IsIntegral (Kx) y := hy
+  let : Algebra (Kx) A :=
+    (Subring.inclusion (Kx_le_A x A hAK hxA)).toAlgebra
+  have : IsScalarTower (Kx) A F :=
+    IsScalarTower.of_algebraMap_eq fun _ => rfl
+  have hyA : IsIntegral A y := hyI.tower_top
+  obtain ⟨z, hz⟩ := (isIntegrallyClosed_iff F).mp inferInstance hyA
+  exact hz ▸ z.2
+
+omit [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] in
+include hxA hAK in
+private theorem inv_mem_of_notMem_maximalIdeal {b : integralClosure (Kx) F}
+    (hb : Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA) b
+        ∉ IsLocalRing.maximalIdeal A) :
+    ((b : F))⁻¹ ∈ A := by
+  have hbA : (b : F) ∈ A := integralClosure_Kx_le_A x A hAK hxA b.2
+  have hbU : IsUnit (⟨(b : F), hbA⟩ : A) := IsLocalRing.notMem_maximalIdeal.mp hb
+  obtain ⟨u, hu⟩ := hbU
+  have hcoe : (((u⁻¹ : Aˣ) : A) : F) * (b : F) = 1 := by
+    have h1 : ((u⁻¹ : Aˣ) : A) * ⟨(b : F), hbA⟩ = 1 := by rw [← hu]; exact u.inv_mul
+    have := congrArg (Subtype.val : A → F) h1; simpa using this
+  exact (eq_inv_of_mul_eq_one_left hcoe) ▸ ((u⁻¹ : Aˣ) : A).2
+
+include hxA hAK hA in
+private theorem idealOfA_ne_bot :
+    (IsLocalRing.maximalIdeal A).comap
+        (Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA)) ≠ ⊥ := by
+  have : IsFractionRing (integralClosure (Kx) F) F := isFractionRing_integralClosure x
+  intro hP
+  apply hA
+  rw [eq_top_iff]
+  intro y _
+  obtain ⟨a, b, hb, hab⟩ := IsFractionRing.div_surjective (A := integralClosure (Kx) F) y
+  have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb
+  have haA : (a : F) ∈ A := integralClosure_Kx_le_A x A hAK hxA a.2
+  have hbm : Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA) b
+      ∉ IsLocalRing.maximalIdeal A := by
+    intro hbm
+    have hmem : b ∈ (IsLocalRing.maximalIdeal A).comap
+        (Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA)) := hbm
+    rw [hP, Ideal.mem_bot] at hmem
+    exact hb0 hmem
+  rw [← hab, div_eq_mul_inv]
+  exact mul_mem haA (inv_mem_of_notMem_maximalIdeal x A hAK hxA hbm)
+
+omit [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] in
+include hxA hAK in
+private theorem place_of_idealOfA_le (P : HeightOneSpectrum (integralClosure (Kx) F))
+    [IsDedekindDomain (integralClosure (Kx) F)] [IsFractionRing (integralClosure (Kx) F) F]
+    (hP : P.asIdeal = (IsLocalRing.maximalIdeal A).comap
+        (Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA))) :
+    (Place.ofHeightOneSpectrum (K := K) (F := F) P).toValuationSubring ≤ A := by
+  rw [Place.ofHeightOneSpectrum_toValuationSubring,
+    ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+  rintro y ⟨a, s, hs, rfl⟩
+  have haA : (a : F) ∈ A := integralClosure_Kx_le_A x A hAK hxA a.2
+  have hsm : Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA) s
+      ∉ IsLocalRing.maximalIdeal A := by
+    intro h
+    exact hs (hP ▸ h : s ∈ P.asIdeal)
+  exact mul_mem haA (inv_mem_of_notMem_maximalIdeal x A hAK hxA hsm)
+
+include hx hxA hAK hA in
+private theorem exists_place_of_mem [Algebra.IsSeparable (Kxfield) F] :
+    ∃ v : Place K F, v.toValuationSubring = A := by
+  have := isDedekindDomain_integralClosure x hx
+  have : IsFractionRing (integralClosure (Kx) F) F := isFractionRing_integralClosure x
+  let P : HeightOneSpectrum (integralClosure (Kx) F) :=
+    ⟨(IsLocalRing.maximalIdeal A).comap
+        (Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA)),
+      inferInstance, idealOfA_ne_bot x A hAK hA hxA⟩
+  let V : Place K F := Place.ofHeightOneSpectrum P
+  have hVA : V.toValuationSubring ≤ A := place_of_idealOfA_le x A hAK hxA P rfl
+  exact ⟨V, ValuationSubring.eq_of_le_of_ne_top _ hVA hA⟩
+
+end Crux
+
+section Roots
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring \
+  toValuationSubring"
+end AlgebraicCurve.Place
+p2m_open_scoped "AlgebraicCurve AlgebraicCurve.Place" in
+private theorem AlgebraicCurve.Place.exists_of_valuationSubring' {K F : Type*} [Field K] [Field F]
+    [Algebra K F] (x : F) [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F] (A : ValuationSubring F)
+    (hAK : ∀ a : K, algebraMap K F a ∈ A) (hA : A ≠ ⊤) :
+    ∃ v : AlgebraicCurve.Place K F, v.toValuationSubring = A := by
+  by_cases hx : Transcendental K x
+  · rcases A.mem_or_inv_mem x with hxA | hxiA
+    · exact exists_place_of_mem x A hAK hA hx hxA
+    · have hx0 : x ≠ 0 := by
+        rintro rfl; exact hx (isAlgebraic_zero (R := K))
+      have hxinv : Transcendental K x⁻¹ := by
+        rw [Transcendental, IsAlgebraic.inv_iff]; exact hx
+      have hadj : IntermediateField.adjoin K ({x⁻¹} : Set F) =
+          IntermediateField.adjoin K ({x} : Set F) := by
+        refine le_antisymm (IntermediateField.adjoin_le_iff.mpr ?_)
+          (IntermediateField.adjoin_le_iff.mpr ?_)
+        · intro z hz; rw [show z = x⁻¹ from hz]
+          exact inv_mem (IntermediateField.mem_adjoin_simple_self K x)
+        · intro z hz; rw [show z = x from hz]
+          have h : x⁻¹⁻¹ ∈ IntermediateField.adjoin K ({x⁻¹} : Set F) :=
+            inv_mem (IntermediateField.mem_adjoin_simple_self K x⁻¹)
+          rwa [inv_inv] at h
+      have : FiniteDimensional (IntermediateField.adjoin K ({x⁻¹} : Set F)) F := by
+        rw [hadj]; infer_instance
+      have : Algebra.IsSeparable (IntermediateField.adjoin K ({x⁻¹} : Set F)) F := by
+        rw [hadj]; infer_instance
+      exact exists_place_of_mem x⁻¹ A hAK hA hxinv hxiA
+  · rw [Transcendental, not_not] at hx
+    refine absurd ?_ hA
+    rw [eq_top_iff]
+    intro y _
+    have : FiniteDimensional K (IntermediateField.adjoin K ({x} : Set F)) :=
+      IntermediateField.adjoin.finiteDimensional hx.isIntegral
+    have : FiniteDimensional K F :=
+      FiniteDimensional.trans K (IntermediateField.adjoin K ({x} : Set F)) F
+    have : Algebra.IsAlgebraic K F := Algebra.IsAlgebraic.of_finite K F
+    have hyI : IsIntegral K y := (Algebra.IsAlgebraic.isAlgebraic y).isIntegral
+    let : Algebra K A :=
+      ((algebraMap K F).codRestrict A.toSubring hAK).toAlgebra
+    have : IsScalarTower K A F := IsScalarTower.of_algebraMap_eq fun _ => rfl
+    have hyA : IsIntegral A y := hyI.tower_top
+    obtain ⟨z, hz⟩ := (isIntegrallyClosed_iff F).mp inferInstance hyA
+    exact hz ▸ z.2
+
+end Roots
+
+theorem solution
+    {K F : Type*} [Field K] [Field F] [Algebra K F] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F]
+    (A : ValuationSubring F) (hAK : ∀ a : K, algebraMap K F a ∈ A) (hA : A ≠ ⊤) :
+    ∃ v : AlgebraicCurve.Place K F, v.toValuationSubring = A :=
+  AlgebraicCurve.Place.exists_of_valuationSubring' x A hAK hA
+
+end S_AlgebraicCurve_Place_exists_of_valuationSubring_of_isSeparable
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_exists_of_valuationSubring_of_isSeparable (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.exists_of_valuationSubring_of_isSeparable
+    {K F : Type*} [Field K] [Field F] [Algebra K F] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F]
+    (A : ValuationSubring F) (hAK : ∀ a : K, algebraMap K F a ∈ A) (hA : A ≠ ⊤) :
+    ∃ v : AlgebraicCurve.Place K F, v.toValuationSubring = A :=
+  solution x A hAK hA
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_ord_algebraMap_eq_mul_ord.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_ord_algebraMap_eq_mul_ord.lean
new file mode 100644
index 0000000000..ab815be4da
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_ord_algebraMap_eq_mul_ord.lean
@@ -0,0 +1,212 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.exists_ord_algebraMap_eq_mul_ord
+(4a6afafb-d24c-5767-be5f-dfacc8bd73c8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f2955a9a-20c1-503c-be86-1a1a4684b62c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Ramification index: ord_w = ecdotordᵥ on F
+
+Theorem statement: `AlgebraicCurve.Place.exists_ord_algebraMap_eq_mul_ord`
+(`4a6afafb-d24c-5767-be5f-dfacc8bd73c8`), by Claude, 2026-09-05.
+
+Proof: submission `f2955a9a-20c1-503c-be86-1a1a4684b62c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $F'$ be fields with $F$ and $F'$ algebras over $K$ and $F'$ an algebra over $F$ (no
+compatibility between the three structure maps, and no algebraicity or finiteness of $F'/F$, is
+assumed). Here a place of a field $L$ over $K$ consists of a valuation subring $\mathcal O \subseteq
+L$ which contains the image of $K$, is not all of $L$, and is a principal ideal ring; its order
+function $\operatorname{ord}$ is the negative of the logarithm of the associated adic valuation at
+the height-one point of $\mathcal O$, i.e. the normalised discrete valuation, with the convention
+$\operatorname{ord}(0)=0$. Given such a place $w$ of $F'$ over $K$, a place $v$ of $F$ over $K$, and
+the hypothesis that the valuation subring of $v$ is exactly the preimage of the valuation subring of
+$w$ under the structure map $F \to F'$ (that is, $\mathcal O_v = \mathcal O_w \cap F$, so $w$ lies
+over $v$), the assertion is that there exists a natural number $e$ with $e > 0$ such that for every
+$f \in F$ one has $\operatorname{ord}_w(\operatorname{alg}(f)) = e \cdot \operatorname{ord}_v(f)$,
+where $\operatorname{alg}$ denotes the map $F \to F'$.
+
+This is the existence of the ramification index $e(w\mid v)$ of a place $w$ lying over a place $v$,
+in the form of proportionality of the two normalised order functions on $F$. It underpins the
+comparison of orders in towers of function fields, and is used for the criteria that a function with
+nowhere-negative order lies in the base field and for the order computations for the $j$-coordinate
+on the modular function field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_exists_ord_algebraMap_eq_mul_ord.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_exists_ord_algebraMap_eq_mul_ord
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ord ord_one ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow toValuationSubring"
+p2m_open "AlgebraicCurve.Place"
+
+section SinglePlace
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.ord_nonneg_of_mem' {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    0 ≤ v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨n, u, hu⟩ :=
+    IsDiscreteValuationRing.eq_unit_mul_pow_irreducible
+      (x := (⟨f, hf⟩ : v.toValuationSubring)) (by simpa [Subtype.ext_iff] using hf0) hπ
+  have hcoe : f = ((u : v.toValuationSubring) : F) * ((π : F) ^ (n : ℤ)) := by
+    have h := congrArg (Subtype.val) hu
+    push_cast at h
+    rw [zpow_natCast]
+    exact h
+  rw [hcoe, v.ord_unit_smul_zpow u hπ (n : ℤ)]
+  exact Int.natCast_nonneg n
+
+p2m_export "AlgebraicCurve.Place" "ord_nonneg_of_mem'"
+private theorem _root_.AlgebraicCurve.Place.mem_of_ord_nonneg' {f : F} (hf : f ≠ 0)
+    (h : 0 ≤ v.ord f) :
+    f ∈ v.toValuationSubring := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ
+  rw [hu, show v.ord f = (((v.ord f).toNat : ℕ) : ℤ) from (Int.toNat_of_nonneg h).symm,
+    zpow_natCast]
+  exact mul_mem (u : v.toValuationSubring).2 (pow_mem (π : v.toValuationSubring).2 _)
+
+p2m_export "AlgebraicCurve.Place" "mem_of_ord_nonneg'"
+private theorem mem_iff_ord_nonneg' {f : F} (hf : f ≠ 0) :
+    f ∈ v.toValuationSubring ↔ 0 ≤ v.ord f :=
+  ⟨v.ord_nonneg_of_mem', v.mem_of_ord_nonneg' hf⟩
+
+private theorem exists_ord_pos_mem' : ∃ f : F, f ≠ 0 ∧ 0 < v.ord f ∧ f ∈ v.toValuationSubring := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  refine ⟨(π : F), ?_, ?_, π.2⟩
+  · simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  · rw [v.ord_coe_irreducible hπ]
+    exact one_pos
+
+end SinglePlace
+
+section Fiber
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F'] [Algebra F F']
+
+theorem rowMain (w : Place K F') (v : Place K F)
+    (hv : v.toValuationSubring = w.toValuationSubring.comap (algebraMap F F')) :
+    ∃ e : ℕ, 0 < e ∧ ∀ f : F, w.ord (algebraMap F F' f) = e * v.ord f := by
+  have hmem : ∀ {f : F}, f ∈ v.toValuationSubring → algebraMap F F' f ∈ w.toValuationSubring :=
+    fun {f} h => by
+      rw [hv] at h
+      exact (ValuationSubring.mem_comap).mp h
+  have hmem' : ∀ {f : F}, algebraMap F F' f ∈ w.toValuationSubring → f ∈ v.toValuationSubring :=
+    fun {f} h => by
+      rw [hv]
+      exact (ValuationSubring.mem_comap).mpr h
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπF : (π : F) ≠ 0 := by
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have hπF' : algebraMap F F' (π : F) ≠ 0 := by simpa using hπF
+  have he0 : 0 ≤ w.ord (algebraMap F F' (π : F)) := w.ord_nonneg_of_mem' (hmem π.2)
+  have hepos : 0 < w.ord (algebraMap F F' (π : F)) := by
+    rcases eq_or_lt_of_le he0 with h0 | h
+    · exfalso
+      have hinv : (algebraMap F F' (π : F))⁻¹ ∈ w.toValuationSubring :=
+        w.mem_of_ord_nonneg' (inv_ne_zero hπF') (by rw [w.ord_inv, ← h0, neg_zero])
+      have hinv' : (π : F)⁻¹ ∈ v.toValuationSubring := hmem' (by rwa [map_inv₀])
+      have h1 := v.ord_nonneg_of_mem' hinv'
+      rw [v.ord_inv, v.ord_coe_irreducible hπ] at h1
+      omega
+    · exact h
+  have hunit : ∀ u : v.toValuationSubringˣ,
+      w.ord (algebraMap F F' ((u : v.toValuationSubring) : F)) = 0 := by
+    intro u
+    have h1 : 0 ≤ w.ord (algebraMap F F' ((u : v.toValuationSubring) : F)) :=
+      w.ord_nonneg_of_mem' (hmem (u : v.toValuationSubring).2)
+    have h2 : 0 ≤ w.ord (algebraMap F F' ((↑(u⁻¹) : v.toValuationSubring) : F)) :=
+      w.ord_nonneg_of_mem' (hmem (↑(u⁻¹) : v.toValuationSubring).2)
+    have hu0 : ((u : v.toValuationSubring) : F) ≠ 0 := by
+      simp [ne_eq, ZeroMemClass.coe_eq_zero]
+    have hu0' : ((↑(u⁻¹) : v.toValuationSubring) : F) ≠ 0 := by
+      simp [ne_eq, ZeroMemClass.coe_eq_zero]
+    have hprod : ((u : v.toValuationSubring) : F) * ((↑(u⁻¹) : v.toValuationSubring) : F) = 1 := by
+      have := u.mul_inv
+      rw [Subtype.ext_iff] at this
+      push_cast at this
+      exact this
+    have hsum : w.ord (algebraMap F F' ((u : v.toValuationSubring) : F))
+        + w.ord (algebraMap F F' ((↑(u⁻¹) : v.toValuationSubring) : F)) = 0 := by
+      rw [← w.ord_mul ((map_ne_zero (algebraMap F F')).mpr hu0)
+        ((map_ne_zero (algebraMap F F')).mpr hu0'), ← map_mul, hprod, map_one, w.ord_one]
+    omega
+  refine ⟨(w.ord (algebraMap F F' (π : F))).toNat, by omega, fun f => ?_⟩
+  rw [Int.toNat_of_nonneg he0]
+  rcases eq_or_ne f 0 with rfl | hf
+  · simp
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ
+  have hu0 : ((u : v.toValuationSubring) : F) ≠ 0 := by
+    simp [ne_eq, ZeroMemClass.coe_eq_zero]
+  conv_lhs => rw [hu]
+  rw [map_mul, map_zpow₀, w.ord_mul ((map_ne_zero (algebraMap F F')).mpr hu0) (zpow_ne_zero _ hπF'),
+    hunit u, zero_add, w.ord_zpow, mul_comm]
+
+end Fiber
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_Place_exists_ord_algebraMap_eq_mul_ord.AlgebraicCurve in
+theorem solution {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+    [Algebra F F'] (w : Place K F') (v : Place K F)
+    (hv : v.toValuationSubring = w.toValuationSubring.comap (algebraMap F F')) :
+    ∃ e : ℕ, 0 < e ∧ ∀ f : F, w.ord (algebraMap F F' f) = e * v.ord f :=
+  AlgebraicCurve.Place.rowMain w v hv
+
+end S_AlgebraicCurve_Place_exists_ord_algebraMap_eq_mul_ord
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_exists_ord_algebraMap_eq_mul_ord (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.exists_ord_algebraMap_eq_mul_ord {K F F' : Type*} [Field K] [Field F]
+    [Field F'] [Algebra K F] [Algebra K F'] [Algebra F F'] (w : Place K F') (v : Place K F)
+    (hv : v.toValuationSubring = w.toValuationSubring.comap (algebraMap F F')) :
+    ∃ e : ℕ, 0 < e ∧ ∀ f : F, w.ord (algebraMap F F' f) = e * v.ord f :=
+  solution w v hv
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_ord_eq_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_ord_eq_one.lean
new file mode 100644
index 0000000000..e42bea7017
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_ord_eq_one.lean
@@ -0,0 +1,77 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.exists_ord_eq_one
+(c53dc47f-3d74-56f4-b027-ea46543b40cc) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 597585dc-2228-52d1-982a-72bea1af0687
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of a uniformiser at a place
+
+Theorem statement: `AlgebraicCurve.Place.exists_ord_eq_one`
+(`c53dc47f-3d74-56f4-b027-ea46543b40cc`), by Claude, 2026-09-05.
+
+Proof: submission `597585dc-2228-52d1-982a-72bea1af0687`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+sense of the project's structure
+[`AlgebraicCurve.Place`](def/AlgebraicCurve_DivisorClassGroup.html#L22): a valuation subring
+$\mathcal{O}_v \subseteq F$ which contains $\operatorname{algebraMap} K F (a)$ for every $a \in K$,
+which is not all of $F$, and which is a principal ideal ring. For $f \in F$ the integer
+$v.\mathrm{ord}\, f$ is defined as $-\log$ of the value $v.\mathrm{adicValuation}\, f \in
+\mathbb{Z}^{m0}$, where $v.\mathrm{adicValuation}$ is the valuation on $F$ attached to the
+height-one prime of $\mathcal{O}_v$ associated with $v$; thus $\mathrm{ord}$ is the normalised
+additive valuation of $v$, with $\mathrm{ord}\,0$ taking the value coming from $\log 0$. The
+assertion is that there exists $t \in F$ with $v.\mathrm{ord}\, t = 1$, i.e. that the normalised
+order function at $v$ attains the value $1$, so that a uniformiser at $v$ exists in $F$.
+
+This is the existence of a prime element (uniformiser) at a place, the elementary starting point for
+local expansions at $v$; the value group of $\mathrm{ord}$ is thereby all of $\mathbb{Z}$. It is
+used throughout the development of divisors and differentials on a curve, for instance in the lemmas
+relating $\mathrm{ord}$ to differential coefficients and to non-vanishing of the derivation $D$ at
+$v$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_exists_ord_eq_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_exists_ord_eq_one
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : AlgebraicCurve.Place K F) :
+    ∃ t : F, v.ord t = 1 :=
+  let ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  ⟨π, v.ord_coe_irreducible hπ⟩
+
+end S_AlgebraicCurve_Place_exists_ord_eq_one
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_exists_ord_eq_one (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.exists_ord_eq_one {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : AlgebraicCurve.Place K F) :
+    ∃ t : F, v.ord t = 1 :=
+  solution v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_algHom_laurentSeries.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_algHom_laurentSeries.lean
new file mode 100644
index 0000000000..3986d90451
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_algHom_laurentSeries.lean
@@ -0,0 +1,182 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.exists_ord_mul_eq_order_of_algHom_laurentSeries
+(a09cc34f-f4eb-5951-b5ff-76663dc0215e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5ac54bb6-05b5-58e2-8b90-e04fa9444456
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_AtkinLehner
+
+import Mathlib.RingTheory.LaurentSeries
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_hasRamBound
+
+/-!
+# Places from K-algebra embeddings into Laurent series
+
+Theorem statement: `AlgebraicCurve.Place.exists_ord_mul_eq_order_of_algHom_laurentSeries`
+(`a09cc34f-f4eb-5951-b5ff-76663dc0215e`), by Claude, 2026-09-05.
+
+Proof: submission `5ac54bb6-05b5-58e2-8b90-e04fa9444456`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, $F$ a field equipped with a $K$-algebra structure, and $\iota : F \to K((T))$ a
+$K$-algebra homomorphism into the Laurent series field over $K$ (Hahn series with value group
+$\mathbb{Z}$). Assume the non-triviality hypothesis that some $x \in F$ has $\mathrm{order}(\iota x)
+\neq 0$, i.e. the $T$-adic order pulled back along $\iota$ is not identically zero. The conclusion
+asserts the existence of a place $w$ of $F$ over $K$ — that is, a valuation subring of $F$ which
+contains $\mathrm{algebraMap}\,K\,F(a)$ for every $a \in K$, is not all of $F$, and is a principal
+ideal ring — together with a natural number $\gamma$ with $0 < \gamma$, such that for every $x \in
+F$ one has $\mathrm{ord}_w(x)\cdot\gamma = \mathrm{order}(\iota x)$ in $\mathbb{Z}$, where
+$\mathrm{ord}_w(x)$ is minus the logarithm of the value of $x$ under the height-one-spectrum adic
+valuation attached to $w$. Thus the $T$-adic order of $\iota$ is a positive integral multiple of a
+normalised discrete valuation of $F$ trivial on $K$; $\gamma$ plays the role of the ramification
+index of the embedding.
+
+This is the standard device by which an analytic (Laurent-series) expansion of a function field
+determines a place of that field over the base field, with the expansion order equal to the
+valuation up to a positive integer factor. It is used to produce places of function fields of
+modular curves and of their base changes to Laurent series, and is cited in the analysis of orders
+of $j$ and of cusp counting.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_algHom_laurentSeries.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+noncomputable section
+
+open AlgebraicCurve
+
+namespace CD
+
+section Transport
+
+variable {K : Type*} [Field K]
+
+theorem hasRamBound_puiseuxRamEmb {e : ℕ} (he : 0 < e) (x : LaurentSeries K) :
+    HahnSeries.HasRamBound e (HahnSeries.puiseuxRamEmb he x) := by
+  intro q hq
+  have hq' : q ∈ ⇑(HahnSeries.ramScale e) '' x.support := by
+    simpa [HahnSeries.puiseuxRamEmb, HahnSeries.embDomainRingHom] using
+      HahnSeries.support_embDomain_subset hq
+  obtain ⟨k, -, rfl⟩ := hq'
+  exact ⟨k, rfl⟩
+
+theorem order_puiseuxRamEmb {e : ℕ} (he : 0 < e) (x : LaurentSeries K) :
+    (HahnSeries.puiseuxRamEmb he x).order = HahnSeries.ramScale e x.order := by
+  rcases eq_or_ne x 0 with rfl | hx
+  · simp
+  · have hx' : HahnSeries.puiseuxRamEmb (K := K) he x ≠ 0 := by
+      intro h0
+      exact hx ((HahnSeries.puiseuxRamEmb (K := K) he).injective (by rw [h0, map_zero]))
+    have h2 : (HahnSeries.puiseuxRamEmb (K := K) he x).orderTop
+        = WithTop.map (⇑(HahnSeries.ramScale e)) x.orderTop :=
+      HahnSeries.orderTop_embDomain
+    have h1 := HahnSeries.order_eq_orderTop_of_ne_zero hx'
+    rw [h2, ← HahnSeries.order_eq_orderTop_of_ne_zero hx, WithTop.map_coe] at h1
+    exact_mod_cast h1
+
+theorem laurentAlgebraMap_eq_C (c : K) :
+    algebraMap K (LaurentSeries K) c = HahnSeries.C c := by
+  rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_apply]
+  simp [HahnSeries.ofPowerSeries_C]
+
+theorem hahnQAlgebraMap_eq_C (c : K) :
+    algebraMap K (HahnSeries ℚ K) c = HahnSeries.C c := by
+  rw [HahnSeries.algebraMap_apply']
+  simp [HahnSeries.ofPowerSeries_C]
+
+end Transport
+
+section Lift
+
+variable {K : Type*} [Field K] {F : Type*} [Field F] [Algebra K F]
+
+def liftToHahn (ι : F →ₐ[K] LaurentSeries K) : F →ₐ[K] HahnSeries ℚ K where
+  toRingHom := (HahnSeries.puiseuxRamEmb one_pos).comp ι.toRingHom
+  commutes' := by
+    intro c
+    change HahnSeries.puiseuxRamEmb one_pos (ι (algebraMap K F c))
+        = algebraMap K (HahnSeries ℚ K) c
+    rw [ι.commutes c, laurentAlgebraMap_eq_C, hahnQAlgebraMap_eq_C]
+    exact HahnSeries.embDomainRingHom_C
+
+@[scoped simp] theorem liftToHahn_apply (ι : F →ₐ[K] LaurentSeries K) (x : F) :
+    liftToHahn ι x = HahnSeries.puiseuxRamEmb one_pos (ι x) := rfl
+
+theorem order_liftToHahn (ι : F →ₐ[K] LaurentSeries K) (x : F) :
+    (liftToHahn ι x).order = ((ι x).order : ℚ) := by
+  rw [liftToHahn_apply, order_puiseuxRamEmb one_pos, HahnSeries.ramScale_apply]
+  simp
+
+end Lift
+
+section Generic
+
+variable (K : Type*) [Field K]
+
+private theorem _root_.AlgebraicCurve.Place.exists_ord_mul_eq_order_of_algHom_laurentSeries'
+    {F : Type*} [Field F] [Algebra K F] (ι : F →ₐ[K] LaurentSeries K)
+    (h : ∃ x : F, (ι x).order ≠ 0) :
+    ∃ (w : Place K F) (γ : ℕ), 0 < γ ∧ ∀ x : F, w.ord x * (γ : ℤ) = (ι x).order := by
+  obtain ⟨x₀, hx₀⟩ := h
+  have hnt : ∃ x : F, ((liftToHahn ι) x).order ≠ 0 :=
+    ⟨x₀, by rw [order_liftToHahn]; exact_mod_cast hx₀⟩
+  have hRB : ∀ x : F, HahnSeries.HasRamBound 1 ((liftToHahn ι) x) :=
+    fun x => hasRamBound_puiseuxRamEmb one_pos (ι x)
+  obtain ⟨w, g, hg, hgw⟩ :=
+    Place.exists_ord_mul_eq_order_of_hasRamBound (liftToHahn ι) one_pos hRB hnt
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  have hordπ : w.ord (π : F) = 1 := w.ord_coe_irreducible hπ
+  have hgval : g = ((ι (π : F)).order : ℚ) := by
+    have h1 := hgw (π : F)
+    rw [hordπ, order_liftToHahn] at h1
+    simpa using h1
+  have hpos : 0 < (ι (π : F)).order := by
+    rw [hgval] at hg
+    exact_mod_cast hg
+  refine ⟨w, ((ι (π : F)).order).toNat, by omega, fun x => ?_⟩
+  have h1 := hgw x
+  rw [hgval, order_liftToHahn] at h1
+  have h2 : w.ord x * (ι (π : F)).order = (ι x).order := by exact_mod_cast h1
+  rw [Int.toNat_of_nonneg hpos.le]
+  exact h2
+
+end Generic
+
+end CD
+
+open AlgebraicCurve.Place
+
+theorem solution (K : Type*) [Field K] {F : Type*} [Field F] [Algebra K F]
+    (ι : F →ₐ[K] LaurentSeries K)
+    (h : ∃ x : F, (ι x).order ≠ 0) :
+    ∃ (w : Place K F) (γ : ℕ), 0 < γ ∧ ∀ x : F, w.ord x * (γ : ℤ) = (ι x).order :=
+  AlgebraicCurve.Place.exists_ord_mul_eq_order_of_algHom_laurentSeries' K ι h
+
+end
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.exists_ord_mul_eq_order_of_algHom_laurentSeries (K : Type*) [Field K]
+    {F : Type*} [Field F] [Algebra K F] (ι : F →ₐ[K] LaurentSeries K)
+    (h : ∃ x : F, (ι x).order ≠ 0) :
+    ∃ (w : Place K F) (γ : ℕ), 0 < γ ∧ ∀ x : F, w.ord x * (γ : ℤ) = (ι x).order := _root_.solution K
+      ι h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_hasRamBound.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_hasRamBound.lean
new file mode 100644
index 0000000000..9ab7a4137e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_hasRamBound.lean
@@ -0,0 +1,412 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.exists_ord_mul_eq_order_of_hasRamBound
+(843b7273-d68e-53c8-8f36-cdb31c8739f3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a1cb1d78-ef13-5790-84ed-dfe693c48c10
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.HahnSeries.PowerSeries
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_RamificationBound
+
+import Mathlib.Analysis.Normed.Field.Lemmas
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Hahn-series embedding with bounded ramification yields a place
+
+Theorem statement: `AlgebraicCurve.Place.exists_ord_mul_eq_order_of_hasRamBound`
+(`843b7273-d68e-53c8-8f36-cdb31c8739f3`), by Claude, 2026-09-05.
+
+Proof: submission `a1cb1d78-ef13-5790-84ed-dfe693c48c10`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $L$, $F$ be fields with $L$ and $F$ both $K$-algebras, and let $\varphi \colon F \to
+\mathrm{HahnSeries}\,\mathbb{Q}\,L$ be a homomorphism of $K$-algebras into the field of Hahn series
+with rational exponents and coefficients in $L$. Let $d$ be a natural number with $0 < d$, and
+assume the ramification of $\varphi$ is bounded by $d$ in the sense that for every $x \in F$ the
+support of $\varphi(x)$ is contained in $\{k/d : k \in \mathbb{Z}\} \subseteq \mathbb{Q}$. Assume
+further that $\varphi$ is nontrivial for the order function, i.e. there is some $x \in F$ with
+$\mathrm{order}(\varphi(x)) \neq 0$. The conclusion asserts the existence of a place $w$ of $F$ over
+$K$ — that is, a valuation subring of $F$ containing the image of $K$ under the structure map,
+different from $F$ itself, and whose underlying ring is a principal ideal ring — together with a
+rational number $g > 0$ such that for all $x \in F$ one has $(\mathrm{ord}_w x) \cdot g =
+\mathrm{order}(\varphi(x))$, where $\mathrm{ord}_w x \in \mathbb{Z}$ is the negative of the
+logarithm of the adic valuation attached to the height-one prime of $w$, viewed in $\mathbb{Q}$.
+
+This is the statement that the $t$-adic order pulled back along an embedding of $F$ into Hahn series
+with exponents in $\frac1d\mathbb{Z}$ is, up to a positive rational scaling factor $g$ generating
+its value group, the normalised valuation of a place of $F$ over $K$. It is the basic tool used to
+produce places from Puiseux- or Laurent-series expansions, and is invoked by the corresponding
+statement for embeddings into Laurent series and by the divisibility and ramification-index
+computations for such embeddings in the Galois case.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_hasRamBound.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_hasRamBound
+
+noncomputable section
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_hasRamBound.AlgebraicCurve"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ord exists_unit_mul_zpow ne_top' algebraMap_mem' \
+  toValuationSubring isPrincipalIdealRing'"
+namespace HahnEmbedding
+p2m_open "AlgebraicCurve.Place AlgebraicCurve"
+
+variable {K L F : Type*} [Field K] [Field L] [Algebra K L] [Field F] [Algebra K F]
+  (φ : F →ₐ[K] HahnSeries ℚ L)
+
+theorem map_ne_zero {x : F} (hx : x ≠ 0) : φ x ≠ 0 :=
+  (map_ne_zero_iff φ φ.toRingHom.injective).mpr hx
+
+theorem order_map_mul {x y : F} (hx : x ≠ 0) (hy : y ≠ 0) :
+    (φ (x * y)).order = (φ x).order + (φ y).order := by
+  rw [map_mul, HahnSeries.order_mul (map_ne_zero φ hx) (map_ne_zero φ hy)]
+
+theorem order_map_inv (x : F) : (φ x⁻¹).order = -(φ x).order := by
+  rcases eq_or_ne x 0 with rfl | hx
+  · simp
+  have h := order_map_mul φ hx (inv_ne_zero hx)
+  rw [mul_inv_cancel₀ hx, map_one, HahnSeries.order_one] at h
+  linarith
+
+theorem order_map_pow (x : F) (n : ℕ) : (φ (x ^ n)).order = n * (φ x).order := by
+  rw [map_pow, HahnSeries.order_pow, nsmul_eq_mul]
+
+theorem order_map_zpow (x : F) (n : ℤ) : (φ (x ^ n)).order = n * (φ x).order := by
+  rcases Int.eq_nat_or_neg n with ⟨m, rfl | rfl⟩
+  · rw [zpow_natCast, order_map_pow, Int.cast_natCast]
+  · rw [zpow_neg, zpow_natCast, order_map_inv, order_map_pow, Int.cast_neg, Int.cast_natCast,
+      neg_mul]
+
+theorem order_map_algebraMap (c : K) : (φ (algebraMap K F c)).order = 0 := by
+  have h : (algebraMap K (HahnSeries ℚ L)) c = HahnSeries.C (algebraMap K L c) := by
+    rw [HahnSeries.algebraMap_apply', IsScalarTower.algebraMap_apply K L (PowerSeries L),
+      PowerSeries.algebraMap_eq, HahnSeries.ofPowerSeries_C]
+  rw [φ.commutes, h, HahnSeries.order_C]
+
+def valuationSubring : ValuationSubring F where
+  carrier := {x | 0 ≤ (φ x).order}
+  mul_mem' {x y} hx hy := by
+    change 0 ≤ (φ (x * y)).order
+    rcases eq_or_ne x 0 with rfl | hx0
+    · simp
+    rcases eq_or_ne y 0 with rfl | hy0
+    · simp
+    rw [order_map_mul φ hx0 hy0]
+    exact add_nonneg hx hy
+  one_mem' := by
+    change 0 ≤ (φ 1).order
+    rw [map_one, HahnSeries.order_one]
+  add_mem' {x y} hx hy := by
+    change 0 ≤ (φ (x + y)).order
+    rcases eq_or_ne (φ (x + y)) 0 with h0 | h0
+    · rw [h0, HahnSeries.order_zero]
+    rw [map_add] at h0 ⊢
+    exact le_trans (le_min hx hy) (HahnSeries.min_order_le_order_add h0)
+  zero_mem' := by
+    change 0 ≤ (φ 0).order
+    rw [map_zero, HahnSeries.order_zero]
+  neg_mem' {x} hx := by
+    change 0 ≤ (φ (-x)).order
+    rwa [map_neg, HahnSeries.order_neg]
+  mem_or_inv_mem' x := by
+    rcases le_or_gt 0 (φ x).order with h | h
+    · exact Or.inl h
+    · right
+      change 0 ≤ (φ x⁻¹).order
+      rw [order_map_inv]
+      linarith
+
+theorem mem_valuationSubring_iff (x : F) : x ∈ valuationSubring φ ↔ 0 ≤ (φ x).order := Iff.rfl
+
+theorem coe_ne_zero {x : valuationSubring φ} (hx : x ≠ 0) : (x : F) ≠ 0 := by
+  simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hx
+
+theorem ne_zero_of_coe_ne_zero {x : valuationSubring φ} (hx : (x : F) ≠ 0) : x ≠ 0 :=
+  fun h => hx (by rw [h]; rfl)
+
+theorem isUnit_iff_order_eq_zero {x : valuationSubring φ} (hx : x ≠ 0) :
+    IsUnit x ↔ (φ x).order = 0 := by
+  have hxF : (x : F) ≠ 0 := coe_ne_zero φ hx
+  constructor
+  · intro hu
+    obtain ⟨y, hy⟩ := isUnit_iff_exists_inv.mp hu
+    have hxy : ((x : F) * y) = 1 := by
+      have := congrArg Subtype.val hy
+      simpa using this
+    have hyF : (y : F) ≠ 0 := by
+      intro h0
+      rw [h0, mul_zero] at hxy
+      exact zero_ne_one hxy
+    have hsum : (φ x).order + (φ y).order = 0 := by
+      rw [← order_map_mul φ hxF hyF, hxy, map_one, HahnSeries.order_one]
+    have h1 : 0 ≤ (φ x).order := x.2
+    have h2 : 0 ≤ (φ y).order := y.2
+    linarith
+  · intro h0
+    have hinv : (x : F)⁻¹ ∈ valuationSubring φ := by
+      rw [mem_valuationSubring_iff, order_map_inv, h0, neg_zero]
+    refine isUnit_iff_exists_inv.mpr ⟨⟨(x : F)⁻¹, hinv⟩, ?_⟩
+    exact Subtype.ext (mul_inv_cancel₀ hxF)
+
+section Discrete
+
+variable {d : ℕ} (hd : 0 < d) (hφ : ∀ x : F, HahnSeries.HasRamBound d (φ x))
+include hd hφ
+
+theorem exists_int_order_mul (x : F) : ∃ k : ℤ, (φ x).order * d = k := by
+  rcases eq_or_ne (φ x) 0 with h0 | h0
+  · exact ⟨0, by rw [h0, HahnSeries.order_zero, zero_mul, Int.cast_zero]⟩
+  have hmem : (φ x).order ∈ (φ x).support := by
+    rw [HahnSeries.mem_support]
+    exact fun h => h0 (HahnSeries.coeff_order_eq_zero.mp h)
+  obtain ⟨k, hk⟩ := hφ x hmem
+  refine ⟨k, ?_⟩
+  have hd' : (d : ℚ) ≠ 0 := Nat.cast_ne_zero.mpr hd.ne'
+  rw [← hk, div_mul_cancel₀ _ hd']
+
+def posOrders (d : ℕ) : Set ℕ := {n : ℕ | 0 < n ∧ ∃ x : F, (φ x).order * d = n}
+
+variable (hnt : ∃ x : F, (φ x).order ≠ 0)
+include hnt
+
+theorem posOrders_nonempty : (posOrders φ d).Nonempty := by
+  obtain ⟨x, hx⟩ := hnt
+  have hd' : (0 : ℚ) < d := Nat.cast_pos.mpr hd
+  obtain ⟨y, hy⟩ : ∃ y : F, 0 < (φ y).order := by
+    rcases lt_or_gt_of_ne hx with h | h
+    · exact ⟨x⁻¹, by rw [order_map_inv]; linarith⟩
+    · exact ⟨x, h⟩
+  obtain ⟨k, hk⟩ := exists_int_order_mul φ hd hφ y
+  have hkpos : (0 : ℚ) < k := by rw [← hk]; positivity
+  have hkpos' : 0 < k := by exact_mod_cast hkpos
+  refine ⟨k.toNat, ?_, y, ?_⟩
+  · omega
+  · rw [hk]
+    have : ((k.toNat : ℤ) : ℚ) = (k : ℚ) := by rw [Int.toNat_of_nonneg hkpos'.le]
+    exact_mod_cast this.symm
+
+theorem exists_generator :
+    ∃ π : F, 0 < (φ π).order ∧ ∀ x : F, x ≠ 0 → ∃ n : ℤ, (φ x).order = n * (φ π).order := by
+  classical
+  have hd' : (0 : ℚ) < d := Nat.cast_pos.mpr hd
+  have hdne : (d : ℚ) ≠ 0 := hd'.ne'
+  obtain ⟨hmpos, π, hπ⟩ := Nat.sInf_mem (posOrders_nonempty φ hd hφ hnt)
+  set m : ℕ := sInf (posOrders φ d) with hm
+  have hmin : ∀ n ∈ posOrders φ d, m ≤ n := fun n hn => Nat.sInf_le hn
+  have hπpos : 0 < (φ π).order := by
+    have : (0 : ℚ) < (m : ℚ) := by exact_mod_cast hmpos
+    rw [← hπ] at this
+    exact pos_of_mul_pos_left this hd'.le
+  refine ⟨π, hπpos, fun x hx => ?_⟩
+  have hπ0 : π ≠ 0 := by
+    rintro rfl
+    rw [map_zero, HahnSeries.order_zero] at hπpos
+    exact lt_irrefl _ hπpos
+  obtain ⟨k, hk⟩ := exists_int_order_mul φ hd hφ x
+  set q : ℤ := k / m with hq
+  set r : ℤ := k % m with hr
+  have hmZ : (0 : ℤ) < m := by exact_mod_cast hmpos
+  have hr0 : 0 ≤ r := Int.emod_nonneg _ hmZ.ne'
+  have hrm : r < m := Int.emod_lt_of_pos _ hmZ
+  have hkqr : k = m * q + r := (Int.mul_ediv_add_emod k m).symm
+  have hy : (φ (x * π ^ (-q))).order * d = r := by
+    rw [order_map_mul φ hx (zpow_ne_zero _ hπ0), order_map_zpow, add_mul, mul_assoc, hπ, hk,
+      hkqr]
+    push_cast
+    ring
+  rcases hr0.lt_or_eq with hrpos | hr0'
+  · exfalso
+    have hmem : r.toNat ∈ posOrders φ d := by
+      refine ⟨by omega, x * π ^ (-q), ?_⟩
+      rw [hy]
+      have : ((r.toNat : ℤ) : ℚ) = (r : ℚ) := by rw [Int.toNat_of_nonneg hr0]
+      exact_mod_cast this.symm
+    have := hmin _ hmem
+    omega
+  · refine ⟨q, ?_⟩
+    have h1 : (φ x).order * d = q * ((φ π).order * d) := by
+      rw [hk, hπ, hkqr, ← hr0']
+      push_cast
+      ring
+    have h2 : ((φ x).order - q * (φ π).order) * d = 0 := by
+      rw [sub_mul, mul_assoc, ← h1, sub_self]
+    rcases mul_eq_zero.mp h2 with h | h
+    · linarith
+    · exact absurd h hdne
+
+end Discrete
+
+section Generator
+
+variable {π : F} (hπpos : 0 < (φ π).order)
+  (hgen : ∀ x : F, x ≠ 0 → ∃ n : ℤ, (φ x).order = n * (φ π).order)
+include hπpos hgen
+
+theorem gen_ne_zero : π ≠ 0 := by
+  rintro rfl
+  rw [map_zero, HahnSeries.order_zero] at hπpos
+  exact lt_irrefl _ hπpos
+
+omit hgen in
+theorem gen_mem : π ∈ valuationSubring φ := hπpos.le
+
+theorem exists_nat_of_mem {x : F} (hx0 : x ≠ 0) (hx : x ∈ valuationSubring φ) :
+    ∃ n : ℕ, (φ x).order = n * (φ π).order := by
+  obtain ⟨n, hn⟩ := hgen x hx0
+  have hn0 : 0 ≤ n := by
+    by_contra h
+    push Not at h
+    have : (φ x).order < 0 := by
+      rw [hn]
+      exact mul_neg_of_neg_of_pos (by exact_mod_cast h) hπpos
+    exact absurd hx (not_le.mpr this)
+  refine ⟨n.toNat, ?_⟩
+  rw [hn]
+  congr 1
+  have : ((n.toNat : ℤ) : ℚ) = (n : ℚ) := by rw [Int.toNat_of_nonneg hn0]
+  exact_mod_cast this.symm
+
+theorem irreducible_gen : Irreducible (⟨π, gen_mem φ hπpos⟩ : valuationSubring φ) := by
+  have hπ0 := gen_ne_zero φ hπpos hgen
+  refine ⟨fun hu => ?_, fun a b hab => ?_⟩
+  · rw [isUnit_iff_order_eq_zero φ (ne_zero_of_coe_ne_zero φ hπ0)] at hu
+    exact absurd hu hπpos.ne'
+  · have habF : π = (a : F) * b := by
+      have := congrArg Subtype.val hab
+      simpa using this
+    have ha0 : (a : F) ≠ 0 := by
+      intro h; rw [h, zero_mul] at habF; exact hπ0 habF
+    have hb0 : (b : F) ≠ 0 := by
+      intro h; rw [h, mul_zero] at habF; exact hπ0 habF
+    obtain ⟨na, hna⟩ := exists_nat_of_mem φ hπpos hgen ha0 a.2
+    obtain ⟨nb, hnb⟩ := exists_nat_of_mem φ hπpos hgen hb0 b.2
+    have hsum : ((na : ℚ) + nb) * (φ π).order = 1 * (φ π).order := by
+      rw [one_mul]
+      conv_rhs => rw [habF, order_map_mul φ ha0 hb0, hna, hnb]
+      ring
+    have h1 : ((na : ℚ) + nb) = 1 := mul_right_cancel₀ hπpos.ne' hsum
+    have h1' : na + nb = 1 := by exact_mod_cast h1
+    rcases Nat.eq_zero_or_pos na with hna0 | hna0
+    · left
+      rw [isUnit_iff_order_eq_zero φ (ne_zero_of_coe_ne_zero φ ha0), hna, hna0]
+      simp
+    · right
+      have hnb0 : nb = 0 := by omega
+      rw [isUnit_iff_order_eq_zero φ (ne_zero_of_coe_ne_zero φ hb0), hnb, hnb0]
+      simp
+
+theorem hasUnitMulPowIrreducibleFactorization :
+    IsDiscreteValuationRing.HasUnitMulPowIrreducibleFactorization (valuationSubring φ) := by
+  have hπ0 := gen_ne_zero φ hπpos hgen
+  refine ⟨⟨π, gen_mem φ hπpos⟩, irreducible_gen φ hπpos hgen, fun {x} hx => ?_⟩
+  have hxF : (x : F) ≠ 0 := coe_ne_zero φ hx
+  obtain ⟨n, hn⟩ := exists_nat_of_mem φ hπpos hgen hxF x.2
+  have hord : (φ ((x : F) * (π ^ n)⁻¹)).order = 0 := by
+    rw [order_map_mul φ hxF (inv_ne_zero (pow_ne_zero _ hπ0)), order_map_inv, order_map_pow, hn]
+    ring
+  have humem : (x : F) * (π ^ n)⁻¹ ∈ valuationSubring φ := by
+    rw [mem_valuationSubring_iff, hord]
+  have hu0 : (⟨(x : F) * (π ^ n)⁻¹, humem⟩ : valuationSubring φ) ≠ 0 := by
+    simp [ne_eq, Subtype.ext_iff, hxF, hπ0]
+  have hu : IsUnit (⟨(x : F) * (π ^ n)⁻¹, humem⟩ : valuationSubring φ) := by
+    rw [isUnit_iff_order_eq_zero φ hu0]
+    exact hord
+  refine ⟨n, hu.unit, Subtype.ext ?_⟩
+  have : ((hu.unit : valuationSubring φ) : F) = (x : F) * (π ^ n)⁻¹ := by
+    rw [IsUnit.unit_spec]
+  rw [Subring.coe_mul, SubmonoidClass.coe_pow, this]
+  change π ^ n * ((x : F) * (π ^ n)⁻¹) = x
+  field_simp
+
+def place : Place K F where
+  toValuationSubring := valuationSubring φ
+  algebraMap_mem' c := by
+    rw [mem_valuationSubring_iff, order_map_algebraMap]
+  ne_top' h := by
+    have hmem : π⁻¹ ∈ valuationSubring φ := h ▸ ValuationSubring.mem_top _
+    rw [mem_valuationSubring_iff, order_map_inv] at hmem
+    linarith
+  isPrincipalIdealRing' := by
+    have : IsDiscreteValuationRing (valuationSubring φ) :=
+      IsDiscreteValuationRing.ofHasUnitMulPowIrreducibleFactorization
+        (hasUnitMulPowIrreducibleFactorization φ hπpos hgen)
+    infer_instance
+
+theorem ord_mul_order_gen (x : F) :
+    ((place φ hπpos hgen).ord x : ℚ) * (φ π).order = (φ x).order := by
+  rcases eq_or_ne x 0 with rfl | hx
+  · simp
+  have hirr : Irreducible (⟨π, gen_mem φ hπpos⟩ : (place φ hπpos hgen).toValuationSubring) :=
+    irreducible_gen φ hπpos hgen
+  obtain ⟨u, hu⟩ := (place φ hπpos hgen).exists_unit_mul_zpow hx hirr
+  have huF : ((u : (place φ hπpos hgen).toValuationSubring) : F) ≠ 0 :=
+    coe_ne_zero φ (Units.ne_zero u)
+  have huord : (φ ((u : (place φ hπpos hgen).toValuationSubring) : F)).order = 0 :=
+    (isUnit_iff_order_eq_zero φ (Units.ne_zero u)).mp u.isUnit
+  have hπ0 := gen_ne_zero φ hπpos hgen
+  conv_rhs => rw [hu]
+  rw [order_map_mul φ huF (zpow_ne_zero _ hπ0), huord, zero_add]
+  exact (order_map_zpow φ π _).symm
+
+end Generator
+
+end AlgebraicCurve.Place.HahnEmbedding
+
+open AlgebraicCurve.Place.HahnEmbedding in
+theorem solution
+    {K L F : Type*} [Field K] [Field L] [Algebra K L] [Field F] [Algebra K F]
+    (φ : F →ₐ[K] HahnSeries ℚ L) {d : ℕ} (hd : 0 < d)
+    (hφ : ∀ x : F, HahnSeries.HasRamBound d (φ x))
+    (hnt : ∃ x : F, (φ x).order ≠ 0) :
+    ∃ (w : AlgebraicCurve.Place K F) (g : ℚ), 0 < g ∧
+      ∀ x : F, (w.ord x : ℚ) * g = (φ x).order := by
+  obtain ⟨π, hπpos, hgen⟩ := exists_generator φ hd hφ hnt
+  exact ⟨place φ hπpos hgen, (φ π).order, hπpos, ord_mul_order_gen φ hπpos hgen⟩
+
+end
+
+end S_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_hasRamBound
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_hasRamBound (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.exists_ord_mul_eq_order_of_hasRamBound
+    {K L F : Type*} [Field K] [Field L] [Algebra K L] [Field F] [Algebra K F]
+    (φ : F →ₐ[K] HahnSeries ℚ L) {d : ℕ} (hd : 0 < d)
+    (hφ : ∀ x : F, HahnSeries.HasRamBound d (φ x))
+    (hnt : ∃ x : F, (φ x).order ≠ 0) :
+    ∃ (w : AlgebraicCurve.Place K F) (g : ℚ), 0 < g ∧
+      ∀ x : F, (w.ord x : ℚ) * g = (φ x).order :=
+  solution φ hd hφ hnt
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_restrict_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_restrict_eq.lean
new file mode 100644
index 0000000000..8cb91628de
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_restrict_eq.lean
@@ -0,0 +1,107 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.exists_restrict_eq
+(f6b444ba-53d9-5bdc-92a4-aac9a9e883e6) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d9a605b8-dbd4-5be8-b0d2-ebe783ffae74
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import Mathlib.FieldTheory.Separable
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_fiberOver
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Every place extends to a finite separable extension
+
+Theorem statement: `AlgebraicCurve.Place.exists_restrict_eq`
+(`f6b444ba-53d9-5bdc-92a4-aac9a9e883e6`), by Claude, 2026-09-05.
+
+Proof: submission `d9a605b8-dbd4-5be8-b0d2-ebe783ffae74`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F'$ and $M$ be fields with $K$-algebra structures on $F'$ and $M$ and an $F'$-algebra
+structure on $M$ forming a scalar tower over $K$, and assume $M$ is finite-dimensional and separable
+over $F'$. A place of a field $F$ over $K$, in the sense used here, is a valuation subring
+$\mathcal{O}$ of $F$ which contains $\operatorname{im}(K \to F)$, is not all of $F$, and is a
+principal ideal ring; its restriction along $F' \to M$ is the place of $F'$ whose valuation subring
+is the preimage of $\mathcal{O}$ under $\operatorname{algebraMap} F' M$ (the three defining
+conditions being inherited). The assertion is: for every place $w$ of $F'$ over $K$ there exists a
+place $W$ of $M$ over $K$ whose restriction to $F'$ equals $w$, i.e. the restriction map on places
+along a finite separable extension is surjective.
+
+This is the finite separable case of Chevalley's extension theorem for places, equivalently
+surjectivity of the restriction map $\operatorname{Place}(M/K) \to \operatorname{Place}(F'/K)$. It
+is used throughout the curve-theoretic part of the development, for instance in the injectivity
+arguments for the divisorial Weil pairing and in the extension of places along subfields of finite
+degree.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_exists_restrict_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_exists_restrict_eq
+
+noncomputable section
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_Place_exists_restrict_eq.AlgebraicCurve \
+  IsDedekindDomain"
+open scoped Pointwise
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place"
+p2m_open "AlgebraicCurve"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "fiberOver restrict_eq_of_mem_fiberOver restrict \
+  sum_ramificationIndex_mul_inertiaDeg_fiberOver"
+end Place
+end AlgebraicCurve
+
+open _root_.AlgebraicCurve.Place
+  _root_.P2MW.S_AlgebraicCurve_Place_exists_restrict_eq.AlgebraicCurve.Place in
+theorem solution {K F' M : Type*} [Field K] [Field F'] [Field M]
+    [Algebra K F'] [Algebra K M] [Algebra F' M] [IsScalarTower K F' M]
+    [FiniteDimensional F' M] [Algebra.IsSeparable F' M] (w : Place K F') :
+    ∃ W : Place K M, W.restrict F' = w := by
+  by_contra hne
+  push Not at hne
+  have hempty : w.fiberOver M = ∅ :=
+    Finset.eq_empty_of_forall_notMem fun W hW => hne W (restrict_eq_of_mem_fiberOver w hW)
+  have hsum := sum_ramificationIndex_mul_inertiaDeg_fiberOver (F' := M) w
+  rw [hempty, Finset.sum_empty] at hsum
+  have hpos : 0 < Module.finrank F' M := Module.finrank_pos
+  omega
+
+end
+
+end S_AlgebraicCurve_Place_exists_restrict_eq
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_exists_restrict_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.exists_restrict_eq {K F' M : Type*} [Field K] [Field F'] [Field M]
+    [Algebra K F'] [Algebra K M] [Algebra F' M] [IsScalarTower K F' M]
+    [FiniteDimensional F' M] [Algebra.IsSeparable F' M] (w : Place K F') :
+    ∃ W : Place K M, W.restrict F' = w :=
+  solution w
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap.lean
new file mode 100644
index 0000000000..f55302b4e2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap.lean
@@ -0,0 +1,417 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.exists_toValuationSubring_eq_comap
+(30a3796c-a370-52ad-a290-6d595cf72e66) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 201dd02b-ac88-518a-8376-a61af29af808
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.RingTheory.Valuation.LocalSubring
+import Mathlib.RingTheory.IntegralClosure.IntegrallyClosed
+import Mathlib.RingTheory.IntegralClosure.Algebra.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Restriction of a place along an integral extension
+
+Theorem statement: `AlgebraicCurve.Place.exists_toValuationSubring_eq_comap`
+(`30a3796c-a370-52ad-a290-6d595cf72e66`), by Claude, 2026-09-05.
+
+Proof: submission `201dd02b-ac88-518a-8376-a61af29af808`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $F'$ be fields, with $F$ and $F'$ equipped with $K$-algebra structures, $F'$ with an
+$F$-algebra structure, the three forming a scalar tower $K \subseteq F \subseteq F'$, and with $F'$
+integral over $F$. Here a `Place K F` is a valuation subring $\mathcal O \subseteq F$ such that the
+image of $K$ under $\operatorname{algebraMap} K F$ is contained in $\mathcal O$, such that $\mathcal
+O \neq F$, and such that $\mathcal O$ is a principal ideal ring; likewise for `Place K F'`. The
+assertion is that for every place $w$ of $F'$ over $K$ there exists a place $v$ of $F$ over $K$
+whose valuation subring is the preimage of the valuation subring of $w$ under
+$\operatorname{algebraMap} F F'$, that is, $\mathcal O_v = \mathcal O_w \cap F$. Thus the
+intersection of $\mathcal O_w$ with $F$ again contains $K$, is a proper valuation subring of $F$,
+and is a principal ideal ring. The statement is purely existential: no restriction operation is
+named, and uniqueness of $v$ (automatic, since a place is determined by its valuation subring) is
+not part of the conclusion.
+
+This is the restriction $w \mapsto w|_F$ of places along an algebraic extension of fields over a
+common base field, in the form needed to compare places of a function field with those of a
+subfield. It is used in the treatment of the modular function field, for the description of the
+$j$-coordinate via
+[`ModularCurve.jCoordinate_spec_modularFunctionFieldBar`]
+(thm.html#ModularCurve.jCoordinate_spec_modularFunctionFieldBar).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ord ord_one ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow ne_top' algebraMap_mem' toValuationSubring \
+  isPrincipalIdealRing'"
+p2m_open "AlgebraicCurve.Place"
+
+section SinglePlace
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.ord_nonneg_of_mem' {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    0 ≤ v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨n, u, hu⟩ :=
+    IsDiscreteValuationRing.eq_unit_mul_pow_irreducible
+      (x := (⟨f, hf⟩ : v.toValuationSubring)) (by simpa [Subtype.ext_iff] using hf0) hπ
+  have hcoe : f = ((u : v.toValuationSubring) : F) * ((π : F) ^ (n : ℤ)) := by
+    have h := congrArg (Subtype.val) hu
+    push_cast at h
+    rw [zpow_natCast]
+    exact h
+  rw [hcoe, v.ord_unit_smul_zpow u hπ (n : ℤ)]
+  exact Int.natCast_nonneg n
+
+p2m_export "AlgebraicCurve.Place" "ord_nonneg_of_mem'"
+private theorem _root_.AlgebraicCurve.Place.mem_of_ord_nonneg' {f : F} (hf : f ≠ 0)
+    (h : 0 ≤ v.ord f) :
+    f ∈ v.toValuationSubring := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ
+  rw [hu, show v.ord f = (((v.ord f).toNat : ℕ) : ℤ) from (Int.toNat_of_nonneg h).symm,
+    zpow_natCast]
+  exact mul_mem (u : v.toValuationSubring).2 (pow_mem (π : v.toValuationSubring).2 _)
+
+p2m_export "AlgebraicCurve.Place" "mem_of_ord_nonneg'"
+private theorem _root_.AlgebraicCurve.Place.mem_iff_ord_nonneg' {f : F} (hf : f ≠ 0) :
+    f ∈ v.toValuationSubring ↔ 0 ≤ v.ord f :=
+  ⟨v.ord_nonneg_of_mem', v.mem_of_ord_nonneg' hf⟩
+
+p2m_export "AlgebraicCurve.Place" "mem_iff_ord_nonneg'"
+private theorem exists_ord_pos_mem' : ∃ f : F, f ≠ 0 ∧ 0 < v.ord f ∧ f ∈ v.toValuationSubring := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  refine ⟨(π : F), ?_, ?_, π.2⟩
+  · simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  · rw [v.ord_coe_irreducible hπ]
+    exact one_pos
+
+end SinglePlace
+
+section Restrict
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F'] [Algebra F F']
+
+private theorem algebraMap_ne_zero' {f : F} (hf : f ≠ 0) : algebraMap F F' f ≠ 0 := by
+  simpa using hf
+
+variable (w : Place K F')
+
+private theorem _root_.AlgebraicCurve.Place.comap_algebraMap_ne_top' [Algebra.IsIntegral F F'] :
+    w.toValuationSubring.comap (algebraMap F F') ≠ ⊤ := by
+  intro htop
+  apply w.ne_top'
+  have hF : ∀ f : F, algebraMap F F' f ∈ w.toValuationSubring := fun f =>
+    ValuationSubring.mem_comap.mp (htop ▸ ValuationSubring.mem_top f)
+  refine SetLike.ext fun x => ⟨fun _ => ValuationSubring.mem_top x, fun _ => ?_⟩
+  let : Algebra F w.toValuationSubring :=
+    ((algebraMap F F').codRestrict w.toValuationSubring.toSubring hF).toAlgebra
+  let : IsScalarTower F w.toValuationSubring F' :=
+    IsScalarTower.of_algebraMap_eq fun f => rfl
+  have hx : IsIntegral w.toValuationSubring x :=
+    (Algebra.IsIntegral.isIntegral (R := F) x).tower_top
+  obtain ⟨y, hy⟩ := IsIntegrallyClosed.isIntegral_iff.mp hx
+  exact hy ▸ y.2
+
+p2m_export "AlgebraicCurve.Place" "comap_algebraMap_ne_top'"
+variable {w} in
+private theorem mem_comap_iff_ord_nonneg' {f : F} (hf : f ≠ 0) :
+    f ∈ w.toValuationSubring.comap (algebraMap F F') ↔
+      0 ≤ w.ord (algebraMap F F' f) := by
+  rw [ValuationSubring.mem_comap]
+  exact w.mem_iff_ord_nonneg' (algebraMap_ne_zero' hf)
+
+variable {w} in
+private theorem isUnit_mk_comap_iff' {f : F} (hf : f ≠ 0)
+    (hmem : f ∈ w.toValuationSubring.comap (algebraMap F F')) :
+    IsUnit (⟨f, hmem⟩ : w.toValuationSubring.comap (algebraMap F F')) ↔
+      w.ord (algebraMap F F' f) = 0 := by
+  constructor
+  · rintro h
+    obtain ⟨b, hb⟩ := isUnit_iff_exists_inv.mp h
+    have hb' : f * (b : F) = 1 := by
+      simpa [Subtype.ext_iff] using hb
+    have hbne : (b : F) ≠ 0 := by
+      intro h0
+      rw [h0, mul_zero] at hb'
+      exact zero_ne_one hb'
+    have hsum : w.ord (algebraMap F F' f) + w.ord (algebraMap F F' (b : F)) = 0 := by
+      rw [← w.ord_mul (algebraMap_ne_zero' hf) (algebraMap_ne_zero' hbne), ← map_mul, hb',
+        map_one, w.ord_one]
+    have h1 : 0 ≤ w.ord (algebraMap F F' f) := (mem_comap_iff_ord_nonneg' hf).mp hmem
+    have h2 : 0 ≤ w.ord (algebraMap F F' (b : F)) := (mem_comap_iff_ord_nonneg' hbne).mp b.2
+    omega
+  · intro h0
+    have hinv : f⁻¹ ∈ w.toValuationSubring.comap (algebraMap F F') :=
+      (mem_comap_iff_ord_nonneg' (inv_ne_zero hf)).mpr (by rw [map_inv₀, w.ord_inv]; omega)
+    exact ⟨⟨⟨f, hmem⟩, ⟨f⁻¹, hinv⟩, Subtype.ext (mul_inv_cancel₀ hf),
+      Subtype.ext (inv_mul_cancel₀ hf)⟩, rfl⟩
+
+private theorem _root_.AlgebraicCurve.Place.exists_ord_algebraMap_pos' [Algebra.IsIntegral F F'] :
+    ∃ f : F, f ≠ 0 ∧ 0 < w.ord (algebraMap F F' f) := by
+  have h := w.comap_algebraMap_ne_top' (F := F)
+  rw [ne_eq, SetLike.ext_iff, not_forall] at h
+  obtain ⟨g, hg⟩ := h
+  simp only [ValuationSubring.mem_top, iff_true] at hg
+  have hg0 : g ≠ 0 := by
+    rintro rfl
+    exact hg (zero_mem _)
+  refine ⟨g⁻¹, inv_ne_zero hg0, ?_⟩
+  rw [map_inv₀, w.ord_inv]
+  have := (mem_comap_iff_ord_nonneg' hg0).not.mp hg
+  omega
+
+p2m_export "AlgebraicCurve.Place" "exists_ord_algebraMap_pos'"
+
+private def ramificationIndex' (F : Type*) [Field F] [Algebra F F'] : ℕ :=
+  sInf {n : ℕ | 0 < n ∧ ∃ f : F, f ≠ 0 ∧ w.ord (algebraMap F F' f) = n}
+
+private theorem _root_.AlgebraicCurve.Place.ramificationIndex'_le_ord {f : F} (hf : f ≠ 0)
+    (hpos : 0 < w.ord (algebraMap F F' f)) :
+    (ramificationIndex' (F := F) w : ℤ) ≤ w.ord (algebraMap F F' f) := by
+  have h := Nat.sInf_le
+    (s := {n : ℕ | 0 < n ∧ ∃ f : F, f ≠ 0 ∧ w.ord (algebraMap F F' f) = n})
+    (m := (w.ord (algebraMap F F' f)).toNat) ⟨by omega, f, hf, by omega⟩
+  rw [ramificationIndex']
+  omega
+
+p2m_export "AlgebraicCurve.Place" "ramificationIndex'_le_ord"
+variable [Algebra.IsIntegral F F']
+
+private theorem _root_.AlgebraicCurve.Place.ramificationIndex'_set_nonempty :
+    {n : ℕ | 0 < n ∧ ∃ f : F, f ≠ 0 ∧ w.ord (algebraMap F F' f) = n}.Nonempty := by
+  obtain ⟨f, hf0, hf⟩ := w.exists_ord_algebraMap_pos' (F := F)
+  exact ⟨(w.ord (algebraMap F F' f)).toNat, by omega, f, hf0, by omega⟩
+
+p2m_export "AlgebraicCurve.Place" "ramificationIndex'_set_nonempty"
+private theorem _root_.AlgebraicCurve.Place.ramificationIndex'_pos :
+    0 < ramificationIndex' (F := F) w :=
+  (Nat.sInf_mem (w.ramificationIndex'_set_nonempty (F := F))).1
+
+p2m_export "AlgebraicCurve.Place" "ramificationIndex'_pos"
+private theorem _root_.AlgebraicCurve.Place.exists_ord_eq_ramificationIndex' :
+    ∃ f : F, f ≠ 0 ∧ w.ord (algebraMap F F' f) = ramificationIndex' (F := F) w :=
+  (Nat.sInf_mem (w.ramificationIndex'_set_nonempty (F := F))).2
+
+p2m_export "AlgebraicCurve.Place" "exists_ord_eq_ramificationIndex'"
+private theorem _root_.AlgebraicCurve.Place.ramificationIndex'_dvd_ord {f : F} (hf : f ≠ 0) :
+    (ramificationIndex' (F := F) w : ℤ) ∣ w.ord (algebraMap F F' f) := by
+  obtain ⟨g, hg0, hge⟩ := w.exists_ord_eq_ramificationIndex' (F := F)
+  set e : ℤ := (ramificationIndex' (F := F) w : ℤ) with he
+  have hepos : 0 < e := by
+    have := w.ramificationIndex'_pos (F := F)
+    omega
+  set m : ℤ := w.ord (algebraMap F F' f) with hm
+  set q : ℤ := m / e with hq
+  have hgq : algebraMap F F' (g ^ (-q)) = (algebraMap F F' g) ^ (-q) := map_zpow₀ _ _ _
+  have hr : w.ord (algebraMap F F' (f * g ^ (-q))) = m - e * q := by
+    rw [map_mul, w.ord_mul (algebraMap_ne_zero' hf)
+      (by rw [hgq]; exact zpow_ne_zero _ (algebraMap_ne_zero' hg0)), hgq, w.ord_zpow, hge,
+      ← hm]
+    ring
+  have hmod := Int.emod_nonneg m (by omega : e ≠ 0)
+  have hmod' := Int.emod_lt_of_pos m hepos
+  have hbridge : m % e = m - e * q := by
+    rw [hq]
+    exact Int.emod_def m e
+  rcases eq_or_lt_of_le (show (0 : ℤ) ≤ m - e * q by omega) with heq | hlt
+  · exact ⟨q, by omega⟩
+  · exfalso
+    have hfg : f * g ^ (-q) ≠ 0 := mul_ne_zero hf (zpow_ne_zero _ hg0)
+    have hle := w.ramificationIndex'_le_ord (F := F) hfg (by omega)
+    rw [hr, ← he] at hle
+    omega
+
+p2m_export "AlgebraicCurve.Place" "ramificationIndex'_dvd_ord"
+private theorem irreducible_mk_comap' {g : F} (hg0 : g ≠ 0)
+    (hmem : g ∈ w.toValuationSubring.comap (algebraMap F F'))
+    (hge : w.ord (algebraMap F F' g) = ramificationIndex' (F := F) w) :
+    Irreducible (⟨g, hmem⟩ : w.toValuationSubring.comap (algebraMap F F')) := by
+  have hepos : 0 < ramificationIndex' (F := F) w := w.ramificationIndex'_pos (F := F)
+  constructor
+  · rw [isUnit_mk_comap_iff' hg0 hmem, hge]
+    omega
+  · rintro ⟨a, ha⟩ ⟨b, hb⟩ hab
+    have hab' : g = a * b := by simpa [Subtype.ext_iff] using hab
+    have ha0 : a ≠ 0 := by
+      rintro rfl
+      exact hg0 (by simpa using hab')
+    have hb0 : b ≠ 0 := by
+      rintro rfl
+      exact hg0 (by simpa using hab')
+    have hsum : w.ord (algebraMap F F' a) + w.ord (algebraMap F F' b)
+        = ramificationIndex' (F := F) w := by
+      rw [← w.ord_mul (algebraMap_ne_zero' ha0) (algebraMap_ne_zero' hb0), ← map_mul, ← hab',
+        hge]
+    have ha' : 0 ≤ w.ord (algebraMap F F' a) := (mem_comap_iff_ord_nonneg' ha0).mp ha
+    have hb' : 0 ≤ w.ord (algebraMap F F' b) := (mem_comap_iff_ord_nonneg' hb0).mp hb
+    rcases eq_or_lt_of_le ha' with ha0' | hapos
+    · exact Or.inl ((isUnit_mk_comap_iff' ha0 ha).mpr ha0'.symm)
+    rcases eq_or_lt_of_le hb' with hb0' | hbpos
+    · exact Or.inr ((isUnit_mk_comap_iff' hb0 hb).mpr hb0'.symm)
+    exfalso
+    have h1 := w.ramificationIndex'_le_ord (F := F) ha0 hapos
+    have h2 := w.ramificationIndex'_le_ord (F := F) hb0 hbpos
+    omega
+
+private theorem _root_.AlgebraicCurve.Place.isPrincipalIdealRing_comap' :
+    IsPrincipalIdealRing (w.toValuationSubring.comap (algebraMap F F')) := by
+  obtain ⟨g, hg0, hge⟩ := w.exists_ord_eq_ramificationIndex' (F := F)
+  have hepos : 0 < ramificationIndex' (F := F) w := w.ramificationIndex'_pos (F := F)
+  have hgmem : g ∈ w.toValuationSubring.comap (algebraMap F F') :=
+    (mem_comap_iff_ord_nonneg' hg0).mpr (by omega)
+  refine (IsDiscreteValuationRing.ofHasUnitMulPowIrreducibleFactorization
+    ⟨⟨g, hgmem⟩, irreducible_mk_comap' w hg0 hgmem hge, ?_⟩).toIsPrincipalIdealRing
+  rintro ⟨f, hmem⟩ hx
+  have hf : f ≠ 0 := by simpa [Subtype.ext_iff] using hx
+  obtain ⟨c, hc⟩ := w.ramificationIndex'_dvd_ord (F := F) hf
+  have hnonneg : 0 ≤ w.ord (algebraMap F F' f) := (mem_comap_iff_ord_nonneg' hf).mp hmem
+  have hcnonneg : 0 ≤ c := by
+    by_contra hneg
+    have hcle : c ≤ -1 := by omega
+    have : (ramificationIndex' (F := F) w : ℤ) * c ≤ (ramificationIndex' (F := F) w : ℤ) * -1 :=
+      mul_le_mul_of_nonneg_left hcle (by omega)
+    omega
+  set n : ℕ := c.toNat with hn
+  have hcn : (n : ℤ) = c := Int.toNat_of_nonneg hcnonneg
+  refine ⟨n, ?_⟩
+  have hgn : g ^ n ≠ 0 := pow_ne_zero _ hg0
+  have hdiv0 : f / g ^ n ≠ 0 := div_ne_zero hf hgn
+  have hu0 : w.ord (algebraMap F F' (f / g ^ n)) = 0 := by
+    have hkey : algebraMap F F' (f / g ^ n)
+        = algebraMap F F' f * (algebraMap F F' g) ^ (-(n : ℤ)) := by
+      rw [div_eq_mul_inv, map_mul, map_inv₀, map_pow, ← zpow_natCast (algebraMap F F' g) n,
+        ← zpow_neg]
+    rw [hkey, w.ord_mul (algebraMap_ne_zero' hf) (zpow_ne_zero _ (algebraMap_ne_zero' hg0)),
+      w.ord_zpow, hge, hc, ← hcn]
+    ring
+  have humem : f / g ^ n ∈ w.toValuationSubring.comap (algebraMap F F') :=
+    (mem_comap_iff_ord_nonneg' hdiv0).mpr (le_of_eq hu0.symm)
+  have hu : IsUnit (⟨f / g ^ n, humem⟩ : w.toValuationSubring.comap (algebraMap F F')) :=
+    (isUnit_mk_comap_iff' hdiv0 humem).mpr hu0
+  refine ⟨hu.unit, ?_⟩
+  refine Subtype.ext ?_
+  have hcoe : ((hu.unit : w.toValuationSubring.comap (algebraMap F F')) : F) = f / g ^ n := by
+    rw [IsUnit.unit_spec]
+  push_cast
+  rw [hcoe, mul_comm, div_mul_cancel₀]
+  exact hgn
+
+p2m_export "AlgebraicCurve.Place" "isPrincipalIdealRing_comap'"
+section RestrictDef
+
+variable [Algebra K F] [IsScalarTower K F F']
+
+variable (F) in
+private def _root_.AlgebraicCurve.Place.restrict' : Place K F where
+  toValuationSubring := w.toValuationSubring.comap (algebraMap F F')
+  algebraMap_mem' a := by
+    rw [ValuationSubring.mem_comap, ← IsScalarTower.algebraMap_apply]
+    exact w.algebraMap_mem' a
+  ne_top' := w.comap_algebraMap_ne_top'
+  isPrincipalIdealRing' := w.isPrincipalIdealRing_comap'
+
+p2m_export "AlgebraicCurve.Place" "restrict'"
+private theorem ord_restrict' (f : F) :
+    w.ord (algebraMap F F' f) = ramificationIndex' (F := F) w * (w.restrict' F).ord f := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · simp
+  obtain ⟨g, hg0, hge⟩ := w.exists_ord_eq_ramificationIndex' (F := F)
+  have hepos : 0 < ramificationIndex' (F := F) w := w.ramificationIndex'_pos (F := F)
+  have hgmem : g ∈ w.toValuationSubring.comap (algebraMap F F') :=
+    (mem_comap_iff_ord_nonneg' hg0).mpr (by omega)
+  obtain ⟨u, hu⟩ := (w.restrict' F).exists_unit_mul_zpow hf
+    (π := ⟨g, hgmem⟩) (irreducible_mk_comap' w hg0 hgmem hge)
+  set n : ℤ := (w.restrict' F).ord f with hn
+  have hune : ((u : (w.restrict' F).toValuationSubring) : F) ≠ 0 := by
+    intro h0
+    have := u.mul_inv
+    rw [Subtype.ext_iff] at this
+    push_cast at this
+    rw [h0, zero_mul] at this
+    exact zero_ne_one this
+  have huord : w.ord (algebraMap F F' ((u : (w.restrict' F).toValuationSubring) : F)) = 0 :=
+    (isUnit_mk_comap_iff' hune (u : (w.restrict' F).toValuationSubring).2).mp u.isUnit
+  have hgz : (algebraMap F F' g) ^ n ≠ 0 := zpow_ne_zero _ (algebraMap_ne_zero' hg0)
+  calc w.ord (algebraMap F F' f)
+      = w.ord (algebraMap F F' (((u : (w.restrict' F).toValuationSubring) : F) * g ^ n)) := by
+        rw [← hu]
+    _ = w.ord (algebraMap F F' ((u : (w.restrict' F).toValuationSubring) : F))
+          + w.ord ((algebraMap F F' g) ^ n) := by
+        rw [map_mul, map_zpow₀]
+        exact w.ord_mul (algebraMap_ne_zero' hune) hgz
+    _ = ramificationIndex' (F := F) w * n := by
+        rw [huord, w.ord_zpow, hge, zero_add, mul_comm]
+
+theorem rowMain :
+    ∃ v : Place K F, v.toValuationSubring = w.toValuationSubring.comap (algebraMap F F') :=
+  ⟨w.restrict' F, rfl⟩
+
+end RestrictDef
+
+end Restrict
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap.AlgebraicCurve in
+theorem solution {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+    [Algebra F F'] [IsScalarTower K F F'] [Algebra.IsIntegral F F'] (w : Place K F') :
+    ∃ v : Place K F, v.toValuationSubring = w.toValuationSubring.comap (algebraMap F F') :=
+  AlgebraicCurve.Place.rowMain w
+
+end S_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.exists_toValuationSubring_eq_comap {K F F' : Type*} [Field K] [Field F]
+    [Field F'] [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+    [Algebra.IsIntegral F F'] (w : Place K F') :
+    ∃ v : Place K F, v.toValuationSubring = w.toValuationSubring.comap (algebraMap F F') :=
+  solution w
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom.lean
new file mode 100644
index 0000000000..5d776767d1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom.lean
@@ -0,0 +1,292 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.exists_toValuationSubring_eq_comap_ringHom
+(de86ea3a-1842-5dc1-9167-e8f8988b4084) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f00397ed-aa90-557a-a397-1ea06a69b3d2
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.RingTheory.DedekindDomain.IntegralClosure
+import Mathlib.RingTheory.DedekindDomain.Dvr
+import Mathlib.RingTheory.DiscreteValuationRing.TFAE
+import Mathlib.RingTheory.Localization.Integral
+import Mathlib.RingTheory.Valuation.LocalSubring
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Algebra
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Pullback of a valuation subring along φ gives a place
+
+Theorem statement: `AlgebraicCurve.Place.exists_toValuationSubring_eq_comap_ringHom`
+(`de86ea3a-1842-5dc1-9167-e8f8988b4084`), by Claude, 2026-09-05.
+
+Proof: submission `f00397ed-aa90-557a-a397-1ea06a69b3d2`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $F'$ be fields with $F$ a $K$-algebra and $\operatorname{char} K = 0$, and suppose
+there is an element $x \in F$ such that $F$ is finite-dimensional over the intermediate field $K(x)
+=$ `IntermediateField.adjoin K {x}`. Let $\varphi : F \to F'$ be a ring homomorphism and let $w$ be
+a valuation subring of $F'$. Assume that $\varphi$ carries the image of $K$ into $w$, i.e.
+$\varphi(\mathrm{alg}_{K\to F}(a)) \in w$ for every $a \in K$, and that $w$ does not swallow all of
+$\varphi(F)$, i.e. there exists $y \in F$ with $\varphi(y) \notin w$. The conclusion is that there
+exists a place $v$ of $F$ over $K$ in the sense of the project's structure
+[`AlgebraicCurve.Place`](def/AlgebraicCurve_DivisorClassGroup.html#L22) — a valuation subring of $F$
+which contains $\mathrm{alg}_{K\to F}(a)$ for all $a \in K$, is not the whole of $F$, and is a
+principal ideal ring — whose underlying valuation subring is exactly the preimage $\varphi^{-1}(w)
+=$ `w.comap φ`.
+
+This is the construction of the place of $F/K$ lying under a given valuation of an extension or base
+change of $F$: the preimage of $w$ is a valuation subring of $F$, and the two hypotheses supply
+respectively the containment of $K$ and the properness needed for it to be a place, while finiteness
+of $F$ over a rational subfield $K(x)$ in characteristic zero gives the discreteness (principality).
+It is used in the divisor and differential theory of function fields, for instance in comparing
+divisors and orders under constant field extension and in the residue sum formula for differentials.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom.AlgebraicCurve \
+  IsDedekindDomain"
+open scoped IntermediateField.algebraAdjoinAdjoin
+
+section Crux
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] [CharZero K]
+variable (x : F) [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+variable (A : ValuationSubring F) (hAK : ∀ a : K, algebraMap K F a ∈ A) (hA : A ≠ ⊤)
+variable (hx : Transcendental K x) (hxA : x ∈ A)
+
+local notation3 "Kx" => Algebra.adjoin K ({x} : Set F)
+local notation3 "Kxfield" => IntermediateField.adjoin K ({x} : Set F)
+
+omit [CharZero K] [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] in
+include hx in
+private theorem isDedekindDomain_Kx : IsDedekindDomain (Kx) := by
+  have hinj : Function.Injective (Polynomial.aeval x : Polynomial K →ₐ[K] F) :=
+    transcendental_iff_injective.mp hx
+  have hrange : (Polynomial.aeval x : Polynomial K →ₐ[K] F).range = Kx :=
+    (Algebra.adjoin_singleton_eq_range_aeval K x).symm
+  let e : Polynomial K ≃ₐ[K] Kx :=
+    (AlgEquiv.ofInjective _ hinj).trans (Subalgebra.equivOfEq _ _ hrange)
+  have : IsPrincipalIdealRing (Kx) :=
+    IsPrincipalIdealRing.of_surjective (e : Polynomial K →+* Kx) e.surjective
+  infer_instance
+
+include hx in
+private theorem isDedekindDomain_integralClosure :
+    IsDedekindDomain (integralClosure (Kx) F) := by
+  have := isDedekindDomain_Kx x hx
+  have : Algebra.IsSeparable (Kxfield) F := Algebra.IsSeparable.of_integral _ _
+  exact integralClosure.isDedekindDomain (Kx) (Kxfield) F
+
+omit [CharZero K] in
+private theorem isFractionRing_integralClosure :
+    IsFractionRing (integralClosure (Kx) F) F :=
+  integralClosure.isFractionRing_of_finite_extension (A := Kx) (Kxfield) F
+
+omit [CharZero K] [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] in
+include hxA hAK in
+private theorem Kx_le_A : (Kx).toSubring ≤ A.toSubring := by
+  intro y hy
+  induction hy using Algebra.adjoin_induction with
+  | mem z hz => obtain rfl : z = x := hz; exact hxA
+  | algebraMap a => exact hAK a
+  | add a b _ _ ha hb => exact add_mem ha hb
+  | mul a b _ _ ha hb => exact mul_mem ha hb
+
+private scoped instance : IsFractionRing (A : ValuationSubring F).toSubring F := by
+  rw [← A.integer_valuation]; infer_instance
+
+private scoped instance : IsFractionRing (A : ValuationSubring F) F :=
+  inferInstanceAs (IsFractionRing A.toSubring F)
+
+omit [CharZero K] [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] in
+include hxA hAK in
+private theorem integralClosure_Kx_le_A :
+    (integralClosure (Kx) F).toSubring ≤ A.toSubring := by
+  intro y hy
+  have hyI : IsIntegral (Kx) y := hy
+  let : Algebra (Kx) A :=
+    (Subring.inclusion (Kx_le_A x A hAK hxA)).toAlgebra
+  have : IsScalarTower (Kx) A F :=
+    IsScalarTower.of_algebraMap_eq fun _ => rfl
+  have hyA : IsIntegral A y := hyI.tower_top
+  obtain ⟨z, hz⟩ := (isIntegrallyClosed_iff F).mp inferInstance hyA
+  exact hz ▸ z.2
+
+omit [CharZero K] [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] in
+include hxA hAK in
+private theorem inv_mem_of_notMem_maximalIdeal {b : integralClosure (Kx) F}
+    (hb : Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA) b
+        ∉ IsLocalRing.maximalIdeal A) :
+    ((b : F))⁻¹ ∈ A := by
+  have hbA : (b : F) ∈ A := integralClosure_Kx_le_A x A hAK hxA b.2
+  have hbU : IsUnit (⟨(b : F), hbA⟩ : A) := IsLocalRing.notMem_maximalIdeal.mp hb
+  obtain ⟨u, hu⟩ := hbU
+  have hcoe : (((u⁻¹ : Aˣ) : A) : F) * (b : F) = 1 := by
+    have h1 : ((u⁻¹ : Aˣ) : A) * ⟨(b : F), hbA⟩ = 1 := by rw [← hu]; exact u.inv_mul
+    have := congrArg (Subtype.val : A → F) h1; simpa using this
+  exact (eq_inv_of_mul_eq_one_left hcoe) ▸ ((u⁻¹ : Aˣ) : A).2
+
+omit [CharZero K] in
+include hxA hAK hA in
+private theorem idealOfA_ne_bot :
+    (IsLocalRing.maximalIdeal A).comap
+        (Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA)) ≠ ⊥ := by
+  have : IsFractionRing (integralClosure (Kx) F) F := isFractionRing_integralClosure x
+  intro hP
+  apply hA
+  rw [eq_top_iff]
+  intro y _
+  obtain ⟨a, b, hb, hab⟩ := IsFractionRing.div_surjective (A := integralClosure (Kx) F) y
+  have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb
+  have haA : (a : F) ∈ A := integralClosure_Kx_le_A x A hAK hxA a.2
+  have hbm : Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA) b
+      ∉ IsLocalRing.maximalIdeal A := by
+    intro hbm
+    have hmem : b ∈ (IsLocalRing.maximalIdeal A).comap
+        (Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA)) := hbm
+    rw [hP, Ideal.mem_bot] at hmem
+    exact hb0 hmem
+  rw [← hab, div_eq_mul_inv]
+  exact mul_mem haA (inv_mem_of_notMem_maximalIdeal x A hAK hxA hbm)
+
+omit [CharZero K] [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] in
+include hxA hAK in
+private theorem place_of_idealOfA_le (P : HeightOneSpectrum (integralClosure (Kx) F))
+    [IsDedekindDomain (integralClosure (Kx) F)] [IsFractionRing (integralClosure (Kx) F) F]
+    (hP : P.asIdeal = (IsLocalRing.maximalIdeal A).comap
+        (Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA))) :
+    (Place.ofHeightOneSpectrum (K := K) (F := F) P).toValuationSubring ≤ A := by
+  rw [Place.ofHeightOneSpectrum_toValuationSubring,
+    ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+  rintro y ⟨a, s, hs, rfl⟩
+  have haA : (a : F) ∈ A := integralClosure_Kx_le_A x A hAK hxA a.2
+  have hsm : Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA) s
+      ∉ IsLocalRing.maximalIdeal A := by
+    intro h
+    exact hs (hP ▸ h : s ∈ P.asIdeal)
+  exact mul_mem haA (inv_mem_of_notMem_maximalIdeal x A hAK hxA hsm)
+
+include hx hxA hAK hA in
+private theorem exists_place_of_mem :
+    ∃ v : Place K F, v.toValuationSubring = A := by
+  have := isDedekindDomain_integralClosure x hx
+  have : IsFractionRing (integralClosure (Kx) F) F := isFractionRing_integralClosure x
+  let P : HeightOneSpectrum (integralClosure (Kx) F) :=
+    ⟨(IsLocalRing.maximalIdeal A).comap
+        (Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA)),
+      inferInstance, idealOfA_ne_bot x A hAK hA hxA⟩
+  let V : Place K F := Place.ofHeightOneSpectrum P
+  have hVA : V.toValuationSubring ≤ A := place_of_idealOfA_le x A hAK hxA P rfl
+  exact ⟨V, ValuationSubring.eq_of_le_of_ne_top _ hVA hA⟩
+
+end Crux
+
+section Roots
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ord ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring \
+  toValuationSubring"
+end AlgebraicCurve.Place
+p2m_open_scoped "AlgebraicCurve AlgebraicCurve.Place" in
+private theorem AlgebraicCurve.Place.exists_of_valuationSubring {K F : Type*} [Field K] [Field F]
+    [Algebra K F] [CharZero K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (A : ValuationSubring F)
+    (hAK : ∀ a : K, algebraMap K F a ∈ A) (hA : A ≠ ⊤) :
+    ∃ v : AlgebraicCurve.Place K F, v.toValuationSubring = A := by
+  by_cases hx : Transcendental K x
+  · rcases A.mem_or_inv_mem x with hxA | hxiA
+    · exact exists_place_of_mem x A hAK hA hx hxA
+    · have hx0 : x ≠ 0 := by
+        rintro rfl; exact hx (isAlgebraic_zero (R := K))
+      have hxinv : Transcendental K x⁻¹ := by
+        rw [Transcendental, IsAlgebraic.inv_iff]; exact hx
+      have hadj : IntermediateField.adjoin K ({x⁻¹} : Set F) =
+          IntermediateField.adjoin K ({x} : Set F) := by
+        refine le_antisymm (IntermediateField.adjoin_le_iff.mpr ?_)
+          (IntermediateField.adjoin_le_iff.mpr ?_)
+        · intro z hz; rw [show z = x⁻¹ from hz]
+          exact inv_mem (IntermediateField.mem_adjoin_simple_self K x)
+        · intro z hz; rw [show z = x from hz]
+          have h : x⁻¹⁻¹ ∈ IntermediateField.adjoin K ({x⁻¹} : Set F) :=
+            inv_mem (IntermediateField.mem_adjoin_simple_self K x⁻¹)
+          rwa [inv_inv] at h
+      have : FiniteDimensional (IntermediateField.adjoin K ({x⁻¹} : Set F)) F := by
+        rw [hadj]; infer_instance
+      exact exists_place_of_mem x⁻¹ A hAK hA hxinv hxiA
+  · rw [Transcendental, not_not] at hx
+    refine absurd ?_ hA
+    rw [eq_top_iff]
+    intro y _
+    have : FiniteDimensional K (IntermediateField.adjoin K ({x} : Set F)) :=
+      IntermediateField.adjoin.finiteDimensional hx.isIntegral
+    have : FiniteDimensional K F :=
+      FiniteDimensional.trans K (IntermediateField.adjoin K ({x} : Set F)) F
+    have : Algebra.IsAlgebraic K F := Algebra.IsAlgebraic.of_finite K F
+    have hyI : IsIntegral K y := (Algebra.IsAlgebraic.isAlgebraic y).isIntegral
+    let : Algebra K A :=
+      ((algebraMap K F).codRestrict A.toSubring hAK).toAlgebra
+    have : IsScalarTower K A F := IsScalarTower.of_algebraMap_eq fun _ => rfl
+    have hyA : IsIntegral A y := hyI.tower_top
+    obtain ⟨z, hz⟩ := (isIntegrallyClosed_iff F).mp inferInstance hyA
+    exact hz ▸ z.2
+
+p2m_open_scoped "AlgebraicCurve AlgebraicCurve.Place" in
+private theorem AlgebraicCurve.Place.exists_toValuationSubring_eq_comap_ringHom {K F F' : Type*}
+    [Field K] [Field F] [Field F'] [Algebra K F] [CharZero K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (φ : F →+* F')
+    (w : ValuationSubring F') (hwK : ∀ a : K, φ (algebraMap K F a) ∈ w) (hwx : ∃ y : F, φ y ∉ w) :
+    ∃ v : AlgebraicCurve.Place K F, v.toValuationSubring = w.comap φ := by
+  refine AlgebraicCurve.Place.exists_of_valuationSubring x (w.comap φ)
+    (fun a => hwK a) ?_
+  intro h
+  obtain ⟨y, hy⟩ := hwx
+  exact hy (h ▸ ValuationSubring.mem_top y : y ∈ w.comap φ)
+
+end Roots
+
+theorem solution {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [CharZero K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (φ : F →+* F')
+    (w : ValuationSubring F') (hwK : ∀ a : K, φ (algebraMap K F a) ∈ w) (hwx : ∃ y : F, φ y ∉ w) :
+    ∃ v : AlgebraicCurve.Place K F, v.toValuationSubring = w.comap φ :=
+  AlgebraicCurve.Place.exists_toValuationSubring_eq_comap_ringHom x φ w hwK hwx
+
+end S_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.exists_toValuationSubring_eq_comap_ringHom {K F F' : Type*} [Field K]
+    [Field F] [Field F'] [Algebra K F] [CharZero K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (φ : F →+* F')
+    (w : ValuationSubring F') (hwK : ∀ a : K, φ (algebraMap K F a) ∈ w) (hwx : ∃ y : F, φ y ∉ w) :
+    ∃ v : AlgebraicCurve.Place K F, v.toValuationSubring = w.comap φ :=
+  solution x φ w hwK hwx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom_of_isSeparable.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom_of_isSeparable.lean
new file mode 100644
index 0000000000..5d53dc9020
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom_of_isSeparable.lean
@@ -0,0 +1,303 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.Place.exists_toValuationSubring_eq_comap_ringHom_of_isSeparable
+(c2700d3f-c07d-5588-8b25-09576fc6b229) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 359f9990-bd8a-5b92-a14e-643e8f7b69e8
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.RingTheory.DedekindDomain.IntegralClosure
+import Mathlib.RingTheory.DedekindDomain.Dvr
+import Mathlib.RingTheory.DiscreteValuationRing.TFAE
+import Mathlib.RingTheory.Localization.Integral
+import Mathlib.RingTheory.Valuation.LocalSubring
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Algebra
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Pullback of a proper valuation subring is a place
+
+Theorem statement: `AlgebraicCurve.Place.exists_toValuationSubring_eq_comap_ringHom_of_isSeparable`
+(`c2700d3f-c07d-5588-8b25-09576fc6b229`), by Claude, 2026-09-05.
+
+Proof: submission `359f9990-bd8a-5b92-a14e-643e8f7b69e8`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$ and $F'$ be fields with $F$ a $K$-algebra, and let $x \in F$ be such that $F$ is
+finite-dimensional over the intermediate field $K(x) =$ `IntermediateField.adjoin K {x}` and the
+extension $F/K(x)$ is separable. Let $\varphi \colon F \to F'$ be a ring homomorphism, and let $w$
+be a valuation subring of $F'$. Assume that $\varphi(a)$ lies in $w$ for every $a$ in the image of
+$K$ in $F$ under the structure map, and that $\varphi(y) \notin w$ for at least one $y \in F$. Then
+there is a place $v$ of $F/K$, that is, a valuation subring $\mathcal{O}_v \subseteq F$ containing
+the image of $K$, different from all of $F$, and whose underlying ring is a principal ideal ring,
+such that $\mathcal{O}_v$ is exactly the preimage $\varphi^{-1}(w)$ of $w$ under $\varphi$.
+
+This is the standard construction of a place of a one-variable function field $F/K$ by pulling back
+a proper valuation subring along a homomorphism out of $F$, here with separability of $F$ over
+$K(x)$ assumed in place of any hypothesis on the characteristic; the separability is what makes the
+integral closure in $F$ of the valuation ring of the corresponding place of $K(x)$ a finite module,
+hence Dedekind. It is used to produce places of $F/K$ with prescribed behaviour, for instance in the
+results on places obtained from $K$-algebra homomorphisms and on constant field extensions,
+including the case of algebraically closed constant field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom_of_isSeparable.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom_of_isSeparable
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom_of_isSeparable.AlgebraicCu\
+  rve IsDedekindDomain"
+open scoped IntermediateField.algebraAdjoinAdjoin
+
+section Crux
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable (x : F) [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+  [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F]
+variable (A : ValuationSubring F) (hAK : ∀ a : K, algebraMap K F a ∈ A) (hA : A ≠ ⊤)
+variable (hx : Transcendental K x) (hxA : x ∈ A)
+
+local notation3 "Kx" => Algebra.adjoin K ({x} : Set F)
+local notation3 "Kxfield" => IntermediateField.adjoin K ({x} : Set F)
+
+omit [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F] [FiniteDimensional
+  (IntermediateField.adjoin K ({x} : Set F)) F] in
+include hx in
+private theorem isDedekindDomain_Kx : IsDedekindDomain (Kx) := by
+  have hinj : Function.Injective (Polynomial.aeval x : Polynomial K →ₐ[K] F) :=
+    transcendental_iff_injective.mp hx
+  have hrange : (Polynomial.aeval x : Polynomial K →ₐ[K] F).range = Kx :=
+    (Algebra.adjoin_singleton_eq_range_aeval K x).symm
+  let e : Polynomial K ≃ₐ[K] Kx :=
+    (AlgEquiv.ofInjective _ hinj).trans (Subalgebra.equivOfEq _ _ hrange)
+  have : IsPrincipalIdealRing (Kx) :=
+    IsPrincipalIdealRing.of_surjective (e : Polynomial K →+* Kx) e.surjective
+  infer_instance
+
+include hx in
+private theorem isDedekindDomain_integralClosure :
+    IsDedekindDomain (integralClosure (Kx) F) := by
+  have := isDedekindDomain_Kx x hx
+  exact integralClosure.isDedekindDomain (Kx) (Kxfield) F
+
+omit [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F] in
+private theorem isFractionRing_integralClosure :
+    IsFractionRing (integralClosure (Kx) F) F :=
+  integralClosure.isFractionRing_of_finite_extension (A := Kx) (Kxfield) F
+
+omit [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F] [FiniteDimensional
+  (IntermediateField.adjoin K ({x} : Set F)) F] in
+include hxA hAK in
+private theorem Kx_le_A : (Kx).toSubring ≤ A.toSubring := by
+  intro y hy
+  induction hy using Algebra.adjoin_induction with
+  | mem z hz => obtain rfl : z = x := hz; exact hxA
+  | algebraMap a => exact hAK a
+  | add a b _ _ ha hb => exact add_mem ha hb
+  | mul a b _ _ ha hb => exact mul_mem ha hb
+
+private scoped instance : IsFractionRing (A : ValuationSubring F).toSubring F := by
+  rw [← A.integer_valuation]; infer_instance
+
+private scoped instance : IsFractionRing (A : ValuationSubring F) F :=
+  inferInstanceAs (IsFractionRing A.toSubring F)
+
+omit [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F] [FiniteDimensional
+  (IntermediateField.adjoin K ({x} : Set F)) F] in
+include hxA hAK in
+private theorem integralClosure_Kx_le_A :
+    (integralClosure (Kx) F).toSubring ≤ A.toSubring := by
+  intro y hy
+  have hyI : IsIntegral (Kx) y := hy
+  let : Algebra (Kx) A :=
+    (Subring.inclusion (Kx_le_A x A hAK hxA)).toAlgebra
+  have : IsScalarTower (Kx) A F :=
+    IsScalarTower.of_algebraMap_eq fun _ => rfl
+  have hyA : IsIntegral A y := hyI.tower_top
+  obtain ⟨z, hz⟩ := (isIntegrallyClosed_iff F).mp inferInstance hyA
+  exact hz ▸ z.2
+
+omit [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F] [FiniteDimensional
+  (IntermediateField.adjoin K ({x} : Set F)) F] in
+include hxA hAK in
+private theorem inv_mem_of_notMem_maximalIdeal {b : integralClosure (Kx) F}
+    (hb : Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA) b
+        ∉ IsLocalRing.maximalIdeal A) :
+    ((b : F))⁻¹ ∈ A := by
+  have hbA : (b : F) ∈ A := integralClosure_Kx_le_A x A hAK hxA b.2
+  have hbU : IsUnit (⟨(b : F), hbA⟩ : A) := IsLocalRing.notMem_maximalIdeal.mp hb
+  obtain ⟨u, hu⟩ := hbU
+  have hcoe : (((u⁻¹ : Aˣ) : A) : F) * (b : F) = 1 := by
+    have h1 : ((u⁻¹ : Aˣ) : A) * ⟨(b : F), hbA⟩ = 1 := by rw [← hu]; exact u.inv_mul
+    have := congrArg (Subtype.val : A → F) h1; simpa using this
+  exact (eq_inv_of_mul_eq_one_left hcoe) ▸ ((u⁻¹ : Aˣ) : A).2
+
+omit [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F] in
+include hxA hAK hA in
+private theorem idealOfA_ne_bot :
+    (IsLocalRing.maximalIdeal A).comap
+        (Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA)) ≠ ⊥ := by
+  have : IsFractionRing (integralClosure (Kx) F) F := isFractionRing_integralClosure x
+  intro hP
+  apply hA
+  rw [eq_top_iff]
+  intro y _
+  obtain ⟨a, b, hb, hab⟩ := IsFractionRing.div_surjective (A := integralClosure (Kx) F) y
+  have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb
+  have haA : (a : F) ∈ A := integralClosure_Kx_le_A x A hAK hxA a.2
+  have hbm : Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA) b
+      ∉ IsLocalRing.maximalIdeal A := by
+    intro hbm
+    have hmem : b ∈ (IsLocalRing.maximalIdeal A).comap
+        (Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA)) := hbm
+    rw [hP, Ideal.mem_bot] at hmem
+    exact hb0 hmem
+  rw [← hab, div_eq_mul_inv]
+  exact mul_mem haA (inv_mem_of_notMem_maximalIdeal x A hAK hxA hbm)
+
+omit [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F] [FiniteDimensional
+  (IntermediateField.adjoin K ({x} : Set F)) F] in
+include hxA hAK in
+private theorem place_of_idealOfA_le (P : HeightOneSpectrum (integralClosure (Kx) F))
+    [IsDedekindDomain (integralClosure (Kx) F)] [IsFractionRing (integralClosure (Kx) F) F]
+    (hP : P.asIdeal = (IsLocalRing.maximalIdeal A).comap
+        (Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA))) :
+    (Place.ofHeightOneSpectrum (K := K) (F := F) P).toValuationSubring ≤ A := by
+  rw [Place.ofHeightOneSpectrum_toValuationSubring,
+    ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+  rintro y ⟨a, s, hs, rfl⟩
+  have haA : (a : F) ∈ A := integralClosure_Kx_le_A x A hAK hxA a.2
+  have hsm : Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA) s
+      ∉ IsLocalRing.maximalIdeal A := by
+    intro h
+    exact hs (hP ▸ h : s ∈ P.asIdeal)
+  exact mul_mem haA (inv_mem_of_notMem_maximalIdeal x A hAK hxA hsm)
+
+include hx hxA hAK hA in
+private theorem exists_place_of_mem :
+    ∃ v : Place K F, v.toValuationSubring = A := by
+  have := isDedekindDomain_integralClosure x hx
+  have : IsFractionRing (integralClosure (Kx) F) F := isFractionRing_integralClosure x
+  let P : HeightOneSpectrum (integralClosure (Kx) F) :=
+    ⟨(IsLocalRing.maximalIdeal A).comap
+        (Subring.inclusion (integralClosure_Kx_le_A x A hAK hxA)),
+      inferInstance, idealOfA_ne_bot x A hAK hA hxA⟩
+  let V : Place K F := Place.ofHeightOneSpectrum P
+  have hVA : V.toValuationSubring ≤ A := place_of_idealOfA_le x A hAK hxA P rfl
+  exact ⟨V, ValuationSubring.eq_of_le_of_ne_top _ hVA hA⟩
+
+end Crux
+
+section Roots
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ord ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring \
+  toValuationSubring"
+end AlgebraicCurve.Place
+p2m_open_scoped "AlgebraicCurve AlgebraicCurve.Place" in
+private theorem AlgebraicCurve.Place.exists_of_valuationSubring {K F : Type*} [Field K] [Field F]
+    [Algebra K F] (x : F) [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F] (A : ValuationSubring F)
+    (hAK : ∀ a : K, algebraMap K F a ∈ A) (hA : A ≠ ⊤) :
+    ∃ v : AlgebraicCurve.Place K F, v.toValuationSubring = A := by
+  by_cases hx : Transcendental K x
+  · rcases A.mem_or_inv_mem x with hxA | hxiA
+    · exact exists_place_of_mem x A hAK hA hx hxA
+    · have hx0 : x ≠ 0 := by
+        rintro rfl; exact hx (isAlgebraic_zero (R := K))
+      have hxinv : Transcendental K x⁻¹ := by
+        rw [Transcendental, IsAlgebraic.inv_iff]; exact hx
+      have hadj : IntermediateField.adjoin K ({x⁻¹} : Set F) =
+          IntermediateField.adjoin K ({x} : Set F) := by
+        refine le_antisymm (IntermediateField.adjoin_le_iff.mpr ?_)
+          (IntermediateField.adjoin_le_iff.mpr ?_)
+        · intro z hz; rw [show z = x⁻¹ from hz]
+          exact inv_mem (IntermediateField.mem_adjoin_simple_self K x)
+        · intro z hz; rw [show z = x from hz]
+          have h : x⁻¹⁻¹ ∈ IntermediateField.adjoin K ({x⁻¹} : Set F) :=
+            inv_mem (IntermediateField.mem_adjoin_simple_self K x⁻¹)
+          rwa [inv_inv] at h
+      have : FiniteDimensional (IntermediateField.adjoin K ({x⁻¹} : Set F)) F := by
+        rw [hadj]; infer_instance
+      have : Algebra.IsSeparable (IntermediateField.adjoin K ({x⁻¹} : Set F)) F := by
+        rw [hadj]; infer_instance
+      exact exists_place_of_mem x⁻¹ A hAK hA hxinv hxiA
+  · rw [Transcendental, not_not] at hx
+    refine absurd ?_ hA
+    rw [eq_top_iff]
+    intro y _
+    have : FiniteDimensional K (IntermediateField.adjoin K ({x} : Set F)) :=
+      IntermediateField.adjoin.finiteDimensional hx.isIntegral
+    have : FiniteDimensional K F :=
+      FiniteDimensional.trans K (IntermediateField.adjoin K ({x} : Set F)) F
+    have : Algebra.IsAlgebraic K F := Algebra.IsAlgebraic.of_finite K F
+    have hyI : IsIntegral K y := (Algebra.IsAlgebraic.isAlgebraic y).isIntegral
+    let : Algebra K A :=
+      ((algebraMap K F).codRestrict A.toSubring hAK).toAlgebra
+    have : IsScalarTower K A F := IsScalarTower.of_algebraMap_eq fun _ => rfl
+    have hyA : IsIntegral A y := hyI.tower_top
+    obtain ⟨z, hz⟩ := (isIntegrallyClosed_iff F).mp inferInstance hyA
+    exact hz ▸ z.2
+
+p2m_open_scoped "AlgebraicCurve AlgebraicCurve.Place" in
+private theorem AlgebraicCurve.Place.exists_toValuationSubring_eq_comap_ringHom {K F F' : Type*}
+    [Field K] [Field F] [Field F'] [Algebra K F] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F] (φ : F →+* F')
+    (w : ValuationSubring F') (hwK : ∀ a : K, φ (algebraMap K F a) ∈ w) (hwx : ∃ y : F, φ y ∉ w) :
+    ∃ v : AlgebraicCurve.Place K F, v.toValuationSubring = w.comap φ := by
+  refine AlgebraicCurve.Place.exists_of_valuationSubring x (w.comap φ)
+    (fun a => hwK a) ?_
+  intro h
+  obtain ⟨y, hy⟩ := hwx
+  exact hy (h ▸ ValuationSubring.mem_top y : y ∈ w.comap φ)
+
+end Roots
+
+theorem solution {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F] (φ : F →+* F')
+    (w : ValuationSubring F') (hwK : ∀ a : K, φ (algebraMap K F a) ∈ w) (hwx : ∃ y : F, φ y ∉ w) :
+    ∃ v : AlgebraicCurve.Place K F, v.toValuationSubring = w.comap φ :=
+  AlgebraicCurve.Place.exists_toValuationSubring_eq_comap_ringHom x φ w hwK hwx
+
+end S_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom_of_isSeparable
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom_of_isSeparable
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.exists_toValuationSubring_eq_comap_ringHom_of_isSeparable
+    {K F F' : Type*} [Field K] [Field F] [Field F']
+    [Algebra K F] (x : F) [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F]
+    (φ : F →+* F') (w : ValuationSubring F')
+    (hwK : ∀ a : K, φ (algebraMap K F a) ∈ w) (hwx : ∃ y : F, φ y ∉ w) :
+    ∃ v : AlgebraicCurve.Place K F, v.toValuationSubring = w.comap φ :=
+  solution x φ w hwK hwx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_finite_residueField_of_finiteDimensional.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_finite_residueField_of_finiteDimensional.lean
new file mode 100644
index 0000000000..11596dcc9f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_finite_residueField_of_finiteDimensional.lean
@@ -0,0 +1,157 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.finite_residueField_of_finiteDimensional
+(bbdfa1a3-22ad-54df-ab92-df7e9cd5811e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6374efc9-41f3-5080-93b5-66b10eb8f598
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finiteness of residue degree in a finite extension
+
+Theorem statement: `AlgebraicCurve.Place.finite_residueField_of_finiteDimensional`
+(`bbdfa1a3-22ad-54df-ab92-df7e9cd5811e`), by Claude, 2026-09-05.
+
+Proof: submission `6374efc9-41f3-5080-93b5-66b10eb8f598`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $F'$ be fields with $F$ and $F'$ algebras over $K$ and $F'$ an algebra over $F$, the
+three structure maps forming a scalar tower $K \to F \to F'$, and assume $F'$ is finite-dimensional
+over $F$. Let $w$ be a place of $F'$ over $K$ in the sense of this project: a valuation subring
+$\mathcal{O}_w \subseteq F'$ containing $\mathrm{algebraMap}\,K\,F'(a)$ for every $a \in K$,
+different from the whole of $F'$, and which is a principal ideal ring. Write
+$w.\mathrm{ResidueField}$ for the residue field of the local ring $\mathcal{O}_w$, and let
+$w.\mathrm{restrict}\,F$ be the place of $F$ over $K$ whose valuation subring is the preimage
+$\mathcal{O}_w \cap F$ of $\mathcal{O}_w$ under $\mathrm{algebraMap}\,F\,F'$ (its three axioms being
+inherited from those of $w$). The conclusion is that $w.\mathrm{ResidueField}$ is a finite module
+over the residue field of $w.\mathrm{restrict}\,F$, the latter acting through the induced map of
+residue fields; equivalently, the residue degree $f(w \mid w|_F)$ is finite. No separability
+hypothesis on $F'/F$ is imposed.
+
+This is the finiteness half of the classical statement that, in a finite extension of function
+fields, each place has finite residue degree; it is the separability-free form, and the bound
+obtained is by $[F':F]$. It is used in establishing that a field transcendental over $K$ gives a
+curve over $K$ in the project's sense, and in the degree bookkeeping for places on
+characteristic-$p$ fibre models of modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_finite_residueField_of_finiteDimensional.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_finite_residueField_of_finiteDimensional
+
+open AlgebraicCurve
+
+namespace S09G2F
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+  [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F']
+
+open IsLocalRing in
+theorem linearIndependent_lift (w : Place K F') {ι : Type*} [Finite ι]
+    (x : ι → w.toValuationSubring)
+    (hx : LinearIndependent (w.restrict F).ResidueField
+      fun i => (residue w.toValuationSubring (x i) : w.ResidueField)) :
+    LinearIndependent F fun i => ((x i : w.toValuationSubring) : F') := by
+  classical
+  let := Fintype.ofFinite ι
+  rw [Fintype.linearIndependent_iff]
+  intro g hg
+  by_contra hne
+  obtain ⟨i₀, hi₀⟩ : ∃ i, g i ≠ 0 := not_forall.mp hne
+  set O : ValuationSubring F := (w.restrict F).toValuationSubring
+  have hne' : (Finset.univ.filter fun i => g i ≠ 0).Nonempty := ⟨i₀, by simpa using hi₀⟩
+  obtain ⟨k, hk, hkmax⟩ := Finset.exists_max_image _ (fun i => O.valuation (g i)) hne'
+  have hgk : g k ≠ 0 := by simpa using hk
+  have hb : ∀ i, g i / g k ∈ O := by
+    intro i
+    by_cases hi : g i = 0
+    · simp [hi]
+    · apply O.mem_of_valuation_le_one
+      rw [map_div₀]
+      have hk0 : (0 : O.ValueGroup) < O.valuation (g k) := by
+        rw [zero_lt_iff]; exact (map_ne_zero _).mpr hgk
+      exact (div_le_one₀ hk0).mpr (hkmax i (by simpa using hi))
+  let b : ι → O := fun i => ⟨g i / g k, hb i⟩
+  have hrel : ∑ i, Place.restrictInclusion F w (b i) * x i = 0 := by
+    apply Subtype.ext
+    have hcoe : ((∑ i, Place.restrictInclusion F w (b i) * x i : w.toValuationSubring) : F') =
+        ∑ i, algebraMap F F' (g i / g k) * (x i : F') := by
+      rw [AddSubmonoidClass.coe_finsetSum]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [MulMemClass.coe_mul, Place.coe_restrictInclusion]
+    rw [hcoe]
+    have : ∑ i, algebraMap F F' (g i / g k) * (x i : F') =
+        algebraMap F F' (g k)⁻¹ * ∑ i, g i • ((x i : w.toValuationSubring) : F') := by
+      rw [Finset.mul_sum]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [Algebra.smul_def, div_eq_inv_mul, map_mul, mul_assoc]
+    rw [this, hg, mul_zero]
+    rfl
+  have hres : ∑ i, (residue O (b i) : (w.restrict F).ResidueField) •
+      (residue w.toValuationSubring (x i) : w.ResidueField) = 0 := by
+    have h := congrArg (residue w.toValuationSubring) hrel
+    rw [map_sum, map_zero] at h
+    rw [← h]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [Algebra.smul_def, Place.algebraMap_residueField_eq, Place.restrictResidueMap_residue,
+      map_mul]
+  have hk1 := (Fintype.linearIndependent_iff.mp hx) _ hres k
+  have hbk : b k = 1 := Subtype.ext (div_self hgk)
+  rw [hbk, map_one] at hk1
+  exact one_ne_zero hk1
+
+open IsLocalRing in
+theorem finite_residueField (w : Place K F') :
+    Module.Finite (w.restrict F).ResidueField w.ResidueField := by
+  classical
+  rw [← Module.rank_lt_aleph0_iff]
+  refine lt_of_le_of_lt (rank_le (n := Module.finrank F F') fun s hs => ?_)
+    Cardinal.natCast_lt_aleph0
+  choose x hx using fun y : s => residue_surjective (R := w.toValuationSubring) (y : w.ResidueField)
+  have hs' : LinearIndependent (w.restrict F).ResidueField
+      fun i : s => (residue w.toValuationSubring (x i) : w.ResidueField) := by
+    simpa only [hx] using hs
+  have := linearIndependent_lift (F := F) w x hs'
+  simpa [Fintype.card_coe] using this.fintype_card_le_finrank
+
+end S09G2F
+
+theorem solution {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+    [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F'] (w : Place K F') :
+    Module.Finite (w.restrict F).ResidueField w.ResidueField :=
+  S09G2F.finite_residueField (F := F) w
+
+end S_AlgebraicCurve_Place_finite_residueField_of_finiteDimensional
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_finite_residueField_of_finiteDimensional (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.finite_residueField_of_finiteDimensional {K F F' : Type*} [Field K]
+    [Field F] [Field F'] [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+    [FiniteDimensional F F'] (w : Place K F') :
+    Module.Finite (w.restrict F).ResidueField w.ResidueField :=
+  solution w
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_inertiaDegAlong_comp.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_inertiaDegAlong_comp.lean
new file mode 100644
index 0000000000..50a90accba
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_inertiaDegAlong_comp.lean
@@ -0,0 +1,111 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.inertiaDegAlong_comp
+(c9a09ece-3a42-5346-8fc5-a227abeaca40) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3dd2e3bc-18d9-525e-b403-31f970382fe5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Multiplicativity of the inertia degree in a tower
+
+Theorem statement: `AlgebraicCurve.Place.inertiaDegAlong_comp`
+(`c9a09ece-3a42-5346-8fc5-a227abeaca40`), by Claude, 2026-09-05.
+
+Proof: submission `3dd2e3bc-18d9-525e-b403-31f970382fe5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $F$, $F'$, $F''$ be fields equipped with $K$-algebra structures, and let
+$\varphi \colon F \to F'$ and $\chi \colon F' \to F''$ be $K$-algebra homomorphisms whose underlying
+ring homomorphisms are integral, with integrality of the composite $\chi \circ \varphi$ assumed as a
+separate hypothesis. Let $W$ be a place of $F''$ over $K$, that is, a valuation subring of $F''$
+containing the image of $K$, different from $F''$ itself, and whose ring is a principal ideal ring.
+For an integral $K$-algebra map $\psi$, the place obtained by restricting $W$ along $\psi$ is the
+preimage valuation subring of $W$ under $\psi$, and the inertia degree of $W$ along $\psi$ is the
+$\mathbb{N}$-valued rank $\operatorname{finrank}$ of the residue field of $W$ as a module over the
+residue field of that restricted place (so the value is $0$ when this residue extension is
+infinite). The conclusion is that the inertia degree of $W$ along $\chi \circ \varphi$ equals the
+product of the inertia degree of $W$ along $\chi$ and the inertia degree, along $\varphi$, of the
+restriction of $W$ along $\chi$. No finiteness hypothesis is imposed, so the identity also covers
+the case in which all three degrees are $0$.
+
+This is the classical multiplicativity of the residue (inertia) degree $f$ in a tower of function
+fields, here for places presented as principal valuation subrings and with inertia degrees defined
+as residue-field ranks. It is used in the theory of divisor push-forward along correspondences,
+notably for the composition law for push-forwards and in the fundamental-identity statements summing
+$e \cdot f$ over a bifibre.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_inertiaDegAlong_comp.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_inertiaDegAlong_comp
+
+open IsDedekindDomain AlgebraicCurve
+
+theorem solution {K F F' F'' : Type*} [Field K] [Field F] [Field F'] [Field F''] [Algebra K F]
+    [Algebra K F'] [Algebra K F''] (φ : F →ₐ[K] F') (χ : F' →ₐ[K] F'') (hφ : φ.toRingHom.IsIntegral)
+    (hχ : χ.toRingHom.IsIntegral) (hχφ : (χ.comp φ).toRingHom.IsIntegral) (W : Place K F'') :
+    W.inertiaDegAlong (χ.comp φ) hχφ = W.inertiaDegAlong χ hχ * (W.restrictAlong χ
+      hχ).inertiaDegAlong φ hφ := by
+  let iχ : Algebra F' F'' := algebraAlong χ
+  have := isScalarTower_along χ
+  have := isIntegral_along χ hχ
+  let iφ : Algebra F F' := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  let w : Place K F' := W.restrict F'
+  let v : Place K F := w.restrict F
+  let iχφ : Algebra F F'' := algebraAlong (χ.comp φ)
+  have := isScalarTower_along (χ.comp φ)
+  have := isIntegral_along (χ.comp φ) hχφ
+  let : Algebra v.ResidueField W.ResidueField := (Place.restrictResidueMap F W).toAlgebra
+  have : IsScalarTower v.ResidueField w.ResidueField W.ResidueField := by
+    refine IsScalarTower.of_algebraMap_eq fun x => ?_
+    obtain ⟨a, rfl⟩ := IsLocalRing.residue_surjective x
+    change Place.restrictResidueMap F W (IsLocalRing.residue _ a)
+      = Place.restrictResidueMap F' W (Place.restrictResidueMap F w (IsLocalRing.residue _ a))
+    rw [Place.restrictResidueMap_residue, Place.restrictResidueMap_residue,
+      Place.restrictResidueMap_residue]
+    exact congrArg _ (Subtype.ext rfl)
+  change Module.finrank v.ResidueField W.ResidueField
+    = Module.finrank w.ResidueField W.ResidueField * Module.finrank v.ResidueField w.ResidueField
+  rw [mul_comm]
+  exact (Module.finrank_mul_finrank v.ResidueField w.ResidueField W.ResidueField).symm
+
+end S_AlgebraicCurve_Place_inertiaDegAlong_comp
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_inertiaDegAlong_comp (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.inertiaDegAlong_comp {K F F' F'' : Type*} [Field K] [Field F]
+    [Field F'] [Field F''] [Algebra K F] [Algebra K F'] [Algebra K F''] (φ : F →ₐ[K] F')
+    (χ : F' →ₐ[K] F'') (hφ : φ.toRingHom.IsIntegral) (hχ : χ.toRingHom.IsIntegral)
+    (hχφ : (χ.comp φ).toRingHom.IsIntegral) (W : Place K F'') :
+    W.inertiaDegAlong (χ.comp φ) hχφ = W.inertiaDegAlong χ hχ * (W.restrictAlong χ
+      hχ).inertiaDegAlong φ hφ :=
+  solution φ χ hφ hχ hχφ W
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_inertiaDeg_eq_of_restrict_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_inertiaDeg_eq_of_restrict_eq.lean
new file mode 100644
index 0000000000..71daecb034
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_inertiaDeg_eq_of_restrict_eq.lean
@@ -0,0 +1,119 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.inertiaDeg_eq_of_restrict_eq
+(2babbc8b-41e2-5c0f-acf6-9e3403240472) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b56f5bef-a420-5ab3-9a1c-8a4dd8a8dd24
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import Mathlib.FieldTheory.Galois.Basic
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_algEquiv_smul_eq_of_restrict_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_SemilinearAut_inertiaDeg_smul
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Inertia degree is constant on a Galois fibre
+
+Theorem statement: `AlgebraicCurve.Place.inertiaDeg_eq_of_restrict_eq`
+(`2babbc8b-41e2-5c0f-acf6-9e3403240472`), by Claude, 2026-09-05.
+
+Proof: submission `b56f5bef-a420-5ab3-9a1c-8a4dd8a8dd24`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F'$ and $M$ be fields with $F'$ and $M$ algebras over $K$ and $M$ an algebra over $F'$,
+the three structures forming a scalar tower, and assume $M$ is finite-dimensional over $F'$ and
+$M/F'$ is Galois. Let $W$ and $W'$ be places of $M$ over $K$, that is, valuation subrings of $M$
+that contain the image of $K$ under the structure map, are distinct from $M$ itself, and are
+principal ideal rings. The hypothesis is that $W$ and $W'$ have the same restriction to $F'$: the
+preimages of their valuation subrings under $\mathrm{algebraMap}\,F'\,M$, regarded as places of $F'$
+over $K$, coincide. The conclusion is the equality of the two inertia degrees over $F'$, where the
+inertia degree of a place $w$ of $M$ over $F'$ is the dimension of the residue field of the local
+ring $w$ as a vector space over the residue field of the restricted place $w|_{F'}$; thus
+$f(W'|_{F'}) = f(W|_{F'})$ as natural numbers.
+
+This is the classical constancy of the residue (inertia) degree among the places of $M$ lying over a
+fixed place of $F'$ when $M/F'$ is finite Galois. It feeds the fundamental identity relating the
+number of places in a fibre, the ramification indices and the inertia degrees, used in
+[`AlgebraicCurve.Place.card_fiberOver_mul_ramificationIndex_mul_inertiaDeg`]
+(thm.html#AlgebraicCurve.Place.card_fiberOver_mul_ramificationIndex_mul_inertiaDeg)
+and in the two summation formulas over bifibres.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_inertiaDeg_eq_of_restrict_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_inertiaDeg_eq_of_restrict_eq
+
+noncomputable section
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_Place_inertiaDeg_eq_of_restrict_eq.AlgebraicCurve \
+  IsDedekindDomain"
+open scoped Pointwise
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "SemilinearAut.IntertwinesAlong Place SemilinearAut \
+  SemilinearAut.ofAlgAut SemilinearAut.ofAlgAut_smul Place.exists_algEquiv_smul_eq_of_restrict_eq \
+  SemilinearAut.inertiaDeg_smul"
+p2m_open "AlgebraicCurve"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrict inertiaDeg exists_algEquiv_smul_eq_of_restrict_eq"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F' M : Type*} [Field K] [Field F'] [Field M] [Algebra K F'] [Algebra K M]
+  [Algebra F' M] [IsScalarTower K F' M]
+
+private theorem intertwinesAlong_one_ofAlgAut (σ : M ≃ₐ[F'] M) :
+    SemilinearAut.IntertwinesAlong (algebraMap F' M) (1 : SemilinearAut K F')
+      (SemilinearAut.ofAlgAut (σ.restrictScalars K)) := by
+  intro x
+  rw [one_smul, SemilinearAut.ofAlgAut_smul]
+  exact σ.commutes x
+
+end Place
+end AlgebraicCurve
+
+open _root_.AlgebraicCurve.Place
+  _root_.P2MW.S_AlgebraicCurve_Place_inertiaDeg_eq_of_restrict_eq.AlgebraicCurve.Place in
+theorem solution {K F' M : Type*} [Field K] [Field F'] [Field M]
+    [Algebra K F'] [Algebra K M] [Algebra F' M] [IsScalarTower K F' M]
+    [FiniteDimensional F' M] [IsGalois F' M] (W W' : Place K M)
+    (h : W'.restrict F' = W.restrict F') :
+    W'.inertiaDeg F' = W.inertiaDeg F' := by
+  obtain ⟨σ, rfl⟩ := Place.exists_algEquiv_smul_eq_of_restrict_eq W W' h
+  exact SemilinearAut.inertiaDeg_smul (intertwinesAlong_one_ofAlgAut σ) W
+
+end
+
+end S_AlgebraicCurve_Place_inertiaDeg_eq_of_restrict_eq
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_inertiaDeg_eq_of_restrict_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.inertiaDeg_eq_of_restrict_eq {K F' M : Type*} [Field K] [Field F']
+    [Field M]
+    [Algebra K F'] [Algebra K M] [Algebra F' M] [IsScalarTower K F' M]
+    [FiniteDimensional F' M] [IsGalois F' M] (W W' : Place K M)
+    (h : W'.restrict F' = W.restrict F') :
+    W'.inertiaDeg F' = W.inertiaDeg F' :=
+  solution W W' h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_inertiaDeg_pos.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_inertiaDeg_pos.lean
new file mode 100644
index 0000000000..3db9673fb2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_inertiaDeg_pos.lean
@@ -0,0 +1,272 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.inertiaDeg_pos
+(7614ce49-81bf-51f5-87f1-54b3c626d731) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 58519134-d19c-5df4-a806-85bf825d1f03
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_nonneg_of_mem
+import Mathlib.NumberTheory.RamificationInertia.Inertia
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Positivity of the inertia degree f(w∣ v)
+
+Theorem statement: `AlgebraicCurve.Place.inertiaDeg_pos` (`7614ce49-81bf-51f5-87f1-54b3c626d731`),
+by Claude, 2026-09-05.
+
+Proof: submission `58519134-d19c-5df4-a806-85bf825d1f03`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $F'$ be fields with $F$ and $F'$ algebras over $K$ and $F'$ an algebra over $F$, the
+three structures forming a scalar tower, and assume that $F'$ is finite-dimensional and separable
+over $F$. Let $w$ be a place of $F'$ over $K$ in the sense of the project, that is, a valuation
+subring $\mathcal{O}_w \subseteq F'$ containing $\mathrm{algebraMap}\,K\,F'(a)$ for every $a \in K$,
+different from the whole of $F'$, and whose ideals are all principal. Write $v =
+w.\mathrm{restrict}\,F$ for the place of $F$ over $K$ whose valuation subring is the preimage
+$\mathcal{O}_w \cap F$ of $\mathcal{O}_w$ under $\mathrm{algebraMap}\,F\,F'$, and let $\kappa(w)$
+and $\kappa(v)$ denote the residue fields of the local rings $\mathcal{O}_w$ and $\mathcal{O}_w \cap
+F$. The assertion is that the inertia degree $w.\mathrm{inertiaDeg}\,F$, defined as the
+$\kappa(v)$-rank of $\kappa(w)$, is strictly positive; equivalently, $\kappa(w)$ is a
+finite-dimensional nonzero $\kappa(v)$-vector space, so that the rank is not the default value $0$
+assigned to infinite-dimensional modules.
+
+This is the standard fact that the residue (inertia) degree $f(w\mid v)$ of a place in a finite
+separable extension is finite and at least $1$. It serves as bookkeeping for the counting identity
+$\sum_i e_i f_i = [F':F]$ and is used by the lemmas computing ramification indices of places from
+divisibility properties of valuations.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_inertiaDeg_pos.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_inertiaDeg_pos
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.fiberCenter_liesOver Place"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "mem_maximalIdeal_iff_ord_pos center integralClosureAt \
+  forall_mem_of_restrict_eq fiberCenter mem_fiberCenter_iff_ord_pos \
+  toValuationSubring_eq_of_restrict_eq fiberCenter_liesOver restrict restrictInclusion \
+  restrictResidueMap inertiaDeg ext ResidueField ord ord_mul ord_inv toValuationSubring mk \
+  ord_nonneg_of_mem"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+section ResidueDictionary
+
+variable {v : Place K F} {w : Place K F'}
+
+private def toValuationSubringOfRestrictEq (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.toValuationSubring :=
+  (algebraMap (integralClosureAt F' v) F').codRestrict
+    w.toValuationSubring.toSubring (forall_mem_of_restrict_eq hw)
+
+omit [FiniteDimensional F F'] in
+@[scoped simp]
+private theorem coe_toValuationSubringOfRestrictEq (hw : w.restrict F = v)
+    (c : integralClosureAt F' v) :
+    (toValuationSubringOfRestrictEq hw c : F')
+      = algebraMap (integralClosureAt F' v) F' c := rfl
+
+private def residueOfCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.ResidueField :=
+  (IsLocalRing.residue w.toValuationSubring).comp (toValuationSubringOfRestrictEq hw)
+
+omit [FiniteDimensional F F'] in
+private theorem residueOfCenter_apply (hw : w.restrict F = v) (c : integralClosureAt F' v) :
+    residueOfCenter hw c = IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw c) := rfl
+
+private theorem ker_residueOfCenter (hw : w.restrict F = v) :
+    RingHom.ker (residueOfCenter hw) = (fiberCenter F' v hw).asIdeal := by
+  ext c
+  rw [RingHom.mem_ker, residueOfCenter_apply, IsLocalRing.residue_eq_zero_iff]
+  exact Iff.rfl
+
+private theorem surjective_residueOfCenter (hw : w.restrict F = v) :
+    Function.Surjective (residueOfCenter hw) := by
+  classical
+  intro y
+  obtain ⟨x, rfl⟩ := IsLocalRing.residue_surjective y
+  have hx : (x : F') ∈ HeightOneSpectrum.valuationSubringAtPrime F' (fiberCenter F' v hw) := by
+    rw [← toValuationSubring_eq_of_restrict_eq hw]
+    exact x.2
+  obtain ⟨a, s, hs, hxas⟩ := hx
+  have hsP : s ∉ (fiberCenter F' v hw).asIdeal := hs
+  have hs0 : s ≠ 0 := fun h => hsP (h ▸ (fiberCenter F' v hw).asIdeal.zero_mem)
+  have hsF : algebraMap (integralClosureAt F' v) F' s ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hs0
+  have hsord : w.ord (algebraMap (integralClosureAt F' v) F' s) = 0 := by
+    have h1 : ¬ 0 < w.ord (algebraMap (integralClosureAt F' v) F' s) := by
+      rw [← mem_fiberCenter_iff_ord_pos hw hs0]
+      exact hsP
+    have h2 : 0 ≤ w.ord (algebraMap (integralClosureAt F' v) F' s) :=
+      w.ord_nonneg_of_mem (forall_mem_of_restrict_eq hw s)
+    omega
+  have hmax : (fiberCenter F' v hw).asIdeal.IsMaximal :=
+    (fiberCenter F' v hw).isPrime.isMaximal (fiberCenter F' v hw).ne_bot
+  obtain ⟨t, i, hi, hti⟩ := hmax.exists_inv hsP
+  have hst : s * t - 1 ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : s * t - 1 = -i := by linear_combination hti
+    rw [h1]
+    exact neg_mem hi
+  refine ⟨a * t, ?_⟩
+  rw [residueOfCenter_apply, ← sub_eq_zero, ← map_sub, IsLocalRing.residue_eq_zero_iff]
+  have hcoe : ((toValuationSubringOfRestrictEq hw (a * t) - x : w.toValuationSubring) : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') := rfl
+  rcases eq_or_ne (toValuationSubringOfRestrictEq hw (a * t) - x) 0 with hzero | hne
+  · rw [hzero]
+    exact (IsLocalRing.maximalIdeal w.toValuationSubring).zero_mem
+  have hcoene : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') ≠ 0 := by
+    intro h
+    exact hne (by rwa [← hcoe, ZeroMemClass.coe_eq_zero] at h)
+  have hfactor : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t * s - a)
+          * (algebraMap (integralClosureAt F' v) F' s)⁻¹ := by
+    rw [hxas, map_sub, map_mul (algebraMap (integralClosureAt F' v) F') (a * t) s,
+      sub_mul, mul_assoc, mul_inv_cancel₀ hsF, mul_one]
+  have hdiffC : a * t * s - a ≠ 0 := by
+    intro h
+    apply hcoene
+    rw [hfactor, h, map_zero, zero_mul]
+  have hdiffP : a * t * s - a ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : a * t * s - a = a * (s * t - 1) := by ring
+    rw [h1]
+    exact Ideal.mul_mem_left _ _ hst
+  have hmem' : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      ∈ w.toValuationSubring := by
+    rw [← hcoe]
+    exact Subtype.coe_prop _
+  rw [show (toValuationSubringOfRestrictEq hw (a * t) - x)
+      = (⟨_, hmem'⟩ : w.toValuationSubring) from Subtype.ext hcoe,
+    w.mem_maximalIdeal_iff_ord_pos hcoene hmem']
+  rw [hfactor, w.ord_mul (by
+      simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hdiffC)
+    (inv_ne_zero hsF), w.ord_inv, hsord, neg_zero, add_zero]
+  exact (mem_fiberCenter_iff_ord_pos hw hdiffC).mp hdiffP
+
+private def residueFieldEquivQuotientCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v ⧸ (fiberCenter F' v hw).asIdeal ≃+* w.ResidueField :=
+  (Ideal.quotEquivOfEq (ker_residueOfCenter hw).symm).trans
+    ((residueOfCenter hw).quotientKerEquivOfSurjective (surjective_residueOfCenter hw))
+
+private theorem residueFieldEquivQuotientCenter_mk (hw : w.restrict F = v)
+    (c : integralClosureAt F' v) :
+    residueFieldEquivQuotientCenter hw (Ideal.Quotient.mk _ c) = residueOfCenter hw c := by
+  change ((residueOfCenter hw).quotientKerEquivOfSurjective (surjective_residueOfCenter hw))
+    ((Ideal.quotEquivOfEq (ker_residueOfCenter hw).symm) (Ideal.Quotient.mk _ c))
+      = residueOfCenter hw c
+  rw [Ideal.quotEquivOfEq_mk]
+  exact RingHom.quotientKerEquivOfSurjective_apply_mk _ c
+
+private def placeCongrEquiv {u u' : Place K F} (h : u = u') :
+    u.toValuationSubring ≃+* u'.toValuationSubring where
+  toFun x := ⟨x.1, h ▸ x.2⟩
+  invFun x := ⟨x.1, h.symm ▸ x.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  map_mul' _ _ := rfl
+  map_add' _ _ := rfl
+
+@[scoped simp]
+private theorem coe_placeCongrEquiv {u u' : Place K F} (h : u = u') (x : u.toValuationSubring) :
+    (placeCongrEquiv h x : F) = (x : F) := rfl
+
+private def restrictResidueFieldEquiv (hw : w.restrict F = v) :
+    (w.restrict F).ResidueField ≃+* IsLocalRing.ResidueField v.toValuationSubring :=
+  IsLocalRing.ResidueField.mapEquiv (placeCongrEquiv hw)
+
+omit [FiniteDimensional F F'] in
+private theorem restrictResidueFieldEquiv_residue (hw : w.restrict F = v)
+    (a : (w.restrict F).toValuationSubring) :
+    restrictResidueFieldEquiv hw (IsLocalRing.residue _ a)
+      = IsLocalRing.residue _ (placeCongrEquiv hw a) := by
+  simp only [restrictResidueFieldEquiv, IsLocalRing.ResidueField.mapEquiv_apply,
+    IsLocalRing.ResidueField.map_residue, RingEquiv.coe_toRingHom]
+
+private theorem inertiaDeg_eq_inertiaDeg_fiberCenter (hw : w.restrict F = v) :
+    w.inertiaDeg F =
+      (fiberCenter F' v hw).asIdeal.inertiaDeg v.toValuationSubring := by
+  have := fiberCenter_liesOver hw
+  rw [Ideal.inertiaDeg_eq_of_isMaximal (IsLocalRing.maximalIdeal v.toValuationSubring)
+    (fiberCenter F' v hw).asIdeal]
+  change Module.finrank (w.restrict F).ResidueField w.ResidueField = _
+  refine Algebra.finrank_eq_of_equiv_equiv (restrictResidueFieldEquiv hw)
+    (residueFieldEquivQuotientCenter hw).symm ?_
+  ext a
+  obtain ⟨a, rfl⟩ := IsLocalRing.residue_surjective a
+  simp only [RingHom.coe_comp, Function.comp_apply, RingEquiv.toRingHom_eq_coe,
+    RingHom.coe_coe]
+  apply (residueFieldEquivQuotientCenter hw).injective
+  rw [RingEquiv.apply_symm_apply]
+  change IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw
+        (algebraMap v.toValuationSubring (integralClosureAt F' v) (placeCongrEquiv hw a)))
+    = IsLocalRing.residue w.toValuationSubring (restrictInclusion F w a)
+  refine congrArg _ (Subtype.ext ?_)
+  change algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) (placeCongrEquiv hw a))
+    = algebraMap F F' (a : F)
+  rw [← IsScalarTower.algebraMap_apply,
+    IsScalarTower.algebraMap_apply v.toValuationSubring F F']
+  rfl
+
+end ResidueDictionary
+
+end Place
+end AlgebraicCurve
+end
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_Place_inertiaDeg_pos.AlgebraicCurve"
+
+theorem solution {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+    [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+    (w : Place K F') :
+    0 < w.inertiaDeg F := by
+  have := Place.fiberCenter_liesOver (F' := F') (v := w.restrict F) rfl
+  rw [Place.inertiaDeg_eq_inertiaDeg_fiberCenter rfl]
+  exact Ideal.inertiaDeg_pos _ _
+
+end S_AlgebraicCurve_Place_inertiaDeg_pos
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_inertiaDeg_pos (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.inertiaDeg_pos {K F F' : Type*} [Field K] [Field F] [Field F']
+    [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F']
+    [Algebra.IsSeparable F F'] (w : Place K F') :
+    0 < w.inertiaDeg F :=
+  solution w
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_inertiaDeg_pos_of_finiteDimensional.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_inertiaDeg_pos_of_finiteDimensional.lean
new file mode 100644
index 0000000000..b22bdda26c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_inertiaDeg_pos_of_finiteDimensional.lean
@@ -0,0 +1,162 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.inertiaDeg_pos_of_finiteDimensional
+(544f298e-a487-51ba-87ff-8c1c72d2b416) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8fb7cb25-7415-529e-b771-2c3bb33dc290
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Positivity of the inertia degree in a finite extension
+
+Theorem statement: `AlgebraicCurve.Place.inertiaDeg_pos_of_finiteDimensional`
+(`544f298e-a487-51ba-87ff-8c1c72d2b416`), by Claude, 2026-09-05.
+
+Proof: submission `8fb7cb25-7415-529e-b771-2c3bb33dc290`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $F'$ be fields with $F$ and $F'$ algebras over $K$ and $F'$ an algebra over $F$, the
+three structures forming a scalar tower, and assume $F'$ is finite-dimensional over $F$. Let $w$ be
+a place of $F'$ over $K$ in the sense of the project, that is a valuation subring $\mathcal{O}_w
+\subseteq F'$ containing the image of $K$ under the structure map, different from all of $F'$, and
+whose underlying ring is a principal ideal ring. Its restriction $w|_F$ is the place of $F$ over $K$
+whose valuation subring is the preimage $\mathcal{O}_w \cap F$ of $\mathcal{O}_w$ under the
+structure map $F \to F'$, and the inertia degree $f(w/w|_F)$ is defined as the
+$\mathrm{Module.finrank}$ of the residue field $\mathcal{O}_w/\mathfrak{m}_w$ of $w$ regarded as a
+module over the residue field of $w|_F$. The assertion is that this natural number is strictly
+positive. Since `Module.finrank` takes the value $0$ on modules that are not finitely generated free
+of finite rank, the content is that the residue extension $\kappa(w)/\kappa(w|_F)$ is
+finite-dimensional; no separability hypothesis is imposed.
+
+This is the residue-degree half of the fundamental inequality for places in a finite extension of
+fields: the residue field of $w$ is finite over that of its restriction, so the inertia degree is
+not the junk value $0$. Together with the tower formula relating the degree of $w$ to $f(w/w|_F)$
+and the degree of $w|_F$, it is used in the divisor theory of curves over $K$, for instance by
+[`AlgebraicCurve.Place.deg_ne_zero_of_finiteDimensional_adjoin`]
+(thm.html#AlgebraicCurve.Place.deg_ne_zero_of_finiteDimensional_adjoin)
+and
+[`AlgebraicCurve.Place.eq_of_finrank_lt_two_mul_ramificationIndex`]
+(thm.html#AlgebraicCurve.Place.eq_of_finrank_lt_two_mul_ramificationIndex).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_inertiaDeg_pos_of_finiteDimensional.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_inertiaDeg_pos_of_finiteDimensional
+
+open AlgebraicCurve
+
+namespace S09G2
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+  [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F']
+
+open IsLocalRing in
+theorem linearIndependent_lift (w : Place K F') {ι : Type*} [Finite ι]
+    (x : ι → w.toValuationSubring)
+    (hx : LinearIndependent (w.restrict F).ResidueField
+      fun i => (residue w.toValuationSubring (x i) : w.ResidueField)) :
+    LinearIndependent F fun i => ((x i : w.toValuationSubring) : F') := by
+  classical
+  let := Fintype.ofFinite ι
+  rw [Fintype.linearIndependent_iff]
+  intro g hg
+  by_contra hne
+  obtain ⟨i₀, hi₀⟩ : ∃ i, g i ≠ 0 := not_forall.mp hne
+  set O : ValuationSubring F := (w.restrict F).toValuationSubring
+  have hne' : (Finset.univ.filter fun i => g i ≠ 0).Nonempty := ⟨i₀, by simpa using hi₀⟩
+  obtain ⟨k, hk, hkmax⟩ := Finset.exists_max_image _ (fun i => O.valuation (g i)) hne'
+  have hgk : g k ≠ 0 := by simpa using hk
+  have hb : ∀ i, g i / g k ∈ O := by
+    intro i
+    by_cases hi : g i = 0
+    · simp [hi]
+    · apply O.mem_of_valuation_le_one
+      rw [map_div₀]
+      have hk0 : (0 : O.ValueGroup) < O.valuation (g k) := by
+        rw [zero_lt_iff]; exact (map_ne_zero _).mpr hgk
+      exact (div_le_one₀ hk0).mpr (hkmax i (by simpa using hi))
+  let b : ι → O := fun i => ⟨g i / g k, hb i⟩
+  have hrel : ∑ i, Place.restrictInclusion F w (b i) * x i = 0 := by
+    apply Subtype.ext
+    have hcoe : ((∑ i, Place.restrictInclusion F w (b i) * x i : w.toValuationSubring) : F') =
+        ∑ i, algebraMap F F' (g i / g k) * (x i : F') := by
+      rw [AddSubmonoidClass.coe_finsetSum]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [MulMemClass.coe_mul, Place.coe_restrictInclusion]
+    rw [hcoe]
+    have : ∑ i, algebraMap F F' (g i / g k) * (x i : F') =
+        algebraMap F F' (g k)⁻¹ * ∑ i, g i • ((x i : w.toValuationSubring) : F') := by
+      rw [Finset.mul_sum]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [Algebra.smul_def, div_eq_inv_mul, map_mul, mul_assoc]
+    rw [this, hg, mul_zero]
+    rfl
+  have hres : ∑ i, (residue O (b i) : (w.restrict F).ResidueField) •
+      (residue w.toValuationSubring (x i) : w.ResidueField) = 0 := by
+    have h := congrArg (residue w.toValuationSubring) hrel
+    rw [map_sum, map_zero] at h
+    rw [← h]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [Algebra.smul_def, Place.algebraMap_residueField_eq, Place.restrictResidueMap_residue,
+      map_mul]
+  have hk1 := (Fintype.linearIndependent_iff.mp hx) _ hres k
+  have hbk : b k = 1 := Subtype.ext (div_self hgk)
+  rw [hbk, map_one] at hk1
+  exact one_ne_zero hk1
+
+open IsLocalRing in
+theorem finite_residueField (w : Place K F') :
+    Module.Finite (w.restrict F).ResidueField w.ResidueField := by
+  classical
+  rw [← Module.rank_lt_aleph0_iff]
+  refine lt_of_le_of_lt (rank_le (n := Module.finrank F F') fun s hs => ?_)
+    Cardinal.natCast_lt_aleph0
+  choose x hx using fun y : s => residue_surjective (R := w.toValuationSubring) (y : w.ResidueField)
+  have hs' : LinearIndependent (w.restrict F).ResidueField
+      fun i : s => (residue w.toValuationSubring (x i) : w.ResidueField) := by
+    simpa only [hx] using hs
+  have := linearIndependent_lift (F := F) w x hs'
+  simpa [Fintype.card_coe] using this.fintype_card_le_finrank
+
+end S09G2
+
+theorem solution {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+    [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F'] (w : Place K F') :
+    0 < w.inertiaDeg F := by
+  have := S09G2.finite_residueField (F := F) w
+  exact Module.finrank_pos
+
+end S_AlgebraicCurve_Place_inertiaDeg_pos_of_finiteDimensional
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_inertiaDeg_pos_of_finiteDimensional (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.inertiaDeg_pos_of_finiteDimensional {K F F' : Type*} [Field K]
+    [Field F] [Field F'] [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+    [FiniteDimensional F F'] (w : Place K F') :
+    0 < w.inertiaDeg F :=
+  solution w
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_isRational_iff_deg_eq_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_isRational_iff_deg_eq_one.lean
new file mode 100644
index 0000000000..7002cc83fb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_isRational_iff_deg_eq_one.lean
@@ -0,0 +1,92 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.isRational_iff_deg_eq_one
+(1af570e5-1c20-5298-9e2d-bff0496b3ec8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2f628728-a3b9-545a-bd76-d6a8c1eb215d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A place is rational iff its degree is 1
+
+Theorem statement: `AlgebraicCurve.Place.isRational_iff_deg_eq_one`
+(`1af570e5-1c20-5298-9e2d-bff0496b3ec8`), by Claude, 2026-09-05.
+
+Proof: submission `2f628728-a3b9-545a-bd76-d6a8c1eb215d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+sense of the project: a valuation subring $\mathcal{O}_v \subseteq F$ that contains the image of $K$
+under the structure map, is not the whole of $F$, and is a principal ideal ring. Write $\kappa(v)$
+for the residue field of the local ring $\mathcal{O}_v$, and let $\deg v$ be the $K$-dimension
+$\operatorname{finrank}_K \kappa(v)$ of $\kappa(v)$ as a $K$-module (which is $0$ by the Mathlib
+convention when this dimension is infinite). The theorem asserts the equivalence: the structure map
+$K \to \kappa(v)$ is surjective (the project's notion of $v$ being rational) if and only if $\deg v
+= 1$. In particular the degree-one condition already forces $\kappa(v)$ to be finite-dimensional
+over $K$, so no separate finiteness hypothesis occurs.
+
+This is the standard characterisation of the rational (degree-one) places of a function field $F/K$,
+as in the basic theory of places and their residue class fields. It belongs to the
+evaluation-of-functions layer underlying divisors, Weil reciprocity and the divisorial Weil pairing,
+and is invoked throughout that development whenever rational places are identified with places of
+degree $1$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_isRational_iff_deg_eq_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_isRational_iff_deg_eq_one
+
+open AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) :
+    v.IsRational ↔ v.deg = 1 := by
+  constructor
+  · intro hv
+    have hbij : Function.Bijective (algebraMap K v.ResidueField) :=
+      ⟨v.algebraMap_residueField_injective, hv⟩
+    change Module.finrank K v.ResidueField = 1
+    rw [← Module.finrank_self K]
+    exact ((AlgEquiv.ofBijective (Algebra.ofId K v.ResidueField)
+      hbij).toLinearEquiv.finrank_eq).symm
+  · intro h x
+    have hbot : (⊥ : Subalgebra K v.ResidueField) = ⊤ :=
+      Subalgebra.bot_eq_top_iff_finrank_eq_one.mpr h
+    have hx : x ∈ (⊥ : Subalgebra K v.ResidueField) := by
+      rw [hbot]
+      exact Algebra.mem_top
+    exact Algebra.mem_bot.mp hx
+
+end S_AlgebraicCurve_Place_isRational_iff_deg_eq_one
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_isRational_iff_deg_eq_one (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.isRational_iff_deg_eq_one {K F : Type*} [Field K] [Field F]
+    [Algebra K F] (v : Place K F) :
+    v.IsRational ↔ v.deg = 1 :=
+  solution v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_isRational_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_isRational_of_isAlgClosed.lean
new file mode 100644
index 0000000000..efe4840611
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_isRational_of_isAlgClosed.lean
@@ -0,0 +1,179 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.isRational_of_isAlgClosed
+(e4c82b93-d311-5480-b6bd-5d53a5bfc0a1) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2c696e4d-d10a-5f5f-92be-b714830c6b80
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+
+import Mathlib.Algebra.BigOperators.Field
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_isRational_iff_deg_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Places of a function field over an algebraically closed constant field are rational
+
+Theorem statement: `AlgebraicCurve.Place.isRational_of_isAlgClosed`
+(`e4c82b93-d311-5480-b6bd-5d53a5bfc0a1`), by Claude, 2026-09-05.
+
+Proof: submission `2c696e4d-d10a-5f5f-92be-b714830c6b80`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field and let $F$ be a field carrying both a $K$-algebra
+structure and a $\mathrm{RatFunc}\,K$-algebra structure, compatible in the sense that $K \to
+\mathrm{RatFunc}\,K \to F$ is a scalar tower, and such that $F$ is finite-dimensional as a
+$\mathrm{RatFunc}\,K$-vector space; thus $F$ is a finite extension of the rational function field
+$K(t)$ with $K$ as constant field. Let $v$ be a place of $F$ over $K$, that is, the data of a
+valuation subring $\mathcal{O}_v = v.\mathtt{toValuationSubring}$ of $F$ which contains the image of
+$K$ under the structure map, is not the whole of $F$, and is a principal ideal ring. The assertion
+is that $v$ is rational in the sense of the project predicate `IsRational`: the structure map from
+$K$ to the residue field of the local ring $\mathcal{O}_v$ is surjective, i.e. every residue class
+is represented by a constant, so the residue field of $v$ is exhausted by $K$.
+
+This is the classical fact that over an algebraically closed constant field every place of a
+function field has degree one; it makes all rationality-of-support hypotheses in the theory of
+evaluation of functions at places and of Weil reciprocity automatic in the geometric setting. It is
+used throughout the divisor-theoretic and Weil-pairing parts of the development, for instance by
+[`AlgebraicCurve.Divisor.mapDomain_placeReduction_eq_ord_of_retraction`]
+(thm.html#AlgebraicCurve.Divisor.mapDomain_placeReduction_eq_ord_of_retraction)
+and by the injectivity statements for the divisorial Weil pairing.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_isRational_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_isRational_of_isAlgClosed
+
+open AlgebraicCurve Polynomial
+
+theorem solution {K F : Type*} [Field K] [IsAlgClosed K] [Field F] [Algebra K F]
+    [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F] [FiniteDimensional (RatFunc K) F]
+    (v : Place K F) :
+    v.IsRational := by
+  classical
+  intro y
+  obtain ⟨x, rfl⟩ := IsLocalRing.residue_surjective y
+  let u : Place K (RatFunc K) := v.restrict (RatFunc K)
+  have hu : u.IsRational :=
+    (AlgebraicCurve.Place.isRational_iff_deg_eq_one u).2
+      (AlgebraicCurve.RationalFunctionField.deg_eq_one_of_isAlgClosed K u)
+  have hconst : ∀ {b : RatFunc K} (hb : algebraMap (RatFunc K) F b ∈ v.toValuationSubring),
+      ∃ c : K, algebraMap K v.ResidueField c
+        = IsLocalRing.residue _ (⟨algebraMap (RatFunc K) F b, hb⟩ : v.toValuationSubring) := by
+    intro b hb
+    have hb' : b ∈ u.toValuationSubring := ValuationSubring.mem_comap.mpr hb
+    refine ⟨u.evalAt b, ?_⟩
+    have h1 : algebraMap K u.ResidueField (u.evalAt b) = IsLocalRing.residue _ ⟨b, hb'⟩ :=
+      u.algebraMap_evalAt hu hb'
+    have h2 : (⟨algebraMap (RatFunc K) F b, hb⟩ : v.toValuationSubring)
+        = Place.restrictInclusion (RatFunc K) v ⟨b, hb'⟩ := rfl
+    rw [h2, ← Place.restrictResidueMap_residue, ← h1, ← Place.algebraMap_residueField_eq,
+      ← IsScalarTower.algebraMap_apply]
+  obtain ⟨p, hp0, hpx⟩ : IsAlgebraic (RatFunc K) (x : F) := Algebra.IsAlgebraic.isAlgebraic _
+  have hsupp : p.support.Nonempty := Polynomial.support_nonempty.mpr hp0
+  obtain ⟨j, hj, hjmin⟩ := p.support.exists_min_image
+    (fun i => v.ord (algebraMap (RatFunc K) F (p.coeff i))) hsupp
+  have haj0 : p.coeff j ≠ 0 := Polynomial.mem_support_iff.mp hj
+  have hajF : algebraMap (RatFunc K) F (p.coeff j) ≠ 0 :=
+    (map_ne_zero_iff _ (algebraMap (RatFunc K) F).injective).mpr haj0
+  have hbmem : ∀ i, algebraMap (RatFunc K) F (p.coeff i / p.coeff j) ∈ v.toValuationSubring := by
+    intro i
+    by_cases hi : i ∈ p.support
+    · have hai0 : p.coeff i ≠ 0 := Polynomial.mem_support_iff.mp hi
+      have haiF : algebraMap (RatFunc K) F (p.coeff i) ≠ 0 :=
+        (map_ne_zero_iff _ (algebraMap (RatFunc K) F).injective).mpr hai0
+      rw [map_div₀]
+      refine v.mem_of_ord_nonneg (div_ne_zero haiF hajF) ?_
+      rw [div_eq_mul_inv, v.ord_mul haiF (inv_ne_zero hajF), v.ord_inv]
+      have := hjmin i hi
+      omega
+    · rw [Polynomial.notMem_support_iff.mp hi, zero_div, map_zero]
+      exact zero_mem _
+  have haeval : ∀ (q : (RatFunc K)[X]) (z : F),
+      aeval z q = ∑ i ∈ q.support, algebraMap (RatFunc K) F (q.coeff i) * z ^ i := by
+    intro q z
+    conv_lhs => rw [q.as_sum_support]
+    simp [map_sum, ← C_mul_X_pow_eq_monomial]
+  have hrel : ∑ i ∈ p.support,
+      algebraMap (RatFunc K) F (p.coeff i / p.coeff j) * (x : F) ^ i = 0 := by
+    have hsum : ∑ i ∈ p.support, algebraMap (RatFunc K) F (p.coeff i) * (x : F) ^ i = 0 := by
+      rw [← haeval, hpx]
+    have hfac : ∑ i ∈ p.support, algebraMap (RatFunc K) F (p.coeff i / p.coeff j) * (x : F) ^ i
+        = (∑ i ∈ p.support, algebraMap (RatFunc K) F (p.coeff i) * (x : F) ^ i)
+            / algebraMap (RatFunc K) F (p.coeff j) := by
+      rw [Finset.sum_div]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [map_div₀]
+      ring
+    rw [hfac, hsum, zero_div]
+  set B : ℕ → v.toValuationSubring := fun i => ⟨_, hbmem i⟩ with hB
+  have hrelO : ∑ i ∈ p.support, B i * x ^ i = 0 := by
+    apply Subtype.ext
+    simp only [AddSubmonoidClass.coe_finsetSum, MulMemClass.coe_mul, SubmonoidClass.coe_pow,
+      ZeroMemClass.coe_zero, hB]
+    exact hrel
+  choose c hc using fun i => hconst (hbmem i)
+  have hcj : c j = 1 := by
+    have h1 : (B j) = 1 := Subtype.ext (by simp [hB, haj0])
+    have := hc j
+    rw [show (⟨_, hbmem j⟩ : v.toValuationSubring) = B j from rfl, h1, map_one] at this
+    exact (algebraMap K v.ResidueField).injective (by rw [this, map_one])
+  set R : K[X] := ∑ i ∈ p.support, C (c i) * X ^ i with hR
+  have hRy : aeval (IsLocalRing.residue v.toValuationSubring x) R = 0 := by
+    have h := congrArg (IsLocalRing.residue v.toValuationSubring) hrelO
+    rw [map_sum, map_zero] at h
+    simp only [map_mul, map_pow] at h
+    rw [hR, map_sum]
+    simp only [map_mul, map_pow, aeval_C, aeval_X]
+    rw [← h]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [hc i]
+  have hRj : R.coeff j = 1 := by
+    rw [hR, finsetSum_coeff]
+    simp only [coeff_C_mul_X_pow]
+    rw [Finset.sum_ite_eq p.support j, ite_eq_left hj, hcj]
+  have hR0 : R ≠ 0 := fun h => by
+    have := hRj
+    rw [h, coeff_zero] at this
+    exact zero_ne_one this
+  have halgy : IsAlgebraic K (IsLocalRing.residue v.toValuationSubring x) := ⟨R, hR0, hRy⟩
+  have hdeg : (minpoly K (IsLocalRing.residue v.toValuationSubring x)).degree = 1 :=
+    IsAlgClosed.degree_eq_one_of_irreducible K (minpoly.irreducible halgy.isIntegral)
+  obtain ⟨a, ha⟩ := minpoly.degree_eq_one_iff.mp hdeg
+  exact ⟨a, ha⟩
+
+end S_AlgebraicCurve_Place_isRational_of_isAlgClosed
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_isRational_of_isAlgClosed (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.isRational_of_isAlgClosed {K F : Type*} [Field K] [IsAlgClosed K]
+    [Field F] [Algebra K F] [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [FiniteDimensional (RatFunc K) F] (v : Place K F) :
+    v.IsRational :=
+  solution v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_isSeparable_adjoin_of_ord_eq_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_isSeparable_adjoin_of_ord_eq_one.lean
new file mode 100644
index 0000000000..b736a97f99
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_isSeparable_adjoin_of_ord_eq_one.lean
@@ -0,0 +1,485 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.isSeparable_adjoin_of_ord_eq_one
+(b6078803-65f8-5cf9-9134-c4cecb1eeb2a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 155ee009-1669-5776-af91-f2ddc9e25926
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+
+import Mathlib.FieldTheory.Relrank
+import Mathlib.RingTheory.Unramified.Field
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_transcendental_of_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isAlgebraic_adjoin_of_transcendental
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Elements of order one at a place are separating
+
+Theorem statement: `AlgebraicCurve.Place.isSeparable_adjoin_of_ord_eq_one`
+(`b6078803-65f8-5cf9-9134-c4cecb1eeb2a`), by Claude, 2026-09-05.
+
+Proof: submission `155ee009-1669-5776-af91-f2ddc9e25926`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and suppose $K$ is perfect. Assume given an
+element $x \in F$ such that $F$ is algebraic over the intermediate field $K(x)$ obtained by
+adjoining $x$ to $K$ inside $F$ — so $F$ is a function field of one variable over $K$ in this sense.
+Let $v$ be a place of $F$ over $K$ in the sense of the structure
+[`AlgebraicCurve.Place`](def/AlgebraicCurve_DivisorClassGroup.html#L22): a valuation subring of $F$
+containing the image of $K$ under the structure map, distinct from all of $F$, and whose underlying
+ring is a principal ideal ring. For $f \in F$ write $\operatorname{ord}_v f$ for the integer $-\log$
+of the value of $f$ under the $\mathbb{Z}^{m0}$-valued valuation attached to $v$ viewed as a point
+of the height-one spectrum, i.e. the normalised additive order of vanishing at $v$. Let $t \in F$
+satisfy $\operatorname{ord}_v t = 1$, that is, $t$ is a uniformiser at $v$. The conclusion is that
+$F$ is a separable algebra over the intermediate field $K(t)$ generated by $t$ over $K$.
+
+Classically this says that a uniformiser at a place of a function field of one variable over a
+perfect constant field is a separating element, the separability criterion behind the construction
+of differentials in positive characteristic. Within the development it is the source of separability
+for uniformisers, and is used by the results on the divisor $D$ and the differential coefficients
+attached to an element of order one at a place; its proof cites the transcendence over $K$ of
+elements of nonzero order and the fact that $F$ remains algebraic over $K(t)$ for transcendental
+$t$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_isSeparable_adjoin_of_ord_eq_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_isSeparable_adjoin_of_ord_eq_one
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place isAlgebraic_adjoin_of_transcendental"
+namespace SEPEngine
+p2m_open "AlgebraicCurve"
+
+open IntermediateField Polynomial
+
+private def frobeniusSubfield (M : Type*) [Field M] (p : ℕ) [ExpChar M p] : Subfield M :=
+  (frobenius M p).fieldRange
+
+private theorem mem_frobeniusSubfield_iff {M : Type*} [Field M] (p : ℕ) [ExpChar M p] {a : M} :
+    a ∈ frobeniusSubfield M p ↔ ∃ b : M, b ^ p = a := by
+  simp only [frobeniusSubfield, RingHom.mem_fieldRange, frobenius_def]
+
+private theorem pow_mem_frobeniusSubfield {M : Type*} [Field M] (p : ℕ) [ExpChar M p] (a : M) :
+    a ^ p ∈ frobeniusSubfield M p := (mem_frobeniusSubfield_iff p).mpr ⟨a, rfl⟩
+
+private def frobeniusRingEquivRange (M : Type*) [Field M] (p : ℕ) [ExpChar M p] :
+    M ≃+* frobeniusSubfield M p :=
+  RingEquiv.ofBijective (frobenius M p).rangeRestrict
+    ⟨fun _ _ h ↦ (frobenius M p).injective (Subtype.ext_iff.mp h),
+      (frobenius M p).rangeRestrict_surjective⟩
+
+private theorem frobeniusRingEquivRange_apply (M : Type*) [Field M] (p : ℕ) [ExpChar M p]
+    (a : M) : ((frobeniusRingEquivRange M p a : frobeniusSubfield M p) : M) = a ^ p := rfl
+
+section Transport
+
+variable {E M : Type*} [Field E] [Field M] [Algebra E M] (p : ℕ) [ExpChar E p] [ExpChar M p]
+
+private abbrev frobeniusSubfieldImageInM : Subfield M :=
+  (frobeniusSubfield E p).map (algebraMap E M)
+
+omit [ExpChar M p] in
+private theorem frobeniusSubfieldImageInM_le_algebraMapRange :
+    frobeniusSubfieldImageInM (E := E) (M := M) p ≤ (algebraMap E M).fieldRange :=
+  fun _ ⟨a, _, ha⟩ ↦ ⟨a, ha⟩
+
+private theorem frobeniusSubfieldImageInM_le_frobeniusSubfield :
+    frobeniusSubfieldImageInM (E := E) (M := M) p ≤ frobeniusSubfield M p := by
+  rintro _ ⟨_, ⟨b, rfl⟩, rfl⟩
+  exact ⟨algebraMap E M b, by simp only [frobenius_def, map_pow]⟩
+
+private theorem comap_frobenius_frobeniusSubfield :
+    (frobeniusSubfield M p).comap (frobenius M p) = ⊤ := by
+  ext x; constructor
+  · intro _; trivial
+  · intro _; exact ⟨x, rfl⟩
+
+private theorem comap_frobenius_frobeniusSubfieldImageInM :
+    (frobeniusSubfieldImageInM (E := E) (M := M) p).comap (frobenius M p) =
+      (algebraMap E M).fieldRange := by
+  ext x; constructor
+  · rintro ⟨_, ⟨b, rfl⟩, hb⟩
+    exact ⟨b, (frobenius M p).injective (by simpa only [frobenius_def, map_pow] using hb)⟩
+  · rintro ⟨e, rfl⟩
+    exact ⟨e ^ p, ⟨e, rfl⟩, by simp only [frobenius_def, map_pow]⟩
+
+private theorem finrank_algebraMapRange_eq :
+    Module.finrank (↥(algebraMap E M).fieldRange) M = Module.finrank E M := by
+  have h := lift_rank_eq_of_equiv_equiv (M := M) (M' := M)
+    (R := E) (R' := ↥(algebraMap E M).fieldRange)
+    (fun e ↦ (algebraMap E M).rangeRestrictFieldEquiv e) (AddEquiv.refl M)
+    (algebraMap E M).rangeRestrictFieldEquiv.bijective
+    (fun e m ↦ by
+      change e • m = ((algebraMap E M).rangeRestrictFieldEquiv e) • m
+      rw [Algebra.smul_def, Subfield.smul_def]
+      rfl)
+  simp only [Cardinal.lift_id] at h
+  exact congrArg Cardinal.toNat h.symm
+
+private theorem finrank_frobeniusSubfield_eq [FiniteDimensional E M]
+    [FiniteDimensional (frobeniusSubfield E p) E] :
+    Module.finrank (frobeniusSubfield M p) M = Module.finrank (frobeniusSubfield E p) E := by
+  set Mp : Subfield M := frobeniusSubfield M p with hMp
+  set Ep' : Subfield M := frobeniusSubfieldImageInM (E := E) (M := M) p with hEp'
+  set E' : Subfield M := (algebraMap E M).fieldRange with hE'
+  have hfrob : Subfield.relfinrank Ep' Mp = Subfield.relfinrank E' (⊤ : Subfield M) := by
+    have h1 := Subfield.relfinrank_comap_comap_eq_relfinrank_of_le (A := Ep') (B := Mp)
+      (frobenius M p) (by rw [hMp]; exact le_refl _)
+    rw [comap_frobenius_frobeniusSubfield, comap_frobenius_frobeniusSubfieldImageInM] at h1
+    exact h1.symm
+  have htowerE : Subfield.relfinrank Ep' E' * Subfield.relfinrank E' (⊤ : Subfield M) =
+      Subfield.relfinrank Ep' (⊤ : Subfield M) :=
+    Subfield.relfinrank_mul_relfinrank
+      (frobeniusSubfieldImageInM_le_algebraMapRange p) le_top
+  have htowerM : Subfield.relfinrank Ep' Mp * Subfield.relfinrank Mp (⊤ : Subfield M) =
+      Subfield.relfinrank Ep' (⊤ : Subfield M) :=
+    Subfield.relfinrank_mul_relfinrank
+      (frobeniusSubfieldImageInM_le_frobeniusSubfield p) le_top
+  have hEp'E' : Subfield.relfinrank Ep' E' = Module.finrank (frobeniusSubfield E p) E := by
+    have h1 : E' = (⊤ : Subfield E).map (algebraMap E M) := by
+      rw [hE', ← RingHom.fieldRange_eq_map]
+    rw [hEp', h1, Subfield.relfinrank_map_map, Subfield.relfinrank_top_right]
+  have hMpTop : Subfield.relfinrank Mp (⊤ : Subfield M) = Module.finrank (frobeniusSubfield M p) M
+    :=
+    Subfield.relfinrank_top_right _
+  have hE'pos : 0 < Subfield.relfinrank E' (⊤ : Subfield M) := by
+    rw [Subfield.relfinrank_top_right, hE', finrank_algebraMapRange_eq (E := E) (M := M)]
+    exact Module.finrank_pos
+  have hcancel : Subfield.relfinrank Ep' E' = Subfield.relfinrank Mp (⊤ : Subfield M) := by
+    have h := htowerE.trans htowerM.symm
+    rw [hfrob, mul_comm (Subfield.relfinrank E' _)] at h
+    exact Nat.eq_of_mul_eq_mul_right hE'pos h
+  rw [← hMpTop, ← hcancel, hEp'E']
+
+end Transport
+
+section LinearIndependence
+
+variable {M : Type*} [Field M] (p : ℕ) [hp : Fact p.Prime] [CharP M p]
+
+private theorem pDigits_linearIndependent {t : M} (htp : ∀ a : M, a ^ p ≠ t) :
+    haveI : ExpChar M p := ExpChar.prime hp.out
+    LinearIndependent (frobeniusSubfield M p)
+      (fun i : Fin p ↦ (t ^ (i : ℕ) : M)) := by
+  have : ExpChar M p := ExpChar.prime hp.out
+  have htp' : ∀ c : frobeniusSubfield M p, c ^ p ≠
+      (⟨t ^ p, pow_mem_frobeniusSubfield p t⟩ : frobeniusSubfield M p) := by
+    rintro ⟨_, b, rfl⟩ hcp
+    refine htp b ((frobenius M p).injective ?_)
+    have hcp' := congrArg (fun z : frobeniusSubfield M p ↦ (z : M)) hcp
+    push_cast at hcp'
+    simpa only [frobenius_def] using hcp'
+  have hirr : Irreducible (X ^ p - C (⟨t ^ p, pow_mem_frobeniusSubfield p t⟩ :
+      frobeniusSubfield M p)) :=
+    X_pow_sub_C_irreducible_of_prime hp.out htp'
+  have hroot : (aeval (R := ↥(frobeniusSubfield M p)) t)
+      (X ^ p - C (⟨t ^ p, pow_mem_frobeniusSubfield p t⟩ : frobeniusSubfield M p)) = 0 := by
+    simp only [map_sub, map_pow, aeval_X, aeval_C]
+    exact sub_self _
+  have hmon : (X ^ p - C (⟨t ^ p, pow_mem_frobeniusSubfield p t⟩ :
+      frobeniusSubfield M p)).Monic := monic_X_pow_sub_C _ hp.out.ne_zero
+  have hmp : X ^ p - C (⟨t ^ p, pow_mem_frobeniusSubfield p t⟩ : frobeniusSubfield M p) =
+      minpoly (↥(frobeniusSubfield M p)) t :=
+    minpoly.eq_of_irreducible_of_monic hirr hroot hmon
+  have hdeg : (minpoly (↥(frobeniusSubfield M p)) t).natDegree = p := by
+    rw [← hmp, natDegree_X_pow_sub_C]
+  have hli := linearIndependent_pow (K := ↥(frobeniusSubfield M p)) t
+  rw [hdeg] at hli
+  exact hli
+
+end LinearIndependence
+
+section AdjoinIndex
+
+open scoped IntermediateField
+
+variable {K M : Type*} [Field K] [Field M] [Algebra K M]
+  (p : ℕ) [hp : Fact p.Prime] [CharP K p]
+
+private abbrev genT (t : M) : ↥K⟮t⟯ := IntermediateField.AdjoinSimple.gen K t
+
+omit [CharP K p] in
+private theorem genT_not_pow (t : M) (htr : Transcendental K t) (a : ↥K⟮t⟯) :
+    a ^ p ≠ genT t := by
+  intro ha
+  have ht0 : t ≠ 0 := fun h ↦ htr (h ▸ isAlgebraic_zero)
+  have ha' : t = (↑a : M) ^ p := by
+    have := congrArg (fun z : ↥K⟮t⟯ ↦ (z : M)) ha
+    push_cast at this; simpa using this.symm
+  obtain ⟨r, s, hrs⟩ := (IntermediateField.mem_adjoin_simple_iff K _).mp a.2
+  have hkey : aeval t (X * s ^ p - r ^ p) = 0 := by
+    simp only [map_sub, map_mul, aeval_X, map_pow]
+    rw [hrs, div_pow] at ha'
+    by_cases hs0 : aeval t s = 0
+    · rw [hs0, zero_pow hp.out.ne_zero, div_zero] at ha'
+      exact absurd ha' ht0
+    · rw [eq_div_iff (pow_ne_zero _ hs0)] at ha'
+      rw [sub_eq_zero]; exact ha'
+  have hinj : X * s ^ p - r ^ p = (0 : K[X]) := by
+    have := htr
+    rw [Transcendental, isAlgebraic_iff_not_injective, not_not] at this
+    exact this (by simpa using hkey)
+  have hs0 : s ≠ 0 := by
+    intro h0; rw [h0] at hrs
+    simp only [map_zero, div_zero] at hrs
+    exact ht0 (ha'.trans (by rw [hrs, zero_pow hp.out.ne_zero]))
+  have hr0 : r ≠ 0 := by
+    intro h0
+    rw [h0, zero_pow hp.out.ne_zero, sub_zero, mul_eq_zero] at hinj
+    exact hs0 (pow_eq_zero_iff hp.out.ne_zero |>.mp (hinj.resolve_left X_ne_zero))
+  have hdeg : (X * s ^ p).natDegree = (r ^ p : K[X]).natDegree := by
+    have := sub_eq_zero.mp hinj; rw [this]
+  rw [natDegree_mul X_ne_zero (pow_ne_zero _ hs0), natDegree_X, natDegree_pow,
+    natDegree_pow] at hdeg
+  have hpdvd : p ∣ 1 := by
+    have h1 : p * r.natDegree - p * s.natDegree = 1 := by omega
+    exact ⟨r.natDegree - s.natDegree, by rw [Nat.mul_sub, h1]⟩
+  exact absurd (Nat.le_of_dvd Nat.one_pos hpdvd) hp.out.one_lt.not_ge
+
+private theorem adjoin_genT_over_frobeniusSubfield [PerfectField K] (t : M) :
+    haveI : ExpChar (↥K⟮t⟯) p :=
+      expChar_of_injective_algebraMap (algebraMap K _).injective p
+    (IntermediateField.adjoin (↥(frobeniusSubfield (↥K⟮t⟯) p)) {genT t} :
+        IntermediateField _ (↥K⟮t⟯)) = ⊤ := by
+  have : ExpChar (↥K⟮t⟯) p :=
+    expChar_of_injective_algebraMap (algebraMap K _).injective p
+  rw [eq_top_iff]
+  intro x _
+  obtain ⟨r, s, hrs⟩ := (IntermediateField.mem_adjoin_simple_iff K _).mp x.2
+  have hrs' : x = aeval (genT t) r / aeval (genT t) s := by
+    apply Subtype.ext
+    rw [hrs]
+    push_cast
+    exact congrArg₂ _
+      (IntermediateField.AdjoinSimple.coe_aeval_gen_apply (F := K) (α := t) r).symm
+      (IntermediateField.AdjoinSimple.coe_aeval_gen_apply (F := K) (α := t) s).symm
+  rw [hrs']
+  have hK : ∀ c : K, (algebraMap K (↥K⟮t⟯)) c ∈ (frobeniusSubfield (↥K⟮t⟯) p : Subfield _) := by
+    intro c
+    obtain ⟨c', hc'⟩ := (frobeniusEquiv K p).surjective c
+    exact ⟨algebraMap K _ c', by
+      rw [← hc']; simp only [frobenius_def, map_pow, frobeniusEquiv_apply, frobenius_def]⟩
+  have haeval : ∀ q : K[X], aeval (genT t) q ∈
+      (IntermediateField.adjoin (↥(frobeniusSubfield (↥K⟮t⟯) p)) {genT t} :
+        IntermediateField _ (↥K⟮t⟯)) := by
+    intro q
+    induction q using Polynomial.induction_on with
+    | C c =>
+      simp only [aeval_C]
+      exact IntermediateField.algebraMap_mem _ (⟨_, hK c⟩ : ↥(frobeniusSubfield (↥K⟮t⟯) p))
+    | add f g hf hg => simpa only [map_add] using add_mem hf hg
+    | monomial n c _ =>
+      simp only [map_mul, aeval_C, map_pow, aeval_X]
+      exact mul_mem (IntermediateField.algebraMap_mem _
+          (⟨_, hK c⟩ : ↥(frobeniusSubfield (↥K⟮t⟯) p)))
+        (pow_mem (IntermediateField.mem_adjoin_simple_self _ _) _)
+  exact div_mem (haeval r) (haeval s)
+
+private theorem finrank_frobeniusSubfield_adjoin_transcendental [PerfectField K]
+    {t : M} (htr : Transcendental K t) :
+    haveI : ExpChar (↥(IntermediateField.adjoin K ({t} : Set M))) p :=
+      expChar_of_injective_algebraMap (algebraMap K _).injective p
+    Module.finrank
+      (frobeniusSubfield (↥(IntermediateField.adjoin K ({t} : Set M))) p)
+      (↥(IntermediateField.adjoin K ({t} : Set M))) = p := by
+  have : ExpChar (↥K⟮t⟯) p :=
+    expChar_of_injective_algebraMap (algebraMap K _).injective p
+  have : CharP (↥K⟮t⟯) p :=
+    charP_of_injective_algebraMap (algebraMap K _).injective p
+  let t' : ↥K⟮t⟯ := genT t
+  let tp : ↥(frobeniusSubfield (↥K⟮t⟯) p) := ⟨t' ^ p, pow_mem_frobeniusSubfield p t'⟩
+  have hint : IsIntegral (↥(frobeniusSubfield (↥K⟮t⟯) p)) t' := by
+    refine ⟨X ^ p - C tp, monic_X_pow_sub_C _ hp.out.ne_zero, ?_⟩
+    simp only [eval₂_sub, eval₂_X_pow, eval₂_C]
+    exact sub_eq_zero.mpr rfl
+  have hfd : FiniteDimensional (↥(frobeniusSubfield (↥K⟮t⟯) p)) (↥K⟮t⟯) := by
+    have h1 := adjoin_genT_over_frobeniusSubfield (K := K) (M := M) p t
+    have h2 := IntermediateField.adjoin.finiteDimensional hint
+    rw [show t' = genT t from rfl, h1] at h2
+    exact (IntermediateField.topEquiv (F := ↥(frobeniusSubfield (↥K⟮t⟯) p))
+      (E := ↥K⟮t⟯)).toLinearEquiv.finiteDimensional
+  have hli := pDigits_linearIndependent (M := ↥K⟮t⟯) p (t := t') (genT_not_pow p t htr)
+  refine le_antisymm ?_
+    (by simpa only [Fintype.card_fin] using hli.fintype_card_le_finrank)
+  have htop := adjoin_genT_over_frobeniusSubfield (K := K) (M := M) p t
+  calc Module.finrank _ (↥K⟮t⟯)
+      = Module.finrank (↥(frobeniusSubfield (↥K⟮t⟯) p))
+          (↥(IntermediateField.adjoin (↥(frobeniusSubfield (↥K⟮t⟯) p)) {t'} :
+            IntermediateField _ (↥K⟮t⟯))) := by
+        rw [show t' = genT t from rfl, htop, IntermediateField.finrank_top']
+    _ = (minpoly (↥(frobeniusSubfield (↥K⟮t⟯) p)) t').natDegree :=
+        IntermediateField.adjoin.finrank hint
+    _ ≤ (X ^ p - C tp).natDegree :=
+        Polynomial.natDegree_le_of_dvd (minpoly.dvd _ _ (by
+          simp only [map_sub, map_pow, aeval_X, aeval_C]; exact sub_eq_zero.mpr rfl))
+          (monic_X_pow_sub_C _ hp.out.ne_zero).ne_zero
+    _ = p := natDegree_X_pow_sub_C
+
+end AdjoinIndex
+
+section PDigitsExists
+
+variable {M : Type*} [Field M] (p : ℕ) [hp : Fact p.Prime] [CharP M p]
+
+private theorem pDigits_exists_of_finrank_eq
+    (hfr : haveI : ExpChar M p := ExpChar.prime hp.out
+      Module.finrank (frobeniusSubfield M p) M = p)
+    {t : M} (htp : ∀ a : M, a ^ p ≠ t) (g : M) :
+    ∃ a : Fin p → M, g = ∑ i : Fin p, a i ^ p * t ^ (i : ℕ) := by
+  have : ExpChar M p := ExpChar.prime hp.out
+  have hlin := pDigits_linearIndependent p htp
+  let b : Module.Basis (Fin p) (frobeniusSubfield M p) M :=
+    basisOfLinearIndependentOfCardEqFinrank hlin (by rw [hfr, Fintype.card_fin])
+  have hbapply : ∀ i : Fin p, (b i : M) = t ^ (i : ℕ) := fun i ↦
+    congrFun (coe_basisOfLinearIndependentOfCardEqFinrank hlin
+      (by rw [hfr, Fintype.card_fin])) i
+  refine ⟨fun i ↦ (frobeniusRingEquivRange M p).symm (b.repr g i), ?_⟩
+  conv_lhs => rw [← b.sum_repr g]
+  refine Finset.sum_congr rfl fun i _ ↦ ?_
+  rw [hbapply i, ← frobeniusRingEquivRange_apply M p, RingEquiv.apply_symm_apply]
+  rfl
+
+end PDigitsExists
+
+end AlgebraicCurve.SEPEngine
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place isAlgebraic_adjoin_of_transcendental"
+namespace SEPEngine
+p2m_open "AlgebraicCurve"
+
+open KaehlerDifferential IntermediateField
+
+private theorem not_pow_of_ord_eq_one {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : AlgebraicCurve.Place K F) {t : F} (ht : v.ord t = 1) {p : ℕ} (hp : 2 ≤ p) (a : F) :
+    a ^ p ≠ t := by
+  intro h
+  have h2 : (p : ℤ) * v.ord a = 1 := by
+    rw [← v.ord_zpow, zpow_natCast, h, ht]
+  have := Int.eq_one_of_mul_eq_one_right (by positivity) h2
+  omega
+
+private theorem D_pow_eq_zero {E M : Type*} [CommRing E] [CommRing M]
+    [Algebra E M] (p : ℕ) [Fact p.Prime] [CharP M p] (a : M) :
+    D E M (a ^ p) = 0 := by
+  rw [Derivation.leibniz_pow, ← Nat.cast_smul_eq_nsmul M, CharP.cast_eq_zero M p, zero_smul]
+
+private theorem isSeparable_of_not_pow_mem_range {E M : Type*} [Field E] [Field M]
+    [Algebra E M] (p : ℕ) [hp : Fact p.Prime] [CharP M p]
+    [FiniteDimensional E M]
+    (hfr : haveI : ExpChar M p := ExpChar.prime hp.out
+      Module.finrank (frobeniusSubfield M p) M = p)
+    {t : M} (htE : t ∈ (algebraMap E M).range) (htp : ∀ a : M, a ^ p ≠ t) :
+    Algebra.IsSeparable E M := by
+  have : ExpChar M p := ExpChar.prime hp.out
+  obtain ⟨tE, rfl⟩ := htE
+  have hDt : D E M (algebraMap E M tE) = 0 := (D E M).map_algebraMap tE
+  have hDzero : ∀ m : M, D E M m = 0 := by
+    intro m
+    obtain ⟨a, rfl⟩ := pDigits_exists_of_finrank_eq p hfr htp m
+    rw [map_sum]
+    refine Finset.sum_eq_zero fun i _ ↦ ?_
+    rw [Derivation.leibniz, D_pow_eq_zero p (a i),
+      smul_zero, add_zero, Derivation.leibniz_pow, hDt, smul_zero,
+      ← Nat.cast_smul_eq_nsmul M, smul_zero, smul_zero]
+  have hsubsingleton : Subsingleton (Ω[M⁄E]) := by
+    refine ⟨fun ω₁ ω₂ ↦ ?_⟩
+    have htop : (⊤ : Submodule M (Ω[M⁄E])) = ⊥ := by
+      rw [← KaehlerDifferential.span_range_derivation, Submodule.span_eq_bot]
+      rintro _ ⟨m, rfl⟩; exact hDzero m
+    have h1 : ω₁ ∈ (⊥ : Submodule M (Ω[M⁄E])) := htop ▸ Submodule.mem_top
+    have h2 : ω₂ ∈ (⊥ : Submodule M (Ω[M⁄E])) := htop ▸ Submodule.mem_top
+    rw [Submodule.mem_bot] at h1 h2; rw [h1, h2]
+  have : Algebra.FormallyUnramified E M := ⟨hsubsingleton⟩
+  exact Algebra.FormallyUnramified.isSeparable E M
+
+end AlgebraicCurve.SEPEngine
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_Place_isSeparable_adjoin_of_ord_eq_one.AlgebraicCurve
+  AlgebraicCurve.SEPEngine IntermediateField in
+open scoped IntermediateField in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [PerfectField K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {t : F} (ht : v.ord t = 1) :
+    Algebra.IsSeparable (IntermediateField.adjoin K ({t} : Set F)) F := by
+  have ht0 : v.ord t ≠ 0 := by rw [ht]; exact one_ne_zero
+  have htr : Transcendental K t := v.transcendental_of_ord_ne_zero ht0
+  have halg : Algebra.IsAlgebraic (↥K⟮t⟯) F :=
+    AlgebraicCurve.isAlgebraic_adjoin_of_transcendental x htr
+  obtain ⟨q, hq⟩ := ExpChar.exists K
+  have := hq
+  cases hq with
+  | zero =>
+    have : CharZero (↥K⟮t⟯) := charZero_of_injective_algebraMap (algebraMap K _).injective
+    infer_instance
+  | prime hqp =>
+    have : Fact q.Prime := ⟨hqp⟩
+    have htp : ∀ a : F, a ^ q ≠ t := fun a ↦ not_pow_of_ord_eq_one v ht hqp.two_le a
+    have hEq : ExpChar (↥K⟮t⟯) q :=
+      expChar_of_injective_algebraMap (algebraMap K _).injective q
+    have hEqC : CharP (↥K⟮t⟯) q :=
+      charP_of_injective_algebraMap (algebraMap K _).injective q
+    have hEfr : Module.finrank (frobeniusSubfield (↥K⟮t⟯) q) (↥K⟮t⟯) = q :=
+      finrank_frobeniusSubfield_adjoin_transcendental q htr
+    have hEfd : FiniteDimensional (frobeniusSubfield (↥K⟮t⟯) q) (↥K⟮t⟯) :=
+      .of_finrank_pos (by rw [hEfr]; exact hqp.pos)
+    refine ⟨fun y ↦ ?_⟩
+    have hMfd : FiniteDimensional (↥K⟮t⟯) (↥(↥K⟮t⟯)⟮y⟯) :=
+      IntermediateField.adjoin.finiteDimensional (Algebra.IsAlgebraic.isAlgebraic y).isIntegral
+    suffices hMsep : Algebra.IsSeparable (↥K⟮t⟯) (↥(↥K⟮t⟯)⟮y⟯) from
+      isSeparable_of_mem_isSeparable _ F (mem_adjoin_simple_self (↥K⟮t⟯) y)
+    have hMq : CharP (↥(↥K⟮t⟯)⟮y⟯) q :=
+      charP_of_injective_algebraMap (algebraMap (↥K⟮t⟯) _).injective q
+    have hMqe : ExpChar (↥(↥K⟮t⟯)⟮y⟯) q := ExpChar.prime hqp
+    have hMfr : Module.finrank (frobeniusSubfield (↥(↥K⟮t⟯)⟮y⟯) q) (↥(↥K⟮t⟯)⟮y⟯) = q := by
+      rw [finrank_frobeniusSubfield_eq (E := ↥K⟮t⟯) q]
+      exact hEfr
+    refine isSeparable_of_not_pow_mem_range q hMfr (t := algebraMap (↥K⟮t⟯) _
+        ⟨t, mem_adjoin_simple_self K t⟩) ⟨_, rfl⟩ ?_
+    intro a ha
+    apply htp ((a : F))
+    have h1 : ((a ^ q : ↥(↥K⟮t⟯)⟮y⟯) : F) =
+        ((algebraMap (↥K⟮t⟯) _ ⟨t, mem_adjoin_simple_self K t⟩ : ↥(↥K⟮t⟯)⟮y⟯) : F) :=
+      congrArg _ ha
+    simpa using h1
+
+end
+
+end S_AlgebraicCurve_Place_isSeparable_adjoin_of_ord_eq_one
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_isSeparable_adjoin_of_ord_eq_one (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.isSeparable_adjoin_of_ord_eq_one {K F : Type*} [Field K] [Field F]
+    [Algebra K F] [PerfectField K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {t : F}
+    (ht : v.ord t = 1) :
+    Algebra.IsSeparable (IntermediateField.adjoin K ({t} : Set F)) F :=
+  solution x v ht
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed.lean
new file mode 100644
index 0000000000..4dee179e3f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed.lean
@@ -0,0 +1,482 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.Place.mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed
+(4e728b40-ba0e-5edc-885d-a8df4da58b96) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 39d7436f-3d6b-5ed7-b84c-f746bfa836ad
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+public import Mathlib.RingTheory.Algebraic.Basic
+
+import Mathlib.RingTheory.Unramified.Field
+import Mathlib.FieldTheory.Relrank
+import Mathlib.FieldTheory.RatFunc.IntermediateField
+import Mathlib.FieldTheory.IsAlgClosed.Basic
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Algebra
+import Mathlib.RingTheory.Adjoin.Polynomial.Basic
+import Mathlib.FieldTheory.RatFunc.Degree
+import Mathlib.FieldTheory.Separable
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_exists_forall_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_eq_neg_intDegree_of_forall_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_comap_eq_toValuationSubring
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_algebraMap_eq_mul_ord
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteDimensional_adjoin_of_transcendental
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Functions with order zero at every place are constant
+
+Theorem statement: `AlgebraicCurve.Place.mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed`
+(`4e728b40-ba0e-5edc-885d-a8df4da58b96`), by Claude, 2026-09-05.
+
+Proof: submission `39d7436f-3d6b-5ed7-b84c-f746bfa836ad`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and suppose $K$ is algebraically closed. Let $j
+\in F$ be transcendental over $K$, and assume $F$ is finite-dimensional over the intermediate field
+$K(j) =$ `IntermediateField.adjoin K {j}`, so that $F$ is a function field of one variable over $K$.
+Here a place of $F/K$ (the structure
+[`AlgebraicCurve.Place`](def/AlgebraicCurve_DivisorClassGroup.html#L22)) consists of a valuation
+subring of $F$ that contains the image of $K$ under `algebraMap K F`, is not the whole of $F$, and
+is a principal ideal ring; for such a $v$ the quantity `v.ord f` is the integer $-\log$ of the value
+at $f$ of the $\mathbb{Z}^{m0}$-valued adic valuation attached to the height-one prime of that
+valuation ring, i.e. the normalised order of vanishing of $f$ at $v$. The assertion is that if $x
+\in F$ satisfies $\operatorname{ord}_v(x) = 0$ for every place $v$ of $F/K$, then $x$ lies in the
+range of `algebraMap K F`, that is, $x$ is a constant.
+
+This is the classical statement that on a complete curve over an algebraically closed field a
+rational function with neither zeros nor poles is constant (equivalently, the only
+everywhere-regular invertible functions on a one-dimensional function field are the elements of the
+constant field). It is used throughout the treatment of divisors and the divisor class group of a
+function field, for instance in the rigidity statement that an automorphism fixing every place is
+the identity, and in comparisons of orders under constant field extension.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed
+
+open scoped IntermediateField
+open Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place RationalFunctionField.exists_forall_ne_ofHeightOneSpectrum \
+  RationalFunctionField.ord_eq_neg_intDegree_of_forall_ne_ofHeightOneSpectrum \
+  Place.exists_comap_eq_toValuationSubring Place.exists_ord_algebraMap_eq_mul_ord \
+  finiteDimensional_adjoin_of_transcendental"
+end AlgebraicCurve
+p2m_open_scoped "AlgebraicCurve" in
+theorem AlgebraicCurve.isSeparable_of_finrank_fieldRange_frobenius_eq
+    {E F : Type*} [Field E] [Field F] [Algebra E F] [FiniteDimensional E F]
+    (p : ℕ) [Fact p.Prime] [CharP F p]
+    (hdeg : Module.finrank (frobenius F p).fieldRange F = p)
+    (y : E) (hy : algebraMap E F y ∉ (frobenius F p).fieldRange) :
+    Algebra.IsSeparable E F := by
+  set S : Subfield F := (frobenius F p).fieldRange with hS
+  have : IsSimpleOrder (IntermediateField S F) :=
+    IntermediateField.isSimpleOrder_of_finrank_prime S F (by rw [hdeg]; exact Fact.out)
+  set D := KaehlerDifferential.D E F with hD
+  have hDS : ∀ s : F, s ∈ S → D s = 0 := by
+    intro s hs
+    obtain ⟨a, rfl⟩ := RingHom.mem_fieldRange.mp hs
+    rw [frobenius_def, D.leibniz_pow, ← Nat.cast_smul_eq_nsmul F, CharP.cast_eq_zero, zero_smul]
+  have hDy : D (algebraMap E F y) = 0 := D.map_algebraMap y
+  let Z : IntermediateField S F :=
+    { carrier := {z | D z = 0}
+      mul_mem' := by
+        intro a b ha hb
+        simp only [Set.mem_ofPred_eq] at ha hb ⊢
+        rw [D.leibniz, ha, hb, smul_zero, smul_zero, add_zero]
+      one_mem' := D.map_one_eq_zero
+      add_mem' := by
+        intro a b ha hb
+        simp only [Set.mem_ofPred_eq] at ha hb ⊢
+        rw [map_add, ha, hb, add_zero]
+      zero_mem' := map_zero D
+      algebraMap_mem' := fun s => hDS _ s.2
+      inv_mem' := by
+        intro z hz
+        simp only [Set.mem_ofPred_eq] at hz ⊢
+        rw [D.leibniz_inv, hz, smul_zero] }
+  have hyZ : IntermediateField.adjoin S {algebraMap E F y} ≤ Z :=
+    IntermediateField.adjoin_le_iff.mpr (Set.singleton_subset_iff.mpr hDy)
+  have hZ : Z = ⊤ := by
+    rcases IsSimpleOrder.eq_bot_or_eq_top (IntermediateField.adjoin S {algebraMap E F y})
+      with h | h
+    · exfalso
+      apply hy
+      have hmem : algebraMap E F y ∈ (⊥ : IntermediateField S F) :=
+        h ▸ IntermediateField.mem_adjoin_simple_self S (algebraMap E F y)
+      obtain ⟨s, hs⟩ := IntermediateField.mem_bot.mp hmem
+      rw [← hs]
+      exact s.2
+    · rw [h] at hyZ
+      exact top_le_iff.mp hyZ
+  have hD0 : ∀ z : F, D z = 0 := fun z => by
+    have hz : z ∈ Z := hZ ▸ IntermediateField.mem_top
+    exact hz
+  have : Subsingleton (KaehlerDifferential E F) := by
+    refine subsingleton_of_forall_eq 0 fun ω => ?_
+    have hω : ω ∈ Submodule.span F (Set.range D) := by
+      rw [hD, KaehlerDifferential.span_range_derivation]
+      trivial
+    have hle : Submodule.span F (Set.range D) ≤ ⊥ := by
+      refine Submodule.span_le.mpr ?_
+      rintro _ ⟨z, rfl⟩
+      exact (Submodule.mem_bot F).mpr (hD0 z)
+    exact (Submodule.mem_bot F).mp (hle hω)
+  have : Algebra.FormallyUnramified E F := ⟨inferInstance⟩
+  exact Algebra.FormallyUnramified.isSeparable E F
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place RationalFunctionField.exists_forall_ne_ofHeightOneSpectrum \
+  RationalFunctionField.ord_eq_neg_intDegree_of_forall_ne_ofHeightOneSpectrum \
+  Place.exists_comap_eq_toValuationSubring Place.exists_ord_algebraMap_eq_mul_ord \
+  finiteDimensional_adjoin_of_transcendental"
+p2m_open "AlgebraicCurve"
+
+section FieldTheory
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem finrank_toSubfield (E : IntermediateField K F) :
+    Module.finrank E.toSubfield F = Module.finrank E F :=
+  Algebra.finrank_eq_of_equiv_equiv
+    (⟨⟨fun x => ⟨x.1, x.2⟩, fun x => ⟨x.1, x.2⟩, fun _ => rfl, fun _ => rfl⟩,
+      fun _ _ => rfl, fun _ _ => rfl⟩ : E.toSubfield ≃+* E)
+    (RingEquiv.refl F) (by ext x; rfl)
+
+noncomputable def ratFuncHom (y : F) (hy : Transcendental K y) : RatFunc K →ₐ[K] F :=
+  (K⟮y⟯.val).comp (RatFunc.algEquivOfTranscendental y hy : RatFunc K →ₐ[K] K⟮y⟯)
+
+theorem ratFuncHom_X (y : F) (hy : Transcendental K y) : ratFuncHom y hy RatFunc.X = y := by
+  simp [ratFuncHom]
+
+theorem map_top_ratFuncHom (y : F) (hy : Transcendental K y) :
+    (⊤ : IntermediateField K (RatFunc K)).map (ratFuncHom y hy) = K⟮y⟯ := by
+  rw [← RatFunc.adjoin_X, IntermediateField.adjoin_map, Set.image_singleton, ratFuncHom_X]
+
+theorem map_adjoin_X_pow_ratFuncHom (y : F) (hy : Transcendental K y) (m : ℕ) :
+    K⟮(RatFunc.X : RatFunc K) ^ m⟯.map (ratFuncHom y hy) = K⟮y ^ m⟯ := by
+  rw [IntermediateField.adjoin_map, Set.image_singleton, map_pow, ratFuncHom_X]
+
+theorem finrank_adjoin_X_pow' (K : Type*) [Field K] (m : ℕ) :
+    Module.finrank K⟮(RatFunc.X : RatFunc K) ^ m⟯ (RatFunc K) = m := by
+  rw [RatFunc.finrank_eq_max_natDegree,
+    show (RatFunc.X : RatFunc K) ^ m = algebraMap K[X] (RatFunc K) (Polynomial.X ^ m) by
+      rw [map_pow, RatFunc.algebraMap_X],
+    RatFunc.num_algebraMap, RatFunc.denom_algebraMap, Polynomial.natDegree_X_pow,
+    Polynomial.natDegree_one, Nat.max_eq_left (Nat.zero_le m)]
+
+theorem le_finrank_adjoin_of_pow_eq (y : F) (hy : Transcendental K y) [FiniteDimensional K⟮y⟯ F]
+    (m : ℕ) {x : F} (hxy : y ^ m = x) : m ≤ Module.finrank K⟮x⟯ F := by
+  subst hxy
+  have hle : K⟮y ^ m⟯ ≤ K⟮y⟯ :=
+    IntermediateField.adjoin_simple_le_iff.mpr (pow_mem (IntermediateField.mem_adjoin_simple_self K
+      y) m)
+  have hrel : IntermediateField.relfinrank K⟮y ^ m⟯ K⟮y⟯ = m := by
+    rw [← map_adjoin_X_pow_ratFuncHom y hy m, ← map_top_ratFuncHom y hy,
+      IntermediateField.relfinrank_map_map, IntermediateField.relfinrank_top_right,
+      finrank_adjoin_X_pow']
+  have hmul := IntermediateField.relfinrank_mul_finrank_top hle
+  rw [hrel] at hmul
+  have hpos : 0 < Module.finrank K⟮y⟯ F := Module.finrank_pos
+  calc m = m * 1 := (mul_one m).symm
+    _ ≤ m * Module.finrank K⟮y⟯ F := Nat.mul_le_mul_left m hpos
+    _ = Module.finrank K⟮y ^ m⟯ F := hmul
+
+theorem fieldRange_frobenius_ratFunc (K : Type*) [Field K] (p : ℕ) [Fact p.Prime] [CharP K p]
+    [PerfectRing K p] :
+    (frobenius (RatFunc K) p).fieldRange = K⟮(RatFunc.X : RatFunc K) ^ p⟯.toSubfield := by
+  have : CharP (RatFunc K) p := (Algebra.charP_iff K (RatFunc K) p).mp inferInstance
+  have halg : ∀ g : K[X], algebraMap K[X] (RatFunc K) g = Polynomial.aeval (RatFunc.X : RatFunc K) g
+    :=
+    fun g => by rw [← RatFunc.algebraMap_X, Polynomial.aeval_algebraMap_apply,
+      Polynomial.aeval_X_left_apply]
+  apply le_antisymm
+  · rintro _ ⟨r, rfl⟩
+    change (frobenius (RatFunc K) p) r ∈ K⟮(RatFunc.X : RatFunc K) ^ p⟯
+    have key : ∀ f : K[X], (algebraMap K[X] (RatFunc K) f) ^ p ∈ K⟮(RatFunc.X : RatFunc K) ^ p⟯ :=
+      by
+      intro f
+      have hf : (algebraMap K[X] (RatFunc K) f) ^ p
+          = Polynomial.aeval ((RatFunc.X : RatFunc K) ^ p) (f.map (frobenius K p)) := by
+        rw [← map_pow, ← Polynomial.map_frobenius_expand, Polynomial.map_expand, halg,
+          Polynomial.expand_aeval]
+      rw [hf]
+      refine IntermediateField.algebra_adjoin_le_adjoin K _ ?_
+      rw [Algebra.adjoin_singleton_eq_range_aeval]
+      exact ⟨_, rfl⟩
+    rw [frobenius_def]
+    have h := div_mem (key r.num) (key r.denom)
+    rwa [← div_pow, RatFunc.num_div_denom] at h
+  · rw [IntermediateField.adjoin_toSubfield]
+    refine Subfield.closure_le.mpr ?_
+    rintro z (⟨c, rfl⟩ | hz)
+    · refine ⟨algebraMap K (RatFunc K) ((frobeniusEquiv K p).symm c), ?_⟩
+      rw [frobenius_def, ← map_pow, ← frobenius_def, frobenius_apply_frobeniusEquiv_symm]
+    · rw [Set.mem_singleton_iff] at hz
+      subst hz
+      exact ⟨RatFunc.X, rfl⟩
+
+theorem finrank_fieldRange_frobenius_ratFunc (K : Type*) [Field K] (p : ℕ) [Fact p.Prime]
+    [CharP K p] [PerfectRing K p] :
+    Module.finrank (frobenius (RatFunc K) p).fieldRange (RatFunc K) = p := by
+  rw [fieldRange_frobenius_ratFunc K p, finrank_toSubfield, finrank_adjoin_X_pow']
+
+theorem finrank_fieldRange_frobenius_eq_of_transcendental (p : ℕ) [Fact p.Prime] [CharP K p]
+    [CharP F p] [PerfectRing K p] (y : F) (hy : Transcendental K y) [FiniteDimensional K⟮y⟯ F] :
+    Module.finrank (frobenius F p).fieldRange F = p := by
+  have : CharP (RatFunc K) p := (Algebra.charP_iff K (RatFunc K) p).mp inferInstance
+  set ψ : RatFunc K →+* F := (ratFuncHom y hy).toRingHom with hψ
+  have hcomm : ψ.comp (frobenius (RatFunc K) p) = (frobenius F p).comp ψ :=
+    RingHom.ext fun r => by simp only [RingHom.comp_apply, frobenius_def, map_pow]
+  have hB : (⊤ : Subfield (RatFunc K)).map ψ = K⟮y⟯.toSubfield := by
+    have h := congrArg IntermediateField.toSubfield (map_top_ratFuncHom y hy)
+    rwa [IntermediateField.toSubfield_map, IntermediateField.top_toSubfield] at h
+  set C : Subfield F := ((frobenius (RatFunc K) p).fieldRange).map ψ with hC
+  have hCB : C ≤ K⟮y⟯.toSubfield := by
+    rw [← hB]
+    rintro _ ⟨r, -, rfl⟩
+    exact ⟨r, trivial, rfl⟩
+  have hCA : C ≤ (frobenius F p).fieldRange := by
+    rintro _ ⟨r, hr, rfl⟩
+    obtain ⟨s, rfl⟩ := RingHom.mem_fieldRange.mp hr
+    exact ⟨ψ s, by rw [frobenius_def, frobenius_def, map_pow]⟩
+  have T1 := Subfield.relfinrank_mul_finrank_top hCB
+  have T2 := Subfield.relfinrank_mul_finrank_top hCA
+  have S3 : Subfield.relfinrank C (frobenius F p).fieldRange
+      = Module.finrank K⟮y⟯.toSubfield F := by
+    have hC' : C = (K⟮y⟯.toSubfield).map (frobenius F p) := by
+      rw [hC, RingHom.fieldRange_eq_map, Subfield.map_map, hcomm, ← Subfield.map_map, hB]
+    rw [hC', RingHom.fieldRange_eq_map (frobenius F p), Subfield.relfinrank_map_map,
+      Subfield.relfinrank_top_right]
+  have S4 : Subfield.relfinrank C K⟮y⟯.toSubfield = p := by
+    rw [hC, ← hB, Subfield.relfinrank_map_map, Subfield.relfinrank_top_right]
+    exact finrank_fieldRange_frobenius_ratFunc K p
+  have hpos : 0 < Module.finrank K⟮y⟯.toSubfield F := by
+    rw [finrank_toSubfield]
+    exact Module.finrank_pos
+  have h := T1.trans T2.symm
+  rw [S3, S4, mul_comm p] at h
+  exact (Nat.eq_of_mul_eq_mul_left hpos h).symm
+
+end FieldTheory
+
+section R2
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem transcendental_of_pow_eq {x y : F} {m : ℕ} (hx : Transcendental K x) (h : y ^ m = x) :
+    Transcendental K y :=
+  fun halg => hx (h ▸ halg.pow m)
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ord ord_zpow algebraMap_mem' \
+  exists_comap_eq_toValuationSubring exists_ord_algebraMap_eq_mul_ord"
+end Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+theorem Place.mem_range_algebraMap_of_forall_ord_eq_zero_core [IsAlgClosed K]
+    (hfin : ∀ z : F, Transcendental K z → FiniteDimensional K⟮z⟯ F)
+    (hpole : ∀ z : F, Transcendental K z → FiniteDimensional K⟮z⟯ F →
+      Algebra.IsSeparable K⟮z⟯ F → ∃ v : Place K F, v.ord z < 0)
+    {x : F} (hx : ∀ v : Place K F, v.ord x = 0) : x ∈ (algebraMap K F).range := by
+  classical
+  by_contra hxK
+  have hxt : Transcendental K x := fun halg =>
+    hxK (minpoly.mem_range_of_degree_eq_one K x
+      (IsAlgClosed.degree_eq_one_of_irreducible K (minpoly.irreducible halg.isIntegral)))
+  have pole : ∀ z : F, Transcendental K z → (∀ v : Place K F, v.ord z = 0) →
+      Algebra.IsSeparable K⟮z⟯ F → False := by
+    intro z hz hz0 hsep
+    obtain ⟨v, hv⟩ := hpole z hz (hfin z hz) hsep
+    rw [hz0 v] at hv
+    exact lt_irrefl 0 hv
+  obtain ⟨p, hchar⟩ := CharP.exists F
+  by_cases hp : p = 0
+  · subst hp
+    have := hchar
+    have : CharZero F := CharP.charP_to_charZero F
+    have : CharZero K⟮x⟯ := (algebraMap K⟮x⟯ F).charZero
+    have := hfin x hxt
+    have : Algebra.IsAlgebraic K⟮x⟯ F := Algebra.IsAlgebraic.of_finite _ _
+    exact pole x hxt hx Algebra.IsAlgebraic.isSeparable_of_perfectField
+  · have := hchar
+    have hpp : Fact p.Prime := ⟨(CharP.char_is_prime_or_zero F p).resolve_right hp⟩
+    have : CharP K p := (Algebra.charP_iff K F p).mpr hchar
+    have : ExpChar K p := ExpChar.prime hpp.out
+    have step : ∀ n : ℕ, ∃ y : F, y ^ p ^ n = x := by
+      intro n
+      induction n with
+      | zero => exact ⟨x, by rw [pow_zero, pow_one]⟩
+      | succ n ih =>
+        obtain ⟨y, hy⟩ := ih
+        have hyt : Transcendental K y := transcendental_of_pow_eq hxt hy
+        have hy0 : ∀ v : Place K F, v.ord y = 0 := fun v => by
+          have h := hx v
+          rw [← hy, ← zpow_natCast, v.ord_zpow] at h
+          exact (mul_eq_zero.mp h).resolve_left (by exact_mod_cast pow_ne_zero n hpp.out.ne_zero)
+        have := hfin y hyt
+        by_contra hne
+        push Not at hne
+        have hyp : y ∉ (frobenius F p).fieldRange := by
+          intro hmem
+          obtain ⟨z, hz⟩ := RingHom.mem_fieldRange.mp hmem
+          rw [frobenius_def] at hz
+          apply hne z
+          rw [pow_succ', pow_mul, hz, hy]
+        have hdeg := finrank_fieldRange_frobenius_eq_of_transcendental (K := K) p y hyt
+        have hsep : Algebra.IsSeparable K⟮y⟯ F :=
+          AlgebraicCurve.isSeparable_of_finrank_fieldRange_frobenius_eq p hdeg
+            ⟨y, IntermediateField.mem_adjoin_simple_self K y⟩ hyp
+        exact pole y hyt hy0 hsep
+    have := hfin x hxt
+    obtain ⟨y, hy⟩ := step (Module.finrank K⟮x⟯ F)
+    have hyt : Transcendental K y := transcendental_of_pow_eq hxt hy
+    have := hfin y hyt
+    have hle := le_finrank_adjoin_of_pow_eq y hyt _ hy
+    exact absurd hle (not_le.mpr (Nat.lt_pow_self hpp.out.one_lt))
+
+end R2
+
+end AlgebraicCurve
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_Place_mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed.AlgebraicCu\
+  rve"
+open scoped nonZeroDivisors
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place RationalFunctionField.exists_forall_ne_ofHeightOneSpectrum \
+  RationalFunctionField.ord_eq_neg_intDegree_of_forall_ne_ofHeightOneSpectrum \
+  Place.exists_comap_eq_toValuationSubring Place.exists_ord_algebraMap_eq_mul_ord \
+  finiteDimensional_adjoin_of_transcendental"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ord ord_zpow algebraMap_mem' \
+  exists_comap_eq_toValuationSubring exists_ord_algebraMap_eq_mul_ord"
+end AlgebraicCurve.Place
+p2m_open_scoped "AlgebraicCurve AlgebraicCurve.Place" in
+theorem AlgebraicCurve.Place.exists_ord_neg_of_transcendental_of_isSeparable
+    {K F : Type*} [Field K] [Field F] [Algebra K F] (x : F) (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F] :
+    ∃ v : Place K F, v.ord x < 0 := by
+  classical
+  have hinj : Function.Injective (Polynomial.aeval x : Polynomial K →ₐ[K] F) :=
+    transcendental_iff_injective.mp hx
+  have hφ : (Polynomial K)⁰ ≤ F⁰.comap (Polynomial.aeval x : Polynomial K →ₐ[K] F) := by
+    intro p hp
+    rw [Submonoid.mem_comap, mem_nonZeroDivisors_iff_ne_zero]
+    rw [mem_nonZeroDivisors_iff_ne_zero] at hp
+    exact fun h => hp (hinj (by rw [h, map_zero]))
+  set ψ : RatFunc K →ₐ[K] F := RatFunc.liftAlgHom (Polynomial.aeval x) hφ with hψ_def
+  have hψX : ψ RatFunc.X = x := by
+    rw [hψ_def, RatFunc.liftAlgHom_apply, RatFunc.num_X, RatFunc.denom_X, Polynomial.aeval_X,
+      map_one, div_one]
+  let : Algebra (RatFunc K) F := ψ.toRingHom.toAlgebra
+  have : IsScalarTower K (RatFunc K) F :=
+    IsScalarTower.of_algebraMap_eq fun c => (ψ.commutes c).symm
+  have hEle : IntermediateField.adjoin K ({x} : Set F) ≤ ψ.fieldRange :=
+    IntermediateField.adjoin_le_iff.mpr (Set.singleton_subset_iff.mpr ⟨RatFunc.X, hψX⟩)
+  have : Module.Finite (RatFunc K) F := by
+    obtain ⟨s, hs⟩ := Module.finite_def.mp
+      (inferInstance : Module.Finite (IntermediateField.adjoin K ({x} : Set F)) F)
+    refine Module.finite_def.mpr ⟨s, ?_⟩
+    rw [eq_top_iff]
+    rintro f -
+    have hf : f ∈ Submodule.span (IntermediateField.adjoin K ({x} : Set F)) (s : Set F) := by
+      rw [hs]; trivial
+    induction hf using Submodule.span_induction with
+    | mem g hg => exact Submodule.subset_span hg
+    | zero => exact Submodule.zero_mem _
+    | add g h _ _ hg hh => exact Submodule.add_mem _ hg hh
+    | smul e g _ hg =>
+      obtain ⟨r, hr⟩ := hEle e.2
+      have hsm : e • g = r • g := by
+        rw [Algebra.smul_def, Algebra.smul_def, RingHom.algebraMap_toAlgebra]
+        have he' : algebraMap (IntermediateField.adjoin K ({x} : Set F)) F e = (e : F) := rfl
+        rw [he', ← hr]
+      rw [hsm]
+      exact Submodule.smul_mem _ r hg
+  have haev : ∀ p : Polynomial K,
+      Polynomial.aeval x p ∈ IntermediateField.adjoin K ({x} : Set F) := fun p =>
+    IntermediateField.algebra_adjoin_le_adjoin K _ (Polynomial.aeval_mem_adjoin_singleton K x)
+  have hle : ψ.fieldRange ≤ IntermediateField.adjoin K ({x} : Set F) := by
+    intro y hy
+    obtain ⟨z, rfl⟩ := AlgHom.mem_fieldRange.mp hy
+    rw [hψ_def, RatFunc.liftAlgHom_apply]
+    exact div_mem (haev z.num) (haev z.denom)
+  have hfr : ψ.fieldRange = IntermediateField.adjoin K ({x} : Set F) := le_antisymm hle hEle
+  let eKx : RatFunc K ≃ₐ[K] ↥(IntermediateField.adjoin K ({x} : Set F)) :=
+    (AlgEquiv.ofInjectiveField ψ).trans (IntermediateField.equivOfEq hfr)
+  have : Algebra.IsSeparable (RatFunc K) F := by
+    refine Algebra.IsSeparable.of_equiv_equiv eKx.symm.toRingEquiv (RingEquiv.refl F) ?_
+    refine RingHom.ext fun z => ?_
+    change ψ (eKx.symm z) = algebraMap (IntermediateField.adjoin K ({x} : Set F)) F z
+    have h1 : ψ (eKx.symm z) = ((eKx (eKx.symm z) : IntermediateField.adjoin K ({x} : Set F)) : F)
+      :=
+      rfl
+    rw [h1, eKx.apply_symm_apply, IntermediateField.algebraMap_apply]
+  obtain ⟨vinf, hvinf⟩ :=
+    AlgebraicCurve.RationalFunctionField.exists_forall_ne_ofHeightOneSpectrum (K := K)
+  obtain ⟨w, hw⟩ := AlgebraicCurve.Place.exists_comap_eq_toValuationSubring (F' := F) vinf
+  obtain ⟨e, he0, htrans⟩ :=
+    AlgebraicCurve.Place.exists_ord_algebraMap_eq_mul_ord w vinf hw.symm
+  refine ⟨w, ?_⟩
+  have hX := htrans RatFunc.X
+  have hordX : vinf.ord RatFunc.X = -1 := by
+    rw [AlgebraicCurve.RationalFunctionField.ord_eq_neg_intDegree_of_forall_ne_ofHeightOneSpectrum
+      vinf hvinf RatFunc.X_ne_zero, RatFunc.intDegree_X]
+  have hmapX : algebraMap (RatFunc K) F RatFunc.X = x := by
+    rw [RingHom.algebraMap_toAlgebra]
+    exact hψX
+  rw [hmapX, hordX] at hX
+  rw [hX, mul_neg_one, Left.neg_neg_iff]
+  exact_mod_cast he0
+
+theorem solution
+    {K F : Type*} [Field K] [Field F] [Algebra K F] [IsAlgClosed K] (j : F)
+    (hj : Transcendental K j) [FiniteDimensional (IntermediateField.adjoin K ({j} : Set F)) F]
+    {x : F} (hx : ∀ v : Place K F, v.ord x = 0) : x ∈ (algebraMap K F).range := by
+  have _ := hj
+  exact AlgebraicCurve.Place.mem_range_algebraMap_of_forall_ord_eq_zero_core
+    (fun z hz => AlgebraicCurve.finiteDimensional_adjoin_of_transcendental j hz)
+    (fun z hz _ _ => AlgebraicCurve.Place.exists_ord_neg_of_transcendental_of_isSeparable z hz)
+    hx
+
+end S_AlgebraicCurve_Place_mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed {K F : Type*}
+    [Field K] [Field F] [Algebra K F] [IsAlgClosed K] (j : F) (hj : Transcendental K j)
+    [FiniteDimensional (IntermediateField.adjoin K ({j} : Set F)) F] {x : F}
+    (hx : ∀ v : Place K F, v.ord x = 0) :
+    x ∈ (algebraMap K F).range :=
+  solution j hj hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_mem_toValuationSubring_of_isIntegral_adjoin.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_mem_toValuationSubring_of_isIntegral_adjoin.lean
new file mode 100644
index 0000000000..1ea6bff7ec
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_mem_toValuationSubring_of_isIntegral_adjoin.lean
@@ -0,0 +1,125 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.mem_toValuationSubring_of_isIntegral_adjoin
+(afab5c85-24ff-5086-95a7-9e4918ad135f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 64a65cfd-323a-5a4b-bde4-2d6044710ccb
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.RingTheory.Valuation.Integral
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Valuation subrings containing j are integrally closed over K[j]
+
+Theorem statement: `AlgebraicCurve.Place.mem_toValuationSubring_of_isIntegral_adjoin`
+(`afab5c85-24ff-5086-95a7-9e4918ad135f`), by Claude, 2026-09-05.
+
+Proof: submission `64a65cfd-323a-5a4b-bde4-2d6044710ccb`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+sense of the project: a valuation subring $\mathcal O_v =$ `v.toValuationSubring` of $F$ such that
+$\mathrm{algebraMap}\,K\,F(a) \in \mathcal O_v$ for every $a \in K$, such that $\mathcal O_v \neq
+F$, and such that the ring $\mathcal O_v$ is a principal ideal ring. Let $j, x \in F$, assume $j \in
+\mathcal O_v$, and assume that $x$ is integral over the $K$-subalgebra $\mathrm{Algebra.adjoin}\ K\
+\{j\} = K[j]$ of $F$, i.e. $x$ is a root of a monic polynomial with coefficients in $K[j]$. The
+conclusion is that $x \in \mathcal O_v$. Thus the statement is the integral closedness of $\mathcal
+O_v$ in $F$ combined with the containment $K[j] \subseteq \mathcal O_v$; the proof uses only that
+$\mathcal O_v$ is a valuation subring of $F$ containing the image of $K$, not that it is proper or a
+principal ideal ring.
+
+This is the standard fact that a valuation ring is integrally closed in its fraction field, packaged
+for places of a function field $F/K$ and for integrality over a simple $K$-subalgebra $K[j]$. It
+serves as the bridge used throughout the divisor-theoretic part of the development, for instance
+when locating the support of a modular unit: it is invoked to conclude that an element integral over
+$\mathbb Q[j]$ lies in every valuation subring containing $j$, and is cited by the results on orders
+of such elements and on divisors (for example
+[`AlgebraicCurve.Place.ord_eq_zero_of_isIntegral_adjoin`]
+(thm.html#AlgebraicCurve.Place.ord_eq_zero_of_isIntegral_adjoin)).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_mem_toValuationSubring_of_isIntegral_adjoin.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_mem_toValuationSubring_of_isIntegral_adjoin
+
+open AlgebraicCurve
+
+namespace ModularCurve
+
+namespace QexpN
+
+private def placeSubalgebra {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) :
+    Subalgebra K F :=
+  { v.toValuationSubring.toSubring.toSubsemiring with algebraMap_mem' := v.algebraMap_mem' }
+
+private theorem mem_placeSubalgebra {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) {y : F} :
+    y ∈ placeSubalgebra v ↔ y ∈ v.toValuationSubring := Iff.rfl
+
+private theorem valuationSubring_integers {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) :
+    (v.toValuationSubring.valuation).Integers v.toValuationSubring :=
+  { hom_inj := Subtype.coe_injective
+    map_le_one := fun a => v.toValuationSubring.valuation_le_one a
+    exists_of_le_one := fun {r} hr =>
+      ⟨⟨r, v.toValuationSubring.mem_of_valuation_le_one r hr⟩, rfl⟩ }
+
+private theorem mem_of_isIntegral_adjoin {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) {j x : F} (hj : j ∈ v.toValuationSubring)
+    (hx : IsIntegral (Algebra.adjoin K {j}) x) : x ∈ v.toValuationSubring := by
+  have hle : Algebra.adjoin K {j} ≤ placeSubalgebra v :=
+    Algebra.adjoin_le (Set.singleton_subset_iff.mpr ((mem_placeSubalgebra v).mpr hj))
+  let φ' : ↥(Algebra.adjoin K {j}) →+* ↥(v.toValuationSubring) :=
+    { toFun := fun a => ⟨(a : F), (mem_placeSubalgebra v).mp (hle a.2)⟩
+      map_one' := rfl
+      map_mul' := fun _ _ => rfl
+      map_zero' := rfl
+      map_add' := fun _ _ => rfl }
+  have hOx : IsIntegral (↥v.toValuationSubring) x :=
+    IsIntegral.map_of_comp_eq φ' (RingHom.id F) (by ext a; rfl) hx
+  exact v.toValuationSubring.mem_of_valuation_le_one x
+    ((valuationSubring_integers v).isIntegral_iff_v_le_one.mp hOx)
+
+end QexpN
+
+end ModularCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) {j x : F}
+    (hj : j ∈ v.toValuationSubring) (hx : IsIntegral (Algebra.adjoin K {j}) x) :
+    x ∈ v.toValuationSubring :=
+  ModularCurve.QexpN.mem_of_isIntegral_adjoin v hj hx
+
+end S_AlgebraicCurve_Place_mem_toValuationSubring_of_isIntegral_adjoin
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_mem_toValuationSubring_of_isIntegral_adjoin (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.mem_toValuationSubring_of_isIntegral_adjoin {K F : Type*} [Field K]
+    [Field F] [Algebra K F] (v : Place K F) {j x : F} (hj : j ∈ v.toValuationSubring)
+    (hx : IsIntegral (Algebra.adjoin K {j}) x) :
+    x ∈ v.toValuationSubring :=
+  solution v hj hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_min_ord_le_ord_add.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_min_ord_le_ord_add.lean
new file mode 100644
index 0000000000..5d91ef432d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_min_ord_le_ord_add.lean
@@ -0,0 +1,99 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.min_ord_le_ord_add
+(53d68399-5d09-50f9-b4eb-2f8e8477f42d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 0d17451d-b08c-5c66-a8d5-342e7d970351
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Ultrametric inequality for ord at a place
+
+Theorem statement: `AlgebraicCurve.Place.min_ord_le_ord_add`
+(`53d68399-5d09-50f9-b4eb-2f8e8477f42d`), by Claude, 2026-09-05.
+
+Proof: submission `0d17451d-b08c-5c66-a8d5-342e7d970351`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+sense of the project: a valuation subring of $F$ that contains the image of $K$ under the structure
+map, is not the whole of $F$, and is a principal ideal ring. Write $v$ also for the associated adic
+valuation $F \to \mathbb{Z}^{m0}$ attached to the height-one prime of this valuation ring, and set
+$\operatorname{ord}_v(f) = -\log\bigl(v(f)\bigr) \in \mathbb{Z}$, the negated logarithm of that
+value in $\mathbb{Z}^{m0} = \mathbb{Z} \cup \{0\}$ written multiplicatively. Let $f, g \in F$ with
+$f \neq 0$, $g \neq 0$ and $f + g \neq 0$. Then $$\min\bigl(\operatorname{ord}_v f,
+\operatorname{ord}_v g\bigr) \le \operatorname{ord}_v(f+g).$$ The nonvanishing hypotheses are what
+make the three logarithms genuine integers rather than the default value assigned to $0$; no further
+assumption on $K$, $F$ or the characteristic is made.
+
+This is the ultrametric (strong triangle) inequality in the additive normalisation used for order
+functions at places of a function field, and it underlies the basic manipulations with divisors: it
+is invoked throughout the divisor and divisor-class-group development, for instance in the study of
+kernels of symmetric value matrices and in descent statements for torsion divisor classes along a
+constant field extension.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_min_ord_le_ord_add.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_min_ord_le_ord_add
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ord"
+namespace FF2S
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem le_ord_add (v : Place K F) {f g : F} (hf : f ≠ 0) (hg : g ≠ 0) (hfg : f + g ≠ 0) :
+    min (v.ord f) (v.ord g) ≤ v.ord (f + g) := by
+  have hf' := v.adicValuation_ne_zero hf
+  have hg' := v.adicValuation_ne_zero hg
+  have hfg' := v.adicValuation_ne_zero hfg
+  have hmax : v.adicValuation (f + g) ≤ max (v.adicValuation f) (v.adicValuation g) :=
+    Valuation.map_add _ _ _
+  unfold Place.ord
+  rcases le_max_iff.mp hmax with hle | hle
+  · have := (WithZero.log_le_log hfg' hf').mpr hle
+    omega
+  · have := (WithZero.log_le_log hfg' hg').mpr hle
+    omega
+
+end AlgebraicCurve.FF2S
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : AlgebraicCurve.Place K F)
+    {f g : F} (hf : f ≠ 0) (hg : g ≠ 0) (hfg : f + g ≠ 0) :
+    min (v.ord f) (v.ord g) ≤ v.ord (f + g) :=
+  AlgebraicCurve.FF2S.le_ord_add v hf hg hfg
+
+end S_AlgebraicCurve_Place_min_ord_le_ord_add
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_min_ord_le_ord_add (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.min_ord_le_ord_add {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : AlgebraicCurve.Place K F) {f g : F} (hf : f ≠ 0) (hg : g ≠ 0) (hfg : f + g ≠ 0) :
+    min (v.ord f) (v.ord g) ≤ v.ord (f + g) :=
+  solution v hf hg hfg
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_min_ord_le_ord_add_v2.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_min_ord_le_ord_add_v2.lean
new file mode 100644
index 0000000000..0ed46986a9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_min_ord_le_ord_add_v2.lean
@@ -0,0 +1,36 @@
+/-
+Copyright (c) 2026 David Loeffler. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: David Loeffler
+
+Proof extracted from Definitions.FLT.Defs_IsogenyEndDatum_sharedLibrary.
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_min_ord_le_ord_add
+
+/-!
+# Ultrametric inequality for the order at a place, allowing zero summands
+
+The nonvanishing assumption on the sum suffices: either summand may be zero.
+-/
+
+public section publicSection
+
+namespace AlgebraicCurve.Place
+
+theorem min_ord_le_ord_add' {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) {f g : F} (hfg : f + g ≠ 0) :
+    min (v.ord f) (v.ord g) ≤ v.ord (f + g) := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · simp
+  rcases eq_or_ne g 0 with rfl | hg
+  · simp
+  exact v.min_ord_le_ord_add hf hg hfg
+
+end AlgebraicCurve.Place
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ordDiff_D_eq_ord_sub_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ordDiff_D_eq_ord_sub_one.lean
new file mode 100644
index 0000000000..2b5c1b4b22
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ordDiff_D_eq_ord_sub_one.lean
@@ -0,0 +1,242 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.ordDiff_D_eq_ord_sub_one
+(e47cd320-aa83-5adf-89df-8b840fc002f1) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7191dcfb-0764-5a3c-a366-0fb6b581d97b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_D_ne_zero_of_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_diffCoeff_smul_D_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_add_eq_of_lt
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_natCast
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# ordᵥ(df) = ordᵥ(f) - 1 at zeros and poles
+
+Theorem statement: `AlgebraicCurve.Place.ordDiff_D_eq_ord_sub_one`
+(`e47cd320-aa83-5adf-89df-8b840fc002f1`), by Claude, 2026-09-05.
+
+Proof: submission `7191dcfb-0764-5a3c-a366-0fb6b581d97b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field of characteristic zero, $F$ a field equipped with a $K$-algebra structure, and
+suppose some $x \in F$ is such that $F$ is finite-dimensional over the intermediate field $K(x)$
+generated by $x$. Let $v$ be a place of $F$ over $K$ in the sense of the structure `Place`, that is,
+a valuation subring of $F$ containing the image of $K$, distinct from all of $F$, and a principal
+ideal ring; write $\operatorname{ord}_v$ for the associated normalised integer valuation, obtained
+as minus the logarithm of the $\mathbb{Z}^{m0}$-valued adic valuation of the height-one prime of
+$v$. For $\omega \in \Omega[F\,⁄\,K]$ put $\operatorname{ordDiff}_v(\omega) =
+\operatorname{ord}_v(g)$, where $t$ is a chosen element with $\operatorname{ord}_v(t) = 1$ and $g$
+is a chosen element of $F$ with $\omega = g \cdot D_{K/F}(t)$ (both choices default to $0$ if no
+such element exists). Then for every $f \in F$ with $\operatorname{ord}_v(f) \neq 0$ one has
+$\operatorname{ordDiff}_v(D_{K/F}(f)) = \operatorname{ord}_v(f) - 1$, a single formula covering both
+zeros and poles of $f$.
+
+This is the local computation of the order of a differential at a zero or pole, in the form
+$\operatorname{ord}_v(df) = \operatorname{ord}_v(f) - 1$ for $\operatorname{ord}_v(f) \neq 0$, valid
+in characteristic zero where no $p$-th power phenomenon can occur. It feeds the computation of
+canonical divisors and hence the genus of modular curves, being used in the identification of the
+genus of the modular function field with the genus formula and in the study of regular differentials
+there.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ordDiff_D_eq_ord_sub_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ordDiff_D_eq_ord_sub_one
+
+noncomputable section
+open KaehlerDifferential
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.diffCoeff Place.ordDiff_def Place \
+  Place.D_ne_zero_of_ord_ne_zero Place.diffCoeff_smul_D_of_ord_ne_zero Place.diffCoeff_smul_D_eq \
+  Place.ord_diffCoeff_D_nonneg Place.ord_add_eq_of_lt"
+namespace FF2R4A
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+section R3grade
+variable [CharZero K] (x : F) [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+
+include x in
+theorem ordDiff_smul (v : Place K F) {g : F} (hg : g ≠ 0) {ω : Ω[F⁄K]} (hω : ω ≠ 0) :
+    v.ordDiff (g • ω) = v.ord g + v.ordDiff ω := by
+  have h1 : v.ord v.uniformizer_alt ≠ 0 := by
+    rw [v.ord_uniformizer_alt v.exists_ord_eq_one]; exact one_ne_zero
+  set a := Place.diffCoeff v.uniformizer_alt ω with ha
+  have hωa : a • D K F v.uniformizer_alt = ω := Place.diffCoeff_smul_D_of_ord_ne_zero x v h1 ω
+  have ha0 : a ≠ 0 := by
+    intro h0; rw [h0, zero_smul] at hωa; exact hω hωa.symm
+  rw [Place.ordDiff_def, Place.ordDiff_def, ← ha, ← hωa, smul_smul,
+    Place.diffCoeff_smul_D_eq x v h1, v.ord_mul hg ha0]
+
+end R3grade
+
+section R4grade
+variable [CharZero K] (x : F) [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+
+include x in
+theorem ord_diffCoeff_D_eq_zero (v : Place K F) {t t' : F} (ht : v.ord t = 1) (ht' : v.ord t' = 1) :
+    v.ord (Place.diffCoeff t (D K F t')) = 0 := by
+  have ht0 : v.ord t ≠ 0 := by rw [ht]; exact one_ne_zero
+  have ht0' : v.ord t' ≠ 0 := by rw [ht']; exact one_ne_zero
+  set c := Place.diffCoeff t (D K F t') with hc
+  set c' := Place.diffCoeff t' (D K F t) with hc'
+  have h1 : c • D K F t = D K F t' := Place.diffCoeff_smul_D_of_ord_ne_zero x v ht0 _
+  have h2 : c' • D K F t' = D K F t := Place.diffCoeff_smul_D_of_ord_ne_zero x v ht0' _
+  have hcc : c * c' = 1 := by
+    have h3 : (c * c') • D K F t' = (1 : F) • D K F t' := by
+      rw [one_smul, ← smul_smul, h2, h1]
+    exact smul_left_injective F (Place.D_ne_zero_of_ord_ne_zero x v ht0') h3
+  have hc0 : c ≠ 0 := left_ne_zero_of_mul_eq_one hcc
+  have hc0' : c' ≠ 0 := right_ne_zero_of_mul_eq_one hcc
+  have hsum : v.ord c + v.ord c' = 0 := by rw [← v.ord_mul hc0 hc0', hcc, v.ord_one]
+  have hge : 0 ≤ v.ord c := Place.ord_diffCoeff_D_nonneg x v ht (by rw [ht']; exact zero_le_one)
+  have hge' : 0 ≤ v.ord c' := Place.ord_diffCoeff_D_nonneg x v ht' (by rw [ht]; exact zero_le_one)
+  omega
+
+include x in
+theorem ordDiff_eq_ord_diffCoeff (v : Place K F) {t : F} (ht : v.ord t = 1) (ω : Ω[F⁄K]) :
+    v.ordDiff ω = v.ord (Place.diffCoeff t ω) := by
+  have ht0 : v.ord t ≠ 0 := by rw [ht]; exact one_ne_zero
+  have hu : v.ord v.uniformizer_alt = 1 := v.ord_uniformizer_alt v.exists_ord_eq_one
+  have hu0 : v.ord v.uniformizer_alt ≠ 0 := by rw [hu]; exact one_ne_zero
+  set a := Place.diffCoeff t ω with ha
+  set c := Place.diffCoeff v.uniformizer_alt (D K F t) with hc
+  have hω : a • D K F t = ω := Place.diffCoeff_smul_D_of_ord_ne_zero x v ht0 ω
+  have hDt : c • D K F v.uniformizer_alt = D K F t :=
+    Place.diffCoeff_smul_D_of_ord_ne_zero x v hu0 _
+  have hc0 : c ≠ 0 := by
+    rintro h; rw [h, zero_smul] at hDt; exact Place.D_ne_zero_of_ord_ne_zero x v ht0 hDt.symm
+  have hcord : v.ord c = 0 := ord_diffCoeff_D_eq_zero x v hu ht
+  rw [Place.ordDiff_def, ← hω, ← hDt, smul_smul, Place.diffCoeff_smul_D_eq x v hu0]
+  rcases eq_or_ne a 0 with h0 | ha0
+  · rw [h0, zero_mul]
+  · rw [v.ord_mul ha0 hc0, hcord, add_zero]
+
+include x in
+theorem ordDiff_D_nonneg (v : Place K F) {f : F} (hf : 0 ≤ v.ord f) : 0 ≤ v.ordDiff (D K F f) := by
+  obtain ⟨t, ht⟩ := v.exists_ord_eq_one
+  rw [ordDiff_eq_ord_diffCoeff x v ht]
+  exact Place.ord_diffCoeff_D_nonneg x v ht hf
+
+include x in
+theorem ordDiff_D_of_ord_pos (v : Place K F) {f : F} (hf : 0 < v.ord f) :
+    v.ordDiff (D K F f) = v.ord f - 1 := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπord : v.ord (π : F) = 1 := v.ord_coe_irreducible hπ
+  have hπ0 : v.ord (π : F) ≠ 0 := by rw [hπord]; exact one_ne_zero
+  have hf0 : f ≠ 0 := by rintro rfl; simp at hf
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf0 hπ
+  obtain ⟨n, hn⟩ : ∃ n : ℕ, v.ord f = n := ⟨(v.ord f).toNat, (Int.toNat_of_nonneg hf.le).symm⟩
+  have hn0 : n ≠ 0 := by rintro rfl; simp [hn] at hf
+  rw [hn, zpow_natCast] at hu
+  have : CharZero F := charZero_of_injective_algebraMap (algebraMap K F).injective
+  set uF : F := ((u : v.toValuationSubring) : F) with huF
+  have huF0 : uF ≠ 0 := by
+    intro h; apply hf0; rw [hu, h, zero_mul]
+  have hπF : (π : F) ≠ 0 := by
+    intro h; rw [h, v.ord_zero] at hπord; exact zero_ne_one hπord
+  have hnF : (n : F) ≠ 0 := Nat.cast_ne_zero.mpr hn0
+  have huord : v.ord uF = 0 := v.ord_coe_unit u
+  set cu := Place.diffCoeff (π : F) (D K F uF) with hcu
+  have hcu_ge : 0 ≤ v.ord cu := Place.ord_diffCoeff_D_nonneg x v hπord huord.ge
+  have hDu : cu • D K F (π : F) = D K F uF := Place.diffCoeff_smul_D_of_ord_ne_zero x v hπ0 _
+  have hDf : D K F f = (uF * (n * (π : F) ^ (n - 1)) + (π : F) ^ n * cu) • D K F (π : F) := by
+    rw [hu, Derivation.leibniz, Derivation.leibniz_pow, ← hDu, ← Nat.cast_smul_eq_nsmul F]
+    simp only [smul_smul]
+    rw [← add_smul]
+  rw [ordDiff_eq_ord_diffCoeff x v hπord, hDf, Place.diffCoeff_smul_D_eq x v hπ0, hn]
+  have hπn1 : v.ord ((π : F) ^ (n - 1)) = ((n - 1 : ℕ) : ℤ) := by
+    rw [← zpow_natCast, v.ord_zpow, hπord, mul_one]
+  have hA0 : uF * (n * (π : F) ^ (n - 1)) ≠ 0 :=
+    mul_ne_zero huF0 (mul_ne_zero hnF (pow_ne_zero _ hπF))
+  have hA : v.ord (uF * (n * (π : F) ^ (n - 1))) = ((n - 1 : ℕ) : ℤ) := by
+    rw [v.ord_mul huF0 (mul_ne_zero hnF (pow_ne_zero _ hπF)), huord, zero_add,
+      v.ord_mul hnF (pow_ne_zero _ hπF), v.ord_natCast n, zero_add, hπn1]
+  have hsub : ((n - 1 : ℕ) : ℤ) = (n : ℤ) - 1 := by
+    rw [Nat.cast_sub (Nat.one_le_iff_ne_zero.mpr hn0)]; simp
+  rcases eq_or_ne cu 0 with hcu0 | hcu0
+  · rw [hcu0, mul_zero, add_zero, hA, hsub]
+  · have hB : v.ord ((π : F) ^ n * cu) = (n : ℤ) + v.ord cu := by
+      rw [v.ord_mul (pow_ne_zero _ hπF) hcu0, ← zpow_natCast, v.ord_zpow, hπord, mul_one]
+    rw [Place.ord_add_eq_of_lt v hA0 (mul_ne_zero (pow_ne_zero _ hπF) hcu0) (by
+      rw [hA, hB, hsub]; omega), hA, hsub]
+
+include x in
+theorem ordDiff_D_eq_ord_sub_one (v : Place K F) {f : F} (hf : v.ord f ≠ 0) :
+    v.ordDiff (D K F f) = v.ord f - 1 := by
+  rcases lt_or_gt_of_ne hf with hneg | hpos
+  · have hf0 : f ≠ 0 := by rintro rfl; simp at hneg
+    have hinv : 0 < v.ord f⁻¹ := by rw [v.ord_inv]; omega
+    have hinv0 : v.ord f⁻¹ ≠ 0 := hinv.ne'
+    have hDf : D K F f = (-(f ^ 2)) • D K F f⁻¹ := by
+      rw [Derivation.leibniz_inv, smul_smul]
+      have : -(f ^ 2) * -(f⁻¹ ^ 2) = 1 := by field_simp
+      rw [this, one_smul]
+    rw [hDf, ordDiff_smul x v (neg_ne_zero.mpr (pow_ne_zero 2 hf0))
+      (Place.D_ne_zero_of_ord_ne_zero x v hinv0), ordDiff_D_of_ord_pos x v hinv, v.ord_neg,
+      ← zpow_natCast, v.ord_zpow, v.ord_inv]
+    push_cast
+    ring
+  · exact ordDiff_D_of_ord_pos x v hpos
+
+include x in
+theorem ordDiff_D_eq_ord_sub_algebraMap_sub_one (v : Place K F) {f : F} {c : K}
+    (hfc : v.ord (f - algebraMap K F c) ≠ 0) :
+    v.ordDiff (D K F f) = v.ord (f - algebraMap K F c) - 1 := by
+  have : D K F f = D K F (f - algebraMap K F c) := by
+    rw [map_sub, Derivation.map_algebraMap, sub_zero]
+  rw [this, ordDiff_D_eq_ord_sub_one x v hfc]
+
+end R4grade
+
+end AlgebraicCurve.FF2R4A
+
+end
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [CharZero K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (v : AlgebraicCurve.Place K F)
+    {f : F} (hf : v.ord f ≠ 0) :
+    v.ordDiff (KaehlerDifferential.D K F f) = v.ord f - 1 :=
+  AlgebraicCurve.FF2R4A.ordDiff_D_eq_ord_sub_one x v hf
+
+end S_AlgebraicCurve_Place_ordDiff_D_eq_ord_sub_one
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ordDiff_D_eq_ord_sub_one (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.ordDiff_D_eq_ord_sub_one {K F : Type*} [Field K] [Field F]
+    [Algebra K F] [CharZero K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (v : AlgebraicCurve.Place K F)
+    {f : F} (hf : v.ord f ≠ 0) :
+    v.ordDiff (KaehlerDifferential.D K F f) = v.ord f - 1 :=
+  solution x v hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ordDiff_eq_ordDifferential.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ordDiff_eq_ordDifferential.lean
new file mode 100644
index 0000000000..70a3eaa54d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ordDiff_eq_ordDifferential.lean
@@ -0,0 +1,110 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.ordDiff_eq_ordDifferential
+(09c76274-63ea-5dda-a3a7-31d65caf24cb) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 74f859ed-68d5-5060-a01e-fa47323f8f42
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CanonicalDivisor
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_diffCoeff_smul_D_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ordDiff_eq_ord_diffCoeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_dCoordGenerates_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_iff_exists_transcendental_finiteDimensional
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The two orders of a differential at a place agree
+
+Theorem statement: `AlgebraicCurve.Place.ordDiff_eq_ordDifferential`
+(`09c76274-63ea-5dda-a3a7-31d65caf24cb`), by Claude, 2026-09-05.
+
+Proof: submission `74f859ed-68d5-5060-a01e-fa47323f8f42`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, $K$ of characteristic zero, $F$ essentially of
+finite type over $K$, and suppose $F/K$ satisfies the curve axioms of `IsCurveOver`: every nonzero
+$f \in F$ has a divisor of degree $0$ whose value at each place $v$ is $\mathrm{ord}_v f$, each
+residue field $\mathcal{O}_v/\mathfrak{m}_v$ is finite-dimensional over $K$, and $\Omega_{F/K}$ is
+free of rank $1$ over $F$. Let $v$ be a place of $F/K$ (a valuation subring of $F$ containing the
+image of $K$, distinct from $F$ itself, and a principal ideal ring) and let $\omega \in
+\Omega_{F/K}$. The assertion is the equality of two integers attached to $\omega$ at $v$: on one
+side $\mathrm{ord}_v$ of the coefficient $g$ in a representation $\omega = g \cdot \mathrm{d}t$,
+where $t$ is the element chosen by `uniformizer_alt` from those with $\mathrm{ord}_v t = 1$ (and
+$g$, as in `diffCoeff`, is a chosen solution, $0$ if none exists); on the other side
+$\mathrm{ord}_v$ of the coefficient chosen by `differentialCoeff` in a representation $\omega = f
+\cdot \mathrm{dCoord}_v$.
+
+This is the well-definedness of the order of a differential at a place in the form needed here: the
+two formalisations of that order, one computed against a chosen element of valuation $1$ and one
+against the distinguished coordinate differential $\mathrm{dCoord}_v$, define the same integer. It
+is used to transfer results between the two settings, for instance in the identification of regular
+differentials and in the computations of orders of Wronskians on modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ordDiff_eq_ordDifferential.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ordDiff_eq_ordDifferential
+
+open AlgebraicCurve IntermediateField
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [CharZero K] [Algebra.EssFiniteType K F] [AlgebraicCurve.IsCurveOver K F]
+    (v : AlgebraicCurve.Place K F) (ω : Ω[F⁄K]) :
+    v.ordDiff ω = v.ordDifferential ω := by
+  have : PerfectField K := inferInstance
+  have : v.DCoordGenerates := AlgebraicCurve.dCoordGenerates_of_isCurveOver v
+  obtain ⟨x, -, hfin, -⟩ :=
+    (AlgebraicCurve.isCurveOver_iff_exists_transcendental_finiteDimensional (K := K) (F := F)).mp
+      inferInstance
+  have := hfin
+  have : Algebra.IsAlgebraic K⟮x⟯ F := Algebra.IsAlgebraic.of_finite K⟮x⟯ F
+  have hirr := (IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose_spec
+  have hπ₀ : v.ord ((IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose : F) =
+    1 :=
+    v.ord_coe_irreducible hirr
+  have hd : v.dCoord = KaehlerDifferential.D K F
+      ((IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose : F) := rfl
+  have hω : ω = v.differentialCoeff ω • KaehlerDifferential.D K F
+      ((IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose : F) := by
+    rw [← hd, v.differentialCoeff_smul_dCoord]
+  rw [AlgebraicCurve.Place.ordDiff_eq_ord_diffCoeff x v hπ₀ ω]
+  change _ = v.ord (v.differentialCoeff ω)
+  conv_lhs => rw [hω]
+  rw [AlgebraicCurve.Place.diffCoeff_smul_D_eq x v (by rw [hπ₀]; exact one_ne_zero)]
+
+end S_AlgebraicCurve_Place_ordDiff_eq_ordDifferential
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ordDiff_eq_ordDifferential (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.ordDiff_eq_ordDifferential {K F : Type*} [Field K] [Field F]
+    [Algebra K F]
+    [CharZero K] [Algebra.EssFiniteType K F] [AlgebraicCurve.IsCurveOver K F]
+    (v : AlgebraicCurve.Place K F) (ω : Ω[F⁄K]) :
+    v.ordDiff ω = v.ordDifferential ω :=
+  solution v ω
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ordDiff_eq_ord_diffCoeff.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ordDiff_eq_ord_diffCoeff.lean
new file mode 100644
index 0000000000..1d02017fd3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ordDiff_eq_ord_diffCoeff.lean
@@ -0,0 +1,243 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.ordDiff_eq_ord_diffCoeff
+(9b156dc4-1387-545b-8328-21470075c19f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5736f467-f36f-502f-acf8-ccf2179ee9aa
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_D_ne_zero_of_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_diffCoeff_smul_D_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_add_eq_of_lt
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_natCast
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order of a differential is independent of the uniformiser
+
+Theorem statement: `AlgebraicCurve.Place.ordDiff_eq_ord_diffCoeff`
+(`9b156dc4-1387-545b-8328-21470075c19f`), by Claude, 2026-09-05.
+
+Proof: submission `5736f467-f36f-502f-acf8-ccf2179ee9aa`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, $K$ of characteristic zero, and let $x \in F$ be
+such that $F$ is finite-dimensional over the intermediate field $K(x) =$ `IntermediateField.adjoin K
+{x}`. Let $v$ be a place of $F$ over $K$, that is, a valuation subring of $F$ containing
+$\operatorname{image}(K \to F)$, distinct from $F$ itself, whose ring is a principal ideal ring;
+write $\operatorname{ord}_v(f)$ for $-\log$ of the associated adic valuation of $f$, so that
+$\operatorname{ord}_v$ is the normalised integer-valued order function at $v$. Let $t \in F$ satisfy
+$\operatorname{ord}_v(t) = 1$, and let $\omega \in \Omega_{F/K}$ be a Kähler differential. Then
+$\operatorname{ordDiff}_v(\omega) = \operatorname{ord}_v\bigl(\operatorname{diffCoeff}(t,
+\omega)\bigr)$, where $\operatorname{diffCoeff}(s, \omega)$ denotes a chosen $g \in F$ with $\omega
+= g \cdot \mathrm{d}s$ when such a $g$ exists and $0$ otherwise, and where
+$\operatorname{ordDiff}_v(\omega)$ is by definition
+$\operatorname{ord}_v\bigl(\operatorname{diffCoeff}(t_v, \omega)\bigr)$ for one fixed choice $t_v$
+of an element of $F$ of order $1$ at $v$. Thus the value computed from the fixed choice agrees with
+the value computed from an arbitrary $t$ of order $1$, with no hypothesis on $\omega$.
+
+This is the well-definedness statement for the order of a differential at a place of a function
+field of one variable in characteristic zero: the integer $\operatorname{ord}_v(\omega)$ depends
+only on $\omega$ and $v$, not on the uniformiser used to express $\omega$ as $g\,\mathrm{d}t$. It
+underlies the comparison of `ordDiff` with the order of the associated differential and is used in
+the estimates for Wronskian differentials and heights on the modular curve $X_0$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ordDiff_eq_ord_diffCoeff.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ordDiff_eq_ord_diffCoeff
+
+noncomputable section
+open KaehlerDifferential
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.diffCoeff Place.ordDiff_def Place \
+  Place.D_ne_zero_of_ord_ne_zero Place.diffCoeff_smul_D_of_ord_ne_zero Place.diffCoeff_smul_D_eq \
+  Place.ord_diffCoeff_D_nonneg Place.ord_add_eq_of_lt"
+namespace FF2R4A
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+section R3grade
+variable [CharZero K] (x : F) [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+
+include x in
+theorem ordDiff_smul (v : Place K F) {g : F} (hg : g ≠ 0) {ω : Ω[F⁄K]} (hω : ω ≠ 0) :
+    v.ordDiff (g • ω) = v.ord g + v.ordDiff ω := by
+  have h1 : v.ord v.uniformizer_alt ≠ 0 := by
+    rw [v.ord_uniformizer_alt v.exists_ord_eq_one]; exact one_ne_zero
+  set a := Place.diffCoeff v.uniformizer_alt ω with ha
+  have hωa : a • D K F v.uniformizer_alt = ω := Place.diffCoeff_smul_D_of_ord_ne_zero x v h1 ω
+  have ha0 : a ≠ 0 := by
+    intro h0; rw [h0, zero_smul] at hωa; exact hω hωa.symm
+  rw [Place.ordDiff_def, Place.ordDiff_def, ← ha, ← hωa, smul_smul,
+    Place.diffCoeff_smul_D_eq x v h1, v.ord_mul hg ha0]
+
+end R3grade
+
+section R4grade
+variable [CharZero K] (x : F) [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+
+include x in
+theorem ord_diffCoeff_D_eq_zero (v : Place K F) {t t' : F} (ht : v.ord t = 1) (ht' : v.ord t' = 1) :
+    v.ord (Place.diffCoeff t (D K F t')) = 0 := by
+  have ht0 : v.ord t ≠ 0 := by rw [ht]; exact one_ne_zero
+  have ht0' : v.ord t' ≠ 0 := by rw [ht']; exact one_ne_zero
+  set c := Place.diffCoeff t (D K F t') with hc
+  set c' := Place.diffCoeff t' (D K F t) with hc'
+  have h1 : c • D K F t = D K F t' := Place.diffCoeff_smul_D_of_ord_ne_zero x v ht0 _
+  have h2 : c' • D K F t' = D K F t := Place.diffCoeff_smul_D_of_ord_ne_zero x v ht0' _
+  have hcc : c * c' = 1 := by
+    have h3 : (c * c') • D K F t' = (1 : F) • D K F t' := by
+      rw [one_smul, ← smul_smul, h2, h1]
+    exact smul_left_injective F (Place.D_ne_zero_of_ord_ne_zero x v ht0') h3
+  have hc0 : c ≠ 0 := left_ne_zero_of_mul_eq_one hcc
+  have hc0' : c' ≠ 0 := right_ne_zero_of_mul_eq_one hcc
+  have hsum : v.ord c + v.ord c' = 0 := by rw [← v.ord_mul hc0 hc0', hcc, v.ord_one]
+  have hge : 0 ≤ v.ord c := Place.ord_diffCoeff_D_nonneg x v ht (by rw [ht']; exact zero_le_one)
+  have hge' : 0 ≤ v.ord c' := Place.ord_diffCoeff_D_nonneg x v ht' (by rw [ht]; exact zero_le_one)
+  omega
+
+include x in
+theorem ordDiff_eq_ord_diffCoeff (v : Place K F) {t : F} (ht : v.ord t = 1) (ω : Ω[F⁄K]) :
+    v.ordDiff ω = v.ord (Place.diffCoeff t ω) := by
+  have ht0 : v.ord t ≠ 0 := by rw [ht]; exact one_ne_zero
+  have hu : v.ord v.uniformizer_alt = 1 := v.ord_uniformizer_alt v.exists_ord_eq_one
+  have hu0 : v.ord v.uniformizer_alt ≠ 0 := by rw [hu]; exact one_ne_zero
+  set a := Place.diffCoeff t ω with ha
+  set c := Place.diffCoeff v.uniformizer_alt (D K F t) with hc
+  have hω : a • D K F t = ω := Place.diffCoeff_smul_D_of_ord_ne_zero x v ht0 ω
+  have hDt : c • D K F v.uniformizer_alt = D K F t :=
+    Place.diffCoeff_smul_D_of_ord_ne_zero x v hu0 _
+  have hc0 : c ≠ 0 := by
+    rintro h; rw [h, zero_smul] at hDt; exact Place.D_ne_zero_of_ord_ne_zero x v ht0 hDt.symm
+  have hcord : v.ord c = 0 := ord_diffCoeff_D_eq_zero x v hu ht
+  rw [Place.ordDiff_def, ← hω, ← hDt, smul_smul, Place.diffCoeff_smul_D_eq x v hu0]
+  rcases eq_or_ne a 0 with h0 | ha0
+  · rw [h0, zero_mul]
+  · rw [v.ord_mul ha0 hc0, hcord, add_zero]
+
+include x in
+theorem ordDiff_D_nonneg (v : Place K F) {f : F} (hf : 0 ≤ v.ord f) : 0 ≤ v.ordDiff (D K F f) := by
+  obtain ⟨t, ht⟩ := v.exists_ord_eq_one
+  rw [ordDiff_eq_ord_diffCoeff x v ht]
+  exact Place.ord_diffCoeff_D_nonneg x v ht hf
+
+include x in
+theorem ordDiff_D_of_ord_pos (v : Place K F) {f : F} (hf : 0 < v.ord f) :
+    v.ordDiff (D K F f) = v.ord f - 1 := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπord : v.ord (π : F) = 1 := v.ord_coe_irreducible hπ
+  have hπ0 : v.ord (π : F) ≠ 0 := by rw [hπord]; exact one_ne_zero
+  have hf0 : f ≠ 0 := by rintro rfl; simp at hf
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf0 hπ
+  obtain ⟨n, hn⟩ : ∃ n : ℕ, v.ord f = n := ⟨(v.ord f).toNat, (Int.toNat_of_nonneg hf.le).symm⟩
+  have hn0 : n ≠ 0 := by rintro rfl; simp [hn] at hf
+  rw [hn, zpow_natCast] at hu
+  have : CharZero F := charZero_of_injective_algebraMap (algebraMap K F).injective
+  set uF : F := ((u : v.toValuationSubring) : F) with huF
+  have huF0 : uF ≠ 0 := by
+    intro h; apply hf0; rw [hu, h, zero_mul]
+  have hπF : (π : F) ≠ 0 := by
+    intro h; rw [h, v.ord_zero] at hπord; exact zero_ne_one hπord
+  have hnF : (n : F) ≠ 0 := Nat.cast_ne_zero.mpr hn0
+  have huord : v.ord uF = 0 := v.ord_coe_unit u
+  set cu := Place.diffCoeff (π : F) (D K F uF) with hcu
+  have hcu_ge : 0 ≤ v.ord cu := Place.ord_diffCoeff_D_nonneg x v hπord huord.ge
+  have hDu : cu • D K F (π : F) = D K F uF := Place.diffCoeff_smul_D_of_ord_ne_zero x v hπ0 _
+  have hDf : D K F f = (uF * (n * (π : F) ^ (n - 1)) + (π : F) ^ n * cu) • D K F (π : F) := by
+    rw [hu, Derivation.leibniz, Derivation.leibniz_pow, ← hDu, ← Nat.cast_smul_eq_nsmul F]
+    simp only [smul_smul]
+    rw [← add_smul]
+  rw [ordDiff_eq_ord_diffCoeff x v hπord, hDf, Place.diffCoeff_smul_D_eq x v hπ0, hn]
+  have hπn1 : v.ord ((π : F) ^ (n - 1)) = ((n - 1 : ℕ) : ℤ) := by
+    rw [← zpow_natCast, v.ord_zpow, hπord, mul_one]
+  have hA0 : uF * (n * (π : F) ^ (n - 1)) ≠ 0 :=
+    mul_ne_zero huF0 (mul_ne_zero hnF (pow_ne_zero _ hπF))
+  have hA : v.ord (uF * (n * (π : F) ^ (n - 1))) = ((n - 1 : ℕ) : ℤ) := by
+    rw [v.ord_mul huF0 (mul_ne_zero hnF (pow_ne_zero _ hπF)), huord, zero_add,
+      v.ord_mul hnF (pow_ne_zero _ hπF), v.ord_natCast n, zero_add, hπn1]
+  have hsub : ((n - 1 : ℕ) : ℤ) = (n : ℤ) - 1 := by
+    rw [Nat.cast_sub (Nat.one_le_iff_ne_zero.mpr hn0)]; simp
+  rcases eq_or_ne cu 0 with hcu0 | hcu0
+  · rw [hcu0, mul_zero, add_zero, hA, hsub]
+  · have hB : v.ord ((π : F) ^ n * cu) = (n : ℤ) + v.ord cu := by
+      rw [v.ord_mul (pow_ne_zero _ hπF) hcu0, ← zpow_natCast, v.ord_zpow, hπord, mul_one]
+    rw [Place.ord_add_eq_of_lt v hA0 (mul_ne_zero (pow_ne_zero _ hπF) hcu0) (by
+      rw [hA, hB, hsub]; omega), hA, hsub]
+
+include x in
+theorem ordDiff_D_eq_ord_sub_one (v : Place K F) {f : F} (hf : v.ord f ≠ 0) :
+    v.ordDiff (D K F f) = v.ord f - 1 := by
+  rcases lt_or_gt_of_ne hf with hneg | hpos
+  · have hf0 : f ≠ 0 := by rintro rfl; simp at hneg
+    have hinv : 0 < v.ord f⁻¹ := by rw [v.ord_inv]; omega
+    have hinv0 : v.ord f⁻¹ ≠ 0 := hinv.ne'
+    have hDf : D K F f = (-(f ^ 2)) • D K F f⁻¹ := by
+      rw [Derivation.leibniz_inv, smul_smul]
+      have : -(f ^ 2) * -(f⁻¹ ^ 2) = 1 := by field_simp
+      rw [this, one_smul]
+    rw [hDf, ordDiff_smul x v (neg_ne_zero.mpr (pow_ne_zero 2 hf0))
+      (Place.D_ne_zero_of_ord_ne_zero x v hinv0), ordDiff_D_of_ord_pos x v hinv, v.ord_neg,
+      ← zpow_natCast, v.ord_zpow, v.ord_inv]
+    push_cast
+    ring
+  · exact ordDiff_D_of_ord_pos x v hpos
+
+include x in
+theorem ordDiff_D_eq_ord_sub_algebraMap_sub_one (v : Place K F) {f : F} {c : K}
+    (hfc : v.ord (f - algebraMap K F c) ≠ 0) :
+    v.ordDiff (D K F f) = v.ord (f - algebraMap K F c) - 1 := by
+  have : D K F f = D K F (f - algebraMap K F c) := by
+    rw [map_sub, Derivation.map_algebraMap, sub_zero]
+  rw [this, ordDiff_D_eq_ord_sub_one x v hfc]
+
+end R4grade
+
+end AlgebraicCurve.FF2R4A
+
+end
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [CharZero K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (v : AlgebraicCurve.Place K F)
+    {t : F} (ht : v.ord t = 1) (ω : Ω[F⁄K]) :
+    v.ordDiff ω = v.ord (AlgebraicCurve.Place.diffCoeff t ω) :=
+  AlgebraicCurve.FF2R4A.ordDiff_eq_ord_diffCoeff x v ht ω
+
+end S_AlgebraicCurve_Place_ordDiff_eq_ord_diffCoeff
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ordDiff_eq_ord_diffCoeff (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.ordDiff_eq_ord_diffCoeff {K F : Type*} [Field K] [Field F]
+    [Algebra K F] [CharZero K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (v : AlgebraicCurve.Place K F)
+    {t : F} (ht : v.ord t = 1) (ω : Ω[F⁄K]) :
+    v.ordDiff ω = v.ord (AlgebraicCurve.Place.diffCoeff t ω) :=
+  solution x v ht ω
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ordDiff_smul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ordDiff_smul.lean
new file mode 100644
index 0000000000..5f1196ba74
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ordDiff_smul.lean
@@ -0,0 +1,118 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.ordDiff_smul
+(bf02357a-bbbb-57d3-a3e9-16e475b6318c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 561bf41a-b67e-5c3d-b0c6-cbaa38f6f972
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_diffCoeff_smul_D_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_eq_one
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order of a differential scales: ordᵥ(gω)=ordᵥ g+ordᵥω
+
+Theorem statement: `AlgebraicCurve.Place.ordDiff_smul` (`bf02357a-bbbb-57d3-a3e9-16e475b6318c`), by
+Claude, 2026-09-05.
+
+Proof: submission `561bf41a-b67e-5c3d-b0c6-cbaa38f6f972`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra and $\operatorname{char} K = 0$, and let $x \in F$
+be an element such that $F$ is algebraic over the intermediate field $K(x) =$
+`IntermediateField.adjoin K {x}`. Let $v$ be a place of $F/K$ in the sense of this development: a
+valuation subring of $F$ containing $\operatorname{algebraMap} K F(a)$ for every $a \in K$, distinct
+from $F$ itself, and whose ring is a principal ideal ring. For $f \in F$, $\operatorname{ord}_v f$
+denotes $-\log$ of the value of $f$ under the adic valuation of the associated height-one prime, an
+element of $\mathbb{Z}$; `uniformizer_alt` is a chosen $t \in F$ with $\operatorname{ord}_v t = 1$
+when such a $t$ exists and $0$ otherwise; for $t \in F$ and $\omega \in \Omega_{F/K}$,
+$\operatorname{diffCoeff} t\,\omega$ is a chosen $g \in F$ with $\omega = g \cdot D_{K/F}t$ when one
+exists and $0$ otherwise; and $\operatorname{ordDiff}_v \omega :=
+\operatorname{ord}_v(\operatorname{diffCoeff} (\mathrm{uniformizer\_alt})\,\omega)$. The assertion
+is that for every nonzero $g \in F$ and every nonzero Kähler differential $\omega \in \Omega_{F/K}$
+one has $\operatorname{ordDiff}_v(g \cdot \omega) = \operatorname{ord}_v g +
+\operatorname{ordDiff}_v \omega$. Both nonvanishing hypotheses are needed, since the conventions
+above assign order $0$ to the zero element and to the zero differential.
+
+This is the standard multiplicativity of the order of a differential at a place of a function field
+of one variable, in the form used to show that the divisor of a nonzero differential is well defined
+up to the divisor of a function. It is used in the characterisation of regular differentials on an
+algebraic curve and in the comparison of coefficient maps for differentials on modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ordDiff_smul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ordDiff_smul
+
+noncomputable section
+open KaehlerDifferential
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.diffCoeff Place.ordDiff_def Place \
+  Place.diffCoeff_smul_D_of_ord_ne_zero Place.diffCoeff_smul_D_eq"
+namespace FF2R4A
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+section R3grade
+variable [CharZero K] (x : F) [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+
+include x in
+theorem ordDiff_smul (v : Place K F) {g : F} (hg : g ≠ 0) {ω : Ω[F⁄K]} (hω : ω ≠ 0) :
+    v.ordDiff (g • ω) = v.ord g + v.ordDiff ω := by
+  have h1 : v.ord v.uniformizer_alt ≠ 0 := by
+    rw [v.ord_uniformizer_alt v.exists_ord_eq_one]; exact one_ne_zero
+  set a := Place.diffCoeff v.uniformizer_alt ω with ha
+  have hωa : a • D K F v.uniformizer_alt = ω := Place.diffCoeff_smul_D_of_ord_ne_zero x v h1 ω
+  have ha0 : a ≠ 0 := by
+    intro h0; rw [h0, zero_smul] at hωa; exact hω hωa.symm
+  rw [Place.ordDiff_def, Place.ordDiff_def, ← ha, ← hωa, smul_smul,
+    Place.diffCoeff_smul_D_eq x v h1, v.ord_mul hg ha0]
+
+end R3grade
+
+end AlgebraicCurve.FF2R4A
+
+end
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [CharZero K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {g : F} (hg : g ≠ 0) {ω : Ω[F⁄K]} (hω : ω ≠ 0) :
+    v.ordDiff (g • ω) = v.ord g + v.ordDiff ω :=
+  AlgebraicCurve.FF2R4A.ordDiff_smul x v hg hω
+
+end S_AlgebraicCurve_Place_ordDiff_smul
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ordDiff_smul (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.ordDiff_smul {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [CharZero K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {g : F} (hg : g ≠ 0) {ω : Ω[F⁄K]} (hω : ω ≠ 0) :
+    v.ordDiff (g • ω) = v.ord g + v.ordDiff ω :=
+  solution x v hg hω
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ordDiff_smul_of_perfectField.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ordDiff_smul_of_perfectField.lean
new file mode 100644
index 0000000000..8bd406c983
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ordDiff_smul_of_perfectField.lean
@@ -0,0 +1,116 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.ordDiff_smul_of_perfectField
+(5e0cf34b-828c-5cda-8931-efddc8b3afb5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission dc2a612f-4101-5609-a795-6f37e6773fdf
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_diffCoeff_smul_D_eq_of_ord_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_eq_one
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Additivity of ordDiff under scaling over a perfect field
+
+Theorem statement: `AlgebraicCurve.Place.ordDiff_smul_of_perfectField`
+(`5e0cf34b-828c-5cda-8931-efddc8b3afb5`), by Claude, 2026-09-05.
+
+Proof: submission `dc2a612f-4101-5609-a795-6f37e6773fdf`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra and $K$ perfect, and let $x \in F$ be an element
+such that $F$ is algebraic over the intermediate field $K(x) = K(\{x\})$ generated by $x$. Let $v$
+be a place of $F$ over $K$ in the sense of this development: a valuation subring of $F$ containing
+the image of $K$, different from all of $F$, and whose underlying ring is a principal ideal ring;
+write $\operatorname{ord}_v$ for the associated integer-valued order function, defined as minus the
+logarithm of the adic valuation attached to the height-one prime of $v$. Let $g \in F$ be nonzero
+and let $\omega \in \Omega_{F/K}$ be a nonzero Kähler differential. The quantity
+$\operatorname{ordDiff}_v(\omega)$ is by definition $\operatorname{ord}_v$ of the coefficient
+expressing $\omega$ as a multiple of $D_{K/F}(t)$, where $t$ is the chosen element of $F$ with
+$\operatorname{ord}_v(t) = 1$ (and the coefficient is taken to be $0$ if no such expression exists).
+The assertion is the equality of integers $$\operatorname{ordDiff}_v(g \cdot \omega) =
+\operatorname{ord}_v(g) + \operatorname{ordDiff}_v(\omega).$$
+
+This is the expected behaviour of the order of a differential at a place under multiplication by a
+function, in the one-variable setting over a perfect base field: it is what makes the divisor of a
+nonzero differential well defined up to the divisor of a function. It is used in the computations of
+$\operatorname{ordDiff}$ of exact differentials $D(f)$ and of pullbacks of differentials along maps
+of function fields.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ordDiff_smul_of_perfectField.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ordDiff_smul_of_perfectField
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "diffCoeff ordDiff ordDiff_def ord_uniformizer_alt \
+  uniformizer_alt ord ord_mul diffCoeff_smul_D_of_ord_eq_one diffCoeff_smul_D_eq_of_ord_eq_one \
+  exists_ord_eq_one"
+p2m_open "AlgebraicCurve.Place AlgebraicCurve"
+
+private theorem H1_impl {K F : Type*} [Field K] [Field F] [Algebra K F] [PerfectField K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F)
+    {g : F} (hg : g ≠ 0) {ω : Ω[F⁄K]} (hω : ω ≠ 0) :
+    v.ordDiff (g • ω) = v.ord g + v.ordDiff ω := by
+  have ht : v.ord v.uniformizer_alt = 1 := v.ord_uniformizer_alt v.exists_ord_eq_one
+  have hrep : diffCoeff v.uniformizer_alt ω • KaehlerDifferential.D K F v.uniformizer_alt = ω :=
+    v.diffCoeff_smul_D_of_ord_eq_one x ht ω
+  have hgo : g • ω = (g * diffCoeff v.uniformizer_alt ω) • KaehlerDifferential.D K F
+    v.uniformizer_alt :=
+    by
+    conv_lhs => rw [← hrep]
+    rw [smul_smul]
+  have hco : diffCoeff v.uniformizer_alt (g • ω) = g * diffCoeff v.uniformizer_alt ω := by
+    rw [hgo]
+    exact v.diffCoeff_smul_D_eq_of_ord_eq_one x ht _
+  have hc0 : diffCoeff v.uniformizer_alt ω ≠ 0 := by
+    intro h0
+    apply hω
+    rw [← hrep, h0, zero_smul]
+  rw [ordDiff_def, ordDiff_def, hco, v.ord_mul hg hc0]
+
+end AlgebraicCurve.Place
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [PerfectField K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {g : F} (hg : g ≠ 0) {ω : Ω[F⁄K]} (hω : ω ≠ 0) :
+    v.ordDiff (g • ω) = v.ord g + v.ordDiff ω :=
+  AlgebraicCurve.Place.H1_impl x v hg hω
+
+end S_AlgebraicCurve_Place_ordDiff_smul_of_perfectField
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ordDiff_smul_of_perfectField (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.ordDiff_smul_of_perfectField {K F : Type*} [Field K] [Field F]
+    [Algebra K F] [PerfectField K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {g : F} (hg : g ≠ 0) {ω : Ω[F⁄K]} (hω : ω ≠ 0) :
+    v.ordDiff (g • ω) = v.ord g + v.ordDiff ω :=
+  solution x v hg hω
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ordDiff_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ordDiff_zero.lean
new file mode 100644
index 0000000000..8da23ed543
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ordDiff_zero.lean
@@ -0,0 +1,133 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.ordDiff_zero
+(6f269f67-f826-5b30-9fae-a2c8d24bb9ba) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b9d8ef3e-ed78-5a02-8203-6f9418f14ef6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_transcendental_of_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isAlgebraic_adjoin_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_KaehlerDifferential_D_ne_zero_of_transcendental
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The zero differential has order 0 at every place
+
+Theorem statement: `AlgebraicCurve.Place.ordDiff_zero` (`6f269f67-f826-5b30-9fae-a2c8d24bb9ba`), by
+Claude, 2026-09-05.
+
+Proof: submission `b9d8ef3e-ed78-5a02-8203-6f9418f14ef6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field of characteristic zero and $F$ a field extension of $K$ such that, for a given
+element $x \in F$, the extension $F$ is algebraic over the intermediate field $K(x) =$
+`IntermediateField.adjoin K {x}`. Let $v$ be a place of $F$ over $K$ in the sense of the project's
+structure [`AlgebraicCurve.Place`](def/AlgebraicCurve_DivisorClassGroup.html#L22): a valuation
+subring of $F$ containing the image of $K$ under the structure map, distinct from $F$ itself, and
+whose ring is a principal ideal ring. Recall the relevant definitions: `v.uniformizer_alt` is a
+chosen element $t \in F$ with `v.ord t = 1` if one exists and $0$ otherwise; for $t \in F$ and a
+Kähler differential $\omega \in \Omega_{F/K}$, `Place.diffCoeff t ω` is a chosen $g \in F$ with
+$\omega = g \cdot D_{K,F}(t)$ if one exists and $0$ otherwise; and `v.ordDiff ω` is `v.ord` of
+`Place.diffCoeff v.uniformizer_alt ω`. The assertion is that `v.ordDiff 0 = 0`, that is, the order
+at $v$ of the zero differential is $0$, in accordance with the convention $\operatorname{ord}_v(0) =
+0$ for functions.
+
+This is the normalisation fact underlying the definition of the order of a differential at a place;
+because of it, the additivity rule for $\operatorname{ord}_v(g\,\omega)$ must carry explicit
+nonvanishing hypotheses. It is used in the description of the regular differentials of a curve
+([`AlgebraicCurve.mem_regularDiffs_iff`](thm.html#AlgebraicCurve.mem_regularDiffs_iff)) and in the
+treatment of coefficient maps on modular curves
+([`ModularCurve.coeffMap_coeffEmb_of_ringHom`](thm.html#ModularCurve.coeffMap_coeffEmb_of_ringHom),
+[`ModularCurve.coeffMap_mem_laurentBaseChange_of_ringHom`]
+(thm.html#ModularCurve.coeffMap_mem_laurentBaseChange_of_ringHom)).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ordDiff_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ordDiff_zero
+
+noncomputable section
+open KaehlerDifferential
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.diffCoeff Place.diffCoeff_smul_D Place.ordDiff_def Place \
+  isAlgebraic_adjoin_of_transcendental"
+namespace FF2R3
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] [CharZero K] (x : F)
+  [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+
+include x in
+private theorem isSeparable_adjoin (v : Place K F) {t : F} (ht : v.ord t ≠ 0) :
+    Algebra.IsSeparable (IntermediateField.adjoin K ({t} : Set F)) F := by
+  have : Algebra.IsAlgebraic (IntermediateField.adjoin K ({t} : Set F)) F :=
+    AlgebraicCurve.isAlgebraic_adjoin_of_transcendental x (v.transcendental_of_ord_ne_zero ht)
+  have : CharZero F := charZero_of_injective_algebraMap (algebraMap K F).injective
+  infer_instance
+
+include x in
+theorem D_ne_zero_of_ord_ne_zero (v : Place K F) {t : F} (ht : v.ord t ≠ 0) : D K F t ≠ 0 :=
+  haveI := isSeparable_adjoin x v ht
+  KaehlerDifferential.D_ne_zero_of_transcendental K t (v.transcendental_of_ord_ne_zero ht)
+
+include x in
+theorem diffCoeff_smul_of_ord_ne_zero (v : Place K F) {t : F} (ht : v.ord t ≠ 0) (g : F) :
+    Place.diffCoeff t (g • D K F t) = g :=
+  smul_left_injective F (D_ne_zero_of_ord_ne_zero x v ht)
+    (Place.diffCoeff_smul_D ⟨g, rfl⟩)
+
+include x in
+theorem ordDiff_smul_D_uniformizer (v : Place K F) (g : F) :
+    v.ordDiff (g • D K F v.uniformizer_alt) = v.ord g := by
+  have h1 : v.ord v.uniformizer_alt = 1 := v.ord_uniformizer_alt v.exists_ord_eq_one
+  rw [Place.ordDiff_def, diffCoeff_smul_of_ord_ne_zero x v (by rw [h1]; exact one_ne_zero)]
+
+include x in
+theorem ordDiff_zero (v : Place K F) : v.ordDiff 0 = 0 := by
+  simpa using ordDiff_smul_D_uniformizer x v 0
+
+end AlgebraicCurve.FF2R3
+
+end
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [CharZero K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) :
+    v.ordDiff 0 = 0 :=
+  AlgebraicCurve.FF2R3.ordDiff_zero x v
+
+end S_AlgebraicCurve_Place_ordDiff_zero
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ordDiff_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.ordDiff_zero {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [CharZero K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) :
+    v.ordDiff 0 = 0 :=
+  solution x v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_add_eq_of_lt.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_add_eq_of_lt.lean
new file mode 100644
index 0000000000..873313a5b6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_add_eq_of_lt.lean
@@ -0,0 +1,97 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.ord_add_eq_of_lt
+(aa3e68f5-2bd7-5b6e-b609-302cb070c32a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e31ec49f-f4f2-5325-9676-112d26279b13
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Strict ultrametric equality: ord(f+g)=ord f
+
+Theorem statement: `AlgebraicCurve.Place.ord_add_eq_of_lt` (`aa3e68f5-2bd7-5b6e-b609-302cb070c32a`),
+by Claude, 2026-09-05.
+
+Proof: submission `e31ec49f-f4f2-5325-9676-112d26279b13`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+sense of the project: a valuation subring of $F$ that contains the image of $K$ under the structure
+map, is not the whole of $F$, and is a principal ideal ring. Associated with $v$ is the
+$\mathbb{Z}^{m0}$-valued adic valuation
+[`AlgebraicCurve.Place.adicValuation`](def/AlgebraicCurve_DivisorClassGroup.html#L102), namely the
+valuation attached to the height-one prime of $v$, and the integer-valued order function
+[`AlgebraicCurve.Place.ord`](def/AlgebraicCurve_DivisorClassGroup.html#L122), defined on $f \in F$
+as minus the `WithZero` logarithm of the value of that adic valuation at $f$. Let $f, g \in F$ be
+nonzero and assume $\operatorname{ord}_v(f) < \operatorname{ord}_v(g)$. The conclusion is
+$\operatorname{ord}_v(f+g) = \operatorname{ord}_v(f)$. The two non-vanishing hypotheses are needed
+because the order function takes the value $0$ at $0$, so that without them the comparison of orders
+would not reflect a comparison of valuations.
+
+This is the equality case of the ultrametric inequality, transported from the multiplicative
+$\mathbb{Z}^{m0}$-valued adic valuation of a place to the additive integer order function. It is
+used throughout the development of orders and divisors attached to places, for instance in the
+construction of elements with prescribed valuations at a finite set of places.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ord_add_eq_of_lt.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ord_add_eq_of_lt
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ord"
+namespace FF2S
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem ord_add_eq_of_lt (v : Place K F) {f g : F} (hf : f ≠ 0) (hg : g ≠ 0)
+    (h : v.ord f < v.ord g) : v.ord (f + g) = v.ord f := by
+  have hval : v.adicValuation g < v.adicValuation f := by
+    have hf' := v.adicValuation_ne_zero hf
+    have hg' := v.adicValuation_ne_zero hg
+    rw [← WithZero.log_lt_log hg' hf']
+    unfold Place.ord at h
+    omega
+  unfold Place.ord
+  rw [Valuation.map_add_eq_of_lt_left _ hval]
+
+end AlgebraicCurve.FF2S
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : AlgebraicCurve.Place K F)
+    {f g : F} (hf : f ≠ 0) (hg : g ≠ 0) (h : v.ord f < v.ord g) :
+    v.ord (f + g) = v.ord f :=
+  AlgebraicCurve.FF2S.ord_add_eq_of_lt v hf hg h
+
+end S_AlgebraicCurve_Place_ord_add_eq_of_lt
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ord_add_eq_of_lt (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.ord_add_eq_of_lt {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : AlgebraicCurve.Place K F) {f g : F} (hf : f ≠ 0) (hg : g ≠ 0) (h : v.ord f < v.ord g) :
+    v.ord (f + g) = v.ord f :=
+  solution v hf hg h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_algebraMap.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_algebraMap.lean
new file mode 100644
index 0000000000..4553d56c06
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_algebraMap.lean
@@ -0,0 +1,115 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.ord_algebraMap
+(e9cbc30c-79d6-5e63-be12-ce80e24a3ecf) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3e52d324-acb0-5f10-abfd-f730853be6f1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Constants have order of vanishing zero at every place
+
+Theorem statement: `AlgebraicCurve.Place.ord_algebraMap` (`e9cbc30c-79d6-5e63-be12-ce80e24a3ecf`),
+by Claude, 2026-09-05.
+
+Proof: submission `3e52d324-acb0-5f10-abfd-f730853be6f1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+sense of the structure [`AlgebraicCurve.Place`](def/AlgebraicCurve_DivisorClassGroup.html#L22): a
+valuation subring `v.toValuationSubring` of $F$ which contains $\mathrm{algebraMap}_{K\to F}(a)$ for
+every $a\in K$, which is not all of $F$, and which is a principal ideal ring. Attached to $v$ is the
+valuation `v.adicValuation` on $F$ with values in $\mathbb{Z}^{m0}=\mathbb{Z}\cup\{0\}$ (the
+multiplicative integers with a zero adjoined), namely the valuation of the height-one prime
+`v.heightOneSpectrum` of the valuation ring, and the integer-valued order function
+$v.\mathrm{ord}(f) = -\log\bigl(v.\mathrm{adicValuation}(f)\bigr)$, where `WithZero.log` sends the
+adjoined zero to $0$. The assertion is that for every $c\in K$ one has
+$v.\mathrm{ord}\bigl(\mathrm{algebraMap}_{K\to F}(c)\bigr)=0$; in particular the convention for
+$c=0$ is included, the order of $0$ being $0$.
+
+This is the standard fact that elements of the constant field are units at every place of the
+function field $F/K$, so that they contribute no divisor; it is the basic step showing that the
+divisor map kills $K^{\times}$. It is used pervasively throughout the development of divisors and
+the divisor class group, and in the estimates for functions on annuli that rely on it.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ord_algebraMap.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ord_algebraMap
+
+open IsDedekindDomain WithZero IsLocalRing
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "coe_algebraMap adicValuation adicValuation_coe_eq_one_iff ord \
+  ord_zero toValuationSubring"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.isUnit_algebraMap {c : K} (hc : c ≠ 0) :
+    IsUnit (algebraMap K v.toValuationSubring c) :=
+  (isUnit_iff_ne_zero.mpr hc).map _
+
+p2m_export "AlgebraicCurve.Place" "isUnit_algebraMap"
+private theorem _root_.AlgebraicCurve.Place.adicValuation_algebraMap {c : K} (hc : c ≠ 0) :
+    v.adicValuation (algebraMap K F c) = 1 := by
+  rw [← v.coe_algebraMap]
+  exact (v.adicValuation_coe_eq_one_iff _).mpr (v.isUnit_algebraMap hc)
+
+p2m_export "AlgebraicCurve.Place" "adicValuation_algebraMap"
+private theorem rowMain (c : K) : v.ord (algebraMap K F c) = 0 := by
+  rcases eq_or_ne c 0 with rfl | hc
+  · rw [map_zero, v.ord_zero]
+  · simp only [ord, v.adicValuation_algebraMap hc, log_one, neg_zero]
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve _root_.P2MW.S_AlgebraicCurve_Place_ord_algebraMap.AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) (c : K) :
+    v.ord (algebraMap K F c) = 0 :=
+  AlgebraicCurve.Place.rowMain v c
+
+end S_AlgebraicCurve_Place_ord_algebraMap
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ord_algebraMap (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.ord_algebraMap {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) (c : K) :
+    v.ord (algebraMap K F c) = 0 :=
+  solution v c
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg.lean
new file mode 100644
index 0000000000..35a9163bcf
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg.lean
@@ -0,0 +1,555 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.ord_diffCoeff_D_nonneg
+(15c05da3-b3ab-5a8f-94a8-a95db8b657ce) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission be1faaa5-7f5b-53d4-80a6-b4a470ea647b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_nonneg_of_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_of_ord_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_transcendental_of_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_diffCoeff_smul_D_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteDimensional_adjoin_of_transcendental
+import Mathlib.RingTheory.Unramified.Basic
+import Mathlib.RingTheory.Unramified.LocalRing
+import Mathlib.RingTheory.Kaehler.Polynomial
+import Mathlib.RingTheory.EssentialFiniteness
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import Mathlib.FieldTheory.Perfect
+import Mathlib.Algebra.CharP.Algebra
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Regularity of df/dt at a place with uniformiser t
+
+Theorem statement: `AlgebraicCurve.Place.ord_diffCoeff_D_nonneg`
+(`15c05da3-b3ab-5a8f-94a8-a95db8b657ce`), by Claude, 2026-09-05.
+
+Proof: submission `be1faaa5-7f5b-53d4-80a6-b4a470ea647b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, $K$ of characteristic zero, and let $x \in F$ be
+such that $F$ is finite-dimensional over the intermediate field $K(x) =$ `IntermediateField.adjoin K
+{x}`. Let $v$ be a place of $F$ over $K$ in the sense of this development: a valuation subring of
+$F$ containing the image of $K$ under the structure map, distinct from $F$ itself, and whose
+underlying ring is a principal ideal ring; for $h \in F$ the integer $\operatorname{ord}_v(h)$ is
+$-\log$ of the value of $h$ under the $\mathbb{Z}^{m0}$-valued adic valuation attached to the
+height-one prime of that subring. Assume $t \in F$ satisfies $\operatorname{ord}_v(t) = 1$, and $f
+\in F$ satisfies $0 \le \operatorname{ord}_v(f)$. Write $\mathrm{D}_{K,F} f$ for the universal
+derivation of $f$ in $\Omega_{F/K}$, and let `diffCoeff t` send a Kähler differential $\omega$ to
+some chosen $g \in F$ with $\omega = g \cdot \mathrm{D}_{K,F} t$ if such a $g$ exists, and to $0$
+otherwise. The conclusion is that $0 \le \operatorname{ord}_v\bigl(\mathrm{diffCoeff}\,
+t\,(\mathrm{D}_{K,F} f)\bigr)$.
+
+This is the local statement that, for a uniformiser $t$ at $v$, the derivation $d/dt$ carries the
+valuation ring of $v$ into itself: the coefficient of $df$ against $dt$ is regular at $v$ whenever
+$f$ is. It underlies the companion results computing the order of a differential, among them
+[`AlgebraicCurve.Place.ordDiff_D_eq_ord_sub_one`]
+(thm.html#AlgebraicCurve.Place.ordDiff_D_eq_ord_sub_one),
+[`AlgebraicCurve.Place.ordDiff_D_nonneg`](thm.html#AlgebraicCurve.Place.ordDiff_D_nonneg) and
+[`AlgebraicCurve.Place.ordDiff_eq_ord_diffCoeff`]
+(thm.html#AlgebraicCurve.Place.ordDiff_eq_ord_diffCoeff),
+and hence the independence of that order from the chosen uniformiser.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing KaehlerDifferential
+open scoped TensorProduct
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.mem_maximalIdeal_iff_ord_pos' Place.restrict Place \
+  Place.coe_algebraMap Place.ord_zero Place.diffCoeff Place.diffCoeff_smul_D_eq \
+  finiteDimensional_adjoin_of_transcendental"
+p2m_open "AlgebraicCurve"
+
+namespace FF2R4
+
+p2m_open "AlgebraicCurve.Place"
+
+private theorem polyMem {K : Type*} [Field K] (u : Place K (RatFunc K))
+    (hX : (RatFunc.X : RatFunc K) ∈ u.toValuationSubring) (p : Polynomial K) :
+    algebraMap (Polynomial K) (RatFunc K) p ∈ u.toValuationSubring := by
+  induction p using Polynomial.induction_on' with
+  | add p q hp hq => rw [map_add]; exact add_mem hp hq
+  | monomial n a =>
+    rw [← Polynomial.C_mul_X_pow_eq_monomial, map_mul, map_pow]
+    refine mul_mem ?_ (pow_mem ?_ n)
+    · rw [← Polynomial.algebraMap_eq,
+        ← IsScalarTower.algebraMap_apply K (Polynomial K) (RatFunc K)]
+      exact u.algebraMap_mem' a
+    · rw [RatFunc.algebraMap_X]
+      exact hX
+
+private theorem isLocalization_valuationSubring {K Φ : Type*} [Field K] [Field Φ] [Algebra K Φ]
+    (w : Place K Φ) {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R Φ]
+    [IsFractionRing R Φ] (P : HeightOneSpectrum R) [Algebra R w.toValuationSubring]
+    (halg : ∀ r : R, (algebraMap R w.toValuationSubring r : Φ) = algebraMap R Φ r)
+    (heq : w.toValuationSubring = HeightOneSpectrum.valuationSubringAtPrime Φ P)
+    (hmem : ∀ {r : R}, r ≠ 0 → (r ∈ P.asIdeal ↔ 0 < w.ord (algebraMap R Φ r))) :
+    IsLocalization P.asIdeal.primeCompl w.toValuationSubring := by
+  refine (isLocalization_iff P.asIdeal.primeCompl w.toValuationSubring).mpr ⟨?_, ?_, ?_⟩
+  · rintro ⟨s, hs⟩
+    have hs0 : s ≠ 0 := fun h => hs (h ▸ P.asIdeal.zero_mem)
+    have hsΦ : algebraMap R Φ s ≠ 0 := fun h =>
+      hs0 (IsFractionRing.injective R Φ (by rw [h, map_zero]))
+    have hordle : ¬ 0 < w.ord (algebraMap R Φ s) := fun h => hs ((hmem hs0).mpr h)
+    have hmem' : algebraMap R Φ s ∈ w.toValuationSubring :=
+      halg s ▸ (algebraMap R w.toValuationSubring s).2
+    have hordge : 0 ≤ w.ord (algebraMap R Φ s) := w.ord_nonneg_of_mem hmem'
+    have hord0 : w.ord (algebraMap R Φ s) = 0 := by omega
+    have hinv : (algebraMap R Φ s)⁻¹ ∈ w.toValuationSubring :=
+      w.mem_of_ord_nonneg (inv_ne_zero hsΦ) (by rw [w.ord_inv, hord0]; omega)
+    refine isUnit_iff_exists_inv.mpr ⟨⟨(algebraMap R Φ s)⁻¹, hinv⟩, ?_⟩
+    apply Subtype.ext
+    change (algebraMap R w.toValuationSubring s : Φ) * (algebraMap R Φ s)⁻¹ = 1
+    rw [halg, mul_inv_cancel₀ hsΦ]
+  · intro z
+    have hz : (z : Φ) ∈ HeightOneSpectrum.valuationSubringAtPrime Φ P := heq ▸ z.2
+    obtain ⟨⟨a, s⟩, hfrac⟩ := IsLocalization.surj
+      (S := HeightOneSpectrum.valuationSubringAtPrime Φ P) P.asIdeal.primeCompl ⟨(z : Φ), hz⟩
+    have hWcoe : ∀ r : R,
+        (algebraMap R (HeightOneSpectrum.valuationSubringAtPrime Φ P) r : Φ)
+          = algebraMap R Φ r := fun r => by
+      rw [IsScalarTower.algebraMap_apply R (HeightOneSpectrum.valuationSubringAtPrime Φ P) Φ]
+      rfl
+    have hfrac' := congrArg
+      (Subtype.val : (HeightOneSpectrum.valuationSubringAtPrime Φ P) → Φ) hfrac
+    refine ⟨⟨a, s⟩, ?_⟩
+    apply Subtype.ext
+    change (z : Φ) * (algebraMap R w.toValuationSubring (s : R) : Φ)
+      = (algebraMap R w.toValuationSubring a : Φ)
+    rw [halg, halg, ← hWcoe (s : R), ← hWcoe a]
+    exact hfrac'
+  · intro a b h
+    have hΦ : algebraMap R Φ a = algebraMap R Φ b := by
+      rw [← halg a, ← halg b]
+      exact congrArg (Subtype.val : w.toValuationSubring → Φ) h
+    exact ⟨1, by rw [IsFractionRing.injective R Φ hΦ]⟩
+
+private theorem isAlgebraic_residue {R S : Type*} [CommRing R] [CommRing S] [Algebra R S]
+    [IsLocalRing R] [IsLocalRing S] [IsLocalHom (algebraMap R S)]
+    {x : S} (hx : ∃ p : Polynomial R, p.Monic ∧ Polynomial.eval₂ (algebraMap R S) x p = 0) :
+    IsAlgebraic (IsLocalRing.ResidueField R) (IsLocalRing.residue S x) := by
+  obtain ⟨p, hpm, hpe⟩ := hx
+  refine ⟨p.map (IsLocalRing.residue R), (hpm.map _).ne_zero, ?_⟩
+  rw [Polynomial.aeval_def, Polynomial.eval₂_map]
+  have hcomp : (algebraMap (ResidueField R) (ResidueField S)).comp (IsLocalRing.residue R)
+      = (IsLocalRing.residue S).comp (algebraMap R S) :=
+    RingHom.ext fun r => IsLocalRing.ResidueField.algebraMap_residue r
+  rw [hcomp, ← Polynomial.hom_eval₂, hpe, map_zero]
+
+section Dict
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+variable {v : Place K F} {w : Place K F'}
+
+private def toValuationSubringOfRestrictEq (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.toValuationSubring :=
+  (algebraMap (integralClosureAt F' v) F').codRestrict
+    w.toValuationSubring.toSubring (forall_mem_of_restrict_eq hw)
+
+omit [FiniteDimensional F F'] in
+@[scoped simp]
+private theorem coe_toValuationSubringOfRestrictEq (hw : w.restrict F = v)
+    (c : integralClosureAt F' v) :
+    (toValuationSubringOfRestrictEq hw c : F')
+      = algebraMap (integralClosureAt F' v) F' c := rfl
+
+private def residueOfCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.ResidueField :=
+  (IsLocalRing.residue w.toValuationSubring).comp (toValuationSubringOfRestrictEq hw)
+
+omit [FiniteDimensional F F'] in
+private theorem residueOfCenter_apply (hw : w.restrict F = v) (c : integralClosureAt F' v) :
+    residueOfCenter hw c = IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw c) := rfl
+
+private theorem surjective_residueOfCenter (hw : w.restrict F = v) :
+    Function.Surjective (residueOfCenter hw) := by
+  classical
+  intro y
+  obtain ⟨x, rfl⟩ := IsLocalRing.residue_surjective y
+  have hx : (x : F') ∈ HeightOneSpectrum.valuationSubringAtPrime F' (fiberCenter F' v hw) := by
+    rw [← toValuationSubring_eq_of_restrict_eq hw]
+    exact x.2
+  obtain ⟨a, s, hs, hxas⟩ := hx
+  have hsP : s ∉ (fiberCenter F' v hw).asIdeal := hs
+  have hs0 : s ≠ 0 := fun h => hsP (h ▸ (fiberCenter F' v hw).asIdeal.zero_mem)
+  have hsF : algebraMap (integralClosureAt F' v) F' s ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hs0
+  have hsord : w.ord (algebraMap (integralClosureAt F' v) F' s) = 0 := by
+    have h1 : ¬ 0 < w.ord (algebraMap (integralClosureAt F' v) F' s) := by
+      rw [← mem_fiberCenter_iff_ord_pos hw hs0]
+      exact hsP
+    have h2 : 0 ≤ w.ord (algebraMap (integralClosureAt F' v) F' s) :=
+      w.ord_nonneg_of_mem (forall_mem_of_restrict_eq hw s)
+    omega
+  have hmax : (fiberCenter F' v hw).asIdeal.IsMaximal :=
+    (fiberCenter F' v hw).isPrime.isMaximal (fiberCenter F' v hw).ne_bot
+  obtain ⟨t, i, hi, hti⟩ := hmax.exists_inv hsP
+  have hst : s * t - 1 ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : s * t - 1 = -i := by linear_combination hti
+    rw [h1]
+    exact neg_mem hi
+  refine ⟨a * t, ?_⟩
+  rw [residueOfCenter_apply, ← sub_eq_zero, ← map_sub, IsLocalRing.residue_eq_zero_iff]
+  have hcoe : ((toValuationSubringOfRestrictEq hw (a * t) - x : w.toValuationSubring) : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') := rfl
+  rcases eq_or_ne (toValuationSubringOfRestrictEq hw (a * t) - x) 0 with hzero | hne
+  · rw [hzero]
+    exact (IsLocalRing.maximalIdeal w.toValuationSubring).zero_mem
+  have hcoene : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') ≠ 0 := by
+    intro h
+    exact hne (by rwa [← hcoe, ZeroMemClass.coe_eq_zero] at h)
+  have hfactor : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t * s - a)
+          * (algebraMap (integralClosureAt F' v) F' s)⁻¹ := by
+    rw [hxas, map_sub, map_mul (algebraMap (integralClosureAt F' v) F') (a * t) s,
+      sub_mul, mul_assoc, mul_inv_cancel₀ hsF, mul_one]
+  have hdiffC : a * t * s - a ≠ 0 := by
+    intro h
+    apply hcoene
+    rw [hfactor, h, map_zero, zero_mul]
+  have hdiffP : a * t * s - a ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : a * t * s - a = a * (s * t - 1) := by ring
+    rw [h1]
+    exact Ideal.mul_mem_left _ _ hst
+  have hmem' : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      ∈ w.toValuationSubring := by
+    rw [← hcoe]
+    exact Subtype.coe_prop _
+  rw [show (toValuationSubringOfRestrictEq hw (a * t) - x)
+      = (⟨_, hmem'⟩ : w.toValuationSubring) from Subtype.ext hcoe,
+    w.mem_maximalIdeal_iff_ord_pos hcoene hmem']
+  rw [hfactor, w.ord_mul (by
+      simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hdiffC)
+    (inv_ne_zero hsF), w.ord_inv, hsord, neg_zero, add_zero]
+  exact (mem_fiberCenter_iff_ord_pos hw hdiffC).mp hdiffP
+
+end Dict
+
+private theorem engine {K : Type*} [Field K] [CharZero K] {F : Type*} [Field F] [Algebra K F]
+    [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F] [FiniteDimensional (RatFunc K) F]
+    (x : F) [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : Place K F) {u : Place K (RatFunc K)} (hu : Place.restrict (RatFunc K) v = u)
+    (ht : v.ord (algebraMap (RatFunc K) F RatFunc.X) = 1)
+    {f : F} (hf : 0 ≤ v.ord f) :
+    0 ≤ v.ord (Place.diffCoeff (algebraMap (RatFunc K) F RatFunc.X) (D K F f)) := by
+  classical
+  have : CharZero (RatFunc K) :=
+    charZero_of_injective_algebraMap (algebraMap K (RatFunc K)).injective
+  have : Algebra.IsAlgebraic (RatFunc K) F := Algebra.IsAlgebraic.of_finite _ _
+  have : Algebra.IsSeparable (RatFunc K) F := inferInstance
+  have : Algebra.IsIntegral (RatFunc K) F := Algebra.IsIntegral.of_finite _ _
+  have hepos : 0 < v.ramificationIndex (RatFunc K) := v.ramificationIndex_pos
+  have hres : v.ord (algebraMap (RatFunc K) F RatFunc.X)
+      = (v.ramificationIndex (RatFunc K) : ℤ)
+        * (Place.restrict (RatFunc K) v).ord RatFunc.X :=
+    v.ord_restrict RatFunc.X
+  rw [hu, ht] at hres
+  have huX : u.ord RatFunc.X = 1 := by
+    have hdvd : ((v.ramificationIndex (RatFunc K) : ℤ)) ∣ 1 := ⟨u.ord RatFunc.X, hres⟩
+    have hle := Int.le_of_dvd one_pos hdvd
+    have he1 : v.ramificationIndex (RatFunc K) = 1 := by omega
+    rw [he1] at hres
+    omega
+  have hX0 : (RatFunc.X : RatFunc K) ≠ 0 := RatFunc.X_ne_zero
+  have hXmem : (RatFunc.X : RatFunc K) ∈ u.toValuationSubring :=
+    u.mem_of_ord_nonneg hX0 (by rw [huX]; omega)
+  have htne : algebraMap (RatFunc K) F RatFunc.X ≠ 0 := by
+    intro h
+    rw [h, Place.ord_zero] at ht
+    exact zero_ne_one ht
+  let instCOv : Algebra (integralClosureAt F u) v.toValuationSubring :=
+    (toValuationSubringOfRestrictEq hu).toAlgebra
+  have halgC : ∀ c : integralClosureAt F u,
+      (algebraMap (integralClosureAt F u) v.toValuationSubring c : F)
+        = algebraMap (integralClosureAt F u) F c := fun _ => rfl
+  have hloc : IsLocalization (fiberCenter F u hu).asIdeal.primeCompl v.toValuationSubring :=
+    isLocalization_valuationSubring v (fiberCenter F u hu) halgC
+      (toValuationSubring_eq_of_restrict_eq hu)
+      (fun {c} hc => mem_fiberCenter_iff_ord_pos hu hc)
+  let instOuOv : Algebra u.toValuationSubring v.toValuationSubring :=
+    ((algebraMap (integralClosureAt F u) v.toValuationSubring).comp
+      (algebraMap u.toValuationSubring (integralClosureAt F u))).toAlgebra
+  have instTowOuCOv : IsScalarTower u.toValuationSubring (integralClosureAt F u)
+      v.toValuationSubring := IsScalarTower.of_algebraMap_eq' rfl
+  have halgOuOv : ∀ g : u.toValuationSubring,
+      (algebraMap u.toValuationSubring v.toValuationSubring g : F)
+        = algebraMap (RatFunc K) F (g : RatFunc K) := by
+    intro g
+    change (algebraMap (integralClosureAt F u) v.toValuationSubring
+      (algebraMap u.toValuationSubring (integralClosureAt F u) g) : F) = _
+    rw [halgC, ← IsScalarTower.algebraMap_apply u.toValuationSubring (integralClosureAt F u) F,
+      IsScalarTower.algebraMap_apply u.toValuationSubring (RatFunc K) F]
+    rfl
+  have hcompOuF : (algebraMap v.toValuationSubring F).comp
+      (algebraMap u.toValuationSubring v.toValuationSubring)
+        = algebraMap u.toValuationSubring F := by
+    apply RingHom.ext
+    intro g
+    change (algebraMap u.toValuationSubring v.toValuationSubring g : F) = _
+    rw [halgOuOv g, IsScalarTower.algebraMap_apply u.toValuationSubring (RatFunc K) F]
+    rfl
+  have instEFT : Algebra.EssFiniteType u.toValuationSubring v.toValuationSubring := by
+    have h2 : Algebra.EssFiniteType (integralClosureAt F u) v.toValuationSubring :=
+      Algebra.EssFiniteType.of_isLocalization _ (fiberCenter F u hu).asIdeal.primeCompl
+    exact Algebra.EssFiniteType.comp u.toValuationSubring (integralClosureAt F u)
+      v.toValuationSubring
+  have instLH : IsLocalHom (algebraMap u.toValuationSubring v.toValuationSubring) := by
+    constructor
+    intro a ha
+    by_contra hnu
+    have ha0 : a ≠ 0 := by
+      rintro rfl
+      rw [map_zero] at ha
+      exact not_isUnit_zero ha
+    have hposu : 0 < u.ord (algebraMap u.toValuationSubring (RatFunc K) a) :=
+      (Place.mem_maximalIdeal_iff_ord_pos' ha0).mp ((IsLocalRing.mem_maximalIdeal _).mpr hnu)
+    have himg0 : v.ord ((algebraMap u.toValuationSubring v.toValuationSubring a : F)) = 0 := by
+      have h := v.ord_coe_unit ha.unit
+      rwa [ha.unit_spec] at h
+    have himgpos : 0 < v.ord ((algebraMap u.toValuationSubring v.toValuationSubring a : F)) := by
+      rw [halgOuOv a, v.ord_restrict, hu]
+      exact mul_pos (by exact_mod_cast hepos) hposu
+    omega
+  have instCZκu : CharZero (IsLocalRing.ResidueField u.toValuationSubring) :=
+    charZero_of_injective_ringHom
+      (RingHom.injective ((IsLocalRing.residue u.toValuationSubring).comp
+        (algebraMap K u.toValuationSubring)))
+  have instAκ : Algebra.IsAlgebraic (IsLocalRing.ResidueField u.toValuationSubring)
+      (IsLocalRing.ResidueField v.toValuationSubring) := by
+    constructor
+    intro y
+    obtain ⟨c, hc⟩ := surjective_residueOfCenter hu y
+    rw [← hc, residueOfCenter_apply]
+    apply isAlgebraic_residue
+    obtain ⟨p, hpm, hpe⟩ := c.2
+    refine ⟨p, hpm, ?_⟩
+    have hinj : Function.Injective (algebraMap v.toValuationSubring F) :=
+      IsFractionRing.injective _ _
+    apply hinj
+    rw [map_zero, Polynomial.hom_eval₂, hcompOuF]
+    exact hpe
+  have hmapmax : Ideal.map (algebraMap u.toValuationSubring v.toValuationSubring)
+      (IsLocalRing.maximalIdeal u.toValuationSubring)
+        = IsLocalRing.maximalIdeal v.toValuationSubring := by
+    apply le_antisymm
+    · exact ((IsLocalRing.local_hom_TFAE
+        (algebraMap u.toValuationSubring v.toValuationSubring)).out 1 3).mp instLH
+    · intro z hz
+      rcases eq_or_ne z 0 with rfl | hz0
+      · exact zero_mem _
+      have hposz : 0 < v.ord (algebraMap v.toValuationSubring F z) :=
+        (Place.mem_maximalIdeal_iff_ord_pos' hz0).mp hz
+      have hzF : (z : F) ≠ 0 := fun h => hz0 (ZeroMemClass.coe_eq_zero.mp h)
+      have hyne : (z : F) * (algebraMap (RatFunc K) F RatFunc.X)⁻¹ ≠ 0 :=
+        mul_ne_zero hzF (inv_ne_zero htne)
+      have hyord : 0 ≤ v.ord ((z : F) * (algebraMap (RatFunc K) F RatFunc.X)⁻¹) := by
+        rw [v.ord_mul hzF (inv_ne_zero htne), v.ord_inv, ht]
+        have hposz' : 0 < v.ord (z : F) := hposz
+        omega
+      have hymem : (z : F) * (algebraMap (RatFunc K) F RatFunc.X)⁻¹ ∈ v.toValuationSubring :=
+        v.mem_of_ord_nonneg hyne hyord
+      have hXune : (⟨RatFunc.X, hXmem⟩ : u.toValuationSubring) ≠ 0 := by
+        intro h
+        exact hX0 (by simpa using congrArg Subtype.val h)
+      have hXu_mm : (⟨RatFunc.X, hXmem⟩ : u.toValuationSubring)
+          ∈ IsLocalRing.maximalIdeal u.toValuationSubring := by
+        rw [Place.mem_maximalIdeal_iff_ord_pos' hXune]
+        show 0 < u.ord (algebraMap u.toValuationSubring (RatFunc K) ⟨RatFunc.X, hXmem⟩)
+        have hX : algebraMap u.toValuationSubring (RatFunc K) ⟨RatFunc.X, hXmem⟩
+            = RatFunc.X := rfl
+        rw [hX, huX]
+        omega
+      have hfact : z = algebraMap u.toValuationSubring v.toValuationSubring ⟨RatFunc.X, hXmem⟩
+          * ⟨(z : F) * (algebraMap (RatFunc K) F RatFunc.X)⁻¹, hymem⟩ := by
+        apply Subtype.ext
+        change (z : F) = (algebraMap u.toValuationSubring v.toValuationSubring
+          ⟨RatFunc.X, hXmem⟩ : F) * ((z : F) * (algebraMap (RatFunc K) F RatFunc.X)⁻¹)
+        rw [halgOuOv]
+        change (z : F) = algebraMap (RatFunc K) F RatFunc.X
+          * ((z : F) * (algebraMap (RatFunc K) F RatFunc.X)⁻¹)
+        rw [mul_comm (z : F) _, ← mul_assoc, mul_inv_cancel₀ htne, one_mul]
+      rw [hfact]
+      exact Ideal.mul_mem_right _ _ (Ideal.mem_map_of_mem _ hXu_mm)
+  have hFU1 : Algebra.FormallyUnramified u.toValuationSubring v.toValuationSubring :=
+    Algebra.FormallyUnramified.of_map_maximalIdeal hmapmax
+  have hpmem : ∀ p : Polynomial K,
+      algebraMap (Polynomial K) (RatFunc K) p ∈ u.toValuationSubring := polyMem u hXmem
+  let instKXOu : Algebra (Polynomial K) u.toValuationSubring :=
+    ((algebraMap (Polynomial K) (RatFunc K)).codRestrict
+      u.toValuationSubring.toSubring hpmem).toAlgebra
+  have halgKXOu : ∀ p : Polynomial K,
+      (algebraMap (Polynomial K) u.toValuationSubring p : RatFunc K)
+        = algebraMap (Polynomial K) (RatFunc K) p := fun _ => rfl
+  have hlocKX : IsLocalization
+      (centerHeightOneSpectrum (Polynomial K) u hpmem).asIdeal.primeCompl
+        u.toValuationSubring :=
+    isLocalization_valuationSubring u (centerHeightOneSpectrum (Polynomial K) u hpmem) halgKXOu
+      (toValuationSubring_eq_of_forall_mem u hpmem)
+      (fun {r} hr => by
+        rw [centerHeightOneSpectrum_asIdeal]
+        exact mem_center_iff_ord_pos u hpmem hr)
+  have hFU0 : Algebra.FormallyUnramified (Polynomial K) u.toValuationSubring :=
+    Algebra.FormallyUnramified.of_isLocalization
+      (centerHeightOneSpectrum (Polynomial K) u hpmem).asIdeal.primeCompl
+  let instKXOv : Algebra (Polynomial K) v.toValuationSubring :=
+    ((algebraMap u.toValuationSubring v.toValuationSubring).comp
+      (algebraMap (Polynomial K) u.toValuationSubring)).toAlgebra
+  have instTowKXOuOv : IsScalarTower (Polynomial K) u.toValuationSubring
+      v.toValuationSubring := IsScalarTower.of_algebraMap_eq' rfl
+  have hFU : Algebra.FormallyUnramified (Polynomial K) v.toValuationSubring :=
+    Algebra.FormallyUnramified.comp (Polynomial K) u.toValuationSubring v.toValuationSubring
+  have instTowKKXOv : IsScalarTower K (Polynomial K) v.toValuationSubring := by
+    apply IsScalarTower.of_algebraMap_eq
+    intro a
+    apply Subtype.ext
+    rw [Place.coe_algebraMap]
+    change algebraMap K F a = (algebraMap u.toValuationSubring v.toValuationSubring
+      (algebraMap (Polynomial K) u.toValuationSubring (algebraMap K (Polynomial K) a)) : F)
+    rw [halgOuOv, halgKXOu, ← IsScalarTower.algebraMap_apply K (Polynomial K) (RatFunc K),
+      ← IsScalarTower.algebraMap_apply K (RatFunc K) F]
+  have hspan : ∀ ω : Ω[↥v.toValuationSubring⁄K], ω ∈ Submodule.span v.toValuationSubring
+      {D K v.toValuationSubring (algebraMap (Polynomial K) v.toValuationSubring
+        Polynomial.X)} := by
+    intro ω
+    have hexact := KaehlerDifferential.exact_mapBaseChange_map K (Polynomial K)
+      v.toValuationSubring
+    have h0 : KaehlerDifferential.map K (Polynomial K) v.toValuationSubring
+        v.toValuationSubring ω = 0 := Subsingleton.elim _ _
+    obtain ⟨ξ, hξ⟩ := (hexact ω).mp h0
+    rw [← hξ]
+    clear hξ
+    induction ξ using TensorProduct.inductionOn with
+    | tmul b ω' =>
+      rw [KaehlerDifferential.mapBaseChange_tmul]
+      have hω' : ω' = ((KaehlerDifferential.polynomialEquiv K) ω')
+          • D K (Polynomial K) Polynomial.X :=
+        ((KaehlerDifferential.polynomialEquiv K).symm_apply_apply ω').symm
+      rw [hω', map_smul, KaehlerDifferential.map_D]
+      rw [show ((KaehlerDifferential.polynomialEquiv K) ω') • D K v.toValuationSubring
+          (algebraMap (Polynomial K) v.toValuationSubring Polynomial.X)
+        = (algebraMap (Polynomial K) v.toValuationSubring
+            ((KaehlerDifferential.polynomialEquiv K) ω'))
+            • D K v.toValuationSubring (algebraMap (Polynomial K) v.toValuationSubring
+              Polynomial.X)
+        from (algebraMap_smul _ _ _).symm, smul_smul]
+      exact Submodule.smul_mem _ _ (Submodule.mem_span_singleton_self _)
+    | add ξ₁ ξ₂ h₁ h₂ =>
+      rw [map_add]
+      exact Submodule.add_mem _ h₁ h₂
+  have hfmem : f ∈ v.toValuationSubring := by
+    rcases eq_or_ne f 0 with rfl | hf0
+    · exact zero_mem _
+    · exact v.mem_of_ord_nonneg hf0 hf
+  obtain ⟨g, hg⟩ := Submodule.mem_span_singleton.mp
+    (hspan (D K v.toValuationSubring ⟨f, hfmem⟩))
+  have hpush := congrArg (KaehlerDifferential.map K K v.toValuationSubring F) hg
+  rw [map_smul, KaehlerDifferential.map_D, KaehlerDifferential.map_D] at hpush
+  have hXOvF : algebraMap v.toValuationSubring F
+      (algebraMap (Polynomial K) v.toValuationSubring Polynomial.X)
+        = algebraMap (RatFunc K) F RatFunc.X := by
+    change (algebraMap u.toValuationSubring v.toValuationSubring
+      (algebraMap (Polynomial K) u.toValuationSubring Polynomial.X) : F) = _
+    rw [halgOuOv, halgKXOu, RatFunc.algebraMap_X]
+  have hfOvF : algebraMap v.toValuationSubring F (⟨f, hfmem⟩ : v.toValuationSubring) = f := rfl
+  rw [hXOvF, hfOvF] at hpush
+  have hgsmul : ((g : F)) • D K F (algebraMap (RatFunc K) F RatFunc.X)
+      = g • D K F (algebraMap (RatFunc K) F RatFunc.X) := algebraMap_smul F g _
+  rw [← hgsmul] at hpush
+  rw [← hpush, Place.diffCoeff_smul_D_eq x v
+    (show v.ord (algebraMap (RatFunc K) F RatFunc.X) ≠ 0 by rw [ht]; exact one_ne_zero)
+    (g : F)]
+  exact v.ord_nonneg_of_mem g.2
+
+theorem ord_diffCoeff_D_nonneg {K F : Type*} [Field K] [Field F] [Algebra K F] [CharZero K]
+    (x : F) [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {t : F} (ht : v.ord t = 1) {f : F} (hf : 0 ≤ v.ord f) :
+    0 ≤ v.ord (AlgebraicCurve.Place.diffCoeff t (KaehlerDifferential.D K F f)) := by
+  classical
+  have htr : Transcendental K t :=
+    v.transcendental_of_ord_ne_zero (by rw [ht]; exact one_ne_zero)
+  let e : RatFunc K ≃ₐ[K] ↥(IntermediateField.adjoin K ({t} : Set F)) :=
+    RatFunc.algEquivOfTranscendental t htr
+  let : Algebra (RatFunc K) (↥(IntermediateField.adjoin K ({t} : Set F))) :=
+    e.toAlgHom.toRingHom.toAlgebra
+  let : Algebra (RatFunc K) F :=
+    ((algebraMap (↥(IntermediateField.adjoin K ({t} : Set F))) F).comp
+      e.toAlgHom.toRingHom).toAlgebra
+  have : IsScalarTower (RatFunc K) (↥(IntermediateField.adjoin K ({t} : Set F))) F :=
+    IsScalarTower.of_algebraMap_eq fun q => rfl
+  have : IsScalarTower K (RatFunc K) F := IsScalarTower.of_algebraMap_eq fun r => by
+    change algebraMap K F r
+      = algebraMap (↥(IntermediateField.adjoin K ({t} : Set F))) F (e (algebraMap K (RatFunc K) r))
+    rw [AlgEquiv.commutes]
+    exact IsScalarTower.algebraMap_apply K (↥(IntermediateField.adjoin K ({t} : Set F))) F r
+  have : Module.Finite (RatFunc K) (↥(IntermediateField.adjoin K ({t} : Set F))) :=
+    Module.Finite.of_surjective
+      (Algebra.linearMap (RatFunc K) (↥(IntermediateField.adjoin K ({t} : Set F))))
+      e.surjective
+  have : FiniteDimensional (↥(IntermediateField.adjoin K ({t} : Set F))) F :=
+    AlgebraicCurve.finiteDimensional_adjoin_of_transcendental x htr
+  have : FiniteDimensional (RatFunc K) F :=
+    Module.Finite.trans (↥(IntermediateField.adjoin K ({t} : Set F))) F
+  have : Algebra.IsAlgebraic (↥(IntermediateField.adjoin K ({x} : Set F))) F :=
+    Algebra.IsAlgebraic.of_finite _ _
+  have hXt : algebraMap (RatFunc K) F RatFunc.X = t :=
+    RatFunc.algEquivOfTranscendental_X t htr
+  rw [← hXt] at ht ⊢
+  exact engine x v rfl ht hf
+
+end FF2R4
+end AlgebraicCurve
+end
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [CharZero K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (v : AlgebraicCurve.Place K F)
+    {t : F}
+    (ht : v.ord t = 1) {f : F} (hf : 0 ≤ v.ord f) :
+    0 ≤ v.ord (AlgebraicCurve.Place.diffCoeff t (KaehlerDifferential.D K F f)) :=
+  AlgebraicCurve.FF2R4.ord_diffCoeff_D_nonneg x v ht hf
+
+end S_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.ord_diffCoeff_D_nonneg {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [CharZero K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (v : AlgebraicCurve.Place K F)
+    {t : F}
+    (ht : v.ord t = 1) {f : F} (hf : 0 ≤ v.ord f) :
+    0 ≤ v.ord (AlgebraicCurve.Place.diffCoeff t (KaehlerDifferential.D K F f)) :=
+  solution x v ht hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg_of_isSeparable.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg_of_isSeparable.lean
new file mode 100644
index 0000000000..28a8827b05
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg_of_isSeparable.lean
@@ -0,0 +1,614 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.ord_diffCoeff_D_nonneg_of_isSeparable
+(6d8aaf73-f4da-5fc8-918a-ec4506db231b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5db19e19-28c2-5a1b-a164-633c1970ef3c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_nonneg_of_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_of_ord_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_transcendental_of_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteDimensional_adjoin_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_KaehlerDifferential_D_ne_zero_of_transcendental
+import Mathlib.RingTheory.Unramified.Basic
+import Mathlib.RingTheory.Unramified.LocalRing
+import Mathlib.RingTheory.Kaehler.Polynomial
+import Mathlib.RingTheory.EssentialFiniteness
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import Mathlib.FieldTheory.Perfect
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Differentiation with respect to a uniformiser preserves 𝒪ᵥ
+
+Theorem statement: `AlgebraicCurve.Place.ord_diffCoeff_D_nonneg_of_isSeparable`
+(`6d8aaf73-f4da-5fc8-918a-ec4506db231b`), by Claude, 2026-09-05.
+
+Proof: submission `5db19e19-28c2-5a1b-a164-633c1970ef3c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a perfect field and $F$ a field extension of $K$, and suppose there is an element $x \in
+F$ with $F$ finite-dimensional over the intermediate field $K(x) =$ `IntermediateField.adjoin K
+{x}`. Let $v$ be a place of $F$ over $K$, that is, a valuation subring of $F$ containing the image
+of $K$, different from all of $F$, and whose underlying ring is a principal ideal ring; write
+$\operatorname{ord}_v$ for the associated normalised valuation, the negative of the logarithm of the
+$\mathbb{Z}^{m0}$-valued adic valuation attached to the height-one prime of $v$. Let $t \in F$
+satisfy $\operatorname{ord}_v t = 1$, and assume $F$ is separable over $K(t)$. Then for every $f \in
+F$ with $\operatorname{ord}_v f \ge 0$ one has $\operatorname{ord}_v\bigl(\operatorname{diffCoeff}
+t\, (\mathrm{d}_{K/F} f)\bigr) \ge 0$, where $\operatorname{diffCoeff} t\, \omega$ denotes a chosen
+$g \in F$ with $\omega = g \cdot \mathrm{d}t$ in $\Omega_{F/K}$ when such a $g$ exists, and $0$
+otherwise.
+
+This is the statement that the derivation $f \mapsto \mathrm{d}f/\mathrm{d}t$ with respect to a
+uniformiser $t$ at $v$ maps the valuation ring of $v$ into itself, in the form used for function
+fields of one variable over a perfect constant field. It underlies the computation of the order of
+vanishing of differentials at a place, and is cited in the results on $\operatorname{ord}$ of
+$\mathrm{d}f$ for $f$ with positive order and on orders of pullbacks of differentials.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg_of_isSeparable.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg_of_isSeparable
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing KaehlerDifferential
+open scoped TensorProduct
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.mem_maximalIdeal_iff_ord_pos' Place.restrict Place \
+  Place.coe_algebraMap Place.ord_zero Place.diffCoeff Place.diffCoeff_smul_D \
+  finiteDimensional_adjoin_of_transcendental"
+p2m_open "AlgebraicCurve"
+
+namespace FF2R4p
+
+p2m_open "AlgebraicCurve.Place"
+
+private theorem diffCoeff_smul_D_eq_of_isSeparable {K F : Type*} [Field K] [Field F]
+    [Algebra K F] (v : Place K F) {t : F} (ht : v.ord t ≠ 0)
+    [Algebra.IsSeparable (IntermediateField.adjoin K ({t} : Set F)) F] (g : F) :
+    Place.diffCoeff t (g • KaehlerDifferential.D K F t) = g :=
+  smul_left_injective F
+    (KaehlerDifferential.D_ne_zero_of_transcendental K t (v.transcendental_of_ord_ne_zero ht))
+    (Place.diffCoeff_smul_D ⟨g, rfl⟩)
+
+private theorem polyMem {K : Type*} [Field K] (u : Place K (RatFunc K))
+    (hX : (RatFunc.X : RatFunc K) ∈ u.toValuationSubring) (p : Polynomial K) :
+    algebraMap (Polynomial K) (RatFunc K) p ∈ u.toValuationSubring := by
+  induction p using Polynomial.induction_on' with
+  | add p q hp hq => rw [map_add]; exact add_mem hp hq
+  | monomial n a =>
+    rw [← Polynomial.C_mul_X_pow_eq_monomial, map_mul, map_pow]
+    refine mul_mem ?_ (pow_mem ?_ n)
+    · rw [← Polynomial.algebraMap_eq,
+        ← IsScalarTower.algebraMap_apply K (Polynomial K) (RatFunc K)]
+      exact u.algebraMap_mem' a
+    · rw [RatFunc.algebraMap_X]
+      exact hX
+
+private theorem isLocalization_valuationSubring {K Φ : Type*} [Field K] [Field Φ] [Algebra K Φ]
+    (w : Place K Φ) {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R Φ]
+    [IsFractionRing R Φ] (P : HeightOneSpectrum R) [Algebra R w.toValuationSubring]
+    (halg : ∀ r : R, (algebraMap R w.toValuationSubring r : Φ) = algebraMap R Φ r)
+    (heq : w.toValuationSubring = HeightOneSpectrum.valuationSubringAtPrime Φ P)
+    (hmem : ∀ {r : R}, r ≠ 0 → (r ∈ P.asIdeal ↔ 0 < w.ord (algebraMap R Φ r))) :
+    IsLocalization P.asIdeal.primeCompl w.toValuationSubring := by
+  refine (isLocalization_iff P.asIdeal.primeCompl w.toValuationSubring).mpr ⟨?_, ?_, ?_⟩
+  · rintro ⟨s, hs⟩
+    have hs0 : s ≠ 0 := fun h => hs (h ▸ P.asIdeal.zero_mem)
+    have hsΦ : algebraMap R Φ s ≠ 0 := fun h =>
+      hs0 (IsFractionRing.injective R Φ (by rw [h, map_zero]))
+    have hordle : ¬ 0 < w.ord (algebraMap R Φ s) := fun h => hs ((hmem hs0).mpr h)
+    have hmem' : algebraMap R Φ s ∈ w.toValuationSubring :=
+      halg s ▸ (algebraMap R w.toValuationSubring s).2
+    have hordge : 0 ≤ w.ord (algebraMap R Φ s) := w.ord_nonneg_of_mem hmem'
+    have hord0 : w.ord (algebraMap R Φ s) = 0 := by omega
+    have hinv : (algebraMap R Φ s)⁻¹ ∈ w.toValuationSubring :=
+      w.mem_of_ord_nonneg (inv_ne_zero hsΦ) (by rw [w.ord_inv, hord0]; omega)
+    refine isUnit_iff_exists_inv.mpr ⟨⟨(algebraMap R Φ s)⁻¹, hinv⟩, ?_⟩
+    apply Subtype.ext
+    change (algebraMap R w.toValuationSubring s : Φ) * (algebraMap R Φ s)⁻¹ = 1
+    rw [halg, mul_inv_cancel₀ hsΦ]
+  · intro z
+    have hz : (z : Φ) ∈ HeightOneSpectrum.valuationSubringAtPrime Φ P := heq ▸ z.2
+    obtain ⟨⟨a, s⟩, hfrac⟩ := IsLocalization.surj
+      (S := HeightOneSpectrum.valuationSubringAtPrime Φ P) P.asIdeal.primeCompl ⟨(z : Φ), hz⟩
+    have hWcoe : ∀ r : R,
+        (algebraMap R (HeightOneSpectrum.valuationSubringAtPrime Φ P) r : Φ)
+          = algebraMap R Φ r := fun r => by
+      rw [IsScalarTower.algebraMap_apply R (HeightOneSpectrum.valuationSubringAtPrime Φ P) Φ]
+      rfl
+    have hfrac' := congrArg
+      (Subtype.val : (HeightOneSpectrum.valuationSubringAtPrime Φ P) → Φ) hfrac
+    refine ⟨⟨a, s⟩, ?_⟩
+    apply Subtype.ext
+    change (z : Φ) * (algebraMap R w.toValuationSubring (s : R) : Φ)
+      = (algebraMap R w.toValuationSubring a : Φ)
+    rw [halg, halg, ← hWcoe (s : R), ← hWcoe a]
+    exact hfrac'
+  · intro a b h
+    have hΦ : algebraMap R Φ a = algebraMap R Φ b := by
+      rw [← halg a, ← halg b]
+      exact congrArg (Subtype.val : w.toValuationSubring → Φ) h
+    exact ⟨1, by rw [IsFractionRing.injective R Φ hΦ]⟩
+
+private theorem isAlgebraic_residue {R S : Type*} [CommRing R] [CommRing S] [Algebra R S]
+    [IsLocalRing R] [IsLocalRing S] [IsLocalHom (algebraMap R S)]
+    {x : S} (hx : ∃ p : Polynomial R, p.Monic ∧ Polynomial.eval₂ (algebraMap R S) x p = 0) :
+    IsAlgebraic (IsLocalRing.ResidueField R) (IsLocalRing.residue S x) := by
+  obtain ⟨p, hpm, hpe⟩ := hx
+  refine ⟨p.map (IsLocalRing.residue R), (hpm.map _).ne_zero, ?_⟩
+  rw [Polynomial.aeval_def, Polynomial.eval₂_map]
+  have hcomp : (algebraMap (ResidueField R) (ResidueField S)).comp (IsLocalRing.residue R)
+      = (IsLocalRing.residue S).comp (algebraMap R S) :=
+    RingHom.ext fun r => IsLocalRing.ResidueField.algebraMap_residue r
+  rw [hcomp, ← Polynomial.hom_eval₂, hpe, map_zero]
+
+private theorem isAlgebraic_residueField_of_X_mem {K : Type*} [Field K] (u : Place K (RatFunc K))
+    [Algebra (Polynomial K) u.toValuationSubring]
+    (halg : ∀ p : Polynomial K, (algebraMap (Polynomial K) u.toValuationSubring p : RatFunc K)
+      = algebraMap (Polynomial K) (RatFunc K) p)
+    (S : Submonoid (Polynomial K)) [IsLocalization S u.toValuationSubring]
+    (hX : algebraMap (Polynomial K) u.toValuationSubring Polynomial.X
+      ∈ IsLocalRing.maximalIdeal u.toValuationSubring) :
+    Algebra.IsAlgebraic K (IsLocalRing.ResidueField u.toValuationSubring) := by
+  have hC : ∀ c : K, algebraMap (Polynomial K) u.toValuationSubring (Polynomial.C c)
+      = algebraMap K u.toValuationSubring c := by
+    intro c
+    apply Subtype.ext
+    rw [halg, Place.coe_algebraMap, ← Polynomial.algebraMap_eq,
+      ← IsScalarTower.algebraMap_apply K (Polynomial K) (RatFunc K)]
+  have hres : ∀ p : Polynomial K,
+      IsLocalRing.residue u.toValuationSubring (algebraMap (Polynomial K) u.toValuationSubring p)
+        = algebraMap K (IsLocalRing.ResidueField u.toValuationSubring) (p.coeff 0) := by
+    intro p
+    rw [IsScalarTower.algebraMap_apply K u.toValuationSubring
+        (IsLocalRing.ResidueField u.toValuationSubring),
+      IsLocalRing.ResidueField.algebraMap_eq, ← hC, ← sub_eq_zero, ← map_sub,
+      IsLocalRing.residue_eq_zero_iff, ← map_sub]
+    have hp : p - Polynomial.C (p.coeff 0) = Polynomial.X * p.divX := by
+      rw [sub_eq_iff_eq_add, Polynomial.X_mul_divX_add]
+    rw [hp, map_mul]
+    exact Ideal.mul_mem_right _ _ hX
+  constructor
+  intro y
+  obtain ⟨z, rfl⟩ := IsLocalRing.residue_surjective y
+  obtain ⟨⟨a, s⟩, h⟩ := IsLocalization.surj S z
+  have hsu : IsUnit (algebraMap (Polynomial K) u.toValuationSubring (s : Polynomial K)) :=
+    IsLocalization.map_units u.toValuationSubring s
+  have hs0 : algebraMap K (IsLocalRing.ResidueField u.toValuationSubring)
+      ((s : Polynomial K).coeff 0) ≠ 0 := by
+    rw [← hres]
+    exact (IsLocalRing.residue_ne_zero_iff_isUnit _).mpr hsu
+  have hz : IsLocalRing.residue u.toValuationSubring z
+      = algebraMap K (IsLocalRing.ResidueField u.toValuationSubring)
+          (a.coeff 0 / (s : Polynomial K).coeff 0) := by
+    have h' := congrArg (IsLocalRing.residue u.toValuationSubring) h
+    rw [map_mul, hres, hres] at h'
+    rw [map_div₀, eq_div_iff hs0, h']
+  rw [hz]
+  exact isAlgebraic_algebraMap _
+
+section Dict
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+variable {v : Place K F} {w : Place K F'}
+
+private def toValuationSubringOfRestrictEq (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.toValuationSubring :=
+  (algebraMap (integralClosureAt F' v) F').codRestrict
+    w.toValuationSubring.toSubring (forall_mem_of_restrict_eq hw)
+
+omit [FiniteDimensional F F'] in
+@[scoped simp]
+private theorem coe_toValuationSubringOfRestrictEq (hw : w.restrict F = v)
+    (c : integralClosureAt F' v) :
+    (toValuationSubringOfRestrictEq hw c : F')
+      = algebraMap (integralClosureAt F' v) F' c := rfl
+
+private def residueOfCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.ResidueField :=
+  (IsLocalRing.residue w.toValuationSubring).comp (toValuationSubringOfRestrictEq hw)
+
+omit [FiniteDimensional F F'] in
+private theorem residueOfCenter_apply (hw : w.restrict F = v) (c : integralClosureAt F' v) :
+    residueOfCenter hw c = IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw c) := rfl
+
+private theorem surjective_residueOfCenter (hw : w.restrict F = v) :
+    Function.Surjective (residueOfCenter hw) := by
+  classical
+  intro y
+  obtain ⟨x, rfl⟩ := IsLocalRing.residue_surjective y
+  have hx : (x : F') ∈ HeightOneSpectrum.valuationSubringAtPrime F' (fiberCenter F' v hw) := by
+    rw [← toValuationSubring_eq_of_restrict_eq hw]
+    exact x.2
+  obtain ⟨a, s, hs, hxas⟩ := hx
+  have hsP : s ∉ (fiberCenter F' v hw).asIdeal := hs
+  have hs0 : s ≠ 0 := fun h => hsP (h ▸ (fiberCenter F' v hw).asIdeal.zero_mem)
+  have hsF : algebraMap (integralClosureAt F' v) F' s ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hs0
+  have hsord : w.ord (algebraMap (integralClosureAt F' v) F' s) = 0 := by
+    have h1 : ¬ 0 < w.ord (algebraMap (integralClosureAt F' v) F' s) := by
+      rw [← mem_fiberCenter_iff_ord_pos hw hs0]
+      exact hsP
+    have h2 : 0 ≤ w.ord (algebraMap (integralClosureAt F' v) F' s) :=
+      w.ord_nonneg_of_mem (forall_mem_of_restrict_eq hw s)
+    omega
+  have hmax : (fiberCenter F' v hw).asIdeal.IsMaximal :=
+    (fiberCenter F' v hw).isPrime.isMaximal (fiberCenter F' v hw).ne_bot
+  obtain ⟨t, i, hi, hti⟩ := hmax.exists_inv hsP
+  have hst : s * t - 1 ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : s * t - 1 = -i := by linear_combination hti
+    rw [h1]
+    exact neg_mem hi
+  refine ⟨a * t, ?_⟩
+  rw [residueOfCenter_apply, ← sub_eq_zero, ← map_sub, IsLocalRing.residue_eq_zero_iff]
+  have hcoe : ((toValuationSubringOfRestrictEq hw (a * t) - x : w.toValuationSubring) : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') := rfl
+  rcases eq_or_ne (toValuationSubringOfRestrictEq hw (a * t) - x) 0 with hzero | hne
+  · rw [hzero]
+    exact (IsLocalRing.maximalIdeal w.toValuationSubring).zero_mem
+  have hcoene : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') ≠ 0 := by
+    intro h
+    exact hne (by rwa [← hcoe, ZeroMemClass.coe_eq_zero] at h)
+  have hfactor : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t * s - a)
+          * (algebraMap (integralClosureAt F' v) F' s)⁻¹ := by
+    rw [hxas, map_sub, map_mul (algebraMap (integralClosureAt F' v) F') (a * t) s,
+      sub_mul, mul_assoc, mul_inv_cancel₀ hsF, mul_one]
+  have hdiffC : a * t * s - a ≠ 0 := by
+    intro h
+    apply hcoene
+    rw [hfactor, h, map_zero, zero_mul]
+  have hdiffP : a * t * s - a ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : a * t * s - a = a * (s * t - 1) := by ring
+    rw [h1]
+    exact Ideal.mul_mem_left _ _ hst
+  have hmem' : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      ∈ w.toValuationSubring := by
+    rw [← hcoe]
+    exact Subtype.coe_prop _
+  rw [show (toValuationSubringOfRestrictEq hw (a * t) - x)
+      = (⟨_, hmem'⟩ : w.toValuationSubring) from Subtype.ext hcoe,
+    w.mem_maximalIdeal_iff_ord_pos hcoene hmem']
+  rw [hfactor, w.ord_mul (by
+      simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hdiffC)
+    (inv_ne_zero hsF), w.ord_inv, hsord, neg_zero, add_zero]
+  exact (mem_fiberCenter_iff_ord_pos hw hdiffC).mp hdiffP
+
+end Dict
+
+private theorem engine {K : Type*} [Field K] [PerfectField K] {F : Type*} [Field F] [Algebra K F]
+    [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F] [FiniteDimensional (RatFunc K) F]
+    [Algebra.IsSeparable (RatFunc K) F]
+    (v : Place K F) {u : Place K (RatFunc K)} (hu : Place.restrict (RatFunc K) v = u)
+    (ht : v.ord (algebraMap (RatFunc K) F RatFunc.X) = 1)
+    {f : F} (hf : 0 ≤ v.ord f) :
+    ∃ g : F, 0 ≤ v.ord g ∧ D K F f = g • D K F (algebraMap (RatFunc K) F RatFunc.X) := by
+  classical
+  have : Algebra.IsAlgebraic (RatFunc K) F := Algebra.IsAlgebraic.of_finite _ _
+  have : Algebra.IsIntegral (RatFunc K) F := Algebra.IsIntegral.of_finite _ _
+  have hepos : 0 < v.ramificationIndex (RatFunc K) := v.ramificationIndex_pos
+  have hres : v.ord (algebraMap (RatFunc K) F RatFunc.X)
+      = (v.ramificationIndex (RatFunc K) : ℤ)
+        * (Place.restrict (RatFunc K) v).ord RatFunc.X :=
+    v.ord_restrict RatFunc.X
+  rw [hu, ht] at hres
+  have huX : u.ord RatFunc.X = 1 := by
+    have hdvd : ((v.ramificationIndex (RatFunc K) : ℤ)) ∣ 1 := ⟨u.ord RatFunc.X, hres⟩
+    have hle := Int.le_of_dvd one_pos hdvd
+    have he1 : v.ramificationIndex (RatFunc K) = 1 := by omega
+    rw [he1] at hres
+    omega
+  have hX0 : (RatFunc.X : RatFunc K) ≠ 0 := RatFunc.X_ne_zero
+  have hXmem : (RatFunc.X : RatFunc K) ∈ u.toValuationSubring :=
+    u.mem_of_ord_nonneg hX0 (by rw [huX]; omega)
+  have htne : algebraMap (RatFunc K) F RatFunc.X ≠ 0 := by
+    intro h
+    rw [h, Place.ord_zero] at ht
+    exact zero_ne_one ht
+  let instCOv : Algebra (integralClosureAt F u) v.toValuationSubring :=
+    (toValuationSubringOfRestrictEq hu).toAlgebra
+  have halgC : ∀ c : integralClosureAt F u,
+      (algebraMap (integralClosureAt F u) v.toValuationSubring c : F)
+        = algebraMap (integralClosureAt F u) F c := fun _ => rfl
+  have hloc : IsLocalization (fiberCenter F u hu).asIdeal.primeCompl v.toValuationSubring :=
+    isLocalization_valuationSubring v (fiberCenter F u hu) halgC
+      (toValuationSubring_eq_of_restrict_eq hu)
+      (fun {c} hc => mem_fiberCenter_iff_ord_pos hu hc)
+  let instOuOv : Algebra u.toValuationSubring v.toValuationSubring :=
+    ((algebraMap (integralClosureAt F u) v.toValuationSubring).comp
+      (algebraMap u.toValuationSubring (integralClosureAt F u))).toAlgebra
+  have instTowOuCOv : IsScalarTower u.toValuationSubring (integralClosureAt F u)
+      v.toValuationSubring := IsScalarTower.of_algebraMap_eq' rfl
+  have halgOuOv : ∀ g : u.toValuationSubring,
+      (algebraMap u.toValuationSubring v.toValuationSubring g : F)
+        = algebraMap (RatFunc K) F (g : RatFunc K) := by
+    intro g
+    change (algebraMap (integralClosureAt F u) v.toValuationSubring
+      (algebraMap u.toValuationSubring (integralClosureAt F u) g) : F) = _
+    rw [halgC, ← IsScalarTower.algebraMap_apply u.toValuationSubring (integralClosureAt F u) F,
+      IsScalarTower.algebraMap_apply u.toValuationSubring (RatFunc K) F]
+    rfl
+  have hcompOuF : (algebraMap v.toValuationSubring F).comp
+      (algebraMap u.toValuationSubring v.toValuationSubring)
+        = algebraMap u.toValuationSubring F := by
+    apply RingHom.ext
+    intro g
+    change (algebraMap u.toValuationSubring v.toValuationSubring g : F) = _
+    rw [halgOuOv g, IsScalarTower.algebraMap_apply u.toValuationSubring (RatFunc K) F]
+    rfl
+  have instEFT : Algebra.EssFiniteType u.toValuationSubring v.toValuationSubring := by
+    have h2 : Algebra.EssFiniteType (integralClosureAt F u) v.toValuationSubring :=
+      Algebra.EssFiniteType.of_isLocalization _ (fiberCenter F u hu).asIdeal.primeCompl
+    exact Algebra.EssFiniteType.comp u.toValuationSubring (integralClosureAt F u)
+      v.toValuationSubring
+  have instLH : IsLocalHom (algebraMap u.toValuationSubring v.toValuationSubring) := by
+    constructor
+    intro a ha
+    by_contra hnu
+    have ha0 : a ≠ 0 := by
+      rintro rfl
+      rw [map_zero] at ha
+      exact not_isUnit_zero ha
+    have hposu : 0 < u.ord (algebraMap u.toValuationSubring (RatFunc K) a) :=
+      (Place.mem_maximalIdeal_iff_ord_pos' ha0).mp ((IsLocalRing.mem_maximalIdeal _).mpr hnu)
+    have himg0 : v.ord ((algebraMap u.toValuationSubring v.toValuationSubring a : F)) = 0 := by
+      have h := v.ord_coe_unit ha.unit
+      rwa [ha.unit_spec] at h
+    have himgpos : 0 < v.ord ((algebraMap u.toValuationSubring v.toValuationSubring a : F)) := by
+      rw [halgOuOv a, v.ord_restrict, hu]
+      exact mul_pos (by exact_mod_cast hepos) hposu
+    omega
+  have hpmem : ∀ p : Polynomial K,
+      algebraMap (Polynomial K) (RatFunc K) p ∈ u.toValuationSubring := polyMem u hXmem
+  let instKXOu : Algebra (Polynomial K) u.toValuationSubring :=
+    ((algebraMap (Polynomial K) (RatFunc K)).codRestrict
+      u.toValuationSubring.toSubring hpmem).toAlgebra
+  have halgKXOu : ∀ p : Polynomial K,
+      (algebraMap (Polynomial K) u.toValuationSubring p : RatFunc K)
+        = algebraMap (Polynomial K) (RatFunc K) p := fun _ => rfl
+  have hlocKX : IsLocalization
+      (centerHeightOneSpectrum (Polynomial K) u hpmem).asIdeal.primeCompl
+        u.toValuationSubring :=
+    isLocalization_valuationSubring u (centerHeightOneSpectrum (Polynomial K) u hpmem) halgKXOu
+      (toValuationSubring_eq_of_forall_mem u hpmem)
+      (fun {r} hr => by
+        rw [centerHeightOneSpectrum_asIdeal]
+        exact mem_center_iff_ord_pos u hpmem hr)
+  have hXune : (⟨RatFunc.X, hXmem⟩ : u.toValuationSubring) ≠ 0 := by
+    intro h
+    exact hX0 (by simpa using congrArg Subtype.val h)
+  have hXu_mm : (⟨RatFunc.X, hXmem⟩ : u.toValuationSubring)
+      ∈ IsLocalRing.maximalIdeal u.toValuationSubring := by
+    rw [Place.mem_maximalIdeal_iff_ord_pos' hXune]
+    show 0 < u.ord (algebraMap u.toValuationSubring (RatFunc K) ⟨RatFunc.X, hXmem⟩)
+    have hX : algebraMap u.toValuationSubring (RatFunc K) ⟨RatFunc.X, hXmem⟩
+        = RatFunc.X := rfl
+    rw [hX, huX]
+    omega
+  have hXKX_mm : algebraMap (Polynomial K) u.toValuationSubring Polynomial.X
+      ∈ IsLocalRing.maximalIdeal u.toValuationSubring := by
+    have h1 : algebraMap (Polynomial K) u.toValuationSubring Polynomial.X
+        = ⟨RatFunc.X, hXmem⟩ := Subtype.ext (by rw [halgKXOu, RatFunc.algebraMap_X])
+    rw [h1]
+    exact hXu_mm
+  have instAκu : Algebra.IsAlgebraic K (IsLocalRing.ResidueField u.toValuationSubring) :=
+    isAlgebraic_residueField_of_X_mem u halgKXOu
+      (centerHeightOneSpectrum (Polynomial K) u hpmem).asIdeal.primeCompl hXKX_mm
+  have instPFκu : PerfectField (IsLocalRing.ResidueField u.toValuationSubring) :=
+    Algebra.IsAlgebraic.perfectField (K := K)
+  have instAκ : Algebra.IsAlgebraic (IsLocalRing.ResidueField u.toValuationSubring)
+      (IsLocalRing.ResidueField v.toValuationSubring) := by
+    constructor
+    intro y
+    obtain ⟨c, hc⟩ := surjective_residueOfCenter hu y
+    rw [← hc, residueOfCenter_apply]
+    apply isAlgebraic_residue
+    obtain ⟨p, hpm, hpe⟩ := c.2
+    refine ⟨p, hpm, ?_⟩
+    have hinj : Function.Injective (algebraMap v.toValuationSubring F) :=
+      IsFractionRing.injective _ _
+    apply hinj
+    rw [map_zero, Polynomial.hom_eval₂, hcompOuF]
+    exact hpe
+  have hmapmax : Ideal.map (algebraMap u.toValuationSubring v.toValuationSubring)
+      (IsLocalRing.maximalIdeal u.toValuationSubring)
+        = IsLocalRing.maximalIdeal v.toValuationSubring := by
+    apply le_antisymm
+    · exact ((IsLocalRing.local_hom_TFAE
+        (algebraMap u.toValuationSubring v.toValuationSubring)).out 1 3).mp instLH
+    · intro z hz
+      rcases eq_or_ne z 0 with rfl | hz0
+      · exact zero_mem _
+      have hposz : 0 < v.ord (algebraMap v.toValuationSubring F z) :=
+        (Place.mem_maximalIdeal_iff_ord_pos' hz0).mp hz
+      have hzF : (z : F) ≠ 0 := fun h => hz0 (ZeroMemClass.coe_eq_zero.mp h)
+      have hyne : (z : F) * (algebraMap (RatFunc K) F RatFunc.X)⁻¹ ≠ 0 :=
+        mul_ne_zero hzF (inv_ne_zero htne)
+      have hyord : 0 ≤ v.ord ((z : F) * (algebraMap (RatFunc K) F RatFunc.X)⁻¹) := by
+        rw [v.ord_mul hzF (inv_ne_zero htne), v.ord_inv, ht]
+        have hposz' : 0 < v.ord (z : F) := hposz
+        omega
+      have hymem : (z : F) * (algebraMap (RatFunc K) F RatFunc.X)⁻¹ ∈ v.toValuationSubring :=
+        v.mem_of_ord_nonneg hyne hyord
+      have hfact : z = algebraMap u.toValuationSubring v.toValuationSubring ⟨RatFunc.X, hXmem⟩
+          * ⟨(z : F) * (algebraMap (RatFunc K) F RatFunc.X)⁻¹, hymem⟩ := by
+        apply Subtype.ext
+        change (z : F) = (algebraMap u.toValuationSubring v.toValuationSubring
+          ⟨RatFunc.X, hXmem⟩ : F) * ((z : F) * (algebraMap (RatFunc K) F RatFunc.X)⁻¹)
+        rw [halgOuOv]
+        change (z : F) = algebraMap (RatFunc K) F RatFunc.X
+          * ((z : F) * (algebraMap (RatFunc K) F RatFunc.X)⁻¹)
+        rw [mul_comm (z : F) _, ← mul_assoc, mul_inv_cancel₀ htne, one_mul]
+      rw [hfact]
+      exact Ideal.mul_mem_right _ _ (Ideal.mem_map_of_mem _ hXu_mm)
+  have hFU1 : Algebra.FormallyUnramified u.toValuationSubring v.toValuationSubring :=
+    Algebra.FormallyUnramified.of_map_maximalIdeal hmapmax
+  have hFU0 : Algebra.FormallyUnramified (Polynomial K) u.toValuationSubring :=
+    Algebra.FormallyUnramified.of_isLocalization
+      (centerHeightOneSpectrum (Polynomial K) u hpmem).asIdeal.primeCompl
+  let instKXOv : Algebra (Polynomial K) v.toValuationSubring :=
+    ((algebraMap u.toValuationSubring v.toValuationSubring).comp
+      (algebraMap (Polynomial K) u.toValuationSubring)).toAlgebra
+  have instTowKXOuOv : IsScalarTower (Polynomial K) u.toValuationSubring
+      v.toValuationSubring := IsScalarTower.of_algebraMap_eq' rfl
+  have hFU : Algebra.FormallyUnramified (Polynomial K) v.toValuationSubring :=
+    Algebra.FormallyUnramified.comp (Polynomial K) u.toValuationSubring v.toValuationSubring
+  have instTowKKXOv : IsScalarTower K (Polynomial K) v.toValuationSubring := by
+    apply IsScalarTower.of_algebraMap_eq
+    intro a
+    apply Subtype.ext
+    rw [Place.coe_algebraMap]
+    change algebraMap K F a = (algebraMap u.toValuationSubring v.toValuationSubring
+      (algebraMap (Polynomial K) u.toValuationSubring (algebraMap K (Polynomial K) a)) : F)
+    rw [halgOuOv, halgKXOu, ← IsScalarTower.algebraMap_apply K (Polynomial K) (RatFunc K),
+      ← IsScalarTower.algebraMap_apply K (RatFunc K) F]
+  have hspan : ∀ ω : Ω[↥v.toValuationSubring⁄K], ω ∈ Submodule.span v.toValuationSubring
+      {D K v.toValuationSubring (algebraMap (Polynomial K) v.toValuationSubring
+        Polynomial.X)} := by
+    intro ω
+    have hexact := KaehlerDifferential.exact_mapBaseChange_map K (Polynomial K)
+      v.toValuationSubring
+    have h0 : KaehlerDifferential.map K (Polynomial K) v.toValuationSubring
+        v.toValuationSubring ω = 0 := Subsingleton.elim _ _
+    obtain ⟨ξ, hξ⟩ := (hexact ω).mp h0
+    rw [← hξ]
+    clear hξ
+    induction ξ using TensorProduct.inductionOn with
+    | tmul b ω' =>
+      rw [KaehlerDifferential.mapBaseChange_tmul]
+      have hω' : ω' = ((KaehlerDifferential.polynomialEquiv K) ω')
+          • D K (Polynomial K) Polynomial.X :=
+        ((KaehlerDifferential.polynomialEquiv K).symm_apply_apply ω').symm
+      rw [hω', map_smul, KaehlerDifferential.map_D]
+      rw [show ((KaehlerDifferential.polynomialEquiv K) ω') • D K v.toValuationSubring
+          (algebraMap (Polynomial K) v.toValuationSubring Polynomial.X)
+        = (algebraMap (Polynomial K) v.toValuationSubring
+            ((KaehlerDifferential.polynomialEquiv K) ω'))
+            • D K v.toValuationSubring (algebraMap (Polynomial K) v.toValuationSubring
+              Polynomial.X)
+        from (algebraMap_smul _ _ _).symm, smul_smul]
+      exact Submodule.smul_mem _ _ (Submodule.mem_span_singleton_self _)
+    | add ξ₁ ξ₂ h₁ h₂ =>
+      rw [map_add]
+      exact Submodule.add_mem _ h₁ h₂
+  have hfmem : f ∈ v.toValuationSubring := by
+    rcases eq_or_ne f 0 with rfl | hf0
+    · exact zero_mem _
+    · exact v.mem_of_ord_nonneg hf0 hf
+  obtain ⟨g, hg⟩ := Submodule.mem_span_singleton.mp
+    (hspan (D K v.toValuationSubring ⟨f, hfmem⟩))
+  have hpush := congrArg (KaehlerDifferential.map K K v.toValuationSubring F) hg
+  rw [map_smul, KaehlerDifferential.map_D, KaehlerDifferential.map_D] at hpush
+  have hXOvF : algebraMap v.toValuationSubring F
+      (algebraMap (Polynomial K) v.toValuationSubring Polynomial.X)
+        = algebraMap (RatFunc K) F RatFunc.X := by
+    change (algebraMap u.toValuationSubring v.toValuationSubring
+      (algebraMap (Polynomial K) u.toValuationSubring Polynomial.X) : F) = _
+    rw [halgOuOv, halgKXOu, RatFunc.algebraMap_X]
+  have hfOvF : algebraMap v.toValuationSubring F (⟨f, hfmem⟩ : v.toValuationSubring) = f := rfl
+  rw [hXOvF, hfOvF] at hpush
+  have hgsmul : ((g : F)) • D K F (algebraMap (RatFunc K) F RatFunc.X)
+      = g • D K F (algebraMap (RatFunc K) F RatFunc.X) := algebraMap_smul F g _
+  rw [← hgsmul] at hpush
+  exact ⟨g, v.ord_nonneg_of_mem g.2, hpush.symm⟩
+
+theorem ord_diffCoeff_D_nonneg_of_isSeparable {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [PerfectField K] (x : F) [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F) {t : F} (ht : v.ord t = 1)
+    [Algebra.IsSeparable (IntermediateField.adjoin K ({t} : Set F)) F]
+    {f : F} (hf : 0 ≤ v.ord f) :
+    0 ≤ v.ord (AlgebraicCurve.Place.diffCoeff t (KaehlerDifferential.D K F f)) := by
+  classical
+  have htr : Transcendental K t :=
+    v.transcendental_of_ord_ne_zero (by rw [ht]; exact one_ne_zero)
+  let e : RatFunc K ≃ₐ[K] ↥(IntermediateField.adjoin K ({t} : Set F)) :=
+    RatFunc.algEquivOfTranscendental t htr
+  let : Algebra (RatFunc K) (↥(IntermediateField.adjoin K ({t} : Set F))) :=
+    e.toAlgHom.toRingHom.toAlgebra
+  let : Algebra (RatFunc K) F :=
+    ((algebraMap (↥(IntermediateField.adjoin K ({t} : Set F))) F).comp
+      e.toAlgHom.toRingHom).toAlgebra
+  have : IsScalarTower (RatFunc K) (↥(IntermediateField.adjoin K ({t} : Set F))) F :=
+    IsScalarTower.of_algebraMap_eq fun q => rfl
+  have : IsScalarTower K (RatFunc K) F := IsScalarTower.of_algebraMap_eq fun r => by
+    change algebraMap K F r
+      = algebraMap (↥(IntermediateField.adjoin K ({t} : Set F))) F (e (algebraMap K (RatFunc K) r))
+    rw [AlgEquiv.commutes]
+    exact IsScalarTower.algebraMap_apply K (↥(IntermediateField.adjoin K ({t} : Set F))) F r
+  have : Module.Finite (RatFunc K) (↥(IntermediateField.adjoin K ({t} : Set F))) :=
+    Module.Finite.of_surjective
+      (Algebra.linearMap (RatFunc K) (↥(IntermediateField.adjoin K ({t} : Set F))))
+      e.surjective
+  have : FiniteDimensional (↥(IntermediateField.adjoin K ({t} : Set F))) F :=
+    AlgebraicCurve.finiteDimensional_adjoin_of_transcendental x htr
+  have : FiniteDimensional (RatFunc K) F :=
+    Module.Finite.trans (↥(IntermediateField.adjoin K ({t} : Set F))) F
+  have : Algebra.IsSeparable (RatFunc K) F :=
+    Algebra.IsSeparable.of_equiv_equiv e.symm.toRingEquiv (RingEquiv.refl F)
+      (RingHom.ext fun y => by
+        change algebraMap (↥(IntermediateField.adjoin K ({t} : Set F))) F (e (e.symm y))
+          = algebraMap (↥(IntermediateField.adjoin K ({t} : Set F))) F y
+        rw [AlgEquiv.apply_symm_apply])
+  have hXt : algebraMap (RatFunc K) F RatFunc.X = t :=
+    RatFunc.algEquivOfTranscendental_X t htr
+  have ht' : v.ord (algebraMap (RatFunc K) F RatFunc.X) = 1 := by rw [hXt]; exact ht
+  obtain ⟨g, hg, hDf⟩ := engine v rfl ht' hf
+  rw [hXt] at hDf
+  rw [hDf, diffCoeff_smul_D_eq_of_isSeparable v (by rw [ht]; exact one_ne_zero) g]
+  exact hg
+
+end FF2R4p
+end AlgebraicCurve
+end
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [PerfectField K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (v : AlgebraicCurve.Place K F)
+    {t : F}
+    (ht : v.ord t = 1)
+    [Algebra.IsSeparable (IntermediateField.adjoin K ({t} : Set F)) F] {f : F} (hf : 0 ≤ v.ord f) :
+    0 ≤ v.ord (AlgebraicCurve.Place.diffCoeff t (KaehlerDifferential.D K F f)) :=
+  AlgebraicCurve.FF2R4p.ord_diffCoeff_D_nonneg_of_isSeparable x v ht hf
+
+end S_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg_of_isSeparable
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg_of_isSeparable (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.ord_diffCoeff_D_nonneg_of_isSeparable {K F : Type*} [Field K] [Field F]
+    [Algebra K F] [PerfectField K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (v : AlgebraicCurve.Place K F)
+    {t : F}
+    (ht : v.ord t = 1)
+    [Algebra.IsSeparable (IntermediateField.adjoin K ({t} : Set F)) F] {f : F} (hf : 0 ≤ v.ord f) :
+    0 ≤ v.ord (AlgebraicCurve.Place.diffCoeff t (KaehlerDifferential.D K F f)) :=
+  solution x v ht hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg_of_perfectField.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg_of_perfectField.lean
new file mode 100644
index 0000000000..ce9b1453e3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg_of_perfectField.lean
@@ -0,0 +1,87 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.ord_diffCoeff_D_nonneg_of_perfectField
+(943f53ef-b24c-5e51-875e-f7b450639865) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ac2bef2a-2c90-5709-ac48-e1f904e7a8aa
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_isSeparable_adjoin_of_ord_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg_of_isSeparable
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Differentiation by a uniformiser preserves the valuation ring
+
+Theorem statement: `AlgebraicCurve.Place.ord_diffCoeff_D_nonneg_of_perfectField`
+(`943f53ef-b24c-5e51-875e-f7b450639865`), by Claude, 2026-09-05.
+
+Proof: submission `ac2bef2a-2c90-5709-ac48-e1f904e7a8aa`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra and $K$ perfect, and let $x \in F$ be such that $F$
+is finite-dimensional over the intermediate field $K(x) =$ `IntermediateField.adjoin K {x}`. Let $v$
+be a place of $F$ over $K$, that is, a valuation subring of $F$ which contains the image of $K$
+under the structure map, is not all of $F$, and is a principal ideal ring; write
+$\operatorname{ord}_v(g) = -\log$ of the value of $g$ under the associated $\mathbb{Z}^{m0}$-valued
+adic valuation of the corresponding height-one prime, an integer. Assume $t \in F$ satisfies
+$\operatorname{ord}_v(t) = 1$, and let $f \in F$ satisfy $0 \le \operatorname{ord}_v(f)$. The
+conclusion is $0 \le \operatorname{ord}_v\bigl(\mathrm{diffCoeff}(t, \mathrm{d}f)\bigr)$, where
+$\mathrm{d}f =$ `KaehlerDifferential.D K F f` in $\Omega_{F/K}$ and $\mathrm{diffCoeff}(t, \omega)$
+denotes a chosen $g \in F$ with $\omega = g \cdot \mathrm{d}t$ when such a $g$ exists, and $0$
+otherwise.
+
+This is the perfect-constant-field form of the statement that differentiation with respect to a
+uniformiser at $v$ carries the valuation ring of $v$ into itself; in characteristic $p$ it underlies
+the construction of the Cartier operator on differentials. It is used in the comparison of the
+differential order with the order of a differential at a place and in the behaviour of regular
+differentials under extension of the constant field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg_of_perfectField.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg_of_perfectField
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [PerfectField K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (v : AlgebraicCurve.Place K F)
+    {t : F}
+    (ht : v.ord t = 1) {f : F} (hf : 0 ≤ v.ord f) :
+    0 ≤ v.ord (AlgebraicCurve.Place.diffCoeff t (KaehlerDifferential.D K F f)) := by
+  have : Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F :=
+    Algebra.IsAlgebraic.of_finite _ _
+  have := AlgebraicCurve.Place.isSeparable_adjoin_of_ord_eq_one x v ht
+  exact AlgebraicCurve.Place.ord_diffCoeff_D_nonneg_of_isSeparable x v ht hf
+
+end S_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg_of_perfectField
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg_of_perfectField (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.ord_diffCoeff_D_nonneg_of_perfectField {K F : Type*} [Field K]
+    [Field F] [Algebra K F] [PerfectField K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (v : AlgebraicCurve.Place K F)
+    {t : F}
+    (ht : v.ord t = 1) {f : F} (hf : 0 ≤ v.ord f) :
+    0 ≤ v.ord (AlgebraicCurve.Place.diffCoeff t (KaehlerDifferential.D K F f)) :=
+  solution x v ht hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_dvd_of_forall_hahnSeries_embedding_hasRamBound.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_dvd_of_forall_hahnSeries_embedding_hasRamBound.lean
new file mode 100644
index 0000000000..44b8ce0eb2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_dvd_of_forall_hahnSeries_embedding_hasRamBound.lean
@@ -0,0 +1,305 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.ord_dvd_of_forall_hahnSeries_embedding_hasRamBound
+(f165bcf6-81a8-5fab-9912-9eaa96ffdc12) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e1fe62cf-fdd4-5a20-8892-3deed39d03c1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import Mathlib.RingTheory.HahnSeries.PowerSeries
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_RamificationBound
+
+import Mathlib.Algebra.Algebra.IsSimpleRing
+import Mathlib.Algebra.Lie.OfAssociative
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_restrict_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_dvd_of_hahnSeries_embedding_of_isGalois
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_isAlgClosed_rat
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_mem_puiseuxRamSubfield_iff
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Bounded Puiseux denominators bound ramification over a closed point
+
+Theorem statement: `AlgebraicCurve.Place.ord_dvd_of_forall_hahnSeries_embedding_hasRamBound`
+(`f165bcf6-81a8-5fab-9912-9eaa96ffdc12`), by Claude, 2026-09-05.
+
+Proof: submission `e1fe62cf-fdd4-5a20-8892-3deed39d03c1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field of characteristic $0$, let $L$ be an algebraically closed field which is a
+$K$-algebra, and let $F$ be a field equipped with $K$-algebra and $\mathrm{RatFunc}\,K$-algebra
+structures which are compatible (a scalar tower over $K$) and with $F$ finite-dimensional over
+$\mathrm{RatFunc}\,K$. Let $p \in K[X]$ be irreducible and let $a \in L$ satisfy $p(a) = 0$ and
+$p'(a) \neq 0$, so $a$ is a simple root of $p$ in $L$. Let $d$ be a natural number with $0 < d$.
+Assume that for every $K$-algebra homomorphism $\psi \colon F \to
+\mathrm{HahnSeries}\,\mathbb{Q}\,L$ sending the image of $X$ in $F$ to $\mathrm{C}(a) + t$ (the Hahn
+series $a$ plus the monomial with coefficient $1$ in degree $1$), and for every $x \in F$, the
+series $\psi(x)$ satisfies [`HahnSeries.HasRamBound d`](def/HahnSeries_RamificationBound.html#L32),
+i.e. its support is contained in the set of rationals $k/d$ with $k \in \mathbb{Z}$. Let $w$ be a
+place of $F$ over $K$, that is, a valuation subring of $F$ containing
+$\mathrm{algebraMap}\,K\,F(K)$, different from $F$ itself, and a principal ideal ring; its order
+function is $w.\mathrm{ord}(f) = -\log$ of the value of $f$ under the $\mathbb{Z}^{m0}$-valued adic
+valuation attached to the maximal ideal of that subring. If $w.\mathrm{ord}$ of the image of $p$ in
+$F$ is positive, then this order divides $d$ in $\mathbb{Z}$.
+
+This is the Newton–Puiseux ramification criterion in the form used downstream: if all branches of
+the finite cover $F / K(X)$ above the closed point $p$, expanded as Hahn series in a local parameter
+$t = X - a$ at a simple root $a$ of $p$, have support in $\tfrac{1}{d}\mathbb{Z}$, then the
+ramification index of every place of $F$ above $p$ divides $d$ (the case $d = 1$ being
+unramifiedness). It is applied to modular curves, in the divisibility statements for $\mathrm{ord}$
+of $j$ and of $j - 1728$ at places of the relevant function fields.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ord_dvd_of_forall_hahnSeries_embedding_hasRamBound.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ord_dvd_of_forall_hahnSeries_embedding_hasRamBound
+
+noncomputable section
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_Place_ord_dvd_of_forall_hahnSeries_embedding_hasRamBound.AlgebraicCurve \
+  Polynomial"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ord_dvd_of_hahnSeries_embedding_of_isGalois \
+  Place.exists_restrict_eq"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ord ramificationIndex_pos ord_restrict \
+  ord_dvd_of_hahnSeries_embedding_of_isGalois exists_restrict_eq"
+namespace HahnUnramDescentAux
+p2m_open "AlgebraicCurve.Place AlgebraicCurve"
+
+theorem algebraMap_hahn_eq_C {K L : Type*} [Field K] [Field L] [Algebra K L] (c : K) :
+    (algebraMap K (HahnSeries ℚ L)) c = HahnSeries.C (algebraMap K L c) := by
+  rw [HahnSeries.algebraMap_apply', IsScalarTower.algebraMap_apply K L (PowerSeries L),
+    PowerSeries.algebraMap_eq, HahnSeries.ofPowerSeries_C]
+
+theorem eval₂_C_single_one {L : Type*} [Field L] (q : L[X]) :
+    q.eval₂ (HahnSeries.C : L →+* HahnSeries ℚ L) (HahnSeries.single (1 : ℚ) (1 : L))
+      = HahnSeries.ofPowerSeries ℚ L (q : PowerSeries L) := by
+  have heq : (Polynomial.eval₂RingHom (HahnSeries.C : L →+* HahnSeries ℚ L)
+        (HahnSeries.single (1 : ℚ) (1 : L)))
+      = (HahnSeries.ofPowerSeries ℚ L).comp (Polynomial.coeToPowerSeries.ringHom (R := L)) := by
+    refine Polynomial.ringHom_ext (fun c => ?_) ?_
+    · rw [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_C, RingHom.coe_comp, Function.comp_apply,
+        Polynomial.coeToPowerSeries.ringHom_apply, Polynomial.coe_C, HahnSeries.ofPowerSeries_C]
+    · rw [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X, RingHom.coe_comp, Function.comp_apply,
+        Polynomial.coeToPowerSeries.ringHom_apply, Polynomial.coe_X, HahnSeries.ofPowerSeries_X]
+  have := congrArg (fun f : L[X] →+* HahnSeries ℚ L => f q) heq
+  simpa [Polynomial.coeToPowerSeries.ringHom_apply] using this
+
+theorem hasRamBound_one_ofPowerSeries {L : Type*} [Field L] (x : PowerSeries L) :
+    HahnSeries.HasRamBound 1 (HahnSeries.ofPowerSeries ℚ L x) := by
+  intro g hg
+  have hg' : g ∈ Set.range ((↑) : ℕ → ℚ) := by
+    by_contra h
+    rw [HahnSeries.mem_support, HahnSeries.ofPowerSeries_apply] at hg
+    exact hg (HahnSeries.embDomain_of_notMem_range (by simpa using h))
+  obtain ⟨m, rfl⟩ := hg'
+  exact ⟨(m : ℤ), by push_cast; ring⟩
+
+theorem aeval_C_add_single {K L : Type*} [Field K] [Field L] [Algebra K L] (a : L) (p : K[X]) :
+    Polynomial.aeval (R := K) (HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L)) p
+      = HahnSeries.ofPowerSeries ℚ L
+          ((((p.map (algebraMap K L)).comp (X + C a) : L[X])) : PowerSeries L) := by
+  set t : HahnSeries ℚ L := HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L) with ht
+  have h1 : (Polynomial.aeval (R := K) t).toRingHom
+      = Polynomial.eval₂RingHom ((HahnSeries.C : L →+* HahnSeries ℚ L).comp (algebraMap K L)) t
+        := by
+    refine Polynomial.ringHom_ext (fun c => ?_) ?_
+    · rw [AlgHom.toRingHom_eq_coe, RingHom.coe_coe, Polynomial.aeval_C, algebraMap_hahn_eq_C,
+        Polynomial.coe_eval₂RingHom, Polynomial.eval₂_C, RingHom.coe_comp, Function.comp_apply]
+    · rw [AlgHom.toRingHom_eq_coe, RingHom.coe_coe, Polynomial.aeval_X,
+        Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X]
+  have h2 := congrArg (fun f : K[X] →+* HahnSeries ℚ L => f p) h1
+  simp only [AlgHom.toRingHom_eq_coe, RingHom.coe_coe, Polynomial.coe_eval₂RingHom] at h2
+  rw [h2, ← Polynomial.eval₂_map, ← eval₂_C_single_one, Polynomial.eval₂_comp,
+    Polynomial.eval₂_add, Polynomial.eval₂_X, Polynomial.eval₂_C, ht, add_comm]
+
+theorem aeval_C_add_single_injective {K L : Type*} [Field K] [Field L] [Algebra K L] (a : L) :
+    Function.Injective
+      (Polynomial.aeval (R := K) (HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L))) := by
+  intro p₁ p₂ h
+  have h' := h
+  rw [aeval_C_add_single, aeval_C_add_single] at h'
+  have h3 := HahnSeries.ofPowerSeries_injective h'
+  rw [Polynomial.coe_inj] at h3
+  have h4 : (p₁.map (algebraMap K L)) = (p₂.map (algebraMap K L)) := by
+    have := congrArg (fun r : L[X] => r.comp (X - C a)) h3
+    simpa [Polynomial.comp_assoc] using this
+  exact Polynomial.map_injective _ (algebraMap K L).injective h4
+
+end AlgebraicCurve.Place.HahnUnramDescentAux
+
+open AlgebraicCurve.Place.HahnUnramDescentAux in
+theorem solution
+    {K L F : Type*} [Field K] [CharZero K] [Field L] [Algebra K L] [IsAlgClosed L]
+    [Field F] [Algebra K F] [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [FiniteDimensional (RatFunc K) F]
+    (p : Polynomial K) (hp : Irreducible p) (a : L)
+    (ha : Polynomial.aeval a p = 0) (ha' : Polynomial.aeval a (Polynomial.derivative p) ≠ 0)
+    {d : ℕ} (hd : 0 < d)
+    (hF : ∀ ψ : F →ₐ[K] HahnSeries ℚ L,
+      ψ (algebraMap (RatFunc K) F (algebraMap (Polynomial K) (RatFunc K) Polynomial.X))
+          = HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L) →
+        ∀ x : F, HahnSeries.HasRamBound d (ψ x))
+    (w : AlgebraicCurve.Place K F)
+    (hw : 0 < w.ord (algebraMap (RatFunc K) F (algebraMap (Polynomial K) (RatFunc K) p))) :
+    w.ord (algebraMap (RatFunc K) F (algebraMap (Polynomial K) (RatFunc K) p)) ∣ (d : ℤ) := by
+  classical
+  set t : HahnSeries ℚ L := HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L) with ht
+  set X₀ : RatFunc K := algebraMap (Polynomial K) (RatFunc K) Polynomial.X with hX₀
+  set f₀ : RatFunc K := algebraMap (Polynomial K) (RatFunc K) p with hf₀
+  let E := AlgebraicClosure F
+  have : Algebra.IsAlgebraic (RatFunc K) E := Algebra.IsAlgebraic.trans (RatFunc K) F E
+  have : IsAlgClosure (RatFunc K) E := IsAlgClosure.ofAlgebraic (RatFunc K) F E
+  let M := IntermediateField.normalClosure (RatFunc K) F E
+  have : FiniteDimensional F M := Module.Finite.of_restrictScalars_finite (RatFunc K) F M
+  have : IsScalarTower K F M := IsScalarTower.of_algebraMap_eq (fun c => rfl)
+  have : Algebra.IsSeparable F M := Algebra.isSeparable_tower_top_of_isSeparable (RatFunc K) F M
+  let φ : Polynomial K →ₐ[K] HahnSeries ℚ L := Polynomial.aeval t
+  have hφ : nonZeroDivisors (Polynomial K)
+      ≤ Submonoid.comap φ (nonZeroDivisors (HahnSeries ℚ L)) := by
+    intro q hq
+    rw [Submonoid.mem_comap, mem_nonZeroDivisors_iff_ne_zero]
+    rw [mem_nonZeroDivisors_iff_ne_zero] at hq
+    intro h0
+    exact hq (aeval_C_add_single_injective (K := K) a (by rw [map_zero]; exact h0))
+  let τ : RatFunc K →ₐ[K] HahnSeries ℚ L := RatFunc.liftAlgHom φ hφ
+  have hτp : ∀ q : Polynomial K, τ (algebraMap (Polynomial K) (RatFunc K) q) = φ q := by
+    intro q
+    have h := RatFunc.liftAlgHom_apply_div φ hφ q 1
+    rwa [map_one, div_one, map_one, div_one] at h
+  have hτX : τ X₀ = t := by rw [hX₀, hτp]; exact Polynomial.aeval_X t
+  let : Algebra (RatFunc K) (HahnSeries ℚ L) := τ.toRingHom.toAlgebra
+  have hτalg : ∀ r : RatFunc K, algebraMap (RatFunc K) (HahnSeries ℚ L) r = τ r := fun r => rfl
+  have : IsAlgClosed (HahnSeries ℚ L) := HahnSeries.isAlgClosed_rat
+  let ψM : M →ₐ[RatFunc K] HahnSeries ℚ L := IsAlgClosed.lift
+  let ψ : M →ₐ[K] HahnSeries ℚ L :=
+    { toRingHom := ψM.toRingHom
+      commutes' := fun c => by
+        change ψM (algebraMap K M c) = algebraMap K (HahnSeries ℚ L) c
+        rw [IsScalarTower.algebraMap_apply K (RatFunc K) M, ψM.commutes, hτalg, τ.commutes] }
+  have hψapply : ∀ m : M, ψ m = ψM m := fun m => rfl
+  have hψX : ψ (algebraMap (RatFunc K) M X₀)
+      = HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L) := by
+    rw [hψapply, ψM.commutes, hτalg]
+    exact hτX
+  have hLaurent : ∀ y : HahnSeries ℚ L,
+      y ∈ HahnSeries.puiseuxRamSubfield L hd ↔ HahnSeries.HasRamBound d y :=
+    fun y => HahnSeries.mem_puiseuxRamSubfield_iff hd
+  have hmono : ∀ y : HahnSeries ℚ L, HahnSeries.HasRamBound 1 y → HahnSeries.HasRamBound d y := by
+    intro y hy g hg
+    obtain ⟨m, hm⟩ := hy hg
+    refine ⟨m * d, ?_⟩
+    rw [← hm]
+    have hd0 : (d : ℚ) ≠ 0 := by exact_mod_cast hd.ne'
+    push_cast
+    field_simp
+  have hτmem : ∀ r : RatFunc K, τ r ∈ HahnSeries.puiseuxRamSubfield L hd := by
+    intro r
+    refine RatFunc.induction_on (P := fun r => τ r ∈ HahnSeries.puiseuxRamSubfield L hd)
+      r (fun p₁ q₁ _ => ?_)
+    change τ (algebraMap K[X] (RatFunc K) p₁ / algebraMap K[X] (RatFunc K) q₁) ∈ _
+    rw [map_div₀, hτp, hτp]
+    refine div_mem ?_ ?_ <;>
+    · rw [hLaurent]
+      apply hmono
+      change HahnSeries.HasRamBound 1 (Polynomial.aeval (R := K) t _)
+      rw [ht, aeval_C_add_single]
+      exact hasRamBound_one_ofPowerSeries _
+  let T : Subfield (HahnSeries ℚ L) := HahnSeries.puiseuxRamSubfield L hd
+  let S : IntermediateField (RatFunc K) M :=
+    (T.comap ψM.toRingHom).toIntermediateField (fun r => by
+      change ψM (algebraMap (RatFunc K) M r) ∈ T
+      rw [ψM.commutes]
+      exact hτmem r)
+  have hmemS : ∀ m : M, m ∈ S ↔ ψM m ∈ T := fun m => Iff.rfl
+  have hS : S = ⊤ := by
+    apply IntermediateField.lift_injective M
+    rw [IntermediateField.lift_top]
+    refine le_antisymm (IntermediateField.lift_le S) ?_
+    change IntermediateField.normalClosure (RatFunc K) F E ≤ IntermediateField.lift S
+    unfold IntermediateField.normalClosure
+    refine iSup_le (fun g => ?_)
+    rintro x ⟨y, rfl⟩
+    have hgy : ∀ y : F, g y ∈ M := fun y => AlgHom.fieldRange_le_normalClosure g ⟨y, rfl⟩
+    let g' : F →ₐ[RatFunc K] M := g.codRestrict M.toSubalgebra hgy
+    change ((g' y : M) : E) ∈ IntermediateField.lift S
+    rw [IntermediateField.mem_lift, hmemS, hLaurent]
+    let ψF : F →ₐ[K] HahnSeries ℚ L :=
+      { toRingHom := (ψM.comp g').toRingHom
+        commutes' := fun c => by
+          change ψM (g' (algebraMap K F c)) = algebraMap K (HahnSeries ℚ L) c
+          rw [IsScalarTower.algebraMap_apply K (RatFunc K) F, g'.commutes, ψM.commutes, hτalg,
+            τ.commutes] }
+    have hψFapply : ∀ x : F, ψF x = ψM (g' x) := fun x => rfl
+    have hψF : ψF (algebraMap (RatFunc K) F X₀) = t := by
+      rw [hψFapply, g'.commutes, ψM.commutes, hτalg]
+      exact hτX
+    have := hF ψF hψF y
+    rwa [hψFapply] at this
+  have hψLaurent : ∀ m : M, HahnSeries.HasRamBound d (ψ m) := by
+    intro m
+    have hm : m ∈ S := by rw [hS]; exact IntermediateField.mem_top
+    rw [hψapply]
+    exact (hLaurent _).mp ((hmemS m).mp hm)
+  have hcore := AlgebraicCurve.Place.ord_dvd_of_hahnSeries_embedding_of_isGalois
+    (K := K) (L := L) (M := M) p hp a ha ha' ψ hψX hd hψLaurent
+  obtain ⟨W, hWw⟩ := AlgebraicCurve.Place.exists_restrict_eq (K := K) (F' := F) (M := M) w
+  have hrel := W.ord_restrict (F := F) (algebraMap (RatFunc K) F f₀)
+  rw [hWw, ← IsScalarTower.algebraMap_apply (RatFunc K) F M] at hrel
+  have he := W.ramificationIndex_pos (F := F)
+  have hWpos : 0 < W.ord (algebraMap (RatFunc K) M f₀) := by
+    rw [hrel]; exact mul_pos (by exact_mod_cast he) hw
+  have hW1 := hcore W hWpos
+  rw [hrel] at hW1
+  exact (dvd_mul_left _ _).trans hW1
+
+end
+
+end S_AlgebraicCurve_Place_ord_dvd_of_forall_hahnSeries_embedding_hasRamBound
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ord_dvd_of_forall_hahnSeries_embedding_hasRamBound (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.ord_dvd_of_forall_hahnSeries_embedding_hasRamBound
+    {K L F : Type*} [Field K] [CharZero K] [Field L] [Algebra K L] [IsAlgClosed L]
+    [Field F] [Algebra K F] [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [FiniteDimensional (RatFunc K) F]
+    (p : Polynomial K) (hp : Irreducible p) (a : L)
+    (ha : Polynomial.aeval a p = 0) (ha' : Polynomial.aeval a (Polynomial.derivative p) ≠ 0)
+    {d : ℕ} (hd : 0 < d)
+    (hF : ∀ ψ : F →ₐ[K] HahnSeries ℚ L,
+      ψ (algebraMap (RatFunc K) F (algebraMap (Polynomial K) (RatFunc K) Polynomial.X))
+          = HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L) →
+        ∀ x : F, HahnSeries.HasRamBound d (ψ x))
+    (w : AlgebraicCurve.Place K F)
+    (hw : 0 < w.ord (algebraMap (RatFunc K) F (algebraMap (Polynomial K) (RatFunc K) p))) :
+    w.ord (algebraMap (RatFunc K) F (algebraMap (Polynomial K) (RatFunc K) p)) ∣ (d : ℤ) :=
+  solution p hp a ha ha' hd hF w hw
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_dvd_of_hahnSeries_embedding_of_isGalois.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_dvd_of_hahnSeries_embedding_of_isGalois.lean
new file mode 100644
index 0000000000..5a2ead6e9d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_dvd_of_hahnSeries_embedding_of_isGalois.lean
@@ -0,0 +1,312 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.ord_dvd_of_hahnSeries_embedding_of_isGalois
+(6246ce2f-6eb6-5afc-ad64-e8999f7315b9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d49158f7-8e25-5256-9535-4265044dccd0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import Mathlib.RingTheory.HahnSeries.PowerSeries
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_RamificationBound
+
+import Mathlib.Data.Int.Star
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_hasRamBound
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ramificationIndex_eq_of_restrict_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty_algebraMap
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Puiseux bound d forces ord_W(p)∣ d
+
+Theorem statement: `AlgebraicCurve.Place.ord_dvd_of_hahnSeries_embedding_of_isGalois`
+(`6246ce2f-6eb6-5afc-ad64-e8999f7315b9`), by Claude, 2026-09-05.
+
+Proof: submission `d49158f7-8e25-5256-9535-4265044dccd0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K\subseteq L$ be fields ($L$ a $K$-algebra), and let $M$ be a field that is simultaneously a
+$K$-algebra and an algebra over the rational function field $\mathrm{RatFunc}\,K$, the two
+structures being compatible (scalar tower $K\subseteq \mathrm{RatFunc}\,K\subseteq M$), with $M$
+finite-dimensional and Galois over $\mathrm{RatFunc}\,K$. Let $p\in K[X]$ be irreducible and let
+$a\in L$ satisfy $p(a)=0$ and $p'(a)\neq 0$, i.e. $a$ is a simple root of $p$ in $L$. Let
+$\psi\colon M\to \mathrm{HahnSeries}\,\mathbb{Q}\,L$ be a $K$-algebra homomorphism into the Hahn
+series field with value group $\mathbb{Q}$ and coefficients in $L$, such that $\psi$ sends the image
+of $X$ in $M$ to $a+t$, that is to the constant series $a$ plus the monomial with exponent $1$ and
+coefficient $1$. Let $d$ be a positive natural number and assume that for every $m\in M$ the series
+$\psi(m)$ has $\mathrm{HasRamBound}\ d$, i.e. its support is contained in $\{k/d :
+k\in\mathbb{Z}\}$. Finally, let $W$ be a place of $M$ over $K$ — a valuation subring of $M$
+containing $\mathrm{algebraMap}\,K\,M(K)$, different from $M$ itself, and a principal ideal ring —
+and write $\mathrm{ord}_W$ for the associated $\mathbb{Z}$-valued order function, minus the
+logarithm of the adic valuation attached to the height-one prime of $W$. Assume $\mathrm{ord}_W$ of
+the image of $p$ in $M$ is strictly positive, i.e. $W$ lies over the place $(p)$ of $K(X)$. Then
+$\mathrm{ord}_W$ of the image of $p$ divides $d$ in $\mathbb{Z}$.
+
+This is the divisibility form of the classical statement that Puiseux expansions with denominators
+dividing $d$ bound the ramification: every place of $M$ above the closed point $(p)$ of the rational
+function field has ramification index dividing $d$, the case $d=1$ being the Laurent-series
+criterion for unramifiedness. It is used by
+[`AlgebraicCurve.Place.ord_dvd_of_forall_hahnSeries_embedding_hasRamBound`]
+(thm.html#AlgebraicCurve.Place.ord_dvd_of_forall_hahnSeries_embedding_hasRamBound).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ord_dvd_of_hahnSeries_embedding_of_isGalois.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ord_dvd_of_hahnSeries_embedding_of_isGalois
+
+noncomputable section
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_Place_ord_dvd_of_hahnSeries_embedding_of_isGalois.AlgebraicCurve Polynomial"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ord_ofHeightOneSpectrum_ne_zero_iff \
+  RationalFunctionField.finitePlace Place.exists_ord_mul_eq_order_of_hasRamBound \
+  Place.ramificationIndex_eq_of_restrict_eq \
+  RationalFunctionField.eq_ofHeightOneSpectrum_or_eq_placeInfty \
+  RationalFunctionField.ord_placeInfty_algebraMap"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ord ord_coe_irreducible toValuationSubring ramificationIndex \
+  ramificationIndex_pos restrict ord_restrict ord_ofHeightOneSpectrum_ne_zero_iff \
+  exists_ord_mul_eq_order_of_hasRamBound ramificationIndex_eq_of_restrict_eq"
+namespace HahnUnramAux
+p2m_open "AlgebraicCurve.Place AlgebraicCurve"
+
+theorem algebraMap_hahn_eq_C {K L : Type*} [Field K] [Field L] [Algebra K L] (c : K) :
+    (algebraMap K (HahnSeries ℚ L)) c = HahnSeries.C (algebraMap K L c) := by
+  rw [HahnSeries.algebraMap_apply', IsScalarTower.algebraMap_apply K L (PowerSeries L),
+    PowerSeries.algebraMap_eq, HahnSeries.ofPowerSeries_C]
+
+theorem eval₂_C_single_one {L : Type*} [Field L] (q : L[X]) :
+    q.eval₂ (HahnSeries.C : L →+* HahnSeries ℚ L) (HahnSeries.single (1 : ℚ) (1 : L))
+      = HahnSeries.ofPowerSeries ℚ L (q : PowerSeries L) := by
+  have heq : (Polynomial.eval₂RingHom (HahnSeries.C : L →+* HahnSeries ℚ L)
+        (HahnSeries.single (1 : ℚ) (1 : L)))
+      = (HahnSeries.ofPowerSeries ℚ L).comp (Polynomial.coeToPowerSeries.ringHom (R := L)) := by
+    refine Polynomial.ringHom_ext (fun c => ?_) ?_
+    · rw [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_C, RingHom.coe_comp, Function.comp_apply,
+        Polynomial.coeToPowerSeries.ringHom_apply, Polynomial.coe_C, HahnSeries.ofPowerSeries_C]
+    · rw [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X, RingHom.coe_comp, Function.comp_apply,
+        Polynomial.coeToPowerSeries.ringHom_apply, Polynomial.coe_X, HahnSeries.ofPowerSeries_X]
+  have := congrArg (fun f : L[X] →+* HahnSeries ℚ L => f q) heq
+  simpa [Polynomial.coeToPowerSeries.ringHom_apply] using this
+
+theorem order_ofPowerSeries_eq_one {L : Type*} [Field L] (q : L[X]) (h0 : q.coeff 0 = 0)
+    (h1 : q.coeff 1 ≠ 0) :
+    (HahnSeries.ofPowerSeries ℚ L (q : PowerSeries L)).order = 1 := by
+  set x := HahnSeries.ofPowerSeries ℚ L (q : PowerSeries L) with hx
+  have hc1 : x.coeff (1 : ℚ) ≠ 0 := by
+    have : x.coeff ((1 : ℕ) : ℚ) = q.coeff 1 := by
+      rw [hx, HahnSeries.ofPowerSeries_apply_coeff, Polynomial.coeff_coe]
+    rw [Nat.cast_one] at this
+    rwa [this]
+  have hx0 : x ≠ 0 := fun h => hc1 (by rw [h]; rfl)
+  refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero hc1) ?_
+  have hsupp : x.order ∈ x.support := by
+    rw [HahnSeries.mem_support]; exact fun h => hx0 (HahnSeries.coeff_order_eq_zero.mp h)
+  have hrange : x.support ⊆ Set.range (fun n : ℕ => (n : ℚ)) := by
+    intro g hg
+    by_contra hng
+    rw [HahnSeries.mem_support, hx, HahnSeries.ofPowerSeries_apply] at hg
+    exact hg (HahnSeries.embDomain_of_notMem_range (by simpa using hng))
+  obtain ⟨n, hn⟩ := hrange hsupp
+  have hcn : x.coeff (n : ℚ) = q.coeff n := by
+    rw [hx, HahnSeries.ofPowerSeries_apply_coeff, Polynomial.coeff_coe]
+  have hn0 : n ≠ 0 := by
+    rintro rfl
+    rw [HahnSeries.mem_support, ← hn, hcn, h0] at hsupp
+    exact hsupp rfl
+  rw [← hn]
+  change (1 : ℚ) ≤ (n : ℚ)
+  exact_mod_cast Nat.one_le_iff_ne_zero.mpr hn0
+
+theorem taylor_coeffs {K L : Type*} [Field K] [Field L] [Algebra K L] (p : K[X]) (a : L)
+    (ha : aeval a p = 0) (ha' : aeval a (derivative p) ≠ 0) :
+    ((p.map (algebraMap K L)).comp (X + C a)).coeff 0 = 0 ∧
+      ((p.map (algebraMap K L)).comp (X + C a)).coeff 1 ≠ 0 := by
+  set pL := p.map (algebraMap K L) with hpL
+  constructor
+  · rw [Polynomial.coeff_zero_eq_eval_zero, Polynomial.eval_comp, Polynomial.eval_add,
+      Polynomial.eval_X, Polynomial.eval_C, zero_add, hpL, Polynomial.eval_map,
+      ← Polynomial.aeval_def, ha]
+  · have hd : ((pL.comp (X + C a)).coeff 1 : L) = (derivative (pL.comp (X + C a))).coeff 0 := by
+      rw [Polynomial.coeff_derivative]; simp
+    rw [hd, Polynomial.derivative_comp]
+    simp only [Polynomial.derivative_add, Polynomial.derivative_X, Polynomial.derivative_C,
+      add_zero, one_mul]
+    rw [Polynomial.coeff_zero_eq_eval_zero, Polynomial.eval_comp, Polynomial.eval_add,
+      Polynomial.eval_X, Polynomial.eval_C, zero_add, hpL, Polynomial.derivative_map,
+      Polynomial.eval_map, ← Polynomial.aeval_def]
+    exact ha'
+
+open AlgebraicCurve.RationalFunctionField in
+theorem eq_finitePlace_of_ord_pos {K : Type*} [Field K] {p : K[X]} (hp : Irreducible p)
+    (v : Place K (RatFunc K)) (hv : 0 < v.ord (algebraMap K[X] (RatFunc K) p)) :
+    v = finitePlace K hp := by
+  classical
+  rcases AlgebraicCurve.RationalFunctionField.eq_ofHeightOneSpectrum_or_eq_placeInfty v with
+    ⟨w, rfl⟩ | rfl
+  · have hmem : p ∈ w.asIdeal :=
+      (Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w hp.ne_zero).mp
+        hv.ne'
+    have hle : Ideal.span {p} ≤ w.asIdeal := (Ideal.span_singleton_le_iff_mem _).mpr hmem
+    have hmax : (Ideal.span {p}).IsMaximal := PrincipalIdealRing.isMaximal_of_irreducible hp
+    have heq : Ideal.span {p} = w.asIdeal := hmax.eq_of_le w.isPrime.ne_top hle
+    have hw : w = heightOneSpectrumOfIrreducible K hp := by
+      ext1; rw [← heq, heightOneSpectrumOfIrreducible_asIdeal]
+    rw [hw, finitePlace_def]
+  · exfalso
+    rw [AlgebraicCurve.RationalFunctionField.ord_placeInfty_algebraMap hp.ne_zero] at hv
+    have := p.natDegree.cast_nonneg (α := ℤ)
+    omega
+
+end AlgebraicCurve.Place.HahnUnramAux
+
+open AlgebraicCurve.Place.HahnUnramAux in
+theorem solution
+    {K L M : Type*} [Field K] [Field L] [Algebra K L] [Field M] [Algebra K M]
+    [Algebra (RatFunc K) M] [IsScalarTower K (RatFunc K) M]
+    [FiniteDimensional (RatFunc K) M] [IsGalois (RatFunc K) M]
+    (p : Polynomial K) (hp : Irreducible p) (a : L)
+    (ha : Polynomial.aeval a p = 0) (ha' : Polynomial.aeval a (Polynomial.derivative p) ≠ 0)
+    (ψ : M →ₐ[K] HahnSeries ℚ L)
+    (hψX : ψ (algebraMap (RatFunc K) M (algebraMap (Polynomial K) (RatFunc K) Polynomial.X))
+      = HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L))
+    {d : ℕ} (hd : 0 < d) (hψ : ∀ m : M, HahnSeries.HasRamBound d (ψ m))
+    (W : AlgebraicCurve.Place K M)
+    (hW : 0 < W.ord (algebraMap (RatFunc K) M (algebraMap (Polynomial K) (RatFunc K) p))) :
+    W.ord (algebraMap (RatFunc K) M (algebraMap (Polynomial K) (RatFunc K) p)) ∣ (d : ℤ) := by
+  classical
+  set f₀ : RatFunc K := algebraMap (Polynomial K) (RatFunc K) p with hf₀
+  set f : M := algebraMap (RatFunc K) M f₀ with hf
+  set ρ : K[X] →+* HahnSeries ℚ L :=
+    ψ.toRingHom.comp ((algebraMap (RatFunc K) M).comp (algebraMap K[X] (RatFunc K))) with hρ
+  have hρC : ∀ c : K, ρ (C c) = HahnSeries.C (algebraMap K L c) := by
+    intro c
+    simp only [hρ, RingHom.coe_comp, Function.comp_apply, AlgHom.toRingHom_eq_coe,
+      RingHom.coe_coe]
+    rw [Polynomial.C_eq_algebraMap, ← IsScalarTower.algebraMap_apply K K[X] (RatFunc K),
+      ← IsScalarTower.algebraMap_apply K (RatFunc K) M, ψ.commutes, algebraMap_hahn_eq_C]
+  have hρX : ρ X = HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L) := by
+    simp only [hρ, RingHom.coe_comp, Function.comp_apply, AlgHom.toRingHom_eq_coe,
+      RingHom.coe_coe]
+    exact hψX
+  have hρeq : ρ = Polynomial.eval₂RingHom ((HahnSeries.C : L →+* HahnSeries ℚ L).comp
+      (algebraMap K L)) (HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L)) := by
+    refine Polynomial.ringHom_ext (fun c => ?_) ?_
+    · rw [hρC, Polynomial.coe_eval₂RingHom, Polynomial.eval₂_C, RingHom.coe_comp,
+        Function.comp_apply]
+    · rw [hρX, Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X]
+  set q : L[X] := (p.map (algebraMap K L)).comp (X + C a) with hq
+  have hψf : ψ f = HahnSeries.ofPowerSeries ℚ L (q : PowerSeries L) := by
+    have h1 : ψ f = ρ p := by simp [hρ, hf, hf₀]
+    rw [h1, hρeq, Polynomial.coe_eval₂RingHom, ← Polynomial.eval₂_map, ← eval₂_C_single_one,
+      hq, Polynomial.eval₂_comp, Polynomial.eval₂_add, Polynomial.eval₂_X, Polynomial.eval₂_C,
+      add_comm]
+  obtain ⟨hq0, hq1⟩ := taylor_coeffs p a ha ha'
+  have horder : (ψ f).order = 1 := by
+    rw [hψf]; exact order_ofPowerSeries_eq_one q hq0 hq1
+  obtain ⟨W₀, g, hg, hW₀⟩ :=
+    AlgebraicCurve.Place.exists_ord_mul_eq_order_of_hasRamBound ψ hd hψ
+      ⟨f, by rw [horder]; exact one_ne_zero⟩
+  obtain ⟨ϖ, hϖ⟩ := IsDiscreteValuationRing.exists_irreducible W₀.toValuationSubring
+  have hϖ0 : (ϖ : M) ≠ 0 := by
+    have := hϖ.ne_zero
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using this
+  have hψϖ0 : ψ (ϖ : M) ≠ 0 := (map_ne_zero_iff ψ ψ.toRingHom.injective).mpr hϖ0
+  obtain ⟨k, hk⟩ : ∃ k : ℤ, (ψ (ϖ : M)).order = (k : ℚ) / d := by
+    have hmem : (ψ (ϖ : M)).order ∈ (ψ (ϖ : M)).support := by
+      rw [HahnSeries.mem_support]; exact fun h => hψϖ0 (HahnSeries.coeff_order_eq_zero.mp h)
+    obtain ⟨k, hk⟩ := hψ (ϖ : M) hmem
+    exact ⟨k, hk.symm⟩
+  have hgk : g = (k : ℚ) / d := by
+    have := hW₀ (ϖ : M)
+    rw [W₀.ord_coe_irreducible hϖ, Int.cast_one, one_mul, hk] at this
+    exact this
+  have hdpos : (0 : ℚ) < d := by exact_mod_cast hd
+  have hkpos : 0 < k := by
+    have h : (0 : ℚ) < (k : ℚ) / d := hgk ▸ hg
+    exact_mod_cast (div_pos_iff_of_pos_right hdpos).mp h
+  have hW₀f : W₀.ord f * k = d := by
+    have h := hW₀ f
+    rw [horder, hgk, mul_div_assoc', div_eq_one_iff_eq hdpos.ne'] at h
+    exact_mod_cast h
+  have hW₀dvd : W₀.ord f ∣ (d : ℤ) := Dvd.intro k hW₀f
+  have hW₀pos : 0 < W₀.ord f := by
+    have h : 0 < W₀.ord f * k := by rw [hW₀f]; exact_mod_cast hd
+    by_contra hle
+    push Not at hle
+    have : W₀.ord f * k ≤ 0 := mul_nonpos_of_nonpos_of_nonneg hle hkpos.le
+    omega
+  have hvW : W.restrict (RatFunc K) = RationalFunctionField.finitePlace K hp := by
+    refine eq_finitePlace_of_ord_pos hp _ ?_
+    have h := W.ord_restrict (F := RatFunc K) f₀
+    have he := W.ramificationIndex_pos (F := RatFunc K)
+    rw [← hf] at h
+    by_contra hneg
+    push Not at hneg
+    have : W.ord f ≤ 0 := by
+      rw [h]; exact mul_nonpos_of_nonneg_of_nonpos (by exact_mod_cast he.le) hneg
+    omega
+  have hvW₀ : W₀.restrict (RatFunc K) = RationalFunctionField.finitePlace K hp := by
+    refine eq_finitePlace_of_ord_pos hp _ ?_
+    have h := W₀.ord_restrict (F := RatFunc K) f₀
+    have he := W₀.ramificationIndex_pos (F := RatFunc K)
+    rw [← hf] at h
+    by_contra hneg
+    push Not at hneg
+    have : W₀.ord f ≤ 0 := by
+      rw [h]; exact mul_nonpos_of_nonneg_of_nonpos (by exact_mod_cast he.le) hneg
+    omega
+  have hres : W.restrict (RatFunc K) = W₀.restrict (RatFunc K) := hvW.trans hvW₀.symm
+  have he : W.ramificationIndex (RatFunc K) = W₀.ramificationIndex (RatFunc K) :=
+    AlgebraicCurve.Place.ramificationIndex_eq_of_restrict_eq W₀ W hres
+  have h1 := W.ord_restrict (F := RatFunc K) f₀
+  have h2 := W₀.ord_restrict (F := RatFunc K) f₀
+  rw [← hf] at h1 h2
+  rw [h1, he, hres, ← h2]
+  exact hW₀dvd
+
+end
+
+end S_AlgebraicCurve_Place_ord_dvd_of_hahnSeries_embedding_of_isGalois
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ord_dvd_of_hahnSeries_embedding_of_isGalois (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.ord_dvd_of_hahnSeries_embedding_of_isGalois
+    {K L M : Type*} [Field K] [Field L] [Algebra K L] [Field M] [Algebra K M]
+    [Algebra (RatFunc K) M] [IsScalarTower K (RatFunc K) M]
+    [FiniteDimensional (RatFunc K) M] [IsGalois (RatFunc K) M]
+    (p : Polynomial K) (hp : Irreducible p) (a : L)
+    (ha : Polynomial.aeval a p = 0) (ha' : Polynomial.aeval a (Polynomial.derivative p) ≠ 0)
+    (ψ : M →ₐ[K] HahnSeries ℚ L)
+    (hψX : ψ (algebraMap (RatFunc K) M (algebraMap (Polynomial K) (RatFunc K) Polynomial.X))
+      = HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L))
+    {d : ℕ} (hd : 0 < d) (hψ : ∀ m : M, HahnSeries.HasRamBound d (ψ m))
+    (W : AlgebraicCurve.Place K M)
+    (hW : 0 < W.ord (algebraMap (RatFunc K) M (algebraMap (Polynomial K) (RatFunc K) p))) :
+    W.ord (algebraMap (RatFunc K) M (algebraMap (Polynomial K) (RatFunc K) p)) ∣ (d : ℤ) :=
+  solution p hp a ha ha' ψ hψX hd hψ W hW
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_eq_neg_log_of_valuationSubring_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_eq_neg_log_of_valuationSubring_eq.lean
new file mode 100644
index 0000000000..d2201132aa
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_eq_neg_log_of_valuationSubring_eq.lean
@@ -0,0 +1,126 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.ord_eq_neg_log_of_valuationSubring_eq
+(55fadbf2-8d9e-519d-bf4e-525b671655aa) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4e012cfe-b87b-512b-a0eb-3c4e5c312cd9
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_isEquiv_adicValuation_of_valuationSubring_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order at a place computed by any valuation with the same ring
+
+Theorem statement: `AlgebraicCurve.Place.ord_eq_neg_log_of_valuationSubring_eq`
+(`55fadbf2-8d9e-519d-bf4e-525b671655aa`), by Claude, 2026-09-05.
+
+Proof: submission `4e012cfe-b87b-512b-a0eb-3c4e5c312cd9`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$, that is, a
+valuation subring of $F$ containing the image of $K$ under the structure map, distinct from $F$
+itself, and a principal ideal ring. Let $w$ be a valuation on $F$ with values in $\mathbb{Z}^{m0} =
+\mathrm{WithZero}(\mathrm{Multiplicative}\ \mathbb{Z})$ whose valuation subring coincides with the
+valuation subring of $v$, and suppose there is an element $\pi \in F$ with $w(\pi) = \exp(-1)$, the
+image of $-1 \in \mathbb{Z}$ in $\mathbb{Z}^{m0}$. Then for every nonzero $f \in F$ one has
+$v.\mathrm{ord}(f) = -\mathrm{log}(w(f))$, where by definition $v.\mathrm{ord}(f)$ is
+$-\mathrm{log}$ of the value at $f$ of the adic valuation attached to $v$, namely the
+height-one-spectrum valuation on $F$ of the corresponding prime of the valuation subring. Thus $w$,
+normalised so as to take the value $\exp(-1)$ somewhere, computes the order function of the place on
+the nose, not merely up to equivalence.
+
+This is the normalisation transfer for the order function of a place: equivalence of valuations
+determines the conditions $w(x) \le 1$, $=1$, $<1$, but not the integer order, and attaining the
+value $\exp(-1)$ pins down the normalisation. It is used throughout the treatment of divisors on
+curves, for instance when identifying the order functions of the places of a rational function field
+with the valuations given by explicit uniformisers.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ord_eq_neg_log_of_valuationSubring_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ord_eq_neg_log_of_valuationSubring_eq
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_Place_ord_eq_neg_log_of_valuationSubring_eq.AlgebraicCurve"
+open IsDedekindDomain WithZero IsLocalRing
+open scoped Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place"
+namespace WFa
+p2m_open "AlgebraicCurve"
+
+theorem le_exp_neg_one_of_lt_one {x : ℤᵐ⁰} (hx : x < 1) : x ≤ exp (-1 : ℤ) := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · exact zero_le
+  · rw [← exp_log hx0] at hx ⊢
+    rw [show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_lt_exp] at hx
+    rw [exp_le_exp]
+    omega
+
+end AlgebraicCurve.WFa
+
+open AlgebraicCurve.WFa in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+    (w : Valuation F (WithZero (Multiplicative ℤ))) (hw : w.valuationSubring = v.toValuationSubring)
+    {π : F} (hπ : w π = WithZero.exp (-1 : ℤ)) {f : F} (hf : f ≠ 0) :
+    v.ord f = -WithZero.log (w f) := by
+  have hequiv : w.IsEquiv v.adicValuation :=
+    v.isEquiv_adicValuation_of_valuationSubring_eq hw
+  have hexp_lt : (exp (-1 : ℤ) : ℤᵐ⁰) < 1 := by
+    rw [show (1 : ℤᵐ⁰) = exp 0 from rfl]
+    exact exp_lt_exp.mpr (by omega)
+  obtain ⟨π₀, hπ₀⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hadic_π₀ : v.adicValuation (π₀ : F) = exp (-1 : ℤ) := v.adicValuation_coe_irreducible hπ₀
+  have hwπ₀ : w (π₀ : F) = exp (-1 : ℤ) := by
+    refine le_antisymm (le_exp_neg_one_of_lt_one (hequiv.lt_one_iff_lt_one.mpr ?_)) ?_
+    · rw [hadic_π₀]
+      exact hexp_lt
+    · rw [← hπ]
+      refine (hequiv π π₀).mpr ?_
+      rw [hadic_π₀]
+      refine le_exp_neg_one_of_lt_one (hequiv.lt_one_iff_lt_one.mp ?_)
+      rw [hπ]
+      exact hexp_lt
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ₀
+  have hwu : w ((u : v.toValuationSubring) : F) = 1 :=
+    hequiv.eq_one_iff_eq_one.mpr ((v.adicValuation_coe_eq_one_iff _).mpr u.isUnit)
+  set n := v.ord f with hn
+  rw [hu, map_mul, map_zpow₀, hwu, hwπ₀, one_mul, log_zpow, log_exp, smul_eq_mul]
+  ring
+
+end S_AlgebraicCurve_Place_ord_eq_neg_log_of_valuationSubring_eq
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ord_eq_neg_log_of_valuationSubring_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.ord_eq_neg_log_of_valuationSubring_eq {K F : Type*} [Field K] [Field F]
+    [Algebra K F] (v : Place K F) (w : Valuation F (WithZero (Multiplicative ℤ)))
+    (hw : w.valuationSubring = v.toValuationSubring) {π : F} (hπ : w π = WithZero.exp (-1 : ℤ))
+    {f : F} (hf : f ≠ 0) :
+    v.ord f = -WithZero.log (w f) :=
+  solution v w hw hπ hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_eq_zero_of_isIntegral_adjoin.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_eq_zero_of_isIntegral_adjoin.lean
new file mode 100644
index 0000000000..aa26b0dbf5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_eq_zero_of_isIntegral_adjoin.lean
@@ -0,0 +1,94 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.ord_eq_zero_of_isIntegral_adjoin
+(cf819755-b119-5538-81c0-fd5d8764e198) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c4de5ba7-527e-5d01-8a09-a46cff0a51c2
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_mem_toValuationSubring_of_isIntegral_adjoin
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integral with integral inverse over K[j] implies order zero
+
+Theorem statement: `AlgebraicCurve.Place.ord_eq_zero_of_isIntegral_adjoin`
+(`cf819755-b119-5538-81c0-fd5d8764e198`), by Claude, 2026-09-05.
+
+Proof: submission `c4de5ba7-527e-5d01-8a09-a46cff0a51c2`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+project's sense: a valuation subring $v.\mathrm{toValuationSubring}$ of $F$ that contains the image
+of $K$ under the structure map, is not all of $F$, and is a principal ideal ring. Let $j, x \in F$,
+suppose $j$ lies in $v.\mathrm{toValuationSubring}$, and suppose that both $x$ and $x^{-1}$ are
+integral over the $K$-subalgebra $\mathrm{Algebra.adjoin}\ K\ \{j\}$ of $F$ generated by $j$, i.e.
+each is a root of a monic polynomial with coefficients in $K[j]$. Then $v.\mathrm{ord}\ x = 0$,
+where $v.\mathrm{ord}$ is minus the logarithm of the value of the adic valuation attached to $v$
+(the $\mathbb{Z}^{m0}$-valued valuation of the height-one prime of $v.\mathrm{toValuationSubring}$),
+so that $v.\mathrm{ord}$ is the normalised order of vanishing at $v$, with the value $0$ at $x = 0$
+by Lean's inversion convention $0^{-1} = 0$ being consistent with the hypotheses.
+
+The statement records that an element of $F$ which, together with its inverse, is integral over
+$K[j]$ is a unit at every place where $j$ is integral, hence has order zero there. It is used in the
+modular-curve part of the development, for instance in locating the support of divisors of modular
+units at the cusps and in the height and cuspidal-class computations that cite it.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ord_eq_zero_of_isIntegral_adjoin.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ord_eq_zero_of_isIntegral_adjoin
+
+open AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) {j x : F}
+    (hj : j ∈ v.toValuationSubring) (hx : IsIntegral (Algebra.adjoin K {j}) x)
+    (hx' : IsIntegral (Algebra.adjoin K {j}) x⁻¹) :
+    v.ord x = 0 := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · exact v.ord_zero
+  · have hxa : x ∈ v.toValuationSubring :=
+      v.mem_toValuationSubring_of_isIntegral_adjoin hj hx
+    have hxi : x⁻¹ ∈ v.toValuationSubring :=
+      v.mem_toValuationSubring_of_isIntegral_adjoin hj hx'
+    have hunit : IsUnit (⟨x, hxa⟩ : v.toValuationSubring) := by
+      refine isUnit_iff_exists_inv.mpr ⟨⟨x⁻¹, hxi⟩, ?_⟩
+      ext
+      simp [mul_inv_cancel₀ hx0]
+    have h1 : v.adicValuation x = 1 :=
+      (v.adicValuation_coe_eq_one_iff ⟨x, hxa⟩).mpr hunit
+    simp [AlgebraicCurve.Place.ord, h1]
+
+end S_AlgebraicCurve_Place_ord_eq_zero_of_isIntegral_adjoin
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ord_eq_zero_of_isIntegral_adjoin (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.ord_eq_zero_of_isIntegral_adjoin {K F : Type*} [Field K] [Field F]
+    [Algebra K F] (v : Place K F) {j x : F} (hj : j ∈ v.toValuationSubring)
+    (hx : IsIntegral (Algebra.adjoin K {j}) x) (hx' : IsIntegral (Algebra.adjoin K {j}) x⁻¹) :
+    v.ord x = 0 :=
+  solution v hj hx hx'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_eq_zero_of_not_mem_of_eval_monic_eq_zero_of_coeff_eq_aeval_inv_div.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_eq_zero_of_not_mem_of_eval_monic_eq_zero_of_coeff_eq_aeval_inv_div.lean
new file mode 100644
index 0000000000..959cc128d1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_eq_zero_of_not_mem_of_eval_monic_eq_zero_of_coeff_eq_aeval_inv_div.lean
@@ -0,0 +1,226 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.Place.ord_eq_zero_of_not_mem_of_eval_monic_eq_zero_of_coeff_eq_aeval_inv_div
+(a3cc0f5a-ee93-5487-81f1-c26e1a71e350) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2ead6451-88b8-5b4f-af04-e79cd8ad8fb3
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order zero for elements integral over K[1/j]_{(1/j)} and inverse
+
+Theorem statement:
+`AlgebraicCurve.Place.ord_eq_zero_of_not_mem_of_eval_monic_eq_zero_of_coeff_eq_aeval_inv_div`
+(`a3cc0f5a-ee93-5487-81f1-c26e1a71e350`), by Claude, 2026-09-05.
+
+Proof: submission `2ead6451-88b8-5b4f-af04-e79cd8ad8fb3`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$: a
+valuation subring $\mathcal{O}_v =$ `v.toValuationSubring` of $F$ which contains the image of $K$
+under the structure map, is not all of $F$, and is a principal ideal ring. Let $j \in F$ with $j
+\notin \mathcal{O}_v$, and let $P, Q \in F[X]$ be monic polynomials such that for every index $i$
+the $i$-th coefficient of $P$, and likewise of $Q$, can be written as $p(j^{-1})/q(j^{-1})$ for some
+$p, q \in K[X]$ (evaluation via the $K$-algebra map into $F$) with the constant coefficient of $q$
+nonzero. Suppose finally that $x \in F$ satisfies $P(x) = 0$ and $Q(x^{-1}) = 0$. Then
+$\operatorname{ord}_v(x) = 0$, where $\operatorname{ord}_v$ is the integer-valued invariant $-\log$
+of the adic valuation attached to the height-one spectrum of $\mathcal{O}_v$.
+
+This is the local statement that an element of $F$ which, together with its inverse, is integral
+over the local ring of the $j$-line at $j = \infty$ has order zero at every place where $j$ has a
+pole; the integrality is presented concretely through monic equations whose coefficients are ratios
+of polynomials in $j^{-1}$ with invertible denominator. It is used by
+[`ModularCurve.ord_eq_zero_of_not_mem_of_realizeOf_tendsto`]
+(thm.html#ModularCurve.ord_eq_zero_of_not_mem_of_realizeOf_tendsto).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ord_eq_zero_of_not_mem_of_eval_monic_eq_zero_of_coeff_eq_aeval_inv_div.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_b7453246
+
+noncomputable section
+
+open Polynomial
+
+namespace ModularCurve
+namespace Ws49
+namespace N3
+
+open AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem ord_eq_zero_of_mem_of_inv_mem (v : Place K F) {x : F}
+    (hx : x ∈ v.toValuationSubring) (hx' : x⁻¹ ∈ v.toValuationSubring) : v.ord x = 0 := by
+  rcases eq_or_ne x 0 with rfl | h0
+  · exact v.ord_zero
+  · have h1 : 0 ≤ v.ord x := (v.mem_iff_ord_nonneg h0).mp hx
+    have h2 : 0 ≤ v.ord x⁻¹ := (v.mem_iff_ord_nonneg (inv_ne_zero h0)).mp hx'
+    rw [v.ord_inv] at h2
+    omega
+
+theorem inv_mem_and_valuation_lt_one_of_not_mem (v : Place K F) {j : F}
+    (hj : j ∉ v.toValuationSubring) :
+    j⁻¹ ∈ v.toValuationSubring ∧ v.toValuationSubring.valuation j⁻¹ < 1 := by
+  have hmem : j⁻¹ ∈ v.toValuationSubring := by
+    rcases v.toValuationSubring.mem_or_inv_mem j with h | h
+    · exact absurd h hj
+    · exact h
+  refine ⟨hmem, ?_⟩
+  have hle : v.toValuationSubring.valuation j⁻¹ ≤ 1 :=
+    (v.toValuationSubring.valuation_le_one_iff _).mpr hmem
+  rcases hle.lt_or_eq with hlt | heq
+  · exact hlt
+  · exfalso
+    apply hj
+    have hj0 : j ≠ 0 := by
+      rintro rfl
+      exact hj (zero_mem _)
+    rw [← v.toValuationSubring.valuation_le_one_iff]
+    have : v.toValuationSubring.valuation j = 1 := by
+      have h := map_inv₀ v.toValuationSubring.valuation j
+      rw [heq] at h
+      exact inv_eq_one.mp h.symm
+    exact this.le
+
+theorem valuation_algebraMap_eq_one (v : Place K F) {c : K} (hc : c ≠ 0) :
+    v.toValuationSubring.valuation (algebraMap K F c) = 1 := by
+  have h1 : v.toValuationSubring.valuation (algebraMap K F c) ≤ 1 :=
+    (v.toValuationSubring.valuation_le_one_iff _).mpr (v.algebraMap_mem' c)
+  have h2 : v.toValuationSubring.valuation (algebraMap K F c⁻¹) ≤ 1 :=
+    (v.toValuationSubring.valuation_le_one_iff _).mpr (v.algebraMap_mem' c⁻¹)
+  have hc0 : algebraMap K F c ≠ 0 := (map_ne_zero_iff _ (algebraMap K F).injective).mpr hc
+  have hprod : v.toValuationSubring.valuation (algebraMap K F c) *
+      v.toValuationSubring.valuation (algebraMap K F c⁻¹) = 1 := by
+    rw [← map_mul, map_inv₀ (algebraMap K F), mul_inv_cancel₀ hc0, map_one]
+  by_contra hne
+  have hlt : v.toValuationSubring.valuation (algebraMap K F c) < 1 := lt_of_le_of_ne h1 hne
+  have : v.toValuationSubring.valuation (algebraMap K F c) *
+      v.toValuationSubring.valuation (algebraMap K F c⁻¹) < 1 :=
+    calc v.toValuationSubring.valuation (algebraMap K F c) *
+          v.toValuationSubring.valuation (algebraMap K F c⁻¹)
+        ≤ v.toValuationSubring.valuation (algebraMap K F c) * 1 := by gcongr
+      _ = v.toValuationSubring.valuation (algebraMap K F c) := mul_one _
+      _ < 1 := hlt
+  rw [hprod] at this
+  exact lt_irrefl _ this
+
+theorem aeval_mem (v : Place K F) {u : F} (hu : u ∈ v.toValuationSubring) (r : K[X]) :
+    aeval u r ∈ v.toValuationSubring := by
+  induction r using Polynomial.induction_on' with
+  | add p q hp hq => rw [map_add]; exact add_mem hp hq
+  | monomial n a =>
+    rw [aeval_monomial]
+    exact mul_mem (v.algebraMap_mem' a) (pow_mem hu n)
+
+theorem valuation_aeval_eq_one (v : Place K F) {u : F} (hu : u ∈ v.toValuationSubring)
+    (hu1 : v.toValuationSubring.valuation u < 1) (q : K[X]) (hq : q.coeff 0 ≠ 0) :
+    v.toValuationSubring.valuation (aeval u q) = 1 := by
+  obtain ⟨r, hr⟩ : ∃ r : K[X], q = C (q.coeff 0) + X * r := ⟨q.divX, by
+    conv_lhs => rw [← q.divX_mul_X_add]
+    ring⟩
+  have hval_r : v.toValuationSubring.valuation (aeval u r) ≤ 1 :=
+    (v.toValuationSubring.valuation_le_one_iff _).mpr (aeval_mem v hu r)
+  have hsmall : v.toValuationSubring.valuation (u * aeval u r) < 1 := by
+    rw [map_mul]
+    calc v.toValuationSubring.valuation u * v.toValuationSubring.valuation (aeval u r)
+        ≤ v.toValuationSubring.valuation u * 1 := by gcongr
+      _ = v.toValuationSubring.valuation u := mul_one _
+      _ < 1 := hu1
+  have hconst : v.toValuationSubring.valuation (algebraMap K F (q.coeff 0)) = 1 :=
+    valuation_algebraMap_eq_one v hq
+  have hq' : aeval u q = algebraMap K F (q.coeff 0) + u * aeval u r := by
+    conv_lhs => rw [hr]
+    simp [map_add, map_mul, aeval_C, aeval_X]
+  rw [hq']
+  rw [Valuation.map_add_eq_of_lt_left]
+  · exact hconst
+  · rw [hconst]; exact hsmall
+
+theorem aeval_div_aeval_mem (v : Place K F) {u : F} (hu : u ∈ v.toValuationSubring)
+    (hu1 : v.toValuationSubring.valuation u < 1) (p q : K[X]) (hq : q.coeff 0 ≠ 0) :
+    aeval u p / aeval u q ∈ v.toValuationSubring := by
+  rw [← v.toValuationSubring.valuation_le_one_iff, map_div₀, valuation_aeval_eq_one v hu hu1 q hq,
+    div_one, v.toValuationSubring.valuation_le_one_iff]
+  exact aeval_mem v hu p
+
+theorem mem_of_monic_of_coeff_eq_aeval_div (v : Place K F) {u : F} (hu : u ∈ v.toValuationSubring)
+    (hu1 : v.toValuationSubring.valuation u < 1) {P : F[X]} (hP : P.Monic)
+    (hcoeff : ∀ i, ∃ p q : K[X], q.coeff 0 ≠ 0 ∧ P.coeff i = aeval u p / aeval u q)
+    {x : F} (hx : P.eval x = 0) : x ∈ v.toValuationSubring := by
+  refine v.mem_of_eval_monic_eq_zero hP (fun i => ?_) hx
+  obtain ⟨p, q, hq, hi⟩ := hcoeff i
+  rw [hi]
+  exact aeval_div_aeval_mem v hu hu1 p q hq
+
+theorem ord_eq_zero_of_not_mem (v : Place K F) {j : F} (hj : j ∉ v.toValuationSubring)
+    {P Q : F[X]} (hP : P.Monic) (hQ : Q.Monic)
+    (hPc : ∀ i, ∃ p q : K[X], q.coeff 0 ≠ 0 ∧ P.coeff i = aeval j⁻¹ p / aeval j⁻¹ q)
+    (hQc : ∀ i, ∃ p q : K[X], q.coeff 0 ≠ 0 ∧ Q.coeff i = aeval j⁻¹ p / aeval j⁻¹ q)
+    {x : F} (hx : P.eval x = 0) (hx' : Q.eval x⁻¹ = 0) : v.ord x = 0 := by
+  obtain ⟨hu, hu1⟩ := inv_mem_and_valuation_lt_one_of_not_mem v hj
+  exact ord_eq_zero_of_mem_of_inv_mem v
+    (mem_of_monic_of_coeff_eq_aeval_div v hu hu1 hP hPc hx)
+    (mem_of_monic_of_coeff_eq_aeval_div v hu hu1 hQ hQc hx')
+
+end ModularCurve.Ws49.N3
+
+end
+
+open Polynomial in
+theorem solution
+    {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : AlgebraicCurve.Place K F) {j : F} (hj : j ∉ v.toValuationSubring)
+    {P Q : F[X]} (hP : P.Monic) (hQ : Q.Monic)
+    (hPc : ∀ i, ∃ p q : K[X], q.coeff 0 ≠ 0 ∧ P.coeff i = aeval j⁻¹ p / aeval j⁻¹ q)
+    (hQc : ∀ i, ∃ p q : K[X], q.coeff 0 ≠ 0 ∧ Q.coeff i = aeval j⁻¹ p / aeval j⁻¹ q)
+    {x : F} (hx : P.eval x = 0) (hx' : Q.eval x⁻¹ = 0) :
+    v.ord x = 0 :=
+  ModularCurve.Ws49.N3.ord_eq_zero_of_not_mem v hj hP hQ hPc hQc hx hx'
+
+end S_OVERLONG_b7453246
+end P2MW
+export
+  P2MW.S_OVERLONG_b7453246
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Polynomial
+theorem AlgebraicCurve.Place.ord_eq_zero_of_not_mem_of_eval_monic_eq_zero_of_coeff_eq_aeval_inv_div
+    {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : AlgebraicCurve.Place K F) {j : F} (hj : j ∉ v.toValuationSubring)
+    {P Q : F[X]} (hP : P.Monic) (hQ : Q.Monic)
+    (hPc : ∀ i, ∃ p q : K[X], q.coeff 0 ≠ 0 ∧ P.coeff i = aeval j⁻¹ p / aeval j⁻¹ q)
+    (hQc : ∀ i, ∃ p q : K[X], q.coeff 0 ≠ 0 ∧ Q.coeff i = aeval j⁻¹ p / aeval j⁻¹ q)
+    {x : F} (hx : P.eval x = 0) (hx' : Q.eval x⁻¹ = 0) :
+    v.ord x = 0 :=
+  solution v hj hP hQ hPc hQc hx hx'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_natCast.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_natCast.lean
new file mode 100644
index 0000000000..3a1d34e7ac
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_natCast.lean
@@ -0,0 +1,93 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.ord_natCast
+(e2a0b930-e803-57bb-9cf6-8e5d4e7bd6cd) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 30234e90-66a2-57c0-9e40-ebc2f672ca39
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Natural-number constants have order zero at a place
+
+Theorem statement: `AlgebraicCurve.Place.ord_natCast` (`e2a0b930-e803-57bb-9cf6-8e5d4e7bd6cd`), by
+Claude, 2026-09-05.
+
+Proof: submission `30234e90-66a2-57c0-9e40-ebc2f672ca39`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+sense of the divisor-class-group module: a valuation subring of $F$ that contains the image of $K$
+under the structure map, is not all of $F$, and is a principal ideal ring. Attached to such a $v$ is
+its adic valuation $v.adicValuation$, the $\mathbb{Z}^{m0}$-valued valuation on $F$ associated with
+the height-one prime determined by $v$, and the order function $v.\mathrm{ord}(f) =
+-\mathrm{log}\,(v.adicValuation\,f)$, where $\mathrm{log}$ is the `WithZero` logarithm, so that in
+particular $v.\mathrm{ord}(0) = 0$ by convention. The assertion is that for every natural number
+$n$, the image of $n$ in $F$ under the canonical cast satisfies $v.\mathrm{ord}(n) = 0$. No
+hypothesis on the characteristic of $F$ is imposed: in characteristic $p$ the cast of $n$ may
+vanish, and the conclusion still holds because of the convention giving $0$ order zero.
+
+This is the familiar statement that a place of $F$ over $K$ is trivial on constants, specialised to
+the constants coming from the prime ring; it is used in the computations of orders of differentials,
+being cited by
+[`AlgebraicCurve.Place.ordDiff_D_eq_ord_sub_one`]
+(thm.html#AlgebraicCurve.Place.ordDiff_D_eq_ord_sub_one),
+[`AlgebraicCurve.Place.ordDiff_D_nonneg`](thm.html#AlgebraicCurve.Place.ordDiff_D_nonneg) and
+[`AlgebraicCurve.Place.ordDiff_eq_ord_diffCoeff`]
+(thm.html#AlgebraicCurve.Place.ordDiff_eq_ord_diffCoeff).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ord_natCast.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ord_natCast
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ord_algebraMap"
+namespace FF2S
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem ord_natCast (v : Place K F) (n : ℕ) : v.ord (n : F) = 0 := by
+  rw [show (n : F) = algebraMap K F n by simp]
+  exact v.ord_algebraMap n
+
+end AlgebraicCurve.FF2S
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : AlgebraicCurve.Place K F)
+    (n : ℕ) :
+    v.ord (n : F) = 0 :=
+  AlgebraicCurve.FF2S.ord_natCast v n
+
+end S_AlgebraicCurve_Place_ord_natCast
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ord_natCast (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.ord_natCast {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : AlgebraicCurve.Place K F) (n : ℕ) :
+    v.ord (n : F) = 0 :=
+  solution v n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_restrictAlong_eq_natCard_algHom_of_isGalois.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_restrictAlong_eq_natCard_algHom_of_isGalois.lean
new file mode 100644
index 0000000000..09ed9819b4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_restrictAlong_eq_natCard_algHom_of_isGalois.lean
@@ -0,0 +1,860 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.ord_restrictAlong_eq_natCard_algHom_of_isGalois
+(8e50de98-6fdc-590e-b2ee-1ad607fe9b17) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3200129a-66ed-582e-b880-3c9441cb337b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+
+import Mathlib.Algebra.Lie.OfAssociative
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_card_fiberOver_mul_ramificationIndex_mul_inertiaDeg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_deg_eq_one_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_deg_ne_zero_of_finiteDimensional_adjoin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_algEquiv_smul_eq_of_restrict_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_restrictAlong_surjective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_restrict_ofAlgAut_smul
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Hilbert decomposition over a rational place of K(t)
+
+Theorem statement: `AlgebraicCurve.Place.ord_restrictAlong_eq_natCard_algHom_of_isGalois`
+(`8e50de98-6fdc-590e-b2ee-1ad607fe9b17`), by Claude, 2026-09-05.
+
+Proof: submission `3200129a-66ed-582e-b880-3c9441cb337b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field and let $F$, $M$ be fields equipped with $K$-algebra
+structures. Fix $x \in F$, $t \in M$, $j_0 \in K$, a $K$-algebra homomorphism $\iota : F \to M$ with
+$\iota(x) = t$, and assume $M$ is a finite-dimensional Galois extension of the subfield $K\langle
+t\rangle$ generated by $t$ over $K$, and that for every $K$-algebra homomorphism $\psi : F \to M$
+with $\psi(x) = t$ the underlying ring homomorphism is integral. Let $W_0$ be a place of $M$ over
+$K$ (a valuation subring of $M$ containing the image of $K$, distinct from $M$, whose ring is a
+principal ideal ring) with $\operatorname{ord}_{W_0}(t - j_0) > 0$, the order being minus the
+logarithm of the associated adic valuation. Writing $D$ for the set of $\sigma \in
+\mathrm{Gal}(M/K\langle t\rangle)$ whose associated semilinear automorphism $(\sigma,
+\mathrm{id}_K)$ fixes $W_0$, and $W_0|_\psi$ for the place of $F$ with valuation subring
+$\psi^{-1}(\mathcal O_{W_0})$, the conclusion is the conjunction: (1) $\operatorname{ord}_{W_0}(t -
+j_0) = \#D$; (2) $\operatorname{ord}_{W_0|_\psi}(x - j_0) > 0$ for every such $\psi$; (3) every
+place $w$ of $F$ over $K$ with $\operatorname{ord}_w(x - j_0) > 0$ equals $W_0|_\psi$ for some such
+$\psi$; (4) $W_0|_\psi = W_0|_{\psi'}$ if and only if $\psi' = \sigma \circ \psi$ for some $\sigma
+\in D$; (5) $\operatorname{ord}_{W_0|_\psi}(x - j_0)$ equals the number of $\psi'$ with $\psi'(x) =
+t$ and $W_0|_{\psi'} = W_0|_\psi$.
+
+This is Hilbert's decomposition theory for a place of an intermediate field of a Galois extension,
+specialised to a place of $M$ above the rational place $t = j_0$ of $K(t)$ with $K$ algebraically
+closed, so that residue degrees are $1$ and ramification indices are orders of decomposition groups;
+the places of $F$ above $x = j_0$ are thereby identified with the classes of $K$-embeddings $F \to
+M$ sending $x$ to $t$ modulo the decomposition group. It underlies the double-coset count of places
+and the ramification contributions used in the degree and genus estimates for modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ord_restrictAlong_eq_natCard_algHom_of_isGalois.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+open AlgebraicCurve Place
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ord_restrictAlong_eq_natCard_algHom_of_isGalois
+
+
+open AlgebraicCurve IsDedekindDomain WithZero
+open scoped IntermediateField
+
+noncomputable section
+
+namespace P2MKcA
+namespace HilbertB
+
+section Engine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+
+theorem mem_of_ord_sub_pos (w : Place K F) {f : F} {c : K}
+    (h : 0 < w.ord (f - algebraMap K F c)) : f ∈ w.toValuationSubring := by
+  have hne : f - algebraMap K F c ≠ 0 := by
+    intro h0
+    rw [h0, Place.ord_zero] at h
+    exact lt_irrefl _ h
+  have := add_mem (mem_of_ord_nonneg w hne h.le) (w.algebraMap_mem' c)
+  rwa [sub_add_cancel] at this
+
+theorem ord_eq_one_of_valuation_eq (w : Place K F) {v' : Valuation F ℤᵐ⁰}
+    (hv' : v'.valuationSubring = w.toValuationSubring) {x : F} (hx : v' x = exp (-1 : ℤ)) :
+    w.ord x = 1 := by
+  have hE := w.isEquiv_adicValuation_of_valuationSubring_eq hv'
+  have hx0 : v' x ≠ 0 := by rw [hx]; exact exp_ne_zero
+  have hu0 : w.adicValuation x ≠ 0 := (hE.eq_zero).ne.mp hx0
+  have hlt : w.adicValuation x < 1 := by
+    refine hE.lt_one_iff_lt_one.mp ?_
+    rw [hx, ← exp_zero]
+    exact exp_lt_exp.mpr (by norm_num)
+  obtain ⟨ϖ, hϖ⟩ := w.heightOneSpectrum.valuation_exists_uniformizer F
+  change w.adicValuation ϖ = exp (-1 : ℤ) at hϖ
+  have hϖ0 : w.adicValuation ϖ ≠ 0 := by rw [hϖ]; exact exp_ne_zero
+  have hϖlt : v' ϖ < 1 := by
+    refine hE.lt_one_iff_lt_one.mpr ?_
+    rw [hϖ, ← exp_zero]
+    exact exp_lt_exp.mpr (by norm_num)
+  have hϖ0' : v' ϖ ≠ 0 := (hE.eq_zero).ne.mpr hϖ0
+  have hϖle : v' ϖ ≤ v' x := by
+    rw [hx, ← log_le_iff_le_exp hϖ0']
+    have hlog : log (v' ϖ) < 0 := (log_lt_iff_lt_exp hϖ0').mpr (by rw [exp_zero]; exact hϖlt)
+    omega
+  have hge : exp (-1 : ℤ) ≤ w.adicValuation x := by
+    rw [← hϖ]
+    exact (hE ϖ x).mp hϖle
+  have hle' : log (w.adicValuation x) ≤ -1 := by
+    have hlog : log (w.adicValuation x) < 0 :=
+      (log_lt_iff_lt_exp hu0).mpr (by rw [exp_zero]; exact hlt)
+    omega
+  have hge' : -1 ≤ log (w.adicValuation x) := (le_log_iff_exp_le hu0).mpr hge
+  simp only [Place.ord]
+  omega
+
+scoped instance instIsPrincipalIdealRingAdjoinSingleton (t : F) :
+    IsPrincipalIdealRing (Algebra.adjoin K ({t} : Set F)) := by
+  have hmem : ∀ p : Polynomial K, Polynomial.aeval t p ∈ Algebra.adjoin K ({t} : Set F) := by
+    intro p
+    rw [Algebra.adjoin_singleton_eq_range_aeval]
+    exact ⟨p, rfl⟩
+  refine IsPrincipalIdealRing.of_surjective
+    ((Polynomial.aeval t).codRestrict (Algebra.adjoin K ({t} : Set F)) hmem) ?_
+  rintro ⟨a, ha⟩
+  obtain ⟨p, hp⟩ : ∃ p : Polynomial K, Polynomial.aeval t p = a := by
+    rw [Algebra.adjoin_singleton_eq_range_aeval] at ha
+    exact (AlgHom.mem_range _).mp ha
+  exact ⟨p, Subtype.ext hp⟩
+
+def linGen (t : F) (c : K) : Algebra.adjoin K ({t} : Set F) :=
+  ⟨t, Algebra.self_mem_adjoin_singleton K t⟩ - algebraMap K _ c
+
+@[scoped simp] theorem coe_linGen (t : F) (c : K) :
+    ((linGen t c : Algebra.adjoin K ({t} : Set F)) : F) = t - algebraMap K F c := by
+  simp [linGen]
+
+section Transcendental
+
+variable (t : F) (htr : Transcendental K t)
+
+include htr in
+theorem linGen_ne_zero (c : K) : linGen t c ≠ 0 := by
+  intro h
+  have h' := congrArg (fun a : Algebra.adjoin K ({t} : Set F) => (a : F)) h
+  simp only [coe_linGen, ZeroMemClass.coe_zero, sub_eq_zero] at h'
+  exact htr (by rw [h']; exact isAlgebraic_algebraMap c)
+
+def polyEquiv : Polynomial K ≃ₐ[K] Algebra.adjoin K ({t} : Set F) :=
+  (AlgEquiv.ofInjective (Polynomial.aeval t) (transcendental_iff_injective.mp htr)).trans
+    (Subalgebra.equivOfEq _ _ (by rw [Algebra.adjoin_singleton_eq_range_aeval]))
+
+theorem polyEquiv_X_sub_C (c : K) :
+    polyEquiv t htr (Polynomial.X - Polynomial.C c) = linGen t c := by
+  apply Subtype.ext
+  rw [coe_linGen]
+  simp [polyEquiv, Subalgebra.equivOfEq_apply, AlgEquiv.ofInjective_apply]
+
+include htr in
+theorem prime_linGen (c : K) : Prime (linGen t c) := by
+  rw [← polyEquiv_X_sub_C t htr c, MulEquiv.prime_iff]
+  exact Polynomial.prime_X_sub_C c
+
+def linPrime (c : K) : HeightOneSpectrum (Algebra.adjoin K ({t} : Set F)) :=
+  ⟨Ideal.span {linGen t c}, (Ideal.span_singleton_prime (linGen_ne_zero t htr c)).mpr
+    (prime_linGen t htr c), by
+      rw [ne_eq, Ideal.span_singleton_eq_bot]
+      exact linGen_ne_zero t htr c⟩
+
+open scoped IntermediateField.algebraAdjoinAdjoin
+
+def basePlace (c : K) : Place K (IntermediateField.adjoin K ({t} : Set F)) :=
+  Place.ofHeightOneSpectrum (K := K) (linPrime t htr c)
+
+theorem algebraMap_linGen (c : K) :
+    algebraMap (Algebra.adjoin K ({t} : Set F)) (IntermediateField.adjoin K ({t} : Set F))
+        (linGen t c) =
+      IntermediateField.AdjoinSimple.gen K t - algebraMap K _ c := by
+  apply Subtype.ext
+  rw [IntermediateField.algebraAdjoinAdjoin.coe_algebraMap, coe_linGen]
+  simp
+
+theorem ord_basePlace (c : K) :
+    (basePlace t htr c).ord (IntermediateField.AdjoinSimple.gen K t - algebraMap K _ c) = 1 := by
+  rw [← algebraMap_linGen]
+  refine ord_eq_one_of_valuation_eq (basePlace t htr c)
+    (v' := (linPrime t htr c).valuation (IntermediateField.adjoin K ({t} : Set F))) rfl ?_
+  rw [HeightOneSpectrum.valuation_of_algebraMap]
+  exact (linPrime t htr c).intValuation_singleton (linGen_ne_zero t htr c) rfl
+
+theorem forall_algebraMap_mem (v : Place K (IntermediateField.adjoin K ({t} : Set F)))
+    (ht : IntermediateField.AdjoinSimple.gen K t ∈ v.toValuationSubring)
+    (r : Algebra.adjoin K ({t} : Set F)) :
+    algebraMap (Algebra.adjoin K ({t} : Set F)) (IntermediateField.adjoin K ({t} : Set F)) r ∈
+      v.toValuationSubring := by
+  obtain ⟨x, hx⟩ := r
+  change (⟨x, IntermediateField.algebra_adjoin_le_adjoin K _ hx⟩ :
+      IntermediateField.adjoin K ({t} : Set F)) ∈ v.toValuationSubring
+  induction hx using Algebra.adjoin_induction with
+  | mem y hy =>
+    have hy' : y = t := Set.mem_singleton_iff.mp hy
+    subst hy'
+    exact ht
+  | algebraMap a => exact v.algebraMap_mem' a
+  | add y z hy hz ihy ihz => exact add_mem ihy ihz
+  | mul y z hy hz ihy ihz => exact mul_mem ihy ihz
+
+include htr in
+theorem eq_basePlace_of_ord_pos (v : Place K (IntermediateField.adjoin K ({t} : Set F))) (c : K)
+    (hv : 0 < v.ord (IntermediateField.AdjoinSimple.gen K t - algebraMap K _ c)) :
+    v = basePlace t htr c := by
+  have ht : IntermediateField.AdjoinSimple.gen K t ∈ v.toValuationSubring := mem_of_ord_sub_pos v hv
+  have hw := forall_algebraMap_mem t v ht
+  have hmem : linGen t c ∈ Place.center (Algebra.adjoin K ({t} : Set F)) v hw := by
+    rw [Place.mem_center_iff_ord_pos v hw (linGen_ne_zero t htr c), algebraMap_linGen]
+    exact hv
+  have hcenter : Place.center (Algebra.adjoin K ({t} : Set F)) v hw = Ideal.span {linGen t c} := by
+    have : (Ideal.span {linGen t c}).IsPrime := (linPrime t htr c).isPrime
+    have hmax : (Ideal.span {linGen t c}).IsMaximal :=
+      IsPrime.to_maximal_ideal (linPrime t htr c).ne_bot
+    exact (hmax.eq_of_le (Ideal.IsPrime.ne_top inferInstance)
+      ((Ideal.span_singleton_le_iff_mem _).mpr hmem)).symm
+  have hc : Place.centerHeightOneSpectrum (Algebra.adjoin K ({t} : Set F)) v hw =
+      linPrime t htr c := HeightOneSpectrum.ext hcenter
+  apply Place.ext
+  rw [v.toValuationSubring_eq_of_forall_mem hw, hc,
+    HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+  rfl
+
+include htr in
+theorem restrict_eq_basePlace [Algebra.IsIntegral (IntermediateField.adjoin K ({t} : Set F)) F]
+    (w : Place K F) (c : K) (hw : 0 < w.ord (t - algebraMap K F c)) :
+    w.restrict (IntermediateField.adjoin K ({t} : Set F)) = basePlace t htr c ∧
+    (w.restrict (IntermediateField.adjoin K ({t} : Set F))).ord
+      (IntermediateField.AdjoinSimple.gen K t - algebraMap K _ c) = 1 := by
+  have hgen : algebraMap (IntermediateField.adjoin K ({t} : Set F)) F
+      (IntermediateField.AdjoinSimple.gen K t - algebraMap K _ c) = t - algebraMap K F c := by
+    rw [map_sub, IntermediateField.AdjoinSimple.algebraMap_gen K t, ←
+      IsScalarTower.algebraMap_apply]
+  have h := Place.ord_restrict (F := IntermediateField.adjoin K ({t} : Set F)) w
+    (IntermediateField.AdjoinSimple.gen K t - algebraMap K _ c)
+  rw [hgen] at h
+  have hpos : 0 < (w.restrict (IntermediateField.adjoin K ({t} : Set F))).ord
+      (IntermediateField.AdjoinSimple.gen K t - algebraMap K _ c) := by
+    rw [h] at hw
+    exact (pos_iff_pos_of_mul_pos hw).mp
+      (by exact_mod_cast w.ramificationIndex_pos (F := IntermediateField.adjoin K ({t} : Set F)))
+  have heq :=
+    eq_basePlace_of_ord_pos t htr (w.restrict (IntermediateField.adjoin K ({t} : Set F))) c
+    hpos
+  refine ⟨heq, ?_⟩
+  have h1 := ord_basePlace t htr c
+  rw [← heq] at h1
+  exact h1
+
+end Transcendental
+
+end Engine
+
+section Along
+
+variable {K F M : Type*} [Field K] [Field F] [Field M] [Algebra K F] [Algebra K M]
+  (ι : F →ₐ[K] M) (y : F)
+
+def adjoinEquivAlong :
+    IntermediateField.adjoin K ({y} : Set F) ≃ₐ[K] IntermediateField.adjoin K ({ι y} : Set M) :=
+  (IntermediateField.equivMap (IntermediateField.adjoin K ({y} : Set F)) ι).trans
+    (IntermediateField.equivOfEq (by rw [IntermediateField.adjoin_map, Set.image_singleton]))
+
+theorem coe_adjoinEquivAlong (r : IntermediateField.adjoin K ({y} : Set F)) :
+    ((adjoinEquivAlong ι y r : IntermediateField.adjoin K ({ι y} : Set M)) : M) = ι r := rfl
+
+theorem finiteAlong_of_finiteDimensional_adjoin
+    [h : FiniteDimensional (IntermediateField.adjoin K ({ι y} : Set M)) M] :
+    FiniteAlong K ι := by
+  let := algebraAlong ι
+  set R' := IntermediateField.adjoin K ({ι y} : Set M)
+  obtain ⟨S, hS⟩ := h.fg_top
+  refine ⟨⟨S, ?_⟩⟩
+  rw [eq_top_iff]
+  rintro b -
+  have hb : b ∈ Submodule.span R' (S : Set M) := by rw [hS]; exact Submodule.mem_top
+  induction hb using Submodule.span_induction with
+  | mem b hb => exact Submodule.subset_span hb
+  | zero => exact zero_mem _
+  | add b b' _ _ ih ih' => exact add_mem ih ih'
+  | smul r' b _ ih =>
+    have hc : (r' : M) = ι ((adjoinEquivAlong ι y).symm r' : IntermediateField.adjoin K ({y} : Set
+      F)) :=
+      by
+      rw [← coe_adjoinEquivAlong ι y, AlgEquiv.apply_symm_apply]
+    have hr : r' • b =
+        (((adjoinEquivAlong ι y).symm r' : IntermediateField.adjoin K ({y} : Set F)) : F) • b := by
+      change (r' : M) * b = ι _ * b
+      rw [hc]
+    rw [hr]
+    exact Submodule.smul_mem _ _ ih
+
+theorem separableAlong_of_isSeparable_adjoin
+    [Algebra.IsSeparable (IntermediateField.adjoin K ({ι y} : Set M)) M] :
+    SeparableAlong K ι := by
+  let := algebraAlong ι
+  set R := IntermediateField.adjoin K ({y} : Set F)
+  set R' := IntermediateField.adjoin K ({ι y} : Set M)
+  refine ⟨fun b => ?_⟩
+  have hs : (minpoly R' b).Separable := Algebra.IsSeparable.isSeparable R' b
+  set e := adjoinEquivAlong ι y
+  set φ : R' →+* F := (algebraMap R F).comp (e.symm : R' →+* R) with hφ
+  have hcomp : (algebraMap F M).comp φ = algebraMap R' M := by
+    ext r'
+    change ι (algebraMap R F (e.symm r')) = (r' : M)
+    rw [show algebraMap R F (e.symm r') = ((e.symm r' : R) : F) from rfl, ← coe_adjoinEquivAlong ι
+      y,
+      AlgEquiv.apply_symm_apply]
+  have hq : ((minpoly R' b).map φ).Separable := hs.map
+  have hqb : Polynomial.aeval b ((minpoly R' b).map φ) = 0 := by
+    rw [Polynomial.aeval_def, Polynomial.eval₂_map, hcomp, ← Polynomial.aeval_def]
+    exact minpoly.aeval R' b
+  exact hq.of_dvd (minpoly.dvd F b hqb)
+
+theorem isIntegral_of_finiteAlong (hfin : FiniteAlong K ι) : ι.toRingHom.IsIntegral := by
+  let := algebraAlong ι
+  have : Module.Finite F M := hfin
+  intro m
+  exact Algebra.IsIntegral.isIntegral (R := F) m
+
+theorem normalAlong_of_normal_adjoin
+    [Normal (IntermediateField.adjoin K ({ι y} : Set M)) M] :
+    @Normal F M _ _ (algebraAlong ι) := by
+  let := algebraAlong ι
+  set R := IntermediateField.adjoin K ({y} : Set F)
+  set R' := IntermediateField.adjoin K ({ι y} : Set M)
+  set e := adjoinEquivAlong ι y
+  set φ : R' →+* F := (algebraMap R F).comp (e.symm : R' →+* R) with hφ
+  have hcomp : (algebraMap F M).comp φ = algebraMap R' M := by
+    ext r'
+    change ι (algebraMap R F (e.symm r')) = (r' : M)
+    rw [show algebraMap R F (e.symm r') = ((e.symm r' : R) : F) from rfl, ← coe_adjoinEquivAlong ι
+      y,
+      AlgEquiv.apply_symm_apply]
+  refine normal_iff.mpr fun b => ?_
+  have hint : IsIntegral R' b := Normal.isIntegral inferInstance b
+  have hsplit : ((minpoly R' b).map (algebraMap R' M)).Splits :=
+    Normal.splits inferInstance b
+  have hqb : Polynomial.aeval b ((minpoly R' b).map φ) = 0 := by
+    rw [Polynomial.aeval_def, Polynomial.eval₂_map, hcomp, ← Polynomial.aeval_def]
+    exact minpoly.aeval R' b
+  have hintF : IsIntegral F b := ⟨(minpoly R' b).map φ, (minpoly.monic hint).map φ, by
+    rw [← Polynomial.aeval_def]; exact hqb⟩
+  refine ⟨hintF, ?_⟩
+  have hdvd : minpoly F b ∣ (minpoly R' b).map φ := minpoly.dvd F b hqb
+  have hsplit' : (((minpoly R' b).map φ).map (algebraMap F M)).Splits := by
+    rw [Polynomial.map_map, hcomp]
+    exact hsplit
+  exact Polynomial.Splits.of_dvd hsplit' (Polynomial.map_ne_zero
+    (Polynomial.map_monic_ne_zero (minpoly.monic hint))) (Polynomial.map_dvd _ hdvd)
+
+end Along
+
+section Galois
+
+variable (K E M : Type*) [Field K] [Field E] [Field M]
+  [Algebra K E] [Algebra K M] [Algebra E M] [IsScalarTower K E M]
+
+def toSemilinear : (M ≃ₐ[E] M) →* SemilinearAut K M where
+  toFun σ := SemilinearAut.ofAlgAut (σ.restrictScalars K)
+  map_one' := by ext <;> rfl
+  map_mul' _ _ := by ext <;> rfl
+
+@[reducible] def placeAction : MulAction (M ≃ₐ[E] M) (Place K M) :=
+  MulAction.compHom _ (toSemilinear K E M)
+
+attribute [local instance] placeAction
+
+variable {K E M}
+
+theorem smul_place_def (σ : M ≃ₐ[E] M) (W : Place K M) :
+    σ • W = SemilinearAut.ofAlgAut (σ.restrictScalars K) • W := rfl
+
+theorem mem_smul_place_iff (σ : M ≃ₐ[E] M) (W : Place K M) (y : M) :
+    y ∈ (σ • W).toValuationSubring ↔ σ.symm y ∈ W.toValuationSubring := by
+  rw [smul_place_def, SemilinearAut.smul_toValuationSubring,
+    ValuationSubring.mem_pointwise_smul_iff_inv_smul_mem, ← map_inv, SemilinearAut.ofAlgAut_smul]
+  rfl
+
+theorem ord_smul_apply (σ : M ≃ₐ[E] M) (W : Place K M) (y : M) : (σ • W).ord (σ y) = W.ord y :=
+  SemilinearAut.ord_smul (SemilinearAut.ofAlgAut (σ.restrictScalars K)) W y
+
+theorem ord_apply_of_smul_eq {σ : M ≃ₐ[E] M} {W : Place K M} (h : σ • W = W) (y : M) :
+    W.ord (σ y) = W.ord y := by
+  conv_lhs => rw [← h]
+  exact ord_smul_apply σ W y
+
+variable [FiniteDimensional E M] [IsGalois E M]
+
+theorem mem_fiberOver_iff_mem_orbit (P W : Place K M) :
+    W ∈ (P.restrict E).fiberOver M ↔ W ∈ MulAction.orbit (M ≃ₐ[E] M) P := by
+  rw [Place.mem_fiberOver, MulAction.mem_orbit_iff]
+  constructor
+  · intro h
+    obtain ⟨σ, hσ⟩ := Place.exists_algEquiv_smul_eq_of_restrict_eq (K := K) (F' := E) P W h
+    exact ⟨σ, hσ⟩
+  · rintro ⟨σ, rfl⟩
+    exact Place.restrict_ofAlgAut_smul σ P
+
+theorem card_stabilizer_mul_card_fiberOver (P : Place K M) :
+    Nat.card (MulAction.stabilizer (M ≃ₐ[E] M) P) * ((P.restrict E).fiberOver M).card =
+      Module.finrank E M := by
+  have h1 := Subgroup.card_mul_index (MulAction.stabilizer (M ≃ₐ[E] M) P)
+  rw [MulAction.index_stabilizer, IsGalois.card_aut_eq_finrank] at h1
+  have h2 : (MulAction.orbit (M ≃ₐ[E] M) P).ncard = ((P.restrict E).fiberOver M).card := by
+    rw [← Set.ncard_coe_finset]
+    congr 1
+    ext W
+    rw [Finset.mem_coe, mem_fiberOver_iff_mem_orbit]
+  rw [h2] at h1
+  exact h1
+
+omit [FiniteDimensional E M] [IsGalois E M] in
+theorem inertiaDeg_eq_one_of_deg_eq_one {F' : Type*} [Field F'] [Algebra K F'] [Algebra F' M]
+    [IsScalarTower K F' M] [Algebra.IsIntegral F' M] (W : Place K M) (hW : W.deg = 1) :
+    W.inertiaDeg F' = 1 := by
+  have h := W.deg_restrict_mul_inertiaDeg (F := F')
+  rw [hW] at h
+  exact Nat.eq_one_of_mul_eq_one_left h
+
+theorem card_stabilizer_eq (P : Place K M) (hdeg : P.deg = 1) :
+    Nat.card (MulAction.stabilizer (M ≃ₐ[E] M) P) = P.ramificationIndex E := by
+  have h1 := card_stabilizer_mul_card_fiberOver (K := K) (E := E) P
+  have h2 := Place.card_fiberOver_mul_ramificationIndex_mul_inertiaDeg (K := K) (P.restrict E) P rfl
+  rw [inertiaDeg_eq_one_of_deg_eq_one P hdeg, mul_one] at h2
+  have hpos : 0 < ((P.restrict E).fiberOver M).card :=
+    Finset.card_pos.mpr ⟨P, Place.restrict_mem_fiberOver P⟩
+  have : Nat.card (MulAction.stabilizer (M ≃ₐ[E] M) P) * ((P.restrict E).fiberOver M).card =
+      P.ramificationIndex E * ((P.restrict E).fiberOver M).card := by
+    rw [h1, mul_comm, h2]
+  exact Nat.eq_of_mul_eq_mul_right hpos this
+
+end Galois
+
+section AlongPsi
+
+variable {K F M : Type*} [Field K] [Field F] [Field M] [Algebra K F] [Algebra K M]
+  (x : F) (t : M)
+
+def adjoinEquivNorm (ψ : F →ₐ[K] M) (hψ : ψ x = t) : K⟮x⟯ ≃ₐ[K] K⟮t⟯ :=
+  (adjoinEquivAlong ψ x).trans (IntermediateField.equivOfEq (by rw [hψ]))
+
+theorem coe_adjoinEquivNorm (ψ : F →ₐ[K] M) (hψ : ψ x = t) (r : K⟮x⟯) :
+    ((adjoinEquivNorm x t ψ hψ r : K⟮t⟯) : M) = ψ r := rfl
+
+def baseHom (ψ : F →ₐ[K] M) (hψ : ψ x = t) : K⟮t⟯ →+* F :=
+  (algebraMap K⟮x⟯ F).comp ((adjoinEquivNorm x t ψ hψ).symm : K⟮t⟯ →+* K⟮x⟯)
+
+theorem psi_baseHom (ψ : F →ₐ[K] M) (hψ : ψ x = t) (r : K⟮t⟯) : ψ (baseHom x t ψ hψ r) = r := by
+  change ψ (((adjoinEquivNorm x t ψ hψ).symm r : K⟮x⟯) : F) = r
+  rw [← coe_adjoinEquivNorm x t ψ hψ, AlgEquiv.apply_symm_apply]
+
+theorem baseHom_mem (ψ : F →ₐ[K] M) (hψ : ψ x = t) (r : K⟮t⟯) : baseHom x t ψ hψ r ∈ K⟮x⟯ :=
+  ((adjoinEquivNorm x t ψ hψ).symm r).2
+
+theorem apply_eq_of_mem_adjoin (ψ ψ' : F →ₐ[K] M) (hψ : ψ x = t) (hψ' : ψ' x = t) {f : F}
+    (hf : f ∈ K⟮x⟯) : ψ f = ψ' f := by
+  have h : ψ.comp (K⟮x⟯.val) = ψ'.comp (K⟮x⟯.val) := by
+    refine IntermediateField.adjoin_algHom_ext K fun y hy => ?_
+    rw [Set.mem_singleton_iff] at hy
+    subst hy
+    change ψ y = ψ' y
+    rw [hψ, hψ']
+  exact congrArg (fun φ : K⟮x⟯ →ₐ[K] M => φ ⟨f, hf⟩) h
+
+theorem psi'_baseHom (ψ ψ' : F →ₐ[K] M) (hψ : ψ x = t) (hψ' : ψ' x = t) (r : K⟮t⟯) :
+    ψ' (baseHom x t ψ hψ r) = r := by
+  rw [← apply_eq_of_mem_adjoin x t ψ ψ' hψ hψ' (baseHom_mem x t ψ hψ r)]
+  exact psi_baseHom x t ψ hψ r
+
+theorem exists_algEquiv_comp_eq [Normal K⟮t⟯ M] (ψ ψ' : F →ₐ[K] M) (hψ : ψ x = t)
+    (hψ' : ψ' x = t) : ∃ τ : M ≃ₐ[K⟮t⟯] M, ∀ f, τ (ψ f) = ψ' f := by
+  let : Algebra K⟮t⟯ F := (baseHom x t ψ hψ).toAlgebra
+  let : Algebra F M := algebraAlong ψ
+  have : IsScalarTower K⟮t⟯ F M := IsScalarTower.of_algebraMap_eq fun r =>
+    (psi_baseHom x t ψ hψ r).symm
+  let ϕ : F →ₐ[K⟮t⟯] M :=
+    { (ψ' : F →+* M) with
+      commutes' := fun r => by
+        change ψ' (baseHom x t ψ hψ r) = (r : M)
+        exact psi'_baseHom x t ψ ψ' hψ hψ' r }
+  have hϕ : ∀ f, ϕ f = ψ' f := fun f => rfl
+  let τh : M →ₐ[K⟮t⟯] M := ϕ.liftNormal M
+  have : Algebra.IsAlgebraic K⟮t⟯ M := Algebra.IsIntegral.isAlgebraic
+  refine ⟨AlgEquiv.ofBijective τh (Algebra.IsAlgebraic.algHom_bijective τh), fun f => ?_⟩
+  change τh (algebraMap F M f) = ψ' f
+  rw [AlgHom.liftNormal_commutes]
+  exact hϕ f
+
+attribute [local instance] placeAction
+
+theorem restrictAlong_comp (ψ : F →ₐ[K] M) (τ : M ≃ₐ[K⟮t⟯] M)
+    (h₁ : (((τ : M →ₐ[K⟮t⟯] M).restrictScalars K).comp ψ).toRingHom.IsIntegral)
+    (h₂ : ψ.toRingHom.IsIntegral) (W : Place K M) :
+    W.restrictAlong (((τ : M →ₐ[K⟮t⟯] M).restrictScalars K).comp ψ) h₁ =
+      (τ⁻¹ • W).restrictAlong ψ h₂ := by
+  apply Place.ext
+  ext f
+  change (τ (ψ f) ∈ W.toValuationSubring) ↔ ψ f ∈ (τ⁻¹ • W).toValuationSubring
+  rw [mem_smul_place_iff]
+  rfl
+
+theorem finiteAlong_norm [FiniteDimensional K⟮t⟯ M] (ψ : F →ₐ[K] M) (hψ : ψ x = t) :
+    FiniteAlong K ψ := by
+  have : FiniteDimensional K⟮ψ x⟯ M := by rw [hψ]; infer_instance
+  exact finiteAlong_of_finiteDimensional_adjoin ψ x
+
+theorem separableAlong_norm [FiniteDimensional K⟮t⟯ M] [IsGalois K⟮t⟯ M] (ψ : F →ₐ[K] M)
+    (hψ : ψ x = t) : SeparableAlong K ψ := by
+  have : IsGalois K⟮ψ x⟯ M := by rw [hψ]; infer_instance
+  exact separableAlong_of_isSeparable_adjoin ψ x
+
+theorem isGalois_along [FiniteDimensional K⟮t⟯ M] [IsGalois K⟮t⟯ M] (ψ : F →ₐ[K] M)
+    (hψ : ψ x = t) : @IsGalois F _ M _ (algebraAlong ψ) := by
+  let := algebraAlong ψ
+  have : IsGalois K⟮ψ x⟯ M := by rw [hψ]; infer_instance
+  have : Algebra.IsSeparable F M := separableAlong_of_isSeparable_adjoin ψ x
+  have : Normal F M := normalAlong_of_normal_adjoin ψ x
+  exact isGalois_iff.mpr ⟨inferInstance, inferInstance⟩
+
+end AlongPsi
+
+section Main
+
+variable {K : Type*} [Field K] [IsAlgClosed K] {F M : Type*} [Field F] [Field M] [Algebra K F]
+  [Algebra K M] (x : F) (t : M) (j₀ : K) (ι : F →ₐ[K] M) (hι : ι x = t)
+  [FiniteDimensional K⟮t⟯ M] [IsGalois K⟮t⟯ M]
+  (hint : ∀ ψ : F →ₐ[K] M, ψ x = t → ψ.toRingHom.IsIntegral)
+  (W₀ : Place K M) (hW₀ : 0 < W₀.ord (t - algebraMap K M j₀))
+
+attribute [local instance] placeAction
+
+omit [IsAlgClosed K] [FiniteDimensional (↥K⟮t⟯) M] [IsGalois (↥K⟮t⟯) M] in
+theorem algebraMap_gen_sub :
+    algebraMap K⟮t⟯ M (IntermediateField.AdjoinSimple.gen K t - algebraMap K K⟮t⟯ j₀) =
+      t - algebraMap K M j₀ := by
+  rw [map_sub, IntermediateField.AdjoinSimple.algebraMap_gen K t, ← IsScalarTower.algebraMap_apply]
+
+include hW₀ in
+omit [FiniteDimensional (↥K⟮t⟯) M] [IsGalois (↥K⟮t⟯) M] in
+theorem transcendental_t : Transcendental K t := by
+  intro halg
+  obtain ⟨c, hc⟩ : t ∈ (algebraMap K M).range := by
+    have h1 := IsAlgClosed.degree_eq_one_of_irreducible K (minpoly.irreducible halg.isIntegral)
+    exact minpoly.mem_range_of_degree_eq_one K t h1
+  rw [← hc, ← map_sub, Place.ord_algebraMap] at hW₀
+  exact lt_irrefl _ hW₀
+
+omit [IsAlgClosed K] [FiniteDimensional (↥K⟮t⟯) M] [IsGalois (↥K⟮t⟯) M] in
+theorem psi_sub (ψ : F →ₐ[K] M) (hψ : ψ x = t) :
+    ψ (x - algebraMap K F j₀) = t - algebraMap K M j₀ := by
+  rw [map_sub, hψ, ψ.commutes]
+
+include hW₀ in
+theorem ord_eq_card_stabilizer :
+    W₀.ord (t - algebraMap K M j₀) = Nat.card (MulAction.stabilizer (M ≃ₐ[K⟮t⟯] M) W₀) := by
+  have htr := transcendental_t t j₀ W₀ hW₀
+  have h := Place.ord_restrict (F := K⟮t⟯) W₀
+    (IntermediateField.AdjoinSimple.gen K t - algebraMap K K⟮t⟯ j₀)
+  rw [algebraMap_gen_sub] at h
+  obtain ⟨-, h1⟩ := restrict_eq_basePlace (F := M) t htr W₀ j₀ hW₀
+  rw [h1, mul_one] at h
+  rw [h]
+  have hdeg : W₀.deg = 1 := Place.deg_eq_one_of_isAlgClosed W₀
+    (Place.deg_ne_zero_of_finiteDimensional_adjoin t htr W₀)
+  exact_mod_cast (card_stabilizer_eq (K := K) (E := K⟮t⟯) W₀ hdeg).symm
+
+include hW₀ in
+omit [IsAlgClosed K] [FiniteDimensional (↥K⟮t⟯) M] [IsGalois (↥K⟮t⟯) M] in
+theorem ord_restrictAlong_pos (ψ : F →ₐ[K] M) (hψ : ψ x = t) (h : ψ.toRingHom.IsIntegral) :
+    0 < (W₀.restrictAlong ψ h).ord (x - algebraMap K F j₀) := by
+  have hf := Place.ord_restrictAlong ψ h W₀ (x - algebraMap K F j₀)
+  rw [psi_sub x t j₀ ψ hψ] at hf
+  rw [hf] at hW₀
+  exact pos_of_mul_pos_right hW₀ (by exact_mod_cast Nat.zero_le _)
+
+include hW₀ in
+theorem exists_smul_eq_of_ord_pos (W : Place K M) (hW : 0 < W.ord (t - algebraMap K M j₀)) :
+    ∃ σ : M ≃ₐ[K⟮t⟯] M, σ • W₀ = W := by
+  have htr := transcendental_t t j₀ W₀ hW₀
+  obtain ⟨h0, -⟩ := restrict_eq_basePlace (F := M) t htr W₀ j₀ hW₀
+  obtain ⟨h1, -⟩ := restrict_eq_basePlace (F := M) t htr W j₀ hW
+  exact Place.exists_algEquiv_smul_eq_of_restrict_eq (K := K) (F' := K⟮t⟯) W₀ W (h1.trans h0.symm)
+
+omit [IsAlgClosed K] [FiniteDimensional (↥K⟮t⟯) M] [IsGalois (↥K⟮t⟯) M] in
+theorem inv_comp_apply (σ : M ≃ₐ[K⟮t⟯] M) (hι : ι x = t) :
+    (((σ⁻¹ : M ≃ₐ[K⟮t⟯] M) : M →ₐ[K⟮t⟯] M).restrictScalars K).comp ι x = t := by
+  change σ⁻¹ (ι x) = t
+  rw [hι]
+  exact σ⁻¹.commutes (⟨t, IntermediateField.mem_adjoin_simple_self K t⟩ : K⟮t⟯)
+
+include hι hW₀ in
+theorem exists_restrictAlong_eq (w : Place K F) (hw : 0 < w.ord (x - algebraMap K F j₀)) :
+    ∃ (ψ : F →ₐ[K] M) (hψ : ψ x = t), W₀.restrictAlong ψ (hint ψ hψ) = w := by
+  obtain ⟨W, hWw⟩ := Place.restrictAlong_surjective ι (hint ι hι) (finiteAlong_norm x t ι hι)
+    (separableAlong_norm x t ι hι) w
+  dsimp only at hWw
+  have hW : 0 < W.ord (t - algebraMap K M j₀) := by
+    have hf := Place.ord_restrictAlong ι (hint ι hι) W (x - algebraMap K F j₀)
+    rw [psi_sub x t j₀ ι hι, hWw] at hf
+    rw [hf]
+    let := algebraAlong ι
+    have := isScalarTower_along (K := K) ι
+    have := isIntegral_along (K := K) ι (hint ι hι)
+    have he : 0 < Place.ramificationIndexAlong ι W := W.ramificationIndex_pos (F := F)
+    exact mul_pos (by exact_mod_cast he) hw
+  obtain ⟨σ, hσ⟩ := exists_smul_eq_of_ord_pos t j₀ W₀ hW₀ W hW
+  refine ⟨(((σ⁻¹ : M ≃ₐ[K⟮t⟯] M) : M →ₐ[K⟮t⟯] M).restrictScalars K).comp ι,
+    inv_comp_apply x t ι σ hι, ?_⟩
+  rw [restrictAlong_comp t ι σ⁻¹ _ (hint ι hι) W₀, inv_inv, hσ, hWw]
+
+def toGal (ψ : F →ₐ[K] M) (hψ : ψ x = t) (u : M ≃+* M) (hu : ∀ f, u (ψ f) = ψ f) :
+    M ≃ₐ[K⟮t⟯] M :=
+  AlgEquiv.ofRingEquiv (f := u) fun r => by
+    change u (r : M) = r
+    rw [← psi_baseHom x t ψ hψ r]
+    exact hu _
+
+omit [IsAlgClosed K] [FiniteDimensional (↥K⟮t⟯) M] [IsGalois (↥K⟮t⟯) M] in
+@[scoped simp] theorem toGal_apply (ψ : F →ₐ[K] M) (hψ : ψ x = t) (u : M ≃+* M)
+    (hu : ∀ f, u (ψ f) = ψ f) (y : M) : toGal x t ψ hψ u hu y = u y := rfl
+
+omit [IsAlgClosed K] in
+theorem restrictAlong_eq_iff (ψ ψ' : F →ₐ[K] M) (hψ : ψ x = t) (hψ' : ψ' x = t) :
+    W₀.restrictAlong ψ (hint ψ hψ) = W₀.restrictAlong ψ' (hint ψ' hψ') ↔
+      ∃ σ : M ≃ₐ[K⟮t⟯] M, SemilinearAut.ofAlgAut (σ.restrictScalars K) • W₀ = W₀ ∧
+        ψ' = ((σ : M →ₐ[K⟮t⟯] M).restrictScalars K).comp ψ := by
+  constructor
+  · intro h
+    obtain ⟨τ, hτ⟩ := exists_algEquiv_comp_eq x t ψ ψ' hψ hψ'
+    have hψ'eq : ψ' = ((τ : M →ₐ[K⟮t⟯] M).restrictScalars K).comp ψ :=
+      AlgHom.ext fun f => (hτ f).symm
+    subst hψ'eq
+    rw [restrictAlong_comp t ψ τ _ (hint ψ hψ) W₀] at h
+    let := algebraAlong ψ
+    have := isScalarTower_along (K := K) ψ
+    have : Module.Finite F M := finiteAlong_norm x t ψ hψ
+    have : IsGalois F M := isGalois_along x t ψ hψ
+    obtain ⟨u, hu⟩ := Place.exists_algEquiv_smul_eq_of_restrict_eq (K := K) (F' := F) W₀ (τ⁻¹ • W₀)
+      h.symm
+    have huc : ∀ f, (u : M ≃+* M) (ψ f) = ψ f := fun f => u.commutes f
+    let uk : M ≃ₐ[K⟮t⟯] M := toGal x t ψ hψ (u : M ≃+* M) huc
+    have huk : uk • W₀ = τ⁻¹ • W₀ := by
+      rw [smul_place_def, show uk.restrictScalars K = u.restrictScalars K from
+        AlgEquiv.ext fun _ => rfl]
+      exact hu
+    refine ⟨τ * uk, ?_, ?_⟩
+    · change (τ * uk) • W₀ = W₀
+      rw [mul_smul, huk, smul_inv_smul]
+    · ext f
+      change τ (ψ f) = (τ * uk) (ψ f)
+      rw [AlgEquiv.mul_apply, toGal_apply]
+      exact congrArg τ (huc f).symm
+  · rintro ⟨σ, hσ, rfl⟩
+    rw [restrictAlong_comp t ψ σ _ (hint ψ hψ) W₀]
+    have hσ' : σ⁻¹ • W₀ = W₀ := by
+      rw [inv_smul_eq_iff]
+      exact hσ.symm
+    rw [hσ']
+
+abbrev Emb : Type _ := {ψ : F →ₐ[K] M // ψ x = t}
+
+@[reducible] def embAction : MulAction (M ≃ₐ[K⟮t⟯] M) (Emb x t (K := K)) where
+  smul σ ψ := ⟨((σ : M →ₐ[K⟮t⟯] M).restrictScalars K).comp ψ.1, by
+    change σ (ψ.1 x) = t
+    rw [ψ.2]
+    exact σ.commutes (⟨t, IntermediateField.mem_adjoin_simple_self K t⟩ : K⟮t⟯)⟩
+  one_smul ψ := Subtype.ext (AlgHom.ext fun _ => rfl)
+  mul_smul σ τ ψ := Subtype.ext (AlgHom.ext fun _ => rfl)
+
+attribute [local instance] embAction
+
+omit [IsAlgClosed K] [FiniteDimensional (↥K⟮t⟯) M] [IsGalois (↥K⟮t⟯) M] in
+theorem smul_emb_val (σ : M ≃ₐ[K⟮t⟯] M) (ψ : Emb x t (K := K)) :
+    (σ • ψ).1 = ((σ : M →ₐ[K⟮t⟯] M).restrictScalars K).comp ψ.1 := rfl
+
+omit [IsAlgClosed K] in
+theorem setOf_sameClass_eq_orbit (ψ : Emb x t (K := K)) :
+    {ψ' : Emb x t (K := K) | W₀.restrictAlong ψ'.1 (hint ψ'.1 ψ'.2) = W₀.restrictAlong ψ.1 (hint ψ.1
+      ψ.2)} =
+      MulAction.orbit (MulAction.stabilizer (M ≃ₐ[K⟮t⟯] M) W₀) ψ := by
+  ext ψ'
+  rw [Set.mem_ofPred_eq, MulAction.mem_orbit_iff, eq_comm,
+    restrictAlong_eq_iff x t hint W₀ ψ.1 ψ'.1 ψ.2 ψ'.2]
+  constructor
+  · rintro ⟨σ, hσ, h⟩
+    exact ⟨⟨σ, hσ⟩, Subtype.ext h.symm⟩
+  · rintro ⟨⟨σ, hσ⟩, h⟩
+    exact ⟨σ, hσ, (congrArg Subtype.val h).symm⟩
+
+include hW₀ in
+theorem card_stabilizer_emb (ψ : Emb x t (K := K)) :
+    Nat.card (MulAction.stabilizer (MulAction.stabilizer (M ≃ₐ[K⟮t⟯] M) W₀) ψ) =
+      Place.ramificationIndexAlong ψ.1 W₀ := by
+  let := algebraAlong ψ.1
+  have := isScalarTower_along (K := K) ψ.1
+  have : Module.Finite F M := finiteAlong_norm x t ψ.1 ψ.2
+  have : IsGalois F M := isGalois_along x t ψ.1 ψ.2
+  have hdeg : W₀.deg = 1 := Place.deg_eq_one_of_isAlgClosed W₀
+    (Place.deg_ne_zero_of_finiteDimensional_adjoin t (transcendental_t t j₀ W₀ hW₀) W₀)
+  rw [show Place.ramificationIndexAlong ψ.1 W₀ = W₀.ramificationIndex F from rfl,
+    ← card_stabilizer_eq (K := K) (E := F) W₀ hdeg]
+  have fwd_comm : ∀ d : MulAction.stabilizer (MulAction.stabilizer (M ≃ₐ[K⟮t⟯] M) W₀) ψ,
+      ∀ f, ((d.1.1 : M ≃ₐ[K⟮t⟯] M) : M ≃+* M) (ψ.1 f) = ψ.1 f := by
+    intro d f
+    have h := congrArg (fun e : Emb x t (K := K) => e.1 f) (MulAction.mem_stabilizer_iff.mp d.2)
+    exact h
+  let fwd : MulAction.stabilizer (MulAction.stabilizer (M ≃ₐ[K⟮t⟯] M) W₀) ψ →
+      MulAction.stabilizer (M ≃ₐ[F] M) W₀ := fun d =>
+    ⟨AlgEquiv.ofRingEquiv (f := ((d.1.1 : M ≃ₐ[K⟮t⟯] M) : M ≃+* M)) (fwd_comm d), by
+      rw [MulAction.mem_stabilizer_iff, smul_place_def,
+        show (AlgEquiv.ofRingEquiv (fwd_comm d) : M ≃ₐ[F] M).restrictScalars K =
+          (d.1.1 : M ≃ₐ[K⟮t⟯] M).restrictScalars K from AlgEquiv.ext fun _ => rfl]
+      exact MulAction.mem_stabilizer_iff.mp d.1.2⟩
+  let bwd : MulAction.stabilizer (M ≃ₐ[F] M) W₀ →
+      MulAction.stabilizer (MulAction.stabilizer (M ≃ₐ[K⟮t⟯] M) W₀) ψ := fun u =>
+    ⟨⟨toGal x t ψ.1 ψ.2 (u.1 : M ≃+* M) (fun f => u.1.commutes f), by
+      rw [MulAction.mem_stabilizer_iff, smul_place_def,
+        show (toGal x t ψ.1 ψ.2 (u.1 : M ≃+* M) (fun f => u.1.commutes f)).restrictScalars K =
+          u.1.restrictScalars K from AlgEquiv.ext fun _ => rfl]
+      exact MulAction.mem_stabilizer_iff.mp u.2⟩, by
+      rw [MulAction.mem_stabilizer_iff]
+      exact Subtype.ext (AlgHom.ext fun f => u.1.commutes f)⟩
+  exact Nat.card_congr
+    { toFun := fwd
+      invFun := bwd
+      left_inv := fun d => Subtype.ext (Subtype.ext (AlgEquiv.ext fun _ => rfl))
+      right_inv := fun u => Subtype.ext (AlgEquiv.ext fun _ => rfl) }
+
+include hW₀ in
+theorem ord_restrictAlong_eq_card (ψ : F →ₐ[K] M) (hψ : ψ x = t) :
+    (W₀.restrictAlong ψ (hint ψ hψ)).ord (x - algebraMap K F j₀) =
+      Nat.card {ψ' : Emb x t (K := K) //
+        W₀.restrictAlong ψ'.1 (hint ψ'.1 ψ'.2) = W₀.restrictAlong ψ (hint ψ hψ)} := by
+  set D := MulAction.stabilizer (M ≃ₐ[K⟮t⟯] M) W₀ with hD
+  let ψe : Emb x t (K := K) := ⟨ψ, hψ⟩
+  have h1 := Subgroup.card_mul_index (MulAction.stabilizer D ψe)
+  rw [MulAction.index_stabilizer] at h1
+  have h2 : (MulAction.orbit D ψe).ncard = Nat.card {ψ' : Emb x t (K := K) //
+      W₀.restrictAlong ψ'.1 (hint ψ'.1 ψ'.2) = W₀.restrictAlong ψ (hint ψ hψ)} := by
+    rw [← setOf_sameClass_eq_orbit x t hint W₀ ψe, ← Nat.card_coe_set_eq]
+    rfl
+  have h3 := card_stabilizer_emb x t j₀ W₀ hW₀ ψe
+  have h4 := ord_eq_card_stabilizer t j₀ W₀ hW₀
+  have h5 := Place.ord_restrictAlong ψ (hint ψ hψ) W₀ (x - algebraMap K F j₀)
+  rw [psi_sub x t j₀ ψ hψ] at h5
+  rw [h2, h3] at h1
+  have he : 0 < Place.ramificationIndexAlong ψ W₀ := by
+    let := algebraAlong ψ
+    have := isScalarTower_along (K := K) ψ
+    have := isIntegral_along (K := K) ψ (hint ψ hψ)
+    exact W₀.ramificationIndex_pos (F := F)
+  have h6 : (Place.ramificationIndexAlong ψ W₀ : ℤ) * (W₀.restrictAlong ψ (hint ψ hψ)).ord
+      (x - algebraMap K F j₀) = (Place.ramificationIndexAlong ψ W₀ : ℤ) *
+        Nat.card {ψ' : Emb x t (K := K) //
+          W₀.restrictAlong ψ'.1 (hint ψ'.1 ψ'.2) = W₀.restrictAlong ψ (hint ψ hψ)} := by
+    rw [← h5, h4, ← hD, ← h1]
+    push_cast
+    ring
+  exact mul_left_cancel₀ (by exact_mod_cast he.ne') h6
+
+end Main
+
+end P2MKcA.HilbertB
+end
+
+open P2MKcA.HilbertB in
+universe u v in
+theorem solution
+    (K : Type u) [Field K] [IsAlgClosed K]
+    {F M : Type v} [Field F] [Field M] [Algebra K F] [Algebra K M]
+    (x : F) (t : M) (j₀ : K) (ι : F →ₐ[K] M) (hι : ι x = t)
+    (hfin : FiniteDimensional K⟮t⟯ M) (hgal : IsGalois K⟮t⟯ M)
+    (hint : ∀ ψ : F →ₐ[K] M, ψ x = t → ψ.toRingHom.IsIntegral)
+    (W₀ : Place K M) (hW₀ : 0 < W₀.ord (t - algebraMap K M j₀)) :
+    (W₀.ord (t - algebraMap K M j₀) =
+        Nat.card {σ : M ≃ₐ[K⟮t⟯] M // SemilinearAut.ofAlgAut (σ.restrictScalars K) • W₀ = W₀}) ∧
+    (∀ (ψ : F →ₐ[K] M) (hψ : ψ x = t),
+        0 < (W₀.restrictAlong ψ (hint ψ hψ)).ord (x - algebraMap K F j₀)) ∧
+    (∀ w : Place K F, 0 < w.ord (x - algebraMap K F j₀) →
+        ∃ (ψ : F →ₐ[K] M) (hψ : ψ x = t), W₀.restrictAlong ψ (hint ψ hψ) = w) ∧
+    (∀ (ψ ψ' : F →ₐ[K] M) (hψ : ψ x = t) (hψ' : ψ' x = t),
+        W₀.restrictAlong ψ (hint ψ hψ) = W₀.restrictAlong ψ' (hint ψ' hψ') ↔
+          ∃ σ : M ≃ₐ[K⟮t⟯] M, SemilinearAut.ofAlgAut (σ.restrictScalars K) • W₀ = W₀ ∧
+            ψ' = ((σ : M →ₐ[K⟮t⟯] M).restrictScalars K).comp ψ) ∧
+    (∀ (ψ : F →ₐ[K] M) (hψ : ψ x = t),
+        (W₀.restrictAlong ψ (hint ψ hψ)).ord (x - algebraMap K F j₀) =
+          Nat.card {ψ' : {ψ' : F →ₐ[K] M // ψ' x = t} //
+            W₀.restrictAlong ψ'.1 (hint ψ'.1 ψ'.2) = W₀.restrictAlong ψ (hint ψ hψ)}) := by
+  have := hfin
+  have := hgal
+  refine ⟨?_, fun ψ hψ => ord_restrictAlong_pos x t j₀ W₀ hW₀ ψ hψ (hint ψ hψ),
+    fun w hw => exists_restrictAlong_eq x t j₀ ι hι hint W₀ hW₀ w hw,
+    fun ψ ψ' hψ hψ' => restrictAlong_eq_iff x t hint W₀ ψ ψ' hψ hψ',
+    fun ψ hψ => ord_restrictAlong_eq_card x t j₀ hint W₀ hW₀ ψ hψ⟩
+  rw [ord_eq_card_stabilizer t j₀ W₀ hW₀]
+  congr 1
+
+end S_AlgebraicCurve_Place_ord_restrictAlong_eq_natCard_algHom_of_isGalois
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ord_restrictAlong_eq_natCard_algHom_of_isGalois (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+open scoped IntermediateField
+
+universe u v in
+theorem AlgebraicCurve.Place.ord_restrictAlong_eq_natCard_algHom_of_isGalois
+    (K : Type u) [Field K] [IsAlgClosed K]
+    {F M : Type v} [Field F] [Field M] [Algebra K F] [Algebra K M]
+    (x : F) (t : M) (j₀ : K) (ι : F →ₐ[K] M) (hι : ι x = t)
+    (hfin : FiniteDimensional K⟮t⟯ M) (hgal : IsGalois K⟮t⟯ M)
+    (hint : ∀ ψ : F →ₐ[K] M, ψ x = t → ψ.toRingHom.IsIntegral)
+    (W₀ : Place K M) (hW₀ : 0 < W₀.ord (t - algebraMap K M j₀)) :
+    (W₀.ord (t - algebraMap K M j₀) =
+        Nat.card {σ : M ≃ₐ[K⟮t⟯] M // SemilinearAut.ofAlgAut (σ.restrictScalars K) • W₀ = W₀}) ∧
+    (∀ (ψ : F →ₐ[K] M) (hψ : ψ x = t),
+        0 < (W₀.restrictAlong ψ (hint ψ hψ)).ord (x - algebraMap K F j₀)) ∧
+    (∀ w : Place K F, 0 < w.ord (x - algebraMap K F j₀) →
+        ∃ (ψ : F →ₐ[K] M) (hψ : ψ x = t), W₀.restrictAlong ψ (hint ψ hψ) = w) ∧
+    (∀ (ψ ψ' : F →ₐ[K] M) (hψ : ψ x = t) (hψ' : ψ' x = t),
+        W₀.restrictAlong ψ (hint ψ hψ) = W₀.restrictAlong ψ' (hint ψ' hψ') ↔
+          ∃ σ : M ≃ₐ[K⟮t⟯] M, SemilinearAut.ofAlgAut (σ.restrictScalars K) • W₀ = W₀ ∧
+            ψ' = ((σ : M →ₐ[K⟮t⟯] M).restrictScalars K).comp ψ) ∧
+    (∀ (ψ : F →ₐ[K] M) (hψ : ψ x = t),
+        (W₀.restrictAlong ψ (hint ψ hψ)).ord (x - algebraMap K F j₀) =
+          Nat.card {ψ' : {ψ' : F →ₐ[K] M // ψ' x = t} //
+            W₀.restrictAlong ψ'.1 (hint ψ'.1 ψ'.2) = W₀.restrictAlong ψ (hint ψ hψ)}) :=
+  solution K x t j₀ ι hι hfin hgal hint W₀ hW₀
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_smul_of_ne_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_smul_of_ne_zero.lean
new file mode 100644
index 0000000000..d6168d1638
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_smul_of_ne_zero.lean
@@ -0,0 +1,91 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.ord_smul_of_ne_zero
+(ade5b407-0841-5603-9f32-5eed766c44cb) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1674e0b0-7466-5d27-9782-8d136657c972
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order at a place is invariant under nonzero constants
+
+Theorem statement: `AlgebraicCurve.Place.ord_smul_of_ne_zero`
+(`ade5b407-0841-5603-9f32-5eed766c44cb`), by Claude, 2026-09-05.
+
+Proof: submission `1674e0b0-7466-5d27-9782-8d136657c972`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F/K$ in the sense of
+the project: a valuation subring `v.toValuationSubring` of $F$ that contains
+$\operatorname{algebraMap} K F\,(a)$ for every $a \in K$, is not all of $F$, and is a principal
+ideal ring. For such a $v$, `v.adicValuation` denotes the $\mathbb{Z}^{m0}$-valued valuation on $F$
+attached to the corresponding height-one prime of the valuation ring, and `v.ord f` is defined as
+$-\log$ of `v.adicValuation f`, an integer, with the convention arising from $\log$ on
+$\mathbb{Z}^{m0}$ that $\operatorname{ord}_v(0) = 0$. The theorem asserts: for every $c \in K$ with
+$c \neq 0$ and every $x \in F$, the scalar multiple $c \bullet x$ satisfies $\operatorname{ord}_v(c
+\bullet x) = \operatorname{ord}_v(x)$. Note that no hypothesis is placed on $x$; the case $x = 0$ is
+covered by the convention just described.
+
+This is the statement that the normalised order function at a place of $F/K$ is constant on
+$K^\times$-orbits, i.e. that nonzero elements of the constant field are units of every place's
+valuation ring. It is used throughout the divisor-theoretic part of the development, for instance
+when computing orders of elements modified by a nonzero constant factor.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ord_smul_of_ne_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ord_smul_of_ne_zero
+
+open AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) {c : K}
+    (hc : c ≠ 0) (x : F) :
+    v.ord (c • x) = v.ord x := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · rw [smul_zero]
+  · have halg : algebraMap K F c ≠ 0 :=
+      fun h => hc ((algebraMap K F).injective (by rw [h, map_zero]))
+    have hunit : IsUnit (⟨algebraMap K F c, v.algebraMap_mem' c⟩ : v.toValuationSubring) := by
+      refine isUnit_iff_exists_inv.mpr ⟨⟨algebraMap K F c⁻¹, v.algebraMap_mem' c⁻¹⟩, ?_⟩
+      ext
+      simp [mul_inv_cancel₀ halg]
+    have h0 : v.ord (algebraMap K F c) = 0 := by
+      have h1 : v.adicValuation (algebraMap K F c) = 1 :=
+        (v.adicValuation_coe_eq_one_iff ⟨algebraMap K F c, v.algebraMap_mem' c⟩).mpr hunit
+      simp [AlgebraicCurve.Place.ord, h1]
+    rw [Algebra.smul_def, v.ord_mul halg hx0, h0, zero_add]
+
+end S_AlgebraicCurve_Place_ord_smul_of_ne_zero
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ord_smul_of_ne_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.ord_smul_of_ne_zero {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) {c : K} (hc : c ≠ 0) (x : F) :
+    v.ord (c • x) = v.ord x :=
+  solution v hc x
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_sub_one_le_ordDiff_D_of_perfectField.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_sub_one_le_ordDiff_D_of_perfectField.lean
new file mode 100644
index 0000000000..146727fda0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_sub_one_le_ordDiff_D_of_perfectField.lean
@@ -0,0 +1,257 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.ord_sub_one_le_ordDiff_D_of_perfectField
+(b3aa7121-3df5-5d36-bb2f-e12e932d5c63) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 024f34bb-0e9b-507a-a512-678f85b797e7
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_diffCoeff_smul_D_eq_of_ord_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg_of_perfectField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_min_ord_le_ord_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Lower bound ordᵥ(f)-1leordDiffᵥ(df) over a perfect field
+
+Theorem statement: `AlgebraicCurve.Place.ord_sub_one_le_ordDiff_D_of_perfectField`
+(`b3aa7121-3df5-5d36-bb2f-e12e932d5c63`), by Claude, 2026-09-05.
+
+Proof: submission `024f34bb-0e9b-507a-a512-678f85b797e7`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a perfect field and $F$ a field extension of $K$, let $x\in F$ be such that $F$ is
+finite-dimensional as a vector space over the intermediate field $K(x)=\,$`IntermediateField.adjoin
+K {x}`, and let $v$ be a place of $F$ over $K$, that is, a valuation subring of $F$ that contains
+the image of $K$ under the structure map, is not the whole of $F$, and is a principal ideal ring.
+For $f\in F$ write $\operatorname{ord}_v(f)\in\mathbb{Z}$ for the negative of the logarithm of the
+value of $f$ under the $\mathbb{Z}^{m0}$-valued adic valuation attached to the height-one prime of
+$v$, and for $\omega\in\Omega_{F/K}$ write
+$\operatorname{ordDiff}_v(\omega)=\operatorname{ord}_v\bigl(\operatorname{diffCoeff}
+t\,\omega\bigr)$, where $t$ is the chosen element of $F$ with $\operatorname{ord}_v(t)=1$ produced
+by `uniformizer_alt` and $\operatorname{diffCoeff} t\,\omega$ is a chosen $g\in F$ with
+$\omega=g\cdot D_{K,F}t$ (and $0$ if no such $g$ exists). The assertion is that for every $f\in F$
+whose Kähler differential $D_{K,F}f\in\Omega_{F/K}$ is nonzero one has
+$$\operatorname{ord}_v(f)-1\;\le\;\operatorname{ordDiff}_v\bigl(D_{K,F}f\bigr).$$ In particular the
+nonvanishing hypothesis on $D_{K,F}f$ is what rules out inseparable situations such as $f=t^p$ in
+characteristic $p$.
+
+This is the standard local estimate for the order at a place of an exact differential on a function
+field: the differential $df$ has order at least $\operatorname{ord}_v(f)-1$, coming from the Leibniz
+rule applied to $f=t^{n}u$ with $t$ a uniformizer and $u$ a unit at $v$. It feeds the global
+computations bounding $\sum_v\operatorname{ordDiff}_v(df)$ and $\sum_v(\operatorname{ord}_v(f)-1)$
+by twice the genus, and a positivity statement for orders of differentials built from the
+discriminant expression $\Delta$-type quantity $j$-invariant data.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ord_sub_one_le_ordDiff_D_of_perfectField.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ord_sub_one_le_ordDiff_D_of_perfectField
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "diffCoeff ordDiff ordDiff_def ord_uniformizer_alt \
+  uniformizer_alt ord ord_zero ord_mul ord_inv ord_zpow diffCoeff_smul_D_of_ord_eq_one \
+  diffCoeff_smul_D_eq_of_ord_eq_one ord_diffCoeff_D_nonneg_of_perfectField exists_ord_eq_one \
+  min_ord_le_ord_add ord_algebraMap"
+p2m_open "AlgebraicCurve.Place AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+private theorem _root_.AlgebraicCurve.Place.ordDiff_smul_impl [PerfectField K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    (v : AlgebraicCurve.Place K F)
+    {g : F} (hg : g ≠ 0) {ω : Ω[F⁄K]} (hω : ω ≠ 0) :
+    v.ordDiff (g • ω) = v.ord g + v.ordDiff ω := by
+  have ht : v.ord v.uniformizer_alt = 1 := v.ord_uniformizer_alt v.exists_ord_eq_one
+  have hrep : diffCoeff v.uniformizer_alt ω • KaehlerDifferential.D K F v.uniformizer_alt = ω :=
+    v.diffCoeff_smul_D_of_ord_eq_one x ht ω
+  have hgo : g • ω = (g * diffCoeff v.uniformizer_alt ω) • KaehlerDifferential.D K F
+    v.uniformizer_alt :=
+    by
+    conv_lhs => rw [← hrep]
+    rw [smul_smul]
+  have hco : diffCoeff v.uniformizer_alt (g • ω) = g * diffCoeff v.uniformizer_alt ω := by
+    rw [hgo]
+    exact v.diffCoeff_smul_D_eq_of_ord_eq_one x ht _
+  have hc0 : diffCoeff v.uniformizer_alt ω ≠ 0 := by
+    intro h0
+    apply hω
+    rw [← hrep, h0, zero_smul]
+  rw [ordDiff_def, ordDiff_def, hco, v.ord_mul hg hc0]
+
+p2m_export "AlgebraicCurve.Place" "ordDiff_smul_impl"
+private theorem ord_pow_nat (v : AlgebraicCurve.Place K F) (t : F) (m : ℕ) :
+    v.ord (t ^ m) = (m : ℤ) * v.ord t := by
+  rw [← zpow_natCast t m, v.ord_zpow]
+
+private theorem _root_.AlgebraicCurve.Place.H2_pos [PerfectField K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (v : AlgebraicCurve.Place K F)
+    {f : F} (hD : KaehlerDifferential.D K F f ≠ 0) (hn : 0 ≤ v.ord f) :
+    v.ord f - 1 ≤ v.ordDiff (KaehlerDifferential.D K F f) := by
+  have ht : v.ord v.uniformizer_alt = 1 := v.ord_uniformizer_alt v.exists_ord_eq_one
+  set t := v.uniformizer_alt with htdef
+  have ht0 : t ≠ 0 := by
+    intro h0
+    rw [h0, v.ord_zero] at ht
+    omega
+  have hf0 : f ≠ 0 := by
+    rintro rfl
+    rw [map_zero] at hD
+    exact hD rfl
+  set m : ℕ := (v.ord f).toNat with hmdef
+  have hm : (m : ℤ) = v.ord f := Int.toNat_of_nonneg hn
+  have htm0 : t ^ m ≠ 0 := pow_ne_zero m ht0
+  set u : F := f * (t ^ m)⁻¹ with hudef
+  have hu0 : u ≠ 0 := mul_ne_zero hf0 (inv_ne_zero htm0)
+  have hordu : v.ord u = 0 := by
+    rw [hudef, v.ord_mul hf0 (inv_ne_zero htm0), v.ord_inv, ord_pow_nat, ht, hm]
+    ring
+  have hfeq : f = u * t ^ m := by
+    rw [hudef, mul_assoc, inv_mul_cancel₀ htm0, mul_one]
+  set cu : F := diffCoeff t (KaehlerDifferential.D K F u) with hcudef
+  have hcu_nonneg : 0 ≤ v.ord cu :=
+    v.ord_diffCoeff_D_nonneg_of_perfectField x ht (le_of_eq hordu.symm)
+  have hrepu : cu • KaehlerDifferential.D K F t = KaehlerDifferential.D K F u :=
+    v.diffCoeff_smul_D_of_ord_eq_one x ht _
+  have hDtm : KaehlerDifferential.D K F (t ^ m) =
+      ((m : F) * t ^ (m - 1)) • KaehlerDifferential.D K F t := by
+    rw [Derivation.leibniz_pow, ← Nat.cast_smul_eq_nsmul F m, smul_smul]
+  have hdecomp : KaehlerDifferential.D K F f =
+      (u * ((m : F) * t ^ (m - 1)) + t ^ m * cu) • KaehlerDifferential.D K F t := by
+    conv_lhs => rw [hfeq]
+    rw [Derivation.leibniz, hDtm, ← hrepu, smul_smul, smul_smul, add_smul]
+  have hcoeff : diffCoeff t (KaehlerDifferential.D K F f) =
+      u * ((m : F) * t ^ (m - 1)) + t ^ m * cu := by
+    rw [hdecomp]
+    exact v.diffCoeff_smul_D_eq_of_ord_eq_one x ht _
+  have hsum0 : u * ((m : F) * t ^ (m - 1)) + t ^ m * cu ≠ 0 := by
+    intro h0
+    apply hD
+    rw [hdecomp, h0, zero_smul]
+  rw [ordDiff_def, ← htdef, hcoeff]
+  rcases eq_or_ne (u * ((m : F) * t ^ (m - 1))) 0 with ha | ha
+  · rw [ha, zero_add] at hsum0 ⊢
+    have hcu0 : cu ≠ 0 := fun h => hsum0 (by rw [h, mul_zero])
+    rw [v.ord_mul htm0 hcu0, ord_pow_nat, ht]
+    omega
+  · have hmF : (m : F) ≠ 0 := by
+      intro h
+      exact ha (by rw [h, zero_mul, mul_zero])
+    have hm1 : 1 ≤ m := by
+      rcases Nat.eq_zero_or_pos m with h | h
+      · exact absurd (by rw [h, Nat.cast_zero] : (m : F) = 0) hmF
+      · exact h
+    have hordm : v.ord ((m : F)) = 0 := by
+      have hcast : ((m : F)) = algebraMap K F ((m : K)) := by
+        rw [map_natCast]
+      rw [hcast, v.ord_algebraMap]
+    have horda : v.ord (u * ((m : F) * t ^ (m - 1))) = (m : ℤ) - 1 := by
+      have h1 : (m : F) * t ^ (m - 1) ≠ 0 := mul_ne_zero hmF (pow_ne_zero _ ht0)
+      rw [v.ord_mul hu0 h1, v.ord_mul hmF (pow_ne_zero _ ht0), ord_pow_nat, ht, hordu, hordm]
+      have : ((m - 1 : ℕ) : ℤ) = (m : ℤ) - 1 := by
+        omega
+      rw [this]
+      ring
+    rcases eq_or_ne cu 0 with hcu0 | hcu0
+    · rw [hcu0, mul_zero, add_zero, horda]
+      omega
+    · have hordb : v.ord (t ^ m * cu) = (m : ℤ) + v.ord cu := by
+        rw [v.ord_mul htm0 hcu0, ord_pow_nat, ht]
+        ring
+      have hmin := v.min_ord_le_ord_add ha (by exact mul_ne_zero htm0 hcu0) hsum0
+      rw [horda, hordb] at hmin
+      have : min ((m : ℤ) - 1) ((m : ℤ) + v.ord cu) = (m : ℤ) - 1 := by
+        omega
+      rw [this] at hmin
+      omega
+
+p2m_export "AlgebraicCurve.Place" "H2_pos"
+private theorem H2_impl [PerfectField K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (v : AlgebraicCurve.Place K F)
+    {f : F} (hD : KaehlerDifferential.D K F f ≠ 0) :
+    v.ord f - 1 ≤ v.ordDiff (KaehlerDifferential.D K F f) := by
+  rcases le_or_gt 0 (v.ord f) with hn | hn
+  · exact v.H2_pos x hD hn
+  · have hf0 : f ≠ 0 := by
+      rintro rfl
+      rw [map_zero] at hD
+      exact hD rfl
+    have hDinv : KaehlerDifferential.D K F f⁻¹ ≠ 0 := by
+      intro h0
+      apply hD
+      have hleib := Derivation.leibniz_inv (KaehlerDifferential.D K F) f
+      rw [h0] at hleib
+      have hne : (-f⁻¹ ^ 2 : F) ≠ 0 := by
+        simpa using hf0
+      rcases smul_eq_zero.mp hleib.symm with h | h
+      · exact absurd h hne
+      · exact h
+    have hpos := v.H2_pos x hDinv (by rw [v.ord_inv]; omega)
+    have hleib := Derivation.leibniz_inv (KaehlerDifferential.D K F) f
+    have hsmul : v.ordDiff (KaehlerDifferential.D K F f⁻¹) =
+        v.ord (-f⁻¹ ^ 2) + v.ordDiff (KaehlerDifferential.D K F f) := by
+      rw [hleib]
+      exact v.ordDiff_smul_impl x (by simpa using hf0) hD
+    have hordneg : v.ord (-f⁻¹ ^ 2 : F) = -2 * v.ord f := by
+      have hneg1 : (-f⁻¹ ^ 2 : F) = algebraMap K F (-1) * f⁻¹ ^ 2 := by
+        rw [map_neg, map_one]
+        ring
+      have h2 : (f⁻¹ ^ 2 : F) ≠ 0 := by
+        simpa using hf0
+      have hneg1ne : algebraMap K F (-1) ≠ 0 := by
+        rw [map_neg, map_one]
+        exact neg_ne_zero.mpr one_ne_zero
+      rw [hneg1, v.ord_mul hneg1ne h2,
+        v.ord_algebraMap, ← zpow_natCast (f⁻¹) 2, v.ord_zpow, v.ord_inv]
+      ring
+    rw [v.ord_inv] at hpos
+    rw [hsmul, hordneg] at hpos
+    omega
+
+end AlgebraicCurve.Place
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [PerfectField K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (v : AlgebraicCurve.Place K F)
+    {f : F}
+    (hD : KaehlerDifferential.D K F f ≠ 0) :
+    v.ord f - 1 ≤ v.ordDiff (KaehlerDifferential.D K F f) :=
+  AlgebraicCurve.Place.H2_impl x v hD
+
+end S_AlgebraicCurve_Place_ord_sub_one_le_ordDiff_D_of_perfectField
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ord_sub_one_le_ordDiff_D_of_perfectField (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.ord_sub_one_le_ordDiff_D_of_perfectField {K F : Type*} [Field K]
+    [Field F] [Algebra K F] [PerfectField K] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] (v : AlgebraicCurve.Place K F)
+    {f : F}
+    (hD : KaehlerDifferential.D K F f ≠ 0) :
+    v.ord f - 1 ≤ v.ordDiff (KaehlerDifferential.D K F f) :=
+  solution x v hD
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_sum_algebraMap_mul_le_ord_of_linearIndependent_of_constantFieldExtension.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_sum_algebraMap_mul_le_ord_of_linearIndependent_of_constantFieldExtension.lean
new file mode 100644
index 0000000000..9184878ac1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ord_sum_algebraMap_mul_le_ord_of_linearIndependent_of_constantFieldExtension.lean
@@ -0,0 +1,267 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.Place.ord_sum_algebraMap_mul_le_ord_of_linearIndependent_of_constantFieldExtension
+(28da6612-7502-5e70-9d2c-35fe64ed010d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d6f09882-448e-5b92-9c54-27289f65783c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# No cancellation of K'-weighted F-sums at lifted places
+
+Theorem statement:
+`AlgebraicCurve.Place.ord_sum_algebraMap_mul_le_ord_of_linearIndependent_of_constantFieldExtension`
+(`28da6612-7502-5e70-9d2c-35fe64ed010d`), by Claude, 2026-09-05.
+
+Proof: submission `d6f09882-448e-5b92-9c54-27289f65783c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K \subseteq K'$ and $F \subseteq F'$ be fields with $K \to F$, $K' \to F'$, $K \to K'$, $F \to
+F'$ and $K \to F'$ algebra structures forming compatible scalar towers $K \subseteq K' \subseteq F'$
+and $K \subseteq F \subseteq F'$, with $K$ and $K'$ algebraically closed, and assume `IsCurveOver K
+F` and `IsCurveOver K' F'`: in each case every nonzero element has a degree-zero principal divisor
+recording its orders at all places, every place has residue field finite over the constant field,
+and the module of Kähler differentials is free of rank one over the function field. Assume further
+that $F$ is finite over $K(x)$ for some $x$ transcendental over $K$, that $F'$ is finite over
+$K'(x')$ for some $x'$ transcendental over $K'$, and that $F'$ is generated over $K'$ by the image
+of $F$. Here a place is a valuation subring of the function field containing the image of the
+constant field, distinct from the whole field and a principal ideal ring, and $\mathrm{ord}$ denotes
+minus the logarithm of the associated adic valuation. Let $\mathrm{lift}$ be any map from places of
+$F/K$ to places of $F'/K'$ satisfying $\mathrm{ord}_{\mathrm{lift}\,P}(f) = \mathrm{ord}_P(f)$ for
+all $f \in F$ and all $P$. Fix a place $v$ of $F/K$, a family $B : \iota \to K'$ that is linearly
+independent over $K$, and a nonzero finitely supported $g : \iota \to_0 F$. Then $\Sigma = \sum_{j
+\in \operatorname{supp} g} B_j\, g_j \in F'$ is nonzero, and
+$\mathrm{ord}_{\mathrm{lift}\,v}(\Sigma) \le \mathrm{ord}_v(g_j)$ for every $j \in
+\operatorname{supp} g$.
+
+This is the no-cancellation half of the behaviour of places under a constant field extension, the
+computational core of the statement that the Riemann–Roch space of a divisor does not grow when the
+constant field is enlarged (Stichtenoth, Theorem 3.6.3(a)). It is used by
+[`AlgebraicCurve.mem_riemannRochSpace_of_sum_basis_smul_algebraMap_mem_mapDomain`]
+(thm.html#AlgebraicCurve.mem_riemannRochSpace_of_sum_basis_smul_algebraMap_mem_mapDomain)
+to deduce membership of each coordinate $g_j$ in the Riemann–Roch space over $K$ from membership of
+the weighted sum over $K'$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ord_sum_algebraMap_mul_le_ord_of_linearIndependent_of_constantFieldExtension.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_a521858c
+
+
+open AlgebraicCurve IsLocalRing
+
+namespace W7XChildL
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem exists_digit [IsAlgClosed K] (v : Place K F) [Module.Finite K v.ResidueField]
+    {π : v.toValuationSubring} (hπ : Irreducible π) (o : v.toValuationSubring) :
+    ∃ a : K, ∃ o' : v.toValuationSubring, o = algebraMap K v.toValuationSubring a + π * o' := by
+  have : Algebra.IsIntegral K v.ResidueField := Algebra.IsIntegral.of_finite K _
+  have hbij : Function.Bijective (algebraMap K v.ResidueField) :=
+    IsAlgClosed.algebraMap_bijective_of_isIntegral
+  obtain ⟨a, ha⟩ := hbij.2 (IsLocalRing.residue v.toValuationSubring o)
+  have hmem : o - algebraMap K v.toValuationSubring a ∈
+      IsLocalRing.maximalIdeal v.toValuationSubring := by
+    rw [← IsLocalRing.residue_eq_zero_iff, map_sub, sub_eq_zero, ← ha,
+      IsScalarTower.algebraMap_apply K v.toValuationSubring v.ResidueField,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  rw [hπ.maximalIdeal_eq, Ideal.mem_span_singleton'] at hmem
+  obtain ⟨b, hb⟩ := hmem
+  exact ⟨a, b, by rw [mul_comm, hb]; ring⟩
+
+end W7XChildL
+
+open W7XChildL
+
+theorem solution
+    (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [IsAlgClosed K'] [IsCurveOver K F] [IsCurveOver K' F']
+    (lift : Place K F → Place K' F')
+    (hlift_ord : ∀ (P : Place K F) (f : F), (lift P).ord (algebraMap F F' f) = P.ord f)
+    (v : Place K F) {ι : Type*} (B : ι → K') (hB : LinearIndependent K B)
+    (g : ι →₀ F) (hg : g ≠ 0) :
+    (∑ j ∈ g.support, algebraMap K' F' (B j) * algebraMap F F' (g j)) ≠ 0 ∧
+    ∀ j ∈ g.support,
+      (lift v).ord (∑ j ∈ g.support, algebraMap K' F' (B j) * algebraMap F F' (g j)) ≤
+        v.ord (g j) := by
+  classical
+  set Tot := ∑ j ∈ g.support, algebraMap K' F' (B j) * algebraMap F F' (g j) with hTot
+  have hsne : g.support.Nonempty := Finsupp.support_nonempty_iff.mpr hg
+  have : Module.Finite K v.ResidueField := IsCurveOver.finiteResidue v
+  obtain ⟨j₁, hj₁, hj₁m⟩ := g.support.exists_mem_eq_inf' hsne (fun j => v.ord (g j))
+  set m := g.support.inf' hsne (fun j => v.ord (g j)) with hm
+  have hmle : ∀ j ∈ g.support, m ≤ v.ord (g j) := fun j hj => Finset.inf'_le _ hj
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπ0 : (π : F) ≠ 0 := fun h => hπ.ne_zero (Subtype.ext h)
+  have hπord : v.ord (π : F) = 1 := v.ord_coe_irreducible hπ
+  have hgj0 : ∀ j ∈ g.support, g j ≠ 0 := fun j hj => Finsupp.mem_support_iff.mp hj
+  have haj_ne : ∀ j ∈ g.support, (π : F) ^ (-m) * g j ≠ 0 := fun j hj =>
+    mul_ne_zero (zpow_ne_zero _ hπ0) (hgj0 j hj)
+  have haj_ord : ∀ j ∈ g.support, v.ord ((π : F) ^ (-m) * g j) = v.ord (g j) - m := by
+    intro j hj
+    rw [v.ord_mul (zpow_ne_zero _ hπ0) (hgj0 j hj), v.ord_zpow, hπord]; ring
+  have haj_mem : ∀ j ∈ g.support, (π : F) ^ (-m) * g j ∈ v.toValuationSubring := fun j hj =>
+    (v.mem_iff_ord_nonneg (haj_ne j hj)).mpr (by rw [haj_ord j hj]; linarith [hmle j hj])
+  have hdig : ∀ j, ∀ hj : j ∈ g.support, ∃ cj : K, ∃ o' : v.toValuationSubring,
+      (⟨_, haj_mem j hj⟩ : v.toValuationSubring) =
+        algebraMap K v.toValuationSubring cj + π * o' :=
+    fun j hj => exists_digit v hπ ⟨_, haj_mem j hj⟩
+  choose c o' hco using hdig
+  have hcj1 : c j₁ hj₁ ≠ 0 := by
+    intro hc0
+    have heq : (π : F) ^ (-m) * g j₁ = (π : F) * ((o' j₁ hj₁ : v.toValuationSubring) : F) := by
+      have h := congrArg (Subtype.val (p := (· ∈ v.toValuationSubring))) (hco j₁ hj₁)
+      simp only [hc0, map_zero, zero_add, MulMemClass.coe_mul] at h
+      exact h
+    have haj1ord : v.ord ((π:F) ^ (-m) * g j₁) = 0 := by rw [haj_ord j₁ hj₁, ← hj₁m]; ring
+    rcases eq_or_ne ((o' j₁ hj₁ : v.toValuationSubring) : F) 0 with ho0 | ho0
+    · rw [heq, ho0, mul_zero] at haj1ord
+      exact haj_ne j₁ hj₁ (by rw [heq, ho0, mul_zero])
+    · rw [heq, v.ord_mul hπ0 ho0, hπord] at haj1ord
+      have := v.ord_nonneg_of_mem (o' j₁ hj₁).2
+      omega
+  let c' : ι → K := fun j => if hj : j ∈ g.support then c j hj else 0
+  have hc'eq : ∀ j (hj : j ∈ g.support), c' j = c j hj := fun j hj => dite_eq_left hj
+  let e' : ι → F :=
+    fun j => if hj : j ∈ g.support then ((o' j hj : v.toValuationSubring) : F) else 0
+  have he'eq : ∀ j (hj : j ∈ g.support), e' j = ((o' j hj : v.toValuationSubring) : F) :=
+    fun j hj => dite_eq_left hj
+  have he'mem : ∀ j ∈ g.support, e' j ∈ v.toValuationSubring := fun j hj =>
+    (he'eq j hj) ▸ (o' j hj).2
+  let d : K' := ∑ j ∈ g.support, c' j • B j
+  have hd : d ≠ 0 := by
+    intro hd0
+    have := linearIndependent_iff'.1 hB g.support c' hd0 j₁ hj₁
+    rw [hc'eq j₁ hj₁] at this
+    exact hcj1 this
+  have hcoe : ∀ j (hj : j ∈ g.support), (π:F) ^ (-m) * g j =
+      algebraMap K F (c' j) + (π:F) * (e' j) := by
+    intro j hj
+    have h := congrArg (Subtype.val (p := (· ∈ v.toValuationSubring))) (hco j hj)
+    simp only [AddMemClass.coe_add, MulMemClass.coe_mul, Place.coe_algebraMap] at h
+    rw [hc'eq j hj, he'eq j hj]; exact h
+  let R : F' := ∑ j ∈ g.support, algebraMap K' F' (B j) * algebraMap F F' (e' j)
+  have hfact : (algebraMap F F' (π:F)) ^ (-m) * Tot =
+      algebraMap K' F' d + algebraMap F F' (π:F) * R := by
+    rw [hTot, Finset.mul_sum]
+    simp only [d, R, map_sum, Finset.mul_sum, ← Finset.sum_add_distrib]
+    refine Finset.sum_congr rfl fun j hj => ?_
+    rw [show (algebraMap F F' (π:F)) ^ (-m) * (algebraMap K' F' (B j) * algebraMap F F' (g j))
+        = algebraMap K' F' (B j) * algebraMap F F' ((π:F) ^ (-m) * g j) by
+      rw [map_mul, ← map_zpow₀]; ring]
+    rw [hcoe j hj, map_add, map_mul, Algebra.smul_def, map_mul,
+      ← IsScalarTower.algebraMap_apply K K' F', ← IsScalarTower.algebraMap_apply K F F']
+    ring
+  have hφπ0 : algebraMap F F' (π:F) ≠ 0 := by
+    simpa using (algebraMap F F').injective.ne hπ0
+  have hφπord : (lift v).ord (algebraMap F F' (π:F)) = 1 := by rw [hlift_ord]; exact hπord
+  have hRmem : R ∈ (lift v).toValuationSubring := by
+    refine Subring.sum_mem _ fun j hj => mul_mem ((lift v).algebraMap_mem' _) ?_
+    rcases eq_or_ne (e' j) 0 with h0 | h0
+    · rw [h0, map_zero]; exact zero_mem _
+    · refine ((lift v).mem_iff_ord_nonneg ?_).mpr ?_
+      · simpa using (algebraMap F F').injective.ne h0
+      · rw [hlift_ord]; exact v.ord_nonneg_of_mem (he'mem j hj)
+  have hd' : algebraMap K' F' d ≠ 0 := by
+    simpa using (algebraMap K' F').injective.ne hd
+  have hdord : (lift v).ord (algebraMap K' F' d) = 0 := by
+    have h1 := (lift v).ord_nonneg_of_mem ((lift v).algebraMap_mem' d)
+    have h2 := (lift v).ord_nonneg_of_mem ((lift v).algebraMap_mem' d⁻¹)
+    rw [map_inv₀, (lift v).ord_inv] at h2; omega
+  set S := algebraMap K' F' d + algebraMap F F' (π:F) * R with hS
+  have hSmem : S ∈ (lift v).toValuationSubring :=
+    add_mem ((lift v).algebraMap_mem' d)
+      (mul_mem (((lift v).mem_iff_ord_nonneg hφπ0).mpr (by omega)) hRmem)
+  have hSne : S ≠ 0 := by
+    intro h0
+    have heq : (algebraMap F F' (π:F))⁻¹ * algebraMap K' F' d = -R := by
+      have h1 : algebraMap K' F' d = -(algebraMap F F' (π:F) * R) := by
+        rw [eq_neg_iff_add_eq_zero]; exact hS ▸ h0
+      rw [h1, mul_neg, ← mul_assoc, inv_mul_cancel₀ hφπ0, one_mul]
+    have hmem : (algebraMap F F' (π:F))⁻¹ * algebraMap K' F' d ∈ (lift v).toValuationSubring := by
+      rw [heq]; exact neg_mem hRmem
+    have := (lift v).ord_nonneg_of_mem hmem
+    rw [(lift v).ord_mul (inv_ne_zero hφπ0) hd', (lift v).ord_inv, hφπord, hdord] at this
+    omega
+  have hSord : (lift v).ord S = 0 := by
+    have hge := (lift v).ord_nonneg_of_mem hSmem
+    by_contra hne
+    have hSge1 : 1 ≤ (lift v).ord S := by omega
+    have hπinvS : (algebraMap F F' (π:F))⁻¹ * S ∈ (lift v).toValuationSubring := by
+      refine ((lift v).mem_iff_ord_nonneg (mul_ne_zero (inv_ne_zero hφπ0) hSne)).mpr ?_
+      rw [(lift v).ord_mul (inv_ne_zero hφπ0) hSne, (lift v).ord_inv, hφπord]; omega
+    have hπinvd : (algebraMap F F' (π:F))⁻¹ * algebraMap K' F' d
+        ∈ (lift v).toValuationSubring := by
+      have heq : (algebraMap F F' (π:F))⁻¹ * algebraMap K' F' d =
+          (algebraMap F F' (π:F))⁻¹ * S - R := by
+        rw [hS]; field_simp; ring
+      rw [heq]; exact sub_mem hπinvS hRmem
+    have := (lift v).ord_nonneg_of_mem hπinvd
+    rw [(lift v).ord_mul (inv_ne_zero hφπ0) hd', (lift v).ord_inv, hφπord, hdord] at this
+    omega
+  have hTotne : Tot ≠ 0 := fun h0 => hSne (by rw [← hfact, h0, mul_zero])
+  have hTotord : (lift v).ord Tot = m := by
+    have h := hSord
+    rw [← hfact, (lift v).ord_mul (zpow_ne_zero _ hφπ0) hTotne,
+      (lift v).ord_zpow, hφπord] at h
+    linarith
+  exact ⟨hTotne, fun j hj => hTotord ▸ hmle j hj⟩
+
+end S_OVERLONG_a521858c
+end P2MW
+export
+  P2MW.S_OVERLONG_a521858c
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem
+  AlgebraicCurve.Place.ord_sum_algebraMap_mul_le_ord_of_linearIndependent_of_constantFieldExtension
+    (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [IsAlgClosed K'] [IsCurveOver K F] [IsCurveOver K' F']
+    (lift : Place K F → Place K' F')
+    (hlift_ord : ∀ (P : Place K F) (f : F), (lift P).ord (algebraMap F F' f) = P.ord f)
+    (v : Place K F) {ι : Type*} (B : ι → K') (hB : LinearIndependent K B)
+    (g : ι →₀ F) (hg : g ≠ 0) :
+    (∑ j ∈ g.support, algebraMap K' F' (B j) * algebraMap F F' (g j)) ≠ 0 ∧
+    ∀ j ∈ g.support,
+      (lift v).ord (∑ j ∈ g.support, algebraMap K' F' (B j) * algebraMap F F' (g j)) ≤
+        v.ord (g j) :=
+  solution K F K' F' lift hlift_ord v B hB g hg
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ramificationIndex_eq_of_restrict_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ramificationIndex_eq_of_restrict_eq.lean
new file mode 100644
index 0000000000..56de687b29
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ramificationIndex_eq_of_restrict_eq.lean
@@ -0,0 +1,121 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.ramificationIndex_eq_of_restrict_eq
+(5fbca615-84cc-5e09-9ed6-2b9040ebc83e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission abf14081-5d7d-557a-b02a-be931aee2080
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import Mathlib.FieldTheory.Galois.Basic
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_algEquiv_smul_eq_of_restrict_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_SemilinearAut_ramificationIndex_smul
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Ramification index is constant on a Galois fibre
+
+Theorem statement: `AlgebraicCurve.Place.ramificationIndex_eq_of_restrict_eq`
+(`5fbca615-84cc-5e09-9ed6-2b9040ebc83e`), by Claude, 2026-09-05.
+
+Proof: submission `abf14081-5d7d-557a-b02a-be931aee2080`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F'$ and $M$ be fields with $F'$ and $M$ algebras over $K$ and $M$ an algebra over $F'$,
+the three structures forming a scalar tower, and assume $M$ is finite-dimensional over $F'$ and
+Galois over $F'$. Let $W$ and $W'$ be places of $M$ over $K$, that is, valuation subrings of $M$
+containing the image of $K$ under the structure map, different from all of $M$, and whose underlying
+ring is a principal ideal ring. Suppose $W$ and $W'$ have the same restriction to $F'$, where the
+restriction of a place of $M$ is the place of $F'$ whose valuation subring is the preimage of the
+given valuation subring under $\mathrm{algebraMap}\colon F' \to M$. Then the ramification indices of
+$W'$ and of $W$ over $F'$ agree, the ramification index of a place $w$ of $M$ over $F'$ being the
+infimum of the set of natural numbers $n$ with $0 < n$ for which there exists $f \in F'$, $f \neq
+0$, with $w.\mathrm{ord}$ of the image of $f$ in $M$ equal to $n$.
+
+This is the standard statement that in a finite Galois extension the ramification index is the same
+at all places lying over a fixed place of the base field. It feeds into the fundamental identity
+$\sum_{W \mid w} e\, f = [M:F']$ in the form
+[`AlgebraicCurve.Place.card_fiberOver_mul_ramificationIndex_mul_inertiaDeg`]
+(thm.html#AlgebraicCurve.Place.card_fiberOver_mul_ramificationIndex_mul_inertiaDeg),
+and into the results on orders of elements under Hahn series embeddings in the Galois case.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ramificationIndex_eq_of_restrict_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ramificationIndex_eq_of_restrict_eq
+
+noncomputable section
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_Place_ramificationIndex_eq_of_restrict_eq.AlgebraicCurve IsDedekindDomain"
+open scoped Pointwise
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "SemilinearAut.IntertwinesAlong Place SemilinearAut \
+  SemilinearAut.ofAlgAut SemilinearAut.ofAlgAut_smul Place.exists_algEquiv_smul_eq_of_restrict_eq \
+  SemilinearAut.ramificationIndex_smul"
+p2m_open "AlgebraicCurve"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ramificationIndex restrict \
+  exists_algEquiv_smul_eq_of_restrict_eq"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F' M : Type*} [Field K] [Field F'] [Field M] [Algebra K F'] [Algebra K M]
+  [Algebra F' M] [IsScalarTower K F' M]
+
+private theorem intertwinesAlong_one_ofAlgAut (σ : M ≃ₐ[F'] M) :
+    SemilinearAut.IntertwinesAlong (algebraMap F' M) (1 : SemilinearAut K F')
+      (SemilinearAut.ofAlgAut (σ.restrictScalars K)) := by
+  intro x
+  rw [one_smul, SemilinearAut.ofAlgAut_smul]
+  exact σ.commutes x
+
+end Place
+end AlgebraicCurve
+
+open _root_.AlgebraicCurve.Place
+  _root_.P2MW.S_AlgebraicCurve_Place_ramificationIndex_eq_of_restrict_eq.AlgebraicCurve.Place in
+theorem solution {K F' M : Type*} [Field K] [Field F'] [Field M]
+    [Algebra K F'] [Algebra K M] [Algebra F' M] [IsScalarTower K F' M]
+    [FiniteDimensional F' M] [IsGalois F' M] (W W' : Place K M)
+    (h : W'.restrict F' = W.restrict F') :
+    W'.ramificationIndex F' = W.ramificationIndex F' := by
+  obtain ⟨σ, rfl⟩ := Place.exists_algEquiv_smul_eq_of_restrict_eq W W' h
+  exact SemilinearAut.ramificationIndex_smul (intertwinesAlong_one_ofAlgAut σ) W
+
+end
+
+end S_AlgebraicCurve_Place_ramificationIndex_eq_of_restrict_eq
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ramificationIndex_eq_of_restrict_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.ramificationIndex_eq_of_restrict_eq {K F' M : Type*} [Field K]
+    [Field F'] [Field M]
+    [Algebra K F'] [Algebra K M] [Algebra F' M] [IsScalarTower K F' M]
+    [FiniteDimensional F' M] [IsGalois F' M] (W W' : Place K M)
+    (h : W'.restrict F' = W.restrict F') :
+    W'.ramificationIndex F' = W.ramificationIndex F' :=
+  solution W W' h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ramificationIndex_eq_ramificationIdx_fiberCenter.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ramificationIndex_eq_ramificationIdx_fiberCenter.lean
new file mode 100644
index 0000000000..d50f44c5fe
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_ramificationIndex_eq_ramificationIdx_fiberCenter.lean
@@ -0,0 +1,286 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.ramificationIndex_eq_ramificationIdx_fiberCenter
+(40611fc7-9a3c-5cf1-9df8-c037da709ad9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7a22b94a-7431-5f01-9e5a-c4d620c2de42
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_iff_ord_nonneg
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# e(w∣ v) equals the ramification index of the fibre centre
+
+Theorem statement: `AlgebraicCurve.Place.ramificationIndex_eq_ramificationIdx_fiberCenter`
+(`40611fc7-9a3c-5cf1-9df8-c037da709ad9`), by Claude, 2026-09-05.
+
+Proof: submission `7a22b94a-7431-5f01-9e5a-c4d620c2de42`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $F'$ be fields with $F$ and $F'$ algebras over $K$ and $F'$ an algebra over $F$, the
+three structures forming a scalar tower, and assume $F'/F$ is finite-dimensional and separable. Let
+$v$ be a place of $F$ over $K$, that is, a valuation subring $\mathcal O_v$ of $F$ containing the
+image of $K$, different from $F$ itself, and a principal ideal ring; let $w$ be such a place of $F'$
+over $K$, and assume $w$ restricts to $v$, i.e. the preimage of $\mathcal O_w$ under $F \to F'$ is
+exactly $\mathcal O_v$. Write $C =$ `integralClosureAt F' v` for the integral closure of $\mathcal
+O_v$ in $F'$, a Dedekind domain with fraction field $F'$ and finite over $\mathcal O_v$, and let
+`Place.fiberCenter F' v hw` be the height-one prime of $C$ cut out by $w$, namely the centre of $w$
+on $C$. The assertion is that `w.ramificationIndex F`, defined as the least positive natural number
+$n$ for which $w.\mathrm{ord}$ takes the value $n$ at the image in $F'$ of some nonzero element of
+$F$, coincides with the ramification index, in the sense of `ramificationIdx'`, of the maximal ideal
+$\mathfrak m_v$ of $\mathcal O_v$ relative to the prime ideal underlying that fibre centre.
+
+This is the valuation half of the dictionary between the places of $F'$ lying over a place $v$ of
+$F$ and the primes of the integral closure of $\mathcal O_v$ in $F'$; it is what allows the
+fundamental identity $\sum_i e_i f_i = [F' : F]$ for Dedekind extensions to be read as a statement
+about places. It is used in the computation of norms and of local contributions along a fibre, for
+instance in
+[`AlgebraicCurve.Place.evalAt_norm_eq_prod_fiber`]
+(thm.html#AlgebraicCurve.Place.evalAt_norm_eq_prod_fiber)
+and
+[`AlgebraicCurve.Place.hasValue_norm_along_of_separableAlong`]
+(thm.html#AlgebraicCurve.Place.hasValue_norm_along_of_separableAlong).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ramificationIndex_eq_ramificationIdx_fiberCenter.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ramificationIndex_eq_ramificationIdx_fiberCenter
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.fiberCenter Place"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "center integralClosureAt fiberCenter \
+  toValuationSubring_eq_of_restrict_eq algebraMap_integralClosureAt_ne_zero \
+  ord_algebraMap_integralClosureAt ramificationIndex ramificationIndex_pos restrict ord ord_mul \
+  ord_inv ord_coe_irreducible ord_zpow toValuationSubring mem_iff_ord_nonneg"
+p2m_open "AlgebraicCurve.Place"
+
+section Uniqueness
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+private theorem eq_ord_of_addHom_of_nonneg_iff (φ : F → ℤ)
+    (hmul : ∀ x y, x ≠ 0 → y ≠ 0 → φ (x * y) = φ x + φ y)
+    (hone : ∃ t, t ≠ 0 ∧ φ t = 1)
+    (hiff : ∀ x, x ≠ 0 → (0 ≤ φ x ↔ x ∈ w.toValuationSubring))
+    {x : F} (hx : x ≠ 0) : φ x = w.ord x := by
+  obtain ⟨t, ht0, ht1⟩ := hone
+  have hφ1 : φ 1 = 0 := by
+    have := hmul 1 1 one_ne_zero one_ne_zero
+    rw [mul_one] at this
+    omega
+  have hinv : ∀ y, y ≠ 0 → φ y⁻¹ = -φ y := by
+    intro y hy
+    have h1 : φ (y * y⁻¹) = φ y + φ y⁻¹ := hmul y y⁻¹ hy (inv_ne_zero hy)
+    rw [mul_inv_cancel₀ hy, hφ1] at h1
+    omega
+  have hpow : ∀ (y : F), y ≠ 0 → ∀ m : ℕ, φ (y ^ m) = m * φ y := by
+    intro y hy m
+    induction m with
+    | zero => simpa using hφ1
+    | succ m ih =>
+      rw [pow_succ, hmul _ _ (pow_ne_zero _ hy) hy, ih]
+      push_cast
+      ring
+  have hzpow : ∀ (y : F) (n : ℤ), y ≠ 0 → φ (y ^ n) = n * φ y := by
+    intro y n hy
+    rcases n with m | m
+    · simpa using hpow y hy m
+    · rw [zpow_negSucc, hinv _ (pow_ne_zero _ hy), hpow y hy, Int.negSucc_eq]
+      push_cast
+      ring
+  have hsign : ∀ y, y ≠ 0 → (0 ≤ φ y ↔ 0 ≤ w.ord y) := by
+    intro y hy
+    rw [hiff y hy, w.mem_iff_ord_nonneg hy]
+  have hzero : ∀ y, y ≠ 0 → (φ y = 0 ↔ w.ord y = 0) := by
+    intro y hy
+    have h1 := hsign y hy
+    have h2 := hsign y⁻¹ (inv_ne_zero hy)
+    rw [hinv y hy, w.ord_inv] at h2
+    omega
+  have htord : 0 < w.ord t := by
+    have h1 := (hsign t ht0).mp (by omega)
+    have h2 := (hzero t ht0).not.mp (by omega)
+    omega
+  have hcancel : ∀ y, y ≠ 0 → w.ord y = φ y * w.ord t := by
+    intro y hy
+    have hyt : y * t ^ (-(φ y)) ≠ 0 := mul_ne_zero hy (zpow_ne_zero _ ht0)
+    have h1 : φ (y * t ^ (-(φ y))) = 0 := by
+      rw [hmul _ _ hy (zpow_ne_zero _ ht0), hzpow t _ ht0, ht1]
+      ring
+    have h2 : w.ord (y * t ^ (-(φ y))) = 0 := (hzero _ hyt).mp h1
+    rw [w.ord_mul hy (zpow_ne_zero _ ht0), w.ord_zpow] at h2
+    linarith
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  have hπ0 : (π : F) ≠ 0 := by
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have hπcancel := hcancel (π : F) hπ0
+  rw [w.ord_coe_irreducible hπ] at hπcancel
+  have htord1 : w.ord t = 1 := by
+    have hdvd : w.ord t ∣ 1 := ⟨φ (π : F), by linarith⟩
+    have := Int.le_of_dvd one_pos hdvd
+    omega
+  have := hcancel x hx
+  rw [htord1, mul_one] at this
+  exact this.symm
+
+end Uniqueness
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+section ValuationDictionary
+
+variable {v : Place K F} {w : Place K F'}
+
+private theorem neg_log_valuation_fiberCenter_eq_ord (hw : w.restrict F = v) {x : F'} (hx : x ≠ 0) :
+    -log ((fiberCenter F' v hw).valuation F' x) = w.ord x := by
+  refine eq_ord_of_addHom_of_nonneg_iff w
+    (fun y => -log ((fiberCenter F' v hw).valuation F' y)) ?_ ?_ ?_ hx
+  · intro a b ha hb
+    show -log ((fiberCenter F' v hw).valuation F' (a * b)) =
+      -log ((fiberCenter F' v hw).valuation F' a) +
+        -log ((fiberCenter F' v hw).valuation F' b)
+    rw [map_mul, log_mul ((Valuation.ne_zero_iff _).mpr ha) ((Valuation.ne_zero_iff _).mpr hb)]
+    ring
+  · obtain ⟨t, ht⟩ := (fiberCenter F' v hw).valuation_exists_uniformizer F'
+    refine ⟨t, ?_, ?_⟩
+    · intro h
+      rw [h, map_zero] at ht
+      exact exp_ne_zero ht.symm
+    · show -log ((fiberCenter F' v hw).valuation F' t) = 1
+      rw [ht, log_exp]
+      ring
+  · intro y hy
+    have hy0 : (fiberCenter F' v hw).valuation F' y ≠ 0 := (Valuation.ne_zero_iff _).mpr hy
+    change 0 ≤ -log ((fiberCenter F' v hw).valuation F' y) ↔ y ∈ w.toValuationSubring
+    have hmem : y ∈ w.toValuationSubring ↔ (fiberCenter F' v hw).valuation F' y ≤ 1 := by
+      rw [toValuationSubring_eq_of_restrict_eq hw,
+        HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact Iff.rfl
+    rw [hmem]
+    constructor
+    · intro h
+      calc (fiberCenter F' v hw).valuation F' y
+          = exp (log ((fiberCenter F' v hw).valuation F' y)) := (exp_log hy0).symm
+        _ ≤ exp 0 := by rw [exp_le_exp]; omega
+        _ = 1 := exp_zero
+    · intro h
+      have h1 : exp (log ((fiberCenter F' v hw).valuation F' y)) ≤ exp 0 := by
+        rw [exp_log hy0, exp_zero]
+        exact h
+      rw [exp_le_exp] at h1
+      omega
+
+private theorem le_ord_iff_mem_pow_fiberCenter (hw : w.restrict F = v)
+    {c : integralClosureAt F' v} (hc : c ≠ 0) (n : ℕ) :
+    (n : ℤ) ≤ w.ord (algebraMap (integralClosureAt F' v) F' c) ↔
+      c ∈ (fiberCenter F' v hw).asIdeal ^ n := by
+  have hcF : algebraMap (integralClosureAt F' v) F' c ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hc
+  rw [← neg_log_valuation_fiberCenter_eq_ord hw hcF,
+    HeightOneSpectrum.valuation_of_algebraMap,
+    ← HeightOneSpectrum.intValuation_le_pow_iff_mem]
+  have h0 : (fiberCenter F' v hw).intValuation c ≠ 0 :=
+    HeightOneSpectrum.intValuation_ne_zero _ c hc
+  constructor
+  · intro h
+    calc (fiberCenter F' v hw).intValuation c
+        = exp (log ((fiberCenter F' v hw).intValuation c)) := (exp_log h0).symm
+      _ ≤ exp (-(n : ℤ)) := by rw [exp_le_exp]; omega
+  · intro h
+    have h1 : exp (log ((fiberCenter F' v hw).intValuation c)) ≤ exp (-(n : ℤ)) := by
+      rw [exp_log h0]
+      exact h
+    rw [exp_le_exp] at h1
+    omega
+
+private theorem ramificationIndex_eq_ramificationIdx_fiberCenter (hw : w.restrict F = v) :
+    w.ramificationIndex F =
+      (IsLocalRing.maximalIdeal v.toValuationSubring).ramificationIdx'
+        (fiberCenter F' v hw).asIdeal := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπ0 : π ≠ 0 := hπ.ne_zero
+  have hπC : algebraMap v.toValuationSubring (integralClosureAt F' v) π ≠ 0 :=
+    algebraMap_integralClosureAt_ne_zero hπ0
+  have hmap : (IsLocalRing.maximalIdeal v.toValuationSubring).map
+      (algebraMap v.toValuationSubring (integralClosureAt F' v))
+        = Ideal.span {algebraMap v.toValuationSubring (integralClosureAt F' v) π} := by
+    rw [hπ.maximalIdeal_eq, Ideal.map_span, Set.image_singleton]
+  have hord : w.ord (algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) π))
+        = w.ramificationIndex F := by
+    rw [ord_algebraMap_integralClosureAt hw, ValuationSubring.algebraMap_apply,
+      v.ord_coe_irreducible hπ, mul_one]
+  refine (Ideal.ramificationIdx'_spec ?_ ?_).symm
+  · rw [hmap, Ideal.span_singleton_le_iff_mem,
+      ← le_ord_iff_mem_pow_fiberCenter hw hπC, hord]
+  · rw [hmap, Ideal.span_singleton_le_iff_mem,
+      ← le_ord_iff_mem_pow_fiberCenter hw hπC, hord]
+    have : 0 < w.ramificationIndex F := w.ramificationIndex_pos
+    push_cast
+    omega
+
+end ValuationDictionary
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_Place_ramificationIndex_eq_ramificationIdx_fiberCenter.AlgebraicCurve"
+
+theorem solution {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+    [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+    (v : Place K F) {w : Place K F'}
+    (hw : w.restrict F = v) :
+    w.ramificationIndex F = (IsLocalRing.maximalIdeal v.toValuationSubring).ramificationIdx'
+      (Place.fiberCenter F' v hw).asIdeal :=
+  Place.ramificationIndex_eq_ramificationIdx_fiberCenter hw
+
+end S_AlgebraicCurve_Place_ramificationIndex_eq_ramificationIdx_fiberCenter
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ramificationIndex_eq_ramificationIdx_fiberCenter (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.ramificationIndex_eq_ramificationIdx_fiberCenter {K F F' : Type*}
+    [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F'] [Algebra F F']
+    [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F'] (v : Place K F)
+    {w : Place K F'}
+    (hw : w.restrict F = v) :
+    w.ramificationIndex F = (IsLocalRing.maximalIdeal v.toValuationSubring).ramificationIdx'
+      (Place.fiberCenter F' v hw).asIdeal :=
+  solution v hw
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_restrictAlong_restrictAlong.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_restrictAlong_restrictAlong.lean
new file mode 100644
index 0000000000..abc6e3e9f5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_restrictAlong_restrictAlong.lean
@@ -0,0 +1,86 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.restrictAlong_restrictAlong
+(b8071c81-9b0d-5f98-9ed1-1333b5bee0ce) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c443aab3-d51e-55e0-86b1-2b43a8991374
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Transitivity of restriction of places along a tower
+
+Theorem statement: `AlgebraicCurve.Place.restrictAlong_restrictAlong`
+(`b8071c81-9b0d-5f98-9ed1-1333b5bee0ce`), by Claude, 2026-09-05.
+
+Proof: submission `c443aab3-d51e-55e0-86b1-2b43a8991374`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $F$, $F'$, $F''$ be fields equipped with $K$-algebra structures. Let
+$\varphi \colon F \to F'$ and $\chi \colon F' \to F''$ be $K$-algebra homomorphisms, and assume that
+the underlying ring homomorphism of $\varphi$ is integral, that the underlying ring homomorphism of
+$\chi$ is integral, and that the underlying ring homomorphism of the composite $\chi \circ \varphi$
+(formed as `χ.comp φ`) is integral; these three integrality hypotheses are given separately, the
+composite one not being deduced from the other two. Let $W$ be a place of $F''$ over $K$, that is, a
+valuation subring $\mathcal{O}_W \subseteq F''$ which contains the image of $K$ under the structure
+map, is not all of $F''$, and is a principal ideal ring. Here `Place.restrictAlong` sends a place of
+the target to the place of the source whose valuation subring is the preimage of the given one under
+the map in question, the map being used to view the target as an algebra over the source. The
+assertion is that restricting $W$ along $\chi$ to a place of $F'$ and then restricting the result
+along $\varphi$ gives exactly the same place of $F$ as restricting $W$ along the composite $\chi
+\circ \varphi$.
+
+This is the functoriality (transitivity in a tower) of restriction of places along integral
+$K$-algebra maps of function fields, the place-level statement underlying the compatibility of
+pull-back and push-forward of divisors with composition of the maps; it is used by the corresponding
+transitivity results for `Divisor.pullbackAlong` and `Divisor.pushforwardAlong` and by the
+multiplicativity of ramification indices in a tower.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_restrictAlong_restrictAlong.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_restrictAlong_restrictAlong
+
+open IsDedekindDomain AlgebraicCurve
+
+theorem solution {K F F' F'' : Type*} [Field K] [Field F] [Field F'] [Field F''] [Algebra K F]
+    [Algebra K F'] [Algebra K F''] (φ : F →ₐ[K] F') (χ : F' →ₐ[K] F'') (hφ : φ.toRingHom.IsIntegral)
+    (hχ : χ.toRingHom.IsIntegral) (hχφ : (χ.comp φ).toRingHom.IsIntegral) (W : Place K F'') :
+    (W.restrictAlong χ hχ).restrictAlong φ hφ = W.restrictAlong (χ.comp φ) hχφ :=
+  Place.ext (SetLike.ext fun _ => Iff.rfl)
+
+end S_AlgebraicCurve_Place_restrictAlong_restrictAlong
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_restrictAlong_restrictAlong (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.restrictAlong_restrictAlong {K F F' F'' : Type*} [Field K] [Field F]
+    [Field F'] [Field F''] [Algebra K F] [Algebra K F'] [Algebra K F''] (φ : F →ₐ[K] F')
+    (χ : F' →ₐ[K] F'') (hφ : φ.toRingHom.IsIntegral) (hχ : χ.toRingHom.IsIntegral)
+    (hχφ : (χ.comp φ).toRingHom.IsIntegral) (W : Place K F'') :
+    (W.restrictAlong χ hχ).restrictAlong φ hφ = W.restrictAlong (χ.comp φ) hχφ :=
+  solution φ χ hφ hχ hχφ W
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_restrictAlong_surjective.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_restrictAlong_surjective.lean
new file mode 100644
index 0000000000..1d0fdbef93
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_restrictAlong_surjective.lean
@@ -0,0 +1,93 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.restrictAlong_surjective
+(f685dcec-8c0f-5ba0-96a3-c999ac4864ce) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4d65e8b0-cb9f-5d54-8dd1-14861cba1468
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_restrict_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Surjectivity of restriction of places along a finite separable map
+
+Theorem statement: `AlgebraicCurve.Place.restrictAlong_surjective`
+(`f685dcec-8c0f-5ba0-96a3-c999ac4864ce`), by Claude, 2026-09-05.
+
+Proof: submission `4d65e8b0-cb9f-5d54-8dd1-14861cba1468`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $F$, $F'$ be field extensions of $K$. Let $\varphi : F \to F'$ be a
+$K$-algebra homomorphism whose underlying ring homomorphism is integral, and transport along
+$\varphi$ the $F$-algebra structure on $F'$; assume `FiniteAlong`, i.e. that $F'$ is a finite
+$F$-module for this structure, and `SeparableAlong`, i.e. that $F'$ is a separable $F$-algebra for
+it. Here a place of a $K$-extension $L$ (the structure
+[`AlgebraicCurve.Place`](def/AlgebraicCurve_DivisorClassGroup.html#L22)) consists of a valuation
+subring of $L$ that contains the image of $K$ under the structure map, is not all of $L$, and is a
+principal ideal ring; and `Place.restrictAlong` sends a place $w$ of $F'/K$ to the place of $F/K$
+whose valuation subring is the preimage of that of $w$ under $\varphi$ (its non-triviality and
+principality being inherited). The assertion is that the resulting map from places of $F'/K$ to
+places of $F/K$, $w \mapsto w.\mathrm{restrictAlong}\ \varphi$, is surjective: every place of $F/K$
+is the restriction along $\varphi$ of some place of $F'/K$.
+
+This is the existence half of lying-over for places of a function field: each discrete valuation
+ring of $F$ containing $K$ admits a prolongation to $F'$ when $F'/F$ is finite separable. It
+underlies the fibre-counting statements for the restriction map (degree and ramification identities
+along a correspondence) and, through them, surjectivity statements for push-forward maps on divisor
+classes and on points.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_restrictAlong_surjective.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_restrictAlong_surjective
+
+open AlgebraicCurve
+
+theorem solution
+    {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+    (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (hfin : AlgebraicCurve.FiniteAlong K φ) (hsep : AlgebraicCurve.SeparableAlong K φ) :
+    Function.Surjective (fun w : AlgebraicCurve.Place K F' => w.restrictAlong φ hφ) := by
+  intro v
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have : Module.Finite F F' := hfin
+  have : Algebra.IsSeparable F F' := hsep
+  obtain ⟨W, hW⟩ := AlgebraicCurve.Place.exists_restrict_eq (K := K) (F' := F) (M := F') v
+  exact ⟨W, hW⟩
+
+end S_AlgebraicCurve_Place_restrictAlong_surjective
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_restrictAlong_surjective (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.restrictAlong_surjective
+    {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+    (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (hfin : AlgebraicCurve.FiniteAlong K φ) (hsep : AlgebraicCurve.SeparableAlong K φ) :
+    Function.Surjective (fun w : AlgebraicCurve.Place K F' => w.restrictAlong φ hφ) :=
+  solution φ hφ hfin hsep
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_restrict_ofAlgAut_smul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_restrict_ofAlgAut_smul.lean
new file mode 100644
index 0000000000..4c20472bdb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_restrict_ofAlgAut_smul.lean
@@ -0,0 +1,109 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.restrict_ofAlgAut_smul
+(2e110162-9aa0-5bc2-a7ac-8b8e54efc63f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c0826770-116c-5481-b13d-8997f74b15fc
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_BaseChangeGalois
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# F'-automorphisms fix restrictions of places to F'
+
+Theorem statement: `AlgebraicCurve.Place.restrict_ofAlgAut_smul`
+(`2e110162-9aa0-5bc2-a7ac-8b8e54efc63f`), by Claude, 2026-09-05.
+
+Proof: submission `c0826770-116c-5481-b13d-8997f74b15fc`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K \subseteq F' \subseteq M$ be fields, given as a field $K$, a field $F'$ with a $K$-algebra
+structure, a field $M$ with $K$- and $F'$-algebra structures forming a scalar tower over $K$, with
+$M$ integral over $F'$. Let $\sigma$ be an $F'$-algebra automorphism of $M$, and let $W$ be a place
+of $M$ over $K$ in the project's sense: a valuation subring $\mathcal{O}_W \subseteq M$ containing
+the image of $K$, different from $M$ itself, and whose underlying ring is a principal ideal ring.
+Viewing $\sigma$ as a $K$-algebra automorphism and hence, via `SemilinearAut.ofAlgAut`, as the
+semilinear automorphism given by the pair $(\sigma, \mathrm{id}_K)$ of ring automorphisms of $M$ and
+of $K$ compatible with $K \to M$, let $\sigma \cdot W$ be the place whose valuation subring is the
+pointwise image $\sigma(\mathcal{O}_W)$. The assertion is that the restrictions to $F'$ of $\sigma
+\cdot W$ and of $W$ coincide as places of $F'$ over $K$, i.e. $\sigma(\mathcal{O}_W)$ and
+$\mathcal{O}_W$ have the same preimage in $F'$ under $F' \to M$.
+
+This is the standard fact that an automorphism of $M$ fixing an intermediate field $F'$ carries each
+place of $M$ to a place lying over the same place of $F'$, so that the fibres of restriction are
+unions of orbits. It is used in the treatment of the Galois action on places and divisors, notably
+in the identity expressing the sum of the Galois translates of a divisor as a pullback of a
+pushforward and in the injectivity results for the divisorial Weil pairing.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_restrict_ofAlgAut_smul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_restrict_ofAlgAut_smul
+
+noncomputable section
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_Place_restrict_ofAlgAut_smul.AlgebraicCurve \
+  IsDedekindDomain"
+open scoped Pointwise
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ext SemilinearAut SemilinearAut.inv_smul_def \
+  SemilinearAut.ofAlgAut SemilinearAut.toRingAut_ofAlgAut SemilinearAut.smul_toValuationSubring"
+p2m_open "AlgebraicCurve"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrict restrict_toValuationSubring ext smul_toValuationSubring"
+end Place
+end AlgebraicCurve
+
+open _root_.AlgebraicCurve.Place
+  _root_.P2MW.S_AlgebraicCurve_Place_restrict_ofAlgAut_smul.AlgebraicCurve.Place in
+theorem solution {K F' M : Type*} [Field K] [Field F'] [Field M]
+    [Algebra K F'] [Algebra K M] [Algebra F' M] [IsScalarTower K F' M]
+    [Algebra.IsIntegral F' M] (σ : M ≃ₐ[F'] M) (W : Place K M) :
+    (SemilinearAut.ofAlgAut (σ.restrictScalars K) • W).restrict F' = W.restrict F' := by
+  refine Place.ext ?_
+  ext x
+  rw [restrict_toValuationSubring, restrict_toValuationSubring, ValuationSubring.mem_comap,
+    ValuationSubring.mem_comap, SemilinearAut.smul_toValuationSubring,
+    ValuationSubring.mem_pointwise_smul_iff_inv_smul_mem, SemilinearAut.inv_smul_def,
+    SemilinearAut.toRingAut_ofAlgAut]
+  have : ((σ.restrictScalars K : M ≃+* M).symm (algebraMap F' M x)) = algebraMap F' M x := by
+    rw [RingEquiv.symm_apply_eq]
+    exact (σ.commutes x).symm
+  rw [this]
+
+end
+
+end S_AlgebraicCurve_Place_restrict_ofAlgAut_smul
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_restrict_ofAlgAut_smul (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.restrict_ofAlgAut_smul {K F' M : Type*} [Field K] [Field F'] [Field M]
+    [Algebra K F'] [Algebra K M] [Algebra F' M] [IsScalarTower K F' M]
+    [Algebra.IsIntegral F' M] (σ : M ≃ₐ[F'] M) (W : Place K M) :
+    (SemilinearAut.ofAlgAut (σ.restrictScalars K) • W).restrict F' = W.restrict F' :=
+  solution σ W
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg.lean
new file mode 100644
index 0000000000..661a30e4e0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg.lean
@@ -0,0 +1,1022 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.sum_ramificationIndex_mul_inertiaDeg
+(726f87db-1b81-52b1-acd4-0b24e2b78c6e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4061be28-36c3-51c4-bd40-dde77734f98e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+
+import Mathlib.RingTheory.DedekindDomain.IntegralClosure
+import Mathlib.RingTheory.DedekindDomain.Factorization
+import Mathlib.Algebra.Polynomial.Lifts
+import Mathlib.FieldTheory.Minpoly.Field
+import Mathlib.RingTheory.RamificationInertia.Basic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_nonneg_of_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_of_ord_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_iff_ord_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_exists_ord_pos
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_eq_zero_iff_adicValuation_eq_one
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Fundamental identity sum_{w∣ v} e f = [F':F]
+
+Theorem statement: `AlgebraicCurve.Place.sum_ramificationIndex_mul_inertiaDeg`
+(`726f87db-1b81-52b1-acd4-0b24e2b78c6e`), by Claude, 2026-09-05.
+
+Proof: submission `4061be28-36c3-51c4-bd40-dde77734f98e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $F'$ be fields with $K$-algebra structures on $F$ and $F'$ and an $F$-algebra
+structure on $F'$ forming a scalar tower over $K$, with $F'/F$ finite and separable. A place of $F$
+over $K$ is, by definition, a valuation subring of $F$ containing the image of $K$, different from
+all of $F$, and whose ring is a principal ideal ring; likewise for places of $F'$ over $K$. Assume
+`HasPrincipalDivisors K F'`, i.e. every nonzero $f \in F'$ admits a divisor $D$ (a finitely
+supported $\mathbb{Z}$-valued function on the places of $F'$ over $K$) with $D(w) =
+\mathrm{ord}_w(f)$ at every place $w$ and with degree zero, the degree being the sum of the $D(w)$
+weighted by the residue degrees $\deg w$. Then for every place $v$ of $F$ over $K$, summing over the
+finite set of places $w$ of $F'$ over $K$ whose restriction to $F$ (the preimage valuation subring
+under $F \to F'$) equals $v$, one has $$\sum_{w \mid v} e(w|v)\, f(w|v) = [F' : F]$$ as integers,
+where $e(w|v)$ is the least positive integer of the form $\mathrm{ord}_w(f)$ for some nonzero $f \in
+F$, and $f(w|v)$ is the degree of the residue field of $w$ over the residue field of its restriction
+to $F$.
+
+This is the fundamental identity for places of a function field relating ramification indices and
+residue degrees in a finite separable extension. It is the basic degree computation behind the
+behaviour of divisors and their degrees under pull-back and push-forward along $F \hookrightarrow
+F'$, and is used in the theory of the degree-zero divisor class group and in the computation of
+ramification indices in Kummer-type extensions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg.AlgebraicCurve"
+
+
+noncomputable section
+
+open IsDedekindDomain Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.restrict_fiber_finite Place.mem_fiber FundamentalIdentity \
+  SumRamificationInertia Place Place.ext HasPrincipalDivisors Pic"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ramificationIndex ramificationIndex_pos restrict \
+  restrict_toValuationSubring ord_restrict restrict_fiber_finite restrictInclusion \
+  restrictResidueMap inertiaDeg fiber mem_fiber ext ResidueField deg adicValuation_coe_eq_one_iff \
+  ord ord_mul ord_inv ord_coe_irreducible ord_zpow isPrincipalIdealRing_valuationSubring ne_top' \
+  algebraMap_mem' toValuationSubring isPrincipalIdealRing' mk ord_nonneg_of_mem mem_of_ord_nonneg \
+  mem_iff_ord_nonneg exists_ord_pos ord_eq_zero_iff_adicValuation_eq_one"
+p2m_open "AlgebraicCurve.Place"
+
+section IntegrallyClosed
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.ord_neg (f : F) : w.ord (-f) = w.ord f := by
+  simp only [ord, Valuation.map_neg]
+
+p2m_export "AlgebraicCurve.Place" "ord_neg"
+
+private theorem _root_.AlgebraicCurve.Place.mem_of_eval_monic_eq_zero {P : Polynomial F}
+    (hP : P.Monic)
+    (hcoeff : ∀ i, P.coeff i ∈ w.toValuationSubring) {x : F} (hx : P.eval x = 0) :
+    x ∈ w.toValuationSubring := by
+  have hlift : P ∈ lifts (algebraMap w.toValuationSubring F) := by
+    rw [lifts_iff_coeff_lifts]
+    exact fun n => ⟨⟨P.coeff n, hcoeff n⟩, rfl⟩
+  obtain ⟨Q, hQmap, -, hQmonic⟩ := lifts_and_degree_eq_and_monic hlift hP
+  have hint : IsIntegral w.toValuationSubring x := by
+    refine ⟨Q, hQmonic, ?_⟩
+    rw [show eval₂ (algebraMap w.toValuationSubring F) x Q = (Q.map _).eval x from
+      (eval_map _ x).symm, hQmap, hx]
+  obtain ⟨y, hy⟩ := IsIntegrallyClosed.isIntegral_iff.mp hint
+  exact hy ▸ y.2
+
+p2m_export "AlgebraicCurve.Place" "mem_of_eval_monic_eq_zero"
+
+private theorem _root_.AlgebraicCurve.Place.mem_maximalIdeal_iff_ord_pos {x : F} (hx : x ≠ 0)
+    (hmem : x ∈ w.toValuationSubring) :
+    (⟨x, hmem⟩ : w.toValuationSubring) ∈ IsLocalRing.maximalIdeal w.toValuationSubring ↔
+      0 < w.ord x := by
+  have hnonneg : 0 ≤ w.ord x := w.ord_nonneg_of_mem hmem
+  have hcoe : ((⟨x, hmem⟩ : w.toValuationSubring) : F) = x := rfl
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff, ← w.adicValuation_coe_eq_one_iff,
+    hcoe, ← w.ord_eq_zero_iff_adicValuation_eq_one hx]
+  omega
+
+p2m_export "AlgebraicCurve.Place" "mem_maximalIdeal_iff_ord_pos"
+end IntegrallyClosed
+
+section SupportTransfer
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F'] [Algebra F F']
+  [FiniteDimensional F F']
+
+variable (w : Place K F')
+
+omit [FiniteDimensional F F'] in
+private theorem _root_.AlgebraicCurve.Place.aeval_mem {Q : Polynomial F} {x : F'}
+    (hcoeff : ∀ i, algebraMap F F' (Q.coeff i) ∈ w.toValuationSubring)
+    (hx : x ∈ w.toValuationSubring) :
+    Polynomial.aeval x Q ∈ w.toValuationSubring := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range]
+  exact sum_mem fun i _ => mul_mem (hcoeff i) (pow_mem hx i)
+
+p2m_export "AlgebraicCurve.Place" "aeval_mem"
+
+theorem exists_coeff_ord_ne_zero {f : F'} (hf : f ≠ 0) (hford : w.ord f ≠ 0) :
+    ∃ i < (minpoly F f).natDegree, (minpoly F f).coeff i ≠ 0 ∧
+      w.ord (algebraMap F F' ((minpoly F f).coeff i)) ≠ 0 := by
+  by_contra hcon
+  push Not at hcon
+  set P := minpoly F f with hPdef
+  have hint : IsIntegral F f := Algebra.IsIntegral.isIntegral f
+  have hmonic : P.Monic := minpoly.monic hint
+  have hdeg : 0 < P.natDegree := minpoly.natDegree_pos hint
+  have hc0 : P.coeff 0 ≠ 0 := minpoly.coeff_zero_ne_zero hint hf
+  have hcoeff : ∀ i, algebraMap F F' (P.coeff i) ∈ w.toValuationSubring := by
+    intro i
+    rcases lt_trichotomy i P.natDegree with hi | hi | hi
+    · rcases eq_or_ne (P.coeff i) 0 with h0 | h0
+      · simp [h0]
+      · exact w.mem_of_ord_nonneg (by simpa using h0) (by have := hcon i hi h0; omega)
+    · subst hi
+      simp [hmonic.coeff_natDegree]
+    · simp [Polynomial.coeff_eq_zero_of_natDegree_lt hi]
+  have hfmem : f ∈ w.toValuationSubring := by
+    refine w.mem_of_eval_monic_eq_zero (P := P.map (algebraMap F F')) (hmonic.map _)
+      (fun i => by simpa using hcoeff i) ?_
+    rw [Polynomial.eval_map, ← Polynomial.aeval_def, hPdef, minpoly.aeval]
+  have hfpos : 0 < w.ord f := lt_of_le_of_ne (w.ord_nonneg_of_mem hfmem) (Ne.symm hford)
+  have hkey : algebraMap F F' (P.coeff 0) = -(f * Polynomial.aeval f P.divX) := by
+    have hsplit : Polynomial.aeval f (Polynomial.X * P.divX + Polynomial.C (P.coeff 0))
+        = (0 : F') := by rw [P.X_mul_divX_add]; exact minpoly.aeval F f
+    rw [map_add, map_mul, Polynomial.aeval_X, Polynomial.aeval_C] at hsplit
+    linear_combination hsplit
+  have hcof_mem : Polynomial.aeval f P.divX ∈ w.toValuationSubring :=
+    w.aeval_mem (fun i => by rw [Polynomial.coeff_divX]; exact hcoeff (i + 1)) hfmem
+  have hcof_ne : Polynomial.aeval f P.divX ≠ 0 := by
+    intro h
+    rw [h, mul_zero, neg_zero] at hkey
+    exact hc0 (by simpa using hkey)
+  have hpos0 : 0 < w.ord (algebraMap F F' (P.coeff 0)) := by
+    rw [hkey, w.ord_neg, w.ord_mul hf hcof_ne]
+    have := w.ord_nonneg_of_mem hcof_mem
+    omega
+  have := hcon 0 hdeg hc0
+  omega
+
+end SupportTransfer
+
+section Chart
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R F] [IsFractionRing R F]
+variable (w : Place K F)
+
+private def chartHom (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    R →+* w.toValuationSubring :=
+  (algebraMap R F).codRestrict w.toValuationSubring.toSubring hw
+
+omit [IsDedekindDomain R] [IsFractionRing R F] in
+@[scoped simp]
+private theorem coe_chartHom (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) (r : R) :
+    (chartHom w hw r : F) = algebraMap R F r := rfl
+
+variable (R) in
+def center (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) : Ideal R :=
+  (IsLocalRing.maximalIdeal w.toValuationSubring).comap (chartHom w hw)
+
+scoped instance (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    (center R w hw).IsPrime :=
+  Ideal.comap_isPrime _ _
+
+omit [IsDedekindDomain R] [IsFractionRing R F] in
+theorem mem_center_iff (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) {r : R} :
+    r ∈ center R w hw ↔
+      (⟨algebraMap R F r, hw r⟩ : w.toValuationSubring) ∈
+        IsLocalRing.maximalIdeal w.toValuationSubring :=
+  Iff.rfl
+
+theorem mem_center_iff_ord_pos (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring)
+    {r : R} (hr : r ≠ 0) :
+    r ∈ center R w hw ↔ 0 < w.ord (algebraMap R F r) := by
+  have hr' : algebraMap R F r ≠ 0 := by
+    simpa using (IsFractionRing.injective R F).ne_iff.mpr hr
+  rw [mem_center_iff, w.mem_maximalIdeal_iff_ord_pos hr']
+
+omit [IsDedekindDomain R] [IsFractionRing R F] in
+private theorem inv_algebraMap_mem (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring)
+    {s : R} (hs : IsUnit (chartHom w hw s)) :
+    (algebraMap R F s)⁻¹ ∈ w.toValuationSubring := by
+  obtain ⟨u, hu⟩ := hs
+  have hcoe : ((u : w.toValuationSubring) : F) = algebraMap R F s := by rw [hu]; rfl
+  have h1 : (((u⁻¹ : w.toValuationSubringˣ) : w.toValuationSubring) : F)
+      * algebraMap R F s = 1 := by
+    have hmul := congrArg (fun a : w.toValuationSubring => (a : F)) u.inv_mul
+    push_cast at hmul
+    rwa [hcoe] at hmul
+  rw [← eq_inv_of_mul_eq_one_left h1]
+  exact SetLike.coe_mem _
+
+theorem center_ne_bot (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    center R w hw ≠ ⊥ := by
+  intro hbot
+  apply w.ne_top'
+  have hunit : ∀ r : R, r ≠ 0 → IsUnit (chartHom w hw r) := by
+    intro r hr
+    by_contra hu
+    have : r ∈ center R w hw :=
+      (mem_center_iff w hw).mpr ((IsLocalRing.mem_maximalIdeal _).mpr hu)
+    rw [hbot] at this
+    exact hr (by simpa using this)
+  refine SetLike.ext fun x => ⟨fun _ => ValuationSubring.mem_top x, fun _ => ?_⟩
+  obtain ⟨a, b, hb, hx⟩ := IsFractionRing.div_surjective (A := R) x
+  rw [← hx, div_eq_mul_inv]
+  exact mul_mem (hw a) (inv_algebraMap_mem w hw (hunit b (nonZeroDivisors.ne_zero hb)))
+
+variable (R) in
+def centerHeightOneSpectrum (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    HeightOneSpectrum R :=
+  ⟨center R w hw, inferInstance, center_ne_bot w hw⟩
+
+@[scoped simp]
+theorem centerHeightOneSpectrum_asIdeal
+    (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    (centerHeightOneSpectrum R w hw).asIdeal = center R w hw := rfl
+
+theorem valuationSubringAtPrime_centerHeightOneSpectrum_le
+    (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    HeightOneSpectrum.valuationSubringAtPrime F (centerHeightOneSpectrum R w hw) ≤
+      w.toValuationSubring := by
+  rintro x ⟨a, s, hs, rfl⟩
+  refine mul_mem (hw a) (inv_algebraMap_mem w hw ?_)
+  rw [← IsLocalRing.notMem_maximalIdeal]
+  exact fun hmem => hs ((mem_center_iff w hw).mpr hmem)
+
+theorem toValuationSubring_eq_of_forall_mem
+    (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    w.toValuationSubring =
+      HeightOneSpectrum.valuationSubringAtPrime F (centerHeightOneSpectrum R w hw) :=
+  (ValuationSubring.eq_of_le_of_ne_top _
+    (valuationSubringAtPrime_centerHeightOneSpectrum_le w hw) w.ne_top').symm
+
+theorem finite_setOf_forall_mem_and_ord_pos {r₀ : R} (hr₀ : r₀ ≠ 0) :
+    {w : Place K F | (∀ r : R, algebraMap R F r ∈ w.toValuationSubring) ∧
+      0 < w.ord (algebraMap R F r₀)}.Finite := by
+  have hfin : {p : HeightOneSpectrum R | p.asIdeal ∣ Ideal.span {r₀}}.Finite :=
+    Ideal.finite_factors (by simpa [Ideal.span_singleton_eq_bot] using hr₀)
+  rw [← Set.finite_coe_iff]
+  have := hfin.to_subtype
+  refine Finite.of_injective
+    (fun w => (⟨centerHeightOneSpectrum R w.1 w.2.1, ?_⟩ :
+      {p : HeightOneSpectrum R | p.asIdeal ∣ Ideal.span {r₀}})) ?_
+  · rw [Set.mem_ofPred_eq, centerHeightOneSpectrum_asIdeal, Ideal.dvd_span_singleton]
+    exact (mem_center_iff_ord_pos w.1 w.2.1 hr₀).mpr w.2.2
+  · intro w w' h
+    have hcenter : centerHeightOneSpectrum R w.1 w.2.1
+        = centerHeightOneSpectrum R w'.1 w'.2.1 := congrArg Subtype.val h
+    refine Subtype.ext (Place.ext ?_)
+    rw [toValuationSubring_eq_of_forall_mem w.1 w.2.1,
+      toValuationSubring_eq_of_forall_mem w'.1 w'.2.1, hcenter]
+
+end Chart
+
+section FiberFiniteness
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+  [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+theorem finite_setOf_restrict_eq (v : Place K F) :
+    {w : Place K F' | w.restrict F = v}.Finite := by
+  classical
+  let : Algebra v.toValuationSubring F' :=
+    ((algebraMap F F').comp (algebraMap v.toValuationSubring F)).toAlgebra
+  have : IsScalarTower v.toValuationSubring F F' :=
+    IsScalarTower.of_algebraMap_eq fun _ => rfl
+  have : IsDedekindDomain (integralClosure v.toValuationSubring F') :=
+    integralClosure.isDedekindDomain v.toValuationSubring F F'
+  have : IsFractionRing (integralClosure v.toValuationSubring F') F' :=
+    integralClosure.isFractionRing_of_finite_extension (A := v.toValuationSubring) F F'
+  obtain ⟨π, hπ0, hπpos⟩ := v.exists_ord_pos
+  have hπmem : π ∈ v.toValuationSubring := v.mem_of_ord_nonneg hπ0 hπpos.le
+  set C := integralClosure v.toValuationSubring F' with hC
+  set π' : C := algebraMap v.toValuationSubring C ⟨π, hπmem⟩ with hπ'
+  have hπ'F : algebraMap C F' π' = algebraMap F F' π := by
+    rw [hπ', ← IsScalarTower.algebraMap_apply, IsScalarTower.algebraMap_apply
+      v.toValuationSubring F F']
+    rfl
+  have hπ'0 : π' ≠ 0 := by
+    intro h
+    apply hπ0
+    have : algebraMap C F' π' = 0 := by rw [h, map_zero]
+    rw [hπ'F] at this
+    simpa using this
+  refine Set.Finite.subset (finite_setOf_forall_mem_and_ord_pos (R := C) hπ'0) ?_
+  rintro w (hw : w.restrict F = v)
+  have hOv : ∀ g : F, g ∈ v.toValuationSubring → algebraMap F F' g ∈ w.toValuationSubring := by
+    intro g hg
+    rw [← hw] at hg
+    exact hg
+  refine ⟨?_, ?_⟩
+  · intro c
+    obtain ⟨Q, hQmonic, hQeval⟩ := c.2
+    have : algebraMap C F' c = (c : F') := rfl
+    rw [this]
+    refine w.mem_of_eval_monic_eq_zero (P := Q.map (algebraMap v.toValuationSubring F'))
+      (hQmonic.map _) (fun i => ?_) (by rw [Polynomial.eval_map]; exact hQeval)
+    rw [Polynomial.coeff_map, IsScalarTower.algebraMap_apply v.toValuationSubring F F']
+    exact hOv _ (Q.coeff i).2
+  · rw [hπ'F, w.ord_restrict π, hw]
+    have hepos : 0 < w.ramificationIndex F := w.ramificationIndex_pos
+    positivity
+
+end FiberFiniteness
+
+end Place
+end AlgebraicCurve
+
+section
+
+open IsDedekindDomain WithZero IsLocalRing
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.restrict_fiber_finite Place.mem_fiber FundamentalIdentity \
+  SumRamificationInertia Place Place.ext HasPrincipalDivisors Pic"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ramificationIndex ramificationIndex_pos restrict \
+  restrict_toValuationSubring ord_restrict restrict_fiber_finite restrictInclusion \
+  restrictResidueMap inertiaDeg fiber mem_fiber ext ResidueField deg adicValuation_coe_eq_one_iff \
+  ord ord_mul ord_inv ord_coe_irreducible ord_zpow isPrincipalIdealRing_valuationSubring ne_top' \
+  algebraMap_mem' toValuationSubring isPrincipalIdealRing' mk ord_nonneg_of_mem mem_of_ord_nonneg \
+  mem_iff_ord_nonneg exists_ord_pos ord_eq_zero_iff_adicValuation_eq_one"
+p2m_open "AlgebraicCurve.Place"
+
+section Uniqueness
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+theorem eq_ord_of_addHom_of_nonneg_iff (φ : F → ℤ)
+    (hmul : ∀ x y, x ≠ 0 → y ≠ 0 → φ (x * y) = φ x + φ y)
+    (hone : ∃ t, t ≠ 0 ∧ φ t = 1)
+    (hiff : ∀ x, x ≠ 0 → (0 ≤ φ x ↔ x ∈ w.toValuationSubring))
+    {x : F} (hx : x ≠ 0) : φ x = w.ord x := by
+  obtain ⟨t, ht0, ht1⟩ := hone
+  have hφ1 : φ 1 = 0 := by
+    have := hmul 1 1 one_ne_zero one_ne_zero
+    rw [mul_one] at this
+    omega
+  have hinv : ∀ y, y ≠ 0 → φ y⁻¹ = -φ y := by
+    intro y hy
+    have h1 : φ (y * y⁻¹) = φ y + φ y⁻¹ := hmul y y⁻¹ hy (inv_ne_zero hy)
+    rw [mul_inv_cancel₀ hy, hφ1] at h1
+    omega
+  have hpow : ∀ (y : F), y ≠ 0 → ∀ m : ℕ, φ (y ^ m) = m * φ y := by
+    intro y hy m
+    induction m with
+    | zero => simpa using hφ1
+    | succ m ih =>
+      rw [pow_succ, hmul _ _ (pow_ne_zero _ hy) hy, ih]
+      push_cast
+      ring
+  have hzpow : ∀ (y : F) (n : ℤ), y ≠ 0 → φ (y ^ n) = n * φ y := by
+    intro y n hy
+    rcases n with m | m
+    · simpa using hpow y hy m
+    · rw [zpow_negSucc, hinv _ (pow_ne_zero _ hy), hpow y hy, Int.negSucc_eq]
+      push_cast
+      ring
+  have hsign : ∀ y, y ≠ 0 → (0 ≤ φ y ↔ 0 ≤ w.ord y) := by
+    intro y hy
+    rw [hiff y hy, w.mem_iff_ord_nonneg hy]
+  have hzero : ∀ y, y ≠ 0 → (φ y = 0 ↔ w.ord y = 0) := by
+    intro y hy
+    have h1 := hsign y hy
+    have h2 := hsign y⁻¹ (inv_ne_zero hy)
+    rw [hinv y hy, w.ord_inv] at h2
+    omega
+  have htord : 0 < w.ord t := by
+    have h1 := (hsign t ht0).mp (by omega)
+    have h2 := (hzero t ht0).not.mp (by omega)
+    omega
+  have hcancel : ∀ y, y ≠ 0 → w.ord y = φ y * w.ord t := by
+    intro y hy
+    have hyt : y * t ^ (-(φ y)) ≠ 0 := mul_ne_zero hy (zpow_ne_zero _ ht0)
+    have h1 : φ (y * t ^ (-(φ y))) = 0 := by
+      rw [hmul _ _ hy (zpow_ne_zero _ ht0), hzpow t _ ht0, ht1]
+      ring
+    have h2 : w.ord (y * t ^ (-(φ y))) = 0 := (hzero _ hyt).mp h1
+    rw [w.ord_mul hy (zpow_ne_zero _ ht0), w.ord_zpow] at h2
+    linarith
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  have hπ0 : (π : F) ≠ 0 := by
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have hπcancel := hcancel (π : F) hπ0
+  rw [w.ord_coe_irreducible hπ] at hπcancel
+  have htord1 : w.ord t = 1 := by
+    have hdvd : w.ord t ∣ 1 := ⟨φ (π : F), by linarith⟩
+    have := Int.le_of_dvd one_pos hdvd
+    omega
+  have := hcancel x hx
+  rw [htord1, mul_one] at this
+  exact this.symm
+
+end Uniqueness
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+variable (F') in
+@[reducible] def valuationSubringAlgebra (v : Place K F) : Algebra v.toValuationSubring F' :=
+  ((algebraMap F F').comp (algebraMap v.toValuationSubring F)).toAlgebra
+
+attribute [local instance 0] valuationSubringAlgebra
+
+section Setup
+
+variable (v : Place K F)
+
+scoped instance (priority := 100) : IsScalarTower v.toValuationSubring F F' :=
+  IsScalarTower.of_algebraMap_eq fun _ => rfl
+
+variable (F') in
+abbrev integralClosureAt : Type _ := integralClosure v.toValuationSubring F'
+
+scoped instance : IsDedekindDomain (integralClosureAt F' v) :=
+  integralClosure.isDedekindDomain v.toValuationSubring F F'
+
+scoped instance : IsFractionRing (integralClosureAt F' v) F' :=
+  integralClosure.isFractionRing_of_finite_extension (A := v.toValuationSubring) F F'
+
+scoped instance : Module.Finite v.toValuationSubring (integralClosureAt F' v) :=
+  IsIntegralClosure.finite v.toValuationSubring F F' _
+
+omit [Algebra K F'] [IsScalarTower K F F'] [FiniteDimensional F F']
+  [Algebra.IsSeparable F F'] in
+theorem algebraMap_integralClosureAt_injective :
+    Function.Injective
+      (algebraMap v.toValuationSubring (integralClosureAt F' v)) := by
+  intro a b hab
+  have h1 : algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) a)
+        = algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) b) := by rw [hab]
+  rw [← IsScalarTower.algebraMap_apply, ← IsScalarTower.algebraMap_apply] at h1
+  exact ((algebraMap F F').injective.comp
+    (IsFractionRing.injective v.toValuationSubring F)) h1
+
+scoped instance : Module.IsTorsionFree v.toValuationSubring (integralClosureAt F' v) := by
+  rw [Module.isTorsionFree_iff_smul_eq_zero]
+  intro r c hrc
+  rw [Algebra.smul_def] at hrc
+  rcases mul_eq_zero.mp hrc with h | h
+  · exact Or.inl (algebraMap_integralClosureAt_injective v (by rw [h, map_zero]))
+  · exact Or.inr h
+
+theorem maximalIdeal_ne_bot :
+    IsLocalRing.maximalIdeal v.toValuationSubring ≠ ⊥ := by
+  intro h
+  exact ValuationSubring.not_isField_of_ne_top F v.ne_top'
+    (IsLocalRing.isField_iff_maximalIdeal_eq.mpr h)
+
+end Setup
+
+section Center
+
+variable {v : Place K F} {w : Place K F'}
+
+omit [FiniteDimensional F F'] in
+theorem forall_mem_of_restrict_eq (hw : w.restrict F = v) (c : integralClosureAt F' v) :
+    algebraMap (integralClosureAt F' v) F' c ∈ w.toValuationSubring := by
+  obtain ⟨Q, hQmonic, hQeval⟩ := c.2
+  have hOv : ∀ g : F, g ∈ v.toValuationSubring →
+      algebraMap F F' g ∈ w.toValuationSubring := by
+    intro g hg
+    rw [← hw] at hg
+    exact hg
+  refine w.mem_of_eval_monic_eq_zero (P := Q.map (algebraMap v.toValuationSubring F'))
+    (hQmonic.map _) (fun i => ?_) (by rw [Polynomial.eval_map]; exact hQeval)
+  rw [Polynomial.coeff_map,
+    IsScalarTower.algebraMap_apply v.toValuationSubring F F']
+  exact hOv _ (Q.coeff i).2
+
+variable (F' v) in
+def fiberCenter (hw : w.restrict F = v) : HeightOneSpectrum (integralClosureAt F' v) :=
+  centerHeightOneSpectrum (integralClosureAt F' v) w (forall_mem_of_restrict_eq hw)
+
+theorem mem_fiberCenter_iff_ord_pos (hw : w.restrict F = v) {c : integralClosureAt F' v}
+    (hc : c ≠ 0) :
+    c ∈ (fiberCenter F' v hw).asIdeal ↔
+      0 < w.ord (algebraMap (integralClosureAt F' v) F' c) :=
+  mem_center_iff_ord_pos w (forall_mem_of_restrict_eq hw) hc
+
+theorem toValuationSubring_eq_of_restrict_eq (hw : w.restrict F = v) :
+    w.toValuationSubring =
+      HeightOneSpectrum.valuationSubringAtPrime F' (fiberCenter F' v hw) :=
+  toValuationSubring_eq_of_forall_mem w (forall_mem_of_restrict_eq hw)
+
+theorem mem_maximalIdeal_iff_ord_pos' {r : v.toValuationSubring} (hr : r ≠ 0) :
+    r ∈ IsLocalRing.maximalIdeal v.toValuationSubring ↔
+      0 < v.ord (algebraMap v.toValuationSubring F r) := by
+  have hrF : (algebraMap v.toValuationSubring F r : F) ≠ 0 := by
+    simpa using (IsFractionRing.injective v.toValuationSubring F).ne_iff.mpr hr
+  have := v.mem_maximalIdeal_iff_ord_pos hrF (Subtype.coe_prop r)
+  simpa using this
+
+omit [Algebra K F'] [IsScalarTower K F F'] [FiniteDimensional F F']
+  [Algebra.IsSeparable F F'] in
+theorem algebraMap_integralClosureAt_ne_zero {r : v.toValuationSubring} (hr : r ≠ 0) :
+    algebraMap v.toValuationSubring (integralClosureAt F' v) r ≠ 0 := fun h =>
+  hr (algebraMap_integralClosureAt_injective v (by rw [h, map_zero]))
+
+omit [FiniteDimensional F F'] in
+theorem ord_algebraMap_integralClosureAt (hw : w.restrict F = v) (r : v.toValuationSubring) :
+    w.ord (algebraMap (integralClosureAt F' v) F'
+        (algebraMap v.toValuationSubring (integralClosureAt F' v) r))
+      = w.ramificationIndex F * v.ord (algebraMap v.toValuationSubring F r) := by
+  rw [← IsScalarTower.algebraMap_apply,
+    IsScalarTower.algebraMap_apply v.toValuationSubring F F', w.ord_restrict, hw]
+
+theorem fiberCenter_liesOver (hw : w.restrict F = v) :
+    (fiberCenter F' v hw).asIdeal.LiesOver
+      (IsLocalRing.maximalIdeal v.toValuationSubring) := by
+  refine ⟨?_⟩
+  rw [Ideal.under_def]
+  ext r
+  rcases eq_or_ne r 0 with rfl | hr
+  · simp
+  rw [Ideal.mem_comap,
+    mem_fiberCenter_iff_ord_pos hw (algebraMap_integralClosureAt_ne_zero hr),
+    ord_algebraMap_integralClosureAt hw, mem_maximalIdeal_iff_ord_pos' hr]
+  have hepos : 0 < ramificationIndex (F := F) w := w.ramificationIndex_pos
+  constructor
+  · intro h
+    positivity
+  · intro h
+    rcases mul_pos_iff.mp h with ⟨_, h2⟩ | ⟨h1, _⟩
+    · exact h2
+    · omega
+
+end Center
+
+section ValuationDictionary
+
+variable {v : Place K F} {w : Place K F'}
+
+theorem neg_log_valuation_fiberCenter_eq_ord (hw : w.restrict F = v) {x : F'} (hx : x ≠ 0) :
+    -log ((fiberCenter F' v hw).valuation F' x) = w.ord x := by
+  refine eq_ord_of_addHom_of_nonneg_iff w
+    (fun y => -log ((fiberCenter F' v hw).valuation F' y)) ?_ ?_ ?_ hx
+  · intro a b ha hb
+    show -log ((fiberCenter F' v hw).valuation F' (a * b)) =
+      -log ((fiberCenter F' v hw).valuation F' a) +
+        -log ((fiberCenter F' v hw).valuation F' b)
+    rw [map_mul, log_mul ((Valuation.ne_zero_iff _).mpr ha) ((Valuation.ne_zero_iff _).mpr hb)]
+    ring
+  · obtain ⟨t, ht⟩ := (fiberCenter F' v hw).valuation_exists_uniformizer F'
+    refine ⟨t, ?_, ?_⟩
+    · intro h
+      rw [h, map_zero] at ht
+      exact exp_ne_zero ht.symm
+    · show -log ((fiberCenter F' v hw).valuation F' t) = 1
+      rw [ht, log_exp]
+      ring
+  · intro y hy
+    have hy0 : (fiberCenter F' v hw).valuation F' y ≠ 0 := (Valuation.ne_zero_iff _).mpr hy
+    change 0 ≤ -log ((fiberCenter F' v hw).valuation F' y) ↔ y ∈ w.toValuationSubring
+    have hmem : y ∈ w.toValuationSubring ↔ (fiberCenter F' v hw).valuation F' y ≤ 1 := by
+      rw [toValuationSubring_eq_of_restrict_eq hw,
+        HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact Iff.rfl
+    rw [hmem]
+    constructor
+    · intro h
+      calc (fiberCenter F' v hw).valuation F' y
+          = exp (log ((fiberCenter F' v hw).valuation F' y)) := (exp_log hy0).symm
+        _ ≤ exp 0 := by rw [exp_le_exp]; omega
+        _ = 1 := exp_zero
+    · intro h
+      have h1 : exp (log ((fiberCenter F' v hw).valuation F' y)) ≤ exp 0 := by
+        rw [exp_log hy0, exp_zero]
+        exact h
+      rw [exp_le_exp] at h1
+      omega
+
+theorem le_ord_iff_mem_pow_fiberCenter (hw : w.restrict F = v)
+    {c : integralClosureAt F' v} (hc : c ≠ 0) (n : ℕ) :
+    (n : ℤ) ≤ w.ord (algebraMap (integralClosureAt F' v) F' c) ↔
+      c ∈ (fiberCenter F' v hw).asIdeal ^ n := by
+  have hcF : algebraMap (integralClosureAt F' v) F' c ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hc
+  rw [← neg_log_valuation_fiberCenter_eq_ord hw hcF,
+    HeightOneSpectrum.valuation_of_algebraMap,
+    ← HeightOneSpectrum.intValuation_le_pow_iff_mem]
+  have h0 : (fiberCenter F' v hw).intValuation c ≠ 0 :=
+    HeightOneSpectrum.intValuation_ne_zero _ c hc
+  constructor
+  · intro h
+    calc (fiberCenter F' v hw).intValuation c
+        = exp (log ((fiberCenter F' v hw).intValuation c)) := (exp_log h0).symm
+      _ ≤ exp (-(n : ℤ)) := by rw [exp_le_exp]; omega
+  · intro h
+    have h1 : exp (log ((fiberCenter F' v hw).intValuation c)) ≤ exp (-(n : ℤ)) := by
+      rw [exp_log h0]
+      exact h
+    rw [exp_le_exp] at h1
+    omega
+
+theorem ramificationIndex_eq_ramificationIdx_fiberCenter (hw : w.restrict F = v) :
+    w.ramificationIndex F =
+      (IsLocalRing.maximalIdeal v.toValuationSubring).ramificationIdx'
+        (fiberCenter F' v hw).asIdeal := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπ0 : π ≠ 0 := hπ.ne_zero
+  have hπC : algebraMap v.toValuationSubring (integralClosureAt F' v) π ≠ 0 :=
+    algebraMap_integralClosureAt_ne_zero hπ0
+  have hmap : (IsLocalRing.maximalIdeal v.toValuationSubring).map
+      (algebraMap v.toValuationSubring (integralClosureAt F' v))
+        = Ideal.span {algebraMap v.toValuationSubring (integralClosureAt F' v) π} := by
+    rw [hπ.maximalIdeal_eq, Ideal.map_span, Set.image_singleton]
+  have hord : w.ord (algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) π))
+        = w.ramificationIndex F := by
+    rw [ord_algebraMap_integralClosureAt hw, ValuationSubring.algebraMap_apply,
+      v.ord_coe_irreducible hπ, mul_one]
+  refine (Ideal.ramificationIdx'_spec ?_ ?_).symm
+  · rw [hmap, Ideal.span_singleton_le_iff_mem,
+      ← le_ord_iff_mem_pow_fiberCenter hw hπC, hord]
+  · rw [hmap, Ideal.span_singleton_le_iff_mem,
+      ← le_ord_iff_mem_pow_fiberCenter hw hπC, hord]
+    have : 0 < w.ramificationIndex F := w.ramificationIndex_pos
+    push_cast
+    omega
+
+end ValuationDictionary
+
+section ResidueDictionary
+
+variable {v : Place K F} {w : Place K F'}
+
+def toValuationSubringOfRestrictEq (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.toValuationSubring :=
+  (algebraMap (integralClosureAt F' v) F').codRestrict
+    w.toValuationSubring.toSubring (forall_mem_of_restrict_eq hw)
+
+omit [FiniteDimensional F F'] in
+@[scoped simp]
+theorem coe_toValuationSubringOfRestrictEq (hw : w.restrict F = v)
+    (c : integralClosureAt F' v) :
+    (toValuationSubringOfRestrictEq hw c : F')
+      = algebraMap (integralClosureAt F' v) F' c := rfl
+
+def residueOfCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.ResidueField :=
+  (IsLocalRing.residue w.toValuationSubring).comp (toValuationSubringOfRestrictEq hw)
+
+omit [FiniteDimensional F F'] in
+theorem residueOfCenter_apply (hw : w.restrict F = v) (c : integralClosureAt F' v) :
+    residueOfCenter hw c = IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw c) := rfl
+
+theorem ker_residueOfCenter (hw : w.restrict F = v) :
+    RingHom.ker (residueOfCenter hw) = (fiberCenter F' v hw).asIdeal := by
+  ext c
+  rw [RingHom.mem_ker, residueOfCenter_apply, IsLocalRing.residue_eq_zero_iff]
+  exact Iff.rfl
+
+theorem surjective_residueOfCenter (hw : w.restrict F = v) :
+    Function.Surjective (residueOfCenter hw) := by
+  classical
+  intro y
+  obtain ⟨x, rfl⟩ := IsLocalRing.residue_surjective y
+  have hx : (x : F') ∈ HeightOneSpectrum.valuationSubringAtPrime F' (fiberCenter F' v hw) := by
+    rw [← toValuationSubring_eq_of_restrict_eq hw]
+    exact x.2
+  obtain ⟨a, s, hs, hxas⟩ := hx
+  have hsP : s ∉ (fiberCenter F' v hw).asIdeal := hs
+  have hs0 : s ≠ 0 := fun h => hsP (h ▸ (fiberCenter F' v hw).asIdeal.zero_mem)
+  have hsF : algebraMap (integralClosureAt F' v) F' s ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hs0
+  have hsord : w.ord (algebraMap (integralClosureAt F' v) F' s) = 0 := by
+    have h1 : ¬ 0 < w.ord (algebraMap (integralClosureAt F' v) F' s) := by
+      rw [← mem_fiberCenter_iff_ord_pos hw hs0]
+      exact hsP
+    have h2 : 0 ≤ w.ord (algebraMap (integralClosureAt F' v) F' s) :=
+      w.ord_nonneg_of_mem (forall_mem_of_restrict_eq hw s)
+    omega
+  have hmax : (fiberCenter F' v hw).asIdeal.IsMaximal :=
+    (fiberCenter F' v hw).isPrime.isMaximal (fiberCenter F' v hw).ne_bot
+  obtain ⟨t, i, hi, hti⟩ := hmax.exists_inv hsP
+  have hst : s * t - 1 ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : s * t - 1 = -i := by linear_combination hti
+    rw [h1]
+    exact neg_mem hi
+  refine ⟨a * t, ?_⟩
+  rw [residueOfCenter_apply, ← sub_eq_zero, ← map_sub, IsLocalRing.residue_eq_zero_iff]
+  have hcoe : ((toValuationSubringOfRestrictEq hw (a * t) - x : w.toValuationSubring) : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') := rfl
+  rcases eq_or_ne (toValuationSubringOfRestrictEq hw (a * t) - x) 0 with hzero | hne
+  · rw [hzero]
+    exact (IsLocalRing.maximalIdeal w.toValuationSubring).zero_mem
+  have hcoene : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') ≠ 0 := by
+    intro h
+    exact hne (by rwa [← hcoe, ZeroMemClass.coe_eq_zero] at h)
+  have hfactor : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t * s - a)
+          * (algebraMap (integralClosureAt F' v) F' s)⁻¹ := by
+    rw [hxas, map_sub, map_mul (algebraMap (integralClosureAt F' v) F') (a * t) s,
+      sub_mul, mul_assoc, mul_inv_cancel₀ hsF, mul_one]
+  have hdiffC : a * t * s - a ≠ 0 := by
+    intro h
+    apply hcoene
+    rw [hfactor, h, map_zero, zero_mul]
+  have hdiffP : a * t * s - a ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : a * t * s - a = a * (s * t - 1) := by ring
+    rw [h1]
+    exact Ideal.mul_mem_left _ _ hst
+  have hmem' : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      ∈ w.toValuationSubring := by
+    rw [← hcoe]
+    exact Subtype.coe_prop _
+  rw [show (toValuationSubringOfRestrictEq hw (a * t) - x)
+      = (⟨_, hmem'⟩ : w.toValuationSubring) from Subtype.ext hcoe,
+    w.mem_maximalIdeal_iff_ord_pos hcoene hmem']
+  rw [hfactor, w.ord_mul (by
+      simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hdiffC)
+    (inv_ne_zero hsF), w.ord_inv, hsord, neg_zero, add_zero]
+  exact (mem_fiberCenter_iff_ord_pos hw hdiffC).mp hdiffP
+
+def residueFieldEquivQuotientCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v ⧸ (fiberCenter F' v hw).asIdeal ≃+* w.ResidueField :=
+  (Ideal.quotEquivOfEq (ker_residueOfCenter hw).symm).trans
+    ((residueOfCenter hw).quotientKerEquivOfSurjective (surjective_residueOfCenter hw))
+
+theorem residueFieldEquivQuotientCenter_mk (hw : w.restrict F = v)
+    (c : integralClosureAt F' v) :
+    residueFieldEquivQuotientCenter hw (Ideal.Quotient.mk _ c) = residueOfCenter hw c := by
+  change ((residueOfCenter hw).quotientKerEquivOfSurjective (surjective_residueOfCenter hw))
+    ((Ideal.quotEquivOfEq (ker_residueOfCenter hw).symm) (Ideal.Quotient.mk _ c))
+      = residueOfCenter hw c
+  rw [Ideal.quotEquivOfEq_mk]
+  exact RingHom.quotientKerEquivOfSurjective_apply_mk _ c
+
+def placeCongrEquiv {u u' : Place K F} (h : u = u') :
+    u.toValuationSubring ≃+* u'.toValuationSubring where
+  toFun x := ⟨x.1, h ▸ x.2⟩
+  invFun x := ⟨x.1, h.symm ▸ x.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  map_mul' _ _ := rfl
+  map_add' _ _ := rfl
+
+@[scoped simp]
+theorem coe_placeCongrEquiv {u u' : Place K F} (h : u = u') (x : u.toValuationSubring) :
+    (placeCongrEquiv h x : F) = (x : F) := rfl
+
+def restrictResidueFieldEquiv (hw : w.restrict F = v) :
+    (w.restrict F).ResidueField ≃+* IsLocalRing.ResidueField v.toValuationSubring :=
+  IsLocalRing.ResidueField.mapEquiv (placeCongrEquiv hw)
+
+omit [FiniteDimensional F F'] in
+theorem restrictResidueFieldEquiv_residue (hw : w.restrict F = v)
+    (a : (w.restrict F).toValuationSubring) :
+    restrictResidueFieldEquiv hw (IsLocalRing.residue _ a)
+      = IsLocalRing.residue _ (placeCongrEquiv hw a) := by
+  simp only [restrictResidueFieldEquiv, IsLocalRing.ResidueField.mapEquiv_apply,
+    IsLocalRing.ResidueField.map_residue, RingEquiv.coe_toRingHom]
+
+theorem inertiaDeg_eq_inertiaDeg_fiberCenter (hw : w.restrict F = v) :
+    w.inertiaDeg F =
+      (fiberCenter F' v hw).asIdeal.inertiaDeg v.toValuationSubring := by
+  have := fiberCenter_liesOver hw
+  rw [Ideal.inertiaDeg_eq_of_isMaximal (IsLocalRing.maximalIdeal v.toValuationSubring)
+    (fiberCenter F' v hw).asIdeal]
+  change Module.finrank (w.restrict F).ResidueField w.ResidueField = _
+  refine Algebra.finrank_eq_of_equiv_equiv (restrictResidueFieldEquiv hw)
+    (residueFieldEquivQuotientCenter hw).symm ?_
+  ext a
+  obtain ⟨a, rfl⟩ := IsLocalRing.residue_surjective a
+  simp only [RingHom.coe_comp, Function.comp_apply, RingEquiv.toRingHom_eq_coe,
+    RingHom.coe_coe]
+  apply (residueFieldEquivQuotientCenter hw).injective
+  rw [RingEquiv.apply_symm_apply]
+  change IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw
+        (algebraMap v.toValuationSubring (integralClosureAt F' v) (placeCongrEquiv hw a)))
+    = IsLocalRing.residue w.toValuationSubring (restrictInclusion F w a)
+  refine congrArg _ (Subtype.ext ?_)
+  change algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) (placeCongrEquiv hw a))
+    = algebraMap F F' (a : F)
+  rw [← IsScalarTower.algebraMap_apply,
+    IsScalarTower.algebraMap_apply v.toValuationSubring F F']
+  rfl
+
+end ResidueDictionary
+
+section Bijection
+
+variable {v : Place K F}
+
+def placeOfPrime (P : HeightOneSpectrum (integralClosureAt F' v)) : Place K F' where
+  toValuationSubring := HeightOneSpectrum.valuationSubringAtPrime F' P
+  algebraMap_mem' := fun a => by
+    rw [HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring,
+      Valuation.mem_valuationSubring_iff]
+    have h1 : algebraMap K F' a = algebraMap (integralClosureAt F' v) F'
+        (algebraMap v.toValuationSubring (integralClosureAt F' v)
+          (algebraMap K v.toValuationSubring a)) := by
+      rw [← IsScalarTower.algebraMap_apply,
+        IsScalarTower.algebraMap_apply v.toValuationSubring F F',
+        ← IsScalarTower.algebraMap_apply K v.toValuationSubring F,
+        ← IsScalarTower.algebraMap_apply K F F']
+    rw [h1]
+    exact P.valuation_le_one _
+  ne_top' := by
+    rw [HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+    simp only [ne_eq, Valuation.valuationSubring_eq_top_iff, not_not]
+    infer_instance
+  isPrincipalIdealRing' := by
+    rw [HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+    exact isPrincipalIdealRing_valuationSubring P
+
+@[scoped simp]
+theorem placeOfPrime_toValuationSubring (P : HeightOneSpectrum (integralClosureAt F' v)) :
+    (placeOfPrime P).toValuationSubring = HeightOneSpectrum.valuationSubringAtPrime F' P :=
+  rfl
+
+theorem restrict_placeOfPrime (P : HeightOneSpectrum (integralClosureAt F' v)) :
+    (placeOfPrime P).restrict F = v := by
+  have hle : v.toValuationSubring ≤ ((placeOfPrime P).restrict F).toValuationSubring := by
+    intro g hg
+    rw [restrict_toValuationSubring, ValuationSubring.mem_comap,
+      placeOfPrime_toValuationSubring,
+      HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring,
+      Valuation.mem_valuationSubring_iff]
+    have h1 : algebraMap F F' g = algebraMap (integralClosureAt F' v) F'
+        (algebraMap v.toValuationSubring (integralClosureAt F' v) ⟨g, hg⟩) := by
+      rw [← IsScalarTower.algebraMap_apply,
+        IsScalarTower.algebraMap_apply v.toValuationSubring F F']
+      rfl
+    rw [h1]
+    exact P.valuation_le_one _
+  exact (Place.ext (ValuationSubring.eq_of_le_of_ne_top _ hle
+    ((placeOfPrime P).restrict F).ne_top')).symm
+
+theorem fiberCenter_placeOfPrime (P : HeightOneSpectrum (integralClosureAt F' v)) :
+    fiberCenter F' v (restrict_placeOfPrime P) = P := by
+  have h1 : HeightOneSpectrum.valuationSubringAtPrime F'
+      (fiberCenter F' v (restrict_placeOfPrime P))
+        = HeightOneSpectrum.valuationSubringAtPrime F' P := by
+    rw [← toValuationSubring_eq_of_restrict_eq (restrict_placeOfPrime P),
+      placeOfPrime_toValuationSubring]
+  refine HeightOneSpectrum.eq_of_valuation_isEquiv_valuation (K := F') ?_
+  rw [Valuation.isEquiv_iff_valuationSubring,
+    ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring,
+    ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring, h1]
+
+theorem eq_of_fiberCenter_eq {w w' : Place K F'} (hw : w.restrict F = v)
+    (hw' : w'.restrict F = v)
+    (h : fiberCenter F' v hw = fiberCenter F' v hw') : w = w' := by
+  refine Place.ext ?_
+  rw [toValuationSubring_eq_of_restrict_eq hw, toValuationSubring_eq_of_restrict_eq hw', h]
+
+end Bijection
+
+section Assembly
+
+variable (v : Place K F)
+
+theorem sum_ramificationIndex_mul_inertiaDeg_infra [HasPrincipalDivisors K F'] :
+    ∑ w ∈ v.fiber F', (w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ)
+      = (Module.finrank F F' : ℤ) := by
+  classical
+  have hkey :
+      ∑ P ∈ IsDedekindDomain.primesOverFinset
+          (IsLocalRing.maximalIdeal v.toValuationSubring) (integralClosureAt F' v),
+        Ideal.ramificationIdx' (IsLocalRing.maximalIdeal v.toValuationSubring) P *
+          Ideal.inertiaDeg P v.toValuationSubring =
+            Module.finrank F F' := by
+    let p := IsLocalRing.maximalIdeal v.toValuationSubring
+    let S := integralClosureAt F' v
+    let e : {P // P ∈ IsDedekindDomain.primesOverFinset p S} ≃ p.primesOver S :=
+      Set.equivOfEq (IsDedekindDomain.coe_primesOverFinset (maximalIdeal_ne_bot v) S)
+    change (∑ P ∈ IsDedekindDomain.primesOverFinset p S,
+      p.ramificationIdx' P * P.inertiaDeg v.toValuationSubring) = Module.finrank F F'
+    calc
+      _ = ∑ P : {P // P ∈ IsDedekindDomain.primesOverFinset p S},
+          p.ramificationIdx' P.1 * P.1.inertiaDeg v.toValuationSubring := by
+            rw [← Finset.sum_attach, Finset.univ_eq_attach]
+      _ = ∑ P : p.primesOver S,
+          P.1.ramificationIdx v.toValuationSubring *
+            P.1.inertiaDeg v.toValuationSubring := by
+            apply Fintype.sum_equiv e
+            intro P
+            have hmem : P.1 ∈ p.primesOver S := (e P).2
+            let : P.1.IsPrime := hmem.1
+            let : P.1.LiesOver p := hmem.2
+            let : P.1.IsMaximal :=
+              (inferInstance : P.1.IsPrime).isMaximal
+                (Ideal.ne_bot_of_mem_primesOver (maximalIdeal_ne_bot v) hmem)
+            change p.ramificationIdx' P.1 * P.1.inertiaDeg v.toValuationSubring =
+              P.1.ramificationIdx v.toValuationSubring *
+                P.1.inertiaDeg v.toValuationSubring
+            rw [Ideal.ramificationIdx'_eq_ramificationIdx p P.1 (maximalIdeal_ne_bot v)]
+      _ = Module.finrank v.toValuationSubring S :=
+        Ideal.sum_ramification_inertia_eq_finrank p S
+      _ = Module.finrank F F' :=
+        IsIntegralClosure.rank v.toValuationSubring F F' S
+  rw [← hkey]
+  push_cast
+  refine Finset.sum_bij
+    (fun w hw => (fiberCenter F' v (Place.mem_fiber.mp hw)).asIdeal) ?_ ?_ ?_ ?_
+  · intro w hw
+    rw [IsDedekindDomain.mem_primesOverFinset_iff (maximalIdeal_ne_bot v)]
+    exact ⟨(fiberCenter F' v (Place.mem_fiber.mp hw)).isPrime,
+      fiberCenter_liesOver (Place.mem_fiber.mp hw)⟩
+  · intro w hw w' hw' h
+    exact eq_of_fiberCenter_eq (Place.mem_fiber.mp hw) (Place.mem_fiber.mp hw')
+      (HeightOneSpectrum.ext h)
+  · intro P hP
+    rw [IsDedekindDomain.mem_primesOverFinset_iff (maximalIdeal_ne_bot v)] at hP
+    obtain ⟨hP1, hP2⟩ := hP
+    have hPne : P ≠ ⊥ := by
+      intro h
+      apply maximalIdeal_ne_bot v
+      have h2 := hP2.over
+      rw [h, Ideal.under_def, Ideal.comap_bot_of_injective _
+        (algebraMap_integralClosureAt_injective v)] at h2
+      exact h2
+    refine ⟨placeOfPrime ⟨P, hP1, hPne⟩,
+      Place.mem_fiber.mpr (restrict_placeOfPrime ⟨P, hP1, hPne⟩), ?_⟩
+    exact congrArg HeightOneSpectrum.asIdeal
+      (fiberCenter_placeOfPrime (⟨P, hP1, hPne⟩ :
+        HeightOneSpectrum (integralClosureAt F' v)))
+  · intro w hw
+    rw [ramificationIndex_eq_ramificationIdx_fiberCenter (Place.mem_fiber.mp hw),
+      inertiaDeg_eq_inertiaDeg_fiberCenter (Place.mem_fiber.mp hw)]
+
+end Assembly
+end Place
+
+scoped instance instSumRamificationInertia {K F F' : Type*} [Field K] [Field F] [Field F']
+    [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+    [FiniteDimensional F F'] [Algebra.IsSeparable F F'] [HasPrincipalDivisors K F'] :
+    SumRamificationInertia K F F' :=
+  ⟨fun v => Place.sum_ramificationIndex_mul_inertiaDeg_infra v⟩
+
+end AlgebraicCurve
+
+theorem solution {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+    [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+    [HasPrincipalDivisors K F'] (v : Place K F) :
+    ∑ w ∈ v.fiber F', (w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ) = (Module.finrank F F' : ℤ)
+      :=
+  AlgebraicCurve.Place.sum_ramificationIndex_mul_inertiaDeg_infra v
+
+end
+end
+end S_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.sum_ramificationIndex_mul_inertiaDeg {K F F' : Type*} [Field K]
+    [Field F] [Field F'] [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+    [FiniteDimensional F F'] [Algebra.IsSeparable F F'] [HasPrincipalDivisors K F'] (v : Place K F)
+    :
+    ∑ w ∈ v.fiber F', (w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ) = (Module.finrank F F' : ℤ)
+      :=
+  solution v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_fiberOver.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_fiberOver.lean
new file mode 100644
index 0000000000..2f069e60fc
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_fiberOver.lean
@@ -0,0 +1,485 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.sum_ramificationIndex_mul_inertiaDeg_fiberOver
+(c174eb24-a14a-5429-afea-e03a5c710f13) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission cee9065c-1b08-5f33-ad9a-093c42deaec2
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_iff_ord_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_nonneg_of_mem
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Fundamental equality sum e(w|v)f(w|v)=[F':F] for places
+
+Theorem statement: `AlgebraicCurve.Place.sum_ramificationIndex_mul_inertiaDeg_fiberOver`
+(`c174eb24-a14a-5429-afea-e03a5c710f13`), by Claude, 2026-09-05.
+
+Proof: submission `cee9065c-1b08-5f33-ad9a-093c42deaec2`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $F'$ be fields with $F$ and $F'$ algebras over $K$ and $F'$ an algebra over $F$, the
+three structures compatible (a scalar tower $K \subseteq F \subseteq F'$), and suppose $F'$ is
+finite-dimensional over $F$ and separable over $F$. Let $v$ be a place of $F$ over $K$ in the sense
+of the project: a valuation subring $\mathcal{O}_v \subseteq F$ that contains the image of $K$ under
+the structure map, is not all of $F$, and is a principal ideal ring. Consider the finite set
+`v.fiberOver F'` of places $w$ of $F'$ over $K$ whose restriction to $F$ — the valuation subring
+obtained by pulling $\mathcal{O}_w$ back along $F \to F'$ — is exactly $v$. For such a $w$, its
+ramification index over $F$ is the least positive integer $n$ for which $w.\mathrm{ord}$ takes the
+value $n$ at the image in $F'$ of some nonzero element of $F$, and its inertia degree is the
+dimension of the residue field of $\mathcal{O}_w$ as a vector space over the residue field of the
+restriction of $w$ to $F$. The assertion is that, as an identity of integers, $\sum_{w \in
+v.\mathrm{fiberOver}\,F'} e(w|v)\,f(w|v) = [F':F]$, the ramification indices, inertia degrees and
+the dimension $\dim_F F'$ being cast into $\mathbb{Z}$.
+
+This is the fundamental equality of valuation theory, $\sum_i e_i f_i = n$, for the places of a
+finite separable extension of function fields over $K$; no hypothesis on divisors of functions is
+imposed, so it is available before any such property of $F$ is established. It supplies the degree
+bookkeeping used in the comparison of the cardinality of a fibre with its ramification and inertia
+data, in the existence of places restricting to a given place, and in the push-forward and pull-back
+of divisors.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_fiberOver.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_fiberOver
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "mem_maximalIdeal_iff_ord_pos center integralClosureAt \
+  algebraMap_integralClosureAt_injective maximalIdeal_ne_bot forall_mem_of_restrict_eq fiberCenter \
+  mem_fiberCenter_iff_ord_pos toValuationSubring_eq_of_restrict_eq \
+  algebraMap_integralClosureAt_ne_zero ord_algebraMap_integralClosureAt fiberCenter_liesOver \
+  placeOfPrime restrict_placeOfPrime fiberCenter_placeOfPrime eq_of_fiberCenter_eq fiberOver \
+  mem_fiberOver ramificationIndex ramificationIndex_pos restrict restrictInclusion \
+  restrictResidueMap inertiaDeg fiber ext ResidueField ord ord_mul ord_inv ord_coe_irreducible \
+  ord_zpow toValuationSubring mk mem_iff_ord_nonneg ord_nonneg_of_mem"
+p2m_open "AlgebraicCurve.Place"
+
+section Uniqueness
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+private theorem eq_ord_of_addHom_of_nonneg_iff (φ : F → ℤ)
+    (hmul : ∀ x y, x ≠ 0 → y ≠ 0 → φ (x * y) = φ x + φ y)
+    (hone : ∃ t, t ≠ 0 ∧ φ t = 1)
+    (hiff : ∀ x, x ≠ 0 → (0 ≤ φ x ↔ x ∈ w.toValuationSubring))
+    {x : F} (hx : x ≠ 0) : φ x = w.ord x := by
+  obtain ⟨t, ht0, ht1⟩ := hone
+  have hφ1 : φ 1 = 0 := by
+    have := hmul 1 1 one_ne_zero one_ne_zero
+    rw [mul_one] at this
+    omega
+  have hinv : ∀ y, y ≠ 0 → φ y⁻¹ = -φ y := by
+    intro y hy
+    have h1 : φ (y * y⁻¹) = φ y + φ y⁻¹ := hmul y y⁻¹ hy (inv_ne_zero hy)
+    rw [mul_inv_cancel₀ hy, hφ1] at h1
+    omega
+  have hpow : ∀ (y : F), y ≠ 0 → ∀ m : ℕ, φ (y ^ m) = m * φ y := by
+    intro y hy m
+    induction m with
+    | zero => simpa using hφ1
+    | succ m ih =>
+      rw [pow_succ, hmul _ _ (pow_ne_zero _ hy) hy, ih]
+      push_cast
+      ring
+  have hzpow : ∀ (y : F) (n : ℤ), y ≠ 0 → φ (y ^ n) = n * φ y := by
+    intro y n hy
+    rcases n with m | m
+    · simpa using hpow y hy m
+    · rw [zpow_negSucc, hinv _ (pow_ne_zero _ hy), hpow y hy, Int.negSucc_eq]
+      push_cast
+      ring
+  have hsign : ∀ y, y ≠ 0 → (0 ≤ φ y ↔ 0 ≤ w.ord y) := by
+    intro y hy
+    rw [hiff y hy, w.mem_iff_ord_nonneg hy]
+  have hzero : ∀ y, y ≠ 0 → (φ y = 0 ↔ w.ord y = 0) := by
+    intro y hy
+    have h1 := hsign y hy
+    have h2 := hsign y⁻¹ (inv_ne_zero hy)
+    rw [hinv y hy, w.ord_inv] at h2
+    omega
+  have htord : 0 < w.ord t := by
+    have h1 := (hsign t ht0).mp (by omega)
+    have h2 := (hzero t ht0).not.mp (by omega)
+    omega
+  have hcancel : ∀ y, y ≠ 0 → w.ord y = φ y * w.ord t := by
+    intro y hy
+    have hyt : y * t ^ (-(φ y)) ≠ 0 := mul_ne_zero hy (zpow_ne_zero _ ht0)
+    have h1 : φ (y * t ^ (-(φ y))) = 0 := by
+      rw [hmul _ _ hy (zpow_ne_zero _ ht0), hzpow t _ ht0, ht1]
+      ring
+    have h2 : w.ord (y * t ^ (-(φ y))) = 0 := (hzero _ hyt).mp h1
+    rw [w.ord_mul hy (zpow_ne_zero _ ht0), w.ord_zpow] at h2
+    linarith
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  have hπ0 : (π : F) ≠ 0 := by
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have hπcancel := hcancel (π : F) hπ0
+  rw [w.ord_coe_irreducible hπ] at hπcancel
+  have htord1 : w.ord t = 1 := by
+    have hdvd : w.ord t ∣ 1 := ⟨φ (π : F), by linarith⟩
+    have := Int.le_of_dvd one_pos hdvd
+    omega
+  have := hcancel x hx
+  rw [htord1, mul_one] at this
+  exact this.symm
+
+end Uniqueness
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+section ValuationDictionary
+
+variable {v : Place K F} {w : Place K F'}
+
+private theorem neg_log_valuation_fiberCenter_eq_ord (hw : w.restrict F = v) {x : F'} (hx : x ≠ 0) :
+    -log ((fiberCenter F' v hw).valuation F' x) = w.ord x := by
+  refine eq_ord_of_addHom_of_nonneg_iff w
+    (fun y => -log ((fiberCenter F' v hw).valuation F' y)) ?_ ?_ ?_ hx
+  · intro a b ha hb
+    show -log ((fiberCenter F' v hw).valuation F' (a * b)) =
+      -log ((fiberCenter F' v hw).valuation F' a) +
+        -log ((fiberCenter F' v hw).valuation F' b)
+    rw [map_mul, log_mul ((Valuation.ne_zero_iff _).mpr ha) ((Valuation.ne_zero_iff _).mpr hb)]
+    ring
+  · obtain ⟨t, ht⟩ := (fiberCenter F' v hw).valuation_exists_uniformizer F'
+    refine ⟨t, ?_, ?_⟩
+    · intro h
+      rw [h, map_zero] at ht
+      exact exp_ne_zero ht.symm
+    · show -log ((fiberCenter F' v hw).valuation F' t) = 1
+      rw [ht, log_exp]
+      ring
+  · intro y hy
+    have hy0 : (fiberCenter F' v hw).valuation F' y ≠ 0 := (Valuation.ne_zero_iff _).mpr hy
+    change 0 ≤ -log ((fiberCenter F' v hw).valuation F' y) ↔ y ∈ w.toValuationSubring
+    have hmem : y ∈ w.toValuationSubring ↔ (fiberCenter F' v hw).valuation F' y ≤ 1 := by
+      rw [toValuationSubring_eq_of_restrict_eq hw,
+        HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact Iff.rfl
+    rw [hmem]
+    constructor
+    · intro h
+      calc (fiberCenter F' v hw).valuation F' y
+          = exp (log ((fiberCenter F' v hw).valuation F' y)) := (exp_log hy0).symm
+        _ ≤ exp 0 := by rw [exp_le_exp]; omega
+        _ = 1 := exp_zero
+    · intro h
+      have h1 : exp (log ((fiberCenter F' v hw).valuation F' y)) ≤ exp 0 := by
+        rw [exp_log hy0, exp_zero]
+        exact h
+      rw [exp_le_exp] at h1
+      omega
+
+private theorem le_ord_iff_mem_pow_fiberCenter (hw : w.restrict F = v)
+    {c : integralClosureAt F' v} (hc : c ≠ 0) (n : ℕ) :
+    (n : ℤ) ≤ w.ord (algebraMap (integralClosureAt F' v) F' c) ↔
+      c ∈ (fiberCenter F' v hw).asIdeal ^ n := by
+  have hcF : algebraMap (integralClosureAt F' v) F' c ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hc
+  rw [← neg_log_valuation_fiberCenter_eq_ord hw hcF,
+    HeightOneSpectrum.valuation_of_algebraMap,
+    ← HeightOneSpectrum.intValuation_le_pow_iff_mem]
+  have h0 : (fiberCenter F' v hw).intValuation c ≠ 0 :=
+    HeightOneSpectrum.intValuation_ne_zero _ c hc
+  constructor
+  · intro h
+    calc (fiberCenter F' v hw).intValuation c
+        = exp (log ((fiberCenter F' v hw).intValuation c)) := (exp_log h0).symm
+      _ ≤ exp (-(n : ℤ)) := by rw [exp_le_exp]; omega
+  · intro h
+    have h1 : exp (log ((fiberCenter F' v hw).intValuation c)) ≤ exp (-(n : ℤ)) := by
+      rw [exp_log h0]
+      exact h
+    rw [exp_le_exp] at h1
+    omega
+
+private theorem ramificationIndex_eq_ramificationIdx_fiberCenter (hw : w.restrict F = v) :
+    w.ramificationIndex F =
+      (IsLocalRing.maximalIdeal v.toValuationSubring).ramificationIdx'
+        (fiberCenter F' v hw).asIdeal := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπ0 : π ≠ 0 := hπ.ne_zero
+  have hπC : algebraMap v.toValuationSubring (integralClosureAt F' v) π ≠ 0 :=
+    algebraMap_integralClosureAt_ne_zero hπ0
+  have hmap : (IsLocalRing.maximalIdeal v.toValuationSubring).map
+      (algebraMap v.toValuationSubring (integralClosureAt F' v))
+        = Ideal.span {algebraMap v.toValuationSubring (integralClosureAt F' v) π} := by
+    rw [hπ.maximalIdeal_eq, Ideal.map_span, Set.image_singleton]
+  have hord : w.ord (algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) π))
+        = w.ramificationIndex F := by
+    rw [ord_algebraMap_integralClosureAt hw, ValuationSubring.algebraMap_apply,
+      v.ord_coe_irreducible hπ, mul_one]
+  refine (Ideal.ramificationIdx'_spec ?_ ?_).symm
+  · rw [hmap, Ideal.span_singleton_le_iff_mem,
+      ← le_ord_iff_mem_pow_fiberCenter hw hπC, hord]
+  · rw [hmap, Ideal.span_singleton_le_iff_mem,
+      ← le_ord_iff_mem_pow_fiberCenter hw hπC, hord]
+    have : 0 < w.ramificationIndex F := w.ramificationIndex_pos
+    push_cast
+    omega
+
+end ValuationDictionary
+
+section ResidueDictionary
+
+variable {v : Place K F} {w : Place K F'}
+
+private def toValuationSubringOfRestrictEq (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.toValuationSubring :=
+  (algebraMap (integralClosureAt F' v) F').codRestrict
+    w.toValuationSubring.toSubring (forall_mem_of_restrict_eq hw)
+
+omit [FiniteDimensional F F'] in
+@[scoped simp]
+private theorem coe_toValuationSubringOfRestrictEq (hw : w.restrict F = v)
+    (c : integralClosureAt F' v) :
+    (toValuationSubringOfRestrictEq hw c : F')
+      = algebraMap (integralClosureAt F' v) F' c := rfl
+
+private def residueOfCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.ResidueField :=
+  (IsLocalRing.residue w.toValuationSubring).comp (toValuationSubringOfRestrictEq hw)
+
+omit [FiniteDimensional F F'] in
+private theorem residueOfCenter_apply (hw : w.restrict F = v) (c : integralClosureAt F' v) :
+    residueOfCenter hw c = IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw c) := rfl
+
+private theorem ker_residueOfCenter (hw : w.restrict F = v) :
+    RingHom.ker (residueOfCenter hw) = (fiberCenter F' v hw).asIdeal := by
+  ext c
+  rw [RingHom.mem_ker, residueOfCenter_apply, IsLocalRing.residue_eq_zero_iff]
+  exact Iff.rfl
+
+private theorem surjective_residueOfCenter (hw : w.restrict F = v) :
+    Function.Surjective (residueOfCenter hw) := by
+  classical
+  intro y
+  obtain ⟨x, rfl⟩ := IsLocalRing.residue_surjective y
+  have hx : (x : F') ∈ HeightOneSpectrum.valuationSubringAtPrime F' (fiberCenter F' v hw) := by
+    rw [← toValuationSubring_eq_of_restrict_eq hw]
+    exact x.2
+  obtain ⟨a, s, hs, hxas⟩ := hx
+  have hsP : s ∉ (fiberCenter F' v hw).asIdeal := hs
+  have hs0 : s ≠ 0 := fun h => hsP (h ▸ (fiberCenter F' v hw).asIdeal.zero_mem)
+  have hsF : algebraMap (integralClosureAt F' v) F' s ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hs0
+  have hsord : w.ord (algebraMap (integralClosureAt F' v) F' s) = 0 := by
+    have h1 : ¬ 0 < w.ord (algebraMap (integralClosureAt F' v) F' s) := by
+      rw [← mem_fiberCenter_iff_ord_pos hw hs0]
+      exact hsP
+    have h2 : 0 ≤ w.ord (algebraMap (integralClosureAt F' v) F' s) :=
+      w.ord_nonneg_of_mem (forall_mem_of_restrict_eq hw s)
+    omega
+  have hmax : (fiberCenter F' v hw).asIdeal.IsMaximal :=
+    (fiberCenter F' v hw).isPrime.isMaximal (fiberCenter F' v hw).ne_bot
+  obtain ⟨t, i, hi, hti⟩ := hmax.exists_inv hsP
+  have hst : s * t - 1 ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : s * t - 1 = -i := by linear_combination hti
+    rw [h1]
+    exact neg_mem hi
+  refine ⟨a * t, ?_⟩
+  rw [residueOfCenter_apply, ← sub_eq_zero, ← map_sub, IsLocalRing.residue_eq_zero_iff]
+  have hcoe : ((toValuationSubringOfRestrictEq hw (a * t) - x : w.toValuationSubring) : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') := rfl
+  rcases eq_or_ne (toValuationSubringOfRestrictEq hw (a * t) - x) 0 with hzero | hne
+  · rw [hzero]
+    exact (IsLocalRing.maximalIdeal w.toValuationSubring).zero_mem
+  have hcoene : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') ≠ 0 := by
+    intro h
+    exact hne (by rwa [← hcoe, ZeroMemClass.coe_eq_zero] at h)
+  have hfactor : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t * s - a)
+          * (algebraMap (integralClosureAt F' v) F' s)⁻¹ := by
+    rw [hxas, map_sub, map_mul (algebraMap (integralClosureAt F' v) F') (a * t) s,
+      sub_mul, mul_assoc, mul_inv_cancel₀ hsF, mul_one]
+  have hdiffC : a * t * s - a ≠ 0 := by
+    intro h
+    apply hcoene
+    rw [hfactor, h, map_zero, zero_mul]
+  have hdiffP : a * t * s - a ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : a * t * s - a = a * (s * t - 1) := by ring
+    rw [h1]
+    exact Ideal.mul_mem_left _ _ hst
+  have hmem' : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      ∈ w.toValuationSubring := by
+    rw [← hcoe]
+    exact Subtype.coe_prop _
+  rw [show (toValuationSubringOfRestrictEq hw (a * t) - x)
+      = (⟨_, hmem'⟩ : w.toValuationSubring) from Subtype.ext hcoe,
+    w.mem_maximalIdeal_iff_ord_pos hcoene hmem']
+  rw [hfactor, w.ord_mul (by
+      simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hdiffC)
+    (inv_ne_zero hsF), w.ord_inv, hsord, neg_zero, add_zero]
+  exact (mem_fiberCenter_iff_ord_pos hw hdiffC).mp hdiffP
+
+private def residueFieldEquivQuotientCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v ⧸ (fiberCenter F' v hw).asIdeal ≃+* w.ResidueField :=
+  (Ideal.quotEquivOfEq (ker_residueOfCenter hw).symm).trans
+    ((residueOfCenter hw).quotientKerEquivOfSurjective (surjective_residueOfCenter hw))
+
+private theorem residueFieldEquivQuotientCenter_mk (hw : w.restrict F = v)
+    (c : integralClosureAt F' v) :
+    residueFieldEquivQuotientCenter hw (Ideal.Quotient.mk _ c) = residueOfCenter hw c := by
+  change ((residueOfCenter hw).quotientKerEquivOfSurjective (surjective_residueOfCenter hw))
+    ((Ideal.quotEquivOfEq (ker_residueOfCenter hw).symm) (Ideal.Quotient.mk _ c))
+      = residueOfCenter hw c
+  rw [Ideal.quotEquivOfEq_mk]
+  exact RingHom.quotientKerEquivOfSurjective_apply_mk _ c
+
+private def placeCongrEquiv {u u' : Place K F} (h : u = u') :
+    u.toValuationSubring ≃+* u'.toValuationSubring where
+  toFun x := ⟨x.1, h ▸ x.2⟩
+  invFun x := ⟨x.1, h.symm ▸ x.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  map_mul' _ _ := rfl
+  map_add' _ _ := rfl
+
+@[scoped simp]
+private theorem coe_placeCongrEquiv {u u' : Place K F} (h : u = u') (x : u.toValuationSubring) :
+    (placeCongrEquiv h x : F) = (x : F) := rfl
+
+private def restrictResidueFieldEquiv (hw : w.restrict F = v) :
+    (w.restrict F).ResidueField ≃+* IsLocalRing.ResidueField v.toValuationSubring :=
+  IsLocalRing.ResidueField.mapEquiv (placeCongrEquiv hw)
+
+omit [FiniteDimensional F F'] in
+private theorem restrictResidueFieldEquiv_residue (hw : w.restrict F = v)
+    (a : (w.restrict F).toValuationSubring) :
+    restrictResidueFieldEquiv hw (IsLocalRing.residue _ a)
+      = IsLocalRing.residue _ (placeCongrEquiv hw a) := by
+  simp only [restrictResidueFieldEquiv, IsLocalRing.ResidueField.mapEquiv_apply,
+    IsLocalRing.ResidueField.map_residue, RingEquiv.coe_toRingHom]
+
+private theorem inertiaDeg_eq_inertiaDeg_fiberCenter (hw : w.restrict F = v) :
+    w.inertiaDeg F =
+      (fiberCenter F' v hw).asIdeal.inertiaDeg v.toValuationSubring := by
+  have := fiberCenter_liesOver hw
+  rw [Ideal.inertiaDeg_eq_of_isMaximal (IsLocalRing.maximalIdeal v.toValuationSubring)
+    (fiberCenter F' v hw).asIdeal]
+  change Module.finrank (w.restrict F).ResidueField w.ResidueField = _
+  refine Algebra.finrank_eq_of_equiv_equiv (restrictResidueFieldEquiv hw)
+    (residueFieldEquivQuotientCenter hw).symm ?_
+  ext a
+  obtain ⟨a, rfl⟩ := IsLocalRing.residue_surjective a
+  simp only [RingHom.coe_comp, Function.comp_apply, RingEquiv.toRingHom_eq_coe,
+    RingHom.coe_coe]
+  apply (residueFieldEquivQuotientCenter hw).injective
+  rw [RingEquiv.apply_symm_apply]
+  change IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw
+        (algebraMap v.toValuationSubring (integralClosureAt F' v) (placeCongrEquiv hw a)))
+    = IsLocalRing.residue w.toValuationSubring (restrictInclusion F w a)
+  refine congrArg _ (Subtype.ext ?_)
+  change algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) (placeCongrEquiv hw a))
+    = algebraMap F F' (a : F)
+  rw [← IsScalarTower.algebraMap_apply,
+    IsScalarTower.algebraMap_apply v.toValuationSubring F F']
+  rfl
+
+end ResidueDictionary
+
+section Assembly
+
+variable (v : Place K F)
+
+private theorem sum_ramificationIndex_mul_inertiaDeg_fiberOver :
+    ∑ w ∈ v.fiberOver F', (w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ)
+      = (Module.finrank F F' : ℤ) := by
+  classical
+  have hkey := sum_ramificationIdx'_mul_inertiaDeg'_integralClosureAt (F' := F') v
+  rw [← hkey]
+  push_cast
+  refine Finset.sum_bij
+    (fun w hw => (fiberCenter F' v ((mem_fiberOver v).mp hw)).asIdeal) ?_ ?_ ?_ ?_
+  · intro w hw
+    rw [IsDedekindDomain.mem_primesOverFinset_iff (maximalIdeal_ne_bot v)]
+    exact ⟨(fiberCenter F' v ((mem_fiberOver v).mp hw)).isPrime,
+      fiberCenter_liesOver ((mem_fiberOver v).mp hw)⟩
+  · intro w hw w' hw' h
+    exact eq_of_fiberCenter_eq ((mem_fiberOver v).mp hw) ((mem_fiberOver v).mp hw')
+      (HeightOneSpectrum.ext h)
+  · intro P hP
+    rw [IsDedekindDomain.mem_primesOverFinset_iff (maximalIdeal_ne_bot v)] at hP
+    obtain ⟨hP1, hP2⟩ := hP
+    have hPne : P ≠ ⊥ := by
+      intro h
+      apply maximalIdeal_ne_bot v
+      have h2 := hP2.over
+      rw [h, Ideal.under_def, Ideal.comap_bot_of_injective _
+        (algebraMap_integralClosureAt_injective v)] at h2
+      exact h2
+    refine ⟨placeOfPrime ⟨P, hP1, hPne⟩,
+      (mem_fiberOver v).mpr (restrict_placeOfPrime ⟨P, hP1, hPne⟩), ?_⟩
+    exact congrArg HeightOneSpectrum.asIdeal
+      (fiberCenter_placeOfPrime (⟨P, hP1, hPne⟩ :
+        HeightOneSpectrum (integralClosureAt F' v)))
+  · intro w hw
+    rw [ramificationIndex_eq_ramificationIdx_fiberCenter ((mem_fiberOver v).mp hw),
+      inertiaDeg_eq_inertiaDeg_fiberCenter ((mem_fiberOver v).mp hw)]
+
+end Assembly
+
+end Place
+end AlgebraicCurve
+end
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_fiberOver.AlgebraicCurve"
+
+theorem solution {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+    [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+    (v : Place K F) :
+    ∑ w ∈ v.fiberOver F', (w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ) = (Module.finrank F F'
+      : ℤ) :=
+  Place.sum_ramificationIndex_mul_inertiaDeg_fiberOver v
+
+end S_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_fiberOver
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_fiberOver (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.sum_ramificationIndex_mul_inertiaDeg_fiberOver {K F F' : Type*}
+    [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F'] [Algebra F F']
+    [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F'] (v : Place K F) :
+    ∑ w ∈ v.fiberOver F', (w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ) = (Module.finrank F F'
+      : ℤ) :=
+  solution v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_le_finrank.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_le_finrank.lean
new file mode 100644
index 0000000000..ef69a941d2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_le_finrank.lean
@@ -0,0 +1,487 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.sum_ramificationIndex_mul_inertiaDeg_le_finrank
+(4931a8fd-65e8-5b16-a93e-5c3a0bb8f3e0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 24b7d689-1b08-5513-9a91-c51f0acb1775
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_iff_ord_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_nonneg_of_mem
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Fundamental inequality sum_w e_w f_w ≤ [F':F]
+
+Theorem statement: `AlgebraicCurve.Place.sum_ramificationIndex_mul_inertiaDeg_le_finrank`
+(`4931a8fd-65e8-5b16-a93e-5c3a0bb8f3e0`), by Claude, 2026-09-05.
+
+Proof: submission `24b7d689-1b08-5513-9a91-c51f0acb1775`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K \subseteq F \subseteq F'$ be fields with compatible $K$-algebra structures forming a scalar
+tower, with $F'$ finite-dimensional over $F$ and $F'/F$ separable. Here a place of a field $L$ over
+$K$ is a valuation subring of $L$ that contains the image of $K$ under the structure map, is not all
+of $L$, and is a principal ideal ring; its residue field is the residue field of that local ring.
+Let $v$ be such a place of $F$ over $K$, and let $S$ be a finite set of places of $F'$ over $K$ such
+that every $w \in S$ restricts to $v$, the restriction of $w$ to $F$ being the place whose valuation
+subring is the preimage of that of $w$ under $\mathrm{algebraMap}\ F\ F'$. For $w \in S$, the
+ramification index $e(w \mid F)$ is the least $n > 0$ for which some nonzero $f \in F$ has
+$\mathrm{ord}_w(\mathrm{algebraMap}\ F\ F'\,f) = n$, and the inertia degree $f(w \mid F)$ is the
+degree of the residue field of $w$ over the residue field of its restriction to $F$. The conclusion
+is the inequality of integers $\sum_{w \in S} e(w \mid F)\, f(w \mid F) \le [F' : F]$.
+
+This is the fundamental inequality for places of a finite separable extension of function fields:
+any finite collection of places of $F'$ lying over a fixed place $v$ of $F$ contributes at most
+$[F':F]$ to the sum of the products of ramification index and inertia degree, with no requirement
+that the collection exhaust the fibre over $v$. It is used to show that a place over $v$ is unique
+once a partial sum already attains $[F':F]$, and in this form feeds the counting of cusps and of
+poles of modular functions on $X_0(\ell)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_le_finrank.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_le_finrank
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.subset_fiberOver_of_forall_restrict_eq Place"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "mem_maximalIdeal_iff_ord_pos center integralClosureAt \
+  algebraMap_integralClosureAt_injective maximalIdeal_ne_bot forall_mem_of_restrict_eq fiberCenter \
+  mem_fiberCenter_iff_ord_pos toValuationSubring_eq_of_restrict_eq \
+  algebraMap_integralClosureAt_ne_zero ord_algebraMap_integralClosureAt fiberCenter_liesOver \
+  placeOfPrime restrict_placeOfPrime fiberCenter_placeOfPrime eq_of_fiberCenter_eq fiberOver \
+  mem_fiberOver subset_fiberOver_of_forall_restrict_eq ramificationIndex ramificationIndex_pos \
+  restrict restrictInclusion restrictResidueMap inertiaDeg fiber ext ResidueField ord ord_mul \
+  ord_inv ord_coe_irreducible ord_zpow toValuationSubring mk mem_iff_ord_nonneg ord_nonneg_of_mem"
+p2m_open "AlgebraicCurve.Place"
+
+section Uniqueness
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+private theorem eq_ord_of_addHom_of_nonneg_iff (φ : F → ℤ)
+    (hmul : ∀ x y, x ≠ 0 → y ≠ 0 → φ (x * y) = φ x + φ y)
+    (hone : ∃ t, t ≠ 0 ∧ φ t = 1)
+    (hiff : ∀ x, x ≠ 0 → (0 ≤ φ x ↔ x ∈ w.toValuationSubring))
+    {x : F} (hx : x ≠ 0) : φ x = w.ord x := by
+  obtain ⟨t, ht0, ht1⟩ := hone
+  have hφ1 : φ 1 = 0 := by
+    have := hmul 1 1 one_ne_zero one_ne_zero
+    rw [mul_one] at this
+    omega
+  have hinv : ∀ y, y ≠ 0 → φ y⁻¹ = -φ y := by
+    intro y hy
+    have h1 : φ (y * y⁻¹) = φ y + φ y⁻¹ := hmul y y⁻¹ hy (inv_ne_zero hy)
+    rw [mul_inv_cancel₀ hy, hφ1] at h1
+    omega
+  have hpow : ∀ (y : F), y ≠ 0 → ∀ m : ℕ, φ (y ^ m) = m * φ y := by
+    intro y hy m
+    induction m with
+    | zero => simpa using hφ1
+    | succ m ih =>
+      rw [pow_succ, hmul _ _ (pow_ne_zero _ hy) hy, ih]
+      push_cast
+      ring
+  have hzpow : ∀ (y : F) (n : ℤ), y ≠ 0 → φ (y ^ n) = n * φ y := by
+    intro y n hy
+    rcases n with m | m
+    · simpa using hpow y hy m
+    · rw [zpow_negSucc, hinv _ (pow_ne_zero _ hy), hpow y hy, Int.negSucc_eq]
+      push_cast
+      ring
+  have hsign : ∀ y, y ≠ 0 → (0 ≤ φ y ↔ 0 ≤ w.ord y) := by
+    intro y hy
+    rw [hiff y hy, w.mem_iff_ord_nonneg hy]
+  have hzero : ∀ y, y ≠ 0 → (φ y = 0 ↔ w.ord y = 0) := by
+    intro y hy
+    have h1 := hsign y hy
+    have h2 := hsign y⁻¹ (inv_ne_zero hy)
+    rw [hinv y hy, w.ord_inv] at h2
+    omega
+  have htord : 0 < w.ord t := by
+    have h1 := (hsign t ht0).mp (by omega)
+    have h2 := (hzero t ht0).not.mp (by omega)
+    omega
+  have hcancel : ∀ y, y ≠ 0 → w.ord y = φ y * w.ord t := by
+    intro y hy
+    have hyt : y * t ^ (-(φ y)) ≠ 0 := mul_ne_zero hy (zpow_ne_zero _ ht0)
+    have h1 : φ (y * t ^ (-(φ y))) = 0 := by
+      rw [hmul _ _ hy (zpow_ne_zero _ ht0), hzpow t _ ht0, ht1]
+      ring
+    have h2 : w.ord (y * t ^ (-(φ y))) = 0 := (hzero _ hyt).mp h1
+    rw [w.ord_mul hy (zpow_ne_zero _ ht0), w.ord_zpow] at h2
+    linarith
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  have hπ0 : (π : F) ≠ 0 := by
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have hπcancel := hcancel (π : F) hπ0
+  rw [w.ord_coe_irreducible hπ] at hπcancel
+  have htord1 : w.ord t = 1 := by
+    have hdvd : w.ord t ∣ 1 := ⟨φ (π : F), by linarith⟩
+    have := Int.le_of_dvd one_pos hdvd
+    omega
+  have := hcancel x hx
+  rw [htord1, mul_one] at this
+  exact this.symm
+
+end Uniqueness
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+section ValuationDictionary
+
+variable {v : Place K F} {w : Place K F'}
+
+private theorem neg_log_valuation_fiberCenter_eq_ord (hw : w.restrict F = v) {x : F'} (hx : x ≠ 0) :
+    -log ((fiberCenter F' v hw).valuation F' x) = w.ord x := by
+  refine eq_ord_of_addHom_of_nonneg_iff w
+    (fun y => -log ((fiberCenter F' v hw).valuation F' y)) ?_ ?_ ?_ hx
+  · intro a b ha hb
+    show -log ((fiberCenter F' v hw).valuation F' (a * b)) =
+      -log ((fiberCenter F' v hw).valuation F' a) +
+        -log ((fiberCenter F' v hw).valuation F' b)
+    rw [map_mul, log_mul ((Valuation.ne_zero_iff _).mpr ha) ((Valuation.ne_zero_iff _).mpr hb)]
+    ring
+  · obtain ⟨t, ht⟩ := (fiberCenter F' v hw).valuation_exists_uniformizer F'
+    refine ⟨t, ?_, ?_⟩
+    · intro h
+      rw [h, map_zero] at ht
+      exact exp_ne_zero ht.symm
+    · show -log ((fiberCenter F' v hw).valuation F' t) = 1
+      rw [ht, log_exp]
+      ring
+  · intro y hy
+    have hy0 : (fiberCenter F' v hw).valuation F' y ≠ 0 := (Valuation.ne_zero_iff _).mpr hy
+    change 0 ≤ -log ((fiberCenter F' v hw).valuation F' y) ↔ y ∈ w.toValuationSubring
+    have hmem : y ∈ w.toValuationSubring ↔ (fiberCenter F' v hw).valuation F' y ≤ 1 := by
+      rw [toValuationSubring_eq_of_restrict_eq hw,
+        HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact Iff.rfl
+    rw [hmem]
+    constructor
+    · intro h
+      calc (fiberCenter F' v hw).valuation F' y
+          = exp (log ((fiberCenter F' v hw).valuation F' y)) := (exp_log hy0).symm
+        _ ≤ exp 0 := by rw [exp_le_exp]; omega
+        _ = 1 := exp_zero
+    · intro h
+      have h1 : exp (log ((fiberCenter F' v hw).valuation F' y)) ≤ exp 0 := by
+        rw [exp_log hy0, exp_zero]
+        exact h
+      rw [exp_le_exp] at h1
+      omega
+
+private theorem le_ord_iff_mem_pow_fiberCenter (hw : w.restrict F = v)
+    {c : integralClosureAt F' v} (hc : c ≠ 0) (n : ℕ) :
+    (n : ℤ) ≤ w.ord (algebraMap (integralClosureAt F' v) F' c) ↔
+      c ∈ (fiberCenter F' v hw).asIdeal ^ n := by
+  have hcF : algebraMap (integralClosureAt F' v) F' c ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hc
+  rw [← neg_log_valuation_fiberCenter_eq_ord hw hcF,
+    HeightOneSpectrum.valuation_of_algebraMap,
+    ← HeightOneSpectrum.intValuation_le_pow_iff_mem]
+  have h0 : (fiberCenter F' v hw).intValuation c ≠ 0 :=
+    HeightOneSpectrum.intValuation_ne_zero _ c hc
+  constructor
+  · intro h
+    calc (fiberCenter F' v hw).intValuation c
+        = exp (log ((fiberCenter F' v hw).intValuation c)) := (exp_log h0).symm
+      _ ≤ exp (-(n : ℤ)) := by rw [exp_le_exp]; omega
+  · intro h
+    have h1 : exp (log ((fiberCenter F' v hw).intValuation c)) ≤ exp (-(n : ℤ)) := by
+      rw [exp_log h0]
+      exact h
+    rw [exp_le_exp] at h1
+    omega
+
+private theorem ramificationIndex_eq_ramificationIdx_fiberCenter (hw : w.restrict F = v) :
+    w.ramificationIndex F =
+      (IsLocalRing.maximalIdeal v.toValuationSubring).ramificationIdx'
+        (fiberCenter F' v hw).asIdeal := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπ0 : π ≠ 0 := hπ.ne_zero
+  have hπC : algebraMap v.toValuationSubring (integralClosureAt F' v) π ≠ 0 :=
+    algebraMap_integralClosureAt_ne_zero hπ0
+  have hmap : (IsLocalRing.maximalIdeal v.toValuationSubring).map
+      (algebraMap v.toValuationSubring (integralClosureAt F' v))
+        = Ideal.span {algebraMap v.toValuationSubring (integralClosureAt F' v) π} := by
+    rw [hπ.maximalIdeal_eq, Ideal.map_span, Set.image_singleton]
+  have hord : w.ord (algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) π))
+        = w.ramificationIndex F := by
+    rw [ord_algebraMap_integralClosureAt hw, ValuationSubring.algebraMap_apply,
+      v.ord_coe_irreducible hπ, mul_one]
+  refine (Ideal.ramificationIdx'_spec ?_ ?_).symm
+  · rw [hmap, Ideal.span_singleton_le_iff_mem,
+      ← le_ord_iff_mem_pow_fiberCenter hw hπC, hord]
+  · rw [hmap, Ideal.span_singleton_le_iff_mem,
+      ← le_ord_iff_mem_pow_fiberCenter hw hπC, hord]
+    have : 0 < w.ramificationIndex F := w.ramificationIndex_pos
+    push_cast
+    omega
+
+end ValuationDictionary
+
+section ResidueDictionary
+
+variable {v : Place K F} {w : Place K F'}
+
+private def toValuationSubringOfRestrictEq (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.toValuationSubring :=
+  (algebraMap (integralClosureAt F' v) F').codRestrict
+    w.toValuationSubring.toSubring (forall_mem_of_restrict_eq hw)
+
+omit [FiniteDimensional F F'] in
+@[scoped simp]
+private theorem coe_toValuationSubringOfRestrictEq (hw : w.restrict F = v)
+    (c : integralClosureAt F' v) :
+    (toValuationSubringOfRestrictEq hw c : F')
+      = algebraMap (integralClosureAt F' v) F' c := rfl
+
+private def residueOfCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.ResidueField :=
+  (IsLocalRing.residue w.toValuationSubring).comp (toValuationSubringOfRestrictEq hw)
+
+omit [FiniteDimensional F F'] in
+private theorem residueOfCenter_apply (hw : w.restrict F = v) (c : integralClosureAt F' v) :
+    residueOfCenter hw c = IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw c) := rfl
+
+private theorem ker_residueOfCenter (hw : w.restrict F = v) :
+    RingHom.ker (residueOfCenter hw) = (fiberCenter F' v hw).asIdeal := by
+  ext c
+  rw [RingHom.mem_ker, residueOfCenter_apply, IsLocalRing.residue_eq_zero_iff]
+  exact Iff.rfl
+
+private theorem surjective_residueOfCenter (hw : w.restrict F = v) :
+    Function.Surjective (residueOfCenter hw) := by
+  classical
+  intro y
+  obtain ⟨x, rfl⟩ := IsLocalRing.residue_surjective y
+  have hx : (x : F') ∈ HeightOneSpectrum.valuationSubringAtPrime F' (fiberCenter F' v hw) := by
+    rw [← toValuationSubring_eq_of_restrict_eq hw]
+    exact x.2
+  obtain ⟨a, s, hs, hxas⟩ := hx
+  have hsP : s ∉ (fiberCenter F' v hw).asIdeal := hs
+  have hs0 : s ≠ 0 := fun h => hsP (h ▸ (fiberCenter F' v hw).asIdeal.zero_mem)
+  have hsF : algebraMap (integralClosureAt F' v) F' s ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hs0
+  have hsord : w.ord (algebraMap (integralClosureAt F' v) F' s) = 0 := by
+    have h1 : ¬ 0 < w.ord (algebraMap (integralClosureAt F' v) F' s) := by
+      rw [← mem_fiberCenter_iff_ord_pos hw hs0]
+      exact hsP
+    have h2 : 0 ≤ w.ord (algebraMap (integralClosureAt F' v) F' s) :=
+      w.ord_nonneg_of_mem (forall_mem_of_restrict_eq hw s)
+    omega
+  have hmax : (fiberCenter F' v hw).asIdeal.IsMaximal :=
+    (fiberCenter F' v hw).isPrime.isMaximal (fiberCenter F' v hw).ne_bot
+  obtain ⟨t, i, hi, hti⟩ := hmax.exists_inv hsP
+  have hst : s * t - 1 ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : s * t - 1 = -i := by linear_combination hti
+    rw [h1]
+    exact neg_mem hi
+  refine ⟨a * t, ?_⟩
+  rw [residueOfCenter_apply, ← sub_eq_zero, ← map_sub, IsLocalRing.residue_eq_zero_iff]
+  have hcoe : ((toValuationSubringOfRestrictEq hw (a * t) - x : w.toValuationSubring) : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') := rfl
+  rcases eq_or_ne (toValuationSubringOfRestrictEq hw (a * t) - x) 0 with hzero | hne
+  · rw [hzero]
+    exact (IsLocalRing.maximalIdeal w.toValuationSubring).zero_mem
+  have hcoene : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') ≠ 0 := by
+    intro h
+    exact hne (by rwa [← hcoe, ZeroMemClass.coe_eq_zero] at h)
+  have hfactor : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t * s - a)
+          * (algebraMap (integralClosureAt F' v) F' s)⁻¹ := by
+    rw [hxas, map_sub, map_mul (algebraMap (integralClosureAt F' v) F') (a * t) s,
+      sub_mul, mul_assoc, mul_inv_cancel₀ hsF, mul_one]
+  have hdiffC : a * t * s - a ≠ 0 := by
+    intro h
+    apply hcoene
+    rw [hfactor, h, map_zero, zero_mul]
+  have hdiffP : a * t * s - a ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : a * t * s - a = a * (s * t - 1) := by ring
+    rw [h1]
+    exact Ideal.mul_mem_left _ _ hst
+  have hmem' : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      ∈ w.toValuationSubring := by
+    rw [← hcoe]
+    exact Subtype.coe_prop _
+  rw [show (toValuationSubringOfRestrictEq hw (a * t) - x)
+      = (⟨_, hmem'⟩ : w.toValuationSubring) from Subtype.ext hcoe,
+    w.mem_maximalIdeal_iff_ord_pos hcoene hmem']
+  rw [hfactor, w.ord_mul (by
+      simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hdiffC)
+    (inv_ne_zero hsF), w.ord_inv, hsord, neg_zero, add_zero]
+  exact (mem_fiberCenter_iff_ord_pos hw hdiffC).mp hdiffP
+
+private def residueFieldEquivQuotientCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v ⧸ (fiberCenter F' v hw).asIdeal ≃+* w.ResidueField :=
+  (Ideal.quotEquivOfEq (ker_residueOfCenter hw).symm).trans
+    ((residueOfCenter hw).quotientKerEquivOfSurjective (surjective_residueOfCenter hw))
+
+private theorem residueFieldEquivQuotientCenter_mk (hw : w.restrict F = v)
+    (c : integralClosureAt F' v) :
+    residueFieldEquivQuotientCenter hw (Ideal.Quotient.mk _ c) = residueOfCenter hw c := by
+  change ((residueOfCenter hw).quotientKerEquivOfSurjective (surjective_residueOfCenter hw))
+    ((Ideal.quotEquivOfEq (ker_residueOfCenter hw).symm) (Ideal.Quotient.mk _ c))
+      = residueOfCenter hw c
+  rw [Ideal.quotEquivOfEq_mk]
+  exact RingHom.quotientKerEquivOfSurjective_apply_mk _ c
+
+private def placeCongrEquiv {u u' : Place K F} (h : u = u') :
+    u.toValuationSubring ≃+* u'.toValuationSubring where
+  toFun x := ⟨x.1, h ▸ x.2⟩
+  invFun x := ⟨x.1, h.symm ▸ x.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  map_mul' _ _ := rfl
+  map_add' _ _ := rfl
+
+@[scoped simp]
+private theorem coe_placeCongrEquiv {u u' : Place K F} (h : u = u') (x : u.toValuationSubring) :
+    (placeCongrEquiv h x : F) = (x : F) := rfl
+
+private def restrictResidueFieldEquiv (hw : w.restrict F = v) :
+    (w.restrict F).ResidueField ≃+* IsLocalRing.ResidueField v.toValuationSubring :=
+  IsLocalRing.ResidueField.mapEquiv (placeCongrEquiv hw)
+
+omit [FiniteDimensional F F'] in
+private theorem restrictResidueFieldEquiv_residue (hw : w.restrict F = v)
+    (a : (w.restrict F).toValuationSubring) :
+    restrictResidueFieldEquiv hw (IsLocalRing.residue _ a)
+      = IsLocalRing.residue _ (placeCongrEquiv hw a) := by
+  simp only [restrictResidueFieldEquiv, IsLocalRing.ResidueField.mapEquiv_apply,
+    IsLocalRing.ResidueField.map_residue, RingEquiv.coe_toRingHom]
+
+private theorem inertiaDeg_eq_inertiaDeg_fiberCenter (hw : w.restrict F = v) :
+    w.inertiaDeg F =
+      (fiberCenter F' v hw).asIdeal.inertiaDeg v.toValuationSubring := by
+  have := fiberCenter_liesOver hw
+  rw [Ideal.inertiaDeg_eq_of_isMaximal (IsLocalRing.maximalIdeal v.toValuationSubring)
+    (fiberCenter F' v hw).asIdeal]
+  change Module.finrank (w.restrict F).ResidueField w.ResidueField = _
+  refine Algebra.finrank_eq_of_equiv_equiv (restrictResidueFieldEquiv hw)
+    (residueFieldEquivQuotientCenter hw).symm ?_
+  ext a
+  obtain ⟨a, rfl⟩ := IsLocalRing.residue_surjective a
+  simp only [RingHom.coe_comp, Function.comp_apply, RingEquiv.toRingHom_eq_coe,
+    RingHom.coe_coe]
+  apply (residueFieldEquivQuotientCenter hw).injective
+  rw [RingEquiv.apply_symm_apply]
+  change IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw
+        (algebraMap v.toValuationSubring (integralClosureAt F' v) (placeCongrEquiv hw a)))
+    = IsLocalRing.residue w.toValuationSubring (restrictInclusion F w a)
+  refine congrArg _ (Subtype.ext ?_)
+  change algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) (placeCongrEquiv hw a))
+    = algebraMap F F' (a : F)
+  rw [← IsScalarTower.algebraMap_apply,
+    IsScalarTower.algebraMap_apply v.toValuationSubring F F']
+  rfl
+
+end ResidueDictionary
+
+section Assembly
+
+variable (v : Place K F)
+
+private theorem sum_ramificationIndex_mul_inertiaDeg_fiberOver :
+    ∑ w ∈ v.fiberOver F', (w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ)
+      = (Module.finrank F F' : ℤ) := by
+  classical
+  have hkey := sum_ramificationIdx'_mul_inertiaDeg'_integralClosureAt (F' := F') v
+  rw [← hkey]
+  push_cast
+  refine Finset.sum_bij
+    (fun w hw => (fiberCenter F' v ((mem_fiberOver v).mp hw)).asIdeal) ?_ ?_ ?_ ?_
+  · intro w hw
+    rw [IsDedekindDomain.mem_primesOverFinset_iff (maximalIdeal_ne_bot v)]
+    exact ⟨(fiberCenter F' v ((mem_fiberOver v).mp hw)).isPrime,
+      fiberCenter_liesOver ((mem_fiberOver v).mp hw)⟩
+  · intro w hw w' hw' h
+    exact eq_of_fiberCenter_eq ((mem_fiberOver v).mp hw) ((mem_fiberOver v).mp hw')
+      (HeightOneSpectrum.ext h)
+  · intro P hP
+    rw [IsDedekindDomain.mem_primesOverFinset_iff (maximalIdeal_ne_bot v)] at hP
+    obtain ⟨hP1, hP2⟩ := hP
+    have hPne : P ≠ ⊥ := by
+      intro h
+      apply maximalIdeal_ne_bot v
+      have h2 := hP2.over
+      rw [h, Ideal.under_def, Ideal.comap_bot_of_injective _
+        (algebraMap_integralClosureAt_injective v)] at h2
+      exact h2
+    refine ⟨placeOfPrime ⟨P, hP1, hPne⟩,
+      (mem_fiberOver v).mpr (restrict_placeOfPrime ⟨P, hP1, hPne⟩), ?_⟩
+    exact congrArg HeightOneSpectrum.asIdeal
+      (fiberCenter_placeOfPrime (⟨P, hP1, hPne⟩ :
+        HeightOneSpectrum (integralClosureAt F' v)))
+  · intro w hw
+    rw [ramificationIndex_eq_ramificationIdx_fiberCenter ((mem_fiberOver v).mp hw),
+      inertiaDeg_eq_inertiaDeg_fiberCenter ((mem_fiberOver v).mp hw)]
+
+end Assembly
+
+end Place
+end AlgebraicCurve
+end
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_le_finrank.AlgebraicCurve"
+
+theorem solution {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+    [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+    (v : Place K F) (S : Finset (Place K F'))
+    (hS : ∀ w ∈ S, w.restrict F = v) :
+    ∑ w ∈ S, (w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ) ≤ (Module.finrank F F' : ℤ) :=
+  le_of_le_of_eq
+    (Finset.sum_le_sum_of_subset_of_nonneg (Place.subset_fiberOver_of_forall_restrict_eq v hS)
+      (fun _ _ _ => mul_nonneg (Int.natCast_nonneg _) (Int.natCast_nonneg _)))
+    (Place.sum_ramificationIndex_mul_inertiaDeg_fiberOver v)
+
+end S_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_le_finrank
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_le_finrank (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.Place.sum_ramificationIndex_mul_inertiaDeg_le_finrank {K F F' : Type*}
+    [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F'] [Algebra F F']
+    [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F'] (v : Place K F)
+    (S : Finset (Place K F'))
+    (hS : ∀ w ∈ S, w.restrict F = v) :
+    ∑ w ∈ S, (w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ) ≤ (Module.finrank F F' : ℤ) :=
+  solution v S hS
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_transcendental_of_ord_ne_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_transcendental_of_ord_ne_zero.lean
new file mode 100644
index 0000000000..02a237ec7c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_Place_transcendental_of_ord_ne_zero.lean
@@ -0,0 +1,115 @@
+/-
+Based on Prove2Me node AlgebraicCurve.Place.transcendental_of_ord_ne_zero
+(5d81da8b-db85-502b-a949-6ed3c5d7e14b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 67fcf48c-809d-5694-b149-3dcbae67a50d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import Mathlib.RingTheory.Algebraic.Defs
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import Mathlib.RingTheory.Algebraic.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Nonzero order at a place forces transcendence
+
+Theorem statement: `AlgebraicCurve.Place.transcendental_of_ord_ne_zero`
+(`5d81da8b-db85-502b-a949-6ed3c5d7e14b`), by Claude, 2026-09-05.
+
+Proof: submission `67fcf48c-809d-5694-b149-3dcbae67a50d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+sense of the project's structure `Place`: a valuation subring $\mathcal{O}_v \subseteq F$ which
+contains the image of $K$ under the structure map, is not the whole of $F$, and is a principal ideal
+ring. For $f \in F$ the integer $v.\mathrm{ord}\,f$ is defined as the negative of the logarithm of
+the value of $f$ under the adic valuation of $F$ attached to the height-one prime of
+$\mathcal{O}_v$, with values in $\mathbb{Z}^{m0}$. The assertion is that for $t \in F$ with
+$v.\mathrm{ord}\,t \neq 0$, the element $t$ is transcendental over $K$, i.e. `Transcendental K t`
+holds: $t$ is not a root of any nonzero polynomial with coefficients in $K$. No hypothesis is
+imposed on the extension $F/K$ beyond those packaged in `Place`, and no assumption on the
+characteristic is made.
+
+This is the contrapositive of the classical fact that elements algebraic over the constant field
+have neither zeros nor poles, so order zero at every place; in particular a uniformiser, having
+order $1$, is transcendental over $K$. It is used throughout the surrounding theory of places,
+divisors and differentials of a curve, for instance when exhibiting transcendental elements with
+prescribed residue behaviour and when comparing regular differentials under a constant field
+extension.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_transcendental_of_ord_ne_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_transcendental_of_ord_ne_zero
+
+noncomputable section
+open Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.mem_of_eval_monic_eq_zero Place"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "mem_of_eval_monic_eq_zero ext ord ord_zero ord_coe_unit \
+  algebraMap_mem' toValuationSubring"
+namespace FF2R0
+p2m_open "AlgebraicCurve.Place AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : AlgebraicCurve.Place K F)
+
+private theorem mem_of_isAlgebraic {x : F} (hx : IsAlgebraic K x) : x ∈ v.toValuationSubring := by
+  have hint : IsIntegral K x := hx.isIntegral
+  refine v.mem_of_eval_monic_eq_zero (P := (minpoly K x).map (algebraMap K F)) ((minpoly.monic
+    hint).map _)
+    (fun i => ?_) ?_
+  · rw [coeff_map]; exact v.algebraMap_mem' _
+  · rw [eval_map_algebraMap, minpoly.aeval]
+
+theorem ord_eq_zero_of_isAlgebraic' {x : F} (hx : IsAlgebraic K x) : v.ord x = 0 := by
+  by_cases hx0 : x = 0
+  · simp [hx0, v.ord_zero]
+  · let u : v.toValuationSubringˣ :=
+      { val := ⟨x, mem_of_isAlgebraic v hx⟩
+        inv := ⟨x⁻¹, mem_of_isAlgebraic v hx.inv⟩
+        val_inv := Subtype.ext (mul_inv_cancel₀ hx0)
+        inv_val := Subtype.ext (inv_mul_cancel₀ hx0) }
+    exact v.ord_coe_unit u
+
+end AlgebraicCurve.Place.FF2R0
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : AlgebraicCurve.Place K F)
+    {t : F} (ht : v.ord t ≠ 0) :
+    Transcendental K t :=
+  fun h => ht (AlgebraicCurve.Place.FF2R0.ord_eq_zero_of_isAlgebraic' v h)
+
+end
+
+end S_AlgebraicCurve_Place_transcendental_of_ord_ne_zero
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_transcendental_of_ord_ne_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.Place.transcendental_of_ord_ne_zero {K F : Type*} [Field K] [Field F]
+    [Algebra K F] (v : AlgebraicCurve.Place K F) {t : F} (ht : v.ord t ≠ 0) :
+    Transcendental K t :=
+  solution v ht
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_forall_ne_ofHeightOneSpectrum.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_forall_ne_ofHeightOneSpectrum.lean
new file mode 100644
index 0000000000..fe22770bc6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_forall_ne_ofHeightOneSpectrum.lean
@@ -0,0 +1,195 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.RationalFunctionField.deg_eq_one_of_forall_ne_ofHeightOneSpectrum
+(b6d8765a-04bc-52eb-8cf3-5bdc073cf866) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3628b5d2-e5eb-58c7-9f12-396ee2671750
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_toValuationSubring_eq_of_forall_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The place at infinity of K(t) has degree one
+
+Theorem statement:
+`AlgebraicCurve.RationalFunctionField.deg_eq_one_of_forall_ne_ofHeightOneSpectrum`
+(`b6d8765a-04bc-52eb-8cf3-5bdc073cf866`), by Claude, 2026-09-05.
+
+Proof: submission `3628b5d2-e5eb-58c7-9f12-396ee2671750`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $v$ be a place of the rational function field $\mathrm{RatFunc}\,K$ over
+$K$ in the sense of the project's structure `Place`: a valuation subring of $\mathrm{RatFunc}\,K$
+which contains the image of $K$ under the structure map, is not the whole field, and is a principal
+ideal ring. Assume that $v$ differs from `Place.ofHeightOneSpectrum w` for every $w$ in the
+height-one spectrum of the polynomial ring $K[X]$, that is, $v$ is not the place whose valuation
+subring is the valuation subring of the $w$-adic valuation of $\mathrm{RatFunc}\,K$ attached to a
+nonzero prime ideal $w$ of $K[X]$. Then $v.\mathrm{deg} = 1$, where $v.\mathrm{deg}$ is defined as
+the $K$-dimension $\operatorname{finrank}_K$ of the residue field of the local ring
+$v.\mathrm{toValuationSubring}$; equivalently, the structure map $K \to \kappa(v)$ is an
+isomorphism.
+
+This is the classical computation that the place at infinity of the rational function field $K(t)$ —
+the unique place of $K(t)/K$ that is not one of the finite places coming from the nonzero primes of
+$K[X]$ — has residue degree one, the residue field being $K$ itself. It feeds the degree theory of
+divisors on the rational function field and is used by the statements that places have nonzero
+degree, that the place at infinity has degree one, and that divisors built from orders at the finite
+places have degree zero.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_forall_ne_ofHeightOneSpectrum.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_forall_ne_ofHeightOneSpectrum
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_forall_ne_ofHeightOneSpectrum.Algebraic\
+  Curve"
+open IsDedekindDomain WithZero IsLocalRing
+open scoped Polynomial
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.deg Place.ofHeightOneSpectrum \
+  RationalFunctionField.toValuationSubring_eq_of_forall_ne_ofHeightOneSpectrum \
+  Place.mem_maximalIdeal_iff_adicValuation_lt_one"
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "toValuationSubring_eq_of_forall_ne_ofHeightOneSp\
+  ectrum"
+p2m_open "AlgebraicCurve.RationalFunctionField AlgebraicCurve"
+
+namespace WFg
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+
+theorem exists_sub_algebraMap_intDegree_neg {x : RatFunc K}
+    (hx : RatFunc.inftyValuation K x ≤ 1) :
+    ∃ c : K, x - algebraMap K (RatFunc K) c = 0 ∨
+      (x - algebraMap K (RatFunc K) c).intDegree < 0 := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · exact ⟨0, Or.inl (by simp)⟩
+  have hdeg : x.intDegree ≤ 0 := by
+    rw [RatFunc.inftyValuation_apply, RatFunc.inftyValuation_of_nonzero K hx0,
+      show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_le_exp] at hx
+    exact hx
+  have hnum0 : x.num ≠ 0 := RatFunc.num_ne_zero hx0
+  have hden0 : x.denom ≠ 0 := x.denom_ne_zero
+  rcases lt_or_eq_of_le hdeg with hlt | heq
+  · exact ⟨0, Or.inr (by simpa using hlt)⟩
+  have hndeg : x.num.natDegree = x.denom.natDegree := by
+    have h2 := heq
+    rw [RatFunc.intDegree, sub_eq_zero] at h2
+    exact_mod_cast h2
+  set c : K := x.num.leadingCoeff / x.denom.leadingCoeff with hc
+  have hc0 : c ≠ 0 := by
+    rw [hc]
+    exact div_ne_zero (Polynomial.leadingCoeff_ne_zero.mpr hnum0)
+      (Polynomial.leadingCoeff_ne_zero.mpr hden0)
+  refine ⟨c, ?_⟩
+  have hsub : x - algebraMap K (RatFunc K) c
+      = algebraMap K[X] (RatFunc K) (x.num - Polynomial.C c * x.denom)
+        / algebraMap K[X] (RatFunc K) x.denom := by
+    rw [map_sub, map_mul, sub_div, x.num_div_denom, mul_div_assoc,
+      div_self ((map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hden0),
+      mul_one, IsScalarTower.algebraMap_apply K K[X] (RatFunc K), Polynomial.algebraMap_eq]
+  rcases eq_or_ne (x.num - Polynomial.C c * x.denom) 0 with hzero | hnz
+  · exact Or.inl (by rw [hsub, hzero, map_zero, zero_div])
+  refine Or.inr ?_
+  rw [hsub, RatFunc.intDegree_div ((map_ne_zero_iff _
+      (IsFractionRing.injective K[X] (RatFunc K))).mpr hnz)
+    ((map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hden0),
+    RatFunc.intDegree_polynomial, RatFunc.intDegree_polynomial, sub_neg]
+  have hCdeg : (Polynomial.C c * x.denom).degree = x.denom.degree := by
+    rw [Polynomial.degree_mul, Polynomial.degree_C hc0, zero_add]
+  have hdegeq : x.num.degree = (Polynomial.C c * x.denom).degree := by
+    rw [hCdeg, Polynomial.degree_eq_natDegree hnum0, Polynomial.degree_eq_natDegree hden0,
+      hndeg]
+  have hlc : x.num.leadingCoeff = (Polynomial.C c * x.denom).leadingCoeff := by
+    rw [Polynomial.leadingCoeff_mul, Polynomial.leadingCoeff_C, hc,
+      div_mul_cancel₀ _ (Polynomial.leadingCoeff_ne_zero.mpr hden0)]
+  have hlt := Polynomial.degree_sub_lt_left hdegeq hnum0 hlc
+  rw [hdegeq, hCdeg] at hlt
+  exact_mod_cast Polynomial.natDegree_lt_natDegree hnz hlt
+
+end WFg
+
+end AlgebraicCurve.RationalFunctionField
+
+end
+
+theorem solution {K : Type*} [Field K] (v : Place K (RatFunc K))
+    (hv : ∀ w : IsDedekindDomain.HeightOneSpectrum (Polynomial K), v ≠ Place.ofHeightOneSpectrum w)
+    :
+    v.deg = 1 := by
+  classical
+  have hvS : v.toValuationSubring = (RatFunc.inftyValuation K).valuationSubring :=
+    AlgebraicCurve.RationalFunctionField.toValuationSubring_eq_of_forall_ne_ofHeightOneSpectrum v hv
+  have hequiv : (RatFunc.inftyValuation K).IsEquiv v.adicValuation :=
+    v.isEquiv_adicValuation_of_valuationSubring_eq hvS.symm
+  have hbij : Function.Bijective (Algebra.ofId K v.ResidueField) := by
+    constructor
+    · exact fun a b h => (algebraMap K v.ResidueField).injective h
+    · intro y
+      obtain ⟨⟨x, hx⟩, rfl⟩ := IsLocalRing.residue_surjective y
+      have hx' : RatFunc.inftyValuation K x ≤ 1 := by
+        rw [hvS] at hx
+        exact (Valuation.mem_valuationSubring_iff _ _).mp hx
+      obtain ⟨c, hc⟩ :=
+        AlgebraicCurve.RationalFunctionField.WFg.exists_sub_algebraMap_intDegree_neg K hx'
+      refine ⟨c, ?_⟩
+      change IsLocalRing.residue _ (algebraMap K v.toValuationSubring c) = _
+      rw [← sub_eq_zero, ← map_sub, IsLocalRing.residue_eq_zero_iff,
+        Place.mem_maximalIdeal_iff_adicValuation_lt_one]
+      change v.adicValuation (algebraMap K (RatFunc K) c - x) < 1
+      rw [← hequiv.lt_one_iff_lt_one,
+        show algebraMap K (RatFunc K) c - x = -(x - algebraMap K (RatFunc K) c) from
+          (neg_sub _ _).symm, Valuation.map_neg]
+      rcases hc with hc | hc
+      · rw [hc, map_zero]
+        exact zero_lt_one
+      · rw [RatFunc.inftyValuation_apply, RatFunc.inftyValuationDef]
+        split
+        · exact zero_lt_one
+        · rw [show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_lt_exp]
+          exact hc
+  rw [Place.deg, ← (AlgEquiv.ofBijective _ hbij).toLinearEquiv.finrank_eq,
+    Module.finrank_self]
+
+end S_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_forall_ne_ofHeightOneSpectrum
+end P2MW
+export P2MW.S_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_forall_ne_ofHeightOneSpectrum
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.RationalFunctionField.deg_eq_one_of_forall_ne_ofHeightOneSpectrum {K : Type*}
+    [Field K] (v : Place K (RatFunc K))
+    (hv : ∀ w : IsDedekindDomain.HeightOneSpectrum (Polynomial K), v ≠ Place.ofHeightOneSpectrum w)
+    :
+    v.deg = 1 :=
+  solution v hv
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_isAlgClosed.lean
new file mode 100644
index 0000000000..880de69980
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_isAlgClosed.lean
@@ -0,0 +1,1320 @@
+/-
+Based on Prove2Me node AlgebraicCurve.RationalFunctionField.deg_eq_one_of_isAlgClosed
+(60a99f71-0b86-5e70-95c3-986100d59d42) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1013d6e3-4110-504f-9cee-b141b6fdc2ce
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import Mathlib.FieldTheory.RatFunc.Degree
+import Mathlib.NumberTheory.RatFunc.Ostrowski
+import Mathlib.RingTheory.DedekindDomain.Factorization
+import Mathlib.FieldTheory.IsAlgClosed.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_of_ord_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_nonneg_of_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_eq_neg_log_of_valuationSubring_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_finite_setOf_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_hasPrincipalDivisors
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_of_span
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_subsingleton_setOf_forall_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_congr
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_inv
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_zpow
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_isRational_iff_deg_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_zsmul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_zpow_left
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_single_sub_single
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Places of K(t) over an algebraically closed K have degree one
+
+Theorem statement: `AlgebraicCurve.RationalFunctionField.deg_eq_one_of_isAlgClosed`
+(`60a99f71-0b86-5e70-95c3-986100d59d42`), by Claude, 2026-09-05.
+
+Proof: submission `1013d6e3-4110-504f-9cee-b141b6fdc2ce`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field and let $v$ be a place of the rational function field
+$\mathrm{RatFunc}\,K$ over $K$, that is, a structure consisting of a valuation subring
+$\mathcal{O}_v$ of $\mathrm{RatFunc}\,K$ together with the three conditions that $\mathcal{O}_v$
+contains $\mathrm{algebraMap}\,K\,(\mathrm{RatFunc}\,K)(a)$ for every $a \in K$, that
+$\mathcal{O}_v$ is not the whole field, and that $\mathcal{O}_v$ is a principal ideal ring. The
+assertion is that $v.\mathrm{deg} = 1$, where $v.\mathrm{deg}$ is defined as the $K$-rank
+$\mathrm{Module.finrank}\,K$ of the residue field $\mathcal{O}_v/\mathfrak{m}_v$ of the local ring
+$\mathcal{O}_v$, regarded as a $K$-vector space via the structure map. Equivalently, over an
+algebraically closed base field every place of $K(t)$ is rational: its residue field is
+one-dimensional over $K$, hence equal to the image of $K$.
+
+This is the classical statement that the places of the rational function field over an algebraically
+closed field $K$ are all of degree one, so that they correspond to the points of $\mathbb{P}^1(K)$
+and evaluation at a place takes values in $K$. It is used to deduce that every place of $K(t)$ is
+rational and, through that, in the proof of Weil reciprocity for the rational function field and its
+algebraically closed special case.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_isAlgClosed
+
+noncomputable section
+
+open Polynomial IsDedekindDomain WithZero IsLocalRing
+
+open scoped Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.mem_maximalIdeal_iff_adicValuation_lt_one \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff Place Place.ext Place.deg Place.ord_inv Divisor \
+  Divisor.degree Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring Place.evalAt \
+  Divisor.evalFun Divisor.evalFun_def Divisor.evalFun_zero \
+  RationalFunctionField.hasPrincipalDivisors Place.evalAt_congr Place.evalAt_algebraMap \
+  Place.isRational_iff_deg_eq_one Divisor.evalFun_add Divisor.evalFun_mul Divisor.evalFun_zsmul \
+  Divisor.evalFun_zpow_left Divisor.evalFun_single_sub_single"
+p2m_open "AlgebraicCurve"
+
+scoped instance {K : Type*} [Field K] : HasPrincipalDivisors K (RatFunc K) :=
+  RationalFunctionField.hasPrincipalDivisors K
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "adicValuation_valuationSubring \
+  isEquiv_adicValuation_of_valuationSubring_eq mem_maximalIdeal_iff_adicValuation_lt_one \
+  ord_ofHeightOneSpectrum_ne_zero_iff ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring algebraMap_mem' toValuationSubring \
+  IsRational evalAt mem_of_ord_nonneg ord_nonneg_of_mem ord_algebraMap \
+  ord_eq_neg_log_of_valuationSubring_eq evalAt_congr evalAt_algebraMap evalAt_mul evalAt_ne_zero \
+  evalAt_inv isRational_iff_deg_eq_one"
+p2m_open "AlgebraicCurve.Place~algebraMap_ne_zero"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+theorem isRational_of_deg_eq_one (h : v.deg = 1) : v.IsRational :=
+  (AlgebraicCurve.Place.isRational_iff_deg_eq_one v).2 h
+
+theorem deg_eq_one_of_isRational (hv : v.IsRational) : v.deg = 1 :=
+  (AlgebraicCurve.Place.isRational_iff_deg_eq_one v).1 hv
+
+end Place
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "heightOneSpectrumOfIrreducible \
+  heightOneSpectrumOfIrreducible_asIdeal exists_irreducible_span finitePlace finitePlace_def \
+  algebraMap_mem_ofHeightOneSpectrum deg_finitePlace placeOfPoint \
+  placeOfPoint_eq_ofHeightOneSpectrum placeOfPoint_injective deg_placeOfPoint placeInfty \
+  placeInfty_toValuationSubring finite_setOf_ord_ne_zero degree_eq_zero_of_forall_eq_ord \
+  hasPrincipalDivisors ord_ofHeightOneSpectrum_of_span"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable (K : Type*) [Field K]
+
+theorem ord_finitePlace_ne_zero_iff {p : K[X]} (hp : Irreducible p) {q : K[X]} (hq : q ≠ 0) :
+    (finitePlace K hp).ord (algebraMap K[X] (RatFunc K) q) ≠ 0 ↔ p ∣ q := by
+  rw [finitePlace, Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) _ hq,
+    heightOneSpectrumOfIrreducible_asIdeal, Ideal.mem_span_singleton]
+
+section PlaceInfty
+
+variable [DecidableEq (RatFunc K)]
+
+theorem inftyValuation_isEquiv_adicValuation :
+    (RatFunc.inftyValuation K).IsEquiv (placeInfty K).adicValuation :=
+  (placeInfty K).isEquiv_adicValuation_of_valuationSubring_eq rfl
+
+theorem placeInfty_ne_ofHeightOneSpectrum (w : HeightOneSpectrum K[X]) :
+    placeInfty K ≠ Place.ofHeightOneSpectrum w := by
+  intro h
+  refine RatFunc.adicValuation_not_isEquiv_infty_valuation w
+    ((Valuation.isEquiv_iff_valuationSubring _ _).mpr ?_)
+  have h2 := congrArg Place.toValuationSubring h
+  rw [placeInfty_toValuationSubring, Place.ofHeightOneSpectrum_toValuationSubring] at h2
+  exact h2.symm
+
+end PlaceInfty
+
+variable {K}
+
+theorem eq_ofHeightOneSpectrum_or_eq_placeInfty [DecidableEq (RatFunc K)]
+    (v : Place K (RatFunc K)) :
+    (∃ w : HeightOneSpectrum K[X], v = Place.ofHeightOneSpectrum w) ∨ v = placeInfty K := by
+  rcases (RatFunc.valuation_isEquiv_infty_or_adic (v := v.adicValuation)).or with h | h
+  · exact Or.inr (Place.ext (v.adicValuation_valuationSubring.symm.trans
+      ((Valuation.isEquiv_iff_valuationSubring _ _).mp h)))
+  · obtain ⟨w, hw, -⟩ := h
+    exact Or.inl ⟨w, Place.ext (v.adicValuation_valuationSubring.symm.trans
+      ((Valuation.isEquiv_iff_valuationSubring _ _).mp hw))⟩
+
+section DegInfty
+
+variable (K) [DecidableEq (RatFunc K)]
+
+theorem exists_sub_algebraMap_intDegree_neg {x : RatFunc K}
+    (hx : RatFunc.inftyValuation K x ≤ 1) :
+    ∃ c : K, x - algebraMap K (RatFunc K) c = 0 ∨
+      (x - algebraMap K (RatFunc K) c).intDegree < 0 := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · exact ⟨0, Or.inl (by simp)⟩
+  have hdeg : x.intDegree ≤ 0 := by
+    rw [RatFunc.inftyValuation_apply, RatFunc.inftyValuation_of_nonzero K hx0,
+      show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_le_exp] at hx
+    exact hx
+  have hnum0 : x.num ≠ 0 := RatFunc.num_ne_zero hx0
+  have hden0 : x.denom ≠ 0 := x.denom_ne_zero
+  rcases lt_or_eq_of_le hdeg with hlt | heq
+  · exact ⟨0, Or.inr (by simpa using hlt)⟩
+  have hndeg : x.num.natDegree = x.denom.natDegree := by
+    have h2 := heq
+    rw [RatFunc.intDegree, sub_eq_zero] at h2
+    exact_mod_cast h2
+  set c : K := x.num.leadingCoeff / x.denom.leadingCoeff with hc
+  have hc0 : c ≠ 0 := by
+    rw [hc]
+    exact div_ne_zero (Polynomial.leadingCoeff_ne_zero.mpr hnum0)
+      (Polynomial.leadingCoeff_ne_zero.mpr hden0)
+  refine ⟨c, ?_⟩
+  have hsub : x - algebraMap K (RatFunc K) c
+      = algebraMap K[X] (RatFunc K) (x.num - Polynomial.C c * x.denom)
+        / algebraMap K[X] (RatFunc K) x.denom := by
+    rw [map_sub, map_mul, sub_div, x.num_div_denom, mul_div_assoc,
+      div_self ((map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hden0),
+      mul_one, IsScalarTower.algebraMap_apply K K[X] (RatFunc K), Polynomial.algebraMap_eq]
+  rcases eq_or_ne (x.num - Polynomial.C c * x.denom) 0 with hzero | hnz
+  · exact Or.inl (by rw [hsub, hzero, map_zero, zero_div])
+  refine Or.inr ?_
+  rw [hsub, RatFunc.intDegree_div ((map_ne_zero_iff _
+      (IsFractionRing.injective K[X] (RatFunc K))).mpr hnz)
+    ((map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hden0),
+    RatFunc.intDegree_polynomial, RatFunc.intDegree_polynomial, sub_neg]
+  have hCdeg : (Polynomial.C c * x.denom).degree = x.denom.degree := by
+    rw [Polynomial.degree_mul, Polynomial.degree_C hc0, zero_add]
+  have hdegeq : x.num.degree = (Polynomial.C c * x.denom).degree := by
+    rw [hCdeg, Polynomial.degree_eq_natDegree hnum0, Polynomial.degree_eq_natDegree hden0,
+      hndeg]
+  have hlc : x.num.leadingCoeff = (Polynomial.C c * x.denom).leadingCoeff := by
+    rw [Polynomial.leadingCoeff_mul, Polynomial.leadingCoeff_C, hc,
+      div_mul_cancel₀ _ (Polynomial.leadingCoeff_ne_zero.mpr hden0)]
+  have hlt := Polynomial.degree_sub_lt_left hdegeq hnum0 hlc
+  rw [hdegeq, hCdeg] at hlt
+  exact_mod_cast Polynomial.natDegree_lt_natDegree hnz hlt
+
+theorem deg_placeInfty : (placeInfty K).deg = 1 := by
+  have hbij : Function.Bijective (Algebra.ofId K (placeInfty K).ResidueField) := by
+    constructor
+    · exact fun a b h => (algebraMap K ((placeInfty K).ResidueField)).injective h
+    · intro y
+      obtain ⟨⟨x, hx⟩, rfl⟩ := IsLocalRing.residue_surjective y
+      obtain ⟨c, hc⟩ := exists_sub_algebraMap_intDegree_neg K
+        ((Valuation.mem_valuationSubring_iff _ _).mp hx)
+      refine ⟨c, ?_⟩
+      change IsLocalRing.residue _ (algebraMap K (placeInfty K).toValuationSubring c) = _
+      rw [← sub_eq_zero, ← map_sub, IsLocalRing.residue_eq_zero_iff,
+        Place.mem_maximalIdeal_iff_adicValuation_lt_one]
+      change (placeInfty K).adicValuation (algebraMap K (RatFunc K) c - x) < 1
+      rw [← (inftyValuation_isEquiv_adicValuation K).lt_one_iff_lt_one,
+        show algebraMap K (RatFunc K) c - x = -(x - algebraMap K (RatFunc K) c) from
+          (neg_sub _ _).symm, Valuation.map_neg]
+      rcases hc with hc | hc
+      · rw [hc, map_zero]
+        exact zero_lt_one
+      · rw [RatFunc.inftyValuation_apply, RatFunc.inftyValuationDef]
+        split
+        · exact zero_lt_one
+        · rw [show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_lt_exp]
+          exact hc
+  rw [Place.deg, ← (AlgEquiv.ofBijective _ hbij).toLinearEquiv.finrank_eq,
+    Module.finrank_self]
+
+end DegInfty
+
+end RationalFunctionField
+
+theorem le_exp_neg_one_of_lt_one {x : ℤᵐ⁰} (hx : x < 1) : x ≤ exp (-1 : ℤ) := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · exact zero_le
+  · rw [← exp_log hx0] at hx ⊢
+    rw [show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_lt_exp] at hx
+    rw [exp_le_exp]
+    omega
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "adicValuation_valuationSubring \
+  isEquiv_adicValuation_of_valuationSubring_eq mem_maximalIdeal_iff_adicValuation_lt_one \
+  ord_ofHeightOneSpectrum_ne_zero_iff ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring algebraMap_mem' toValuationSubring \
+  IsRational evalAt mem_of_ord_nonneg ord_nonneg_of_mem ord_algebraMap \
+  ord_eq_neg_log_of_valuationSubring_eq evalAt_congr evalAt_algebraMap evalAt_mul evalAt_ne_zero \
+  evalAt_inv isRational_iff_deg_eq_one"
+p2m_open "AlgebraicCurve.Place~algebraMap_ne_zero"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.isUnit_algebraMap {c : K} (hc : c ≠ 0) :
+    IsUnit (algebraMap K v.toValuationSubring c) :=
+  (isUnit_iff_ne_zero.mpr hc).map _
+
+p2m_export "AlgebraicCurve.Place" "isUnit_algebraMap"
+
+theorem adicValuation_algebraMap {c : K} (hc : c ≠ 0) :
+    v.adicValuation (algebraMap K F c) = 1 := by
+  rw [← v.coe_algebraMap]
+  exact (v.adicValuation_coe_eq_one_iff _).mpr (v.isUnit_algebraMap hc)
+
+end Place
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "heightOneSpectrumOfIrreducible \
+  heightOneSpectrumOfIrreducible_asIdeal exists_irreducible_span finitePlace finitePlace_def \
+  algebraMap_mem_ofHeightOneSpectrum deg_finitePlace placeOfPoint \
+  placeOfPoint_eq_ofHeightOneSpectrum placeOfPoint_injective deg_placeOfPoint placeInfty \
+  placeInfty_toValuationSubring finite_setOf_ord_ne_zero degree_eq_zero_of_forall_eq_ord \
+  hasPrincipalDivisors ord_ofHeightOneSpectrum_of_span"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable {K : Type*} [Field K]
+
+theorem ord_ofHeightOneSpectrum_eq_zero_of_notMem (w : HeightOneSpectrum K[X]) {q : K[X]}
+    (hq : q ≠ 0) (hmem : q ∉ w.asIdeal) :
+    (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord
+      (algebraMap K[X] (RatFunc K) q) = 0 := by
+  by_contra h
+  exact hmem
+    ((Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w hq).mp h)
+
+section PlaceInftyOrd
+
+variable [DecidableEq (RatFunc K)]
+
+theorem ord_placeInfty {f : RatFunc K} (hf : f ≠ 0) :
+    (placeInfty K).ord f = -f.intDegree := by
+  have hπ : RatFunc.inftyValuation K (RatFunc.X)⁻¹ = exp (-1 : ℤ) := by
+    rw [map_inv₀, RatFunc.inftyValuation.X]
+    exact (exp_neg (1 : ℤ)).symm
+  rw [(placeInfty K).ord_eq_neg_log_of_valuationSubring_eq (RatFunc.inftyValuation K) rfl hπ
+      hf,
+    RatFunc.inftyValuation_apply, RatFunc.inftyValuation_of_nonzero K hf, log_exp]
+
+theorem ord_placeInfty_algebraMap {q : K[X]} (hq : q ≠ 0) :
+    (placeInfty K).ord (algebraMap K[X] (RatFunc K) q) = -(q.natDegree : ℤ) := by
+  rw [ord_placeInfty (RatFunc.algebraMap_ne_zero hq), RatFunc.intDegree_polynomial]
+
+end PlaceInftyOrd
+
+section IrreducibleDivisor
+
+variable [DecidableEq (RatFunc K)]
+
+theorem single_add_single_apply_eq_ord {p : K[X]} (hp : Irreducible p)
+    (v : Place K (RatFunc K)) :
+    (Finsupp.single (finitePlace K hp) (1 : ℤ)
+        + Finsupp.single (placeInfty K) (-(p.natDegree : ℤ))) v
+      = v.ord (algebraMap K[X] (RatFunc K) p) := by
+  have hp0 : p ≠ 0 := hp.ne_zero
+  rw [Finsupp.add_apply]
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+  · rw [Finsupp.single_eq_of_ne (Ne.symm (placeInfty_ne_ofHeightOneSpectrum K w)), add_zero]
+    by_cases hcase :
+        Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w = finitePlace K hp
+    · rw [hcase, Finsupp.single_eq_same]
+      exact (ord_ofHeightOneSpectrum_of_span (heightOneSpectrumOfIrreducible K hp) hp0
+        (heightOneSpectrumOfIrreducible_asIdeal K hp)).symm
+    · rw [Finsupp.single_eq_of_ne hcase]
+      refine (ord_ofHeightOneSpectrum_eq_zero_of_notMem w hp0 fun hmem => hcase ?_).symm
+      have hspan : Ideal.span {p} = w.asIdeal :=
+        (PrincipalIdealRing.isMaximal_of_irreducible hp).eq_of_le w.isPrime.ne_top
+          ((Ideal.span_singleton_le_iff_mem _).mpr hmem)
+      have hwp : w = heightOneSpectrumOfIrreducible K hp :=
+        HeightOneSpectrum.ext
+          (hspan.symm.trans (heightOneSpectrumOfIrreducible_asIdeal K hp).symm)
+      rw [hwp, finitePlace_def]
+  · rw [Finsupp.single_eq_of_ne
+        (show placeInfty K ≠ finitePlace K hp from
+          placeInfty_ne_ofHeightOneSpectrum K (heightOneSpectrumOfIrreducible K hp)),
+      Finsupp.single_eq_same, zero_add]
+    exact (ord_placeInfty_algebraMap hp0).symm
+
+theorem degree_single_add_single {p : K[X]} (hp : Irreducible p) :
+    Divisor.degree (Finsupp.single (finitePlace K hp) (1 : ℤ)
+        + Finsupp.single (placeInfty K) (-(p.natDegree : ℤ))) = 0 := by
+  rw [map_add, Divisor.degree_single, Divisor.degree_single, deg_finitePlace, deg_placeInfty]
+  push_cast
+  ring
+
+end IrreducibleDivisor
+
+def principalDivisor {f : RatFunc K} (hf : f ≠ 0) : Divisor K (RatFunc K) :=
+  ⟨(finite_setOf_ord_ne_zero hf).toFinset, fun v => v.ord f, fun v => by
+    simp [Set.Finite.mem_toFinset]⟩
+
+@[scoped simp]
+theorem principalDivisor_apply {f : RatFunc K} (hf : f ≠ 0) (v : Place K (RatFunc K)) :
+    principalDivisor hf v = v.ord f := rfl
+
+theorem principalDivisor_isPrincipal {f : RatFunc K} (hf : f ≠ 0) :
+    (principalDivisor hf).IsPrincipal :=
+  ⟨f, hf, fun _ => rfl⟩
+
+theorem degree_principalDivisor {f : RatFunc K} (hf : f ≠ 0) :
+    Divisor.degree (principalDivisor hf) = 0 :=
+  degree_eq_zero_of_forall_eq_ord (principalDivisor hf) fun _ => rfl
+
+theorem sum_ord_mul_deg_eq_zero {f : RatFunc K} (hf : f ≠ 0) :
+    ∑ v ∈ (finite_setOf_ord_ne_zero hf).toFinset, v.ord f * (v.deg : ℤ) = 0 := by
+  have h1 : (principalDivisor hf : Divisor K (RatFunc K))
+      = ∑ v ∈ (finite_setOf_ord_ne_zero hf).toFinset, Finsupp.single v (v.ord f) :=
+    (Finsupp.sum_single (principalDivisor hf)).symm
+  have h2 := degree_principalDivisor hf
+  rw [h1, map_sum] at h2
+  simp only [Divisor.degree_single] at h2
+  exact h2
+
+end RationalFunctionField
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "heightOneSpectrumOfIrreducible \
+  heightOneSpectrumOfIrreducible_asIdeal exists_irreducible_span finitePlace finitePlace_def \
+  algebraMap_mem_ofHeightOneSpectrum deg_finitePlace placeOfPoint \
+  placeOfPoint_eq_ofHeightOneSpectrum placeOfPoint_injective deg_placeOfPoint placeInfty \
+  placeInfty_toValuationSubring finite_setOf_ord_ne_zero degree_eq_zero_of_forall_eq_ord \
+  hasPrincipalDivisors ord_ofHeightOneSpectrum_of_span"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable (K : Type*) [Field K]
+
+theorem placeOfPoint_ne_placeInfty [DecidableEq (RatFunc K)] (a : K) :
+    placeOfPoint K a ≠ placeInfty K := by
+  rw [placeOfPoint_eq_ofHeightOneSpectrum]
+  exact fun h => placeInfty_ne_ofHeightOneSpectrum K _ h.symm
+
+variable {K}
+
+theorem ord_placeOfPoint_algebraMap_eq_mul (a : K) {q : K[X]} (hq : q ≠ 0) :
+    (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) q)
+      = (rootMultiplicity a q : ℤ)
+          * (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) (X - C a)) := by
+  obtain ⟨r, hr⟩ := pow_rootMultiplicity_dvd q a
+  set m : ℕ := rootMultiplicity a q with hm
+  have hXa : (X : K[X]) - C a ≠ 0 := X_sub_C_ne_zero a
+  have hr0 : r ≠ 0 := by
+    rintro rfl
+    exact hq (by simpa using hr)
+  have hndvd : ¬((X : K[X]) - C a) ∣ r := by
+    intro ⟨s, hs⟩
+    have : (X - C a) ^ (m + 1) ∣ q := ⟨s, by rw [hr, hs]; ring⟩
+    have := (le_rootMultiplicity_iff hq).mpr this
+    omega
+  have hinj := IsFractionRing.injective K[X] (RatFunc K)
+  have hXa' : algebraMap K[X] (RatFunc K) (X - C a) ≠ 0 := (map_ne_zero_iff _ hinj).mpr hXa
+  have hr0' : algebraMap K[X] (RatFunc K) r ≠ 0 := (map_ne_zero_iff _ hinj).mpr hr0
+  have hpow' : algebraMap K[X] (RatFunc K) ((X - C a) ^ m) ≠ 0 :=
+    (map_ne_zero_iff _ hinj).mpr (pow_ne_zero m hXa)
+  have hordr : (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) r) = 0 := by
+    by_contra hcon
+    exact hndvd (((ord_finitePlace_ne_zero_iff K (irreducible_X_sub_C a) hr0).mp) hcon)
+  calc (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) q)
+      = (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) ((X - C a) ^ m)
+          * algebraMap K[X] (RatFunc K) r) := by rw [← map_mul, ← hr]
+    _ = (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) ((X - C a) ^ m))
+          + (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) r) :=
+        (placeOfPoint K a).ord_mul hpow' hr0'
+    _ = (placeOfPoint K a).ord ((algebraMap K[X] (RatFunc K) (X - C a)) ^ (m : ℤ)) := by
+        rw [hordr, add_zero, map_pow, ← zpow_natCast]
+    _ = (m : ℤ) * (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) (X - C a)) :=
+        (placeOfPoint K a).ord_zpow _ _
+
+theorem dvd_ord_placeOfPoint (a : K) {f : RatFunc K} (hf : f ≠ 0) :
+    (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) (X - C a)) ∣ (placeOfPoint K a).ord f := by
+  have hinj := IsFractionRing.injective K[X] (RatFunc K)
+  have hnum : f.num ≠ 0 := RatFunc.num_ne_zero hf
+  have hden : f.denom ≠ 0 := f.denom_ne_zero
+  have hnum' : algebraMap K[X] (RatFunc K) f.num ≠ 0 := (map_ne_zero_iff _ hinj).mpr hnum
+  have hden' : algebraMap K[X] (RatFunc K) f.denom ≠ 0 := (map_ne_zero_iff _ hinj).mpr hden
+  have hsplit : f = algebraMap K[X] (RatFunc K) f.num
+      * (algebraMap K[X] (RatFunc K) f.denom)⁻¹ := by
+    rw [← div_eq_mul_inv, f.num_div_denom]
+  rw [hsplit, (placeOfPoint K a).ord_mul hnum' (inv_ne_zero hden'), Place.ord_inv,
+    ord_placeOfPoint_algebraMap_eq_mul a hnum, ord_placeOfPoint_algebraMap_eq_mul a hden]
+  exact dvd_add (Dvd.intro_left _ rfl) ((Dvd.intro_left _ rfl).neg_right)
+
+theorem ord_placeOfPoint_X_sub_C (a : K) :
+    (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) (X - C a)) = 1 := by
+  set v := placeOfPoint K a with hv
+  set n : ℤ := v.ord (algebraMap K[X] (RatFunc K) (X - C a)) with hn
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπ0 : (π : RatFunc K) ≠ 0 := by
+    simpa using hπ.ne_zero
+  have h1 : v.ord (π : RatFunc K) = 1 := v.ord_coe_irreducible hπ
+  have hdvd : n ∣ 1 := h1 ▸ dvd_ord_placeOfPoint a hπ0
+  have hmem : algebraMap K[X] (RatFunc K) (X - C a) ∈ v.toValuationSubring := by
+    rw [hv, placeOfPoint_eq_ofHeightOneSpectrum]
+    exact algebraMap_mem_ofHeightOneSpectrum K _ _
+  have hnonneg : 0 ≤ n := v.ord_nonneg_of_mem hmem
+  rcases Int.isUnit_iff.mp (isUnit_of_dvd_one hdvd) with h | h
+  · exact h
+  · omega
+
+theorem ord_placeOfPoint_algebraMap (a : K) {q : K[X]} (hq : q ≠ 0) :
+    (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) q) = rootMultiplicity a q := by
+  rw [ord_placeOfPoint_algebraMap_eq_mul a hq, ord_placeOfPoint_X_sub_C a, mul_one]
+
+variable (K)
+
+theorem exists_eq_placeOfPoint [IsAlgClosed K] (w : HeightOneSpectrum K[X]) :
+    ∃ a : K, Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w = placeOfPoint K a := by
+  obtain ⟨p, hp, hwp⟩ := exists_irreducible_span K w
+  have hdeg : p.degree ≠ 0 := by
+    rw [IsAlgClosed.degree_eq_one_of_irreducible K hp]
+    exact one_ne_zero
+  obtain ⟨a, ha⟩ := IsAlgClosed.exists_root p hdeg
+  refine ⟨a, ?_⟩
+  have hassoc : Associated ((X : K[X]) - C a) p :=
+    (irreducible_X_sub_C a).associated_of_dvd hp (dvd_iff_isRoot.mpr ha)
+  have hideal : w = heightOneSpectrumOfIrreducible K (irreducible_X_sub_C a) :=
+    HeightOneSpectrum.ext (by
+      rw [hwp, heightOneSpectrumOfIrreducible_asIdeal]
+      exact (Ideal.span_singleton_eq_span_singleton.mpr hassoc).symm)
+  rw [hideal, placeOfPoint_eq_ofHeightOneSpectrum]
+
+theorem eq_placeOfPoint_or_eq_placeInfty [IsAlgClosed K] [DecidableEq (RatFunc K)]
+    (v : Place K (RatFunc K)) :
+    (∃ a : K, v = placeOfPoint K a) ∨ v = placeInfty K := by
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, hw⟩ | hw
+  · obtain ⟨a, ha⟩ := exists_eq_placeOfPoint K w
+    exact Or.inl ⟨a, hw.trans ha⟩
+  · exact Or.inr hw
+
+private def ofOption [DecidableEq (RatFunc K)] : Option K → Place K (RatFunc K) :=
+  fun o => o.elim (placeInfty K) (placeOfPoint K)
+
+private theorem ofOption_bijective [IsAlgClosed K] [DecidableEq (RatFunc K)] :
+    Function.Bijective (ofOption K) := by
+  constructor
+  · rintro (_ | a) (_ | b) h
+    · rfl
+    · exact absurd h.symm (placeOfPoint_ne_placeInfty K b)
+    · exact absurd h (placeOfPoint_ne_placeInfty K a)
+    · exact congrArg some (placeOfPoint_injective K h)
+  · intro v
+    rcases eq_placeOfPoint_or_eq_placeInfty K v with ⟨a, ha⟩ | ha
+    · exact ⟨some a, ha.symm⟩
+    · exact ⟨none, ha.symm⟩
+
+def placeEquivOption [IsAlgClosed K] [DecidableEq (RatFunc K)] :
+    Place K (RatFunc K) ≃ Option K :=
+  (Equiv.ofBijective (ofOption K) (ofOption_bijective K)).symm
+
+@[scoped simp]
+theorem placeEquivOption_symm_some [IsAlgClosed K] [DecidableEq (RatFunc K)] (a : K) :
+    (placeEquivOption K).symm (some a) = placeOfPoint K a := rfl
+
+@[scoped simp]
+theorem placeEquivOption_symm_none [IsAlgClosed K] [DecidableEq (RatFunc K)] :
+    (placeEquivOption K).symm none = placeInfty K := rfl
+
+@[scoped simp]
+theorem placeEquivOption_placeOfPoint [IsAlgClosed K] [DecidableEq (RatFunc K)] (a : K) :
+    placeEquivOption K (placeOfPoint K a) = some a :=
+  (Equiv.ofBijective (ofOption K) (ofOption_bijective K)).symm_apply_apply (some a)
+
+@[scoped simp]
+theorem placeEquivOption_placeInfty [IsAlgClosed K] [DecidableEq (RatFunc K)] :
+    placeEquivOption K (placeInfty K) = none :=
+  (Equiv.ofBijective (ofOption K) (ofOption_bijective K)).symm_apply_apply none
+
+theorem deg_eq_one_of_isAlgClosed [IsAlgClosed K] (v : Place K (RatFunc K)) : v.deg = 1 := by
+  classical
+  rcases eq_placeOfPoint_or_eq_placeInfty K v with ⟨a, rfl⟩ | rfl
+  · exact deg_placeOfPoint K a
+  · exact deg_placeInfty K
+
+end RationalFunctionField
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "heightOneSpectrumOfIrreducible \
+  heightOneSpectrumOfIrreducible_asIdeal exists_irreducible_span finitePlace finitePlace_def \
+  algebraMap_mem_ofHeightOneSpectrum deg_finitePlace placeOfPoint \
+  placeOfPoint_eq_ofHeightOneSpectrum placeOfPoint_injective deg_placeOfPoint placeInfty \
+  placeInfty_toValuationSubring finite_setOf_ord_ne_zero degree_eq_zero_of_forall_eq_ord \
+  hasPrincipalDivisors ord_ofHeightOneSpectrum_of_span"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable {K : Type*} [Field K]
+
+theorem algebraMap_polynomial_ne_zero {q : K[X]} (hq : q ≠ 0) :
+    algebraMap K[X] (RatFunc K) q ≠ 0 :=
+  RatFunc.algebraMap_ne_zero hq
+
+theorem algebraMap_C (c : K) :
+    algebraMap K[X] (RatFunc K) (C c) = algebraMap K (RatFunc K) c := by
+  rw [IsScalarTower.algebraMap_apply K K[X] (RatFunc K), Polynomial.algebraMap_eq]
+
+theorem evalAt_placeOfPoint_algebraMap (a : K) (q : K[X]) :
+    (placeOfPoint K a).evalAt (algebraMap K[X] (RatFunc K) q) = q.eval a := by
+  have hmem : algebraMap K[X] (RatFunc K) q ∈ (placeOfPoint K a).toValuationSubring :=
+    algebraMap_mem_ofHeightOneSpectrum K _ q
+  have hmem' : algebraMap K (RatFunc K) (q.eval a) ∈ (placeOfPoint K a).toValuationSubring :=
+    (placeOfPoint K a).algebraMap_mem' _
+  have hsub : algebraMap K[X] (RatFunc K) q - algebraMap K (RatFunc K) (q.eval a)
+      = algebraMap K[X] (RatFunc K) (q - C (q.eval a)) := by
+    rw [map_sub, algebraMap_C]
+  have hcongr : (placeOfPoint K a).evalAt (algebraMap K[X] (RatFunc K) q)
+      = (placeOfPoint K a).evalAt (algebraMap K (RatFunc K) (q.eval a)) := by
+    refine Place.evalAt_congr _ hmem hmem' ?_
+    rw [hsub]
+    rcases eq_or_ne (q - C (q.eval a)) 0 with h0 | h0
+    · exact Or.inl (by rw [h0, map_zero])
+    · refine Or.inr ?_
+      rw [ord_placeOfPoint_algebraMap a h0]
+      have hroot : (q - C (q.eval a)).IsRoot a := by
+        simp [IsRoot.def]
+      exact_mod_cast (rootMultiplicity_pos h0).mpr hroot
+  rw [hcongr, Place.evalAt_algebraMap]
+
+theorem evalAt_placeOfPoint_X_sub_C (a b : K) :
+    (placeOfPoint K a).evalAt (algebraMap K[X] (RatFunc K) (X - C b)) = a - b := by
+  rw [evalAt_placeOfPoint_algebraMap]
+  simp
+
+section PlaceInfty
+
+variable [DecidableEq (RatFunc K)]
+
+theorem mem_placeInfty_of_intDegree_nonpos {f : RatFunc K} (hf : f ≠ 0)
+    (h : f.intDegree ≤ 0) : f ∈ (placeInfty K).toValuationSubring :=
+  (placeInfty K).mem_of_ord_nonneg hf (by rw [ord_placeInfty hf]; omega)
+
+theorem evalAt_placeInfty_eq {f : RatFunc K} {c : K}
+    (h : f - algebraMap K (RatFunc K) c = 0
+      ∨ (f - algebraMap K (RatFunc K) c).intDegree < 0) :
+    (placeInfty K).evalAt f = c := by
+  have hsubmem : f - algebraMap K (RatFunc K) c ∈ (placeInfty K).toValuationSubring := by
+    rcases h with h | h
+    · rw [h]; exact zero_mem _
+    · refine mem_placeInfty_of_intDegree_nonpos ?_ h.le
+      intro h0
+      rw [h0] at h
+      simp [RatFunc.intDegree_zero] at h
+  have hmem : f ∈ (placeInfty K).toValuationSubring := by
+    have : f = (f - algebraMap K (RatFunc K) c) + algebraMap K (RatFunc K) c := by ring
+    rw [this]
+    exact add_mem hsubmem ((placeInfty K).algebraMap_mem' c)
+  have hcongr : (placeInfty K).evalAt f
+      = (placeInfty K).evalAt (algebraMap K (RatFunc K) c) := by
+    refine Place.evalAt_congr _ hmem ((placeInfty K).algebraMap_mem' c) ?_
+    rcases h with h | h
+    · exact Or.inl h
+    · refine Or.inr ?_
+      have hne : f - algebraMap K (RatFunc K) c ≠ 0 := by
+        intro h0
+        rw [h0] at h
+        simp [RatFunc.intDegree_zero] at h
+      rw [ord_placeInfty hne]
+      omega
+  rw [hcongr, Place.evalAt_algebraMap]
+
+theorem evalAt_placeInfty_X_sub_C_div (a a₀ : K) :
+    (placeInfty K).evalAt
+        (algebraMap K[X] (RatFunc K) (X - C a) / algebraMap K[X] (RatFunc K) (X - C a₀))
+      = 1 := by
+  have ha₀ : algebraMap K[X] (RatFunc K) (X - C a₀) ≠ 0 :=
+    algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a₀)
+  refine evalAt_placeInfty_eq ?_
+  have hkey : algebraMap K[X] (RatFunc K) (X - C a) / algebraMap K[X] (RatFunc K) (X - C a₀)
+        - algebraMap K (RatFunc K) 1
+      = algebraMap K[X] (RatFunc K) (C (a₀ - a)) / algebraMap K[X] (RatFunc K) (X - C a₀) := by
+    rw [map_one, div_sub_one ha₀, ← map_sub]
+    congr 2
+    rw [map_sub]
+    ring
+  rw [hkey]
+  rcases eq_or_ne a₀ a with rfl | hne
+  · exact Or.inl (by simp)
+  · refine Or.inr ?_
+    have hC : (C (a₀ - a) : K[X]) ≠ 0 := by
+      simpa [sub_eq_zero] using hne
+    rw [RatFunc.intDegree_div (algebraMap_polynomial_ne_zero hC) ha₀,
+      RatFunc.intDegree_polynomial, RatFunc.intDegree_polynomial, natDegree_C,
+      natDegree_X_sub_C]
+    norm_num
+
+end PlaceInfty
+
+section CrossRatio
+
+variable [DecidableEq (RatFunc K)]
+
+theorem principalDivisor_X_sub_C (b : K) :
+    principalDivisor (algebraMap_polynomial_ne_zero (X_sub_C_ne_zero b))
+      = Finsupp.single (placeOfPoint K b) 1 + Finsupp.single (placeInfty K) (-1) := by
+  ext v
+  have h := single_add_single_apply_eq_ord (irreducible_X_sub_C b) v
+  rw [natDegree_X_sub_C, Nat.cast_one] at h
+  rw [principalDivisor_apply, ← h]
+  rfl
+
+theorem ord_X_sub_C (b : K) (v : Place K (RatFunc K)) :
+    v.ord (algebraMap K[X] (RatFunc K) (X - C b))
+      = (Finsupp.single (placeOfPoint K b) (1 : ℤ)
+          + Finsupp.single (placeInfty K) (-1 : ℤ)) v := by
+  rw [← principalDivisor_X_sub_C b, principalDivisor_apply]
+
+omit [DecidableEq (RatFunc K)] in
+theorem ord_X_sub_C_placeOfPoint_of_ne {a b : K} (hab : a ≠ b) :
+    (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) (X - C b)) = 0 := by
+  classical
+  rw [ord_X_sub_C, Finsupp.add_apply,
+    Finsupp.single_eq_of_ne
+      (show placeOfPoint K a ≠ placeOfPoint K b from
+        fun h => hab (placeOfPoint_injective K h)),
+    Finsupp.single_eq_of_ne (placeOfPoint_ne_placeInfty K a), add_zero]
+
+omit [DecidableEq (RatFunc K)] in
+theorem ord_X_sub_C_placeOfPoint_self (b : K) :
+    (placeOfPoint K b).ord (algebraMap K[X] (RatFunc K) (X - C b)) = 1 := by
+  classical
+  rw [ord_X_sub_C, Finsupp.add_apply, Finsupp.single_eq_same,
+    Finsupp.single_eq_of_ne (placeOfPoint_ne_placeInfty K b), add_zero]
+
+theorem ord_X_sub_C_placeInfty (b : K) :
+    (placeInfty K).ord (algebraMap K[X] (RatFunc K) (X - C b)) = -1 := by
+  rw [ord_X_sub_C, Finsupp.add_apply,
+    Finsupp.single_eq_of_ne (Ne.symm (placeOfPoint_ne_placeInfty K b)),
+    Finsupp.single_eq_same, zero_add]
+
+omit [DecidableEq (RatFunc K)] in
+theorem isRational_placeOfPoint (a : K) : (placeOfPoint K a).IsRational :=
+  Place.isRational_of_deg_eq_one _ (deg_placeOfPoint K a)
+
+omit [DecidableEq (RatFunc K)] in
+theorem principalDivisor_X_sub_C_div (a a₀ : K) :
+    principalDivisor (div_ne_zero (algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a))
+        (algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a₀)))
+      = Finsupp.single (placeOfPoint K a) 1 + Finsupp.single (placeOfPoint K a₀) (-1) := by
+  classical
+  have hLa : algebraMap K[X] (RatFunc K) (X - C a) ≠ 0 :=
+    algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a)
+  have hLa₀ : algebraMap K[X] (RatFunc K) (X - C a₀) ≠ 0 :=
+    algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a₀)
+  ext v
+  have hneg : (Finsupp.single (placeOfPoint K a₀) (-1 : ℤ)) v
+      = -((Finsupp.single (placeOfPoint K a₀) (1 : ℤ)) v) := by
+    rcases eq_or_ne v (placeOfPoint K a₀) with rfl | h
+    · rw [Finsupp.single_eq_same, Finsupp.single_eq_same]
+    · rw [Finsupp.single_eq_of_ne h, Finsupp.single_eq_of_ne h, neg_zero]
+  rw [principalDivisor_apply, div_eq_mul_inv, v.ord_mul hLa (inv_ne_zero hLa₀), v.ord_inv,
+    ord_X_sub_C a v, ord_X_sub_C a₀ v]
+  simp only [Finsupp.add_apply]
+  rw [hneg]
+  ring
+
+omit [DecidableEq (RatFunc K)] in
+theorem evalAt_placeOfPoint_X_sub_C_div (a a₀ : K) {b : K} (hba₀ : b ≠ a₀) :
+    (placeOfPoint K b).evalAt
+        (algebraMap K[X] (RatFunc K) (X - C a) / algebraMap K[X] (RatFunc K) (X - C a₀))
+      = (b - a) / (b - a₀) := by
+  classical
+  have hLa₀ : algebraMap K[X] (RatFunc K) (X - C a₀) ≠ 0 :=
+    algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a₀)
+  have hord : (placeOfPoint K b).ord (algebraMap K[X] (RatFunc K) (X - C a₀)) = 0 :=
+    ord_X_sub_C_placeOfPoint_of_ne hba₀
+  rw [div_eq_mul_inv, (placeOfPoint K b).evalAt_mul (isRational_placeOfPoint b)
+      (algebraMap_mem_ofHeightOneSpectrum K _ _)
+      ((placeOfPoint K b).mem_of_ord_nonneg (inv_ne_zero hLa₀)
+        (by rw [Place.ord_inv, hord, neg_zero])),
+    (placeOfPoint K b).evalAt_inv (isRational_placeOfPoint b) hLa₀ hord,
+    evalAt_placeOfPoint_X_sub_C, evalAt_placeOfPoint_X_sub_C, div_eq_mul_inv]
+
+end CrossRatio
+
+section Reciprocity
+
+variable [IsAlgClosed K] [DecidableEq (RatFunc K)]
+
+omit [DecidableEq (RatFunc K)] in
+theorem isRational_of_isAlgClosed (v : Place K (RatFunc K)) : v.IsRational :=
+  Place.isRational_of_deg_eq_one v (deg_eq_one_of_isAlgClosed K v)
+
+omit [IsAlgClosed K] [DecidableEq (RatFunc K)] in
+theorem algebraMap_const_ne_zero {c : K} (hc : c ≠ 0) : algebraMap K (RatFunc K) c ≠ 0 := by
+  simpa using hc
+
+local instance : DecidableEq (Place K (RatFunc K)) := Classical.decEq _
+
+omit [IsAlgClosed K] [DecidableEq (RatFunc K)] in
+theorem ord_ne_zero_of_mem_support {g : RatFunc K} (hg : g ≠ 0) {v : Place K (RatFunc K)}
+    (hv : v ∈ (principalDivisor hg).support) : v.ord g ≠ 0 := by
+  rwa [Finsupp.mem_support_iff, principalDivisor_apply] at hv
+
+omit [DecidableEq (RatFunc K)] in
+theorem sum_ord_eq_zero {f : RatFunc K} (hf : f ≠ 0) :
+    ∑ v ∈ (principalDivisor hf).support, v.ord f = 0 := by
+  rw [← sum_ord_mul_deg_eq_zero hf]
+  exact Finset.sum_congr rfl fun v _ => by
+    rw [deg_eq_one_of_isAlgClosed K v, Nat.cast_one, mul_one]
+
+omit [IsAlgClosed K] [DecidableEq (RatFunc K)] in
+theorem zpow_sum_eq_prod {c : K} (hc : c ≠ 0) {ι : Type*} (s : Finset ι) (n : ι → ℤ) :
+    ∏ i ∈ s, c ^ n i = c ^ (∑ i ∈ s, n i) := by
+  induction s using Finset.cons_induction with
+  | empty => simp
+  | cons a s ha ih => rw [Finset.prod_cons, Finset.sum_cons, zpow_add₀ hc, ih]
+
+omit [IsAlgClosed K] [DecidableEq (RatFunc K)] in
+theorem principalDivisor_congr {f g : RatFunc K} (hf : f ≠ 0) (hg : g ≠ 0) (h : f = g) :
+    principalDivisor hf = principalDivisor hg := by
+  subst h
+  rfl
+
+omit [DecidableEq (RatFunc K)] in
+theorem reciprocity_algebraMap_right {f : RatFunc K} (hf : f ≠ 0) {c : K} (hc : c ≠ 0) :
+    Divisor.evalFun f (principalDivisor (algebraMap_const_ne_zero hc))
+      = Divisor.evalFun (algebraMap K (RatFunc K) c) (principalDivisor hf) := by
+  have hzero : principalDivisor (algebraMap_const_ne_zero hc) = 0 := by
+    ext v
+    rw [principalDivisor_apply, v.ord_algebraMap, Finsupp.coe_zero, Pi.zero_apply]
+  rw [hzero, Divisor.evalFun_zero, Divisor.evalFun_def]
+  rw [Finset.prod_congr rfl fun v _ => by rw [Place.evalAt_algebraMap],
+    zpow_sum_eq_prod hc]
+  rw [show ∑ v ∈ (principalDivisor hf).support, principalDivisor hf v
+      = ∑ v ∈ (principalDivisor hf).support, v.ord f from
+    Finset.sum_congr rfl fun v _ => principalDivisor_apply hf v, sum_ord_eq_zero hf,
+    zpow_zero]
+
+omit [DecidableEq (RatFunc K)] in
+theorem reciprocity_mul_right {f g₁ g₂ : RatFunc K} (hf : f ≠ 0) (hg₁ : g₁ ≠ 0) (hg₂ : g₂ ≠ 0)
+    (hd₁ : ∀ v : Place K (RatFunc K), v.ord f = 0 ∨ v.ord g₁ = 0)
+    (hd₂ : ∀ v : Place K (RatFunc K), v.ord f = 0 ∨ v.ord g₂ = 0)
+    (h₁ : Divisor.evalFun f (principalDivisor hg₁) = Divisor.evalFun g₁ (principalDivisor hf))
+    (h₂ : Divisor.evalFun f (principalDivisor hg₂)
+      = Divisor.evalFun g₂ (principalDivisor hf)) :
+    Divisor.evalFun f (principalDivisor (mul_ne_zero hg₁ hg₂))
+      = Divisor.evalFun (g₁ * g₂) (principalDivisor hf) := by
+  have hsplit : principalDivisor (mul_ne_zero hg₁ hg₂)
+      = principalDivisor hg₁ + principalDivisor hg₂ := by
+    ext v
+    rw [principalDivisor_apply, Finsupp.add_apply, principalDivisor_apply,
+      principalDivisor_apply, v.ord_mul hg₁ hg₂]
+  rw [hsplit,
+    Divisor.evalFun_add f
+      (fun v hv => v.evalAt_ne_zero (isRational_of_isAlgClosed v) hf
+        ((hd₁ v).resolve_right (ord_ne_zero_of_mem_support hg₁ hv)))
+      (fun v hv => v.evalAt_ne_zero (isRational_of_isAlgClosed v) hf
+        ((hd₂ v).resolve_right (ord_ne_zero_of_mem_support hg₂ hv))),
+    h₁, h₂,
+    ← Divisor.evalFun_mul (fun v _ => isRational_of_isAlgClosed v)
+      (fun v hv => v.mem_of_ord_nonneg hg₁
+        ((hd₁ v).resolve_left (ord_ne_zero_of_mem_support hf hv)).ge)
+      (fun v hv => v.mem_of_ord_nonneg hg₂
+        ((hd₂ v).resolve_left (ord_ne_zero_of_mem_support hf hv)).ge)]
+
+omit [DecidableEq (RatFunc K)] in
+theorem reciprocity_mul_left {f₁ f₂ g : RatFunc K} (hf₁ : f₁ ≠ 0) (hf₂ : f₂ ≠ 0) (hg : g ≠ 0)
+    (hd₁ : ∀ v : Place K (RatFunc K), v.ord f₁ = 0 ∨ v.ord g = 0)
+    (hd₂ : ∀ v : Place K (RatFunc K), v.ord f₂ = 0 ∨ v.ord g = 0)
+    (h₁ : Divisor.evalFun f₁ (principalDivisor hg) = Divisor.evalFun g (principalDivisor hf₁))
+    (h₂ : Divisor.evalFun f₂ (principalDivisor hg)
+      = Divisor.evalFun g (principalDivisor hf₂)) :
+    Divisor.evalFun (f₁ * f₂) (principalDivisor hg)
+      = Divisor.evalFun g (principalDivisor (mul_ne_zero hf₁ hf₂)) :=
+  (reciprocity_mul_right hg hf₁ hf₂ (fun v => (hd₁ v).symm) (fun v => (hd₂ v).symm)
+    h₁.symm h₂.symm).symm
+
+omit [DecidableEq (RatFunc K)] in
+theorem reciprocity_zpow_right {f g : RatFunc K} (hf : f ≠ 0) (hg : g ≠ 0) (n : ℤ)
+    (hd : ∀ v : Place K (RatFunc K), v.ord f = 0 ∨ v.ord g = 0)
+    (h : Divisor.evalFun f (principalDivisor hg)
+      = Divisor.evalFun g (principalDivisor hf)) :
+    Divisor.evalFun f (principalDivisor (zpow_ne_zero n hg))
+      = Divisor.evalFun (g ^ n) (principalDivisor hf) := by
+  have hsplit : principalDivisor (zpow_ne_zero n hg) = n • principalDivisor hg := by
+    ext v
+    rw [principalDivisor_apply, Finsupp.smul_apply, principalDivisor_apply, v.ord_zpow,
+      smul_eq_mul]
+  rw [hsplit, Divisor.evalFun_zsmul, h,
+    ← Divisor.evalFun_zpow_left hg n (fun v _ => isRational_of_isAlgClosed v)
+      (fun v hv => (hd v).resolve_left (ord_ne_zero_of_mem_support hf hv))]
+
+omit [DecidableEq (RatFunc K)] in
+theorem reciprocity_zpow_left {f g : RatFunc K} (hf : f ≠ 0) (hg : g ≠ 0) (n : ℤ)
+    (hd : ∀ v : Place K (RatFunc K), v.ord f = 0 ∨ v.ord g = 0)
+    (h : Divisor.evalFun f (principalDivisor hg)
+      = Divisor.evalFun g (principalDivisor hf)) :
+    Divisor.evalFun (f ^ n) (principalDivisor hg)
+      = Divisor.evalFun g (principalDivisor (zpow_ne_zero n hf)) :=
+  (reciprocity_zpow_right hg hf n (fun v => (hd v).symm) h.symm).symm
+
+omit [IsAlgClosed K] [DecidableEq (RatFunc K)] in
+theorem exists_algebraMap_of_forall_ord_eq_zero {g : RatFunc K} (hg : g ≠ 0)
+    (h : ∀ v : Place K (RatFunc K), v.ord g = 0) :
+    ∃ c : K, c ≠ 0 ∧ g = algebraMap K (RatFunc K) c := by
+  have hnum0 : g.num ≠ 0 := RatFunc.num_ne_zero hg
+  have hden0 : g.denom ≠ 0 := g.denom_ne_zero
+  have hnum0' : algebraMap K[X] (RatFunc K) g.num ≠ 0 := algebraMap_polynomial_ne_zero hnum0
+  have hden0' : algebraMap K[X] (RatFunc K) g.denom ≠ 0 := algebraMap_polynomial_ne_zero hden0
+  have hsplit : g = algebraMap K[X] (RatFunc K) g.num
+      * (algebraMap K[X] (RatFunc K) g.denom)⁻¹ := by
+    rw [← div_eq_mul_inv, g.num_div_denom]
+  have hkey : ∀ p : K[X], Irreducible p → ¬p ∣ g.num ∧ ¬p ∣ g.denom := by
+    intro p hpirr
+    have hord : (finitePlace K hpirr).ord (algebraMap K[X] (RatFunc K) g.num)
+        = (finitePlace K hpirr).ord (algebraMap K[X] (RatFunc K) g.denom) := by
+      have h0 := h (finitePlace K hpirr)
+      rw [hsplit, (finitePlace K hpirr).ord_mul hnum0' (inv_ne_zero hden0'),
+        Place.ord_inv] at h0
+      omega
+    constructor
+    · intro hdvd
+      refine hpirr.not_isUnit (g.isCoprime_num_denom.isUnit_of_dvd' hdvd ?_)
+      refine (ord_finitePlace_ne_zero_iff K hpirr hden0).mp ?_
+      rw [← hord]
+      exact (ord_finitePlace_ne_zero_iff K hpirr hnum0).mpr hdvd
+    · intro hdvd
+      refine hpirr.not_isUnit (g.isCoprime_num_denom.isUnit_of_dvd' ?_ hdvd)
+      refine (ord_finitePlace_ne_zero_iff K hpirr hnum0).mp ?_
+      rw [hord]
+      exact (ord_finitePlace_ne_zero_iff K hpirr hden0).mpr hdvd
+  have hunit : ∀ q : K[X], q ≠ 0 → (∀ p : K[X], Irreducible p → ¬p ∣ q) → IsUnit q := by
+    intro q hq hp
+    by_contra hu
+    obtain ⟨p, hpirr, hpdvd⟩ := WfDvdMonoid.exists_irreducible_factor hu hq
+    exact hp p hpirr hpdvd
+  obtain ⟨c₁, hc₁u, hc₁⟩ :=
+    Polynomial.isUnit_iff.mp (hunit g.num hnum0 fun p hp => (hkey p hp).1)
+  obtain ⟨c₂, hc₂u, hc₂⟩ :=
+    Polynomial.isUnit_iff.mp (hunit g.denom hden0 fun p hp => (hkey p hp).2)
+  have hc₁0 : c₁ ≠ 0 := fun h0 => hnum0 (by rw [← hc₁, h0, map_zero])
+  have hc₂0 : c₂ ≠ 0 := fun h0 => hden0 (by rw [← hc₂, h0, map_zero])
+  refine ⟨c₁ / c₂, div_ne_zero hc₁0 hc₂0, ?_⟩
+  rw [← g.num_div_denom, ← hc₁, ← hc₂, algebraMap_C, algebraMap_C, map_div₀]
+
+omit [IsAlgClosed K] in
+omit [DecidableEq (RatFunc K)] in
+theorem crossRatio_reciprocity {a a₀ b : K} (hba : b ≠ a) (hba₀ : b ≠ a₀) :
+    Divisor.evalFun
+        (algebraMap K[X] (RatFunc K) (X - C a) / algebraMap K[X] (RatFunc K) (X - C a₀))
+        (principalDivisor (algebraMap_polynomial_ne_zero (X_sub_C_ne_zero b)))
+      = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b))
+        (principalDivisor (div_ne_zero (algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a))
+          (algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a₀)))) := by
+  classical
+  rw [principalDivisor_X_sub_C b, principalDivisor_X_sub_C_div a a₀,
+    Divisor.evalFun_single_sub_single _
+      (by rw [evalAt_placeOfPoint_X_sub_C_div a a₀ hba₀]
+          exact div_ne_zero (sub_ne_zero.mpr hba) (sub_ne_zero.mpr hba₀))
+      (by rw [evalAt_placeInfty_X_sub_C_div a a₀]; exact one_ne_zero),
+    Divisor.evalFun_single_sub_single _
+      (by rw [evalAt_placeOfPoint_X_sub_C]
+          exact sub_ne_zero.mpr fun h => hba h.symm)
+      (by rw [evalAt_placeOfPoint_X_sub_C]
+          exact sub_ne_zero.mpr fun h => hba₀ h.symm),
+    evalAt_placeOfPoint_X_sub_C_div a a₀ hba₀, evalAt_placeInfty_X_sub_C_div a a₀,
+    evalAt_placeOfPoint_X_sub_C, evalAt_placeOfPoint_X_sub_C, div_one]
+  rw [div_eq_div_iff (sub_ne_zero.mpr hba₀) (sub_ne_zero.mpr fun h => hba₀ h.symm)]
+  ring
+
+omit [DecidableEq (RatFunc K)] in
+theorem reciprocity_of_forall_ord_eq_zero {f g : RatFunc K} (hf : f ≠ 0) (hg : g ≠ 0)
+    (hzero : ∀ v : Place K (RatFunc K), v.ord g = 0) :
+    Divisor.evalFun f (principalDivisor hg) = Divisor.evalFun g (principalDivisor hf) := by
+  obtain ⟨c, hc, rfl⟩ := exists_algebraMap_of_forall_ord_eq_zero hg hzero
+  exact reciprocity_algebraMap_right hf hc
+
+omit [IsAlgClosed K] [DecidableEq (RatFunc K)] in
+theorem ord_div_zpow (v : Place K (RatFunc K)) {g h : RatFunc K} (hg : g ≠ 0) (hh : h ≠ 0)
+    (m : ℤ) : v.ord (g / h ^ m) = v.ord g - m * v.ord h := by
+  rw [div_eq_mul_inv, v.ord_mul hg (inv_ne_zero (zpow_ne_zero m hh)), v.ord_inv, v.ord_zpow,
+    sub_eq_add_neg]
+
+omit [IsAlgClosed K] in
+theorem ord_X_sub_C_eq_zero_of_ne (b : K) {v : Place K (RatFunc K)}
+    (hvb : v ≠ placeOfPoint K b) (hvinf : v ≠ placeInfty K) :
+    v.ord (algebraMap K[X] (RatFunc K) (X - C b)) = 0 := by
+  rw [ord_X_sub_C b v, Finsupp.add_apply, Finsupp.single_eq_of_ne hvb,
+    Finsupp.single_eq_of_ne hvinf, add_zero]
+
+theorem reciprocity_linear (b : K) :
+    ∀ (n : ℕ) (f : RatFunc K) (hf : f ≠ 0),
+      (placeInfty K).ord f = 0 → (placeOfPoint K b).ord f = 0 →
+      (principalDivisor hf).support.card ≤ n →
+      Divisor.evalFun f
+          (principalDivisor (algebraMap_polynomial_ne_zero (X_sub_C_ne_zero b)))
+        = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b)) (principalDivisor hf) := by
+  have hLb : algebraMap K[X] (RatFunc K) (X - C b) ≠ 0 :=
+    algebraMap_polynomial_ne_zero (X_sub_C_ne_zero b)
+  intro n
+  induction n with
+  | zero =>
+    intro f hf hinf hb hcard
+    refine (reciprocity_of_forall_ord_eq_zero hLb hf fun v => ?_).symm
+    rw [← principalDivisor_apply hf v,
+      Finsupp.support_eq_empty.mp (Finset.card_eq_zero.mp (Nat.le_zero.mp hcard))]
+    rfl
+  | succ n ih =>
+    intro f hf hinf hb hcard
+    rcases Finset.eq_empty_or_nonempty (principalDivisor hf).support with hempty | hne
+    · refine (reciprocity_of_forall_ord_eq_zero hLb hf fun v => ?_).symm
+      rw [← principalDivisor_apply hf v, Finsupp.support_eq_empty.mp hempty]
+      rfl
+    have hsum := sum_ord_eq_zero hf
+    have hexpos : ∃ v ∈ (principalDivisor hf).support, 0 < v.ord f := by
+      by_contra hcon
+      have hcon' : ∀ v ∈ (principalDivisor hf).support, v.ord f ≤ 0 := fun v hv => by
+        by_contra hgt
+        exact hcon ⟨v, hv, not_le.mp hgt⟩
+      have hlt : ∑ v ∈ (principalDivisor hf).support, v.ord f
+          < ∑ v ∈ (principalDivisor hf).support, (0 : ℤ) :=
+        Finset.sum_lt_sum_of_nonempty hne fun v hv =>
+          lt_of_le_of_ne (hcon' v hv) (ord_ne_zero_of_mem_support hf hv)
+      rw [Finset.sum_const_zero, hsum] at hlt
+      exact lt_irrefl 0 hlt
+    have hexneg : ∃ v ∈ (principalDivisor hf).support, v.ord f < 0 := by
+      by_contra hcon
+      have hcon' : ∀ v ∈ (principalDivisor hf).support, 0 ≤ v.ord f := fun v hv => by
+        by_contra hgt
+        exact hcon ⟨v, hv, not_le.mp hgt⟩
+      have hlt : ∑ v ∈ (principalDivisor hf).support, (0 : ℤ)
+          < ∑ v ∈ (principalDivisor hf).support, v.ord f :=
+        Finset.sum_lt_sum_of_nonempty hne fun v hv =>
+          lt_of_le_of_ne (hcon' v hv) (Ne.symm (ord_ne_zero_of_mem_support hf hv))
+      rw [Finset.sum_const_zero, hsum] at hlt
+      exact lt_irrefl 0 hlt
+    obtain ⟨vp, hvp_mem, hvp⟩ := hexpos
+    obtain ⟨vn, hvn_mem, hvn⟩ := hexneg
+    obtain ⟨a, rfl⟩ : ∃ x : K, vp = placeOfPoint K x := by
+      rcases eq_placeOfPoint_or_eq_placeInfty K vp with h | h
+      · exact h
+      · rw [h, hinf] at hvp
+        exact absurd hvp (lt_irrefl 0)
+    obtain ⟨a₀, rfl⟩ : ∃ x : K, vn = placeOfPoint K x := by
+      rcases eq_placeOfPoint_or_eq_placeInfty K vn with h | h
+      · exact h
+      · rw [h, hinf] at hvn
+        exact absurd hvn (lt_irrefl 0)
+    have hab : a ≠ b := by
+      rintro rfl
+      rw [hb] at hvp
+      exact lt_irrefl 0 hvp
+    have ha₀b : a₀ ≠ b := by
+      rintro rfl
+      rw [hb] at hvn
+      exact lt_irrefl 0 hvn
+    have haa₀ : placeOfPoint K a ≠ placeOfPoint K a₀ := by
+      intro h
+      rw [h] at hvp
+      omega
+    have hLa : algebraMap K[X] (RatFunc K) (X - C a) ≠ 0 :=
+      algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a)
+    have hLa₀ : algebraMap K[X] (RatFunc K) (X - C a₀) ≠ 0 :=
+      algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a₀)
+    have hrne : algebraMap K[X] (RatFunc K) (X - C a) / algebraMap K[X] (RatFunc K) (X - C a₀)
+        ≠ 0 := div_ne_zero hLa hLa₀
+    have hord_r : ∀ v : Place K (RatFunc K),
+        v.ord (algebraMap K[X] (RatFunc K) (X - C a) / algebraMap K[X] (RatFunc K) (X - C a₀))
+          = (Finsupp.single (placeOfPoint K a) (1 : ℤ)
+              + Finsupp.single (placeOfPoint K a₀) (-1 : ℤ)) v := fun v => by
+      rw [← principalDivisor_apply hrne v, principalDivisor_X_sub_C_div a a₀]
+    set m : ℤ := (placeOfPoint K a).ord f with hm
+    have hrm_ne : (algebraMap K[X] (RatFunc K) (X - C a)
+        / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m ≠ 0 := zpow_ne_zero m hrne
+    have hf' : f / (algebraMap K[X] (RatFunc K) (X - C a)
+        / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m ≠ 0 := div_ne_zero hf hrm_ne
+    have hord_f' : ∀ v : Place K (RatFunc K),
+        v.ord (f / (algebraMap K[X] (RatFunc K) (X - C a)
+            / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m)
+          = v.ord f - m * (Finsupp.single (placeOfPoint K a) (1 : ℤ)
+              + Finsupp.single (placeOfPoint K a₀) (-1 : ℤ)) v := fun v => by
+      rw [ord_div_zpow v hf hrne m, hord_r v]
+    have hf'_inf : (placeInfty K).ord (f / (algebraMap K[X] (RatFunc K) (X - C a)
+        / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m) = 0 := by
+      rw [hord_f', hinf, Finsupp.add_apply,
+        Finsupp.single_eq_of_ne (Ne.symm (placeOfPoint_ne_placeInfty K a)),
+        Finsupp.single_eq_of_ne (Ne.symm (placeOfPoint_ne_placeInfty K a₀))]
+      ring
+    have hf'_b : (placeOfPoint K b).ord (f / (algebraMap K[X] (RatFunc K) (X - C a)
+        / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m) = 0 := by
+      rw [hord_f', hb, Finsupp.add_apply,
+        Finsupp.single_eq_of_ne
+          (show placeOfPoint K b ≠ placeOfPoint K a from
+            fun h => hab (placeOfPoint_injective K h).symm),
+        Finsupp.single_eq_of_ne
+          (show placeOfPoint K b ≠ placeOfPoint K a₀ from
+            fun h => ha₀b (placeOfPoint_injective K h).symm)]
+      ring
+    have hf'_a : (placeOfPoint K a).ord (f / (algebraMap K[X] (RatFunc K) (X - C a)
+        / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m) = 0 := by
+      rw [hord_f', Finsupp.add_apply, Finsupp.single_eq_same,
+        Finsupp.single_eq_of_ne haa₀, ← hm]
+      ring
+    have hsupp' : (principalDivisor hf').support
+        ⊆ (principalDivisor hf).support.erase (placeOfPoint K a) := by
+      intro v hv
+      have hvord := ord_ne_zero_of_mem_support hf' hv
+      rw [Finset.mem_erase]
+      constructor
+      · rintro rfl
+        exact hvord hf'_a
+      · rw [Finsupp.mem_support_iff, principalDivisor_apply]
+        intro hvf
+        apply hvord
+        rw [hord_f' v, hvf, Finsupp.add_apply]
+        rcases eq_or_ne v (placeOfPoint K a) with rfl | hva
+        · rw [hf'_a] at hvord
+          exact absurd rfl hvord
+        rcases eq_or_ne v (placeOfPoint K a₀) with rfl | hva₀
+        · rw [hvf] at hvn
+          exact absurd hvn (lt_irrefl 0)
+        · rw [Finsupp.single_eq_of_ne hva, Finsupp.single_eq_of_ne hva₀]
+          ring
+    have hcard' : (principalDivisor hf').support.card ≤ n := by
+      have h1 := Finset.card_le_card hsupp'
+      rw [Finset.card_erase_of_mem hvp_mem] at h1
+      omega
+    have hd_r_Lb : ∀ v : Place K (RatFunc K),
+        v.ord (algebraMap K[X] (RatFunc K) (X - C a)
+            / algebraMap K[X] (RatFunc K) (X - C a₀)) = 0
+          ∨ v.ord (algebraMap K[X] (RatFunc K) (X - C b)) = 0 := by
+      intro v
+      rcases eq_or_ne v (placeOfPoint K a) with rfl | hva
+      · exact Or.inr (ord_X_sub_C_placeOfPoint_of_ne hab)
+      rcases eq_or_ne v (placeOfPoint K a₀) with rfl | hva₀
+      · exact Or.inr (ord_X_sub_C_placeOfPoint_of_ne ha₀b)
+      · refine Or.inl ?_
+        rw [hord_r v, Finsupp.add_apply, Finsupp.single_eq_of_ne hva,
+          Finsupp.single_eq_of_ne hva₀]
+        ring
+    have hd_rm_Lb : ∀ v : Place K (RatFunc K),
+        v.ord ((algebraMap K[X] (RatFunc K) (X - C a)
+            / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m) = 0
+          ∨ v.ord (algebraMap K[X] (RatFunc K) (X - C b)) = 0 := fun v =>
+      (hd_r_Lb v).imp_left fun h => by rw [v.ord_zpow, h, mul_zero]
+    have hd_f'_Lb : ∀ v : Place K (RatFunc K),
+        v.ord (f / (algebraMap K[X] (RatFunc K) (X - C a)
+            / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m) = 0
+          ∨ v.ord (algebraMap K[X] (RatFunc K) (X - C b)) = 0 := by
+      intro v
+      rcases eq_or_ne v (placeOfPoint K b) with rfl | hvb
+      · exact Or.inl hf'_b
+      rcases eq_or_ne v (placeInfty K) with rfl | hvinf
+      · exact Or.inl hf'_inf
+      · exact Or.inr (ord_X_sub_C_eq_zero_of_ne b hvb hvinf)
+    have hcross_pow :
+        Divisor.evalFun ((algebraMap K[X] (RatFunc K) (X - C a)
+            / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m)
+          (principalDivisor hLb)
+        = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b))
+            (principalDivisor (zpow_ne_zero m hrne)) :=
+      reciprocity_zpow_left hrne hLb m hd_r_Lb
+        (crossRatio_reciprocity (fun h => hab h.symm) (fun h => ha₀b h.symm))
+    have hih :
+        Divisor.evalFun (f / (algebraMap K[X] (RatFunc K) (X - C a)
+            / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m)
+          (principalDivisor hLb)
+        = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b)) (principalDivisor hf') :=
+      ih _ hf' hf'_inf hf'_b hcard'
+    have hmul :
+        Divisor.evalFun ((algebraMap K[X] (RatFunc K) (X - C a)
+              / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m
+            * (f / (algebraMap K[X] (RatFunc K) (X - C a)
+              / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m))
+          (principalDivisor hLb)
+        = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b))
+            (principalDivisor (mul_ne_zero (zpow_ne_zero m hrne) hf')) :=
+      reciprocity_mul_left (zpow_ne_zero m hrne) hf' hLb hd_rm_Lb hd_f'_Lb hcross_pow hih
+    have hfeq : f = (algebraMap K[X] (RatFunc K) (X - C a)
+        / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m
+        * (f / (algebraMap K[X] (RatFunc K) (X - C a)
+          / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m) := by
+      rw [mul_comm, div_mul_cancel₀ _ hrm_ne]
+    calc Divisor.evalFun f (principalDivisor hLb)
+        = Divisor.evalFun ((algebraMap K[X] (RatFunc K) (X - C a)
+              / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m
+            * (f / (algebraMap K[X] (RatFunc K) (X - C a)
+              / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m))
+          (principalDivisor hLb) := by rw [← hfeq]
+      _ = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b))
+            (principalDivisor (mul_ne_zero (zpow_ne_zero m hrne) hf')) := hmul
+      _ = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b)) (principalDivisor hf) := by
+          rw [principalDivisor_congr (mul_ne_zero (zpow_ne_zero m hrne) hf') hf hfeq.symm]
+
+theorem reciprocity_of_ord_placeInfty_eq_zero :
+    ∀ (n : ℕ) (f g : RatFunc K) (hf : f ≠ 0) (hg : g ≠ 0),
+      (placeInfty K).ord f = 0 →
+      (∀ v : Place K (RatFunc K), v.ord f = 0 ∨ v.ord g = 0) →
+      ((principalDivisor hg).support.erase (placeInfty K)).card ≤ n →
+      Divisor.evalFun f (principalDivisor hg) = Divisor.evalFun g (principalDivisor hf) := by
+  have hbase : ∀ (f g : RatFunc K) (hf : f ≠ 0) (hg : g ≠ 0),
+      (principalDivisor hg).support.erase (placeInfty K) = ∅ →
+      Divisor.evalFun f (principalDivisor hg) = Divisor.evalFun g (principalDivisor hf) := by
+    intro f g hf hg hempty
+    refine reciprocity_of_forall_ord_eq_zero hf hg fun v => ?_
+    by_contra hv
+    have hvmem : v ∈ (principalDivisor hg).support := by
+      rw [Finsupp.mem_support_iff, principalDivisor_apply]
+      exact hv
+    have hsubset : (principalDivisor hg).support ⊆ {placeInfty K} := by
+      intro w hw
+      rw [Finset.mem_singleton]
+      by_contra hwne
+      exact absurd (hempty ▸ Finset.mem_erase.mpr ⟨hwne, hw⟩) (Finset.notMem_empty w)
+    have hsupp_eq : (principalDivisor hg).support = {placeInfty K} :=
+      Finset.Subset.antisymm hsubset
+        (Finset.singleton_subset_iff.mpr (Finset.mem_singleton.mp (hsubset hvmem) ▸ hvmem))
+    have hsum := sum_ord_eq_zero hg
+    rw [hsupp_eq, Finset.sum_singleton] at hsum
+    rw [Finset.mem_singleton.mp (hsubset hvmem)] at hv
+    exact hv hsum
+  intro n
+  induction n with
+  | zero =>
+    intro f g hf hg hinf hd hcard
+    exact hbase f g hf hg (Finset.card_eq_zero.mp (Nat.le_zero.mp hcard))
+  | succ n ih =>
+    intro f g hf hg hinf hd hcard
+    rcases Finset.eq_empty_or_nonempty
+      ((principalDivisor hg).support.erase (placeInfty K)) with hempty | hne
+    · exact hbase f g hf hg hempty
+    obtain ⟨vb, hvb⟩ := hne
+    rw [Finset.mem_erase] at hvb
+    obtain ⟨b, rfl⟩ : ∃ x : K, vb = placeOfPoint K x := by
+      rcases eq_placeOfPoint_or_eq_placeInfty K vb with h | h
+      · exact h
+      · exact absurd h hvb.1
+    have hordb : (placeOfPoint K b).ord g ≠ 0 := ord_ne_zero_of_mem_support hg hvb.2
+    have hfb : (placeOfPoint K b).ord f = 0 := (hd _).resolve_right hordb
+    have hLb : algebraMap K[X] (RatFunc K) (X - C b) ≠ 0 :=
+      algebraMap_polynomial_ne_zero (X_sub_C_ne_zero b)
+    set m : ℤ := (placeOfPoint K b).ord g with hm
+    have hLbm : (algebraMap K[X] (RatFunc K) (X - C b)) ^ m ≠ 0 := zpow_ne_zero m hLb
+    have hg' : g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m ≠ 0 := div_ne_zero hg hLbm
+    have hord_g' : ∀ v : Place K (RatFunc K),
+        v.ord (g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m)
+          = v.ord g - m * v.ord (algebraMap K[X] (RatFunc K) (X - C b)) := fun v =>
+      ord_div_zpow v hg hLb m
+    have hg'_b : (placeOfPoint K b).ord
+        (g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m) = 0 := by
+      rw [hord_g', ord_X_sub_C_placeOfPoint_self, ← hm]
+      ring
+    have hsupp' : (principalDivisor hg').support.erase (placeInfty K)
+        ⊆ ((principalDivisor hg).support.erase (placeInfty K)).erase (placeOfPoint K b) := by
+      intro v hv
+      rw [Finset.mem_erase] at hv
+      have hvord := ord_ne_zero_of_mem_support hg' hv.2
+      rw [Finset.mem_erase, Finset.mem_erase]
+      refine ⟨?_, hv.1, ?_⟩
+      · rintro rfl
+        exact hvord hg'_b
+      · rw [Finsupp.mem_support_iff, principalDivisor_apply]
+        intro hvg
+        apply hvord
+        rw [hord_g' v, hvg,
+          ord_X_sub_C_eq_zero_of_ne b (fun h => hvord (by rw [h]; exact hg'_b)) hv.1]
+        ring
+    have hcard' : ((principalDivisor hg').support.erase (placeInfty K)).card ≤ n := by
+      have h1 := Finset.card_le_card hsupp'
+      rw [Finset.card_erase_of_mem (Finset.mem_erase.mpr hvb)] at h1
+      omega
+    have hd_f_Lb : ∀ v : Place K (RatFunc K),
+        v.ord f = 0 ∨ v.ord (algebraMap K[X] (RatFunc K) (X - C b)) = 0 := by
+      intro v
+      rcases eq_or_ne v (placeOfPoint K b) with rfl | hvb'
+      · exact Or.inl hfb
+      rcases eq_or_ne v (placeInfty K) with rfl | hvinf
+      · exact Or.inl hinf
+      · exact Or.inr (ord_X_sub_C_eq_zero_of_ne b hvb' hvinf)
+    have hd_f_Lbm : ∀ v : Place K (RatFunc K),
+        v.ord f = 0 ∨ v.ord ((algebraMap K[X] (RatFunc K) (X - C b)) ^ m) = 0 := fun v =>
+      (hd_f_Lb v).imp_right fun h => by rw [v.ord_zpow, h, mul_zero]
+    have hd_f_g' : ∀ v : Place K (RatFunc K),
+        v.ord f = 0 ∨ v.ord (g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m) = 0 := by
+      intro v
+      by_cases hv : v.ord f = 0
+      · exact Or.inl hv
+      · refine Or.inr ?_
+        rw [hord_g' v, (hd v).resolve_left hv, (hd_f_Lb v).resolve_left hv, mul_zero,
+          sub_zero]
+    have hlin :
+        Divisor.evalFun f (principalDivisor hLb)
+          = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b)) (principalDivisor hf) :=
+      reciprocity_linear b (principalDivisor hf).support.card f hf hinf hfb le_rfl
+    have hlin_pow :
+        Divisor.evalFun f (principalDivisor hLbm)
+          = Divisor.evalFun ((algebraMap K[X] (RatFunc K) (X - C b)) ^ m)
+              (principalDivisor hf) :=
+      reciprocity_zpow_right hf hLb m hd_f_Lb hlin
+    have hih :
+        Divisor.evalFun f (principalDivisor hg')
+          = Divisor.evalFun (g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m)
+              (principalDivisor hf) :=
+      ih f _ hf hg' hinf hd_f_g' hcard'
+    have hmul :
+        Divisor.evalFun f (principalDivisor (mul_ne_zero hLbm hg'))
+          = Divisor.evalFun ((algebraMap K[X] (RatFunc K) (X - C b)) ^ m
+              * (g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m)) (principalDivisor hf) :=
+      reciprocity_mul_right hf hLbm hg' hd_f_Lbm hd_f_g' hlin_pow hih
+    have hgeq : g = (algebraMap K[X] (RatFunc K) (X - C b)) ^ m
+        * (g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m) := by
+      rw [mul_comm, div_mul_cancel₀ _ hLbm]
+    calc Divisor.evalFun f (principalDivisor hg)
+        = Divisor.evalFun f (principalDivisor (mul_ne_zero hLbm hg')) := by
+          rw [principalDivisor_congr hg (mul_ne_zero hLbm hg') hgeq]
+      _ = Divisor.evalFun ((algebraMap K[X] (RatFunc K) (X - C b)) ^ m
+            * (g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m)) (principalDivisor hf) := hmul
+      _ = Divisor.evalFun g (principalDivisor hf) := by rw [← hgeq]
+
+end Reciprocity
+end RationalFunctionField
+end AlgebraicCurve
+end
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_isAlgClosed.AlgebraicCurve in
+theorem solution (K : Type*) [Field K] [IsAlgClosed K] (v : Place K (RatFunc K)) : v.deg = 1 :=
+  AlgebraicCurve.RationalFunctionField.deg_eq_one_of_isAlgClosed K v
+
+end S_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_isAlgClosed
+end P2MW
+export P2MW.S_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_isAlgClosed (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve AlgebraicCurve.RationalFunctionField
+theorem AlgebraicCurve.RationalFunctionField.deg_eq_one_of_isAlgClosed (K : Type*) [Field K]
+    [IsAlgClosed K] (v : Place K (RatFunc K)) :
+    v.deg = 1 :=
+  solution K v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_deg_ne_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_deg_ne_zero.lean
new file mode 100644
index 0000000000..84810049ff
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_deg_ne_zero.lean
@@ -0,0 +1,99 @@
+/-
+Based on Prove2Me node AlgebraicCurve.RationalFunctionField.deg_ne_zero
+(9cd09f93-3ea8-5bf3-8a57-2218fb4588eb) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 494a1722-ba29-5743-be03-96e4b40d3f61
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_forall_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_deg_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Places of K(t) have nonzero degree
+
+Theorem statement: `AlgebraicCurve.RationalFunctionField.deg_ne_zero`
+(`9cd09f93-3ea8-5bf3-8a57-2218fb4588eb`), by Claude, 2026-09-05.
+
+Proof: submission `494a1722-ba29-5743-be03-96e4b40d3f61`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $v$ be a place of the rational function field $\mathrm{RatFunc}\,K$ over
+$K$ in the sense of the project's structure `Place`: a valuation subring $\mathcal{O}_v$ of
+$\mathrm{RatFunc}\,K$ that contains $\mathrm{algebraMap}\,K\,(\mathrm{RatFunc}\,K)(a)$ for every $a
+\in K$, is not the whole field, and is a principal ideal ring. Its degree $v.\mathrm{deg}$ is
+defined to be the $K$-rank $\mathrm{Module.finrank}\,K$ of the residue field
+$\mathcal{O}_v/\mathfrak{m}_v$, that is, of `IsLocalRing.ResidueField v.toValuationSubring`, viewed
+as a $K$-vector space via the structure map. The assertion is that this natural number is nonzero.
+Since `Module.finrank` returns $0$ both for the zero module and for modules that are not
+finite-dimensional, the statement simultaneously says that the residue field of every place of
+$K(t)$ is a finite extension of $K$ and that it is nontrivial; equivalently, the junk value $0$
+never occurs, so $v.\mathrm{deg} \geq 1$ always holds.
+
+This is the statement that the residue degree of a place of a rational function field is finite and
+positive, the basic finiteness needed before degrees of divisors on $\mathbb{P}^1_K$ can be
+manipulated. It is used for the non-vanishing of degrees of places in finite extensions of $K(t)$
+and, through that, for places of the modular function field and for counting arguments on modular
+curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_deg_ne_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_RationalFunctionField_deg_ne_zero
+
+open AlgebraicCurve IsDedekindDomain Polynomial
+
+theorem solution {K : Type*} [Field K] (v : Place K (RatFunc K)) : v.deg ≠ 0 := by
+  by_cases h : ∀ w : HeightOneSpectrum K[X], v ≠ Place.ofHeightOneSpectrum w
+  · rw [RationalFunctionField.deg_eq_one_of_forall_ne_ofHeightOneSpectrum v h]
+    exact one_ne_zero
+  · obtain ⟨w, hw⟩ : ∃ w : HeightOneSpectrum K[X], v = Place.ofHeightOneSpectrum w := by
+      simpa using h
+    subst hw
+    obtain ⟨p, hp⟩ := Submodule.IsPrincipal.principal w.asIdeal
+    rw [RationalFunctionField.deg_ofHeightOneSpectrum K hp]
+    have hp0 : p ≠ 0 := by
+      intro h0
+      apply w.ne_bot
+      rw [hp, h0]
+      exact Ideal.span_singleton_eq_bot.mpr rfl
+    have hprime : Prime p := by
+      have hpr := w.isPrime
+      rw [hp] at hpr
+      exact (Ideal.span_singleton_prime hp0).mp hpr
+    exact (natDegree_pos_iff_degree_pos.mpr (degree_pos_of_irreducible hprime.irreducible)).ne'
+
+end S_AlgebraicCurve_RationalFunctionField_deg_ne_zero
+end P2MW
+export P2MW.S_AlgebraicCurve_RationalFunctionField_deg_ne_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.RationalFunctionField.deg_ne_zero {K : Type*} [Field K]
+    (v : Place K (RatFunc K)) :
+    v.deg ≠ 0 :=
+  solution v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_deg_placeInfty.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_deg_placeInfty.lean
new file mode 100644
index 0000000000..b80fceb6cb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_deg_placeInfty.lean
@@ -0,0 +1,88 @@
+/-
+Based on Prove2Me node AlgebraicCurve.RationalFunctionField.deg_placeInfty
+(7dae8346-786a-5cde-b729-973c2fb2060b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 760195a1-b9a3-5915-8ee2-38787c67d16c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceInfty
+
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_placeInfty_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_forall_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The place at infinity of K(t) has degree one
+
+Theorem statement: `AlgebraicCurve.RationalFunctionField.deg_placeInfty`
+(`7dae8346-786a-5cde-b729-973c2fb2060b`), by Claude, 2026-09-05.
+
+Proof: submission `760195a1-b9a3-5915-8ee2-38787c67d16c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field. Consider the rational function field $\mathrm{RatFunc}\,K$ and the place
+$\mathtt{placeInfty}\ K$ of $\mathrm{RatFunc}\,K$ over $K$, that is, the datum consisting of the
+valuation subring attached to the infinity valuation `RatFunc.inftyValuation K` of
+$\mathrm{RatFunc}\,K$, together with the verifications required by the structure `Place`: that every
+element $\mathrm{algebraMap}\,K\,(\mathrm{RatFunc}\,K)(a)$, $a \in K$, lies in this subring (the
+infinity valuation is trivial on the constants), that the subring is not all of
+$\mathrm{RatFunc}\,K$, and that it is a principal ideal ring (being a discrete valuation ring). The
+degree of a place $v$ is by definition $\mathrm{Module.finrank}$ over $K$ of its residue field, the
+residue field of the local ring $v.\mathtt{toValuationSubring}$. The assertion is that
+$(\mathtt{placeInfty}\ K).\deg = 1$, i.e. the residue field of the infinity valuation ring of $K(t)$
+is one-dimensional as a $K$-vector space, so that the place at infinity is a rational place. No
+hypothesis on $K$ beyond being a field is imposed.
+
+This is the classical fact that, among the places of the rational function field $K(t)$ — the monic
+irreducible polynomials together with $\infty$ — the place at infinity is rational, its residue
+field being $K$ itself. It identifies the named place at infinity as a degree-one point of
+$\mathbb{P}^1$ and is used throughout the function-field foundations, for instance in the
+Riemann–Roch-style computations for $K(t)$ such as
+[`AlgebraicCurve.RationalFunctionField.ell_sub_ell_eq_genus_zero`]
+(thm.html#AlgebraicCurve.RationalFunctionField.ell_sub_ell_eq_genus_zero)
+and the finite-dimensionality of the space attached to the zero divisor.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_deg_placeInfty.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_RationalFunctionField_deg_placeInfty
+
+open IsDedekindDomain AlgebraicCurve AlgebraicCurve.RationalFunctionField
+
+theorem solution (K : Type*) [Field K] [DecidableEq (RatFunc K)] : (placeInfty K).deg = 1 :=
+  AlgebraicCurve.RationalFunctionField.deg_eq_one_of_forall_ne_ofHeightOneSpectrum (placeInfty K)
+    (AlgebraicCurve.RationalFunctionField.placeInfty_ne_ofHeightOneSpectrum K)
+
+end S_AlgebraicCurve_RationalFunctionField_deg_placeInfty
+end P2MW
+export P2MW.S_AlgebraicCurve_RationalFunctionField_deg_placeInfty (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve AlgebraicCurve.RationalFunctionField
+theorem AlgebraicCurve.RationalFunctionField.deg_placeInfty (K : Type*) [Field K]
+    [DecidableEq (RatFunc K)] :
+    (placeInfty K).deg = 1 :=
+  solution K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord.lean
new file mode 100644
index 0000000000..d10048b39b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord.lean
@@ -0,0 +1,113 @@
+/-
+Based on Prove2Me node AlgebraicCurve.RationalFunctionField.degree_eq_zero_of_forall_eq_ord
+(f5bb46d2-4a6d-59d3-a6b3-9b660446d26c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b7b39db5-4b47-5f92-aa17-01d45c4af7a5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_finite_setOf_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Divisors of rational functions on P¹ have degree zero
+
+Theorem statement: `AlgebraicCurve.RationalFunctionField.degree_eq_zero_of_forall_eq_ord`
+(`f5bb46d2-4a6d-59d3-a6b3-9b660446d26c`), by Claude, 2026-09-05.
+
+Proof: submission `b7b39db5-4b47-5f92-aa17-01d45c4af7a5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $f$ be an element of the rational function field $\mathrm{RatFunc}\,K$.
+Here a place of $\mathrm{RatFunc}\,K$ over $K$ is a valuation subring of $\mathrm{RatFunc}\,K$ that
+contains the image of $K$, is not the whole field, and is a principal ideal ring; for such a place
+$v$ and an element $g$, $v.\mathrm{ord}\,g$ is the integer $-\log$ of the value of $g$ under the
+$\mathbb{Z}^{m0}$-valued adic valuation attached to $v$, i.e. the order of vanishing of $g$ at $v$.
+A divisor is a finitely supported function $D$ from the set of such places to $\mathbb{Z}$, and its
+degree is the finite sum $\sum_v D(v)\cdot \deg v$, where $\deg v$ is the degree attached to the
+place $v$. The assertion is: if $D$ is a divisor such that $D(v) = v.\mathrm{ord}\,f$ for every
+place $v$ of $\mathrm{RatFunc}\,K$ over $K$, then $\mathrm{Divisor.degree}\,D = 0$. No nonvanishing
+hypothesis on $f$ is imposed; for $f = 0$ the hypothesis forces $D = 0$.
+
+This is the degree-zero property of principal divisors (the sum, or product, formula) for the
+rational function field $K(t)$, that is, for $\mathbb{P}^1_K$. It underlies the computation of the
+divisor class group of the rational function field and is used, among other things, to show that
+places of $K(t)$ have degree one when $K$ is algebraically closed and to evaluate divisors at the
+place at infinity.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord
+
+open AlgebraicCurve
+open IsDedekindDomain WithZero IsLocalRing
+open scoped Polynomial
+
+theorem solution {K : Type*} [Field K] {f : RatFunc K} (D : Divisor K (RatFunc K))
+    (hD : ∀ v : Place K (RatFunc K), D v = v.ord f) :
+    Divisor.degree D = 0 := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · have hzero : D = 0 := by
+      ext v
+      simp [hD v]
+    rw [hzero, map_zero]
+  · have hden : f.denom ≠ 0 := f.denom_ne_zero
+    have hdenF : algebraMap K[X] (RatFunc K) f.denom ≠ 0 := RatFunc.algebraMap_ne_zero hden
+    set Dden : Divisor K (RatFunc K) :=
+      Finsupp.ofSupportFinite
+        (fun v : Place K (RatFunc K) => v.ord (algebraMap K[X] (RatFunc K) f.denom))
+        (AlgebraicCurve.RationalFunctionField.finite_setOf_ord_ne_zero hdenF) with hDden_def
+    have hDden : ∀ v : Place K (RatFunc K),
+        Dden v = v.ord (algebraMap K[X] (RatFunc K) f.denom) := fun v => rfl
+    have hsplit : ∀ v : Place K (RatFunc K),
+        (D + Dden) v = v.ord (algebraMap K[X] (RatFunc K) f.num) := by
+      intro v
+      rw [Finsupp.add_apply, hD v, hDden v]
+      have hmul : f * algebraMap K[X] (RatFunc K) f.denom
+          = algebraMap K[X] (RatFunc K) f.num :=
+        ((div_eq_iff hdenF).mp f.num_div_denom).symm
+      have h2 := v.ord_mul hf hdenF
+      rw [hmul] at h2
+      exact h2.symm
+    have h1 := AlgebraicCurve.RationalFunctionField.degree_eq_zero_of_forall_eq_ord_algebraMap
+      f.num (D + Dden) hsplit
+    have h2 := AlgebraicCurve.RationalFunctionField.degree_eq_zero_of_forall_eq_ord_algebraMap
+      f.denom Dden hDden
+    rw [map_add, h2, add_zero] at h1
+    exact h1
+
+end S_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord
+end P2MW
+export P2MW.S_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.RationalFunctionField.degree_eq_zero_of_forall_eq_ord {K : Type*} [Field K]
+    {f : RatFunc K} (D : Divisor K (RatFunc K)) (hD : ∀ v : Place K (RatFunc K), D v = v.ord f) :
+    Divisor.degree D = 0 :=
+  solution D hD
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord_algebraMap.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord_algebraMap.lean
new file mode 100644
index 0000000000..23e2e880ce
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord_algebraMap.lean
@@ -0,0 +1,230 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.RationalFunctionField.degree_eq_zero_of_forall_eq_ord_algebraMap
+(ba5de16f-1086-5701-903d-c960fbd0bc4d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 53133994-14a7-53b6-900f-486e09a3ccaa
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.FieldTheory.RatFunc.Degree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_exists_forall_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_subsingleton_setOf_forall_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_of_span
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_eq_neg_intDegree_of_forall_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_deg_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_eq_one_of_forall_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_ofHeightOneSpectrum_ne_zero_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Divisors cut out by a polynomial have degree zero
+
+Theorem statement: `AlgebraicCurve.RationalFunctionField.degree_eq_zero_of_forall_eq_ord_algebraMap`
+(`ba5de16f-1086-5701-903d-c960fbd0bc4d`), by Claude, 2026-09-05.
+
+Proof: submission `53133994-14a7-53b6-900f-486e09a3ccaa`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and $q \in K[X]$ a polynomial. The assertion is about divisors of the rational
+function field $K(t) =$ `RatFunc K` over $K$, a divisor being a finitely supported function $D$ from
+the type `Place K (RatFunc K)` of places to $\mathbb{Z}$; here a place consists of a valuation
+subring of $K(t)$ that contains the image of $K$ under the structure map, is not all of $K(t)$, and
+is a principal ideal ring. For such a place $v$, $v.\mathrm{ord}(f)$ denotes $-\log$ of the value at
+$f$ of the $\mathbb{Z}^{m0}$-valued adic valuation attached to the height one prime of $v$, and the
+degree of a divisor is the finite sum $\sum_v D(v)\cdot v.\mathrm{deg}$, where $v.\mathrm{deg}$ is
+the degree attached to the place $v$ (a natural number, cast into $\mathbb{Z}$). The theorem states:
+for every divisor $D$ of $K(t)$ over $K$ such that $D(v) = v.\mathrm{ord}\bigl(\iota(q)\bigr)$ for
+every place $v$, where $\iota : K[X] \to K(t)$ is the structure map, the degree of $D$ is $0$.
+Nothing is claimed about the existence of such a $D$ for a given $q$.
+
+This is the degree-zero property of principal divisors in the special case of the rational function
+field, for divisors coming from a polynomial: in classical terms, $\sum_v
+\operatorname{ord}_v(q)\deg(v) = 0$, the finite places contributing $\deg p$ for each irreducible
+factor $p$ and the place at infinity contributing $-\deg q$. It is used in the passage to arbitrary
+rational functions and in the vanishing of the sum of local residues over the finite places of
+$K(t)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord_algebraMap.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord_algebraMap
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord_algebraMap.AlgebraicC\
+  urve"
+open IsDedekindDomain WithZero IsLocalRing
+open scoped Polynomial
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor Divisor.degree Divisor.degree_single \
+  Place.ofHeightOneSpectrum RationalFunctionField.exists_forall_ne_ofHeightOneSpectrum \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff"
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "exists_forall_ne_ofHeightOneSpectrum \
+  subsingleton_setOf_forall_ne_ofHeightOneSpectrum ord_ofHeightOneSpectrum_of_span \
+  ord_eq_neg_intDegree_of_forall_ne_ofHeightOneSpectrum deg_ofHeightOneSpectrum \
+  deg_eq_one_of_forall_ne_ofHeightOneSpectrum"
+p2m_open "AlgebraicCurve.RationalFunctionField~finitePlace~heightOneSpectrumOfIrreducible_asIdeal~h\
+  eightOneSpectrumOfIrreducible AlgebraicCurve"
+
+namespace WFj
+variable (K : Type*) [Field K]
+
+def heightOneSpectrumOfIrreducible {p : K[X]} (hp : Irreducible p) :
+    HeightOneSpectrum K[X] where
+  asIdeal := Ideal.span {p}
+  isPrime := (PrincipalIdealRing.isMaximal_of_irreducible hp).isPrime
+  ne_bot := by simpa [Ideal.span_singleton_eq_bot] using hp.ne_zero
+
+theorem heightOneSpectrumOfIrreducible_asIdeal {p : K[X]} (hp : Irreducible p) :
+    (heightOneSpectrumOfIrreducible K hp).asIdeal = Ideal.span {p} := rfl
+
+def finitePlace {p : K[X]} (hp : Irreducible p) : Place K (RatFunc K) :=
+  Place.ofHeightOneSpectrum (heightOneSpectrumOfIrreducible K hp)
+
+variable {K}
+
+theorem ne_finitePlace_of_forall_ne {v : Place K (RatFunc K)}
+    (hv : ∀ w : HeightOneSpectrum K[X], v ≠ Place.ofHeightOneSpectrum w) {p : K[X]}
+    (hp : Irreducible p) :
+    v ≠ finitePlace K hp :=
+  hv _
+
+theorem single_add_single_apply_eq_ord {vinf : Place K (RatFunc K)}
+    (hvinf : ∀ w : HeightOneSpectrum K[X], vinf ≠ Place.ofHeightOneSpectrum w)
+    {p : K[X]} (hp : Irreducible p) (v : Place K (RatFunc K)) :
+    (Finsupp.single (finitePlace K hp) (1 : ℤ)
+        + Finsupp.single vinf (-(p.natDegree : ℤ))) v
+      = v.ord (algebraMap K[X] (RatFunc K) p) := by
+  have hp0 : p ≠ 0 := hp.ne_zero
+  rw [Finsupp.add_apply]
+  by_cases hfin : ∃ w : HeightOneSpectrum K[X], v = Place.ofHeightOneSpectrum w
+  · obtain ⟨w, rfl⟩ := hfin
+    rw [Finsupp.single_eq_of_ne (hvinf w).symm, add_zero]
+    by_cases hcase :
+        Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w = finitePlace K hp
+    · rw [hcase, Finsupp.single_eq_same]
+      exact (ord_ofHeightOneSpectrum_of_span (heightOneSpectrumOfIrreducible K hp) hp0
+        (heightOneSpectrumOfIrreducible_asIdeal K hp)).symm
+    · rw [Finsupp.single_eq_of_ne hcase]
+      symm
+      by_contra hne
+      refine hcase ?_
+      have hmem : p ∈ w.asIdeal :=
+        (Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w hp0).mp hne
+      have hspan : Ideal.span {p} = w.asIdeal :=
+        (PrincipalIdealRing.isMaximal_of_irreducible hp).eq_of_le w.isPrime.ne_top
+          ((Ideal.span_singleton_le_iff_mem _).mpr hmem)
+      have hwp : w = heightOneSpectrumOfIrreducible K hp :=
+        HeightOneSpectrum.ext
+          (hspan.symm.trans (heightOneSpectrumOfIrreducible_asIdeal K hp).symm)
+      rw [hwp]
+      rfl
+  · have hv : ∀ w : HeightOneSpectrum K[X], v ≠ Place.ofHeightOneSpectrum w :=
+      fun w h => hfin ⟨w, h⟩
+    have hveq : v = vinf := subsingleton_setOf_forall_ne_ofHeightOneSpectrum hv hvinf
+    rw [Finsupp.single_eq_of_ne (show v ≠ finitePlace K hp from hv _), zero_add, hveq,
+      Finsupp.single_eq_same,
+      ord_eq_neg_intDegree_of_forall_ne_ofHeightOneSpectrum vinf hvinf (RatFunc.algebraMap_ne_zero
+      hp0),
+      RatFunc.intDegree_polynomial]
+
+theorem degree_single_add_single {vinf : Place K (RatFunc K)}
+    (hvinf : ∀ w : HeightOneSpectrum K[X], vinf ≠ Place.ofHeightOneSpectrum w)
+    {p : K[X]} (hp : Irreducible p) :
+    Divisor.degree (Finsupp.single (finitePlace K hp) (1 : ℤ)
+        + Finsupp.single vinf (-(p.natDegree : ℤ))) = 0 := by
+  rw [map_add, Divisor.degree_single, Divisor.degree_single,
+    show (finitePlace K hp).deg = p.natDegree from
+      deg_ofHeightOneSpectrum K (heightOneSpectrumOfIrreducible_asIdeal K hp),
+    deg_eq_one_of_forall_ne_ofHeightOneSpectrum vinf hvinf]
+  push_cast
+  ring
+
+end WFj
+
+end AlgebraicCurve.RationalFunctionField
+
+end
+
+theorem solution {K : Type*} [Field K] (q : Polynomial K) :
+    ∀ D : Divisor K (RatFunc K), (∀ v : Place K (RatFunc K), D v = v.ord (algebraMap (Polynomial K)
+      (RatFunc K) q)) → Divisor.degree D = 0 := by
+  classical
+  obtain ⟨vinf, hvinf⟩ :=
+    AlgebraicCurve.RationalFunctionField.exists_forall_ne_ofHeightOneSpectrum (K := K)
+  refine UniqueFactorizationMonoid.induction_on_prime q ?_ ?_ ?_
+  · intro D hD
+    have hzero : D = 0 := by
+      ext v
+      simp [hD v]
+    rw [hzero, map_zero]
+  · intro x hx D hD
+    obtain ⟨r, -, rfl⟩ := Polynomial.isUnit_iff.mp hx
+    have hC : (algebraMap K[X] (RatFunc K)) (Polynomial.C r) = algebraMap K (RatFunc K) r := by
+      rw [← Polynomial.algebraMap_eq, ← IsScalarTower.algebraMap_apply]
+    have hzero : D = 0 := by
+      ext v
+      rw [hD v, hC, v.ord_algebraMap]
+      simp
+    rw [hzero, map_zero]
+  · intro a p ha hp ih D hD
+    have hp' : algebraMap K[X] (RatFunc K) p ≠ 0 := RatFunc.algebraMap_ne_zero hp.ne_zero
+    have ha' : algebraMap K[X] (RatFunc K) a ≠ 0 := RatFunc.algebraMap_ne_zero ha
+    set Dp : Divisor K (RatFunc K) :=
+      Finsupp.single (AlgebraicCurve.RationalFunctionField.WFj.finitePlace K hp.irreducible) (1 : ℤ)
+        + Finsupp.single vinf (-(p.natDegree : ℤ)) with hDp_def
+    have hDp : ∀ v : Place K (RatFunc K), Dp v = v.ord (algebraMap K[X] (RatFunc K) p) :=
+      fun v => AlgebraicCurve.RationalFunctionField.WFj.single_add_single_apply_eq_ord hvinf
+        hp.irreducible v
+    have hDa : ∀ v : Place K (RatFunc K),
+        (D - Dp) v = v.ord (algebraMap K[X] (RatFunc K) a) := by
+      intro v
+      rw [Finsupp.sub_apply, hD v, hDp v, map_mul, v.ord_mul hp' ha']
+      ring
+    have hdeg_p : Divisor.degree Dp = 0 :=
+      AlgebraicCurve.RationalFunctionField.WFj.degree_single_add_single hvinf hp.irreducible
+    have hdeg_a : Divisor.degree (D - Dp) = 0 := ih (D - Dp) hDa
+    have hsplit : D = Dp + (D - Dp) := by abel
+    rw [hsplit, map_add, hdeg_p, zero_add]
+    exact hdeg_a
+
+end S_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord_algebraMap
+end P2MW
+export P2MW.S_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord_algebraMap
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.RationalFunctionField.degree_eq_zero_of_forall_eq_ord_algebraMap {K : Type*}
+    [Field K] (q : Polynomial K) :
+    ∀ D : Divisor K (RatFunc K), (∀ v : Place K (RatFunc K), D v = v.ord (algebraMap (Polynomial K)
+      (RatFunc K) q)) → Divisor.degree D = 0 :=
+  solution q
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_eq_placeInfty_iff_forall_ne_ofHeightOneSpectrum.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_eq_placeInfty_iff_forall_ne_ofHeightOneSpectrum.lean
new file mode 100644
index 0000000000..261e5143ea
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_eq_placeInfty_iff_forall_ne_ofHeightOneSpectrum.lean
@@ -0,0 +1,94 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.RationalFunctionField.eq_placeInfty_iff_forall_ne_ofHeightOneSpectrum
+(5dc01e2e-6b78-580e-ae5e-511e2495ea8f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2e7eae80-5114-5bf8-84dd-43b5162fd0d1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceInfty
+
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_placeInfty_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_subsingleton_setOf_forall_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The infinite place of K(t) characterised among all places
+
+Theorem statement:
+`AlgebraicCurve.RationalFunctionField.eq_placeInfty_iff_forall_ne_ofHeightOneSpectrum`
+(`5dc01e2e-6b78-580e-ae5e-511e2495ea8f`), by Claude, 2026-09-05.
+
+Proof: submission `2e7eae80-5114-5bf8-84dd-43b5162fd0d1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field. Work with the type `Place K (RatFunc K)` of places of the rational function
+field $K(t)$ over $K$, an element of which consists of a valuation subring of $K(t)$ that contains
+$\mathrm{algebraMap}\,K\,K(t)(a)$ for every $a \in K$, is not all of $K(t)$, and is a principal
+ideal ring. For such a $v$, the theorem asserts the equivalence: $v$ equals `placeInfty K`, the
+place whose valuation subring is the valuation subring of the degree-at-infinity valuation
+`RatFunc.inftyValuation K` of $K(t)$, if and only if for every height-one prime $w$ of the
+polynomial ring $K[X]$ one has $v \neq$ `Place.ofHeightOneSpectrum w`, the latter being the place
+whose valuation subring is that of the $w$-adic valuation of $K(t)$ attached to $w$ by the Dedekind
+domain $K[X]$. Thus the place at infinity is exactly the place of $K(t)/K$ which is not the $w$-adic
+place of any nonzero prime of $K[X]$.
+
+This is the classical description of the places of the rational function field: they are the
+$P$-adic places for $P$ a monic irreducible polynomial together with the single place at infinity;
+here that description is packaged as an intrinsic characterisation of `placeInfty K`, so that the
+infinite place can be recognised by a property not mentioning its construction. It is used to split
+the places of $K(t)$ into the finite ones and the one at infinity, and in the treatment of places on
+modular curves via prolongation pairs and chart data.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_eq_placeInfty_iff_forall_ne_ofHeightOneSpectrum.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_e6aa63aa
+
+open IsDedekindDomain AlgebraicCurve AlgebraicCurve.RationalFunctionField
+
+theorem solution {K : Type*} [Field K] [DecidableEq (RatFunc K)] (v : Place K (RatFunc K)) :
+    v = placeInfty K ↔ ∀ w : IsDedekindDomain.HeightOneSpectrum (Polynomial K), v ≠
+      Place.ofHeightOneSpectrum w := by
+  constructor
+  · rintro rfl
+    exact AlgebraicCurve.RationalFunctionField.placeInfty_ne_ofHeightOneSpectrum K
+  · intro h
+    exact AlgebraicCurve.RationalFunctionField.subsingleton_setOf_forall_ne_ofHeightOneSpectrum h
+      (AlgebraicCurve.RationalFunctionField.placeInfty_ne_ofHeightOneSpectrum K)
+
+end S_OVERLONG_e6aa63aa
+end P2MW
+export P2MW.S_OVERLONG_e6aa63aa
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve AlgebraicCurve.RationalFunctionField
+theorem AlgebraicCurve.RationalFunctionField.eq_placeInfty_iff_forall_ne_ofHeightOneSpectrum
+    {K : Type*} [Field K] [DecidableEq (RatFunc K)] (v : Place K (RatFunc K)) :
+    v = placeInfty K ↔ ∀ w : IsDedekindDomain.HeightOneSpectrum (Polynomial K), v ≠
+      Place.ofHeightOneSpectrum w :=
+  solution v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_exists_forall_ne_ofHeightOneSpectrum.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_exists_forall_ne_ofHeightOneSpectrum.lean
new file mode 100644
index 0000000000..76d6b762a8
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_exists_forall_ne_ofHeightOneSpectrum.lean
@@ -0,0 +1,216 @@
+/-
+Based on Prove2Me node AlgebraicCurve.RationalFunctionField.exists_forall_ne_ofHeightOneSpectrum
+(5e0bdace-46ac-5793-8044-fe6a2fce8738) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5addb35a-f141-57bc-abe6-0203591829a6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.NumberTheory.RatFunc.Ostrowski
+import Mathlib.RingTheory.DedekindDomain.Factorization
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of a place of K(t)/K that is not a finite place
+
+Theorem statement: `AlgebraicCurve.RationalFunctionField.exists_forall_ne_ofHeightOneSpectrum`
+(`5e0bdace-46ac-5793-8044-fe6a2fce8738`), by Claude, 2026-09-05.
+
+Proof: submission `5addb35a-f141-57bc-abe6-0203591829a6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $\mathrm{RatFunc}\,K$ be the rational function field in one variable over
+$K$. A `Place K (RatFunc K)` consists of a valuation subring $\mathcal{O}$ of $\mathrm{RatFunc}\,K$
+such that the image of every element of $K$ under the structure map $K \to \mathrm{RatFunc}\,K$ lies
+in $\mathcal{O}$, such that $\mathcal{O} \neq \top$, and such that $\mathcal{O}$ is a principal
+ideal ring; for a height-one prime $w$ of the polynomial ring $K[X]$, the place
+`Place.ofHeightOneSpectrum w` is the one whose valuation subring is the valuation subring of the
+$w$-adic valuation of $\mathrm{RatFunc}\,K$ (regarded as the fraction field of $K[X]$), the three
+defining conditions holding because $w$-adic valuations are $\le 1$ on polynomials, are nontrivial,
+and have principal-ideal valuation subrings. The theorem asserts: there exists a place $v$ of $K(t)$
+over $K$ in this sense such that for every height-one prime $w$ of $K[X]$ one has $v \neq$
+`Place.ofHeightOneSpectrum w`. No hypotheses beyond $K$ being a field are imposed.
+
+This is the existence half of the classification of the places of the projective line: besides the
+finite places, attached to the height-one primes of $K[X]$, there is the place at infinity. It is
+used in the development of places and orders on a rational function field, for instance in the
+results on elements with a pole at some place, on elements regular at every place, and on degrees of
+divisors of rational functions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_exists_forall_ne_ofHeightOneSpectrum.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_20cd8cfe
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing
+open scoped Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext heightOneSpectrum adicValuation adicValuation_ne_zero ord \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring isPrincipalIdealRing'"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.adicValuation_valuationSubring' :
+    v.adicValuation.valuationSubring = v.toValuationSubring := by
+  ext x
+  rw [Valuation.mem_valuationSubring_iff]
+  constructor
+  · intro hx
+    obtain ⟨a, rfl⟩ := IsDiscreteValuationRing.exists_lift_of_le_one hx
+    exact a.2
+  · intro hx
+    exact v.heightOneSpectrum.valuation_le_one (⟨x, hx⟩ : v.toValuationSubring)
+
+p2m_export "AlgebraicCurve.Place" "adicValuation_valuationSubring'"
+private theorem _root_.AlgebraicCurve.Place.mem_iff_adicValuation_le_one' {f : F} :
+    f ∈ v.toValuationSubring ↔ v.adicValuation f ≤ 1 := by
+  rw [← v.adicValuation_valuationSubring']
+  exact Valuation.mem_valuationSubring_iff _ _
+
+p2m_export "AlgebraicCurve.Place" "mem_iff_adicValuation_le_one'"
+private theorem adicValuation_isRankOneDiscrete' : v.adicValuation.IsRankOneDiscrete :=
+  IsDiscreteValuationRing.isRankOneDiscrete v.toValuationSubring F
+
+private theorem adicValuation_isTrivialOn' : v.adicValuation.IsTrivialOn K :=
+  Valuation.IsTrivialOn.of_le_one v.adicValuation fun a =>
+    v.mem_iff_adicValuation_le_one'.mp (v.algebraMap_mem' a)
+
+private theorem _root_.AlgebraicCurve.Place.isEquiv_adicValuation_of_valuationSubring_eq' {Γ :
+  Type*}
+    [LinearOrderedCommGroupWithZero Γ] {w : Valuation F Γ}
+    (h : w.valuationSubring = v.toValuationSubring) : w.IsEquiv v.adicValuation :=
+  (Valuation.isEquiv_iff_valuationSubring _ _).mpr
+    (h.trans v.adicValuation_valuationSubring'.symm)
+
+p2m_export "AlgebraicCurve.Place" "isEquiv_adicValuation_of_valuationSubring_eq'"
+private theorem ord_eq_zero_iff_adicValuation_eq_one' {f : F} (hf : f ≠ 0) :
+    v.ord f = 0 ↔ v.adicValuation f = 1 := by
+  simp only [ord, neg_eq_zero]
+  constructor
+  · intro h
+    have h2 := exp_log (v.adicValuation_ne_zero hf)
+    rw [h, exp_zero] at h2
+    exact h2.symm
+  · intro h
+    rw [h, log_one]
+
+section OfHeightOneSpectrum
+
+variable {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R F] [IsFractionRing R F]
+  [Algebra K R] [IsScalarTower K R F]
+
+private theorem isEquiv_adicValuation_ofHeightOneSpectrum' (w : HeightOneSpectrum R) :
+    (w.valuation F).IsEquiv (ofHeightOneSpectrum (K := K) w).adicValuation :=
+  (ofHeightOneSpectrum (K := K) w).isEquiv_adicValuation_of_valuationSubring_eq' rfl
+
+end OfHeightOneSpectrum
+
+end Place
+
+namespace RationalFunctionField
+
+variable (K : Type*) [Field K]
+
+section PlaceInfty
+
+variable [DecidableEq (RatFunc K)]
+
+private theorem nontrivial_valueGroup_inftyValuation :
+    Nontrivial (MonoidWithZeroHom.valueGroup (.ofClass (RatFunc.inftyValuation K))) := by
+  rw [Subgroup.nontrivial_iff_exists_ne_one]
+  refine ⟨Units.mk0 (RatFunc.inftyValuation K RatFunc.X)
+    (by rw [RatFunc.inftyValuation.X]; exact exp_ne_zero), ?_, ?_⟩
+  · exact MonoidWithZeroHom.mem_valueGroup _ ⟨RatFunc.X, rfl⟩
+  · rw [ne_eq, Units.ext_iff, Units.val_mk0, Units.val_one, RatFunc.inftyValuation.X]
+    simp
+
+private def placeInfty' : Place K (RatFunc K) where
+  toValuationSubring := (RatFunc.inftyValuation K).valuationSubring
+  algebraMap_mem' a := by
+    rw [Valuation.mem_valuationSubring_iff]
+    exact Valuation.IsTrivialOn.valuation_algebraMap_le_one (v := RatFunc.inftyValuation K) a
+  ne_top' := by
+    have := nontrivial_valueGroup_inftyValuation K
+    simp only [ne_eq, Valuation.valuationSubring_eq_top_iff, not_not]
+    infer_instance
+  isPrincipalIdealRing' :=
+    haveI := nontrivial_valueGroup_inftyValuation K
+    (Valuation.valuationSubring_isDiscreteValuationRing
+      (RatFunc.inftyValuation K)).toIsPrincipalIdealRing
+
+private theorem placeInfty'_ne_ofHeightOneSpectrum (w : HeightOneSpectrum K[X]) :
+    placeInfty' K ≠ Place.ofHeightOneSpectrum w := by
+  intro h
+  refine RatFunc.adicValuation_not_isEquiv_infty_valuation w
+    ((Valuation.isEquiv_iff_valuationSubring _ _).mpr ?_)
+  have h2 := congrArg Place.toValuationSubring h
+  rw [Place.ofHeightOneSpectrum_toValuationSubring] at h2
+  exact h2.symm
+
+end PlaceInfty
+
+variable {K}
+
+theorem rowMain :
+    ∃ v : Place K (RatFunc K), ∀ w : HeightOneSpectrum K[X], v ≠ Place.ofHeightOneSpectrum w := by
+  classical
+  exact ⟨placeInfty' K, placeInfty'_ne_ofHeightOneSpectrum K⟩
+
+end RationalFunctionField
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_OVERLONG_20cd8cfe.AlgebraicCurve
+  in
+theorem solution {K : Type*} [Field K] :
+    ∃ v : Place K (RatFunc K), ∀ w : IsDedekindDomain.HeightOneSpectrum (Polynomial K), v ≠
+      Place.ofHeightOneSpectrum w :=
+  AlgebraicCurve.RationalFunctionField.rowMain
+
+end S_OVERLONG_20cd8cfe
+end P2MW
+export P2MW.S_OVERLONG_20cd8cfe (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.RationalFunctionField.exists_forall_ne_ofHeightOneSpectrum {K : Type*}
+    [Field K] :
+    ∃ v : Place K (RatFunc K), ∀ w : IsDedekindDomain.HeightOneSpectrum (Polynomial K), v ≠
+      Place.ofHeightOneSpectrum w :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_finiteDimensional_lSpace_zero_of_constantsAreBase.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_finiteDimensional_lSpace_zero_of_constantsAreBase.lean
new file mode 100644
index 0000000000..2b1b6750da
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_finiteDimensional_lSpace_zero_of_constantsAreBase.lean
@@ -0,0 +1,2674 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.RationalFunctionField.finiteDimensional_lSpace_zero_of_constantsAreBase
+(5d4c35f9-694f-5610-aa74-d68bc8fe05e0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 55304bb3-d884-5cea-a9c4-2d6277bda85e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+
+import Mathlib.Algebra.Polynomial.Basis
+import Mathlib.Data.Int.LeastGreatest
+import Mathlib.LinearAlgebra.Matrix.FiniteDimensional
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PoleDivisorPackage
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_restrict_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_placeInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finite-dimensionality of L(0) when the constants are K
+
+Theorem statement:
+`AlgebraicCurve.RationalFunctionField.finiteDimensional_lSpace_zero_of_constantsAreBase`
+(`5d4c35f9-694f-5610-aa74-d68bc8fe05e0`), by Claude, 2026-09-05.
+
+Proof: submission `55304bb3-d884-5cea-a9c4-2d6277bda85e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and $F$ a field equipped with a $K$-algebra structure. A place of $K$ in $F$ is a
+valuation subring of $F$ that contains $\operatorname{image}(K \to F)$, is not all of $F$, and is a
+principal ideal ring; a divisor is a finitely supported function from places to $\mathbb{Z}$, and
+for a divisor $D$ the space $\mathrm{LSpace}\,D = \mathrm{riemannRochSpace}\,D$ is the $K$-submodule
+of those $f \in F$ with $v(f) \le \exp(D\,v)$ for every place $v$, where $v$ denotes the associated
+valuation. For $D = 0$ this is the set of $f$ lying in every place's valuation ring. The hypothesis
+`ConstantsAreBase K F` asserts precisely that this space $\mathrm{LSpace}\,(0)$ coincides with the
+range of the $K$-linear map $K \to F$. Under this hypothesis the conclusion is that
+$\mathrm{LSpace}\,(0)$ is a finite-dimensional $K$-vector space (its dimension being $1$, although
+only finiteness is asserted).
+
+This is the statement that a function field whose field of constants is the base field has
+finite-dimensional (indeed one-dimensional) Riemann–Roch space attached to the zero divisor. It
+serves to discharge the `FiniteDimensional K (LSpace 0)` side condition appearing in the divisor and
+constant-field-extension results built on Riemann–Roch, such as the bounds on $\dim_K L(D)$ under
+place reduction and the torsion descent statements for constant field extensions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_finiteDimensional_lSpace_zero_of_constantsAreBase.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_b9c3c6d1
+
+
+open Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "degree degree_single principal smul_def smul_apply pullback \
+  pullback_apply degree_pullback"
+end Divisor
+variable {D : Divisor K F}
+p2m_open_scoped "AlgebraicCurve.Divisor" in
+theorem Divisor.degree_nonneg_of_nonneg [IsCurveOver K F]
+    {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) : 0 ≤ Divisor.degree D := by
+  rw [Divisor.degree_eq_sum_support]
+  exact Finset.sum_nonneg fun v _ => mul_nonneg (hD v) (Int.natCast_nonneg _)
+theorem lSpace_eq_bot_of_degree_neg [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) : LSpace D = ⊥ := by
+  rw [eq_bot_iff]
+  intro f hf
+  rw [Submodule.mem_bot]
+  by_contra hf0
+  obtain ⟨P, hPord, hPdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+  have heff : ∀ v : Place K F, 0 ≤ (P + D) v := by
+    intro v
+    rw [Finsupp.add_apply, hPord]
+    rcases mem_lSpace_iff_ord.mp hf with rfl | h
+    · exact absurd rfl hf0
+    · linarith [h v]
+  have hdegPD : 0 ≤ Divisor.degree (P + D) := Divisor.degree_nonneg_of_nonneg heff
+  rw [map_add, hPdeg, zero_add] at hdegPD
+  exact absurd hdegPD (not_le.mpr hD)
+end AlgebraicCurve
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~restrict_plac\
+  eOfPrime~placeOfPrime~comap_algebraMap_ne_top"
+
+variable (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mk_mem_maximalIdeal_iff {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    (⟨f, hf⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring
+      ↔ f = 0 ∨ 0 < v.ord f := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  constructor
+  · intro hu
+    rcases eq_or_ne f 0 with rfl | hf0
+    · exact Or.inl rfl
+    · refine Or.inr ?_
+      rcases lt_or_eq_of_le (AlgebraicCurve.Place.ord_nonneg_of_mem v hf) with h | h
+      · exact h
+      · exfalso
+        apply hu
+        rw [← v.adicValuation_coe_eq_one_iff ⟨f, hf⟩]
+        change v.adicValuation f = 1
+        rw [v.adicValuation_eq_exp_neg_ord hf0, ← h, neg_zero, WithZero.exp_zero]
+  · intro h hu
+    have hne : f ≠ 0 := fun h0 => hu.ne_zero (Subtype.ext h0)
+    have h0 : v.ord f = 0 := by
+      obtain ⟨u, hu'⟩ := hu
+      have hcoe : f = ((u : v.toValuationSubring) : F) := by rw [hu']
+      rw [hcoe]; exact v.ord_coe_unit u
+    rcases h with rfl | hpos
+    · exact hne rfl
+    · omega
+
+p2m_export "AlgebraicCurve.Place" "mk_mem_maximalIdeal_iff"
+end Place
+
+theorem ell_le_ell_sub_single_add_deg [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    ell D ≤ ell (D - Finsupp.single P 1) + P.deg := by
+  classical
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible P.toValuationSubring
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by
+    simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := by
+    intro g hg
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ g : F, g ∈ LSpace D → t ^ (D P) * g ∈ P.toValuationSubring := by
+    intro g hg
+    rcases eq_or_ne g 0 with rfl | hg0
+    · simp
+    · refine AlgebraicCurve.Place.mem_of_ord_nonneg P (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have := (mem_lSpace_iff_ord.mp hg).resolve_left hg0 P
+      linarith
+  let ψ : LSpace D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun f => ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+      map_add' := by intro f g; apply Subtype.ext; push_cast; ring
+      map_smul' := by
+        intro c f; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap]
+        ring }
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : LSpace D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ f : LSpace D, φ f = 0 ↔
+      (⟨t ^ (D P) * (f : F), hmem _ f.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := by
+    intro f
+    rw [show φ f = IsLocalRing.residue P.toValuationSubring ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+          from hres (ψ f),
+      IsLocalRing.residue_eq_zero_iff]
+  have hED : E ≤ D := by
+    rw [Finsupp.le_def]; intro v; rw [hE, Finsupp.sub_apply]
+    have : (0 : ℤ) ≤ Finsupp.single P 1 v := by
+      rcases eq_or_ne v P with rfl | hv
+      · simp
+      · simp [Finsupp.single_eq_of_ne hv]
+    linarith
+  have hsub : LSpace E ≤ LSpace D := lSpace_mono hED
+  have hker : LinearMap.ker φ = (LSpace E).comap (LSpace D).subtype := by
+    ext f
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi f, P.mk_mem_maximalIdeal_iff]
+    rcases eq_or_ne (f : F) 0 with hf0 | hf0
+    · simp only [hf0, mul_zero, true_or, true_iff]
+      exact (LSpace E).zero_mem
+    · rw [mem_lSpace_iff_ord]
+      have hfD := (mem_lSpace_iff_ord.mp f.2).resolve_left hf0
+      constructor
+      · rintro (h | h)
+        · exact absurd h (mul_ne_zero htn0 hf0)
+        · refine Or.inr (fun v => ?_)
+          rcases eq_or_ne v P with rfl | hv
+          · rw [hEP]; rw [hordmul hf0] at h; omega
+          · rw [hEv v hv]; exact hfD v
+      · rintro (h | h)
+        · exact absurd h hf0
+        · refine Or.inr ?_
+          have hP := h P
+          rw [hEP] at hP
+          rw [hordmul hf0]; omega
+  have hkerfin : finrank K (LinearMap.ker φ) = ell E := by
+    rw [hker, LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe hsub)]
+  have hquot : finrank K (LSpace D ⧸ LinearMap.ker φ) ≤ P.deg := by
+    rw [LinearEquiv.finrank_eq φ.quotKerEquivRange]
+    exact Submodule.finrank_le (LinearMap.range φ)
+  by_cases hfin : FiniteDimensional K (LSpace D)
+  · have := hfin
+    have hrn := Submodule.finrank_quotient_add_finrank (LinearMap.ker φ)
+    rw [hkerfin] at hrn
+    have hb : ell D = finrank K (LSpace D) := rfl
+    omega
+  · have h0 : ell D = 0 := by rw [ell]; exact finrank_of_infinite_dimensional hfin
+    omega
+
+theorem one_le_deg [IsCurveOver K F] (P : Place K F) : 1 ≤ P.deg := by
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  exact Module.finrank_pos
+
+theorem ell_le_degree_add_ellZero [IsCurveOver K F] {D : Divisor K F}
+    (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D : Divisor K F, (∀ v, 0 ≤ D v) →
+      (Divisor.degree D).toNat = m →
+      (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) by
+    exact H (Divisor.degree D).toNat D hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D hD hm
+    by_cases hD0 : D = 0
+    · subst hD0; simp
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ D P := by
+        have hne : D P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hD P; omega
+      set E : Divisor K F := D - Finsupp.single P 1 with hE
+      have hEeff : ∀ v, 0 ≤ E v := by
+        intro v; rw [hE, Finsupp.sub_apply]
+        rcases eq_or_ne v P with rfl | hv
+        · rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have hdegE : Divisor.degree E = Divisor.degree D - P.deg := by
+        rw [hE, map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hDnn : 0 ≤ Divisor.degree D := Divisor.degree_nonneg_of_nonneg hD
+      have hEnn : 0 ≤ Divisor.degree E := Divisor.degree_nonneg_of_nonneg hEeff
+      have hmlt : (Divisor.degree E).toNat < m := by rw [← hm]; omega
+      have hIH := IH _ hmlt E hEeff rfl
+      have hstep := ell_le_ell_sub_single_add_deg D P
+      rw [← hE] at hstep
+      have hstep' : (ell D : ℤ) ≤ (ell E : ℤ) + P.deg := by exact_mod_cast hstep
+      rw [hdegE] at hIH
+      linarith
+
+theorem ell_le_degree_add_one_of_effective [IsCurveOver K F]
+    (hC : ConstantsAreBase K F) {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  have h := ell_le_degree_add_ellZero hD
+  rw [ell_zero_eq_one_of_constantsAreBase hC] at h
+  exact_mod_cast h
+
+def lSpaceShiftEquiv (D : Divisor K F) {g : F} (hg : g ≠ 0)
+    {Dg : Divisor K F} (hDg : ∀ v, Dg v = v.ord g) :
+    LSpace D ≃ₗ[K] LSpace (D + Dg) where
+  toFun h := ⟨(h : F) * g⁻¹, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (h : F) 0 with hh0 | hh0
+    · left; rw [hh0, zero_mul]
+    · right; intro v
+      rw [Finsupp.add_apply, hDg, v.ord_mul hh0 (inv_ne_zero hg), v.ord_inv]
+      have := (mem_lSpace_iff_ord.mp h.2).resolve_left hh0 v
+      linarith⟩
+  invFun k := ⟨(k : F) * g, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (k : F) 0 with hk0 | hk0
+    · left; rw [hk0, zero_mul]
+    · right; intro v
+      have := (mem_lSpace_iff_ord.mp k.2).resolve_left hk0 v
+      rw [Finsupp.add_apply, hDg] at this
+      rw [v.ord_mul hk0 hg]
+      linarith⟩
+  map_add' h₁ h₂ := by apply Subtype.ext; push_cast; ring
+  map_smul' c h := by
+    apply Subtype.ext
+    simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def]
+    ring
+  left_inv h := by
+    apply Subtype.ext
+    change (h : F) * g⁻¹ * g = (h : F)
+    rw [mul_assoc, inv_mul_cancel₀ hg, mul_one]
+  right_inv k := by
+    apply Subtype.ext
+    change (k : F) * g * g⁻¹ = (k : F)
+    rw [mul_assoc, mul_inv_cancel₀ hg, mul_one]
+
+theorem ell_le_degree_add_one [IsCurveOver K F] (hC : ConstantsAreBase K F)
+    {D : Divisor K F} (hD : 0 ≤ Divisor.degree D) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  rcases eq_or_ne (ell D) 0 with h0 | h0
+  · rw [h0]; push_cast; linarith
+  · have hbot : LSpace D ≠ ⊥ := fun h => h0 (by rw [ell, h, finrank_bot])
+    obtain ⟨g, hgL, hg0⟩ := (Submodule.ne_bot_iff _).mp hbot
+    obtain ⟨Dg, hDgord, hDgdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) g hg0
+    have heff : ∀ v, 0 ≤ (D + Dg) v := by
+      intro v; rw [Finsupp.add_apply, hDgord]
+      have := (mem_lSpace_iff_ord.mp hgL).resolve_left hg0 v
+      linarith
+    have hdeg : Divisor.degree (D + Dg) = Divisor.degree D := by
+      rw [map_add, hDgdeg, add_zero]
+    have hell : ell D = ell (D + Dg) :=
+      LinearEquiv.finrank_eq (lSpaceShiftEquiv D hg0 hDgord)
+    have hfin := ell_le_degree_add_one_of_effective hC heff
+    rw [hdeg] at hfin
+    rw [hell]; exact hfin
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion factor mk mem_bot subtype_injective \
+  mk.injEq Quotient.subsingleton_iff Quotient.mk span restrictScalars inhabited \
+  inclusion_injective comapSubtypeEquivOfLe mem_comap finrank_quotient_add_finrank mem_top \
+  Quotient.equiv mkQ mem_map coe_subtype map_smul' zero one quotientQuotientEquivQuotient \
+  coe_eq_zero finrank_le range_subtype Quotient.mk_surjective map mem_inf mem_sup \
+  Quotient.mk_eq_zero topEquiv map_injective_of_injective comap_subtype_self mapQ subsingleton_iff \
+  module smul_def mk_eq_zero coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono \
+  map_sup coe_zero smul"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+def nestedComapMapMkQEquiv {A B C : Submodule K X} (_hAB : A ≤ B) (hBC : B ≤ C) :
+    ((B.comap C.subtype).map (A.comap C.subtype).mkQ : Submodule K _)
+      ≃ₗ[K] B ⧸ A.comap B.subtype := by
+  set S := A.comap C.subtype with hS
+  set T := B.comap C.subtype with hT
+  let ψ : (T : Type _) →ₗ[K] (C ⧸ S) := S.mkQ ∘ₗ T.subtype
+  have hker : LinearMap.ker ψ = S.comap T.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = T.map S.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let e1 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (T.map S.mkQ : Submodule K _) :=
+    (Submodule.Quotient.equiv _ (LinearMap.ker ψ) (LinearEquiv.refl K T)
+        (by rw [hker]; simp)).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have hmap : (S.comap T.subtype).map
+      (Submodule.comapSubtypeEquivOfLe hBC : (T : Type _) →ₗ[K] B) = A.comap B.subtype := by
+    ext ⟨b, hb⟩
+    simp only [mem_map, mem_comap, Submodule.coe_subtype, hS]
+    constructor
+    · rintro ⟨⟨⟨x, hxC⟩, hxB⟩, hxA, hxeq⟩
+      have hx : x = b := congrArg Subtype.val hxeq
+      subst hx; exact hxA
+    · intro hbA
+      exact ⟨⟨⟨b, hBC hb⟩, hb⟩, hbA, rfl⟩
+  let e2 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (B ⧸ A.comap B.subtype) :=
+    Submodule.Quotient.equiv _ _ (Submodule.comapSubtypeEquivOfLe hBC) hmap
+  exact e1.symm.trans e2
+
+theorem finrank_quotient_chain {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCB : Module.Finite K (C ⧸ B.comap C.subtype)]
+    [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (C ⧸ A.comap C.subtype) ∧
+      finrank K (C ⧸ A.comap C.subtype)
+        = finrank K (C ⧸ B.comap C.subtype) + finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (T.map S.mkQ : Submodule K _) := Module.Finite.equiv eK.symm
+  have : Module.Finite K ((C ⧸ S) ⧸ T.map S.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (C ⧸ S) := Module.Finite.of_submodule_quotient (T.map S.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+theorem finrank_quotient_chain' {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCA : Module.Finite K (C ⧸ A.comap C.subtype)] :
+    Module.Finite K (C ⧸ B.comap C.subtype) ∧
+      finrank K (C ⧸ B.comap C.subtype)
+        = finrank K (C ⧸ A.comap C.subtype) - finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (C ⧸ T) := Module.Finite.equiv e3
+  refine ⟨this, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+def adeleBddQuotSingleEquivResidueField (D : Divisor K F) (P : Place K F) :
+    (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+      ≃ₗ[K] P.ResidueField := by
+  classical
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  let π : P.toValuationSubring :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose
+  have hπ : Irreducible π :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose_spec
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := fun {g} hg => by
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ α : Place K F → F, α ∈ adeleBdd D → t ^ (D P) * α P ∈ P.toValuationSubring := by
+    intro α hα
+    rcases eq_or_ne (α P) 0 with hg0 | hg0
+    · simp [hg0]
+    · refine AlgebraicCurve.Place.mem_of_ord_nonneg P (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have h := hα P
+      rw [P.adicValuation_eq_exp_neg_ord hg0, WithZero.exp_le_exp] at h
+      linarith
+  let ψ : adeleBdd D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun α => ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩
+      map_add' := by
+        intro α β; apply Subtype.ext
+        simp only [Submodule.coe_add, Pi.add_apply]
+        push_cast; ring
+      map_smul' := by
+        intro c α; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap, Pi.smul_apply]
+        ring }
+  have hψ_apply : ∀ α : adeleBdd D,
+      (ψ α : F) = t ^ (D P) * (α : Place K F → F) P := fun α => rfl
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : adeleBdd D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ α : adeleBdd D, φ α = 0 ↔
+      (⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := fun α => by
+    rw [show φ α = IsLocalRing.residue P.toValuationSubring
+            ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ from hres (ψ α),
+      IsLocalRing.residue_eq_zero_iff]
+  have hker : LinearMap.ker φ = (adeleBdd E).comap (adeleBdd D).subtype := by
+    ext α
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi α, P.mk_mem_maximalIdeal_iff, mem_adeleBdd]
+    have hαD := α.2
+    constructor
+    · rintro (h | h) v
+      · have hα0 : (α : Place K F → F) P = 0 := by
+          rcases mul_eq_zero.mp h with h' | h'
+          · exact absurd h' htn0
+          · exact h'
+        by_cases hv : v = P
+        · subst v; rw [hα0, Valuation.map_zero]; exact zero_le
+        · rw [hEv v hv]; exact hαD v
+      · by_cases hv : v = P
+        · subst v
+          rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+          · rw [hα0, Valuation.map_zero]; exact zero_le
+          · rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP]
+            rw [hordmul hα0] at h; omega
+        · rw [hEv v hv]; exact hαD v
+    · intro h
+      rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+      · left; rw [hα0, mul_zero]
+      · right
+        have hP := h P
+        rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP] at hP
+        rw [hordmul hα0]; omega
+  have hsurj : Function.Surjective φ := by
+    intro c
+    obtain ⟨cl, hcl⟩ := IsLocalRing.residue_surjective (R := P.toValuationSubring) c
+    set f : F := (cl : F) * t ^ (-(D P)) with hf
+    have hαD : Pi.single P f ∈ adeleBdd D := by
+      intro v
+      by_cases hv : v = P
+      · subst v
+        simp only [Pi.single_eq_same]
+        rcases eq_or_ne (cl : F) 0 with hc0 | hc0
+        · rw [hf, hc0, zero_mul, Valuation.map_zero]; exact zero_le
+        · have hf0 : f ≠ 0 := by rw [hf]; exact mul_ne_zero hc0 (zpow_ne_zero _ ht0)
+          rw [P.adicValuation_eq_exp_neg_ord hf0, WithZero.exp_le_exp]
+          rw [hf, P.ord_mul hc0 (zpow_ne_zero _ ht0), P.ord_zpow, ht1, mul_one]
+          have hclnn := AlgebraicCurve.Place.ord_nonneg_of_mem P cl.2
+          linarith
+      · rw [Pi.single_eq_of_ne hv, Valuation.map_zero]; exact zero_le
+    refine ⟨⟨Pi.single P f, hαD⟩, ?_⟩
+    change res (ψ ⟨Pi.single P f, hαD⟩) = c
+    rw [hres]
+    rw [show (ψ ⟨Pi.single P f, hαD⟩ : P.toValuationSubring) = cl from ?_, hcl]
+    apply Subtype.ext
+    rw [hψ_apply]
+    change t ^ (D P) * (Pi.single P f : Place K F → F) P = (cl : F)
+    rw [show (Pi.single P f : Place K F → F) P = f from Pi.single_eq_same _ _, hf,
+      mul_comm (cl : F), ← mul_assoc, ← zpow_add₀ ht0, add_neg_cancel, zpow_zero, one_mul]
+  exact (Submodule.Quotient.equiv _ _ (LinearEquiv.refl K _) (by rw [← hker]; simp)).trans
+    (φ.quotKerEquivOfSurjective hsurj)
+
+theorem finrank_adeleBdd_quotient_single [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    Module.Finite K
+        (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype) ∧
+      finrank K
+          (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+        = P.deg := by
+  have := IsCurveOver.finite_residueField (K := K) P
+  exact ⟨Module.Finite.equiv (adeleBddQuotSingleEquivResidueField D P).symm,
+    (adeleBddQuotSingleEquivResidueField D P).finrank_eq⟩
+
+theorem finrank_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+      (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+        = Divisor.degree D₂ - Divisor.degree D₁ := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D₁ D₂ : Divisor K F, D₁ ≤ D₂ →
+      (Divisor.degree (D₂ - D₁)).toNat = m →
+      Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+        (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+          = Divisor.degree D₂ - Divisor.degree D₁ from
+    H _ D₁ D₂ hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D₁ D₂ hD hm
+    have hEeff : ∀ v, 0 ≤ (D₂ - D₁) v := fun v => by
+      rw [Finsupp.sub_apply]; have := hD v; omega
+    by_cases hD0 : D₂ - D₁ = 0
+    · have hD12 : D₁ = D₂ := (sub_eq_zero.mp hD0).symm
+      subst hD12
+      rw [Submodule.comap_subtype_self]
+      have : Subsingleton (adeleBdd D₁ ⧸ (⊤ : Submodule K (adeleBdd D₁))) :=
+        Submodule.Quotient.subsingleton_iff.mpr rfl
+      exact ⟨Module.Finite.of_finite, by simp [Module.finrank_zero_of_subsingleton]⟩
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ (D₂ - D₁) P := by
+        have hne : (D₂ - D₁) P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hEeff P; omega
+      set D₂' : Divisor K F := D₂ - Finsupp.single P 1 with hD₂'
+      have h12' : D₁ ≤ D₂' := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]
+          have := hPpos; rw [Finsupp.sub_apply] at this; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have h2'2 : D₂' ≤ D₂ := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]
+      have hdegD₂' : Divisor.degree D₂' = Divisor.degree D₂ - P.deg := by
+        rw [hD₂', map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hEnn : 0 ≤ Divisor.degree (D₂ - D₁) := Divisor.degree_nonneg_of_nonneg hEeff
+      have hE'nn : 0 ≤ Divisor.degree (D₂' - D₁) := Divisor.degree_nonneg_of_nonneg
+        (fun v => by rw [Finsupp.sub_apply]; have := h12' v; omega)
+      have hdegdiff : Divisor.degree (D₂' - D₁) = Divisor.degree (D₂ - D₁) - P.deg := by
+        simp only [hD₂', map_sub, Divisor.degree_single, one_mul]; ring
+      have hmlt : (Divisor.degree (D₂' - D₁)).toNat < m := by rw [← hm]; omega
+      obtain ⟨hfin', hrank'⟩ := IH _ hmlt D₁ D₂' h12' rfl
+      obtain ⟨hfinS, hrankS⟩ := finrank_adeleBdd_quotient_single (K := K) D₂ P
+      rw [← hD₂'] at hfinS hrankS
+      have := hfin'; have := hfinS
+      obtain ⟨hfin, hrank⟩ := Submodule.finrank_quotient_chain
+        (A := adeleBdd D₁) (B := adeleBdd D₂') (C := adeleBdd D₂)
+        (adeleBdd_mono h12') (adeleBdd_mono h2'2)
+      refine ⟨hfin, ?_⟩
+      rw [hrank, hrankS]
+      push_cast
+      linarith [hrank', hdegD₂']
+
+theorem module_finite_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  (finrank_adeleBdd_quotient hD).1
+
+theorem finrank_adeleBdd_quotient_eq [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+      = Divisor.degree D₂ - Divisor.degree D₁ :=
+  (finrank_adeleBdd_quotient hD).2
+
+def lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (_hD : D₁ ≤ D₂) :
+    (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      →ₗ[K] (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  Submodule.mapQ _ _
+    ((diagonalHom K F).restrict
+      (p := (LSpace D₂ : Submodule K F)) (q := (adeleBdd D₂ : Submodule K _))
+      (fun f hf => diagonal_mem_adeleBdd_iff.mpr hf))
+    (fun f hf => by
+      simp only [Submodule.mem_comap, Submodule.coe_subtype] at hf ⊢
+      exact diagonal_mem_adeleBdd_iff.mpr hf)
+
+theorem lSpaceQuotientToAdeleBddQuotient_injective {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Function.Injective (lSpaceQuotientToAdeleBddQuotient hD) := by
+  rw [injective_iff_map_eq_zero]
+  intro x hx
+  obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+  rw [Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype]
+  rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk f)
+        = Submodule.Quotient.mk ((diagonalHom K F).restrict
+            (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f) from rfl,
+    Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype] at hx
+  exact diagonal_mem_adeleBdd_iff.mp hx
+
+
+theorem ell_sub_ell_le_degree_sub_degree [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)] :
+    (ell D₂ : ℤ) - (ell D₁ : ℤ) ≤ Divisor.degree D₂ - Divisor.degree D₁ := by
+  have := module_finite_adeleBdd_quotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    rw [hℓ₁]; exact (Submodule.finrank_quotient_add_finrank _).symm
+  have hemb : finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      ≤ finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+    LinearMap.finrank_le_finrank_of_injective (lSpaceQuotientToAdeleBddQuotient_injective hD)
+  have hloc := finrank_adeleBdd_quotient_eq hD
+  have : (ell D₂ : ℤ) - (ell D₁ : ℤ)
+      = (finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) : ℤ) := by
+    rw [hL]; push_cast; ring
+  rw [this, ← hloc]
+  exact_mod_cast hemb
+
+theorem adeleBdd_inf_sup_globalSub {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F)
+      = adeleBdd D₁ ⊔ adeleBdd D₂ ⊓ globalSub K F := by
+  rw [inf_comm, sup_inf_assoc_of_le _ (adeleBdd_mono hD), inf_comm]
+
+theorem map_diagonal_lSpace_inf_adeleBdd {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (LSpace D₂).map (diagonalHom K F) ⊓ adeleBdd D₁ = (LSpace D₁).map (diagonalHom K F) := by
+  rw [map_diagonal_lSpace, map_diagonal_lSpace, inf_right_comm,
+    inf_eq_right.mpr (adeleBdd_mono hD)]
+
+theorem gate_finrank_adeleBdd_quotient_single_point [IsCurveOver K F] (P : Place K F) :
+    (finrank K (adeleBdd (Finsupp.single P 1 : Divisor K F)
+        ⧸ (adeleBdd (0 : Divisor K F)).comap (adeleBdd (Finsupp.single P 1)).subtype) : ℤ)
+      = (P.deg : ℤ) := by
+  classical
+  have h01 : (0 : Divisor K F) ≤ Finsupp.single P 1 := by
+    intro v; rw [Finsupp.zero_apply, Finsupp.single_apply]; split_ifs <;> omega
+  have h := finrank_adeleBdd_quotient_eq (K := K) h01
+  rw [h, map_zero, sub_zero, Divisor.degree_single, one_mul]
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion factor mk mem_bot subtype_injective \
+  mk.injEq Quotient.subsingleton_iff Quotient.mk span restrictScalars inhabited \
+  inclusion_injective comapSubtypeEquivOfLe mem_comap finrank_quotient_add_finrank mem_top \
+  Quotient.equiv mkQ mem_map coe_subtype map_smul' zero one quotientQuotientEquivQuotient \
+  coe_eq_zero finrank_le range_subtype Quotient.mk_surjective map mem_inf mem_sup \
+  Quotient.mk_eq_zero topEquiv map_injective_of_injective comap_subtype_self mapQ subsingleton_iff \
+  module smul_def mk_eq_zero coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono \
+  map_sup coe_zero smul"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+theorem comap_subtype_sup_of_le_of_le {S T C : Submodule K X} (hS : S ≤ C) (hT : T ≤ C) :
+    S.comap C.subtype ⊔ T.comap C.subtype = (S ⊔ T).comap C.subtype := by
+  apply Submodule.map_injective_of_injective (f := C.subtype) C.subtype_injective
+  rw [Submodule.map_sup, Submodule.map_comap_subtype, Submodule.map_comap_subtype,
+    Submodule.map_comap_subtype, inf_eq_right.mpr hS, inf_eq_right.mpr hT,
+    inf_eq_right.mpr (sup_le hS hT)]
+
+theorem finrank_quotient_chain_top {M : Type*} [AddCommGroup M] [Module K M]
+    {A B : Submodule K M} (hAB : A ≤ B)
+    [hMB : Module.Finite K (M ⧸ B)] [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (M ⧸ A) ∧
+      finrank K (M ⧸ A) = finrank K (M ⧸ B) + finrank K (B ⧸ A.comap B.subtype) := by
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  let ψ : (B : Type _) →ₗ[K] (M ⧸ A) := A.mkQ ∘ₗ B.subtype
+  have hker : LinearMap.ker ψ = A.comap B.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = B.map A.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let eK : (B ⧸ A.comap B.subtype) ≃ₗ[K] (B.map A.mkQ : Submodule K (M ⧸ A)) :=
+    (Submodule.quotEquivOfEq _ _ hker.symm).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have : Module.Finite K (B.map A.mkQ : Submodule K (M ⧸ A)) := Module.Finite.equiv eK
+  have : Module.Finite K ((M ⧸ A) ⧸ B.map A.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (M ⧸ A) := Module.Finite.of_submodule_quotient (B.map A.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (B.map A.mkQ)
+  rw [LinearEquiv.finrank_eq e3, ← LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem globalSub_le_adeleSpace [HasPrincipalDivisors K F] :
+    globalSub K F ≤ adeleSpace K F := by
+  rintro _ ⟨f, rfl⟩
+  exact diagonal_mem_adeleSpace f
+
+theorem adeleBdd_sup_globalSub_le_adeleSpace [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+  sup_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_eq_comap [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBddPrincipal K F D = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype :=
+  Submodule.comap_subtype_sup_of_le_of_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_mono {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBddPrincipal K F D₁ ≤ adeleBddPrincipal K F D₂ :=
+  sup_le_sup_right (Submodule.comap_mono (adeleBdd_mono hD)) _
+
+section FiniteLSpace
+
+variable [IsCurveOver K F]
+
+theorem finiteDimensional_lSpace [hL0 : FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (D : Divisor K F) : FiniteDimensional K (LSpace D) := by
+  have h0D : (0 : Divisor K F) ≤ D ⊔ 0 := le_sup_right
+  have hDD : D ≤ D ⊔ 0 := le_sup_left
+  suffices h : FiniteDimensional K (LSpace (D ⊔ 0)) by
+    exact Module.Finite.of_injective (Submodule.inclusion (lSpace_mono hDD))
+      (Submodule.inclusion_injective _)
+  have := module_finite_adeleBdd_quotient (K := K) h0D
+  have hfinQ : FiniteDimensional K
+      (LSpace (D ⊔ 0) ⧸ (LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype) :=
+    Module.Finite.of_injective _ (lSpaceQuotientToAdeleBddQuotient_injective h0D)
+  have : FiniteDimensional K
+      ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype : Submodule K _) :=
+    Module.Finite.equiv (Submodule.comapSubtypeEquivOfLe (lSpace_mono h0D)).symm
+  exact Module.Finite.of_submodule_quotient
+    ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype)
+
+end FiniteLSpace
+
+
+theorem range_lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD)
+      = ((adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype).map
+          ((adeleBdd D₁).comap (adeleBdd D₂).subtype).mkQ := by
+  classical
+  ext z
+  obtain ⟨α, rfl⟩ := Submodule.Quotient.mk_surjective _ z
+  simp only [LinearMap.mem_range, Submodule.mem_map, Submodule.mem_comap, Submodule.coe_subtype,
+    Submodule.mkQ_apply]
+  constructor
+  · rintro ⟨x, hx⟩
+    obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+    have hxeq : Submodule.Quotient.mk
+        ((diagonalHom K F).restrict (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f)
+        = (Submodule.Quotient.mk α :
+            adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) := hx
+    refine ⟨α, ?_, rfl⟩
+    have hdiag2 : (diagonalHom K F (f : F)) ∈ adeleBdd D₂ := diagonal_mem_adeleBdd_iff.mpr f.2
+    have hsub : (α : Place K F → F) - diagonalHom K F (f : F) ∈ adeleBdd D₁ := by
+      have hq := (Submodule.Quotient.eq _).mp hxeq.symm
+      simpa using hq
+    refine Submodule.mem_sup.mpr ⟨(α : Place K F → F) - diagonalHom K F (f : F), hsub,
+      diagonalHom K F (f : F), diagonal_mem_globalSub _, ?_⟩
+    abel
+  · rintro ⟨β, hβ, hβeq⟩
+    have hβ' : (β : Place K F → F) ∈ adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F) :=
+      Submodule.mem_inf.mpr ⟨β.2, hβ⟩
+    rw [adeleBdd_inf_sup_globalSub hD, ← map_diagonal_lSpace] at hβ'
+    obtain ⟨γ, hγ, δ, ⟨f, hf, hfδ⟩, hsum⟩ := Submodule.mem_sup.mp hβ'
+    refine ⟨Submodule.Quotient.mk ⟨f, hf⟩, ?_⟩
+    rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk ⟨f, hf⟩)
+          = Submodule.Quotient.mk ((diagonalHom K F).restrict
+              (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) ⟨f, hf⟩) from rfl,
+      ← hβeq, Submodule.Quotient.eq]
+    refine Submodule.mem_comap.mpr ?_
+    change diagonalHom K F f - (β : Place K F → F) ∈ adeleBdd D₁
+    have hβsub : diagonalHom K F f - (β : Place K F → F) = -γ := by
+      rw [← hsum, hfδ]; ring
+    rw [hβsub]; exact (adeleBdd D₁).neg_mem hγ
+
+
+theorem finrank_adeleBddSup_quotient [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) [hL : FiniteDimensional K (LSpace D₂)] :
+    Module.Finite K (↥(adeleBdd D₂ ⊔ globalSub K F)
+        ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) ∧
+      (finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+          ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) : ℤ)
+        = (Divisor.degree D₂ - ell D₂) - (Divisor.degree D₁ - ell D₁) := by
+  classical
+  let A : Submodule K (adeleBdd D₂) := (adeleBdd D₁).comap (adeleBdd D₂).subtype
+  let B : Submodule K (adeleBdd D₂) :=
+    (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype
+  have hAB : A ≤ B := Submodule.comap_mono le_sup_left
+  have hfinA : Module.Finite K (adeleBdd D₂ ⧸ A) := module_finite_adeleBdd_quotient hD
+  have hdimA : (finrank K (adeleBdd D₂ ⧸ A) : ℤ) = Divisor.degree D₂ - Divisor.degree D₁ :=
+    finrank_adeleBdd_quotient_eq hD
+  have hran : LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD) = B.map A.mkQ :=
+    range_lSpaceQuotientToAdeleBddQuotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hdimL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K)
+      ((LSpace D₁).comap (LSpace D₂).subtype)
+    rw [← hℓ₁] at h; exact h.symm
+  have hdimB : ell D₂ = finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) + ell D₁ := by
+    rw [← hran, LinearMap.finrank_range_of_inj
+      (lSpaceQuotientToAdeleBddQuotient_injective hD)]
+    exact hdimL
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  have hfinB : Module.Finite K (adeleBdd D₂ ⧸ B) := Module.Finite.equiv e3
+  have hdim2 : finrank K (adeleBdd D₂ ⧸ A)
+      = finrank K (adeleBdd D₂ ⧸ B) + finrank K (B.map A.mkQ : Submodule K _) := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K) (M := adeleBdd D₂ ⧸ A)
+      (B.map A.mkQ)
+    rw [LinearEquiv.finrank_eq e3] at h; omega
+  have e2 := LinearMap.quotientInfEquivSupQuotient (R := K)
+    (adeleBdd D₂) (adeleBdd D₁ ⊔ globalSub K F)
+  have hsup : adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F) = adeleBdd D₂ ⊔ globalSub K F := by
+    rw [← sup_assoc, sup_eq_left.mpr (adeleBdd_mono hD)]
+  have hB' : (adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype = B := by
+    rw [Submodule.comap_subtype_self, top_inf_eq]
+  let eL : (adeleBdd D₂ ⧸ B) ≃ₗ[K]
+      (adeleBdd D₂ ⧸ ((adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+        (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype)) :=
+    Submodule.quotEquivOfEq _ _ hB'.symm
+  have hfin_iso : Module.Finite K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype) :=
+    Module.Finite.equiv (eL.trans e2)
+  have hdim_iso : finrank K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype)
+      = finrank K (adeleBdd D₂ ⧸ B) :=
+    (LinearEquiv.finrank_eq (eL.trans e2)).symm
+  have hcast : (finrank K (adeleBdd D₂ ⧸ A) : ℤ)
+      = (finrank K (adeleBdd D₂ ⧸ B) : ℤ) + ((ell D₂ : ℤ) - (ell D₁ : ℤ)) := by
+    have hb : (ell D₂ : ℤ)
+        = (finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) : ℤ) + (ell D₁ : ℤ) := by
+      exact_mod_cast hdimB
+    push_cast [hdim2]; linarith
+  have hgoal : (finrank K (adeleBdd D₂ ⧸ B) : ℤ)
+      = Divisor.degree D₂ - ↑(ell D₂) - (Divisor.degree D₁ - ↑(ell D₁)) := by
+    linarith [hdimA, hcast]
+  clear_value eL
+  exact hsup ▸ ⟨hfin_iso, by rw [hdim_iso]; exact hgoal⟩
+
+section Index
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+
+theorem adeleBddSup_eq_of_degree_sub_ell_eq {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)]
+    (heq : Divisor.degree D₂ - ell D₂ = Divisor.degree D₁ - ell D₁) :
+    adeleBdd D₂ ⊔ globalSub K F = adeleBdd D₁ ⊔ globalSub K F := by
+  obtain ⟨hfin, hdim⟩ := finrank_adeleBddSup_quotient hD
+  rw [heq, sub_self] at hdim
+  refine le_antisymm ?_ (sup_le_sup_right (adeleBdd_mono hD) _)
+  have := hfin
+  have hd0 : finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) = 0 := by
+    exact_mod_cast hdim
+  have hsub : Subsingleton (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) :=
+    Module.finrank_zero_iff.mp hd0
+  have htop := Submodule.Quotient.subsingleton_iff.mp hsub
+  intro x hx
+  have hxc : (⟨x, hx⟩ : ↥(adeleBdd D₂ ⊔ globalSub K F)) ∈
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype := by
+    rw [htop]; exact Submodule.mem_top
+  exact hxc
+
+end Index
+
+namespace RiemannGenusReachedAt
+p2m_export "AlgebraicCurve.RiemannGenusReachedAt" "finite mk eq isMax"
+end RiemannGenusReachedAt
+namespace RiemannGenusReachedAt
+p2m_open_scoped "AlgebraicCurve.RiemannGenusReachedAt" in
+private theorem _root_.AlgebraicCurve.RiemannGenusReachedAt.eq_of_ge [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {D : Divisor K F} (hD : D₀ ≤ D) :
+    Divisor.degree D - ell D = γ - 1 := by
+  have := finiteDimensional_lSpace (K := K) D
+  have hge : Divisor.degree D₀ - (ell D₀ : ℤ) ≤ Divisor.degree D - ell D := by
+    have := ell_sub_ell_le_degree_sub_degree (K := K) hD
+    linarith
+  exact le_antisymm (h.isMax D) (h.eq ▸ hge)
+
+end RiemannGenusReachedAt
+p2m_export "AlgebraicCurve" "RiemannGenusReachedAt.eq_of_ge"
+
+theorem adeleSpace_eq_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    adeleSpace K F = adeleBdd D₀ ⊔ globalSub K F := by
+  refine le_antisymm ?_ (adeleBdd_sup_globalSub_le_adeleSpace D₀)
+  rw [adeleSpace, iSup_le_iff]
+  intro D
+  refine le_trans (adeleBdd_mono (le_sup_left : D ≤ D ⊔ D₀)) ?_
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have heq : Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) = Divisor.degree D₀ - ell D₀ :=
+    (h.eq_of_ge le_sup_right).trans h.eq.symm
+  have hsup := adeleBddSup_eq_of_degree_sub_ell_eq (K := K)
+    (le_sup_right : D₀ ≤ D ⊔ D₀) heq
+  rw [← hsup]
+  exact le_sup_left
+
+theorem indexOfSpecialty_eq_zero_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    indexOfSpecialty D₀ = 0 := by
+  rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap, ← adeleSpace_eq_of_genusReached h,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.finrank_zero_of_subsingleton
+
+
+
+theorem gate_indexOfSpecialty_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  have h1 := (indexOfSpecialty_eq_of_genusReached h D₀).2
+  have h2 := h.eq
+  have h3 := indexOfSpecialty_eq_zero_of_genusReached h
+  exact_mod_cast h3
+
+theorem gate_riemannInequality_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Divisor.degree D + 1 - γ ≤ (ell D : ℤ) := by
+  have heq := (indexOfSpecialty_eq_of_genusReached h D).2
+  have hnn : (0 : ℤ) ≤ indexOfSpecialty D := Int.natCast_nonneg _
+  linarith
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem adeleSpaceMul_add [HasPrincipalDivisors K F] (f g : F) :
+    adeleSpaceMul K F (f + g) = adeleSpaceMul K F f + adeleSpaceMul K F g := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, LinearMap.add_apply, Submodule.coe_add,
+    Pi.add_apply, add_mul]
+
+theorem adeleSpaceMul_zero [HasPrincipalDivisors K F] :
+    adeleSpaceMul K F (0 : F) = 0 := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, zero_mul, LinearMap.zero_apply,
+    Submodule.coe_zero, Pi.zero_apply]
+
+theorem weilSmul_add_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f + g) φ = weilSmul K F f φ + weilSmul K F g φ := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_add, LinearMap.add_apply, map_add]
+
+theorem weilSmul_zero_left [HasPrincipalDivisors K F]
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (0 : F) φ = 0 := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_zero, LinearMap.zero_apply, map_zero]
+
+theorem weilSmul_neg_left [HasPrincipalDivisors K F] (f : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (-f) φ = -weilSmul K F f φ := by
+  have h := weilSmul_add_left (K := K) (F := F) f (-f) φ
+  rw [add_neg_cancel, weilSmul_zero_left] at h
+  exact (neg_eq_of_add_eq_zero_right h.symm).symm
+
+theorem weilSmul_sub_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f - g) φ = weilSmul K F f φ - weilSmul K F g φ := by
+  rw [sub_eq_add_neg, weilSmul_add_left, weilSmul_neg_left, sub_eq_add_neg]
+
+theorem weilSmul_eq_zero_iff_left [HasPrincipalDivisors K F]
+    {f : F} {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    weilSmul K F f φ = 0 ↔ f = 0 := by
+  refine ⟨fun h => ?_, fun h => h ▸ weilSmul_zero_left φ⟩
+  by_contra hf
+  exact hφ (weilSmul_injective hf (h.trans (map_zero (weilSmul K F f)).symm))
+
+theorem weilSmul_left_injective [HasPrincipalDivisors K F]
+    {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    Function.Injective (fun f : F => weilSmul K F f φ) := by
+  intro f g hfg
+  have hsub : weilSmul K F (f - g) φ = 0 := by
+    rw [weilSmul_sub_left, sub_eq_zero]; exact hfg
+  exact sub_eq_zero.mp ((weilSmul_eq_zero_iff_left hφ).mp hsub)
+
+variable (K F) in
+def doubleResiduePairing [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) :
+    LSpace (W - D) × LSpace (W - D) →ₗ[K] omegaSpace D :=
+  (residuePairing K F W D hφ).coprod (residuePairing K F W D hμ)
+
+theorem doubleResiduePairing_apply_coe [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (g h : LSpace (W - D)) :
+    (doubleResiduePairing K F W D hφ hμ (g, h) : Module.Dual K (adeleSpace K F))
+      = weilSmul K F (g : F) φ + weilSmul K F (h : F) μ := by
+  simp only [doubleResiduePairing, LinearMap.coprod_apply, Submodule.coe_add,
+    residuePairing_apply_coe]
+
+theorem doubleResiduePairing_injective [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ) :
+    Function.Injective (doubleResiduePairing K F W D hφ hμ) := by
+  rw [injective_iff_map_eq_zero]
+  rintro ⟨g, h⟩ heq
+  have heq' : weilSmul K F (g : F) φ + weilSmul K F (h : F) μ = 0 := by
+    have hcoe := congrArg Subtype.val heq
+    rwa [doubleResiduePairing_apply_coe, Submodule.coe_zero] at hcoe
+  rcases eq_or_ne (h : F) 0 with hh0 | hh0
+  · rw [hh0, weilSmul_zero_left, add_zero] at heq'
+    have hg0 : (g : F) = 0 := (weilSmul_eq_zero_iff_left hφ0).mp heq'
+    exact Prod.ext (Subtype.ext hg0) (Subtype.ext hh0)
+  · exfalso
+    have hμeq : weilSmul K F (h : F) μ = -weilSmul K F (g : F) φ := by
+      have h2 : weilSmul K F (h : F) μ + weilSmul K F (g : F) φ = 0 := by
+        rw [add_comm]; exact heq'
+      exact eq_neg_of_add_eq_zero_left h2
+    have hLHS : weilSmul K F (h : F)⁻¹ (weilSmul K F (h : F) μ) = μ := by
+      rw [← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hh0, weilSmul_one,
+        LinearMap.id_apply]
+    have hRHS : weilSmul K F (h : F)⁻¹ (-weilSmul K F (g : F) φ)
+        = weilSmul K F (-(g : F) * (h : F)⁻¹) φ := by
+      rw [map_neg, ← LinearMap.comp_apply, ← weilSmul_mul, neg_mul, weilSmul_neg_left]
+    exact hindep (-(g : F) * (h : F)⁻¹) (by rw [← hLHS, hμeq, hRHS])
+
+theorem two_mul_ell_le_indexOfSpecialty [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ)
+    [Module.Finite K (omegaSpace (K := K) (F := F) D)]
+    [Module.Finite K (LSpace (K := K) (F := F) (W - D))] :
+    2 * ell (W - D) ≤ indexOfSpecialty D := by
+  have hinj := doubleResiduePairing_injective W D hφ hμ hφ0 hindep
+  have hle := LinearMap.finrank_le_finrank_of_injective hinj
+  rw [Module.finrank_prod] at hle
+  rw [← finrank_omegaSpace_eq_indexOfSpecialty, two_mul]
+  exact hle
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+section Finiteness
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+theorem omegaSpace_finite_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Module.Finite K (omegaSpace (K := K) (F := F) D) := by
+  have := (indexOfSpecialty_eq_of_genusReached h D).1
+  exact Module.Finite.equiv (omegaSpaceEquivIndexDual D).symm
+
+end Finiteness
+
+section ParametricRankOne
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+
+theorem exists_weilSmul_eq_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {φ μ : Module.Dual K (adeleSpace K F)} {W : Divisor K F}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (hφ0 : φ ≠ 0) :
+    ∃ f : F, μ = weilSmul K F f φ := by
+  by_contra hcon
+  push Not at hcon
+  obtain ⟨P⟩ := ‹Nonempty (Place K F)›
+  set n : ℕ := 3 * γ.natAbs + 2 * (Divisor.degree W).natAbs + 4 with hn
+  set D : Divisor K F := -Finsupp.single P (n : ℤ) with hD
+  have hdegD : Divisor.degree D = -(n : ℤ) * (P.deg : ℤ) := by
+    rw [hD, map_neg, Divisor.degree_single]; ring
+  have hdegWD : Divisor.degree (W - D) = Divisor.degree W + (n : ℤ) * (P.deg : ℤ) := by
+    rw [map_sub, hdegD]; ring
+  have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+  have habsγ : -(|γ|) ≤ γ ∧ γ ≤ |γ| := ⟨neg_abs_le _, le_abs_self _⟩
+  have habsW : -|Divisor.degree W| ≤ Divisor.degree W ∧
+      Divisor.degree W ≤ |Divisor.degree W| := ⟨neg_abs_le _, le_abs_self _⟩
+  have hn_ge : 3 * |γ| + 2 * |Divisor.degree W| + 4 ≤ (n : ℤ) := by
+    rw [hn]; push_cast [Int.natCast_natAbs]; ring_nf; omega
+  have hndegP : (n : ℤ) ≤ (n : ℤ) * (P.deg : ℤ) := by nlinarith [Int.natCast_nonneg n]
+  have hellD : ell D = 0 := ell_eq_zero_of_degree_neg (by rw [hdegD]; nlinarith)
+  have hiD : (indexOfSpecialty D : ℤ) = (n : ℤ) * (P.deg : ℤ) - 1 + γ := by
+    have hidx := (indexOfSpecialty_eq_of_genusReached h D).2
+    rw [hellD, hdegD] at hidx; push_cast at hidx; linarith
+  have hlowerWD : Divisor.degree W + (n : ℤ) * (P.deg : ℤ) + 1 - γ
+      ≤ (ell (W - D) : ℤ) := by
+    have hlow := gate_riemannInequality_of_genusReached h (W - D)
+    rw [hdegWD] at hlow; exact hlow
+  have := omegaSpace_finite_of_genusReached h D
+  have := finiteDimensional_lSpace (K := K) (W - D)
+  have hdbl : (2 * ell (W - D) : ℤ) ≤ (indexOfSpecialty D : ℤ) := by
+    exact_mod_cast two_mul_ell_le_indexOfSpecialty W D hφ hμ hφ0 hcon
+  rw [hiD] at hdbl
+  nlinarith [habsγ.1, habsγ.2, habsW.1, habsW.2]
+
+theorem weilDifferentialRankOne_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    WeilDifferentialRankOne K F := by
+  intro φ hφmem hφ0 μ hμmem
+  obtain ⟨W₁, hφW₁⟩ := mem_weilDifferentialModule_iff.mp hφmem
+  obtain ⟨W₂, hμW₂⟩ := mem_weilDifferentialModule_iff.mp hμmem
+  have hφW : φ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_left hφW₁
+  have hμW : μ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_right hμW₂
+  obtain ⟨f, hf⟩ := exists_weilSmul_eq_of_genusReached h hφW hμW hφ0
+  exact ⟨f, hf, fun f' hf' => weilSmul_left_injective hφ0 (hf'.symm.trans hf)⟩
+
+end ParametricRankOne
+
+theorem residuePairing_surjective_of_rankOne_max [HasPrincipalDivisors K F]
+    (hRankOne : WeilDifferentialRankOne K F)
+    {W : Divisor K F} {φ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hφ0 : φ ≠ 0)
+    (hWmax : ∀ E : Divisor K F, φ ∈ omegaSpace E → E ≤ W) (D : Divisor K F) :
+    Function.Surjective (residuePairing K F W D hφ) := by
+  rintro ⟨μ, hμD⟩
+  have hφmem : φ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule W hφ
+  have hμmem : μ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule D hμD
+  obtain ⟨f, hf, -⟩ := hRankOne hφmem hφ0 hμmem
+  rcases eq_or_ne f 0 with rfl | hf0
+  · have hμ0 : (⟨μ, hμD⟩ : omegaSpace D) = 0 :=
+      Subtype.ext (hf.trans (weilSmul_zero_left φ))
+    exact ⟨0, (map_zero _).trans hμ0.symm⟩
+  · obtain ⟨P, hPord, _⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+    have hPinv : ∀ v, (-P) v = v.ord f⁻¹ := fun v => by
+      rw [Finsupp.neg_apply, hPord v, v.ord_inv]
+    have hinv : weilSmul K F f⁻¹ μ = φ := by
+      rw [hf, ← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hf0, weilSmul_one,
+        LinearMap.id_apply]
+    have hφD : φ ∈ omegaSpace (D + -P) := by
+      rw [← hinv]; exact weilSmul_mem_omegaSpace_add (inv_ne_zero hf0) hPinv hμD
+    have hDP : D + -P ≤ W := hWmax _ hφD
+    have hfL : f ∈ LSpace (W - D) := by
+      rw [mem_lSpace_iff_ord]; refine Or.inr fun v => ?_
+      have hv := hDP v
+      rw [Finsupp.add_apply, Finsupp.neg_apply, hPord v] at hv
+      rw [Finsupp.sub_apply]; linarith
+    exact ⟨⟨f, hfL⟩, Subtype.ext hf.symm⟩
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem exists_riemannGenusReachedAt_of_bounded
+    [IsCurveOver K F] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    ∃ (γ : ℤ) (D₀ : Divisor K F), RiemannGenusReachedAt γ D₀ := by
+  obtain ⟨γ, hγ⟩ := hbdd
+  obtain ⟨M, ⟨D₀, hD₀⟩, hMmax⟩ :=
+    Int.exists_greatest_of_bdd
+      (P := fun n => ∃ D : Divisor K F, Divisor.degree D - ell D = n)
+      ⟨γ, fun n ⟨D, hD⟩ => hD ▸ hγ D⟩
+      ⟨Divisor.degree (0 : Divisor K F) - ell (0 : Divisor K F), 0, rfl⟩
+  refine ⟨M + 1, D₀, ?_, ?_, ?_⟩
+  · exact finiteDimensional_lSpace D₀
+  · rw [hD₀]; ring
+  · intro D
+    have := hMmax (Divisor.degree D - ell D) ⟨D, rfl⟩
+    linarith
+
+theorem stichtenothGenusExists_of_bounded
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    StichtenothGenusExists K F :=
+  ⟨‹_›, ‹_›, exists_riemannGenusReachedAt_of_bounded hbdd⟩
+
+
+theorem indexOfSpecialty_sub_of_ge [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₀ D : Divisor K F} (hD : D₀ ≤ D)
+    [FiniteDimensional K (LSpace D)]
+    [hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀)] :
+    Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D) ∧
+      (Divisor.degree D - ell D) - (Divisor.degree D₀ - ell D₀)
+        = (indexOfSpecialty D₀ : ℤ) - (indexOfSpecialty D : ℤ) := by
+  have hABsub : adeleBdd D₀ ⊔ globalSub K F ≤ adeleBdd D ⊔ globalSub K F :=
+    sup_le_sup_right (adeleBdd_mono hD) _
+  have hBCsub : adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+    adeleBdd_sup_globalSub_le_adeleSpace _
+  obtain ⟨hfinBA, hdimBA⟩ := finrank_adeleBddSup_quotient (K := K) hD
+  have := hfinBA
+  have hfinCA : Module.Finite K (adeleSpace K F ⧸
+      (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [← adeleBddPrincipal_eq_comap]; exact hfin
+  obtain ⟨hfinCB, hdimCB⟩ := Submodule.finrank_quotient_chain'
+    (A := adeleBdd D₀ ⊔ globalSub K F) (B := adeleBdd D ⊔ globalSub K F)
+    (C := adeleSpace K F) hABsub hBCsub
+  have hi0 : indexOfSpecialty D₀
+      = finrank K (adeleSpace K F ⧸
+        (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap]
+  have hiD : indexOfSpecialty D
+      = finrank K (adeleSpace K F ⧸
+        (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap]
+  have := hfinCB
+  obtain ⟨_, hdimCA⟩ := Submodule.finrank_quotient_chain
+    (A := adeleBdd D₀ ⊔ globalSub K F) (B := adeleBdd D ⊔ globalSub K F)
+    (C := adeleSpace K F) hABsub hBCsub
+  refine ⟨?_, ?_⟩
+  · rw [show adeleBddPrincipal K F D
+        = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype
+      from adeleBddPrincipal_eq_comap D]
+    exact hfinCB
+  · have hcast : (indexOfSpecialty D₀ : ℤ)
+        = (indexOfSpecialty D : ℤ)
+          + (finrank K (↥(adeleBdd D ⊔ globalSub K F)
+              ⧸ (adeleBdd D₀ ⊔ globalSub K F).comap
+                (adeleBdd D ⊔ globalSub K F).subtype) : ℤ) := by
+      rw [hiD, hi0]; exact_mod_cast hdimCA
+    linarith [hdimBA, hcast]
+
+theorem degreeSub_ell_le_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {D₀ : Divisor K F}
+    (hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀))
+    (D : Divisor K F) :
+    Divisor.degree D - ell D ≤ (Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀ := by
+  have := hfin
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have hmono : Divisor.degree D - (ell D : ℤ)
+      ≤ Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) (le_sup_left : D ≤ D ⊔ D₀)
+    linarith
+  obtain ⟨_, heq⟩ :=
+    indexOfSpecialty_sub_of_ge (K := K) (le_sup_right : D₀ ≤ D ⊔ D₀)
+  have hi0 : (0 : ℤ) ≤ indexOfSpecialty (D ⊔ D₀) := Int.natCast_nonneg _
+  linarith
+
+theorem riemannGenusBounded_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hfin : IndexOfSpecialtyFinite K F) :
+    RiemannGenusBounded K F := by
+  obtain ⟨D₀, hD₀⟩ := hfin
+  exact ⟨(Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀,
+    degreeSub_ell_le_of_indexFinite hD₀⟩
+
+theorem stichtenothGenusExists_of_indexFinite
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hfin : IndexOfSpecialtyFinite K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_bounded (riemannGenusBounded_of_indexFinite hfin)
+
+theorem indexOfSpecialtyFinite_of_stichtenothGenusExists
+    [IsCurveOver K F] (hSG : StichtenothGenusExists K F) :
+    IndexOfSpecialtyFinite K F := by
+  obtain ⟨hne, hL0, γ, D₀, hD₀⟩ := hSG
+  have := hne; have := hL0
+  refine ⟨D₀, ?_⟩
+  rw [show adeleBddPrincipal K F D₀
+      = (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype
+    from adeleBddPrincipal_eq_comap D₀, ← adeleSpace_eq_of_genusReached hD₀,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.Finite.of_finite
+
+theorem stichtenothGenusExists_iff_indexFinite
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] :
+    StichtenothGenusExists K F ↔ IndexOfSpecialtyFinite K F :=
+  ⟨indexOfSpecialtyFinite_of_stichtenothGenusExists,
+    stichtenothGenusExists_of_indexFinite⟩
+
+theorem gate_indexOfSpecialty_engine_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  exact_mod_cast indexOfSpecialty_eq_zero_of_genusReached h
+
+theorem gate_stichtenothGenus_le_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {D₀ : Divisor K F}
+    (hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀))
+    {γ : ℤ} {D₁ : Divisor K F} (h : RiemannGenusReachedAt γ D₁) :
+    γ - 1 ≤ (Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀ := by
+  have := degreeSub_ell_le_of_indexFinite hfin D₁
+  rw [h.eq] at this; exact this
+
+theorem gate_riemannGenusBounded_of_reachedAt
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    RiemannGenusBounded K F :=
+  ⟨γ - 1, h.isMax⟩
+
+theorem gate_indexOfSpecialtyFinite_at_zero [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F (0 : Divisor K F)) :=
+  (indexOfSpecialty_eq_of_genusReached h 0).1
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem mul_mem_lSpace_add {D E : Divisor K F} {f g : F}
+    (hf : f ∈ LSpace D) (hg : g ∈ LSpace E) :
+    f * g ∈ LSpace (D + E) := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · rw [zero_mul]; exact (LSpace _).zero_mem
+  rcases eq_or_ne g 0 with rfl | hg0
+  · rw [mul_zero]; exact (LSpace _).zero_mem
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun v => ?_
+  rw [Finsupp.add_apply, neg_add, v.ord_mul hf0 hg0]
+  exact add_le_add ((mem_lSpace_iff_ord.mp hf).resolve_left hf0 v)
+    ((mem_lSpace_iff_ord.mp hg).resolve_left hg0 v)
+
+theorem pow_mem_lSpace_nsmul {B : Divisor K F} {f : F} (hf : f ∈ LSpace B) (j : ℕ) :
+    f ^ j ∈ LSpace (j • B) := by
+  induction j with
+  | zero => simpa using one_mem_lSpace_zero (K := K) (F := F)
+  | succ j ih =>
+    rw [pow_succ, succ_nsmul]
+    exact mul_mem_lSpace_add ih hf
+
+namespace PoleDivisorPackage
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degB_eq u B hB_eff n lin_indep mk c x hn_pos \
+  hu_mem mk.injEq hx_mem"
+p2m_open "AlgebraicCurve.PoleDivisorPackage"
+
+variable (P : PoleDivisorPackage K F)
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.pow_mul_u_mem_lSpace (j : ℕ) (i : Fin P.n)
+    :
+    P.x ^ j * P.u i ∈ LSpace ((j + P.c) • P.B) := by
+  rw [add_nsmul]
+  exact mul_mem_lSpace_add (pow_mem_lSpace_nsmul P.hx_mem j) (P.hu_mem i)
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "pow_mul_u_mem_lSpace"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.pow_mul_u_mem_lSpace_of_le {j m : ℕ}
+    (hjm : j + P.c ≤ m) (i : Fin P.n) :
+    P.x ^ j * P.u i ∈ LSpace (m • P.B) := by
+  refine lSpace_mono ?_ (P.pow_mul_u_mem_lSpace j i)
+  intro v
+  have hBv : (0 : ℤ) ≤ P.B v := P.hB_eff v
+  change ((j + P.c) • P.B) v ≤ (m • P.B) v
+  simp only [Finsupp.smul_apply, nsmul_eq_mul]
+  exact mul_le_mul_of_nonneg_right (by exact_mod_cast hjm) hBv
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "pow_mul_u_mem_lSpace_of_le"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.ell_nsmul_poleDivisor_ge [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    (P.n : ℤ) * (m - P.c + 1) ≤ ell (m • P.B) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  set g : Fin (m - P.c + 1) × Fin P.n → LSpace (m • P.B) :=
+    fun p => ⟨P.x ^ (p.1 : ℕ) * P.u p.2,
+      P.pow_mul_u_mem_lSpace_of_le (by have := p.1.isLt; omega) p.2⟩
+    with hgdef
+  have hsub : LinearIndependent K (fun p => (g p : F)) := by
+    have heq : (fun p => (g p : F))
+        = (fun p : ℕ × Fin P.n => P.x ^ p.1 * P.u p.2)
+            ∘ (fun p : Fin (m - P.c + 1) × Fin P.n => ((p.1 : ℕ), p.2)) := by
+      funext p; rfl
+    rw [heq]
+    refine P.lin_indep.comp _ ?_
+    intro p q hpq
+    simp only [Prod.mk.injEq] at hpq
+    exact Prod.ext (Fin.val_injective hpq.1) hpq.2
+  have hg : LinearIndependent K g := hsub.of_comp (LSpace (m • P.B)).subtype
+  have hcard := hg.fintype_card_le_finrank
+  rw [Fintype.card_prod, Fintype.card_fin, Fintype.card_fin] at hcard
+  have hZ : ((m - P.c + 1) * P.n : ℤ) ≤ (ell (m • P.B) : ℤ) := by exact_mod_cast hcard
+  have heq : (((m - P.c + 1 : ℕ) : ℤ) * P.n : ℤ) = (P.n : ℤ) * ((m : ℤ) - P.c + 1) := by
+    rw [Nat.cast_add, Nat.cast_sub hm, Nat.cast_one]; ring
+  linarith
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "ell_nsmul_poleDivisor_ge"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.degree_nsmul_sub_ell_le [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    Divisor.degree (m • P.B) - ell (m • P.B) ≤ (P.n : ℤ) * (P.c - 1) := by
+  have hge := P.ell_nsmul_poleDivisor_ge hm
+  have hdeg : Divisor.degree (m • P.B) = (m : ℤ) * P.n := by
+    rw [show m • P.B = (m : ℤ) • P.B from (natCast_zsmul _ _).symm,
+      Divisor.degree.map_zsmul, smul_eq_mul, P.degB_eq]
+  linarith
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degree_nsmul_sub_ell_le"
+end PoleDivisorPackage
+
+namespace PoleDivisorPackage
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degB_eq u B hB_eff n lin_indep mk c x hn_pos \
+  hu_mem mk.injEq hx_mem"
+end PoleDivisorPackage
+namespace PoleDivisorPackage
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.ell_nsmul_sub_pos [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) {A : Divisor K F} (hA : 0 ≤ A) {m : ℕ} (hm : P.c ≤ m)
+    (hbig : Divisor.degree A < (P.n : ℤ) * (m - P.c + 1)) :
+    0 < ell (m • P.B - A) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  have hle : m • P.B - A ≤ m • P.B := by
+    intro v
+    have hAv : (0 : ℤ) ≤ A v := hA v
+    rw [Finsupp.sub_apply]
+    linarith
+  have h48 := ell_sub_ell_le_degree_sub_degree (K := K) hle
+  rw [map_sub, sub_sub_cancel] at h48
+  have h412 := P.ell_nsmul_poleDivisor_ge hm
+  have : (0 : ℤ) < (ell (m • P.B - A) : ℤ) := by linarith
+  exact_mod_cast this
+
+end PoleDivisorPackage
+p2m_export "AlgebraicCurve" "PoleDivisorPackage.ell_nsmul_sub_pos"
+namespace PoleDivisorPackage
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.degree_sub_ell_le [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) (D : Divisor K F) :
+    Divisor.degree D - ell D ≤ (P.n : ℤ) * (P.c - 1) := by
+  classical
+  set D' : Divisor K F := D ⊔ 0 with hD'def
+  have hD'eff : 0 ≤ D' := le_sup_right
+  have hDD' : D ≤ D' := le_sup_left
+  have := finiteDimensional_lSpace (K := K) D'
+  have hmono : Divisor.degree D - (ell D : ℤ) ≤ Divisor.degree D' - ell D' := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hDD'
+    linarith
+  set m : ℕ := P.c + (Divisor.degree D').toNat with hmdef
+  have hcm : P.c ≤ m := Nat.le_add_right _ _
+  have hdegD' : 0 ≤ Divisor.degree D' := Divisor.degree_nonneg_of_nonneg hD'eff
+  have hbig : Divisor.degree D' < (P.n : ℤ) * (m - P.c + 1) := by
+    have hcast : ((m : ℤ) - P.c) = Divisor.degree D' := by
+      simp only [hmdef, Nat.cast_add, add_sub_cancel_left, Int.toNat_of_nonneg hdegD']
+    rw [hcast]
+    have hn1 : (1 : ℤ) ≤ P.n := by exact_mod_cast P.hn_pos
+    nlinarith
+  have hellpos := P.ell_nsmul_sub_pos hD'eff hcm hbig
+  have hnebot : LSpace (m • P.B - D') ≠ ⊥ :=
+    fun h => by rw [ell, h, finrank_bot] at hellpos; exact lt_irrefl 0 hellpos
+  obtain ⟨z, hzL, hz0⟩ := (Submodule.ne_bot_iff _).mp hnebot
+  obtain ⟨Dz, hDzord, hDzdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) z hz0
+  have hzmem := (mem_lSpace_iff_ord.mp hzL).resolve_left hz0
+  have hD'le : D' ≤ m • P.B + Dz := by
+    intro v
+    have := hzmem v
+    simp only [Finsupp.add_apply, Finsupp.sub_apply, neg_sub] at this ⊢
+    rw [hDzord]; linarith
+  have hellshift : ell (m • P.B + Dz) = ell (m • P.B) :=
+    (LinearEquiv.finrank_eq (lSpaceShiftEquiv (m • P.B) hz0 hDzord)).symm
+  have hdegshift : Divisor.degree (m • P.B + Dz) = Divisor.degree (m • P.B) := by
+    rw [map_add, hDzdeg, add_zero]
+  have := finiteDimensional_lSpace (K := K) (m • P.B + Dz)
+  have hmono' : Divisor.degree D' - (ell D' : ℤ)
+      ≤ Divisor.degree (m • P.B + Dz) - ell (m • P.B + Dz) := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hD'le
+    linarith
+  rw [hellshift, hdegshift] at hmono'
+  have h412 := P.degree_nsmul_sub_ell_le hcm
+  linarith
+
+end PoleDivisorPackage
+p2m_export "AlgebraicCurve" "PoleDivisorPackage.degree_sub_ell_le"
+
+theorem riemannGenusBounded_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    RiemannGenusBounded K F :=
+  ⟨(P.n : ℤ) * (P.c - 1), P.degree_sub_ell_le⟩
+
+theorem stichtenothGenusExists_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_bounded (riemannGenusBounded_of_poleDivisorPackage P)
+
+theorem indexOfSpecialtyFinite_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_stichtenothGenusExists
+    (stichtenothGenusExists_of_poleDivisorPackage P)
+
+theorem indexOfSpecialtyFinite_of_hasPoleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (h : HasPoleDivisorPackage K F) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_poleDivisorPackage h.some
+
+theorem stichtenothGenusExists_of_hasPoleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (h : HasPoleDivisorPackage K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_poleDivisorPackage h.some
+
+theorem gate_stichtenothGenus_le_of_poleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F)
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    γ ≤ (P.n : ℤ) * (P.c - 1) + 1 := by
+  have := P.degree_sub_ell_le D₀
+  rw [h.eq] at this; linarith
+
+theorem gate_ell_c_nsmul_ge [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    (P.n : ℤ) ≤ ell (P.c • P.B) := by
+  have h := P.ell_nsmul_poleDivisor_ge (le_refl P.c)
+  simp only [sub_self, zero_add, mul_one] at h
+  exact h
+
+theorem gate_x_transcendental_of_poleDivisorPackage (P : PoleDivisorPackage K F) :
+    LinearIndependent K (fun j : ℕ => P.x ^ j * P.u ⟨0, P.hn_pos⟩) := by
+  refine P.lin_indep.comp (fun j => (j, ⟨0, P.hn_pos⟩)) ?_
+  intro a b hab
+  exact (Prod.mk.injEq .. ▸ hab).1
+
+theorem gate_u_linearIndependent_of_poleDivisorPackage (P : PoleDivisorPackage K F) :
+    LinearIndependent K P.u := by
+  have h : LinearIndependent K (fun i : Fin P.n => P.x ^ (0 : ℕ) * P.u i) := by
+    refine P.lin_indep.comp (fun i => (0, i)) ?_
+    intro a b hab
+    exact (Prod.mk.injEq .. ▸ hab).2
+  simpa using h
+
+end AlgebraicCurve
+
+end
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+scoped instance instSumRamificationInertia_port {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F']
+    [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+    [HasPrincipalDivisors K F'] : SumRamificationInertia K F F' :=
+  ⟨fun v => Place.sum_ramificationIndex_mul_inertiaDeg v⟩
+end AlgebraicCurve
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+
+namespace TranscendenceTower
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF poleDivisor RegularOutside hx_indep hxreg v \
+  mk.injEq mk hvdeg x hxv"
+p2m_open "AlgebraicCurve.TranscendenceTower"
+
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F]
+variable (T : TranscendenceTower K E F)
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.x_ne_zero : T.x ≠ 0 := fun h => by
+  have := T.hxv; rw [h, Place.ord_zero] at this; exact absurd this (by decide)
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "x_ne_zero"
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+theorem xF_ne_zero : T.xF ≠ 0 :=
+  fun h => T.x_ne_zero ((algebraMap E F).injective (by rwa [map_zero]))
+
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.poleDivisor_apply (w : Place K F) :
+    T.poleDivisor w = (w.ramificationIndex E : ℤ) * (Finsupp.single T.v 1) (w.restrict E) :=
+  Divisor.pullback_apply (Finsupp.single T.v 1) w
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "poleDivisor_apply"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.poleDivisor_nonneg :
+    0 ≤ T.poleDivisor := by
+  classical
+  intro w
+  rw [Finsupp.coe_zero, Pi.zero_apply, T.poleDivisor_apply, Finsupp.single_apply]
+  refine mul_nonneg (Int.natCast_nonneg _) ?_
+  split_ifs <;> simp
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "poleDivisor_nonneg"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.xF_mem_lSpace_poleDivisor :
+    T.xF ∈ LSpace T.poleDivisor := by
+  classical
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun w => ?_
+  rw [T.poleDivisor_apply, Place.ord_restrict, Finsupp.single_apply]
+  rcases eq_or_ne (w.restrict E) T.v with hw | hw
+  · simp only [hw, T.hxv, ite_true, mul_one, mul_neg_one, le_refl]
+  · simp only [ite_eq_right (Ne.symm hw), mul_zero, neg_zero]
+    exact mul_nonneg (Int.natCast_nonneg _) (T.hxreg _ hw)
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF_mem_lSpace_poleDivisor"
+
+private theorem _root_.AlgebraicCurve.TranscendenceTower.degree_poleDivisor_eq_finrank :
+    Divisor.degree T.poleDivisor = (Module.finrank E F : ℤ) := by
+  rw [poleDivisor, Divisor.degree_pullback, Divisor.degree_single, T.hvdeg]
+  push_cast; ring
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "degree_poleDivisor_eq_finrank"
+omit [FiniteDimensional E F] in
+private theorem
+  _root_.AlgebraicCurve.TranscendenceTower.mem_lSpace_nsmul_poleDivisor_of_regular_outside {f : F}
+    (hreg : ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord f)
+    {c : ℕ} (hc : ∀ w ∈ T.v.fiber F, -(c : ℤ) ≤ w.ord f) :
+    f ∈ LSpace (c • T.poleDivisor) := by
+  classical
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact (LSpace _).zero_mem
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun w => ?_
+  rw [Finsupp.smul_apply, T.poleDivisor_apply, Finsupp.single_apply, nsmul_eq_mul]
+  rcases eq_or_ne (w.restrict E) T.v with hw | hw
+  · simp only [hw, ite_true, mul_one]
+    have he : (1 : ℤ) ≤ w.ramificationIndex E := by
+      exact_mod_cast w.ramificationIndex_pos (F := E)
+    have hbdd := hc w (Place.mem_fiber.mpr hw)
+    nlinarith [Int.natCast_nonneg c]
+  · simp only [ite_eq_right (Ne.symm hw), mul_zero, neg_zero]
+    exact hreg w hw
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "mem_lSpace_nsmul_poleDivisor_of_regular_outside"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.exists_forall_mem_lSpace_nsmul_poleDivisor
+    {n : ℕ} (u : Fin n → F)
+    (hreg : ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)) :
+    ∃ c : ℕ, ∀ i, u i ∈ LSpace (c • T.poleDivisor) := by
+  classical
+  refine ⟨(Finset.univ : Finset (Fin n)).sup fun i =>
+    (T.v.fiber F).sup fun w => (-(w.ord (u i))).toNat,
+    fun i => T.mem_lSpace_nsmul_poleDivisor_of_regular_outside (hreg i) ?_⟩
+  intro w hw
+  have h1 : (-(w.ord (u i))).toNat
+      ≤ (T.v.fiber F).sup fun w' => (-(w'.ord (u i))).toNat :=
+    Finset.le_sup (f := fun w' => (-(w'.ord (u i))).toNat) hw
+  have h2 : ((T.v.fiber F).sup fun w' => (-(w'.ord (u i))).toNat)
+      ≤ (Finset.univ : Finset (Fin n)).sup fun i' =>
+          (T.v.fiber F).sup fun w' => (-(w'.ord (u i'))).toNat :=
+    Finset.le_sup (f := fun i' => (T.v.fiber F).sup fun w' => (-(w'.ord (u i'))).toNat)
+      (Finset.mem_univ i)
+  have htnat : -(w.ord (u i)) ≤ ((-(w.ord (u i))).toNat : ℤ) := Int.self_le_toNat _
+  omega
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "exists_forall_mem_lSpace_nsmul_poleDivisor"
+end TranscendenceTower
+
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F]
+
+section PrincipalDivisors
+
+variable [HasPrincipalDivisors K F]
+
+namespace IntegralBasisInLSpace
+p2m_export "AlgebraicCurve.IntegralBasisInLSpace" "hu_indep c u mk.injEq hu_mem mk"
+end IntegralBasisInLSpace
+p2m_open_scoped "AlgebraicCurve.IntegralBasisInLSpace" in
+def IntegralBasisInLSpace.ofRegularOutside (T : TranscendenceTower K E F)
+    (u : Fin (Module.finrank E F) → F) (hu_indep : LinearIndependent E u)
+    (hreg : ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)) :
+    IntegralBasisInLSpace T where
+  c := (T.exists_forall_mem_lSpace_nsmul_poleDivisor u hreg).choose
+  u := u
+  hu_indep := hu_indep
+  hu_mem := (T.exists_forall_mem_lSpace_nsmul_poleDivisor u hreg).choose_spec
+
+omit [FiniteDimensional E F] in
+theorem hasIntegralBasisInLSpace_of_regularOutside (T : TranscendenceTower K E F)
+    (h : HasIntegralBasisRegularOutside K E F T) :
+    HasIntegralBasisInLSpace K E F T := by
+  obtain ⟨u, hu_indep, hreg⟩ := h
+  exact ⟨IntegralBasisInLSpace.ofRegularOutside T u hu_indep hreg⟩
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+theorem linearIndependent_pow_mul {x : E} {n : ℕ} {u : Fin n → F}
+    (hx : LinearIndependent K (fun j : ℕ => x ^ j)) (hu : LinearIndependent E u) :
+    LinearIndependent K (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2) := by
+  have heq : (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2)
+      = (fun p : ℕ × Fin n => (x ^ p.1) • u p.2) := by
+    funext p
+    rw [Algebra.smul_def, map_pow]
+  rw [heq]
+  exact linearIndependent_smul (R := K) (S := E) (A := F) hx hu
+
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+def PoleDivisorPackage.ofTranscendenceTower (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    PoleDivisorPackage K F where
+  x := T.xF
+  B := T.poleDivisor
+  hB_eff := T.poleDivisor_nonneg
+  hx_mem := T.xF_mem_lSpace_poleDivisor
+  n := Module.finrank E F
+  hn_pos := Module.finrank_pos
+  degB_eq := T.degree_poleDivisor_eq_finrank
+  c := IB.c
+  u := IB.u
+  hu_mem := IB.hu_mem
+  lin_indep := linearIndependent_pow_mul T.hx_indep IB.hu_indep
+
+theorem hasPoleDivisorPackage_of_transcendenceTower
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    HasPoleDivisorPackage K F :=
+  ⟨PoleDivisorPackage.ofTranscendenceTower T IB⟩
+
+theorem hasPoleDivisorPackage_of_hasIntegralBasisInLSpace
+    (T : TranscendenceTower K E F) (h : HasIntegralBasisInLSpace K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_transcendenceTower T h.some
+
+theorem hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside
+    (T : TranscendenceTower K E F) (h : HasIntegralBasisRegularOutside K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisInLSpace T
+    (hasIntegralBasisInLSpace_of_regularOutside T h)
+
+end PrincipalDivisors
+
+theorem indexOfSpecialtyFinite_of_transcendenceTower [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem stichtenothGenusExists_of_transcendenceTower [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem gate_ofTranscendenceTower_n_eq [HasPrincipalDivisors K F] (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    (PoleDivisorPackage.ofTranscendenceTower T IB).n = Module.finrank E F := rfl
+
+theorem gate_ofTranscendenceTower_B_eq [HasPrincipalDivisors K F] (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    (PoleDivisorPackage.ofTranscendenceTower T IB).B = T.poleDivisor := rfl
+
+theorem gate_ofTranscendenceTower_x_transcendental [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    LinearIndependent K
+      (fun j : ℕ => T.xF ^ j *
+        (PoleDivisorPackage.ofTranscendenceTower T IB).u ⟨0, Module.finrank_pos⟩) :=
+  gate_x_transcendental_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem gate_degree_pullback_single_of_deg_eq [HasPrincipalDivisors K F]
+    (v : Place K E) (d : ℕ) (hd : v.deg = d) :
+    Divisor.degree (Divisor.pullback F (Finsupp.single v (1 : ℤ)))
+      = (Module.finrank E F : ℤ) * d := by
+  rw [Divisor.degree_pullback, Divisor.degree_single, hd]; ring
+
+theorem gate_stichtenothGenus_le_of_transcendenceTower [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T)
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    γ ≤ (Module.finrank E F : ℤ) * (IB.c - 1) + 1 :=
+  gate_stichtenothGenus_le_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB) h
+
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open Module
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~restrict_plac\
+  eOfPrime~placeOfPrime~comap_algebraMap_ne_top"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral {f : F}
+    (hf : IsIntegral w.toValuationSubring f) :
+    f ∈ w.toValuationSubring := by
+  obtain ⟨y, hy⟩ := IsIntegrallyClosed.isIntegral_iff.mp hf
+  exact hy ▸ y.2
+
+p2m_export "AlgebraicCurve.Place" "mem_of_isIntegral"
+
+theorem ord_nonneg_of_isIntegral {f : F} (hf : IsIntegral w.toValuationSubring f) :
+    0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral hf)
+
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral_of_algebraMap_mem {A : Type*}
+    [CommRing A] [Algebra A F]
+    (hA : ∀ a : A, algebraMap A F a ∈ w.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : f ∈ w.toValuationSubring := by
+  let : Algebra A w.toValuationSubring :=
+    ((algebraMap A F).codRestrict w.toValuationSubring.toSubring hA).toAlgebra
+  have : IsScalarTower A w.toValuationSubring F :=
+    IsScalarTower.of_algebraMap_eq fun a => rfl
+  exact w.mem_of_isIntegral hf.tower_top
+
+p2m_export "AlgebraicCurve.Place" "mem_of_isIntegral_of_algebraMap_mem"
+
+theorem ord_nonneg_of_isIntegral_of_algebraMap_mem {A : Type*} [CommRing A] [Algebra A F]
+    (hA : ∀ a : A, algebraMap A F a ∈ w.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : 0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral_of_algebraMap_mem hA hf)
+
+end Place
+
+section Bridge
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+variable {A : Type*} [CommRing A] [Algebra A E] [Algebra A F] [IsScalarTower A E F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+end Place
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral_of_restrict [Algebra.IsIntegral E F]
+    (w : Place K F)
+    {u : Place K E} (hw : w.restrict E = u)
+    (hA : ∀ a : A, algebraMap A E a ∈ u.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : f ∈ w.toValuationSubring := by
+  refine w.mem_of_isIntegral_of_algebraMap_mem (fun a => ?_) hf
+  rw [IsScalarTower.algebraMap_apply A E F, ← w.mem_restrict_iff, hw]
+  exact hA a
+
+end Place
+p2m_export "AlgebraicCurve" "Place.mem_of_isIntegral_of_restrict"
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.ord_nonneg_of_isIntegral_of_restrict
+    [Algebra.IsIntegral E F] (w : Place K F)
+    {u : Place K E} (hw : w.restrict E = u)
+    (hA : ∀ a : A, algebraMap A E a ∈ u.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : 0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral_of_restrict hw hA hf)
+
+end Place
+p2m_export "AlgebraicCurve" "Place.ord_nonneg_of_isIntegral_of_restrict"
+namespace TranscendenceTower
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF poleDivisor RegularOutside hx_indep hxreg v \
+  mk.injEq mk hvdeg x hxv"
+end TranscendenceTower
+namespace TranscendenceTower
+p2m_open_scoped "AlgebraicCurve.TranscendenceTower" in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.ord_nonneg_of_isIntegral_of_regularOutside
+    [Algebra.IsIntegral E F] (T : TranscendenceTower K E F) (hA : T.RegularOutside A)
+    {f : F} (hf : IsIntegral A f) :
+    ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord f := fun w hw =>
+  w.ord_nonneg_of_isIntegral_of_restrict rfl (hA _ hw) hf
+
+end TranscendenceTower
+p2m_export "AlgebraicCurve" "TranscendenceTower.ord_nonneg_of_isIntegral_of_regularOutside"
+end Bridge
+
+section Headline
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F]
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+theorem linearIndependent_reindex_basis {s : Finset F} (b : Basis s E F) :
+    LinearIndependent E (fun i : Fin (Module.finrank E F) =>
+      b ((Fintype.equivFinOfCardEq (Module.finrank_eq_card_basis b).symm).symm i)) :=
+  b.linearIndependent.comp _ (Equiv.injective _)
+
+theorem hasIntegralBasisRegularOutside_of_isFractionRing
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    HasIntegralBasisRegularOutside K E F T := by
+  obtain ⟨s, b, hint⟩ := FiniteDimensional.exists_is_basis_integral A E F
+  set e : Fin (Module.finrank E F) ≃ s :=
+    (Fintype.equivFinOfCardEq (Module.finrank_eq_card_basis b).symm).symm
+  refine ⟨fun i => b (e i), linearIndependent_reindex_basis b, fun i w hw => ?_⟩
+  exact T.ord_nonneg_of_isIntegral_of_regularOutside hA (hint (e i)) w hw
+
+theorem hasIntegralBasisRegularOutside_of_hasRegularFractionSubring
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    HasIntegralBasisRegularOutside K E F T := by
+  obtain ⟨A, hfrac, hreg⟩ := h
+  have : IsFractionRing A E := hfrac
+  exact hasIntegralBasisRegularOutside_of_isFractionRing (A := A) T
+    (fun u hu a => hreg u hu (a : E) a.property)
+
+theorem hasPoleDivisorPackage_of_isFractionRing [HasPrincipalDivisors K F]
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside T
+    (hasIntegralBasisRegularOutside_of_isFractionRing T hA)
+
+theorem stichtenothGenusExists_of_isFractionRing [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasPoleDivisorPackage
+    (hasPoleDivisorPackage_of_isFractionRing T hA)
+
+theorem hasPoleDivisorPackage_of_hasRegularFractionSubring [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside T
+    (hasIntegralBasisRegularOutside_of_hasRegularFractionSubring T h)
+
+theorem stichtenothGenusExists_of_hasRegularFractionSubring [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasPoleDivisorPackage
+    (hasPoleDivisorPackage_of_hasRegularFractionSubring T h)
+
+namespace TranscendenceTower
+p2m_open_scoped "AlgebraicCurve.TranscendenceTower" in
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.adjoin_x_regularOutside (T :
+  TranscendenceTower K E F) :
+    ∀ u : Place K E, u ≠ T.v →
+      ∀ a ∈ Algebra.adjoin K {T.x}, a ∈ u.toValuationSubring := by
+  intro u hu a ha
+  let S : Subalgebra K E :=
+    { u.toValuationSubring.toSubsemiring with
+      algebraMap_mem' := u.algebraMap_mem' }
+  suffices h : a ∈ S from h
+  refine Algebra.adjoin_le ?_ ha
+  intro y hy
+  rw [Set.mem_singleton_iff] at hy
+  subst hy
+  change T.x ∈ u.toValuationSubring
+  exact AlgebraicCurve.Place.mem_of_ord_nonneg u T.x_ne_zero (T.hxreg u hu)
+
+end TranscendenceTower
+p2m_export "AlgebraicCurve" "TranscendenceTower.adjoin_x_regularOutside"
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+theorem hasRegularFractionSubring_of_adjoin_x_isFractionRing
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    HasRegularFractionSubring K E F T :=
+  ⟨Algebra.adjoin K {T.x}, hfrac, T.adjoin_x_regularOutside⟩
+
+theorem hasIntegralBasisRegularOutside_of_adjoin_x_isFractionRing
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    HasIntegralBasisRegularOutside K E F T :=
+  hasIntegralBasisRegularOutside_of_hasRegularFractionSubring T
+    (hasRegularFractionSubring_of_adjoin_x_isFractionRing T hfrac)
+
+theorem stichtenothGenusExists_of_adjoin_x_isFractionRing [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasRegularFractionSubring T
+    (hasRegularFractionSubring_of_adjoin_x_isFractionRing T hfrac)
+
+end Headline
+
+section Gates
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem gate_mem_of_isIntegral_recovers_comap (w : Place K F) (E : Type*) [Field E]
+    [Algebra E F] [Algebra.IsIntegral E F]
+    (hE : ∀ a : E, algebraMap E F a ∈ w.toValuationSubring) (f : F) :
+    f ∈ w.toValuationSubring := by
+  let : Algebra E w.toValuationSubring :=
+    ((algebraMap E F).codRestrict w.toValuationSubring.toSubring hE).toAlgebra
+  have : IsScalarTower E w.toValuationSubring F :=
+    IsScalarTower.of_algebraMap_eq fun _ => rfl
+  exact w.mem_of_isIntegral (Algebra.IsIntegral.isIntegral (R := E) f).tower_top
+
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+
+theorem gate_bridge_recovers_hxreg [Algebra.IsIntegral E F]
+    (T : TranscendenceTower K E F) (w : Place K F) (hw : w.restrict E ≠ T.v) :
+    0 ≤ w.ord T.xF := by
+  rw [TranscendenceTower.xF, Place.ord_restrict]
+  exact mul_nonneg (Int.natCast_nonneg _) (T.hxreg _ hw)
+
+theorem gate_regularOutside_mono (T : TranscendenceTower K E F) {A A' : Subalgebra K E}
+    (hle : A ≤ A')
+    (hA' : ∀ u : Place K E, u ≠ T.v → ∀ a ∈ A', a ∈ u.toValuationSubring) :
+    ∀ u : Place K E, u ≠ T.v → ∀ a ∈ A, a ∈ u.toValuationSubring :=
+  fun u hu a ha => hA' u hu a (hle ha)
+
+theorem gate_bot_regularOutside (T : TranscendenceTower K E F) :
+    ∀ u : Place K E, u ≠ T.v → ∀ a ∈ (⊥ : Subalgebra K E), a ∈ u.toValuationSubring := by
+  intro u _ a ha
+  obtain ⟨c, rfl⟩ := Algebra.mem_bot.mp ha
+  exact u.algebraMap_mem' c
+
+theorem gate_adjoin_x_not_regular_at_v (T : TranscendenceTower K E F) :
+    ¬ ∀ a ∈ Algebra.adjoin K {T.x}, a ∈ T.v.toValuationSubring := by
+  intro h
+  have hx := AlgebraicCurve.Place.ord_nonneg_of_mem T.v (h T.x (Algebra.subset_adjoin rfl))
+  rw [T.hxv] at hx
+  exact absurd hx (by decide)
+
+end Gates
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open Module Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+section Transcendental
+
+variable {K A : Type*} [CommRing K] [CommRing A] [Algebra K A]
+
+theorem linearIndependent_pow_of_transcendental {x : A} (hx : Transcendental K x) :
+    LinearIndependent K (fun j : ℕ => x ^ j) := by
+  have hinj : Function.Injective (Polynomial.aeval x : K[X] →ₐ[K] A) :=
+    transcendental_iff_injective.mp hx
+  have hXj : LinearIndependent K (fun j : ℕ => (X : K[X]) ^ j) := by
+    have hb := (Polynomial.basisMonomials K).linearIndependent
+    simp only [Polynomial.coe_basisMonomials] at hb
+    convert hb using 2 with j
+    exact (Polynomial.monomial_one_right_eq_X_pow j).symm
+  have heq : (fun j : ℕ => x ^ j)
+      = (fun j : ℕ => (Polynomial.aeval x : K[X] →ₐ[K] A) (X ^ j)) := by
+    funext j; simp
+  rw [heq]
+  exact hXj.map' (Polynomial.aeval x).toLinearMap
+    (LinearMap.ker_eq_bot_of_injective hinj)
+
+theorem transcendental_of_linearIndependent_pow {x : A}
+    (hx : LinearIndependent K (fun j : ℕ => x ^ j)) :
+    Transcendental K x := by
+  rw [transcendental_iff]
+  intro p hp
+  rw [Polynomial.aeval_eq_sum_range, ← Fin.sum_univ_eq_sum_range] at hp
+  ext j
+  rcases lt_or_ge j (p.natDegree + 1) with hj | hj
+  · exact (Fintype.linearIndependent_iff.mp
+      (hx.comp (Fin.val : Fin (p.natDegree + 1) → ℕ) Fin.val_injective))
+      (fun i => p.coeff i) hp ⟨j, hj⟩
+  · exact p.coeff_eq_zero_of_natDegree_lt (Nat.lt_of_succ_le hj)
+
+end Transcendental
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "algebraMap_mem_ofHeightOneSpectrum placeInfty \
+  ord_placeInfty deg_placeInfty eq_ofHeightOneSpectrum_or_eq_placeInfty"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+
+theorem ord_placeInfty_X : (placeInfty K).ord (RatFunc.X : RatFunc K) = -1 := by
+  rw [ord_placeInfty (K := K) RatFunc.X_ne_zero, RatFunc.intDegree_X]
+
+theorem algebraMap_polynomial_mem_of_ne_placeInfty
+    {u : Place K (RatFunc K)} (hu : u ≠ placeInfty K) (q : K[X]) :
+    algebraMap K[X] (RatFunc K) q ∈ u.toValuationSubring := by
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty u with ⟨w, hw⟩ | hw
+  · subst hw; exact algebraMap_mem_ofHeightOneSpectrum K w q
+  · exact absurd hw hu
+
+theorem ord_X_nonneg_of_ne_placeInfty
+    {u : Place K (RatFunc K)} (hu : u ≠ placeInfty K) :
+    0 ≤ u.ord (RatFunc.X : RatFunc K) := by
+  rw [← RatFunc.algebraMap_X]
+  exact AlgebraicCurve.Place.ord_nonneg_of_mem u (algebraMap_polynomial_mem_of_ne_placeInfty K hu
+    Polynomial.X)
+
+variable (F : Type*) [Field F] [Algebra K F] [Algebra (RatFunc K) F]
+  [IsScalarTower K (RatFunc K) F]
+
+def transcendenceTower : TranscendenceTower K (RatFunc K) F where
+  x := RatFunc.X
+  hx_indep := linearIndependent_pow_of_transcendental RatFunc.transcendental_X
+  v := placeInfty K
+  hvdeg := deg_placeInfty K
+  hxv := ord_placeInfty_X K
+  hxreg := fun _ hu => ord_X_nonneg_of_ne_placeInfty K hu
+
+@[scoped simp]
+theorem transcendenceTower_x : (transcendenceTower K F).x = RatFunc.X := rfl
+
+@[scoped simp]
+theorem transcendenceTower_v : (transcendenceTower K F).v = placeInfty K := rfl
+
+omit [DecidableEq (RatFunc K)] in
+theorem aeval_X_eq_algebraMap (q : K[X]) :
+    (Polynomial.aeval (R := K) (RatFunc.X : RatFunc K)) q
+      = algebraMap K[X] (RatFunc K) q := by
+  have hext : (Polynomial.aeval (R := K) (RatFunc.X : RatFunc K))
+      = IsScalarTower.toAlgHom K K[X] (RatFunc K) :=
+    Polynomial.algHom_ext (by simp [RatFunc.algebraMap_X])
+  rw [hext]; rfl
+
+omit [DecidableEq (RatFunc K)] in
+theorem algebraMap_polynomial_mem_adjoin_X (q : K[X]) :
+    algebraMap K[X] (RatFunc K) q ∈ Algebra.adjoin K {(RatFunc.X : RatFunc K)} := by
+  rw [Algebra.adjoin_singleton_eq_range_aeval]
+  exact ⟨q, aeval_X_eq_algebraMap K q⟩
+
+omit [DecidableEq (RatFunc K)] in
+theorem isFractionRing_adjoin_X :
+    IsFractionRing (Algebra.adjoin K {(RatFunc.X : RatFunc K)}) (RatFunc K) := by
+  refine IsFractionRing.of_field _ _ fun z => ?_
+  refine ⟨⟨algebraMap K[X] (RatFunc K) z.num, algebraMap_polynomial_mem_adjoin_X K z.num⟩,
+    ⟨algebraMap K[X] (RatFunc K) z.denom, algebraMap_polynomial_mem_adjoin_X K z.denom⟩, ?_⟩
+  change z = algebraMap K[X] (RatFunc K) z.num / algebraMap K[X] (RatFunc K) z.denom
+  exact z.num_div_denom.symm
+
+theorem hasRegularFractionSubring :
+    HasRegularFractionSubring K (RatFunc K) F (transcendenceTower K F) :=
+  hasRegularFractionSubring_of_adjoin_x_isFractionRing
+    (transcendenceTower K F) (isFractionRing_adjoin_X K)
+
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+
+theorem hasIntegralBasisRegularOutside :
+    HasIntegralBasisRegularOutside K (RatFunc K) F (transcendenceTower K F) :=
+  hasIntegralBasisRegularOutside_of_adjoin_x_isFractionRing
+    (transcendenceTower K F) (isFractionRing_adjoin_X K)
+
+section PrincipalDivisors
+
+variable [HasPrincipalDivisors K F]
+
+omit [DecidableEq (RatFunc K)] in
+theorem hasPoleDivisorPackage_of_ratFunc_tower :
+    HasPoleDivisorPackage K F := by
+  classical
+  exact
+    hasPoleDivisorPackage_of_hasRegularFractionSubring
+      (transcendenceTower K F) (hasRegularFractionSubring K F)
+
+end PrincipalDivisors
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+omit [DecidableEq (RatFunc K)] in
+theorem stichtenothGenusExists_of_ratFunc_tower :
+    StichtenothGenusExists K F := by
+  classical
+  exact
+    stichtenothGenusExists_of_adjoin_x_isFractionRing
+      (transcendenceTower K F) (isFractionRing_adjoin_X K)
+
+omit [DecidableEq (RatFunc K)] in
+theorem indexOfSpecialtyFinite_of_ratFunc_tower :
+    IndexOfSpecialtyFinite K F := by
+  classical
+  exact
+    indexOfSpecialtyFinite_of_stichtenothGenusExists
+      (stichtenothGenusExists_of_ratFunc_tower K F)
+
+end RationalFunctionField
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open Module Polynomial IsDedekindDomain
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "algebraMap_mem_ofHeightOneSpectrum placeInfty \
+  ord_placeInfty deg_placeInfty eq_ofHeightOneSpectrum_or_eq_placeInfty"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+variable (F : Type*) [Field F] [Algebra K F] [Algebra (RatFunc K) F]
+  [IsScalarTower K (RatFunc K) F]
+
+section LyingOver
+
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+
+omit [DecidableEq (RatFunc K)] in
+omit [DecidableEq (RatFunc K)] in
+private theorem _root_.AlgebraicCurve.RationalFunctionField.exists_restrict_eq (v : Place K (RatFunc
+  K)) :
+    ∃ w : Place K F, w.restrict (RatFunc K) = v :=
+  Place.exists_restrict_eq v
+
+p2m_export "AlgebraicCurve.RationalFunctionField" "exists_restrict_eq"
+
+omit [DecidableEq (RatFunc K)] in
+theorem nonempty_place_of_ratFunc_tower : Nonempty (Place K F) := by
+  classical
+  exact
+    (exists_restrict_eq K F (placeInfty K)).nonempty
+
+end LyingOver
+
+omit [DecidableEq (RatFunc K)] [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F] in
+theorem finiteDimensional_lSpace_zero_of_constantsAreBase_port (hC : ConstantsAreBase K F) :
+    FiniteDimensional K (LSpace (0 : Divisor K F)) := by
+  rw [show LSpace (0 : Divisor K F) = LinearMap.range (Algebra.linearMap K F) from hC]
+  exact LinearMap.finiteDimensional_range _
+
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+variable [IsCurveOver K F]
+
+omit [DecidableEq (RatFunc K)] in
+theorem stichtenothGenusExists (hC : ConstantsAreBase K F) :
+    StichtenothGenusExists K F := by
+  classical
+  exact
+    haveI := nonempty_place_of_ratFunc_tower K F
+    haveI := finiteDimensional_lSpace_zero_of_constantsAreBase_port K F hC
+    stichtenothGenusExists_of_ratFunc_tower K F
+
+omit [DecidableEq (RatFunc K)] in
+theorem indexOfSpecialtyFinite (hC : ConstantsAreBase K F) :
+    IndexOfSpecialtyFinite K F := by
+  classical
+  exact
+    indexOfSpecialtyFinite_of_stichtenothGenusExists (stichtenothGenusExists K F hC)
+
+omit [DecidableEq (RatFunc K)] in
+theorem riemannGenusBounded (hC : ConstantsAreBase K F) : RiemannGenusBounded K F := by
+  classical
+  exact
+    haveI := nonempty_place_of_ratFunc_tower K F
+    haveI := finiteDimensional_lSpace_zero_of_constantsAreBase_port K F hC
+    riemannGenusBounded_of_poleDivisorPackage (hasPoleDivisorPackage_of_ratFunc_tower K F).some
+
+end RationalFunctionField
+end AlgebraicCurve
+end
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg\
+  " in
+open
+  _root_.P2MW.S_OVERLONG_b9c3c6d1.AlgebraicCurve
+  Polynomial in
+theorem solution (K : Type*) [Field K] (F : Type*) [Field F] [Algebra K F]
+    (hC : ConstantsAreBase K F) :
+    FiniteDimensional K (LSpace (0 : Divisor K F)) :=
+  AlgebraicCurve.RationalFunctionField.finiteDimensional_lSpace_zero_of_constantsAreBase_port (K :=
+    K) (F := F) (hC := hC)
+
+end S_OVERLONG_b9c3c6d1
+end P2MW
+export P2MW.S_OVERLONG_b9c3c6d1
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace AlgebraicCurve
+theorem RationalFunctionField.finiteDimensional_lSpace_zero_of_constantsAreBase (K : Type*)
+    [Field K] (F : Type*) [Field F] [Algebra K F] (hC : ConstantsAreBase K F) :
+    FiniteDimensional K (LSpace (0 : Divisor K F)) :=
+  solution K F hC
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_finite_setOf_ord_ne_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_finite_setOf_ord_ne_zero.lean
new file mode 100644
index 0000000000..594f9eed86
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_finite_setOf_ord_ne_zero.lean
@@ -0,0 +1,273 @@
+/-
+Based on Prove2Me node AlgebraicCurve.RationalFunctionField.finite_setOf_ord_ne_zero
+(fdb7c420-9420-59be-b0d3-d85ceb56a7ea) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a083b117-cab5-570d-a196-3b99f918cc77
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.NumberTheory.RatFunc.Ostrowski
+import Mathlib.RingTheory.DedekindDomain.Factorization
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A nonzero rational function has finitely many zeros and poles
+
+Theorem statement: `AlgebraicCurve.RationalFunctionField.finite_setOf_ord_ne_zero`
+(`fdb7c420-9420-59be-b0d3-d85ceb56a7ea`), by Claude, 2026-09-05.
+
+Proof: submission `a083b117-cab5-570d-a196-3b99f918cc77`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $f$ be a nonzero element of the field $K(t)$ of rational functions in one
+variable over $K$. A place of $K(t)$ over $K$, in the sense used here, is a valuation subring
+$\mathcal{O}$ of $K(t)$ which contains the image of $K$ under the structure map, is not the whole of
+$K(t)$, and is a principal ideal ring; to such a place is attached the $\mathbb{Z}^{m0}$-valued adic
+valuation of $K(t)$ coming from the corresponding height-one prime of $\mathcal{O}$, and
+$\operatorname{ord}_v(g) \in \mathbb{Z}$ is defined as minus the logarithm of the value of that
+valuation at $g$ (so $\operatorname{ord}_v$ is the normalised valuation attached to $v$, positive at
+a zero and negative at a pole, with the convention $\operatorname{ord}_v(0) = 0$). The assertion is
+that the set of places $v$ of $K(t)$ over $K$ with $\operatorname{ord}_v(f) \neq 0$ is a finite set.
+
+This is the finiteness of the support of the divisor of a nonzero rational function on
+$\mathbb{P}^1_K$: the zeros and poles of $f$ are contained in the primes dividing its numerator or
+denominator, together with the place at infinity. It is the finite-support half of the existence of
+principal divisors for $K(t)$, and is used in the computation of divisor degrees on
+$\mathbb{P}^1_K$, in particular in the results on degrees of places and on functions with prescribed
+order.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_finite_setOf_ord_ne_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_RationalFunctionField_finite_setOf_ord_ne_zero
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing
+open scoped Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ext Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext heightOneSpectrum adicValuation adicValuation_ne_zero ord \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring isPrincipalIdealRing'"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.adicValuation_valuationSubring' :
+    v.adicValuation.valuationSubring = v.toValuationSubring := by
+  ext x
+  rw [Valuation.mem_valuationSubring_iff]
+  constructor
+  · intro hx
+    obtain ⟨a, rfl⟩ := IsDiscreteValuationRing.exists_lift_of_le_one hx
+    exact a.2
+  · intro hx
+    exact v.heightOneSpectrum.valuation_le_one (⟨x, hx⟩ : v.toValuationSubring)
+
+p2m_export "AlgebraicCurve.Place" "adicValuation_valuationSubring'"
+private theorem _root_.AlgebraicCurve.Place.mem_iff_adicValuation_le_one' {f : F} :
+    f ∈ v.toValuationSubring ↔ v.adicValuation f ≤ 1 := by
+  rw [← v.adicValuation_valuationSubring']
+  exact Valuation.mem_valuationSubring_iff _ _
+
+p2m_export "AlgebraicCurve.Place" "mem_iff_adicValuation_le_one'"
+private theorem _root_.AlgebraicCurve.Place.adicValuation_isRankOneDiscrete' :
+    v.adicValuation.IsRankOneDiscrete :=
+  IsDiscreteValuationRing.isRankOneDiscrete v.toValuationSubring F
+
+p2m_export "AlgebraicCurve.Place" "adicValuation_isRankOneDiscrete'"
+private theorem _root_.AlgebraicCurve.Place.adicValuation_isTrivialOn' :
+    v.adicValuation.IsTrivialOn K :=
+  Valuation.IsTrivialOn.of_le_one v.adicValuation fun a =>
+    v.mem_iff_adicValuation_le_one'.mp (v.algebraMap_mem' a)
+
+p2m_export "AlgebraicCurve.Place" "adicValuation_isTrivialOn'"
+private theorem _root_.AlgebraicCurve.Place.isEquiv_adicValuation_of_valuationSubring_eq' {Γ :
+  Type*}
+    [LinearOrderedCommGroupWithZero Γ] {w : Valuation F Γ}
+    (h : w.valuationSubring = v.toValuationSubring) : w.IsEquiv v.adicValuation :=
+  (Valuation.isEquiv_iff_valuationSubring _ _).mpr
+    (h.trans v.adicValuation_valuationSubring'.symm)
+
+p2m_export "AlgebraicCurve.Place" "isEquiv_adicValuation_of_valuationSubring_eq'"
+private theorem _root_.AlgebraicCurve.Place.ord_eq_zero_iff_adicValuation_eq_one' {f : F}
+    (hf : f ≠ 0) :
+    v.ord f = 0 ↔ v.adicValuation f = 1 := by
+  simp only [ord, neg_eq_zero]
+  constructor
+  · intro h
+    have h2 := exp_log (v.adicValuation_ne_zero hf)
+    rw [h, exp_zero] at h2
+    exact h2.symm
+  · intro h
+    rw [h, log_one]
+
+p2m_export "AlgebraicCurve.Place" "ord_eq_zero_iff_adicValuation_eq_one'"
+section OfHeightOneSpectrum
+
+variable {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R F] [IsFractionRing R F]
+  [Algebra K R] [IsScalarTower K R F]
+
+private theorem isEquiv_adicValuation_ofHeightOneSpectrum' (w : HeightOneSpectrum R) :
+    (w.valuation F).IsEquiv (ofHeightOneSpectrum (K := K) w).adicValuation :=
+  (ofHeightOneSpectrum (K := K) w).isEquiv_adicValuation_of_valuationSubring_eq' rfl
+
+end OfHeightOneSpectrum
+
+end Place
+
+namespace RationalFunctionField
+
+variable (K : Type*) [Field K]
+
+section PlaceInfty
+
+variable [DecidableEq (RatFunc K)]
+
+private theorem nontrivial_valueGroup_inftyValuation :
+    Nontrivial (MonoidWithZeroHom.valueGroup (.ofClass (RatFunc.inftyValuation K))) := by
+  rw [Subgroup.nontrivial_iff_exists_ne_one]
+  refine ⟨Units.mk0 (RatFunc.inftyValuation K RatFunc.X)
+    (by rw [RatFunc.inftyValuation.X]; exact exp_ne_zero), ?_, ?_⟩
+  · exact MonoidWithZeroHom.mem_valueGroup _ ⟨RatFunc.X, rfl⟩
+  · rw [ne_eq, Units.ext_iff, Units.val_mk0, Units.val_one, RatFunc.inftyValuation.X]
+    simp
+
+private def placeInfty' : Place K (RatFunc K) where
+  toValuationSubring := (RatFunc.inftyValuation K).valuationSubring
+  algebraMap_mem' a := by
+    rw [Valuation.mem_valuationSubring_iff]
+    exact Valuation.IsTrivialOn.valuation_algebraMap_le_one (v := RatFunc.inftyValuation K) a
+  ne_top' := by
+    have := nontrivial_valueGroup_inftyValuation K
+    simp only [ne_eq, Valuation.valuationSubring_eq_top_iff, not_not]
+    infer_instance
+  isPrincipalIdealRing' :=
+    haveI := nontrivial_valueGroup_inftyValuation K
+    (Valuation.valuationSubring_isDiscreteValuationRing
+      (RatFunc.inftyValuation K)).toIsPrincipalIdealRing
+
+private theorem placeInfty'_ne_ofHeightOneSpectrum (w : HeightOneSpectrum K[X]) :
+    placeInfty' K ≠ Place.ofHeightOneSpectrum w := by
+  intro h
+  refine RatFunc.adicValuation_not_isEquiv_infty_valuation w
+    ((Valuation.isEquiv_iff_valuationSubring _ _).mpr ?_)
+  have h2 := congrArg Place.toValuationSubring h
+  rw [Place.ofHeightOneSpectrum_toValuationSubring] at h2
+  exact h2.symm
+
+end PlaceInfty
+
+variable {K}
+
+private theorem eq_ofHeightOneSpectrum_or_eq_placeInfty' [DecidableEq (RatFunc K)]
+    (v : Place K (RatFunc K)) :
+    (∃ w : HeightOneSpectrum K[X], v = Place.ofHeightOneSpectrum w) ∨ v = placeInfty' K := by
+  have := v.adicValuation_isRankOneDiscrete'
+  have := v.adicValuation_isTrivialOn'
+  rcases (RatFunc.valuation_isEquiv_infty_or_adic (v := v.adicValuation)).or with h | h
+  · exact Or.inr (Place.ext (v.adicValuation_valuationSubring'.symm.trans
+      ((Valuation.isEquiv_iff_valuationSubring _ _).mp h)))
+  · obtain ⟨w, hw, -⟩ := h
+    exact Or.inl ⟨w, Place.ext (v.adicValuation_valuationSubring'.symm.trans
+      ((Valuation.isEquiv_iff_valuationSubring _ _).mp hw))⟩
+
+private theorem finite_setOf_valuation_ne_one' {f : RatFunc K} (hf : f ≠ 0) :
+    {w : HeightOneSpectrum K[X] | w.valuation (RatFunc K) f ≠ 1}.Finite := by
+  have hnum : (Ideal.span {f.num} : Ideal K[X]) ≠ 0 := by
+    simpa [Ideal.span_singleton_eq_bot] using RatFunc.num_ne_zero hf
+  have hden : (Ideal.span {f.denom} : Ideal K[X]) ≠ 0 := by
+    simpa [Ideal.span_singleton_eq_bot] using f.denom_ne_zero
+  refine Set.Finite.subset ((Ideal.finite_factors hnum).union (Ideal.finite_factors hden))
+    fun w hw => ?_
+  by_contra hcon
+  simp only [Set.mem_union, Set.mem_ofPred_eq, not_or, Ideal.dvd_span_singleton] at hcon
+  refine hw ?_
+  have h1 : w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) f.num) = 1 :=
+    (HeightOneSpectrum.valuation_eq_one_iff_notMem w).mpr hcon.1
+  have h2 : w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) f.denom) = 1 :=
+    (HeightOneSpectrum.valuation_eq_one_iff_notMem w).mpr hcon.2
+  rw [show f = algebraMap K[X] (RatFunc K) f.num / algebraMap K[X] (RatFunc K) f.denom from
+    f.num_div_denom.symm, map_div₀, h1, h2]
+  exact div_one 1
+
+private theorem subsingleton_setOf_forall_ne_ofHeightOneSpectrum' :
+    {v : Place K (RatFunc K) |
+      ∀ w : HeightOneSpectrum K[X], v ≠ Place.ofHeightOneSpectrum w}.Subsingleton := by
+  classical
+  intro v hv v' hv'
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty' v with ⟨w, h⟩ | h
+  · exact absurd h (hv w)
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty' v' with ⟨w, h'⟩ | h'
+  · exact absurd h' (hv' w)
+  rw [h, h']
+
+theorem rowMain {f : RatFunc K} (hf : f ≠ 0) :
+    {v : Place K (RatFunc K) | v.ord f ≠ 0}.Finite := by
+  refine Set.Finite.subset
+    (Set.Finite.union
+      (Set.Finite.image (Place.ofHeightOneSpectrum (K := K))
+        (finite_setOf_valuation_ne_one' hf))
+      (Set.Subsingleton.finite subsingleton_setOf_forall_ne_ofHeightOneSpectrum'))
+    fun v hv => ?_
+  simp only [Set.mem_ofPred_eq] at hv
+  simp only [Set.mem_union, Set.mem_image, Set.mem_ofPred_eq]
+  by_cases hcase : ∃ w : HeightOneSpectrum K[X], v = Place.ofHeightOneSpectrum w
+  · obtain ⟨w, rfl⟩ := hcase
+    refine Or.inl ⟨w, fun hone => hv ?_, rfl⟩
+    exact ((Place.ofHeightOneSpectrum (K := K) w).ord_eq_zero_iff_adicValuation_eq_one' hf).mpr
+      ((Place.isEquiv_adicValuation_ofHeightOneSpectrum' (K := K) (F := RatFunc K)
+        w).eq_one_iff_eq_one.mp hone)
+  · exact Or.inr fun w h => hcase ⟨w, h⟩
+
+end RationalFunctionField
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_RationalFunctionField_finite_setOf_ord_ne_zero.AlgebraicCurve in
+theorem solution {K : Type*} [Field K] {f : RatFunc K} (hf : f ≠ 0) :
+    {v : Place K (RatFunc K) | v.ord f ≠ 0}.Finite :=
+  AlgebraicCurve.RationalFunctionField.rowMain hf
+
+end S_AlgebraicCurve_RationalFunctionField_finite_setOf_ord_ne_zero
+end P2MW
+export P2MW.S_AlgebraicCurve_RationalFunctionField_finite_setOf_ord_ne_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.RationalFunctionField.finite_setOf_ord_ne_zero {K : Type*} [Field K]
+    {f : RatFunc K} (hf : f ≠ 0) :
+    {v : Place K (RatFunc K) | v.ord f ≠ 0}.Finite :=
+  solution hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_hasPrincipalDivisors.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_hasPrincipalDivisors.lean
new file mode 100644
index 0000000000..b3c54ab020
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_hasPrincipalDivisors.lean
@@ -0,0 +1,89 @@
+/-
+Based on Prove2Me node AlgebraicCurve.RationalFunctionField.hasPrincipalDivisors
+(75d35402-9c3b-5962-860b-ccf669cfd75b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission cf4ddbf8-4379-5686-aa89-08922551151c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_finite_setOf_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Principal divisors on the rational function field
+
+Theorem statement: `AlgebraicCurve.RationalFunctionField.hasPrincipalDivisors`
+(`75d35402-9c3b-5962-860b-ccf669cfd75b`), by Claude, 2026-09-05.
+
+Proof: submission `cf4ddbf8-4379-5686-aa89-08922551151c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field. The assertion is that the class `HasPrincipalDivisors K (RatFunc K)` holds for
+the rational function field $K(t)$ over $K$, i.e. that its single field `exists_divisor` is
+satisfied: for every $f \in K(t)$ with $f \neq 0$ there exists a divisor $D$, that is, a finitely
+supported function from `Place K (RatFunc K)` to $\mathbb{Z}$, such that (i) $D\,v =
+v.\mathrm{ord}\,f$ for every place $v$, and (ii) $\mathrm{Divisor.degree}\,D = 0$, where
+`Divisor.degree` is the additive map sending $D$ to $\sum_v D\,v \cdot v.\mathrm{deg}$, the sum
+being over the (finite) support of $D$. Here a place of $K(t)$ over $K$ is, by the definition of the
+structure `Place`, a valuation subring of $K(t)$ which contains the image of $K$ under the structure
+map, is not the whole of $K(t)$, and is a principal ideal ring; $v.\mathrm{ord}$ and
+$v.\mathrm{deg}$ are the associated order function and residue degree. Thus the content is twofold:
+the zeros and poles of a nonzero rational function are finite in number, so that $v \mapsto
+v.\mathrm{ord}\,f$ is a divisor, and that divisor has degree zero.
+
+This is the classical degree formula $\sum_v \mathrm{ord}_v(f)\cdot\deg v = 0$ for the genus-zero
+function field $K(t)$, together with the finiteness of the set of zeros and poles, packaged as the
+hypothesis class used by the divisor class group development. It is the instance on which the
+subsequent results about the places of $K(t)$ — among them the computation of degrees over an
+algebraically closed field and the evaluation maps at the place at infinity and at the places
+attached to points — rely.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_hasPrincipalDivisors.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_RationalFunctionField_hasPrincipalDivisors
+
+open AlgebraicCurve
+open IsDedekindDomain WithZero IsLocalRing
+open scoped Polynomial
+
+theorem solution (K : Type*) [Field K] : HasPrincipalDivisors K (RatFunc K) :=
+  ⟨fun f hf =>
+    ⟨Finsupp.ofSupportFinite (fun v : Place K (RatFunc K) => v.ord f)
+        (AlgebraicCurve.RationalFunctionField.finite_setOf_ord_ne_zero hf),
+      fun _ => rfl,
+      AlgebraicCurve.RationalFunctionField.degree_eq_zero_of_forall_eq_ord _ fun _ => rfl⟩⟩
+
+end S_AlgebraicCurve_RationalFunctionField_hasPrincipalDivisors
+end P2MW
+export P2MW.S_AlgebraicCurve_RationalFunctionField_hasPrincipalDivisors (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.RationalFunctionField.hasPrincipalDivisors (K : Type*) [Field K] :
+    HasPrincipalDivisors K (RatFunc K) :=
+  solution K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_nonempty_place_of_ratFunc_tower.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_nonempty_place_of_ratFunc_tower.lean
new file mode 100644
index 0000000000..77257a9d23
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_nonempty_place_of_ratFunc_tower.lean
@@ -0,0 +1,91 @@
+/-
+Based on Prove2Me node AlgebraicCurve.RationalFunctionField.nonempty_place_of_ratFunc_tower
+(ca470c8c-3cff-5708-8cb2-bac339865b28) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a5ed6dcf-7d85-5326-976c-bc8aa7ab80e9
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_restrict_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of a place for a finite separable extension of K(X)
+
+Theorem statement: `AlgebraicCurve.RationalFunctionField.nonempty_place_of_ratFunc_tower`
+(`ca470c8c-3cff-5708-8cb2-bac339865b28`), by Claude, 2026-09-05.
+
+Proof: submission `a5ed6dcf-7d85-5326-976c-bc8aa7ab80e9`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, and let $F$ be a field that is simultaneously a $K$-algebra and a `RatFunc
+K`-algebra, the two structures being compatible in the sense that $K \to \mathrm{RatFunc}\,K \to F$
+is a scalar tower, and assume $F$ is finite-dimensional and separable over the rational function
+field $\mathrm{RatFunc}\,K = K(X)$. Then the type $\mathtt{AlgebraicCurve.Place}\,K\,F$ is nonempty;
+that is, there exists at least one place of $F$ over $K$, where such a place is by definition a
+valuation subring $\mathcal{O} \subseteq F$ subject to three conditions: the image of $K$ under the
+structure map lies in $\mathcal{O}$, $\mathcal{O}$ is not all of $F$, and $\mathcal{O}$ is a
+principal ideal ring. In particular no assumption is made that $K$ is algebraically closed, perfect,
+or that $F/K$ is of any prescribed transcendence degree beyond what the tower hypotheses force.
+
+This is the existence half of the standard fact that an algebraic function field in one variable has
+places, obtained from the place at infinity of $K(X)$ by the theory of places lying above a given
+place in a finite separable extension. It serves as the nonemptiness side condition in the
+Riemann–Roch/genus development, and is used in the passage to an algebraically closed constant field
+and in the degree formula for $\ell$ in that setting, as well as in the corresponding statement for
+fields given instead by a transcendental element and a finiteness hypothesis.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_nonempty_place_of_ratFunc_tower.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_RationalFunctionField_nonempty_place_of_ratFunc_tower
+
+open AlgebraicCurve
+
+theorem solution (K : Type*) [Field K]
+    (F : Type*) [Field F] [Algebra K F] [Algebra (RatFunc K) F]
+    [IsScalarTower K (RatFunc K) F] [FiniteDimensional (RatFunc K) F]
+    [Algebra.IsSeparable (RatFunc K) F] :
+    Nonempty (AlgebraicCurve.Place K F) := by
+  classical
+  exact
+    (AlgebraicCurve.Place.exists_restrict_eq (M := F)
+      (AlgebraicCurve.RationalFunctionField.placeInfty K)).nonempty
+
+end S_AlgebraicCurve_RationalFunctionField_nonempty_place_of_ratFunc_tower
+end P2MW
+export P2MW.S_AlgebraicCurve_RationalFunctionField_nonempty_place_of_ratFunc_tower (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.RationalFunctionField.nonempty_place_of_ratFunc_tower (K : Type*) [Field K]
+    (F : Type*) [Field F] [Algebra K F] [Algebra (RatFunc K) F]
+    [IsScalarTower K (RatFunc K) F] [FiniteDimensional (RatFunc K) F]
+    [Algebra.IsSeparable (RatFunc K) F] :
+    Nonempty (AlgebraicCurve.Place K F) := by
+  classical
+  exact
+    solution K F
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_X_nonneg_of_ne_placeInfty.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_X_nonneg_of_ne_placeInfty.lean
new file mode 100644
index 0000000000..2e5f8a8ecf
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_X_nonneg_of_ne_placeInfty.lean
@@ -0,0 +1,2686 @@
+/-
+Based on Prove2Me node AlgebraicCurve.RationalFunctionField.ord_X_nonneg_of_ne_placeInfty
+(3595a982-deb4-5e3e-abf1-28ca3a6013a2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b09b94bb-f6ea-58ed-a6e3-82c4f4be1f2e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceInfty
+
+import Mathlib.Algebra.Polynomial.Basis
+import Mathlib.Data.Int.LeastGreatest
+import Mathlib.LinearAlgebra.Matrix.FiniteDimensional
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PoleDivisorPackage
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_restrict_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_placeInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# ordᵤ(X)≥ 0 for every place u≠∞ of K(X)
+
+Theorem statement: `AlgebraicCurve.RationalFunctionField.ord_X_nonneg_of_ne_placeInfty`
+(`3595a982-deb4-5e3e-abf1-28ca3a6013a2`), by Claude, 2026-09-05.
+
+Proof: submission `b09b94bb-f6ea-58ed-a6e3-82c4f4be1f2e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $u$ be a place of the rational function field $\mathrm{RatFunc}\,K$ over
+$K$, that is, a valuation subring of $\mathrm{RatFunc}\,K$ which contains the image of $K$ under the
+structure map, is not the whole of $\mathrm{RatFunc}\,K$, and is a principal ideal ring. Assume that
+$u$ is not the place `RationalFunctionField.placeInfty K`, the place whose valuation subring is the
+valuation subring of the infinite (degree) valuation `RatFunc.inftyValuation K` on
+$\mathrm{RatFunc}\,K$. Then $0 \le u.\mathrm{ord}\,X$, where for $f \in \mathrm{RatFunc}\,K$ the
+integer $u.\mathrm{ord}\,f$ is defined as $-\log$ of the value of $f$ under the adic valuation
+attached to the height-one prime of the valuation subring of $u$, with values in $\mathbb{Z}^{m0}$.
+In other words, the coordinate function $X$ has non-negative order, hence no pole, at every place of
+$K(X)/K$ other than the place at infinity.
+
+This is the standard statement that $X$ is regular away from the infinite place of the rational
+function field, the pole of $X$ being concentrated at $\infty$ with $\operatorname{ord}_\infty(X) =
+-1$. It enters the construction of the canonical transcendence tower over $K(X)$ and is used in the
+bound
+[`AlgebraicCurve.sum_ordDiff_D_le_two_mul_genusFF_of_isSeparable`]
+(thm.html#AlgebraicCurve.sum_ordDiff_D_le_two_mul_genusFF_of_isSeparable).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_ord_X_nonneg_of_ne_placeInfty.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_RationalFunctionField_ord_X_nonneg_of_ne_placeInfty
+
+
+open Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "degree degree_single principal smul_def smul_apply pullback \
+  pullback_apply degree_pullback"
+end Divisor
+variable {D : Divisor K F}
+p2m_open_scoped "AlgebraicCurve.Divisor" in
+theorem Divisor.degree_nonneg_of_nonneg [IsCurveOver K F]
+    {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) : 0 ≤ Divisor.degree D := by
+  rw [Divisor.degree_eq_sum_support]
+  exact Finset.sum_nonneg fun v _ => mul_nonneg (hD v) (Int.natCast_nonneg _)
+theorem lSpace_eq_bot_of_degree_neg [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) : LSpace D = ⊥ := by
+  rw [eq_bot_iff]
+  intro f hf
+  rw [Submodule.mem_bot]
+  by_contra hf0
+  obtain ⟨P, hPord, hPdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+  have heff : ∀ v : Place K F, 0 ≤ (P + D) v := by
+    intro v
+    rw [Finsupp.add_apply, hPord]
+    rcases mem_lSpace_iff_ord.mp hf with rfl | h
+    · exact absurd rfl hf0
+    · linarith [h v]
+  have hdegPD : 0 ≤ Divisor.degree (P + D) := Divisor.degree_nonneg_of_nonneg heff
+  rw [map_add, hPdeg, zero_add] at hdegPD
+  exact absurd hdegPD (not_le.mpr hD)
+end AlgebraicCurve
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~restrict_plac\
+  eOfPrime~placeOfPrime~comap_algebraMap_ne_top"
+
+variable (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mk_mem_maximalIdeal_iff {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    (⟨f, hf⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring
+      ↔ f = 0 ∨ 0 < v.ord f := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  constructor
+  · intro hu
+    rcases eq_or_ne f 0 with rfl | hf0
+    · exact Or.inl rfl
+    · refine Or.inr ?_
+      rcases lt_or_eq_of_le (AlgebraicCurve.Place.ord_nonneg_of_mem v hf) with h | h
+      · exact h
+      · exfalso
+        apply hu
+        rw [← v.adicValuation_coe_eq_one_iff ⟨f, hf⟩]
+        change v.adicValuation f = 1
+        rw [v.adicValuation_eq_exp_neg_ord hf0, ← h, neg_zero, WithZero.exp_zero]
+  · intro h hu
+    have hne : f ≠ 0 := fun h0 => hu.ne_zero (Subtype.ext h0)
+    have h0 : v.ord f = 0 := by
+      obtain ⟨u, hu'⟩ := hu
+      have hcoe : f = ((u : v.toValuationSubring) : F) := by rw [hu']
+      rw [hcoe]; exact v.ord_coe_unit u
+    rcases h with rfl | hpos
+    · exact hne rfl
+    · omega
+
+p2m_export "AlgebraicCurve.Place" "mk_mem_maximalIdeal_iff"
+end Place
+
+theorem ell_le_ell_sub_single_add_deg [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    ell D ≤ ell (D - Finsupp.single P 1) + P.deg := by
+  classical
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible P.toValuationSubring
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by
+    simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := by
+    intro g hg
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ g : F, g ∈ LSpace D → t ^ (D P) * g ∈ P.toValuationSubring := by
+    intro g hg
+    rcases eq_or_ne g 0 with rfl | hg0
+    · simp
+    · refine AlgebraicCurve.Place.mem_of_ord_nonneg P (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have := (mem_lSpace_iff_ord.mp hg).resolve_left hg0 P
+      linarith
+  let ψ : LSpace D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun f => ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+      map_add' := by intro f g; apply Subtype.ext; push_cast; ring
+      map_smul' := by
+        intro c f; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap]
+        ring }
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : LSpace D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ f : LSpace D, φ f = 0 ↔
+      (⟨t ^ (D P) * (f : F), hmem _ f.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := by
+    intro f
+    rw [show φ f = IsLocalRing.residue P.toValuationSubring ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+          from hres (ψ f),
+      IsLocalRing.residue_eq_zero_iff]
+  have hED : E ≤ D := by
+    rw [Finsupp.le_def]; intro v; rw [hE, Finsupp.sub_apply]
+    have : (0 : ℤ) ≤ Finsupp.single P 1 v := by
+      rcases eq_or_ne v P with rfl | hv
+      · simp
+      · simp [Finsupp.single_eq_of_ne hv]
+    linarith
+  have hsub : LSpace E ≤ LSpace D := lSpace_mono hED
+  have hker : LinearMap.ker φ = (LSpace E).comap (LSpace D).subtype := by
+    ext f
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi f, P.mk_mem_maximalIdeal_iff]
+    rcases eq_or_ne (f : F) 0 with hf0 | hf0
+    · simp only [hf0, mul_zero, true_or, true_iff]
+      exact (LSpace E).zero_mem
+    · rw [mem_lSpace_iff_ord]
+      have hfD := (mem_lSpace_iff_ord.mp f.2).resolve_left hf0
+      constructor
+      · rintro (h | h)
+        · exact absurd h (mul_ne_zero htn0 hf0)
+        · refine Or.inr (fun v => ?_)
+          rcases eq_or_ne v P with rfl | hv
+          · rw [hEP]; rw [hordmul hf0] at h; omega
+          · rw [hEv v hv]; exact hfD v
+      · rintro (h | h)
+        · exact absurd h hf0
+        · refine Or.inr ?_
+          have hP := h P
+          rw [hEP] at hP
+          rw [hordmul hf0]; omega
+  have hkerfin : finrank K (LinearMap.ker φ) = ell E := by
+    rw [hker, LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe hsub)]
+  have hquot : finrank K (LSpace D ⧸ LinearMap.ker φ) ≤ P.deg := by
+    rw [LinearEquiv.finrank_eq φ.quotKerEquivRange]
+    exact Submodule.finrank_le (LinearMap.range φ)
+  by_cases hfin : FiniteDimensional K (LSpace D)
+  · have := hfin
+    have hrn := Submodule.finrank_quotient_add_finrank (LinearMap.ker φ)
+    rw [hkerfin] at hrn
+    have hb : ell D = finrank K (LSpace D) := rfl
+    omega
+  · have h0 : ell D = 0 := by rw [ell]; exact finrank_of_infinite_dimensional hfin
+    omega
+
+theorem one_le_deg [IsCurveOver K F] (P : Place K F) : 1 ≤ P.deg := by
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  exact Module.finrank_pos
+
+theorem ell_le_degree_add_ellZero [IsCurveOver K F] {D : Divisor K F}
+    (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D : Divisor K F, (∀ v, 0 ≤ D v) →
+      (Divisor.degree D).toNat = m →
+      (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) by
+    exact H (Divisor.degree D).toNat D hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D hD hm
+    by_cases hD0 : D = 0
+    · subst hD0; simp
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ D P := by
+        have hne : D P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hD P; omega
+      set E : Divisor K F := D - Finsupp.single P 1 with hE
+      have hEeff : ∀ v, 0 ≤ E v := by
+        intro v; rw [hE, Finsupp.sub_apply]
+        rcases eq_or_ne v P with rfl | hv
+        · rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have hdegE : Divisor.degree E = Divisor.degree D - P.deg := by
+        rw [hE, map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hDnn : 0 ≤ Divisor.degree D := Divisor.degree_nonneg_of_nonneg hD
+      have hEnn : 0 ≤ Divisor.degree E := Divisor.degree_nonneg_of_nonneg hEeff
+      have hmlt : (Divisor.degree E).toNat < m := by rw [← hm]; omega
+      have hIH := IH _ hmlt E hEeff rfl
+      have hstep := ell_le_ell_sub_single_add_deg D P
+      rw [← hE] at hstep
+      have hstep' : (ell D : ℤ) ≤ (ell E : ℤ) + P.deg := by exact_mod_cast hstep
+      rw [hdegE] at hIH
+      linarith
+
+theorem ell_le_degree_add_one_of_effective [IsCurveOver K F]
+    (hC : ConstantsAreBase K F) {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  have h := ell_le_degree_add_ellZero hD
+  rw [ell_zero_eq_one_of_constantsAreBase hC] at h
+  exact_mod_cast h
+
+def lSpaceShiftEquiv (D : Divisor K F) {g : F} (hg : g ≠ 0)
+    {Dg : Divisor K F} (hDg : ∀ v, Dg v = v.ord g) :
+    LSpace D ≃ₗ[K] LSpace (D + Dg) where
+  toFun h := ⟨(h : F) * g⁻¹, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (h : F) 0 with hh0 | hh0
+    · left; rw [hh0, zero_mul]
+    · right; intro v
+      rw [Finsupp.add_apply, hDg, v.ord_mul hh0 (inv_ne_zero hg), v.ord_inv]
+      have := (mem_lSpace_iff_ord.mp h.2).resolve_left hh0 v
+      linarith⟩
+  invFun k := ⟨(k : F) * g, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (k : F) 0 with hk0 | hk0
+    · left; rw [hk0, zero_mul]
+    · right; intro v
+      have := (mem_lSpace_iff_ord.mp k.2).resolve_left hk0 v
+      rw [Finsupp.add_apply, hDg] at this
+      rw [v.ord_mul hk0 hg]
+      linarith⟩
+  map_add' h₁ h₂ := by apply Subtype.ext; push_cast; ring
+  map_smul' c h := by
+    apply Subtype.ext
+    simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def]
+    ring
+  left_inv h := by
+    apply Subtype.ext
+    change (h : F) * g⁻¹ * g = (h : F)
+    rw [mul_assoc, inv_mul_cancel₀ hg, mul_one]
+  right_inv k := by
+    apply Subtype.ext
+    change (k : F) * g * g⁻¹ = (k : F)
+    rw [mul_assoc, mul_inv_cancel₀ hg, mul_one]
+
+theorem ell_le_degree_add_one [IsCurveOver K F] (hC : ConstantsAreBase K F)
+    {D : Divisor K F} (hD : 0 ≤ Divisor.degree D) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  rcases eq_or_ne (ell D) 0 with h0 | h0
+  · rw [h0]; push_cast; linarith
+  · have hbot : LSpace D ≠ ⊥ := fun h => h0 (by rw [ell, h, finrank_bot])
+    obtain ⟨g, hgL, hg0⟩ := (Submodule.ne_bot_iff _).mp hbot
+    obtain ⟨Dg, hDgord, hDgdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) g hg0
+    have heff : ∀ v, 0 ≤ (D + Dg) v := by
+      intro v; rw [Finsupp.add_apply, hDgord]
+      have := (mem_lSpace_iff_ord.mp hgL).resolve_left hg0 v
+      linarith
+    have hdeg : Divisor.degree (D + Dg) = Divisor.degree D := by
+      rw [map_add, hDgdeg, add_zero]
+    have hell : ell D = ell (D + Dg) :=
+      LinearEquiv.finrank_eq (lSpaceShiftEquiv D hg0 hDgord)
+    have hfin := ell_le_degree_add_one_of_effective hC heff
+    rw [hdeg] at hfin
+    rw [hell]; exact hfin
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion factor mk mem_bot subtype_injective \
+  mk.injEq Quotient.subsingleton_iff Quotient.mk span restrictScalars inhabited \
+  inclusion_injective comapSubtypeEquivOfLe mem_comap finrank_quotient_add_finrank mem_top \
+  Quotient.equiv mkQ mem_map coe_subtype map_smul' zero one quotientQuotientEquivQuotient \
+  coe_eq_zero finrank_le range_subtype Quotient.mk_surjective map mem_inf mem_sup \
+  Quotient.mk_eq_zero topEquiv map_injective_of_injective comap_subtype_self mapQ subsingleton_iff \
+  module smul_def mk_eq_zero coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono \
+  map_sup coe_zero smul"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+def nestedComapMapMkQEquiv {A B C : Submodule K X} (_hAB : A ≤ B) (hBC : B ≤ C) :
+    ((B.comap C.subtype).map (A.comap C.subtype).mkQ : Submodule K _)
+      ≃ₗ[K] B ⧸ A.comap B.subtype := by
+  set S := A.comap C.subtype with hS
+  set T := B.comap C.subtype with hT
+  let ψ : (T : Type _) →ₗ[K] (C ⧸ S) := S.mkQ ∘ₗ T.subtype
+  have hker : LinearMap.ker ψ = S.comap T.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = T.map S.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let e1 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (T.map S.mkQ : Submodule K _) :=
+    (Submodule.Quotient.equiv _ (LinearMap.ker ψ) (LinearEquiv.refl K T)
+        (by rw [hker]; simp)).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have hmap : (S.comap T.subtype).map
+      (Submodule.comapSubtypeEquivOfLe hBC : (T : Type _) →ₗ[K] B) = A.comap B.subtype := by
+    ext ⟨b, hb⟩
+    simp only [mem_map, mem_comap, Submodule.coe_subtype, hS]
+    constructor
+    · rintro ⟨⟨⟨x, hxC⟩, hxB⟩, hxA, hxeq⟩
+      have hx : x = b := congrArg Subtype.val hxeq
+      subst hx; exact hxA
+    · intro hbA
+      exact ⟨⟨⟨b, hBC hb⟩, hb⟩, hbA, rfl⟩
+  let e2 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (B ⧸ A.comap B.subtype) :=
+    Submodule.Quotient.equiv _ _ (Submodule.comapSubtypeEquivOfLe hBC) hmap
+  exact e1.symm.trans e2
+
+theorem finrank_quotient_chain {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCB : Module.Finite K (C ⧸ B.comap C.subtype)]
+    [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (C ⧸ A.comap C.subtype) ∧
+      finrank K (C ⧸ A.comap C.subtype)
+        = finrank K (C ⧸ B.comap C.subtype) + finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (T.map S.mkQ : Submodule K _) := Module.Finite.equiv eK.symm
+  have : Module.Finite K ((C ⧸ S) ⧸ T.map S.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (C ⧸ S) := Module.Finite.of_submodule_quotient (T.map S.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+theorem finrank_quotient_chain' {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCA : Module.Finite K (C ⧸ A.comap C.subtype)] :
+    Module.Finite K (C ⧸ B.comap C.subtype) ∧
+      finrank K (C ⧸ B.comap C.subtype)
+        = finrank K (C ⧸ A.comap C.subtype) - finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (C ⧸ T) := Module.Finite.equiv e3
+  refine ⟨this, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+def adeleBddQuotSingleEquivResidueField (D : Divisor K F) (P : Place K F) :
+    (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+      ≃ₗ[K] P.ResidueField := by
+  classical
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  let π : P.toValuationSubring :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose
+  have hπ : Irreducible π :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose_spec
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := fun {g} hg => by
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ α : Place K F → F, α ∈ adeleBdd D → t ^ (D P) * α P ∈ P.toValuationSubring := by
+    intro α hα
+    rcases eq_or_ne (α P) 0 with hg0 | hg0
+    · simp [hg0]
+    · refine AlgebraicCurve.Place.mem_of_ord_nonneg P (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have h := hα P
+      rw [P.adicValuation_eq_exp_neg_ord hg0, WithZero.exp_le_exp] at h
+      linarith
+  let ψ : adeleBdd D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun α => ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩
+      map_add' := by
+        intro α β; apply Subtype.ext
+        simp only [Submodule.coe_add, Pi.add_apply]
+        push_cast; ring
+      map_smul' := by
+        intro c α; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap, Pi.smul_apply]
+        ring }
+  have hψ_apply : ∀ α : adeleBdd D,
+      (ψ α : F) = t ^ (D P) * (α : Place K F → F) P := fun α => rfl
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : adeleBdd D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ α : adeleBdd D, φ α = 0 ↔
+      (⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := fun α => by
+    rw [show φ α = IsLocalRing.residue P.toValuationSubring
+            ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ from hres (ψ α),
+      IsLocalRing.residue_eq_zero_iff]
+  have hker : LinearMap.ker φ = (adeleBdd E).comap (adeleBdd D).subtype := by
+    ext α
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi α, P.mk_mem_maximalIdeal_iff, mem_adeleBdd]
+    have hαD := α.2
+    constructor
+    · rintro (h | h) v
+      · have hα0 : (α : Place K F → F) P = 0 := by
+          rcases mul_eq_zero.mp h with h' | h'
+          · exact absurd h' htn0
+          · exact h'
+        by_cases hv : v = P
+        · subst v; rw [hα0, Valuation.map_zero]; exact zero_le
+        · rw [hEv v hv]; exact hαD v
+      · by_cases hv : v = P
+        · subst v
+          rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+          · rw [hα0, Valuation.map_zero]; exact zero_le
+          · rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP]
+            rw [hordmul hα0] at h; omega
+        · rw [hEv v hv]; exact hαD v
+    · intro h
+      rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+      · left; rw [hα0, mul_zero]
+      · right
+        have hP := h P
+        rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP] at hP
+        rw [hordmul hα0]; omega
+  have hsurj : Function.Surjective φ := by
+    intro c
+    obtain ⟨cl, hcl⟩ := IsLocalRing.residue_surjective (R := P.toValuationSubring) c
+    set f : F := (cl : F) * t ^ (-(D P)) with hf
+    have hαD : Pi.single P f ∈ adeleBdd D := by
+      intro v
+      by_cases hv : v = P
+      · subst v
+        simp only [Pi.single_eq_same]
+        rcases eq_or_ne (cl : F) 0 with hc0 | hc0
+        · rw [hf, hc0, zero_mul, Valuation.map_zero]; exact zero_le
+        · have hf0 : f ≠ 0 := by rw [hf]; exact mul_ne_zero hc0 (zpow_ne_zero _ ht0)
+          rw [P.adicValuation_eq_exp_neg_ord hf0, WithZero.exp_le_exp]
+          rw [hf, P.ord_mul hc0 (zpow_ne_zero _ ht0), P.ord_zpow, ht1, mul_one]
+          have hclnn := AlgebraicCurve.Place.ord_nonneg_of_mem P cl.2
+          linarith
+      · rw [Pi.single_eq_of_ne hv, Valuation.map_zero]; exact zero_le
+    refine ⟨⟨Pi.single P f, hαD⟩, ?_⟩
+    change res (ψ ⟨Pi.single P f, hαD⟩) = c
+    rw [hres]
+    rw [show (ψ ⟨Pi.single P f, hαD⟩ : P.toValuationSubring) = cl from ?_, hcl]
+    apply Subtype.ext
+    rw [hψ_apply]
+    change t ^ (D P) * (Pi.single P f : Place K F → F) P = (cl : F)
+    rw [show (Pi.single P f : Place K F → F) P = f from Pi.single_eq_same _ _, hf,
+      mul_comm (cl : F), ← mul_assoc, ← zpow_add₀ ht0, add_neg_cancel, zpow_zero, one_mul]
+  exact (Submodule.Quotient.equiv _ _ (LinearEquiv.refl K _) (by rw [← hker]; simp)).trans
+    (φ.quotKerEquivOfSurjective hsurj)
+
+theorem finrank_adeleBdd_quotient_single [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    Module.Finite K
+        (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype) ∧
+      finrank K
+          (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+        = P.deg := by
+  have := IsCurveOver.finite_residueField (K := K) P
+  exact ⟨Module.Finite.equiv (adeleBddQuotSingleEquivResidueField D P).symm,
+    (adeleBddQuotSingleEquivResidueField D P).finrank_eq⟩
+
+theorem finrank_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+      (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+        = Divisor.degree D₂ - Divisor.degree D₁ := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D₁ D₂ : Divisor K F, D₁ ≤ D₂ →
+      (Divisor.degree (D₂ - D₁)).toNat = m →
+      Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+        (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+          = Divisor.degree D₂ - Divisor.degree D₁ from
+    H _ D₁ D₂ hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D₁ D₂ hD hm
+    have hEeff : ∀ v, 0 ≤ (D₂ - D₁) v := fun v => by
+      rw [Finsupp.sub_apply]; have := hD v; omega
+    by_cases hD0 : D₂ - D₁ = 0
+    · have hD12 : D₁ = D₂ := (sub_eq_zero.mp hD0).symm
+      subst hD12
+      rw [Submodule.comap_subtype_self]
+      have : Subsingleton (adeleBdd D₁ ⧸ (⊤ : Submodule K (adeleBdd D₁))) :=
+        Submodule.Quotient.subsingleton_iff.mpr rfl
+      exact ⟨Module.Finite.of_finite, by simp [Module.finrank_zero_of_subsingleton]⟩
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ (D₂ - D₁) P := by
+        have hne : (D₂ - D₁) P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hEeff P; omega
+      set D₂' : Divisor K F := D₂ - Finsupp.single P 1 with hD₂'
+      have h12' : D₁ ≤ D₂' := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]
+          have := hPpos; rw [Finsupp.sub_apply] at this; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have h2'2 : D₂' ≤ D₂ := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]
+      have hdegD₂' : Divisor.degree D₂' = Divisor.degree D₂ - P.deg := by
+        rw [hD₂', map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hEnn : 0 ≤ Divisor.degree (D₂ - D₁) := Divisor.degree_nonneg_of_nonneg hEeff
+      have hE'nn : 0 ≤ Divisor.degree (D₂' - D₁) := Divisor.degree_nonneg_of_nonneg
+        (fun v => by rw [Finsupp.sub_apply]; have := h12' v; omega)
+      have hdegdiff : Divisor.degree (D₂' - D₁) = Divisor.degree (D₂ - D₁) - P.deg := by
+        simp only [hD₂', map_sub, Divisor.degree_single, one_mul]; ring
+      have hmlt : (Divisor.degree (D₂' - D₁)).toNat < m := by rw [← hm]; omega
+      obtain ⟨hfin', hrank'⟩ := IH _ hmlt D₁ D₂' h12' rfl
+      obtain ⟨hfinS, hrankS⟩ := finrank_adeleBdd_quotient_single (K := K) D₂ P
+      rw [← hD₂'] at hfinS hrankS
+      have := hfin'; have := hfinS
+      obtain ⟨hfin, hrank⟩ := Submodule.finrank_quotient_chain
+        (A := adeleBdd D₁) (B := adeleBdd D₂') (C := adeleBdd D₂)
+        (adeleBdd_mono h12') (adeleBdd_mono h2'2)
+      refine ⟨hfin, ?_⟩
+      rw [hrank, hrankS]
+      push_cast
+      linarith [hrank', hdegD₂']
+
+theorem module_finite_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  (finrank_adeleBdd_quotient hD).1
+
+theorem finrank_adeleBdd_quotient_eq [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+      = Divisor.degree D₂ - Divisor.degree D₁ :=
+  (finrank_adeleBdd_quotient hD).2
+
+def lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (_hD : D₁ ≤ D₂) :
+    (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      →ₗ[K] (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  Submodule.mapQ _ _
+    ((diagonalHom K F).restrict
+      (p := (LSpace D₂ : Submodule K F)) (q := (adeleBdd D₂ : Submodule K _))
+      (fun f hf => diagonal_mem_adeleBdd_iff.mpr hf))
+    (fun f hf => by
+      simp only [Submodule.mem_comap, Submodule.coe_subtype] at hf ⊢
+      exact diagonal_mem_adeleBdd_iff.mpr hf)
+
+theorem lSpaceQuotientToAdeleBddQuotient_injective {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Function.Injective (lSpaceQuotientToAdeleBddQuotient hD) := by
+  rw [injective_iff_map_eq_zero]
+  intro x hx
+  obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+  rw [Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype]
+  rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk f)
+        = Submodule.Quotient.mk ((diagonalHom K F).restrict
+            (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f) from rfl,
+    Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype] at hx
+  exact diagonal_mem_adeleBdd_iff.mp hx
+
+
+theorem ell_sub_ell_le_degree_sub_degree [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)] :
+    (ell D₂ : ℤ) - (ell D₁ : ℤ) ≤ Divisor.degree D₂ - Divisor.degree D₁ := by
+  have := module_finite_adeleBdd_quotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    rw [hℓ₁]; exact (Submodule.finrank_quotient_add_finrank _).symm
+  have hemb : finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      ≤ finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+    LinearMap.finrank_le_finrank_of_injective (lSpaceQuotientToAdeleBddQuotient_injective hD)
+  have hloc := finrank_adeleBdd_quotient_eq hD
+  have : (ell D₂ : ℤ) - (ell D₁ : ℤ)
+      = (finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) : ℤ) := by
+    rw [hL]; push_cast; ring
+  rw [this, ← hloc]
+  exact_mod_cast hemb
+
+theorem adeleBdd_inf_sup_globalSub {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F)
+      = adeleBdd D₁ ⊔ adeleBdd D₂ ⊓ globalSub K F := by
+  rw [inf_comm, sup_inf_assoc_of_le _ (adeleBdd_mono hD), inf_comm]
+
+theorem map_diagonal_lSpace_inf_adeleBdd {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (LSpace D₂).map (diagonalHom K F) ⊓ adeleBdd D₁ = (LSpace D₁).map (diagonalHom K F) := by
+  rw [map_diagonal_lSpace, map_diagonal_lSpace, inf_right_comm,
+    inf_eq_right.mpr (adeleBdd_mono hD)]
+
+theorem gate_finrank_adeleBdd_quotient_single_point [IsCurveOver K F] (P : Place K F) :
+    (finrank K (adeleBdd (Finsupp.single P 1 : Divisor K F)
+        ⧸ (adeleBdd (0 : Divisor K F)).comap (adeleBdd (Finsupp.single P 1)).subtype) : ℤ)
+      = (P.deg : ℤ) := by
+  classical
+  have h01 : (0 : Divisor K F) ≤ Finsupp.single P 1 := by
+    intro v; rw [Finsupp.zero_apply, Finsupp.single_apply]; split_ifs <;> omega
+  have h := finrank_adeleBdd_quotient_eq (K := K) h01
+  rw [h, map_zero, sub_zero, Divisor.degree_single, one_mul]
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion factor mk mem_bot subtype_injective \
+  mk.injEq Quotient.subsingleton_iff Quotient.mk span restrictScalars inhabited \
+  inclusion_injective comapSubtypeEquivOfLe mem_comap finrank_quotient_add_finrank mem_top \
+  Quotient.equiv mkQ mem_map coe_subtype map_smul' zero one quotientQuotientEquivQuotient \
+  coe_eq_zero finrank_le range_subtype Quotient.mk_surjective map mem_inf mem_sup \
+  Quotient.mk_eq_zero topEquiv map_injective_of_injective comap_subtype_self mapQ subsingleton_iff \
+  module smul_def mk_eq_zero coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono \
+  map_sup coe_zero smul"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+theorem comap_subtype_sup_of_le_of_le {S T C : Submodule K X} (hS : S ≤ C) (hT : T ≤ C) :
+    S.comap C.subtype ⊔ T.comap C.subtype = (S ⊔ T).comap C.subtype := by
+  apply Submodule.map_injective_of_injective (f := C.subtype) C.subtype_injective
+  rw [Submodule.map_sup, Submodule.map_comap_subtype, Submodule.map_comap_subtype,
+    Submodule.map_comap_subtype, inf_eq_right.mpr hS, inf_eq_right.mpr hT,
+    inf_eq_right.mpr (sup_le hS hT)]
+
+theorem finrank_quotient_chain_top {M : Type*} [AddCommGroup M] [Module K M]
+    {A B : Submodule K M} (hAB : A ≤ B)
+    [hMB : Module.Finite K (M ⧸ B)] [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (M ⧸ A) ∧
+      finrank K (M ⧸ A) = finrank K (M ⧸ B) + finrank K (B ⧸ A.comap B.subtype) := by
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  let ψ : (B : Type _) →ₗ[K] (M ⧸ A) := A.mkQ ∘ₗ B.subtype
+  have hker : LinearMap.ker ψ = A.comap B.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = B.map A.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let eK : (B ⧸ A.comap B.subtype) ≃ₗ[K] (B.map A.mkQ : Submodule K (M ⧸ A)) :=
+    (Submodule.quotEquivOfEq _ _ hker.symm).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have : Module.Finite K (B.map A.mkQ : Submodule K (M ⧸ A)) := Module.Finite.equiv eK
+  have : Module.Finite K ((M ⧸ A) ⧸ B.map A.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (M ⧸ A) := Module.Finite.of_submodule_quotient (B.map A.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (B.map A.mkQ)
+  rw [LinearEquiv.finrank_eq e3, ← LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem globalSub_le_adeleSpace [HasPrincipalDivisors K F] :
+    globalSub K F ≤ adeleSpace K F := by
+  rintro _ ⟨f, rfl⟩
+  exact diagonal_mem_adeleSpace f
+
+theorem adeleBdd_sup_globalSub_le_adeleSpace [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+  sup_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_eq_comap [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBddPrincipal K F D = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype :=
+  Submodule.comap_subtype_sup_of_le_of_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_mono {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBddPrincipal K F D₁ ≤ adeleBddPrincipal K F D₂ :=
+  sup_le_sup_right (Submodule.comap_mono (adeleBdd_mono hD)) _
+
+section FiniteLSpace
+
+variable [IsCurveOver K F]
+
+theorem finiteDimensional_lSpace [hL0 : FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (D : Divisor K F) : FiniteDimensional K (LSpace D) := by
+  have h0D : (0 : Divisor K F) ≤ D ⊔ 0 := le_sup_right
+  have hDD : D ≤ D ⊔ 0 := le_sup_left
+  suffices h : FiniteDimensional K (LSpace (D ⊔ 0)) by
+    exact Module.Finite.of_injective (Submodule.inclusion (lSpace_mono hDD))
+      (Submodule.inclusion_injective _)
+  have := module_finite_adeleBdd_quotient (K := K) h0D
+  have hfinQ : FiniteDimensional K
+      (LSpace (D ⊔ 0) ⧸ (LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype) :=
+    Module.Finite.of_injective _ (lSpaceQuotientToAdeleBddQuotient_injective h0D)
+  have : FiniteDimensional K
+      ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype : Submodule K _) :=
+    Module.Finite.equiv (Submodule.comapSubtypeEquivOfLe (lSpace_mono h0D)).symm
+  exact Module.Finite.of_submodule_quotient
+    ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype)
+
+end FiniteLSpace
+
+
+theorem range_lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD)
+      = ((adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype).map
+          ((adeleBdd D₁).comap (adeleBdd D₂).subtype).mkQ := by
+  classical
+  ext z
+  obtain ⟨α, rfl⟩ := Submodule.Quotient.mk_surjective _ z
+  simp only [LinearMap.mem_range, Submodule.mem_map, Submodule.mem_comap, Submodule.coe_subtype,
+    Submodule.mkQ_apply]
+  constructor
+  · rintro ⟨x, hx⟩
+    obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+    have hxeq : Submodule.Quotient.mk
+        ((diagonalHom K F).restrict (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f)
+        = (Submodule.Quotient.mk α :
+            adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) := hx
+    refine ⟨α, ?_, rfl⟩
+    have hdiag2 : (diagonalHom K F (f : F)) ∈ adeleBdd D₂ := diagonal_mem_adeleBdd_iff.mpr f.2
+    have hsub : (α : Place K F → F) - diagonalHom K F (f : F) ∈ adeleBdd D₁ := by
+      have hq := (Submodule.Quotient.eq _).mp hxeq.symm
+      simpa using hq
+    refine Submodule.mem_sup.mpr ⟨(α : Place K F → F) - diagonalHom K F (f : F), hsub,
+      diagonalHom K F (f : F), diagonal_mem_globalSub _, ?_⟩
+    abel
+  · rintro ⟨β, hβ, hβeq⟩
+    have hβ' : (β : Place K F → F) ∈ adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F) :=
+      Submodule.mem_inf.mpr ⟨β.2, hβ⟩
+    rw [adeleBdd_inf_sup_globalSub hD, ← map_diagonal_lSpace] at hβ'
+    obtain ⟨γ, hγ, δ, ⟨f, hf, hfδ⟩, hsum⟩ := Submodule.mem_sup.mp hβ'
+    refine ⟨Submodule.Quotient.mk ⟨f, hf⟩, ?_⟩
+    rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk ⟨f, hf⟩)
+          = Submodule.Quotient.mk ((diagonalHom K F).restrict
+              (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) ⟨f, hf⟩) from rfl,
+      ← hβeq, Submodule.Quotient.eq]
+    refine Submodule.mem_comap.mpr ?_
+    change diagonalHom K F f - (β : Place K F → F) ∈ adeleBdd D₁
+    have hβsub : diagonalHom K F f - (β : Place K F → F) = -γ := by
+      rw [← hsum, hfδ]; ring
+    rw [hβsub]; exact (adeleBdd D₁).neg_mem hγ
+
+
+theorem finrank_adeleBddSup_quotient [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) [hL : FiniteDimensional K (LSpace D₂)] :
+    Module.Finite K (↥(adeleBdd D₂ ⊔ globalSub K F)
+        ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) ∧
+      (finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+          ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) : ℤ)
+        = (Divisor.degree D₂ - ell D₂) - (Divisor.degree D₁ - ell D₁) := by
+  classical
+  let A : Submodule K (adeleBdd D₂) := (adeleBdd D₁).comap (adeleBdd D₂).subtype
+  let B : Submodule K (adeleBdd D₂) :=
+    (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype
+  have hAB : A ≤ B := Submodule.comap_mono le_sup_left
+  have hfinA : Module.Finite K (adeleBdd D₂ ⧸ A) := module_finite_adeleBdd_quotient hD
+  have hdimA : (finrank K (adeleBdd D₂ ⧸ A) : ℤ) = Divisor.degree D₂ - Divisor.degree D₁ :=
+    finrank_adeleBdd_quotient_eq hD
+  have hran : LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD) = B.map A.mkQ :=
+    range_lSpaceQuotientToAdeleBddQuotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hdimL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K)
+      ((LSpace D₁).comap (LSpace D₂).subtype)
+    rw [← hℓ₁] at h; exact h.symm
+  have hdimB : ell D₂ = finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) + ell D₁ := by
+    rw [← hran, LinearMap.finrank_range_of_inj
+      (lSpaceQuotientToAdeleBddQuotient_injective hD)]
+    exact hdimL
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  have hfinB : Module.Finite K (adeleBdd D₂ ⧸ B) := Module.Finite.equiv e3
+  have hdim2 : finrank K (adeleBdd D₂ ⧸ A)
+      = finrank K (adeleBdd D₂ ⧸ B) + finrank K (B.map A.mkQ : Submodule K _) := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K) (M := adeleBdd D₂ ⧸ A)
+      (B.map A.mkQ)
+    rw [LinearEquiv.finrank_eq e3] at h; omega
+  have e2 := LinearMap.quotientInfEquivSupQuotient (R := K)
+    (adeleBdd D₂) (adeleBdd D₁ ⊔ globalSub K F)
+  have hsup : adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F) = adeleBdd D₂ ⊔ globalSub K F := by
+    rw [← sup_assoc, sup_eq_left.mpr (adeleBdd_mono hD)]
+  have hB' : (adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype = B := by
+    rw [Submodule.comap_subtype_self, top_inf_eq]
+  let eL : (adeleBdd D₂ ⧸ B) ≃ₗ[K]
+      (adeleBdd D₂ ⧸ ((adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+        (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype)) :=
+    Submodule.quotEquivOfEq _ _ hB'.symm
+  have hfin_iso : Module.Finite K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype) :=
+    Module.Finite.equiv (eL.trans e2)
+  have hdim_iso : finrank K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype)
+      = finrank K (adeleBdd D₂ ⧸ B) :=
+    (LinearEquiv.finrank_eq (eL.trans e2)).symm
+  have hcast : (finrank K (adeleBdd D₂ ⧸ A) : ℤ)
+      = (finrank K (adeleBdd D₂ ⧸ B) : ℤ) + ((ell D₂ : ℤ) - (ell D₁ : ℤ)) := by
+    have hb : (ell D₂ : ℤ)
+        = (finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) : ℤ) + (ell D₁ : ℤ) := by
+      exact_mod_cast hdimB
+    push_cast [hdim2]; linarith
+  have hgoal : (finrank K (adeleBdd D₂ ⧸ B) : ℤ)
+      = Divisor.degree D₂ - ↑(ell D₂) - (Divisor.degree D₁ - ↑(ell D₁)) := by
+    linarith [hdimA, hcast]
+  clear_value eL
+  exact hsup ▸ ⟨hfin_iso, by rw [hdim_iso]; exact hgoal⟩
+
+section Index
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+
+theorem adeleBddSup_eq_of_degree_sub_ell_eq {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)]
+    (heq : Divisor.degree D₂ - ell D₂ = Divisor.degree D₁ - ell D₁) :
+    adeleBdd D₂ ⊔ globalSub K F = adeleBdd D₁ ⊔ globalSub K F := by
+  obtain ⟨hfin, hdim⟩ := finrank_adeleBddSup_quotient hD
+  rw [heq, sub_self] at hdim
+  refine le_antisymm ?_ (sup_le_sup_right (adeleBdd_mono hD) _)
+  have := hfin
+  have hd0 : finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) = 0 := by
+    exact_mod_cast hdim
+  have hsub : Subsingleton (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) :=
+    Module.finrank_zero_iff.mp hd0
+  have htop := Submodule.Quotient.subsingleton_iff.mp hsub
+  intro x hx
+  have hxc : (⟨x, hx⟩ : ↥(adeleBdd D₂ ⊔ globalSub K F)) ∈
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype := by
+    rw [htop]; exact Submodule.mem_top
+  exact hxc
+
+end Index
+
+namespace RiemannGenusReachedAt
+p2m_export "AlgebraicCurve.RiemannGenusReachedAt" "finite mk eq isMax"
+end RiemannGenusReachedAt
+namespace RiemannGenusReachedAt
+p2m_open_scoped "AlgebraicCurve.RiemannGenusReachedAt" in
+private theorem _root_.AlgebraicCurve.RiemannGenusReachedAt.eq_of_ge [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {D : Divisor K F} (hD : D₀ ≤ D) :
+    Divisor.degree D - ell D = γ - 1 := by
+  have := finiteDimensional_lSpace (K := K) D
+  have hge : Divisor.degree D₀ - (ell D₀ : ℤ) ≤ Divisor.degree D - ell D := by
+    have := ell_sub_ell_le_degree_sub_degree (K := K) hD
+    linarith
+  exact le_antisymm (h.isMax D) (h.eq ▸ hge)
+
+end RiemannGenusReachedAt
+p2m_export "AlgebraicCurve" "RiemannGenusReachedAt.eq_of_ge"
+
+theorem adeleSpace_eq_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    adeleSpace K F = adeleBdd D₀ ⊔ globalSub K F := by
+  refine le_antisymm ?_ (adeleBdd_sup_globalSub_le_adeleSpace D₀)
+  rw [adeleSpace, iSup_le_iff]
+  intro D
+  refine le_trans (adeleBdd_mono (le_sup_left : D ≤ D ⊔ D₀)) ?_
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have heq : Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) = Divisor.degree D₀ - ell D₀ :=
+    (h.eq_of_ge le_sup_right).trans h.eq.symm
+  have hsup := adeleBddSup_eq_of_degree_sub_ell_eq (K := K)
+    (le_sup_right : D₀ ≤ D ⊔ D₀) heq
+  rw [← hsup]
+  exact le_sup_left
+
+theorem indexOfSpecialty_eq_zero_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    indexOfSpecialty D₀ = 0 := by
+  rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap, ← adeleSpace_eq_of_genusReached h,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.finrank_zero_of_subsingleton
+
+
+
+theorem gate_indexOfSpecialty_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  have h1 := (indexOfSpecialty_eq_of_genusReached h D₀).2
+  have h2 := h.eq
+  have h3 := indexOfSpecialty_eq_zero_of_genusReached h
+  exact_mod_cast h3
+
+theorem gate_riemannInequality_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Divisor.degree D + 1 - γ ≤ (ell D : ℤ) := by
+  have heq := (indexOfSpecialty_eq_of_genusReached h D).2
+  have hnn : (0 : ℤ) ≤ indexOfSpecialty D := Int.natCast_nonneg _
+  linarith
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem adeleSpaceMul_add [HasPrincipalDivisors K F] (f g : F) :
+    adeleSpaceMul K F (f + g) = adeleSpaceMul K F f + adeleSpaceMul K F g := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, LinearMap.add_apply, Submodule.coe_add,
+    Pi.add_apply, add_mul]
+
+theorem adeleSpaceMul_zero [HasPrincipalDivisors K F] :
+    adeleSpaceMul K F (0 : F) = 0 := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, zero_mul, LinearMap.zero_apply,
+    Submodule.coe_zero, Pi.zero_apply]
+
+theorem weilSmul_add_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f + g) φ = weilSmul K F f φ + weilSmul K F g φ := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_add, LinearMap.add_apply, map_add]
+
+theorem weilSmul_zero_left [HasPrincipalDivisors K F]
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (0 : F) φ = 0 := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_zero, LinearMap.zero_apply, map_zero]
+
+theorem weilSmul_neg_left [HasPrincipalDivisors K F] (f : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (-f) φ = -weilSmul K F f φ := by
+  have h := weilSmul_add_left (K := K) (F := F) f (-f) φ
+  rw [add_neg_cancel, weilSmul_zero_left] at h
+  exact (neg_eq_of_add_eq_zero_right h.symm).symm
+
+theorem weilSmul_sub_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f - g) φ = weilSmul K F f φ - weilSmul K F g φ := by
+  rw [sub_eq_add_neg, weilSmul_add_left, weilSmul_neg_left, sub_eq_add_neg]
+
+theorem weilSmul_eq_zero_iff_left [HasPrincipalDivisors K F]
+    {f : F} {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    weilSmul K F f φ = 0 ↔ f = 0 := by
+  refine ⟨fun h => ?_, fun h => h ▸ weilSmul_zero_left φ⟩
+  by_contra hf
+  exact hφ (weilSmul_injective hf (h.trans (map_zero (weilSmul K F f)).symm))
+
+theorem weilSmul_left_injective [HasPrincipalDivisors K F]
+    {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    Function.Injective (fun f : F => weilSmul K F f φ) := by
+  intro f g hfg
+  have hsub : weilSmul K F (f - g) φ = 0 := by
+    rw [weilSmul_sub_left, sub_eq_zero]; exact hfg
+  exact sub_eq_zero.mp ((weilSmul_eq_zero_iff_left hφ).mp hsub)
+
+variable (K F) in
+def doubleResiduePairing [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) :
+    LSpace (W - D) × LSpace (W - D) →ₗ[K] omegaSpace D :=
+  (residuePairing K F W D hφ).coprod (residuePairing K F W D hμ)
+
+theorem doubleResiduePairing_apply_coe [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (g h : LSpace (W - D)) :
+    (doubleResiduePairing K F W D hφ hμ (g, h) : Module.Dual K (adeleSpace K F))
+      = weilSmul K F (g : F) φ + weilSmul K F (h : F) μ := by
+  simp only [doubleResiduePairing, LinearMap.coprod_apply, Submodule.coe_add,
+    residuePairing_apply_coe]
+
+theorem doubleResiduePairing_injective [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ) :
+    Function.Injective (doubleResiduePairing K F W D hφ hμ) := by
+  rw [injective_iff_map_eq_zero]
+  rintro ⟨g, h⟩ heq
+  have heq' : weilSmul K F (g : F) φ + weilSmul K F (h : F) μ = 0 := by
+    have hcoe := congrArg Subtype.val heq
+    rwa [doubleResiduePairing_apply_coe, Submodule.coe_zero] at hcoe
+  rcases eq_or_ne (h : F) 0 with hh0 | hh0
+  · rw [hh0, weilSmul_zero_left, add_zero] at heq'
+    have hg0 : (g : F) = 0 := (weilSmul_eq_zero_iff_left hφ0).mp heq'
+    exact Prod.ext (Subtype.ext hg0) (Subtype.ext hh0)
+  · exfalso
+    have hμeq : weilSmul K F (h : F) μ = -weilSmul K F (g : F) φ := by
+      have h2 : weilSmul K F (h : F) μ + weilSmul K F (g : F) φ = 0 := by
+        rw [add_comm]; exact heq'
+      exact eq_neg_of_add_eq_zero_left h2
+    have hLHS : weilSmul K F (h : F)⁻¹ (weilSmul K F (h : F) μ) = μ := by
+      rw [← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hh0, weilSmul_one,
+        LinearMap.id_apply]
+    have hRHS : weilSmul K F (h : F)⁻¹ (-weilSmul K F (g : F) φ)
+        = weilSmul K F (-(g : F) * (h : F)⁻¹) φ := by
+      rw [map_neg, ← LinearMap.comp_apply, ← weilSmul_mul, neg_mul, weilSmul_neg_left]
+    exact hindep (-(g : F) * (h : F)⁻¹) (by rw [← hLHS, hμeq, hRHS])
+
+theorem two_mul_ell_le_indexOfSpecialty [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ)
+    [Module.Finite K (omegaSpace (K := K) (F := F) D)]
+    [Module.Finite K (LSpace (K := K) (F := F) (W - D))] :
+    2 * ell (W - D) ≤ indexOfSpecialty D := by
+  have hinj := doubleResiduePairing_injective W D hφ hμ hφ0 hindep
+  have hle := LinearMap.finrank_le_finrank_of_injective hinj
+  rw [Module.finrank_prod] at hle
+  rw [← finrank_omegaSpace_eq_indexOfSpecialty, two_mul]
+  exact hle
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+section Finiteness
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+theorem omegaSpace_finite_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Module.Finite K (omegaSpace (K := K) (F := F) D) := by
+  have := (indexOfSpecialty_eq_of_genusReached h D).1
+  exact Module.Finite.equiv (omegaSpaceEquivIndexDual D).symm
+
+end Finiteness
+
+section ParametricRankOne
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+
+theorem exists_weilSmul_eq_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {φ μ : Module.Dual K (adeleSpace K F)} {W : Divisor K F}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (hφ0 : φ ≠ 0) :
+    ∃ f : F, μ = weilSmul K F f φ := by
+  by_contra hcon
+  push Not at hcon
+  obtain ⟨P⟩ := ‹Nonempty (Place K F)›
+  set n : ℕ := 3 * γ.natAbs + 2 * (Divisor.degree W).natAbs + 4 with hn
+  set D : Divisor K F := -Finsupp.single P (n : ℤ) with hD
+  have hdegD : Divisor.degree D = -(n : ℤ) * (P.deg : ℤ) := by
+    rw [hD, map_neg, Divisor.degree_single]; ring
+  have hdegWD : Divisor.degree (W - D) = Divisor.degree W + (n : ℤ) * (P.deg : ℤ) := by
+    rw [map_sub, hdegD]; ring
+  have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+  have habsγ : -(|γ|) ≤ γ ∧ γ ≤ |γ| := ⟨neg_abs_le _, le_abs_self _⟩
+  have habsW : -|Divisor.degree W| ≤ Divisor.degree W ∧
+      Divisor.degree W ≤ |Divisor.degree W| := ⟨neg_abs_le _, le_abs_self _⟩
+  have hn_ge : 3 * |γ| + 2 * |Divisor.degree W| + 4 ≤ (n : ℤ) := by
+    rw [hn]; push_cast [Int.natCast_natAbs]; ring_nf; omega
+  have hndegP : (n : ℤ) ≤ (n : ℤ) * (P.deg : ℤ) := by nlinarith [Int.natCast_nonneg n]
+  have hellD : ell D = 0 := ell_eq_zero_of_degree_neg (by rw [hdegD]; nlinarith)
+  have hiD : (indexOfSpecialty D : ℤ) = (n : ℤ) * (P.deg : ℤ) - 1 + γ := by
+    have hidx := (indexOfSpecialty_eq_of_genusReached h D).2
+    rw [hellD, hdegD] at hidx; push_cast at hidx; linarith
+  have hlowerWD : Divisor.degree W + (n : ℤ) * (P.deg : ℤ) + 1 - γ
+      ≤ (ell (W - D) : ℤ) := by
+    have hlow := gate_riemannInequality_of_genusReached h (W - D)
+    rw [hdegWD] at hlow; exact hlow
+  have := omegaSpace_finite_of_genusReached h D
+  have := finiteDimensional_lSpace (K := K) (W - D)
+  have hdbl : (2 * ell (W - D) : ℤ) ≤ (indexOfSpecialty D : ℤ) := by
+    exact_mod_cast two_mul_ell_le_indexOfSpecialty W D hφ hμ hφ0 hcon
+  rw [hiD] at hdbl
+  nlinarith [habsγ.1, habsγ.2, habsW.1, habsW.2]
+
+theorem weilDifferentialRankOne_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    WeilDifferentialRankOne K F := by
+  intro φ hφmem hφ0 μ hμmem
+  obtain ⟨W₁, hφW₁⟩ := mem_weilDifferentialModule_iff.mp hφmem
+  obtain ⟨W₂, hμW₂⟩ := mem_weilDifferentialModule_iff.mp hμmem
+  have hφW : φ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_left hφW₁
+  have hμW : μ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_right hμW₂
+  obtain ⟨f, hf⟩ := exists_weilSmul_eq_of_genusReached h hφW hμW hφ0
+  exact ⟨f, hf, fun f' hf' => weilSmul_left_injective hφ0 (hf'.symm.trans hf)⟩
+
+end ParametricRankOne
+
+theorem residuePairing_surjective_of_rankOne_max [HasPrincipalDivisors K F]
+    (hRankOne : WeilDifferentialRankOne K F)
+    {W : Divisor K F} {φ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hφ0 : φ ≠ 0)
+    (hWmax : ∀ E : Divisor K F, φ ∈ omegaSpace E → E ≤ W) (D : Divisor K F) :
+    Function.Surjective (residuePairing K F W D hφ) := by
+  rintro ⟨μ, hμD⟩
+  have hφmem : φ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule W hφ
+  have hμmem : μ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule D hμD
+  obtain ⟨f, hf, -⟩ := hRankOne hφmem hφ0 hμmem
+  rcases eq_or_ne f 0 with rfl | hf0
+  · have hμ0 : (⟨μ, hμD⟩ : omegaSpace D) = 0 :=
+      Subtype.ext (hf.trans (weilSmul_zero_left φ))
+    exact ⟨0, (map_zero _).trans hμ0.symm⟩
+  · obtain ⟨P, hPord, _⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+    have hPinv : ∀ v, (-P) v = v.ord f⁻¹ := fun v => by
+      rw [Finsupp.neg_apply, hPord v, v.ord_inv]
+    have hinv : weilSmul K F f⁻¹ μ = φ := by
+      rw [hf, ← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hf0, weilSmul_one,
+        LinearMap.id_apply]
+    have hφD : φ ∈ omegaSpace (D + -P) := by
+      rw [← hinv]; exact weilSmul_mem_omegaSpace_add (inv_ne_zero hf0) hPinv hμD
+    have hDP : D + -P ≤ W := hWmax _ hφD
+    have hfL : f ∈ LSpace (W - D) := by
+      rw [mem_lSpace_iff_ord]; refine Or.inr fun v => ?_
+      have hv := hDP v
+      rw [Finsupp.add_apply, Finsupp.neg_apply, hPord v] at hv
+      rw [Finsupp.sub_apply]; linarith
+    exact ⟨⟨f, hfL⟩, Subtype.ext hf.symm⟩
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem exists_riemannGenusReachedAt_of_bounded
+    [IsCurveOver K F] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    ∃ (γ : ℤ) (D₀ : Divisor K F), RiemannGenusReachedAt γ D₀ := by
+  obtain ⟨γ, hγ⟩ := hbdd
+  obtain ⟨M, ⟨D₀, hD₀⟩, hMmax⟩ :=
+    Int.exists_greatest_of_bdd
+      (P := fun n => ∃ D : Divisor K F, Divisor.degree D - ell D = n)
+      ⟨γ, fun n ⟨D, hD⟩ => hD ▸ hγ D⟩
+      ⟨Divisor.degree (0 : Divisor K F) - ell (0 : Divisor K F), 0, rfl⟩
+  refine ⟨M + 1, D₀, ?_, ?_, ?_⟩
+  · exact finiteDimensional_lSpace D₀
+  · rw [hD₀]; ring
+  · intro D
+    have := hMmax (Divisor.degree D - ell D) ⟨D, rfl⟩
+    linarith
+
+theorem stichtenothGenusExists_of_bounded
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    StichtenothGenusExists K F :=
+  ⟨‹_›, ‹_›, exists_riemannGenusReachedAt_of_bounded hbdd⟩
+
+
+theorem indexOfSpecialty_sub_of_ge [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₀ D : Divisor K F} (hD : D₀ ≤ D)
+    [FiniteDimensional K (LSpace D)]
+    [hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀)] :
+    Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D) ∧
+      (Divisor.degree D - ell D) - (Divisor.degree D₀ - ell D₀)
+        = (indexOfSpecialty D₀ : ℤ) - (indexOfSpecialty D : ℤ) := by
+  have hABsub : adeleBdd D₀ ⊔ globalSub K F ≤ adeleBdd D ⊔ globalSub K F :=
+    sup_le_sup_right (adeleBdd_mono hD) _
+  have hBCsub : adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+    adeleBdd_sup_globalSub_le_adeleSpace _
+  obtain ⟨hfinBA, hdimBA⟩ := finrank_adeleBddSup_quotient (K := K) hD
+  have := hfinBA
+  have hfinCA : Module.Finite K (adeleSpace K F ⧸
+      (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [← adeleBddPrincipal_eq_comap]; exact hfin
+  obtain ⟨hfinCB, hdimCB⟩ := Submodule.finrank_quotient_chain'
+    (A := adeleBdd D₀ ⊔ globalSub K F) (B := adeleBdd D ⊔ globalSub K F)
+    (C := adeleSpace K F) hABsub hBCsub
+  have hi0 : indexOfSpecialty D₀
+      = finrank K (adeleSpace K F ⧸
+        (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap]
+  have hiD : indexOfSpecialty D
+      = finrank K (adeleSpace K F ⧸
+        (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap]
+  have := hfinCB
+  obtain ⟨_, hdimCA⟩ := Submodule.finrank_quotient_chain
+    (A := adeleBdd D₀ ⊔ globalSub K F) (B := adeleBdd D ⊔ globalSub K F)
+    (C := adeleSpace K F) hABsub hBCsub
+  refine ⟨?_, ?_⟩
+  · rw [show adeleBddPrincipal K F D
+        = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype
+      from adeleBddPrincipal_eq_comap D]
+    exact hfinCB
+  · have hcast : (indexOfSpecialty D₀ : ℤ)
+        = (indexOfSpecialty D : ℤ)
+          + (finrank K (↥(adeleBdd D ⊔ globalSub K F)
+              ⧸ (adeleBdd D₀ ⊔ globalSub K F).comap
+                (adeleBdd D ⊔ globalSub K F).subtype) : ℤ) := by
+      rw [hiD, hi0]; exact_mod_cast hdimCA
+    linarith [hdimBA, hcast]
+
+theorem degreeSub_ell_le_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {D₀ : Divisor K F}
+    (hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀))
+    (D : Divisor K F) :
+    Divisor.degree D - ell D ≤ (Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀ := by
+  have := hfin
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have hmono : Divisor.degree D - (ell D : ℤ)
+      ≤ Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) (le_sup_left : D ≤ D ⊔ D₀)
+    linarith
+  obtain ⟨_, heq⟩ :=
+    indexOfSpecialty_sub_of_ge (K := K) (le_sup_right : D₀ ≤ D ⊔ D₀)
+  have hi0 : (0 : ℤ) ≤ indexOfSpecialty (D ⊔ D₀) := Int.natCast_nonneg _
+  linarith
+
+theorem riemannGenusBounded_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hfin : IndexOfSpecialtyFinite K F) :
+    RiemannGenusBounded K F := by
+  obtain ⟨D₀, hD₀⟩ := hfin
+  exact ⟨(Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀,
+    degreeSub_ell_le_of_indexFinite hD₀⟩
+
+theorem stichtenothGenusExists_of_indexFinite
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hfin : IndexOfSpecialtyFinite K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_bounded (riemannGenusBounded_of_indexFinite hfin)
+
+theorem indexOfSpecialtyFinite_of_stichtenothGenusExists
+    [IsCurveOver K F] (hSG : StichtenothGenusExists K F) :
+    IndexOfSpecialtyFinite K F := by
+  obtain ⟨hne, hL0, γ, D₀, hD₀⟩ := hSG
+  have := hne; have := hL0
+  refine ⟨D₀, ?_⟩
+  rw [show adeleBddPrincipal K F D₀
+      = (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype
+    from adeleBddPrincipal_eq_comap D₀, ← adeleSpace_eq_of_genusReached hD₀,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.Finite.of_finite
+
+theorem stichtenothGenusExists_iff_indexFinite
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] :
+    StichtenothGenusExists K F ↔ IndexOfSpecialtyFinite K F :=
+  ⟨indexOfSpecialtyFinite_of_stichtenothGenusExists,
+    stichtenothGenusExists_of_indexFinite⟩
+
+theorem gate_indexOfSpecialty_engine_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  exact_mod_cast indexOfSpecialty_eq_zero_of_genusReached h
+
+theorem gate_stichtenothGenus_le_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {D₀ : Divisor K F}
+    (hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀))
+    {γ : ℤ} {D₁ : Divisor K F} (h : RiemannGenusReachedAt γ D₁) :
+    γ - 1 ≤ (Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀ := by
+  have := degreeSub_ell_le_of_indexFinite hfin D₁
+  rw [h.eq] at this; exact this
+
+theorem gate_riemannGenusBounded_of_reachedAt
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    RiemannGenusBounded K F :=
+  ⟨γ - 1, h.isMax⟩
+
+theorem gate_indexOfSpecialtyFinite_at_zero [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F (0 : Divisor K F)) :=
+  (indexOfSpecialty_eq_of_genusReached h 0).1
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem mul_mem_lSpace_add {D E : Divisor K F} {f g : F}
+    (hf : f ∈ LSpace D) (hg : g ∈ LSpace E) :
+    f * g ∈ LSpace (D + E) := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · rw [zero_mul]; exact (LSpace _).zero_mem
+  rcases eq_or_ne g 0 with rfl | hg0
+  · rw [mul_zero]; exact (LSpace _).zero_mem
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun v => ?_
+  rw [Finsupp.add_apply, neg_add, v.ord_mul hf0 hg0]
+  exact add_le_add ((mem_lSpace_iff_ord.mp hf).resolve_left hf0 v)
+    ((mem_lSpace_iff_ord.mp hg).resolve_left hg0 v)
+
+theorem pow_mem_lSpace_nsmul {B : Divisor K F} {f : F} (hf : f ∈ LSpace B) (j : ℕ) :
+    f ^ j ∈ LSpace (j • B) := by
+  induction j with
+  | zero => simpa using one_mem_lSpace_zero (K := K) (F := F)
+  | succ j ih =>
+    rw [pow_succ, succ_nsmul]
+    exact mul_mem_lSpace_add ih hf
+
+namespace PoleDivisorPackage
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degB_eq u B hB_eff n lin_indep mk c x hn_pos \
+  hu_mem mk.injEq hx_mem"
+p2m_open "AlgebraicCurve.PoleDivisorPackage"
+
+variable (P : PoleDivisorPackage K F)
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.pow_mul_u_mem_lSpace (j : ℕ) (i : Fin P.n)
+    :
+    P.x ^ j * P.u i ∈ LSpace ((j + P.c) • P.B) := by
+  rw [add_nsmul]
+  exact mul_mem_lSpace_add (pow_mem_lSpace_nsmul P.hx_mem j) (P.hu_mem i)
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "pow_mul_u_mem_lSpace"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.pow_mul_u_mem_lSpace_of_le {j m : ℕ}
+    (hjm : j + P.c ≤ m) (i : Fin P.n) :
+    P.x ^ j * P.u i ∈ LSpace (m • P.B) := by
+  refine lSpace_mono ?_ (P.pow_mul_u_mem_lSpace j i)
+  intro v
+  have hBv : (0 : ℤ) ≤ P.B v := P.hB_eff v
+  change ((j + P.c) • P.B) v ≤ (m • P.B) v
+  simp only [Finsupp.smul_apply, nsmul_eq_mul]
+  exact mul_le_mul_of_nonneg_right (by exact_mod_cast hjm) hBv
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "pow_mul_u_mem_lSpace_of_le"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.ell_nsmul_poleDivisor_ge [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    (P.n : ℤ) * (m - P.c + 1) ≤ ell (m • P.B) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  set g : Fin (m - P.c + 1) × Fin P.n → LSpace (m • P.B) :=
+    fun p => ⟨P.x ^ (p.1 : ℕ) * P.u p.2,
+      P.pow_mul_u_mem_lSpace_of_le (by have := p.1.isLt; omega) p.2⟩
+    with hgdef
+  have hsub : LinearIndependent K (fun p => (g p : F)) := by
+    have heq : (fun p => (g p : F))
+        = (fun p : ℕ × Fin P.n => P.x ^ p.1 * P.u p.2)
+            ∘ (fun p : Fin (m - P.c + 1) × Fin P.n => ((p.1 : ℕ), p.2)) := by
+      funext p; rfl
+    rw [heq]
+    refine P.lin_indep.comp _ ?_
+    intro p q hpq
+    simp only [Prod.mk.injEq] at hpq
+    exact Prod.ext (Fin.val_injective hpq.1) hpq.2
+  have hg : LinearIndependent K g := hsub.of_comp (LSpace (m • P.B)).subtype
+  have hcard := hg.fintype_card_le_finrank
+  rw [Fintype.card_prod, Fintype.card_fin, Fintype.card_fin] at hcard
+  have hZ : ((m - P.c + 1) * P.n : ℤ) ≤ (ell (m • P.B) : ℤ) := by exact_mod_cast hcard
+  have heq : (((m - P.c + 1 : ℕ) : ℤ) * P.n : ℤ) = (P.n : ℤ) * ((m : ℤ) - P.c + 1) := by
+    rw [Nat.cast_add, Nat.cast_sub hm, Nat.cast_one]; ring
+  linarith
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "ell_nsmul_poleDivisor_ge"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.degree_nsmul_sub_ell_le [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    Divisor.degree (m • P.B) - ell (m • P.B) ≤ (P.n : ℤ) * (P.c - 1) := by
+  have hge := P.ell_nsmul_poleDivisor_ge hm
+  have hdeg : Divisor.degree (m • P.B) = (m : ℤ) * P.n := by
+    rw [show m • P.B = (m : ℤ) • P.B from (natCast_zsmul _ _).symm,
+      Divisor.degree.map_zsmul, smul_eq_mul, P.degB_eq]
+  linarith
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degree_nsmul_sub_ell_le"
+end PoleDivisorPackage
+
+namespace PoleDivisorPackage
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degB_eq u B hB_eff n lin_indep mk c x hn_pos \
+  hu_mem mk.injEq hx_mem"
+end PoleDivisorPackage
+namespace PoleDivisorPackage
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.ell_nsmul_sub_pos [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) {A : Divisor K F} (hA : 0 ≤ A) {m : ℕ} (hm : P.c ≤ m)
+    (hbig : Divisor.degree A < (P.n : ℤ) * (m - P.c + 1)) :
+    0 < ell (m • P.B - A) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  have hle : m • P.B - A ≤ m • P.B := by
+    intro v
+    have hAv : (0 : ℤ) ≤ A v := hA v
+    rw [Finsupp.sub_apply]
+    linarith
+  have h48 := ell_sub_ell_le_degree_sub_degree (K := K) hle
+  rw [map_sub, sub_sub_cancel] at h48
+  have h412 := P.ell_nsmul_poleDivisor_ge hm
+  have : (0 : ℤ) < (ell (m • P.B - A) : ℤ) := by linarith
+  exact_mod_cast this
+
+end PoleDivisorPackage
+p2m_export "AlgebraicCurve" "PoleDivisorPackage.ell_nsmul_sub_pos"
+namespace PoleDivisorPackage
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.degree_sub_ell_le [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) (D : Divisor K F) :
+    Divisor.degree D - ell D ≤ (P.n : ℤ) * (P.c - 1) := by
+  classical
+  set D' : Divisor K F := D ⊔ 0 with hD'def
+  have hD'eff : 0 ≤ D' := le_sup_right
+  have hDD' : D ≤ D' := le_sup_left
+  have := finiteDimensional_lSpace (K := K) D'
+  have hmono : Divisor.degree D - (ell D : ℤ) ≤ Divisor.degree D' - ell D' := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hDD'
+    linarith
+  set m : ℕ := P.c + (Divisor.degree D').toNat with hmdef
+  have hcm : P.c ≤ m := Nat.le_add_right _ _
+  have hdegD' : 0 ≤ Divisor.degree D' := Divisor.degree_nonneg_of_nonneg hD'eff
+  have hbig : Divisor.degree D' < (P.n : ℤ) * (m - P.c + 1) := by
+    have hcast : ((m : ℤ) - P.c) = Divisor.degree D' := by
+      simp only [hmdef, Nat.cast_add, add_sub_cancel_left, Int.toNat_of_nonneg hdegD']
+    rw [hcast]
+    have hn1 : (1 : ℤ) ≤ P.n := by exact_mod_cast P.hn_pos
+    nlinarith
+  have hellpos := P.ell_nsmul_sub_pos hD'eff hcm hbig
+  have hnebot : LSpace (m • P.B - D') ≠ ⊥ :=
+    fun h => by rw [ell, h, finrank_bot] at hellpos; exact lt_irrefl 0 hellpos
+  obtain ⟨z, hzL, hz0⟩ := (Submodule.ne_bot_iff _).mp hnebot
+  obtain ⟨Dz, hDzord, hDzdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) z hz0
+  have hzmem := (mem_lSpace_iff_ord.mp hzL).resolve_left hz0
+  have hD'le : D' ≤ m • P.B + Dz := by
+    intro v
+    have := hzmem v
+    simp only [Finsupp.add_apply, Finsupp.sub_apply, neg_sub] at this ⊢
+    rw [hDzord]; linarith
+  have hellshift : ell (m • P.B + Dz) = ell (m • P.B) :=
+    (LinearEquiv.finrank_eq (lSpaceShiftEquiv (m • P.B) hz0 hDzord)).symm
+  have hdegshift : Divisor.degree (m • P.B + Dz) = Divisor.degree (m • P.B) := by
+    rw [map_add, hDzdeg, add_zero]
+  have := finiteDimensional_lSpace (K := K) (m • P.B + Dz)
+  have hmono' : Divisor.degree D' - (ell D' : ℤ)
+      ≤ Divisor.degree (m • P.B + Dz) - ell (m • P.B + Dz) := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hD'le
+    linarith
+  rw [hellshift, hdegshift] at hmono'
+  have h412 := P.degree_nsmul_sub_ell_le hcm
+  linarith
+
+end PoleDivisorPackage
+p2m_export "AlgebraicCurve" "PoleDivisorPackage.degree_sub_ell_le"
+
+theorem riemannGenusBounded_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    RiemannGenusBounded K F :=
+  ⟨(P.n : ℤ) * (P.c - 1), P.degree_sub_ell_le⟩
+
+theorem stichtenothGenusExists_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_bounded (riemannGenusBounded_of_poleDivisorPackage P)
+
+theorem indexOfSpecialtyFinite_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_stichtenothGenusExists
+    (stichtenothGenusExists_of_poleDivisorPackage P)
+
+theorem indexOfSpecialtyFinite_of_hasPoleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (h : HasPoleDivisorPackage K F) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_poleDivisorPackage h.some
+
+theorem stichtenothGenusExists_of_hasPoleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (h : HasPoleDivisorPackage K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_poleDivisorPackage h.some
+
+theorem gate_stichtenothGenus_le_of_poleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F)
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    γ ≤ (P.n : ℤ) * (P.c - 1) + 1 := by
+  have := P.degree_sub_ell_le D₀
+  rw [h.eq] at this; linarith
+
+theorem gate_ell_c_nsmul_ge [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    (P.n : ℤ) ≤ ell (P.c • P.B) := by
+  have h := P.ell_nsmul_poleDivisor_ge (le_refl P.c)
+  simp only [sub_self, zero_add, mul_one] at h
+  exact h
+
+theorem gate_x_transcendental_of_poleDivisorPackage (P : PoleDivisorPackage K F) :
+    LinearIndependent K (fun j : ℕ => P.x ^ j * P.u ⟨0, P.hn_pos⟩) := by
+  refine P.lin_indep.comp (fun j => (j, ⟨0, P.hn_pos⟩)) ?_
+  intro a b hab
+  exact (Prod.mk.injEq .. ▸ hab).1
+
+theorem gate_u_linearIndependent_of_poleDivisorPackage (P : PoleDivisorPackage K F) :
+    LinearIndependent K P.u := by
+  have h : LinearIndependent K (fun i : Fin P.n => P.x ^ (0 : ℕ) * P.u i) := by
+    refine P.lin_indep.comp (fun i => (0, i)) ?_
+    intro a b hab
+    exact (Prod.mk.injEq .. ▸ hab).2
+  simpa using h
+
+end AlgebraicCurve
+
+end
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+scoped instance instSumRamificationInertia_port {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F']
+    [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+    [HasPrincipalDivisors K F'] : SumRamificationInertia K F F' :=
+  ⟨fun v => Place.sum_ramificationIndex_mul_inertiaDeg v⟩
+end AlgebraicCurve
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+
+namespace TranscendenceTower
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF poleDivisor RegularOutside hx_indep hxreg v \
+  mk.injEq mk hvdeg x hxv"
+p2m_open "AlgebraicCurve.TranscendenceTower"
+
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F]
+variable (T : TranscendenceTower K E F)
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.x_ne_zero : T.x ≠ 0 := fun h => by
+  have := T.hxv; rw [h, Place.ord_zero] at this; exact absurd this (by decide)
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "x_ne_zero"
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+theorem xF_ne_zero : T.xF ≠ 0 :=
+  fun h => T.x_ne_zero ((algebraMap E F).injective (by rwa [map_zero]))
+
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.poleDivisor_apply (w : Place K F) :
+    T.poleDivisor w = (w.ramificationIndex E : ℤ) * (Finsupp.single T.v 1) (w.restrict E) :=
+  Divisor.pullback_apply (Finsupp.single T.v 1) w
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "poleDivisor_apply"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.poleDivisor_nonneg :
+    0 ≤ T.poleDivisor := by
+  classical
+  intro w
+  rw [Finsupp.coe_zero, Pi.zero_apply, T.poleDivisor_apply, Finsupp.single_apply]
+  refine mul_nonneg (Int.natCast_nonneg _) ?_
+  split_ifs <;> simp
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "poleDivisor_nonneg"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.xF_mem_lSpace_poleDivisor :
+    T.xF ∈ LSpace T.poleDivisor := by
+  classical
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun w => ?_
+  rw [T.poleDivisor_apply, Place.ord_restrict, Finsupp.single_apply]
+  rcases eq_or_ne (w.restrict E) T.v with hw | hw
+  · simp only [hw, T.hxv, ite_true, mul_one, mul_neg_one, le_refl]
+  · simp only [ite_eq_right (Ne.symm hw), mul_zero, neg_zero]
+    exact mul_nonneg (Int.natCast_nonneg _) (T.hxreg _ hw)
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF_mem_lSpace_poleDivisor"
+
+private theorem _root_.AlgebraicCurve.TranscendenceTower.degree_poleDivisor_eq_finrank :
+    Divisor.degree T.poleDivisor = (Module.finrank E F : ℤ) := by
+  rw [poleDivisor, Divisor.degree_pullback, Divisor.degree_single, T.hvdeg]
+  push_cast; ring
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "degree_poleDivisor_eq_finrank"
+omit [FiniteDimensional E F] in
+private theorem
+  _root_.AlgebraicCurve.TranscendenceTower.mem_lSpace_nsmul_poleDivisor_of_regular_outside {f : F}
+    (hreg : ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord f)
+    {c : ℕ} (hc : ∀ w ∈ T.v.fiber F, -(c : ℤ) ≤ w.ord f) :
+    f ∈ LSpace (c • T.poleDivisor) := by
+  classical
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact (LSpace _).zero_mem
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun w => ?_
+  rw [Finsupp.smul_apply, T.poleDivisor_apply, Finsupp.single_apply, nsmul_eq_mul]
+  rcases eq_or_ne (w.restrict E) T.v with hw | hw
+  · simp only [hw, ite_true, mul_one]
+    have he : (1 : ℤ) ≤ w.ramificationIndex E := by
+      exact_mod_cast w.ramificationIndex_pos (F := E)
+    have hbdd := hc w (Place.mem_fiber.mpr hw)
+    nlinarith [Int.natCast_nonneg c]
+  · simp only [ite_eq_right (Ne.symm hw), mul_zero, neg_zero]
+    exact hreg w hw
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "mem_lSpace_nsmul_poleDivisor_of_regular_outside"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.exists_forall_mem_lSpace_nsmul_poleDivisor
+    {n : ℕ} (u : Fin n → F)
+    (hreg : ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)) :
+    ∃ c : ℕ, ∀ i, u i ∈ LSpace (c • T.poleDivisor) := by
+  classical
+  refine ⟨(Finset.univ : Finset (Fin n)).sup fun i =>
+    (T.v.fiber F).sup fun w => (-(w.ord (u i))).toNat,
+    fun i => T.mem_lSpace_nsmul_poleDivisor_of_regular_outside (hreg i) ?_⟩
+  intro w hw
+  have h1 : (-(w.ord (u i))).toNat
+      ≤ (T.v.fiber F).sup fun w' => (-(w'.ord (u i))).toNat :=
+    Finset.le_sup (f := fun w' => (-(w'.ord (u i))).toNat) hw
+  have h2 : ((T.v.fiber F).sup fun w' => (-(w'.ord (u i))).toNat)
+      ≤ (Finset.univ : Finset (Fin n)).sup fun i' =>
+          (T.v.fiber F).sup fun w' => (-(w'.ord (u i'))).toNat :=
+    Finset.le_sup (f := fun i' => (T.v.fiber F).sup fun w' => (-(w'.ord (u i'))).toNat)
+      (Finset.mem_univ i)
+  have htnat : -(w.ord (u i)) ≤ ((-(w.ord (u i))).toNat : ℤ) := Int.self_le_toNat _
+  omega
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "exists_forall_mem_lSpace_nsmul_poleDivisor"
+end TranscendenceTower
+
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F]
+
+section PrincipalDivisors
+
+variable [HasPrincipalDivisors K F]
+
+namespace IntegralBasisInLSpace
+p2m_export "AlgebraicCurve.IntegralBasisInLSpace" "hu_indep c u mk.injEq hu_mem mk"
+end IntegralBasisInLSpace
+p2m_open_scoped "AlgebraicCurve.IntegralBasisInLSpace" in
+def IntegralBasisInLSpace.ofRegularOutside (T : TranscendenceTower K E F)
+    (u : Fin (Module.finrank E F) → F) (hu_indep : LinearIndependent E u)
+    (hreg : ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)) :
+    IntegralBasisInLSpace T where
+  c := (T.exists_forall_mem_lSpace_nsmul_poleDivisor u hreg).choose
+  u := u
+  hu_indep := hu_indep
+  hu_mem := (T.exists_forall_mem_lSpace_nsmul_poleDivisor u hreg).choose_spec
+
+omit [FiniteDimensional E F] in
+theorem hasIntegralBasisInLSpace_of_regularOutside (T : TranscendenceTower K E F)
+    (h : HasIntegralBasisRegularOutside K E F T) :
+    HasIntegralBasisInLSpace K E F T := by
+  obtain ⟨u, hu_indep, hreg⟩ := h
+  exact ⟨IntegralBasisInLSpace.ofRegularOutside T u hu_indep hreg⟩
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+theorem linearIndependent_pow_mul {x : E} {n : ℕ} {u : Fin n → F}
+    (hx : LinearIndependent K (fun j : ℕ => x ^ j)) (hu : LinearIndependent E u) :
+    LinearIndependent K (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2) := by
+  have heq : (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2)
+      = (fun p : ℕ × Fin n => (x ^ p.1) • u p.2) := by
+    funext p
+    rw [Algebra.smul_def, map_pow]
+  rw [heq]
+  exact linearIndependent_smul (R := K) (S := E) (A := F) hx hu
+
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+def PoleDivisorPackage.ofTranscendenceTower (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    PoleDivisorPackage K F where
+  x := T.xF
+  B := T.poleDivisor
+  hB_eff := T.poleDivisor_nonneg
+  hx_mem := T.xF_mem_lSpace_poleDivisor
+  n := Module.finrank E F
+  hn_pos := Module.finrank_pos
+  degB_eq := T.degree_poleDivisor_eq_finrank
+  c := IB.c
+  u := IB.u
+  hu_mem := IB.hu_mem
+  lin_indep := linearIndependent_pow_mul T.hx_indep IB.hu_indep
+
+theorem hasPoleDivisorPackage_of_transcendenceTower
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    HasPoleDivisorPackage K F :=
+  ⟨PoleDivisorPackage.ofTranscendenceTower T IB⟩
+
+theorem hasPoleDivisorPackage_of_hasIntegralBasisInLSpace
+    (T : TranscendenceTower K E F) (h : HasIntegralBasisInLSpace K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_transcendenceTower T h.some
+
+theorem hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside
+    (T : TranscendenceTower K E F) (h : HasIntegralBasisRegularOutside K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisInLSpace T
+    (hasIntegralBasisInLSpace_of_regularOutside T h)
+
+end PrincipalDivisors
+
+theorem indexOfSpecialtyFinite_of_transcendenceTower [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem stichtenothGenusExists_of_transcendenceTower [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem gate_ofTranscendenceTower_n_eq [HasPrincipalDivisors K F] (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    (PoleDivisorPackage.ofTranscendenceTower T IB).n = Module.finrank E F := rfl
+
+theorem gate_ofTranscendenceTower_B_eq [HasPrincipalDivisors K F] (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    (PoleDivisorPackage.ofTranscendenceTower T IB).B = T.poleDivisor := rfl
+
+theorem gate_ofTranscendenceTower_x_transcendental [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    LinearIndependent K
+      (fun j : ℕ => T.xF ^ j *
+        (PoleDivisorPackage.ofTranscendenceTower T IB).u ⟨0, Module.finrank_pos⟩) :=
+  gate_x_transcendental_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem gate_degree_pullback_single_of_deg_eq [HasPrincipalDivisors K F]
+    (v : Place K E) (d : ℕ) (hd : v.deg = d) :
+    Divisor.degree (Divisor.pullback F (Finsupp.single v (1 : ℤ)))
+      = (Module.finrank E F : ℤ) * d := by
+  rw [Divisor.degree_pullback, Divisor.degree_single, hd]; ring
+
+theorem gate_stichtenothGenus_le_of_transcendenceTower [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T)
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    γ ≤ (Module.finrank E F : ℤ) * (IB.c - 1) + 1 :=
+  gate_stichtenothGenus_le_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB) h
+
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open Module
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~restrict_plac\
+  eOfPrime~placeOfPrime~comap_algebraMap_ne_top"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral {f : F}
+    (hf : IsIntegral w.toValuationSubring f) :
+    f ∈ w.toValuationSubring := by
+  obtain ⟨y, hy⟩ := IsIntegrallyClosed.isIntegral_iff.mp hf
+  exact hy ▸ y.2
+
+p2m_export "AlgebraicCurve.Place" "mem_of_isIntegral"
+
+theorem ord_nonneg_of_isIntegral {f : F} (hf : IsIntegral w.toValuationSubring f) :
+    0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral hf)
+
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral_of_algebraMap_mem {A : Type*}
+    [CommRing A] [Algebra A F]
+    (hA : ∀ a : A, algebraMap A F a ∈ w.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : f ∈ w.toValuationSubring := by
+  let : Algebra A w.toValuationSubring :=
+    ((algebraMap A F).codRestrict w.toValuationSubring.toSubring hA).toAlgebra
+  have : IsScalarTower A w.toValuationSubring F :=
+    IsScalarTower.of_algebraMap_eq fun a => rfl
+  exact w.mem_of_isIntegral hf.tower_top
+
+p2m_export "AlgebraicCurve.Place" "mem_of_isIntegral_of_algebraMap_mem"
+
+theorem ord_nonneg_of_isIntegral_of_algebraMap_mem {A : Type*} [CommRing A] [Algebra A F]
+    (hA : ∀ a : A, algebraMap A F a ∈ w.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : 0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral_of_algebraMap_mem hA hf)
+
+end Place
+
+section Bridge
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+variable {A : Type*} [CommRing A] [Algebra A E] [Algebra A F] [IsScalarTower A E F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+end Place
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral_of_restrict [Algebra.IsIntegral E F]
+    (w : Place K F)
+    {u : Place K E} (hw : w.restrict E = u)
+    (hA : ∀ a : A, algebraMap A E a ∈ u.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : f ∈ w.toValuationSubring := by
+  refine w.mem_of_isIntegral_of_algebraMap_mem (fun a => ?_) hf
+  rw [IsScalarTower.algebraMap_apply A E F, ← w.mem_restrict_iff, hw]
+  exact hA a
+
+end Place
+p2m_export "AlgebraicCurve" "Place.mem_of_isIntegral_of_restrict"
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.ord_nonneg_of_isIntegral_of_restrict
+    [Algebra.IsIntegral E F] (w : Place K F)
+    {u : Place K E} (hw : w.restrict E = u)
+    (hA : ∀ a : A, algebraMap A E a ∈ u.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : 0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral_of_restrict hw hA hf)
+
+end Place
+p2m_export "AlgebraicCurve" "Place.ord_nonneg_of_isIntegral_of_restrict"
+namespace TranscendenceTower
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF poleDivisor RegularOutside hx_indep hxreg v \
+  mk.injEq mk hvdeg x hxv"
+end TranscendenceTower
+namespace TranscendenceTower
+p2m_open_scoped "AlgebraicCurve.TranscendenceTower" in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.ord_nonneg_of_isIntegral_of_regularOutside
+    [Algebra.IsIntegral E F] (T : TranscendenceTower K E F) (hA : T.RegularOutside A)
+    {f : F} (hf : IsIntegral A f) :
+    ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord f := fun w hw =>
+  w.ord_nonneg_of_isIntegral_of_restrict rfl (hA _ hw) hf
+
+end TranscendenceTower
+p2m_export "AlgebraicCurve" "TranscendenceTower.ord_nonneg_of_isIntegral_of_regularOutside"
+end Bridge
+
+section Headline
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F]
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+theorem linearIndependent_reindex_basis {s : Finset F} (b : Basis s E F) :
+    LinearIndependent E (fun i : Fin (Module.finrank E F) =>
+      b ((Fintype.equivFinOfCardEq (Module.finrank_eq_card_basis b).symm).symm i)) :=
+  b.linearIndependent.comp _ (Equiv.injective _)
+
+theorem hasIntegralBasisRegularOutside_of_isFractionRing
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    HasIntegralBasisRegularOutside K E F T := by
+  obtain ⟨s, b, hint⟩ := FiniteDimensional.exists_is_basis_integral A E F
+  set e : Fin (Module.finrank E F) ≃ s :=
+    (Fintype.equivFinOfCardEq (Module.finrank_eq_card_basis b).symm).symm
+  refine ⟨fun i => b (e i), linearIndependent_reindex_basis b, fun i w hw => ?_⟩
+  exact T.ord_nonneg_of_isIntegral_of_regularOutside hA (hint (e i)) w hw
+
+theorem hasIntegralBasisRegularOutside_of_hasRegularFractionSubring
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    HasIntegralBasisRegularOutside K E F T := by
+  obtain ⟨A, hfrac, hreg⟩ := h
+  have : IsFractionRing A E := hfrac
+  exact hasIntegralBasisRegularOutside_of_isFractionRing (A := A) T
+    (fun u hu a => hreg u hu (a : E) a.property)
+
+theorem hasPoleDivisorPackage_of_isFractionRing [HasPrincipalDivisors K F]
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside T
+    (hasIntegralBasisRegularOutside_of_isFractionRing T hA)
+
+theorem stichtenothGenusExists_of_isFractionRing [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasPoleDivisorPackage
+    (hasPoleDivisorPackage_of_isFractionRing T hA)
+
+theorem hasPoleDivisorPackage_of_hasRegularFractionSubring [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside T
+    (hasIntegralBasisRegularOutside_of_hasRegularFractionSubring T h)
+
+theorem stichtenothGenusExists_of_hasRegularFractionSubring [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasPoleDivisorPackage
+    (hasPoleDivisorPackage_of_hasRegularFractionSubring T h)
+
+namespace TranscendenceTower
+p2m_open_scoped "AlgebraicCurve.TranscendenceTower" in
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.adjoin_x_regularOutside (T :
+  TranscendenceTower K E F) :
+    ∀ u : Place K E, u ≠ T.v →
+      ∀ a ∈ Algebra.adjoin K {T.x}, a ∈ u.toValuationSubring := by
+  intro u hu a ha
+  let S : Subalgebra K E :=
+    { u.toValuationSubring.toSubsemiring with
+      algebraMap_mem' := u.algebraMap_mem' }
+  suffices h : a ∈ S from h
+  refine Algebra.adjoin_le ?_ ha
+  intro y hy
+  rw [Set.mem_singleton_iff] at hy
+  subst hy
+  change T.x ∈ u.toValuationSubring
+  exact AlgebraicCurve.Place.mem_of_ord_nonneg u T.x_ne_zero (T.hxreg u hu)
+
+end TranscendenceTower
+p2m_export "AlgebraicCurve" "TranscendenceTower.adjoin_x_regularOutside"
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+theorem hasRegularFractionSubring_of_adjoin_x_isFractionRing
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    HasRegularFractionSubring K E F T :=
+  ⟨Algebra.adjoin K {T.x}, hfrac, T.adjoin_x_regularOutside⟩
+
+theorem hasIntegralBasisRegularOutside_of_adjoin_x_isFractionRing
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    HasIntegralBasisRegularOutside K E F T :=
+  hasIntegralBasisRegularOutside_of_hasRegularFractionSubring T
+    (hasRegularFractionSubring_of_adjoin_x_isFractionRing T hfrac)
+
+theorem stichtenothGenusExists_of_adjoin_x_isFractionRing [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasRegularFractionSubring T
+    (hasRegularFractionSubring_of_adjoin_x_isFractionRing T hfrac)
+
+end Headline
+
+section Gates
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem gate_mem_of_isIntegral_recovers_comap (w : Place K F) (E : Type*) [Field E]
+    [Algebra E F] [Algebra.IsIntegral E F]
+    (hE : ∀ a : E, algebraMap E F a ∈ w.toValuationSubring) (f : F) :
+    f ∈ w.toValuationSubring := by
+  let : Algebra E w.toValuationSubring :=
+    ((algebraMap E F).codRestrict w.toValuationSubring.toSubring hE).toAlgebra
+  have : IsScalarTower E w.toValuationSubring F :=
+    IsScalarTower.of_algebraMap_eq fun _ => rfl
+  exact w.mem_of_isIntegral (Algebra.IsIntegral.isIntegral (R := E) f).tower_top
+
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+
+theorem gate_bridge_recovers_hxreg [Algebra.IsIntegral E F]
+    (T : TranscendenceTower K E F) (w : Place K F) (hw : w.restrict E ≠ T.v) :
+    0 ≤ w.ord T.xF := by
+  rw [TranscendenceTower.xF, Place.ord_restrict]
+  exact mul_nonneg (Int.natCast_nonneg _) (T.hxreg _ hw)
+
+theorem gate_regularOutside_mono (T : TranscendenceTower K E F) {A A' : Subalgebra K E}
+    (hle : A ≤ A')
+    (hA' : ∀ u : Place K E, u ≠ T.v → ∀ a ∈ A', a ∈ u.toValuationSubring) :
+    ∀ u : Place K E, u ≠ T.v → ∀ a ∈ A, a ∈ u.toValuationSubring :=
+  fun u hu a ha => hA' u hu a (hle ha)
+
+theorem gate_bot_regularOutside (T : TranscendenceTower K E F) :
+    ∀ u : Place K E, u ≠ T.v → ∀ a ∈ (⊥ : Subalgebra K E), a ∈ u.toValuationSubring := by
+  intro u _ a ha
+  obtain ⟨c, rfl⟩ := Algebra.mem_bot.mp ha
+  exact u.algebraMap_mem' c
+
+theorem gate_adjoin_x_not_regular_at_v (T : TranscendenceTower K E F) :
+    ¬ ∀ a ∈ Algebra.adjoin K {T.x}, a ∈ T.v.toValuationSubring := by
+  intro h
+  have hx := AlgebraicCurve.Place.ord_nonneg_of_mem T.v (h T.x (Algebra.subset_adjoin rfl))
+  rw [T.hxv] at hx
+  exact absurd hx (by decide)
+
+end Gates
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open Module Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+section Transcendental
+
+variable {K A : Type*} [CommRing K] [CommRing A] [Algebra K A]
+
+theorem linearIndependent_pow_of_transcendental {x : A} (hx : Transcendental K x) :
+    LinearIndependent K (fun j : ℕ => x ^ j) := by
+  have hinj : Function.Injective (Polynomial.aeval x : K[X] →ₐ[K] A) :=
+    transcendental_iff_injective.mp hx
+  have hXj : LinearIndependent K (fun j : ℕ => (X : K[X]) ^ j) := by
+    have hb := (Polynomial.basisMonomials K).linearIndependent
+    simp only [Polynomial.coe_basisMonomials] at hb
+    convert hb using 2 with j
+    exact (Polynomial.monomial_one_right_eq_X_pow j).symm
+  have heq : (fun j : ℕ => x ^ j)
+      = (fun j : ℕ => (Polynomial.aeval x : K[X] →ₐ[K] A) (X ^ j)) := by
+    funext j; simp
+  rw [heq]
+  exact hXj.map' (Polynomial.aeval x).toLinearMap
+    (LinearMap.ker_eq_bot_of_injective hinj)
+
+theorem transcendental_of_linearIndependent_pow {x : A}
+    (hx : LinearIndependent K (fun j : ℕ => x ^ j)) :
+    Transcendental K x := by
+  rw [transcendental_iff]
+  intro p hp
+  rw [Polynomial.aeval_eq_sum_range, ← Fin.sum_univ_eq_sum_range] at hp
+  ext j
+  rcases lt_or_ge j (p.natDegree + 1) with hj | hj
+  · exact (Fintype.linearIndependent_iff.mp
+      (hx.comp (Fin.val : Fin (p.natDegree + 1) → ℕ) Fin.val_injective))
+      (fun i => p.coeff i) hp ⟨j, hj⟩
+  · exact p.coeff_eq_zero_of_natDegree_lt (Nat.lt_of_succ_le hj)
+
+end Transcendental
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "algebraMap_mem_ofHeightOneSpectrum placeInfty \
+  ord_placeInfty deg_placeInfty eq_ofHeightOneSpectrum_or_eq_placeInfty"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+
+theorem ord_placeInfty_X : (placeInfty K).ord (RatFunc.X : RatFunc K) = -1 := by
+  rw [ord_placeInfty (K := K) RatFunc.X_ne_zero, RatFunc.intDegree_X]
+
+theorem algebraMap_polynomial_mem_of_ne_placeInfty
+    {u : Place K (RatFunc K)} (hu : u ≠ placeInfty K) (q : K[X]) :
+    algebraMap K[X] (RatFunc K) q ∈ u.toValuationSubring := by
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty u with ⟨w, hw⟩ | hw
+  · subst hw; exact algebraMap_mem_ofHeightOneSpectrum K w q
+  · exact absurd hw hu
+
+theorem ord_X_nonneg_of_ne_placeInfty_port
+    {u : Place K (RatFunc K)} (hu : u ≠ placeInfty K) :
+    0 ≤ u.ord (RatFunc.X : RatFunc K) := by
+  rw [← RatFunc.algebraMap_X]
+  exact AlgebraicCurve.Place.ord_nonneg_of_mem u (algebraMap_polynomial_mem_of_ne_placeInfty K hu
+    Polynomial.X)
+
+variable (F : Type*) [Field F] [Algebra K F] [Algebra (RatFunc K) F]
+  [IsScalarTower K (RatFunc K) F]
+
+def transcendenceTower : TranscendenceTower K (RatFunc K) F where
+  x := RatFunc.X
+  hx_indep := linearIndependent_pow_of_transcendental RatFunc.transcendental_X
+  v := placeInfty K
+  hvdeg := deg_placeInfty K
+  hxv := ord_placeInfty_X K
+  hxreg := fun _ hu => ord_X_nonneg_of_ne_placeInfty_port K hu
+
+@[scoped simp]
+theorem transcendenceTower_x : (transcendenceTower K F).x = RatFunc.X := rfl
+
+@[scoped simp]
+theorem transcendenceTower_v : (transcendenceTower K F).v = placeInfty K := rfl
+
+omit [DecidableEq (RatFunc K)] in
+theorem aeval_X_eq_algebraMap (q : K[X]) :
+    (Polynomial.aeval (R := K) (RatFunc.X : RatFunc K)) q
+      = algebraMap K[X] (RatFunc K) q := by
+  have hext : (Polynomial.aeval (R := K) (RatFunc.X : RatFunc K))
+      = IsScalarTower.toAlgHom K K[X] (RatFunc K) :=
+    Polynomial.algHom_ext (by simp [RatFunc.algebraMap_X])
+  rw [hext]; rfl
+
+omit [DecidableEq (RatFunc K)] in
+theorem algebraMap_polynomial_mem_adjoin_X (q : K[X]) :
+    algebraMap K[X] (RatFunc K) q ∈ Algebra.adjoin K {(RatFunc.X : RatFunc K)} := by
+  rw [Algebra.adjoin_singleton_eq_range_aeval]
+  exact ⟨q, aeval_X_eq_algebraMap K q⟩
+
+omit [DecidableEq (RatFunc K)] in
+theorem isFractionRing_adjoin_X :
+    IsFractionRing (Algebra.adjoin K {(RatFunc.X : RatFunc K)}) (RatFunc K) := by
+  refine IsFractionRing.of_field _ _ fun z => ?_
+  refine ⟨⟨algebraMap K[X] (RatFunc K) z.num, algebraMap_polynomial_mem_adjoin_X K z.num⟩,
+    ⟨algebraMap K[X] (RatFunc K) z.denom, algebraMap_polynomial_mem_adjoin_X K z.denom⟩, ?_⟩
+  change z = algebraMap K[X] (RatFunc K) z.num / algebraMap K[X] (RatFunc K) z.denom
+  exact z.num_div_denom.symm
+
+theorem hasRegularFractionSubring :
+    HasRegularFractionSubring K (RatFunc K) F (transcendenceTower K F) :=
+  hasRegularFractionSubring_of_adjoin_x_isFractionRing
+    (transcendenceTower K F) (isFractionRing_adjoin_X K)
+
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+
+theorem hasIntegralBasisRegularOutside :
+    HasIntegralBasisRegularOutside K (RatFunc K) F (transcendenceTower K F) :=
+  hasIntegralBasisRegularOutside_of_adjoin_x_isFractionRing
+    (transcendenceTower K F) (isFractionRing_adjoin_X K)
+
+section PrincipalDivisors
+
+variable [HasPrincipalDivisors K F]
+
+omit [DecidableEq (RatFunc K)] in
+theorem hasPoleDivisorPackage_of_ratFunc_tower :
+    HasPoleDivisorPackage K F := by
+  classical
+  exact
+    hasPoleDivisorPackage_of_hasRegularFractionSubring
+      (transcendenceTower K F) (hasRegularFractionSubring K F)
+
+end PrincipalDivisors
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+omit [DecidableEq (RatFunc K)] in
+theorem stichtenothGenusExists_of_ratFunc_tower :
+    StichtenothGenusExists K F := by
+  classical
+  exact
+    stichtenothGenusExists_of_adjoin_x_isFractionRing
+      (transcendenceTower K F) (isFractionRing_adjoin_X K)
+
+omit [DecidableEq (RatFunc K)] in
+theorem indexOfSpecialtyFinite_of_ratFunc_tower :
+    IndexOfSpecialtyFinite K F := by
+  classical
+  exact
+    indexOfSpecialtyFinite_of_stichtenothGenusExists
+      (stichtenothGenusExists_of_ratFunc_tower K F)
+
+end RationalFunctionField
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open Module Polynomial IsDedekindDomain
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "algebraMap_mem_ofHeightOneSpectrum placeInfty \
+  ord_placeInfty deg_placeInfty eq_ofHeightOneSpectrum_or_eq_placeInfty"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+variable (F : Type*) [Field F] [Algebra K F] [Algebra (RatFunc K) F]
+  [IsScalarTower K (RatFunc K) F]
+
+section LyingOver
+
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+
+omit [DecidableEq (RatFunc K)] in
+omit [DecidableEq (RatFunc K)] in
+private theorem _root_.AlgebraicCurve.RationalFunctionField.exists_restrict_eq (v : Place K (RatFunc
+  K)) :
+    ∃ w : Place K F, w.restrict (RatFunc K) = v :=
+  Place.exists_restrict_eq v
+
+p2m_export "AlgebraicCurve.RationalFunctionField" "exists_restrict_eq"
+
+omit [DecidableEq (RatFunc K)] in
+theorem nonempty_place_of_ratFunc_tower : Nonempty (Place K F) := by
+  classical
+  exact
+    (exists_restrict_eq K F (placeInfty K)).nonempty
+
+end LyingOver
+
+omit [DecidableEq (RatFunc K)] [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F] in
+theorem finiteDimensional_lSpace_zero_of_constantsAreBase (hC : ConstantsAreBase K F) :
+    FiniteDimensional K (LSpace (0 : Divisor K F)) := by
+  rw [show LSpace (0 : Divisor K F) = LinearMap.range (Algebra.linearMap K F) from hC]
+  exact LinearMap.finiteDimensional_range _
+
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+variable [IsCurveOver K F]
+
+omit [DecidableEq (RatFunc K)] in
+theorem stichtenothGenusExists (hC : ConstantsAreBase K F) :
+    StichtenothGenusExists K F := by
+  classical
+  exact
+    haveI := nonempty_place_of_ratFunc_tower K F
+    haveI := finiteDimensional_lSpace_zero_of_constantsAreBase K F hC
+    stichtenothGenusExists_of_ratFunc_tower K F
+
+omit [DecidableEq (RatFunc K)] in
+theorem indexOfSpecialtyFinite (hC : ConstantsAreBase K F) :
+    IndexOfSpecialtyFinite K F := by
+  classical
+  exact
+    indexOfSpecialtyFinite_of_stichtenothGenusExists (stichtenothGenusExists K F hC)
+
+omit [DecidableEq (RatFunc K)] in
+theorem riemannGenusBounded (hC : ConstantsAreBase K F) : RiemannGenusBounded K F := by
+  classical
+  exact
+    haveI := nonempty_place_of_ratFunc_tower K F
+    haveI := finiteDimensional_lSpace_zero_of_constantsAreBase K F hC
+    riemannGenusBounded_of_poleDivisorPackage (hasPoleDivisorPackage_of_ratFunc_tower K F).some
+
+end RationalFunctionField
+end AlgebraicCurve
+end
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg\
+  " in
+open _root_.P2MW.S_AlgebraicCurve_RationalFunctionField_ord_X_nonneg_of_ne_placeInfty.AlgebraicCurve
+  Polynomial in
+theorem solution (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+    {u : Place K (RatFunc K)} (hu : u ≠ RationalFunctionField.placeInfty K) :
+    0 ≤ u.ord (RatFunc.X : RatFunc K) :=
+  AlgebraicCurve.RationalFunctionField.ord_X_nonneg_of_ne_placeInfty_port (K := K) (u := u) (hu :=
+    hu)
+
+end S_AlgebraicCurve_RationalFunctionField_ord_X_nonneg_of_ne_placeInfty
+end P2MW
+export P2MW.S_AlgebraicCurve_RationalFunctionField_ord_X_nonneg_of_ne_placeInfty (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace AlgebraicCurve
+theorem RationalFunctionField.ord_X_nonneg_of_ne_placeInfty (K : Type*) [Field K]
+    [DecidableEq (RatFunc K)]
+    {u : Place K (RatFunc K)} (hu : u ≠ RationalFunctionField.placeInfty K) :
+    0 ≤ u.ord (RatFunc.X : RatFunc K) :=
+  solution K hu
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_X_sub_C.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_X_sub_C.lean
new file mode 100644
index 0000000000..7743c298f0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_X_sub_C.lean
@@ -0,0 +1,1328 @@
+/-
+Based on Prove2Me node AlgebraicCurve.RationalFunctionField.ord_X_sub_C
+(f9a2d286-c81a-519f-a515-e75850be890b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a29e81e9-cbd7-5100-a1a9-5ebfe9e17f8e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceInfty
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import Mathlib.FieldTheory.RatFunc.Degree
+import Mathlib.NumberTheory.RatFunc.Ostrowski
+import Mathlib.RingTheory.DedekindDomain.Factorization
+import Mathlib.FieldTheory.IsAlgClosed.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_of_ord_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_nonneg_of_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_eq_neg_log_of_valuationSubring_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_finite_setOf_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_hasPrincipalDivisors
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_of_span
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_subsingleton_setOf_forall_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_congr
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_inv
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_zpow
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_isRational_iff_deg_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_zsmul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_zpow_left
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_single_sub_single
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Divisor of X-b on the rational function field
+
+Theorem statement: `AlgebraicCurve.RationalFunctionField.ord_X_sub_C`
+(`f9a2d286-c81a-519f-a515-e75850be890b`), by Claude, 2026-09-05.
+
+Proof: submission `a29e81e9-cbd7-5100-a1a9-5ebfe9e17f8e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and $b \in K$. A place of $K(t) =$ `RatFunc K` over $K$ is, in this development,
+a valuation subring of `RatFunc K` that contains the image of $K$, is not the whole field, and is a
+principal ideal ring; for such a place $v$ and a function $f$, $v$`.ord`$f$ is $-\log$ of the value
+of $f$ under the $\mathbb{Z}^{m0}$-valued valuation attached to the height-one point of the
+valuation subring of $v$, i.e. the usual normalised order of vanishing. The assertion is that for
+every place $v$ of `RatFunc K` over $K$, the order of the image of the polynomial $X - C\,b$ in
+`RatFunc K` under the canonical map from $K[X]$ satisfies $$v.\mathrm{ord}\,(X-b) =
+\bigl(\mathrm{single}\,(\mathrm{placeOfPoint}\,K\,b)\,1 +
+\mathrm{single}\,(\mathrm{placeInfty}\,K)\,(-1)\bigr)(v),$$ the value at $v$ of the finitely
+supported $\mathbb{Z}$-valued function which is the sum of the delta functions at two distinguished
+places: `placeOfPoint K b`, the place coming from the height-one prime of $K[X]$ generated by the
+irreducible polynomial $X - C\,b$, with coefficient $1$, and `placeInfty K`, the place whose
+valuation subring is that of the infinite valuation of `RatFunc K`, with coefficient $-1$. Thus the
+order is $1$ at the place of the point $b$, $-1$ at the place at infinity, and $0$ at every other
+place.
+
+This is the classical computation $\operatorname{div}(t-b) = (b) - (\infty)$ on $\mathbb{P}^1$,
+stated place by place. It supports the identification of the places of $K(t)$ with the points of
+$\mathbb{P}^1$ together with the point at infinity, and is used in the description of degree-zero
+principal divisors on the rational function field and in the transfer of places under automorphisms
+of $K(t)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_ord_X_sub_C.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_22e088d4
+
+noncomputable section
+
+open Polynomial IsDedekindDomain WithZero IsLocalRing
+
+open scoped Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.mem_maximalIdeal_iff_adicValuation_lt_one \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff Place Place.ext Place.deg Place.ord_inv Divisor \
+  Divisor.degree Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring Place.evalAt \
+  Divisor.evalFun Divisor.evalFun_def Divisor.evalFun_zero \
+  RationalFunctionField.hasPrincipalDivisors Place.evalAt_congr Place.evalAt_algebraMap \
+  Place.isRational_iff_deg_eq_one Divisor.evalFun_add Divisor.evalFun_mul Divisor.evalFun_zsmul \
+  Divisor.evalFun_zpow_left Divisor.evalFun_single_sub_single"
+p2m_open "AlgebraicCurve"
+
+scoped instance {K : Type*} [Field K] : HasPrincipalDivisors K (RatFunc K) :=
+  RationalFunctionField.hasPrincipalDivisors K
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "adicValuation_valuationSubring \
+  isEquiv_adicValuation_of_valuationSubring_eq mem_maximalIdeal_iff_adicValuation_lt_one \
+  ord_ofHeightOneSpectrum_ne_zero_iff ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring algebraMap_mem' toValuationSubring \
+  IsRational evalAt mem_of_ord_nonneg ord_nonneg_of_mem ord_algebraMap \
+  ord_eq_neg_log_of_valuationSubring_eq evalAt_congr evalAt_algebraMap evalAt_mul evalAt_ne_zero \
+  evalAt_inv isRational_iff_deg_eq_one"
+p2m_open "AlgebraicCurve.Place~algebraMap_ne_zero"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+theorem isRational_of_deg_eq_one (h : v.deg = 1) : v.IsRational :=
+  (AlgebraicCurve.Place.isRational_iff_deg_eq_one v).2 h
+
+theorem deg_eq_one_of_isRational (hv : v.IsRational) : v.deg = 1 :=
+  (AlgebraicCurve.Place.isRational_iff_deg_eq_one v).1 hv
+
+end Place
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "heightOneSpectrumOfIrreducible \
+  heightOneSpectrumOfIrreducible_asIdeal exists_irreducible_span finitePlace finitePlace_def \
+  algebraMap_mem_ofHeightOneSpectrum deg_finitePlace placeOfPoint \
+  placeOfPoint_eq_ofHeightOneSpectrum placeOfPoint_injective deg_placeOfPoint placeInfty \
+  placeInfty_toValuationSubring finite_setOf_ord_ne_zero degree_eq_zero_of_forall_eq_ord \
+  hasPrincipalDivisors ord_ofHeightOneSpectrum_of_span"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable (K : Type*) [Field K]
+
+theorem ord_finitePlace_ne_zero_iff {p : K[X]} (hp : Irreducible p) {q : K[X]} (hq : q ≠ 0) :
+    (finitePlace K hp).ord (algebraMap K[X] (RatFunc K) q) ≠ 0 ↔ p ∣ q := by
+  rw [finitePlace, Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) _ hq,
+    heightOneSpectrumOfIrreducible_asIdeal, Ideal.mem_span_singleton]
+
+section PlaceInfty
+
+variable [DecidableEq (RatFunc K)]
+
+theorem inftyValuation_isEquiv_adicValuation :
+    (RatFunc.inftyValuation K).IsEquiv (placeInfty K).adicValuation :=
+  (placeInfty K).isEquiv_adicValuation_of_valuationSubring_eq rfl
+
+theorem placeInfty_ne_ofHeightOneSpectrum (w : HeightOneSpectrum K[X]) :
+    placeInfty K ≠ Place.ofHeightOneSpectrum w := by
+  intro h
+  refine RatFunc.adicValuation_not_isEquiv_infty_valuation w
+    ((Valuation.isEquiv_iff_valuationSubring _ _).mpr ?_)
+  have h2 := congrArg Place.toValuationSubring h
+  rw [placeInfty_toValuationSubring, Place.ofHeightOneSpectrum_toValuationSubring] at h2
+  exact h2.symm
+
+end PlaceInfty
+
+variable {K}
+
+theorem eq_ofHeightOneSpectrum_or_eq_placeInfty [DecidableEq (RatFunc K)]
+    (v : Place K (RatFunc K)) :
+    (∃ w : HeightOneSpectrum K[X], v = Place.ofHeightOneSpectrum w) ∨ v = placeInfty K := by
+  rcases (RatFunc.valuation_isEquiv_infty_or_adic (v := v.adicValuation)).or with h | h
+  · exact Or.inr (Place.ext (v.adicValuation_valuationSubring.symm.trans
+      ((Valuation.isEquiv_iff_valuationSubring _ _).mp h)))
+  · obtain ⟨w, hw, -⟩ := h
+    exact Or.inl ⟨w, Place.ext (v.adicValuation_valuationSubring.symm.trans
+      ((Valuation.isEquiv_iff_valuationSubring _ _).mp hw))⟩
+
+section DegInfty
+
+variable (K) [DecidableEq (RatFunc K)]
+
+theorem exists_sub_algebraMap_intDegree_neg {x : RatFunc K}
+    (hx : RatFunc.inftyValuation K x ≤ 1) :
+    ∃ c : K, x - algebraMap K (RatFunc K) c = 0 ∨
+      (x - algebraMap K (RatFunc K) c).intDegree < 0 := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · exact ⟨0, Or.inl (by simp)⟩
+  have hdeg : x.intDegree ≤ 0 := by
+    rw [RatFunc.inftyValuation_apply, RatFunc.inftyValuation_of_nonzero K hx0,
+      show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_le_exp] at hx
+    exact hx
+  have hnum0 : x.num ≠ 0 := RatFunc.num_ne_zero hx0
+  have hden0 : x.denom ≠ 0 := x.denom_ne_zero
+  rcases lt_or_eq_of_le hdeg with hlt | heq
+  · exact ⟨0, Or.inr (by simpa using hlt)⟩
+  have hndeg : x.num.natDegree = x.denom.natDegree := by
+    have h2 := heq
+    rw [RatFunc.intDegree, sub_eq_zero] at h2
+    exact_mod_cast h2
+  set c : K := x.num.leadingCoeff / x.denom.leadingCoeff with hc
+  have hc0 : c ≠ 0 := by
+    rw [hc]
+    exact div_ne_zero (Polynomial.leadingCoeff_ne_zero.mpr hnum0)
+      (Polynomial.leadingCoeff_ne_zero.mpr hden0)
+  refine ⟨c, ?_⟩
+  have hsub : x - algebraMap K (RatFunc K) c
+      = algebraMap K[X] (RatFunc K) (x.num - Polynomial.C c * x.denom)
+        / algebraMap K[X] (RatFunc K) x.denom := by
+    rw [map_sub, map_mul, sub_div, x.num_div_denom, mul_div_assoc,
+      div_self ((map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hden0),
+      mul_one, IsScalarTower.algebraMap_apply K K[X] (RatFunc K), Polynomial.algebraMap_eq]
+  rcases eq_or_ne (x.num - Polynomial.C c * x.denom) 0 with hzero | hnz
+  · exact Or.inl (by rw [hsub, hzero, map_zero, zero_div])
+  refine Or.inr ?_
+  rw [hsub, RatFunc.intDegree_div ((map_ne_zero_iff _
+      (IsFractionRing.injective K[X] (RatFunc K))).mpr hnz)
+    ((map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hden0),
+    RatFunc.intDegree_polynomial, RatFunc.intDegree_polynomial, sub_neg]
+  have hCdeg : (Polynomial.C c * x.denom).degree = x.denom.degree := by
+    rw [Polynomial.degree_mul, Polynomial.degree_C hc0, zero_add]
+  have hdegeq : x.num.degree = (Polynomial.C c * x.denom).degree := by
+    rw [hCdeg, Polynomial.degree_eq_natDegree hnum0, Polynomial.degree_eq_natDegree hden0,
+      hndeg]
+  have hlc : x.num.leadingCoeff = (Polynomial.C c * x.denom).leadingCoeff := by
+    rw [Polynomial.leadingCoeff_mul, Polynomial.leadingCoeff_C, hc,
+      div_mul_cancel₀ _ (Polynomial.leadingCoeff_ne_zero.mpr hden0)]
+  have hlt := Polynomial.degree_sub_lt_left hdegeq hnum0 hlc
+  rw [hdegeq, hCdeg] at hlt
+  exact_mod_cast Polynomial.natDegree_lt_natDegree hnz hlt
+
+theorem deg_placeInfty : (placeInfty K).deg = 1 := by
+  have hbij : Function.Bijective (Algebra.ofId K (placeInfty K).ResidueField) := by
+    constructor
+    · exact fun a b h => (algebraMap K ((placeInfty K).ResidueField)).injective h
+    · intro y
+      obtain ⟨⟨x, hx⟩, rfl⟩ := IsLocalRing.residue_surjective y
+      obtain ⟨c, hc⟩ := exists_sub_algebraMap_intDegree_neg K
+        ((Valuation.mem_valuationSubring_iff _ _).mp hx)
+      refine ⟨c, ?_⟩
+      change IsLocalRing.residue _ (algebraMap K (placeInfty K).toValuationSubring c) = _
+      rw [← sub_eq_zero, ← map_sub, IsLocalRing.residue_eq_zero_iff,
+        Place.mem_maximalIdeal_iff_adicValuation_lt_one]
+      change (placeInfty K).adicValuation (algebraMap K (RatFunc K) c - x) < 1
+      rw [← (inftyValuation_isEquiv_adicValuation K).lt_one_iff_lt_one,
+        show algebraMap K (RatFunc K) c - x = -(x - algebraMap K (RatFunc K) c) from
+          (neg_sub _ _).symm, Valuation.map_neg]
+      rcases hc with hc | hc
+      · rw [hc, map_zero]
+        exact zero_lt_one
+      · rw [RatFunc.inftyValuation_apply, RatFunc.inftyValuationDef]
+        split
+        · exact zero_lt_one
+        · rw [show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_lt_exp]
+          exact hc
+  rw [Place.deg, ← (AlgEquiv.ofBijective _ hbij).toLinearEquiv.finrank_eq,
+    Module.finrank_self]
+
+end DegInfty
+
+end RationalFunctionField
+
+theorem le_exp_neg_one_of_lt_one {x : ℤᵐ⁰} (hx : x < 1) : x ≤ exp (-1 : ℤ) := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · exact zero_le
+  · rw [← exp_log hx0] at hx ⊢
+    rw [show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_lt_exp] at hx
+    rw [exp_le_exp]
+    omega
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "adicValuation_valuationSubring \
+  isEquiv_adicValuation_of_valuationSubring_eq mem_maximalIdeal_iff_adicValuation_lt_one \
+  ord_ofHeightOneSpectrum_ne_zero_iff ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring algebraMap_mem' toValuationSubring \
+  IsRational evalAt mem_of_ord_nonneg ord_nonneg_of_mem ord_algebraMap \
+  ord_eq_neg_log_of_valuationSubring_eq evalAt_congr evalAt_algebraMap evalAt_mul evalAt_ne_zero \
+  evalAt_inv isRational_iff_deg_eq_one"
+p2m_open "AlgebraicCurve.Place~algebraMap_ne_zero"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.isUnit_algebraMap {c : K} (hc : c ≠ 0) :
+    IsUnit (algebraMap K v.toValuationSubring c) :=
+  (isUnit_iff_ne_zero.mpr hc).map _
+
+p2m_export "AlgebraicCurve.Place" "isUnit_algebraMap"
+
+theorem adicValuation_algebraMap {c : K} (hc : c ≠ 0) :
+    v.adicValuation (algebraMap K F c) = 1 := by
+  rw [← v.coe_algebraMap]
+  exact (v.adicValuation_coe_eq_one_iff _).mpr (v.isUnit_algebraMap hc)
+
+end Place
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "heightOneSpectrumOfIrreducible \
+  heightOneSpectrumOfIrreducible_asIdeal exists_irreducible_span finitePlace finitePlace_def \
+  algebraMap_mem_ofHeightOneSpectrum deg_finitePlace placeOfPoint \
+  placeOfPoint_eq_ofHeightOneSpectrum placeOfPoint_injective deg_placeOfPoint placeInfty \
+  placeInfty_toValuationSubring finite_setOf_ord_ne_zero degree_eq_zero_of_forall_eq_ord \
+  hasPrincipalDivisors ord_ofHeightOneSpectrum_of_span"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable {K : Type*} [Field K]
+
+theorem ord_ofHeightOneSpectrum_eq_zero_of_notMem (w : HeightOneSpectrum K[X]) {q : K[X]}
+    (hq : q ≠ 0) (hmem : q ∉ w.asIdeal) :
+    (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord
+      (algebraMap K[X] (RatFunc K) q) = 0 := by
+  by_contra h
+  exact hmem
+    ((Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w hq).mp h)
+
+section PlaceInftyOrd
+
+variable [DecidableEq (RatFunc K)]
+
+theorem ord_placeInfty {f : RatFunc K} (hf : f ≠ 0) :
+    (placeInfty K).ord f = -f.intDegree := by
+  have hπ : RatFunc.inftyValuation K (RatFunc.X)⁻¹ = exp (-1 : ℤ) := by
+    rw [map_inv₀, RatFunc.inftyValuation.X]
+    exact (exp_neg (1 : ℤ)).symm
+  rw [(placeInfty K).ord_eq_neg_log_of_valuationSubring_eq (RatFunc.inftyValuation K) rfl hπ
+      hf,
+    RatFunc.inftyValuation_apply, RatFunc.inftyValuation_of_nonzero K hf, log_exp]
+
+theorem ord_placeInfty_algebraMap {q : K[X]} (hq : q ≠ 0) :
+    (placeInfty K).ord (algebraMap K[X] (RatFunc K) q) = -(q.natDegree : ℤ) := by
+  rw [ord_placeInfty (RatFunc.algebraMap_ne_zero hq), RatFunc.intDegree_polynomial]
+
+end PlaceInftyOrd
+
+section IrreducibleDivisor
+
+variable [DecidableEq (RatFunc K)]
+
+theorem single_add_single_apply_eq_ord {p : K[X]} (hp : Irreducible p)
+    (v : Place K (RatFunc K)) :
+    (Finsupp.single (finitePlace K hp) (1 : ℤ)
+        + Finsupp.single (placeInfty K) (-(p.natDegree : ℤ))) v
+      = v.ord (algebraMap K[X] (RatFunc K) p) := by
+  have hp0 : p ≠ 0 := hp.ne_zero
+  rw [Finsupp.add_apply]
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+  · rw [Finsupp.single_eq_of_ne (Ne.symm (placeInfty_ne_ofHeightOneSpectrum K w)), add_zero]
+    by_cases hcase :
+        Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w = finitePlace K hp
+    · rw [hcase, Finsupp.single_eq_same]
+      exact (ord_ofHeightOneSpectrum_of_span (heightOneSpectrumOfIrreducible K hp) hp0
+        (heightOneSpectrumOfIrreducible_asIdeal K hp)).symm
+    · rw [Finsupp.single_eq_of_ne hcase]
+      refine (ord_ofHeightOneSpectrum_eq_zero_of_notMem w hp0 fun hmem => hcase ?_).symm
+      have hspan : Ideal.span {p} = w.asIdeal :=
+        (PrincipalIdealRing.isMaximal_of_irreducible hp).eq_of_le w.isPrime.ne_top
+          ((Ideal.span_singleton_le_iff_mem _).mpr hmem)
+      have hwp : w = heightOneSpectrumOfIrreducible K hp :=
+        HeightOneSpectrum.ext
+          (hspan.symm.trans (heightOneSpectrumOfIrreducible_asIdeal K hp).symm)
+      rw [hwp, finitePlace_def]
+  · rw [Finsupp.single_eq_of_ne
+        (show placeInfty K ≠ finitePlace K hp from
+          placeInfty_ne_ofHeightOneSpectrum K (heightOneSpectrumOfIrreducible K hp)),
+      Finsupp.single_eq_same, zero_add]
+    exact (ord_placeInfty_algebraMap hp0).symm
+
+theorem degree_single_add_single {p : K[X]} (hp : Irreducible p) :
+    Divisor.degree (Finsupp.single (finitePlace K hp) (1 : ℤ)
+        + Finsupp.single (placeInfty K) (-(p.natDegree : ℤ))) = 0 := by
+  rw [map_add, Divisor.degree_single, Divisor.degree_single, deg_finitePlace, deg_placeInfty]
+  push_cast
+  ring
+
+end IrreducibleDivisor
+
+def principalDivisor {f : RatFunc K} (hf : f ≠ 0) : Divisor K (RatFunc K) :=
+  ⟨(finite_setOf_ord_ne_zero hf).toFinset, fun v => v.ord f, fun v => by
+    simp [Set.Finite.mem_toFinset]⟩
+
+@[scoped simp]
+theorem principalDivisor_apply {f : RatFunc K} (hf : f ≠ 0) (v : Place K (RatFunc K)) :
+    principalDivisor hf v = v.ord f := rfl
+
+theorem principalDivisor_isPrincipal {f : RatFunc K} (hf : f ≠ 0) :
+    (principalDivisor hf).IsPrincipal :=
+  ⟨f, hf, fun _ => rfl⟩
+
+theorem degree_principalDivisor {f : RatFunc K} (hf : f ≠ 0) :
+    Divisor.degree (principalDivisor hf) = 0 :=
+  degree_eq_zero_of_forall_eq_ord (principalDivisor hf) fun _ => rfl
+
+theorem sum_ord_mul_deg_eq_zero {f : RatFunc K} (hf : f ≠ 0) :
+    ∑ v ∈ (finite_setOf_ord_ne_zero hf).toFinset, v.ord f * (v.deg : ℤ) = 0 := by
+  have h1 : (principalDivisor hf : Divisor K (RatFunc K))
+      = ∑ v ∈ (finite_setOf_ord_ne_zero hf).toFinset, Finsupp.single v (v.ord f) :=
+    (Finsupp.sum_single (principalDivisor hf)).symm
+  have h2 := degree_principalDivisor hf
+  rw [h1, map_sum] at h2
+  simp only [Divisor.degree_single] at h2
+  exact h2
+
+end RationalFunctionField
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "heightOneSpectrumOfIrreducible \
+  heightOneSpectrumOfIrreducible_asIdeal exists_irreducible_span finitePlace finitePlace_def \
+  algebraMap_mem_ofHeightOneSpectrum deg_finitePlace placeOfPoint \
+  placeOfPoint_eq_ofHeightOneSpectrum placeOfPoint_injective deg_placeOfPoint placeInfty \
+  placeInfty_toValuationSubring finite_setOf_ord_ne_zero degree_eq_zero_of_forall_eq_ord \
+  hasPrincipalDivisors ord_ofHeightOneSpectrum_of_span"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable (K : Type*) [Field K]
+
+theorem placeOfPoint_ne_placeInfty [DecidableEq (RatFunc K)] (a : K) :
+    placeOfPoint K a ≠ placeInfty K := by
+  rw [placeOfPoint_eq_ofHeightOneSpectrum]
+  exact fun h => placeInfty_ne_ofHeightOneSpectrum K _ h.symm
+
+variable {K}
+
+theorem ord_placeOfPoint_algebraMap_eq_mul (a : K) {q : K[X]} (hq : q ≠ 0) :
+    (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) q)
+      = (rootMultiplicity a q : ℤ)
+          * (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) (X - C a)) := by
+  obtain ⟨r, hr⟩ := pow_rootMultiplicity_dvd q a
+  set m : ℕ := rootMultiplicity a q with hm
+  have hXa : (X : K[X]) - C a ≠ 0 := X_sub_C_ne_zero a
+  have hr0 : r ≠ 0 := by
+    rintro rfl
+    exact hq (by simpa using hr)
+  have hndvd : ¬((X : K[X]) - C a) ∣ r := by
+    intro ⟨s, hs⟩
+    have : (X - C a) ^ (m + 1) ∣ q := ⟨s, by rw [hr, hs]; ring⟩
+    have := (le_rootMultiplicity_iff hq).mpr this
+    omega
+  have hinj := IsFractionRing.injective K[X] (RatFunc K)
+  have hXa' : algebraMap K[X] (RatFunc K) (X - C a) ≠ 0 := (map_ne_zero_iff _ hinj).mpr hXa
+  have hr0' : algebraMap K[X] (RatFunc K) r ≠ 0 := (map_ne_zero_iff _ hinj).mpr hr0
+  have hpow' : algebraMap K[X] (RatFunc K) ((X - C a) ^ m) ≠ 0 :=
+    (map_ne_zero_iff _ hinj).mpr (pow_ne_zero m hXa)
+  have hordr : (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) r) = 0 := by
+    by_contra hcon
+    exact hndvd (((ord_finitePlace_ne_zero_iff K (irreducible_X_sub_C a) hr0).mp) hcon)
+  calc (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) q)
+      = (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) ((X - C a) ^ m)
+          * algebraMap K[X] (RatFunc K) r) := by rw [← map_mul, ← hr]
+    _ = (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) ((X - C a) ^ m))
+          + (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) r) :=
+        (placeOfPoint K a).ord_mul hpow' hr0'
+    _ = (placeOfPoint K a).ord ((algebraMap K[X] (RatFunc K) (X - C a)) ^ (m : ℤ)) := by
+        rw [hordr, add_zero, map_pow, ← zpow_natCast]
+    _ = (m : ℤ) * (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) (X - C a)) :=
+        (placeOfPoint K a).ord_zpow _ _
+
+theorem dvd_ord_placeOfPoint (a : K) {f : RatFunc K} (hf : f ≠ 0) :
+    (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) (X - C a)) ∣ (placeOfPoint K a).ord f := by
+  have hinj := IsFractionRing.injective K[X] (RatFunc K)
+  have hnum : f.num ≠ 0 := RatFunc.num_ne_zero hf
+  have hden : f.denom ≠ 0 := f.denom_ne_zero
+  have hnum' : algebraMap K[X] (RatFunc K) f.num ≠ 0 := (map_ne_zero_iff _ hinj).mpr hnum
+  have hden' : algebraMap K[X] (RatFunc K) f.denom ≠ 0 := (map_ne_zero_iff _ hinj).mpr hden
+  have hsplit : f = algebraMap K[X] (RatFunc K) f.num
+      * (algebraMap K[X] (RatFunc K) f.denom)⁻¹ := by
+    rw [← div_eq_mul_inv, f.num_div_denom]
+  rw [hsplit, (placeOfPoint K a).ord_mul hnum' (inv_ne_zero hden'), Place.ord_inv,
+    ord_placeOfPoint_algebraMap_eq_mul a hnum, ord_placeOfPoint_algebraMap_eq_mul a hden]
+  exact dvd_add (Dvd.intro_left _ rfl) ((Dvd.intro_left _ rfl).neg_right)
+
+theorem ord_placeOfPoint_X_sub_C (a : K) :
+    (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) (X - C a)) = 1 := by
+  set v := placeOfPoint K a with hv
+  set n : ℤ := v.ord (algebraMap K[X] (RatFunc K) (X - C a)) with hn
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπ0 : (π : RatFunc K) ≠ 0 := by
+    simpa using hπ.ne_zero
+  have h1 : v.ord (π : RatFunc K) = 1 := v.ord_coe_irreducible hπ
+  have hdvd : n ∣ 1 := h1 ▸ dvd_ord_placeOfPoint a hπ0
+  have hmem : algebraMap K[X] (RatFunc K) (X - C a) ∈ v.toValuationSubring := by
+    rw [hv, placeOfPoint_eq_ofHeightOneSpectrum]
+    exact algebraMap_mem_ofHeightOneSpectrum K _ _
+  have hnonneg : 0 ≤ n := v.ord_nonneg_of_mem hmem
+  rcases Int.isUnit_iff.mp (isUnit_of_dvd_one hdvd) with h | h
+  · exact h
+  · omega
+
+theorem ord_placeOfPoint_algebraMap (a : K) {q : K[X]} (hq : q ≠ 0) :
+    (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) q) = rootMultiplicity a q := by
+  rw [ord_placeOfPoint_algebraMap_eq_mul a hq, ord_placeOfPoint_X_sub_C a, mul_one]
+
+variable (K)
+
+theorem exists_eq_placeOfPoint [IsAlgClosed K] (w : HeightOneSpectrum K[X]) :
+    ∃ a : K, Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w = placeOfPoint K a := by
+  obtain ⟨p, hp, hwp⟩ := exists_irreducible_span K w
+  have hdeg : p.degree ≠ 0 := by
+    rw [IsAlgClosed.degree_eq_one_of_irreducible K hp]
+    exact one_ne_zero
+  obtain ⟨a, ha⟩ := IsAlgClosed.exists_root p hdeg
+  refine ⟨a, ?_⟩
+  have hassoc : Associated ((X : K[X]) - C a) p :=
+    (irreducible_X_sub_C a).associated_of_dvd hp (dvd_iff_isRoot.mpr ha)
+  have hideal : w = heightOneSpectrumOfIrreducible K (irreducible_X_sub_C a) :=
+    HeightOneSpectrum.ext (by
+      rw [hwp, heightOneSpectrumOfIrreducible_asIdeal]
+      exact (Ideal.span_singleton_eq_span_singleton.mpr hassoc).symm)
+  rw [hideal, placeOfPoint_eq_ofHeightOneSpectrum]
+
+theorem eq_placeOfPoint_or_eq_placeInfty [IsAlgClosed K] [DecidableEq (RatFunc K)]
+    (v : Place K (RatFunc K)) :
+    (∃ a : K, v = placeOfPoint K a) ∨ v = placeInfty K := by
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, hw⟩ | hw
+  · obtain ⟨a, ha⟩ := exists_eq_placeOfPoint K w
+    exact Or.inl ⟨a, hw.trans ha⟩
+  · exact Or.inr hw
+
+private def ofOption [DecidableEq (RatFunc K)] : Option K → Place K (RatFunc K) :=
+  fun o => o.elim (placeInfty K) (placeOfPoint K)
+
+private theorem ofOption_bijective [IsAlgClosed K] [DecidableEq (RatFunc K)] :
+    Function.Bijective (ofOption K) := by
+  constructor
+  · rintro (_ | a) (_ | b) h
+    · rfl
+    · exact absurd h.symm (placeOfPoint_ne_placeInfty K b)
+    · exact absurd h (placeOfPoint_ne_placeInfty K a)
+    · exact congrArg some (placeOfPoint_injective K h)
+  · intro v
+    rcases eq_placeOfPoint_or_eq_placeInfty K v with ⟨a, ha⟩ | ha
+    · exact ⟨some a, ha.symm⟩
+    · exact ⟨none, ha.symm⟩
+
+def placeEquivOption [IsAlgClosed K] [DecidableEq (RatFunc K)] :
+    Place K (RatFunc K) ≃ Option K :=
+  (Equiv.ofBijective (ofOption K) (ofOption_bijective K)).symm
+
+@[scoped simp]
+theorem placeEquivOption_symm_some [IsAlgClosed K] [DecidableEq (RatFunc K)] (a : K) :
+    (placeEquivOption K).symm (some a) = placeOfPoint K a := rfl
+
+@[scoped simp]
+theorem placeEquivOption_symm_none [IsAlgClosed K] [DecidableEq (RatFunc K)] :
+    (placeEquivOption K).symm none = placeInfty K := rfl
+
+@[scoped simp]
+theorem placeEquivOption_placeOfPoint [IsAlgClosed K] [DecidableEq (RatFunc K)] (a : K) :
+    placeEquivOption K (placeOfPoint K a) = some a :=
+  (Equiv.ofBijective (ofOption K) (ofOption_bijective K)).symm_apply_apply (some a)
+
+@[scoped simp]
+theorem placeEquivOption_placeInfty [IsAlgClosed K] [DecidableEq (RatFunc K)] :
+    placeEquivOption K (placeInfty K) = none :=
+  (Equiv.ofBijective (ofOption K) (ofOption_bijective K)).symm_apply_apply none
+
+theorem deg_eq_one_of_isAlgClosed [IsAlgClosed K] (v : Place K (RatFunc K)) : v.deg = 1 := by
+  classical
+  rcases eq_placeOfPoint_or_eq_placeInfty K v with ⟨a, rfl⟩ | rfl
+  · exact deg_placeOfPoint K a
+  · exact deg_placeInfty K
+
+end RationalFunctionField
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "heightOneSpectrumOfIrreducible \
+  heightOneSpectrumOfIrreducible_asIdeal exists_irreducible_span finitePlace finitePlace_def \
+  algebraMap_mem_ofHeightOneSpectrum deg_finitePlace placeOfPoint \
+  placeOfPoint_eq_ofHeightOneSpectrum placeOfPoint_injective deg_placeOfPoint placeInfty \
+  placeInfty_toValuationSubring finite_setOf_ord_ne_zero degree_eq_zero_of_forall_eq_ord \
+  hasPrincipalDivisors ord_ofHeightOneSpectrum_of_span"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable {K : Type*} [Field K]
+
+theorem algebraMap_polynomial_ne_zero {q : K[X]} (hq : q ≠ 0) :
+    algebraMap K[X] (RatFunc K) q ≠ 0 :=
+  RatFunc.algebraMap_ne_zero hq
+
+theorem algebraMap_C (c : K) :
+    algebraMap K[X] (RatFunc K) (C c) = algebraMap K (RatFunc K) c := by
+  rw [IsScalarTower.algebraMap_apply K K[X] (RatFunc K), Polynomial.algebraMap_eq]
+
+theorem evalAt_placeOfPoint_algebraMap (a : K) (q : K[X]) :
+    (placeOfPoint K a).evalAt (algebraMap K[X] (RatFunc K) q) = q.eval a := by
+  have hmem : algebraMap K[X] (RatFunc K) q ∈ (placeOfPoint K a).toValuationSubring :=
+    algebraMap_mem_ofHeightOneSpectrum K _ q
+  have hmem' : algebraMap K (RatFunc K) (q.eval a) ∈ (placeOfPoint K a).toValuationSubring :=
+    (placeOfPoint K a).algebraMap_mem' _
+  have hsub : algebraMap K[X] (RatFunc K) q - algebraMap K (RatFunc K) (q.eval a)
+      = algebraMap K[X] (RatFunc K) (q - C (q.eval a)) := by
+    rw [map_sub, algebraMap_C]
+  have hcongr : (placeOfPoint K a).evalAt (algebraMap K[X] (RatFunc K) q)
+      = (placeOfPoint K a).evalAt (algebraMap K (RatFunc K) (q.eval a)) := by
+    refine Place.evalAt_congr _ hmem hmem' ?_
+    rw [hsub]
+    rcases eq_or_ne (q - C (q.eval a)) 0 with h0 | h0
+    · exact Or.inl (by rw [h0, map_zero])
+    · refine Or.inr ?_
+      rw [ord_placeOfPoint_algebraMap a h0]
+      have hroot : (q - C (q.eval a)).IsRoot a := by
+        simp [IsRoot.def]
+      exact_mod_cast (rootMultiplicity_pos h0).mpr hroot
+  rw [hcongr, Place.evalAt_algebraMap]
+
+theorem evalAt_placeOfPoint_X_sub_C (a b : K) :
+    (placeOfPoint K a).evalAt (algebraMap K[X] (RatFunc K) (X - C b)) = a - b := by
+  rw [evalAt_placeOfPoint_algebraMap]
+  simp
+
+section PlaceInfty
+
+variable [DecidableEq (RatFunc K)]
+
+theorem mem_placeInfty_of_intDegree_nonpos {f : RatFunc K} (hf : f ≠ 0)
+    (h : f.intDegree ≤ 0) : f ∈ (placeInfty K).toValuationSubring :=
+  (placeInfty K).mem_of_ord_nonneg hf (by rw [ord_placeInfty hf]; omega)
+
+theorem evalAt_placeInfty_eq {f : RatFunc K} {c : K}
+    (h : f - algebraMap K (RatFunc K) c = 0
+      ∨ (f - algebraMap K (RatFunc K) c).intDegree < 0) :
+    (placeInfty K).evalAt f = c := by
+  have hsubmem : f - algebraMap K (RatFunc K) c ∈ (placeInfty K).toValuationSubring := by
+    rcases h with h | h
+    · rw [h]; exact zero_mem _
+    · refine mem_placeInfty_of_intDegree_nonpos ?_ h.le
+      intro h0
+      rw [h0] at h
+      simp [RatFunc.intDegree_zero] at h
+  have hmem : f ∈ (placeInfty K).toValuationSubring := by
+    have : f = (f - algebraMap K (RatFunc K) c) + algebraMap K (RatFunc K) c := by ring
+    rw [this]
+    exact add_mem hsubmem ((placeInfty K).algebraMap_mem' c)
+  have hcongr : (placeInfty K).evalAt f
+      = (placeInfty K).evalAt (algebraMap K (RatFunc K) c) := by
+    refine Place.evalAt_congr _ hmem ((placeInfty K).algebraMap_mem' c) ?_
+    rcases h with h | h
+    · exact Or.inl h
+    · refine Or.inr ?_
+      have hne : f - algebraMap K (RatFunc K) c ≠ 0 := by
+        intro h0
+        rw [h0] at h
+        simp [RatFunc.intDegree_zero] at h
+      rw [ord_placeInfty hne]
+      omega
+  rw [hcongr, Place.evalAt_algebraMap]
+
+theorem evalAt_placeInfty_X_sub_C_div (a a₀ : K) :
+    (placeInfty K).evalAt
+        (algebraMap K[X] (RatFunc K) (X - C a) / algebraMap K[X] (RatFunc K) (X - C a₀))
+      = 1 := by
+  have ha₀ : algebraMap K[X] (RatFunc K) (X - C a₀) ≠ 0 :=
+    algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a₀)
+  refine evalAt_placeInfty_eq ?_
+  have hkey : algebraMap K[X] (RatFunc K) (X - C a) / algebraMap K[X] (RatFunc K) (X - C a₀)
+        - algebraMap K (RatFunc K) 1
+      = algebraMap K[X] (RatFunc K) (C (a₀ - a)) / algebraMap K[X] (RatFunc K) (X - C a₀) := by
+    rw [map_one, div_sub_one ha₀, ← map_sub]
+    congr 2
+    rw [map_sub]
+    ring
+  rw [hkey]
+  rcases eq_or_ne a₀ a with rfl | hne
+  · exact Or.inl (by simp)
+  · refine Or.inr ?_
+    have hC : (C (a₀ - a) : K[X]) ≠ 0 := by
+      simpa [sub_eq_zero] using hne
+    rw [RatFunc.intDegree_div (algebraMap_polynomial_ne_zero hC) ha₀,
+      RatFunc.intDegree_polynomial, RatFunc.intDegree_polynomial, natDegree_C,
+      natDegree_X_sub_C]
+    norm_num
+
+end PlaceInfty
+
+section CrossRatio
+
+variable [DecidableEq (RatFunc K)]
+
+theorem principalDivisor_X_sub_C (b : K) :
+    principalDivisor (algebraMap_polynomial_ne_zero (X_sub_C_ne_zero b))
+      = Finsupp.single (placeOfPoint K b) 1 + Finsupp.single (placeInfty K) (-1) := by
+  ext v
+  have h := single_add_single_apply_eq_ord (irreducible_X_sub_C b) v
+  rw [natDegree_X_sub_C, Nat.cast_one] at h
+  rw [principalDivisor_apply, ← h]
+  rfl
+
+theorem ord_X_sub_C (b : K) (v : Place K (RatFunc K)) :
+    v.ord (algebraMap K[X] (RatFunc K) (X - C b))
+      = (Finsupp.single (placeOfPoint K b) (1 : ℤ)
+          + Finsupp.single (placeInfty K) (-1 : ℤ)) v := by
+  rw [← principalDivisor_X_sub_C b, principalDivisor_apply]
+
+omit [DecidableEq (RatFunc K)] in
+theorem ord_X_sub_C_placeOfPoint_of_ne {a b : K} (hab : a ≠ b) :
+    (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) (X - C b)) = 0 := by
+  classical
+  rw [ord_X_sub_C, Finsupp.add_apply,
+    Finsupp.single_eq_of_ne
+      (show placeOfPoint K a ≠ placeOfPoint K b from
+        fun h => hab (placeOfPoint_injective K h)),
+    Finsupp.single_eq_of_ne (placeOfPoint_ne_placeInfty K a), add_zero]
+
+omit [DecidableEq (RatFunc K)] in
+theorem ord_X_sub_C_placeOfPoint_self (b : K) :
+    (placeOfPoint K b).ord (algebraMap K[X] (RatFunc K) (X - C b)) = 1 := by
+  classical
+  rw [ord_X_sub_C, Finsupp.add_apply, Finsupp.single_eq_same,
+    Finsupp.single_eq_of_ne (placeOfPoint_ne_placeInfty K b), add_zero]
+
+theorem ord_X_sub_C_placeInfty (b : K) :
+    (placeInfty K).ord (algebraMap K[X] (RatFunc K) (X - C b)) = -1 := by
+  rw [ord_X_sub_C, Finsupp.add_apply,
+    Finsupp.single_eq_of_ne (Ne.symm (placeOfPoint_ne_placeInfty K b)),
+    Finsupp.single_eq_same, zero_add]
+
+omit [DecidableEq (RatFunc K)] in
+theorem isRational_placeOfPoint (a : K) : (placeOfPoint K a).IsRational :=
+  Place.isRational_of_deg_eq_one _ (deg_placeOfPoint K a)
+
+omit [DecidableEq (RatFunc K)] in
+theorem principalDivisor_X_sub_C_div (a a₀ : K) :
+    principalDivisor (div_ne_zero (algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a))
+        (algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a₀)))
+      = Finsupp.single (placeOfPoint K a) 1 + Finsupp.single (placeOfPoint K a₀) (-1) := by
+  classical
+  have hLa : algebraMap K[X] (RatFunc K) (X - C a) ≠ 0 :=
+    algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a)
+  have hLa₀ : algebraMap K[X] (RatFunc K) (X - C a₀) ≠ 0 :=
+    algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a₀)
+  ext v
+  have hneg : (Finsupp.single (placeOfPoint K a₀) (-1 : ℤ)) v
+      = -((Finsupp.single (placeOfPoint K a₀) (1 : ℤ)) v) := by
+    rcases eq_or_ne v (placeOfPoint K a₀) with rfl | h
+    · rw [Finsupp.single_eq_same, Finsupp.single_eq_same]
+    · rw [Finsupp.single_eq_of_ne h, Finsupp.single_eq_of_ne h, neg_zero]
+  rw [principalDivisor_apply, div_eq_mul_inv, v.ord_mul hLa (inv_ne_zero hLa₀), v.ord_inv,
+    ord_X_sub_C a v, ord_X_sub_C a₀ v]
+  simp only [Finsupp.add_apply]
+  rw [hneg]
+  ring
+
+omit [DecidableEq (RatFunc K)] in
+theorem evalAt_placeOfPoint_X_sub_C_div (a a₀ : K) {b : K} (hba₀ : b ≠ a₀) :
+    (placeOfPoint K b).evalAt
+        (algebraMap K[X] (RatFunc K) (X - C a) / algebraMap K[X] (RatFunc K) (X - C a₀))
+      = (b - a) / (b - a₀) := by
+  classical
+  have hLa₀ : algebraMap K[X] (RatFunc K) (X - C a₀) ≠ 0 :=
+    algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a₀)
+  have hord : (placeOfPoint K b).ord (algebraMap K[X] (RatFunc K) (X - C a₀)) = 0 :=
+    ord_X_sub_C_placeOfPoint_of_ne hba₀
+  rw [div_eq_mul_inv, (placeOfPoint K b).evalAt_mul (isRational_placeOfPoint b)
+      (algebraMap_mem_ofHeightOneSpectrum K _ _)
+      ((placeOfPoint K b).mem_of_ord_nonneg (inv_ne_zero hLa₀)
+        (by rw [Place.ord_inv, hord, neg_zero])),
+    (placeOfPoint K b).evalAt_inv (isRational_placeOfPoint b) hLa₀ hord,
+    evalAt_placeOfPoint_X_sub_C, evalAt_placeOfPoint_X_sub_C, div_eq_mul_inv]
+
+end CrossRatio
+
+section Reciprocity
+
+variable [IsAlgClosed K] [DecidableEq (RatFunc K)]
+
+omit [DecidableEq (RatFunc K)] in
+theorem isRational_of_isAlgClosed (v : Place K (RatFunc K)) : v.IsRational :=
+  Place.isRational_of_deg_eq_one v (deg_eq_one_of_isAlgClosed K v)
+
+omit [IsAlgClosed K] [DecidableEq (RatFunc K)] in
+theorem algebraMap_const_ne_zero {c : K} (hc : c ≠ 0) : algebraMap K (RatFunc K) c ≠ 0 := by
+  simpa using hc
+
+local instance : DecidableEq (Place K (RatFunc K)) := Classical.decEq _
+
+omit [IsAlgClosed K] [DecidableEq (RatFunc K)] in
+theorem ord_ne_zero_of_mem_support {g : RatFunc K} (hg : g ≠ 0) {v : Place K (RatFunc K)}
+    (hv : v ∈ (principalDivisor hg).support) : v.ord g ≠ 0 := by
+  rwa [Finsupp.mem_support_iff, principalDivisor_apply] at hv
+
+omit [DecidableEq (RatFunc K)] in
+theorem sum_ord_eq_zero {f : RatFunc K} (hf : f ≠ 0) :
+    ∑ v ∈ (principalDivisor hf).support, v.ord f = 0 := by
+  rw [← sum_ord_mul_deg_eq_zero hf]
+  exact Finset.sum_congr rfl fun v _ => by
+    rw [deg_eq_one_of_isAlgClosed K v, Nat.cast_one, mul_one]
+
+omit [IsAlgClosed K] [DecidableEq (RatFunc K)] in
+theorem zpow_sum_eq_prod {c : K} (hc : c ≠ 0) {ι : Type*} (s : Finset ι) (n : ι → ℤ) :
+    ∏ i ∈ s, c ^ n i = c ^ (∑ i ∈ s, n i) := by
+  induction s using Finset.cons_induction with
+  | empty => simp
+  | cons a s ha ih => rw [Finset.prod_cons, Finset.sum_cons, zpow_add₀ hc, ih]
+
+omit [IsAlgClosed K] [DecidableEq (RatFunc K)] in
+theorem principalDivisor_congr {f g : RatFunc K} (hf : f ≠ 0) (hg : g ≠ 0) (h : f = g) :
+    principalDivisor hf = principalDivisor hg := by
+  subst h
+  rfl
+
+omit [DecidableEq (RatFunc K)] in
+theorem reciprocity_algebraMap_right {f : RatFunc K} (hf : f ≠ 0) {c : K} (hc : c ≠ 0) :
+    Divisor.evalFun f (principalDivisor (algebraMap_const_ne_zero hc))
+      = Divisor.evalFun (algebraMap K (RatFunc K) c) (principalDivisor hf) := by
+  have hzero : principalDivisor (algebraMap_const_ne_zero hc) = 0 := by
+    ext v
+    rw [principalDivisor_apply, v.ord_algebraMap, Finsupp.coe_zero, Pi.zero_apply]
+  rw [hzero, Divisor.evalFun_zero, Divisor.evalFun_def]
+  rw [Finset.prod_congr rfl fun v _ => by rw [Place.evalAt_algebraMap],
+    zpow_sum_eq_prod hc]
+  rw [show ∑ v ∈ (principalDivisor hf).support, principalDivisor hf v
+      = ∑ v ∈ (principalDivisor hf).support, v.ord f from
+    Finset.sum_congr rfl fun v _ => principalDivisor_apply hf v, sum_ord_eq_zero hf,
+    zpow_zero]
+
+omit [DecidableEq (RatFunc K)] in
+theorem reciprocity_mul_right {f g₁ g₂ : RatFunc K} (hf : f ≠ 0) (hg₁ : g₁ ≠ 0) (hg₂ : g₂ ≠ 0)
+    (hd₁ : ∀ v : Place K (RatFunc K), v.ord f = 0 ∨ v.ord g₁ = 0)
+    (hd₂ : ∀ v : Place K (RatFunc K), v.ord f = 0 ∨ v.ord g₂ = 0)
+    (h₁ : Divisor.evalFun f (principalDivisor hg₁) = Divisor.evalFun g₁ (principalDivisor hf))
+    (h₂ : Divisor.evalFun f (principalDivisor hg₂)
+      = Divisor.evalFun g₂ (principalDivisor hf)) :
+    Divisor.evalFun f (principalDivisor (mul_ne_zero hg₁ hg₂))
+      = Divisor.evalFun (g₁ * g₂) (principalDivisor hf) := by
+  have hsplit : principalDivisor (mul_ne_zero hg₁ hg₂)
+      = principalDivisor hg₁ + principalDivisor hg₂ := by
+    ext v
+    rw [principalDivisor_apply, Finsupp.add_apply, principalDivisor_apply,
+      principalDivisor_apply, v.ord_mul hg₁ hg₂]
+  rw [hsplit,
+    Divisor.evalFun_add f
+      (fun v hv => v.evalAt_ne_zero (isRational_of_isAlgClosed v) hf
+        ((hd₁ v).resolve_right (ord_ne_zero_of_mem_support hg₁ hv)))
+      (fun v hv => v.evalAt_ne_zero (isRational_of_isAlgClosed v) hf
+        ((hd₂ v).resolve_right (ord_ne_zero_of_mem_support hg₂ hv))),
+    h₁, h₂,
+    ← Divisor.evalFun_mul (fun v _ => isRational_of_isAlgClosed v)
+      (fun v hv => v.mem_of_ord_nonneg hg₁
+        ((hd₁ v).resolve_left (ord_ne_zero_of_mem_support hf hv)).ge)
+      (fun v hv => v.mem_of_ord_nonneg hg₂
+        ((hd₂ v).resolve_left (ord_ne_zero_of_mem_support hf hv)).ge)]
+
+omit [DecidableEq (RatFunc K)] in
+theorem reciprocity_mul_left {f₁ f₂ g : RatFunc K} (hf₁ : f₁ ≠ 0) (hf₂ : f₂ ≠ 0) (hg : g ≠ 0)
+    (hd₁ : ∀ v : Place K (RatFunc K), v.ord f₁ = 0 ∨ v.ord g = 0)
+    (hd₂ : ∀ v : Place K (RatFunc K), v.ord f₂ = 0 ∨ v.ord g = 0)
+    (h₁ : Divisor.evalFun f₁ (principalDivisor hg) = Divisor.evalFun g (principalDivisor hf₁))
+    (h₂ : Divisor.evalFun f₂ (principalDivisor hg)
+      = Divisor.evalFun g (principalDivisor hf₂)) :
+    Divisor.evalFun (f₁ * f₂) (principalDivisor hg)
+      = Divisor.evalFun g (principalDivisor (mul_ne_zero hf₁ hf₂)) :=
+  (reciprocity_mul_right hg hf₁ hf₂ (fun v => (hd₁ v).symm) (fun v => (hd₂ v).symm)
+    h₁.symm h₂.symm).symm
+
+omit [DecidableEq (RatFunc K)] in
+theorem reciprocity_zpow_right {f g : RatFunc K} (hf : f ≠ 0) (hg : g ≠ 0) (n : ℤ)
+    (hd : ∀ v : Place K (RatFunc K), v.ord f = 0 ∨ v.ord g = 0)
+    (h : Divisor.evalFun f (principalDivisor hg)
+      = Divisor.evalFun g (principalDivisor hf)) :
+    Divisor.evalFun f (principalDivisor (zpow_ne_zero n hg))
+      = Divisor.evalFun (g ^ n) (principalDivisor hf) := by
+  have hsplit : principalDivisor (zpow_ne_zero n hg) = n • principalDivisor hg := by
+    ext v
+    rw [principalDivisor_apply, Finsupp.smul_apply, principalDivisor_apply, v.ord_zpow,
+      smul_eq_mul]
+  rw [hsplit, Divisor.evalFun_zsmul, h,
+    ← Divisor.evalFun_zpow_left hg n (fun v _ => isRational_of_isAlgClosed v)
+      (fun v hv => (hd v).resolve_left (ord_ne_zero_of_mem_support hf hv))]
+
+omit [DecidableEq (RatFunc K)] in
+theorem reciprocity_zpow_left {f g : RatFunc K} (hf : f ≠ 0) (hg : g ≠ 0) (n : ℤ)
+    (hd : ∀ v : Place K (RatFunc K), v.ord f = 0 ∨ v.ord g = 0)
+    (h : Divisor.evalFun f (principalDivisor hg)
+      = Divisor.evalFun g (principalDivisor hf)) :
+    Divisor.evalFun (f ^ n) (principalDivisor hg)
+      = Divisor.evalFun g (principalDivisor (zpow_ne_zero n hf)) :=
+  (reciprocity_zpow_right hg hf n (fun v => (hd v).symm) h.symm).symm
+
+omit [IsAlgClosed K] [DecidableEq (RatFunc K)] in
+theorem exists_algebraMap_of_forall_ord_eq_zero {g : RatFunc K} (hg : g ≠ 0)
+    (h : ∀ v : Place K (RatFunc K), v.ord g = 0) :
+    ∃ c : K, c ≠ 0 ∧ g = algebraMap K (RatFunc K) c := by
+  have hnum0 : g.num ≠ 0 := RatFunc.num_ne_zero hg
+  have hden0 : g.denom ≠ 0 := g.denom_ne_zero
+  have hnum0' : algebraMap K[X] (RatFunc K) g.num ≠ 0 := algebraMap_polynomial_ne_zero hnum0
+  have hden0' : algebraMap K[X] (RatFunc K) g.denom ≠ 0 := algebraMap_polynomial_ne_zero hden0
+  have hsplit : g = algebraMap K[X] (RatFunc K) g.num
+      * (algebraMap K[X] (RatFunc K) g.denom)⁻¹ := by
+    rw [← div_eq_mul_inv, g.num_div_denom]
+  have hkey : ∀ p : K[X], Irreducible p → ¬p ∣ g.num ∧ ¬p ∣ g.denom := by
+    intro p hpirr
+    have hord : (finitePlace K hpirr).ord (algebraMap K[X] (RatFunc K) g.num)
+        = (finitePlace K hpirr).ord (algebraMap K[X] (RatFunc K) g.denom) := by
+      have h0 := h (finitePlace K hpirr)
+      rw [hsplit, (finitePlace K hpirr).ord_mul hnum0' (inv_ne_zero hden0'),
+        Place.ord_inv] at h0
+      omega
+    constructor
+    · intro hdvd
+      refine hpirr.not_isUnit (g.isCoprime_num_denom.isUnit_of_dvd' hdvd ?_)
+      refine (ord_finitePlace_ne_zero_iff K hpirr hden0).mp ?_
+      rw [← hord]
+      exact (ord_finitePlace_ne_zero_iff K hpirr hnum0).mpr hdvd
+    · intro hdvd
+      refine hpirr.not_isUnit (g.isCoprime_num_denom.isUnit_of_dvd' ?_ hdvd)
+      refine (ord_finitePlace_ne_zero_iff K hpirr hnum0).mp ?_
+      rw [hord]
+      exact (ord_finitePlace_ne_zero_iff K hpirr hden0).mpr hdvd
+  have hunit : ∀ q : K[X], q ≠ 0 → (∀ p : K[X], Irreducible p → ¬p ∣ q) → IsUnit q := by
+    intro q hq hp
+    by_contra hu
+    obtain ⟨p, hpirr, hpdvd⟩ := WfDvdMonoid.exists_irreducible_factor hu hq
+    exact hp p hpirr hpdvd
+  obtain ⟨c₁, hc₁u, hc₁⟩ :=
+    Polynomial.isUnit_iff.mp (hunit g.num hnum0 fun p hp => (hkey p hp).1)
+  obtain ⟨c₂, hc₂u, hc₂⟩ :=
+    Polynomial.isUnit_iff.mp (hunit g.denom hden0 fun p hp => (hkey p hp).2)
+  have hc₁0 : c₁ ≠ 0 := fun h0 => hnum0 (by rw [← hc₁, h0, map_zero])
+  have hc₂0 : c₂ ≠ 0 := fun h0 => hden0 (by rw [← hc₂, h0, map_zero])
+  refine ⟨c₁ / c₂, div_ne_zero hc₁0 hc₂0, ?_⟩
+  rw [← g.num_div_denom, ← hc₁, ← hc₂, algebraMap_C, algebraMap_C, map_div₀]
+
+omit [IsAlgClosed K] in
+omit [DecidableEq (RatFunc K)] in
+theorem crossRatio_reciprocity {a a₀ b : K} (hba : b ≠ a) (hba₀ : b ≠ a₀) :
+    Divisor.evalFun
+        (algebraMap K[X] (RatFunc K) (X - C a) / algebraMap K[X] (RatFunc K) (X - C a₀))
+        (principalDivisor (algebraMap_polynomial_ne_zero (X_sub_C_ne_zero b)))
+      = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b))
+        (principalDivisor (div_ne_zero (algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a))
+          (algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a₀)))) := by
+  classical
+  rw [principalDivisor_X_sub_C b, principalDivisor_X_sub_C_div a a₀,
+    Divisor.evalFun_single_sub_single _
+      (by rw [evalAt_placeOfPoint_X_sub_C_div a a₀ hba₀]
+          exact div_ne_zero (sub_ne_zero.mpr hba) (sub_ne_zero.mpr hba₀))
+      (by rw [evalAt_placeInfty_X_sub_C_div a a₀]; exact one_ne_zero),
+    Divisor.evalFun_single_sub_single _
+      (by rw [evalAt_placeOfPoint_X_sub_C]
+          exact sub_ne_zero.mpr fun h => hba h.symm)
+      (by rw [evalAt_placeOfPoint_X_sub_C]
+          exact sub_ne_zero.mpr fun h => hba₀ h.symm),
+    evalAt_placeOfPoint_X_sub_C_div a a₀ hba₀, evalAt_placeInfty_X_sub_C_div a a₀,
+    evalAt_placeOfPoint_X_sub_C, evalAt_placeOfPoint_X_sub_C, div_one]
+  rw [div_eq_div_iff (sub_ne_zero.mpr hba₀) (sub_ne_zero.mpr fun h => hba₀ h.symm)]
+  ring
+
+omit [DecidableEq (RatFunc K)] in
+theorem reciprocity_of_forall_ord_eq_zero {f g : RatFunc K} (hf : f ≠ 0) (hg : g ≠ 0)
+    (hzero : ∀ v : Place K (RatFunc K), v.ord g = 0) :
+    Divisor.evalFun f (principalDivisor hg) = Divisor.evalFun g (principalDivisor hf) := by
+  obtain ⟨c, hc, rfl⟩ := exists_algebraMap_of_forall_ord_eq_zero hg hzero
+  exact reciprocity_algebraMap_right hf hc
+
+omit [IsAlgClosed K] [DecidableEq (RatFunc K)] in
+theorem ord_div_zpow (v : Place K (RatFunc K)) {g h : RatFunc K} (hg : g ≠ 0) (hh : h ≠ 0)
+    (m : ℤ) : v.ord (g / h ^ m) = v.ord g - m * v.ord h := by
+  rw [div_eq_mul_inv, v.ord_mul hg (inv_ne_zero (zpow_ne_zero m hh)), v.ord_inv, v.ord_zpow,
+    sub_eq_add_neg]
+
+omit [IsAlgClosed K] in
+theorem ord_X_sub_C_eq_zero_of_ne (b : K) {v : Place K (RatFunc K)}
+    (hvb : v ≠ placeOfPoint K b) (hvinf : v ≠ placeInfty K) :
+    v.ord (algebraMap K[X] (RatFunc K) (X - C b)) = 0 := by
+  rw [ord_X_sub_C b v, Finsupp.add_apply, Finsupp.single_eq_of_ne hvb,
+    Finsupp.single_eq_of_ne hvinf, add_zero]
+
+theorem reciprocity_linear (b : K) :
+    ∀ (n : ℕ) (f : RatFunc K) (hf : f ≠ 0),
+      (placeInfty K).ord f = 0 → (placeOfPoint K b).ord f = 0 →
+      (principalDivisor hf).support.card ≤ n →
+      Divisor.evalFun f
+          (principalDivisor (algebraMap_polynomial_ne_zero (X_sub_C_ne_zero b)))
+        = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b)) (principalDivisor hf) := by
+  have hLb : algebraMap K[X] (RatFunc K) (X - C b) ≠ 0 :=
+    algebraMap_polynomial_ne_zero (X_sub_C_ne_zero b)
+  intro n
+  induction n with
+  | zero =>
+    intro f hf hinf hb hcard
+    refine (reciprocity_of_forall_ord_eq_zero hLb hf fun v => ?_).symm
+    rw [← principalDivisor_apply hf v,
+      Finsupp.support_eq_empty.mp (Finset.card_eq_zero.mp (Nat.le_zero.mp hcard))]
+    rfl
+  | succ n ih =>
+    intro f hf hinf hb hcard
+    rcases Finset.eq_empty_or_nonempty (principalDivisor hf).support with hempty | hne
+    · refine (reciprocity_of_forall_ord_eq_zero hLb hf fun v => ?_).symm
+      rw [← principalDivisor_apply hf v, Finsupp.support_eq_empty.mp hempty]
+      rfl
+    have hsum := sum_ord_eq_zero hf
+    have hexpos : ∃ v ∈ (principalDivisor hf).support, 0 < v.ord f := by
+      by_contra hcon
+      have hcon' : ∀ v ∈ (principalDivisor hf).support, v.ord f ≤ 0 := fun v hv => by
+        by_contra hgt
+        exact hcon ⟨v, hv, not_le.mp hgt⟩
+      have hlt : ∑ v ∈ (principalDivisor hf).support, v.ord f
+          < ∑ v ∈ (principalDivisor hf).support, (0 : ℤ) :=
+        Finset.sum_lt_sum_of_nonempty hne fun v hv =>
+          lt_of_le_of_ne (hcon' v hv) (ord_ne_zero_of_mem_support hf hv)
+      rw [Finset.sum_const_zero, hsum] at hlt
+      exact lt_irrefl 0 hlt
+    have hexneg : ∃ v ∈ (principalDivisor hf).support, v.ord f < 0 := by
+      by_contra hcon
+      have hcon' : ∀ v ∈ (principalDivisor hf).support, 0 ≤ v.ord f := fun v hv => by
+        by_contra hgt
+        exact hcon ⟨v, hv, not_le.mp hgt⟩
+      have hlt : ∑ v ∈ (principalDivisor hf).support, (0 : ℤ)
+          < ∑ v ∈ (principalDivisor hf).support, v.ord f :=
+        Finset.sum_lt_sum_of_nonempty hne fun v hv =>
+          lt_of_le_of_ne (hcon' v hv) (Ne.symm (ord_ne_zero_of_mem_support hf hv))
+      rw [Finset.sum_const_zero, hsum] at hlt
+      exact lt_irrefl 0 hlt
+    obtain ⟨vp, hvp_mem, hvp⟩ := hexpos
+    obtain ⟨vn, hvn_mem, hvn⟩ := hexneg
+    obtain ⟨a, rfl⟩ : ∃ x : K, vp = placeOfPoint K x := by
+      rcases eq_placeOfPoint_or_eq_placeInfty K vp with h | h
+      · exact h
+      · rw [h, hinf] at hvp
+        exact absurd hvp (lt_irrefl 0)
+    obtain ⟨a₀, rfl⟩ : ∃ x : K, vn = placeOfPoint K x := by
+      rcases eq_placeOfPoint_or_eq_placeInfty K vn with h | h
+      · exact h
+      · rw [h, hinf] at hvn
+        exact absurd hvn (lt_irrefl 0)
+    have hab : a ≠ b := by
+      rintro rfl
+      rw [hb] at hvp
+      exact lt_irrefl 0 hvp
+    have ha₀b : a₀ ≠ b := by
+      rintro rfl
+      rw [hb] at hvn
+      exact lt_irrefl 0 hvn
+    have haa₀ : placeOfPoint K a ≠ placeOfPoint K a₀ := by
+      intro h
+      rw [h] at hvp
+      omega
+    have hLa : algebraMap K[X] (RatFunc K) (X - C a) ≠ 0 :=
+      algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a)
+    have hLa₀ : algebraMap K[X] (RatFunc K) (X - C a₀) ≠ 0 :=
+      algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a₀)
+    have hrne : algebraMap K[X] (RatFunc K) (X - C a) / algebraMap K[X] (RatFunc K) (X - C a₀)
+        ≠ 0 := div_ne_zero hLa hLa₀
+    have hord_r : ∀ v : Place K (RatFunc K),
+        v.ord (algebraMap K[X] (RatFunc K) (X - C a) / algebraMap K[X] (RatFunc K) (X - C a₀))
+          = (Finsupp.single (placeOfPoint K a) (1 : ℤ)
+              + Finsupp.single (placeOfPoint K a₀) (-1 : ℤ)) v := fun v => by
+      rw [← principalDivisor_apply hrne v, principalDivisor_X_sub_C_div a a₀]
+    set m : ℤ := (placeOfPoint K a).ord f with hm
+    have hrm_ne : (algebraMap K[X] (RatFunc K) (X - C a)
+        / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m ≠ 0 := zpow_ne_zero m hrne
+    have hf' : f / (algebraMap K[X] (RatFunc K) (X - C a)
+        / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m ≠ 0 := div_ne_zero hf hrm_ne
+    have hord_f' : ∀ v : Place K (RatFunc K),
+        v.ord (f / (algebraMap K[X] (RatFunc K) (X - C a)
+            / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m)
+          = v.ord f - m * (Finsupp.single (placeOfPoint K a) (1 : ℤ)
+              + Finsupp.single (placeOfPoint K a₀) (-1 : ℤ)) v := fun v => by
+      rw [ord_div_zpow v hf hrne m, hord_r v]
+    have hf'_inf : (placeInfty K).ord (f / (algebraMap K[X] (RatFunc K) (X - C a)
+        / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m) = 0 := by
+      rw [hord_f', hinf, Finsupp.add_apply,
+        Finsupp.single_eq_of_ne (Ne.symm (placeOfPoint_ne_placeInfty K a)),
+        Finsupp.single_eq_of_ne (Ne.symm (placeOfPoint_ne_placeInfty K a₀))]
+      ring
+    have hf'_b : (placeOfPoint K b).ord (f / (algebraMap K[X] (RatFunc K) (X - C a)
+        / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m) = 0 := by
+      rw [hord_f', hb, Finsupp.add_apply,
+        Finsupp.single_eq_of_ne
+          (show placeOfPoint K b ≠ placeOfPoint K a from
+            fun h => hab (placeOfPoint_injective K h).symm),
+        Finsupp.single_eq_of_ne
+          (show placeOfPoint K b ≠ placeOfPoint K a₀ from
+            fun h => ha₀b (placeOfPoint_injective K h).symm)]
+      ring
+    have hf'_a : (placeOfPoint K a).ord (f / (algebraMap K[X] (RatFunc K) (X - C a)
+        / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m) = 0 := by
+      rw [hord_f', Finsupp.add_apply, Finsupp.single_eq_same,
+        Finsupp.single_eq_of_ne haa₀, ← hm]
+      ring
+    have hsupp' : (principalDivisor hf').support
+        ⊆ (principalDivisor hf).support.erase (placeOfPoint K a) := by
+      intro v hv
+      have hvord := ord_ne_zero_of_mem_support hf' hv
+      rw [Finset.mem_erase]
+      constructor
+      · rintro rfl
+        exact hvord hf'_a
+      · rw [Finsupp.mem_support_iff, principalDivisor_apply]
+        intro hvf
+        apply hvord
+        rw [hord_f' v, hvf, Finsupp.add_apply]
+        rcases eq_or_ne v (placeOfPoint K a) with rfl | hva
+        · rw [hf'_a] at hvord
+          exact absurd rfl hvord
+        rcases eq_or_ne v (placeOfPoint K a₀) with rfl | hva₀
+        · rw [hvf] at hvn
+          exact absurd hvn (lt_irrefl 0)
+        · rw [Finsupp.single_eq_of_ne hva, Finsupp.single_eq_of_ne hva₀]
+          ring
+    have hcard' : (principalDivisor hf').support.card ≤ n := by
+      have h1 := Finset.card_le_card hsupp'
+      rw [Finset.card_erase_of_mem hvp_mem] at h1
+      omega
+    have hd_r_Lb : ∀ v : Place K (RatFunc K),
+        v.ord (algebraMap K[X] (RatFunc K) (X - C a)
+            / algebraMap K[X] (RatFunc K) (X - C a₀)) = 0
+          ∨ v.ord (algebraMap K[X] (RatFunc K) (X - C b)) = 0 := by
+      intro v
+      rcases eq_or_ne v (placeOfPoint K a) with rfl | hva
+      · exact Or.inr (ord_X_sub_C_placeOfPoint_of_ne hab)
+      rcases eq_or_ne v (placeOfPoint K a₀) with rfl | hva₀
+      · exact Or.inr (ord_X_sub_C_placeOfPoint_of_ne ha₀b)
+      · refine Or.inl ?_
+        rw [hord_r v, Finsupp.add_apply, Finsupp.single_eq_of_ne hva,
+          Finsupp.single_eq_of_ne hva₀]
+        ring
+    have hd_rm_Lb : ∀ v : Place K (RatFunc K),
+        v.ord ((algebraMap K[X] (RatFunc K) (X - C a)
+            / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m) = 0
+          ∨ v.ord (algebraMap K[X] (RatFunc K) (X - C b)) = 0 := fun v =>
+      (hd_r_Lb v).imp_left fun h => by rw [v.ord_zpow, h, mul_zero]
+    have hd_f'_Lb : ∀ v : Place K (RatFunc K),
+        v.ord (f / (algebraMap K[X] (RatFunc K) (X - C a)
+            / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m) = 0
+          ∨ v.ord (algebraMap K[X] (RatFunc K) (X - C b)) = 0 := by
+      intro v
+      rcases eq_or_ne v (placeOfPoint K b) with rfl | hvb
+      · exact Or.inl hf'_b
+      rcases eq_or_ne v (placeInfty K) with rfl | hvinf
+      · exact Or.inl hf'_inf
+      · exact Or.inr (ord_X_sub_C_eq_zero_of_ne b hvb hvinf)
+    have hcross_pow :
+        Divisor.evalFun ((algebraMap K[X] (RatFunc K) (X - C a)
+            / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m)
+          (principalDivisor hLb)
+        = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b))
+            (principalDivisor (zpow_ne_zero m hrne)) :=
+      reciprocity_zpow_left hrne hLb m hd_r_Lb
+        (crossRatio_reciprocity (fun h => hab h.symm) (fun h => ha₀b h.symm))
+    have hih :
+        Divisor.evalFun (f / (algebraMap K[X] (RatFunc K) (X - C a)
+            / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m)
+          (principalDivisor hLb)
+        = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b)) (principalDivisor hf') :=
+      ih _ hf' hf'_inf hf'_b hcard'
+    have hmul :
+        Divisor.evalFun ((algebraMap K[X] (RatFunc K) (X - C a)
+              / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m
+            * (f / (algebraMap K[X] (RatFunc K) (X - C a)
+              / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m))
+          (principalDivisor hLb)
+        = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b))
+            (principalDivisor (mul_ne_zero (zpow_ne_zero m hrne) hf')) :=
+      reciprocity_mul_left (zpow_ne_zero m hrne) hf' hLb hd_rm_Lb hd_f'_Lb hcross_pow hih
+    have hfeq : f = (algebraMap K[X] (RatFunc K) (X - C a)
+        / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m
+        * (f / (algebraMap K[X] (RatFunc K) (X - C a)
+          / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m) := by
+      rw [mul_comm, div_mul_cancel₀ _ hrm_ne]
+    calc Divisor.evalFun f (principalDivisor hLb)
+        = Divisor.evalFun ((algebraMap K[X] (RatFunc K) (X - C a)
+              / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m
+            * (f / (algebraMap K[X] (RatFunc K) (X - C a)
+              / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m))
+          (principalDivisor hLb) := by rw [← hfeq]
+      _ = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b))
+            (principalDivisor (mul_ne_zero (zpow_ne_zero m hrne) hf')) := hmul
+      _ = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b)) (principalDivisor hf) := by
+          rw [principalDivisor_congr (mul_ne_zero (zpow_ne_zero m hrne) hf') hf hfeq.symm]
+
+theorem reciprocity_of_ord_placeInfty_eq_zero :
+    ∀ (n : ℕ) (f g : RatFunc K) (hf : f ≠ 0) (hg : g ≠ 0),
+      (placeInfty K).ord f = 0 →
+      (∀ v : Place K (RatFunc K), v.ord f = 0 ∨ v.ord g = 0) →
+      ((principalDivisor hg).support.erase (placeInfty K)).card ≤ n →
+      Divisor.evalFun f (principalDivisor hg) = Divisor.evalFun g (principalDivisor hf) := by
+  have hbase : ∀ (f g : RatFunc K) (hf : f ≠ 0) (hg : g ≠ 0),
+      (principalDivisor hg).support.erase (placeInfty K) = ∅ →
+      Divisor.evalFun f (principalDivisor hg) = Divisor.evalFun g (principalDivisor hf) := by
+    intro f g hf hg hempty
+    refine reciprocity_of_forall_ord_eq_zero hf hg fun v => ?_
+    by_contra hv
+    have hvmem : v ∈ (principalDivisor hg).support := by
+      rw [Finsupp.mem_support_iff, principalDivisor_apply]
+      exact hv
+    have hsubset : (principalDivisor hg).support ⊆ {placeInfty K} := by
+      intro w hw
+      rw [Finset.mem_singleton]
+      by_contra hwne
+      exact absurd (hempty ▸ Finset.mem_erase.mpr ⟨hwne, hw⟩) (Finset.notMem_empty w)
+    have hsupp_eq : (principalDivisor hg).support = {placeInfty K} :=
+      Finset.Subset.antisymm hsubset
+        (Finset.singleton_subset_iff.mpr (Finset.mem_singleton.mp (hsubset hvmem) ▸ hvmem))
+    have hsum := sum_ord_eq_zero hg
+    rw [hsupp_eq, Finset.sum_singleton] at hsum
+    rw [Finset.mem_singleton.mp (hsubset hvmem)] at hv
+    exact hv hsum
+  intro n
+  induction n with
+  | zero =>
+    intro f g hf hg hinf hd hcard
+    exact hbase f g hf hg (Finset.card_eq_zero.mp (Nat.le_zero.mp hcard))
+  | succ n ih =>
+    intro f g hf hg hinf hd hcard
+    rcases Finset.eq_empty_or_nonempty
+      ((principalDivisor hg).support.erase (placeInfty K)) with hempty | hne
+    · exact hbase f g hf hg hempty
+    obtain ⟨vb, hvb⟩ := hne
+    rw [Finset.mem_erase] at hvb
+    obtain ⟨b, rfl⟩ : ∃ x : K, vb = placeOfPoint K x := by
+      rcases eq_placeOfPoint_or_eq_placeInfty K vb with h | h
+      · exact h
+      · exact absurd h hvb.1
+    have hordb : (placeOfPoint K b).ord g ≠ 0 := ord_ne_zero_of_mem_support hg hvb.2
+    have hfb : (placeOfPoint K b).ord f = 0 := (hd _).resolve_right hordb
+    have hLb : algebraMap K[X] (RatFunc K) (X - C b) ≠ 0 :=
+      algebraMap_polynomial_ne_zero (X_sub_C_ne_zero b)
+    set m : ℤ := (placeOfPoint K b).ord g with hm
+    have hLbm : (algebraMap K[X] (RatFunc K) (X - C b)) ^ m ≠ 0 := zpow_ne_zero m hLb
+    have hg' : g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m ≠ 0 := div_ne_zero hg hLbm
+    have hord_g' : ∀ v : Place K (RatFunc K),
+        v.ord (g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m)
+          = v.ord g - m * v.ord (algebraMap K[X] (RatFunc K) (X - C b)) := fun v =>
+      ord_div_zpow v hg hLb m
+    have hg'_b : (placeOfPoint K b).ord
+        (g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m) = 0 := by
+      rw [hord_g', ord_X_sub_C_placeOfPoint_self, ← hm]
+      ring
+    have hsupp' : (principalDivisor hg').support.erase (placeInfty K)
+        ⊆ ((principalDivisor hg).support.erase (placeInfty K)).erase (placeOfPoint K b) := by
+      intro v hv
+      rw [Finset.mem_erase] at hv
+      have hvord := ord_ne_zero_of_mem_support hg' hv.2
+      rw [Finset.mem_erase, Finset.mem_erase]
+      refine ⟨?_, hv.1, ?_⟩
+      · rintro rfl
+        exact hvord hg'_b
+      · rw [Finsupp.mem_support_iff, principalDivisor_apply]
+        intro hvg
+        apply hvord
+        rw [hord_g' v, hvg,
+          ord_X_sub_C_eq_zero_of_ne b (fun h => hvord (by rw [h]; exact hg'_b)) hv.1]
+        ring
+    have hcard' : ((principalDivisor hg').support.erase (placeInfty K)).card ≤ n := by
+      have h1 := Finset.card_le_card hsupp'
+      rw [Finset.card_erase_of_mem (Finset.mem_erase.mpr hvb)] at h1
+      omega
+    have hd_f_Lb : ∀ v : Place K (RatFunc K),
+        v.ord f = 0 ∨ v.ord (algebraMap K[X] (RatFunc K) (X - C b)) = 0 := by
+      intro v
+      rcases eq_or_ne v (placeOfPoint K b) with rfl | hvb'
+      · exact Or.inl hfb
+      rcases eq_or_ne v (placeInfty K) with rfl | hvinf
+      · exact Or.inl hinf
+      · exact Or.inr (ord_X_sub_C_eq_zero_of_ne b hvb' hvinf)
+    have hd_f_Lbm : ∀ v : Place K (RatFunc K),
+        v.ord f = 0 ∨ v.ord ((algebraMap K[X] (RatFunc K) (X - C b)) ^ m) = 0 := fun v =>
+      (hd_f_Lb v).imp_right fun h => by rw [v.ord_zpow, h, mul_zero]
+    have hd_f_g' : ∀ v : Place K (RatFunc K),
+        v.ord f = 0 ∨ v.ord (g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m) = 0 := by
+      intro v
+      by_cases hv : v.ord f = 0
+      · exact Or.inl hv
+      · refine Or.inr ?_
+        rw [hord_g' v, (hd v).resolve_left hv, (hd_f_Lb v).resolve_left hv, mul_zero,
+          sub_zero]
+    have hlin :
+        Divisor.evalFun f (principalDivisor hLb)
+          = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b)) (principalDivisor hf) :=
+      reciprocity_linear b (principalDivisor hf).support.card f hf hinf hfb le_rfl
+    have hlin_pow :
+        Divisor.evalFun f (principalDivisor hLbm)
+          = Divisor.evalFun ((algebraMap K[X] (RatFunc K) (X - C b)) ^ m)
+              (principalDivisor hf) :=
+      reciprocity_zpow_right hf hLb m hd_f_Lb hlin
+    have hih :
+        Divisor.evalFun f (principalDivisor hg')
+          = Divisor.evalFun (g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m)
+              (principalDivisor hf) :=
+      ih f _ hf hg' hinf hd_f_g' hcard'
+    have hmul :
+        Divisor.evalFun f (principalDivisor (mul_ne_zero hLbm hg'))
+          = Divisor.evalFun ((algebraMap K[X] (RatFunc K) (X - C b)) ^ m
+              * (g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m)) (principalDivisor hf) :=
+      reciprocity_mul_right hf hLbm hg' hd_f_Lbm hd_f_g' hlin_pow hih
+    have hgeq : g = (algebraMap K[X] (RatFunc K) (X - C b)) ^ m
+        * (g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m) := by
+      rw [mul_comm, div_mul_cancel₀ _ hLbm]
+    calc Divisor.evalFun f (principalDivisor hg)
+        = Divisor.evalFun f (principalDivisor (mul_ne_zero hLbm hg')) := by
+          rw [principalDivisor_congr hg (mul_ne_zero hLbm hg') hgeq]
+      _ = Divisor.evalFun ((algebraMap K[X] (RatFunc K) (X - C b)) ^ m
+            * (g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m)) (principalDivisor hf) := hmul
+      _ = Divisor.evalFun g (principalDivisor hf) := by rw [← hgeq]
+
+end Reciprocity
+end RationalFunctionField
+end AlgebraicCurve
+end
+
+open Polynomial _root_.AlgebraicCurve
+  _root_.P2MW.S_OVERLONG_22e088d4.AlgebraicCurve
+  _root_.AlgebraicCurve.RationalFunctionField
+  _root_.P2MW.S_OVERLONG_22e088d4.AlgebraicCurve.RationalFunctionField
+  in
+theorem solution (K : Type*) [Field K] [DecidableEq (RatFunc K)] (b : K) (v : Place K (RatFunc K)) :
+    v.ord (algebraMap (Polynomial K) (RatFunc K) (Polynomial.X - Polynomial.C b)) = (Finsupp.single
+      (placeOfPoint K b) (1 : ℤ) + Finsupp.single (placeInfty K) (-1 : ℤ)) v :=
+  AlgebraicCurve.RationalFunctionField.ord_X_sub_C b v
+
+end S_OVERLONG_22e088d4
+end P2MW
+export P2MW.S_OVERLONG_22e088d4 (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve AlgebraicCurve.RationalFunctionField
+theorem AlgebraicCurve.RationalFunctionField.ord_X_sub_C (K : Type*) [Field K]
+    [DecidableEq (RatFunc K)] (b : K) (v : Place K (RatFunc K)) :
+    v.ord (algebraMap (Polynomial K) (RatFunc K) (Polynomial.X - Polynomial.C b)) = (Finsupp.single
+      (placeOfPoint K b) (1 : ℤ) + Finsupp.single (placeInfty K) (-1 : ℤ)) v :=
+  solution K b v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_eq_neg_intDegree_of_forall_ne_ofHeightOneSpectrum.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_eq_neg_intDegree_of_forall_ne_ofHeightOneSpectrum.lean
new file mode 100644
index 0000000000..cd8160e7bd
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_eq_neg_intDegree_of_forall_ne_ofHeightOneSpectrum.lean
@@ -0,0 +1,101 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.RationalFunctionField.ord_eq_neg_intDegree_of_forall_ne_ofHeightOneSpectrum
+(aff2c448-5247-5cf8-b286-350bd75e11e5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 230abd3e-62a3-58f3-a54f-d8134c83ba01
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Degree
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_eq_neg_log_of_valuationSubring_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_toValuationSubring_eq_of_forall_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# At the infinite place of K(X), ord = -deg
+
+Theorem statement:
+`AlgebraicCurve.RationalFunctionField.ord_eq_neg_intDegree_of_forall_ne_ofHeightOneSpectrum`
+(`aff2c448-5247-5cf8-b286-350bd75e11e5`), by Claude, 2026-09-05.
+
+Proof: submission `230abd3e-62a3-58f3-a54f-d8134c83ba01`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $v$ be a place of the rational function field $\mathrm{RatFunc}\ K$ over
+$K$ in the sense of the project's structure `Place`: a valuation subring of $\mathrm{RatFunc}\ K$
+that contains the image of $K$ under the structure map, is not the whole field, and is a principal
+ideal ring. Assume that $v$ is distinct from `Place.ofHeightOneSpectrum w` for every $w$ in the
+height-one spectrum of the polynomial ring $K[X]$, i.e. $v$ is not the place whose valuation subring
+is that of the $w$-adic valuation on $\mathrm{RatFunc}\ K$, for any nonzero prime $w$ of $K[X]$. Let
+$f \neq 0$ be a rational function. Then $v.\mathrm{ord}\, f = -f.\mathrm{intDegree}$, where
+$v.\mathrm{ord}\, f$ is minus the logarithm (in $\mathbb{Z}$, via `WithZero.log`) of the value at
+$f$ of the adic valuation attached to the maximal ideal of the valuation ring of $v$, viewed as a
+point of the height-one spectrum, and $f.\mathrm{intDegree}$ is the degree of the numerator of $f$
+minus the degree of its denominator.
+
+This identifies the unique place of $K(X)/K$ that is not a finite place — the place at infinity —
+and computes its order function as minus the degree, the divisor-theoretic form of the statement
+that $1/X$ is a uniformiser at infinity. It is used in the study of places and divisors of function
+fields, for instance in showing that a place of a function field over an algebraically closed field
+with all orders zero forces membership in the constants, and that a rational function with
+prescribed orders has degree zero.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_ord_eq_neg_intDegree_of_forall_ne_ofHeightOneSpectrum.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_d34bfdc7
+
+open AlgebraicCurve
+open IsDedekindDomain WithZero IsLocalRing
+open scoped Polynomial
+
+theorem solution {K : Type*} [Field K] (v : Place K (RatFunc K))
+    (hv : ∀ w : IsDedekindDomain.HeightOneSpectrum (Polynomial K), v ≠ Place.ofHeightOneSpectrum w)
+    {f : RatFunc K} (hf : f ≠ 0) :
+    v.ord f = -f.intDegree := by
+  classical
+  have hπ : RatFunc.inftyValuation K (RatFunc.X)⁻¹ = exp (-1 : ℤ) := by
+    rw [map_inv₀, RatFunc.inftyValuation.X]
+    exact (exp_neg (1 : ℤ)).symm
+  rw [v.ord_eq_neg_log_of_valuationSubring_eq (RatFunc.inftyValuation K)
+      (AlgebraicCurve.RationalFunctionField.toValuationSubring_eq_of_forall_ne_ofHeightOneSpectrum
+        v hv).symm hπ hf,
+    RatFunc.inftyValuation_apply, RatFunc.inftyValuation_of_nonzero K hf, log_exp]
+
+end S_OVERLONG_d34bfdc7
+end P2MW
+export
+  P2MW.S_OVERLONG_d34bfdc7
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.RationalFunctionField.ord_eq_neg_intDegree_of_forall_ne_ofHeightOneSpectrum
+    {K : Type*} [Field K] (v : Place K (RatFunc K))
+    (hv : ∀ w : IsDedekindDomain.HeightOneSpectrum (Polynomial K), v ≠ Place.ofHeightOneSpectrum w)
+    {f : RatFunc K} (hf : f ≠ 0) :
+    v.ord f = -f.intDegree :=
+  solution v hv hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_eq_neg_log.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_eq_neg_log.lean
new file mode 100644
index 0000000000..cdfebaf3b6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_eq_neg_log.lean
@@ -0,0 +1,98 @@
+/-
+Based on Prove2Me node AlgebraicCurve.RationalFunctionField.ord_ofHeightOneSpectrum_eq_neg_log
+(2bd8c823-9b6f-5635-a092-45542aa65bd1) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ec2907c6-cfaf-5459-9320-98fa7771fe1b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_eq_neg_log_of_valuationSubring_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order at a finite place of K(t) equals the adic valuation
+
+Theorem statement: `AlgebraicCurve.RationalFunctionField.ord_ofHeightOneSpectrum_eq_neg_log`
+(`2bd8c823-9b6f-5635-a092-45542aa65bd1`), by Claude, 2026-09-05.
+
+Proof: submission `ec2907c6-cfaf-5459-9320-98fa7771fe1b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, let $w$ be a height-one prime of the polynomial ring $K[X]$, let $p \in K[X]$ be
+nonzero with $w.\mathrm{asIdeal} = (p)$, and let $f \in \mathrm{RatFunc}\,K$ be nonzero. Attached to
+$w$ is the place `Place.ofHeightOneSpectrum w` of $\mathrm{RatFunc}\,K$ over $K$, namely the
+$K$-subalgebra-containing valuation subring of $\mathrm{RatFunc}\,K$ cut out by the
+$\mathbb{Z}^{m0}$-valued $w$-adic valuation $w.\mathrm{valuation}\,(\mathrm{RatFunc}\,K)$, together
+with the facts that this subring is not all of $\mathrm{RatFunc}\,K$ and is a principal ideal ring.
+For a place $v$, $\mathrm{ord}\,f$ is defined as $-\mathrm{log}$ of the value at $f$ of the adic
+valuation intrinsically associated with $v$ (the valuation of the height-one prime of the valuation
+ring of $v$). The assertion is that for this place the intrinsic normalised order of $f$ agrees with
+the extrinsic one: $$\mathrm{ord}\,f =
+-\mathrm{log}\bigl(w.\mathrm{valuation}\,(\mathrm{RatFunc}\,K)\,f\bigr),$$ an equality of integers,
+i.e. $\mathrm{ord}\,f$ is the multiplicity of $p$ in $f$.
+
+This identifies the normalised order function of a finite place of the rational function field
+$K(t)$, defined through the place's own valuation ring, with the exponent of the corresponding
+$w$-adic valuation on $\mathrm{RatFunc}\,K$; it is the computational form in which orders at finite
+places are used. It is cited by
+[`AlgebraicCurve.RationalFunctionField.ord_ofHeightOneSpectrum_of_span`]
+(thm.html#AlgebraicCurve.RationalFunctionField.ord_ofHeightOneSpectrum_of_span)
+and by
+[`AlgebraicCurve.RationalFunctionField.trace_localResidue_finitePlace_div_pow_eq_zero`]
+(thm.html#AlgebraicCurve.RationalFunctionField.trace_localResidue_finitePlace_div_pow_eq_zero).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_eq_neg_log.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_eq_neg_log
+
+open AlgebraicCurve
+open IsDedekindDomain WithZero IsLocalRing
+open scoped Polynomial
+
+theorem solution {K : Type*} [Field K] (w : IsDedekindDomain.HeightOneSpectrum (Polynomial K))
+    {p : Polynomial K} (hp : p ≠ 0) (hw : w.asIdeal = Ideal.span {p}) {f : RatFunc K} (hf : f ≠ 0) :
+    (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord f = -WithZero.log (w.valuation
+      (RatFunc K) f) := by
+  have hval : w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) p) = exp (-1 : ℤ) := by
+    have h := w.intValuation_singleton hp hw
+    rw [← h]
+    simpa using w.valuation_of_algebraMap (K := RatFunc K) p
+  exact (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K)
+    w).ord_eq_neg_log_of_valuationSubring_eq (w.valuation (RatFunc K)) rfl hval hf
+
+end S_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_eq_neg_log
+end P2MW
+export P2MW.S_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_eq_neg_log (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.RationalFunctionField.ord_ofHeightOneSpectrum_eq_neg_log {K : Type*}
+    [Field K] (w : IsDedekindDomain.HeightOneSpectrum (Polynomial K)) {p : Polynomial K}
+    (hp : p ≠ 0) (hw : w.asIdeal = Ideal.span {p}) {f : RatFunc K} (hf : f ≠ 0) :
+    (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord f = -WithZero.log (w.valuation
+      (RatFunc K) f) :=
+  solution w hp hw hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_of_span.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_of_span.lean
new file mode 100644
index 0000000000..9aca430be8
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_of_span.lean
@@ -0,0 +1,95 @@
+/-
+Based on Prove2Me node AlgebraicCurve.RationalFunctionField.ord_ofHeightOneSpectrum_of_span
+(89bb3391-aada-5f34-8ae4-964805dcc2c2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8f9aa023-829c-5b7d-a779-3de65f788e61
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_eq_neg_log
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A generator of a height-one prime of K[X] has order 1
+
+Theorem statement: `AlgebraicCurve.RationalFunctionField.ord_ofHeightOneSpectrum_of_span`
+(`89bb3391-aada-5f34-8ae4-964805dcc2c2`), by Claude, 2026-09-05.
+
+Proof: submission `8f9aa023-829c-5b7d-a779-3de65f788e61`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, and let $w$ be a point of the height-one spectrum of the polynomial ring $K[X]$,
+i.e. a nonzero prime ideal `w.asIdeal` of height one. Let $p \in K[X]$ be nonzero and assume that
+`w.asIdeal` is the principal ideal generated by $p$. Associated with $w$ is the place
+`Place.ofHeightOneSpectrum w` of the rational function field $\mathrm{RatFunc}(K)$ over $K$: the
+valuation subring of the $w$-adic valuation of $\mathrm{RatFunc}(K)$, packaged as a `Place`, that
+is, a valuation subring of $\mathrm{RatFunc}(K)$ containing the image of $K$, different from the
+whole field, and a principal ideal ring. For a place $v$, $v.\mathrm{ord}(f)$ is defined as minus
+the `WithZero.log` of the value at $f$ of the adic valuation attached to $v$, valued in
+$\mathbb{Z}^{m0}$, so that $\mathrm{ord}$ is the additive normalisation of the valuation with
+$\mathrm{ord}$ of a uniformiser equal to $1$. The assertion is that the order of the image of $p$
+under the structure map $K[X] \to \mathrm{RatFunc}(K)$ at this place equals $1$; equivalently, any
+generator of $w$ is a uniformiser at the corresponding finite place of $K(t)/K$.
+
+This is the basic normalisation statement for the finite places of the rational function field: the
+finite places of $K(t)$ correspond to the height-one primes of $K[X]$, and a generator of such a
+prime has order exactly one there. It is used throughout the treatment of divisors on
+$\mathbb{P}^1$, for instance in computing degrees of principal divisors and in evaluating functions
+at places, including at the place at infinity.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_of_span.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_of_span
+
+open AlgebraicCurve
+open IsDedekindDomain WithZero IsLocalRing
+open scoped Polynomial
+
+theorem solution {K : Type*} [Field K] (w : IsDedekindDomain.HeightOneSpectrum (Polynomial K))
+    {p : Polynomial K} (hp : p ≠ 0) (hw : w.asIdeal = Ideal.span {p}) :
+    (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord (algebraMap (Polynomial K) (RatFunc
+      K) p) = 1 := by
+  have hval : w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) p) = exp (-1 : ℤ) := by
+    have h := w.intValuation_singleton hp hw
+    rw [← h]
+    simpa using w.valuation_of_algebraMap (K := RatFunc K) p
+  rw [AlgebraicCurve.RationalFunctionField.ord_ofHeightOneSpectrum_eq_neg_log w hp hw
+    (RatFunc.algebraMap_ne_zero hp), hval]
+  simp [log_exp]
+
+end S_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_of_span
+end P2MW
+export P2MW.S_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_of_span (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.RationalFunctionField.ord_ofHeightOneSpectrum_of_span {K : Type*} [Field K]
+    (w : IsDedekindDomain.HeightOneSpectrum (Polynomial K)) {p : Polynomial K} (hp : p ≠ 0)
+    (hw : w.asIdeal = Ideal.span {p}) :
+    (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord (algebraMap (Polynomial K) (RatFunc
+      K) p) = 1 :=
+  solution w hp hw
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty.lean
new file mode 100644
index 0000000000..6a7e76d9ad
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty.lean
@@ -0,0 +1,87 @@
+/-
+Based on Prove2Me node AlgebraicCurve.RationalFunctionField.ord_placeInfty
+(3c1d2f21-1efb-5e11-a4c3-ce8ddea9179b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 74ae96fc-9bfe-59aa-954f-25e3933b067d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceInfty
+
+import Mathlib.FieldTheory.RatFunc.Degree
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_placeInfty_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_eq_neg_intDegree_of_forall_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order at the infinite place is minus the degree
+
+Theorem statement: `AlgebraicCurve.RationalFunctionField.ord_placeInfty`
+(`3c1d2f21-1efb-5e11-a4c3-ce8ddea9179b`), by Claude, 2026-09-05.
+
+Proof: submission `74ae96fc-9bfe-59aa-954f-25e3933b067d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $f$ be a nonzero element of the rational function field
+$\mathrm{RatFunc}\,K$. Consider the place $\mathrm{placeInfty}\,K$ of $\mathrm{RatFunc}\,K$ over
+$K$: in the project's sense a place of $F$ over $K$ is a valuation subring of $F$ containing the
+image of $K$ under the structure map, different from all of $F$, and a principal ideal ring; for
+$\mathrm{placeInfty}\,K$ the valuation subring is the one attached to the infinity valuation
+$\mathrm{RatFunc.inftyValuation}\,K$ on $K(t)$, whose containment of the constants comes from the
+triviality of that valuation on $K$, whose non-triviality gives that it is not everything, and whose
+principality comes from the fact that the valuation ring is a discrete valuation ring. For a place
+$v$ the integer $v.\mathrm{ord}\,g$ is defined as $-\log$ of the value at $g$ of the adic valuation
+of the height-one prime of the valuation subring, with values in $\mathbb{Z}^{m0}$. The assertion is
+the equality $(\mathrm{placeInfty}\,K).\mathrm{ord}\,f = -f.\mathrm{intDegree}$, where the integer
+degree of $f$ is the degree of its numerator minus that of its denominator.
+
+This identifies the normalised order function at the place at infinity of $\mathbb{P}^1_K$ with
+minus the degree of a rational function; in particular a polynomial of degree $d$ has a pole of
+order $d$ there, and $1/t$ is a uniformiser. It is used throughout the function-field foundations of
+the project, for instance in determining which rational functions lie in $K[t]$ away from infinity
+and in the finiteness and Riemann–Roch computations for the rational function field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_ord_placeInfty.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_RationalFunctionField_ord_placeInfty
+
+open IsDedekindDomain AlgebraicCurve AlgebraicCurve.RationalFunctionField
+
+theorem solution {K : Type*} [Field K] [DecidableEq (RatFunc K)] {f : RatFunc K} (hf : f ≠ 0) :
+    (placeInfty K).ord f = -f.intDegree :=
+  AlgebraicCurve.RationalFunctionField.ord_eq_neg_intDegree_of_forall_ne_ofHeightOneSpectrum
+    (placeInfty K)
+    (AlgebraicCurve.RationalFunctionField.placeInfty_ne_ofHeightOneSpectrum K) hf
+
+end S_AlgebraicCurve_RationalFunctionField_ord_placeInfty
+end P2MW
+export P2MW.S_AlgebraicCurve_RationalFunctionField_ord_placeInfty (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve AlgebraicCurve.RationalFunctionField
+theorem AlgebraicCurve.RationalFunctionField.ord_placeInfty {K : Type*} [Field K]
+    [DecidableEq (RatFunc K)] {f : RatFunc K} (hf : f ≠ 0) :
+    (placeInfty K).ord f = -f.intDegree :=
+  solution hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty_X.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty_X.lean
new file mode 100644
index 0000000000..877533310c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty_X.lean
@@ -0,0 +1,2681 @@
+/-
+Based on Prove2Me node AlgebraicCurve.RationalFunctionField.ord_placeInfty_X
+(074b2d90-f4d6-5aaf-b6fb-123133b1a911) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f2f726b5-ce75-563a-9f7f-19c2332adc92
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceInfty
+
+import Mathlib.Algebra.Polynomial.Basis
+import Mathlib.Data.Int.LeastGreatest
+import Mathlib.LinearAlgebra.Matrix.FiniteDimensional
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PoleDivisorPackage
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_restrict_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_placeInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# ord_∞(X) = -1 on the rational function field
+
+Theorem statement: `AlgebraicCurve.RationalFunctionField.ord_placeInfty_X`
+(`074b2d90-f4d6-5aaf-b6fb-123133b1a911`), by Claude, 2026-09-05.
+
+Proof: submission `f2f726b5-ce75-563a-9f7f-19c2332adc92`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $\mathrm{RatFunc}\,K = K(X)$ be the field of rational functions over $K$.
+Consider the place at infinity `RationalFunctionField.placeInfty K` of $K(X)$ over $K$: it is the
+datum, in the sense of the structure
+[`AlgebraicCurve.Place`](def/AlgebraicCurve_DivisorClassGroup.html#L22), consisting of the valuation
+subring attached to the valuation `RatFunc.inftyValuation K`, together with the facts that this
+subring contains the image of $K$ under the structure map, is not the whole of $K(X)$, and is a
+principal ideal ring. For a place $v$ of $F$ over $K$, the integer $v.\mathrm{ord}(f)$ is defined as
+$-\log$ of the value $v.\mathrm{adicValuation}(f) \in \mathbb{Z}^{m0}$, where
+$v.\mathrm{adicValuation}$ is the $\mathbb{Z}^{m0}$-valued valuation of $F$ attached to the
+height-one prime of the valuation subring of $v$. The assertion is that for the coordinate function
+$X \in K(X)$ one has $(\mathrm{placeInfty}\,K).\mathrm{ord}(X) = -1$.
+
+This records that $X$ has a simple pole at the place at infinity of $K(X)/K$, the normalisation of
+the degree-valuation on the rational function field; it is the basic numerical input for divisor
+computations on the projective line. It is used in the construction of pole divisors and in the
+comparison of orders at infinity with orders at the finite places arising from reduction.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_ord_placeInfty_X.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_RationalFunctionField_ord_placeInfty_X
+
+
+open Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "degree degree_single principal smul_def smul_apply pullback \
+  pullback_apply degree_pullback"
+end Divisor
+variable {D : Divisor K F}
+p2m_open_scoped "AlgebraicCurve.Divisor" in
+theorem Divisor.degree_nonneg_of_nonneg [IsCurveOver K F]
+    {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) : 0 ≤ Divisor.degree D := by
+  rw [Divisor.degree_eq_sum_support]
+  exact Finset.sum_nonneg fun v _ => mul_nonneg (hD v) (Int.natCast_nonneg _)
+theorem lSpace_eq_bot_of_degree_neg [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) : LSpace D = ⊥ := by
+  rw [eq_bot_iff]
+  intro f hf
+  rw [Submodule.mem_bot]
+  by_contra hf0
+  obtain ⟨P, hPord, hPdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+  have heff : ∀ v : Place K F, 0 ≤ (P + D) v := by
+    intro v
+    rw [Finsupp.add_apply, hPord]
+    rcases mem_lSpace_iff_ord.mp hf with rfl | h
+    · exact absurd rfl hf0
+    · linarith [h v]
+  have hdegPD : 0 ≤ Divisor.degree (P + D) := Divisor.degree_nonneg_of_nonneg heff
+  rw [map_add, hPdeg, zero_add] at hdegPD
+  exact absurd hdegPD (not_le.mpr hD)
+end AlgebraicCurve
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~restrict_plac\
+  eOfPrime~placeOfPrime~comap_algebraMap_ne_top"
+
+variable (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mk_mem_maximalIdeal_iff {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    (⟨f, hf⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring
+      ↔ f = 0 ∨ 0 < v.ord f := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  constructor
+  · intro hu
+    rcases eq_or_ne f 0 with rfl | hf0
+    · exact Or.inl rfl
+    · refine Or.inr ?_
+      rcases lt_or_eq_of_le (AlgebraicCurve.Place.ord_nonneg_of_mem v hf) with h | h
+      · exact h
+      · exfalso
+        apply hu
+        rw [← v.adicValuation_coe_eq_one_iff ⟨f, hf⟩]
+        change v.adicValuation f = 1
+        rw [v.adicValuation_eq_exp_neg_ord hf0, ← h, neg_zero, WithZero.exp_zero]
+  · intro h hu
+    have hne : f ≠ 0 := fun h0 => hu.ne_zero (Subtype.ext h0)
+    have h0 : v.ord f = 0 := by
+      obtain ⟨u, hu'⟩ := hu
+      have hcoe : f = ((u : v.toValuationSubring) : F) := by rw [hu']
+      rw [hcoe]; exact v.ord_coe_unit u
+    rcases h with rfl | hpos
+    · exact hne rfl
+    · omega
+
+p2m_export "AlgebraicCurve.Place" "mk_mem_maximalIdeal_iff"
+end Place
+
+theorem ell_le_ell_sub_single_add_deg [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    ell D ≤ ell (D - Finsupp.single P 1) + P.deg := by
+  classical
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible P.toValuationSubring
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by
+    simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := by
+    intro g hg
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ g : F, g ∈ LSpace D → t ^ (D P) * g ∈ P.toValuationSubring := by
+    intro g hg
+    rcases eq_or_ne g 0 with rfl | hg0
+    · simp
+    · refine AlgebraicCurve.Place.mem_of_ord_nonneg P (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have := (mem_lSpace_iff_ord.mp hg).resolve_left hg0 P
+      linarith
+  let ψ : LSpace D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun f => ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+      map_add' := by intro f g; apply Subtype.ext; push_cast; ring
+      map_smul' := by
+        intro c f; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap]
+        ring }
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : LSpace D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ f : LSpace D, φ f = 0 ↔
+      (⟨t ^ (D P) * (f : F), hmem _ f.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := by
+    intro f
+    rw [show φ f = IsLocalRing.residue P.toValuationSubring ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+          from hres (ψ f),
+      IsLocalRing.residue_eq_zero_iff]
+  have hED : E ≤ D := by
+    rw [Finsupp.le_def]; intro v; rw [hE, Finsupp.sub_apply]
+    have : (0 : ℤ) ≤ Finsupp.single P 1 v := by
+      rcases eq_or_ne v P with rfl | hv
+      · simp
+      · simp [Finsupp.single_eq_of_ne hv]
+    linarith
+  have hsub : LSpace E ≤ LSpace D := lSpace_mono hED
+  have hker : LinearMap.ker φ = (LSpace E).comap (LSpace D).subtype := by
+    ext f
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi f, P.mk_mem_maximalIdeal_iff]
+    rcases eq_or_ne (f : F) 0 with hf0 | hf0
+    · simp only [hf0, mul_zero, true_or, true_iff]
+      exact (LSpace E).zero_mem
+    · rw [mem_lSpace_iff_ord]
+      have hfD := (mem_lSpace_iff_ord.mp f.2).resolve_left hf0
+      constructor
+      · rintro (h | h)
+        · exact absurd h (mul_ne_zero htn0 hf0)
+        · refine Or.inr (fun v => ?_)
+          rcases eq_or_ne v P with rfl | hv
+          · rw [hEP]; rw [hordmul hf0] at h; omega
+          · rw [hEv v hv]; exact hfD v
+      · rintro (h | h)
+        · exact absurd h hf0
+        · refine Or.inr ?_
+          have hP := h P
+          rw [hEP] at hP
+          rw [hordmul hf0]; omega
+  have hkerfin : finrank K (LinearMap.ker φ) = ell E := by
+    rw [hker, LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe hsub)]
+  have hquot : finrank K (LSpace D ⧸ LinearMap.ker φ) ≤ P.deg := by
+    rw [LinearEquiv.finrank_eq φ.quotKerEquivRange]
+    exact Submodule.finrank_le (LinearMap.range φ)
+  by_cases hfin : FiniteDimensional K (LSpace D)
+  · have := hfin
+    have hrn := Submodule.finrank_quotient_add_finrank (LinearMap.ker φ)
+    rw [hkerfin] at hrn
+    have hb : ell D = finrank K (LSpace D) := rfl
+    omega
+  · have h0 : ell D = 0 := by rw [ell]; exact finrank_of_infinite_dimensional hfin
+    omega
+
+theorem one_le_deg [IsCurveOver K F] (P : Place K F) : 1 ≤ P.deg := by
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  exact Module.finrank_pos
+
+theorem ell_le_degree_add_ellZero [IsCurveOver K F] {D : Divisor K F}
+    (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D : Divisor K F, (∀ v, 0 ≤ D v) →
+      (Divisor.degree D).toNat = m →
+      (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) by
+    exact H (Divisor.degree D).toNat D hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D hD hm
+    by_cases hD0 : D = 0
+    · subst hD0; simp
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ D P := by
+        have hne : D P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hD P; omega
+      set E : Divisor K F := D - Finsupp.single P 1 with hE
+      have hEeff : ∀ v, 0 ≤ E v := by
+        intro v; rw [hE, Finsupp.sub_apply]
+        rcases eq_or_ne v P with rfl | hv
+        · rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have hdegE : Divisor.degree E = Divisor.degree D - P.deg := by
+        rw [hE, map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hDnn : 0 ≤ Divisor.degree D := Divisor.degree_nonneg_of_nonneg hD
+      have hEnn : 0 ≤ Divisor.degree E := Divisor.degree_nonneg_of_nonneg hEeff
+      have hmlt : (Divisor.degree E).toNat < m := by rw [← hm]; omega
+      have hIH := IH _ hmlt E hEeff rfl
+      have hstep := ell_le_ell_sub_single_add_deg D P
+      rw [← hE] at hstep
+      have hstep' : (ell D : ℤ) ≤ (ell E : ℤ) + P.deg := by exact_mod_cast hstep
+      rw [hdegE] at hIH
+      linarith
+
+theorem ell_le_degree_add_one_of_effective [IsCurveOver K F]
+    (hC : ConstantsAreBase K F) {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  have h := ell_le_degree_add_ellZero hD
+  rw [ell_zero_eq_one_of_constantsAreBase hC] at h
+  exact_mod_cast h
+
+def lSpaceShiftEquiv (D : Divisor K F) {g : F} (hg : g ≠ 0)
+    {Dg : Divisor K F} (hDg : ∀ v, Dg v = v.ord g) :
+    LSpace D ≃ₗ[K] LSpace (D + Dg) where
+  toFun h := ⟨(h : F) * g⁻¹, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (h : F) 0 with hh0 | hh0
+    · left; rw [hh0, zero_mul]
+    · right; intro v
+      rw [Finsupp.add_apply, hDg, v.ord_mul hh0 (inv_ne_zero hg), v.ord_inv]
+      have := (mem_lSpace_iff_ord.mp h.2).resolve_left hh0 v
+      linarith⟩
+  invFun k := ⟨(k : F) * g, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (k : F) 0 with hk0 | hk0
+    · left; rw [hk0, zero_mul]
+    · right; intro v
+      have := (mem_lSpace_iff_ord.mp k.2).resolve_left hk0 v
+      rw [Finsupp.add_apply, hDg] at this
+      rw [v.ord_mul hk0 hg]
+      linarith⟩
+  map_add' h₁ h₂ := by apply Subtype.ext; push_cast; ring
+  map_smul' c h := by
+    apply Subtype.ext
+    simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def]
+    ring
+  left_inv h := by
+    apply Subtype.ext
+    change (h : F) * g⁻¹ * g = (h : F)
+    rw [mul_assoc, inv_mul_cancel₀ hg, mul_one]
+  right_inv k := by
+    apply Subtype.ext
+    change (k : F) * g * g⁻¹ = (k : F)
+    rw [mul_assoc, mul_inv_cancel₀ hg, mul_one]
+
+theorem ell_le_degree_add_one [IsCurveOver K F] (hC : ConstantsAreBase K F)
+    {D : Divisor K F} (hD : 0 ≤ Divisor.degree D) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  rcases eq_or_ne (ell D) 0 with h0 | h0
+  · rw [h0]; push_cast; linarith
+  · have hbot : LSpace D ≠ ⊥ := fun h => h0 (by rw [ell, h, finrank_bot])
+    obtain ⟨g, hgL, hg0⟩ := (Submodule.ne_bot_iff _).mp hbot
+    obtain ⟨Dg, hDgord, hDgdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) g hg0
+    have heff : ∀ v, 0 ≤ (D + Dg) v := by
+      intro v; rw [Finsupp.add_apply, hDgord]
+      have := (mem_lSpace_iff_ord.mp hgL).resolve_left hg0 v
+      linarith
+    have hdeg : Divisor.degree (D + Dg) = Divisor.degree D := by
+      rw [map_add, hDgdeg, add_zero]
+    have hell : ell D = ell (D + Dg) :=
+      LinearEquiv.finrank_eq (lSpaceShiftEquiv D hg0 hDgord)
+    have hfin := ell_le_degree_add_one_of_effective hC heff
+    rw [hdeg] at hfin
+    rw [hell]; exact hfin
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion factor mk mem_bot subtype_injective \
+  mk.injEq Quotient.subsingleton_iff Quotient.mk span restrictScalars inhabited \
+  inclusion_injective comapSubtypeEquivOfLe mem_comap finrank_quotient_add_finrank mem_top \
+  Quotient.equiv mkQ mem_map coe_subtype map_smul' zero one quotientQuotientEquivQuotient \
+  coe_eq_zero finrank_le range_subtype Quotient.mk_surjective map mem_inf mem_sup \
+  Quotient.mk_eq_zero topEquiv map_injective_of_injective comap_subtype_self mapQ subsingleton_iff \
+  module smul_def mk_eq_zero coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono \
+  map_sup coe_zero smul"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+def nestedComapMapMkQEquiv {A B C : Submodule K X} (_hAB : A ≤ B) (hBC : B ≤ C) :
+    ((B.comap C.subtype).map (A.comap C.subtype).mkQ : Submodule K _)
+      ≃ₗ[K] B ⧸ A.comap B.subtype := by
+  set S := A.comap C.subtype with hS
+  set T := B.comap C.subtype with hT
+  let ψ : (T : Type _) →ₗ[K] (C ⧸ S) := S.mkQ ∘ₗ T.subtype
+  have hker : LinearMap.ker ψ = S.comap T.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = T.map S.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let e1 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (T.map S.mkQ : Submodule K _) :=
+    (Submodule.Quotient.equiv _ (LinearMap.ker ψ) (LinearEquiv.refl K T)
+        (by rw [hker]; simp)).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have hmap : (S.comap T.subtype).map
+      (Submodule.comapSubtypeEquivOfLe hBC : (T : Type _) →ₗ[K] B) = A.comap B.subtype := by
+    ext ⟨b, hb⟩
+    simp only [mem_map, mem_comap, Submodule.coe_subtype, hS]
+    constructor
+    · rintro ⟨⟨⟨x, hxC⟩, hxB⟩, hxA, hxeq⟩
+      have hx : x = b := congrArg Subtype.val hxeq
+      subst hx; exact hxA
+    · intro hbA
+      exact ⟨⟨⟨b, hBC hb⟩, hb⟩, hbA, rfl⟩
+  let e2 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (B ⧸ A.comap B.subtype) :=
+    Submodule.Quotient.equiv _ _ (Submodule.comapSubtypeEquivOfLe hBC) hmap
+  exact e1.symm.trans e2
+
+theorem finrank_quotient_chain {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCB : Module.Finite K (C ⧸ B.comap C.subtype)]
+    [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (C ⧸ A.comap C.subtype) ∧
+      finrank K (C ⧸ A.comap C.subtype)
+        = finrank K (C ⧸ B.comap C.subtype) + finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (T.map S.mkQ : Submodule K _) := Module.Finite.equiv eK.symm
+  have : Module.Finite K ((C ⧸ S) ⧸ T.map S.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (C ⧸ S) := Module.Finite.of_submodule_quotient (T.map S.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+theorem finrank_quotient_chain' {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCA : Module.Finite K (C ⧸ A.comap C.subtype)] :
+    Module.Finite K (C ⧸ B.comap C.subtype) ∧
+      finrank K (C ⧸ B.comap C.subtype)
+        = finrank K (C ⧸ A.comap C.subtype) - finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (C ⧸ T) := Module.Finite.equiv e3
+  refine ⟨this, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+def adeleBddQuotSingleEquivResidueField (D : Divisor K F) (P : Place K F) :
+    (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+      ≃ₗ[K] P.ResidueField := by
+  classical
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  let π : P.toValuationSubring :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose
+  have hπ : Irreducible π :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose_spec
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := fun {g} hg => by
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ α : Place K F → F, α ∈ adeleBdd D → t ^ (D P) * α P ∈ P.toValuationSubring := by
+    intro α hα
+    rcases eq_or_ne (α P) 0 with hg0 | hg0
+    · simp [hg0]
+    · refine AlgebraicCurve.Place.mem_of_ord_nonneg P (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have h := hα P
+      rw [P.adicValuation_eq_exp_neg_ord hg0, WithZero.exp_le_exp] at h
+      linarith
+  let ψ : adeleBdd D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun α => ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩
+      map_add' := by
+        intro α β; apply Subtype.ext
+        simp only [Submodule.coe_add, Pi.add_apply]
+        push_cast; ring
+      map_smul' := by
+        intro c α; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap, Pi.smul_apply]
+        ring }
+  have hψ_apply : ∀ α : adeleBdd D,
+      (ψ α : F) = t ^ (D P) * (α : Place K F → F) P := fun α => rfl
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : adeleBdd D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ α : adeleBdd D, φ α = 0 ↔
+      (⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := fun α => by
+    rw [show φ α = IsLocalRing.residue P.toValuationSubring
+            ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ from hres (ψ α),
+      IsLocalRing.residue_eq_zero_iff]
+  have hker : LinearMap.ker φ = (adeleBdd E).comap (adeleBdd D).subtype := by
+    ext α
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi α, P.mk_mem_maximalIdeal_iff, mem_adeleBdd]
+    have hαD := α.2
+    constructor
+    · rintro (h | h) v
+      · have hα0 : (α : Place K F → F) P = 0 := by
+          rcases mul_eq_zero.mp h with h' | h'
+          · exact absurd h' htn0
+          · exact h'
+        by_cases hv : v = P
+        · subst v; rw [hα0, Valuation.map_zero]; exact zero_le
+        · rw [hEv v hv]; exact hαD v
+      · by_cases hv : v = P
+        · subst v
+          rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+          · rw [hα0, Valuation.map_zero]; exact zero_le
+          · rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP]
+            rw [hordmul hα0] at h; omega
+        · rw [hEv v hv]; exact hαD v
+    · intro h
+      rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+      · left; rw [hα0, mul_zero]
+      · right
+        have hP := h P
+        rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP] at hP
+        rw [hordmul hα0]; omega
+  have hsurj : Function.Surjective φ := by
+    intro c
+    obtain ⟨cl, hcl⟩ := IsLocalRing.residue_surjective (R := P.toValuationSubring) c
+    set f : F := (cl : F) * t ^ (-(D P)) with hf
+    have hαD : Pi.single P f ∈ adeleBdd D := by
+      intro v
+      by_cases hv : v = P
+      · subst v
+        simp only [Pi.single_eq_same]
+        rcases eq_or_ne (cl : F) 0 with hc0 | hc0
+        · rw [hf, hc0, zero_mul, Valuation.map_zero]; exact zero_le
+        · have hf0 : f ≠ 0 := by rw [hf]; exact mul_ne_zero hc0 (zpow_ne_zero _ ht0)
+          rw [P.adicValuation_eq_exp_neg_ord hf0, WithZero.exp_le_exp]
+          rw [hf, P.ord_mul hc0 (zpow_ne_zero _ ht0), P.ord_zpow, ht1, mul_one]
+          have hclnn := AlgebraicCurve.Place.ord_nonneg_of_mem P cl.2
+          linarith
+      · rw [Pi.single_eq_of_ne hv, Valuation.map_zero]; exact zero_le
+    refine ⟨⟨Pi.single P f, hαD⟩, ?_⟩
+    change res (ψ ⟨Pi.single P f, hαD⟩) = c
+    rw [hres]
+    rw [show (ψ ⟨Pi.single P f, hαD⟩ : P.toValuationSubring) = cl from ?_, hcl]
+    apply Subtype.ext
+    rw [hψ_apply]
+    change t ^ (D P) * (Pi.single P f : Place K F → F) P = (cl : F)
+    rw [show (Pi.single P f : Place K F → F) P = f from Pi.single_eq_same _ _, hf,
+      mul_comm (cl : F), ← mul_assoc, ← zpow_add₀ ht0, add_neg_cancel, zpow_zero, one_mul]
+  exact (Submodule.Quotient.equiv _ _ (LinearEquiv.refl K _) (by rw [← hker]; simp)).trans
+    (φ.quotKerEquivOfSurjective hsurj)
+
+theorem finrank_adeleBdd_quotient_single [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    Module.Finite K
+        (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype) ∧
+      finrank K
+          (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+        = P.deg := by
+  have := IsCurveOver.finite_residueField (K := K) P
+  exact ⟨Module.Finite.equiv (adeleBddQuotSingleEquivResidueField D P).symm,
+    (adeleBddQuotSingleEquivResidueField D P).finrank_eq⟩
+
+theorem finrank_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+      (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+        = Divisor.degree D₂ - Divisor.degree D₁ := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D₁ D₂ : Divisor K F, D₁ ≤ D₂ →
+      (Divisor.degree (D₂ - D₁)).toNat = m →
+      Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+        (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+          = Divisor.degree D₂ - Divisor.degree D₁ from
+    H _ D₁ D₂ hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D₁ D₂ hD hm
+    have hEeff : ∀ v, 0 ≤ (D₂ - D₁) v := fun v => by
+      rw [Finsupp.sub_apply]; have := hD v; omega
+    by_cases hD0 : D₂ - D₁ = 0
+    · have hD12 : D₁ = D₂ := (sub_eq_zero.mp hD0).symm
+      subst hD12
+      rw [Submodule.comap_subtype_self]
+      have : Subsingleton (adeleBdd D₁ ⧸ (⊤ : Submodule K (adeleBdd D₁))) :=
+        Submodule.Quotient.subsingleton_iff.mpr rfl
+      exact ⟨Module.Finite.of_finite, by simp [Module.finrank_zero_of_subsingleton]⟩
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ (D₂ - D₁) P := by
+        have hne : (D₂ - D₁) P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hEeff P; omega
+      set D₂' : Divisor K F := D₂ - Finsupp.single P 1 with hD₂'
+      have h12' : D₁ ≤ D₂' := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]
+          have := hPpos; rw [Finsupp.sub_apply] at this; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have h2'2 : D₂' ≤ D₂ := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]
+      have hdegD₂' : Divisor.degree D₂' = Divisor.degree D₂ - P.deg := by
+        rw [hD₂', map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hEnn : 0 ≤ Divisor.degree (D₂ - D₁) := Divisor.degree_nonneg_of_nonneg hEeff
+      have hE'nn : 0 ≤ Divisor.degree (D₂' - D₁) := Divisor.degree_nonneg_of_nonneg
+        (fun v => by rw [Finsupp.sub_apply]; have := h12' v; omega)
+      have hdegdiff : Divisor.degree (D₂' - D₁) = Divisor.degree (D₂ - D₁) - P.deg := by
+        simp only [hD₂', map_sub, Divisor.degree_single, one_mul]; ring
+      have hmlt : (Divisor.degree (D₂' - D₁)).toNat < m := by rw [← hm]; omega
+      obtain ⟨hfin', hrank'⟩ := IH _ hmlt D₁ D₂' h12' rfl
+      obtain ⟨hfinS, hrankS⟩ := finrank_adeleBdd_quotient_single (K := K) D₂ P
+      rw [← hD₂'] at hfinS hrankS
+      have := hfin'; have := hfinS
+      obtain ⟨hfin, hrank⟩ := Submodule.finrank_quotient_chain
+        (A := adeleBdd D₁) (B := adeleBdd D₂') (C := adeleBdd D₂)
+        (adeleBdd_mono h12') (adeleBdd_mono h2'2)
+      refine ⟨hfin, ?_⟩
+      rw [hrank, hrankS]
+      push_cast
+      linarith [hrank', hdegD₂']
+
+theorem module_finite_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  (finrank_adeleBdd_quotient hD).1
+
+theorem finrank_adeleBdd_quotient_eq [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+      = Divisor.degree D₂ - Divisor.degree D₁ :=
+  (finrank_adeleBdd_quotient hD).2
+
+def lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (_hD : D₁ ≤ D₂) :
+    (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      →ₗ[K] (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  Submodule.mapQ _ _
+    ((diagonalHom K F).restrict
+      (p := (LSpace D₂ : Submodule K F)) (q := (adeleBdd D₂ : Submodule K _))
+      (fun f hf => diagonal_mem_adeleBdd_iff.mpr hf))
+    (fun f hf => by
+      simp only [Submodule.mem_comap, Submodule.coe_subtype] at hf ⊢
+      exact diagonal_mem_adeleBdd_iff.mpr hf)
+
+theorem lSpaceQuotientToAdeleBddQuotient_injective {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Function.Injective (lSpaceQuotientToAdeleBddQuotient hD) := by
+  rw [injective_iff_map_eq_zero]
+  intro x hx
+  obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+  rw [Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype]
+  rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk f)
+        = Submodule.Quotient.mk ((diagonalHom K F).restrict
+            (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f) from rfl,
+    Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype] at hx
+  exact diagonal_mem_adeleBdd_iff.mp hx
+
+
+theorem ell_sub_ell_le_degree_sub_degree [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)] :
+    (ell D₂ : ℤ) - (ell D₁ : ℤ) ≤ Divisor.degree D₂ - Divisor.degree D₁ := by
+  have := module_finite_adeleBdd_quotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    rw [hℓ₁]; exact (Submodule.finrank_quotient_add_finrank _).symm
+  have hemb : finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      ≤ finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+    LinearMap.finrank_le_finrank_of_injective (lSpaceQuotientToAdeleBddQuotient_injective hD)
+  have hloc := finrank_adeleBdd_quotient_eq hD
+  have : (ell D₂ : ℤ) - (ell D₁ : ℤ)
+      = (finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) : ℤ) := by
+    rw [hL]; push_cast; ring
+  rw [this, ← hloc]
+  exact_mod_cast hemb
+
+theorem adeleBdd_inf_sup_globalSub {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F)
+      = adeleBdd D₁ ⊔ adeleBdd D₂ ⊓ globalSub K F := by
+  rw [inf_comm, sup_inf_assoc_of_le _ (adeleBdd_mono hD), inf_comm]
+
+theorem map_diagonal_lSpace_inf_adeleBdd {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (LSpace D₂).map (diagonalHom K F) ⊓ adeleBdd D₁ = (LSpace D₁).map (diagonalHom K F) := by
+  rw [map_diagonal_lSpace, map_diagonal_lSpace, inf_right_comm,
+    inf_eq_right.mpr (adeleBdd_mono hD)]
+
+theorem gate_finrank_adeleBdd_quotient_single_point [IsCurveOver K F] (P : Place K F) :
+    (finrank K (adeleBdd (Finsupp.single P 1 : Divisor K F)
+        ⧸ (adeleBdd (0 : Divisor K F)).comap (adeleBdd (Finsupp.single P 1)).subtype) : ℤ)
+      = (P.deg : ℤ) := by
+  classical
+  have h01 : (0 : Divisor K F) ≤ Finsupp.single P 1 := by
+    intro v; rw [Finsupp.zero_apply, Finsupp.single_apply]; split_ifs <;> omega
+  have h := finrank_adeleBdd_quotient_eq (K := K) h01
+  rw [h, map_zero, sub_zero, Divisor.degree_single, one_mul]
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion factor mk mem_bot subtype_injective \
+  mk.injEq Quotient.subsingleton_iff Quotient.mk span restrictScalars inhabited \
+  inclusion_injective comapSubtypeEquivOfLe mem_comap finrank_quotient_add_finrank mem_top \
+  Quotient.equiv mkQ mem_map coe_subtype map_smul' zero one quotientQuotientEquivQuotient \
+  coe_eq_zero finrank_le range_subtype Quotient.mk_surjective map mem_inf mem_sup \
+  Quotient.mk_eq_zero topEquiv map_injective_of_injective comap_subtype_self mapQ subsingleton_iff \
+  module smul_def mk_eq_zero coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono \
+  map_sup coe_zero smul"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+theorem comap_subtype_sup_of_le_of_le {S T C : Submodule K X} (hS : S ≤ C) (hT : T ≤ C) :
+    S.comap C.subtype ⊔ T.comap C.subtype = (S ⊔ T).comap C.subtype := by
+  apply Submodule.map_injective_of_injective (f := C.subtype) C.subtype_injective
+  rw [Submodule.map_sup, Submodule.map_comap_subtype, Submodule.map_comap_subtype,
+    Submodule.map_comap_subtype, inf_eq_right.mpr hS, inf_eq_right.mpr hT,
+    inf_eq_right.mpr (sup_le hS hT)]
+
+theorem finrank_quotient_chain_top {M : Type*} [AddCommGroup M] [Module K M]
+    {A B : Submodule K M} (hAB : A ≤ B)
+    [hMB : Module.Finite K (M ⧸ B)] [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (M ⧸ A) ∧
+      finrank K (M ⧸ A) = finrank K (M ⧸ B) + finrank K (B ⧸ A.comap B.subtype) := by
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  let ψ : (B : Type _) →ₗ[K] (M ⧸ A) := A.mkQ ∘ₗ B.subtype
+  have hker : LinearMap.ker ψ = A.comap B.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = B.map A.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let eK : (B ⧸ A.comap B.subtype) ≃ₗ[K] (B.map A.mkQ : Submodule K (M ⧸ A)) :=
+    (Submodule.quotEquivOfEq _ _ hker.symm).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have : Module.Finite K (B.map A.mkQ : Submodule K (M ⧸ A)) := Module.Finite.equiv eK
+  have : Module.Finite K ((M ⧸ A) ⧸ B.map A.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (M ⧸ A) := Module.Finite.of_submodule_quotient (B.map A.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (B.map A.mkQ)
+  rw [LinearEquiv.finrank_eq e3, ← LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem globalSub_le_adeleSpace [HasPrincipalDivisors K F] :
+    globalSub K F ≤ adeleSpace K F := by
+  rintro _ ⟨f, rfl⟩
+  exact diagonal_mem_adeleSpace f
+
+theorem adeleBdd_sup_globalSub_le_adeleSpace [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+  sup_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_eq_comap [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBddPrincipal K F D = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype :=
+  Submodule.comap_subtype_sup_of_le_of_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_mono {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBddPrincipal K F D₁ ≤ adeleBddPrincipal K F D₂ :=
+  sup_le_sup_right (Submodule.comap_mono (adeleBdd_mono hD)) _
+
+section FiniteLSpace
+
+variable [IsCurveOver K F]
+
+theorem finiteDimensional_lSpace [hL0 : FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (D : Divisor K F) : FiniteDimensional K (LSpace D) := by
+  have h0D : (0 : Divisor K F) ≤ D ⊔ 0 := le_sup_right
+  have hDD : D ≤ D ⊔ 0 := le_sup_left
+  suffices h : FiniteDimensional K (LSpace (D ⊔ 0)) by
+    exact Module.Finite.of_injective (Submodule.inclusion (lSpace_mono hDD))
+      (Submodule.inclusion_injective _)
+  have := module_finite_adeleBdd_quotient (K := K) h0D
+  have hfinQ : FiniteDimensional K
+      (LSpace (D ⊔ 0) ⧸ (LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype) :=
+    Module.Finite.of_injective _ (lSpaceQuotientToAdeleBddQuotient_injective h0D)
+  have : FiniteDimensional K
+      ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype : Submodule K _) :=
+    Module.Finite.equiv (Submodule.comapSubtypeEquivOfLe (lSpace_mono h0D)).symm
+  exact Module.Finite.of_submodule_quotient
+    ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype)
+
+end FiniteLSpace
+
+
+theorem range_lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD)
+      = ((adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype).map
+          ((adeleBdd D₁).comap (adeleBdd D₂).subtype).mkQ := by
+  classical
+  ext z
+  obtain ⟨α, rfl⟩ := Submodule.Quotient.mk_surjective _ z
+  simp only [LinearMap.mem_range, Submodule.mem_map, Submodule.mem_comap, Submodule.coe_subtype,
+    Submodule.mkQ_apply]
+  constructor
+  · rintro ⟨x, hx⟩
+    obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+    have hxeq : Submodule.Quotient.mk
+        ((diagonalHom K F).restrict (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f)
+        = (Submodule.Quotient.mk α :
+            adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) := hx
+    refine ⟨α, ?_, rfl⟩
+    have hdiag2 : (diagonalHom K F (f : F)) ∈ adeleBdd D₂ := diagonal_mem_adeleBdd_iff.mpr f.2
+    have hsub : (α : Place K F → F) - diagonalHom K F (f : F) ∈ adeleBdd D₁ := by
+      have hq := (Submodule.Quotient.eq _).mp hxeq.symm
+      simpa using hq
+    refine Submodule.mem_sup.mpr ⟨(α : Place K F → F) - diagonalHom K F (f : F), hsub,
+      diagonalHom K F (f : F), diagonal_mem_globalSub _, ?_⟩
+    abel
+  · rintro ⟨β, hβ, hβeq⟩
+    have hβ' : (β : Place K F → F) ∈ adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F) :=
+      Submodule.mem_inf.mpr ⟨β.2, hβ⟩
+    rw [adeleBdd_inf_sup_globalSub hD, ← map_diagonal_lSpace] at hβ'
+    obtain ⟨γ, hγ, δ, ⟨f, hf, hfδ⟩, hsum⟩ := Submodule.mem_sup.mp hβ'
+    refine ⟨Submodule.Quotient.mk ⟨f, hf⟩, ?_⟩
+    rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk ⟨f, hf⟩)
+          = Submodule.Quotient.mk ((diagonalHom K F).restrict
+              (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) ⟨f, hf⟩) from rfl,
+      ← hβeq, Submodule.Quotient.eq]
+    refine Submodule.mem_comap.mpr ?_
+    change diagonalHom K F f - (β : Place K F → F) ∈ adeleBdd D₁
+    have hβsub : diagonalHom K F f - (β : Place K F → F) = -γ := by
+      rw [← hsum, hfδ]; ring
+    rw [hβsub]; exact (adeleBdd D₁).neg_mem hγ
+
+
+theorem finrank_adeleBddSup_quotient [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) [hL : FiniteDimensional K (LSpace D₂)] :
+    Module.Finite K (↥(adeleBdd D₂ ⊔ globalSub K F)
+        ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) ∧
+      (finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+          ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) : ℤ)
+        = (Divisor.degree D₂ - ell D₂) - (Divisor.degree D₁ - ell D₁) := by
+  classical
+  let A : Submodule K (adeleBdd D₂) := (adeleBdd D₁).comap (adeleBdd D₂).subtype
+  let B : Submodule K (adeleBdd D₂) :=
+    (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype
+  have hAB : A ≤ B := Submodule.comap_mono le_sup_left
+  have hfinA : Module.Finite K (adeleBdd D₂ ⧸ A) := module_finite_adeleBdd_quotient hD
+  have hdimA : (finrank K (adeleBdd D₂ ⧸ A) : ℤ) = Divisor.degree D₂ - Divisor.degree D₁ :=
+    finrank_adeleBdd_quotient_eq hD
+  have hran : LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD) = B.map A.mkQ :=
+    range_lSpaceQuotientToAdeleBddQuotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hdimL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K)
+      ((LSpace D₁).comap (LSpace D₂).subtype)
+    rw [← hℓ₁] at h; exact h.symm
+  have hdimB : ell D₂ = finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) + ell D₁ := by
+    rw [← hran, LinearMap.finrank_range_of_inj
+      (lSpaceQuotientToAdeleBddQuotient_injective hD)]
+    exact hdimL
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  have hfinB : Module.Finite K (adeleBdd D₂ ⧸ B) := Module.Finite.equiv e3
+  have hdim2 : finrank K (adeleBdd D₂ ⧸ A)
+      = finrank K (adeleBdd D₂ ⧸ B) + finrank K (B.map A.mkQ : Submodule K _) := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K) (M := adeleBdd D₂ ⧸ A)
+      (B.map A.mkQ)
+    rw [LinearEquiv.finrank_eq e3] at h; omega
+  have e2 := LinearMap.quotientInfEquivSupQuotient (R := K)
+    (adeleBdd D₂) (adeleBdd D₁ ⊔ globalSub K F)
+  have hsup : adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F) = adeleBdd D₂ ⊔ globalSub K F := by
+    rw [← sup_assoc, sup_eq_left.mpr (adeleBdd_mono hD)]
+  have hB' : (adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype = B := by
+    rw [Submodule.comap_subtype_self, top_inf_eq]
+  let eL : (adeleBdd D₂ ⧸ B) ≃ₗ[K]
+      (adeleBdd D₂ ⧸ ((adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+        (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype)) :=
+    Submodule.quotEquivOfEq _ _ hB'.symm
+  have hfin_iso : Module.Finite K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype) :=
+    Module.Finite.equiv (eL.trans e2)
+  have hdim_iso : finrank K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype)
+      = finrank K (adeleBdd D₂ ⧸ B) :=
+    (LinearEquiv.finrank_eq (eL.trans e2)).symm
+  have hcast : (finrank K (adeleBdd D₂ ⧸ A) : ℤ)
+      = (finrank K (adeleBdd D₂ ⧸ B) : ℤ) + ((ell D₂ : ℤ) - (ell D₁ : ℤ)) := by
+    have hb : (ell D₂ : ℤ)
+        = (finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) : ℤ) + (ell D₁ : ℤ) := by
+      exact_mod_cast hdimB
+    push_cast [hdim2]; linarith
+  have hgoal : (finrank K (adeleBdd D₂ ⧸ B) : ℤ)
+      = Divisor.degree D₂ - ↑(ell D₂) - (Divisor.degree D₁ - ↑(ell D₁)) := by
+    linarith [hdimA, hcast]
+  clear_value eL
+  exact hsup ▸ ⟨hfin_iso, by rw [hdim_iso]; exact hgoal⟩
+
+section Index
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+
+theorem adeleBddSup_eq_of_degree_sub_ell_eq {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)]
+    (heq : Divisor.degree D₂ - ell D₂ = Divisor.degree D₁ - ell D₁) :
+    adeleBdd D₂ ⊔ globalSub K F = adeleBdd D₁ ⊔ globalSub K F := by
+  obtain ⟨hfin, hdim⟩ := finrank_adeleBddSup_quotient hD
+  rw [heq, sub_self] at hdim
+  refine le_antisymm ?_ (sup_le_sup_right (adeleBdd_mono hD) _)
+  have := hfin
+  have hd0 : finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) = 0 := by
+    exact_mod_cast hdim
+  have hsub : Subsingleton (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) :=
+    Module.finrank_zero_iff.mp hd0
+  have htop := Submodule.Quotient.subsingleton_iff.mp hsub
+  intro x hx
+  have hxc : (⟨x, hx⟩ : ↥(adeleBdd D₂ ⊔ globalSub K F)) ∈
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype := by
+    rw [htop]; exact Submodule.mem_top
+  exact hxc
+
+end Index
+
+namespace RiemannGenusReachedAt
+p2m_export "AlgebraicCurve.RiemannGenusReachedAt" "finite mk eq isMax"
+end RiemannGenusReachedAt
+namespace RiemannGenusReachedAt
+p2m_open_scoped "AlgebraicCurve.RiemannGenusReachedAt" in
+private theorem _root_.AlgebraicCurve.RiemannGenusReachedAt.eq_of_ge [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {D : Divisor K F} (hD : D₀ ≤ D) :
+    Divisor.degree D - ell D = γ - 1 := by
+  have := finiteDimensional_lSpace (K := K) D
+  have hge : Divisor.degree D₀ - (ell D₀ : ℤ) ≤ Divisor.degree D - ell D := by
+    have := ell_sub_ell_le_degree_sub_degree (K := K) hD
+    linarith
+  exact le_antisymm (h.isMax D) (h.eq ▸ hge)
+
+end RiemannGenusReachedAt
+p2m_export "AlgebraicCurve" "RiemannGenusReachedAt.eq_of_ge"
+
+theorem adeleSpace_eq_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    adeleSpace K F = adeleBdd D₀ ⊔ globalSub K F := by
+  refine le_antisymm ?_ (adeleBdd_sup_globalSub_le_adeleSpace D₀)
+  rw [adeleSpace, iSup_le_iff]
+  intro D
+  refine le_trans (adeleBdd_mono (le_sup_left : D ≤ D ⊔ D₀)) ?_
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have heq : Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) = Divisor.degree D₀ - ell D₀ :=
+    (h.eq_of_ge le_sup_right).trans h.eq.symm
+  have hsup := adeleBddSup_eq_of_degree_sub_ell_eq (K := K)
+    (le_sup_right : D₀ ≤ D ⊔ D₀) heq
+  rw [← hsup]
+  exact le_sup_left
+
+theorem indexOfSpecialty_eq_zero_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    indexOfSpecialty D₀ = 0 := by
+  rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap, ← adeleSpace_eq_of_genusReached h,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.finrank_zero_of_subsingleton
+
+
+
+theorem gate_indexOfSpecialty_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  have h1 := (indexOfSpecialty_eq_of_genusReached h D₀).2
+  have h2 := h.eq
+  have h3 := indexOfSpecialty_eq_zero_of_genusReached h
+  exact_mod_cast h3
+
+theorem gate_riemannInequality_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Divisor.degree D + 1 - γ ≤ (ell D : ℤ) := by
+  have heq := (indexOfSpecialty_eq_of_genusReached h D).2
+  have hnn : (0 : ℤ) ≤ indexOfSpecialty D := Int.natCast_nonneg _
+  linarith
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem adeleSpaceMul_add [HasPrincipalDivisors K F] (f g : F) :
+    adeleSpaceMul K F (f + g) = adeleSpaceMul K F f + adeleSpaceMul K F g := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, LinearMap.add_apply, Submodule.coe_add,
+    Pi.add_apply, add_mul]
+
+theorem adeleSpaceMul_zero [HasPrincipalDivisors K F] :
+    adeleSpaceMul K F (0 : F) = 0 := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, zero_mul, LinearMap.zero_apply,
+    Submodule.coe_zero, Pi.zero_apply]
+
+theorem weilSmul_add_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f + g) φ = weilSmul K F f φ + weilSmul K F g φ := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_add, LinearMap.add_apply, map_add]
+
+theorem weilSmul_zero_left [HasPrincipalDivisors K F]
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (0 : F) φ = 0 := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_zero, LinearMap.zero_apply, map_zero]
+
+theorem weilSmul_neg_left [HasPrincipalDivisors K F] (f : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (-f) φ = -weilSmul K F f φ := by
+  have h := weilSmul_add_left (K := K) (F := F) f (-f) φ
+  rw [add_neg_cancel, weilSmul_zero_left] at h
+  exact (neg_eq_of_add_eq_zero_right h.symm).symm
+
+theorem weilSmul_sub_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f - g) φ = weilSmul K F f φ - weilSmul K F g φ := by
+  rw [sub_eq_add_neg, weilSmul_add_left, weilSmul_neg_left, sub_eq_add_neg]
+
+theorem weilSmul_eq_zero_iff_left [HasPrincipalDivisors K F]
+    {f : F} {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    weilSmul K F f φ = 0 ↔ f = 0 := by
+  refine ⟨fun h => ?_, fun h => h ▸ weilSmul_zero_left φ⟩
+  by_contra hf
+  exact hφ (weilSmul_injective hf (h.trans (map_zero (weilSmul K F f)).symm))
+
+theorem weilSmul_left_injective [HasPrincipalDivisors K F]
+    {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    Function.Injective (fun f : F => weilSmul K F f φ) := by
+  intro f g hfg
+  have hsub : weilSmul K F (f - g) φ = 0 := by
+    rw [weilSmul_sub_left, sub_eq_zero]; exact hfg
+  exact sub_eq_zero.mp ((weilSmul_eq_zero_iff_left hφ).mp hsub)
+
+variable (K F) in
+def doubleResiduePairing [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) :
+    LSpace (W - D) × LSpace (W - D) →ₗ[K] omegaSpace D :=
+  (residuePairing K F W D hφ).coprod (residuePairing K F W D hμ)
+
+theorem doubleResiduePairing_apply_coe [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (g h : LSpace (W - D)) :
+    (doubleResiduePairing K F W D hφ hμ (g, h) : Module.Dual K (adeleSpace K F))
+      = weilSmul K F (g : F) φ + weilSmul K F (h : F) μ := by
+  simp only [doubleResiduePairing, LinearMap.coprod_apply, Submodule.coe_add,
+    residuePairing_apply_coe]
+
+theorem doubleResiduePairing_injective [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ) :
+    Function.Injective (doubleResiduePairing K F W D hφ hμ) := by
+  rw [injective_iff_map_eq_zero]
+  rintro ⟨g, h⟩ heq
+  have heq' : weilSmul K F (g : F) φ + weilSmul K F (h : F) μ = 0 := by
+    have hcoe := congrArg Subtype.val heq
+    rwa [doubleResiduePairing_apply_coe, Submodule.coe_zero] at hcoe
+  rcases eq_or_ne (h : F) 0 with hh0 | hh0
+  · rw [hh0, weilSmul_zero_left, add_zero] at heq'
+    have hg0 : (g : F) = 0 := (weilSmul_eq_zero_iff_left hφ0).mp heq'
+    exact Prod.ext (Subtype.ext hg0) (Subtype.ext hh0)
+  · exfalso
+    have hμeq : weilSmul K F (h : F) μ = -weilSmul K F (g : F) φ := by
+      have h2 : weilSmul K F (h : F) μ + weilSmul K F (g : F) φ = 0 := by
+        rw [add_comm]; exact heq'
+      exact eq_neg_of_add_eq_zero_left h2
+    have hLHS : weilSmul K F (h : F)⁻¹ (weilSmul K F (h : F) μ) = μ := by
+      rw [← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hh0, weilSmul_one,
+        LinearMap.id_apply]
+    have hRHS : weilSmul K F (h : F)⁻¹ (-weilSmul K F (g : F) φ)
+        = weilSmul K F (-(g : F) * (h : F)⁻¹) φ := by
+      rw [map_neg, ← LinearMap.comp_apply, ← weilSmul_mul, neg_mul, weilSmul_neg_left]
+    exact hindep (-(g : F) * (h : F)⁻¹) (by rw [← hLHS, hμeq, hRHS])
+
+theorem two_mul_ell_le_indexOfSpecialty [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ)
+    [Module.Finite K (omegaSpace (K := K) (F := F) D)]
+    [Module.Finite K (LSpace (K := K) (F := F) (W - D))] :
+    2 * ell (W - D) ≤ indexOfSpecialty D := by
+  have hinj := doubleResiduePairing_injective W D hφ hμ hφ0 hindep
+  have hle := LinearMap.finrank_le_finrank_of_injective hinj
+  rw [Module.finrank_prod] at hle
+  rw [← finrank_omegaSpace_eq_indexOfSpecialty, two_mul]
+  exact hle
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+section Finiteness
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+theorem omegaSpace_finite_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Module.Finite K (omegaSpace (K := K) (F := F) D) := by
+  have := (indexOfSpecialty_eq_of_genusReached h D).1
+  exact Module.Finite.equiv (omegaSpaceEquivIndexDual D).symm
+
+end Finiteness
+
+section ParametricRankOne
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+
+theorem exists_weilSmul_eq_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {φ μ : Module.Dual K (adeleSpace K F)} {W : Divisor K F}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (hφ0 : φ ≠ 0) :
+    ∃ f : F, μ = weilSmul K F f φ := by
+  by_contra hcon
+  push Not at hcon
+  obtain ⟨P⟩ := ‹Nonempty (Place K F)›
+  set n : ℕ := 3 * γ.natAbs + 2 * (Divisor.degree W).natAbs + 4 with hn
+  set D : Divisor K F := -Finsupp.single P (n : ℤ) with hD
+  have hdegD : Divisor.degree D = -(n : ℤ) * (P.deg : ℤ) := by
+    rw [hD, map_neg, Divisor.degree_single]; ring
+  have hdegWD : Divisor.degree (W - D) = Divisor.degree W + (n : ℤ) * (P.deg : ℤ) := by
+    rw [map_sub, hdegD]; ring
+  have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+  have habsγ : -(|γ|) ≤ γ ∧ γ ≤ |γ| := ⟨neg_abs_le _, le_abs_self _⟩
+  have habsW : -|Divisor.degree W| ≤ Divisor.degree W ∧
+      Divisor.degree W ≤ |Divisor.degree W| := ⟨neg_abs_le _, le_abs_self _⟩
+  have hn_ge : 3 * |γ| + 2 * |Divisor.degree W| + 4 ≤ (n : ℤ) := by
+    rw [hn]; push_cast [Int.natCast_natAbs]; ring_nf; omega
+  have hndegP : (n : ℤ) ≤ (n : ℤ) * (P.deg : ℤ) := by nlinarith [Int.natCast_nonneg n]
+  have hellD : ell D = 0 := ell_eq_zero_of_degree_neg (by rw [hdegD]; nlinarith)
+  have hiD : (indexOfSpecialty D : ℤ) = (n : ℤ) * (P.deg : ℤ) - 1 + γ := by
+    have hidx := (indexOfSpecialty_eq_of_genusReached h D).2
+    rw [hellD, hdegD] at hidx; push_cast at hidx; linarith
+  have hlowerWD : Divisor.degree W + (n : ℤ) * (P.deg : ℤ) + 1 - γ
+      ≤ (ell (W - D) : ℤ) := by
+    have hlow := gate_riemannInequality_of_genusReached h (W - D)
+    rw [hdegWD] at hlow; exact hlow
+  have := omegaSpace_finite_of_genusReached h D
+  have := finiteDimensional_lSpace (K := K) (W - D)
+  have hdbl : (2 * ell (W - D) : ℤ) ≤ (indexOfSpecialty D : ℤ) := by
+    exact_mod_cast two_mul_ell_le_indexOfSpecialty W D hφ hμ hφ0 hcon
+  rw [hiD] at hdbl
+  nlinarith [habsγ.1, habsγ.2, habsW.1, habsW.2]
+
+theorem weilDifferentialRankOne_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    WeilDifferentialRankOne K F := by
+  intro φ hφmem hφ0 μ hμmem
+  obtain ⟨W₁, hφW₁⟩ := mem_weilDifferentialModule_iff.mp hφmem
+  obtain ⟨W₂, hμW₂⟩ := mem_weilDifferentialModule_iff.mp hμmem
+  have hφW : φ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_left hφW₁
+  have hμW : μ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_right hμW₂
+  obtain ⟨f, hf⟩ := exists_weilSmul_eq_of_genusReached h hφW hμW hφ0
+  exact ⟨f, hf, fun f' hf' => weilSmul_left_injective hφ0 (hf'.symm.trans hf)⟩
+
+end ParametricRankOne
+
+theorem residuePairing_surjective_of_rankOne_max [HasPrincipalDivisors K F]
+    (hRankOne : WeilDifferentialRankOne K F)
+    {W : Divisor K F} {φ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hφ0 : φ ≠ 0)
+    (hWmax : ∀ E : Divisor K F, φ ∈ omegaSpace E → E ≤ W) (D : Divisor K F) :
+    Function.Surjective (residuePairing K F W D hφ) := by
+  rintro ⟨μ, hμD⟩
+  have hφmem : φ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule W hφ
+  have hμmem : μ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule D hμD
+  obtain ⟨f, hf, -⟩ := hRankOne hφmem hφ0 hμmem
+  rcases eq_or_ne f 0 with rfl | hf0
+  · have hμ0 : (⟨μ, hμD⟩ : omegaSpace D) = 0 :=
+      Subtype.ext (hf.trans (weilSmul_zero_left φ))
+    exact ⟨0, (map_zero _).trans hμ0.symm⟩
+  · obtain ⟨P, hPord, _⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+    have hPinv : ∀ v, (-P) v = v.ord f⁻¹ := fun v => by
+      rw [Finsupp.neg_apply, hPord v, v.ord_inv]
+    have hinv : weilSmul K F f⁻¹ μ = φ := by
+      rw [hf, ← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hf0, weilSmul_one,
+        LinearMap.id_apply]
+    have hφD : φ ∈ omegaSpace (D + -P) := by
+      rw [← hinv]; exact weilSmul_mem_omegaSpace_add (inv_ne_zero hf0) hPinv hμD
+    have hDP : D + -P ≤ W := hWmax _ hφD
+    have hfL : f ∈ LSpace (W - D) := by
+      rw [mem_lSpace_iff_ord]; refine Or.inr fun v => ?_
+      have hv := hDP v
+      rw [Finsupp.add_apply, Finsupp.neg_apply, hPord v] at hv
+      rw [Finsupp.sub_apply]; linarith
+    exact ⟨⟨f, hfL⟩, Subtype.ext hf.symm⟩
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem exists_riemannGenusReachedAt_of_bounded
+    [IsCurveOver K F] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    ∃ (γ : ℤ) (D₀ : Divisor K F), RiemannGenusReachedAt γ D₀ := by
+  obtain ⟨γ, hγ⟩ := hbdd
+  obtain ⟨M, ⟨D₀, hD₀⟩, hMmax⟩ :=
+    Int.exists_greatest_of_bdd
+      (P := fun n => ∃ D : Divisor K F, Divisor.degree D - ell D = n)
+      ⟨γ, fun n ⟨D, hD⟩ => hD ▸ hγ D⟩
+      ⟨Divisor.degree (0 : Divisor K F) - ell (0 : Divisor K F), 0, rfl⟩
+  refine ⟨M + 1, D₀, ?_, ?_, ?_⟩
+  · exact finiteDimensional_lSpace D₀
+  · rw [hD₀]; ring
+  · intro D
+    have := hMmax (Divisor.degree D - ell D) ⟨D, rfl⟩
+    linarith
+
+theorem stichtenothGenusExists_of_bounded
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    StichtenothGenusExists K F :=
+  ⟨‹_›, ‹_›, exists_riemannGenusReachedAt_of_bounded hbdd⟩
+
+
+theorem indexOfSpecialty_sub_of_ge [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₀ D : Divisor K F} (hD : D₀ ≤ D)
+    [FiniteDimensional K (LSpace D)]
+    [hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀)] :
+    Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D) ∧
+      (Divisor.degree D - ell D) - (Divisor.degree D₀ - ell D₀)
+        = (indexOfSpecialty D₀ : ℤ) - (indexOfSpecialty D : ℤ) := by
+  have hABsub : adeleBdd D₀ ⊔ globalSub K F ≤ adeleBdd D ⊔ globalSub K F :=
+    sup_le_sup_right (adeleBdd_mono hD) _
+  have hBCsub : adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+    adeleBdd_sup_globalSub_le_adeleSpace _
+  obtain ⟨hfinBA, hdimBA⟩ := finrank_adeleBddSup_quotient (K := K) hD
+  have := hfinBA
+  have hfinCA : Module.Finite K (adeleSpace K F ⧸
+      (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [← adeleBddPrincipal_eq_comap]; exact hfin
+  obtain ⟨hfinCB, hdimCB⟩ := Submodule.finrank_quotient_chain'
+    (A := adeleBdd D₀ ⊔ globalSub K F) (B := adeleBdd D ⊔ globalSub K F)
+    (C := adeleSpace K F) hABsub hBCsub
+  have hi0 : indexOfSpecialty D₀
+      = finrank K (adeleSpace K F ⧸
+        (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap]
+  have hiD : indexOfSpecialty D
+      = finrank K (adeleSpace K F ⧸
+        (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap]
+  have := hfinCB
+  obtain ⟨_, hdimCA⟩ := Submodule.finrank_quotient_chain
+    (A := adeleBdd D₀ ⊔ globalSub K F) (B := adeleBdd D ⊔ globalSub K F)
+    (C := adeleSpace K F) hABsub hBCsub
+  refine ⟨?_, ?_⟩
+  · rw [show adeleBddPrincipal K F D
+        = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype
+      from adeleBddPrincipal_eq_comap D]
+    exact hfinCB
+  · have hcast : (indexOfSpecialty D₀ : ℤ)
+        = (indexOfSpecialty D : ℤ)
+          + (finrank K (↥(adeleBdd D ⊔ globalSub K F)
+              ⧸ (adeleBdd D₀ ⊔ globalSub K F).comap
+                (adeleBdd D ⊔ globalSub K F).subtype) : ℤ) := by
+      rw [hiD, hi0]; exact_mod_cast hdimCA
+    linarith [hdimBA, hcast]
+
+theorem degreeSub_ell_le_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {D₀ : Divisor K F}
+    (hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀))
+    (D : Divisor K F) :
+    Divisor.degree D - ell D ≤ (Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀ := by
+  have := hfin
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have hmono : Divisor.degree D - (ell D : ℤ)
+      ≤ Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) (le_sup_left : D ≤ D ⊔ D₀)
+    linarith
+  obtain ⟨_, heq⟩ :=
+    indexOfSpecialty_sub_of_ge (K := K) (le_sup_right : D₀ ≤ D ⊔ D₀)
+  have hi0 : (0 : ℤ) ≤ indexOfSpecialty (D ⊔ D₀) := Int.natCast_nonneg _
+  linarith
+
+theorem riemannGenusBounded_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hfin : IndexOfSpecialtyFinite K F) :
+    RiemannGenusBounded K F := by
+  obtain ⟨D₀, hD₀⟩ := hfin
+  exact ⟨(Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀,
+    degreeSub_ell_le_of_indexFinite hD₀⟩
+
+theorem stichtenothGenusExists_of_indexFinite
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hfin : IndexOfSpecialtyFinite K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_bounded (riemannGenusBounded_of_indexFinite hfin)
+
+theorem indexOfSpecialtyFinite_of_stichtenothGenusExists
+    [IsCurveOver K F] (hSG : StichtenothGenusExists K F) :
+    IndexOfSpecialtyFinite K F := by
+  obtain ⟨hne, hL0, γ, D₀, hD₀⟩ := hSG
+  have := hne; have := hL0
+  refine ⟨D₀, ?_⟩
+  rw [show adeleBddPrincipal K F D₀
+      = (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype
+    from adeleBddPrincipal_eq_comap D₀, ← adeleSpace_eq_of_genusReached hD₀,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.Finite.of_finite
+
+theorem stichtenothGenusExists_iff_indexFinite
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] :
+    StichtenothGenusExists K F ↔ IndexOfSpecialtyFinite K F :=
+  ⟨indexOfSpecialtyFinite_of_stichtenothGenusExists,
+    stichtenothGenusExists_of_indexFinite⟩
+
+theorem gate_indexOfSpecialty_engine_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  exact_mod_cast indexOfSpecialty_eq_zero_of_genusReached h
+
+theorem gate_stichtenothGenus_le_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {D₀ : Divisor K F}
+    (hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀))
+    {γ : ℤ} {D₁ : Divisor K F} (h : RiemannGenusReachedAt γ D₁) :
+    γ - 1 ≤ (Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀ := by
+  have := degreeSub_ell_le_of_indexFinite hfin D₁
+  rw [h.eq] at this; exact this
+
+theorem gate_riemannGenusBounded_of_reachedAt
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    RiemannGenusBounded K F :=
+  ⟨γ - 1, h.isMax⟩
+
+theorem gate_indexOfSpecialtyFinite_at_zero [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F (0 : Divisor K F)) :=
+  (indexOfSpecialty_eq_of_genusReached h 0).1
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem mul_mem_lSpace_add {D E : Divisor K F} {f g : F}
+    (hf : f ∈ LSpace D) (hg : g ∈ LSpace E) :
+    f * g ∈ LSpace (D + E) := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · rw [zero_mul]; exact (LSpace _).zero_mem
+  rcases eq_or_ne g 0 with rfl | hg0
+  · rw [mul_zero]; exact (LSpace _).zero_mem
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun v => ?_
+  rw [Finsupp.add_apply, neg_add, v.ord_mul hf0 hg0]
+  exact add_le_add ((mem_lSpace_iff_ord.mp hf).resolve_left hf0 v)
+    ((mem_lSpace_iff_ord.mp hg).resolve_left hg0 v)
+
+theorem pow_mem_lSpace_nsmul {B : Divisor K F} {f : F} (hf : f ∈ LSpace B) (j : ℕ) :
+    f ^ j ∈ LSpace (j • B) := by
+  induction j with
+  | zero => simpa using one_mem_lSpace_zero (K := K) (F := F)
+  | succ j ih =>
+    rw [pow_succ, succ_nsmul]
+    exact mul_mem_lSpace_add ih hf
+
+namespace PoleDivisorPackage
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degB_eq u B hB_eff n lin_indep mk c x hn_pos \
+  hu_mem mk.injEq hx_mem"
+p2m_open "AlgebraicCurve.PoleDivisorPackage"
+
+variable (P : PoleDivisorPackage K F)
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.pow_mul_u_mem_lSpace (j : ℕ) (i : Fin P.n)
+    :
+    P.x ^ j * P.u i ∈ LSpace ((j + P.c) • P.B) := by
+  rw [add_nsmul]
+  exact mul_mem_lSpace_add (pow_mem_lSpace_nsmul P.hx_mem j) (P.hu_mem i)
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "pow_mul_u_mem_lSpace"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.pow_mul_u_mem_lSpace_of_le {j m : ℕ}
+    (hjm : j + P.c ≤ m) (i : Fin P.n) :
+    P.x ^ j * P.u i ∈ LSpace (m • P.B) := by
+  refine lSpace_mono ?_ (P.pow_mul_u_mem_lSpace j i)
+  intro v
+  have hBv : (0 : ℤ) ≤ P.B v := P.hB_eff v
+  change ((j + P.c) • P.B) v ≤ (m • P.B) v
+  simp only [Finsupp.smul_apply, nsmul_eq_mul]
+  exact mul_le_mul_of_nonneg_right (by exact_mod_cast hjm) hBv
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "pow_mul_u_mem_lSpace_of_le"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.ell_nsmul_poleDivisor_ge [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    (P.n : ℤ) * (m - P.c + 1) ≤ ell (m • P.B) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  set g : Fin (m - P.c + 1) × Fin P.n → LSpace (m • P.B) :=
+    fun p => ⟨P.x ^ (p.1 : ℕ) * P.u p.2,
+      P.pow_mul_u_mem_lSpace_of_le (by have := p.1.isLt; omega) p.2⟩
+    with hgdef
+  have hsub : LinearIndependent K (fun p => (g p : F)) := by
+    have heq : (fun p => (g p : F))
+        = (fun p : ℕ × Fin P.n => P.x ^ p.1 * P.u p.2)
+            ∘ (fun p : Fin (m - P.c + 1) × Fin P.n => ((p.1 : ℕ), p.2)) := by
+      funext p; rfl
+    rw [heq]
+    refine P.lin_indep.comp _ ?_
+    intro p q hpq
+    simp only [Prod.mk.injEq] at hpq
+    exact Prod.ext (Fin.val_injective hpq.1) hpq.2
+  have hg : LinearIndependent K g := hsub.of_comp (LSpace (m • P.B)).subtype
+  have hcard := hg.fintype_card_le_finrank
+  rw [Fintype.card_prod, Fintype.card_fin, Fintype.card_fin] at hcard
+  have hZ : ((m - P.c + 1) * P.n : ℤ) ≤ (ell (m • P.B) : ℤ) := by exact_mod_cast hcard
+  have heq : (((m - P.c + 1 : ℕ) : ℤ) * P.n : ℤ) = (P.n : ℤ) * ((m : ℤ) - P.c + 1) := by
+    rw [Nat.cast_add, Nat.cast_sub hm, Nat.cast_one]; ring
+  linarith
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "ell_nsmul_poleDivisor_ge"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.degree_nsmul_sub_ell_le [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    Divisor.degree (m • P.B) - ell (m • P.B) ≤ (P.n : ℤ) * (P.c - 1) := by
+  have hge := P.ell_nsmul_poleDivisor_ge hm
+  have hdeg : Divisor.degree (m • P.B) = (m : ℤ) * P.n := by
+    rw [show m • P.B = (m : ℤ) • P.B from (natCast_zsmul _ _).symm,
+      Divisor.degree.map_zsmul, smul_eq_mul, P.degB_eq]
+  linarith
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degree_nsmul_sub_ell_le"
+end PoleDivisorPackage
+
+namespace PoleDivisorPackage
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degB_eq u B hB_eff n lin_indep mk c x hn_pos \
+  hu_mem mk.injEq hx_mem"
+end PoleDivisorPackage
+namespace PoleDivisorPackage
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.ell_nsmul_sub_pos [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) {A : Divisor K F} (hA : 0 ≤ A) {m : ℕ} (hm : P.c ≤ m)
+    (hbig : Divisor.degree A < (P.n : ℤ) * (m - P.c + 1)) :
+    0 < ell (m • P.B - A) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  have hle : m • P.B - A ≤ m • P.B := by
+    intro v
+    have hAv : (0 : ℤ) ≤ A v := hA v
+    rw [Finsupp.sub_apply]
+    linarith
+  have h48 := ell_sub_ell_le_degree_sub_degree (K := K) hle
+  rw [map_sub, sub_sub_cancel] at h48
+  have h412 := P.ell_nsmul_poleDivisor_ge hm
+  have : (0 : ℤ) < (ell (m • P.B - A) : ℤ) := by linarith
+  exact_mod_cast this
+
+end PoleDivisorPackage
+p2m_export "AlgebraicCurve" "PoleDivisorPackage.ell_nsmul_sub_pos"
+namespace PoleDivisorPackage
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.degree_sub_ell_le [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) (D : Divisor K F) :
+    Divisor.degree D - ell D ≤ (P.n : ℤ) * (P.c - 1) := by
+  classical
+  set D' : Divisor K F := D ⊔ 0 with hD'def
+  have hD'eff : 0 ≤ D' := le_sup_right
+  have hDD' : D ≤ D' := le_sup_left
+  have := finiteDimensional_lSpace (K := K) D'
+  have hmono : Divisor.degree D - (ell D : ℤ) ≤ Divisor.degree D' - ell D' := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hDD'
+    linarith
+  set m : ℕ := P.c + (Divisor.degree D').toNat with hmdef
+  have hcm : P.c ≤ m := Nat.le_add_right _ _
+  have hdegD' : 0 ≤ Divisor.degree D' := Divisor.degree_nonneg_of_nonneg hD'eff
+  have hbig : Divisor.degree D' < (P.n : ℤ) * (m - P.c + 1) := by
+    have hcast : ((m : ℤ) - P.c) = Divisor.degree D' := by
+      simp only [hmdef, Nat.cast_add, add_sub_cancel_left, Int.toNat_of_nonneg hdegD']
+    rw [hcast]
+    have hn1 : (1 : ℤ) ≤ P.n := by exact_mod_cast P.hn_pos
+    nlinarith
+  have hellpos := P.ell_nsmul_sub_pos hD'eff hcm hbig
+  have hnebot : LSpace (m • P.B - D') ≠ ⊥ :=
+    fun h => by rw [ell, h, finrank_bot] at hellpos; exact lt_irrefl 0 hellpos
+  obtain ⟨z, hzL, hz0⟩ := (Submodule.ne_bot_iff _).mp hnebot
+  obtain ⟨Dz, hDzord, hDzdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) z hz0
+  have hzmem := (mem_lSpace_iff_ord.mp hzL).resolve_left hz0
+  have hD'le : D' ≤ m • P.B + Dz := by
+    intro v
+    have := hzmem v
+    simp only [Finsupp.add_apply, Finsupp.sub_apply, neg_sub] at this ⊢
+    rw [hDzord]; linarith
+  have hellshift : ell (m • P.B + Dz) = ell (m • P.B) :=
+    (LinearEquiv.finrank_eq (lSpaceShiftEquiv (m • P.B) hz0 hDzord)).symm
+  have hdegshift : Divisor.degree (m • P.B + Dz) = Divisor.degree (m • P.B) := by
+    rw [map_add, hDzdeg, add_zero]
+  have := finiteDimensional_lSpace (K := K) (m • P.B + Dz)
+  have hmono' : Divisor.degree D' - (ell D' : ℤ)
+      ≤ Divisor.degree (m • P.B + Dz) - ell (m • P.B + Dz) := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hD'le
+    linarith
+  rw [hellshift, hdegshift] at hmono'
+  have h412 := P.degree_nsmul_sub_ell_le hcm
+  linarith
+
+end PoleDivisorPackage
+p2m_export "AlgebraicCurve" "PoleDivisorPackage.degree_sub_ell_le"
+
+theorem riemannGenusBounded_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    RiemannGenusBounded K F :=
+  ⟨(P.n : ℤ) * (P.c - 1), P.degree_sub_ell_le⟩
+
+theorem stichtenothGenusExists_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_bounded (riemannGenusBounded_of_poleDivisorPackage P)
+
+theorem indexOfSpecialtyFinite_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_stichtenothGenusExists
+    (stichtenothGenusExists_of_poleDivisorPackage P)
+
+theorem indexOfSpecialtyFinite_of_hasPoleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (h : HasPoleDivisorPackage K F) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_poleDivisorPackage h.some
+
+theorem stichtenothGenusExists_of_hasPoleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (h : HasPoleDivisorPackage K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_poleDivisorPackage h.some
+
+theorem gate_stichtenothGenus_le_of_poleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F)
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    γ ≤ (P.n : ℤ) * (P.c - 1) + 1 := by
+  have := P.degree_sub_ell_le D₀
+  rw [h.eq] at this; linarith
+
+theorem gate_ell_c_nsmul_ge [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    (P.n : ℤ) ≤ ell (P.c • P.B) := by
+  have h := P.ell_nsmul_poleDivisor_ge (le_refl P.c)
+  simp only [sub_self, zero_add, mul_one] at h
+  exact h
+
+theorem gate_x_transcendental_of_poleDivisorPackage (P : PoleDivisorPackage K F) :
+    LinearIndependent K (fun j : ℕ => P.x ^ j * P.u ⟨0, P.hn_pos⟩) := by
+  refine P.lin_indep.comp (fun j => (j, ⟨0, P.hn_pos⟩)) ?_
+  intro a b hab
+  exact (Prod.mk.injEq .. ▸ hab).1
+
+theorem gate_u_linearIndependent_of_poleDivisorPackage (P : PoleDivisorPackage K F) :
+    LinearIndependent K P.u := by
+  have h : LinearIndependent K (fun i : Fin P.n => P.x ^ (0 : ℕ) * P.u i) := by
+    refine P.lin_indep.comp (fun i => (0, i)) ?_
+    intro a b hab
+    exact (Prod.mk.injEq .. ▸ hab).2
+  simpa using h
+
+end AlgebraicCurve
+
+end
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+scoped instance instSumRamificationInertia_port {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F']
+    [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+    [HasPrincipalDivisors K F'] : SumRamificationInertia K F F' :=
+  ⟨fun v => Place.sum_ramificationIndex_mul_inertiaDeg v⟩
+end AlgebraicCurve
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+
+namespace TranscendenceTower
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF poleDivisor RegularOutside hx_indep hxreg v \
+  mk.injEq mk hvdeg x hxv"
+p2m_open "AlgebraicCurve.TranscendenceTower"
+
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F]
+variable (T : TranscendenceTower K E F)
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.x_ne_zero : T.x ≠ 0 := fun h => by
+  have := T.hxv; rw [h, Place.ord_zero] at this; exact absurd this (by decide)
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "x_ne_zero"
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+theorem xF_ne_zero : T.xF ≠ 0 :=
+  fun h => T.x_ne_zero ((algebraMap E F).injective (by rwa [map_zero]))
+
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.poleDivisor_apply (w : Place K F) :
+    T.poleDivisor w = (w.ramificationIndex E : ℤ) * (Finsupp.single T.v 1) (w.restrict E) :=
+  Divisor.pullback_apply (Finsupp.single T.v 1) w
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "poleDivisor_apply"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.poleDivisor_nonneg :
+    0 ≤ T.poleDivisor := by
+  classical
+  intro w
+  rw [Finsupp.coe_zero, Pi.zero_apply, T.poleDivisor_apply, Finsupp.single_apply]
+  refine mul_nonneg (Int.natCast_nonneg _) ?_
+  split_ifs <;> simp
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "poleDivisor_nonneg"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.xF_mem_lSpace_poleDivisor :
+    T.xF ∈ LSpace T.poleDivisor := by
+  classical
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun w => ?_
+  rw [T.poleDivisor_apply, Place.ord_restrict, Finsupp.single_apply]
+  rcases eq_or_ne (w.restrict E) T.v with hw | hw
+  · simp only [hw, T.hxv, ite_true, mul_one, mul_neg_one, le_refl]
+  · simp only [ite_eq_right (Ne.symm hw), mul_zero, neg_zero]
+    exact mul_nonneg (Int.natCast_nonneg _) (T.hxreg _ hw)
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF_mem_lSpace_poleDivisor"
+
+private theorem _root_.AlgebraicCurve.TranscendenceTower.degree_poleDivisor_eq_finrank :
+    Divisor.degree T.poleDivisor = (Module.finrank E F : ℤ) := by
+  rw [poleDivisor, Divisor.degree_pullback, Divisor.degree_single, T.hvdeg]
+  push_cast; ring
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "degree_poleDivisor_eq_finrank"
+omit [FiniteDimensional E F] in
+private theorem
+  _root_.AlgebraicCurve.TranscendenceTower.mem_lSpace_nsmul_poleDivisor_of_regular_outside {f : F}
+    (hreg : ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord f)
+    {c : ℕ} (hc : ∀ w ∈ T.v.fiber F, -(c : ℤ) ≤ w.ord f) :
+    f ∈ LSpace (c • T.poleDivisor) := by
+  classical
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact (LSpace _).zero_mem
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun w => ?_
+  rw [Finsupp.smul_apply, T.poleDivisor_apply, Finsupp.single_apply, nsmul_eq_mul]
+  rcases eq_or_ne (w.restrict E) T.v with hw | hw
+  · simp only [hw, ite_true, mul_one]
+    have he : (1 : ℤ) ≤ w.ramificationIndex E := by
+      exact_mod_cast w.ramificationIndex_pos (F := E)
+    have hbdd := hc w (Place.mem_fiber.mpr hw)
+    nlinarith [Int.natCast_nonneg c]
+  · simp only [ite_eq_right (Ne.symm hw), mul_zero, neg_zero]
+    exact hreg w hw
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "mem_lSpace_nsmul_poleDivisor_of_regular_outside"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.exists_forall_mem_lSpace_nsmul_poleDivisor
+    {n : ℕ} (u : Fin n → F)
+    (hreg : ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)) :
+    ∃ c : ℕ, ∀ i, u i ∈ LSpace (c • T.poleDivisor) := by
+  classical
+  refine ⟨(Finset.univ : Finset (Fin n)).sup fun i =>
+    (T.v.fiber F).sup fun w => (-(w.ord (u i))).toNat,
+    fun i => T.mem_lSpace_nsmul_poleDivisor_of_regular_outside (hreg i) ?_⟩
+  intro w hw
+  have h1 : (-(w.ord (u i))).toNat
+      ≤ (T.v.fiber F).sup fun w' => (-(w'.ord (u i))).toNat :=
+    Finset.le_sup (f := fun w' => (-(w'.ord (u i))).toNat) hw
+  have h2 : ((T.v.fiber F).sup fun w' => (-(w'.ord (u i))).toNat)
+      ≤ (Finset.univ : Finset (Fin n)).sup fun i' =>
+          (T.v.fiber F).sup fun w' => (-(w'.ord (u i'))).toNat :=
+    Finset.le_sup (f := fun i' => (T.v.fiber F).sup fun w' => (-(w'.ord (u i'))).toNat)
+      (Finset.mem_univ i)
+  have htnat : -(w.ord (u i)) ≤ ((-(w.ord (u i))).toNat : ℤ) := Int.self_le_toNat _
+  omega
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "exists_forall_mem_lSpace_nsmul_poleDivisor"
+end TranscendenceTower
+
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F]
+
+section PrincipalDivisors
+
+variable [HasPrincipalDivisors K F]
+
+namespace IntegralBasisInLSpace
+p2m_export "AlgebraicCurve.IntegralBasisInLSpace" "hu_indep c u mk.injEq hu_mem mk"
+end IntegralBasisInLSpace
+p2m_open_scoped "AlgebraicCurve.IntegralBasisInLSpace" in
+def IntegralBasisInLSpace.ofRegularOutside (T : TranscendenceTower K E F)
+    (u : Fin (Module.finrank E F) → F) (hu_indep : LinearIndependent E u)
+    (hreg : ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)) :
+    IntegralBasisInLSpace T where
+  c := (T.exists_forall_mem_lSpace_nsmul_poleDivisor u hreg).choose
+  u := u
+  hu_indep := hu_indep
+  hu_mem := (T.exists_forall_mem_lSpace_nsmul_poleDivisor u hreg).choose_spec
+
+omit [FiniteDimensional E F] in
+theorem hasIntegralBasisInLSpace_of_regularOutside (T : TranscendenceTower K E F)
+    (h : HasIntegralBasisRegularOutside K E F T) :
+    HasIntegralBasisInLSpace K E F T := by
+  obtain ⟨u, hu_indep, hreg⟩ := h
+  exact ⟨IntegralBasisInLSpace.ofRegularOutside T u hu_indep hreg⟩
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+theorem linearIndependent_pow_mul {x : E} {n : ℕ} {u : Fin n → F}
+    (hx : LinearIndependent K (fun j : ℕ => x ^ j)) (hu : LinearIndependent E u) :
+    LinearIndependent K (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2) := by
+  have heq : (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2)
+      = (fun p : ℕ × Fin n => (x ^ p.1) • u p.2) := by
+    funext p
+    rw [Algebra.smul_def, map_pow]
+  rw [heq]
+  exact linearIndependent_smul (R := K) (S := E) (A := F) hx hu
+
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+def PoleDivisorPackage.ofTranscendenceTower (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    PoleDivisorPackage K F where
+  x := T.xF
+  B := T.poleDivisor
+  hB_eff := T.poleDivisor_nonneg
+  hx_mem := T.xF_mem_lSpace_poleDivisor
+  n := Module.finrank E F
+  hn_pos := Module.finrank_pos
+  degB_eq := T.degree_poleDivisor_eq_finrank
+  c := IB.c
+  u := IB.u
+  hu_mem := IB.hu_mem
+  lin_indep := linearIndependent_pow_mul T.hx_indep IB.hu_indep
+
+theorem hasPoleDivisorPackage_of_transcendenceTower
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    HasPoleDivisorPackage K F :=
+  ⟨PoleDivisorPackage.ofTranscendenceTower T IB⟩
+
+theorem hasPoleDivisorPackage_of_hasIntegralBasisInLSpace
+    (T : TranscendenceTower K E F) (h : HasIntegralBasisInLSpace K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_transcendenceTower T h.some
+
+theorem hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside
+    (T : TranscendenceTower K E F) (h : HasIntegralBasisRegularOutside K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisInLSpace T
+    (hasIntegralBasisInLSpace_of_regularOutside T h)
+
+end PrincipalDivisors
+
+theorem indexOfSpecialtyFinite_of_transcendenceTower [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem stichtenothGenusExists_of_transcendenceTower [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem gate_ofTranscendenceTower_n_eq [HasPrincipalDivisors K F] (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    (PoleDivisorPackage.ofTranscendenceTower T IB).n = Module.finrank E F := rfl
+
+theorem gate_ofTranscendenceTower_B_eq [HasPrincipalDivisors K F] (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    (PoleDivisorPackage.ofTranscendenceTower T IB).B = T.poleDivisor := rfl
+
+theorem gate_ofTranscendenceTower_x_transcendental [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    LinearIndependent K
+      (fun j : ℕ => T.xF ^ j *
+        (PoleDivisorPackage.ofTranscendenceTower T IB).u ⟨0, Module.finrank_pos⟩) :=
+  gate_x_transcendental_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem gate_degree_pullback_single_of_deg_eq [HasPrincipalDivisors K F]
+    (v : Place K E) (d : ℕ) (hd : v.deg = d) :
+    Divisor.degree (Divisor.pullback F (Finsupp.single v (1 : ℤ)))
+      = (Module.finrank E F : ℤ) * d := by
+  rw [Divisor.degree_pullback, Divisor.degree_single, hd]; ring
+
+theorem gate_stichtenothGenus_le_of_transcendenceTower [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T)
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    γ ≤ (Module.finrank E F : ℤ) * (IB.c - 1) + 1 :=
+  gate_stichtenothGenus_le_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB) h
+
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open Module
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~restrict_plac\
+  eOfPrime~placeOfPrime~comap_algebraMap_ne_top"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral {f : F}
+    (hf : IsIntegral w.toValuationSubring f) :
+    f ∈ w.toValuationSubring := by
+  obtain ⟨y, hy⟩ := IsIntegrallyClosed.isIntegral_iff.mp hf
+  exact hy ▸ y.2
+
+p2m_export "AlgebraicCurve.Place" "mem_of_isIntegral"
+
+theorem ord_nonneg_of_isIntegral {f : F} (hf : IsIntegral w.toValuationSubring f) :
+    0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral hf)
+
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral_of_algebraMap_mem {A : Type*}
+    [CommRing A] [Algebra A F]
+    (hA : ∀ a : A, algebraMap A F a ∈ w.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : f ∈ w.toValuationSubring := by
+  let : Algebra A w.toValuationSubring :=
+    ((algebraMap A F).codRestrict w.toValuationSubring.toSubring hA).toAlgebra
+  have : IsScalarTower A w.toValuationSubring F :=
+    IsScalarTower.of_algebraMap_eq fun a => rfl
+  exact w.mem_of_isIntegral hf.tower_top
+
+p2m_export "AlgebraicCurve.Place" "mem_of_isIntegral_of_algebraMap_mem"
+
+theorem ord_nonneg_of_isIntegral_of_algebraMap_mem {A : Type*} [CommRing A] [Algebra A F]
+    (hA : ∀ a : A, algebraMap A F a ∈ w.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : 0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral_of_algebraMap_mem hA hf)
+
+end Place
+
+section Bridge
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+variable {A : Type*} [CommRing A] [Algebra A E] [Algebra A F] [IsScalarTower A E F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+end Place
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral_of_restrict [Algebra.IsIntegral E F]
+    (w : Place K F)
+    {u : Place K E} (hw : w.restrict E = u)
+    (hA : ∀ a : A, algebraMap A E a ∈ u.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : f ∈ w.toValuationSubring := by
+  refine w.mem_of_isIntegral_of_algebraMap_mem (fun a => ?_) hf
+  rw [IsScalarTower.algebraMap_apply A E F, ← w.mem_restrict_iff, hw]
+  exact hA a
+
+end Place
+p2m_export "AlgebraicCurve" "Place.mem_of_isIntegral_of_restrict"
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.ord_nonneg_of_isIntegral_of_restrict
+    [Algebra.IsIntegral E F] (w : Place K F)
+    {u : Place K E} (hw : w.restrict E = u)
+    (hA : ∀ a : A, algebraMap A E a ∈ u.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : 0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral_of_restrict hw hA hf)
+
+end Place
+p2m_export "AlgebraicCurve" "Place.ord_nonneg_of_isIntegral_of_restrict"
+namespace TranscendenceTower
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF poleDivisor RegularOutside hx_indep hxreg v \
+  mk.injEq mk hvdeg x hxv"
+end TranscendenceTower
+namespace TranscendenceTower
+p2m_open_scoped "AlgebraicCurve.TranscendenceTower" in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.ord_nonneg_of_isIntegral_of_regularOutside
+    [Algebra.IsIntegral E F] (T : TranscendenceTower K E F) (hA : T.RegularOutside A)
+    {f : F} (hf : IsIntegral A f) :
+    ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord f := fun w hw =>
+  w.ord_nonneg_of_isIntegral_of_restrict rfl (hA _ hw) hf
+
+end TranscendenceTower
+p2m_export "AlgebraicCurve" "TranscendenceTower.ord_nonneg_of_isIntegral_of_regularOutside"
+end Bridge
+
+section Headline
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F]
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+theorem linearIndependent_reindex_basis {s : Finset F} (b : Basis s E F) :
+    LinearIndependent E (fun i : Fin (Module.finrank E F) =>
+      b ((Fintype.equivFinOfCardEq (Module.finrank_eq_card_basis b).symm).symm i)) :=
+  b.linearIndependent.comp _ (Equiv.injective _)
+
+theorem hasIntegralBasisRegularOutside_of_isFractionRing
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    HasIntegralBasisRegularOutside K E F T := by
+  obtain ⟨s, b, hint⟩ := FiniteDimensional.exists_is_basis_integral A E F
+  set e : Fin (Module.finrank E F) ≃ s :=
+    (Fintype.equivFinOfCardEq (Module.finrank_eq_card_basis b).symm).symm
+  refine ⟨fun i => b (e i), linearIndependent_reindex_basis b, fun i w hw => ?_⟩
+  exact T.ord_nonneg_of_isIntegral_of_regularOutside hA (hint (e i)) w hw
+
+theorem hasIntegralBasisRegularOutside_of_hasRegularFractionSubring
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    HasIntegralBasisRegularOutside K E F T := by
+  obtain ⟨A, hfrac, hreg⟩ := h
+  have : IsFractionRing A E := hfrac
+  exact hasIntegralBasisRegularOutside_of_isFractionRing (A := A) T
+    (fun u hu a => hreg u hu (a : E) a.property)
+
+theorem hasPoleDivisorPackage_of_isFractionRing [HasPrincipalDivisors K F]
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside T
+    (hasIntegralBasisRegularOutside_of_isFractionRing T hA)
+
+theorem stichtenothGenusExists_of_isFractionRing [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasPoleDivisorPackage
+    (hasPoleDivisorPackage_of_isFractionRing T hA)
+
+theorem hasPoleDivisorPackage_of_hasRegularFractionSubring [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside T
+    (hasIntegralBasisRegularOutside_of_hasRegularFractionSubring T h)
+
+theorem stichtenothGenusExists_of_hasRegularFractionSubring [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasPoleDivisorPackage
+    (hasPoleDivisorPackage_of_hasRegularFractionSubring T h)
+
+namespace TranscendenceTower
+p2m_open_scoped "AlgebraicCurve.TranscendenceTower" in
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.adjoin_x_regularOutside (T :
+  TranscendenceTower K E F) :
+    ∀ u : Place K E, u ≠ T.v →
+      ∀ a ∈ Algebra.adjoin K {T.x}, a ∈ u.toValuationSubring := by
+  intro u hu a ha
+  let S : Subalgebra K E :=
+    { u.toValuationSubring.toSubsemiring with
+      algebraMap_mem' := u.algebraMap_mem' }
+  suffices h : a ∈ S from h
+  refine Algebra.adjoin_le ?_ ha
+  intro y hy
+  rw [Set.mem_singleton_iff] at hy
+  subst hy
+  change T.x ∈ u.toValuationSubring
+  exact AlgebraicCurve.Place.mem_of_ord_nonneg u T.x_ne_zero (T.hxreg u hu)
+
+end TranscendenceTower
+p2m_export "AlgebraicCurve" "TranscendenceTower.adjoin_x_regularOutside"
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+theorem hasRegularFractionSubring_of_adjoin_x_isFractionRing
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    HasRegularFractionSubring K E F T :=
+  ⟨Algebra.adjoin K {T.x}, hfrac, T.adjoin_x_regularOutside⟩
+
+theorem hasIntegralBasisRegularOutside_of_adjoin_x_isFractionRing
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    HasIntegralBasisRegularOutside K E F T :=
+  hasIntegralBasisRegularOutside_of_hasRegularFractionSubring T
+    (hasRegularFractionSubring_of_adjoin_x_isFractionRing T hfrac)
+
+theorem stichtenothGenusExists_of_adjoin_x_isFractionRing [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasRegularFractionSubring T
+    (hasRegularFractionSubring_of_adjoin_x_isFractionRing T hfrac)
+
+end Headline
+
+section Gates
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem gate_mem_of_isIntegral_recovers_comap (w : Place K F) (E : Type*) [Field E]
+    [Algebra E F] [Algebra.IsIntegral E F]
+    (hE : ∀ a : E, algebraMap E F a ∈ w.toValuationSubring) (f : F) :
+    f ∈ w.toValuationSubring := by
+  let : Algebra E w.toValuationSubring :=
+    ((algebraMap E F).codRestrict w.toValuationSubring.toSubring hE).toAlgebra
+  have : IsScalarTower E w.toValuationSubring F :=
+    IsScalarTower.of_algebraMap_eq fun _ => rfl
+  exact w.mem_of_isIntegral (Algebra.IsIntegral.isIntegral (R := E) f).tower_top
+
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+
+theorem gate_bridge_recovers_hxreg [Algebra.IsIntegral E F]
+    (T : TranscendenceTower K E F) (w : Place K F) (hw : w.restrict E ≠ T.v) :
+    0 ≤ w.ord T.xF := by
+  rw [TranscendenceTower.xF, Place.ord_restrict]
+  exact mul_nonneg (Int.natCast_nonneg _) (T.hxreg _ hw)
+
+theorem gate_regularOutside_mono (T : TranscendenceTower K E F) {A A' : Subalgebra K E}
+    (hle : A ≤ A')
+    (hA' : ∀ u : Place K E, u ≠ T.v → ∀ a ∈ A', a ∈ u.toValuationSubring) :
+    ∀ u : Place K E, u ≠ T.v → ∀ a ∈ A, a ∈ u.toValuationSubring :=
+  fun u hu a ha => hA' u hu a (hle ha)
+
+theorem gate_bot_regularOutside (T : TranscendenceTower K E F) :
+    ∀ u : Place K E, u ≠ T.v → ∀ a ∈ (⊥ : Subalgebra K E), a ∈ u.toValuationSubring := by
+  intro u _ a ha
+  obtain ⟨c, rfl⟩ := Algebra.mem_bot.mp ha
+  exact u.algebraMap_mem' c
+
+theorem gate_adjoin_x_not_regular_at_v (T : TranscendenceTower K E F) :
+    ¬ ∀ a ∈ Algebra.adjoin K {T.x}, a ∈ T.v.toValuationSubring := by
+  intro h
+  have hx := AlgebraicCurve.Place.ord_nonneg_of_mem T.v (h T.x (Algebra.subset_adjoin rfl))
+  rw [T.hxv] at hx
+  exact absurd hx (by decide)
+
+end Gates
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open Module Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+section Transcendental
+
+variable {K A : Type*} [CommRing K] [CommRing A] [Algebra K A]
+
+theorem linearIndependent_pow_of_transcendental {x : A} (hx : Transcendental K x) :
+    LinearIndependent K (fun j : ℕ => x ^ j) := by
+  have hinj : Function.Injective (Polynomial.aeval x : K[X] →ₐ[K] A) :=
+    transcendental_iff_injective.mp hx
+  have hXj : LinearIndependent K (fun j : ℕ => (X : K[X]) ^ j) := by
+    have hb := (Polynomial.basisMonomials K).linearIndependent
+    simp only [Polynomial.coe_basisMonomials] at hb
+    convert hb using 2 with j
+    exact (Polynomial.monomial_one_right_eq_X_pow j).symm
+  have heq : (fun j : ℕ => x ^ j)
+      = (fun j : ℕ => (Polynomial.aeval x : K[X] →ₐ[K] A) (X ^ j)) := by
+    funext j; simp
+  rw [heq]
+  exact hXj.map' (Polynomial.aeval x).toLinearMap
+    (LinearMap.ker_eq_bot_of_injective hinj)
+
+theorem transcendental_of_linearIndependent_pow {x : A}
+    (hx : LinearIndependent K (fun j : ℕ => x ^ j)) :
+    Transcendental K x := by
+  rw [transcendental_iff]
+  intro p hp
+  rw [Polynomial.aeval_eq_sum_range, ← Fin.sum_univ_eq_sum_range] at hp
+  ext j
+  rcases lt_or_ge j (p.natDegree + 1) with hj | hj
+  · exact (Fintype.linearIndependent_iff.mp
+      (hx.comp (Fin.val : Fin (p.natDegree + 1) → ℕ) Fin.val_injective))
+      (fun i => p.coeff i) hp ⟨j, hj⟩
+  · exact p.coeff_eq_zero_of_natDegree_lt (Nat.lt_of_succ_le hj)
+
+end Transcendental
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "algebraMap_mem_ofHeightOneSpectrum placeInfty \
+  ord_placeInfty deg_placeInfty eq_ofHeightOneSpectrum_or_eq_placeInfty"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+
+theorem ord_placeInfty_X_port : (placeInfty K).ord (RatFunc.X : RatFunc K) = -1 := by
+  rw [ord_placeInfty (K := K) RatFunc.X_ne_zero, RatFunc.intDegree_X]
+
+theorem algebraMap_polynomial_mem_of_ne_placeInfty
+    {u : Place K (RatFunc K)} (hu : u ≠ placeInfty K) (q : K[X]) :
+    algebraMap K[X] (RatFunc K) q ∈ u.toValuationSubring := by
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty u with ⟨w, hw⟩ | hw
+  · subst hw; exact algebraMap_mem_ofHeightOneSpectrum K w q
+  · exact absurd hw hu
+
+theorem ord_X_nonneg_of_ne_placeInfty
+    {u : Place K (RatFunc K)} (hu : u ≠ placeInfty K) :
+    0 ≤ u.ord (RatFunc.X : RatFunc K) := by
+  rw [← RatFunc.algebraMap_X]
+  exact AlgebraicCurve.Place.ord_nonneg_of_mem u (algebraMap_polynomial_mem_of_ne_placeInfty K hu
+    Polynomial.X)
+
+variable (F : Type*) [Field F] [Algebra K F] [Algebra (RatFunc K) F]
+  [IsScalarTower K (RatFunc K) F]
+
+def transcendenceTower : TranscendenceTower K (RatFunc K) F where
+  x := RatFunc.X
+  hx_indep := linearIndependent_pow_of_transcendental RatFunc.transcendental_X
+  v := placeInfty K
+  hvdeg := deg_placeInfty K
+  hxv := ord_placeInfty_X_port K
+  hxreg := fun _ hu => ord_X_nonneg_of_ne_placeInfty K hu
+
+@[scoped simp]
+theorem transcendenceTower_x : (transcendenceTower K F).x = RatFunc.X := rfl
+
+@[scoped simp]
+theorem transcendenceTower_v : (transcendenceTower K F).v = placeInfty K := rfl
+
+omit [DecidableEq (RatFunc K)] in
+theorem aeval_X_eq_algebraMap (q : K[X]) :
+    (Polynomial.aeval (R := K) (RatFunc.X : RatFunc K)) q
+      = algebraMap K[X] (RatFunc K) q := by
+  have hext : (Polynomial.aeval (R := K) (RatFunc.X : RatFunc K))
+      = IsScalarTower.toAlgHom K K[X] (RatFunc K) :=
+    Polynomial.algHom_ext (by simp [RatFunc.algebraMap_X])
+  rw [hext]; rfl
+
+omit [DecidableEq (RatFunc K)] in
+theorem algebraMap_polynomial_mem_adjoin_X (q : K[X]) :
+    algebraMap K[X] (RatFunc K) q ∈ Algebra.adjoin K {(RatFunc.X : RatFunc K)} := by
+  rw [Algebra.adjoin_singleton_eq_range_aeval]
+  exact ⟨q, aeval_X_eq_algebraMap K q⟩
+
+omit [DecidableEq (RatFunc K)] in
+theorem isFractionRing_adjoin_X :
+    IsFractionRing (Algebra.adjoin K {(RatFunc.X : RatFunc K)}) (RatFunc K) := by
+  refine IsFractionRing.of_field _ _ fun z => ?_
+  refine ⟨⟨algebraMap K[X] (RatFunc K) z.num, algebraMap_polynomial_mem_adjoin_X K z.num⟩,
+    ⟨algebraMap K[X] (RatFunc K) z.denom, algebraMap_polynomial_mem_adjoin_X K z.denom⟩, ?_⟩
+  change z = algebraMap K[X] (RatFunc K) z.num / algebraMap K[X] (RatFunc K) z.denom
+  exact z.num_div_denom.symm
+
+theorem hasRegularFractionSubring :
+    HasRegularFractionSubring K (RatFunc K) F (transcendenceTower K F) :=
+  hasRegularFractionSubring_of_adjoin_x_isFractionRing
+    (transcendenceTower K F) (isFractionRing_adjoin_X K)
+
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+
+theorem hasIntegralBasisRegularOutside :
+    HasIntegralBasisRegularOutside K (RatFunc K) F (transcendenceTower K F) :=
+  hasIntegralBasisRegularOutside_of_adjoin_x_isFractionRing
+    (transcendenceTower K F) (isFractionRing_adjoin_X K)
+
+section PrincipalDivisors
+
+variable [HasPrincipalDivisors K F]
+
+omit [DecidableEq (RatFunc K)] in
+theorem hasPoleDivisorPackage_of_ratFunc_tower :
+    HasPoleDivisorPackage K F := by
+  classical
+  exact
+    hasPoleDivisorPackage_of_hasRegularFractionSubring
+      (transcendenceTower K F) (hasRegularFractionSubring K F)
+
+end PrincipalDivisors
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+omit [DecidableEq (RatFunc K)] in
+theorem stichtenothGenusExists_of_ratFunc_tower :
+    StichtenothGenusExists K F := by
+  classical
+  exact
+    stichtenothGenusExists_of_adjoin_x_isFractionRing
+      (transcendenceTower K F) (isFractionRing_adjoin_X K)
+
+omit [DecidableEq (RatFunc K)] in
+theorem indexOfSpecialtyFinite_of_ratFunc_tower :
+    IndexOfSpecialtyFinite K F := by
+  classical
+  exact
+    indexOfSpecialtyFinite_of_stichtenothGenusExists
+      (stichtenothGenusExists_of_ratFunc_tower K F)
+
+end RationalFunctionField
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open Module Polynomial IsDedekindDomain
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep RationalFunctionField.placeInfty \
+  Place.sum_ramificationIndex_mul_inertiaDeg RationalFunctionField.ord_placeInfty \
+  Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "algebraMap_mem_ofHeightOneSpectrum placeInfty \
+  ord_placeInfty deg_placeInfty eq_ofHeightOneSpectrum_or_eq_placeInfty"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+variable (F : Type*) [Field F] [Algebra K F] [Algebra (RatFunc K) F]
+  [IsScalarTower K (RatFunc K) F]
+
+section LyingOver
+
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+
+omit [DecidableEq (RatFunc K)] in
+omit [DecidableEq (RatFunc K)] in
+private theorem _root_.AlgebraicCurve.RationalFunctionField.exists_restrict_eq (v : Place K (RatFunc
+  K)) :
+    ∃ w : Place K F, w.restrict (RatFunc K) = v :=
+  Place.exists_restrict_eq v
+
+p2m_export "AlgebraicCurve.RationalFunctionField" "exists_restrict_eq"
+
+omit [DecidableEq (RatFunc K)] in
+theorem nonempty_place_of_ratFunc_tower : Nonempty (Place K F) := by
+  classical
+  exact
+    (exists_restrict_eq K F (placeInfty K)).nonempty
+
+end LyingOver
+
+omit [DecidableEq (RatFunc K)] [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F] in
+theorem finiteDimensional_lSpace_zero_of_constantsAreBase (hC : ConstantsAreBase K F) :
+    FiniteDimensional K (LSpace (0 : Divisor K F)) := by
+  rw [show LSpace (0 : Divisor K F) = LinearMap.range (Algebra.linearMap K F) from hC]
+  exact LinearMap.finiteDimensional_range _
+
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+variable [IsCurveOver K F]
+
+omit [DecidableEq (RatFunc K)] in
+theorem stichtenothGenusExists (hC : ConstantsAreBase K F) :
+    StichtenothGenusExists K F := by
+  classical
+  exact
+    haveI := nonempty_place_of_ratFunc_tower K F
+    haveI := finiteDimensional_lSpace_zero_of_constantsAreBase K F hC
+    stichtenothGenusExists_of_ratFunc_tower K F
+
+omit [DecidableEq (RatFunc K)] in
+theorem indexOfSpecialtyFinite (hC : ConstantsAreBase K F) :
+    IndexOfSpecialtyFinite K F := by
+  classical
+  exact
+    indexOfSpecialtyFinite_of_stichtenothGenusExists (stichtenothGenusExists K F hC)
+
+omit [DecidableEq (RatFunc K)] in
+theorem riemannGenusBounded (hC : ConstantsAreBase K F) : RiemannGenusBounded K F := by
+  classical
+  exact
+    haveI := nonempty_place_of_ratFunc_tower K F
+    haveI := finiteDimensional_lSpace_zero_of_constantsAreBase K F hC
+    riemannGenusBounded_of_poleDivisorPackage (hasPoleDivisorPackage_of_ratFunc_tower K F).some
+
+end RationalFunctionField
+end AlgebraicCurve
+end
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg\
+  " in
+open _root_.P2MW.S_AlgebraicCurve_RationalFunctionField_ord_placeInfty_X.AlgebraicCurve Polynomial
+  in
+theorem solution (K : Type*) [Field K] [DecidableEq (RatFunc K)] :
+    (RationalFunctionField.placeInfty K).ord (RatFunc.X : RatFunc K) = -1 :=
+  AlgebraicCurve.RationalFunctionField.ord_placeInfty_X_port (K := K)
+
+end S_AlgebraicCurve_RationalFunctionField_ord_placeInfty_X
+end P2MW
+export P2MW.S_AlgebraicCurve_RationalFunctionField_ord_placeInfty_X (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace AlgebraicCurve
+theorem RationalFunctionField.ord_placeInfty_X (K : Type*) [Field K] [DecidableEq (RatFunc K)] :
+    (RationalFunctionField.placeInfty K).ord (RatFunc.X : RatFunc K) = -1 :=
+  solution K
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty_algebraMap.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty_algebraMap.lean
new file mode 100644
index 0000000000..b1d1a7e300
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty_algebraMap.lean
@@ -0,0 +1,84 @@
+/-
+Based on Prove2Me node AlgebraicCurve.RationalFunctionField.ord_placeInfty_algebraMap
+(46a8360b-25ea-521c-a346-d4c9dd16f8eb) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d0c6e3bd-3cd7-5b5b-9098-77408598336a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceInfty
+
+import Mathlib.FieldTheory.RatFunc.Degree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order at infinity of a polynomial is -deg q
+
+Theorem statement: `AlgebraicCurve.RationalFunctionField.ord_placeInfty_algebraMap`
+(`46a8360b-25ea-521c-a346-d4c9dd16f8eb`), by Claude, 2026-09-05.
+
+Proof: submission `d0c6e3bd-3cd7-5b5b-9098-77408598336a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $q \in K[t]$ be a non-zero polynomial. Consider the place at infinity
+$\mathtt{placeInfty}\,K$ of the rational function field $K(t)$: in the sense of the project's notion
+of a place of $K(t)$ over $K$, it is given by the valuation subring of the infinity valuation
+`RatFunc.inftyValuation K` on $K(t)$, which contains the image of $K$, is not all of $K(t)$, and is
+a principal ideal ring. For a place $v$, $v.\mathtt{ord}(f)$ is defined as minus the
+`WithZero`-logarithm of the value of $f$ under the adic valuation attached to the height-one prime
+of the valuation subring of $v$, so that it is the usual normalised order of vanishing, negative at
+a pole. The assertion is that for the image of $q$ under the structure map $K[t] \to K(t)$ one has
+$$(\mathtt{placeInfty}\,K).\mathtt{ord}\bigl(\mathrm{alg}(q)\bigr) = -\,\deg q,$$ the degree being
+`Polynomial.natDegree` viewed as an integer; equivalently, a non-zero polynomial of degree $d$ has a
+pole of order exactly $d$ at infinity.
+
+This is the computation of the divisor of a polynomial at the point at infinity of $\mathbb{P}^1$,
+in the standard description of the places of $K(t)$ as the monic irreducibles together with
+$\infty$. It is part of the function-field foundations used in the genus-zero computations for
+$K(t)$ and in the local analysis of orders at places, for instance in
+[`AlgebraicCurve.RationalFunctionField.ell_sub_ell_eq_genus_zero`]
+(thm.html#AlgebraicCurve.RationalFunctionField.ell_sub_ell_eq_genus_zero).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_ord_placeInfty_algebraMap.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_RationalFunctionField_ord_placeInfty_algebraMap
+
+open AlgebraicCurve AlgebraicCurve.RationalFunctionField
+
+theorem solution {K : Type*} [Field K] [DecidableEq (RatFunc K)] {q : Polynomial K} (hq : q ≠ 0) :
+    (placeInfty K).ord (algebraMap (Polynomial K) (RatFunc K) q) = -(q.natDegree : ℤ) := by
+  rw [AlgebraicCurve.RationalFunctionField.ord_placeInfty (RatFunc.algebraMap_ne_zero hq),
+    RatFunc.intDegree_polynomial]
+
+end S_AlgebraicCurve_RationalFunctionField_ord_placeInfty_algebraMap
+end P2MW
+export P2MW.S_AlgebraicCurve_RationalFunctionField_ord_placeInfty_algebraMap (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve AlgebraicCurve.RationalFunctionField
+theorem AlgebraicCurve.RationalFunctionField.ord_placeInfty_algebraMap {K : Type*} [Field K]
+    [DecidableEq (RatFunc K)] {q : Polynomial K} (hq : q ≠ 0) :
+    (placeInfty K).ord (algebraMap (Polynomial K) (RatFunc K) q) = -(q.natDegree : ℤ) :=
+  solution hq
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_placeOfPoint_algebraMap.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_placeOfPoint_algebraMap.lean
new file mode 100644
index 0000000000..57935f599d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_ord_placeOfPoint_algebraMap.lean
@@ -0,0 +1,1322 @@
+/-
+Based on Prove2Me node AlgebraicCurve.RationalFunctionField.ord_placeOfPoint_algebraMap
+(1a43d932-e0c1-5826-a18d-35cc3cba5bd9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f079b6f0-a382-5762-9e20-763cf0c5ddac
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import Mathlib.FieldTheory.RatFunc.Degree
+import Mathlib.NumberTheory.RatFunc.Ostrowski
+import Mathlib.RingTheory.DedekindDomain.Factorization
+import Mathlib.FieldTheory.IsAlgClosed.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_of_ord_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_nonneg_of_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_eq_neg_log_of_valuationSubring_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_finite_setOf_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_hasPrincipalDivisors
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_of_span
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_subsingleton_setOf_forall_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_congr
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_inv
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_zpow
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_isRational_iff_deg_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_zsmul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_zpow_left
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_evalFun_single_sub_single
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order at the place t=a equals root multiplicity
+
+Theorem statement: `AlgebraicCurve.RationalFunctionField.ord_placeOfPoint_algebraMap`
+(`1a43d932-e0c1-5826-a18d-35cc3cba5bd9`), by Claude, 2026-09-05.
+
+Proof: submission `f079b6f0-a382-5762-9e20-763cf0c5ddac`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, let $a \in K$, and let $q \in K[X]$ be a nonzero polynomial. Consider the place
+`placeOfPoint K a` of the rational function field $K(X)$ attached to the point $X = a$: it is the
+place obtained from the height-one prime $(X-a)$ of $K[X]$ — the data of a valuation subring of
+$K(X)$ containing the image of $K$, distinct from all of $K(X)$ and a principal ideal ring — namely
+the local ring of $K(X)$ at $X-a$. For a place $v$, $v.\mathrm{ord}$ of an element $f$ is defined as
+$-\log$ of the value of $f$ under the $\mathbb{Z}^{m0}$-valued adic valuation associated with the
+corresponding height-one prime. The assertion is that the order of the image of $q$ under the map
+$K[X] \to K(X)$ at this place equals `Polynomial.rootMultiplicity a q`, the largest $m$ with
+$(X-a)^m \mid q$.
+
+This is the basic dictionary, for the rational function field, between the order of vanishing of a
+rational function at the place corresponding to a rational point $a$ of $\mathbb{P}^1$ and the
+multiplicity of $a$ as a root of a polynomial. It is used throughout the development of places and
+divisors of $K(X)$, for instance in computing orders of differences of coordinates and ramification
+indices along maps of curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_ord_placeOfPoint_algebraMap.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_3fd9514a
+
+noncomputable section
+
+open Polynomial IsDedekindDomain WithZero IsLocalRing
+
+open scoped Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.mem_maximalIdeal_iff_adicValuation_lt_one \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff Place Place.ext Place.deg Place.ord_inv Divisor \
+  Divisor.degree Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring Place.evalAt \
+  Divisor.evalFun Divisor.evalFun_def Divisor.evalFun_zero \
+  RationalFunctionField.hasPrincipalDivisors Place.evalAt_congr Place.evalAt_algebraMap \
+  Place.isRational_iff_deg_eq_one Divisor.evalFun_add Divisor.evalFun_mul Divisor.evalFun_zsmul \
+  Divisor.evalFun_zpow_left Divisor.evalFun_single_sub_single"
+p2m_open "AlgebraicCurve"
+
+scoped instance {K : Type*} [Field K] : HasPrincipalDivisors K (RatFunc K) :=
+  RationalFunctionField.hasPrincipalDivisors K
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "adicValuation_valuationSubring \
+  isEquiv_adicValuation_of_valuationSubring_eq mem_maximalIdeal_iff_adicValuation_lt_one \
+  ord_ofHeightOneSpectrum_ne_zero_iff ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring algebraMap_mem' toValuationSubring \
+  IsRational evalAt mem_of_ord_nonneg ord_nonneg_of_mem ord_algebraMap \
+  ord_eq_neg_log_of_valuationSubring_eq evalAt_congr evalAt_algebraMap evalAt_mul evalAt_ne_zero \
+  evalAt_inv isRational_iff_deg_eq_one"
+p2m_open "AlgebraicCurve.Place~algebraMap_ne_zero"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+theorem isRational_of_deg_eq_one (h : v.deg = 1) : v.IsRational :=
+  (AlgebraicCurve.Place.isRational_iff_deg_eq_one v).2 h
+
+theorem deg_eq_one_of_isRational (hv : v.IsRational) : v.deg = 1 :=
+  (AlgebraicCurve.Place.isRational_iff_deg_eq_one v).1 hv
+
+end Place
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "heightOneSpectrumOfIrreducible \
+  heightOneSpectrumOfIrreducible_asIdeal exists_irreducible_span finitePlace finitePlace_def \
+  algebraMap_mem_ofHeightOneSpectrum deg_finitePlace placeOfPoint \
+  placeOfPoint_eq_ofHeightOneSpectrum placeOfPoint_injective deg_placeOfPoint placeInfty \
+  placeInfty_toValuationSubring finite_setOf_ord_ne_zero degree_eq_zero_of_forall_eq_ord \
+  hasPrincipalDivisors ord_ofHeightOneSpectrum_of_span"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable (K : Type*) [Field K]
+
+theorem ord_finitePlace_ne_zero_iff {p : K[X]} (hp : Irreducible p) {q : K[X]} (hq : q ≠ 0) :
+    (finitePlace K hp).ord (algebraMap K[X] (RatFunc K) q) ≠ 0 ↔ p ∣ q := by
+  rw [finitePlace, Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) _ hq,
+    heightOneSpectrumOfIrreducible_asIdeal, Ideal.mem_span_singleton]
+
+section PlaceInfty
+
+variable [DecidableEq (RatFunc K)]
+
+theorem inftyValuation_isEquiv_adicValuation :
+    (RatFunc.inftyValuation K).IsEquiv (placeInfty K).adicValuation :=
+  (placeInfty K).isEquiv_adicValuation_of_valuationSubring_eq rfl
+
+theorem placeInfty_ne_ofHeightOneSpectrum (w : HeightOneSpectrum K[X]) :
+    placeInfty K ≠ Place.ofHeightOneSpectrum w := by
+  intro h
+  refine RatFunc.adicValuation_not_isEquiv_infty_valuation w
+    ((Valuation.isEquiv_iff_valuationSubring _ _).mpr ?_)
+  have h2 := congrArg Place.toValuationSubring h
+  rw [placeInfty_toValuationSubring, Place.ofHeightOneSpectrum_toValuationSubring] at h2
+  exact h2.symm
+
+end PlaceInfty
+
+variable {K}
+
+theorem eq_ofHeightOneSpectrum_or_eq_placeInfty [DecidableEq (RatFunc K)]
+    (v : Place K (RatFunc K)) :
+    (∃ w : HeightOneSpectrum K[X], v = Place.ofHeightOneSpectrum w) ∨ v = placeInfty K := by
+  rcases (RatFunc.valuation_isEquiv_infty_or_adic (v := v.adicValuation)).or with h | h
+  · exact Or.inr (Place.ext (v.adicValuation_valuationSubring.symm.trans
+      ((Valuation.isEquiv_iff_valuationSubring _ _).mp h)))
+  · obtain ⟨w, hw, -⟩ := h
+    exact Or.inl ⟨w, Place.ext (v.adicValuation_valuationSubring.symm.trans
+      ((Valuation.isEquiv_iff_valuationSubring _ _).mp hw))⟩
+
+section DegInfty
+
+variable (K) [DecidableEq (RatFunc K)]
+
+theorem exists_sub_algebraMap_intDegree_neg {x : RatFunc K}
+    (hx : RatFunc.inftyValuation K x ≤ 1) :
+    ∃ c : K, x - algebraMap K (RatFunc K) c = 0 ∨
+      (x - algebraMap K (RatFunc K) c).intDegree < 0 := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · exact ⟨0, Or.inl (by simp)⟩
+  have hdeg : x.intDegree ≤ 0 := by
+    rw [RatFunc.inftyValuation_apply, RatFunc.inftyValuation_of_nonzero K hx0,
+      show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_le_exp] at hx
+    exact hx
+  have hnum0 : x.num ≠ 0 := RatFunc.num_ne_zero hx0
+  have hden0 : x.denom ≠ 0 := x.denom_ne_zero
+  rcases lt_or_eq_of_le hdeg with hlt | heq
+  · exact ⟨0, Or.inr (by simpa using hlt)⟩
+  have hndeg : x.num.natDegree = x.denom.natDegree := by
+    have h2 := heq
+    rw [RatFunc.intDegree, sub_eq_zero] at h2
+    exact_mod_cast h2
+  set c : K := x.num.leadingCoeff / x.denom.leadingCoeff with hc
+  have hc0 : c ≠ 0 := by
+    rw [hc]
+    exact div_ne_zero (Polynomial.leadingCoeff_ne_zero.mpr hnum0)
+      (Polynomial.leadingCoeff_ne_zero.mpr hden0)
+  refine ⟨c, ?_⟩
+  have hsub : x - algebraMap K (RatFunc K) c
+      = algebraMap K[X] (RatFunc K) (x.num - Polynomial.C c * x.denom)
+        / algebraMap K[X] (RatFunc K) x.denom := by
+    rw [map_sub, map_mul, sub_div, x.num_div_denom, mul_div_assoc,
+      div_self ((map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hden0),
+      mul_one, IsScalarTower.algebraMap_apply K K[X] (RatFunc K), Polynomial.algebraMap_eq]
+  rcases eq_or_ne (x.num - Polynomial.C c * x.denom) 0 with hzero | hnz
+  · exact Or.inl (by rw [hsub, hzero, map_zero, zero_div])
+  refine Or.inr ?_
+  rw [hsub, RatFunc.intDegree_div ((map_ne_zero_iff _
+      (IsFractionRing.injective K[X] (RatFunc K))).mpr hnz)
+    ((map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hden0),
+    RatFunc.intDegree_polynomial, RatFunc.intDegree_polynomial, sub_neg]
+  have hCdeg : (Polynomial.C c * x.denom).degree = x.denom.degree := by
+    rw [Polynomial.degree_mul, Polynomial.degree_C hc0, zero_add]
+  have hdegeq : x.num.degree = (Polynomial.C c * x.denom).degree := by
+    rw [hCdeg, Polynomial.degree_eq_natDegree hnum0, Polynomial.degree_eq_natDegree hden0,
+      hndeg]
+  have hlc : x.num.leadingCoeff = (Polynomial.C c * x.denom).leadingCoeff := by
+    rw [Polynomial.leadingCoeff_mul, Polynomial.leadingCoeff_C, hc,
+      div_mul_cancel₀ _ (Polynomial.leadingCoeff_ne_zero.mpr hden0)]
+  have hlt := Polynomial.degree_sub_lt_left hdegeq hnum0 hlc
+  rw [hdegeq, hCdeg] at hlt
+  exact_mod_cast Polynomial.natDegree_lt_natDegree hnz hlt
+
+theorem deg_placeInfty : (placeInfty K).deg = 1 := by
+  have hbij : Function.Bijective (Algebra.ofId K (placeInfty K).ResidueField) := by
+    constructor
+    · exact fun a b h => (algebraMap K ((placeInfty K).ResidueField)).injective h
+    · intro y
+      obtain ⟨⟨x, hx⟩, rfl⟩ := IsLocalRing.residue_surjective y
+      obtain ⟨c, hc⟩ := exists_sub_algebraMap_intDegree_neg K
+        ((Valuation.mem_valuationSubring_iff _ _).mp hx)
+      refine ⟨c, ?_⟩
+      change IsLocalRing.residue _ (algebraMap K (placeInfty K).toValuationSubring c) = _
+      rw [← sub_eq_zero, ← map_sub, IsLocalRing.residue_eq_zero_iff,
+        Place.mem_maximalIdeal_iff_adicValuation_lt_one]
+      change (placeInfty K).adicValuation (algebraMap K (RatFunc K) c - x) < 1
+      rw [← (inftyValuation_isEquiv_adicValuation K).lt_one_iff_lt_one,
+        show algebraMap K (RatFunc K) c - x = -(x - algebraMap K (RatFunc K) c) from
+          (neg_sub _ _).symm, Valuation.map_neg]
+      rcases hc with hc | hc
+      · rw [hc, map_zero]
+        exact zero_lt_one
+      · rw [RatFunc.inftyValuation_apply, RatFunc.inftyValuationDef]
+        split
+        · exact zero_lt_one
+        · rw [show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_lt_exp]
+          exact hc
+  rw [Place.deg, ← (AlgEquiv.ofBijective _ hbij).toLinearEquiv.finrank_eq,
+    Module.finrank_self]
+
+end DegInfty
+
+end RationalFunctionField
+
+theorem le_exp_neg_one_of_lt_one {x : ℤᵐ⁰} (hx : x < 1) : x ≤ exp (-1 : ℤ) := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · exact zero_le
+  · rw [← exp_log hx0] at hx ⊢
+    rw [show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_lt_exp] at hx
+    rw [exp_le_exp]
+    omega
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "adicValuation_valuationSubring \
+  isEquiv_adicValuation_of_valuationSubring_eq mem_maximalIdeal_iff_adicValuation_lt_one \
+  ord_ofHeightOneSpectrum_ne_zero_iff ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring algebraMap_mem' toValuationSubring \
+  IsRational evalAt mem_of_ord_nonneg ord_nonneg_of_mem ord_algebraMap \
+  ord_eq_neg_log_of_valuationSubring_eq evalAt_congr evalAt_algebraMap evalAt_mul evalAt_ne_zero \
+  evalAt_inv isRational_iff_deg_eq_one"
+p2m_open "AlgebraicCurve.Place~algebraMap_ne_zero"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.isUnit_algebraMap {c : K} (hc : c ≠ 0) :
+    IsUnit (algebraMap K v.toValuationSubring c) :=
+  (isUnit_iff_ne_zero.mpr hc).map _
+
+p2m_export "AlgebraicCurve.Place" "isUnit_algebraMap"
+
+theorem adicValuation_algebraMap {c : K} (hc : c ≠ 0) :
+    v.adicValuation (algebraMap K F c) = 1 := by
+  rw [← v.coe_algebraMap]
+  exact (v.adicValuation_coe_eq_one_iff _).mpr (v.isUnit_algebraMap hc)
+
+end Place
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "heightOneSpectrumOfIrreducible \
+  heightOneSpectrumOfIrreducible_asIdeal exists_irreducible_span finitePlace finitePlace_def \
+  algebraMap_mem_ofHeightOneSpectrum deg_finitePlace placeOfPoint \
+  placeOfPoint_eq_ofHeightOneSpectrum placeOfPoint_injective deg_placeOfPoint placeInfty \
+  placeInfty_toValuationSubring finite_setOf_ord_ne_zero degree_eq_zero_of_forall_eq_ord \
+  hasPrincipalDivisors ord_ofHeightOneSpectrum_of_span"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable {K : Type*} [Field K]
+
+theorem ord_ofHeightOneSpectrum_eq_zero_of_notMem (w : HeightOneSpectrum K[X]) {q : K[X]}
+    (hq : q ≠ 0) (hmem : q ∉ w.asIdeal) :
+    (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord
+      (algebraMap K[X] (RatFunc K) q) = 0 := by
+  by_contra h
+  exact hmem
+    ((Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w hq).mp h)
+
+section PlaceInftyOrd
+
+variable [DecidableEq (RatFunc K)]
+
+theorem ord_placeInfty {f : RatFunc K} (hf : f ≠ 0) :
+    (placeInfty K).ord f = -f.intDegree := by
+  have hπ : RatFunc.inftyValuation K (RatFunc.X)⁻¹ = exp (-1 : ℤ) := by
+    rw [map_inv₀, RatFunc.inftyValuation.X]
+    exact (exp_neg (1 : ℤ)).symm
+  rw [(placeInfty K).ord_eq_neg_log_of_valuationSubring_eq (RatFunc.inftyValuation K) rfl hπ
+      hf,
+    RatFunc.inftyValuation_apply, RatFunc.inftyValuation_of_nonzero K hf, log_exp]
+
+theorem ord_placeInfty_algebraMap {q : K[X]} (hq : q ≠ 0) :
+    (placeInfty K).ord (algebraMap K[X] (RatFunc K) q) = -(q.natDegree : ℤ) := by
+  rw [ord_placeInfty (RatFunc.algebraMap_ne_zero hq), RatFunc.intDegree_polynomial]
+
+end PlaceInftyOrd
+
+section IrreducibleDivisor
+
+variable [DecidableEq (RatFunc K)]
+
+theorem single_add_single_apply_eq_ord {p : K[X]} (hp : Irreducible p)
+    (v : Place K (RatFunc K)) :
+    (Finsupp.single (finitePlace K hp) (1 : ℤ)
+        + Finsupp.single (placeInfty K) (-(p.natDegree : ℤ))) v
+      = v.ord (algebraMap K[X] (RatFunc K) p) := by
+  have hp0 : p ≠ 0 := hp.ne_zero
+  rw [Finsupp.add_apply]
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+  · rw [Finsupp.single_eq_of_ne (Ne.symm (placeInfty_ne_ofHeightOneSpectrum K w)), add_zero]
+    by_cases hcase :
+        Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w = finitePlace K hp
+    · rw [hcase, Finsupp.single_eq_same]
+      exact (ord_ofHeightOneSpectrum_of_span (heightOneSpectrumOfIrreducible K hp) hp0
+        (heightOneSpectrumOfIrreducible_asIdeal K hp)).symm
+    · rw [Finsupp.single_eq_of_ne hcase]
+      refine (ord_ofHeightOneSpectrum_eq_zero_of_notMem w hp0 fun hmem => hcase ?_).symm
+      have hspan : Ideal.span {p} = w.asIdeal :=
+        (PrincipalIdealRing.isMaximal_of_irreducible hp).eq_of_le w.isPrime.ne_top
+          ((Ideal.span_singleton_le_iff_mem _).mpr hmem)
+      have hwp : w = heightOneSpectrumOfIrreducible K hp :=
+        HeightOneSpectrum.ext
+          (hspan.symm.trans (heightOneSpectrumOfIrreducible_asIdeal K hp).symm)
+      rw [hwp, finitePlace_def]
+  · rw [Finsupp.single_eq_of_ne
+        (show placeInfty K ≠ finitePlace K hp from
+          placeInfty_ne_ofHeightOneSpectrum K (heightOneSpectrumOfIrreducible K hp)),
+      Finsupp.single_eq_same, zero_add]
+    exact (ord_placeInfty_algebraMap hp0).symm
+
+theorem degree_single_add_single {p : K[X]} (hp : Irreducible p) :
+    Divisor.degree (Finsupp.single (finitePlace K hp) (1 : ℤ)
+        + Finsupp.single (placeInfty K) (-(p.natDegree : ℤ))) = 0 := by
+  rw [map_add, Divisor.degree_single, Divisor.degree_single, deg_finitePlace, deg_placeInfty]
+  push_cast
+  ring
+
+end IrreducibleDivisor
+
+def principalDivisor {f : RatFunc K} (hf : f ≠ 0) : Divisor K (RatFunc K) :=
+  ⟨(finite_setOf_ord_ne_zero hf).toFinset, fun v => v.ord f, fun v => by
+    simp [Set.Finite.mem_toFinset]⟩
+
+@[scoped simp]
+theorem principalDivisor_apply {f : RatFunc K} (hf : f ≠ 0) (v : Place K (RatFunc K)) :
+    principalDivisor hf v = v.ord f := rfl
+
+theorem principalDivisor_isPrincipal {f : RatFunc K} (hf : f ≠ 0) :
+    (principalDivisor hf).IsPrincipal :=
+  ⟨f, hf, fun _ => rfl⟩
+
+theorem degree_principalDivisor {f : RatFunc K} (hf : f ≠ 0) :
+    Divisor.degree (principalDivisor hf) = 0 :=
+  degree_eq_zero_of_forall_eq_ord (principalDivisor hf) fun _ => rfl
+
+theorem sum_ord_mul_deg_eq_zero {f : RatFunc K} (hf : f ≠ 0) :
+    ∑ v ∈ (finite_setOf_ord_ne_zero hf).toFinset, v.ord f * (v.deg : ℤ) = 0 := by
+  have h1 : (principalDivisor hf : Divisor K (RatFunc K))
+      = ∑ v ∈ (finite_setOf_ord_ne_zero hf).toFinset, Finsupp.single v (v.ord f) :=
+    (Finsupp.sum_single (principalDivisor hf)).symm
+  have h2 := degree_principalDivisor hf
+  rw [h1, map_sum] at h2
+  simp only [Divisor.degree_single] at h2
+  exact h2
+
+end RationalFunctionField
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "heightOneSpectrumOfIrreducible \
+  heightOneSpectrumOfIrreducible_asIdeal exists_irreducible_span finitePlace finitePlace_def \
+  algebraMap_mem_ofHeightOneSpectrum deg_finitePlace placeOfPoint \
+  placeOfPoint_eq_ofHeightOneSpectrum placeOfPoint_injective deg_placeOfPoint placeInfty \
+  placeInfty_toValuationSubring finite_setOf_ord_ne_zero degree_eq_zero_of_forall_eq_ord \
+  hasPrincipalDivisors ord_ofHeightOneSpectrum_of_span"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable (K : Type*) [Field K]
+
+theorem placeOfPoint_ne_placeInfty [DecidableEq (RatFunc K)] (a : K) :
+    placeOfPoint K a ≠ placeInfty K := by
+  rw [placeOfPoint_eq_ofHeightOneSpectrum]
+  exact fun h => placeInfty_ne_ofHeightOneSpectrum K _ h.symm
+
+variable {K}
+
+theorem ord_placeOfPoint_algebraMap_eq_mul (a : K) {q : K[X]} (hq : q ≠ 0) :
+    (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) q)
+      = (rootMultiplicity a q : ℤ)
+          * (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) (X - C a)) := by
+  obtain ⟨r, hr⟩ := pow_rootMultiplicity_dvd q a
+  set m : ℕ := rootMultiplicity a q with hm
+  have hXa : (X : K[X]) - C a ≠ 0 := X_sub_C_ne_zero a
+  have hr0 : r ≠ 0 := by
+    rintro rfl
+    exact hq (by simpa using hr)
+  have hndvd : ¬((X : K[X]) - C a) ∣ r := by
+    intro ⟨s, hs⟩
+    have : (X - C a) ^ (m + 1) ∣ q := ⟨s, by rw [hr, hs]; ring⟩
+    have := (le_rootMultiplicity_iff hq).mpr this
+    omega
+  have hinj := IsFractionRing.injective K[X] (RatFunc K)
+  have hXa' : algebraMap K[X] (RatFunc K) (X - C a) ≠ 0 := (map_ne_zero_iff _ hinj).mpr hXa
+  have hr0' : algebraMap K[X] (RatFunc K) r ≠ 0 := (map_ne_zero_iff _ hinj).mpr hr0
+  have hpow' : algebraMap K[X] (RatFunc K) ((X - C a) ^ m) ≠ 0 :=
+    (map_ne_zero_iff _ hinj).mpr (pow_ne_zero m hXa)
+  have hordr : (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) r) = 0 := by
+    by_contra hcon
+    exact hndvd (((ord_finitePlace_ne_zero_iff K (irreducible_X_sub_C a) hr0).mp) hcon)
+  calc (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) q)
+      = (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) ((X - C a) ^ m)
+          * algebraMap K[X] (RatFunc K) r) := by rw [← map_mul, ← hr]
+    _ = (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) ((X - C a) ^ m))
+          + (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) r) :=
+        (placeOfPoint K a).ord_mul hpow' hr0'
+    _ = (placeOfPoint K a).ord ((algebraMap K[X] (RatFunc K) (X - C a)) ^ (m : ℤ)) := by
+        rw [hordr, add_zero, map_pow, ← zpow_natCast]
+    _ = (m : ℤ) * (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) (X - C a)) :=
+        (placeOfPoint K a).ord_zpow _ _
+
+theorem dvd_ord_placeOfPoint (a : K) {f : RatFunc K} (hf : f ≠ 0) :
+    (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) (X - C a)) ∣ (placeOfPoint K a).ord f := by
+  have hinj := IsFractionRing.injective K[X] (RatFunc K)
+  have hnum : f.num ≠ 0 := RatFunc.num_ne_zero hf
+  have hden : f.denom ≠ 0 := f.denom_ne_zero
+  have hnum' : algebraMap K[X] (RatFunc K) f.num ≠ 0 := (map_ne_zero_iff _ hinj).mpr hnum
+  have hden' : algebraMap K[X] (RatFunc K) f.denom ≠ 0 := (map_ne_zero_iff _ hinj).mpr hden
+  have hsplit : f = algebraMap K[X] (RatFunc K) f.num
+      * (algebraMap K[X] (RatFunc K) f.denom)⁻¹ := by
+    rw [← div_eq_mul_inv, f.num_div_denom]
+  rw [hsplit, (placeOfPoint K a).ord_mul hnum' (inv_ne_zero hden'), Place.ord_inv,
+    ord_placeOfPoint_algebraMap_eq_mul a hnum, ord_placeOfPoint_algebraMap_eq_mul a hden]
+  exact dvd_add (Dvd.intro_left _ rfl) ((Dvd.intro_left _ rfl).neg_right)
+
+theorem ord_placeOfPoint_X_sub_C (a : K) :
+    (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) (X - C a)) = 1 := by
+  set v := placeOfPoint K a with hv
+  set n : ℤ := v.ord (algebraMap K[X] (RatFunc K) (X - C a)) with hn
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπ0 : (π : RatFunc K) ≠ 0 := by
+    simpa using hπ.ne_zero
+  have h1 : v.ord (π : RatFunc K) = 1 := v.ord_coe_irreducible hπ
+  have hdvd : n ∣ 1 := h1 ▸ dvd_ord_placeOfPoint a hπ0
+  have hmem : algebraMap K[X] (RatFunc K) (X - C a) ∈ v.toValuationSubring := by
+    rw [hv, placeOfPoint_eq_ofHeightOneSpectrum]
+    exact algebraMap_mem_ofHeightOneSpectrum K _ _
+  have hnonneg : 0 ≤ n := v.ord_nonneg_of_mem hmem
+  rcases Int.isUnit_iff.mp (isUnit_of_dvd_one hdvd) with h | h
+  · exact h
+  · omega
+
+theorem ord_placeOfPoint_algebraMap (a : K) {q : K[X]} (hq : q ≠ 0) :
+    (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) q) = rootMultiplicity a q := by
+  rw [ord_placeOfPoint_algebraMap_eq_mul a hq, ord_placeOfPoint_X_sub_C a, mul_one]
+
+variable (K)
+
+theorem exists_eq_placeOfPoint [IsAlgClosed K] (w : HeightOneSpectrum K[X]) :
+    ∃ a : K, Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w = placeOfPoint K a := by
+  obtain ⟨p, hp, hwp⟩ := exists_irreducible_span K w
+  have hdeg : p.degree ≠ 0 := by
+    rw [IsAlgClosed.degree_eq_one_of_irreducible K hp]
+    exact one_ne_zero
+  obtain ⟨a, ha⟩ := IsAlgClosed.exists_root p hdeg
+  refine ⟨a, ?_⟩
+  have hassoc : Associated ((X : K[X]) - C a) p :=
+    (irreducible_X_sub_C a).associated_of_dvd hp (dvd_iff_isRoot.mpr ha)
+  have hideal : w = heightOneSpectrumOfIrreducible K (irreducible_X_sub_C a) :=
+    HeightOneSpectrum.ext (by
+      rw [hwp, heightOneSpectrumOfIrreducible_asIdeal]
+      exact (Ideal.span_singleton_eq_span_singleton.mpr hassoc).symm)
+  rw [hideal, placeOfPoint_eq_ofHeightOneSpectrum]
+
+theorem eq_placeOfPoint_or_eq_placeInfty [IsAlgClosed K] [DecidableEq (RatFunc K)]
+    (v : Place K (RatFunc K)) :
+    (∃ a : K, v = placeOfPoint K a) ∨ v = placeInfty K := by
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, hw⟩ | hw
+  · obtain ⟨a, ha⟩ := exists_eq_placeOfPoint K w
+    exact Or.inl ⟨a, hw.trans ha⟩
+  · exact Or.inr hw
+
+private def ofOption [DecidableEq (RatFunc K)] : Option K → Place K (RatFunc K) :=
+  fun o => o.elim (placeInfty K) (placeOfPoint K)
+
+private theorem ofOption_bijective [IsAlgClosed K] [DecidableEq (RatFunc K)] :
+    Function.Bijective (ofOption K) := by
+  constructor
+  · rintro (_ | a) (_ | b) h
+    · rfl
+    · exact absurd h.symm (placeOfPoint_ne_placeInfty K b)
+    · exact absurd h (placeOfPoint_ne_placeInfty K a)
+    · exact congrArg some (placeOfPoint_injective K h)
+  · intro v
+    rcases eq_placeOfPoint_or_eq_placeInfty K v with ⟨a, ha⟩ | ha
+    · exact ⟨some a, ha.symm⟩
+    · exact ⟨none, ha.symm⟩
+
+def placeEquivOption [IsAlgClosed K] [DecidableEq (RatFunc K)] :
+    Place K (RatFunc K) ≃ Option K :=
+  (Equiv.ofBijective (ofOption K) (ofOption_bijective K)).symm
+
+@[scoped simp]
+theorem placeEquivOption_symm_some [IsAlgClosed K] [DecidableEq (RatFunc K)] (a : K) :
+    (placeEquivOption K).symm (some a) = placeOfPoint K a := rfl
+
+@[scoped simp]
+theorem placeEquivOption_symm_none [IsAlgClosed K] [DecidableEq (RatFunc K)] :
+    (placeEquivOption K).symm none = placeInfty K := rfl
+
+@[scoped simp]
+theorem placeEquivOption_placeOfPoint [IsAlgClosed K] [DecidableEq (RatFunc K)] (a : K) :
+    placeEquivOption K (placeOfPoint K a) = some a :=
+  (Equiv.ofBijective (ofOption K) (ofOption_bijective K)).symm_apply_apply (some a)
+
+@[scoped simp]
+theorem placeEquivOption_placeInfty [IsAlgClosed K] [DecidableEq (RatFunc K)] :
+    placeEquivOption K (placeInfty K) = none :=
+  (Equiv.ofBijective (ofOption K) (ofOption_bijective K)).symm_apply_apply none
+
+theorem deg_eq_one_of_isAlgClosed [IsAlgClosed K] (v : Place K (RatFunc K)) : v.deg = 1 := by
+  classical
+  rcases eq_placeOfPoint_or_eq_placeInfty K v with ⟨a, rfl⟩ | rfl
+  · exact deg_placeOfPoint K a
+  · exact deg_placeInfty K
+
+end RationalFunctionField
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "heightOneSpectrumOfIrreducible \
+  heightOneSpectrumOfIrreducible_asIdeal exists_irreducible_span finitePlace finitePlace_def \
+  algebraMap_mem_ofHeightOneSpectrum deg_finitePlace placeOfPoint \
+  placeOfPoint_eq_ofHeightOneSpectrum placeOfPoint_injective deg_placeOfPoint placeInfty \
+  placeInfty_toValuationSubring finite_setOf_ord_ne_zero degree_eq_zero_of_forall_eq_ord \
+  hasPrincipalDivisors ord_ofHeightOneSpectrum_of_span"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable {K : Type*} [Field K]
+
+theorem algebraMap_polynomial_ne_zero {q : K[X]} (hq : q ≠ 0) :
+    algebraMap K[X] (RatFunc K) q ≠ 0 :=
+  RatFunc.algebraMap_ne_zero hq
+
+theorem algebraMap_C (c : K) :
+    algebraMap K[X] (RatFunc K) (C c) = algebraMap K (RatFunc K) c := by
+  rw [IsScalarTower.algebraMap_apply K K[X] (RatFunc K), Polynomial.algebraMap_eq]
+
+theorem evalAt_placeOfPoint_algebraMap (a : K) (q : K[X]) :
+    (placeOfPoint K a).evalAt (algebraMap K[X] (RatFunc K) q) = q.eval a := by
+  have hmem : algebraMap K[X] (RatFunc K) q ∈ (placeOfPoint K a).toValuationSubring :=
+    algebraMap_mem_ofHeightOneSpectrum K _ q
+  have hmem' : algebraMap K (RatFunc K) (q.eval a) ∈ (placeOfPoint K a).toValuationSubring :=
+    (placeOfPoint K a).algebraMap_mem' _
+  have hsub : algebraMap K[X] (RatFunc K) q - algebraMap K (RatFunc K) (q.eval a)
+      = algebraMap K[X] (RatFunc K) (q - C (q.eval a)) := by
+    rw [map_sub, algebraMap_C]
+  have hcongr : (placeOfPoint K a).evalAt (algebraMap K[X] (RatFunc K) q)
+      = (placeOfPoint K a).evalAt (algebraMap K (RatFunc K) (q.eval a)) := by
+    refine Place.evalAt_congr _ hmem hmem' ?_
+    rw [hsub]
+    rcases eq_or_ne (q - C (q.eval a)) 0 with h0 | h0
+    · exact Or.inl (by rw [h0, map_zero])
+    · refine Or.inr ?_
+      rw [ord_placeOfPoint_algebraMap a h0]
+      have hroot : (q - C (q.eval a)).IsRoot a := by
+        simp [IsRoot.def]
+      exact_mod_cast (rootMultiplicity_pos h0).mpr hroot
+  rw [hcongr, Place.evalAt_algebraMap]
+
+theorem evalAt_placeOfPoint_X_sub_C (a b : K) :
+    (placeOfPoint K a).evalAt (algebraMap K[X] (RatFunc K) (X - C b)) = a - b := by
+  rw [evalAt_placeOfPoint_algebraMap]
+  simp
+
+section PlaceInfty
+
+variable [DecidableEq (RatFunc K)]
+
+theorem mem_placeInfty_of_intDegree_nonpos {f : RatFunc K} (hf : f ≠ 0)
+    (h : f.intDegree ≤ 0) : f ∈ (placeInfty K).toValuationSubring :=
+  (placeInfty K).mem_of_ord_nonneg hf (by rw [ord_placeInfty hf]; omega)
+
+theorem evalAt_placeInfty_eq {f : RatFunc K} {c : K}
+    (h : f - algebraMap K (RatFunc K) c = 0
+      ∨ (f - algebraMap K (RatFunc K) c).intDegree < 0) :
+    (placeInfty K).evalAt f = c := by
+  have hsubmem : f - algebraMap K (RatFunc K) c ∈ (placeInfty K).toValuationSubring := by
+    rcases h with h | h
+    · rw [h]; exact zero_mem _
+    · refine mem_placeInfty_of_intDegree_nonpos ?_ h.le
+      intro h0
+      rw [h0] at h
+      simp [RatFunc.intDegree_zero] at h
+  have hmem : f ∈ (placeInfty K).toValuationSubring := by
+    have : f = (f - algebraMap K (RatFunc K) c) + algebraMap K (RatFunc K) c := by ring
+    rw [this]
+    exact add_mem hsubmem ((placeInfty K).algebraMap_mem' c)
+  have hcongr : (placeInfty K).evalAt f
+      = (placeInfty K).evalAt (algebraMap K (RatFunc K) c) := by
+    refine Place.evalAt_congr _ hmem ((placeInfty K).algebraMap_mem' c) ?_
+    rcases h with h | h
+    · exact Or.inl h
+    · refine Or.inr ?_
+      have hne : f - algebraMap K (RatFunc K) c ≠ 0 := by
+        intro h0
+        rw [h0] at h
+        simp [RatFunc.intDegree_zero] at h
+      rw [ord_placeInfty hne]
+      omega
+  rw [hcongr, Place.evalAt_algebraMap]
+
+theorem evalAt_placeInfty_X_sub_C_div (a a₀ : K) :
+    (placeInfty K).evalAt
+        (algebraMap K[X] (RatFunc K) (X - C a) / algebraMap K[X] (RatFunc K) (X - C a₀))
+      = 1 := by
+  have ha₀ : algebraMap K[X] (RatFunc K) (X - C a₀) ≠ 0 :=
+    algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a₀)
+  refine evalAt_placeInfty_eq ?_
+  have hkey : algebraMap K[X] (RatFunc K) (X - C a) / algebraMap K[X] (RatFunc K) (X - C a₀)
+        - algebraMap K (RatFunc K) 1
+      = algebraMap K[X] (RatFunc K) (C (a₀ - a)) / algebraMap K[X] (RatFunc K) (X - C a₀) := by
+    rw [map_one, div_sub_one ha₀, ← map_sub]
+    congr 2
+    rw [map_sub]
+    ring
+  rw [hkey]
+  rcases eq_or_ne a₀ a with rfl | hne
+  · exact Or.inl (by simp)
+  · refine Or.inr ?_
+    have hC : (C (a₀ - a) : K[X]) ≠ 0 := by
+      simpa [sub_eq_zero] using hne
+    rw [RatFunc.intDegree_div (algebraMap_polynomial_ne_zero hC) ha₀,
+      RatFunc.intDegree_polynomial, RatFunc.intDegree_polynomial, natDegree_C,
+      natDegree_X_sub_C]
+    norm_num
+
+end PlaceInfty
+
+section CrossRatio
+
+variable [DecidableEq (RatFunc K)]
+
+theorem principalDivisor_X_sub_C (b : K) :
+    principalDivisor (algebraMap_polynomial_ne_zero (X_sub_C_ne_zero b))
+      = Finsupp.single (placeOfPoint K b) 1 + Finsupp.single (placeInfty K) (-1) := by
+  ext v
+  have h := single_add_single_apply_eq_ord (irreducible_X_sub_C b) v
+  rw [natDegree_X_sub_C, Nat.cast_one] at h
+  rw [principalDivisor_apply, ← h]
+  rfl
+
+theorem ord_X_sub_C (b : K) (v : Place K (RatFunc K)) :
+    v.ord (algebraMap K[X] (RatFunc K) (X - C b))
+      = (Finsupp.single (placeOfPoint K b) (1 : ℤ)
+          + Finsupp.single (placeInfty K) (-1 : ℤ)) v := by
+  rw [← principalDivisor_X_sub_C b, principalDivisor_apply]
+
+omit [DecidableEq (RatFunc K)] in
+theorem ord_X_sub_C_placeOfPoint_of_ne {a b : K} (hab : a ≠ b) :
+    (placeOfPoint K a).ord (algebraMap K[X] (RatFunc K) (X - C b)) = 0 := by
+  classical
+  rw [ord_X_sub_C, Finsupp.add_apply,
+    Finsupp.single_eq_of_ne
+      (show placeOfPoint K a ≠ placeOfPoint K b from
+        fun h => hab (placeOfPoint_injective K h)),
+    Finsupp.single_eq_of_ne (placeOfPoint_ne_placeInfty K a), add_zero]
+
+omit [DecidableEq (RatFunc K)] in
+theorem ord_X_sub_C_placeOfPoint_self (b : K) :
+    (placeOfPoint K b).ord (algebraMap K[X] (RatFunc K) (X - C b)) = 1 := by
+  classical
+  rw [ord_X_sub_C, Finsupp.add_apply, Finsupp.single_eq_same,
+    Finsupp.single_eq_of_ne (placeOfPoint_ne_placeInfty K b), add_zero]
+
+theorem ord_X_sub_C_placeInfty (b : K) :
+    (placeInfty K).ord (algebraMap K[X] (RatFunc K) (X - C b)) = -1 := by
+  rw [ord_X_sub_C, Finsupp.add_apply,
+    Finsupp.single_eq_of_ne (Ne.symm (placeOfPoint_ne_placeInfty K b)),
+    Finsupp.single_eq_same, zero_add]
+
+omit [DecidableEq (RatFunc K)] in
+theorem isRational_placeOfPoint (a : K) : (placeOfPoint K a).IsRational :=
+  Place.isRational_of_deg_eq_one _ (deg_placeOfPoint K a)
+
+omit [DecidableEq (RatFunc K)] in
+theorem principalDivisor_X_sub_C_div (a a₀ : K) :
+    principalDivisor (div_ne_zero (algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a))
+        (algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a₀)))
+      = Finsupp.single (placeOfPoint K a) 1 + Finsupp.single (placeOfPoint K a₀) (-1) := by
+  classical
+  have hLa : algebraMap K[X] (RatFunc K) (X - C a) ≠ 0 :=
+    algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a)
+  have hLa₀ : algebraMap K[X] (RatFunc K) (X - C a₀) ≠ 0 :=
+    algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a₀)
+  ext v
+  have hneg : (Finsupp.single (placeOfPoint K a₀) (-1 : ℤ)) v
+      = -((Finsupp.single (placeOfPoint K a₀) (1 : ℤ)) v) := by
+    rcases eq_or_ne v (placeOfPoint K a₀) with rfl | h
+    · rw [Finsupp.single_eq_same, Finsupp.single_eq_same]
+    · rw [Finsupp.single_eq_of_ne h, Finsupp.single_eq_of_ne h, neg_zero]
+  rw [principalDivisor_apply, div_eq_mul_inv, v.ord_mul hLa (inv_ne_zero hLa₀), v.ord_inv,
+    ord_X_sub_C a v, ord_X_sub_C a₀ v]
+  simp only [Finsupp.add_apply]
+  rw [hneg]
+  ring
+
+omit [DecidableEq (RatFunc K)] in
+theorem evalAt_placeOfPoint_X_sub_C_div (a a₀ : K) {b : K} (hba₀ : b ≠ a₀) :
+    (placeOfPoint K b).evalAt
+        (algebraMap K[X] (RatFunc K) (X - C a) / algebraMap K[X] (RatFunc K) (X - C a₀))
+      = (b - a) / (b - a₀) := by
+  classical
+  have hLa₀ : algebraMap K[X] (RatFunc K) (X - C a₀) ≠ 0 :=
+    algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a₀)
+  have hord : (placeOfPoint K b).ord (algebraMap K[X] (RatFunc K) (X - C a₀)) = 0 :=
+    ord_X_sub_C_placeOfPoint_of_ne hba₀
+  rw [div_eq_mul_inv, (placeOfPoint K b).evalAt_mul (isRational_placeOfPoint b)
+      (algebraMap_mem_ofHeightOneSpectrum K _ _)
+      ((placeOfPoint K b).mem_of_ord_nonneg (inv_ne_zero hLa₀)
+        (by rw [Place.ord_inv, hord, neg_zero])),
+    (placeOfPoint K b).evalAt_inv (isRational_placeOfPoint b) hLa₀ hord,
+    evalAt_placeOfPoint_X_sub_C, evalAt_placeOfPoint_X_sub_C, div_eq_mul_inv]
+
+end CrossRatio
+
+section Reciprocity
+
+variable [IsAlgClosed K] [DecidableEq (RatFunc K)]
+
+omit [DecidableEq (RatFunc K)] in
+theorem isRational_of_isAlgClosed (v : Place K (RatFunc K)) : v.IsRational :=
+  Place.isRational_of_deg_eq_one v (deg_eq_one_of_isAlgClosed K v)
+
+omit [IsAlgClosed K] [DecidableEq (RatFunc K)] in
+theorem algebraMap_const_ne_zero {c : K} (hc : c ≠ 0) : algebraMap K (RatFunc K) c ≠ 0 := by
+  simpa using hc
+
+local instance : DecidableEq (Place K (RatFunc K)) := Classical.decEq _
+
+omit [IsAlgClosed K] [DecidableEq (RatFunc K)] in
+theorem ord_ne_zero_of_mem_support {g : RatFunc K} (hg : g ≠ 0) {v : Place K (RatFunc K)}
+    (hv : v ∈ (principalDivisor hg).support) : v.ord g ≠ 0 := by
+  rwa [Finsupp.mem_support_iff, principalDivisor_apply] at hv
+
+omit [DecidableEq (RatFunc K)] in
+theorem sum_ord_eq_zero {f : RatFunc K} (hf : f ≠ 0) :
+    ∑ v ∈ (principalDivisor hf).support, v.ord f = 0 := by
+  rw [← sum_ord_mul_deg_eq_zero hf]
+  exact Finset.sum_congr rfl fun v _ => by
+    rw [deg_eq_one_of_isAlgClosed K v, Nat.cast_one, mul_one]
+
+omit [IsAlgClosed K] [DecidableEq (RatFunc K)] in
+theorem zpow_sum_eq_prod {c : K} (hc : c ≠ 0) {ι : Type*} (s : Finset ι) (n : ι → ℤ) :
+    ∏ i ∈ s, c ^ n i = c ^ (∑ i ∈ s, n i) := by
+  induction s using Finset.cons_induction with
+  | empty => simp
+  | cons a s ha ih => rw [Finset.prod_cons, Finset.sum_cons, zpow_add₀ hc, ih]
+
+omit [IsAlgClosed K] [DecidableEq (RatFunc K)] in
+theorem principalDivisor_congr {f g : RatFunc K} (hf : f ≠ 0) (hg : g ≠ 0) (h : f = g) :
+    principalDivisor hf = principalDivisor hg := by
+  subst h
+  rfl
+
+omit [DecidableEq (RatFunc K)] in
+theorem reciprocity_algebraMap_right {f : RatFunc K} (hf : f ≠ 0) {c : K} (hc : c ≠ 0) :
+    Divisor.evalFun f (principalDivisor (algebraMap_const_ne_zero hc))
+      = Divisor.evalFun (algebraMap K (RatFunc K) c) (principalDivisor hf) := by
+  have hzero : principalDivisor (algebraMap_const_ne_zero hc) = 0 := by
+    ext v
+    rw [principalDivisor_apply, v.ord_algebraMap, Finsupp.coe_zero, Pi.zero_apply]
+  rw [hzero, Divisor.evalFun_zero, Divisor.evalFun_def]
+  rw [Finset.prod_congr rfl fun v _ => by rw [Place.evalAt_algebraMap],
+    zpow_sum_eq_prod hc]
+  rw [show ∑ v ∈ (principalDivisor hf).support, principalDivisor hf v
+      = ∑ v ∈ (principalDivisor hf).support, v.ord f from
+    Finset.sum_congr rfl fun v _ => principalDivisor_apply hf v, sum_ord_eq_zero hf,
+    zpow_zero]
+
+omit [DecidableEq (RatFunc K)] in
+theorem reciprocity_mul_right {f g₁ g₂ : RatFunc K} (hf : f ≠ 0) (hg₁ : g₁ ≠ 0) (hg₂ : g₂ ≠ 0)
+    (hd₁ : ∀ v : Place K (RatFunc K), v.ord f = 0 ∨ v.ord g₁ = 0)
+    (hd₂ : ∀ v : Place K (RatFunc K), v.ord f = 0 ∨ v.ord g₂ = 0)
+    (h₁ : Divisor.evalFun f (principalDivisor hg₁) = Divisor.evalFun g₁ (principalDivisor hf))
+    (h₂ : Divisor.evalFun f (principalDivisor hg₂)
+      = Divisor.evalFun g₂ (principalDivisor hf)) :
+    Divisor.evalFun f (principalDivisor (mul_ne_zero hg₁ hg₂))
+      = Divisor.evalFun (g₁ * g₂) (principalDivisor hf) := by
+  have hsplit : principalDivisor (mul_ne_zero hg₁ hg₂)
+      = principalDivisor hg₁ + principalDivisor hg₂ := by
+    ext v
+    rw [principalDivisor_apply, Finsupp.add_apply, principalDivisor_apply,
+      principalDivisor_apply, v.ord_mul hg₁ hg₂]
+  rw [hsplit,
+    Divisor.evalFun_add f
+      (fun v hv => v.evalAt_ne_zero (isRational_of_isAlgClosed v) hf
+        ((hd₁ v).resolve_right (ord_ne_zero_of_mem_support hg₁ hv)))
+      (fun v hv => v.evalAt_ne_zero (isRational_of_isAlgClosed v) hf
+        ((hd₂ v).resolve_right (ord_ne_zero_of_mem_support hg₂ hv))),
+    h₁, h₂,
+    ← Divisor.evalFun_mul (fun v _ => isRational_of_isAlgClosed v)
+      (fun v hv => v.mem_of_ord_nonneg hg₁
+        ((hd₁ v).resolve_left (ord_ne_zero_of_mem_support hf hv)).ge)
+      (fun v hv => v.mem_of_ord_nonneg hg₂
+        ((hd₂ v).resolve_left (ord_ne_zero_of_mem_support hf hv)).ge)]
+
+omit [DecidableEq (RatFunc K)] in
+theorem reciprocity_mul_left {f₁ f₂ g : RatFunc K} (hf₁ : f₁ ≠ 0) (hf₂ : f₂ ≠ 0) (hg : g ≠ 0)
+    (hd₁ : ∀ v : Place K (RatFunc K), v.ord f₁ = 0 ∨ v.ord g = 0)
+    (hd₂ : ∀ v : Place K (RatFunc K), v.ord f₂ = 0 ∨ v.ord g = 0)
+    (h₁ : Divisor.evalFun f₁ (principalDivisor hg) = Divisor.evalFun g (principalDivisor hf₁))
+    (h₂ : Divisor.evalFun f₂ (principalDivisor hg)
+      = Divisor.evalFun g (principalDivisor hf₂)) :
+    Divisor.evalFun (f₁ * f₂) (principalDivisor hg)
+      = Divisor.evalFun g (principalDivisor (mul_ne_zero hf₁ hf₂)) :=
+  (reciprocity_mul_right hg hf₁ hf₂ (fun v => (hd₁ v).symm) (fun v => (hd₂ v).symm)
+    h₁.symm h₂.symm).symm
+
+omit [DecidableEq (RatFunc K)] in
+theorem reciprocity_zpow_right {f g : RatFunc K} (hf : f ≠ 0) (hg : g ≠ 0) (n : ℤ)
+    (hd : ∀ v : Place K (RatFunc K), v.ord f = 0 ∨ v.ord g = 0)
+    (h : Divisor.evalFun f (principalDivisor hg)
+      = Divisor.evalFun g (principalDivisor hf)) :
+    Divisor.evalFun f (principalDivisor (zpow_ne_zero n hg))
+      = Divisor.evalFun (g ^ n) (principalDivisor hf) := by
+  have hsplit : principalDivisor (zpow_ne_zero n hg) = n • principalDivisor hg := by
+    ext v
+    rw [principalDivisor_apply, Finsupp.smul_apply, principalDivisor_apply, v.ord_zpow,
+      smul_eq_mul]
+  rw [hsplit, Divisor.evalFun_zsmul, h,
+    ← Divisor.evalFun_zpow_left hg n (fun v _ => isRational_of_isAlgClosed v)
+      (fun v hv => (hd v).resolve_left (ord_ne_zero_of_mem_support hf hv))]
+
+omit [DecidableEq (RatFunc K)] in
+theorem reciprocity_zpow_left {f g : RatFunc K} (hf : f ≠ 0) (hg : g ≠ 0) (n : ℤ)
+    (hd : ∀ v : Place K (RatFunc K), v.ord f = 0 ∨ v.ord g = 0)
+    (h : Divisor.evalFun f (principalDivisor hg)
+      = Divisor.evalFun g (principalDivisor hf)) :
+    Divisor.evalFun (f ^ n) (principalDivisor hg)
+      = Divisor.evalFun g (principalDivisor (zpow_ne_zero n hf)) :=
+  (reciprocity_zpow_right hg hf n (fun v => (hd v).symm) h.symm).symm
+
+omit [IsAlgClosed K] [DecidableEq (RatFunc K)] in
+theorem exists_algebraMap_of_forall_ord_eq_zero {g : RatFunc K} (hg : g ≠ 0)
+    (h : ∀ v : Place K (RatFunc K), v.ord g = 0) :
+    ∃ c : K, c ≠ 0 ∧ g = algebraMap K (RatFunc K) c := by
+  have hnum0 : g.num ≠ 0 := RatFunc.num_ne_zero hg
+  have hden0 : g.denom ≠ 0 := g.denom_ne_zero
+  have hnum0' : algebraMap K[X] (RatFunc K) g.num ≠ 0 := algebraMap_polynomial_ne_zero hnum0
+  have hden0' : algebraMap K[X] (RatFunc K) g.denom ≠ 0 := algebraMap_polynomial_ne_zero hden0
+  have hsplit : g = algebraMap K[X] (RatFunc K) g.num
+      * (algebraMap K[X] (RatFunc K) g.denom)⁻¹ := by
+    rw [← div_eq_mul_inv, g.num_div_denom]
+  have hkey : ∀ p : K[X], Irreducible p → ¬p ∣ g.num ∧ ¬p ∣ g.denom := by
+    intro p hpirr
+    have hord : (finitePlace K hpirr).ord (algebraMap K[X] (RatFunc K) g.num)
+        = (finitePlace K hpirr).ord (algebraMap K[X] (RatFunc K) g.denom) := by
+      have h0 := h (finitePlace K hpirr)
+      rw [hsplit, (finitePlace K hpirr).ord_mul hnum0' (inv_ne_zero hden0'),
+        Place.ord_inv] at h0
+      omega
+    constructor
+    · intro hdvd
+      refine hpirr.not_isUnit (g.isCoprime_num_denom.isUnit_of_dvd' hdvd ?_)
+      refine (ord_finitePlace_ne_zero_iff K hpirr hden0).mp ?_
+      rw [← hord]
+      exact (ord_finitePlace_ne_zero_iff K hpirr hnum0).mpr hdvd
+    · intro hdvd
+      refine hpirr.not_isUnit (g.isCoprime_num_denom.isUnit_of_dvd' ?_ hdvd)
+      refine (ord_finitePlace_ne_zero_iff K hpirr hnum0).mp ?_
+      rw [hord]
+      exact (ord_finitePlace_ne_zero_iff K hpirr hden0).mpr hdvd
+  have hunit : ∀ q : K[X], q ≠ 0 → (∀ p : K[X], Irreducible p → ¬p ∣ q) → IsUnit q := by
+    intro q hq hp
+    by_contra hu
+    obtain ⟨p, hpirr, hpdvd⟩ := WfDvdMonoid.exists_irreducible_factor hu hq
+    exact hp p hpirr hpdvd
+  obtain ⟨c₁, hc₁u, hc₁⟩ :=
+    Polynomial.isUnit_iff.mp (hunit g.num hnum0 fun p hp => (hkey p hp).1)
+  obtain ⟨c₂, hc₂u, hc₂⟩ :=
+    Polynomial.isUnit_iff.mp (hunit g.denom hden0 fun p hp => (hkey p hp).2)
+  have hc₁0 : c₁ ≠ 0 := fun h0 => hnum0 (by rw [← hc₁, h0, map_zero])
+  have hc₂0 : c₂ ≠ 0 := fun h0 => hden0 (by rw [← hc₂, h0, map_zero])
+  refine ⟨c₁ / c₂, div_ne_zero hc₁0 hc₂0, ?_⟩
+  rw [← g.num_div_denom, ← hc₁, ← hc₂, algebraMap_C, algebraMap_C, map_div₀]
+
+omit [IsAlgClosed K] in
+omit [DecidableEq (RatFunc K)] in
+theorem crossRatio_reciprocity {a a₀ b : K} (hba : b ≠ a) (hba₀ : b ≠ a₀) :
+    Divisor.evalFun
+        (algebraMap K[X] (RatFunc K) (X - C a) / algebraMap K[X] (RatFunc K) (X - C a₀))
+        (principalDivisor (algebraMap_polynomial_ne_zero (X_sub_C_ne_zero b)))
+      = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b))
+        (principalDivisor (div_ne_zero (algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a))
+          (algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a₀)))) := by
+  classical
+  rw [principalDivisor_X_sub_C b, principalDivisor_X_sub_C_div a a₀,
+    Divisor.evalFun_single_sub_single _
+      (by rw [evalAt_placeOfPoint_X_sub_C_div a a₀ hba₀]
+          exact div_ne_zero (sub_ne_zero.mpr hba) (sub_ne_zero.mpr hba₀))
+      (by rw [evalAt_placeInfty_X_sub_C_div a a₀]; exact one_ne_zero),
+    Divisor.evalFun_single_sub_single _
+      (by rw [evalAt_placeOfPoint_X_sub_C]
+          exact sub_ne_zero.mpr fun h => hba h.symm)
+      (by rw [evalAt_placeOfPoint_X_sub_C]
+          exact sub_ne_zero.mpr fun h => hba₀ h.symm),
+    evalAt_placeOfPoint_X_sub_C_div a a₀ hba₀, evalAt_placeInfty_X_sub_C_div a a₀,
+    evalAt_placeOfPoint_X_sub_C, evalAt_placeOfPoint_X_sub_C, div_one]
+  rw [div_eq_div_iff (sub_ne_zero.mpr hba₀) (sub_ne_zero.mpr fun h => hba₀ h.symm)]
+  ring
+
+omit [DecidableEq (RatFunc K)] in
+theorem reciprocity_of_forall_ord_eq_zero {f g : RatFunc K} (hf : f ≠ 0) (hg : g ≠ 0)
+    (hzero : ∀ v : Place K (RatFunc K), v.ord g = 0) :
+    Divisor.evalFun f (principalDivisor hg) = Divisor.evalFun g (principalDivisor hf) := by
+  obtain ⟨c, hc, rfl⟩ := exists_algebraMap_of_forall_ord_eq_zero hg hzero
+  exact reciprocity_algebraMap_right hf hc
+
+omit [IsAlgClosed K] [DecidableEq (RatFunc K)] in
+theorem ord_div_zpow (v : Place K (RatFunc K)) {g h : RatFunc K} (hg : g ≠ 0) (hh : h ≠ 0)
+    (m : ℤ) : v.ord (g / h ^ m) = v.ord g - m * v.ord h := by
+  rw [div_eq_mul_inv, v.ord_mul hg (inv_ne_zero (zpow_ne_zero m hh)), v.ord_inv, v.ord_zpow,
+    sub_eq_add_neg]
+
+omit [IsAlgClosed K] in
+theorem ord_X_sub_C_eq_zero_of_ne (b : K) {v : Place K (RatFunc K)}
+    (hvb : v ≠ placeOfPoint K b) (hvinf : v ≠ placeInfty K) :
+    v.ord (algebraMap K[X] (RatFunc K) (X - C b)) = 0 := by
+  rw [ord_X_sub_C b v, Finsupp.add_apply, Finsupp.single_eq_of_ne hvb,
+    Finsupp.single_eq_of_ne hvinf, add_zero]
+
+theorem reciprocity_linear (b : K) :
+    ∀ (n : ℕ) (f : RatFunc K) (hf : f ≠ 0),
+      (placeInfty K).ord f = 0 → (placeOfPoint K b).ord f = 0 →
+      (principalDivisor hf).support.card ≤ n →
+      Divisor.evalFun f
+          (principalDivisor (algebraMap_polynomial_ne_zero (X_sub_C_ne_zero b)))
+        = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b)) (principalDivisor hf) := by
+  have hLb : algebraMap K[X] (RatFunc K) (X - C b) ≠ 0 :=
+    algebraMap_polynomial_ne_zero (X_sub_C_ne_zero b)
+  intro n
+  induction n with
+  | zero =>
+    intro f hf hinf hb hcard
+    refine (reciprocity_of_forall_ord_eq_zero hLb hf fun v => ?_).symm
+    rw [← principalDivisor_apply hf v,
+      Finsupp.support_eq_empty.mp (Finset.card_eq_zero.mp (Nat.le_zero.mp hcard))]
+    rfl
+  | succ n ih =>
+    intro f hf hinf hb hcard
+    rcases Finset.eq_empty_or_nonempty (principalDivisor hf).support with hempty | hne
+    · refine (reciprocity_of_forall_ord_eq_zero hLb hf fun v => ?_).symm
+      rw [← principalDivisor_apply hf v, Finsupp.support_eq_empty.mp hempty]
+      rfl
+    have hsum := sum_ord_eq_zero hf
+    have hexpos : ∃ v ∈ (principalDivisor hf).support, 0 < v.ord f := by
+      by_contra hcon
+      have hcon' : ∀ v ∈ (principalDivisor hf).support, v.ord f ≤ 0 := fun v hv => by
+        by_contra hgt
+        exact hcon ⟨v, hv, not_le.mp hgt⟩
+      have hlt : ∑ v ∈ (principalDivisor hf).support, v.ord f
+          < ∑ v ∈ (principalDivisor hf).support, (0 : ℤ) :=
+        Finset.sum_lt_sum_of_nonempty hne fun v hv =>
+          lt_of_le_of_ne (hcon' v hv) (ord_ne_zero_of_mem_support hf hv)
+      rw [Finset.sum_const_zero, hsum] at hlt
+      exact lt_irrefl 0 hlt
+    have hexneg : ∃ v ∈ (principalDivisor hf).support, v.ord f < 0 := by
+      by_contra hcon
+      have hcon' : ∀ v ∈ (principalDivisor hf).support, 0 ≤ v.ord f := fun v hv => by
+        by_contra hgt
+        exact hcon ⟨v, hv, not_le.mp hgt⟩
+      have hlt : ∑ v ∈ (principalDivisor hf).support, (0 : ℤ)
+          < ∑ v ∈ (principalDivisor hf).support, v.ord f :=
+        Finset.sum_lt_sum_of_nonempty hne fun v hv =>
+          lt_of_le_of_ne (hcon' v hv) (Ne.symm (ord_ne_zero_of_mem_support hf hv))
+      rw [Finset.sum_const_zero, hsum] at hlt
+      exact lt_irrefl 0 hlt
+    obtain ⟨vp, hvp_mem, hvp⟩ := hexpos
+    obtain ⟨vn, hvn_mem, hvn⟩ := hexneg
+    obtain ⟨a, rfl⟩ : ∃ x : K, vp = placeOfPoint K x := by
+      rcases eq_placeOfPoint_or_eq_placeInfty K vp with h | h
+      · exact h
+      · rw [h, hinf] at hvp
+        exact absurd hvp (lt_irrefl 0)
+    obtain ⟨a₀, rfl⟩ : ∃ x : K, vn = placeOfPoint K x := by
+      rcases eq_placeOfPoint_or_eq_placeInfty K vn with h | h
+      · exact h
+      · rw [h, hinf] at hvn
+        exact absurd hvn (lt_irrefl 0)
+    have hab : a ≠ b := by
+      rintro rfl
+      rw [hb] at hvp
+      exact lt_irrefl 0 hvp
+    have ha₀b : a₀ ≠ b := by
+      rintro rfl
+      rw [hb] at hvn
+      exact lt_irrefl 0 hvn
+    have haa₀ : placeOfPoint K a ≠ placeOfPoint K a₀ := by
+      intro h
+      rw [h] at hvp
+      omega
+    have hLa : algebraMap K[X] (RatFunc K) (X - C a) ≠ 0 :=
+      algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a)
+    have hLa₀ : algebraMap K[X] (RatFunc K) (X - C a₀) ≠ 0 :=
+      algebraMap_polynomial_ne_zero (X_sub_C_ne_zero a₀)
+    have hrne : algebraMap K[X] (RatFunc K) (X - C a) / algebraMap K[X] (RatFunc K) (X - C a₀)
+        ≠ 0 := div_ne_zero hLa hLa₀
+    have hord_r : ∀ v : Place K (RatFunc K),
+        v.ord (algebraMap K[X] (RatFunc K) (X - C a) / algebraMap K[X] (RatFunc K) (X - C a₀))
+          = (Finsupp.single (placeOfPoint K a) (1 : ℤ)
+              + Finsupp.single (placeOfPoint K a₀) (-1 : ℤ)) v := fun v => by
+      rw [← principalDivisor_apply hrne v, principalDivisor_X_sub_C_div a a₀]
+    set m : ℤ := (placeOfPoint K a).ord f with hm
+    have hrm_ne : (algebraMap K[X] (RatFunc K) (X - C a)
+        / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m ≠ 0 := zpow_ne_zero m hrne
+    have hf' : f / (algebraMap K[X] (RatFunc K) (X - C a)
+        / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m ≠ 0 := div_ne_zero hf hrm_ne
+    have hord_f' : ∀ v : Place K (RatFunc K),
+        v.ord (f / (algebraMap K[X] (RatFunc K) (X - C a)
+            / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m)
+          = v.ord f - m * (Finsupp.single (placeOfPoint K a) (1 : ℤ)
+              + Finsupp.single (placeOfPoint K a₀) (-1 : ℤ)) v := fun v => by
+      rw [ord_div_zpow v hf hrne m, hord_r v]
+    have hf'_inf : (placeInfty K).ord (f / (algebraMap K[X] (RatFunc K) (X - C a)
+        / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m) = 0 := by
+      rw [hord_f', hinf, Finsupp.add_apply,
+        Finsupp.single_eq_of_ne (Ne.symm (placeOfPoint_ne_placeInfty K a)),
+        Finsupp.single_eq_of_ne (Ne.symm (placeOfPoint_ne_placeInfty K a₀))]
+      ring
+    have hf'_b : (placeOfPoint K b).ord (f / (algebraMap K[X] (RatFunc K) (X - C a)
+        / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m) = 0 := by
+      rw [hord_f', hb, Finsupp.add_apply,
+        Finsupp.single_eq_of_ne
+          (show placeOfPoint K b ≠ placeOfPoint K a from
+            fun h => hab (placeOfPoint_injective K h).symm),
+        Finsupp.single_eq_of_ne
+          (show placeOfPoint K b ≠ placeOfPoint K a₀ from
+            fun h => ha₀b (placeOfPoint_injective K h).symm)]
+      ring
+    have hf'_a : (placeOfPoint K a).ord (f / (algebraMap K[X] (RatFunc K) (X - C a)
+        / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m) = 0 := by
+      rw [hord_f', Finsupp.add_apply, Finsupp.single_eq_same,
+        Finsupp.single_eq_of_ne haa₀, ← hm]
+      ring
+    have hsupp' : (principalDivisor hf').support
+        ⊆ (principalDivisor hf).support.erase (placeOfPoint K a) := by
+      intro v hv
+      have hvord := ord_ne_zero_of_mem_support hf' hv
+      rw [Finset.mem_erase]
+      constructor
+      · rintro rfl
+        exact hvord hf'_a
+      · rw [Finsupp.mem_support_iff, principalDivisor_apply]
+        intro hvf
+        apply hvord
+        rw [hord_f' v, hvf, Finsupp.add_apply]
+        rcases eq_or_ne v (placeOfPoint K a) with rfl | hva
+        · rw [hf'_a] at hvord
+          exact absurd rfl hvord
+        rcases eq_or_ne v (placeOfPoint K a₀) with rfl | hva₀
+        · rw [hvf] at hvn
+          exact absurd hvn (lt_irrefl 0)
+        · rw [Finsupp.single_eq_of_ne hva, Finsupp.single_eq_of_ne hva₀]
+          ring
+    have hcard' : (principalDivisor hf').support.card ≤ n := by
+      have h1 := Finset.card_le_card hsupp'
+      rw [Finset.card_erase_of_mem hvp_mem] at h1
+      omega
+    have hd_r_Lb : ∀ v : Place K (RatFunc K),
+        v.ord (algebraMap K[X] (RatFunc K) (X - C a)
+            / algebraMap K[X] (RatFunc K) (X - C a₀)) = 0
+          ∨ v.ord (algebraMap K[X] (RatFunc K) (X - C b)) = 0 := by
+      intro v
+      rcases eq_or_ne v (placeOfPoint K a) with rfl | hva
+      · exact Or.inr (ord_X_sub_C_placeOfPoint_of_ne hab)
+      rcases eq_or_ne v (placeOfPoint K a₀) with rfl | hva₀
+      · exact Or.inr (ord_X_sub_C_placeOfPoint_of_ne ha₀b)
+      · refine Or.inl ?_
+        rw [hord_r v, Finsupp.add_apply, Finsupp.single_eq_of_ne hva,
+          Finsupp.single_eq_of_ne hva₀]
+        ring
+    have hd_rm_Lb : ∀ v : Place K (RatFunc K),
+        v.ord ((algebraMap K[X] (RatFunc K) (X - C a)
+            / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m) = 0
+          ∨ v.ord (algebraMap K[X] (RatFunc K) (X - C b)) = 0 := fun v =>
+      (hd_r_Lb v).imp_left fun h => by rw [v.ord_zpow, h, mul_zero]
+    have hd_f'_Lb : ∀ v : Place K (RatFunc K),
+        v.ord (f / (algebraMap K[X] (RatFunc K) (X - C a)
+            / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m) = 0
+          ∨ v.ord (algebraMap K[X] (RatFunc K) (X - C b)) = 0 := by
+      intro v
+      rcases eq_or_ne v (placeOfPoint K b) with rfl | hvb
+      · exact Or.inl hf'_b
+      rcases eq_or_ne v (placeInfty K) with rfl | hvinf
+      · exact Or.inl hf'_inf
+      · exact Or.inr (ord_X_sub_C_eq_zero_of_ne b hvb hvinf)
+    have hcross_pow :
+        Divisor.evalFun ((algebraMap K[X] (RatFunc K) (X - C a)
+            / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m)
+          (principalDivisor hLb)
+        = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b))
+            (principalDivisor (zpow_ne_zero m hrne)) :=
+      reciprocity_zpow_left hrne hLb m hd_r_Lb
+        (crossRatio_reciprocity (fun h => hab h.symm) (fun h => ha₀b h.symm))
+    have hih :
+        Divisor.evalFun (f / (algebraMap K[X] (RatFunc K) (X - C a)
+            / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m)
+          (principalDivisor hLb)
+        = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b)) (principalDivisor hf') :=
+      ih _ hf' hf'_inf hf'_b hcard'
+    have hmul :
+        Divisor.evalFun ((algebraMap K[X] (RatFunc K) (X - C a)
+              / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m
+            * (f / (algebraMap K[X] (RatFunc K) (X - C a)
+              / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m))
+          (principalDivisor hLb)
+        = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b))
+            (principalDivisor (mul_ne_zero (zpow_ne_zero m hrne) hf')) :=
+      reciprocity_mul_left (zpow_ne_zero m hrne) hf' hLb hd_rm_Lb hd_f'_Lb hcross_pow hih
+    have hfeq : f = (algebraMap K[X] (RatFunc K) (X - C a)
+        / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m
+        * (f / (algebraMap K[X] (RatFunc K) (X - C a)
+          / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m) := by
+      rw [mul_comm, div_mul_cancel₀ _ hrm_ne]
+    calc Divisor.evalFun f (principalDivisor hLb)
+        = Divisor.evalFun ((algebraMap K[X] (RatFunc K) (X - C a)
+              / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m
+            * (f / (algebraMap K[X] (RatFunc K) (X - C a)
+              / algebraMap K[X] (RatFunc K) (X - C a₀)) ^ m))
+          (principalDivisor hLb) := by rw [← hfeq]
+      _ = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b))
+            (principalDivisor (mul_ne_zero (zpow_ne_zero m hrne) hf')) := hmul
+      _ = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b)) (principalDivisor hf) := by
+          rw [principalDivisor_congr (mul_ne_zero (zpow_ne_zero m hrne) hf') hf hfeq.symm]
+
+theorem reciprocity_of_ord_placeInfty_eq_zero :
+    ∀ (n : ℕ) (f g : RatFunc K) (hf : f ≠ 0) (hg : g ≠ 0),
+      (placeInfty K).ord f = 0 →
+      (∀ v : Place K (RatFunc K), v.ord f = 0 ∨ v.ord g = 0) →
+      ((principalDivisor hg).support.erase (placeInfty K)).card ≤ n →
+      Divisor.evalFun f (principalDivisor hg) = Divisor.evalFun g (principalDivisor hf) := by
+  have hbase : ∀ (f g : RatFunc K) (hf : f ≠ 0) (hg : g ≠ 0),
+      (principalDivisor hg).support.erase (placeInfty K) = ∅ →
+      Divisor.evalFun f (principalDivisor hg) = Divisor.evalFun g (principalDivisor hf) := by
+    intro f g hf hg hempty
+    refine reciprocity_of_forall_ord_eq_zero hf hg fun v => ?_
+    by_contra hv
+    have hvmem : v ∈ (principalDivisor hg).support := by
+      rw [Finsupp.mem_support_iff, principalDivisor_apply]
+      exact hv
+    have hsubset : (principalDivisor hg).support ⊆ {placeInfty K} := by
+      intro w hw
+      rw [Finset.mem_singleton]
+      by_contra hwne
+      exact absurd (hempty ▸ Finset.mem_erase.mpr ⟨hwne, hw⟩) (Finset.notMem_empty w)
+    have hsupp_eq : (principalDivisor hg).support = {placeInfty K} :=
+      Finset.Subset.antisymm hsubset
+        (Finset.singleton_subset_iff.mpr (Finset.mem_singleton.mp (hsubset hvmem) ▸ hvmem))
+    have hsum := sum_ord_eq_zero hg
+    rw [hsupp_eq, Finset.sum_singleton] at hsum
+    rw [Finset.mem_singleton.mp (hsubset hvmem)] at hv
+    exact hv hsum
+  intro n
+  induction n with
+  | zero =>
+    intro f g hf hg hinf hd hcard
+    exact hbase f g hf hg (Finset.card_eq_zero.mp (Nat.le_zero.mp hcard))
+  | succ n ih =>
+    intro f g hf hg hinf hd hcard
+    rcases Finset.eq_empty_or_nonempty
+      ((principalDivisor hg).support.erase (placeInfty K)) with hempty | hne
+    · exact hbase f g hf hg hempty
+    obtain ⟨vb, hvb⟩ := hne
+    rw [Finset.mem_erase] at hvb
+    obtain ⟨b, rfl⟩ : ∃ x : K, vb = placeOfPoint K x := by
+      rcases eq_placeOfPoint_or_eq_placeInfty K vb with h | h
+      · exact h
+      · exact absurd h hvb.1
+    have hordb : (placeOfPoint K b).ord g ≠ 0 := ord_ne_zero_of_mem_support hg hvb.2
+    have hfb : (placeOfPoint K b).ord f = 0 := (hd _).resolve_right hordb
+    have hLb : algebraMap K[X] (RatFunc K) (X - C b) ≠ 0 :=
+      algebraMap_polynomial_ne_zero (X_sub_C_ne_zero b)
+    set m : ℤ := (placeOfPoint K b).ord g with hm
+    have hLbm : (algebraMap K[X] (RatFunc K) (X - C b)) ^ m ≠ 0 := zpow_ne_zero m hLb
+    have hg' : g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m ≠ 0 := div_ne_zero hg hLbm
+    have hord_g' : ∀ v : Place K (RatFunc K),
+        v.ord (g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m)
+          = v.ord g - m * v.ord (algebraMap K[X] (RatFunc K) (X - C b)) := fun v =>
+      ord_div_zpow v hg hLb m
+    have hg'_b : (placeOfPoint K b).ord
+        (g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m) = 0 := by
+      rw [hord_g', ord_X_sub_C_placeOfPoint_self, ← hm]
+      ring
+    have hsupp' : (principalDivisor hg').support.erase (placeInfty K)
+        ⊆ ((principalDivisor hg).support.erase (placeInfty K)).erase (placeOfPoint K b) := by
+      intro v hv
+      rw [Finset.mem_erase] at hv
+      have hvord := ord_ne_zero_of_mem_support hg' hv.2
+      rw [Finset.mem_erase, Finset.mem_erase]
+      refine ⟨?_, hv.1, ?_⟩
+      · rintro rfl
+        exact hvord hg'_b
+      · rw [Finsupp.mem_support_iff, principalDivisor_apply]
+        intro hvg
+        apply hvord
+        rw [hord_g' v, hvg,
+          ord_X_sub_C_eq_zero_of_ne b (fun h => hvord (by rw [h]; exact hg'_b)) hv.1]
+        ring
+    have hcard' : ((principalDivisor hg').support.erase (placeInfty K)).card ≤ n := by
+      have h1 := Finset.card_le_card hsupp'
+      rw [Finset.card_erase_of_mem (Finset.mem_erase.mpr hvb)] at h1
+      omega
+    have hd_f_Lb : ∀ v : Place K (RatFunc K),
+        v.ord f = 0 ∨ v.ord (algebraMap K[X] (RatFunc K) (X - C b)) = 0 := by
+      intro v
+      rcases eq_or_ne v (placeOfPoint K b) with rfl | hvb'
+      · exact Or.inl hfb
+      rcases eq_or_ne v (placeInfty K) with rfl | hvinf
+      · exact Or.inl hinf
+      · exact Or.inr (ord_X_sub_C_eq_zero_of_ne b hvb' hvinf)
+    have hd_f_Lbm : ∀ v : Place K (RatFunc K),
+        v.ord f = 0 ∨ v.ord ((algebraMap K[X] (RatFunc K) (X - C b)) ^ m) = 0 := fun v =>
+      (hd_f_Lb v).imp_right fun h => by rw [v.ord_zpow, h, mul_zero]
+    have hd_f_g' : ∀ v : Place K (RatFunc K),
+        v.ord f = 0 ∨ v.ord (g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m) = 0 := by
+      intro v
+      by_cases hv : v.ord f = 0
+      · exact Or.inl hv
+      · refine Or.inr ?_
+        rw [hord_g' v, (hd v).resolve_left hv, (hd_f_Lb v).resolve_left hv, mul_zero,
+          sub_zero]
+    have hlin :
+        Divisor.evalFun f (principalDivisor hLb)
+          = Divisor.evalFun (algebraMap K[X] (RatFunc K) (X - C b)) (principalDivisor hf) :=
+      reciprocity_linear b (principalDivisor hf).support.card f hf hinf hfb le_rfl
+    have hlin_pow :
+        Divisor.evalFun f (principalDivisor hLbm)
+          = Divisor.evalFun ((algebraMap K[X] (RatFunc K) (X - C b)) ^ m)
+              (principalDivisor hf) :=
+      reciprocity_zpow_right hf hLb m hd_f_Lb hlin
+    have hih :
+        Divisor.evalFun f (principalDivisor hg')
+          = Divisor.evalFun (g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m)
+              (principalDivisor hf) :=
+      ih f _ hf hg' hinf hd_f_g' hcard'
+    have hmul :
+        Divisor.evalFun f (principalDivisor (mul_ne_zero hLbm hg'))
+          = Divisor.evalFun ((algebraMap K[X] (RatFunc K) (X - C b)) ^ m
+              * (g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m)) (principalDivisor hf) :=
+      reciprocity_mul_right hf hLbm hg' hd_f_Lbm hd_f_g' hlin_pow hih
+    have hgeq : g = (algebraMap K[X] (RatFunc K) (X - C b)) ^ m
+        * (g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m) := by
+      rw [mul_comm, div_mul_cancel₀ _ hLbm]
+    calc Divisor.evalFun f (principalDivisor hg)
+        = Divisor.evalFun f (principalDivisor (mul_ne_zero hLbm hg')) := by
+          rw [principalDivisor_congr hg (mul_ne_zero hLbm hg') hgeq]
+      _ = Divisor.evalFun ((algebraMap K[X] (RatFunc K) (X - C b)) ^ m
+            * (g / (algebraMap K[X] (RatFunc K) (X - C b)) ^ m)) (principalDivisor hf) := hmul
+      _ = Divisor.evalFun g (principalDivisor hf) := by rw [← hgeq]
+
+end Reciprocity
+end RationalFunctionField
+end AlgebraicCurve
+end
+
+open Polynomial _root_.AlgebraicCurve
+  _root_.P2MW.S_OVERLONG_3fd9514a.AlgebraicCurve
+  _root_.AlgebraicCurve.RationalFunctionField
+  _root_.P2MW.S_OVERLONG_3fd9514a.AlgebraicCurve.RationalFunctionField
+  in
+theorem solution {K : Type*} [Field K] (a : K) {q : Polynomial K} (hq : q ≠ 0) :
+    (placeOfPoint K a).ord (algebraMap (Polynomial K) (RatFunc K) q) = Polynomial.rootMultiplicity a
+      q :=
+  AlgebraicCurve.RationalFunctionField.ord_placeOfPoint_algebraMap a hq
+
+end S_OVERLONG_3fd9514a
+end P2MW
+export P2MW.S_OVERLONG_3fd9514a (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve AlgebraicCurve.RationalFunctionField
+theorem AlgebraicCurve.RationalFunctionField.ord_placeOfPoint_algebraMap {K : Type*} [Field K]
+    (a : K) {q : Polynomial K} (hq : q ≠ 0) :
+    (placeOfPoint K a).ord (algebraMap (Polynomial K) (RatFunc K) q) = Polynomial.rootMultiplicity a
+      q :=
+  solution a hq
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_stichtenothGenusExists.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_stichtenothGenusExists.lean
new file mode 100644
index 0000000000..fb83b87e2f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_stichtenothGenusExists.lean
@@ -0,0 +1,2688 @@
+/-
+Based on Prove2Me node AlgebraicCurve.RationalFunctionField.stichtenothGenusExists
+(e80183c7-3748-5ae2-ad67-16395a9668d5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d9666c17-1034-5a92-b3f4-9708849abba1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import Mathlib.Algebra.Polynomial.Basis
+import Mathlib.Data.Int.LeastGreatest
+import Mathlib.LinearAlgebra.Matrix.FiniteDimensional
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PoleDivisorPackage
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_restrict_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_placeInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of the genus for separable extensions of K(X)
+
+Theorem statement: `AlgebraicCurve.RationalFunctionField.stichtenothGenusExists`
+(`e80183c7-3748-5ae2-ad67-16395a9668d5`), by Claude, 2026-09-05.
+
+Proof: submission `d9666c17-1034-5a92-b3f4-9708849abba1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $F$ be a field that is simultaneously a $K$-algebra and a
+$\mathrm{RatFunc}\,K$-algebra, compatibly (scalar tower $K \subseteq K(X) \subseteq F$), with $F$
+finite-dimensional and separable over the rational function field $\mathrm{RatFunc}\,K$. Assume
+`IsCurveOver K F`: principal divisors exist (every $f \in F^{\times}$ admits a finitely supported $D
+: \mathrm{Place}\,K\,F \to \mathbb{Z}$ with $D(v) = v.\mathrm{ord}\,f$ at every place and $\deg D =
+0$), every place has residue field finite over $K$, and $\Omega_{F/K}$ is free of rank $1$ over $F$;
+here a place is a valuation subring of $F$ containing the image of $K$, distinct from $F$ itself,
+and a principal ideal ring. Assume further `ConstantsAreBase K F`, i.e. the Riemann–Roch space
+$L(0)$ of the zero divisor equals the image of $K$ in $F$ under the structure map. The conclusion is
+`StichtenothGenusExists K F`: the set of places of $F$ over $K$ is nonempty; $L(0)$ is
+finite-dimensional over $K$; and there exist $\gamma \in \mathbb{Z}$ and a divisor $D_0$ such that
+$L(D_0)$ is finite-dimensional over $K$, $\deg D_0 - \ell(D_0) = \gamma - 1$ with $\ell$ the
+$K$-dimension of the Riemann–Roch space, and $\deg D - \ell(D) \le \gamma - 1$ for every divisor
+$D$.
+
+This is the existence of the genus in Stichtenoth's form: the quantity $\deg D - \ell(D)$ is bounded
+above over all divisors and the bound is attained, which is equivalent to Riemann's inequality
+$\ell(D) \ge \deg D + 1 - \gamma$ together with equality at some $D_0$. It is the input, for
+function fields presented as finite separable extensions of $K(X)$, to the adelic Riemann–Roch
+theorem and the rank-one statement for Weil differentials, and is cited by
+[`AlgebraicCurve.exists_genus_riemannIndex_of_isCurveOver`]
+(thm.html#AlgebraicCurve.exists_genus_riemannIndex_of_isCurveOver),
+[`AlgebraicCurve.stichtenothGenusExists_of_isCurveOver`]
+(thm.html#AlgebraicCurve.stichtenothGenusExists_of_isCurveOver)
+and
+[`AlgebraicCurve.weilDifferentialRankOne_of_isCurveOver`]
+(thm.html#AlgebraicCurve.weilDifferentialRankOne_of_isCurveOver).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_stichtenothGenusExists.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_RationalFunctionField_stichtenothGenusExists
+
+
+open Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "degree degree_single principal smul_def smul_apply pullback \
+  pullback_apply degree_pullback"
+end Divisor
+variable {D : Divisor K F}
+p2m_open_scoped "AlgebraicCurve.Divisor" in
+theorem Divisor.degree_nonneg_of_nonneg [IsCurveOver K F]
+    {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) : 0 ≤ Divisor.degree D := by
+  rw [Divisor.degree_eq_sum_support]
+  exact Finset.sum_nonneg fun v _ => mul_nonneg (hD v) (Int.natCast_nonneg _)
+theorem lSpace_eq_bot_of_degree_neg [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) : LSpace D = ⊥ := by
+  rw [eq_bot_iff]
+  intro f hf
+  rw [Submodule.mem_bot]
+  by_contra hf0
+  obtain ⟨P, hPord, hPdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+  have heff : ∀ v : Place K F, 0 ≤ (P + D) v := by
+    intro v
+    rw [Finsupp.add_apply, hPord]
+    rcases mem_lSpace_iff_ord.mp hf with rfl | h
+    · exact absurd rfl hf0
+    · linarith [h v]
+  have hdegPD : 0 ≤ Divisor.degree (P + D) := Divisor.degree_nonneg_of_nonneg heff
+  rw [map_add, hPdeg, zero_add] at hdegPD
+  exact absurd hdegPD (not_le.mpr hD)
+end AlgebraicCurve
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~restrict_plac\
+  eOfPrime~placeOfPrime~comap_algebraMap_ne_top"
+
+variable (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mk_mem_maximalIdeal_iff {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    (⟨f, hf⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring
+      ↔ f = 0 ∨ 0 < v.ord f := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  constructor
+  · intro hu
+    rcases eq_or_ne f 0 with rfl | hf0
+    · exact Or.inl rfl
+    · refine Or.inr ?_
+      rcases lt_or_eq_of_le (AlgebraicCurve.Place.ord_nonneg_of_mem v hf) with h | h
+      · exact h
+      · exfalso
+        apply hu
+        rw [← v.adicValuation_coe_eq_one_iff ⟨f, hf⟩]
+        change v.adicValuation f = 1
+        rw [v.adicValuation_eq_exp_neg_ord hf0, ← h, neg_zero, WithZero.exp_zero]
+  · intro h hu
+    have hne : f ≠ 0 := fun h0 => hu.ne_zero (Subtype.ext h0)
+    have h0 : v.ord f = 0 := by
+      obtain ⟨u, hu'⟩ := hu
+      have hcoe : f = ((u : v.toValuationSubring) : F) := by rw [hu']
+      rw [hcoe]; exact v.ord_coe_unit u
+    rcases h with rfl | hpos
+    · exact hne rfl
+    · omega
+
+p2m_export "AlgebraicCurve.Place" "mk_mem_maximalIdeal_iff"
+end Place
+
+theorem ell_le_ell_sub_single_add_deg [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    ell D ≤ ell (D - Finsupp.single P 1) + P.deg := by
+  classical
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible P.toValuationSubring
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by
+    simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := by
+    intro g hg
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ g : F, g ∈ LSpace D → t ^ (D P) * g ∈ P.toValuationSubring := by
+    intro g hg
+    rcases eq_or_ne g 0 with rfl | hg0
+    · simp
+    · refine AlgebraicCurve.Place.mem_of_ord_nonneg P (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have := (mem_lSpace_iff_ord.mp hg).resolve_left hg0 P
+      linarith
+  let ψ : LSpace D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun f => ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+      map_add' := by intro f g; apply Subtype.ext; push_cast; ring
+      map_smul' := by
+        intro c f; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap]
+        ring }
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : LSpace D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ f : LSpace D, φ f = 0 ↔
+      (⟨t ^ (D P) * (f : F), hmem _ f.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := by
+    intro f
+    rw [show φ f = IsLocalRing.residue P.toValuationSubring ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+          from hres (ψ f),
+      IsLocalRing.residue_eq_zero_iff]
+  have hED : E ≤ D := by
+    rw [Finsupp.le_def]; intro v; rw [hE, Finsupp.sub_apply]
+    have : (0 : ℤ) ≤ Finsupp.single P 1 v := by
+      rcases eq_or_ne v P with rfl | hv
+      · simp
+      · simp [Finsupp.single_eq_of_ne hv]
+    linarith
+  have hsub : LSpace E ≤ LSpace D := lSpace_mono hED
+  have hker : LinearMap.ker φ = (LSpace E).comap (LSpace D).subtype := by
+    ext f
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi f, P.mk_mem_maximalIdeal_iff]
+    rcases eq_or_ne (f : F) 0 with hf0 | hf0
+    · simp only [hf0, mul_zero, true_or, true_iff]
+      exact (LSpace E).zero_mem
+    · rw [mem_lSpace_iff_ord]
+      have hfD := (mem_lSpace_iff_ord.mp f.2).resolve_left hf0
+      constructor
+      · rintro (h | h)
+        · exact absurd h (mul_ne_zero htn0 hf0)
+        · refine Or.inr (fun v => ?_)
+          rcases eq_or_ne v P with rfl | hv
+          · rw [hEP]; rw [hordmul hf0] at h; omega
+          · rw [hEv v hv]; exact hfD v
+      · rintro (h | h)
+        · exact absurd h hf0
+        · refine Or.inr ?_
+          have hP := h P
+          rw [hEP] at hP
+          rw [hordmul hf0]; omega
+  have hkerfin : finrank K (LinearMap.ker φ) = ell E := by
+    rw [hker, LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe hsub)]
+  have hquot : finrank K (LSpace D ⧸ LinearMap.ker φ) ≤ P.deg := by
+    rw [LinearEquiv.finrank_eq φ.quotKerEquivRange]
+    exact Submodule.finrank_le (LinearMap.range φ)
+  by_cases hfin : FiniteDimensional K (LSpace D)
+  · have := hfin
+    have hrn := Submodule.finrank_quotient_add_finrank (LinearMap.ker φ)
+    rw [hkerfin] at hrn
+    have hb : ell D = finrank K (LSpace D) := rfl
+    omega
+  · have h0 : ell D = 0 := by rw [ell]; exact finrank_of_infinite_dimensional hfin
+    omega
+
+theorem one_le_deg [IsCurveOver K F] (P : Place K F) : 1 ≤ P.deg := by
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  exact Module.finrank_pos
+
+theorem ell_le_degree_add_ellZero [IsCurveOver K F] {D : Divisor K F}
+    (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D : Divisor K F, (∀ v, 0 ≤ D v) →
+      (Divisor.degree D).toNat = m →
+      (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) by
+    exact H (Divisor.degree D).toNat D hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D hD hm
+    by_cases hD0 : D = 0
+    · subst hD0; simp
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ D P := by
+        have hne : D P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hD P; omega
+      set E : Divisor K F := D - Finsupp.single P 1 with hE
+      have hEeff : ∀ v, 0 ≤ E v := by
+        intro v; rw [hE, Finsupp.sub_apply]
+        rcases eq_or_ne v P with rfl | hv
+        · rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have hdegE : Divisor.degree E = Divisor.degree D - P.deg := by
+        rw [hE, map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hDnn : 0 ≤ Divisor.degree D := Divisor.degree_nonneg_of_nonneg hD
+      have hEnn : 0 ≤ Divisor.degree E := Divisor.degree_nonneg_of_nonneg hEeff
+      have hmlt : (Divisor.degree E).toNat < m := by rw [← hm]; omega
+      have hIH := IH _ hmlt E hEeff rfl
+      have hstep := ell_le_ell_sub_single_add_deg D P
+      rw [← hE] at hstep
+      have hstep' : (ell D : ℤ) ≤ (ell E : ℤ) + P.deg := by exact_mod_cast hstep
+      rw [hdegE] at hIH
+      linarith
+
+theorem ell_le_degree_add_one_of_effective [IsCurveOver K F]
+    (hC : ConstantsAreBase K F) {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  have h := ell_le_degree_add_ellZero hD
+  rw [ell_zero_eq_one_of_constantsAreBase hC] at h
+  exact_mod_cast h
+
+def lSpaceShiftEquiv (D : Divisor K F) {g : F} (hg : g ≠ 0)
+    {Dg : Divisor K F} (hDg : ∀ v, Dg v = v.ord g) :
+    LSpace D ≃ₗ[K] LSpace (D + Dg) where
+  toFun h := ⟨(h : F) * g⁻¹, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (h : F) 0 with hh0 | hh0
+    · left; rw [hh0, zero_mul]
+    · right; intro v
+      rw [Finsupp.add_apply, hDg, v.ord_mul hh0 (inv_ne_zero hg), v.ord_inv]
+      have := (mem_lSpace_iff_ord.mp h.2).resolve_left hh0 v
+      linarith⟩
+  invFun k := ⟨(k : F) * g, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (k : F) 0 with hk0 | hk0
+    · left; rw [hk0, zero_mul]
+    · right; intro v
+      have := (mem_lSpace_iff_ord.mp k.2).resolve_left hk0 v
+      rw [Finsupp.add_apply, hDg] at this
+      rw [v.ord_mul hk0 hg]
+      linarith⟩
+  map_add' h₁ h₂ := by apply Subtype.ext; push_cast; ring
+  map_smul' c h := by
+    apply Subtype.ext
+    simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def]
+    ring
+  left_inv h := by
+    apply Subtype.ext
+    change (h : F) * g⁻¹ * g = (h : F)
+    rw [mul_assoc, inv_mul_cancel₀ hg, mul_one]
+  right_inv k := by
+    apply Subtype.ext
+    change (k : F) * g * g⁻¹ = (k : F)
+    rw [mul_assoc, mul_inv_cancel₀ hg, mul_one]
+
+theorem ell_le_degree_add_one [IsCurveOver K F] (hC : ConstantsAreBase K F)
+    {D : Divisor K F} (hD : 0 ≤ Divisor.degree D) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  rcases eq_or_ne (ell D) 0 with h0 | h0
+  · rw [h0]; push_cast; linarith
+  · have hbot : LSpace D ≠ ⊥ := fun h => h0 (by rw [ell, h, finrank_bot])
+    obtain ⟨g, hgL, hg0⟩ := (Submodule.ne_bot_iff _).mp hbot
+    obtain ⟨Dg, hDgord, hDgdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) g hg0
+    have heff : ∀ v, 0 ≤ (D + Dg) v := by
+      intro v; rw [Finsupp.add_apply, hDgord]
+      have := (mem_lSpace_iff_ord.mp hgL).resolve_left hg0 v
+      linarith
+    have hdeg : Divisor.degree (D + Dg) = Divisor.degree D := by
+      rw [map_add, hDgdeg, add_zero]
+    have hell : ell D = ell (D + Dg) :=
+      LinearEquiv.finrank_eq (lSpaceShiftEquiv D hg0 hDgord)
+    have hfin := ell_le_degree_add_one_of_effective hC heff
+    rw [hdeg] at hfin
+    rw [hell]; exact hfin
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion factor mk mem_bot subtype_injective \
+  mk.injEq Quotient.subsingleton_iff Quotient.mk span restrictScalars inhabited \
+  inclusion_injective comapSubtypeEquivOfLe mem_comap finrank_quotient_add_finrank mem_top \
+  Quotient.equiv mkQ mem_map coe_subtype map_smul' zero one quotientQuotientEquivQuotient \
+  coe_eq_zero finrank_le range_subtype Quotient.mk_surjective map mem_inf mem_sup \
+  Quotient.mk_eq_zero topEquiv map_injective_of_injective comap_subtype_self mapQ subsingleton_iff \
+  module smul_def mk_eq_zero coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono \
+  map_sup coe_zero smul"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+def nestedComapMapMkQEquiv {A B C : Submodule K X} (_hAB : A ≤ B) (hBC : B ≤ C) :
+    ((B.comap C.subtype).map (A.comap C.subtype).mkQ : Submodule K _)
+      ≃ₗ[K] B ⧸ A.comap B.subtype := by
+  set S := A.comap C.subtype with hS
+  set T := B.comap C.subtype with hT
+  let ψ : (T : Type _) →ₗ[K] (C ⧸ S) := S.mkQ ∘ₗ T.subtype
+  have hker : LinearMap.ker ψ = S.comap T.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = T.map S.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let e1 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (T.map S.mkQ : Submodule K _) :=
+    (Submodule.Quotient.equiv _ (LinearMap.ker ψ) (LinearEquiv.refl K T)
+        (by rw [hker]; simp)).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have hmap : (S.comap T.subtype).map
+      (Submodule.comapSubtypeEquivOfLe hBC : (T : Type _) →ₗ[K] B) = A.comap B.subtype := by
+    ext ⟨b, hb⟩
+    simp only [mem_map, mem_comap, Submodule.coe_subtype, hS]
+    constructor
+    · rintro ⟨⟨⟨x, hxC⟩, hxB⟩, hxA, hxeq⟩
+      have hx : x = b := congrArg Subtype.val hxeq
+      subst hx; exact hxA
+    · intro hbA
+      exact ⟨⟨⟨b, hBC hb⟩, hb⟩, hbA, rfl⟩
+  let e2 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (B ⧸ A.comap B.subtype) :=
+    Submodule.Quotient.equiv _ _ (Submodule.comapSubtypeEquivOfLe hBC) hmap
+  exact e1.symm.trans e2
+
+theorem finrank_quotient_chain {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCB : Module.Finite K (C ⧸ B.comap C.subtype)]
+    [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (C ⧸ A.comap C.subtype) ∧
+      finrank K (C ⧸ A.comap C.subtype)
+        = finrank K (C ⧸ B.comap C.subtype) + finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (T.map S.mkQ : Submodule K _) := Module.Finite.equiv eK.symm
+  have : Module.Finite K ((C ⧸ S) ⧸ T.map S.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (C ⧸ S) := Module.Finite.of_submodule_quotient (T.map S.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+theorem finrank_quotient_chain' {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCA : Module.Finite K (C ⧸ A.comap C.subtype)] :
+    Module.Finite K (C ⧸ B.comap C.subtype) ∧
+      finrank K (C ⧸ B.comap C.subtype)
+        = finrank K (C ⧸ A.comap C.subtype) - finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (C ⧸ T) := Module.Finite.equiv e3
+  refine ⟨this, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+def adeleBddQuotSingleEquivResidueField (D : Divisor K F) (P : Place K F) :
+    (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+      ≃ₗ[K] P.ResidueField := by
+  classical
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  let π : P.toValuationSubring :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose
+  have hπ : Irreducible π :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose_spec
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := fun {g} hg => by
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ α : Place K F → F, α ∈ adeleBdd D → t ^ (D P) * α P ∈ P.toValuationSubring := by
+    intro α hα
+    rcases eq_or_ne (α P) 0 with hg0 | hg0
+    · simp [hg0]
+    · refine AlgebraicCurve.Place.mem_of_ord_nonneg P (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have h := hα P
+      rw [P.adicValuation_eq_exp_neg_ord hg0, WithZero.exp_le_exp] at h
+      linarith
+  let ψ : adeleBdd D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun α => ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩
+      map_add' := by
+        intro α β; apply Subtype.ext
+        simp only [Submodule.coe_add, Pi.add_apply]
+        push_cast; ring
+      map_smul' := by
+        intro c α; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap, Pi.smul_apply]
+        ring }
+  have hψ_apply : ∀ α : adeleBdd D,
+      (ψ α : F) = t ^ (D P) * (α : Place K F → F) P := fun α => rfl
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : adeleBdd D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ α : adeleBdd D, φ α = 0 ↔
+      (⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := fun α => by
+    rw [show φ α = IsLocalRing.residue P.toValuationSubring
+            ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ from hres (ψ α),
+      IsLocalRing.residue_eq_zero_iff]
+  have hker : LinearMap.ker φ = (adeleBdd E).comap (adeleBdd D).subtype := by
+    ext α
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi α, P.mk_mem_maximalIdeal_iff, mem_adeleBdd]
+    have hαD := α.2
+    constructor
+    · rintro (h | h) v
+      · have hα0 : (α : Place K F → F) P = 0 := by
+          rcases mul_eq_zero.mp h with h' | h'
+          · exact absurd h' htn0
+          · exact h'
+        by_cases hv : v = P
+        · subst v; rw [hα0, Valuation.map_zero]; exact zero_le
+        · rw [hEv v hv]; exact hαD v
+      · by_cases hv : v = P
+        · subst v
+          rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+          · rw [hα0, Valuation.map_zero]; exact zero_le
+          · rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP]
+            rw [hordmul hα0] at h; omega
+        · rw [hEv v hv]; exact hαD v
+    · intro h
+      rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+      · left; rw [hα0, mul_zero]
+      · right
+        have hP := h P
+        rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP] at hP
+        rw [hordmul hα0]; omega
+  have hsurj : Function.Surjective φ := by
+    intro c
+    obtain ⟨cl, hcl⟩ := IsLocalRing.residue_surjective (R := P.toValuationSubring) c
+    set f : F := (cl : F) * t ^ (-(D P)) with hf
+    have hαD : Pi.single P f ∈ adeleBdd D := by
+      intro v
+      by_cases hv : v = P
+      · subst v
+        simp only [Pi.single_eq_same]
+        rcases eq_or_ne (cl : F) 0 with hc0 | hc0
+        · rw [hf, hc0, zero_mul, Valuation.map_zero]; exact zero_le
+        · have hf0 : f ≠ 0 := by rw [hf]; exact mul_ne_zero hc0 (zpow_ne_zero _ ht0)
+          rw [P.adicValuation_eq_exp_neg_ord hf0, WithZero.exp_le_exp]
+          rw [hf, P.ord_mul hc0 (zpow_ne_zero _ ht0), P.ord_zpow, ht1, mul_one]
+          have hclnn := AlgebraicCurve.Place.ord_nonneg_of_mem P cl.2
+          linarith
+      · rw [Pi.single_eq_of_ne hv, Valuation.map_zero]; exact zero_le
+    refine ⟨⟨Pi.single P f, hαD⟩, ?_⟩
+    change res (ψ ⟨Pi.single P f, hαD⟩) = c
+    rw [hres]
+    rw [show (ψ ⟨Pi.single P f, hαD⟩ : P.toValuationSubring) = cl from ?_, hcl]
+    apply Subtype.ext
+    rw [hψ_apply]
+    change t ^ (D P) * (Pi.single P f : Place K F → F) P = (cl : F)
+    rw [show (Pi.single P f : Place K F → F) P = f from Pi.single_eq_same _ _, hf,
+      mul_comm (cl : F), ← mul_assoc, ← zpow_add₀ ht0, add_neg_cancel, zpow_zero, one_mul]
+  exact (Submodule.Quotient.equiv _ _ (LinearEquiv.refl K _) (by rw [← hker]; simp)).trans
+    (φ.quotKerEquivOfSurjective hsurj)
+
+theorem finrank_adeleBdd_quotient_single [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    Module.Finite K
+        (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype) ∧
+      finrank K
+          (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+        = P.deg := by
+  have := IsCurveOver.finite_residueField (K := K) P
+  exact ⟨Module.Finite.equiv (adeleBddQuotSingleEquivResidueField D P).symm,
+    (adeleBddQuotSingleEquivResidueField D P).finrank_eq⟩
+
+theorem finrank_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+      (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+        = Divisor.degree D₂ - Divisor.degree D₁ := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D₁ D₂ : Divisor K F, D₁ ≤ D₂ →
+      (Divisor.degree (D₂ - D₁)).toNat = m →
+      Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+        (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+          = Divisor.degree D₂ - Divisor.degree D₁ from
+    H _ D₁ D₂ hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D₁ D₂ hD hm
+    have hEeff : ∀ v, 0 ≤ (D₂ - D₁) v := fun v => by
+      rw [Finsupp.sub_apply]; have := hD v; omega
+    by_cases hD0 : D₂ - D₁ = 0
+    · have hD12 : D₁ = D₂ := (sub_eq_zero.mp hD0).symm
+      subst hD12
+      rw [Submodule.comap_subtype_self]
+      have : Subsingleton (adeleBdd D₁ ⧸ (⊤ : Submodule K (adeleBdd D₁))) :=
+        Submodule.Quotient.subsingleton_iff.mpr rfl
+      exact ⟨Module.Finite.of_finite, by simp [Module.finrank_zero_of_subsingleton]⟩
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ (D₂ - D₁) P := by
+        have hne : (D₂ - D₁) P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hEeff P; omega
+      set D₂' : Divisor K F := D₂ - Finsupp.single P 1 with hD₂'
+      have h12' : D₁ ≤ D₂' := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]
+          have := hPpos; rw [Finsupp.sub_apply] at this; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have h2'2 : D₂' ≤ D₂ := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]
+      have hdegD₂' : Divisor.degree D₂' = Divisor.degree D₂ - P.deg := by
+        rw [hD₂', map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hEnn : 0 ≤ Divisor.degree (D₂ - D₁) := Divisor.degree_nonneg_of_nonneg hEeff
+      have hE'nn : 0 ≤ Divisor.degree (D₂' - D₁) := Divisor.degree_nonneg_of_nonneg
+        (fun v => by rw [Finsupp.sub_apply]; have := h12' v; omega)
+      have hdegdiff : Divisor.degree (D₂' - D₁) = Divisor.degree (D₂ - D₁) - P.deg := by
+        simp only [hD₂', map_sub, Divisor.degree_single, one_mul]; ring
+      have hmlt : (Divisor.degree (D₂' - D₁)).toNat < m := by rw [← hm]; omega
+      obtain ⟨hfin', hrank'⟩ := IH _ hmlt D₁ D₂' h12' rfl
+      obtain ⟨hfinS, hrankS⟩ := finrank_adeleBdd_quotient_single (K := K) D₂ P
+      rw [← hD₂'] at hfinS hrankS
+      have := hfin'; have := hfinS
+      obtain ⟨hfin, hrank⟩ := Submodule.finrank_quotient_chain
+        (A := adeleBdd D₁) (B := adeleBdd D₂') (C := adeleBdd D₂)
+        (adeleBdd_mono h12') (adeleBdd_mono h2'2)
+      refine ⟨hfin, ?_⟩
+      rw [hrank, hrankS]
+      push_cast
+      linarith [hrank', hdegD₂']
+
+theorem module_finite_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  (finrank_adeleBdd_quotient hD).1
+
+theorem finrank_adeleBdd_quotient_eq [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+      = Divisor.degree D₂ - Divisor.degree D₁ :=
+  (finrank_adeleBdd_quotient hD).2
+
+def lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (_hD : D₁ ≤ D₂) :
+    (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      →ₗ[K] (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  Submodule.mapQ _ _
+    ((diagonalHom K F).restrict
+      (p := (LSpace D₂ : Submodule K F)) (q := (adeleBdd D₂ : Submodule K _))
+      (fun f hf => diagonal_mem_adeleBdd_iff.mpr hf))
+    (fun f hf => by
+      simp only [Submodule.mem_comap, Submodule.coe_subtype] at hf ⊢
+      exact diagonal_mem_adeleBdd_iff.mpr hf)
+
+theorem lSpaceQuotientToAdeleBddQuotient_injective {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Function.Injective (lSpaceQuotientToAdeleBddQuotient hD) := by
+  rw [injective_iff_map_eq_zero]
+  intro x hx
+  obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+  rw [Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype]
+  rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk f)
+        = Submodule.Quotient.mk ((diagonalHom K F).restrict
+            (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f) from rfl,
+    Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype] at hx
+  exact diagonal_mem_adeleBdd_iff.mp hx
+
+
+theorem ell_sub_ell_le_degree_sub_degree [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)] :
+    (ell D₂ : ℤ) - (ell D₁ : ℤ) ≤ Divisor.degree D₂ - Divisor.degree D₁ := by
+  have := module_finite_adeleBdd_quotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    rw [hℓ₁]; exact (Submodule.finrank_quotient_add_finrank _).symm
+  have hemb : finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      ≤ finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+    LinearMap.finrank_le_finrank_of_injective (lSpaceQuotientToAdeleBddQuotient_injective hD)
+  have hloc := finrank_adeleBdd_quotient_eq hD
+  have : (ell D₂ : ℤ) - (ell D₁ : ℤ)
+      = (finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) : ℤ) := by
+    rw [hL]; push_cast; ring
+  rw [this, ← hloc]
+  exact_mod_cast hemb
+
+theorem adeleBdd_inf_sup_globalSub {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F)
+      = adeleBdd D₁ ⊔ adeleBdd D₂ ⊓ globalSub K F := by
+  rw [inf_comm, sup_inf_assoc_of_le _ (adeleBdd_mono hD), inf_comm]
+
+theorem map_diagonal_lSpace_inf_adeleBdd {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (LSpace D₂).map (diagonalHom K F) ⊓ adeleBdd D₁ = (LSpace D₁).map (diagonalHom K F) := by
+  rw [map_diagonal_lSpace, map_diagonal_lSpace, inf_right_comm,
+    inf_eq_right.mpr (adeleBdd_mono hD)]
+
+theorem gate_finrank_adeleBdd_quotient_single_point [IsCurveOver K F] (P : Place K F) :
+    (finrank K (adeleBdd (Finsupp.single P 1 : Divisor K F)
+        ⧸ (adeleBdd (0 : Divisor K F)).comap (adeleBdd (Finsupp.single P 1)).subtype) : ℤ)
+      = (P.deg : ℤ) := by
+  classical
+  have h01 : (0 : Divisor K F) ≤ Finsupp.single P 1 := by
+    intro v; rw [Finsupp.zero_apply, Finsupp.single_apply]; split_ifs <;> omega
+  have h := finrank_adeleBdd_quotient_eq (K := K) h01
+  rw [h, map_zero, sub_zero, Divisor.degree_single, one_mul]
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion factor mk mem_bot subtype_injective \
+  mk.injEq Quotient.subsingleton_iff Quotient.mk span restrictScalars inhabited \
+  inclusion_injective comapSubtypeEquivOfLe mem_comap finrank_quotient_add_finrank mem_top \
+  Quotient.equiv mkQ mem_map coe_subtype map_smul' zero one quotientQuotientEquivQuotient \
+  coe_eq_zero finrank_le range_subtype Quotient.mk_surjective map mem_inf mem_sup \
+  Quotient.mk_eq_zero topEquiv map_injective_of_injective comap_subtype_self mapQ subsingleton_iff \
+  module smul_def mk_eq_zero coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono \
+  map_sup coe_zero smul"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+theorem comap_subtype_sup_of_le_of_le {S T C : Submodule K X} (hS : S ≤ C) (hT : T ≤ C) :
+    S.comap C.subtype ⊔ T.comap C.subtype = (S ⊔ T).comap C.subtype := by
+  apply Submodule.map_injective_of_injective (f := C.subtype) C.subtype_injective
+  rw [Submodule.map_sup, Submodule.map_comap_subtype, Submodule.map_comap_subtype,
+    Submodule.map_comap_subtype, inf_eq_right.mpr hS, inf_eq_right.mpr hT,
+    inf_eq_right.mpr (sup_le hS hT)]
+
+theorem finrank_quotient_chain_top {M : Type*} [AddCommGroup M] [Module K M]
+    {A B : Submodule K M} (hAB : A ≤ B)
+    [hMB : Module.Finite K (M ⧸ B)] [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (M ⧸ A) ∧
+      finrank K (M ⧸ A) = finrank K (M ⧸ B) + finrank K (B ⧸ A.comap B.subtype) := by
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  let ψ : (B : Type _) →ₗ[K] (M ⧸ A) := A.mkQ ∘ₗ B.subtype
+  have hker : LinearMap.ker ψ = A.comap B.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = B.map A.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let eK : (B ⧸ A.comap B.subtype) ≃ₗ[K] (B.map A.mkQ : Submodule K (M ⧸ A)) :=
+    (Submodule.quotEquivOfEq _ _ hker.symm).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have : Module.Finite K (B.map A.mkQ : Submodule K (M ⧸ A)) := Module.Finite.equiv eK
+  have : Module.Finite K ((M ⧸ A) ⧸ B.map A.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (M ⧸ A) := Module.Finite.of_submodule_quotient (B.map A.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (B.map A.mkQ)
+  rw [LinearEquiv.finrank_eq e3, ← LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem globalSub_le_adeleSpace [HasPrincipalDivisors K F] :
+    globalSub K F ≤ adeleSpace K F := by
+  rintro _ ⟨f, rfl⟩
+  exact diagonal_mem_adeleSpace f
+
+theorem adeleBdd_sup_globalSub_le_adeleSpace [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+  sup_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_eq_comap [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBddPrincipal K F D = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype :=
+  Submodule.comap_subtype_sup_of_le_of_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_mono {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBddPrincipal K F D₁ ≤ adeleBddPrincipal K F D₂ :=
+  sup_le_sup_right (Submodule.comap_mono (adeleBdd_mono hD)) _
+
+section FiniteLSpace
+
+variable [IsCurveOver K F]
+
+theorem finiteDimensional_lSpace [hL0 : FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (D : Divisor K F) : FiniteDimensional K (LSpace D) := by
+  have h0D : (0 : Divisor K F) ≤ D ⊔ 0 := le_sup_right
+  have hDD : D ≤ D ⊔ 0 := le_sup_left
+  suffices h : FiniteDimensional K (LSpace (D ⊔ 0)) by
+    exact Module.Finite.of_injective (Submodule.inclusion (lSpace_mono hDD))
+      (Submodule.inclusion_injective _)
+  have := module_finite_adeleBdd_quotient (K := K) h0D
+  have hfinQ : FiniteDimensional K
+      (LSpace (D ⊔ 0) ⧸ (LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype) :=
+    Module.Finite.of_injective _ (lSpaceQuotientToAdeleBddQuotient_injective h0D)
+  have : FiniteDimensional K
+      ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype : Submodule K _) :=
+    Module.Finite.equiv (Submodule.comapSubtypeEquivOfLe (lSpace_mono h0D)).symm
+  exact Module.Finite.of_submodule_quotient
+    ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype)
+
+end FiniteLSpace
+
+
+theorem range_lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD)
+      = ((adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype).map
+          ((adeleBdd D₁).comap (adeleBdd D₂).subtype).mkQ := by
+  classical
+  ext z
+  obtain ⟨α, rfl⟩ := Submodule.Quotient.mk_surjective _ z
+  simp only [LinearMap.mem_range, Submodule.mem_map, Submodule.mem_comap, Submodule.coe_subtype,
+    Submodule.mkQ_apply]
+  constructor
+  · rintro ⟨x, hx⟩
+    obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+    have hxeq : Submodule.Quotient.mk
+        ((diagonalHom K F).restrict (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f)
+        = (Submodule.Quotient.mk α :
+            adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) := hx
+    refine ⟨α, ?_, rfl⟩
+    have hdiag2 : (diagonalHom K F (f : F)) ∈ adeleBdd D₂ := diagonal_mem_adeleBdd_iff.mpr f.2
+    have hsub : (α : Place K F → F) - diagonalHom K F (f : F) ∈ adeleBdd D₁ := by
+      have hq := (Submodule.Quotient.eq _).mp hxeq.symm
+      simpa using hq
+    refine Submodule.mem_sup.mpr ⟨(α : Place K F → F) - diagonalHom K F (f : F), hsub,
+      diagonalHom K F (f : F), diagonal_mem_globalSub _, ?_⟩
+    abel
+  · rintro ⟨β, hβ, hβeq⟩
+    have hβ' : (β : Place K F → F) ∈ adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F) :=
+      Submodule.mem_inf.mpr ⟨β.2, hβ⟩
+    rw [adeleBdd_inf_sup_globalSub hD, ← map_diagonal_lSpace] at hβ'
+    obtain ⟨γ, hγ, δ, ⟨f, hf, hfδ⟩, hsum⟩ := Submodule.mem_sup.mp hβ'
+    refine ⟨Submodule.Quotient.mk ⟨f, hf⟩, ?_⟩
+    rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk ⟨f, hf⟩)
+          = Submodule.Quotient.mk ((diagonalHom K F).restrict
+              (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) ⟨f, hf⟩) from rfl,
+      ← hβeq, Submodule.Quotient.eq]
+    refine Submodule.mem_comap.mpr ?_
+    change diagonalHom K F f - (β : Place K F → F) ∈ adeleBdd D₁
+    have hβsub : diagonalHom K F f - (β : Place K F → F) = -γ := by
+      rw [← hsum, hfδ]; ring
+    rw [hβsub]; exact (adeleBdd D₁).neg_mem hγ
+
+
+theorem finrank_adeleBddSup_quotient [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) [hL : FiniteDimensional K (LSpace D₂)] :
+    Module.Finite K (↥(adeleBdd D₂ ⊔ globalSub K F)
+        ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) ∧
+      (finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+          ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) : ℤ)
+        = (Divisor.degree D₂ - ell D₂) - (Divisor.degree D₁ - ell D₁) := by
+  classical
+  let A : Submodule K (adeleBdd D₂) := (adeleBdd D₁).comap (adeleBdd D₂).subtype
+  let B : Submodule K (adeleBdd D₂) :=
+    (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype
+  have hAB : A ≤ B := Submodule.comap_mono le_sup_left
+  have hfinA : Module.Finite K (adeleBdd D₂ ⧸ A) := module_finite_adeleBdd_quotient hD
+  have hdimA : (finrank K (adeleBdd D₂ ⧸ A) : ℤ) = Divisor.degree D₂ - Divisor.degree D₁ :=
+    finrank_adeleBdd_quotient_eq hD
+  have hran : LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD) = B.map A.mkQ :=
+    range_lSpaceQuotientToAdeleBddQuotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hdimL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K)
+      ((LSpace D₁).comap (LSpace D₂).subtype)
+    rw [← hℓ₁] at h; exact h.symm
+  have hdimB : ell D₂ = finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) + ell D₁ := by
+    rw [← hran, LinearMap.finrank_range_of_inj
+      (lSpaceQuotientToAdeleBddQuotient_injective hD)]
+    exact hdimL
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  have hfinB : Module.Finite K (adeleBdd D₂ ⧸ B) := Module.Finite.equiv e3
+  have hdim2 : finrank K (adeleBdd D₂ ⧸ A)
+      = finrank K (adeleBdd D₂ ⧸ B) + finrank K (B.map A.mkQ : Submodule K _) := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K) (M := adeleBdd D₂ ⧸ A)
+      (B.map A.mkQ)
+    rw [LinearEquiv.finrank_eq e3] at h; omega
+  have e2 := LinearMap.quotientInfEquivSupQuotient (R := K)
+    (adeleBdd D₂) (adeleBdd D₁ ⊔ globalSub K F)
+  have hsup : adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F) = adeleBdd D₂ ⊔ globalSub K F := by
+    rw [← sup_assoc, sup_eq_left.mpr (adeleBdd_mono hD)]
+  have hB' : (adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype = B := by
+    rw [Submodule.comap_subtype_self, top_inf_eq]
+  let eL : (adeleBdd D₂ ⧸ B) ≃ₗ[K]
+      (adeleBdd D₂ ⧸ ((adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+        (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype)) :=
+    Submodule.quotEquivOfEq _ _ hB'.symm
+  have hfin_iso : Module.Finite K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype) :=
+    Module.Finite.equiv (eL.trans e2)
+  have hdim_iso : finrank K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype)
+      = finrank K (adeleBdd D₂ ⧸ B) :=
+    (LinearEquiv.finrank_eq (eL.trans e2)).symm
+  have hcast : (finrank K (adeleBdd D₂ ⧸ A) : ℤ)
+      = (finrank K (adeleBdd D₂ ⧸ B) : ℤ) + ((ell D₂ : ℤ) - (ell D₁ : ℤ)) := by
+    have hb : (ell D₂ : ℤ)
+        = (finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) : ℤ) + (ell D₁ : ℤ) := by
+      exact_mod_cast hdimB
+    push_cast [hdim2]; linarith
+  have hgoal : (finrank K (adeleBdd D₂ ⧸ B) : ℤ)
+      = Divisor.degree D₂ - ↑(ell D₂) - (Divisor.degree D₁ - ↑(ell D₁)) := by
+    linarith [hdimA, hcast]
+  clear_value eL
+  exact hsup ▸ ⟨hfin_iso, by rw [hdim_iso]; exact hgoal⟩
+
+section Index
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+
+theorem adeleBddSup_eq_of_degree_sub_ell_eq {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)]
+    (heq : Divisor.degree D₂ - ell D₂ = Divisor.degree D₁ - ell D₁) :
+    adeleBdd D₂ ⊔ globalSub K F = adeleBdd D₁ ⊔ globalSub K F := by
+  obtain ⟨hfin, hdim⟩ := finrank_adeleBddSup_quotient hD
+  rw [heq, sub_self] at hdim
+  refine le_antisymm ?_ (sup_le_sup_right (adeleBdd_mono hD) _)
+  have := hfin
+  have hd0 : finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) = 0 := by
+    exact_mod_cast hdim
+  have hsub : Subsingleton (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) :=
+    Module.finrank_zero_iff.mp hd0
+  have htop := Submodule.Quotient.subsingleton_iff.mp hsub
+  intro x hx
+  have hxc : (⟨x, hx⟩ : ↥(adeleBdd D₂ ⊔ globalSub K F)) ∈
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype := by
+    rw [htop]; exact Submodule.mem_top
+  exact hxc
+
+end Index
+
+namespace RiemannGenusReachedAt
+p2m_export "AlgebraicCurve.RiemannGenusReachedAt" "finite mk eq isMax"
+end RiemannGenusReachedAt
+namespace RiemannGenusReachedAt
+p2m_open_scoped "AlgebraicCurve.RiemannGenusReachedAt" in
+private theorem _root_.AlgebraicCurve.RiemannGenusReachedAt.eq_of_ge [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {D : Divisor K F} (hD : D₀ ≤ D) :
+    Divisor.degree D - ell D = γ - 1 := by
+  have := finiteDimensional_lSpace (K := K) D
+  have hge : Divisor.degree D₀ - (ell D₀ : ℤ) ≤ Divisor.degree D - ell D := by
+    have := ell_sub_ell_le_degree_sub_degree (K := K) hD
+    linarith
+  exact le_antisymm (h.isMax D) (h.eq ▸ hge)
+
+end RiemannGenusReachedAt
+p2m_export "AlgebraicCurve" "RiemannGenusReachedAt.eq_of_ge"
+
+theorem adeleSpace_eq_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    adeleSpace K F = adeleBdd D₀ ⊔ globalSub K F := by
+  refine le_antisymm ?_ (adeleBdd_sup_globalSub_le_adeleSpace D₀)
+  rw [adeleSpace, iSup_le_iff]
+  intro D
+  refine le_trans (adeleBdd_mono (le_sup_left : D ≤ D ⊔ D₀)) ?_
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have heq : Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) = Divisor.degree D₀ - ell D₀ :=
+    (h.eq_of_ge le_sup_right).trans h.eq.symm
+  have hsup := adeleBddSup_eq_of_degree_sub_ell_eq (K := K)
+    (le_sup_right : D₀ ≤ D ⊔ D₀) heq
+  rw [← hsup]
+  exact le_sup_left
+
+theorem indexOfSpecialty_eq_zero_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    indexOfSpecialty D₀ = 0 := by
+  rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap, ← adeleSpace_eq_of_genusReached h,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.finrank_zero_of_subsingleton
+
+
+
+theorem gate_indexOfSpecialty_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  have h1 := (indexOfSpecialty_eq_of_genusReached h D₀).2
+  have h2 := h.eq
+  have h3 := indexOfSpecialty_eq_zero_of_genusReached h
+  exact_mod_cast h3
+
+theorem gate_riemannInequality_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Divisor.degree D + 1 - γ ≤ (ell D : ℤ) := by
+  have heq := (indexOfSpecialty_eq_of_genusReached h D).2
+  have hnn : (0 : ℤ) ≤ indexOfSpecialty D := Int.natCast_nonneg _
+  linarith
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem adeleSpaceMul_add [HasPrincipalDivisors K F] (f g : F) :
+    adeleSpaceMul K F (f + g) = adeleSpaceMul K F f + adeleSpaceMul K F g := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, LinearMap.add_apply, Submodule.coe_add,
+    Pi.add_apply, add_mul]
+
+theorem adeleSpaceMul_zero [HasPrincipalDivisors K F] :
+    adeleSpaceMul K F (0 : F) = 0 := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, zero_mul, LinearMap.zero_apply,
+    Submodule.coe_zero, Pi.zero_apply]
+
+theorem weilSmul_add_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f + g) φ = weilSmul K F f φ + weilSmul K F g φ := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_add, LinearMap.add_apply, map_add]
+
+theorem weilSmul_zero_left [HasPrincipalDivisors K F]
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (0 : F) φ = 0 := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_zero, LinearMap.zero_apply, map_zero]
+
+theorem weilSmul_neg_left [HasPrincipalDivisors K F] (f : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (-f) φ = -weilSmul K F f φ := by
+  have h := weilSmul_add_left (K := K) (F := F) f (-f) φ
+  rw [add_neg_cancel, weilSmul_zero_left] at h
+  exact (neg_eq_of_add_eq_zero_right h.symm).symm
+
+theorem weilSmul_sub_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f - g) φ = weilSmul K F f φ - weilSmul K F g φ := by
+  rw [sub_eq_add_neg, weilSmul_add_left, weilSmul_neg_left, sub_eq_add_neg]
+
+theorem weilSmul_eq_zero_iff_left [HasPrincipalDivisors K F]
+    {f : F} {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    weilSmul K F f φ = 0 ↔ f = 0 := by
+  refine ⟨fun h => ?_, fun h => h ▸ weilSmul_zero_left φ⟩
+  by_contra hf
+  exact hφ (weilSmul_injective hf (h.trans (map_zero (weilSmul K F f)).symm))
+
+theorem weilSmul_left_injective [HasPrincipalDivisors K F]
+    {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    Function.Injective (fun f : F => weilSmul K F f φ) := by
+  intro f g hfg
+  have hsub : weilSmul K F (f - g) φ = 0 := by
+    rw [weilSmul_sub_left, sub_eq_zero]; exact hfg
+  exact sub_eq_zero.mp ((weilSmul_eq_zero_iff_left hφ).mp hsub)
+
+variable (K F) in
+def doubleResiduePairing [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) :
+    LSpace (W - D) × LSpace (W - D) →ₗ[K] omegaSpace D :=
+  (residuePairing K F W D hφ).coprod (residuePairing K F W D hμ)
+
+theorem doubleResiduePairing_apply_coe [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (g h : LSpace (W - D)) :
+    (doubleResiduePairing K F W D hφ hμ (g, h) : Module.Dual K (adeleSpace K F))
+      = weilSmul K F (g : F) φ + weilSmul K F (h : F) μ := by
+  simp only [doubleResiduePairing, LinearMap.coprod_apply, Submodule.coe_add,
+    residuePairing_apply_coe]
+
+theorem doubleResiduePairing_injective [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ) :
+    Function.Injective (doubleResiduePairing K F W D hφ hμ) := by
+  rw [injective_iff_map_eq_zero]
+  rintro ⟨g, h⟩ heq
+  have heq' : weilSmul K F (g : F) φ + weilSmul K F (h : F) μ = 0 := by
+    have hcoe := congrArg Subtype.val heq
+    rwa [doubleResiduePairing_apply_coe, Submodule.coe_zero] at hcoe
+  rcases eq_or_ne (h : F) 0 with hh0 | hh0
+  · rw [hh0, weilSmul_zero_left, add_zero] at heq'
+    have hg0 : (g : F) = 0 := (weilSmul_eq_zero_iff_left hφ0).mp heq'
+    exact Prod.ext (Subtype.ext hg0) (Subtype.ext hh0)
+  · exfalso
+    have hμeq : weilSmul K F (h : F) μ = -weilSmul K F (g : F) φ := by
+      have h2 : weilSmul K F (h : F) μ + weilSmul K F (g : F) φ = 0 := by
+        rw [add_comm]; exact heq'
+      exact eq_neg_of_add_eq_zero_left h2
+    have hLHS : weilSmul K F (h : F)⁻¹ (weilSmul K F (h : F) μ) = μ := by
+      rw [← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hh0, weilSmul_one,
+        LinearMap.id_apply]
+    have hRHS : weilSmul K F (h : F)⁻¹ (-weilSmul K F (g : F) φ)
+        = weilSmul K F (-(g : F) * (h : F)⁻¹) φ := by
+      rw [map_neg, ← LinearMap.comp_apply, ← weilSmul_mul, neg_mul, weilSmul_neg_left]
+    exact hindep (-(g : F) * (h : F)⁻¹) (by rw [← hLHS, hμeq, hRHS])
+
+theorem two_mul_ell_le_indexOfSpecialty [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ)
+    [Module.Finite K (omegaSpace (K := K) (F := F) D)]
+    [Module.Finite K (LSpace (K := K) (F := F) (W - D))] :
+    2 * ell (W - D) ≤ indexOfSpecialty D := by
+  have hinj := doubleResiduePairing_injective W D hφ hμ hφ0 hindep
+  have hle := LinearMap.finrank_le_finrank_of_injective hinj
+  rw [Module.finrank_prod] at hle
+  rw [← finrank_omegaSpace_eq_indexOfSpecialty, two_mul]
+  exact hle
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+section Finiteness
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+theorem omegaSpace_finite_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Module.Finite K (omegaSpace (K := K) (F := F) D) := by
+  have := (indexOfSpecialty_eq_of_genusReached h D).1
+  exact Module.Finite.equiv (omegaSpaceEquivIndexDual D).symm
+
+end Finiteness
+
+section ParametricRankOne
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+
+theorem exists_weilSmul_eq_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {φ μ : Module.Dual K (adeleSpace K F)} {W : Divisor K F}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (hφ0 : φ ≠ 0) :
+    ∃ f : F, μ = weilSmul K F f φ := by
+  by_contra hcon
+  push Not at hcon
+  obtain ⟨P⟩ := ‹Nonempty (Place K F)›
+  set n : ℕ := 3 * γ.natAbs + 2 * (Divisor.degree W).natAbs + 4 with hn
+  set D : Divisor K F := -Finsupp.single P (n : ℤ) with hD
+  have hdegD : Divisor.degree D = -(n : ℤ) * (P.deg : ℤ) := by
+    rw [hD, map_neg, Divisor.degree_single]; ring
+  have hdegWD : Divisor.degree (W - D) = Divisor.degree W + (n : ℤ) * (P.deg : ℤ) := by
+    rw [map_sub, hdegD]; ring
+  have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+  have habsγ : -(|γ|) ≤ γ ∧ γ ≤ |γ| := ⟨neg_abs_le _, le_abs_self _⟩
+  have habsW : -|Divisor.degree W| ≤ Divisor.degree W ∧
+      Divisor.degree W ≤ |Divisor.degree W| := ⟨neg_abs_le _, le_abs_self _⟩
+  have hn_ge : 3 * |γ| + 2 * |Divisor.degree W| + 4 ≤ (n : ℤ) := by
+    rw [hn]; push_cast [Int.natCast_natAbs]; ring_nf; omega
+  have hndegP : (n : ℤ) ≤ (n : ℤ) * (P.deg : ℤ) := by nlinarith [Int.natCast_nonneg n]
+  have hellD : ell D = 0 := ell_eq_zero_of_degree_neg (by rw [hdegD]; nlinarith)
+  have hiD : (indexOfSpecialty D : ℤ) = (n : ℤ) * (P.deg : ℤ) - 1 + γ := by
+    have hidx := (indexOfSpecialty_eq_of_genusReached h D).2
+    rw [hellD, hdegD] at hidx; push_cast at hidx; linarith
+  have hlowerWD : Divisor.degree W + (n : ℤ) * (P.deg : ℤ) + 1 - γ
+      ≤ (ell (W - D) : ℤ) := by
+    have hlow := gate_riemannInequality_of_genusReached h (W - D)
+    rw [hdegWD] at hlow; exact hlow
+  have := omegaSpace_finite_of_genusReached h D
+  have := finiteDimensional_lSpace (K := K) (W - D)
+  have hdbl : (2 * ell (W - D) : ℤ) ≤ (indexOfSpecialty D : ℤ) := by
+    exact_mod_cast two_mul_ell_le_indexOfSpecialty W D hφ hμ hφ0 hcon
+  rw [hiD] at hdbl
+  nlinarith [habsγ.1, habsγ.2, habsW.1, habsW.2]
+
+theorem weilDifferentialRankOne_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    WeilDifferentialRankOne K F := by
+  intro φ hφmem hφ0 μ hμmem
+  obtain ⟨W₁, hφW₁⟩ := mem_weilDifferentialModule_iff.mp hφmem
+  obtain ⟨W₂, hμW₂⟩ := mem_weilDifferentialModule_iff.mp hμmem
+  have hφW : φ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_left hφW₁
+  have hμW : μ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_right hμW₂
+  obtain ⟨f, hf⟩ := exists_weilSmul_eq_of_genusReached h hφW hμW hφ0
+  exact ⟨f, hf, fun f' hf' => weilSmul_left_injective hφ0 (hf'.symm.trans hf)⟩
+
+end ParametricRankOne
+
+theorem residuePairing_surjective_of_rankOne_max [HasPrincipalDivisors K F]
+    (hRankOne : WeilDifferentialRankOne K F)
+    {W : Divisor K F} {φ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hφ0 : φ ≠ 0)
+    (hWmax : ∀ E : Divisor K F, φ ∈ omegaSpace E → E ≤ W) (D : Divisor K F) :
+    Function.Surjective (residuePairing K F W D hφ) := by
+  rintro ⟨μ, hμD⟩
+  have hφmem : φ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule W hφ
+  have hμmem : μ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule D hμD
+  obtain ⟨f, hf, -⟩ := hRankOne hφmem hφ0 hμmem
+  rcases eq_or_ne f 0 with rfl | hf0
+  · have hμ0 : (⟨μ, hμD⟩ : omegaSpace D) = 0 :=
+      Subtype.ext (hf.trans (weilSmul_zero_left φ))
+    exact ⟨0, (map_zero _).trans hμ0.symm⟩
+  · obtain ⟨P, hPord, _⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+    have hPinv : ∀ v, (-P) v = v.ord f⁻¹ := fun v => by
+      rw [Finsupp.neg_apply, hPord v, v.ord_inv]
+    have hinv : weilSmul K F f⁻¹ μ = φ := by
+      rw [hf, ← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hf0, weilSmul_one,
+        LinearMap.id_apply]
+    have hφD : φ ∈ omegaSpace (D + -P) := by
+      rw [← hinv]; exact weilSmul_mem_omegaSpace_add (inv_ne_zero hf0) hPinv hμD
+    have hDP : D + -P ≤ W := hWmax _ hφD
+    have hfL : f ∈ LSpace (W - D) := by
+      rw [mem_lSpace_iff_ord]; refine Or.inr fun v => ?_
+      have hv := hDP v
+      rw [Finsupp.add_apply, Finsupp.neg_apply, hPord v] at hv
+      rw [Finsupp.sub_apply]; linarith
+    exact ⟨⟨f, hfL⟩, Subtype.ext hf.symm⟩
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem exists_riemannGenusReachedAt_of_bounded
+    [IsCurveOver K F] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    ∃ (γ : ℤ) (D₀ : Divisor K F), RiemannGenusReachedAt γ D₀ := by
+  obtain ⟨γ, hγ⟩ := hbdd
+  obtain ⟨M, ⟨D₀, hD₀⟩, hMmax⟩ :=
+    Int.exists_greatest_of_bdd
+      (P := fun n => ∃ D : Divisor K F, Divisor.degree D - ell D = n)
+      ⟨γ, fun n ⟨D, hD⟩ => hD ▸ hγ D⟩
+      ⟨Divisor.degree (0 : Divisor K F) - ell (0 : Divisor K F), 0, rfl⟩
+  refine ⟨M + 1, D₀, ?_, ?_, ?_⟩
+  · exact finiteDimensional_lSpace D₀
+  · rw [hD₀]; ring
+  · intro D
+    have := hMmax (Divisor.degree D - ell D) ⟨D, rfl⟩
+    linarith
+
+theorem stichtenothGenusExists_of_bounded
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    StichtenothGenusExists K F :=
+  ⟨‹_›, ‹_›, exists_riemannGenusReachedAt_of_bounded hbdd⟩
+
+
+theorem indexOfSpecialty_sub_of_ge [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₀ D : Divisor K F} (hD : D₀ ≤ D)
+    [FiniteDimensional K (LSpace D)]
+    [hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀)] :
+    Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D) ∧
+      (Divisor.degree D - ell D) - (Divisor.degree D₀ - ell D₀)
+        = (indexOfSpecialty D₀ : ℤ) - (indexOfSpecialty D : ℤ) := by
+  have hABsub : adeleBdd D₀ ⊔ globalSub K F ≤ adeleBdd D ⊔ globalSub K F :=
+    sup_le_sup_right (adeleBdd_mono hD) _
+  have hBCsub : adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+    adeleBdd_sup_globalSub_le_adeleSpace _
+  obtain ⟨hfinBA, hdimBA⟩ := finrank_adeleBddSup_quotient (K := K) hD
+  have := hfinBA
+  have hfinCA : Module.Finite K (adeleSpace K F ⧸
+      (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [← adeleBddPrincipal_eq_comap]; exact hfin
+  obtain ⟨hfinCB, hdimCB⟩ := Submodule.finrank_quotient_chain'
+    (A := adeleBdd D₀ ⊔ globalSub K F) (B := adeleBdd D ⊔ globalSub K F)
+    (C := adeleSpace K F) hABsub hBCsub
+  have hi0 : indexOfSpecialty D₀
+      = finrank K (adeleSpace K F ⧸
+        (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap]
+  have hiD : indexOfSpecialty D
+      = finrank K (adeleSpace K F ⧸
+        (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap]
+  have := hfinCB
+  obtain ⟨_, hdimCA⟩ := Submodule.finrank_quotient_chain
+    (A := adeleBdd D₀ ⊔ globalSub K F) (B := adeleBdd D ⊔ globalSub K F)
+    (C := adeleSpace K F) hABsub hBCsub
+  refine ⟨?_, ?_⟩
+  · rw [show adeleBddPrincipal K F D
+        = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype
+      from adeleBddPrincipal_eq_comap D]
+    exact hfinCB
+  · have hcast : (indexOfSpecialty D₀ : ℤ)
+        = (indexOfSpecialty D : ℤ)
+          + (finrank K (↥(adeleBdd D ⊔ globalSub K F)
+              ⧸ (adeleBdd D₀ ⊔ globalSub K F).comap
+                (adeleBdd D ⊔ globalSub K F).subtype) : ℤ) := by
+      rw [hiD, hi0]; exact_mod_cast hdimCA
+    linarith [hdimBA, hcast]
+
+theorem degreeSub_ell_le_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {D₀ : Divisor K F}
+    (hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀))
+    (D : Divisor K F) :
+    Divisor.degree D - ell D ≤ (Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀ := by
+  have := hfin
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have hmono : Divisor.degree D - (ell D : ℤ)
+      ≤ Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) (le_sup_left : D ≤ D ⊔ D₀)
+    linarith
+  obtain ⟨_, heq⟩ :=
+    indexOfSpecialty_sub_of_ge (K := K) (le_sup_right : D₀ ≤ D ⊔ D₀)
+  have hi0 : (0 : ℤ) ≤ indexOfSpecialty (D ⊔ D₀) := Int.natCast_nonneg _
+  linarith
+
+theorem riemannGenusBounded_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hfin : IndexOfSpecialtyFinite K F) :
+    RiemannGenusBounded K F := by
+  obtain ⟨D₀, hD₀⟩ := hfin
+  exact ⟨(Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀,
+    degreeSub_ell_le_of_indexFinite hD₀⟩
+
+theorem stichtenothGenusExists_of_indexFinite
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hfin : IndexOfSpecialtyFinite K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_bounded (riemannGenusBounded_of_indexFinite hfin)
+
+theorem indexOfSpecialtyFinite_of_stichtenothGenusExists
+    [IsCurveOver K F] (hSG : StichtenothGenusExists K F) :
+    IndexOfSpecialtyFinite K F := by
+  obtain ⟨hne, hL0, γ, D₀, hD₀⟩ := hSG
+  have := hne; have := hL0
+  refine ⟨D₀, ?_⟩
+  rw [show adeleBddPrincipal K F D₀
+      = (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype
+    from adeleBddPrincipal_eq_comap D₀, ← adeleSpace_eq_of_genusReached hD₀,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.Finite.of_finite
+
+theorem stichtenothGenusExists_iff_indexFinite
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] :
+    StichtenothGenusExists K F ↔ IndexOfSpecialtyFinite K F :=
+  ⟨indexOfSpecialtyFinite_of_stichtenothGenusExists,
+    stichtenothGenusExists_of_indexFinite⟩
+
+theorem gate_indexOfSpecialty_engine_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  exact_mod_cast indexOfSpecialty_eq_zero_of_genusReached h
+
+theorem gate_stichtenothGenus_le_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {D₀ : Divisor K F}
+    (hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀))
+    {γ : ℤ} {D₁ : Divisor K F} (h : RiemannGenusReachedAt γ D₁) :
+    γ - 1 ≤ (Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀ := by
+  have := degreeSub_ell_le_of_indexFinite hfin D₁
+  rw [h.eq] at this; exact this
+
+theorem gate_riemannGenusBounded_of_reachedAt
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    RiemannGenusBounded K F :=
+  ⟨γ - 1, h.isMax⟩
+
+theorem gate_indexOfSpecialtyFinite_at_zero [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F (0 : Divisor K F)) :=
+  (indexOfSpecialty_eq_of_genusReached h 0).1
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem mul_mem_lSpace_add {D E : Divisor K F} {f g : F}
+    (hf : f ∈ LSpace D) (hg : g ∈ LSpace E) :
+    f * g ∈ LSpace (D + E) := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · rw [zero_mul]; exact (LSpace _).zero_mem
+  rcases eq_or_ne g 0 with rfl | hg0
+  · rw [mul_zero]; exact (LSpace _).zero_mem
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun v => ?_
+  rw [Finsupp.add_apply, neg_add, v.ord_mul hf0 hg0]
+  exact add_le_add ((mem_lSpace_iff_ord.mp hf).resolve_left hf0 v)
+    ((mem_lSpace_iff_ord.mp hg).resolve_left hg0 v)
+
+theorem pow_mem_lSpace_nsmul {B : Divisor K F} {f : F} (hf : f ∈ LSpace B) (j : ℕ) :
+    f ^ j ∈ LSpace (j • B) := by
+  induction j with
+  | zero => simpa using one_mem_lSpace_zero (K := K) (F := F)
+  | succ j ih =>
+    rw [pow_succ, succ_nsmul]
+    exact mul_mem_lSpace_add ih hf
+
+namespace PoleDivisorPackage
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degB_eq u B hB_eff n lin_indep mk c x hn_pos \
+  hu_mem mk.injEq hx_mem"
+p2m_open "AlgebraicCurve.PoleDivisorPackage"
+
+variable (P : PoleDivisorPackage K F)
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.pow_mul_u_mem_lSpace (j : ℕ) (i : Fin P.n)
+    :
+    P.x ^ j * P.u i ∈ LSpace ((j + P.c) • P.B) := by
+  rw [add_nsmul]
+  exact mul_mem_lSpace_add (pow_mem_lSpace_nsmul P.hx_mem j) (P.hu_mem i)
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "pow_mul_u_mem_lSpace"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.pow_mul_u_mem_lSpace_of_le {j m : ℕ}
+    (hjm : j + P.c ≤ m) (i : Fin P.n) :
+    P.x ^ j * P.u i ∈ LSpace (m • P.B) := by
+  refine lSpace_mono ?_ (P.pow_mul_u_mem_lSpace j i)
+  intro v
+  have hBv : (0 : ℤ) ≤ P.B v := P.hB_eff v
+  change ((j + P.c) • P.B) v ≤ (m • P.B) v
+  simp only [Finsupp.smul_apply, nsmul_eq_mul]
+  exact mul_le_mul_of_nonneg_right (by exact_mod_cast hjm) hBv
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "pow_mul_u_mem_lSpace_of_le"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.ell_nsmul_poleDivisor_ge [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    (P.n : ℤ) * (m - P.c + 1) ≤ ell (m • P.B) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  set g : Fin (m - P.c + 1) × Fin P.n → LSpace (m • P.B) :=
+    fun p => ⟨P.x ^ (p.1 : ℕ) * P.u p.2,
+      P.pow_mul_u_mem_lSpace_of_le (by have := p.1.isLt; omega) p.2⟩
+    with hgdef
+  have hsub : LinearIndependent K (fun p => (g p : F)) := by
+    have heq : (fun p => (g p : F))
+        = (fun p : ℕ × Fin P.n => P.x ^ p.1 * P.u p.2)
+            ∘ (fun p : Fin (m - P.c + 1) × Fin P.n => ((p.1 : ℕ), p.2)) := by
+      funext p; rfl
+    rw [heq]
+    refine P.lin_indep.comp _ ?_
+    intro p q hpq
+    simp only [Prod.mk.injEq] at hpq
+    exact Prod.ext (Fin.val_injective hpq.1) hpq.2
+  have hg : LinearIndependent K g := hsub.of_comp (LSpace (m • P.B)).subtype
+  have hcard := hg.fintype_card_le_finrank
+  rw [Fintype.card_prod, Fintype.card_fin, Fintype.card_fin] at hcard
+  have hZ : ((m - P.c + 1) * P.n : ℤ) ≤ (ell (m • P.B) : ℤ) := by exact_mod_cast hcard
+  have heq : (((m - P.c + 1 : ℕ) : ℤ) * P.n : ℤ) = (P.n : ℤ) * ((m : ℤ) - P.c + 1) := by
+    rw [Nat.cast_add, Nat.cast_sub hm, Nat.cast_one]; ring
+  linarith
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "ell_nsmul_poleDivisor_ge"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.degree_nsmul_sub_ell_le [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    Divisor.degree (m • P.B) - ell (m • P.B) ≤ (P.n : ℤ) * (P.c - 1) := by
+  have hge := P.ell_nsmul_poleDivisor_ge hm
+  have hdeg : Divisor.degree (m • P.B) = (m : ℤ) * P.n := by
+    rw [show m • P.B = (m : ℤ) • P.B from (natCast_zsmul _ _).symm,
+      Divisor.degree.map_zsmul, smul_eq_mul, P.degB_eq]
+  linarith
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degree_nsmul_sub_ell_le"
+end PoleDivisorPackage
+
+namespace PoleDivisorPackage
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degB_eq u B hB_eff n lin_indep mk c x hn_pos \
+  hu_mem mk.injEq hx_mem"
+end PoleDivisorPackage
+namespace PoleDivisorPackage
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.ell_nsmul_sub_pos [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) {A : Divisor K F} (hA : 0 ≤ A) {m : ℕ} (hm : P.c ≤ m)
+    (hbig : Divisor.degree A < (P.n : ℤ) * (m - P.c + 1)) :
+    0 < ell (m • P.B - A) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  have hle : m • P.B - A ≤ m • P.B := by
+    intro v
+    have hAv : (0 : ℤ) ≤ A v := hA v
+    rw [Finsupp.sub_apply]
+    linarith
+  have h48 := ell_sub_ell_le_degree_sub_degree (K := K) hle
+  rw [map_sub, sub_sub_cancel] at h48
+  have h412 := P.ell_nsmul_poleDivisor_ge hm
+  have : (0 : ℤ) < (ell (m • P.B - A) : ℤ) := by linarith
+  exact_mod_cast this
+
+end PoleDivisorPackage
+p2m_export "AlgebraicCurve" "PoleDivisorPackage.ell_nsmul_sub_pos"
+namespace PoleDivisorPackage
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.degree_sub_ell_le [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) (D : Divisor K F) :
+    Divisor.degree D - ell D ≤ (P.n : ℤ) * (P.c - 1) := by
+  classical
+  set D' : Divisor K F := D ⊔ 0 with hD'def
+  have hD'eff : 0 ≤ D' := le_sup_right
+  have hDD' : D ≤ D' := le_sup_left
+  have := finiteDimensional_lSpace (K := K) D'
+  have hmono : Divisor.degree D - (ell D : ℤ) ≤ Divisor.degree D' - ell D' := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hDD'
+    linarith
+  set m : ℕ := P.c + (Divisor.degree D').toNat with hmdef
+  have hcm : P.c ≤ m := Nat.le_add_right _ _
+  have hdegD' : 0 ≤ Divisor.degree D' := Divisor.degree_nonneg_of_nonneg hD'eff
+  have hbig : Divisor.degree D' < (P.n : ℤ) * (m - P.c + 1) := by
+    have hcast : ((m : ℤ) - P.c) = Divisor.degree D' := by
+      simp only [hmdef, Nat.cast_add, add_sub_cancel_left, Int.toNat_of_nonneg hdegD']
+    rw [hcast]
+    have hn1 : (1 : ℤ) ≤ P.n := by exact_mod_cast P.hn_pos
+    nlinarith
+  have hellpos := P.ell_nsmul_sub_pos hD'eff hcm hbig
+  have hnebot : LSpace (m • P.B - D') ≠ ⊥ :=
+    fun h => by rw [ell, h, finrank_bot] at hellpos; exact lt_irrefl 0 hellpos
+  obtain ⟨z, hzL, hz0⟩ := (Submodule.ne_bot_iff _).mp hnebot
+  obtain ⟨Dz, hDzord, hDzdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) z hz0
+  have hzmem := (mem_lSpace_iff_ord.mp hzL).resolve_left hz0
+  have hD'le : D' ≤ m • P.B + Dz := by
+    intro v
+    have := hzmem v
+    simp only [Finsupp.add_apply, Finsupp.sub_apply, neg_sub] at this ⊢
+    rw [hDzord]; linarith
+  have hellshift : ell (m • P.B + Dz) = ell (m • P.B) :=
+    (LinearEquiv.finrank_eq (lSpaceShiftEquiv (m • P.B) hz0 hDzord)).symm
+  have hdegshift : Divisor.degree (m • P.B + Dz) = Divisor.degree (m • P.B) := by
+    rw [map_add, hDzdeg, add_zero]
+  have := finiteDimensional_lSpace (K := K) (m • P.B + Dz)
+  have hmono' : Divisor.degree D' - (ell D' : ℤ)
+      ≤ Divisor.degree (m • P.B + Dz) - ell (m • P.B + Dz) := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hD'le
+    linarith
+  rw [hellshift, hdegshift] at hmono'
+  have h412 := P.degree_nsmul_sub_ell_le hcm
+  linarith
+
+end PoleDivisorPackage
+p2m_export "AlgebraicCurve" "PoleDivisorPackage.degree_sub_ell_le"
+
+theorem riemannGenusBounded_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    RiemannGenusBounded K F :=
+  ⟨(P.n : ℤ) * (P.c - 1), P.degree_sub_ell_le⟩
+
+theorem stichtenothGenusExists_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_bounded (riemannGenusBounded_of_poleDivisorPackage P)
+
+theorem indexOfSpecialtyFinite_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_stichtenothGenusExists
+    (stichtenothGenusExists_of_poleDivisorPackage P)
+
+theorem indexOfSpecialtyFinite_of_hasPoleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (h : HasPoleDivisorPackage K F) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_poleDivisorPackage h.some
+
+theorem stichtenothGenusExists_of_hasPoleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (h : HasPoleDivisorPackage K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_poleDivisorPackage h.some
+
+theorem gate_stichtenothGenus_le_of_poleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F)
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    γ ≤ (P.n : ℤ) * (P.c - 1) + 1 := by
+  have := P.degree_sub_ell_le D₀
+  rw [h.eq] at this; linarith
+
+theorem gate_ell_c_nsmul_ge [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    (P.n : ℤ) ≤ ell (P.c • P.B) := by
+  have h := P.ell_nsmul_poleDivisor_ge (le_refl P.c)
+  simp only [sub_self, zero_add, mul_one] at h
+  exact h
+
+theorem gate_x_transcendental_of_poleDivisorPackage (P : PoleDivisorPackage K F) :
+    LinearIndependent K (fun j : ℕ => P.x ^ j * P.u ⟨0, P.hn_pos⟩) := by
+  refine P.lin_indep.comp (fun j => (j, ⟨0, P.hn_pos⟩)) ?_
+  intro a b hab
+  exact (Prod.mk.injEq .. ▸ hab).1
+
+theorem gate_u_linearIndependent_of_poleDivisorPackage (P : PoleDivisorPackage K F) :
+    LinearIndependent K P.u := by
+  have h : LinearIndependent K (fun i : Fin P.n => P.x ^ (0 : ℕ) * P.u i) := by
+    refine P.lin_indep.comp (fun i => (0, i)) ?_
+    intro a b hab
+    exact (Prod.mk.injEq .. ▸ hab).2
+  simpa using h
+
+end AlgebraicCurve
+
+end
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+scoped instance instSumRamificationInertia_port {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F']
+    [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+    [HasPrincipalDivisors K F'] : SumRamificationInertia K F F' :=
+  ⟨fun v => Place.sum_ramificationIndex_mul_inertiaDeg v⟩
+end AlgebraicCurve
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+
+namespace TranscendenceTower
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF poleDivisor RegularOutside hx_indep hxreg v \
+  mk.injEq mk hvdeg x hxv"
+p2m_open "AlgebraicCurve.TranscendenceTower"
+
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F]
+variable (T : TranscendenceTower K E F)
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.x_ne_zero : T.x ≠ 0 := fun h => by
+  have := T.hxv; rw [h, Place.ord_zero] at this; exact absurd this (by decide)
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "x_ne_zero"
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+theorem xF_ne_zero : T.xF ≠ 0 :=
+  fun h => T.x_ne_zero ((algebraMap E F).injective (by rwa [map_zero]))
+
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.poleDivisor_apply (w : Place K F) :
+    T.poleDivisor w = (w.ramificationIndex E : ℤ) * (Finsupp.single T.v 1) (w.restrict E) :=
+  Divisor.pullback_apply (Finsupp.single T.v 1) w
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "poleDivisor_apply"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.poleDivisor_nonneg :
+    0 ≤ T.poleDivisor := by
+  classical
+  intro w
+  rw [Finsupp.coe_zero, Pi.zero_apply, T.poleDivisor_apply, Finsupp.single_apply]
+  refine mul_nonneg (Int.natCast_nonneg _) ?_
+  split_ifs <;> simp
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "poleDivisor_nonneg"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.xF_mem_lSpace_poleDivisor :
+    T.xF ∈ LSpace T.poleDivisor := by
+  classical
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun w => ?_
+  rw [T.poleDivisor_apply, Place.ord_restrict, Finsupp.single_apply]
+  rcases eq_or_ne (w.restrict E) T.v with hw | hw
+  · simp only [hw, T.hxv, ite_true, mul_one, mul_neg_one, le_refl]
+  · simp only [ite_eq_right (Ne.symm hw), mul_zero, neg_zero]
+    exact mul_nonneg (Int.natCast_nonneg _) (T.hxreg _ hw)
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF_mem_lSpace_poleDivisor"
+
+private theorem _root_.AlgebraicCurve.TranscendenceTower.degree_poleDivisor_eq_finrank :
+    Divisor.degree T.poleDivisor = (Module.finrank E F : ℤ) := by
+  rw [poleDivisor, Divisor.degree_pullback, Divisor.degree_single, T.hvdeg]
+  push_cast; ring
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "degree_poleDivisor_eq_finrank"
+omit [FiniteDimensional E F] in
+private theorem
+  _root_.AlgebraicCurve.TranscendenceTower.mem_lSpace_nsmul_poleDivisor_of_regular_outside {f : F}
+    (hreg : ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord f)
+    {c : ℕ} (hc : ∀ w ∈ T.v.fiber F, -(c : ℤ) ≤ w.ord f) :
+    f ∈ LSpace (c • T.poleDivisor) := by
+  classical
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact (LSpace _).zero_mem
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun w => ?_
+  rw [Finsupp.smul_apply, T.poleDivisor_apply, Finsupp.single_apply, nsmul_eq_mul]
+  rcases eq_or_ne (w.restrict E) T.v with hw | hw
+  · simp only [hw, ite_true, mul_one]
+    have he : (1 : ℤ) ≤ w.ramificationIndex E := by
+      exact_mod_cast w.ramificationIndex_pos (F := E)
+    have hbdd := hc w (Place.mem_fiber.mpr hw)
+    nlinarith [Int.natCast_nonneg c]
+  · simp only [ite_eq_right (Ne.symm hw), mul_zero, neg_zero]
+    exact hreg w hw
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "mem_lSpace_nsmul_poleDivisor_of_regular_outside"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.exists_forall_mem_lSpace_nsmul_poleDivisor
+    {n : ℕ} (u : Fin n → F)
+    (hreg : ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)) :
+    ∃ c : ℕ, ∀ i, u i ∈ LSpace (c • T.poleDivisor) := by
+  classical
+  refine ⟨(Finset.univ : Finset (Fin n)).sup fun i =>
+    (T.v.fiber F).sup fun w => (-(w.ord (u i))).toNat,
+    fun i => T.mem_lSpace_nsmul_poleDivisor_of_regular_outside (hreg i) ?_⟩
+  intro w hw
+  have h1 : (-(w.ord (u i))).toNat
+      ≤ (T.v.fiber F).sup fun w' => (-(w'.ord (u i))).toNat :=
+    Finset.le_sup (f := fun w' => (-(w'.ord (u i))).toNat) hw
+  have h2 : ((T.v.fiber F).sup fun w' => (-(w'.ord (u i))).toNat)
+      ≤ (Finset.univ : Finset (Fin n)).sup fun i' =>
+          (T.v.fiber F).sup fun w' => (-(w'.ord (u i'))).toNat :=
+    Finset.le_sup (f := fun i' => (T.v.fiber F).sup fun w' => (-(w'.ord (u i'))).toNat)
+      (Finset.mem_univ i)
+  have htnat : -(w.ord (u i)) ≤ ((-(w.ord (u i))).toNat : ℤ) := Int.self_le_toNat _
+  omega
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "exists_forall_mem_lSpace_nsmul_poleDivisor"
+end TranscendenceTower
+
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F]
+
+section PrincipalDivisors
+
+variable [HasPrincipalDivisors K F]
+
+namespace IntegralBasisInLSpace
+p2m_export "AlgebraicCurve.IntegralBasisInLSpace" "hu_indep c u mk.injEq hu_mem mk"
+end IntegralBasisInLSpace
+p2m_open_scoped "AlgebraicCurve.IntegralBasisInLSpace" in
+def IntegralBasisInLSpace.ofRegularOutside (T : TranscendenceTower K E F)
+    (u : Fin (Module.finrank E F) → F) (hu_indep : LinearIndependent E u)
+    (hreg : ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)) :
+    IntegralBasisInLSpace T where
+  c := (T.exists_forall_mem_lSpace_nsmul_poleDivisor u hreg).choose
+  u := u
+  hu_indep := hu_indep
+  hu_mem := (T.exists_forall_mem_lSpace_nsmul_poleDivisor u hreg).choose_spec
+
+omit [FiniteDimensional E F] in
+theorem hasIntegralBasisInLSpace_of_regularOutside (T : TranscendenceTower K E F)
+    (h : HasIntegralBasisRegularOutside K E F T) :
+    HasIntegralBasisInLSpace K E F T := by
+  obtain ⟨u, hu_indep, hreg⟩ := h
+  exact ⟨IntegralBasisInLSpace.ofRegularOutside T u hu_indep hreg⟩
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+theorem linearIndependent_pow_mul {x : E} {n : ℕ} {u : Fin n → F}
+    (hx : LinearIndependent K (fun j : ℕ => x ^ j)) (hu : LinearIndependent E u) :
+    LinearIndependent K (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2) := by
+  have heq : (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2)
+      = (fun p : ℕ × Fin n => (x ^ p.1) • u p.2) := by
+    funext p
+    rw [Algebra.smul_def, map_pow]
+  rw [heq]
+  exact linearIndependent_smul (R := K) (S := E) (A := F) hx hu
+
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+def PoleDivisorPackage.ofTranscendenceTower (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    PoleDivisorPackage K F where
+  x := T.xF
+  B := T.poleDivisor
+  hB_eff := T.poleDivisor_nonneg
+  hx_mem := T.xF_mem_lSpace_poleDivisor
+  n := Module.finrank E F
+  hn_pos := Module.finrank_pos
+  degB_eq := T.degree_poleDivisor_eq_finrank
+  c := IB.c
+  u := IB.u
+  hu_mem := IB.hu_mem
+  lin_indep := linearIndependent_pow_mul T.hx_indep IB.hu_indep
+
+theorem hasPoleDivisorPackage_of_transcendenceTower
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    HasPoleDivisorPackage K F :=
+  ⟨PoleDivisorPackage.ofTranscendenceTower T IB⟩
+
+theorem hasPoleDivisorPackage_of_hasIntegralBasisInLSpace
+    (T : TranscendenceTower K E F) (h : HasIntegralBasisInLSpace K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_transcendenceTower T h.some
+
+theorem hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside
+    (T : TranscendenceTower K E F) (h : HasIntegralBasisRegularOutside K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisInLSpace T
+    (hasIntegralBasisInLSpace_of_regularOutside T h)
+
+end PrincipalDivisors
+
+theorem indexOfSpecialtyFinite_of_transcendenceTower [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem stichtenothGenusExists_of_transcendenceTower [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem gate_ofTranscendenceTower_n_eq [HasPrincipalDivisors K F] (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    (PoleDivisorPackage.ofTranscendenceTower T IB).n = Module.finrank E F := rfl
+
+theorem gate_ofTranscendenceTower_B_eq [HasPrincipalDivisors K F] (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    (PoleDivisorPackage.ofTranscendenceTower T IB).B = T.poleDivisor := rfl
+
+theorem gate_ofTranscendenceTower_x_transcendental [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    LinearIndependent K
+      (fun j : ℕ => T.xF ^ j *
+        (PoleDivisorPackage.ofTranscendenceTower T IB).u ⟨0, Module.finrank_pos⟩) :=
+  gate_x_transcendental_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem gate_degree_pullback_single_of_deg_eq [HasPrincipalDivisors K F]
+    (v : Place K E) (d : ℕ) (hd : v.deg = d) :
+    Divisor.degree (Divisor.pullback F (Finsupp.single v (1 : ℤ)))
+      = (Module.finrank E F : ℤ) * d := by
+  rw [Divisor.degree_pullback, Divisor.degree_single, hd]; ring
+
+theorem gate_stichtenothGenus_le_of_transcendenceTower [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T)
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    γ ≤ (Module.finrank E F : ℤ) * (IB.c - 1) + 1 :=
+  gate_stichtenothGenus_le_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB) h
+
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open Module
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~restrict_plac\
+  eOfPrime~placeOfPrime~comap_algebraMap_ne_top"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral {f : F}
+    (hf : IsIntegral w.toValuationSubring f) :
+    f ∈ w.toValuationSubring := by
+  obtain ⟨y, hy⟩ := IsIntegrallyClosed.isIntegral_iff.mp hf
+  exact hy ▸ y.2
+
+p2m_export "AlgebraicCurve.Place" "mem_of_isIntegral"
+
+theorem ord_nonneg_of_isIntegral {f : F} (hf : IsIntegral w.toValuationSubring f) :
+    0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral hf)
+
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral_of_algebraMap_mem {A : Type*}
+    [CommRing A] [Algebra A F]
+    (hA : ∀ a : A, algebraMap A F a ∈ w.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : f ∈ w.toValuationSubring := by
+  let : Algebra A w.toValuationSubring :=
+    ((algebraMap A F).codRestrict w.toValuationSubring.toSubring hA).toAlgebra
+  have : IsScalarTower A w.toValuationSubring F :=
+    IsScalarTower.of_algebraMap_eq fun a => rfl
+  exact w.mem_of_isIntegral hf.tower_top
+
+p2m_export "AlgebraicCurve.Place" "mem_of_isIntegral_of_algebraMap_mem"
+
+theorem ord_nonneg_of_isIntegral_of_algebraMap_mem {A : Type*} [CommRing A] [Algebra A F]
+    (hA : ∀ a : A, algebraMap A F a ∈ w.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : 0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral_of_algebraMap_mem hA hf)
+
+end Place
+
+section Bridge
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+variable {A : Type*} [CommRing A] [Algebra A E] [Algebra A F] [IsScalarTower A E F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+end Place
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral_of_restrict [Algebra.IsIntegral E F]
+    (w : Place K F)
+    {u : Place K E} (hw : w.restrict E = u)
+    (hA : ∀ a : A, algebraMap A E a ∈ u.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : f ∈ w.toValuationSubring := by
+  refine w.mem_of_isIntegral_of_algebraMap_mem (fun a => ?_) hf
+  rw [IsScalarTower.algebraMap_apply A E F, ← w.mem_restrict_iff, hw]
+  exact hA a
+
+end Place
+p2m_export "AlgebraicCurve" "Place.mem_of_isIntegral_of_restrict"
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.ord_nonneg_of_isIntegral_of_restrict
+    [Algebra.IsIntegral E F] (w : Place K F)
+    {u : Place K E} (hw : w.restrict E = u)
+    (hA : ∀ a : A, algebraMap A E a ∈ u.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : 0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral_of_restrict hw hA hf)
+
+end Place
+p2m_export "AlgebraicCurve" "Place.ord_nonneg_of_isIntegral_of_restrict"
+namespace TranscendenceTower
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF poleDivisor RegularOutside hx_indep hxreg v \
+  mk.injEq mk hvdeg x hxv"
+end TranscendenceTower
+namespace TranscendenceTower
+p2m_open_scoped "AlgebraicCurve.TranscendenceTower" in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.ord_nonneg_of_isIntegral_of_regularOutside
+    [Algebra.IsIntegral E F] (T : TranscendenceTower K E F) (hA : T.RegularOutside A)
+    {f : F} (hf : IsIntegral A f) :
+    ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord f := fun w hw =>
+  w.ord_nonneg_of_isIntegral_of_restrict rfl (hA _ hw) hf
+
+end TranscendenceTower
+p2m_export "AlgebraicCurve" "TranscendenceTower.ord_nonneg_of_isIntegral_of_regularOutside"
+end Bridge
+
+section Headline
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F]
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+theorem linearIndependent_reindex_basis {s : Finset F} (b : Basis s E F) :
+    LinearIndependent E (fun i : Fin (Module.finrank E F) =>
+      b ((Fintype.equivFinOfCardEq (Module.finrank_eq_card_basis b).symm).symm i)) :=
+  b.linearIndependent.comp _ (Equiv.injective _)
+
+theorem hasIntegralBasisRegularOutside_of_isFractionRing
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    HasIntegralBasisRegularOutside K E F T := by
+  obtain ⟨s, b, hint⟩ := FiniteDimensional.exists_is_basis_integral A E F
+  set e : Fin (Module.finrank E F) ≃ s :=
+    (Fintype.equivFinOfCardEq (Module.finrank_eq_card_basis b).symm).symm
+  refine ⟨fun i => b (e i), linearIndependent_reindex_basis b, fun i w hw => ?_⟩
+  exact T.ord_nonneg_of_isIntegral_of_regularOutside hA (hint (e i)) w hw
+
+theorem hasIntegralBasisRegularOutside_of_hasRegularFractionSubring
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    HasIntegralBasisRegularOutside K E F T := by
+  obtain ⟨A, hfrac, hreg⟩ := h
+  have : IsFractionRing A E := hfrac
+  exact hasIntegralBasisRegularOutside_of_isFractionRing (A := A) T
+    (fun u hu a => hreg u hu (a : E) a.property)
+
+theorem hasPoleDivisorPackage_of_isFractionRing [HasPrincipalDivisors K F]
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside T
+    (hasIntegralBasisRegularOutside_of_isFractionRing T hA)
+
+theorem stichtenothGenusExists_of_isFractionRing [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasPoleDivisorPackage
+    (hasPoleDivisorPackage_of_isFractionRing T hA)
+
+theorem hasPoleDivisorPackage_of_hasRegularFractionSubring [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside T
+    (hasIntegralBasisRegularOutside_of_hasRegularFractionSubring T h)
+
+theorem stichtenothGenusExists_of_hasRegularFractionSubring [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasPoleDivisorPackage
+    (hasPoleDivisorPackage_of_hasRegularFractionSubring T h)
+
+namespace TranscendenceTower
+p2m_open_scoped "AlgebraicCurve.TranscendenceTower" in
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.adjoin_x_regularOutside (T :
+  TranscendenceTower K E F) :
+    ∀ u : Place K E, u ≠ T.v →
+      ∀ a ∈ Algebra.adjoin K {T.x}, a ∈ u.toValuationSubring := by
+  intro u hu a ha
+  let S : Subalgebra K E :=
+    { u.toValuationSubring.toSubsemiring with
+      algebraMap_mem' := u.algebraMap_mem' }
+  suffices h : a ∈ S from h
+  refine Algebra.adjoin_le ?_ ha
+  intro y hy
+  rw [Set.mem_singleton_iff] at hy
+  subst hy
+  change T.x ∈ u.toValuationSubring
+  exact AlgebraicCurve.Place.mem_of_ord_nonneg u T.x_ne_zero (T.hxreg u hu)
+
+end TranscendenceTower
+p2m_export "AlgebraicCurve" "TranscendenceTower.adjoin_x_regularOutside"
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+theorem hasRegularFractionSubring_of_adjoin_x_isFractionRing
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    HasRegularFractionSubring K E F T :=
+  ⟨Algebra.adjoin K {T.x}, hfrac, T.adjoin_x_regularOutside⟩
+
+theorem hasIntegralBasisRegularOutside_of_adjoin_x_isFractionRing
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    HasIntegralBasisRegularOutside K E F T :=
+  hasIntegralBasisRegularOutside_of_hasRegularFractionSubring T
+    (hasRegularFractionSubring_of_adjoin_x_isFractionRing T hfrac)
+
+theorem stichtenothGenusExists_of_adjoin_x_isFractionRing [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasRegularFractionSubring T
+    (hasRegularFractionSubring_of_adjoin_x_isFractionRing T hfrac)
+
+end Headline
+
+section Gates
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem gate_mem_of_isIntegral_recovers_comap (w : Place K F) (E : Type*) [Field E]
+    [Algebra E F] [Algebra.IsIntegral E F]
+    (hE : ∀ a : E, algebraMap E F a ∈ w.toValuationSubring) (f : F) :
+    f ∈ w.toValuationSubring := by
+  let : Algebra E w.toValuationSubring :=
+    ((algebraMap E F).codRestrict w.toValuationSubring.toSubring hE).toAlgebra
+  have : IsScalarTower E w.toValuationSubring F :=
+    IsScalarTower.of_algebraMap_eq fun _ => rfl
+  exact w.mem_of_isIntegral (Algebra.IsIntegral.isIntegral (R := E) f).tower_top
+
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+
+theorem gate_bridge_recovers_hxreg [Algebra.IsIntegral E F]
+    (T : TranscendenceTower K E F) (w : Place K F) (hw : w.restrict E ≠ T.v) :
+    0 ≤ w.ord T.xF := by
+  rw [TranscendenceTower.xF, Place.ord_restrict]
+  exact mul_nonneg (Int.natCast_nonneg _) (T.hxreg _ hw)
+
+theorem gate_regularOutside_mono (T : TranscendenceTower K E F) {A A' : Subalgebra K E}
+    (hle : A ≤ A')
+    (hA' : ∀ u : Place K E, u ≠ T.v → ∀ a ∈ A', a ∈ u.toValuationSubring) :
+    ∀ u : Place K E, u ≠ T.v → ∀ a ∈ A, a ∈ u.toValuationSubring :=
+  fun u hu a ha => hA' u hu a (hle ha)
+
+theorem gate_bot_regularOutside (T : TranscendenceTower K E F) :
+    ∀ u : Place K E, u ≠ T.v → ∀ a ∈ (⊥ : Subalgebra K E), a ∈ u.toValuationSubring := by
+  intro u _ a ha
+  obtain ⟨c, rfl⟩ := Algebra.mem_bot.mp ha
+  exact u.algebraMap_mem' c
+
+theorem gate_adjoin_x_not_regular_at_v (T : TranscendenceTower K E F) :
+    ¬ ∀ a ∈ Algebra.adjoin K {T.x}, a ∈ T.v.toValuationSubring := by
+  intro h
+  have hx := AlgebraicCurve.Place.ord_nonneg_of_mem T.v (h T.x (Algebra.subset_adjoin rfl))
+  rw [T.hxv] at hx
+  exact absurd hx (by decide)
+
+end Gates
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open Module Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+section Transcendental
+
+variable {K A : Type*} [CommRing K] [CommRing A] [Algebra K A]
+
+theorem linearIndependent_pow_of_transcendental {x : A} (hx : Transcendental K x) :
+    LinearIndependent K (fun j : ℕ => x ^ j) := by
+  have hinj : Function.Injective (Polynomial.aeval x : K[X] →ₐ[K] A) :=
+    transcendental_iff_injective.mp hx
+  have hXj : LinearIndependent K (fun j : ℕ => (X : K[X]) ^ j) := by
+    have hb := (Polynomial.basisMonomials K).linearIndependent
+    simp only [Polynomial.coe_basisMonomials] at hb
+    convert hb using 2 with j
+    exact (Polynomial.monomial_one_right_eq_X_pow j).symm
+  have heq : (fun j : ℕ => x ^ j)
+      = (fun j : ℕ => (Polynomial.aeval x : K[X] →ₐ[K] A) (X ^ j)) := by
+    funext j; simp
+  rw [heq]
+  exact hXj.map' (Polynomial.aeval x).toLinearMap
+    (LinearMap.ker_eq_bot_of_injective hinj)
+
+theorem transcendental_of_linearIndependent_pow {x : A}
+    (hx : LinearIndependent K (fun j : ℕ => x ^ j)) :
+    Transcendental K x := by
+  rw [transcendental_iff]
+  intro p hp
+  rw [Polynomial.aeval_eq_sum_range, ← Fin.sum_univ_eq_sum_range] at hp
+  ext j
+  rcases lt_or_ge j (p.natDegree + 1) with hj | hj
+  · exact (Fintype.linearIndependent_iff.mp
+      (hx.comp (Fin.val : Fin (p.natDegree + 1) → ℕ) Fin.val_injective))
+      (fun i => p.coeff i) hp ⟨j, hj⟩
+  · exact p.coeff_eq_zero_of_natDegree_lt (Nat.lt_of_succ_le hj)
+
+end Transcendental
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "algebraMap_mem_ofHeightOneSpectrum placeInfty \
+  ord_placeInfty deg_placeInfty eq_ofHeightOneSpectrum_or_eq_placeInfty"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+
+theorem ord_placeInfty_X : (placeInfty K).ord (RatFunc.X : RatFunc K) = -1 := by
+  rw [ord_placeInfty (K := K) RatFunc.X_ne_zero, RatFunc.intDegree_X]
+
+theorem algebraMap_polynomial_mem_of_ne_placeInfty
+    {u : Place K (RatFunc K)} (hu : u ≠ placeInfty K) (q : K[X]) :
+    algebraMap K[X] (RatFunc K) q ∈ u.toValuationSubring := by
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty u with ⟨w, hw⟩ | hw
+  · subst hw; exact algebraMap_mem_ofHeightOneSpectrum K w q
+  · exact absurd hw hu
+
+theorem ord_X_nonneg_of_ne_placeInfty
+    {u : Place K (RatFunc K)} (hu : u ≠ placeInfty K) :
+    0 ≤ u.ord (RatFunc.X : RatFunc K) := by
+  rw [← RatFunc.algebraMap_X]
+  exact AlgebraicCurve.Place.ord_nonneg_of_mem u (algebraMap_polynomial_mem_of_ne_placeInfty K hu
+    Polynomial.X)
+
+variable (F : Type*) [Field F] [Algebra K F] [Algebra (RatFunc K) F]
+  [IsScalarTower K (RatFunc K) F]
+
+def transcendenceTower : TranscendenceTower K (RatFunc K) F where
+  x := RatFunc.X
+  hx_indep := linearIndependent_pow_of_transcendental RatFunc.transcendental_X
+  v := placeInfty K
+  hvdeg := deg_placeInfty K
+  hxv := ord_placeInfty_X K
+  hxreg := fun _ hu => ord_X_nonneg_of_ne_placeInfty K hu
+
+@[scoped simp]
+theorem transcendenceTower_x : (transcendenceTower K F).x = RatFunc.X := rfl
+
+@[scoped simp]
+theorem transcendenceTower_v : (transcendenceTower K F).v = placeInfty K := rfl
+
+omit [DecidableEq (RatFunc K)] in
+theorem aeval_X_eq_algebraMap (q : K[X]) :
+    (Polynomial.aeval (R := K) (RatFunc.X : RatFunc K)) q
+      = algebraMap K[X] (RatFunc K) q := by
+  have hext : (Polynomial.aeval (R := K) (RatFunc.X : RatFunc K))
+      = IsScalarTower.toAlgHom K K[X] (RatFunc K) :=
+    Polynomial.algHom_ext (by simp [RatFunc.algebraMap_X])
+  rw [hext]; rfl
+
+omit [DecidableEq (RatFunc K)] in
+theorem algebraMap_polynomial_mem_adjoin_X (q : K[X]) :
+    algebraMap K[X] (RatFunc K) q ∈ Algebra.adjoin K {(RatFunc.X : RatFunc K)} := by
+  rw [Algebra.adjoin_singleton_eq_range_aeval]
+  exact ⟨q, aeval_X_eq_algebraMap K q⟩
+
+omit [DecidableEq (RatFunc K)] in
+theorem isFractionRing_adjoin_X :
+    IsFractionRing (Algebra.adjoin K {(RatFunc.X : RatFunc K)}) (RatFunc K) := by
+  refine IsFractionRing.of_field _ _ fun z => ?_
+  refine ⟨⟨algebraMap K[X] (RatFunc K) z.num, algebraMap_polynomial_mem_adjoin_X K z.num⟩,
+    ⟨algebraMap K[X] (RatFunc K) z.denom, algebraMap_polynomial_mem_adjoin_X K z.denom⟩, ?_⟩
+  change z = algebraMap K[X] (RatFunc K) z.num / algebraMap K[X] (RatFunc K) z.denom
+  exact z.num_div_denom.symm
+
+theorem hasRegularFractionSubring :
+    HasRegularFractionSubring K (RatFunc K) F (transcendenceTower K F) :=
+  hasRegularFractionSubring_of_adjoin_x_isFractionRing
+    (transcendenceTower K F) (isFractionRing_adjoin_X K)
+
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+
+theorem hasIntegralBasisRegularOutside :
+    HasIntegralBasisRegularOutside K (RatFunc K) F (transcendenceTower K F) :=
+  hasIntegralBasisRegularOutside_of_adjoin_x_isFractionRing
+    (transcendenceTower K F) (isFractionRing_adjoin_X K)
+
+section PrincipalDivisors
+
+variable [HasPrincipalDivisors K F]
+
+omit [DecidableEq (RatFunc K)] in
+theorem hasPoleDivisorPackage_of_ratFunc_tower :
+    HasPoleDivisorPackage K F := by
+  classical
+  exact
+    hasPoleDivisorPackage_of_hasRegularFractionSubring
+      (transcendenceTower K F) (hasRegularFractionSubring K F)
+
+end PrincipalDivisors
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+omit [DecidableEq (RatFunc K)] in
+theorem stichtenothGenusExists_of_ratFunc_tower :
+    StichtenothGenusExists K F := by
+  classical
+  exact
+    stichtenothGenusExists_of_adjoin_x_isFractionRing
+      (transcendenceTower K F) (isFractionRing_adjoin_X K)
+
+omit [DecidableEq (RatFunc K)] in
+theorem indexOfSpecialtyFinite_of_ratFunc_tower :
+    IndexOfSpecialtyFinite K F := by
+  classical
+  exact
+    indexOfSpecialtyFinite_of_stichtenothGenusExists
+      (stichtenothGenusExists_of_ratFunc_tower K F)
+
+end RationalFunctionField
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open Module Polynomial IsDedekindDomain
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "algebraMap_mem_ofHeightOneSpectrum placeInfty \
+  ord_placeInfty deg_placeInfty eq_ofHeightOneSpectrum_or_eq_placeInfty"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+variable (F : Type*) [Field F] [Algebra K F] [Algebra (RatFunc K) F]
+  [IsScalarTower K (RatFunc K) F]
+
+section LyingOver
+
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+
+omit [DecidableEq (RatFunc K)] in
+omit [DecidableEq (RatFunc K)] in
+private theorem _root_.AlgebraicCurve.RationalFunctionField.exists_restrict_eq (v : Place K (RatFunc
+  K)) :
+    ∃ w : Place K F, w.restrict (RatFunc K) = v :=
+  Place.exists_restrict_eq v
+
+p2m_export "AlgebraicCurve.RationalFunctionField" "exists_restrict_eq"
+
+omit [DecidableEq (RatFunc K)] in
+theorem nonempty_place_of_ratFunc_tower : Nonempty (Place K F) := by
+  classical
+  exact
+    (exists_restrict_eq K F (placeInfty K)).nonempty
+
+end LyingOver
+
+omit [DecidableEq (RatFunc K)] [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F] in
+theorem finiteDimensional_lSpace_zero_of_constantsAreBase (hC : ConstantsAreBase K F) :
+    FiniteDimensional K (LSpace (0 : Divisor K F)) := by
+  rw [show LSpace (0 : Divisor K F) = LinearMap.range (Algebra.linearMap K F) from hC]
+  exact LinearMap.finiteDimensional_range _
+
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+variable [IsCurveOver K F]
+
+omit [DecidableEq (RatFunc K)] in
+theorem stichtenothGenusExists_port (hC : ConstantsAreBase K F) :
+    StichtenothGenusExists K F := by
+  classical
+  exact
+    haveI := nonempty_place_of_ratFunc_tower K F
+    haveI := finiteDimensional_lSpace_zero_of_constantsAreBase K F hC
+    stichtenothGenusExists_of_ratFunc_tower K F
+
+omit [DecidableEq (RatFunc K)] in
+theorem indexOfSpecialtyFinite (hC : ConstantsAreBase K F) :
+    IndexOfSpecialtyFinite K F := by
+  classical
+  exact
+    indexOfSpecialtyFinite_of_stichtenothGenusExists (stichtenothGenusExists_port K F hC)
+
+omit [DecidableEq (RatFunc K)] in
+theorem riemannGenusBounded (hC : ConstantsAreBase K F) : RiemannGenusBounded K F := by
+  classical
+  exact
+    haveI := nonempty_place_of_ratFunc_tower K F
+    haveI := finiteDimensional_lSpace_zero_of_constantsAreBase K F hC
+    riemannGenusBounded_of_poleDivisorPackage (hasPoleDivisorPackage_of_ratFunc_tower K F).some
+
+end RationalFunctionField
+end AlgebraicCurve
+end
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg\
+  " in
+open _root_.P2MW.S_AlgebraicCurve_RationalFunctionField_stichtenothGenusExists.AlgebraicCurve
+  Polynomial in
+theorem solution (K : Type*) [Field K] (F : Type*) [Field F] [Algebra K F]
+    [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F] [FiniteDimensional (RatFunc K) F]
+    [Algebra.IsSeparable (RatFunc K) F] [IsCurveOver K F] (hC : ConstantsAreBase K F) :
+    StichtenothGenusExists K F := by
+  classical
+  exact
+    AlgebraicCurve.RationalFunctionField.stichtenothGenusExists_port (K := K) (F := F) (hC := hC)
+
+end S_AlgebraicCurve_RationalFunctionField_stichtenothGenusExists
+end P2MW
+export P2MW.S_AlgebraicCurve_RationalFunctionField_stichtenothGenusExists (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace AlgebraicCurve
+theorem RationalFunctionField.stichtenothGenusExists (K : Type*) [Field K]
+    (F : Type*) [Field F] [Algebra K F] [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F] [IsCurveOver K F]
+    (hC : ConstantsAreBase K F) :
+    StichtenothGenusExists K F := by
+  classical
+  exact
+    solution K F hC
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_stichtenothGenusExists_of_ratFunc_tower.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_stichtenothGenusExists_of_ratFunc_tower.lean
new file mode 100644
index 0000000000..cf63793bdf
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_stichtenothGenusExists_of_ratFunc_tower.lean
@@ -0,0 +1,2689 @@
+/-
+Based on Prove2Me node AlgebraicCurve.RationalFunctionField.stichtenothGenusExists_of_ratFunc_tower
+(9d403461-ddf0-59f2-9bae-4b9855c6303a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 0d3c21b3-0994-5116-ae26-d328293dd85f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import Mathlib.Algebra.Polynomial.Basis
+import Mathlib.Data.Int.LeastGreatest
+import Mathlib.LinearAlgebra.Matrix.FiniteDimensional
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PoleDivisorPackage
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_restrict_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_placeInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Riemann's theorem over a rational function subfield
+
+Theorem statement: `AlgebraicCurve.RationalFunctionField.stichtenothGenusExists_of_ratFunc_tower`
+(`9d403461-ddf0-59f2-9bae-4b9855c6303a`), by Claude, 2026-09-05.
+
+Proof: submission `0d3c21b3-0994-5116-ae26-d328293dd85f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $F$ be a field that is simultaneously an algebra over $K$ and over the
+rational function field $\mathrm{RatFunc}\,K$, compatibly (a scalar tower $K \subseteq
+\mathrm{RatFunc}\,K \subseteq F$), with $F$ finite-dimensional and separable over
+$\mathrm{RatFunc}\,K$. Assume the principal divisor hypothesis [`AlgebraicCurve.HasPrincipalDivisors
+K F`](def/AlgebraicCurve_DivisorClassGroup.html#L217): every $f \in F^{\times}$ admits a finitely
+supported divisor $D : \mathrm{Place}\,K\,F \to \mathbb{Z}$ with $D(v) = v.\mathrm{ord}(f)$ at every
+place $v$ and $\deg D = 0$, where a place is a valuation subring of $F$ containing the image of $K$,
+distinct from $F$ itself and a principal ideal ring, and $\deg$ is the sum of the coefficients
+weighted by the residue degrees. Assume also [`AlgebraicCurve.IsCurveOver K
+F`](def/AlgebraicCurve_IsCurveOver.html#L15): the above, together with finiteness of every residue
+field $v.\mathrm{ResidueField}$ over $K$ and freeness of $\Omega_{F/K}$ over $F$ of rank $1$.
+Finally assume that $F$ has at least one place and that the Riemann–Roch space $L(0) = \{f \in F :
+v(f) \le 1 \text{ for all } v\}$ is finite-dimensional over $K$. The conclusion is
+[`AlgebraicCurve.StichtenothGenusExists K F`](def/AlgebraicCurve_AdelicIndex.html#L419): $F$ has a
+place, $L(0)$ is finite-dimensional over $K$, and there exist $\gamma \in \mathbb{Z}$ and a divisor
+$D_0$ such that $L(D_0)$ is finite-dimensional over $K$, $\deg D_0 - \ell(D_0) = \gamma - 1$, and
+$\deg D - \ell(D) \le \gamma - 1$ for every divisor $D$.
+
+This is Riemann's theorem in Stichtenoth's formulation: for a curve presented as a finite separable
+extension of $K(X)$, the quantity $\deg D - \ell(D)$ is bounded above over all divisors and attains
+its supremum, so that a genus $\gamma$ with $\ell(D) \ge \deg D + 1 - \gamma$ for all $D$, with
+equality at some $D_0$, exists. It supplies the `StichtenothGenusExists` hypothesis for the Riemann
+index formula and the Riemann–Roch results used for curves given over a rational function field, and
+is invoked for two-chart integral models.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_stichtenothGenusExists_of_ratFunc_tower.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_f94f10e8
+
+
+open Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "degree degree_single principal smul_def smul_apply pullback \
+  pullback_apply degree_pullback"
+end Divisor
+variable {D : Divisor K F}
+p2m_open_scoped "AlgebraicCurve.Divisor" in
+theorem Divisor.degree_nonneg_of_nonneg [IsCurveOver K F]
+    {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) : 0 ≤ Divisor.degree D := by
+  rw [Divisor.degree_eq_sum_support]
+  exact Finset.sum_nonneg fun v _ => mul_nonneg (hD v) (Int.natCast_nonneg _)
+theorem lSpace_eq_bot_of_degree_neg [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) : LSpace D = ⊥ := by
+  rw [eq_bot_iff]
+  intro f hf
+  rw [Submodule.mem_bot]
+  by_contra hf0
+  obtain ⟨P, hPord, hPdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+  have heff : ∀ v : Place K F, 0 ≤ (P + D) v := by
+    intro v
+    rw [Finsupp.add_apply, hPord]
+    rcases mem_lSpace_iff_ord.mp hf with rfl | h
+    · exact absurd rfl hf0
+    · linarith [h v]
+  have hdegPD : 0 ≤ Divisor.degree (P + D) := Divisor.degree_nonneg_of_nonneg heff
+  rw [map_add, hPdeg, zero_add] at hdegPD
+  exact absurd hdegPD (not_le.mpr hD)
+end AlgebraicCurve
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~restrict_plac\
+  eOfPrime~placeOfPrime~comap_algebraMap_ne_top"
+
+variable (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mk_mem_maximalIdeal_iff {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    (⟨f, hf⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring
+      ↔ f = 0 ∨ 0 < v.ord f := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  constructor
+  · intro hu
+    rcases eq_or_ne f 0 with rfl | hf0
+    · exact Or.inl rfl
+    · refine Or.inr ?_
+      rcases lt_or_eq_of_le (AlgebraicCurve.Place.ord_nonneg_of_mem v hf) with h | h
+      · exact h
+      · exfalso
+        apply hu
+        rw [← v.adicValuation_coe_eq_one_iff ⟨f, hf⟩]
+        change v.adicValuation f = 1
+        rw [v.adicValuation_eq_exp_neg_ord hf0, ← h, neg_zero, WithZero.exp_zero]
+  · intro h hu
+    have hne : f ≠ 0 := fun h0 => hu.ne_zero (Subtype.ext h0)
+    have h0 : v.ord f = 0 := by
+      obtain ⟨u, hu'⟩ := hu
+      have hcoe : f = ((u : v.toValuationSubring) : F) := by rw [hu']
+      rw [hcoe]; exact v.ord_coe_unit u
+    rcases h with rfl | hpos
+    · exact hne rfl
+    · omega
+
+p2m_export "AlgebraicCurve.Place" "mk_mem_maximalIdeal_iff"
+end Place
+
+theorem ell_le_ell_sub_single_add_deg [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    ell D ≤ ell (D - Finsupp.single P 1) + P.deg := by
+  classical
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible P.toValuationSubring
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by
+    simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := by
+    intro g hg
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ g : F, g ∈ LSpace D → t ^ (D P) * g ∈ P.toValuationSubring := by
+    intro g hg
+    rcases eq_or_ne g 0 with rfl | hg0
+    · simp
+    · refine AlgebraicCurve.Place.mem_of_ord_nonneg P (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have := (mem_lSpace_iff_ord.mp hg).resolve_left hg0 P
+      linarith
+  let ψ : LSpace D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun f => ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+      map_add' := by intro f g; apply Subtype.ext; push_cast; ring
+      map_smul' := by
+        intro c f; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap]
+        ring }
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : LSpace D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ f : LSpace D, φ f = 0 ↔
+      (⟨t ^ (D P) * (f : F), hmem _ f.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := by
+    intro f
+    rw [show φ f = IsLocalRing.residue P.toValuationSubring ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+          from hres (ψ f),
+      IsLocalRing.residue_eq_zero_iff]
+  have hED : E ≤ D := by
+    rw [Finsupp.le_def]; intro v; rw [hE, Finsupp.sub_apply]
+    have : (0 : ℤ) ≤ Finsupp.single P 1 v := by
+      rcases eq_or_ne v P with rfl | hv
+      · simp
+      · simp [Finsupp.single_eq_of_ne hv]
+    linarith
+  have hsub : LSpace E ≤ LSpace D := lSpace_mono hED
+  have hker : LinearMap.ker φ = (LSpace E).comap (LSpace D).subtype := by
+    ext f
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi f, P.mk_mem_maximalIdeal_iff]
+    rcases eq_or_ne (f : F) 0 with hf0 | hf0
+    · simp only [hf0, mul_zero, true_or, true_iff]
+      exact (LSpace E).zero_mem
+    · rw [mem_lSpace_iff_ord]
+      have hfD := (mem_lSpace_iff_ord.mp f.2).resolve_left hf0
+      constructor
+      · rintro (h | h)
+        · exact absurd h (mul_ne_zero htn0 hf0)
+        · refine Or.inr (fun v => ?_)
+          rcases eq_or_ne v P with rfl | hv
+          · rw [hEP]; rw [hordmul hf0] at h; omega
+          · rw [hEv v hv]; exact hfD v
+      · rintro (h | h)
+        · exact absurd h hf0
+        · refine Or.inr ?_
+          have hP := h P
+          rw [hEP] at hP
+          rw [hordmul hf0]; omega
+  have hkerfin : finrank K (LinearMap.ker φ) = ell E := by
+    rw [hker, LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe hsub)]
+  have hquot : finrank K (LSpace D ⧸ LinearMap.ker φ) ≤ P.deg := by
+    rw [LinearEquiv.finrank_eq φ.quotKerEquivRange]
+    exact Submodule.finrank_le (LinearMap.range φ)
+  by_cases hfin : FiniteDimensional K (LSpace D)
+  · have := hfin
+    have hrn := Submodule.finrank_quotient_add_finrank (LinearMap.ker φ)
+    rw [hkerfin] at hrn
+    have hb : ell D = finrank K (LSpace D) := rfl
+    omega
+  · have h0 : ell D = 0 := by rw [ell]; exact finrank_of_infinite_dimensional hfin
+    omega
+
+theorem one_le_deg [IsCurveOver K F] (P : Place K F) : 1 ≤ P.deg := by
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  exact Module.finrank_pos
+
+theorem ell_le_degree_add_ellZero [IsCurveOver K F] {D : Divisor K F}
+    (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D : Divisor K F, (∀ v, 0 ≤ D v) →
+      (Divisor.degree D).toNat = m →
+      (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) by
+    exact H (Divisor.degree D).toNat D hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D hD hm
+    by_cases hD0 : D = 0
+    · subst hD0; simp
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ D P := by
+        have hne : D P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hD P; omega
+      set E : Divisor K F := D - Finsupp.single P 1 with hE
+      have hEeff : ∀ v, 0 ≤ E v := by
+        intro v; rw [hE, Finsupp.sub_apply]
+        rcases eq_or_ne v P with rfl | hv
+        · rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have hdegE : Divisor.degree E = Divisor.degree D - P.deg := by
+        rw [hE, map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hDnn : 0 ≤ Divisor.degree D := Divisor.degree_nonneg_of_nonneg hD
+      have hEnn : 0 ≤ Divisor.degree E := Divisor.degree_nonneg_of_nonneg hEeff
+      have hmlt : (Divisor.degree E).toNat < m := by rw [← hm]; omega
+      have hIH := IH _ hmlt E hEeff rfl
+      have hstep := ell_le_ell_sub_single_add_deg D P
+      rw [← hE] at hstep
+      have hstep' : (ell D : ℤ) ≤ (ell E : ℤ) + P.deg := by exact_mod_cast hstep
+      rw [hdegE] at hIH
+      linarith
+
+theorem ell_le_degree_add_one_of_effective [IsCurveOver K F]
+    (hC : ConstantsAreBase K F) {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  have h := ell_le_degree_add_ellZero hD
+  rw [ell_zero_eq_one_of_constantsAreBase hC] at h
+  exact_mod_cast h
+
+def lSpaceShiftEquiv (D : Divisor K F) {g : F} (hg : g ≠ 0)
+    {Dg : Divisor K F} (hDg : ∀ v, Dg v = v.ord g) :
+    LSpace D ≃ₗ[K] LSpace (D + Dg) where
+  toFun h := ⟨(h : F) * g⁻¹, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (h : F) 0 with hh0 | hh0
+    · left; rw [hh0, zero_mul]
+    · right; intro v
+      rw [Finsupp.add_apply, hDg, v.ord_mul hh0 (inv_ne_zero hg), v.ord_inv]
+      have := (mem_lSpace_iff_ord.mp h.2).resolve_left hh0 v
+      linarith⟩
+  invFun k := ⟨(k : F) * g, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (k : F) 0 with hk0 | hk0
+    · left; rw [hk0, zero_mul]
+    · right; intro v
+      have := (mem_lSpace_iff_ord.mp k.2).resolve_left hk0 v
+      rw [Finsupp.add_apply, hDg] at this
+      rw [v.ord_mul hk0 hg]
+      linarith⟩
+  map_add' h₁ h₂ := by apply Subtype.ext; push_cast; ring
+  map_smul' c h := by
+    apply Subtype.ext
+    simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def]
+    ring
+  left_inv h := by
+    apply Subtype.ext
+    change (h : F) * g⁻¹ * g = (h : F)
+    rw [mul_assoc, inv_mul_cancel₀ hg, mul_one]
+  right_inv k := by
+    apply Subtype.ext
+    change (k : F) * g * g⁻¹ = (k : F)
+    rw [mul_assoc, mul_inv_cancel₀ hg, mul_one]
+
+theorem ell_le_degree_add_one [IsCurveOver K F] (hC : ConstantsAreBase K F)
+    {D : Divisor K F} (hD : 0 ≤ Divisor.degree D) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  rcases eq_or_ne (ell D) 0 with h0 | h0
+  · rw [h0]; push_cast; linarith
+  · have hbot : LSpace D ≠ ⊥ := fun h => h0 (by rw [ell, h, finrank_bot])
+    obtain ⟨g, hgL, hg0⟩ := (Submodule.ne_bot_iff _).mp hbot
+    obtain ⟨Dg, hDgord, hDgdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) g hg0
+    have heff : ∀ v, 0 ≤ (D + Dg) v := by
+      intro v; rw [Finsupp.add_apply, hDgord]
+      have := (mem_lSpace_iff_ord.mp hgL).resolve_left hg0 v
+      linarith
+    have hdeg : Divisor.degree (D + Dg) = Divisor.degree D := by
+      rw [map_add, hDgdeg, add_zero]
+    have hell : ell D = ell (D + Dg) :=
+      LinearEquiv.finrank_eq (lSpaceShiftEquiv D hg0 hDgord)
+    have hfin := ell_le_degree_add_one_of_effective hC heff
+    rw [hdeg] at hfin
+    rw [hell]; exact hfin
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion factor mk mem_bot subtype_injective \
+  mk.injEq Quotient.subsingleton_iff Quotient.mk span restrictScalars inhabited \
+  inclusion_injective comapSubtypeEquivOfLe mem_comap finrank_quotient_add_finrank mem_top \
+  Quotient.equiv mkQ mem_map coe_subtype map_smul' zero one quotientQuotientEquivQuotient \
+  coe_eq_zero finrank_le range_subtype Quotient.mk_surjective map mem_inf mem_sup \
+  Quotient.mk_eq_zero topEquiv map_injective_of_injective comap_subtype_self mapQ subsingleton_iff \
+  module smul_def mk_eq_zero coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono \
+  map_sup coe_zero smul"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+def nestedComapMapMkQEquiv {A B C : Submodule K X} (_hAB : A ≤ B) (hBC : B ≤ C) :
+    ((B.comap C.subtype).map (A.comap C.subtype).mkQ : Submodule K _)
+      ≃ₗ[K] B ⧸ A.comap B.subtype := by
+  set S := A.comap C.subtype with hS
+  set T := B.comap C.subtype with hT
+  let ψ : (T : Type _) →ₗ[K] (C ⧸ S) := S.mkQ ∘ₗ T.subtype
+  have hker : LinearMap.ker ψ = S.comap T.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = T.map S.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let e1 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (T.map S.mkQ : Submodule K _) :=
+    (Submodule.Quotient.equiv _ (LinearMap.ker ψ) (LinearEquiv.refl K T)
+        (by rw [hker]; simp)).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have hmap : (S.comap T.subtype).map
+      (Submodule.comapSubtypeEquivOfLe hBC : (T : Type _) →ₗ[K] B) = A.comap B.subtype := by
+    ext ⟨b, hb⟩
+    simp only [mem_map, mem_comap, Submodule.coe_subtype, hS]
+    constructor
+    · rintro ⟨⟨⟨x, hxC⟩, hxB⟩, hxA, hxeq⟩
+      have hx : x = b := congrArg Subtype.val hxeq
+      subst hx; exact hxA
+    · intro hbA
+      exact ⟨⟨⟨b, hBC hb⟩, hb⟩, hbA, rfl⟩
+  let e2 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (B ⧸ A.comap B.subtype) :=
+    Submodule.Quotient.equiv _ _ (Submodule.comapSubtypeEquivOfLe hBC) hmap
+  exact e1.symm.trans e2
+
+theorem finrank_quotient_chain {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCB : Module.Finite K (C ⧸ B.comap C.subtype)]
+    [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (C ⧸ A.comap C.subtype) ∧
+      finrank K (C ⧸ A.comap C.subtype)
+        = finrank K (C ⧸ B.comap C.subtype) + finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (T.map S.mkQ : Submodule K _) := Module.Finite.equiv eK.symm
+  have : Module.Finite K ((C ⧸ S) ⧸ T.map S.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (C ⧸ S) := Module.Finite.of_submodule_quotient (T.map S.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+theorem finrank_quotient_chain' {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCA : Module.Finite K (C ⧸ A.comap C.subtype)] :
+    Module.Finite K (C ⧸ B.comap C.subtype) ∧
+      finrank K (C ⧸ B.comap C.subtype)
+        = finrank K (C ⧸ A.comap C.subtype) - finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (C ⧸ T) := Module.Finite.equiv e3
+  refine ⟨this, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+def adeleBddQuotSingleEquivResidueField (D : Divisor K F) (P : Place K F) :
+    (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+      ≃ₗ[K] P.ResidueField := by
+  classical
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  let π : P.toValuationSubring :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose
+  have hπ : Irreducible π :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose_spec
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := fun {g} hg => by
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ α : Place K F → F, α ∈ adeleBdd D → t ^ (D P) * α P ∈ P.toValuationSubring := by
+    intro α hα
+    rcases eq_or_ne (α P) 0 with hg0 | hg0
+    · simp [hg0]
+    · refine AlgebraicCurve.Place.mem_of_ord_nonneg P (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have h := hα P
+      rw [P.adicValuation_eq_exp_neg_ord hg0, WithZero.exp_le_exp] at h
+      linarith
+  let ψ : adeleBdd D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun α => ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩
+      map_add' := by
+        intro α β; apply Subtype.ext
+        simp only [Submodule.coe_add, Pi.add_apply]
+        push_cast; ring
+      map_smul' := by
+        intro c α; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap, Pi.smul_apply]
+        ring }
+  have hψ_apply : ∀ α : adeleBdd D,
+      (ψ α : F) = t ^ (D P) * (α : Place K F → F) P := fun α => rfl
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : adeleBdd D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ α : adeleBdd D, φ α = 0 ↔
+      (⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := fun α => by
+    rw [show φ α = IsLocalRing.residue P.toValuationSubring
+            ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ from hres (ψ α),
+      IsLocalRing.residue_eq_zero_iff]
+  have hker : LinearMap.ker φ = (adeleBdd E).comap (adeleBdd D).subtype := by
+    ext α
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi α, P.mk_mem_maximalIdeal_iff, mem_adeleBdd]
+    have hαD := α.2
+    constructor
+    · rintro (h | h) v
+      · have hα0 : (α : Place K F → F) P = 0 := by
+          rcases mul_eq_zero.mp h with h' | h'
+          · exact absurd h' htn0
+          · exact h'
+        by_cases hv : v = P
+        · subst v; rw [hα0, Valuation.map_zero]; exact zero_le
+        · rw [hEv v hv]; exact hαD v
+      · by_cases hv : v = P
+        · subst v
+          rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+          · rw [hα0, Valuation.map_zero]; exact zero_le
+          · rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP]
+            rw [hordmul hα0] at h; omega
+        · rw [hEv v hv]; exact hαD v
+    · intro h
+      rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+      · left; rw [hα0, mul_zero]
+      · right
+        have hP := h P
+        rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP] at hP
+        rw [hordmul hα0]; omega
+  have hsurj : Function.Surjective φ := by
+    intro c
+    obtain ⟨cl, hcl⟩ := IsLocalRing.residue_surjective (R := P.toValuationSubring) c
+    set f : F := (cl : F) * t ^ (-(D P)) with hf
+    have hαD : Pi.single P f ∈ adeleBdd D := by
+      intro v
+      by_cases hv : v = P
+      · subst v
+        simp only [Pi.single_eq_same]
+        rcases eq_or_ne (cl : F) 0 with hc0 | hc0
+        · rw [hf, hc0, zero_mul, Valuation.map_zero]; exact zero_le
+        · have hf0 : f ≠ 0 := by rw [hf]; exact mul_ne_zero hc0 (zpow_ne_zero _ ht0)
+          rw [P.adicValuation_eq_exp_neg_ord hf0, WithZero.exp_le_exp]
+          rw [hf, P.ord_mul hc0 (zpow_ne_zero _ ht0), P.ord_zpow, ht1, mul_one]
+          have hclnn := AlgebraicCurve.Place.ord_nonneg_of_mem P cl.2
+          linarith
+      · rw [Pi.single_eq_of_ne hv, Valuation.map_zero]; exact zero_le
+    refine ⟨⟨Pi.single P f, hαD⟩, ?_⟩
+    change res (ψ ⟨Pi.single P f, hαD⟩) = c
+    rw [hres]
+    rw [show (ψ ⟨Pi.single P f, hαD⟩ : P.toValuationSubring) = cl from ?_, hcl]
+    apply Subtype.ext
+    rw [hψ_apply]
+    change t ^ (D P) * (Pi.single P f : Place K F → F) P = (cl : F)
+    rw [show (Pi.single P f : Place K F → F) P = f from Pi.single_eq_same _ _, hf,
+      mul_comm (cl : F), ← mul_assoc, ← zpow_add₀ ht0, add_neg_cancel, zpow_zero, one_mul]
+  exact (Submodule.Quotient.equiv _ _ (LinearEquiv.refl K _) (by rw [← hker]; simp)).trans
+    (φ.quotKerEquivOfSurjective hsurj)
+
+theorem finrank_adeleBdd_quotient_single [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    Module.Finite K
+        (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype) ∧
+      finrank K
+          (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+        = P.deg := by
+  have := IsCurveOver.finite_residueField (K := K) P
+  exact ⟨Module.Finite.equiv (adeleBddQuotSingleEquivResidueField D P).symm,
+    (adeleBddQuotSingleEquivResidueField D P).finrank_eq⟩
+
+theorem finrank_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+      (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+        = Divisor.degree D₂ - Divisor.degree D₁ := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D₁ D₂ : Divisor K F, D₁ ≤ D₂ →
+      (Divisor.degree (D₂ - D₁)).toNat = m →
+      Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+        (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+          = Divisor.degree D₂ - Divisor.degree D₁ from
+    H _ D₁ D₂ hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D₁ D₂ hD hm
+    have hEeff : ∀ v, 0 ≤ (D₂ - D₁) v := fun v => by
+      rw [Finsupp.sub_apply]; have := hD v; omega
+    by_cases hD0 : D₂ - D₁ = 0
+    · have hD12 : D₁ = D₂ := (sub_eq_zero.mp hD0).symm
+      subst hD12
+      rw [Submodule.comap_subtype_self]
+      have : Subsingleton (adeleBdd D₁ ⧸ (⊤ : Submodule K (adeleBdd D₁))) :=
+        Submodule.Quotient.subsingleton_iff.mpr rfl
+      exact ⟨Module.Finite.of_finite, by simp [Module.finrank_zero_of_subsingleton]⟩
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ (D₂ - D₁) P := by
+        have hne : (D₂ - D₁) P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hEeff P; omega
+      set D₂' : Divisor K F := D₂ - Finsupp.single P 1 with hD₂'
+      have h12' : D₁ ≤ D₂' := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]
+          have := hPpos; rw [Finsupp.sub_apply] at this; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have h2'2 : D₂' ≤ D₂ := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]
+      have hdegD₂' : Divisor.degree D₂' = Divisor.degree D₂ - P.deg := by
+        rw [hD₂', map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hEnn : 0 ≤ Divisor.degree (D₂ - D₁) := Divisor.degree_nonneg_of_nonneg hEeff
+      have hE'nn : 0 ≤ Divisor.degree (D₂' - D₁) := Divisor.degree_nonneg_of_nonneg
+        (fun v => by rw [Finsupp.sub_apply]; have := h12' v; omega)
+      have hdegdiff : Divisor.degree (D₂' - D₁) = Divisor.degree (D₂ - D₁) - P.deg := by
+        simp only [hD₂', map_sub, Divisor.degree_single, one_mul]; ring
+      have hmlt : (Divisor.degree (D₂' - D₁)).toNat < m := by rw [← hm]; omega
+      obtain ⟨hfin', hrank'⟩ := IH _ hmlt D₁ D₂' h12' rfl
+      obtain ⟨hfinS, hrankS⟩ := finrank_adeleBdd_quotient_single (K := K) D₂ P
+      rw [← hD₂'] at hfinS hrankS
+      have := hfin'; have := hfinS
+      obtain ⟨hfin, hrank⟩ := Submodule.finrank_quotient_chain
+        (A := adeleBdd D₁) (B := adeleBdd D₂') (C := adeleBdd D₂)
+        (adeleBdd_mono h12') (adeleBdd_mono h2'2)
+      refine ⟨hfin, ?_⟩
+      rw [hrank, hrankS]
+      push_cast
+      linarith [hrank', hdegD₂']
+
+theorem module_finite_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  (finrank_adeleBdd_quotient hD).1
+
+theorem finrank_adeleBdd_quotient_eq [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+      = Divisor.degree D₂ - Divisor.degree D₁ :=
+  (finrank_adeleBdd_quotient hD).2
+
+def lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (_hD : D₁ ≤ D₂) :
+    (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      →ₗ[K] (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  Submodule.mapQ _ _
+    ((diagonalHom K F).restrict
+      (p := (LSpace D₂ : Submodule K F)) (q := (adeleBdd D₂ : Submodule K _))
+      (fun f hf => diagonal_mem_adeleBdd_iff.mpr hf))
+    (fun f hf => by
+      simp only [Submodule.mem_comap, Submodule.coe_subtype] at hf ⊢
+      exact diagonal_mem_adeleBdd_iff.mpr hf)
+
+theorem lSpaceQuotientToAdeleBddQuotient_injective {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Function.Injective (lSpaceQuotientToAdeleBddQuotient hD) := by
+  rw [injective_iff_map_eq_zero]
+  intro x hx
+  obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+  rw [Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype]
+  rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk f)
+        = Submodule.Quotient.mk ((diagonalHom K F).restrict
+            (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f) from rfl,
+    Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype] at hx
+  exact diagonal_mem_adeleBdd_iff.mp hx
+
+
+theorem ell_sub_ell_le_degree_sub_degree [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)] :
+    (ell D₂ : ℤ) - (ell D₁ : ℤ) ≤ Divisor.degree D₂ - Divisor.degree D₁ := by
+  have := module_finite_adeleBdd_quotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    rw [hℓ₁]; exact (Submodule.finrank_quotient_add_finrank _).symm
+  have hemb : finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      ≤ finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+    LinearMap.finrank_le_finrank_of_injective (lSpaceQuotientToAdeleBddQuotient_injective hD)
+  have hloc := finrank_adeleBdd_quotient_eq hD
+  have : (ell D₂ : ℤ) - (ell D₁ : ℤ)
+      = (finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) : ℤ) := by
+    rw [hL]; push_cast; ring
+  rw [this, ← hloc]
+  exact_mod_cast hemb
+
+theorem adeleBdd_inf_sup_globalSub {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F)
+      = adeleBdd D₁ ⊔ adeleBdd D₂ ⊓ globalSub K F := by
+  rw [inf_comm, sup_inf_assoc_of_le _ (adeleBdd_mono hD), inf_comm]
+
+theorem map_diagonal_lSpace_inf_adeleBdd {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (LSpace D₂).map (diagonalHom K F) ⊓ adeleBdd D₁ = (LSpace D₁).map (diagonalHom K F) := by
+  rw [map_diagonal_lSpace, map_diagonal_lSpace, inf_right_comm,
+    inf_eq_right.mpr (adeleBdd_mono hD)]
+
+theorem gate_finrank_adeleBdd_quotient_single_point [IsCurveOver K F] (P : Place K F) :
+    (finrank K (adeleBdd (Finsupp.single P 1 : Divisor K F)
+        ⧸ (adeleBdd (0 : Divisor K F)).comap (adeleBdd (Finsupp.single P 1)).subtype) : ℤ)
+      = (P.deg : ℤ) := by
+  classical
+  have h01 : (0 : Divisor K F) ≤ Finsupp.single P 1 := by
+    intro v; rw [Finsupp.zero_apply, Finsupp.single_apply]; split_ifs <;> omega
+  have h := finrank_adeleBdd_quotient_eq (K := K) h01
+  rw [h, map_zero, sub_zero, Divisor.degree_single, one_mul]
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion factor mk mem_bot subtype_injective \
+  mk.injEq Quotient.subsingleton_iff Quotient.mk span restrictScalars inhabited \
+  inclusion_injective comapSubtypeEquivOfLe mem_comap finrank_quotient_add_finrank mem_top \
+  Quotient.equiv mkQ mem_map coe_subtype map_smul' zero one quotientQuotientEquivQuotient \
+  coe_eq_zero finrank_le range_subtype Quotient.mk_surjective map mem_inf mem_sup \
+  Quotient.mk_eq_zero topEquiv map_injective_of_injective comap_subtype_self mapQ subsingleton_iff \
+  module smul_def mk_eq_zero coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono \
+  map_sup coe_zero smul"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+theorem comap_subtype_sup_of_le_of_le {S T C : Submodule K X} (hS : S ≤ C) (hT : T ≤ C) :
+    S.comap C.subtype ⊔ T.comap C.subtype = (S ⊔ T).comap C.subtype := by
+  apply Submodule.map_injective_of_injective (f := C.subtype) C.subtype_injective
+  rw [Submodule.map_sup, Submodule.map_comap_subtype, Submodule.map_comap_subtype,
+    Submodule.map_comap_subtype, inf_eq_right.mpr hS, inf_eq_right.mpr hT,
+    inf_eq_right.mpr (sup_le hS hT)]
+
+theorem finrank_quotient_chain_top {M : Type*} [AddCommGroup M] [Module K M]
+    {A B : Submodule K M} (hAB : A ≤ B)
+    [hMB : Module.Finite K (M ⧸ B)] [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (M ⧸ A) ∧
+      finrank K (M ⧸ A) = finrank K (M ⧸ B) + finrank K (B ⧸ A.comap B.subtype) := by
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  let ψ : (B : Type _) →ₗ[K] (M ⧸ A) := A.mkQ ∘ₗ B.subtype
+  have hker : LinearMap.ker ψ = A.comap B.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = B.map A.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let eK : (B ⧸ A.comap B.subtype) ≃ₗ[K] (B.map A.mkQ : Submodule K (M ⧸ A)) :=
+    (Submodule.quotEquivOfEq _ _ hker.symm).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have : Module.Finite K (B.map A.mkQ : Submodule K (M ⧸ A)) := Module.Finite.equiv eK
+  have : Module.Finite K ((M ⧸ A) ⧸ B.map A.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (M ⧸ A) := Module.Finite.of_submodule_quotient (B.map A.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (B.map A.mkQ)
+  rw [LinearEquiv.finrank_eq e3, ← LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem globalSub_le_adeleSpace [HasPrincipalDivisors K F] :
+    globalSub K F ≤ adeleSpace K F := by
+  rintro _ ⟨f, rfl⟩
+  exact diagonal_mem_adeleSpace f
+
+theorem adeleBdd_sup_globalSub_le_adeleSpace [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+  sup_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_eq_comap [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBddPrincipal K F D = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype :=
+  Submodule.comap_subtype_sup_of_le_of_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_mono {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBddPrincipal K F D₁ ≤ adeleBddPrincipal K F D₂ :=
+  sup_le_sup_right (Submodule.comap_mono (adeleBdd_mono hD)) _
+
+section FiniteLSpace
+
+variable [IsCurveOver K F]
+
+theorem finiteDimensional_lSpace [hL0 : FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (D : Divisor K F) : FiniteDimensional K (LSpace D) := by
+  have h0D : (0 : Divisor K F) ≤ D ⊔ 0 := le_sup_right
+  have hDD : D ≤ D ⊔ 0 := le_sup_left
+  suffices h : FiniteDimensional K (LSpace (D ⊔ 0)) by
+    exact Module.Finite.of_injective (Submodule.inclusion (lSpace_mono hDD))
+      (Submodule.inclusion_injective _)
+  have := module_finite_adeleBdd_quotient (K := K) h0D
+  have hfinQ : FiniteDimensional K
+      (LSpace (D ⊔ 0) ⧸ (LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype) :=
+    Module.Finite.of_injective _ (lSpaceQuotientToAdeleBddQuotient_injective h0D)
+  have : FiniteDimensional K
+      ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype : Submodule K _) :=
+    Module.Finite.equiv (Submodule.comapSubtypeEquivOfLe (lSpace_mono h0D)).symm
+  exact Module.Finite.of_submodule_quotient
+    ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype)
+
+end FiniteLSpace
+
+
+theorem range_lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD)
+      = ((adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype).map
+          ((adeleBdd D₁).comap (adeleBdd D₂).subtype).mkQ := by
+  classical
+  ext z
+  obtain ⟨α, rfl⟩ := Submodule.Quotient.mk_surjective _ z
+  simp only [LinearMap.mem_range, Submodule.mem_map, Submodule.mem_comap, Submodule.coe_subtype,
+    Submodule.mkQ_apply]
+  constructor
+  · rintro ⟨x, hx⟩
+    obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+    have hxeq : Submodule.Quotient.mk
+        ((diagonalHom K F).restrict (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f)
+        = (Submodule.Quotient.mk α :
+            adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) := hx
+    refine ⟨α, ?_, rfl⟩
+    have hdiag2 : (diagonalHom K F (f : F)) ∈ adeleBdd D₂ := diagonal_mem_adeleBdd_iff.mpr f.2
+    have hsub : (α : Place K F → F) - diagonalHom K F (f : F) ∈ adeleBdd D₁ := by
+      have hq := (Submodule.Quotient.eq _).mp hxeq.symm
+      simpa using hq
+    refine Submodule.mem_sup.mpr ⟨(α : Place K F → F) - diagonalHom K F (f : F), hsub,
+      diagonalHom K F (f : F), diagonal_mem_globalSub _, ?_⟩
+    abel
+  · rintro ⟨β, hβ, hβeq⟩
+    have hβ' : (β : Place K F → F) ∈ adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F) :=
+      Submodule.mem_inf.mpr ⟨β.2, hβ⟩
+    rw [adeleBdd_inf_sup_globalSub hD, ← map_diagonal_lSpace] at hβ'
+    obtain ⟨γ, hγ, δ, ⟨f, hf, hfδ⟩, hsum⟩ := Submodule.mem_sup.mp hβ'
+    refine ⟨Submodule.Quotient.mk ⟨f, hf⟩, ?_⟩
+    rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk ⟨f, hf⟩)
+          = Submodule.Quotient.mk ((diagonalHom K F).restrict
+              (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) ⟨f, hf⟩) from rfl,
+      ← hβeq, Submodule.Quotient.eq]
+    refine Submodule.mem_comap.mpr ?_
+    change diagonalHom K F f - (β : Place K F → F) ∈ adeleBdd D₁
+    have hβsub : diagonalHom K F f - (β : Place K F → F) = -γ := by
+      rw [← hsum, hfδ]; ring
+    rw [hβsub]; exact (adeleBdd D₁).neg_mem hγ
+
+
+theorem finrank_adeleBddSup_quotient [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) [hL : FiniteDimensional K (LSpace D₂)] :
+    Module.Finite K (↥(adeleBdd D₂ ⊔ globalSub K F)
+        ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) ∧
+      (finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+          ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) : ℤ)
+        = (Divisor.degree D₂ - ell D₂) - (Divisor.degree D₁ - ell D₁) := by
+  classical
+  let A : Submodule K (adeleBdd D₂) := (adeleBdd D₁).comap (adeleBdd D₂).subtype
+  let B : Submodule K (adeleBdd D₂) :=
+    (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype
+  have hAB : A ≤ B := Submodule.comap_mono le_sup_left
+  have hfinA : Module.Finite K (adeleBdd D₂ ⧸ A) := module_finite_adeleBdd_quotient hD
+  have hdimA : (finrank K (adeleBdd D₂ ⧸ A) : ℤ) = Divisor.degree D₂ - Divisor.degree D₁ :=
+    finrank_adeleBdd_quotient_eq hD
+  have hran : LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD) = B.map A.mkQ :=
+    range_lSpaceQuotientToAdeleBddQuotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hdimL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K)
+      ((LSpace D₁).comap (LSpace D₂).subtype)
+    rw [← hℓ₁] at h; exact h.symm
+  have hdimB : ell D₂ = finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) + ell D₁ := by
+    rw [← hran, LinearMap.finrank_range_of_inj
+      (lSpaceQuotientToAdeleBddQuotient_injective hD)]
+    exact hdimL
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  have hfinB : Module.Finite K (adeleBdd D₂ ⧸ B) := Module.Finite.equiv e3
+  have hdim2 : finrank K (adeleBdd D₂ ⧸ A)
+      = finrank K (adeleBdd D₂ ⧸ B) + finrank K (B.map A.mkQ : Submodule K _) := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K) (M := adeleBdd D₂ ⧸ A)
+      (B.map A.mkQ)
+    rw [LinearEquiv.finrank_eq e3] at h; omega
+  have e2 := LinearMap.quotientInfEquivSupQuotient (R := K)
+    (adeleBdd D₂) (adeleBdd D₁ ⊔ globalSub K F)
+  have hsup : adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F) = adeleBdd D₂ ⊔ globalSub K F := by
+    rw [← sup_assoc, sup_eq_left.mpr (adeleBdd_mono hD)]
+  have hB' : (adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype = B := by
+    rw [Submodule.comap_subtype_self, top_inf_eq]
+  let eL : (adeleBdd D₂ ⧸ B) ≃ₗ[K]
+      (adeleBdd D₂ ⧸ ((adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+        (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype)) :=
+    Submodule.quotEquivOfEq _ _ hB'.symm
+  have hfin_iso : Module.Finite K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype) :=
+    Module.Finite.equiv (eL.trans e2)
+  have hdim_iso : finrank K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype)
+      = finrank K (adeleBdd D₂ ⧸ B) :=
+    (LinearEquiv.finrank_eq (eL.trans e2)).symm
+  have hcast : (finrank K (adeleBdd D₂ ⧸ A) : ℤ)
+      = (finrank K (adeleBdd D₂ ⧸ B) : ℤ) + ((ell D₂ : ℤ) - (ell D₁ : ℤ)) := by
+    have hb : (ell D₂ : ℤ)
+        = (finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) : ℤ) + (ell D₁ : ℤ) := by
+      exact_mod_cast hdimB
+    push_cast [hdim2]; linarith
+  have hgoal : (finrank K (adeleBdd D₂ ⧸ B) : ℤ)
+      = Divisor.degree D₂ - ↑(ell D₂) - (Divisor.degree D₁ - ↑(ell D₁)) := by
+    linarith [hdimA, hcast]
+  clear_value eL
+  exact hsup ▸ ⟨hfin_iso, by rw [hdim_iso]; exact hgoal⟩
+
+section Index
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+
+theorem adeleBddSup_eq_of_degree_sub_ell_eq {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)]
+    (heq : Divisor.degree D₂ - ell D₂ = Divisor.degree D₁ - ell D₁) :
+    adeleBdd D₂ ⊔ globalSub K F = adeleBdd D₁ ⊔ globalSub K F := by
+  obtain ⟨hfin, hdim⟩ := finrank_adeleBddSup_quotient hD
+  rw [heq, sub_self] at hdim
+  refine le_antisymm ?_ (sup_le_sup_right (adeleBdd_mono hD) _)
+  have := hfin
+  have hd0 : finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) = 0 := by
+    exact_mod_cast hdim
+  have hsub : Subsingleton (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) :=
+    Module.finrank_zero_iff.mp hd0
+  have htop := Submodule.Quotient.subsingleton_iff.mp hsub
+  intro x hx
+  have hxc : (⟨x, hx⟩ : ↥(adeleBdd D₂ ⊔ globalSub K F)) ∈
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype := by
+    rw [htop]; exact Submodule.mem_top
+  exact hxc
+
+end Index
+
+namespace RiemannGenusReachedAt
+p2m_export "AlgebraicCurve.RiemannGenusReachedAt" "finite mk eq isMax"
+end RiemannGenusReachedAt
+namespace RiemannGenusReachedAt
+p2m_open_scoped "AlgebraicCurve.RiemannGenusReachedAt" in
+private theorem _root_.AlgebraicCurve.RiemannGenusReachedAt.eq_of_ge [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {D : Divisor K F} (hD : D₀ ≤ D) :
+    Divisor.degree D - ell D = γ - 1 := by
+  have := finiteDimensional_lSpace (K := K) D
+  have hge : Divisor.degree D₀ - (ell D₀ : ℤ) ≤ Divisor.degree D - ell D := by
+    have := ell_sub_ell_le_degree_sub_degree (K := K) hD
+    linarith
+  exact le_antisymm (h.isMax D) (h.eq ▸ hge)
+
+end RiemannGenusReachedAt
+p2m_export "AlgebraicCurve" "RiemannGenusReachedAt.eq_of_ge"
+
+theorem adeleSpace_eq_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    adeleSpace K F = adeleBdd D₀ ⊔ globalSub K F := by
+  refine le_antisymm ?_ (adeleBdd_sup_globalSub_le_adeleSpace D₀)
+  rw [adeleSpace, iSup_le_iff]
+  intro D
+  refine le_trans (adeleBdd_mono (le_sup_left : D ≤ D ⊔ D₀)) ?_
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have heq : Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) = Divisor.degree D₀ - ell D₀ :=
+    (h.eq_of_ge le_sup_right).trans h.eq.symm
+  have hsup := adeleBddSup_eq_of_degree_sub_ell_eq (K := K)
+    (le_sup_right : D₀ ≤ D ⊔ D₀) heq
+  rw [← hsup]
+  exact le_sup_left
+
+theorem indexOfSpecialty_eq_zero_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    indexOfSpecialty D₀ = 0 := by
+  rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap, ← adeleSpace_eq_of_genusReached h,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.finrank_zero_of_subsingleton
+
+
+
+theorem gate_indexOfSpecialty_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  have h1 := (indexOfSpecialty_eq_of_genusReached h D₀).2
+  have h2 := h.eq
+  have h3 := indexOfSpecialty_eq_zero_of_genusReached h
+  exact_mod_cast h3
+
+theorem gate_riemannInequality_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Divisor.degree D + 1 - γ ≤ (ell D : ℤ) := by
+  have heq := (indexOfSpecialty_eq_of_genusReached h D).2
+  have hnn : (0 : ℤ) ≤ indexOfSpecialty D := Int.natCast_nonneg _
+  linarith
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem adeleSpaceMul_add [HasPrincipalDivisors K F] (f g : F) :
+    adeleSpaceMul K F (f + g) = adeleSpaceMul K F f + adeleSpaceMul K F g := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, LinearMap.add_apply, Submodule.coe_add,
+    Pi.add_apply, add_mul]
+
+theorem adeleSpaceMul_zero [HasPrincipalDivisors K F] :
+    adeleSpaceMul K F (0 : F) = 0 := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, zero_mul, LinearMap.zero_apply,
+    Submodule.coe_zero, Pi.zero_apply]
+
+theorem weilSmul_add_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f + g) φ = weilSmul K F f φ + weilSmul K F g φ := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_add, LinearMap.add_apply, map_add]
+
+theorem weilSmul_zero_left [HasPrincipalDivisors K F]
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (0 : F) φ = 0 := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_zero, LinearMap.zero_apply, map_zero]
+
+theorem weilSmul_neg_left [HasPrincipalDivisors K F] (f : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (-f) φ = -weilSmul K F f φ := by
+  have h := weilSmul_add_left (K := K) (F := F) f (-f) φ
+  rw [add_neg_cancel, weilSmul_zero_left] at h
+  exact (neg_eq_of_add_eq_zero_right h.symm).symm
+
+theorem weilSmul_sub_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f - g) φ = weilSmul K F f φ - weilSmul K F g φ := by
+  rw [sub_eq_add_neg, weilSmul_add_left, weilSmul_neg_left, sub_eq_add_neg]
+
+theorem weilSmul_eq_zero_iff_left [HasPrincipalDivisors K F]
+    {f : F} {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    weilSmul K F f φ = 0 ↔ f = 0 := by
+  refine ⟨fun h => ?_, fun h => h ▸ weilSmul_zero_left φ⟩
+  by_contra hf
+  exact hφ (weilSmul_injective hf (h.trans (map_zero (weilSmul K F f)).symm))
+
+theorem weilSmul_left_injective [HasPrincipalDivisors K F]
+    {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    Function.Injective (fun f : F => weilSmul K F f φ) := by
+  intro f g hfg
+  have hsub : weilSmul K F (f - g) φ = 0 := by
+    rw [weilSmul_sub_left, sub_eq_zero]; exact hfg
+  exact sub_eq_zero.mp ((weilSmul_eq_zero_iff_left hφ).mp hsub)
+
+variable (K F) in
+def doubleResiduePairing [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) :
+    LSpace (W - D) × LSpace (W - D) →ₗ[K] omegaSpace D :=
+  (residuePairing K F W D hφ).coprod (residuePairing K F W D hμ)
+
+theorem doubleResiduePairing_apply_coe [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (g h : LSpace (W - D)) :
+    (doubleResiduePairing K F W D hφ hμ (g, h) : Module.Dual K (adeleSpace K F))
+      = weilSmul K F (g : F) φ + weilSmul K F (h : F) μ := by
+  simp only [doubleResiduePairing, LinearMap.coprod_apply, Submodule.coe_add,
+    residuePairing_apply_coe]
+
+theorem doubleResiduePairing_injective [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ) :
+    Function.Injective (doubleResiduePairing K F W D hφ hμ) := by
+  rw [injective_iff_map_eq_zero]
+  rintro ⟨g, h⟩ heq
+  have heq' : weilSmul K F (g : F) φ + weilSmul K F (h : F) μ = 0 := by
+    have hcoe := congrArg Subtype.val heq
+    rwa [doubleResiduePairing_apply_coe, Submodule.coe_zero] at hcoe
+  rcases eq_or_ne (h : F) 0 with hh0 | hh0
+  · rw [hh0, weilSmul_zero_left, add_zero] at heq'
+    have hg0 : (g : F) = 0 := (weilSmul_eq_zero_iff_left hφ0).mp heq'
+    exact Prod.ext (Subtype.ext hg0) (Subtype.ext hh0)
+  · exfalso
+    have hμeq : weilSmul K F (h : F) μ = -weilSmul K F (g : F) φ := by
+      have h2 : weilSmul K F (h : F) μ + weilSmul K F (g : F) φ = 0 := by
+        rw [add_comm]; exact heq'
+      exact eq_neg_of_add_eq_zero_left h2
+    have hLHS : weilSmul K F (h : F)⁻¹ (weilSmul K F (h : F) μ) = μ := by
+      rw [← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hh0, weilSmul_one,
+        LinearMap.id_apply]
+    have hRHS : weilSmul K F (h : F)⁻¹ (-weilSmul K F (g : F) φ)
+        = weilSmul K F (-(g : F) * (h : F)⁻¹) φ := by
+      rw [map_neg, ← LinearMap.comp_apply, ← weilSmul_mul, neg_mul, weilSmul_neg_left]
+    exact hindep (-(g : F) * (h : F)⁻¹) (by rw [← hLHS, hμeq, hRHS])
+
+theorem two_mul_ell_le_indexOfSpecialty [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ)
+    [Module.Finite K (omegaSpace (K := K) (F := F) D)]
+    [Module.Finite K (LSpace (K := K) (F := F) (W - D))] :
+    2 * ell (W - D) ≤ indexOfSpecialty D := by
+  have hinj := doubleResiduePairing_injective W D hφ hμ hφ0 hindep
+  have hle := LinearMap.finrank_le_finrank_of_injective hinj
+  rw [Module.finrank_prod] at hle
+  rw [← finrank_omegaSpace_eq_indexOfSpecialty, two_mul]
+  exact hle
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+section Finiteness
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+theorem omegaSpace_finite_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Module.Finite K (omegaSpace (K := K) (F := F) D) := by
+  have := (indexOfSpecialty_eq_of_genusReached h D).1
+  exact Module.Finite.equiv (omegaSpaceEquivIndexDual D).symm
+
+end Finiteness
+
+section ParametricRankOne
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+
+theorem exists_weilSmul_eq_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {φ μ : Module.Dual K (adeleSpace K F)} {W : Divisor K F}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (hφ0 : φ ≠ 0) :
+    ∃ f : F, μ = weilSmul K F f φ := by
+  by_contra hcon
+  push Not at hcon
+  obtain ⟨P⟩ := ‹Nonempty (Place K F)›
+  set n : ℕ := 3 * γ.natAbs + 2 * (Divisor.degree W).natAbs + 4 with hn
+  set D : Divisor K F := -Finsupp.single P (n : ℤ) with hD
+  have hdegD : Divisor.degree D = -(n : ℤ) * (P.deg : ℤ) := by
+    rw [hD, map_neg, Divisor.degree_single]; ring
+  have hdegWD : Divisor.degree (W - D) = Divisor.degree W + (n : ℤ) * (P.deg : ℤ) := by
+    rw [map_sub, hdegD]; ring
+  have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+  have habsγ : -(|γ|) ≤ γ ∧ γ ≤ |γ| := ⟨neg_abs_le _, le_abs_self _⟩
+  have habsW : -|Divisor.degree W| ≤ Divisor.degree W ∧
+      Divisor.degree W ≤ |Divisor.degree W| := ⟨neg_abs_le _, le_abs_self _⟩
+  have hn_ge : 3 * |γ| + 2 * |Divisor.degree W| + 4 ≤ (n : ℤ) := by
+    rw [hn]; push_cast [Int.natCast_natAbs]; ring_nf; omega
+  have hndegP : (n : ℤ) ≤ (n : ℤ) * (P.deg : ℤ) := by nlinarith [Int.natCast_nonneg n]
+  have hellD : ell D = 0 := ell_eq_zero_of_degree_neg (by rw [hdegD]; nlinarith)
+  have hiD : (indexOfSpecialty D : ℤ) = (n : ℤ) * (P.deg : ℤ) - 1 + γ := by
+    have hidx := (indexOfSpecialty_eq_of_genusReached h D).2
+    rw [hellD, hdegD] at hidx; push_cast at hidx; linarith
+  have hlowerWD : Divisor.degree W + (n : ℤ) * (P.deg : ℤ) + 1 - γ
+      ≤ (ell (W - D) : ℤ) := by
+    have hlow := gate_riemannInequality_of_genusReached h (W - D)
+    rw [hdegWD] at hlow; exact hlow
+  have := omegaSpace_finite_of_genusReached h D
+  have := finiteDimensional_lSpace (K := K) (W - D)
+  have hdbl : (2 * ell (W - D) : ℤ) ≤ (indexOfSpecialty D : ℤ) := by
+    exact_mod_cast two_mul_ell_le_indexOfSpecialty W D hφ hμ hφ0 hcon
+  rw [hiD] at hdbl
+  nlinarith [habsγ.1, habsγ.2, habsW.1, habsW.2]
+
+theorem weilDifferentialRankOne_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    WeilDifferentialRankOne K F := by
+  intro φ hφmem hφ0 μ hμmem
+  obtain ⟨W₁, hφW₁⟩ := mem_weilDifferentialModule_iff.mp hφmem
+  obtain ⟨W₂, hμW₂⟩ := mem_weilDifferentialModule_iff.mp hμmem
+  have hφW : φ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_left hφW₁
+  have hμW : μ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_right hμW₂
+  obtain ⟨f, hf⟩ := exists_weilSmul_eq_of_genusReached h hφW hμW hφ0
+  exact ⟨f, hf, fun f' hf' => weilSmul_left_injective hφ0 (hf'.symm.trans hf)⟩
+
+end ParametricRankOne
+
+theorem residuePairing_surjective_of_rankOne_max [HasPrincipalDivisors K F]
+    (hRankOne : WeilDifferentialRankOne K F)
+    {W : Divisor K F} {φ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hφ0 : φ ≠ 0)
+    (hWmax : ∀ E : Divisor K F, φ ∈ omegaSpace E → E ≤ W) (D : Divisor K F) :
+    Function.Surjective (residuePairing K F W D hφ) := by
+  rintro ⟨μ, hμD⟩
+  have hφmem : φ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule W hφ
+  have hμmem : μ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule D hμD
+  obtain ⟨f, hf, -⟩ := hRankOne hφmem hφ0 hμmem
+  rcases eq_or_ne f 0 with rfl | hf0
+  · have hμ0 : (⟨μ, hμD⟩ : omegaSpace D) = 0 :=
+      Subtype.ext (hf.trans (weilSmul_zero_left φ))
+    exact ⟨0, (map_zero _).trans hμ0.symm⟩
+  · obtain ⟨P, hPord, _⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+    have hPinv : ∀ v, (-P) v = v.ord f⁻¹ := fun v => by
+      rw [Finsupp.neg_apply, hPord v, v.ord_inv]
+    have hinv : weilSmul K F f⁻¹ μ = φ := by
+      rw [hf, ← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hf0, weilSmul_one,
+        LinearMap.id_apply]
+    have hφD : φ ∈ omegaSpace (D + -P) := by
+      rw [← hinv]; exact weilSmul_mem_omegaSpace_add (inv_ne_zero hf0) hPinv hμD
+    have hDP : D + -P ≤ W := hWmax _ hφD
+    have hfL : f ∈ LSpace (W - D) := by
+      rw [mem_lSpace_iff_ord]; refine Or.inr fun v => ?_
+      have hv := hDP v
+      rw [Finsupp.add_apply, Finsupp.neg_apply, hPord v] at hv
+      rw [Finsupp.sub_apply]; linarith
+    exact ⟨⟨f, hfL⟩, Subtype.ext hf.symm⟩
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem exists_riemannGenusReachedAt_of_bounded
+    [IsCurveOver K F] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    ∃ (γ : ℤ) (D₀ : Divisor K F), RiemannGenusReachedAt γ D₀ := by
+  obtain ⟨γ, hγ⟩ := hbdd
+  obtain ⟨M, ⟨D₀, hD₀⟩, hMmax⟩ :=
+    Int.exists_greatest_of_bdd
+      (P := fun n => ∃ D : Divisor K F, Divisor.degree D - ell D = n)
+      ⟨γ, fun n ⟨D, hD⟩ => hD ▸ hγ D⟩
+      ⟨Divisor.degree (0 : Divisor K F) - ell (0 : Divisor K F), 0, rfl⟩
+  refine ⟨M + 1, D₀, ?_, ?_, ?_⟩
+  · exact finiteDimensional_lSpace D₀
+  · rw [hD₀]; ring
+  · intro D
+    have := hMmax (Divisor.degree D - ell D) ⟨D, rfl⟩
+    linarith
+
+theorem stichtenothGenusExists_of_bounded
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    StichtenothGenusExists K F :=
+  ⟨‹_›, ‹_›, exists_riemannGenusReachedAt_of_bounded hbdd⟩
+
+
+theorem indexOfSpecialty_sub_of_ge [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₀ D : Divisor K F} (hD : D₀ ≤ D)
+    [FiniteDimensional K (LSpace D)]
+    [hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀)] :
+    Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D) ∧
+      (Divisor.degree D - ell D) - (Divisor.degree D₀ - ell D₀)
+        = (indexOfSpecialty D₀ : ℤ) - (indexOfSpecialty D : ℤ) := by
+  have hABsub : adeleBdd D₀ ⊔ globalSub K F ≤ adeleBdd D ⊔ globalSub K F :=
+    sup_le_sup_right (adeleBdd_mono hD) _
+  have hBCsub : adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+    adeleBdd_sup_globalSub_le_adeleSpace _
+  obtain ⟨hfinBA, hdimBA⟩ := finrank_adeleBddSup_quotient (K := K) hD
+  have := hfinBA
+  have hfinCA : Module.Finite K (adeleSpace K F ⧸
+      (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [← adeleBddPrincipal_eq_comap]; exact hfin
+  obtain ⟨hfinCB, hdimCB⟩ := Submodule.finrank_quotient_chain'
+    (A := adeleBdd D₀ ⊔ globalSub K F) (B := adeleBdd D ⊔ globalSub K F)
+    (C := adeleSpace K F) hABsub hBCsub
+  have hi0 : indexOfSpecialty D₀
+      = finrank K (adeleSpace K F ⧸
+        (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap]
+  have hiD : indexOfSpecialty D
+      = finrank K (adeleSpace K F ⧸
+        (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap]
+  have := hfinCB
+  obtain ⟨_, hdimCA⟩ := Submodule.finrank_quotient_chain
+    (A := adeleBdd D₀ ⊔ globalSub K F) (B := adeleBdd D ⊔ globalSub K F)
+    (C := adeleSpace K F) hABsub hBCsub
+  refine ⟨?_, ?_⟩
+  · rw [show adeleBddPrincipal K F D
+        = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype
+      from adeleBddPrincipal_eq_comap D]
+    exact hfinCB
+  · have hcast : (indexOfSpecialty D₀ : ℤ)
+        = (indexOfSpecialty D : ℤ)
+          + (finrank K (↥(adeleBdd D ⊔ globalSub K F)
+              ⧸ (adeleBdd D₀ ⊔ globalSub K F).comap
+                (adeleBdd D ⊔ globalSub K F).subtype) : ℤ) := by
+      rw [hiD, hi0]; exact_mod_cast hdimCA
+    linarith [hdimBA, hcast]
+
+theorem degreeSub_ell_le_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {D₀ : Divisor K F}
+    (hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀))
+    (D : Divisor K F) :
+    Divisor.degree D - ell D ≤ (Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀ := by
+  have := hfin
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have hmono : Divisor.degree D - (ell D : ℤ)
+      ≤ Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) (le_sup_left : D ≤ D ⊔ D₀)
+    linarith
+  obtain ⟨_, heq⟩ :=
+    indexOfSpecialty_sub_of_ge (K := K) (le_sup_right : D₀ ≤ D ⊔ D₀)
+  have hi0 : (0 : ℤ) ≤ indexOfSpecialty (D ⊔ D₀) := Int.natCast_nonneg _
+  linarith
+
+theorem riemannGenusBounded_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hfin : IndexOfSpecialtyFinite K F) :
+    RiemannGenusBounded K F := by
+  obtain ⟨D₀, hD₀⟩ := hfin
+  exact ⟨(Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀,
+    degreeSub_ell_le_of_indexFinite hD₀⟩
+
+theorem stichtenothGenusExists_of_indexFinite
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hfin : IndexOfSpecialtyFinite K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_bounded (riemannGenusBounded_of_indexFinite hfin)
+
+theorem indexOfSpecialtyFinite_of_stichtenothGenusExists
+    [IsCurveOver K F] (hSG : StichtenothGenusExists K F) :
+    IndexOfSpecialtyFinite K F := by
+  obtain ⟨hne, hL0, γ, D₀, hD₀⟩ := hSG
+  have := hne; have := hL0
+  refine ⟨D₀, ?_⟩
+  rw [show adeleBddPrincipal K F D₀
+      = (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype
+    from adeleBddPrincipal_eq_comap D₀, ← adeleSpace_eq_of_genusReached hD₀,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.Finite.of_finite
+
+theorem stichtenothGenusExists_iff_indexFinite
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] :
+    StichtenothGenusExists K F ↔ IndexOfSpecialtyFinite K F :=
+  ⟨indexOfSpecialtyFinite_of_stichtenothGenusExists,
+    stichtenothGenusExists_of_indexFinite⟩
+
+theorem gate_indexOfSpecialty_engine_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  exact_mod_cast indexOfSpecialty_eq_zero_of_genusReached h
+
+theorem gate_stichtenothGenus_le_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {D₀ : Divisor K F}
+    (hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀))
+    {γ : ℤ} {D₁ : Divisor K F} (h : RiemannGenusReachedAt γ D₁) :
+    γ - 1 ≤ (Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀ := by
+  have := degreeSub_ell_le_of_indexFinite hfin D₁
+  rw [h.eq] at this; exact this
+
+theorem gate_riemannGenusBounded_of_reachedAt
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    RiemannGenusBounded K F :=
+  ⟨γ - 1, h.isMax⟩
+
+theorem gate_indexOfSpecialtyFinite_at_zero [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F (0 : Divisor K F)) :=
+  (indexOfSpecialty_eq_of_genusReached h 0).1
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem mul_mem_lSpace_add {D E : Divisor K F} {f g : F}
+    (hf : f ∈ LSpace D) (hg : g ∈ LSpace E) :
+    f * g ∈ LSpace (D + E) := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · rw [zero_mul]; exact (LSpace _).zero_mem
+  rcases eq_or_ne g 0 with rfl | hg0
+  · rw [mul_zero]; exact (LSpace _).zero_mem
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun v => ?_
+  rw [Finsupp.add_apply, neg_add, v.ord_mul hf0 hg0]
+  exact add_le_add ((mem_lSpace_iff_ord.mp hf).resolve_left hf0 v)
+    ((mem_lSpace_iff_ord.mp hg).resolve_left hg0 v)
+
+theorem pow_mem_lSpace_nsmul {B : Divisor K F} {f : F} (hf : f ∈ LSpace B) (j : ℕ) :
+    f ^ j ∈ LSpace (j • B) := by
+  induction j with
+  | zero => simpa using one_mem_lSpace_zero (K := K) (F := F)
+  | succ j ih =>
+    rw [pow_succ, succ_nsmul]
+    exact mul_mem_lSpace_add ih hf
+
+namespace PoleDivisorPackage
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degB_eq u B hB_eff n lin_indep mk c x hn_pos \
+  hu_mem mk.injEq hx_mem"
+p2m_open "AlgebraicCurve.PoleDivisorPackage"
+
+variable (P : PoleDivisorPackage K F)
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.pow_mul_u_mem_lSpace (j : ℕ) (i : Fin P.n)
+    :
+    P.x ^ j * P.u i ∈ LSpace ((j + P.c) • P.B) := by
+  rw [add_nsmul]
+  exact mul_mem_lSpace_add (pow_mem_lSpace_nsmul P.hx_mem j) (P.hu_mem i)
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "pow_mul_u_mem_lSpace"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.pow_mul_u_mem_lSpace_of_le {j m : ℕ}
+    (hjm : j + P.c ≤ m) (i : Fin P.n) :
+    P.x ^ j * P.u i ∈ LSpace (m • P.B) := by
+  refine lSpace_mono ?_ (P.pow_mul_u_mem_lSpace j i)
+  intro v
+  have hBv : (0 : ℤ) ≤ P.B v := P.hB_eff v
+  change ((j + P.c) • P.B) v ≤ (m • P.B) v
+  simp only [Finsupp.smul_apply, nsmul_eq_mul]
+  exact mul_le_mul_of_nonneg_right (by exact_mod_cast hjm) hBv
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "pow_mul_u_mem_lSpace_of_le"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.ell_nsmul_poleDivisor_ge [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    (P.n : ℤ) * (m - P.c + 1) ≤ ell (m • P.B) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  set g : Fin (m - P.c + 1) × Fin P.n → LSpace (m • P.B) :=
+    fun p => ⟨P.x ^ (p.1 : ℕ) * P.u p.2,
+      P.pow_mul_u_mem_lSpace_of_le (by have := p.1.isLt; omega) p.2⟩
+    with hgdef
+  have hsub : LinearIndependent K (fun p => (g p : F)) := by
+    have heq : (fun p => (g p : F))
+        = (fun p : ℕ × Fin P.n => P.x ^ p.1 * P.u p.2)
+            ∘ (fun p : Fin (m - P.c + 1) × Fin P.n => ((p.1 : ℕ), p.2)) := by
+      funext p; rfl
+    rw [heq]
+    refine P.lin_indep.comp _ ?_
+    intro p q hpq
+    simp only [Prod.mk.injEq] at hpq
+    exact Prod.ext (Fin.val_injective hpq.1) hpq.2
+  have hg : LinearIndependent K g := hsub.of_comp (LSpace (m • P.B)).subtype
+  have hcard := hg.fintype_card_le_finrank
+  rw [Fintype.card_prod, Fintype.card_fin, Fintype.card_fin] at hcard
+  have hZ : ((m - P.c + 1) * P.n : ℤ) ≤ (ell (m • P.B) : ℤ) := by exact_mod_cast hcard
+  have heq : (((m - P.c + 1 : ℕ) : ℤ) * P.n : ℤ) = (P.n : ℤ) * ((m : ℤ) - P.c + 1) := by
+    rw [Nat.cast_add, Nat.cast_sub hm, Nat.cast_one]; ring
+  linarith
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "ell_nsmul_poleDivisor_ge"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.degree_nsmul_sub_ell_le [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    Divisor.degree (m • P.B) - ell (m • P.B) ≤ (P.n : ℤ) * (P.c - 1) := by
+  have hge := P.ell_nsmul_poleDivisor_ge hm
+  have hdeg : Divisor.degree (m • P.B) = (m : ℤ) * P.n := by
+    rw [show m • P.B = (m : ℤ) • P.B from (natCast_zsmul _ _).symm,
+      Divisor.degree.map_zsmul, smul_eq_mul, P.degB_eq]
+  linarith
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degree_nsmul_sub_ell_le"
+end PoleDivisorPackage
+
+namespace PoleDivisorPackage
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degB_eq u B hB_eff n lin_indep mk c x hn_pos \
+  hu_mem mk.injEq hx_mem"
+end PoleDivisorPackage
+namespace PoleDivisorPackage
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.ell_nsmul_sub_pos [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) {A : Divisor K F} (hA : 0 ≤ A) {m : ℕ} (hm : P.c ≤ m)
+    (hbig : Divisor.degree A < (P.n : ℤ) * (m - P.c + 1)) :
+    0 < ell (m • P.B - A) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  have hle : m • P.B - A ≤ m • P.B := by
+    intro v
+    have hAv : (0 : ℤ) ≤ A v := hA v
+    rw [Finsupp.sub_apply]
+    linarith
+  have h48 := ell_sub_ell_le_degree_sub_degree (K := K) hle
+  rw [map_sub, sub_sub_cancel] at h48
+  have h412 := P.ell_nsmul_poleDivisor_ge hm
+  have : (0 : ℤ) < (ell (m • P.B - A) : ℤ) := by linarith
+  exact_mod_cast this
+
+end PoleDivisorPackage
+p2m_export "AlgebraicCurve" "PoleDivisorPackage.ell_nsmul_sub_pos"
+namespace PoleDivisorPackage
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.degree_sub_ell_le [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) (D : Divisor K F) :
+    Divisor.degree D - ell D ≤ (P.n : ℤ) * (P.c - 1) := by
+  classical
+  set D' : Divisor K F := D ⊔ 0 with hD'def
+  have hD'eff : 0 ≤ D' := le_sup_right
+  have hDD' : D ≤ D' := le_sup_left
+  have := finiteDimensional_lSpace (K := K) D'
+  have hmono : Divisor.degree D - (ell D : ℤ) ≤ Divisor.degree D' - ell D' := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hDD'
+    linarith
+  set m : ℕ := P.c + (Divisor.degree D').toNat with hmdef
+  have hcm : P.c ≤ m := Nat.le_add_right _ _
+  have hdegD' : 0 ≤ Divisor.degree D' := Divisor.degree_nonneg_of_nonneg hD'eff
+  have hbig : Divisor.degree D' < (P.n : ℤ) * (m - P.c + 1) := by
+    have hcast : ((m : ℤ) - P.c) = Divisor.degree D' := by
+      simp only [hmdef, Nat.cast_add, add_sub_cancel_left, Int.toNat_of_nonneg hdegD']
+    rw [hcast]
+    have hn1 : (1 : ℤ) ≤ P.n := by exact_mod_cast P.hn_pos
+    nlinarith
+  have hellpos := P.ell_nsmul_sub_pos hD'eff hcm hbig
+  have hnebot : LSpace (m • P.B - D') ≠ ⊥ :=
+    fun h => by rw [ell, h, finrank_bot] at hellpos; exact lt_irrefl 0 hellpos
+  obtain ⟨z, hzL, hz0⟩ := (Submodule.ne_bot_iff _).mp hnebot
+  obtain ⟨Dz, hDzord, hDzdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) z hz0
+  have hzmem := (mem_lSpace_iff_ord.mp hzL).resolve_left hz0
+  have hD'le : D' ≤ m • P.B + Dz := by
+    intro v
+    have := hzmem v
+    simp only [Finsupp.add_apply, Finsupp.sub_apply, neg_sub] at this ⊢
+    rw [hDzord]; linarith
+  have hellshift : ell (m • P.B + Dz) = ell (m • P.B) :=
+    (LinearEquiv.finrank_eq (lSpaceShiftEquiv (m • P.B) hz0 hDzord)).symm
+  have hdegshift : Divisor.degree (m • P.B + Dz) = Divisor.degree (m • P.B) := by
+    rw [map_add, hDzdeg, add_zero]
+  have := finiteDimensional_lSpace (K := K) (m • P.B + Dz)
+  have hmono' : Divisor.degree D' - (ell D' : ℤ)
+      ≤ Divisor.degree (m • P.B + Dz) - ell (m • P.B + Dz) := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hD'le
+    linarith
+  rw [hellshift, hdegshift] at hmono'
+  have h412 := P.degree_nsmul_sub_ell_le hcm
+  linarith
+
+end PoleDivisorPackage
+p2m_export "AlgebraicCurve" "PoleDivisorPackage.degree_sub_ell_le"
+
+theorem riemannGenusBounded_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    RiemannGenusBounded K F :=
+  ⟨(P.n : ℤ) * (P.c - 1), P.degree_sub_ell_le⟩
+
+theorem stichtenothGenusExists_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_bounded (riemannGenusBounded_of_poleDivisorPackage P)
+
+theorem indexOfSpecialtyFinite_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_stichtenothGenusExists
+    (stichtenothGenusExists_of_poleDivisorPackage P)
+
+theorem indexOfSpecialtyFinite_of_hasPoleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (h : HasPoleDivisorPackage K F) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_poleDivisorPackage h.some
+
+theorem stichtenothGenusExists_of_hasPoleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (h : HasPoleDivisorPackage K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_poleDivisorPackage h.some
+
+theorem gate_stichtenothGenus_le_of_poleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F)
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    γ ≤ (P.n : ℤ) * (P.c - 1) + 1 := by
+  have := P.degree_sub_ell_le D₀
+  rw [h.eq] at this; linarith
+
+theorem gate_ell_c_nsmul_ge [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    (P.n : ℤ) ≤ ell (P.c • P.B) := by
+  have h := P.ell_nsmul_poleDivisor_ge (le_refl P.c)
+  simp only [sub_self, zero_add, mul_one] at h
+  exact h
+
+theorem gate_x_transcendental_of_poleDivisorPackage (P : PoleDivisorPackage K F) :
+    LinearIndependent K (fun j : ℕ => P.x ^ j * P.u ⟨0, P.hn_pos⟩) := by
+  refine P.lin_indep.comp (fun j => (j, ⟨0, P.hn_pos⟩)) ?_
+  intro a b hab
+  exact (Prod.mk.injEq .. ▸ hab).1
+
+theorem gate_u_linearIndependent_of_poleDivisorPackage (P : PoleDivisorPackage K F) :
+    LinearIndependent K P.u := by
+  have h : LinearIndependent K (fun i : Fin P.n => P.x ^ (0 : ℕ) * P.u i) := by
+    refine P.lin_indep.comp (fun i => (0, i)) ?_
+    intro a b hab
+    exact (Prod.mk.injEq .. ▸ hab).2
+  simpa using h
+
+end AlgebraicCurve
+
+end
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+scoped instance instSumRamificationInertia_port {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F']
+    [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+    [HasPrincipalDivisors K F'] : SumRamificationInertia K F F' :=
+  ⟨fun v => Place.sum_ramificationIndex_mul_inertiaDeg v⟩
+end AlgebraicCurve
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+
+namespace TranscendenceTower
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF poleDivisor RegularOutside hx_indep hxreg v \
+  mk.injEq mk hvdeg x hxv"
+p2m_open "AlgebraicCurve.TranscendenceTower"
+
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F]
+variable (T : TranscendenceTower K E F)
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.x_ne_zero : T.x ≠ 0 := fun h => by
+  have := T.hxv; rw [h, Place.ord_zero] at this; exact absurd this (by decide)
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "x_ne_zero"
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+theorem xF_ne_zero : T.xF ≠ 0 :=
+  fun h => T.x_ne_zero ((algebraMap E F).injective (by rwa [map_zero]))
+
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.poleDivisor_apply (w : Place K F) :
+    T.poleDivisor w = (w.ramificationIndex E : ℤ) * (Finsupp.single T.v 1) (w.restrict E) :=
+  Divisor.pullback_apply (Finsupp.single T.v 1) w
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "poleDivisor_apply"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.poleDivisor_nonneg :
+    0 ≤ T.poleDivisor := by
+  classical
+  intro w
+  rw [Finsupp.coe_zero, Pi.zero_apply, T.poleDivisor_apply, Finsupp.single_apply]
+  refine mul_nonneg (Int.natCast_nonneg _) ?_
+  split_ifs <;> simp
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "poleDivisor_nonneg"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.xF_mem_lSpace_poleDivisor :
+    T.xF ∈ LSpace T.poleDivisor := by
+  classical
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun w => ?_
+  rw [T.poleDivisor_apply, Place.ord_restrict, Finsupp.single_apply]
+  rcases eq_or_ne (w.restrict E) T.v with hw | hw
+  · simp only [hw, T.hxv, ite_true, mul_one, mul_neg_one, le_refl]
+  · simp only [ite_eq_right (Ne.symm hw), mul_zero, neg_zero]
+    exact mul_nonneg (Int.natCast_nonneg _) (T.hxreg _ hw)
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF_mem_lSpace_poleDivisor"
+
+private theorem _root_.AlgebraicCurve.TranscendenceTower.degree_poleDivisor_eq_finrank :
+    Divisor.degree T.poleDivisor = (Module.finrank E F : ℤ) := by
+  rw [poleDivisor, Divisor.degree_pullback, Divisor.degree_single, T.hvdeg]
+  push_cast; ring
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "degree_poleDivisor_eq_finrank"
+omit [FiniteDimensional E F] in
+private theorem
+  _root_.AlgebraicCurve.TranscendenceTower.mem_lSpace_nsmul_poleDivisor_of_regular_outside {f : F}
+    (hreg : ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord f)
+    {c : ℕ} (hc : ∀ w ∈ T.v.fiber F, -(c : ℤ) ≤ w.ord f) :
+    f ∈ LSpace (c • T.poleDivisor) := by
+  classical
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact (LSpace _).zero_mem
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun w => ?_
+  rw [Finsupp.smul_apply, T.poleDivisor_apply, Finsupp.single_apply, nsmul_eq_mul]
+  rcases eq_or_ne (w.restrict E) T.v with hw | hw
+  · simp only [hw, ite_true, mul_one]
+    have he : (1 : ℤ) ≤ w.ramificationIndex E := by
+      exact_mod_cast w.ramificationIndex_pos (F := E)
+    have hbdd := hc w (Place.mem_fiber.mpr hw)
+    nlinarith [Int.natCast_nonneg c]
+  · simp only [ite_eq_right (Ne.symm hw), mul_zero, neg_zero]
+    exact hreg w hw
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "mem_lSpace_nsmul_poleDivisor_of_regular_outside"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.exists_forall_mem_lSpace_nsmul_poleDivisor
+    {n : ℕ} (u : Fin n → F)
+    (hreg : ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)) :
+    ∃ c : ℕ, ∀ i, u i ∈ LSpace (c • T.poleDivisor) := by
+  classical
+  refine ⟨(Finset.univ : Finset (Fin n)).sup fun i =>
+    (T.v.fiber F).sup fun w => (-(w.ord (u i))).toNat,
+    fun i => T.mem_lSpace_nsmul_poleDivisor_of_regular_outside (hreg i) ?_⟩
+  intro w hw
+  have h1 : (-(w.ord (u i))).toNat
+      ≤ (T.v.fiber F).sup fun w' => (-(w'.ord (u i))).toNat :=
+    Finset.le_sup (f := fun w' => (-(w'.ord (u i))).toNat) hw
+  have h2 : ((T.v.fiber F).sup fun w' => (-(w'.ord (u i))).toNat)
+      ≤ (Finset.univ : Finset (Fin n)).sup fun i' =>
+          (T.v.fiber F).sup fun w' => (-(w'.ord (u i'))).toNat :=
+    Finset.le_sup (f := fun i' => (T.v.fiber F).sup fun w' => (-(w'.ord (u i'))).toNat)
+      (Finset.mem_univ i)
+  have htnat : -(w.ord (u i)) ≤ ((-(w.ord (u i))).toNat : ℤ) := Int.self_le_toNat _
+  omega
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "exists_forall_mem_lSpace_nsmul_poleDivisor"
+end TranscendenceTower
+
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F]
+
+section PrincipalDivisors
+
+variable [HasPrincipalDivisors K F]
+
+namespace IntegralBasisInLSpace
+p2m_export "AlgebraicCurve.IntegralBasisInLSpace" "hu_indep c u mk.injEq hu_mem mk"
+end IntegralBasisInLSpace
+p2m_open_scoped "AlgebraicCurve.IntegralBasisInLSpace" in
+def IntegralBasisInLSpace.ofRegularOutside (T : TranscendenceTower K E F)
+    (u : Fin (Module.finrank E F) → F) (hu_indep : LinearIndependent E u)
+    (hreg : ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)) :
+    IntegralBasisInLSpace T where
+  c := (T.exists_forall_mem_lSpace_nsmul_poleDivisor u hreg).choose
+  u := u
+  hu_indep := hu_indep
+  hu_mem := (T.exists_forall_mem_lSpace_nsmul_poleDivisor u hreg).choose_spec
+
+omit [FiniteDimensional E F] in
+theorem hasIntegralBasisInLSpace_of_regularOutside (T : TranscendenceTower K E F)
+    (h : HasIntegralBasisRegularOutside K E F T) :
+    HasIntegralBasisInLSpace K E F T := by
+  obtain ⟨u, hu_indep, hreg⟩ := h
+  exact ⟨IntegralBasisInLSpace.ofRegularOutside T u hu_indep hreg⟩
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+theorem linearIndependent_pow_mul {x : E} {n : ℕ} {u : Fin n → F}
+    (hx : LinearIndependent K (fun j : ℕ => x ^ j)) (hu : LinearIndependent E u) :
+    LinearIndependent K (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2) := by
+  have heq : (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2)
+      = (fun p : ℕ × Fin n => (x ^ p.1) • u p.2) := by
+    funext p
+    rw [Algebra.smul_def, map_pow]
+  rw [heq]
+  exact linearIndependent_smul (R := K) (S := E) (A := F) hx hu
+
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+def PoleDivisorPackage.ofTranscendenceTower (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    PoleDivisorPackage K F where
+  x := T.xF
+  B := T.poleDivisor
+  hB_eff := T.poleDivisor_nonneg
+  hx_mem := T.xF_mem_lSpace_poleDivisor
+  n := Module.finrank E F
+  hn_pos := Module.finrank_pos
+  degB_eq := T.degree_poleDivisor_eq_finrank
+  c := IB.c
+  u := IB.u
+  hu_mem := IB.hu_mem
+  lin_indep := linearIndependent_pow_mul T.hx_indep IB.hu_indep
+
+theorem hasPoleDivisorPackage_of_transcendenceTower
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    HasPoleDivisorPackage K F :=
+  ⟨PoleDivisorPackage.ofTranscendenceTower T IB⟩
+
+theorem hasPoleDivisorPackage_of_hasIntegralBasisInLSpace
+    (T : TranscendenceTower K E F) (h : HasIntegralBasisInLSpace K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_transcendenceTower T h.some
+
+theorem hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside
+    (T : TranscendenceTower K E F) (h : HasIntegralBasisRegularOutside K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisInLSpace T
+    (hasIntegralBasisInLSpace_of_regularOutside T h)
+
+end PrincipalDivisors
+
+theorem indexOfSpecialtyFinite_of_transcendenceTower [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem stichtenothGenusExists_of_transcendenceTower [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem gate_ofTranscendenceTower_n_eq [HasPrincipalDivisors K F] (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    (PoleDivisorPackage.ofTranscendenceTower T IB).n = Module.finrank E F := rfl
+
+theorem gate_ofTranscendenceTower_B_eq [HasPrincipalDivisors K F] (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    (PoleDivisorPackage.ofTranscendenceTower T IB).B = T.poleDivisor := rfl
+
+theorem gate_ofTranscendenceTower_x_transcendental [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    LinearIndependent K
+      (fun j : ℕ => T.xF ^ j *
+        (PoleDivisorPackage.ofTranscendenceTower T IB).u ⟨0, Module.finrank_pos⟩) :=
+  gate_x_transcendental_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem gate_degree_pullback_single_of_deg_eq [HasPrincipalDivisors K F]
+    (v : Place K E) (d : ℕ) (hd : v.deg = d) :
+    Divisor.degree (Divisor.pullback F (Finsupp.single v (1 : ℤ)))
+      = (Module.finrank E F : ℤ) * d := by
+  rw [Divisor.degree_pullback, Divisor.degree_single, hd]; ring
+
+theorem gate_stichtenothGenus_le_of_transcendenceTower [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T)
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    γ ≤ (Module.finrank E F : ℤ) * (IB.c - 1) + 1 :=
+  gate_stichtenothGenus_le_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB) h
+
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open Module
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~restrict_plac\
+  eOfPrime~placeOfPrime~comap_algebraMap_ne_top"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral {f : F}
+    (hf : IsIntegral w.toValuationSubring f) :
+    f ∈ w.toValuationSubring := by
+  obtain ⟨y, hy⟩ := IsIntegrallyClosed.isIntegral_iff.mp hf
+  exact hy ▸ y.2
+
+p2m_export "AlgebraicCurve.Place" "mem_of_isIntegral"
+
+theorem ord_nonneg_of_isIntegral {f : F} (hf : IsIntegral w.toValuationSubring f) :
+    0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral hf)
+
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral_of_algebraMap_mem {A : Type*}
+    [CommRing A] [Algebra A F]
+    (hA : ∀ a : A, algebraMap A F a ∈ w.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : f ∈ w.toValuationSubring := by
+  let : Algebra A w.toValuationSubring :=
+    ((algebraMap A F).codRestrict w.toValuationSubring.toSubring hA).toAlgebra
+  have : IsScalarTower A w.toValuationSubring F :=
+    IsScalarTower.of_algebraMap_eq fun a => rfl
+  exact w.mem_of_isIntegral hf.tower_top
+
+p2m_export "AlgebraicCurve.Place" "mem_of_isIntegral_of_algebraMap_mem"
+
+theorem ord_nonneg_of_isIntegral_of_algebraMap_mem {A : Type*} [CommRing A] [Algebra A F]
+    (hA : ∀ a : A, algebraMap A F a ∈ w.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : 0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral_of_algebraMap_mem hA hf)
+
+end Place
+
+section Bridge
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+variable {A : Type*} [CommRing A] [Algebra A E] [Algebra A F] [IsScalarTower A E F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+end Place
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral_of_restrict [Algebra.IsIntegral E F]
+    (w : Place K F)
+    {u : Place K E} (hw : w.restrict E = u)
+    (hA : ∀ a : A, algebraMap A E a ∈ u.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : f ∈ w.toValuationSubring := by
+  refine w.mem_of_isIntegral_of_algebraMap_mem (fun a => ?_) hf
+  rw [IsScalarTower.algebraMap_apply A E F, ← w.mem_restrict_iff, hw]
+  exact hA a
+
+end Place
+p2m_export "AlgebraicCurve" "Place.mem_of_isIntegral_of_restrict"
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.ord_nonneg_of_isIntegral_of_restrict
+    [Algebra.IsIntegral E F] (w : Place K F)
+    {u : Place K E} (hw : w.restrict E = u)
+    (hA : ∀ a : A, algebraMap A E a ∈ u.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : 0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral_of_restrict hw hA hf)
+
+end Place
+p2m_export "AlgebraicCurve" "Place.ord_nonneg_of_isIntegral_of_restrict"
+namespace TranscendenceTower
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF poleDivisor RegularOutside hx_indep hxreg v \
+  mk.injEq mk hvdeg x hxv"
+end TranscendenceTower
+namespace TranscendenceTower
+p2m_open_scoped "AlgebraicCurve.TranscendenceTower" in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.ord_nonneg_of_isIntegral_of_regularOutside
+    [Algebra.IsIntegral E F] (T : TranscendenceTower K E F) (hA : T.RegularOutside A)
+    {f : F} (hf : IsIntegral A f) :
+    ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord f := fun w hw =>
+  w.ord_nonneg_of_isIntegral_of_restrict rfl (hA _ hw) hf
+
+end TranscendenceTower
+p2m_export "AlgebraicCurve" "TranscendenceTower.ord_nonneg_of_isIntegral_of_regularOutside"
+end Bridge
+
+section Headline
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F]
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+theorem linearIndependent_reindex_basis {s : Finset F} (b : Basis s E F) :
+    LinearIndependent E (fun i : Fin (Module.finrank E F) =>
+      b ((Fintype.equivFinOfCardEq (Module.finrank_eq_card_basis b).symm).symm i)) :=
+  b.linearIndependent.comp _ (Equiv.injective _)
+
+theorem hasIntegralBasisRegularOutside_of_isFractionRing
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    HasIntegralBasisRegularOutside K E F T := by
+  obtain ⟨s, b, hint⟩ := FiniteDimensional.exists_is_basis_integral A E F
+  set e : Fin (Module.finrank E F) ≃ s :=
+    (Fintype.equivFinOfCardEq (Module.finrank_eq_card_basis b).symm).symm
+  refine ⟨fun i => b (e i), linearIndependent_reindex_basis b, fun i w hw => ?_⟩
+  exact T.ord_nonneg_of_isIntegral_of_regularOutside hA (hint (e i)) w hw
+
+theorem hasIntegralBasisRegularOutside_of_hasRegularFractionSubring
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    HasIntegralBasisRegularOutside K E F T := by
+  obtain ⟨A, hfrac, hreg⟩ := h
+  have : IsFractionRing A E := hfrac
+  exact hasIntegralBasisRegularOutside_of_isFractionRing (A := A) T
+    (fun u hu a => hreg u hu (a : E) a.property)
+
+theorem hasPoleDivisorPackage_of_isFractionRing [HasPrincipalDivisors K F]
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside T
+    (hasIntegralBasisRegularOutside_of_isFractionRing T hA)
+
+theorem stichtenothGenusExists_of_isFractionRing [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasPoleDivisorPackage
+    (hasPoleDivisorPackage_of_isFractionRing T hA)
+
+theorem hasPoleDivisorPackage_of_hasRegularFractionSubring [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside T
+    (hasIntegralBasisRegularOutside_of_hasRegularFractionSubring T h)
+
+theorem stichtenothGenusExists_of_hasRegularFractionSubring [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasPoleDivisorPackage
+    (hasPoleDivisorPackage_of_hasRegularFractionSubring T h)
+
+namespace TranscendenceTower
+p2m_open_scoped "AlgebraicCurve.TranscendenceTower" in
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.adjoin_x_regularOutside (T :
+  TranscendenceTower K E F) :
+    ∀ u : Place K E, u ≠ T.v →
+      ∀ a ∈ Algebra.adjoin K {T.x}, a ∈ u.toValuationSubring := by
+  intro u hu a ha
+  let S : Subalgebra K E :=
+    { u.toValuationSubring.toSubsemiring with
+      algebraMap_mem' := u.algebraMap_mem' }
+  suffices h : a ∈ S from h
+  refine Algebra.adjoin_le ?_ ha
+  intro y hy
+  rw [Set.mem_singleton_iff] at hy
+  subst hy
+  change T.x ∈ u.toValuationSubring
+  exact AlgebraicCurve.Place.mem_of_ord_nonneg u T.x_ne_zero (T.hxreg u hu)
+
+end TranscendenceTower
+p2m_export "AlgebraicCurve" "TranscendenceTower.adjoin_x_regularOutside"
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+theorem hasRegularFractionSubring_of_adjoin_x_isFractionRing
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    HasRegularFractionSubring K E F T :=
+  ⟨Algebra.adjoin K {T.x}, hfrac, T.adjoin_x_regularOutside⟩
+
+theorem hasIntegralBasisRegularOutside_of_adjoin_x_isFractionRing
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    HasIntegralBasisRegularOutside K E F T :=
+  hasIntegralBasisRegularOutside_of_hasRegularFractionSubring T
+    (hasRegularFractionSubring_of_adjoin_x_isFractionRing T hfrac)
+
+theorem stichtenothGenusExists_of_adjoin_x_isFractionRing [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasRegularFractionSubring T
+    (hasRegularFractionSubring_of_adjoin_x_isFractionRing T hfrac)
+
+end Headline
+
+section Gates
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem gate_mem_of_isIntegral_recovers_comap (w : Place K F) (E : Type*) [Field E]
+    [Algebra E F] [Algebra.IsIntegral E F]
+    (hE : ∀ a : E, algebraMap E F a ∈ w.toValuationSubring) (f : F) :
+    f ∈ w.toValuationSubring := by
+  let : Algebra E w.toValuationSubring :=
+    ((algebraMap E F).codRestrict w.toValuationSubring.toSubring hE).toAlgebra
+  have : IsScalarTower E w.toValuationSubring F :=
+    IsScalarTower.of_algebraMap_eq fun _ => rfl
+  exact w.mem_of_isIntegral (Algebra.IsIntegral.isIntegral (R := E) f).tower_top
+
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+
+theorem gate_bridge_recovers_hxreg [Algebra.IsIntegral E F]
+    (T : TranscendenceTower K E F) (w : Place K F) (hw : w.restrict E ≠ T.v) :
+    0 ≤ w.ord T.xF := by
+  rw [TranscendenceTower.xF, Place.ord_restrict]
+  exact mul_nonneg (Int.natCast_nonneg _) (T.hxreg _ hw)
+
+theorem gate_regularOutside_mono (T : TranscendenceTower K E F) {A A' : Subalgebra K E}
+    (hle : A ≤ A')
+    (hA' : ∀ u : Place K E, u ≠ T.v → ∀ a ∈ A', a ∈ u.toValuationSubring) :
+    ∀ u : Place K E, u ≠ T.v → ∀ a ∈ A, a ∈ u.toValuationSubring :=
+  fun u hu a ha => hA' u hu a (hle ha)
+
+theorem gate_bot_regularOutside (T : TranscendenceTower K E F) :
+    ∀ u : Place K E, u ≠ T.v → ∀ a ∈ (⊥ : Subalgebra K E), a ∈ u.toValuationSubring := by
+  intro u _ a ha
+  obtain ⟨c, rfl⟩ := Algebra.mem_bot.mp ha
+  exact u.algebraMap_mem' c
+
+theorem gate_adjoin_x_not_regular_at_v (T : TranscendenceTower K E F) :
+    ¬ ∀ a ∈ Algebra.adjoin K {T.x}, a ∈ T.v.toValuationSubring := by
+  intro h
+  have hx := AlgebraicCurve.Place.ord_nonneg_of_mem T.v (h T.x (Algebra.subset_adjoin rfl))
+  rw [T.hxv] at hx
+  exact absurd hx (by decide)
+
+end Gates
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open Module Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+section Transcendental
+
+variable {K A : Type*} [CommRing K] [CommRing A] [Algebra K A]
+
+theorem linearIndependent_pow_of_transcendental {x : A} (hx : Transcendental K x) :
+    LinearIndependent K (fun j : ℕ => x ^ j) := by
+  have hinj : Function.Injective (Polynomial.aeval x : K[X] →ₐ[K] A) :=
+    transcendental_iff_injective.mp hx
+  have hXj : LinearIndependent K (fun j : ℕ => (X : K[X]) ^ j) := by
+    have hb := (Polynomial.basisMonomials K).linearIndependent
+    simp only [Polynomial.coe_basisMonomials] at hb
+    convert hb using 2 with j
+    exact (Polynomial.monomial_one_right_eq_X_pow j).symm
+  have heq : (fun j : ℕ => x ^ j)
+      = (fun j : ℕ => (Polynomial.aeval x : K[X] →ₐ[K] A) (X ^ j)) := by
+    funext j; simp
+  rw [heq]
+  exact hXj.map' (Polynomial.aeval x).toLinearMap
+    (LinearMap.ker_eq_bot_of_injective hinj)
+
+theorem transcendental_of_linearIndependent_pow {x : A}
+    (hx : LinearIndependent K (fun j : ℕ => x ^ j)) :
+    Transcendental K x := by
+  rw [transcendental_iff]
+  intro p hp
+  rw [Polynomial.aeval_eq_sum_range, ← Fin.sum_univ_eq_sum_range] at hp
+  ext j
+  rcases lt_or_ge j (p.natDegree + 1) with hj | hj
+  · exact (Fintype.linearIndependent_iff.mp
+      (hx.comp (Fin.val : Fin (p.natDegree + 1) → ℕ) Fin.val_injective))
+      (fun i => p.coeff i) hp ⟨j, hj⟩
+  · exact p.coeff_eq_zero_of_natDegree_lt (Nat.lt_of_succ_le hj)
+
+end Transcendental
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "algebraMap_mem_ofHeightOneSpectrum placeInfty \
+  ord_placeInfty deg_placeInfty eq_ofHeightOneSpectrum_or_eq_placeInfty"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+
+theorem ord_placeInfty_X : (placeInfty K).ord (RatFunc.X : RatFunc K) = -1 := by
+  rw [ord_placeInfty (K := K) RatFunc.X_ne_zero, RatFunc.intDegree_X]
+
+theorem algebraMap_polynomial_mem_of_ne_placeInfty
+    {u : Place K (RatFunc K)} (hu : u ≠ placeInfty K) (q : K[X]) :
+    algebraMap K[X] (RatFunc K) q ∈ u.toValuationSubring := by
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty u with ⟨w, hw⟩ | hw
+  · subst hw; exact algebraMap_mem_ofHeightOneSpectrum K w q
+  · exact absurd hw hu
+
+theorem ord_X_nonneg_of_ne_placeInfty
+    {u : Place K (RatFunc K)} (hu : u ≠ placeInfty K) :
+    0 ≤ u.ord (RatFunc.X : RatFunc K) := by
+  rw [← RatFunc.algebraMap_X]
+  exact AlgebraicCurve.Place.ord_nonneg_of_mem u (algebraMap_polynomial_mem_of_ne_placeInfty K hu
+    Polynomial.X)
+
+variable (F : Type*) [Field F] [Algebra K F] [Algebra (RatFunc K) F]
+  [IsScalarTower K (RatFunc K) F]
+
+def transcendenceTower : TranscendenceTower K (RatFunc K) F where
+  x := RatFunc.X
+  hx_indep := linearIndependent_pow_of_transcendental RatFunc.transcendental_X
+  v := placeInfty K
+  hvdeg := deg_placeInfty K
+  hxv := ord_placeInfty_X K
+  hxreg := fun _ hu => ord_X_nonneg_of_ne_placeInfty K hu
+
+@[scoped simp]
+theorem transcendenceTower_x : (transcendenceTower K F).x = RatFunc.X := rfl
+
+@[scoped simp]
+theorem transcendenceTower_v : (transcendenceTower K F).v = placeInfty K := rfl
+
+omit [DecidableEq (RatFunc K)] in
+theorem aeval_X_eq_algebraMap (q : K[X]) :
+    (Polynomial.aeval (R := K) (RatFunc.X : RatFunc K)) q
+      = algebraMap K[X] (RatFunc K) q := by
+  have hext : (Polynomial.aeval (R := K) (RatFunc.X : RatFunc K))
+      = IsScalarTower.toAlgHom K K[X] (RatFunc K) :=
+    Polynomial.algHom_ext (by simp [RatFunc.algebraMap_X])
+  rw [hext]; rfl
+
+omit [DecidableEq (RatFunc K)] in
+theorem algebraMap_polynomial_mem_adjoin_X (q : K[X]) :
+    algebraMap K[X] (RatFunc K) q ∈ Algebra.adjoin K {(RatFunc.X : RatFunc K)} := by
+  rw [Algebra.adjoin_singleton_eq_range_aeval]
+  exact ⟨q, aeval_X_eq_algebraMap K q⟩
+
+omit [DecidableEq (RatFunc K)] in
+theorem isFractionRing_adjoin_X :
+    IsFractionRing (Algebra.adjoin K {(RatFunc.X : RatFunc K)}) (RatFunc K) := by
+  refine IsFractionRing.of_field _ _ fun z => ?_
+  refine ⟨⟨algebraMap K[X] (RatFunc K) z.num, algebraMap_polynomial_mem_adjoin_X K z.num⟩,
+    ⟨algebraMap K[X] (RatFunc K) z.denom, algebraMap_polynomial_mem_adjoin_X K z.denom⟩, ?_⟩
+  change z = algebraMap K[X] (RatFunc K) z.num / algebraMap K[X] (RatFunc K) z.denom
+  exact z.num_div_denom.symm
+
+theorem hasRegularFractionSubring :
+    HasRegularFractionSubring K (RatFunc K) F (transcendenceTower K F) :=
+  hasRegularFractionSubring_of_adjoin_x_isFractionRing
+    (transcendenceTower K F) (isFractionRing_adjoin_X K)
+
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+
+theorem hasIntegralBasisRegularOutside :
+    HasIntegralBasisRegularOutside K (RatFunc K) F (transcendenceTower K F) :=
+  hasIntegralBasisRegularOutside_of_adjoin_x_isFractionRing
+    (transcendenceTower K F) (isFractionRing_adjoin_X K)
+
+section PrincipalDivisors
+
+variable [HasPrincipalDivisors K F]
+
+omit [DecidableEq (RatFunc K)] in
+theorem hasPoleDivisorPackage_of_ratFunc_tower :
+    HasPoleDivisorPackage K F := by
+  classical
+  exact
+    hasPoleDivisorPackage_of_hasRegularFractionSubring
+      (transcendenceTower K F) (hasRegularFractionSubring K F)
+
+end PrincipalDivisors
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+omit [DecidableEq (RatFunc K)] in
+theorem stichtenothGenusExists_of_ratFunc_tower_port :
+    StichtenothGenusExists K F := by
+  classical
+  exact
+    stichtenothGenusExists_of_adjoin_x_isFractionRing
+      (transcendenceTower K F) (isFractionRing_adjoin_X K)
+
+omit [DecidableEq (RatFunc K)] in
+theorem indexOfSpecialtyFinite_of_ratFunc_tower :
+    IndexOfSpecialtyFinite K F := by
+  classical
+  exact
+    indexOfSpecialtyFinite_of_stichtenothGenusExists
+      (stichtenothGenusExists_of_ratFunc_tower_port K F)
+
+end RationalFunctionField
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open Module Polynomial IsDedekindDomain
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "algebraMap_mem_ofHeightOneSpectrum placeInfty \
+  ord_placeInfty deg_placeInfty eq_ofHeightOneSpectrum_or_eq_placeInfty"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+variable (F : Type*) [Field F] [Algebra K F] [Algebra (RatFunc K) F]
+  [IsScalarTower K (RatFunc K) F]
+
+section LyingOver
+
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+
+omit [DecidableEq (RatFunc K)] in
+omit [DecidableEq (RatFunc K)] in
+private theorem _root_.AlgebraicCurve.RationalFunctionField.exists_restrict_eq (v : Place K (RatFunc
+  K)) :
+    ∃ w : Place K F, w.restrict (RatFunc K) = v :=
+  Place.exists_restrict_eq v
+
+p2m_export "AlgebraicCurve.RationalFunctionField" "exists_restrict_eq"
+
+omit [DecidableEq (RatFunc K)] in
+theorem nonempty_place_of_ratFunc_tower : Nonempty (Place K F) := by
+  classical
+  exact
+    (exists_restrict_eq K F (placeInfty K)).nonempty
+
+end LyingOver
+
+omit [DecidableEq (RatFunc K)] [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F] in
+theorem finiteDimensional_lSpace_zero_of_constantsAreBase (hC : ConstantsAreBase K F) :
+    FiniteDimensional K (LSpace (0 : Divisor K F)) := by
+  rw [show LSpace (0 : Divisor K F) = LinearMap.range (Algebra.linearMap K F) from hC]
+  exact LinearMap.finiteDimensional_range _
+
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+variable [IsCurveOver K F]
+
+omit [DecidableEq (RatFunc K)] in
+theorem stichtenothGenusExists (hC : ConstantsAreBase K F) :
+    StichtenothGenusExists K F := by
+  classical
+  exact
+    haveI := nonempty_place_of_ratFunc_tower K F
+    haveI := finiteDimensional_lSpace_zero_of_constantsAreBase K F hC
+    stichtenothGenusExists_of_ratFunc_tower_port K F
+
+omit [DecidableEq (RatFunc K)] in
+theorem indexOfSpecialtyFinite (hC : ConstantsAreBase K F) :
+    IndexOfSpecialtyFinite K F := by
+  classical
+  exact
+    indexOfSpecialtyFinite_of_stichtenothGenusExists (stichtenothGenusExists K F hC)
+
+omit [DecidableEq (RatFunc K)] in
+theorem riemannGenusBounded (hC : ConstantsAreBase K F) : RiemannGenusBounded K F := by
+  classical
+  exact
+    haveI := nonempty_place_of_ratFunc_tower K F
+    haveI := finiteDimensional_lSpace_zero_of_constantsAreBase K F hC
+    riemannGenusBounded_of_poleDivisorPackage (hasPoleDivisorPackage_of_ratFunc_tower K F).some
+
+end RationalFunctionField
+end AlgebraicCurve
+end
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg\
+  " in
+open
+  _root_.P2MW.S_OVERLONG_f94f10e8.AlgebraicCurve
+  Polynomial in
+theorem solution (K : Type*) [Field K] (F : Type*) [Field F] [Algebra K F]
+    [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F] [FiniteDimensional (RatFunc K) F]
+    [Algebra.IsSeparable (RatFunc K) F] [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] :
+    StichtenothGenusExists K F := by
+  classical
+  exact
+    AlgebraicCurve.RationalFunctionField.stichtenothGenusExists_of_ratFunc_tower_port (K := K) (F :=
+        F)
+
+end S_OVERLONG_f94f10e8
+end P2MW
+export P2MW.S_OVERLONG_f94f10e8
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.RationalFunctionField.stichtenothGenusExists_of_ratFunc_tower (K : Type*)
+    [Field K]
+    (F : Type*) [Field F] [Algebra K F] [Algebra (RatFunc K) F]
+    [IsScalarTower K (RatFunc K) F] [FiniteDimensional (RatFunc K) F]
+    [Algebra.IsSeparable (RatFunc K) F]
+    [AlgebraicCurve.IsCurveOver K F] [Nonempty (AlgebraicCurve.Place K F)]
+    [FiniteDimensional K (AlgebraicCurve.LSpace (0 : AlgebraicCurve.Divisor K F))] :
+    AlgebraicCurve.StichtenothGenusExists K F := by
+  classical
+  exact
+    solution K F
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_subsingleton_setOf_forall_ne_ofHeightOneSpectrum.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_subsingleton_setOf_forall_ne_ofHeightOneSpectrum.lean
new file mode 100644
index 0000000000..9d3355cbf8
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_subsingleton_setOf_forall_ne_ofHeightOneSpectrum.lean
@@ -0,0 +1,246 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.RationalFunctionField.subsingleton_setOf_forall_ne_ofHeightOneSpectrum
+(6909b602-2efa-5ea4-b2ec-e54556b62997) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 21545100-5620-5552-97d0-901ecbf0b692
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.NumberTheory.RatFunc.Ostrowski
+import Mathlib.RingTheory.DedekindDomain.Factorization
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# At most one place of K(t)/K is not finite
+
+Theorem statement:
+`AlgebraicCurve.RationalFunctionField.subsingleton_setOf_forall_ne_ofHeightOneSpectrum`
+(`6909b602-2efa-5ea4-b2ec-e54556b62997`), by Claude, 2026-09-05.
+
+Proof: submission `21545100-5620-5552-97d0-901ecbf0b692`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, and consider the rational function field $\mathrm{RatFunc}\,K$ in one variable
+over $K$. Here a place of $\mathrm{RatFunc}\,K$ over $K$, i.e. an element of `Place K (RatFunc K)`,
+is by definition a valuation subring $\mathcal O$ of $\mathrm{RatFunc}\,K$ such that the image of
+every element of $K$ under the structure map $K \to \mathrm{RatFunc}\,K$ lies in $\mathcal O$, such
+that $\mathcal O \neq \mathrm{RatFunc}\,K$, and such that $\mathcal O$ is a principal ideal ring.
+For a height-one prime $w$ of the polynomial ring $K[X]$, the place `Place.ofHeightOneSpectrum w` is
+the valuation subring of the $w$-adic valuation of $\mathrm{RatFunc}\,K$ (the fraction field of
+$K[X]$). The assertion is that the set of those places $v$ of $\mathrm{RatFunc}\,K$ over $K$ with $v
+\neq$ `Place.ofHeightOneSpectrum w` for every height-one prime $w$ of $K[X]$ is a subsingleton: any
+two such places coincide. The statement is the uniqueness half only; no place at infinity is named,
+and the existence of a non-finite place is not part of the conclusion.
+
+This is the uniqueness part of Ostrowski's classification of the places of the rational function
+field: the closed points of $\mathbb A^1_K$, i.e. the height-one primes of $K[X]$, account for all
+places of $K(t)/K$ except at most one, the place at infinity. It is used in the treatment of
+divisors on $\mathbb P^1_K$, for instance in
+[`AlgebraicCurve.Place.finite_setOf_deg_eq`](thm.html#AlgebraicCurve.Place.finite_setOf_deg_eq),
+[`AlgebraicCurve.RationalFunctionField.deg_eq_one_of_isAlgClosed`]
+(thm.html#AlgebraicCurve.RationalFunctionField.deg_eq_one_of_isAlgClosed)
+and
+[`AlgebraicCurve.RationalFunctionField.degree_eq_zero_of_forall_eq_ord_algebraMap`]
+(thm.html#AlgebraicCurve.RationalFunctionField.degree_eq_zero_of_forall_eq_ord_algebraMap).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_subsingleton_setOf_forall_ne_ofHeightOneSpectrum.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_2a3d6b2b
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing
+open scoped Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ext Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext heightOneSpectrum adicValuation adicValuation_ne_zero ord \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring isPrincipalIdealRing'"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.adicValuation_valuationSubring' :
+    v.adicValuation.valuationSubring = v.toValuationSubring := by
+  ext x
+  rw [Valuation.mem_valuationSubring_iff]
+  constructor
+  · intro hx
+    obtain ⟨a, rfl⟩ := IsDiscreteValuationRing.exists_lift_of_le_one hx
+    exact a.2
+  · intro hx
+    exact v.heightOneSpectrum.valuation_le_one (⟨x, hx⟩ : v.toValuationSubring)
+
+p2m_export "AlgebraicCurve.Place" "adicValuation_valuationSubring'"
+private theorem _root_.AlgebraicCurve.Place.mem_iff_adicValuation_le_one' {f : F} :
+    f ∈ v.toValuationSubring ↔ v.adicValuation f ≤ 1 := by
+  rw [← v.adicValuation_valuationSubring']
+  exact Valuation.mem_valuationSubring_iff _ _
+
+p2m_export "AlgebraicCurve.Place" "mem_iff_adicValuation_le_one'"
+private theorem _root_.AlgebraicCurve.Place.adicValuation_isRankOneDiscrete' :
+    v.adicValuation.IsRankOneDiscrete :=
+  IsDiscreteValuationRing.isRankOneDiscrete v.toValuationSubring F
+
+p2m_export "AlgebraicCurve.Place" "adicValuation_isRankOneDiscrete'"
+private theorem _root_.AlgebraicCurve.Place.adicValuation_isTrivialOn' :
+    v.adicValuation.IsTrivialOn K :=
+  Valuation.IsTrivialOn.of_le_one v.adicValuation fun a =>
+    v.mem_iff_adicValuation_le_one'.mp (v.algebraMap_mem' a)
+
+p2m_export "AlgebraicCurve.Place" "adicValuation_isTrivialOn'"
+private theorem _root_.AlgebraicCurve.Place.isEquiv_adicValuation_of_valuationSubring_eq' {Γ :
+  Type*}
+    [LinearOrderedCommGroupWithZero Γ] {w : Valuation F Γ}
+    (h : w.valuationSubring = v.toValuationSubring) : w.IsEquiv v.adicValuation :=
+  (Valuation.isEquiv_iff_valuationSubring _ _).mpr
+    (h.trans v.adicValuation_valuationSubring'.symm)
+
+p2m_export "AlgebraicCurve.Place" "isEquiv_adicValuation_of_valuationSubring_eq'"
+private theorem ord_eq_zero_iff_adicValuation_eq_one' {f : F} (hf : f ≠ 0) :
+    v.ord f = 0 ↔ v.adicValuation f = 1 := by
+  simp only [ord, neg_eq_zero]
+  constructor
+  · intro h
+    have h2 := exp_log (v.adicValuation_ne_zero hf)
+    rw [h, exp_zero] at h2
+    exact h2.symm
+  · intro h
+    rw [h, log_one]
+
+section OfHeightOneSpectrum
+
+variable {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R F] [IsFractionRing R F]
+  [Algebra K R] [IsScalarTower K R F]
+
+private theorem isEquiv_adicValuation_ofHeightOneSpectrum' (w : HeightOneSpectrum R) :
+    (w.valuation F).IsEquiv (ofHeightOneSpectrum (K := K) w).adicValuation :=
+  (ofHeightOneSpectrum (K := K) w).isEquiv_adicValuation_of_valuationSubring_eq' rfl
+
+end OfHeightOneSpectrum
+
+end Place
+
+namespace RationalFunctionField
+
+variable (K : Type*) [Field K]
+
+section PlaceInfty
+
+variable [DecidableEq (RatFunc K)]
+
+private theorem nontrivial_valueGroup_inftyValuation :
+    Nontrivial (MonoidWithZeroHom.valueGroup (.ofClass (RatFunc.inftyValuation K))) := by
+  rw [Subgroup.nontrivial_iff_exists_ne_one]
+  refine ⟨Units.mk0 (RatFunc.inftyValuation K RatFunc.X)
+    (by rw [RatFunc.inftyValuation.X]; exact exp_ne_zero), ?_, ?_⟩
+  · exact MonoidWithZeroHom.mem_valueGroup _ ⟨RatFunc.X, rfl⟩
+  · rw [ne_eq, Units.ext_iff, Units.val_mk0, Units.val_one, RatFunc.inftyValuation.X]
+    simp
+
+private def placeInfty' : Place K (RatFunc K) where
+  toValuationSubring := (RatFunc.inftyValuation K).valuationSubring
+  algebraMap_mem' a := by
+    rw [Valuation.mem_valuationSubring_iff]
+    exact Valuation.IsTrivialOn.valuation_algebraMap_le_one (v := RatFunc.inftyValuation K) a
+  ne_top' := by
+    have := nontrivial_valueGroup_inftyValuation K
+    simp only [ne_eq, Valuation.valuationSubring_eq_top_iff, not_not]
+    infer_instance
+  isPrincipalIdealRing' :=
+    haveI := nontrivial_valueGroup_inftyValuation K
+    (Valuation.valuationSubring_isDiscreteValuationRing
+      (RatFunc.inftyValuation K)).toIsPrincipalIdealRing
+
+private theorem placeInfty'_ne_ofHeightOneSpectrum (w : HeightOneSpectrum K[X]) :
+    placeInfty' K ≠ Place.ofHeightOneSpectrum w := by
+  intro h
+  refine RatFunc.adicValuation_not_isEquiv_infty_valuation w
+    ((Valuation.isEquiv_iff_valuationSubring _ _).mpr ?_)
+  have h2 := congrArg Place.toValuationSubring h
+  rw [Place.ofHeightOneSpectrum_toValuationSubring] at h2
+  exact h2.symm
+
+end PlaceInfty
+
+variable {K}
+
+private theorem eq_ofHeightOneSpectrum_or_eq_placeInfty' [DecidableEq (RatFunc K)]
+    (v : Place K (RatFunc K)) :
+    (∃ w : HeightOneSpectrum K[X], v = Place.ofHeightOneSpectrum w) ∨ v = placeInfty' K := by
+  have := v.adicValuation_isRankOneDiscrete'
+  have := v.adicValuation_isTrivialOn'
+  rcases (RatFunc.valuation_isEquiv_infty_or_adic (v := v.adicValuation)).or with h | h
+  · exact Or.inr (Place.ext (v.adicValuation_valuationSubring'.symm.trans
+      ((Valuation.isEquiv_iff_valuationSubring _ _).mp h)))
+  · obtain ⟨w, hw, -⟩ := h
+    exact Or.inl ⟨w, Place.ext (v.adicValuation_valuationSubring'.symm.trans
+      ((Valuation.isEquiv_iff_valuationSubring _ _).mp hw))⟩
+
+theorem rowMain :
+    {v : Place K (RatFunc K) |
+      ∀ w : HeightOneSpectrum K[X], v ≠ Place.ofHeightOneSpectrum w}.Subsingleton := by
+  classical
+  intro v hv v' hv'
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty' v with ⟨w, h⟩ | h
+  · exact absurd h (hv w)
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty' v' with ⟨w, h'⟩ | h'
+  · exact absurd h' (hv' w)
+  rw [h, h']
+
+end RationalFunctionField
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_OVERLONG_2a3d6b2b.AlgebraicCurve
+  in
+theorem solution {K : Type*} [Field K] :
+    {v : Place K (RatFunc K) | ∀ w : IsDedekindDomain.HeightOneSpectrum (Polynomial K), v ≠
+      Place.ofHeightOneSpectrum w}.Subsingleton :=
+  AlgebraicCurve.RationalFunctionField.rowMain
+
+end S_OVERLONG_2a3d6b2b
+end P2MW
+export P2MW.S_OVERLONG_2a3d6b2b
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.RationalFunctionField.subsingleton_setOf_forall_ne_ofHeightOneSpectrum
+    {K : Type*} [Field K] :
+    {v : Place K (RatFunc K) | ∀ w : IsDedekindDomain.HeightOneSpectrum (Polynomial K), v ≠
+      Place.ofHeightOneSpectrum w}.Subsingleton :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_toValuationSubring_eq_of_forall_ne_ofHeightOneSpectrum.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_toValuationSubring_eq_of_forall_ne_ofHeightOneSpectrum.lean
new file mode 100644
index 0000000000..9b1cdb1749
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_RationalFunctionField_toValuationSubring_eq_of_forall_ne_ofHeightOneSpectrum.lean
@@ -0,0 +1,103 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.RationalFunctionField.toValuationSubring_eq_of_forall_ne_ofHeightOneSpectrum
+(b16d57bd-64f3-5e5d-9a5b-eee948a2c874) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1a0a4486-f528-5d32-9478-0270db9fe56b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Valuation
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.NumberTheory.RatFunc.Ostrowski
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_adicValuation_valuationSubring
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_adicValuation_isRankOneDiscrete
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_adicValuation_isTrivialOn
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Places of K(t)/K other than the finite ones lie at infinity
+
+Theorem statement:
+`AlgebraicCurve.RationalFunctionField.toValuationSubring_eq_of_forall_ne_ofHeightOneSpectrum`
+(`b16d57bd-64f3-5e5d-9a5b-eee948a2c874`), by Claude, 2026-09-05.
+
+Proof: submission `1a0a4486-f528-5d32-9478-0270db9fe56b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $v$ be a place of the rational function field $\mathrm{RatFunc}\,K$ over
+$K$ in the sense of the project structure `Place`: a datum consisting of a valuation subring
+$v.\mathrm{toValuationSubring}$ of $\mathrm{RatFunc}\,K$ which contains the image of $K$ under the
+structure map, which is not the whole field, and which is a principal ideal ring. Assume that for
+every height-one prime $w$ of the polynomial ring $K[X]$ the place $v$ differs from
+`Place.ofHeightOneSpectrum w`, the place whose valuation subring is that of the $w$-adic valuation
+of $K[X]$ extended to its fraction field $\mathrm{RatFunc}\,K$. The conclusion is an equality of
+subrings of $\mathrm{RatFunc}\,K$: $v.\mathrm{toValuationSubring}$ equals the valuation subring of
+Mathlib's valuation at infinity `RatFunc.inftyValuation K`, i.e. the ring of rational functions
+whose numerator degree does not exceed its denominator degree. The hypothesis is a statement about
+places, not merely about valuation subrings, and the conclusion identifies only the subring, not a
+normalised valuation.
+
+This is the classification of the places of the rational function field $K(t)$ trivial on $K$ (the
+function-field analogue of Ostrowski's theorem): the finite places come from the height-one primes
+of $K[X]$, and the remaining one is the place at infinity. It is used in the divisor-theoretic
+treatment of $\mathbb{P}^1$, where it feeds the computation of the degree of the place at infinity
+and of the order function attached to it at that place.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_toValuationSubring_eq_of_forall_ne_ofHeightOneSpectrum.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_168df5ef
+
+open AlgebraicCurve
+open IsDedekindDomain WithZero IsLocalRing
+open scoped Polynomial
+
+theorem solution {K : Type*} [Field K] [DecidableEq (RatFunc K)] (v : Place K (RatFunc K))
+    (hv : ∀ w : IsDedekindDomain.HeightOneSpectrum (Polynomial K), v ≠ Place.ofHeightOneSpectrum w)
+    :
+    v.toValuationSubring = (RatFunc.inftyValuation K).valuationSubring := by
+  have := v.adicValuation_isRankOneDiscrete
+  have := v.adicValuation_isTrivialOn
+  rcases (RatFunc.valuation_isEquiv_infty_or_adic (v := v.adicValuation)).or with h | h
+  · exact v.adicValuation_valuationSubring.symm.trans
+      ((Valuation.isEquiv_iff_valuationSubring _ _).mp h)
+  · obtain ⟨w, hw, -⟩ := h
+    exact absurd (Place.ext (v.adicValuation_valuationSubring.symm.trans
+      ((Valuation.isEquiv_iff_valuationSubring _ _).mp hw))) (hv w)
+
+end S_OVERLONG_168df5ef
+end P2MW
+export
+  P2MW.S_OVERLONG_168df5ef
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.RationalFunctionField.toValuationSubring_eq_of_forall_ne_ofHeightOneSpectrum
+    {K : Type*} [Field K] [DecidableEq (RatFunc K)] (v : Place K (RatFunc K))
+    (hv : ∀ w : IsDedekindDomain.HeightOneSpectrum (Polynomial K), v ≠ Place.ofHeightOneSpectrum w)
+    :
+    v.toValuationSubring = (RatFunc.inftyValuation K).valuationSubring :=
+  solution v hv
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_SemilinearAut_inertiaDeg_smul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_SemilinearAut_inertiaDeg_smul.lean
new file mode 100644
index 0000000000..8821ebd60f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_SemilinearAut_inertiaDeg_smul.lean
@@ -0,0 +1,142 @@
+/-
+Based on Prove2Me node AlgebraicCurve.SemilinearAut.inertiaDeg_smul
+(251f8687-be65-5238-922c-b868e9175bff) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission db6d5cc5-36ba-5be1-9c60-6833cc578381
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Invariance of inertia degree under intertwined semilinear automorphisms
+
+Theorem statement: `AlgebraicCurve.SemilinearAut.inertiaDeg_smul`
+(`251f8687-be65-5238-922c-b868e9175bff`), by Claude, 2026-09-05.
+
+Proof: submission `db6d5cc5-36ba-5be1-9c60-6833cc578381`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $F'$ be fields with $F$ and $F'$ algebras over $K$ and $F'$ an algebra over $F$, the
+three structure maps forming a scalar tower, and with $F'$ integral over $F$. Here a semilinear
+automorphism in `SemilinearAut K F` is a pair $(\sigma,\tau)$ consisting of a ring automorphism
+$\sigma$ of $F$ and a ring automorphism $\tau$ of $K$ such that $\sigma(\iota_{K,F}(a)) =
+\iota_{K,F}(\tau a)$ for all $a \in K$, these pairs forming a subgroup of $\mathrm{Aut}(F) \times
+\mathrm{Aut}(K)$, and likewise for `SemilinearAut K F'`. Given $g \in$ `SemilinearAut K F` and $g'
+\in$ `SemilinearAut K F'` satisfying `IntertwinesAlong`, that is $g' \cdot \iota_{F,F'}(x) =
+\iota_{F,F'}(g \cdot x)$ for every $x \in F$, and given a place $w$ of $F'$ over $K$ (a valuation
+subring of $F'$, distinct from $F'$, containing the image of $K$, and a principal ideal ring), the
+conclusion is the equality of inertia degrees $f(g' \cdot w \mid F) = f(w \mid F)$, where $g' \cdot
+w$ is the pointwise translate of $w$ by $g'$ and where $f(\,\cdot \mid F)$ denotes the dimension, as
+a vector space over the residue field of the place of $F$ obtained by pulling the given place back
+along $\iota_{F,F'}$, of the residue field of that place of $F'$.
+
+This is the invariance of the residue (inertia) degree in a tower $F \subseteq F'$ under a
+compatible pair of semilinear automorphisms of $F$ and $F'$; it is the residue-degree half of the
+statement that such a pair acts on places compatibly with the tower. It is used for
+[`AlgebraicCurve.Place.inertiaDeg_eq_of_restrict_eq`]
+(thm.html#AlgebraicCurve.Place.inertiaDeg_eq_of_restrict_eq)
+and for
+[`AlgebraicCurve.SemilinearAut.pushforward_smul`]
+(thm.html#AlgebraicCurve.SemilinearAut.pushforward_smul).
+The inertia degree is a vector-space dimension, so it takes the value $0$ on infinite residue
+extensions; the assertion is an equality of the two dimensions and carries no finiteness
+information.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_SemilinearAut_inertiaDeg_smul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_SemilinearAut_inertiaDeg_smul
+
+open AlgebraicCurve AlgebraicCurve.SemilinearAut
+open scoped Pointwise
+
+noncomputable section
+
+private def restrictSmulValuationSubringEquiv {K F F' : Type*} [Field K] [Field F] [Field F']
+    [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F'] [Algebra.IsIntegral F F']
+    {g : SemilinearAut K F} {g' : SemilinearAut K F'}
+    (hgg' : IntertwinesAlong (algebraMap F F') g g')
+    (w : Place K F') :
+    (w.restrict F).toValuationSubring ≃+* ((g' • w).restrict F).toValuationSubring where
+  toFun x := ⟨g • (x : F), by
+    change algebraMap F F' (g • (x : F)) ∈ (g' • w).toValuationSubring
+    rw [← hgg' (x : F), smul_toValuationSubring]
+    exact ValuationSubring.smul_mem_pointwise_smul g' _ _ x.2⟩
+  invFun y := ⟨g⁻¹ • (y : F), by
+    change algebraMap F F' (g⁻¹ • (y : F)) ∈ w.toValuationSubring
+    rw [← hgg'.inv (y : F)]
+    have hy : algebraMap F F' (y : F) ∈ (g' • w).toValuationSubring := y.2
+    rw [smul_toValuationSubring,
+      ValuationSubring.mem_pointwise_smul_iff_inv_smul_mem] at hy
+    exact hy⟩
+  left_inv x := by ext; exact inv_smul_smul g (x : F)
+  right_inv y := by ext; exact smul_inv_smul g (y : F)
+  map_mul' x y := by ext; exact smul_mul' g (x : F) (y : F)
+  map_add' x y := by ext; exact smul_add g (x : F) (y : F)
+
+@[scoped simp]
+private theorem coe_restrictSmulValuationSubringEquiv_apply {K F F' : Type*} [Field K] [Field F]
+    [Field F'] [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+    [Algebra.IsIntegral F F'] {g : SemilinearAut K F} {g' : SemilinearAut K F'}
+    (hgg' : IntertwinesAlong (algebraMap F F') g g') (w : Place K F')
+    (x : (w.restrict F).toValuationSubring) :
+    ((restrictSmulValuationSubringEquiv hgg' w x :
+      ((g' • w).restrict F).toValuationSubring) : F) = g • (x : F) :=
+  rfl
+
+theorem solution {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+    [Algebra F F'] [IsScalarTower K F F'] [Algebra.IsIntegral F F'] {g : SemilinearAut K F}
+    {g' : SemilinearAut K F'} (hgg' : IntertwinesAlong (algebraMap F F') g g') (w : Place K F') :
+    (g' • w).inertiaDeg F = w.inertiaDeg F := by
+  refine (Algebra.finrank_eq_of_equiv_equiv
+    (IsLocalRing.ResidueField.mapEquiv (restrictSmulValuationSubringEquiv hgg' w))
+    (smulResidueRingEquiv g' w) ?_).symm
+  ext x
+  obtain ⟨a, rfl⟩ := Ideal.Quotient.mk_surjective x
+  change (Place.restrictResidueMap F (g' • w))
+        (IsLocalRing.ResidueField.map _ (IsLocalRing.residue _ a))
+      = (smulResidueRingEquiv g' w) ((Place.restrictResidueMap F w) (IsLocalRing.residue _ a))
+  rw [IsLocalRing.ResidueField.map_residue, Place.restrictResidueMap_residue,
+    Place.restrictResidueMap_residue, smulResidueRingEquiv,
+    IsLocalRing.ResidueField.mapEquiv_apply, IsLocalRing.ResidueField.map_residue]
+  refine congrArg _ (Subtype.ext ?_)
+  change algebraMap F F' (g • (a : F)) = g' • (algebraMap F F' (a : F))
+  exact (hgg' (a : F)).symm
+
+end
+
+end S_AlgebraicCurve_SemilinearAut_inertiaDeg_smul
+end P2MW
+export P2MW.S_AlgebraicCurve_SemilinearAut_inertiaDeg_smul (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve AlgebraicCurve.SemilinearAut
+theorem AlgebraicCurve.SemilinearAut.inertiaDeg_smul {K F F' : Type*} [Field K] [Field F] [Field F']
+    [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F'] [Algebra.IsIntegral F F']
+    {g : SemilinearAut K F} {g' : SemilinearAut K F'}
+    (hgg' : IntertwinesAlong (algebraMap F F') g g') (w : Place K F') :
+    (g' • w).inertiaDeg F = w.inertiaDeg F :=
+  solution hgg' w
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_SemilinearAut_ord_algebraMap_smul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_SemilinearAut_ord_algebraMap_smul.lean
new file mode 100644
index 0000000000..4167b47e65
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_SemilinearAut_ord_algebraMap_smul.lean
@@ -0,0 +1,94 @@
+/-
+Based on Prove2Me node AlgebraicCurve.SemilinearAut.ord_algebraMap_smul
+(efeaf7d0-be37-5ce2-98dc-743bf6ddda48) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 242bea13-f29e-53ae-9a1a-356922a8bd1d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order at a transported place of an element from the subfield
+
+Theorem statement: `AlgebraicCurve.SemilinearAut.ord_algebraMap_smul`
+(`efeaf7d0-be37-5ce2-98dc-743bf6ddda48`), by Claude, 2026-09-05.
+
+Proof: submission `242bea13-f29e-53ae-9a1a-356922a8bd1d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $F'$ be fields with $F$ and $F'$ algebras over $K$ and $F'$ an algebra over $F$. Let
+$g$ be an element of `SemilinearAut K F`, that is, a pair consisting of a ring automorphism of $F$
+and a ring automorphism of $K$ that are compatible with the structure map $K \to F$ (the
+automorphism of $F$ sends the image of $a \in K$ to the image of the $K$-automorphism applied to
+$a$), and likewise let $g'$ be an element of `SemilinearAut K F'`. Assume `IntertwinesAlong
+(algebraMap F F') g g'`, i.e. $g' \cdot (\iota x) = \iota (g \cdot x)$ for every $x \in F$, where
+$\iota =$ `algebraMap F F'`. Let $w$ be a place of $F'$ over $K$, namely a valuation subring of $F'$
+which contains the image of $K$, is not all of $F'$, and is a principal ideal ring; and let $f \in
+F$. Then the order of $\iota f$ at the place $g' \cdot w$ obtained by transporting $w$ by $g'$
+equals the order of $\iota(g^{-1} \cdot f)$ at $w$, where the order of an element at a place is the
+negative of the logarithm of the value of the associated adic valuation.
+
+This is the formal compatibility, for semilinear automorphisms intertwined along a field extension
+$F \subseteq F'$, between transport of places and the induced action on elements coming from the
+subfield: the order at the transported place of an element of $F$ is the order at the original place
+of the inversely transported element. It is used in the corresponding statement for ramification
+indices,
+[`AlgebraicCurve.SemilinearAut.ramificationIndex_smul`]
+(thm.html#AlgebraicCurve.SemilinearAut.ramificationIndex_smul).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_SemilinearAut_ord_algebraMap_smul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_SemilinearAut_ord_algebraMap_smul
+
+open AlgebraicCurve AlgebraicCurve.SemilinearAut
+open scoped Pointwise
+
+noncomputable section
+
+theorem solution {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+    [Algebra F F'] {g : SemilinearAut K F} {g' : SemilinearAut K F'}
+    (hgg' : IntertwinesAlong (algebraMap F F') g g') (w : Place K F') (f : F) :
+    (g' • w).ord (algebraMap F F' f) = w.ord (algebraMap F F' (g⁻¹ • f)) := by
+  have hrw : algebraMap F F' f = g' • (algebraMap F F' (g⁻¹ • f)) := by
+    rw [hgg' (g⁻¹ • f), smul_inv_smul]
+  rw [hrw]
+  exact ord_smul g' w _
+
+end
+
+end S_AlgebraicCurve_SemilinearAut_ord_algebraMap_smul
+end P2MW
+export P2MW.S_AlgebraicCurve_SemilinearAut_ord_algebraMap_smul (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve AlgebraicCurve.SemilinearAut
+theorem AlgebraicCurve.SemilinearAut.ord_algebraMap_smul {K F F' : Type*} [Field K] [Field F]
+    [Field F'] [Algebra K F] [Algebra K F'] [Algebra F F'] {g : SemilinearAut K F}
+    {g' : SemilinearAut K F'} (hgg' : IntertwinesAlong (algebraMap F F') g g') (w : Place K F')
+    (f : F) :
+    (g' • w).ord (algebraMap F F' f) = w.ord (algebraMap F F' (g⁻¹ • f)) :=
+  solution hgg' w f
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_SemilinearAut_ramificationIndex_smul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_SemilinearAut_ramificationIndex_smul.lean
new file mode 100644
index 0000000000..11c77614d6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_SemilinearAut_ramificationIndex_smul.lean
@@ -0,0 +1,99 @@
+/-
+Based on Prove2Me node AlgebraicCurve.SemilinearAut.ramificationIndex_smul
+(9729c55e-17db-51a6-afca-e2c5ed8bb2b5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a2ee7daf-860f-56f9-b9f4-910360cbf327
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_SemilinearAut_ord_algebraMap_smul
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Ramification index is invariant under intertwined semilinear automorphisms
+
+Theorem statement: `AlgebraicCurve.SemilinearAut.ramificationIndex_smul`
+(`9729c55e-17db-51a6-afca-e2c5ed8bb2b5`), by Claude, 2026-09-05.
+
+Proof: submission `a2ee7daf-860f-56f9-b9f4-910360cbf327`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $F'$ be fields with $F$ and $F'$ algebras over $K$ and $F'$ an algebra over $F$. Let
+$g$ be an element of `SemilinearAut K F`, that is a pair consisting of a ring automorphism of $F$
+and a ring automorphism of $K$ which are compatible with the structure map $K \to F$, and let $g'$
+be such a pair for $F'$ over $K$. Assume `IntertwinesAlong (algebraMap F F') g g'`: for every $x \in
+F$ one has $g' \cdot (\mathrm{alg}_{F \to F'}(x)) = \mathrm{alg}_{F \to F'}(g \cdot x)$, the actions
+being those of the two semilinear automorphisms on $F'$ and on $F$ respectively. Let $w$ be a place
+of $F'$ over $K$, i.e. a valuation subring of $F'$ which contains the image of $K$, is not all of
+$F'$, and is a principal ideal ring. Then the ramification index over $F$ of the translated place
+$g' \cdot w$ equals that of $w$, where the ramification index of a place $u$ of $F'$ relative to $F$
+is by definition the infimum of the set of natural numbers $n$ with $n > 0$ for which there exists
+$f \in F$, $f \neq 0$, with $u.\mathrm{ord}(\mathrm{alg}_{F \to F'}(f)) = n$.
+
+This is the invariance of the ramification index $e(w \mid F)$ under a compatible (intertwined) pair
+of semilinear automorphisms of the two function fields, in the setting where $F'$ is given as an
+$F$-algebra. It is used in the Galois/base-change bookkeeping for places on curves, in particular in
+the comparison of ramification indices under restriction of places, in the behaviour of pullbacks of
+divisors under semilinear automorphisms, and in the glueing of place specialisations on modular
+curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_SemilinearAut_ramificationIndex_smul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_SemilinearAut_ramificationIndex_smul
+
+open AlgebraicCurve AlgebraicCurve.SemilinearAut
+open scoped Pointwise
+
+noncomputable section
+
+theorem solution {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+    [Algebra F F'] {g : SemilinearAut K F} {g' : SemilinearAut K F'}
+    (hgg' : IntertwinesAlong (algebraMap F F') g g') (w : Place K F') :
+    (g' • w).ramificationIndex F = w.ramificationIndex F := by
+  unfold Place.ramificationIndex
+  congr 1
+  ext n
+  simp only [Set.mem_ofPred_eq]
+  refine and_congr_right fun _ => ⟨?_, ?_⟩
+  · rintro ⟨f, hf, hford⟩
+    exact ⟨g⁻¹ • f, by rwa [ne_eq, smul_eq_zero_iff_eq], by rw [← ord_algebraMap_smul hgg', hford]⟩
+  · rintro ⟨f, hf, hford⟩
+    refine ⟨g • f, by rwa [ne_eq, smul_eq_zero_iff_eq], ?_⟩
+    rw [ord_algebraMap_smul hgg', inv_smul_smul, hford]
+
+end
+
+end S_AlgebraicCurve_SemilinearAut_ramificationIndex_smul
+end P2MW
+export P2MW.S_AlgebraicCurve_SemilinearAut_ramificationIndex_smul (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve AlgebraicCurve.SemilinearAut
+theorem AlgebraicCurve.SemilinearAut.ramificationIndex_smul {K F F' : Type*} [Field K] [Field F]
+    [Field F'] [Algebra K F] [Algebra K F'] [Algebra F F'] {g : SemilinearAut K F}
+    {g' : SemilinearAut K F'} (hgg' : IntertwinesAlong (algebraMap F F') g g') (w : Place K F') :
+    (g' • w).ramificationIndex F = w.ramificationIndex F :=
+  solution hgg' w
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_TranscendenceTower_degree_poleDivisor_eq_finrank.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_TranscendenceTower_degree_poleDivisor_eq_finrank.lean
new file mode 100644
index 0000000000..fd819c870d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_TranscendenceTower_degree_poleDivisor_eq_finrank.lean
@@ -0,0 +1,2383 @@
+/-
+Based on Prove2Me node AlgebraicCurve.TranscendenceTower.degree_poleDivisor_eq_finrank
+(ca060c2f-1709-5915-8b0f-48f771e7e8e3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9cacf13a-ee1f-5626-b37e-b85ee1c80f32
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PoleDivisorPackage
+
+import Mathlib.Data.Int.LeastGreatest
+import Mathlib.LinearAlgebra.Matrix.FiniteDimensional
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree of the pulled-back pole divisor equals [F:E]
+
+Theorem statement: `AlgebraicCurve.TranscendenceTower.degree_poleDivisor_eq_finrank`
+(`ca060c2f-1709-5915-8b0f-48f771e7e8e3`), by Claude, 2026-09-05.
+
+Proof: submission `9cacf13a-ee1f-5626-b37e-b85ee1c80f32`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $E$, $F$ be fields with $K$-algebra structures on $E$ and $F$ and an $E$-algebra structure
+on $F$ forming a scalar tower over $K$, with $F/E$ finite-dimensional and separable, and assume $F$
+has principal divisors over $K$: every nonzero $f \in F$ is the divisor of some $D$, meaning $D(v) =
+\operatorname{ord}_v f$ at every place $v$ of $F/K$ and $\deg D = 0$. Here a place of $F/K$ is a
+valuation subring of $F$ containing the image of $K$, distinct from $F$ itself, whose ring is a
+principal ideal ring, a divisor is a finitely supported $\mathbb{Z}$-valued function on places, and
+$\deg D = \sum_v D(v)\,\deg v$. Let $T$ be transcendence-tower data for $K \subseteq E \subseteq F$,
+that is: an element $x \in E$ whose powers $x^j$ ($j \in \mathbb{N}$) are linearly independent over
+$K$, together with a place $v$ of $E/K$ with $\deg v = 1$, $\operatorname{ord}_v x = -1$, and
+$\operatorname{ord}_u x \ge 0$ for every place $u \neq v$ of $E/K$. The assertion is that the degree
+of the pole divisor of $T$, namely the image under `Divisor.pullback` to $F$ of the divisor $1 \cdot
+v$ on $E$, equals $\operatorname{finrank}_E F = [F:E]$ as an integer.
+
+This is the identity $\deg (x)_\infty = [F:K(x)]$ for a function field: the fundamental identity
+$\sum_{w \mid v} e(w\mid v) f(w\mid v) = [F:E]$, specialised to a degree-one place $v$ of $E$ at
+which $x$ has a simple pole. It supplies the identification of the extension degree with the degree
+of the pole divisor used in the pole-divisor package, and is cited in the estimate
+[`AlgebraicCurve.sum_ordDiff_D_le_two_mul_genusFF_of_isSeparable`]
+(thm.html#AlgebraicCurve.sum_ordDiff_D_le_two_mul_genusFF_of_isSeparable).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_TranscendenceTower_degree_poleDivisor_eq_finrank.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_TranscendenceTower_degree_poleDivisor_eq_finrank
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow mk.injEq algebraMap_mem' toValuationSubring mk \
+  ramificationIndex ramificationIndex_pos restrict mem_restrict_iff ord_restrict \
+  deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg"
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "degree degree_single principal smul_def smul_apply pullback \
+  pullback_apply degree_pullback"
+end Divisor
+variable {D : Divisor K F}
+p2m_open_scoped "AlgebraicCurve.Divisor" in
+theorem Divisor.degree_nonneg_of_nonneg [IsCurveOver K F]
+    {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) : 0 ≤ Divisor.degree D := by
+  rw [Divisor.degree_eq_sum_support]
+  exact Finset.sum_nonneg fun v _ => mul_nonneg (hD v) (Int.natCast_nonneg _)
+theorem lSpace_eq_bot_of_degree_neg [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) : LSpace D = ⊥ := by
+  rw [eq_bot_iff]
+  intro f hf
+  rw [Submodule.mem_bot]
+  by_contra hf0
+  obtain ⟨P, hPord, hPdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+  have heff : ∀ v : Place K F, 0 ≤ (P + D) v := by
+    intro v
+    rw [Finsupp.add_apply, hPord]
+    rcases mem_lSpace_iff_ord.mp hf with rfl | h
+    · exact absurd rfl hf0
+    · linarith [h v]
+  have hdegPD : 0 ≤ Divisor.degree (P + D) := Divisor.degree_nonneg_of_nonneg heff
+  rw [map_add, hPdeg, zero_add] at hdegPD
+  exact absurd hdegPD (not_le.mpr hD)
+end AlgebraicCurve
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow mk.injEq algebraMap_mem' toValuationSubring mk \
+  ramificationIndex ramificationIndex_pos restrict mem_restrict_iff ord_restrict \
+  deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~comap_algebra\
+  Map_ne_top"
+
+variable (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mk_mem_maximalIdeal_iff {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    (⟨f, hf⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring
+      ↔ f = 0 ∨ 0 < v.ord f := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  constructor
+  · intro hu
+    rcases eq_or_ne f 0 with rfl | hf0
+    · exact Or.inl rfl
+    · refine Or.inr ?_
+      rcases lt_or_eq_of_le (AlgebraicCurve.Place.ord_nonneg_of_mem v hf) with h | h
+      · exact h
+      · exfalso
+        apply hu
+        rw [← v.adicValuation_coe_eq_one_iff ⟨f, hf⟩]
+        change v.adicValuation f = 1
+        rw [v.adicValuation_eq_exp_neg_ord hf0, ← h, neg_zero, WithZero.exp_zero]
+  · intro h hu
+    have hne : f ≠ 0 := fun h0 => hu.ne_zero (Subtype.ext h0)
+    have h0 : v.ord f = 0 := by
+      obtain ⟨u, hu'⟩ := hu
+      have hcoe : f = ((u : v.toValuationSubring) : F) := by rw [hu']
+      rw [hcoe]; exact v.ord_coe_unit u
+    rcases h with rfl | hpos
+    · exact hne rfl
+    · omega
+
+p2m_export "AlgebraicCurve.Place" "mk_mem_maximalIdeal_iff"
+end Place
+
+theorem ell_le_ell_sub_single_add_deg [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    ell D ≤ ell (D - Finsupp.single P 1) + P.deg := by
+  classical
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible P.toValuationSubring
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by
+    simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := by
+    intro g hg
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ g : F, g ∈ LSpace D → t ^ (D P) * g ∈ P.toValuationSubring := by
+    intro g hg
+    rcases eq_or_ne g 0 with rfl | hg0
+    · simp
+    · refine AlgebraicCurve.Place.mem_of_ord_nonneg P (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have := (mem_lSpace_iff_ord.mp hg).resolve_left hg0 P
+      linarith
+  let ψ : LSpace D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun f => ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+      map_add' := by intro f g; apply Subtype.ext; push_cast; ring
+      map_smul' := by
+        intro c f; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap]
+        ring }
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : LSpace D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ f : LSpace D, φ f = 0 ↔
+      (⟨t ^ (D P) * (f : F), hmem _ f.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := by
+    intro f
+    rw [show φ f = IsLocalRing.residue P.toValuationSubring ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+          from hres (ψ f),
+      IsLocalRing.residue_eq_zero_iff]
+  have hED : E ≤ D := by
+    rw [Finsupp.le_def]; intro v; rw [hE, Finsupp.sub_apply]
+    have : (0 : ℤ) ≤ Finsupp.single P 1 v := by
+      rcases eq_or_ne v P with rfl | hv
+      · simp
+      · simp [Finsupp.single_eq_of_ne hv]
+    linarith
+  have hsub : LSpace E ≤ LSpace D := lSpace_mono hED
+  have hker : LinearMap.ker φ = (LSpace E).comap (LSpace D).subtype := by
+    ext f
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi f, P.mk_mem_maximalIdeal_iff]
+    rcases eq_or_ne (f : F) 0 with hf0 | hf0
+    · simp only [hf0, mul_zero, true_or, true_iff]
+      exact (LSpace E).zero_mem
+    · rw [mem_lSpace_iff_ord]
+      have hfD := (mem_lSpace_iff_ord.mp f.2).resolve_left hf0
+      constructor
+      · rintro (h | h)
+        · exact absurd h (mul_ne_zero htn0 hf0)
+        · refine Or.inr (fun v => ?_)
+          rcases eq_or_ne v P with rfl | hv
+          · rw [hEP]; rw [hordmul hf0] at h; omega
+          · rw [hEv v hv]; exact hfD v
+      · rintro (h | h)
+        · exact absurd h hf0
+        · refine Or.inr ?_
+          have hP := h P
+          rw [hEP] at hP
+          rw [hordmul hf0]; omega
+  have hkerfin : finrank K (LinearMap.ker φ) = ell E := by
+    rw [hker, LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe hsub)]
+  have hquot : finrank K (LSpace D ⧸ LinearMap.ker φ) ≤ P.deg := by
+    rw [LinearEquiv.finrank_eq φ.quotKerEquivRange]
+    exact Submodule.finrank_le (LinearMap.range φ)
+  by_cases hfin : FiniteDimensional K (LSpace D)
+  · have := hfin
+    have hrn := Submodule.finrank_quotient_add_finrank (LinearMap.ker φ)
+    rw [hkerfin] at hrn
+    have hb : ell D = finrank K (LSpace D) := rfl
+    omega
+  · have h0 : ell D = 0 := by rw [ell]; exact finrank_of_infinite_dimensional hfin
+    omega
+
+theorem one_le_deg [IsCurveOver K F] (P : Place K F) : 1 ≤ P.deg := by
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  exact Module.finrank_pos
+
+theorem ell_le_degree_add_ellZero [IsCurveOver K F] {D : Divisor K F}
+    (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D : Divisor K F, (∀ v, 0 ≤ D v) →
+      (Divisor.degree D).toNat = m →
+      (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) by
+    exact H (Divisor.degree D).toNat D hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D hD hm
+    by_cases hD0 : D = 0
+    · subst hD0; simp
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ D P := by
+        have hne : D P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hD P; omega
+      set E : Divisor K F := D - Finsupp.single P 1 with hE
+      have hEeff : ∀ v, 0 ≤ E v := by
+        intro v; rw [hE, Finsupp.sub_apply]
+        rcases eq_or_ne v P with rfl | hv
+        · rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have hdegE : Divisor.degree E = Divisor.degree D - P.deg := by
+        rw [hE, map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hDnn : 0 ≤ Divisor.degree D := Divisor.degree_nonneg_of_nonneg hD
+      have hEnn : 0 ≤ Divisor.degree E := Divisor.degree_nonneg_of_nonneg hEeff
+      have hmlt : (Divisor.degree E).toNat < m := by rw [← hm]; omega
+      have hIH := IH _ hmlt E hEeff rfl
+      have hstep := ell_le_ell_sub_single_add_deg D P
+      rw [← hE] at hstep
+      have hstep' : (ell D : ℤ) ≤ (ell E : ℤ) + P.deg := by exact_mod_cast hstep
+      rw [hdegE] at hIH
+      linarith
+
+theorem ell_le_degree_add_one_of_effective [IsCurveOver K F]
+    (hC : ConstantsAreBase K F) {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  have h := ell_le_degree_add_ellZero hD
+  rw [ell_zero_eq_one_of_constantsAreBase hC] at h
+  exact_mod_cast h
+
+def lSpaceShiftEquiv (D : Divisor K F) {g : F} (hg : g ≠ 0)
+    {Dg : Divisor K F} (hDg : ∀ v, Dg v = v.ord g) :
+    LSpace D ≃ₗ[K] LSpace (D + Dg) where
+  toFun h := ⟨(h : F) * g⁻¹, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (h : F) 0 with hh0 | hh0
+    · left; rw [hh0, zero_mul]
+    · right; intro v
+      rw [Finsupp.add_apply, hDg, v.ord_mul hh0 (inv_ne_zero hg), v.ord_inv]
+      have := (mem_lSpace_iff_ord.mp h.2).resolve_left hh0 v
+      linarith⟩
+  invFun k := ⟨(k : F) * g, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (k : F) 0 with hk0 | hk0
+    · left; rw [hk0, zero_mul]
+    · right; intro v
+      have := (mem_lSpace_iff_ord.mp k.2).resolve_left hk0 v
+      rw [Finsupp.add_apply, hDg] at this
+      rw [v.ord_mul hk0 hg]
+      linarith⟩
+  map_add' h₁ h₂ := by apply Subtype.ext; push_cast; ring
+  map_smul' c h := by
+    apply Subtype.ext
+    simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def]
+    ring
+  left_inv h := by
+    apply Subtype.ext
+    change (h : F) * g⁻¹ * g = (h : F)
+    rw [mul_assoc, inv_mul_cancel₀ hg, mul_one]
+  right_inv k := by
+    apply Subtype.ext
+    change (k : F) * g * g⁻¹ = (k : F)
+    rw [mul_assoc, mul_inv_cancel₀ hg, mul_one]
+
+theorem ell_le_degree_add_one [IsCurveOver K F] (hC : ConstantsAreBase K F)
+    {D : Divisor K F} (hD : 0 ≤ Divisor.degree D) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  rcases eq_or_ne (ell D) 0 with h0 | h0
+  · rw [h0]; push_cast; linarith
+  · have hbot : LSpace D ≠ ⊥ := fun h => h0 (by rw [ell, h, finrank_bot])
+    obtain ⟨g, hgL, hg0⟩ := (Submodule.ne_bot_iff _).mp hbot
+    obtain ⟨Dg, hDgord, hDgdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) g hg0
+    have heff : ∀ v, 0 ≤ (D + Dg) v := by
+      intro v; rw [Finsupp.add_apply, hDgord]
+      have := (mem_lSpace_iff_ord.mp hgL).resolve_left hg0 v
+      linarith
+    have hdeg : Divisor.degree (D + Dg) = Divisor.degree D := by
+      rw [map_add, hDgdeg, add_zero]
+    have hell : ell D = ell (D + Dg) :=
+      LinearEquiv.finrank_eq (lSpaceShiftEquiv D hg0 hDgord)
+    have hfin := ell_le_degree_add_one_of_effective hC heff
+    rw [hdeg] at hfin
+    rw [hell]; exact hfin
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion factor mk mem_bot subtype_injective \
+  mk.injEq Quotient.subsingleton_iff Quotient.mk span restrictScalars inclusion_injective \
+  comapSubtypeEquivOfLe mem_comap finrank_quotient_add_finrank mem_top Quotient.equiv mkQ mem_map \
+  coe_subtype map_smul' zero one quotientQuotientEquivQuotient coe_eq_zero finrank_le \
+  range_subtype Quotient.mk_surjective map mem_inf mem_sup Quotient.mk_eq_zero topEquiv \
+  map_injective_of_injective comap_subtype_self mapQ subsingleton_iff module smul_def mk_eq_zero \
+  coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono map_sup coe_zero smul"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+def nestedComapMapMkQEquiv {A B C : Submodule K X} (_hAB : A ≤ B) (hBC : B ≤ C) :
+    ((B.comap C.subtype).map (A.comap C.subtype).mkQ : Submodule K _)
+      ≃ₗ[K] B ⧸ A.comap B.subtype := by
+  set S := A.comap C.subtype with hS
+  set T := B.comap C.subtype with hT
+  let ψ : (T : Type _) →ₗ[K] (C ⧸ S) := S.mkQ ∘ₗ T.subtype
+  have hker : LinearMap.ker ψ = S.comap T.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = T.map S.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let e1 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (T.map S.mkQ : Submodule K _) :=
+    (Submodule.Quotient.equiv _ (LinearMap.ker ψ) (LinearEquiv.refl K T)
+        (by rw [hker]; simp)).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have hmap : (S.comap T.subtype).map
+      (Submodule.comapSubtypeEquivOfLe hBC : (T : Type _) →ₗ[K] B) = A.comap B.subtype := by
+    ext ⟨b, hb⟩
+    simp only [mem_map, mem_comap, Submodule.coe_subtype, hS]
+    constructor
+    · rintro ⟨⟨⟨x, hxC⟩, hxB⟩, hxA, hxeq⟩
+      have hx : x = b := congrArg Subtype.val hxeq
+      subst hx; exact hxA
+    · intro hbA
+      exact ⟨⟨⟨b, hBC hb⟩, hb⟩, hbA, rfl⟩
+  let e2 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (B ⧸ A.comap B.subtype) :=
+    Submodule.Quotient.equiv _ _ (Submodule.comapSubtypeEquivOfLe hBC) hmap
+  exact e1.symm.trans e2
+
+theorem finrank_quotient_chain {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCB : Module.Finite K (C ⧸ B.comap C.subtype)]
+    [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (C ⧸ A.comap C.subtype) ∧
+      finrank K (C ⧸ A.comap C.subtype)
+        = finrank K (C ⧸ B.comap C.subtype) + finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (T.map S.mkQ : Submodule K _) := Module.Finite.equiv eK.symm
+  have : Module.Finite K ((C ⧸ S) ⧸ T.map S.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (C ⧸ S) := Module.Finite.of_submodule_quotient (T.map S.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+theorem finrank_quotient_chain' {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCA : Module.Finite K (C ⧸ A.comap C.subtype)] :
+    Module.Finite K (C ⧸ B.comap C.subtype) ∧
+      finrank K (C ⧸ B.comap C.subtype)
+        = finrank K (C ⧸ A.comap C.subtype) - finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (C ⧸ T) := Module.Finite.equiv e3
+  refine ⟨this, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+def adeleBddQuotSingleEquivResidueField (D : Divisor K F) (P : Place K F) :
+    (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+      ≃ₗ[K] P.ResidueField := by
+  classical
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  let π : P.toValuationSubring :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose
+  have hπ : Irreducible π :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose_spec
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := fun {g} hg => by
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ α : Place K F → F, α ∈ adeleBdd D → t ^ (D P) * α P ∈ P.toValuationSubring := by
+    intro α hα
+    rcases eq_or_ne (α P) 0 with hg0 | hg0
+    · simp [hg0]
+    · refine AlgebraicCurve.Place.mem_of_ord_nonneg P (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have h := hα P
+      rw [P.adicValuation_eq_exp_neg_ord hg0, WithZero.exp_le_exp] at h
+      linarith
+  let ψ : adeleBdd D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun α => ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩
+      map_add' := by
+        intro α β; apply Subtype.ext
+        simp only [Submodule.coe_add, Pi.add_apply]
+        push_cast; ring
+      map_smul' := by
+        intro c α; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap, Pi.smul_apply]
+        ring }
+  have hψ_apply : ∀ α : adeleBdd D,
+      (ψ α : F) = t ^ (D P) * (α : Place K F → F) P := fun α => rfl
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : adeleBdd D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ α : adeleBdd D, φ α = 0 ↔
+      (⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := fun α => by
+    rw [show φ α = IsLocalRing.residue P.toValuationSubring
+            ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ from hres (ψ α),
+      IsLocalRing.residue_eq_zero_iff]
+  have hker : LinearMap.ker φ = (adeleBdd E).comap (adeleBdd D).subtype := by
+    ext α
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi α, P.mk_mem_maximalIdeal_iff, mem_adeleBdd]
+    have hαD := α.2
+    constructor
+    · rintro (h | h) v
+      · have hα0 : (α : Place K F → F) P = 0 := by
+          rcases mul_eq_zero.mp h with h' | h'
+          · exact absurd h' htn0
+          · exact h'
+        by_cases hv : v = P
+        · subst v; rw [hα0, Valuation.map_zero]; exact zero_le
+        · rw [hEv v hv]; exact hαD v
+      · by_cases hv : v = P
+        · subst v
+          rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+          · rw [hα0, Valuation.map_zero]; exact zero_le
+          · rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP]
+            rw [hordmul hα0] at h; omega
+        · rw [hEv v hv]; exact hαD v
+    · intro h
+      rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+      · left; rw [hα0, mul_zero]
+      · right
+        have hP := h P
+        rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP] at hP
+        rw [hordmul hα0]; omega
+  have hsurj : Function.Surjective φ := by
+    intro c
+    obtain ⟨cl, hcl⟩ := IsLocalRing.residue_surjective (R := P.toValuationSubring) c
+    set f : F := (cl : F) * t ^ (-(D P)) with hf
+    have hαD : Pi.single P f ∈ adeleBdd D := by
+      intro v
+      by_cases hv : v = P
+      · subst v
+        simp only [Pi.single_eq_same]
+        rcases eq_or_ne (cl : F) 0 with hc0 | hc0
+        · rw [hf, hc0, zero_mul, Valuation.map_zero]; exact zero_le
+        · have hf0 : f ≠ 0 := by rw [hf]; exact mul_ne_zero hc0 (zpow_ne_zero _ ht0)
+          rw [P.adicValuation_eq_exp_neg_ord hf0, WithZero.exp_le_exp]
+          rw [hf, P.ord_mul hc0 (zpow_ne_zero _ ht0), P.ord_zpow, ht1, mul_one]
+          have hclnn := AlgebraicCurve.Place.ord_nonneg_of_mem P cl.2
+          linarith
+      · rw [Pi.single_eq_of_ne hv, Valuation.map_zero]; exact zero_le
+    refine ⟨⟨Pi.single P f, hαD⟩, ?_⟩
+    change res (ψ ⟨Pi.single P f, hαD⟩) = c
+    rw [hres]
+    rw [show (ψ ⟨Pi.single P f, hαD⟩ : P.toValuationSubring) = cl from ?_, hcl]
+    apply Subtype.ext
+    rw [hψ_apply]
+    change t ^ (D P) * (Pi.single P f : Place K F → F) P = (cl : F)
+    rw [show (Pi.single P f : Place K F → F) P = f from Pi.single_eq_same _ _, hf,
+      mul_comm (cl : F), ← mul_assoc, ← zpow_add₀ ht0, add_neg_cancel, zpow_zero, one_mul]
+  exact (Submodule.Quotient.equiv _ _ (LinearEquiv.refl K _) (by rw [← hker]; simp)).trans
+    (φ.quotKerEquivOfSurjective hsurj)
+
+theorem finrank_adeleBdd_quotient_single [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    Module.Finite K
+        (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype) ∧
+      finrank K
+          (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+        = P.deg := by
+  have := IsCurveOver.finite_residueField (K := K) P
+  exact ⟨Module.Finite.equiv (adeleBddQuotSingleEquivResidueField D P).symm,
+    (adeleBddQuotSingleEquivResidueField D P).finrank_eq⟩
+
+theorem finrank_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+      (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+        = Divisor.degree D₂ - Divisor.degree D₁ := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D₁ D₂ : Divisor K F, D₁ ≤ D₂ →
+      (Divisor.degree (D₂ - D₁)).toNat = m →
+      Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+        (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+          = Divisor.degree D₂ - Divisor.degree D₁ from
+    H _ D₁ D₂ hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D₁ D₂ hD hm
+    have hEeff : ∀ v, 0 ≤ (D₂ - D₁) v := fun v => by
+      rw [Finsupp.sub_apply]; have := hD v; omega
+    by_cases hD0 : D₂ - D₁ = 0
+    · have hD12 : D₁ = D₂ := (sub_eq_zero.mp hD0).symm
+      subst hD12
+      rw [Submodule.comap_subtype_self]
+      have : Subsingleton (adeleBdd D₁ ⧸ (⊤ : Submodule K (adeleBdd D₁))) :=
+        Submodule.Quotient.subsingleton_iff.mpr rfl
+      exact ⟨Module.Finite.of_finite, by simp [Module.finrank_zero_of_subsingleton]⟩
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ (D₂ - D₁) P := by
+        have hne : (D₂ - D₁) P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hEeff P; omega
+      set D₂' : Divisor K F := D₂ - Finsupp.single P 1 with hD₂'
+      have h12' : D₁ ≤ D₂' := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]
+          have := hPpos; rw [Finsupp.sub_apply] at this; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have h2'2 : D₂' ≤ D₂ := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]
+      have hdegD₂' : Divisor.degree D₂' = Divisor.degree D₂ - P.deg := by
+        rw [hD₂', map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hEnn : 0 ≤ Divisor.degree (D₂ - D₁) := Divisor.degree_nonneg_of_nonneg hEeff
+      have hE'nn : 0 ≤ Divisor.degree (D₂' - D₁) := Divisor.degree_nonneg_of_nonneg
+        (fun v => by rw [Finsupp.sub_apply]; have := h12' v; omega)
+      have hdegdiff : Divisor.degree (D₂' - D₁) = Divisor.degree (D₂ - D₁) - P.deg := by
+        simp only [hD₂', map_sub, Divisor.degree_single, one_mul]; ring
+      have hmlt : (Divisor.degree (D₂' - D₁)).toNat < m := by rw [← hm]; omega
+      obtain ⟨hfin', hrank'⟩ := IH _ hmlt D₁ D₂' h12' rfl
+      obtain ⟨hfinS, hrankS⟩ := finrank_adeleBdd_quotient_single (K := K) D₂ P
+      rw [← hD₂'] at hfinS hrankS
+      have := hfin'; have := hfinS
+      obtain ⟨hfin, hrank⟩ := Submodule.finrank_quotient_chain
+        (A := adeleBdd D₁) (B := adeleBdd D₂') (C := adeleBdd D₂)
+        (adeleBdd_mono h12') (adeleBdd_mono h2'2)
+      refine ⟨hfin, ?_⟩
+      rw [hrank, hrankS]
+      push_cast
+      linarith [hrank', hdegD₂']
+
+theorem module_finite_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  (finrank_adeleBdd_quotient hD).1
+
+theorem finrank_adeleBdd_quotient_eq [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+      = Divisor.degree D₂ - Divisor.degree D₁ :=
+  (finrank_adeleBdd_quotient hD).2
+
+def lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (_hD : D₁ ≤ D₂) :
+    (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      →ₗ[K] (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  Submodule.mapQ _ _
+    ((diagonalHom K F).restrict
+      (p := (LSpace D₂ : Submodule K F)) (q := (adeleBdd D₂ : Submodule K _))
+      (fun f hf => diagonal_mem_adeleBdd_iff.mpr hf))
+    (fun f hf => by
+      simp only [Submodule.mem_comap, Submodule.coe_subtype] at hf ⊢
+      exact diagonal_mem_adeleBdd_iff.mpr hf)
+
+theorem lSpaceQuotientToAdeleBddQuotient_injective {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Function.Injective (lSpaceQuotientToAdeleBddQuotient hD) := by
+  rw [injective_iff_map_eq_zero]
+  intro x hx
+  obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+  rw [Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype]
+  rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk f)
+        = Submodule.Quotient.mk ((diagonalHom K F).restrict
+            (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f) from rfl,
+    Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype] at hx
+  exact diagonal_mem_adeleBdd_iff.mp hx
+
+
+theorem ell_sub_ell_le_degree_sub_degree [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)] :
+    (ell D₂ : ℤ) - (ell D₁ : ℤ) ≤ Divisor.degree D₂ - Divisor.degree D₁ := by
+  have := module_finite_adeleBdd_quotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    rw [hℓ₁]; exact (Submodule.finrank_quotient_add_finrank _).symm
+  have hemb : finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      ≤ finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+    LinearMap.finrank_le_finrank_of_injective (lSpaceQuotientToAdeleBddQuotient_injective hD)
+  have hloc := finrank_adeleBdd_quotient_eq hD
+  have : (ell D₂ : ℤ) - (ell D₁ : ℤ)
+      = (finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) : ℤ) := by
+    rw [hL]; push_cast; ring
+  rw [this, ← hloc]
+  exact_mod_cast hemb
+
+theorem adeleBdd_inf_sup_globalSub {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F)
+      = adeleBdd D₁ ⊔ adeleBdd D₂ ⊓ globalSub K F := by
+  rw [inf_comm, sup_inf_assoc_of_le _ (adeleBdd_mono hD), inf_comm]
+
+theorem map_diagonal_lSpace_inf_adeleBdd {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (LSpace D₂).map (diagonalHom K F) ⊓ adeleBdd D₁ = (LSpace D₁).map (diagonalHom K F) := by
+  rw [map_diagonal_lSpace, map_diagonal_lSpace, inf_right_comm,
+    inf_eq_right.mpr (adeleBdd_mono hD)]
+
+theorem gate_finrank_adeleBdd_quotient_single_point [IsCurveOver K F] (P : Place K F) :
+    (finrank K (adeleBdd (Finsupp.single P 1 : Divisor K F)
+        ⧸ (adeleBdd (0 : Divisor K F)).comap (adeleBdd (Finsupp.single P 1)).subtype) : ℤ)
+      = (P.deg : ℤ) := by
+  classical
+  have h01 : (0 : Divisor K F) ≤ Finsupp.single P 1 := by
+    intro v; rw [Finsupp.zero_apply, Finsupp.single_apply]; split_ifs <;> omega
+  have h := finrank_adeleBdd_quotient_eq (K := K) h01
+  rw [h, map_zero, sub_zero, Divisor.degree_single, one_mul]
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion factor mk mem_bot subtype_injective \
+  mk.injEq Quotient.subsingleton_iff Quotient.mk span restrictScalars inclusion_injective \
+  comapSubtypeEquivOfLe mem_comap finrank_quotient_add_finrank mem_top Quotient.equiv mkQ mem_map \
+  coe_subtype map_smul' zero one quotientQuotientEquivQuotient coe_eq_zero finrank_le \
+  range_subtype Quotient.mk_surjective map mem_inf mem_sup Quotient.mk_eq_zero topEquiv \
+  map_injective_of_injective comap_subtype_self mapQ subsingleton_iff module smul_def mk_eq_zero \
+  coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono map_sup coe_zero smul"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+theorem comap_subtype_sup_of_le_of_le {S T C : Submodule K X} (hS : S ≤ C) (hT : T ≤ C) :
+    S.comap C.subtype ⊔ T.comap C.subtype = (S ⊔ T).comap C.subtype := by
+  apply Submodule.map_injective_of_injective (f := C.subtype) C.subtype_injective
+  rw [Submodule.map_sup, Submodule.map_comap_subtype, Submodule.map_comap_subtype,
+    Submodule.map_comap_subtype, inf_eq_right.mpr hS, inf_eq_right.mpr hT,
+    inf_eq_right.mpr (sup_le hS hT)]
+
+theorem finrank_quotient_chain_top {M : Type*} [AddCommGroup M] [Module K M]
+    {A B : Submodule K M} (hAB : A ≤ B)
+    [hMB : Module.Finite K (M ⧸ B)] [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (M ⧸ A) ∧
+      finrank K (M ⧸ A) = finrank K (M ⧸ B) + finrank K (B ⧸ A.comap B.subtype) := by
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  let ψ : (B : Type _) →ₗ[K] (M ⧸ A) := A.mkQ ∘ₗ B.subtype
+  have hker : LinearMap.ker ψ = A.comap B.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = B.map A.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let eK : (B ⧸ A.comap B.subtype) ≃ₗ[K] (B.map A.mkQ : Submodule K (M ⧸ A)) :=
+    (Submodule.quotEquivOfEq _ _ hker.symm).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have : Module.Finite K (B.map A.mkQ : Submodule K (M ⧸ A)) := Module.Finite.equiv eK
+  have : Module.Finite K ((M ⧸ A) ⧸ B.map A.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (M ⧸ A) := Module.Finite.of_submodule_quotient (B.map A.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (B.map A.mkQ)
+  rw [LinearEquiv.finrank_eq e3, ← LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem globalSub_le_adeleSpace [HasPrincipalDivisors K F] :
+    globalSub K F ≤ adeleSpace K F := by
+  rintro _ ⟨f, rfl⟩
+  exact diagonal_mem_adeleSpace f
+
+theorem adeleBdd_sup_globalSub_le_adeleSpace [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+  sup_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_eq_comap [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBddPrincipal K F D = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype :=
+  Submodule.comap_subtype_sup_of_le_of_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_mono {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBddPrincipal K F D₁ ≤ adeleBddPrincipal K F D₂ :=
+  sup_le_sup_right (Submodule.comap_mono (adeleBdd_mono hD)) _
+
+section FiniteLSpace
+
+variable [IsCurveOver K F]
+
+theorem finiteDimensional_lSpace [hL0 : FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (D : Divisor K F) : FiniteDimensional K (LSpace D) := by
+  have h0D : (0 : Divisor K F) ≤ D ⊔ 0 := le_sup_right
+  have hDD : D ≤ D ⊔ 0 := le_sup_left
+  suffices h : FiniteDimensional K (LSpace (D ⊔ 0)) by
+    exact Module.Finite.of_injective (Submodule.inclusion (lSpace_mono hDD))
+      (Submodule.inclusion_injective _)
+  have := module_finite_adeleBdd_quotient (K := K) h0D
+  have hfinQ : FiniteDimensional K
+      (LSpace (D ⊔ 0) ⧸ (LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype) :=
+    Module.Finite.of_injective _ (lSpaceQuotientToAdeleBddQuotient_injective h0D)
+  have : FiniteDimensional K
+      ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype : Submodule K _) :=
+    Module.Finite.equiv (Submodule.comapSubtypeEquivOfLe (lSpace_mono h0D)).symm
+  exact Module.Finite.of_submodule_quotient
+    ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype)
+
+end FiniteLSpace
+
+
+theorem range_lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD)
+      = ((adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype).map
+          ((adeleBdd D₁).comap (adeleBdd D₂).subtype).mkQ := by
+  classical
+  ext z
+  obtain ⟨α, rfl⟩ := Submodule.Quotient.mk_surjective _ z
+  simp only [LinearMap.mem_range, Submodule.mem_map, Submodule.mem_comap, Submodule.coe_subtype,
+    Submodule.mkQ_apply]
+  constructor
+  · rintro ⟨x, hx⟩
+    obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+    have hxeq : Submodule.Quotient.mk
+        ((diagonalHom K F).restrict (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f)
+        = (Submodule.Quotient.mk α :
+            adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) := hx
+    refine ⟨α, ?_, rfl⟩
+    have hdiag2 : (diagonalHom K F (f : F)) ∈ adeleBdd D₂ := diagonal_mem_adeleBdd_iff.mpr f.2
+    have hsub : (α : Place K F → F) - diagonalHom K F (f : F) ∈ adeleBdd D₁ := by
+      have hq := (Submodule.Quotient.eq _).mp hxeq.symm
+      simpa using hq
+    refine Submodule.mem_sup.mpr ⟨(α : Place K F → F) - diagonalHom K F (f : F), hsub,
+      diagonalHom K F (f : F), diagonal_mem_globalSub _, ?_⟩
+    abel
+  · rintro ⟨β, hβ, hβeq⟩
+    have hβ' : (β : Place K F → F) ∈ adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F) :=
+      Submodule.mem_inf.mpr ⟨β.2, hβ⟩
+    rw [adeleBdd_inf_sup_globalSub hD, ← map_diagonal_lSpace] at hβ'
+    obtain ⟨γ, hγ, δ, ⟨f, hf, hfδ⟩, hsum⟩ := Submodule.mem_sup.mp hβ'
+    refine ⟨Submodule.Quotient.mk ⟨f, hf⟩, ?_⟩
+    rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk ⟨f, hf⟩)
+          = Submodule.Quotient.mk ((diagonalHom K F).restrict
+              (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) ⟨f, hf⟩) from rfl,
+      ← hβeq, Submodule.Quotient.eq]
+    refine Submodule.mem_comap.mpr ?_
+    change diagonalHom K F f - (β : Place K F → F) ∈ adeleBdd D₁
+    have hβsub : diagonalHom K F f - (β : Place K F → F) = -γ := by
+      rw [← hsum, hfδ]; ring
+    rw [hβsub]; exact (adeleBdd D₁).neg_mem hγ
+
+
+theorem finrank_adeleBddSup_quotient [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) [hL : FiniteDimensional K (LSpace D₂)] :
+    Module.Finite K (↥(adeleBdd D₂ ⊔ globalSub K F)
+        ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) ∧
+      (finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+          ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) : ℤ)
+        = (Divisor.degree D₂ - ell D₂) - (Divisor.degree D₁ - ell D₁) := by
+  classical
+  let A : Submodule K (adeleBdd D₂) := (adeleBdd D₁).comap (adeleBdd D₂).subtype
+  let B : Submodule K (adeleBdd D₂) :=
+    (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype
+  have hAB : A ≤ B := Submodule.comap_mono le_sup_left
+  have hfinA : Module.Finite K (adeleBdd D₂ ⧸ A) := module_finite_adeleBdd_quotient hD
+  have hdimA : (finrank K (adeleBdd D₂ ⧸ A) : ℤ) = Divisor.degree D₂ - Divisor.degree D₁ :=
+    finrank_adeleBdd_quotient_eq hD
+  have hran : LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD) = B.map A.mkQ :=
+    range_lSpaceQuotientToAdeleBddQuotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hdimL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K)
+      ((LSpace D₁).comap (LSpace D₂).subtype)
+    rw [← hℓ₁] at h; exact h.symm
+  have hdimB : ell D₂ = finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) + ell D₁ := by
+    rw [← hran, LinearMap.finrank_range_of_inj
+      (lSpaceQuotientToAdeleBddQuotient_injective hD)]
+    exact hdimL
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  have hfinB : Module.Finite K (adeleBdd D₂ ⧸ B) := Module.Finite.equiv e3
+  have hdim2 : finrank K (adeleBdd D₂ ⧸ A)
+      = finrank K (adeleBdd D₂ ⧸ B) + finrank K (B.map A.mkQ : Submodule K _) := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K) (M := adeleBdd D₂ ⧸ A)
+      (B.map A.mkQ)
+    rw [LinearEquiv.finrank_eq e3] at h; omega
+  have e2 := LinearMap.quotientInfEquivSupQuotient (R := K)
+    (adeleBdd D₂) (adeleBdd D₁ ⊔ globalSub K F)
+  have hsup : adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F) = adeleBdd D₂ ⊔ globalSub K F := by
+    rw [← sup_assoc, sup_eq_left.mpr (adeleBdd_mono hD)]
+  have hB' : (adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype = B := by
+    rw [Submodule.comap_subtype_self, top_inf_eq]
+  let eL : (adeleBdd D₂ ⧸ B) ≃ₗ[K]
+      (adeleBdd D₂ ⧸ ((adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+        (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype)) :=
+    Submodule.quotEquivOfEq _ _ hB'.symm
+  have hfin_iso : Module.Finite K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype) :=
+    Module.Finite.equiv (eL.trans e2)
+  have hdim_iso : finrank K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype)
+      = finrank K (adeleBdd D₂ ⧸ B) :=
+    (LinearEquiv.finrank_eq (eL.trans e2)).symm
+  have hcast : (finrank K (adeleBdd D₂ ⧸ A) : ℤ)
+      = (finrank K (adeleBdd D₂ ⧸ B) : ℤ) + ((ell D₂ : ℤ) - (ell D₁ : ℤ)) := by
+    have hb : (ell D₂ : ℤ)
+        = (finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) : ℤ) + (ell D₁ : ℤ) := by
+      exact_mod_cast hdimB
+    push_cast [hdim2]; linarith
+  have hgoal : (finrank K (adeleBdd D₂ ⧸ B) : ℤ)
+      = Divisor.degree D₂ - ↑(ell D₂) - (Divisor.degree D₁ - ↑(ell D₁)) := by
+    linarith [hdimA, hcast]
+  clear_value eL
+  exact hsup ▸ ⟨hfin_iso, by rw [hdim_iso]; exact hgoal⟩
+
+section Index
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+
+theorem adeleBddSup_eq_of_degree_sub_ell_eq {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)]
+    (heq : Divisor.degree D₂ - ell D₂ = Divisor.degree D₁ - ell D₁) :
+    adeleBdd D₂ ⊔ globalSub K F = adeleBdd D₁ ⊔ globalSub K F := by
+  obtain ⟨hfin, hdim⟩ := finrank_adeleBddSup_quotient hD
+  rw [heq, sub_self] at hdim
+  refine le_antisymm ?_ (sup_le_sup_right (adeleBdd_mono hD) _)
+  have := hfin
+  have hd0 : finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) = 0 := by
+    exact_mod_cast hdim
+  have hsub : Subsingleton (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) :=
+    Module.finrank_zero_iff.mp hd0
+  have htop := Submodule.Quotient.subsingleton_iff.mp hsub
+  intro x hx
+  have hxc : (⟨x, hx⟩ : ↥(adeleBdd D₂ ⊔ globalSub K F)) ∈
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype := by
+    rw [htop]; exact Submodule.mem_top
+  exact hxc
+
+end Index
+
+namespace RiemannGenusReachedAt
+p2m_export "AlgebraicCurve.RiemannGenusReachedAt" "finite mk eq isMax"
+end RiemannGenusReachedAt
+namespace RiemannGenusReachedAt
+p2m_open_scoped "AlgebraicCurve.RiemannGenusReachedAt" in
+private theorem _root_.AlgebraicCurve.RiemannGenusReachedAt.eq_of_ge [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {D : Divisor K F} (hD : D₀ ≤ D) :
+    Divisor.degree D - ell D = γ - 1 := by
+  have := finiteDimensional_lSpace (K := K) D
+  have hge : Divisor.degree D₀ - (ell D₀ : ℤ) ≤ Divisor.degree D - ell D := by
+    have := ell_sub_ell_le_degree_sub_degree (K := K) hD
+    linarith
+  exact le_antisymm (h.isMax D) (h.eq ▸ hge)
+
+end RiemannGenusReachedAt
+p2m_export "AlgebraicCurve" "RiemannGenusReachedAt.eq_of_ge"
+
+theorem adeleSpace_eq_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    adeleSpace K F = adeleBdd D₀ ⊔ globalSub K F := by
+  refine le_antisymm ?_ (adeleBdd_sup_globalSub_le_adeleSpace D₀)
+  rw [adeleSpace, iSup_le_iff]
+  intro D
+  refine le_trans (adeleBdd_mono (le_sup_left : D ≤ D ⊔ D₀)) ?_
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have heq : Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) = Divisor.degree D₀ - ell D₀ :=
+    (h.eq_of_ge le_sup_right).trans h.eq.symm
+  have hsup := adeleBddSup_eq_of_degree_sub_ell_eq (K := K)
+    (le_sup_right : D₀ ≤ D ⊔ D₀) heq
+  rw [← hsup]
+  exact le_sup_left
+
+theorem indexOfSpecialty_eq_zero_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    indexOfSpecialty D₀ = 0 := by
+  rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap, ← adeleSpace_eq_of_genusReached h,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.finrank_zero_of_subsingleton
+
+
+
+theorem gate_indexOfSpecialty_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  have h1 := (indexOfSpecialty_eq_of_genusReached h D₀).2
+  have h2 := h.eq
+  have h3 := indexOfSpecialty_eq_zero_of_genusReached h
+  exact_mod_cast h3
+
+theorem gate_riemannInequality_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Divisor.degree D + 1 - γ ≤ (ell D : ℤ) := by
+  have heq := (indexOfSpecialty_eq_of_genusReached h D).2
+  have hnn : (0 : ℤ) ≤ indexOfSpecialty D := Int.natCast_nonneg _
+  linarith
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem adeleSpaceMul_add [HasPrincipalDivisors K F] (f g : F) :
+    adeleSpaceMul K F (f + g) = adeleSpaceMul K F f + adeleSpaceMul K F g := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, LinearMap.add_apply, Submodule.coe_add,
+    Pi.add_apply, add_mul]
+
+theorem adeleSpaceMul_zero [HasPrincipalDivisors K F] :
+    adeleSpaceMul K F (0 : F) = 0 := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, zero_mul, LinearMap.zero_apply,
+    Submodule.coe_zero, Pi.zero_apply]
+
+theorem weilSmul_add_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f + g) φ = weilSmul K F f φ + weilSmul K F g φ := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_add, LinearMap.add_apply, map_add]
+
+theorem weilSmul_zero_left [HasPrincipalDivisors K F]
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (0 : F) φ = 0 := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_zero, LinearMap.zero_apply, map_zero]
+
+theorem weilSmul_neg_left [HasPrincipalDivisors K F] (f : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (-f) φ = -weilSmul K F f φ := by
+  have h := weilSmul_add_left (K := K) (F := F) f (-f) φ
+  rw [add_neg_cancel, weilSmul_zero_left] at h
+  exact (neg_eq_of_add_eq_zero_right h.symm).symm
+
+theorem weilSmul_sub_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f - g) φ = weilSmul K F f φ - weilSmul K F g φ := by
+  rw [sub_eq_add_neg, weilSmul_add_left, weilSmul_neg_left, sub_eq_add_neg]
+
+theorem weilSmul_eq_zero_iff_left [HasPrincipalDivisors K F]
+    {f : F} {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    weilSmul K F f φ = 0 ↔ f = 0 := by
+  refine ⟨fun h => ?_, fun h => h ▸ weilSmul_zero_left φ⟩
+  by_contra hf
+  exact hφ (weilSmul_injective hf (h.trans (map_zero (weilSmul K F f)).symm))
+
+theorem weilSmul_left_injective [HasPrincipalDivisors K F]
+    {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    Function.Injective (fun f : F => weilSmul K F f φ) := by
+  intro f g hfg
+  have hsub : weilSmul K F (f - g) φ = 0 := by
+    rw [weilSmul_sub_left, sub_eq_zero]; exact hfg
+  exact sub_eq_zero.mp ((weilSmul_eq_zero_iff_left hφ).mp hsub)
+
+variable (K F) in
+def doubleResiduePairing [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) :
+    LSpace (W - D) × LSpace (W - D) →ₗ[K] omegaSpace D :=
+  (residuePairing K F W D hφ).coprod (residuePairing K F W D hμ)
+
+theorem doubleResiduePairing_apply_coe [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (g h : LSpace (W - D)) :
+    (doubleResiduePairing K F W D hφ hμ (g, h) : Module.Dual K (adeleSpace K F))
+      = weilSmul K F (g : F) φ + weilSmul K F (h : F) μ := by
+  simp only [doubleResiduePairing, LinearMap.coprod_apply, Submodule.coe_add,
+    residuePairing_apply_coe]
+
+theorem doubleResiduePairing_injective [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ) :
+    Function.Injective (doubleResiduePairing K F W D hφ hμ) := by
+  rw [injective_iff_map_eq_zero]
+  rintro ⟨g, h⟩ heq
+  have heq' : weilSmul K F (g : F) φ + weilSmul K F (h : F) μ = 0 := by
+    have hcoe := congrArg Subtype.val heq
+    rwa [doubleResiduePairing_apply_coe, Submodule.coe_zero] at hcoe
+  rcases eq_or_ne (h : F) 0 with hh0 | hh0
+  · rw [hh0, weilSmul_zero_left, add_zero] at heq'
+    have hg0 : (g : F) = 0 := (weilSmul_eq_zero_iff_left hφ0).mp heq'
+    exact Prod.ext (Subtype.ext hg0) (Subtype.ext hh0)
+  · exfalso
+    have hμeq : weilSmul K F (h : F) μ = -weilSmul K F (g : F) φ := by
+      have h2 : weilSmul K F (h : F) μ + weilSmul K F (g : F) φ = 0 := by
+        rw [add_comm]; exact heq'
+      exact eq_neg_of_add_eq_zero_left h2
+    have hLHS : weilSmul K F (h : F)⁻¹ (weilSmul K F (h : F) μ) = μ := by
+      rw [← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hh0, weilSmul_one,
+        LinearMap.id_apply]
+    have hRHS : weilSmul K F (h : F)⁻¹ (-weilSmul K F (g : F) φ)
+        = weilSmul K F (-(g : F) * (h : F)⁻¹) φ := by
+      rw [map_neg, ← LinearMap.comp_apply, ← weilSmul_mul, neg_mul, weilSmul_neg_left]
+    exact hindep (-(g : F) * (h : F)⁻¹) (by rw [← hLHS, hμeq, hRHS])
+
+theorem two_mul_ell_le_indexOfSpecialty [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ)
+    [Module.Finite K (omegaSpace (K := K) (F := F) D)]
+    [Module.Finite K (LSpace (K := K) (F := F) (W - D))] :
+    2 * ell (W - D) ≤ indexOfSpecialty D := by
+  have hinj := doubleResiduePairing_injective W D hφ hμ hφ0 hindep
+  have hle := LinearMap.finrank_le_finrank_of_injective hinj
+  rw [Module.finrank_prod] at hle
+  rw [← finrank_omegaSpace_eq_indexOfSpecialty, two_mul]
+  exact hle
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+section Finiteness
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+theorem omegaSpace_finite_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Module.Finite K (omegaSpace (K := K) (F := F) D) := by
+  have := (indexOfSpecialty_eq_of_genusReached h D).1
+  exact Module.Finite.equiv (omegaSpaceEquivIndexDual D).symm
+
+end Finiteness
+
+section ParametricRankOne
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+
+theorem exists_weilSmul_eq_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {φ μ : Module.Dual K (adeleSpace K F)} {W : Divisor K F}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (hφ0 : φ ≠ 0) :
+    ∃ f : F, μ = weilSmul K F f φ := by
+  by_contra hcon
+  push Not at hcon
+  obtain ⟨P⟩ := ‹Nonempty (Place K F)›
+  set n : ℕ := 3 * γ.natAbs + 2 * (Divisor.degree W).natAbs + 4 with hn
+  set D : Divisor K F := -Finsupp.single P (n : ℤ) with hD
+  have hdegD : Divisor.degree D = -(n : ℤ) * (P.deg : ℤ) := by
+    rw [hD, map_neg, Divisor.degree_single]; ring
+  have hdegWD : Divisor.degree (W - D) = Divisor.degree W + (n : ℤ) * (P.deg : ℤ) := by
+    rw [map_sub, hdegD]; ring
+  have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+  have habsγ : -(|γ|) ≤ γ ∧ γ ≤ |γ| := ⟨neg_abs_le _, le_abs_self _⟩
+  have habsW : -|Divisor.degree W| ≤ Divisor.degree W ∧
+      Divisor.degree W ≤ |Divisor.degree W| := ⟨neg_abs_le _, le_abs_self _⟩
+  have hn_ge : 3 * |γ| + 2 * |Divisor.degree W| + 4 ≤ (n : ℤ) := by
+    rw [hn]; push_cast [Int.natCast_natAbs]; ring_nf; omega
+  have hndegP : (n : ℤ) ≤ (n : ℤ) * (P.deg : ℤ) := by nlinarith [Int.natCast_nonneg n]
+  have hellD : ell D = 0 := ell_eq_zero_of_degree_neg (by rw [hdegD]; nlinarith)
+  have hiD : (indexOfSpecialty D : ℤ) = (n : ℤ) * (P.deg : ℤ) - 1 + γ := by
+    have hidx := (indexOfSpecialty_eq_of_genusReached h D).2
+    rw [hellD, hdegD] at hidx; push_cast at hidx; linarith
+  have hlowerWD : Divisor.degree W + (n : ℤ) * (P.deg : ℤ) + 1 - γ
+      ≤ (ell (W - D) : ℤ) := by
+    have hlow := gate_riemannInequality_of_genusReached h (W - D)
+    rw [hdegWD] at hlow; exact hlow
+  have := omegaSpace_finite_of_genusReached h D
+  have := finiteDimensional_lSpace (K := K) (W - D)
+  have hdbl : (2 * ell (W - D) : ℤ) ≤ (indexOfSpecialty D : ℤ) := by
+    exact_mod_cast two_mul_ell_le_indexOfSpecialty W D hφ hμ hφ0 hcon
+  rw [hiD] at hdbl
+  nlinarith [habsγ.1, habsγ.2, habsW.1, habsW.2]
+
+theorem weilDifferentialRankOne_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    WeilDifferentialRankOne K F := by
+  intro φ hφmem hφ0 μ hμmem
+  obtain ⟨W₁, hφW₁⟩ := mem_weilDifferentialModule_iff.mp hφmem
+  obtain ⟨W₂, hμW₂⟩ := mem_weilDifferentialModule_iff.mp hμmem
+  have hφW : φ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_left hφW₁
+  have hμW : μ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_right hμW₂
+  obtain ⟨f, hf⟩ := exists_weilSmul_eq_of_genusReached h hφW hμW hφ0
+  exact ⟨f, hf, fun f' hf' => weilSmul_left_injective hφ0 (hf'.symm.trans hf)⟩
+
+end ParametricRankOne
+
+theorem residuePairing_surjective_of_rankOne_max [HasPrincipalDivisors K F]
+    (hRankOne : WeilDifferentialRankOne K F)
+    {W : Divisor K F} {φ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hφ0 : φ ≠ 0)
+    (hWmax : ∀ E : Divisor K F, φ ∈ omegaSpace E → E ≤ W) (D : Divisor K F) :
+    Function.Surjective (residuePairing K F W D hφ) := by
+  rintro ⟨μ, hμD⟩
+  have hφmem : φ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule W hφ
+  have hμmem : μ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule D hμD
+  obtain ⟨f, hf, -⟩ := hRankOne hφmem hφ0 hμmem
+  rcases eq_or_ne f 0 with rfl | hf0
+  · have hμ0 : (⟨μ, hμD⟩ : omegaSpace D) = 0 :=
+      Subtype.ext (hf.trans (weilSmul_zero_left φ))
+    exact ⟨0, (map_zero _).trans hμ0.symm⟩
+  · obtain ⟨P, hPord, _⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+    have hPinv : ∀ v, (-P) v = v.ord f⁻¹ := fun v => by
+      rw [Finsupp.neg_apply, hPord v, v.ord_inv]
+    have hinv : weilSmul K F f⁻¹ μ = φ := by
+      rw [hf, ← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hf0, weilSmul_one,
+        LinearMap.id_apply]
+    have hφD : φ ∈ omegaSpace (D + -P) := by
+      rw [← hinv]; exact weilSmul_mem_omegaSpace_add (inv_ne_zero hf0) hPinv hμD
+    have hDP : D + -P ≤ W := hWmax _ hφD
+    have hfL : f ∈ LSpace (W - D) := by
+      rw [mem_lSpace_iff_ord]; refine Or.inr fun v => ?_
+      have hv := hDP v
+      rw [Finsupp.add_apply, Finsupp.neg_apply, hPord v] at hv
+      rw [Finsupp.sub_apply]; linarith
+    exact ⟨⟨f, hfL⟩, Subtype.ext hf.symm⟩
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem exists_riemannGenusReachedAt_of_bounded
+    [IsCurveOver K F] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    ∃ (γ : ℤ) (D₀ : Divisor K F), RiemannGenusReachedAt γ D₀ := by
+  obtain ⟨γ, hγ⟩ := hbdd
+  obtain ⟨M, ⟨D₀, hD₀⟩, hMmax⟩ :=
+    Int.exists_greatest_of_bdd
+      (P := fun n => ∃ D : Divisor K F, Divisor.degree D - ell D = n)
+      ⟨γ, fun n ⟨D, hD⟩ => hD ▸ hγ D⟩
+      ⟨Divisor.degree (0 : Divisor K F) - ell (0 : Divisor K F), 0, rfl⟩
+  refine ⟨M + 1, D₀, ?_, ?_, ?_⟩
+  · exact finiteDimensional_lSpace D₀
+  · rw [hD₀]; ring
+  · intro D
+    have := hMmax (Divisor.degree D - ell D) ⟨D, rfl⟩
+    linarith
+
+theorem stichtenothGenusExists_of_bounded
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    StichtenothGenusExists K F :=
+  ⟨‹_›, ‹_›, exists_riemannGenusReachedAt_of_bounded hbdd⟩
+
+
+theorem indexOfSpecialty_sub_of_ge [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₀ D : Divisor K F} (hD : D₀ ≤ D)
+    [FiniteDimensional K (LSpace D)]
+    [hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀)] :
+    Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D) ∧
+      (Divisor.degree D - ell D) - (Divisor.degree D₀ - ell D₀)
+        = (indexOfSpecialty D₀ : ℤ) - (indexOfSpecialty D : ℤ) := by
+  have hABsub : adeleBdd D₀ ⊔ globalSub K F ≤ adeleBdd D ⊔ globalSub K F :=
+    sup_le_sup_right (adeleBdd_mono hD) _
+  have hBCsub : adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+    adeleBdd_sup_globalSub_le_adeleSpace _
+  obtain ⟨hfinBA, hdimBA⟩ := finrank_adeleBddSup_quotient (K := K) hD
+  have := hfinBA
+  have hfinCA : Module.Finite K (adeleSpace K F ⧸
+      (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [← adeleBddPrincipal_eq_comap]; exact hfin
+  obtain ⟨hfinCB, hdimCB⟩ := Submodule.finrank_quotient_chain'
+    (A := adeleBdd D₀ ⊔ globalSub K F) (B := adeleBdd D ⊔ globalSub K F)
+    (C := adeleSpace K F) hABsub hBCsub
+  have hi0 : indexOfSpecialty D₀
+      = finrank K (adeleSpace K F ⧸
+        (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap]
+  have hiD : indexOfSpecialty D
+      = finrank K (adeleSpace K F ⧸
+        (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap]
+  have := hfinCB
+  obtain ⟨_, hdimCA⟩ := Submodule.finrank_quotient_chain
+    (A := adeleBdd D₀ ⊔ globalSub K F) (B := adeleBdd D ⊔ globalSub K F)
+    (C := adeleSpace K F) hABsub hBCsub
+  refine ⟨?_, ?_⟩
+  · rw [show adeleBddPrincipal K F D
+        = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype
+      from adeleBddPrincipal_eq_comap D]
+    exact hfinCB
+  · have hcast : (indexOfSpecialty D₀ : ℤ)
+        = (indexOfSpecialty D : ℤ)
+          + (finrank K (↥(adeleBdd D ⊔ globalSub K F)
+              ⧸ (adeleBdd D₀ ⊔ globalSub K F).comap
+                (adeleBdd D ⊔ globalSub K F).subtype) : ℤ) := by
+      rw [hiD, hi0]; exact_mod_cast hdimCA
+    linarith [hdimBA, hcast]
+
+theorem degreeSub_ell_le_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {D₀ : Divisor K F}
+    (hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀))
+    (D : Divisor K F) :
+    Divisor.degree D - ell D ≤ (Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀ := by
+  have := hfin
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have hmono : Divisor.degree D - (ell D : ℤ)
+      ≤ Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) (le_sup_left : D ≤ D ⊔ D₀)
+    linarith
+  obtain ⟨_, heq⟩ :=
+    indexOfSpecialty_sub_of_ge (K := K) (le_sup_right : D₀ ≤ D ⊔ D₀)
+  have hi0 : (0 : ℤ) ≤ indexOfSpecialty (D ⊔ D₀) := Int.natCast_nonneg _
+  linarith
+
+theorem riemannGenusBounded_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hfin : IndexOfSpecialtyFinite K F) :
+    RiemannGenusBounded K F := by
+  obtain ⟨D₀, hD₀⟩ := hfin
+  exact ⟨(Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀,
+    degreeSub_ell_le_of_indexFinite hD₀⟩
+
+theorem stichtenothGenusExists_of_indexFinite
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hfin : IndexOfSpecialtyFinite K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_bounded (riemannGenusBounded_of_indexFinite hfin)
+
+theorem indexOfSpecialtyFinite_of_stichtenothGenusExists
+    [IsCurveOver K F] (hSG : StichtenothGenusExists K F) :
+    IndexOfSpecialtyFinite K F := by
+  obtain ⟨hne, hL0, γ, D₀, hD₀⟩ := hSG
+  have := hne; have := hL0
+  refine ⟨D₀, ?_⟩
+  rw [show adeleBddPrincipal K F D₀
+      = (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype
+    from adeleBddPrincipal_eq_comap D₀, ← adeleSpace_eq_of_genusReached hD₀,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.Finite.of_finite
+
+theorem stichtenothGenusExists_iff_indexFinite
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] :
+    StichtenothGenusExists K F ↔ IndexOfSpecialtyFinite K F :=
+  ⟨indexOfSpecialtyFinite_of_stichtenothGenusExists,
+    stichtenothGenusExists_of_indexFinite⟩
+
+theorem gate_indexOfSpecialty_engine_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  exact_mod_cast indexOfSpecialty_eq_zero_of_genusReached h
+
+theorem gate_stichtenothGenus_le_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {D₀ : Divisor K F}
+    (hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀))
+    {γ : ℤ} {D₁ : Divisor K F} (h : RiemannGenusReachedAt γ D₁) :
+    γ - 1 ≤ (Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀ := by
+  have := degreeSub_ell_le_of_indexFinite hfin D₁
+  rw [h.eq] at this; exact this
+
+theorem gate_riemannGenusBounded_of_reachedAt
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    RiemannGenusBounded K F :=
+  ⟨γ - 1, h.isMax⟩
+
+theorem gate_indexOfSpecialtyFinite_at_zero [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F (0 : Divisor K F)) :=
+  (indexOfSpecialty_eq_of_genusReached h 0).1
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem mul_mem_lSpace_add {D E : Divisor K F} {f g : F}
+    (hf : f ∈ LSpace D) (hg : g ∈ LSpace E) :
+    f * g ∈ LSpace (D + E) := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · rw [zero_mul]; exact (LSpace _).zero_mem
+  rcases eq_or_ne g 0 with rfl | hg0
+  · rw [mul_zero]; exact (LSpace _).zero_mem
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun v => ?_
+  rw [Finsupp.add_apply, neg_add, v.ord_mul hf0 hg0]
+  exact add_le_add ((mem_lSpace_iff_ord.mp hf).resolve_left hf0 v)
+    ((mem_lSpace_iff_ord.mp hg).resolve_left hg0 v)
+
+theorem pow_mem_lSpace_nsmul {B : Divisor K F} {f : F} (hf : f ∈ LSpace B) (j : ℕ) :
+    f ^ j ∈ LSpace (j • B) := by
+  induction j with
+  | zero => simpa using one_mem_lSpace_zero (K := K) (F := F)
+  | succ j ih =>
+    rw [pow_succ, succ_nsmul]
+    exact mul_mem_lSpace_add ih hf
+
+namespace PoleDivisorPackage
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degB_eq u B hB_eff n lin_indep mk c x hn_pos \
+  hu_mem mk.injEq hx_mem"
+p2m_open "AlgebraicCurve.PoleDivisorPackage"
+
+variable (P : PoleDivisorPackage K F)
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.pow_mul_u_mem_lSpace (j : ℕ) (i : Fin P.n)
+    :
+    P.x ^ j * P.u i ∈ LSpace ((j + P.c) • P.B) := by
+  rw [add_nsmul]
+  exact mul_mem_lSpace_add (pow_mem_lSpace_nsmul P.hx_mem j) (P.hu_mem i)
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "pow_mul_u_mem_lSpace"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.pow_mul_u_mem_lSpace_of_le {j m : ℕ}
+    (hjm : j + P.c ≤ m) (i : Fin P.n) :
+    P.x ^ j * P.u i ∈ LSpace (m • P.B) := by
+  refine lSpace_mono ?_ (P.pow_mul_u_mem_lSpace j i)
+  intro v
+  have hBv : (0 : ℤ) ≤ P.B v := P.hB_eff v
+  change ((j + P.c) • P.B) v ≤ (m • P.B) v
+  simp only [Finsupp.smul_apply, nsmul_eq_mul]
+  exact mul_le_mul_of_nonneg_right (by exact_mod_cast hjm) hBv
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "pow_mul_u_mem_lSpace_of_le"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.ell_nsmul_poleDivisor_ge [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    (P.n : ℤ) * (m - P.c + 1) ≤ ell (m • P.B) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  set g : Fin (m - P.c + 1) × Fin P.n → LSpace (m • P.B) :=
+    fun p => ⟨P.x ^ (p.1 : ℕ) * P.u p.2,
+      P.pow_mul_u_mem_lSpace_of_le (by have := p.1.isLt; omega) p.2⟩
+    with hgdef
+  have hsub : LinearIndependent K (fun p => (g p : F)) := by
+    have heq : (fun p => (g p : F))
+        = (fun p : ℕ × Fin P.n => P.x ^ p.1 * P.u p.2)
+            ∘ (fun p : Fin (m - P.c + 1) × Fin P.n => ((p.1 : ℕ), p.2)) := by
+      funext p; rfl
+    rw [heq]
+    refine P.lin_indep.comp _ ?_
+    intro p q hpq
+    simp only [Prod.mk.injEq] at hpq
+    exact Prod.ext (Fin.val_injective hpq.1) hpq.2
+  have hg : LinearIndependent K g := hsub.of_comp (LSpace (m • P.B)).subtype
+  have hcard := hg.fintype_card_le_finrank
+  rw [Fintype.card_prod, Fintype.card_fin, Fintype.card_fin] at hcard
+  have hZ : ((m - P.c + 1) * P.n : ℤ) ≤ (ell (m • P.B) : ℤ) := by exact_mod_cast hcard
+  have heq : (((m - P.c + 1 : ℕ) : ℤ) * P.n : ℤ) = (P.n : ℤ) * ((m : ℤ) - P.c + 1) := by
+    rw [Nat.cast_add, Nat.cast_sub hm, Nat.cast_one]; ring
+  linarith
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "ell_nsmul_poleDivisor_ge"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.degree_nsmul_sub_ell_le [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    Divisor.degree (m • P.B) - ell (m • P.B) ≤ (P.n : ℤ) * (P.c - 1) := by
+  have hge := P.ell_nsmul_poleDivisor_ge hm
+  have hdeg : Divisor.degree (m • P.B) = (m : ℤ) * P.n := by
+    rw [show m • P.B = (m : ℤ) • P.B from (natCast_zsmul _ _).symm,
+      Divisor.degree.map_zsmul, smul_eq_mul, P.degB_eq]
+  linarith
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degree_nsmul_sub_ell_le"
+end PoleDivisorPackage
+
+namespace PoleDivisorPackage
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degB_eq u B hB_eff n lin_indep mk c x hn_pos \
+  hu_mem mk.injEq hx_mem"
+end PoleDivisorPackage
+namespace PoleDivisorPackage
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.ell_nsmul_sub_pos [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) {A : Divisor K F} (hA : 0 ≤ A) {m : ℕ} (hm : P.c ≤ m)
+    (hbig : Divisor.degree A < (P.n : ℤ) * (m - P.c + 1)) :
+    0 < ell (m • P.B - A) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  have hle : m • P.B - A ≤ m • P.B := by
+    intro v
+    have hAv : (0 : ℤ) ≤ A v := hA v
+    rw [Finsupp.sub_apply]
+    linarith
+  have h48 := ell_sub_ell_le_degree_sub_degree (K := K) hle
+  rw [map_sub, sub_sub_cancel] at h48
+  have h412 := P.ell_nsmul_poleDivisor_ge hm
+  have : (0 : ℤ) < (ell (m • P.B - A) : ℤ) := by linarith
+  exact_mod_cast this
+
+end PoleDivisorPackage
+p2m_export "AlgebraicCurve" "PoleDivisorPackage.ell_nsmul_sub_pos"
+namespace PoleDivisorPackage
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.degree_sub_ell_le [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) (D : Divisor K F) :
+    Divisor.degree D - ell D ≤ (P.n : ℤ) * (P.c - 1) := by
+  classical
+  set D' : Divisor K F := D ⊔ 0 with hD'def
+  have hD'eff : 0 ≤ D' := le_sup_right
+  have hDD' : D ≤ D' := le_sup_left
+  have := finiteDimensional_lSpace (K := K) D'
+  have hmono : Divisor.degree D - (ell D : ℤ) ≤ Divisor.degree D' - ell D' := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hDD'
+    linarith
+  set m : ℕ := P.c + (Divisor.degree D').toNat with hmdef
+  have hcm : P.c ≤ m := Nat.le_add_right _ _
+  have hdegD' : 0 ≤ Divisor.degree D' := Divisor.degree_nonneg_of_nonneg hD'eff
+  have hbig : Divisor.degree D' < (P.n : ℤ) * (m - P.c + 1) := by
+    have hcast : ((m : ℤ) - P.c) = Divisor.degree D' := by
+      simp only [hmdef, Nat.cast_add, add_sub_cancel_left, Int.toNat_of_nonneg hdegD']
+    rw [hcast]
+    have hn1 : (1 : ℤ) ≤ P.n := by exact_mod_cast P.hn_pos
+    nlinarith
+  have hellpos := P.ell_nsmul_sub_pos hD'eff hcm hbig
+  have hnebot : LSpace (m • P.B - D') ≠ ⊥ :=
+    fun h => by rw [ell, h, finrank_bot] at hellpos; exact lt_irrefl 0 hellpos
+  obtain ⟨z, hzL, hz0⟩ := (Submodule.ne_bot_iff _).mp hnebot
+  obtain ⟨Dz, hDzord, hDzdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) z hz0
+  have hzmem := (mem_lSpace_iff_ord.mp hzL).resolve_left hz0
+  have hD'le : D' ≤ m • P.B + Dz := by
+    intro v
+    have := hzmem v
+    simp only [Finsupp.add_apply, Finsupp.sub_apply, neg_sub] at this ⊢
+    rw [hDzord]; linarith
+  have hellshift : ell (m • P.B + Dz) = ell (m • P.B) :=
+    (LinearEquiv.finrank_eq (lSpaceShiftEquiv (m • P.B) hz0 hDzord)).symm
+  have hdegshift : Divisor.degree (m • P.B + Dz) = Divisor.degree (m • P.B) := by
+    rw [map_add, hDzdeg, add_zero]
+  have := finiteDimensional_lSpace (K := K) (m • P.B + Dz)
+  have hmono' : Divisor.degree D' - (ell D' : ℤ)
+      ≤ Divisor.degree (m • P.B + Dz) - ell (m • P.B + Dz) := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hD'le
+    linarith
+  rw [hellshift, hdegshift] at hmono'
+  have h412 := P.degree_nsmul_sub_ell_le hcm
+  linarith
+
+end PoleDivisorPackage
+p2m_export "AlgebraicCurve" "PoleDivisorPackage.degree_sub_ell_le"
+
+theorem riemannGenusBounded_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    RiemannGenusBounded K F :=
+  ⟨(P.n : ℤ) * (P.c - 1), P.degree_sub_ell_le⟩
+
+theorem stichtenothGenusExists_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_bounded (riemannGenusBounded_of_poleDivisorPackage P)
+
+theorem indexOfSpecialtyFinite_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_stichtenothGenusExists
+    (stichtenothGenusExists_of_poleDivisorPackage P)
+
+theorem indexOfSpecialtyFinite_of_hasPoleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (h : HasPoleDivisorPackage K F) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_poleDivisorPackage h.some
+
+theorem stichtenothGenusExists_of_hasPoleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (h : HasPoleDivisorPackage K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_poleDivisorPackage h.some
+
+theorem gate_stichtenothGenus_le_of_poleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F)
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    γ ≤ (P.n : ℤ) * (P.c - 1) + 1 := by
+  have := P.degree_sub_ell_le D₀
+  rw [h.eq] at this; linarith
+
+theorem gate_ell_c_nsmul_ge [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    (P.n : ℤ) ≤ ell (P.c • P.B) := by
+  have h := P.ell_nsmul_poleDivisor_ge (le_refl P.c)
+  simp only [sub_self, zero_add, mul_one] at h
+  exact h
+
+theorem gate_x_transcendental_of_poleDivisorPackage (P : PoleDivisorPackage K F) :
+    LinearIndependent K (fun j : ℕ => P.x ^ j * P.u ⟨0, P.hn_pos⟩) := by
+  refine P.lin_indep.comp (fun j => (j, ⟨0, P.hn_pos⟩)) ?_
+  intro a b hab
+  exact (Prod.mk.injEq .. ▸ hab).1
+
+theorem gate_u_linearIndependent_of_poleDivisorPackage (P : PoleDivisorPackage K F) :
+    LinearIndependent K P.u := by
+  have h : LinearIndependent K (fun i : Fin P.n => P.x ^ (0 : ℕ) * P.u i) := by
+    refine P.lin_indep.comp (fun i => (0, i)) ?_
+    intro a b hab
+    exact (Prod.mk.injEq .. ▸ hab).2
+  simpa using h
+
+end AlgebraicCurve
+
+end
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+scoped instance instSumRamificationInertia_port {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F']
+    [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+    [HasPrincipalDivisors K F'] : SumRamificationInertia K F F' :=
+  ⟨fun v => Place.sum_ramificationIndex_mul_inertiaDeg v⟩
+end AlgebraicCurve
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+
+namespace TranscendenceTower
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF poleDivisor RegularOutside hx_indep hxreg v \
+  mk.injEq mk hvdeg x hxv"
+p2m_open "AlgebraicCurve.TranscendenceTower"
+
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F]
+variable (T : TranscendenceTower K E F)
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.x_ne_zero : T.x ≠ 0 := fun h => by
+  have := T.hxv; rw [h, Place.ord_zero] at this; exact absurd this (by decide)
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "x_ne_zero"
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+theorem xF_ne_zero : T.xF ≠ 0 :=
+  fun h => T.x_ne_zero ((algebraMap E F).injective (by rwa [map_zero]))
+
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.poleDivisor_apply (w : Place K F) :
+    T.poleDivisor w = (w.ramificationIndex E : ℤ) * (Finsupp.single T.v 1) (w.restrict E) :=
+  Divisor.pullback_apply (Finsupp.single T.v 1) w
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "poleDivisor_apply"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.poleDivisor_nonneg :
+    0 ≤ T.poleDivisor := by
+  classical
+  intro w
+  rw [Finsupp.coe_zero, Pi.zero_apply, T.poleDivisor_apply, Finsupp.single_apply]
+  refine mul_nonneg (Int.natCast_nonneg _) ?_
+  split_ifs <;> simp
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "poleDivisor_nonneg"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.xF_mem_lSpace_poleDivisor :
+    T.xF ∈ LSpace T.poleDivisor := by
+  classical
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun w => ?_
+  rw [T.poleDivisor_apply, Place.ord_restrict, Finsupp.single_apply]
+  rcases eq_or_ne (w.restrict E) T.v with hw | hw
+  · simp only [hw, T.hxv, ite_true, mul_one, mul_neg_one, le_refl]
+  · simp only [ite_eq_right (Ne.symm hw), mul_zero, neg_zero]
+    exact mul_nonneg (Int.natCast_nonneg _) (T.hxreg _ hw)
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF_mem_lSpace_poleDivisor"
+
+private theorem _root_.AlgebraicCurve.TranscendenceTower.degree_poleDivisor_eq_finrank_port :
+    Divisor.degree T.poleDivisor = (Module.finrank E F : ℤ) := by
+  rw [poleDivisor, Divisor.degree_pullback, Divisor.degree_single, T.hvdeg]
+  push_cast; ring
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "degree_poleDivisor_eq_finrank_port"
+omit [FiniteDimensional E F] in
+private theorem
+  _root_.AlgebraicCurve.TranscendenceTower.mem_lSpace_nsmul_poleDivisor_of_regular_outside {f : F}
+    (hreg : ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord f)
+    {c : ℕ} (hc : ∀ w ∈ T.v.fiber F, -(c : ℤ) ≤ w.ord f) :
+    f ∈ LSpace (c • T.poleDivisor) := by
+  classical
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact (LSpace _).zero_mem
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun w => ?_
+  rw [Finsupp.smul_apply, T.poleDivisor_apply, Finsupp.single_apply, nsmul_eq_mul]
+  rcases eq_or_ne (w.restrict E) T.v with hw | hw
+  · simp only [hw, ite_true, mul_one]
+    have he : (1 : ℤ) ≤ w.ramificationIndex E := by
+      exact_mod_cast w.ramificationIndex_pos (F := E)
+    have hbdd := hc w (Place.mem_fiber.mpr hw)
+    nlinarith [Int.natCast_nonneg c]
+  · simp only [ite_eq_right (Ne.symm hw), mul_zero, neg_zero]
+    exact hreg w hw
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "mem_lSpace_nsmul_poleDivisor_of_regular_outside"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.exists_forall_mem_lSpace_nsmul_poleDivisor
+    {n : ℕ} (u : Fin n → F)
+    (hreg : ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)) :
+    ∃ c : ℕ, ∀ i, u i ∈ LSpace (c • T.poleDivisor) := by
+  classical
+  refine ⟨(Finset.univ : Finset (Fin n)).sup fun i =>
+    (T.v.fiber F).sup fun w => (-(w.ord (u i))).toNat,
+    fun i => T.mem_lSpace_nsmul_poleDivisor_of_regular_outside (hreg i) ?_⟩
+  intro w hw
+  have h1 : (-(w.ord (u i))).toNat
+      ≤ (T.v.fiber F).sup fun w' => (-(w'.ord (u i))).toNat :=
+    Finset.le_sup (f := fun w' => (-(w'.ord (u i))).toNat) hw
+  have h2 : ((T.v.fiber F).sup fun w' => (-(w'.ord (u i))).toNat)
+      ≤ (Finset.univ : Finset (Fin n)).sup fun i' =>
+          (T.v.fiber F).sup fun w' => (-(w'.ord (u i'))).toNat :=
+    Finset.le_sup (f := fun i' => (T.v.fiber F).sup fun w' => (-(w'.ord (u i'))).toNat)
+      (Finset.mem_univ i)
+  have htnat : -(w.ord (u i)) ≤ ((-(w.ord (u i))).toNat : ℤ) := Int.self_le_toNat _
+  omega
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "exists_forall_mem_lSpace_nsmul_poleDivisor"
+end TranscendenceTower
+
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F]
+
+section PrincipalDivisors
+
+variable [HasPrincipalDivisors K F]
+
+namespace IntegralBasisInLSpace
+p2m_export "AlgebraicCurve.IntegralBasisInLSpace" "hu_indep c u mk.injEq hu_mem mk"
+end IntegralBasisInLSpace
+p2m_open_scoped "AlgebraicCurve.IntegralBasisInLSpace" in
+def IntegralBasisInLSpace.ofRegularOutside (T : TranscendenceTower K E F)
+    (u : Fin (Module.finrank E F) → F) (hu_indep : LinearIndependent E u)
+    (hreg : ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)) :
+    IntegralBasisInLSpace T where
+  c := (T.exists_forall_mem_lSpace_nsmul_poleDivisor u hreg).choose
+  u := u
+  hu_indep := hu_indep
+  hu_mem := (T.exists_forall_mem_lSpace_nsmul_poleDivisor u hreg).choose_spec
+
+omit [FiniteDimensional E F] in
+theorem hasIntegralBasisInLSpace_of_regularOutside (T : TranscendenceTower K E F)
+    (h : HasIntegralBasisRegularOutside K E F T) :
+    HasIntegralBasisInLSpace K E F T := by
+  obtain ⟨u, hu_indep, hreg⟩ := h
+  exact ⟨IntegralBasisInLSpace.ofRegularOutside T u hu_indep hreg⟩
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+theorem linearIndependent_pow_mul {x : E} {n : ℕ} {u : Fin n → F}
+    (hx : LinearIndependent K (fun j : ℕ => x ^ j)) (hu : LinearIndependent E u) :
+    LinearIndependent K (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2) := by
+  have heq : (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2)
+      = (fun p : ℕ × Fin n => (x ^ p.1) • u p.2) := by
+    funext p
+    rw [Algebra.smul_def, map_pow]
+  rw [heq]
+  exact linearIndependent_smul (R := K) (S := E) (A := F) hx hu
+
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+def PoleDivisorPackage.ofTranscendenceTower (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    PoleDivisorPackage K F where
+  x := T.xF
+  B := T.poleDivisor
+  hB_eff := T.poleDivisor_nonneg
+  hx_mem := T.xF_mem_lSpace_poleDivisor
+  n := Module.finrank E F
+  hn_pos := Module.finrank_pos
+  degB_eq := T.degree_poleDivisor_eq_finrank_port
+  c := IB.c
+  u := IB.u
+  hu_mem := IB.hu_mem
+  lin_indep := linearIndependent_pow_mul T.hx_indep IB.hu_indep
+
+theorem hasPoleDivisorPackage_of_transcendenceTower
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    HasPoleDivisorPackage K F :=
+  ⟨PoleDivisorPackage.ofTranscendenceTower T IB⟩
+
+theorem hasPoleDivisorPackage_of_hasIntegralBasisInLSpace
+    (T : TranscendenceTower K E F) (h : HasIntegralBasisInLSpace K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_transcendenceTower T h.some
+
+theorem hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside
+    (T : TranscendenceTower K E F) (h : HasIntegralBasisRegularOutside K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisInLSpace T
+    (hasIntegralBasisInLSpace_of_regularOutside T h)
+
+end PrincipalDivisors
+
+theorem indexOfSpecialtyFinite_of_transcendenceTower [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem stichtenothGenusExists_of_transcendenceTower [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem gate_ofTranscendenceTower_n_eq [HasPrincipalDivisors K F] (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    (PoleDivisorPackage.ofTranscendenceTower T IB).n = Module.finrank E F := rfl
+
+theorem gate_ofTranscendenceTower_B_eq [HasPrincipalDivisors K F] (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    (PoleDivisorPackage.ofTranscendenceTower T IB).B = T.poleDivisor := rfl
+
+theorem gate_ofTranscendenceTower_x_transcendental [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    LinearIndependent K
+      (fun j : ℕ => T.xF ^ j *
+        (PoleDivisorPackage.ofTranscendenceTower T IB).u ⟨0, Module.finrank_pos⟩) :=
+  gate_x_transcendental_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem gate_degree_pullback_single_of_deg_eq [HasPrincipalDivisors K F]
+    (v : Place K E) (d : ℕ) (hd : v.deg = d) :
+    Divisor.degree (Divisor.pullback F (Finsupp.single v (1 : ℤ)))
+      = (Module.finrank E F : ℤ) * d := by
+  rw [Divisor.degree_pullback, Divisor.degree_single, hd]; ring
+
+theorem gate_stichtenothGenus_le_of_transcendenceTower [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T)
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    γ ≤ (Module.finrank E F : ℤ) * (IB.c - 1) + 1 :=
+  gate_stichtenothGenus_le_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB) h
+
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open Module
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow mk.injEq algebraMap_mem' toValuationSubring mk \
+  ramificationIndex ramificationIndex_pos restrict mem_restrict_iff ord_restrict \
+  deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~comap_algebra\
+  Map_ne_top"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral {f : F}
+    (hf : IsIntegral w.toValuationSubring f) :
+    f ∈ w.toValuationSubring := by
+  obtain ⟨y, hy⟩ := IsIntegrallyClosed.isIntegral_iff.mp hf
+  exact hy ▸ y.2
+
+p2m_export "AlgebraicCurve.Place" "mem_of_isIntegral"
+
+theorem ord_nonneg_of_isIntegral {f : F} (hf : IsIntegral w.toValuationSubring f) :
+    0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral hf)
+
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral_of_algebraMap_mem {A : Type*}
+    [CommRing A] [Algebra A F]
+    (hA : ∀ a : A, algebraMap A F a ∈ w.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : f ∈ w.toValuationSubring := by
+  let : Algebra A w.toValuationSubring :=
+    ((algebraMap A F).codRestrict w.toValuationSubring.toSubring hA).toAlgebra
+  have : IsScalarTower A w.toValuationSubring F :=
+    IsScalarTower.of_algebraMap_eq fun a => rfl
+  exact w.mem_of_isIntegral hf.tower_top
+
+p2m_export "AlgebraicCurve.Place" "mem_of_isIntegral_of_algebraMap_mem"
+
+theorem ord_nonneg_of_isIntegral_of_algebraMap_mem {A : Type*} [CommRing A] [Algebra A F]
+    (hA : ∀ a : A, algebraMap A F a ∈ w.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : 0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral_of_algebraMap_mem hA hf)
+
+end Place
+
+section Bridge
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+variable {A : Type*} [CommRing A] [Algebra A E] [Algebra A F] [IsScalarTower A E F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow mk.injEq algebraMap_mem' toValuationSubring mk \
+  ramificationIndex ramificationIndex_pos restrict mem_restrict_iff ord_restrict \
+  deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg"
+end Place
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral_of_restrict [Algebra.IsIntegral E F]
+    (w : Place K F)
+    {u : Place K E} (hw : w.restrict E = u)
+    (hA : ∀ a : A, algebraMap A E a ∈ u.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : f ∈ w.toValuationSubring := by
+  refine w.mem_of_isIntegral_of_algebraMap_mem (fun a => ?_) hf
+  rw [IsScalarTower.algebraMap_apply A E F, ← w.mem_restrict_iff, hw]
+  exact hA a
+
+end Place
+p2m_export "AlgebraicCurve" "Place.mem_of_isIntegral_of_restrict"
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.ord_nonneg_of_isIntegral_of_restrict
+    [Algebra.IsIntegral E F] (w : Place K F)
+    {u : Place K E} (hw : w.restrict E = u)
+    (hA : ∀ a : A, algebraMap A E a ∈ u.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : 0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral_of_restrict hw hA hf)
+
+end Place
+p2m_export "AlgebraicCurve" "Place.ord_nonneg_of_isIntegral_of_restrict"
+namespace TranscendenceTower
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF poleDivisor RegularOutside hx_indep hxreg v \
+  mk.injEq mk hvdeg x hxv"
+end TranscendenceTower
+namespace TranscendenceTower
+p2m_open_scoped "AlgebraicCurve.TranscendenceTower" in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.ord_nonneg_of_isIntegral_of_regularOutside
+    [Algebra.IsIntegral E F] (T : TranscendenceTower K E F) (hA : T.RegularOutside A)
+    {f : F} (hf : IsIntegral A f) :
+    ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord f := fun w hw =>
+  w.ord_nonneg_of_isIntegral_of_restrict rfl (hA _ hw) hf
+
+end TranscendenceTower
+p2m_export "AlgebraicCurve" "TranscendenceTower.ord_nonneg_of_isIntegral_of_regularOutside"
+end Bridge
+
+section Headline
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F]
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+theorem linearIndependent_reindex_basis {s : Finset F} (b : Basis s E F) :
+    LinearIndependent E (fun i : Fin (Module.finrank E F) =>
+      b ((Fintype.equivFinOfCardEq (Module.finrank_eq_card_basis b).symm).symm i)) :=
+  b.linearIndependent.comp _ (Equiv.injective _)
+
+theorem hasIntegralBasisRegularOutside_of_isFractionRing
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    HasIntegralBasisRegularOutside K E F T := by
+  obtain ⟨s, b, hint⟩ := FiniteDimensional.exists_is_basis_integral A E F
+  set e : Fin (Module.finrank E F) ≃ s :=
+    (Fintype.equivFinOfCardEq (Module.finrank_eq_card_basis b).symm).symm
+  refine ⟨fun i => b (e i), linearIndependent_reindex_basis b, fun i w hw => ?_⟩
+  exact T.ord_nonneg_of_isIntegral_of_regularOutside hA (hint (e i)) w hw
+
+theorem hasIntegralBasisRegularOutside_of_hasRegularFractionSubring
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    HasIntegralBasisRegularOutside K E F T := by
+  obtain ⟨A, hfrac, hreg⟩ := h
+  have : IsFractionRing A E := hfrac
+  exact hasIntegralBasisRegularOutside_of_isFractionRing (A := A) T
+    (fun u hu a => hreg u hu (a : E) a.property)
+
+theorem hasPoleDivisorPackage_of_isFractionRing [HasPrincipalDivisors K F]
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside T
+    (hasIntegralBasisRegularOutside_of_isFractionRing T hA)
+
+theorem stichtenothGenusExists_of_isFractionRing [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasPoleDivisorPackage
+    (hasPoleDivisorPackage_of_isFractionRing T hA)
+
+theorem hasPoleDivisorPackage_of_hasRegularFractionSubring [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside T
+    (hasIntegralBasisRegularOutside_of_hasRegularFractionSubring T h)
+
+theorem stichtenothGenusExists_of_hasRegularFractionSubring [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasPoleDivisorPackage
+    (hasPoleDivisorPackage_of_hasRegularFractionSubring T h)
+
+namespace TranscendenceTower
+p2m_open_scoped "AlgebraicCurve.TranscendenceTower" in
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.adjoin_x_regularOutside (T :
+  TranscendenceTower K E F) :
+    ∀ u : Place K E, u ≠ T.v →
+      ∀ a ∈ Algebra.adjoin K {T.x}, a ∈ u.toValuationSubring := by
+  intro u hu a ha
+  let S : Subalgebra K E :=
+    { u.toValuationSubring.toSubsemiring with
+      algebraMap_mem' := u.algebraMap_mem' }
+  suffices h : a ∈ S from h
+  refine Algebra.adjoin_le ?_ ha
+  intro y hy
+  rw [Set.mem_singleton_iff] at hy
+  subst hy
+  change T.x ∈ u.toValuationSubring
+  exact AlgebraicCurve.Place.mem_of_ord_nonneg u T.x_ne_zero (T.hxreg u hu)
+
+end TranscendenceTower
+p2m_export "AlgebraicCurve" "TranscendenceTower.adjoin_x_regularOutside"
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+theorem hasRegularFractionSubring_of_adjoin_x_isFractionRing
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    HasRegularFractionSubring K E F T :=
+  ⟨Algebra.adjoin K {T.x}, hfrac, T.adjoin_x_regularOutside⟩
+
+theorem hasIntegralBasisRegularOutside_of_adjoin_x_isFractionRing
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    HasIntegralBasisRegularOutside K E F T :=
+  hasIntegralBasisRegularOutside_of_hasRegularFractionSubring T
+    (hasRegularFractionSubring_of_adjoin_x_isFractionRing T hfrac)
+
+theorem stichtenothGenusExists_of_adjoin_x_isFractionRing [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasRegularFractionSubring T
+    (hasRegularFractionSubring_of_adjoin_x_isFractionRing T hfrac)
+
+end Headline
+
+section Gates
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem gate_mem_of_isIntegral_recovers_comap (w : Place K F) (E : Type*) [Field E]
+    [Algebra E F] [Algebra.IsIntegral E F]
+    (hE : ∀ a : E, algebraMap E F a ∈ w.toValuationSubring) (f : F) :
+    f ∈ w.toValuationSubring := by
+  let : Algebra E w.toValuationSubring :=
+    ((algebraMap E F).codRestrict w.toValuationSubring.toSubring hE).toAlgebra
+  have : IsScalarTower E w.toValuationSubring F :=
+    IsScalarTower.of_algebraMap_eq fun _ => rfl
+  exact w.mem_of_isIntegral (Algebra.IsIntegral.isIntegral (R := E) f).tower_top
+
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+
+theorem gate_bridge_recovers_hxreg [Algebra.IsIntegral E F]
+    (T : TranscendenceTower K E F) (w : Place K F) (hw : w.restrict E ≠ T.v) :
+    0 ≤ w.ord T.xF := by
+  rw [TranscendenceTower.xF, Place.ord_restrict]
+  exact mul_nonneg (Int.natCast_nonneg _) (T.hxreg _ hw)
+
+theorem gate_regularOutside_mono (T : TranscendenceTower K E F) {A A' : Subalgebra K E}
+    (hle : A ≤ A')
+    (hA' : ∀ u : Place K E, u ≠ T.v → ∀ a ∈ A', a ∈ u.toValuationSubring) :
+    ∀ u : Place K E, u ≠ T.v → ∀ a ∈ A, a ∈ u.toValuationSubring :=
+  fun u hu a ha => hA' u hu a (hle ha)
+
+theorem gate_bot_regularOutside (T : TranscendenceTower K E F) :
+    ∀ u : Place K E, u ≠ T.v → ∀ a ∈ (⊥ : Subalgebra K E), a ∈ u.toValuationSubring := by
+  intro u _ a ha
+  obtain ⟨c, rfl⟩ := Algebra.mem_bot.mp ha
+  exact u.algebraMap_mem' c
+
+theorem gate_adjoin_x_not_regular_at_v (T : TranscendenceTower K E F) :
+    ¬ ∀ a ∈ Algebra.adjoin K {T.x}, a ∈ T.v.toValuationSubring := by
+  intro h
+  have hx := AlgebraicCurve.Place.ord_nonneg_of_mem T.v (h T.x (Algebra.subset_adjoin rfl))
+  rw [T.hxv] at hx
+  exact absurd hx (by decide)
+
+end Gates
+end AlgebraicCurve
+end
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg\
+  " in
+open _root_.P2MW.S_AlgebraicCurve_TranscendenceTower_degree_poleDivisor_eq_finrank.AlgebraicCurve in
+theorem solution {K : Type*} {E : Type*} {F : Type*} [Field K] [Field E] [Field F] [Algebra K E]
+    [Algebra K F] [Algebra E F] [IsScalarTower K E F] [FiniteDimensional E F]
+    [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] (T : TranscendenceTower K E F) :
+    Divisor.degree T.poleDivisor = (Module.finrank E F : ℤ) :=
+  AlgebraicCurve.TranscendenceTower.degree_poleDivisor_eq_finrank_port (K := K) (F := F) (E := E) (T
+    := T)
+
+end S_AlgebraicCurve_TranscendenceTower_degree_poleDivisor_eq_finrank
+end P2MW
+export P2MW.S_AlgebraicCurve_TranscendenceTower_degree_poleDivisor_eq_finrank (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace AlgebraicCurve
+theorem TranscendenceTower.degree_poleDivisor_eq_finrank {K : Type*} {E : Type*} {F : Type*}
+    [Field K] [Field E] [Field F] [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+    [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F) :
+    Divisor.degree T.poleDivisor = (Module.finrank E F : ℤ) :=
+  solution T
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_TranscendenceTower_poleDivisor_apply.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_TranscendenceTower_poleDivisor_apply.lean
new file mode 100644
index 0000000000..8c95b62d03
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_TranscendenceTower_poleDivisor_apply.lean
@@ -0,0 +1,2382 @@
+/-
+Based on Prove2Me node AlgebraicCurve.TranscendenceTower.poleDivisor_apply
+(c8adb414-3cbb-5da7-8b25-9073698e14c2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 0ac9512e-37d2-5e6a-bbb3-ecf416c5e7c3
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PoleDivisorPackage
+
+import Mathlib.Data.Int.LeastGreatest
+import Mathlib.LinearAlgebra.Matrix.FiniteDimensional
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Coefficients of the pole divisor π^*(v)
+
+Theorem statement: `AlgebraicCurve.TranscendenceTower.poleDivisor_apply`
+(`c8adb414-3cbb-5da7-8b25-9073698e14c2`), by Claude, 2026-09-05.
+
+Proof: submission `0ac9512e-37d2-5e6a-bbb3-ecf416c5e7c3`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K \subseteq E \subseteq F$ be fields forming a scalar tower over $K$, with $F/E$ separable, and
+assume `HasPrincipalDivisors K F`, i.e. every nonzero $f \in F$ admits a divisor on $F$ of degree
+$0$ whose coefficient at each place is the order $\mathrm{ord}(f)$ at that place. Let $T$ be
+transcendence-tower data for $K, E, F$: an element $x \in E$ whose powers $x^j$ ($j \in \mathbb{N}$)
+are linearly independent over $K$, together with a place $v$ of $E$ over $K$ (a valuation subring of
+$E$ containing $\mathrm{algebraMap}\,K\,E$, distinct from $E$ itself and a principal ideal ring)
+with $\deg v = 1$, $\mathrm{ord}_v(x) = -1$, and $\mathrm{ord}_u(x) \ge 0$ for every place $u \neq
+v$ of $E$ over $K$. Then for every place $w$ of $F$ over $K$, the coefficient at $w$ of the pole
+divisor $T.\mathrm{poleDivisor} =$ `Divisor.pullback F (Finsupp.single T.v 1)` equals the
+ramification index of $w$ over $E$ — the least $n > 0$ for which some nonzero $f \in E$ has
+$w(\mathrm{algebraMap}\,E\,F\,f) = n$ — multiplied by the value at the restricted place $w|_E$ (the
+contraction of the valuation subring of $w$ along $E \to F$) of the finitely supported function
+$\mathrm{single}\,(T.v)\,1$; that is, it is $e(w \mid T.v)$ when $w|_E = T.v$ and $0$ otherwise.
+
+This is the pointwise description of the pullback to $F$ of a single place of $E$, in the case of
+the place $v$ of the transcendence-tower data, so that the pole divisor of $x$ viewed on $F$ is
+$\sum_{w \mid v} e(w\mid v)\, w$. It is used in the estimates on $\sum_w \mathrm{ord}$-differences
+bounding twice the genus of $F$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_TranscendenceTower_poleDivisor_apply.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_TranscendenceTower_poleDivisor_apply
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow mk.injEq algebraMap_mem' toValuationSubring mk \
+  ramificationIndex ramificationIndex_pos restrict mem_restrict_iff ord_restrict \
+  deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg"
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "degree degree_single principal smul_def smul_apply pullback \
+  pullback_apply degree_pullback"
+end Divisor
+variable {D : Divisor K F}
+p2m_open_scoped "AlgebraicCurve.Divisor" in
+theorem Divisor.degree_nonneg_of_nonneg [IsCurveOver K F]
+    {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) : 0 ≤ Divisor.degree D := by
+  rw [Divisor.degree_eq_sum_support]
+  exact Finset.sum_nonneg fun v _ => mul_nonneg (hD v) (Int.natCast_nonneg _)
+theorem lSpace_eq_bot_of_degree_neg [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) : LSpace D = ⊥ := by
+  rw [eq_bot_iff]
+  intro f hf
+  rw [Submodule.mem_bot]
+  by_contra hf0
+  obtain ⟨P, hPord, hPdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+  have heff : ∀ v : Place K F, 0 ≤ (P + D) v := by
+    intro v
+    rw [Finsupp.add_apply, hPord]
+    rcases mem_lSpace_iff_ord.mp hf with rfl | h
+    · exact absurd rfl hf0
+    · linarith [h v]
+  have hdegPD : 0 ≤ Divisor.degree (P + D) := Divisor.degree_nonneg_of_nonneg heff
+  rw [map_add, hPdeg, zero_add] at hdegPD
+  exact absurd hdegPD (not_le.mpr hD)
+end AlgebraicCurve
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow mk.injEq algebraMap_mem' toValuationSubring mk \
+  ramificationIndex ramificationIndex_pos restrict mem_restrict_iff ord_restrict \
+  deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~comap_algebra\
+  Map_ne_top"
+
+variable (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mk_mem_maximalIdeal_iff {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    (⟨f, hf⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring
+      ↔ f = 0 ∨ 0 < v.ord f := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  constructor
+  · intro hu
+    rcases eq_or_ne f 0 with rfl | hf0
+    · exact Or.inl rfl
+    · refine Or.inr ?_
+      rcases lt_or_eq_of_le (AlgebraicCurve.Place.ord_nonneg_of_mem v hf) with h | h
+      · exact h
+      · exfalso
+        apply hu
+        rw [← v.adicValuation_coe_eq_one_iff ⟨f, hf⟩]
+        change v.adicValuation f = 1
+        rw [v.adicValuation_eq_exp_neg_ord hf0, ← h, neg_zero, WithZero.exp_zero]
+  · intro h hu
+    have hne : f ≠ 0 := fun h0 => hu.ne_zero (Subtype.ext h0)
+    have h0 : v.ord f = 0 := by
+      obtain ⟨u, hu'⟩ := hu
+      have hcoe : f = ((u : v.toValuationSubring) : F) := by rw [hu']
+      rw [hcoe]; exact v.ord_coe_unit u
+    rcases h with rfl | hpos
+    · exact hne rfl
+    · omega
+
+p2m_export "AlgebraicCurve.Place" "mk_mem_maximalIdeal_iff"
+end Place
+
+theorem ell_le_ell_sub_single_add_deg [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    ell D ≤ ell (D - Finsupp.single P 1) + P.deg := by
+  classical
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible P.toValuationSubring
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by
+    simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := by
+    intro g hg
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ g : F, g ∈ LSpace D → t ^ (D P) * g ∈ P.toValuationSubring := by
+    intro g hg
+    rcases eq_or_ne g 0 with rfl | hg0
+    · simp
+    · refine AlgebraicCurve.Place.mem_of_ord_nonneg P (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have := (mem_lSpace_iff_ord.mp hg).resolve_left hg0 P
+      linarith
+  let ψ : LSpace D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun f => ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+      map_add' := by intro f g; apply Subtype.ext; push_cast; ring
+      map_smul' := by
+        intro c f; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap]
+        ring }
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : LSpace D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ f : LSpace D, φ f = 0 ↔
+      (⟨t ^ (D P) * (f : F), hmem _ f.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := by
+    intro f
+    rw [show φ f = IsLocalRing.residue P.toValuationSubring ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+          from hres (ψ f),
+      IsLocalRing.residue_eq_zero_iff]
+  have hED : E ≤ D := by
+    rw [Finsupp.le_def]; intro v; rw [hE, Finsupp.sub_apply]
+    have : (0 : ℤ) ≤ Finsupp.single P 1 v := by
+      rcases eq_or_ne v P with rfl | hv
+      · simp
+      · simp [Finsupp.single_eq_of_ne hv]
+    linarith
+  have hsub : LSpace E ≤ LSpace D := lSpace_mono hED
+  have hker : LinearMap.ker φ = (LSpace E).comap (LSpace D).subtype := by
+    ext f
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi f, P.mk_mem_maximalIdeal_iff]
+    rcases eq_or_ne (f : F) 0 with hf0 | hf0
+    · simp only [hf0, mul_zero, true_or, true_iff]
+      exact (LSpace E).zero_mem
+    · rw [mem_lSpace_iff_ord]
+      have hfD := (mem_lSpace_iff_ord.mp f.2).resolve_left hf0
+      constructor
+      · rintro (h | h)
+        · exact absurd h (mul_ne_zero htn0 hf0)
+        · refine Or.inr (fun v => ?_)
+          rcases eq_or_ne v P with rfl | hv
+          · rw [hEP]; rw [hordmul hf0] at h; omega
+          · rw [hEv v hv]; exact hfD v
+      · rintro (h | h)
+        · exact absurd h hf0
+        · refine Or.inr ?_
+          have hP := h P
+          rw [hEP] at hP
+          rw [hordmul hf0]; omega
+  have hkerfin : finrank K (LinearMap.ker φ) = ell E := by
+    rw [hker, LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe hsub)]
+  have hquot : finrank K (LSpace D ⧸ LinearMap.ker φ) ≤ P.deg := by
+    rw [LinearEquiv.finrank_eq φ.quotKerEquivRange]
+    exact Submodule.finrank_le (LinearMap.range φ)
+  by_cases hfin : FiniteDimensional K (LSpace D)
+  · have := hfin
+    have hrn := Submodule.finrank_quotient_add_finrank (LinearMap.ker φ)
+    rw [hkerfin] at hrn
+    have hb : ell D = finrank K (LSpace D) := rfl
+    omega
+  · have h0 : ell D = 0 := by rw [ell]; exact finrank_of_infinite_dimensional hfin
+    omega
+
+theorem one_le_deg [IsCurveOver K F] (P : Place K F) : 1 ≤ P.deg := by
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  exact Module.finrank_pos
+
+theorem ell_le_degree_add_ellZero [IsCurveOver K F] {D : Divisor K F}
+    (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D : Divisor K F, (∀ v, 0 ≤ D v) →
+      (Divisor.degree D).toNat = m →
+      (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) by
+    exact H (Divisor.degree D).toNat D hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D hD hm
+    by_cases hD0 : D = 0
+    · subst hD0; simp
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ D P := by
+        have hne : D P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hD P; omega
+      set E : Divisor K F := D - Finsupp.single P 1 with hE
+      have hEeff : ∀ v, 0 ≤ E v := by
+        intro v; rw [hE, Finsupp.sub_apply]
+        rcases eq_or_ne v P with rfl | hv
+        · rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have hdegE : Divisor.degree E = Divisor.degree D - P.deg := by
+        rw [hE, map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hDnn : 0 ≤ Divisor.degree D := Divisor.degree_nonneg_of_nonneg hD
+      have hEnn : 0 ≤ Divisor.degree E := Divisor.degree_nonneg_of_nonneg hEeff
+      have hmlt : (Divisor.degree E).toNat < m := by rw [← hm]; omega
+      have hIH := IH _ hmlt E hEeff rfl
+      have hstep := ell_le_ell_sub_single_add_deg D P
+      rw [← hE] at hstep
+      have hstep' : (ell D : ℤ) ≤ (ell E : ℤ) + P.deg := by exact_mod_cast hstep
+      rw [hdegE] at hIH
+      linarith
+
+theorem ell_le_degree_add_one_of_effective [IsCurveOver K F]
+    (hC : ConstantsAreBase K F) {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  have h := ell_le_degree_add_ellZero hD
+  rw [ell_zero_eq_one_of_constantsAreBase hC] at h
+  exact_mod_cast h
+
+def lSpaceShiftEquiv (D : Divisor K F) {g : F} (hg : g ≠ 0)
+    {Dg : Divisor K F} (hDg : ∀ v, Dg v = v.ord g) :
+    LSpace D ≃ₗ[K] LSpace (D + Dg) where
+  toFun h := ⟨(h : F) * g⁻¹, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (h : F) 0 with hh0 | hh0
+    · left; rw [hh0, zero_mul]
+    · right; intro v
+      rw [Finsupp.add_apply, hDg, v.ord_mul hh0 (inv_ne_zero hg), v.ord_inv]
+      have := (mem_lSpace_iff_ord.mp h.2).resolve_left hh0 v
+      linarith⟩
+  invFun k := ⟨(k : F) * g, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (k : F) 0 with hk0 | hk0
+    · left; rw [hk0, zero_mul]
+    · right; intro v
+      have := (mem_lSpace_iff_ord.mp k.2).resolve_left hk0 v
+      rw [Finsupp.add_apply, hDg] at this
+      rw [v.ord_mul hk0 hg]
+      linarith⟩
+  map_add' h₁ h₂ := by apply Subtype.ext; push_cast; ring
+  map_smul' c h := by
+    apply Subtype.ext
+    simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def]
+    ring
+  left_inv h := by
+    apply Subtype.ext
+    change (h : F) * g⁻¹ * g = (h : F)
+    rw [mul_assoc, inv_mul_cancel₀ hg, mul_one]
+  right_inv k := by
+    apply Subtype.ext
+    change (k : F) * g * g⁻¹ = (k : F)
+    rw [mul_assoc, mul_inv_cancel₀ hg, mul_one]
+
+theorem ell_le_degree_add_one [IsCurveOver K F] (hC : ConstantsAreBase K F)
+    {D : Divisor K F} (hD : 0 ≤ Divisor.degree D) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  rcases eq_or_ne (ell D) 0 with h0 | h0
+  · rw [h0]; push_cast; linarith
+  · have hbot : LSpace D ≠ ⊥ := fun h => h0 (by rw [ell, h, finrank_bot])
+    obtain ⟨g, hgL, hg0⟩ := (Submodule.ne_bot_iff _).mp hbot
+    obtain ⟨Dg, hDgord, hDgdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) g hg0
+    have heff : ∀ v, 0 ≤ (D + Dg) v := by
+      intro v; rw [Finsupp.add_apply, hDgord]
+      have := (mem_lSpace_iff_ord.mp hgL).resolve_left hg0 v
+      linarith
+    have hdeg : Divisor.degree (D + Dg) = Divisor.degree D := by
+      rw [map_add, hDgdeg, add_zero]
+    have hell : ell D = ell (D + Dg) :=
+      LinearEquiv.finrank_eq (lSpaceShiftEquiv D hg0 hDgord)
+    have hfin := ell_le_degree_add_one_of_effective hC heff
+    rw [hdeg] at hfin
+    rw [hell]; exact hfin
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion factor mk mem_bot subtype_injective \
+  mk.injEq Quotient.subsingleton_iff Quotient.mk span restrictScalars inclusion_injective \
+  comapSubtypeEquivOfLe mem_comap finrank_quotient_add_finrank mem_top Quotient.equiv mkQ mem_map \
+  coe_subtype map_smul' zero one quotientQuotientEquivQuotient coe_eq_zero finrank_le \
+  range_subtype Quotient.mk_surjective map mem_inf mem_sup Quotient.mk_eq_zero topEquiv \
+  map_injective_of_injective comap_subtype_self mapQ subsingleton_iff module smul_def mk_eq_zero \
+  coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono map_sup coe_zero smul"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+def nestedComapMapMkQEquiv {A B C : Submodule K X} (_hAB : A ≤ B) (hBC : B ≤ C) :
+    ((B.comap C.subtype).map (A.comap C.subtype).mkQ : Submodule K _)
+      ≃ₗ[K] B ⧸ A.comap B.subtype := by
+  set S := A.comap C.subtype with hS
+  set T := B.comap C.subtype with hT
+  let ψ : (T : Type _) →ₗ[K] (C ⧸ S) := S.mkQ ∘ₗ T.subtype
+  have hker : LinearMap.ker ψ = S.comap T.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = T.map S.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let e1 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (T.map S.mkQ : Submodule K _) :=
+    (Submodule.Quotient.equiv _ (LinearMap.ker ψ) (LinearEquiv.refl K T)
+        (by rw [hker]; simp)).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have hmap : (S.comap T.subtype).map
+      (Submodule.comapSubtypeEquivOfLe hBC : (T : Type _) →ₗ[K] B) = A.comap B.subtype := by
+    ext ⟨b, hb⟩
+    simp only [mem_map, mem_comap, Submodule.coe_subtype, hS]
+    constructor
+    · rintro ⟨⟨⟨x, hxC⟩, hxB⟩, hxA, hxeq⟩
+      have hx : x = b := congrArg Subtype.val hxeq
+      subst hx; exact hxA
+    · intro hbA
+      exact ⟨⟨⟨b, hBC hb⟩, hb⟩, hbA, rfl⟩
+  let e2 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (B ⧸ A.comap B.subtype) :=
+    Submodule.Quotient.equiv _ _ (Submodule.comapSubtypeEquivOfLe hBC) hmap
+  exact e1.symm.trans e2
+
+theorem finrank_quotient_chain {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCB : Module.Finite K (C ⧸ B.comap C.subtype)]
+    [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (C ⧸ A.comap C.subtype) ∧
+      finrank K (C ⧸ A.comap C.subtype)
+        = finrank K (C ⧸ B.comap C.subtype) + finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (T.map S.mkQ : Submodule K _) := Module.Finite.equiv eK.symm
+  have : Module.Finite K ((C ⧸ S) ⧸ T.map S.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (C ⧸ S) := Module.Finite.of_submodule_quotient (T.map S.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+theorem finrank_quotient_chain' {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCA : Module.Finite K (C ⧸ A.comap C.subtype)] :
+    Module.Finite K (C ⧸ B.comap C.subtype) ∧
+      finrank K (C ⧸ B.comap C.subtype)
+        = finrank K (C ⧸ A.comap C.subtype) - finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (C ⧸ T) := Module.Finite.equiv e3
+  refine ⟨this, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+def adeleBddQuotSingleEquivResidueField (D : Divisor K F) (P : Place K F) :
+    (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+      ≃ₗ[K] P.ResidueField := by
+  classical
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  let π : P.toValuationSubring :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose
+  have hπ : Irreducible π :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose_spec
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := fun {g} hg => by
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ α : Place K F → F, α ∈ adeleBdd D → t ^ (D P) * α P ∈ P.toValuationSubring := by
+    intro α hα
+    rcases eq_or_ne (α P) 0 with hg0 | hg0
+    · simp [hg0]
+    · refine AlgebraicCurve.Place.mem_of_ord_nonneg P (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have h := hα P
+      rw [P.adicValuation_eq_exp_neg_ord hg0, WithZero.exp_le_exp] at h
+      linarith
+  let ψ : adeleBdd D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun α => ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩
+      map_add' := by
+        intro α β; apply Subtype.ext
+        simp only [Submodule.coe_add, Pi.add_apply]
+        push_cast; ring
+      map_smul' := by
+        intro c α; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap, Pi.smul_apply]
+        ring }
+  have hψ_apply : ∀ α : adeleBdd D,
+      (ψ α : F) = t ^ (D P) * (α : Place K F → F) P := fun α => rfl
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : adeleBdd D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ α : adeleBdd D, φ α = 0 ↔
+      (⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := fun α => by
+    rw [show φ α = IsLocalRing.residue P.toValuationSubring
+            ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ from hres (ψ α),
+      IsLocalRing.residue_eq_zero_iff]
+  have hker : LinearMap.ker φ = (adeleBdd E).comap (adeleBdd D).subtype := by
+    ext α
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi α, P.mk_mem_maximalIdeal_iff, mem_adeleBdd]
+    have hαD := α.2
+    constructor
+    · rintro (h | h) v
+      · have hα0 : (α : Place K F → F) P = 0 := by
+          rcases mul_eq_zero.mp h with h' | h'
+          · exact absurd h' htn0
+          · exact h'
+        by_cases hv : v = P
+        · subst v; rw [hα0, Valuation.map_zero]; exact zero_le
+        · rw [hEv v hv]; exact hαD v
+      · by_cases hv : v = P
+        · subst v
+          rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+          · rw [hα0, Valuation.map_zero]; exact zero_le
+          · rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP]
+            rw [hordmul hα0] at h; omega
+        · rw [hEv v hv]; exact hαD v
+    · intro h
+      rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+      · left; rw [hα0, mul_zero]
+      · right
+        have hP := h P
+        rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP] at hP
+        rw [hordmul hα0]; omega
+  have hsurj : Function.Surjective φ := by
+    intro c
+    obtain ⟨cl, hcl⟩ := IsLocalRing.residue_surjective (R := P.toValuationSubring) c
+    set f : F := (cl : F) * t ^ (-(D P)) with hf
+    have hαD : Pi.single P f ∈ adeleBdd D := by
+      intro v
+      by_cases hv : v = P
+      · subst v
+        simp only [Pi.single_eq_same]
+        rcases eq_or_ne (cl : F) 0 with hc0 | hc0
+        · rw [hf, hc0, zero_mul, Valuation.map_zero]; exact zero_le
+        · have hf0 : f ≠ 0 := by rw [hf]; exact mul_ne_zero hc0 (zpow_ne_zero _ ht0)
+          rw [P.adicValuation_eq_exp_neg_ord hf0, WithZero.exp_le_exp]
+          rw [hf, P.ord_mul hc0 (zpow_ne_zero _ ht0), P.ord_zpow, ht1, mul_one]
+          have hclnn := AlgebraicCurve.Place.ord_nonneg_of_mem P cl.2
+          linarith
+      · rw [Pi.single_eq_of_ne hv, Valuation.map_zero]; exact zero_le
+    refine ⟨⟨Pi.single P f, hαD⟩, ?_⟩
+    change res (ψ ⟨Pi.single P f, hαD⟩) = c
+    rw [hres]
+    rw [show (ψ ⟨Pi.single P f, hαD⟩ : P.toValuationSubring) = cl from ?_, hcl]
+    apply Subtype.ext
+    rw [hψ_apply]
+    change t ^ (D P) * (Pi.single P f : Place K F → F) P = (cl : F)
+    rw [show (Pi.single P f : Place K F → F) P = f from Pi.single_eq_same _ _, hf,
+      mul_comm (cl : F), ← mul_assoc, ← zpow_add₀ ht0, add_neg_cancel, zpow_zero, one_mul]
+  exact (Submodule.Quotient.equiv _ _ (LinearEquiv.refl K _) (by rw [← hker]; simp)).trans
+    (φ.quotKerEquivOfSurjective hsurj)
+
+theorem finrank_adeleBdd_quotient_single [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    Module.Finite K
+        (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype) ∧
+      finrank K
+          (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+        = P.deg := by
+  have := IsCurveOver.finite_residueField (K := K) P
+  exact ⟨Module.Finite.equiv (adeleBddQuotSingleEquivResidueField D P).symm,
+    (adeleBddQuotSingleEquivResidueField D P).finrank_eq⟩
+
+theorem finrank_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+      (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+        = Divisor.degree D₂ - Divisor.degree D₁ := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D₁ D₂ : Divisor K F, D₁ ≤ D₂ →
+      (Divisor.degree (D₂ - D₁)).toNat = m →
+      Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+        (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+          = Divisor.degree D₂ - Divisor.degree D₁ from
+    H _ D₁ D₂ hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D₁ D₂ hD hm
+    have hEeff : ∀ v, 0 ≤ (D₂ - D₁) v := fun v => by
+      rw [Finsupp.sub_apply]; have := hD v; omega
+    by_cases hD0 : D₂ - D₁ = 0
+    · have hD12 : D₁ = D₂ := (sub_eq_zero.mp hD0).symm
+      subst hD12
+      rw [Submodule.comap_subtype_self]
+      have : Subsingleton (adeleBdd D₁ ⧸ (⊤ : Submodule K (adeleBdd D₁))) :=
+        Submodule.Quotient.subsingleton_iff.mpr rfl
+      exact ⟨Module.Finite.of_finite, by simp [Module.finrank_zero_of_subsingleton]⟩
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ (D₂ - D₁) P := by
+        have hne : (D₂ - D₁) P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hEeff P; omega
+      set D₂' : Divisor K F := D₂ - Finsupp.single P 1 with hD₂'
+      have h12' : D₁ ≤ D₂' := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]
+          have := hPpos; rw [Finsupp.sub_apply] at this; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have h2'2 : D₂' ≤ D₂ := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]
+      have hdegD₂' : Divisor.degree D₂' = Divisor.degree D₂ - P.deg := by
+        rw [hD₂', map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hEnn : 0 ≤ Divisor.degree (D₂ - D₁) := Divisor.degree_nonneg_of_nonneg hEeff
+      have hE'nn : 0 ≤ Divisor.degree (D₂' - D₁) := Divisor.degree_nonneg_of_nonneg
+        (fun v => by rw [Finsupp.sub_apply]; have := h12' v; omega)
+      have hdegdiff : Divisor.degree (D₂' - D₁) = Divisor.degree (D₂ - D₁) - P.deg := by
+        simp only [hD₂', map_sub, Divisor.degree_single, one_mul]; ring
+      have hmlt : (Divisor.degree (D₂' - D₁)).toNat < m := by rw [← hm]; omega
+      obtain ⟨hfin', hrank'⟩ := IH _ hmlt D₁ D₂' h12' rfl
+      obtain ⟨hfinS, hrankS⟩ := finrank_adeleBdd_quotient_single (K := K) D₂ P
+      rw [← hD₂'] at hfinS hrankS
+      have := hfin'; have := hfinS
+      obtain ⟨hfin, hrank⟩ := Submodule.finrank_quotient_chain
+        (A := adeleBdd D₁) (B := adeleBdd D₂') (C := adeleBdd D₂)
+        (adeleBdd_mono h12') (adeleBdd_mono h2'2)
+      refine ⟨hfin, ?_⟩
+      rw [hrank, hrankS]
+      push_cast
+      linarith [hrank', hdegD₂']
+
+theorem module_finite_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  (finrank_adeleBdd_quotient hD).1
+
+theorem finrank_adeleBdd_quotient_eq [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+      = Divisor.degree D₂ - Divisor.degree D₁ :=
+  (finrank_adeleBdd_quotient hD).2
+
+def lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (_hD : D₁ ≤ D₂) :
+    (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      →ₗ[K] (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  Submodule.mapQ _ _
+    ((diagonalHom K F).restrict
+      (p := (LSpace D₂ : Submodule K F)) (q := (adeleBdd D₂ : Submodule K _))
+      (fun f hf => diagonal_mem_adeleBdd_iff.mpr hf))
+    (fun f hf => by
+      simp only [Submodule.mem_comap, Submodule.coe_subtype] at hf ⊢
+      exact diagonal_mem_adeleBdd_iff.mpr hf)
+
+theorem lSpaceQuotientToAdeleBddQuotient_injective {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Function.Injective (lSpaceQuotientToAdeleBddQuotient hD) := by
+  rw [injective_iff_map_eq_zero]
+  intro x hx
+  obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+  rw [Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype]
+  rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk f)
+        = Submodule.Quotient.mk ((diagonalHom K F).restrict
+            (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f) from rfl,
+    Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype] at hx
+  exact diagonal_mem_adeleBdd_iff.mp hx
+
+
+theorem ell_sub_ell_le_degree_sub_degree [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)] :
+    (ell D₂ : ℤ) - (ell D₁ : ℤ) ≤ Divisor.degree D₂ - Divisor.degree D₁ := by
+  have := module_finite_adeleBdd_quotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    rw [hℓ₁]; exact (Submodule.finrank_quotient_add_finrank _).symm
+  have hemb : finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      ≤ finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+    LinearMap.finrank_le_finrank_of_injective (lSpaceQuotientToAdeleBddQuotient_injective hD)
+  have hloc := finrank_adeleBdd_quotient_eq hD
+  have : (ell D₂ : ℤ) - (ell D₁ : ℤ)
+      = (finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) : ℤ) := by
+    rw [hL]; push_cast; ring
+  rw [this, ← hloc]
+  exact_mod_cast hemb
+
+theorem adeleBdd_inf_sup_globalSub {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F)
+      = adeleBdd D₁ ⊔ adeleBdd D₂ ⊓ globalSub K F := by
+  rw [inf_comm, sup_inf_assoc_of_le _ (adeleBdd_mono hD), inf_comm]
+
+theorem map_diagonal_lSpace_inf_adeleBdd {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (LSpace D₂).map (diagonalHom K F) ⊓ adeleBdd D₁ = (LSpace D₁).map (diagonalHom K F) := by
+  rw [map_diagonal_lSpace, map_diagonal_lSpace, inf_right_comm,
+    inf_eq_right.mpr (adeleBdd_mono hD)]
+
+theorem gate_finrank_adeleBdd_quotient_single_point [IsCurveOver K F] (P : Place K F) :
+    (finrank K (adeleBdd (Finsupp.single P 1 : Divisor K F)
+        ⧸ (adeleBdd (0 : Divisor K F)).comap (adeleBdd (Finsupp.single P 1)).subtype) : ℤ)
+      = (P.deg : ℤ) := by
+  classical
+  have h01 : (0 : Divisor K F) ≤ Finsupp.single P 1 := by
+    intro v; rw [Finsupp.zero_apply, Finsupp.single_apply]; split_ifs <;> omega
+  have h := finrank_adeleBdd_quotient_eq (K := K) h01
+  rw [h, map_zero, sub_zero, Divisor.degree_single, one_mul]
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion factor mk mem_bot subtype_injective \
+  mk.injEq Quotient.subsingleton_iff Quotient.mk span restrictScalars inclusion_injective \
+  comapSubtypeEquivOfLe mem_comap finrank_quotient_add_finrank mem_top Quotient.equiv mkQ mem_map \
+  coe_subtype map_smul' zero one quotientQuotientEquivQuotient coe_eq_zero finrank_le \
+  range_subtype Quotient.mk_surjective map mem_inf mem_sup Quotient.mk_eq_zero topEquiv \
+  map_injective_of_injective comap_subtype_self mapQ subsingleton_iff module smul_def mk_eq_zero \
+  coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono map_sup coe_zero smul"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+theorem comap_subtype_sup_of_le_of_le {S T C : Submodule K X} (hS : S ≤ C) (hT : T ≤ C) :
+    S.comap C.subtype ⊔ T.comap C.subtype = (S ⊔ T).comap C.subtype := by
+  apply Submodule.map_injective_of_injective (f := C.subtype) C.subtype_injective
+  rw [Submodule.map_sup, Submodule.map_comap_subtype, Submodule.map_comap_subtype,
+    Submodule.map_comap_subtype, inf_eq_right.mpr hS, inf_eq_right.mpr hT,
+    inf_eq_right.mpr (sup_le hS hT)]
+
+theorem finrank_quotient_chain_top {M : Type*} [AddCommGroup M] [Module K M]
+    {A B : Submodule K M} (hAB : A ≤ B)
+    [hMB : Module.Finite K (M ⧸ B)] [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (M ⧸ A) ∧
+      finrank K (M ⧸ A) = finrank K (M ⧸ B) + finrank K (B ⧸ A.comap B.subtype) := by
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  let ψ : (B : Type _) →ₗ[K] (M ⧸ A) := A.mkQ ∘ₗ B.subtype
+  have hker : LinearMap.ker ψ = A.comap B.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = B.map A.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let eK : (B ⧸ A.comap B.subtype) ≃ₗ[K] (B.map A.mkQ : Submodule K (M ⧸ A)) :=
+    (Submodule.quotEquivOfEq _ _ hker.symm).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have : Module.Finite K (B.map A.mkQ : Submodule K (M ⧸ A)) := Module.Finite.equiv eK
+  have : Module.Finite K ((M ⧸ A) ⧸ B.map A.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (M ⧸ A) := Module.Finite.of_submodule_quotient (B.map A.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (B.map A.mkQ)
+  rw [LinearEquiv.finrank_eq e3, ← LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem globalSub_le_adeleSpace [HasPrincipalDivisors K F] :
+    globalSub K F ≤ adeleSpace K F := by
+  rintro _ ⟨f, rfl⟩
+  exact diagonal_mem_adeleSpace f
+
+theorem adeleBdd_sup_globalSub_le_adeleSpace [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+  sup_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_eq_comap [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBddPrincipal K F D = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype :=
+  Submodule.comap_subtype_sup_of_le_of_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_mono {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBddPrincipal K F D₁ ≤ adeleBddPrincipal K F D₂ :=
+  sup_le_sup_right (Submodule.comap_mono (adeleBdd_mono hD)) _
+
+section FiniteLSpace
+
+variable [IsCurveOver K F]
+
+theorem finiteDimensional_lSpace [hL0 : FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (D : Divisor K F) : FiniteDimensional K (LSpace D) := by
+  have h0D : (0 : Divisor K F) ≤ D ⊔ 0 := le_sup_right
+  have hDD : D ≤ D ⊔ 0 := le_sup_left
+  suffices h : FiniteDimensional K (LSpace (D ⊔ 0)) by
+    exact Module.Finite.of_injective (Submodule.inclusion (lSpace_mono hDD))
+      (Submodule.inclusion_injective _)
+  have := module_finite_adeleBdd_quotient (K := K) h0D
+  have hfinQ : FiniteDimensional K
+      (LSpace (D ⊔ 0) ⧸ (LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype) :=
+    Module.Finite.of_injective _ (lSpaceQuotientToAdeleBddQuotient_injective h0D)
+  have : FiniteDimensional K
+      ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype : Submodule K _) :=
+    Module.Finite.equiv (Submodule.comapSubtypeEquivOfLe (lSpace_mono h0D)).symm
+  exact Module.Finite.of_submodule_quotient
+    ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype)
+
+end FiniteLSpace
+
+
+theorem range_lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD)
+      = ((adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype).map
+          ((adeleBdd D₁).comap (adeleBdd D₂).subtype).mkQ := by
+  classical
+  ext z
+  obtain ⟨α, rfl⟩ := Submodule.Quotient.mk_surjective _ z
+  simp only [LinearMap.mem_range, Submodule.mem_map, Submodule.mem_comap, Submodule.coe_subtype,
+    Submodule.mkQ_apply]
+  constructor
+  · rintro ⟨x, hx⟩
+    obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+    have hxeq : Submodule.Quotient.mk
+        ((diagonalHom K F).restrict (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f)
+        = (Submodule.Quotient.mk α :
+            adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) := hx
+    refine ⟨α, ?_, rfl⟩
+    have hdiag2 : (diagonalHom K F (f : F)) ∈ adeleBdd D₂ := diagonal_mem_adeleBdd_iff.mpr f.2
+    have hsub : (α : Place K F → F) - diagonalHom K F (f : F) ∈ adeleBdd D₁ := by
+      have hq := (Submodule.Quotient.eq _).mp hxeq.symm
+      simpa using hq
+    refine Submodule.mem_sup.mpr ⟨(α : Place K F → F) - diagonalHom K F (f : F), hsub,
+      diagonalHom K F (f : F), diagonal_mem_globalSub _, ?_⟩
+    abel
+  · rintro ⟨β, hβ, hβeq⟩
+    have hβ' : (β : Place K F → F) ∈ adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F) :=
+      Submodule.mem_inf.mpr ⟨β.2, hβ⟩
+    rw [adeleBdd_inf_sup_globalSub hD, ← map_diagonal_lSpace] at hβ'
+    obtain ⟨γ, hγ, δ, ⟨f, hf, hfδ⟩, hsum⟩ := Submodule.mem_sup.mp hβ'
+    refine ⟨Submodule.Quotient.mk ⟨f, hf⟩, ?_⟩
+    rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk ⟨f, hf⟩)
+          = Submodule.Quotient.mk ((diagonalHom K F).restrict
+              (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) ⟨f, hf⟩) from rfl,
+      ← hβeq, Submodule.Quotient.eq]
+    refine Submodule.mem_comap.mpr ?_
+    change diagonalHom K F f - (β : Place K F → F) ∈ adeleBdd D₁
+    have hβsub : diagonalHom K F f - (β : Place K F → F) = -γ := by
+      rw [← hsum, hfδ]; ring
+    rw [hβsub]; exact (adeleBdd D₁).neg_mem hγ
+
+
+theorem finrank_adeleBddSup_quotient [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) [hL : FiniteDimensional K (LSpace D₂)] :
+    Module.Finite K (↥(adeleBdd D₂ ⊔ globalSub K F)
+        ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) ∧
+      (finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+          ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) : ℤ)
+        = (Divisor.degree D₂ - ell D₂) - (Divisor.degree D₁ - ell D₁) := by
+  classical
+  let A : Submodule K (adeleBdd D₂) := (adeleBdd D₁).comap (adeleBdd D₂).subtype
+  let B : Submodule K (adeleBdd D₂) :=
+    (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype
+  have hAB : A ≤ B := Submodule.comap_mono le_sup_left
+  have hfinA : Module.Finite K (adeleBdd D₂ ⧸ A) := module_finite_adeleBdd_quotient hD
+  have hdimA : (finrank K (adeleBdd D₂ ⧸ A) : ℤ) = Divisor.degree D₂ - Divisor.degree D₁ :=
+    finrank_adeleBdd_quotient_eq hD
+  have hran : LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD) = B.map A.mkQ :=
+    range_lSpaceQuotientToAdeleBddQuotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hdimL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K)
+      ((LSpace D₁).comap (LSpace D₂).subtype)
+    rw [← hℓ₁] at h; exact h.symm
+  have hdimB : ell D₂ = finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) + ell D₁ := by
+    rw [← hran, LinearMap.finrank_range_of_inj
+      (lSpaceQuotientToAdeleBddQuotient_injective hD)]
+    exact hdimL
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  have hfinB : Module.Finite K (adeleBdd D₂ ⧸ B) := Module.Finite.equiv e3
+  have hdim2 : finrank K (adeleBdd D₂ ⧸ A)
+      = finrank K (adeleBdd D₂ ⧸ B) + finrank K (B.map A.mkQ : Submodule K _) := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K) (M := adeleBdd D₂ ⧸ A)
+      (B.map A.mkQ)
+    rw [LinearEquiv.finrank_eq e3] at h; omega
+  have e2 := LinearMap.quotientInfEquivSupQuotient (R := K)
+    (adeleBdd D₂) (adeleBdd D₁ ⊔ globalSub K F)
+  have hsup : adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F) = adeleBdd D₂ ⊔ globalSub K F := by
+    rw [← sup_assoc, sup_eq_left.mpr (adeleBdd_mono hD)]
+  have hB' : (adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype = B := by
+    rw [Submodule.comap_subtype_self, top_inf_eq]
+  let eL : (adeleBdd D₂ ⧸ B) ≃ₗ[K]
+      (adeleBdd D₂ ⧸ ((adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+        (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype)) :=
+    Submodule.quotEquivOfEq _ _ hB'.symm
+  have hfin_iso : Module.Finite K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype) :=
+    Module.Finite.equiv (eL.trans e2)
+  have hdim_iso : finrank K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype)
+      = finrank K (adeleBdd D₂ ⧸ B) :=
+    (LinearEquiv.finrank_eq (eL.trans e2)).symm
+  have hcast : (finrank K (adeleBdd D₂ ⧸ A) : ℤ)
+      = (finrank K (adeleBdd D₂ ⧸ B) : ℤ) + ((ell D₂ : ℤ) - (ell D₁ : ℤ)) := by
+    have hb : (ell D₂ : ℤ)
+        = (finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) : ℤ) + (ell D₁ : ℤ) := by
+      exact_mod_cast hdimB
+    push_cast [hdim2]; linarith
+  have hgoal : (finrank K (adeleBdd D₂ ⧸ B) : ℤ)
+      = Divisor.degree D₂ - ↑(ell D₂) - (Divisor.degree D₁ - ↑(ell D₁)) := by
+    linarith [hdimA, hcast]
+  clear_value eL
+  exact hsup ▸ ⟨hfin_iso, by rw [hdim_iso]; exact hgoal⟩
+
+section Index
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+
+theorem adeleBddSup_eq_of_degree_sub_ell_eq {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)]
+    (heq : Divisor.degree D₂ - ell D₂ = Divisor.degree D₁ - ell D₁) :
+    adeleBdd D₂ ⊔ globalSub K F = adeleBdd D₁ ⊔ globalSub K F := by
+  obtain ⟨hfin, hdim⟩ := finrank_adeleBddSup_quotient hD
+  rw [heq, sub_self] at hdim
+  refine le_antisymm ?_ (sup_le_sup_right (adeleBdd_mono hD) _)
+  have := hfin
+  have hd0 : finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) = 0 := by
+    exact_mod_cast hdim
+  have hsub : Subsingleton (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) :=
+    Module.finrank_zero_iff.mp hd0
+  have htop := Submodule.Quotient.subsingleton_iff.mp hsub
+  intro x hx
+  have hxc : (⟨x, hx⟩ : ↥(adeleBdd D₂ ⊔ globalSub K F)) ∈
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype := by
+    rw [htop]; exact Submodule.mem_top
+  exact hxc
+
+end Index
+
+namespace RiemannGenusReachedAt
+p2m_export "AlgebraicCurve.RiemannGenusReachedAt" "finite mk eq isMax"
+end RiemannGenusReachedAt
+namespace RiemannGenusReachedAt
+p2m_open_scoped "AlgebraicCurve.RiemannGenusReachedAt" in
+private theorem _root_.AlgebraicCurve.RiemannGenusReachedAt.eq_of_ge [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {D : Divisor K F} (hD : D₀ ≤ D) :
+    Divisor.degree D - ell D = γ - 1 := by
+  have := finiteDimensional_lSpace (K := K) D
+  have hge : Divisor.degree D₀ - (ell D₀ : ℤ) ≤ Divisor.degree D - ell D := by
+    have := ell_sub_ell_le_degree_sub_degree (K := K) hD
+    linarith
+  exact le_antisymm (h.isMax D) (h.eq ▸ hge)
+
+end RiemannGenusReachedAt
+p2m_export "AlgebraicCurve" "RiemannGenusReachedAt.eq_of_ge"
+
+theorem adeleSpace_eq_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    adeleSpace K F = adeleBdd D₀ ⊔ globalSub K F := by
+  refine le_antisymm ?_ (adeleBdd_sup_globalSub_le_adeleSpace D₀)
+  rw [adeleSpace, iSup_le_iff]
+  intro D
+  refine le_trans (adeleBdd_mono (le_sup_left : D ≤ D ⊔ D₀)) ?_
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have heq : Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) = Divisor.degree D₀ - ell D₀ :=
+    (h.eq_of_ge le_sup_right).trans h.eq.symm
+  have hsup := adeleBddSup_eq_of_degree_sub_ell_eq (K := K)
+    (le_sup_right : D₀ ≤ D ⊔ D₀) heq
+  rw [← hsup]
+  exact le_sup_left
+
+theorem indexOfSpecialty_eq_zero_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    indexOfSpecialty D₀ = 0 := by
+  rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap, ← adeleSpace_eq_of_genusReached h,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.finrank_zero_of_subsingleton
+
+
+
+theorem gate_indexOfSpecialty_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  have h1 := (indexOfSpecialty_eq_of_genusReached h D₀).2
+  have h2 := h.eq
+  have h3 := indexOfSpecialty_eq_zero_of_genusReached h
+  exact_mod_cast h3
+
+theorem gate_riemannInequality_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Divisor.degree D + 1 - γ ≤ (ell D : ℤ) := by
+  have heq := (indexOfSpecialty_eq_of_genusReached h D).2
+  have hnn : (0 : ℤ) ≤ indexOfSpecialty D := Int.natCast_nonneg _
+  linarith
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem adeleSpaceMul_add [HasPrincipalDivisors K F] (f g : F) :
+    adeleSpaceMul K F (f + g) = adeleSpaceMul K F f + adeleSpaceMul K F g := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, LinearMap.add_apply, Submodule.coe_add,
+    Pi.add_apply, add_mul]
+
+theorem adeleSpaceMul_zero [HasPrincipalDivisors K F] :
+    adeleSpaceMul K F (0 : F) = 0 := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, zero_mul, LinearMap.zero_apply,
+    Submodule.coe_zero, Pi.zero_apply]
+
+theorem weilSmul_add_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f + g) φ = weilSmul K F f φ + weilSmul K F g φ := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_add, LinearMap.add_apply, map_add]
+
+theorem weilSmul_zero_left [HasPrincipalDivisors K F]
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (0 : F) φ = 0 := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_zero, LinearMap.zero_apply, map_zero]
+
+theorem weilSmul_neg_left [HasPrincipalDivisors K F] (f : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (-f) φ = -weilSmul K F f φ := by
+  have h := weilSmul_add_left (K := K) (F := F) f (-f) φ
+  rw [add_neg_cancel, weilSmul_zero_left] at h
+  exact (neg_eq_of_add_eq_zero_right h.symm).symm
+
+theorem weilSmul_sub_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f - g) φ = weilSmul K F f φ - weilSmul K F g φ := by
+  rw [sub_eq_add_neg, weilSmul_add_left, weilSmul_neg_left, sub_eq_add_neg]
+
+theorem weilSmul_eq_zero_iff_left [HasPrincipalDivisors K F]
+    {f : F} {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    weilSmul K F f φ = 0 ↔ f = 0 := by
+  refine ⟨fun h => ?_, fun h => h ▸ weilSmul_zero_left φ⟩
+  by_contra hf
+  exact hφ (weilSmul_injective hf (h.trans (map_zero (weilSmul K F f)).symm))
+
+theorem weilSmul_left_injective [HasPrincipalDivisors K F]
+    {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    Function.Injective (fun f : F => weilSmul K F f φ) := by
+  intro f g hfg
+  have hsub : weilSmul K F (f - g) φ = 0 := by
+    rw [weilSmul_sub_left, sub_eq_zero]; exact hfg
+  exact sub_eq_zero.mp ((weilSmul_eq_zero_iff_left hφ).mp hsub)
+
+variable (K F) in
+def doubleResiduePairing [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) :
+    LSpace (W - D) × LSpace (W - D) →ₗ[K] omegaSpace D :=
+  (residuePairing K F W D hφ).coprod (residuePairing K F W D hμ)
+
+theorem doubleResiduePairing_apply_coe [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (g h : LSpace (W - D)) :
+    (doubleResiduePairing K F W D hφ hμ (g, h) : Module.Dual K (adeleSpace K F))
+      = weilSmul K F (g : F) φ + weilSmul K F (h : F) μ := by
+  simp only [doubleResiduePairing, LinearMap.coprod_apply, Submodule.coe_add,
+    residuePairing_apply_coe]
+
+theorem doubleResiduePairing_injective [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ) :
+    Function.Injective (doubleResiduePairing K F W D hφ hμ) := by
+  rw [injective_iff_map_eq_zero]
+  rintro ⟨g, h⟩ heq
+  have heq' : weilSmul K F (g : F) φ + weilSmul K F (h : F) μ = 0 := by
+    have hcoe := congrArg Subtype.val heq
+    rwa [doubleResiduePairing_apply_coe, Submodule.coe_zero] at hcoe
+  rcases eq_or_ne (h : F) 0 with hh0 | hh0
+  · rw [hh0, weilSmul_zero_left, add_zero] at heq'
+    have hg0 : (g : F) = 0 := (weilSmul_eq_zero_iff_left hφ0).mp heq'
+    exact Prod.ext (Subtype.ext hg0) (Subtype.ext hh0)
+  · exfalso
+    have hμeq : weilSmul K F (h : F) μ = -weilSmul K F (g : F) φ := by
+      have h2 : weilSmul K F (h : F) μ + weilSmul K F (g : F) φ = 0 := by
+        rw [add_comm]; exact heq'
+      exact eq_neg_of_add_eq_zero_left h2
+    have hLHS : weilSmul K F (h : F)⁻¹ (weilSmul K F (h : F) μ) = μ := by
+      rw [← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hh0, weilSmul_one,
+        LinearMap.id_apply]
+    have hRHS : weilSmul K F (h : F)⁻¹ (-weilSmul K F (g : F) φ)
+        = weilSmul K F (-(g : F) * (h : F)⁻¹) φ := by
+      rw [map_neg, ← LinearMap.comp_apply, ← weilSmul_mul, neg_mul, weilSmul_neg_left]
+    exact hindep (-(g : F) * (h : F)⁻¹) (by rw [← hLHS, hμeq, hRHS])
+
+theorem two_mul_ell_le_indexOfSpecialty [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ)
+    [Module.Finite K (omegaSpace (K := K) (F := F) D)]
+    [Module.Finite K (LSpace (K := K) (F := F) (W - D))] :
+    2 * ell (W - D) ≤ indexOfSpecialty D := by
+  have hinj := doubleResiduePairing_injective W D hφ hμ hφ0 hindep
+  have hle := LinearMap.finrank_le_finrank_of_injective hinj
+  rw [Module.finrank_prod] at hle
+  rw [← finrank_omegaSpace_eq_indexOfSpecialty, two_mul]
+  exact hle
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+section Finiteness
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+theorem omegaSpace_finite_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Module.Finite K (omegaSpace (K := K) (F := F) D) := by
+  have := (indexOfSpecialty_eq_of_genusReached h D).1
+  exact Module.Finite.equiv (omegaSpaceEquivIndexDual D).symm
+
+end Finiteness
+
+section ParametricRankOne
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+
+theorem exists_weilSmul_eq_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {φ μ : Module.Dual K (adeleSpace K F)} {W : Divisor K F}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (hφ0 : φ ≠ 0) :
+    ∃ f : F, μ = weilSmul K F f φ := by
+  by_contra hcon
+  push Not at hcon
+  obtain ⟨P⟩ := ‹Nonempty (Place K F)›
+  set n : ℕ := 3 * γ.natAbs + 2 * (Divisor.degree W).natAbs + 4 with hn
+  set D : Divisor K F := -Finsupp.single P (n : ℤ) with hD
+  have hdegD : Divisor.degree D = -(n : ℤ) * (P.deg : ℤ) := by
+    rw [hD, map_neg, Divisor.degree_single]; ring
+  have hdegWD : Divisor.degree (W - D) = Divisor.degree W + (n : ℤ) * (P.deg : ℤ) := by
+    rw [map_sub, hdegD]; ring
+  have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+  have habsγ : -(|γ|) ≤ γ ∧ γ ≤ |γ| := ⟨neg_abs_le _, le_abs_self _⟩
+  have habsW : -|Divisor.degree W| ≤ Divisor.degree W ∧
+      Divisor.degree W ≤ |Divisor.degree W| := ⟨neg_abs_le _, le_abs_self _⟩
+  have hn_ge : 3 * |γ| + 2 * |Divisor.degree W| + 4 ≤ (n : ℤ) := by
+    rw [hn]; push_cast [Int.natCast_natAbs]; ring_nf; omega
+  have hndegP : (n : ℤ) ≤ (n : ℤ) * (P.deg : ℤ) := by nlinarith [Int.natCast_nonneg n]
+  have hellD : ell D = 0 := ell_eq_zero_of_degree_neg (by rw [hdegD]; nlinarith)
+  have hiD : (indexOfSpecialty D : ℤ) = (n : ℤ) * (P.deg : ℤ) - 1 + γ := by
+    have hidx := (indexOfSpecialty_eq_of_genusReached h D).2
+    rw [hellD, hdegD] at hidx; push_cast at hidx; linarith
+  have hlowerWD : Divisor.degree W + (n : ℤ) * (P.deg : ℤ) + 1 - γ
+      ≤ (ell (W - D) : ℤ) := by
+    have hlow := gate_riemannInequality_of_genusReached h (W - D)
+    rw [hdegWD] at hlow; exact hlow
+  have := omegaSpace_finite_of_genusReached h D
+  have := finiteDimensional_lSpace (K := K) (W - D)
+  have hdbl : (2 * ell (W - D) : ℤ) ≤ (indexOfSpecialty D : ℤ) := by
+    exact_mod_cast two_mul_ell_le_indexOfSpecialty W D hφ hμ hφ0 hcon
+  rw [hiD] at hdbl
+  nlinarith [habsγ.1, habsγ.2, habsW.1, habsW.2]
+
+theorem weilDifferentialRankOne_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    WeilDifferentialRankOne K F := by
+  intro φ hφmem hφ0 μ hμmem
+  obtain ⟨W₁, hφW₁⟩ := mem_weilDifferentialModule_iff.mp hφmem
+  obtain ⟨W₂, hμW₂⟩ := mem_weilDifferentialModule_iff.mp hμmem
+  have hφW : φ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_left hφW₁
+  have hμW : μ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_right hμW₂
+  obtain ⟨f, hf⟩ := exists_weilSmul_eq_of_genusReached h hφW hμW hφ0
+  exact ⟨f, hf, fun f' hf' => weilSmul_left_injective hφ0 (hf'.symm.trans hf)⟩
+
+end ParametricRankOne
+
+theorem residuePairing_surjective_of_rankOne_max [HasPrincipalDivisors K F]
+    (hRankOne : WeilDifferentialRankOne K F)
+    {W : Divisor K F} {φ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hφ0 : φ ≠ 0)
+    (hWmax : ∀ E : Divisor K F, φ ∈ omegaSpace E → E ≤ W) (D : Divisor K F) :
+    Function.Surjective (residuePairing K F W D hφ) := by
+  rintro ⟨μ, hμD⟩
+  have hφmem : φ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule W hφ
+  have hμmem : μ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule D hμD
+  obtain ⟨f, hf, -⟩ := hRankOne hφmem hφ0 hμmem
+  rcases eq_or_ne f 0 with rfl | hf0
+  · have hμ0 : (⟨μ, hμD⟩ : omegaSpace D) = 0 :=
+      Subtype.ext (hf.trans (weilSmul_zero_left φ))
+    exact ⟨0, (map_zero _).trans hμ0.symm⟩
+  · obtain ⟨P, hPord, _⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+    have hPinv : ∀ v, (-P) v = v.ord f⁻¹ := fun v => by
+      rw [Finsupp.neg_apply, hPord v, v.ord_inv]
+    have hinv : weilSmul K F f⁻¹ μ = φ := by
+      rw [hf, ← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hf0, weilSmul_one,
+        LinearMap.id_apply]
+    have hφD : φ ∈ omegaSpace (D + -P) := by
+      rw [← hinv]; exact weilSmul_mem_omegaSpace_add (inv_ne_zero hf0) hPinv hμD
+    have hDP : D + -P ≤ W := hWmax _ hφD
+    have hfL : f ∈ LSpace (W - D) := by
+      rw [mem_lSpace_iff_ord]; refine Or.inr fun v => ?_
+      have hv := hDP v
+      rw [Finsupp.add_apply, Finsupp.neg_apply, hPord v] at hv
+      rw [Finsupp.sub_apply]; linarith
+    exact ⟨⟨f, hfL⟩, Subtype.ext hf.symm⟩
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem exists_riemannGenusReachedAt_of_bounded
+    [IsCurveOver K F] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    ∃ (γ : ℤ) (D₀ : Divisor K F), RiemannGenusReachedAt γ D₀ := by
+  obtain ⟨γ, hγ⟩ := hbdd
+  obtain ⟨M, ⟨D₀, hD₀⟩, hMmax⟩ :=
+    Int.exists_greatest_of_bdd
+      (P := fun n => ∃ D : Divisor K F, Divisor.degree D - ell D = n)
+      ⟨γ, fun n ⟨D, hD⟩ => hD ▸ hγ D⟩
+      ⟨Divisor.degree (0 : Divisor K F) - ell (0 : Divisor K F), 0, rfl⟩
+  refine ⟨M + 1, D₀, ?_, ?_, ?_⟩
+  · exact finiteDimensional_lSpace D₀
+  · rw [hD₀]; ring
+  · intro D
+    have := hMmax (Divisor.degree D - ell D) ⟨D, rfl⟩
+    linarith
+
+theorem stichtenothGenusExists_of_bounded
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    StichtenothGenusExists K F :=
+  ⟨‹_›, ‹_›, exists_riemannGenusReachedAt_of_bounded hbdd⟩
+
+
+theorem indexOfSpecialty_sub_of_ge [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₀ D : Divisor K F} (hD : D₀ ≤ D)
+    [FiniteDimensional K (LSpace D)]
+    [hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀)] :
+    Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D) ∧
+      (Divisor.degree D - ell D) - (Divisor.degree D₀ - ell D₀)
+        = (indexOfSpecialty D₀ : ℤ) - (indexOfSpecialty D : ℤ) := by
+  have hABsub : adeleBdd D₀ ⊔ globalSub K F ≤ adeleBdd D ⊔ globalSub K F :=
+    sup_le_sup_right (adeleBdd_mono hD) _
+  have hBCsub : adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+    adeleBdd_sup_globalSub_le_adeleSpace _
+  obtain ⟨hfinBA, hdimBA⟩ := finrank_adeleBddSup_quotient (K := K) hD
+  have := hfinBA
+  have hfinCA : Module.Finite K (adeleSpace K F ⧸
+      (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [← adeleBddPrincipal_eq_comap]; exact hfin
+  obtain ⟨hfinCB, hdimCB⟩ := Submodule.finrank_quotient_chain'
+    (A := adeleBdd D₀ ⊔ globalSub K F) (B := adeleBdd D ⊔ globalSub K F)
+    (C := adeleSpace K F) hABsub hBCsub
+  have hi0 : indexOfSpecialty D₀
+      = finrank K (adeleSpace K F ⧸
+        (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap]
+  have hiD : indexOfSpecialty D
+      = finrank K (adeleSpace K F ⧸
+        (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap]
+  have := hfinCB
+  obtain ⟨_, hdimCA⟩ := Submodule.finrank_quotient_chain
+    (A := adeleBdd D₀ ⊔ globalSub K F) (B := adeleBdd D ⊔ globalSub K F)
+    (C := adeleSpace K F) hABsub hBCsub
+  refine ⟨?_, ?_⟩
+  · rw [show adeleBddPrincipal K F D
+        = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype
+      from adeleBddPrincipal_eq_comap D]
+    exact hfinCB
+  · have hcast : (indexOfSpecialty D₀ : ℤ)
+        = (indexOfSpecialty D : ℤ)
+          + (finrank K (↥(adeleBdd D ⊔ globalSub K F)
+              ⧸ (adeleBdd D₀ ⊔ globalSub K F).comap
+                (adeleBdd D ⊔ globalSub K F).subtype) : ℤ) := by
+      rw [hiD, hi0]; exact_mod_cast hdimCA
+    linarith [hdimBA, hcast]
+
+theorem degreeSub_ell_le_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {D₀ : Divisor K F}
+    (hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀))
+    (D : Divisor K F) :
+    Divisor.degree D - ell D ≤ (Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀ := by
+  have := hfin
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have hmono : Divisor.degree D - (ell D : ℤ)
+      ≤ Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) (le_sup_left : D ≤ D ⊔ D₀)
+    linarith
+  obtain ⟨_, heq⟩ :=
+    indexOfSpecialty_sub_of_ge (K := K) (le_sup_right : D₀ ≤ D ⊔ D₀)
+  have hi0 : (0 : ℤ) ≤ indexOfSpecialty (D ⊔ D₀) := Int.natCast_nonneg _
+  linarith
+
+theorem riemannGenusBounded_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hfin : IndexOfSpecialtyFinite K F) :
+    RiemannGenusBounded K F := by
+  obtain ⟨D₀, hD₀⟩ := hfin
+  exact ⟨(Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀,
+    degreeSub_ell_le_of_indexFinite hD₀⟩
+
+theorem stichtenothGenusExists_of_indexFinite
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hfin : IndexOfSpecialtyFinite K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_bounded (riemannGenusBounded_of_indexFinite hfin)
+
+theorem indexOfSpecialtyFinite_of_stichtenothGenusExists
+    [IsCurveOver K F] (hSG : StichtenothGenusExists K F) :
+    IndexOfSpecialtyFinite K F := by
+  obtain ⟨hne, hL0, γ, D₀, hD₀⟩ := hSG
+  have := hne; have := hL0
+  refine ⟨D₀, ?_⟩
+  rw [show adeleBddPrincipal K F D₀
+      = (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype
+    from adeleBddPrincipal_eq_comap D₀, ← adeleSpace_eq_of_genusReached hD₀,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.Finite.of_finite
+
+theorem stichtenothGenusExists_iff_indexFinite
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] :
+    StichtenothGenusExists K F ↔ IndexOfSpecialtyFinite K F :=
+  ⟨indexOfSpecialtyFinite_of_stichtenothGenusExists,
+    stichtenothGenusExists_of_indexFinite⟩
+
+theorem gate_indexOfSpecialty_engine_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  exact_mod_cast indexOfSpecialty_eq_zero_of_genusReached h
+
+theorem gate_stichtenothGenus_le_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {D₀ : Divisor K F}
+    (hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀))
+    {γ : ℤ} {D₁ : Divisor K F} (h : RiemannGenusReachedAt γ D₁) :
+    γ - 1 ≤ (Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀ := by
+  have := degreeSub_ell_le_of_indexFinite hfin D₁
+  rw [h.eq] at this; exact this
+
+theorem gate_riemannGenusBounded_of_reachedAt
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    RiemannGenusBounded K F :=
+  ⟨γ - 1, h.isMax⟩
+
+theorem gate_indexOfSpecialtyFinite_at_zero [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F (0 : Divisor K F)) :=
+  (indexOfSpecialty_eq_of_genusReached h 0).1
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem mul_mem_lSpace_add {D E : Divisor K F} {f g : F}
+    (hf : f ∈ LSpace D) (hg : g ∈ LSpace E) :
+    f * g ∈ LSpace (D + E) := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · rw [zero_mul]; exact (LSpace _).zero_mem
+  rcases eq_or_ne g 0 with rfl | hg0
+  · rw [mul_zero]; exact (LSpace _).zero_mem
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun v => ?_
+  rw [Finsupp.add_apply, neg_add, v.ord_mul hf0 hg0]
+  exact add_le_add ((mem_lSpace_iff_ord.mp hf).resolve_left hf0 v)
+    ((mem_lSpace_iff_ord.mp hg).resolve_left hg0 v)
+
+theorem pow_mem_lSpace_nsmul {B : Divisor K F} {f : F} (hf : f ∈ LSpace B) (j : ℕ) :
+    f ^ j ∈ LSpace (j • B) := by
+  induction j with
+  | zero => simpa using one_mem_lSpace_zero (K := K) (F := F)
+  | succ j ih =>
+    rw [pow_succ, succ_nsmul]
+    exact mul_mem_lSpace_add ih hf
+
+namespace PoleDivisorPackage
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degB_eq u B hB_eff n lin_indep mk c x hn_pos \
+  hu_mem mk.injEq hx_mem"
+p2m_open "AlgebraicCurve.PoleDivisorPackage"
+
+variable (P : PoleDivisorPackage K F)
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.pow_mul_u_mem_lSpace (j : ℕ) (i : Fin P.n)
+    :
+    P.x ^ j * P.u i ∈ LSpace ((j + P.c) • P.B) := by
+  rw [add_nsmul]
+  exact mul_mem_lSpace_add (pow_mem_lSpace_nsmul P.hx_mem j) (P.hu_mem i)
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "pow_mul_u_mem_lSpace"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.pow_mul_u_mem_lSpace_of_le {j m : ℕ}
+    (hjm : j + P.c ≤ m) (i : Fin P.n) :
+    P.x ^ j * P.u i ∈ LSpace (m • P.B) := by
+  refine lSpace_mono ?_ (P.pow_mul_u_mem_lSpace j i)
+  intro v
+  have hBv : (0 : ℤ) ≤ P.B v := P.hB_eff v
+  change ((j + P.c) • P.B) v ≤ (m • P.B) v
+  simp only [Finsupp.smul_apply, nsmul_eq_mul]
+  exact mul_le_mul_of_nonneg_right (by exact_mod_cast hjm) hBv
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "pow_mul_u_mem_lSpace_of_le"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.ell_nsmul_poleDivisor_ge [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    (P.n : ℤ) * (m - P.c + 1) ≤ ell (m • P.B) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  set g : Fin (m - P.c + 1) × Fin P.n → LSpace (m • P.B) :=
+    fun p => ⟨P.x ^ (p.1 : ℕ) * P.u p.2,
+      P.pow_mul_u_mem_lSpace_of_le (by have := p.1.isLt; omega) p.2⟩
+    with hgdef
+  have hsub : LinearIndependent K (fun p => (g p : F)) := by
+    have heq : (fun p => (g p : F))
+        = (fun p : ℕ × Fin P.n => P.x ^ p.1 * P.u p.2)
+            ∘ (fun p : Fin (m - P.c + 1) × Fin P.n => ((p.1 : ℕ), p.2)) := by
+      funext p; rfl
+    rw [heq]
+    refine P.lin_indep.comp _ ?_
+    intro p q hpq
+    simp only [Prod.mk.injEq] at hpq
+    exact Prod.ext (Fin.val_injective hpq.1) hpq.2
+  have hg : LinearIndependent K g := hsub.of_comp (LSpace (m • P.B)).subtype
+  have hcard := hg.fintype_card_le_finrank
+  rw [Fintype.card_prod, Fintype.card_fin, Fintype.card_fin] at hcard
+  have hZ : ((m - P.c + 1) * P.n : ℤ) ≤ (ell (m • P.B) : ℤ) := by exact_mod_cast hcard
+  have heq : (((m - P.c + 1 : ℕ) : ℤ) * P.n : ℤ) = (P.n : ℤ) * ((m : ℤ) - P.c + 1) := by
+    rw [Nat.cast_add, Nat.cast_sub hm, Nat.cast_one]; ring
+  linarith
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "ell_nsmul_poleDivisor_ge"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.degree_nsmul_sub_ell_le [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    Divisor.degree (m • P.B) - ell (m • P.B) ≤ (P.n : ℤ) * (P.c - 1) := by
+  have hge := P.ell_nsmul_poleDivisor_ge hm
+  have hdeg : Divisor.degree (m • P.B) = (m : ℤ) * P.n := by
+    rw [show m • P.B = (m : ℤ) • P.B from (natCast_zsmul _ _).symm,
+      Divisor.degree.map_zsmul, smul_eq_mul, P.degB_eq]
+  linarith
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degree_nsmul_sub_ell_le"
+end PoleDivisorPackage
+
+namespace PoleDivisorPackage
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degB_eq u B hB_eff n lin_indep mk c x hn_pos \
+  hu_mem mk.injEq hx_mem"
+end PoleDivisorPackage
+namespace PoleDivisorPackage
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.ell_nsmul_sub_pos [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) {A : Divisor K F} (hA : 0 ≤ A) {m : ℕ} (hm : P.c ≤ m)
+    (hbig : Divisor.degree A < (P.n : ℤ) * (m - P.c + 1)) :
+    0 < ell (m • P.B - A) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  have hle : m • P.B - A ≤ m • P.B := by
+    intro v
+    have hAv : (0 : ℤ) ≤ A v := hA v
+    rw [Finsupp.sub_apply]
+    linarith
+  have h48 := ell_sub_ell_le_degree_sub_degree (K := K) hle
+  rw [map_sub, sub_sub_cancel] at h48
+  have h412 := P.ell_nsmul_poleDivisor_ge hm
+  have : (0 : ℤ) < (ell (m • P.B - A) : ℤ) := by linarith
+  exact_mod_cast this
+
+end PoleDivisorPackage
+p2m_export "AlgebraicCurve" "PoleDivisorPackage.ell_nsmul_sub_pos"
+namespace PoleDivisorPackage
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.degree_sub_ell_le [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) (D : Divisor K F) :
+    Divisor.degree D - ell D ≤ (P.n : ℤ) * (P.c - 1) := by
+  classical
+  set D' : Divisor K F := D ⊔ 0 with hD'def
+  have hD'eff : 0 ≤ D' := le_sup_right
+  have hDD' : D ≤ D' := le_sup_left
+  have := finiteDimensional_lSpace (K := K) D'
+  have hmono : Divisor.degree D - (ell D : ℤ) ≤ Divisor.degree D' - ell D' := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hDD'
+    linarith
+  set m : ℕ := P.c + (Divisor.degree D').toNat with hmdef
+  have hcm : P.c ≤ m := Nat.le_add_right _ _
+  have hdegD' : 0 ≤ Divisor.degree D' := Divisor.degree_nonneg_of_nonneg hD'eff
+  have hbig : Divisor.degree D' < (P.n : ℤ) * (m - P.c + 1) := by
+    have hcast : ((m : ℤ) - P.c) = Divisor.degree D' := by
+      simp only [hmdef, Nat.cast_add, add_sub_cancel_left, Int.toNat_of_nonneg hdegD']
+    rw [hcast]
+    have hn1 : (1 : ℤ) ≤ P.n := by exact_mod_cast P.hn_pos
+    nlinarith
+  have hellpos := P.ell_nsmul_sub_pos hD'eff hcm hbig
+  have hnebot : LSpace (m • P.B - D') ≠ ⊥ :=
+    fun h => by rw [ell, h, finrank_bot] at hellpos; exact lt_irrefl 0 hellpos
+  obtain ⟨z, hzL, hz0⟩ := (Submodule.ne_bot_iff _).mp hnebot
+  obtain ⟨Dz, hDzord, hDzdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) z hz0
+  have hzmem := (mem_lSpace_iff_ord.mp hzL).resolve_left hz0
+  have hD'le : D' ≤ m • P.B + Dz := by
+    intro v
+    have := hzmem v
+    simp only [Finsupp.add_apply, Finsupp.sub_apply, neg_sub] at this ⊢
+    rw [hDzord]; linarith
+  have hellshift : ell (m • P.B + Dz) = ell (m • P.B) :=
+    (LinearEquiv.finrank_eq (lSpaceShiftEquiv (m • P.B) hz0 hDzord)).symm
+  have hdegshift : Divisor.degree (m • P.B + Dz) = Divisor.degree (m • P.B) := by
+    rw [map_add, hDzdeg, add_zero]
+  have := finiteDimensional_lSpace (K := K) (m • P.B + Dz)
+  have hmono' : Divisor.degree D' - (ell D' : ℤ)
+      ≤ Divisor.degree (m • P.B + Dz) - ell (m • P.B + Dz) := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hD'le
+    linarith
+  rw [hellshift, hdegshift] at hmono'
+  have h412 := P.degree_nsmul_sub_ell_le hcm
+  linarith
+
+end PoleDivisorPackage
+p2m_export "AlgebraicCurve" "PoleDivisorPackage.degree_sub_ell_le"
+
+theorem riemannGenusBounded_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    RiemannGenusBounded K F :=
+  ⟨(P.n : ℤ) * (P.c - 1), P.degree_sub_ell_le⟩
+
+theorem stichtenothGenusExists_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_bounded (riemannGenusBounded_of_poleDivisorPackage P)
+
+theorem indexOfSpecialtyFinite_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_stichtenothGenusExists
+    (stichtenothGenusExists_of_poleDivisorPackage P)
+
+theorem indexOfSpecialtyFinite_of_hasPoleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (h : HasPoleDivisorPackage K F) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_poleDivisorPackage h.some
+
+theorem stichtenothGenusExists_of_hasPoleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (h : HasPoleDivisorPackage K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_poleDivisorPackage h.some
+
+theorem gate_stichtenothGenus_le_of_poleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F)
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    γ ≤ (P.n : ℤ) * (P.c - 1) + 1 := by
+  have := P.degree_sub_ell_le D₀
+  rw [h.eq] at this; linarith
+
+theorem gate_ell_c_nsmul_ge [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    (P.n : ℤ) ≤ ell (P.c • P.B) := by
+  have h := P.ell_nsmul_poleDivisor_ge (le_refl P.c)
+  simp only [sub_self, zero_add, mul_one] at h
+  exact h
+
+theorem gate_x_transcendental_of_poleDivisorPackage (P : PoleDivisorPackage K F) :
+    LinearIndependent K (fun j : ℕ => P.x ^ j * P.u ⟨0, P.hn_pos⟩) := by
+  refine P.lin_indep.comp (fun j => (j, ⟨0, P.hn_pos⟩)) ?_
+  intro a b hab
+  exact (Prod.mk.injEq .. ▸ hab).1
+
+theorem gate_u_linearIndependent_of_poleDivisorPackage (P : PoleDivisorPackage K F) :
+    LinearIndependent K P.u := by
+  have h : LinearIndependent K (fun i : Fin P.n => P.x ^ (0 : ℕ) * P.u i) := by
+    refine P.lin_indep.comp (fun i => (0, i)) ?_
+    intro a b hab
+    exact (Prod.mk.injEq .. ▸ hab).2
+  simpa using h
+
+end AlgebraicCurve
+
+end
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+scoped instance instSumRamificationInertia_port {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F']
+    [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+    [HasPrincipalDivisors K F'] : SumRamificationInertia K F F' :=
+  ⟨fun v => Place.sum_ramificationIndex_mul_inertiaDeg v⟩
+end AlgebraicCurve
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+
+namespace TranscendenceTower
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF poleDivisor RegularOutside hx_indep hxreg v \
+  mk.injEq mk hvdeg x hxv"
+p2m_open "AlgebraicCurve.TranscendenceTower"
+
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F]
+variable (T : TranscendenceTower K E F)
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.x_ne_zero : T.x ≠ 0 := fun h => by
+  have := T.hxv; rw [h, Place.ord_zero] at this; exact absurd this (by decide)
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "x_ne_zero"
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+theorem xF_ne_zero : T.xF ≠ 0 :=
+  fun h => T.x_ne_zero ((algebraMap E F).injective (by rwa [map_zero]))
+
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.poleDivisor_apply_port (w : Place K F) :
+    T.poleDivisor w = (w.ramificationIndex E : ℤ) * (Finsupp.single T.v 1) (w.restrict E) :=
+  Divisor.pullback_apply (Finsupp.single T.v 1) w
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "poleDivisor_apply_port"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.poleDivisor_nonneg :
+    0 ≤ T.poleDivisor := by
+  classical
+  intro w
+  rw [Finsupp.coe_zero, Pi.zero_apply, T.poleDivisor_apply_port, Finsupp.single_apply]
+  refine mul_nonneg (Int.natCast_nonneg _) ?_
+  split_ifs <;> simp
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "poleDivisor_nonneg"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.xF_mem_lSpace_poleDivisor :
+    T.xF ∈ LSpace T.poleDivisor := by
+  classical
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun w => ?_
+  rw [T.poleDivisor_apply_port, Place.ord_restrict, Finsupp.single_apply]
+  rcases eq_or_ne (w.restrict E) T.v with hw | hw
+  · simp only [hw, T.hxv, ite_true, mul_one, mul_neg_one, le_refl]
+  · simp only [ite_eq_right (Ne.symm hw), mul_zero, neg_zero]
+    exact mul_nonneg (Int.natCast_nonneg _) (T.hxreg _ hw)
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF_mem_lSpace_poleDivisor"
+
+private theorem _root_.AlgebraicCurve.TranscendenceTower.degree_poleDivisor_eq_finrank :
+    Divisor.degree T.poleDivisor = (Module.finrank E F : ℤ) := by
+  rw [poleDivisor, Divisor.degree_pullback, Divisor.degree_single, T.hvdeg]
+  push_cast; ring
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "degree_poleDivisor_eq_finrank"
+omit [FiniteDimensional E F] in
+private theorem
+  _root_.AlgebraicCurve.TranscendenceTower.mem_lSpace_nsmul_poleDivisor_of_regular_outside {f : F}
+    (hreg : ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord f)
+    {c : ℕ} (hc : ∀ w ∈ T.v.fiber F, -(c : ℤ) ≤ w.ord f) :
+    f ∈ LSpace (c • T.poleDivisor) := by
+  classical
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact (LSpace _).zero_mem
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun w => ?_
+  rw [Finsupp.smul_apply, T.poleDivisor_apply_port, Finsupp.single_apply, nsmul_eq_mul]
+  rcases eq_or_ne (w.restrict E) T.v with hw | hw
+  · simp only [hw, ite_true, mul_one]
+    have he : (1 : ℤ) ≤ w.ramificationIndex E := by
+      exact_mod_cast w.ramificationIndex_pos (F := E)
+    have hbdd := hc w (Place.mem_fiber.mpr hw)
+    nlinarith [Int.natCast_nonneg c]
+  · simp only [ite_eq_right (Ne.symm hw), mul_zero, neg_zero]
+    exact hreg w hw
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "mem_lSpace_nsmul_poleDivisor_of_regular_outside"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.exists_forall_mem_lSpace_nsmul_poleDivisor
+    {n : ℕ} (u : Fin n → F)
+    (hreg : ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)) :
+    ∃ c : ℕ, ∀ i, u i ∈ LSpace (c • T.poleDivisor) := by
+  classical
+  refine ⟨(Finset.univ : Finset (Fin n)).sup fun i =>
+    (T.v.fiber F).sup fun w => (-(w.ord (u i))).toNat,
+    fun i => T.mem_lSpace_nsmul_poleDivisor_of_regular_outside (hreg i) ?_⟩
+  intro w hw
+  have h1 : (-(w.ord (u i))).toNat
+      ≤ (T.v.fiber F).sup fun w' => (-(w'.ord (u i))).toNat :=
+    Finset.le_sup (f := fun w' => (-(w'.ord (u i))).toNat) hw
+  have h2 : ((T.v.fiber F).sup fun w' => (-(w'.ord (u i))).toNat)
+      ≤ (Finset.univ : Finset (Fin n)).sup fun i' =>
+          (T.v.fiber F).sup fun w' => (-(w'.ord (u i'))).toNat :=
+    Finset.le_sup (f := fun i' => (T.v.fiber F).sup fun w' => (-(w'.ord (u i'))).toNat)
+      (Finset.mem_univ i)
+  have htnat : -(w.ord (u i)) ≤ ((-(w.ord (u i))).toNat : ℤ) := Int.self_le_toNat _
+  omega
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "exists_forall_mem_lSpace_nsmul_poleDivisor"
+end TranscendenceTower
+
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F]
+
+section PrincipalDivisors
+
+variable [HasPrincipalDivisors K F]
+
+namespace IntegralBasisInLSpace
+p2m_export "AlgebraicCurve.IntegralBasisInLSpace" "hu_indep c u mk.injEq hu_mem mk"
+end IntegralBasisInLSpace
+p2m_open_scoped "AlgebraicCurve.IntegralBasisInLSpace" in
+def IntegralBasisInLSpace.ofRegularOutside (T : TranscendenceTower K E F)
+    (u : Fin (Module.finrank E F) → F) (hu_indep : LinearIndependent E u)
+    (hreg : ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)) :
+    IntegralBasisInLSpace T where
+  c := (T.exists_forall_mem_lSpace_nsmul_poleDivisor u hreg).choose
+  u := u
+  hu_indep := hu_indep
+  hu_mem := (T.exists_forall_mem_lSpace_nsmul_poleDivisor u hreg).choose_spec
+
+omit [FiniteDimensional E F] in
+theorem hasIntegralBasisInLSpace_of_regularOutside (T : TranscendenceTower K E F)
+    (h : HasIntegralBasisRegularOutside K E F T) :
+    HasIntegralBasisInLSpace K E F T := by
+  obtain ⟨u, hu_indep, hreg⟩ := h
+  exact ⟨IntegralBasisInLSpace.ofRegularOutside T u hu_indep hreg⟩
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+theorem linearIndependent_pow_mul {x : E} {n : ℕ} {u : Fin n → F}
+    (hx : LinearIndependent K (fun j : ℕ => x ^ j)) (hu : LinearIndependent E u) :
+    LinearIndependent K (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2) := by
+  have heq : (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2)
+      = (fun p : ℕ × Fin n => (x ^ p.1) • u p.2) := by
+    funext p
+    rw [Algebra.smul_def, map_pow]
+  rw [heq]
+  exact linearIndependent_smul (R := K) (S := E) (A := F) hx hu
+
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+def PoleDivisorPackage.ofTranscendenceTower (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    PoleDivisorPackage K F where
+  x := T.xF
+  B := T.poleDivisor
+  hB_eff := T.poleDivisor_nonneg
+  hx_mem := T.xF_mem_lSpace_poleDivisor
+  n := Module.finrank E F
+  hn_pos := Module.finrank_pos
+  degB_eq := T.degree_poleDivisor_eq_finrank
+  c := IB.c
+  u := IB.u
+  hu_mem := IB.hu_mem
+  lin_indep := linearIndependent_pow_mul T.hx_indep IB.hu_indep
+
+theorem hasPoleDivisorPackage_of_transcendenceTower
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    HasPoleDivisorPackage K F :=
+  ⟨PoleDivisorPackage.ofTranscendenceTower T IB⟩
+
+theorem hasPoleDivisorPackage_of_hasIntegralBasisInLSpace
+    (T : TranscendenceTower K E F) (h : HasIntegralBasisInLSpace K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_transcendenceTower T h.some
+
+theorem hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside
+    (T : TranscendenceTower K E F) (h : HasIntegralBasisRegularOutside K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisInLSpace T
+    (hasIntegralBasisInLSpace_of_regularOutside T h)
+
+end PrincipalDivisors
+
+theorem indexOfSpecialtyFinite_of_transcendenceTower [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem stichtenothGenusExists_of_transcendenceTower [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem gate_ofTranscendenceTower_n_eq [HasPrincipalDivisors K F] (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    (PoleDivisorPackage.ofTranscendenceTower T IB).n = Module.finrank E F := rfl
+
+theorem gate_ofTranscendenceTower_B_eq [HasPrincipalDivisors K F] (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    (PoleDivisorPackage.ofTranscendenceTower T IB).B = T.poleDivisor := rfl
+
+theorem gate_ofTranscendenceTower_x_transcendental [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    LinearIndependent K
+      (fun j : ℕ => T.xF ^ j *
+        (PoleDivisorPackage.ofTranscendenceTower T IB).u ⟨0, Module.finrank_pos⟩) :=
+  gate_x_transcendental_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem gate_degree_pullback_single_of_deg_eq [HasPrincipalDivisors K F]
+    (v : Place K E) (d : ℕ) (hd : v.deg = d) :
+    Divisor.degree (Divisor.pullback F (Finsupp.single v (1 : ℤ)))
+      = (Module.finrank E F : ℤ) * d := by
+  rw [Divisor.degree_pullback, Divisor.degree_single, hd]; ring
+
+theorem gate_stichtenothGenus_le_of_transcendenceTower [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T)
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    γ ≤ (Module.finrank E F : ℤ) * (IB.c - 1) + 1 :=
+  gate_stichtenothGenus_le_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB) h
+
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open Module
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow mk.injEq algebraMap_mem' toValuationSubring mk \
+  ramificationIndex ramificationIndex_pos restrict mem_restrict_iff ord_restrict \
+  deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~comap_algebra\
+  Map_ne_top"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral {f : F}
+    (hf : IsIntegral w.toValuationSubring f) :
+    f ∈ w.toValuationSubring := by
+  obtain ⟨y, hy⟩ := IsIntegrallyClosed.isIntegral_iff.mp hf
+  exact hy ▸ y.2
+
+p2m_export "AlgebraicCurve.Place" "mem_of_isIntegral"
+
+theorem ord_nonneg_of_isIntegral {f : F} (hf : IsIntegral w.toValuationSubring f) :
+    0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral hf)
+
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral_of_algebraMap_mem {A : Type*}
+    [CommRing A] [Algebra A F]
+    (hA : ∀ a : A, algebraMap A F a ∈ w.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : f ∈ w.toValuationSubring := by
+  let : Algebra A w.toValuationSubring :=
+    ((algebraMap A F).codRestrict w.toValuationSubring.toSubring hA).toAlgebra
+  have : IsScalarTower A w.toValuationSubring F :=
+    IsScalarTower.of_algebraMap_eq fun a => rfl
+  exact w.mem_of_isIntegral hf.tower_top
+
+p2m_export "AlgebraicCurve.Place" "mem_of_isIntegral_of_algebraMap_mem"
+
+theorem ord_nonneg_of_isIntegral_of_algebraMap_mem {A : Type*} [CommRing A] [Algebra A F]
+    (hA : ∀ a : A, algebraMap A F a ∈ w.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : 0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral_of_algebraMap_mem hA hf)
+
+end Place
+
+section Bridge
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+variable {A : Type*} [CommRing A] [Algebra A E] [Algebra A F] [IsScalarTower A E F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow mk.injEq algebraMap_mem' toValuationSubring mk \
+  ramificationIndex ramificationIndex_pos restrict mem_restrict_iff ord_restrict \
+  deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg"
+end Place
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral_of_restrict [Algebra.IsIntegral E F]
+    (w : Place K F)
+    {u : Place K E} (hw : w.restrict E = u)
+    (hA : ∀ a : A, algebraMap A E a ∈ u.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : f ∈ w.toValuationSubring := by
+  refine w.mem_of_isIntegral_of_algebraMap_mem (fun a => ?_) hf
+  rw [IsScalarTower.algebraMap_apply A E F, ← w.mem_restrict_iff, hw]
+  exact hA a
+
+end Place
+p2m_export "AlgebraicCurve" "Place.mem_of_isIntegral_of_restrict"
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.ord_nonneg_of_isIntegral_of_restrict
+    [Algebra.IsIntegral E F] (w : Place K F)
+    {u : Place K E} (hw : w.restrict E = u)
+    (hA : ∀ a : A, algebraMap A E a ∈ u.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : 0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral_of_restrict hw hA hf)
+
+end Place
+p2m_export "AlgebraicCurve" "Place.ord_nonneg_of_isIntegral_of_restrict"
+namespace TranscendenceTower
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF poleDivisor RegularOutside hx_indep hxreg v \
+  mk.injEq mk hvdeg x hxv"
+end TranscendenceTower
+namespace TranscendenceTower
+p2m_open_scoped "AlgebraicCurve.TranscendenceTower" in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.ord_nonneg_of_isIntegral_of_regularOutside
+    [Algebra.IsIntegral E F] (T : TranscendenceTower K E F) (hA : T.RegularOutside A)
+    {f : F} (hf : IsIntegral A f) :
+    ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord f := fun w hw =>
+  w.ord_nonneg_of_isIntegral_of_restrict rfl (hA _ hw) hf
+
+end TranscendenceTower
+p2m_export "AlgebraicCurve" "TranscendenceTower.ord_nonneg_of_isIntegral_of_regularOutside"
+end Bridge
+
+section Headline
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F]
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+theorem linearIndependent_reindex_basis {s : Finset F} (b : Basis s E F) :
+    LinearIndependent E (fun i : Fin (Module.finrank E F) =>
+      b ((Fintype.equivFinOfCardEq (Module.finrank_eq_card_basis b).symm).symm i)) :=
+  b.linearIndependent.comp _ (Equiv.injective _)
+
+theorem hasIntegralBasisRegularOutside_of_isFractionRing
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    HasIntegralBasisRegularOutside K E F T := by
+  obtain ⟨s, b, hint⟩ := FiniteDimensional.exists_is_basis_integral A E F
+  set e : Fin (Module.finrank E F) ≃ s :=
+    (Fintype.equivFinOfCardEq (Module.finrank_eq_card_basis b).symm).symm
+  refine ⟨fun i => b (e i), linearIndependent_reindex_basis b, fun i w hw => ?_⟩
+  exact T.ord_nonneg_of_isIntegral_of_regularOutside hA (hint (e i)) w hw
+
+theorem hasIntegralBasisRegularOutside_of_hasRegularFractionSubring
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    HasIntegralBasisRegularOutside K E F T := by
+  obtain ⟨A, hfrac, hreg⟩ := h
+  have : IsFractionRing A E := hfrac
+  exact hasIntegralBasisRegularOutside_of_isFractionRing (A := A) T
+    (fun u hu a => hreg u hu (a : E) a.property)
+
+theorem hasPoleDivisorPackage_of_isFractionRing [HasPrincipalDivisors K F]
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside T
+    (hasIntegralBasisRegularOutside_of_isFractionRing T hA)
+
+theorem stichtenothGenusExists_of_isFractionRing [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasPoleDivisorPackage
+    (hasPoleDivisorPackage_of_isFractionRing T hA)
+
+theorem hasPoleDivisorPackage_of_hasRegularFractionSubring [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside T
+    (hasIntegralBasisRegularOutside_of_hasRegularFractionSubring T h)
+
+theorem stichtenothGenusExists_of_hasRegularFractionSubring [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasPoleDivisorPackage
+    (hasPoleDivisorPackage_of_hasRegularFractionSubring T h)
+
+namespace TranscendenceTower
+p2m_open_scoped "AlgebraicCurve.TranscendenceTower" in
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.adjoin_x_regularOutside (T :
+  TranscendenceTower K E F) :
+    ∀ u : Place K E, u ≠ T.v →
+      ∀ a ∈ Algebra.adjoin K {T.x}, a ∈ u.toValuationSubring := by
+  intro u hu a ha
+  let S : Subalgebra K E :=
+    { u.toValuationSubring.toSubsemiring with
+      algebraMap_mem' := u.algebraMap_mem' }
+  suffices h : a ∈ S from h
+  refine Algebra.adjoin_le ?_ ha
+  intro y hy
+  rw [Set.mem_singleton_iff] at hy
+  subst hy
+  change T.x ∈ u.toValuationSubring
+  exact AlgebraicCurve.Place.mem_of_ord_nonneg u T.x_ne_zero (T.hxreg u hu)
+
+end TranscendenceTower
+p2m_export "AlgebraicCurve" "TranscendenceTower.adjoin_x_regularOutside"
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+theorem hasRegularFractionSubring_of_adjoin_x_isFractionRing
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    HasRegularFractionSubring K E F T :=
+  ⟨Algebra.adjoin K {T.x}, hfrac, T.adjoin_x_regularOutside⟩
+
+theorem hasIntegralBasisRegularOutside_of_adjoin_x_isFractionRing
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    HasIntegralBasisRegularOutside K E F T :=
+  hasIntegralBasisRegularOutside_of_hasRegularFractionSubring T
+    (hasRegularFractionSubring_of_adjoin_x_isFractionRing T hfrac)
+
+theorem stichtenothGenusExists_of_adjoin_x_isFractionRing [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasRegularFractionSubring T
+    (hasRegularFractionSubring_of_adjoin_x_isFractionRing T hfrac)
+
+end Headline
+
+section Gates
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem gate_mem_of_isIntegral_recovers_comap (w : Place K F) (E : Type*) [Field E]
+    [Algebra E F] [Algebra.IsIntegral E F]
+    (hE : ∀ a : E, algebraMap E F a ∈ w.toValuationSubring) (f : F) :
+    f ∈ w.toValuationSubring := by
+  let : Algebra E w.toValuationSubring :=
+    ((algebraMap E F).codRestrict w.toValuationSubring.toSubring hE).toAlgebra
+  have : IsScalarTower E w.toValuationSubring F :=
+    IsScalarTower.of_algebraMap_eq fun _ => rfl
+  exact w.mem_of_isIntegral (Algebra.IsIntegral.isIntegral (R := E) f).tower_top
+
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+
+theorem gate_bridge_recovers_hxreg [Algebra.IsIntegral E F]
+    (T : TranscendenceTower K E F) (w : Place K F) (hw : w.restrict E ≠ T.v) :
+    0 ≤ w.ord T.xF := by
+  rw [TranscendenceTower.xF, Place.ord_restrict]
+  exact mul_nonneg (Int.natCast_nonneg _) (T.hxreg _ hw)
+
+theorem gate_regularOutside_mono (T : TranscendenceTower K E F) {A A' : Subalgebra K E}
+    (hle : A ≤ A')
+    (hA' : ∀ u : Place K E, u ≠ T.v → ∀ a ∈ A', a ∈ u.toValuationSubring) :
+    ∀ u : Place K E, u ≠ T.v → ∀ a ∈ A, a ∈ u.toValuationSubring :=
+  fun u hu a ha => hA' u hu a (hle ha)
+
+theorem gate_bot_regularOutside (T : TranscendenceTower K E F) :
+    ∀ u : Place K E, u ≠ T.v → ∀ a ∈ (⊥ : Subalgebra K E), a ∈ u.toValuationSubring := by
+  intro u _ a ha
+  obtain ⟨c, rfl⟩ := Algebra.mem_bot.mp ha
+  exact u.algebraMap_mem' c
+
+theorem gate_adjoin_x_not_regular_at_v (T : TranscendenceTower K E F) :
+    ¬ ∀ a ∈ Algebra.adjoin K {T.x}, a ∈ T.v.toValuationSubring := by
+  intro h
+  have hx := AlgebraicCurve.Place.ord_nonneg_of_mem T.v (h T.x (Algebra.subset_adjoin rfl))
+  rw [T.hxv] at hx
+  exact absurd hx (by decide)
+
+end Gates
+end AlgebraicCurve
+end
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg\
+  " in
+open _root_.P2MW.S_AlgebraicCurve_TranscendenceTower_poleDivisor_apply.AlgebraicCurve in
+theorem solution {K : Type*} {E : Type*} {F : Type*} [Field K] [Field E] [Field F] [Algebra K E]
+    [Algebra K F] [Algebra E F] [IsScalarTower K E F] [Algebra.IsSeparable E F]
+    [HasPrincipalDivisors K F] (T : TranscendenceTower K E F) (w : Place K F) :
+    T.poleDivisor w = (w.ramificationIndex E : ℤ) * (Finsupp.single T.v 1) (w.restrict E) :=
+  AlgebraicCurve.TranscendenceTower.poleDivisor_apply_port (K := K) (F := F) (E := E) (T := T) (w :=
+    w)
+
+end S_AlgebraicCurve_TranscendenceTower_poleDivisor_apply
+end P2MW
+export P2MW.S_AlgebraicCurve_TranscendenceTower_poleDivisor_apply (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace AlgebraicCurve
+theorem TranscendenceTower.poleDivisor_apply {K : Type*} {E : Type*} {F : Type*} [Field K] [Field E]
+    [Field F] [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+    [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] (T : TranscendenceTower K E F)
+    (w : Place K F) :
+    T.poleDivisor w = (w.ramificationIndex E : ℤ) * (Finsupp.single T.v 1) (w.restrict E) :=
+  solution T w
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_constantsAreBase_of_deg_eq_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_constantsAreBase_of_deg_eq_one.lean
new file mode 100644
index 0000000000..a68fae2a9e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_constantsAreBase_of_deg_eq_one.lean
@@ -0,0 +1,76 @@
+/-
+Based on Prove2Me node AlgebraicCurve.constantsAreBase_of_deg_eq_one
+(51f0b069-efe1-5222-b0a8-29fba4c7735c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e53e3990-7671-5eed-9e9c-e97c16e98e6e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_isRational_iff_deg_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_constantsAreBase_of_exists_isRational
+
+/-!
+# Constants are the base field given a degree-one place
+
+Theorem statement: `AlgebraicCurve.constantsAreBase_of_deg_eq_one`
+(`51f0b069-efe1-5222-b0a8-29fba4c7735c`), by Claude, 2026-09-05.
+
+Proof: submission `e53e3990-7671-5eed-9e9c-e97c16e98e6e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and suppose $F/K$ satisfies
+`HasPrincipalDivisors`: every nonzero $f \in F$ admits a divisor $D$ — a finitely supported function
+from the places of $K$ in $F$ to $\mathbb{Z}$ — with $D(v) = \operatorname{ord}_v(f)$ at every place
+$v$ and with $\deg D = 0$, the degree being the additive extension of $v \mapsto \deg v$, where a
+place is a valuation subring of $F$ containing the image of $K$, distinct from $F$ itself and a
+principal ideal ring, and $\deg v$ is the $K$-dimension of the residue field of that valuation
+subring. Assume further that there is a place $v_0$ with $\deg v_0 = 1$, that is, whose residue
+field is one-dimensional over $K$. Then `ConstantsAreBase K F` holds: the Riemann–Roch space $L(0)$
+attached to the zero divisor coincides, as a $K$-submodule of $F$, with the range of the $K$-linear
+structure map $K \to F$; in other words the only elements of $F$ with no pole at any place are the
+constants coming from $K$.
+
+This is the standard statement that a function field possessing a rational place has $K$ as its full
+field of constants. It is the convenient degree-theoretic form of the criterion for
+`ConstantsAreBase`, and is invoked throughout the Riemann–Roch and curve-model development, for
+instance in the comparison of Riemann–Roch spaces under place reduction and in the identification of
+the genus of a curve model.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_constantsAreBase_of_deg_eq_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [AlgebraicCurve.HasPrincipalDivisors K F]
+    (v₀ : AlgebraicCurve.Place K F) (hdeg : v₀.deg = 1) :
+    AlgebraicCurve.ConstantsAreBase K F :=
+  AlgebraicCurve.constantsAreBase_of_exists_isRational v₀ ((v₀.isRational_iff_deg_eq_one).mpr hdeg)
+    (hdeg ▸ one_ne_zero)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.constantsAreBase_of_deg_eq_one {K F : Type*} [Field K] [Field F]
+    [Algebra K F]
+    [AlgebraicCurve.HasPrincipalDivisors K F]
+    (v₀ : AlgebraicCurve.Place K F) (hdeg : v₀.deg = 1) :
+    AlgebraicCurve.ConstantsAreBase K F :=
+  solution v₀ hdeg
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_constantsAreBase_of_exists_isRational.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_constantsAreBase_of_exists_isRational.lean
new file mode 100644
index 0000000000..5acde7fe51
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_constantsAreBase_of_exists_isRational.lean
@@ -0,0 +1,176 @@
+/-
+Based on Prove2Me node AlgebraicCurve.constantsAreBase_of_exists_isRational
+(e5935f1d-f6fa-5aab-a3ff-4940601a9231) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1f63e6c4-88b9-5ab5-a0b9-b36a7ab733b3
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_ne_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Constants are the base field, given a rational place
+
+Theorem statement: `AlgebraicCurve.constantsAreBase_of_exists_isRational`
+(`e5935f1d-f6fa-5aab-a3ff-4940601a9231`), by Claude, 2026-09-05.
+
+Proof: submission `1f63e6c4-88b9-5ab5-a0b9-b36a7ab733b3`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and assume the class
+[`AlgebraicCurve.HasPrincipalDivisors K F`](def/AlgebraicCurve_DivisorClassGroup.html#L217): every
+nonzero $f \in F$ admits a divisor $D$ (a finitely supported $\mathbb{Z}$-valued function on the
+places of $K$ in $F$) with $D(v) = \operatorname{ord}_v(f)$ for all places $v$ and with $\deg D =
+0$, the degree being $\sum_v D(v)\,\deg v$ where $\deg v = \operatorname{finrank}_K$ of the residue
+field of $v$. Here a place is a valuation subring of $F$ containing the image of $K$, distinct from
+$F$ itself, and a principal ideal ring. Suppose given one place $v_0$ such that the structure map $K
+\to \kappa(v_0)$ onto the residue field of $v_0$ is surjective (the predicate
+[`AlgebraicCurve.Place.IsRational`](def/AlgebraicCurve_PlaceEvaluation.html#L18)), and such that
+$\deg v_0 \neq 0$. The conclusion is [`AlgebraicCurve.ConstantsAreBase K
+F`](def/AlgebraicCurve_AdelicIndex.html#L45), namely that the Riemann–Roch space of the zero
+divisor, $L(0) \subseteq F$, equals the range of the $K$-linear map $K \to F$; that is, the elements
+of $F$ with no poles at any place are exactly the constants coming from $K$.
+
+This is the standard statement that the field of constants of a function field is the base field, as
+soon as there exists a rational place of nonzero degree. It is used to supply the `ConstantsAreBase`
+hypothesis in the Riemann–Roch corollaries of the project, via the specialisations
+[`AlgebraicCurve.constantsAreBase_of_deg_eq_one`]
+(thm.html#AlgebraicCurve.constantsAreBase_of_deg_eq_one)
+and
+[`AlgebraicCurve.constantsAreBase_of_isAlgClosed`]
+(thm.html#AlgebraicCurve.constantsAreBase_of_isAlgClosed),
+and ultimately in the Serre-duality pairing statement for curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_constantsAreBase_of_exists_isRational.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_constantsAreBase_of_exists_isRational
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_constantsAreBase_of_exists_isRational.AlgebraicCurve"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "mem_lSpace_iff_ord algebraMap_mem_lSpace_zero ConstantsAreBase Place \
+  Place.coe_algebraMap Divisor Divisor.degree HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor Divisor.degree_eq_sum_support"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg ord algebraMap_mem' \
+  toValuationSubring IsRational evalAt algebraMap_evalAt mem_of_ord_nonneg ord_nonneg_of_mem \
+  evalAt_ne_zero"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+open IsLocalRing in
+private theorem _root_.AlgebraicCurve.Place.ord_sub_evalAt_pos_s17 (hrat : v.IsRational) {f : F}
+    (hf : f ∈ v.toValuationSubring)
+    (hne : f - algebraMap K F (v.evalAt f) ≠ 0) :
+    0 < v.ord (f - algebraMap K F (v.evalAt f)) := by
+  have hmem : f - algebraMap K F (v.evalAt f) ∈ v.toValuationSubring :=
+    sub_mem hf (v.algebraMap_mem' _)
+  rcases eq_or_ne (v.ord (f - algebraMap K F (v.evalAt f))) 0 with h0 | h0
+  · exfalso
+    refine v.evalAt_ne_zero hrat hne h0 ?_
+    have hres : algebraMap K v.ResidueField
+        (v.evalAt (f - algebraMap K F (v.evalAt f))) = 0 := by
+      rw [v.algebraMap_evalAt hrat hmem]
+      have hcoe : (⟨f - algebraMap K F (v.evalAt f), hmem⟩ : v.toValuationSubring)
+          = ⟨f, hf⟩ - algebraMap K v.toValuationSubring (v.evalAt f) := by
+        refine Subtype.ext ?_
+        change f - algebraMap K F (v.evalAt f)
+          = f - (algebraMap K v.toValuationSubring (v.evalAt f) : F)
+        rw [Place.coe_algebraMap]
+      rw [hcoe, map_sub, sub_eq_zero, ← v.algebraMap_evalAt hrat hf,
+        IsScalarTower.algebraMap_apply K v.toValuationSubring v.ResidueField,
+        IsLocalRing.ResidueField.algebraMap_eq]
+    exact (map_eq_zero_iff _ (algebraMap K v.ResidueField).injective).mp hres
+  · have hnonneg := v.ord_nonneg_of_mem hmem
+    omega
+
+p2m_export "AlgebraicCurve.Place" "ord_sub_evalAt_pos_s17"
+variable [HasPrincipalDivisors K F]
+
+theorem eq_algebraMap_of_forall_ord_nonneg_s17 (v₀ : Place K F) (hrat : v₀.IsRational)
+    (hdeg : v₀.deg ≠ 0) {g : F} (hg : g ≠ 0) (hord : ∀ v : Place K F, 0 ≤ v.ord g) :
+    ∃ c : K, g = algebraMap K F c := by
+  have hg₀ : g ∈ v₀.toValuationSubring := v₀.mem_of_ord_nonneg hg (hord v₀)
+  refine ⟨v₀.evalAt g, ?_⟩
+  by_contra hne
+  set t : F := g - algebraMap K F (v₀.evalAt g) with ht
+  have htne : t ≠ 0 := sub_ne_zero.mpr hne
+  have hzero : 0 < v₀.ord t := v₀.ord_sub_evalAt_pos_s17 hrat hg₀ htne
+  have hpole : ∀ v : Place K F, 0 ≤ v.ord t := fun v =>
+    v.ord_nonneg_of_mem (sub_mem (v.mem_of_ord_nonneg hg (hord v)) (v.algebraMap_mem' _))
+  obtain ⟨D, hD, hdeg0⟩ := HasPrincipalDivisors.exists_divisor (K := K) t htne
+  have hDpos : 0 < D v₀ := by rw [hD v₀]; exact hzero
+  have hDnonneg : ∀ v, 0 ≤ D v := fun v => by rw [hD v]; exact hpole v
+  have hmem : v₀ ∈ D.support := Finsupp.mem_support_iff.mpr hDpos.ne'
+  have hpos : 0 < Divisor.degree D := by
+    rw [Divisor.degree_eq_sum_support]
+    calc (0 : ℤ) < D v₀ * (v₀.deg : ℤ) :=
+          mul_pos hDpos (by exact_mod_cast Nat.pos_of_ne_zero hdeg)
+      _ ≤ ∑ v ∈ D.support, D v * (v.deg : ℤ) :=
+          Finset.single_le_sum
+            (fun v _ => mul_nonneg (hDnonneg v) (Int.natCast_nonneg _)) hmem
+  omega
+
+end Place
+
+theorem constantsAreBase_of_exists_isRational_s17 {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [HasPrincipalDivisors K F]
+    (v₀ : Place K F) (hrat : v₀.IsRational) (hdeg : v₀.deg ≠ 0) :
+    ConstantsAreBase K F := by
+  refine le_antisymm (fun f hf => ?_) (fun f ⟨c, hc⟩ => hc ▸ algebraMap_mem_lSpace_zero c)
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact zero_mem _
+  · have hord : ∀ v : Place K F, 0 ≤ v.ord f := by
+      have h := (mem_lSpace_iff_ord.mp hf).resolve_left hf0
+      simpa using h
+    obtain ⟨c, hc⟩ := Place.eq_algebraMap_of_forall_ord_nonneg_s17 v₀ hrat hdeg hf0 hord
+    exact ⟨c, hc.symm⟩
+
+end AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [AlgebraicCurve.HasPrincipalDivisors K F]
+    (v₀ : AlgebraicCurve.Place K F) (hrat : v₀.IsRational) (hdeg : v₀.deg ≠ 0) :
+    AlgebraicCurve.ConstantsAreBase K F :=
+  AlgebraicCurve.constantsAreBase_of_exists_isRational_s17 v₀ hrat hdeg
+
+end S_AlgebraicCurve_constantsAreBase_of_exists_isRational
+end P2MW
+export P2MW.S_AlgebraicCurve_constantsAreBase_of_exists_isRational (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.constantsAreBase_of_exists_isRational {K F : Type*} [Field K] [Field F]
+    [Algebra K F]
+    [AlgebraicCurve.HasPrincipalDivisors K F]
+    (v₀ : AlgebraicCurve.Place K F) (hrat : v₀.IsRational) (hdeg : v₀.deg ≠ 0) :
+    AlgebraicCurve.ConstantsAreBase K F :=
+  solution v₀ hrat hdeg
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_constantsAreBase_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_constantsAreBase_of_isAlgClosed.lean
new file mode 100644
index 0000000000..83005276db
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_constantsAreBase_of_isAlgClosed.lean
@@ -0,0 +1,97 @@
+/-
+Based on Prove2Me node AlgebraicCurve.constantsAreBase_of_isAlgClosed
+(ae516b02-8cce-5991-9cef-dd60890a2469) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 824b37ed-1c32-5145-84ce-fe39a9a2be83
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_isRational_iff_deg_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_isRational_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_nonempty_place_of_ratFunc_tower
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_constantsAreBase_of_exists_isRational
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Over an algebraically closed base, the constants are K
+
+Theorem statement: `AlgebraicCurve.constantsAreBase_of_isAlgClosed`
+(`ae516b02-8cce-5991-9cef-dd60890a2469`), by Claude, 2026-09-05.
+
+Proof: submission `824b37ed-1c32-5145-84ce-fe39a9a2be83`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and suppose in addition that $F$ is an algebra
+over the rational function field $\mathrm{RatFunc}\,K$ in a way compatible with the $K$-algebra
+structures (a scalar tower $K \subseteq \mathrm{RatFunc}\,K \subseteq F$), finite-dimensional over
+$\mathrm{RatFunc}\,K$ and separable over it. Assume $K$ is algebraically closed and that $F$ is a
+curve over $K$ in the sense of [`AlgebraicCurve.IsCurveOver K
+F`](def/AlgebraicCurve_IsCurveOver.html#L15): every nonzero $f \in F$ admits a divisor $D$ (a
+finitely supported integer-valued function on the places of $F/K$, a place being a proper valuation
+subring of $F$ containing the image of $K$ whose ring is a principal ideal ring) with $D(v) =
+\mathrm{ord}_v(f)$ at every place $v$ and $\deg D = 0$; each residue field of a place is
+finite-dimensional over $K$; and the module of Kähler differentials $\Omega_{F/K}$ is free of rank
+one over $F$. The conclusion is [`AlgebraicCurve.ConstantsAreBase K
+F`](def/AlgebraicCurve_AdelicIndex.html#L45), namely that the Riemann–Roch space $L(0)$ of the zero
+divisor, as a $K$-submodule of $F$, equals the range of the $K$-linear structure map $K \to F$.
+
+This is the statement that a curve over an algebraically closed field has no constants beyond the
+base field, so that $\ell(0) = 1$; it is the input needed to normalise the Riemann–Roch formula over
+an algebraically closed base, and is cited by the computations of $\deg \omega = 2g-2$, of $\ell(D)
+= \deg D + 1 - g$, and of spaces of polar differentials.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_constantsAreBase_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_constantsAreBase_of_isAlgClosed
+
+open AlgebraicCurve
+
+theorem solution (K F : Type*) [Field K] [Field F] [Algebra K F]
+    [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+    [IsAlgClosed K] [AlgebraicCurve.IsCurveOver K F] :
+    AlgebraicCurve.ConstantsAreBase K F := by
+  classical
+  obtain ⟨v⟩ := AlgebraicCurve.RationalFunctionField.nonempty_place_of_ratFunc_tower K F
+  have hrat : v.IsRational := AlgebraicCurve.Place.isRational_of_isAlgClosed v
+  exact AlgebraicCurve.constantsAreBase_of_exists_isRational v hrat
+    (((v.isRational_iff_deg_eq_one).mp hrat).symm ▸ one_ne_zero)
+
+end S_AlgebraicCurve_constantsAreBase_of_isAlgClosed
+end P2MW
+export P2MW.S_AlgebraicCurve_constantsAreBase_of_isAlgClosed (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.constantsAreBase_of_isAlgClosed (K F : Type*) [Field K] [Field F]
+    [Algebra K F]
+    [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+    [IsAlgClosed K] [AlgebraicCurve.IsCurveOver K F] :
+    AlgebraicCurve.ConstantsAreBase K F := by
+  classical
+  exact
+    solution K F
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_constantsAreBase_of_isAlgClosed_of_transcendental.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_constantsAreBase_of_isAlgClosed_of_transcendental.lean
new file mode 100644
index 0000000000..09f50a9308
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_constantsAreBase_of_isAlgClosed_of_transcendental.lean
@@ -0,0 +1,104 @@
+/-
+Based on Prove2Me node AlgebraicCurve.constantsAreBase_of_isAlgClosed_of_transcendental
+(d7f11e84-74c2-50a3-a08a-692ae5afaed9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission cf36bc84-90ca-5cdf-bf19-29eecd1e3f84
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom_of_isSeparable
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_constantsAreBase_of_deg_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_separating_transcendental_of_perfectField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_isAlgClosed_of_transcendental
+import Mathlib.RingTheory.Valuation.LocalSubring
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Constants are the base field when K is algebraically closed
+
+Theorem statement: `AlgebraicCurve.constantsAreBase_of_isAlgClosed_of_transcendental`
+(`d7f11e84-74c2-50a3-a08a-692ae5afaed9`), by Claude, 2026-09-05.
+
+Proof: submission `cf36bc84-90ca-5cdf-bf19-29eecd1e3f84`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field and let $F$ be a field equipped with a $K$-algebra
+structure. Suppose given $x \in F$ transcendental over $K$ such that $F$ is finite-dimensional over
+the intermediate field $K(x) =$ `IntermediateField.adjoin K {x}`. Then `ConstantsAreBase K F` holds:
+writing `Divisor K F` for the group of finitely supported $\mathbb{Z}$-valued functions on the set
+`Place K F` of places of $F$ over $K$, and `LSpace D` for the Riemann–Roch space `riemannRochSpace
+D` viewed as a $K$-submodule of $F$, the assertion is the equality of $K$-submodules of $F$
+$$\mathcal{L}(0) \;=\; \operatorname{range}\big(\mathrm{Algebra.linearMap}\ K\ F\big),$$
+that is, the Riemann–Roch space of the zero divisor coincides with the image of $K$ in $F$ under the
+structure map. Thus the only elements of $F$ that are regular at every place of $F/K$ are the images
+of the elements of $K$.
+
+This is the classical statement that the field of constants of a function field of one variable over
+an algebraically closed base field is the base field itself (Stichtenoth, Cor. I.1.20). It feeds the
+Riemann–Roch package of the development, where it yields $\ell(0) = 1$, and is used in the treatment
+of the degree-zero divisor class group and of reduction of curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_constantsAreBase_of_isAlgClosed_of_transcendental.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_constantsAreBase_of_isAlgClosed_of_transcendental
+
+
+open AlgebraicCurve
+
+theorem solution
+    {K F : Type*} [Field K] [IsAlgClosed K] [Field F] [Algebra K F]
+    (x : F) (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] :
+    ConstantsAreBase K F := by
+  have hICO : IsCurveOver K F := isCurveOver_of_isAlgClosed_of_transcendental x hx
+  obtain ⟨t, htr_t, hfd_t, hsep_t⟩ :=
+    exists_separating_transcendental_of_perfectField (K := K) (F := F) hx inferInstance
+  have : FiniteDimensional (IntermediateField.adjoin K ({t} : Set F)) F := hfd_t
+  have : Algebra.IsSeparable (IntermediateField.adjoin K ({t} : Set F)) F := hsep_t
+  have hxIC : x ∉ (integralClosure K F).toSubring := fun h ↦ hx h.isAlgebraic
+  obtain ⟨V, hICV, hxV⟩ :=
+    Subring.exists_le_valuationSubring_of_isIntegrallyClosedIn
+      (R := (integralClosure K F).toSubring) hxIC
+  have hKV : ∀ a : K, (RingHom.id F) (algebraMap K F a) ∈ V := fun a ↦
+    hICV (Subalgebra.algebraMap_mem (integralClosure K F) a)
+  obtain ⟨v₀, -⟩ :=
+    Place.exists_toValuationSubring_eq_comap_ringHom_of_isSeparable (K := K) (F := F) (F' := F)
+      t (RingHom.id F) V hKV ⟨x, hxV⟩
+  exact constantsAreBase_of_deg_eq_one v₀ (IsCurveOver.deg_eq_one_of_isAlgClosed v₀)
+
+end S_AlgebraicCurve_constantsAreBase_of_isAlgClosed_of_transcendental
+end P2MW
+export P2MW.S_AlgebraicCurve_constantsAreBase_of_isAlgClosed_of_transcendental (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.constantsAreBase_of_isAlgClosed_of_transcendental
+    {K F : Type*} [Field K] [IsAlgClosed K] [Field F] [Algebra K F]
+    (x : F) (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] :
+    ConstantsAreBase K F :=
+  solution x hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_dCoordGenerates_of_isCurveOver.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_dCoordGenerates_of_isCurveOver.lean
new file mode 100644
index 0000000000..d1c09b2ba7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_dCoordGenerates_of_isCurveOver.lean
@@ -0,0 +1,1148 @@
+/-
+Based on Prove2Me node AlgebraicCurve.dCoordGenerates_of_isCurveOver
+(2eb1e0ff-91de-550a-bd77-cad165d366e9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c236de2d-fa90-53a6-8147-76b2f9d806f1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CanonicalDivisor
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.Adjoin.Polynomial.Transcendental
+import Mathlib.RingTheory.LocalRing.Module
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.Unramified.Field
+import Mathlib.RingTheory.Valuation.LocalSubring
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_IsCurveOver_exists_separating_transcendental
+
+/-!
+# Differential of a uniformiser generates Ω_{F/K}
+
+Theorem statement: `AlgebraicCurve.dCoordGenerates_of_isCurveOver`
+(`2eb1e0ff-91de-550a-bd77-cad165d366e9`), by Claude, 2026-09-05.
+
+Proof: submission `c236de2d-fa90-53a6-8147-76b2f9d806f1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, $K$ perfect, and $F$ essentially of finite type
+over $K$, and assume `IsCurveOver K F`, i.e. (a) every nonzero $f \in F$ admits a divisor $D$ on the
+places of $F/K$ with $D(v) = \operatorname{ord}_v f$ for all $v$ and $\deg D = 0$, (b) for every
+place $v$ the residue field of $v$ is a finite $K$-module, and (c) the module of Kähler
+differentials $\Omega[F\!\restriction\!K]$ is free of rank one over $F$. Here a place $v$ of $F/K$
+is a valuation subring of $F$ which contains $\operatorname{algebraMap} K F(a)$ for every $a \in K$,
+is not all of $F$, and is a principal ideal ring. The conclusion is that every place $v$ satisfies
+`DCoordGenerates`, i.e. the single element $v.\mathrm{dCoord} = D_{K,F}(v.\mathrm{uniformizer})$,
+the Kähler differential of the chosen uniformiser `v.uniformizer` of $v$, spans
+$\Omega[F\!\restriction\!K]$ as an $F$-submodule: $\operatorname{span}_F\{v.\mathrm{dCoord}\} =
+\top$.
+
+This is the statement that at each place of a curve the differential of a local uniformiser is a
+generator of the (rank-one) module of differentials, so that $d\pi_v$ may be used as a local
+coordinate. It discharges the hypothesis that every place has `DCoordGenerates`, which is carried by
+the Riemann–Roch and residue-theorem statements of the development and by the many results built on
+them, and it is deduced from the existence of a separating transcendental element
+(`exists_separating_transcendental`).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_dCoordGenerates_of_isCurveOver.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+
+open IsDedekindDomain
+namespace AlgebraicCurve
+
+namespace Place
+
+section Transport
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private noncomputable def uniformizerSubring' : v.toValuationSubring :=
+  (IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose
+
+private theorem kaehlerMap_subring_D_uniformizer :
+    KaehlerDifferential.map K K v.toValuationSubring F
+      (KaehlerDifferential.D K v.toValuationSubring v.uniformizerSubring') = v.dCoord := by
+  rw [KaehlerDifferential.map_D K K v.toValuationSubring F]
+  rfl
+
+end Transport
+
+end Place
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def ValSubringKaehlerSpanTop : Prop :=
+  ∀ v : Place K F,
+    Submodule.span v.toValuationSubring
+      {KaehlerDifferential.D K v.toValuationSubring (Place.uniformizerSubring' v)} = ⊤
+
+end AlgebraicCurve
+
+open IsDedekindDomain Polynomial
+namespace AlgebraicCurve
+
+namespace Place
+
+section CotangentEngine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private noncomputable def uniformizerSubring'' : v.toValuationSubring :=
+  (IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose
+
+@[reducible] private noncomputable def polynomialAlgebra :
+    Algebra K[X] v.toValuationSubring :=
+  (Polynomial.aeval (R := K) v.uniformizerSubring'').toRingHom.toAlgebra
+
+private theorem polynomialAlgebra_algebraMap_X :
+    letI := v.polynomialAlgebra
+    algebraMap K[X] v.toValuationSubring X = v.uniformizerSubring'' :=
+  aeval_X _
+
+private lemma polynomialIsScalarTower :
+    letI := v.polynomialAlgebra
+    IsScalarTower K K[X] v.toValuationSubring := by
+  let := v.polynomialAlgebra
+  refine IsScalarTower.of_algebraMap_eq fun a => ?_
+  change _ = aeval v.uniformizerSubring'' (algebraMap K K[X] a)
+  simp [Polynomial.algebraMap_eq, aeval_C]
+
+private theorem range_mapBaseChange_le_span_D_uniformizer :
+    letI := v.polynomialAlgebra
+    letI := v.polynomialIsScalarTower
+    LinearMap.range (KaehlerDifferential.mapBaseChange K K[X] v.toValuationSubring)
+      ≤ Submodule.span v.toValuationSubring
+          {KaehlerDifferential.D K v.toValuationSubring v.uniformizerSubring''} := by
+  let := v.polynomialAlgebra
+  let := v.polynomialIsScalarTower
+  rintro _ ⟨t, rfl⟩
+  induction t with
+  | add x y hx hy => rw [map_add]; exact add_mem hx hy
+  | tmul b ω =>
+    rw [KaehlerDifferential.mapBaseChange_tmul,
+      show ω = (KaehlerDifferential.polynomialEquiv K ω) • (KaehlerDifferential.D K K[X] X) from
+        ((KaehlerDifferential.polynomialEquiv K).symm_apply_apply ω).symm.trans
+          (KaehlerDifferential.polynomialEquiv_symm K _),
+      LinearMap.map_smul, KaehlerDifferential.map_D,
+      show algebraMap K[X] v.toValuationSubring X = v.uniformizerSubring'' from aeval_X _,
+      ← algebraMap_smul (A := v.toValuationSubring)]
+    exact Submodule.smul_mem _ b
+      (Submodule.smul_mem _ _ (Submodule.mem_span_singleton_self _))
+
+private theorem range_mapBaseChange_eq_top_of_subsingleton
+    (hsub :
+      letI := v.polynomialAlgebra
+      Subsingleton Ω[v.toValuationSubring⁄K[X]]) :
+    letI := v.polynomialAlgebra
+    letI := v.polynomialIsScalarTower
+    LinearMap.range (KaehlerDifferential.mapBaseChange K K[X] v.toValuationSubring) = ⊤ := by
+  let := v.polynomialAlgebra
+  let := v.polynomialIsScalarTower
+  rw [KaehlerDifferential.range_mapBaseChange]
+  exact LinearMap.ker_eq_top.mpr (Subsingleton.elim _ _)
+
+private theorem span_D_uniformizer_eq_top_of_subsingleton
+    (hsub :
+      letI := v.polynomialAlgebra
+      Subsingleton Ω[v.toValuationSubring⁄K[X]]) :
+    Submodule.span v.toValuationSubring
+      {KaehlerDifferential.D K v.toValuationSubring v.uniformizerSubring''} = ⊤ := by
+  refine top_le_iff.mp ?_
+  rw [← v.range_mapBaseChange_eq_top_of_subsingleton hsub]
+  exact v.range_mapBaseChange_le_span_D_uniformizer
+
+end CotangentEngine
+end Place
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def ValSubringPolynomialFormallyUnramified : Prop :=
+  ∀ v : Place K F,
+    letI := v.polynomialAlgebra
+    Subsingleton Ω[v.toValuationSubring⁄K[X]]
+
+variable {K F}
+
+theorem valSubringKaehlerSpanTop_of_polynomialFormallyUnramified
+    (hfu : ValSubringPolynomialFormallyUnramified K F) :
+    ValSubringKaehlerSpanTop K F :=
+  fun v => v.span_D_uniformizer_eq_top_of_subsingleton (hfu v)
+
+end AlgebraicCurve
+
+open IsDedekindDomain Polynomial IsLocalRing
+open scoped TensorProduct
+
+namespace AlgebraicCurve
+
+namespace Place
+
+section ResidueEngine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private noncomputable def uniformizerSubring''' :
+    v.toValuationSubring :=
+  (IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose
+
+private theorem irreducible_uniformizerSubring''' :
+    Irreducible v.uniformizerSubring''' :=
+  (IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose_spec
+
+private theorem maximalIdeal_eq_span_uniformizer :
+    IsLocalRing.maximalIdeal v.toValuationSubring = Ideal.span {v.uniformizerSubring'''} :=
+  (IsDiscreteValuationRing.irreducible_iff_uniformizer _).mp v.irreducible_uniformizerSubring'''
+
+private theorem D_polynomialAlgebra_uniformizer :
+    letI := v.polynomialAlgebra
+    KaehlerDifferential.D K[X] v.toValuationSubring v.uniformizerSubring''' = 0 := by
+  let := v.polynomialAlgebra
+  rw [show v.uniformizerSubring''' = algebraMap K[X] v.toValuationSubring X from
+    (v.polynomialAlgebra_algebraMap_X).symm]
+  exact (KaehlerDifferential.D K[X] v.toValuationSubring).map_algebraMap X
+
+private theorem ker_algebraMap_residueField_eq_span :
+    RingHom.ker (algebraMap v.toValuationSubring v.ResidueField)
+      = Ideal.span {v.uniformizerSubring'''} := by
+  rw [IsLocalRing.ResidueField.algebraMap_eq, IsLocalRing.ker_residue,
+    v.maximalIdeal_eq_span_uniformizer]
+
+private theorem
+  formallyUnramified_polynomial_residueField_of_isSeparable
+    [Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring)] :
+    letI := v.polynomialAlgebra
+    Algebra.FormallyUnramified K[X] (IsLocalRing.ResidueField v.toValuationSubring) := by
+  let := v.polynomialAlgebra
+  let := v.polynomialIsScalarTower
+  have : Algebra.FormallyUnramified K (IsLocalRing.ResidueField v.toValuationSubring) :=
+    Algebra.FormallyUnramified.of_isSeparable K _
+  exact Algebra.FormallyUnramified.of_restrictScalars K K[X] _
+
+private theorem subsingleton_residueKaehler_of_isSeparable
+    [Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring)] :
+    letI := v.polynomialAlgebra
+    Subsingleton Ω[(IsLocalRing.ResidueField v.toValuationSubring)⁄K[X]] := by
+  let := v.polynomialAlgebra
+  have := v.formallyUnramified_polynomial_residueField_of_isSeparable
+  exact Algebra.FormallyUnramified.subsingleton_kaehlerDifferential
+
+private theorem
+  subsingleton_residueTensor_polynomialKaehler_of_isSeparable
+    [Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring)] :
+    letI := v.polynomialAlgebra
+    Subsingleton (v.ResidueField ⊗[v.toValuationSubring] Ω[v.toValuationSubring⁄K[X]]) := by
+  let := v.polynomialAlgebra
+  let := v.polynomialIsScalarTower
+  have := v.subsingleton_residueKaehler_of_isSeparable
+  refine subsingleton_of_forall_eq 0 fun t => ?_
+  obtain ⟨c, rfl⟩ :=
+    ((KaehlerDifferential.exact_kerCotangentToTensor_mapBaseChange K[X]
+      v.toValuationSubring v.ResidueField
+      Ideal.Quotient.mk_surjective) t).mp (Subsingleton.elim _ _)
+  obtain ⟨⟨x, hx⟩, rfl⟩ := Ideal.toCotangent_surjective _ c
+  simp only [KaehlerDifferential.kerCotangentToTensor_toCotangent]
+  rw [v.ker_algebraMap_residueField_eq_span] at hx
+  induction hx using Submodule.span_induction with
+  | mem y hy =>
+    rcases hy with rfl
+    rw [v.D_polynomialAlgebra_uniformizer, TensorProduct.tmul_zero]
+  | zero => simp
+  | add y z _ _ hy hz =>
+    rw [map_add, TensorProduct.tmul_add, hy, hz, add_zero]
+  | smul a y hy IH =>
+    have hres : (algebraMap v.toValuationSubring v.ResidueField y) = 0 := by
+      rw [IsLocalRing.ResidueField.algebraMap_eq, IsLocalRing.residue_eq_zero_iff,
+        v.maximalIdeal_eq_span_uniformizer]
+      exact hy
+    rw [smul_eq_mul, Derivation.leibniz, TensorProduct.tmul_add,
+      TensorProduct.tmul_smul, IH, smul_zero, zero_add,
+      ← TensorProduct.smul_tmul, ← Algebra.algebraMap_eq_smul_one, hres,
+      TensorProduct.zero_tmul]
+
+private theorem finite_polynomialKaehler_of_finite_kaehler
+    [Module.Finite v.toValuationSubring Ω[v.toValuationSubring⁄K]] :
+    letI := v.polynomialAlgebra
+    Module.Finite v.toValuationSubring Ω[v.toValuationSubring⁄K[X]] := by
+  let := v.polynomialAlgebra
+  let := v.polynomialIsScalarTower
+  exact Module.Finite.of_surjective
+    (KaehlerDifferential.map K K[X] v.toValuationSubring v.toValuationSubring)
+    (KaehlerDifferential.map_surjective K K[X] v.toValuationSubring)
+
+private theorem subsingleton_polynomialKaehler_of_isSeparable_of_finite
+    [Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring)]
+    [Module.Finite v.toValuationSubring Ω[v.toValuationSubring⁄K]] :
+    letI := v.polynomialAlgebra
+    Subsingleton Ω[v.toValuationSubring⁄K[X]] := by
+  let := v.polynomialAlgebra
+  have := v.finite_polynomialKaehler_of_finite_kaehler
+  have := v.subsingleton_residueTensor_polynomialKaehler_of_isSeparable
+  exact (IsLocalRing.subsingleton_tensorProduct (R := v.toValuationSubring)).mp ‹_›
+
+end ResidueEngine
+end Place
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def ValSubringKaehlerFinite : Prop :=
+  ∀ v : Place K F, Module.Finite v.toValuationSubring Ω[v.toValuationSubring⁄K]
+
+variable {K F}
+
+theorem valSubringPolynomialFormallyUnramified_of_kaehlerFinite_of_isSeparable
+    [∀ v : Place K F, Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring)]
+    (hfin : ValSubringKaehlerFinite K F) :
+    ValSubringPolynomialFormallyUnramified K F := by
+  intro v
+  have := hfin v
+  exact v.subsingleton_polynomialKaehler_of_isSeparable_of_finite
+
+end AlgebraicCurve
+
+open IsDedekindDomain Polynomial IsLocalRing
+namespace AlgebraicCurve
+
+namespace Place
+
+section EftEngine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem finite_kaehler_of_essFiniteType [Algebra.EssFiniteType K
+  v.toValuationSubring] :
+    Module.Finite v.toValuationSubring Ω[v.toValuationSubring⁄K] :=
+  KaehlerDifferential.finite K v.toValuationSubring
+
+private theorem essFiniteType_of_exists_finiteType_isLocalization
+    (h : ∃ (S₀ : Subalgebra K v.toValuationSubring) (M : Submonoid S₀),
+      Algebra.FiniteType K S₀ ∧ IsLocalization M v.toValuationSubring) :
+    Algebra.EssFiniteType K v.toValuationSubring :=
+  (Algebra.essFiniteType_iff_exists_subalgebra K v.toValuationSubring).mpr
+    (h.imp fun _ ⟨M, hft, hloc⟩ => ⟨M, hft, hloc⟩)
+
+end EftEngine
+end Place
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def ValSubringEssFiniteType : Prop :=
+  ∀ v : Place K F, Algebra.EssFiniteType K v.toValuationSubring
+
+def ValSubringFiniteTypeModel : Prop :=
+  ∀ v : Place K F,
+    ∃ (S₀ : Subalgebra K v.toValuationSubring) (M : Submonoid S₀),
+      Algebra.FiniteType K S₀ ∧ IsLocalization M v.toValuationSubring
+
+variable {K F}
+
+theorem valSubringKaehlerFinite_of_essFiniteType
+    (heft : ValSubringEssFiniteType K F) :
+    ValSubringKaehlerFinite K F := fun v =>
+  haveI := heft v
+  v.finite_kaehler_of_essFiniteType
+
+theorem valSubringEssFiniteType_of_finiteTypeModel
+    (hmodel : ValSubringFiniteTypeModel K F) :
+    ValSubringEssFiniteType K F := fun v =>
+  v.essFiniteType_of_exists_finiteType_isLocalization (hmodel v)
+
+theorem valSubringEssFiniteType_iff_finiteTypeModel :
+    ValSubringEssFiniteType K F ↔ ValSubringFiniteTypeModel K F := by
+  constructor
+  · intro heft v
+    have := heft v
+    exact (Algebra.essFiniteType_iff_exists_subalgebra K v.toValuationSubring).mp (heft v)
+  · exact valSubringEssFiniteType_of_finiteTypeModel
+
+theorem valSubringKaehlerFinite_of_finiteTypeModel
+    (hmodel : ValSubringFiniteTypeModel K F) :
+    ValSubringKaehlerFinite K F :=
+  valSubringKaehlerFinite_of_essFiniteType
+    (valSubringEssFiniteType_of_finiteTypeModel hmodel)
+
+end AlgebraicCurve
+
+open IsDedekindDomain Polynomial IsLocalRing
+namespace ValuationSubring
+open ValuationSubring
+
+variable {F : Type*} [Field F]
+
+private theorem ofPrime_congr_s12 {R : ValuationSubring F} {P Q : Ideal R}
+    [P.IsPrime] [Q.IsPrime] (h : P = Q) : R.ofPrime P = R.ofPrime Q := by
+  subst h; congr
+
+theorem eq_top_of_idealOfLE_eq_bot_s12 {R S : ValuationSubring F} (h : R ≤ S)
+    (hbot : idealOfLE R S h = ⊥) : S = ⊤ := by
+  have : IsDomain R := inferInstanceAs (IsDomain R.toSubring)
+  rw [← ofPrime_idealOfLE R S h, ofPrime_congr_s12 hbot, ofPrime_bot]
+
+theorem idealOfLE_ne_bot_of_ne_top_s12 {R S : ValuationSubring F} (h : R ≤ S)
+    (hS : S ≠ ⊤) : idealOfLE R S h ≠ ⊥ :=
+  fun hbot => hS (eq_top_of_idealOfLE_eq_bot_s12 h hbot)
+
+theorem eq_of_isDiscreteValuationRing_of_le_s12 {R S : ValuationSubring F}
+    [IsDiscreteValuationRing R] (h : R ≤ S) (hS : S ≠ ⊤) : R = S := by
+  have : IsDomain R := inferInstanceAs (IsDomain R.toSubring)
+  have : IsDedekindDomain R := IsPrincipalIdealRing.isDedekindDomain R
+  have hne : idealOfLE R S h ≠ ⊥ := idealOfLE_ne_bot_of_ne_top_s12 h hS
+  have hmax : (idealOfLE R S h).IsMaximal := (prime_idealOfLE R S h).isMaximal hne
+  have heq : idealOfLE R S h = IsLocalRing.maximalIdeal R := IsLocalRing.eq_maximalIdeal hmax
+  rw [← ofPrime_idealOfLE R S h, ofPrime_congr_s12 heq, ofPrime_top]
+
+end ValuationSubring
+
+namespace AlgebraicCurve
+
+namespace Place
+
+section CenterIdeal
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+variable (A : Subalgebra K F) (hA : (A : Set F) ⊆ (v.toValuationSubring : Set F))
+
+@[reducible] private noncomputable def modelInclusion :
+    A →+* v.toValuationSubring :=
+  (Subring.inclusion (show A.toSubring ≤ v.toValuationSubring.toSubring from hA))
+
+@[scoped simp] theorem coe_modelInclusion (a : A) :
+    ((v.modelInclusion A hA a : v.toValuationSubring) : F) = (a : F) := rfl
+
+@[reducible] private noncomputable def modelAlgebra :
+    Algebra A v.toValuationSubring :=
+  (v.modelInclusion A hA).toAlgebra
+
+@[reducible] private noncomputable def centerIdeal : Ideal A :=
+  letI := v.modelAlgebra A hA
+  (IsLocalRing.maximalIdeal v.toValuationSubring).comap (algebraMap A v.toValuationSubring)
+
+scoped instance centerIdeal_isPrime : (v.centerIdeal A hA).IsPrime :=
+  letI := v.modelAlgebra A hA
+  Ideal.comap_isPrime _ _
+
+private theorem isUnit_modelInclusion_of_not_mem_centerIdeal {s : A}
+    (hs : s ∉ v.centerIdeal A hA) :
+    IsUnit (v.modelInclusion A hA s) := by
+  let := v.modelAlgebra A hA
+  rw [centerIdeal, Ideal.mem_comap, IsLocalRing.mem_maximalIdeal, mem_nonunits_iff,
+    not_not] at hs
+  exact hs
+
+private theorem isUnit_modelInclusion_of_mem_primeCompl (s :
+  (v.centerIdeal A hA).primeCompl) :
+    IsUnit (v.modelInclusion A hA (s : A)) :=
+  v.isUnit_modelInclusion_of_not_mem_centerIdeal A hA s.2
+
+private theorem modelAlgebra_isScalarTower :
+    letI := v.modelAlgebra A hA
+    IsScalarTower K A v.toValuationSubring := by
+  let := v.modelAlgebra A hA
+  refine IsScalarTower.of_algebraMap_eq fun c => ?_
+  apply Subtype.ext
+  simp only [coe_modelInclusion, RingHom.algebraMap_toAlgebra]
+  rfl
+
+private theorem essFiniteType_of_finiteType_isLocalization_centerIdeal
+    [Algebra.FiniteType K A]
+    (hloc : letI := v.modelAlgebra A hA
+            IsLocalization.AtPrime v.toValuationSubring (v.centerIdeal A hA)) :
+    Algebra.EssFiniteType K v.toValuationSubring := by
+  let := v.modelAlgebra A hA
+  have := v.modelAlgebra_isScalarTower A hA
+  have : Algebra.EssFiniteType A v.toValuationSubring :=
+    Algebra.EssFiniteType.of_isLocalization _ (v.centerIdeal A hA).primeCompl
+  exact Algebra.EssFiniteType.comp K A v.toValuationSubring
+
+end CenterIdeal
+end Place
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def ValSubringDedekindModel : Prop :=
+  ∀ v : Place K F,
+    ∃ (A : Subalgebra K F) (hA : (A : Set F) ⊆ (v.toValuationSubring : Set F)),
+      Algebra.FiniteType K A ∧
+      (letI := v.modelAlgebra A hA
+       IsLocalization.AtPrime v.toValuationSubring (v.centerIdeal A hA))
+
+variable {K F}
+
+theorem valSubringEssFiniteType_of_dedekindModel
+    (hmodel : ValSubringDedekindModel K F) :
+    ValSubringEssFiniteType K F := fun v => by
+  obtain ⟨A, hA, hft, hloc⟩ := hmodel v
+  exact v.essFiniteType_of_finiteType_isLocalization_centerIdeal A hA hloc
+
+theorem valSubringFiniteTypeModel_of_dedekindModel
+    (hmodel : ValSubringDedekindModel K F) :
+    ValSubringFiniteTypeModel K F :=
+  valSubringEssFiniteType_iff_finiteTypeModel.mp
+    (valSubringEssFiniteType_of_dedekindModel hmodel)
+
+end AlgebraicCurve
+
+open IsLocalRing
+
+namespace AlgebraicCurve
+
+namespace Place
+
+section CenterNonzero
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+  (A : Subalgebra K F) (hA : (A : Set F) ⊆ (v.toValuationSubring : Set F))
+
+private theorem inv_mem_of_not_mem_centerIdeal {a : A} (ha : a ∉ v.centerIdeal A hA) :
+    ((a : F))⁻¹ ∈ v.toValuationSubring := by
+  obtain ⟨u, hu⟩ := v.isUnit_modelInclusion_of_not_mem_centerIdeal A hA ha
+  have huF : ((u : v.toValuationSubring) : F) = (a : F) :=
+    congrArg (Subtype.val : v.toValuationSubring → F) hu
+  have huinvF : ((u⁻¹ : v.toValuationSubringˣ).1 : F) * (a : F) = 1 := by
+    have h1 : ((u⁻¹ : v.toValuationSubringˣ).1 : F) * ((u : v.toValuationSubring) : F)
+        = ((1 : v.toValuationSubring) : F) :=
+      congrArg (Subtype.val : v.toValuationSubring → F) u.inv_mul
+    rw [huF] at h1; exact h1
+  have : ((u⁻¹ : v.toValuationSubringˣ).1 : F) = (a : F)⁻¹ :=
+    eq_inv_of_mul_eq_one_left huinvF
+  exact this ▸ ((u⁻¹ : v.toValuationSubringˣ).1 : v.toValuationSubring).2
+
+private theorem div_mem_of_not_mem_centerIdeal (r : A) {a : A}
+    (ha : a ∉ v.centerIdeal A hA) :
+    (r : F) / (a : F) ∈ v.toValuationSubring := by
+  rw [div_eq_mul_inv]
+  exact v.toValuationSubring.toSubring.mul_mem (hA r.2)
+    (inv_mem_of_not_mem_centerIdeal v A hA ha)
+
+private theorem centerIdeal_ne_bot_of_isFractionRing [IsFractionRing A
+  F] :
+    v.centerIdeal A hA ≠ ⊥ := by
+  obtain ⟨f, hf⟩ : ∃ f : F, f ∉ v.toValuationSubring := by
+    by_contra h; push Not at h
+    exact v.ne_top' (ValuationSubring.toSubring_injective (top_le_iff.mp fun x _ => h x))
+  obtain ⟨r, s, hs, hfrs⟩ := IsFractionRing.div_surjective (A := A) f
+  have hsP : s ∈ v.centerIdeal A hA := by
+    by_contra hsP
+    apply hf
+    have : algebraMap A F r / algebraMap A F s ∈ v.toValuationSubring :=
+      div_mem_of_not_mem_centerIdeal v A hA r hsP
+    rwa [hfrs] at this
+  intro hbot
+  exact (nonZeroDivisors.ne_zero hs) (Ideal.mem_bot.mp (hbot ▸ hsP))
+
+end CenterNonzero
+
+section LocalizationSubalgebra
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+  (A : Subalgebra K F) (hA : (A : Set F) ⊆ (v.toValuationSubring : Set F))
+
+@[reducible] private noncomputable def centerLocalizationSubalgebra
+  [IsFractionRing A F] :
+    Subalgebra A F :=
+  Localization.subalgebra.ofField F (v.centerIdeal A hA).primeCompl
+    (v.centerIdeal A hA).primeCompl_le_nonZeroDivisors
+
+scoped instance centerLocalizationSubalgebra_isLocalization [IsFractionRing A F] :
+    IsLocalization.AtPrime (v.centerLocalizationSubalgebra A hA) (v.centerIdeal A hA) :=
+  Localization.subalgebra.isLocalization_ofField F _ _
+
+scoped instance centerLocalizationSubalgebra_isDomain [IsFractionRing A F] :
+    IsDomain (v.centerLocalizationSubalgebra A hA) :=
+  inferInstanceAs (IsDomain (_ : Subalgebra A F))
+
+private theorem centerLocalizationSubalgebra_isDiscreteValuationRing
+    [IsDedekindDomain A] [IsFractionRing A F] :
+    IsDiscreteValuationRing (v.centerLocalizationSubalgebra A hA) :=
+  IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain A
+    (v.centerIdeal_ne_bot_of_isFractionRing A hA) _
+
+scoped instance centerLocalizationSubalgebra_isFractionRing [IsFractionRing A F] :
+    IsFractionRing (v.centerLocalizationSubalgebra A hA) F :=
+  inferInstanceAs (IsFractionRing (Localization.subalgebra.ofField F _ _) F)
+
+private theorem centerLocalizationSubalgebra_subset [IsFractionRing A F]
+  :
+    ((v.centerLocalizationSubalgebra A hA : Subalgebra A F) : Set F)
+      ⊆ (v.toValuationSubring : Set F) := by
+  intro x hx
+  obtain ⟨a, s, hs, rfl⟩ := hx
+  rw [← div_eq_mul_inv]
+  exact div_mem_of_not_mem_centerIdeal v A hA a hs
+
+private noncomputable def centerLocalizationValuationSubring
+    [IsDedekindDomain A] [IsFractionRing A F] : ValuationSubring F where
+  toSubring := (v.centerLocalizationSubalgebra A hA).toSubring
+  mem_or_inv_mem' x := by
+    have := v.centerLocalizationSubalgebra_isDiscreteValuationRing A hA
+    rcases ValuationRing.isInteger_or_isInteger (v.centerLocalizationSubalgebra A hA) x with
+      ⟨a, ha⟩ | ⟨a, ha⟩
+    · exact Or.inl (ha ▸ a.2)
+    · exact Or.inr (ha ▸ a.2)
+
+theorem coe_centerLocalizationValuationSubring [IsDedekindDomain A] [IsFractionRing A F] :
+    ((v.centerLocalizationValuationSubring A hA : ValuationSubring F) : Set F)
+      = ((v.centerLocalizationSubalgebra A hA : Subalgebra A F) : Set F) := rfl
+
+scoped instance centerLocalizationValuationSubring_isDiscreteValuationRing
+    [IsDedekindDomain A] [IsFractionRing A F] :
+    IsDiscreteValuationRing (v.centerLocalizationValuationSubring A hA) :=
+  v.centerLocalizationSubalgebra_isDiscreteValuationRing A hA
+
+private theorem centerLocalizationValuationSubring_le
+    [IsDedekindDomain A] [IsFractionRing A F] :
+    v.centerLocalizationValuationSubring A hA ≤ v.toValuationSubring :=
+  v.centerLocalizationSubalgebra_subset A hA
+
+private theorem centerLocalizationValuationSubring_eq
+    [IsDedekindDomain A] [IsFractionRing A F] :
+    v.centerLocalizationValuationSubring A hA = v.toValuationSubring :=
+  ValuationSubring.eq_of_isDiscreteValuationRing_of_le_s12
+    (v.centerLocalizationValuationSubring_le A hA) v.ne_top'
+
+theorem coe_centerLocalizationSubalgebra_eq [IsDedekindDomain A] [IsFractionRing A F] :
+    ((v.centerLocalizationSubalgebra A hA : Subalgebra A F) : Set F)
+      = (v.toValuationSubring : Set F) := by
+  rw [← coe_centerLocalizationValuationSubring]
+  exact congrArg (SetLike.coe) (v.centerLocalizationValuationSubring_eq A hA)
+
+private theorem mem_centerLocalizationSubalgebra_of_mem
+    [IsDedekindDomain A] [IsFractionRing A F]
+    (x : F) (hx : x ∈ v.toValuationSubring) :
+    x ∈ (v.centerLocalizationSubalgebra A hA : Subalgebra A F) := by
+  rw [← SetLike.mem_coe, coe_centerLocalizationSubalgebra_eq]; exact hx
+
+private theorem isLocalization_centerIdeal_of_isDedekindDomain
+    [IsDedekindDomain A] [IsFractionRing A F] :
+    letI := v.modelAlgebra A hA
+    IsLocalization.AtPrime v.toValuationSubring (v.centerIdeal A hA) := by
+  let := v.modelAlgebra A hA
+  refine (isLocalization_iff _ _).mpr ⟨?_, ?_, ?_⟩
+  · exact v.isUnit_modelInclusion_of_mem_primeCompl A hA
+  · intro x
+    have hxP : (x : F) ∈ (v.centerLocalizationSubalgebra A hA : Subalgebra A F) :=
+      v.mem_centerLocalizationSubalgebra_of_mem A hA (x : F) x.2
+    obtain ⟨a, s, hs, hxeq⟩ := hxP
+    refine ⟨⟨a, ⟨s, hs⟩⟩, Subtype.ext ?_⟩
+    change (x : F) * ((s : A) : F) = ((a : A) : F)
+    have halg_s : algebraMap A F s = ((s : A) : F) := rfl
+    have halg_a : algebraMap A F a = ((a : A) : F) := rfl
+    have hs0 : algebraMap A F s ≠ 0 := by
+      intro hF
+      have hsne : s ≠ 0 := fun h => (h ▸ hs) (Ideal.zero_mem _)
+      exact hsne (Subtype.ext (p := (· ∈ A)) (halg_s ▸ hF))
+    rw [← halg_s, ← halg_a, hxeq, mul_assoc, inv_mul_cancel₀ hs0, mul_one]
+  · intro a₁ a₂ h
+    have hF : (a₁ : F) = (a₂ : F) :=
+      congrArg (Subtype.val : v.toValuationSubring → F) h
+    exact ⟨1, by rw [show a₁ = a₂ from Subtype.ext hF]⟩
+
+end LocalizationSubalgebra
+end Place
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def ValSubringDedekindFractionModel : Prop :=
+  ∀ v : Place K F,
+    ∃ (A : Subalgebra K F) (_ : (A : Set F) ⊆ (v.toValuationSubring : Set F)),
+      Algebra.FiniteType K A ∧ IsDedekindDomain A ∧ IsFractionRing A F
+
+variable {K F}
+
+theorem valSubringDedekindModel_of_dedekindFractionModel
+    (hfrac : ValSubringDedekindFractionModel K F) :
+    ValSubringDedekindModel K F := fun v => by
+  obtain ⟨A, hA, hft, hded, hfracA⟩ := hfrac v
+  exact ⟨A, hA, hft, v.isLocalization_centerIdeal_of_isDedekindDomain A hA⟩
+
+end AlgebraicCurve
+
+open IsLocalRing
+
+namespace AlgebraicCurve
+
+namespace Place
+
+section IntegrallyClosed
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem isIntegrallyClosed_toValuationSubring :
+    IsIntegrallyClosed v.toValuationSubring := inferInstance
+
+private theorem mem_valuationSubring_of_isIntegral {x : F}
+    (hx : IsIntegral v.toValuationSubring x) :
+    x ∈ v.toValuationSubring := by
+  obtain ⟨y, hy⟩ := (isIntegrallyClosed_iff F).mp (v.isIntegrallyClosed_toValuationSubring) hx
+  exact hy ▸ y.2
+
+variable (B : Subalgebra K F) (hB : (B : Set F) ⊆ (v.toValuationSubring : Set F))
+
+include hB in
+private theorem modelAlgebra_isScalarTower_top :
+    letI := v.modelAlgebra B hB
+    IsScalarTower B v.toValuationSubring F := by
+  let := v.modelAlgebra B hB
+  refine IsScalarTower.of_algebraMap_eq fun b => ?_
+  rfl
+
+include hB in
+private theorem mem_valuationSubring_of_isIntegral_subalgebra {x : F}
+    (hx : IsIntegral B x) :
+    x ∈ v.toValuationSubring := by
+  let := v.modelAlgebra B hB
+  have := v.modelAlgebra_isScalarTower_top B hB
+  exact v.mem_valuationSubring_of_isIntegral (hx.tower_top (A := v.toValuationSubring))
+
+include hB in
+private theorem integralClosure_subset_valuationSubring :
+    ((integralClosure B F : Subalgebra B F) : Set F)
+      ⊆ (v.toValuationSubring : Set F) := fun _ hx =>
+  v.mem_valuationSubring_of_isIntegral_subalgebra B hB hx
+
+end IntegrallyClosed
+end Place
+
+section TwoCharts
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def IsAffineChart (A : Subalgebra K F) : Prop :=
+  Algebra.FiniteType K A ∧ IsDedekindDomain A ∧ IsFractionRing A F
+
+def ValSubringTwoAffineCharts : Prop :=
+  ∃ A₀ A₁ : Subalgebra K F, IsAffineChart K F A₀ ∧ IsAffineChart K F A₁
+    ∧ ∀ v : Place K F, (A₀ : Set F) ⊆ (v.toValuationSubring : Set F)
+        ∨ (A₁ : Set F) ⊆ (v.toValuationSubring : Set F)
+
+variable {K F}
+
+theorem valSubringDedekindFractionModel_of_twoAffineCharts
+    (h : ValSubringTwoAffineCharts K F) :
+    ValSubringDedekindFractionModel K F := fun v => by
+  obtain ⟨A₀, A₁, ⟨hft₀, hded₀, hfrac₀⟩, ⟨hft₁, hded₁, hfrac₁⟩, hcover⟩ := h
+  rcases hcover v with h₀ | h₁
+  · exact ⟨A₀, h₀, hft₀, hded₀, hfrac₀⟩
+  · exact ⟨A₁, h₁, hft₁, hded₁, hfrac₁⟩
+
+theorem valSubringDedekindModel_of_twoAffineCharts
+    (h : ValSubringTwoAffineCharts K F) :
+    ValSubringDedekindModel K F :=
+  valSubringDedekindModel_of_dedekindFractionModel
+    (valSubringDedekindFractionModel_of_twoAffineCharts h)
+
+end TwoCharts
+
+section Gates
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+@[reducible] private noncomputable def toKSubalgebra (v : Place K F) :
+    Subalgebra K F where
+  __ := v.toValuationSubring.toSubring
+  algebraMap_mem' c := v.algebraMap_mem' c
+
+private theorem coe_toKSubalgebra (v : Place K F) :
+    (v.toKSubalgebra : Set F) = (v.toValuationSubring : Set F) := rfl
+
+end Place
+
+theorem gate_adjoin_subset_valuationSubring_of_mem (v : Place K F) {t : F}
+    (ht : t ∈ v.toValuationSubring) :
+    ((Algebra.adjoin K {t} : Subalgebra K F) : Set F)
+      ⊆ (v.toValuationSubring : Set F) := by
+  rw [← v.coe_toKSubalgebra]
+  exact Algebra.adjoin_le (Set.singleton_subset_iff.mpr ht)
+
+end Gates
+end AlgebraicCurve
+
+open IsLocalRing IntermediateField IntermediateField.algebraAdjoinAdjoin
+
+namespace AlgebraicCurve
+
+section AdjoinRingProperties
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+private theorem _root_.Transcendental.isPrincipalIdealRing_adjoin_s12 {t : F}
+    (ht : Transcendental K t) :
+    IsPrincipalIdealRing ↥(Algebra.adjoin K ({t} : Set F)) :=
+  IsPrincipalIdealRing.of_surjective
+    (Polynomial.algEquivOfTranscendental K t ht).toRingHom
+    (Polynomial.algEquivOfTranscendental K t ht).surjective
+
+private theorem _root_.Transcendental.isDedekindDomain_adjoin_s12 {t : F} (ht : Transcendental K t)
+    :
+    IsDedekindDomain ↥(Algebra.adjoin K ({t} : Set F)) :=
+  haveI := ht.isPrincipalIdealRing_adjoin_s12
+  inferInstance
+
+private theorem _root_.Transcendental.isIntegrallyClosed_adjoin_s12 {t : F}
+    (ht : Transcendental K t) :
+    IsIntegrallyClosed ↥(Algebra.adjoin K ({t} : Set F)) :=
+  haveI := ht.isDedekindDomain_adjoin_s12
+  inferInstance
+
+private theorem _root_.Transcendental.isNoetherianRing_adjoin_s12 {t : F} (ht : Transcendental K t)
+    :
+    IsNoetherianRing ↥(Algebra.adjoin K ({t} : Set F)) :=
+  haveI := ht.isPrincipalIdealRing_adjoin_s12
+  inferInstance
+
+private theorem _root_.Algebra.FiniteType.adjoin_singleton_s12 (t : F) :
+    Algebra.FiniteType K ↥(Algebra.adjoin K ({t} : Set F)) :=
+  Algebra.FiniteType.adjoin_of_finite (Set.finite_singleton t)
+
+private theorem _root_.Transcendental.inv_s12 {t : F} (ht : Transcendental K t) :
+    Transcendental K t⁻¹ := by
+  rw [Transcendental, IsAlgebraic.inv_iff]; exact ht
+
+end AdjoinRingProperties
+
+section TranscendentalChart
+
+variable (K : Type*) {F : Type*} [Field K] [Field F] [Algebra K F]
+
+@[reducible] noncomputable def transcendentalChart (t : F) : Subalgebra K F :=
+  (integralClosure (Algebra.adjoin K ({t} : Set F)) F).restrictScalars K
+
+theorem coe_transcendentalChart (t : F) :
+    (transcendentalChart K t : Set F)
+      = ((integralClosure (Algebra.adjoin K ({t} : Set F)) F : Subalgebra _ F) : Set F) :=
+  rfl
+
+variable {K}
+
+theorem transcendentalChart_subset_valuationSubring_of_mem (v : Place K F)
+    {t : F} (ht : t ∈ v.toValuationSubring) :
+    (transcendentalChart K t : Set F) ⊆ (v.toValuationSubring : Set F) := by
+  rw [coe_transcendentalChart]
+  exact v.integralClosure_subset_valuationSubring _
+    (gate_adjoin_subset_valuationSubring_of_mem v ht)
+
+theorem transcendentalChart_subset_or_inv_subset (v : Place K F) (t : F) :
+    (transcendentalChart K t : Set F) ⊆ (v.toValuationSubring : Set F)
+      ∨ (transcendentalChart K t⁻¹ : Set F) ⊆ (v.toValuationSubring : Set F) :=
+  (v.toValuationSubring.mem_or_inv_mem t).imp
+    (transcendentalChart_subset_valuationSubring_of_mem v)
+    (transcendentalChart_subset_valuationSubring_of_mem v)
+
+end TranscendentalChart
+
+section IsAffineChartEngine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+section
+
+variable (B : Subalgebra K F)
+
+theorem isScalarTower_integralClosure_subalgebra :
+    IsScalarTower K B ↥(integralClosure B F) := by
+  refine IsScalarTower.of_algebraMap_eq fun c => ?_
+  exact Subtype.ext rfl
+
+theorem finiteType_integralClosure_of_moduleFinite (hft : Algebra.FiniteType K B)
+    (hfin : Module.Finite B ↥(integralClosure B F)) :
+    Algebra.FiniteType K ↥(integralClosure B F) :=
+  haveI := isScalarTower_integralClosure_subalgebra B
+  haveI := hfin
+  Algebra.FiniteType.trans (S := B) hft inferInstance
+
+end
+
+theorem isDedekindDomain_integralClosure_adjoin {t : F} (ht : Transcendental K t)
+    [FiniteDimensional K⟮t⟯ F] [Algebra.IsSeparable K⟮t⟯ F] :
+    IsDedekindDomain ↥(integralClosure (Algebra.adjoin K ({t} : Set F)) F) := by
+  have := ht.isDedekindDomain_adjoin_s12
+  exact integralClosure.isDedekindDomain ↥(Algebra.adjoin K ({t} : Set F)) ↥(K⟮t⟯) F
+
+theorem isFractionRing_integralClosure_adjoin (t : F) [FiniteDimensional K⟮t⟯ F] :
+    IsFractionRing ↥(integralClosure (Algebra.adjoin K ({t} : Set F)) F) F :=
+  integralClosure.isFractionRing_of_finite_extension
+    (A := ↥(Algebra.adjoin K ({t} : Set F))) ↥(K⟮t⟯) F
+
+theorem moduleFinite_integralClosure_adjoin {t : F} (ht : Transcendental K t)
+    [FiniteDimensional K⟮t⟯ F] [Algebra.IsSeparable K⟮t⟯ F] :
+    Module.Finite ↥(Algebra.adjoin K ({t} : Set F))
+      ↥(integralClosure (Algebra.adjoin K ({t} : Set F)) F) := by
+  have := ht.isIntegrallyClosed_adjoin_s12
+  have := ht.isNoetherianRing_adjoin_s12
+  exact IsIntegralClosure.finite (A := ↥(Algebra.adjoin K ({t} : Set F)))
+    (K := ↥(K⟮t⟯)) (L := F) (integralClosure ↥(Algebra.adjoin K ({t} : Set F)) F)
+
+theorem finiteType_integralClosure_adjoin {t : F} (ht : Transcendental K t)
+    [FiniteDimensional K⟮t⟯ F] [Algebra.IsSeparable K⟮t⟯ F] :
+    Algebra.FiniteType K ↥(integralClosure (Algebra.adjoin K ({t} : Set F)) F) :=
+  finiteType_integralClosure_of_moduleFinite (Algebra.adjoin K {t})
+    (Algebra.FiniteType.adjoin_singleton_s12 t) (moduleFinite_integralClosure_adjoin ht)
+
+theorem isAffineChart_restrictScalars_integralClosure (B : Subalgebra K F)
+    (hft : Algebra.FiniteType K ↥(integralClosure B F))
+    (hded : IsDedekindDomain ↥(integralClosure B F))
+    (hfrac : IsFractionRing ↥(integralClosure B F) F) :
+    IsAffineChart K F ((integralClosure B F).restrictScalars K) :=
+  ⟨hft, hded, hfrac⟩
+
+theorem isAffineChart_transcendentalChart {t : F} (ht : Transcendental K t)
+    [FiniteDimensional K⟮t⟯ F] [Algebra.IsSeparable K⟮t⟯ F] :
+    IsAffineChart K F (transcendentalChart K t) :=
+  isAffineChart_restrictScalars_integralClosure (Algebra.adjoin K {t})
+    (finiteType_integralClosure_adjoin ht)
+    (isDedekindDomain_integralClosure_adjoin ht)
+    (isFractionRing_integralClosure_adjoin t)
+
+end IsAffineChartEngine
+
+section SeparatingTranscendental
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def HasSeparatingTranscendental : Prop :=
+  ∃ t : F, Transcendental K t
+    ∧ FiniteDimensional K⟮t⟯ F ∧ Algebra.IsSeparable K⟮t⟯ F
+    ∧ FiniteDimensional K⟮t⁻¹⟯ F ∧ Algebra.IsSeparable K⟮t⁻¹⟯ F
+
+variable {K F}
+
+theorem valSubringTwoAffineCharts_of_hasSeparatingTranscendental
+    (h : HasSeparatingTranscendental K F) :
+    ValSubringTwoAffineCharts K F := by
+  obtain ⟨t, ht, hfin, hsep, hfin', hsep'⟩ := h
+  exact ⟨transcendentalChart K t, transcendentalChart K t⁻¹,
+    isAffineChart_transcendentalChart ht,
+    isAffineChart_transcendentalChart ht.inv_s12,
+    fun v => transcendentalChart_subset_or_inv_subset v t⟩
+
+theorem valSubringDedekindModel_of_hasSeparatingTranscendental
+    (h : HasSeparatingTranscendental K F) :
+    ValSubringDedekindModel K F :=
+  valSubringDedekindModel_of_twoAffineCharts
+    (valSubringTwoAffineCharts_of_hasSeparatingTranscendental h)
+
+end SeparatingTranscendental
+end AlgebraicCurve
+
+open IntermediateField
+
+namespace IntermediateField
+open IntermediateField
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem adjoin_simple_inv_s12 (t : F) : K⟮t⁻¹⟯ = K⟮t⟯ := by
+  refine le_antisymm (adjoin_simple_le_iff.mpr ?_) (adjoin_simple_le_iff.mpr ?_)
+  · exact inv_mem (mem_adjoin_simple_self K t)
+  · have h : (t⁻¹)⁻¹ ∈ (K⟮t⁻¹⟯ : IntermediateField K F) :=
+      inv_mem (mem_adjoin_simple_self K t⁻¹)
+    rwa [inv_inv] at h
+
+theorem algebraMap_comp_equivOfEq_s12 {S T : IntermediateField K F} (h : S = T) :
+    (algebraMap T F).comp ((IntermediateField.equivOfEq h).toRingEquiv : S →+* T)
+      = ((RingEquiv.refl F : F ≃+* F) : F →+* F).comp (algebraMap S F) := by
+  ext x; rfl
+
+theorem finiteDimensional_of_eq_s12 {S T : IntermediateField K F} (h : S = T)
+    [FiniteDimensional ↥S F] : FiniteDimensional ↥T F :=
+  Module.Finite.of_equiv_equiv (IntermediateField.equivOfEq h).toRingEquiv (RingEquiv.refl F)
+    (algebraMap_comp_equivOfEq_s12 h)
+
+theorem isSeparable_of_eq_s12 {S T : IntermediateField K F} (h : S = T)
+    [Algebra.IsSeparable ↥S F] : Algebra.IsSeparable ↥T F :=
+  Algebra.IsSeparable.of_equiv_equiv (IntermediateField.equivOfEq h).toRingEquiv
+    (RingEquiv.refl F) (algebraMap_comp_equivOfEq_s12 h)
+
+theorem finiteDimensional_adjoin_inv_s12 (t : F) [FiniteDimensional K⟮t⟯ F] :
+    FiniteDimensional K⟮t⁻¹⟯ F :=
+  finiteDimensional_of_eq_s12 (adjoin_simple_inv_s12 t).symm
+
+theorem isSeparable_adjoin_inv_s12 (t : F) [Algebra.IsSeparable K⟮t⟯ F] :
+    Algebra.IsSeparable K⟮t⁻¹⟯ F :=
+  isSeparable_of_eq_s12 (adjoin_simple_inv_s12 t).symm
+
+end IntermediateField
+
+open IntermediateField
+
+namespace AlgebraicCurve
+
+section AbstractEngine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+open scoped AlgebraicCurve.Place in
+theorem Place.dCoordGenerates_of_valSubringKaehlerSpanTop
+    (hspan : ValSubringKaehlerSpanTop K F) (v : Place K F) :
+    v.DCoordGenerates := by
+  constructor
+  rw [eq_top_iff,
+    ← KaehlerDifferential.span_range_map_derivation_of_isLocalization (R := K)
+      (S := v.toValuationSubring) (T := F) (nonZeroDivisors v.toValuationSubring),
+    Submodule.span_le]
+  rintro _ ⟨f, rfl⟩
+  have hDf : KaehlerDifferential.D K v.toValuationSubring f
+      ∈ (⊤ : Submodule v.toValuationSubring Ω[v.toValuationSubring⁄K]) := Submodule.mem_top
+  rw [← hspan v] at hDf
+  have hmap : (KaehlerDifferential.map K K v.toValuationSubring F ∘
+        KaehlerDifferential.D K v.toValuationSubring) f
+      ∈ Submodule.map (KaehlerDifferential.map K K v.toValuationSubring F)
+        (Submodule.span v.toValuationSubring _) :=
+    Submodule.mem_map_of_mem hDf
+  rw [Submodule.map_span, Set.image_singleton,
+    v.kaehlerMap_subring_D_uniformizer] at hmap
+  exact Submodule.span_le_restrictScalars v.toValuationSubring F {v.dCoord} hmap
+
+end AbstractEngine
+end AlgebraicCurve
+
+noncomputable section
+
+
+namespace AlgebraicCurve
+
+section PerPlaceSupply
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+open scoped AlgebraicCurve.Place in
+private theorem
+  isSeparable_residueField_of_perfectField_of_finiteResidue
+    [PerfectField K] (v : Place K F) [v.FiniteResidue] :
+    Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring) := by
+  have : Module.Finite K (IsLocalRing.ResidueField v.toValuationSubring) :=
+    Place.FiniteResidue.finite
+  have : Algebra.IsAlgebraic K (IsLocalRing.ResidueField v.toValuationSubring) :=
+    Algebra.IsAlgebraic.of_finite K _
+  exact Algebra.IsAlgebraic.isSeparable_of_perfectField
+
+end Place
+theorem isSeparable_residueField_forall_of_perfectField
+    [PerfectField K] [∀ v : Place K F, v.FiniteResidue] :
+    ∀ v : Place K F,
+      Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring) :=
+  fun v => v.isSeparable_residueField_of_perfectField_of_finiteResidue
+
+end PerPlaceSupply
+
+section IsSeparableEngines
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem valSubringKaehlerSpanTop_of_kaehlerFinite_of_isSeparable
+    [∀ v : Place K F, Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring)]
+    (hfin : ValSubringKaehlerFinite K F) :
+    ValSubringKaehlerSpanTop K F :=
+  valSubringKaehlerSpanTop_of_polynomialFormallyUnramified
+    (valSubringPolynomialFormallyUnramified_of_kaehlerFinite_of_isSeparable hfin)
+
+open scoped AlgebraicCurve.Place in
+theorem Place.dCoordGenerates_of_valSubringKaehlerFinite_of_isSeparable
+    [∀ v : Place K F, Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring)]
+    (hfin : ValSubringKaehlerFinite K F) (v : Place K F) :
+    v.DCoordGenerates :=
+  Place.dCoordGenerates_of_valSubringKaehlerSpanTop
+    (valSubringKaehlerSpanTop_of_kaehlerFinite_of_isSeparable hfin) v
+
+end IsSeparableEngines
+
+section PerfectFieldEngines
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+open scoped AlgebraicCurve.Place in
+theorem Place.dCoordGenerates_of_valSubringKaehlerFinite_of_perfectField
+    [PerfectField K] [∀ v : Place K F, v.FiniteResidue]
+    (hfin : ValSubringKaehlerFinite K F) (v : Place K F) :
+    v.DCoordGenerates :=
+  haveI : ∀ v : Place K F,
+      Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring) :=
+    isSeparable_residueField_forall_of_perfectField
+  Place.dCoordGenerates_of_valSubringKaehlerFinite_of_isSeparable hfin v
+
+end PerfectFieldEngines
+end AlgebraicCurve
+
+section
+
+namespace AlgebraicCurve
+
+section S12ChainWires
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+open scoped AlgebraicCurve.Place in
+theorem Place.dCoordGenerates_of_valSubringFiniteTypeModel_of_perfectField
+    [PerfectField K] [∀ v : Place K F, v.FiniteResidue]
+    (hmodel : ValSubringFiniteTypeModel K F) (v : Place K F) :
+    v.DCoordGenerates :=
+  Place.dCoordGenerates_of_valSubringKaehlerFinite_of_perfectField
+    (valSubringKaehlerFinite_of_finiteTypeModel hmodel) v
+
+open scoped AlgebraicCurve.Place in
+theorem Place.dCoordGenerates_of_valSubringDedekindModel_of_perfectField
+    [PerfectField K] [∀ v : Place K F, v.FiniteResidue]
+    (hmodel : ValSubringDedekindModel K F) (v : Place K F) :
+    v.DCoordGenerates :=
+  Place.dCoordGenerates_of_valSubringFiniteTypeModel_of_perfectField
+    (valSubringFiniteTypeModel_of_dedekindModel hmodel) v
+
+open scoped AlgebraicCurve.Place in
+theorem Place.dCoordGenerates_of_hasSeparatingTranscendental_of_perfectField
+    [PerfectField K] [∀ v : Place K F, v.FiniteResidue]
+    (hsep : HasSeparatingTranscendental K F) (v : Place K F) :
+    v.DCoordGenerates :=
+  Place.dCoordGenerates_of_valSubringDedekindModel_of_perfectField
+    (valSubringDedekindModel_of_hasSeparatingTranscendental hsep) v
+
+open IntermediateField in
+theorem hasSeparatingTranscendental_of_isCurveOver_of_perfectField
+    [PerfectField K] [Algebra.EssFiniteType K F] [IsCurveOver K F] :
+    HasSeparatingTranscendental K F := by
+  obtain ⟨t, htr, hfd, hsep⟩ := IsCurveOver.exists_separating_transcendental (K := K) (F := F)
+  exact ⟨t, htr, hfd, hsep,
+    IntermediateField.finiteDimensional_adjoin_inv_s12 t,
+    IntermediateField.isSeparable_adjoin_inv_s12 t⟩
+
+end S12ChainWires
+end AlgebraicCurve
+end
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [PerfectField K] [Algebra.EssFiniteType K F] [AlgebraicCurve.IsCurveOver K F] :
+    ∀ v : AlgebraicCurve.Place K F, v.DCoordGenerates := by
+  exact fun v => AlgebraicCurve.Place.dCoordGenerates_of_hasSeparatingTranscendental_of_perfectField
+    (AlgebraicCurve.hasSeparatingTranscendental_of_isCurveOver_of_perfectField (K := K) (F := F)) v
+
+end
+
+end privateSection
+
+public section publicSection
+
+namespace AlgebraicCurve
+theorem dCoordGenerates_of_isCurveOver {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [PerfectField K] [Algebra.EssFiniteType K F] [IsCurveOver K F] :
+    ∀ v : Place K F, v.DCoordGenerates :=
+  solution
+
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_degree_canonicalDivisor_eq_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_degree_canonicalDivisor_eq_of_isAlgClosed.lean
new file mode 100644
index 0000000000..9049ed2fcb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_degree_canonicalDivisor_eq_of_isAlgClosed.lean
@@ -0,0 +1,125 @@
+/-
+Based on Prove2Me node AlgebraicCurve.degree_canonicalDivisor_eq_of_isAlgClosed
+(1628ca08-ae66-54fc-a113-0bb819e7c43f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c7325ff5-eb67-5a4c-8ea8-d2d4f45b0dbd
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_LocalResidue
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_constantsAreBase_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_degree_canonicalDivisor_eq_of_riemannRoch
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree of a canonical divisor is 2g-2 over ̄ K
+
+Theorem statement: `AlgebraicCurve.degree_canonicalDivisor_eq_of_isAlgClosed`
+(`1628ca08-ae66-54fc-a113-0bb819e7c43f`), by Claude, 2026-09-05.
+
+Proof: submission `c7325ff5-eb67-5a4c-8ea8-d2d4f45b0dbd`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field and $F$ a field extension of $K$ which is an algebraic
+function field in the sense encoded by the ambient hypotheses: $F$ is an $K$-algebra which is also
+an algebra over $\mathrm{RatFunc}\,K$ compatibly with $K$ (scalar tower), integral, module-finite
+and finite-dimensional over $\mathrm{RatFunc}\,K$ and separable over it; the modules $\Omega[F/K]$
+and $\Omega[\mathrm{RatFunc}\,K / K]$ are nontrivial; both $F$ and $\mathrm{RatFunc}\,K$ are curves
+over $K$, meaning every nonzero function has a divisor of its orders of degree $0$, all residue
+fields of places are finite over $K$, and the differentials are free of rank one over the function
+field; at every place of $F$ and of $\mathrm{RatFunc}\,K$ the element $v.\mathrm{dCoord}$ spans the
+differentials over the function field and the residue field is finite over $K$; every place of $F$
+carries local residue data, there is a chosen canonical such datum at each place of $F$ (killing
+$\pi^{-(n+1)}$ for $n\ge 1$), the trace $\mathrm{Algebra.trace}\,K\,v.\mathrm{ResidueField}$ is a
+nonzero $K$-linear map at every place, and every nonzero differential has an associated divisor of
+its orders of vanishing. Then for every nonzero $\omega \in \Omega[F/K]$ the divisor
+`canonicalDivisorOf hω`, whose value at a place $v$ is $v.\mathrm{ordDifferential}\,\omega$, has
+degree $\sum_v \mathrm{ord}_v(\omega)\deg v = 2g - 2$, where $g$ is [`AlgebraicCurve.genus K
+F`](def/AlgebraicCurve_CanonicalDivisor.html#L33), defined as $(\deg(\text{a canonical
+divisor})+2)/2$.
+
+This is the classical identity $\deg(K_F) = 2g-2$ for the canonical class of a curve over an
+algebraically closed base field, with the genus taken in its canonical-degree normalisation. It is
+used in the genus computations for modular function fields, notably in the Riemann–Hurwitz style
+count of ramification contributions and in the canonical-divisor degree formulas for modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_degree_canonicalDivisor_eq_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_degree_canonicalDivisor_eq_of_isAlgClosed
+
+theorem solution
+    {K F : Type*} [Field K] [IsAlgClosed K]
+    [Field F] [Algebra K F]
+    [AlgebraicCurve.HasCanonicalDivisor (K := K) (F := F)]
+    [∀ w : AlgebraicCurve.Place K F, w.DCoordGenerates]
+    [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [Algebra.IsIntegral (RatFunc K) F]
+    [AlgebraicCurve.HasLocalResidue K F]
+    [∀ w : AlgebraicCurve.Place K F, w.FiniteResidue]
+    [Nontrivial Ω[F⁄K]]
+    [AlgebraicCurve.IsCurveOver K F] [AlgebraicCurve.IsCurveOver K (RatFunc K)]
+    [∀ u : AlgebraicCurve.Place K (RatFunc K), u.FiniteResidue]
+    [AlgebraicCurve.HasCanonicalLocalResidueKStar K F]
+    [Algebra.IsSeparable (RatFunc K) F]
+    [Nontrivial Ω[(RatFunc K)⁄K]] [∀ v : AlgebraicCurve.Place K (RatFunc K), v.DCoordGenerates]
+    [FiniteDimensional (RatFunc K) F] [AlgebraicCurve.HasSeparableResidue K F]
+    {ω : Ω[F⁄K]} (hω : ω ≠ 0) :
+    AlgebraicCurve.Divisor.degree (AlgebraicCurve.canonicalDivisorOf hω) = 2 * (AlgebraicCurve.genus
+        K F : ℤ) - 2 := by
+  classical
+  exact
+    AlgebraicCurve.degree_canonicalDivisor_eq_of_riemannRoch
+        AlgebraicCurve.functionFieldRiemannRoch_of_isAlgClosed
+        (AlgebraicCurve.constantsAreBase_of_isAlgClosed K F) hω
+
+end S_AlgebraicCurve_degree_canonicalDivisor_eq_of_isAlgClosed
+end P2MW
+export P2MW.S_AlgebraicCurve_degree_canonicalDivisor_eq_of_isAlgClosed (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.degree_canonicalDivisor_eq_of_isAlgClosed
+    {K F : Type*} [Field K] [IsAlgClosed K]
+    [Field F] [Algebra K F]
+    [AlgebraicCurve.HasCanonicalDivisor (K := K) (F := F)]
+    [∀ w : AlgebraicCurve.Place K F, w.DCoordGenerates]
+    [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [Algebra.IsIntegral (RatFunc K) F]
+    [AlgebraicCurve.HasLocalResidue K F]
+    [∀ w : AlgebraicCurve.Place K F, w.FiniteResidue]
+    [Nontrivial Ω[F⁄K]]
+    [AlgebraicCurve.IsCurveOver K F] [AlgebraicCurve.IsCurveOver K (RatFunc K)]
+    [∀ u : AlgebraicCurve.Place K (RatFunc K), u.FiniteResidue]
+    [AlgebraicCurve.HasCanonicalLocalResidueKStar K F]
+    [Algebra.IsSeparable (RatFunc K) F]
+    [Nontrivial Ω[(RatFunc K)⁄K]] [∀ v : AlgebraicCurve.Place K (RatFunc K), v.DCoordGenerates]
+    [FiniteDimensional (RatFunc K) F] [AlgebraicCurve.HasSeparableResidue K F]
+    {ω : Ω[F⁄K]} (hω : ω ≠ 0) :
+    AlgebraicCurve.Divisor.degree (AlgebraicCurve.canonicalDivisorOf hω) = 2 * (AlgebraicCurve.genus
+        K F : ℤ) - 2 := by
+  classical
+  exact
+    solution hω
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_degree_canonicalDivisor_eq_of_riemannRoch.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_degree_canonicalDivisor_eq_of_riemannRoch.lean
new file mode 100644
index 0000000000..19c0adf678
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_degree_canonicalDivisor_eq_of_riemannRoch.lean
@@ -0,0 +1,83 @@
+/-
+Based on Prove2Me node AlgebraicCurve.degree_canonicalDivisor_eq_of_riemannRoch
+(9dfc4df1-81fe-5828-85e4-c502ad6ac953) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a9a86fc1-c645-5192-a794-16c9c83e2717
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RiemannRochRows
+
+/-!
+# Degree of a canonical divisor is 2g-2
+
+Theorem statement: `AlgebraicCurve.degree_canonicalDivisor_eq_of_riemannRoch`
+(`9dfc4df1-81fe-5828-85e4-c502ad6ac953`), by Claude, 2026-09-05.
+
+Proof: submission `a9a86fc1-c645-5192-a794-16c9c83e2717`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and assume `IsCurveOver K F`: every nonzero $f \in
+F$ has a divisor whose coefficient at each place $v$ is $v.\mathrm{ord}\,f$ and whose degree is $0$,
+every place has residue field finite over $K$, and the module of Kähler differentials $\Omega[F⁄K]$
+is free of rank one over $F$. Assume further `HasCanonicalDivisor`, i.e. every nonzero $\omega \in
+\Omega[F⁄K]$ admits a divisor $D$ with $D v = v.\mathrm{ordDifferential}\,\omega =
+v.\mathrm{ord}(v.\mathrm{differentialCoeff}\,\omega)$ for all places $v$, and that for each place
+$v$ the differential $d(\text{uniformizer of } v)$ spans $\Omega[F⁄K]$ over $F$. Two hypotheses are
+imposed as propositions: `FunctionFieldRiemannRoch K F`, asserting that for every nonzero
+differential $\omega$ and every divisor $D$ one has $\mathrm{ell}(D) -
+\mathrm{ell}(\mathrm{canonicalDivisorOf}\,\omega - D) = \deg D + 1 - g$, where $g$ is `genus K F`;
+and `ConstantsAreBase K F`, asserting that the Riemann–Roch space of the zero divisor is exactly the
+image of $K$ in $F$. Then for any nonzero $\omega \in \Omega[F⁄K]$, the degree of
+`canonicalDivisorOf hω` (the sum over places of its coefficient times the residue degree
+$v.\mathrm{deg}$) equals $2g - 2$, where $g$ is `genus K F`, defined as $(\deg(\text{canonical
+divisor of some chosen nonzero differential}) + 2).\mathrm{toNat}/2$.
+
+This is the standard corollary of Riemann–Roch computing the degree of a canonical divisor, here
+also expressing that the canonical-divisor definition of the genus is consistent with the
+Riemann–Roch formula and independent of the chosen nonzero differential. It is used downstream in
+the function-field package, for instance in the versions of the degree and dimension formulas over
+algebraically closed constant fields and in genus computations for splitting fields.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_degree_canonicalDivisor_eq_of_riemannRoch.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open AlgebraicCurve KaehlerDifferential
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F]
+    [HasCanonicalDivisor (K := K) (F := F)] [∀ v : Place K F, v.DCoordGenerates]
+    (hRR : FunctionFieldRiemannRoch K F) (hC : ConstantsAreBase K F) {ω : Ω[F⁄K]} (hω : ω ≠ 0) :
+    Divisor.degree (canonicalDivisorOf hω) = 2 * (genus K F : ℤ) - 2 := by
+  have h0 := hRR hω 0
+  rw [map_zero, ell_zero_eq_one_of_constantsAreBase hC, sub_zero] at h0
+  push_cast at h0
+  have hW := hRR hω (canonicalDivisorOf hω)
+  rw [sub_self, ell_zero_eq_one_of_constantsAreBase hC] at hW
+  push_cast at hW
+  linarith
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve KaehlerDifferential
+theorem AlgebraicCurve.degree_canonicalDivisor_eq_of_riemannRoch {K F : Type*} [Field K] [Field F]
+    [Algebra K F] [IsCurveOver K F] [HasCanonicalDivisor (K := K) (F := F)]
+    [∀ v : Place K F, v.DCoordGenerates] (hRR : FunctionFieldRiemannRoch K F)
+    (hC : ConstantsAreBase K F) {ω : Ω[F⁄K]} (hω : ω ≠ 0) :
+    Divisor.degree (canonicalDivisorOf hω) = 2 * (genus K F : ℤ) - 2 := _root_.solution hRR hC hω
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_degree_poleDivisor_eq_finrank_adjoin_of_isAlgClosed_of_transcendental.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_degree_poleDivisor_eq_finrank_adjoin_of_isAlgClosed_of_transcendental.lean
new file mode 100644
index 0000000000..b057940976
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_degree_poleDivisor_eq_finrank_adjoin_of_isAlgClosed_of_transcendental.lean
@@ -0,0 +1,99 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.degree_poleDivisor_eq_finrank_adjoin_of_isAlgClosed_of_transcendental
+(18dcfd3c-c55b-56e7-b305-233aea765b0a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 419acd1f-06d4-5020-9ab6-e2f9276ad4df
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_finrank_adjoin_of_eq_max_neg_ord
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_constantsAreBase_of_isAlgClosed_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_isAlgClosed_of_transcendental
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree of the pole divisor of x equals [F:K(x)]
+
+Theorem statement:
+`AlgebraicCurve.degree_poleDivisor_eq_finrank_adjoin_of_isAlgClosed_of_transcendental`
+(`18dcfd3c-c55b-56e7-b305-233aea765b0a`), by Claude, 2026-09-05.
+
+Proof: submission `419acd1f-06d4-5020-9ab6-e2f9276ad4df`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field and $F$ a field equipped with a $K$-algebra structure. Let
+$x \in F$ be transcendental over $K$, and assume $F$ is finite-dimensional as a module over the
+intermediate field $K(x) =$ `IntermediateField.adjoin K {x}`. Let $D$ be a divisor of $F/K$, that
+is, a finitely supported integer-valued function on the type `Place K F` of places, a place being a
+valuation subring of $F$ that contains the image of $K$ under the structure map, is not all of $F$,
+and is a principal ideal ring. Suppose $D$ is the pole divisor of $x$, in the sense that for every
+place $v$ one has $D(v) = \max(0, -\operatorname{ord}_v x)$, where $\operatorname{ord}_v$ is minus
+the logarithm of the $\mathbb{Z}^{m0}$-valued valuation attached to $v$ through the corresponding
+height-one prime. Then the degree of $D$, namely the sum $\sum_v D(v)\cdot \deg v$ of its
+coefficients weighted by the degrees of the places, equals the image in $\mathbb{Z}$ of
+$\operatorname{finrank}_{K(x)} F$.
+
+This is the classical statement that the pole divisor $(x)_\infty$ of a non-constant function $x$
+has degree $[F:K(x)]$, here in the form where the constant field is algebraically closed. It is the
+degree-counting input for several later results on genus bounds and on reductions of curves, which
+invoke it to convert a field degree into a divisor degree.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_degree_poleDivisor_eq_finrank_adjoin_of_isAlgClosed_of_transcendental.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_6c405002
+
+
+open AlgebraicCurve
+
+theorem solution
+    {K F : Type*} [Field K] [IsAlgClosed K] [Field F] [Algebra K F]
+    (x : F) (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    (D : Divisor K F) (hD : ∀ v : Place K F, D v = max 0 (-v.ord x)) :
+    Divisor.degree D = (Module.finrank (IntermediateField.adjoin K ({x} : Set F)) F : ℤ) := by
+  have : IsCurveOver K F := isCurveOver_of_isAlgClosed_of_transcendental x hx
+  have hcab : ConstantsAreBase K F := constantsAreBase_of_isAlgClosed_of_transcendental x hx
+  have hℓ0 : ell (0 : Divisor K F) = 1 := ell_zero_eq_one_of_constantsAreBase hcab
+  have : FiniteDimensional K (LSpace (0 : Divisor K F)) :=
+    FiniteDimensional.of_finrank_eq_succ (n := 0) hℓ0
+  exact Divisor.degree_eq_finrank_adjoin_of_eq_max_neg_ord x hx D hD
+
+end S_OVERLONG_6c405002
+end P2MW
+export P2MW.S_OVERLONG_6c405002
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.degree_poleDivisor_eq_finrank_adjoin_of_isAlgClosed_of_transcendental
+    {K F : Type*} [Field K] [IsAlgClosed K] [Field F] [Algebra K F]
+    (x : F) (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    (D : Divisor K F) (hD : ∀ v : Place K F, D v = max 0 (-v.ord x)) :
+    Divisor.degree D = (Module.finrank (IntermediateField.adjoin K ({x} : Set F)) F : ℤ) :=
+  solution x hx D hD
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_ell_canonicalDivisor_eq_genus_of_riemannRoch.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_ell_canonicalDivisor_eq_genus_of_riemannRoch.lean
new file mode 100644
index 0000000000..f1d452fa9b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_ell_canonicalDivisor_eq_genus_of_riemannRoch.lean
@@ -0,0 +1,91 @@
+/-
+Based on Prove2Me node AlgebraicCurve.ell_canonicalDivisor_eq_genus_of_riemannRoch
+(6490df83-3ba6-5721-9899-b194612e7873) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1b046a38-7dac-5a77-b3dc-a29f99602a17
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RiemannRochRows
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# ℓ of a canonical divisor equals the genus
+
+Theorem statement: `AlgebraicCurve.ell_canonicalDivisor_eq_genus_of_riemannRoch`
+(`6490df83-3ba6-5721-9899-b194612e7873`), by Claude, 2026-09-05.
+
+Proof: submission `1b046a38-7dac-5a77-b3dc-a29f99602a17`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and assume `IsCurveOver K F`: every nonzero $f \in
+F$ has a principal divisor, i.e. a finitely supported function on the places `Place K F` of $F/K$
+whose value at $v$ is $\operatorname{ord}_v(f)$ and whose degree is $0$; each place has residue
+field finite over $K$; and $\Omega_{F/K}$ is free of rank $1$ over $F$. Assume
+`HasCanonicalDivisor`: for every nonzero $\omega \in \Omega_{F/K}$ there is a divisor whose value at
+each place $v$ is $v.\mathrm{ordDifferential}\,\omega = \operatorname{ord}_v$ of the differential
+coefficient of $\omega$ at $v$; `canonicalDivisorOf` selects such a divisor. Assume further that for
+each place $v$ the differential $d(\pi_v)$ of a uniformiser spans $\Omega_{F/K}$ over $F$. Two
+further hypotheses are assumed: `FunctionFieldRiemannRoch K F`, i.e. $\ell(D) -
+\ell(\mathrm{canonicalDivisorOf}\,h_\omega - D) = \deg D + 1 - g$ for every nonzero differential and
+every divisor $D$, where $\ell(D)$ is the $K$-dimension of the Riemann–Roch space of $D$ and $g$ is
+`genus K F`, defined as $(\deg(\text{a canonical divisor}) + 2)/2$ truncated to $\mathbb{N}$; and
+`ConstantsAreBase K F`, i.e. the Riemann–Roch space of the zero divisor is exactly the image of $K$
+in $F$. Then for every nonzero $\omega \in \Omega_{F/K}$ one has
+$\ell(\mathrm{canonicalDivisorOf}\,h_\omega) = g$ as integers.
+
+This is the standard consequence of Riemann–Roch at $D = 0$: the space of global differentials has
+dimension equal to the genus, here in the divisor-theoretic form $\ell((\omega)) = g$ for the
+function field $F/K$ of a curve. It is used in the identification of this canonical-degree genus
+with the genus attached to the function field,
+[`AlgebraicCurve.genus_eq_genusFF`](thm.html#AlgebraicCurve.genus_eq_genusFF).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_ell_canonicalDivisor_eq_genus_of_riemannRoch.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_ell_canonicalDivisor_eq_genus_of_riemannRoch
+
+open AlgebraicCurve KaehlerDifferential
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F]
+    [HasCanonicalDivisor (K := K) (F := F)] [∀ v : Place K F, v.DCoordGenerates]
+    (hRR : FunctionFieldRiemannRoch K F) (hC : ConstantsAreBase K F) {ω : Ω[F⁄K]} (hω : ω ≠ 0) :
+    (ell (canonicalDivisorOf hω) : ℤ) = (genus K F : ℤ) := by
+  have h0 := hRR hω 0
+  rw [map_zero, ell_zero_eq_one_of_constantsAreBase hC, sub_zero] at h0
+  push_cast at h0
+  linarith
+
+end S_AlgebraicCurve_ell_canonicalDivisor_eq_genus_of_riemannRoch
+end P2MW
+export P2MW.S_AlgebraicCurve_ell_canonicalDivisor_eq_genus_of_riemannRoch (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve KaehlerDifferential
+theorem AlgebraicCurve.ell_canonicalDivisor_eq_genus_of_riemannRoch {K F : Type*} [Field K]
+    [Field F] [Algebra K F] [IsCurveOver K F] [HasCanonicalDivisor (K := K) (F := F)]
+    [∀ v : Place K F, v.DCoordGenerates] (hRR : FunctionFieldRiemannRoch K F)
+    (hC : ConstantsAreBase K F) {ω : Ω[F⁄K]} (hω : ω ≠ 0) :
+    (ell (canonicalDivisorOf hω) : ℤ) = (genus K F : ℤ) :=
+  solution hRR hC hω
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_ell_eq_degree_add_one_sub_genusFF_of_isAlgClosed_of_isSeparable.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_ell_eq_degree_add_one_sub_genusFF_of_isAlgClosed_of_isSeparable.lean
new file mode 100644
index 0000000000..6af1f8db41
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_ell_eq_degree_add_one_sub_genusFF_of_isAlgClosed_of_isSeparable.lean
@@ -0,0 +1,193 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.ell_eq_degree_add_one_sub_genusFF_of_isAlgClosed_of_isSeparable
+(1ae50d15-37c4-5a9d-9054-09cdc9f3f89e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 61f21c19-de5a-5806-bf87-90b6b7aac3dd
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+
+import Mathlib.RingTheory.Finiteness.ModuleFinitePresentation
+import Mathlib.RingTheory.PicardGroup
+import Mathlib.RingTheory.TotallySplit
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_finiteDimensional_lSpace_zero_of_constantsAreBase
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_nonempty_place_of_ratFunc_tower
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_stichtenothGenusExists_of_ratFunc_tower
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_constantsAreBase_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_dCoordGenerates_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_degree_canonicalDivisor_eq_of_riemannRoch
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_genus_eq_genusFF
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_hasCanonicalDivisor_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_instIsCurveOverRatFunc
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_lSpace_eq_bot_of_degree_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_weilDualityAdelic_of_functionFieldRiemannRoch_of_stichtenothGenusExists
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Riemann–Roch equality for deg D ≥ 2g-1
+
+Theorem statement: `AlgebraicCurve.ell_eq_degree_add_one_sub_genusFF_of_isAlgClosed_of_isSeparable`
+(`1ae50d15-37c4-5a9d-9054-09cdc9f3f89e`), by Claude, 2026-09-05.
+
+Proof: submission `61f21c19-de5a-5806-bf87-90b6b7aac3dd`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $k$ be an algebraically closed field and $F$ a field equipped with a $k$-algebra structure.
+Suppose there is an element $x \in F$ transcendental over $k$ such that $F$ is finite-dimensional
+over the intermediate field $k\langle x\rangle =$ `IntermediateField.adjoin k {x}` and separable
+over it. A place of $F/k$ is a valuation subring of $F$ containing the image of $k$, distinct from
+$F$ itself and a principal ideal ring; a divisor is a finitely supported function from places to
+$\mathbb{Z}$, and its degree is $\sum_v D(v)\,\deg v$. Write $\ell(D)$ for the $k$-dimension of the
+Riemann–Roch space $L(D)$ and $g =$ `genusFF k F` for the $k$-dimension of $H^1$ of the zero
+divisor. The assertion is: for every divisor $D$ of $F/k$ with $\deg D \ge 2g - 1$, one has, as an
+identity of integers,
+$$\ell(D) = \deg D + 1 - g.$$
+
+This is the Riemann–Roch theorem in its sharp form above the threshold $\deg D > 2g - 2$, for a
+function field in one variable over an algebraically closed constant field, stated with the
+hypotheses in the convenient shape ($x$ transcendental, $F/k(x)$ finite and separable) rather than
+as a bundle of curve-structure instances. It is the dimension-counting input used wherever effective
+divisors of large degree must be shown to have Riemann–Roch spaces of the expected size, for
+instance in the glueing and base-point-freeness arguments for semistable coverings cited downstream.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_ell_eq_degree_add_one_sub_genusFF_of_isAlgClosed_of_isSeparable.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_ell_eq_degree_add_one_sub_genusFF_of_isAlgClosed_of_isSeparable
+
+
+noncomputable section
+
+open AlgebraicCurve KaehlerDifferential
+open scoped IntermediateField
+
+namespace E97cRRExact
+
+theorem main (k : Type*) [Field k] [IsAlgClosed k] {F : Type*} [Field F] [Algebra k F]
+    (x : F) (hx : Transcendental k x)
+    (hfin : FiniteDimensional (IntermediateField.adjoin k ({x} : Set F)) F)
+    (hsep : Algebra.IsSeparable (IntermediateField.adjoin k ({x} : Set F)) F)
+    (D : Divisor k F) (hD : 2 * (genusFF k F : ℤ) - 1 ≤ D.degree) :
+    (ell D : ℤ) = D.degree + 1 - (genusFF k F : ℤ) := by
+  classical
+  have hCO : IsCurveOver k F := isCurveOver_of_transcendental hx hfin hsep
+  have : HasPrincipalDivisors k F := IsCurveOver.hasPrincipalDivisors
+  let e := RatFunc.algEquivOfTranscendental x hx
+  let : Algebra (RatFunc k) k⟮x⟯ := e.toAlgHom.toRingHom.toAlgebra
+  let : Algebra (RatFunc k) F := ((algebraMap k⟮x⟯ F).comp e.toAlgHom.toRingHom).toAlgebra
+  have : IsScalarTower (RatFunc k) k⟮x⟯ F := IsScalarTower.of_algebraMap_eq fun _ => rfl
+  have : IsScalarTower k (RatFunc k) k⟮x⟯ :=
+    IsScalarTower.of_algebraMap_eq fun r => by
+      change algebraMap k k⟮x⟯ r = e (algebraMap k (RatFunc k) r)
+      rw [AlgEquiv.commutes]
+  have : IsScalarTower k (RatFunc k) F :=
+    IsScalarTower.of_algebraMap_eq fun r => by
+      change algebraMap k F r = algebraMap k⟮x⟯ F (e (algebraMap k (RatFunc k) r))
+      rw [AlgEquiv.commutes]
+      exact IsScalarTower.algebraMap_apply k k⟮x⟯ F r
+  have : Module.Finite (RatFunc k) k⟮x⟯ :=
+    Module.Finite.of_surjective (Algebra.linearMap (RatFunc k) k⟮x⟯) e.surjective
+  have : FiniteDimensional k⟮x⟯ F := hfin
+  have : Module.Finite (RatFunc k) F := Module.Finite.trans k⟮x⟯ F
+  have : Algebra.IsIntegral (RatFunc k) F := Algebra.IsIntegral.of_finite _ _
+  have : Algebra.IsSeparable k⟮x⟯ F := hsep
+  have : Algebra.IsSeparable (RatFunc k) k⟮x⟯ :=
+    Algebra.IsSeparable.of_algHom (RatFunc k) (RatFunc k)
+      { e.symm.toRingEquiv.toRingHom with
+        commutes' := fun r => by
+          change e.symm (algebraMap (RatFunc k) k⟮x⟯ r) = r
+          exact e.symm_apply_apply r }
+  have : Algebra.IsSeparable (RatFunc k) F := Algebra.IsSeparable.trans (RatFunc k) k⟮x⟯ F
+  have : Algebra.EssFiniteType (Polynomial k) (RatFunc k) :=
+    Algebra.EssFiniteType.of_isLocalization (RatFunc k) (nonZeroDivisors (Polynomial k))
+  have : Algebra.EssFiniteType k (RatFunc k) :=
+    Algebra.EssFiniteType.comp k (Polynomial k) (RatFunc k)
+  have : Algebra.EssFiniteType (RatFunc k) F := inferInstance
+  have : Algebra.EssFiniteType k F := Algebra.EssFiniteType.comp k (RatFunc k) F
+  have hHCD : HasCanonicalDivisor (K := k) (F := F) := hasCanonicalDivisor_of_isCurveOver
+  have hDCG : ∀ w : Place k F, w.DCoordGenerates := dCoordGenerates_of_isCurveOver
+  have : IsCurveOver k (RatFunc k) := AlgebraicCurve.instIsCurveOverRatFunc k
+  have hDCGR : ∀ v : Place k (RatFunc k), v.DCoordGenerates := dCoordGenerates_of_isCurveOver
+  have hRR : FunctionFieldRiemannRoch k F := functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver
+  have hC : ConstantsAreBase k F := constantsAreBase_of_isAlgClosed k F
+  have : FiniteDimensional k (LSpace (0 : Divisor k F)) :=
+    RationalFunctionField.finiteDimensional_lSpace_zero_of_constantsAreBase k F hC
+  have : Nonempty (Place k F) := RationalFunctionField.nonempty_place_of_ratFunc_tower k F
+  have hSG : StichtenothGenusExists k F :=
+    RationalFunctionField.stichtenothGenusExists_of_ratFunc_tower k F
+  have hWDA : WeilDualityAdelic k F :=
+    weilDualityAdelic_of_functionFieldRiemannRoch_of_stichtenothGenusExists hRR hSG
+  have hg : genus k F = genusFF k F := genus_eq_genusFF hRR hWDA hC
+  obtain ⟨ω, hω⟩ := exists_ne (0 : Ω[F⁄k])
+  have hdegK : Divisor.degree (canonicalDivisorOf hω) = 2 * (genus k F : ℤ) - 2 :=
+    degree_canonicalDivisor_eq_of_riemannRoch hRR hC hω
+  have hRRD : (ell D : ℤ) - (ell (canonicalDivisorOf hω - D) : ℤ) = Divisor.degree D + 1 - (genus k
+    F : ℤ) :=
+    hRR hω D
+  have hneg : Divisor.degree (canonicalDivisorOf hω - D) < 0 := by
+    rw [map_sub, hdegK, hg]
+    have : Divisor.degree D = D.degree := rfl
+    linarith
+  have hell0 : ell (canonicalDivisorOf hω - D) = 0 := by
+    change Module.finrank k ↥(LSpace (canonicalDivisorOf hω - D)) = 0
+    rw [lSpace_eq_bot_of_degree_neg hneg, finrank_bot]
+  rw [hell0, hg, Nat.cast_zero, sub_zero] at hRRD
+  exact hRRD
+
+end E97cRRExact
+
+end
+
+open AlgebraicCurve in
+open scoped IntermediateField in
+theorem solution
+    (k : Type*) [Field k] [IsAlgClosed k] {F : Type*} [Field F] [Algebra k F]
+    (x : F) (hx : Transcendental k x)
+    (hfin : FiniteDimensional (IntermediateField.adjoin k ({x} : Set F)) F)
+    (hsep : Algebra.IsSeparable (IntermediateField.adjoin k ({x} : Set F)) F)
+    (D : Divisor k F) (hD : 2 * (genusFF k F : ℤ) - 1 ≤ D.degree) :
+    (ell D : ℤ) = D.degree + 1 - (genusFF k F : ℤ) :=
+  E97cRRExact.main k x hx hfin hsep D hD
+
+end S_AlgebraicCurve_ell_eq_degree_add_one_sub_genusFF_of_isAlgClosed_of_isSeparable
+end P2MW
+export P2MW.S_AlgebraicCurve_ell_eq_degree_add_one_sub_genusFF_of_isAlgClosed_of_isSeparable
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+open scoped IntermediateField
+theorem AlgebraicCurve.ell_eq_degree_add_one_sub_genusFF_of_isAlgClosed_of_isSeparable
+    (k : Type*) [Field k] [IsAlgClosed k] {F : Type*} [Field F] [Algebra k F]
+    (x : F) (hx : Transcendental k x)
+    (hfin : FiniteDimensional (IntermediateField.adjoin k ({x} : Set F)) F)
+    (hsep : Algebra.IsSeparable (IntermediateField.adjoin k ({x} : Set F)) F)
+    (D : Divisor k F) (hD : 2 * (genusFF k F : ℤ) - 1 ≤ D.degree) :
+    (ell D : ℤ) = D.degree + 1 - (genusFF k F : ℤ) :=
+  solution k x hx hfin hsep D hD
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg.lean
new file mode 100644
index 0000000000..fb20de40a6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg.lean
@@ -0,0 +1,140 @@
+/-
+Based on Prove2Me node AlgebraicCurve.ell_eq_zero_of_degree_neg
+(5cf85887-633a-5fb4-bf20-d6b446470e19) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d57b61c0-3f37-521f-b40a-645afe3a51a7
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Vanishing of ℓ(D) when deg D<0
+
+Theorem statement: `AlgebraicCurve.ell_eq_zero_of_degree_neg`
+(`5cf85887-633a-5fb4-bf20-d6b446470e19`), by Claude, 2026-09-05.
+
+Proof: submission `d57b61c0-3f37-521f-b40a-645afe3a51a7`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $D$ be a divisor of $F/K$, that is, a
+finitely supported function from the type of places `Place K F` (valuation subrings of $F$
+containing the image of $K$, proper in $F$, whose underlying ring is a principal ideal ring) to
+$\mathbb{Z}$. Assume `IsCurveOver K F`: every nonzero $f \in F$ admits a divisor $P$ with $P(v) =
+\operatorname{ord}_v(f)$ at every place $v$ and $\deg P = 0$; each residue field
+$v.\mathrm{ResidueField}$ is a finite $K$-module; and the module of Kähler differentials
+$\Omega_{F/K}$ is free of rank one over $F$. Here $\deg D = \sum_{v} D(v)\,[\,v.\mathrm{deg}\,]$,
+the degrees $v.\mathrm{deg}$ being natural numbers. Under the hypothesis $\deg D < 0$, the
+conclusion is that $\ell(D) = 0$, where $\ell(D)$ is by definition the $K$-dimension `Module.finrank
+K` of the Riemann–Roch space `LSpace D`, an abbreviation for Mathlib's `riemannRochSpace D`, viewed
+as a $K$-submodule of $F$.
+
+This is the standard vanishing statement for Riemann–Roch spaces of divisors of negative degree
+(Stichtenoth I.4.8), the first elementary consequence of the fact that principal divisors have
+degree zero. It is used throughout the function-field Riemann–Roch development, in particular in the
+arguments bounding the index of specialty and in the constructions of good reductions and of
+sections on Riemann–Roch opens.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_ell_eq_zero_of_degree_neg.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_ell_eq_zero_of_degree_neg
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor Divisor.degree HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor IsCurveOver LSpace ell mem_lSpace_iff_ord \
+  WeilDifferentialRankOne StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "deg ord ord_unit_smul_zpow exists_unit_mul_zpow \
+  toValuationSubring"
+p2m_open "AlgebraicCurve.Place"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+p2m_export "AlgebraicCurve.Place" "ord_nonneg_of_mem"
+p2m_export "AlgebraicCurve.Place" "mem_of_ord_nonneg"
+theorem mem_iff_ord_nonneg {f : F} (hf : f ≠ 0) :
+    f ∈ v.toValuationSubring ↔ 0 ≤ v.ord f :=
+  ⟨v.ord_nonneg_of_mem, v.mem_of_ord_nonneg hf⟩
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor Divisor.degree HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor IsCurveOver LSpace ell mem_lSpace_iff_ord \
+  WeilDifferentialRankOne StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "degree"
+end Divisor
+variable {D : Divisor K F}
+p2m_open_scoped "AlgebraicCurve.Divisor" in
+theorem Divisor.degree_nonneg_of_nonneg [IsCurveOver K F]
+    {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) : 0 ≤ Divisor.degree D := by
+  rw [Divisor.degree_eq_sum_support]
+  exact Finset.sum_nonneg fun v _ => mul_nonneg (hD v) (Int.natCast_nonneg _)
+theorem lSpace_eq_bot_of_degree_neg [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) : LSpace D = ⊥ := by
+  rw [eq_bot_iff]
+  intro f hf
+  rw [Submodule.mem_bot]
+  by_contra hf0
+  obtain ⟨P, hPord, hPdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+  have heff : ∀ v : Place K F, 0 ≤ (P + D) v := by
+    intro v
+    rw [Finsupp.add_apply, hPord]
+    rcases mem_lSpace_iff_ord.mp hf with rfl | h
+    · exact absurd rfl hf0
+    · linarith [h v]
+  have hdegPD : 0 ≤ Divisor.degree (P + D) := Divisor.degree_nonneg_of_nonneg heff
+  rw [map_add, hPdeg, zero_add] at hdegPD
+  exact absurd hdegPD (not_le.mpr hD)
+theorem ell_eq_zero_of_degree_neg_port [IsCurveOver K F] (hD : Divisor.degree D < 0) :
+    ell D = 0 := by
+  rw [ell, lSpace_eq_bot_of_degree_neg hD, finrank_bot]
+end AlgebraicCurve
+
+open _root_.AlgebraicCurve _root_.P2MW.S_AlgebraicCurve_ell_eq_zero_of_degree_neg.AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] {D : Divisor K F} [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) :
+    ell D = 0 :=
+  AlgebraicCurve.ell_eq_zero_of_degree_neg_port (K := K) (F := F) (D := D) (hD := hD)
+
+end S_AlgebraicCurve_ell_eq_zero_of_degree_neg
+end P2MW
+export P2MW.S_AlgebraicCurve_ell_eq_zero_of_degree_neg (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace AlgebraicCurve
+theorem ell_eq_zero_of_degree_neg {K F : Type*} [Field K] [Field F] [Algebra K F] {D : Divisor K F}
+    [IsCurveOver K F] (hD : Divisor.degree D < 0) :
+    ell D = 0 :=
+  solution hD
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_ell_le_degree_add_ellZero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_ell_le_degree_add_ellZero.lean
new file mode 100644
index 0000000000..2395455760
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_ell_le_degree_add_ellZero.lean
@@ -0,0 +1,391 @@
+/-
+Based on Prove2Me node AlgebraicCurve.ell_le_degree_add_ellZero
+(ad62287e-6d19-5b7f-8ae7-4545166706b0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 059b8425-82fa-5852-ba77-c57ce13c3788
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import Mathlib.RingTheory.Flat.TorsionFree
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Riemann's inequality: ℓ(D)≤deg D+ℓ(0)
+
+Theorem statement: `AlgebraicCurve.ell_le_degree_add_ellZero`
+(`ad62287e-6d19-5b7f-8ae7-4545166706b0`), by Claude, 2026-09-05.
+
+Proof: submission `059b8425-82fa-5852-ba77-c57ce13c3788`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra satisfying `IsCurveOver K F`: every nonzero $f \in
+F$ admits a divisor $D$ with $D v = \operatorname{ord}_v f$ at every place $v$ and $\deg D = 0$;
+each place has residue field finite over $K$; and $\Omega_{F/K}$ is free of rank $1$ over $F$. Here
+a place of $F/K$ is a valuation subring of $F$ containing the image of $K$, different from $F$
+itself, and a principal ideal ring, and a divisor is a finitely supported function from places to
+$\mathbb{Z}$. Let $D$ be a divisor that is effective, i.e. $0 \le D$ pointwise, and assume that the
+Riemann–Roch space of the zero divisor, namely the $K$-subspace $\{f \in F : v(f) \le 1 \text{ for
+all } v\}$ cut out by the adic valuations, is finite-dimensional over $K$. Writing $\ell(E)$ for the
+$K$-dimension of the space $\{f \in F : v(f) \le \exp(E v) \text{ for all } v\}$ and $\deg D =
+\sum_v D v \cdot \deg v$ for the degree weighted by the degrees of the places, the conclusion is the
+inequality of integers $\ell(D) \le \deg D + \ell(0)$.
+
+This is Riemann's inequality, the elementary half of the Riemann–Roch theorem for a one-variable
+function field, in effective form. It is used in the project's bound on the dimension of spaces
+attached to divisors with prescribed pole orders, and in the analysis of orders of functions on
+modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_ell_le_degree_add_ellZero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_ell_le_degree_add_ellZero
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase WeilDifferentialRankOne StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_coe_unit ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow toValuationSubring adicValuation_eq_exp_neg_ord"
+p2m_open "AlgebraicCurve.Place"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+p2m_export "AlgebraicCurve.Place" "ord_nonneg_of_mem"
+p2m_export "AlgebraicCurve.Place" "mem_of_ord_nonneg"
+theorem mem_iff_ord_nonneg {f : F} (hf : f ≠ 0) :
+    f ∈ v.toValuationSubring ↔ 0 ≤ v.ord f :=
+  ⟨v.ord_nonneg_of_mem, v.mem_of_ord_nonneg hf⟩
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase WeilDifferentialRankOne StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "degree degree_single principal smul_def"
+end Divisor
+variable {D : Divisor K F}
+p2m_open_scoped "AlgebraicCurve.Divisor" in
+theorem Divisor.degree_nonneg_of_nonneg [IsCurveOver K F]
+    {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) : 0 ≤ Divisor.degree D := by
+  rw [Divisor.degree_eq_sum_support]
+  exact Finset.sum_nonneg fun v _ => mul_nonneg (hD v) (Int.natCast_nonneg _)
+theorem lSpace_eq_bot_of_degree_neg [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) : LSpace D = ⊥ := by
+  rw [eq_bot_iff]
+  intro f hf
+  rw [Submodule.mem_bot]
+  by_contra hf0
+  obtain ⟨P, hPord, hPdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+  have heff : ∀ v : Place K F, 0 ≤ (P + D) v := by
+    intro v
+    rw [Finsupp.add_apply, hPord]
+    rcases mem_lSpace_iff_ord.mp hf with rfl | h
+    · exact absurd rfl hf0
+    · linarith [h v]
+  have hdegPD : 0 ≤ Divisor.degree (P + D) := Divisor.degree_nonneg_of_nonneg heff
+  rw [map_add, hPdeg, zero_add] at hdegPD
+  exact absurd hdegPD (not_le.mpr hD)
+end AlgebraicCurve
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase WeilDifferentialRankOne StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_coe_unit ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow toValuationSubring adicValuation_eq_exp_neg_ord"
+p2m_open "AlgebraicCurve.Place"
+
+variable (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mk_mem_maximalIdeal_iff {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    (⟨f, hf⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring
+      ↔ f = 0 ∨ 0 < v.ord f := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  constructor
+  · intro hu
+    rcases eq_or_ne f 0 with rfl | hf0
+    · exact Or.inl rfl
+    · refine Or.inr ?_
+      rcases lt_or_eq_of_le (v.ord_nonneg_of_mem hf) with h | h
+      · exact h
+      · exfalso
+        apply hu
+        rw [← v.adicValuation_coe_eq_one_iff ⟨f, hf⟩]
+        change v.adicValuation f = 1
+        rw [v.adicValuation_eq_exp_neg_ord hf0, ← h, neg_zero, WithZero.exp_zero]
+  · intro h hu
+    have hne : f ≠ 0 := fun h0 => hu.ne_zero (Subtype.ext h0)
+    have h0 : v.ord f = 0 := by
+      obtain ⟨u, hu'⟩ := hu
+      have hcoe : f = ((u : v.toValuationSubring) : F) := by rw [hu']
+      rw [hcoe]; exact v.ord_coe_unit u
+    rcases h with rfl | hpos
+    · exact hne rfl
+    · omega
+
+p2m_export "AlgebraicCurve.Place" "mk_mem_maximalIdeal_iff"
+end Place
+
+theorem ell_le_ell_sub_single_add_deg [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    ell D ≤ ell (D - Finsupp.single P 1) + P.deg := by
+  classical
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible P.toValuationSubring
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by
+    simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := by
+    intro g hg
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ g : F, g ∈ LSpace D → t ^ (D P) * g ∈ P.toValuationSubring := by
+    intro g hg
+    rcases eq_or_ne g 0 with rfl | hg0
+    · simp
+    · refine P.mem_of_ord_nonneg (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have := (mem_lSpace_iff_ord.mp hg).resolve_left hg0 P
+      linarith
+  let ψ : LSpace D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun f => ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+      map_add' := by intro f g; apply Subtype.ext; push_cast; ring
+      map_smul' := by
+        intro c f; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap]
+        ring }
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : LSpace D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ f : LSpace D, φ f = 0 ↔
+      (⟨t ^ (D P) * (f : F), hmem _ f.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := by
+    intro f
+    rw [show φ f = IsLocalRing.residue P.toValuationSubring ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+          from hres (ψ f),
+      IsLocalRing.residue_eq_zero_iff]
+  have hED : E ≤ D := by
+    rw [Finsupp.le_def]; intro v; rw [hE, Finsupp.sub_apply]
+    have : (0 : ℤ) ≤ Finsupp.single P 1 v := by
+      rcases eq_or_ne v P with rfl | hv
+      · simp
+      · simp [Finsupp.single_eq_of_ne hv]
+    linarith
+  have hsub : LSpace E ≤ LSpace D := lSpace_mono hED
+  have hker : LinearMap.ker φ = (LSpace E).comap (LSpace D).subtype := by
+    ext f
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi f, P.mk_mem_maximalIdeal_iff]
+    rcases eq_or_ne (f : F) 0 with hf0 | hf0
+    · simp only [hf0, mul_zero, true_or, true_iff]
+      exact (LSpace E).zero_mem
+    · rw [mem_lSpace_iff_ord]
+      have hfD := (mem_lSpace_iff_ord.mp f.2).resolve_left hf0
+      constructor
+      · rintro (h | h)
+        · exact absurd h (mul_ne_zero htn0 hf0)
+        · refine Or.inr (fun v => ?_)
+          rcases eq_or_ne v P with rfl | hv
+          · rw [hEP]; rw [hordmul hf0] at h; omega
+          · rw [hEv v hv]; exact hfD v
+      · rintro (h | h)
+        · exact absurd h hf0
+        · refine Or.inr ?_
+          have hP := h P
+          rw [hEP] at hP
+          rw [hordmul hf0]; omega
+  have hkerfin : finrank K (LinearMap.ker φ) = ell E := by
+    rw [hker, LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe hsub)]
+  have hquot : finrank K (LSpace D ⧸ LinearMap.ker φ) ≤ P.deg := by
+    rw [LinearEquiv.finrank_eq φ.quotKerEquivRange]
+    exact Submodule.finrank_le (LinearMap.range φ)
+  by_cases hfin : FiniteDimensional K (LSpace D)
+  · have := hfin
+    have hrn := Submodule.finrank_quotient_add_finrank (LinearMap.ker φ)
+    rw [hkerfin] at hrn
+    have hb : ell D = finrank K (LSpace D) := rfl
+    omega
+  · have h0 : ell D = 0 := by rw [ell]; exact finrank_of_infinite_dimensional hfin
+    omega
+
+theorem one_le_deg [IsCurveOver K F] (P : Place K F) : 1 ≤ P.deg := by
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  exact Module.finrank_pos
+
+theorem ell_le_degree_add_ellZero_port [IsCurveOver K F] {D : Divisor K F}
+    (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D : Divisor K F, (∀ v, 0 ≤ D v) →
+      (Divisor.degree D).toNat = m →
+      (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) by
+    exact H (Divisor.degree D).toNat D hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D hD hm
+    by_cases hD0 : D = 0
+    · subst hD0; simp
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ D P := by
+        have hne : D P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hD P; omega
+      set E : Divisor K F := D - Finsupp.single P 1 with hE
+      have hEeff : ∀ v, 0 ≤ E v := by
+        intro v; rw [hE, Finsupp.sub_apply]
+        rcases eq_or_ne v P with rfl | hv
+        · rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have hdegE : Divisor.degree E = Divisor.degree D - P.deg := by
+        rw [hE, map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hDnn : 0 ≤ Divisor.degree D := Divisor.degree_nonneg_of_nonneg hD
+      have hEnn : 0 ≤ Divisor.degree E := Divisor.degree_nonneg_of_nonneg hEeff
+      have hmlt : (Divisor.degree E).toNat < m := by rw [← hm]; omega
+      have hIH := IH _ hmlt E hEeff rfl
+      have hstep := ell_le_ell_sub_single_add_deg D P
+      rw [← hE] at hstep
+      have hstep' : (ell D : ℤ) ≤ (ell E : ℤ) + P.deg := by exact_mod_cast hstep
+      rw [hdegE] at hIH
+      linarith
+
+theorem ell_le_degree_add_one_of_effective [IsCurveOver K F]
+    (hC : ConstantsAreBase K F) {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  have h := ell_le_degree_add_ellZero_port hD
+  rw [ell_zero_eq_one_of_constantsAreBase hC] at h
+  exact_mod_cast h
+
+def lSpaceShiftEquiv (D : Divisor K F) {g : F} (hg : g ≠ 0)
+    {Dg : Divisor K F} (hDg : ∀ v, Dg v = v.ord g) :
+    LSpace D ≃ₗ[K] LSpace (D + Dg) where
+  toFun h := ⟨(h : F) * g⁻¹, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (h : F) 0 with hh0 | hh0
+    · left; rw [hh0, zero_mul]
+    · right; intro v
+      rw [Finsupp.add_apply, hDg, v.ord_mul hh0 (inv_ne_zero hg), v.ord_inv]
+      have := (mem_lSpace_iff_ord.mp h.2).resolve_left hh0 v
+      linarith⟩
+  invFun k := ⟨(k : F) * g, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (k : F) 0 with hk0 | hk0
+    · left; rw [hk0, zero_mul]
+    · right; intro v
+      have := (mem_lSpace_iff_ord.mp k.2).resolve_left hk0 v
+      rw [Finsupp.add_apply, hDg] at this
+      rw [v.ord_mul hk0 hg]
+      linarith⟩
+  map_add' h₁ h₂ := by apply Subtype.ext; push_cast; ring
+  map_smul' c h := by
+    apply Subtype.ext
+    simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def]
+    ring
+  left_inv h := by
+    apply Subtype.ext
+    change (h : F) * g⁻¹ * g = (h : F)
+    rw [mul_assoc, inv_mul_cancel₀ hg, mul_one]
+  right_inv k := by
+    apply Subtype.ext
+    change (k : F) * g * g⁻¹ = (k : F)
+    rw [mul_assoc, mul_inv_cancel₀ hg, mul_one]
+
+theorem ell_le_degree_add_one [IsCurveOver K F] (hC : ConstantsAreBase K F)
+    {D : Divisor K F} (hD : 0 ≤ Divisor.degree D) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  rcases eq_or_ne (ell D) 0 with h0 | h0
+  · rw [h0]; push_cast; linarith
+  · have hbot : LSpace D ≠ ⊥ := fun h => h0 (by rw [ell, h, finrank_bot])
+    obtain ⟨g, hgL, hg0⟩ := (Submodule.ne_bot_iff _).mp hbot
+    obtain ⟨Dg, hDgord, hDgdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) g hg0
+    have heff : ∀ v, 0 ≤ (D + Dg) v := by
+      intro v; rw [Finsupp.add_apply, hDgord]
+      have := (mem_lSpace_iff_ord.mp hgL).resolve_left hg0 v
+      linarith
+    have hdeg : Divisor.degree (D + Dg) = Divisor.degree D := by
+      rw [map_add, hDgdeg, add_zero]
+    have hell : ell D = ell (D + Dg) :=
+      LinearEquiv.finrank_eq (lSpaceShiftEquiv D hg0 hDgord)
+    have hfin := ell_le_degree_add_one_of_effective hC heff
+    rw [hdeg] at hfin
+    rw [hell]; exact hfin
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve _root_.P2MW.S_AlgebraicCurve_ell_le_degree_add_ellZero.AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F] {D : Divisor K F}
+    (hD : 0 ≤ D) [FiniteDimensional K ↥(LSpace (0 : Divisor K F))] :
+    (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) :=
+  AlgebraicCurve.ell_le_degree_add_ellZero_port (K := K) (F := F) (D := D) (hD := hD)
+
+end S_AlgebraicCurve_ell_le_degree_add_ellZero
+end P2MW
+export P2MW.S_AlgebraicCurve_ell_le_degree_add_ellZero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace AlgebraicCurve
+theorem ell_le_degree_add_ellZero {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F]
+    {D : Divisor K F}
+    (hD : 0 ≤ D) [FiniteDimensional K ↥(LSpace (0 : Divisor K F))] :
+    (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) :=
+  solution hD
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_ell_mapDomain_eq_of_constantFieldExtension_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_ell_mapDomain_eq_of_constantFieldExtension_of_isAlgClosed.lean
new file mode 100644
index 0000000000..ff77758863
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_ell_mapDomain_eq_of_constantFieldExtension_of_isAlgClosed.lean
@@ -0,0 +1,233 @@
+/-
+Based on Prove2Me node AlgebraicCurve.ell_mapDomain_eq_of_constantFieldExtension_of_isAlgClosed
+(85b5f1e2-5144-57bd-914d-4779dc077cdf) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 699795c5-a7d5-5387-a750-ff233a77cee0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_separating_transcendental_of_perfectField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom_of_isSeparable
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_lSpace_mapDomain_subset_span_image_lSpace_of_constantFieldExtension_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_linearIndependent_of_constantFieldExtension_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Invariance of ℓ(D) under constant field extension
+
+Theorem statement: `AlgebraicCurve.ell_mapDomain_eq_of_constantFieldExtension_of_isAlgClosed`
+(`85b5f1e2-5144-57bd-914d-4779dc077cdf`), by Claude, 2026-09-05.
+
+Proof: submission `699795c5-a7d5-5387-a750-ff233a77cee0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K \subseteq K'$ and $F, F'$ be fields with $F$ a $K$-algebra, $F'$ a $K'$-algebra and an
+$F$-algebra, compatibly in the sense that $K \to K' \to F'$ and $K \to F \to F'$ both compose to the
+given $K$-algebra structure on $F'$, and assume $K$ and $K'$ algebraically closed. Assume $F$ is
+finitely generated of transcendence degree one over $K$, in the form: some $x \in F$ is
+transcendental over $K$ with $F$ finite-dimensional over $K(x)$, and likewise for $F'$ over $K'$;
+assume also `IsCurveOver K F` and `IsCurveOver K' F'`, i.e. every nonzero function has a principal
+divisor of degree $0$, every place has residue field finite over the base field, and the module of
+Kähler differentials is free of rank one over the function field. Assume $F'$ is generated over $K'$
+by the image of $F$, i.e. the intermediate field $K'$ adjoined to $\mathrm{range}(F \to F')$ is all
+of $F'$. Here a place of $F/K$ is a valuation subring of $F$ containing $K$, distinct from $F$,
+whose ring is a principal ideal ring, a divisor is a finitely supported $\mathbb{Z}$-valued function
+on places, and $\ell(D) = \dim_K \{f \in F : v(f) \le \exp(D(v)) \text{ for all } v\}$ for the
+$\mathbb{Z}^{m0}$-valued adic valuations $v$. Let $\mathrm{lift}$ be an injective map from places of
+$F/K$ to places of $F'/K'$ such that $\mathrm{ord}_{\mathrm{lift}(P)}(f) = \mathrm{ord}_P(f)$ for
+all $f \in F$, and such that every place $v'$ of $F'/K'$ outside the image of $\mathrm{lift}$ has
+$v'$ pulled back along $F \to F'$ different from every place of $F/K$. Then for every divisor $D$ of
+$F/K$ whose Riemann–Roch space is finite-dimensional over $K$, the pushforward `D.mapDomain lift`
+satisfies $\ell_{K'}(\mathrm{mapDomain}\,\mathrm{lift}\,D) = \ell_K(D)$.
+
+This is the invariance of the Riemann–Roch dimension under a constant field extension with
+algebraically closed base field (Stichtenoth, Theorem 3.6.3(a)), the divisor being transported by
+the given lifting of places. It is used to compare genera across the extension, in the two
+inequalities
+[`AlgebraicCurve.genusFF_le_of_constantFieldExtension_of_isAlgClosed`]
+(thm.html#AlgebraicCurve.genusFF_le_of_constantFieldExtension_of_isAlgClosed)
+and
+[`AlgebraicCurve.le_genusFF_of_constantFieldExtension_of_isAlgClosed`]
+(thm.html#AlgebraicCurve.le_genusFF_of_constantFieldExtension_of_isAlgClosed).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_ell_mapDomain_eq_of_constantFieldExtension_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_ell_mapDomain_eq_of_constantFieldExtension_of_isAlgClosed
+
+
+open AlgebraicCurve
+
+namespace W7XEllMapDomain
+
+variable {K F K' F' : Type*}
+  [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+  [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+  [IsAlgClosed K]
+
+theorem algebraMap_mem_of_new
+    (hfg : ∃ x : F, Transcendental K x ∧
+      FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F)
+    {v' : Place K' F'}
+    (hv' : ∀ v : Place K F, v'.toValuationSubring.comap (algebraMap F F') ≠ v.toValuationSubring)
+    (f : F) : algebraMap F F' f ∈ v'.toValuationSubring := by
+  by_contra hmem
+  obtain ⟨x, hxt, hxfin⟩ := hfg
+  obtain ⟨t, _ht_trans, ht_fin, ht_sep⟩ :=
+    AlgebraicCurve.exists_separating_transcendental_of_perfectField hxt hxfin
+  have := ht_fin; have := ht_sep
+  obtain ⟨P, hP⟩ :=
+    AlgebraicCurve.Place.exists_toValuationSubring_eq_comap_ringHom_of_isSeparable
+      (K := K) t (algebraMap F F') v'.toValuationSubring
+      (fun c => by
+        rw [← IsScalarTower.algebraMap_apply K F F', IsScalarTower.algebraMap_apply K K' F']
+        exact v'.algebraMap_mem' _)
+      ⟨f, hmem⟩
+  exact hv' P hP.symm
+
+theorem algebraMap_mem_lSpace
+    (hfg : ∃ x : F, Transcendental K x ∧
+      FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F)
+    {lift : Place K F → Place K' F'}
+    (hlift_ord : ∀ (P : Place K F) (f : F), (lift P).ord (algebraMap F F' f) = P.ord f)
+    (hlift_inj : Function.Injective lift)
+    (hlift_new : ∀ v' : Place K' F', (∀ v, lift v ≠ v') →
+      ∀ v : Place K F, v'.toValuationSubring.comap (algebraMap F F') ≠ v.toValuationSubring)
+    {D : Divisor K F} {f : F} (hf : f ∈ LSpace D) :
+    algebraMap F F' f ∈ LSpace (K := K') (Finsupp.mapDomain lift D) := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · simp
+  refine mem_lSpace_iff_ord.mpr (Or.inr fun v' => ?_)
+  by_cases hold : ∃ v, lift v = v'
+  · obtain ⟨v, rfl⟩ := hold
+    rw [Finsupp.mapDomain_apply_of_injective hlift_inj, hlift_ord]
+    exact (mem_lSpace_iff_ord.mp hf).resolve_left hf0 v
+  · push Not at hold
+    rw [show (Finsupp.mapDomain lift D) v' = 0 from
+      Finsupp.mapDomain_of_notMem_range D v' (by simpa [Set.range] using hold), neg_zero]
+    have hmem := algebraMap_mem_of_new (K' := K') (F' := F') hfg (hlift_new v' hold) f
+    rcases (v'.adicValuation_le_one_iff).mp (v'.adicValuation_le_one_of_mem hmem) with h0 | h
+    · exact absurd ((algebraMap F F').injective (h0.trans (map_zero _).symm)) hf0
+    · exact h
+
+end W7XEllMapDomain
+
+open W7XEllMapDomain
+
+theorem solution
+    (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [IsAlgClosed K']
+    (hfg : ∃ x : F, Transcendental K x ∧ FiniteDimensional (IntermediateField.adjoin K ({x} : Set
+      F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    [IsCurveOver K F] [IsCurveOver K' F']
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤)
+    (lift : Place K F → Place K' F')
+    (hlift_ord : ∀ (P : Place K F) (f : F), (lift P).ord (algebraMap F F' f) = P.ord f)
+    (hlift_inj : Function.Injective lift)
+    (hlift_new : ∀ v' : Place K' F', (∀ v, lift v ≠ v') →
+      ∀ v : Place K F, v'.toValuationSubring.comap (algebraMap F F') ≠ v.toValuationSubring)
+    (D : Divisor K F) [FiniteDimensional K ↥(riemannRochSpace D)] :
+    ell (K := K') (D.mapDomain lift) = ell (K := K) D := by
+  classical
+  set b := Module.finBasis K ↥(riemannRochSpace D) with hb
+  set n := ell (K := K) D with hn
+  set e : Fin n → ↥(LSpace (K := K') (Finsupp.mapDomain lift D)) :=
+    fun i => ⟨algebraMap F F' (b i).1,
+      algebraMap_mem_lSpace hfg hlift_ord hlift_inj hlift_new (b i).2⟩ with he
+  have hLI : LinearIndependent K' e := by
+    have hLI0 : LinearIndependent K' (fun i => algebraMap F F' (b i : F)) :=
+      linearIndependent_of_constantFieldExtension_of_isAlgClosed K F K' F' hfg hfg' hgen
+        (b.linearIndependent.map' (riemannRochSpace D).subtype
+          (LinearMap.ker_eq_bot.mpr Subtype.val_injective))
+    exact hLI0.of_comp (LSpace (K := K') (Finsupp.mapDomain lift D)).subtype
+  have hSpan : Submodule.span K' (Set.range e) = ⊤ := by
+    rw [eq_top_iff]
+    rintro ⟨f', hf'⟩ -
+    have hmem_img : f' ∈ Submodule.span K' ((algebraMap F F') '' (LSpace (K := K) D : Set F)) :=
+      lSpace_mapDomain_subset_span_image_lSpace_of_constantFieldExtension_of_isAlgClosed
+        K F K' F' hfg hfg' hgen lift hlift_ord hlift_inj D hf'
+    have heq : Submodule.span K' ((algebraMap F F') '' (LSpace (K := K) D : Set F)) =
+        Submodule.span K' (Set.range fun i => algebraMap F F' (b i : F)) := by
+      refine le_antisymm (Submodule.span_le.mpr ?_) (Submodule.span_mono ?_)
+      · rintro _ ⟨g, hg, rfl⟩
+        have : algebraMap F F' g = ∑ i, (algebraMap K K' (b.repr ⟨g, hg⟩ i)) •
+            algebraMap F F' (b i : F) := by
+          conv_lhs => rw [show g = ((⟨g, hg⟩ : riemannRochSpace D) : F) from rfl,
+            ← b.sum_repr ⟨g, hg⟩]
+          simp only [Submodule.coe_sum, SetLike.val_smul, map_sum]
+          refine Finset.sum_congr rfl fun i _ => ?_
+          rw [Algebra.smul_def, map_mul, ← IsScalarTower.algebraMap_apply K F F',
+            Algebra.smul_def, IsScalarTower.algebraMap_apply K K' F']
+        rw [this]
+        exact Submodule.sum_mem _ fun i _ =>
+          Submodule.smul_mem _ _ (Submodule.subset_span ⟨i, rfl⟩)
+      · rintro _ ⟨i, rfl⟩; exact ⟨_, (b i).2, rfl⟩
+    rw [heq] at hmem_img
+    have hmap : Submodule.span K' (Set.range fun i => algebraMap F F' (b i : F)) =
+        (Submodule.span K' (Set.range e)).map
+          (LSpace (K := K') (Finsupp.mapDomain lift D)).subtype := by
+      rw [Submodule.map_span, ← Set.range_comp]
+      rfl
+    rw [hmap] at hmem_img
+    obtain ⟨y, hy, hyf⟩ := hmem_img
+    rwa [show y = ⟨f', hf'⟩ from Subtype.ext hyf] at hy
+  have hBasis : Module.Basis (Fin n) K' ↥(LSpace (K := K') (Finsupp.mapDomain lift D)) :=
+    .mk hLI (le_of_eq hSpan.symm)
+  calc ell (K := K') (D.mapDomain lift)
+      = Fintype.card (Fin n) := Module.finrank_eq_card_basis hBasis
+    _ = n := Fintype.card_fin n
+    _ = ell (K := K) D := hn
+
+end S_AlgebraicCurve_ell_mapDomain_eq_of_constantFieldExtension_of_isAlgClosed
+end P2MW
+export P2MW.S_AlgebraicCurve_ell_mapDomain_eq_of_constantFieldExtension_of_isAlgClosed (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.ell_mapDomain_eq_of_constantFieldExtension_of_isAlgClosed
+    (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [IsAlgClosed K']
+    (hfg : ∃ x : F, Transcendental K x ∧ FiniteDimensional (IntermediateField.adjoin K ({x} : Set
+      F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    [IsCurveOver K F] [IsCurveOver K' F']
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤)
+    (lift : Place K F → Place K' F')
+    (hlift_ord : ∀ (P : Place K F) (f : F), (lift P).ord (algebraMap F F' f) = P.ord f)
+    (hlift_inj : Function.Injective lift)
+    (hlift_new : ∀ v' : Place K' F', (∀ v, lift v ≠ v') →
+      ∀ v : Place K F, v'.toValuationSubring.comap (algebraMap F F') ≠ v.toValuationSubring)
+    (D : Divisor K F) [FiniteDimensional K ↥(riemannRochSpace D)] :
+    ell (K := K') (D.mapDomain lift) = ell (K := K) D :=
+  solution K F K' F' hfg hfg' hgen lift hlift_ord hlift_inj hlift_new D
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_essFiniteType_of_transcendental_of_finiteDimensional.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_essFiniteType_of_transcendental_of_finiteDimensional.lean
new file mode 100644
index 0000000000..f8a14aa550
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_essFiniteType_of_transcendental_of_finiteDimensional.lean
@@ -0,0 +1,97 @@
+/-
+Based on Prove2Me node AlgebraicCurve.essFiniteType_of_transcendental_of_finiteDimensional
+(da7d1dae-e045-52f9-9794-368f9eeed669) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 36a1ac61-a6ff-5717-8aa6-031e8818eab9
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Defs
+public import Mathlib.LinearAlgebra.FiniteDimensional.Defs
+public import Mathlib.RingTheory.Algebraic.Defs
+public import Mathlib.RingTheory.EssentialFiniteness
+
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import Mathlib.RingTheory.SimpleRing.Principal
+import Mathlib.RingTheory.TotallySplit
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finite extensions of K(x) are essentially of finite type
+
+Theorem statement: `AlgebraicCurve.essFiniteType_of_transcendental_of_finiteDimensional`
+(`da7d1dae-e045-52f9-9794-368f9eeed669`), by Claude, 2026-09-05.
+
+Proof: submission `36a1ac61-a6ff-5717-8aa6-031e8818eab9`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $x \in F$ be transcendental over $K$, that
+is, $x$ is not a root of any nonzero polynomial in $K[X]$. Assume further that $F$ is
+finite-dimensional as a module over the intermediate field $K\langle x\rangle =$
+`IntermediateField.adjoin K {x}`, the subfield of $F$ generated over $K$ by $x$. The conclusion is
+`Algebra.EssFiniteType K F`: the $K$-algebra $F$ is essentially of finite type, i.e. it is obtained
+from a finitely generated $K$-subalgebra by localisation, in the sense of Mathlib's predicate (there
+is a finite subset of $F$ such that every element of $F$ is a quotient of elements of the
+$K$-subalgebra it generates). No separability, normality or characteristic hypotheses are imposed,
+and the degree $[F : K\langle x\rangle]$ is not otherwise constrained; the hypotheses are exactly
+transcendence of $x$ together with finite-dimensionality of $F$ over $K\langle x\rangle$.
+
+This is the standard fact that a function field in one variable over $K$ is essentially of finite
+type over $K$, packaged so that the `Algebra.EssFiniteType K F` hypothesis appearing throughout the
+algebraic-curve development (differentials, canonical divisors, reduction of curves) can be
+discharged from the data a function field actually carries. It is invoked by a large number of
+statements about curves and their differentials which assume the base field extension is essentially
+of finite type.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_essFiniteType_of_transcendental_of_finiteDimensional.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_essFiniteType_of_transcendental_of_finiteDimensional
+
+open IntermediateField Polynomial
+
+theorem solution
+    {K F : Type*} [Field K] [Field F] [Algebra K F]
+    {x : F} (htr : Transcendental K x)
+    (hfd : FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F) :
+    Algebra.EssFiniteType K F := by
+  have := hfd
+  let e : RatFunc K ≃ₐ[K] K⟮x⟯ := RatFunc.algEquivOfTranscendental x htr
+  have : Algebra.EssFiniteType K[X] (RatFunc K) :=
+    Algebra.EssFiniteType.of_isLocalization (RatFunc K) (nonZeroDivisors K[X])
+  have : Algebra.EssFiniteType K (RatFunc K) := Algebra.EssFiniteType.comp K K[X] (RatFunc K)
+  have : Algebra.EssFiniteType K ↥K⟮x⟯ :=
+    Algebra.EssFiniteType.of_surjective e.toAlgHom e.surjective
+  have : Algebra.EssFiniteType ↥K⟮x⟯ F := Algebra.EssFiniteType.of_finiteType _ _
+  exact Algebra.EssFiniteType.comp K ↥K⟮x⟯ F
+
+end S_AlgebraicCurve_essFiniteType_of_transcendental_of_finiteDimensional
+end P2MW
+export P2MW.S_AlgebraicCurve_essFiniteType_of_transcendental_of_finiteDimensional (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.essFiniteType_of_transcendental_of_finiteDimensional
+    {K F : Type*} [Field K] [Field F] [Algebra K F]
+    {x : F} (htr : Transcendental K x)
+    (hfd : FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F) :
+    Algebra.EssFiniteType K F :=
+  solution htr hfd
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_divisor_eq_max_ord_sub_algebraMap.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_divisor_eq_max_ord_sub_algebraMap.lean
new file mode 100644
index 0000000000..8e9cb5588e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_divisor_eq_max_ord_sub_algebraMap.lean
@@ -0,0 +1,95 @@
+/-
+Based on Prove2Me node AlgebraicCurve.exists_divisor_eq_max_ord_sub_algebraMap
+(bfacb035-0084-5562-9e11-8a52d16fde3c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4f54069c-e429-5fd5-8e91-e98ad1b66a55
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of the divisor of zeros of x-a
+
+Theorem statement: `AlgebraicCurve.exists_divisor_eq_max_ord_sub_algebraMap`
+(`bfacb035-0084-5562-9e11-8a52d16fde3c`), by Claude, 2026-09-05.
+
+Proof: submission `4f54069c-e429-5fd5-8e91-e98ad1b66a55`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and assume `HasPrincipalDivisors K F`, i.e. that
+for every nonzero $f \in F$ there is a finitely supported integer-valued function $D$ on the places
+of $F/K$ with $D(v) = \operatorname{ord}_v(f)$ for every place $v$ and with $\deg D = 0$; here a
+place of $F/K$ is a valuation subring of $F$ that contains the image of $K$ under the structure map,
+is not all of $F$, and is a principal ideal ring, $\operatorname{ord}_v(f)$ is minus the logarithm
+of the value of $f$ under the adic valuation attached to the height-one prime of $v$, and the degree
+is the sum of the coefficients weighted by the residue degrees of the places. Let $x \in F$ be
+transcendental over $K$ and let $a \in K$. Then there exists a divisor $D$ on the places of $F/K$,
+that is a finitely supported function from `Place K F` to $\mathbb{Z}$, such that for every place
+$v$ one has $D(v) = \max\bigl(0, \operatorname{ord}_v(x -
+\operatorname{algebraMap}_{K,F}(a))\bigr)$. No assertion is made about the degree of $D$.
+
+This is the existence of the divisor of zeros of $x-a$, the positive part of the principal divisor
+$\operatorname{div}(x-a)$; its support enumerates the places of $F/K$ lying over the value $a$ of
+$x$, so that the fibre of $x$ above $a$ is finite. It feeds the computation of the number of such
+places, used in
+[`AlgebraicCurve.exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed`]
+(thm.html#AlgebraicCurve.exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_exists_divisor_eq_max_ord_sub_algebraMap.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_exists_divisor_eq_max_ord_sub_algebraMap
+
+open AlgebraicCurve
+
+theorem solution
+    {K F : Type*} [Field K] [Field F] [Algebra K F] [HasPrincipalDivisors K F]
+    (x : F) (hx : Transcendental K x) (a : K) :
+    ∃ D : Divisor K F, ∀ v : Place K F, D v = max 0 (v.ord (x - algebraMap K F a)) := by
+  classical
+  have hxa : x - algebraMap K F a ≠ 0 := by
+    intro h
+    apply hx
+    rw [sub_eq_zero] at h
+    rw [h]
+    exact isAlgebraic_algebraMap a
+  obtain ⟨P, hP, -⟩ := HasPrincipalDivisors.exists_divisor (K := K) (x - algebraMap K F a) hxa
+  exact ⟨P.mapRange (fun n => max 0 n) (by simp), fun v => by rw [Finsupp.mapRange_apply, hP v]⟩
+
+end S_AlgebraicCurve_exists_divisor_eq_max_ord_sub_algebraMap
+end P2MW
+export P2MW.S_AlgebraicCurve_exists_divisor_eq_max_ord_sub_algebraMap (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.exists_divisor_eq_max_ord_sub_algebraMap
+    {K F : Type*} [Field K] [Field F] [Algebra K F] [HasPrincipalDivisors K F]
+    (x : F) (hx : Transcendental K x) (a : K) :
+    ∃ D : Divisor K F, ∀ v : Place K F, D v = max 0 (v.ord (x - algebraMap K F a)) :=
+  solution x hx a
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_divisor_forall_eq_weightFloor.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_divisor_forall_eq_weightFloor.lean
new file mode 100644
index 0000000000..06f6b3facb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_divisor_forall_eq_weightFloor.lean
@@ -0,0 +1,123 @@
+/-
+Based on Prove2Me node AlgebraicCurve.exists_divisor_forall_eq_weightFloor
+(2481fa8e-e5c7-5074-ae56-61e602d63890) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6154789a-fda8-565a-8f5a-880b27e8802f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of the weight-m floor divisor on a curve
+
+Theorem statement: `AlgebraicCurve.exists_divisor_forall_eq_weightFloor`
+(`2481fa8e-e5c7-5074-ae56-61e602d63890`), by Claude, 2026-09-05.
+
+Proof: submission `6154789a-fda8-565a-8f5a-880b27e8802f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and $F$ a field equipped with a $K$-algebra structure satisfying
+[`AlgebraicCurve.IsCurveOver K F`](def/AlgebraicCurve_IsCurveOver.html#L15), i.e. (i) $F$ has
+principal divisors over $K$: every $f \neq 0$ in $F$ admits a finitely supported function $D$ on the
+places with $D(v) = \operatorname{ord}_v f$ for all $v$ and $\deg D = 0$, (ii) for every place $v$
+the residue field of the associated valuation subring is a finite $K$-module, and (iii)
+$\Omega[F/K]$ is a free $F$-module of rank $1$. Here a place is a valuation subring of $F$ that
+contains the image of $K$, is not all of $F$ and is a principal ideal ring, $\operatorname{ord}_v$
+is minus the logarithm of its $\mathbb{Z}^{m0}$-valued adic valuation, and a divisor is a finitely
+supported function from places to $\mathbb{Z}$. Let $y \in F$ and $m \in \mathbb{N}$. Then there
+exists a divisor $D$ such that for every place $w$,
+$$D(w) = \left[\operatorname{ord}_w y > 0\right]\,\frac{2m\,\operatorname{ord}_w y}{3} +
+\left[\operatorname{ord}_w(y-1728) > 0\right]\,\frac{m\,\operatorname{ord}_w(y-1728)}{2} +
+\left[\operatorname{ord}_w y < 0\right]\, m\,\operatorname{ord}_w y,$$
+the two fractions being integer division, which in the branches where they occur (nonnegative
+numerator, positive denominator) is the floor. Thus the assertion is exactly that the right-hand
+side, as a function of $w$, has finite support.
+
+This is the weight-$m$ floor divisor attached to $y$ on a curve, the divisor of $(dy)^{m}$ corrected
+at the points of ramification of order $2$ and $3$ when $y$ is a modular invariant; it is the
+function-field-theoretic form of the divisor used in the Riemann–Roch computation of dimensions of
+spaces of modular forms. It is invoked for the $\Gamma_1$-case dimension formulae and in producing
+the corresponding divisor on a modular curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_exists_divisor_forall_eq_weightFloor.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_exists_divisor_forall_eq_weightFloor
+
+open AlgebraicCurve
+
+namespace DivexG
+
+theorem exists_divisor_ord (K : Type*) [Field K] {F : Type*} [Field F] [Algebra K F]
+    [IsCurveOver K F] (f : F) :
+    ∃ D : Divisor K F, ∀ v : Place K F, D v = v.ord f := by
+  classical
+  rcases eq_or_ne f 0 with rfl | hf
+  · exact ⟨0, fun v => by simp⟩
+  · have : HasPrincipalDivisors K F := IsCurveOver.hasPrincipalDivisors
+    obtain ⟨D, hD, -⟩ := HasPrincipalDivisors.exists_divisor (K := K) (F := F) f hf
+    exact ⟨D, hD⟩
+
+end DivexG
+
+theorem solution
+    (K : Type*) [Field K] {F : Type*} [Field F] [Algebra K F] [AlgebraicCurve.IsCurveOver K F]
+    (y : F) (m : ℕ) :
+    ∃ D : AlgebraicCurve.Divisor K F, ∀ w : AlgebraicCurve.Place K F,
+      D w = (if 0 < w.ord y then (2 * (m : ℤ) * w.ord y) / 3 else 0)
+          + (if 0 < w.ord (y - 1728) then ((m : ℤ) * w.ord (y - 1728)) / 2 else 0)
+          + (if w.ord y < 0 then (m : ℤ) * w.ord y else 0) := by
+  classical
+  obtain ⟨Dj, hDj⟩ := DivexG.exists_divisor_ord K y
+  obtain ⟨Dc, hDc⟩ := DivexG.exists_divisor_ord K (y - 1728)
+  let R : Place K F → ℤ := fun w =>
+    (if 0 < w.ord y then (2 * (m : ℤ) * w.ord y) / 3 else 0)
+      + (if 0 < w.ord (y - 1728) then ((m : ℤ) * w.ord (y - 1728)) / 2 else 0)
+      + (if w.ord y < 0 then (m : ℤ) * w.ord y else 0)
+  have hsupp : ∀ w, R w ≠ 0 → w ∈ Dj.support ∪ Dc.support := by
+    intro w hw
+    by_contra hmem
+    rw [Finset.mem_union, not_or, Finsupp.mem_support_iff, Finsupp.mem_support_iff, not_not,
+      not_not,
+      hDj w, hDc w] at hmem
+    apply hw
+    simp only [R, hmem.1, hmem.2, lt_irrefl, ite_false, add_zero]
+  refine ⟨Finsupp.onFinset (Dj.support ∪ Dc.support) R hsupp, fun w => ?_⟩
+  rw [Finsupp.onFinset_apply]
+
+end S_AlgebraicCurve_exists_divisor_forall_eq_weightFloor
+end P2MW
+export P2MW.S_AlgebraicCurve_exists_divisor_forall_eq_weightFloor (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem AlgebraicCurve.exists_divisor_forall_eq_weightFloor
+    (K : Type*) [Field K] {F : Type*} [Field F] [Algebra K F] [AlgebraicCurve.IsCurveOver K F]
+    (y : F) (m : ℕ) :
+    ∃ D : AlgebraicCurve.Divisor K F, ∀ w : AlgebraicCurve.Place K F,
+      D w = (if 0 < w.ord y then (2 * (m : ℤ) * w.ord y) / 3 else 0)
+          + (if 0 < w.ord (y - 1728) then ((m : ℤ) * w.ord (y - 1728)) / 2 else 0)
+          + (if w.ord y < 0 then (m : ℤ) * w.ord y else 0) :=
+  solution K y m
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_finiteDimensional_isSeparable_adjoin_of_constantFieldExtension_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_finiteDimensional_isSeparable_adjoin_of_constantFieldExtension_of_isAlgClosed.lean
new file mode 100644
index 0000000000..5f0d7cc8a9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_finiteDimensional_isSeparable_adjoin_of_constantFieldExtension_of_isAlgClosed.lean
@@ -0,0 +1,163 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.exists_finiteDimensional_isSeparable_adjoin_of_constantFieldExtension_of_isAlgClosed
+(3a95c22c-d63d-58cf-8425-27387f799760) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f712fcd4-03e1-57d7-b600-a62920b8a436
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+
+import Mathlib.FieldTheory.SeparableClosure
+import Mathlib.LinearAlgebra.FreeModule.PID
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.PicardGroup
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_separating_transcendental_of_perfectField
+
+/-!
+# Constant field extension of a separably generated function field
+
+Theorem statement:
+`AlgebraicCurve.
+exists_finiteDimensional_isSeparable_adjoin_of_constantFieldExtension_of_isAlgClosed`
+(`3a95c22c-d63d-58cf-8425-27387f799760`), by Claude, 2026-09-05.
+
+Proof: submission `f712fcd4-03e1-57d7-b600-a62920b8a436`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K, F, K', F'$ be fields with algebra structures $K \to F$, $K' \to F'$, $K \to K'$, $F \to F'$
+and $K \to F'$, the last compatible with the towers $K \to K' \to F'$ and $K \to F \to F'$, and
+suppose $K$ is algebraically closed. Assume: (i) there is $x \in F$ transcendental over $K$ such
+that $F$ is finite-dimensional over the intermediate field $K(x) \subseteq F$ generated by $x$; (ii)
+there is $x \in F'$ transcendental over $K'$ such that $F'$ is finite-dimensional over $K'(x)
+\subseteq F'$; (iii) the intermediate field of $F'/K'$ generated over $K'$ by the image of $F$ under
+$F \to F'$ is all of $F'$. Then there exists $t' \in F'$ such that $F'$ is finite-dimensional over
+the intermediate field $K'(t') \subseteq F'$ and $F'$ is separable over $K'(t')$.
+
+This is the statement that a constant field extension $F' = K' \cdot F$ of a one-variable function
+field over an algebraically closed constant field is again separably generated, the witness being
+the image of a separating transcendental downstairs. It is used in the construction of places of
+$F'$ restricting to a prescribed place of $F$
+([`AlgebraicCurve.Place.exists_comap_algebraMap_eq_of_constantFieldExtension_of_isAlgClosed`]
+(thm.html#AlgebraicCurve.Place.
+exists_comap_algebraMap_eq_of_constantFieldExtension_of_isAlgClosed)).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_exists_finiteDimensional_isSeparable_adjoin_of_constantFieldExtension_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+open IntermediateField
+
+theorem solution
+    (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K]
+    (hfg : ∃ x : F, Transcendental K x ∧
+      FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F)
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤) :
+    ∃ t' : F', FiniteDimensional (IntermediateField.adjoin K' ({t'} : Set F')) F' ∧
+      Algebra.IsSeparable (IntermediateField.adjoin K' ({t'} : Set F')) F' := by
+  classical
+  obtain ⟨x, hx, hxfin⟩ := hfg
+  obtain ⟨t, _ht_trans, ht_fin, ht_sep⟩ :=
+    AlgebraicCurve.exists_separating_transcendental_of_perfectField hx hxfin
+  have := ht_fin; have := ht_sep
+  refine ⟨algebraMap F F' t, ?_, ?_⟩
+  all_goals
+    set Kt := IntermediateField.adjoin K ({t} : Set F) with hKt
+    set t' := algebraMap F F' t with ht'
+    set Kt' := IntermediateField.adjoin K' ({t'} : Set F') with hKt'
+    have hmem : ∀ a : Kt, algebraMap F F' (a : F) ∈ Kt' := by
+      intro a
+      have hle : Kt.toSubfield ≤ Kt'.toSubfield.comap (algebraMap F F') := by
+        rw [hKt, adjoin_toSubfield]
+        refine Subfield.closure_le.mpr ?_
+        rintro y (⟨c, rfl⟩ | ⟨rfl : y = t⟩)
+        · simp only [SetLike.mem_coe, Subfield.mem_comap]
+          rw [← IsScalarTower.algebraMap_apply K F F', IsScalarTower.algebraMap_apply K K' F']
+          exact IntermediateField.algebraMap_mem Kt' _
+        · exact mem_adjoin_simple_self K' t'
+      exact hle a.2
+    let σ : Kt →+* Kt' :=
+      ((algebraMap F F').comp (algebraMap Kt F)).codRestrict Kt'.toSubring hmem
+    have hσF' : (algebraMap Kt' F').comp σ = (algebraMap F F').comp (algebraMap Kt F) :=
+      RingHom.ext fun _ => rfl
+    set Bt := Module.finBasis Kt F with hBt
+    set S : Set F' := Set.range fun i => algebraMap F F' (Bt i : F) with hS
+    have : Finite S := (Set.finite_range _).to_subtype
+    have key : ∀ i,
+        Polynomial.aeval (R := Kt') (algebraMap F F' (Bt i : F))
+          ((minpoly Kt (Bt i : F)).map σ) = 0 := by
+      intro i
+      rw [Polynomial.aeval_def, Polynomial.eval₂_map, hσF',
+        ← Polynomial.hom_eval₂, ← Polynomial.aeval_def, minpoly.aeval, map_zero]
+    have hint : ∀ y ∈ S, IsIntegral Kt' y := by
+      rintro _ ⟨i, rfl⟩
+      exact ⟨(minpoly Kt (Bt i : F)).map σ,
+        ((minpoly.monic (Algebra.IsIntegral.isIntegral (R := Kt) (Bt i : F))).map σ), key i⟩
+    have hsepS : ∀ y ∈ S, IsSeparable Kt' y := by
+      rintro _ ⟨i, rfl⟩
+      have hp : ((minpoly Kt (Bt i : F)).map σ).Separable :=
+        Polynomial.Separable.map (Algebra.IsSeparable.isSeparable Kt (Bt i : F))
+      exact Polynomial.Separable.of_dvd hp (minpoly.dvd _ _ (key i))
+    have hadj_top : IntermediateField.adjoin Kt' S = ⊤ := by
+      rw [← IntermediateField.restrictScalars_eq_top_iff (K := K'), eq_top_iff, ← hgen]
+      refine IntermediateField.adjoin_le_iff.mpr ?_
+      rintro _ ⟨f, rfl⟩
+      change algebraMap F F' f ∈ (adjoin Kt' S).restrictScalars K'
+      have hrepr : algebraMap F F' f =
+          ∑ i, algebraMap Kt' F' (σ (Bt.repr f i)) * algebraMap F F' (Bt i : F) := by
+        conv_lhs => rw [← Bt.sum_repr f, map_sum]
+        simp only [Algebra.smul_def, map_mul]
+        rfl
+      rw [hrepr]
+      exact sum_mem fun i _ => mul_mem
+        (IntermediateField.algebraMap_mem (adjoin Kt' S) (σ (Bt.repr f i)))
+        (subset_adjoin Kt' S ⟨i, rfl⟩)
+  · have hfd : FiniteDimensional Kt' (adjoin Kt' S) :=
+      IntermediateField.finiteDimensional_adjoin fun y hy => hint y hy
+    rw [hadj_top] at hfd
+    exact IntermediateField.topEquiv.toLinearEquiv.finiteDimensional
+  · rw [← separableClosure.eq_top_iff, eq_top_iff, ← hadj_top]
+    exact adjoin_le_iff.mpr fun y hy => mem_separableClosure_iff.mpr (hsepS y hy)
+
+end privateSection
+
+public section publicSection
+
+namespace AlgebraicCurve
+
+theorem exists_finiteDimensional_isSeparable_adjoin_of_constantFieldExtension_of_isAlgClosed
+    (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K]
+    (hfg : ∃ x : F, Transcendental K x ∧
+      FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F)
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤) :
+    ∃ t' : F', FiniteDimensional (IntermediateField.adjoin K' ({t'} : Set F')) F' ∧
+      Algebra.IsSeparable (IntermediateField.adjoin K' ({t'} : Set F')) F' :=
+  solution K F K' F' hfg hgen
+
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_finset_sum_neg_ord_eq_finrank_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_finset_sum_neg_ord_eq_finrank_of_isAlgClosed.lean
new file mode 100644
index 0000000000..0a068d6612
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_finset_sum_neg_ord_eq_finrank_of_isAlgClosed.lean
@@ -0,0 +1,108 @@
+/-
+Based on Prove2Me node AlgebraicCurve.exists_finset_sum_neg_ord_eq_finrank_of_isAlgClosed
+(cf8ed5f7-65bd-5942-b45e-81bee149ff73) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 66ab165e-6e36-572b-90c6-3a094ebf6452
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_degree_poleDivisor_eq_finrank_adjoin_of_isAlgClosed_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_poleDivisor_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_isAlgClosed_of_transcendental
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Sum of pole orders of x equals [F:k(x)]
+
+Theorem statement: `AlgebraicCurve.exists_finset_sum_neg_ord_eq_finrank_of_isAlgClosed`
+(`cf8ed5f7-65bd-5942-b45e-81bee149ff73`), by Claude, 2026-09-05.
+
+Proof: submission `66ab165e-6e36-572b-90c6-3a094ebf6452`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $k$ be an algebraically closed field and $F$ a field equipped with a $k$-algebra structure, let
+$x \in F$ be transcendental over $k$, and assume $F$ is finite-dimensional as a module over the
+intermediate field $k(x) =$ `IntermediateField.adjoin k {x}`. Here a place $P$ of $F$ over $k$ is a
+valuation subring of $F$ that contains the image of $k$ under the structure map, is not all of $F$,
+and is a principal ideal ring; for such a $P$ and $f \in F$, $\operatorname{ord}_P f$ is the integer
+$-\log$ of the value of $f$ under the $\mathbb{Z}^{m0}$-valued valuation attached to the height-one
+prime of $P$. The assertion is that there is a finite set $S$ of places of $F$ over $k$ whose
+members are exactly the places $P$ with $\operatorname{ord}_P x < 0$ — so in particular the set of
+poles of $x$ is finite — and such that $$\sum_{P \in S} \bigl(-\operatorname{ord}_P x\bigr) = [\,F :
+k(x)\,],$$ the right-hand side being the $k(x)$-dimension of $F$ viewed as an integer.
+
+This is the classical statement that, over an algebraically closed constant field, the total pole
+order of a non-constant function $x$ on a curve equals the degree $[F:k(x)]$ of the associated
+covering of the projective line. It is the `Finset` form of the corresponding statement about the
+degree of the pole divisor, and is used in the project for counting places with prescribed
+behaviour, for instance in the computation of $\ell(0)$ and in the study of divisors built from
+floors of orders.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_exists_finset_sum_neg_ord_eq_finrank_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_exists_finset_sum_neg_ord_eq_finrank_of_isAlgClosed
+
+open AlgebraicCurve
+
+theorem solution
+    (k : Type*) [Field k] [IsAlgClosed k] {F : Type*} [Field F] [Algebra k F]
+    (x : F) (hx : Transcendental k x)
+    (hfin : FiniteDimensional (IntermediateField.adjoin k ({x} : Set F)) F) :
+    ∃ S : Finset (Place k F), (∀ P, P ∈ S ↔ P.ord x < 0) ∧
+      ∑ P ∈ S, (-P.ord x) = (Module.finrank (IntermediateField.adjoin k ({x} : Set F)) F : ℤ) := by
+  classical
+  have := hfin
+  have : IsCurveOver k F := isCurveOver_of_isAlgClosed_of_transcendental x hx
+  obtain ⟨D, hD⟩ := AlgebraicCurve.exists_poleDivisor_of_transcendental x hx
+  refine ⟨D.support, fun P => ?_, ?_⟩
+  · rw [Finsupp.mem_support_iff, hD P]
+    constructor
+    · intro h; by_contra h'; exact h (max_eq_left (by omega))
+    · intro h; rw [max_eq_right (by omega)]; omega
+  · have hdeg :=
+      AlgebraicCurve.degree_poleDivisor_eq_finrank_adjoin_of_isAlgClosed_of_transcendental x hx D hD
+    rw [AlgebraicCurve.Divisor.degree_eq_sum_support] at hdeg
+    rw [← hdeg]
+    refine Finset.sum_congr rfl fun P hP => ?_
+    rw [IsCurveOver.deg_eq_one_of_isAlgClosed P, Nat.cast_one, mul_one, hD P]
+    rw [Finsupp.mem_support_iff, hD P] at hP
+    have : P.ord x < 0 := by by_contra h'; exact hP (max_eq_left (by omega))
+    rw [max_eq_right (by omega)]
+
+end S_AlgebraicCurve_exists_finset_sum_neg_ord_eq_finrank_of_isAlgClosed
+end P2MW
+export P2MW.S_AlgebraicCurve_exists_finset_sum_neg_ord_eq_finrank_of_isAlgClosed (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.exists_finset_sum_neg_ord_eq_finrank_of_isAlgClosed
+    (k : Type*) [Field k] [IsAlgClosed k] {F : Type*} [Field F] [Algebra k F]
+    (x : F) (hx : Transcendental k x)
+    (hfin : FiniteDimensional (IntermediateField.adjoin k ({x} : Set F)) F) :
+    ∃ S : Finset (Place k F), (∀ P, P ∈ S ↔ P.ord x < 0) ∧
+      ∑ P ∈ S, (-P.ord x) = (Module.finrank (IntermediateField.adjoin k ({x} : Set F)) F : ℤ) :=
+  solution k x hx hfin
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed.lean
new file mode 100644
index 0000000000..677539f33e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed.lean
@@ -0,0 +1,122 @@
+/-
+Based on Prove2Me node AlgebraicCurve.exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed
+(8d31be42-bebd-5aa9-b199-3a9cf9ed31f0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 051e652c-cd4a-5af4-b0c3-40438dc3363d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_finrank_adjoin_of_eq_max_ord_sub_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_constantsAreBase_of_isAlgClosed_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_divisor_eq_max_ord_sub_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_isAlgClosed_of_transcendental
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Zero sum of x-a equals [F:k(x)] over ̄ k
+
+Theorem statement: `AlgebraicCurve.exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed`
+(`8d31be42-bebd-5aa9-b199-3a9cf9ed31f0`), by Claude, 2026-09-05.
+
+Proof: submission `051e652c-cd4a-5af4-b0c3-40438dc3363d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $k$ be an algebraically closed field and $F$ a field equipped with a $k$-algebra structure. Let
+$x \in F$ be transcendental over $k$, assume $F$ is finite-dimensional as a module over the
+intermediate field $k(x) =$ `IntermediateField.adjoin k {x}`, and let $a \in k$. Here a place of $F$
+over $k$ (the structure `Place k F`) is a valuation subring of $F$ containing
+$\operatorname{algebraMap} k F(b)$ for every $b \in k$, different from all of $F$, and whose
+underlying ring is a principal ideal ring; for such a place $P$ and $f \in F$, $P.\mathrm{ord}(f)$
+is the integer $-\log$ of the value of $f$ under the valuation of $F$ attached to the height-one
+prime of $P$. The assertion is that there exists a finite set $S$ of places of $F$ over $k$ such
+that a place $P$ lies in $S$ precisely when $P.\mathrm{ord}(x - \operatorname{algebraMap} k F(a)) >
+0$, and such that $$\sum_{P \in S} P.\mathrm{ord}\bigl(x - \operatorname{algebraMap} k F(a)\bigr) =
+\bigl[F : k(x)\bigr],$$ the right-hand side being $\operatorname{finrank}_{k(x)} F$ regarded as an
+integer. In particular the set of places at which $x - a$ has a zero is finite, and the zeros of
+$x-a$ counted with multiplicity total $[F:k(x)]$.
+
+This is the classical statement that, over an algebraically closed constant field, the fibre of the
+map $x$ above a point $a \in k$ has total multiplicity equal to the degree $[F:k(x)]$ (Stichtenoth,
+Theorem 1.4.11), packaged as an explicit finite sum rather than as an equality of divisor degrees.
+It is used for the ramification estimates for the covering $X_1(M) \to \mathbb{P}^1_j$ and for
+counting zeros against supersingular points; among its consumers are
+[`AlgebraicCurve.finrank_adjoin_le_mul_natCard_place_ord_sub_algebraMap_pos_of_forall_ord_le`]
+(thm.html#AlgebraicCurve.
+finrank_adjoin_le_mul_natCard_place_ord_sub_algebraMap_pos_of_forall_ord_le)
+and lemmas on cuspidal and non-cuspidal specialisations of modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed
+
+open AlgebraicCurve
+
+theorem solution
+    (k : Type*) [Field k] [IsAlgClosed k] {F : Type*} [Field F] [Algebra k F]
+    (x : F) (hx : Transcendental k x)
+    (hfin : FiniteDimensional (IntermediateField.adjoin k ({x} : Set F)) F) (a : k) :
+    ∃ S : Finset (Place k F), (∀ P, P ∈ S ↔ 0 < P.ord (x - algebraMap k F a)) ∧
+      ∑ P ∈ S, P.ord (x - algebraMap k F a) = (Module.finrank (IntermediateField.adjoin k ({x} : Set
+        F)) F : ℤ) := by
+  classical
+  have := hfin
+  have : IsCurveOver k F := isCurveOver_of_isAlgClosed_of_transcendental x hx
+  have hcab : ConstantsAreBase k F := constantsAreBase_of_isAlgClosed_of_transcendental x hx
+  have hℓ0 : ell (0 : Divisor k F) = 1 := ell_zero_eq_one_of_constantsAreBase hcab
+  have : FiniteDimensional k (LSpace (0 : Divisor k F)) :=
+    FiniteDimensional.of_finrank_eq_succ (n := 0) hℓ0
+  obtain ⟨D, hD⟩ := AlgebraicCurve.exists_divisor_eq_max_ord_sub_algebraMap x hx a
+  refine ⟨D.support, fun P => ?_, ?_⟩
+  · rw [Finsupp.mem_support_iff, hD P]
+    constructor
+    · intro h; by_contra h'; exact h (max_eq_left (by omega))
+    · intro h; rw [max_eq_right (by omega)]; omega
+  · have hdeg :=
+      AlgebraicCurve.Divisor.degree_eq_finrank_adjoin_of_eq_max_ord_sub_algebraMap x hx a D hD
+    rw [AlgebraicCurve.Divisor.degree_eq_sum_support] at hdeg
+    rw [← hdeg]
+    refine Finset.sum_congr rfl fun P hP => ?_
+    rw [IsCurveOver.deg_eq_one_of_isAlgClosed P, Nat.cast_one, mul_one, hD P]
+    rw [Finsupp.mem_support_iff, hD P] at hP
+    have : 0 < P.ord (x - algebraMap k F a) := by by_contra h'; exact hP (max_eq_left (by omega))
+    rw [max_eq_right (by omega)]
+
+end S_AlgebraicCurve_exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed
+end P2MW
+export P2MW.S_AlgebraicCurve_exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed
+    (k : Type*) [Field k] [IsAlgClosed k] {F : Type*} [Field F] [Algebra k F]
+    (x : F) (hx : Transcendental k x)
+    (hfin : FiniteDimensional (IntermediateField.adjoin k ({x} : Set F)) F) (a : k) :
+    ∃ S : Finset (Place k F), (∀ P, P ∈ S ↔ 0 < P.ord (x - algebraMap k F a)) ∧
+      ∑ P ∈ S, P.ord (x - algebraMap k F a) = (Module.finrank (IntermediateField.adjoin k ({x} : Set
+        F)) F : ℤ) :=
+  solution k x hx hfin a
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_genus_riemannIndex_of_isCurveOver.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_genus_riemannIndex_of_isCurveOver.lean
new file mode 100644
index 0000000000..229314b581
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_genus_riemannIndex_of_isCurveOver.lean
@@ -0,0 +1,138 @@
+/-
+Based on Prove2Me node AlgebraicCurve.exists_genus_riemannIndex_of_isCurveOver
+(9a2f9079-9764-5acf-ad36-06f9412f5986) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e9c4d2d8-9b39-5061-9c3f-7f11697bc00e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_IsCurveOver_exists_separating_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_stichtenothGenusExists
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_genus_riemannIndex_of_stichtenothGenusExists
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Riemann's index theorem for curves over a perfect field
+
+Theorem statement: `AlgebraicCurve.exists_genus_riemannIndex_of_isCurveOver`
+(`9a2f9079-9764-5acf-ad36-06f9412f5986`), by Claude, 2026-09-05.
+
+Proof: submission `e9c4d2d8-9b39-5061-9c3f-7f11697bc00e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a perfect field and $F$ a field equipped with a $K$-algebra structure which is
+essentially of finite type over $K$ and satisfies `IsCurveOver K F`: every nonzero $f \in F$ admits
+a divisor whose value at each place $v$ is $\mathrm{ord}_v(f)$ and whose degree is $0$, each residue
+field of a place of $F/K$ is finite-dimensional over $K$, and the module of Kähler differentials
+$\Omega[F/K]$ is free of rank $1$ over $F$. Here a place is a valuation subring of $F$ containing
+the image of $K$, distinct from $F$ itself, and a principal ideal ring, and a divisor is a finitely
+supported function from places to $\mathbb{Z}$, its degree being $\sum_v D(v)\,\deg v$. Assume
+further `ConstantsAreBase K F`, i.e. the Riemann–Roch space of the zero divisor is exactly the image
+of $K$ in $F$. Then there is an integer $\gamma$ such that for every divisor $D$: the quotient of
+the adele space $\bigcup_E \{\alpha : |\alpha_v|_v \le \exp(E(v))\ \forall v\}$ by the sum of the
+subspace cut out by the bounds of $D$ and of the image of the diagonal map $F \to \prod_v F$ is
+finite-dimensional over $K$, and its $K$-dimension $i(D)$ satisfies $i(D) = \ell(D) - (\deg D + 1 -
+\gamma)$, where $\ell(D) = \dim_K$ of the Riemann–Roch space of $D$.
+
+This is Riemann's index theorem in adelic form, producing the genus $\gamma$ as the single integer
+controlling the index of specialty of all divisors simultaneously; in this formulation the existence
+of $\gamma$ is asserted without identifying it with the Kähler genus. It is the form of Riemann–Roch
+used downstream, for instance in the results on divisors under constant field extension.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_exists_genus_riemannIndex_of_isCurveOver.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_exists_genus_riemannIndex_of_isCurveOver
+
+open IntermediateField
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_exists_genus_riemannIndex_of_isCurveOver.AlgebraicCurve"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Divisor Divisor.degree IsCurveOver ell ConstantsAreBase adeleSpace \
+  indexOfSpecialty adeleBddPrincipal StichtenothGenusExists \
+  IsCurveOver.exists_separating_transcendental RationalFunctionField.stichtenothGenusExists \
+  exists_genus_riemannIndex_of_stichtenothGenusExists"
+namespace TowerFreePort
+p2m_open "AlgebraicCurve"
+theorem stichtenothGenusExists_of_isCurveOver_port {K : Type*} {F : Type*} [Field K] [Field F]
+    [Algebra K F] [PerfectField K] [Algebra.EssFiniteType K F] [IsCurveOver K F]
+    (hC : ConstantsAreBase K F) :
+    StichtenothGenusExists K F := by
+  classical
+  obtain ⟨x, htr, hfd, hsep⟩ := IsCurveOver.exists_separating_transcendental (K := K) (F := F)
+  have := hfd; have := hsep
+  set e : RatFunc K ≃ₐ[K] K⟮x⟯ := RatFunc.algEquivOfTranscendental x htr with he
+  let : Algebra (RatFunc K) F := ((algebraMap K⟮x⟯ F).comp e.toAlgHom.toRingHom).toAlgebra
+  have hsq : RingHom.comp (algebraMap (RatFunc K) F) (e.symm.toRingEquiv : K⟮x⟯ →+* RatFunc K)
+      = RingHom.comp (RingEquiv.refl F : F →+* F) (algebraMap K⟮x⟯ F) := by
+    refine RingHom.ext fun a => ?_
+    change algebraMap K⟮x⟯ F (e (e.symm a)) = algebraMap K⟮x⟯ F a
+    rw [e.apply_symm_apply]
+  have : IsScalarTower K (RatFunc K) F :=
+    IsScalarTower.of_algebraMap_eq fun a => by
+      change algebraMap K F a = algebraMap K⟮x⟯ F (e (algebraMap K (RatFunc K) a))
+      rw [e.commutes, ← IsScalarTower.algebraMap_apply]
+  have : FiniteDimensional (RatFunc K) F :=
+    Module.Finite.of_equiv_equiv e.symm.toRingEquiv (RingEquiv.refl F) hsq
+  have : Algebra.IsSeparable (RatFunc K) F :=
+    Algebra.IsSeparable.of_equiv_equiv e.symm.toRingEquiv (RingEquiv.refl F) hsq
+  exact RationalFunctionField.stichtenothGenusExists K F hC
+
+theorem solution {K : Type*} {F : Type*} [Field K] [Field F] [Algebra K F] [PerfectField K]
+    [Algebra.EssFiniteType K F] [IsCurveOver K F] (hC : ConstantsAreBase K F) :
+    ∃ γ : ℤ, ∀ D : Divisor K F,
+      Module.Finite K (↥(adeleSpace K F) ⧸ adeleBddPrincipal K F D) ∧
+        (indexOfSpecialty D : ℤ) = (ell D : ℤ) - (Divisor.degree D + 1 - γ) := by
+  exact exists_genus_riemannIndex_of_stichtenothGenusExists
+    (stichtenothGenusExists_of_isCurveOver_port hC)
+
+end AlgebraicCurve.TowerFreePort
+
+open IntermediateField _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_exists_genus_riemannIndex_of_isCurveOver.AlgebraicCurve in
+theorem solution {K : Type*} {F : Type*} [Field K] [Field F] [Algebra K F] [PerfectField K]
+    [Algebra.EssFiniteType K F] [IsCurveOver K F] (hC : ConstantsAreBase K F) :
+    ∃ γ : ℤ, ∀ D : Divisor K F,
+      Module.Finite K (↥(adeleSpace K F) ⧸ adeleBddPrincipal K F D) ∧
+        (indexOfSpecialty D : ℤ) = (ell D : ℤ) - (Divisor.degree D + 1 - γ) :=
+  AlgebraicCurve.TowerFreePort.solution hC
+
+end S_AlgebraicCurve_exists_genus_riemannIndex_of_isCurveOver
+end P2MW
+export P2MW.S_AlgebraicCurve_exists_genus_riemannIndex_of_isCurveOver (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace AlgebraicCurve
+theorem exists_genus_riemannIndex_of_isCurveOver {K : Type*} {F : Type*} [Field K] [Field F]
+    [Algebra K F] [PerfectField K] [Algebra.EssFiniteType K F] [IsCurveOver K F]
+    (hC : ConstantsAreBase K F) :
+    ∃ γ : ℤ, ∀ D : Divisor K F,
+      Module.Finite K (↥(adeleSpace K F) ⧸ adeleBddPrincipal K F D) ∧
+        (indexOfSpecialty D : ℤ) = (ell D : ℤ) - (Divisor.degree D + 1 - γ) :=
+  solution hC
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_genus_riemannIndex_of_stichtenothGenusExists.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_genus_riemannIndex_of_stichtenothGenusExists.lean
new file mode 100644
index 0000000000..598a8926a5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_genus_riemannIndex_of_stichtenothGenusExists.lean
@@ -0,0 +1,1646 @@
+/-
+Based on Prove2Me node AlgebraicCurve.exists_genus_riemannIndex_of_stichtenothGenusExists
+(54cdae2a-d941-5bef-9844-e8cf4f94900d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 66288c62-f31d-5d34-8e8a-a6eac684f3f2
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import Mathlib.LinearAlgebra.Matrix.FiniteDimensional
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.PicardGroup
+import Mathlib.Data.Int.LeastGreatest
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Adelic Riemann–Roch from existence of the Stichtenoth genus
+
+Theorem statement: `AlgebraicCurve.exists_genus_riemannIndex_of_stichtenothGenusExists`
+(`54cdae2a-d941-5bef-9844-e8cf4f94900d`), by Claude, 2026-09-05.
+
+Proof: submission `66288c62-f31d-5d34-8e8a-a6eac684f3f2`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra satisfying `IsCurveOver K F`, that is: every
+nonzero $f \in F$ has a divisor whose coefficient at each place $v$ is $v.\mathrm{ord}\, f$ and
+whose degree is $0$; each place has residue field finite over $K$; and $\Omega_{F/K}$ is free of
+rank one over $F$. Assume `StichtenothGenusExists K F`: there is at least one place of $F/K$, the
+Riemann–Roch space $L(0)$ is finite-dimensional over $K$, and there are $\gamma_0 \in \mathbb{Z}$
+and a divisor $D_0$ with $L(D_0)$ finite-dimensional, $\deg D_0 - \ell(D_0) = \gamma_0 - 1$, and
+$\deg D - \ell(D) \le \gamma_0 - 1$ for every divisor $D$. Here divisors are finitely supported
+$\mathbb{Z}$-valued functions on places, $\deg$ is the sum of coefficients weighted by the residue
+degrees, and $\ell(D) = \dim_K L(D)$. The conclusion asserts the existence of an integer $\gamma$
+such that for every divisor $D$: first, the quotient of the adele space $\mathbb{A} = \sup_E
+\{\alpha \mid v(\alpha_v) \le \exp(E_v) \text{ for all } v\}$ inside $\prod_v F$ by the submodule
+generated by $\{\alpha \in \mathbb{A} \mid v(\alpha_v) \le \exp(D_v)\}$ together with the image of
+the diagonal map $F \to \prod_v F$ is a finite $K$-module; and second, its $K$-dimension $i(D)$
+satisfies $i(D) = \ell(D) - (\deg D + 1 - \gamma)$ in $\mathbb{Z}$. The integer $\gamma$ is produced
+existentially and is not asserted to equal $\gamma_0$.
+
+This is the adelic form of the Riemann–Roch theorem, $\ell(D) - i(D) = \deg D + 1 - \gamma$, with
+$\gamma$ the Stichtenoth genus defined by the maximality property in the hypothesis; the index of
+specialty is computed as the $K$-dimension of the adele class group attached to $D$. It is used to
+obtain the same conclusion from the curve axioms alone and to extract the uniform bound $\deg D + 1
+- \ell(D) \le \gamma$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_exists_genus_riemannIndex_of_stichtenothGenusExists.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_exists_genus_riemannIndex_of_stichtenothGenusExists
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero \
+  ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono \
+  diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  residuePairing_injective WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached \
+  StichtenothGenusExists RiemannGenusBounded IndexOfSpecialtyFinite"
+p2m_open "AlgebraicCurve"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_coe_unit ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow mk.injEq toValuationSubring mk \
+  adicValuation_eq_exp_neg_ord"
+p2m_open "AlgebraicCurve.Place"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+p2m_export "AlgebraicCurve.Place" "ord_nonneg_of_mem"
+p2m_export "AlgebraicCurve.Place" "mem_of_ord_nonneg"
+theorem mem_iff_ord_nonneg {f : F} (hf : f ≠ 0) :
+    f ∈ v.toValuationSubring ↔ 0 ≤ v.ord f :=
+  ⟨v.ord_nonneg_of_mem, v.mem_of_ord_nonneg hf⟩
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero \
+  ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono \
+  diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  residuePairing_injective WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached \
+  StichtenothGenusExists RiemannGenusBounded IndexOfSpecialtyFinite"
+p2m_open "AlgebraicCurve"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "degree degree_single principal smul_def smul_apply"
+end Divisor
+variable {D : Divisor K F}
+p2m_open_scoped "AlgebraicCurve.Divisor" in
+theorem Divisor.degree_nonneg_of_nonneg [IsCurveOver K F]
+    {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) : 0 ≤ Divisor.degree D := by
+  rw [Divisor.degree_eq_sum_support]
+  exact Finset.sum_nonneg fun v _ => mul_nonneg (hD v) (Int.natCast_nonneg _)
+theorem lSpace_eq_bot_of_degree_neg [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) : LSpace D = ⊥ := by
+  rw [eq_bot_iff]
+  intro f hf
+  rw [Submodule.mem_bot]
+  by_contra hf0
+  obtain ⟨P, hPord, hPdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+  have heff : ∀ v : Place K F, 0 ≤ (P + D) v := by
+    intro v
+    rw [Finsupp.add_apply, hPord]
+    rcases mem_lSpace_iff_ord.mp hf with rfl | h
+    · exact absurd rfl hf0
+    · linarith [h v]
+  have hdegPD : 0 ≤ Divisor.degree (P + D) := Divisor.degree_nonneg_of_nonneg heff
+  rw [map_add, hPdeg, zero_add] at hdegPD
+  exact absurd hdegPD (not_le.mpr hD)
+end AlgebraicCurve
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero \
+  ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono \
+  diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  residuePairing_injective WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached \
+  StichtenothGenusExists RiemannGenusBounded IndexOfSpecialtyFinite"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_coe_unit ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow mk.injEq toValuationSubring mk \
+  adicValuation_eq_exp_neg_ord"
+p2m_open "AlgebraicCurve.Place"
+
+variable (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mk_mem_maximalIdeal_iff {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    (⟨f, hf⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring
+      ↔ f = 0 ∨ 0 < v.ord f := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  constructor
+  · intro hu
+    rcases eq_or_ne f 0 with rfl | hf0
+    · exact Or.inl rfl
+    · refine Or.inr ?_
+      rcases lt_or_eq_of_le (v.ord_nonneg_of_mem hf) with h | h
+      · exact h
+      · exfalso
+        apply hu
+        rw [← v.adicValuation_coe_eq_one_iff ⟨f, hf⟩]
+        change v.adicValuation f = 1
+        rw [v.adicValuation_eq_exp_neg_ord hf0, ← h, neg_zero, WithZero.exp_zero]
+  · intro h hu
+    have hne : f ≠ 0 := fun h0 => hu.ne_zero (Subtype.ext h0)
+    have h0 : v.ord f = 0 := by
+      obtain ⟨u, hu'⟩ := hu
+      have hcoe : f = ((u : v.toValuationSubring) : F) := by rw [hu']
+      rw [hcoe]; exact v.ord_coe_unit u
+    rcases h with rfl | hpos
+    · exact hne rfl
+    · omega
+
+p2m_export "AlgebraicCurve.Place" "mk_mem_maximalIdeal_iff"
+end Place
+
+theorem ell_le_ell_sub_single_add_deg [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    ell D ≤ ell (D - Finsupp.single P 1) + P.deg := by
+  classical
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible P.toValuationSubring
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by
+    simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := by
+    intro g hg
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ g : F, g ∈ LSpace D → t ^ (D P) * g ∈ P.toValuationSubring := by
+    intro g hg
+    rcases eq_or_ne g 0 with rfl | hg0
+    · simp
+    · refine P.mem_of_ord_nonneg (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have := (mem_lSpace_iff_ord.mp hg).resolve_left hg0 P
+      linarith
+  let ψ : LSpace D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun f => ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+      map_add' := by intro f g; apply Subtype.ext; push_cast; ring
+      map_smul' := by
+        intro c f; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap]
+        ring }
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : LSpace D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ f : LSpace D, φ f = 0 ↔
+      (⟨t ^ (D P) * (f : F), hmem _ f.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := by
+    intro f
+    rw [show φ f = IsLocalRing.residue P.toValuationSubring ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+          from hres (ψ f),
+      IsLocalRing.residue_eq_zero_iff]
+  have hED : E ≤ D := by
+    rw [Finsupp.le_def]; intro v; rw [hE, Finsupp.sub_apply]
+    have : (0 : ℤ) ≤ Finsupp.single P 1 v := by
+      rcases eq_or_ne v P with rfl | hv
+      · simp
+      · simp [Finsupp.single_eq_of_ne hv]
+    linarith
+  have hsub : LSpace E ≤ LSpace D := lSpace_mono hED
+  have hker : LinearMap.ker φ = (LSpace E).comap (LSpace D).subtype := by
+    ext f
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi f, P.mk_mem_maximalIdeal_iff]
+    rcases eq_or_ne (f : F) 0 with hf0 | hf0
+    · simp only [hf0, mul_zero, true_or, true_iff]
+      exact (LSpace E).zero_mem
+    · rw [mem_lSpace_iff_ord]
+      have hfD := (mem_lSpace_iff_ord.mp f.2).resolve_left hf0
+      constructor
+      · rintro (h | h)
+        · exact absurd h (mul_ne_zero htn0 hf0)
+        · refine Or.inr (fun v => ?_)
+          rcases eq_or_ne v P with rfl | hv
+          · rw [hEP]; rw [hordmul hf0] at h; omega
+          · rw [hEv v hv]; exact hfD v
+      · rintro (h | h)
+        · exact absurd h hf0
+        · refine Or.inr ?_
+          have hP := h P
+          rw [hEP] at hP
+          rw [hordmul hf0]; omega
+  have hkerfin : finrank K (LinearMap.ker φ) = ell E := by
+    rw [hker, LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe hsub)]
+  have hquot : finrank K (LSpace D ⧸ LinearMap.ker φ) ≤ P.deg := by
+    rw [LinearEquiv.finrank_eq φ.quotKerEquivRange]
+    exact Submodule.finrank_le (LinearMap.range φ)
+  by_cases hfin : FiniteDimensional K (LSpace D)
+  · have := hfin
+    have hrn := Submodule.finrank_quotient_add_finrank (LinearMap.ker φ)
+    rw [hkerfin] at hrn
+    have hb : ell D = finrank K (LSpace D) := rfl
+    omega
+  · have h0 : ell D = 0 := by rw [ell]; exact finrank_of_infinite_dimensional hfin
+    omega
+
+theorem one_le_deg [IsCurveOver K F] (P : Place K F) : 1 ≤ P.deg := by
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  exact Module.finrank_pos
+
+theorem ell_le_degree_add_ellZero [IsCurveOver K F] {D : Divisor K F}
+    (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D : Divisor K F, (∀ v, 0 ≤ D v) →
+      (Divisor.degree D).toNat = m →
+      (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) by
+    exact H (Divisor.degree D).toNat D hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D hD hm
+    by_cases hD0 : D = 0
+    · subst hD0; simp
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ D P := by
+        have hne : D P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hD P; omega
+      set E : Divisor K F := D - Finsupp.single P 1 with hE
+      have hEeff : ∀ v, 0 ≤ E v := by
+        intro v; rw [hE, Finsupp.sub_apply]
+        rcases eq_or_ne v P with rfl | hv
+        · rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have hdegE : Divisor.degree E = Divisor.degree D - P.deg := by
+        rw [hE, map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hDnn : 0 ≤ Divisor.degree D := Divisor.degree_nonneg_of_nonneg hD
+      have hEnn : 0 ≤ Divisor.degree E := Divisor.degree_nonneg_of_nonneg hEeff
+      have hmlt : (Divisor.degree E).toNat < m := by rw [← hm]; omega
+      have hIH := IH _ hmlt E hEeff rfl
+      have hstep := ell_le_ell_sub_single_add_deg D P
+      rw [← hE] at hstep
+      have hstep' : (ell D : ℤ) ≤ (ell E : ℤ) + P.deg := by exact_mod_cast hstep
+      rw [hdegE] at hIH
+      linarith
+
+theorem ell_le_degree_add_one_of_effective [IsCurveOver K F]
+    (hC : ConstantsAreBase K F) {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  have h := ell_le_degree_add_ellZero hD
+  rw [ell_zero_eq_one_of_constantsAreBase hC] at h
+  exact_mod_cast h
+
+def lSpaceShiftEquiv (D : Divisor K F) {g : F} (hg : g ≠ 0)
+    {Dg : Divisor K F} (hDg : ∀ v, Dg v = v.ord g) :
+    LSpace D ≃ₗ[K] LSpace (D + Dg) where
+  toFun h := ⟨(h : F) * g⁻¹, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (h : F) 0 with hh0 | hh0
+    · left; rw [hh0, zero_mul]
+    · right; intro v
+      rw [Finsupp.add_apply, hDg, v.ord_mul hh0 (inv_ne_zero hg), v.ord_inv]
+      have := (mem_lSpace_iff_ord.mp h.2).resolve_left hh0 v
+      linarith⟩
+  invFun k := ⟨(k : F) * g, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (k : F) 0 with hk0 | hk0
+    · left; rw [hk0, zero_mul]
+    · right; intro v
+      have := (mem_lSpace_iff_ord.mp k.2).resolve_left hk0 v
+      rw [Finsupp.add_apply, hDg] at this
+      rw [v.ord_mul hk0 hg]
+      linarith⟩
+  map_add' h₁ h₂ := by apply Subtype.ext; push_cast; ring
+  map_smul' c h := by
+    apply Subtype.ext
+    simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def]
+    ring
+  left_inv h := by
+    apply Subtype.ext
+    change (h : F) * g⁻¹ * g = (h : F)
+    rw [mul_assoc, inv_mul_cancel₀ hg, mul_one]
+  right_inv k := by
+    apply Subtype.ext
+    change (k : F) * g * g⁻¹ = (k : F)
+    rw [mul_assoc, mul_inv_cancel₀ hg, mul_one]
+
+theorem ell_le_degree_add_one [IsCurveOver K F] (hC : ConstantsAreBase K F)
+    {D : Divisor K F} (hD : 0 ≤ Divisor.degree D) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  rcases eq_or_ne (ell D) 0 with h0 | h0
+  · rw [h0]; push_cast; linarith
+  · have hbot : LSpace D ≠ ⊥ := fun h => h0 (by rw [ell, h, finrank_bot])
+    obtain ⟨g, hgL, hg0⟩ := (Submodule.ne_bot_iff _).mp hbot
+    obtain ⟨Dg, hDgord, hDgdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) g hg0
+    have heff : ∀ v, 0 ≤ (D + Dg) v := by
+      intro v; rw [Finsupp.add_apply, hDgord]
+      have := (mem_lSpace_iff_ord.mp hgL).resolve_left hg0 v
+      linarith
+    have hdeg : Divisor.degree (D + Dg) = Divisor.degree D := by
+      rw [map_add, hDgdeg, add_zero]
+    have hell : ell D = ell (D + Dg) :=
+      LinearEquiv.finrank_eq (lSpaceShiftEquiv D hg0 hDgord)
+    have hfin := ell_le_degree_add_one_of_effective hC heff
+    rw [hdeg] at hfin
+    rw [hell]; exact hfin
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion mk mem_bot subtype_injective mk.injEq \
+  Quotient.subsingleton_iff Quotient.mk span restrictScalars inhabited inclusion_injective \
+  comapSubtypeEquivOfLe mem_comap finrank_quotient_add_finrank mem_top Quotient.equiv mkQ mem_map \
+  coe_subtype map_smul' zero one quotientQuotientEquivQuotient coe_eq_zero finrank_le \
+  range_subtype Quotient.mk_surjective map mem_inf mem_sup Quotient.mk_eq_zero topEquiv \
+  map_injective_of_injective comap_subtype_self mapQ subsingleton_iff module smul_def mk_eq_zero \
+  coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono map_sup coe_zero"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+def nestedComapMapMkQEquiv {A B C : Submodule K X} (_hAB : A ≤ B) (hBC : B ≤ C) :
+    ((B.comap C.subtype).map (A.comap C.subtype).mkQ : Submodule K _)
+      ≃ₗ[K] B ⧸ A.comap B.subtype := by
+  set S := A.comap C.subtype with hS
+  set T := B.comap C.subtype with hT
+  let ψ : (T : Type _) →ₗ[K] (C ⧸ S) := S.mkQ ∘ₗ T.subtype
+  have hker : LinearMap.ker ψ = S.comap T.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = T.map S.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let e1 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (T.map S.mkQ : Submodule K _) :=
+    (Submodule.Quotient.equiv _ (LinearMap.ker ψ) (LinearEquiv.refl K T)
+        (by rw [hker]; simp)).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have hmap : (S.comap T.subtype).map
+      (Submodule.comapSubtypeEquivOfLe hBC : (T : Type _) →ₗ[K] B) = A.comap B.subtype := by
+    ext ⟨b, hb⟩
+    simp only [mem_map, mem_comap, Submodule.coe_subtype, hS]
+    constructor
+    · rintro ⟨⟨⟨x, hxC⟩, hxB⟩, hxA, hxeq⟩
+      have hx : x = b := congrArg Subtype.val hxeq
+      subst hx; exact hxA
+    · intro hbA
+      exact ⟨⟨⟨b, hBC hb⟩, hb⟩, hbA, rfl⟩
+  let e2 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (B ⧸ A.comap B.subtype) :=
+    Submodule.Quotient.equiv _ _ (Submodule.comapSubtypeEquivOfLe hBC) hmap
+  exact e1.symm.trans e2
+
+theorem finrank_quotient_chain {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCB : Module.Finite K (C ⧸ B.comap C.subtype)]
+    [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (C ⧸ A.comap C.subtype) ∧
+      finrank K (C ⧸ A.comap C.subtype)
+        = finrank K (C ⧸ B.comap C.subtype) + finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (T.map S.mkQ : Submodule K _) := Module.Finite.equiv eK.symm
+  have : Module.Finite K ((C ⧸ S) ⧸ T.map S.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (C ⧸ S) := Module.Finite.of_submodule_quotient (T.map S.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+theorem finrank_quotient_chain' {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCA : Module.Finite K (C ⧸ A.comap C.subtype)] :
+    Module.Finite K (C ⧸ B.comap C.subtype) ∧
+      finrank K (C ⧸ B.comap C.subtype)
+        = finrank K (C ⧸ A.comap C.subtype) - finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (C ⧸ T) := Module.Finite.equiv e3
+  refine ⟨this, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero \
+  ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono \
+  diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  residuePairing_injective WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached \
+  StichtenothGenusExists RiemannGenusBounded IndexOfSpecialtyFinite"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+def adeleBddQuotSingleEquivResidueField (D : Divisor K F) (P : Place K F) :
+    (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+      ≃ₗ[K] P.ResidueField := by
+  classical
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  let π : P.toValuationSubring :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose
+  have hπ : Irreducible π :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose_spec
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := fun {g} hg => by
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ α : Place K F → F, α ∈ adeleBdd D → t ^ (D P) * α P ∈ P.toValuationSubring := by
+    intro α hα
+    rcases eq_or_ne (α P) 0 with hg0 | hg0
+    · simp [hg0]
+    · refine P.mem_of_ord_nonneg (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have h := hα P
+      rw [P.adicValuation_eq_exp_neg_ord hg0, WithZero.exp_le_exp] at h
+      linarith
+  let ψ : adeleBdd D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun α => ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩
+      map_add' := by
+        intro α β; apply Subtype.ext
+        simp only [Submodule.coe_add, Pi.add_apply]
+        push_cast; ring
+      map_smul' := by
+        intro c α; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap, Pi.smul_apply]
+        ring }
+  have hψ_apply : ∀ α : adeleBdd D,
+      (ψ α : F) = t ^ (D P) * (α : Place K F → F) P := fun α => rfl
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : adeleBdd D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ α : adeleBdd D, φ α = 0 ↔
+      (⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := fun α => by
+    rw [show φ α = IsLocalRing.residue P.toValuationSubring
+            ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ from hres (ψ α),
+      IsLocalRing.residue_eq_zero_iff]
+  have hker : LinearMap.ker φ = (adeleBdd E).comap (adeleBdd D).subtype := by
+    ext α
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi α, P.mk_mem_maximalIdeal_iff, mem_adeleBdd]
+    have hαD := α.2
+    constructor
+    · rintro (h | h) v
+      · have hα0 : (α : Place K F → F) P = 0 := by
+          rcases mul_eq_zero.mp h with h' | h'
+          · exact absurd h' htn0
+          · exact h'
+        by_cases hv : v = P
+        · subst v; rw [hα0, Valuation.map_zero]; exact zero_le
+        · rw [hEv v hv]; exact hαD v
+      · by_cases hv : v = P
+        · subst v
+          rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+          · rw [hα0, Valuation.map_zero]; exact zero_le
+          · rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP]
+            rw [hordmul hα0] at h; omega
+        · rw [hEv v hv]; exact hαD v
+    · intro h
+      rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+      · left; rw [hα0, mul_zero]
+      · right
+        have hP := h P
+        rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP] at hP
+        rw [hordmul hα0]; omega
+  have hsurj : Function.Surjective φ := by
+    intro c
+    obtain ⟨cl, hcl⟩ := IsLocalRing.residue_surjective (R := P.toValuationSubring) c
+    set f : F := (cl : F) * t ^ (-(D P)) with hf
+    have hαD : Pi.single P f ∈ adeleBdd D := by
+      intro v
+      by_cases hv : v = P
+      · subst v
+        simp only [Pi.single_eq_same]
+        rcases eq_or_ne (cl : F) 0 with hc0 | hc0
+        · rw [hf, hc0, zero_mul, Valuation.map_zero]; exact zero_le
+        · have hf0 : f ≠ 0 := by rw [hf]; exact mul_ne_zero hc0 (zpow_ne_zero _ ht0)
+          rw [P.adicValuation_eq_exp_neg_ord hf0, WithZero.exp_le_exp]
+          rw [hf, P.ord_mul hc0 (zpow_ne_zero _ ht0), P.ord_zpow, ht1, mul_one]
+          have hclnn := P.ord_nonneg_of_mem cl.2
+          linarith
+      · rw [Pi.single_eq_of_ne hv, Valuation.map_zero]; exact zero_le
+    refine ⟨⟨Pi.single P f, hαD⟩, ?_⟩
+    change res (ψ ⟨Pi.single P f, hαD⟩) = c
+    rw [hres]
+    rw [show (ψ ⟨Pi.single P f, hαD⟩ : P.toValuationSubring) = cl from ?_, hcl]
+    apply Subtype.ext
+    rw [hψ_apply]
+    change t ^ (D P) * (Pi.single P f : Place K F → F) P = (cl : F)
+    rw [show (Pi.single P f : Place K F → F) P = f from Pi.single_eq_same _ _, hf,
+      mul_comm (cl : F), ← mul_assoc, ← zpow_add₀ ht0, add_neg_cancel, zpow_zero, one_mul]
+  exact (Submodule.Quotient.equiv _ _ (LinearEquiv.refl K _) (by rw [← hker]; simp)).trans
+    (φ.quotKerEquivOfSurjective hsurj)
+
+theorem finrank_adeleBdd_quotient_single [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    Module.Finite K
+        (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype) ∧
+      finrank K
+          (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+        = P.deg := by
+  have := IsCurveOver.finite_residueField (K := K) P
+  exact ⟨Module.Finite.equiv (adeleBddQuotSingleEquivResidueField D P).symm,
+    (adeleBddQuotSingleEquivResidueField D P).finrank_eq⟩
+
+theorem finrank_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+      (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+        = Divisor.degree D₂ - Divisor.degree D₁ := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D₁ D₂ : Divisor K F, D₁ ≤ D₂ →
+      (Divisor.degree (D₂ - D₁)).toNat = m →
+      Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+        (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+          = Divisor.degree D₂ - Divisor.degree D₁ from
+    H _ D₁ D₂ hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D₁ D₂ hD hm
+    have hEeff : ∀ v, 0 ≤ (D₂ - D₁) v := fun v => by
+      rw [Finsupp.sub_apply]; have := hD v; omega
+    by_cases hD0 : D₂ - D₁ = 0
+    · have hD12 : D₁ = D₂ := (sub_eq_zero.mp hD0).symm
+      subst hD12
+      rw [Submodule.comap_subtype_self]
+      have : Subsingleton (adeleBdd D₁ ⧸ (⊤ : Submodule K (adeleBdd D₁))) :=
+        Submodule.Quotient.subsingleton_iff.mpr rfl
+      exact ⟨Module.Finite.of_finite, by simp [Module.finrank_zero_of_subsingleton]⟩
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ (D₂ - D₁) P := by
+        have hne : (D₂ - D₁) P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hEeff P; omega
+      set D₂' : Divisor K F := D₂ - Finsupp.single P 1 with hD₂'
+      have h12' : D₁ ≤ D₂' := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]
+          have := hPpos; rw [Finsupp.sub_apply] at this; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have h2'2 : D₂' ≤ D₂ := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]
+      have hdegD₂' : Divisor.degree D₂' = Divisor.degree D₂ - P.deg := by
+        rw [hD₂', map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hEnn : 0 ≤ Divisor.degree (D₂ - D₁) := Divisor.degree_nonneg_of_nonneg hEeff
+      have hE'nn : 0 ≤ Divisor.degree (D₂' - D₁) := Divisor.degree_nonneg_of_nonneg
+        (fun v => by rw [Finsupp.sub_apply]; have := h12' v; omega)
+      have hdegdiff : Divisor.degree (D₂' - D₁) = Divisor.degree (D₂ - D₁) - P.deg := by
+        simp only [hD₂', map_sub, Divisor.degree_single, one_mul]; ring
+      have hmlt : (Divisor.degree (D₂' - D₁)).toNat < m := by rw [← hm]; omega
+      obtain ⟨hfin', hrank'⟩ := IH _ hmlt D₁ D₂' h12' rfl
+      obtain ⟨hfinS, hrankS⟩ := finrank_adeleBdd_quotient_single (K := K) D₂ P
+      rw [← hD₂'] at hfinS hrankS
+      have := hfin'; have := hfinS
+      obtain ⟨hfin, hrank⟩ := Submodule.finrank_quotient_chain
+        (A := adeleBdd D₁) (B := adeleBdd D₂') (C := adeleBdd D₂)
+        (adeleBdd_mono h12') (adeleBdd_mono h2'2)
+      refine ⟨hfin, ?_⟩
+      rw [hrank, hrankS]
+      push_cast
+      linarith [hrank', hdegD₂']
+
+theorem module_finite_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  (finrank_adeleBdd_quotient hD).1
+
+theorem finrank_adeleBdd_quotient_eq [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+      = Divisor.degree D₂ - Divisor.degree D₁ :=
+  (finrank_adeleBdd_quotient hD).2
+
+def lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (_hD : D₁ ≤ D₂) :
+    (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      →ₗ[K] (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  Submodule.mapQ _ _
+    ((diagonalHom K F).restrict
+      (p := (LSpace D₂ : Submodule K F)) (q := (adeleBdd D₂ : Submodule K _))
+      (fun f hf => diagonal_mem_adeleBdd_iff.mpr hf))
+    (fun f hf => by
+      simp only [Submodule.mem_comap, Submodule.coe_subtype] at hf ⊢
+      exact diagonal_mem_adeleBdd_iff.mpr hf)
+
+theorem lSpaceQuotientToAdeleBddQuotient_injective {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Function.Injective (lSpaceQuotientToAdeleBddQuotient hD) := by
+  rw [injective_iff_map_eq_zero]
+  intro x hx
+  obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+  rw [Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype]
+  rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk f)
+        = Submodule.Quotient.mk ((diagonalHom K F).restrict
+            (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f) from rfl,
+    Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype] at hx
+  exact diagonal_mem_adeleBdd_iff.mp hx
+
+
+theorem ell_sub_ell_le_degree_sub_degree [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)] :
+    (ell D₂ : ℤ) - (ell D₁ : ℤ) ≤ Divisor.degree D₂ - Divisor.degree D₁ := by
+  have := module_finite_adeleBdd_quotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    rw [hℓ₁]; exact (Submodule.finrank_quotient_add_finrank _).symm
+  have hemb : finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      ≤ finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+    LinearMap.finrank_le_finrank_of_injective (lSpaceQuotientToAdeleBddQuotient_injective hD)
+  have hloc := finrank_adeleBdd_quotient_eq hD
+  have : (ell D₂ : ℤ) - (ell D₁ : ℤ)
+      = (finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) : ℤ) := by
+    rw [hL]; push_cast; ring
+  rw [this, ← hloc]
+  exact_mod_cast hemb
+
+theorem adeleBdd_inf_sup_globalSub {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F)
+      = adeleBdd D₁ ⊔ adeleBdd D₂ ⊓ globalSub K F := by
+  rw [inf_comm, sup_inf_assoc_of_le _ (adeleBdd_mono hD), inf_comm]
+
+theorem map_diagonal_lSpace_inf_adeleBdd {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (LSpace D₂).map (diagonalHom K F) ⊓ adeleBdd D₁ = (LSpace D₁).map (diagonalHom K F) := by
+  rw [map_diagonal_lSpace, map_diagonal_lSpace, inf_right_comm,
+    inf_eq_right.mpr (adeleBdd_mono hD)]
+
+theorem gate_finrank_adeleBdd_quotient_single_point [IsCurveOver K F] (P : Place K F) :
+    (finrank K (adeleBdd (Finsupp.single P 1 : Divisor K F)
+        ⧸ (adeleBdd (0 : Divisor K F)).comap (adeleBdd (Finsupp.single P 1)).subtype) : ℤ)
+      = (P.deg : ℤ) := by
+  classical
+  have h01 : (0 : Divisor K F) ≤ Finsupp.single P 1 := by
+    intro v; rw [Finsupp.zero_apply, Finsupp.single_apply]; split_ifs <;> omega
+  have h := finrank_adeleBdd_quotient_eq (K := K) h01
+  rw [h, map_zero, sub_zero, Divisor.degree_single, one_mul]
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion mk mem_bot subtype_injective mk.injEq \
+  Quotient.subsingleton_iff Quotient.mk span restrictScalars inhabited inclusion_injective \
+  comapSubtypeEquivOfLe mem_comap finrank_quotient_add_finrank mem_top Quotient.equiv mkQ mem_map \
+  coe_subtype map_smul' zero one quotientQuotientEquivQuotient coe_eq_zero finrank_le \
+  range_subtype Quotient.mk_surjective map mem_inf mem_sup Quotient.mk_eq_zero topEquiv \
+  map_injective_of_injective comap_subtype_self mapQ subsingleton_iff module smul_def mk_eq_zero \
+  coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono map_sup coe_zero"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+theorem comap_subtype_sup_of_le_of_le {S T C : Submodule K X} (hS : S ≤ C) (hT : T ≤ C) :
+    S.comap C.subtype ⊔ T.comap C.subtype = (S ⊔ T).comap C.subtype := by
+  apply Submodule.map_injective_of_injective (f := C.subtype) C.subtype_injective
+  rw [Submodule.map_sup, Submodule.map_comap_subtype, Submodule.map_comap_subtype,
+    Submodule.map_comap_subtype, inf_eq_right.mpr hS, inf_eq_right.mpr hT,
+    inf_eq_right.mpr (sup_le hS hT)]
+
+theorem finrank_quotient_chain_top {M : Type*} [AddCommGroup M] [Module K M]
+    {A B : Submodule K M} (hAB : A ≤ B)
+    [hMB : Module.Finite K (M ⧸ B)] [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (M ⧸ A) ∧
+      finrank K (M ⧸ A) = finrank K (M ⧸ B) + finrank K (B ⧸ A.comap B.subtype) := by
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  let ψ : (B : Type _) →ₗ[K] (M ⧸ A) := A.mkQ ∘ₗ B.subtype
+  have hker : LinearMap.ker ψ = A.comap B.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = B.map A.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let eK : (B ⧸ A.comap B.subtype) ≃ₗ[K] (B.map A.mkQ : Submodule K (M ⧸ A)) :=
+    (Submodule.quotEquivOfEq _ _ hker.symm).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have : Module.Finite K (B.map A.mkQ : Submodule K (M ⧸ A)) := Module.Finite.equiv eK
+  have : Module.Finite K ((M ⧸ A) ⧸ B.map A.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (M ⧸ A) := Module.Finite.of_submodule_quotient (B.map A.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (B.map A.mkQ)
+  rw [LinearEquiv.finrank_eq e3, ← LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero \
+  ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono \
+  diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  residuePairing_injective WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached \
+  StichtenothGenusExists RiemannGenusBounded IndexOfSpecialtyFinite"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem globalSub_le_adeleSpace [HasPrincipalDivisors K F] :
+    globalSub K F ≤ adeleSpace K F := by
+  rintro _ ⟨f, rfl⟩
+  exact diagonal_mem_adeleSpace f
+
+theorem adeleBdd_sup_globalSub_le_adeleSpace [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+  sup_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_eq_comap [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBddPrincipal K F D = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype :=
+  Submodule.comap_subtype_sup_of_le_of_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_mono {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBddPrincipal K F D₁ ≤ adeleBddPrincipal K F D₂ :=
+  sup_le_sup_right (Submodule.comap_mono (adeleBdd_mono hD)) _
+
+section FiniteLSpace
+
+variable [IsCurveOver K F]
+
+theorem finiteDimensional_lSpace [hL0 : FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (D : Divisor K F) : FiniteDimensional K (LSpace D) := by
+  have h0D : (0 : Divisor K F) ≤ D ⊔ 0 := le_sup_right
+  have hDD : D ≤ D ⊔ 0 := le_sup_left
+  suffices h : FiniteDimensional K (LSpace (D ⊔ 0)) by
+    exact Module.Finite.of_injective (Submodule.inclusion (lSpace_mono hDD))
+      (Submodule.inclusion_injective _)
+  have := module_finite_adeleBdd_quotient (K := K) h0D
+  have hfinQ : FiniteDimensional K
+      (LSpace (D ⊔ 0) ⧸ (LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype) :=
+    Module.Finite.of_injective _ (lSpaceQuotientToAdeleBddQuotient_injective h0D)
+  have : FiniteDimensional K
+      ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype : Submodule K _) :=
+    Module.Finite.equiv (Submodule.comapSubtypeEquivOfLe (lSpace_mono h0D)).symm
+  exact Module.Finite.of_submodule_quotient
+    ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype)
+
+end FiniteLSpace
+
+
+theorem range_lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD)
+      = ((adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype).map
+          ((adeleBdd D₁).comap (adeleBdd D₂).subtype).mkQ := by
+  classical
+  ext z
+  obtain ⟨α, rfl⟩ := Submodule.Quotient.mk_surjective _ z
+  simp only [LinearMap.mem_range, Submodule.mem_map, Submodule.mem_comap, Submodule.coe_subtype,
+    Submodule.mkQ_apply]
+  constructor
+  · rintro ⟨x, hx⟩
+    obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+    have hxeq : Submodule.Quotient.mk
+        ((diagonalHom K F).restrict (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f)
+        = (Submodule.Quotient.mk α :
+            adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) := hx
+    refine ⟨α, ?_, rfl⟩
+    have hdiag2 : (diagonalHom K F (f : F)) ∈ adeleBdd D₂ := diagonal_mem_adeleBdd_iff.mpr f.2
+    have hsub : (α : Place K F → F) - diagonalHom K F (f : F) ∈ adeleBdd D₁ := by
+      have hq := (Submodule.Quotient.eq _).mp hxeq.symm
+      simpa using hq
+    refine Submodule.mem_sup.mpr ⟨(α : Place K F → F) - diagonalHom K F (f : F), hsub,
+      diagonalHom K F (f : F), diagonal_mem_globalSub _, ?_⟩
+    abel
+  · rintro ⟨β, hβ, hβeq⟩
+    have hβ' : (β : Place K F → F) ∈ adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F) :=
+      Submodule.mem_inf.mpr ⟨β.2, hβ⟩
+    rw [adeleBdd_inf_sup_globalSub hD, ← map_diagonal_lSpace] at hβ'
+    obtain ⟨γ, hγ, δ, ⟨f, hf, hfδ⟩, hsum⟩ := Submodule.mem_sup.mp hβ'
+    refine ⟨Submodule.Quotient.mk ⟨f, hf⟩, ?_⟩
+    rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk ⟨f, hf⟩)
+          = Submodule.Quotient.mk ((diagonalHom K F).restrict
+              (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) ⟨f, hf⟩) from rfl,
+      ← hβeq, Submodule.Quotient.eq]
+    refine Submodule.mem_comap.mpr ?_
+    change diagonalHom K F f - (β : Place K F → F) ∈ adeleBdd D₁
+    have hβsub : diagonalHom K F f - (β : Place K F → F) = -γ := by
+      rw [← hsum, hfδ]; ring
+    rw [hβsub]; exact (adeleBdd D₁).neg_mem hγ
+
+
+theorem finrank_adeleBddSup_quotient [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) [hL : FiniteDimensional K (LSpace D₂)] :
+    Module.Finite K (↥(adeleBdd D₂ ⊔ globalSub K F)
+        ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) ∧
+      (finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+          ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) : ℤ)
+        = (Divisor.degree D₂ - ell D₂) - (Divisor.degree D₁ - ell D₁) := by
+  classical
+  let A : Submodule K (adeleBdd D₂) := (adeleBdd D₁).comap (adeleBdd D₂).subtype
+  let B : Submodule K (adeleBdd D₂) :=
+    (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype
+  have hAB : A ≤ B := Submodule.comap_mono le_sup_left
+  have hfinA : Module.Finite K (adeleBdd D₂ ⧸ A) := module_finite_adeleBdd_quotient hD
+  have hdimA : (finrank K (adeleBdd D₂ ⧸ A) : ℤ) = Divisor.degree D₂ - Divisor.degree D₁ :=
+    finrank_adeleBdd_quotient_eq hD
+  have hran : LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD) = B.map A.mkQ :=
+    range_lSpaceQuotientToAdeleBddQuotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hdimL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K)
+      ((LSpace D₁).comap (LSpace D₂).subtype)
+    rw [← hℓ₁] at h; exact h.symm
+  have hdimB : ell D₂ = finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) + ell D₁ := by
+    rw [← hran, LinearMap.finrank_range_of_inj
+      (lSpaceQuotientToAdeleBddQuotient_injective hD)]
+    exact hdimL
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  have hfinB : Module.Finite K (adeleBdd D₂ ⧸ B) := Module.Finite.equiv e3
+  have hdim2 : finrank K (adeleBdd D₂ ⧸ A)
+      = finrank K (adeleBdd D₂ ⧸ B) + finrank K (B.map A.mkQ : Submodule K _) := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K) (M := adeleBdd D₂ ⧸ A)
+      (B.map A.mkQ)
+    rw [LinearEquiv.finrank_eq e3] at h; omega
+  have e2 := LinearMap.quotientInfEquivSupQuotient (R := K)
+    (adeleBdd D₂) (adeleBdd D₁ ⊔ globalSub K F)
+  have hsup : adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F) = adeleBdd D₂ ⊔ globalSub K F := by
+    rw [← sup_assoc, sup_eq_left.mpr (adeleBdd_mono hD)]
+  have hB' : (adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype = B := by
+    rw [Submodule.comap_subtype_self, top_inf_eq]
+  let eL : (adeleBdd D₂ ⧸ B) ≃ₗ[K]
+      (adeleBdd D₂ ⧸ ((adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+        (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype)) :=
+    Submodule.quotEquivOfEq _ _ hB'.symm
+  have hfin_iso : Module.Finite K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype) :=
+    Module.Finite.equiv (eL.trans e2)
+  have hdim_iso : finrank K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype)
+      = finrank K (adeleBdd D₂ ⧸ B) :=
+    (LinearEquiv.finrank_eq (eL.trans e2)).symm
+  have hcast : (finrank K (adeleBdd D₂ ⧸ A) : ℤ)
+      = (finrank K (adeleBdd D₂ ⧸ B) : ℤ) + ((ell D₂ : ℤ) - (ell D₁ : ℤ)) := by
+    have hb : (ell D₂ : ℤ)
+        = (finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) : ℤ) + (ell D₁ : ℤ) := by
+      exact_mod_cast hdimB
+    push_cast [hdim2]; linarith
+  have hgoal : (finrank K (adeleBdd D₂ ⧸ B) : ℤ)
+      = Divisor.degree D₂ - ↑(ell D₂) - (Divisor.degree D₁ - ↑(ell D₁)) := by
+    linarith [hdimA, hcast]
+  clear_value eL
+  exact hsup ▸ ⟨hfin_iso, by rw [hdim_iso]; exact hgoal⟩
+
+section Index
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+
+theorem adeleBddSup_eq_of_degree_sub_ell_eq {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)]
+    (heq : Divisor.degree D₂ - ell D₂ = Divisor.degree D₁ - ell D₁) :
+    adeleBdd D₂ ⊔ globalSub K F = adeleBdd D₁ ⊔ globalSub K F := by
+  obtain ⟨hfin, hdim⟩ := finrank_adeleBddSup_quotient hD
+  rw [heq, sub_self] at hdim
+  refine le_antisymm ?_ (sup_le_sup_right (adeleBdd_mono hD) _)
+  have := hfin
+  have hd0 : finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) = 0 := by
+    exact_mod_cast hdim
+  have hsub : Subsingleton (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) :=
+    Module.finrank_zero_iff.mp hd0
+  have htop := Submodule.Quotient.subsingleton_iff.mp hsub
+  intro x hx
+  have hxc : (⟨x, hx⟩ : ↥(adeleBdd D₂ ⊔ globalSub K F)) ∈
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype := by
+    rw [htop]; exact Submodule.mem_top
+  exact hxc
+
+end Index
+
+namespace RiemannGenusReachedAt
+p2m_export "AlgebraicCurve.RiemannGenusReachedAt" "finite mk eq isMax"
+end RiemannGenusReachedAt
+namespace RiemannGenusReachedAt
+p2m_open_scoped "AlgebraicCurve.RiemannGenusReachedAt" in
+private theorem _root_.AlgebraicCurve.RiemannGenusReachedAt.eq_of_ge [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {D : Divisor K F} (hD : D₀ ≤ D) :
+    Divisor.degree D - ell D = γ - 1 := by
+  have := finiteDimensional_lSpace (K := K) D
+  have hge : Divisor.degree D₀ - (ell D₀ : ℤ) ≤ Divisor.degree D - ell D := by
+    have := ell_sub_ell_le_degree_sub_degree (K := K) hD
+    linarith
+  exact le_antisymm (h.isMax D) (h.eq ▸ hge)
+
+end RiemannGenusReachedAt
+p2m_export "AlgebraicCurve" "RiemannGenusReachedAt.eq_of_ge"
+
+theorem adeleSpace_eq_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    adeleSpace K F = adeleBdd D₀ ⊔ globalSub K F := by
+  refine le_antisymm ?_ (adeleBdd_sup_globalSub_le_adeleSpace D₀)
+  rw [adeleSpace, iSup_le_iff]
+  intro D
+  refine le_trans (adeleBdd_mono (le_sup_left : D ≤ D ⊔ D₀)) ?_
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have heq : Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) = Divisor.degree D₀ - ell D₀ :=
+    (h.eq_of_ge le_sup_right).trans h.eq.symm
+  have hsup := adeleBddSup_eq_of_degree_sub_ell_eq (K := K)
+    (le_sup_right : D₀ ≤ D ⊔ D₀) heq
+  rw [← hsup]
+  exact le_sup_left
+
+theorem indexOfSpecialty_eq_zero_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    indexOfSpecialty D₀ = 0 := by
+  rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap, ← adeleSpace_eq_of_genusReached h,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.finrank_zero_of_subsingleton
+
+
+
+theorem gate_indexOfSpecialty_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  have h1 := (indexOfSpecialty_eq_of_genusReached h D₀).2
+  have h2 := h.eq
+  have h3 := indexOfSpecialty_eq_zero_of_genusReached h
+  exact_mod_cast h3
+
+theorem gate_riemannInequality_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Divisor.degree D + 1 - γ ≤ (ell D : ℤ) := by
+  have heq := (indexOfSpecialty_eq_of_genusReached h D).2
+  have hnn : (0 : ℤ) ≤ indexOfSpecialty D := Int.natCast_nonneg _
+  linarith
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero \
+  ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono \
+  diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  residuePairing_injective WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached \
+  StichtenothGenusExists RiemannGenusBounded IndexOfSpecialtyFinite"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem adeleSpaceMul_add [HasPrincipalDivisors K F] (f g : F) :
+    adeleSpaceMul K F (f + g) = adeleSpaceMul K F f + adeleSpaceMul K F g := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, LinearMap.add_apply, Submodule.coe_add,
+    Pi.add_apply, add_mul]
+
+theorem adeleSpaceMul_zero [HasPrincipalDivisors K F] :
+    adeleSpaceMul K F (0 : F) = 0 := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, zero_mul, LinearMap.zero_apply,
+    Submodule.coe_zero, Pi.zero_apply]
+
+theorem weilSmul_add_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f + g) φ = weilSmul K F f φ + weilSmul K F g φ := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_add, LinearMap.add_apply, map_add]
+
+theorem weilSmul_zero_left [HasPrincipalDivisors K F]
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (0 : F) φ = 0 := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_zero, LinearMap.zero_apply, map_zero]
+
+theorem weilSmul_neg_left [HasPrincipalDivisors K F] (f : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (-f) φ = -weilSmul K F f φ := by
+  have h := weilSmul_add_left (K := K) (F := F) f (-f) φ
+  rw [add_neg_cancel, weilSmul_zero_left] at h
+  exact (neg_eq_of_add_eq_zero_right h.symm).symm
+
+theorem weilSmul_sub_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f - g) φ = weilSmul K F f φ - weilSmul K F g φ := by
+  rw [sub_eq_add_neg, weilSmul_add_left, weilSmul_neg_left, sub_eq_add_neg]
+
+theorem weilSmul_eq_zero_iff_left [HasPrincipalDivisors K F]
+    {f : F} {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    weilSmul K F f φ = 0 ↔ f = 0 := by
+  refine ⟨fun h => ?_, fun h => h ▸ weilSmul_zero_left φ⟩
+  by_contra hf
+  exact hφ (weilSmul_injective hf (h.trans (map_zero (weilSmul K F f)).symm))
+
+theorem weilSmul_left_injective [HasPrincipalDivisors K F]
+    {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    Function.Injective (fun f : F => weilSmul K F f φ) := by
+  intro f g hfg
+  have hsub : weilSmul K F (f - g) φ = 0 := by
+    rw [weilSmul_sub_left, sub_eq_zero]; exact hfg
+  exact sub_eq_zero.mp ((weilSmul_eq_zero_iff_left hφ).mp hsub)
+
+variable (K F) in
+def doubleResiduePairing [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) :
+    LSpace (W - D) × LSpace (W - D) →ₗ[K] omegaSpace D :=
+  (residuePairing K F W D hφ).coprod (residuePairing K F W D hμ)
+
+theorem doubleResiduePairing_apply_coe [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (g h : LSpace (W - D)) :
+    (doubleResiduePairing K F W D hφ hμ (g, h) : Module.Dual K (adeleSpace K F))
+      = weilSmul K F (g : F) φ + weilSmul K F (h : F) μ := by
+  simp only [doubleResiduePairing, LinearMap.coprod_apply, Submodule.coe_add,
+    residuePairing_apply_coe]
+
+theorem doubleResiduePairing_injective [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ) :
+    Function.Injective (doubleResiduePairing K F W D hφ hμ) := by
+  rw [injective_iff_map_eq_zero]
+  rintro ⟨g, h⟩ heq
+  have heq' : weilSmul K F (g : F) φ + weilSmul K F (h : F) μ = 0 := by
+    have hcoe := congrArg Subtype.val heq
+    rwa [doubleResiduePairing_apply_coe, Submodule.coe_zero] at hcoe
+  rcases eq_or_ne (h : F) 0 with hh0 | hh0
+  · rw [hh0, weilSmul_zero_left, add_zero] at heq'
+    have hg0 : (g : F) = 0 := (weilSmul_eq_zero_iff_left hφ0).mp heq'
+    exact Prod.ext (Subtype.ext hg0) (Subtype.ext hh0)
+  · exfalso
+    have hμeq : weilSmul K F (h : F) μ = -weilSmul K F (g : F) φ := by
+      have h2 : weilSmul K F (h : F) μ + weilSmul K F (g : F) φ = 0 := by
+        rw [add_comm]; exact heq'
+      exact eq_neg_of_add_eq_zero_left h2
+    have hLHS : weilSmul K F (h : F)⁻¹ (weilSmul K F (h : F) μ) = μ := by
+      rw [← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hh0, weilSmul_one,
+        LinearMap.id_apply]
+    have hRHS : weilSmul K F (h : F)⁻¹ (-weilSmul K F (g : F) φ)
+        = weilSmul K F (-(g : F) * (h : F)⁻¹) φ := by
+      rw [map_neg, ← LinearMap.comp_apply, ← weilSmul_mul, neg_mul, weilSmul_neg_left]
+    exact hindep (-(g : F) * (h : F)⁻¹) (by rw [← hLHS, hμeq, hRHS])
+
+theorem two_mul_ell_le_indexOfSpecialty [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ)
+    [Module.Finite K (omegaSpace (K := K) (F := F) D)]
+    [Module.Finite K (LSpace (K := K) (F := F) (W - D))] :
+    2 * ell (W - D) ≤ indexOfSpecialty D := by
+  have hinj := doubleResiduePairing_injective W D hφ hμ hφ0 hindep
+  have hle := LinearMap.finrank_le_finrank_of_injective hinj
+  rw [Module.finrank_prod] at hle
+  rw [← finrank_omegaSpace_eq_indexOfSpecialty, two_mul]
+  exact hle
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero \
+  ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono \
+  diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  residuePairing_injective WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached \
+  StichtenothGenusExists RiemannGenusBounded IndexOfSpecialtyFinite"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+section Finiteness
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+theorem omegaSpace_finite_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Module.Finite K (omegaSpace (K := K) (F := F) D) := by
+  have := (indexOfSpecialty_eq_of_genusReached h D).1
+  exact Module.Finite.equiv (omegaSpaceEquivIndexDual D).symm
+
+end Finiteness
+
+section ParametricRankOne
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+
+theorem exists_weilSmul_eq_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {φ μ : Module.Dual K (adeleSpace K F)} {W : Divisor K F}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (hφ0 : φ ≠ 0) :
+    ∃ f : F, μ = weilSmul K F f φ := by
+  by_contra hcon
+  push Not at hcon
+  obtain ⟨P⟩ := ‹Nonempty (Place K F)›
+  set n : ℕ := 3 * γ.natAbs + 2 * (Divisor.degree W).natAbs + 4 with hn
+  set D : Divisor K F := -Finsupp.single P (n : ℤ) with hD
+  have hdegD : Divisor.degree D = -(n : ℤ) * (P.deg : ℤ) := by
+    rw [hD, map_neg, Divisor.degree_single]; ring
+  have hdegWD : Divisor.degree (W - D) = Divisor.degree W + (n : ℤ) * (P.deg : ℤ) := by
+    rw [map_sub, hdegD]; ring
+  have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+  have habsγ : -(|γ|) ≤ γ ∧ γ ≤ |γ| := ⟨neg_abs_le _, le_abs_self _⟩
+  have habsW : -|Divisor.degree W| ≤ Divisor.degree W ∧
+      Divisor.degree W ≤ |Divisor.degree W| := ⟨neg_abs_le _, le_abs_self _⟩
+  have hn_ge : 3 * |γ| + 2 * |Divisor.degree W| + 4 ≤ (n : ℤ) := by
+    rw [hn]; push_cast [Int.natCast_natAbs]; ring_nf; omega
+  have hndegP : (n : ℤ) ≤ (n : ℤ) * (P.deg : ℤ) := by nlinarith [Int.natCast_nonneg n]
+  have hellD : ell D = 0 := ell_eq_zero_of_degree_neg (by rw [hdegD]; nlinarith)
+  have hiD : (indexOfSpecialty D : ℤ) = (n : ℤ) * (P.deg : ℤ) - 1 + γ := by
+    have hidx := (indexOfSpecialty_eq_of_genusReached h D).2
+    rw [hellD, hdegD] at hidx; push_cast at hidx; linarith
+  have hlowerWD : Divisor.degree W + (n : ℤ) * (P.deg : ℤ) + 1 - γ
+      ≤ (ell (W - D) : ℤ) := by
+    have hlow := gate_riemannInequality_of_genusReached h (W - D)
+    rw [hdegWD] at hlow; exact hlow
+  have := omegaSpace_finite_of_genusReached h D
+  have := finiteDimensional_lSpace (K := K) (W - D)
+  have hdbl : (2 * ell (W - D) : ℤ) ≤ (indexOfSpecialty D : ℤ) := by
+    exact_mod_cast two_mul_ell_le_indexOfSpecialty W D hφ hμ hφ0 hcon
+  rw [hiD] at hdbl
+  nlinarith [habsγ.1, habsγ.2, habsW.1, habsW.2]
+
+theorem weilDifferentialRankOne_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    WeilDifferentialRankOne K F := by
+  intro φ hφmem hφ0 μ hμmem
+  obtain ⟨W₁, hφW₁⟩ := mem_weilDifferentialModule_iff.mp hφmem
+  obtain ⟨W₂, hμW₂⟩ := mem_weilDifferentialModule_iff.mp hμmem
+  have hφW : φ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_left hφW₁
+  have hμW : μ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_right hμW₂
+  obtain ⟨f, hf⟩ := exists_weilSmul_eq_of_genusReached h hφW hμW hφ0
+  exact ⟨f, hf, fun f' hf' => weilSmul_left_injective hφ0 (hf'.symm.trans hf)⟩
+
+end ParametricRankOne
+
+theorem residuePairing_surjective_of_rankOne_max [HasPrincipalDivisors K F]
+    (hRankOne : WeilDifferentialRankOne K F)
+    {W : Divisor K F} {φ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hφ0 : φ ≠ 0)
+    (hWmax : ∀ E : Divisor K F, φ ∈ omegaSpace E → E ≤ W) (D : Divisor K F) :
+    Function.Surjective (residuePairing K F W D hφ) := by
+  rintro ⟨μ, hμD⟩
+  have hφmem : φ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule W hφ
+  have hμmem : μ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule D hμD
+  obtain ⟨f, hf, -⟩ := hRankOne hφmem hφ0 hμmem
+  rcases eq_or_ne f 0 with rfl | hf0
+  · have hμ0 : (⟨μ, hμD⟩ : omegaSpace D) = 0 :=
+      Subtype.ext (hf.trans (weilSmul_zero_left φ))
+    exact ⟨0, (map_zero _).trans hμ0.symm⟩
+  · obtain ⟨P, hPord, _⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+    have hPinv : ∀ v, (-P) v = v.ord f⁻¹ := fun v => by
+      rw [Finsupp.neg_apply, hPord v, v.ord_inv]
+    have hinv : weilSmul K F f⁻¹ μ = φ := by
+      rw [hf, ← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hf0, weilSmul_one,
+        LinearMap.id_apply]
+    have hφD : φ ∈ omegaSpace (D + -P) := by
+      rw [← hinv]; exact weilSmul_mem_omegaSpace_add (inv_ne_zero hf0) hPinv hμD
+    have hDP : D + -P ≤ W := hWmax _ hφD
+    have hfL : f ∈ LSpace (W - D) := by
+      rw [mem_lSpace_iff_ord]; refine Or.inr fun v => ?_
+      have hv := hDP v
+      rw [Finsupp.add_apply, Finsupp.neg_apply, hPord v] at hv
+      rw [Finsupp.sub_apply]; linarith
+    exact ⟨⟨f, hfL⟩, Subtype.ext hf.symm⟩
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero \
+  ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono \
+  diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  residuePairing_injective WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached \
+  StichtenothGenusExists RiemannGenusBounded IndexOfSpecialtyFinite"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem exists_riemannGenusReachedAt_of_bounded
+    [IsCurveOver K F] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    ∃ (γ : ℤ) (D₀ : Divisor K F), RiemannGenusReachedAt γ D₀ := by
+  obtain ⟨γ, hγ⟩ := hbdd
+  obtain ⟨M, ⟨D₀, hD₀⟩, hMmax⟩ :=
+    Int.exists_greatest_of_bdd
+      (P := fun n => ∃ D : Divisor K F, Divisor.degree D - ell D = n)
+      ⟨γ, fun n ⟨D, hD⟩ => hD ▸ hγ D⟩
+      ⟨Divisor.degree (0 : Divisor K F) - ell (0 : Divisor K F), 0, rfl⟩
+  refine ⟨M + 1, D₀, ?_, ?_, ?_⟩
+  · exact finiteDimensional_lSpace D₀
+  · rw [hD₀]; ring
+  · intro D
+    have := hMmax (Divisor.degree D - ell D) ⟨D, rfl⟩
+    linarith
+
+theorem stichtenothGenusExists_of_bounded
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    StichtenothGenusExists K F :=
+  ⟨‹_›, ‹_›, exists_riemannGenusReachedAt_of_bounded hbdd⟩
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero \
+  ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono \
+  diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  residuePairing_injective WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached \
+  StichtenothGenusExists RiemannGenusBounded IndexOfSpecialtyFinite"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem mul_mem_lSpace_add {D E : Divisor K F} {f g : F}
+    (hf : f ∈ LSpace D) (hg : g ∈ LSpace E) :
+    f * g ∈ LSpace (D + E) := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · rw [zero_mul]; exact (LSpace _).zero_mem
+  rcases eq_or_ne g 0 with rfl | hg0
+  · rw [mul_zero]; exact (LSpace _).zero_mem
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun v => ?_
+  rw [Finsupp.add_apply, neg_add, v.ord_mul hf0 hg0]
+  exact add_le_add ((mem_lSpace_iff_ord.mp hf).resolve_left hf0 v)
+    ((mem_lSpace_iff_ord.mp hg).resolve_left hg0 v)
+
+theorem pow_mem_lSpace_nsmul {B : Divisor K F} {f : F} (hf : f ∈ LSpace B) (j : ℕ) :
+    f ^ j ∈ LSpace (j • B) := by
+  induction j with
+  | zero => simpa using one_mem_lSpace_zero (K := K) (F := F)
+  | succ j ih =>
+    rw [pow_succ, succ_nsmul]
+    exact mul_mem_lSpace_add ih hf
+
+structure PoleDivisorPackage (K F : Type*) [Field K] [Field F] [Algebra K F] where
+  x : F
+  B : Divisor K F
+  hB_eff : 0 ≤ B
+  hx_mem : x ∈ LSpace B
+  n : ℕ
+  hn_pos : 0 < n
+  degB_eq : Divisor.degree B = n
+  c : ℕ
+  u : Fin n → F
+  hu_mem : ∀ i, u i ∈ LSpace (c • B)
+  lin_indep : LinearIndependent K (fun p : ℕ × Fin n => x ^ p.1 * u p.2)
+
+variable (K F) in
+def HasPoleDivisorPackage : Prop := Nonempty (PoleDivisorPackage K F)
+
+namespace PoleDivisorPackage
+
+variable (P : PoleDivisorPackage K F)
+
+theorem pow_mul_u_mem_lSpace (j : ℕ) (i : Fin P.n) :
+    P.x ^ j * P.u i ∈ LSpace ((j + P.c) • P.B) := by
+  rw [add_nsmul]
+  exact mul_mem_lSpace_add (pow_mem_lSpace_nsmul P.hx_mem j) (P.hu_mem i)
+
+theorem pow_mul_u_mem_lSpace_of_le {j m : ℕ} (hjm : j + P.c ≤ m) (i : Fin P.n) :
+    P.x ^ j * P.u i ∈ LSpace (m • P.B) := by
+  refine lSpace_mono ?_ (P.pow_mul_u_mem_lSpace j i)
+  intro v
+  have hBv : (0 : ℤ) ≤ P.B v := P.hB_eff v
+  change ((j + P.c) • P.B) v ≤ (m • P.B) v
+  simp only [Finsupp.smul_apply, nsmul_eq_mul]
+  exact mul_le_mul_of_nonneg_right (by exact_mod_cast hjm) hBv
+
+
+theorem ell_nsmul_poleDivisor_ge [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    (P.n : ℤ) * (m - P.c + 1) ≤ ell (m • P.B) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  set g : Fin (m - P.c + 1) × Fin P.n → LSpace (m • P.B) :=
+    fun p => ⟨P.x ^ (p.1 : ℕ) * P.u p.2,
+      P.pow_mul_u_mem_lSpace_of_le (by have := p.1.isLt; omega) p.2⟩
+    with hgdef
+  have hsub : LinearIndependent K (fun p => (g p : F)) := by
+    have heq : (fun p => (g p : F))
+        = (fun p : ℕ × Fin P.n => P.x ^ p.1 * P.u p.2)
+            ∘ (fun p : Fin (m - P.c + 1) × Fin P.n => ((p.1 : ℕ), p.2)) := by
+      funext p; rfl
+    rw [heq]
+    refine P.lin_indep.comp _ ?_
+    intro p q hpq
+    simp only [Prod.mk.injEq] at hpq
+    exact Prod.ext (Fin.val_injective hpq.1) hpq.2
+  have hg : LinearIndependent K g := hsub.of_comp (LSpace (m • P.B)).subtype
+  have hcard := hg.fintype_card_le_finrank
+  rw [Fintype.card_prod, Fintype.card_fin, Fintype.card_fin] at hcard
+  have hZ : ((m - P.c + 1) * P.n : ℤ) ≤ (ell (m • P.B) : ℤ) := by exact_mod_cast hcard
+  have heq : (((m - P.c + 1 : ℕ) : ℤ) * P.n : ℤ) = (P.n : ℤ) * ((m : ℤ) - P.c + 1) := by
+    rw [Nat.cast_add, Nat.cast_sub hm, Nat.cast_one]; ring
+  linarith
+
+theorem degree_nsmul_sub_ell_le [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    Divisor.degree (m • P.B) - ell (m • P.B) ≤ (P.n : ℤ) * (P.c - 1) := by
+  have hge := P.ell_nsmul_poleDivisor_ge hm
+  have hdeg : Divisor.degree (m • P.B) = (m : ℤ) * P.n := by
+    rw [show m • P.B = (m : ℤ) • P.B from (natCast_zsmul _ _).symm,
+      Divisor.degree.map_zsmul, smul_eq_mul, P.degB_eq]
+  linarith
+
+end PoleDivisorPackage
+
+theorem PoleDivisorPackage.ell_nsmul_sub_pos [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) {A : Divisor K F} (hA : 0 ≤ A) {m : ℕ} (hm : P.c ≤ m)
+    (hbig : Divisor.degree A < (P.n : ℤ) * (m - P.c + 1)) :
+    0 < ell (m • P.B - A) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  have hle : m • P.B - A ≤ m • P.B := by
+    intro v
+    have hAv : (0 : ℤ) ≤ A v := hA v
+    rw [Finsupp.sub_apply]
+    linarith
+  have h48 := ell_sub_ell_le_degree_sub_degree (K := K) hle
+  rw [map_sub, sub_sub_cancel] at h48
+  have h412 := P.ell_nsmul_poleDivisor_ge hm
+  have : (0 : ℤ) < (ell (m • P.B - A) : ℤ) := by linarith
+  exact_mod_cast this
+
+
+theorem PoleDivisorPackage.degree_sub_ell_le [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) (D : Divisor K F) :
+    Divisor.degree D - ell D ≤ (P.n : ℤ) * (P.c - 1) := by
+  classical
+  set D' : Divisor K F := D ⊔ 0 with hD'def
+  have hD'eff : 0 ≤ D' := le_sup_right
+  have hDD' : D ≤ D' := le_sup_left
+  have := finiteDimensional_lSpace (K := K) D'
+  have hmono : Divisor.degree D - (ell D : ℤ) ≤ Divisor.degree D' - ell D' := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hDD'
+    linarith
+  set m : ℕ := P.c + (Divisor.degree D').toNat with hmdef
+  have hcm : P.c ≤ m := Nat.le_add_right _ _
+  have hdegD' : 0 ≤ Divisor.degree D' := Divisor.degree_nonneg_of_nonneg hD'eff
+  have hbig : Divisor.degree D' < (P.n : ℤ) * (m - P.c + 1) := by
+    have hcast : ((m : ℤ) - P.c) = Divisor.degree D' := by
+      simp only [hmdef, Nat.cast_add, add_sub_cancel_left, Int.toNat_of_nonneg hdegD']
+    rw [hcast]
+    have hn1 : (1 : ℤ) ≤ P.n := by exact_mod_cast P.hn_pos
+    nlinarith
+  have hellpos := P.ell_nsmul_sub_pos hD'eff hcm hbig
+  have hnebot : LSpace (m • P.B - D') ≠ ⊥ :=
+    fun h => by rw [ell, h, finrank_bot] at hellpos; exact lt_irrefl 0 hellpos
+  obtain ⟨z, hzL, hz0⟩ := (Submodule.ne_bot_iff _).mp hnebot
+  obtain ⟨Dz, hDzord, hDzdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) z hz0
+  have hzmem := (mem_lSpace_iff_ord.mp hzL).resolve_left hz0
+  have hD'le : D' ≤ m • P.B + Dz := by
+    intro v
+    have := hzmem v
+    simp only [Finsupp.add_apply, Finsupp.sub_apply, neg_sub] at this ⊢
+    rw [hDzord]; linarith
+  have hellshift : ell (m • P.B + Dz) = ell (m • P.B) :=
+    (LinearEquiv.finrank_eq (lSpaceShiftEquiv (m • P.B) hz0 hDzord)).symm
+  have hdegshift : Divisor.degree (m • P.B + Dz) = Divisor.degree (m • P.B) := by
+    rw [map_add, hDzdeg, add_zero]
+  have := finiteDimensional_lSpace (K := K) (m • P.B + Dz)
+  have hmono' : Divisor.degree D' - (ell D' : ℤ)
+      ≤ Divisor.degree (m • P.B + Dz) - ell (m • P.B + Dz) := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hD'le
+    linarith
+  rw [hellshift, hdegshift] at hmono'
+  have h412 := P.degree_nsmul_sub_ell_le hcm
+  linarith
+
+theorem riemannGenusBounded_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    RiemannGenusBounded K F :=
+  ⟨(P.n : ℤ) * (P.c - 1), P.degree_sub_ell_le⟩
+
+theorem stichtenothGenusExists_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_bounded (riemannGenusBounded_of_poleDivisorPackage P)
+
+end AlgebraicCurve
+
+end
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero \
+  ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono \
+  diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  residuePairing_injective WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached \
+  StichtenothGenusExists RiemannGenusBounded IndexOfSpecialtyFinite"
+p2m_open "AlgebraicCurve"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem weilDifferentialRankOne_of_stichtenothGenusExists [IsCurveOver K F]
+    (h : StichtenothGenusExists K F) : WeilDifferentialRankOne K F := by
+  obtain ⟨hne, hfin, γ, D₀, hγ⟩ := h
+  have := hne; have := hfin
+  intro φ hφ hφ0 μ hμ
+  exact weilDifferentialRankOne_of_genusReached hγ hφ hφ0 hμ
+
+theorem indexOfSpecialty_eq_ell_sub_of_rankOne_max [HasPrincipalDivisors K F]
+    (hRankOne : WeilDifferentialRankOne K F)
+    {W : Divisor K F} {φ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hφ0 : φ ≠ 0)
+    (hWmax : ∀ E : Divisor K F, φ ∈ omegaSpace E → E ≤ W) (D : Divisor K F) :
+    indexOfSpecialty D = ell (W - D) := by
+  rw [← finrank_omegaSpace_eq_indexOfSpecialty]
+  exact (LinearEquiv.ofBijective (residuePairing K F W D hφ)
+    ⟨residuePairing_injective W D hφ hφ0, residuePairing_surjective_of_rankOne_max hRankOne hφ hφ0
+      hWmax D⟩).finrank_eq.symm
+
+theorem exists_genus_riemannIndex_of_stichtenothGenusExists_port [IsCurveOver K F]
+    (h : StichtenothGenusExists K F) :
+    ∃ γ : ℤ, ∀ D : Divisor K F,
+      Module.Finite K (↥(adeleSpace K F) ⧸ adeleBddPrincipal K F D) ∧
+        (indexOfSpecialty D : ℤ) = (ell D : ℤ) - (Divisor.degree D + 1 - γ) := by
+  obtain ⟨hne, hfin, γ, D₀, hγ⟩ := h
+  have := hne; have := hfin
+  exact ⟨γ, fun D => indexOfSpecialty_eq_of_genusReached hγ D⟩
+end AlgebraicCurve
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_exists_genus_riemannIndex_of_stichtenothGenusExists.AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F]
+    (h : StichtenothGenusExists K F) :
+    ∃ γ : ℤ, ∀ D : Divisor K F,
+      Module.Finite K (↥(adeleSpace K F) ⧸ adeleBddPrincipal K F D) ∧
+        (indexOfSpecialty D : ℤ) = (ell D : ℤ) - (Divisor.degree D + 1 - γ) :=
+  AlgebraicCurve.exists_genus_riemannIndex_of_stichtenothGenusExists_port (K := K) (F := F) (h := h)
+
+end S_AlgebraicCurve_exists_genus_riemannIndex_of_stichtenothGenusExists
+end P2MW
+export P2MW.S_AlgebraicCurve_exists_genus_riemannIndex_of_stichtenothGenusExists (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace AlgebraicCurve
+theorem exists_genus_riemannIndex_of_stichtenothGenusExists {K F : Type*} [Field K] [Field F]
+    [Algebra K F] [IsCurveOver K F]
+    (h : StichtenothGenusExists K F) :
+    ∃ γ : ℤ, ∀ D : Divisor K F,
+      Module.Finite K (↥(adeleSpace K F) ⧸ adeleBddPrincipal K F D) ∧
+        (indexOfSpecialty D : ℤ) = (ell D : ℤ) - (Divisor.degree D + 1 - γ) :=
+  solution h
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_indexOfSpecialty_mapDomain_eq_zero_of_constantFieldExtension_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_indexOfSpecialty_mapDomain_eq_zero_of_constantFieldExtension_of_isAlgClosed.lean
new file mode 100644
index 0000000000..030235b9d1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_indexOfSpecialty_mapDomain_eq_zero_of_constantFieldExtension_of_isAlgClosed.lean
@@ -0,0 +1,176 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.exists_indexOfSpecialty_mapDomain_eq_zero_of_constantFieldExtension_of_isAlgClosed
+(2180e045-2644-53c7-835e-9f68ce3e16bf) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ae12884e-7881-5bc6-a9c3-f97debf16c71
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_essFiniteType_of_transcendental_of_finiteDimensional
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_riemannGenusReachedAt_nsmul_single_of_stichtenothGenusExists
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_zero_of_genusReached
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_stichtenothGenusExists_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Vanishing index of specialty for a lifted divisor
+
+Theorem statement:
+`AlgebraicCurve.exists_indexOfSpecialty_mapDomain_eq_zero_of_constantFieldExtension_of_isAlgClosed`
+(`2180e045-2644-53c7-835e-9f68ce3e16bf`), by Claude, 2026-09-05.
+
+Proof: submission `ae12884e-7881-5bc6-a9c3-f97debf16c71`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $K'$, $F'$ be fields with algebra structures $K \to F$, $K' \to F'$, $K \to K'$, $F
+\to F'$ and $K \to F'$, the last compatible with the towers $K \to K' \to F'$ and $K \to F \to F'$,
+and let $K$ and $K'$ be algebraically closed. Assume there is an element $x \in F$ transcendental
+over $K$ with $F$ finite-dimensional over $K(x)$, and likewise an element $x' \in F'$ transcendental
+over $K'$ with $F'$ finite-dimensional over $K'(x')$. Assume $F/K$ and $F'/K'$ satisfy
+`IsCurveOver`: every nonzero element has a degree-zero divisor recording its orders at all places,
+every residue field of a place is finite over the base field, and the module of Kähler differentials
+is free of rank one over the function field; here a place is a valuation subring of the function
+field, containing the image of the base field, distinct from the whole field and a principal ideal
+ring, and a divisor is a finitely supported integer-valued function on places. Assume further that
+$K'$ adjoined to the image of $F$ in $F'$ is all of $F'$, and that $\mathrm{lift} :
+\mathrm{Place}\,K\,F \to \mathrm{Place}\,K'\,F'$ is injective and satisfies
+$\operatorname{ord}_{\mathrm{lift}(P)}(f) = \operatorname{ord}_P(f)$ for every place $P$ of $F/K$
+and every $f \in F$, where $\operatorname{ord}$ is minus the logarithm of the associated adic
+valuation. Then there exists a divisor $D$ of $F/K$ whose pushforward $\mathrm{Finsupp.mapDomain}\
+\mathrm{lift}\ D$, a divisor of $F'/K'$, has index of specialty zero, i.e. the $K'$-dimension of the
+quotient of the adele space of $F'$ (the supremum over divisors $E$ of the spaces of families
+bounded by $E$ at every place) by the sum of the space of adeles bounded by
+$\mathrm{Finsupp.mapDomain}\ \mathrm{lift}\ D$ and the image of the diagonal embedding of $F'$
+vanishes.
+
+This is the form of the strong approximation theorem needed for constant-field extensions: some
+divisor supported on old places becomes non-special after lifting, so that every adele of $F'$ is
+congruent modulo $F'$ to one integral at all new places. It is used in the comparison of the genus
+of $F/K$ with that of the constant-field extension $F'/K'$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_exists_indexOfSpecialty_mapDomain_eq_zero_of_constantFieldExtension_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_9269c335
+
+
+open AlgebraicCurve
+
+namespace W7XChildE
+
+theorem constantsAreBase {K F : Type*} [Field K] [Field F] [Algebra K F] [IsAlgClosed K]
+    [IsCurveOver K F]
+    (hfg : ∃ x : F, Transcendental K x ∧
+      FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F) :
+    ConstantsAreBase K F := by
+  obtain ⟨x, hxt, _⟩ := hfg
+  have : HasPrincipalDivisors K F := IsCurveOver.hasPrincipalDivisors
+  refine le_antisymm (fun f hf => ?_) (fun f ⟨c, hc⟩ => hc ▸ fun v =>
+    Place.adicValuation_algebraMap_le_one v c)
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact zero_mem _
+  have hord : ∀ v : Place K F, 0 ≤ v.ord f := fun v => by
+    have := (mem_riemannRochSpace_iff.mp hf v).resolve_left hf0; simpa using this
+  obtain ⟨Df, hDord, hDdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) (F := F) f hf0
+  have hdiv : ∀ v : Place K F, v.ord f = 0 := by
+    by_contra hne; push Not at hne; obtain ⟨v, hv⟩ := hne
+    refine absurd hDdeg (ne_of_gt ?_)
+    rw [Divisor.degree_eq_sum_support]
+    refine Finset.sum_pos' (fun w _ => mul_nonneg (by rw [hDord w]; exact hord w)
+      (Int.natCast_nonneg _)) ⟨v, ?_, ?_⟩
+    · simp only [Finsupp.mem_support_iff, hDord v]; exact hv
+    · rw [hDord v]
+      have : Module.Finite K v.ResidueField := IsCurveOver.finiteResidue v
+      have : (v.deg : ℤ) = 1 := by exact_mod_cast Place.deg_eq_one_of_isAlgClosed_of_finite v
+      rw [this, mul_one]; exact (hord v).lt_of_ne' hv
+  exact ⟨_, (Place.mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed x hxt
+    (F := F) hdiv).choose_spec⟩
+
+end W7XChildE
+
+open W7XChildE
+
+theorem solution
+    (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [IsAlgClosed K']
+    (hfg : ∃ x : F, Transcendental K x ∧ FiniteDimensional (IntermediateField.adjoin K ({x} : Set
+      F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    [IsCurveOver K F] [IsCurveOver K' F']
+    (lift : Place K F → Place K' F') :
+    ∃ D : Divisor K F, indexOfSpecialty (K := K') (Finsupp.mapDomain lift D) = 0 := by
+  classical
+  obtain ⟨x, hxt, hxfd⟩ := id hfg
+  obtain ⟨x', hxt', hxfd'⟩ := id hfg'
+  have : Algebra.EssFiniteType K F :=
+    essFiniteType_of_transcendental_of_finiteDimensional hxt hxfd
+  have : Algebra.EssFiniteType K' F' :=
+    essFiniteType_of_transcendental_of_finiteDimensional hxt' hxfd'
+  have hCAB : ConstantsAreBase K F := constantsAreBase hfg
+  have hCAB' : ConstantsAreBase K' F' := constantsAreBase hfg'
+  obtain ⟨hne, hfd0, γ, D₀, hD₀⟩ := stichtenothGenusExists_of_isCurveOver (K := K) (F := F) hCAB
+  obtain ⟨hne', hfd0', γ', D₀', hD₀'⟩ :=
+    stichtenothGenusExists_of_isCurveOver (K := K') (F := F') hCAB'
+  have := hne; have := hfd0; have := hne'; have := hfd0'
+  obtain ⟨P₀⟩ := hne
+  obtain ⟨n, hRGA⟩ :=
+    exists_riemannGenusReachedAt_nsmul_single_of_stichtenothGenusExists hD₀' (lift P₀)
+  refine ⟨Finsupp.single P₀ (n : ℤ), ?_⟩
+  have hmap : (Finsupp.mapDomain lift (Finsupp.single P₀ (n : ℤ)) : Divisor K' F')
+      = (n : ℤ) • Finsupp.single (lift P₀) (1 : ℤ) := by
+    rw [Finsupp.mapDomain_single, Finsupp.smul_single, smul_eq_mul, mul_one]
+  rw [hmap]
+  exact indexOfSpecialty_eq_zero_of_genusReached hRGA
+
+end S_OVERLONG_9269c335
+end P2MW
+export
+  P2MW.S_OVERLONG_9269c335
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem
+  AlgebraicCurve.exists_indexOfSpecialty_mapDomain_eq_zero_of_constantFieldExtension_of_isAlgClosed
+    (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [IsAlgClosed K']
+    (hfg : ∃ x : F, Transcendental K x ∧ FiniteDimensional (IntermediateField.adjoin K ({x} : Set
+      F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    [IsCurveOver K F] [IsCurveOver K' F']
+    (lift : Place K F → Place K' F') :
+    ∃ D : Divisor K F, indexOfSpecialty (K := K') (Finsupp.mapDomain lift D) = 0 :=
+  solution K F K' F' hfg hfg' lift
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_indexOfSpecialty_nsmul_single_eq_zero_of_genusReached.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_indexOfSpecialty_nsmul_single_eq_zero_of_genusReached.lean
new file mode 100644
index 0000000000..c23ad4a754
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_indexOfSpecialty_nsmul_single_eq_zero_of_genusReached.lean
@@ -0,0 +1,134 @@
+/-
+Based on Prove2Me node AlgebraicCurve.exists_indexOfSpecialty_nsmul_single_eq_zero_of_genusReached
+(42d1d42d-658c-50e6-a41f-6d40bc7f47b4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f23a3754-5336-5417-a741-9774f4cd39a3
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_omegaSpace_finite_of_genusReached
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Strong approximation: i(nQ)=0 for some n
+
+Theorem statement: `AlgebraicCurve.exists_indexOfSpecialty_nsmul_single_eq_zero_of_genusReached`
+(`42d1d42d-658c-50e6-a41f-6d40bc7f47b4`), by Claude, 2026-09-05.
+
+Proof: submission `f23a3754-5336-5417-a741-9774f4cd39a3`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra satisfying `IsCurveOver K F`, i.e. every nonzero $f
+\in F$ has a degree-zero divisor recording its orders $\operatorname{ord}_v f$ at all places, each
+residue field $\kappa(v)$ of a place $v$ (a proper valuation subring of $F$ containing $K$ whose
+ring is a principal ideal ring) is a finite-dimensional $K$-module, and $\Omega_{F/K}$ is free of
+rank $1$ over $F$; assume moreover that `Place K F` is nonempty and that the space $L(0) = \{f \in F
+: v(f) \le 1 \text{ for all } v\}$ is finite-dimensional over $K$. Let $\gamma \in \mathbb{Z}$ and
+let $D_0$ be a divisor (a finitely supported $\mathbb{Z}$-valued function on places) with
+`RiemannGenusReachedAt γ D₀`: $L(D_0)$ is finite-dimensional over $K$, $\deg D_0 - \mathrm{ell}(D_0)
+= \gamma - 1$, and $\deg D - \mathrm{ell}(D) \le \gamma - 1$ for every divisor $D$. Then for every
+place $Q$ there exists $n \in \mathbb{N}$ such that $\mathrm{indexOfSpecialty}(n \cdot \delta_Q) =
+0$, i.e. the $K$-dimension of the quotient of the adele space by the sum of the subspaces of adeles
+bounded by $n\cdot\delta_Q$ and of diagonal (principal) adeles vanishes.
+
+This is the Strong Approximation Theorem in the currency of the index of specialty: for $n$ large,
+$\mathcal{A}_F = \mathcal{A}_F(nQ) + F$. It feeds
+[`AlgebraicCurve.exists_riemannGenusReachedAt_nsmul_single_of_stichtenothGenusExists`]
+(thm.html#AlgebraicCurve.exists_riemannGenusReachedAt_nsmul_single_of_stichtenothGenusExists),
+where combined with the index formula it shows that the genus bound is already attained at a
+multiple of a single place, and is also used in
+[`AlgebraicCurve.eq_genusFF_of_forall_ell_sub_ell_eq`]
+(thm.html#AlgebraicCurve.eq_genusFF_of_forall_ell_sub_ell_eq).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_exists_indexOfSpecialty_nsmul_single_eq_zero_of_genusReached.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_exists_indexOfSpecialty_nsmul_single_eq_zero_of_genusReached
+
+
+open AlgebraicCurve
+
+theorem solution
+    {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K ↥(LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (Q : Place K F) :
+    ∃ n : ℕ, indexOfSpecialty ((n : ℤ) • Finsupp.single Q (1 : ℤ)) = 0 := by
+  classical
+  have hQdeg : (1 : ℤ) ≤ (Q.deg : ℤ) := by
+    have hfin : Module.Finite K Q.ResidueField := IsCurveOver.finiteResidue Q
+    have hpos : 0 < Q.deg := Module.finrank_pos
+    exact_mod_cast hpos
+  set B : ℤ := (indexOfSpecialty (0 : Divisor K F) : ℤ) + γ - 1 with hB
+  refine ⟨B.natAbs + 1, ?_⟩
+  set n : ℕ := B.natAbs + 1 with hn
+  set Dn : Divisor K F := (n : ℤ) • Finsupp.single Q (1 : ℤ) with hDn
+  have hdeg : Divisor.degree Dn = (n : ℤ) * (Q.deg : ℤ) := by
+    simp only [hDn, zsmul_eq_mul, Finsupp.smul_single, mul_one]
+    exact Divisor.degree_single Q (n : ℤ)
+  have hBn : B < (n : ℤ) * (Q.deg : ℤ) := by
+    have h1 : B < (n : ℤ) := by
+      have : B ≤ |B| := le_abs_self B
+      rw [Int.abs_eq_natAbs] at this
+      calc B ≤ (B.natAbs : ℤ) := this
+        _ < (B.natAbs : ℤ) + 1 := lt_add_one _
+        _ = (n : ℤ) := by push_cast [hn]; ring
+    calc B < (n : ℤ) := h1
+      _ = (n : ℤ) * 1 := (mul_one _).symm
+      _ ≤ (n : ℤ) * (Q.deg : ℤ) := by
+          apply mul_le_mul_of_nonneg_left hQdeg
+          exact_mod_cast Nat.zero_le n
+  by_contra hne
+  have homegafin : Module.Finite K ↥(omegaSpace (K := K) (F := F) Dn) :=
+    omegaSpace_finite_of_genusReached h Dn
+  have homegane : (omegaSpace (K := K) (F := F) Dn) ≠ ⊥ := by
+    intro hbot
+    apply hne
+    rw [← finrank_omegaSpace_eq_indexOfSpecialty Dn, hbot]
+    exact finrank_bot K _
+  obtain ⟨ψ, hψ, hψne⟩ := (Submodule.ne_bot_iff _).mp homegane
+  have hfin0 : Module.Finite K ↥(omegaSpace (K := K) (F := F) (0 : Divisor K F)) :=
+    omegaSpace_finite_of_genusReached h 0
+  have hle : (ell Dn : ℤ) ≤ (indexOfSpecialty (0 : Divisor K F) : ℤ) := by
+    have hls := ell_sub_le_indexOfSpecialty Dn (0 : Divisor K F) hψ hψne
+    simp only [sub_zero] at hls
+    exact_mod_cast hls
+  have hmax := h.isMax Dn
+  rw [hdeg] at hmax
+  linarith
+
+end S_AlgebraicCurve_exists_indexOfSpecialty_nsmul_single_eq_zero_of_genusReached
+end P2MW
+export P2MW.S_AlgebraicCurve_exists_indexOfSpecialty_nsmul_single_eq_zero_of_genusReached (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.exists_indexOfSpecialty_nsmul_single_eq_zero_of_genusReached
+    {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K ↥(LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (Q : Place K F) :
+    ∃ n : ℕ, indexOfSpecialty ((n : ℤ) • Finsupp.single Q (1 : ℤ)) = 0 :=
+  solution h Q
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_poleDivisor_of_transcendental.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_poleDivisor_of_transcendental.lean
new file mode 100644
index 0000000000..b6e85683e2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_poleDivisor_of_transcendental.lean
@@ -0,0 +1,94 @@
+/-
+Based on Prove2Me node AlgebraicCurve.exists_poleDivisor_of_transcendental
+(48e87314-6924-5a6b-a827-053e0c1cec1d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission fe43833f-5bff-56f1-b39b-cf5311feef73
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_isAlgClosed_of_transcendental
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of the pole divisor of a transcendental element
+
+Theorem statement: `AlgebraicCurve.exists_poleDivisor_of_transcendental`
+(`48e87314-6924-5a6b-a827-053e0c1cec1d`), by Claude, 2026-09-05.
+
+Proof: submission `fe43833f-5bff-56f1-b39b-cf5311feef73`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field and let $F$ be a field equipped with a $K$-algebra
+structure, and let $x \in F$ be transcendental over $K$, with $F$ finite-dimensional as a vector
+space over the intermediate field $K(x) =$ `IntermediateField.adjoin K {x}`. A place of $F/K$ is, in
+this development, a valuation subring of $F$ that contains the image of $K$ under the structure map,
+is not the whole of $F$, and is a principal ideal ring; for such a $v$ and $f \in F$,
+$\operatorname{ord}_v f$ is defined as minus the logarithm of the value of $f$ under the
+$\mathbb{Z}^{m0}$-valued adic valuation attached to the height-one prime of $v$, and a divisor is a
+finitely supported function from places of $F/K$ to $\mathbb{Z}$. The assertion is that there exists
+a divisor $D$, that is a finitely supported integer-valued function on the places of $F/K$, such
+that for every place $v$ one has $D(v) = \max(0, -\operatorname{ord}_v x)$. Equivalently, the set of
+places at which $x$ has a pole is finite, and the pole divisor $(x)_\infty$ exists as an element of
+the divisor group.
+
+This is the existence of the pole divisor $(x)_\infty$ of a transcendental element in a function
+field of one variable over an algebraically closed constant field, i.e. the finiteness of the set of
+poles of $x$. It supplies the divisor used in the computation of degrees against $[F : K(x)]$ and in
+the genus inequalities for regular prolongations that build on it.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_exists_poleDivisor_of_transcendental.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_exists_poleDivisor_of_transcendental
+
+open AlgebraicCurve
+
+theorem solution
+    {K F : Type*} [Field K] [IsAlgClosed K] [Field F] [Algebra K F]
+    (x : F) (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] :
+    ∃ D : Divisor K F, ∀ v : Place K F, D v = max 0 (-v.ord x) := by
+  have : IsCurveOver K F := isCurveOver_of_isAlgClosed_of_transcendental x hx
+  have hx0 : x ≠ 0 := fun h => hx (h ▸ isAlgebraic_zero)
+  obtain ⟨P, hP, -⟩ := HasPrincipalDivisors.exists_divisor (K := K) (F := F) x hx0
+  refine ⟨(-P) ⊔ 0, fun v => ?_⟩
+  change max ((-P) v) ((0 : Divisor K F) v) = max 0 (-v.ord x)
+  rw [Finsupp.neg_apply, hP v, Finsupp.coe_zero, Pi.zero_apply, max_comm]
+
+end S_AlgebraicCurve_exists_poleDivisor_of_transcendental
+end P2MW
+export P2MW.S_AlgebraicCurve_exists_poleDivisor_of_transcendental (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.exists_poleDivisor_of_transcendental
+    {K F : Type*} [Field K] [IsAlgClosed K] [Field F] [Algebra K F]
+    (x : F) (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] :
+    ∃ D : Divisor K F, ∀ v : Place K F, D v = max 0 (-v.ord x) :=
+  solution x hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_riemannGenusReachedAt_nsmul_single_of_stichtenothGenusExists.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_riemannGenusReachedAt_nsmul_single_of_stichtenothGenusExists.lean
new file mode 100644
index 0000000000..8ff4ab5538
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_riemannGenusReachedAt_nsmul_single_of_stichtenothGenusExists.lean
@@ -0,0 +1,106 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.exists_riemannGenusReachedAt_nsmul_single_of_stichtenothGenusExists
+(ca093734-12dd-594a-980b-08b791760f21) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 76a95cca-a8c6-5f34-9d2e-722cd986e596
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_indexOfSpecialty_nsmul_single_eq_zero_of_genusReached
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteDimensional_lSpace
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Genus bound attained at a multiple of any single place
+
+Theorem statement:
+`AlgebraicCurve.exists_riemannGenusReachedAt_nsmul_single_of_stichtenothGenusExists`
+(`ca093734-12dd-594a-980b-08b791760f21`), by Claude, 2026-09-05.
+
+Proof: submission `76a95cca-a8c6-5f34-9d2e-722cd986e596`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K \subseteq F$ be fields with $F$ a $K$-algebra satisfying `IsCurveOver K F`: every nonzero $f
+\in F$ has a principal divisor of degree $0$ whose coefficient at each place is
+$\operatorname{ord}_v f$, each place has residue field finite over $K$, and the module of Kähler
+differentials $\Omega[F/K]$ is free of rank $1$ over $F$; here a place is a valuation subring of $F$
+containing $\operatorname{im}(K)$, distinct from $F$ itself, and a principal ideal ring, and a
+divisor is a finitely supported function from places to $\mathbb{Z}$, with $\deg$ the sum of its
+coefficients weighted by the residue degrees. Assume the set of places is nonempty and that the
+Riemann–Roch space $\mathrm{LSpace}(0) = \{f \in F : v(f) \le 1 \text{ for all } v\}$ is
+finite-dimensional over $K$. Let $\gamma \in \mathbb{Z}$ and let $D_0$ be a divisor at which the
+Riemann genus bound $\gamma$ is reached, i.e. $\mathrm{LSpace}(D_0)$ is finite-dimensional over $K$,
+$\deg D_0 - \ell(D_0) = \gamma - 1$, and $\deg D - \ell(D) \le \gamma - 1$ for every divisor $D$.
+Then for every place $Q$ there exists $n \in \mathbb{N}$ such that the bound $\gamma$ is likewise
+reached at the divisor $n \cdot Q$, that is, $\mathrm{LSpace}(n\,Q)$ is finite-dimensional,
+$\deg(n\,Q) - \ell(n\,Q) = \gamma - 1$, and the same maximality holds.
+
+This is the form in which the strong approximation theorem for function fields enters the
+development: the supremum defining the genus is already attained on the divisors supported at a
+single prescribed place, equivalently the index of specialty of $n\,Q$ vanishes for some $n$. It is
+used in the computation of $\ell$ for multiples of a place and in the behaviour of the index of
+specialty under extension of the constant field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_exists_riemannGenusReachedAt_nsmul_single_of_stichtenothGenusExists.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_exists_riemannGenusReachedAt_nsmul_single_of_stichtenothGenusExists
+
+
+open AlgebraicCurve
+
+theorem solution
+    {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K ↥(LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (Q : Place K F) :
+    ∃ n : ℕ, RiemannGenusReachedAt γ ((n : ℤ) • Finsupp.single Q 1) := by
+  classical
+  obtain ⟨n, hn⟩ :=
+    exists_indexOfSpecialty_nsmul_single_eq_zero_of_genusReached h Q
+  refine ⟨n, ?_⟩
+  have hidx := (indexOfSpecialty_eq_of_genusReached h
+    ((n : ℤ) • Finsupp.single Q (1 : ℤ))).2
+  rw [hn] at hidx
+  have heq : Divisor.degree ((n : ℤ) • Finsupp.single Q (1 : ℤ)) -
+      (ell ((n : ℤ) • Finsupp.single Q (1 : ℤ)) : ℤ) = γ - 1 := by
+    push_cast at hidx ⊢
+    linarith
+  exact ⟨finiteDimensional_lSpace _, heq, h.isMax⟩
+
+end S_AlgebraicCurve_exists_riemannGenusReachedAt_nsmul_single_of_stichtenothGenusExists
+end P2MW
+export P2MW.S_AlgebraicCurve_exists_riemannGenusReachedAt_nsmul_single_of_stichtenothGenusExists
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.exists_riemannGenusReachedAt_nsmul_single_of_stichtenothGenusExists
+    {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K ↥(LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (Q : Place K F) :
+    ∃ n : ℕ, RiemannGenusReachedAt γ ((n : ℤ) • Finsupp.single Q 1) :=
+  solution h Q
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_separating_transcendental_of_perfectField.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_separating_transcendental_of_perfectField.lean
new file mode 100644
index 0000000000..e9faba113e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_exists_separating_transcendental_of_perfectField.lean
@@ -0,0 +1,217 @@
+/-
+Based on Prove2Me node AlgebraicCurve.exists_separating_transcendental_of_perfectField
+(a9b8b10c-f084-5a40-8677-5f0e6588bb12) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 792d0909-c16c-55f0-97a0-e8101b570ba7
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Defs
+public import Mathlib.FieldTheory.Perfect
+
+import Mathlib.Algebra.CharP.IntermediateField
+import Mathlib.FieldTheory.Relrank
+import Mathlib.RingTheory.AlgebraicIndependent.AlgebraicClosure
+import Mathlib.RingTheory.AlgebraicIndependent.TranscendenceBasis
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Algebra_IsSeparable_of_finrank_fieldRange_frobenius_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finrank_frobeniusSubfield_eq_of_transcendental
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of a separating transcendental over a perfect field
+
+Theorem statement: `AlgebraicCurve.exists_separating_transcendental_of_perfectField`
+(`a9b8b10c-f084-5a40-8677-5f0e6588bb12`), by Claude, 2026-09-05.
+
+Proof: submission `792d0909-c16c-55f0-97a0-e8101b570ba7`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $K$ perfect and $F$ a $K$-algebra, and let $x \in F$ be
+transcendental over $K$ (i.e. $x$ is not a root of any nonzero polynomial over $K$) and such that
+$F$ is finite-dimensional as a module over the intermediate field $K(x)$ generated by $\{x\}$ inside
+$F$. Then there exists $t \in F$ with three properties: $t$ is transcendental over $K$; $F$ is
+finite-dimensional over the intermediate field $K(t)$ generated by $\{t\}$; and the extension
+$F/K(t)$ is separable, in the sense of the `Algebra.IsSeparable` predicate, namely every element of
+$F$ has separable minimal polynomial over $K(t)$. Thus an algebraic function field of one variable
+over a perfect field, presented by one transcendental generator $x$ with $[F:K(x)] < \infty$, admits
+a separating transcendental element.
+
+This is F. K. Schmidt's theorem that a one-variable algebraic function field over a perfect constant
+field is separably generated; no hypothesis on the exact constant field of $F$ beyond perfectness of
+$K$ is made. It underpins the curve-theoretic part of the development, being used for instance in
+the results on places, regular prolongations and the degree-zero Picard group of a curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_exists_separating_transcendental_of_perfectField.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_exists_separating_transcendental_of_perfectField
+
+open IntermediateField
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "finrank_frobeniusSubfield_eq_of_transcendental"
+namespace SeparatingTranscendentalOfPerfectField
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem isTranscendenceBasis_of_transcendental {x : F} (hx : Transcendental K x)
+    (hfd : FiniteDimensional K⟮x⟯ F) : IsTranscendenceBasis K (fun _ : Fin 1 => x) := by
+  have hind : AlgebraicIndependent K (fun _ : Fin 1 => x) :=
+    algebraicIndependent_unique_type_iff.mpr hx
+  refine hind.isTranscendenceBasis_iff_isAlgebraic.mpr ?_
+  have hr : Set.range (fun _ : Fin 1 => x) = ({x} : Set F) := by
+    ext y
+    simp [eq_comm]
+  rw [hr, ← IntermediateField.isAlgebraic_adjoin_iff_top]
+  have := hfd
+  exact Algebra.IsAlgebraic.of_finite K⟮x⟯ F
+
+theorem isAlgebraic_adjoin_of_transcendental {x : F} (hx : Transcendental K x)
+    (hfd : FiniteDimensional K⟮x⟯ F) {t : F} (ht : Transcendental K t) :
+    Algebra.IsAlgebraic K⟮t⟯ F := by
+  classical
+  have htind : AlgebraicIndepOn K id ({t} : Set F) := by
+    refine algebraicIndependent_unique_type_iff.mpr ?_
+    simpa using ht
+  obtain ⟨s, hts, hbasis⟩ := exists_isTranscendenceBasis_superset htind
+  have hcard := hbasis.lift_cardinalMk_eq (isTranscendenceBasis_of_transcendental hx hfd)
+  simp only [Cardinal.mk_fin, Nat.cast_one, Cardinal.lift_one, Cardinal.lift_eq_one] at hcard
+  have hsub : s.Subsingleton := Cardinal.mk_le_one_iff_set_subsingleton.mp hcard.le
+  have hseq : s = {t} := hsub.eq_singleton_of_mem (hts rfl)
+  subst hseq
+  have h := hbasis.isAlgebraic_field
+  rwa [Subtype.range_coe] at h
+
+theorem finiteDimensional_adjoin_of_transcendental {x : F} (hx : Transcendental K x)
+    (hfd : FiniteDimensional K⟮x⟯ F) {t : F} (ht : Transcendental K t) :
+    FiniteDimensional K⟮t⟯ F := by
+  classical
+  have := hfd
+  have halg : Algebra.IsAlgebraic K⟮t⟯ F := isAlgebraic_adjoin_of_transcendental hx hfd ht
+  obtain ⟨s, hs⟩ := Module.finite_def.mp hfd
+  set E : IntermediateField K⟮t⟯ F :=
+    IntermediateField.adjoin K⟮t⟯ (insert x (↑s : Set F)) with hE
+  have hxE : x ∈ E := IntermediateField.subset_adjoin _ _ (Set.mem_insert _ _)
+  have hrange : ∀ r : K⟮x⟯, (r : F) ∈ E := by
+    intro r
+    have hle : K⟮x⟯ ≤ E.restrictScalars K :=
+      IntermediateField.adjoin_simple_le_iff.mpr
+        ((IntermediateField.mem_restrictScalars K).mpr hxE)
+    exact (IntermediateField.mem_restrictScalars K).mp (hle r.2)
+  have hmem : ∀ y : F, y ∈ E := by
+    intro y
+    have hy : y ∈ Submodule.span K⟮x⟯ (↑s : Set F) := by
+      rw [hs]; exact Submodule.mem_top
+    refine Submodule.span_induction (fun z hz => ?_) ?_ (fun z w _ _ hz hw => ?_)
+      (fun r z _ hz => ?_) hy
+    · exact IntermediateField.subset_adjoin _ _ (Set.mem_insert_of_mem _ hz)
+    · exact zero_mem E
+    · exact add_mem hz hw
+    · rw [Algebra.smul_def]
+      exact mul_mem (hrange r) hz
+  have htop : E = ⊤ := by
+    rw [eq_top_iff]
+    intro y _
+    exact hmem y
+  have : Finite ↥(insert x (↑s : Set F)) :=
+    Set.Finite.to_subtype ((s.finite_toSet).insert x)
+  have hfdE : FiniteDimensional K⟮t⟯ ↥E := by
+    rw [hE]
+    exact IntermediateField.finiteDimensional_adjoin
+      (fun z _ => (halg.isAlgebraic z).isIntegral)
+  rw [htop] at hfdE
+  have := hfdE
+  exact LinearEquiv.finiteDimensional
+    (IntermediateField.topEquiv (F := K⟮t⟯) (E := F)).toLinearEquiv
+
+theorem transcendental_of_not_mem_fieldRange_frobenius [PerfectField K] (p : ℕ)
+    [Fact p.Prime] [CharP K p] [CharP F p] {t : F} (ht : t ∉ (frobenius F p).fieldRange) :
+    Transcendental K t := by
+  intro halg
+  apply ht
+  have : Algebra.IsAlgebraic K K⟮t⟯ :=
+    IntermediateField.isAlgebraic_adjoin_simple halg.isIntegral
+  have : PerfectField K⟮t⟯ := Algebra.IsAlgebraic.perfectField (K := K)
+  have : CharP K⟮t⟯ p := charP_of_injective_algebraMap (algebraMap K K⟮t⟯).injective p
+  obtain ⟨s, hs⟩ := surjective_frobenius K⟮t⟯ p ⟨t, mem_adjoin_simple_self K t⟩
+  refine RingHom.mem_fieldRange.mpr ⟨(s : F), ?_⟩
+  have h := congrArg (fun u : K⟮t⟯ => (u : F)) hs
+  simpa [frobenius_def] using h
+
+theorem exists_separating [PerfectField K] {x : F} (hx : Transcendental K x)
+    (hfd : FiniteDimensional K⟮x⟯ F) :
+    ∃ t : F, Transcendental K t ∧ FiniteDimensional K⟮t⟯ F ∧ Algebra.IsSeparable K⟮t⟯ F := by
+  classical
+  have := hfd
+  obtain h0 | ⟨p, hp, hchar⟩ := CharP.exists' K
+  · have : CharZero K⟮x⟯ := charZero_of_injective_algebraMap (algebraMap K K⟮x⟯).injective
+    have : Algebra.IsAlgebraic K⟮x⟯ F := Algebra.IsAlgebraic.of_finite K⟮x⟯ F
+    exact ⟨x, hx, hfd, Algebra.IsAlgebraic.isSeparable_of_perfectField⟩
+  · have := hp
+    have := hchar
+    have : CharP F p := charP_of_injective_algebraMap (algebraMap K F).injective p
+    have hdeg : Module.finrank (frobenius F p).fieldRange F = p :=
+      AlgebraicCurve.finrank_frobeniusSubfield_eq_of_transcendental p x hx
+    have hnle : ¬ ((⊤ : Subfield F) ≤ (frobenius F p).fieldRange) := by
+      intro hle
+      have h1 : Module.finrank (frobenius F p).fieldRange F = 1 := by
+        rw [← Subfield.relfinrank_top_right, Subfield.relfinrank_eq_one_iff]
+        exact hle
+      exact hp.out.one_lt.ne (h1.symm.trans hdeg)
+    obtain ⟨t, -, ht⟩ := IsConcreteLE.not_le_iff_exists.mp hnle
+    have httr : Transcendental K t := transcendental_of_not_mem_fieldRange_frobenius p ht
+    have htfd : FiniteDimensional K⟮t⟯ F :=
+      finiteDimensional_adjoin_of_transcendental hx hfd httr
+    have := htfd
+    have hsep : Algebra.IsSeparable K⟮t⟯ F :=
+      Algebra.IsSeparable.of_finrank_fieldRange_frobenius_eq p hdeg
+        (⟨t, mem_adjoin_simple_self K t⟩ : K⟮t⟯) ht
+    exact ⟨t, httr, htfd, hsep⟩
+
+end AlgebraicCurve.SeparatingTranscendentalOfPerfectField
+
+theorem solution
+    {K F : Type*} [Field K] [Field F] [Algebra K F] [PerfectField K]
+    {x : F} (htr : Transcendental K x)
+    (hfd : FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F) :
+    ∃ t : F, Transcendental K t ∧
+      FiniteDimensional (IntermediateField.adjoin K ({t} : Set F)) F ∧
+      Algebra.IsSeparable (IntermediateField.adjoin K ({t} : Set F)) F :=
+  AlgebraicCurve.SeparatingTranscendentalOfPerfectField.exists_separating htr hfd
+
+end S_AlgebraicCurve_exists_separating_transcendental_of_perfectField
+end P2MW
+export P2MW.S_AlgebraicCurve_exists_separating_transcendental_of_perfectField (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.exists_separating_transcendental_of_perfectField
+    {K F : Type*} [Field K] [Field F] [Algebra K F] [PerfectField K]
+    {x : F} (htr : Transcendental K x)
+    (hfd : FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F) :
+    ∃ t : F, Transcendental K t ∧
+      FiniteDimensional (IntermediateField.adjoin K ({t} : Set F)) F ∧
+      Algebra.IsSeparable (IntermediateField.adjoin K ({t} : Set F)) F :=
+  solution htr hfd
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finiteAlong_comp.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finiteAlong_comp.lean
new file mode 100644
index 0000000000..ef34420638
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finiteAlong_comp.lean
@@ -0,0 +1,88 @@
+/-
+Based on Prove2Me node AlgebraicCurve.finiteAlong_comp
+(ae32d856-4a57-5ecc-97dd-3c00ba07172a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4ee7ca86-c34b-54fc-863c-9bc65223c7a0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finiteness along a composite of K-algebra maps
+
+Theorem statement: `AlgebraicCurve.finiteAlong_comp` (`ae32d856-4a57-5ecc-97dd-3c00ba07172a`), by
+Claude, 2026-09-05.
+
+Proof: submission `4ee7ca86-c34b-54fc-863c-9bc65223c7a0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $F'$ and $F''$ be fields, each of $F$, $F'$, $F''$ equipped with a $K$-algebra
+structure, and let $\varphi \colon F \to F'$ and $\chi \colon F' \to F''$ be $K$-algebra
+homomorphisms. For a $K$-algebra homomorphism the predicate `FiniteAlong` asserts that the target is
+a finite module over the source for the algebra structure `algebraAlong` transported along that
+homomorphism, i.e. the one whose structure map is the homomorphism itself. The hypotheses are that
+$F'$ is a finite $F$-module along $\varphi$ and that $F''$ is a finite $F'$-module along $\chi$. The
+conclusion is that $F''$ is a finite $F$-module along the composite $\chi \circ \varphi$ (written in
+Lean as `χ.comp φ`), that is, `FiniteAlong K (χ.comp φ)` holds. Thus the statement is exactly the
+multiplicativity of module-finiteness in a tower of field extensions, phrased for the instance-free
+predicate `FiniteAlong` rather than for ambient `Algebra` instances.
+
+This is the tower law for module-finiteness, in the form needed when extensions of function fields
+are presented by explicit $K$-algebra maps rather than by registered algebra instances. It is used
+throughout the treatment of modular curves and their correspondences, for instance in the
+composition of pullback and pushforward maps entering the Hecke operators and in comparisons of
+modular polynomial data.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_finiteAlong_comp.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_finiteAlong_comp
+
+open AlgebraicCurve
+
+theorem solution {K F F' F'' : Type*} [Field K] [Field F] [Field F'] [Field F''] [Algebra K F]
+    [Algebra K F'] [Algebra K F''] (φ : F →ₐ[K] F') (χ : F' →ₐ[K] F'') (hφ : FiniteAlong K φ)
+    (hχ : FiniteAlong K χ) :
+    FiniteAlong K (χ.comp φ) := by
+  let := algebraAlong φ
+  let := algebraAlong χ
+  let := algebraAlong (χ.comp φ)
+  have : IsScalarTower F F' F'' := IsScalarTower.of_algebraMap_eq fun _ => rfl
+  have : Module.Finite F F' := hφ
+  have : Module.Finite F' F'' := hχ
+  exact Module.Finite.trans F' F''
+
+end S_AlgebraicCurve_finiteAlong_comp
+end P2MW
+export P2MW.S_AlgebraicCurve_finiteAlong_comp (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.finiteAlong_comp {K F F' F'' : Type*} [Field K] [Field F] [Field F']
+    [Field F''] [Algebra K F] [Algebra K F'] [Algebra K F''] (φ : F →ₐ[K] F') (χ : F' →ₐ[K] F'')
+    (hφ : FiniteAlong K φ) (hχ : FiniteAlong K χ) :
+    FiniteAlong K (χ.comp φ) :=
+  solution φ χ hφ hχ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finiteAlong_of_surjective.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finiteAlong_of_surjective.lean
new file mode 100644
index 0000000000..06999ef33a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finiteAlong_of_surjective.lean
@@ -0,0 +1,81 @@
+/-
+Based on Prove2Me node AlgebraicCurve.finiteAlong_of_surjective
+(37c921ba-5a08-512e-914b-bc710b09079f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 631a8471-dde0-54d9-b254-fb7e226a0060
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Surjective K-algebra maps of fields are finite
+
+Theorem statement: `AlgebraicCurve.finiteAlong_of_surjective`
+(`37c921ba-5a08-512e-914b-bc710b09079f`), by Claude, 2026-09-05.
+
+Proof: submission `631a8471-dde0-54d9-b254-fb7e226a0060`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $F'$ be fields, with $F$ and $F'$ equipped with $K$-algebra structures, and let
+$\varphi \colon F \to F'$ be a homomorphism of $K$-algebras. Assume that $\varphi$ is surjective as
+a map of underlying sets. Then `FiniteAlong K φ` holds, that is: when $F'$ is regarded as an
+$F$-algebra via the ring homomorphism underlying $\varphi$ (the algebra structure `algebraAlong φ`,
+whose structure map is $\varphi$ itself), $F'$ is a finite $F$-module, i.e. finitely generated as a
+module over $F$ along $\varphi$. Note that the hypothesis is surjectivity of $\varphi$, not a degree
+or integrality assumption; since a ring homomorphism between fields is automatically injective, such
+a $\varphi$ is in fact an isomorphism and $F'$ is free of rank one over $F$, but only finiteness is
+asserted here.
+
+This is the degenerate case of the finiteness hypothesis used throughout the theory of
+correspondences between function fields of curves, where a morphism of curves is required to make
+the target function field a finite extension of the source: an isomorphism of function fields
+trivially satisfies it. It is invoked to supply the `FiniteAlong` hypothesis for identity-like or
+isomorphism degeneracy maps, for instance in the compatibility of pushforward and pullback of
+divisors along a surjective map and in the identities for degeneracy pairs on modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_finiteAlong_of_surjective.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_finiteAlong_of_surjective
+
+open AlgebraicCurve
+
+theorem solution {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+    (φ : F →ₐ[K] F') (hφ : Function.Surjective φ) :
+    FiniteAlong K φ := by
+  let := algebraAlong φ
+  exact Module.Finite.of_surjective (Algebra.linearMap F F') hφ
+
+end S_AlgebraicCurve_finiteAlong_of_surjective
+end P2MW
+export P2MW.S_AlgebraicCurve_finiteAlong_of_surjective (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.finiteAlong_of_surjective {K F F' : Type*} [Field K] [Field F] [Field F']
+    [Algebra K F] [Algebra K F'] (φ : F →ₐ[K] F') (hφ : Function.Surjective φ) :
+    FiniteAlong K φ :=
+  solution φ hφ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finiteDimensional_adjoin_of_transcendental.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finiteDimensional_adjoin_of_transcendental.lean
new file mode 100644
index 0000000000..ce58b0f47b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finiteDimensional_adjoin_of_transcendental.lean
@@ -0,0 +1,156 @@
+/-
+Based on Prove2Me node AlgebraicCurve.finiteDimensional_adjoin_of_transcendental
+(685f0eca-c73f-571c-b627-994c1364dfe4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission bc4e1e56-5766-5df9-8200-673eaab4dc84
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Defs
+public import Mathlib.RingTheory.Algebraic.Defs
+public import Mathlib.LinearAlgebra.FiniteDimensional.Defs
+
+import Mathlib.RingTheory.AlgebraicIndependent.TranscendenceBasis
+import Mathlib.RingTheory.AlgebraicIndependent.Transcendental
+import Mathlib.RingTheory.AlgebraicIndependent.AlgebraicClosure
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+import Mathlib.LinearAlgebra.Dimension.FreeAndStrongRankCondition
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finiteness over K(t) for every transcendental t
+
+Theorem statement: `AlgebraicCurve.finiteDimensional_adjoin_of_transcendental`
+(`685f0eca-c73f-571c-b627-994c1364dfe4`), by Claude, 2026-09-05.
+
+Proof: submission `bc4e1e56-5766-5df9-8200-673eaab4dc84`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $x \in F$ be an element such that $F$ is
+finite-dimensional as a vector space over the intermediate field $K(x) =$ `IntermediateField.adjoin
+K {x}`. Let $t \in F$ be transcendental over $K$, that is, $t$ is not algebraic over $K$
+(`Transcendental K t`). The conclusion is that $F$ is finite-dimensional over the intermediate field
+$K(t) =$ `IntermediateField.adjoin K {t}`. The hypothesis on $x$ is an instance assumption, and no
+relation between $x$ and $t$ is required: $x$ is an arbitrary element witnessing finiteness over
+some simple intermediate extension, and the assertion is that finiteness then holds over the
+subfield generated by any transcendental element. (If $x$ happens to be algebraic over $K$ the
+hypothesis forces $F$ to be algebraic over $K$, so no transcendental $t$ exists and the statement is
+empty; the substantive case is $F$ a function field in one variable over $K$.)
+
+This is the intermediate-field form of the standard fact that a function field of one variable is
+finite over $K(t)$ for every $t$ transcendental over the constant field, independently of the chosen
+generator. It is used throughout the curve-theoretic part of the development, for instance in the
+treatment of reductions and of places, where a transcendental element is produced by other means and
+finiteness over the field it generates is then needed.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_finiteDimensional_adjoin_of_transcendental.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_finiteDimensional_adjoin_of_transcendental
+
+open Set Cardinal
+
+namespace AlgebraicCurve
+namespace FF2KE3
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem isAlgebraic_adjoin_of_transcendental' (x : F)
+    [halg : Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    {t : F} (ht : Transcendental K t) :
+    Algebra.IsAlgebraic (IntermediateField.adjoin K ({t} : Set F)) F := by
+  have hx : Transcendental K x := by
+    intro hxalg
+    have : Algebra.IsAlgebraic K (IntermediateField.adjoin K ({x} : Set F)) :=
+      IntermediateField.isAlgebraic_adjoin_simple hxalg.isIntegral
+    have : Algebra.IsAlgebraic K F :=
+      Algebra.IsAlgebraic.trans K (IntermediateField.adjoin K ({x} : Set F)) F
+    exact ht (Algebra.IsAlgebraic.isAlgebraic t)
+  have hbx : IsTranscendenceBasis K ![x] := by
+    rw [isTranscendenceBasis_iff_algebraicIndependent_isAlgebraic]
+    refine ⟨algebraicIndependent_iff_transcendental.mpr hx, ?_⟩
+    have : Set.range ![x] = {x} := by simp
+    rw [this]
+    exact (IntermediateField.isAlgebraic_adjoin_iff_top (F := K) (s := ({x} : Set F))).mp halg
+  have hind : AlgebraicIndepOn K id ({t} : Set F) := by
+    rw [AlgebraicIndepOn, algebraicIndependent_unique_type_iff]
+    simpa using ht
+  obtain ⟨S, htS, hS⟩ := exists_isTranscendenceBasis_superset hind
+  have hcard := hS.lift_cardinalMk_eq hbx
+  simp only [Cardinal.mk_fin, Nat.cast_one, Cardinal.lift_one, Cardinal.lift_eq_one] at hcard
+  have hS_eq : S = {t} :=
+    (Cardinal.mk_le_one_iff_set_subsingleton.mp hcard.le).eq_singleton_of_mem (htS rfl)
+  subst hS_eq
+  have h := hS.isAlgebraic_field
+  rwa [Subtype.range_coe] at h
+
+theorem finiteDimensional_adjoin_of_transcendental' (x : F)
+    [hfin : FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    {t : F} (ht : Transcendental K t) :
+    FiniteDimensional (IntermediateField.adjoin K ({t} : Set F)) F := by
+  have halg : Algebra.IsAlgebraic (IntermediateField.adjoin K ({t} : Set F)) F :=
+    isAlgebraic_adjoin_of_transcendental' x ht
+  set E := IntermediateField.adjoin K ({t} : Set F)
+  set Kx := IntermediateField.adjoin K ({x} : Set F)
+  let b := Module.finBasis Kx F
+  let S : Set F := insert x (Set.range b)
+  have : Finite S := Set.Finite.insert x (Set.finite_range b) |>.to_subtype
+  have hM : FiniteDimensional E (IntermediateField.adjoin E S) :=
+    IntermediateField.finiteDimensional_adjoin fun y _ => (halg.isAlgebraic y).isIntegral
+  have htop : IntermediateField.adjoin E S = ⊤ := by
+    rw [eq_top_iff]
+    intro y _
+    have hKx : ∀ c : Kx, (c : F) ∈ IntermediateField.adjoin E S := by
+      intro c
+      have hle : Kx ≤ (IntermediateField.adjoin E S).restrictScalars K := by
+        rw [IntermediateField.adjoin_le_iff]
+        intro z hz
+        rw [Set.mem_singleton_iff] at hz
+        subst hz
+        exact IntermediateField.subset_adjoin E S (Set.mem_insert _ _)
+      exact hle c.2
+    rw [← b.sum_repr y]
+    refine Subfield.sum_mem _ fun i _ => ?_
+    rw [IntermediateField.smul_def]
+    exact mul_mem (hKx _) (IntermediateField.subset_adjoin E S (Set.mem_insert_of_mem _ ⟨i, rfl⟩))
+  rw [htop] at hM
+  exact (IntermediateField.topEquiv (F := E) (E := F)).toLinearEquiv.finiteDimensional
+
+end AlgebraicCurve.FF2KE3
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] {t : F}
+    (ht : Transcendental K t) :
+    FiniteDimensional (IntermediateField.adjoin K ({t} : Set F)) F :=
+  AlgebraicCurve.FF2KE3.finiteDimensional_adjoin_of_transcendental' x ht
+
+end S_AlgebraicCurve_finiteDimensional_adjoin_of_transcendental
+end P2MW
+export P2MW.S_AlgebraicCurve_finiteDimensional_adjoin_of_transcendental (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.finiteDimensional_adjoin_of_transcendental {K F : Type*} [Field K] [Field F]
+    [Algebra K F] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] {t : F}
+    (ht : Transcendental K t) :
+    FiniteDimensional (IntermediateField.adjoin K ({t} : Set F)) F :=
+  solution x ht
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finiteDimensional_lSpace.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finiteDimensional_lSpace.lean
new file mode 100644
index 0000000000..3f99f28d0b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finiteDimensional_lSpace.lean
@@ -0,0 +1,1061 @@
+/-
+Based on Prove2Me node AlgebraicCurve.finiteDimensional_lSpace
+(2999d7ea-42e7-50ff-ba72-d5940f309b72) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d0998c16-c88f-588c-9160-ad9b2e2f6692
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import Mathlib.RingTheory.Flat.TorsionFree
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finite-dimensionality of all L(D) from that of L(0)
+
+Theorem statement: `AlgebraicCurve.finiteDimensional_lSpace`
+(`2999d7ea-42e7-50ff-ba72-d5940f309b72`), by Claude, 2026-09-05.
+
+Proof: submission `d0998c16-c88f-588c-9160-ad9b2e2f6692`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and suppose $F/K$ is a curve in the sense of the
+predicate `IsCurveOver`: every nonzero $f \in F$ admits a divisor $D$ with $D(v) =
+v.\mathrm{ord}(f)$ at every place $v$ and $\deg D = 0$; every place $v$ has residue field
+$v.\mathrm{ResidueField}$ finite over $K$; and the module of Kähler differentials $\Omega[F/K]$ is
+free of rank $1$ over $F$. Here a place of $F/K$ is a valuation subring of $F$ that contains the
+image of $K$, is not all of $F$, and is a principal ideal ring, and a divisor is a finitely
+supported function from places to $\mathbb{Z}$. For a divisor $D$, $L(D) =$ `LSpace D` is the
+$K$-submodule of $F$ consisting of those $f$ with $v.\mathrm{adicValuation}(f) \le \exp(D(v))$ for
+every place $v$. Assume in addition that $L(0)$, the space attached to the zero divisor, is
+finite-dimensional over $K$. The conclusion is that for every divisor $D$ the space $L(D)$ is
+finite-dimensional over $K$.
+
+This is the basic finiteness statement of the Riemann–Roch theory of a one-variable function field:
+all Riemann–Roch spaces are finite-dimensional as soon as the space of the zero divisor is. It
+serves as the standing finiteness hypothesis for the dimension counts $\ell(D)$ used throughout the
+development of the index and Riemann–Roch formulae, and is cited by a large number of subsequent
+results there, including the descent statements for divisor classes under constant field extensions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_finiteDimensional_lSpace.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_finiteDimensional_lSpace
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_coe_unit ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow toValuationSubring mk adicValuation_eq_exp_neg_ord"
+p2m_open "AlgebraicCurve.Place"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+p2m_export "AlgebraicCurve.Place" "ord_nonneg_of_mem"
+p2m_export "AlgebraicCurve.Place" "mem_of_ord_nonneg"
+theorem mem_iff_ord_nonneg {f : F} (hf : f ≠ 0) :
+    f ∈ v.toValuationSubring ↔ 0 ≤ v.ord f :=
+  ⟨v.ord_nonneg_of_mem, v.mem_of_ord_nonneg hf⟩
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "degree degree_single principal smul_def smul_apply"
+end Divisor
+variable {D : Divisor K F}
+p2m_open_scoped "AlgebraicCurve.Divisor" in
+theorem Divisor.degree_nonneg_of_nonneg [IsCurveOver K F]
+    {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) : 0 ≤ Divisor.degree D := by
+  rw [Divisor.degree_eq_sum_support]
+  exact Finset.sum_nonneg fun v _ => mul_nonneg (hD v) (Int.natCast_nonneg _)
+theorem lSpace_eq_bot_of_degree_neg [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) : LSpace D = ⊥ := by
+  rw [eq_bot_iff]
+  intro f hf
+  rw [Submodule.mem_bot]
+  by_contra hf0
+  obtain ⟨P, hPord, hPdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+  have heff : ∀ v : Place K F, 0 ≤ (P + D) v := by
+    intro v
+    rw [Finsupp.add_apply, hPord]
+    rcases mem_lSpace_iff_ord.mp hf with rfl | h
+    · exact absurd rfl hf0
+    · linarith [h v]
+  have hdegPD : 0 ≤ Divisor.degree (P + D) := Divisor.degree_nonneg_of_nonneg heff
+  rw [map_add, hPdeg, zero_add] at hdegPD
+  exact absurd hdegPD (not_le.mpr hD)
+end AlgebraicCurve
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_coe_unit ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow toValuationSubring mk adicValuation_eq_exp_neg_ord"
+p2m_open "AlgebraicCurve.Place"
+
+variable (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mk_mem_maximalIdeal_iff {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    (⟨f, hf⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring
+      ↔ f = 0 ∨ 0 < v.ord f := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  constructor
+  · intro hu
+    rcases eq_or_ne f 0 with rfl | hf0
+    · exact Or.inl rfl
+    · refine Or.inr ?_
+      rcases lt_or_eq_of_le (v.ord_nonneg_of_mem hf) with h | h
+      · exact h
+      · exfalso
+        apply hu
+        rw [← v.adicValuation_coe_eq_one_iff ⟨f, hf⟩]
+        change v.adicValuation f = 1
+        rw [v.adicValuation_eq_exp_neg_ord hf0, ← h, neg_zero, WithZero.exp_zero]
+  · intro h hu
+    have hne : f ≠ 0 := fun h0 => hu.ne_zero (Subtype.ext h0)
+    have h0 : v.ord f = 0 := by
+      obtain ⟨u, hu'⟩ := hu
+      have hcoe : f = ((u : v.toValuationSubring) : F) := by rw [hu']
+      rw [hcoe]; exact v.ord_coe_unit u
+    rcases h with rfl | hpos
+    · exact hne rfl
+    · omega
+
+p2m_export "AlgebraicCurve.Place" "mk_mem_maximalIdeal_iff"
+end Place
+
+theorem ell_le_ell_sub_single_add_deg [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    ell D ≤ ell (D - Finsupp.single P 1) + P.deg := by
+  classical
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible P.toValuationSubring
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by
+    simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := by
+    intro g hg
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ g : F, g ∈ LSpace D → t ^ (D P) * g ∈ P.toValuationSubring := by
+    intro g hg
+    rcases eq_or_ne g 0 with rfl | hg0
+    · simp
+    · refine P.mem_of_ord_nonneg (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have := (mem_lSpace_iff_ord.mp hg).resolve_left hg0 P
+      linarith
+  let ψ : LSpace D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun f => ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+      map_add' := by intro f g; apply Subtype.ext; push_cast; ring
+      map_smul' := by
+        intro c f; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap]
+        ring }
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : LSpace D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ f : LSpace D, φ f = 0 ↔
+      (⟨t ^ (D P) * (f : F), hmem _ f.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := by
+    intro f
+    rw [show φ f = IsLocalRing.residue P.toValuationSubring ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+          from hres (ψ f),
+      IsLocalRing.residue_eq_zero_iff]
+  have hED : E ≤ D := by
+    rw [Finsupp.le_def]; intro v; rw [hE, Finsupp.sub_apply]
+    have : (0 : ℤ) ≤ Finsupp.single P 1 v := by
+      rcases eq_or_ne v P with rfl | hv
+      · simp
+      · simp [Finsupp.single_eq_of_ne hv]
+    linarith
+  have hsub : LSpace E ≤ LSpace D := lSpace_mono hED
+  have hker : LinearMap.ker φ = (LSpace E).comap (LSpace D).subtype := by
+    ext f
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi f, P.mk_mem_maximalIdeal_iff]
+    rcases eq_or_ne (f : F) 0 with hf0 | hf0
+    · simp only [hf0, mul_zero, true_or, true_iff]
+      exact (LSpace E).zero_mem
+    · rw [mem_lSpace_iff_ord]
+      have hfD := (mem_lSpace_iff_ord.mp f.2).resolve_left hf0
+      constructor
+      · rintro (h | h)
+        · exact absurd h (mul_ne_zero htn0 hf0)
+        · refine Or.inr (fun v => ?_)
+          rcases eq_or_ne v P with rfl | hv
+          · rw [hEP]; rw [hordmul hf0] at h; omega
+          · rw [hEv v hv]; exact hfD v
+      · rintro (h | h)
+        · exact absurd h hf0
+        · refine Or.inr ?_
+          have hP := h P
+          rw [hEP] at hP
+          rw [hordmul hf0]; omega
+  have hkerfin : finrank K (LinearMap.ker φ) = ell E := by
+    rw [hker, LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe hsub)]
+  have hquot : finrank K (LSpace D ⧸ LinearMap.ker φ) ≤ P.deg := by
+    rw [LinearEquiv.finrank_eq φ.quotKerEquivRange]
+    exact Submodule.finrank_le (LinearMap.range φ)
+  by_cases hfin : FiniteDimensional K (LSpace D)
+  · have := hfin
+    have hrn := Submodule.finrank_quotient_add_finrank (LinearMap.ker φ)
+    rw [hkerfin] at hrn
+    have hb : ell D = finrank K (LSpace D) := rfl
+    omega
+  · have h0 : ell D = 0 := by rw [ell]; exact finrank_of_infinite_dimensional hfin
+    omega
+
+theorem one_le_deg [IsCurveOver K F] (P : Place K F) : 1 ≤ P.deg := by
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  exact Module.finrank_pos
+
+theorem ell_le_degree_add_ellZero [IsCurveOver K F] {D : Divisor K F}
+    (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D : Divisor K F, (∀ v, 0 ≤ D v) →
+      (Divisor.degree D).toNat = m →
+      (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) by
+    exact H (Divisor.degree D).toNat D hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D hD hm
+    by_cases hD0 : D = 0
+    · subst hD0; simp
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ D P := by
+        have hne : D P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hD P; omega
+      set E : Divisor K F := D - Finsupp.single P 1 with hE
+      have hEeff : ∀ v, 0 ≤ E v := by
+        intro v; rw [hE, Finsupp.sub_apply]
+        rcases eq_or_ne v P with rfl | hv
+        · rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have hdegE : Divisor.degree E = Divisor.degree D - P.deg := by
+        rw [hE, map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hDnn : 0 ≤ Divisor.degree D := Divisor.degree_nonneg_of_nonneg hD
+      have hEnn : 0 ≤ Divisor.degree E := Divisor.degree_nonneg_of_nonneg hEeff
+      have hmlt : (Divisor.degree E).toNat < m := by rw [← hm]; omega
+      have hIH := IH _ hmlt E hEeff rfl
+      have hstep := ell_le_ell_sub_single_add_deg D P
+      rw [← hE] at hstep
+      have hstep' : (ell D : ℤ) ≤ (ell E : ℤ) + P.deg := by exact_mod_cast hstep
+      rw [hdegE] at hIH
+      linarith
+
+theorem ell_le_degree_add_one_of_effective [IsCurveOver K F]
+    (hC : ConstantsAreBase K F) {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  have h := ell_le_degree_add_ellZero hD
+  rw [ell_zero_eq_one_of_constantsAreBase hC] at h
+  exact_mod_cast h
+
+def lSpaceShiftEquiv (D : Divisor K F) {g : F} (hg : g ≠ 0)
+    {Dg : Divisor K F} (hDg : ∀ v, Dg v = v.ord g) :
+    LSpace D ≃ₗ[K] LSpace (D + Dg) where
+  toFun h := ⟨(h : F) * g⁻¹, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (h : F) 0 with hh0 | hh0
+    · left; rw [hh0, zero_mul]
+    · right; intro v
+      rw [Finsupp.add_apply, hDg, v.ord_mul hh0 (inv_ne_zero hg), v.ord_inv]
+      have := (mem_lSpace_iff_ord.mp h.2).resolve_left hh0 v
+      linarith⟩
+  invFun k := ⟨(k : F) * g, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (k : F) 0 with hk0 | hk0
+    · left; rw [hk0, zero_mul]
+    · right; intro v
+      have := (mem_lSpace_iff_ord.mp k.2).resolve_left hk0 v
+      rw [Finsupp.add_apply, hDg] at this
+      rw [v.ord_mul hk0 hg]
+      linarith⟩
+  map_add' h₁ h₂ := by apply Subtype.ext; push_cast; ring
+  map_smul' c h := by
+    apply Subtype.ext
+    simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def]
+    ring
+  left_inv h := by
+    apply Subtype.ext
+    change (h : F) * g⁻¹ * g = (h : F)
+    rw [mul_assoc, inv_mul_cancel₀ hg, mul_one]
+  right_inv k := by
+    apply Subtype.ext
+    change (k : F) * g * g⁻¹ = (k : F)
+    rw [mul_assoc, mul_inv_cancel₀ hg, mul_one]
+
+theorem ell_le_degree_add_one [IsCurveOver K F] (hC : ConstantsAreBase K F)
+    {D : Divisor K F} (hD : 0 ≤ Divisor.degree D) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  rcases eq_or_ne (ell D) 0 with h0 | h0
+  · rw [h0]; push_cast; linarith
+  · have hbot : LSpace D ≠ ⊥ := fun h => h0 (by rw [ell, h, finrank_bot])
+    obtain ⟨g, hgL, hg0⟩ := (Submodule.ne_bot_iff _).mp hbot
+    obtain ⟨Dg, hDgord, hDgdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) g hg0
+    have heff : ∀ v, 0 ≤ (D + Dg) v := by
+      intro v; rw [Finsupp.add_apply, hDgord]
+      have := (mem_lSpace_iff_ord.mp hgL).resolve_left hg0 v
+      linarith
+    have hdeg : Divisor.degree (D + Dg) = Divisor.degree D := by
+      rw [map_add, hDgdeg, add_zero]
+    have hell : ell D = ell (D + Dg) :=
+      LinearEquiv.finrank_eq (lSpaceShiftEquiv D hg0 hDgord)
+    have hfin := ell_le_degree_add_one_of_effective hC heff
+    rw [hdeg] at hfin
+    rw [hell]; exact hfin
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion mk mem_bot subtype_injective \
+  Quotient.subsingleton_iff Quotient.mk restrictScalars inclusion_injective comapSubtypeEquivOfLe \
+  mem_comap finrank_quotient_add_finrank mem_top Quotient.equiv mkQ mem_map coe_subtype map_smul' \
+  zero one quotientQuotientEquivQuotient coe_eq_zero finrank_le range_subtype \
+  Quotient.mk_surjective map mem_inf mem_sup Quotient.mk_eq_zero topEquiv \
+  map_injective_of_injective comap_subtype_self mapQ subsingleton_iff module smul_def mk_eq_zero \
+  coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono map_sup"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+def nestedComapMapMkQEquiv {A B C : Submodule K X} (_hAB : A ≤ B) (hBC : B ≤ C) :
+    ((B.comap C.subtype).map (A.comap C.subtype).mkQ : Submodule K _)
+      ≃ₗ[K] B ⧸ A.comap B.subtype := by
+  set S := A.comap C.subtype with hS
+  set T := B.comap C.subtype with hT
+  let ψ : (T : Type _) →ₗ[K] (C ⧸ S) := S.mkQ ∘ₗ T.subtype
+  have hker : LinearMap.ker ψ = S.comap T.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = T.map S.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let e1 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (T.map S.mkQ : Submodule K _) :=
+    (Submodule.Quotient.equiv _ (LinearMap.ker ψ) (LinearEquiv.refl K T)
+        (by rw [hker]; simp)).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have hmap : (S.comap T.subtype).map
+      (Submodule.comapSubtypeEquivOfLe hBC : (T : Type _) →ₗ[K] B) = A.comap B.subtype := by
+    ext ⟨b, hb⟩
+    simp only [mem_map, mem_comap, Submodule.coe_subtype, hS]
+    constructor
+    · rintro ⟨⟨⟨x, hxC⟩, hxB⟩, hxA, hxeq⟩
+      have hx : x = b := congrArg Subtype.val hxeq
+      subst hx; exact hxA
+    · intro hbA
+      exact ⟨⟨⟨b, hBC hb⟩, hb⟩, hbA, rfl⟩
+  let e2 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (B ⧸ A.comap B.subtype) :=
+    Submodule.Quotient.equiv _ _ (Submodule.comapSubtypeEquivOfLe hBC) hmap
+  exact e1.symm.trans e2
+
+theorem finrank_quotient_chain {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCB : Module.Finite K (C ⧸ B.comap C.subtype)]
+    [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (C ⧸ A.comap C.subtype) ∧
+      finrank K (C ⧸ A.comap C.subtype)
+        = finrank K (C ⧸ B.comap C.subtype) + finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (T.map S.mkQ : Submodule K _) := Module.Finite.equiv eK.symm
+  have : Module.Finite K ((C ⧸ S) ⧸ T.map S.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (C ⧸ S) := Module.Finite.of_submodule_quotient (T.map S.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+theorem finrank_quotient_chain' {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCA : Module.Finite K (C ⧸ A.comap C.subtype)] :
+    Module.Finite K (C ⧸ B.comap C.subtype) ∧
+      finrank K (C ⧸ B.comap C.subtype)
+        = finrank K (C ⧸ A.comap C.subtype) - finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (C ⧸ T) := Module.Finite.equiv e3
+  refine ⟨this, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+def adeleBddQuotSingleEquivResidueField (D : Divisor K F) (P : Place K F) :
+    (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+      ≃ₗ[K] P.ResidueField := by
+  classical
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  let π : P.toValuationSubring :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose
+  have hπ : Irreducible π :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose_spec
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := fun {g} hg => by
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ α : Place K F → F, α ∈ adeleBdd D → t ^ (D P) * α P ∈ P.toValuationSubring := by
+    intro α hα
+    rcases eq_or_ne (α P) 0 with hg0 | hg0
+    · simp [hg0]
+    · refine P.mem_of_ord_nonneg (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have h := hα P
+      rw [P.adicValuation_eq_exp_neg_ord hg0, WithZero.exp_le_exp] at h
+      linarith
+  let ψ : adeleBdd D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun α => ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩
+      map_add' := by
+        intro α β; apply Subtype.ext
+        simp only [Submodule.coe_add, Pi.add_apply]
+        push_cast; ring
+      map_smul' := by
+        intro c α; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap, Pi.smul_apply]
+        ring }
+  have hψ_apply : ∀ α : adeleBdd D,
+      (ψ α : F) = t ^ (D P) * (α : Place K F → F) P := fun α => rfl
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : adeleBdd D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ α : adeleBdd D, φ α = 0 ↔
+      (⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := fun α => by
+    rw [show φ α = IsLocalRing.residue P.toValuationSubring
+            ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ from hres (ψ α),
+      IsLocalRing.residue_eq_zero_iff]
+  have hker : LinearMap.ker φ = (adeleBdd E).comap (adeleBdd D).subtype := by
+    ext α
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi α, P.mk_mem_maximalIdeal_iff, mem_adeleBdd]
+    have hαD := α.2
+    constructor
+    · rintro (h | h) v
+      · have hα0 : (α : Place K F → F) P = 0 := by
+          rcases mul_eq_zero.mp h with h' | h'
+          · exact absurd h' htn0
+          · exact h'
+        by_cases hv : v = P
+        · subst v; rw [hα0, Valuation.map_zero]; exact zero_le
+        · rw [hEv v hv]; exact hαD v
+      · by_cases hv : v = P
+        · subst v
+          rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+          · rw [hα0, Valuation.map_zero]; exact zero_le
+          · rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP]
+            rw [hordmul hα0] at h; omega
+        · rw [hEv v hv]; exact hαD v
+    · intro h
+      rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+      · left; rw [hα0, mul_zero]
+      · right
+        have hP := h P
+        rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP] at hP
+        rw [hordmul hα0]; omega
+  have hsurj : Function.Surjective φ := by
+    intro c
+    obtain ⟨cl, hcl⟩ := IsLocalRing.residue_surjective (R := P.toValuationSubring) c
+    set f : F := (cl : F) * t ^ (-(D P)) with hf
+    have hαD : Pi.single P f ∈ adeleBdd D := by
+      intro v
+      by_cases hv : v = P
+      · subst v
+        simp only [Pi.single_eq_same]
+        rcases eq_or_ne (cl : F) 0 with hc0 | hc0
+        · rw [hf, hc0, zero_mul, Valuation.map_zero]; exact zero_le
+        · have hf0 : f ≠ 0 := by rw [hf]; exact mul_ne_zero hc0 (zpow_ne_zero _ ht0)
+          rw [P.adicValuation_eq_exp_neg_ord hf0, WithZero.exp_le_exp]
+          rw [hf, P.ord_mul hc0 (zpow_ne_zero _ ht0), P.ord_zpow, ht1, mul_one]
+          have hclnn := P.ord_nonneg_of_mem cl.2
+          linarith
+      · rw [Pi.single_eq_of_ne hv, Valuation.map_zero]; exact zero_le
+    refine ⟨⟨Pi.single P f, hαD⟩, ?_⟩
+    change res (ψ ⟨Pi.single P f, hαD⟩) = c
+    rw [hres]
+    rw [show (ψ ⟨Pi.single P f, hαD⟩ : P.toValuationSubring) = cl from ?_, hcl]
+    apply Subtype.ext
+    rw [hψ_apply]
+    change t ^ (D P) * (Pi.single P f : Place K F → F) P = (cl : F)
+    rw [show (Pi.single P f : Place K F → F) P = f from Pi.single_eq_same _ _, hf,
+      mul_comm (cl : F), ← mul_assoc, ← zpow_add₀ ht0, add_neg_cancel, zpow_zero, one_mul]
+  exact (Submodule.Quotient.equiv _ _ (LinearEquiv.refl K _) (by rw [← hker]; simp)).trans
+    (φ.quotKerEquivOfSurjective hsurj)
+
+theorem finrank_adeleBdd_quotient_single [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    Module.Finite K
+        (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype) ∧
+      finrank K
+          (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+        = P.deg := by
+  have := IsCurveOver.finite_residueField (K := K) P
+  exact ⟨Module.Finite.equiv (adeleBddQuotSingleEquivResidueField D P).symm,
+    (adeleBddQuotSingleEquivResidueField D P).finrank_eq⟩
+
+theorem finrank_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+      (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+        = Divisor.degree D₂ - Divisor.degree D₁ := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D₁ D₂ : Divisor K F, D₁ ≤ D₂ →
+      (Divisor.degree (D₂ - D₁)).toNat = m →
+      Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+        (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+          = Divisor.degree D₂ - Divisor.degree D₁ from
+    H _ D₁ D₂ hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D₁ D₂ hD hm
+    have hEeff : ∀ v, 0 ≤ (D₂ - D₁) v := fun v => by
+      rw [Finsupp.sub_apply]; have := hD v; omega
+    by_cases hD0 : D₂ - D₁ = 0
+    · have hD12 : D₁ = D₂ := (sub_eq_zero.mp hD0).symm
+      subst hD12
+      rw [Submodule.comap_subtype_self]
+      have : Subsingleton (adeleBdd D₁ ⧸ (⊤ : Submodule K (adeleBdd D₁))) :=
+        Submodule.Quotient.subsingleton_iff.mpr rfl
+      exact ⟨Module.Finite.of_finite, by simp [Module.finrank_zero_of_subsingleton]⟩
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ (D₂ - D₁) P := by
+        have hne : (D₂ - D₁) P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hEeff P; omega
+      set D₂' : Divisor K F := D₂ - Finsupp.single P 1 with hD₂'
+      have h12' : D₁ ≤ D₂' := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]
+          have := hPpos; rw [Finsupp.sub_apply] at this; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have h2'2 : D₂' ≤ D₂ := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]
+      have hdegD₂' : Divisor.degree D₂' = Divisor.degree D₂ - P.deg := by
+        rw [hD₂', map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hEnn : 0 ≤ Divisor.degree (D₂ - D₁) := Divisor.degree_nonneg_of_nonneg hEeff
+      have hE'nn : 0 ≤ Divisor.degree (D₂' - D₁) := Divisor.degree_nonneg_of_nonneg
+        (fun v => by rw [Finsupp.sub_apply]; have := h12' v; omega)
+      have hdegdiff : Divisor.degree (D₂' - D₁) = Divisor.degree (D₂ - D₁) - P.deg := by
+        simp only [hD₂', map_sub, Divisor.degree_single, one_mul]; ring
+      have hmlt : (Divisor.degree (D₂' - D₁)).toNat < m := by rw [← hm]; omega
+      obtain ⟨hfin', hrank'⟩ := IH _ hmlt D₁ D₂' h12' rfl
+      obtain ⟨hfinS, hrankS⟩ := finrank_adeleBdd_quotient_single (K := K) D₂ P
+      rw [← hD₂'] at hfinS hrankS
+      have := hfin'; have := hfinS
+      obtain ⟨hfin, hrank⟩ := Submodule.finrank_quotient_chain
+        (A := adeleBdd D₁) (B := adeleBdd D₂') (C := adeleBdd D₂)
+        (adeleBdd_mono h12') (adeleBdd_mono h2'2)
+      refine ⟨hfin, ?_⟩
+      rw [hrank, hrankS]
+      push_cast
+      linarith [hrank', hdegD₂']
+
+theorem module_finite_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  (finrank_adeleBdd_quotient hD).1
+
+theorem finrank_adeleBdd_quotient_eq [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+      = Divisor.degree D₂ - Divisor.degree D₁ :=
+  (finrank_adeleBdd_quotient hD).2
+
+def lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (_hD : D₁ ≤ D₂) :
+    (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      →ₗ[K] (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  Submodule.mapQ _ _
+    ((diagonalHom K F).restrict
+      (p := (LSpace D₂ : Submodule K F)) (q := (adeleBdd D₂ : Submodule K _))
+      (fun f hf => diagonal_mem_adeleBdd_iff.mpr hf))
+    (fun f hf => by
+      simp only [Submodule.mem_comap, Submodule.coe_subtype] at hf ⊢
+      exact diagonal_mem_adeleBdd_iff.mpr hf)
+
+theorem lSpaceQuotientToAdeleBddQuotient_injective {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Function.Injective (lSpaceQuotientToAdeleBddQuotient hD) := by
+  rw [injective_iff_map_eq_zero]
+  intro x hx
+  obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+  rw [Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype]
+  rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk f)
+        = Submodule.Quotient.mk ((diagonalHom K F).restrict
+            (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f) from rfl,
+    Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype] at hx
+  exact diagonal_mem_adeleBdd_iff.mp hx
+
+
+theorem ell_sub_ell_le_degree_sub_degree [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)] :
+    (ell D₂ : ℤ) - (ell D₁ : ℤ) ≤ Divisor.degree D₂ - Divisor.degree D₁ := by
+  have := module_finite_adeleBdd_quotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    rw [hℓ₁]; exact (Submodule.finrank_quotient_add_finrank _).symm
+  have hemb : finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      ≤ finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+    LinearMap.finrank_le_finrank_of_injective (lSpaceQuotientToAdeleBddQuotient_injective hD)
+  have hloc := finrank_adeleBdd_quotient_eq hD
+  have : (ell D₂ : ℤ) - (ell D₁ : ℤ)
+      = (finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) : ℤ) := by
+    rw [hL]; push_cast; ring
+  rw [this, ← hloc]
+  exact_mod_cast hemb
+
+theorem adeleBdd_inf_sup_globalSub {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F)
+      = adeleBdd D₁ ⊔ adeleBdd D₂ ⊓ globalSub K F := by
+  rw [inf_comm, sup_inf_assoc_of_le _ (adeleBdd_mono hD), inf_comm]
+
+theorem map_diagonal_lSpace_inf_adeleBdd {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (LSpace D₂).map (diagonalHom K F) ⊓ adeleBdd D₁ = (LSpace D₁).map (diagonalHom K F) := by
+  rw [map_diagonal_lSpace, map_diagonal_lSpace, inf_right_comm,
+    inf_eq_right.mpr (adeleBdd_mono hD)]
+
+theorem gate_finrank_adeleBdd_quotient_single_point [IsCurveOver K F] (P : Place K F) :
+    (finrank K (adeleBdd (Finsupp.single P 1 : Divisor K F)
+        ⧸ (adeleBdd (0 : Divisor K F)).comap (adeleBdd (Finsupp.single P 1)).subtype) : ℤ)
+      = (P.deg : ℤ) := by
+  classical
+  have h01 : (0 : Divisor K F) ≤ Finsupp.single P 1 := by
+    intro v; rw [Finsupp.zero_apply, Finsupp.single_apply]; split_ifs <;> omega
+  have h := finrank_adeleBdd_quotient_eq (K := K) h01
+  rw [h, map_zero, sub_zero, Divisor.degree_single, one_mul]
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion mk mem_bot subtype_injective \
+  Quotient.subsingleton_iff Quotient.mk restrictScalars inclusion_injective comapSubtypeEquivOfLe \
+  mem_comap finrank_quotient_add_finrank mem_top Quotient.equiv mkQ mem_map coe_subtype map_smul' \
+  zero one quotientQuotientEquivQuotient coe_eq_zero finrank_le range_subtype \
+  Quotient.mk_surjective map mem_inf mem_sup Quotient.mk_eq_zero topEquiv \
+  map_injective_of_injective comap_subtype_self mapQ subsingleton_iff module smul_def mk_eq_zero \
+  coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono map_sup"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+theorem comap_subtype_sup_of_le_of_le {S T C : Submodule K X} (hS : S ≤ C) (hT : T ≤ C) :
+    S.comap C.subtype ⊔ T.comap C.subtype = (S ⊔ T).comap C.subtype := by
+  apply Submodule.map_injective_of_injective (f := C.subtype) C.subtype_injective
+  rw [Submodule.map_sup, Submodule.map_comap_subtype, Submodule.map_comap_subtype,
+    Submodule.map_comap_subtype, inf_eq_right.mpr hS, inf_eq_right.mpr hT,
+    inf_eq_right.mpr (sup_le hS hT)]
+
+theorem finrank_quotient_chain_top {M : Type*} [AddCommGroup M] [Module K M]
+    {A B : Submodule K M} (hAB : A ≤ B)
+    [hMB : Module.Finite K (M ⧸ B)] [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (M ⧸ A) ∧
+      finrank K (M ⧸ A) = finrank K (M ⧸ B) + finrank K (B ⧸ A.comap B.subtype) := by
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  let ψ : (B : Type _) →ₗ[K] (M ⧸ A) := A.mkQ ∘ₗ B.subtype
+  have hker : LinearMap.ker ψ = A.comap B.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = B.map A.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let eK : (B ⧸ A.comap B.subtype) ≃ₗ[K] (B.map A.mkQ : Submodule K (M ⧸ A)) :=
+    (Submodule.quotEquivOfEq _ _ hker.symm).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have : Module.Finite K (B.map A.mkQ : Submodule K (M ⧸ A)) := Module.Finite.equiv eK
+  have : Module.Finite K ((M ⧸ A) ⧸ B.map A.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (M ⧸ A) := Module.Finite.of_submodule_quotient (B.map A.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (B.map A.mkQ)
+  rw [LinearEquiv.finrank_eq e3, ← LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem globalSub_le_adeleSpace [HasPrincipalDivisors K F] :
+    globalSub K F ≤ adeleSpace K F := by
+  rintro _ ⟨f, rfl⟩
+  exact diagonal_mem_adeleSpace f
+
+theorem adeleBdd_sup_globalSub_le_adeleSpace [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+  sup_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_eq_comap [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBddPrincipal K F D = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype :=
+  Submodule.comap_subtype_sup_of_le_of_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_mono {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBddPrincipal K F D₁ ≤ adeleBddPrincipal K F D₂ :=
+  sup_le_sup_right (Submodule.comap_mono (adeleBdd_mono hD)) _
+
+section FiniteLSpace
+
+variable [IsCurveOver K F]
+
+theorem finiteDimensional_lSpace_port [hL0 : FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (D : Divisor K F) : FiniteDimensional K (LSpace D) := by
+  have h0D : (0 : Divisor K F) ≤ D ⊔ 0 := le_sup_right
+  have hDD : D ≤ D ⊔ 0 := le_sup_left
+  suffices h : FiniteDimensional K (LSpace (D ⊔ 0)) by
+    exact Module.Finite.of_injective (Submodule.inclusion (lSpace_mono hDD))
+      (Submodule.inclusion_injective _)
+  have := module_finite_adeleBdd_quotient (K := K) h0D
+  have hfinQ : FiniteDimensional K
+      (LSpace (D ⊔ 0) ⧸ (LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype) :=
+    Module.Finite.of_injective _ (lSpaceQuotientToAdeleBddQuotient_injective h0D)
+  have : FiniteDimensional K
+      ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype : Submodule K _) :=
+    Module.Finite.equiv (Submodule.comapSubtypeEquivOfLe (lSpace_mono h0D)).symm
+  exact Module.Finite.of_submodule_quotient
+    ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype)
+
+end FiniteLSpace
+
+
+theorem range_lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD)
+      = ((adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype).map
+          ((adeleBdd D₁).comap (adeleBdd D₂).subtype).mkQ := by
+  classical
+  ext z
+  obtain ⟨α, rfl⟩ := Submodule.Quotient.mk_surjective _ z
+  simp only [LinearMap.mem_range, Submodule.mem_map, Submodule.mem_comap, Submodule.coe_subtype,
+    Submodule.mkQ_apply]
+  constructor
+  · rintro ⟨x, hx⟩
+    obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+    have hxeq : Submodule.Quotient.mk
+        ((diagonalHom K F).restrict (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f)
+        = (Submodule.Quotient.mk α :
+            adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) := hx
+    refine ⟨α, ?_, rfl⟩
+    have hdiag2 : (diagonalHom K F (f : F)) ∈ adeleBdd D₂ := diagonal_mem_adeleBdd_iff.mpr f.2
+    have hsub : (α : Place K F → F) - diagonalHom K F (f : F) ∈ adeleBdd D₁ := by
+      have hq := (Submodule.Quotient.eq _).mp hxeq.symm
+      simpa using hq
+    refine Submodule.mem_sup.mpr ⟨(α : Place K F → F) - diagonalHom K F (f : F), hsub,
+      diagonalHom K F (f : F), diagonal_mem_globalSub _, ?_⟩
+    abel
+  · rintro ⟨β, hβ, hβeq⟩
+    have hβ' : (β : Place K F → F) ∈ adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F) :=
+      Submodule.mem_inf.mpr ⟨β.2, hβ⟩
+    rw [adeleBdd_inf_sup_globalSub hD, ← map_diagonal_lSpace] at hβ'
+    obtain ⟨γ, hγ, δ, ⟨f, hf, hfδ⟩, hsum⟩ := Submodule.mem_sup.mp hβ'
+    refine ⟨Submodule.Quotient.mk ⟨f, hf⟩, ?_⟩
+    rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk ⟨f, hf⟩)
+          = Submodule.Quotient.mk ((diagonalHom K F).restrict
+              (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) ⟨f, hf⟩) from rfl,
+      ← hβeq, Submodule.Quotient.eq]
+    refine Submodule.mem_comap.mpr ?_
+    change diagonalHom K F f - (β : Place K F → F) ∈ adeleBdd D₁
+    have hβsub : diagonalHom K F f - (β : Place K F → F) = -γ := by
+      rw [← hsum, hfδ]; ring
+    rw [hβsub]; exact (adeleBdd D₁).neg_mem hγ
+
+
+theorem finrank_adeleBddSup_quotient [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) [hL : FiniteDimensional K (LSpace D₂)] :
+    Module.Finite K (↥(adeleBdd D₂ ⊔ globalSub K F)
+        ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) ∧
+      (finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+          ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) : ℤ)
+        = (Divisor.degree D₂ - ell D₂) - (Divisor.degree D₁ - ell D₁) := by
+  classical
+  let A : Submodule K (adeleBdd D₂) := (adeleBdd D₁).comap (adeleBdd D₂).subtype
+  let B : Submodule K (adeleBdd D₂) :=
+    (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype
+  have hAB : A ≤ B := Submodule.comap_mono le_sup_left
+  have hfinA : Module.Finite K (adeleBdd D₂ ⧸ A) := module_finite_adeleBdd_quotient hD
+  have hdimA : (finrank K (adeleBdd D₂ ⧸ A) : ℤ) = Divisor.degree D₂ - Divisor.degree D₁ :=
+    finrank_adeleBdd_quotient_eq hD
+  have hran : LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD) = B.map A.mkQ :=
+    range_lSpaceQuotientToAdeleBddQuotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hdimL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K)
+      ((LSpace D₁).comap (LSpace D₂).subtype)
+    rw [← hℓ₁] at h; exact h.symm
+  have hdimB : ell D₂ = finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) + ell D₁ := by
+    rw [← hran, LinearMap.finrank_range_of_inj
+      (lSpaceQuotientToAdeleBddQuotient_injective hD)]
+    exact hdimL
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  have hfinB : Module.Finite K (adeleBdd D₂ ⧸ B) := Module.Finite.equiv e3
+  have hdim2 : finrank K (adeleBdd D₂ ⧸ A)
+      = finrank K (adeleBdd D₂ ⧸ B) + finrank K (B.map A.mkQ : Submodule K _) := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K) (M := adeleBdd D₂ ⧸ A)
+      (B.map A.mkQ)
+    rw [LinearEquiv.finrank_eq e3] at h; omega
+  have e2 := LinearMap.quotientInfEquivSupQuotient (R := K)
+    (adeleBdd D₂) (adeleBdd D₁ ⊔ globalSub K F)
+  have hsup : adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F) = adeleBdd D₂ ⊔ globalSub K F := by
+    rw [← sup_assoc, sup_eq_left.mpr (adeleBdd_mono hD)]
+  have hB' : (adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype = B := by
+    rw [Submodule.comap_subtype_self, top_inf_eq]
+  let eL : (adeleBdd D₂ ⧸ B) ≃ₗ[K]
+      (adeleBdd D₂ ⧸ ((adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+        (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype)) :=
+    Submodule.quotEquivOfEq _ _ hB'.symm
+  have hfin_iso : Module.Finite K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype) :=
+    Module.Finite.equiv (eL.trans e2)
+  have hdim_iso : finrank K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype)
+      = finrank K (adeleBdd D₂ ⧸ B) :=
+    (LinearEquiv.finrank_eq (eL.trans e2)).symm
+  have hcast : (finrank K (adeleBdd D₂ ⧸ A) : ℤ)
+      = (finrank K (adeleBdd D₂ ⧸ B) : ℤ) + ((ell D₂ : ℤ) - (ell D₁ : ℤ)) := by
+    have hb : (ell D₂ : ℤ)
+        = (finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) : ℤ) + (ell D₁ : ℤ) := by
+      exact_mod_cast hdimB
+    push_cast [hdim2]; linarith
+  have hgoal : (finrank K (adeleBdd D₂ ⧸ B) : ℤ)
+      = Divisor.degree D₂ - ↑(ell D₂) - (Divisor.degree D₁ - ↑(ell D₁)) := by
+    linarith [hdimA, hcast]
+  clear_value eL
+  exact hsup ▸ ⟨hfin_iso, by rw [hdim_iso]; exact hgoal⟩
+
+section Index
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+
+theorem adeleBddSup_eq_of_degree_sub_ell_eq {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)]
+    (heq : Divisor.degree D₂ - ell D₂ = Divisor.degree D₁ - ell D₁) :
+    adeleBdd D₂ ⊔ globalSub K F = adeleBdd D₁ ⊔ globalSub K F := by
+  obtain ⟨hfin, hdim⟩ := finrank_adeleBddSup_quotient hD
+  rw [heq, sub_self] at hdim
+  refine le_antisymm ?_ (sup_le_sup_right (adeleBdd_mono hD) _)
+  have := hfin
+  have hd0 : finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) = 0 := by
+    exact_mod_cast hdim
+  have hsub : Subsingleton (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) :=
+    Module.finrank_zero_iff.mp hd0
+  have htop := Submodule.Quotient.subsingleton_iff.mp hsub
+  intro x hx
+  have hxc : (⟨x, hx⟩ : ↥(adeleBdd D₂ ⊔ globalSub K F)) ∈
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype := by
+    rw [htop]; exact Submodule.mem_top
+  exact hxc
+
+end Index
+
+namespace RiemannGenusReachedAt
+p2m_export "AlgebraicCurve.RiemannGenusReachedAt" "finite mk eq isMax"
+end RiemannGenusReachedAt
+namespace RiemannGenusReachedAt
+p2m_open_scoped "AlgebraicCurve.RiemannGenusReachedAt" in
+private theorem _root_.AlgebraicCurve.RiemannGenusReachedAt.eq_of_ge [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {D : Divisor K F} (hD : D₀ ≤ D) :
+    Divisor.degree D - ell D = γ - 1 := by
+  have := finiteDimensional_lSpace_port (K := K) D
+  have hge : Divisor.degree D₀ - (ell D₀ : ℤ) ≤ Divisor.degree D - ell D := by
+    have := ell_sub_ell_le_degree_sub_degree (K := K) hD
+    linarith
+  exact le_antisymm (h.isMax D) (h.eq ▸ hge)
+
+end RiemannGenusReachedAt
+p2m_export "AlgebraicCurve" "RiemannGenusReachedAt.eq_of_ge"
+
+theorem adeleSpace_eq_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    adeleSpace K F = adeleBdd D₀ ⊔ globalSub K F := by
+  refine le_antisymm ?_ (adeleBdd_sup_globalSub_le_adeleSpace D₀)
+  rw [adeleSpace, iSup_le_iff]
+  intro D
+  refine le_trans (adeleBdd_mono (le_sup_left : D ≤ D ⊔ D₀)) ?_
+  have := finiteDimensional_lSpace_port (K := K) (D ⊔ D₀)
+  have heq : Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) = Divisor.degree D₀ - ell D₀ :=
+    (h.eq_of_ge le_sup_right).trans h.eq.symm
+  have hsup := adeleBddSup_eq_of_degree_sub_ell_eq (K := K)
+    (le_sup_right : D₀ ≤ D ⊔ D₀) heq
+  rw [← hsup]
+  exact le_sup_left
+
+theorem indexOfSpecialty_eq_zero_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    indexOfSpecialty D₀ = 0 := by
+  rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap, ← adeleSpace_eq_of_genusReached h,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.finrank_zero_of_subsingleton
+
+
+
+theorem gate_indexOfSpecialty_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  have h1 := (indexOfSpecialty_eq_of_genusReached h D₀).2
+  have h2 := h.eq
+  have h3 := indexOfSpecialty_eq_zero_of_genusReached h
+  exact_mod_cast h3
+
+theorem gate_riemannInequality_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Divisor.degree D + 1 - γ ≤ (ell D : ℤ) := by
+  have heq := (indexOfSpecialty_eq_of_genusReached h D).2
+  have hnn : (0 : ℤ) ≤ indexOfSpecialty D := Int.natCast_nonneg _
+  linarith
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve _root_.P2MW.S_AlgebraicCurve_finiteDimensional_lSpace.AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F]
+    [hL0 : FiniteDimensional K ↥(LSpace (0 : Divisor K F))]
+    (D : Divisor K F) : FiniteDimensional K ↥(LSpace D) :=
+  AlgebraicCurve.finiteDimensional_lSpace_port (K := K) (F := F) (D := D)
+
+end S_AlgebraicCurve_finiteDimensional_lSpace
+end P2MW
+export P2MW.S_AlgebraicCurve_finiteDimensional_lSpace (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace AlgebraicCurve
+theorem finiteDimensional_lSpace {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F]
+    [hL0 : FiniteDimensional K ↥(LSpace (0 : Divisor K F))]
+    (D : Divisor K F) : FiniteDimensional K ↥(LSpace D) :=
+  solution D
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finiteDimensional_lSpace_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finiteDimensional_lSpace_zero.lean
new file mode 100644
index 0000000000..8456cc853c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finiteDimensional_lSpace_zero.lean
@@ -0,0 +1,164 @@
+/-
+Based on Prove2Me node AlgebraicCurve.finiteDimensional_lSpace_zero
+(2237db3c-cf22-51ab-9ad1-840755d4ac5f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6d18a7c7-683f-5c3d-875b-2a48478665d4
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finite-dimensionality of L(0) on a curve
+
+Theorem statement: `AlgebraicCurve.finiteDimensional_lSpace_zero`
+(`2237db3c-cf22-51ab-9ad1-840755d4ac5f`), by Claude, 2026-09-05.
+
+Proof: submission `6d18a7c7-683f-5c3d-875b-2a48478665d4`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $\mathrm{Place}\,K\,F$ denote the set of
+places of $F/K$, a place being a valuation subring of $F$ that contains the image of $K$ under the
+structure map, is not all of $F$, and is a principal ideal ring. A divisor is a finitely supported
+function from places to $\mathbb{Z}$. Assume `IsCurveOver K F`, that is: every nonzero $f \in F$
+admits a divisor $D$ with $D(v) = \operatorname{ord}_v(f)$ at every place $v$ and of degree $0$; the
+residue field of every place is a finite $K$-module; and the module of Kähler differentials
+$\Omega_{F/K}$ is free of rank one over $F$. Assume further that $F$ is essentially of finite type
+over $K$ and that at least one place of $F/K$ exists. Then the Riemann–Roch space of the zero
+divisor, $L(0) = \{f \in F \mid v(f) \le 1 \text{ for every place } v\}$, regarded as a
+$K$-submodule of $F$, is a finite-dimensional $K$-vector space.
+
+This is the statement that the ring of constants of a one-variable function field is finite over the
+base field, in the form of finite-dimensionality of $L(0)$. It is the base case of the finiteness
+statements for Riemann–Roch spaces in this development and is cited by the results bounding $\dim_K
+L(D)$ in terms of $\deg D$ and by the constructions of functions with prescribed orders at a place.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_finiteDimensional_lSpace_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_finiteDimensional_lSpace_zero
+
+noncomputable section
+
+universe u v
+
+open AlgebraicCurve
+
+theorem solution
+    (K : Type u) (F : Type v) [Field K] [Field F] [Algebra K F]
+    [IsCurveOver K F] [Algebra.EssFiniteType K F] [Nonempty (Place K F)] :
+    FiniteDimensional K (LSpace (0 : Divisor K F)) := by
+  classical
+  have hord : ∀ f : F, f ∈ LSpace (0 : Divisor K F) → f ≠ 0 →
+      ∀ v : Place K F, v.ord f = 0 := by
+    intro f hf hf0
+    have hnn : ∀ v : Place K F, 0 ≤ v.ord f := by
+      rcases (mem_lSpace_iff_ord).mp hf with h0 | h
+      · exact absurd h0 hf0
+      · intro v; simpa using h v
+    obtain ⟨D, hDord, hDdeg⟩ :=
+      HasPrincipalDivisors.exists_divisor (K := K) (F := F) f hf0
+    have hdeg_sum : Divisor.degree D = D.sum (fun w n => n * (w.deg : ℤ)) := by
+      simp [Divisor.degree, Finsupp.liftAddHom_apply, AddMonoidHom.coe_mulRight]
+    have hdegpos : ∀ w : Place K F, 0 < (w.deg : ℤ) := by
+      intro w
+      have : Module.Finite K w.ResidueField := IsCurveOver.finiteResidue w
+      exact_mod_cast Module.finrank_pos
+    have hterm : ∀ w ∈ D.support, D w * (w.deg : ℤ) = 0 := by
+      refine (Finset.sum_eq_zero_iff_of_nonneg ?_).mp ?_
+      · intro w _
+        exact mul_nonneg (hDord w ▸ hnn w) (le_of_lt (hdegpos w))
+      · have h := hDdeg
+        rw [hdeg_sum] at h
+        exact h
+    have hD0 : ∀ w : Place K F, D w = 0 := by
+      intro w
+      by_cases hw : w ∈ D.support
+      · rcases mul_eq_zero.mp (hterm w hw) with h | h
+        · exact h
+        · exact absurd h (ne_of_gt (hdegpos w))
+      · exact Finsupp.notMem_support_iff.mp hw
+    intro v
+    rw [← hDord v]; exact hD0 v
+  obtain ⟨v₀⟩ := ‹Nonempty (Place K F)›
+  have hmem : ∀ f : LSpace (0 : Divisor K F), (f : F) ∈ v₀.toValuationSubring := by
+    intro f
+    by_cases hf0 : (f : F) = 0
+    · rw [hf0]; exact zero_mem _
+    · obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v₀.toValuationSubring
+      obtain ⟨u, hu⟩ := v₀.exists_unit_mul_zpow hf0 hπ
+      rw [hord f f.2 hf0 v₀, zpow_zero, mul_one] at hu
+      rw [hu]; exact (u : v₀.toValuationSubring).2
+  let φ : LSpace (0 : Divisor K F) →ₗ[K] v₀.ResidueField :=
+    { toFun := fun f => IsLocalRing.residue _ (⟨f, hmem f⟩ : v₀.toValuationSubring)
+      map_add' := by
+        intro f g
+        have h : (⟨((f + g : LSpace (0 : Divisor K F)) : F), hmem (f + g)⟩ :
+            v₀.toValuationSubring) = ⟨f, hmem f⟩ + ⟨g, hmem g⟩ := rfl
+        rw [h, map_add]
+      map_smul' := by
+        intro k f
+        have h : (⟨((k • f : LSpace (0 : Divisor K F)) : F), hmem (k • f)⟩ :
+            v₀.toValuationSubring) = algebraMap K v₀.toValuationSubring k * ⟨f, hmem f⟩ := by
+          apply Subtype.ext
+          change (k • (f : F)) = _
+          rw [Algebra.smul_def]; rfl
+        rw [h, map_mul]
+        change algebraMap K v₀.ResidueField k * _ = k • _
+        rw [Algebra.smul_def] }
+  have hker : ∀ f : LSpace (0 : Divisor K F), φ f = 0 → f = 0 := by
+    intro f hφf
+    by_contra hf
+    have hf0 : (f : F) ≠ 0 := fun h => hf (Subtype.ext h)
+    obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v₀.toValuationSubring
+    obtain ⟨u, hu⟩ := v₀.exists_unit_mul_zpow hf0 hπ
+    rw [hord f f.2 hf0 v₀, zpow_zero, mul_one] at hu
+    have huf : (⟨f, hmem f⟩ : v₀.toValuationSubring) = (u : v₀.toValuationSubring) :=
+      Subtype.ext hu
+    have : IsUnit (φ f) := by
+      change IsUnit (IsLocalRing.residue _ (⟨f, hmem f⟩ : v₀.toValuationSubring))
+      rw [huf]
+      exact (IsLocalRing.residue _).isUnit_map u.isUnit
+    rw [hφf] at this
+    exact this.ne_zero rfl
+  have : Module.Finite K v₀.ResidueField := IsCurveOver.finiteResidue v₀
+  exact FiniteDimensional.of_injective φ ((injective_iff_map_eq_zero φ).mpr hker)
+
+end
+end S_AlgebraicCurve_finiteDimensional_lSpace_zero
+end P2MW
+export P2MW.S_AlgebraicCurve_finiteDimensional_lSpace_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+noncomputable section
+
+universe u v
+theorem AlgebraicCurve.finiteDimensional_lSpace_zero
+    (K : Type u) (F : Type v) [Field K] [Field F] [Algebra K F]
+    [IsCurveOver K F] [Algebra.EssFiniteType K F] [Nonempty (Place K F)] :
+    FiniteDimensional K (LSpace (0 : Divisor K F)) :=
+  solution K F
+end
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finite_and_finrank_regularDifferentials_eq_genus.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finite_and_finrank_regularDifferentials_eq_genus.lean
new file mode 100644
index 0000000000..ef1ef1f7fb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finite_and_finrank_regularDifferentials_eq_genus.lean
@@ -0,0 +1,293 @@
+/-
+Based on Prove2Me node AlgebraicCurve.finite_and_finrank_regularDifferentials_eq_genus
+(36752414-1ec4-5b94-8fec-c5a406af6025) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission bb555221-8820-54f1-ab35-84e866a49dee
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_CanonicalDivisor
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RegularDifferentials
+
+import Mathlib.FieldTheory.RatFunc.IntermediateField
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_constantsAreBase_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_dCoordGenerates_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_essFiniteType_of_transcendental_of_finiteDimensional
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteDimensional_lSpace
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_ratFunc
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_IsCurveOver_exists_separating_transcendental
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Regular differentials form a space of dimension the genus
+
+Theorem statement: `AlgebraicCurve.finite_and_finrank_regularDifferentials_eq_genus`
+(`36752414-1ec4-5b94-8fec-c5a406af6025`), by Claude, 2026-09-05.
+
+Proof: submission `bb555221-8820-54f1-ab35-84e866a49dee`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, $K$ algebraically closed, and $F$ essentially of
+finite type over $K$. Assume [`AlgebraicCurve.IsCurveOver K
+F`](def/AlgebraicCurve_IsCurveOver.html#L15): every nonzero $f \in F$ has a finitely supported
+divisor recording its orders $v.\mathrm{ord}\,f$ at all places and of degree $0$; for each place $v$
+the residue field of $v$ is a finite $K$-module; and $\Omega_{F/K}$ is free of rank one over $F$.
+Here a place is a valuation subring of $F$ containing the image of $K$, different from $F$, whose
+ring is a principal ideal ring. Assume also
+[`AlgebraicCurve.HasCanonicalDivisor`](def/AlgebraicCurve_CanonicalDivisor.html#L14): every nonzero
+$\omega \in \Omega_{F/K}$ admits a finitely supported divisor $D$ with $D(v) =
+v.\mathrm{ordDifferential}\,\omega$ for all $v$. Then the $K$-submodule
+[`AlgebraicCurve.regularDifferentials K F`](def/AlgebraicCurve_RegularDifferentials.html#L26) of
+$\Omega_{F/K}$, consisting of those $\omega$ such that for every place $v$ one may write $\omega = f
+\cdot \mathrm{d}t_v$ with $f$ in the valuation subring of $v$ and $t_v$ a uniformiser at $v$, is a
+finite-dimensional $K$-vector space, and its $K$-dimension equals [`AlgebraicCurve.genus K
+F`](def/AlgebraicCurve_CanonicalDivisor.html#L33), namely $(\deg D_\omega + 2)/2$ computed from a
+canonical divisor of some nonzero differential (and $0$ if $\Omega_{F/K} = 0$).
+
+This is the identification $\dim_K H^0(X,\Omega^1_X) = g$ for a curve over an algebraically closed
+field, equivalently $\ell(W) = g$ for a canonical divisor $W$ in the language of function fields; it
+reconciles the divisor-theoretic definition of the genus used in this development with the dimension
+of the space of everywhere-regular differentials. It is invoked in the study of $\mathrm{Pic}^0$ and
+of regular differentials under constant field extension.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_finite_and_finrank_regularDifferentials_eq_genus.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_finite_and_finrank_regularDifferentials_eq_genus
+
+noncomputable section
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_finite_and_finrank_regularDifferentials_eq_genus.AlgebraicCurve \
+  KaehlerDifferential IntermediateField"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver IsCurveOver.finrank_kaehler Place Divisor \
+  HasCanonicalDivisor canonicalDivisorOf canonicalDivisorOf_apply genus Place.ordDifferential \
+  regularDifferentials mem_regularDifferentials_iff FunctionFieldRiemannRoch LSpace ell \
+  mem_lSpace_iff_ord ConstantsAreBase ell_zero_eq_one_of_constantsAreBase \
+  dCoordGenerates_of_isCurveOver IsCurveOver.exists_separating_transcendental isCurveOver_ratFunc \
+  essFiniteType_of_transcendental_of_finiteDimensional \
+  functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver constantsAreBase_of_isAlgClosed \
+  finiteDimensional_lSpace"
+p2m_open "AlgebraicCurve"
+
+namespace RegularDifferentialsFinrank
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem ord_nonneg_of_mem_valuationSubring (v : Place K F) {f : F}
+    (hf : f ∈ v.toValuationSubring) : 0 ≤ v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨n, u, hu⟩ :=
+    IsDiscreteValuationRing.eq_unit_mul_pow_irreducible
+      (x := (⟨f, hf⟩ : v.toValuationSubring)) (by simpa [Subtype.ext_iff] using hf0) hπ
+  have hcoe : f = ((u : v.toValuationSubring) : F) * ((π : F) ^ (n : ℤ)) := by
+    have h := congrArg Subtype.val hu
+    push_cast at h
+    rw [zpow_natCast]
+    exact h
+  rw [hcoe, v.ord_unit_smul_zpow u hπ (n : ℤ)]
+  exact Int.natCast_nonneg n
+
+theorem mem_valuationSubring_of_ord_nonneg (v : Place K F) {f : F} (hf : f ≠ 0)
+    (h : 0 ≤ v.ord f) : f ∈ v.toValuationSubring := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ
+  rw [hu, show v.ord f = (((v.ord f).toNat : ℕ) : ℤ) from (Int.toNat_of_nonneg h).symm,
+    zpow_natCast]
+  exact mul_mem (u : v.toValuationSubring).2 (pow_mem (π : v.toValuationSubring).2 _)
+
+theorem differentialCoeff_ne_zero {ω : Ω[F⁄K]} (hω : ω ≠ 0) (v : Place K F) [v.DCoordGenerates] :
+    v.differentialCoeff ω ≠ 0 := by
+  intro h
+  apply hω
+  rw [← v.differentialCoeff_smul_dCoord ω, h, zero_smul]
+
+theorem exists_smul_eq [IsCurveOver K F] {ω₀ : Ω[F⁄K]} (hω₀ : ω₀ ≠ 0) (ω : Ω[F⁄K]) :
+    ∃ h : F, h • ω₀ = ω :=
+  (finrank_eq_one_iff_of_nonzero' ω₀ hω₀).mp IsCurveOver.finrank_kaehler ω
+
+section Comparison
+
+variable [IsCurveOver K F] [HasCanonicalDivisor (K := K) (F := F)]
+  [∀ v : Place K F, v.DCoordGenerates]
+
+theorem smul_mem_regularDifferentials_iff {ω₀ : Ω[F⁄K]} (hω₀ : ω₀ ≠ 0) (h : F) :
+    h • ω₀ ∈ regularDifferentials K F ↔ h ∈ LSpace (canonicalDivisorOf hω₀) := by
+  rcases eq_or_ne h 0 with rfl | hh
+  · simp only [zero_smul, Submodule.zero_mem]
+  rw [mem_regularDifferentials_iff, mem_lSpace_iff_ord, or_iff_right hh]
+  refine forall_congr' fun v => ?_
+  have hc : v.differentialCoeff ω₀ ≠ 0 := differentialCoeff_ne_zero hω₀ v
+  have hdec : h • ω₀ = (h * v.differentialCoeff ω₀) • v.dCoord := by
+    rw [mul_smul, v.differentialCoeff_smul_dCoord]
+  have hprod : h * v.differentialCoeff ω₀ ≠ 0 := mul_ne_zero hh hc
+  rw [canonicalDivisorOf_apply, Place.ordDifferential]
+  constructor
+  · rintro ⟨g, hg, hEq⟩
+    have hgu : g = h * v.differentialCoeff ω₀ := by
+      rw [← v.differentialCoeff_unique hEq, v.differentialCoeff_unique hdec]
+    have h0 : 0 ≤ v.ord (h * v.differentialCoeff ω₀) :=
+      hgu ▸ ord_nonneg_of_mem_valuationSubring v hg
+    rw [v.ord_mul hh hc] at h0
+    linarith
+  · intro hle
+    refine ⟨h * v.differentialCoeff ω₀, ?_, hdec⟩
+    refine mem_valuationSubring_of_ord_nonneg v hprod ?_
+    rw [v.ord_mul hh hc]
+    linarith
+
+def toRegular {ω₀ : Ω[F⁄K]} (hω₀ : ω₀ ≠ 0) :
+    LSpace (canonicalDivisorOf hω₀) →ₗ[K] regularDifferentials K F where
+  toFun h := ⟨(h : F) • ω₀, (smul_mem_regularDifferentials_iff hω₀ (h : F)).mpr h.2⟩
+  map_add' h₁ h₂ := by
+    ext
+    simp [add_smul]
+  map_smul' c h := by
+    ext
+    simp [smul_assoc]
+
+theorem toRegular_apply {ω₀ : Ω[F⁄K]} (hω₀ : ω₀ ≠ 0) (h : LSpace (canonicalDivisorOf hω₀)) :
+    ((toRegular hω₀ h : regularDifferentials K F) : Ω[F⁄K]) = (h : F) • ω₀ := rfl
+
+theorem toRegular_bijective {ω₀ : Ω[F⁄K]} (hω₀ : ω₀ ≠ 0) :
+    Function.Bijective (toRegular (K := K) (F := F) hω₀) := by
+  constructor
+  · intro h₁ h₂ hEq
+    have hEq' : ((h₁ : F) - (h₂ : F)) • ω₀ = 0 := by
+      have := congrArg (fun x : regularDifferentials K F => (x : Ω[F⁄K])) hEq
+      simp only [toRegular_apply] at this
+      rw [sub_smul, this, sub_self]
+    rcases smul_eq_zero.mp hEq' with h0 | h0
+    · exact Subtype.ext (sub_eq_zero.mp h0)
+    · exact absurd h0 hω₀
+  · rintro ⟨ω, hω⟩
+    obtain ⟨h, rfl⟩ := exists_smul_eq hω₀ ω
+    exact ⟨⟨h, (smul_mem_regularDifferentials_iff hω₀ h).mp hω⟩, rfl⟩
+
+def lSpaceCanonicalEquivRegular {ω₀ : Ω[F⁄K]} (hω₀ : ω₀ ≠ 0) :
+    LSpace (canonicalDivisorOf hω₀) ≃ₗ[K] regularDifferentials K F :=
+  LinearEquiv.ofBijective (toRegular hω₀) (toRegular_bijective hω₀)
+
+theorem ell_canonical_eq_genus (hRR : FunctionFieldRiemannRoch K F) (hC : ConstantsAreBase K F)
+    {ω₀ : Ω[F⁄K]} (hω₀ : ω₀ ≠ 0) :
+    ell (canonicalDivisorOf hω₀) = genus K F := by
+  have h := hRR hω₀ 0
+  rw [sub_zero, ell_zero_eq_one_of_constantsAreBase hC] at h
+  simp only [map_zero, Nat.cast_one, zero_add] at h
+  exact_mod_cast (by linarith : (ell (canonicalDivisorOf hω₀) : ℤ) = genus K F)
+
+end Comparison
+
+theorem riemannRoch_and_constantsAreBase [IsAlgClosed K] [Algebra.EssFiniteType K F]
+    [IsCurveOver K F] [HasCanonicalDivisor (K := K) (F := F)]
+    [∀ v : Place K F, v.DCoordGenerates] :
+    FunctionFieldRiemannRoch K F ∧ ConstantsAreBase K F := by
+  classical
+  obtain ⟨t, ht, htfd, htsep⟩ :=
+    IsCurveOver.exists_separating_transcendental (K := K) (F := F)
+  have := htfd
+  have := htsep
+  set e : RatFunc K ≃ₐ[K] K⟮t⟯ := RatFunc.algEquivOfTranscendental t ht with he
+  let : Algebra (RatFunc K) F :=
+    ((algebraMap K⟮t⟯ F).comp e.toAlgHom.toRingHom).toAlgebra
+  have hsq : RingHom.comp (algebraMap (RatFunc K) F)
+        (e.symm.toRingEquiv : K⟮t⟯ →+* RatFunc K)
+      = RingHom.comp (RingEquiv.refl F : F →+* F) (algebraMap K⟮t⟯ F) := by
+    refine RingHom.ext fun a => ?_
+    change algebraMap K⟮t⟯ F (e (e.symm a)) = algebraMap K⟮t⟯ F a
+    rw [e.apply_symm_apply]
+  have : IsScalarTower K (RatFunc K) F :=
+    IsScalarTower.of_algebraMap_eq fun a => by
+      change algebraMap K F a = algebraMap K⟮t⟯ F (e (algebraMap K (RatFunc K) a))
+      rw [e.commutes, ← IsScalarTower.algebraMap_apply]
+  have : FiniteDimensional (RatFunc K) F :=
+    Module.Finite.of_equiv_equiv e.symm.toRingEquiv (RingEquiv.refl F) hsq
+  have : Algebra.IsSeparable (RatFunc K) F :=
+    Algebra.IsSeparable.of_equiv_equiv e.symm.toRingEquiv (RingEquiv.refl F) hsq
+  have : Algebra.IsIntegral (RatFunc K) F := Algebra.IsIntegral.of_finite (RatFunc K) F
+  have : IsCurveOver K (RatFunc K) := isCurveOver_ratFunc K
+  have : FiniteDimensional (IntermediateField.adjoin K ({RatFunc.X} : Set (RatFunc K)))
+      (RatFunc K) := by
+    refine Module.Finite.of_surjective
+      (Algebra.linearMap (IntermediateField.adjoin K ({RatFunc.X} : Set (RatFunc K)))
+        (RatFunc K)) fun y => ?_
+    refine ⟨⟨y, ?_⟩, rfl⟩
+    rw [RatFunc.adjoin_X]
+    exact IntermediateField.mem_top
+  have : Algebra.EssFiniteType K (RatFunc K) :=
+    essFiniteType_of_transcendental_of_finiteDimensional
+      (RatFunc.transcendental_X (K := K)) inferInstance
+  have : ∀ v : Place K (RatFunc K), v.DCoordGenerates := dCoordGenerates_of_isCurveOver
+  refine ⟨?_, constantsAreBase_of_isAlgClosed K F⟩
+  intro _ _ _ ω hω D
+  exact functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver (K := K) (F := F) hω D
+
+end RegularDifferentialsFinrank
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_finite_and_finrank_regularDifferentials_eq_genus.AlgebraicCurve
+  AlgebraicCurve.RegularDifferentialsFinrank KaehlerDifferential in
+theorem solution {K F : Type*} [Field K]
+    [Field F] [Algebra K F] [IsAlgClosed K] [Algebra.EssFiniteType K F]
+    [AlgebraicCurve.IsCurveOver K F] [AlgebraicCurve.HasCanonicalDivisor (K := K) (F := F)] :
+    Module.Finite K ↥(AlgebraicCurve.regularDifferentials K F) ∧
+      Module.finrank K ↥(AlgebraicCurve.regularDifferentials K F) =
+        AlgebraicCurve.genus K F := by
+  classical
+  have : ∀ v : Place K F, v.DCoordGenerates := dCoordGenerates_of_isCurveOver
+  obtain ⟨hRR, hC⟩ := riemannRoch_and_constantsAreBase (K := K) (F := F)
+  obtain ⟨ω₀, hω₀⟩ := exists_ne (0 : Ω[F⁄K])
+  have : FiniteDimensional K ↥(LSpace (0 : Divisor K F)) := by
+    rw [show LSpace (0 : Divisor K F) = _ from hC]
+    infer_instance
+  have : FiniteDimensional K ↥(LSpace (canonicalDivisorOf hω₀)) :=
+    finiteDimensional_lSpace _
+  set e := lSpaceCanonicalEquivRegular (K := K) (F := F) hω₀
+  refine ⟨Module.Finite.equiv e, ?_⟩
+  rw [← e.finrank_eq]
+  exact ell_canonical_eq_genus hRR hC hω₀
+
+end S_AlgebraicCurve_finite_and_finrank_regularDifferentials_eq_genus
+end P2MW
+export P2MW.S_AlgebraicCurve_finite_and_finrank_regularDifferentials_eq_genus (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.finite_and_finrank_regularDifferentials_eq_genus {K F : Type*} [Field K]
+    [Field F] [Algebra K F] [IsAlgClosed K] [Algebra.EssFiniteType K F]
+    [AlgebraicCurve.IsCurveOver K F] [AlgebraicCurve.HasCanonicalDivisor (K := K) (F := F)] :
+    Module.Finite K ↥(AlgebraicCurve.regularDifferentials K F) ∧
+      Module.finrank K ↥(AlgebraicCurve.regularDifferentials K F) =
+        AlgebraicCurve.genus K F :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finite_setOf_ord_ne_zero_of_finiteDimensional.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finite_setOf_ord_ne_zero_of_finiteDimensional.lean
new file mode 100644
index 0000000000..adf83984b8
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finite_setOf_ord_ne_zero_of_finiteDimensional.lean
@@ -0,0 +1,190 @@
+/-
+Based on Prove2Me node AlgebraicCurve.finite_setOf_ord_ne_zero_of_finiteDimensional
+(8d6abb0c-e134-5f13-b229-4a15c978b445) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 0ce6dc3f-67e5-53c0-9c04-17148c9bbe6e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+public import Mathlib.FieldTheory.RatFunc.Basic
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_nonneg_of_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_of_ord_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_finite_setOf_ord_ne_zero
+import Mathlib.FieldTheory.Minpoly.Field
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finiteness of zeros and poles in a finite separable extension of K(X)
+
+Theorem statement: `AlgebraicCurve.finite_setOf_ord_ne_zero_of_finiteDimensional`
+(`8d6abb0c-e134-5f13-b229-4a15c978b445`), by Claude, 2026-09-05.
+
+Proof: submission `0ce6dc3f-67e5-53c0-9c04-17148c9bbe6e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $F'$ be a field equipped with a $K$-algebra structure and with a
+$\mathrm{RatFunc}\,K$-algebra structure, the two being compatible (a scalar tower $K \subseteq K(X)
+\subseteq F'$), and assume $F'$ is finite-dimensional over the rational function field $K(X)$ and
+separable over it. Let $f \in F'$ be nonzero. Then the set of places $w$ of $F'$ over $K$ with
+$\operatorname{ord}_w(f) \neq 0$ is finite. Here a place of $F'$ over $K$ is, as defined in this
+development, a valuation subring of $F'$ which contains the image of $K$ under the structure map, is
+not the whole of $F'$, and is a principal ideal ring; for such a $w$ the quantity
+$\operatorname{ord}_w(f)$ is $-\log$ of the value at $f$ of the $\mathbb{Z}^{m0}$-valued adic
+valuation attached to the height-one prime of the valuation subring of $w$, so that $\{w :
+\operatorname{ord}_w(f) \neq 0\}$ is the set of zeros and poles of $f$.
+
+This is the classical statement that a nonzero element of an algebraic function field has only
+finitely many zeros and poles, here in the form needed for function fields that are finite separable
+extensions of $K(X)$. It is the finiteness ingredient used by
+[`AlgebraicCurve.hasPrincipalDivisors_of_finiteDimensional_of_isSeparable`]
+(thm.html#AlgebraicCurve.hasPrincipalDivisors_of_finiteDimensional_of_isSeparable),
+which produces principal divisors for such fields.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_finite_setOf_ord_ne_zero_of_finiteDimensional.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_finite_setOf_ord_ne_zero_of_finiteDimensional
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.finite_setOf_restrict_eq Place \
+  RationalFunctionField.finite_setOf_ord_ne_zero"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ord_neg mem_of_eval_monic_eq_zero finite_setOf_restrict_eq \
+  restrict ord_restrict ord ord_mul toValuationSubring ord_nonneg_of_mem mem_of_ord_nonneg"
+p2m_open "AlgebraicCurve.Place~ord_eq_zero_iff_adicValuation_eq_one~exists_ord_pos"
+
+section SupportTransfer
+
+open Polynomial
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F'] [Algebra F F']
+  [FiniteDimensional F F']
+
+variable (w : Place K F')
+
+omit [FiniteDimensional F F'] in
+private theorem _root_.AlgebraicCurve.Place.aeval_mem {Q : Polynomial F} {x : F'}
+    (hcoeff : ∀ i, algebraMap F F' (Q.coeff i) ∈ w.toValuationSubring)
+    (hx : x ∈ w.toValuationSubring) :
+    Polynomial.aeval x Q ∈ w.toValuationSubring := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range]
+  exact sum_mem fun i _ => mul_mem (hcoeff i) (pow_mem hx i)
+
+p2m_export "AlgebraicCurve.Place" "aeval_mem"
+
+private theorem _root_.AlgebraicCurve.Place.exists_coeff_ord_ne_zero {f : F'} (hf : f ≠ 0)
+    (hford : w.ord f ≠ 0) :
+    ∃ i < (minpoly F f).natDegree, (minpoly F f).coeff i ≠ 0 ∧
+      w.ord (algebraMap F F' ((minpoly F f).coeff i)) ≠ 0 := by
+  by_contra hcon
+  push Not at hcon
+  set P := minpoly F f with hPdef
+  have hint : IsIntegral F f := Algebra.IsIntegral.isIntegral f
+  have hmonic : P.Monic := minpoly.monic hint
+  have hdeg : 0 < P.natDegree := minpoly.natDegree_pos hint
+  have hc0 : P.coeff 0 ≠ 0 := minpoly.coeff_zero_ne_zero hint hf
+  have hcoeff : ∀ i, algebraMap F F' (P.coeff i) ∈ w.toValuationSubring := by
+    intro i
+    rcases lt_trichotomy i P.natDegree with hi | hi | hi
+    · rcases eq_or_ne (P.coeff i) 0 with h0 | h0
+      · simp [h0]
+      · exact w.mem_of_ord_nonneg (by simpa using h0) (by have := hcon i hi h0; omega)
+    · subst hi
+      simp [hmonic.coeff_natDegree]
+    · simp [Polynomial.coeff_eq_zero_of_natDegree_lt hi]
+  have hfmem : f ∈ w.toValuationSubring := by
+    refine w.mem_of_eval_monic_eq_zero (P := P.map (algebraMap F F')) (hmonic.map _)
+      (fun i => by simpa using hcoeff i) ?_
+    rw [Polynomial.eval_map, ← Polynomial.aeval_def, hPdef, minpoly.aeval]
+  have hfpos : 0 < w.ord f := lt_of_le_of_ne (w.ord_nonneg_of_mem hfmem) (Ne.symm hford)
+  have hkey : algebraMap F F' (P.coeff 0) = -(f * Polynomial.aeval f P.divX) := by
+    have hsplit : Polynomial.aeval f (Polynomial.X * P.divX + Polynomial.C (P.coeff 0))
+        = (0 : F') := by rw [P.X_mul_divX_add]; exact minpoly.aeval F f
+    rw [map_add, map_mul, Polynomial.aeval_X, Polynomial.aeval_C] at hsplit
+    linear_combination hsplit
+  have hcof_mem : Polynomial.aeval f P.divX ∈ w.toValuationSubring :=
+    w.aeval_mem (fun i => by rw [Polynomial.coeff_divX]; exact hcoeff (i + 1)) hfmem
+  have hcof_ne : Polynomial.aeval f P.divX ≠ 0 := by
+    intro h
+    rw [h, mul_zero, neg_zero] at hkey
+    exact hc0 (by simpa using hkey)
+  have hpos0 : 0 < w.ord (algebraMap F F' (P.coeff 0)) := by
+    rw [hkey, w.ord_neg, w.ord_mul hf hcof_ne]
+    have := w.ord_nonneg_of_mem hcof_mem
+    omega
+  have := hcon 0 hdeg hc0
+  omega
+
+p2m_export "AlgebraicCurve.Place" "exists_coeff_ord_ne_zero"
+end SupportTransfer
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_finite_setOf_ord_ne_zero_of_finiteDimensional.AlgebraicCurve"
+
+theorem solution {K F' : Type*} [Field K] [Field F'] [Algebra K F']
+    [Algebra (RatFunc K) F'] [IsScalarTower K (RatFunc K) F'] [FiniteDimensional (RatFunc K) F']
+    [Algebra.IsSeparable (RatFunc K) F']
+    {f : F'} (hf : f ≠ 0) : {w : Place K F' | w.ord f ≠ 0}.Finite := by
+  classical
+  set P := minpoly (RatFunc K) f with hPdef
+  refine Set.Finite.subset (Set.Finite.biUnion (Set.finite_Iio P.natDegree) (fun i _ =>
+    Set.Finite.biUnion (s := {v : Place K (RatFunc K) | v.ord (P.coeff i) ≠ 0})
+      ?_ (fun v _ => Place.finite_setOf_restrict_eq v))) ?_
+  · rcases eq_or_ne (P.coeff i) 0 with h0 | h0
+    · simp [h0]
+    · exact RationalFunctionField.finite_setOf_ord_ne_zero h0
+  · intro w hw
+    obtain ⟨i, hi, hci, hord⟩ := w.exists_coeff_ord_ne_zero (F := RatFunc K) hf hw
+    simp only [Set.mem_iUnion, Set.mem_ofPred_eq, exists_prop]
+    refine ⟨i, hi, w.restrict (RatFunc K), ?_, rfl⟩
+    intro h0
+    apply hord
+    rw [w.ord_restrict, h0, mul_zero]
+
+end S_AlgebraicCurve_finite_setOf_ord_ne_zero_of_finiteDimensional
+end P2MW
+export P2MW.S_AlgebraicCurve_finite_setOf_ord_ne_zero_of_finiteDimensional (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.finite_setOf_ord_ne_zero_of_finiteDimensional {K F' : Type*} [Field K]
+    [Field F'] [Algebra K F']
+    [Algebra (RatFunc K) F'] [IsScalarTower K (RatFunc K) F'] [FiniteDimensional (RatFunc K) F']
+    [Algebra.IsSeparable (RatFunc K) F']
+    {f : F'} (hf : f ≠ 0)
+    : {w : Place K F' | w.ord f ≠ 0}.Finite :=
+  solution hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finrank_frobeniusSubfield_eq_of_transcendental.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finrank_frobeniusSubfield_eq_of_transcendental.lean
new file mode 100644
index 0000000000..db5cef2c15
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finrank_frobeniusSubfield_eq_of_transcendental.lean
@@ -0,0 +1,444 @@
+/-
+Based on Prove2Me node AlgebraicCurve.finrank_frobeniusSubfield_eq_of_transcendental
+(4399ba35-43e6-5b5d-8ef1-d153ef817153) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission bb6ff04e-78e4-5201-a7c3-39610405eac0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+public import Mathlib.FieldTheory.Perfect
+public import Mathlib.Algebra.CharP.Algebra
+
+import Mathlib.FieldTheory.KummerPolynomial
+import Mathlib.FieldTheory.Relrank
+import Mathlib.LinearAlgebra.FiniteDimensional.Lemmas
+import Mathlib.LinearAlgebra.Dimension.Free
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# [M:Mᵖ]=p for a one-variable function field over a perfect field
+
+Theorem statement: `AlgebraicCurve.finrank_frobeniusSubfield_eq_of_transcendental`
+(`4399ba35-43e6-5b5d-8ef1-d153ef817153`), by Claude, 2026-09-05.
+
+Proof: submission `bb6ff04e-78e4-5201-a7c3-39610405eac0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $M$ be fields with $M$ a $K$-algebra, let $K$ be perfect, and let $p$ be a prime with
+$K$ of characteristic $p$. Let $t \in M$ be transcendental over $K$, i.e. no nonzero polynomial over
+$K$ vanishes at $t$, and assume that $M$ is finite-dimensional as a module over the intermediate
+field $K(t) =$ `IntermediateField.adjoin K {t}` generated by $t$. Since the structure map $K \to M$
+is injective, $M$ also has exponential characteristic $p$, and the Frobenius endomorphism $x \mapsto
+x^p$ of $M$ is available; its field range is the subfield $M^p$ of $p$-th powers. The assertion is
+that the rank of $M$ as a module over this subfield is exactly $p$, that is $[M : M^p] = p$. (The
+rank is the `Module.finrank` of $M$ over the coercion of `(frobenius M p).fieldRange`, so the
+equality with $p$ in particular records that this rank is finite.)
+
+This is the classical computation of the degree of a one-variable algebraic function field over its
+subfield of $p$-th powers, for a perfect constant field of characteristic $p$; both hypotheses
+matter, since imperfect constant fields or higher transcendence degree give larger indices. Within
+the development it underlies the computation of degrees of Frobenius-type endomorphisms and the
+existence of separating transcendental elements, and is used in the analysis of norm formulae for
+Weierstrass curves over algebraically closed fields of positive characteristic.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_finrank_frobeniusSubfield_eq_of_transcendental.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_finrank_frobeniusSubfield_eq_of_transcendental
+
+noncomputable section
+
+namespace AlgebraicCurve
+namespace PthPowerIndex
+
+open IntermediateField Polynomial
+
+private def frobeniusSubfield (M : Type*) [Field M] (p : ℕ) [ExpChar M p] : Subfield M :=
+  (frobenius M p).fieldRange
+
+private theorem mem_frobeniusSubfield_iff {M : Type*} [Field M] (p : ℕ) [ExpChar M p] {a : M} :
+    a ∈ frobeniusSubfield M p ↔ ∃ b : M, b ^ p = a := by
+  simp only [frobeniusSubfield, RingHom.mem_fieldRange, frobenius_def]
+
+private theorem pow_mem_frobeniusSubfield {M : Type*} [Field M] (p : ℕ) [ExpChar M p] (a : M) :
+    a ^ p ∈ frobeniusSubfield M p := (mem_frobeniusSubfield_iff p).mpr ⟨a, rfl⟩
+
+private def frobeniusRingEquivRange (M : Type*) [Field M] (p : ℕ) [ExpChar M p] :
+    M ≃+* frobeniusSubfield M p :=
+  RingEquiv.ofBijective (frobenius M p).rangeRestrict
+    ⟨fun _ _ h ↦ (frobenius M p).injective (Subtype.ext_iff.mp h),
+      (frobenius M p).rangeRestrict_surjective⟩
+
+private theorem frobeniusRingEquivRange_apply (M : Type*) [Field M] (p : ℕ) [ExpChar M p]
+    (a : M) : ((frobeniusRingEquivRange M p a : frobeniusSubfield M p) : M) = a ^ p := rfl
+
+section Transport
+
+variable {E M : Type*} [Field E] [Field M] [Algebra E M] (p : ℕ) [ExpChar E p] [ExpChar M p]
+
+private abbrev frobeniusSubfieldImageInM : Subfield M :=
+  (frobeniusSubfield E p).map (algebraMap E M)
+
+omit [ExpChar M p] in
+private theorem frobeniusSubfieldImageInM_le_algebraMapRange :
+    frobeniusSubfieldImageInM (E := E) (M := M) p ≤ (algebraMap E M).fieldRange :=
+  fun _ ⟨a, _, ha⟩ ↦ ⟨a, ha⟩
+
+private theorem frobeniusSubfieldImageInM_le_frobeniusSubfield :
+    frobeniusSubfieldImageInM (E := E) (M := M) p ≤ frobeniusSubfield M p := by
+  rintro _ ⟨_, ⟨b, rfl⟩, rfl⟩
+  exact ⟨algebraMap E M b, by simp only [frobenius_def, map_pow]⟩
+
+private theorem comap_frobenius_frobeniusSubfield :
+    (frobeniusSubfield M p).comap (frobenius M p) = ⊤ := by
+  ext x; constructor
+  · intro _; trivial
+  · intro _; exact ⟨x, rfl⟩
+
+private theorem comap_frobenius_frobeniusSubfieldImageInM :
+    (frobeniusSubfieldImageInM (E := E) (M := M) p).comap (frobenius M p) =
+      (algebraMap E M).fieldRange := by
+  ext x; constructor
+  · rintro ⟨_, ⟨b, rfl⟩, hb⟩
+    exact ⟨b, (frobenius M p).injective (by simpa only [frobenius_def, map_pow] using hb)⟩
+  · rintro ⟨e, rfl⟩
+    exact ⟨e ^ p, ⟨e, rfl⟩, by simp only [frobenius_def, map_pow]⟩
+
+private theorem finrank_algebraMapRange_eq :
+    Module.finrank (↥(algebraMap E M).fieldRange) M = Module.finrank E M := by
+  have h := lift_rank_eq_of_equiv_equiv (M := M) (M' := M)
+    (R := E) (R' := ↥(algebraMap E M).fieldRange)
+    (fun e ↦ (algebraMap E M).rangeRestrictFieldEquiv e) (AddEquiv.refl M)
+    (algebraMap E M).rangeRestrictFieldEquiv.bijective
+    (fun e m ↦ by
+      change e • m = ((algebraMap E M).rangeRestrictFieldEquiv e) • m
+      rw [Algebra.smul_def, Subfield.smul_def]
+      rfl)
+  simp only [Cardinal.lift_id] at h
+  exact congrArg Cardinal.toNat h.symm
+
+private theorem finrank_frobeniusSubfield_eq [FiniteDimensional E M]
+    [FiniteDimensional (frobeniusSubfield E p) E] :
+    Module.finrank (frobeniusSubfield M p) M = Module.finrank (frobeniusSubfield E p) E := by
+  set Mp : Subfield M := frobeniusSubfield M p with hMp
+  set Ep' : Subfield M := frobeniusSubfieldImageInM (E := E) (M := M) p with hEp'
+  set E' : Subfield M := (algebraMap E M).fieldRange with hE'
+  have hfrob : Subfield.relfinrank Ep' Mp = Subfield.relfinrank E' (⊤ : Subfield M) := by
+    have h1 := Subfield.relfinrank_comap_comap_eq_relfinrank_of_le (A := Ep') (B := Mp)
+      (frobenius M p) (by rw [hMp]; exact le_refl _)
+    rw [comap_frobenius_frobeniusSubfield, comap_frobenius_frobeniusSubfieldImageInM] at h1
+    exact h1.symm
+  have htowerE : Subfield.relfinrank Ep' E' * Subfield.relfinrank E' (⊤ : Subfield M) =
+      Subfield.relfinrank Ep' (⊤ : Subfield M) :=
+    Subfield.relfinrank_mul_relfinrank
+      (frobeniusSubfieldImageInM_le_algebraMapRange p) le_top
+  have htowerM : Subfield.relfinrank Ep' Mp * Subfield.relfinrank Mp (⊤ : Subfield M) =
+      Subfield.relfinrank Ep' (⊤ : Subfield M) :=
+    Subfield.relfinrank_mul_relfinrank
+      (frobeniusSubfieldImageInM_le_frobeniusSubfield p) le_top
+  have hEp'E' : Subfield.relfinrank Ep' E' = Module.finrank (frobeniusSubfield E p) E := by
+    have h1 : E' = (⊤ : Subfield E).map (algebraMap E M) := by
+      rw [hE', ← RingHom.fieldRange_eq_map]
+    rw [hEp', h1, Subfield.relfinrank_map_map, Subfield.relfinrank_top_right]
+  have hMpTop : Subfield.relfinrank Mp (⊤ : Subfield M) = Module.finrank (frobeniusSubfield M p) M
+    :=
+    Subfield.relfinrank_top_right _
+  have hE'pos : 0 < Subfield.relfinrank E' (⊤ : Subfield M) := by
+    rw [Subfield.relfinrank_top_right, hE', finrank_algebraMapRange_eq (E := E) (M := M)]
+    exact Module.finrank_pos
+  have hcancel : Subfield.relfinrank Ep' E' = Subfield.relfinrank Mp (⊤ : Subfield M) := by
+    have h := htowerE.trans htowerM.symm
+    rw [hfrob, mul_comm (Subfield.relfinrank E' _)] at h
+    exact Nat.eq_of_mul_eq_mul_right hE'pos h
+  rw [← hMpTop, ← hcancel, hEp'E']
+
+end Transport
+
+section LinearIndependence
+
+variable {M : Type*} [Field M] (p : ℕ) [hp : Fact p.Prime] [CharP M p]
+
+private theorem pDigits_linearIndependent {t : M} (htp : ∀ a : M, a ^ p ≠ t) :
+    haveI : ExpChar M p := ExpChar.prime hp.out
+    LinearIndependent (frobeniusSubfield M p)
+      (fun i : Fin p ↦ (t ^ (i : ℕ) : M)) := by
+  have : ExpChar M p := ExpChar.prime hp.out
+  have htp' : ∀ c : frobeniusSubfield M p, c ^ p ≠
+      (⟨t ^ p, pow_mem_frobeniusSubfield p t⟩ : frobeniusSubfield M p) := by
+    rintro ⟨_, b, rfl⟩ hcp
+    refine htp b ((frobenius M p).injective ?_)
+    have hcp' := congrArg (fun z : frobeniusSubfield M p ↦ (z : M)) hcp
+    push_cast at hcp'
+    simpa only [frobenius_def] using hcp'
+  have hirr : Irreducible (X ^ p - C (⟨t ^ p, pow_mem_frobeniusSubfield p t⟩ :
+      frobeniusSubfield M p)) :=
+    X_pow_sub_C_irreducible_of_prime hp.out htp'
+  have hroot : (aeval (R := ↥(frobeniusSubfield M p)) t)
+      (X ^ p - C (⟨t ^ p, pow_mem_frobeniusSubfield p t⟩ : frobeniusSubfield M p)) = 0 := by
+    simp only [map_sub, map_pow, aeval_X, aeval_C]
+    exact sub_self _
+  have hmon : (X ^ p - C (⟨t ^ p, pow_mem_frobeniusSubfield p t⟩ :
+      frobeniusSubfield M p)).Monic := monic_X_pow_sub_C _ hp.out.ne_zero
+  have hmp : X ^ p - C (⟨t ^ p, pow_mem_frobeniusSubfield p t⟩ : frobeniusSubfield M p) =
+      minpoly (↥(frobeniusSubfield M p)) t :=
+    minpoly.eq_of_irreducible_of_monic hirr hroot hmon
+  have hdeg : (minpoly (↥(frobeniusSubfield M p)) t).natDegree = p := by
+    rw [← hmp, natDegree_X_pow_sub_C]
+  have hli := linearIndependent_pow (K := ↥(frobeniusSubfield M p)) t
+  rw [hdeg] at hli
+  exact hli
+
+end LinearIndependence
+
+section AdjoinIndex
+
+open scoped IntermediateField
+
+variable {K M : Type*} [Field K] [Field M] [Algebra K M]
+  (p : ℕ) [hp : Fact p.Prime] [CharP K p]
+
+private abbrev genT (t : M) : ↥K⟮t⟯ := IntermediateField.AdjoinSimple.gen K t
+
+omit [CharP K p] in
+private theorem genT_not_pow (t : M) (htr : Transcendental K t) (a : ↥K⟮t⟯) :
+    a ^ p ≠ genT t := by
+  intro ha
+  have ht0 : t ≠ 0 := fun h ↦ htr (h ▸ isAlgebraic_zero)
+  have ha' : t = (↑a : M) ^ p := by
+    have := congrArg (fun z : ↥K⟮t⟯ ↦ (z : M)) ha
+    push_cast at this; simpa using this.symm
+  obtain ⟨r, s, hrs⟩ := (IntermediateField.mem_adjoin_simple_iff K _).mp a.2
+  have hkey : aeval t (X * s ^ p - r ^ p) = 0 := by
+    simp only [map_sub, map_mul, aeval_X, map_pow]
+    rw [hrs, div_pow] at ha'
+    by_cases hs0 : aeval t s = 0
+    · rw [hs0, zero_pow hp.out.ne_zero, div_zero] at ha'
+      exact absurd ha' ht0
+    · rw [eq_div_iff (pow_ne_zero _ hs0)] at ha'
+      rw [sub_eq_zero]; exact ha'
+  have hinj : X * s ^ p - r ^ p = (0 : K[X]) := by
+    have := htr
+    rw [Transcendental, isAlgebraic_iff_not_injective, not_not] at this
+    exact this (by simpa using hkey)
+  have hs0 : s ≠ 0 := by
+    intro h0; rw [h0] at hrs
+    simp only [map_zero, div_zero] at hrs
+    exact ht0 (ha'.trans (by rw [hrs, zero_pow hp.out.ne_zero]))
+  have hr0 : r ≠ 0 := by
+    intro h0
+    rw [h0, zero_pow hp.out.ne_zero, sub_zero, mul_eq_zero] at hinj
+    exact hs0 (pow_eq_zero_iff hp.out.ne_zero |>.mp (hinj.resolve_left X_ne_zero))
+  have hdeg : (X * s ^ p).natDegree = (r ^ p : K[X]).natDegree := by
+    have := sub_eq_zero.mp hinj; rw [this]
+  rw [natDegree_mul X_ne_zero (pow_ne_zero _ hs0), natDegree_X, natDegree_pow,
+    natDegree_pow] at hdeg
+  have hpdvd : p ∣ 1 := by
+    have h1 : p * r.natDegree - p * s.natDegree = 1 := by omega
+    exact ⟨r.natDegree - s.natDegree, by rw [Nat.mul_sub, h1]⟩
+  exact absurd (Nat.le_of_dvd Nat.one_pos hpdvd) hp.out.one_lt.not_ge
+
+private theorem adjoin_genT_over_frobeniusSubfield [PerfectField K] (t : M) :
+    haveI : ExpChar (↥K⟮t⟯) p :=
+      expChar_of_injective_algebraMap (algebraMap K _).injective p
+    (IntermediateField.adjoin (↥(frobeniusSubfield (↥K⟮t⟯) p)) {genT t} :
+        IntermediateField _ (↥K⟮t⟯)) = ⊤ := by
+  have : ExpChar (↥K⟮t⟯) p :=
+    expChar_of_injective_algebraMap (algebraMap K _).injective p
+  rw [eq_top_iff]
+  intro x _
+  obtain ⟨r, s, hrs⟩ := (IntermediateField.mem_adjoin_simple_iff K _).mp x.2
+  have hrs' : x = aeval (genT t) r / aeval (genT t) s := by
+    apply Subtype.ext
+    rw [hrs]
+    push_cast
+    exact congrArg₂ _
+      (IntermediateField.AdjoinSimple.coe_aeval_gen_apply (F := K) (α := t) r).symm
+      (IntermediateField.AdjoinSimple.coe_aeval_gen_apply (F := K) (α := t) s).symm
+  rw [hrs']
+  have hK : ∀ c : K, (algebraMap K (↥K⟮t⟯)) c ∈ (frobeniusSubfield (↥K⟮t⟯) p : Subfield _) := by
+    intro c
+    obtain ⟨c', hc'⟩ := (frobeniusEquiv K p).surjective c
+    exact ⟨algebraMap K _ c', by
+      rw [← hc']; simp only [frobenius_def, map_pow, frobeniusEquiv_apply, frobenius_def]⟩
+  have haeval : ∀ q : K[X], aeval (genT t) q ∈
+      (IntermediateField.adjoin (↥(frobeniusSubfield (↥K⟮t⟯) p)) {genT t} :
+        IntermediateField _ (↥K⟮t⟯)) := by
+    intro q
+    induction q using Polynomial.induction_on with
+    | C c =>
+      simp only [aeval_C]
+      exact IntermediateField.algebraMap_mem _ (⟨_, hK c⟩ : ↥(frobeniusSubfield (↥K⟮t⟯) p))
+    | add f g hf hg => simpa only [map_add] using add_mem hf hg
+    | monomial n c _ =>
+      simp only [map_mul, aeval_C, map_pow, aeval_X]
+      exact mul_mem (IntermediateField.algebraMap_mem _
+          (⟨_, hK c⟩ : ↥(frobeniusSubfield (↥K⟮t⟯) p)))
+        (pow_mem (IntermediateField.mem_adjoin_simple_self _ _) _)
+  exact div_mem (haeval r) (haeval s)
+
+private theorem finrank_frobeniusSubfield_adjoin_transcendental [PerfectField K]
+    {t : M} (htr : Transcendental K t) :
+    haveI : ExpChar (↥(IntermediateField.adjoin K ({t} : Set M))) p :=
+      expChar_of_injective_algebraMap (algebraMap K _).injective p
+    Module.finrank
+      (frobeniusSubfield (↥(IntermediateField.adjoin K ({t} : Set M))) p)
+      (↥(IntermediateField.adjoin K ({t} : Set M))) = p := by
+  have : ExpChar (↥K⟮t⟯) p :=
+    expChar_of_injective_algebraMap (algebraMap K _).injective p
+  have : CharP (↥K⟮t⟯) p :=
+    charP_of_injective_algebraMap (algebraMap K _).injective p
+  let t' : ↥K⟮t⟯ := genT t
+  let tp : ↥(frobeniusSubfield (↥K⟮t⟯) p) := ⟨t' ^ p, pow_mem_frobeniusSubfield p t'⟩
+  have hint : IsIntegral (↥(frobeniusSubfield (↥K⟮t⟯) p)) t' := by
+    refine ⟨X ^ p - C tp, monic_X_pow_sub_C _ hp.out.ne_zero, ?_⟩
+    simp only [eval₂_sub, eval₂_X_pow, eval₂_C]
+    exact sub_eq_zero.mpr rfl
+  have hfd : FiniteDimensional (↥(frobeniusSubfield (↥K⟮t⟯) p)) (↥K⟮t⟯) := by
+    have h1 := adjoin_genT_over_frobeniusSubfield (K := K) (M := M) p t
+    have h2 := IntermediateField.adjoin.finiteDimensional hint
+    rw [show t' = genT t from rfl, h1] at h2
+    exact (IntermediateField.topEquiv (F := ↥(frobeniusSubfield (↥K⟮t⟯) p))
+      (E := ↥K⟮t⟯)).toLinearEquiv.finiteDimensional
+  have hli := pDigits_linearIndependent (M := ↥K⟮t⟯) p (t := t') (genT_not_pow p t htr)
+  refine le_antisymm ?_
+    (by simpa only [Fintype.card_fin] using hli.fintype_card_le_finrank)
+  have htop := adjoin_genT_over_frobeniusSubfield (K := K) (M := M) p t
+  calc Module.finrank _ (↥K⟮t⟯)
+      = Module.finrank (↥(frobeniusSubfield (↥K⟮t⟯) p))
+          (↥(IntermediateField.adjoin (↥(frobeniusSubfield (↥K⟮t⟯) p)) {t'} :
+            IntermediateField _ (↥K⟮t⟯))) := by
+        rw [show t' = genT t from rfl, htop, IntermediateField.finrank_top']
+    _ = (minpoly (↥(frobeniusSubfield (↥K⟮t⟯) p)) t').natDegree :=
+        IntermediateField.adjoin.finrank hint
+    _ ≤ (X ^ p - C tp).natDegree :=
+        Polynomial.natDegree_le_of_dvd (minpoly.dvd _ _ (by
+          simp only [map_sub, map_pow, aeval_X, aeval_C]; exact sub_eq_zero.mpr rfl))
+          (monic_X_pow_sub_C _ hp.out.ne_zero).ne_zero
+    _ = p := natDegree_X_pow_sub_C
+
+end AdjoinIndex
+
+private theorem finrank_frobeniusSubfield_eq_of_transcendental {K M : Type*} [Field K] [Field M]
+    [Algebra K M] [PerfectField K] (p : ℕ) [hp : Fact p.Prime] [CharP K p]
+    (t : M) (htr : Transcendental K t)
+    [FiniteDimensional (IntermediateField.adjoin K ({t} : Set M)) M] :
+    haveI : ExpChar M p := expChar_of_injective_algebraMap (algebraMap K M).injective p
+    Module.finrank (frobeniusSubfield M p) M = p := by
+  have : ExpChar M p := expChar_of_injective_algebraMap (algebraMap K M).injective p
+  have : ExpChar (↥(IntermediateField.adjoin K ({t} : Set M))) p :=
+    expChar_of_injective_algebraMap (algebraMap K _).injective p
+  have : FiniteDimensional
+      (frobeniusSubfield (↥(IntermediateField.adjoin K ({t} : Set M))) p)
+      (↥(IntermediateField.adjoin K ({t} : Set M))) :=
+    FiniteDimensional.of_finrank_pos (by
+      rw [finrank_frobeniusSubfield_adjoin_transcendental p htr]; exact hp.out.pos)
+  rw [finrank_frobeniusSubfield_eq (E := ↥(IntermediateField.adjoin K ({t} : Set M))) p,
+    finrank_frobeniusSubfield_adjoin_transcendental p htr]
+
+section PDigitsExists
+
+variable {M : Type*} [Field M] (p : ℕ) [hp : Fact p.Prime] [CharP M p]
+
+private theorem pDigits_exists_of_finrank_eq
+    (hfr : haveI : ExpChar M p := ExpChar.prime hp.out
+      Module.finrank (frobeniusSubfield M p) M = p)
+    {t : M} (htp : ∀ a : M, a ^ p ≠ t) (g : M) :
+    ∃ a : Fin p → M, g = ∑ i : Fin p, a i ^ p * t ^ (i : ℕ) := by
+  have : ExpChar M p := ExpChar.prime hp.out
+  have hlin := pDigits_linearIndependent p htp
+  let b : Module.Basis (Fin p) (frobeniusSubfield M p) M :=
+    basisOfLinearIndependentOfCardEqFinrank hlin (by rw [hfr, Fintype.card_fin])
+  have hbapply : ∀ i : Fin p, (b i : M) = t ^ (i : ℕ) := fun i ↦
+    congrFun (coe_basisOfLinearIndependentOfCardEqFinrank hlin
+      (by rw [hfr, Fintype.card_fin])) i
+  refine ⟨fun i ↦ (frobeniusRingEquivRange M p).symm (b.repr g i), ?_⟩
+  conv_lhs => rw [← b.sum_repr g]
+  refine Finset.sum_congr rfl fun i _ ↦ ?_
+  rw [hbapply i, ← frobeniusRingEquivRange_apply M p, RingEquiv.apply_symm_apply]
+  rfl
+
+end PDigitsExists
+
+private theorem pDigits_existsUnique_of_transcendental {K M : Type*} [Field K] [Field M]
+    [Algebra K M] [PerfectField K] (p : ℕ) [hp : Fact p.Prime] [CharP K p]
+    (t : M) (htr : Transcendental K t)
+    [FiniteDimensional (IntermediateField.adjoin K ({t} : Set M)) M]
+    (htp : ∀ a : M, a ^ p ≠ t) (g : M) :
+    ∃! a : Fin p → M, g = ∑ i : Fin p, a i ^ p * t ^ (i : ℕ) := by
+  have : CharP M p := charP_of_injective_algebraMap (algebraMap K M).injective p
+  have : ExpChar M p := ExpChar.prime hp.out
+  have hlin := pDigits_linearIndependent p htp
+  have hfr := finrank_frobeniusSubfield_eq_of_transcendental p t htr
+  let b : Module.Basis (Fin p) (frobeniusSubfield M p) M :=
+    basisOfLinearIndependentOfCardEqFinrank hlin (by rw [hfr, Fintype.card_fin])
+  have hbapply : ∀ i : Fin p, (b i : M) = t ^ (i : ℕ) := fun i ↦
+    congrFun (coe_basisOfLinearIndependentOfCardEqFinrank hlin
+      (by rw [hfr, Fintype.card_fin])) i
+  have hexpand : ∀ (c : Fin p → M),
+      ∑ i : Fin p, c i ^ p * t ^ (i : ℕ) =
+        ∑ i : Fin p, (frobeniusRingEquivRange M p (c i) : frobeniusSubfield M p) • b i := by
+    intro c
+    refine Finset.sum_congr rfl fun i _ ↦ ?_
+    rw [hbapply i, Subfield.smul_def, frobeniusRingEquivRange_apply, smul_eq_mul]
+  obtain ⟨a, ha⟩ := pDigits_exists_of_finrank_eq p hfr htp g
+  refine ⟨a, ha, ?_⟩
+  intro a' ha'
+  have key : ∀ i, frobeniusRingEquivRange M p (a i) = frobeniusRingEquivRange M p (a' i) := by
+    intro i
+    have hga : g = ∑ j : Fin p, (frobeniusRingEquivRange M p (a j) :
+        frobeniusSubfield M p) • b j := ha.trans (hexpand a)
+    have hga' : g = ∑ j : Fin p, (frobeniusRingEquivRange M p (a' j) :
+        frobeniusSubfield M p) • b j := ha'.trans (hexpand a')
+    have hra := b.repr_sum_self
+      (c := fun j ↦ (frobeniusRingEquivRange M p (a j) : frobeniusSubfield M p))
+    have hra' := b.repr_sum_self
+      (c := fun j ↦ (frobeniusRingEquivRange M p (a' j) : frobeniusSubfield M p))
+    rw [← hga] at hra
+    rw [← hga'] at hra'
+    exact congrFun (hra.symm.trans hra') i
+  funext i
+  exact (frobeniusRingEquivRange M p).injective (key i).symm
+
+end AlgebraicCurve.PthPowerIndex
+
+theorem solution {K M : Type*} [Field K] [Field M] [Algebra K M]
+    [PerfectField K] (p : ℕ) [hp : Fact p.Prime] [CharP K p] (t : M) (htr : Transcendental K t)
+    [FiniteDimensional (IntermediateField.adjoin K ({t} : Set M)) M] :
+    haveI : ExpChar M p := expChar_of_injective_algebraMap (algebraMap K M).injective p
+    Module.finrank ↥(frobenius M p).fieldRange M = p :=
+  AlgebraicCurve.PthPowerIndex.finrank_frobeniusSubfield_eq_of_transcendental p t htr
+
+end
+
+end S_AlgebraicCurve_finrank_frobeniusSubfield_eq_of_transcendental
+end P2MW
+export P2MW.S_AlgebraicCurve_finrank_frobeniusSubfield_eq_of_transcendental (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.finrank_frobeniusSubfield_eq_of_transcendental {K M : Type*} [Field K]
+    [Field M] [Algebra K M]
+    [PerfectField K] (p : ℕ) [hp : Fact p.Prime] [CharP K p] (t : M) (htr : Transcendental K t)
+    [FiniteDimensional (IntermediateField.adjoin K ({t} : Set M)) M] :
+    haveI : ExpChar M p := expChar_of_injective_algebraMap (algebraMap K M).injective p
+    Module.finrank ↥(frobenius M p).fieldRange M = p :=
+  solution p t htr
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finrank_le_and_natCard_places_le_of_constantFieldExtension_adjoin.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finrank_le_and_natCard_places_le_of_constantFieldExtension_adjoin.lean
new file mode 100644
index 0000000000..64f305f41b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_finrank_le_and_natCard_places_le_of_constantFieldExtension_adjoin.lean
@@ -0,0 +1,449 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.finrank_le_and_natCard_places_le_of_constantFieldExtension_adjoin
+(a93a0fd6-b762-5620-a1c2-4211647c1f99) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 44d00469-9cc7-55e5-894e-d696722ba769
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import Mathlib.Algebra.Lie.OfAssociative
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_comap_algebraMap_eq_of_constantFieldExtension
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_linearIndependent_of_constantFieldExtension
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Constant field extension: degree and zero/pole counts
+
+Theorem statement:
+`AlgebraicCurve.finrank_le_and_natCard_places_le_of_constantFieldExtension_adjoin`
+(`a93a0fd6-b762-5620-a1c2-4211647c1f99`), by Claude, 2026-09-05.
+
+Proof: submission `44d00469-9cc7-55e5-894e-d696722ba769`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $k$ be an algebraically closed field of characteristic $0$ and let $F$ be a field extension of
+$k$ which is a curve over $k$ in the sense of the project's predicate
+[`AlgebraicCurve.IsCurveOver`](def/AlgebraicCurve_IsCurveOver.html#L15): every nonzero $f \in F$
+admits a divisor of degree $0$ whose value at each place equals $\operatorname{ord}_P(f)$, every
+place $P$ of $F$ over $k$ (a valuation subring of $F$ containing the image of $k$, different from
+$F$ itself, and a principal ideal ring) has residue field finite-dimensional over $k$, and
+$\Omega[F/k]$ is free of rank one over $F$. Let $y \in F$ be transcendental over $k$ with $F$
+finite-dimensional over $k(y) =$ `IntermediateField.adjoin k {y}`. Let $K'$ be a field extension of
+$k$, let $L$ be a field extension of $K'$, let $t \in L$ be transcendental over $K'$, and let $E$ be
+an intermediate field between $K'(t)$ and $L$ with $E$ finite-dimensional over $K'(t)$. Assume $E$
+is an $F$-algebra and a $k$-algebra compatibly with the towers $k \subseteq K' \subseteq E$ and $k
+\subseteq F \subseteq E$, that the image of $y$ in $E$ equals $t$ in $L$, and that $E$ is generated
+over $K'$ by the image of $F$. Then $[F : k(y)] \le [E : K'(t)]$, and for every nonzero $u \in F$
+the set of places $P$ of $E$ over $K'$ with $\operatorname{ord}_P(\varphi(u)) > 0$ is finite of
+cardinality at most the number of places of $F$ over $k$ at which $u$ has positive order, and
+likewise the set of places of $E$ over $K'$ with $\operatorname{ord}_P(\varphi(u)) < 0$ is finite of
+cardinality at most the number of places of $F$ over $k$ at which $u$ has negative order, where
+$\varphi$ denotes the structure map $F \to E$ and $\operatorname{ord}$ is minus the logarithm of the
+associated $\mathbb{Z}^{m0}$-valued adic valuation.
+
+This is the comparison of a one-variable function field with its constant field extension, realised
+concretely inside a finite extension of $K'(t)$: the degree over the rational subfield does not drop
+and the numbers of zeros and of poles of a function do not increase. It is used in the counting
+arguments for modular curves, where fibres of a map of curves are matched with double cosets
+([`ModularCurve.natCard_doubleCoset_le_card_fibres_of_finrank_eq_index`]
+(thm.html#ModularCurve.natCard_doubleCoset_le_card_fibres_of_finrank_eq_index),
+[`ModularCurve.natCard_fibres_jqModC_eq_natCard_doubleCoset_of_finrank_eq_index`]
+(thm.html#ModularCurve.natCard_fibres_jqModC_eq_natCard_doubleCoset_of_finrank_eq_index),
+[`ModularCurve.natCard_place_ord_neg_laurentBaseChange_gamma1_eq_natCard_doubleCoset`]
+(thm.html#ModularCurve.natCard_place_ord_neg_laurentBaseChange_gamma1_eq_natCard_doubleCoset)).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_finrank_le_and_natCard_places_le_of_constantFieldExtension_adjoin.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 1600000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_finrank_le_and_natCard_places_le_of_constantFieldExtension_adjoin
+
+
+open scoped IntermediateField
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ord_inv HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor IsCurveOver \
+  Place.exists_comap_algebraMap_eq_of_constantFieldExtension \
+  linearIndependent_of_constantFieldExtension Place.exists_toValuationSubring_eq_comap_ringHom \
+  Place.mem_iff_ord_nonneg"
+namespace ConstantFieldAdjoin
+p2m_open "AlgebraicCurve"
+
+section Main
+
+theorem linearIndependent_pow_of_transcendental {k A : Type*} [Field k] [Ring A] [Algebra k A]
+    {Y : A} (hY : Transcendental k Y) (N : ℕ) :
+    LinearIndependent k (fun n : Fin N => Y ^ (n : ℕ)) := by
+  classical
+  rw [Fintype.linearIndependent_iff]
+  intro a ha m
+  have hinj := transcendental_iff_injective.mp hY
+  have hpoly : Polynomial.aeval Y (∑ n : Fin N, Polynomial.monomial (n : ℕ) (a n)) = 0 := by
+    rw [map_sum]
+    simpa [Polynomial.aeval_monomial, Algebra.smul_def] using ha
+  have hzero : (∑ n : Fin N, Polynomial.monomial (n : ℕ) (a n)) = 0 :=
+    hinj (by rw [hpoly, map_zero])
+  have hcoeff := congrArg (fun p : Polynomial k => p.coeff (m : ℕ)) hzero
+  simp only [Polynomial.finsetSum_coeff, Polynomial.coeff_monomial, Polynomial.coeff_zero] at hcoeff
+  rw [Finset.sum_eq_single m (fun n _ hn => ite_eq_right (fun h => hn (Fin.ext h))) (by
+    simp)] at hcoeff
+  simpa using hcoeff
+
+variable {k : Type*} [Field k] [IsAlgClosed k] [CharZero k]
+variable {F : Type*} [Field F] [Algebra k F]
+variable {K' : Type*} [Field K'] [Algebra k K']
+variable {L : Type*} [Field L] [Algebra K' L] (t : L) (E : IntermediateField K'⟮t⟯ L)
+variable [Algebra F E] [Algebra k E] [IsScalarTower k K' E] [IsScalarTower k F E]
+
+theorem exists_mul_aeval_eq (l : K'⟮t⟯) :
+    ∃ p q : Polynomial K', Polynomial.aeval t q ≠ 0 ∧ (l : L) * Polynomial.aeval t q =
+      Polynomial.aeval t p := by
+  obtain ⟨r, s, hrs⟩ := (IntermediateField.mem_adjoin_simple_iff K' (l : L)).mp l.2
+  by_cases hs : Polynomial.aeval t s = 0
+  · refine ⟨0, 1, by simp, ?_⟩
+    rw [hrs, hs, div_zero, zero_mul, map_zero]
+  · refine ⟨r, s, hs, ?_⟩
+    rw [hrs, div_mul_cancel₀ _ hs]
+
+
+theorem finrank_le_finrank (y : F) (hy : Transcendental k y) [FiniteDimensional k⟮y⟯ F]
+    (hyt : (algebraMap F E y : L) = t)
+    (hfg' : ∃ x : E, Transcendental K' x ∧ FiniteDimensional K'⟮x⟯ E)
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F E)) = ⊤)
+    [FiniteDimensional K'⟮t⟯ E] :
+    Module.finrank k⟮y⟯ F ≤ Module.finrank K'⟮t⟯ E := by
+  classical
+  set d := Module.finrank k⟮y⟯ F with hd
+  let b := Module.finBasisOfFinrankEq k⟮y⟯ F hd.symm
+  suffices hli : LinearIndependent K'⟮t⟯ (fun i : Fin d => algebraMap F E (b i)) by
+    simpa using hli.fintype_card_le_finrank
+  rw [Fintype.linearIndependent_iff]
+  intro l hl
+  have hpq : ∀ i, ∃ p q : Polynomial K', Polynomial.aeval t q ≠ 0 ∧
+      ((l i : K'⟮t⟯) : L) * Polynomial.aeval t q = Polynomial.aeval t p := fun i =>
+        exists_mul_aeval_eq t (l i)
+  choose p q hq hpq using hpq
+  set Q : Polynomial K' := ∏ i, q i with hQ
+  have hQ0 : Polynomial.aeval t Q ≠ 0 := by
+    rw [hQ, map_prod]
+    exact Finset.prod_ne_zero_iff.mpr fun i _ => hq i
+  let P : Fin d → Polynomial K' := fun i => p i * ∏ j ∈ Finset.univ.erase i, q j
+  have hP : ∀ i, ((l i : K'⟮t⟯) : L) * Polynomial.aeval t Q = Polynomial.aeval t (P i) := by
+    intro i
+    rw [hQ, ← Finset.mul_prod_erase Finset.univ q (Finset.mem_univ i), map_mul, ← mul_assoc, hpq i,
+      ← map_mul]
+  have hrelL : ∑ i, ((l i : K'⟮t⟯) : L) * (algebraMap F E (b i) : L) = 0 := by
+    have := congrArg (fun e : E => (e : L)) hl
+    simpa [IntermediateField.smul_def, smul_eq_mul] using this
+  have hrelQ : ∑ i, Polynomial.aeval t (P i) * (algebraMap F E (b i) : L) = 0 := by
+    have := congrArg (fun z : L => Polynomial.aeval t Q * z) hrelL
+    simp only [mul_zero, Finset.mul_sum] at this
+    rw [← this]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [← hP i]; ring
+  set N : ℕ := (Finset.univ.sup fun i => (P i).natDegree) + 1 with hN
+  have hdeg : ∀ i, (P i).natDegree < N := fun i =>
+    Nat.lt_succ_of_le (Finset.le_sup (f := fun i => (P i).natDegree) (Finset.mem_univ i))
+  have htn : ∀ n : ℕ, ((algebraMap F E (y ^ n) : E) : L) = t ^ n := by
+    intro n
+    rw [map_pow]
+    push_cast
+    rw [hyt]
+  have hrel2 : ∑ pr : Fin N × Fin d,
+      (P pr.2).coeff (pr.1 : ℕ) • ((algebraMap F E (y ^ (pr.1 : ℕ) * b pr.2) : E) : L) = 0 := by
+    rw [← hrelQ, Fintype.sum_prod_type, Finset.sum_comm]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [Polynomial.aeval_eq_sum_range' (hdeg i), Finset.sum_mul, ← Fin.sum_univ_eq_sum_range]
+    refine Finset.sum_congr rfl fun n _ => ?_
+    rw [map_mul, MulMemClass.coe_mul, htn, smul_mul_assoc]
+  let Y : k⟮y⟯ := ⟨y, IntermediateField.mem_adjoin_simple_self k y⟩
+  have hYt : Transcendental k Y := by
+    have hinj : Function.Injective (algebraMap k⟮y⟯ F) := (algebraMap k⟮y⟯ F).injective
+    rw [← transcendental_algebraMap_iff hinj]
+    exact hy
+  have hli1 : LinearIndependent k (fun pr : Fin N × Fin d => (Y ^ (pr.1 : ℕ)) • b pr.2) :=
+    linearIndependent_smul (linearIndependent_pow_of_transcendental hYt N) b.linearIndependent
+  have hfam : (fun pr : Fin N × Fin d => y ^ (pr.1 : ℕ) * b pr.2) =
+      (fun pr : Fin N × Fin d => (Y ^ (pr.1 : ℕ)) • b pr.2) := by
+    funext pr
+    rw [IntermediateField.smul_def]
+    rfl
+  have hLD := AlgebraicCurve.linearIndependent_of_constantFieldExtension k F K' E
+    ⟨y, hy, inferInstance⟩ hfg' hgen (b := fun pr : Fin N × Fin d => y ^ (pr.1 : ℕ) * b pr.2)
+    (by rw [hfam]; exact hli1)
+  have hLD' : LinearIndependent K'
+      (fun pr : Fin N × Fin d => ((algebraMap F E (y ^ (pr.1 : ℕ) * b pr.2) : E) : L)) :=
+    hLD.map' ((E.val.restrictScalars K').toLinearMap)
+      (LinearMap.ker_eq_bot.mpr fun a b h => Subtype.ext h)
+  have hcoeff : ∀ pr : Fin N × Fin d, (P pr.2).coeff (pr.1 : ℕ) = 0 :=
+    Fintype.linearIndependent_iff.mp hLD' _ hrel2
+  intro i
+  have hPi : P i = 0 := by
+    ext n
+    rw [Polynomial.coeff_zero]
+    rcases lt_or_ge n N with hn | hn
+    · exact hcoeff (⟨n, hn⟩, i)
+    · exact Polynomial.coeff_eq_zero_of_natDegree_lt (lt_of_lt_of_le (hdeg i) hn)
+  have := hP i
+  rw [hPi, map_zero, mul_eq_zero] at this
+  rcases this with h | h
+  · exact_mod_cast h
+  · exact absurd h hQ0
+
+theorem natCard_places_le (y : F) (hy : Transcendental k y) [FiniteDimensional k⟮y⟯ F]
+    [AlgebraicCurve.IsCurveOver k F]
+    (hfg' : ∃ x : E, Transcendental K' x ∧ FiniteDimensional K'⟮x⟯ E)
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F E)) = ⊤)
+    (u : F) (hu : u ≠ 0) :
+    (Finite {P : AlgebraicCurve.Place K' E // 0 < P.ord (algebraMap F E u)} ∧
+      Nat.card {P : AlgebraicCurve.Place K' E // 0 < P.ord (algebraMap F E u)} ≤
+        Nat.card {P : AlgebraicCurve.Place k F // 0 < P.ord u}) ∧
+      (Finite {P : AlgebraicCurve.Place K' E // P.ord (algebraMap F E u) < 0} ∧
+      Nat.card {P : AlgebraicCurve.Place K' E // P.ord (algebraMap F E u) < 0} ≤
+        Nat.card {P : AlgebraicCurve.Place k F // P.ord u < 0}) := by
+  classical
+  have hu' : algebraMap F E u ≠ 0 := (map_ne_zero _).mpr hu
+  have hcomap : ∀ P : AlgebraicCurve.Place K' E, P.ord (algebraMap F E u) ≠ 0 →
+      ∃ v : AlgebraicCurve.Place k F,
+        v.toValuationSubring = P.toValuationSubring.comap (algebraMap F E) := by
+    intro P hP
+    refine AlgebraicCurve.Place.exists_toValuationSubring_eq_comap_ringHom (K := k) y (algebraMap F
+      E)
+      P.toValuationSubring (fun a => ?_) ?_
+    · rw [← IsScalarTower.algebraMap_apply, IsScalarTower.algebraMap_apply k K' E]
+      exact P.algebraMap_mem' _
+    · rcases lt_or_gt_of_ne hP with h | h
+      · exact ⟨u, fun hmem => by
+          have := (AlgebraicCurve.Place.mem_iff_ord_nonneg P hu').mp hmem; omega⟩
+      · refine ⟨u⁻¹, fun hmem => ?_⟩
+        rw [map_inv₀] at hmem
+        have := (AlgebraicCurve.Place.mem_iff_ord_nonneg P (inv_ne_zero hu')).mp hmem
+        rw [AlgebraicCurve.Place.ord_inv] at this
+        omega
+  have huniq : ∀ (v : AlgebraicCurve.Place k F) (P₁ P₂ : AlgebraicCurve.Place K' E),
+      P₁.toValuationSubring.comap (algebraMap F E) = v.toValuationSubring →
+      P₂.toValuationSubring.comap (algebraMap F E) = v.toValuationSubring → P₁ = P₂ := by
+    intro v P₁ P₂ h₁ h₂
+    obtain ⟨P', -, -, hP'⟩ :=
+      AlgebraicCurve.Place.exists_comap_algebraMap_eq_of_constantFieldExtension k F K' E
+        ⟨y, hy, inferInstance⟩ hfg' hgen v
+    rw [hP' P₁ h₁, hP' P₂ h₂]
+  have hsign_pos : ∀ (P : AlgebraicCurve.Place K' E) (v : AlgebraicCurve.Place k F),
+      v.toValuationSubring = P.toValuationSubring.comap (algebraMap F E) →
+      (0 < P.ord (algebraMap F E u) ↔ 0 < v.ord u) := by
+    intro P v hv
+    have h1 : algebraMap F E u ∈ P.toValuationSubring ↔ u ∈ v.toValuationSubring := by
+      rw [hv, ValuationSubring.mem_comap]
+    have h2 : (algebraMap F E u)⁻¹ ∈ P.toValuationSubring ↔ u⁻¹ ∈ v.toValuationSubring := by
+      rw [hv, ValuationSubring.mem_comap, map_inv₀]
+    rw [AlgebraicCurve.Place.mem_iff_ord_nonneg P hu', AlgebraicCurve.Place.mem_iff_ord_nonneg v
+      hu] at h1
+    rw [AlgebraicCurve.Place.mem_iff_ord_nonneg P (inv_ne_zero hu'),
+      AlgebraicCurve.Place.mem_iff_ord_nonneg v (inv_ne_zero hu),
+      AlgebraicCurve.Place.ord_inv, AlgebraicCurve.Place.ord_inv] at h2
+    constructor
+    · intro h; by_contra h'; have := h2.mpr (by omega); omega
+    · intro h; by_contra h'; have := h2.mp (by omega); omega
+  have hsign_neg : ∀ (P : AlgebraicCurve.Place K' E) (v : AlgebraicCurve.Place k F),
+      v.toValuationSubring = P.toValuationSubring.comap (algebraMap F E) →
+      (P.ord (algebraMap F E u) < 0 ↔ v.ord u < 0) := by
+    intro P v hv
+    have h1 : algebraMap F E u ∈ P.toValuationSubring ↔ u ∈ v.toValuationSubring := by
+      rw [hv, ValuationSubring.mem_comap]
+    rw [AlgebraicCurve.Place.mem_iff_ord_nonneg P hu', AlgebraicCurve.Place.mem_iff_ord_nonneg v
+      hu] at h1
+    constructor
+    · intro h; by_contra h'; have := h1.mpr (by omega); omega
+    · intro h; by_contra h'; have := h1.mp (by omega); omega
+  obtain ⟨D, hD, -⟩ := AlgebraicCurve.HasPrincipalDivisors.exists_divisor (K := k) u hu
+  have hfin_pos : Finite {P : AlgebraicCurve.Place k F // 0 < P.ord u} := by
+    apply Finite.of_injective (fun P => (⟨P.1, by
+      rw [Finsupp.mem_support_iff, hD]; exact P.2.ne'⟩ : D.support))
+    intro P₁ P₂ h; exact Subtype.ext (congrArg (fun z : D.support => (z : AlgebraicCurve.Place k F))
+      h)
+  have hfin_neg : Finite {P : AlgebraicCurve.Place k F // P.ord u < 0} := by
+    apply Finite.of_injective (fun P => (⟨P.1, by
+      rw [Finsupp.mem_support_iff, hD]; exact P.2.ne⟩ : D.support))
+    intro P₁ P₂ h; exact Subtype.ext (congrArg (fun z : D.support => (z : AlgebraicCurve.Place k F))
+      h)
+  constructor
+  · let f : {P : AlgebraicCurve.Place K' E // 0 < P.ord (algebraMap F E u)} →
+        {P : AlgebraicCurve.Place k F // 0 < P.ord u} := fun P =>
+      ⟨(hcomap P.1 P.2.ne').choose,
+        (hsign_pos P.1 _ (hcomap P.1 P.2.ne').choose_spec).mp P.2⟩
+    suffices hf : Function.Injective f from
+      ⟨Finite.of_injective f hf, Nat.card_le_card_of_injective f hf⟩
+    intro P₁ P₂ h
+    apply Subtype.ext
+    have h' := congrArg (fun z : {P : AlgebraicCurve.Place k F // 0 < P.ord u} => z.1) h
+    exact huniq _ P₁.1 P₂.1 (hcomap P₁.1 P₁.2.ne').choose_spec.symm
+      (by rw [show (hcomap P₁.1 P₁.2.ne').choose = (hcomap P₂.1 P₂.2.ne').choose from h']
+          exact (hcomap P₂.1 P₂.2.ne').choose_spec.symm)
+  · let f : {P : AlgebraicCurve.Place K' E // P.ord (algebraMap F E u) < 0} →
+        {P : AlgebraicCurve.Place k F // P.ord u < 0} := fun P =>
+      ⟨(hcomap P.1 P.2.ne).choose,
+        (hsign_neg P.1 _ (hcomap P.1 P.2.ne).choose_spec).mp P.2⟩
+    suffices hf : Function.Injective f from
+      ⟨Finite.of_injective f hf, Nat.card_le_card_of_injective f hf⟩
+    intro P₁ P₂ h
+    apply Subtype.ext
+    have h' := congrArg (fun z : {P : AlgebraicCurve.Place k F // P.ord u < 0} => z.1) h
+    exact huniq _ P₁.1 P₂.1 (hcomap P₁.1 P₁.2.ne).choose_spec.symm
+      (by rw [show (hcomap P₁.1 P₁.2.ne).choose = (hcomap P₂.1 P₂.2.ne).choose from h']
+          exact (hcomap P₂.1 P₂.2.ne).choose_spec.symm)
+
+omit [IsAlgClosed k] [CharZero k] in
+theorem finiteDimensional_adjoin_of_coe_eq [FiniteDimensional K'⟮t⟯ E] (x : E) (hx : (x : L) = t) :
+    FiniteDimensional K'⟮x⟯ E := by
+  let f : E →ₐ[K'] L := E.val.restrictScalars K'
+  have hmap : (K'⟮x⟯).map f = K'⟮t⟯ := by
+    rw [IntermediateField.adjoin_map, Set.image_singleton]
+    congr 1
+    rw [Set.singleton_eq_singleton_iff]
+    exact hx
+  let e : K'⟮x⟯ ≃ₐ[K'] K'⟮t⟯ :=
+    (IntermediateField.equivMap K'⟮x⟯ f).trans (IntermediateField.equivOfEq hmap)
+  have he : ∀ z : K'⟮x⟯, ((e z : K'⟮t⟯) : L) = ((z : E) : L) := fun z => rfl
+  refine Module.Finite.of_equiv_equiv (A₁ := K'⟮t⟯) (B₁ := E) (A₂ := K'⟮x⟯) (B₂ := E)
+    e.symm.toRingEquiv (RingEquiv.refl E) ?_
+  refine RingHom.ext fun l => Subtype.ext ?_
+  change (((e.symm l : K'⟮x⟯) : E) : L) = ((algebraMap K'⟮t⟯ E l : E) : L)
+  rw [← he (e.symm l), AlgEquiv.apply_symm_apply]
+  rfl
+
+theorem adjoin_adjoin_subset {K' : Type*} [Field K'] {L : Type*} [Field L] [Algebra K' L]
+    (S : Set L) (t : L)
+    (ht : t ∈ IntermediateField.adjoin K' S) :
+    ((IntermediateField.adjoin K'⟮t⟯ S : IntermediateField K'⟮t⟯ L) : Set L) ⊆
+      ((IntermediateField.adjoin K' S : IntermediateField K' L) : Set L) := by
+  have h1 : ((IntermediateField.adjoin K'⟮t⟯ S : IntermediateField K'⟮t⟯ L) : Set L) =
+      (IntermediateField.restrictScalars K' (IntermediateField.adjoin K'⟮t⟯ S) : Set L) := rfl
+  rw [h1, IntermediateField.restrictScalars_adjoin]
+  have hle : IntermediateField.adjoin K' ((K'⟮t⟯ : Set L) ∪ S) ≤ IntermediateField.adjoin K' S := by
+    rw [IntermediateField.adjoin_le_iff]
+    apply Set.union_subset
+    · have : K'⟮t⟯ ≤ IntermediateField.adjoin K' S := IntermediateField.adjoin_simple_le_iff.mpr ht
+      exact SetLike.coe_subset_coe.mpr this
+    · exact IntermediateField.subset_adjoin _ _
+  exact SetLike.coe_subset_coe.mpr hle
+
+omit [IsAlgClosed k] [CharZero k] in
+theorem adjoin_range_eq_top
+    (hEle : (E : Set L) ⊆
+      ((IntermediateField.adjoin K' (Set.range fun u : F => (algebraMap F E u : L)) :
+        IntermediateField K' L) : Set L)) :
+    IntermediateField.adjoin K' (Set.range (algebraMap F E)) = ⊤ := by
+  let f : E →ₐ[K'] L := E.val.restrictScalars K'
+  set A := IntermediateField.adjoin K' (Set.range (algebraMap F E)) with hA
+  have hmapA : A.map f = IntermediateField.adjoin K' (Set.range fun u : F => (algebraMap F E u : L))
+    :=
+    by
+    rw [hA, IntermediateField.adjoin_map, ← Set.range_comp]
+    rfl
+  rw [eq_top_iff]
+  intro e _
+  have he : (e : L) ∈ A.map f := by
+    rw [hmapA]; exact hEle e.2
+  obtain ⟨a, ha, hae⟩ := (IntermediateField.mem_map A).mp he
+  have : a = e := Subtype.ext hae
+  rw [← this]; exact ha
+
+end Main
+
+end AlgebraicCurve.ConstantFieldAdjoin
+
+end
+
+open scoped IntermediateField in
+theorem solution
+    {k : Type*} [Field k] [IsAlgClosed k] [CharZero k]
+    {F : Type*} [Field F] [Algebra k F] [AlgebraicCurve.IsCurveOver k F]
+    (y : F) (hy : Transcendental k y)
+    [FiniteDimensional (IntermediateField.adjoin k ({y} : Set F)) F]
+    {K' : Type*} [Field K'] [Algebra k K']
+    {L : Type*} [Field L] [Algebra K' L] (t : L) (ht : Transcendental K' t)
+    (E : IntermediateField (IntermediateField.adjoin K' ({t} : Set L)) L)
+    [FiniteDimensional (IntermediateField.adjoin K' ({t} : Set L)) E]
+    [Algebra F E] [Algebra k E] [IsScalarTower k K' E] [IsScalarTower k F E]
+    (hyt : (algebraMap F E y : L) = t)
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F E)) = ⊤) :
+    Module.finrank (IntermediateField.adjoin k ({y} : Set F)) F ≤
+        Module.finrank (IntermediateField.adjoin K' ({t} : Set L)) E ∧
+      ∀ u : F, u ≠ 0 →
+        (Finite {P : AlgebraicCurve.Place K' E // 0 < P.ord (algebraMap F E u)} ∧
+          Nat.card {P : AlgebraicCurve.Place K' E // 0 < P.ord (algebraMap F E u)} ≤
+            Nat.card {P : AlgebraicCurve.Place k F // 0 < P.ord u}) ∧
+        (Finite {P : AlgebraicCurve.Place K' E // P.ord (algebraMap F E u) < 0} ∧
+          Nat.card {P : AlgebraicCurve.Place K' E // P.ord (algebraMap F E u) < 0} ≤
+            Nat.card {P : AlgebraicCurve.Place k F // P.ord u < 0}) := by
+  have hx : Transcendental K' (algebraMap F E y) := by
+    have : IsScalarTower K' E L := IsScalarTower.of_algebraMap_eq (fun _ => rfl)
+    rw [← transcendental_algebraMap_iff (R := K') (A := L) (algebraMap E L).injective]
+    change Transcendental K' ((algebraMap F E y : E) : L)
+    rw [hyt]
+    exact ht
+  have hfg' : ∃ x : E, Transcendental K' x ∧ FiniteDimensional K'⟮x⟯ E :=
+    ⟨algebraMap F E y, hx,
+      AlgebraicCurve.ConstantFieldAdjoin.finiteDimensional_adjoin_of_coe_eq t E _ hyt⟩
+  exact ⟨AlgebraicCurve.ConstantFieldAdjoin.finrank_le_finrank t E y hy hyt hfg' hgen,
+    fun u hu => AlgebraicCurve.ConstantFieldAdjoin.natCard_places_le t E y hy hfg' hgen u hu⟩
+
+end S_AlgebraicCurve_finrank_le_and_natCard_places_le_of_constantFieldExtension_adjoin
+end P2MW
+export P2MW.S_AlgebraicCurve_finrank_le_and_natCard_places_le_of_constantFieldExtension_adjoin
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped IntermediateField
+theorem AlgebraicCurve.finrank_le_and_natCard_places_le_of_constantFieldExtension_adjoin
+    {k : Type*} [Field k] [IsAlgClosed k] [CharZero k]
+    {F : Type*} [Field F] [Algebra k F] [AlgebraicCurve.IsCurveOver k F]
+    (y : F) (hy : Transcendental k y)
+    [FiniteDimensional (IntermediateField.adjoin k ({y} : Set F)) F]
+    {K' : Type*} [Field K'] [Algebra k K']
+    {L : Type*} [Field L] [Algebra K' L] (t : L) (ht : Transcendental K' t)
+    (E : IntermediateField (IntermediateField.adjoin K' ({t} : Set L)) L)
+    [FiniteDimensional (IntermediateField.adjoin K' ({t} : Set L)) E]
+    [Algebra F E] [Algebra k E] [IsScalarTower k K' E] [IsScalarTower k F E]
+    (hyt : (algebraMap F E y : L) = t)
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F E)) = ⊤) :
+    Module.finrank (IntermediateField.adjoin k ({y} : Set F)) F ≤
+        Module.finrank (IntermediateField.adjoin K' ({t} : Set L)) E ∧
+      ∀ u : F, u ≠ 0 →
+        (Finite {P : AlgebraicCurve.Place K' E // 0 < P.ord (algebraMap F E u)} ∧
+          Nat.card {P : AlgebraicCurve.Place K' E // 0 < P.ord (algebraMap F E u)} ≤
+            Nat.card {P : AlgebraicCurve.Place k F // 0 < P.ord u}) ∧
+        (Finite {P : AlgebraicCurve.Place K' E // P.ord (algebraMap F E u) < 0} ∧
+          Nat.card {P : AlgebraicCurve.Place K' E // P.ord (algebraMap F E u) < 0} ≤
+            Nat.card {P : AlgebraicCurve.Place k F // P.ord u < 0}) :=
+  solution y hy t ht E hyt hgen
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed.lean
new file mode 100644
index 0000000000..396875e098
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed.lean
@@ -0,0 +1,119 @@
+/-
+Based on Prove2Me node AlgebraicCurve.functionFieldRiemannRoch_of_isAlgClosed
+(b4ac021e-cbea-59f4-abb3-092663a1778d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2254a18a-8fc5-56c0-8fbb-b9a37eb766a0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_LocalResidue
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RiemannRochRows
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_residueTheoremK_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_functionFieldRiemannRoch_of_residueTheoremK_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Riemann–Roch over an algebraically closed base field
+
+Theorem statement: `AlgebraicCurve.functionFieldRiemannRoch_of_isAlgClosed`
+(`b4ac021e-cbea-59f4-abb3-092663a1778d`), by Claude, 2026-09-05.
+
+Proof: submission `2254a18a-8fc5-56c0-8fbb-b9a37eb766a0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field (no restriction on characteristic), with decidable equality
+on $\mathrm{RatFunc}\,K$, and let $F$ be a field and a $K$-algebra which is moreover an algebra over
+$\mathrm{RatFunc}\,K$ compatibly with $K$ (scalar tower), integral, module-finite and
+finite-dimensional over $\mathrm{RatFunc}\,K$, and separable over it. Assume: `HasCanonicalDivisor`,
+i.e. for every nonzero $\omega \in \Omega_{F/K}$ the function $v \mapsto
+v.\mathrm{ordDifferential}\,\omega$ on places is given by a finitely supported divisor; at every
+place of $F$ and of $\mathrm{RatFunc}\,K$ the element `dCoord` spans $\Omega$ over the field
+(`DCoordGenerates`) and the residue field is finite-dimensional over $K$ (`FiniteResidue`);
+$\Omega_{F/K}$ and $\Omega_{\mathrm{RatFunc}\,K/K}$ are nontrivial; `HasLocalResidue K F`, i.e.
+every place carries a $K$-linear residue map on $F$ vanishing on the valuation subring and sending
+$f$ with $\pi f$ integral to the residue class of $\pi f$; `HasCanonicalLocalResidueKStar K F`, a
+choice of canonical local residue datum over $K$ at each place; `HasPrincipalDivisors K F`, i.e.
+each nonzero $f \in F$ has a divisor of valuations of total degree $0$; `IsCurveOver K F` and
+$\mathrm{IsCurveOver}\,K\,(\mathrm{RatFunc}\,K)$ (principal divisors, finite residue fields,
+$\Omega$ free of rank one); and `HasSeparableResidue K F`, i.e. the trace form
+$\mathrm{Tr}_{\kappa(v)/K}$ is nonzero at every place. Then `FunctionFieldRiemannRoch K F` holds:
+granted the curve, canonical-divisor and `DCoordGenerates` structures, for every nonzero $\omega \in
+\Omega_{F/K}$ and every divisor $D$ of $F/K$, $\ell(D) - \ell\bigl((\omega) - D\bigr) = \deg D + 1 -
+g$, with $(\omega)$ the chosen canonical divisor of $\omega$ and $g$ the genus as defined from the
+degree of a canonical divisor.
+
+This is the Riemann–Roch theorem for the function field $F/K$ of a curve over an algebraically
+closed field, in Tate's residue-theoretic formulation. It is the form used downstream to compute
+$\deg(\omega) = 2g-2$, to identify $\ell((\omega)) = g$, and in the ramification count
+[`AlgebraicCurve.finsum_ramificationIndexAlong_sub_one_eq`]
+(thm.html#AlgebraicCurve.finsum_ramificationIndexAlong_sub_one_eq).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed
+
+theorem solution
+    {K F : Type*} [Field K] [IsAlgClosed K]
+    [Field F] [Algebra K F]
+    [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [Algebra.IsIntegral (RatFunc K) F]
+    [AlgebraicCurve.HasLocalResidue K F]
+    [∀ w : AlgebraicCurve.Place K F, w.FiniteResidue]
+    [Nontrivial Ω[F⁄K]]
+    [AlgebraicCurve.IsCurveOver K (RatFunc K)]
+    [∀ u : AlgebraicCurve.Place K (RatFunc K), u.FiniteResidue]
+    [AlgebraicCurve.HasCanonicalLocalResidueKStar K F]
+    [Algebra.IsSeparable (RatFunc K) F]
+    [Nontrivial Ω[(RatFunc K)⁄K]] [∀ v : AlgebraicCurve.Place K (RatFunc K), v.DCoordGenerates]
+    [FiniteDimensional (RatFunc K) F] [AlgebraicCurve.HasSeparableResidue K F] :
+    AlgebraicCurve.FunctionFieldRiemannRoch K F := by
+  classical
+  exact
+    AlgebraicCurve.functionFieldRiemannRoch_of_residueTheoremK_of_isAlgClosed
+      (hRTK := AlgebraicCurve.residueTheoremK_of_isAlgClosed)
+
+end S_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed
+end P2MW
+export P2MW.S_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.functionFieldRiemannRoch_of_isAlgClosed
+    {K F : Type*} [Field K] [IsAlgClosed K]
+    [Field F] [Algebra K F]
+    [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [Algebra.IsIntegral (RatFunc K) F]
+    [AlgebraicCurve.HasLocalResidue K F]
+    [∀ w : AlgebraicCurve.Place K F, w.FiniteResidue]
+    [Nontrivial Ω[F⁄K]]
+    [AlgebraicCurve.IsCurveOver K (RatFunc K)]
+    [∀ u : AlgebraicCurve.Place K (RatFunc K), u.FiniteResidue]
+    [AlgebraicCurve.HasCanonicalLocalResidueKStar K F]
+    [Algebra.IsSeparable (RatFunc K) F]
+    [Nontrivial Ω[(RatFunc K)⁄K]] [∀ v : AlgebraicCurve.Place K (RatFunc K), v.DCoordGenerates]
+    [FiniteDimensional (RatFunc K) F] [AlgebraicCurve.HasSeparableResidue K F] :
+    AlgebraicCurve.FunctionFieldRiemannRoch K F := by
+  classical
+  exact
+    solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver.lean
new file mode 100644
index 0000000000..b3659f3ced
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver.lean
@@ -0,0 +1,119 @@
+/-
+Based on Prove2Me node AlgebraicCurve.functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver
+(3a944b5c-172c-5044-964d-7f2ed0fa2054) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6017bee5-ca7f-5960-bbed-aa34bbe52075
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RiemannRochRows
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_CanonicalLocalResidueInstanceV2
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Riemann–Roch over an algebraically closed constant field
+
+Theorem statement: `AlgebraicCurve.functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver`
+(`3a944b5c-172c-5044-964d-7f2ed0fa2054`), by Claude, 2026-09-05.
+
+Proof: submission `6017bee5-ca7f-5960-bbed-aa34bbe52075`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field and $F$ a field equipped with a $K$-algebra structure,
+subject to the following hypotheses. The places of $F$ over $K$ — valuation subrings of $F$
+containing the image of $K$, proper in $F$, and principal ideal rings — are assumed to satisfy: each
+nonzero $\omega \in \Omega_{F/K}$ has its family of differential orders $v \mapsto
+v.\mathrm{ordDifferential}\,\omega$ realised by a finitely supported divisor
+(`HasCanonicalDivisor`); for each place $v$ the differential $d(\pi_v)$ of a uniformiser spans
+$\Omega_{F/K}$ over $F$ (`DCoordGenerates`); each residue field is finite-dimensional over $K$;
+every nonzero $f \in F$ has a finitely supported divisor of orders, of degree $0$
+(`HasPrincipalDivisors`); and $F$ is a curve over $K$ in the sense that principal divisors exist,
+residue fields are finite over $K$, and $\Omega_{F/K}$ is free of rank one over $F$. Further, $F$ is
+a finite, finite-dimensional, integral, separable extension of $\mathrm{RatFunc}\,K$ compatibly with
+$K$, the rational function field itself is a curve over $K$ whose places have finite residue fields
+and satisfy `DCoordGenerates`, and $\Omega_{F/K}$ and $\Omega_{\mathrm{RatFunc}\,K/K}$ are
+nontrivial. Then `FunctionFieldRiemannRoch K F` holds: for every nonzero $\omega \in \Omega_{F/K}$
+and every divisor $D$ of $F/K$, $$\ell(D) - \ell((\omega) - D) = \deg D + 1 - g,$$ where $(\omega)$
+is the canonical divisor attached to $\omega$, $\deg$ is the degree of a divisor weighted by residue
+degrees, and $g$ is the genus, defined from $\deg$ of a canonical divisor by $(\deg + 2)/2$.
+
+This is the Riemann–Roch theorem for an algebraic function field of one variable with algebraically
+closed constant field, in the form $\ell(D) - \ell((\omega)-D) = \deg D + 1 - g$. It is the version
+of the theorem whose hypothesis list mentions only places, divisors and differentials, and it feeds
+the consequences drawn from Riemann–Roch in the project, such as the triviality of divisor classes
+in genus zero and the resulting structure of the degree-zero Picard group.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver
+
+
+open AlgebraicCurve
+
+theorem solution
+    {K F : Type*} [Field K] [IsAlgClosed K]
+    [Field F] [Algebra K F]
+    [AlgebraicCurve.HasCanonicalDivisor (K := K) (F := F)]
+    [∀ w : AlgebraicCurve.Place K F, w.DCoordGenerates]
+    [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [Algebra.IsIntegral (RatFunc K) F]
+    [∀ w : AlgebraicCurve.Place K F, w.FiniteResidue]
+    [Nontrivial Ω[F⁄K]]
+    [AlgebraicCurve.IsCurveOver K F] [AlgebraicCurve.IsCurveOver K (RatFunc K)]
+    [∀ u : AlgebraicCurve.Place K (RatFunc K), u.FiniteResidue]
+    [Algebra.IsSeparable (RatFunc K) F]
+    [Nontrivial Ω[(RatFunc K)⁄K]] [∀ v : AlgebraicCurve.Place K (RatFunc K), v.DCoordGenerates]
+    [FiniteDimensional (RatFunc K) F] :
+    AlgebraicCurve.FunctionFieldRiemannRoch K F := by
+  classical
+  have : HasCanonicalLocalResidueKStar K F := instHasCanonicalLocalResidueKStar
+  have : HasSeparableResidue K F := HasSeparableResidue.of_perfectField_of_isCurveOver
+  intro _i1 _i2 _i3 ω hω D
+  exact functionFieldRiemannRoch_of_isAlgClosed (K := K) (F := F) hω D
+
+end S_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver
+end P2MW
+export P2MW.S_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver
+    {K F : Type*} [Field K] [IsAlgClosed K]
+    [Field F] [Algebra K F]
+    [AlgebraicCurve.HasCanonicalDivisor (K := K) (F := F)]
+    [∀ w : AlgebraicCurve.Place K F, w.DCoordGenerates]
+    [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [Algebra.IsIntegral (RatFunc K) F]
+    [∀ w : AlgebraicCurve.Place K F, w.FiniteResidue]
+    [Nontrivial Ω[F⁄K]]
+    [AlgebraicCurve.IsCurveOver K F] [AlgebraicCurve.IsCurveOver K (RatFunc K)]
+    [∀ u : AlgebraicCurve.Place K (RatFunc K), u.FiniteResidue]
+    [Algebra.IsSeparable (RatFunc K) F]
+    [Nontrivial Ω[(RatFunc K)⁄K]] [∀ v : AlgebraicCurve.Place K (RatFunc K), v.DCoordGenerates]
+    [FiniteDimensional (RatFunc K) F] :
+    AlgebraicCurve.FunctionFieldRiemannRoch K F := by
+  classical
+  exact solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_functionFieldRiemannRoch_of_residueTheoremK_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_functionFieldRiemannRoch_of_residueTheoremK_of_isAlgClosed.lean
new file mode 100644
index 0000000000..f162cdc09d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_functionFieldRiemannRoch_of_residueTheoremK_of_isAlgClosed.lean
@@ -0,0 +1,3216 @@
+/-
+Based on Prove2Me node AlgebraicCurve.functionFieldRiemannRoch_of_residueTheoremK_of_isAlgClosed
+(8bd1b687-2d60-5640-816e-0d5b5cf62589) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9f4f5d07-b3d2-5b73-addf-0040dc8f2e92
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_LocalResidue
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RiemannRochRows
+
+import Mathlib.Algebra.Polynomial.Basis
+import Mathlib.Data.Int.LeastGreatest
+import Mathlib.LinearAlgebra.Matrix.FiniteDimensional
+import Mathlib.NumberTheory.RatFunc.Ostrowski
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_CanonicalLocalResidueInstanceV2
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_WeilOfKaehler
+import LeanPool.FLTEichlerShimura.Definitions.Defs_IsogenyEndDatum_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Defs_WeierstrassCurve_veluSharedLibrary
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached
+
+/-!
+# Riemann–Roch from the residue theorem, K algebraically closed
+
+Theorem statement: `AlgebraicCurve.functionFieldRiemannRoch_of_residueTheoremK_of_isAlgClosed`
+(`8bd1b687-2d60-5640-816e-0d5b5cf62589`), by Claude, 2026-09-05.
+
+Proof: submission `9f4f5d07-b3d2-5b73-addf-0040dc8f2e92`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field and $F$ a field equipped with a $K$-algebra structure, and
+suppose in addition that $F$ is an algebra over $\mathrm{RatFunc}\,K$ compatibly with $K$ (scalar
+tower), integral, finite and separable over $\mathrm{RatFunc}\,K$. The remaining hypotheses are:
+`HasCanonicalDivisor`, i.e. for each nonzero $\omega \in \Omega_{F/K}$ there is a finitely supported
+$\mathbb Z$-valued function on the places of $F/K$ whose value at each place $v$ is
+$\mathrm{ord}_v(\omega)$; at every place $v$ of $F/K$ and of $\mathrm{RatFunc}\,K/K$ the element
+$d\,(\text{uniformiser})$ spans the relevant module of differentials over the field and the residue
+field is finite over $K$; $\Omega_{F/K}$ and $\Omega_{\mathrm{RatFunc}\,K/K}$ are nontrivial;
+`IsCurveOver K F` and `IsCurveOver K (RatFunc K)` (principal divisors exist and have degree $0$,
+residue fields are finite over $K$, and the module of differentials is free of rank one);
+`HasPrincipalDivisors K F`; existence of local residue data at every place, together with a chosen
+family of canonical local residue data over $K$; and `HasSeparableResidue K F`, i.e. the trace
+$\mathrm{Tr}_{\,\kappa(v)/K}$ is nonzero for every place $v$. Assume finally `ResidueTheoremK K F`:
+for every family of canonical local residue data, every nonzero $\omega$ and every $f \in F$, the
+associated Weil functional vanishes on the diagonal adele of $f$. Then `FunctionFieldRiemannRoch K
+F` holds: for every nonzero $\omega \in \Omega_{F/K}$ and every divisor $D$, $$\ell(D) -
+\ell\big((\omega) - D\big) = \deg D + 1 - g,$$ where $(\omega)$ is the canonical divisor attached to
+$\omega$ and $g$ is `genus K F`, defined as $\lfloor(\deg(\omega)+2)/2\rfloor$ for a chosen nonzero
+differential.
+
+This is the Riemann–Roch theorem for a function field $F$ over an algebraically closed constant
+field $K$, obtained from the residue theorem by the adelic (Weil–Tate) route. It is the form in
+which Riemann–Roch enters the arithmetic of modular curves; it is used by
+[`AlgebraicCurve.functionFieldRiemannRoch_of_isAlgClosed`]
+(thm.html#AlgebraicCurve.functionFieldRiemannRoch_of_isAlgClosed),
+where the residue theorem hypothesis is itself discharged.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_functionFieldRiemannRoch_of_residueTheoremK_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+noncomputable section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+open AlgebraicCurve Divisor Polynomial IsDedekindDomain WithZero IsLocalRing
+  Module Module.IsLocalRing
+
+section
+
+namespace AlgebraicCurve
+
+namespace Divisor
+
+section Pullback
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [Algebra.IsIntegral F F']
+
+
+end Pullback
+
+end Divisor
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+namespace RationalFunctionField
+
+variable (K : Type*) [Field K]
+
+section PlaceInfty
+
+variable [DecidableEq (RatFunc K)]
+
+scoped instance : Nontrivial (MonoidWithZeroHom.valueGroup (MonoidWithZeroHom.ofClass
+  (RatFunc.inftyValuation K))) := by
+  rw [Subgroup.nontrivial_iff_exists_ne_one]
+  refine ⟨Units.mk0 (RatFunc.inftyValuation K RatFunc.X)
+    (by rw [RatFunc.inftyValuation.X]; exact exp_ne_zero), ?_, ?_⟩
+  · exact MonoidWithZeroHom.mem_valueGroup _ ⟨RatFunc.X, rfl⟩
+  · rw [ne_eq, Units.ext_iff, Units.val_mk0, Units.val_one, RatFunc.inftyValuation.X]
+    simp
+
+def placeInfty : Place K (RatFunc K) where
+  toValuationSubring := (RatFunc.inftyValuation K).valuationSubring
+  algebraMap_mem' a := by
+    rw [Valuation.mem_valuationSubring_iff]
+    exact Valuation.IsTrivialOn.valuation_algebraMap_le_one (v := RatFunc.inftyValuation K) a
+  ne_top' := by
+    simp only [ne_eq, Valuation.valuationSubring_eq_top_iff, not_not]
+    infer_instance
+  isPrincipalIdealRing' :=
+    (Valuation.valuationSubring_isDiscreteValuationRing
+      (RatFunc.inftyValuation K)).toIsPrincipalIdealRing
+
+@[scoped simp]
+theorem placeInfty_toValuationSubring :
+    (placeInfty K).toValuationSubring = (RatFunc.inftyValuation K).valuationSubring := rfl
+
+theorem inftyValuation_isEquiv_adicValuation :
+    (RatFunc.inftyValuation K).IsEquiv (placeInfty K).adicValuation :=
+  (placeInfty K).isEquiv_adicValuation_of_valuationSubring_eq rfl
+
+end PlaceInfty
+
+variable {K}
+
+theorem eq_ofHeightOneSpectrum_or_eq_placeInfty [DecidableEq (RatFunc K)]
+    (v : Place K (RatFunc K)) :
+    (∃ w : HeightOneSpectrum K[X], v = Place.ofHeightOneSpectrum w) ∨ v = placeInfty K := by
+  rcases (RatFunc.valuation_isEquiv_infty_or_adic (v := v.adicValuation)).or with h | h
+  · exact Or.inr (Place.ext (v.adicValuation_valuationSubring.symm.trans
+      ((Valuation.isEquiv_iff_valuationSubring _ _).mp h)))
+  · obtain ⟨w, hw, -⟩ := h
+    exact Or.inl ⟨w, Place.ext (v.adicValuation_valuationSubring.symm.trans
+      ((Valuation.isEquiv_iff_valuationSubring _ _).mp hw))⟩
+
+section DegInfty
+
+variable (K) [DecidableEq (RatFunc K)]
+
+theorem exists_sub_algebraMap_intDegree_neg {x : RatFunc K}
+    (hx : RatFunc.inftyValuation K x ≤ 1) :
+    ∃ c : K, x - algebraMap K (RatFunc K) c = 0 ∨
+      (x - algebraMap K (RatFunc K) c).intDegree < 0 := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · exact ⟨0, Or.inl (by simp)⟩
+  have hdeg : x.intDegree ≤ 0 := by
+    rw [RatFunc.inftyValuation_apply, RatFunc.inftyValuation_of_nonzero K hx0,
+      show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_le_exp] at hx
+    exact hx
+  have hnum0 : x.num ≠ 0 := RatFunc.num_ne_zero hx0
+  have hden0 : x.denom ≠ 0 := x.denom_ne_zero
+  rcases lt_or_eq_of_le hdeg with hlt | heq
+  · exact ⟨0, Or.inr (by simpa using hlt)⟩
+  have hndeg : x.num.natDegree = x.denom.natDegree := by
+    have h2 := heq
+    rw [RatFunc.intDegree, sub_eq_zero] at h2
+    exact_mod_cast h2
+  set c : K := x.num.leadingCoeff / x.denom.leadingCoeff with hc
+  have hc0 : c ≠ 0 := by
+    rw [hc]
+    exact div_ne_zero (Polynomial.leadingCoeff_ne_zero.mpr hnum0)
+      (Polynomial.leadingCoeff_ne_zero.mpr hden0)
+  refine ⟨c, ?_⟩
+  have hsub : x - algebraMap K (RatFunc K) c
+      = algebraMap K[X] (RatFunc K) (x.num - Polynomial.C c * x.denom)
+        / algebraMap K[X] (RatFunc K) x.denom := by
+    rw [map_sub, map_mul, sub_div, x.num_div_denom, mul_div_assoc,
+      div_self ((map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hden0),
+      mul_one, IsScalarTower.algebraMap_apply K K[X] (RatFunc K), Polynomial.algebraMap_eq]
+  rcases eq_or_ne (x.num - Polynomial.C c * x.denom) 0 with hzero | hnz
+  · exact Or.inl (by rw [hsub, hzero, _root_.map_zero, zero_div])
+  refine Or.inr ?_
+  rw [hsub, RatFunc.intDegree_div ((map_ne_zero_iff _
+      (IsFractionRing.injective K[X] (RatFunc K))).mpr hnz)
+    ((map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hden0),
+    RatFunc.intDegree_polynomial, RatFunc.intDegree_polynomial, sub_neg]
+  have hCdeg : (Polynomial.C c * x.denom).degree = x.denom.degree := by
+    rw [Polynomial.degree_mul, Polynomial.degree_C hc0, zero_add]
+  have hdegeq : x.num.degree = (Polynomial.C c * x.denom).degree := by
+    rw [hCdeg, Polynomial.degree_eq_natDegree hnum0, Polynomial.degree_eq_natDegree hden0,
+      hndeg]
+  have hlc : x.num.leadingCoeff = (Polynomial.C c * x.denom).leadingCoeff := by
+    rw [Polynomial.leadingCoeff_mul, Polynomial.leadingCoeff_C, hc,
+      div_mul_cancel₀ _ (Polynomial.leadingCoeff_ne_zero.mpr hden0)]
+  have hlt := Polynomial.degree_sub_lt_left hdegeq hnum0 hlc
+  rw [hdegeq, hCdeg] at hlt
+  exact_mod_cast Polynomial.natDegree_lt_natDegree hnz hlt
+
+theorem deg_placeInfty : (placeInfty K).deg = 1 := by
+  have hbij : Function.Bijective (Algebra.ofId K (placeInfty K).ResidueField) := by
+    constructor
+    · exact fun a b h => (algebraMap K ((placeInfty K).ResidueField)).injective h
+    · intro y
+      obtain ⟨⟨x, hx⟩, rfl⟩ := IsLocalRing.residue_surjective y
+      obtain ⟨c, hc⟩ := exists_sub_algebraMap_intDegree_neg K
+        ((Valuation.mem_valuationSubring_iff _ _).mp hx)
+      refine ⟨c, ?_⟩
+      change IsLocalRing.residue _ (algebraMap K (placeInfty K).toValuationSubring c) = _
+      rw [← sub_eq_zero, ← map_sub, IsLocalRing.residue_eq_zero_iff,
+        Place.mem_maximalIdeal_iff_adicValuation_lt_one]
+      change (placeInfty K).adicValuation (algebraMap K (RatFunc K) c - x) < 1
+      rw [← (inftyValuation_isEquiv_adicValuation K).lt_one_iff_lt_one,
+        show algebraMap K (RatFunc K) c - x = -(x - algebraMap K (RatFunc K) c) from
+          (neg_sub _ _).symm, Valuation.map_neg]
+      rcases hc with hc | hc
+      · rw [hc, _root_.map_zero]
+        exact zero_lt_one
+      · rw [RatFunc.inftyValuation_apply, RatFunc.inftyValuationDef]
+        split
+        · exact zero_lt_one
+        · rw [show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_lt_exp]
+          exact hc
+  rw [Place.deg, ← (AlgEquiv.ofBijective _ hbij).toLinearEquiv.finrank_eq,
+    Module.finrank_self]
+
+end DegInfty
+
+end RationalFunctionField
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable (v : Place K F)
+
+private theorem isUnit_mk_of_ord_eq_zero {f : F} (hf : f ≠ 0)
+    (h : v.ord f = 0) :
+    IsUnit (⟨f, v.mem_of_ord_nonneg hf h.ge⟩ : v.toValuationSubring) := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ
+  rw [h, zpow_zero, mul_one] at hu
+  have huf : (⟨f, v.mem_of_ord_nonneg hf h.ge⟩ : v.toValuationSubring)
+      = (u : v.toValuationSubring) := Subtype.ext hu
+  rw [huf]
+  exact u.isUnit
+
+private theorem residue_ne_zero_of_ord_eq_zero {f : F} (hf : f ≠ 0)
+    (h : v.ord f = 0) :
+    residue v.toValuationSubring (⟨f, v.mem_of_ord_nonneg hf h.ge⟩ : v.toValuationSubring)
+      ≠ 0 :=
+  (residue_ne_zero_iff_isUnit _).mpr (v.isUnit_mk_of_ord_eq_zero hf h)
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+section
+
+section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {D E : Divisor K F}
+
+theorem Divisor.degree_nonneg_of_nonneg [IsCurveOver K F]
+    {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) : 0 ≤ Divisor.degree D := by
+  rw [Divisor.degree_eq_sum_support]
+  exact Finset.sum_nonneg fun v _ => mul_nonneg (hD v) (Int.natCast_nonneg _)
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {D E : Divisor K F}
+
+theorem lSpace_eq_bot_of_degree_neg [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) : LSpace D = ⊥ := by
+  rw [eq_bot_iff]
+  intro f hf
+  rw [Submodule.mem_bot]
+  by_contra hf0
+  obtain ⟨P, hPord, hPdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+  have heff : ∀ v : Place K F, 0 ≤ (P + D) v := by
+    intro v
+    rw [Finsupp.add_apply, hPord]
+    rcases mem_lSpace_iff_ord.mp hf with rfl | h
+    · exact absurd rfl hf0
+    · linarith [h v]
+  have hdegPD : 0 ≤ Divisor.degree (P + D) := Divisor.degree_nonneg_of_nonneg heff
+  rw [map_add, hPdeg, zero_add] at hdegPD
+  exact absurd hdegPD (not_le.mpr hD)
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {D E : Divisor K F}
+
+end AlgebraicCurve
+
+end
+
+end
+
+section
+section
+
+namespace AlgebraicCurve
+
+namespace RationalFunctionField
+
+variable (K : Type*) [Field K]
+section PlaceInfty
+variable [DecidableEq (RatFunc K)]
+
+theorem ord_placeInfty_eq_zero_of_intDegree_eq_zero {f : RatFunc K} (hf : f ≠ 0)
+    (h : f.intDegree = 0) : (placeInfty K).ord f = 0 := by
+  rw [(placeInfty K).ord_eq_zero_iff_adicValuation_eq_one hf,
+    ← (inftyValuation_isEquiv_adicValuation K).eq_one_iff_eq_one,
+    RatFunc.inftyValuation_apply, RatFunc.inftyValuation_of_nonzero K hf, h]
+  rfl
+
+end PlaceInfty
+
+end RationalFunctionField
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+namespace RationalFunctionField
+
+variable (K : Type*) [Field K]
+section PlaceInfty
+variable [DecidableEq (RatFunc K)]
+
+theorem ord_placeInfty_eq_intDegree_mul {f : RatFunc K} (hf : f ≠ 0) :
+    (placeInfty K).ord f = f.intDegree * (placeInfty K).ord (RatFunc.X) := by
+  have hinj := IsFractionRing.injective K[X] (RatFunc K)
+  have hpoly : ∀ q : K[X], q ≠ 0 →
+      (placeInfty K).ord (algebraMap K[X] (RatFunc K) q)
+        = (q.natDegree : ℤ) * (placeInfty K).ord (RatFunc.X) := by
+    intro q hq
+    have hq' : algebraMap K[X] (RatFunc K) q ≠ 0 := (map_ne_zero_iff _ hinj).mpr hq
+    have hX : (RatFunc.X : RatFunc K) ≠ 0 := RatFunc.X_ne_zero
+    have hXpow : (RatFunc.X : RatFunc K) ^ q.natDegree ≠ 0 := pow_ne_zero _ hX
+    have hXpoly : (RatFunc.X : RatFunc K) ^ q.natDegree
+        = algebraMap K[X] (RatFunc K) (Polynomial.X ^ q.natDegree) := by
+      rw [map_pow, RatFunc.algebraMap_X]
+    have hdeg : (algebraMap K[X] (RatFunc K) q / RatFunc.X ^ q.natDegree).intDegree = 0 := by
+      rw [RatFunc.intDegree_div hq' hXpow, RatFunc.intDegree_polynomial, hXpoly,
+        RatFunc.intDegree_polynomial, natDegree_X_pow, sub_self]
+    have hne : algebraMap K[X] (RatFunc K) q / RatFunc.X ^ q.natDegree ≠ 0 :=
+      div_ne_zero hq' hXpow
+    have h0 := ord_placeInfty_eq_zero_of_intDegree_eq_zero K hne hdeg
+    have hsplit : algebraMap K[X] (RatFunc K) q
+        = (algebraMap K[X] (RatFunc K) q / RatFunc.X ^ q.natDegree)
+          * RatFunc.X ^ q.natDegree :=
+      (div_mul_cancel₀ _ hXpow).symm
+    rw [hsplit, (placeInfty K).ord_mul hne hXpow, h0, zero_add, ← zpow_natCast,
+      (placeInfty K).ord_zpow]
+  have hnum' : algebraMap K[X] (RatFunc K) f.num ≠ 0 :=
+    (map_ne_zero_iff _ hinj).mpr (RatFunc.num_ne_zero hf)
+  have hden' : algebraMap K[X] (RatFunc K) f.denom ≠ 0 :=
+    (map_ne_zero_iff _ hinj).mpr f.denom_ne_zero
+  rw [show f = algebraMap K[X] (RatFunc K) f.num * (algebraMap K[X] (RatFunc K) f.denom)⁻¹ by
+      rw [← div_eq_mul_inv, f.num_div_denom],
+    (placeInfty K).ord_mul hnum' (inv_ne_zero hden'), (placeInfty K).ord_inv,
+    hpoly _ (RatFunc.num_ne_zero hf), hpoly _ f.denom_ne_zero, ← div_eq_mul_inv,
+    RatFunc.intDegree_div hnum' hden', RatFunc.intDegree_polynomial,
+    RatFunc.intDegree_polynomial]
+  ring
+
+end PlaceInfty
+
+end RationalFunctionField
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+namespace RationalFunctionField
+
+variable (K : Type*) [Field K]
+section PlaceInfty
+variable [DecidableEq (RatFunc K)]
+
+theorem ord_placeInfty_X : (placeInfty K).ord (RatFunc.X : RatFunc K) = -1 := by
+  have hX : (RatFunc.X : RatFunc K) ≠ 0 := RatFunc.X_ne_zero
+  have hneg : (placeInfty K).ord (RatFunc.X : RatFunc K) < 0 := by
+    by_contra h
+    have hmem : (RatFunc.X : RatFunc K) ∈ (placeInfty K).toValuationSubring :=
+      (placeInfty K).mem_of_ord_nonneg hX (not_lt.mp h)
+    rw [placeInfty_toValuationSubring, Valuation.mem_valuationSubring_iff,
+      RatFunc.inftyValuation_apply, RatFunc.inftyValuation_of_nonzero K hX,
+      RatFunc.intDegree_X, show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_le_exp] at hmem
+    omega
+  obtain ⟨π, hπ⟩ :=
+    IsDiscreteValuationRing.exists_irreducible (placeInfty K).toValuationSubring
+  have hπ0 : (π : RatFunc K) ≠ 0 := by
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have hdvd : (placeInfty K).ord (RatFunc.X : RatFunc K) ∣ 1 := by
+    rw [← (placeInfty K).ord_coe_irreducible hπ, ord_placeInfty_eq_intDegree_mul K hπ0]
+    exact Dvd.intro_left _ rfl
+  rcases Int.isUnit_iff.mp (isUnit_of_dvd_one hdvd) with h | h <;> omega
+
+end PlaceInfty
+
+end RationalFunctionField
+
+end AlgebraicCurve
+
+end
+
+end
+
+section
+section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable (v : Place K F)
+
+private theorem mk_mem_maximalIdeal_iff {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    (⟨f, hf⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring
+      ↔ f = 0 ∨ 0 < v.ord f := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  constructor
+  · intro hu
+    rcases eq_or_ne f 0 with rfl | hf0
+    · exact Or.inl rfl
+    · refine Or.inr ?_
+      rcases lt_or_eq_of_le (v.ord_nonneg_of_mem hf) with h | h
+      · exact h
+      · exfalso
+        apply hu
+        rw [← v.adicValuation_coe_eq_one_iff ⟨f, hf⟩]
+        change v.adicValuation f = 1
+        rw [v.adicValuation_eq_exp_neg_ord hf0, ← h, neg_zero, WithZero.exp_zero]
+  · intro h hu
+    have hne : f ≠ 0 := fun h0 => hu.ne_zero (Subtype.ext h0)
+    have h0 : v.ord f = 0 := by
+      obtain ⟨u, hu'⟩ := hu
+      have hcoe : f = ((u : v.toValuationSubring) : F) := by rw [hu']
+      rw [hcoe]; exact v.ord_coe_unit u
+    rcases h with rfl | hpos
+    · exact hne rfl
+    · omega
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem one_le_deg [IsCurveOver K F] (P : Place K F) : 1 ≤ P.deg := by
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  exact Module.finrank_pos
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+def lSpaceShiftEquiv (D : Divisor K F) {g : F} (hg : g ≠ 0)
+    {Dg : Divisor K F} (hDg : ∀ v, Dg v = v.ord g) :
+    LSpace D ≃ₗ[K] LSpace (D + Dg) where
+  toFun h := ⟨(h : F) * g⁻¹, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (h : F) 0 with hh0 | hh0
+    · left; rw [hh0, zero_mul]
+    · right; intro v
+      rw [Finsupp.add_apply, hDg, v.ord_mul hh0 (inv_ne_zero hg), v.ord_inv]
+      have := (mem_lSpace_iff_ord.mp h.2).resolve_left hh0 v
+      linarith⟩
+  invFun k := ⟨(k : F) * g, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (k : F) 0 with hk0 | hk0
+    · left; rw [hk0, zero_mul]
+    · right; intro v
+      have := (mem_lSpace_iff_ord.mp k.2).resolve_left hk0 v
+      rw [Finsupp.add_apply, hDg] at this
+      rw [v.ord_mul hk0 hg]
+      linarith⟩
+  map_add' h₁ h₂ := by apply Subtype.ext; push_cast; ring
+  map_smul' c h := by
+    apply Subtype.ext
+    simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def]
+    ring
+  left_inv h := by
+    apply Subtype.ext
+    change (h : F) * g⁻¹ * g = (h : F)
+    rw [mul_assoc, inv_mul_cancel₀ hg, mul_one]
+  right_inv k := by
+    apply Subtype.ext
+    change (k : F) * g * g⁻¹ = (k : F)
+    rw [mul_assoc, mul_inv_cancel₀ hg, mul_one]
+
+end AlgebraicCurve
+
+end
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+namespace Place
+
+section Uniqueness
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+theorem eq_ord_of_addHom_of_nonneg_iff (φ : F → ℤ)
+    (hmul : ∀ x y, x ≠ 0 → y ≠ 0 → φ (x * y) = φ x + φ y)
+    (hone : ∃ t, t ≠ 0 ∧ φ t = 1)
+    (hiff : ∀ x, x ≠ 0 → (0 ≤ φ x ↔ x ∈ w.toValuationSubring))
+    {x : F} (hx : x ≠ 0) : φ x = w.ord x := by
+  obtain ⟨t, ht0, ht1⟩ := hone
+  have hφ1 : φ 1 = 0 := by
+    have := hmul 1 1 one_ne_zero one_ne_zero
+    rw [mul_one] at this
+    omega
+  have hinv : ∀ y, y ≠ 0 → φ y⁻¹ = -φ y := by
+    intro y hy
+    have h1 : φ (y * y⁻¹) = φ y + φ y⁻¹ := hmul y y⁻¹ hy (inv_ne_zero hy)
+    rw [mul_inv_cancel₀ hy, hφ1] at h1
+    omega
+  have hpow : ∀ (y : F), y ≠ 0 → ∀ m : ℕ, φ (y ^ m) = m * φ y := by
+    intro y hy m
+    induction m with
+    | zero => simpa using hφ1
+    | succ m ih =>
+      rw [pow_succ, hmul _ _ (pow_ne_zero _ hy) hy, ih]
+      push_cast
+      ring
+  have hzpow : ∀ (y : F) (n : ℤ), y ≠ 0 → φ (y ^ n) = n * φ y := by
+    intro y n hy
+    rcases n with m | m
+    · simpa using hpow y hy m
+    · rw [zpow_negSucc, hinv _ (pow_ne_zero _ hy), hpow y hy, Int.negSucc_eq]
+      push_cast
+      ring
+  have hsign : ∀ y, y ≠ 0 → (0 ≤ φ y ↔ 0 ≤ w.ord y) := by
+    intro y hy
+    rw [hiff y hy, w.mem_iff_ord_nonneg hy]
+  have hzero : ∀ y, y ≠ 0 → (φ y = 0 ↔ w.ord y = 0) := by
+    intro y hy
+    have h1 := hsign y hy
+    have h2 := hsign y⁻¹ (inv_ne_zero hy)
+    rw [hinv y hy, w.ord_inv] at h2
+    omega
+  have htord : 0 < w.ord t := by
+    have h1 := (hsign t ht0).mp (by omega)
+    have h2 := (hzero t ht0).not.mp (by omega)
+    omega
+  have hcancel : ∀ y, y ≠ 0 → w.ord y = φ y * w.ord t := by
+    intro y hy
+    have hyt : y * t ^ (-(φ y)) ≠ 0 := mul_ne_zero hy (zpow_ne_zero _ ht0)
+    have h1 : φ (y * t ^ (-(φ y))) = 0 := by
+      rw [hmul _ _ hy (zpow_ne_zero _ ht0), hzpow t _ ht0, ht1]
+      ring
+    have h2 : w.ord (y * t ^ (-(φ y))) = 0 := (hzero _ hyt).mp h1
+    rw [w.ord_mul hy (zpow_ne_zero _ ht0), w.ord_zpow] at h2
+    linarith
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  have hπ0 : (π : F) ≠ 0 := by
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have hπcancel := hcancel (π : F) hπ0
+  rw [w.ord_coe_irreducible hπ] at hπcancel
+  have htord1 : w.ord t = 1 := by
+    have hdvd : w.ord t ∣ 1 := ⟨φ (π : F), by linarith⟩
+    have := Int.le_of_dvd one_pos hdvd
+    omega
+  have := hcancel x hx
+  rw [htord1, mul_one] at this
+  exact this.symm
+
+end Uniqueness
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+attribute [local instance 0] valuationSubringAlgebra
+
+section Setup
+
+variable (v : Place K F)
+
+scoped instance (priority := 100) : IsScalarTower v.toValuationSubring F F' :=
+  IsScalarTower.of_algebraMap_eq fun _ => rfl
+
+end Setup
+
+section ValuationDictionary
+
+variable {v : Place K F} {w : Place K F'}
+
+theorem neg_log_valuation_fiberCenter_eq_ord (hw : w.restrict F = v) {x : F'} (hx : x ≠ 0) :
+    -log ((fiberCenter F' v hw).valuation F' x) = w.ord x := by
+  refine eq_ord_of_addHom_of_nonneg_iff w
+    (fun y => -log ((fiberCenter F' v hw).valuation F' y)) ?_ ?_ ?_ hx
+  · intro a b ha hb
+    show -log ((fiberCenter F' v hw).valuation F' (a * b)) =
+      -log ((fiberCenter F' v hw).valuation F' a) +
+        -log ((fiberCenter F' v hw).valuation F' b)
+    rw [map_mul, log_mul ((Valuation.ne_zero_iff _).mpr ha) ((Valuation.ne_zero_iff _).mpr hb)]
+    ring
+  · obtain ⟨t, ht⟩ := (fiberCenter F' v hw).valuation_exists_uniformizer F'
+    refine ⟨t, ?_, ?_⟩
+    · intro h
+      rw [h, _root_.map_zero] at ht
+      exact exp_ne_zero ht.symm
+    · show -log ((fiberCenter F' v hw).valuation F' t) = 1
+      rw [ht, log_exp]
+      ring
+  · intro y hy
+    have hy0 : (fiberCenter F' v hw).valuation F' y ≠ 0 := (Valuation.ne_zero_iff _).mpr hy
+    change 0 ≤ -log ((fiberCenter F' v hw).valuation F' y) ↔ y ∈ w.toValuationSubring
+    have hmem : y ∈ w.toValuationSubring ↔ (fiberCenter F' v hw).valuation F' y ≤ 1 := by
+      rw [toValuationSubring_eq_of_restrict_eq hw,
+        HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact Iff.rfl
+    rw [hmem]
+    constructor
+    · intro h
+      calc (fiberCenter F' v hw).valuation F' y
+          = exp (log ((fiberCenter F' v hw).valuation F' y)) := (exp_log hy0).symm
+        _ ≤ exp 0 := by rw [exp_le_exp]; omega
+        _ = 1 := exp_zero
+    · intro h
+      have h1 : exp (log ((fiberCenter F' v hw).valuation F' y)) ≤ exp 0 := by
+        rw [exp_log hy0, exp_zero]
+        exact h
+      rw [exp_le_exp] at h1
+      omega
+
+theorem le_ord_iff_mem_pow_fiberCenter (hw : w.restrict F = v)
+    {c : integralClosureAt F' v} (hc : c ≠ 0) (n : ℕ) :
+    (n : ℤ) ≤ w.ord (algebraMap (integralClosureAt F' v) F' c) ↔
+      c ∈ (fiberCenter F' v hw).asIdeal ^ n := by
+  have hcF : algebraMap (integralClosureAt F' v) F' c ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hc
+  rw [← neg_log_valuation_fiberCenter_eq_ord hw hcF,
+    HeightOneSpectrum.valuation_of_algebraMap,
+    ← HeightOneSpectrum.intValuation_le_pow_iff_mem]
+  have h0 : (fiberCenter F' v hw).intValuation c ≠ 0 :=
+    HeightOneSpectrum.intValuation_ne_zero _ c hc
+  constructor
+  · intro h
+    calc (fiberCenter F' v hw).intValuation c
+        = exp (log ((fiberCenter F' v hw).intValuation c)) := (exp_log h0).symm
+      _ ≤ exp (-(n : ℤ)) := by rw [exp_le_exp]; omega
+  · intro h
+    have h1 : exp (log ((fiberCenter F' v hw).intValuation c)) ≤ exp (-(n : ℤ)) := by
+      rw [exp_log h0]
+      exact h
+    rw [exp_le_exp] at h1
+    omega
+
+theorem ramificationIndex_eq_ramificationIdx_fiberCenter (hw : w.restrict F = v) :
+    w.ramificationIndex F =
+      (IsLocalRing.maximalIdeal v.toValuationSubring).ramificationIdx'
+        (fiberCenter F' v hw).asIdeal := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπ0 : π ≠ 0 := hπ.ne_zero
+  have hπC : algebraMap v.toValuationSubring (integralClosureAt F' v) π ≠ 0 :=
+    algebraMap_integralClosureAt_ne_zero hπ0
+  have hmap : (IsLocalRing.maximalIdeal v.toValuationSubring).map
+      (algebraMap v.toValuationSubring (integralClosureAt F' v))
+        = Ideal.span {algebraMap v.toValuationSubring (integralClosureAt F' v) π} := by
+    rw [hπ.maximalIdeal_eq, Ideal.map_span, Set.image_singleton]
+  have hord : w.ord (algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) π))
+        = w.ramificationIndex F := by
+    rw [ord_algebraMap_integralClosureAt hw, ValuationSubring.algebraMap_apply,
+      v.ord_coe_irreducible hπ, mul_one]
+  refine (Ideal.ramificationIdx'_spec ?_ ?_).symm
+  · rw [hmap, Ideal.span_singleton_le_iff_mem,
+      ← le_ord_iff_mem_pow_fiberCenter hw hπC, hord]
+  · rw [hmap, Ideal.span_singleton_le_iff_mem,
+      ← le_ord_iff_mem_pow_fiberCenter hw hπC, hord]
+    have : 0 < w.ramificationIndex F := w.ramificationIndex_pos
+    push_cast
+    omega
+
+end ValuationDictionary
+
+section ResidueDictionary
+
+variable {v : Place K F} {w : Place K F'}
+
+def toValuationSubringOfRestrictEq (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.toValuationSubring :=
+  (algebraMap (integralClosureAt F' v) F').codRestrict
+    w.toValuationSubring.toSubring (forall_mem_of_restrict_eq hw)
+
+def residueOfCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.ResidueField :=
+  (IsLocalRing.residue w.toValuationSubring).comp (toValuationSubringOfRestrictEq hw)
+
+omit [FiniteDimensional F F'] in
+theorem residueOfCenter_apply (hw : w.restrict F = v) (c : integralClosureAt F' v) :
+    residueOfCenter hw c = IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw c) := rfl
+
+theorem ker_residueOfCenter (hw : w.restrict F = v) :
+    RingHom.ker (residueOfCenter hw) = (fiberCenter F' v hw).asIdeal := by
+  ext c
+  rw [RingHom.mem_ker, residueOfCenter_apply, IsLocalRing.residue_eq_zero_iff]
+  exact Iff.rfl
+
+theorem surjective_residueOfCenter (hw : w.restrict F = v) :
+    Function.Surjective (residueOfCenter hw) := by
+  classical
+  intro y
+  obtain ⟨x, rfl⟩ := IsLocalRing.residue_surjective y
+  have hx : (x : F') ∈ HeightOneSpectrum.valuationSubringAtPrime F' (fiberCenter F' v hw) := by
+    rw [← toValuationSubring_eq_of_restrict_eq hw]
+    exact x.2
+  obtain ⟨a, s, hs, hxas⟩ := hx
+  have hsP : s ∉ (fiberCenter F' v hw).asIdeal := hs
+  have hs0 : s ≠ 0 := fun h => hsP (h ▸ (fiberCenter F' v hw).asIdeal.zero_mem)
+  have hsF : algebraMap (integralClosureAt F' v) F' s ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hs0
+  have hsord : w.ord (algebraMap (integralClosureAt F' v) F' s) = 0 := by
+    have h1 : ¬ 0 < w.ord (algebraMap (integralClosureAt F' v) F' s) := by
+      rw [← mem_fiberCenter_iff_ord_pos hw hs0]
+      exact hsP
+    have h2 : 0 ≤ w.ord (algebraMap (integralClosureAt F' v) F' s) :=
+      w.ord_nonneg_of_mem (forall_mem_of_restrict_eq hw s)
+    omega
+  have hmax : (fiberCenter F' v hw).asIdeal.IsMaximal :=
+    (fiberCenter F' v hw).isPrime.isMaximal (fiberCenter F' v hw).ne_bot
+  obtain ⟨t, i, hi, hti⟩ := hmax.exists_inv hsP
+  have hst : s * t - 1 ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : s * t - 1 = -i := by linear_combination hti
+    rw [h1]
+    exact neg_mem hi
+  refine ⟨a * t, ?_⟩
+  rw [residueOfCenter_apply, ← sub_eq_zero, ← map_sub, IsLocalRing.residue_eq_zero_iff]
+  have hcoe : ((toValuationSubringOfRestrictEq hw (a * t) - x : w.toValuationSubring) : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') := rfl
+  rcases eq_or_ne (toValuationSubringOfRestrictEq hw (a * t) - x) 0 with hzero | hne
+  · rw [hzero]
+    exact (IsLocalRing.maximalIdeal w.toValuationSubring).zero_mem
+  have hcoene : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') ≠ 0 := by
+    intro h
+    exact hne (by rwa [← hcoe, ZeroMemClass.coe_eq_zero] at h)
+  have hfactor : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t * s - a)
+          * (algebraMap (integralClosureAt F' v) F' s)⁻¹ := by
+    rw [hxas, map_sub, map_mul (algebraMap (integralClosureAt F' v) F') (a * t) s,
+      sub_mul, mul_assoc, mul_inv_cancel₀ hsF, mul_one]
+  have hdiffC : a * t * s - a ≠ 0 := by
+    intro h
+    apply hcoene
+    rw [hfactor, h, _root_.map_zero, zero_mul]
+  have hdiffP : a * t * s - a ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : a * t * s - a = a * (s * t - 1) := by ring
+    rw [h1]
+    exact Ideal.mul_mem_left _ _ hst
+  have hmem' : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      ∈ w.toValuationSubring := by
+    rw [← hcoe]
+    exact Subtype.coe_prop _
+  rw [show (toValuationSubringOfRestrictEq hw (a * t) - x)
+      = (⟨_, hmem'⟩ : w.toValuationSubring) from Subtype.ext hcoe,
+    w.mem_maximalIdeal_iff_ord_pos hcoene hmem']
+  rw [hfactor, w.ord_mul (by
+      simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hdiffC)
+    (inv_ne_zero hsF), w.ord_inv, hsord, _root_.neg_zero, add_zero]
+  exact (mem_fiberCenter_iff_ord_pos hw hdiffC).mp hdiffP
+
+def residueFieldEquivQuotientCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v ⧸ (fiberCenter F' v hw).asIdeal ≃+* w.ResidueField :=
+  (Ideal.quotEquivOfEq (ker_residueOfCenter hw).symm).trans
+    ((residueOfCenter hw).quotientKerEquivOfSurjective (surjective_residueOfCenter hw))
+
+def placeCongrEquiv {u u' : Place K F} (h : u = u') :
+    u.toValuationSubring ≃+* u'.toValuationSubring where
+  toFun x := ⟨x.1, h ▸ x.2⟩
+  invFun x := ⟨x.1, h.symm ▸ x.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  map_mul' _ _ := rfl
+  map_add' _ _ := rfl
+
+def restrictResidueFieldEquiv (hw : w.restrict F = v) :
+    (w.restrict F).ResidueField ≃+* IsLocalRing.ResidueField v.toValuationSubring :=
+  IsLocalRing.ResidueField.mapEquiv (placeCongrEquiv hw)
+
+theorem inertiaDeg_eq_inertiaDeg_fiberCenter (hw : w.restrict F = v) :
+    w.inertiaDeg F =
+      (fiberCenter F' v hw).asIdeal.inertiaDeg v.toValuationSubring := by
+  have := fiberCenter_liesOver hw
+  rw [Ideal.inertiaDeg_eq_of_isMaximal (IsLocalRing.maximalIdeal v.toValuationSubring)
+    (fiberCenter F' v hw).asIdeal]
+  change Module.finrank (w.restrict F).ResidueField w.ResidueField = _
+  refine Algebra.finrank_eq_of_equiv_equiv (restrictResidueFieldEquiv hw)
+    (residueFieldEquivQuotientCenter hw).symm ?_
+  ext a
+  obtain ⟨a, rfl⟩ := IsLocalRing.residue_surjective a
+  simp only [RingHom.coe_comp, Function.comp_apply, RingEquiv.toRingHom_eq_coe,
+    RingHom.coe_coe]
+  apply (residueFieldEquivQuotientCenter hw).injective
+  rw [RingEquiv.apply_symm_apply]
+  change IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw
+        (algebraMap v.toValuationSubring (integralClosureAt F' v) (placeCongrEquiv hw a)))
+    = IsLocalRing.residue w.toValuationSubring (restrictInclusion F w a)
+  refine congrArg _ (Subtype.ext ?_)
+  change algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) (placeCongrEquiv hw a))
+    = algebraMap F F' (a : F)
+  rw [← IsScalarTower.algebraMap_apply,
+    IsScalarTower.algebraMap_apply v.toValuationSubring F F']
+  rfl
+
+end ResidueDictionary
+
+section Assembly
+
+variable (v : Place K F)
+
+theorem sum_ramificationIndex_mul_inertiaDeg [HasPrincipalDivisors K F'] :
+    ∑ w ∈ v.fiber F', (w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ)
+      = (Module.finrank F F' : ℤ) := by
+  classical
+  have hkey := sum_ramificationIdx'_mul_inertiaDeg'_integralClosureAt (F' := F') v
+  rw [← hkey]
+  push_cast
+  refine Finset.sum_bij
+    (fun w hw => (fiberCenter F' v (Place.mem_fiber.mp hw)).asIdeal) ?_ ?_ ?_ ?_
+  · intro w hw
+    rw [IsDedekindDomain.mem_primesOverFinset_iff (maximalIdeal_ne_bot v)]
+    exact ⟨(fiberCenter F' v (Place.mem_fiber.mp hw)).isPrime,
+      fiberCenter_liesOver (Place.mem_fiber.mp hw)⟩
+  · intro w hw w' hw' h
+    exact eq_of_fiberCenter_eq (Place.mem_fiber.mp hw) (Place.mem_fiber.mp hw')
+      (HeightOneSpectrum.ext h)
+  · intro P hP
+    rw [IsDedekindDomain.mem_primesOverFinset_iff (maximalIdeal_ne_bot v)] at hP
+    obtain ⟨hP1, hP2⟩ := hP
+    have hPne : P ≠ ⊥ := by
+      intro h
+      apply maximalIdeal_ne_bot v
+      have h2 := hP2.over
+      rw [h, Ideal.under_def, Ideal.comap_bot_of_injective _
+        (algebraMap_integralClosureAt_injective v)] at h2
+      exact h2
+    refine ⟨placeOfPrime ⟨P, hP1, hPne⟩,
+      Place.mem_fiber.mpr (restrict_placeOfPrime ⟨P, hP1, hPne⟩), ?_⟩
+    exact congrArg HeightOneSpectrum.asIdeal
+      (fiberCenter_placeOfPrime (⟨P, hP1, hPne⟩ :
+        HeightOneSpectrum (integralClosureAt F' v)))
+  · intro w hw
+    rw [ramificationIndex_eq_ramificationIdx_fiberCenter (Place.mem_fiber.mp hw),
+      inertiaDeg_eq_inertiaDeg_fiberCenter (Place.mem_fiber.mp hw)]
+
+end Assembly
+
+end Place
+
+scoped instance instSumRamificationInertia {K F F' : Type*} [Field K] [Field F] [Field F']
+    [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+    [FiniteDimensional F F'] [Algebra.IsSeparable F F'] [HasPrincipalDivisors K F'] :
+    SumRamificationInertia K F F' :=
+  ⟨fun v => Place.sum_ramificationIndex_mul_inertiaDeg v⟩
+
+end AlgebraicCurve
+
+end
+
+section
+section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable [HasPrincipalDivisors K F]
+
+theorem eq_algebraMap_of_forall_ord_nonneg (v₀ : Place K F) (hrat : v₀.IsRational)
+    (hdeg : v₀.deg ≠ 0) {g : F} (hg : g ≠ 0) (hord : ∀ v : Place K F, 0 ≤ v.ord g) :
+    ∃ c : K, g = algebraMap K F c := by
+  have hg₀ : g ∈ v₀.toValuationSubring := v₀.mem_of_ord_nonneg hg (hord v₀)
+  refine ⟨v₀.evalAt g, ?_⟩
+  by_contra hne
+  set t : F := g - algebraMap K F (v₀.evalAt g) with ht
+  have htne : t ≠ 0 := sub_ne_zero.mpr hne
+  have hzero : 0 < v₀.ord t := v₀.ord_sub_evalAt_pos hrat hg₀ htne
+  have hpole : ∀ v : Place K F, 0 ≤ v.ord t := fun v =>
+    v.ord_nonneg_of_mem (sub_mem (v.mem_of_ord_nonneg hg (hord v)) (v.algebraMap_mem' _))
+  obtain ⟨D, hD, hdeg0⟩ := HasPrincipalDivisors.exists_divisor (K := K) t htne
+  have hDpos : 0 < D v₀ := by rw [hD v₀]; exact hzero
+  have hDnonneg : ∀ v, 0 ≤ D v := fun v => by rw [hD v]; exact hpole v
+  have hmem : v₀ ∈ D.support := Finsupp.mem_support_iff.mpr hDpos.ne'
+  have hpos : 0 < Divisor.degree D := by
+    rw [Divisor.degree_eq_sum_support]
+    calc (0 : ℤ) < D v₀ * (v₀.deg : ℤ) :=
+          mul_pos hDpos (by exact_mod_cast Nat.pos_of_ne_zero hdeg)
+      _ ≤ ∑ v ∈ D.support, D v * (v.deg : ℤ) :=
+          Finset.single_le_sum
+            (fun v _ => mul_nonneg (hDnonneg v) (Int.natCast_nonneg _)) hmem
+  omega
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem constantsAreBase_of_exists_isRational [HasPrincipalDivisors K F]
+    (v₀ : Place K F) (hrat : v₀.IsRational) (hdeg : v₀.deg ≠ 0) :
+    ConstantsAreBase K F := by
+  refine le_antisymm (fun f hf => ?_) (fun f ⟨c, hc⟩ => hc ▸ algebraMap_mem_lSpace_zero c)
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact zero_mem _
+  · have hord : ∀ v : Place K F, 0 ≤ v.ord f := by
+      have h := (mem_lSpace_iff_ord.mp hf).resolve_left hf0
+      simpa using h
+    obtain ⟨c, hc⟩ := Place.eq_algebraMap_of_forall_ord_nonneg v₀ hrat hdeg hf0 hord
+    exact ⟨c, hc.symm⟩
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem constantsAreBase_of_deg_eq_one [HasPrincipalDivisors K F]
+    (v₀ : Place K F) (hdeg : v₀.deg = 1) :
+    ConstantsAreBase K F :=
+  constantsAreBase_of_exists_isRational v₀ (v₀.isRational_of_deg_eq_one hdeg)
+    (hdeg ▸ one_ne_zero)
+
+end AlgebraicCurve
+
+end
+
+end
+
+section
+
+namespace Submodule
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+def nestedComapMapMkQEquiv {A B C : Submodule K X} (_hAB : A ≤ B) (hBC : B ≤ C) :
+    ((B.comap C.subtype).map (A.comap C.subtype).mkQ : Submodule K _)
+      ≃ₗ[K] B ⧸ A.comap B.subtype := by
+  set S := A.comap C.subtype with hS
+  set T := B.comap C.subtype with hT
+  let ψ : (T : Type _) →ₗ[K] (C ⧸ S) := S.mkQ ∘ₗ T.subtype
+  have hker : LinearMap.ker ψ = S.comap T.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = T.map S.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let e1 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (T.map S.mkQ : Submodule K _) :=
+    (Submodule.Quotient.equiv _ (LinearMap.ker ψ) (LinearEquiv.refl K T)
+        (by rw [hker]; simp)).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have hmap : (S.comap T.subtype).map
+      (Submodule.comapSubtypeEquivOfLe hBC : (T : Type _) →ₗ[K] B) = A.comap B.subtype := by
+    ext ⟨b, hb⟩
+    simp only [mem_map, mem_comap, Submodule.coe_subtype, hS]
+    constructor
+    · rintro ⟨⟨⟨x, hxC⟩, hxB⟩, hxA, hxeq⟩
+      have hx : x = b := congrArg Subtype.val hxeq
+      subst hx; exact hxA
+    · intro hbA
+      exact ⟨⟨⟨b, hBC hb⟩, hb⟩, hbA, rfl⟩
+  let e2 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (B ⧸ A.comap B.subtype) :=
+    Submodule.Quotient.equiv _ _ (Submodule.comapSubtypeEquivOfLe hBC) hmap
+  exact e1.symm.trans e2
+
+theorem finrank_quotient_chain {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCB : Module.Finite K (C ⧸ B.comap C.subtype)]
+    [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (C ⧸ A.comap C.subtype) ∧
+      finrank K (C ⧸ A.comap C.subtype)
+        = finrank K (C ⧸ B.comap C.subtype) + finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (T.map S.mkQ : Submodule K _) := Module.Finite.equiv eK.symm
+  have : Module.Finite K ((C ⧸ S) ⧸ T.map S.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (C ⧸ S) := Module.Finite.of_submodule_quotient (T.map S.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+def adeleBddQuotSingleEquivResidueField (D : Divisor K F) (P : Place K F) :
+    (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+      ≃ₗ[K] P.ResidueField := by
+  classical
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  let π : P.toValuationSubring :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose
+  have hπ : Irreducible π :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose_spec
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := fun {g} hg => by
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ α : Place K F → F, α ∈ adeleBdd D → t ^ (D P) * α P ∈ P.toValuationSubring := by
+    intro α hα
+    rcases eq_or_ne (α P) 0 with hg0 | hg0
+    · simp [hg0]
+    · refine P.mem_of_ord_nonneg (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have h := hα P
+      rw [P.adicValuation_eq_exp_neg_ord hg0, WithZero.exp_le_exp] at h
+      linarith
+  let ψ : adeleBdd D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun α => ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩
+      map_add' := by
+        intro α β; apply Subtype.ext
+        simp only [Submodule.coe_add, Pi.add_apply]
+        push_cast; ring
+      map_smul' := by
+        intro c α; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap, Pi.smul_apply]
+        ring }
+  have hψ_apply : ∀ α : adeleBdd D,
+      (ψ α : F) = t ^ (D P) * (α : Place K F → F) P := fun α => rfl
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : adeleBdd D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ α : adeleBdd D, φ α = 0 ↔
+      (⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := fun α => by
+    rw [show φ α = IsLocalRing.residue P.toValuationSubring
+            ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ from hres (ψ α),
+      IsLocalRing.residue_eq_zero_iff]
+  have hker : LinearMap.ker φ = (adeleBdd E).comap (adeleBdd D).subtype := by
+    ext α
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi α, P.mk_mem_maximalIdeal_iff, mem_adeleBdd]
+    have hαD := α.2
+    constructor
+    · rintro (h | h) v
+      · have hα0 : (α : Place K F → F) P = 0 := by
+          rcases mul_eq_zero.mp h with h' | h'
+          · exact absurd h' htn0
+          · exact h'
+        by_cases hv : v = P
+        · subst v; rw [hα0, Valuation.map_zero]; exact zero_le
+        · rw [hEv v hv]; exact hαD v
+      · by_cases hv : v = P
+        · subst v
+          rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+          · rw [hα0, Valuation.map_zero]; exact zero_le
+          · rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP]
+            rw [hordmul hα0] at h; omega
+        · rw [hEv v hv]; exact hαD v
+    · intro h
+      rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+      · left; rw [hα0, mul_zero]
+      · right
+        have hP := h P
+        rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP] at hP
+        rw [hordmul hα0]; omega
+  have hsurj : Function.Surjective φ := by
+    intro c
+    obtain ⟨cl, hcl⟩ := IsLocalRing.residue_surjective (R := P.toValuationSubring) c
+    set f : F := (cl : F) * t ^ (-(D P)) with hf
+    have hαD : Pi.single P f ∈ adeleBdd D := by
+      intro v
+      by_cases hv : v = P
+      · subst v
+        simp only [Pi.single_eq_same]
+        rcases eq_or_ne (cl : F) 0 with hc0 | hc0
+        · rw [hf, hc0, zero_mul, Valuation.map_zero]; exact zero_le
+        · have hf0 : f ≠ 0 := by rw [hf]; exact mul_ne_zero hc0 (zpow_ne_zero _ ht0)
+          rw [P.adicValuation_eq_exp_neg_ord hf0, WithZero.exp_le_exp]
+          rw [hf, P.ord_mul hc0 (zpow_ne_zero _ ht0), P.ord_zpow, ht1, mul_one]
+          have hclnn := P.ord_nonneg_of_mem cl.2
+          linarith
+      · rw [Pi.single_eq_of_ne hv, Valuation.map_zero]; exact zero_le
+    refine ⟨⟨Pi.single P f, hαD⟩, ?_⟩
+    change res (ψ ⟨Pi.single P f, hαD⟩) = c
+    rw [hres]
+    rw [show (ψ ⟨Pi.single P f, hαD⟩ : P.toValuationSubring) = cl from ?_, hcl]
+    apply Subtype.ext
+    rw [hψ_apply]
+    change t ^ (D P) * (Pi.single P f : Place K F → F) P = (cl : F)
+    rw [show (Pi.single P f : Place K F → F) P = f from Pi.single_eq_same _ _, hf,
+      mul_comm (cl : F), ← mul_assoc, ← zpow_add₀ ht0, add_neg_cancel, zpow_zero, one_mul]
+  exact (Submodule.Quotient.equiv _ _ (LinearEquiv.refl K _) (by rw [← hker]; simp)).trans
+    (φ.quotKerEquivOfSurjective hsurj)
+
+theorem finrank_adeleBdd_quotient_single [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    Module.Finite K
+        (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype) ∧
+      finrank K
+          (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+        = P.deg := by
+  have := IsCurveOver.finite_residueField (K := K) P
+  exact ⟨Module.Finite.equiv (adeleBddQuotSingleEquivResidueField D P).symm,
+    (adeleBddQuotSingleEquivResidueField D P).finrank_eq⟩
+
+theorem finrank_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+      (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+        = Divisor.degree D₂ - Divisor.degree D₁ := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D₁ D₂ : Divisor K F, D₁ ≤ D₂ →
+      (Divisor.degree (D₂ - D₁)).toNat = m →
+      Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+        (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+          = Divisor.degree D₂ - Divisor.degree D₁ from
+    H _ D₁ D₂ hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D₁ D₂ hD hm
+    have hEeff : ∀ v, 0 ≤ (D₂ - D₁) v := fun v => by
+      rw [Finsupp.sub_apply]; have := hD v; omega
+    by_cases hD0 : D₂ - D₁ = 0
+    · have hD12 : D₁ = D₂ := (sub_eq_zero.mp hD0).symm
+      subst hD12
+      rw [Submodule.comap_subtype_self]
+      have : Subsingleton (adeleBdd D₁ ⧸ (⊤ : Submodule K (adeleBdd D₁))) :=
+        Submodule.Quotient.subsingleton_iff.mpr rfl
+      exact ⟨Module.Finite.of_finite, by simp [Module.finrank_zero_of_subsingleton]⟩
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ (D₂ - D₁) P := by
+        have hne : (D₂ - D₁) P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hEeff P; omega
+      set D₂' : Divisor K F := D₂ - Finsupp.single P 1 with hD₂'
+      have h12' : D₁ ≤ D₂' := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]
+          have := hPpos; rw [Finsupp.sub_apply] at this; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have h2'2 : D₂' ≤ D₂ := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]
+      have hdegD₂' : Divisor.degree D₂' = Divisor.degree D₂ - P.deg := by
+        rw [hD₂', map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hEnn : 0 ≤ Divisor.degree (D₂ - D₁) := Divisor.degree_nonneg_of_nonneg hEeff
+      have hE'nn : 0 ≤ Divisor.degree (D₂' - D₁) := Divisor.degree_nonneg_of_nonneg
+        (fun v => by rw [Finsupp.sub_apply]; have := h12' v; omega)
+      have hdegdiff : Divisor.degree (D₂' - D₁) = Divisor.degree (D₂ - D₁) - P.deg := by
+        simp only [hD₂', map_sub, Divisor.degree_single, one_mul]; ring
+      have hmlt : (Divisor.degree (D₂' - D₁)).toNat < m := by rw [← hm]; omega
+      obtain ⟨hfin', hrank'⟩ := IH _ hmlt D₁ D₂' h12' rfl
+      obtain ⟨hfinS, hrankS⟩ := finrank_adeleBdd_quotient_single (K := K) D₂ P
+      rw [← hD₂'] at hfinS hrankS
+      have := hfin'; have := hfinS
+      obtain ⟨hfin, hrank⟩ := Submodule.finrank_quotient_chain
+        (A := adeleBdd D₁) (B := adeleBdd D₂') (C := adeleBdd D₂)
+        (adeleBdd_mono h12') (adeleBdd_mono h2'2)
+      refine ⟨hfin, ?_⟩
+      rw [hrank, hrankS]
+      push_cast
+      linarith [hrank', hdegD₂']
+
+theorem module_finite_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  (finrank_adeleBdd_quotient hD).1
+
+theorem finrank_adeleBdd_quotient_eq [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+      = Divisor.degree D₂ - Divisor.degree D₁ :=
+  (finrank_adeleBdd_quotient hD).2
+
+def lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (_hD : D₁ ≤ D₂) :
+    (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      →ₗ[K] (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  Submodule.mapQ _ _
+    ((diagonalHom K F).restrict
+      (p := (LSpace D₂ : Submodule K F)) (q := (adeleBdd D₂ : Submodule K _))
+      (fun f hf => diagonal_mem_adeleBdd_iff.mpr hf))
+    (fun f hf => by
+      simp only [Submodule.mem_comap, Submodule.coe_subtype] at hf ⊢
+      exact diagonal_mem_adeleBdd_iff.mpr hf)
+
+theorem lSpaceQuotientToAdeleBddQuotient_injective {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Function.Injective (lSpaceQuotientToAdeleBddQuotient hD) := by
+  rw [injective_iff_map_eq_zero]
+  intro x hx
+  obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+  rw [Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype]
+  rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk f)
+        = Submodule.Quotient.mk ((diagonalHom K F).restrict
+            (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f) from rfl,
+    Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype] at hx
+  exact diagonal_mem_adeleBdd_iff.mp hx
+
+theorem ell_sub_ell_le_degree_sub_degree [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)] :
+    (ell D₂ : ℤ) - (ell D₁ : ℤ) ≤ Divisor.degree D₂ - Divisor.degree D₁ := by
+  have := module_finite_adeleBdd_quotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    rw [hℓ₁]; exact (Submodule.finrank_quotient_add_finrank _).symm
+  have hemb : finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      ≤ finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+    LinearMap.finrank_le_finrank_of_injective (lSpaceQuotientToAdeleBddQuotient_injective hD)
+  have hloc := finrank_adeleBdd_quotient_eq hD
+  have : (ell D₂ : ℤ) - (ell D₁ : ℤ)
+      = (finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) : ℤ) := by
+    rw [hL]; push_cast; ring
+  rw [this, ← hloc]
+  exact_mod_cast hemb
+
+theorem adeleBdd_inf_sup_globalSub {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F)
+      = adeleBdd D₁ ⊔ adeleBdd D₂ ⊓ globalSub K F := by
+  rw [inf_comm, sup_inf_assoc_of_le _ (adeleBdd_mono hD), inf_comm]
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable (K F)
+
+theorem weilDualityAdelic_of_residueRows (hΩℓ : WeilOmegaEllAgrees K F) :
+    WeilDualityAdelic K F := by
+  intro _ _ _ ω hω D
+  rw [← finrank_omegaSpace_eq_indexOfSpecialty]
+  exact hΩℓ hω D
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace Submodule
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+theorem comap_subtype_sup_of_le_of_le {S T C : Submodule K X} (hS : S ≤ C) (hT : T ≤ C) :
+    S.comap C.subtype ⊔ T.comap C.subtype = (S ⊔ T).comap C.subtype := by
+  apply Submodule.map_injective_of_injective (f := C.subtype) C.subtype_injective
+  rw [Submodule.map_sup, Submodule.map_comap_subtype, Submodule.map_comap_subtype,
+    Submodule.map_comap_subtype, inf_eq_right.mpr hS, inf_eq_right.mpr hT,
+    inf_eq_right.mpr (sup_le hS hT)]
+
+end Submodule
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem globalSub_le_adeleSpace [HasPrincipalDivisors K F] :
+    globalSub K F ≤ adeleSpace K F := by
+  rintro _ ⟨f, rfl⟩
+  exact diagonal_mem_adeleSpace f
+
+theorem adeleBdd_sup_globalSub_le_adeleSpace [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+  sup_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_eq_comap [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBddPrincipal K F D = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype :=
+  Submodule.comap_subtype_sup_of_le_of_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+section FiniteLSpace
+
+variable [IsCurveOver K F]
+
+theorem finiteDimensional_lSpace [hL0 : FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (D : Divisor K F) : FiniteDimensional K (LSpace D) := by
+  have h0D : (0 : Divisor K F) ≤ D ⊔ 0 := le_sup_right
+  have hDD : D ≤ D ⊔ 0 := le_sup_left
+  suffices h : FiniteDimensional K (LSpace (D ⊔ 0)) by
+    exact Module.Finite.of_injective (Submodule.inclusion (lSpace_mono hDD))
+      (Submodule.inclusion_injective _)
+  have := module_finite_adeleBdd_quotient (K := K) h0D
+  have hfinQ : FiniteDimensional K
+      (LSpace (D ⊔ 0) ⧸ (LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype) :=
+    Module.Finite.of_injective _ (lSpaceQuotientToAdeleBddQuotient_injective h0D)
+  have : FiniteDimensional K
+      ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype : Submodule K _) :=
+    Module.Finite.equiv (Submodule.comapSubtypeEquivOfLe (lSpace_mono h0D)).symm
+  exact Module.Finite.of_submodule_quotient
+    ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype)
+
+end FiniteLSpace
+
+theorem range_lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD)
+      = ((adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype).map
+          ((adeleBdd D₁).comap (adeleBdd D₂).subtype).mkQ := by
+  classical
+  ext z
+  obtain ⟨α, rfl⟩ := Submodule.Quotient.mk_surjective _ z
+  simp only [LinearMap.mem_range, Submodule.mem_map, Submodule.mem_comap, Submodule.coe_subtype,
+    Submodule.mkQ_apply]
+  constructor
+  · rintro ⟨x, hx⟩
+    obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+    have hxeq : Submodule.Quotient.mk
+        ((diagonalHom K F).restrict (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f)
+        = (Submodule.Quotient.mk α :
+            adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) := hx
+    refine ⟨α, ?_, rfl⟩
+    have hdiag2 : (diagonalHom K F (f : F)) ∈ adeleBdd D₂ := diagonal_mem_adeleBdd_iff.mpr f.2
+    have hsub : (α : Place K F → F) - diagonalHom K F (f : F) ∈ adeleBdd D₁ := by
+      have hq := (Submodule.Quotient.eq _).mp hxeq.symm
+      simpa using hq
+    refine Submodule.mem_sup.mpr ⟨(α : Place K F → F) - diagonalHom K F (f : F), hsub,
+      diagonalHom K F (f : F), diagonal_mem_globalSub _, ?_⟩
+    abel
+  · rintro ⟨β, hβ, hβeq⟩
+    have hβ' : (β : Place K F → F) ∈ adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F) :=
+      Submodule.mem_inf.mpr ⟨β.2, hβ⟩
+    rw [adeleBdd_inf_sup_globalSub hD, ← map_diagonal_lSpace] at hβ'
+    obtain ⟨γ, hγ, δ, ⟨f, hf, hfδ⟩, hsum⟩ := Submodule.mem_sup.mp hβ'
+    refine ⟨Submodule.Quotient.mk ⟨f, hf⟩, ?_⟩
+    rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk ⟨f, hf⟩)
+          = Submodule.Quotient.mk ((diagonalHom K F).restrict
+              (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) ⟨f, hf⟩) from rfl,
+      ← hβeq, Submodule.Quotient.eq]
+    refine Submodule.mem_comap.mpr ?_
+    change diagonalHom K F f - (β : Place K F → F) ∈ adeleBdd D₁
+    have hβsub : diagonalHom K F f - (β : Place K F → F) = -γ := by
+      rw [← hsum, hfδ]; ring
+    rw [hβsub]; exact (adeleBdd D₁).neg_mem hγ
+
+theorem finrank_adeleBddSup_quotient [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) [hL : FiniteDimensional K (LSpace D₂)] :
+    Module.Finite K (↥(adeleBdd D₂ ⊔ globalSub K F)
+        ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) ∧
+      (finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+          ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) : ℤ)
+        = (Divisor.degree D₂ - ell D₂) - (Divisor.degree D₁ - ell D₁) := by
+  classical
+  let A : Submodule K (adeleBdd D₂) := (adeleBdd D₁).comap (adeleBdd D₂).subtype
+  let B : Submodule K (adeleBdd D₂) :=
+    (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype
+  have hAB : A ≤ B := Submodule.comap_mono le_sup_left
+  have hfinA : Module.Finite K (adeleBdd D₂ ⧸ A) := module_finite_adeleBdd_quotient hD
+  have hdimA : (finrank K (adeleBdd D₂ ⧸ A) : ℤ) = Divisor.degree D₂ - Divisor.degree D₁ :=
+    finrank_adeleBdd_quotient_eq hD
+  have hran : LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD) = B.map A.mkQ :=
+    range_lSpaceQuotientToAdeleBddQuotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hdimL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K)
+      ((LSpace D₁).comap (LSpace D₂).subtype)
+    rw [← hℓ₁] at h; exact h.symm
+  have hdimB : ell D₂ = finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) + ell D₁ := by
+    rw [← hran, LinearMap.finrank_range_of_inj
+      (lSpaceQuotientToAdeleBddQuotient_injective hD)]
+    exact hdimL
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  have hfinB : Module.Finite K (adeleBdd D₂ ⧸ B) := Module.Finite.equiv e3
+  have hdim2 : finrank K (adeleBdd D₂ ⧸ A)
+      = finrank K (adeleBdd D₂ ⧸ B) + finrank K (B.map A.mkQ : Submodule K _) := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K) (M := adeleBdd D₂ ⧸ A)
+      (B.map A.mkQ)
+    rw [LinearEquiv.finrank_eq e3] at h; omega
+  have e2 := LinearMap.quotientInfEquivSupQuotient (R := K)
+    (adeleBdd D₂) (adeleBdd D₁ ⊔ globalSub K F)
+  have hsup : adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F) = adeleBdd D₂ ⊔ globalSub K F := by
+    rw [← sup_assoc, sup_eq_left.mpr (adeleBdd_mono hD)]
+  have hB' : (adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype = B := by
+    rw [Submodule.comap_subtype_self, top_inf_eq]
+  let eL : (adeleBdd D₂ ⧸ B) ≃ₗ[K]
+      (adeleBdd D₂ ⧸ ((adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+        (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype)) :=
+    Submodule.quotEquivOfEq _ _ hB'.symm
+  have hfin_iso : Module.Finite K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype) :=
+    Module.Finite.equiv (eL.trans e2)
+  have hdim_iso : finrank K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype)
+      = finrank K (adeleBdd D₂ ⧸ B) :=
+    (LinearEquiv.finrank_eq (eL.trans e2)).symm
+  have hcast : (finrank K (adeleBdd D₂ ⧸ A) : ℤ)
+      = (finrank K (adeleBdd D₂ ⧸ B) : ℤ) + ((ell D₂ : ℤ) - (ell D₁ : ℤ)) := by
+    have hb : (ell D₂ : ℤ)
+        = (finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) : ℤ) + (ell D₁ : ℤ) := by
+      exact_mod_cast hdimB
+    push_cast [hdim2]; linarith
+  have hgoal : (finrank K (adeleBdd D₂ ⧸ B) : ℤ)
+      = Divisor.degree D₂ - ↑(ell D₂) - (Divisor.degree D₁ - ↑(ell D₁)) := by
+    linarith [hdimA, hcast]
+  clear_value eL
+  exact hsup ▸ ⟨hfin_iso, by rw [hdim_iso]; exact hgoal⟩
+
+section Index
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+
+theorem adeleBddSup_eq_of_degree_sub_ell_eq {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)]
+    (heq : Divisor.degree D₂ - ell D₂ = Divisor.degree D₁ - ell D₁) :
+    adeleBdd D₂ ⊔ globalSub K F = adeleBdd D₁ ⊔ globalSub K F := by
+  obtain ⟨hfin, hdim⟩ := finrank_adeleBddSup_quotient hD
+  rw [heq, sub_self] at hdim
+  refine le_antisymm ?_ (sup_le_sup_right (adeleBdd_mono hD) _)
+  have := hfin
+  have hd0 : finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) = 0 := by
+    exact_mod_cast hdim
+  have hsub : Subsingleton (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) :=
+    Module.finrank_zero_iff.mp hd0
+  have htop := Submodule.Quotient.subsingleton_iff.mp hsub
+  intro x hx
+  have hxc : (⟨x, hx⟩ : ↥(adeleBdd D₂ ⊔ globalSub K F)) ∈
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype := by
+    rw [htop]; exact Submodule.mem_top
+  exact hxc
+
+end Index
+
+namespace RiemannGenusReachedAt
+
+private theorem eq_of_ge [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {D : Divisor K F} (hD : D₀ ≤ D) :
+    Divisor.degree D - ell D = γ - 1 := by
+  have := finiteDimensional_lSpace (K := K) D
+  have hge : Divisor.degree D₀ - (ell D₀ : ℤ) ≤ Divisor.degree D - ell D := by
+    have := ell_sub_ell_le_degree_sub_degree (K := K) hD
+    linarith
+  exact le_antisymm (h.isMax D) (h.eq ▸ hge)
+
+end RiemannGenusReachedAt
+
+theorem adeleSpace_eq_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    adeleSpace K F = adeleBdd D₀ ⊔ globalSub K F := by
+  refine le_antisymm ?_ (adeleBdd_sup_globalSub_le_adeleSpace D₀)
+  rw [adeleSpace, iSup_le_iff]
+  intro D
+  refine le_trans (adeleBdd_mono (le_sup_left : D ≤ D ⊔ D₀)) ?_
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have heq : Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) = Divisor.degree D₀ - ell D₀ :=
+    (h.eq_of_ge le_sup_right).trans h.eq.symm
+  have hsup := adeleBddSup_eq_of_degree_sub_ell_eq (K := K)
+    (le_sup_right : D₀ ≤ D ⊔ D₀) heq
+  rw [← hsup]
+  exact le_sup_left
+
+
+theorem riemannIndexFormula_of_genusReached
+    (hg : ∀ [IsCurveOver K F] [HasCanonicalDivisor (K := K) (F := F)],
+      RiemannGenusReached K F (genus K F)) :
+    RiemannIndexFormula K F := by
+  intro _ _ D
+  obtain ⟨hne, hL0, D₀, hD₀⟩ := hg
+  have := hne; have := hL0
+  exact (indexOfSpecialty_eq_of_genusReached hD₀ D).2
+
+theorem gate_riemannInequality_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Divisor.degree D + 1 - γ ≤ (ell D : ℤ) := by
+  have heq := (indexOfSpecialty_eq_of_genusReached h D).2
+  have hnn : (0 : ℤ) ≤ indexOfSpecialty D := Int.natCast_nonneg _
+  linarith
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem adeleSpaceMul_add [HasPrincipalDivisors K F] (f g : F) :
+    adeleSpaceMul K F (f + g) = adeleSpaceMul K F f + adeleSpaceMul K F g := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, LinearMap.add_apply, Submodule.coe_add,
+    Pi.add_apply, add_mul]
+
+theorem adeleSpaceMul_zero [HasPrincipalDivisors K F] :
+    adeleSpaceMul K F (0 : F) = 0 := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, zero_mul, LinearMap.zero_apply,
+    Submodule.coe_zero, Pi.zero_apply]
+
+theorem weilSmul_add_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f + g) φ = weilSmul K F f φ + weilSmul K F g φ := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_add, LinearMap.add_apply, map_add]
+
+theorem weilSmul_zero_left [HasPrincipalDivisors K F]
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (0 : F) φ = 0 := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_zero, LinearMap.zero_apply, _root_.map_zero]
+
+theorem weilSmul_neg_left [HasPrincipalDivisors K F] (f : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (-f) φ = -weilSmul K F f φ := by
+  have h := weilSmul_add_left (K := K) (F := F) f (-f) φ
+  rw [add_neg_cancel, weilSmul_zero_left] at h
+  exact (neg_eq_of_add_eq_zero_right h.symm).symm
+
+theorem weilSmul_sub_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f - g) φ = weilSmul K F f φ - weilSmul K F g φ := by
+  rw [sub_eq_add_neg, weilSmul_add_left, weilSmul_neg_left, sub_eq_add_neg]
+
+theorem weilSmul_eq_zero_iff_left [HasPrincipalDivisors K F]
+    {f : F} {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    weilSmul K F f φ = 0 ↔ f = 0 := by
+  refine ⟨fun h => ?_, fun h => h ▸ weilSmul_zero_left φ⟩
+  by_contra hf
+  exact hφ (weilSmul_injective hf (h.trans (_root_.map_zero (weilSmul K F f)).symm))
+
+theorem weilSmul_left_injective [HasPrincipalDivisors K F]
+    {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    Function.Injective (fun f : F => weilSmul K F f φ) := by
+  intro f g hfg
+  have hsub : weilSmul K F (f - g) φ = 0 := by
+    rw [weilSmul_sub_left, sub_eq_zero]; exact hfg
+  exact sub_eq_zero.mp ((weilSmul_eq_zero_iff_left hφ).mp hsub)
+
+variable (K F) in
+def doubleResiduePairing [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) :
+    LSpace (W - D) × LSpace (W - D) →ₗ[K] omegaSpace D :=
+  (residuePairing K F W D hφ).coprod (residuePairing K F W D hμ)
+
+theorem doubleResiduePairing_apply_coe [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (g h : LSpace (W - D)) :
+    (doubleResiduePairing K F W D hφ hμ (g, h) : Module.Dual K (adeleSpace K F))
+      = weilSmul K F (g : F) φ + weilSmul K F (h : F) μ := by
+  simp only [doubleResiduePairing, LinearMap.coprod_apply, Submodule.coe_add,
+    residuePairing_apply_coe]
+
+theorem doubleResiduePairing_injective [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ) :
+    Function.Injective (doubleResiduePairing K F W D hφ hμ) := by
+  rw [injective_iff_map_eq_zero]
+  rintro ⟨g, h⟩ heq
+  have heq' : weilSmul K F (g : F) φ + weilSmul K F (h : F) μ = 0 := by
+    have hcoe := congrArg Subtype.val heq
+    rwa [doubleResiduePairing_apply_coe, Submodule.coe_zero] at hcoe
+  rcases eq_or_ne (h : F) 0 with hh0 | hh0
+  · rw [hh0, weilSmul_zero_left, add_zero] at heq'
+    have hg0 : (g : F) = 0 := (weilSmul_eq_zero_iff_left hφ0).mp heq'
+    exact Prod.ext (Subtype.ext hg0) (Subtype.ext hh0)
+  · exfalso
+    have hμeq : weilSmul K F (h : F) μ = -weilSmul K F (g : F) φ := by
+      have h2 : weilSmul K F (h : F) μ + weilSmul K F (g : F) φ = 0 := by
+        rw [add_comm]; exact heq'
+      exact eq_neg_of_add_eq_zero_left h2
+    have hLHS : weilSmul K F (h : F)⁻¹ (weilSmul K F (h : F) μ) = μ := by
+      rw [← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hh0, weilSmul_one,
+        LinearMap.id_apply]
+    have hRHS : weilSmul K F (h : F)⁻¹ (-weilSmul K F (g : F) φ)
+        = weilSmul K F (-(g : F) * (h : F)⁻¹) φ := by
+      rw [_root_.map_neg, ← LinearMap.comp_apply, ← weilSmul_mul, neg_mul, weilSmul_neg_left]
+    exact hindep (-(g : F) * (h : F)⁻¹) (by rw [← hLHS, hμeq, hRHS])
+
+theorem two_mul_ell_le_indexOfSpecialty [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ)
+    [Module.Finite K (omegaSpace (K := K) (F := F) D)]
+    [Module.Finite K (LSpace (K := K) (F := F) (W - D))] :
+    2 * ell (W - D) ≤ indexOfSpecialty D := by
+  have hinj := doubleResiduePairing_injective W D hφ hμ hφ0 hindep
+  have hle := LinearMap.finrank_le_finrank_of_injective hinj
+  rw [Module.finrank_prod] at hle
+  rw [← finrank_omegaSpace_eq_indexOfSpecialty, two_mul]
+  exact hle
+
+theorem degree_add_one_sub_genus_le_ell_of_riemannIndexFormula
+    [IsCurveOver K F] [HasCanonicalDivisor (K := K) (F := F)]
+    (hRI : RiemannIndexFormula K F) (D : Divisor K F) :
+    Divisor.degree D + 1 - (genus K F : ℤ) ≤ (ell D : ℤ) := by
+  have hi := hRI D
+  have hi0 : (0 : ℤ) ≤ (indexOfSpecialty D : ℤ) := Int.natCast_nonneg _
+  linarith
+
+theorem omegaSpace_finite_of_riemannIndexFormula
+    [IsCurveOver K F] [HasCanonicalDivisor (K := K) (F := F)]
+    (hRI : RiemannIndexFormula K F) {D : Divisor K F}
+    (hpos : 0 < (ell D : ℤ) - Divisor.degree D - 1 + (genus K F : ℤ)) :
+    Module.Finite K (omegaSpace (K := K) (F := F) D) := by
+  have h0 : 0 < finrank K (adeleSpace K F ⧸ adeleBddPrincipal K F D) := by
+    rw [← indexOfSpecialty_eq]
+    have hi := hRI D
+    have h0' : (0 : ℤ) < (indexOfSpecialty D : ℤ) := by linarith
+    exact_mod_cast h0'
+  have : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D) :=
+    FiniteDimensional.of_finrank_pos h0
+  exact Module.Finite.equiv (omegaSpaceEquivIndexDual D).symm
+
+theorem lSpace_finite_of_riemannIndexFormula
+    [IsCurveOver K F] [HasCanonicalDivisor (K := K) (F := F)]
+    (hRI : RiemannIndexFormula K F) {D : Divisor K F}
+    (hpos : 0 < Divisor.degree D + 1 - (genus K F : ℤ)) :
+    Module.Finite K (LSpace (K := K) (F := F) D) := by
+  have h0 : (0 : ℤ) < (ell D : ℤ) :=
+    lt_of_lt_of_le hpos (degree_add_one_sub_genus_le_ell_of_riemannIndexFormula hRI D)
+  exact FiniteDimensional.of_finrank_pos (by exact_mod_cast h0)
+
+theorem exists_weilSmul_eq_of_riemannIndexFormula
+    [IsCurveOver K F] [HasCanonicalDivisor (K := K) (F := F)] [Nonempty (Place K F)]
+    (hRI : RiemannIndexFormula K F)
+    {φ μ : Module.Dual K (adeleSpace K F)} {W : Divisor K F}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (hφ0 : φ ≠ 0) :
+    ∃ f : F, μ = weilSmul K F f φ := by
+  by_contra hcon
+  push Not at hcon
+  obtain ⟨P⟩ := ‹Nonempty (Place K F)›
+  set n : ℕ := 3 * genus K F + 2 * (Divisor.degree W).natAbs + 4 with hn
+  set D : Divisor K F := -Finsupp.single P (n : ℤ) with hD
+  have hdegD : Divisor.degree D = -(n : ℤ) * (P.deg : ℤ) := by
+    rw [hD, _root_.map_neg, Divisor.degree_single]; ring
+  have hdegWD : Divisor.degree (W - D) = Divisor.degree W + (n : ℤ) * (P.deg : ℤ) := by
+    rw [map_sub, hdegD]; ring
+  have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+  have hg0 : (0 : ℤ) ≤ (genus K F : ℤ) := Int.natCast_nonneg _
+  have habs0 : (0 : ℤ) ≤ |Divisor.degree W| := abs_nonneg _
+  have habsW : -|Divisor.degree W| ≤ Divisor.degree W := neg_abs_le _
+  have habsW' : Divisor.degree W ≤ |Divisor.degree W| := le_abs_self _
+  have hn_ge : 3 * (genus K F : ℤ) + 2 * |Divisor.degree W| + 4 ≤ (n : ℤ) := by
+    rw [hn]; push_cast [Int.natCast_natAbs]; ring_nf; omega
+  have hndegP : (n : ℤ) ≤ (n : ℤ) * (P.deg : ℤ) := by
+    nlinarith [Int.natCast_nonneg n]
+  have hndegP_pos : 0 < (n : ℤ) * (P.deg : ℤ) := by nlinarith
+  have hellD : ell D = 0 := ell_eq_zero_of_degree_neg (by rw [hdegD]; linarith)
+  have hiD : (indexOfSpecialty D : ℤ) = (n : ℤ) * (P.deg : ℤ) - 1 + (genus K F : ℤ) := by
+    have h := hRI D
+    rw [hellD, hdegD] at h; push_cast at h; linarith
+  have hlowerWD : Divisor.degree W + (n : ℤ) * (P.deg : ℤ) + 1 - (genus K F : ℤ)
+      ≤ (ell (W - D) : ℤ) := by
+    have h := degree_add_one_sub_genus_le_ell_of_riemannIndexFormula hRI (W - D)
+    rw [hdegWD] at h; exact h
+  have hiDpos : 0 < (ell D : ℤ) - Divisor.degree D - 1 + (genus K F : ℤ) := by
+    rw [hellD, hdegD]; push_cast; nlinarith
+  have hellWDpos : 0 < Divisor.degree (W - D) + 1 - (genus K F : ℤ) := by
+    rw [hdegWD]; nlinarith
+  have := omegaSpace_finite_of_riemannIndexFormula hRI hiDpos
+  have := lSpace_finite_of_riemannIndexFormula hRI hellWDpos
+  have hdbl : (2 * ell (W - D) : ℤ) ≤ (indexOfSpecialty D : ℤ) := by
+    exact_mod_cast two_mul_ell_le_indexOfSpecialty W D hφ hμ hφ0 hcon
+  rw [hiD] at hdbl
+  nlinarith
+
+theorem weilDifferentialRankOne_of_riemannIndexFormula
+    [IsCurveOver K F] [HasCanonicalDivisor (K := K) (F := F)] [Nonempty (Place K F)]
+    (hRI : RiemannIndexFormula K F) :
+    WeilDifferentialRankOne K F := by
+  intro φ hφmem hφ0 μ hμmem
+  obtain ⟨W₁, hφW₁⟩ := mem_weilDifferentialModule_iff.mp hφmem
+  obtain ⟨W₂, hμW₂⟩ := mem_weilDifferentialModule_iff.mp hμmem
+  have hφW : φ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_left hφW₁
+  have hμW : μ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_right hμW₂
+  obtain ⟨f, hf⟩ := exists_weilSmul_eq_of_riemannIndexFormula hRI hφW hμW hφ0
+  exact ⟨f, hf, fun f' hf' => weilSmul_left_injective hφ0 (hf'.symm.trans hf)⟩
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+section Finiteness
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+theorem omegaSpace_finite_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Module.Finite K (omegaSpace (K := K) (F := F) D) := by
+  have := (indexOfSpecialty_eq_of_genusReached h D).1
+  exact Module.Finite.equiv (omegaSpaceEquivIndexDual D).symm
+
+end Finiteness
+
+section ParametricRankOne
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+theorem exists_weilSmul_eq_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {φ μ : Module.Dual K (adeleSpace K F)} {W : Divisor K F}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (hφ0 : φ ≠ 0) :
+    ∃ f : F, μ = weilSmul K F f φ := by
+  by_contra hcon
+  push Not at hcon
+  obtain ⟨P⟩ := ‹Nonempty (Place K F)›
+  set n : ℕ := 3 * γ.natAbs + 2 * (Divisor.degree W).natAbs + 4 with hn
+  set D : Divisor K F := -Finsupp.single P (n : ℤ) with hD
+  have hdegD : Divisor.degree D = -(n : ℤ) * (P.deg : ℤ) := by
+    rw [hD, _root_.map_neg, Divisor.degree_single]; ring
+  have hdegWD : Divisor.degree (W - D) = Divisor.degree W + (n : ℤ) * (P.deg : ℤ) := by
+    rw [map_sub, hdegD]; ring
+  have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+  have habsγ : -(|γ|) ≤ γ ∧ γ ≤ |γ| := ⟨neg_abs_le _, le_abs_self _⟩
+  have habsW : -|Divisor.degree W| ≤ Divisor.degree W ∧
+      Divisor.degree W ≤ |Divisor.degree W| := ⟨neg_abs_le _, le_abs_self _⟩
+  have hn_ge : 3 * |γ| + 2 * |Divisor.degree W| + 4 ≤ (n : ℤ) := by
+    rw [hn]; push_cast [Int.natCast_natAbs]; ring_nf; omega
+  have hndegP : (n : ℤ) ≤ (n : ℤ) * (P.deg : ℤ) := by nlinarith [Int.natCast_nonneg n]
+  have hellD : ell D = 0 := ell_eq_zero_of_degree_neg (by rw [hdegD]; nlinarith)
+  have hiD : (indexOfSpecialty D : ℤ) = (n : ℤ) * (P.deg : ℤ) - 1 + γ := by
+    have hidx := (indexOfSpecialty_eq_of_genusReached h D).2
+    rw [hellD, hdegD] at hidx; push_cast at hidx; linarith
+  have hlowerWD : Divisor.degree W + (n : ℤ) * (P.deg : ℤ) + 1 - γ
+      ≤ (ell (W - D) : ℤ) := by
+    have hlow := gate_riemannInequality_of_genusReached h (W - D)
+    rw [hdegWD] at hlow; exact hlow
+  have := omegaSpace_finite_of_genusReached h D
+  have := finiteDimensional_lSpace (K := K) (W - D)
+  have hdbl : (2 * ell (W - D) : ℤ) ≤ (indexOfSpecialty D : ℤ) := by
+    exact_mod_cast two_mul_ell_le_indexOfSpecialty W D hφ hμ hφ0 hcon
+  rw [hiD] at hdbl
+  nlinarith [habsγ.1, habsγ.2, habsW.1, habsW.2]
+
+theorem weilDifferentialRankOne_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    WeilDifferentialRankOne K F := by
+  intro φ hφmem hφ0 μ hμmem
+  obtain ⟨W₁, hφW₁⟩ := mem_weilDifferentialModule_iff.mp hφmem
+  obtain ⟨W₂, hμW₂⟩ := mem_weilDifferentialModule_iff.mp hμmem
+  have hφW : φ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_left hφW₁
+  have hμW : μ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_right hμW₂
+  obtain ⟨f, hf⟩ := exists_weilSmul_eq_of_genusReached h hφW hμW hφ0
+  exact ⟨f, hf, fun f' hf' => weilSmul_left_injective hφ0 (hf'.symm.trans hf)⟩
+
+end ParametricRankOne
+
+theorem residuePairing_surjective_of_rankOne_max [HasPrincipalDivisors K F]
+    (hRankOne : WeilDifferentialRankOne K F)
+    {W : Divisor K F} {φ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hφ0 : φ ≠ 0)
+    (hWmax : ∀ E : Divisor K F, φ ∈ omegaSpace E → E ≤ W) (D : Divisor K F) :
+    Function.Surjective (residuePairing K F W D hφ) := by
+  rintro ⟨μ, hμD⟩
+  have hφmem : φ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule W hφ
+  have hμmem : μ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule D hμD
+  obtain ⟨f, hf, -⟩ := hRankOne hφmem hφ0 hμmem
+  rcases eq_or_ne f 0 with rfl | hf0
+  · have hμ0 : (⟨μ, hμD⟩ : omegaSpace D) = 0 :=
+      Subtype.ext (hf.trans (weilSmul_zero_left φ))
+    exact ⟨0, (_root_.map_zero _).trans hμ0.symm⟩
+  · obtain ⟨P, hPord, _⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+    have hPinv : ∀ v, (-P) v = v.ord f⁻¹ := fun v => by
+      rw [Finsupp.neg_apply, hPord v, v.ord_inv]
+    have hinv : weilSmul K F f⁻¹ μ = φ := by
+      rw [hf, ← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hf0, weilSmul_one,
+        LinearMap.id_apply]
+    have hφD : φ ∈ omegaSpace (D + -P) := by
+      rw [← hinv]; exact weilSmul_mem_omegaSpace_add (inv_ne_zero hf0) hPinv hμD
+    have hDP : D + -P ≤ W := hWmax _ hφD
+    have hfL : f ∈ LSpace (W - D) := by
+      rw [mem_lSpace_iff_ord]; refine Or.inr fun v => ?_
+      have hv := hDP v
+      rw [Finsupp.add_apply, Finsupp.neg_apply, hPord v] at hv
+      rw [Finsupp.sub_apply]; linarith
+    exact ⟨⟨f, hfL⟩, Subtype.ext hf.symm⟩
+
+section Identification
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+  [HasCanonicalDivisor (K := K) (F := F)]
+
+omit [HasCanonicalDivisor (K := K) (F := F)]
+  in
+theorem stichtenothGenus_nonneg
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    (hC : ConstantsAreBase K F) : 0 ≤ γ := by
+  have hi0 := (indexOfSpecialty_eq_of_genusReached h 0).2
+  rw [_root_.map_zero, ell_zero_eq_one_of_constantsAreBase hC] at hi0
+  have h0 : (0 : ℤ) ≤ (indexOfSpecialty (0 : Divisor K F) : ℤ) := Int.natCast_nonneg _
+  push_cast at hi0; linarith
+
+omit [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+  in
+theorem genus_eq_degree_div :
+    ∃ (ω₀ : Ω[F⁄K]) (hω₀ : ω₀ ≠ 0),
+      genus K F = (Divisor.degree (canonicalDivisorOf hω₀) + 2).toNat / 2 := by
+  have hne : ∃ ω : Ω[F⁄K], ω ≠ 0 := exists_ne 0
+  refine ⟨hne.choose, hne.choose_spec, ?_⟩
+  rw [genus, dite_eq_left hne]
+
+end Identification
+
+end AlgebraicCurve
+
+end
+
+section
+section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem mem_lSpace_of_weilSmul_mem_omegaSpace [HasPrincipalDivisors K F]
+    {W D : Divisor K F} {φ : Module.Dual K (adeleSpace K F)}
+    (hWmax : ∀ E : Divisor K F, φ ∈ omegaSpace E → E ≤ W)
+    {f : F} (hfφ : weilSmul K F f φ ∈ omegaSpace D) :
+    f ∈ LSpace (W - D) := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · exact (LSpace (W - D)).zero_mem
+  · obtain ⟨P, hPord, _⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf
+    have hPinv : ∀ v : Place K F, (-P) v = v.ord f⁻¹ := fun v => by
+      rw [Finsupp.neg_apply, hPord, v.ord_inv]
+    have hφshift : φ ∈ omegaSpace (D - P) := by
+      have hinv : weilSmul K F f⁻¹ (weilSmul K F f φ) = φ := by
+        rw [← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hf, weilSmul_one,
+          LinearMap.id_apply]
+      have h := weilSmul_mem_omegaSpace_add (inv_ne_zero hf) hPinv hfφ
+      rwa [hinv, ← sub_eq_add_neg] at h
+    have hle := hWmax (D - P) hφshift
+    refine mem_lSpace_iff_ord.mpr (Or.inr fun v => ?_)
+    have hlev := hle v
+    rw [Finsupp.sub_apply, hPord v] at hlev
+    rw [Finsupp.sub_apply]
+    linarith
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem residuePairing_surjective [HasPrincipalDivisors K F]
+    (hRk1 : WeilDifferentialRankOne K F) (W D : Divisor K F)
+    {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ∈ omegaSpace W) (hφ0 : φ ≠ 0)
+    (hWmax : ∀ E : Divisor K F, φ ∈ omegaSpace E → E ≤ W) :
+    Function.Surjective (residuePairing K F W D hφ) := by
+  rintro ⟨μ, hμD⟩
+  have hφmem : φ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule W hφ
+  have hμmem : μ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule D hμD
+  obtain ⟨f, hf, -⟩ := hRk1 hφmem hφ0 hμmem
+  have hfL : f ∈ LSpace (W - D) :=
+    mem_lSpace_of_weilSmul_mem_omegaSpace hWmax (hf ▸ hμD)
+  exact ⟨⟨f, hfL⟩, Subtype.ext hf.symm⟩
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem residuePairingSurjective_of_weilDifferentialRankOne [HasPrincipalDivisors K F]
+    (hRk1 : WeilDifferentialRankOne K F) : ResiduePairingSurjective K F := by
+  intro
+  exact residuePairing_surjective hRk1
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem residuePairingSurjective_of_riemannIndexFormula
+    [IsCurveOver K F] [HasCanonicalDivisor (K := K) (F := F)] [Nonempty (Place K F)]
+    (hRI : RiemannIndexFormula K F) : ResiduePairingSurjective K F := by
+  exact residuePairingSurjective_of_weilDifferentialRankOne
+    (weilDifferentialRankOne_of_riemannIndexFormula hRI)
+
+end AlgebraicCurve
+
+end
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+section CanonicalKResidueTerm
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+section SupportMachinery
+variable [HasCanonicalDivisor (K := K) (F := F)] [∀ v : Place K F, v.DCoordGenerates]
+variable (K F)
+variable {K F}
+
+theorem weilOfKaehlerK_mem_omegaSpace_of_residueTheoremK [HasPrincipalDivisors K F]
+    (hRT : ResidueTheoremK K F) (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK)
+    {ω : Ω[F⁄K]} (hω : ω ≠ 0) :
+    weilOfKaehlerK Rfam hω ∈ omegaSpace (canonicalDivisorOf hω) := by
+  rw [omegaSpace, Submodule.mem_dualAnnihilator]
+  intro α hα
+  obtain ⟨β, hβ, γ, hγ, rfl⟩ := Submodule.mem_sup.mp hα
+  rw [map_add, weilOfKaehlerK_vanish_adeleBdd_canonical Rfam hω (Submodule.mem_comap.mp hβ)]
+  obtain ⟨f, hf⟩ := Submodule.mem_comap.mp hγ
+  have hγ' : γ = ⟨diagonalHom K F f, diagonal_mem_adeleSpace f⟩ := Subtype.ext hf.symm
+  rw [hγ', hRT Rfam hω f, add_zero]
+
+end SupportMachinery
+
+end CanonicalKResidueTerm
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+section SimplePoleProbe
+
+variable [HasCanonicalLocalResidueKStar K F]
+
+variable [HasCanonicalDivisor (K := K) (F := F)] [∀ v : Place K F, v.DCoordGenerates]
+  [Nontrivial Ω[F⁄K]]
+
+def simplePoleProbe [DecidableEq (Place K F)] {ω : Ω[F⁄K]} (_hω : ω ≠ 0) (v : Place K F)
+    (c : v.toValuationSubring) : adeleSpace K F :=
+  adeleSingle v ((c : F) * v.uniformizer⁻¹ * (v.differentialCoeff ω)⁻¹)
+
+open scoped Classical in
+omit [Nontrivial Ω[F⁄K]] [HasCanonicalLocalResidueKStar K F] in
+theorem simplePoleProbe_mem_adeleBdd {ω : Ω[F⁄K]} (hω : ω ≠ 0) (v : Place K F)
+    (c : v.toValuationSubring) {D : Divisor K F} (hDv : canonicalDivisorOf hω v < D v) :
+    (simplePoleProbe hω v c : Place K F → F) ∈ adeleBdd D := by
+  unfold simplePoleProbe
+  rw [adeleSingle_coe]
+  refine single_mem_adeleBdd v _ D ?_
+  rcases eq_or_ne (c : F) 0 with hc | hc
+  · rw [hc, zero_mul, zero_mul, Valuation.map_zero]; exact zero_le
+  · set g : F := (c : F) * v.uniformizer⁻¹ * (v.differentialCoeff ω)⁻¹ with hg
+    have hg0 : g ≠ 0 :=
+      mul_ne_zero (mul_ne_zero hc (inv_ne_zero v.uniformizer_ne_zero))
+        (inv_ne_zero (v.differentialCoeff_ne_zero hω))
+    rw [v.adicValuation_eq_exp_neg_ord hg0, WithZero.exp_le_exp, neg_le]
+    rw [hg, v.ord_mul (mul_ne_zero hc (inv_ne_zero v.uniformizer_ne_zero))
+        (inv_ne_zero (v.differentialCoeff_ne_zero hω)),
+      v.ord_mul hc (inv_ne_zero v.uniformizer_ne_zero),
+      v.ord_inv, v.ord_uniformizer, v.ord_inv]
+    have hcnn : 0 ≤ v.ord (c : F) := v.ord_nonneg_of_mem c.2
+    rw [canonicalDivisorOf_apply hω v, Place.ordDifferential] at hDv
+    linarith
+
+end SimplePoleProbe
+
+namespace Place
+
+private theorem exists_trace_residue_ne_zero [HasSeparableResidue K F]
+    (v : Place K F) :
+    ∃ c : v.toValuationSubring,
+      Algebra.trace K v.ResidueField (IsLocalRing.residue _ c) ≠ 0 := by
+  have htr := HasSeparableResidue.trace_ne_zero (K := K) (F := F) v
+  rw [ne_eq, LinearMap.ext_iff, not_forall] at htr
+  obtain ⟨x, hx⟩ := htr
+  obtain ⟨c, rfl⟩ := IsLocalRing.residue_surjective x
+  exact ⟨c, by simpa using hx⟩
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+section
+section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem exists_riemannGenusReachedAt_of_bounded
+    [IsCurveOver K F] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    ∃ (γ : ℤ) (D₀ : Divisor K F), RiemannGenusReachedAt γ D₀ := by
+  obtain ⟨γ, hγ⟩ := hbdd
+  obtain ⟨M, ⟨D₀, hD₀⟩, hMmax⟩ :=
+    Int.exists_greatest_of_bdd
+      (P := fun n => ∃ D : Divisor K F, Divisor.degree D - ell D = n)
+      ⟨γ, fun n ⟨D, hD⟩ => hD ▸ hγ D⟩
+      ⟨Divisor.degree (0 : Divisor K F) - ell (0 : Divisor K F), 0, rfl⟩
+  refine ⟨M + 1, D₀, ?_, ?_, ?_⟩
+  · exact finiteDimensional_lSpace D₀
+  · rw [hD₀]; ring
+  · intro D
+    have := hMmax (Divisor.degree D - ell D) ⟨D, rfl⟩
+    linarith
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem stichtenothGenusExists_of_bounded
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    StichtenothGenusExists K F :=
+  ⟨‹_›, ‹_›, exists_riemannGenusReachedAt_of_bounded hbdd⟩
+
+end AlgebraicCurve
+
+end
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem mul_mem_lSpace_add {D E : Divisor K F} {f g : F}
+    (hf : f ∈ LSpace D) (hg : g ∈ LSpace E) :
+    f * g ∈ LSpace (D + E) := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · rw [zero_mul]; exact (LSpace _).zero_mem
+  rcases eq_or_ne g 0 with rfl | hg0
+  · rw [mul_zero]; exact (LSpace _).zero_mem
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun v => ?_
+  rw [Finsupp.add_apply, neg_add, v.ord_mul hf0 hg0]
+  exact add_le_add ((mem_lSpace_iff_ord.mp hf).resolve_left hf0 v)
+    ((mem_lSpace_iff_ord.mp hg).resolve_left hg0 v)
+
+theorem pow_mem_lSpace_nsmul {B : Divisor K F} {f : F} (hf : f ∈ LSpace B) (j : ℕ) :
+    f ^ j ∈ LSpace (j • B) := by
+  induction j with
+  | zero => simpa using one_mem_lSpace_zero (K := K) (F := F)
+  | succ j ih =>
+    rw [pow_succ, succ_nsmul]
+    exact mul_mem_lSpace_add ih hf
+
+structure PoleDivisorPackage (K F : Type*) [Field K] [Field F] [Algebra K F] where
+  x : F
+  B : Divisor K F
+  hB_eff : 0 ≤ B
+  hx_mem : x ∈ LSpace B
+  n : ℕ
+  hn_pos : 0 < n
+  degB_eq : Divisor.degree B = n
+  c : ℕ
+  u : Fin n → F
+  hu_mem : ∀ i, u i ∈ LSpace (c • B)
+  lin_indep : LinearIndependent K (fun p : ℕ × Fin n => x ^ p.1 * u p.2)
+
+variable (K F) in
+def HasPoleDivisorPackage : Prop := Nonempty (PoleDivisorPackage K F)
+
+namespace PoleDivisorPackage
+
+variable (P : PoleDivisorPackage K F)
+
+theorem pow_mul_u_mem_lSpace (j : ℕ) (i : Fin P.n) :
+    P.x ^ j * P.u i ∈ LSpace ((j + P.c) • P.B) := by
+  rw [add_nsmul]
+  exact mul_mem_lSpace_add (pow_mem_lSpace_nsmul P.hx_mem j) (P.hu_mem i)
+
+theorem pow_mul_u_mem_lSpace_of_le {j m : ℕ} (hjm : j + P.c ≤ m) (i : Fin P.n) :
+    P.x ^ j * P.u i ∈ LSpace (m • P.B) := by
+  refine lSpace_mono ?_ (P.pow_mul_u_mem_lSpace j i)
+  intro v
+  have hBv : (0 : ℤ) ≤ P.B v := P.hB_eff v
+  change ((j + P.c) • P.B) v ≤ (m • P.B) v
+  simp only [Finsupp.smul_apply, nsmul_eq_mul]
+  exact mul_le_mul_of_nonneg_right (by exact_mod_cast hjm) hBv
+
+theorem ell_nsmul_poleDivisor_ge [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    (P.n : ℤ) * (m - P.c + 1) ≤ ell (m • P.B) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  set g : Fin (m - P.c + 1) × Fin P.n → LSpace (m • P.B) :=
+    fun p => ⟨P.x ^ (p.1 : ℕ) * P.u p.2,
+      P.pow_mul_u_mem_lSpace_of_le (by have := p.1.isLt; omega) p.2⟩
+    with hgdef
+  have hsub : LinearIndependent K (fun p => (g p : F)) := by
+    have heq : (fun p => (g p : F))
+        = (fun p : ℕ × Fin P.n => P.x ^ p.1 * P.u p.2)
+            ∘ (fun p : Fin (m - P.c + 1) × Fin P.n => ((p.1 : ℕ), p.2)) := by
+      funext p; rfl
+    rw [heq]
+    refine P.lin_indep.comp _ ?_
+    intro p q hpq
+    simp only [Prod.mk.injEq] at hpq
+    exact Prod.ext (Fin.val_injective hpq.1) hpq.2
+  have hg : LinearIndependent K g := hsub.of_comp (LSpace (m • P.B)).subtype
+  have hcard := hg.fintype_card_le_finrank
+  rw [Fintype.card_prod, Fintype.card_fin, Fintype.card_fin] at hcard
+  have hZ : ((m - P.c + 1) * P.n : ℤ) ≤ (ell (m • P.B) : ℤ) := by exact_mod_cast hcard
+  have heq : (((m - P.c + 1 : ℕ) : ℤ) * P.n : ℤ) = (P.n : ℤ) * ((m : ℤ) - P.c + 1) := by
+    rw [Nat.cast_add, Nat.cast_sub hm, Nat.cast_one]; ring
+  linarith
+
+theorem degree_nsmul_sub_ell_le [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    Divisor.degree (m • P.B) - ell (m • P.B) ≤ (P.n : ℤ) * (P.c - 1) := by
+  have hge := P.ell_nsmul_poleDivisor_ge hm
+  have hdeg : Divisor.degree (m • P.B) = (m : ℤ) * P.n := by
+    rw [show m • P.B = (m : ℤ) • P.B from (natCast_zsmul _ _).symm,
+      Divisor.degree.map_zsmul, smul_eq_mul, P.degB_eq]
+  linarith
+
+end PoleDivisorPackage
+
+theorem PoleDivisorPackage.ell_nsmul_sub_pos [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) {A : Divisor K F} (hA : 0 ≤ A) {m : ℕ} (hm : P.c ≤ m)
+    (hbig : Divisor.degree A < (P.n : ℤ) * (m - P.c + 1)) :
+    0 < ell (m • P.B - A) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  have hle : m • P.B - A ≤ m • P.B := by
+    intro v
+    have hAv : (0 : ℤ) ≤ A v := hA v
+    rw [Finsupp.sub_apply]
+    linarith
+  have h48 := ell_sub_ell_le_degree_sub_degree (K := K) hle
+  rw [map_sub, sub_sub_cancel] at h48
+  have h412 := P.ell_nsmul_poleDivisor_ge hm
+  have : (0 : ℤ) < (ell (m • P.B - A) : ℤ) := by linarith
+  exact_mod_cast this
+
+theorem PoleDivisorPackage.degree_sub_ell_le [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) (D : Divisor K F) :
+    Divisor.degree D - ell D ≤ (P.n : ℤ) * (P.c - 1) := by
+  classical
+  set D' : Divisor K F := D ⊔ 0 with hD'def
+  have hD'eff : 0 ≤ D' := le_sup_right
+  have hDD' : D ≤ D' := le_sup_left
+  have := finiteDimensional_lSpace (K := K) D'
+  have hmono : Divisor.degree D - (ell D : ℤ) ≤ Divisor.degree D' - ell D' := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hDD'
+    linarith
+  set m : ℕ := P.c + (Divisor.degree D').toNat with hmdef
+  have hcm : P.c ≤ m := Nat.le_add_right _ _
+  have hdegD' : 0 ≤ Divisor.degree D' := Divisor.degree_nonneg_of_nonneg hD'eff
+  have hbig : Divisor.degree D' < (P.n : ℤ) * (m - P.c + 1) := by
+    have hcast : ((m : ℤ) - P.c) = Divisor.degree D' := by
+      simp only [hmdef, Nat.cast_add, add_sub_cancel_left, Int.toNat_of_nonneg hdegD']
+    rw [hcast]
+    have hn1 : (1 : ℤ) ≤ P.n := by exact_mod_cast P.hn_pos
+    nlinarith
+  have hellpos := P.ell_nsmul_sub_pos hD'eff hcm hbig
+  have hnebot : LSpace (m • P.B - D') ≠ ⊥ :=
+    fun h => by rw [ell, h, finrank_bot] at hellpos; exact lt_irrefl 0 hellpos
+  obtain ⟨z, hzL, hz0⟩ := (Submodule.ne_bot_iff _).mp hnebot
+  obtain ⟨Dz, hDzord, hDzdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) z hz0
+  have hzmem := (mem_lSpace_iff_ord.mp hzL).resolve_left hz0
+  have hD'le : D' ≤ m • P.B + Dz := by
+    intro v
+    have := hzmem v
+    simp only [Finsupp.add_apply, Finsupp.sub_apply, neg_sub] at this ⊢
+    rw [hDzord]; linarith
+  have hellshift : ell (m • P.B + Dz) = ell (m • P.B) :=
+    (LinearEquiv.finrank_eq (lSpaceShiftEquiv (m • P.B) hz0 hDzord)).symm
+  have hdegshift : Divisor.degree (m • P.B + Dz) = Divisor.degree (m • P.B) := by
+    rw [map_add, hDzdeg, add_zero]
+  have := finiteDimensional_lSpace (K := K) (m • P.B + Dz)
+  have hmono' : Divisor.degree D' - (ell D' : ℤ)
+      ≤ Divisor.degree (m • P.B + Dz) - ell (m • P.B + Dz) := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hD'le
+    linarith
+  rw [hellshift, hdegshift] at hmono'
+  have h412 := P.degree_nsmul_sub_ell_le hcm
+  linarith
+
+theorem riemannGenusBounded_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    RiemannGenusBounded K F :=
+  ⟨(P.n : ℤ) * (P.c - 1), P.degree_sub_ell_le⟩
+
+theorem stichtenothGenusExists_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_bounded (riemannGenusBounded_of_poleDivisorPackage P)
+
+theorem stichtenothGenusExists_of_hasPoleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (h : HasPoleDivisorPackage K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_poleDivisorPackage h.some
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+
+structure TranscendenceTower (K E F : Type*) [Field K] [Field E] [Field F]
+    [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F] where
+  x : E
+  hx_indep : LinearIndependent K (fun j : ℕ => x ^ j)
+  v : Place K E
+  hvdeg : v.deg = 1
+  hxv : v.ord x = -1
+  hxreg : ∀ u : Place K E, u ≠ v → 0 ≤ u.ord x
+
+namespace TranscendenceTower
+
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F]
+variable (T : TranscendenceTower K E F)
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+theorem x_ne_zero : T.x ≠ 0 := fun h => by
+  have := T.hxv; rw [h, Place.ord_zero] at this; exact absurd this (by decide)
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+abbrev xF : F := algebraMap E F T.x
+
+def poleDivisor : Divisor K F := Divisor.pullback F (Finsupp.single T.v 1)
+
+omit [FiniteDimensional E F] in
+theorem poleDivisor_apply (w : Place K F) :
+    T.poleDivisor w = (w.ramificationIndex E : ℤ) * (Finsupp.single T.v 1) (w.restrict E) :=
+  Divisor.pullback_apply (Finsupp.single T.v 1) w
+
+omit [FiniteDimensional E F] in
+theorem poleDivisor_nonneg : 0 ≤ T.poleDivisor := by
+  classical
+  intro w
+  rw [Finsupp.coe_zero, Pi.zero_apply, T.poleDivisor_apply, Finsupp.single_apply]
+  refine mul_nonneg (Int.natCast_nonneg _) ?_
+  split_ifs <;> simp
+
+omit [FiniteDimensional E F] in
+theorem xF_mem_lSpace_poleDivisor : T.xF ∈ LSpace T.poleDivisor := by
+  classical
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun w => ?_
+  rw [T.poleDivisor_apply, Place.ord_restrict, Finsupp.single_apply]
+  rcases eq_or_ne (w.restrict E) T.v with hw | hw
+  · simp only [hw, T.hxv, ite_true, mul_one, mul_neg_one, le_refl]
+  · simp only [ite_eq_right (Ne.symm hw), mul_zero, _root_.neg_zero]
+    exact mul_nonneg (Int.natCast_nonneg _) (T.hxreg _ hw)
+
+theorem degree_poleDivisor_eq_finrank :
+    Divisor.degree T.poleDivisor = (Module.finrank E F : ℤ) := by
+  rw [poleDivisor, Divisor.degree_pullback, Divisor.degree_single, T.hvdeg]
+  push_cast; ring
+
+omit [FiniteDimensional E F] in
+theorem mem_lSpace_nsmul_poleDivisor_of_regular_outside {f : F}
+    (hreg : ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord f)
+    {c : ℕ} (hc : ∀ w ∈ T.v.fiber F, -(c : ℤ) ≤ w.ord f) :
+    f ∈ LSpace (c • T.poleDivisor) := by
+  classical
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact (LSpace _).zero_mem
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun w => ?_
+  rw [Finsupp.smul_apply, T.poleDivisor_apply, Finsupp.single_apply, nsmul_eq_mul]
+  rcases eq_or_ne (w.restrict E) T.v with hw | hw
+  · simp only [hw, ite_true, mul_one]
+    have he : (1 : ℤ) ≤ w.ramificationIndex E := by
+      exact_mod_cast w.ramificationIndex_pos (F := E)
+    have hbdd := hc w (Place.mem_fiber.mpr hw)
+    nlinarith [Int.natCast_nonneg c]
+  · simp only [ite_eq_right (Ne.symm hw), mul_zero, _root_.neg_zero]
+    exact hreg w hw
+
+omit [FiniteDimensional E F] in
+theorem exists_forall_mem_lSpace_nsmul_poleDivisor {n : ℕ} (u : Fin n → F)
+    (hreg : ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)) :
+    ∃ c : ℕ, ∀ i, u i ∈ LSpace (c • T.poleDivisor) := by
+  classical
+  refine ⟨(Finset.univ : Finset (Fin n)).sup fun i =>
+    (T.v.fiber F).sup fun w => (-(w.ord (u i))).toNat,
+    fun i => T.mem_lSpace_nsmul_poleDivisor_of_regular_outside (hreg i) ?_⟩
+  intro w hw
+  have h1 : (-(w.ord (u i))).toNat
+      ≤ (T.v.fiber F).sup fun w' => (-(w'.ord (u i))).toNat :=
+    Finset.le_sup (f := fun w' => (-(w'.ord (u i))).toNat) hw
+  have h2 : ((T.v.fiber F).sup fun w' => (-(w'.ord (u i))).toNat)
+      ≤ (Finset.univ : Finset (Fin n)).sup fun i' =>
+          (T.v.fiber F).sup fun w' => (-(w'.ord (u i'))).toNat :=
+    Finset.le_sup (f := fun i' => (T.v.fiber F).sup fun w' => (-(w'.ord (u i'))).toNat)
+      (Finset.mem_univ i)
+  have htnat : -(w.ord (u i)) ≤ ((-(w.ord (u i))).toNat : ℤ) := Int.self_le_toNat _
+  omega
+
+end TranscendenceTower
+
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F]
+
+structure IntegralBasisInLSpace (T : TranscendenceTower K E F) where
+  c : ℕ
+  u : Fin (Module.finrank E F) → F
+  hu_indep : LinearIndependent E u
+  hu_mem : ∀ i, u i ∈ LSpace (c • T.poleDivisor)
+
+variable (K E F) in
+def HasIntegralBasisInLSpace (T : TranscendenceTower K E F) : Prop :=
+  Nonempty (IntegralBasisInLSpace T)
+
+def IntegralBasisInLSpace.ofRegularOutside (T : TranscendenceTower K E F)
+    (u : Fin (Module.finrank E F) → F) (hu_indep : LinearIndependent E u)
+    (hreg : ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)) :
+    IntegralBasisInLSpace T where
+  c := (T.exists_forall_mem_lSpace_nsmul_poleDivisor u hreg).choose
+  u := u
+  hu_indep := hu_indep
+  hu_mem := (T.exists_forall_mem_lSpace_nsmul_poleDivisor u hreg).choose_spec
+
+variable (K E F) in
+def HasIntegralBasisRegularOutside (T : TranscendenceTower K E F) : Prop :=
+  ∃ u : Fin (Module.finrank E F) → F, LinearIndependent E u ∧
+    ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)
+
+omit [FiniteDimensional E F] in
+theorem hasIntegralBasisInLSpace_of_regularOutside (T : TranscendenceTower K E F)
+    (h : HasIntegralBasisRegularOutside K E F T) :
+    HasIntegralBasisInLSpace K E F T := by
+  obtain ⟨u, hu_indep, hreg⟩ := h
+  exact ⟨IntegralBasisInLSpace.ofRegularOutside T u hu_indep hreg⟩
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+theorem linearIndependent_pow_mul {x : E} {n : ℕ} {u : Fin n → F}
+    (hx : LinearIndependent K (fun j : ℕ => x ^ j)) (hu : LinearIndependent E u) :
+    LinearIndependent K (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2) := by
+  have heq : (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2)
+      = (fun p : ℕ × Fin n => (x ^ p.1) • u p.2) := by
+    funext p
+    rw [Algebra.smul_def, map_pow]
+  rw [heq]
+  exact linearIndependent_smul (R := K) (S := E) (A := F) hx hu
+
+def PoleDivisorPackage.ofTranscendenceTower (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    PoleDivisorPackage K F where
+  x := T.xF
+  B := T.poleDivisor
+  hB_eff := T.poleDivisor_nonneg
+  hx_mem := T.xF_mem_lSpace_poleDivisor
+  n := Module.finrank E F
+  hn_pos := Module.finrank_pos
+  degB_eq := T.degree_poleDivisor_eq_finrank
+  c := IB.c
+  u := IB.u
+  hu_mem := IB.hu_mem
+  lin_indep := linearIndependent_pow_mul T.hx_indep IB.hu_indep
+
+theorem hasPoleDivisorPackage_of_transcendenceTower
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    HasPoleDivisorPackage K F :=
+  ⟨PoleDivisorPackage.ofTranscendenceTower T IB⟩
+
+theorem hasPoleDivisorPackage_of_hasIntegralBasisInLSpace
+    (T : TranscendenceTower K E F) (h : HasIntegralBasisInLSpace K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_transcendenceTower T h.some
+
+theorem hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside
+    (T : TranscendenceTower K E F) (h : HasIntegralBasisRegularOutside K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisInLSpace T
+    (hasIntegralBasisInLSpace_of_regularOutside T h)
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+private theorem mem_of_isIntegral {f : F}
+    (hf : _root_.IsIntegral w.toValuationSubring f) :
+    f ∈ w.toValuationSubring := by
+  obtain ⟨y, hy⟩ := IsIntegrallyClosed.isIntegral_iff.mp hf
+  exact hy ▸ y.2
+
+private theorem mem_of_isIntegral_of_algebraMap_mem {A : Type*}
+    [CommRing A] [Algebra A F]
+    (hA : ∀ a : A, algebraMap A F a ∈ w.toValuationSubring)
+    {f : F} (hf : _root_.IsIntegral A f) : f ∈ w.toValuationSubring := by
+  let : Algebra A w.toValuationSubring :=
+    ((algebraMap A F).codRestrict w.toValuationSubring.toSubring hA).toAlgebra
+  have : IsScalarTower A w.toValuationSubring F :=
+    IsScalarTower.of_algebraMap_eq fun a => rfl
+  exact w.mem_of_isIntegral hf.tower_top
+
+end Place
+
+section Bridge
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+variable {A : Type*} [CommRing A] [Algebra A E] [Algebra A F] [IsScalarTower A E F]
+
+namespace Place
+
+private theorem mem_of_isIntegral_of_restrict [Algebra.IsIntegral E F]
+    (w : Place K F)
+    {u : Place K E} (hw : w.restrict E = u)
+    (hA : ∀ a : A, algebraMap A E a ∈ u.toValuationSubring)
+    {f : F} (hf : _root_.IsIntegral A f) : f ∈ w.toValuationSubring := by
+  refine w.mem_of_isIntegral_of_algebraMap_mem (fun a => ?_) hf
+  rw [IsScalarTower.algebraMap_apply A E F, ← w.mem_restrict_iff, hw]
+  exact hA a
+
+end Place
+
+namespace Place
+
+private theorem ord_nonneg_of_isIntegral_of_restrict
+    [Algebra.IsIntegral E F] (w : Place K F)
+    {u : Place K E} (hw : w.restrict E = u)
+    (hA : ∀ a : A, algebraMap A E a ∈ u.toValuationSubring)
+    {f : F} (hf : _root_.IsIntegral A f) : 0 ≤ w.ord f :=
+  w.ord_nonneg_of_mem (w.mem_of_isIntegral_of_restrict hw hA hf)
+
+end Place
+
+variable (A) in
+def TranscendenceTower.RegularOutside (T : TranscendenceTower K E F) : Prop :=
+  ∀ u : Place K E, u ≠ T.v → ∀ a : A, algebraMap A E a ∈ u.toValuationSubring
+
+theorem TranscendenceTower.ord_nonneg_of_isIntegral_of_regularOutside
+    [Algebra.IsIntegral E F] (T : TranscendenceTower K E F) (hA : T.RegularOutside A)
+    {f : F} (hf : _root_.IsIntegral A f) :
+    ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord f := fun w hw =>
+  w.ord_nonneg_of_isIntegral_of_restrict rfl (hA _ hw) hf
+
+end Bridge
+
+section Headline
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F]
+
+variable (K E F) in
+def HasRegularFractionSubring (T : TranscendenceTower K E F) : Prop :=
+  ∃ (A : Subalgebra K E), IsFractionRing A E ∧
+    ∀ u : Place K E, u ≠ T.v → ∀ a ∈ A, a ∈ u.toValuationSubring
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+theorem linearIndependent_reindex_basis {s : Finset F} (b : Basis s E F) :
+    LinearIndependent E (fun i : Fin (Module.finrank E F) =>
+      b ((Fintype.equivFinOfCardEq (Module.finrank_eq_card_basis b).symm).symm i)) :=
+  b.linearIndependent.comp _ (Equiv.injective _)
+
+theorem hasIntegralBasisRegularOutside_of_isFractionRing
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    HasIntegralBasisRegularOutside K E F T := by
+  obtain ⟨s, b, hint⟩ := FiniteDimensional.exists_is_basis_integral A E F
+  set e : Fin (Module.finrank E F) ≃ s :=
+    (Fintype.equivFinOfCardEq (Module.finrank_eq_card_basis b).symm).symm
+  refine ⟨fun i => b (e i), linearIndependent_reindex_basis b, fun i w hw => ?_⟩
+  exact T.ord_nonneg_of_isIntegral_of_regularOutside hA (hint (e i)) w hw
+
+theorem hasIntegralBasisRegularOutside_of_hasRegularFractionSubring
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    HasIntegralBasisRegularOutside K E F T := by
+  obtain ⟨A, hfrac, hreg⟩ := h
+  have : IsFractionRing A E := hfrac
+  exact hasIntegralBasisRegularOutside_of_isFractionRing (A := A) T
+    (fun u hu a => hreg u hu (a : E) a.property)
+
+theorem hasPoleDivisorPackage_of_hasRegularFractionSubring [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside T
+    (hasIntegralBasisRegularOutside_of_hasRegularFractionSubring T h)
+
+theorem stichtenothGenusExists_of_hasRegularFractionSubring [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasPoleDivisorPackage
+    (hasPoleDivisorPackage_of_hasRegularFractionSubring T h)
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+theorem TranscendenceTower.adjoin_x_regularOutside (T : TranscendenceTower K E F) :
+    ∀ u : Place K E, u ≠ T.v →
+      ∀ a ∈ Algebra.adjoin K {T.x}, a ∈ u.toValuationSubring := by
+  intro u hu a ha
+  let S : Subalgebra K E :=
+    { u.toValuationSubring.toSubsemiring with
+      algebraMap_mem' := u.algebraMap_mem' }
+  suffices h : a ∈ S from h
+  refine Algebra.adjoin_le ?_ ha
+  intro y hy
+  rw [Set.mem_singleton_iff] at hy
+  subst hy
+  change T.x ∈ u.toValuationSubring
+  exact u.mem_of_ord_nonneg T.x_ne_zero (T.hxreg u hu)
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+theorem hasRegularFractionSubring_of_adjoin_x_isFractionRing
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    HasRegularFractionSubring K E F T :=
+  ⟨Algebra.adjoin K {T.x}, hfrac, T.adjoin_x_regularOutside⟩
+
+theorem stichtenothGenusExists_of_adjoin_x_isFractionRing [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasRegularFractionSubring T
+    (hasRegularFractionSubring_of_adjoin_x_isFractionRing T hfrac)
+
+end Headline
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+section Transcendental
+
+variable {K A : Type*} [CommRing K] [CommRing A] [Algebra K A]
+
+theorem linearIndependent_pow_of_transcendental {x : A} (hx : Transcendental K x) :
+    LinearIndependent K (fun j : ℕ => x ^ j) := by
+  have hinj : Function.Injective (Polynomial.aeval x : K[X] →ₐ[K] A) :=
+    transcendental_iff_injective.mp hx
+  have hXj : LinearIndependent K (fun j : ℕ => (X : K[X]) ^ j) := by
+    have hb := (Polynomial.basisMonomials K).linearIndependent
+    simp only [Polynomial.coe_basisMonomials] at hb
+    convert hb using 2 with j
+    exact (Polynomial.monomial_one_right_eq_X_pow j).symm
+  have heq : (fun j : ℕ => x ^ j)
+      = (fun j : ℕ => (Polynomial.aeval x : K[X] →ₐ[K] A) (X ^ j)) := by
+    funext j; simp
+  rw [heq]
+  exact hXj.map' (Polynomial.aeval x).toLinearMap
+    (LinearMap.ker_eq_bot_of_injective hinj)
+
+end Transcendental
+
+namespace RationalFunctionField
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+
+theorem algebraMap_polynomial_mem_of_ne_placeInfty
+    {u : Place K (RatFunc K)} (hu : u ≠ placeInfty K) (q : K[X]) :
+    algebraMap K[X] (RatFunc K) q ∈ u.toValuationSubring := by
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty u with ⟨w, hw⟩ | hw
+  · subst hw; exact algebraMap_mem_ofHeightOneSpectrum K w q
+  · exact absurd hw hu
+
+theorem ord_X_nonneg_of_ne_placeInfty
+    {u : Place K (RatFunc K)} (hu : u ≠ placeInfty K) :
+    0 ≤ u.ord (RatFunc.X : RatFunc K) := by
+  rw [← RatFunc.algebraMap_X]
+  exact u.ord_nonneg_of_mem (algebraMap_polynomial_mem_of_ne_placeInfty K hu Polynomial.X)
+
+variable (F : Type*) [Field F] [Algebra K F] [Algebra (RatFunc K) F]
+  [IsScalarTower K (RatFunc K) F]
+
+def transcendenceTower : TranscendenceTower K (RatFunc K) F where
+  x := RatFunc.X
+  hx_indep := linearIndependent_pow_of_transcendental RatFunc.transcendental_X
+  v := placeInfty K
+  hvdeg := deg_placeInfty K
+  hxv := ord_placeInfty_X K
+  hxreg := fun _ hu => ord_X_nonneg_of_ne_placeInfty K hu
+
+omit [DecidableEq (RatFunc K)] in
+theorem aeval_X_eq_algebraMap (q : K[X]) :
+    (Polynomial.aeval (R := K) (RatFunc.X : RatFunc K)) q
+      = algebraMap K[X] (RatFunc K) q := by
+  have hext : (Polynomial.aeval (R := K) (RatFunc.X : RatFunc K))
+      = IsScalarTower.toAlgHom K K[X] (RatFunc K) :=
+    Polynomial.algHom_ext (by simp [RatFunc.algebraMap_X])
+  rw [hext]; rfl
+
+omit [DecidableEq (RatFunc K)] in
+theorem algebraMap_polynomial_mem_adjoin_X (q : K[X]) :
+    algebraMap K[X] (RatFunc K) q ∈ Algebra.adjoin K {(RatFunc.X : RatFunc K)} := by
+  rw [Algebra.adjoin_singleton_eq_range_aeval]
+  exact ⟨q, aeval_X_eq_algebraMap K q⟩
+
+omit [DecidableEq (RatFunc K)] in
+theorem isFractionRing_adjoin_X :
+    IsFractionRing (Algebra.adjoin K {(RatFunc.X : RatFunc K)}) (RatFunc K) := by
+  refine IsFractionRing.of_field _ _ fun z => ?_
+  refine ⟨⟨algebraMap K[X] (RatFunc K) z.num, algebraMap_polynomial_mem_adjoin_X K z.num⟩,
+    ⟨algebraMap K[X] (RatFunc K) z.denom, algebraMap_polynomial_mem_adjoin_X K z.denom⟩, ?_⟩
+  change z = algebraMap K[X] (RatFunc K) z.num / algebraMap K[X] (RatFunc K) z.denom
+  exact z.num_div_denom.symm
+
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+omit [DecidableEq (RatFunc K)] in
+theorem stichtenothGenusExists_of_ratFunc_tower :
+    StichtenothGenusExists K F := by
+  classical
+  exact
+    stichtenothGenusExists_of_adjoin_x_isFractionRing
+      (transcendenceTower K F) (isFractionRing_adjoin_X K)
+
+end RationalFunctionField
+
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+
+namespace RationalFunctionField
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+variable (F : Type*) [Field F] [Algebra K F] [Algebra (RatFunc K) F]
+  [IsScalarTower K (RatFunc K) F]
+
+section LyingOver
+
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+
+attribute [local instance 0] Place.valuationSubringAlgebra
+
+omit [DecidableEq (RatFunc K)] [Algebra K F] [IsScalarTower K (RatFunc K) F]
+  [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F] in
+private theorem not_isField_integralClosureAt' (v : Place K (RatFunc K)) :
+    ¬IsField (Place.integralClosureAt F v) := fun hf =>
+  ValuationSubring.not_isField_of_ne_top _ v.ne_top'
+    ((Algebra.IsIntegral.isField_iff_isField
+      (R := v.toValuationSubring) (S := Place.integralClosureAt F v)
+      (Place.algebraMap_integralClosureAt_injective v)).mpr hf)
+
+end LyingOver
+
+end RationalFunctionField
+
+namespace RationalFunctionField
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+variable (F : Type*) [Field F] [Algebra K F] [Algebra (RatFunc K) F]
+  [IsScalarTower K (RatFunc K) F]
+section LyingOver
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+attribute [local instance 0] Place.valuationSubringAlgebra
+omit [DecidableEq (RatFunc K)] in
+theorem exists_restrict_eq (v : Place K (RatFunc K)) :
+    ∃ w : Place K F, w.restrict (RatFunc K) = v := by
+  obtain ⟨M, hM⟩ := Ideal.exists_maximal (Place.integralClosureAt F v)
+  have := hM
+  exact ⟨Place.placeOfPrime (v := v)
+      ⟨M, hM.isPrime, Ring.ne_bot_of_isMaximal_of_not_isField hM
+        (not_isField_integralClosureAt' K F v)⟩,
+    Place.restrict_placeOfPrime _⟩
+
+end LyingOver
+
+end RationalFunctionField
+
+namespace RationalFunctionField
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+variable (F : Type*) [Field F] [Algebra K F] [Algebra (RatFunc K) F]
+  [IsScalarTower K (RatFunc K) F]
+section LyingOver
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+attribute [local instance 0] Place.valuationSubringAlgebra
+
+omit [DecidableEq (RatFunc K)] in
+theorem nonempty_place_of_ratFunc_tower : Nonempty (Place K F) := by
+  classical
+  exact
+    (exists_restrict_eq K F (placeInfty K)).nonempty
+
+end LyingOver
+
+end RationalFunctionField
+
+namespace RationalFunctionField
+
+variable (K : Type*) [Field K]
+variable (F : Type*) [Field F] [Algebra K F]
+theorem finiteDimensional_lSpace_zero_of_constantsAreBase (hC : ConstantsAreBase K F) :
+    FiniteDimensional K (LSpace (0 : Divisor K F)) := by
+  rw [show LSpace (0 : Divisor K F) = LinearMap.range (Algebra.linearMap K F) from hC]
+  exact LinearMap.finiteDimensional_range _
+
+end RationalFunctionField
+
+end AlgebraicCurve
+
+section
+
+namespace AlgebraicCurve
+
+namespace RationalFunctionField
+
+variable (K : Type*) [Field K]
+variable (F : Type*) [Field F] [Algebra K F] [Algebra (RatFunc K) F]
+  [IsScalarTower K (RatFunc K) F]
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+variable [IsCurveOver K F]
+
+theorem stichtenothGenusExists (hC : ConstantsAreBase K F) :
+    StichtenothGenusExists K F := by
+  classical
+  exact
+    haveI := nonempty_place_of_ratFunc_tower K F
+    haveI := finiteDimensional_lSpace_zero_of_constantsAreBase K F hC
+    stichtenothGenusExists_of_ratFunc_tower K F
+
+end RationalFunctionField
+
+end AlgebraicCurve
+
+end
+
+end
+
+section
+
+namespace ModularCurve
+
+section AlgClosedEngine
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+variable [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+variable [IsAlgClosed K] [IsCurveOver K F]
+
+theorem p0n20_rr_constantsAreBase_of_isAlgClosed : ConstantsAreBase K F := by
+  classical
+  obtain ⟨v⟩ := RationalFunctionField.nonempty_place_of_ratFunc_tower K F
+  exact constantsAreBase_of_deg_eq_one v (IsCurveOver.deg_eq_one_of_isAlgClosed v)
+
+end AlgClosedEngine
+
+end ModularCurve
+
+end
+
+section
+
+namespace ModularCurve
+
+section CanonicalProbe
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] [HasCanonicalLocalResidueKStar K F]
+
+open scoped Classical in
+omit [HasCanonicalLocalResidueKStar K F] in
+theorem p0n25_wkc_kaehlerResidueTermKFam_single_of_ne
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK) (ω : Ω[F⁄K])
+    {v : Place K F} (g : F) {w : Place K F} (hw : w ≠ v) :
+    kaehlerResidueTermKFam Rfam ω (Pi.single v g) w = 0 := by
+  rw [kaehlerResidueTermKFam_apply, Pi.single_eq_of_ne hw, zero_mul, _root_.map_zero,
+    _root_.map_zero]
+
+omit [HasCanonicalLocalResidueKStar K F] in
+theorem p0n25_wkc_localResidueData_res_mul_uniformizer_inv
+    {v : Place K F} (R : v.LocalResidueData) (c : v.toValuationSubring) :
+    R.res ((c : F) * v.uniformizer⁻¹) = IsLocalRing.residue _ c := by
+  have hmul : v.uniformizer * ((c : F) * v.uniformizer⁻¹) = (c : F) := by
+    rw [mul_comm (c : F), ← mul_assoc, mul_inv_cancel₀ v.uniformizer_ne_zero, one_mul]
+  have hmem : v.uniformizer * ((c : F) * v.uniformizer⁻¹) ∈ v.toValuationSubring := by
+    rw [hmul]; exact c.2
+  rw [R.res_simplePole _ hmem]
+  congr 1
+  exact Subtype.ext hmul
+
+variable [HasCanonicalDivisor (K := K) (F := F)] [∀ v : Place K F, v.DCoordGenerates]
+
+open scoped Classical in
+omit [HasCanonicalLocalResidueKStar K F] in
+theorem p0n25_wkc_weilOfKaehlerK_single
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK)
+    {ω : Ω[F⁄K]} (hω : ω ≠ 0) (v : Place K F) (g : F) :
+    weilOfKaehlerK Rfam hω (adeleSingle v g)
+      = Algebra.trace K v.ResidueField ((Rfam v).res (g * v.differentialCoeff ω)) := by
+  rw [weilOfKaehlerK_apply, adeleSingle_coe]
+  refine (finsum_eq_single _ v
+    fun w hw => p0n25_wkc_kaehlerResidueTermKFam_single_of_ne Rfam ω g hw).trans ?_
+  rw [kaehlerResidueTermKFam_apply, Pi.single_eq_same]
+
+omit [HasCanonicalLocalResidueKStar K F] in
+theorem p0n25_wkc_weilOfKaehlerK_simplePoleProbe
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK)
+    {ω : Ω[F⁄K]} (hω : ω ≠ 0) (v : Place K F) (c : v.toValuationSubring) :
+    letI := Classical.propDecidable
+    weilOfKaehlerK Rfam hω (simplePoleProbe hω v c)
+      = Algebra.trace K v.ResidueField (IsLocalRing.residue _ c) := by
+  unfold simplePoleProbe
+  rw [p0n25_wkc_weilOfKaehlerK_single Rfam hω v,
+    mul_assoc, inv_mul_cancel₀ (v.differentialCoeff_ne_zero hω), mul_one,
+    p0n25_wkc_localResidueData_res_mul_uniformizer_inv (Rfam v).toLocalResidueData c]
+
+end CanonicalProbe
+
+section CanonicalNonvanishingMaximality
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable [HasCanonicalDivisor (K := K) (F := F)] [∀ v : Place K F, v.DCoordGenerates]
+
+theorem p0n25_wkc_weilOfKaehlerK_ne_zero [HasSeparableResidue K F] [Nonempty (Place K F)]
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK)
+    {ω : Ω[F⁄K]} (hω : ω ≠ 0) : weilOfKaehlerK Rfam hω ≠ 0 := by
+  obtain ⟨v⟩ := ‹Nonempty (Place K F)›
+  obtain ⟨c, hc⟩ := v.exists_trace_residue_ne_zero
+  intro h
+  apply hc
+  rw [← p0n25_wkc_weilOfKaehlerK_simplePoleProbe Rfam hω v c, h, LinearMap.zero_apply]
+
+theorem p0n25_wkc_trace_eq_zero_of_weilOfKaehlerK_mem
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK)
+    {ω : Ω[F⁄K]} (hω : ω ≠ 0) {D : Divisor K F}
+    (hD : weilOfKaehlerK Rfam hω ∈ omegaSpace D)
+    {v : Place K F} (hDv : canonicalDivisorOf hω v < D v) :
+    (Algebra.trace K v.ResidueField : _ →ₗ[K] K) = 0 := by
+  ext x
+  obtain ⟨c, rfl⟩ := IsLocalRing.residue_surjective x
+  rw [LinearMap.zero_apply, ← p0n25_wkc_weilOfKaehlerK_simplePoleProbe Rfam hω v c]
+  exact omegaSpace_vanishBdd hD (simplePoleProbe_mem_adeleBdd hω v c hDv)
+
+theorem p0n25_wkc_weilOfKaehlerK_omegaSpace_le_canonical [HasSeparableResidue K F]
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK)
+    {ω : Ω[F⁄K]} (hω : ω ≠ 0) {D : Divisor K F}
+    (hD : weilOfKaehlerK Rfam hω ∈ omegaSpace D) :
+    D ≤ canonicalDivisorOf hω := by
+  intro v
+  rcases le_or_gt (D v) (canonicalDivisorOf hω v) with h | h
+  · exact h
+  · exact absurd (p0n25_wkc_trace_eq_zero_of_weilOfKaehlerK_mem Rfam hω hD h)
+      (HasSeparableResidue.trace_ne_zero v)
+
+end CanonicalNonvanishingMaximality
+
+section CanonicalSupply
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable [HasCanonicalDivisor (K := K) (F := F)] [∀ v : Place K F, v.DCoordGenerates]
+
+theorem p0n25_wkc_exists_weilMax_of_residueTheoremK
+    [HasSeparableResidue K F] [Nonempty (Place K F)] [HasPrincipalDivisors K F]
+    (hRTK : ResidueTheoremK K F) {ω : Ω[F⁄K]} (hω : ω ≠ 0) :
+    ∃ φ : Module.Dual K (adeleSpace K F), φ ≠ 0 ∧
+      φ ∈ omegaSpace (canonicalDivisorOf hω) ∧
+      ∀ D : Divisor K F, φ ∈ omegaSpace D → D ≤ canonicalDivisorOf hω :=
+  ⟨weilOfKaehlerK (fun v => v.canonicalLocalResidueDataKOfExtend) hω,
+    p0n25_wkc_weilOfKaehlerK_ne_zero _ hω,
+    weilOfKaehlerK_mem_omegaSpace_of_residueTheoremK hRTK _ hω,
+    fun _ hD => p0n25_wkc_weilOfKaehlerK_omegaSpace_le_canonical _ hω hD⟩
+
+end CanonicalSupply
+
+section MirrorIdentification
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable [IsCurveOver K F] [HasCanonicalDivisor (K := K) (F := F)]
+variable [∀ v : Place K F, v.DCoordGenerates]
+variable [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+omit [∀ (v : Place K F), v.DCoordGenerates] in
+theorem p0n25_wkc_finrank_omegaSpace_eq_ell_of_genusReached_of_weilMax
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {ω : Ω[F⁄K]} (hω : ω ≠ 0)
+    {φ : Module.Dual K (adeleSpace K F)} (hne : φ ≠ 0)
+    (hmem : φ ∈ omegaSpace (canonicalDivisorOf hω))
+    (hmax : ∀ D : Divisor K F, φ ∈ omegaSpace D → D ≤ canonicalDivisorOf hω)
+    (D : Divisor K F) :
+    Module.finrank K (omegaSpace (K := K) (F := F) D) = ell (canonicalDivisorOf hω - D) := by
+  have hinj := residuePairing_injective (canonicalDivisorOf hω) D hmem hne
+  have hsurj := residuePairing_surjective_of_rankOne_max
+    (weilDifferentialRankOne_of_genusReached h) hmem hne hmax D
+  exact (LinearEquiv.ofBijective _ ⟨hinj, hsurj⟩).finrank_eq.symm
+
+omit [∀ (v : Place K F), v.DCoordGenerates] in
+theorem p0n25_wkc_ell_canonicalDivisor_eq_gamma_of_weilMax
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    (hsup : ∀ {ω : Ω[F⁄K]} (hω : ω ≠ 0), ∃ φ : Module.Dual K (adeleSpace K F),
+      φ ≠ 0 ∧ φ ∈ omegaSpace (canonicalDivisorOf hω) ∧
+      ∀ D : Divisor K F, φ ∈ omegaSpace D → D ≤ canonicalDivisorOf hω)
+    (hC : ConstantsAreBase K F) {ω : Ω[F⁄K]} (hω : ω ≠ 0) :
+    (ell (canonicalDivisorOf hω) : ℤ) = γ := by
+  obtain ⟨φ, hne, hmem, hmax⟩ := hsup hω
+  have hΩ0 := p0n25_wkc_finrank_omegaSpace_eq_ell_of_genusReached_of_weilMax
+    h hω hne hmem hmax 0
+  rw [sub_zero] at hΩ0
+  have hi0 := (indexOfSpecialty_eq_of_genusReached h 0).2
+  rw [← finrank_omegaSpace_eq_indexOfSpecialty, hΩ0, _root_.map_zero,
+    ell_zero_eq_one_of_constantsAreBase hC] at hi0
+  push_cast at hi0
+  linarith
+
+omit [∀ (v : Place K F), v.DCoordGenerates] in
+theorem p0n25_wkc_degree_canonicalDivisor_eq_of_weilMax
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    (hsup : ∀ {ω : Ω[F⁄K]} (hω : ω ≠ 0), ∃ φ : Module.Dual K (adeleSpace K F),
+      φ ≠ 0 ∧ φ ∈ omegaSpace (canonicalDivisorOf hω) ∧
+      ∀ D : Divisor K F, φ ∈ omegaSpace D → D ≤ canonicalDivisorOf hω)
+    (hC : ConstantsAreBase K F) {ω : Ω[F⁄K]} (hω : ω ≠ 0) :
+    Divisor.degree (canonicalDivisorOf hω) = 2 * γ - 2 := by
+  obtain ⟨φ, hne, hmem, hmax⟩ := hsup hω
+  have hΩW := p0n25_wkc_finrank_omegaSpace_eq_ell_of_genusReached_of_weilMax
+    h hω hne hmem hmax (canonicalDivisorOf hω)
+  rw [sub_self] at hΩW
+  have hiW := (indexOfSpecialty_eq_of_genusReached h (canonicalDivisorOf hω)).2
+  rw [← finrank_omegaSpace_eq_indexOfSpecialty, hΩW,
+    ell_zero_eq_one_of_constantsAreBase hC] at hiW
+  have hℓW := p0n25_wkc_ell_canonicalDivisor_eq_gamma_of_weilMax h hsup hC hω
+  push_cast at hiW
+  linarith
+
+omit [∀ (v : Place K F), v.DCoordGenerates] in
+theorem p0n25_wkc_stichtenothGenus_eq_genus_of_weilMax
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    (hsup : ∀ {ω : Ω[F⁄K]} (hω : ω ≠ 0), ∃ φ : Module.Dual K (adeleSpace K F),
+      φ ≠ 0 ∧ φ ∈ omegaSpace (canonicalDivisorOf hω) ∧
+      ∀ D : Divisor K F, φ ∈ omegaSpace D → D ≤ canonicalDivisorOf hω)
+    (hC : ConstantsAreBase K F) :
+    γ = (genus K F : ℤ) := by
+  obtain ⟨ω₀, hω₀, hgen⟩ := genus_eq_degree_div (K := K) (F := F)
+  have hdeg := p0n25_wkc_degree_canonicalDivisor_eq_of_weilMax h hsup hC hω₀
+  have hγ0 := stichtenothGenus_nonneg h hC
+  rw [hgen, hdeg]
+  have h2 : (2 * γ - 2 + 2).toNat / 2 = γ.toNat := by omega
+  rw [h2]
+  exact (Int.toNat_of_nonneg hγ0).symm
+
+end MirrorIdentification
+
+section MirrorAssembly
+
+variable (K : Type*) [Field K]
+variable (F : Type*) [Field F] [Algebra K F]
+    [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+variable [IsCurveOver K F] [HasCanonicalDivisor (K := K) (F := F)]
+variable [∀ v : Place K F, v.DCoordGenerates]
+
+omit [∀ (v : Place K F), v.DCoordGenerates] in
+theorem p0n25_wkc_riemannGenusReached_of_weilMax
+    (hsup : ∀ {ω : Ω[F⁄K]} (hω : ω ≠ 0), ∃ φ : Module.Dual K (adeleSpace K F),
+      φ ≠ 0 ∧ φ ∈ omegaSpace (canonicalDivisorOf hω) ∧
+      ∀ D : Divisor K F, φ ∈ omegaSpace D → D ≤ canonicalDivisorOf hω)
+    (hC : ConstantsAreBase K F) :
+    RiemannGenusReached K F (genus K F) := by
+  classical
+  obtain ⟨hne, hL0, γ, D₀, hD₀⟩ := RationalFunctionField.stichtenothGenusExists K F hC
+  have := hne
+  have := hL0
+  have hγeq := p0n25_wkc_stichtenothGenus_eq_genus_of_weilMax hD₀ hsup hC
+  exact ⟨hne, hL0, D₀, hγeq ▸ hD₀⟩
+
+omit [IsCurveOver K F] [∀ (v : Place K F), v.DCoordGenerates] in
+theorem p0n25_wkc_riemannIndexFormula_of_weilMax
+    (hsup : ∀ {ω : Ω[F⁄K]} (hω : ω ≠ 0), ∃ φ : Module.Dual K (adeleSpace K F),
+      φ ≠ 0 ∧ φ ∈ omegaSpace (canonicalDivisorOf hω) ∧
+      ∀ D : Divisor K F, φ ∈ omegaSpace D → D ≤ canonicalDivisorOf hω)
+    (hC : ConstantsAreBase K F) :
+    RiemannIndexFormula K F := by
+  classical
+  refine riemannIndexFormula_of_genusReached ?_
+  intro _ _
+  exact p0n25_wkc_riemannGenusReached_of_weilMax K F hsup hC
+
+omit [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+  [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+  [∀ (v : Place K F), v.DCoordGenerates] in
+theorem p0n25_wkc_weilOmegaEllAgrees_of_weilMax [Nonempty (Place K F)]
+    (hRI : RiemannIndexFormula K F)
+    (hsup : ∀ {ω : Ω[F⁄K]} (hω : ω ≠ 0), ∃ φ : Module.Dual K (adeleSpace K F),
+      φ ≠ 0 ∧ φ ∈ omegaSpace (canonicalDivisorOf hω) ∧
+      ∀ D : Divisor K F, φ ∈ omegaSpace D → D ≤ canonicalDivisorOf hω) :
+    WeilOmegaEllAgrees K F := by
+  classical
+  have hSurj : ResiduePairingSurjective K F :=
+    residuePairingSurjective_of_riemannIndexFormula hRI
+  intro _ _ _ ω hω D
+  obtain ⟨φ, hne, hmem, hmax⟩ := hsup hω
+  have hinj := residuePairing_injective (canonicalDivisorOf hω) D hmem hne
+  have hsurj := hSurj (canonicalDivisorOf hω) D hmem hne hmax
+  exact_mod_cast (LinearEquiv.ofBijective
+    (residuePairing K F (canonicalDivisorOf hω) D hmem) ⟨hinj, hsurj⟩).finrank_eq.symm
+
+omit [IsCurveOver K F] [∀ (v : Place K F), v.DCoordGenerates] in
+theorem p0n25_wkc_functionFieldRiemannRoch_of_weilMax_of_constantsAreBase
+    (hsup : ∀ {ω : Ω[F⁄K]} (hω : ω ≠ 0), ∃ φ : Module.Dual K (adeleSpace K F),
+      φ ≠ 0 ∧ φ ∈ omegaSpace (canonicalDivisorOf hω) ∧
+      ∀ D : Divisor K F, φ ∈ omegaSpace D → D ≤ canonicalDivisorOf hω)
+    (hC : ConstantsAreBase K F) :
+    FunctionFieldRiemannRoch K F := by
+  classical
+  have hRI : RiemannIndexFormula K F :=
+    p0n25_wkc_riemannIndexFormula_of_weilMax K F hsup hC
+  have := RationalFunctionField.nonempty_place_of_ratFunc_tower K F
+  have hΩℓ : WeilOmegaEllAgrees K F :=
+    p0n25_wkc_weilOmegaEllAgrees_of_weilMax K F hRI hsup
+  have hWDA : WeilDualityAdelic K F := weilDualityAdelic_of_residueRows K F hΩℓ
+  have hWD : WeilDuality K F := weilDuality_of_riemannIndex_of_adelic K F hRI hWDA
+  intro _ _ _ ω hω D
+  exact functionFieldRiemannRoch_of_riemann_and_duality K F hWD hω D
+
+omit [IsCurveOver K F] in
+theorem p0n25_wkc_functionFieldRiemannRoch_of_residueTheoremK
+    [HasSeparableResidue K F]
+    (hRTK : ResidueTheoremK K F) (hC : ConstantsAreBase K F) :
+    FunctionFieldRiemannRoch K F := by
+  classical
+  have := RationalFunctionField.nonempty_place_of_ratFunc_tower K F
+  intro _ _ _ ω hω D
+  exact p0n25_wkc_functionFieldRiemannRoch_of_weilMax_of_constantsAreBase K F
+    (fun {ω'} hω' => p0n25_wkc_exists_weilMax_of_residueTheoremK hRTK hω') hC hω D
+
+end MirrorAssembly
+
+end ModularCurve
+
+end
+
+theorem solution
+    {K F : Type*} [Field K] [IsAlgClosed K]
+    [Field F] [Algebra K F]
+    [AlgebraicCurve.HasCanonicalDivisor (K := K) (F := F)]
+    [∀ w : AlgebraicCurve.Place K F, w.DCoordGenerates]
+    [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [Algebra.IsIntegral (RatFunc K) F]
+    [AlgebraicCurve.HasLocalResidue K F]
+    [∀ w : AlgebraicCurve.Place K F, w.FiniteResidue]
+    [Nontrivial Ω[F⁄K]]
+    [AlgebraicCurve.IsCurveOver K F] [AlgebraicCurve.IsCurveOver K (RatFunc K)]
+    [∀ u : AlgebraicCurve.Place K (RatFunc K), u.FiniteResidue]
+    [AlgebraicCurve.HasCanonicalLocalResidueKStar K F]
+    [Algebra.IsSeparable (RatFunc K) F]
+    [Nontrivial Ω[(RatFunc K)⁄K]] [∀ v : AlgebraicCurve.Place K (RatFunc K), v.DCoordGenerates]
+    [FiniteDimensional (RatFunc K) F] [AlgebraicCurve.HasSeparableResidue K F]
+    (hRTK : AlgebraicCurve.ResidueTheoremK K F) :
+    AlgebraicCurve.FunctionFieldRiemannRoch K F := by
+  classical
+  intro _ _ _
+  exact ModularCurve.p0n25_wkc_functionFieldRiemannRoch_of_residueTheoremK K F
+    (hRTK := hRTK) (hC := ModularCurve.p0n20_rr_constantsAreBase_of_isAlgClosed K F)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.functionFieldRiemannRoch_of_residueTheoremK_of_isAlgClosed
+    {K F : Type*} [Field K] [IsAlgClosed K]
+    [Field F] [Algebra K F]
+    [AlgebraicCurve.HasCanonicalDivisor (K := K) (F := F)]
+    [∀ w : AlgebraicCurve.Place K F, w.DCoordGenerates]
+    [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [Algebra.IsIntegral (RatFunc K) F]
+    [AlgebraicCurve.HasLocalResidue K F]
+    [∀ w : AlgebraicCurve.Place K F, w.FiniteResidue]
+    [Nontrivial Ω[F⁄K]]
+    [AlgebraicCurve.IsCurveOver K F] [AlgebraicCurve.IsCurveOver K (RatFunc K)]
+    [∀ u : AlgebraicCurve.Place K (RatFunc K), u.FiniteResidue]
+    [AlgebraicCurve.HasCanonicalLocalResidueKStar K F]
+    [Algebra.IsSeparable (RatFunc K) F]
+    [Nontrivial Ω[(RatFunc K)⁄K]] [∀ v : AlgebraicCurve.Place K (RatFunc K), v.DCoordGenerates]
+    [FiniteDimensional (RatFunc K) F] [AlgebraicCurve.HasSeparableResidue K F]
+    (hRTK : AlgebraicCurve.ResidueTheoremK K F) :
+    AlgebraicCurve.FunctionFieldRiemannRoch K F := by
+  classical
+  -- `by exact` to suppress a linter warning (instance in conclusion overlaps with hypotheses)
+  exact solution hRTK
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_genusFF_eq_of_constantFieldExtension_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_genusFF_eq_of_constantFieldExtension_of_isAlgClosed.lean
new file mode 100644
index 0000000000..560d7c8810
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_genusFF_eq_of_constantFieldExtension_of_isAlgClosed.lean
@@ -0,0 +1,105 @@
+/-
+Based on Prove2Me node AlgebraicCurve.genusFF_eq_of_constantFieldExtension_of_isAlgClosed
+(729c32da-a2e4-5d19-9e97-4cb53850663c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission de1dccfb-35d0-5415-9e5e-71b0e5fa33ed
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Repartitions
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_genusFF_le_of_constantFieldExtension_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_le_genusFF_of_constantFieldExtension_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Genus invariance under algebraically closed constant field extension
+
+Theorem statement: `AlgebraicCurve.genusFF_eq_of_constantFieldExtension_of_isAlgClosed`
+(`729c32da-a2e4-5d19-9e97-4cb53850663c`), by Claude, 2026-09-05.
+
+Proof: submission `de1dccfb-35d0-5415-9e5e-71b0e5fa33ed`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $K'$, $F'$ be fields with algebra maps $K \to F$, $K' \to F'$, $K \to K'$, $F \to F'$
+and $K \to F'$, the last compatible with the towers $K \to K' \to F'$ and $K \to F \to F'$, and
+suppose $K$ and $K'$ are algebraically closed. Assume $F$ is a function field of one variable over
+$K$ in the sense that some $x \in F$ is transcendental over $K$ and $F$ is finite-dimensional over
+the intermediate field $K(x)$ generated by $x$, and likewise that some $x \in F'$ is transcendental
+over $K'$ with $F'$ finite-dimensional over $K'(x)$. Assume further that $F/K$ and $F'/K'$ both
+satisfy `IsCurveOver`: every nonzero element has an associated divisor recording its orders at all
+places and of degree $0$, each place having residue field finite over the base field, and the module
+of Kähler differentials of the function field over the base field free of rank one. Here a place of
+$F/K$ is a valuation subring of $F$ containing the image of $K$, different from $F$ itself, and a
+principal ideal ring. Finally, assume the $K'$-intermediate field of $F'$ generated by the image of
+$F$ is all of $F'$. Then the two adelic genera agree: $\dim_{K'} H^1(0) = \dim_K H^1(0)$, that is,
+`genusFF K' F' = genusFF K F`, where the genus is the dimension over the base field of the
+repartition cohomology group $H^1$ of the zero divisor.
+
+This is the invariance of the genus of an algebraic function field of one variable under extension
+of an algebraically closed constant field, in arbitrary characteristic, formulated for the adelic
+(repartition) definition of the genus. It is used throughout the curve-theoretic part of the
+development, for instance in comparing orders of divisors after a constant field extension and in
+the Abel–Jacobi and point-counting statements over finite fields.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_genusFF_eq_of_constantFieldExtension_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_genusFF_eq_of_constantFieldExtension_of_isAlgClosed
+
+open AlgebraicCurve
+
+theorem solution (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [IsAlgClosed K']
+    (hfg : ∃ x : F, Transcendental K x ∧ FiniteDimensional (IntermediateField.adjoin K ({x} : Set
+      F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    [IsCurveOver K F] [IsCurveOver K' F']
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤) :
+    genusFF K' F' = genusFF K F :=
+  Nat.le_antisymm
+    (AlgebraicCurve.genusFF_le_of_constantFieldExtension_of_isAlgClosed K F K' F' hfg hfg' hgen)
+    (AlgebraicCurve.le_genusFF_of_constantFieldExtension_of_isAlgClosed K F K' F' hfg hfg' hgen)
+
+end S_AlgebraicCurve_genusFF_eq_of_constantFieldExtension_of_isAlgClosed
+end P2MW
+export P2MW.S_AlgebraicCurve_genusFF_eq_of_constantFieldExtension_of_isAlgClosed (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.genusFF_eq_of_constantFieldExtension_of_isAlgClosed (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [IsAlgClosed K']
+    (hfg : ∃ x : F, Transcendental K x ∧ FiniteDimensional (IntermediateField.adjoin K ({x} : Set
+      F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    [IsCurveOver K F] [IsCurveOver K' F']
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤) :
+    genusFF K' F' = genusFF K F :=
+  solution K F K' F' hfg hfg' hgen
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_genusFF_le_of_constantFieldExtension_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_genusFF_le_of_constantFieldExtension_of_isAlgClosed.lean
new file mode 100644
index 0000000000..5914cb2524
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_genusFF_le_of_constantFieldExtension_of_isAlgClosed.lean
@@ -0,0 +1,213 @@
+/-
+Based on Prove2Me node AlgebraicCurve.genusFF_le_of_constantFieldExtension_of_isAlgClosed
+(90cf01c5-1813-5cdd-8060-f05695a4ba29) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8e049f4f-7be9-549b-afe2-0404d97907c2
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Repartitions
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_comap_algebraMap_eq_of_constantFieldExtension_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_mapDomain_eq_of_constantFieldExtension_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_essFiniteType_of_transcendental_of_finiteDimensional
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_genus_riemannIndex_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_indexOfSpecialty_mapDomain_eq_zero_of_constantFieldExtension_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteDimensional_lSpace
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_finrank_H1
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_stichtenothGenusExists_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Genus does not increase under algebraically closed constant field extension
+
+Theorem statement: `AlgebraicCurve.genusFF_le_of_constantFieldExtension_of_isAlgClosed`
+(`90cf01c5-1813-5cdd-8060-f05695a4ba29`), by Claude, 2026-09-05.
+
+Proof: submission `8e049f4f-7be9-549b-afe2-0404d97907c2`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K, F, K', F'$ be fields with $F$ a $K$-algebra, $F'$ a $K'$-algebra, $K'$ and $F'$ algebras
+over $K$ and $F$ respectively, arranged in compatible towers $K \to K' \to F'$ and $K \to F \to F'$,
+and assume $K$ and $K'$ are algebraically closed. Assume that $F$ contains an element $x$
+transcendental over $K$ with $F$ finite-dimensional over $K(x)$, and likewise that $F'$ contains an
+element transcendental over $K'$ with $F'$ finite over the subfield it generates; so $F/K$ and
+$F'/K'$ are function fields of one variable. Assume further that each of $F/K$ and $F'/K'$ satisfies
+`IsCurveOver`: every nonzero element has an associated divisor of degree $0$ recording its orders at
+all places (a place being a proper valuation subring containing the image of the constant field and
+which is a principal ideal ring), every place has residue field finite-dimensional over the constant
+field, and the module of Kähler differentials is free of rank one over the function field. Assume
+finally that the $K'$-subfield of $F'$ generated by the image of $F$ is all of $F'$. Then $\dim_{K'}
+H^1(0) \le \dim_K H^1(0)$, i.e. `genusFF K' F' ≤ genusFF K F` for the repartition genus.
+
+This is one inequality of the classical statement that the genus of a one-variable function field is
+unchanged by extension of an algebraically closed constant field. It is used by
+[`AlgebraicCurve.genusFF_eq_of_constantFieldExtension_of_isAlgClosed`]
+(thm.html#AlgebraicCurve.genusFF_eq_of_constantFieldExtension_of_isAlgClosed),
+which combines it with the opposite inequality.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_genusFF_le_of_constantFieldExtension_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_genusFF_le_of_constantFieldExtension_of_isAlgClosed
+
+
+open AlgebraicCurve
+
+namespace W7XGenusFFLE
+
+theorem constantsAreBase {K F : Type*} [Field K] [Field F] [Algebra K F] [IsAlgClosed K]
+    [IsCurveOver K F]
+    (hfg : ∃ x : F, Transcendental K x ∧
+      FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F) :
+    ConstantsAreBase K F := by
+  obtain ⟨x, hxt, hxfd⟩ := hfg
+  have : HasPrincipalDivisors K F := IsCurveOver.hasPrincipalDivisors
+  refine le_antisymm (fun f hf => ?_) (fun f ⟨c, hc⟩ => hc ▸ fun v =>
+    Place.adicValuation_algebraMap_le_one v c)
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact zero_mem _
+  have hord : ∀ v : Place K F, 0 ≤ v.ord f := fun v => by
+    have := (mem_riemannRochSpace_iff.mp hf v).resolve_left hf0; simpa using this
+  obtain ⟨Df, hDord, hDdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) (F := F) f hf0
+  have hdiv : ∀ v : Place K F, v.ord f = 0 := by
+    by_contra hne; push Not at hne; obtain ⟨v, hv⟩ := hne
+    refine absurd hDdeg (ne_of_gt ?_)
+    rw [Divisor.degree_eq_sum_support]
+    refine Finset.sum_pos' (fun w _ => mul_nonneg (by rw [hDord w]; exact hord w)
+      (Int.natCast_nonneg _)) ⟨v, ?_, ?_⟩
+    · simp only [Finsupp.mem_support_iff, hDord v]; exact hv
+    · rw [hDord v]
+      have : Module.Finite K v.ResidueField := IsCurveOver.finiteResidue v
+      have : (v.deg : ℤ) = 1 := by exact_mod_cast Place.deg_eq_one_of_isAlgClosed_of_finite v
+      rw [this, mul_one]; exact (hord v).lt_of_ne' hv
+  exact ⟨_, (Place.mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed x hxt
+    (F := F) hdiv).choose_spec⟩
+
+end W7XGenusFFLE
+
+open W7XGenusFFLE
+
+theorem solution (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [IsAlgClosed K']
+    (hfg : ∃ x : F, Transcendental K x ∧ FiniteDimensional (IntermediateField.adjoin K ({x} : Set
+      F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    [IsCurveOver K F] [IsCurveOver K' F']
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤) :
+    genusFF K' F' ≤ genusFF K F := by
+  classical
+  obtain ⟨x, hxt, hxfd⟩ := id hfg
+  obtain ⟨x', hxt', hxfd'⟩ := id hfg'
+  have : Algebra.EssFiniteType K F :=
+    essFiniteType_of_transcendental_of_finiteDimensional hxt hxfd
+  have : Algebra.EssFiniteType K' F' :=
+    essFiniteType_of_transcendental_of_finiteDimensional hxt' hxfd'
+  have hCAB : ConstantsAreBase K F := constantsAreBase hfg
+  have hCAB' : ConstantsAreBase K' F' := constantsAreBase hfg'
+  have : HasPrincipalDivisors K F := IsCurveOver.hasPrincipalDivisors
+  have : HasPrincipalDivisors K' F' := IsCurveOver.hasPrincipalDivisors
+  obtain ⟨γ, hγ⟩ := exists_genus_riemannIndex_of_isCurveOver (K := K) (F := F) hCAB
+  obtain ⟨γ', hγ'⟩ := exists_genus_riemannIndex_of_isCurveOver (K := K') (F := F') hCAB'
+  have hγeq : γ = (genusFF K F : ℤ) := by
+    have h0 := (hγ 0).2
+    rw [show Divisor.degree (0 : Divisor K F) = 0 from map_zero _,
+      ell_zero_eq_one_of_constantsAreBase hCAB,
+      indexOfSpecialty_eq_finrank_H1 (K := K) (F := F) 0] at h0
+    unfold genusFF; push_cast at h0 ⊢; linarith
+  have hγeq' : γ' = (genusFF K' F' : ℤ) := by
+    have h0 := (hγ' 0).2
+    rw [show Divisor.degree (0 : Divisor K' F') = 0 from map_zero _,
+      ell_zero_eq_one_of_constantsAreBase hCAB',
+      indexOfSpecialty_eq_finrank_H1 (K := K') (F := F') 0] at h0
+    unfold genusFF; push_cast at h0 ⊢; linarith
+  have hX := fun P =>
+    Place.exists_comap_algebraMap_eq_of_constantFieldExtension_of_isAlgClosed
+      K F K' F' hfg hfg' hgen P
+  choose lift hlift_comap hlift_ord hlift_uniq using hX
+  have hlift_inj : Function.Injective lift := fun P Q h => by
+    have hP := hlift_comap P; have hQ := h ▸ hlift_comap Q
+    exact Place.ext (hP.symm.trans hQ)
+  have hlift_new : ∀ v' : Place K' F', (∀ v, lift v ≠ v') →
+      ∀ v : Place K F, v'.toValuationSubring.comap (algebraMap F F') ≠ v.toValuationSubring :=
+    fun v' hnv v hcomap => hnv v ((hlift_uniq v v' hcomap).symm)
+  have : ∀ v : Place K F, Module.Finite K v.ResidueField := fun v => IsCurveOver.finiteResidue v
+  have : ∀ v' : Place K' F', Module.Finite K' v'.ResidueField :=
+    fun v' => IsCurveOver.finiteResidue v'
+  obtain ⟨D, hiD'⟩ :=
+    exists_indexOfSpecialty_mapDomain_eq_zero_of_constantFieldExtension_of_isAlgClosed
+      K F K' F' hfg hfg' lift
+  set D' : Divisor K' F' := Finsupp.mapDomain lift D with hD'def
+  have hdegEq : Divisor.degree D' = Divisor.degree D := by
+    rw [Divisor.degree_eq_sum_support, Divisor.degree_eq_sum_support, hD'def,
+      Finsupp.mapDomain_support_of_injective hlift_inj,
+      Finset.sum_image (fun a _ b _ h => hlift_inj h)]
+    refine Finset.sum_congr rfl fun v _ => ?_
+    rw [Finsupp.mapDomain_apply_of_injective hlift_inj,
+      show ((lift v).deg : ℤ) = 1 from by
+        exact_mod_cast Place.deg_eq_one_of_isAlgClosed_of_finite (lift v),
+      show ((v.deg : ℤ)) = 1 from by exact_mod_cast Place.deg_eq_one_of_isAlgClosed_of_finite v]
+  obtain ⟨hne, hfd0, γ₀, D₀, hD₀⟩ := stichtenothGenusExists_of_isCurveOver (K := K) (F := F) hCAB
+  have : FiniteDimensional K ↥(LSpace (0 : Divisor K F)) := hfd0
+  have hfdD : FiniteDimensional K ↥(riemannRochSpace D) := finiteDimensional_lSpace D
+  have hellEq : ell (K := K') D' = ell (K := K) D := by
+    rw [hD'def]
+    exact ell_mapDomain_eq_of_constantFieldExtension_of_isAlgClosed K F K' F' hfg hfg' hgen
+      lift hlift_ord hlift_inj hlift_new D
+  have hiD : (0:ℤ) ≤ γ - γ' := by
+    have h1 := (hγ' D').2
+    rw [hiD', Nat.cast_zero] at h1
+    have h2 : (ell (K := K') D' : ℤ) = Divisor.degree D' + 1 - γ' := by linarith
+    rw [hdegEq, hellEq] at h2
+    have h3 := (hγ D).2
+    have hnn : (0:ℤ) ≤ (indexOfSpecialty (K := K) D : ℤ) := Int.natCast_nonneg _
+    linarith
+  have hγle : γ' ≤ γ := by linarith
+  rw [hγeq, hγeq'] at hγle
+  exact_mod_cast hγle
+
+end S_AlgebraicCurve_genusFF_le_of_constantFieldExtension_of_isAlgClosed
+end P2MW
+export P2MW.S_AlgebraicCurve_genusFF_le_of_constantFieldExtension_of_isAlgClosed (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.genusFF_le_of_constantFieldExtension_of_isAlgClosed (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [IsAlgClosed K']
+    (hfg : ∃ x : F, Transcendental K x ∧ FiniteDimensional (IntermediateField.adjoin K ({x} : Set
+      F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    [IsCurveOver K F] [IsCurveOver K' F']
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤) :
+    genusFF K' F' ≤ genusFF K F :=
+  solution K F K' F' hfg hfg' hgen
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_genus_eq_genusFF.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_genus_eq_genusFF.lean
new file mode 100644
index 0000000000..870e95cb08
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_genus_eq_genusFF.lean
@@ -0,0 +1,106 @@
+/-
+Based on Prove2Me node AlgebraicCurve.genus_eq_genusFF
+(35ea4d8e-84ab-5bbb-a01c-f993cbf6ce66) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 854eb426-e870-5e37-b092-36e34e7cc43c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RiemannRochRows
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_canonicalDivisor_eq_genus_of_riemannRoch
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_finrank_H1
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Canonical-degree genus equals the adelic genus dim_K H¹(0)
+
+Theorem statement: `AlgebraicCurve.genus_eq_genusFF` (`35ea4d8e-84ab-5bbb-a01c-f993cbf6ce66`), by
+Claude, 2026-09-05.
+
+Proof: submission `854eb426-e870-5e37-b092-36e34e7cc43c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and assume $F/K$ is a curve in the project's
+sense, i.e. `IsCurveOver K F`: every nonzero $f \in F$ has a divisor $D$ with $D(v) =
+v.\mathrm{ord}(f)$ at every place $v$ and $\deg D = 0$, every residue field
+$v.\mathrm{ResidueField}$ is finite-dimensional over $K$, and $\Omega[F/K]$ is free of rank one over
+$F$. Assume further `HasCanonicalDivisor`, that every nonzero $\omega \in \Omega[F/K]$ admits a
+divisor whose value at each place $v$ is $v.\mathrm{ordDifferential}(\omega)$, and that for each
+place $v$ the element $v.\mathrm{dCoord}$ spans $\Omega[F/K]$ over $F$. Three further hypotheses are
+assumed: `FunctionFieldRiemannRoch`, that $\ell(D) - \ell(K_\omega - D) = \deg D + 1 - g$ for every
+nonzero $\omega$ (with $K_\omega$ the associated canonical divisor) and every divisor $D$;
+`WeilDualityAdelic`, that the index of specialty $i(D)$, defined as the $K$-dimension of the adele
+space modulo the sum of the bounded-adeles subspace of $D$ and the image of $F$, equals
+$\ell(K_\omega - D)$; and `ConstantsAreBase`, that the Riemann–Roch space of the zero divisor is
+exactly $K \cdot 1 \subseteq F$. The conclusion is that `genus K F`, namely $(\deg K_\omega + 2)/2$
+for a classically chosen nonzero differential, equals `genusFF K F`, namely $\dim_K H^1(0)$.
+
+This reconciles the two definitions of the genus of a one-variable function field: the one read off
+from the degree of a canonical divisor and the adelic one, $\dim_K \mathbb{A}_F/(\mathbb{A}_F(0) +
+F)$. It is the bridge used by the downstream results about $\mathrm{Pic}^0$ and its torsion, which
+are stated in terms of `genusFF`.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_genus_eq_genusFF.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_genus_eq_genusFF
+
+open AlgebraicCurve KaehlerDifferential
+
+theorem solution
+    {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [AlgebraicCurve.IsCurveOver K F] [AlgebraicCurve.HasCanonicalDivisor (K := K) (F := F)]
+    [∀ v : AlgebraicCurve.Place K F, v.DCoordGenerates]
+    (hRR : AlgebraicCurve.FunctionFieldRiemannRoch K F)
+    (hWDA : AlgebraicCurve.WeilDualityAdelic K F)
+    (hC : AlgebraicCurve.ConstantsAreBase K F) :
+    AlgebraicCurve.genus K F = AlgebraicCurve.genusFF K F := by
+  have : HasPrincipalDivisors K F := IsCurveOver.hasPrincipalDivisors
+  obtain ⟨ω, hω⟩ := exists_ne (0 : Ω[F⁄K])
+  have h1 : (indexOfSpecialty (0 : Divisor K F) : ℤ) = (ell (canonicalDivisorOf hω - 0) : ℤ) :=
+    hWDA hω 0
+  rw [sub_zero] at h1
+  have h2 : (ell (canonicalDivisorOf hω) : ℤ) = (genus K F : ℤ) :=
+    ell_canonicalDivisor_eq_genus_of_riemannRoch hRR hC hω
+  have h3 : indexOfSpecialty (0 : Divisor K F) = Module.finrank K (H1 (0 : Divisor K F)) :=
+    indexOfSpecialty_eq_finrank_H1 0
+  have h4 : (indexOfSpecialty (0 : Divisor K F) : ℤ) = (genusFF K F : ℤ) := by
+    rw [genusFF, ← h3]
+  have : (genus K F : ℤ) = (genusFF K F : ℤ) := by
+    rw [← h4, h1, h2]
+  exact_mod_cast this
+
+end S_AlgebraicCurve_genus_eq_genusFF
+end P2MW
+export P2MW.S_AlgebraicCurve_genus_eq_genusFF (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.genus_eq_genusFF
+    {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [AlgebraicCurve.IsCurveOver K F] [AlgebraicCurve.HasCanonicalDivisor (K := K) (F := F)]
+    [∀ v : AlgebraicCurve.Place K F, v.DCoordGenerates]
+    (hRR : AlgebraicCurve.FunctionFieldRiemannRoch K F)
+    (hWDA : AlgebraicCurve.WeilDualityAdelic K F)
+    (hC : AlgebraicCurve.ConstantsAreBase K F) :
+    AlgebraicCurve.genus K F = AlgebraicCurve.genusFF K F :=
+  solution hRR hWDA hC
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_hasCanonicalDivisor_of_isCurveOver.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_hasCanonicalDivisor_of_isCurveOver.lean
new file mode 100644
index 0000000000..8119fbb8cf
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_hasCanonicalDivisor_of_isCurveOver.lean
@@ -0,0 +1,1833 @@
+/-
+Based on Prove2Me node AlgebraicCurve.hasCanonicalDivisor_of_isCurveOver
+(84375f49-6cc7-5c4e-b9b7-b80767fb5a0d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 175dc8a0-b4e7-556f-bde0-4a025636ddec
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_CanonicalDivisor
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import Mathlib.RingTheory.DedekindDomain.Different
+import Mathlib.RingTheory.Adjoin.Polynomial.Transcendental
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_IsCurveOver_exists_separating_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_KaehlerDifferential_D_ne_zero_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_KaehlerDifferential_span_D_eq_top_of_transcendental
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of canonical divisors on a curve over a perfect field
+
+Theorem statement: `AlgebraicCurve.hasCanonicalDivisor_of_isCurveOver`
+(`84375f49-6cc7-5c4e-b9b7-b80767fb5a0d`), by Claude, 2026-09-05.
+
+Proof: submission `175dc8a0-b4e7-556f-bde0-4a025636ddec`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, assume $K$ is perfect, that $F$ is essentially of
+finite type over $K$, and that [`AlgebraicCurve.IsCurveOver K
+F`](def/AlgebraicCurve_IsCurveOver.html#L15) holds; the latter says three things: (i) principal
+divisors exist, i.e. for every $f \in F^{\times}$ there is a finitely supported function $D \colon
+\mathrm{Place}\,K\,F \to \mathbb{Z}$ with $D(v) = \mathrm{ord}_v(f)$ at every place $v$ and $\deg D
+= 0$, where a place of $F/K$ is a valuation subring of $F$ containing the image of $K$, different
+from $F$ itself, and a principal ideal ring; (ii) for every place $v$ the residue field of that
+valuation subring is a finite-dimensional $K$-module; and (iii) the module of Kähler differentials
+$\Omega_{F/K}$ is free of rank one over $F$. The conclusion is
+[`AlgebraicCurve.HasCanonicalDivisor`](def/AlgebraicCurve_CanonicalDivisor.html#L14): for every
+$\omega \in \Omega_{F/K}$ with $\omega \neq 0$ there is a finitely supported divisor $D \colon
+\mathrm{Place}\,K\,F \to_{f} \mathbb{Z}$ such that, for every place $v$, $D(v)$ equals
+$\mathrm{ord}_v$ of the coefficient of $\omega$ read off against the local differential at $v$, that
+is $D(v) = v.\mathrm{ordDifferential}(\omega)$.
+
+This is the existence of canonical divisors on a curve: the local orders of a nonzero differential
+vanish at all but finitely many places, so a differential determines a divisor class. It is the
+hypothesis under which Riemann–Roch theory for $\Omega_{F/K}$ is developed in this formalisation,
+and it is invoked generically for every curve over a perfect base, including the function fields of
+the modular curves $X_0(N)$ used later.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_hasCanonicalDivisor_of_isCurveOver.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_hasCanonicalDivisor_of_isCurveOver
+
+
+open IsDedekindDomain
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.FiniteResidue HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor Place.FiniteResidue.finite HasCanonicalDivisor \
+  IsCurveOver.exists_separating_transcendental"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue ord ord_zero ord_one ord_mul \
+  ord_inv ord_coe_unit ord_coe_irreducible ord_unit_smul_zpow exists_unit_mul_zpow ne_top' \
+  FiniteResidue.finite algebraMap_mem' toValuationSubring dCoord DCoordGenerates dCoord_ne_zero \
+  differentialCoeff differentialCoeff_smul_dCoord differentialCoeff_unique ordDifferential \
+  ordDifferential_smul mem_maximalIdeal_iff_ord_pos"
+p2m_open "AlgebraicCurve.Place"
+
+section Transport
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private noncomputable def _root_.AlgebraicCurve.Place.uniformizerSubring' : v.toValuationSubring :=
+  (IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose
+
+p2m_export "AlgebraicCurve.Place" "uniformizerSubring'"
+private scoped instance instSMulCommClass_subring : SMulCommClass K v.toValuationSubring F :=
+  IsScalarTower.to_smulCommClass
+
+private theorem _root_.AlgebraicCurve.Place.kaehlerMap_subring_D_uniformizer :
+    KaehlerDifferential.map K K v.toValuationSubring F
+      (KaehlerDifferential.D K v.toValuationSubring v.uniformizerSubring') = v.dCoord := by
+  rw [KaehlerDifferential.map_D K K v.toValuationSubring F]
+  rfl
+
+p2m_export "AlgebraicCurve.Place" "kaehlerMap_subring_D_uniformizer"
+end Transport
+
+end Place
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def ValSubringKaehlerSpanTop : Prop :=
+  ∀ v : Place K F,
+    Submodule.span v.toValuationSubring
+      {KaehlerDifferential.D K v.toValuationSubring (Place.uniformizerSubring' v)} = ⊤
+
+end AlgebraicCurve
+
+open IsDedekindDomain Polynomial
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.FiniteResidue HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor Place.FiniteResidue.finite HasCanonicalDivisor \
+  IsCurveOver.exists_separating_transcendental"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue ord ord_zero ord_one ord_mul \
+  ord_inv ord_coe_unit ord_coe_irreducible ord_unit_smul_zpow exists_unit_mul_zpow ne_top' \
+  FiniteResidue.finite algebraMap_mem' toValuationSubring dCoord DCoordGenerates dCoord_ne_zero \
+  differentialCoeff differentialCoeff_smul_dCoord differentialCoeff_unique ordDifferential \
+  ordDifferential_smul mem_maximalIdeal_iff_ord_pos"
+p2m_open "AlgebraicCurve.Place"
+
+section CotangentEngine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private noncomputable def _root_.AlgebraicCurve.Place.uniformizerSubring'' : v.toValuationSubring :=
+  (IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose
+
+p2m_export "AlgebraicCurve.Place" "uniformizerSubring''"
+@[reducible] private noncomputable def _root_.AlgebraicCurve.Place.polynomialAlgebra :
+    Algebra K[X] v.toValuationSubring :=
+  (Polynomial.aeval (R := K) v.uniformizerSubring'').toRingHom.toAlgebra
+
+p2m_export "AlgebraicCurve.Place" "polynomialAlgebra"
+private theorem _root_.AlgebraicCurve.Place.polynomialAlgebra_algebraMap_X :
+    letI := v.polynomialAlgebra
+    algebraMap K[X] v.toValuationSubring X = v.uniformizerSubring'' :=
+  aeval_X _
+
+p2m_export "AlgebraicCurve.Place" "polynomialAlgebra_algebraMap_X"
+private lemma _root_.AlgebraicCurve.Place.polynomialIsScalarTower :
+    letI := v.polynomialAlgebra
+    IsScalarTower K K[X] v.toValuationSubring := by
+  let := v.polynomialAlgebra
+  refine IsScalarTower.of_algebraMap_eq fun a => ?_
+  change _ = aeval v.uniformizerSubring'' (algebraMap K K[X] a)
+  simp [Polynomial.algebraMap_eq, aeval_C]
+
+p2m_export "AlgebraicCurve.Place" "polynomialIsScalarTower"
+private theorem _root_.AlgebraicCurve.Place.range_mapBaseChange_le_span_D_uniformizer :
+    letI := v.polynomialAlgebra
+    letI := v.polynomialIsScalarTower
+    LinearMap.range (KaehlerDifferential.mapBaseChange K K[X] v.toValuationSubring)
+      ≤ Submodule.span v.toValuationSubring
+          {KaehlerDifferential.D K v.toValuationSubring v.uniformizerSubring''} := by
+  let := v.polynomialAlgebra
+  let := v.polynomialIsScalarTower
+  rintro _ ⟨t, rfl⟩
+  induction t with
+  | add x y hx hy => rw [map_add]; exact add_mem hx hy
+  | tmul b ω =>
+    rw [KaehlerDifferential.mapBaseChange_tmul,
+      show ω = (KaehlerDifferential.polynomialEquiv K ω) • (KaehlerDifferential.D K K[X] X) from
+        ((KaehlerDifferential.polynomialEquiv K).symm_apply_apply ω).symm.trans
+          (KaehlerDifferential.polynomialEquiv_symm K _),
+      LinearMap.map_smul, KaehlerDifferential.map_D,
+      show algebraMap K[X] v.toValuationSubring X = v.uniformizerSubring'' from aeval_X _,
+      ← algebraMap_smul (A := v.toValuationSubring)]
+    exact Submodule.smul_mem _ b
+      (Submodule.smul_mem _ _ (Submodule.mem_span_singleton_self _))
+
+p2m_export "AlgebraicCurve.Place" "range_mapBaseChange_le_span_D_uniformizer"
+private theorem _root_.AlgebraicCurve.Place.range_mapBaseChange_eq_top_of_subsingleton
+    (hsub :
+      letI := v.polynomialAlgebra
+      Subsingleton Ω[v.toValuationSubring⁄K[X]]) :
+    letI := v.polynomialAlgebra
+    letI := v.polynomialIsScalarTower
+    LinearMap.range (KaehlerDifferential.mapBaseChange K K[X] v.toValuationSubring) = ⊤ := by
+  let := v.polynomialAlgebra
+  let := v.polynomialIsScalarTower
+  rw [KaehlerDifferential.range_mapBaseChange]
+  exact LinearMap.ker_eq_top.mpr (Subsingleton.elim _ _)
+
+p2m_export "AlgebraicCurve.Place" "range_mapBaseChange_eq_top_of_subsingleton"
+private theorem _root_.AlgebraicCurve.Place.span_D_uniformizer_eq_top_of_subsingleton
+    (hsub :
+      letI := v.polynomialAlgebra
+      Subsingleton Ω[v.toValuationSubring⁄K[X]]) :
+    Submodule.span v.toValuationSubring
+      {KaehlerDifferential.D K v.toValuationSubring v.uniformizerSubring''} = ⊤ := by
+  refine top_le_iff.mp ?_
+  rw [← v.range_mapBaseChange_eq_top_of_subsingleton hsub]
+  exact v.range_mapBaseChange_le_span_D_uniformizer
+
+p2m_export "AlgebraicCurve.Place" "span_D_uniformizer_eq_top_of_subsingleton"
+end CotangentEngine
+end Place
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def ValSubringPolynomialFormallyUnramified : Prop :=
+  ∀ v : Place K F,
+    letI := v.polynomialAlgebra
+    Subsingleton Ω[v.toValuationSubring⁄K[X]]
+
+variable {K F}
+
+theorem valSubringKaehlerSpanTop_of_polynomialFormallyUnramified
+    (hfu : ValSubringPolynomialFormallyUnramified K F) :
+    ValSubringKaehlerSpanTop K F :=
+  fun v => v.span_D_uniformizer_eq_top_of_subsingleton (hfu v)
+
+end AlgebraicCurve
+
+open IsDedekindDomain Polynomial IsLocalRing
+open scoped TensorProduct
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.FiniteResidue HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor Place.FiniteResidue.finite HasCanonicalDivisor \
+  IsCurveOver.exists_separating_transcendental"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue ord ord_zero ord_one ord_mul \
+  ord_inv ord_coe_unit ord_coe_irreducible ord_unit_smul_zpow exists_unit_mul_zpow ne_top' \
+  FiniteResidue.finite algebraMap_mem' toValuationSubring dCoord DCoordGenerates dCoord_ne_zero \
+  differentialCoeff differentialCoeff_smul_dCoord differentialCoeff_unique ordDifferential \
+  ordDifferential_smul mem_maximalIdeal_iff_ord_pos"
+p2m_open "AlgebraicCurve.Place"
+
+section ResidueEngine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private noncomputable def _root_.AlgebraicCurve.Place.uniformizerSubring''' :
+    v.toValuationSubring :=
+  (IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose
+
+p2m_export "AlgebraicCurve.Place" "uniformizerSubring'''"
+private theorem _root_.AlgebraicCurve.Place.irreducible_uniformizerSubring''' :
+    Irreducible v.uniformizerSubring''' :=
+  (IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose_spec
+
+p2m_export "AlgebraicCurve.Place" "irreducible_uniformizerSubring'''"
+private theorem _root_.AlgebraicCurve.Place.maximalIdeal_eq_span_uniformizer :
+    IsLocalRing.maximalIdeal v.toValuationSubring = Ideal.span {v.uniformizerSubring'''} :=
+  (IsDiscreteValuationRing.irreducible_iff_uniformizer _).mp v.irreducible_uniformizerSubring'''
+
+p2m_export "AlgebraicCurve.Place" "maximalIdeal_eq_span_uniformizer"
+private theorem _root_.AlgebraicCurve.Place.D_polynomialAlgebra_uniformizer :
+    letI := v.polynomialAlgebra
+    KaehlerDifferential.D K[X] v.toValuationSubring v.uniformizerSubring''' = 0 := by
+  let := v.polynomialAlgebra
+  rw [show v.uniformizerSubring''' = algebraMap K[X] v.toValuationSubring X from
+    (v.polynomialAlgebra_algebraMap_X).symm]
+  exact (KaehlerDifferential.D K[X] v.toValuationSubring).map_algebraMap X
+
+p2m_export "AlgebraicCurve.Place" "D_polynomialAlgebra_uniformizer"
+private theorem _root_.AlgebraicCurve.Place.ker_algebraMap_residueField_eq_span :
+    RingHom.ker (algebraMap v.toValuationSubring v.ResidueField)
+      = Ideal.span {v.uniformizerSubring'''} := by
+  rw [IsLocalRing.ResidueField.algebraMap_eq, IsLocalRing.ker_residue,
+    v.maximalIdeal_eq_span_uniformizer]
+
+p2m_export "AlgebraicCurve.Place" "ker_algebraMap_residueField_eq_span"
+private theorem
+  _root_.AlgebraicCurve.Place.formallyUnramified_polynomial_residueField_of_isSeparable
+    [Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring)] :
+    letI := v.polynomialAlgebra
+    Algebra.FormallyUnramified K[X] (IsLocalRing.ResidueField v.toValuationSubring) := by
+  let := v.polynomialAlgebra
+  let := v.polynomialIsScalarTower
+  have : Algebra.FormallyUnramified K (IsLocalRing.ResidueField v.toValuationSubring) :=
+    Algebra.FormallyUnramified.of_isSeparable K _
+  exact Algebra.FormallyUnramified.of_restrictScalars K K[X] _
+
+p2m_export "AlgebraicCurve.Place" "formallyUnramified_polynomial_residueField_of_isSeparable"
+private theorem _root_.AlgebraicCurve.Place.subsingleton_residueKaehler_of_isSeparable
+    [Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring)] :
+    letI := v.polynomialAlgebra
+    Subsingleton Ω[(IsLocalRing.ResidueField v.toValuationSubring)⁄K[X]] := by
+  let := v.polynomialAlgebra
+  have := v.formallyUnramified_polynomial_residueField_of_isSeparable
+  exact Algebra.FormallyUnramified.subsingleton_kaehlerDifferential
+
+p2m_export "AlgebraicCurve.Place" "subsingleton_residueKaehler_of_isSeparable"
+private theorem
+  _root_.AlgebraicCurve.Place.subsingleton_residueTensor_polynomialKaehler_of_isSeparable
+    [Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring)] :
+    letI := v.polynomialAlgebra
+    Subsingleton (v.ResidueField ⊗[v.toValuationSubring] Ω[v.toValuationSubring⁄K[X]]) := by
+  let := v.polynomialAlgebra
+  let := v.polynomialIsScalarTower
+  have := v.subsingleton_residueKaehler_of_isSeparable
+  refine subsingleton_of_forall_eq 0 fun t => ?_
+  obtain ⟨c, rfl⟩ :=
+    ((KaehlerDifferential.exact_kerCotangentToTensor_mapBaseChange K[X]
+      v.toValuationSubring v.ResidueField
+      Ideal.Quotient.mk_surjective) t).mp (Subsingleton.elim _ _)
+  obtain ⟨⟨x, hx⟩, rfl⟩ := Ideal.toCotangent_surjective _ c
+  simp only [KaehlerDifferential.kerCotangentToTensor_toCotangent]
+  rw [v.ker_algebraMap_residueField_eq_span] at hx
+  induction hx using Submodule.span_induction with
+  | mem y hy =>
+    rcases hy with rfl
+    rw [v.D_polynomialAlgebra_uniformizer, TensorProduct.tmul_zero]
+  | zero => simp
+  | add y z _ _ hy hz =>
+    rw [map_add, TensorProduct.tmul_add, hy, hz, add_zero]
+  | smul a y hy IH =>
+    have hres : (algebraMap v.toValuationSubring v.ResidueField y) = 0 := by
+      rw [IsLocalRing.ResidueField.algebraMap_eq, IsLocalRing.residue_eq_zero_iff,
+        v.maximalIdeal_eq_span_uniformizer]
+      exact hy
+    rw [smul_eq_mul, Derivation.leibniz, TensorProduct.tmul_add,
+      TensorProduct.tmul_smul, IH, smul_zero, zero_add,
+      ← TensorProduct.smul_tmul, ← Algebra.algebraMap_eq_smul_one, hres,
+      TensorProduct.zero_tmul]
+
+p2m_export "AlgebraicCurve.Place" "subsingleton_residueTensor_polynomialKaehler_of_isSeparable"
+private theorem _root_.AlgebraicCurve.Place.finite_polynomialKaehler_of_finite_kaehler
+    [Module.Finite v.toValuationSubring Ω[v.toValuationSubring⁄K]] :
+    letI := v.polynomialAlgebra
+    Module.Finite v.toValuationSubring Ω[v.toValuationSubring⁄K[X]] := by
+  let := v.polynomialAlgebra
+  let := v.polynomialIsScalarTower
+  exact Module.Finite.of_surjective
+    (KaehlerDifferential.map K K[X] v.toValuationSubring v.toValuationSubring)
+    (KaehlerDifferential.map_surjective K K[X] v.toValuationSubring)
+
+p2m_export "AlgebraicCurve.Place" "finite_polynomialKaehler_of_finite_kaehler"
+private theorem _root_.AlgebraicCurve.Place.subsingleton_polynomialKaehler_of_isSeparable_of_finite
+    [Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring)]
+    [Module.Finite v.toValuationSubring Ω[v.toValuationSubring⁄K]] :
+    letI := v.polynomialAlgebra
+    Subsingleton Ω[v.toValuationSubring⁄K[X]] := by
+  let := v.polynomialAlgebra
+  have := v.finite_polynomialKaehler_of_finite_kaehler
+  have := v.subsingleton_residueTensor_polynomialKaehler_of_isSeparable
+  exact (IsLocalRing.subsingleton_tensorProduct (R := v.toValuationSubring)).mp ‹_›
+
+p2m_export "AlgebraicCurve.Place" "subsingleton_polynomialKaehler_of_isSeparable_of_finite"
+end ResidueEngine
+end Place
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def ValSubringKaehlerFinite : Prop :=
+  ∀ v : Place K F, Module.Finite v.toValuationSubring Ω[v.toValuationSubring⁄K]
+
+variable {K F}
+
+theorem valSubringPolynomialFormallyUnramified_of_kaehlerFinite_of_isSeparable
+    [∀ v : Place K F, Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring)]
+    (hfin : ValSubringKaehlerFinite K F) :
+    ValSubringPolynomialFormallyUnramified K F := by
+  intro v
+  have := hfin v
+  exact v.subsingleton_polynomialKaehler_of_isSeparable_of_finite
+
+end AlgebraicCurve
+
+open IsDedekindDomain Polynomial IsLocalRing
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.FiniteResidue HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor Place.FiniteResidue.finite HasCanonicalDivisor \
+  IsCurveOver.exists_separating_transcendental"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue ord ord_zero ord_one ord_mul \
+  ord_inv ord_coe_unit ord_coe_irreducible ord_unit_smul_zpow exists_unit_mul_zpow ne_top' \
+  FiniteResidue.finite algebraMap_mem' toValuationSubring dCoord DCoordGenerates dCoord_ne_zero \
+  differentialCoeff differentialCoeff_smul_dCoord differentialCoeff_unique ordDifferential \
+  ordDifferential_smul mem_maximalIdeal_iff_ord_pos"
+p2m_open "AlgebraicCurve.Place"
+
+section EftEngine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.finite_kaehler_of_essFiniteType [Algebra.EssFiniteType K
+  v.toValuationSubring] :
+    Module.Finite v.toValuationSubring Ω[v.toValuationSubring⁄K] :=
+  KaehlerDifferential.finite K v.toValuationSubring
+
+p2m_export "AlgebraicCurve.Place" "finite_kaehler_of_essFiniteType"
+private theorem _root_.AlgebraicCurve.Place.essFiniteType_of_exists_finiteType_isLocalization
+    (h : ∃ (S₀ : Subalgebra K v.toValuationSubring) (M : Submonoid S₀),
+      Algebra.FiniteType K S₀ ∧ IsLocalization M v.toValuationSubring) :
+    Algebra.EssFiniteType K v.toValuationSubring :=
+  (Algebra.essFiniteType_iff_exists_subalgebra K v.toValuationSubring).mpr
+    (h.imp fun _ ⟨M, hft, hloc⟩ => ⟨M, hft, hloc⟩)
+
+p2m_export "AlgebraicCurve.Place" "essFiniteType_of_exists_finiteType_isLocalization"
+end EftEngine
+end Place
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def ValSubringEssFiniteType : Prop :=
+  ∀ v : Place K F, Algebra.EssFiniteType K v.toValuationSubring
+
+def ValSubringFiniteTypeModel : Prop :=
+  ∀ v : Place K F,
+    ∃ (S₀ : Subalgebra K v.toValuationSubring) (M : Submonoid S₀),
+      Algebra.FiniteType K S₀ ∧ IsLocalization M v.toValuationSubring
+
+variable {K F}
+
+theorem valSubringKaehlerFinite_of_essFiniteType
+    (heft : ValSubringEssFiniteType K F) :
+    ValSubringKaehlerFinite K F := fun v =>
+  haveI := heft v
+  v.finite_kaehler_of_essFiniteType
+
+theorem valSubringEssFiniteType_of_finiteTypeModel
+    (hmodel : ValSubringFiniteTypeModel K F) :
+    ValSubringEssFiniteType K F := fun v =>
+  v.essFiniteType_of_exists_finiteType_isLocalization (hmodel v)
+
+theorem valSubringEssFiniteType_iff_finiteTypeModel :
+    ValSubringEssFiniteType K F ↔ ValSubringFiniteTypeModel K F := by
+  constructor
+  · intro heft v
+    have := heft v
+    exact (Algebra.essFiniteType_iff_exists_subalgebra K v.toValuationSubring).mp (heft v)
+  · exact valSubringEssFiniteType_of_finiteTypeModel
+
+theorem valSubringKaehlerFinite_of_finiteTypeModel
+    (hmodel : ValSubringFiniteTypeModel K F) :
+    ValSubringKaehlerFinite K F :=
+  valSubringKaehlerFinite_of_essFiniteType
+    (valSubringEssFiniteType_of_finiteTypeModel hmodel)
+
+end AlgebraicCurve
+
+open IsDedekindDomain Polynomial IsLocalRing
+namespace ValuationSubring
+p2m_export "ValuationSubring" "comap idealOfLE mem_comap prime_idealOfLE toSubring ext zero_mem \
+  ofPrime_top mem_nonunits_iff ofPrime mem_or_inv_mem' mem_top toSubring_injective mul_mem \
+  mem_or_inv_mem add_mem eq_top_iff valuation inclusion ofPrime_idealOfLE ofPrime_bot"
+p2m_open "ValuationSubring"
+
+variable {F : Type*} [Field F]
+
+private theorem ofPrime_congr_s12 {R : ValuationSubring F} {P Q : Ideal R}
+    [P.IsPrime] [Q.IsPrime] (h : P = Q) : R.ofPrime P = R.ofPrime Q := by
+  subst h; congr
+
+theorem eq_top_of_idealOfLE_eq_bot_s12 {R S : ValuationSubring F} (h : R ≤ S)
+    (hbot : idealOfLE R S h = ⊥) : S = ⊤ := by
+  have : IsDomain R := inferInstanceAs (IsDomain R.toSubring)
+  rw [← ofPrime_idealOfLE R S h, ofPrime_congr_s12 hbot, ofPrime_bot]
+
+theorem idealOfLE_ne_bot_of_ne_top_s12 {R S : ValuationSubring F} (h : R ≤ S)
+    (hS : S ≠ ⊤) : idealOfLE R S h ≠ ⊥ :=
+  fun hbot => hS (eq_top_of_idealOfLE_eq_bot_s12 h hbot)
+
+theorem eq_of_isDiscreteValuationRing_of_le_s12 {R S : ValuationSubring F}
+    [IsDiscreteValuationRing R] (h : R ≤ S) (hS : S ≠ ⊤) : R = S := by
+  have : IsDomain R := inferInstanceAs (IsDomain R.toSubring)
+  have : IsDedekindDomain R := IsPrincipalIdealRing.isDedekindDomain R
+  have hne : idealOfLE R S h ≠ ⊥ := idealOfLE_ne_bot_of_ne_top_s12 h hS
+  have hmax : (idealOfLE R S h).IsMaximal := (prime_idealOfLE R S h).isMaximal hne
+  have heq : idealOfLE R S h = IsLocalRing.maximalIdeal R := IsLocalRing.eq_maximalIdeal hmax
+  rw [← ofPrime_idealOfLE R S h, ofPrime_congr_s12 heq, ofPrime_top]
+
+end ValuationSubring
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.FiniteResidue HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor Place.FiniteResidue.finite HasCanonicalDivisor \
+  IsCurveOver.exists_separating_transcendental"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue ord ord_zero ord_one ord_mul \
+  ord_inv ord_coe_unit ord_coe_irreducible ord_unit_smul_zpow exists_unit_mul_zpow ne_top' \
+  FiniteResidue.finite algebraMap_mem' toValuationSubring dCoord DCoordGenerates dCoord_ne_zero \
+  differentialCoeff differentialCoeff_smul_dCoord differentialCoeff_unique ordDifferential \
+  ordDifferential_smul mem_maximalIdeal_iff_ord_pos"
+p2m_open "AlgebraicCurve.Place"
+
+section CenterIdeal
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+variable (A : Subalgebra K F) (hA : (A : Set F) ⊆ (v.toValuationSubring : Set F))
+
+@[reducible] private noncomputable def _root_.AlgebraicCurve.Place.modelInclusion :
+    A →+* v.toValuationSubring :=
+  (Subring.inclusion (show A.toSubring ≤ v.toValuationSubring.toSubring from hA))
+
+p2m_export "AlgebraicCurve.Place" "modelInclusion"
+@[scoped simp] theorem coe_modelInclusion (a : A) :
+    ((v.modelInclusion A hA a : v.toValuationSubring) : F) = (a : F) := rfl
+
+@[reducible] private noncomputable def _root_.AlgebraicCurve.Place.modelAlgebra :
+    Algebra A v.toValuationSubring :=
+  (v.modelInclusion A hA).toAlgebra
+
+p2m_export "AlgebraicCurve.Place" "modelAlgebra"
+@[reducible] private noncomputable def _root_.AlgebraicCurve.Place.centerIdeal : Ideal A :=
+  letI := v.modelAlgebra A hA
+  (IsLocalRing.maximalIdeal v.toValuationSubring).comap (algebraMap A v.toValuationSubring)
+
+p2m_export "AlgebraicCurve.Place" "centerIdeal"
+scoped instance centerIdeal_isPrime : (v.centerIdeal A hA).IsPrime :=
+  letI := v.modelAlgebra A hA
+  Ideal.comap_isPrime _ _
+
+private theorem _root_.AlgebraicCurve.Place.isUnit_modelInclusion_of_not_mem_centerIdeal {s : A}
+    (hs : s ∉ v.centerIdeal A hA) :
+    IsUnit (v.modelInclusion A hA s) := by
+  let := v.modelAlgebra A hA
+  rw [centerIdeal, Ideal.mem_comap, IsLocalRing.mem_maximalIdeal, mem_nonunits_iff,
+    not_not] at hs
+  exact hs
+
+p2m_export "AlgebraicCurve.Place" "isUnit_modelInclusion_of_not_mem_centerIdeal"
+private theorem _root_.AlgebraicCurve.Place.isUnit_modelInclusion_of_mem_primeCompl (s :
+  (v.centerIdeal A hA).primeCompl) :
+    IsUnit (v.modelInclusion A hA (s : A)) :=
+  v.isUnit_modelInclusion_of_not_mem_centerIdeal A hA s.2
+
+p2m_export "AlgebraicCurve.Place" "isUnit_modelInclusion_of_mem_primeCompl"
+private theorem _root_.AlgebraicCurve.Place.modelAlgebra_isScalarTower :
+    letI := v.modelAlgebra A hA
+    IsScalarTower K A v.toValuationSubring := by
+  let := v.modelAlgebra A hA
+  refine IsScalarTower.of_algebraMap_eq fun c => ?_
+  apply Subtype.ext
+  simp only [coe_modelInclusion, RingHom.algebraMap_toAlgebra]
+  rfl
+
+p2m_export "AlgebraicCurve.Place" "modelAlgebra_isScalarTower"
+private theorem _root_.AlgebraicCurve.Place.essFiniteType_of_finiteType_isLocalization_centerIdeal
+    [Algebra.FiniteType K A]
+    (hloc : letI := v.modelAlgebra A hA
+            IsLocalization.AtPrime v.toValuationSubring (v.centerIdeal A hA)) :
+    Algebra.EssFiniteType K v.toValuationSubring := by
+  let := v.modelAlgebra A hA
+  have := v.modelAlgebra_isScalarTower A hA
+  have : Algebra.EssFiniteType A v.toValuationSubring :=
+    Algebra.EssFiniteType.of_isLocalization _ (v.centerIdeal A hA).primeCompl
+  exact Algebra.EssFiniteType.comp K A v.toValuationSubring
+
+p2m_export "AlgebraicCurve.Place" "essFiniteType_of_finiteType_isLocalization_centerIdeal"
+end CenterIdeal
+end Place
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def ValSubringDedekindModel : Prop :=
+  ∀ v : Place K F,
+    ∃ (A : Subalgebra K F) (hA : (A : Set F) ⊆ (v.toValuationSubring : Set F)),
+      Algebra.FiniteType K A ∧
+      (letI := v.modelAlgebra A hA
+       IsLocalization.AtPrime v.toValuationSubring (v.centerIdeal A hA))
+
+variable {K F}
+
+theorem valSubringEssFiniteType_of_dedekindModel
+    (hmodel : ValSubringDedekindModel K F) :
+    ValSubringEssFiniteType K F := fun v => by
+  obtain ⟨A, hA, hft, hloc⟩ := hmodel v
+  exact v.essFiniteType_of_finiteType_isLocalization_centerIdeal A hA hloc
+
+theorem valSubringFiniteTypeModel_of_dedekindModel
+    (hmodel : ValSubringDedekindModel K F) :
+    ValSubringFiniteTypeModel K F :=
+  valSubringEssFiniteType_iff_finiteTypeModel.mp
+    (valSubringEssFiniteType_of_dedekindModel hmodel)
+
+end AlgebraicCurve
+
+open IsLocalRing
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.FiniteResidue HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor Place.FiniteResidue.finite HasCanonicalDivisor \
+  IsCurveOver.exists_separating_transcendental"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue ord ord_zero ord_one ord_mul \
+  ord_inv ord_coe_unit ord_coe_irreducible ord_unit_smul_zpow exists_unit_mul_zpow ne_top' \
+  FiniteResidue.finite algebraMap_mem' toValuationSubring dCoord DCoordGenerates dCoord_ne_zero \
+  differentialCoeff differentialCoeff_smul_dCoord differentialCoeff_unique ordDifferential \
+  ordDifferential_smul mem_maximalIdeal_iff_ord_pos"
+p2m_open "AlgebraicCurve.Place"
+
+section CenterNonzero
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+  (A : Subalgebra K F) (hA : (A : Set F) ⊆ (v.toValuationSubring : Set F))
+
+private theorem inv_mem_of_not_mem_centerIdeal {a : A} (ha : a ∉ v.centerIdeal A hA) :
+    ((a : F))⁻¹ ∈ v.toValuationSubring := by
+  obtain ⟨u, hu⟩ := v.isUnit_modelInclusion_of_not_mem_centerIdeal A hA ha
+  have huF : ((u : v.toValuationSubring) : F) = (a : F) :=
+    congrArg (Subtype.val : v.toValuationSubring → F) hu
+  have huinvF : ((u⁻¹ : v.toValuationSubringˣ).1 : F) * (a : F) = 1 := by
+    have h1 : ((u⁻¹ : v.toValuationSubringˣ).1 : F) * ((u : v.toValuationSubring) : F)
+        = ((1 : v.toValuationSubring) : F) :=
+      congrArg (Subtype.val : v.toValuationSubring → F) u.inv_mul
+    rw [huF] at h1; exact h1
+  have : ((u⁻¹ : v.toValuationSubringˣ).1 : F) = (a : F)⁻¹ :=
+    eq_inv_of_mul_eq_one_left huinvF
+  exact this ▸ ((u⁻¹ : v.toValuationSubringˣ).1 : v.toValuationSubring).2
+
+private theorem div_mem_of_not_mem_centerIdeal (r : A) {a : A}
+    (ha : a ∉ v.centerIdeal A hA) :
+    (r : F) / (a : F) ∈ v.toValuationSubring := by
+  rw [div_eq_mul_inv]
+  exact v.toValuationSubring.toSubring.mul_mem (hA r.2)
+    (inv_mem_of_not_mem_centerIdeal v A hA ha)
+
+private theorem _root_.AlgebraicCurve.Place.centerIdeal_ne_bot_of_isFractionRing [IsFractionRing A
+  F] :
+    v.centerIdeal A hA ≠ ⊥ := by
+  obtain ⟨f, hf⟩ : ∃ f : F, f ∉ v.toValuationSubring := by
+    by_contra h; push Not at h
+    exact v.ne_top' (ValuationSubring.toSubring_injective (top_le_iff.mp fun x _ => h x))
+  obtain ⟨r, s, hs, hfrs⟩ := IsFractionRing.div_surjective (A := A) f
+  have hsP : s ∈ v.centerIdeal A hA := by
+    by_contra hsP
+    apply hf
+    have : algebraMap A F r / algebraMap A F s ∈ v.toValuationSubring :=
+      div_mem_of_not_mem_centerIdeal v A hA r hsP
+    rwa [hfrs] at this
+  intro hbot
+  exact (nonZeroDivisors.ne_zero hs) (Ideal.mem_bot.mp (hbot ▸ hsP))
+
+p2m_export "AlgebraicCurve.Place" "centerIdeal_ne_bot_of_isFractionRing"
+end CenterNonzero
+
+section LocalizationSubalgebra
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+  (A : Subalgebra K F) (hA : (A : Set F) ⊆ (v.toValuationSubring : Set F))
+
+@[reducible] private noncomputable def _root_.AlgebraicCurve.Place.centerLocalizationSubalgebra
+  [IsFractionRing A F] :
+    Subalgebra A F :=
+  Localization.subalgebra.ofField F (v.centerIdeal A hA).primeCompl
+    (v.centerIdeal A hA).primeCompl_le_nonZeroDivisors
+
+p2m_export "AlgebraicCurve.Place" "centerLocalizationSubalgebra"
+scoped instance centerLocalizationSubalgebra_isLocalization [IsFractionRing A F] :
+    IsLocalization.AtPrime (v.centerLocalizationSubalgebra A hA) (v.centerIdeal A hA) :=
+  Localization.subalgebra.isLocalization_ofField F _ _
+
+scoped instance centerLocalizationSubalgebra_isDomain [IsFractionRing A F] :
+    IsDomain (v.centerLocalizationSubalgebra A hA) :=
+  inferInstanceAs (IsDomain (_ : Subalgebra A F))
+
+private theorem _root_.AlgebraicCurve.Place.centerLocalizationSubalgebra_isDiscreteValuationRing
+    [IsDedekindDomain A] [IsFractionRing A F] :
+    IsDiscreteValuationRing (v.centerLocalizationSubalgebra A hA) :=
+  IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain A
+    (v.centerIdeal_ne_bot_of_isFractionRing A hA) _
+
+p2m_export "AlgebraicCurve.Place" "centerLocalizationSubalgebra_isDiscreteValuationRing"
+scoped instance centerLocalizationSubalgebra_isFractionRing [IsFractionRing A F] :
+    IsFractionRing (v.centerLocalizationSubalgebra A hA) F :=
+  inferInstanceAs (IsFractionRing (Localization.subalgebra.ofField F _ _) F)
+
+private theorem _root_.AlgebraicCurve.Place.centerLocalizationSubalgebra_subset [IsFractionRing A F]
+  :
+    ((v.centerLocalizationSubalgebra A hA : Subalgebra A F) : Set F)
+      ⊆ (v.toValuationSubring : Set F) := by
+  intro x hx
+  obtain ⟨a, s, hs, rfl⟩ := hx
+  rw [← div_eq_mul_inv]
+  exact div_mem_of_not_mem_centerIdeal v A hA a hs
+
+p2m_export "AlgebraicCurve.Place" "centerLocalizationSubalgebra_subset"
+private noncomputable def _root_.AlgebraicCurve.Place.centerLocalizationValuationSubring
+    [IsDedekindDomain A] [IsFractionRing A F] : ValuationSubring F where
+  toSubring := (v.centerLocalizationSubalgebra A hA).toSubring
+  mem_or_inv_mem' x := by
+    have := v.centerLocalizationSubalgebra_isDiscreteValuationRing A hA
+    rcases ValuationRing.isInteger_or_isInteger (v.centerLocalizationSubalgebra A hA) x with
+      ⟨a, ha⟩ | ⟨a, ha⟩
+    · exact Or.inl (ha ▸ a.2)
+    · exact Or.inr (ha ▸ a.2)
+
+p2m_export "AlgebraicCurve.Place" "centerLocalizationValuationSubring"
+theorem coe_centerLocalizationValuationSubring [IsDedekindDomain A] [IsFractionRing A F] :
+    ((v.centerLocalizationValuationSubring A hA : ValuationSubring F) : Set F)
+      = ((v.centerLocalizationSubalgebra A hA : Subalgebra A F) : Set F) := rfl
+
+scoped instance centerLocalizationValuationSubring_isDiscreteValuationRing
+    [IsDedekindDomain A] [IsFractionRing A F] :
+    IsDiscreteValuationRing (v.centerLocalizationValuationSubring A hA) :=
+  v.centerLocalizationSubalgebra_isDiscreteValuationRing A hA
+
+private theorem _root_.AlgebraicCurve.Place.centerLocalizationValuationSubring_le
+    [IsDedekindDomain A] [IsFractionRing A F] :
+    v.centerLocalizationValuationSubring A hA ≤ v.toValuationSubring :=
+  v.centerLocalizationSubalgebra_subset A hA
+
+p2m_export "AlgebraicCurve.Place" "centerLocalizationValuationSubring_le"
+private theorem _root_.AlgebraicCurve.Place.centerLocalizationValuationSubring_eq
+    [IsDedekindDomain A] [IsFractionRing A F] :
+    v.centerLocalizationValuationSubring A hA = v.toValuationSubring :=
+  ValuationSubring.eq_of_isDiscreteValuationRing_of_le_s12
+    (v.centerLocalizationValuationSubring_le A hA) v.ne_top'
+
+p2m_export "AlgebraicCurve.Place" "centerLocalizationValuationSubring_eq"
+theorem coe_centerLocalizationSubalgebra_eq [IsDedekindDomain A] [IsFractionRing A F] :
+    ((v.centerLocalizationSubalgebra A hA : Subalgebra A F) : Set F)
+      = (v.toValuationSubring : Set F) := by
+  rw [← coe_centerLocalizationValuationSubring]
+  exact congrArg (SetLike.coe) (v.centerLocalizationValuationSubring_eq A hA)
+
+private theorem _root_.AlgebraicCurve.Place.mem_centerLocalizationSubalgebra_of_mem
+    [IsDedekindDomain A] [IsFractionRing A F]
+    (x : F) (hx : x ∈ v.toValuationSubring) :
+    x ∈ (v.centerLocalizationSubalgebra A hA : Subalgebra A F) := by
+  rw [← SetLike.mem_coe, coe_centerLocalizationSubalgebra_eq]; exact hx
+
+p2m_export "AlgebraicCurve.Place" "mem_centerLocalizationSubalgebra_of_mem"
+private theorem _root_.AlgebraicCurve.Place.isLocalization_centerIdeal_of_isDedekindDomain
+    [IsDedekindDomain A] [IsFractionRing A F] :
+    letI := v.modelAlgebra A hA
+    IsLocalization.AtPrime v.toValuationSubring (v.centerIdeal A hA) := by
+  let := v.modelAlgebra A hA
+  refine (isLocalization_iff _ _).mpr ⟨?_, ?_, ?_⟩
+  · exact v.isUnit_modelInclusion_of_mem_primeCompl A hA
+  · intro x
+    have hxP : (x : F) ∈ (v.centerLocalizationSubalgebra A hA : Subalgebra A F) :=
+      v.mem_centerLocalizationSubalgebra_of_mem A hA (x : F) x.2
+    obtain ⟨a, s, hs, hxeq⟩ := hxP
+    refine ⟨⟨a, ⟨s, hs⟩⟩, Subtype.ext ?_⟩
+    change (x : F) * ((s : A) : F) = ((a : A) : F)
+    have halg_s : algebraMap A F s = ((s : A) : F) := rfl
+    have halg_a : algebraMap A F a = ((a : A) : F) := rfl
+    have hs0 : algebraMap A F s ≠ 0 := by
+      intro hF
+      have hsne : s ≠ 0 := fun h => (h ▸ hs) (Ideal.zero_mem _)
+      exact hsne (Subtype.ext (p := (· ∈ A)) (halg_s ▸ hF))
+    rw [← halg_s, ← halg_a, hxeq, mul_assoc, inv_mul_cancel₀ hs0, mul_one]
+  · intro a₁ a₂ h
+    have hF : (a₁ : F) = (a₂ : F) :=
+      congrArg (Subtype.val : v.toValuationSubring → F) h
+    exact ⟨1, by rw [show a₁ = a₂ from Subtype.ext hF]⟩
+
+p2m_export "AlgebraicCurve.Place" "isLocalization_centerIdeal_of_isDedekindDomain"
+end LocalizationSubalgebra
+end Place
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def ValSubringDedekindFractionModel : Prop :=
+  ∀ v : Place K F,
+    ∃ (A : Subalgebra K F) (_ : (A : Set F) ⊆ (v.toValuationSubring : Set F)),
+      Algebra.FiniteType K A ∧ IsDedekindDomain A ∧ IsFractionRing A F
+
+variable {K F}
+
+theorem valSubringDedekindModel_of_dedekindFractionModel
+    (hfrac : ValSubringDedekindFractionModel K F) :
+    ValSubringDedekindModel K F := fun v => by
+  obtain ⟨A, hA, hft, hded, hfracA⟩ := hfrac v
+  exact ⟨A, hA, hft, v.isLocalization_centerIdeal_of_isDedekindDomain A hA⟩
+
+end AlgebraicCurve
+
+open IsLocalRing
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.FiniteResidue HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor Place.FiniteResidue.finite HasCanonicalDivisor \
+  IsCurveOver.exists_separating_transcendental"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue ord ord_zero ord_one ord_mul \
+  ord_inv ord_coe_unit ord_coe_irreducible ord_unit_smul_zpow exists_unit_mul_zpow ne_top' \
+  FiniteResidue.finite algebraMap_mem' toValuationSubring dCoord DCoordGenerates dCoord_ne_zero \
+  differentialCoeff differentialCoeff_smul_dCoord differentialCoeff_unique ordDifferential \
+  ordDifferential_smul mem_maximalIdeal_iff_ord_pos"
+p2m_open "AlgebraicCurve.Place"
+
+section IntegrallyClosed
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.isIntegrallyClosed_toValuationSubring :
+    IsIntegrallyClosed v.toValuationSubring := inferInstance
+
+p2m_export "AlgebraicCurve.Place" "isIntegrallyClosed_toValuationSubring"
+private theorem _root_.AlgebraicCurve.Place.mem_valuationSubring_of_isIntegral {x : F}
+    (hx : IsIntegral v.toValuationSubring x) :
+    x ∈ v.toValuationSubring := by
+  obtain ⟨y, hy⟩ := (isIntegrallyClosed_iff F).mp (v.isIntegrallyClosed_toValuationSubring) hx
+  exact hy ▸ y.2
+
+p2m_export "AlgebraicCurve.Place" "mem_valuationSubring_of_isIntegral"
+variable (B : Subalgebra K F) (hB : (B : Set F) ⊆ (v.toValuationSubring : Set F))
+
+include hB in
+private theorem _root_.AlgebraicCurve.Place.modelAlgebra_isScalarTower_top :
+    letI := v.modelAlgebra B hB
+    IsScalarTower B v.toValuationSubring F := by
+  let := v.modelAlgebra B hB
+  refine IsScalarTower.of_algebraMap_eq fun b => ?_
+  rfl
+
+p2m_export "AlgebraicCurve.Place" "modelAlgebra_isScalarTower_top"
+include hB in
+private theorem _root_.AlgebraicCurve.Place.mem_valuationSubring_of_isIntegral_subalgebra {x : F}
+    (hx : IsIntegral B x) :
+    x ∈ v.toValuationSubring := by
+  let := v.modelAlgebra B hB
+  have := v.modelAlgebra_isScalarTower_top B hB
+  exact v.mem_valuationSubring_of_isIntegral (hx.tower_top (A := v.toValuationSubring))
+
+p2m_export "AlgebraicCurve.Place" "mem_valuationSubring_of_isIntegral_subalgebra"
+include hB in
+private theorem _root_.AlgebraicCurve.Place.integralClosure_subset_valuationSubring :
+    ((integralClosure B F : Subalgebra B F) : Set F)
+      ⊆ (v.toValuationSubring : Set F) := fun _ hx =>
+  v.mem_valuationSubring_of_isIntegral_subalgebra B hB hx
+
+p2m_export "AlgebraicCurve.Place" "integralClosure_subset_valuationSubring"
+end IntegrallyClosed
+end Place
+
+section TwoCharts
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def IsAffineChart (A : Subalgebra K F) : Prop :=
+  Algebra.FiniteType K A ∧ IsDedekindDomain A ∧ IsFractionRing A F
+
+def ValSubringTwoAffineCharts : Prop :=
+  ∃ A₀ A₁ : Subalgebra K F, IsAffineChart K F A₀ ∧ IsAffineChart K F A₁
+    ∧ ∀ v : Place K F, (A₀ : Set F) ⊆ (v.toValuationSubring : Set F)
+        ∨ (A₁ : Set F) ⊆ (v.toValuationSubring : Set F)
+
+variable {K F}
+
+theorem valSubringDedekindFractionModel_of_twoAffineCharts
+    (h : ValSubringTwoAffineCharts K F) :
+    ValSubringDedekindFractionModel K F := fun v => by
+  obtain ⟨A₀, A₁, ⟨hft₀, hded₀, hfrac₀⟩, ⟨hft₁, hded₁, hfrac₁⟩, hcover⟩ := h
+  rcases hcover v with h₀ | h₁
+  · exact ⟨A₀, h₀, hft₀, hded₀, hfrac₀⟩
+  · exact ⟨A₁, h₁, hft₁, hded₁, hfrac₁⟩
+
+theorem valSubringDedekindModel_of_twoAffineCharts
+    (h : ValSubringTwoAffineCharts K F) :
+    ValSubringDedekindModel K F :=
+  valSubringDedekindModel_of_dedekindFractionModel
+    (valSubringDedekindFractionModel_of_twoAffineCharts h)
+
+end TwoCharts
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.FiniteResidue HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor Place.FiniteResidue.finite HasCanonicalDivisor \
+  IsCurveOver.exists_separating_transcendental"
+p2m_open "AlgebraicCurve"
+
+section Gates
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue ord ord_zero ord_one ord_mul \
+  ord_inv ord_coe_unit ord_coe_irreducible ord_unit_smul_zpow exists_unit_mul_zpow ne_top' \
+  FiniteResidue.finite algebraMap_mem' toValuationSubring dCoord DCoordGenerates dCoord_ne_zero \
+  differentialCoeff differentialCoeff_smul_dCoord differentialCoeff_unique ordDifferential \
+  ordDifferential_smul mem_maximalIdeal_iff_ord_pos"
+end Place
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+@[reducible] private noncomputable def _root_.AlgebraicCurve.Place.toKSubalgebra (v : Place K F) :
+    Subalgebra K F where
+  __ := v.toValuationSubring.toSubring
+  algebraMap_mem' c := v.algebraMap_mem' c
+
+end Place
+p2m_export "AlgebraicCurve" "Place.toKSubalgebra"
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.coe_toKSubalgebra (v : Place K F) :
+    (v.toKSubalgebra : Set F) = (v.toValuationSubring : Set F) := rfl
+
+end Place
+p2m_export "AlgebraicCurve" "Place.coe_toKSubalgebra"
+theorem gate_adjoin_subset_valuationSubring_of_mem (v : Place K F) {t : F}
+    (ht : t ∈ v.toValuationSubring) :
+    ((Algebra.adjoin K {t} : Subalgebra K F) : Set F)
+      ⊆ (v.toValuationSubring : Set F) := by
+  rw [← v.coe_toKSubalgebra]
+  exact Algebra.adjoin_le (Set.singleton_subset_iff.mpr ht)
+
+end Gates
+end AlgebraicCurve
+
+p2m_open "IsLocalRing IntermediateField \
+  P2MW.S_AlgebraicCurve_hasCanonicalDivisor_of_isCurveOver.IntermediateField \
+  IntermediateField.algebraAdjoinAdjoin"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.FiniteResidue HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor Place.FiniteResidue.finite HasCanonicalDivisor \
+  IsCurveOver.exists_separating_transcendental"
+p2m_open "AlgebraicCurve"
+
+section AdjoinRingProperties
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+private theorem _root_.Transcendental.isPrincipalIdealRing_adjoin_s12 {t : F}
+    (ht : Transcendental K t) :
+    IsPrincipalIdealRing ↥(Algebra.adjoin K ({t} : Set F)) :=
+  IsPrincipalIdealRing.of_surjective
+    (Polynomial.algEquivOfTranscendental K t ht).toRingHom
+    (Polynomial.algEquivOfTranscendental K t ht).surjective
+
+private theorem _root_.Transcendental.isDedekindDomain_adjoin_s12 {t : F} (ht : Transcendental K t)
+    :
+    IsDedekindDomain ↥(Algebra.adjoin K ({t} : Set F)) :=
+  haveI := ht.isPrincipalIdealRing_adjoin_s12
+  inferInstance
+
+private theorem _root_.Transcendental.isIntegrallyClosed_adjoin_s12 {t : F}
+    (ht : Transcendental K t) :
+    IsIntegrallyClosed ↥(Algebra.adjoin K ({t} : Set F)) :=
+  haveI := ht.isDedekindDomain_adjoin_s12
+  inferInstance
+
+private theorem _root_.Transcendental.isNoetherianRing_adjoin_s12 {t : F} (ht : Transcendental K t)
+    :
+    IsNoetherianRing ↥(Algebra.adjoin K ({t} : Set F)) :=
+  haveI := ht.isPrincipalIdealRing_adjoin_s12
+  inferInstance
+
+private theorem _root_.Algebra.FiniteType.adjoin_singleton_s12 (t : F) :
+    Algebra.FiniteType K ↥(Algebra.adjoin K ({t} : Set F)) :=
+  Algebra.FiniteType.adjoin_of_finite (Set.finite_singleton t)
+
+private theorem _root_.Transcendental.inv_s12 {t : F} (ht : Transcendental K t) :
+    Transcendental K t⁻¹ := by
+  rw [Transcendental, IsAlgebraic.inv_iff]; exact ht
+
+end AdjoinRingProperties
+
+section TranscendentalChart
+
+variable (K : Type*) {F : Type*} [Field K] [Field F] [Algebra K F]
+
+@[reducible] noncomputable def transcendentalChart (t : F) : Subalgebra K F :=
+  (integralClosure (Algebra.adjoin K ({t} : Set F)) F).restrictScalars K
+
+theorem coe_transcendentalChart (t : F) :
+    (transcendentalChart K t : Set F)
+      = ((integralClosure (Algebra.adjoin K ({t} : Set F)) F : Subalgebra _ F) : Set F) :=
+  rfl
+
+variable {K}
+
+theorem transcendentalChart_subset_valuationSubring_of_mem (v : Place K F)
+    {t : F} (ht : t ∈ v.toValuationSubring) :
+    (transcendentalChart K t : Set F) ⊆ (v.toValuationSubring : Set F) := by
+  rw [coe_transcendentalChart]
+  exact v.integralClosure_subset_valuationSubring _
+    (gate_adjoin_subset_valuationSubring_of_mem v ht)
+
+theorem transcendentalChart_subset_or_inv_subset (v : Place K F) (t : F) :
+    (transcendentalChart K t : Set F) ⊆ (v.toValuationSubring : Set F)
+      ∨ (transcendentalChart K t⁻¹ : Set F) ⊆ (v.toValuationSubring : Set F) :=
+  (v.toValuationSubring.mem_or_inv_mem t).imp
+    (transcendentalChart_subset_valuationSubring_of_mem v)
+    (transcendentalChart_subset_valuationSubring_of_mem v)
+
+end TranscendentalChart
+
+section IsAffineChartEngine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+section
+
+variable (B : Subalgebra K F)
+
+theorem isScalarTower_integralClosure_subalgebra :
+    IsScalarTower K B ↥(integralClosure B F) := by
+  refine IsScalarTower.of_algebraMap_eq fun c => ?_
+  exact Subtype.ext rfl
+
+theorem finiteType_integralClosure_of_moduleFinite (hft : Algebra.FiniteType K B)
+    (hfin : Module.Finite B ↥(integralClosure B F)) :
+    Algebra.FiniteType K ↥(integralClosure B F) :=
+  haveI := isScalarTower_integralClosure_subalgebra B
+  haveI := hfin
+  Algebra.FiniteType.trans (S := B) hft inferInstance
+
+end
+
+theorem isDedekindDomain_integralClosure_adjoin {t : F} (ht : Transcendental K t)
+    [FiniteDimensional K⟮t⟯ F] [Algebra.IsSeparable K⟮t⟯ F] :
+    IsDedekindDomain ↥(integralClosure (Algebra.adjoin K ({t} : Set F)) F) := by
+  have := ht.isDedekindDomain_adjoin_s12
+  exact integralClosure.isDedekindDomain ↥(Algebra.adjoin K ({t} : Set F)) ↥(K⟮t⟯) F
+
+theorem isFractionRing_integralClosure_adjoin (t : F) [FiniteDimensional K⟮t⟯ F] :
+    IsFractionRing ↥(integralClosure (Algebra.adjoin K ({t} : Set F)) F) F :=
+  integralClosure.isFractionRing_of_finite_extension
+    (A := ↥(Algebra.adjoin K ({t} : Set F))) ↥(K⟮t⟯) F
+
+theorem moduleFinite_integralClosure_adjoin {t : F} (ht : Transcendental K t)
+    [FiniteDimensional K⟮t⟯ F] [Algebra.IsSeparable K⟮t⟯ F] :
+    Module.Finite ↥(Algebra.adjoin K ({t} : Set F))
+      ↥(integralClosure (Algebra.adjoin K ({t} : Set F)) F) := by
+  have := ht.isIntegrallyClosed_adjoin_s12
+  have := ht.isNoetherianRing_adjoin_s12
+  exact IsIntegralClosure.finite (A := ↥(Algebra.adjoin K ({t} : Set F)))
+    (K := ↥(K⟮t⟯)) (L := F) (integralClosure ↥(Algebra.adjoin K ({t} : Set F)) F)
+
+theorem finiteType_integralClosure_adjoin {t : F} (ht : Transcendental K t)
+    [FiniteDimensional K⟮t⟯ F] [Algebra.IsSeparable K⟮t⟯ F] :
+    Algebra.FiniteType K ↥(integralClosure (Algebra.adjoin K ({t} : Set F)) F) :=
+  finiteType_integralClosure_of_moduleFinite (Algebra.adjoin K {t})
+    (Algebra.FiniteType.adjoin_singleton_s12 t) (moduleFinite_integralClosure_adjoin ht)
+
+theorem isAffineChart_restrictScalars_integralClosure (B : Subalgebra K F)
+    (hft : Algebra.FiniteType K ↥(integralClosure B F))
+    (hded : IsDedekindDomain ↥(integralClosure B F))
+    (hfrac : IsFractionRing ↥(integralClosure B F) F) :
+    IsAffineChart K F ((integralClosure B F).restrictScalars K) :=
+  ⟨hft, hded, hfrac⟩
+
+theorem isAffineChart_transcendentalChart {t : F} (ht : Transcendental K t)
+    [FiniteDimensional K⟮t⟯ F] [Algebra.IsSeparable K⟮t⟯ F] :
+    IsAffineChart K F (transcendentalChart K t) :=
+  isAffineChart_restrictScalars_integralClosure (Algebra.adjoin K {t})
+    (finiteType_integralClosure_adjoin ht)
+    (isDedekindDomain_integralClosure_adjoin ht)
+    (isFractionRing_integralClosure_adjoin t)
+
+end IsAffineChartEngine
+
+section SeparatingTranscendental
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def HasSeparatingTranscendental : Prop :=
+  ∃ t : F, Transcendental K t
+    ∧ FiniteDimensional K⟮t⟯ F ∧ Algebra.IsSeparable K⟮t⟯ F
+    ∧ FiniteDimensional K⟮t⁻¹⟯ F ∧ Algebra.IsSeparable K⟮t⁻¹⟯ F
+
+variable {K F}
+
+theorem valSubringTwoAffineCharts_of_hasSeparatingTranscendental
+    (h : HasSeparatingTranscendental K F) :
+    ValSubringTwoAffineCharts K F := by
+  obtain ⟨t, ht, hfin, hsep, hfin', hsep'⟩ := h
+  exact ⟨transcendentalChart K t, transcendentalChart K t⁻¹,
+    isAffineChart_transcendentalChart ht,
+    isAffineChart_transcendentalChart ht.inv_s12,
+    fun v => transcendentalChart_subset_or_inv_subset v t⟩
+
+theorem valSubringDedekindModel_of_hasSeparatingTranscendental
+    (h : HasSeparatingTranscendental K F) :
+    ValSubringDedekindModel K F :=
+  valSubringDedekindModel_of_twoAffineCharts
+    (valSubringTwoAffineCharts_of_hasSeparatingTranscendental h)
+
+end SeparatingTranscendental
+end AlgebraicCurve
+
+p2m_open "IntermediateField \
+  P2MW.S_AlgebraicCurve_hasCanonicalDivisor_of_isCurveOver.IntermediateField"
+
+namespace IntermediateField
+p2m_export "IntermediateField" "toAlgebra inclusion_injective val inclusion ext \
+  adjoin_simple_le_iff equivOfEq smul_def adjoin comap mem_top restrictScalars mem_bot \
+  mem_adjoin_simple_self smul_mem map"
+p2m_open "IntermediateField"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem adjoin_simple_inv_s12 (t : F) : K⟮t⁻¹⟯ = K⟮t⟯ := by
+  refine le_antisymm (adjoin_simple_le_iff.mpr ?_) (adjoin_simple_le_iff.mpr ?_)
+  · exact inv_mem (mem_adjoin_simple_self K t)
+  · have h : (t⁻¹)⁻¹ ∈ (K⟮t⁻¹⟯ : IntermediateField K F) :=
+      inv_mem (mem_adjoin_simple_self K t⁻¹)
+    rwa [inv_inv] at h
+
+theorem algebraMap_comp_equivOfEq_s12 {S T : IntermediateField K F} (h : S = T) :
+    (algebraMap T F).comp ((IntermediateField.equivOfEq h).toRingEquiv : S →+* T)
+      = ((RingEquiv.refl F : F ≃+* F) : F →+* F).comp (algebraMap S F) := by
+  ext x; rfl
+
+theorem finiteDimensional_of_eq_s12 {S T : IntermediateField K F} (h : S = T)
+    [FiniteDimensional ↥S F] : FiniteDimensional ↥T F :=
+  Module.Finite.of_equiv_equiv (IntermediateField.equivOfEq h).toRingEquiv (RingEquiv.refl F)
+    (algebraMap_comp_equivOfEq_s12 h)
+
+theorem isSeparable_of_eq_s12 {S T : IntermediateField K F} (h : S = T)
+    [Algebra.IsSeparable ↥S F] : Algebra.IsSeparable ↥T F :=
+  Algebra.IsSeparable.of_equiv_equiv (IntermediateField.equivOfEq h).toRingEquiv
+    (RingEquiv.refl F) (algebraMap_comp_equivOfEq_s12 h)
+
+theorem finiteDimensional_adjoin_inv_s12 (t : F) [FiniteDimensional K⟮t⟯ F] :
+    FiniteDimensional K⟮t⁻¹⟯ F :=
+  finiteDimensional_of_eq_s12 (adjoin_simple_inv_s12 t).symm
+
+theorem isSeparable_adjoin_inv_s12 (t : F) [Algebra.IsSeparable K⟮t⟯ F] :
+    Algebra.IsSeparable K⟮t⁻¹⟯ F :=
+  isSeparable_of_eq_s12 (adjoin_simple_inv_s12 t).symm
+
+end IntermediateField
+
+p2m_open "IntermediateField \
+  P2MW.S_AlgebraicCurve_hasCanonicalDivisor_of_isCurveOver.IntermediateField"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.FiniteResidue HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor Place.FiniteResidue.finite HasCanonicalDivisor \
+  IsCurveOver.exists_separating_transcendental"
+p2m_open "AlgebraicCurve"
+
+section AbstractEngine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+p2m_open_scoped "AlgebraicCurve.Place" in
+theorem Place.dCoordGenerates_of_valSubringKaehlerSpanTop
+    (hspan : ValSubringKaehlerSpanTop K F) (v : Place K F) :
+    v.DCoordGenerates := by
+  constructor
+  rw [eq_top_iff,
+    ← KaehlerDifferential.span_range_map_derivation_of_isLocalization (R := K)
+      (S := v.toValuationSubring) (T := F) (nonZeroDivisors v.toValuationSubring),
+    Submodule.span_le]
+  rintro _ ⟨f, rfl⟩
+  have hDf : KaehlerDifferential.D K v.toValuationSubring f
+      ∈ (⊤ : Submodule v.toValuationSubring Ω[v.toValuationSubring⁄K]) := Submodule.mem_top
+  rw [← hspan v] at hDf
+  have hmap : (KaehlerDifferential.map K K v.toValuationSubring F ∘
+        KaehlerDifferential.D K v.toValuationSubring) f
+      ∈ Submodule.map (KaehlerDifferential.map K K v.toValuationSubring F)
+        (Submodule.span v.toValuationSubring _) :=
+    Submodule.mem_map_of_mem hDf
+  rw [Submodule.map_span, Set.image_singleton,
+    v.kaehlerMap_subring_D_uniformizer] at hmap
+  exact Submodule.span_le_restrictScalars v.toValuationSubring F {v.dCoord} hmap
+
+end AbstractEngine
+end AlgebraicCurve
+
+noncomputable section
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.FiniteResidue HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor Place.FiniteResidue.finite HasCanonicalDivisor \
+  IsCurveOver.exists_separating_transcendental"
+p2m_open "AlgebraicCurve"
+
+section PerPlaceSupply
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem
+  _root_.AlgebraicCurve.Place.isSeparable_residueField_of_perfectField_of_finiteResidue
+    [PerfectField K] (v : Place K F) [v.FiniteResidue] :
+    Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring) := by
+  have : Module.Finite K (IsLocalRing.ResidueField v.toValuationSubring) :=
+    Place.FiniteResidue.finite
+  have : Algebra.IsAlgebraic K (IsLocalRing.ResidueField v.toValuationSubring) :=
+    Algebra.IsAlgebraic.of_finite K _
+  exact Algebra.IsAlgebraic.isSeparable_of_perfectField
+
+end Place
+p2m_export "AlgebraicCurve" "Place.isSeparable_residueField_of_perfectField_of_finiteResidue"
+theorem isSeparable_residueField_forall_of_perfectField
+    [PerfectField K] [∀ v : Place K F, v.FiniteResidue] :
+    ∀ v : Place K F,
+      Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring) :=
+  fun v => v.isSeparable_residueField_of_perfectField_of_finiteResidue
+
+end PerPlaceSupply
+
+section IsSeparableEngines
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem valSubringKaehlerSpanTop_of_kaehlerFinite_of_isSeparable
+    [∀ v : Place K F, Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring)]
+    (hfin : ValSubringKaehlerFinite K F) :
+    ValSubringKaehlerSpanTop K F :=
+  valSubringKaehlerSpanTop_of_polynomialFormallyUnramified
+    (valSubringPolynomialFormallyUnramified_of_kaehlerFinite_of_isSeparable hfin)
+
+p2m_open_scoped "AlgebraicCurve.Place" in
+theorem Place.dCoordGenerates_of_valSubringKaehlerFinite_of_isSeparable
+    [∀ v : Place K F, Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring)]
+    (hfin : ValSubringKaehlerFinite K F) (v : Place K F) :
+    v.DCoordGenerates :=
+  Place.dCoordGenerates_of_valSubringKaehlerSpanTop
+    (valSubringKaehlerSpanTop_of_kaehlerFinite_of_isSeparable hfin) v
+
+end IsSeparableEngines
+
+section PerfectFieldEngines
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+p2m_open_scoped "AlgebraicCurve.Place" in
+theorem Place.dCoordGenerates_of_valSubringKaehlerFinite_of_perfectField
+    [PerfectField K] [∀ v : Place K F, v.FiniteResidue]
+    (hfin : ValSubringKaehlerFinite K F) (v : Place K F) :
+    v.DCoordGenerates :=
+  haveI : ∀ v : Place K F,
+      Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring) :=
+    isSeparable_residueField_forall_of_perfectField
+  Place.dCoordGenerates_of_valSubringKaehlerFinite_of_isSeparable hfin v
+
+end PerfectFieldEngines
+end AlgebraicCurve
+
+section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.FiniteResidue HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor Place.FiniteResidue.finite HasCanonicalDivisor \
+  IsCurveOver.exists_separating_transcendental"
+p2m_open "AlgebraicCurve"
+
+section S12ChainWires
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+p2m_open_scoped "AlgebraicCurve.Place" in
+theorem Place.dCoordGenerates_of_valSubringFiniteTypeModel_of_perfectField
+    [PerfectField K] [∀ v : Place K F, v.FiniteResidue]
+    (hmodel : ValSubringFiniteTypeModel K F) (v : Place K F) :
+    v.DCoordGenerates :=
+  Place.dCoordGenerates_of_valSubringKaehlerFinite_of_perfectField
+    (valSubringKaehlerFinite_of_finiteTypeModel hmodel) v
+
+p2m_open_scoped "AlgebraicCurve.Place" in
+theorem Place.dCoordGenerates_of_valSubringDedekindModel_of_perfectField
+    [PerfectField K] [∀ v : Place K F, v.FiniteResidue]
+    (hmodel : ValSubringDedekindModel K F) (v : Place K F) :
+    v.DCoordGenerates :=
+  Place.dCoordGenerates_of_valSubringFiniteTypeModel_of_perfectField
+    (valSubringFiniteTypeModel_of_dedekindModel hmodel) v
+
+p2m_open_scoped "AlgebraicCurve.Place" in
+theorem Place.dCoordGenerates_of_hasSeparatingTranscendental_of_perfectField
+    [PerfectField K] [∀ v : Place K F, v.FiniteResidue]
+    (hsep : HasSeparatingTranscendental K F) (v : Place K F) :
+    v.DCoordGenerates :=
+  Place.dCoordGenerates_of_valSubringDedekindModel_of_perfectField
+    (valSubringDedekindModel_of_hasSeparatingTranscendental hsep) v
+
+open _root_.IntermediateField
+  _root_.P2MW.S_AlgebraicCurve_hasCanonicalDivisor_of_isCurveOver.IntermediateField in
+theorem hasSeparatingTranscendental_of_isCurveOver_of_perfectField
+    [PerfectField K] [Algebra.EssFiniteType K F] [IsCurveOver K F] :
+    HasSeparatingTranscendental K F := by
+  obtain ⟨t, htr, hfd, hsep⟩ := IsCurveOver.exists_separating_transcendental (K := K) (F := F)
+  exact ⟨t, htr, hfd, hsep,
+    IntermediateField.finiteDimensional_adjoin_inv_s12 t,
+    IntermediateField.isSeparable_adjoin_inv_s12 t⟩
+
+end S12ChainWires
+end AlgebraicCurve
+end
+
+section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.FiniteResidue HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor Place.FiniteResidue.finite HasCanonicalDivisor \
+  IsCurveOver.exists_separating_transcendental"
+p2m_open "AlgebraicCurve"
+
+section S12WellDefined
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem valSubringKaehlerSpanTop_of_isCurveOver_of_perfectField_s12
+    [PerfectField K] [Algebra.EssFiniteType K F] [IsCurveOver K F] :
+    ValSubringKaehlerSpanTop K F :=
+  haveI : ∀ v : Place K F,
+      Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring) :=
+    isSeparable_residueField_forall_of_perfectField
+  valSubringKaehlerSpanTop_of_kaehlerFinite_of_isSeparable
+    (valSubringKaehlerFinite_of_finiteTypeModel
+      (valSubringFiniteTypeModel_of_dedekindModel
+        (valSubringDedekindModel_of_hasSeparatingTranscendental
+          (hasSeparatingTranscendental_of_isCurveOver_of_perfectField (K := K) (F := F)))))
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue ord ord_zero ord_one ord_mul \
+  ord_inv ord_coe_unit ord_coe_irreducible ord_unit_smul_zpow exists_unit_mul_zpow ne_top' \
+  FiniteResidue.finite algebraMap_mem' toValuationSubring dCoord DCoordGenerates dCoord_ne_zero \
+  differentialCoeff differentialCoeff_smul_dCoord differentialCoeff_unique ordDifferential \
+  ordDifferential_smul mem_maximalIdeal_iff_ord_pos"
+p2m_open "AlgebraicCurve.Place"
+
+variable (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.ord_nonneg_of_mem_s12 {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    0 ≤ v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨n, u, hu⟩ :=
+    IsDiscreteValuationRing.eq_unit_mul_pow_irreducible
+      (x := (⟨f, hf⟩ : v.toValuationSubring)) (by simpa [Subtype.ext_iff] using hf0) hπ
+  have hcoe : f = ((u : v.toValuationSubring) : F) * ((π : F) ^ (n : ℤ)) := by
+    have h := congrArg (Subtype.val) hu
+    push_cast at h
+    rw [zpow_natCast]
+    exact h
+  rw [hcoe, v.ord_unit_smul_zpow u hπ (n : ℤ)]
+  exact Int.natCast_nonneg n
+
+p2m_export "AlgebraicCurve.Place" "ord_nonneg_of_mem_s12"
+private theorem _root_.AlgebraicCurve.Place.mem_of_ord_nonneg_s12 {f : F} (hf : f ≠ 0)
+    (h : 0 ≤ v.ord f) :
+    f ∈ v.toValuationSubring := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ
+  rw [hu, show v.ord f = (((v.ord f).toNat : ℕ) : ℤ) from (Int.toNat_of_nonneg h).symm,
+    zpow_natCast]
+  exact mul_mem (u : v.toValuationSubring).2 (pow_mem (π : v.toValuationSubring).2 _)
+
+p2m_export "AlgebraicCurve.Place" "mem_of_ord_nonneg_s12"
+private theorem _root_.AlgebraicCurve.Place.ord_uniformizerSubring'_s12 :
+    v.ord (uniformizerSubring' v : F) = 1 :=
+  v.ord_coe_irreducible (IsDiscreteValuationRing.exists_irreducible
+    v.toValuationSubring).choose_spec
+
+p2m_export "AlgebraicCurve.Place" "ord_uniformizerSubring'_s12"
+private theorem _root_.AlgebraicCurve.Place.dCoord_eq_D_uniformizerSubring'_s12 :
+    v.dCoord = KaehlerDifferential.D K F (uniformizerSubring' v : F) := rfl
+
+p2m_export "AlgebraicCurve.Place" "dCoord_eq_D_uniformizerSubring'_s12"
+
+private theorem _root_.AlgebraicCurve.Place.exists_mem_D_eq_smul_dCoord_s12 (hspan :
+  ValSubringKaehlerSpanTop K F)
+    {x : F} (hx : x ∈ v.toValuationSubring) :
+    ∃ c : F, c ∈ v.toValuationSubring ∧ KaehlerDifferential.D K F x = c • v.dCoord := by
+  have hmem : KaehlerDifferential.D K v.toValuationSubring (⟨x, hx⟩ : v.toValuationSubring)
+      ∈ Submodule.span v.toValuationSubring
+          {KaehlerDifferential.D K v.toValuationSubring (uniformizerSubring' v)} := by
+    rw [hspan v]; exact Submodule.mem_top
+  obtain ⟨c, hc⟩ := Submodule.mem_span_singleton.mp hmem
+  refine ⟨(c : F), c.2, ?_⟩
+  have h := congrArg (KaehlerDifferential.map K K v.toValuationSubring F) hc
+  rw [LinearMap.map_smul_of_tower, v.kaehlerMap_subring_D_uniformizer,
+    KaehlerDifferential.map_D] at h
+  calc KaehlerDifferential.D K F x
+      = KaehlerDifferential.D K F (algebraMap v.toValuationSubring F ⟨x, hx⟩) := rfl
+    _ = c • v.dCoord := h.symm
+    _ = (c : F) • v.dCoord := (algebraMap_smul F c v.dCoord).symm
+
+p2m_export "AlgebraicCurve.Place" "exists_mem_D_eq_smul_dCoord_s12"
+
+private theorem _root_.AlgebraicCurve.Place.exists_unit_D_eq_smul_dCoord_s12 (hspan :
+  ValSubringKaehlerSpanTop K F)
+    [Nontrivial Ω[F⁄K]] [v.DCoordGenerates] {ϖ : F} (hϖ : v.ord ϖ = 1) :
+    ∃ w : F, w ≠ 0 ∧ v.ord w = 0 ∧ KaehlerDifferential.D K F ϖ = w • v.dCoord := by
+  have hϖ0 : ϖ ≠ 0 := fun h => by rw [h, v.ord_zero] at hϖ; exact zero_ne_one hϖ
+  have hϖmem : ϖ ∈ v.toValuationSubring :=
+    v.mem_of_ord_nonneg_s12 hϖ0 (by rw [hϖ]; exact zero_le_one)
+  obtain ⟨c, hc, hDϖ⟩ := v.exists_mem_D_eq_smul_dCoord_s12 hspan hϖmem
+  set π₀ : F := (uniformizerSubring' v : F) with hπ₀
+  have hπ₀ord : v.ord π₀ = 1 := v.ord_uniformizerSubring'_s12
+  have hπ₀0 : π₀ ≠ 0 := fun h => by rw [h, v.ord_zero] at hπ₀ord; exact zero_ne_one hπ₀ord
+  set a : F := π₀ / ϖ with ha
+  have ha0 : a ≠ 0 := div_ne_zero hπ₀0 hϖ0
+  have haord : v.ord a = 0 := by
+    rw [ha, div_eq_mul_inv, v.ord_mul hπ₀0 (inv_ne_zero hϖ0), v.ord_inv, hπ₀ord, hϖ]; ring
+  have hamem : a ∈ v.toValuationSubring := v.mem_of_ord_nonneg_s12 ha0 haord.ge
+  obtain ⟨d, hd, hDa⟩ := v.exists_mem_D_eq_smul_dCoord_s12 hspan hamem
+  have hπ₀eq : π₀ = a * ϖ := by rw [ha, div_mul_cancel₀ _ hϖ0]
+  have hD : v.dCoord = (a * c + ϖ * d) • v.dCoord := by
+    conv_lhs => rw [v.dCoord_eq_D_uniformizerSubring'_s12, ← hπ₀, hπ₀eq, Derivation.leibniz, hDϖ,
+      hDa]
+    rw [smul_smul, smul_smul, ← add_smul, mul_comm ϖ d]
+  have hone : a * c + ϖ * d = 1 := by
+    have h1 : (1 - (a * c + ϖ * d)) • v.dCoord = 0 := by rw [sub_smul, one_smul, ← hD, sub_self]
+    rcases smul_eq_zero.mp h1 with h | h
+    · exact (sub_eq_zero.mp h).symm
+    · exact absurd h v.dCoord_ne_zero
+  have hacmem : a * c ∈ v.toValuationSubring := mul_mem hamem hc
+  have hunit : IsUnit (⟨a * c, hacmem⟩ : v.toValuationSubring) := by
+    by_contra hnu
+    have hmax : (⟨a * c, hacmem⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal
+      v.toValuationSubring :=
+      (IsLocalRing.mem_maximalIdeal _).mpr hnu
+    have hϖmax : (⟨ϖ, hϖmem⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring
+      :=
+      (v.mem_maximalIdeal_iff_ord_pos hϖ0 hϖmem).mpr (by rw [hϖ]; exact one_pos)
+    have h1 : (1 : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring := by
+      have : (1 : v.toValuationSubring)
+          = ⟨a * c, hacmem⟩ + ⟨ϖ, hϖmem⟩ * ⟨d, hd⟩ := Subtype.ext (by
+            change (1 : F) = a * c + ϖ * d
+            exact hone.symm)
+      rw [this]
+      exact add_mem hmax (Ideal.mul_mem_right _ _ hϖmax)
+    exact (IsLocalRing.maximalIdeal.isMaximal v.toValuationSubring).ne_top
+      ((Ideal.eq_top_iff_one _).mpr h1)
+  have hacord : v.ord (a * c) = 0 := by
+    have := v.ord_coe_unit hunit.unit
+    rwa [IsUnit.unit_spec] at this
+  have hc0 : c ≠ 0 := by
+    intro h0
+    have hz : (⟨a * c, hacmem⟩ : v.toValuationSubring) = 0 := Subtype.ext (by simp [h0])
+    rw [hz] at hunit
+    exact not_isUnit_zero hunit
+  have hcord : v.ord c = 0 := by
+    rw [v.ord_mul ha0 hc0, haord, zero_add] at hacord
+    exact hacord
+  exact ⟨c, hc0, hcord, hDϖ⟩
+
+p2m_export "AlgebraicCurve.Place" "exists_unit_D_eq_smul_dCoord_s12"
+
+private theorem _root_.AlgebraicCurve.Place.exists_ord_eq_zero_D_eq_smul_D_s12 (hspan :
+  ValSubringKaehlerSpanTop K F)
+    [Nontrivial Ω[F⁄K]] [v.DCoordGenerates]
+    (π π' : F) (hπ : v.ord π = 1) (hπ' : v.ord π' = 1) :
+    ∃ u : F, v.ord u = 0 ∧ KaehlerDifferential.D K F π' = u • KaehlerDifferential.D K F π := by
+  obtain ⟨w, hw0, hw, hDπ⟩ := v.exists_unit_D_eq_smul_dCoord_s12 hspan hπ
+  obtain ⟨w', hw0', hw', hDπ'⟩ := v.exists_unit_D_eq_smul_dCoord_s12 hspan hπ'
+  refine ⟨w' / w, ?_, ?_⟩
+  · rw [div_eq_mul_inv, v.ord_mul hw0' (inv_ne_zero hw0), v.ord_inv, hw', hw]; ring
+  · rw [hDπ', hDπ, smul_smul, div_mul_cancel₀ _ hw0]
+
+p2m_export "AlgebraicCurve.Place" "exists_ord_eq_zero_D_eq_smul_D_s12"
+end Place
+
+theorem exists_ord_eq_zero_D_eq_smul_D_of_isCurveOver_s12
+    [PerfectField K] [Algebra.EssFiniteType K F] [IsCurveOver K F]
+    (v : Place K F) (π π' : F) (hπ : v.ord π = 1) (hπ' : v.ord π' = 1) :
+    ∃ u : F, v.ord u = 0 ∧ KaehlerDifferential.D K F π' = u • KaehlerDifferential.D K F π := by
+  have hspan := valSubringKaehlerSpanTop_of_isCurveOver_of_perfectField_s12 (K := K) (F := F)
+  have : v.DCoordGenerates := Place.dCoordGenerates_of_valSubringKaehlerSpanTop hspan v
+  exact v.exists_ord_eq_zero_D_eq_smul_D_s12 hspan π π' hπ hπ'
+
+theorem exists_mem_D_eq_smul_D_of_isCurveOver_s12
+    [PerfectField K] [Algebra.EssFiniteType K F] [IsCurveOver K F]
+    (v : Place K F) {π : F} (hπ : v.ord π = 1) {x : F} (hx : x ∈ v.toValuationSubring) :
+    ∃ c : F, c ∈ v.toValuationSubring ∧ KaehlerDifferential.D K F x = c • KaehlerDifferential.D K F
+      π := by
+  have hspan := valSubringKaehlerSpanTop_of_isCurveOver_of_perfectField_s12 (K := K) (F := F)
+  have : v.DCoordGenerates := Place.dCoordGenerates_of_valSubringKaehlerSpanTop hspan v
+  obtain ⟨c, hc, hDx⟩ := v.exists_mem_D_eq_smul_dCoord_s12 hspan hx
+  obtain ⟨w, hw0, hw, hDπ⟩ := v.exists_unit_D_eq_smul_dCoord_s12 hspan hπ
+  refine ⟨c / w, ?_, ?_⟩
+  · rcases eq_or_ne c 0 with rfl | hc0
+    · rw [zero_div]; exact zero_mem _
+    · exact v.mem_of_ord_nonneg_s12 (div_ne_zero hc0 hw0) (by
+        rw [div_eq_mul_inv, v.ord_mul hc0 (inv_ne_zero hw0), v.ord_inv, hw, neg_zero, add_zero]
+        exact v.ord_nonneg_of_mem_s12 hc)
+  · rw [hDx, hDπ, smul_smul, div_mul_cancel₀ _ hw0]
+
+end S12WellDefined
+end AlgebraicCurve
+end
+
+section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.FiniteResidue HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor Place.FiniteResidue.finite HasCanonicalDivisor \
+  IsCurveOver.exists_separating_transcendental"
+p2m_open "AlgebraicCurve"
+
+p2m_open "KaehlerDifferential IntermediateField \
+  P2MW.S_AlgebraicCurve_hasCanonicalDivisor_of_isCurveOver.IntermediateField \
+  IntermediateField.algebraAdjoinAdjoin Polynomial"
+
+section S12HCD
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem hasCanonicalDivisor_of_generator_finiteSupport_s12
+    [IsCurveOver K F] [∀ v : Place K F, v.DCoordGenerates]
+    {ω₀ : Ω[F⁄K]} (hω₀ : ω₀ ≠ 0) (hgen : Submodule.span F ({ω₀} : Set Ω[F⁄K]) = ⊤)
+    (hfin : {v : Place K F | v.ordDifferential ω₀ ≠ 0}.Finite) :
+    HasCanonicalDivisor (K := K) (F := F) := by
+  classical
+  refine ⟨fun ω hω => ?_⟩
+  have hmem : ω ∈ Submodule.span F ({ω₀} : Set Ω[F⁄K]) := by rw [hgen]; exact Submodule.mem_top
+  obtain ⟨g, rfl⟩ := Submodule.mem_span_singleton.mp hmem
+  have hg : g ≠ 0 := by rintro rfl; exact hω (zero_smul _ _)
+  obtain ⟨Dg, hDg, -⟩ := HasPrincipalDivisors.exists_divisor (K := K) g hg
+  refine ⟨Dg + Finsupp.onFinset hfin.toFinset (fun v => v.ordDifferential ω₀)
+      (fun v hv => hfin.mem_toFinset.mpr hv), fun v => ?_⟩
+  rw [Finsupp.add_apply, Finsupp.onFinset_apply, hDg v]
+  have hc : v.differentialCoeff ω₀ ≠ 0 := by
+    intro h0; apply hω₀; rw [← v.differentialCoeff_smul_dCoord ω₀, h0, zero_smul]
+  exact (v.ordDifferential_smul hg hc).symm
+
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.ordDifferential_D_eq_zero_of_span_eq_top_s12 (hspan :
+  ValSubringKaehlerSpanTop K F)
+    [Nontrivial Ω[F⁄K]] (v : Place K F) [v.DCoordGenerates]
+    (s : v.toValuationSubring)
+    (hs : Submodule.span v.toValuationSubring
+      ({KaehlerDifferential.D K v.toValuationSubring s} : Set Ω[v.toValuationSubring⁄K]) = ⊤) :
+    v.ordDifferential (KaehlerDifferential.D K F (s : F)) = 0 := by
+  have h1mem : KaehlerDifferential.D K v.toValuationSubring s
+      ∈ Submodule.span v.toValuationSubring
+        ({KaehlerDifferential.D K v.toValuationSubring (uniformizerSubring' v)} : Set
+          Ω[v.toValuationSubring⁄K]) := by
+    rw [hspan v]; exact Submodule.mem_top
+  have h2mem : KaehlerDifferential.D K v.toValuationSubring (uniformizerSubring' v)
+      ∈ Submodule.span v.toValuationSubring
+        ({KaehlerDifferential.D K v.toValuationSubring s} : Set Ω[v.toValuationSubring⁄K]) := by
+    rw [hs]; exact Submodule.mem_top
+  obtain ⟨c, hc⟩ := Submodule.mem_span_singleton.mp h1mem
+  obtain ⟨c', hc'⟩ := Submodule.mem_span_singleton.mp h2mem
+  have h1 : KaehlerDifferential.D K F (s : F) = (c : F) • v.dCoord := by
+    have h := congrArg (KaehlerDifferential.map K K v.toValuationSubring F) hc
+    rw [LinearMap.map_smul_of_tower, v.kaehlerMap_subring_D_uniformizer,
+      KaehlerDifferential.map_D] at h
+    calc KaehlerDifferential.D K F (s : F)
+        = KaehlerDifferential.D K F (algebraMap v.toValuationSubring F s) := rfl
+      _ = c • v.dCoord := h.symm
+      _ = (c : F) • v.dCoord := (algebraMap_smul F c v.dCoord).symm
+  have h2 : v.dCoord = (c' : F) • KaehlerDifferential.D K F (s : F) := by
+    have h := congrArg (KaehlerDifferential.map K K v.toValuationSubring F) hc'
+    rw [LinearMap.map_smul_of_tower, KaehlerDifferential.map_D,
+      v.kaehlerMap_subring_D_uniformizer] at h
+    calc v.dCoord = c' • KaehlerDifferential.D K F (algebraMap v.toValuationSubring F s) := h.symm
+      _ = (c' : F) • KaehlerDifferential.D K F (s : F) := (algebraMap_smul F c' _).symm
+  have hcc : (c' : F) * c = 1 := by
+    have h3 : (1 - (c' : F) * c) • v.dCoord = 0 := by
+      rw [sub_smul, one_smul, mul_smul, ← h1, ← h2, sub_self]
+    rcases smul_eq_zero.mp h3 with h | h
+    · exact (sub_eq_zero.mp h).symm
+    · exact absurd h v.dCoord_ne_zero
+  have hc0 : (c : F) ≠ 0 := fun h => by rw [h, mul_zero] at hcc; exact zero_ne_one hcc
+  have hc'0 : (c' : F) ≠ 0 := fun h => by rw [h, zero_mul] at hcc; exact zero_ne_one hcc
+  have hcord : v.ord (c : F) = 0 := by
+    have hsum : v.ord (c' : F) + v.ord (c : F) = 0 := by rw [← v.ord_mul hc'0 hc0, hcc, v.ord_one]
+    have h4 := v.ord_nonneg_of_mem_s12 c.2
+    have h5 := v.ord_nonneg_of_mem_s12 c'.2
+    omega
+  have hcoeff : v.differentialCoeff (KaehlerDifferential.D K F (s : F)) = c :=
+    v.differentialCoeff_unique h1
+  change v.ord (v.differentialCoeff _) = 0
+  rw [hcoeff]; exact hcord
+
+end Place
+p2m_export "AlgebraicCurve" "Place.ordDifferential_D_eq_zero_of_span_eq_top_s12"
+
+theorem mem_span_D_adjoin_s12 (t : F) (ω : Ω[↥(Algebra.adjoin K ({t} : Set F))⁄K]) :
+    ω ∈ Submodule.span ↥(Algebra.adjoin K ({t} : Set F))
+      ({(KaehlerDifferential.D K ↥(Algebra.adjoin K ({t} : Set F))
+        ⟨t, Algebra.self_mem_adjoin_singleton K t⟩)} : Set Ω[↥(Algebra.adjoin K ({t} : Set F))⁄K])
+          := by
+  have htop : ω ∈ Submodule.span ↥(Algebra.adjoin K ({t} : Set F))
+      (Set.range (KaehlerDifferential.D K ↥(Algebra.adjoin K ({t} : Set F)))) := by
+    rw [KaehlerDifferential.span_range_derivation]; exact Submodule.mem_top
+  refine Submodule.span_le.mpr ?_ htop
+  rintro _ ⟨r, rfl⟩
+  have hr : (r : F) ∈ (Polynomial.aeval (R := K) t).range := by
+    rw [← Algebra.adjoin_singleton_eq_range_aeval]; exact r.2
+  obtain ⟨Q, hQ⟩ := hr
+  have hr' : r = Polynomial.aeval (⟨t, Algebra.self_mem_adjoin_singleton K t⟩ : Algebra.adjoin K
+    ({t} : Set F)) Q :=
+    by
+    apply Subtype.ext
+    change (r : F) = (Algebra.adjoin K ({t} : Set F)).val (Polynomial.aeval _ Q)
+    rw [← Polynomial.aeval_algHom_apply]
+    exact hQ.symm
+  rw [hr', Derivation.map_aeval]
+  exact Submodule.smul_mem _ _ (Submodule.subset_span rfl)
+
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.span_D_eq_top_of_isUnramifiedAt_s12 (v : Place K F)
+    (T : Subalgebra K F)
+    (hT : (T : Set F) ⊆ (v.toValuationSubring : Set F))
+    {t : F} (hRT : Algebra.adjoin K ({t} : Set F) ≤ T)
+    [IsDedekindDomain T] [IsFractionRing T F]
+    (hunr : letI : Algebra ↥(Algebra.adjoin K ({t} : Set F)) T := (Subalgebra.inclusion
+      hRT).toRingHom.toAlgebra
+      Algebra.IsUnramifiedAt ↥(Algebra.adjoin K ({t} : Set F)) (v.centerIdeal T hT)) :
+    Submodule.span v.toValuationSubring
+      ({(KaehlerDifferential.D K v.toValuationSubring
+        ⟨t, hT (hRT (Algebra.self_mem_adjoin_singleton K t))⟩)} : Set Ω[v.toValuationSubring⁄K]) = ⊤
+          := by
+  let iRT : Algebra ↥(Algebra.adjoin K ({t} : Set F)) T :=
+    (Subalgebra.inclusion hRT).toRingHom.toAlgebra
+  let iTO : Algebra T v.toValuationSubring := v.modelAlgebra T hT
+  let iRO : Algebra ↥(Algebra.adjoin K ({t} : Set F)) v.toValuationSubring :=
+    ((algebraMap T v.toValuationSubring).comp (algebraMap ↥(Algebra.adjoin K ({t} : Set F))
+      T)).toAlgebra
+  have : IsScalarTower ↥(Algebra.adjoin K ({t} : Set F)) T v.toValuationSubring :=
+    IsScalarTower.of_algebraMap_eq fun _ => rfl
+  have : IsScalarTower K ↥(Algebra.adjoin K ({t} : Set F)) v.toValuationSubring :=
+    IsScalarTower.of_algebraMap_eq fun a => Subtype.ext rfl
+  have hloc := v.isLocalization_centerIdeal_of_isDedekindDomain T hT
+  have : Algebra.FormallyUnramified ↥(Algebra.adjoin K ({t} : Set F))
+      (Localization.AtPrime (v.centerIdeal T hT)) := hunr
+  let e : Localization.AtPrime (v.centerIdeal T hT) ≃ₐ[T] v.toValuationSubring :=
+    IsLocalization.algEquiv (v.centerIdeal T hT).primeCompl _ _
+  have : Algebra.FormallyUnramified ↥(Algebra.adjoin K ({t} : Set F)) v.toValuationSubring :=
+    Algebra.FormallyUnramified.of_equiv (e.restrictScalars ↥(Algebra.adjoin K ({t} : Set F)))
+  have hsub : Subsingleton Ω[v.toValuationSubring⁄↥(Algebra.adjoin K ({t} : Set F))] :=
+    Algebra.FormallyUnramified.subsingleton_kaehlerDifferential
+  have hrange : LinearMap.range
+      (KaehlerDifferential.mapBaseChange K ↥(Algebra.adjoin K ({t} : Set F)) v.toValuationSubring) =
+        ⊤ := by
+    rw [KaehlerDifferential.range_mapBaseChange]
+    exact LinearMap.ker_eq_top.mpr (Subsingleton.elim _ _)
+  have htO : algebraMap ↥(Algebra.adjoin K ({t} : Set F)) v.toValuationSubring
+      ⟨t, Algebra.self_mem_adjoin_singleton K t⟩
+        = ⟨t, hT (hRT (Algebra.self_mem_adjoin_singleton K t))⟩ := Subtype.ext rfl
+  have hle : LinearMap.range
+      (KaehlerDifferential.mapBaseChange K ↥(Algebra.adjoin K ({t} : Set F)) v.toValuationSubring)
+      ≤ Submodule.span v.toValuationSubring
+        ({(KaehlerDifferential.D K v.toValuationSubring
+          ⟨t, hT (hRT (Algebra.self_mem_adjoin_singleton K t))⟩)} : Set Ω[v.toValuationSubring⁄K])
+            := by
+    rintro _ ⟨x, rfl⟩
+    induction x with
+    | add x y hx hy => rw [map_add]; exact add_mem hx hy
+    | tmul b ω =>
+      rw [KaehlerDifferential.mapBaseChange_tmul]
+      refine Submodule.smul_mem _ b ?_
+      obtain ⟨r, hr⟩ := Submodule.mem_span_singleton.mp (mem_span_D_adjoin_s12 t ω)
+      rw [← hr, LinearMap.map_smul_of_tower, KaehlerDifferential.map_D, htO]
+      exact Submodule.smul_mem _ _ (Submodule.subset_span rfl)
+  exact top_le_iff.mp (hrange ▸ hle)
+
+end Place
+p2m_export "AlgebraicCurve" "Place.span_D_eq_top_of_isUnramifiedAt_s12"
+
+p2m_open_scoped "AlgebraicCurve.Place" in
+theorem Place.eq_of_centerIdeal_eq_s12 (T : Subalgebra K F) [IsDedekindDomain T]
+    [IsFractionRing T F]
+    {v₁ v₂ : Place K F} (h₁ : (T : Set F) ⊆ (v₁.toValuationSubring : Set F))
+    (h₂ : (T : Set F) ⊆ (v₂.toValuationSubring : Set F))
+    (hP : v₁.centerIdeal T h₁ = v₂.centerIdeal T h₂) : v₁ = v₂ := by
+  have hle : v₁.centerLocalizationValuationSubring T h₁ ≤ v₂.toValuationSubring := by
+    intro x hx
+    change x ∈ (v₁.centerLocalizationSubalgebra T h₁ : Subalgebra T F) at hx
+    obtain ⟨a, s, hs, rfl⟩ := hx
+    rw [← div_eq_mul_inv]
+    exact div_mem_of_not_mem_centerIdeal v₂ T h₂ a (hP ▸ hs)
+  have heq := ValuationSubring.eq_of_isDiscreteValuationRing_of_le_s12 hle v₂.ne_top'
+  rw [v₁.centerLocalizationValuationSubring_eq T h₁] at heq
+  cases v₁; cases v₂
+  congr
+
+theorem adjoin_le_transcendentalChart_s12 (t : F) :
+    Algebra.adjoin K ({t} : Set F) ≤ transcendentalChart K t := by
+  intro x hx
+  change x ∈ integralClosure ↥(Algebra.adjoin K ({t} : Set F)) F
+  rw [mem_integralClosure_iff]
+  exact isIntegral_algebraMap (R := ↥(Algebra.adjoin K ({t} : Set F))) (A := F) (x := ⟨x, hx⟩)
+
+attribute [local instance] FractionRing.liftAlgebra FractionRing.isScalarTower_liftAlgebra
+
+theorem finite_ordDifferential_D_ne_zero_s12 (hspan : ValSubringKaehlerSpanTop K F)
+    [IsCurveOver K F] [∀ v : Place K F, v.DCoordGenerates] [PerfectField K]
+    {t : F} (htr : Transcendental K t) [FiniteDimensional K⟮t⟯ F] [Algebra.IsSeparable K⟮t⟯ F] :
+    {v : Place K F | v.ordDifferential (KaehlerDifferential.D K F t) ≠ 0}.Finite := by
+  classical
+  have ht0 : t ≠ 0 := fun h => htr (h ▸ isAlgebraic_zero)
+  have hRT : Algebra.adjoin K ({t} : Set F) ≤ transcendentalChart K t :=
+    adjoin_le_transcendentalChart_s12 t
+  obtain ⟨hft, hded, hfrac⟩ := isAffineChart_transcendentalChart (K := K) htr
+  have : IsDedekindDomain ↥(transcendentalChart K t) := hded
+  have : IsFractionRing ↥(transcendentalChart K t) F := hfrac
+  let iRT : Algebra ↥(Algebra.adjoin K ({t} : Set F)) ↥(transcendentalChart K t) :=
+    (Subalgebra.inclusion hRT).toRingHom.toAlgebra
+  have : IsScalarTower ↥(Algebra.adjoin K ({t} : Set F)) ↥(transcendentalChart K t) F :=
+    IsScalarTower.of_algebraMap_eq fun _ => rfl
+  have : IsPrincipalIdealRing ↥(Algebra.adjoin K ({t} : Set F)) :=
+    htr.isPrincipalIdealRing_adjoin_s12
+  have : IsDedekindDomain ↥(Algebra.adjoin K ({t} : Set F)) := htr.isDedekindDomain_adjoin_s12
+  have hinj : Function.Injective (algebraMap ↥(Algebra.adjoin K ({t} : Set F)) ↥(transcendentalChart
+    K t)) :=
+    Subalgebra.inclusion_injective hRT
+  have : FaithfulSMul ↥(Algebra.adjoin K ({t} : Set F)) ↥(transcendentalChart K t) :=
+    (faithfulSMul_iff_algebraMap_injective _ _).mpr hinj
+  have : Module.IsTorsionFree ↥(Algebra.adjoin K ({t} : Set F)) ↥(transcendentalChart K t) := by
+    rw [Module.isTorsionFree_iff_smul_eq_zero]
+    intro c x h
+    rw [Algebra.smul_def] at h
+    rcases mul_eq_zero.mp h with h | h
+    · exact Or.inl (hinj (by rw [h, map_zero]))
+    · exact Or.inr h
+  have : Module.Finite ↥(Algebra.adjoin K ({t} : Set F)) ↥(transcendentalChart K t) :=
+    moduleFinite_integralClosure_adjoin (K := K) htr
+  have : Algebra.EssFiniteType ↥(Algebra.adjoin K ({t} : Set F)) ↥(transcendentalChart K t) :=
+    inferInstance
+  have : FaithfulSMul ↥(Algebra.adjoin K ({t} : Set F)) (FractionRing ↥(transcendentalChart K t)) :=
+    inferInstance
+  have : Algebra.IsSeparable (FractionRing ↥(Algebra.adjoin K ({t} : Set F)))
+      (FractionRing ↥(transcendentalChart K t)) := by
+    let e₁ : FractionRing ↥(Algebra.adjoin K ({t} : Set F)) ≃ₐ[↥(Algebra.adjoin K ({t} : Set F))]
+      K⟮t⟯ :=
+      FractionRing.algEquiv _ K⟮t⟯
+    let e₂ : FractionRing ↥(transcendentalChart K t) ≃ₐ[↥(transcendentalChart K t)] F :=
+      FractionRing.algEquiv _ F
+    refine Algebra.IsSeparable.of_equiv_equiv e₁.symm.toRingEquiv e₂.symm.toRingEquiv ?_
+    ext r
+    exact IsFractionRing.algEquiv_commutes e₁.symm e₂.symm r
+  have hdiff : differentIdeal ↥(Algebra.adjoin K ({t} : Set F)) ↥(transcendentalChart K t) ≠ ⊥ :=
+    differentIdeal_ne_bot
+  have hfinP : {P : IsDedekindDomain.HeightOneSpectrum ↥(transcendentalChart K t) |
+      P.asIdeal ∣ differentIdeal ↥(Algebra.adjoin K ({t} : Set F)) ↥(transcendentalChart K
+        t)}.Finite :=
+    Ideal.finite_factors hdiff
+  obtain ⟨Dt, hDt, -⟩ := HasPrincipalDivisors.exists_divisor (K := K) t ht0
+  have hpole : {v : Place K F | v.ord t < 0}.Finite := by
+    refine (Dt.support.finite_toSet).subset ?_
+    intro v hv
+    simp only [Set.mem_ofPred_eq, Finset.mem_coe, Finsupp.mem_support_iff] at hv ⊢
+    rw [hDt v]; omega
+  have hsub : ∀ v : Place K F, 0 ≤ v.ord t →
+      ((transcendentalChart K t : Subalgebra K F) : Set F) ⊆ (v.toValuationSubring : Set F) := by
+    intro v hv
+    exact transcendentalChart_subset_valuationSubring_of_mem v (v.mem_of_ord_nonneg_s12 ht0 hv)
+  have key : ∀ (v : Place K F) (hv : 0 ≤ v.ord t),
+      ¬ ((v.centerIdeal (transcendentalChart K t) (hsub v hv)) ∣
+          differentIdeal ↥(Algebra.adjoin K ({t} : Set F)) ↥(transcendentalChart K t)) →
+      v.ordDifferential (KaehlerDifferential.D K F t) = 0 := by
+    intro v hv hndvd
+    have hunr := (not_dvd_differentIdeal_iff (A := ↥(Algebra.adjoin K ({t} : Set F)))
+      (B := ↥(transcendentalChart K t))).mp hndvd
+    have hs := v.span_D_eq_top_of_isUnramifiedAt_s12 (transcendentalChart K t) (hsub v hv) hRT hunr
+    exact v.ordDifferential_D_eq_zero_of_span_eq_top_s12 hspan
+      ⟨t, (hsub v hv) (hRT (Algebra.self_mem_adjoin_singleton K t))⟩ hs
+  have hS₂ : {v : Place K F | ∃ hv : 0 ≤ v.ord t, (v.centerIdeal (transcendentalChart K t) (hsub v
+    hv)) ∣
+      differentIdeal ↥(Algebra.adjoin K ({t} : Set F)) ↥(transcendentalChart K t)}.Finite := by
+    have := hfinP.to_subtype
+    let g : {v : Place K F | ∃ hv : 0 ≤ v.ord t, (v.centerIdeal (transcendentalChart K t) (hsub v
+      hv)) ∣
+        differentIdeal ↥(Algebra.adjoin K ({t} : Set F)) ↥(transcendentalChart K t)} →
+        {P : IsDedekindDomain.HeightOneSpectrum ↥(transcendentalChart K t) |
+          P.asIdeal ∣ differentIdeal ↥(Algebra.adjoin K ({t} : Set F)) ↥(transcendentalChart K t)}
+            :=
+      fun x => ⟨⟨x.1.centerIdeal (transcendentalChart K t) (hsub x.1 x.2.1), inferInstance,
+        x.1.centerIdeal_ne_bot_of_isFractionRing (transcendentalChart K t) (hsub x.1 x.2.1)⟩, x.2.2⟩
+    have hg : Function.Injective g := by
+      rintro ⟨v₁, hv₁, hd₁⟩ ⟨v₂, hv₂, hd₂⟩ h
+      have hP := congrArg (fun P => P.1.asIdeal) h
+      exact Subtype.ext (Place.eq_of_centerIdeal_eq_s12 (transcendentalChart K t) _ _ hP)
+    have := Finite.of_injective g hg
+    exact Set.toFinite _
+  refine (hpole.union hS₂).subset ?_
+  intro v hv
+  by_cases h0 : 0 ≤ v.ord t
+  · right
+    by_contra hnot
+    exact hv (key v h0 (fun hd => hnot ⟨h0, hd⟩))
+  · left
+    exact lt_of_not_ge h0
+
+theorem hasCanonicalDivisor_of_isCurveOver_s12
+    [PerfectField K] [Algebra.EssFiniteType K F] [IsCurveOver K F] :
+    HasCanonicalDivisor (K := K) (F := F) := by
+  have hspan := valSubringKaehlerSpanTop_of_isCurveOver_of_perfectField_s12 (K := K) (F := F)
+  have : ∀ v : Place K F, v.DCoordGenerates := fun v =>
+    Place.dCoordGenerates_of_valSubringKaehlerSpanTop hspan v
+  obtain ⟨t, htr, hfd, hsep⟩ := IsCurveOver.exists_separating_transcendental (K := K) (F := F)
+  have := hfd
+  have := hsep
+  exact hasCanonicalDivisor_of_generator_finiteSupport_s12
+    (KaehlerDifferential.D_ne_zero_of_transcendental K t htr)
+    (KaehlerDifferential.span_D_eq_top_of_transcendental K t htr)
+    (finite_ordDifferential_D_ne_zero_s12 hspan htr)
+
+end S12HCD
+end AlgebraicCurve
+end
+
+theorem solution
+    {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [PerfectField K] [Algebra.EssFiniteType K F] [AlgebraicCurve.IsCurveOver K F] :
+    AlgebraicCurve.HasCanonicalDivisor (K := K) (F := F) := by
+  exact AlgebraicCurve.hasCanonicalDivisor_of_isCurveOver_s12
+
+end
+end S_AlgebraicCurve_hasCanonicalDivisor_of_isCurveOver
+end P2MW
+export P2MW.S_AlgebraicCurve_hasCanonicalDivisor_of_isCurveOver (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.hasCanonicalDivisor_of_isCurveOver
+    {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [PerfectField K] [Algebra.EssFiniteType K F] [AlgebraicCurve.IsCurveOver K F] :
+    AlgebraicCurve.HasCanonicalDivisor (K := K) (F := F) :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_hasPrincipalDivisors_adjoin_of_transcendental.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_hasPrincipalDivisors_adjoin_of_transcendental.lean
new file mode 100644
index 0000000000..ffdbe0667f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_hasPrincipalDivisors_adjoin_of_transcendental.lean
@@ -0,0 +1,152 @@
+/-
+Based on Prove2Me node AlgebraicCurve.hasPrincipalDivisors_adjoin_of_transcendental
+(e49a8052-c48a-5975-9da7-693d21f3ccf2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 38904e51-cb4d-538f-a36c-844c17b83510
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_hasPrincipalDivisors_of_transcendental
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Principal divisors on K(x,T) with x transcendental, T integral
+
+Theorem statement: `AlgebraicCurve.hasPrincipalDivisors_adjoin_of_transcendental`
+(`e49a8052-c48a-5975-9da7-693d21f3ccf2`), by Claude, 2026-09-05.
+
+Proof: submission `38904e51-cb4d-538f-a36c-844c17b83510`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field of characteristic $0$ and $LF$ a field equipped with a $K$-algebra structure. Let
+$x \in LF$ be transcendental over $K$, and let $T$ be a finite subset of $LF$ each of whose elements
+is integral over the intermediate field $\mathrm{adjoin}\,K\,\{x\} = K(x) \subseteq LF$. Then the
+intermediate field $F = \mathrm{adjoin}\,K\,(\{x\} \cup T) \subseteq LF$ generated over $K$ by $x$
+together with the elements of $T$ satisfies `HasPrincipalDivisors K F`: for every $f \in F$ with $f
+\neq 0$ there is a divisor $D$, that is a finitely supported function from the places of $F$ over
+$K$ to $\mathbb{Z}$, such that $D(v) = v.\mathrm{ord}\,f$ for every place $v$, and the degree
+$\sum_v D(v)\cdot v.\mathrm{deg}$ of $D$ vanishes. Here a place of $F$ over $K$ is a valuation
+subring of $F$ that contains the image of $K$, is not the whole of $F$, and is a principal ideal
+ring. In particular the family of values $v.\mathrm{ord}\,f$ is finitely supported, so $f$ has only
+finitely many zeros and poles.
+
+This is the theorem that the degree of a principal divisor is zero, for a function field of one
+variable presented by generators: a transcendental element together with finitely many elements
+integral over the rational subfield it generates. It is applied to the field of modular functions of
+level $N$ realised inside a Laurent series field, with $x = j$ and $T$ the set of $j(q^d)$ for $d
+\mid N$, in
+[`ModularCurve.hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull`]
+(thm.html#ModularCurve.hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_hasPrincipalDivisors_adjoin_of_transcendental.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_hasPrincipalDivisors_adjoin_of_transcendental
+
+noncomputable section
+open IntermediateField
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "HasPrincipalDivisors hasPrincipalDivisors_of_transcendental"
+p2m_open "AlgebraicCurve"
+namespace W2
+
+variable (K : Type*) [Field K] [CharZero K] {LF : Type*} [Field LF] [Algebra K LF]
+
+theorem hasPrincipalDivisors_adjoin (x : LF) (hx : Transcendental K x) (T : Finset LF)
+    (hT : ∀ t ∈ T, IsIntegral (IntermediateField.adjoin K ({x} : Set LF)) t) :
+    HasPrincipalDivisors K (IntermediateField.adjoin K (insert x (T : Set LF))) := by
+  set F : IntermediateField K LF := IntermediateField.adjoin K (insert x (T : Set LF)) with hF
+  have hxF : x ∈ F := subset_adjoin K _ (Set.mem_insert x _)
+  have hTF : ∀ t ∈ T, t ∈ F := fun t ht => subset_adjoin K _ (Set.mem_insert_of_mem x ht)
+  set x' : F := ⟨x, hxF⟩ with hx'
+  have hx't : Transcendental K x' :=
+    (transcendental_algebraMap_iff (R := K) (S := F) (A := LF) Subtype.val_injective).mp hx
+  set A : IntermediateField K F := IntermediateField.adjoin K ({x'} : Set F) with hA
+  have hliftA : lift A = IntermediateField.adjoin K ({x} : Set LF) := by
+    rw [hA, lift_adjoin_simple]
+  let e : A ≃ₐ[K] IntermediateField.adjoin K ({x} : Set LF) :=
+    (liftAlgEquiv A).trans (equivOfEq hliftA)
+  have he : ∀ a : A, ((e a : IntermediateField.adjoin K ({x} : Set LF)) : LF) = ((a : F) : LF) := by
+    intro a; rfl
+  have hint : ∀ t (ht : t ∈ T), IsIntegral A (⟨t, hTF t ht⟩ : F) := by
+    intro t ht
+    have h1 : IsIntegral A (t : LF) := by
+      refine (hT t ht).map_of_comp_eq (R := IntermediateField.adjoin K ({x} : Set LF)) (S := LF) (T
+        := A) (U := LF)
+        (e.symm : IntermediateField.adjoin K ({x} : Set LF) →+* A) (RingHom.id LF) ?_
+      ext b
+      change (((e.symm b : A) : F) : LF) = ((b : IntermediateField.adjoin K ({x} : Set LF)) : LF)
+      rw [← he (e.symm b), AlgEquiv.apply_symm_apply]
+    exact (isIntegral_algHom_iff (IsScalarTower.toAlgHom A F LF) Subtype.val_injective).mp h1
+  have : FiniteDimensional A F := by
+    set T' : Set F := (fun t : T => (⟨(t : LF), hTF t t.2⟩ : F)) '' Set.univ with hT'
+    have : Finite T' := Set.Finite.to_subtype ((Set.finite_univ).image _)
+    have hT'int : ∀ y ∈ T', IsIntegral A y := by
+      rintro _ ⟨t, -, rfl⟩; exact hint t t.2
+    have : FiniteDimensional A (IntermediateField.adjoin A T') := finiteDimensional_adjoin hT'int
+    have htop : IntermediateField.adjoin A T' = ⊤ := by
+      apply restrictScalars_injective K
+      rw [restrictScalars_adjoin, restrictScalars_top]
+      apply lift_injective
+      rw [lift_top, lift_adjoin]
+      apply le_antisymm (adjoin_le_iff.mpr ?_) ?_
+      · rintro _ ⟨y, hy, rfl⟩; exact y.2
+      · change IntermediateField.adjoin K (insert x (T : Set LF)) ≤ _
+        apply adjoin.mono
+        intro z hz
+        rcases hz with rfl | hz
+        · exact ⟨x', Or.inl (subset_adjoin K _ (Set.mem_singleton _)), rfl⟩
+        · exact ⟨⟨z, hTF z hz⟩, Or.inr ⟨⟨z, hz⟩, Set.mem_univ _, rfl⟩, rfl⟩
+    rw [htop] at this
+    exact LinearEquiv.finiteDimensional (IntermediateField.topEquiv (F := A) (E := F)).toLinearEquiv
+  exact hasPrincipalDivisors_of_transcendental K x' hx't
+
+end W2
+end AlgebraicCurve
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_hasPrincipalDivisors_adjoin_of_transcendental.AlgebraicCurve"
+
+theorem solution (K : Type*) [Field K] [CharZero K] {LF : Type*} [Field LF] [Algebra K LF]
+    (x : LF) (hx : Transcendental K x) (T : Finset LF)
+    (hT : ∀ t ∈ T, IsIntegral (IntermediateField.adjoin K ({x} : Set LF)) t) :
+    HasPrincipalDivisors K (IntermediateField.adjoin K (insert x (T : Set LF))) :=
+  AlgebraicCurve.W2.hasPrincipalDivisors_adjoin K x hx T hT
+
+end
+
+end S_AlgebraicCurve_hasPrincipalDivisors_adjoin_of_transcendental
+end P2MW
+export P2MW.S_AlgebraicCurve_hasPrincipalDivisors_adjoin_of_transcendental (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.hasPrincipalDivisors_adjoin_of_transcendental (K : Type*) [Field K]
+    [CharZero K] {LF : Type*} [Field LF] [Algebra K LF]
+    (x : LF) (hx : Transcendental K x) (T : Finset LF)
+    (hT : ∀ t ∈ T, IsIntegral (IntermediateField.adjoin K ({x} : Set LF)) t) :
+    HasPrincipalDivisors K (IntermediateField.adjoin K (insert x (T : Set LF))) :=
+  solution K x hx T hT
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_hasPrincipalDivisors_of_finiteDimensional_of_isSeparable.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_hasPrincipalDivisors_of_finiteDimensional_of_isSeparable.lean
new file mode 100644
index 0000000000..e4eae4298c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_hasPrincipalDivisors_of_finiteDimensional_of_isSeparable.lean
@@ -0,0 +1,270 @@
+/-
+Based on Prove2Me node AlgebraicCurve.hasPrincipalDivisors_of_finiteDimensional_of_isSeparable
+(232eae2d-946e-5911-8a07-beaaf516642b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d54a6a76-b64d-59ad-9655-103d0ec4f2f6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+public import Mathlib.FieldTheory.RatFunc.Basic
+
+import Mathlib.Analysis.Normed.Ring.Lemmas
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.Norm.Transitivity
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_fiberOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_hasPrincipalDivisors
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finite_setOf_ord_ne_zero_of_finiteDimensional
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree-zero principal divisors for separable extensions of K(t)
+
+Theorem statement: `AlgebraicCurve.hasPrincipalDivisors_of_finiteDimensional_of_isSeparable`
+(`232eae2d-946e-5911-8a07-beaaf516642b`), by Claude, 2026-09-05.
+
+Proof: submission `d54a6a76-b64d-59ad-9655-103d0ec4f2f6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $E$ be a field equipped with a $K$-algebra structure and a
+$\mathrm{RatFunc}\,K$-algebra structure which are compatible, in the sense that $K \to
+\mathrm{RatFunc}\,K \to E$ is a scalar tower; assume $E$ is finite-dimensional over the rational
+function field $\mathrm{RatFunc}\,K$ and that the extension $E/\mathrm{RatFunc}\,K$ is separable.
+The conclusion is the class `HasPrincipalDivisors K E`, that is: for every $f \in E$ with $f \neq 0$
+there exists a divisor $D$, meaning a finitely supported function from the places of $E$ over $K$ to
+$\mathbb{Z}$, such that $D\,v = v.\mathrm{ord}\,f$ for every place $v$, and such that $D$ has degree
+$0$, the degree being $\sum_{v \in \operatorname{supp} D} D\,v \cdot \deg v$. Here a place of $E$
+over $K$ is a valuation subring of $E$ which contains the image of $K$ under the structure map, is
+not the whole of $E$, and is a principal ideal ring. Since $D$ is required to be finitely supported
+and to agree with $v \mapsto v.\mathrm{ord}\,f$ at every place, the assertion includes the statement
+that $f$ has nonzero order at only finitely many places.
+
+This is the degree-zero property of principal divisors for a global function field presented as a
+finite separable extension of $K(t)$, the basic ingredient in the divisor-class theory of curves
+over $K$. It is the form of the result used to deduce the same statement for an arbitrary separable
+extension generated by a transcendental element, in
+[`AlgebraicCurve.hasPrincipalDivisors_of_transcendental_of_isSeparable`]
+(thm.html#AlgebraicCurve.hasPrincipalDivisors_of_transcendental_of_isSeparable);
+the proof reduces to the rational function field case together with the conservation of degrees in
+the fibre of a place, via the sum of ramification indices times inertia degrees.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_hasPrincipalDivisors_of_finiteDimensional_of_isSeparable.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_hasPrincipalDivisors_of_finiteDimensional_of_isSeparable
+open AlgebraicCurve Polynomial IntermediateField
+
+noncomputable section
+
+namespace HPDfdPort
+
+section General
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+theorem degree_eq_finrank_mul {g : F}
+    {D' : Divisor K F'} (hD' : ∀ w : Place K F', D' w = w.ord (algebraMap F F' g))
+    {D : Divisor K F} (hD : ∀ v : Place K F, D v = v.ord g) :
+    Divisor.degree D' = (Module.finrank F F' : ℤ) * Divisor.degree D := by
+  classical
+  have hmaps : ∀ w ∈ D'.support, w.restrict F ∈ D.support := by
+    intro w hw
+    rw [Finsupp.mem_support_iff] at hw ⊢
+    intro h0
+    apply hw
+    rw [hD' w, w.ord_restrict g, hD (w.restrict F)] at *
+    rw [h0, mul_zero]
+  have happ : ∀ w : Place K F', D' w = (w.ramificationIndex F : ℤ) * D (w.restrict F) := by
+    intro w
+    rw [hD' w, w.ord_restrict g, hD]
+  rw [Divisor.degree_eq_sum, Divisor.degree_eq_sum,
+    ← Finset.sum_fiberwise_of_maps_to hmaps fun w => D' w * (w.deg : ℤ), Finset.mul_sum]
+  refine Finset.sum_congr rfl fun v hv => ?_
+  have hfiber : D'.support.filter (fun w => w.restrict F = v) = v.fiberOver F' := by
+    ext w
+    simp only [Finset.mem_filter, Finsupp.mem_support_iff, Place.mem_fiberOver,
+      and_iff_right_iff_imp]
+    intro hw
+    rw [happ w, hw]
+    have he : 0 < w.ramificationIndex F := w.ramificationIndex_pos (F := F)
+    have hv0 : D v ≠ 0 := Finsupp.mem_support_iff.mp hv
+    exact mul_ne_zero (by exact_mod_cast he.ne') hv0
+  calc
+    ∑ w ∈ D'.support with w.restrict F = v, D' w * (w.deg : ℤ)
+        = D v * ∑ w ∈ v.fiberOver F',
+            (w.ramificationIndex F : ℤ) * (w.deg : ℤ) := by
+          rw [hfiber, Finset.mul_sum]
+          refine Finset.sum_congr rfl fun w hw => ?_
+          rw [happ w, (Place.mem_fiberOver v).mp hw]
+          ring
+    _ = D v * ((Module.finrank F F' : ℤ) * (v.deg : ℤ)) := by
+          congr 1
+          rw [← Place.sum_ramificationIndex_mul_inertiaDeg_fiberOver (K := K) (F' := F') v]
+          rw [Finset.sum_mul]
+          refine Finset.sum_congr rfl fun w hw => ?_
+          have hwr := (Place.mem_fiberOver v).mp hw
+          have hdeg := w.deg_restrict_mul_inertiaDeg (F := F)
+          rw [hwr] at hdeg
+          have hdegZ : (w.deg : ℤ) = (v.deg : ℤ) * (w.inertiaDeg F : ℤ) := by
+            exact_mod_cast hdeg.symm
+          rw [hdegZ]; ring
+    _ = (Module.finrank F F' : ℤ) * (D v * (v.deg : ℤ)) := by ring
+
+theorem Place.ord_prod' {ι : Type*} (v : Place K F') (s : Finset ι)
+    (g : ι → F') (hg : ∀ i ∈ s, g i ≠ 0) :
+    v.ord (∏ i ∈ s, g i) = ∑ i ∈ s, v.ord (g i) := by
+  classical
+  induction s using Finset.cons_induction with
+  | empty => simp
+  | cons i s hi ih =>
+    rw [Finset.prod_cons, Finset.sum_cons,
+      v.ord_mul (hg i (Finset.mem_cons_self i s))
+        (Finset.prod_ne_zero_iff.mpr fun j hj => hg j (Finset.mem_cons_of_mem hj)),
+      ih fun j hj => hg j (Finset.mem_cons_of_mem hj)]
+
+omit [Algebra.IsSeparable F F'] in
+theorem sum_smul_apply_eq_ord_prod {f : F'} (hf : f ≠ 0)
+    {D : Divisor K F'} (hD : ∀ w : Place K F', D w = w.ord f) (w : Place K F') :
+    (∑ σ : F' ≃ₐ[F] F', (AlgEquiv.restrictScalars K σ) • D) w
+      = w.ord (∏ σ : F' ≃ₐ[F] F', σ f) := by
+  classical
+  rw [Place.ord_prod' w _ _ (fun σ _ => by simpa using hf), Finset.sum_apply']
+  refine Finset.sum_congr rfl fun σ _ => ?_
+  rw [Divisor.smul_apply, hD]
+  have h := Place.ord_smul (AlgEquiv.restrictScalars K σ)
+    ((AlgEquiv.restrictScalars K σ)⁻¹ • w) f
+  rw [smul_inv_smul] at h
+  exact h.symm
+
+theorem degree_eq_zero_of_isGalois [IsGalois F F'] [HasPrincipalDivisors K F]
+    {f : F'} {D : Divisor K F'} (hD : ∀ w : Place K F', D w = w.ord f) :
+    Divisor.degree D = 0 := by
+  classical
+  rcases eq_or_ne f 0 with rfl | hf
+  · have : D = 0 := Finsupp.ext fun w => by simpa using hD w
+    rw [this, map_zero]
+  set D'' : Divisor K F' := ∑ σ : F' ≃ₐ[F] F', (AlgEquiv.restrictScalars K σ) • D with hE
+  have hEord : ∀ w : Place K F', D'' w = w.ord (algebraMap F F' (Algebra.norm F f)) := by
+    intro w
+    rw [hE, sum_smul_apply_eq_ord_prod hf hD w, Algebra.norm_eq_prod_automorphisms F f]
+  have hnorm : Algebra.norm F f ≠ 0 := (Algebra.norm_ne_zero_iff (R := F)).mpr hf
+  obtain ⟨D₀, hD₀, hD₀deg⟩ := HasPrincipalDivisors.exists_divisor (K := K)
+    (Algebra.norm F f) hnorm
+  have hEdeg : Divisor.degree D'' = 0 := by
+    rw [degree_eq_finrank_mul hEord hD₀, hD₀deg, mul_zero]
+  have hEdeg' : Divisor.degree D'' = (Module.finrank F F' : ℤ) * Divisor.degree D := by
+    rw [hE, map_sum]
+    simp only [Divisor.degree_smul]
+    rw [Finset.sum_const, Finset.card_univ, nsmul_eq_mul]
+    congr 1
+    exact_mod_cast (Nat.card_eq_fintype_card (α := F' ≃ₐ[F] F')).symm.trans
+      (IsGalois.card_aut_eq_finrank F F')
+  have hpos : (0 : ℤ) < (Module.finrank F F' : ℤ) := by
+    exact_mod_cast Module.finrank_pos (R := F) (M := F')
+  rw [hEdeg] at hEdeg'
+  exact (mul_eq_zero.mp hEdeg'.symm).resolve_left hpos.ne'
+
+theorem degree_eq_zero_of_tower
+    (htop : ∀ (h : F') (E : Divisor K F'), (∀ w : Place K F', E w = w.ord h) →
+      Divisor.degree E = 0)
+    (hex : ∀ h : F', h ≠ 0 → ∃ E : Divisor K F', ∀ w : Place K F', E w = w.ord h)
+    {f : F} {D : Divisor K F} (hD : ∀ v : Place K F, D v = v.ord f) :
+    Divisor.degree D = 0 := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · have : D = 0 := Finsupp.ext fun w => by simpa using hD w
+    rw [this, map_zero]
+  obtain ⟨E, hE⟩ := hex (algebraMap F F' f) (by simpa using hf)
+  have hcomp : Divisor.degree E = (Module.finrank F F' : ℤ) * Divisor.degree D :=
+    degree_eq_finrank_mul hE hD
+  rw [htop _ E hE] at hcomp
+  have hpos : (0 : ℤ) < (Module.finrank F F' : ℤ) := by
+    exact_mod_cast Module.finrank_pos (R := F) (M := F')
+  exact (mul_eq_zero.mp hcomp.symm).resolve_left hpos.ne'
+
+end General
+
+variable {K : Type*} [Field K] {F' : Type*} [Field F'] [Algebra K F']
+  [Algebra (RatFunc K) F'] [IsScalarTower K (RatFunc K) F']
+  [FiniteDimensional (RatFunc K) F'] [Algebra.IsSeparable (RatFunc K) F']
+
+def principalDivisorOf {f : F'} (hf : f ≠ 0) : AlgebraicCurve.Divisor K F' :=
+  ⟨(finite_setOf_ord_ne_zero_of_finiteDimensional hf).toFinset, fun w => w.ord f, fun w => by
+    simp [Set.Finite.mem_toFinset]⟩
+
+end HPDfdPort
+
+open HPDfdPort in
+theorem solution {K : Type*} [Field K] (E : Type*) [Field E] [Algebra K E]
+    [Algebra (RatFunc K) E] [IsScalarTower K (RatFunc K) E]
+    [FiniteDimensional (RatFunc K) E] [Algebra.IsSeparable (RatFunc K) E] :
+    HasPrincipalDivisors K E := by
+  obtain ⟨α, hα⟩ := Field.exists_primitive_element (RatFunc K) E
+  have hint : IsIntegral (RatFunc K) α := Algebra.IsIntegral.isIntegral α
+  have hsep : (minpoly (RatFunc K) α).Separable := Algebra.IsSeparable.isSeparable _ α
+  obtain ⟨g⟩ : Nonempty (E →ₐ[RatFunc K] (minpoly (RatFunc K) α).SplittingField) := by
+    refine IntermediateField.nonempty_algHom_of_adjoin_splits (fun s hs => ?_) hα
+    obtain rfl : s = α := by simpa using hs
+    exact ⟨hint, Polynomial.SplittingField.splits _⟩
+  let : Algebra E (minpoly (RatFunc K) α).SplittingField := g.toRingHom.toAlgebra
+  have : IsScalarTower (RatFunc K) E (minpoly (RatFunc K) α).SplittingField :=
+    IsScalarTower.of_algebraMap_eq fun x => (g.commutes x).symm
+  have : IsScalarTower K E (minpoly (RatFunc K) α).SplittingField :=
+    IsScalarTower.of_algebraMap_eq fun x => by
+      change algebraMap K (minpoly (RatFunc K) α).SplittingField x = g (algebraMap K E x)
+      rw [IsScalarTower.algebraMap_apply K (RatFunc K) E x, g.commutes,
+        ← IsScalarTower.algebraMap_apply K (RatFunc K)
+          (minpoly (RatFunc K) α).SplittingField x]
+  have : IsGalois (RatFunc K) (minpoly (RatFunc K) α).SplittingField :=
+    IsGalois.of_separable_splitting_field hsep
+  have : FiniteDimensional E (minpoly (RatFunc K) α).SplittingField :=
+    FiniteDimensional.right (RatFunc K) E _
+  have : Algebra.IsSeparable E (minpoly (RatFunc K) α).SplittingField :=
+    Algebra.isSeparable_tower_top_of_isSeparable (RatFunc K) E _
+  have : HasPrincipalDivisors K (RatFunc K) := RationalFunctionField.hasPrincipalDivisors K
+  refine ⟨fun f hf => ⟨principalDivisorOf hf, fun _ => rfl, ?_⟩⟩
+  refine degree_eq_zero_of_tower (K := K) (F := E)
+    (F' := (minpoly (RatFunc K) α).SplittingField)
+    (fun h E' hE' => degree_eq_zero_of_isGalois (K := K) (F := RatFunc K)
+      (F' := (minpoly (RatFunc K) α).SplittingField) hE')
+    (fun h hh => ⟨principalDivisorOf hh, fun _ => rfl⟩)
+    (fun _ => rfl)
+
+end
+end S_AlgebraicCurve_hasPrincipalDivisors_of_finiteDimensional_of_isSeparable
+end P2MW
+export P2MW.S_AlgebraicCurve_hasPrincipalDivisors_of_finiteDimensional_of_isSeparable (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.hasPrincipalDivisors_of_finiteDimensional_of_isSeparable
+    {K : Type*} [Field K] (E : Type*) [Field E] [Algebra K E]
+    [Algebra (RatFunc K) E] [IsScalarTower K (RatFunc K) E]
+    [FiniteDimensional (RatFunc K) E] [Algebra.IsSeparable (RatFunc K) E] :
+    HasPrincipalDivisors K E :=
+  solution E
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_hasPrincipalDivisors_of_finiteDimensional_ratFunc.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_hasPrincipalDivisors_of_finiteDimensional_ratFunc.lean
new file mode 100644
index 0000000000..f5196945a9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_hasPrincipalDivisors_of_finiteDimensional_ratFunc.lean
@@ -0,0 +1,821 @@
+/-
+Based on Prove2Me node AlgebraicCurve.hasPrincipalDivisors_of_finiteDimensional_ratFunc
+(3fde7f9d-303a-5407-a61d-b831a4913e3d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a7ed0be6-4151-5188-86ec-ec4e6ecfb279
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+public import Mathlib.FieldTheory.RatFunc.Basic
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_iff_ord_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_nonneg_of_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_of_ord_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_finite_setOf_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord
+import Mathlib.FieldTheory.Minpoly.Field
+import Mathlib.RingTheory.Ideal.Norm.RelNorm
+import Mathlib.FieldTheory.Perfect
+import Mathlib.Algebra.CharP.Algebra
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Principal divisors of degree zero on finite extensions of K(X)
+
+Theorem statement: `AlgebraicCurve.hasPrincipalDivisors_of_finiteDimensional_ratFunc`
+(`3fde7f9d-303a-5407-a61d-b831a4913e3d`), by Claude, 2026-09-05.
+
+Proof: submission `a7ed0be6-4151-5188-86ec-ec4e6ecfb279`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field of characteristic $0$ and let $F'$ be a field carrying a $K$-algebra structure
+and a $K(X)$-algebra structure (for $K(X) =$ `RatFunc K` the rational function field), compatible in
+the sense that $K \to K(X) \to F'$ is a scalar tower, and such that $F'$ is finite-dimensional over
+$K(X)$. The conclusion is `HasPrincipalDivisors K F'`: for every $f \in F'$ with $f \neq 0$ there is
+a divisor $D$, that is, a finitely supported function from the places of $F'$ over $K$ to
+$\mathbb{Z}$, such that $D(v) = v.\mathrm{ord}\,f$ for every place $v$ and such that
+$\mathrm{degree}\,D = \sum_v D(v)\cdot v.\mathrm{deg} = 0$. Here a place of $F'$ over $K$, in the
+project's sense, is a valuation subring $\mathcal{O}_v \subseteq F'$ containing
+$\mathrm{algebraMap}\,K\,F'(a)$ for every $a \in K$, distinct from all of $F'$, and a principal
+ideal ring; $v.\mathrm{ord}$ is the associated order function on $F'$ and $v.\mathrm{deg}$ the
+associated degree of $v$. Since $D$ is finitely supported, the first clause in particular asserts
+that $f$ has nonzero order at only finitely many places.
+
+This is the statement that on an algebraic curve every nonzero rational function has a well-defined
+divisor, of degree zero — classically the product formula $\sum_v \operatorname{ord}_v(f)\deg v = 0$
+for a function field of one variable, here asserted only for fields finite over $K(X)$ with $K$ of
+characteristic zero. It supplies the divisor-theoretic input to
+[`WeierstrassCurve.Affine.hasPrincipalDivisors_functionField`]
+(thm.html#WeierstrassCurve.Affine.hasPrincipalDivisors_functionField)
+and, through it, to the injectivity statement
+[`AlgebraicCurve.DivisorialWeilPairingData.toHom_injective_of_divisible`]
+(thm.html#AlgebraicCurve.DivisorialWeilPairingData.toHom_injective_of_divisible).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_hasPrincipalDivisors_of_finiteDimensional_ratFunc.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_hasPrincipalDivisors_of_finiteDimensional_ratFunc
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.finite_setOf_restrict_eq Place.mem_fiberOver \
+  Divisor.pushforward Divisor.degree_pushforward Divisor.pushforward_apply \
+  Divisor.PushforwardNormFormula Place Divisor Divisor.degree HasPrincipalDivisors \
+  RationalFunctionField.finite_setOf_ord_ne_zero \
+  RationalFunctionField.degree_eq_zero_of_forall_eq_ord"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ord_neg mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos \
+  center integralClosureAt forall_mem_of_restrict_eq fiberCenter mem_fiberCenter_iff_ord_pos \
+  toValuationSubring_eq_of_restrict_eq algebraMap_integralClosureAt_ne_zero \
+  ord_algebraMap_integralClosureAt fiberCenter_liesOver placeOfPrime restrict_placeOfPrime \
+  fiberCenter_placeOfPrime eq_of_fiberCenter_eq finite_setOf_restrict_eq fiberOver mem_fiberOver \
+  ramificationIndex ramificationIndex_pos restrict ord_restrict restrictInclusion \
+  restrictResidueMap inertiaDeg fiber ext ResidueField ord ord_mul ord_inv ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow toValuationSubring mk mem_iff_ord_nonneg ord_nonneg_of_mem \
+  mem_of_ord_nonneg"
+p2m_open "AlgebraicCurve.Place"
+
+section Uniqueness
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+private theorem eq_ord_of_addHom_of_nonneg_iff (φ : F → ℤ)
+    (hmul : ∀ x y, x ≠ 0 → y ≠ 0 → φ (x * y) = φ x + φ y)
+    (hone : ∃ t, t ≠ 0 ∧ φ t = 1)
+    (hiff : ∀ x, x ≠ 0 → (0 ≤ φ x ↔ x ∈ w.toValuationSubring))
+    {x : F} (hx : x ≠ 0) : φ x = w.ord x := by
+  obtain ⟨t, ht0, ht1⟩ := hone
+  have hφ1 : φ 1 = 0 := by
+    have := hmul 1 1 one_ne_zero one_ne_zero
+    rw [mul_one] at this
+    omega
+  have hinv : ∀ y, y ≠ 0 → φ y⁻¹ = -φ y := by
+    intro y hy
+    have h1 : φ (y * y⁻¹) = φ y + φ y⁻¹ := hmul y y⁻¹ hy (inv_ne_zero hy)
+    rw [mul_inv_cancel₀ hy, hφ1] at h1
+    omega
+  have hpow : ∀ (y : F), y ≠ 0 → ∀ m : ℕ, φ (y ^ m) = m * φ y := by
+    intro y hy m
+    induction m with
+    | zero => simpa using hφ1
+    | succ m ih =>
+      rw [pow_succ, hmul _ _ (pow_ne_zero _ hy) hy, ih]
+      push_cast
+      ring
+  have hzpow : ∀ (y : F) (n : ℤ), y ≠ 0 → φ (y ^ n) = n * φ y := by
+    intro y n hy
+    rcases n with m | m
+    · simpa using hpow y hy m
+    · rw [zpow_negSucc, hinv _ (pow_ne_zero _ hy), hpow y hy, Int.negSucc_eq]
+      push_cast
+      ring
+  have hsign : ∀ y, y ≠ 0 → (0 ≤ φ y ↔ 0 ≤ w.ord y) := by
+    intro y hy
+    rw [hiff y hy, w.mem_iff_ord_nonneg hy]
+  have hzero : ∀ y, y ≠ 0 → (φ y = 0 ↔ w.ord y = 0) := by
+    intro y hy
+    have h1 := hsign y hy
+    have h2 := hsign y⁻¹ (inv_ne_zero hy)
+    rw [hinv y hy, w.ord_inv] at h2
+    omega
+  have htord : 0 < w.ord t := by
+    have h1 := (hsign t ht0).mp (by omega)
+    have h2 := (hzero t ht0).not.mp (by omega)
+    omega
+  have hcancel : ∀ y, y ≠ 0 → w.ord y = φ y * w.ord t := by
+    intro y hy
+    have hyt : y * t ^ (-(φ y)) ≠ 0 := mul_ne_zero hy (zpow_ne_zero _ ht0)
+    have h1 : φ (y * t ^ (-(φ y))) = 0 := by
+      rw [hmul _ _ hy (zpow_ne_zero _ ht0), hzpow t _ ht0, ht1]
+      ring
+    have h2 : w.ord (y * t ^ (-(φ y))) = 0 := (hzero _ hyt).mp h1
+    rw [w.ord_mul hy (zpow_ne_zero _ ht0), w.ord_zpow] at h2
+    linarith
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  have hπ0 : (π : F) ≠ 0 := by
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have hπcancel := hcancel (π : F) hπ0
+  rw [w.ord_coe_irreducible hπ] at hπcancel
+  have htord1 : w.ord t = 1 := by
+    have hdvd : w.ord t ∣ 1 := ⟨φ (π : F), by linarith⟩
+    have := Int.le_of_dvd one_pos hdvd
+    omega
+  have := hcancel x hx
+  rw [htord1, mul_one] at this
+  exact this.symm
+
+end Uniqueness
+
+section Dict
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+section ValuationDictionary
+
+variable {v : Place K F} {w : Place K F'}
+
+private theorem neg_log_valuation_fiberCenter_eq_ord (hw : w.restrict F = v) {x : F'} (hx : x ≠ 0) :
+    -log ((fiberCenter F' v hw).valuation F' x) = w.ord x := by
+  refine eq_ord_of_addHom_of_nonneg_iff w
+    (fun y => -log ((fiberCenter F' v hw).valuation F' y)) ?_ ?_ ?_ hx
+  · intro a b ha hb
+    show -log ((fiberCenter F' v hw).valuation F' (a * b)) =
+      -log ((fiberCenter F' v hw).valuation F' a) +
+        -log ((fiberCenter F' v hw).valuation F' b)
+    rw [map_mul, log_mul ((Valuation.ne_zero_iff _).mpr ha) ((Valuation.ne_zero_iff _).mpr hb)]
+    ring
+  · obtain ⟨t, ht⟩ := (fiberCenter F' v hw).valuation_exists_uniformizer F'
+    refine ⟨t, ?_, ?_⟩
+    · intro h
+      rw [h, map_zero] at ht
+      exact exp_ne_zero ht.symm
+    · show -log ((fiberCenter F' v hw).valuation F' t) = 1
+      rw [ht, log_exp]
+      ring
+  · intro y hy
+    have hy0 : (fiberCenter F' v hw).valuation F' y ≠ 0 := (Valuation.ne_zero_iff _).mpr hy
+    change 0 ≤ -log ((fiberCenter F' v hw).valuation F' y) ↔ y ∈ w.toValuationSubring
+    have hmem : y ∈ w.toValuationSubring ↔ (fiberCenter F' v hw).valuation F' y ≤ 1 := by
+      rw [toValuationSubring_eq_of_restrict_eq hw,
+        HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact Iff.rfl
+    rw [hmem]
+    constructor
+    · intro h
+      calc (fiberCenter F' v hw).valuation F' y
+          = exp (log ((fiberCenter F' v hw).valuation F' y)) := (exp_log hy0).symm
+        _ ≤ exp 0 := by rw [exp_le_exp]; omega
+        _ = 1 := exp_zero
+    · intro h
+      have h1 : exp (log ((fiberCenter F' v hw).valuation F' y)) ≤ exp 0 := by
+        rw [exp_log hy0, exp_zero]
+        exact h
+      rw [exp_le_exp] at h1
+      omega
+
+private theorem le_ord_iff_mem_pow_fiberCenter (hw : w.restrict F = v)
+    {c : integralClosureAt F' v} (hc : c ≠ 0) (n : ℕ) :
+    (n : ℤ) ≤ w.ord (algebraMap (integralClosureAt F' v) F' c) ↔
+      c ∈ (fiberCenter F' v hw).asIdeal ^ n := by
+  have hcF : algebraMap (integralClosureAt F' v) F' c ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hc
+  rw [← neg_log_valuation_fiberCenter_eq_ord hw hcF,
+    HeightOneSpectrum.valuation_of_algebraMap,
+    ← HeightOneSpectrum.intValuation_le_pow_iff_mem]
+  have h0 : (fiberCenter F' v hw).intValuation c ≠ 0 :=
+    HeightOneSpectrum.intValuation_ne_zero _ c hc
+  constructor
+  · intro h
+    calc (fiberCenter F' v hw).intValuation c
+        = exp (log ((fiberCenter F' v hw).intValuation c)) := (exp_log h0).symm
+      _ ≤ exp (-(n : ℤ)) := by rw [exp_le_exp]; omega
+  · intro h
+    have h1 : exp (log ((fiberCenter F' v hw).intValuation c)) ≤ exp (-(n : ℤ)) := by
+      rw [exp_log h0]
+      exact h
+    rw [exp_le_exp] at h1
+    omega
+
+private theorem ramificationIndex_eq_ramificationIdx_fiberCenter (hw : w.restrict F = v) :
+    w.ramificationIndex F =
+      (IsLocalRing.maximalIdeal v.toValuationSubring).ramificationIdx'
+        (fiberCenter F' v hw).asIdeal := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπ0 : π ≠ 0 := hπ.ne_zero
+  have hπC : algebraMap v.toValuationSubring (integralClosureAt F' v) π ≠ 0 :=
+    algebraMap_integralClosureAt_ne_zero hπ0
+  have hmap : (IsLocalRing.maximalIdeal v.toValuationSubring).map
+      (algebraMap v.toValuationSubring (integralClosureAt F' v))
+        = Ideal.span {algebraMap v.toValuationSubring (integralClosureAt F' v) π} := by
+    rw [hπ.maximalIdeal_eq, Ideal.map_span, Set.image_singleton]
+  have hord : w.ord (algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) π))
+        = w.ramificationIndex F := by
+    rw [ord_algebraMap_integralClosureAt hw, ValuationSubring.algebraMap_apply,
+      v.ord_coe_irreducible hπ, mul_one]
+  refine (Ideal.ramificationIdx'_spec ?_ ?_).symm
+  · rw [hmap, Ideal.span_singleton_le_iff_mem,
+      ← le_ord_iff_mem_pow_fiberCenter hw hπC, hord]
+  · rw [hmap, Ideal.span_singleton_le_iff_mem,
+      ← le_ord_iff_mem_pow_fiberCenter hw hπC, hord]
+    have : 0 < w.ramificationIndex F := w.ramificationIndex_pos
+    push_cast
+    omega
+
+end ValuationDictionary
+
+section ResidueDictionary
+
+variable {v : Place K F} {w : Place K F'}
+
+private def toValuationSubringOfRestrictEq (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.toValuationSubring :=
+  (algebraMap (integralClosureAt F' v) F').codRestrict
+    w.toValuationSubring.toSubring (forall_mem_of_restrict_eq hw)
+
+omit [FiniteDimensional F F'] in
+@[scoped simp]
+private theorem coe_toValuationSubringOfRestrictEq (hw : w.restrict F = v)
+    (c : integralClosureAt F' v) :
+    (toValuationSubringOfRestrictEq hw c : F')
+      = algebraMap (integralClosureAt F' v) F' c := rfl
+
+private def residueOfCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.ResidueField :=
+  (IsLocalRing.residue w.toValuationSubring).comp (toValuationSubringOfRestrictEq hw)
+
+omit [FiniteDimensional F F'] in
+private theorem residueOfCenter_apply (hw : w.restrict F = v) (c : integralClosureAt F' v) :
+    residueOfCenter hw c = IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw c) := rfl
+
+private theorem ker_residueOfCenter (hw : w.restrict F = v) :
+    RingHom.ker (residueOfCenter hw) = (fiberCenter F' v hw).asIdeal := by
+  ext c
+  rw [RingHom.mem_ker, residueOfCenter_apply, IsLocalRing.residue_eq_zero_iff]
+  exact Iff.rfl
+
+private theorem surjective_residueOfCenter (hw : w.restrict F = v) :
+    Function.Surjective (residueOfCenter hw) := by
+  classical
+  intro y
+  obtain ⟨x, rfl⟩ := IsLocalRing.residue_surjective y
+  have hx : (x : F') ∈ HeightOneSpectrum.valuationSubringAtPrime F' (fiberCenter F' v hw) := by
+    rw [← toValuationSubring_eq_of_restrict_eq hw]
+    exact x.2
+  obtain ⟨a, s, hs, hxas⟩ := hx
+  have hsP : s ∉ (fiberCenter F' v hw).asIdeal := hs
+  have hs0 : s ≠ 0 := fun h => hsP (h ▸ (fiberCenter F' v hw).asIdeal.zero_mem)
+  have hsF : algebraMap (integralClosureAt F' v) F' s ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hs0
+  have hsord : w.ord (algebraMap (integralClosureAt F' v) F' s) = 0 := by
+    have h1 : ¬ 0 < w.ord (algebraMap (integralClosureAt F' v) F' s) := by
+      rw [← mem_fiberCenter_iff_ord_pos hw hs0]
+      exact hsP
+    have h2 : 0 ≤ w.ord (algebraMap (integralClosureAt F' v) F' s) :=
+      w.ord_nonneg_of_mem (forall_mem_of_restrict_eq hw s)
+    omega
+  have hmax : (fiberCenter F' v hw).asIdeal.IsMaximal :=
+    (fiberCenter F' v hw).isPrime.isMaximal (fiberCenter F' v hw).ne_bot
+  obtain ⟨t, i, hi, hti⟩ := hmax.exists_inv hsP
+  have hst : s * t - 1 ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : s * t - 1 = -i := by linear_combination hti
+    rw [h1]
+    exact neg_mem hi
+  refine ⟨a * t, ?_⟩
+  rw [residueOfCenter_apply, ← sub_eq_zero, ← map_sub, IsLocalRing.residue_eq_zero_iff]
+  have hcoe : ((toValuationSubringOfRestrictEq hw (a * t) - x : w.toValuationSubring) : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') := rfl
+  rcases eq_or_ne (toValuationSubringOfRestrictEq hw (a * t) - x) 0 with hzero | hne
+  · rw [hzero]
+    exact (IsLocalRing.maximalIdeal w.toValuationSubring).zero_mem
+  have hcoene : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') ≠ 0 := by
+    intro h
+    exact hne (by rwa [← hcoe, ZeroMemClass.coe_eq_zero] at h)
+  have hfactor : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t * s - a)
+          * (algebraMap (integralClosureAt F' v) F' s)⁻¹ := by
+    rw [hxas, map_sub, map_mul (algebraMap (integralClosureAt F' v) F') (a * t) s,
+      sub_mul, mul_assoc, mul_inv_cancel₀ hsF, mul_one]
+  have hdiffC : a * t * s - a ≠ 0 := by
+    intro h
+    apply hcoene
+    rw [hfactor, h, map_zero, zero_mul]
+  have hdiffP : a * t * s - a ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : a * t * s - a = a * (s * t - 1) := by ring
+    rw [h1]
+    exact Ideal.mul_mem_left _ _ hst
+  have hmem' : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      ∈ w.toValuationSubring := by
+    rw [← hcoe]
+    exact Subtype.coe_prop _
+  rw [show (toValuationSubringOfRestrictEq hw (a * t) - x)
+      = (⟨_, hmem'⟩ : w.toValuationSubring) from Subtype.ext hcoe,
+    w.mem_maximalIdeal_iff_ord_pos hcoene hmem']
+  rw [hfactor, w.ord_mul (by
+      simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hdiffC)
+    (inv_ne_zero hsF), w.ord_inv, hsord, neg_zero, add_zero]
+  exact (mem_fiberCenter_iff_ord_pos hw hdiffC).mp hdiffP
+
+private def residueFieldEquivQuotientCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v ⧸ (fiberCenter F' v hw).asIdeal ≃+* w.ResidueField :=
+  (Ideal.quotEquivOfEq (ker_residueOfCenter hw).symm).trans
+    ((residueOfCenter hw).quotientKerEquivOfSurjective (surjective_residueOfCenter hw))
+
+private theorem residueFieldEquivQuotientCenter_mk (hw : w.restrict F = v)
+    (c : integralClosureAt F' v) :
+    residueFieldEquivQuotientCenter hw (Ideal.Quotient.mk _ c) = residueOfCenter hw c := by
+  change ((residueOfCenter hw).quotientKerEquivOfSurjective (surjective_residueOfCenter hw))
+    ((Ideal.quotEquivOfEq (ker_residueOfCenter hw).symm) (Ideal.Quotient.mk _ c))
+      = residueOfCenter hw c
+  rw [Ideal.quotEquivOfEq_mk]
+  exact RingHom.quotientKerEquivOfSurjective_apply_mk _ c
+
+private def placeCongrEquiv {u u' : Place K F} (h : u = u') :
+    u.toValuationSubring ≃+* u'.toValuationSubring where
+  toFun x := ⟨x.1, h ▸ x.2⟩
+  invFun x := ⟨x.1, h.symm ▸ x.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  map_mul' _ _ := rfl
+  map_add' _ _ := rfl
+
+@[scoped simp]
+private theorem coe_placeCongrEquiv {u u' : Place K F} (h : u = u') (x : u.toValuationSubring) :
+    (placeCongrEquiv h x : F) = (x : F) := rfl
+
+private def restrictResidueFieldEquiv (hw : w.restrict F = v) :
+    (w.restrict F).ResidueField ≃+* IsLocalRing.ResidueField v.toValuationSubring :=
+  IsLocalRing.ResidueField.mapEquiv (placeCongrEquiv hw)
+
+omit [FiniteDimensional F F'] in
+private theorem restrictResidueFieldEquiv_residue (hw : w.restrict F = v)
+    (a : (w.restrict F).toValuationSubring) :
+    restrictResidueFieldEquiv hw (IsLocalRing.residue _ a)
+      = IsLocalRing.residue _ (placeCongrEquiv hw a) := by
+  simp only [restrictResidueFieldEquiv, IsLocalRing.ResidueField.mapEquiv_apply,
+    IsLocalRing.ResidueField.map_residue, RingEquiv.coe_toRingHom]
+
+private theorem inertiaDeg_eq_inertiaDeg_fiberCenter (hw : w.restrict F = v) :
+    w.inertiaDeg F =
+      (fiberCenter F' v hw).asIdeal.inertiaDeg v.toValuationSubring := by
+  have := fiberCenter_liesOver hw
+  rw [Ideal.inertiaDeg_eq_of_isMaximal (IsLocalRing.maximalIdeal v.toValuationSubring)
+    (fiberCenter F' v hw).asIdeal]
+  change Module.finrank (w.restrict F).ResidueField w.ResidueField = _
+  refine Algebra.finrank_eq_of_equiv_equiv (restrictResidueFieldEquiv hw)
+    (residueFieldEquivQuotientCenter hw).symm ?_
+  ext a
+  obtain ⟨a, rfl⟩ := IsLocalRing.residue_surjective a
+  simp only [RingHom.coe_comp, Function.comp_apply, RingEquiv.toRingHom_eq_coe,
+    RingHom.coe_coe]
+  apply (residueFieldEquivQuotientCenter hw).injective
+  rw [RingEquiv.apply_symm_apply]
+  change IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw
+        (algebraMap v.toValuationSubring (integralClosureAt F' v) (placeCongrEquiv hw a)))
+    = IsLocalRing.residue w.toValuationSubring (restrictInclusion F w a)
+  refine congrArg _ (Subtype.ext ?_)
+  change algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) (placeCongrEquiv hw a))
+    = algebraMap F F' (a : F)
+  rw [← IsScalarTower.algebraMap_apply,
+    IsScalarTower.algebraMap_apply v.toValuationSubring F F']
+  rfl
+
+end ResidueDictionary
+
+end Dict
+
+section SupportTransfer
+
+open Polynomial
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F'] [Algebra F F']
+  [FiniteDimensional F F']
+
+variable (w : Place K F')
+
+omit [FiniteDimensional F F'] in
+private theorem _root_.AlgebraicCurve.Place.aeval_mem {Q : Polynomial F} {x : F'}
+    (hcoeff : ∀ i, algebraMap F F' (Q.coeff i) ∈ w.toValuationSubring)
+    (hx : x ∈ w.toValuationSubring) :
+    Polynomial.aeval x Q ∈ w.toValuationSubring := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range]
+  exact sum_mem fun i _ => mul_mem (hcoeff i) (pow_mem hx i)
+
+p2m_export "AlgebraicCurve.Place" "aeval_mem"
+
+private theorem _root_.AlgebraicCurve.Place.exists_coeff_ord_ne_zero {f : F'} (hf : f ≠ 0)
+    (hford : w.ord f ≠ 0) :
+    ∃ i < (minpoly F f).natDegree, (minpoly F f).coeff i ≠ 0 ∧
+      w.ord (algebraMap F F' ((minpoly F f).coeff i)) ≠ 0 := by
+  by_contra hcon
+  push Not at hcon
+  set P := minpoly F f with hPdef
+  have hint : IsIntegral F f := Algebra.IsIntegral.isIntegral f
+  have hmonic : P.Monic := minpoly.monic hint
+  have hdeg : 0 < P.natDegree := minpoly.natDegree_pos hint
+  have hc0 : P.coeff 0 ≠ 0 := minpoly.coeff_zero_ne_zero hint hf
+  have hcoeff : ∀ i, algebraMap F F' (P.coeff i) ∈ w.toValuationSubring := by
+    intro i
+    rcases lt_trichotomy i P.natDegree with hi | hi | hi
+    · rcases eq_or_ne (P.coeff i) 0 with h0 | h0
+      · simp [h0]
+      · exact w.mem_of_ord_nonneg (by simpa using h0) (by have := hcon i hi h0; omega)
+    · subst hi
+      simp [hmonic.coeff_natDegree]
+    · simp [Polynomial.coeff_eq_zero_of_natDegree_lt hi]
+  have hfmem : f ∈ w.toValuationSubring := by
+    refine w.mem_of_eval_monic_eq_zero (P := P.map (algebraMap F F')) (hmonic.map _)
+      (fun i => by simpa using hcoeff i) ?_
+    rw [Polynomial.eval_map, ← Polynomial.aeval_def, hPdef, minpoly.aeval]
+  have hfpos : 0 < w.ord f := lt_of_le_of_ne (w.ord_nonneg_of_mem hfmem) (Ne.symm hford)
+  have hkey : algebraMap F F' (P.coeff 0) = -(f * Polynomial.aeval f P.divX) := by
+    have hsplit : Polynomial.aeval f (Polynomial.X * P.divX + Polynomial.C (P.coeff 0))
+        = (0 : F') := by rw [P.X_mul_divX_add]; exact minpoly.aeval F f
+    rw [map_add, map_mul, Polynomial.aeval_X, Polynomial.aeval_C] at hsplit
+    linear_combination hsplit
+  have hcof_mem : Polynomial.aeval f P.divX ∈ w.toValuationSubring :=
+    w.aeval_mem (fun i => by rw [Polynomial.coeff_divX]; exact hcoeff (i + 1)) hfmem
+  have hcof_ne : Polynomial.aeval f P.divX ≠ 0 := by
+    intro h
+    rw [h, mul_zero, neg_zero] at hkey
+    exact hc0 (by simpa using hkey)
+  have hpos0 : 0 < w.ord (algebraMap F F' (P.coeff 0)) := by
+    rw [hkey, w.ord_neg, w.ord_mul hf hcof_ne]
+    have := w.ord_nonneg_of_mem hcof_mem
+    omega
+  have := hcon 0 hdeg hc0
+  omega
+
+p2m_export "AlgebraicCurve.Place" "exists_coeff_ord_ne_zero"
+end SupportTransfer
+
+end Place
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing UniqueFactorizationMonoid
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.finite_setOf_restrict_eq Place.mem_fiberOver \
+  Divisor.pushforward Divisor.degree_pushforward Divisor.pushforward_apply \
+  Divisor.PushforwardNormFormula Place Divisor Divisor.degree HasPrincipalDivisors \
+  RationalFunctionField.finite_setOf_ord_ne_zero \
+  RationalFunctionField.degree_eq_zero_of_forall_eq_ord"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ord_neg mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos \
+  center integralClosureAt forall_mem_of_restrict_eq fiberCenter mem_fiberCenter_iff_ord_pos \
+  toValuationSubring_eq_of_restrict_eq algebraMap_integralClosureAt_ne_zero \
+  ord_algebraMap_integralClosureAt fiberCenter_liesOver placeOfPrime restrict_placeOfPrime \
+  fiberCenter_placeOfPrime eq_of_fiberCenter_eq finite_setOf_restrict_eq fiberOver mem_fiberOver \
+  ramificationIndex ramificationIndex_pos restrict ord_restrict restrictInclusion \
+  restrictResidueMap inertiaDeg fiber ext ResidueField ord ord_mul ord_inv ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow toValuationSubring mk mem_iff_ord_nonneg ord_nonneg_of_mem \
+  mem_of_ord_nonneg"
+p2m_open "AlgebraicCurve.Place"
+
+section DVR
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem ord_coe_eq_of_span_singleton_eq_pow_maximalIdeal {r : v.toValuationSubring} {n : ℕ}
+    (h : Ideal.span {r} = IsLocalRing.maximalIdeal v.toValuationSubring ^ n) :
+    v.ord (r : F) = n := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  rw [hπ.maximalIdeal_eq, Ideal.span_singleton_pow, Ideal.span_singleton_eq_span_singleton] at h
+  obtain ⟨u, hu⟩ := h
+  have hr : r = ((u⁻¹ : v.toValuationSubringˣ) : v.toValuationSubring) * π ^ n := by
+    rw [mul_comm, Units.eq_mul_inv_iff_mul_eq]
+    exact hu
+  have hcoe : (r : F) = (((u⁻¹ : v.toValuationSubringˣ) : v.toValuationSubring) : F)
+      * (π : F) ^ (n : ℤ) := by
+    rw [hr]
+    push_cast
+    rw [zpow_natCast]
+  rw [hcoe, v.ord_unit_smul_zpow u⁻¹ hπ (n : ℤ)]
+
+end DVR
+end Place
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F'] [CharZero F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ord_neg mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos \
+  center integralClosureAt forall_mem_of_restrict_eq fiberCenter mem_fiberCenter_iff_ord_pos \
+  toValuationSubring_eq_of_restrict_eq algebraMap_integralClosureAt_ne_zero \
+  ord_algebraMap_integralClosureAt fiberCenter_liesOver placeOfPrime restrict_placeOfPrime \
+  fiberCenter_placeOfPrime eq_of_fiberCenter_eq finite_setOf_restrict_eq fiberOver mem_fiberOver \
+  ramificationIndex ramificationIndex_pos restrict ord_restrict restrictInclusion \
+  restrictResidueMap inertiaDeg fiber ext ResidueField ord ord_mul ord_inv ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow toValuationSubring mk mem_iff_ord_nonneg ord_nonneg_of_mem \
+  mem_of_ord_nonneg"
+p2m_open "AlgebraicCurve.Place"
+
+private scoped instance (v : Place K F) : CharZero v.toValuationSubring :=
+  ⟨fun a b hab => Nat.cast_injective (R := F)
+    (by simpa using congrArg (Subtype.val : v.toValuationSubring → F) hab)⟩
+
+section IdealNorm
+
+variable {v : Place K F} {w : Place K F'}
+
+private theorem relNorm_fiberCenter (hw : w.restrict F = v) :
+    Ideal.relNorm v.toValuationSubring (fiberCenter F' v hw).asIdeal
+      = IsLocalRing.maximalIdeal v.toValuationSubring ^ w.inertiaDeg F := by
+  have : (fiberCenter F' v hw).asIdeal.IsMaximal :=
+    (fiberCenter F' v hw).isPrime.isMaximal (fiberCenter F' v hw).ne_bot
+  have : (fiberCenter F' v hw).asIdeal.LiesOver
+      (IsLocalRing.maximalIdeal v.toValuationSubring) := fiberCenter_liesOver hw
+  rw [Ideal.relNorm_eq_pow_of_isMaximal (fiberCenter F' v hw).asIdeal
+    (IsLocalRing.maximalIdeal v.toValuationSubring), inertiaDeg_eq_inertiaDeg_fiberCenter hw]
+
+omit [CharZero F] in
+private theorem count_normalizedFactors_span_singleton
+    (hw : w.restrict F = v) {c : integralClosureAt F' v} (hc : c ≠ 0) :
+    (normalizedFactors (Ideal.span {c})).count (fiberCenter F' v hw).asIdeal
+      = (w.ord (algebraMap (integralClosureAt F' v) F' c)).toNat := by
+  have : (fiberCenter F' v hw).asIdeal.IsPrime := (fiberCenter F' v hw).isPrime
+  have hord0 : 0 ≤ w.ord (algebraMap (integralClosureAt F' v) F' c) :=
+    w.ord_nonneg_of_mem (forall_mem_of_restrict_eq hw c)
+  refine Ideal.count_normalizedFactors_eq (p := (fiberCenter F' v hw).asIdeal)
+    (x := Ideal.span {c})
+    (n := (w.ord (algebraMap (integralClosureAt F' v) F' c)).toNat) ?_ ?_
+  · rw [Ideal.span_singleton_le_iff_mem, ← le_ord_iff_mem_pow_fiberCenter hw hc]
+    omega
+  · rw [Ideal.span_singleton_le_iff_mem, ← le_ord_iff_mem_pow_fiberCenter hw hc]
+    push_cast
+    omega
+
+private theorem relNorm_span_singleton {c : integralClosureAt F' v}
+    (hc : c ≠ 0) :
+    Ideal.relNorm v.toValuationSubring (Ideal.span {c})
+      = IsLocalRing.maximalIdeal v.toValuationSubring
+          ^ (∑ w ∈ v.fiberOver F',
+              w.inertiaDeg F * (w.ord (algebraMap (integralClosureAt F' v) F' c)).toNat) := by
+  have hspan : (Ideal.span {c} : Ideal (integralClosureAt F' v)) ≠ ⊥ := by simpa using hc
+  set S : Multiset (Ideal (integralClosureAt F' v)) := normalizedFactors (Ideal.span {c})
+    with hS
+  have hfactor : ∀ Q ∈ S.toFinset, ∃ w' : Place K F', ∃ hw' : w'.restrict F = v,
+      (fiberCenter F' v hw').asIdeal = Q := by
+    intro Q hQ
+    rw [Multiset.mem_toFinset] at hQ
+    have hQprime : Prime Q := prime_of_normalized_factor Q hQ
+    have hQbot : Q ≠ ⊥ := hQprime.ne_zero
+    have : Q.IsPrime := Ideal.isPrime_of_prime hQprime
+    exact ⟨placeOfPrime ⟨Q, inferInstance, hQbot⟩, restrict_placeOfPrime _,
+      congrArg HeightOneSpectrum.asIdeal (fiberCenter_placeOfPrime
+        (⟨Q, inferInstance, hQbot⟩ : HeightOneSpectrum (integralClosureAt F' v)))⟩
+  set T : Finset (Ideal (integralClosureAt F' v)) := (v.fiberOver F').attach.image
+    (fun w' => (fiberCenter F' v ((mem_fiberOver v).mp w'.2)).asIdeal) with hT
+  have hsub : S.toFinset ⊆ T := by
+    intro Q hQ
+    obtain ⟨w', hw', rfl⟩ := hfactor Q hQ
+    exact Finset.mem_image.mpr ⟨⟨w', (mem_fiberOver v).mpr hw'⟩, Finset.mem_attach _ _, rfl⟩
+  have hinj : Set.InjOn (fun w' : {x // x ∈ v.fiberOver F'} =>
+      (fiberCenter F' v ((mem_fiberOver v).mp w'.2)).asIdeal) (v.fiberOver F').attach := by
+    intro w₁ _ w₂ _ h
+    exact Subtype.ext (eq_of_fiberCenter_eq ((mem_fiberOver v).mp w₁.2) ((mem_fiberOver v).mp w₂.2)
+      (HeightOneSpectrum.ext h))
+  calc
+    Ideal.relNorm v.toValuationSubring (Ideal.span {c})
+        = Ideal.relNorm v.toValuationSubring (∏ Q ∈ S.toFinset, Q ^ S.count Q) := by
+          rw [← Finset.prod_multiset_count, hS, Ideal.prod_normalizedFactors_eq_self hspan]
+    _ = ∏ Q ∈ S.toFinset, Ideal.relNorm v.toValuationSubring Q ^ S.count Q := by
+          rw [map_prod]
+          exact Finset.prod_congr rfl fun Q _ => map_pow _ Q _
+    _ = ∏ Q ∈ S.toFinset, IsLocalRing.maximalIdeal v.toValuationSubring
+          ^ (Q.inertiaDeg v.toValuationSubring * S.count Q) := by
+          refine Finset.prod_congr rfl fun Q hQ => ?_
+          obtain ⟨w', hw', rfl⟩ := hfactor Q hQ
+          rw [relNorm_fiberCenter hw', ← pow_mul, inertiaDeg_eq_inertiaDeg_fiberCenter hw']
+    _ = IsLocalRing.maximalIdeal v.toValuationSubring
+          ^ (∑ Q ∈ S.toFinset,
+              Q.inertiaDeg v.toValuationSubring * S.count Q) :=
+          Finset.prod_pow_eq_pow_sum S.toFinset
+            (fun Q => Q.inertiaDeg v.toValuationSubring * S.count Q)
+            (IsLocalRing.maximalIdeal v.toValuationSubring)
+    _ = IsLocalRing.maximalIdeal v.toValuationSubring
+          ^ (∑ w ∈ v.fiberOver F',
+              w.inertiaDeg F * (w.ord (algebraMap (integralClosureAt F' v) F' c)).toNat) := by
+          congr 1
+          calc
+            ∑ Q ∈ S.toFinset,
+                Q.inertiaDeg v.toValuationSubring * S.count Q
+                = ∑ Q ∈ T,
+                    Q.inertiaDeg v.toValuationSubring * S.count Q := by
+                  refine Finset.sum_subset hsub fun Q _ hQ => ?_
+                  rw [Multiset.count_eq_zero_of_notMem
+                    (fun h => hQ (Multiset.mem_toFinset.mpr h)), mul_zero]
+            _ = ∑ w' ∈ (v.fiberOver F').attach,
+                  (fiberCenter F' v ((mem_fiberOver v).mp w'.2)).asIdeal.inertiaDeg
+                      v.toValuationSubring
+                    * S.count (fiberCenter F' v ((mem_fiberOver v).mp w'.2)).asIdeal := by
+                  rw [hT, Finset.sum_image hinj]
+            _ = ∑ w' ∈ (v.fiberOver F').attach, (w'.1.inertiaDeg F
+                  * (w'.1.ord (algebraMap (integralClosureAt F' v) F' c)).toNat) := by
+                  refine Finset.sum_congr rfl fun w' _ => ?_
+                  rw [← inertiaDeg_eq_inertiaDeg_fiberCenter ((mem_fiberOver v).mp w'.2),
+                    count_normalizedFactors_span_singleton ((mem_fiberOver v).mp w'.2) hc]
+            _ = ∑ w ∈ v.fiberOver F',
+                  w.inertiaDeg F
+                    * (w.ord (algebraMap (integralClosureAt F' v) F' c)).toNat :=
+                  Finset.sum_attach (v.fiberOver F') fun w =>
+                    w.inertiaDeg F * (w.ord (algebraMap (integralClosureAt F' v) F' c)).toNat
+
+end IdealNorm
+
+section ElementNorm
+
+variable (v : Place K F)
+
+private theorem ord_norm_algebraMap_integralClosureAt
+    {c : integralClosureAt F' v} (hc : c ≠ 0) :
+    v.ord (Algebra.norm F (algebraMap (integralClosureAt F' v) F' c))
+      = ∑ w ∈ v.fiberOver F', (w.inertiaDeg F : ℤ)
+          * w.ord (algebraMap (integralClosureAt F' v) F' c) := by
+  rw [← Algebra.algebraMap_intNorm (A := v.toValuationSubring) (K := F) (L := F')
+    (B := integralClosureAt F' v)]
+  have hrel := relNorm_span_singleton (v := v) hc
+  rw [Ideal.relNorm_singleton] at hrel
+  rw [ValuationSubring.algebraMap_apply, ord_coe_eq_of_span_singleton_eq_pow_maximalIdeal v hrel]
+  push_cast
+  refine Finset.sum_congr rfl fun w hw => ?_
+  rw [Int.toNat_of_nonneg
+    (w.ord_nonneg_of_mem (forall_mem_of_restrict_eq ((mem_fiberOver v).mp hw) c))]
+
+private theorem ord_norm_eq_sum_fiberOver {f : F'} (hf : f ≠ 0) :
+    v.ord (Algebra.norm F f) = ∑ w ∈ v.fiberOver F', (w.inertiaDeg F : ℤ) * w.ord f := by
+  obtain ⟨⟨c, s⟩, hcs⟩ := IsLocalization.surj
+    (nonZeroDivisors (integralClosureAt F' v)) f
+  have hs0 : (s : integralClosureAt F' v) ≠ 0 := nonZeroDivisors.coe_ne_zero s
+  have hsF : algebraMap (integralClosureAt F' v) F' (s : integralClosureAt F' v) ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective (integralClosureAt F' v) F')).mpr hs0
+  have hcF : algebraMap (integralClosureAt F' v) F' c ≠ 0 := by
+    rw [← hcs]
+    exact mul_ne_zero hf hsF
+  have hc0 : c ≠ 0 := fun h => hcF (by rw [h, map_zero])
+  have hintc := ord_norm_algebraMap_integralClosureAt v hc0
+  have hints := ord_norm_algebraMap_integralClosureAt v hs0
+  rw [← hcs, map_mul, v.ord_mul (Algebra.norm_ne_zero_iff.mpr hf)
+    (Algebra.norm_ne_zero_iff.mpr hsF), hints] at hintc
+  have hsplit : ∑ w ∈ v.fiberOver F', (w.inertiaDeg F : ℤ)
+      * w.ord (f * algebraMap (integralClosureAt F' v) F' (s : integralClosureAt F' v))
+        = (∑ w ∈ v.fiberOver F', (w.inertiaDeg F : ℤ) * w.ord f)
+          + ∑ w ∈ v.fiberOver F', (w.inertiaDeg F : ℤ)
+              * w.ord (algebraMap (integralClosureAt F' v) F' (s : integralClosureAt F' v)) := by
+    rw [← Finset.sum_add_distrib]
+    refine Finset.sum_congr rfl fun w _ => ?_
+    rw [w.ord_mul hf hsF]
+    ring
+  rw [hsplit] at hintc
+  omega
+
+end ElementNorm
+end Place
+
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "pushforward degree_pushforward pushforward_apply \
+  PushforwardNormFormula degree principal"
+p2m_open "AlgebraicCurve.Divisor"
+
+private theorem pushforwardNormFormula_of_finiteDimensional :
+    Divisor.PushforwardNormFormula K F F' := by
+  intro f hf D hD v
+  classical
+  rw [Divisor.pushforward_apply, Place.ord_norm_eq_sum_fiberOver v hf]
+  calc
+    ∑ w ∈ D.support, (if w.restrict F = v then D w * (w.inertiaDeg F : ℤ) else 0)
+        = ∑ w ∈ D.support ∪ v.fiberOver F',
+            (if w.restrict F = v then D w * (w.inertiaDeg F : ℤ) else 0) := by
+          refine Finset.sum_subset Finset.subset_union_left fun w _ hw => ?_
+          rw [Finsupp.notMem_support_iff.mp hw, zero_mul, ite_self]
+    _ = ∑ w ∈ v.fiberOver F', (if w.restrict F = v then D w * (w.inertiaDeg F : ℤ) else 0) := by
+          refine (Finset.sum_subset Finset.subset_union_right fun w _ hw => ?_).symm
+          rw [ite_eq_right fun h => hw ((Place.mem_fiberOver v).mpr h)]
+    _ = ∑ w ∈ v.fiberOver F', (w.inertiaDeg F : ℤ) * w.ord f := by
+          refine Finset.sum_congr rfl fun w hw => ?_
+          rw [ite_eq_left ((Place.mem_fiberOver v).mp hw), hD w, mul_comm]
+
+end Divisor
+
+section T029
+
+variable {K : Type*} [Field K] {F' : Type*} [Field F'] [Algebra K F']
+  [Algebra (RatFunc K) F'] [IsScalarTower K (RatFunc K) F']
+  [FiniteDimensional (RatFunc K) F'] [Algebra.IsSeparable (RatFunc K) F']
+
+private theorem finite_setOf_ord_ne_zero_of_finiteDimensional {f : F'} (hf : f ≠ 0) :
+    {w : Place K F' | w.ord f ≠ 0}.Finite := by
+  classical
+  set P := minpoly (RatFunc K) f with hPdef
+  refine Set.Finite.subset (Set.Finite.biUnion (Set.finite_Iio P.natDegree) (fun i _ =>
+    Set.Finite.biUnion (s := {v : Place K (RatFunc K) | v.ord (P.coeff i) ≠ 0})
+      ?_ (fun v _ => Place.finite_setOf_restrict_eq v))) ?_
+  · rcases eq_or_ne (P.coeff i) 0 with h0 | h0
+    · simp [h0]
+    · exact RationalFunctionField.finite_setOf_ord_ne_zero h0
+  · intro w hw
+    obtain ⟨i, hi, hci, hord⟩ := w.exists_coeff_ord_ne_zero (F := RatFunc K) hf hw
+    simp only [Set.mem_iUnion, Set.mem_ofPred_eq, exists_prop]
+    refine ⟨i, hi, w.restrict (RatFunc K), ?_, rfl⟩
+    intro h0
+    apply hord
+    rw [w.ord_restrict, h0, mul_zero]
+
+end T029
+end AlgebraicCurve
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_hasPrincipalDivisors_of_finiteDimensional_ratFunc.AlgebraicCurve"
+
+theorem solution (K : Type*) [Field K] [CharZero K] (F' : Type*)
+    [Field F'] [Algebra K F'] [Algebra (RatFunc K) F'] [IsScalarTower K (RatFunc K) F']
+    [FiniteDimensional (RatFunc K) F'] :
+    HasPrincipalDivisors K F' := by
+  have : CharZero (RatFunc K) :=
+    charZero_of_injective_algebraMap (algebraMap K (RatFunc K)).injective
+  constructor
+  intro f hf
+  classical
+  have hfin : {w : Place K F' | w.ord f ≠ 0}.Finite :=
+    finite_setOf_ord_ne_zero_of_finiteDimensional hf
+  refine ⟨Finsupp.onFinset hfin.toFinset (fun w => w.ord f)
+      (fun w hw => hfin.mem_toFinset.mpr hw), fun v => rfl, ?_⟩
+  set D : Divisor K F' := Finsupp.onFinset hfin.toFinset (fun w => w.ord f)
+      (fun w hw => hfin.mem_toFinset.mpr hw) with hDdef
+  have hD : ∀ w : Place K F', D w = w.ord f := fun w => rfl
+  have h0 : Divisor.degree (Divisor.pushforward (RatFunc K) D) = 0 :=
+    RationalFunctionField.degree_eq_zero_of_forall_eq_ord _
+      (fun v => Divisor.pushforwardNormFormula_of_finiteDimensional f hf D hD v)
+  rw [← Divisor.degree_pushforward (F := RatFunc K) D]
+  exact h0
+
+end
+end S_AlgebraicCurve_hasPrincipalDivisors_of_finiteDimensional_ratFunc
+end P2MW
+export P2MW.S_AlgebraicCurve_hasPrincipalDivisors_of_finiteDimensional_ratFunc (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.hasPrincipalDivisors_of_finiteDimensional_ratFunc (K : Type*) [Field K]
+    [CharZero K] (F' : Type*)
+    [Field F'] [Algebra K F'] [Algebra (RatFunc K) F'] [IsScalarTower K (RatFunc K) F']
+    [FiniteDimensional (RatFunc K) F'] :
+    HasPrincipalDivisors K F' :=
+  solution K F'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_hasPrincipalDivisors_of_transcendental.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_hasPrincipalDivisors_of_transcendental.lean
new file mode 100644
index 0000000000..27fa7ebe0b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_hasPrincipalDivisors_of_transcendental.lean
@@ -0,0 +1,845 @@
+/-
+Based on Prove2Me node AlgebraicCurve.hasPrincipalDivisors_of_transcendental
+(b5b9418c-8f88-532c-ad06-cece77886a29) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 602fd9f3-cfb9-5676-a6f8-f9318735d23c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_iff_ord_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_ord_nonneg_of_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_of_ord_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_finite_setOf_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord
+import Mathlib.FieldTheory.Minpoly.Field
+import Mathlib.RingTheory.Ideal.Norm.RelNorm
+import Mathlib.FieldTheory.Perfect
+import Mathlib.Algebra.CharP.Algebra
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree-zero principal divisors over K(x), characteristic 0
+
+Theorem statement: `AlgebraicCurve.hasPrincipalDivisors_of_transcendental`
+(`b5b9418c-8f88-532c-ad06-cece77886a29`), by Claude, 2026-09-05.
+
+Proof: submission `602fd9f3-cfb9-5676-a6f8-f9318735d23c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field of characteristic $0$, let $F$ be a field equipped with a $K$-algebra structure,
+and let $x \in F$ be transcendental over $K$. Assume that $F$ is finite-dimensional as a vector
+space over the intermediate field $K(x) =$ `IntermediateField.adjoin K {x}`. The conclusion is the
+class `HasPrincipalDivisors K F`, i.e. the assertion that for every $f \in F$ with $f \neq 0$ there
+exists a divisor $D$ — a finitely supported function from the places of $F$ over $K$ to
+$\mathbb{Z}$, a place being a valuation subring $\mathcal{O}_v \subseteq F$ which contains
+$\operatorname{im}(K \to F)$, is not all of $F$, and is a principal ideal ring — such that $D(v) =
+v.\mathrm{ord}(f)$ for every place $v$, and such that $D$ has degree $0$, the degree being the sum
+$\sum_v D(v) \cdot v.\mathrm{deg}$ over the (finite) support of $D$ of the values of $D$ weighted by
+the integers $v.\mathrm{deg}$ attached to the places. In particular the existence of such a finitely
+supported $D$ encodes that $v.\mathrm{ord}(f)$ vanishes for all but finitely many $v$.
+
+This is the degree-zero theorem for principal divisors on an algebraic function field of one
+variable, here in the characteristic-zero case and in the form in which the field is presented as a
+finite extension of a rational subfield $K(x)$ generated by a transcendental element; the classical
+statement holds for arbitrary algebraic function fields of one variable, and no such generality is
+claimed here. It supplies the `HasPrincipalDivisors` hypothesis used elsewhere in the development,
+for instance in the variant for fields generated over $K$ by a transcendental element and in the
+identity for the sum of the quantities $e_v - 1$ over places.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_hasPrincipalDivisors_of_transcendental.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_hasPrincipalDivisors_of_transcendental
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.finite_setOf_restrict_eq Place.mem_fiberOver \
+  Divisor.pushforward Divisor.degree_pushforward Divisor.pushforward_apply \
+  Divisor.PushforwardNormFormula Place Divisor Divisor.degree HasPrincipalDivisors \
+  RationalFunctionField.finite_setOf_ord_ne_zero \
+  RationalFunctionField.degree_eq_zero_of_forall_eq_ord"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ord_neg mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos \
+  center integralClosureAt forall_mem_of_restrict_eq fiberCenter mem_fiberCenter_iff_ord_pos \
+  toValuationSubring_eq_of_restrict_eq algebraMap_integralClosureAt_ne_zero \
+  ord_algebraMap_integralClosureAt fiberCenter_liesOver placeOfPrime restrict_placeOfPrime \
+  fiberCenter_placeOfPrime eq_of_fiberCenter_eq finite_setOf_restrict_eq fiberOver mem_fiberOver \
+  ramificationIndex ramificationIndex_pos restrict ord_restrict restrictInclusion \
+  restrictResidueMap inertiaDeg fiber ext ResidueField ord ord_mul ord_inv ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow toValuationSubring mk mem_iff_ord_nonneg ord_nonneg_of_mem \
+  mem_of_ord_nonneg"
+p2m_open "AlgebraicCurve.Place"
+
+section Uniqueness
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+private theorem eq_ord_of_addHom_of_nonneg_iff (φ : F → ℤ)
+    (hmul : ∀ x y, x ≠ 0 → y ≠ 0 → φ (x * y) = φ x + φ y)
+    (hone : ∃ t, t ≠ 0 ∧ φ t = 1)
+    (hiff : ∀ x, x ≠ 0 → (0 ≤ φ x ↔ x ∈ w.toValuationSubring))
+    {x : F} (hx : x ≠ 0) : φ x = w.ord x := by
+  obtain ⟨t, ht0, ht1⟩ := hone
+  have hφ1 : φ 1 = 0 := by
+    have := hmul 1 1 one_ne_zero one_ne_zero
+    rw [mul_one] at this
+    omega
+  have hinv : ∀ y, y ≠ 0 → φ y⁻¹ = -φ y := by
+    intro y hy
+    have h1 : φ (y * y⁻¹) = φ y + φ y⁻¹ := hmul y y⁻¹ hy (inv_ne_zero hy)
+    rw [mul_inv_cancel₀ hy, hφ1] at h1
+    omega
+  have hpow : ∀ (y : F), y ≠ 0 → ∀ m : ℕ, φ (y ^ m) = m * φ y := by
+    intro y hy m
+    induction m with
+    | zero => simpa using hφ1
+    | succ m ih =>
+      rw [pow_succ, hmul _ _ (pow_ne_zero _ hy) hy, ih]
+      push_cast
+      ring
+  have hzpow : ∀ (y : F) (n : ℤ), y ≠ 0 → φ (y ^ n) = n * φ y := by
+    intro y n hy
+    rcases n with m | m
+    · simpa using hpow y hy m
+    · rw [zpow_negSucc, hinv _ (pow_ne_zero _ hy), hpow y hy, Int.negSucc_eq]
+      push_cast
+      ring
+  have hsign : ∀ y, y ≠ 0 → (0 ≤ φ y ↔ 0 ≤ w.ord y) := by
+    intro y hy
+    rw [hiff y hy, w.mem_iff_ord_nonneg hy]
+  have hzero : ∀ y, y ≠ 0 → (φ y = 0 ↔ w.ord y = 0) := by
+    intro y hy
+    have h1 := hsign y hy
+    have h2 := hsign y⁻¹ (inv_ne_zero hy)
+    rw [hinv y hy, w.ord_inv] at h2
+    omega
+  have htord : 0 < w.ord t := by
+    have h1 := (hsign t ht0).mp (by omega)
+    have h2 := (hzero t ht0).not.mp (by omega)
+    omega
+  have hcancel : ∀ y, y ≠ 0 → w.ord y = φ y * w.ord t := by
+    intro y hy
+    have hyt : y * t ^ (-(φ y)) ≠ 0 := mul_ne_zero hy (zpow_ne_zero _ ht0)
+    have h1 : φ (y * t ^ (-(φ y))) = 0 := by
+      rw [hmul _ _ hy (zpow_ne_zero _ ht0), hzpow t _ ht0, ht1]
+      ring
+    have h2 : w.ord (y * t ^ (-(φ y))) = 0 := (hzero _ hyt).mp h1
+    rw [w.ord_mul hy (zpow_ne_zero _ ht0), w.ord_zpow] at h2
+    linarith
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  have hπ0 : (π : F) ≠ 0 := by
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have hπcancel := hcancel (π : F) hπ0
+  rw [w.ord_coe_irreducible hπ] at hπcancel
+  have htord1 : w.ord t = 1 := by
+    have hdvd : w.ord t ∣ 1 := ⟨φ (π : F), by linarith⟩
+    have := Int.le_of_dvd one_pos hdvd
+    omega
+  have := hcancel x hx
+  rw [htord1, mul_one] at this
+  exact this.symm
+
+end Uniqueness
+
+section Dict
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+section ValuationDictionary
+
+variable {v : Place K F} {w : Place K F'}
+
+private theorem neg_log_valuation_fiberCenter_eq_ord (hw : w.restrict F = v) {x : F'} (hx : x ≠ 0) :
+    -log ((fiberCenter F' v hw).valuation F' x) = w.ord x := by
+  refine eq_ord_of_addHom_of_nonneg_iff w
+    (fun y => -log ((fiberCenter F' v hw).valuation F' y)) ?_ ?_ ?_ hx
+  · intro a b ha hb
+    show -log ((fiberCenter F' v hw).valuation F' (a * b)) =
+      -log ((fiberCenter F' v hw).valuation F' a) +
+        -log ((fiberCenter F' v hw).valuation F' b)
+    rw [map_mul, log_mul ((Valuation.ne_zero_iff _).mpr ha) ((Valuation.ne_zero_iff _).mpr hb)]
+    ring
+  · obtain ⟨t, ht⟩ := (fiberCenter F' v hw).valuation_exists_uniformizer F'
+    refine ⟨t, ?_, ?_⟩
+    · intro h
+      rw [h, map_zero] at ht
+      exact exp_ne_zero ht.symm
+    · show -log ((fiberCenter F' v hw).valuation F' t) = 1
+      rw [ht, log_exp]
+      ring
+  · intro y hy
+    have hy0 : (fiberCenter F' v hw).valuation F' y ≠ 0 := (Valuation.ne_zero_iff _).mpr hy
+    change 0 ≤ -log ((fiberCenter F' v hw).valuation F' y) ↔ y ∈ w.toValuationSubring
+    have hmem : y ∈ w.toValuationSubring ↔ (fiberCenter F' v hw).valuation F' y ≤ 1 := by
+      rw [toValuationSubring_eq_of_restrict_eq hw,
+        HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact Iff.rfl
+    rw [hmem]
+    constructor
+    · intro h
+      calc (fiberCenter F' v hw).valuation F' y
+          = exp (log ((fiberCenter F' v hw).valuation F' y)) := (exp_log hy0).symm
+        _ ≤ exp 0 := by rw [exp_le_exp]; omega
+        _ = 1 := exp_zero
+    · intro h
+      have h1 : exp (log ((fiberCenter F' v hw).valuation F' y)) ≤ exp 0 := by
+        rw [exp_log hy0, exp_zero]
+        exact h
+      rw [exp_le_exp] at h1
+      omega
+
+private theorem le_ord_iff_mem_pow_fiberCenter (hw : w.restrict F = v)
+    {c : integralClosureAt F' v} (hc : c ≠ 0) (n : ℕ) :
+    (n : ℤ) ≤ w.ord (algebraMap (integralClosureAt F' v) F' c) ↔
+      c ∈ (fiberCenter F' v hw).asIdeal ^ n := by
+  have hcF : algebraMap (integralClosureAt F' v) F' c ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hc
+  rw [← neg_log_valuation_fiberCenter_eq_ord hw hcF,
+    HeightOneSpectrum.valuation_of_algebraMap,
+    ← HeightOneSpectrum.intValuation_le_pow_iff_mem]
+  have h0 : (fiberCenter F' v hw).intValuation c ≠ 0 :=
+    HeightOneSpectrum.intValuation_ne_zero _ c hc
+  constructor
+  · intro h
+    calc (fiberCenter F' v hw).intValuation c
+        = exp (log ((fiberCenter F' v hw).intValuation c)) := (exp_log h0).symm
+      _ ≤ exp (-(n : ℤ)) := by rw [exp_le_exp]; omega
+  · intro h
+    have h1 : exp (log ((fiberCenter F' v hw).intValuation c)) ≤ exp (-(n : ℤ)) := by
+      rw [exp_log h0]
+      exact h
+    rw [exp_le_exp] at h1
+    omega
+
+private theorem ramificationIndex_eq_ramificationIdx_fiberCenter (hw : w.restrict F = v) :
+    w.ramificationIndex F =
+      (IsLocalRing.maximalIdeal v.toValuationSubring).ramificationIdx'
+        (fiberCenter F' v hw).asIdeal := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπ0 : π ≠ 0 := hπ.ne_zero
+  have hπC : algebraMap v.toValuationSubring (integralClosureAt F' v) π ≠ 0 :=
+    algebraMap_integralClosureAt_ne_zero hπ0
+  have hmap : (IsLocalRing.maximalIdeal v.toValuationSubring).map
+      (algebraMap v.toValuationSubring (integralClosureAt F' v))
+        = Ideal.span {algebraMap v.toValuationSubring (integralClosureAt F' v) π} := by
+    rw [hπ.maximalIdeal_eq, Ideal.map_span, Set.image_singleton]
+  have hord : w.ord (algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) π))
+        = w.ramificationIndex F := by
+    rw [ord_algebraMap_integralClosureAt hw, ValuationSubring.algebraMap_apply,
+      v.ord_coe_irreducible hπ, mul_one]
+  refine (Ideal.ramificationIdx'_spec ?_ ?_).symm
+  · rw [hmap, Ideal.span_singleton_le_iff_mem,
+      ← le_ord_iff_mem_pow_fiberCenter hw hπC, hord]
+  · rw [hmap, Ideal.span_singleton_le_iff_mem,
+      ← le_ord_iff_mem_pow_fiberCenter hw hπC, hord]
+    have : 0 < w.ramificationIndex F := w.ramificationIndex_pos
+    push_cast
+    omega
+
+end ValuationDictionary
+
+section ResidueDictionary
+
+variable {v : Place K F} {w : Place K F'}
+
+private def toValuationSubringOfRestrictEq (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.toValuationSubring :=
+  (algebraMap (integralClosureAt F' v) F').codRestrict
+    w.toValuationSubring.toSubring (forall_mem_of_restrict_eq hw)
+
+omit [FiniteDimensional F F'] in
+@[scoped simp]
+private theorem coe_toValuationSubringOfRestrictEq (hw : w.restrict F = v)
+    (c : integralClosureAt F' v) :
+    (toValuationSubringOfRestrictEq hw c : F')
+      = algebraMap (integralClosureAt F' v) F' c := rfl
+
+private def residueOfCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.ResidueField :=
+  (IsLocalRing.residue w.toValuationSubring).comp (toValuationSubringOfRestrictEq hw)
+
+omit [FiniteDimensional F F'] in
+private theorem residueOfCenter_apply (hw : w.restrict F = v) (c : integralClosureAt F' v) :
+    residueOfCenter hw c = IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw c) := rfl
+
+private theorem ker_residueOfCenter (hw : w.restrict F = v) :
+    RingHom.ker (residueOfCenter hw) = (fiberCenter F' v hw).asIdeal := by
+  ext c
+  rw [RingHom.mem_ker, residueOfCenter_apply, IsLocalRing.residue_eq_zero_iff]
+  exact Iff.rfl
+
+private theorem surjective_residueOfCenter (hw : w.restrict F = v) :
+    Function.Surjective (residueOfCenter hw) := by
+  classical
+  intro y
+  obtain ⟨x, rfl⟩ := IsLocalRing.residue_surjective y
+  have hx : (x : F') ∈ HeightOneSpectrum.valuationSubringAtPrime F' (fiberCenter F' v hw) := by
+    rw [← toValuationSubring_eq_of_restrict_eq hw]
+    exact x.2
+  obtain ⟨a, s, hs, hxas⟩ := hx
+  have hsP : s ∉ (fiberCenter F' v hw).asIdeal := hs
+  have hs0 : s ≠ 0 := fun h => hsP (h ▸ (fiberCenter F' v hw).asIdeal.zero_mem)
+  have hsF : algebraMap (integralClosureAt F' v) F' s ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hs0
+  have hsord : w.ord (algebraMap (integralClosureAt F' v) F' s) = 0 := by
+    have h1 : ¬ 0 < w.ord (algebraMap (integralClosureAt F' v) F' s) := by
+      rw [← mem_fiberCenter_iff_ord_pos hw hs0]
+      exact hsP
+    have h2 : 0 ≤ w.ord (algebraMap (integralClosureAt F' v) F' s) :=
+      w.ord_nonneg_of_mem (forall_mem_of_restrict_eq hw s)
+    omega
+  have hmax : (fiberCenter F' v hw).asIdeal.IsMaximal :=
+    (fiberCenter F' v hw).isPrime.isMaximal (fiberCenter F' v hw).ne_bot
+  obtain ⟨t, i, hi, hti⟩ := hmax.exists_inv hsP
+  have hst : s * t - 1 ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : s * t - 1 = -i := by linear_combination hti
+    rw [h1]
+    exact neg_mem hi
+  refine ⟨a * t, ?_⟩
+  rw [residueOfCenter_apply, ← sub_eq_zero, ← map_sub, IsLocalRing.residue_eq_zero_iff]
+  have hcoe : ((toValuationSubringOfRestrictEq hw (a * t) - x : w.toValuationSubring) : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') := rfl
+  rcases eq_or_ne (toValuationSubringOfRestrictEq hw (a * t) - x) 0 with hzero | hne
+  · rw [hzero]
+    exact (IsLocalRing.maximalIdeal w.toValuationSubring).zero_mem
+  have hcoene : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') ≠ 0 := by
+    intro h
+    exact hne (by rwa [← hcoe, ZeroMemClass.coe_eq_zero] at h)
+  have hfactor : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t * s - a)
+          * (algebraMap (integralClosureAt F' v) F' s)⁻¹ := by
+    rw [hxas, map_sub, map_mul (algebraMap (integralClosureAt F' v) F') (a * t) s,
+      sub_mul, mul_assoc, mul_inv_cancel₀ hsF, mul_one]
+  have hdiffC : a * t * s - a ≠ 0 := by
+    intro h
+    apply hcoene
+    rw [hfactor, h, map_zero, zero_mul]
+  have hdiffP : a * t * s - a ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : a * t * s - a = a * (s * t - 1) := by ring
+    rw [h1]
+    exact Ideal.mul_mem_left _ _ hst
+  have hmem' : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      ∈ w.toValuationSubring := by
+    rw [← hcoe]
+    exact Subtype.coe_prop _
+  rw [show (toValuationSubringOfRestrictEq hw (a * t) - x)
+      = (⟨_, hmem'⟩ : w.toValuationSubring) from Subtype.ext hcoe,
+    w.mem_maximalIdeal_iff_ord_pos hcoene hmem']
+  rw [hfactor, w.ord_mul (by
+      simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hdiffC)
+    (inv_ne_zero hsF), w.ord_inv, hsord, neg_zero, add_zero]
+  exact (mem_fiberCenter_iff_ord_pos hw hdiffC).mp hdiffP
+
+private def residueFieldEquivQuotientCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v ⧸ (fiberCenter F' v hw).asIdeal ≃+* w.ResidueField :=
+  (Ideal.quotEquivOfEq (ker_residueOfCenter hw).symm).trans
+    ((residueOfCenter hw).quotientKerEquivOfSurjective (surjective_residueOfCenter hw))
+
+private theorem residueFieldEquivQuotientCenter_mk (hw : w.restrict F = v)
+    (c : integralClosureAt F' v) :
+    residueFieldEquivQuotientCenter hw (Ideal.Quotient.mk _ c) = residueOfCenter hw c := by
+  change ((residueOfCenter hw).quotientKerEquivOfSurjective (surjective_residueOfCenter hw))
+    ((Ideal.quotEquivOfEq (ker_residueOfCenter hw).symm) (Ideal.Quotient.mk _ c))
+      = residueOfCenter hw c
+  rw [Ideal.quotEquivOfEq_mk]
+  exact RingHom.quotientKerEquivOfSurjective_apply_mk _ c
+
+private def placeCongrEquiv {u u' : Place K F} (h : u = u') :
+    u.toValuationSubring ≃+* u'.toValuationSubring where
+  toFun x := ⟨x.1, h ▸ x.2⟩
+  invFun x := ⟨x.1, h.symm ▸ x.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  map_mul' _ _ := rfl
+  map_add' _ _ := rfl
+
+@[scoped simp]
+private theorem coe_placeCongrEquiv {u u' : Place K F} (h : u = u') (x : u.toValuationSubring) :
+    (placeCongrEquiv h x : F) = (x : F) := rfl
+
+private def restrictResidueFieldEquiv (hw : w.restrict F = v) :
+    (w.restrict F).ResidueField ≃+* IsLocalRing.ResidueField v.toValuationSubring :=
+  IsLocalRing.ResidueField.mapEquiv (placeCongrEquiv hw)
+
+omit [FiniteDimensional F F'] in
+private theorem restrictResidueFieldEquiv_residue (hw : w.restrict F = v)
+    (a : (w.restrict F).toValuationSubring) :
+    restrictResidueFieldEquiv hw (IsLocalRing.residue _ a)
+      = IsLocalRing.residue _ (placeCongrEquiv hw a) := by
+  simp only [restrictResidueFieldEquiv, IsLocalRing.ResidueField.mapEquiv_apply,
+    IsLocalRing.ResidueField.map_residue, RingEquiv.coe_toRingHom]
+
+private theorem inertiaDeg_eq_inertiaDeg_fiberCenter (hw : w.restrict F = v) :
+    w.inertiaDeg F =
+      (fiberCenter F' v hw).asIdeal.inertiaDeg v.toValuationSubring := by
+  have := fiberCenter_liesOver hw
+  rw [Ideal.inertiaDeg_eq_of_isMaximal (IsLocalRing.maximalIdeal v.toValuationSubring)
+    (fiberCenter F' v hw).asIdeal]
+  change Module.finrank (w.restrict F).ResidueField w.ResidueField = _
+  refine Algebra.finrank_eq_of_equiv_equiv (restrictResidueFieldEquiv hw)
+    (residueFieldEquivQuotientCenter hw).symm ?_
+  ext a
+  obtain ⟨a, rfl⟩ := IsLocalRing.residue_surjective a
+  simp only [RingHom.coe_comp, Function.comp_apply, RingEquiv.toRingHom_eq_coe,
+    RingHom.coe_coe]
+  apply (residueFieldEquivQuotientCenter hw).injective
+  rw [RingEquiv.apply_symm_apply]
+  change IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw
+        (algebraMap v.toValuationSubring (integralClosureAt F' v) (placeCongrEquiv hw a)))
+    = IsLocalRing.residue w.toValuationSubring (restrictInclusion F w a)
+  refine congrArg _ (Subtype.ext ?_)
+  change algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) (placeCongrEquiv hw a))
+    = algebraMap F F' (a : F)
+  rw [← IsScalarTower.algebraMap_apply,
+    IsScalarTower.algebraMap_apply v.toValuationSubring F F']
+  rfl
+
+end ResidueDictionary
+
+end Dict
+
+section SupportTransfer
+
+open Polynomial
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F'] [Algebra F F']
+  [FiniteDimensional F F']
+
+variable (w : Place K F')
+
+omit [FiniteDimensional F F'] in
+private theorem _root_.AlgebraicCurve.Place.aeval_mem {Q : Polynomial F} {x : F'}
+    (hcoeff : ∀ i, algebraMap F F' (Q.coeff i) ∈ w.toValuationSubring)
+    (hx : x ∈ w.toValuationSubring) :
+    Polynomial.aeval x Q ∈ w.toValuationSubring := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range]
+  exact sum_mem fun i _ => mul_mem (hcoeff i) (pow_mem hx i)
+
+p2m_export "AlgebraicCurve.Place" "aeval_mem"
+
+private theorem _root_.AlgebraicCurve.Place.exists_coeff_ord_ne_zero {f : F'} (hf : f ≠ 0)
+    (hford : w.ord f ≠ 0) :
+    ∃ i < (minpoly F f).natDegree, (minpoly F f).coeff i ≠ 0 ∧
+      w.ord (algebraMap F F' ((minpoly F f).coeff i)) ≠ 0 := by
+  by_contra hcon
+  push Not at hcon
+  set P := minpoly F f with hPdef
+  have hint : IsIntegral F f := Algebra.IsIntegral.isIntegral f
+  have hmonic : P.Monic := minpoly.monic hint
+  have hdeg : 0 < P.natDegree := minpoly.natDegree_pos hint
+  have hc0 : P.coeff 0 ≠ 0 := minpoly.coeff_zero_ne_zero hint hf
+  have hcoeff : ∀ i, algebraMap F F' (P.coeff i) ∈ w.toValuationSubring := by
+    intro i
+    rcases lt_trichotomy i P.natDegree with hi | hi | hi
+    · rcases eq_or_ne (P.coeff i) 0 with h0 | h0
+      · simp [h0]
+      · exact w.mem_of_ord_nonneg (by simpa using h0) (by have := hcon i hi h0; omega)
+    · subst hi
+      simp [hmonic.coeff_natDegree]
+    · simp [Polynomial.coeff_eq_zero_of_natDegree_lt hi]
+  have hfmem : f ∈ w.toValuationSubring := by
+    refine w.mem_of_eval_monic_eq_zero (P := P.map (algebraMap F F')) (hmonic.map _)
+      (fun i => by simpa using hcoeff i) ?_
+    rw [Polynomial.eval_map, ← Polynomial.aeval_def, hPdef, minpoly.aeval]
+  have hfpos : 0 < w.ord f := lt_of_le_of_ne (w.ord_nonneg_of_mem hfmem) (Ne.symm hford)
+  have hkey : algebraMap F F' (P.coeff 0) = -(f * Polynomial.aeval f P.divX) := by
+    have hsplit : Polynomial.aeval f (Polynomial.X * P.divX + Polynomial.C (P.coeff 0))
+        = (0 : F') := by rw [P.X_mul_divX_add]; exact minpoly.aeval F f
+    rw [map_add, map_mul, Polynomial.aeval_X, Polynomial.aeval_C] at hsplit
+    linear_combination hsplit
+  have hcof_mem : Polynomial.aeval f P.divX ∈ w.toValuationSubring :=
+    w.aeval_mem (fun i => by rw [Polynomial.coeff_divX]; exact hcoeff (i + 1)) hfmem
+  have hcof_ne : Polynomial.aeval f P.divX ≠ 0 := by
+    intro h
+    rw [h, mul_zero, neg_zero] at hkey
+    exact hc0 (by simpa using hkey)
+  have hpos0 : 0 < w.ord (algebraMap F F' (P.coeff 0)) := by
+    rw [hkey, w.ord_neg, w.ord_mul hf hcof_ne]
+    have := w.ord_nonneg_of_mem hcof_mem
+    omega
+  have := hcon 0 hdeg hc0
+  omega
+
+p2m_export "AlgebraicCurve.Place" "exists_coeff_ord_ne_zero"
+end SupportTransfer
+
+end Place
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing UniqueFactorizationMonoid
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.finite_setOf_restrict_eq Place.mem_fiberOver \
+  Divisor.pushforward Divisor.degree_pushforward Divisor.pushforward_apply \
+  Divisor.PushforwardNormFormula Place Divisor Divisor.degree HasPrincipalDivisors \
+  RationalFunctionField.finite_setOf_ord_ne_zero \
+  RationalFunctionField.degree_eq_zero_of_forall_eq_ord"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ord_neg mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos \
+  center integralClosureAt forall_mem_of_restrict_eq fiberCenter mem_fiberCenter_iff_ord_pos \
+  toValuationSubring_eq_of_restrict_eq algebraMap_integralClosureAt_ne_zero \
+  ord_algebraMap_integralClosureAt fiberCenter_liesOver placeOfPrime restrict_placeOfPrime \
+  fiberCenter_placeOfPrime eq_of_fiberCenter_eq finite_setOf_restrict_eq fiberOver mem_fiberOver \
+  ramificationIndex ramificationIndex_pos restrict ord_restrict restrictInclusion \
+  restrictResidueMap inertiaDeg fiber ext ResidueField ord ord_mul ord_inv ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow toValuationSubring mk mem_iff_ord_nonneg ord_nonneg_of_mem \
+  mem_of_ord_nonneg"
+p2m_open "AlgebraicCurve.Place"
+
+section DVR
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem ord_coe_eq_of_span_singleton_eq_pow_maximalIdeal {r : v.toValuationSubring} {n : ℕ}
+    (h : Ideal.span {r} = IsLocalRing.maximalIdeal v.toValuationSubring ^ n) :
+    v.ord (r : F) = n := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  rw [hπ.maximalIdeal_eq, Ideal.span_singleton_pow, Ideal.span_singleton_eq_span_singleton] at h
+  obtain ⟨u, hu⟩ := h
+  have hr : r = ((u⁻¹ : v.toValuationSubringˣ) : v.toValuationSubring) * π ^ n := by
+    rw [mul_comm, Units.eq_mul_inv_iff_mul_eq]
+    exact hu
+  have hcoe : (r : F) = (((u⁻¹ : v.toValuationSubringˣ) : v.toValuationSubring) : F)
+      * (π : F) ^ (n : ℤ) := by
+    rw [hr]
+    push_cast
+    rw [zpow_natCast]
+  rw [hcoe, v.ord_unit_smul_zpow u⁻¹ hπ (n : ℤ)]
+
+end DVR
+end Place
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F'] [CharZero F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ord_neg mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos \
+  center integralClosureAt forall_mem_of_restrict_eq fiberCenter mem_fiberCenter_iff_ord_pos \
+  toValuationSubring_eq_of_restrict_eq algebraMap_integralClosureAt_ne_zero \
+  ord_algebraMap_integralClosureAt fiberCenter_liesOver placeOfPrime restrict_placeOfPrime \
+  fiberCenter_placeOfPrime eq_of_fiberCenter_eq finite_setOf_restrict_eq fiberOver mem_fiberOver \
+  ramificationIndex ramificationIndex_pos restrict ord_restrict restrictInclusion \
+  restrictResidueMap inertiaDeg fiber ext ResidueField ord ord_mul ord_inv ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow toValuationSubring mk mem_iff_ord_nonneg ord_nonneg_of_mem \
+  mem_of_ord_nonneg"
+p2m_open "AlgebraicCurve.Place"
+
+private scoped instance (v : Place K F) : CharZero v.toValuationSubring :=
+  ⟨fun a b hab => Nat.cast_injective (R := F)
+    (by simpa using congrArg (Subtype.val : v.toValuationSubring → F) hab)⟩
+
+section IdealNorm
+
+variable {v : Place K F} {w : Place K F'}
+
+private theorem relNorm_fiberCenter (hw : w.restrict F = v) :
+    Ideal.relNorm v.toValuationSubring (fiberCenter F' v hw).asIdeal
+      = IsLocalRing.maximalIdeal v.toValuationSubring ^ w.inertiaDeg F := by
+  have : (fiberCenter F' v hw).asIdeal.IsMaximal :=
+    (fiberCenter F' v hw).isPrime.isMaximal (fiberCenter F' v hw).ne_bot
+  have : (fiberCenter F' v hw).asIdeal.LiesOver
+      (IsLocalRing.maximalIdeal v.toValuationSubring) := fiberCenter_liesOver hw
+  rw [Ideal.relNorm_eq_pow_of_isMaximal (fiberCenter F' v hw).asIdeal
+    (IsLocalRing.maximalIdeal v.toValuationSubring), inertiaDeg_eq_inertiaDeg_fiberCenter hw]
+
+omit [CharZero F] in
+private theorem count_normalizedFactors_span_singleton
+    (hw : w.restrict F = v) {c : integralClosureAt F' v} (hc : c ≠ 0) :
+    (normalizedFactors (Ideal.span {c})).count (fiberCenter F' v hw).asIdeal
+      = (w.ord (algebraMap (integralClosureAt F' v) F' c)).toNat := by
+  have : (fiberCenter F' v hw).asIdeal.IsPrime := (fiberCenter F' v hw).isPrime
+  have hord0 : 0 ≤ w.ord (algebraMap (integralClosureAt F' v) F' c) :=
+    w.ord_nonneg_of_mem (forall_mem_of_restrict_eq hw c)
+  refine Ideal.count_normalizedFactors_eq (p := (fiberCenter F' v hw).asIdeal)
+    (x := Ideal.span {c})
+    (n := (w.ord (algebraMap (integralClosureAt F' v) F' c)).toNat) ?_ ?_
+  · rw [Ideal.span_singleton_le_iff_mem, ← le_ord_iff_mem_pow_fiberCenter hw hc]
+    omega
+  · rw [Ideal.span_singleton_le_iff_mem, ← le_ord_iff_mem_pow_fiberCenter hw hc]
+    push_cast
+    omega
+
+private theorem relNorm_span_singleton {c : integralClosureAt F' v}
+    (hc : c ≠ 0) :
+    Ideal.relNorm v.toValuationSubring (Ideal.span {c})
+      = IsLocalRing.maximalIdeal v.toValuationSubring
+          ^ (∑ w ∈ v.fiberOver F',
+              w.inertiaDeg F * (w.ord (algebraMap (integralClosureAt F' v) F' c)).toNat) := by
+  have hspan : (Ideal.span {c} : Ideal (integralClosureAt F' v)) ≠ ⊥ := by simpa using hc
+  set S : Multiset (Ideal (integralClosureAt F' v)) := normalizedFactors (Ideal.span {c})
+    with hS
+  have hfactor : ∀ Q ∈ S.toFinset, ∃ w' : Place K F', ∃ hw' : w'.restrict F = v,
+      (fiberCenter F' v hw').asIdeal = Q := by
+    intro Q hQ
+    rw [Multiset.mem_toFinset] at hQ
+    have hQprime : Prime Q := prime_of_normalized_factor Q hQ
+    have hQbot : Q ≠ ⊥ := hQprime.ne_zero
+    have : Q.IsPrime := Ideal.isPrime_of_prime hQprime
+    exact ⟨placeOfPrime ⟨Q, inferInstance, hQbot⟩, restrict_placeOfPrime _,
+      congrArg HeightOneSpectrum.asIdeal (fiberCenter_placeOfPrime
+        (⟨Q, inferInstance, hQbot⟩ : HeightOneSpectrum (integralClosureAt F' v)))⟩
+  set T : Finset (Ideal (integralClosureAt F' v)) := (v.fiberOver F').attach.image
+    (fun w' => (fiberCenter F' v ((mem_fiberOver v).mp w'.2)).asIdeal) with hT
+  have hsub : S.toFinset ⊆ T := by
+    intro Q hQ
+    obtain ⟨w', hw', rfl⟩ := hfactor Q hQ
+    exact Finset.mem_image.mpr ⟨⟨w', (mem_fiberOver v).mpr hw'⟩, Finset.mem_attach _ _, rfl⟩
+  have hinj : Set.InjOn (fun w' : {x // x ∈ v.fiberOver F'} =>
+      (fiberCenter F' v ((mem_fiberOver v).mp w'.2)).asIdeal) (v.fiberOver F').attach := by
+    intro w₁ _ w₂ _ h
+    exact Subtype.ext (eq_of_fiberCenter_eq ((mem_fiberOver v).mp w₁.2) ((mem_fiberOver v).mp w₂.2)
+      (HeightOneSpectrum.ext h))
+  calc
+    Ideal.relNorm v.toValuationSubring (Ideal.span {c})
+        = Ideal.relNorm v.toValuationSubring (∏ Q ∈ S.toFinset, Q ^ S.count Q) := by
+          rw [← Finset.prod_multiset_count, hS, Ideal.prod_normalizedFactors_eq_self hspan]
+    _ = ∏ Q ∈ S.toFinset, Ideal.relNorm v.toValuationSubring Q ^ S.count Q := by
+          rw [map_prod]
+          exact Finset.prod_congr rfl fun Q _ => map_pow _ Q _
+    _ = ∏ Q ∈ S.toFinset, IsLocalRing.maximalIdeal v.toValuationSubring
+          ^ (Q.inertiaDeg v.toValuationSubring * S.count Q) := by
+          refine Finset.prod_congr rfl fun Q hQ => ?_
+          obtain ⟨w', hw', rfl⟩ := hfactor Q hQ
+          rw [relNorm_fiberCenter hw', ← pow_mul, inertiaDeg_eq_inertiaDeg_fiberCenter hw']
+    _ = IsLocalRing.maximalIdeal v.toValuationSubring
+          ^ (∑ Q ∈ S.toFinset,
+              Q.inertiaDeg v.toValuationSubring * S.count Q) :=
+          Finset.prod_pow_eq_pow_sum S.toFinset
+            (fun Q => Q.inertiaDeg v.toValuationSubring * S.count Q)
+            (IsLocalRing.maximalIdeal v.toValuationSubring)
+    _ = IsLocalRing.maximalIdeal v.toValuationSubring
+          ^ (∑ w ∈ v.fiberOver F',
+              w.inertiaDeg F * (w.ord (algebraMap (integralClosureAt F' v) F' c)).toNat) := by
+          congr 1
+          calc
+            ∑ Q ∈ S.toFinset,
+                Q.inertiaDeg v.toValuationSubring * S.count Q
+                = ∑ Q ∈ T,
+                    Q.inertiaDeg v.toValuationSubring * S.count Q := by
+                  refine Finset.sum_subset hsub fun Q _ hQ => ?_
+                  rw [Multiset.count_eq_zero_of_notMem
+                    (fun h => hQ (Multiset.mem_toFinset.mpr h)), mul_zero]
+            _ = ∑ w' ∈ (v.fiberOver F').attach,
+                  (fiberCenter F' v ((mem_fiberOver v).mp w'.2)).asIdeal.inertiaDeg
+                      v.toValuationSubring
+                    * S.count (fiberCenter F' v ((mem_fiberOver v).mp w'.2)).asIdeal := by
+                  rw [hT, Finset.sum_image hinj]
+            _ = ∑ w' ∈ (v.fiberOver F').attach, (w'.1.inertiaDeg F
+                  * (w'.1.ord (algebraMap (integralClosureAt F' v) F' c)).toNat) := by
+                  refine Finset.sum_congr rfl fun w' _ => ?_
+                  rw [← inertiaDeg_eq_inertiaDeg_fiberCenter ((mem_fiberOver v).mp w'.2),
+                    count_normalizedFactors_span_singleton ((mem_fiberOver v).mp w'.2) hc]
+            _ = ∑ w ∈ v.fiberOver F',
+                  w.inertiaDeg F
+                    * (w.ord (algebraMap (integralClosureAt F' v) F' c)).toNat :=
+                  Finset.sum_attach (v.fiberOver F') fun w =>
+                    w.inertiaDeg F * (w.ord (algebraMap (integralClosureAt F' v) F' c)).toNat
+
+end IdealNorm
+
+section ElementNorm
+
+variable (v : Place K F)
+
+private theorem ord_norm_algebraMap_integralClosureAt
+    {c : integralClosureAt F' v} (hc : c ≠ 0) :
+    v.ord (Algebra.norm F (algebraMap (integralClosureAt F' v) F' c))
+      = ∑ w ∈ v.fiberOver F', (w.inertiaDeg F : ℤ)
+          * w.ord (algebraMap (integralClosureAt F' v) F' c) := by
+  rw [← Algebra.algebraMap_intNorm (A := v.toValuationSubring) (K := F) (L := F')
+    (B := integralClosureAt F' v)]
+  have hrel := relNorm_span_singleton (v := v) hc
+  rw [Ideal.relNorm_singleton] at hrel
+  rw [ValuationSubring.algebraMap_apply, ord_coe_eq_of_span_singleton_eq_pow_maximalIdeal v hrel]
+  push_cast
+  refine Finset.sum_congr rfl fun w hw => ?_
+  rw [Int.toNat_of_nonneg
+    (w.ord_nonneg_of_mem (forall_mem_of_restrict_eq ((mem_fiberOver v).mp hw) c))]
+
+private theorem ord_norm_eq_sum_fiberOver {f : F'} (hf : f ≠ 0) :
+    v.ord (Algebra.norm F f) = ∑ w ∈ v.fiberOver F', (w.inertiaDeg F : ℤ) * w.ord f := by
+  obtain ⟨⟨c, s⟩, hcs⟩ := IsLocalization.surj
+    (nonZeroDivisors (integralClosureAt F' v)) f
+  have hs0 : (s : integralClosureAt F' v) ≠ 0 := nonZeroDivisors.coe_ne_zero s
+  have hsF : algebraMap (integralClosureAt F' v) F' (s : integralClosureAt F' v) ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective (integralClosureAt F' v) F')).mpr hs0
+  have hcF : algebraMap (integralClosureAt F' v) F' c ≠ 0 := by
+    rw [← hcs]
+    exact mul_ne_zero hf hsF
+  have hc0 : c ≠ 0 := fun h => hcF (by rw [h, map_zero])
+  have hintc := ord_norm_algebraMap_integralClosureAt v hc0
+  have hints := ord_norm_algebraMap_integralClosureAt v hs0
+  rw [← hcs, map_mul, v.ord_mul (Algebra.norm_ne_zero_iff.mpr hf)
+    (Algebra.norm_ne_zero_iff.mpr hsF), hints] at hintc
+  have hsplit : ∑ w ∈ v.fiberOver F', (w.inertiaDeg F : ℤ)
+      * w.ord (f * algebraMap (integralClosureAt F' v) F' (s : integralClosureAt F' v))
+        = (∑ w ∈ v.fiberOver F', (w.inertiaDeg F : ℤ) * w.ord f)
+          + ∑ w ∈ v.fiberOver F', (w.inertiaDeg F : ℤ)
+              * w.ord (algebraMap (integralClosureAt F' v) F' (s : integralClosureAt F' v)) := by
+    rw [← Finset.sum_add_distrib]
+    refine Finset.sum_congr rfl fun w _ => ?_
+    rw [w.ord_mul hf hsF]
+    ring
+  rw [hsplit] at hintc
+  omega
+
+end ElementNorm
+end Place
+
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "pushforward degree_pushforward pushforward_apply \
+  PushforwardNormFormula degree principal"
+p2m_open "AlgebraicCurve.Divisor"
+
+private theorem pushforwardNormFormula_of_finiteDimensional :
+    Divisor.PushforwardNormFormula K F F' := by
+  intro f hf D hD v
+  classical
+  rw [Divisor.pushforward_apply, Place.ord_norm_eq_sum_fiberOver v hf]
+  calc
+    ∑ w ∈ D.support, (if w.restrict F = v then D w * (w.inertiaDeg F : ℤ) else 0)
+        = ∑ w ∈ D.support ∪ v.fiberOver F',
+            (if w.restrict F = v then D w * (w.inertiaDeg F : ℤ) else 0) := by
+          refine Finset.sum_subset Finset.subset_union_left fun w _ hw => ?_
+          rw [Finsupp.notMem_support_iff.mp hw, zero_mul, ite_self]
+    _ = ∑ w ∈ v.fiberOver F', (if w.restrict F = v then D w * (w.inertiaDeg F : ℤ) else 0) := by
+          refine (Finset.sum_subset Finset.subset_union_right fun w _ hw => ?_).symm
+          rw [ite_eq_right fun h => hw ((Place.mem_fiberOver v).mpr h)]
+    _ = ∑ w ∈ v.fiberOver F', (w.inertiaDeg F : ℤ) * w.ord f := by
+          refine Finset.sum_congr rfl fun w hw => ?_
+          rw [ite_eq_left ((Place.mem_fiberOver v).mp hw), hD w, mul_comm]
+
+end Divisor
+
+section T029
+
+variable {K : Type*} [Field K] {F' : Type*} [Field F'] [Algebra K F']
+  [Algebra (RatFunc K) F'] [IsScalarTower K (RatFunc K) F']
+  [FiniteDimensional (RatFunc K) F'] [Algebra.IsSeparable (RatFunc K) F']
+
+private theorem finite_setOf_ord_ne_zero_of_finiteDimensional {f : F'} (hf : f ≠ 0) :
+    {w : Place K F' | w.ord f ≠ 0}.Finite := by
+  classical
+  set P := minpoly (RatFunc K) f with hPdef
+  refine Set.Finite.subset (Set.Finite.biUnion (Set.finite_Iio P.natDegree) (fun i _ =>
+    Set.Finite.biUnion (s := {v : Place K (RatFunc K) | v.ord (P.coeff i) ≠ 0})
+      ?_ (fun v _ => Place.finite_setOf_restrict_eq v))) ?_
+  · rcases eq_or_ne (P.coeff i) 0 with h0 | h0
+    · simp [h0]
+    · exact RationalFunctionField.finite_setOf_ord_ne_zero h0
+  · intro w hw
+    obtain ⟨i, hi, hci, hord⟩ := w.exists_coeff_ord_ne_zero (F := RatFunc K) hf hw
+    simp only [Set.mem_iUnion, Set.mem_ofPred_eq, exists_prop]
+    refine ⟨i, hi, w.restrict (RatFunc K), ?_, rfl⟩
+    intro h0
+    apply hord
+    rw [w.ord_restrict, h0, mul_zero]
+
+end T029
+
+private theorem hasPrincipalDivisors_of_finiteDimensional_ratFunc (K : Type*) [Field K] [CharZero K]
+    (F' : Type*)
+    [Field F'] [Algebra K F'] [Algebra (RatFunc K) F'] [IsScalarTower K (RatFunc K) F']
+    [FiniteDimensional (RatFunc K) F'] :
+    HasPrincipalDivisors K F' := by
+  have : CharZero (RatFunc K) :=
+    charZero_of_injective_algebraMap (algebraMap K (RatFunc K)).injective
+  constructor
+  intro f hf
+  classical
+  have hfin : {w : Place K F' | w.ord f ≠ 0}.Finite :=
+    finite_setOf_ord_ne_zero_of_finiteDimensional hf
+  refine ⟨Finsupp.onFinset hfin.toFinset (fun w => w.ord f)
+      (fun w hw => hfin.mem_toFinset.mpr hw), fun v => rfl, ?_⟩
+  set D : Divisor K F' := Finsupp.onFinset hfin.toFinset (fun w => w.ord f)
+      (fun w hw => hfin.mem_toFinset.mpr hw) with hDdef
+  have hD : ∀ w : Place K F', D w = w.ord f := fun w => rfl
+  have h0 : Divisor.degree (Divisor.pushforward (RatFunc K) D) = 0 :=
+    RationalFunctionField.degree_eq_zero_of_forall_eq_ord _
+      (fun v => Divisor.pushforwardNormFormula_of_finiteDimensional f hf D hD v)
+  rw [← Divisor.degree_pushforward (F := RatFunc K) D]
+  exact h0
+
+end AlgebraicCurve
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_hasPrincipalDivisors_of_transcendental.AlgebraicCurve"
+
+theorem solution (K : Type*) [Field K] [CharZero K] {F : Type*} [Field F]
+    [Algebra K F] (x : F) (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] : HasPrincipalDivisors K F
+      := by
+  classical
+  let e : RatFunc K ≃ₐ[K] ↥(IntermediateField.adjoin K ({x} : Set F)) :=
+    RatFunc.algEquivOfTranscendental x hx
+  let : Algebra (RatFunc K) (↥(IntermediateField.adjoin K ({x} : Set F))) :=
+    e.toAlgHom.toRingHom.toAlgebra
+  let : Algebra (RatFunc K) F :=
+    ((algebraMap (↥(IntermediateField.adjoin K ({x} : Set F))) F).comp
+      e.toAlgHom.toRingHom).toAlgebra
+  have : IsScalarTower (RatFunc K) (↥(IntermediateField.adjoin K ({x} : Set F))) F :=
+    IsScalarTower.of_algebraMap_eq fun q => rfl
+  have : IsScalarTower K (RatFunc K) F := IsScalarTower.of_algebraMap_eq fun r => by
+    change algebraMap K F r = algebraMap (↥(IntermediateField.adjoin K ({x} : Set F))) F (e
+      (algebraMap K (RatFunc K) r))
+    rw [AlgEquiv.commutes]
+    exact IsScalarTower.algebraMap_apply K (↥(IntermediateField.adjoin K ({x} : Set F))) F r
+  have : Module.Finite (RatFunc K) (↥(IntermediateField.adjoin K ({x} : Set F))) :=
+    Module.Finite.of_surjective (Algebra.linearMap (RatFunc K) (↥(IntermediateField.adjoin K ({x} :
+      Set F)))) e.surjective
+  have : FiniteDimensional (RatFunc K) F :=
+    Module.Finite.trans (↥(IntermediateField.adjoin K ({x} : Set F))) F
+  exact hasPrincipalDivisors_of_finiteDimensional_ratFunc K F
+
+end
+end S_AlgebraicCurve_hasPrincipalDivisors_of_transcendental
+end P2MW
+export P2MW.S_AlgebraicCurve_hasPrincipalDivisors_of_transcendental (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.hasPrincipalDivisors_of_transcendental (K : Type*) [Field K] [CharZero K]
+    {F : Type*} [Field F]
+    [Algebra K F] (x : F) (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] : HasPrincipalDivisors K F :=
+  solution K x hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_hasPrincipalDivisors_of_transcendental_of_isSeparable.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_hasPrincipalDivisors_of_transcendental_of_isSeparable.lean
new file mode 100644
index 0000000000..ccee5abe82
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_hasPrincipalDivisors_of_transcendental_of_isSeparable.lean
@@ -0,0 +1,113 @@
+/-
+Based on Prove2Me node AlgebraicCurve.hasPrincipalDivisors_of_transcendental_of_isSeparable
+(0663f2cf-72db-5ba7-9d87-05f7c57cd081) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d4829827-5081-5397-b5c5-c5d4ac271105
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_hasPrincipalDivisors_of_finiteDimensional_of_isSeparable
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Principal divisors have degree zero for finite separable extensions of K(x)
+
+Theorem statement: `AlgebraicCurve.hasPrincipalDivisors_of_transcendental_of_isSeparable`
+(`0663f2cf-72db-5ba7-9d87-05f7c57cd081`), by Claude, 2026-09-05.
+
+Proof: submission `d4829827-5081-5397-b5c5-c5d4ac271105`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $x \in F$ be transcendental over $K$.
+Write $K\langle x\rangle =$ `IntermediateField.adjoin K {x}` for the intermediate field generated by
+$x$. Assume that $F$ is finite-dimensional over $K\langle x\rangle$ and that the extension
+$F/K\langle x\rangle$ is separable. The conclusion is `HasPrincipalDivisors K F`: for every $f \in
+F$ with $f \neq 0$ there exists a finitely supported function $D$ from the places of $F/K$ to
+$\mathbb{Z}$ such that $D(v) = v.\mathrm{ord}(f)$ for every place $v$, and such that the degree of
+$D$, namely the sum $\sum_v D(v)\cdot v.\mathrm{deg}$ over the support of $D$, vanishes. Here a
+place of $F/K$ is a valuation subring of $F$ which contains the image of $K$ under the structure
+map, is not all of $F$, and is a principal ideal ring; the quantities $v.\mathrm{ord}$ and
+$v.\mathrm{deg}$ are the associated order function and residue degree. Thus, in particular, the
+family of orders of a nonzero $f$ is asserted to be finitely supported, and the resulting divisor
+has degree zero.
+
+This is the statement that in a finite separable extension of a rational function field the divisor
+of a nonzero function is well defined and of degree zero, in a form free of hypotheses on the
+characteristic. It is the entry point used to verify that such an $F$ is a curve over $K$
+([`AlgebraicCurve.isCurveOver_of_transcendental`]
+(thm.html#AlgebraicCurve.isCurveOver_of_transcendental))
+and, through that, in the divisor-theoretic computations on modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_hasPrincipalDivisors_of_transcendental_of_isSeparable.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_hasPrincipalDivisors_of_transcendental_of_isSeparable
+open AlgebraicCurve IntermediateField
+
+noncomputable section
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F]
+    {x : F} (htr : Transcendental K x)
+    (hfd : FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F)
+    (hsep : Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F) :
+    HasPrincipalDivisors K F := by
+  have := hfd; have := hsep
+  let e : RatFunc K ≃ₐ[K] K⟮x⟯ := RatFunc.algEquivOfTranscendental x htr
+  let : Algebra (RatFunc K) F :=
+    ((algebraMap K⟮x⟯ F).comp e.toAlgHom.toRingHom).toAlgebra
+  have hsq : RingHom.comp (algebraMap (RatFunc K) F)
+        (e.symm.toRingEquiv : K⟮x⟯ →+* RatFunc K)
+      = RingHom.comp (RingEquiv.refl F : F →+* F) (algebraMap K⟮x⟯ F) := by
+    refine RingHom.ext fun a => ?_
+    change algebraMap K⟮x⟯ F (e (e.symm a)) = algebraMap K⟮x⟯ F a
+    rw [e.apply_symm_apply]
+  have : IsScalarTower K (RatFunc K) F :=
+    IsScalarTower.of_algebraMap_eq fun a => by
+      change algebraMap K F a = algebraMap K⟮x⟯ F (e (algebraMap K (RatFunc K) a))
+      rw [e.commutes, ← IsScalarTower.algebraMap_apply]
+  have : FiniteDimensional (RatFunc K) F :=
+    Module.Finite.of_equiv_equiv e.symm.toRingEquiv (RingEquiv.refl F) hsq
+  have : Algebra.IsSeparable (RatFunc K) F :=
+    Algebra.IsSeparable.of_equiv_equiv e.symm.toRingEquiv (RingEquiv.refl F) hsq
+  exact hasPrincipalDivisors_of_finiteDimensional_of_isSeparable F
+
+end
+end S_AlgebraicCurve_hasPrincipalDivisors_of_transcendental_of_isSeparable
+end P2MW
+export P2MW.S_AlgebraicCurve_hasPrincipalDivisors_of_transcendental_of_isSeparable (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve IntermediateField
+theorem AlgebraicCurve.hasPrincipalDivisors_of_transcendental_of_isSeparable
+    {K F : Type*} [Field K] [Field F] [Algebra K F]
+    {x : F} (htr : Transcendental K x)
+    (hfd : FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F)
+    (hsep : Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F) :
+    HasPrincipalDivisors K F :=
+  solution htr hfd hsep
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_indexOfSpecialty_eq_finrank_H1.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_indexOfSpecialty_eq_finrank_H1.lean
new file mode 100644
index 0000000000..d46f8cb59e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_indexOfSpecialty_eq_finrank_H1.lean
@@ -0,0 +1,206 @@
+/-
+Based on Prove2Me node AlgebraicCurve.indexOfSpecialty_eq_finrank_H1
+(055e075c-3feb-5cb7-895e-8773debd5a86) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 86931058-61e9-50b4-ae66-59aa4b74a001
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Index of specialty equals dim_K H¹(D)
+
+Theorem statement: `AlgebraicCurve.indexOfSpecialty_eq_finrank_H1`
+(`055e075c-3feb-5cb7-895e-8773debd5a86`), by Claude, 2026-09-05.
+
+Proof: submission `86931058-61e9-50b4-ae66-59aa4b74a001`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and assume `HasPrincipalDivisors K F`: for every
+$f \in F$ with $f \neq 0$ there is a divisor $D$ — a finitely supported function from the places of
+$F/K$ (valuation subrings of $F$ containing the image of $K$, distinct from $F$ itself and with
+principal ideal ring structure) to $\mathbb{Z}$ — such that $D(v) = \operatorname{ord}_v(f)$ at
+every place $v$ and $\deg D = 0$. Let $D$ be a divisor. The theorem asserts the equality of two
+natural numbers. On one side, `indexOfSpecialty D` is the $K$-dimension of the quotient of
+`adeleSpace K F` $= \bigsqcup_E$ `adeleBdd E`, the supremum over all divisors $E$ of the
+$K$-submodules of families $\alpha \in \prod_v F$ satisfying $v(\alpha_v) \le \exp(E(v))$ for all
+$v$, by the sum of the preimages in `adeleSpace K F` of `adeleBdd D` and of `globalSub K F`, the
+range of the diagonal map of $F$. On the other side, $\dim_K H^1(D)$ is the $K$-dimension of the
+quotient of the $F$-subalgebra `repartitions K F` of $\prod_v F$ generated by the families $\alpha$
+for which $\{v : v(\alpha_v) \not\le 1\}$ is finite, by the sum of `repartitionsOf D` (the
+repartitions with $v(\alpha_v) \le \exp(D(v))$ everywhere) and `principalRepartitions K F` (the
+image of $F$ under its algebra map into the repartitions, viewed as a $K$-submodule).
+
+This identifies the adelic index of specialty $i(D) = \dim_K \mathbb{A}/(\mathbb{A}(D)+F)$ with the
+dimension of the repartition-theoretic first cohomology $H^1(D)$, so that the two bookkeeping
+devices for the genus and for Riemann–Roch agree. It is used by the Čech form of Riemann–Roch, by
+counting results for effective divisors and by the surjectivity statement for residues at a regular
+prolongation.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_indexOfSpecialty_eq_finrank_H1.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_indexOfSpecialty_eq_finrank_H1
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor repartitions mem_repartitions_of_forall_le_exp \
+  repartitionsOf principalRepartitions mem_principalRepartitions_iff H1 adeleBdd diagonalHom \
+  adeleSpace adeleBdd_le_adeleSpace globalSub indexOfSpecialty mem_adeleSpace_iff \
+  adeleBddPrincipal indexOfSpecialty_eq"
+p2m_open "AlgebraicCurve"
+
+open WithZero
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem mem_repartitionsOf_iff_coe_mem_adeleBdd {D : Divisor K F} {α : ↥(repartitions K F)} :
+    α ∈ repartitionsOf D ↔ (α : Place K F → F) ∈ adeleBdd D := Iff.rfl
+
+theorem mem_repartitions_of_mem_adeleBdd {D : Divisor K F} {α : Place K F → F} (hα : α ∈ adeleBdd D)
+    :
+    α ∈ repartitions K F :=
+  mem_repartitions_of_forall_le_exp D α hα
+
+theorem mem_repartitions_of_mem_adeleSpace {α : Place K F → F} (hα : α ∈ adeleSpace K F) :
+    α ∈ repartitions K F := by
+  obtain ⟨D, hD⟩ := mem_adeleSpace_iff.mp hα
+  exact mem_repartitions_of_mem_adeleBdd hD
+
+theorem diagonalHom_eq_coe_algebraMap (f : F) :
+    diagonalHom K F f = ((algebraMap F ↥(repartitions K F) f : ↥(repartitions K F)) : Place K F → F)
+      := rfl
+
+theorem mem_principalRepartitions_iff_coe_mem_globalSub {α : ↥(repartitions K F)} :
+    α ∈ principalRepartitions K F ↔ (α : Place K F → F) ∈ globalSub K F := by
+  rw [mem_principalRepartitions_iff]
+  constructor
+  · rintro ⟨f, hf⟩; exact ⟨f, hf.symm⟩
+  · rintro ⟨f, hf⟩; exact ⟨f, hf.symm⟩
+
+noncomputable def boundedFamilies [HasPrincipalDivisors K F] : Subalgebra F (Place K F → F) where
+  carrier := {α | ∃ D : Divisor K F, ∀ v : Place K F, v.adicValuation (α v) ≤ exp (D v)}
+  mul_mem' := by
+    rintro α β ⟨D, hD⟩ ⟨E, hE⟩
+    refine ⟨D + E, fun v => ?_⟩
+    rw [Pi.mul_apply, map_mul, Finsupp.add_apply, exp_add]
+    exact mul_le_mul' (hD v) (hE v)
+  add_mem' := by
+    rintro α β ⟨D, hD⟩ ⟨E, hE⟩
+    refine ⟨D ⊔ E, fun v => ?_⟩
+    rw [Pi.add_apply]
+    refine (Valuation.map_add _ _ _).trans (max_le ?_ ?_)
+    · exact (hD v).trans (exp_le_exp.mpr (le_sup_left (a := D) (b := E) v))
+    · exact (hE v).trans (exp_le_exp.mpr (le_sup_right (a := D) (b := E) v))
+  algebraMap_mem' := by
+    intro f
+    rcases eq_or_ne f 0 with rfl | hf
+    · exact ⟨0, fun v => by simp⟩
+    · obtain ⟨P, hP, -⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf
+      refine ⟨-P, fun v => ?_⟩
+      rw [Pi.algebraMap_apply, Algebra.algebraMap_self, RingHom.id_apply,
+        v.adicValuation_eq_exp_neg_ord hf, Finsupp.neg_apply, hP]
+
+theorem mem_adeleSpace_iff_mem_repartitions [HasPrincipalDivisors K F] {α : Place K F → F} :
+    α ∈ adeleSpace K F ↔ α ∈ repartitions K F := by
+  constructor
+  · exact mem_repartitions_of_mem_adeleSpace
+  · intro hα
+    have h : repartitions K F ≤ boundedFamilies (K := K) (F := F) := by
+      refine Algebra.adjoin_le ?_
+      intro β hβ
+      classical
+      let S : Finset (Place K F) := hβ.toFinset
+      refine ⟨∑ v ∈ S, Finsupp.single v (-(v.ord (β v))), fun v => ?_⟩
+      by_cases hv : v ∈ S
+      · have hβv : β v ≠ 0 := by
+          intro h0
+          have : ¬v.adicValuation (β v) ≤ 1 := by simpa [S] using hv
+          apply this; simp [h0]
+        rw [v.adicValuation_eq_exp_neg_ord hβv, exp_le_exp, Finsupp.finsetSum_apply,
+          Finset.sum_eq_single v (fun w _ hw => Finsupp.single_eq_of_ne (Ne.symm hw)) (fun h => (h
+          hv).elim),
+          Finsupp.single_eq_same]
+      · have : v.adicValuation (β v) ≤ 1 := by
+          by_contra h; exact hv (by simpa [S] using h)
+        refine this.trans ?_
+        rw [Finsupp.finsetSum_apply, Finset.sum_eq_zero (fun w hw => ?_), exp_zero]
+        exact Finsupp.single_eq_of_ne (fun h => hv (h ▸ hw))
+    obtain ⟨D, hD⟩ := h hα
+    exact adeleBdd_le_adeleSpace (D := D) hD
+
+theorem adeleSpace_eq_restrictScalars_repartitions [HasPrincipalDivisors K F] :
+    adeleSpace K F = (Subalgebra.toSubmodule (repartitions K F)).restrictScalars K := by
+  ext α
+  exact mem_adeleSpace_iff_mem_repartitions
+
+noncomputable def adeleSpaceEquivRepartitions [HasPrincipalDivisors K F] :
+    ↥(adeleSpace K F) ≃ₗ[K] ↥(repartitions K F) where
+  toFun α := ⟨α, mem_adeleSpace_iff_mem_repartitions.mp α.2⟩
+  invFun α := ⟨α, mem_adeleSpace_iff_mem_repartitions.mpr α.2⟩
+  map_add' _ _ := rfl
+  map_smul' _ _ := rfl
+  left_inv _ := rfl
+  right_inv _ := rfl
+
+end AlgebraicCurve
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_indexOfSpecialty_eq_finrank_H1.AlgebraicCurve WithZero in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [HasPrincipalDivisors K F]
+    (D : Divisor K F) :
+    indexOfSpecialty D = Module.finrank K (H1 D) := by
+  let e := adeleSpaceEquivRepartitions (K := K) (F := F)
+  have hmap : (adeleBddPrincipal K F D).map (e : ↥(adeleSpace K F) →ₗ[K] ↥(repartitions K F))
+      = repartitionsOf D ⊔ principalRepartitions K F := by
+    rw [Submodule.map_sup]
+    congr 1
+    · ext α
+      simp only [Submodule.mem_map, Submodule.mem_comap, Submodule.coe_subtype]
+      constructor
+      · rintro ⟨β, hβ, rfl⟩; exact hβ
+      · intro hα; exact ⟨e.symm α, hα, e.apply_symm_apply α⟩
+    · ext α
+      simp only [Submodule.mem_map, Submodule.mem_comap, Submodule.coe_subtype]
+      constructor
+      · rintro ⟨β, hβ, rfl⟩; exact mem_principalRepartitions_iff_coe_mem_globalSub.mpr hβ
+      · intro hα
+        exact ⟨e.symm α, mem_principalRepartitions_iff_coe_mem_globalSub.mp hα, e.apply_symm_apply
+          α⟩
+  rw [indexOfSpecialty_eq]
+  exact LinearEquiv.finrank_eq (Submodule.Quotient.equiv _ _ e hmap)
+
+end S_AlgebraicCurve_indexOfSpecialty_eq_finrank_H1
+end P2MW
+export P2MW.S_AlgebraicCurve_indexOfSpecialty_eq_finrank_H1 (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace AlgebraicCurve
+theorem indexOfSpecialty_eq_finrank_H1 {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [HasPrincipalDivisors K F] (D : Divisor K F) :
+    indexOfSpecialty D = Module.finrank K (H1 D) :=
+  solution D
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached.lean
new file mode 100644
index 0000000000..cf1b3c3ba4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached.lean
@@ -0,0 +1,1117 @@
+/-
+Based on Prove2Me node AlgebraicCurve.indexOfSpecialty_eq_of_genusReached
+(90946949-c5a6-5aa2-9e6c-3ad54de146c2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d05daaf8-6a7a-5bea-b525-611905a813a6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import Mathlib.RingTheory.Flat.TorsionFree
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Index of specialty at an attained Riemann genus
+
+Theorem statement: `AlgebraicCurve.indexOfSpecialty_eq_of_genusReached`
+(`90946949-c5a6-5aa2-9e6c-3ad54de146c2`), by Claude, 2026-09-05.
+
+Proof: submission `d05daaf8-6a7a-5bea-b525-611905a813a6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra satisfying `IsCurveOver K F`: every nonzero $f \in
+F$ has a divisor recording its orders $v(f)$ at all places and of degree $0$, every place has
+residue field finite over $K$, and $\Omega_{F/K}$ is free of rank $1$ over $F$. Assume the set of
+places $\mathrm{Place}\ K\ F$ is nonempty and that $L(0) = \{f : v(f) \le 1 \text{ for all } v\}$ is
+finite-dimensional over $K$. Let $\gamma \in \mathbb{Z}$ and let $D_0$ be a divisor with
+`RiemannGenusReachedAt γ D₀`, i.e. $L(D_0)$ is finite-dimensional, $\deg D_0 - \ell(D_0) = \gamma -
+1$, and $\deg D - \ell(D) \le \gamma - 1$ for every divisor $D$. Then for every divisor $D$: the
+quotient of the adele space $\mathbb{A} = \bigsqcup_{E} \mathbb{A}(E)$ (the supremum, inside
+$\prod_v F$, of the submodules $\mathbb{A}(E) = \{\alpha : v(\alpha_v) \le \exp(E v)\ \forall v\}$)
+by the submodule generated by $\mathbb{A}(D) \cap \mathbb{A}$ together with the image of the
+diagonal map $F \to \prod_v F$ is a finite $K$-module, and its $K$-dimension $i(D)$ satisfies $i(D)
+= \ell(D) - (\deg D + 1 - \gamma)$, where $\ell(D) = \dim_K L(D)$ and $\deg$ weights each place by
+the degree of its residue field.
+
+This is the adelic form of the Riemann–Roch theorem in the shape $\ell(D) - i(D) = \deg D + 1 -
+\gamma$, with the genus entering as an attained value of $\max_D(\deg D - \ell(D)) + 1$ rather than
+as a dimension of differentials. It serves as the input for Weil duality, for the identification of
+the space of Weil differentials as one-dimensional, and for the classical Riemann–Roch formula, and
+is used in the Čech-theoretic form
+[`AlgebraicCurve.cechRiemannRoch_of_genusReached`]
+(thm.html#AlgebraicCurve.cechRiemannRoch_of_genusReached)
+and in counting arguments for effective divisors.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_coe_unit ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow toValuationSubring mk adicValuation_eq_exp_neg_ord"
+p2m_open "AlgebraicCurve.Place"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+p2m_export "AlgebraicCurve.Place" "ord_nonneg_of_mem"
+p2m_export "AlgebraicCurve.Place" "mem_of_ord_nonneg"
+theorem mem_iff_ord_nonneg {f : F} (hf : f ≠ 0) :
+    f ∈ v.toValuationSubring ↔ 0 ≤ v.ord f :=
+  ⟨v.ord_nonneg_of_mem, v.mem_of_ord_nonneg hf⟩
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "degree degree_single principal smul_def smul_apply"
+end Divisor
+variable {D : Divisor K F}
+p2m_open_scoped "AlgebraicCurve.Divisor" in
+theorem Divisor.degree_nonneg_of_nonneg [IsCurveOver K F]
+    {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) : 0 ≤ Divisor.degree D := by
+  rw [Divisor.degree_eq_sum_support]
+  exact Finset.sum_nonneg fun v _ => mul_nonneg (hD v) (Int.natCast_nonneg _)
+theorem lSpace_eq_bot_of_degree_neg [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) : LSpace D = ⊥ := by
+  rw [eq_bot_iff]
+  intro f hf
+  rw [Submodule.mem_bot]
+  by_contra hf0
+  obtain ⟨P, hPord, hPdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+  have heff : ∀ v : Place K F, 0 ≤ (P + D) v := by
+    intro v
+    rw [Finsupp.add_apply, hPord]
+    rcases mem_lSpace_iff_ord.mp hf with rfl | h
+    · exact absurd rfl hf0
+    · linarith [h v]
+  have hdegPD : 0 ≤ Divisor.degree (P + D) := Divisor.degree_nonneg_of_nonneg heff
+  rw [map_add, hPdeg, zero_add] at hdegPD
+  exact absurd hdegPD (not_le.mpr hD)
+end AlgebraicCurve
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_coe_unit ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow toValuationSubring mk adicValuation_eq_exp_neg_ord"
+p2m_open "AlgebraicCurve.Place"
+
+variable (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mk_mem_maximalIdeal_iff {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    (⟨f, hf⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring
+      ↔ f = 0 ∨ 0 < v.ord f := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  constructor
+  · intro hu
+    rcases eq_or_ne f 0 with rfl | hf0
+    · exact Or.inl rfl
+    · refine Or.inr ?_
+      rcases lt_or_eq_of_le (v.ord_nonneg_of_mem hf) with h | h
+      · exact h
+      · exfalso
+        apply hu
+        rw [← v.adicValuation_coe_eq_one_iff ⟨f, hf⟩]
+        change v.adicValuation f = 1
+        rw [v.adicValuation_eq_exp_neg_ord hf0, ← h, neg_zero, WithZero.exp_zero]
+  · intro h hu
+    have hne : f ≠ 0 := fun h0 => hu.ne_zero (Subtype.ext h0)
+    have h0 : v.ord f = 0 := by
+      obtain ⟨u, hu'⟩ := hu
+      have hcoe : f = ((u : v.toValuationSubring) : F) := by rw [hu']
+      rw [hcoe]; exact v.ord_coe_unit u
+    rcases h with rfl | hpos
+    · exact hne rfl
+    · omega
+
+p2m_export "AlgebraicCurve.Place" "mk_mem_maximalIdeal_iff"
+end Place
+
+theorem ell_le_ell_sub_single_add_deg [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    ell D ≤ ell (D - Finsupp.single P 1) + P.deg := by
+  classical
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible P.toValuationSubring
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by
+    simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := by
+    intro g hg
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ g : F, g ∈ LSpace D → t ^ (D P) * g ∈ P.toValuationSubring := by
+    intro g hg
+    rcases eq_or_ne g 0 with rfl | hg0
+    · simp
+    · refine P.mem_of_ord_nonneg (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have := (mem_lSpace_iff_ord.mp hg).resolve_left hg0 P
+      linarith
+  let ψ : LSpace D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun f => ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+      map_add' := by intro f g; apply Subtype.ext; push_cast; ring
+      map_smul' := by
+        intro c f; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap]
+        ring }
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : LSpace D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ f : LSpace D, φ f = 0 ↔
+      (⟨t ^ (D P) * (f : F), hmem _ f.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := by
+    intro f
+    rw [show φ f = IsLocalRing.residue P.toValuationSubring ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+          from hres (ψ f),
+      IsLocalRing.residue_eq_zero_iff]
+  have hED : E ≤ D := by
+    rw [Finsupp.le_def]; intro v; rw [hE, Finsupp.sub_apply]
+    have : (0 : ℤ) ≤ Finsupp.single P 1 v := by
+      rcases eq_or_ne v P with rfl | hv
+      · simp
+      · simp [Finsupp.single_eq_of_ne hv]
+    linarith
+  have hsub : LSpace E ≤ LSpace D := lSpace_mono hED
+  have hker : LinearMap.ker φ = (LSpace E).comap (LSpace D).subtype := by
+    ext f
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi f, P.mk_mem_maximalIdeal_iff]
+    rcases eq_or_ne (f : F) 0 with hf0 | hf0
+    · simp only [hf0, mul_zero, true_or, true_iff]
+      exact (LSpace E).zero_mem
+    · rw [mem_lSpace_iff_ord]
+      have hfD := (mem_lSpace_iff_ord.mp f.2).resolve_left hf0
+      constructor
+      · rintro (h | h)
+        · exact absurd h (mul_ne_zero htn0 hf0)
+        · refine Or.inr (fun v => ?_)
+          rcases eq_or_ne v P with rfl | hv
+          · rw [hEP]; rw [hordmul hf0] at h; omega
+          · rw [hEv v hv]; exact hfD v
+      · rintro (h | h)
+        · exact absurd h hf0
+        · refine Or.inr ?_
+          have hP := h P
+          rw [hEP] at hP
+          rw [hordmul hf0]; omega
+  have hkerfin : finrank K (LinearMap.ker φ) = ell E := by
+    rw [hker, LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe hsub)]
+  have hquot : finrank K (LSpace D ⧸ LinearMap.ker φ) ≤ P.deg := by
+    rw [LinearEquiv.finrank_eq φ.quotKerEquivRange]
+    exact Submodule.finrank_le (LinearMap.range φ)
+  by_cases hfin : FiniteDimensional K (LSpace D)
+  · have := hfin
+    have hrn := Submodule.finrank_quotient_add_finrank (LinearMap.ker φ)
+    rw [hkerfin] at hrn
+    have hb : ell D = finrank K (LSpace D) := rfl
+    omega
+  · have h0 : ell D = 0 := by rw [ell]; exact finrank_of_infinite_dimensional hfin
+    omega
+
+theorem one_le_deg [IsCurveOver K F] (P : Place K F) : 1 ≤ P.deg := by
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  exact Module.finrank_pos
+
+theorem ell_le_degree_add_ellZero [IsCurveOver K F] {D : Divisor K F}
+    (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D : Divisor K F, (∀ v, 0 ≤ D v) →
+      (Divisor.degree D).toNat = m →
+      (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) by
+    exact H (Divisor.degree D).toNat D hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D hD hm
+    by_cases hD0 : D = 0
+    · subst hD0; simp
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ D P := by
+        have hne : D P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hD P; omega
+      set E : Divisor K F := D - Finsupp.single P 1 with hE
+      have hEeff : ∀ v, 0 ≤ E v := by
+        intro v; rw [hE, Finsupp.sub_apply]
+        rcases eq_or_ne v P with rfl | hv
+        · rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have hdegE : Divisor.degree E = Divisor.degree D - P.deg := by
+        rw [hE, map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hDnn : 0 ≤ Divisor.degree D := Divisor.degree_nonneg_of_nonneg hD
+      have hEnn : 0 ≤ Divisor.degree E := Divisor.degree_nonneg_of_nonneg hEeff
+      have hmlt : (Divisor.degree E).toNat < m := by rw [← hm]; omega
+      have hIH := IH _ hmlt E hEeff rfl
+      have hstep := ell_le_ell_sub_single_add_deg D P
+      rw [← hE] at hstep
+      have hstep' : (ell D : ℤ) ≤ (ell E : ℤ) + P.deg := by exact_mod_cast hstep
+      rw [hdegE] at hIH
+      linarith
+
+theorem ell_le_degree_add_one_of_effective [IsCurveOver K F]
+    (hC : ConstantsAreBase K F) {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  have h := ell_le_degree_add_ellZero hD
+  rw [ell_zero_eq_one_of_constantsAreBase hC] at h
+  exact_mod_cast h
+
+def lSpaceShiftEquiv (D : Divisor K F) {g : F} (hg : g ≠ 0)
+    {Dg : Divisor K F} (hDg : ∀ v, Dg v = v.ord g) :
+    LSpace D ≃ₗ[K] LSpace (D + Dg) where
+  toFun h := ⟨(h : F) * g⁻¹, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (h : F) 0 with hh0 | hh0
+    · left; rw [hh0, zero_mul]
+    · right; intro v
+      rw [Finsupp.add_apply, hDg, v.ord_mul hh0 (inv_ne_zero hg), v.ord_inv]
+      have := (mem_lSpace_iff_ord.mp h.2).resolve_left hh0 v
+      linarith⟩
+  invFun k := ⟨(k : F) * g, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (k : F) 0 with hk0 | hk0
+    · left; rw [hk0, zero_mul]
+    · right; intro v
+      have := (mem_lSpace_iff_ord.mp k.2).resolve_left hk0 v
+      rw [Finsupp.add_apply, hDg] at this
+      rw [v.ord_mul hk0 hg]
+      linarith⟩
+  map_add' h₁ h₂ := by apply Subtype.ext; push_cast; ring
+  map_smul' c h := by
+    apply Subtype.ext
+    simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def]
+    ring
+  left_inv h := by
+    apply Subtype.ext
+    change (h : F) * g⁻¹ * g = (h : F)
+    rw [mul_assoc, inv_mul_cancel₀ hg, mul_one]
+  right_inv k := by
+    apply Subtype.ext
+    change (k : F) * g * g⁻¹ = (k : F)
+    rw [mul_assoc, mul_inv_cancel₀ hg, mul_one]
+
+theorem ell_le_degree_add_one [IsCurveOver K F] (hC : ConstantsAreBase K F)
+    {D : Divisor K F} (hD : 0 ≤ Divisor.degree D) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  rcases eq_or_ne (ell D) 0 with h0 | h0
+  · rw [h0]; push_cast; linarith
+  · have hbot : LSpace D ≠ ⊥ := fun h => h0 (by rw [ell, h, finrank_bot])
+    obtain ⟨g, hgL, hg0⟩ := (Submodule.ne_bot_iff _).mp hbot
+    obtain ⟨Dg, hDgord, hDgdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) g hg0
+    have heff : ∀ v, 0 ≤ (D + Dg) v := by
+      intro v; rw [Finsupp.add_apply, hDgord]
+      have := (mem_lSpace_iff_ord.mp hgL).resolve_left hg0 v
+      linarith
+    have hdeg : Divisor.degree (D + Dg) = Divisor.degree D := by
+      rw [map_add, hDgdeg, add_zero]
+    have hell : ell D = ell (D + Dg) :=
+      LinearEquiv.finrank_eq (lSpaceShiftEquiv D hg0 hDgord)
+    have hfin := ell_le_degree_add_one_of_effective hC heff
+    rw [hdeg] at hfin
+    rw [hell]; exact hfin
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion mk mem_bot subtype_injective \
+  Quotient.subsingleton_iff Quotient.mk restrictScalars inclusion_injective comapSubtypeEquivOfLe \
+  mem_comap finrank_quotient_add_finrank mem_top Quotient.equiv mkQ mem_map coe_subtype map_smul' \
+  zero one quotientQuotientEquivQuotient coe_eq_zero finrank_le range_subtype \
+  Quotient.mk_surjective map mem_inf mem_sup Quotient.mk_eq_zero topEquiv \
+  map_injective_of_injective comap_subtype_self mapQ subsingleton_iff module smul_def mk_eq_zero \
+  coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono map_sup"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+def nestedComapMapMkQEquiv {A B C : Submodule K X} (_hAB : A ≤ B) (hBC : B ≤ C) :
+    ((B.comap C.subtype).map (A.comap C.subtype).mkQ : Submodule K _)
+      ≃ₗ[K] B ⧸ A.comap B.subtype := by
+  set S := A.comap C.subtype with hS
+  set T := B.comap C.subtype with hT
+  let ψ : (T : Type _) →ₗ[K] (C ⧸ S) := S.mkQ ∘ₗ T.subtype
+  have hker : LinearMap.ker ψ = S.comap T.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = T.map S.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let e1 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (T.map S.mkQ : Submodule K _) :=
+    (Submodule.Quotient.equiv _ (LinearMap.ker ψ) (LinearEquiv.refl K T)
+        (by rw [hker]; simp)).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have hmap : (S.comap T.subtype).map
+      (Submodule.comapSubtypeEquivOfLe hBC : (T : Type _) →ₗ[K] B) = A.comap B.subtype := by
+    ext ⟨b, hb⟩
+    simp only [mem_map, mem_comap, Submodule.coe_subtype, hS]
+    constructor
+    · rintro ⟨⟨⟨x, hxC⟩, hxB⟩, hxA, hxeq⟩
+      have hx : x = b := congrArg Subtype.val hxeq
+      subst hx; exact hxA
+    · intro hbA
+      exact ⟨⟨⟨b, hBC hb⟩, hb⟩, hbA, rfl⟩
+  let e2 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (B ⧸ A.comap B.subtype) :=
+    Submodule.Quotient.equiv _ _ (Submodule.comapSubtypeEquivOfLe hBC) hmap
+  exact e1.symm.trans e2
+
+theorem finrank_quotient_chain {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCB : Module.Finite K (C ⧸ B.comap C.subtype)]
+    [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (C ⧸ A.comap C.subtype) ∧
+      finrank K (C ⧸ A.comap C.subtype)
+        = finrank K (C ⧸ B.comap C.subtype) + finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (T.map S.mkQ : Submodule K _) := Module.Finite.equiv eK.symm
+  have : Module.Finite K ((C ⧸ S) ⧸ T.map S.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (C ⧸ S) := Module.Finite.of_submodule_quotient (T.map S.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+theorem finrank_quotient_chain' {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCA : Module.Finite K (C ⧸ A.comap C.subtype)] :
+    Module.Finite K (C ⧸ B.comap C.subtype) ∧
+      finrank K (C ⧸ B.comap C.subtype)
+        = finrank K (C ⧸ A.comap C.subtype) - finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (C ⧸ T) := Module.Finite.equiv e3
+  refine ⟨this, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+def adeleBddQuotSingleEquivResidueField (D : Divisor K F) (P : Place K F) :
+    (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+      ≃ₗ[K] P.ResidueField := by
+  classical
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  let π : P.toValuationSubring :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose
+  have hπ : Irreducible π :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose_spec
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := fun {g} hg => by
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ α : Place K F → F, α ∈ adeleBdd D → t ^ (D P) * α P ∈ P.toValuationSubring := by
+    intro α hα
+    rcases eq_or_ne (α P) 0 with hg0 | hg0
+    · simp [hg0]
+    · refine P.mem_of_ord_nonneg (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have h := hα P
+      rw [P.adicValuation_eq_exp_neg_ord hg0, WithZero.exp_le_exp] at h
+      linarith
+  let ψ : adeleBdd D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun α => ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩
+      map_add' := by
+        intro α β; apply Subtype.ext
+        simp only [Submodule.coe_add, Pi.add_apply]
+        push_cast; ring
+      map_smul' := by
+        intro c α; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap, Pi.smul_apply]
+        ring }
+  have hψ_apply : ∀ α : adeleBdd D,
+      (ψ α : F) = t ^ (D P) * (α : Place K F → F) P := fun α => rfl
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : adeleBdd D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ α : adeleBdd D, φ α = 0 ↔
+      (⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := fun α => by
+    rw [show φ α = IsLocalRing.residue P.toValuationSubring
+            ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ from hres (ψ α),
+      IsLocalRing.residue_eq_zero_iff]
+  have hker : LinearMap.ker φ = (adeleBdd E).comap (adeleBdd D).subtype := by
+    ext α
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi α, P.mk_mem_maximalIdeal_iff, mem_adeleBdd]
+    have hαD := α.2
+    constructor
+    · rintro (h | h) v
+      · have hα0 : (α : Place K F → F) P = 0 := by
+          rcases mul_eq_zero.mp h with h' | h'
+          · exact absurd h' htn0
+          · exact h'
+        by_cases hv : v = P
+        · subst v; rw [hα0, Valuation.map_zero]; exact zero_le
+        · rw [hEv v hv]; exact hαD v
+      · by_cases hv : v = P
+        · subst v
+          rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+          · rw [hα0, Valuation.map_zero]; exact zero_le
+          · rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP]
+            rw [hordmul hα0] at h; omega
+        · rw [hEv v hv]; exact hαD v
+    · intro h
+      rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+      · left; rw [hα0, mul_zero]
+      · right
+        have hP := h P
+        rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP] at hP
+        rw [hordmul hα0]; omega
+  have hsurj : Function.Surjective φ := by
+    intro c
+    obtain ⟨cl, hcl⟩ := IsLocalRing.residue_surjective (R := P.toValuationSubring) c
+    set f : F := (cl : F) * t ^ (-(D P)) with hf
+    have hαD : Pi.single P f ∈ adeleBdd D := by
+      intro v
+      by_cases hv : v = P
+      · subst v
+        simp only [Pi.single_eq_same]
+        rcases eq_or_ne (cl : F) 0 with hc0 | hc0
+        · rw [hf, hc0, zero_mul, Valuation.map_zero]; exact zero_le
+        · have hf0 : f ≠ 0 := by rw [hf]; exact mul_ne_zero hc0 (zpow_ne_zero _ ht0)
+          rw [P.adicValuation_eq_exp_neg_ord hf0, WithZero.exp_le_exp]
+          rw [hf, P.ord_mul hc0 (zpow_ne_zero _ ht0), P.ord_zpow, ht1, mul_one]
+          have hclnn := P.ord_nonneg_of_mem cl.2
+          linarith
+      · rw [Pi.single_eq_of_ne hv, Valuation.map_zero]; exact zero_le
+    refine ⟨⟨Pi.single P f, hαD⟩, ?_⟩
+    change res (ψ ⟨Pi.single P f, hαD⟩) = c
+    rw [hres]
+    rw [show (ψ ⟨Pi.single P f, hαD⟩ : P.toValuationSubring) = cl from ?_, hcl]
+    apply Subtype.ext
+    rw [hψ_apply]
+    change t ^ (D P) * (Pi.single P f : Place K F → F) P = (cl : F)
+    rw [show (Pi.single P f : Place K F → F) P = f from Pi.single_eq_same _ _, hf,
+      mul_comm (cl : F), ← mul_assoc, ← zpow_add₀ ht0, add_neg_cancel, zpow_zero, one_mul]
+  exact (Submodule.Quotient.equiv _ _ (LinearEquiv.refl K _) (by rw [← hker]; simp)).trans
+    (φ.quotKerEquivOfSurjective hsurj)
+
+theorem finrank_adeleBdd_quotient_single [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    Module.Finite K
+        (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype) ∧
+      finrank K
+          (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+        = P.deg := by
+  have := IsCurveOver.finite_residueField (K := K) P
+  exact ⟨Module.Finite.equiv (adeleBddQuotSingleEquivResidueField D P).symm,
+    (adeleBddQuotSingleEquivResidueField D P).finrank_eq⟩
+
+theorem finrank_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+      (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+        = Divisor.degree D₂ - Divisor.degree D₁ := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D₁ D₂ : Divisor K F, D₁ ≤ D₂ →
+      (Divisor.degree (D₂ - D₁)).toNat = m →
+      Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+        (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+          = Divisor.degree D₂ - Divisor.degree D₁ from
+    H _ D₁ D₂ hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D₁ D₂ hD hm
+    have hEeff : ∀ v, 0 ≤ (D₂ - D₁) v := fun v => by
+      rw [Finsupp.sub_apply]; have := hD v; omega
+    by_cases hD0 : D₂ - D₁ = 0
+    · have hD12 : D₁ = D₂ := (sub_eq_zero.mp hD0).symm
+      subst hD12
+      rw [Submodule.comap_subtype_self]
+      have : Subsingleton (adeleBdd D₁ ⧸ (⊤ : Submodule K (adeleBdd D₁))) :=
+        Submodule.Quotient.subsingleton_iff.mpr rfl
+      exact ⟨Module.Finite.of_finite, by simp [Module.finrank_zero_of_subsingleton]⟩
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ (D₂ - D₁) P := by
+        have hne : (D₂ - D₁) P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hEeff P; omega
+      set D₂' : Divisor K F := D₂ - Finsupp.single P 1 with hD₂'
+      have h12' : D₁ ≤ D₂' := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]
+          have := hPpos; rw [Finsupp.sub_apply] at this; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have h2'2 : D₂' ≤ D₂ := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]
+      have hdegD₂' : Divisor.degree D₂' = Divisor.degree D₂ - P.deg := by
+        rw [hD₂', map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hEnn : 0 ≤ Divisor.degree (D₂ - D₁) := Divisor.degree_nonneg_of_nonneg hEeff
+      have hE'nn : 0 ≤ Divisor.degree (D₂' - D₁) := Divisor.degree_nonneg_of_nonneg
+        (fun v => by rw [Finsupp.sub_apply]; have := h12' v; omega)
+      have hdegdiff : Divisor.degree (D₂' - D₁) = Divisor.degree (D₂ - D₁) - P.deg := by
+        simp only [hD₂', map_sub, Divisor.degree_single, one_mul]; ring
+      have hmlt : (Divisor.degree (D₂' - D₁)).toNat < m := by rw [← hm]; omega
+      obtain ⟨hfin', hrank'⟩ := IH _ hmlt D₁ D₂' h12' rfl
+      obtain ⟨hfinS, hrankS⟩ := finrank_adeleBdd_quotient_single (K := K) D₂ P
+      rw [← hD₂'] at hfinS hrankS
+      have := hfin'; have := hfinS
+      obtain ⟨hfin, hrank⟩ := Submodule.finrank_quotient_chain
+        (A := adeleBdd D₁) (B := adeleBdd D₂') (C := adeleBdd D₂)
+        (adeleBdd_mono h12') (adeleBdd_mono h2'2)
+      refine ⟨hfin, ?_⟩
+      rw [hrank, hrankS]
+      push_cast
+      linarith [hrank', hdegD₂']
+
+theorem module_finite_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  (finrank_adeleBdd_quotient hD).1
+
+theorem finrank_adeleBdd_quotient_eq [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+      = Divisor.degree D₂ - Divisor.degree D₁ :=
+  (finrank_adeleBdd_quotient hD).2
+
+def lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (_hD : D₁ ≤ D₂) :
+    (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      →ₗ[K] (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  Submodule.mapQ _ _
+    ((diagonalHom K F).restrict
+      (p := (LSpace D₂ : Submodule K F)) (q := (adeleBdd D₂ : Submodule K _))
+      (fun f hf => diagonal_mem_adeleBdd_iff.mpr hf))
+    (fun f hf => by
+      simp only [Submodule.mem_comap, Submodule.coe_subtype] at hf ⊢
+      exact diagonal_mem_adeleBdd_iff.mpr hf)
+
+theorem lSpaceQuotientToAdeleBddQuotient_injective {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Function.Injective (lSpaceQuotientToAdeleBddQuotient hD) := by
+  rw [injective_iff_map_eq_zero]
+  intro x hx
+  obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+  rw [Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype]
+  rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk f)
+        = Submodule.Quotient.mk ((diagonalHom K F).restrict
+            (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f) from rfl,
+    Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype] at hx
+  exact diagonal_mem_adeleBdd_iff.mp hx
+
+
+theorem ell_sub_ell_le_degree_sub_degree [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)] :
+    (ell D₂ : ℤ) - (ell D₁ : ℤ) ≤ Divisor.degree D₂ - Divisor.degree D₁ := by
+  have := module_finite_adeleBdd_quotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    rw [hℓ₁]; exact (Submodule.finrank_quotient_add_finrank _).symm
+  have hemb : finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      ≤ finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+    LinearMap.finrank_le_finrank_of_injective (lSpaceQuotientToAdeleBddQuotient_injective hD)
+  have hloc := finrank_adeleBdd_quotient_eq hD
+  have : (ell D₂ : ℤ) - (ell D₁ : ℤ)
+      = (finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) : ℤ) := by
+    rw [hL]; push_cast; ring
+  rw [this, ← hloc]
+  exact_mod_cast hemb
+
+theorem adeleBdd_inf_sup_globalSub {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F)
+      = adeleBdd D₁ ⊔ adeleBdd D₂ ⊓ globalSub K F := by
+  rw [inf_comm, sup_inf_assoc_of_le _ (adeleBdd_mono hD), inf_comm]
+
+theorem map_diagonal_lSpace_inf_adeleBdd {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (LSpace D₂).map (diagonalHom K F) ⊓ adeleBdd D₁ = (LSpace D₁).map (diagonalHom K F) := by
+  rw [map_diagonal_lSpace, map_diagonal_lSpace, inf_right_comm,
+    inf_eq_right.mpr (adeleBdd_mono hD)]
+
+theorem gate_finrank_adeleBdd_quotient_single_point [IsCurveOver K F] (P : Place K F) :
+    (finrank K (adeleBdd (Finsupp.single P 1 : Divisor K F)
+        ⧸ (adeleBdd (0 : Divisor K F)).comap (adeleBdd (Finsupp.single P 1)).subtype) : ℤ)
+      = (P.deg : ℤ) := by
+  classical
+  have h01 : (0 : Divisor K F) ≤ Finsupp.single P 1 := by
+    intro v; rw [Finsupp.zero_apply, Finsupp.single_apply]; split_ifs <;> omega
+  have h := finrank_adeleBdd_quotient_eq (K := K) h01
+  rw [h, map_zero, sub_zero, Divisor.degree_single, one_mul]
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion mk mem_bot subtype_injective \
+  Quotient.subsingleton_iff Quotient.mk restrictScalars inclusion_injective comapSubtypeEquivOfLe \
+  mem_comap finrank_quotient_add_finrank mem_top Quotient.equiv mkQ mem_map coe_subtype map_smul' \
+  zero one quotientQuotientEquivQuotient coe_eq_zero finrank_le range_subtype \
+  Quotient.mk_surjective map mem_inf mem_sup Quotient.mk_eq_zero topEquiv \
+  map_injective_of_injective comap_subtype_self mapQ subsingleton_iff module smul_def mk_eq_zero \
+  coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono map_sup"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+theorem comap_subtype_sup_of_le_of_le {S T C : Submodule K X} (hS : S ≤ C) (hT : T ≤ C) :
+    S.comap C.subtype ⊔ T.comap C.subtype = (S ⊔ T).comap C.subtype := by
+  apply Submodule.map_injective_of_injective (f := C.subtype) C.subtype_injective
+  rw [Submodule.map_sup, Submodule.map_comap_subtype, Submodule.map_comap_subtype,
+    Submodule.map_comap_subtype, inf_eq_right.mpr hS, inf_eq_right.mpr hT,
+    inf_eq_right.mpr (sup_le hS hT)]
+
+theorem finrank_quotient_chain_top {M : Type*} [AddCommGroup M] [Module K M]
+    {A B : Submodule K M} (hAB : A ≤ B)
+    [hMB : Module.Finite K (M ⧸ B)] [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (M ⧸ A) ∧
+      finrank K (M ⧸ A) = finrank K (M ⧸ B) + finrank K (B ⧸ A.comap B.subtype) := by
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  let ψ : (B : Type _) →ₗ[K] (M ⧸ A) := A.mkQ ∘ₗ B.subtype
+  have hker : LinearMap.ker ψ = A.comap B.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = B.map A.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let eK : (B ⧸ A.comap B.subtype) ≃ₗ[K] (B.map A.mkQ : Submodule K (M ⧸ A)) :=
+    (Submodule.quotEquivOfEq _ _ hker.symm).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have : Module.Finite K (B.map A.mkQ : Submodule K (M ⧸ A)) := Module.Finite.equiv eK
+  have : Module.Finite K ((M ⧸ A) ⧸ B.map A.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (M ⧸ A) := Module.Finite.of_submodule_quotient (B.map A.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (B.map A.mkQ)
+  rw [LinearEquiv.finrank_eq e3, ← LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem globalSub_le_adeleSpace [HasPrincipalDivisors K F] :
+    globalSub K F ≤ adeleSpace K F := by
+  rintro _ ⟨f, rfl⟩
+  exact diagonal_mem_adeleSpace f
+
+theorem adeleBdd_sup_globalSub_le_adeleSpace [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+  sup_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_eq_comap [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBddPrincipal K F D = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype :=
+  Submodule.comap_subtype_sup_of_le_of_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_mono {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBddPrincipal K F D₁ ≤ adeleBddPrincipal K F D₂ :=
+  sup_le_sup_right (Submodule.comap_mono (adeleBdd_mono hD)) _
+
+section FiniteLSpace
+
+variable [IsCurveOver K F]
+
+theorem finiteDimensional_lSpace [hL0 : FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (D : Divisor K F) : FiniteDimensional K (LSpace D) := by
+  have h0D : (0 : Divisor K F) ≤ D ⊔ 0 := le_sup_right
+  have hDD : D ≤ D ⊔ 0 := le_sup_left
+  suffices h : FiniteDimensional K (LSpace (D ⊔ 0)) by
+    exact Module.Finite.of_injective (Submodule.inclusion (lSpace_mono hDD))
+      (Submodule.inclusion_injective _)
+  have := module_finite_adeleBdd_quotient (K := K) h0D
+  have hfinQ : FiniteDimensional K
+      (LSpace (D ⊔ 0) ⧸ (LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype) :=
+    Module.Finite.of_injective _ (lSpaceQuotientToAdeleBddQuotient_injective h0D)
+  have : FiniteDimensional K
+      ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype : Submodule K _) :=
+    Module.Finite.equiv (Submodule.comapSubtypeEquivOfLe (lSpace_mono h0D)).symm
+  exact Module.Finite.of_submodule_quotient
+    ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype)
+
+end FiniteLSpace
+
+
+theorem range_lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD)
+      = ((adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype).map
+          ((adeleBdd D₁).comap (adeleBdd D₂).subtype).mkQ := by
+  classical
+  ext z
+  obtain ⟨α, rfl⟩ := Submodule.Quotient.mk_surjective _ z
+  simp only [LinearMap.mem_range, Submodule.mem_map, Submodule.mem_comap, Submodule.coe_subtype,
+    Submodule.mkQ_apply]
+  constructor
+  · rintro ⟨x, hx⟩
+    obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+    have hxeq : Submodule.Quotient.mk
+        ((diagonalHom K F).restrict (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f)
+        = (Submodule.Quotient.mk α :
+            adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) := hx
+    refine ⟨α, ?_, rfl⟩
+    have hdiag2 : (diagonalHom K F (f : F)) ∈ adeleBdd D₂ := diagonal_mem_adeleBdd_iff.mpr f.2
+    have hsub : (α : Place K F → F) - diagonalHom K F (f : F) ∈ adeleBdd D₁ := by
+      have hq := (Submodule.Quotient.eq _).mp hxeq.symm
+      simpa using hq
+    refine Submodule.mem_sup.mpr ⟨(α : Place K F → F) - diagonalHom K F (f : F), hsub,
+      diagonalHom K F (f : F), diagonal_mem_globalSub _, ?_⟩
+    abel
+  · rintro ⟨β, hβ, hβeq⟩
+    have hβ' : (β : Place K F → F) ∈ adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F) :=
+      Submodule.mem_inf.mpr ⟨β.2, hβ⟩
+    rw [adeleBdd_inf_sup_globalSub hD, ← map_diagonal_lSpace] at hβ'
+    obtain ⟨γ, hγ, δ, ⟨f, hf, hfδ⟩, hsum⟩ := Submodule.mem_sup.mp hβ'
+    refine ⟨Submodule.Quotient.mk ⟨f, hf⟩, ?_⟩
+    rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk ⟨f, hf⟩)
+          = Submodule.Quotient.mk ((diagonalHom K F).restrict
+              (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) ⟨f, hf⟩) from rfl,
+      ← hβeq, Submodule.Quotient.eq]
+    refine Submodule.mem_comap.mpr ?_
+    change diagonalHom K F f - (β : Place K F → F) ∈ adeleBdd D₁
+    have hβsub : diagonalHom K F f - (β : Place K F → F) = -γ := by
+      rw [← hsum, hfδ]; ring
+    rw [hβsub]; exact (adeleBdd D₁).neg_mem hγ
+
+
+theorem finrank_adeleBddSup_quotient [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) [hL : FiniteDimensional K (LSpace D₂)] :
+    Module.Finite K (↥(adeleBdd D₂ ⊔ globalSub K F)
+        ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) ∧
+      (finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+          ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) : ℤ)
+        = (Divisor.degree D₂ - ell D₂) - (Divisor.degree D₁ - ell D₁) := by
+  classical
+  let A : Submodule K (adeleBdd D₂) := (adeleBdd D₁).comap (adeleBdd D₂).subtype
+  let B : Submodule K (adeleBdd D₂) :=
+    (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype
+  have hAB : A ≤ B := Submodule.comap_mono le_sup_left
+  have hfinA : Module.Finite K (adeleBdd D₂ ⧸ A) := module_finite_adeleBdd_quotient hD
+  have hdimA : (finrank K (adeleBdd D₂ ⧸ A) : ℤ) = Divisor.degree D₂ - Divisor.degree D₁ :=
+    finrank_adeleBdd_quotient_eq hD
+  have hran : LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD) = B.map A.mkQ :=
+    range_lSpaceQuotientToAdeleBddQuotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hdimL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K)
+      ((LSpace D₁).comap (LSpace D₂).subtype)
+    rw [← hℓ₁] at h; exact h.symm
+  have hdimB : ell D₂ = finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) + ell D₁ := by
+    rw [← hran, LinearMap.finrank_range_of_inj
+      (lSpaceQuotientToAdeleBddQuotient_injective hD)]
+    exact hdimL
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  have hfinB : Module.Finite K (adeleBdd D₂ ⧸ B) := Module.Finite.equiv e3
+  have hdim2 : finrank K (adeleBdd D₂ ⧸ A)
+      = finrank K (adeleBdd D₂ ⧸ B) + finrank K (B.map A.mkQ : Submodule K _) := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K) (M := adeleBdd D₂ ⧸ A)
+      (B.map A.mkQ)
+    rw [LinearEquiv.finrank_eq e3] at h; omega
+  have e2 := LinearMap.quotientInfEquivSupQuotient (R := K)
+    (adeleBdd D₂) (adeleBdd D₁ ⊔ globalSub K F)
+  have hsup : adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F) = adeleBdd D₂ ⊔ globalSub K F := by
+    rw [← sup_assoc, sup_eq_left.mpr (adeleBdd_mono hD)]
+  have hB' : (adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype = B := by
+    rw [Submodule.comap_subtype_self, top_inf_eq]
+  let eL : (adeleBdd D₂ ⧸ B) ≃ₗ[K]
+      (adeleBdd D₂ ⧸ ((adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+        (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype)) :=
+    Submodule.quotEquivOfEq _ _ hB'.symm
+  have hfin_iso : Module.Finite K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype) :=
+    Module.Finite.equiv (eL.trans e2)
+  have hdim_iso : finrank K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype)
+      = finrank K (adeleBdd D₂ ⧸ B) :=
+    (LinearEquiv.finrank_eq (eL.trans e2)).symm
+  have hcast : (finrank K (adeleBdd D₂ ⧸ A) : ℤ)
+      = (finrank K (adeleBdd D₂ ⧸ B) : ℤ) + ((ell D₂ : ℤ) - (ell D₁ : ℤ)) := by
+    have hb : (ell D₂ : ℤ)
+        = (finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) : ℤ) + (ell D₁ : ℤ) := by
+      exact_mod_cast hdimB
+    push_cast [hdim2]; linarith
+  have hgoal : (finrank K (adeleBdd D₂ ⧸ B) : ℤ)
+      = Divisor.degree D₂ - ↑(ell D₂) - (Divisor.degree D₁ - ↑(ell D₁)) := by
+    linarith [hdimA, hcast]
+  clear_value eL
+  exact hsup ▸ ⟨hfin_iso, by rw [hdim_iso]; exact hgoal⟩
+
+section Index
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+
+theorem adeleBddSup_eq_of_degree_sub_ell_eq {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)]
+    (heq : Divisor.degree D₂ - ell D₂ = Divisor.degree D₁ - ell D₁) :
+    adeleBdd D₂ ⊔ globalSub K F = adeleBdd D₁ ⊔ globalSub K F := by
+  obtain ⟨hfin, hdim⟩ := finrank_adeleBddSup_quotient hD
+  rw [heq, sub_self] at hdim
+  refine le_antisymm ?_ (sup_le_sup_right (adeleBdd_mono hD) _)
+  have := hfin
+  have hd0 : finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) = 0 := by
+    exact_mod_cast hdim
+  have hsub : Subsingleton (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) :=
+    Module.finrank_zero_iff.mp hd0
+  have htop := Submodule.Quotient.subsingleton_iff.mp hsub
+  intro x hx
+  have hxc : (⟨x, hx⟩ : ↥(adeleBdd D₂ ⊔ globalSub K F)) ∈
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype := by
+    rw [htop]; exact Submodule.mem_top
+  exact hxc
+
+end Index
+
+namespace RiemannGenusReachedAt
+p2m_export "AlgebraicCurve.RiemannGenusReachedAt" "finite mk eq isMax"
+end RiemannGenusReachedAt
+namespace RiemannGenusReachedAt
+p2m_open_scoped "AlgebraicCurve.RiemannGenusReachedAt" in
+private theorem _root_.AlgebraicCurve.RiemannGenusReachedAt.eq_of_ge [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {D : Divisor K F} (hD : D₀ ≤ D) :
+    Divisor.degree D - ell D = γ - 1 := by
+  have := finiteDimensional_lSpace (K := K) D
+  have hge : Divisor.degree D₀ - (ell D₀ : ℤ) ≤ Divisor.degree D - ell D := by
+    have := ell_sub_ell_le_degree_sub_degree (K := K) hD
+    linarith
+  exact le_antisymm (h.isMax D) (h.eq ▸ hge)
+
+end RiemannGenusReachedAt
+p2m_export "AlgebraicCurve" "RiemannGenusReachedAt.eq_of_ge"
+
+theorem adeleSpace_eq_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    adeleSpace K F = adeleBdd D₀ ⊔ globalSub K F := by
+  refine le_antisymm ?_ (adeleBdd_sup_globalSub_le_adeleSpace D₀)
+  rw [adeleSpace, iSup_le_iff]
+  intro D
+  refine le_trans (adeleBdd_mono (le_sup_left : D ≤ D ⊔ D₀)) ?_
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have heq : Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) = Divisor.degree D₀ - ell D₀ :=
+    (h.eq_of_ge le_sup_right).trans h.eq.symm
+  have hsup := adeleBddSup_eq_of_degree_sub_ell_eq (K := K)
+    (le_sup_right : D₀ ≤ D ⊔ D₀) heq
+  rw [← hsup]
+  exact le_sup_left
+
+theorem indexOfSpecialty_eq_zero_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    indexOfSpecialty D₀ = 0 := by
+  rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap, ← adeleSpace_eq_of_genusReached h,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.finrank_zero_of_subsingleton
+
+
+theorem indexOfSpecialty_eq_of_genusReached_port [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D) ∧
+      (indexOfSpecialty D : ℤ) = (ell D : ℤ) - (Divisor.degree D + 1 - γ) := by
+  classical
+  have hDD' : D ≤ D ⊔ D₀ := le_sup_left
+  have hD0D' : D₀ ≤ D ⊔ D₀ := le_sup_right
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have heqD' : Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) = γ - 1 := h.eq_of_ge hD0D'
+  have hsa : adeleSpace K F = adeleBdd (D ⊔ D₀) ⊔ globalSub K F := by
+    refine le_antisymm ?_ (adeleBdd_sup_globalSub_le_adeleSpace _)
+    rw [adeleSpace_eq_of_genusReached h]
+    exact sup_le_sup_right (adeleBdd_mono hD0D') _
+  have hABsub : adeleBdd D ⊔ globalSub K F ≤ adeleBdd (D ⊔ D₀) ⊔ globalSub K F :=
+    sup_le_sup_right (adeleBdd_mono hDD') _
+  have hBCsub : adeleBdd (D ⊔ D₀) ⊔ globalSub K F ≤ adeleSpace K F :=
+    adeleBdd_sup_globalSub_le_adeleSpace _
+  have hCB : (adeleBdd (D ⊔ D₀) ⊔ globalSub K F).comap (adeleSpace K F).subtype = ⊤ := by
+    rw [← hsa, Submodule.comap_subtype_self]
+  have hfinCB : Module.Finite K (adeleSpace K F ⧸
+      (adeleBdd (D ⊔ D₀) ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [hCB]
+    have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+      Submodule.Quotient.subsingleton_iff.mpr rfl
+    exact Module.Finite.of_finite
+  have hdimCB : finrank K (adeleSpace K F ⧸
+      (adeleBdd (D ⊔ D₀) ⊔ globalSub K F).comap (adeleSpace K F).subtype) = 0 := by
+    rw [hCB]
+    have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+      Submodule.Quotient.subsingleton_iff.mpr rfl
+    exact Module.finrank_zero_of_subsingleton
+  obtain ⟨hfinBA, hdimBA⟩ := finrank_adeleBddSup_quotient (K := K) hDD'
+  have := hfinBA
+  obtain ⟨hfinCA, hdimCA⟩ := Submodule.finrank_quotient_chain
+    (A := adeleBdd D ⊔ globalSub K F) (B := adeleBdd (D ⊔ D₀) ⊔ globalSub K F)
+    (C := adeleSpace K F) hABsub hBCsub
+  have hieq : indexOfSpecialty D
+      = finrank K (adeleSpace K F ⧸
+        (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap]
+  rw [adeleBddPrincipal_eq_comap]
+  refine ⟨hfinCA, ?_⟩
+  rw [hieq]
+  push_cast [hdimCA, hdimCB]
+  linarith [hdimBA, heqD']
+
+theorem gate_indexOfSpecialty_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  have h1 := (indexOfSpecialty_eq_of_genusReached_port h D₀).2
+  have h2 := h.eq
+  have h3 := indexOfSpecialty_eq_zero_of_genusReached h
+  exact_mod_cast h3
+
+theorem gate_riemannInequality_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Divisor.degree D + 1 - γ ≤ (ell D : ℤ) := by
+  have heq := (indexOfSpecialty_eq_of_genusReached_port h D).2
+  have hnn : (0 : ℤ) ≤ indexOfSpecialty D := Int.natCast_nonneg _
+  linarith
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached.AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K ↥(LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Module.Finite K (↥(adeleSpace K F) ⧸ adeleBddPrincipal K F D) ∧
+      (indexOfSpecialty D : ℤ) = (ell D : ℤ) - (Divisor.degree D + 1 - γ) :=
+  AlgebraicCurve.indexOfSpecialty_eq_of_genusReached_port (K := K) (F := F) (γ := γ) (D₀ := D₀) (h
+    := h) (D := D)
+
+end S_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached
+end P2MW
+export P2MW.S_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace AlgebraicCurve
+theorem indexOfSpecialty_eq_of_genusReached {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [IsCurveOver K F] [Nonempty (Place K F)] [FiniteDimensional K ↥(LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Module.Finite K (↥(adeleSpace K F) ⧸ adeleBddPrincipal K F D) ∧
+      (indexOfSpecialty D : ℤ) = (ell D : ℤ) - (Divisor.degree D + 1 - γ) :=
+  solution h D
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_indexOfSpecialty_eq_zero_of_genusReached.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_indexOfSpecialty_eq_zero_of_genusReached.lean
new file mode 100644
index 0000000000..db5f2d4558
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_indexOfSpecialty_eq_zero_of_genusReached.lean
@@ -0,0 +1,1072 @@
+/-
+Based on Prove2Me node AlgebraicCurve.indexOfSpecialty_eq_zero_of_genusReached
+(6d0ccad1-4ea9-561d-ae32-230408a9623a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission bfccb010-8325-53dc-9cf9-935e04c54107
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import Mathlib.RingTheory.Flat.TorsionFree
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Index of specialty vanishes at a genus-realising divisor
+
+Theorem statement: `AlgebraicCurve.indexOfSpecialty_eq_zero_of_genusReached`
+(`6d0ccad1-4ea9-561d-ae32-230408a9623a`), by Claude, 2026-09-05.
+
+Proof: submission `bfccb010-8325-53dc-9cf9-935e04c54107`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra satisfying `IsCurveOver K F`, that is: every
+nonzero $f \in F$ admits a divisor whose coefficient at each place $v$ is $v.\mathrm{ord}\,f$ and
+whose degree is $0$; each place $v$ of $F/K$ has residue field finite over $K$; and the module of
+Kähler differentials $\Omega_{F/K}$ is free of rank one over $F$. Assume moreover that the set
+`Place K F` of places is nonempty and that the Riemann–Roch space $L(0)$ — the $K$-submodule of $f
+\in F$ with $v.\mathrm{adicValuation}(f) \le \exp(0)$ at every place $v$ — is finite-dimensional
+over $K$. Let $\gamma \in \mathbb{Z}$ and let $D_0$ be a divisor, i.e. a finitely supported function
+from places to $\mathbb{Z}$, such that `RiemannGenusReachedAt γ D₀` holds: $L(D_0)$ is
+finite-dimensional over $K$, $\deg D_0 - \mathrm{ell}(D_0) = \gamma - 1$, and $\deg D -
+\mathrm{ell}(D) \le \gamma - 1$ for every divisor $D$, where $\deg$ is the $\mathbb{Z}$-linear form
+summing the coefficients weighted by the residue degrees $v.\mathrm{deg}$ and `ell` is the invariant
+attached to a divisor. The conclusion is that `indexOfSpecialty D₀` $= 0$: the $K$-rank of the
+quotient of the adele space $\bigsqcup_D$ `adeleBdd D` (the supremum over all divisors $D$ of the
+$K$-submodules of families $\alpha \in \prod_v F$ with $v.\mathrm{adicValuation}(\alpha_v) \le
+\exp(D v)$ for all $v$) by the sum of the preimages in it of `adeleBdd D₀` and of the range of the
+diagonal map $F \to \prod_v F$ is zero; since the rank is taken as `Module.finrank`, this vanishing
+is the statement that $\mathbb{A}_F/(\mathbb{A}_F(D_0) + F)$ is not a nonzero finite-dimensional
+$K$-space.
+
+This is the classical fact that the index of specialty $i(D) = \dim_K
+\mathbb{A}_F/(\mathbb{A}_F(D)+F)$ vanishes at a divisor realising the extremal value $\gamma - 1$ of
+$\deg D - \ell(D)$, the anchor of the adelic form of the Riemann–Roch index formula. It is used in
+the comparison of the genus of a function field with that of its constant field extension to an
+algebraically closed field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_indexOfSpecialty_eq_zero_of_genusReached.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_indexOfSpecialty_eq_zero_of_genusReached
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_coe_unit ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow toValuationSubring mk adicValuation_eq_exp_neg_ord"
+p2m_open "AlgebraicCurve.Place"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+p2m_export "AlgebraicCurve.Place" "ord_nonneg_of_mem"
+p2m_export "AlgebraicCurve.Place" "mem_of_ord_nonneg"
+theorem mem_iff_ord_nonneg {f : F} (hf : f ≠ 0) :
+    f ∈ v.toValuationSubring ↔ 0 ≤ v.ord f :=
+  ⟨v.ord_nonneg_of_mem, v.mem_of_ord_nonneg hf⟩
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "degree degree_single principal smul_def smul_apply"
+end Divisor
+variable {D : Divisor K F}
+p2m_open_scoped "AlgebraicCurve.Divisor" in
+theorem Divisor.degree_nonneg_of_nonneg [IsCurveOver K F]
+    {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) : 0 ≤ Divisor.degree D := by
+  rw [Divisor.degree_eq_sum_support]
+  exact Finset.sum_nonneg fun v _ => mul_nonneg (hD v) (Int.natCast_nonneg _)
+theorem lSpace_eq_bot_of_degree_neg [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) : LSpace D = ⊥ := by
+  rw [eq_bot_iff]
+  intro f hf
+  rw [Submodule.mem_bot]
+  by_contra hf0
+  obtain ⟨P, hPord, hPdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+  have heff : ∀ v : Place K F, 0 ≤ (P + D) v := by
+    intro v
+    rw [Finsupp.add_apply, hPord]
+    rcases mem_lSpace_iff_ord.mp hf with rfl | h
+    · exact absurd rfl hf0
+    · linarith [h v]
+  have hdegPD : 0 ≤ Divisor.degree (P + D) := Divisor.degree_nonneg_of_nonneg heff
+  rw [map_add, hPdeg, zero_add] at hdegPD
+  exact absurd hdegPD (not_le.mpr hD)
+end AlgebraicCurve
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_coe_unit ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow toValuationSubring mk adicValuation_eq_exp_neg_ord"
+p2m_open "AlgebraicCurve.Place"
+
+variable (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mk_mem_maximalIdeal_iff {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    (⟨f, hf⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring
+      ↔ f = 0 ∨ 0 < v.ord f := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  constructor
+  · intro hu
+    rcases eq_or_ne f 0 with rfl | hf0
+    · exact Or.inl rfl
+    · refine Or.inr ?_
+      rcases lt_or_eq_of_le (v.ord_nonneg_of_mem hf) with h | h
+      · exact h
+      · exfalso
+        apply hu
+        rw [← v.adicValuation_coe_eq_one_iff ⟨f, hf⟩]
+        change v.adicValuation f = 1
+        rw [v.adicValuation_eq_exp_neg_ord hf0, ← h, neg_zero, WithZero.exp_zero]
+  · intro h hu
+    have hne : f ≠ 0 := fun h0 => hu.ne_zero (Subtype.ext h0)
+    have h0 : v.ord f = 0 := by
+      obtain ⟨u, hu'⟩ := hu
+      have hcoe : f = ((u : v.toValuationSubring) : F) := by rw [hu']
+      rw [hcoe]; exact v.ord_coe_unit u
+    rcases h with rfl | hpos
+    · exact hne rfl
+    · omega
+
+p2m_export "AlgebraicCurve.Place" "mk_mem_maximalIdeal_iff"
+end Place
+
+theorem ell_le_ell_sub_single_add_deg [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    ell D ≤ ell (D - Finsupp.single P 1) + P.deg := by
+  classical
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible P.toValuationSubring
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by
+    simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := by
+    intro g hg
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ g : F, g ∈ LSpace D → t ^ (D P) * g ∈ P.toValuationSubring := by
+    intro g hg
+    rcases eq_or_ne g 0 with rfl | hg0
+    · simp
+    · refine P.mem_of_ord_nonneg (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have := (mem_lSpace_iff_ord.mp hg).resolve_left hg0 P
+      linarith
+  let ψ : LSpace D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun f => ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+      map_add' := by intro f g; apply Subtype.ext; push_cast; ring
+      map_smul' := by
+        intro c f; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap]
+        ring }
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : LSpace D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ f : LSpace D, φ f = 0 ↔
+      (⟨t ^ (D P) * (f : F), hmem _ f.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := by
+    intro f
+    rw [show φ f = IsLocalRing.residue P.toValuationSubring ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+          from hres (ψ f),
+      IsLocalRing.residue_eq_zero_iff]
+  have hED : E ≤ D := by
+    rw [Finsupp.le_def]; intro v; rw [hE, Finsupp.sub_apply]
+    have : (0 : ℤ) ≤ Finsupp.single P 1 v := by
+      rcases eq_or_ne v P with rfl | hv
+      · simp
+      · simp [Finsupp.single_eq_of_ne hv]
+    linarith
+  have hsub : LSpace E ≤ LSpace D := lSpace_mono hED
+  have hker : LinearMap.ker φ = (LSpace E).comap (LSpace D).subtype := by
+    ext f
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi f, P.mk_mem_maximalIdeal_iff]
+    rcases eq_or_ne (f : F) 0 with hf0 | hf0
+    · simp only [hf0, mul_zero, true_or, true_iff]
+      exact (LSpace E).zero_mem
+    · rw [mem_lSpace_iff_ord]
+      have hfD := (mem_lSpace_iff_ord.mp f.2).resolve_left hf0
+      constructor
+      · rintro (h | h)
+        · exact absurd h (mul_ne_zero htn0 hf0)
+        · refine Or.inr (fun v => ?_)
+          rcases eq_or_ne v P with rfl | hv
+          · rw [hEP]; rw [hordmul hf0] at h; omega
+          · rw [hEv v hv]; exact hfD v
+      · rintro (h | h)
+        · exact absurd h hf0
+        · refine Or.inr ?_
+          have hP := h P
+          rw [hEP] at hP
+          rw [hordmul hf0]; omega
+  have hkerfin : finrank K (LinearMap.ker φ) = ell E := by
+    rw [hker, LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe hsub)]
+  have hquot : finrank K (LSpace D ⧸ LinearMap.ker φ) ≤ P.deg := by
+    rw [LinearEquiv.finrank_eq φ.quotKerEquivRange]
+    exact Submodule.finrank_le (LinearMap.range φ)
+  by_cases hfin : FiniteDimensional K (LSpace D)
+  · have := hfin
+    have hrn := Submodule.finrank_quotient_add_finrank (LinearMap.ker φ)
+    rw [hkerfin] at hrn
+    have hb : ell D = finrank K (LSpace D) := rfl
+    omega
+  · have h0 : ell D = 0 := by rw [ell]; exact finrank_of_infinite_dimensional hfin
+    omega
+
+theorem one_le_deg [IsCurveOver K F] (P : Place K F) : 1 ≤ P.deg := by
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  exact Module.finrank_pos
+
+theorem ell_le_degree_add_ellZero [IsCurveOver K F] {D : Divisor K F}
+    (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D : Divisor K F, (∀ v, 0 ≤ D v) →
+      (Divisor.degree D).toNat = m →
+      (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) by
+    exact H (Divisor.degree D).toNat D hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D hD hm
+    by_cases hD0 : D = 0
+    · subst hD0; simp
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ D P := by
+        have hne : D P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hD P; omega
+      set E : Divisor K F := D - Finsupp.single P 1 with hE
+      have hEeff : ∀ v, 0 ≤ E v := by
+        intro v; rw [hE, Finsupp.sub_apply]
+        rcases eq_or_ne v P with rfl | hv
+        · rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have hdegE : Divisor.degree E = Divisor.degree D - P.deg := by
+        rw [hE, map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hDnn : 0 ≤ Divisor.degree D := Divisor.degree_nonneg_of_nonneg hD
+      have hEnn : 0 ≤ Divisor.degree E := Divisor.degree_nonneg_of_nonneg hEeff
+      have hmlt : (Divisor.degree E).toNat < m := by rw [← hm]; omega
+      have hIH := IH _ hmlt E hEeff rfl
+      have hstep := ell_le_ell_sub_single_add_deg D P
+      rw [← hE] at hstep
+      have hstep' : (ell D : ℤ) ≤ (ell E : ℤ) + P.deg := by exact_mod_cast hstep
+      rw [hdegE] at hIH
+      linarith
+
+theorem ell_le_degree_add_one_of_effective [IsCurveOver K F]
+    (hC : ConstantsAreBase K F) {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  have h := ell_le_degree_add_ellZero hD
+  rw [ell_zero_eq_one_of_constantsAreBase hC] at h
+  exact_mod_cast h
+
+def lSpaceShiftEquiv (D : Divisor K F) {g : F} (hg : g ≠ 0)
+    {Dg : Divisor K F} (hDg : ∀ v, Dg v = v.ord g) :
+    LSpace D ≃ₗ[K] LSpace (D + Dg) where
+  toFun h := ⟨(h : F) * g⁻¹, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (h : F) 0 with hh0 | hh0
+    · left; rw [hh0, zero_mul]
+    · right; intro v
+      rw [Finsupp.add_apply, hDg, v.ord_mul hh0 (inv_ne_zero hg), v.ord_inv]
+      have := (mem_lSpace_iff_ord.mp h.2).resolve_left hh0 v
+      linarith⟩
+  invFun k := ⟨(k : F) * g, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (k : F) 0 with hk0 | hk0
+    · left; rw [hk0, zero_mul]
+    · right; intro v
+      have := (mem_lSpace_iff_ord.mp k.2).resolve_left hk0 v
+      rw [Finsupp.add_apply, hDg] at this
+      rw [v.ord_mul hk0 hg]
+      linarith⟩
+  map_add' h₁ h₂ := by apply Subtype.ext; push_cast; ring
+  map_smul' c h := by
+    apply Subtype.ext
+    simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def]
+    ring
+  left_inv h := by
+    apply Subtype.ext
+    change (h : F) * g⁻¹ * g = (h : F)
+    rw [mul_assoc, inv_mul_cancel₀ hg, mul_one]
+  right_inv k := by
+    apply Subtype.ext
+    change (k : F) * g * g⁻¹ = (k : F)
+    rw [mul_assoc, mul_inv_cancel₀ hg, mul_one]
+
+theorem ell_le_degree_add_one [IsCurveOver K F] (hC : ConstantsAreBase K F)
+    {D : Divisor K F} (hD : 0 ≤ Divisor.degree D) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  rcases eq_or_ne (ell D) 0 with h0 | h0
+  · rw [h0]; push_cast; linarith
+  · have hbot : LSpace D ≠ ⊥ := fun h => h0 (by rw [ell, h, finrank_bot])
+    obtain ⟨g, hgL, hg0⟩ := (Submodule.ne_bot_iff _).mp hbot
+    obtain ⟨Dg, hDgord, hDgdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) g hg0
+    have heff : ∀ v, 0 ≤ (D + Dg) v := by
+      intro v; rw [Finsupp.add_apply, hDgord]
+      have := (mem_lSpace_iff_ord.mp hgL).resolve_left hg0 v
+      linarith
+    have hdeg : Divisor.degree (D + Dg) = Divisor.degree D := by
+      rw [map_add, hDgdeg, add_zero]
+    have hell : ell D = ell (D + Dg) :=
+      LinearEquiv.finrank_eq (lSpaceShiftEquiv D hg0 hDgord)
+    have hfin := ell_le_degree_add_one_of_effective hC heff
+    rw [hdeg] at hfin
+    rw [hell]; exact hfin
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion mk mem_bot subtype_injective \
+  Quotient.subsingleton_iff Quotient.mk restrictScalars inclusion_injective comapSubtypeEquivOfLe \
+  mem_comap finrank_quotient_add_finrank mem_top Quotient.equiv mkQ mem_map coe_subtype map_smul' \
+  zero one quotientQuotientEquivQuotient coe_eq_zero finrank_le range_subtype \
+  Quotient.mk_surjective map mem_inf mem_sup Quotient.mk_eq_zero topEquiv \
+  map_injective_of_injective comap_subtype_self mapQ subsingleton_iff module smul_def mk_eq_zero \
+  coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono map_sup"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+def nestedComapMapMkQEquiv {A B C : Submodule K X} (_hAB : A ≤ B) (hBC : B ≤ C) :
+    ((B.comap C.subtype).map (A.comap C.subtype).mkQ : Submodule K _)
+      ≃ₗ[K] B ⧸ A.comap B.subtype := by
+  set S := A.comap C.subtype with hS
+  set T := B.comap C.subtype with hT
+  let ψ : (T : Type _) →ₗ[K] (C ⧸ S) := S.mkQ ∘ₗ T.subtype
+  have hker : LinearMap.ker ψ = S.comap T.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = T.map S.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let e1 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (T.map S.mkQ : Submodule K _) :=
+    (Submodule.Quotient.equiv _ (LinearMap.ker ψ) (LinearEquiv.refl K T)
+        (by rw [hker]; simp)).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have hmap : (S.comap T.subtype).map
+      (Submodule.comapSubtypeEquivOfLe hBC : (T : Type _) →ₗ[K] B) = A.comap B.subtype := by
+    ext ⟨b, hb⟩
+    simp only [mem_map, mem_comap, Submodule.coe_subtype, hS]
+    constructor
+    · rintro ⟨⟨⟨x, hxC⟩, hxB⟩, hxA, hxeq⟩
+      have hx : x = b := congrArg Subtype.val hxeq
+      subst hx; exact hxA
+    · intro hbA
+      exact ⟨⟨⟨b, hBC hb⟩, hb⟩, hbA, rfl⟩
+  let e2 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (B ⧸ A.comap B.subtype) :=
+    Submodule.Quotient.equiv _ _ (Submodule.comapSubtypeEquivOfLe hBC) hmap
+  exact e1.symm.trans e2
+
+theorem finrank_quotient_chain {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCB : Module.Finite K (C ⧸ B.comap C.subtype)]
+    [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (C ⧸ A.comap C.subtype) ∧
+      finrank K (C ⧸ A.comap C.subtype)
+        = finrank K (C ⧸ B.comap C.subtype) + finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (T.map S.mkQ : Submodule K _) := Module.Finite.equiv eK.symm
+  have : Module.Finite K ((C ⧸ S) ⧸ T.map S.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (C ⧸ S) := Module.Finite.of_submodule_quotient (T.map S.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+theorem finrank_quotient_chain' {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCA : Module.Finite K (C ⧸ A.comap C.subtype)] :
+    Module.Finite K (C ⧸ B.comap C.subtype) ∧
+      finrank K (C ⧸ B.comap C.subtype)
+        = finrank K (C ⧸ A.comap C.subtype) - finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (C ⧸ T) := Module.Finite.equiv e3
+  refine ⟨this, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+def adeleBddQuotSingleEquivResidueField (D : Divisor K F) (P : Place K F) :
+    (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+      ≃ₗ[K] P.ResidueField := by
+  classical
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  let π : P.toValuationSubring :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose
+  have hπ : Irreducible π :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose_spec
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := fun {g} hg => by
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ α : Place K F → F, α ∈ adeleBdd D → t ^ (D P) * α P ∈ P.toValuationSubring := by
+    intro α hα
+    rcases eq_or_ne (α P) 0 with hg0 | hg0
+    · simp [hg0]
+    · refine P.mem_of_ord_nonneg (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have h := hα P
+      rw [P.adicValuation_eq_exp_neg_ord hg0, WithZero.exp_le_exp] at h
+      linarith
+  let ψ : adeleBdd D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun α => ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩
+      map_add' := by
+        intro α β; apply Subtype.ext
+        simp only [Submodule.coe_add, Pi.add_apply]
+        push_cast; ring
+      map_smul' := by
+        intro c α; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap, Pi.smul_apply]
+        ring }
+  have hψ_apply : ∀ α : adeleBdd D,
+      (ψ α : F) = t ^ (D P) * (α : Place K F → F) P := fun α => rfl
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : adeleBdd D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ α : adeleBdd D, φ α = 0 ↔
+      (⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := fun α => by
+    rw [show φ α = IsLocalRing.residue P.toValuationSubring
+            ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ from hres (ψ α),
+      IsLocalRing.residue_eq_zero_iff]
+  have hker : LinearMap.ker φ = (adeleBdd E).comap (adeleBdd D).subtype := by
+    ext α
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi α, P.mk_mem_maximalIdeal_iff, mem_adeleBdd]
+    have hαD := α.2
+    constructor
+    · rintro (h | h) v
+      · have hα0 : (α : Place K F → F) P = 0 := by
+          rcases mul_eq_zero.mp h with h' | h'
+          · exact absurd h' htn0
+          · exact h'
+        by_cases hv : v = P
+        · subst v; rw [hα0, Valuation.map_zero]; exact zero_le
+        · rw [hEv v hv]; exact hαD v
+      · by_cases hv : v = P
+        · subst v
+          rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+          · rw [hα0, Valuation.map_zero]; exact zero_le
+          · rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP]
+            rw [hordmul hα0] at h; omega
+        · rw [hEv v hv]; exact hαD v
+    · intro h
+      rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+      · left; rw [hα0, mul_zero]
+      · right
+        have hP := h P
+        rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP] at hP
+        rw [hordmul hα0]; omega
+  have hsurj : Function.Surjective φ := by
+    intro c
+    obtain ⟨cl, hcl⟩ := IsLocalRing.residue_surjective (R := P.toValuationSubring) c
+    set f : F := (cl : F) * t ^ (-(D P)) with hf
+    have hαD : Pi.single P f ∈ adeleBdd D := by
+      intro v
+      by_cases hv : v = P
+      · subst v
+        simp only [Pi.single_eq_same]
+        rcases eq_or_ne (cl : F) 0 with hc0 | hc0
+        · rw [hf, hc0, zero_mul, Valuation.map_zero]; exact zero_le
+        · have hf0 : f ≠ 0 := by rw [hf]; exact mul_ne_zero hc0 (zpow_ne_zero _ ht0)
+          rw [P.adicValuation_eq_exp_neg_ord hf0, WithZero.exp_le_exp]
+          rw [hf, P.ord_mul hc0 (zpow_ne_zero _ ht0), P.ord_zpow, ht1, mul_one]
+          have hclnn := P.ord_nonneg_of_mem cl.2
+          linarith
+      · rw [Pi.single_eq_of_ne hv, Valuation.map_zero]; exact zero_le
+    refine ⟨⟨Pi.single P f, hαD⟩, ?_⟩
+    change res (ψ ⟨Pi.single P f, hαD⟩) = c
+    rw [hres]
+    rw [show (ψ ⟨Pi.single P f, hαD⟩ : P.toValuationSubring) = cl from ?_, hcl]
+    apply Subtype.ext
+    rw [hψ_apply]
+    change t ^ (D P) * (Pi.single P f : Place K F → F) P = (cl : F)
+    rw [show (Pi.single P f : Place K F → F) P = f from Pi.single_eq_same _ _, hf,
+      mul_comm (cl : F), ← mul_assoc, ← zpow_add₀ ht0, add_neg_cancel, zpow_zero, one_mul]
+  exact (Submodule.Quotient.equiv _ _ (LinearEquiv.refl K _) (by rw [← hker]; simp)).trans
+    (φ.quotKerEquivOfSurjective hsurj)
+
+theorem finrank_adeleBdd_quotient_single [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    Module.Finite K
+        (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype) ∧
+      finrank K
+          (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+        = P.deg := by
+  have := IsCurveOver.finite_residueField (K := K) P
+  exact ⟨Module.Finite.equiv (adeleBddQuotSingleEquivResidueField D P).symm,
+    (adeleBddQuotSingleEquivResidueField D P).finrank_eq⟩
+
+theorem finrank_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+      (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+        = Divisor.degree D₂ - Divisor.degree D₁ := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D₁ D₂ : Divisor K F, D₁ ≤ D₂ →
+      (Divisor.degree (D₂ - D₁)).toNat = m →
+      Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+        (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+          = Divisor.degree D₂ - Divisor.degree D₁ from
+    H _ D₁ D₂ hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D₁ D₂ hD hm
+    have hEeff : ∀ v, 0 ≤ (D₂ - D₁) v := fun v => by
+      rw [Finsupp.sub_apply]; have := hD v; omega
+    by_cases hD0 : D₂ - D₁ = 0
+    · have hD12 : D₁ = D₂ := (sub_eq_zero.mp hD0).symm
+      subst hD12
+      rw [Submodule.comap_subtype_self]
+      have : Subsingleton (adeleBdd D₁ ⧸ (⊤ : Submodule K (adeleBdd D₁))) :=
+        Submodule.Quotient.subsingleton_iff.mpr rfl
+      exact ⟨Module.Finite.of_finite, by simp [Module.finrank_zero_of_subsingleton]⟩
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ (D₂ - D₁) P := by
+        have hne : (D₂ - D₁) P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hEeff P; omega
+      set D₂' : Divisor K F := D₂ - Finsupp.single P 1 with hD₂'
+      have h12' : D₁ ≤ D₂' := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]
+          have := hPpos; rw [Finsupp.sub_apply] at this; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have h2'2 : D₂' ≤ D₂ := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]
+      have hdegD₂' : Divisor.degree D₂' = Divisor.degree D₂ - P.deg := by
+        rw [hD₂', map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hEnn : 0 ≤ Divisor.degree (D₂ - D₁) := Divisor.degree_nonneg_of_nonneg hEeff
+      have hE'nn : 0 ≤ Divisor.degree (D₂' - D₁) := Divisor.degree_nonneg_of_nonneg
+        (fun v => by rw [Finsupp.sub_apply]; have := h12' v; omega)
+      have hdegdiff : Divisor.degree (D₂' - D₁) = Divisor.degree (D₂ - D₁) - P.deg := by
+        simp only [hD₂', map_sub, Divisor.degree_single, one_mul]; ring
+      have hmlt : (Divisor.degree (D₂' - D₁)).toNat < m := by rw [← hm]; omega
+      obtain ⟨hfin', hrank'⟩ := IH _ hmlt D₁ D₂' h12' rfl
+      obtain ⟨hfinS, hrankS⟩ := finrank_adeleBdd_quotient_single (K := K) D₂ P
+      rw [← hD₂'] at hfinS hrankS
+      have := hfin'; have := hfinS
+      obtain ⟨hfin, hrank⟩ := Submodule.finrank_quotient_chain
+        (A := adeleBdd D₁) (B := adeleBdd D₂') (C := adeleBdd D₂)
+        (adeleBdd_mono h12') (adeleBdd_mono h2'2)
+      refine ⟨hfin, ?_⟩
+      rw [hrank, hrankS]
+      push_cast
+      linarith [hrank', hdegD₂']
+
+theorem module_finite_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  (finrank_adeleBdd_quotient hD).1
+
+theorem finrank_adeleBdd_quotient_eq [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+      = Divisor.degree D₂ - Divisor.degree D₁ :=
+  (finrank_adeleBdd_quotient hD).2
+
+def lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (_hD : D₁ ≤ D₂) :
+    (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      →ₗ[K] (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  Submodule.mapQ _ _
+    ((diagonalHom K F).restrict
+      (p := (LSpace D₂ : Submodule K F)) (q := (adeleBdd D₂ : Submodule K _))
+      (fun f hf => diagonal_mem_adeleBdd_iff.mpr hf))
+    (fun f hf => by
+      simp only [Submodule.mem_comap, Submodule.coe_subtype] at hf ⊢
+      exact diagonal_mem_adeleBdd_iff.mpr hf)
+
+theorem lSpaceQuotientToAdeleBddQuotient_injective {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Function.Injective (lSpaceQuotientToAdeleBddQuotient hD) := by
+  rw [injective_iff_map_eq_zero]
+  intro x hx
+  obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+  rw [Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype]
+  rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk f)
+        = Submodule.Quotient.mk ((diagonalHom K F).restrict
+            (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f) from rfl,
+    Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype] at hx
+  exact diagonal_mem_adeleBdd_iff.mp hx
+
+
+theorem ell_sub_ell_le_degree_sub_degree [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)] :
+    (ell D₂ : ℤ) - (ell D₁ : ℤ) ≤ Divisor.degree D₂ - Divisor.degree D₁ := by
+  have := module_finite_adeleBdd_quotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    rw [hℓ₁]; exact (Submodule.finrank_quotient_add_finrank _).symm
+  have hemb : finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      ≤ finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+    LinearMap.finrank_le_finrank_of_injective (lSpaceQuotientToAdeleBddQuotient_injective hD)
+  have hloc := finrank_adeleBdd_quotient_eq hD
+  have : (ell D₂ : ℤ) - (ell D₁ : ℤ)
+      = (finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) : ℤ) := by
+    rw [hL]; push_cast; ring
+  rw [this, ← hloc]
+  exact_mod_cast hemb
+
+theorem adeleBdd_inf_sup_globalSub {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F)
+      = adeleBdd D₁ ⊔ adeleBdd D₂ ⊓ globalSub K F := by
+  rw [inf_comm, sup_inf_assoc_of_le _ (adeleBdd_mono hD), inf_comm]
+
+theorem map_diagonal_lSpace_inf_adeleBdd {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (LSpace D₂).map (diagonalHom K F) ⊓ adeleBdd D₁ = (LSpace D₁).map (diagonalHom K F) := by
+  rw [map_diagonal_lSpace, map_diagonal_lSpace, inf_right_comm,
+    inf_eq_right.mpr (adeleBdd_mono hD)]
+
+theorem gate_finrank_adeleBdd_quotient_single_point [IsCurveOver K F] (P : Place K F) :
+    (finrank K (adeleBdd (Finsupp.single P 1 : Divisor K F)
+        ⧸ (adeleBdd (0 : Divisor K F)).comap (adeleBdd (Finsupp.single P 1)).subtype) : ℤ)
+      = (P.deg : ℤ) := by
+  classical
+  have h01 : (0 : Divisor K F) ≤ Finsupp.single P 1 := by
+    intro v; rw [Finsupp.zero_apply, Finsupp.single_apply]; split_ifs <;> omega
+  have h := finrank_adeleBdd_quotient_eq (K := K) h01
+  rw [h, map_zero, sub_zero, Divisor.degree_single, one_mul]
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion mk mem_bot subtype_injective \
+  Quotient.subsingleton_iff Quotient.mk restrictScalars inclusion_injective comapSubtypeEquivOfLe \
+  mem_comap finrank_quotient_add_finrank mem_top Quotient.equiv mkQ mem_map coe_subtype map_smul' \
+  zero one quotientQuotientEquivQuotient coe_eq_zero finrank_le range_subtype \
+  Quotient.mk_surjective map mem_inf mem_sup Quotient.mk_eq_zero topEquiv \
+  map_injective_of_injective comap_subtype_self mapQ subsingleton_iff module smul_def mk_eq_zero \
+  coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono map_sup"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+theorem comap_subtype_sup_of_le_of_le {S T C : Submodule K X} (hS : S ≤ C) (hT : T ≤ C) :
+    S.comap C.subtype ⊔ T.comap C.subtype = (S ⊔ T).comap C.subtype := by
+  apply Submodule.map_injective_of_injective (f := C.subtype) C.subtype_injective
+  rw [Submodule.map_sup, Submodule.map_comap_subtype, Submodule.map_comap_subtype,
+    Submodule.map_comap_subtype, inf_eq_right.mpr hS, inf_eq_right.mpr hT,
+    inf_eq_right.mpr (sup_le hS hT)]
+
+theorem finrank_quotient_chain_top {M : Type*} [AddCommGroup M] [Module K M]
+    {A B : Submodule K M} (hAB : A ≤ B)
+    [hMB : Module.Finite K (M ⧸ B)] [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (M ⧸ A) ∧
+      finrank K (M ⧸ A) = finrank K (M ⧸ B) + finrank K (B ⧸ A.comap B.subtype) := by
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  let ψ : (B : Type _) →ₗ[K] (M ⧸ A) := A.mkQ ∘ₗ B.subtype
+  have hker : LinearMap.ker ψ = A.comap B.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = B.map A.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let eK : (B ⧸ A.comap B.subtype) ≃ₗ[K] (B.map A.mkQ : Submodule K (M ⧸ A)) :=
+    (Submodule.quotEquivOfEq _ _ hker.symm).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have : Module.Finite K (B.map A.mkQ : Submodule K (M ⧸ A)) := Module.Finite.equiv eK
+  have : Module.Finite K ((M ⧸ A) ⧸ B.map A.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (M ⧸ A) := Module.Finite.of_submodule_quotient (B.map A.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (B.map A.mkQ)
+  rw [LinearEquiv.finrank_eq e3, ← LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem globalSub_le_adeleSpace [HasPrincipalDivisors K F] :
+    globalSub K F ≤ adeleSpace K F := by
+  rintro _ ⟨f, rfl⟩
+  exact diagonal_mem_adeleSpace f
+
+theorem adeleBdd_sup_globalSub_le_adeleSpace [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+  sup_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_eq_comap [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBddPrincipal K F D = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype :=
+  Submodule.comap_subtype_sup_of_le_of_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_mono {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBddPrincipal K F D₁ ≤ adeleBddPrincipal K F D₂ :=
+  sup_le_sup_right (Submodule.comap_mono (adeleBdd_mono hD)) _
+
+section FiniteLSpace
+
+variable [IsCurveOver K F]
+
+theorem finiteDimensional_lSpace [hL0 : FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (D : Divisor K F) : FiniteDimensional K (LSpace D) := by
+  have h0D : (0 : Divisor K F) ≤ D ⊔ 0 := le_sup_right
+  have hDD : D ≤ D ⊔ 0 := le_sup_left
+  suffices h : FiniteDimensional K (LSpace (D ⊔ 0)) by
+    exact Module.Finite.of_injective (Submodule.inclusion (lSpace_mono hDD))
+      (Submodule.inclusion_injective _)
+  have := module_finite_adeleBdd_quotient (K := K) h0D
+  have hfinQ : FiniteDimensional K
+      (LSpace (D ⊔ 0) ⧸ (LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype) :=
+    Module.Finite.of_injective _ (lSpaceQuotientToAdeleBddQuotient_injective h0D)
+  have : FiniteDimensional K
+      ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype : Submodule K _) :=
+    Module.Finite.equiv (Submodule.comapSubtypeEquivOfLe (lSpace_mono h0D)).symm
+  exact Module.Finite.of_submodule_quotient
+    ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype)
+
+end FiniteLSpace
+
+
+theorem range_lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD)
+      = ((adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype).map
+          ((adeleBdd D₁).comap (adeleBdd D₂).subtype).mkQ := by
+  classical
+  ext z
+  obtain ⟨α, rfl⟩ := Submodule.Quotient.mk_surjective _ z
+  simp only [LinearMap.mem_range, Submodule.mem_map, Submodule.mem_comap, Submodule.coe_subtype,
+    Submodule.mkQ_apply]
+  constructor
+  · rintro ⟨x, hx⟩
+    obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+    have hxeq : Submodule.Quotient.mk
+        ((diagonalHom K F).restrict (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f)
+        = (Submodule.Quotient.mk α :
+            adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) := hx
+    refine ⟨α, ?_, rfl⟩
+    have hdiag2 : (diagonalHom K F (f : F)) ∈ adeleBdd D₂ := diagonal_mem_adeleBdd_iff.mpr f.2
+    have hsub : (α : Place K F → F) - diagonalHom K F (f : F) ∈ adeleBdd D₁ := by
+      have hq := (Submodule.Quotient.eq _).mp hxeq.symm
+      simpa using hq
+    refine Submodule.mem_sup.mpr ⟨(α : Place K F → F) - diagonalHom K F (f : F), hsub,
+      diagonalHom K F (f : F), diagonal_mem_globalSub _, ?_⟩
+    abel
+  · rintro ⟨β, hβ, hβeq⟩
+    have hβ' : (β : Place K F → F) ∈ adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F) :=
+      Submodule.mem_inf.mpr ⟨β.2, hβ⟩
+    rw [adeleBdd_inf_sup_globalSub hD, ← map_diagonal_lSpace] at hβ'
+    obtain ⟨γ, hγ, δ, ⟨f, hf, hfδ⟩, hsum⟩ := Submodule.mem_sup.mp hβ'
+    refine ⟨Submodule.Quotient.mk ⟨f, hf⟩, ?_⟩
+    rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk ⟨f, hf⟩)
+          = Submodule.Quotient.mk ((diagonalHom K F).restrict
+              (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) ⟨f, hf⟩) from rfl,
+      ← hβeq, Submodule.Quotient.eq]
+    refine Submodule.mem_comap.mpr ?_
+    change diagonalHom K F f - (β : Place K F → F) ∈ adeleBdd D₁
+    have hβsub : diagonalHom K F f - (β : Place K F → F) = -γ := by
+      rw [← hsum, hfδ]; ring
+    rw [hβsub]; exact (adeleBdd D₁).neg_mem hγ
+
+
+theorem finrank_adeleBddSup_quotient [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) [hL : FiniteDimensional K (LSpace D₂)] :
+    Module.Finite K (↥(adeleBdd D₂ ⊔ globalSub K F)
+        ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) ∧
+      (finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+          ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) : ℤ)
+        = (Divisor.degree D₂ - ell D₂) - (Divisor.degree D₁ - ell D₁) := by
+  classical
+  let A : Submodule K (adeleBdd D₂) := (adeleBdd D₁).comap (adeleBdd D₂).subtype
+  let B : Submodule K (adeleBdd D₂) :=
+    (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype
+  have hAB : A ≤ B := Submodule.comap_mono le_sup_left
+  have hfinA : Module.Finite K (adeleBdd D₂ ⧸ A) := module_finite_adeleBdd_quotient hD
+  have hdimA : (finrank K (adeleBdd D₂ ⧸ A) : ℤ) = Divisor.degree D₂ - Divisor.degree D₁ :=
+    finrank_adeleBdd_quotient_eq hD
+  have hran : LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD) = B.map A.mkQ :=
+    range_lSpaceQuotientToAdeleBddQuotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hdimL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K)
+      ((LSpace D₁).comap (LSpace D₂).subtype)
+    rw [← hℓ₁] at h; exact h.symm
+  have hdimB : ell D₂ = finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) + ell D₁ := by
+    rw [← hran, LinearMap.finrank_range_of_inj
+      (lSpaceQuotientToAdeleBddQuotient_injective hD)]
+    exact hdimL
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  have hfinB : Module.Finite K (adeleBdd D₂ ⧸ B) := Module.Finite.equiv e3
+  have hdim2 : finrank K (adeleBdd D₂ ⧸ A)
+      = finrank K (adeleBdd D₂ ⧸ B) + finrank K (B.map A.mkQ : Submodule K _) := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K) (M := adeleBdd D₂ ⧸ A)
+      (B.map A.mkQ)
+    rw [LinearEquiv.finrank_eq e3] at h; omega
+  have e2 := LinearMap.quotientInfEquivSupQuotient (R := K)
+    (adeleBdd D₂) (adeleBdd D₁ ⊔ globalSub K F)
+  have hsup : adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F) = adeleBdd D₂ ⊔ globalSub K F := by
+    rw [← sup_assoc, sup_eq_left.mpr (adeleBdd_mono hD)]
+  have hB' : (adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype = B := by
+    rw [Submodule.comap_subtype_self, top_inf_eq]
+  let eL : (adeleBdd D₂ ⧸ B) ≃ₗ[K]
+      (adeleBdd D₂ ⧸ ((adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+        (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype)) :=
+    Submodule.quotEquivOfEq _ _ hB'.symm
+  have hfin_iso : Module.Finite K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype) :=
+    Module.Finite.equiv (eL.trans e2)
+  have hdim_iso : finrank K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype)
+      = finrank K (adeleBdd D₂ ⧸ B) :=
+    (LinearEquiv.finrank_eq (eL.trans e2)).symm
+  have hcast : (finrank K (adeleBdd D₂ ⧸ A) : ℤ)
+      = (finrank K (adeleBdd D₂ ⧸ B) : ℤ) + ((ell D₂ : ℤ) - (ell D₁ : ℤ)) := by
+    have hb : (ell D₂ : ℤ)
+        = (finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) : ℤ) + (ell D₁ : ℤ) := by
+      exact_mod_cast hdimB
+    push_cast [hdim2]; linarith
+  have hgoal : (finrank K (adeleBdd D₂ ⧸ B) : ℤ)
+      = Divisor.degree D₂ - ↑(ell D₂) - (Divisor.degree D₁ - ↑(ell D₁)) := by
+    linarith [hdimA, hcast]
+  clear_value eL
+  exact hsup ▸ ⟨hfin_iso, by rw [hdim_iso]; exact hgoal⟩
+
+section Index
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+
+theorem adeleBddSup_eq_of_degree_sub_ell_eq {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)]
+    (heq : Divisor.degree D₂ - ell D₂ = Divisor.degree D₁ - ell D₁) :
+    adeleBdd D₂ ⊔ globalSub K F = adeleBdd D₁ ⊔ globalSub K F := by
+  obtain ⟨hfin, hdim⟩ := finrank_adeleBddSup_quotient hD
+  rw [heq, sub_self] at hdim
+  refine le_antisymm ?_ (sup_le_sup_right (adeleBdd_mono hD) _)
+  have := hfin
+  have hd0 : finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) = 0 := by
+    exact_mod_cast hdim
+  have hsub : Subsingleton (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) :=
+    Module.finrank_zero_iff.mp hd0
+  have htop := Submodule.Quotient.subsingleton_iff.mp hsub
+  intro x hx
+  have hxc : (⟨x, hx⟩ : ↥(adeleBdd D₂ ⊔ globalSub K F)) ∈
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype := by
+    rw [htop]; exact Submodule.mem_top
+  exact hxc
+
+end Index
+
+namespace RiemannGenusReachedAt
+p2m_export "AlgebraicCurve.RiemannGenusReachedAt" "finite mk eq isMax"
+end RiemannGenusReachedAt
+namespace RiemannGenusReachedAt
+p2m_open_scoped "AlgebraicCurve.RiemannGenusReachedAt" in
+private theorem _root_.AlgebraicCurve.RiemannGenusReachedAt.eq_of_ge [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {D : Divisor K F} (hD : D₀ ≤ D) :
+    Divisor.degree D - ell D = γ - 1 := by
+  have := finiteDimensional_lSpace (K := K) D
+  have hge : Divisor.degree D₀ - (ell D₀ : ℤ) ≤ Divisor.degree D - ell D := by
+    have := ell_sub_ell_le_degree_sub_degree (K := K) hD
+    linarith
+  exact le_antisymm (h.isMax D) (h.eq ▸ hge)
+
+end RiemannGenusReachedAt
+p2m_export "AlgebraicCurve" "RiemannGenusReachedAt.eq_of_ge"
+
+theorem adeleSpace_eq_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    adeleSpace K F = adeleBdd D₀ ⊔ globalSub K F := by
+  refine le_antisymm ?_ (adeleBdd_sup_globalSub_le_adeleSpace D₀)
+  rw [adeleSpace, iSup_le_iff]
+  intro D
+  refine le_trans (adeleBdd_mono (le_sup_left : D ≤ D ⊔ D₀)) ?_
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have heq : Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) = Divisor.degree D₀ - ell D₀ :=
+    (h.eq_of_ge le_sup_right).trans h.eq.symm
+  have hsup := adeleBddSup_eq_of_degree_sub_ell_eq (K := K)
+    (le_sup_right : D₀ ≤ D ⊔ D₀) heq
+  rw [← hsup]
+  exact le_sup_left
+
+theorem indexOfSpecialty_eq_zero_of_genusReached_port [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    indexOfSpecialty D₀ = 0 := by
+  rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap, ← adeleSpace_eq_of_genusReached h,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.finrank_zero_of_subsingleton
+
+
+
+theorem gate_indexOfSpecialty_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  have h1 := (indexOfSpecialty_eq_of_genusReached h D₀).2
+  have h2 := h.eq
+  have h3 := indexOfSpecialty_eq_zero_of_genusReached_port h
+  exact_mod_cast h3
+
+theorem gate_riemannInequality_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Divisor.degree D + 1 - γ ≤ (ell D : ℤ) := by
+  have heq := (indexOfSpecialty_eq_of_genusReached h D).2
+  have hnn : (0 : ℤ) ≤ indexOfSpecialty D := Int.natCast_nonneg _
+  linarith
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_indexOfSpecialty_eq_zero_of_genusReached.AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K ↥(LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    indexOfSpecialty D₀ = 0 :=
+  AlgebraicCurve.indexOfSpecialty_eq_zero_of_genusReached_port (K := K) (F := F) (γ := γ) (D₀ := D₀)
+    (h := h)
+
+end S_AlgebraicCurve_indexOfSpecialty_eq_zero_of_genusReached
+end P2MW
+export P2MW.S_AlgebraicCurve_indexOfSpecialty_eq_zero_of_genusReached (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace AlgebraicCurve
+theorem indexOfSpecialty_eq_zero_of_genusReached {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [IsCurveOver K F] [Nonempty (Place K F)] [FiniteDimensional K ↥(LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    indexOfSpecialty D₀ = 0 :=
+  solution h
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_instIsCurveOverRatFunc.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_instIsCurveOverRatFunc.lean
new file mode 100644
index 0000000000..e13082b9b8
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_instIsCurveOverRatFunc.lean
@@ -0,0 +1,229 @@
+/-
+Based on Prove2Me node AlgebraicCurve.instIsCurveOverRatFunc
+(af5771e7-2a3e-5ee1-882a-27f33bb8eb3e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2e277df9-23df-5248-a593-e0806acb6186
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import Mathlib.RingTheory.Etale.Kaehler
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_placeInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_hasPrincipalDivisors
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The rational function field K(X) is a curve over K
+
+Theorem statement: `AlgebraicCurve.instIsCurveOverRatFunc` (`af5771e7-2a3e-5ee1-882a-27f33bb8eb3e`),
+by Claude, 2026-09-05.
+
+Proof: submission `2e277df9-23df-5248-a593-e0806acb6186`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+For an arbitrary field $K$, the extension $K \subseteq K(X)$, with $K(X)$ the field `RatFunc K` of
+rational functions in one variable, satisfies the project's predicate [`AlgebraicCurve.IsCurveOver K
+(RatFunc K)`](def/AlgebraicCurve_IsCurveOver.html#L15). Unfolding the class, this asserts three
+things. First, the extension has principal divisors: for every nonzero $f \in K(X)$ there is a
+divisor $D$ on $K(X)/K$ whose value at each place $v$ equals $v.\mathrm{ord}\, f$, the order of $f$
+at $v$, and whose degree is $0$. Here a place of $K(X)/K$ is a valuation subring of $K(X)$ that
+contains the image of $K$, is not all of $K(X)$, and is a principal ideal ring. Second, residue
+fields are finite over the base: for every such place $v$, the residue field of the local ring $v$
+is a finite-dimensional $K$-module. Third, the module of Kähler differentials $\Omega_{K(X)/K}$ is
+free as a $K(X)$-module and its rank over $K(X)$ is $1$. Since `IsCurveOver` is a `Prop`-valued
+class, the statement is available as an instance for $K(X)$ over any field $K$.
+
+This is the statement that the rational function field, the function field of $\mathbb{P}^1_K$, is a
+curve over $K$ in the sense used throughout this development, with $\Omega_{K(X)/K} = K(X)\,dX$ and
+$\deg(f) = 0$ for principal divisors. It discharges the `IsCurveOver K (RatFunc K)` hypothesis in
+the $\mathbb{P}^1$ computations downstream, among them the determination of a canonical divisor and
+of the genus of $K(X)$, and the Riemann–Roch statements applied to the rational function field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_instIsCurveOverRatFunc.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_instIsCurveOverRatFunc
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.FiniteResidue HasPrincipalDivisors \
+  Place.ofHeightOneSpectrum Place.FiniteResidue.finite RationalFunctionField.hasPrincipalDivisors"
+p2m_open "AlgebraicCurve"
+
+scoped instance instHasPrincipalDivisorsRatFuncLaneB (K : Type*) [Field K] : HasPrincipalDivisors K
+  (RatFunc K) :=
+  RationalFunctionField.hasPrincipalDivisors K
+end AlgebraicCurve
+
+section
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing
+open scoped Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.FiniteResidue HasPrincipalDivisors \
+  Place.ofHeightOneSpectrum Place.FiniteResidue.finite RationalFunctionField.hasPrincipalDivisors"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ResidueField deg FiniteResidue ofHeightOneSpectrum \
+  FiniteResidue.finite"
+p2m_open "AlgebraicCurve.Place"
+
+section DegPos
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+theorem finiteResidue_of_deg_pos (h : 0 < v.deg) : v.FiniteResidue :=
+  ⟨Module.finite_of_finrank_pos h⟩
+end DegPos
+end Place
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "exists_irreducible_span deg_ofHeightOneSpectrum \
+  placeInfty eq_ofHeightOneSpectrum_or_eq_placeInfty deg_placeInfty hasPrincipalDivisors"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+variable (K : Type*) [Field K]
+
+scoped instance instFiniteResidueOfHeightOneSpectrum (w : HeightOneSpectrum K[X]) :
+    (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).FiniteResidue := by
+  obtain ⟨p, hp, hw⟩ := exists_irreducible_span K w
+  refine Place.finiteResidue_of_deg_pos _ ?_
+  rw [deg_ofHeightOneSpectrum K hw]
+  exact hp.natDegree_pos
+
+scoped instance instFiniteResiduePlaceInfty [DecidableEq (RatFunc K)] :
+    (placeInfty K).FiniteResidue :=
+  Place.finiteResidue_of_deg_pos _ (by rw [deg_placeInfty K]; exact one_pos)
+
+variable {K} in
+scoped instance instFiniteResidue (v : Place K (RatFunc K)) : v.FiniteResidue := by
+  classical
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+  · exact instFiniteResidueOfHeightOneSpectrum K w
+  · exact instFiniteResiduePlaceInfty K
+
+end RationalFunctionField
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ResidueField deg FiniteResidue ofHeightOneSpectrum \
+  FiniteResidue.finite"
+end Place
+end AlgebraicCurve
+end
+
+section
+
+noncomputable section
+
+open KaehlerDifferential
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.FiniteResidue HasPrincipalDivisors \
+  Place.ofHeightOneSpectrum Place.FiniteResidue.finite RationalFunctionField.hasPrincipalDivisors"
+p2m_open "AlgebraicCurve"
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def KaehlerRankOne : Prop :=
+  Module.Free F Ω[F⁄K] ∧ Module.finrank F Ω[F⁄K] = 1
+
+variable {K F}
+namespace IsCurveOver
+p2m_export "AlgebraicCurve.IsCurveOver" "hasPrincipalDivisors instFiniteResidue finiteResidue \
+  kaehler_free_rank_one"
+end IsCurveOver
+p2m_open_scoped "AlgebraicCurve.IsCurveOver" in
+theorem IsCurveOver.of_finiteResidue_of_kaehlerRankOne
+    [HasPrincipalDivisors K F] [∀ v : Place K F, v.FiniteResidue]
+    (hΩ : KaehlerRankOne K F) : IsCurveOver K F where
+  finiteResidue v := Place.FiniteResidue.finite (v := v)
+  kaehler_free_rank_one := hΩ
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "exists_irreducible_span deg_ofHeightOneSpectrum \
+  placeInfty eq_ofHeightOneSpectrum_or_eq_placeInfty deg_placeInfty hasPrincipalDivisors"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable (K : Type*) [Field K]
+
+theorem isCurveOver_of_kaehlerRankOne (hΩ : KaehlerRankOne K (RatFunc K)) :
+    IsCurveOver K (RatFunc K) :=
+  IsCurveOver.of_finiteResidue_of_kaehlerRankOne hΩ
+end RationalFunctionField
+end AlgebraicCurve
+end
+
+section
+
+noncomputable section
+
+p2m_open "IntermediateField AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_instIsCurveOverRatFunc.AlgebraicCurve Polynomial TensorProduct Module"
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.FiniteResidue HasPrincipalDivisors \
+  Place.ofHeightOneSpectrum Place.FiniteResidue.finite RationalFunctionField.hasPrincipalDivisors"
+p2m_open "AlgebraicCurve"
+
+variable (K : Type*) [Field K]
+
+def kaehlerPolynomialBasis : Basis Unit K[X] Ω[K[X]⁄K] :=
+  (Basis.singleton Unit K[X]).map (KaehlerDifferential.polynomialEquiv K).symm
+
+scoped instance instFormallyEtalePolynomialRatFunc : Algebra.FormallyEtale K[X] (RatFunc K) :=
+  Algebra.FormallyEtale.of_isLocalization (nonZeroDivisors K[X])
+
+def kaehlerRatFuncBasis : Basis Unit (RatFunc K) Ω[(RatFunc K)⁄K] :=
+  ((kaehlerPolynomialBasis K).baseChange (RatFunc K)).map
+    (KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale K K[X] (RatFunc K))
+
+theorem kaehlerRankOne_ratFunc : KaehlerRankOne K (RatFunc K) :=
+  ⟨Module.Free.of_basis (kaehlerRatFuncBasis K),
+    (Module.finrank_eq_card_basis (kaehlerRatFuncBasis K)).trans (by simp)⟩
+
+scoped instance instIsCurveOverRatFunc : IsCurveOver K (RatFunc K) :=
+  RationalFunctionField.isCurveOver_of_kaehlerRankOne K (kaehlerRankOne_ratFunc K)
+
+end AlgebraicCurve
+end
+
+theorem solution (K : Type*) [Field K] : AlgebraicCurve.IsCurveOver K (RatFunc K) :=
+  AlgebraicCurve.instIsCurveOverRatFunc K
+
+end
+end
+end
+end S_AlgebraicCurve_instIsCurveOverRatFunc
+end P2MW
+export P2MW.S_AlgebraicCurve_instIsCurveOverRatFunc (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.instIsCurveOverRatFunc (K : Type*) [Field K] :
+    AlgebraicCurve.IsCurveOver K (RatFunc K) :=
+  solution K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isAlgebraic_adjoin_of_transcendental.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isAlgebraic_adjoin_of_transcendental.lean
new file mode 100644
index 0000000000..52c25982a1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isAlgebraic_adjoin_of_transcendental.lean
@@ -0,0 +1,122 @@
+/-
+Based on Prove2Me node AlgebraicCurve.isAlgebraic_adjoin_of_transcendental
+(60dc6137-b64d-585a-9250-eab23c0a5809) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4ad059e0-b94e-59d0-8eee-547b3ce24372
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Defs
+public import Mathlib.RingTheory.Algebraic.Defs
+
+import Mathlib.RingTheory.AlgebraicIndependent.TranscendenceBasis
+import Mathlib.RingTheory.AlgebraicIndependent.Transcendental
+import Mathlib.RingTheory.AlgebraicIndependent.AlgebraicClosure
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+import Mathlib.LinearAlgebra.Dimension.FreeAndStrongRankCondition
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Transcendence degree one: F algebraic over K(t) for any transcendental t
+
+Theorem statement: `AlgebraicCurve.isAlgebraic_adjoin_of_transcendental`
+(`60dc6137-b64d-585a-9250-eab23c0a5809`), by Claude, 2026-09-05.
+
+Proof: submission `4ad059e0-b94e-59d0-8eee-547b3ce24372`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $x \in F$ be an element such that $F$ is
+algebraic over the intermediate field $K(x) =$ `IntermediateField.adjoin K {x}` generated by $x$
+over $K$ inside $F$. Let $t \in F$ be transcendental over $K$, i.e. $t$ is not a root of any nonzero
+polynomial over $K$ (`Transcendental K t`). The conclusion is that $F$ is algebraic over the
+intermediate field $K(t) =$ `IntermediateField.adjoin K {t}`: every element of $F$ satisfies a
+nonzero polynomial with coefficients in $K(t)$. No hypothesis of transcendence on $x$ is imposed;
+the two hypotheses together force $x$ to be transcendental over $K$, since otherwise $F$ would be
+algebraic over $K$ and no transcendental $t$ could exist. No assumption is made on the
+characteristic of $K$, and $t$ is not assumed to lie in $K(x)$ or to be related to $x$ in any way.
+
+This is the statement that in an extension of transcendence degree one every element transcendental
+over the base generates a subfield over which the whole extension is algebraic; it is the standard
+device for replacing a fixed coordinate $x$ of a function field of one variable by an arbitrary
+uniformiser. It is used throughout the treatment of places and differentials of algebraic curves,
+for instance in the lemmas on orders and differential coefficients at a place.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_isAlgebraic_adjoin_of_transcendental.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_isAlgebraic_adjoin_of_transcendental
+
+open Set Cardinal
+
+namespace AlgebraicCurve
+namespace FF2KE3
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem isAlgebraic_adjoin_of_transcendental' (x : F)
+    [halg : Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+    {t : F} (ht : Transcendental K t) :
+    Algebra.IsAlgebraic (IntermediateField.adjoin K ({t} : Set F)) F := by
+  have hx : Transcendental K x := by
+    intro hxalg
+    have : Algebra.IsAlgebraic K (IntermediateField.adjoin K ({x} : Set F)) :=
+      IntermediateField.isAlgebraic_adjoin_simple hxalg.isIntegral
+    have : Algebra.IsAlgebraic K F :=
+      Algebra.IsAlgebraic.trans K (IntermediateField.adjoin K ({x} : Set F)) F
+    exact ht (Algebra.IsAlgebraic.isAlgebraic t)
+  have hbx : IsTranscendenceBasis K ![x] := by
+    rw [isTranscendenceBasis_iff_algebraicIndependent_isAlgebraic]
+    refine ⟨algebraicIndependent_iff_transcendental.mpr hx, ?_⟩
+    have : Set.range ![x] = {x} := by simp
+    rw [this]
+    exact (IntermediateField.isAlgebraic_adjoin_iff_top (F := K) (s := ({x} : Set F))).mp halg
+  have hind : AlgebraicIndepOn K id ({t} : Set F) := by
+    rw [AlgebraicIndepOn, algebraicIndependent_unique_type_iff]
+    simpa using ht
+  obtain ⟨S, htS, hS⟩ := exists_isTranscendenceBasis_superset hind
+  have hcard := hS.lift_cardinalMk_eq hbx
+  simp only [Cardinal.mk_fin, Nat.cast_one, Cardinal.lift_one, Cardinal.lift_eq_one] at hcard
+  have hS_eq : S = {t} :=
+    (Cardinal.mk_le_one_iff_set_subsingleton.mp hcard.le).eq_singleton_of_mem (htS rfl)
+  subst hS_eq
+  have h := hS.isAlgebraic_field
+  rwa [Subtype.range_coe] at h
+
+end AlgebraicCurve.FF2KE3
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F] {t : F}
+    (ht : Transcendental K t) :
+    Algebra.IsAlgebraic (IntermediateField.adjoin K ({t} : Set F)) F :=
+  AlgebraicCurve.FF2KE3.isAlgebraic_adjoin_of_transcendental' x ht
+
+end S_AlgebraicCurve_isAlgebraic_adjoin_of_transcendental
+end P2MW
+export P2MW.S_AlgebraicCurve_isAlgebraic_adjoin_of_transcendental (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.isAlgebraic_adjoin_of_transcendental {K F : Type*} [Field K] [Field F]
+    [Algebra K F] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F] {t : F}
+    (ht : Transcendental K t) :
+    Algebra.IsAlgebraic (IntermediateField.adjoin K ({t} : Set F)) F :=
+  solution x ht
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isCurveOver_iff_exists_transcendental_finiteDimensional.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isCurveOver_iff_exists_transcendental_finiteDimensional.lean
new file mode 100644
index 0000000000..58e89ac36a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isCurveOver_iff_exists_transcendental_finiteDimensional.lean
@@ -0,0 +1,94 @@
+/-
+Based on Prove2Me node AlgebraicCurve.isCurveOver_iff_exists_transcendental_finiteDimensional
+(d5b52715-a2a2-5fe1-8341-a08704a2c81a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 70115869-095f-5456-8236-35d6c07c8b72
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_IsCurveOver_exists_separating_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_transcendental
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Curves over a perfect field: separating transcendence element
+
+Theorem statement: `AlgebraicCurve.isCurveOver_iff_exists_transcendental_finiteDimensional`
+(`d5b52715-a2a2-5fe1-8341-a08704a2c81a`), by Claude, 2026-09-05.
+
+Proof: submission `70115869-095f-5456-8236-35d6c07c8b72`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, assume $K$ is perfect and that $F$ is essentially
+of finite type over $K$. The theorem asserts the equivalence of two conditions. The first is the
+predicate `IsCurveOver K F`, which bundles three requirements: (i) every nonzero $f \in F$ has a
+principal divisor, i.e. there is a divisor $D$ on $F/K$ with $D(v) = \operatorname{ord}_v(f)$ at
+every place $v$ and $\deg D = 0$, where a place of $F/K$ is a valuation subring of $F$ containing
+the image of $K$, distinct from $F$ itself, and a principal ideal ring; (ii) for every such place
+$v$ the residue field of that valuation subring is a finite $K$-module; and (iii) the module of
+Kähler differentials $\Omega_{F/K}$ is free of rank $1$ over $F$. The second condition is the
+existence of an element $t \in F$ that is transcendental over $K$ and such that $F$ is
+finite-dimensional and separable over the intermediate field $K\langle t\rangle$ generated by $t$.
+
+This is the standard characterisation of a function field of one variable over a perfect base field
+by the existence of a separating transcendence element, here phrased in terms of the project's
+notion `IsCurveOver`. It serves as the working criterion by which the curve axioms are verified or
+used in the subsequent theory of places, divisors and the divisor class group, and is cited widely
+in that development.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_isCurveOver_iff_exists_transcendental_finiteDimensional.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_isCurveOver_iff_exists_transcendental_finiteDimensional
+
+
+open IntermediateField Algebra
+
+theorem solution {K : Type*} {F : Type*} [Field K] [Field F] [Algebra K F]
+    [PerfectField K] [Algebra.EssFiniteType K F] :
+    AlgebraicCurve.IsCurveOver K F ↔ ∃ t : F, Transcendental K t ∧ FiniteDimensional K⟮t⟯ F ∧
+      Algebra.IsSeparable K⟮t⟯ F := by
+  constructor
+  · intro h
+    exact AlgebraicCurve.IsCurveOver.exists_separating_transcendental
+  · rintro ⟨t, htr, hfd, hsep⟩
+    exact AlgebraicCurve.isCurveOver_of_transcendental htr hfd hsep
+
+end S_AlgebraicCurve_isCurveOver_iff_exists_transcendental_finiteDimensional
+end P2MW
+export P2MW.S_AlgebraicCurve_isCurveOver_iff_exists_transcendental_finiteDimensional (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open IntermediateField Algebra
+
+namespace AlgebraicCurve
+theorem isCurveOver_iff_exists_transcendental_finiteDimensional {K : Type*} {F : Type*} [Field K]
+    [Field F] [Algebra K F]
+    [PerfectField K] [Algebra.EssFiniteType K F] :
+    IsCurveOver K F ↔ ∃ t : F, Transcendental K t ∧ FiniteDimensional K⟮t⟯ F ∧ Algebra.IsSeparable
+      K⟮t⟯ F :=
+  solution
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isCurveOver_of_isAlgClosed_of_transcendental.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isCurveOver_of_isAlgClosed_of_transcendental.lean
new file mode 100644
index 0000000000..ad2443b281
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isCurveOver_of_isAlgClosed_of_transcendental.lean
@@ -0,0 +1,86 @@
+/-
+Based on Prove2Me node AlgebraicCurve.isCurveOver_of_isAlgClosed_of_transcendental
+(803f3b0f-03df-506c-8358-bb1db4e07f86) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 483260d6-7a56-50f7-bf0c-e52019013966
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_transcendental_of_perfectField
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Curve criterion over an algebraically closed base
+
+Theorem statement: `AlgebraicCurve.isCurveOver_of_isAlgClosed_of_transcendental`
+(`803f3b0f-03df-506c-8358-bb1db4e07f86`), by Claude, 2026-09-05.
+
+Proof: submission `483260d6-7a56-50f7-bf0c-e52019013966`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field, let $F$ be a field equipped with a $K$-algebra structure,
+and let $x \in F$ be transcendental over $K$. Assume that $F$ is finite-dimensional as a vector
+space over the intermediate field $K(x)$ obtained by adjoining $x$ to $K$ inside $F$. Then
+`IsCurveOver K F` holds, that is: (i) $F$ has principal divisors over $K$, meaning that for every $f
+\in F$ with $f \neq 0$ there is a divisor $D$ of $F/K$ whose value at each place $v$ equals the
+order $v.\mathrm{ord}\, f$ of $f$ at $v$ and whose degree is $0$, where a place of $F/K$ is a
+valuation subring of $F$ that contains the image of $K$, is different from all of $F$, and is a
+principal ideal ring; (ii) for every such place $v$ the residue field of the corresponding local
+ring is a finite $K$-module; and (iii) the module of Kähler differentials $\Omega[F\!\diagup\!K]$ is
+free over $F$ of rank $1$. Compared with the variant requiring $F$ to be separable over $K(x)$, no
+separability hypothesis is imposed here.
+
+This is the working criterion for recognising a field as the function field of a curve over an
+algebraically closed constant field: a transcendental element with finite residual degree suffices,
+with no separability condition on $F/K(x)$. It supplies the `IsCurveOver` instance in the many later
+developments that need it, for instance when the constant field is the algebraically closed residue
+field of a local ring.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_isCurveOver_of_isAlgClosed_of_transcendental.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_isCurveOver_of_isAlgClosed_of_transcendental
+
+open AlgebraicCurve
+
+theorem solution
+    {K F : Type*} [Field K] [IsAlgClosed K] [Field F] [Algebra K F]
+    (x : F) (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] :
+    IsCurveOver K F := by
+  exact isCurveOver_of_transcendental_of_perfectField hx inferInstance
+
+end S_AlgebraicCurve_isCurveOver_of_isAlgClosed_of_transcendental
+end P2MW
+export P2MW.S_AlgebraicCurve_isCurveOver_of_isAlgClosed_of_transcendental (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.isCurveOver_of_isAlgClosed_of_transcendental
+    {K F : Type*} [Field K] [IsAlgClosed K] [Field F] [Algebra K F]
+    (x : F) (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F] :
+    IsCurveOver K F :=
+  solution x hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isCurveOver_of_transcendental.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isCurveOver_of_transcendental.lean
new file mode 100644
index 0000000000..760bcfcd87
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isCurveOver_of_transcendental.lean
@@ -0,0 +1,125 @@
+/-
+Based on Prove2Me node AlgebraicCurve.isCurveOver_of_transcendental
+(baea3bff-414e-5acc-adc4-353640d4fb58) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e6c09c6c-cfc8-52e6-a2c4-ff356a301f87
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_finite_residueField_of_finiteDimensional
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_hasPrincipalDivisors_of_transcendental_of_isSeparable
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_instIsCurveOverRatFunc
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_kaehlerRankOne_of_transcendental
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finite separable extensions of K(x) are curves over K
+
+Theorem statement: `AlgebraicCurve.isCurveOver_of_transcendental`
+(`baea3bff-414e-5acc-adc4-353640d4fb58`), by Claude, 2026-09-05.
+
+Proof: submission `e6c09c6c-cfc8-52e6-a2c4-ff356a301f87`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $x \in F$ be transcendental over $K$.
+Write $K\langle x\rangle$ for the intermediate field `IntermediateField.adjoin K {x}` generated by
+$x$. Assume $F$ is finite-dimensional over $K\langle x\rangle$ and that the extension $K\langle
+x\rangle \subseteq F$ is separable. Then `IsCurveOver K F` holds, which packages three assertions.
+First, principal divisors have degree zero: for every $f \in F$ with $f \neq 0$ there is a divisor
+$D$ of $F/K$ whose value at each place $v$ is the order $v.\mathrm{ord}\, f$ and whose degree is
+$0$. Second, for every place $v$ of $F/K$ — that is, every valuation subring of $F$ which contains
+the image of $K$, is not all of $F$, and is a principal ideal ring — the residue field of that
+valuation subring is a finite-dimensional $K$-module. Third, the module of Kähler differentials
+$\Omega_{F/K}$ is free as an $F$-module and $\operatorname{rank}_F \Omega_{F/K} = 1$.
+
+This is the arbitrary-characteristic criterion identifying a separably generated function field of
+transcendence degree one as a curve over its base field, in the sense of the project's `IsCurveOver`
+package. It is the standard entry point for supplying that package, and is invoked by the
+divisor-class group and Weil-pairing development built on `IsCurveOver`.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_isCurveOver_of_transcendental.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_isCurveOver_of_transcendental
+
+
+open AlgebraicCurve IntermediateField
+
+theorem solution
+    {K F : Type*} [Field K] [Field F] [Algebra K F]
+    {x : F} (htr : Transcendental K x)
+    (hfd : FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F)
+    (hsep : Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F) :
+    IsCurveOver K F := by
+  have hprin : HasPrincipalDivisors K F :=
+    AlgebraicCurve.hasPrincipalDivisors_of_transcendental_of_isSeparable htr hfd hsep
+  have hkae : Module.Free F Ω[F⁄K] ∧ Module.finrank F Ω[F⁄K] = 1 :=
+    AlgebraicCurve.kaehlerRankOne_of_transcendental htr hsep
+  have hfin : ∀ v : Place K F, Module.Finite K v.ResidueField := by
+    have := hfd
+    have := hsep
+    set e : RatFunc K ≃ₐ[K] K⟮x⟯ := RatFunc.algEquivOfTranscendental x htr with he
+    let : Algebra (RatFunc K) F :=
+      ((algebraMap K⟮x⟯ F).comp e.toAlgHom.toRingHom).toAlgebra
+    have hsq : RingHom.comp (algebraMap (RatFunc K) F)
+          (e.symm.toRingEquiv : K⟮x⟯ →+* RatFunc K)
+        = RingHom.comp (RingEquiv.refl F : F →+* F) (algebraMap K⟮x⟯ F) := by
+      refine RingHom.ext fun a => ?_
+      change algebraMap K⟮x⟯ F (e (e.symm a)) = algebraMap K⟮x⟯ F a
+      rw [e.apply_symm_apply]
+    have : IsScalarTower K (RatFunc K) F :=
+      IsScalarTower.of_algebraMap_eq fun a => by
+        change algebraMap K F a = algebraMap K⟮x⟯ F (e (algebraMap K (RatFunc K) a))
+        rw [e.commutes, ← IsScalarTower.algebraMap_apply]
+    have : FiniteDimensional (RatFunc K) F :=
+      Module.Finite.of_equiv_equiv e.symm.toRingEquiv (RingEquiv.refl F) hsq
+    have : Algebra.IsSeparable (RatFunc K) F :=
+      Algebra.IsSeparable.of_equiv_equiv e.symm.toRingEquiv (RingEquiv.refl F) hsq
+    intro v
+    have h1 : Module.Finite (v.restrict (RatFunc K)).ResidueField v.ResidueField :=
+      Place.finite_residueField_of_finiteDimensional (F := RatFunc K) v
+    have h2 : Module.Finite K (v.restrict (RatFunc K)).ResidueField :=
+      (AlgebraicCurve.instIsCurveOverRatFunc K).finiteResidue _
+    exact Module.Finite.trans (v.restrict (RatFunc K)).ResidueField v.ResidueField
+  exact { toHasPrincipalDivisors := hprin, finiteResidue := hfin, kaehler_free_rank_one := hkae }
+
+end S_AlgebraicCurve_isCurveOver_of_transcendental
+end P2MW
+export P2MW.S_AlgebraicCurve_isCurveOver_of_transcendental (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve IntermediateField
+theorem AlgebraicCurve.isCurveOver_of_transcendental
+    {K F : Type*} [Field K] [Field F] [Algebra K F]
+    {x : F} (htr : Transcendental K x)
+    (hfd : FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F)
+    (hsep : Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F) :
+    IsCurveOver K F :=
+  solution htr hfd hsep
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isCurveOver_of_transcendental_of_isSeparable.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isCurveOver_of_transcendental_of_isSeparable.lean
new file mode 100644
index 0000000000..ccc85a9a8a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isCurveOver_of_transcendental_of_isSeparable.lean
@@ -0,0 +1,86 @@
+/-
+Based on Prove2Me node AlgebraicCurve.isCurveOver_of_transcendental_of_isSeparable
+(ce1046fd-9191-51fc-8f68-39fa53dc2bbf) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d2e37a10-22dd-5391-95a4-790d8b63ea85
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_transcendental
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finite separable extensions of K(x) are curves over K
+
+Theorem statement: `AlgebraicCurve.isCurveOver_of_transcendental_of_isSeparable`
+(`ce1046fd-9191-51fc-8f68-39fa53dc2bbf`), by Claude, 2026-09-05.
+
+Proof: submission `d2e37a10-22dd-5391-95a4-790d8b63ea85`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $x \in F$ be transcendental over $K$, i.e.
+the evaluation map from $K[X]$ to $F$ at $x$ is injective. Assume that $F$ is finite-dimensional
+over the intermediate field $K(x) =$ `IntermediateField.adjoin K {x}` and that the extension
+$F/K(x)$ is separable. Then `IsCurveOver K F` holds, that is: (i) for every $f \in F$ with $f \neq
+0$ there is a divisor $D \in$ `Divisor K F` whose value at every place $v$ of $F/K$ is the order
+$v.\mathrm{ord}\, f$ and whose degree is $0$ (the content of `HasPrincipalDivisors`); (ii) for every
+place $v$ of $F/K$ the residue field of $v$ is a finite-dimensional $K$-module; and (iii) the module
+of Kähler differentials $\Omega_{F/K}$ is a free $F$-module with $\operatorname{finrank}_F
+\Omega_{F/K} = 1$. Here a place of $F/K$ is a valuation subring $\mathcal{O}_v$ of $F$ containing
+the image of $K$, not equal to all of $F$, and whose ideals are all principal.
+
+This is the statement that a field extension generated by a transcendental element together with a
+finite separable extension is the function field of a curve over $K$, in the sense of the axiom
+package `IsCurveOver`: principal divisors of degree zero, finite residue degrees at all places, and
+a one-dimensional space of differentials. It supplies the curve hypothesis for the many later
+results about divisors, Picard groups and Jacobians of such function fields.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_isCurveOver_of_transcendental_of_isSeparable.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_isCurveOver_of_transcendental_of_isSeparable
+
+open AlgebraicCurve
+
+theorem solution (K F : Type*) [Field K] [Field F]
+    [Algebra K F] (x : F) (hx : Transcendental K x)
+    (hfin : FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F)
+    (hsep : Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F) :
+    IsCurveOver K F :=
+  AlgebraicCurve.isCurveOver_of_transcendental hx hfin hsep
+
+end S_AlgebraicCurve_isCurveOver_of_transcendental_of_isSeparable
+end P2MW
+export P2MW.S_AlgebraicCurve_isCurveOver_of_transcendental_of_isSeparable (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.isCurveOver_of_transcendental_of_isSeparable (K F : Type*) [Field K]
+    [Field F]
+    [Algebra K F] (x : F) (hx : Transcendental K x)
+    (hfin : FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F)
+    (hsep : Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F) :
+    IsCurveOver K F :=
+  solution K F x hx hfin hsep
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isCurveOver_of_transcendental_of_perfectField.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isCurveOver_of_transcendental_of_perfectField.lean
new file mode 100644
index 0000000000..e07aa2355e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isCurveOver_of_transcendental_of_perfectField.lean
@@ -0,0 +1,85 @@
+/-
+Based on Prove2Me node AlgebraicCurve.isCurveOver_of_transcendental_of_perfectField
+(e7ba4d46-47a9-5639-b062-3daade338787) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e5622a48-424d-5080-8ff2-a36d7e0c9629
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_separating_transcendental_of_perfectField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_transcendental
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# One-variable function fields over perfect fields are curves
+
+Theorem statement: `AlgebraicCurve.isCurveOver_of_transcendental_of_perfectField`
+(`e7ba4d46-47a9-5639-b062-3daade338787`), by Claude, 2026-09-05.
+
+Proof: submission `e5622a48-424d-5080-8ff2-a36d7e0c9629`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and suppose $K$ is perfect. Assume there is an
+element $x \in F$ transcendental over $K$ such that $F$ is finite-dimensional over the intermediate
+field $K(x)$ obtained by adjoining $x$. The conclusion is that the pair $(K,F)$ satisfies
+[`AlgebraicCurve.IsCurveOver`](def/AlgebraicCurve_IsCurveOver.html#L15), that is: (i) $F/K$ has
+principal divisors, meaning that for every $f \in F$ with $f \neq 0$ there is a divisor $D$ of $F/K$
+whose coefficient at each place $v$ equals $v.\mathrm{ord}\, f$ and whose degree is $0$ — here a
+place of $F/K$ is a valuation subring of $F$ that contains the image of $K$, is not all of $F$, and
+is a principal ideal ring; (ii) for every place $v$ of $F/K$ the residue field of that valuation
+subring is a finite-dimensional $K$-module; and (iii) the module of Kähler differentials
+$\Omega_{F/K}$ is a free $F$-module with $\operatorname{finrank}_F \Omega_{F/K} = 1$. No
+separability assumption on $F$ over $K(x)$ is imposed.
+
+This is the statement that a function field of transcendence degree one over a perfect constant
+field carries the curve package used throughout the project: finiteness of residue degrees,
+existence of degree-zero principal divisors, and a one-dimensional space of differentials. It serves
+as the standard source of `IsCurveOver` instances, and is invoked by the body of results on places,
+regularity, poles and residues built on top of that package.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_isCurveOver_of_transcendental_of_perfectField.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_isCurveOver_of_transcendental_of_perfectField
+
+theorem solution
+    {K F : Type*} [Field K] [Field F] [Algebra K F] [PerfectField K]
+    {x : F} (htr : Transcendental K x)
+    (hfd : FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F) :
+    AlgebraicCurve.IsCurveOver K F := by
+  obtain ⟨t, ht, htfd, htsep⟩ :=
+    AlgebraicCurve.exists_separating_transcendental_of_perfectField htr hfd
+  exact AlgebraicCurve.isCurveOver_of_transcendental ht htfd htsep
+
+end S_AlgebraicCurve_isCurveOver_of_transcendental_of_perfectField
+end P2MW
+export P2MW.S_AlgebraicCurve_isCurveOver_of_transcendental_of_perfectField (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.isCurveOver_of_transcendental_of_perfectField
+    {K F : Type*} [Field K] [Field F] [Algebra K F] [PerfectField K]
+    {x : F} (htr : Transcendental K x)
+    (hfd : FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F) :
+    AlgebraicCurve.IsCurveOver K F :=
+  solution htr hfd
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isCurveOver_ratFunc.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isCurveOver_ratFunc.lean
new file mode 100644
index 0000000000..5d603429d9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isCurveOver_ratFunc.lean
@@ -0,0 +1,639 @@
+/-
+Based on Prove2Me node AlgebraicCurve.isCurveOver_ratFunc
+(60e20b31-f460-5926-b9b9-7aefad8c978d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ea22e155-c067-56f5-9ea1-eb7a4cbe85d5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import Mathlib.RingTheory.DedekindDomain.Factorization
+import Mathlib.RingTheory.Flat.TorsionFree
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The rational function field K(t) is a curve over K
+
+Theorem statement: `AlgebraicCurve.isCurveOver_ratFunc` (`60e20b31-f460-5926-b9b9-7aefad8c978d`), by
+Claude, 2026-09-05.
+
+Proof: submission `ea22e155-c067-56f5-9ea1-eb7a4cbe85d5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+For an arbitrary field $K$, the extension $K \subseteq \mathrm{RatFunc}\,K$ — the field of rational
+functions in one variable over $K$ — satisfies the predicate `IsCurveOver`, i.e. the following three
+conditions hold, where a place of $\mathrm{RatFunc}\,K$ over $K$ means a valuation subring
+$\mathcal{O}_v$ of $\mathrm{RatFunc}\,K$ that contains the image of $K$, is not the whole field, and
+is a principal ideal ring. First, the extension has principal divisors: for every $f \in
+\mathrm{RatFunc}\,K$ with $f \neq 0$ there is a divisor $D$ of $K \subseteq \mathrm{RatFunc}\,K$ (in
+particular a function of finite support in the sense of the project's `Divisor` type) whose value at
+every place $v$ equals the order $\mathrm{ord}_v(f)$ of $f$ at $v$, and whose degree is zero.
+Secondly, for every place $v$ the residue field of $\mathcal{O}_v$, i.e. the quotient by its maximal
+ideal, is a finite-dimensional $K$-module. Thirdly, the module of Kähler differentials
+$\Omega_{\mathrm{RatFunc}\,K / K}$ is a free module over $\mathrm{RatFunc}\,K$ of rank one.
+
+This is the base case — the projective line — of the assertion that a function field of
+transcendence degree one is a curve in the sense of the project's axiomatisation, and it provides
+the class instance used whenever the rational function field is treated as a curve. It is invoked in
+the project's divisor and differential theory, for instance in the results on divisor classes and on
+genus-zero function fields.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_isCurveOver_ratFunc.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_isCurveOver_ratFunc
+
+set_option linter.style.longFile 0
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing
+open scoped Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.deg Divisor Divisor.degree \
+  Divisor.degree_single Divisor.degZero Divisor.principal HasPrincipalDivisors Pic \
+  Place.ofHeightOneSpectrum Place.mem_maximalIdeal_iff_adicValuation_lt_one \
+  Place.isEquiv_adicValuation_ofHeightOneSpectrum Place.ord_ofHeightOneSpectrum_ne_zero_iff"
+p2m_open "AlgebraicCurve"
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "placeInfty placeInfty_ne_ofHeightOneSpectrum \
+  eq_ofHeightOneSpectrum_or_eq_placeInfty heightOneSpectrumOfIrreducible \
+  heightOneSpectrumOfIrreducible_asIdeal exists_irreducible_span finitePlace finitePlace_def \
+  deg_ofHeightOneSpectrum deg_finitePlace"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable (K : Type*) [Field K]
+
+section PlaceInfty
+
+variable [DecidableEq (RatFunc K)]
+
+theorem inftyValuation_isEquiv_adicValuation :
+    (RatFunc.inftyValuation K).IsEquiv (placeInfty K).adicValuation :=
+  (placeInfty K).isEquiv_adicValuation_of_valuationSubring_eq rfl
+
+end PlaceInfty
+
+variable {K}
+
+theorem subsingleton_setOf_forall_ne_ofHeightOneSpectrum :
+    {v : Place K (RatFunc K) |
+      ∀ w : HeightOneSpectrum K[X], v ≠ Place.ofHeightOneSpectrum w}.Subsingleton := by
+  classical
+  intro v hv v' hv'
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, h⟩ | h
+  · exact absurd h (hv w)
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v' with ⟨w, h'⟩ | h'
+  · exact absurd h' (hv' w)
+  rw [h, h']
+
+theorem finite_setOf_valuation_ne_one {f : RatFunc K} (hf : f ≠ 0) :
+    {w : HeightOneSpectrum K[X] | w.valuation (RatFunc K) f ≠ 1}.Finite := by
+  have hnum : (Ideal.span {f.num} : Ideal K[X]) ≠ 0 := by
+    simpa [Ideal.span_singleton_eq_bot] using RatFunc.num_ne_zero hf
+  have hden : (Ideal.span {f.denom} : Ideal K[X]) ≠ 0 := by
+    simpa [Ideal.span_singleton_eq_bot] using f.denom_ne_zero
+  refine Set.Finite.subset ((Ideal.finite_factors hnum).union (Ideal.finite_factors hden))
+    fun w hw => ?_
+  by_contra hcon
+  simp only [Set.mem_union, Set.mem_ofPred_eq, not_or, Ideal.dvd_span_singleton] at hcon
+  refine hw ?_
+  have h1 : w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) f.num) = 1 :=
+    (HeightOneSpectrum.valuation_eq_one_iff_notMem w).mpr hcon.1
+  have h2 : w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) f.denom) = 1 :=
+    (HeightOneSpectrum.valuation_eq_one_iff_notMem w).mpr hcon.2
+  rw [show f = algebraMap K[X] (RatFunc K) f.num / algebraMap K[X] (RatFunc K) f.denom from
+    f.num_div_denom.symm, map_div₀, h1, h2]
+  exact div_one 1
+
+theorem finite_setOf_ord_ne_zero {f : RatFunc K} (hf : f ≠ 0) :
+    {v : Place K (RatFunc K) | v.ord f ≠ 0}.Finite := by
+  refine Set.Finite.subset
+    (Set.Finite.union
+      (Set.Finite.image (Place.ofHeightOneSpectrum (K := K))
+        (finite_setOf_valuation_ne_one hf))
+      (Set.Subsingleton.finite subsingleton_setOf_forall_ne_ofHeightOneSpectrum))
+    fun v hv => ?_
+  simp only [Set.mem_ofPred_eq] at hv
+  simp only [Set.mem_union, Set.mem_image, Set.mem_ofPred_eq]
+  by_cases hcase : ∃ w : HeightOneSpectrum K[X], v = Place.ofHeightOneSpectrum w
+  · obtain ⟨w, rfl⟩ := hcase
+    refine Or.inl ⟨w, fun hone => hv ?_, rfl⟩
+    exact ((Place.ofHeightOneSpectrum (K := K) w).ord_eq_zero_iff_adicValuation_eq_one hf).mpr
+      ((Place.isEquiv_adicValuation_ofHeightOneSpectrum (K := K) (F := RatFunc K)
+        w).eq_one_iff_eq_one.mp hone)
+  · exact Or.inr fun w h => hcase ⟨w, h⟩
+
+theorem finite_support_ord {f : RatFunc K} (hf : f ≠ 0) :
+    {v : Place K (RatFunc K) | v.ord f ≠ 0}.Finite :=
+  finite_setOf_ord_ne_zero hf
+
+section DegInfty
+
+variable (K) [DecidableEq (RatFunc K)]
+
+theorem exists_sub_algebraMap_intDegree_neg {x : RatFunc K}
+    (hx : RatFunc.inftyValuation K x ≤ 1) :
+    ∃ c : K, x - algebraMap K (RatFunc K) c = 0 ∨
+      (x - algebraMap K (RatFunc K) c).intDegree < 0 := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · exact ⟨0, Or.inl (by simp)⟩
+  have hdeg : x.intDegree ≤ 0 := by
+    rw [RatFunc.inftyValuation_apply, RatFunc.inftyValuation_of_nonzero K hx0,
+      show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_le_exp] at hx
+    exact hx
+  have hnum0 : x.num ≠ 0 := RatFunc.num_ne_zero hx0
+  have hden0 : x.denom ≠ 0 := x.denom_ne_zero
+  rcases lt_or_eq_of_le hdeg with hlt | heq
+  · exact ⟨0, Or.inr (by simpa using hlt)⟩
+  have hndeg : x.num.natDegree = x.denom.natDegree := by
+    have h2 := heq
+    rw [RatFunc.intDegree, sub_eq_zero] at h2
+    exact_mod_cast h2
+  set c : K := x.num.leadingCoeff / x.denom.leadingCoeff with hc
+  have hc0 : c ≠ 0 := by
+    rw [hc]
+    exact div_ne_zero (Polynomial.leadingCoeff_ne_zero.mpr hnum0)
+      (Polynomial.leadingCoeff_ne_zero.mpr hden0)
+  refine ⟨c, ?_⟩
+  have hsub : x - algebraMap K (RatFunc K) c
+      = algebraMap K[X] (RatFunc K) (x.num - Polynomial.C c * x.denom)
+        / algebraMap K[X] (RatFunc K) x.denom := by
+    rw [map_sub, map_mul, sub_div, x.num_div_denom, mul_div_assoc,
+      div_self ((map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hden0),
+      mul_one, IsScalarTower.algebraMap_apply K K[X] (RatFunc K), Polynomial.algebraMap_eq]
+  rcases eq_or_ne (x.num - Polynomial.C c * x.denom) 0 with hzero | hnz
+  · exact Or.inl (by rw [hsub, hzero, map_zero, zero_div])
+  refine Or.inr ?_
+  rw [hsub, RatFunc.intDegree_div ((map_ne_zero_iff _
+      (IsFractionRing.injective K[X] (RatFunc K))).mpr hnz)
+    ((map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hden0),
+    RatFunc.intDegree_polynomial, RatFunc.intDegree_polynomial, sub_neg]
+  have hCdeg : (Polynomial.C c * x.denom).degree = x.denom.degree := by
+    rw [Polynomial.degree_mul, Polynomial.degree_C hc0, zero_add]
+  have hdegeq : x.num.degree = (Polynomial.C c * x.denom).degree := by
+    rw [hCdeg, Polynomial.degree_eq_natDegree hnum0, Polynomial.degree_eq_natDegree hden0,
+      hndeg]
+  have hlc : x.num.leadingCoeff = (Polynomial.C c * x.denom).leadingCoeff := by
+    rw [Polynomial.leadingCoeff_mul, Polynomial.leadingCoeff_C, hc,
+      div_mul_cancel₀ _ (Polynomial.leadingCoeff_ne_zero.mpr hden0)]
+  have hlt := Polynomial.degree_sub_lt_left hdegeq hnum0 hlc
+  rw [hdegeq, hCdeg] at hlt
+  exact_mod_cast Polynomial.natDegree_lt_natDegree hnz hlt
+
+theorem deg_placeInfty : (placeInfty K).deg = 1 := by
+  have hbij : Function.Bijective (Algebra.ofId K (placeInfty K).ResidueField) := by
+    constructor
+    · exact fun a b h => (algebraMap K ((placeInfty K).ResidueField)).injective h
+    · intro y
+      obtain ⟨⟨x, hx⟩, rfl⟩ := IsLocalRing.residue_surjective y
+      obtain ⟨c, hc⟩ := exists_sub_algebraMap_intDegree_neg K
+        ((Valuation.mem_valuationSubring_iff _ _).mp hx)
+      refine ⟨c, ?_⟩
+      change IsLocalRing.residue _ (algebraMap K (placeInfty K).toValuationSubring c) = _
+      rw [← sub_eq_zero, ← map_sub, IsLocalRing.residue_eq_zero_iff,
+        Place.mem_maximalIdeal_iff_adicValuation_lt_one]
+      change (placeInfty K).adicValuation (algebraMap K (RatFunc K) c - x) < 1
+      rw [← (inftyValuation_isEquiv_adicValuation K).lt_one_iff_lt_one,
+        show algebraMap K (RatFunc K) c - x = -(x - algebraMap K (RatFunc K) c) from
+          (neg_sub _ _).symm, Valuation.map_neg]
+      rcases hc with hc | hc
+      · rw [hc, map_zero]
+        exact zero_lt_one
+      · rw [RatFunc.inftyValuation_apply, RatFunc.inftyValuationDef]
+        split
+        · exact zero_lt_one
+        · rw [show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_lt_exp]
+          exact hc
+  rw [Place.deg, ← (AlgEquiv.ofBijective _ hbij).toLinearEquiv.finrank_eq,
+    Module.finrank_self]
+
+end DegInfty
+
+end RationalFunctionField
+
+end AlgebraicCurve
+
+open IsDedekindDomain WithZero IsLocalRing
+open scoped Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.deg Divisor Divisor.degree \
+  Divisor.degree_single Divisor.degZero Divisor.principal HasPrincipalDivisors Pic \
+  Place.ofHeightOneSpectrum Place.mem_maximalIdeal_iff_adicValuation_lt_one \
+  Place.isEquiv_adicValuation_ofHeightOneSpectrum Place.ord_ofHeightOneSpectrum_ne_zero_iff"
+p2m_open "AlgebraicCurve"
+
+theorem le_exp_neg_one_of_lt_one {x : ℤᵐ⁰} (hx : x < 1) : x ≤ exp (-1 : ℤ) := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · exact zero_le
+  · rw [← exp_log hx0] at hx ⊢
+    rw [show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_lt_exp] at hx
+    rw [exp_le_exp]
+    omega
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg FiniteResidue adicValuation \
+  adicValuation_coe_eq_one_iff adicValuation_coe_irreducible ord ord_zero ord_mul \
+  exists_unit_mul_zpow ofHeightOneSpectrum FiniteResidue.finite toValuationSubring \
+  isEquiv_adicValuation_of_valuationSubring_eq mem_maximalIdeal_iff_adicValuation_lt_one \
+  ord_eq_zero_iff_adicValuation_eq_one isEquiv_adicValuation_ofHeightOneSpectrum \
+  ord_ofHeightOneSpectrum_ne_zero_iff"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.isUnit_algebraMap {c : K} (hc : c ≠ 0) :
+    IsUnit (algebraMap K v.toValuationSubring c) :=
+  (isUnit_iff_ne_zero.mpr hc).map _
+
+p2m_export "AlgebraicCurve.Place" "isUnit_algebraMap"
+
+private theorem _root_.AlgebraicCurve.Place.adicValuation_algebraMap {c : K} (hc : c ≠ 0) :
+    v.adicValuation (algebraMap K F c) = 1 := by
+  rw [← v.coe_algebraMap]
+  exact (v.adicValuation_coe_eq_one_iff _).mpr (v.isUnit_algebraMap hc)
+
+p2m_export "AlgebraicCurve.Place" "adicValuation_algebraMap"
+
+p2m_export "AlgebraicCurve.Place" "ord_algebraMap"
+
+private theorem _root_.AlgebraicCurve.Place.ord_eq_neg_log_of_valuationSubring_eq (w : Valuation F
+  ℤᵐ⁰)
+    (hw : w.valuationSubring = v.toValuationSubring) {π : F} (hπ : w π = exp (-1 : ℤ))
+    {f : F} (hf : f ≠ 0) : v.ord f = -log (w f) := by
+  have hequiv : w.IsEquiv v.adicValuation :=
+    v.isEquiv_adicValuation_of_valuationSubring_eq hw
+  have hexp_lt : (exp (-1 : ℤ) : ℤᵐ⁰) < 1 := by
+    rw [show (1 : ℤᵐ⁰) = exp 0 from rfl]
+    exact exp_lt_exp.mpr (by omega)
+  obtain ⟨π₀, hπ₀⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hadic_π₀ : v.adicValuation (π₀ : F) = exp (-1 : ℤ) := v.adicValuation_coe_irreducible hπ₀
+  have hwπ₀ : w (π₀ : F) = exp (-1 : ℤ) := by
+    refine le_antisymm (le_exp_neg_one_of_lt_one (hequiv.lt_one_iff_lt_one.mpr ?_)) ?_
+    · rw [hadic_π₀]
+      exact hexp_lt
+    · rw [← hπ]
+      refine (hequiv π π₀).mpr ?_
+      rw [hadic_π₀]
+      refine le_exp_neg_one_of_lt_one (hequiv.lt_one_iff_lt_one.mp ?_)
+      rw [hπ]
+      exact hexp_lt
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ₀
+  have hwu : w ((u : v.toValuationSubring) : F) = 1 :=
+    hequiv.eq_one_iff_eq_one.mpr ((v.adicValuation_coe_eq_one_iff _).mpr u.isUnit)
+  set n := v.ord f with hn
+  rw [hu, map_mul, map_zpow₀, hwu, hwπ₀, one_mul, log_zpow, log_exp, smul_eq_mul]
+  ring
+
+p2m_export "AlgebraicCurve.Place" "ord_eq_neg_log_of_valuationSubring_eq"
+end Place
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "placeInfty placeInfty_ne_ofHeightOneSpectrum \
+  eq_ofHeightOneSpectrum_or_eq_placeInfty heightOneSpectrumOfIrreducible \
+  heightOneSpectrumOfIrreducible_asIdeal exists_irreducible_span finitePlace finitePlace_def \
+  deg_ofHeightOneSpectrum deg_finitePlace"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable {K : Type*} [Field K]
+
+theorem ord_ofHeightOneSpectrum_eq_neg_log (w : HeightOneSpectrum K[X]) {p : K[X]}
+    (hp : p ≠ 0) (hw : w.asIdeal = Ideal.span {p}) {f : RatFunc K} (hf : f ≠ 0) :
+    (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord f
+      = -log (w.valuation (RatFunc K) f) := by
+  have hval : w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) p) = exp (-1 : ℤ) := by
+    have h := w.intValuation_singleton hp hw
+    rw [← h]
+    simpa using w.valuation_of_algebraMap (K := RatFunc K) p
+  exact (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K)
+    w).ord_eq_neg_log_of_valuationSubring_eq (w.valuation (RatFunc K)) rfl hval hf
+
+theorem ord_ofHeightOneSpectrum_of_span (w : HeightOneSpectrum K[X]) {p : K[X]}
+    (hp : p ≠ 0) (hw : w.asIdeal = Ideal.span {p}) :
+    (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord
+      (algebraMap K[X] (RatFunc K) p) = 1 := by
+  have hval : w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) p) = exp (-1 : ℤ) := by
+    have h := w.intValuation_singleton hp hw
+    rw [← h]
+    simpa using w.valuation_of_algebraMap (K := RatFunc K) p
+  rw [ord_ofHeightOneSpectrum_eq_neg_log w hp hw (RatFunc.algebraMap_ne_zero hp), hval]
+  simp [log_exp]
+
+theorem ord_ofHeightOneSpectrum_eq_zero_of_notMem (w : HeightOneSpectrum K[X]) {q : K[X]}
+    (hq : q ≠ 0) (hmem : q ∉ w.asIdeal) :
+    (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord
+      (algebraMap K[X] (RatFunc K) q) = 0 := by
+  by_contra h
+  exact hmem
+    ((Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w hq).mp h)
+
+section PlaceInftyOrd
+
+variable [DecidableEq (RatFunc K)]
+
+theorem ord_placeInfty {f : RatFunc K} (hf : f ≠ 0) :
+    (placeInfty K).ord f = -f.intDegree := by
+  have hπ : RatFunc.inftyValuation K (RatFunc.X)⁻¹ = exp (-1 : ℤ) := by
+    rw [map_inv₀, RatFunc.inftyValuation.X]
+    exact (exp_neg (1 : ℤ)).symm
+  rw [(placeInfty K).ord_eq_neg_log_of_valuationSubring_eq (RatFunc.inftyValuation K) rfl hπ
+      hf,
+    RatFunc.inftyValuation_apply, RatFunc.inftyValuation_of_nonzero K hf, log_exp]
+
+theorem ord_placeInfty_algebraMap {q : K[X]} (hq : q ≠ 0) :
+    (placeInfty K).ord (algebraMap K[X] (RatFunc K) q) = -(q.natDegree : ℤ) := by
+  rw [ord_placeInfty (RatFunc.algebraMap_ne_zero hq), RatFunc.intDegree_polynomial]
+
+end PlaceInftyOrd
+
+section IrreducibleDivisor
+
+variable [DecidableEq (RatFunc K)]
+
+theorem single_add_single_apply_eq_ord {p : K[X]} (hp : Irreducible p)
+    (v : Place K (RatFunc K)) :
+    (Finsupp.single (finitePlace K hp) (1 : ℤ)
+        + Finsupp.single (placeInfty K) (-(p.natDegree : ℤ))) v
+      = v.ord (algebraMap K[X] (RatFunc K) p) := by
+  have hp0 : p ≠ 0 := hp.ne_zero
+  rw [Finsupp.add_apply]
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+  · rw [Finsupp.single_eq_of_ne (Ne.symm (placeInfty_ne_ofHeightOneSpectrum K w)), add_zero]
+    by_cases hcase :
+        Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w = finitePlace K hp
+    · rw [hcase, Finsupp.single_eq_same]
+      exact (ord_ofHeightOneSpectrum_of_span (heightOneSpectrumOfIrreducible K hp) hp0
+        (heightOneSpectrumOfIrreducible_asIdeal K hp)).symm
+    · rw [Finsupp.single_eq_of_ne hcase]
+      refine (ord_ofHeightOneSpectrum_eq_zero_of_notMem w hp0 fun hmem => hcase ?_).symm
+      have hspan : Ideal.span {p} = w.asIdeal :=
+        (PrincipalIdealRing.isMaximal_of_irreducible hp).eq_of_le w.isPrime.ne_top
+          ((Ideal.span_singleton_le_iff_mem _).mpr hmem)
+      have hwp : w = heightOneSpectrumOfIrreducible K hp :=
+        HeightOneSpectrum.ext
+          (hspan.symm.trans (heightOneSpectrumOfIrreducible_asIdeal K hp).symm)
+      rw [hwp, finitePlace_def]
+  · rw [Finsupp.single_eq_of_ne
+        (show placeInfty K ≠ finitePlace K hp from
+          placeInfty_ne_ofHeightOneSpectrum K (heightOneSpectrumOfIrreducible K hp)),
+      Finsupp.single_eq_same, zero_add]
+    exact (ord_placeInfty_algebraMap hp0).symm
+
+theorem degree_single_add_single {p : K[X]} (hp : Irreducible p) :
+    Divisor.degree (Finsupp.single (finitePlace K hp) (1 : ℤ)
+        + Finsupp.single (placeInfty K) (-(p.natDegree : ℤ))) = 0 := by
+  rw [map_add, Divisor.degree_single, Divisor.degree_single, deg_finitePlace, deg_placeInfty]
+  push_cast
+  ring
+
+end IrreducibleDivisor
+
+theorem degree_eq_zero_of_forall_eq_ord_algebraMap (q : K[X]) :
+    ∀ D : Divisor K (RatFunc K),
+      (∀ v : Place K (RatFunc K), D v = v.ord (algebraMap K[X] (RatFunc K) q)) →
+      Divisor.degree D = 0 := by
+  classical
+  refine UniqueFactorizationMonoid.induction_on_prime q ?_ ?_ ?_
+  · intro D hD
+    have hzero : D = 0 := by
+      ext v
+      simp [hD v]
+    rw [hzero, map_zero]
+  · intro x hx D hD
+    obtain ⟨r, -, rfl⟩ := Polynomial.isUnit_iff.mp hx
+    have hC : (algebraMap K[X] (RatFunc K)) (Polynomial.C r) = algebraMap K (RatFunc K) r := by
+      rw [← Polynomial.algebraMap_eq, ← IsScalarTower.algebraMap_apply]
+    have hzero : D = 0 := by
+      ext v
+      rw [hD v, hC, v.ord_algebraMap]
+      simp
+    rw [hzero, map_zero]
+  · intro a p ha hp ih D hD
+    have hp' : algebraMap K[X] (RatFunc K) p ≠ 0 := RatFunc.algebraMap_ne_zero hp.ne_zero
+    have ha' : algebraMap K[X] (RatFunc K) a ≠ 0 := RatFunc.algebraMap_ne_zero ha
+    set Dp : Divisor K (RatFunc K) :=
+      Finsupp.single (finitePlace K hp.irreducible) (1 : ℤ)
+        + Finsupp.single (placeInfty K) (-(p.natDegree : ℤ)) with hDp_def
+    have hDp : ∀ v : Place K (RatFunc K), Dp v = v.ord (algebraMap K[X] (RatFunc K) p) :=
+      fun v => single_add_single_apply_eq_ord hp.irreducible v
+    have hDa : ∀ v : Place K (RatFunc K),
+        (D - Dp) v = v.ord (algebraMap K[X] (RatFunc K) a) := by
+      intro v
+      rw [Finsupp.sub_apply, hD v, hDp v, map_mul, v.ord_mul hp' ha']
+      ring
+    have hdeg_p : Divisor.degree Dp = 0 := degree_single_add_single hp.irreducible
+    have hdeg_a : Divisor.degree (D - Dp) = 0 := ih (D - Dp) hDa
+    have hsplit : D = Dp + (D - Dp) := by abel
+    rw [hsplit, map_add, hdeg_p, zero_add]
+    exact hdeg_a
+
+def principalDivisor {f : RatFunc K} (hf : f ≠ 0) : Divisor K (RatFunc K) :=
+  ⟨(finite_setOf_ord_ne_zero hf).toFinset, fun v => v.ord f, fun v => by
+    simp [Set.Finite.mem_toFinset]⟩
+
+@[scoped simp]
+theorem principalDivisor_apply {f : RatFunc K} (hf : f ≠ 0) (v : Place K (RatFunc K)) :
+    principalDivisor hf v = v.ord f := rfl
+
+theorem principalDivisor_isPrincipal {f : RatFunc K} (hf : f ≠ 0) :
+    (principalDivisor hf).IsPrincipal :=
+  ⟨f, hf, fun _ => rfl⟩
+
+theorem degree_eq_zero_of_forall_eq_ord {f : RatFunc K} (D : Divisor K (RatFunc K))
+    (hD : ∀ v : Place K (RatFunc K), D v = v.ord f) : Divisor.degree D = 0 := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · have hzero : D = 0 := by
+      ext v
+      simp [hD v]
+    rw [hzero, map_zero]
+  · have hden : f.denom ≠ 0 := f.denom_ne_zero
+    have hdenF : algebraMap K[X] (RatFunc K) f.denom ≠ 0 := RatFunc.algebraMap_ne_zero hden
+    have hsplit : ∀ v : Place K (RatFunc K),
+        (D + principalDivisor hdenF) v = v.ord (algebraMap K[X] (RatFunc K) f.num) := by
+      intro v
+      rw [Finsupp.add_apply, hD v, principalDivisor_apply]
+      have hmul : f * algebraMap K[X] (RatFunc K) f.denom
+          = algebraMap K[X] (RatFunc K) f.num :=
+        ((div_eq_iff hdenF).mp f.num_div_denom).symm
+      have h2 := v.ord_mul hf hdenF
+      rw [hmul] at h2
+      exact h2.symm
+    have h1 := degree_eq_zero_of_forall_eq_ord_algebraMap f.num
+      (D + principalDivisor hdenF) hsplit
+    have h2 := degree_eq_zero_of_forall_eq_ord_algebraMap f.denom
+      (principalDivisor hdenF) fun _ => rfl
+    rw [map_add, h2, add_zero] at h1
+    exact h1
+
+theorem degree_principalDivisor {f : RatFunc K} (hf : f ≠ 0) :
+    Divisor.degree (principalDivisor hf) = 0 :=
+  degree_eq_zero_of_forall_eq_ord (principalDivisor hf) fun _ => rfl
+
+theorem sum_ord_mul_deg_eq_zero {f : RatFunc K} (hf : f ≠ 0) :
+    ∑ v ∈ (finite_setOf_ord_ne_zero hf).toFinset, v.ord f * (v.deg : ℤ) = 0 := by
+  have h1 : (principalDivisor hf : Divisor K (RatFunc K))
+      = ∑ v ∈ (finite_setOf_ord_ne_zero hf).toFinset, Finsupp.single v (v.ord f) :=
+    (Finsupp.sum_single (principalDivisor hf)).symm
+  have h2 := degree_principalDivisor hf
+  rw [h1, map_sum] at h2
+  simp only [Divisor.degree_single] at h2
+  exact h2
+
+theorem degree_eq_zero_of_isPrincipal {D : Divisor K (RatFunc K)} (hD : D.IsPrincipal) :
+    Divisor.degree D = 0 := by
+  obtain ⟨f, -, hDf⟩ := hD
+  exact degree_eq_zero_of_forall_eq_ord D hDf
+
+theorem principal_le_degZero :
+    Divisor.principal (K := K) (F := RatFunc K) ≤ Divisor.degZero (K := K) (F := RatFunc K) :=
+  fun _ hD => degree_eq_zero_of_isPrincipal hD
+
+scoped instance instHasPrincipalDivisors : HasPrincipalDivisors K (RatFunc K) where
+  exists_divisor _ hf := ⟨principalDivisor hf, fun _ => rfl, degree_principalDivisor hf⟩
+
+end RationalFunctionField
+end AlgebraicCurve
+
+open IsDedekindDomain WithZero IsLocalRing
+open scoped Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.deg Divisor Divisor.degree \
+  Divisor.degree_single Divisor.degZero Divisor.principal HasPrincipalDivisors Pic \
+  Place.ofHeightOneSpectrum Place.mem_maximalIdeal_iff_adicValuation_lt_one \
+  Place.isEquiv_adicValuation_ofHeightOneSpectrum Place.ord_ofHeightOneSpectrum_ne_zero_iff"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg FiniteResidue adicValuation \
+  adicValuation_coe_eq_one_iff adicValuation_coe_irreducible ord ord_zero ord_mul \
+  exists_unit_mul_zpow ofHeightOneSpectrum FiniteResidue.finite toValuationSubring \
+  isEquiv_adicValuation_of_valuationSubring_eq mem_maximalIdeal_iff_adicValuation_lt_one \
+  ord_eq_zero_iff_adicValuation_eq_one isEquiv_adicValuation_ofHeightOneSpectrum \
+  ord_ofHeightOneSpectrum_ne_zero_iff"
+p2m_open "AlgebraicCurve.Place"
+
+section DegPos
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+theorem finiteResidue_of_deg_pos (h : 0 < v.deg) : v.FiniteResidue :=
+  ⟨Module.finite_of_finrank_pos h⟩
+
+private theorem _root_.AlgebraicCurve.Place.deg_pos [v.FiniteResidue] : 0 < v.deg := by
+  have : Module.Finite K v.ResidueField := FiniteResidue.finite
+  exact Module.finrank_pos
+
+p2m_export "AlgebraicCurve.Place" "deg_pos"
+
+theorem deg_ne_zero [v.FiniteResidue] : v.deg ≠ 0 :=
+  v.deg_pos.ne'
+
+end DegPos
+end Place
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "placeInfty placeInfty_ne_ofHeightOneSpectrum \
+  eq_ofHeightOneSpectrum_or_eq_placeInfty heightOneSpectrumOfIrreducible \
+  heightOneSpectrumOfIrreducible_asIdeal exists_irreducible_span finitePlace finitePlace_def \
+  deg_ofHeightOneSpectrum deg_finitePlace"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable (K : Type*) [Field K]
+
+scoped instance instFiniteResidueOfHeightOneSpectrum (w : HeightOneSpectrum K[X]) :
+    (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).FiniteResidue := by
+  obtain ⟨p, hp, hw⟩ := exists_irreducible_span K w
+  refine Place.finiteResidue_of_deg_pos _ ?_
+  rw [deg_ofHeightOneSpectrum K hw]
+  exact hp.natDegree_pos
+
+scoped instance instFiniteResiduePlaceInfty [DecidableEq (RatFunc K)] :
+    (placeInfty K).FiniteResidue :=
+  Place.finiteResidue_of_deg_pos _ (by rw [deg_placeInfty K]; exact one_pos)
+
+variable {K} in
+scoped instance instFiniteResidue (v : Place K (RatFunc K)) : v.FiniteResidue := by
+  classical
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+  · exact instFiniteResidueOfHeightOneSpectrum K w
+  · exact instFiniteResiduePlaceInfty K
+
+end RationalFunctionField
+end AlgebraicCurve
+
+section Kaehler
+
+open Polynomial TensorProduct Module
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver Place Place.deg Divisor Divisor.degree \
+  Divisor.degree_single Divisor.degZero Divisor.principal HasPrincipalDivisors Pic \
+  Place.ofHeightOneSpectrum Place.mem_maximalIdeal_iff_adicValuation_lt_one \
+  Place.isEquiv_adicValuation_ofHeightOneSpectrum Place.ord_ofHeightOneSpectrum_ne_zero_iff"
+p2m_open "AlgebraicCurve"
+
+variable (K : Type*) [Field K]
+
+def kaehlerPolynomialBasis : Basis Unit K[X] Ω[K[X]⁄K] :=
+  (Basis.singleton Unit K[X]).map (KaehlerDifferential.polynomialEquiv K).symm
+
+scoped instance instFormallyEtalePolynomialRatFunc : Algebra.FormallyEtale K[X] (RatFunc K) :=
+  Algebra.FormallyEtale.of_isLocalization (nonZeroDivisors K[X])
+
+def kaehlerRatFuncBasis : Basis Unit (RatFunc K) Ω[(RatFunc K)⁄K] :=
+  ((kaehlerPolynomialBasis K).baseChange (RatFunc K)).map
+    (KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale K K[X] (RatFunc K))
+
+theorem kaehler_free_rank_one_ratFunc :
+    Module.Free (RatFunc K) Ω[(RatFunc K)⁄K] ∧ Module.finrank (RatFunc K) Ω[(RatFunc K)⁄K] = 1 :=
+  ⟨Module.Free.of_basis (kaehlerRatFuncBasis K),
+    (Module.finrank_eq_card_basis (kaehlerRatFuncBasis K)).trans (by simp)⟩
+
+end AlgebraicCurve
+end Kaehler
+end
+
+open _root_.AlgebraicCurve _root_.P2MW.S_AlgebraicCurve_isCurveOver_ratFunc.AlgebraicCurve in
+theorem solution (K : Type*) [Field K] : IsCurveOver K (RatFunc K) :=
+  { toHasPrincipalDivisors := RationalFunctionField.instHasPrincipalDivisors
+    finiteResidue := fun v => (RationalFunctionField.instFiniteResidue v).finite
+    kaehler_free_rank_one := kaehler_free_rank_one_ratFunc K }
+
+end S_AlgebraicCurve_isCurveOver_ratFunc
+end P2MW
+export P2MW.S_AlgebraicCurve_isCurveOver_ratFunc (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.isCurveOver_ratFunc (K : Type*) [Field K] :
+    IsCurveOver K (RatFunc K) :=
+  solution K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isIntegral_adjoin_intermediateField_mk.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isIntegral_adjoin_intermediateField_mk.lean
new file mode 100644
index 0000000000..1f09344935
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isIntegral_adjoin_intermediateField_mk.lean
@@ -0,0 +1,113 @@
+/-
+Based on Prove2Me node AlgebraicCurve.isIntegral_adjoin_intermediateField_mk
+(3e45fe13-63ca-5f74-811e-737bf6f94447) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5d5e4752-c1b9-5579-8f70-e09bba79b803
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.IntegralClosure.IsIntegral.Basic
+public import Mathlib.FieldTheory.IntermediateField.Basic
+
+import Mathlib.Algebra.Algebra.Subalgebra.Lattice
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality over L[j] descends to an intermediate field
+
+Theorem statement: `AlgebraicCurve.isIntegral_adjoin_intermediateField_mk`
+(`3e45fe13-63ca-5f74-811e-737bf6f94447`), by Claude, 2026-09-05.
+
+Proof: submission `5d5e4752-c1b9-5579-8f70-e09bba79b803`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ and $F$ be fields with $F$ an $L$-algebra, let $E$ be an intermediate field of $F/L$, i.e.
+an $L$-subfield of $F$, and let $j, x \in F$ with $hj : j \in E$ and $hx : x \in E$. Assume that
+$x$, as an element of $F$, is integral over the $L$-subalgebra $\mathrm{Algebra.adjoin}\ L\ \{j\} =
+L[j]$ of $F$, that is, $x$ satisfies a monic polynomial with coefficients in $L[j]$. The conclusion
+is that the element $\langle x, hx\rangle$ of $E$ is integral over the $L$-subalgebra
+$\mathrm{Algebra.adjoin}\ L\ \{\langle j, hj\rangle\}$ of $E$ generated by the element $\langle j,
+hj\rangle$ of $E$, i.e. integrality is transferred from the ambient field $F$ and its subring $L[j]
+\subseteq F$ to the intermediate field $E$ and the corresponding subring $L[j] \subseteq E$. The two
+base rings are canonically isomorphic, but they are literally different Lean objects, and the
+statement records the passage between them.
+
+A bookkeeping lemma on base-ring transport for integrality: it lets an integral dependence
+established in a large field $F$ over $L[j]$ be read inside any intermediate field containing $j$
+and the element in question. It is used throughout the construction of modular function fields and
+their places, for instance when elements known to be integral over $\bar{\mathbb Q}[j]$ must be
+treated as integral elements of a modular function field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_isIntegral_adjoin_intermediateField_mk.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_isIntegral_adjoin_intermediateField_mk
+
+theorem solution {L F : Type*} [Field L] [Field F] [Algebra L F] (E : IntermediateField L F)
+    {j x : F} (hj : j ∈ E) (hx : x ∈ E) (h : IsIntegral (Algebra.adjoin L {j}) x) :
+    IsIntegral (Algebra.adjoin L {(⟨j, hj⟩ : E)}) (⟨x, hx⟩ : E) := by
+  have hmapeq : (Algebra.adjoin L {(⟨j, hj⟩ : E)}).map E.val
+      = Algebra.adjoin L {j} := by
+    rw [← Algebra.adjoin_image, Set.image_singleton]
+    rfl
+  let ψfwd : ↥(Algebra.adjoin L {(⟨j, hj⟩ : E)}) →ₐ[L] ↥(Algebra.adjoin L {j}) :=
+    (Subalgebra.equivOfEq _ _ hmapeq).toAlgHom.comp
+      (E.val.subalgebraMap (Algebra.adjoin L {(⟨j, hj⟩ : E)}))
+  have hcoeF : ∀ b : ↥(Algebra.adjoin L {(⟨j, hj⟩ : E)}),
+      ((ψfwd b : ↥(Algebra.adjoin L {j})) : F) = ((b : E) : F) := fun b => rfl
+  have hinjE : Function.Injective ((↑) : E → F) := Subtype.coe_injective
+  have hbij : Function.Bijective ψfwd := by
+    constructor
+    · intro a b hab
+      exact Subtype.ext (hinjE (by
+        have := congrArg (Subtype.val : ↥(Algebra.adjoin L {j}) → F) hab
+        rwa [hcoeF a, hcoeF b] at this))
+    · exact (Subalgebra.equivOfEq _ _ hmapeq).surjective.comp
+        (E.val.subalgebraMap_surjective _)
+  let e := RingEquiv.ofBijective ψfwd hbij
+  have hcoe : ∀ a : ↥(Algebra.adjoin L {j}),
+      (((e.symm a : ↥(Algebra.adjoin L {(⟨j, hj⟩ : E)})) : E) : F) = (a : F) := by
+    intro a
+    have h2 : ψfwd (e.symm a) = a := e.apply_symm_apply a
+    calc (((e.symm a : ↥(Algebra.adjoin L {(⟨j, hj⟩ : E)})) : E) : F)
+        = ((ψfwd (e.symm a) : ↥(Algebra.adjoin L {j})) : F) := (hcoeF _).symm
+      _ = (a : F) := by rw [h2]
+  let : Algebra ↥(Algebra.adjoin L {(⟨j, hj⟩ : E)}) F :=
+    ((algebraMap E F).comp (algebraMap ↥(Algebra.adjoin L {(⟨j, hj⟩ : E)}) E)).toAlgebra
+  have hxT : IsIntegral ↥(Algebra.adjoin L {(⟨j, hj⟩ : E)}) x :=
+    IsIntegral.map_of_comp_eq e.symm.toRingHom (RingHom.id F)
+      (by ext a; exact hcoe a) h
+  let f : E →ₐ[↥(Algebra.adjoin L {(⟨j, hj⟩ : E)})] F :=
+    { toRingHom := (E.val : E →+* F), commutes' := fun t => rfl }
+  have hinjf : Function.Injective f := hinjE
+  exact (isIntegral_algHom_iff f hinjf).mp hxT
+
+end S_AlgebraicCurve_isIntegral_adjoin_intermediateField_mk
+end P2MW
+export P2MW.S_AlgebraicCurve_isIntegral_adjoin_intermediateField_mk (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.isIntegral_adjoin_intermediateField_mk {L F : Type*} [Field L] [Field F]
+    [Algebra L F] (E : IntermediateField L F) {j x : F} (hj : j ∈ E) (hx : x ∈ E)
+    (h : IsIntegral (Algebra.adjoin L {j}) x) :
+    IsIntegral (Algebra.adjoin L {(⟨j, hj⟩ : E)}) (⟨x, hx⟩ : E) :=
+  solution E hj hx h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isIntegral_adjoin_map_algHom.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isIntegral_adjoin_map_algHom.lean
new file mode 100644
index 0000000000..7ac5fdc252
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isIntegral_adjoin_map_algHom.lean
@@ -0,0 +1,90 @@
+/-
+Based on Prove2Me node AlgebraicCurve.isIntegral_adjoin_map_algHom
+(576940b4-b9e7-522d-8843-0ef8f323df09) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 0db3c6f8-d12a-5e11-8eff-c69b60e1465b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.IntegralClosure.IsIntegral.Basic
+
+import Mathlib.Algebra.Algebra.Subalgebra.Lattice
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality over K[j] transports along K-algebra maps
+
+Theorem statement: `AlgebraicCurve.isIntegral_adjoin_map_algHom`
+(`576940b4-b9e7-522d-8843-0ef8f323df09`), by Claude, 2026-09-05.
+
+Proof: submission `0db3c6f8-d12a-5e11-8eff-c69b60e1465b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$ and $F'$ be commutative rings with $F$ and $F'$ both $K$-algebras, and let $\varphi
+\colon F \to F'$ be a homomorphism of $K$-algebras. Let $j, x \in F$, and suppose that $x$ is
+integral over the $K$-subalgebra $\mathrm{Adjoin}_K\{j\} \subseteq F$ generated by $j$, that is, $x$
+satisfies a monic polynomial with coefficients in that subalgebra. The conclusion is that
+$\varphi(x) \in F'$ is integral over the $K$-subalgebra $\mathrm{Adjoin}_K\{\varphi j\} \subseteq
+F'$ generated by $\varphi(j)$. Integrality here is `IsIntegral` of an element of $F$ (respectively
+$F'$) over the corresponding subalgebra regarded as a base ring, the ring structure on the target
+being the one induced by the ambient algebra.
+
+This is the routine transport of the relation 'integral over $K[j]$' along a $K$-algebra
+homomorphism; in the formalisation it moves integrality over $\mathbb{Q}[j]$ from one coefficient
+ring of formal/Laurent series to another, for instance along a coefficient embedding
+$\mathbb{Q}((q)) \to \overline{\mathbb{Q}}((q))$. It is used in the treatment of modular units,
+cuspidality and modular forms mod $p$, where elements are recognised as integral over the $j$-line
+after a change of coefficients.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_isIntegral_adjoin_map_algHom.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_isIntegral_adjoin_map_algHom
+
+theorem solution {K F F' : Type*} [CommRing K] [CommRing F] [CommRing F'] [Algebra K F]
+    [Algebra K F'] (φ : F →ₐ[K] F') {j x : F} (hx : IsIntegral (Algebra.adjoin K {j}) x) :
+    IsIntegral (Algebra.adjoin K {φ j}) (φ x) := by
+  have hle : (Algebra.adjoin K {j}).map φ ≤ Algebra.adjoin K {φ j} := by
+    rw [Subalgebra.map_le]
+    refine Algebra.adjoin_le fun y hy => ?_
+    rw [Set.mem_singleton_iff.mp hy]
+    change j ∈ Subalgebra.comap φ (Algebra.adjoin K {φ j})
+    rw [Subalgebra.mem_comap]
+    exact Algebra.subset_adjoin rfl
+  have hmem : ∀ a : ↥(Algebra.adjoin K {j}),
+      (φ.comp (Algebra.adjoin K {j}).val) a ∈ Algebra.adjoin K {φ j} :=
+    fun a => hle (Subalgebra.mem_map.mpr ⟨(a : F), a.2, rfl⟩)
+  have key := IsIntegral.map_of_comp_eq
+    ((φ.comp (Algebra.adjoin K {j}).val).codRestrict (Algebra.adjoin K {φ j}) hmem).toRingHom
+    φ.toRingHom (by ext a; rfl) hx
+  exact key
+
+end S_AlgebraicCurve_isIntegral_adjoin_map_algHom
+end P2MW
+export P2MW.S_AlgebraicCurve_isIntegral_adjoin_map_algHom (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.isIntegral_adjoin_map_algHom {K F F' : Type*} [CommRing K] [CommRing F]
+    [CommRing F'] [Algebra K F] [Algebra K F'] (φ : F →ₐ[K] F') {j x : F}
+    (hx : IsIntegral (Algebra.adjoin K {j}) x) :
+    IsIntegral (Algebra.adjoin K {φ j}) (φ x) :=
+  solution φ hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isIntegral_adjoin_of_forall_mem_toValuationSubring.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isIntegral_adjoin_of_forall_mem_toValuationSubring.lean
new file mode 100644
index 0000000000..7005772d2b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isIntegral_adjoin_of_forall_mem_toValuationSubring.lean
@@ -0,0 +1,193 @@
+/-
+Based on Prove2Me node AlgebraicCurve.isIntegral_adjoin_of_forall_mem_toValuationSubring
+(ec854fae-ead3-5215-b9ae-f4ef7f1f629d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1c32ddb7-91c8-5b09-90d0-3a34c3d2ac4b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.RingTheory.Valuation.LocalSubring
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_of_valuationSubring_of_isSeparable
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality over K[t] from membership in all places containing t
+
+Theorem statement: `AlgebraicCurve.isIntegral_adjoin_of_forall_mem_toValuationSubring`
+(`ec854fae-ead3-5215-b9ae-f4ef7f1f629d`), by Claude, 2026-09-05.
+
+Proof: submission `1c32ddb7-91c8-5b09-90d0-3a34c3d2ac4b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and suppose there is an element $x \in F$ such
+that $F$ is finite-dimensional and separable over the intermediate field $K(x) =$
+`IntermediateField.adjoin K {x}`. Let $t, z \in F$, and assume that for every place $v$ of $F$ over
+$K$ — that is, for every structure consisting of a valuation subring $\mathcal{O}_v \subseteq F$
+which contains $\mathrm{algebraMap}\,K\,F\,a$ for all $a \in K$, is not the whole of $F$, and is a
+principal ideal ring — the implication $t \in \mathcal{O}_v \Rightarrow z \in \mathcal{O}_v$ holds.
+Then $z$ is integral over the $K$-subalgebra $K[t] =$ `Algebra.adjoin K {t}` of $F$, i.e. $z$
+satisfies a monic polynomial with coefficients in $K[t]$. No hypothesis on the characteristic of $K$
+is imposed, and the hypothesis on places is phrased by membership in the valuation subrings rather
+than by inequalities between valuations.
+
+This is the standard characterisation of the integral closure of $K[t]$ in a function field as the
+intersection of the valuation rings of the places at which $t$ is regular, in the form needed for
+the project's theory of algebraic curves. It is used in the construction of regular prolongations
+and in the characteristic-$p$ models of modular curves, where integrality over a coordinate ring
+must be deduced from local regularity at all places.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_isIntegral_adjoin_of_forall_mem_toValuationSubring.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_isIntegral_adjoin_of_forall_mem_toValuationSubring
+
+open AlgebraicCurve Polynomial
+
+
+namespace INTGlue
+
+theorem isIntegral_of_mem_adjoin_inv {A F : Type*} [CommRing A] [Field F] [Algebra A F]
+    {z : F} (hz0 : z ≠ 0) (hmem : z ∈ Algebra.adjoin A ({z⁻¹} : Set F)) : IsIntegral A z := by
+  classical
+  rw [Algebra.adjoin_singleton_eq_range_aeval] at hmem
+  obtain ⟨p, hp⟩ := hmem
+  have hp' : aeval z⁻¹ p = z := hp
+  have hdeg : (∑ i ∈ Finset.range (p.natDegree + 1), C (p.coeff i) * X ^ (p.natDegree - i)).degree ≤
+      (p.natDegree : WithBot ℕ) := by
+    refine (Polynomial.degree_sum_le _ _).trans (Finset.sup_le fun i _ => ?_)
+    exact (Polynomial.degree_C_mul_X_pow_le _ _).trans (by exact_mod_cast Nat.sub_le _ _)
+  refine ⟨X ^ (p.natDegree + 1) - ∑ i ∈ Finset.range (p.natDegree + 1), C (p.coeff i) * X ^
+    (p.natDegree - i),
+    Polynomial.monic_X_pow_sub (hdeg.trans_lt (by exact_mod_cast Nat.lt_succ_self _)), ?_⟩
+  have hz : z = ∑ i ∈ Finset.range (p.natDegree + 1), algebraMap A F (p.coeff i) * z⁻¹ ^ i := by
+    conv_lhs => rw [← hp']
+    rw [Polynomial.aeval_eq_sum_range]
+    simp only [Algebra.smul_def]
+  have hzpow : ∀ i ∈ Finset.range (p.natDegree + 1), z ^ p.natDegree * z⁻¹ ^ i = z ^ (p.natDegree -
+    i) :=
+    by
+    intro i hi
+    have hi' : i ≤ p.natDegree := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)
+    obtain ⟨k, hk⟩ := Nat.exists_eq_add_of_le hi'
+    rw [hk, Nat.add_sub_cancel_left, pow_add, mul_comm (z ^ i) (z ^ k), mul_assoc, ← mul_pow,
+      mul_inv_cancel₀ hz0, one_pow, mul_one]
+  rw [eval₂_sub, sub_eq_zero, eval₂_pow, eval₂_X, eval₂_finsetSum]
+  simp only [eval₂_mul, eval₂_C, eval₂_pow, eval₂_X]
+  rw [pow_succ]
+  conv_lhs => arg 2; rw [hz]
+  rw [Finset.mul_sum]
+  refine Finset.sum_congr rfl fun i hi => ?_
+  rw [mul_left_comm, hzpow i hi]
+
+theorem isIntegral_of_forall_valuationSubring {F : Type*} [Field F] (A : Subring F) (z : F)
+    (h : ∀ V : ValuationSubring F, A ≤ V.toSubring → z ∈ V) : IsIntegral A z := by
+  classical
+  by_contra hnot
+  have hz0 : z ≠ 0 := by rintro rfl; exact hnot isIntegral_zero
+  set y : F := z⁻¹ with hy
+  let B : Subalgebra A F := Algebra.adjoin A ({y} : Set F)
+  have hyB : y ∈ B := Algebra.subset_adjoin (Set.mem_singleton y)
+  have hzB : z ∉ B := fun hzB => hnot (isIntegral_of_mem_adjoin_inv hz0 hzB)
+  have hyu : (⟨y, hyB⟩ : B) ∈ nonunits B := by
+    intro hu
+    obtain ⟨u, hu⟩ := hu
+    have hinv : ((u⁻¹ : Bˣ) : B).1 = z := by
+      have h1 : ((u : B) : F) * ((u⁻¹ : Bˣ) : B) = 1 := by
+        rw [← Subalgebra.coe_mul, Units.mul_inv]; rfl
+      rw [hu] at h1
+      have : y⁻¹ = ((u⁻¹ : Bˣ) : B).1 := inv_eq_of_mul_eq_one_right h1
+      rw [← this, hy, inv_inv]
+    exact hzB (hinv ▸ ((u⁻¹ : Bˣ) : B).2)
+  obtain ⟨m, hm, hym⟩ := exists_max_ideal_of_mem_nonunits hyu
+  let Bs : Subring F := B.toSubring
+  let m' : Ideal Bs := m
+  have : m'.IsMaximal := hm
+  let L : LocalSubring F := LocalSubring.ofPrime Bs m'
+  obtain ⟨V, hV⟩ := L.exists_le_valuationSubring
+  obtain ⟨hLV, hloc⟩ := LocalSubring.le_def.mp hV
+  have hBL : Bs ≤ L.toSubring := LocalSubring.le_ofPrime Bs m'
+  have hAV : A ≤ V.toSubring := by
+    intro a ha
+    have : (a : F) ∈ Bs := by
+      change a ∈ B
+      exact Subalgebra.algebraMap_mem B ⟨a, ha⟩
+    exact hLV (hBL this)
+  have hzV : z ∈ V := h V hAV
+  have hyL : (algebraMap Bs L.toSubring ⟨y, hyB⟩) ∈ IsLocalRing.maximalIdeal L.toSubring :=
+    (IsLocalization.AtPrime.to_map_mem_maximal_iff L.toSubring m' ⟨y, hyB⟩).mpr hym
+  have hcoe : ((algebraMap Bs L.toSubring ⟨y, hyB⟩ : L.toSubring) : F) = y := by
+    change algebraMap L.toSubring F (algebraMap Bs L.toSubring ⟨y, hyB⟩) = y
+    rw [← IsScalarTower.algebraMap_apply Bs L.toSubring F]
+    rfl
+  have hyV' : ¬ IsUnit (Subring.inclusion hLV (algebraMap Bs L.toSubring ⟨y, hyB⟩)) := by
+    intro hu
+    have := (IsLocalRing.mem_maximalIdeal _).mp hyL
+    exact this (hloc.map_nonunit _ hu)
+  apply hyV'
+  have hyVmem : y ∈ V := by
+    have := (Subring.inclusion hLV (algebraMap Bs L.toSubring ⟨y, hyB⟩)).2
+    rwa [Subring.coe_inclusion, hcoe] at this
+  refine isUnit_iff_exists_inv.mpr ⟨⟨z, hzV⟩, ?_⟩
+  ext
+  simp only [Subring.coe_mul, Subring.coe_inclusion, hcoe, Subring.coe_one]
+  rw [hy, inv_mul_cancel₀ hz0]
+
+end INTGlue
+
+theorem solution
+    {K F : Type*} [Field K] [Field F] [Algebra K F] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F]
+    (t z : F)
+    (h : ∀ v : AlgebraicCurve.Place K F, t ∈ v.toValuationSubring → z ∈ v.toValuationSubring) :
+    IsIntegral (Algebra.adjoin K ({t} : Set F)) z := by
+  classical
+  have key : IsIntegral (Algebra.adjoin K ({t} : Set F)).toSubring z := by
+    refine INTGlue.isIntegral_of_forall_valuationSubring _ z fun V hV => ?_
+    by_cases htop : V = ⊤
+    · rw [htop]; exact ValuationSubring.mem_top z
+    have hK : ∀ a : K, algebraMap K F a ∈ V := fun a =>
+      hV (Subalgebra.algebraMap_mem (Algebra.adjoin K ({t} : Set F)) a)
+    obtain ⟨v, hv⟩ := AlgebraicCurve.Place.exists_of_valuationSubring_of_isSeparable x V hK htop
+    have htV : t ∈ v.toValuationSubring := by
+      rw [hv]; exact hV (Algebra.subset_adjoin (Set.mem_singleton t))
+    have h2 := h v htV
+    rwa [hv] at h2
+  exact key
+
+end S_AlgebraicCurve_isIntegral_adjoin_of_forall_mem_toValuationSubring
+end P2MW
+export P2MW.S_AlgebraicCurve_isIntegral_adjoin_of_forall_mem_toValuationSubring (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.isIntegral_adjoin_of_forall_mem_toValuationSubring
+    {K F : Type*} [Field K] [Field F] [Algebra K F] (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F]
+    (t z : F)
+    (h : ∀ v : AlgebraicCurve.Place K F, t ∈ v.toValuationSubring → z ∈ v.toValuationSubring) :
+    IsIntegral (Algebra.adjoin K ({t} : Set F)) z :=
+  solution x t z h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isIntegral_adjoin_of_forall_ord_nonneg.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isIntegral_adjoin_of_forall_ord_nonneg.lean
new file mode 100644
index 0000000000..8f472aec33
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isIntegral_adjoin_of_forall_ord_nonneg.lean
@@ -0,0 +1,192 @@
+/-
+Based on Prove2Me node AlgebraicCurve.isIntegral_adjoin_of_forall_ord_nonneg
+(926846d9-743f-5935-bbb7-e64fb2222eed) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 09d415ca-fcda-507b-a540-1241516c7dff
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_of_valuationSubring
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# No poles where t is regular implies integrality over K[t]
+
+Theorem statement: `AlgebraicCurve.isIntegral_adjoin_of_forall_ord_nonneg`
+(`926846d9-743f-5935-bbb7-e64fb2222eed`), by Claude, 2026-09-05.
+
+Proof: submission `09d415ca-fcda-507b-a540-1241516c7dff`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, $K$ of characteristic zero, and let $t \in F$ be
+transcendental over $K$, with $F$ finite-dimensional over the intermediate field $K(t) =$
+`IntermediateField.adjoin K {t}`, and assume $F/K$ has principal divisors, i.e. every nonzero $f \in
+F$ admits a finitely supported function $D$ on the places of $F/K$ with $D(v) = \operatorname{ord}_v
+f$ for all $v$ and $\deg D = 0$. Here a place of $F/K$ is a valuation subring of $F$ that contains
+the image of $K$, is not all of $F$, and is a principal ideal ring, and $\operatorname{ord}_v f$ is
+the negative of the logarithm of the value of $f$ under the adic valuation attached to the
+height-one prime of $v$. Let $z \in F$ be such that $\operatorname{ord}_v z \ge 0$ for every place
+$v$ with $\operatorname{ord}_v t \ge 0$. Then $z$ is integral over the $K$-subalgebra $K[t] =$
+`Algebra.adjoin K {t}` of $F$.
+
+This is the classical description of the integral closure of $K[t]$ in a one-variable function field
+$F/K$ as the intersection of the valuation rings of the places at which $t$ has no pole (Stichtenoth
+III.2.6). It is used repeatedly in the construction of integral models of modular curves, e.g. in
+the verification that $q$-expansion coefficients lie in the relevant chart algebras and in the
+analysis of maximal ideals and trace relations for level structures.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_isIntegral_adjoin_of_forall_ord_nonneg.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_isIntegral_adjoin_of_forall_ord_nonneg
+
+open AlgebraicCurve Polynomial
+
+namespace INTGlue
+
+theorem isIntegral_of_mem_adjoin_inv {A F : Type*} [CommRing A] [Field F] [Algebra A F]
+    {z : F} (hz0 : z ≠ 0) (hmem : z ∈ Algebra.adjoin A ({z⁻¹} : Set F)) : IsIntegral A z := by
+  classical
+  rw [Algebra.adjoin_singleton_eq_range_aeval] at hmem
+  obtain ⟨p, hp⟩ := hmem
+  have hp' : aeval z⁻¹ p = z := hp
+  have hdeg : (∑ i ∈ Finset.range (p.natDegree + 1), C (p.coeff i) * X ^ (p.natDegree - i)).degree ≤
+      (p.natDegree : WithBot ℕ) := by
+    refine (Polynomial.degree_sum_le _ _).trans (Finset.sup_le fun i _ => ?_)
+    exact (Polynomial.degree_C_mul_X_pow_le _ _).trans (by exact_mod_cast Nat.sub_le _ _)
+  refine ⟨X ^ (p.natDegree + 1) - ∑ i ∈ Finset.range (p.natDegree + 1), C (p.coeff i) * X ^
+    (p.natDegree - i),
+    Polynomial.monic_X_pow_sub (hdeg.trans_lt (by exact_mod_cast Nat.lt_succ_self _)), ?_⟩
+  have hz : z = ∑ i ∈ Finset.range (p.natDegree + 1), algebraMap A F (p.coeff i) * z⁻¹ ^ i := by
+    conv_lhs => rw [← hp']
+    rw [Polynomial.aeval_eq_sum_range]
+    simp only [Algebra.smul_def]
+  have hzpow : ∀ i ∈ Finset.range (p.natDegree + 1), z ^ p.natDegree * z⁻¹ ^ i = z ^ (p.natDegree -
+    i) :=
+    by
+    intro i hi
+    have hi' : i ≤ p.natDegree := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)
+    obtain ⟨k, hk⟩ := Nat.exists_eq_add_of_le hi'
+    rw [hk, Nat.add_sub_cancel_left, pow_add, mul_comm (z ^ i) (z ^ k), mul_assoc, ← mul_pow,
+      mul_inv_cancel₀ hz0, one_pow, mul_one]
+  rw [eval₂_sub, sub_eq_zero, eval₂_pow, eval₂_X, eval₂_finsetSum]
+  simp only [eval₂_mul, eval₂_C, eval₂_pow, eval₂_X]
+  rw [pow_succ]
+  conv_lhs => arg 2; rw [hz]
+  rw [Finset.mul_sum]
+  refine Finset.sum_congr rfl fun i hi => ?_
+  rw [mul_left_comm, hzpow i hi]
+
+theorem isIntegral_of_forall_valuationSubring {F : Type*} [Field F] (A : Subring F) (z : F)
+    (h : ∀ V : ValuationSubring F, A ≤ V.toSubring → z ∈ V) : IsIntegral A z := by
+  classical
+  by_contra hnot
+  have hz0 : z ≠ 0 := by rintro rfl; exact hnot isIntegral_zero
+  set y : F := z⁻¹ with hy
+  let B : Subalgebra A F := Algebra.adjoin A ({y} : Set F)
+  have hyB : y ∈ B := Algebra.subset_adjoin (Set.mem_singleton y)
+  have hzB : z ∉ B := fun hzB => hnot (isIntegral_of_mem_adjoin_inv hz0 hzB)
+  have hyu : (⟨y, hyB⟩ : B) ∈ nonunits B := by
+    intro hu
+    obtain ⟨u, hu⟩ := hu
+    have hinv : ((u⁻¹ : Bˣ) : B).1 = z := by
+      have h1 : ((u : B) : F) * ((u⁻¹ : Bˣ) : B) = 1 := by
+        rw [← Subalgebra.coe_mul, Units.mul_inv]; rfl
+      rw [hu] at h1
+      have : y⁻¹ = ((u⁻¹ : Bˣ) : B).1 := inv_eq_of_mul_eq_one_right h1
+      rw [← this, hy, inv_inv]
+    exact hzB (hinv ▸ ((u⁻¹ : Bˣ) : B).2)
+  obtain ⟨m, hm, hym⟩ := exists_max_ideal_of_mem_nonunits hyu
+  let Bs : Subring F := B.toSubring
+  let m' : Ideal Bs := m
+  have : m'.IsMaximal := hm
+  let L : LocalSubring F := LocalSubring.ofPrime Bs m'
+  obtain ⟨V, hV⟩ := L.exists_le_valuationSubring
+  obtain ⟨hLV, hloc⟩ := LocalSubring.le_def.mp hV
+  have hBL : Bs ≤ L.toSubring := LocalSubring.le_ofPrime Bs m'
+  have hAV : A ≤ V.toSubring := by
+    intro a ha
+    have : (a : F) ∈ Bs := by
+      change a ∈ B
+      exact Subalgebra.algebraMap_mem B ⟨a, ha⟩
+    exact hLV (hBL this)
+  have hzV : z ∈ V := h V hAV
+  have hyL : (algebraMap Bs L.toSubring ⟨y, hyB⟩) ∈ IsLocalRing.maximalIdeal L.toSubring :=
+    (IsLocalization.AtPrime.to_map_mem_maximal_iff L.toSubring m' ⟨y, hyB⟩).mpr hym
+  have hcoe : ((algebraMap Bs L.toSubring ⟨y, hyB⟩ : L.toSubring) : F) = y := by
+    change algebraMap L.toSubring F (algebraMap Bs L.toSubring ⟨y, hyB⟩) = y
+    rw [← IsScalarTower.algebraMap_apply Bs L.toSubring F]
+    rfl
+  have hyV' : ¬ IsUnit (Subring.inclusion hLV (algebraMap Bs L.toSubring ⟨y, hyB⟩)) := by
+    intro hu
+    have := (IsLocalRing.mem_maximalIdeal _).mp hyL
+    exact this (hloc.map_nonunit _ hu)
+  apply hyV'
+  have hyVmem : y ∈ V := by
+    have := (Subring.inclusion hLV (algebraMap Bs L.toSubring ⟨y, hyB⟩)).2
+    rwa [Subring.coe_inclusion, hcoe] at this
+  refine isUnit_iff_exists_inv.mpr ⟨⟨z, hzV⟩, ?_⟩
+  ext
+  simp only [Subring.coe_mul, Subring.coe_inclusion, hcoe, Subring.coe_one]
+  rw [hy, inv_mul_cancel₀ hz0]
+
+end INTGlue
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [CharZero K] (t : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({t} : Set F)) F]
+    [AlgebraicCurve.HasPrincipalDivisors K F] (z : F)
+    (hz : ∀ v : AlgebraicCurve.Place K F, 0 ≤ v.ord t → 0 ≤ v.ord z) :
+    IsIntegral (Algebra.adjoin K ({t} : Set F)) z := by
+  classical
+  have key : IsIntegral (Algebra.adjoin K ({t} : Set F)).toSubring z := by
+    refine INTGlue.isIntegral_of_forall_valuationSubring _ z fun V hV => ?_
+    by_cases hz0 : z = 0
+    · rw [hz0]; exact V.zero_mem
+    by_cases htop : V = ⊤
+    · rw [htop]; exact ValuationSubring.mem_top z
+    have hK : ∀ a : K, algebraMap K F a ∈ V := fun a =>
+      hV (Subalgebra.algebraMap_mem (Algebra.adjoin K ({t} : Set F)) a)
+    obtain ⟨v, hv⟩ := AlgebraicCurve.Place.exists_of_valuationSubring t V hK htop
+    have htV : t ∈ v.toValuationSubring := by
+      rw [hv]; exact hV (Algebra.subset_adjoin (Set.mem_singleton t))
+    have h1 : 0 ≤ v.ord t := v.ord_nonneg_of_mem htV
+    have h2 := AlgebraicCurve.Place.mem_of_ord_nonneg v hz0 (hz v h1)
+    rwa [hv] at h2
+  exact key
+
+end S_AlgebraicCurve_isIntegral_adjoin_of_forall_ord_nonneg
+end P2MW
+export P2MW.S_AlgebraicCurve_isIntegral_adjoin_of_forall_ord_nonneg (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.isIntegral_adjoin_of_forall_ord_nonneg {K F : Type*} [Field K] [Field F]
+    [Algebra K F] [CharZero K] (t : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({t} : Set F)) F]
+    [AlgebraicCurve.HasPrincipalDivisors K F] (z : F)
+    (hz : ∀ v : AlgebraicCurve.Place K F, 0 ≤ v.ord t → 0 ≤ v.ord z) :
+    IsIntegral (Algebra.adjoin K ({t} : Set F)) z :=
+  solution t z hz
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isIntegral_adjoin_of_isScalarTower.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isIntegral_adjoin_of_isScalarTower.lean
new file mode 100644
index 0000000000..e1c7a2d7ce
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_isIntegral_adjoin_of_isScalarTower.lean
@@ -0,0 +1,78 @@
+/-
+Based on Prove2Me node AlgebraicCurve.isIntegral_adjoin_of_isScalarTower
+(888dcf54-bd3c-52ac-9c4a-de111f6a37be) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8df45cc6-bd84-55d2-8e35-86b947fe5012
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.Adjoin.Polynomial.Basic
+public import Mathlib.RingTheory.IntegralClosure.IsIntegral.Defs
+
+import Mathlib.RingTheory.IntegralClosure.IsIntegral.Basic
+import Mathlib.Algebra.Algebra.Subalgebra.Tower
+
+/-!
+# Integrality over K[j] passes to L[j] in a tower
+
+Theorem statement: `AlgebraicCurve.isIntegral_adjoin_of_isScalarTower`
+(`888dcf54-bd3c-52ac-9c4a-de111f6a37be`), by Claude, 2026-09-05.
+
+Proof: submission `8df45cc6-bd84-55d2-8e35-86b947fe5012`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $L$ and $F$ be commutative rings equipped with algebra structures making $F$ an algebra
+over $L$, $L$ an algebra over $K$ and $F$ an algebra over $K$, with the three structure maps
+compatible (an `IsScalarTower K L F` hypothesis: scalar multiplication by $K$ on $F$ factors through
+$L$). Let $j$ and $x$ be elements of $F$. The hypothesis is that $x$ is integral over the
+$K$-subalgebra $\mathrm{Algebra.adjoin}\ K\ \{j\}$ of $F$ generated by $j$, that is, $x$ is a root
+of a monic polynomial with coefficients in that subalgebra. The conclusion is that $x$ is likewise
+integral over the $L$-subalgebra $\mathrm{Algebra.adjoin}\ L\ \{j\}$ of $F$ generated by $j$. No
+finiteness, reducedness or domain assumptions are imposed on any of the three rings.
+
+This is the elementary transitivity observation that enlarging the ring of scalars from $K[j]$ to
+$L[j]$ inside $F$ preserves integrality; in the modular-curve part of the development it is used to
+pass from integrality over $\mathbb{Q}[j]$ to integrality over $\bar{\mathbb{Q}}[j]$, and it is
+invoked in the study of $q$-expansions, of finite-dimensionality of algebras generated by $j(q)$,
+and of cuspidal classes.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_isIntegral_adjoin_of_isScalarTower.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+theorem solution {K L F : Type*} [CommRing K] [CommRing L] [CommRing F]
+    [Algebra K L] [Algebra K F] [Algebra L F] [IsScalarTower K L F] {j x : F}
+    (hx : IsIntegral (Algebra.adjoin K {j}) x) : IsIntegral (Algebra.adjoin L {j}) x := by
+  have hsub : Algebra.adjoin K {j} ≤ Subalgebra.restrictScalars K (Algebra.adjoin L {j}) :=
+    Algebra.adjoin_le (Set.singleton_subset_iff.mpr
+      ((Subalgebra.mem_restrictScalars K).mpr (Algebra.subset_adjoin rfl)))
+  let φ' : ↥(Algebra.adjoin K {j}) →+* ↥(Algebra.adjoin L {j}) :=
+    { toFun := fun a => ⟨(a : F), (Subalgebra.mem_restrictScalars K).mp (hsub a.2)⟩
+      map_one' := rfl
+      map_mul' := fun _ _ => rfl
+      map_zero' := rfl
+      map_add' := fun _ _ => rfl }
+  exact IsIntegral.map_of_comp_eq φ' (RingHom.id F) (by ext a; rfl) hx
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.isIntegral_adjoin_of_isScalarTower
+    {K L F : Type*} [CommRing K] [CommRing L] [CommRing F]
+    [Algebra K L] [Algebra K F] [Algebra L F] [IsScalarTower K L F] {j x : F}
+    (hx : IsIntegral (Algebra.adjoin K {j}) x) : IsIntegral (Algebra.adjoin L {j}) x := by
+  exact solution hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_kaehlerRankOne_of_transcendental.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_kaehlerRankOne_of_transcendental.lean
new file mode 100644
index 0000000000..fd55ba8038
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_kaehlerRankOne_of_transcendental.lean
@@ -0,0 +1,150 @@
+/-
+Based on Prove2Me node AlgebraicCurve.kaehlerRankOne_of_transcendental
+(4dc3da55-8bb5-5803-9131-85f94c90f6f4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e3b8f68c-c606-5a58-93e4-cb393c668caa
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Defs
+public import Mathlib.FieldTheory.Separable
+public import Mathlib.RingTheory.Kaehler.Basic
+
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import Mathlib.RingTheory.Etale.Field
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Ω_{F/K} is free of rank one over a separable extension of K(x)
+
+Theorem statement: `AlgebraicCurve.kaehlerRankOne_of_transcendental`
+(`4dc3da55-8bb5-5803-9131-85f94c90f6f4`), by Claude, 2026-09-05.
+
+Proof: submission `e3b8f68c-c606-5a58-93e4-cb393c668caa`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $x \in F$ be an element transcendental
+over $K$, i.e. not algebraic over $K$. Assume that $F$ is a separable algebraic extension of the
+intermediate field $K(x) =$ `IntermediateField.adjoin K {x}` generated by $x$ (the hypothesis
+`Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F`, which includes that every
+element of $F$ is algebraic over $K(x)$ with separable minimal polynomial). The conclusion is the
+conjunction of two assertions about the module $\Omega_{F/K}$ of Kähler differentials of $F$ over
+$K$, regarded as an $F$-module: it is a free $F$-module, and its rank `Module.finrank F Ω[F⁄K]`
+equals $1$. No finiteness hypothesis on the extension $F/K(x)$ is imposed, and no basis is exhibited
+in the statement itself (the assertion is freeness together with the numerical value of the rank).
+
+This is the standard computation that a function field in one variable which is separably generated
+has a one-dimensional space of Kähler differentials, $\Omega_{F/K} = F\,dx$. It feeds the
+construction of curves over a field in this development, being cited by
+[`AlgebraicCurve.isCurveOver_of_transcendental`]
+(thm.html#AlgebraicCurve.isCurveOver_of_transcendental)
+and by
+[`AlgebraicCurve.exists_isCurveOver_adjoin_range_eq_top_apply_algEquiv_eq_pow_of_pow_eq_one`]
+(thm.html#AlgebraicCurve.
+exists_isCurveOver_adjoin_range_eq_top_apply_algEquiv_eq_pow_of_pow_eq_one).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_kaehlerRankOne_of_transcendental.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_kaehlerRankOne_of_transcendental
+
+
+noncomputable section
+
+open IntermediateField Polynomial TensorProduct Module
+
+namespace S12Kaehler
+
+variable (K : Type*) [Field K]
+
+def kaehlerPolynomialBasis : Basis Unit K[X] Ω[K[X]⁄K] :=
+  (Basis.singleton Unit K[X]).map (KaehlerDifferential.polynomialEquiv K).symm
+
+scoped instance instFormallyEtalePolynomialRatFunc : Algebra.FormallyEtale K[X] (RatFunc K) :=
+  Algebra.FormallyEtale.of_isLocalization (nonZeroDivisors K[X])
+
+def kaehlerRatFuncBasis : Basis Unit (RatFunc K) Ω[(RatFunc K)⁄K] :=
+  ((kaehlerPolynomialBasis K).baseChange (RatFunc K)).map
+    (KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale K K[X] (RatFunc K))
+
+variable {F : Type*} [Field F] [Algebra K F]
+
+def kaehlerOfRatFuncTowerBasis [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [Algebra.IsSeparable (RatFunc K) F] : Basis Unit F Ω[F⁄K] :=
+  haveI : Algebra.FormallyEtale (RatFunc K) F := Algebra.FormallyEtale.of_isSeparable _ _
+  ((kaehlerRatFuncBasis K).baseChange F).map
+    (KaehlerDifferential.tensorKaehlerEquivOfFormallyEtale K (RatFunc K) F)
+
+theorem kaehlerRankOne_of_ratFuncTower [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [Algebra.IsSeparable (RatFunc K) F] : Module.Free F Ω[F⁄K] ∧ Module.finrank F Ω[F⁄K] = 1 :=
+  ⟨Module.Free.of_basis (kaehlerOfRatFuncTowerBasis K),
+    (Module.finrank_eq_card_basis (kaehlerOfRatFuncTowerBasis K)).trans (by simp)⟩
+
+variable {K}
+
+theorem kaehlerRankOne_of_transcendental {x : F} (htr : Transcendental K x)
+    (hsep : Algebra.IsSeparable K⟮x⟯ F) : Module.Free F Ω[F⁄K] ∧ Module.finrank F Ω[F⁄K] = 1 := by
+  have := hsep
+  let e : RatFunc K ≃ₐ[K] K⟮x⟯ := RatFunc.algEquivOfTranscendental x htr
+  let : Algebra (RatFunc K) F :=
+    ((algebraMap K⟮x⟯ F).comp e.toAlgHom.toRingHom).toAlgebra
+  have hsq : RingHom.comp (algebraMap (RatFunc K) F)
+        (e.symm.toRingEquiv : K⟮x⟯ →+* RatFunc K)
+      = RingHom.comp (RingEquiv.refl F : F →+* F) (algebraMap K⟮x⟯ F) := by
+    refine RingHom.ext fun a => ?_
+    change algebraMap K⟮x⟯ F (e (e.symm a)) = algebraMap K⟮x⟯ F a
+    rw [e.apply_symm_apply]
+  have : IsScalarTower K (RatFunc K) F :=
+    IsScalarTower.of_algebraMap_eq fun a => by
+      change algebraMap K F a = algebraMap K⟮x⟯ F (e (algebraMap K (RatFunc K) a))
+      rw [e.commutes, ← IsScalarTower.algebraMap_apply]
+  have : Algebra.IsSeparable (RatFunc K) F :=
+    Algebra.IsSeparable.of_equiv_equiv e.symm.toRingEquiv (RingEquiv.refl F) hsq
+  exact kaehlerRankOne_of_ratFuncTower K
+
+end S12Kaehler
+end
+
+theorem solution
+    {K F : Type*} [Field K] [Field F] [Algebra K F]
+    {x : F} (htr : Transcendental K x)
+    (hsep : Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F) :
+    Module.Free F Ω[F⁄K] ∧ Module.finrank F Ω[F⁄K] = 1 := by
+  exact S12Kaehler.kaehlerRankOne_of_transcendental htr hsep
+
+end S_AlgebraicCurve_kaehlerRankOne_of_transcendental
+end P2MW
+export P2MW.S_AlgebraicCurve_kaehlerRankOne_of_transcendental (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open KaehlerDifferential
+theorem AlgebraicCurve.kaehlerRankOne_of_transcendental
+    {K F : Type*} [Field K] [Field F] [Algebra K F]
+    {x : F} (htr : Transcendental K x)
+    (hsep : Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F) :
+    Module.Free F Ω[F⁄K] ∧ Module.finrank F Ω[F⁄K] = 1 :=
+  solution htr hsep
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_lSpace_eq_bot_of_degree_neg.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_lSpace_eq_bot_of_degree_neg.lean
new file mode 100644
index 0000000000..f1adee618e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_lSpace_eq_bot_of_degree_neg.lean
@@ -0,0 +1,137 @@
+/-
+Based on Prove2Me node AlgebraicCurve.lSpace_eq_bot_of_degree_neg
+(193c3207-9415-57ea-b35e-c8a7e63242ce) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9d0986d2-565d-5075-ac2e-80e33c9c2f69
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# L(D)=0 for divisors of negative degree
+
+Theorem statement: `AlgebraicCurve.lSpace_eq_bot_of_degree_neg`
+(`193c3207-9415-57ea-b35e-c8a7e63242ce`), by Claude, 2026-09-05.
+
+Proof: submission `9d0986d2-565d-5075-ac2e-80e33c9c2f69`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K \subseteq F$ be fields with $F$ a $K$-algebra, and let $D$ be a divisor of $F/K$, that is, a
+finitely supported function from the set of places of $F/K$ to $\mathbb{Z}$; here a place is a
+valuation subring $\mathcal{O}_v \subsetneq F$ which contains the image of $K$ and is a principal
+ideal ring. Assume $F/K$ satisfies `IsCurveOver`: every nonzero $f \in F$ admits a divisor $P$ with
+$P(v) = \operatorname{ord}_v(f)$ at every place $v$ and $\deg P = 0$; every residue field
+$\mathcal{O}_v/\mathfrak{m}_v$ is finite-dimensional over $K$; and $\Omega_{F/K}$ is free of rank
+$1$ over $F$. Assume further that $\deg D = \sum_v D(v)\,\deg v < 0$. Then the Riemann–Roch space
+`LSpace D`, the $K$-submodule of those $f \in F$ with $v(f) \le \exp(D(v))$ for all places $v$, is
+the zero submodule. Of the `IsCurveOver` data the proof uses only the existence of degree-zero
+principal divisors.
+
+This is the standard first consequence of the degree formalism in the theory of function fields of
+one variable: a divisor of negative degree has trivial Riemann–Roch space. It underlies the
+computation of $\ell(D) = \dim_K L(D)$ and is invoked throughout the Riemann–Roch development, for
+instance in the finiteness and descent statements for Riemann–Roch spaces under reduction and
+constant field extension.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_lSpace_eq_bot_of_degree_neg.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_lSpace_eq_bot_of_degree_neg
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor Divisor.degree HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor IsCurveOver LSpace ell mem_lSpace_iff_ord \
+  WeilDifferentialRankOne StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "deg ord ord_unit_smul_zpow exists_unit_mul_zpow \
+  toValuationSubring"
+p2m_open "AlgebraicCurve.Place"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+p2m_export "AlgebraicCurve.Place" "ord_nonneg_of_mem"
+p2m_export "AlgebraicCurve.Place" "mem_of_ord_nonneg"
+theorem mem_iff_ord_nonneg {f : F} (hf : f ≠ 0) :
+    f ∈ v.toValuationSubring ↔ 0 ≤ v.ord f :=
+  ⟨v.ord_nonneg_of_mem, v.mem_of_ord_nonneg hf⟩
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor Divisor.degree HasPrincipalDivisors \
+  HasPrincipalDivisors.exists_divisor IsCurveOver LSpace ell mem_lSpace_iff_ord \
+  WeilDifferentialRankOne StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "degree"
+end Divisor
+variable {D : Divisor K F}
+p2m_open_scoped "AlgebraicCurve.Divisor" in
+theorem Divisor.degree_nonneg_of_nonneg [IsCurveOver K F]
+    {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) : 0 ≤ Divisor.degree D := by
+  rw [Divisor.degree_eq_sum_support]
+  exact Finset.sum_nonneg fun v _ => mul_nonneg (hD v) (Int.natCast_nonneg _)
+theorem lSpace_eq_bot_of_degree_neg_port [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) : LSpace D = ⊥ := by
+  rw [eq_bot_iff]
+  intro f hf
+  rw [Submodule.mem_bot]
+  by_contra hf0
+  obtain ⟨P, hPord, hPdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+  have heff : ∀ v : Place K F, 0 ≤ (P + D) v := by
+    intro v
+    rw [Finsupp.add_apply, hPord]
+    rcases mem_lSpace_iff_ord.mp hf with rfl | h
+    · exact absurd rfl hf0
+    · linarith [h v]
+  have hdegPD : 0 ≤ Divisor.degree (P + D) := Divisor.degree_nonneg_of_nonneg heff
+  rw [map_add, hPdeg, zero_add] at hdegPD
+  exact absurd hdegPD (not_le.mpr hD)
+end AlgebraicCurve
+
+open _root_.AlgebraicCurve _root_.P2MW.S_AlgebraicCurve_lSpace_eq_bot_of_degree_neg.AlgebraicCurve
+  in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] {D : Divisor K F} [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) : LSpace D = ⊥ :=
+  AlgebraicCurve.lSpace_eq_bot_of_degree_neg_port (K := K) (F := F) (D := D) (hD := hD)
+
+end S_AlgebraicCurve_lSpace_eq_bot_of_degree_neg
+end P2MW
+export P2MW.S_AlgebraicCurve_lSpace_eq_bot_of_degree_neg (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace AlgebraicCurve
+theorem lSpace_eq_bot_of_degree_neg {K F : Type*} [Field K] [Field F] [Algebra K F]
+    {D : Divisor K F} [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) : LSpace D = ⊥ :=
+  solution hD
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_lSpace_mapDomain_subset_span_image_lSpace_of_constantFieldExtension_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_lSpace_mapDomain_subset_span_image_lSpace_of_constantFieldExtension_of_isAlgClosed.lean
new file mode 100644
index 0000000000..0e855f1f4e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_lSpace_mapDomain_subset_span_image_lSpace_of_constantFieldExtension_of_isAlgClosed.lean
@@ -0,0 +1,244 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.lSpace_mapDomain_subset_span_image_lSpace_of_constantFieldExtension_of_isAlgClosed
+(f2d2bd84-f499-5483-aa53-90e12e67fe5d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3ff2149c-0891-52bc-a2fa-1265d075fe39
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_mem_riemannRochSpace_of_sum_basis_smul_algebraMap_mem_mapDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_mem_span_range_algebraMap_of_constantFieldExtension_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Descent of Riemann–Roch spaces along a constant field extension
+
+Theorem statement:
+`AlgebraicCurve.lSpace_mapDomain_subset_span_image_lSpace_of_constantFieldExtension_of_isAlgClosed`
+(`f2d2bd84-f499-5483-aa53-90e12e67fe5d`), by Claude, 2026-09-05.
+
+Proof: submission `3ff2149c-0891-52bc-a2fa-1265d075fe39`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K \subseteq K'$ and $F \subseteq F'$ be fields with $F/K$, $F'/K'$, $K'/K$, $F'/F$ and $F'/K$
+algebras compatible in the two scalar towers $K \to K' \to F'$ and $K \to F \to F'$, with $K$ and
+$K'$ algebraically closed and both $F/K$ and $F'/K'$ satisfying `IsCurveOver`: every nonzero
+function has a divisor of degree zero recording its orders at all places, every place has residue
+field finite over the base field, and the module of Kähler differentials is free of rank one over
+the function field. Here a place is a valuation subring, different from the whole field, containing
+the image of the base field and a principal ideal ring, and a divisor is a finitely supported
+integer-valued function on places. Assume $F$ is finite over $K(x)$ for some $x$ transcendental over
+$K$, likewise $F'$ over $K'(x')$, and that $F'$ is generated over $K'$ by the image of $F$. Let
+$\mathrm{lift}$ be an injective map from places of $F/K$ to places of $F'/K'$ preserving orders,
+$(\mathrm{lift}\,P).\mathrm{ord}(f) = P.\mathrm{ord}(f)$ for all $f \in F$, and such that no place
+of $F'/K'$ outside its image pulls back along $F \to F'$ to the valuation subring of a place of
+$F/K$. Then for a divisor $D$ on $F/K$, every $f'$ in the Riemann–Roch space of the pushforward
+divisor $\mathrm{lift}_*D$, i.e. with $v'(f') \le \exp((\mathrm{lift}_*D)(v'))$ for all places $v'$
+of $F'/K'$, lies in the $K'$-span of the image in $F'$ of the Riemann–Roch space of $D$.
+
+This is the inclusion $L'(\mathrm{Con}\,D) \subseteq K' \cdot L(D)$, the substantive half of the
+equality $L'(\mathrm{Con}\,D) = K' \otimes_K L(D)$ for a constant field extension of function fields
+(Stichtenoth, Theorem 3.6.3(a)). It is used to show that the dimension $\ell(D)$ is unchanged by
+such an extension, that the conorm map on degree-zero divisor classes is injective, and in an
+estimate for hyperplane sections on modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_lSpace_mapDomain_subset_span_image_lSpace_of_constantFieldExtension_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_8889c9fb
+
+
+open AlgebraicCurve
+
+namespace W7XChildJ
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+theorem ord_nonneg_of_mem {f : F} (hf : f ∈ v.toValuationSubring) : 0 ≤ v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨n, u, hu⟩ :=
+    IsDiscreteValuationRing.eq_unit_mul_pow_irreducible
+      (x := (⟨f, hf⟩ : v.toValuationSubring)) (by simpa [Subtype.ext_iff] using hf0) hπ
+  have hcoe : f = ((u : v.toValuationSubring) : F) * ((π : F) ^ (n : ℤ)) := by
+    have h := congrArg (Subtype.val) hu
+    push_cast at h
+    rw [zpow_natCast]
+    exact h
+  rw [hcoe, v.ord_unit_smul_zpow u hπ (n : ℤ)]
+  exact Int.natCast_nonneg n
+
+theorem one_le_ord_of_mem_of_inv_not_mem {f : F} (h1 : f ∈ v.toValuationSubring)
+    (h2 : f⁻¹ ∉ v.toValuationSubring) : 1 ≤ v.ord f := by
+  have hf0 : f ≠ 0 := by rintro rfl; exact h2 (by simp)
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf0 hπ
+  have h0 := ord_nonneg_of_mem v h1
+  by_contra hlt
+  have hz : v.ord f = 0 := by omega
+  apply h2
+  have hmul : ((u : v.toValuationSubring) : F) *
+      (((u⁻¹ : v.toValuationSubringˣ) : v.toValuationSubring) : F) = 1 := by
+    rw [← MulMemClass.coe_mul, Units.mul_inv, OneMemClass.coe_one]
+  rw [hu, hz, zpow_zero, mul_one, ← eq_inv_of_mul_eq_one_right hmul]
+  exact SetLike.coe_mem _
+
+theorem mem_iff_ord_nonneg (f : F) : f ∈ v.toValuationSubring ↔ 0 ≤ v.ord f := by
+  refine ⟨ord_nonneg_of_mem v, fun h => ?_⟩
+  by_contra hmem
+  have hinv : f⁻¹ ∈ v.toValuationSubring :=
+    (v.toValuationSubring.mem_or_inv_mem f).resolve_left hmem
+  have := one_le_ord_of_mem_of_inv_not_mem v hinv (by simpa using hmem)
+  rw [v.ord_inv] at this
+  omega
+
+end W7XChildJ
+
+open W7XChildJ
+
+theorem solution
+    (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [IsAlgClosed K'] [IsCurveOver K F] [IsCurveOver K' F']
+    (hfg : ∃ x : F, Transcendental K x ∧
+      FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤)
+    (lift : Place K F → Place K' F')
+    (hlift_ord : ∀ (P : Place K F) (f : F), (lift P).ord (algebraMap F F' f) = P.ord f)
+    (hlift_inj : Function.Injective lift)
+    (D : Divisor K F) {f' : F'}
+    (hf' : f' ∈ LSpace (K := K') (Finsupp.mapDomain lift D)) :
+    f' ∈ Submodule.span K' ((algebraMap F F') '' (LSpace (K := K) D : Set F)) := by
+  classical
+  have hnew : ∀ v' : Place K' F', (∀ v : Place K F,
+      v'.toValuationSubring.comap (algebraMap F F') ≠ v.toValuationSubring) →
+      f' ∈ v'.toValuationSubring := by
+    intro v' hv'
+    have hnr : ∀ v, lift v ≠ v' := fun v hev => hv' v (by
+      rw [← hev]; ext g
+      rw [ValuationSubring.mem_comap, mem_iff_ord_nonneg, mem_iff_ord_nonneg, hlift_ord])
+    have hD0 : (Finsupp.mapDomain lift D) v' = 0 :=
+      Finsupp.mapDomain_of_notMem_range D v' (by simpa [Set.range] using hnr)
+    rcases mem_lSpace_iff_ord.mp hf' with rfl | hord
+    · exact zero_mem _
+    · rw [mem_iff_ord_nonneg]; have := hord v'; rw [hD0, neg_zero] at this; exact this
+  have hspan' : f' ∈ Submodule.span K' (Set.range (algebraMap F F')) :=
+    mem_span_range_algebraMap_of_constantFieldExtension_of_isAlgClosed
+      K F K' F' hfg hfg' hgen f' hnew
+  let B := Module.Basis.ofVectorSpace K K'
+  obtain ⟨c, hc⟩ := Finsupp.mem_span_range_iff_exists_finsupp.mp hspan'
+  let g : Module.Basis.ofVectorSpaceIndex K K' →₀ F :=
+    (Finsupp.ofSupportFinite
+      (fun j => ∑ f ∈ c.support, (B.repr (c f) j) • f)
+      ((c.support.finite_toSet.biUnion fun f _ => (B.repr (c f)).support.finite_toSet).subset
+        (fun j hj => by
+          simp only [Function.mem_support, ne_eq] at hj
+          simp only [Set.mem_iUnion, Finset.mem_coe, Finsupp.mem_support_iff, ne_eq]
+          by_contra h; push Not at h
+          exact hj (Finset.sum_eq_zero fun f hf => by
+            rw [h f (Finsupp.mem_support_iff.mp hf), zero_smul]))))
+  have hf'eq : f' = ∑ j ∈ g.support, algebraMap K' F' (B j) * algebraMap F F' (g j) := by
+    have hgj : ∀ j, (g j : F) = ∑ f ∈ c.support, B.repr (c f) j • f := fun _ => rfl
+    let S : Finset _ := c.support.biUnion fun f => (B.repr (c f)).support
+    have hgsub : g.support ⊆ S := by
+      intro j hj
+      rw [Finsupp.mem_support_iff, hgj] at hj
+      simp only [S, Finset.mem_biUnion, Finsupp.mem_support_iff]
+      by_contra h; push Not at h
+      exact hj (Finset.sum_eq_zero fun f hf => by
+        rw [h f (Finsupp.mem_support_iff.mp hf), zero_smul])
+    have hcf_S : ∀ f ∈ c.support, c f = ∑ j ∈ S, B.repr (c f) j • B j := by
+      intro f hf
+      conv_lhs => rw [← B.linearCombination_repr (c f), Finsupp.linearCombination_apply,
+        Finsupp.sum]
+      refine Finset.sum_subset ?_ fun j _ hj => by
+        rw [Finsupp.notMem_support_iff.mp hj, zero_smul]
+      exact Finset.subset_biUnion_of_mem (fun f => (B.repr (c f)).support) hf
+    have hterm : ∀ (j : Module.Basis.ofVectorSpaceIndex K K') (f : F),
+        algebraMap K' F' (B.repr (c f) j • B j) * algebraMap F F' f =
+        algebraMap K' F' (B j) * algebraMap F F' (B.repr (c f) j • f) := by
+      intro j f
+      rw [Algebra.smul_def (R := K) (A := K'), map_mul,
+        Algebra.smul_def (R := K) (A := F), map_mul,
+        ← IsScalarTower.algebraMap_apply K K' F',
+        ← IsScalarTower.algebraMap_apply K F F']
+      ring
+    calc f' = ∑ f ∈ c.support, c f • algebraMap F F' f := by
+          rw [← hc]; rfl
+      _ = ∑ f ∈ c.support, ∑ j ∈ S,
+            algebraMap K' F' (B.repr (c f) j • B j) * algebraMap F F' f := by
+          refine Finset.sum_congr rfl fun f hf => ?_
+          conv_lhs => rw [Algebra.smul_def, hcf_S f hf]
+          rw [map_sum, Finset.sum_mul]
+      _ = ∑ j ∈ S, ∑ f ∈ c.support,
+            algebraMap K' F' (B j) * algebraMap F F' (B.repr (c f) j • f) := by
+          rw [Finset.sum_comm]
+          exact Finset.sum_congr rfl fun j _ => Finset.sum_congr rfl fun f _ => hterm j f
+      _ = ∑ j ∈ S, algebraMap K' F' (B j) * algebraMap F F' (g j) := by
+          refine Finset.sum_congr rfl fun j _ => ?_
+          rw [← Finset.mul_sum, ← map_sum, ← hgj]
+      _ = ∑ j ∈ g.support, algebraMap K' F' (B j) * algebraMap F F' (g j) :=
+          (Finset.sum_subset hgsub fun j _ hj => by
+            rw [Finsupp.notMem_support_iff.mp hj, map_zero, mul_zero]).symm
+  have hgD : ∀ j, g j ∈ LSpace (K := K) D :=
+    AlgebraicCurve.mem_riemannRochSpace_of_sum_basis_smul_algebraMap_mem_mapDomain
+      K F K' F' lift hlift_ord hlift_inj D B B.linearIndependent g
+      (hf'eq ▸ hf')
+  rw [hf'eq]
+  refine Submodule.sum_mem _ fun j _ => ?_
+  rw [← Algebra.smul_def]
+  exact Submodule.smul_mem _ _ (Submodule.subset_span ⟨g j, hgD j, rfl⟩)
+
+end S_OVERLONG_8889c9fb
+end P2MW
+export
+  P2MW.S_OVERLONG_8889c9fb
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem
+  AlgebraicCurve.lSpace_mapDomain_subset_span_image_lSpace_of_constantFieldExtension_of_isAlgClosed
+    (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [IsAlgClosed K'] [IsCurveOver K F] [IsCurveOver K' F']
+    (hfg : ∃ x : F, Transcendental K x ∧
+      FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤)
+    (lift : Place K F → Place K' F')
+    (hlift_ord : ∀ (P : Place K F) (f : F), (lift P).ord (algebraMap F F' f) = P.ord f)
+    (hlift_inj : Function.Injective lift)
+    (D : Divisor K F) {f' : F'}
+    (hf' : f' ∈ LSpace (K := K') (Finsupp.mapDomain lift D)) :
+    f' ∈ Submodule.span K' ((algebraMap F F') '' (LSpace (K := K) D : Set F)) :=
+  solution K F K' F' hfg hfg' hgen lift hlift_ord hlift_inj D hf'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_le_genusFF_of_constantFieldExtension_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_le_genusFF_of_constantFieldExtension_of_isAlgClosed.lean
new file mode 100644
index 0000000000..468a15ae88
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_le_genusFF_of_constantFieldExtension_of_isAlgClosed.lean
@@ -0,0 +1,218 @@
+/-
+Based on Prove2Me node AlgebraicCurve.le_genusFF_of_constantFieldExtension_of_isAlgClosed
+(0043cc0f-67ac-50b2-bda5-7a7c57d37045) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 00e0f2cd-fd91-5a4d-a67a-e1414a431576
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Repartitions
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_comap_algebraMap_eq_of_constantFieldExtension_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_mapDomain_eq_of_constantFieldExtension_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_essFiniteType_of_transcendental_of_finiteDimensional
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_genus_riemannIndex_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_finrank_H1
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_zero_of_genusReached
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_stichtenothGenusExists_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Genus does not drop under algebraically closed constant field extension
+
+Theorem statement: `AlgebraicCurve.le_genusFF_of_constantFieldExtension_of_isAlgClosed`
+(`0043cc0f-67ac-50b2-bda5-7a7c57d37045`), by Claude, 2026-09-05.
+
+Proof: submission `00e0f2cd-fd91-5a4d-a67a-e1414a431576`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K \subseteq K' \subseteq F'$ and $K \subseteq F \subseteq F'$ be fields with compatible algebra
+structures (two scalar towers $K \to K' \to F'$ and $K \to F \to F'$), with $K$ and $K'$
+algebraically closed. Assume that $F$ is a one-variable function field over $K$ in the explicit
+sense that there is $x \in F$ transcendental over $K$ with $F$ finite-dimensional over $K(x)$, and
+likewise that there is $x' \in F'$ transcendental over $K'$ with $F'$ finite-dimensional over
+$K'(x')$. Assume further `IsCurveOver K F` and `IsCurveOver K' F'`, i.e. for each of the two
+extensions: every nonzero $f$ admits a divisor $D$ with $D(v) = v(\operatorname{ord} f)$ at all
+places $v$ and $\deg D = 0$ (places being valuation subrings of the function field that contain the
+constants, are not the whole field, and are principal ideal rings), every place has residue field
+finite-dimensional over the constant field, and the module of Kähler differentials is free of rank
+one over the function field. Finally assume $F'$ is generated as a field over $K'$ by the image of
+$F$, i.e. the $K'$-subfield of $F'$ generated by $\operatorname{range}(\mathrm{algebraMap}\ F\ F')$
+is $\top$. Then $\mathrm{genusFF}\ K\ F \le \mathrm{genusFF}\ K'\ F'$, where $\mathrm{genusFF}$ of a
+function field is the $K$-dimension of the adelic $H^1$ of the zero divisor.
+
+This is one inequality of the classical invariance of the genus under extension of an algebraically
+closed constant field; it is used by
+[`AlgebraicCurve.genusFF_eq_of_constantFieldExtension_of_isAlgClosed`]
+(thm.html#AlgebraicCurve.genusFF_eq_of_constantFieldExtension_of_isAlgClosed),
+which combines it with the reverse inequality to identify the two genera.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_le_genusFF_of_constantFieldExtension_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_le_genusFF_of_constantFieldExtension_of_isAlgClosed
+
+
+open AlgebraicCurve
+
+namespace W7XGenusFFGE
+
+theorem constantsAreBase {K F : Type*} [Field K] [Field F] [Algebra K F] [IsAlgClosed K]
+    [IsCurveOver K F]
+    (hfg : ∃ x : F, Transcendental K x ∧
+      FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F) :
+    ConstantsAreBase K F := by
+  obtain ⟨x, hxt, hxfd⟩ := hfg
+  have : HasPrincipalDivisors K F := IsCurveOver.hasPrincipalDivisors
+  refine le_antisymm (fun f hf => ?_) (fun f ⟨c, hc⟩ => hc ▸ fun v =>
+    Place.adicValuation_algebraMap_le_one v c)
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact zero_mem _
+  have hord : ∀ v : Place K F, 0 ≤ v.ord f := fun v => by
+    have := (mem_riemannRochSpace_iff.mp hf v).resolve_left hf0; simpa using this
+  obtain ⟨D, hDord, hDdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) (F := F) f hf0
+  have hdiv : ∀ v : Place K F, v.ord f = 0 := by
+    by_contra hne; push Not at hne; obtain ⟨v, hv⟩ := hne
+    have hpos : 0 < v.ord f := (hord v).lt_of_ne' hv
+    refine absurd hDdeg (ne_of_gt ?_)
+    rw [Divisor.degree_eq_sum_support]
+    refine Finset.sum_pos' (fun w _ => ?_) ⟨v, ?_, ?_⟩
+    · exact mul_nonneg (by rw [hDord w]; exact hord w) (Int.natCast_nonneg _)
+    · simp only [Finsupp.mem_support_iff, hDord v]; exact hv
+    · rw [hDord v]
+      have : Module.Finite K v.ResidueField := IsCurveOver.finiteResidue v
+      have hd1 : (v.deg : ℤ) = 1 := by
+        exact_mod_cast Place.deg_eq_one_of_isAlgClosed_of_finite v
+      rw [hd1, mul_one]; exact hpos
+  exact ⟨_, (Place.mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed x hxt
+    (F := F) hdiv).choose_spec⟩
+
+end W7XGenusFFGE
+
+open W7XGenusFFGE
+
+theorem solution (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [IsAlgClosed K']
+    (hfg : ∃ x : F, Transcendental K x ∧ FiniteDimensional (IntermediateField.adjoin K ({x} : Set
+      F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    [IsCurveOver K F] [IsCurveOver K' F']
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤) :
+    genusFF K F ≤ genusFF K' F' := by
+  classical
+  obtain ⟨x, hxt, hxfd⟩ := id hfg
+  obtain ⟨x', hxt', hxfd'⟩ := id hfg'
+  have : Algebra.EssFiniteType K F :=
+    essFiniteType_of_transcendental_of_finiteDimensional hxt hxfd
+  have : Algebra.EssFiniteType K' F' :=
+    essFiniteType_of_transcendental_of_finiteDimensional hxt' hxfd'
+  have hCAB : ConstantsAreBase K F := constantsAreBase hfg
+  have hCAB' : ConstantsAreBase K' F' := constantsAreBase hfg'
+  have : HasPrincipalDivisors K F := IsCurveOver.hasPrincipalDivisors
+  have : HasPrincipalDivisors K' F' := IsCurveOver.hasPrincipalDivisors
+  obtain ⟨γ, hγ⟩ := exists_genus_riemannIndex_of_isCurveOver (K := K) (F := F) hCAB
+  obtain ⟨γ', hγ'⟩ := exists_genus_riemannIndex_of_isCurveOver (K := K') (F := F') hCAB'
+  have hγeq : γ = (genusFF K F : ℤ) := by
+    have h0 := (hγ 0).2
+    rw [show Divisor.degree (0 : Divisor K F) = 0 from map_zero _,
+      ell_zero_eq_one_of_constantsAreBase hCAB,
+      indexOfSpecialty_eq_finrank_H1 (K := K) (F := F) 0] at h0
+    unfold genusFF; push_cast at h0 ⊢; linarith
+  have hγeq' : γ' = (genusFF K' F' : ℤ) := by
+    have h0 := (hγ' 0).2
+    rw [show Divisor.degree (0 : Divisor K' F') = 0 from map_zero _,
+      ell_zero_eq_one_of_constantsAreBase hCAB',
+      indexOfSpecialty_eq_finrank_H1 (K := K') (F := F') 0] at h0
+    unfold genusFF; push_cast at h0 ⊢; linarith
+  obtain ⟨hne, hfd0, γ₀, D₀, hD₀⟩ := stichtenothGenusExists_of_isCurveOver (K := K) (F := F) hCAB
+  have : Nonempty (Place K F) := hne
+  have : FiniteDimensional K ↥(LSpace (0 : Divisor K F)) := hfd0
+  have hi0 : indexOfSpecialty D₀ = 0 := indexOfSpecialty_eq_zero_of_genusReached hD₀
+  have hkey : Divisor.degree D₀ - (ell D₀ : ℤ) = γ - 1 := by
+    have := (hγ D₀).2; rw [hi0] at this; push_cast at this; linarith
+  have hX := fun P =>
+    Place.exists_comap_algebraMap_eq_of_constantFieldExtension_of_isAlgClosed
+      K F K' F' hfg hfg' hgen P
+  choose lift hlift_comap hlift_ord hlift_uniq using hX
+  have hlift_inj : Function.Injective lift := fun P Q h => by
+    have hP : (lift P).toValuationSubring.comap (algebraMap F F') = P.toValuationSubring :=
+      hlift_comap P
+    have hQ : (lift P).toValuationSubring.comap (algebraMap F F') = Q.toValuationSubring := by
+      rw [h]; exact hlift_comap Q
+    exact Place.ext (hP.symm.trans hQ)
+  have hlift_new : ∀ v' : Place K' F', (∀ v, lift v ≠ v') →
+      ∀ v : Place K F, v'.toValuationSubring.comap (algebraMap F F') ≠ v.toValuationSubring := by
+    intro v' hnv v hcomap
+    exact hnv v ((hlift_uniq v v' hcomap).symm)
+  have : ∀ v : Place K F, Module.Finite K v.ResidueField := fun v => IsCurveOver.finiteResidue v
+  have : ∀ v' : Place K' F', Module.Finite K' v'.ResidueField :=
+    fun v' => IsCurveOver.finiteResidue v'
+  set D₀' : Divisor K' F' := Finsupp.mapDomain lift D₀ with hD₀'def
+  have hdegEq : Divisor.degree D₀' = Divisor.degree D₀ := by
+    rw [Divisor.degree_eq_sum_support, Divisor.degree_eq_sum_support, hD₀'def,
+      Finsupp.mapDomain_support_of_injective hlift_inj,
+      Finset.sum_image (fun a _ b _ h => hlift_inj h)]
+    refine Finset.sum_congr rfl fun v _ => ?_
+    rw [Finsupp.mapDomain_apply_of_injective hlift_inj,
+      show ((lift v).deg : ℤ) = 1 from by
+        exact_mod_cast Place.deg_eq_one_of_isAlgClosed_of_finite (lift v),
+      show ((v.deg : ℤ)) = 1 from by exact_mod_cast Place.deg_eq_one_of_isAlgClosed_of_finite v]
+  have : FiniteDimensional K ↥(riemannRochSpace D₀) := hD₀.finite
+  have hellEq : ell (K := K') D₀' = ell (K := K) D₀ := by
+    rw [hD₀'def]
+    exact ell_mapDomain_eq_of_constantFieldExtension_of_isAlgClosed K F K' F' hfg hfg' hgen
+      lift hlift_ord hlift_inj hlift_new D₀
+  have hbound : Divisor.degree D₀' - (ell (K := K') D₀' : ℤ) ≤ γ' - 1 := by
+    have hIF := (hγ' D₀').2
+    have hnn : (0:ℤ) ≤ (indexOfSpecialty (K := K') D₀' : ℤ) := Int.natCast_nonneg _
+    linarith
+  rw [hdegEq, hellEq, hkey] at hbound
+  have hγle : γ ≤ γ' := by linarith
+  rw [hγeq, hγeq'] at hγle
+  exact_mod_cast hγle
+
+end S_AlgebraicCurve_le_genusFF_of_constantFieldExtension_of_isAlgClosed
+end P2MW
+export P2MW.S_AlgebraicCurve_le_genusFF_of_constantFieldExtension_of_isAlgClosed (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.le_genusFF_of_constantFieldExtension_of_isAlgClosed (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [IsAlgClosed K']
+    (hfg : ∃ x : F, Transcendental K x ∧ FiniteDimensional (IntermediateField.adjoin K ({x} : Set
+      F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    [IsCurveOver K F] [IsCurveOver K' F']
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤) :
+    genusFF K F ≤ genusFF K' F' :=
+  solution K F K' F' hfg hfg' hgen
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_linearIndependent_of_constantFieldExtension.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_linearIndependent_of_constantFieldExtension.lean
new file mode 100644
index 0000000000..7fa3c21893
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_linearIndependent_of_constantFieldExtension.lean
@@ -0,0 +1,653 @@
+/-
+Based on Prove2Me node AlgebraicCurve.linearIndependent_of_constantFieldExtension
+(565dae3e-5fb8-5276-9894-f0fd073c9048) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f0540cd4-108c-5e07-9209-d5e3a433f738
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+
+import Mathlib.Algebra.Polynomial.Eval.Irreducible
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.Nullstellensatz
+import Mathlib.RingTheory.Polynomial.IsIntegral
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Function fields are linearly disjoint from constant field extensions
+
+Theorem statement: `AlgebraicCurve.linearIndependent_of_constantFieldExtension`
+(`565dae3e-5fb8-5276-9894-f0fd073c9048`), by Claude, 2026-09-05.
+
+Proof: submission `f0540cd4-108c-5e07-9209-d5e3a433f738`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $K'$, $F'$ be fields with $F$ a $K$-algebra, $F'$ a $K'$-algebra, $K'$ a $K$-algebra
+and $F'$ both an $F$-algebra and a $K$-algebra, the scalar towers $K \to K' \to F'$ and $K \to F \to
+F'$ being compatible with the given $K$-algebra structure on $F'$; assume $K$ is algebraically
+closed of characteristic zero. Assume further: there is an $x \in F$ transcendental over $K$ with
+$F$ finite-dimensional over the intermediate field $K(x)$ generated by $x$; there is an $x \in F'$
+transcendental over $K'$ with $F'$ finite-dimensional over the intermediate field $K'(x)$; and the
+intermediate field of $F'/K'$ generated by the image of $F$ under $\mathrm{algebraMap}\ F\ F'$ is
+all of $F'$. Then for any index type $\iota$ and any family $b : \iota \to F$ that is linearly
+independent over $K$, the family of images $i \mapsto \mathrm{algebraMap}\ F\ F'\,(b\,i)$ is
+linearly independent over $K'$.
+
+This is the statement that a function field in one variable over an algebraically closed constant
+field is linearly disjoint from any extension of that constant field, equivalently that $F \otimes_K
+K' \to F'$ is injective; classically it is the regularity of $F/K$ when $K$ is algebraically closed.
+It underlies the theory of constant field extensions $F \rightsquigarrow FK'$ used here to compare a
+curve over $\overline{\mathbb{Q}}$ with its base change, and is cited in the comparison of divisors,
+Riemann–Roch spaces and regular differentials under such an extension.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_linearIndependent_of_constantFieldExtension.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_linearIndependent_of_constantFieldExtension
+
+open Polynomial
+
+namespace AlgebraicCurve
+namespace LinDisjSol
+
+section Generic
+
+variable {R S : Type*} [CommRing R] [CommRing S]
+
+noncomputable def genericPoly (d N : ℕ) (v : Fin d → Fin N → R) : R[X][X] :=
+  X ^ d + ∑ j : Fin d, C (∑ n : Fin N, C (v j n) * X ^ (n : ℕ)) * X ^ (j : ℕ)
+
+theorem genericPoly_map (d N : ℕ) (v : Fin d → Fin N → R) (φ : R →+* S) :
+    (genericPoly d N v).map (mapRingHom φ) = genericPoly d N (fun j n => φ (v j n)) := by
+  simp [genericPoly, Polynomial.map_sum, Polynomial.map_mul, Polynomial.map_pow]
+
+theorem genericPoly_monic [Nontrivial R] (d N : ℕ) (v : Fin d → Fin N → R) :
+    (genericPoly d N v).Monic :=
+  monic_X_pow_add (degree_sum_fin_lt _)
+
+theorem genericPoly_natDegree [Nontrivial R] (d N : ℕ) (v : Fin d → Fin N → R) :
+    (genericPoly d N v).natDegree = d := by
+  unfold genericPoly
+  rw [natDegree_add_eq_left_of_degree_lt, natDegree_X_pow]
+  rw [degree_X_pow]
+  exact degree_sum_fin_lt _
+
+theorem genericPoly_coeff_eq (g : R[X][X]) (hg : g.Monic) (N : ℕ)
+    (hN : ∀ j : ℕ, j < g.natDegree → (g.coeff j).natDegree < N) :
+    genericPoly g.natDegree N (fun j n => (g.coeff j).coeff n) = g := by
+  have inner : ∀ j : Fin g.natDegree,
+      (∑ n : Fin N, C ((g.coeff j).coeff n) * X ^ (n : ℕ)) = g.coeff j := by
+    intro j
+    rw [Fin.sum_univ_eq_sum_range (fun n => C ((g.coeff (j : ℕ)).coeff n) * X ^ n) N]
+    exact (as_sum_range_C_mul_X_pow' _ (hN j j.2)).symm
+  unfold genericPoly
+  simp_rw [inner]
+  rw [Fin.sum_univ_eq_sum_range (fun j => C (g.coeff j) * X ^ j) g.natDegree]
+  exact hg.as_sum.symm
+
+end Generic
+
+section Spec
+
+variable {K K' : Type*} [Field K] [Field K'] [Algebra K K'] [IsAlgClosed K]
+
+theorem exists_factorisation_of_factorisation_map (m : K[X][X])
+    (g h : K'[X][X]) (hg : g.Monic) (hh : h.Monic)
+    (hfac : m.map (mapRingHom (algebraMap K K')) = g * h) :
+    ∃ g₀ h₀ : K[X][X], g₀.Monic ∧ h₀.Monic ∧ g₀.natDegree = g.natDegree ∧
+      h₀.natDegree = h.natDegree ∧ m = g₀ * h₀ := by
+  classical
+  set N : ℕ := ((Finset.range g.natDegree).sup fun j => (g.coeff j).natDegree) ⊔
+      ((Finset.range h.natDegree).sup fun j => (h.coeff j).natDegree) + 1 with hN
+  have hNg : ∀ j : ℕ, j < g.natDegree → (g.coeff j).natDegree < N := by
+    intro j hj
+    have : (g.coeff j).natDegree ≤ (Finset.range g.natDegree).sup fun j => (g.coeff j).natDegree :=
+      Finset.le_sup (f := fun j => (g.coeff j).natDegree) (Finset.mem_range.mpr hj)
+    omega
+  have hNh : ∀ j : ℕ, j < h.natDegree → (h.coeff j).natDegree < N := by
+    intro j hj
+    have : (h.coeff j).natDegree ≤ (Finset.range h.natDegree).sup fun j => (h.coeff j).natDegree :=
+      Finset.le_sup (f := fun j => (h.coeff j).natDegree) (Finset.mem_range.mpr hj)
+    omega
+  set dg := g.natDegree
+  set dh := h.natDegree
+  let σ : Type := (Fin dg × Fin N) ⊕ (Fin dh × Fin N)
+  let c : σ → K' :=
+    Sum.elim (fun jn => (g.coeff jn.1).coeff jn.2) (fun jn => (h.coeff jn.1).coeff jn.2)
+  let R := MvPolynomial σ K
+  let G : R[X][X] := genericPoly dg N (fun j n => MvPolynomial.X (Sum.inl (j, n)))
+  let H : R[X][X] := genericPoly dh N (fun j n => MvPolynomial.X (Sum.inr (j, n)))
+  let evc : R →+* K' := (MvPolynomial.aeval c : R →ₐ[K] K')
+  have hGc : G.map (mapRingHom evc) = g := by
+    rw [genericPoly_map]
+    have : (fun j n => evc (MvPolynomial.X (Sum.inl (j, n)))) =
+        fun (j : Fin dg) (n : Fin N) => (g.coeff j).coeff n := by
+      funext j n; change MvPolynomial.aeval c (MvPolynomial.X _) = _; rw [MvPolynomial.aeval_X]; rfl
+    rw [this]
+    exact genericPoly_coeff_eq g hg N hNg
+  have hHc : H.map (mapRingHom evc) = h := by
+    rw [genericPoly_map]
+    have : (fun j n => evc (MvPolynomial.X (Sum.inr (j, n)))) =
+        fun (j : Fin dh) (n : Fin N) => (h.coeff j).coeff n := by
+      funext j n; change MvPolynomial.aeval c (MvPolynomial.X _) = _; rw [MvPolynomial.aeval_X]; rfl
+    rw [this]
+    exact genericPoly_coeff_eq h hh N hNh
+  let D : R[X][X] := m.map (mapRingHom (algebraMap K R)) - G * H
+  have hDc : D.map (mapRingHom evc) = 0 := by
+    simp only [D, Polynomial.map_sub, Polynomial.map_mul, hGc, hHc, Polynomial.map_map,
+      mapRingHom_comp]
+    have : evc.comp (algebraMap K R) = algebraMap K K' := (MvPolynomial.aeval c).comp_algebraMap
+    rw [this, hfac, sub_self]
+  have hcoeffI : ∀ j n : ℕ, evc ((D.coeff j).coeff n) = 0 := by
+    intro j n
+    have := congrArg (fun P : K'[X][X] => (P.coeff j).coeff n) hDc
+    simpa [coeff_map] using this
+  have hker : RingHom.ker evc ≠ ⊤ := RingHom.ker_ne_top evc
+  obtain ⟨𝔪, h𝔪, hle⟩ := Ideal.exists_le_maximal _ hker
+  have : Finite σ := inferInstance
+  obtain ⟨a, ha⟩ := (MvPolynomial.isMaximal_iff_eq_vanishingIdeal_singleton (K := K)).mp h𝔪
+  let eva : R →+* K := (MvPolynomial.aeval a : R →ₐ[K] K)
+  have heva : ∀ j n : ℕ, eva ((D.coeff j).coeff n) = 0 := by
+    intro j n
+    have hmem : (D.coeff j).coeff n ∈ 𝔪 := hle ((RingHom.mem_ker).mpr (hcoeffI j n))
+    rw [ha] at hmem
+    exact (MvPolynomial.mem_vanishingIdeal_singleton_iff a _).mp hmem
+  have hDa : D.map (mapRingHom eva) = 0 := by
+    ext j n
+    simp [coeff_map, heva]
+  refine ⟨G.map (mapRingHom eva), H.map (mapRingHom eva), ?_, ?_, ?_, ?_, ?_⟩
+  · rw [genericPoly_map]; exact genericPoly_monic _ _ _
+  · rw [genericPoly_map]; exact genericPoly_monic _ _ _
+  · rw [genericPoly_map]; exact genericPoly_natDegree _ _ _
+  · rw [genericPoly_map]; exact genericPoly_natDegree _ _ _
+  · have h1 : (m.map (mapRingHom (algebraMap K R))).map (mapRingHom eva) = m := by
+      rw [Polynomial.map_map, mapRingHom_comp]
+      have : eva.comp (algebraMap K R) = RingHom.id K := by
+        rw [show eva.comp (algebraMap K R) = algebraMap K K from
+          (MvPolynomial.aeval a).comp_algebraMap]
+        exact Algebra.algebraMap_self
+      rw [this, mapRingHom_id, Polynomial.map_id]
+    have h2 := hDa
+    simp only [D, Polynomial.map_sub, Polynomial.map_mul, h1] at h2
+    exact sub_eq_zero.mp h2
+
+theorem irreducible_map_of_isAlgClosed (m : K[X][X]) (hm : m.Monic) (hirr : Irreducible m) :
+    Irreducible (m.map (mapRingHom (algebraMap K K'))) := by
+  classical
+  set m' := m.map (mapRingHom (algebraMap K K')) with hm'def
+  have hm' : m'.Monic := hm.map _
+  have hdeg' : m'.natDegree = m.natDegree := hm.natDegree_map _
+  refine ⟨fun hu => ?_, fun g h hgh => ?_⟩
+  · have h0 : m.natDegree = 0 := by rw [← hdeg']; exact natDegree_eq_zero_of_isUnit hu
+    apply hirr.not_isUnit
+    rw [hm.natDegree_eq_zero] at h0
+    rw [h0]; exact isUnit_one
+  · have hlc : g.leadingCoeff * h.leadingCoeff = 1 := by
+      rw [← leadingCoeff_mul, ← hgh]; exact hm'
+    by_cases hg0 : g.natDegree = 0
+    · left
+      have hlc0 : g.coeff 0 * h.leadingCoeff = 1 := by
+        rwa [leadingCoeff, hg0] at hlc
+      rw [eq_C_of_natDegree_eq_zero hg0]
+      exact isUnit_C.mpr (IsUnit.of_mul_eq_one _ hlc0)
+    by_cases hh0 : h.natDegree = 0
+    · right
+      have hlc0 : h.coeff 0 * g.leadingCoeff = 1 := by
+        rw [mul_comm] at hlc; rwa [leadingCoeff, hh0] at hlc
+      rw [eq_C_of_natDegree_eq_zero hh0]
+      exact isUnit_C.mpr (IsUnit.of_mul_eq_one _ hlc0)
+    exfalso
+    set g₁ : K'[X][X] := C h.leadingCoeff * g
+    set h₁ : K'[X][X] := C g.leadingCoeff * h
+    have hg₁ : g₁.Monic := monic_C_mul_of_mul_leadingCoeff_eq_one (by rw [mul_comm]; exact hlc)
+    have hh₁ : h₁.Monic := monic_C_mul_of_mul_leadingCoeff_eq_one hlc
+    have hlg : g.leadingCoeff ≠ 0 := left_ne_zero_of_mul_eq_one hlc
+    have hlh : h.leadingCoeff ≠ 0 := right_ne_zero_of_mul_eq_one hlc
+    have hdg₁ : g₁.natDegree = g.natDegree := natDegree_C_mul hlh
+    have hdh₁ : h₁.natDegree = h.natDegree := natDegree_C_mul hlg
+    have hfac : m' = g₁ * h₁ := by
+      rw [hgh]
+      simp only [g₁, h₁]
+      calc g * h = C (g.leadingCoeff * h.leadingCoeff) * (g * h) := by rw [hlc, C_1, one_mul]
+        _ = C h.leadingCoeff * g * (C g.leadingCoeff * h) := by rw [C_mul]; ring
+    obtain ⟨g₀, h₀, hg₀, hh₀, hdg₀, hdh₀, hm0⟩ :=
+      exists_factorisation_of_factorisation_map m g₁ h₁ hg₁ hh₁ hfac
+    rcases hirr.isUnit_or_isUnit hm0 with hu | hu
+    · have := natDegree_eq_zero_of_isUnit hu
+      rw [hdg₀, hdg₁] at this; exact hg0 this
+    · have := natDegree_eq_zero_of_isUnit hu
+      rw [hdh₀, hdh₁] at this; exact hh0 this
+
+end Spec
+
+section FunctionField
+
+open IntermediateField
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem algebraMap_comp_aeval_gen (x : F) :
+    (algebraMap K⟮x⟯ F).comp (aeval (AdjoinSimple.gen K x) : K[X] →ₐ[K] K⟮x⟯).toRingHom =
+      (aeval x : K[X] →ₐ[K] F).toRingHom :=
+  RingHom.ext fun p => AdjoinSimple.coe_aeval_gen_apply (F := K) x p
+
+theorem aeval_gen_injective {x : F} (hx : Transcendental K x) :
+    Function.Injective (aeval (AdjoinSimple.gen K x) : K[X] →ₐ[K] K⟮x⟯) := by
+  intro p q hpq
+  apply transcendental_iff_injective.mp hx
+  change aeval x p = aeval x q
+  rw [← AdjoinSimple.coe_aeval_gen_apply (F := K) x p,
+    ← AdjoinSimple.coe_aeval_gen_apply (F := K) x q, hpq]
+
+theorem exists_common_denom {x : F} (hx : Transcendental K x) {T : Type*} [Finite T]
+    (r : T → K⟮x⟯) : ∃ q : K[X], q ≠ 0 ∧ ∀ t, ∃ p : K[X],
+      aeval (AdjoinSimple.gen K x) q * r t = aeval (AdjoinSimple.gen K x) p := by
+  classical
+  let := Fintype.ofFinite T
+  let e := RatFunc.algEquivOfTranscendental x hx
+  let u : T → RatFunc K := fun t => e.symm (r t)
+  have key : ∀ g : K[X], (aeval (AdjoinSimple.gen K x) g : K⟮x⟯) =
+      e (algebraMap K[X] (RatFunc K) g) :=
+    fun g => (RatFunc.algEquivOfTranscendental_algebraMap x hx g).symm
+  refine ⟨∏ t, (u t).denom, ?_, fun t => ?_⟩
+  · exact Finset.prod_ne_zero_iff.mpr fun t _ => RatFunc.denom_ne_zero (u t)
+  · refine ⟨(u t).num * ∏ s ∈ Finset.univ.erase t, (u s).denom, ?_⟩
+    have hr : r t = e (u t) := (e.apply_symm_apply (r t)).symm
+    rw [hr, key, key, ← map_mul]
+    congr 1
+    rw [← Finset.mul_prod_erase Finset.univ (fun s => (u s).denom) (Finset.mem_univ t), map_mul,
+      map_mul]
+    have hden : algebraMap K[X] (RatFunc K) (u t).denom ≠ 0 :=
+      (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr
+        (RatFunc.denom_ne_zero _)
+    calc algebraMap K[X] (RatFunc K) (u t).denom *
+          algebraMap K[X] (RatFunc K) (∏ s ∈ Finset.univ.erase t, (u s).denom) * u t
+        = algebraMap K[X] (RatFunc K) (∏ s ∈ Finset.univ.erase t, (u s).denom) *
+          (algebraMap K[X] (RatFunc K) (u t).denom *
+            (algebraMap _ _ (u t).num / algebraMap _ _ (u t).denom)) := by
+          rw [RatFunc.num_div_denom]; ring
+      _ = algebraMap K[X] (RatFunc K) (u t).num *
+          algebraMap K[X] (RatFunc K) (∏ s ∈ Finset.univ.erase t, (u s).denom) := by
+          rw [mul_div_cancel₀ _ hden]; ring
+
+theorem exists_primitive_integral [CharZero K] {x : F} (hx : Transcendental K x)
+    [FiniteDimensional K⟮x⟯ F] :
+    ∃ (y : F) (m : K[X][X]) (d : ℕ), m.Monic ∧ Irreducible m ∧ m.natDegree = d ∧
+      m.eval₂ (aeval x : K[X] →ₐ[K] F).toRingHom y = 0 ∧
+      ∀ f : F, ∃ r : Fin d → K⟮x⟯, f = ∑ j, algebraMap K⟮x⟯ F (r j) * y ^ (j : ℕ) := by
+  classical
+  have : CharZero K⟮x⟯ :=
+    charZero_of_injective_algebraMap (algebraMap K K⟮x⟯).injective
+  have : Algebra.IsSeparable K⟮x⟯ F := Algebra.IsAlgebraic.isSeparable_of_perfectField
+  obtain ⟨y₀, hy₀⟩ := Field.exists_primitive_element K⟮x⟯ F
+  have hy₀int : IsIntegral K⟮x⟯ y₀ := Algebra.IsIntegral.isIntegral y₀
+  set μ : K⟮x⟯[X] := minpoly K⟮x⟯ y₀ with hμ
+  obtain ⟨q, hq0, hq⟩ :=
+    exists_common_denom hx (fun i : Fin (μ.natDegree + 1) => μ.coeff i)
+  choose p hp using hq
+  set s : K⟮x⟯ := aeval (AdjoinSimple.gen K x) q with hs
+  have hs0 : s ≠ 0 := by
+    intro h
+    apply hq0
+    apply aeval_gen_injective hx
+    rw [map_zero]; exact h
+  set y : F := algebraMap K⟮x⟯ F s * y₀ with hy
+  set μs : K⟮x⟯[X] := μ.scaleRoots s with hμs
+  have hμs_monic : μs.Monic := (monic_scaleRoots_iff s).mpr (minpoly.monic hy₀int)
+  have hμs_root : aeval y μs = 0 := scaleRoots_aeval_eq_zero (minpoly.aeval K⟮x⟯ y₀)
+  have hμs_deg : μs.natDegree = μ.natDegree := natDegree_scaleRoots _ _
+  have hlifts : μs ∈ Polynomial.lifts
+      (aeval (AdjoinSimple.gen K x) : K[X] →ₐ[K] K⟮x⟯).toRingHom := by
+    rw [lifts_iff_coeff_lifts]
+    intro n
+    rw [hμs, coeff_scaleRoots]
+    rcases lt_trichotomy n μ.natDegree with hlt | heq | hgt
+    · obtain ⟨k, hk⟩ : ∃ k, μ.natDegree - n = k + 1 := ⟨μ.natDegree - n - 1, by omega⟩
+      refine ⟨p ⟨n, by omega⟩ * q ^ k, ?_⟩
+      have := hp ⟨n, by omega⟩
+      simp only at this
+      change aeval (AdjoinSimple.gen K x) (p ⟨n, by omega⟩ * q ^ k) = _
+      rw [map_mul, map_pow, ← this, hk, pow_succ]
+      ring
+    · subst heq
+      refine ⟨1, ?_⟩
+      change aeval (AdjoinSimple.gen K x) (1 : K[X]) = _
+      rw [map_one, Nat.sub_self, pow_zero, mul_one]
+      exact (minpoly.monic hy₀int).coeff_natDegree.symm
+    · refine ⟨0, ?_⟩
+      change aeval (AdjoinSimple.gen K x) (0 : K[X]) = _
+      rw [map_zero, coeff_eq_zero_of_natDegree_lt hgt, zero_mul]
+  obtain ⟨m, hmμs, hmdeg, hmmonic⟩ := lifts_and_natDegree_eq_and_monic hlifts hμs_monic
+  have hyint : IsIntegral K⟮x⟯ y := Algebra.IsIntegral.isIntegral y
+  have htop : K⟮x⟯⟮y⟯ = ⊤ := by
+    rw [eq_top_iff, ← hy₀, adjoin_simple_le_iff]
+    have : y₀ = algebraMap K⟮x⟯ F s⁻¹ * y := by
+      rw [hy, ← mul_assoc, ← map_mul, inv_mul_cancel₀ hs0, map_one, one_mul]
+    rw [this]
+    exact mul_mem (IntermediateField.algebraMap_mem _ _) (mem_adjoin_simple_self _ y)
+  have hdegμ : μ.natDegree = Module.finrank K⟮x⟯ F := by
+    rw [hμ, ← adjoin.finrank hy₀int, hy₀, finrank_top']
+  have hdegy : (minpoly K⟮x⟯ y).natDegree = Module.finrank K⟮x⟯ F := by
+    rw [← adjoin.finrank hyint, htop, finrank_top']
+  have hμs_eq : μs = minpoly K⟮x⟯ y :=
+    eq_of_monic_of_dvd_of_natDegree_le (minpoly.monic hyint) hμs_monic
+      (minpoly.dvd _ _ hμs_root) (by rw [hμs_deg, hdegμ, hdegy])
+  have hirr : Irreducible m :=
+    Monic.irreducible_of_irreducible_map _ m hmmonic
+      (by rw [hmμs, hμs_eq]; exact minpoly.irreducible hyint)
+  have hroot : m.eval₂ (aeval x : K[X] →ₐ[K] F).toRingHom y = 0 := by
+    have h := hμs_root
+    rw [← hmμs, aeval_def, eval₂_map] at h
+    rwa [← algebraMap_comp_aeval_gen x]
+  let pb := adjoin.powerBasis hyint
+  refine ⟨y, m, (minpoly K⟮x⟯ y).natDegree, hmmonic, hirr, ?_, hroot, fun f => ?_⟩
+  · rw [hmdeg, hμs_eq]
+  · have hf : f ∈ K⟮x⟯⟮y⟯ := by rw [htop]; exact mem_top
+    refine ⟨fun j => pb.basis.repr ⟨f, hf⟩ j, ?_⟩
+    have hsum := pb.basis.sum_repr ⟨f, hf⟩
+    calc f = (K⟮x⟯⟮y⟯).val ⟨f, hf⟩ := rfl
+      _ = (K⟮x⟯⟮y⟯).val (∑ i, pb.basis.repr ⟨f, hf⟩ i • pb.basis i) := by rw [hsum]
+      _ = _ := by
+        rw [map_sum]
+        refine Finset.sum_congr rfl fun j _ => ?_
+        rw [map_smul, Algebra.smul_def, pb.basis_eq_pow, map_pow]
+        rfl
+
+end FunctionField
+
+section Main
+
+open IntermediateField
+
+variable {K F K' F' : Type*} [Field K] [Field F] [Field K'] [Field F'] [Algebra K F]
+  [Algebra K' F'] [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F']
+  [IsScalarTower K F F']
+
+theorem algebraMap_mem_adjoin (x : F) (z : K⟮x⟯) :
+    algebraMap F F' (z : F) ∈ K'⟮algebraMap F F' x⟯ := by
+  let ιFa : F →ₐ[K] F' := IsScalarTower.toAlgHom K F F'
+  have h1 : algebraMap F F' (z : F) ∈ (K⟮x⟯).map ιFa := ⟨z, z.2, rfl⟩
+  rw [adjoin_map, Set.image_singleton] at h1
+  have h2 : K⟮ιFa x⟯ ≤ (K'⟮algebraMap F F' x⟯).restrictScalars K :=
+    adjoin_simple_le_iff.mpr (mem_adjoin_simple_self K' _)
+  exact h2 h1
+
+theorem exists_ringHom_adjoin (x : F) : ∃ ρ : K⟮x⟯ →+* K'⟮algebraMap F F' x⟯,
+    ∀ z, algebraMap K'⟮algebraMap F F' x⟯ F' (ρ z) = algebraMap F F' (algebraMap K⟮x⟯ F z) :=
+  ⟨((algebraMap F F').comp (algebraMap K⟮x⟯ F)).codRestrict (K'⟮algebraMap F F' x⟯)
+      (fun z => algebraMap_mem_adjoin x z), fun _ => rfl⟩
+
+theorem isIntegral_algebraMap (x : F) [FiniteDimensional K⟮x⟯ F] (f : F) :
+    IsIntegral K'⟮algebraMap F F' x⟯ (algebraMap F F' f) := by
+  obtain ⟨ρ, hρ⟩ := exists_ringHom_adjoin (K := K) (K' := K') (F' := F') x
+  have hf : IsIntegral K⟮x⟯ f := Algebra.IsIntegral.isIntegral f
+  refine ⟨(minpoly K⟮x⟯ f).map ρ, (minpoly.monic hf).map ρ, ?_⟩
+  have hcomp : (algebraMap K'⟮algebraMap F F' x⟯ F').comp ρ =
+      (algebraMap F F').comp (algebraMap K⟮x⟯ F) := RingHom.ext hρ
+  rw [eval₂_map, hcomp, ← hom_eval₂, ← aeval_def, minpoly.aeval, map_zero]
+
+theorem transcendental_algebraMap {x : F} [FiniteDimensional K⟮x⟯ F]
+    (hfg' : ∃ x' : F', Transcendental K' x' ∧ FiniteDimensional K'⟮x'⟯ F')
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤) :
+    Transcendental K' (algebraMap F F' x) := by
+  intro hx₁
+  obtain ⟨x', hx', -⟩ := hfg'
+  apply hx'
+  have : FiniteDimensional K' K'⟮algebraMap F F' x⟯ := adjoin.finiteDimensional hx₁.isIntegral
+  have hS : ∀ z ∈ Set.range (algebraMap F F'), IsIntegral K' z := by
+    rintro _ ⟨f, rfl⟩
+    exact isIntegral_trans (R := K') _ (isIntegral_algebraMap (K := K) (K' := K') x f)
+  have := IntermediateField.isAlgebraic_adjoin hS
+  have hmem : x' ∈ IntermediateField.adjoin K' (Set.range (algebraMap F F')) := by
+    rw [hgen]; exact mem_top
+  exact IntermediateField.isAlgebraic_iff.mp
+    (Algebra.IsAlgebraic.isAlgebraic
+      (⟨x', hmem⟩ : IntermediateField.adjoin K' (Set.range (algebraMap F F'))))
+
+theorem linearIndependent_pow_algebraMap [IsAlgClosed K] {x : F}
+    (hx₁ : Transcendental K' (algebraMap F F' x))
+    {y : F} {m : K[X][X]} (hm : m.Monic) (hirr : Irreducible m)
+    (hroot : m.eval₂ (aeval x : K[X] →ₐ[K] F).toRingHom y = 0) :
+    LinearIndependent K'⟮algebraMap F F' x⟯
+      (fun j : Fin m.natDegree => algebraMap F F' y ^ (j : ℕ)) := by
+  classical
+  set x₁ := algebraMap F F' x with hx₁def
+  set y₁ := algebraMap F F' y with hy₁def
+  let ψ : K[X] →+* K'⟮x₁⟯ :=
+    (aeval (AdjoinSimple.gen K' x₁) : K'[X] →ₐ[K'] K'⟮x₁⟯).toRingHom.comp
+      (mapRingHom (algebraMap K K'))
+  set M : K'⟮x₁⟯[X] := m.map ψ with hM
+  have hMmonic : M.Monic := hm.map ψ
+  have hcomp : (algebraMap K'⟮x₁⟯ F').comp ψ = (algebraMap F F').comp (aeval x).toRingHom := by
+    refine Polynomial.ringHom_ext (fun a => ?_) ?_
+    · simp only [ψ, RingHom.coe_comp, Function.comp_apply, coe_mapRingHom, map_C,
+        AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom, aeval_C]
+      rw [← IsScalarTower.algebraMap_apply, ← IsScalarTower.algebraMap_apply,
+        ← IsScalarTower.algebraMap_apply]
+    · simp only [ψ, RingHom.coe_comp, Function.comp_apply, coe_mapRingHom, map_X,
+        AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom, aeval_X]
+      rfl
+  have hMroot : aeval y₁ M = 0 := by
+    rw [aeval_def, hM, eval₂_map, hcomp, hy₁def, ← hom_eval₂, hroot, map_zero]
+  have hMirr : Irreducible M := by
+    have h0 : Irreducible (m.map (mapRingHom (algebraMap K K'))) :=
+      irreducible_map_of_isAlgClosed m hm hirr
+    have h1 : Irreducible ((m.map (mapRingHom (algebraMap K K'))).map
+        (algebraMap K'[X] (RatFunc K'))) :=
+      ((hm.map _).irreducible_iff_irreducible_map_fraction_map).mp h0
+    let e := RatFunc.algEquivOfTranscendental x₁ hx₁
+    have h2 := h1.map (mapEquiv (e : RatFunc K' ≃+* K'⟮x₁⟯))
+    have h3 : mapEquiv (e : RatFunc K' ≃+* K'⟮x₁⟯)
+        ((m.map (mapRingHom (algebraMap K K'))).map (algebraMap K'[X] (RatFunc K'))) = M := by
+      rw [mapEquiv_apply, Polynomial.map_map, Polynomial.map_map, hM]
+      congr 1
+      refine RingHom.ext fun g => ?_
+      simp only [ψ, RingHom.coe_comp, Function.comp_apply, coe_mapRingHom, RingHom.coe_coe,
+        AlgHom.toRingHom_eq_coe]
+      exact RatFunc.algEquivOfTranscendental_algebraMap x₁ hx₁ _
+    rw [h3] at h2
+    exact h2
+  have hMeq : M = minpoly K'⟮x₁⟯ y₁ := minpoly.eq_of_irreducible_of_monic hMirr hMroot hMmonic
+  have hdeg : (minpoly K'⟮x₁⟯ y₁).natDegree = m.natDegree := by
+    rw [← hMeq, hM]; exact hm.natDegree_map ψ
+  have hli := linearIndependent_pow (K := K'⟮x₁⟯) y₁
+  rw [hdeg] at hli
+  exact hli
+
+theorem eq_zero_of_sum_C_mul_map {κ : Type*} [Fintype κ] {c : κ → K'}
+    (hc : LinearIndependent K c) (p : κ → K[X])
+    (h : ∑ k, C (c k) * (p k).map (algebraMap K K') = 0) : ∀ k, p k = 0 := by
+  have hn : ∀ n : ℕ, ∀ k, (p k).coeff n = 0 := by
+    intro n
+    have h1 := congrArg (fun P : K'[X] => P.coeff n) h
+    simp only [finsetSum_coeff, coeff_C_mul, coeff_map, coeff_zero] at h1
+    have h2 : ∑ k, (p k).coeff n • c k = 0 := by
+      rw [← h1]
+      refine Finset.sum_congr rfl fun k _ => ?_
+      rw [Algebra.smul_def, mul_comm]
+    exact Fintype.linearIndependent_iff.mp hc _ h2
+  intro k
+  ext n
+  simp [hn n k]
+
+omit [Algebra K F'] [IsScalarTower K K' F'] in
+theorem eq_zero_of_sum_aeval {x₁ : F'} (hx₁ : Transcendental K' x₁) {κ : Type*} [Fintype κ]
+    {c : κ → K'} (hc : LinearIndependent K c) (p : κ → K[X])
+    (h : ∑ k, algebraMap K' K'⟮x₁⟯ (c k) *
+      aeval (AdjoinSimple.gen K' x₁) ((p k).map (algebraMap K K')) = 0) : ∀ k, p k = 0 := by
+  apply eq_zero_of_sum_C_mul_map hc
+  apply aeval_gen_injective hx₁
+  rw [map_sum, map_zero, ← h]
+  refine Finset.sum_congr rfl fun k _ => ?_
+  rw [map_mul, aeval_C]
+
+theorem eq_zero_of_sum_mul_algebraMap [IsAlgClosed K] [CharZero K] {x : F}
+    (hx : Transcendental K x) [FiniteDimensional K⟮x⟯ F]
+    (hx₁ : Transcendental K' (algebraMap F F' x))
+    {κ : Type*} [Fintype κ] {c : κ → K'} (hc : LinearIndependent K c) (f : κ → F)
+    (hrel : ∑ k, algebraMap F F' (f k) * algebraMap K' F' (c k) = 0) : ∀ k, f k = 0 := by
+  classical
+  obtain ⟨y, m, d, hm, hirr, hd, hroot, hspan⟩ := exists_primitive_integral hx
+  subst hd
+  obtain ⟨ρ, hρ⟩ := exists_ringHom_adjoin (K := K) (K' := K') (F' := F') x
+  have hLD := linearIndependent_pow_algebraMap (K := K) hx₁ hm hirr hroot
+  choose r hr using fun k => hspan (f k)
+  obtain ⟨q, hq0, hq⟩ := exists_common_denom hx (fun kj : κ × Fin m.natDegree => r kj.1 kj.2)
+  choose P hP using hq
+  have hcoefE : ∀ j : Fin m.natDegree,
+      ∑ k, algebraMap K' K'⟮algebraMap F F' x⟯ (c k) * ρ (r k j) = 0 := by
+    have hsum : ∑ j : Fin m.natDegree,
+        (∑ k, algebraMap K' K'⟮algebraMap F F' x⟯ (c k) * ρ (r k j)) •
+          algebraMap F F' y ^ (j : ℕ) = 0 := by
+      rw [← hrel]
+      simp_rw [Finset.sum_smul, Algebra.smul_def]
+      rw [Finset.sum_comm]
+      refine Finset.sum_congr rfl fun k _ => ?_
+      rw [hr k, map_sum, Finset.sum_mul]
+      refine Finset.sum_congr rfl fun j _ => ?_
+      rw [map_mul, map_mul, ← IsScalarTower.algebraMap_apply, hρ, map_pow]
+      ring
+    exact Fintype.linearIndependent_iff.mp hLD _ hsum
+  have hρθ : ∀ p : K[X], ρ (aeval (AdjoinSimple.gen K x) p) =
+      aeval (AdjoinSimple.gen K' (algebraMap F F' x)) (p.map (algebraMap K K')) := by
+    intro p
+    apply (algebraMap K'⟮algebraMap F F' x⟯ F').injective
+    rw [hρ]
+    change algebraMap F F' ((aeval (AdjoinSimple.gen K x) p : K⟮x⟯) : F) =
+      ((aeval (AdjoinSimple.gen K' (algebraMap F F' x)) (p.map (algebraMap K K')) :
+        K'⟮algebraMap F F' x⟯) : F')
+    rw [AdjoinSimple.coe_aeval_gen_apply, AdjoinSimple.coe_aeval_gen_apply, aeval_map_algebraMap,
+      aeval_algebraMap_apply]
+  have hP0 : ∀ k j, P (k, j) = 0 := by
+    intro k j
+    refine eq_zero_of_sum_aeval hx₁ hc (fun k => P (k, j)) ?_ k
+    have := congrArg (fun z => ρ (aeval (AdjoinSimple.gen K x) q) * z) (hcoefE j)
+    simp only [mul_zero, Finset.mul_sum] at this
+    rw [← this]
+    refine Finset.sum_congr rfl fun k _ => ?_
+    rw [← hρθ, ← hP (k, j), map_mul]
+    ring
+  have hs0 : (aeval (AdjoinSimple.gen K x) q : K⟮x⟯) ≠ 0 := by
+    intro h
+    apply hq0
+    apply aeval_gen_injective hx
+    rw [map_zero]; exact h
+  have hr0 : ∀ k j, r k j = 0 := by
+    intro k j
+    have := hP (k, j)
+    rw [hP0 k j, map_zero] at this
+    exact (mul_eq_zero.mp this).resolve_left hs0
+  intro k
+  rw [hr k]
+  simp [hr0]
+
+theorem linearIndependent_algebraMap_of_fintype [IsAlgClosed K] [CharZero K] {x : F}
+    (hx : Transcendental K x) [FiniteDimensional K⟮x⟯ F]
+    (hx₁ : Transcendental K' (algebraMap F F' x))
+    {κ : Type*} [Finite κ] {b : κ → F} (hb : LinearIndependent K b) :
+    LinearIndependent K' (fun i => algebraMap F F' (b i)) := by
+  classical
+  let := Fintype.ofFinite κ
+  rw [Fintype.linearIndependent_iff]
+  intro a hrel i₀
+  let W : Submodule K K' := Submodule.span K (Set.range a)
+  have : Module.Finite K W := Module.Finite.span_of_finite K (Set.finite_range a)
+  let bW := Module.finBasis K W
+  let c : Fin (Module.finrank K W) → K' := fun k => (bW k : K')
+  have hc : LinearIndependent K c :=
+    bW.linearIndependent.map' W.subtype (Submodule.ker_subtype W)
+  have ha : ∀ i, a i ∈ W := fun i => Submodule.subset_span ⟨i, rfl⟩
+  let μ : κ → Fin (Module.finrank K W) → K := fun i k => bW.repr ⟨a i, ha i⟩ k
+  have hai : ∀ i, a i = ∑ k, μ i k • c k := by
+    intro i
+    have h1 := congrArg (Submodule.subtype W) (bW.sum_repr ⟨a i, ha i⟩)
+    rw [map_sum] at h1
+    simp only [map_smul, Submodule.subtype_apply] at h1
+    exact h1.symm
+  let f : Fin (Module.finrank K W) → F := fun k => ∑ i, μ i k • b i
+  have hf : ∀ k, f k = 0 := by
+    apply eq_zero_of_sum_mul_algebraMap hx hx₁ hc f
+    have lhs : ∑ k, algebraMap F F' (f k) * algebraMap K' F' (c k) =
+        ∑ k, ∑ i, algebraMap K F' (μ i k) * algebraMap F F' (b i) * algebraMap K' F' (c k) := by
+      refine Finset.sum_congr rfl fun k _ => ?_
+      simp only [f, map_sum, Finset.sum_mul]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [Algebra.smul_def, map_mul, ← IsScalarTower.algebraMap_apply]
+    have rhs : ∑ i, a i • algebraMap F F' (b i) =
+        ∑ i, ∑ k, algebraMap K F' (μ i k) * algebraMap F F' (b i) * algebraMap K' F' (c k) := by
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [hai i, Algebra.smul_def, map_sum, Finset.sum_mul]
+      refine Finset.sum_congr rfl fun k _ => ?_
+      rw [Algebra.smul_def, map_mul, ← IsScalarTower.algebraMap_apply]
+      ring
+    rw [lhs, Finset.sum_comm, ← rhs, hrel]
+  have hμ : ∀ k i, μ i k = 0 := fun k =>
+    Fintype.linearIndependent_iff.mp hb (fun i => μ i k) (hf k)
+  rw [hai i₀]
+  simp [hμ]
+
+end Main
+
+end AlgebraicCurve.LinDisjSol
+
+open AlgebraicCurve.LinDisjSol in
+theorem solution (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [CharZero K]
+    (hfg : ∃ x : F, Transcendental K x ∧
+      FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤)
+    {ι : Type*} {b : ι → F} (hb : LinearIndependent K b) :
+    LinearIndependent K' (fun i => algebraMap F F' (b i)) := by
+  obtain ⟨x, hx, hfin⟩ := hfg
+  have := hfin
+  have hx₁ : Transcendental K' (algebraMap F F' x) :=
+    transcendental_algebraMap (K := K) (x := x) hfg' hgen
+  rw [linearIndependent_iff_finset_linearIndependent]
+  intro s
+  exact linearIndependent_algebraMap_of_fintype hx hx₁ (hb.comp ((↑) : s → ι) Subtype.val_injective)
+
+end S_AlgebraicCurve_linearIndependent_of_constantFieldExtension
+end P2MW
+export P2MW.S_AlgebraicCurve_linearIndependent_of_constantFieldExtension (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.linearIndependent_of_constantFieldExtension (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [CharZero K]
+    (hfg : ∃ x : F, Transcendental K x ∧
+      FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤)
+    {ι : Type*} {b : ι → F} (hb : LinearIndependent K b) :
+    LinearIndependent K' (fun i => algebraMap F F' (b i)) :=
+  solution K F K' F' hfg hfg' hgen hb
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_linearIndependent_of_constantFieldExtension_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_linearIndependent_of_constantFieldExtension_of_isAlgClosed.lean
new file mode 100644
index 0000000000..f3b91f25c0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_linearIndependent_of_constantFieldExtension_of_isAlgClosed.lean
@@ -0,0 +1,663 @@
+/-
+Based on Prove2Me node AlgebraicCurve.linearIndependent_of_constantFieldExtension_of_isAlgClosed
+(85c11313-6818-5d4b-bd6e-4bc7a8a742a0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f1127467-c533-508e-bee3-4c966fe6b0a3
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+
+import Mathlib.Algebra.Polynomial.Eval.Irreducible
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.Nullstellensatz
+import Mathlib.RingTheory.Polynomial.IsIntegral
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_separating_transcendental_of_perfectField
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Linear disjointness of a function field from constant field extensions
+
+Theorem statement: `AlgebraicCurve.linearIndependent_of_constantFieldExtension_of_isAlgClosed`
+(`85c11313-6818-5d4b-bd6e-4bc7a8a742a0`), by Claude, 2026-09-05.
+
+Proof: submission `f1127467-c533-508e-bee3-4c966fe6b0a3`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $K'$, $F'$ be fields equipped with $K$-algebra structures on $F$, on $K'$ and on $F'$,
+a $K'$-algebra structure on $F'$ and an $F$-algebra structure on $F'$, compatible in the sense that
+$K \to K' \to F'$ and $K \to F \to F'$ are both scalar towers (so $F'$ contains commuting copies of
+$K'$ and of $F$ over $K$). Assume $K$ is algebraically closed. Assume further that $F$ is a function
+field of one variable over $K$, in the sense that there is an element $x \in F$ transcendental over
+$K$ with $F$ finite-dimensional over the intermediate field $K(x)$ generated by $x$; that $F'$ is
+likewise a function field of one variable over $K'$, i.e. some $x \in F'$ is transcendental over
+$K'$ with $F'$ finite-dimensional over $K'(x)$; and that $F'$ is generated over $K'$ by the image of
+$F$, i.e. the intermediate field of $F'/K'$ generated by the range of $\operatorname{algebraMap} F
+F'$ is all of $F'$. Then for every index type $\iota$ and every family $b : \iota \to F$ that is
+linearly independent over $K$, the image family $i \mapsto \operatorname{algebraMap} F F' (b\,i)$ is
+linearly independent over $K'$.
+
+This is the linear disjointness of $F$ and $K'$ over $K$ for a constant field extension $F' = F\cdot
+K'$ of an algebraic function field of one variable with algebraically closed constant field $K$,
+valid in any characteristic; equivalently, the natural map $F \otimes_K K' \to F'$ is injective. It
+underlies the comparison of a curve over $K$ with its base change to $K'$ — places, divisors and
+regular differentials — and is invoked by the statements on compatibility of places, of the
+$\ell$-function bookkeeping and of Cartier-fixed regular differentials under constant field
+extension. The proof cites
+[`AlgebraicCurve.exists_separating_transcendental_of_perfectField`]
+(thm.html#AlgebraicCurve.exists_separating_transcendental_of_perfectField),
+which produces a separating transcendence element for $F$ over the perfect field $K$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_linearIndependent_of_constantFieldExtension_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_linearIndependent_of_constantFieldExtension_of_isAlgClosed
+
+open Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "exists_separating_transcendental_of_perfectField"
+namespace LinDisjSol
+p2m_open "AlgebraicCurve"
+
+section Generic
+
+variable {R S : Type*} [CommRing R] [CommRing S]
+
+noncomputable def genericPoly (d N : ℕ) (v : Fin d → Fin N → R) : R[X][X] :=
+  X ^ d + ∑ j : Fin d, C (∑ n : Fin N, C (v j n) * X ^ (n : ℕ)) * X ^ (j : ℕ)
+
+theorem genericPoly_map (d N : ℕ) (v : Fin d → Fin N → R) (φ : R →+* S) :
+    (genericPoly d N v).map (mapRingHom φ) = genericPoly d N (fun j n => φ (v j n)) := by
+  simp [genericPoly, Polynomial.map_sum, Polynomial.map_mul, Polynomial.map_pow]
+
+theorem genericPoly_monic [Nontrivial R] (d N : ℕ) (v : Fin d → Fin N → R) :
+    (genericPoly d N v).Monic :=
+  monic_X_pow_add (degree_sum_fin_lt _)
+
+theorem genericPoly_natDegree [Nontrivial R] (d N : ℕ) (v : Fin d → Fin N → R) :
+    (genericPoly d N v).natDegree = d := by
+  unfold genericPoly
+  rw [natDegree_add_eq_left_of_degree_lt, natDegree_X_pow]
+  rw [degree_X_pow]
+  exact degree_sum_fin_lt _
+
+theorem genericPoly_coeff_eq (g : R[X][X]) (hg : g.Monic) (N : ℕ)
+    (hN : ∀ j : ℕ, j < g.natDegree → (g.coeff j).natDegree < N) :
+    genericPoly g.natDegree N (fun j n => (g.coeff j).coeff n) = g := by
+  have inner : ∀ j : Fin g.natDegree,
+      (∑ n : Fin N, C ((g.coeff j).coeff n) * X ^ (n : ℕ)) = g.coeff j := by
+    intro j
+    rw [Fin.sum_univ_eq_sum_range (fun n => C ((g.coeff (j : ℕ)).coeff n) * X ^ n) N]
+    exact (as_sum_range_C_mul_X_pow' _ (hN j j.2)).symm
+  unfold genericPoly
+  simp_rw [inner]
+  rw [Fin.sum_univ_eq_sum_range (fun j => C (g.coeff j) * X ^ j) g.natDegree]
+  exact hg.as_sum.symm
+
+end Generic
+
+section Spec
+
+variable {K K' : Type*} [Field K] [Field K'] [Algebra K K'] [IsAlgClosed K]
+
+theorem exists_factorisation_of_factorisation_map (m : K[X][X])
+    (g h : K'[X][X]) (hg : g.Monic) (hh : h.Monic)
+    (hfac : m.map (mapRingHom (algebraMap K K')) = g * h) :
+    ∃ g₀ h₀ : K[X][X], g₀.Monic ∧ h₀.Monic ∧ g₀.natDegree = g.natDegree ∧
+      h₀.natDegree = h.natDegree ∧ m = g₀ * h₀ := by
+  classical
+  set N : ℕ := ((Finset.range g.natDegree).sup fun j => (g.coeff j).natDegree) ⊔
+      ((Finset.range h.natDegree).sup fun j => (h.coeff j).natDegree) + 1 with hN
+  have hNg : ∀ j : ℕ, j < g.natDegree → (g.coeff j).natDegree < N := by
+    intro j hj
+    have : (g.coeff j).natDegree ≤ (Finset.range g.natDegree).sup fun j => (g.coeff j).natDegree :=
+      Finset.le_sup (f := fun j => (g.coeff j).natDegree) (Finset.mem_range.mpr hj)
+    omega
+  have hNh : ∀ j : ℕ, j < h.natDegree → (h.coeff j).natDegree < N := by
+    intro j hj
+    have : (h.coeff j).natDegree ≤ (Finset.range h.natDegree).sup fun j => (h.coeff j).natDegree :=
+      Finset.le_sup (f := fun j => (h.coeff j).natDegree) (Finset.mem_range.mpr hj)
+    omega
+  set dg := g.natDegree
+  set dh := h.natDegree
+  let σ : Type := (Fin dg × Fin N) ⊕ (Fin dh × Fin N)
+  let c : σ → K' :=
+    Sum.elim (fun jn => (g.coeff jn.1).coeff jn.2) (fun jn => (h.coeff jn.1).coeff jn.2)
+  let R := MvPolynomial σ K
+  let G : R[X][X] := genericPoly dg N (fun j n => MvPolynomial.X (Sum.inl (j, n)))
+  let H : R[X][X] := genericPoly dh N (fun j n => MvPolynomial.X (Sum.inr (j, n)))
+  let evc : R →+* K' := (MvPolynomial.aeval c : R →ₐ[K] K')
+  have hGc : G.map (mapRingHom evc) = g := by
+    rw [genericPoly_map]
+    have : (fun j n => evc (MvPolynomial.X (Sum.inl (j, n)))) =
+        fun (j : Fin dg) (n : Fin N) => (g.coeff j).coeff n := by
+      funext j n; change MvPolynomial.aeval c (MvPolynomial.X _) = _; rw [MvPolynomial.aeval_X]; rfl
+    rw [this]
+    exact genericPoly_coeff_eq g hg N hNg
+  have hHc : H.map (mapRingHom evc) = h := by
+    rw [genericPoly_map]
+    have : (fun j n => evc (MvPolynomial.X (Sum.inr (j, n)))) =
+        fun (j : Fin dh) (n : Fin N) => (h.coeff j).coeff n := by
+      funext j n; change MvPolynomial.aeval c (MvPolynomial.X _) = _; rw [MvPolynomial.aeval_X]; rfl
+    rw [this]
+    exact genericPoly_coeff_eq h hh N hNh
+  let D : R[X][X] := m.map (mapRingHom (algebraMap K R)) - G * H
+  have hDc : D.map (mapRingHom evc) = 0 := by
+    simp only [D, Polynomial.map_sub, Polynomial.map_mul, hGc, hHc, Polynomial.map_map,
+      mapRingHom_comp]
+    have : evc.comp (algebraMap K R) = algebraMap K K' := (MvPolynomial.aeval c).comp_algebraMap
+    rw [this, hfac, sub_self]
+  have hcoeffI : ∀ j n : ℕ, evc ((D.coeff j).coeff n) = 0 := by
+    intro j n
+    have := congrArg (fun P : K'[X][X] => (P.coeff j).coeff n) hDc
+    simpa [coeff_map] using this
+  have hker : RingHom.ker evc ≠ ⊤ := RingHom.ker_ne_top evc
+  obtain ⟨𝔪, h𝔪, hle⟩ := Ideal.exists_le_maximal _ hker
+  have : Finite σ := inferInstance
+  obtain ⟨a, ha⟩ := (MvPolynomial.isMaximal_iff_eq_vanishingIdeal_singleton (K := K)).mp h𝔪
+  let eva : R →+* K := (MvPolynomial.aeval a : R →ₐ[K] K)
+  have heva : ∀ j n : ℕ, eva ((D.coeff j).coeff n) = 0 := by
+    intro j n
+    have hmem : (D.coeff j).coeff n ∈ 𝔪 := hle ((RingHom.mem_ker).mpr (hcoeffI j n))
+    rw [ha] at hmem
+    exact (MvPolynomial.mem_vanishingIdeal_singleton_iff a _).mp hmem
+  have hDa : D.map (mapRingHom eva) = 0 := by
+    ext j n
+    simp [coeff_map, heva]
+  refine ⟨G.map (mapRingHom eva), H.map (mapRingHom eva), ?_, ?_, ?_, ?_, ?_⟩
+  · rw [genericPoly_map]; exact genericPoly_monic _ _ _
+  · rw [genericPoly_map]; exact genericPoly_monic _ _ _
+  · rw [genericPoly_map]; exact genericPoly_natDegree _ _ _
+  · rw [genericPoly_map]; exact genericPoly_natDegree _ _ _
+  · have h1 : (m.map (mapRingHom (algebraMap K R))).map (mapRingHom eva) = m := by
+      rw [Polynomial.map_map, mapRingHom_comp]
+      have : eva.comp (algebraMap K R) = RingHom.id K := by
+        rw [show eva.comp (algebraMap K R) = algebraMap K K from
+          (MvPolynomial.aeval a).comp_algebraMap]
+        exact Algebra.algebraMap_self
+      rw [this, mapRingHom_id, Polynomial.map_id]
+    have h2 := hDa
+    simp only [D, Polynomial.map_sub, Polynomial.map_mul, h1] at h2
+    exact sub_eq_zero.mp h2
+
+theorem irreducible_map_of_isAlgClosed (m : K[X][X]) (hm : m.Monic) (hirr : Irreducible m) :
+    Irreducible (m.map (mapRingHom (algebraMap K K'))) := by
+  classical
+  set m' := m.map (mapRingHom (algebraMap K K')) with hm'def
+  have hm' : m'.Monic := hm.map _
+  have hdeg' : m'.natDegree = m.natDegree := hm.natDegree_map _
+  refine ⟨fun hu => ?_, fun g h hgh => ?_⟩
+  · have h0 : m.natDegree = 0 := by rw [← hdeg']; exact natDegree_eq_zero_of_isUnit hu
+    apply hirr.not_isUnit
+    rw [hm.natDegree_eq_zero] at h0
+    rw [h0]; exact isUnit_one
+  · have hlc : g.leadingCoeff * h.leadingCoeff = 1 := by
+      rw [← leadingCoeff_mul, ← hgh]; exact hm'
+    by_cases hg0 : g.natDegree = 0
+    · left
+      have hlc0 : g.coeff 0 * h.leadingCoeff = 1 := by
+        rwa [leadingCoeff, hg0] at hlc
+      rw [eq_C_of_natDegree_eq_zero hg0]
+      exact isUnit_C.mpr (IsUnit.of_mul_eq_one _ hlc0)
+    by_cases hh0 : h.natDegree = 0
+    · right
+      have hlc0 : h.coeff 0 * g.leadingCoeff = 1 := by
+        rw [mul_comm] at hlc; rwa [leadingCoeff, hh0] at hlc
+      rw [eq_C_of_natDegree_eq_zero hh0]
+      exact isUnit_C.mpr (IsUnit.of_mul_eq_one _ hlc0)
+    exfalso
+    set g₁ : K'[X][X] := C h.leadingCoeff * g
+    set h₁ : K'[X][X] := C g.leadingCoeff * h
+    have hg₁ : g₁.Monic := monic_C_mul_of_mul_leadingCoeff_eq_one (by rw [mul_comm]; exact hlc)
+    have hh₁ : h₁.Monic := monic_C_mul_of_mul_leadingCoeff_eq_one hlc
+    have hlg : g.leadingCoeff ≠ 0 := left_ne_zero_of_mul_eq_one hlc
+    have hlh : h.leadingCoeff ≠ 0 := right_ne_zero_of_mul_eq_one hlc
+    have hdg₁ : g₁.natDegree = g.natDegree := natDegree_C_mul hlh
+    have hdh₁ : h₁.natDegree = h.natDegree := natDegree_C_mul hlg
+    have hfac : m' = g₁ * h₁ := by
+      rw [hgh]
+      simp only [g₁, h₁]
+      calc g * h = C (g.leadingCoeff * h.leadingCoeff) * (g * h) := by rw [hlc, C_1, one_mul]
+        _ = C h.leadingCoeff * g * (C g.leadingCoeff * h) := by rw [C_mul]; ring
+    obtain ⟨g₀, h₀, hg₀, hh₀, hdg₀, hdh₀, hm0⟩ :=
+      exists_factorisation_of_factorisation_map m g₁ h₁ hg₁ hh₁ hfac
+    rcases hirr.isUnit_or_isUnit hm0 with hu | hu
+    · have := natDegree_eq_zero_of_isUnit hu
+      rw [hdg₀, hdg₁] at this; exact hg0 this
+    · have := natDegree_eq_zero_of_isUnit hu
+      rw [hdh₀, hdh₁] at this; exact hh0 this
+
+end Spec
+
+section FunctionField
+
+open IntermediateField
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem algebraMap_comp_aeval_gen (x : F) :
+    (algebraMap K⟮x⟯ F).comp (aeval (AdjoinSimple.gen K x) : K[X] →ₐ[K] K⟮x⟯).toRingHom =
+      (aeval x : K[X] →ₐ[K] F).toRingHom :=
+  RingHom.ext fun p => AdjoinSimple.coe_aeval_gen_apply (F := K) x p
+
+theorem aeval_gen_injective {x : F} (hx : Transcendental K x) :
+    Function.Injective (aeval (AdjoinSimple.gen K x) : K[X] →ₐ[K] K⟮x⟯) := by
+  intro p q hpq
+  apply transcendental_iff_injective.mp hx
+  change aeval x p = aeval x q
+  rw [← AdjoinSimple.coe_aeval_gen_apply (F := K) x p,
+    ← AdjoinSimple.coe_aeval_gen_apply (F := K) x q, hpq]
+
+theorem exists_common_denom {x : F} (hx : Transcendental K x) {T : Type*} [Finite T]
+    (r : T → K⟮x⟯) : ∃ q : K[X], q ≠ 0 ∧ ∀ t, ∃ p : K[X],
+      aeval (AdjoinSimple.gen K x) q * r t = aeval (AdjoinSimple.gen K x) p := by
+  classical
+  let := Fintype.ofFinite T
+  let e := RatFunc.algEquivOfTranscendental x hx
+  let u : T → RatFunc K := fun t => e.symm (r t)
+  have key : ∀ g : K[X], (aeval (AdjoinSimple.gen K x) g : K⟮x⟯) =
+      e (algebraMap K[X] (RatFunc K) g) :=
+    fun g => (RatFunc.algEquivOfTranscendental_algebraMap x hx g).symm
+  refine ⟨∏ t, (u t).denom, ?_, fun t => ?_⟩
+  · exact Finset.prod_ne_zero_iff.mpr fun t _ => RatFunc.denom_ne_zero (u t)
+  · refine ⟨(u t).num * ∏ s ∈ Finset.univ.erase t, (u s).denom, ?_⟩
+    have hr : r t = e (u t) := (e.apply_symm_apply (r t)).symm
+    rw [hr, key, key, ← map_mul]
+    congr 1
+    rw [← Finset.mul_prod_erase Finset.univ (fun s => (u s).denom) (Finset.mem_univ t), map_mul,
+      map_mul]
+    have hden : algebraMap K[X] (RatFunc K) (u t).denom ≠ 0 :=
+      (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr
+        (RatFunc.denom_ne_zero _)
+    calc algebraMap K[X] (RatFunc K) (u t).denom *
+          algebraMap K[X] (RatFunc K) (∏ s ∈ Finset.univ.erase t, (u s).denom) * u t
+        = algebraMap K[X] (RatFunc K) (∏ s ∈ Finset.univ.erase t, (u s).denom) *
+          (algebraMap K[X] (RatFunc K) (u t).denom *
+            (algebraMap _ _ (u t).num / algebraMap _ _ (u t).denom)) := by
+          rw [RatFunc.num_div_denom]; ring
+      _ = algebraMap K[X] (RatFunc K) (u t).num *
+          algebraMap K[X] (RatFunc K) (∏ s ∈ Finset.univ.erase t, (u s).denom) := by
+          rw [mul_div_cancel₀ _ hden]; ring
+
+theorem exists_primitive_integral {x : F} (hx : Transcendental K x)
+    [FiniteDimensional K⟮x⟯ F] [Algebra.IsSeparable K⟮x⟯ F] :
+    ∃ (y : F) (m : K[X][X]) (d : ℕ), m.Monic ∧ Irreducible m ∧ m.natDegree = d ∧
+      m.eval₂ (aeval x : K[X] →ₐ[K] F).toRingHom y = 0 ∧
+      ∀ f : F, ∃ r : Fin d → K⟮x⟯, f = ∑ j, algebraMap K⟮x⟯ F (r j) * y ^ (j : ℕ) := by
+  classical
+  obtain ⟨y₀, hy₀⟩ := Field.exists_primitive_element K⟮x⟯ F
+  have hy₀int : IsIntegral K⟮x⟯ y₀ := Algebra.IsIntegral.isIntegral y₀
+  set μ : K⟮x⟯[X] := minpoly K⟮x⟯ y₀ with hμ
+  obtain ⟨q, hq0, hq⟩ :=
+    exists_common_denom hx (fun i : Fin (μ.natDegree + 1) => μ.coeff i)
+  choose p hp using hq
+  set s : K⟮x⟯ := aeval (AdjoinSimple.gen K x) q with hs
+  have hs0 : s ≠ 0 := by
+    intro h
+    apply hq0
+    apply aeval_gen_injective hx
+    rw [map_zero]; exact h
+  set y : F := algebraMap K⟮x⟯ F s * y₀ with hy
+  set μs : K⟮x⟯[X] := μ.scaleRoots s with hμs
+  have hμs_monic : μs.Monic := (monic_scaleRoots_iff s).mpr (minpoly.monic hy₀int)
+  have hμs_root : aeval y μs = 0 := scaleRoots_aeval_eq_zero (minpoly.aeval K⟮x⟯ y₀)
+  have hμs_deg : μs.natDegree = μ.natDegree := natDegree_scaleRoots _ _
+  have hlifts : μs ∈ Polynomial.lifts
+      (aeval (AdjoinSimple.gen K x) : K[X] →ₐ[K] K⟮x⟯).toRingHom := by
+    rw [lifts_iff_coeff_lifts]
+    intro n
+    rw [hμs, coeff_scaleRoots]
+    rcases lt_trichotomy n μ.natDegree with hlt | heq | hgt
+    · obtain ⟨k, hk⟩ : ∃ k, μ.natDegree - n = k + 1 := ⟨μ.natDegree - n - 1, by omega⟩
+      refine ⟨p ⟨n, by omega⟩ * q ^ k, ?_⟩
+      have := hp ⟨n, by omega⟩
+      simp only at this
+      change aeval (AdjoinSimple.gen K x) (p ⟨n, by omega⟩ * q ^ k) = _
+      rw [map_mul, map_pow, ← this, hk, pow_succ]
+      ring
+    · subst heq
+      refine ⟨1, ?_⟩
+      change aeval (AdjoinSimple.gen K x) (1 : K[X]) = _
+      rw [map_one, Nat.sub_self, pow_zero, mul_one]
+      exact (minpoly.monic hy₀int).coeff_natDegree.symm
+    · refine ⟨0, ?_⟩
+      change aeval (AdjoinSimple.gen K x) (0 : K[X]) = _
+      rw [map_zero, coeff_eq_zero_of_natDegree_lt hgt, zero_mul]
+  obtain ⟨m, hmμs, hmdeg, hmmonic⟩ := lifts_and_natDegree_eq_and_monic hlifts hμs_monic
+  have hyint : IsIntegral K⟮x⟯ y := Algebra.IsIntegral.isIntegral y
+  have htop : K⟮x⟯⟮y⟯ = ⊤ := by
+    rw [eq_top_iff, ← hy₀, adjoin_simple_le_iff]
+    have : y₀ = algebraMap K⟮x⟯ F s⁻¹ * y := by
+      rw [hy, ← mul_assoc, ← map_mul, inv_mul_cancel₀ hs0, map_one, one_mul]
+    rw [this]
+    exact mul_mem (IntermediateField.algebraMap_mem _ _) (mem_adjoin_simple_self _ y)
+  have hdegμ : μ.natDegree = Module.finrank K⟮x⟯ F := by
+    rw [hμ, ← adjoin.finrank hy₀int, hy₀, finrank_top']
+  have hdegy : (minpoly K⟮x⟯ y).natDegree = Module.finrank K⟮x⟯ F := by
+    rw [← adjoin.finrank hyint, htop, finrank_top']
+  have hμs_eq : μs = minpoly K⟮x⟯ y :=
+    eq_of_monic_of_dvd_of_natDegree_le (minpoly.monic hyint) hμs_monic
+      (minpoly.dvd _ _ hμs_root) (by rw [hμs_deg, hdegμ, hdegy])
+  have hirr : Irreducible m :=
+    Monic.irreducible_of_irreducible_map _ m hmmonic
+      (by rw [hmμs, hμs_eq]; exact minpoly.irreducible hyint)
+  have hroot : m.eval₂ (aeval x : K[X] →ₐ[K] F).toRingHom y = 0 := by
+    have h := hμs_root
+    rw [← hmμs, aeval_def, eval₂_map] at h
+    rwa [← algebraMap_comp_aeval_gen x]
+  let pb := adjoin.powerBasis hyint
+  refine ⟨y, m, (minpoly K⟮x⟯ y).natDegree, hmmonic, hirr, ?_, hroot, fun f => ?_⟩
+  · rw [hmdeg, hμs_eq]
+  · have hf : f ∈ K⟮x⟯⟮y⟯ := by rw [htop]; exact mem_top
+    refine ⟨fun j => pb.basis.repr ⟨f, hf⟩ j, ?_⟩
+    have hsum := pb.basis.sum_repr ⟨f, hf⟩
+    calc f = (K⟮x⟯⟮y⟯).val ⟨f, hf⟩ := rfl
+      _ = (K⟮x⟯⟮y⟯).val (∑ i, pb.basis.repr ⟨f, hf⟩ i • pb.basis i) := by rw [hsum]
+      _ = _ := by
+        rw [map_sum]
+        refine Finset.sum_congr rfl fun j _ => ?_
+        rw [map_smul, Algebra.smul_def, pb.basis_eq_pow, map_pow]
+        rfl
+
+end FunctionField
+
+section Main
+
+open IntermediateField
+
+variable {K F K' F' : Type*} [Field K] [Field F] [Field K'] [Field F'] [Algebra K F]
+  [Algebra K' F'] [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F']
+  [IsScalarTower K F F']
+
+theorem algebraMap_mem_adjoin (x : F) (z : K⟮x⟯) :
+    algebraMap F F' (z : F) ∈ K'⟮algebraMap F F' x⟯ := by
+  let ιFa : F →ₐ[K] F' := IsScalarTower.toAlgHom K F F'
+  have h1 : algebraMap F F' (z : F) ∈ (K⟮x⟯).map ιFa := ⟨z, z.2, rfl⟩
+  rw [adjoin_map, Set.image_singleton] at h1
+  have h2 : K⟮ιFa x⟯ ≤ (K'⟮algebraMap F F' x⟯).restrictScalars K :=
+    adjoin_simple_le_iff.mpr (mem_adjoin_simple_self K' _)
+  exact h2 h1
+
+theorem exists_ringHom_adjoin (x : F) : ∃ ρ : K⟮x⟯ →+* K'⟮algebraMap F F' x⟯,
+    ∀ z, algebraMap K'⟮algebraMap F F' x⟯ F' (ρ z) = algebraMap F F' (algebraMap K⟮x⟯ F z) :=
+  ⟨((algebraMap F F').comp (algebraMap K⟮x⟯ F)).codRestrict (K'⟮algebraMap F F' x⟯)
+      (fun z => algebraMap_mem_adjoin x z), fun _ => rfl⟩
+
+theorem isIntegral_algebraMap (x : F) [FiniteDimensional K⟮x⟯ F] (f : F) :
+    IsIntegral K'⟮algebraMap F F' x⟯ (algebraMap F F' f) := by
+  obtain ⟨ρ, hρ⟩ := exists_ringHom_adjoin (K := K) (K' := K') (F' := F') x
+  have hf : IsIntegral K⟮x⟯ f := Algebra.IsIntegral.isIntegral f
+  refine ⟨(minpoly K⟮x⟯ f).map ρ, (minpoly.monic hf).map ρ, ?_⟩
+  have hcomp : (algebraMap K'⟮algebraMap F F' x⟯ F').comp ρ =
+      (algebraMap F F').comp (algebraMap K⟮x⟯ F) := RingHom.ext hρ
+  rw [eval₂_map, hcomp, ← hom_eval₂, ← aeval_def, minpoly.aeval, map_zero]
+
+theorem transcendental_algebraMap {x : F} [FiniteDimensional K⟮x⟯ F]
+    (hfg' : ∃ x' : F', Transcendental K' x' ∧ FiniteDimensional K'⟮x'⟯ F')
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤) :
+    Transcendental K' (algebraMap F F' x) := by
+  intro hx₁
+  obtain ⟨x', hx', -⟩ := hfg'
+  apply hx'
+  have : FiniteDimensional K' K'⟮algebraMap F F' x⟯ := adjoin.finiteDimensional hx₁.isIntegral
+  have hS : ∀ z ∈ Set.range (algebraMap F F'), IsIntegral K' z := by
+    rintro _ ⟨f, rfl⟩
+    exact isIntegral_trans (R := K') _ (isIntegral_algebraMap (K := K) (K' := K') x f)
+  have := IntermediateField.isAlgebraic_adjoin hS
+  have hmem : x' ∈ IntermediateField.adjoin K' (Set.range (algebraMap F F')) := by
+    rw [hgen]; exact mem_top
+  exact IntermediateField.isAlgebraic_iff.mp
+    (Algebra.IsAlgebraic.isAlgebraic
+      (⟨x', hmem⟩ : IntermediateField.adjoin K' (Set.range (algebraMap F F'))))
+
+theorem linearIndependent_pow_algebraMap [IsAlgClosed K] {x : F}
+    (hx₁ : Transcendental K' (algebraMap F F' x))
+    {y : F} {m : K[X][X]} (hm : m.Monic) (hirr : Irreducible m)
+    (hroot : m.eval₂ (aeval x : K[X] →ₐ[K] F).toRingHom y = 0) :
+    LinearIndependent K'⟮algebraMap F F' x⟯
+      (fun j : Fin m.natDegree => algebraMap F F' y ^ (j : ℕ)) := by
+  classical
+  set x₁ := algebraMap F F' x with hx₁def
+  set y₁ := algebraMap F F' y with hy₁def
+  let ψ : K[X] →+* K'⟮x₁⟯ :=
+    (aeval (AdjoinSimple.gen K' x₁) : K'[X] →ₐ[K'] K'⟮x₁⟯).toRingHom.comp
+      (mapRingHom (algebraMap K K'))
+  set M : K'⟮x₁⟯[X] := m.map ψ with hM
+  have hMmonic : M.Monic := hm.map ψ
+  have hcomp : (algebraMap K'⟮x₁⟯ F').comp ψ = (algebraMap F F').comp (aeval x).toRingHom := by
+    refine Polynomial.ringHom_ext (fun a => ?_) ?_
+    · simp only [ψ, RingHom.coe_comp, Function.comp_apply, coe_mapRingHom, map_C,
+        AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom, aeval_C]
+      rw [← IsScalarTower.algebraMap_apply, ← IsScalarTower.algebraMap_apply,
+        ← IsScalarTower.algebraMap_apply]
+    · simp only [ψ, RingHom.coe_comp, Function.comp_apply, coe_mapRingHom, map_X,
+        AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom, aeval_X]
+      rfl
+  have hMroot : aeval y₁ M = 0 := by
+    rw [aeval_def, hM, eval₂_map, hcomp, hy₁def, ← hom_eval₂, hroot, map_zero]
+  have hMirr : Irreducible M := by
+    have h0 : Irreducible (m.map (mapRingHom (algebraMap K K'))) :=
+      irreducible_map_of_isAlgClosed m hm hirr
+    have h1 : Irreducible ((m.map (mapRingHom (algebraMap K K'))).map
+        (algebraMap K'[X] (RatFunc K'))) :=
+      ((hm.map _).irreducible_iff_irreducible_map_fraction_map).mp h0
+    let e := RatFunc.algEquivOfTranscendental x₁ hx₁
+    have h2 := h1.map (mapEquiv (e : RatFunc K' ≃+* K'⟮x₁⟯))
+    have h3 : mapEquiv (e : RatFunc K' ≃+* K'⟮x₁⟯)
+        ((m.map (mapRingHom (algebraMap K K'))).map (algebraMap K'[X] (RatFunc K'))) = M := by
+      rw [mapEquiv_apply, Polynomial.map_map, Polynomial.map_map, hM]
+      congr 1
+      refine RingHom.ext fun g => ?_
+      simp only [ψ, RingHom.coe_comp, Function.comp_apply, coe_mapRingHom, RingHom.coe_coe,
+        AlgHom.toRingHom_eq_coe]
+      exact RatFunc.algEquivOfTranscendental_algebraMap x₁ hx₁ _
+    rw [h3] at h2
+    exact h2
+  have hMeq : M = minpoly K'⟮x₁⟯ y₁ := minpoly.eq_of_irreducible_of_monic hMirr hMroot hMmonic
+  have hdeg : (minpoly K'⟮x₁⟯ y₁).natDegree = m.natDegree := by
+    rw [← hMeq, hM]; exact hm.natDegree_map ψ
+  have hli := linearIndependent_pow (K := K'⟮x₁⟯) y₁
+  rw [hdeg] at hli
+  exact hli
+
+theorem eq_zero_of_sum_C_mul_map {κ : Type*} [Fintype κ] {c : κ → K'}
+    (hc : LinearIndependent K c) (p : κ → K[X])
+    (h : ∑ k, C (c k) * (p k).map (algebraMap K K') = 0) : ∀ k, p k = 0 := by
+  have hn : ∀ n : ℕ, ∀ k, (p k).coeff n = 0 := by
+    intro n
+    have h1 := congrArg (fun P : K'[X] => P.coeff n) h
+    simp only [finsetSum_coeff, coeff_C_mul, coeff_map, coeff_zero] at h1
+    have h2 : ∑ k, (p k).coeff n • c k = 0 := by
+      rw [← h1]
+      refine Finset.sum_congr rfl fun k _ => ?_
+      rw [Algebra.smul_def, mul_comm]
+    exact Fintype.linearIndependent_iff.mp hc _ h2
+  intro k
+  ext n
+  simp [hn n k]
+
+omit [Algebra K F'] [IsScalarTower K K' F'] in
+theorem eq_zero_of_sum_aeval {x₁ : F'} (hx₁ : Transcendental K' x₁) {κ : Type*} [Fintype κ]
+    {c : κ → K'} (hc : LinearIndependent K c) (p : κ → K[X])
+    (h : ∑ k, algebraMap K' K'⟮x₁⟯ (c k) *
+      aeval (AdjoinSimple.gen K' x₁) ((p k).map (algebraMap K K')) = 0) : ∀ k, p k = 0 := by
+  apply eq_zero_of_sum_C_mul_map hc
+  apply aeval_gen_injective hx₁
+  rw [map_sum, map_zero, ← h]
+  refine Finset.sum_congr rfl fun k _ => ?_
+  rw [map_mul, aeval_C]
+
+theorem eq_zero_of_sum_mul_algebraMap [IsAlgClosed K] {x : F}
+    (hx : Transcendental K x) [FiniteDimensional K⟮x⟯ F] [Algebra.IsSeparable K⟮x⟯ F]
+    (hx₁ : Transcendental K' (algebraMap F F' x))
+    {κ : Type*} [Fintype κ] {c : κ → K'} (hc : LinearIndependent K c) (f : κ → F)
+    (hrel : ∑ k, algebraMap F F' (f k) * algebraMap K' F' (c k) = 0) : ∀ k, f k = 0 := by
+  classical
+  obtain ⟨y, m, d, hm, hirr, hd, hroot, hspan⟩ := exists_primitive_integral hx
+  subst hd
+  obtain ⟨ρ, hρ⟩ := exists_ringHom_adjoin (K := K) (K' := K') (F' := F') x
+  have hLD := linearIndependent_pow_algebraMap (K := K) hx₁ hm hirr hroot
+  choose r hr using fun k => hspan (f k)
+  obtain ⟨q, hq0, hq⟩ := exists_common_denom hx (fun kj : κ × Fin m.natDegree => r kj.1 kj.2)
+  choose P hP using hq
+  have hcoefE : ∀ j : Fin m.natDegree,
+      ∑ k, algebraMap K' K'⟮algebraMap F F' x⟯ (c k) * ρ (r k j) = 0 := by
+    have hsum : ∑ j : Fin m.natDegree,
+        (∑ k, algebraMap K' K'⟮algebraMap F F' x⟯ (c k) * ρ (r k j)) •
+          algebraMap F F' y ^ (j : ℕ) = 0 := by
+      rw [← hrel]
+      simp_rw [Finset.sum_smul, Algebra.smul_def]
+      rw [Finset.sum_comm]
+      refine Finset.sum_congr rfl fun k _ => ?_
+      rw [hr k, map_sum, Finset.sum_mul]
+      refine Finset.sum_congr rfl fun j _ => ?_
+      rw [map_mul, map_mul, ← IsScalarTower.algebraMap_apply, hρ, map_pow]
+      ring
+    exact Fintype.linearIndependent_iff.mp hLD _ hsum
+  have hρθ : ∀ p : K[X], ρ (aeval (AdjoinSimple.gen K x) p) =
+      aeval (AdjoinSimple.gen K' (algebraMap F F' x)) (p.map (algebraMap K K')) := by
+    intro p
+    apply (algebraMap K'⟮algebraMap F F' x⟯ F').injective
+    rw [hρ]
+    change algebraMap F F' ((aeval (AdjoinSimple.gen K x) p : K⟮x⟯) : F) =
+      ((aeval (AdjoinSimple.gen K' (algebraMap F F' x)) (p.map (algebraMap K K')) :
+        K'⟮algebraMap F F' x⟯) : F')
+    rw [AdjoinSimple.coe_aeval_gen_apply, AdjoinSimple.coe_aeval_gen_apply, aeval_map_algebraMap,
+      aeval_algebraMap_apply]
+  have hP0 : ∀ k j, P (k, j) = 0 := by
+    intro k j
+    refine eq_zero_of_sum_aeval hx₁ hc (fun k => P (k, j)) ?_ k
+    have := congrArg (fun z => ρ (aeval (AdjoinSimple.gen K x) q) * z) (hcoefE j)
+    simp only [mul_zero, Finset.mul_sum] at this
+    rw [← this]
+    refine Finset.sum_congr rfl fun k _ => ?_
+    rw [← hρθ, ← hP (k, j), map_mul]
+    ring
+  have hs0 : (aeval (AdjoinSimple.gen K x) q : K⟮x⟯) ≠ 0 := by
+    intro h
+    apply hq0
+    apply aeval_gen_injective hx
+    rw [map_zero]; exact h
+  have hr0 : ∀ k j, r k j = 0 := by
+    intro k j
+    have := hP (k, j)
+    rw [hP0 k j, map_zero] at this
+    exact (mul_eq_zero.mp this).resolve_left hs0
+  intro k
+  rw [hr k]
+  simp [hr0]
+
+theorem linearIndependent_algebraMap_of_fintype [IsAlgClosed K] {x : F}
+    (hx : Transcendental K x) [FiniteDimensional K⟮x⟯ F] [Algebra.IsSeparable K⟮x⟯ F]
+    (hx₁ : Transcendental K' (algebraMap F F' x))
+    {κ : Type*} [Finite κ] {b : κ → F} (hb : LinearIndependent K b) :
+    LinearIndependent K' (fun i => algebraMap F F' (b i)) := by
+  classical
+  let := Fintype.ofFinite κ
+  rw [Fintype.linearIndependent_iff]
+  intro a hrel i₀
+  let W : Submodule K K' := Submodule.span K (Set.range a)
+  have : Module.Finite K W := Module.Finite.span_of_finite K (Set.finite_range a)
+  let bW := Module.finBasis K W
+  let c : Fin (Module.finrank K W) → K' := fun k => (bW k : K')
+  have hc : LinearIndependent K c :=
+    bW.linearIndependent.map' W.subtype (Submodule.ker_subtype W)
+  have ha : ∀ i, a i ∈ W := fun i => Submodule.subset_span ⟨i, rfl⟩
+  let μ : κ → Fin (Module.finrank K W) → K := fun i k => bW.repr ⟨a i, ha i⟩ k
+  have hai : ∀ i, a i = ∑ k, μ i k • c k := by
+    intro i
+    have h1 := congrArg (Submodule.subtype W) (bW.sum_repr ⟨a i, ha i⟩)
+    rw [map_sum] at h1
+    simp only [map_smul, Submodule.subtype_apply] at h1
+    exact h1.symm
+  let f : Fin (Module.finrank K W) → F := fun k => ∑ i, μ i k • b i
+  have hf : ∀ k, f k = 0 := by
+    apply eq_zero_of_sum_mul_algebraMap hx hx₁ hc f
+    have lhs : ∑ k, algebraMap F F' (f k) * algebraMap K' F' (c k) =
+        ∑ k, ∑ i, algebraMap K F' (μ i k) * algebraMap F F' (b i) * algebraMap K' F' (c k) := by
+      refine Finset.sum_congr rfl fun k _ => ?_
+      simp only [f, map_sum, Finset.sum_mul]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [Algebra.smul_def, map_mul, ← IsScalarTower.algebraMap_apply]
+    have rhs : ∑ i, a i • algebraMap F F' (b i) =
+        ∑ i, ∑ k, algebraMap K F' (μ i k) * algebraMap F F' (b i) * algebraMap K' F' (c k) := by
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [hai i, Algebra.smul_def, map_sum, Finset.sum_mul]
+      refine Finset.sum_congr rfl fun k _ => ?_
+      rw [Algebra.smul_def, map_mul, ← IsScalarTower.algebraMap_apply]
+      ring
+    rw [lhs, Finset.sum_comm, ← rhs, hrel]
+  have hμ : ∀ k i, μ i k = 0 := fun k =>
+    Fintype.linearIndependent_iff.mp hb (fun i => μ i k) (hf k)
+  rw [hai i₀]
+  simp [hμ]
+
+end Main
+
+end AlgebraicCurve.LinDisjSol
+
+open AlgebraicCurve.LinDisjSol in
+theorem solution (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K]
+    (hfg : ∃ x : F, Transcendental K x ∧
+      FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤)
+    {ι : Type*} {b : ι → F} (hb : LinearIndependent K b) :
+    LinearIndependent K' (fun i => algebraMap F F' (b i)) := by
+  obtain ⟨x₀, hx₀, hfin₀⟩ := hfg
+  obtain ⟨x, hx, hfin, hsep⟩ :=
+    AlgebraicCurve.exists_separating_transcendental_of_perfectField hx₀ hfin₀
+  have := hfin
+  have := hsep
+  have hx₁ : Transcendental K' (algebraMap F F' x) :=
+    transcendental_algebraMap (K := K) (x := x) hfg' hgen
+  rw [linearIndependent_iff_finset_linearIndependent]
+  intro s
+  exact linearIndependent_algebraMap_of_fintype hx hx₁ (hb.comp ((↑) : s → ι) Subtype.val_injective)
+
+end S_AlgebraicCurve_linearIndependent_of_constantFieldExtension_of_isAlgClosed
+end P2MW
+export P2MW.S_AlgebraicCurve_linearIndependent_of_constantFieldExtension_of_isAlgClosed (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.linearIndependent_of_constantFieldExtension_of_isAlgClosed
+    (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K]
+    (hfg : ∃ x : F, Transcendental K x ∧
+      FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤)
+    {ι : Type*} {b : ι → F} (hb : LinearIndependent K b) :
+    LinearIndependent K' (fun i => algebraMap F F' (b i)) :=
+  solution K F K' F' hfg hfg' hgen hb
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_linearIndependent_pow_mul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_linearIndependent_pow_mul.lean
new file mode 100644
index 0000000000..f7c7fc334f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_linearIndependent_pow_mul.lean
@@ -0,0 +1,2383 @@
+/-
+Based on Prove2Me node AlgebraicCurve.linearIndependent_pow_mul
+(cb876ba6-ecd7-54ac-9853-98e43065b07c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 721f0a59-0896-5990-a857-3db2d252cf27
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Algebra.Defs
+public import Mathlib.LinearAlgebra.LinearIndependent.Defs
+
+import Mathlib.Data.Int.LeastGreatest
+import Mathlib.LinearAlgebra.Matrix.FiniteDimensional
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PoleDivisorPackage
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Linear independence of the products x^j uᵢ
+
+Theorem statement: `AlgebraicCurve.linearIndependent_pow_mul`
+(`cb876ba6-ecd7-54ac-9853-98e43065b07c`), by Claude, 2026-09-05.
+
+Proof: submission `721f0a59-0896-5990-a857-3db2d252cf27`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $E$, $F$ be fields forming a tower: $E$ and $F$ are $K$-algebras, $F$ is an $E$-algebra,
+and the three structures are compatible as a scalar tower over $K$. Let $x \in E$, let $n$ be a
+natural number, and let $u : \mathrm{Fin}\,n \to F$ be a finite family of elements of $F$. Assume
+that the family of powers $(x^j)_{j \in \mathbb{N}}$ is linearly independent over $K$ (that is, $x$
+is transcendental over $K$), and that the family $u$ is linearly independent over $E$. The
+conclusion is that the family indexed by $\mathbb{N} \times \mathrm{Fin}\,n$ which sends a pair $(j,
+i)$ to $\xi^j \, u_i$, where $\xi$ denotes the image of $x$ in $F$ under the structure map $E \to
+F$, is linearly independent over $K$. Note that the index set of the conclusion is infinite, the
+exponent $j$ ranging over all of $\mathbb{N}$, while the second index ranges over the finite set
+$\mathrm{Fin}\,n$; linear independence is therefore the assertion that every finitely supported
+$K$-linear relation among the $\xi^j u_i$ has all coefficients zero.
+
+This is the standard linear-independence step in the theory of algebraic function fields: a
+transcendental element of an intermediate field together with an $E$-free family in the upper field
+produces a $K$-free family of products. It supplies the linear-independence clause used in
+assembling pole-divisor data, and is cited in the proof of
+[`AlgebraicCurve.Divisor.finrank_adjoin_le_degree_of_eq_max_neg_ord`]
+(thm.html#AlgebraicCurve.Divisor.finrank_adjoin_le_degree_of_eq_max_neg_ord).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_linearIndependent_pow_mul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_linearIndependent_pow_mul
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow mk.injEq algebraMap_mem' toValuationSubring mk \
+  ramificationIndex ramificationIndex_pos restrict mem_restrict_iff ord_restrict \
+  deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg"
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "degree degree_single principal smul_def smul_apply pullback \
+  pullback_apply degree_pullback"
+end Divisor
+variable {D : Divisor K F}
+p2m_open_scoped "AlgebraicCurve.Divisor" in
+theorem Divisor.degree_nonneg_of_nonneg [IsCurveOver K F]
+    {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) : 0 ≤ Divisor.degree D := by
+  rw [Divisor.degree_eq_sum_support]
+  exact Finset.sum_nonneg fun v _ => mul_nonneg (hD v) (Int.natCast_nonneg _)
+theorem lSpace_eq_bot_of_degree_neg [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) : LSpace D = ⊥ := by
+  rw [eq_bot_iff]
+  intro f hf
+  rw [Submodule.mem_bot]
+  by_contra hf0
+  obtain ⟨P, hPord, hPdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+  have heff : ∀ v : Place K F, 0 ≤ (P + D) v := by
+    intro v
+    rw [Finsupp.add_apply, hPord]
+    rcases mem_lSpace_iff_ord.mp hf with rfl | h
+    · exact absurd rfl hf0
+    · linarith [h v]
+  have hdegPD : 0 ≤ Divisor.degree (P + D) := Divisor.degree_nonneg_of_nonneg heff
+  rw [map_add, hPdeg, zero_add] at hdegPD
+  exact absurd hdegPD (not_le.mpr hD)
+end AlgebraicCurve
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow mk.injEq algebraMap_mem' toValuationSubring mk \
+  ramificationIndex ramificationIndex_pos restrict mem_restrict_iff ord_restrict \
+  deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~comap_algebra\
+  Map_ne_top"
+
+variable (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mk_mem_maximalIdeal_iff {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    (⟨f, hf⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring
+      ↔ f = 0 ∨ 0 < v.ord f := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  constructor
+  · intro hu
+    rcases eq_or_ne f 0 with rfl | hf0
+    · exact Or.inl rfl
+    · refine Or.inr ?_
+      rcases lt_or_eq_of_le (AlgebraicCurve.Place.ord_nonneg_of_mem v hf) with h | h
+      · exact h
+      · exfalso
+        apply hu
+        rw [← v.adicValuation_coe_eq_one_iff ⟨f, hf⟩]
+        change v.adicValuation f = 1
+        rw [v.adicValuation_eq_exp_neg_ord hf0, ← h, neg_zero, WithZero.exp_zero]
+  · intro h hu
+    have hne : f ≠ 0 := fun h0 => hu.ne_zero (Subtype.ext h0)
+    have h0 : v.ord f = 0 := by
+      obtain ⟨u, hu'⟩ := hu
+      have hcoe : f = ((u : v.toValuationSubring) : F) := by rw [hu']
+      rw [hcoe]; exact v.ord_coe_unit u
+    rcases h with rfl | hpos
+    · exact hne rfl
+    · omega
+
+p2m_export "AlgebraicCurve.Place" "mk_mem_maximalIdeal_iff"
+end Place
+
+theorem ell_le_ell_sub_single_add_deg [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    ell D ≤ ell (D - Finsupp.single P 1) + P.deg := by
+  classical
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible P.toValuationSubring
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by
+    simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := by
+    intro g hg
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ g : F, g ∈ LSpace D → t ^ (D P) * g ∈ P.toValuationSubring := by
+    intro g hg
+    rcases eq_or_ne g 0 with rfl | hg0
+    · simp
+    · refine AlgebraicCurve.Place.mem_of_ord_nonneg P (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have := (mem_lSpace_iff_ord.mp hg).resolve_left hg0 P
+      linarith
+  let ψ : LSpace D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun f => ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+      map_add' := by intro f g; apply Subtype.ext; push_cast; ring
+      map_smul' := by
+        intro c f; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap]
+        ring }
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : LSpace D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ f : LSpace D, φ f = 0 ↔
+      (⟨t ^ (D P) * (f : F), hmem _ f.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := by
+    intro f
+    rw [show φ f = IsLocalRing.residue P.toValuationSubring ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+          from hres (ψ f),
+      IsLocalRing.residue_eq_zero_iff]
+  have hED : E ≤ D := by
+    rw [Finsupp.le_def]; intro v; rw [hE, Finsupp.sub_apply]
+    have : (0 : ℤ) ≤ Finsupp.single P 1 v := by
+      rcases eq_or_ne v P with rfl | hv
+      · simp
+      · simp [Finsupp.single_eq_of_ne hv]
+    linarith
+  have hsub : LSpace E ≤ LSpace D := lSpace_mono hED
+  have hker : LinearMap.ker φ = (LSpace E).comap (LSpace D).subtype := by
+    ext f
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi f, P.mk_mem_maximalIdeal_iff]
+    rcases eq_or_ne (f : F) 0 with hf0 | hf0
+    · simp only [hf0, mul_zero, true_or, true_iff]
+      exact (LSpace E).zero_mem
+    · rw [mem_lSpace_iff_ord]
+      have hfD := (mem_lSpace_iff_ord.mp f.2).resolve_left hf0
+      constructor
+      · rintro (h | h)
+        · exact absurd h (mul_ne_zero htn0 hf0)
+        · refine Or.inr (fun v => ?_)
+          rcases eq_or_ne v P with rfl | hv
+          · rw [hEP]; rw [hordmul hf0] at h; omega
+          · rw [hEv v hv]; exact hfD v
+      · rintro (h | h)
+        · exact absurd h hf0
+        · refine Or.inr ?_
+          have hP := h P
+          rw [hEP] at hP
+          rw [hordmul hf0]; omega
+  have hkerfin : finrank K (LinearMap.ker φ) = ell E := by
+    rw [hker, LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe hsub)]
+  have hquot : finrank K (LSpace D ⧸ LinearMap.ker φ) ≤ P.deg := by
+    rw [LinearEquiv.finrank_eq φ.quotKerEquivRange]
+    exact Submodule.finrank_le (LinearMap.range φ)
+  by_cases hfin : FiniteDimensional K (LSpace D)
+  · have := hfin
+    have hrn := Submodule.finrank_quotient_add_finrank (LinearMap.ker φ)
+    rw [hkerfin] at hrn
+    have hb : ell D = finrank K (LSpace D) := rfl
+    omega
+  · have h0 : ell D = 0 := by rw [ell]; exact finrank_of_infinite_dimensional hfin
+    omega
+
+theorem one_le_deg [IsCurveOver K F] (P : Place K F) : 1 ≤ P.deg := by
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  exact Module.finrank_pos
+
+theorem ell_le_degree_add_ellZero [IsCurveOver K F] {D : Divisor K F}
+    (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D : Divisor K F, (∀ v, 0 ≤ D v) →
+      (Divisor.degree D).toNat = m →
+      (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) by
+    exact H (Divisor.degree D).toNat D hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D hD hm
+    by_cases hD0 : D = 0
+    · subst hD0; simp
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ D P := by
+        have hne : D P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hD P; omega
+      set E : Divisor K F := D - Finsupp.single P 1 with hE
+      have hEeff : ∀ v, 0 ≤ E v := by
+        intro v; rw [hE, Finsupp.sub_apply]
+        rcases eq_or_ne v P with rfl | hv
+        · rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have hdegE : Divisor.degree E = Divisor.degree D - P.deg := by
+        rw [hE, map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hDnn : 0 ≤ Divisor.degree D := Divisor.degree_nonneg_of_nonneg hD
+      have hEnn : 0 ≤ Divisor.degree E := Divisor.degree_nonneg_of_nonneg hEeff
+      have hmlt : (Divisor.degree E).toNat < m := by rw [← hm]; omega
+      have hIH := IH _ hmlt E hEeff rfl
+      have hstep := ell_le_ell_sub_single_add_deg D P
+      rw [← hE] at hstep
+      have hstep' : (ell D : ℤ) ≤ (ell E : ℤ) + P.deg := by exact_mod_cast hstep
+      rw [hdegE] at hIH
+      linarith
+
+theorem ell_le_degree_add_one_of_effective [IsCurveOver K F]
+    (hC : ConstantsAreBase K F) {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  have h := ell_le_degree_add_ellZero hD
+  rw [ell_zero_eq_one_of_constantsAreBase hC] at h
+  exact_mod_cast h
+
+def lSpaceShiftEquiv (D : Divisor K F) {g : F} (hg : g ≠ 0)
+    {Dg : Divisor K F} (hDg : ∀ v, Dg v = v.ord g) :
+    LSpace D ≃ₗ[K] LSpace (D + Dg) where
+  toFun h := ⟨(h : F) * g⁻¹, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (h : F) 0 with hh0 | hh0
+    · left; rw [hh0, zero_mul]
+    · right; intro v
+      rw [Finsupp.add_apply, hDg, v.ord_mul hh0 (inv_ne_zero hg), v.ord_inv]
+      have := (mem_lSpace_iff_ord.mp h.2).resolve_left hh0 v
+      linarith⟩
+  invFun k := ⟨(k : F) * g, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (k : F) 0 with hk0 | hk0
+    · left; rw [hk0, zero_mul]
+    · right; intro v
+      have := (mem_lSpace_iff_ord.mp k.2).resolve_left hk0 v
+      rw [Finsupp.add_apply, hDg] at this
+      rw [v.ord_mul hk0 hg]
+      linarith⟩
+  map_add' h₁ h₂ := by apply Subtype.ext; push_cast; ring
+  map_smul' c h := by
+    apply Subtype.ext
+    simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def]
+    ring
+  left_inv h := by
+    apply Subtype.ext
+    change (h : F) * g⁻¹ * g = (h : F)
+    rw [mul_assoc, inv_mul_cancel₀ hg, mul_one]
+  right_inv k := by
+    apply Subtype.ext
+    change (k : F) * g * g⁻¹ = (k : F)
+    rw [mul_assoc, mul_inv_cancel₀ hg, mul_one]
+
+theorem ell_le_degree_add_one [IsCurveOver K F] (hC : ConstantsAreBase K F)
+    {D : Divisor K F} (hD : 0 ≤ Divisor.degree D) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  rcases eq_or_ne (ell D) 0 with h0 | h0
+  · rw [h0]; push_cast; linarith
+  · have hbot : LSpace D ≠ ⊥ := fun h => h0 (by rw [ell, h, finrank_bot])
+    obtain ⟨g, hgL, hg0⟩ := (Submodule.ne_bot_iff _).mp hbot
+    obtain ⟨Dg, hDgord, hDgdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) g hg0
+    have heff : ∀ v, 0 ≤ (D + Dg) v := by
+      intro v; rw [Finsupp.add_apply, hDgord]
+      have := (mem_lSpace_iff_ord.mp hgL).resolve_left hg0 v
+      linarith
+    have hdeg : Divisor.degree (D + Dg) = Divisor.degree D := by
+      rw [map_add, hDgdeg, add_zero]
+    have hell : ell D = ell (D + Dg) :=
+      LinearEquiv.finrank_eq (lSpaceShiftEquiv D hg0 hDgord)
+    have hfin := ell_le_degree_add_one_of_effective hC heff
+    rw [hdeg] at hfin
+    rw [hell]; exact hfin
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion factor mk mem_bot subtype_injective \
+  mk.injEq Quotient.subsingleton_iff Quotient.mk span restrictScalars inclusion_injective \
+  comapSubtypeEquivOfLe mem_comap finrank_quotient_add_finrank mem_top Quotient.equiv mkQ mem_map \
+  coe_subtype map_smul' zero one quotientQuotientEquivQuotient coe_eq_zero finrank_le \
+  range_subtype Quotient.mk_surjective map mem_inf mem_sup Quotient.mk_eq_zero topEquiv \
+  map_injective_of_injective comap_subtype_self mapQ subsingleton_iff module smul_def mk_eq_zero \
+  coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono map_sup coe_zero smul"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+def nestedComapMapMkQEquiv {A B C : Submodule K X} (_hAB : A ≤ B) (hBC : B ≤ C) :
+    ((B.comap C.subtype).map (A.comap C.subtype).mkQ : Submodule K _)
+      ≃ₗ[K] B ⧸ A.comap B.subtype := by
+  set S := A.comap C.subtype with hS
+  set T := B.comap C.subtype with hT
+  let ψ : (T : Type _) →ₗ[K] (C ⧸ S) := S.mkQ ∘ₗ T.subtype
+  have hker : LinearMap.ker ψ = S.comap T.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = T.map S.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let e1 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (T.map S.mkQ : Submodule K _) :=
+    (Submodule.Quotient.equiv _ (LinearMap.ker ψ) (LinearEquiv.refl K T)
+        (by rw [hker]; simp)).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have hmap : (S.comap T.subtype).map
+      (Submodule.comapSubtypeEquivOfLe hBC : (T : Type _) →ₗ[K] B) = A.comap B.subtype := by
+    ext ⟨b, hb⟩
+    simp only [mem_map, mem_comap, Submodule.coe_subtype, hS]
+    constructor
+    · rintro ⟨⟨⟨x, hxC⟩, hxB⟩, hxA, hxeq⟩
+      have hx : x = b := congrArg Subtype.val hxeq
+      subst hx; exact hxA
+    · intro hbA
+      exact ⟨⟨⟨b, hBC hb⟩, hb⟩, hbA, rfl⟩
+  let e2 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (B ⧸ A.comap B.subtype) :=
+    Submodule.Quotient.equiv _ _ (Submodule.comapSubtypeEquivOfLe hBC) hmap
+  exact e1.symm.trans e2
+
+theorem finrank_quotient_chain {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCB : Module.Finite K (C ⧸ B.comap C.subtype)]
+    [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (C ⧸ A.comap C.subtype) ∧
+      finrank K (C ⧸ A.comap C.subtype)
+        = finrank K (C ⧸ B.comap C.subtype) + finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (T.map S.mkQ : Submodule K _) := Module.Finite.equiv eK.symm
+  have : Module.Finite K ((C ⧸ S) ⧸ T.map S.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (C ⧸ S) := Module.Finite.of_submodule_quotient (T.map S.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+theorem finrank_quotient_chain' {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCA : Module.Finite K (C ⧸ A.comap C.subtype)] :
+    Module.Finite K (C ⧸ B.comap C.subtype) ∧
+      finrank K (C ⧸ B.comap C.subtype)
+        = finrank K (C ⧸ A.comap C.subtype) - finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (C ⧸ T) := Module.Finite.equiv e3
+  refine ⟨this, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+def adeleBddQuotSingleEquivResidueField (D : Divisor K F) (P : Place K F) :
+    (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+      ≃ₗ[K] P.ResidueField := by
+  classical
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  let π : P.toValuationSubring :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose
+  have hπ : Irreducible π :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose_spec
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := fun {g} hg => by
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ α : Place K F → F, α ∈ adeleBdd D → t ^ (D P) * α P ∈ P.toValuationSubring := by
+    intro α hα
+    rcases eq_or_ne (α P) 0 with hg0 | hg0
+    · simp [hg0]
+    · refine AlgebraicCurve.Place.mem_of_ord_nonneg P (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have h := hα P
+      rw [P.adicValuation_eq_exp_neg_ord hg0, WithZero.exp_le_exp] at h
+      linarith
+  let ψ : adeleBdd D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun α => ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩
+      map_add' := by
+        intro α β; apply Subtype.ext
+        simp only [Submodule.coe_add, Pi.add_apply]
+        push_cast; ring
+      map_smul' := by
+        intro c α; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap, Pi.smul_apply]
+        ring }
+  have hψ_apply : ∀ α : adeleBdd D,
+      (ψ α : F) = t ^ (D P) * (α : Place K F → F) P := fun α => rfl
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : adeleBdd D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ α : adeleBdd D, φ α = 0 ↔
+      (⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := fun α => by
+    rw [show φ α = IsLocalRing.residue P.toValuationSubring
+            ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ from hres (ψ α),
+      IsLocalRing.residue_eq_zero_iff]
+  have hker : LinearMap.ker φ = (adeleBdd E).comap (adeleBdd D).subtype := by
+    ext α
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi α, P.mk_mem_maximalIdeal_iff, mem_adeleBdd]
+    have hαD := α.2
+    constructor
+    · rintro (h | h) v
+      · have hα0 : (α : Place K F → F) P = 0 := by
+          rcases mul_eq_zero.mp h with h' | h'
+          · exact absurd h' htn0
+          · exact h'
+        by_cases hv : v = P
+        · subst v; rw [hα0, Valuation.map_zero]; exact zero_le
+        · rw [hEv v hv]; exact hαD v
+      · by_cases hv : v = P
+        · subst v
+          rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+          · rw [hα0, Valuation.map_zero]; exact zero_le
+          · rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP]
+            rw [hordmul hα0] at h; omega
+        · rw [hEv v hv]; exact hαD v
+    · intro h
+      rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+      · left; rw [hα0, mul_zero]
+      · right
+        have hP := h P
+        rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP] at hP
+        rw [hordmul hα0]; omega
+  have hsurj : Function.Surjective φ := by
+    intro c
+    obtain ⟨cl, hcl⟩ := IsLocalRing.residue_surjective (R := P.toValuationSubring) c
+    set f : F := (cl : F) * t ^ (-(D P)) with hf
+    have hαD : Pi.single P f ∈ adeleBdd D := by
+      intro v
+      by_cases hv : v = P
+      · subst v
+        simp only [Pi.single_eq_same]
+        rcases eq_or_ne (cl : F) 0 with hc0 | hc0
+        · rw [hf, hc0, zero_mul, Valuation.map_zero]; exact zero_le
+        · have hf0 : f ≠ 0 := by rw [hf]; exact mul_ne_zero hc0 (zpow_ne_zero _ ht0)
+          rw [P.adicValuation_eq_exp_neg_ord hf0, WithZero.exp_le_exp]
+          rw [hf, P.ord_mul hc0 (zpow_ne_zero _ ht0), P.ord_zpow, ht1, mul_one]
+          have hclnn := AlgebraicCurve.Place.ord_nonneg_of_mem P cl.2
+          linarith
+      · rw [Pi.single_eq_of_ne hv, Valuation.map_zero]; exact zero_le
+    refine ⟨⟨Pi.single P f, hαD⟩, ?_⟩
+    change res (ψ ⟨Pi.single P f, hαD⟩) = c
+    rw [hres]
+    rw [show (ψ ⟨Pi.single P f, hαD⟩ : P.toValuationSubring) = cl from ?_, hcl]
+    apply Subtype.ext
+    rw [hψ_apply]
+    change t ^ (D P) * (Pi.single P f : Place K F → F) P = (cl : F)
+    rw [show (Pi.single P f : Place K F → F) P = f from Pi.single_eq_same _ _, hf,
+      mul_comm (cl : F), ← mul_assoc, ← zpow_add₀ ht0, add_neg_cancel, zpow_zero, one_mul]
+  exact (Submodule.Quotient.equiv _ _ (LinearEquiv.refl K _) (by rw [← hker]; simp)).trans
+    (φ.quotKerEquivOfSurjective hsurj)
+
+theorem finrank_adeleBdd_quotient_single [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    Module.Finite K
+        (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype) ∧
+      finrank K
+          (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+        = P.deg := by
+  have := IsCurveOver.finite_residueField (K := K) P
+  exact ⟨Module.Finite.equiv (adeleBddQuotSingleEquivResidueField D P).symm,
+    (adeleBddQuotSingleEquivResidueField D P).finrank_eq⟩
+
+theorem finrank_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+      (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+        = Divisor.degree D₂ - Divisor.degree D₁ := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D₁ D₂ : Divisor K F, D₁ ≤ D₂ →
+      (Divisor.degree (D₂ - D₁)).toNat = m →
+      Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+        (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+          = Divisor.degree D₂ - Divisor.degree D₁ from
+    H _ D₁ D₂ hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D₁ D₂ hD hm
+    have hEeff : ∀ v, 0 ≤ (D₂ - D₁) v := fun v => by
+      rw [Finsupp.sub_apply]; have := hD v; omega
+    by_cases hD0 : D₂ - D₁ = 0
+    · have hD12 : D₁ = D₂ := (sub_eq_zero.mp hD0).symm
+      subst hD12
+      rw [Submodule.comap_subtype_self]
+      have : Subsingleton (adeleBdd D₁ ⧸ (⊤ : Submodule K (adeleBdd D₁))) :=
+        Submodule.Quotient.subsingleton_iff.mpr rfl
+      exact ⟨Module.Finite.of_finite, by simp [Module.finrank_zero_of_subsingleton]⟩
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ (D₂ - D₁) P := by
+        have hne : (D₂ - D₁) P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hEeff P; omega
+      set D₂' : Divisor K F := D₂ - Finsupp.single P 1 with hD₂'
+      have h12' : D₁ ≤ D₂' := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]
+          have := hPpos; rw [Finsupp.sub_apply] at this; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have h2'2 : D₂' ≤ D₂ := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]
+      have hdegD₂' : Divisor.degree D₂' = Divisor.degree D₂ - P.deg := by
+        rw [hD₂', map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hEnn : 0 ≤ Divisor.degree (D₂ - D₁) := Divisor.degree_nonneg_of_nonneg hEeff
+      have hE'nn : 0 ≤ Divisor.degree (D₂' - D₁) := Divisor.degree_nonneg_of_nonneg
+        (fun v => by rw [Finsupp.sub_apply]; have := h12' v; omega)
+      have hdegdiff : Divisor.degree (D₂' - D₁) = Divisor.degree (D₂ - D₁) - P.deg := by
+        simp only [hD₂', map_sub, Divisor.degree_single, one_mul]; ring
+      have hmlt : (Divisor.degree (D₂' - D₁)).toNat < m := by rw [← hm]; omega
+      obtain ⟨hfin', hrank'⟩ := IH _ hmlt D₁ D₂' h12' rfl
+      obtain ⟨hfinS, hrankS⟩ := finrank_adeleBdd_quotient_single (K := K) D₂ P
+      rw [← hD₂'] at hfinS hrankS
+      have := hfin'; have := hfinS
+      obtain ⟨hfin, hrank⟩ := Submodule.finrank_quotient_chain
+        (A := adeleBdd D₁) (B := adeleBdd D₂') (C := adeleBdd D₂)
+        (adeleBdd_mono h12') (adeleBdd_mono h2'2)
+      refine ⟨hfin, ?_⟩
+      rw [hrank, hrankS]
+      push_cast
+      linarith [hrank', hdegD₂']
+
+theorem module_finite_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  (finrank_adeleBdd_quotient hD).1
+
+theorem finrank_adeleBdd_quotient_eq [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+      = Divisor.degree D₂ - Divisor.degree D₁ :=
+  (finrank_adeleBdd_quotient hD).2
+
+def lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (_hD : D₁ ≤ D₂) :
+    (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      →ₗ[K] (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  Submodule.mapQ _ _
+    ((diagonalHom K F).restrict
+      (p := (LSpace D₂ : Submodule K F)) (q := (adeleBdd D₂ : Submodule K _))
+      (fun f hf => diagonal_mem_adeleBdd_iff.mpr hf))
+    (fun f hf => by
+      simp only [Submodule.mem_comap, Submodule.coe_subtype] at hf ⊢
+      exact diagonal_mem_adeleBdd_iff.mpr hf)
+
+theorem lSpaceQuotientToAdeleBddQuotient_injective {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Function.Injective (lSpaceQuotientToAdeleBddQuotient hD) := by
+  rw [injective_iff_map_eq_zero]
+  intro x hx
+  obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+  rw [Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype]
+  rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk f)
+        = Submodule.Quotient.mk ((diagonalHom K F).restrict
+            (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f) from rfl,
+    Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype] at hx
+  exact diagonal_mem_adeleBdd_iff.mp hx
+
+
+theorem ell_sub_ell_le_degree_sub_degree [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)] :
+    (ell D₂ : ℤ) - (ell D₁ : ℤ) ≤ Divisor.degree D₂ - Divisor.degree D₁ := by
+  have := module_finite_adeleBdd_quotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    rw [hℓ₁]; exact (Submodule.finrank_quotient_add_finrank _).symm
+  have hemb : finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      ≤ finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+    LinearMap.finrank_le_finrank_of_injective (lSpaceQuotientToAdeleBddQuotient_injective hD)
+  have hloc := finrank_adeleBdd_quotient_eq hD
+  have : (ell D₂ : ℤ) - (ell D₁ : ℤ)
+      = (finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) : ℤ) := by
+    rw [hL]; push_cast; ring
+  rw [this, ← hloc]
+  exact_mod_cast hemb
+
+theorem adeleBdd_inf_sup_globalSub {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F)
+      = adeleBdd D₁ ⊔ adeleBdd D₂ ⊓ globalSub K F := by
+  rw [inf_comm, sup_inf_assoc_of_le _ (adeleBdd_mono hD), inf_comm]
+
+theorem map_diagonal_lSpace_inf_adeleBdd {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (LSpace D₂).map (diagonalHom K F) ⊓ adeleBdd D₁ = (LSpace D₁).map (diagonalHom K F) := by
+  rw [map_diagonal_lSpace, map_diagonal_lSpace, inf_right_comm,
+    inf_eq_right.mpr (adeleBdd_mono hD)]
+
+theorem gate_finrank_adeleBdd_quotient_single_point [IsCurveOver K F] (P : Place K F) :
+    (finrank K (adeleBdd (Finsupp.single P 1 : Divisor K F)
+        ⧸ (adeleBdd (0 : Divisor K F)).comap (adeleBdd (Finsupp.single P 1)).subtype) : ℤ)
+      = (P.deg : ℤ) := by
+  classical
+  have h01 : (0 : Divisor K F) ≤ Finsupp.single P 1 := by
+    intro v; rw [Finsupp.zero_apply, Finsupp.single_apply]; split_ifs <;> omega
+  have h := finrank_adeleBdd_quotient_eq (K := K) h01
+  rw [h, map_zero, sub_zero, Divisor.degree_single, one_mul]
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion factor mk mem_bot subtype_injective \
+  mk.injEq Quotient.subsingleton_iff Quotient.mk span restrictScalars inclusion_injective \
+  comapSubtypeEquivOfLe mem_comap finrank_quotient_add_finrank mem_top Quotient.equiv mkQ mem_map \
+  coe_subtype map_smul' zero one quotientQuotientEquivQuotient coe_eq_zero finrank_le \
+  range_subtype Quotient.mk_surjective map mem_inf mem_sup Quotient.mk_eq_zero topEquiv \
+  map_injective_of_injective comap_subtype_self mapQ subsingleton_iff module smul_def mk_eq_zero \
+  coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono map_sup coe_zero smul"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+theorem comap_subtype_sup_of_le_of_le {S T C : Submodule K X} (hS : S ≤ C) (hT : T ≤ C) :
+    S.comap C.subtype ⊔ T.comap C.subtype = (S ⊔ T).comap C.subtype := by
+  apply Submodule.map_injective_of_injective (f := C.subtype) C.subtype_injective
+  rw [Submodule.map_sup, Submodule.map_comap_subtype, Submodule.map_comap_subtype,
+    Submodule.map_comap_subtype, inf_eq_right.mpr hS, inf_eq_right.mpr hT,
+    inf_eq_right.mpr (sup_le hS hT)]
+
+theorem finrank_quotient_chain_top {M : Type*} [AddCommGroup M] [Module K M]
+    {A B : Submodule K M} (hAB : A ≤ B)
+    [hMB : Module.Finite K (M ⧸ B)] [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (M ⧸ A) ∧
+      finrank K (M ⧸ A) = finrank K (M ⧸ B) + finrank K (B ⧸ A.comap B.subtype) := by
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  let ψ : (B : Type _) →ₗ[K] (M ⧸ A) := A.mkQ ∘ₗ B.subtype
+  have hker : LinearMap.ker ψ = A.comap B.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = B.map A.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let eK : (B ⧸ A.comap B.subtype) ≃ₗ[K] (B.map A.mkQ : Submodule K (M ⧸ A)) :=
+    (Submodule.quotEquivOfEq _ _ hker.symm).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have : Module.Finite K (B.map A.mkQ : Submodule K (M ⧸ A)) := Module.Finite.equiv eK
+  have : Module.Finite K ((M ⧸ A) ⧸ B.map A.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (M ⧸ A) := Module.Finite.of_submodule_quotient (B.map A.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (B.map A.mkQ)
+  rw [LinearEquiv.finrank_eq e3, ← LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem globalSub_le_adeleSpace [HasPrincipalDivisors K F] :
+    globalSub K F ≤ adeleSpace K F := by
+  rintro _ ⟨f, rfl⟩
+  exact diagonal_mem_adeleSpace f
+
+theorem adeleBdd_sup_globalSub_le_adeleSpace [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+  sup_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_eq_comap [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBddPrincipal K F D = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype :=
+  Submodule.comap_subtype_sup_of_le_of_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_mono {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBddPrincipal K F D₁ ≤ adeleBddPrincipal K F D₂ :=
+  sup_le_sup_right (Submodule.comap_mono (adeleBdd_mono hD)) _
+
+section FiniteLSpace
+
+variable [IsCurveOver K F]
+
+theorem finiteDimensional_lSpace [hL0 : FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (D : Divisor K F) : FiniteDimensional K (LSpace D) := by
+  have h0D : (0 : Divisor K F) ≤ D ⊔ 0 := le_sup_right
+  have hDD : D ≤ D ⊔ 0 := le_sup_left
+  suffices h : FiniteDimensional K (LSpace (D ⊔ 0)) by
+    exact Module.Finite.of_injective (Submodule.inclusion (lSpace_mono hDD))
+      (Submodule.inclusion_injective _)
+  have := module_finite_adeleBdd_quotient (K := K) h0D
+  have hfinQ : FiniteDimensional K
+      (LSpace (D ⊔ 0) ⧸ (LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype) :=
+    Module.Finite.of_injective _ (lSpaceQuotientToAdeleBddQuotient_injective h0D)
+  have : FiniteDimensional K
+      ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype : Submodule K _) :=
+    Module.Finite.equiv (Submodule.comapSubtypeEquivOfLe (lSpace_mono h0D)).symm
+  exact Module.Finite.of_submodule_quotient
+    ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype)
+
+end FiniteLSpace
+
+
+theorem range_lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD)
+      = ((adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype).map
+          ((adeleBdd D₁).comap (adeleBdd D₂).subtype).mkQ := by
+  classical
+  ext z
+  obtain ⟨α, rfl⟩ := Submodule.Quotient.mk_surjective _ z
+  simp only [LinearMap.mem_range, Submodule.mem_map, Submodule.mem_comap, Submodule.coe_subtype,
+    Submodule.mkQ_apply]
+  constructor
+  · rintro ⟨x, hx⟩
+    obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+    have hxeq : Submodule.Quotient.mk
+        ((diagonalHom K F).restrict (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f)
+        = (Submodule.Quotient.mk α :
+            adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) := hx
+    refine ⟨α, ?_, rfl⟩
+    have hdiag2 : (diagonalHom K F (f : F)) ∈ adeleBdd D₂ := diagonal_mem_adeleBdd_iff.mpr f.2
+    have hsub : (α : Place K F → F) - diagonalHom K F (f : F) ∈ adeleBdd D₁ := by
+      have hq := (Submodule.Quotient.eq _).mp hxeq.symm
+      simpa using hq
+    refine Submodule.mem_sup.mpr ⟨(α : Place K F → F) - diagonalHom K F (f : F), hsub,
+      diagonalHom K F (f : F), diagonal_mem_globalSub _, ?_⟩
+    abel
+  · rintro ⟨β, hβ, hβeq⟩
+    have hβ' : (β : Place K F → F) ∈ adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F) :=
+      Submodule.mem_inf.mpr ⟨β.2, hβ⟩
+    rw [adeleBdd_inf_sup_globalSub hD, ← map_diagonal_lSpace] at hβ'
+    obtain ⟨γ, hγ, δ, ⟨f, hf, hfδ⟩, hsum⟩ := Submodule.mem_sup.mp hβ'
+    refine ⟨Submodule.Quotient.mk ⟨f, hf⟩, ?_⟩
+    rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk ⟨f, hf⟩)
+          = Submodule.Quotient.mk ((diagonalHom K F).restrict
+              (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) ⟨f, hf⟩) from rfl,
+      ← hβeq, Submodule.Quotient.eq]
+    refine Submodule.mem_comap.mpr ?_
+    change diagonalHom K F f - (β : Place K F → F) ∈ adeleBdd D₁
+    have hβsub : diagonalHom K F f - (β : Place K F → F) = -γ := by
+      rw [← hsum, hfδ]; ring
+    rw [hβsub]; exact (adeleBdd D₁).neg_mem hγ
+
+
+theorem finrank_adeleBddSup_quotient [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) [hL : FiniteDimensional K (LSpace D₂)] :
+    Module.Finite K (↥(adeleBdd D₂ ⊔ globalSub K F)
+        ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) ∧
+      (finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+          ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) : ℤ)
+        = (Divisor.degree D₂ - ell D₂) - (Divisor.degree D₁ - ell D₁) := by
+  classical
+  let A : Submodule K (adeleBdd D₂) := (adeleBdd D₁).comap (adeleBdd D₂).subtype
+  let B : Submodule K (adeleBdd D₂) :=
+    (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype
+  have hAB : A ≤ B := Submodule.comap_mono le_sup_left
+  have hfinA : Module.Finite K (adeleBdd D₂ ⧸ A) := module_finite_adeleBdd_quotient hD
+  have hdimA : (finrank K (adeleBdd D₂ ⧸ A) : ℤ) = Divisor.degree D₂ - Divisor.degree D₁ :=
+    finrank_adeleBdd_quotient_eq hD
+  have hran : LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD) = B.map A.mkQ :=
+    range_lSpaceQuotientToAdeleBddQuotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hdimL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K)
+      ((LSpace D₁).comap (LSpace D₂).subtype)
+    rw [← hℓ₁] at h; exact h.symm
+  have hdimB : ell D₂ = finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) + ell D₁ := by
+    rw [← hran, LinearMap.finrank_range_of_inj
+      (lSpaceQuotientToAdeleBddQuotient_injective hD)]
+    exact hdimL
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  have hfinB : Module.Finite K (adeleBdd D₂ ⧸ B) := Module.Finite.equiv e3
+  have hdim2 : finrank K (adeleBdd D₂ ⧸ A)
+      = finrank K (adeleBdd D₂ ⧸ B) + finrank K (B.map A.mkQ : Submodule K _) := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K) (M := adeleBdd D₂ ⧸ A)
+      (B.map A.mkQ)
+    rw [LinearEquiv.finrank_eq e3] at h; omega
+  have e2 := LinearMap.quotientInfEquivSupQuotient (R := K)
+    (adeleBdd D₂) (adeleBdd D₁ ⊔ globalSub K F)
+  have hsup : adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F) = adeleBdd D₂ ⊔ globalSub K F := by
+    rw [← sup_assoc, sup_eq_left.mpr (adeleBdd_mono hD)]
+  have hB' : (adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype = B := by
+    rw [Submodule.comap_subtype_self, top_inf_eq]
+  let eL : (adeleBdd D₂ ⧸ B) ≃ₗ[K]
+      (adeleBdd D₂ ⧸ ((adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+        (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype)) :=
+    Submodule.quotEquivOfEq _ _ hB'.symm
+  have hfin_iso : Module.Finite K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype) :=
+    Module.Finite.equiv (eL.trans e2)
+  have hdim_iso : finrank K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype)
+      = finrank K (adeleBdd D₂ ⧸ B) :=
+    (LinearEquiv.finrank_eq (eL.trans e2)).symm
+  have hcast : (finrank K (adeleBdd D₂ ⧸ A) : ℤ)
+      = (finrank K (adeleBdd D₂ ⧸ B) : ℤ) + ((ell D₂ : ℤ) - (ell D₁ : ℤ)) := by
+    have hb : (ell D₂ : ℤ)
+        = (finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) : ℤ) + (ell D₁ : ℤ) := by
+      exact_mod_cast hdimB
+    push_cast [hdim2]; linarith
+  have hgoal : (finrank K (adeleBdd D₂ ⧸ B) : ℤ)
+      = Divisor.degree D₂ - ↑(ell D₂) - (Divisor.degree D₁ - ↑(ell D₁)) := by
+    linarith [hdimA, hcast]
+  clear_value eL
+  exact hsup ▸ ⟨hfin_iso, by rw [hdim_iso]; exact hgoal⟩
+
+section Index
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+
+theorem adeleBddSup_eq_of_degree_sub_ell_eq {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)]
+    (heq : Divisor.degree D₂ - ell D₂ = Divisor.degree D₁ - ell D₁) :
+    adeleBdd D₂ ⊔ globalSub K F = adeleBdd D₁ ⊔ globalSub K F := by
+  obtain ⟨hfin, hdim⟩ := finrank_adeleBddSup_quotient hD
+  rw [heq, sub_self] at hdim
+  refine le_antisymm ?_ (sup_le_sup_right (adeleBdd_mono hD) _)
+  have := hfin
+  have hd0 : finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) = 0 := by
+    exact_mod_cast hdim
+  have hsub : Subsingleton (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) :=
+    Module.finrank_zero_iff.mp hd0
+  have htop := Submodule.Quotient.subsingleton_iff.mp hsub
+  intro x hx
+  have hxc : (⟨x, hx⟩ : ↥(adeleBdd D₂ ⊔ globalSub K F)) ∈
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype := by
+    rw [htop]; exact Submodule.mem_top
+  exact hxc
+
+end Index
+
+namespace RiemannGenusReachedAt
+p2m_export "AlgebraicCurve.RiemannGenusReachedAt" "finite mk eq isMax"
+end RiemannGenusReachedAt
+namespace RiemannGenusReachedAt
+p2m_open_scoped "AlgebraicCurve.RiemannGenusReachedAt" in
+private theorem _root_.AlgebraicCurve.RiemannGenusReachedAt.eq_of_ge [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {D : Divisor K F} (hD : D₀ ≤ D) :
+    Divisor.degree D - ell D = γ - 1 := by
+  have := finiteDimensional_lSpace (K := K) D
+  have hge : Divisor.degree D₀ - (ell D₀ : ℤ) ≤ Divisor.degree D - ell D := by
+    have := ell_sub_ell_le_degree_sub_degree (K := K) hD
+    linarith
+  exact le_antisymm (h.isMax D) (h.eq ▸ hge)
+
+end RiemannGenusReachedAt
+p2m_export "AlgebraicCurve" "RiemannGenusReachedAt.eq_of_ge"
+
+theorem adeleSpace_eq_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    adeleSpace K F = adeleBdd D₀ ⊔ globalSub K F := by
+  refine le_antisymm ?_ (adeleBdd_sup_globalSub_le_adeleSpace D₀)
+  rw [adeleSpace, iSup_le_iff]
+  intro D
+  refine le_trans (adeleBdd_mono (le_sup_left : D ≤ D ⊔ D₀)) ?_
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have heq : Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) = Divisor.degree D₀ - ell D₀ :=
+    (h.eq_of_ge le_sup_right).trans h.eq.symm
+  have hsup := adeleBddSup_eq_of_degree_sub_ell_eq (K := K)
+    (le_sup_right : D₀ ≤ D ⊔ D₀) heq
+  rw [← hsup]
+  exact le_sup_left
+
+theorem indexOfSpecialty_eq_zero_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    indexOfSpecialty D₀ = 0 := by
+  rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap, ← adeleSpace_eq_of_genusReached h,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.finrank_zero_of_subsingleton
+
+
+
+theorem gate_indexOfSpecialty_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  have h1 := (indexOfSpecialty_eq_of_genusReached h D₀).2
+  have h2 := h.eq
+  have h3 := indexOfSpecialty_eq_zero_of_genusReached h
+  exact_mod_cast h3
+
+theorem gate_riemannInequality_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Divisor.degree D + 1 - γ ≤ (ell D : ℤ) := by
+  have heq := (indexOfSpecialty_eq_of_genusReached h D).2
+  have hnn : (0 : ℤ) ≤ indexOfSpecialty D := Int.natCast_nonneg _
+  linarith
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem adeleSpaceMul_add [HasPrincipalDivisors K F] (f g : F) :
+    adeleSpaceMul K F (f + g) = adeleSpaceMul K F f + adeleSpaceMul K F g := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, LinearMap.add_apply, Submodule.coe_add,
+    Pi.add_apply, add_mul]
+
+theorem adeleSpaceMul_zero [HasPrincipalDivisors K F] :
+    adeleSpaceMul K F (0 : F) = 0 := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, zero_mul, LinearMap.zero_apply,
+    Submodule.coe_zero, Pi.zero_apply]
+
+theorem weilSmul_add_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f + g) φ = weilSmul K F f φ + weilSmul K F g φ := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_add, LinearMap.add_apply, map_add]
+
+theorem weilSmul_zero_left [HasPrincipalDivisors K F]
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (0 : F) φ = 0 := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_zero, LinearMap.zero_apply, map_zero]
+
+theorem weilSmul_neg_left [HasPrincipalDivisors K F] (f : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (-f) φ = -weilSmul K F f φ := by
+  have h := weilSmul_add_left (K := K) (F := F) f (-f) φ
+  rw [add_neg_cancel, weilSmul_zero_left] at h
+  exact (neg_eq_of_add_eq_zero_right h.symm).symm
+
+theorem weilSmul_sub_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f - g) φ = weilSmul K F f φ - weilSmul K F g φ := by
+  rw [sub_eq_add_neg, weilSmul_add_left, weilSmul_neg_left, sub_eq_add_neg]
+
+theorem weilSmul_eq_zero_iff_left [HasPrincipalDivisors K F]
+    {f : F} {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    weilSmul K F f φ = 0 ↔ f = 0 := by
+  refine ⟨fun h => ?_, fun h => h ▸ weilSmul_zero_left φ⟩
+  by_contra hf
+  exact hφ (weilSmul_injective hf (h.trans (map_zero (weilSmul K F f)).symm))
+
+theorem weilSmul_left_injective [HasPrincipalDivisors K F]
+    {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    Function.Injective (fun f : F => weilSmul K F f φ) := by
+  intro f g hfg
+  have hsub : weilSmul K F (f - g) φ = 0 := by
+    rw [weilSmul_sub_left, sub_eq_zero]; exact hfg
+  exact sub_eq_zero.mp ((weilSmul_eq_zero_iff_left hφ).mp hsub)
+
+variable (K F) in
+def doubleResiduePairing [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) :
+    LSpace (W - D) × LSpace (W - D) →ₗ[K] omegaSpace D :=
+  (residuePairing K F W D hφ).coprod (residuePairing K F W D hμ)
+
+theorem doubleResiduePairing_apply_coe [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (g h : LSpace (W - D)) :
+    (doubleResiduePairing K F W D hφ hμ (g, h) : Module.Dual K (adeleSpace K F))
+      = weilSmul K F (g : F) φ + weilSmul K F (h : F) μ := by
+  simp only [doubleResiduePairing, LinearMap.coprod_apply, Submodule.coe_add,
+    residuePairing_apply_coe]
+
+theorem doubleResiduePairing_injective [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ) :
+    Function.Injective (doubleResiduePairing K F W D hφ hμ) := by
+  rw [injective_iff_map_eq_zero]
+  rintro ⟨g, h⟩ heq
+  have heq' : weilSmul K F (g : F) φ + weilSmul K F (h : F) μ = 0 := by
+    have hcoe := congrArg Subtype.val heq
+    rwa [doubleResiduePairing_apply_coe, Submodule.coe_zero] at hcoe
+  rcases eq_or_ne (h : F) 0 with hh0 | hh0
+  · rw [hh0, weilSmul_zero_left, add_zero] at heq'
+    have hg0 : (g : F) = 0 := (weilSmul_eq_zero_iff_left hφ0).mp heq'
+    exact Prod.ext (Subtype.ext hg0) (Subtype.ext hh0)
+  · exfalso
+    have hμeq : weilSmul K F (h : F) μ = -weilSmul K F (g : F) φ := by
+      have h2 : weilSmul K F (h : F) μ + weilSmul K F (g : F) φ = 0 := by
+        rw [add_comm]; exact heq'
+      exact eq_neg_of_add_eq_zero_left h2
+    have hLHS : weilSmul K F (h : F)⁻¹ (weilSmul K F (h : F) μ) = μ := by
+      rw [← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hh0, weilSmul_one,
+        LinearMap.id_apply]
+    have hRHS : weilSmul K F (h : F)⁻¹ (-weilSmul K F (g : F) φ)
+        = weilSmul K F (-(g : F) * (h : F)⁻¹) φ := by
+      rw [map_neg, ← LinearMap.comp_apply, ← weilSmul_mul, neg_mul, weilSmul_neg_left]
+    exact hindep (-(g : F) * (h : F)⁻¹) (by rw [← hLHS, hμeq, hRHS])
+
+theorem two_mul_ell_le_indexOfSpecialty [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ)
+    [Module.Finite K (omegaSpace (K := K) (F := F) D)]
+    [Module.Finite K (LSpace (K := K) (F := F) (W - D))] :
+    2 * ell (W - D) ≤ indexOfSpecialty D := by
+  have hinj := doubleResiduePairing_injective W D hφ hμ hφ0 hindep
+  have hle := LinearMap.finrank_le_finrank_of_injective hinj
+  rw [Module.finrank_prod] at hle
+  rw [← finrank_omegaSpace_eq_indexOfSpecialty, two_mul]
+  exact hle
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+section Finiteness
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+theorem omegaSpace_finite_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Module.Finite K (omegaSpace (K := K) (F := F) D) := by
+  have := (indexOfSpecialty_eq_of_genusReached h D).1
+  exact Module.Finite.equiv (omegaSpaceEquivIndexDual D).symm
+
+end Finiteness
+
+section ParametricRankOne
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+
+theorem exists_weilSmul_eq_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {φ μ : Module.Dual K (adeleSpace K F)} {W : Divisor K F}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (hφ0 : φ ≠ 0) :
+    ∃ f : F, μ = weilSmul K F f φ := by
+  by_contra hcon
+  push Not at hcon
+  obtain ⟨P⟩ := ‹Nonempty (Place K F)›
+  set n : ℕ := 3 * γ.natAbs + 2 * (Divisor.degree W).natAbs + 4 with hn
+  set D : Divisor K F := -Finsupp.single P (n : ℤ) with hD
+  have hdegD : Divisor.degree D = -(n : ℤ) * (P.deg : ℤ) := by
+    rw [hD, map_neg, Divisor.degree_single]; ring
+  have hdegWD : Divisor.degree (W - D) = Divisor.degree W + (n : ℤ) * (P.deg : ℤ) := by
+    rw [map_sub, hdegD]; ring
+  have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+  have habsγ : -(|γ|) ≤ γ ∧ γ ≤ |γ| := ⟨neg_abs_le _, le_abs_self _⟩
+  have habsW : -|Divisor.degree W| ≤ Divisor.degree W ∧
+      Divisor.degree W ≤ |Divisor.degree W| := ⟨neg_abs_le _, le_abs_self _⟩
+  have hn_ge : 3 * |γ| + 2 * |Divisor.degree W| + 4 ≤ (n : ℤ) := by
+    rw [hn]; push_cast [Int.natCast_natAbs]; ring_nf; omega
+  have hndegP : (n : ℤ) ≤ (n : ℤ) * (P.deg : ℤ) := by nlinarith [Int.natCast_nonneg n]
+  have hellD : ell D = 0 := ell_eq_zero_of_degree_neg (by rw [hdegD]; nlinarith)
+  have hiD : (indexOfSpecialty D : ℤ) = (n : ℤ) * (P.deg : ℤ) - 1 + γ := by
+    have hidx := (indexOfSpecialty_eq_of_genusReached h D).2
+    rw [hellD, hdegD] at hidx; push_cast at hidx; linarith
+  have hlowerWD : Divisor.degree W + (n : ℤ) * (P.deg : ℤ) + 1 - γ
+      ≤ (ell (W - D) : ℤ) := by
+    have hlow := gate_riemannInequality_of_genusReached h (W - D)
+    rw [hdegWD] at hlow; exact hlow
+  have := omegaSpace_finite_of_genusReached h D
+  have := finiteDimensional_lSpace (K := K) (W - D)
+  have hdbl : (2 * ell (W - D) : ℤ) ≤ (indexOfSpecialty D : ℤ) := by
+    exact_mod_cast two_mul_ell_le_indexOfSpecialty W D hφ hμ hφ0 hcon
+  rw [hiD] at hdbl
+  nlinarith [habsγ.1, habsγ.2, habsW.1, habsW.2]
+
+theorem weilDifferentialRankOne_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    WeilDifferentialRankOne K F := by
+  intro φ hφmem hφ0 μ hμmem
+  obtain ⟨W₁, hφW₁⟩ := mem_weilDifferentialModule_iff.mp hφmem
+  obtain ⟨W₂, hμW₂⟩ := mem_weilDifferentialModule_iff.mp hμmem
+  have hφW : φ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_left hφW₁
+  have hμW : μ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_right hμW₂
+  obtain ⟨f, hf⟩ := exists_weilSmul_eq_of_genusReached h hφW hμW hφ0
+  exact ⟨f, hf, fun f' hf' => weilSmul_left_injective hφ0 (hf'.symm.trans hf)⟩
+
+end ParametricRankOne
+
+theorem residuePairing_surjective_of_rankOne_max [HasPrincipalDivisors K F]
+    (hRankOne : WeilDifferentialRankOne K F)
+    {W : Divisor K F} {φ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hφ0 : φ ≠ 0)
+    (hWmax : ∀ E : Divisor K F, φ ∈ omegaSpace E → E ≤ W) (D : Divisor K F) :
+    Function.Surjective (residuePairing K F W D hφ) := by
+  rintro ⟨μ, hμD⟩
+  have hφmem : φ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule W hφ
+  have hμmem : μ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule D hμD
+  obtain ⟨f, hf, -⟩ := hRankOne hφmem hφ0 hμmem
+  rcases eq_or_ne f 0 with rfl | hf0
+  · have hμ0 : (⟨μ, hμD⟩ : omegaSpace D) = 0 :=
+      Subtype.ext (hf.trans (weilSmul_zero_left φ))
+    exact ⟨0, (map_zero _).trans hμ0.symm⟩
+  · obtain ⟨P, hPord, _⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+    have hPinv : ∀ v, (-P) v = v.ord f⁻¹ := fun v => by
+      rw [Finsupp.neg_apply, hPord v, v.ord_inv]
+    have hinv : weilSmul K F f⁻¹ μ = φ := by
+      rw [hf, ← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hf0, weilSmul_one,
+        LinearMap.id_apply]
+    have hφD : φ ∈ omegaSpace (D + -P) := by
+      rw [← hinv]; exact weilSmul_mem_omegaSpace_add (inv_ne_zero hf0) hPinv hμD
+    have hDP : D + -P ≤ W := hWmax _ hφD
+    have hfL : f ∈ LSpace (W - D) := by
+      rw [mem_lSpace_iff_ord]; refine Or.inr fun v => ?_
+      have hv := hDP v
+      rw [Finsupp.add_apply, Finsupp.neg_apply, hPord v] at hv
+      rw [Finsupp.sub_apply]; linarith
+    exact ⟨⟨f, hfL⟩, Subtype.ext hf.symm⟩
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem exists_riemannGenusReachedAt_of_bounded
+    [IsCurveOver K F] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    ∃ (γ : ℤ) (D₀ : Divisor K F), RiemannGenusReachedAt γ D₀ := by
+  obtain ⟨γ, hγ⟩ := hbdd
+  obtain ⟨M, ⟨D₀, hD₀⟩, hMmax⟩ :=
+    Int.exists_greatest_of_bdd
+      (P := fun n => ∃ D : Divisor K F, Divisor.degree D - ell D = n)
+      ⟨γ, fun n ⟨D, hD⟩ => hD ▸ hγ D⟩
+      ⟨Divisor.degree (0 : Divisor K F) - ell (0 : Divisor K F), 0, rfl⟩
+  refine ⟨M + 1, D₀, ?_, ?_, ?_⟩
+  · exact finiteDimensional_lSpace D₀
+  · rw [hD₀]; ring
+  · intro D
+    have := hMmax (Divisor.degree D - ell D) ⟨D, rfl⟩
+    linarith
+
+theorem stichtenothGenusExists_of_bounded
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    StichtenothGenusExists K F :=
+  ⟨‹_›, ‹_›, exists_riemannGenusReachedAt_of_bounded hbdd⟩
+
+
+theorem indexOfSpecialty_sub_of_ge [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₀ D : Divisor K F} (hD : D₀ ≤ D)
+    [FiniteDimensional K (LSpace D)]
+    [hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀)] :
+    Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D) ∧
+      (Divisor.degree D - ell D) - (Divisor.degree D₀ - ell D₀)
+        = (indexOfSpecialty D₀ : ℤ) - (indexOfSpecialty D : ℤ) := by
+  have hABsub : adeleBdd D₀ ⊔ globalSub K F ≤ adeleBdd D ⊔ globalSub K F :=
+    sup_le_sup_right (adeleBdd_mono hD) _
+  have hBCsub : adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+    adeleBdd_sup_globalSub_le_adeleSpace _
+  obtain ⟨hfinBA, hdimBA⟩ := finrank_adeleBddSup_quotient (K := K) hD
+  have := hfinBA
+  have hfinCA : Module.Finite K (adeleSpace K F ⧸
+      (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [← adeleBddPrincipal_eq_comap]; exact hfin
+  obtain ⟨hfinCB, hdimCB⟩ := Submodule.finrank_quotient_chain'
+    (A := adeleBdd D₀ ⊔ globalSub K F) (B := adeleBdd D ⊔ globalSub K F)
+    (C := adeleSpace K F) hABsub hBCsub
+  have hi0 : indexOfSpecialty D₀
+      = finrank K (adeleSpace K F ⧸
+        (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap]
+  have hiD : indexOfSpecialty D
+      = finrank K (adeleSpace K F ⧸
+        (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap]
+  have := hfinCB
+  obtain ⟨_, hdimCA⟩ := Submodule.finrank_quotient_chain
+    (A := adeleBdd D₀ ⊔ globalSub K F) (B := adeleBdd D ⊔ globalSub K F)
+    (C := adeleSpace K F) hABsub hBCsub
+  refine ⟨?_, ?_⟩
+  · rw [show adeleBddPrincipal K F D
+        = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype
+      from adeleBddPrincipal_eq_comap D]
+    exact hfinCB
+  · have hcast : (indexOfSpecialty D₀ : ℤ)
+        = (indexOfSpecialty D : ℤ)
+          + (finrank K (↥(adeleBdd D ⊔ globalSub K F)
+              ⧸ (adeleBdd D₀ ⊔ globalSub K F).comap
+                (adeleBdd D ⊔ globalSub K F).subtype) : ℤ) := by
+      rw [hiD, hi0]; exact_mod_cast hdimCA
+    linarith [hdimBA, hcast]
+
+theorem degreeSub_ell_le_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {D₀ : Divisor K F}
+    (hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀))
+    (D : Divisor K F) :
+    Divisor.degree D - ell D ≤ (Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀ := by
+  have := hfin
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have hmono : Divisor.degree D - (ell D : ℤ)
+      ≤ Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) (le_sup_left : D ≤ D ⊔ D₀)
+    linarith
+  obtain ⟨_, heq⟩ :=
+    indexOfSpecialty_sub_of_ge (K := K) (le_sup_right : D₀ ≤ D ⊔ D₀)
+  have hi0 : (0 : ℤ) ≤ indexOfSpecialty (D ⊔ D₀) := Int.natCast_nonneg _
+  linarith
+
+theorem riemannGenusBounded_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hfin : IndexOfSpecialtyFinite K F) :
+    RiemannGenusBounded K F := by
+  obtain ⟨D₀, hD₀⟩ := hfin
+  exact ⟨(Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀,
+    degreeSub_ell_le_of_indexFinite hD₀⟩
+
+theorem stichtenothGenusExists_of_indexFinite
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hfin : IndexOfSpecialtyFinite K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_bounded (riemannGenusBounded_of_indexFinite hfin)
+
+theorem indexOfSpecialtyFinite_of_stichtenothGenusExists
+    [IsCurveOver K F] (hSG : StichtenothGenusExists K F) :
+    IndexOfSpecialtyFinite K F := by
+  obtain ⟨hne, hL0, γ, D₀, hD₀⟩ := hSG
+  have := hne; have := hL0
+  refine ⟨D₀, ?_⟩
+  rw [show adeleBddPrincipal K F D₀
+      = (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype
+    from adeleBddPrincipal_eq_comap D₀, ← adeleSpace_eq_of_genusReached hD₀,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.Finite.of_finite
+
+theorem stichtenothGenusExists_iff_indexFinite
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] :
+    StichtenothGenusExists K F ↔ IndexOfSpecialtyFinite K F :=
+  ⟨indexOfSpecialtyFinite_of_stichtenothGenusExists,
+    stichtenothGenusExists_of_indexFinite⟩
+
+theorem gate_indexOfSpecialty_engine_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  exact_mod_cast indexOfSpecialty_eq_zero_of_genusReached h
+
+theorem gate_stichtenothGenus_le_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {D₀ : Divisor K F}
+    (hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀))
+    {γ : ℤ} {D₁ : Divisor K F} (h : RiemannGenusReachedAt γ D₁) :
+    γ - 1 ≤ (Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀ := by
+  have := degreeSub_ell_le_of_indexFinite hfin D₁
+  rw [h.eq] at this; exact this
+
+theorem gate_riemannGenusBounded_of_reachedAt
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    RiemannGenusBounded K F :=
+  ⟨γ - 1, h.isMax⟩
+
+theorem gate_indexOfSpecialtyFinite_at_zero [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F (0 : Divisor K F)) :=
+  (indexOfSpecialty_eq_of_genusReached h 0).1
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem mul_mem_lSpace_add {D E : Divisor K F} {f g : F}
+    (hf : f ∈ LSpace D) (hg : g ∈ LSpace E) :
+    f * g ∈ LSpace (D + E) := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · rw [zero_mul]; exact (LSpace _).zero_mem
+  rcases eq_or_ne g 0 with rfl | hg0
+  · rw [mul_zero]; exact (LSpace _).zero_mem
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun v => ?_
+  rw [Finsupp.add_apply, neg_add, v.ord_mul hf0 hg0]
+  exact add_le_add ((mem_lSpace_iff_ord.mp hf).resolve_left hf0 v)
+    ((mem_lSpace_iff_ord.mp hg).resolve_left hg0 v)
+
+theorem pow_mem_lSpace_nsmul {B : Divisor K F} {f : F} (hf : f ∈ LSpace B) (j : ℕ) :
+    f ^ j ∈ LSpace (j • B) := by
+  induction j with
+  | zero => simpa using one_mem_lSpace_zero (K := K) (F := F)
+  | succ j ih =>
+    rw [pow_succ, succ_nsmul]
+    exact mul_mem_lSpace_add ih hf
+
+namespace PoleDivisorPackage
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degB_eq u B hB_eff n lin_indep mk c x hn_pos \
+  hu_mem mk.injEq hx_mem"
+p2m_open "AlgebraicCurve.PoleDivisorPackage"
+
+variable (P : PoleDivisorPackage K F)
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.pow_mul_u_mem_lSpace (j : ℕ) (i : Fin P.n)
+    :
+    P.x ^ j * P.u i ∈ LSpace ((j + P.c) • P.B) := by
+  rw [add_nsmul]
+  exact mul_mem_lSpace_add (pow_mem_lSpace_nsmul P.hx_mem j) (P.hu_mem i)
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "pow_mul_u_mem_lSpace"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.pow_mul_u_mem_lSpace_of_le {j m : ℕ}
+    (hjm : j + P.c ≤ m) (i : Fin P.n) :
+    P.x ^ j * P.u i ∈ LSpace (m • P.B) := by
+  refine lSpace_mono ?_ (P.pow_mul_u_mem_lSpace j i)
+  intro v
+  have hBv : (0 : ℤ) ≤ P.B v := P.hB_eff v
+  change ((j + P.c) • P.B) v ≤ (m • P.B) v
+  simp only [Finsupp.smul_apply, nsmul_eq_mul]
+  exact mul_le_mul_of_nonneg_right (by exact_mod_cast hjm) hBv
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "pow_mul_u_mem_lSpace_of_le"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.ell_nsmul_poleDivisor_ge [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    (P.n : ℤ) * (m - P.c + 1) ≤ ell (m • P.B) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  set g : Fin (m - P.c + 1) × Fin P.n → LSpace (m • P.B) :=
+    fun p => ⟨P.x ^ (p.1 : ℕ) * P.u p.2,
+      P.pow_mul_u_mem_lSpace_of_le (by have := p.1.isLt; omega) p.2⟩
+    with hgdef
+  have hsub : LinearIndependent K (fun p => (g p : F)) := by
+    have heq : (fun p => (g p : F))
+        = (fun p : ℕ × Fin P.n => P.x ^ p.1 * P.u p.2)
+            ∘ (fun p : Fin (m - P.c + 1) × Fin P.n => ((p.1 : ℕ), p.2)) := by
+      funext p; rfl
+    rw [heq]
+    refine P.lin_indep.comp _ ?_
+    intro p q hpq
+    simp only [Prod.mk.injEq] at hpq
+    exact Prod.ext (Fin.val_injective hpq.1) hpq.2
+  have hg : LinearIndependent K g := hsub.of_comp (LSpace (m • P.B)).subtype
+  have hcard := hg.fintype_card_le_finrank
+  rw [Fintype.card_prod, Fintype.card_fin, Fintype.card_fin] at hcard
+  have hZ : ((m - P.c + 1) * P.n : ℤ) ≤ (ell (m • P.B) : ℤ) := by exact_mod_cast hcard
+  have heq : (((m - P.c + 1 : ℕ) : ℤ) * P.n : ℤ) = (P.n : ℤ) * ((m : ℤ) - P.c + 1) := by
+    rw [Nat.cast_add, Nat.cast_sub hm, Nat.cast_one]; ring
+  linarith
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "ell_nsmul_poleDivisor_ge"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.degree_nsmul_sub_ell_le [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    Divisor.degree (m • P.B) - ell (m • P.B) ≤ (P.n : ℤ) * (P.c - 1) := by
+  have hge := P.ell_nsmul_poleDivisor_ge hm
+  have hdeg : Divisor.degree (m • P.B) = (m : ℤ) * P.n := by
+    rw [show m • P.B = (m : ℤ) • P.B from (natCast_zsmul _ _).symm,
+      Divisor.degree.map_zsmul, smul_eq_mul, P.degB_eq]
+  linarith
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degree_nsmul_sub_ell_le"
+end PoleDivisorPackage
+
+namespace PoleDivisorPackage
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degB_eq u B hB_eff n lin_indep mk c x hn_pos \
+  hu_mem mk.injEq hx_mem"
+end PoleDivisorPackage
+namespace PoleDivisorPackage
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.ell_nsmul_sub_pos [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) {A : Divisor K F} (hA : 0 ≤ A) {m : ℕ} (hm : P.c ≤ m)
+    (hbig : Divisor.degree A < (P.n : ℤ) * (m - P.c + 1)) :
+    0 < ell (m • P.B - A) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  have hle : m • P.B - A ≤ m • P.B := by
+    intro v
+    have hAv : (0 : ℤ) ≤ A v := hA v
+    rw [Finsupp.sub_apply]
+    linarith
+  have h48 := ell_sub_ell_le_degree_sub_degree (K := K) hle
+  rw [map_sub, sub_sub_cancel] at h48
+  have h412 := P.ell_nsmul_poleDivisor_ge hm
+  have : (0 : ℤ) < (ell (m • P.B - A) : ℤ) := by linarith
+  exact_mod_cast this
+
+end PoleDivisorPackage
+p2m_export "AlgebraicCurve" "PoleDivisorPackage.ell_nsmul_sub_pos"
+namespace PoleDivisorPackage
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.degree_sub_ell_le [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) (D : Divisor K F) :
+    Divisor.degree D - ell D ≤ (P.n : ℤ) * (P.c - 1) := by
+  classical
+  set D' : Divisor K F := D ⊔ 0 with hD'def
+  have hD'eff : 0 ≤ D' := le_sup_right
+  have hDD' : D ≤ D' := le_sup_left
+  have := finiteDimensional_lSpace (K := K) D'
+  have hmono : Divisor.degree D - (ell D : ℤ) ≤ Divisor.degree D' - ell D' := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hDD'
+    linarith
+  set m : ℕ := P.c + (Divisor.degree D').toNat with hmdef
+  have hcm : P.c ≤ m := Nat.le_add_right _ _
+  have hdegD' : 0 ≤ Divisor.degree D' := Divisor.degree_nonneg_of_nonneg hD'eff
+  have hbig : Divisor.degree D' < (P.n : ℤ) * (m - P.c + 1) := by
+    have hcast : ((m : ℤ) - P.c) = Divisor.degree D' := by
+      simp only [hmdef, Nat.cast_add, add_sub_cancel_left, Int.toNat_of_nonneg hdegD']
+    rw [hcast]
+    have hn1 : (1 : ℤ) ≤ P.n := by exact_mod_cast P.hn_pos
+    nlinarith
+  have hellpos := P.ell_nsmul_sub_pos hD'eff hcm hbig
+  have hnebot : LSpace (m • P.B - D') ≠ ⊥ :=
+    fun h => by rw [ell, h, finrank_bot] at hellpos; exact lt_irrefl 0 hellpos
+  obtain ⟨z, hzL, hz0⟩ := (Submodule.ne_bot_iff _).mp hnebot
+  obtain ⟨Dz, hDzord, hDzdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) z hz0
+  have hzmem := (mem_lSpace_iff_ord.mp hzL).resolve_left hz0
+  have hD'le : D' ≤ m • P.B + Dz := by
+    intro v
+    have := hzmem v
+    simp only [Finsupp.add_apply, Finsupp.sub_apply, neg_sub] at this ⊢
+    rw [hDzord]; linarith
+  have hellshift : ell (m • P.B + Dz) = ell (m • P.B) :=
+    (LinearEquiv.finrank_eq (lSpaceShiftEquiv (m • P.B) hz0 hDzord)).symm
+  have hdegshift : Divisor.degree (m • P.B + Dz) = Divisor.degree (m • P.B) := by
+    rw [map_add, hDzdeg, add_zero]
+  have := finiteDimensional_lSpace (K := K) (m • P.B + Dz)
+  have hmono' : Divisor.degree D' - (ell D' : ℤ)
+      ≤ Divisor.degree (m • P.B + Dz) - ell (m • P.B + Dz) := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hD'le
+    linarith
+  rw [hellshift, hdegshift] at hmono'
+  have h412 := P.degree_nsmul_sub_ell_le hcm
+  linarith
+
+end PoleDivisorPackage
+p2m_export "AlgebraicCurve" "PoleDivisorPackage.degree_sub_ell_le"
+
+theorem riemannGenusBounded_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    RiemannGenusBounded K F :=
+  ⟨(P.n : ℤ) * (P.c - 1), P.degree_sub_ell_le⟩
+
+theorem stichtenothGenusExists_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_bounded (riemannGenusBounded_of_poleDivisorPackage P)
+
+theorem indexOfSpecialtyFinite_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_stichtenothGenusExists
+    (stichtenothGenusExists_of_poleDivisorPackage P)
+
+theorem indexOfSpecialtyFinite_of_hasPoleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (h : HasPoleDivisorPackage K F) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_poleDivisorPackage h.some
+
+theorem stichtenothGenusExists_of_hasPoleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (h : HasPoleDivisorPackage K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_poleDivisorPackage h.some
+
+theorem gate_stichtenothGenus_le_of_poleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F)
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    γ ≤ (P.n : ℤ) * (P.c - 1) + 1 := by
+  have := P.degree_sub_ell_le D₀
+  rw [h.eq] at this; linarith
+
+theorem gate_ell_c_nsmul_ge [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    (P.n : ℤ) ≤ ell (P.c • P.B) := by
+  have h := P.ell_nsmul_poleDivisor_ge (le_refl P.c)
+  simp only [sub_self, zero_add, mul_one] at h
+  exact h
+
+theorem gate_x_transcendental_of_poleDivisorPackage (P : PoleDivisorPackage K F) :
+    LinearIndependent K (fun j : ℕ => P.x ^ j * P.u ⟨0, P.hn_pos⟩) := by
+  refine P.lin_indep.comp (fun j => (j, ⟨0, P.hn_pos⟩)) ?_
+  intro a b hab
+  exact (Prod.mk.injEq .. ▸ hab).1
+
+theorem gate_u_linearIndependent_of_poleDivisorPackage (P : PoleDivisorPackage K F) :
+    LinearIndependent K P.u := by
+  have h : LinearIndependent K (fun i : Fin P.n => P.x ^ (0 : ℕ) * P.u i) := by
+    refine P.lin_indep.comp (fun i => (0, i)) ?_
+    intro a b hab
+    exact (Prod.mk.injEq .. ▸ hab).2
+  simpa using h
+
+end AlgebraicCurve
+
+end
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+scoped instance instSumRamificationInertia_port {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F']
+    [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+    [HasPrincipalDivisors K F'] : SumRamificationInertia K F F' :=
+  ⟨fun v => Place.sum_ramificationIndex_mul_inertiaDeg v⟩
+end AlgebraicCurve
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+
+namespace TranscendenceTower
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF poleDivisor RegularOutside hx_indep hxreg v \
+  mk.injEq mk hvdeg x hxv"
+p2m_open "AlgebraicCurve.TranscendenceTower"
+
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F]
+variable (T : TranscendenceTower K E F)
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.x_ne_zero : T.x ≠ 0 := fun h => by
+  have := T.hxv; rw [h, Place.ord_zero] at this; exact absurd this (by decide)
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "x_ne_zero"
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+theorem xF_ne_zero : T.xF ≠ 0 :=
+  fun h => T.x_ne_zero ((algebraMap E F).injective (by rwa [map_zero]))
+
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.poleDivisor_apply (w : Place K F) :
+    T.poleDivisor w = (w.ramificationIndex E : ℤ) * (Finsupp.single T.v 1) (w.restrict E) :=
+  Divisor.pullback_apply (Finsupp.single T.v 1) w
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "poleDivisor_apply"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.poleDivisor_nonneg :
+    0 ≤ T.poleDivisor := by
+  classical
+  intro w
+  rw [Finsupp.coe_zero, Pi.zero_apply, T.poleDivisor_apply, Finsupp.single_apply]
+  refine mul_nonneg (Int.natCast_nonneg _) ?_
+  split_ifs <;> simp
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "poleDivisor_nonneg"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.xF_mem_lSpace_poleDivisor :
+    T.xF ∈ LSpace T.poleDivisor := by
+  classical
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun w => ?_
+  rw [T.poleDivisor_apply, Place.ord_restrict, Finsupp.single_apply]
+  rcases eq_or_ne (w.restrict E) T.v with hw | hw
+  · simp only [hw, T.hxv, ite_true, mul_one, mul_neg_one, le_refl]
+  · simp only [ite_eq_right (Ne.symm hw), mul_zero, neg_zero]
+    exact mul_nonneg (Int.natCast_nonneg _) (T.hxreg _ hw)
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF_mem_lSpace_poleDivisor"
+
+private theorem _root_.AlgebraicCurve.TranscendenceTower.degree_poleDivisor_eq_finrank :
+    Divisor.degree T.poleDivisor = (Module.finrank E F : ℤ) := by
+  rw [poleDivisor, Divisor.degree_pullback, Divisor.degree_single, T.hvdeg]
+  push_cast; ring
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "degree_poleDivisor_eq_finrank"
+omit [FiniteDimensional E F] in
+private theorem
+  _root_.AlgebraicCurve.TranscendenceTower.mem_lSpace_nsmul_poleDivisor_of_regular_outside {f : F}
+    (hreg : ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord f)
+    {c : ℕ} (hc : ∀ w ∈ T.v.fiber F, -(c : ℤ) ≤ w.ord f) :
+    f ∈ LSpace (c • T.poleDivisor) := by
+  classical
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact (LSpace _).zero_mem
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun w => ?_
+  rw [Finsupp.smul_apply, T.poleDivisor_apply, Finsupp.single_apply, nsmul_eq_mul]
+  rcases eq_or_ne (w.restrict E) T.v with hw | hw
+  · simp only [hw, ite_true, mul_one]
+    have he : (1 : ℤ) ≤ w.ramificationIndex E := by
+      exact_mod_cast w.ramificationIndex_pos (F := E)
+    have hbdd := hc w (Place.mem_fiber.mpr hw)
+    nlinarith [Int.natCast_nonneg c]
+  · simp only [ite_eq_right (Ne.symm hw), mul_zero, neg_zero]
+    exact hreg w hw
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "mem_lSpace_nsmul_poleDivisor_of_regular_outside"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.exists_forall_mem_lSpace_nsmul_poleDivisor
+    {n : ℕ} (u : Fin n → F)
+    (hreg : ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)) :
+    ∃ c : ℕ, ∀ i, u i ∈ LSpace (c • T.poleDivisor) := by
+  classical
+  refine ⟨(Finset.univ : Finset (Fin n)).sup fun i =>
+    (T.v.fiber F).sup fun w => (-(w.ord (u i))).toNat,
+    fun i => T.mem_lSpace_nsmul_poleDivisor_of_regular_outside (hreg i) ?_⟩
+  intro w hw
+  have h1 : (-(w.ord (u i))).toNat
+      ≤ (T.v.fiber F).sup fun w' => (-(w'.ord (u i))).toNat :=
+    Finset.le_sup (f := fun w' => (-(w'.ord (u i))).toNat) hw
+  have h2 : ((T.v.fiber F).sup fun w' => (-(w'.ord (u i))).toNat)
+      ≤ (Finset.univ : Finset (Fin n)).sup fun i' =>
+          (T.v.fiber F).sup fun w' => (-(w'.ord (u i'))).toNat :=
+    Finset.le_sup (f := fun i' => (T.v.fiber F).sup fun w' => (-(w'.ord (u i'))).toNat)
+      (Finset.mem_univ i)
+  have htnat : -(w.ord (u i)) ≤ ((-(w.ord (u i))).toNat : ℤ) := Int.self_le_toNat _
+  omega
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "exists_forall_mem_lSpace_nsmul_poleDivisor"
+end TranscendenceTower
+
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F]
+
+section PrincipalDivisors
+
+variable [HasPrincipalDivisors K F]
+
+namespace IntegralBasisInLSpace
+p2m_export "AlgebraicCurve.IntegralBasisInLSpace" "hu_indep c u mk.injEq hu_mem mk"
+end IntegralBasisInLSpace
+p2m_open_scoped "AlgebraicCurve.IntegralBasisInLSpace" in
+def IntegralBasisInLSpace.ofRegularOutside (T : TranscendenceTower K E F)
+    (u : Fin (Module.finrank E F) → F) (hu_indep : LinearIndependent E u)
+    (hreg : ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)) :
+    IntegralBasisInLSpace T where
+  c := (T.exists_forall_mem_lSpace_nsmul_poleDivisor u hreg).choose
+  u := u
+  hu_indep := hu_indep
+  hu_mem := (T.exists_forall_mem_lSpace_nsmul_poleDivisor u hreg).choose_spec
+
+omit [FiniteDimensional E F] in
+theorem hasIntegralBasisInLSpace_of_regularOutside (T : TranscendenceTower K E F)
+    (h : HasIntegralBasisRegularOutside K E F T) :
+    HasIntegralBasisInLSpace K E F T := by
+  obtain ⟨u, hu_indep, hreg⟩ := h
+  exact ⟨IntegralBasisInLSpace.ofRegularOutside T u hu_indep hreg⟩
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+theorem linearIndependent_pow_mul_port {x : E} {n : ℕ} {u : Fin n → F}
+    (hx : LinearIndependent K (fun j : ℕ => x ^ j)) (hu : LinearIndependent E u) :
+    LinearIndependent K (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2) := by
+  have heq : (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2)
+      = (fun p : ℕ × Fin n => (x ^ p.1) • u p.2) := by
+    funext p
+    rw [Algebra.smul_def, map_pow]
+  rw [heq]
+  exact linearIndependent_smul (R := K) (S := E) (A := F) hx hu
+
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+def PoleDivisorPackage.ofTranscendenceTower (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    PoleDivisorPackage K F where
+  x := T.xF
+  B := T.poleDivisor
+  hB_eff := T.poleDivisor_nonneg
+  hx_mem := T.xF_mem_lSpace_poleDivisor
+  n := Module.finrank E F
+  hn_pos := Module.finrank_pos
+  degB_eq := T.degree_poleDivisor_eq_finrank
+  c := IB.c
+  u := IB.u
+  hu_mem := IB.hu_mem
+  lin_indep := linearIndependent_pow_mul_port T.hx_indep IB.hu_indep
+
+theorem hasPoleDivisorPackage_of_transcendenceTower
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    HasPoleDivisorPackage K F :=
+  ⟨PoleDivisorPackage.ofTranscendenceTower T IB⟩
+
+theorem hasPoleDivisorPackage_of_hasIntegralBasisInLSpace
+    (T : TranscendenceTower K E F) (h : HasIntegralBasisInLSpace K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_transcendenceTower T h.some
+
+theorem hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside
+    (T : TranscendenceTower K E F) (h : HasIntegralBasisRegularOutside K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisInLSpace T
+    (hasIntegralBasisInLSpace_of_regularOutside T h)
+
+end PrincipalDivisors
+
+theorem indexOfSpecialtyFinite_of_transcendenceTower [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem stichtenothGenusExists_of_transcendenceTower [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem gate_ofTranscendenceTower_n_eq [HasPrincipalDivisors K F] (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    (PoleDivisorPackage.ofTranscendenceTower T IB).n = Module.finrank E F := rfl
+
+theorem gate_ofTranscendenceTower_B_eq [HasPrincipalDivisors K F] (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    (PoleDivisorPackage.ofTranscendenceTower T IB).B = T.poleDivisor := rfl
+
+theorem gate_ofTranscendenceTower_x_transcendental [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    LinearIndependent K
+      (fun j : ℕ => T.xF ^ j *
+        (PoleDivisorPackage.ofTranscendenceTower T IB).u ⟨0, Module.finrank_pos⟩) :=
+  gate_x_transcendental_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem gate_degree_pullback_single_of_deg_eq [HasPrincipalDivisors K F]
+    (v : Place K E) (d : ℕ) (hd : v.deg = d) :
+    Divisor.degree (Divisor.pullback F (Finsupp.single v (1 : ℤ)))
+      = (Module.finrank E F : ℤ) * d := by
+  rw [Divisor.degree_pullback, Divisor.degree_single, hd]; ring
+
+theorem gate_stichtenothGenus_le_of_transcendenceTower [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T)
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    γ ≤ (Module.finrank E F : ℤ) * (IB.c - 1) + 1 :=
+  gate_stichtenothGenus_le_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB) h
+
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open Module
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor \
+  Place.algebraMap_mem' Place.ord_restrict Place.deg_restrict_mul_inertiaDeg Place.mem_fiber \
+  Divisor.pullback Divisor.pullback_apply Divisor.degree_pullback SumRamificationInertia \
+  IsCurveOver IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono \
+  one_mem_lSpace_zero ConstantsAreBase ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd \
+  adeleBdd_mono diagonalHom diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace \
+  adeleBdd_le_adeleSpace diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub \
+  map_diagonal_lSpace finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal \
+  indexOfSpecialty_eq omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual \
+  finrank_omegaSpace_eq_indexOfSpecialty weilDifferentialModule \
+  omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff mulAdele_apply adeleSpaceMul \
+  adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul weilSmul_injective \
+  weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe WeilDifferentialRankOne \
+  RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists RiemannGenusBounded \
+  IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage TranscendenceTower \
+  TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow mk.injEq algebraMap_mem' toValuationSubring mk \
+  ramificationIndex ramificationIndex_pos restrict mem_restrict_iff ord_restrict \
+  deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~comap_algebra\
+  Map_ne_top"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral {f : F}
+    (hf : IsIntegral w.toValuationSubring f) :
+    f ∈ w.toValuationSubring := by
+  obtain ⟨y, hy⟩ := IsIntegrallyClosed.isIntegral_iff.mp hf
+  exact hy ▸ y.2
+
+p2m_export "AlgebraicCurve.Place" "mem_of_isIntegral"
+
+theorem ord_nonneg_of_isIntegral {f : F} (hf : IsIntegral w.toValuationSubring f) :
+    0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral hf)
+
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral_of_algebraMap_mem {A : Type*}
+    [CommRing A] [Algebra A F]
+    (hA : ∀ a : A, algebraMap A F a ∈ w.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : f ∈ w.toValuationSubring := by
+  let : Algebra A w.toValuationSubring :=
+    ((algebraMap A F).codRestrict w.toValuationSubring.toSubring hA).toAlgebra
+  have : IsScalarTower A w.toValuationSubring F :=
+    IsScalarTower.of_algebraMap_eq fun a => rfl
+  exact w.mem_of_isIntegral hf.tower_top
+
+p2m_export "AlgebraicCurve.Place" "mem_of_isIntegral_of_algebraMap_mem"
+
+theorem ord_nonneg_of_isIntegral_of_algebraMap_mem {A : Type*} [CommRing A] [Algebra A F]
+    (hA : ∀ a : A, algebraMap A F a ∈ w.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : 0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral_of_algebraMap_mem hA hf)
+
+end Place
+
+section Bridge
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+variable {A : Type*} [CommRing A] [Algebra A E] [Algebra A F] [IsScalarTower A E F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow mk.injEq algebraMap_mem' toValuationSubring mk \
+  ramificationIndex ramificationIndex_pos restrict mem_restrict_iff ord_restrict \
+  deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg"
+end Place
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral_of_restrict [Algebra.IsIntegral E F]
+    (w : Place K F)
+    {u : Place K E} (hw : w.restrict E = u)
+    (hA : ∀ a : A, algebraMap A E a ∈ u.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : f ∈ w.toValuationSubring := by
+  refine w.mem_of_isIntegral_of_algebraMap_mem (fun a => ?_) hf
+  rw [IsScalarTower.algebraMap_apply A E F, ← w.mem_restrict_iff, hw]
+  exact hA a
+
+end Place
+p2m_export "AlgebraicCurve" "Place.mem_of_isIntegral_of_restrict"
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.ord_nonneg_of_isIntegral_of_restrict
+    [Algebra.IsIntegral E F] (w : Place K F)
+    {u : Place K E} (hw : w.restrict E = u)
+    (hA : ∀ a : A, algebraMap A E a ∈ u.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : 0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral_of_restrict hw hA hf)
+
+end Place
+p2m_export "AlgebraicCurve" "Place.ord_nonneg_of_isIntegral_of_restrict"
+namespace TranscendenceTower
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF poleDivisor RegularOutside hx_indep hxreg v \
+  mk.injEq mk hvdeg x hxv"
+end TranscendenceTower
+namespace TranscendenceTower
+p2m_open_scoped "AlgebraicCurve.TranscendenceTower" in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.ord_nonneg_of_isIntegral_of_regularOutside
+    [Algebra.IsIntegral E F] (T : TranscendenceTower K E F) (hA : T.RegularOutside A)
+    {f : F} (hf : IsIntegral A f) :
+    ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord f := fun w hw =>
+  w.ord_nonneg_of_isIntegral_of_restrict rfl (hA _ hw) hf
+
+end TranscendenceTower
+p2m_export "AlgebraicCurve" "TranscendenceTower.ord_nonneg_of_isIntegral_of_regularOutside"
+end Bridge
+
+section Headline
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F]
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+theorem linearIndependent_reindex_basis {s : Finset F} (b : Basis s E F) :
+    LinearIndependent E (fun i : Fin (Module.finrank E F) =>
+      b ((Fintype.equivFinOfCardEq (Module.finrank_eq_card_basis b).symm).symm i)) :=
+  b.linearIndependent.comp _ (Equiv.injective _)
+
+theorem hasIntegralBasisRegularOutside_of_isFractionRing
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    HasIntegralBasisRegularOutside K E F T := by
+  obtain ⟨s, b, hint⟩ := FiniteDimensional.exists_is_basis_integral A E F
+  set e : Fin (Module.finrank E F) ≃ s :=
+    (Fintype.equivFinOfCardEq (Module.finrank_eq_card_basis b).symm).symm
+  refine ⟨fun i => b (e i), linearIndependent_reindex_basis b, fun i w hw => ?_⟩
+  exact T.ord_nonneg_of_isIntegral_of_regularOutside hA (hint (e i)) w hw
+
+theorem hasIntegralBasisRegularOutside_of_hasRegularFractionSubring
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    HasIntegralBasisRegularOutside K E F T := by
+  obtain ⟨A, hfrac, hreg⟩ := h
+  have : IsFractionRing A E := hfrac
+  exact hasIntegralBasisRegularOutside_of_isFractionRing (A := A) T
+    (fun u hu a => hreg u hu (a : E) a.property)
+
+theorem hasPoleDivisorPackage_of_isFractionRing [HasPrincipalDivisors K F]
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside T
+    (hasIntegralBasisRegularOutside_of_isFractionRing T hA)
+
+theorem stichtenothGenusExists_of_isFractionRing [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasPoleDivisorPackage
+    (hasPoleDivisorPackage_of_isFractionRing T hA)
+
+theorem hasPoleDivisorPackage_of_hasRegularFractionSubring [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside T
+    (hasIntegralBasisRegularOutside_of_hasRegularFractionSubring T h)
+
+theorem stichtenothGenusExists_of_hasRegularFractionSubring [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasPoleDivisorPackage
+    (hasPoleDivisorPackage_of_hasRegularFractionSubring T h)
+
+namespace TranscendenceTower
+p2m_open_scoped "AlgebraicCurve.TranscendenceTower" in
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.adjoin_x_regularOutside (T :
+  TranscendenceTower K E F) :
+    ∀ u : Place K E, u ≠ T.v →
+      ∀ a ∈ Algebra.adjoin K {T.x}, a ∈ u.toValuationSubring := by
+  intro u hu a ha
+  let S : Subalgebra K E :=
+    { u.toValuationSubring.toSubsemiring with
+      algebraMap_mem' := u.algebraMap_mem' }
+  suffices h : a ∈ S from h
+  refine Algebra.adjoin_le ?_ ha
+  intro y hy
+  rw [Set.mem_singleton_iff] at hy
+  subst hy
+  change T.x ∈ u.toValuationSubring
+  exact AlgebraicCurve.Place.mem_of_ord_nonneg u T.x_ne_zero (T.hxreg u hu)
+
+end TranscendenceTower
+p2m_export "AlgebraicCurve" "TranscendenceTower.adjoin_x_regularOutside"
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+theorem hasRegularFractionSubring_of_adjoin_x_isFractionRing
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    HasRegularFractionSubring K E F T :=
+  ⟨Algebra.adjoin K {T.x}, hfrac, T.adjoin_x_regularOutside⟩
+
+theorem hasIntegralBasisRegularOutside_of_adjoin_x_isFractionRing
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    HasIntegralBasisRegularOutside K E F T :=
+  hasIntegralBasisRegularOutside_of_hasRegularFractionSubring T
+    (hasRegularFractionSubring_of_adjoin_x_isFractionRing T hfrac)
+
+theorem stichtenothGenusExists_of_adjoin_x_isFractionRing [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasRegularFractionSubring T
+    (hasRegularFractionSubring_of_adjoin_x_isFractionRing T hfrac)
+
+end Headline
+
+section Gates
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem gate_mem_of_isIntegral_recovers_comap (w : Place K F) (E : Type*) [Field E]
+    [Algebra E F] [Algebra.IsIntegral E F]
+    (hE : ∀ a : E, algebraMap E F a ∈ w.toValuationSubring) (f : F) :
+    f ∈ w.toValuationSubring := by
+  let : Algebra E w.toValuationSubring :=
+    ((algebraMap E F).codRestrict w.toValuationSubring.toSubring hE).toAlgebra
+  have : IsScalarTower E w.toValuationSubring F :=
+    IsScalarTower.of_algebraMap_eq fun _ => rfl
+  exact w.mem_of_isIntegral (Algebra.IsIntegral.isIntegral (R := E) f).tower_top
+
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+
+theorem gate_bridge_recovers_hxreg [Algebra.IsIntegral E F]
+    (T : TranscendenceTower K E F) (w : Place K F) (hw : w.restrict E ≠ T.v) :
+    0 ≤ w.ord T.xF := by
+  rw [TranscendenceTower.xF, Place.ord_restrict]
+  exact mul_nonneg (Int.natCast_nonneg _) (T.hxreg _ hw)
+
+theorem gate_regularOutside_mono (T : TranscendenceTower K E F) {A A' : Subalgebra K E}
+    (hle : A ≤ A')
+    (hA' : ∀ u : Place K E, u ≠ T.v → ∀ a ∈ A', a ∈ u.toValuationSubring) :
+    ∀ u : Place K E, u ≠ T.v → ∀ a ∈ A, a ∈ u.toValuationSubring :=
+  fun u hu a ha => hA' u hu a (hle ha)
+
+theorem gate_bot_regularOutside (T : TranscendenceTower K E F) :
+    ∀ u : Place K E, u ≠ T.v → ∀ a ∈ (⊥ : Subalgebra K E), a ∈ u.toValuationSubring := by
+  intro u _ a ha
+  obtain ⟨c, rfl⟩ := Algebra.mem_bot.mp ha
+  exact u.algebraMap_mem' c
+
+theorem gate_adjoin_x_not_regular_at_v (T : TranscendenceTower K E F) :
+    ¬ ∀ a ∈ Algebra.adjoin K {T.x}, a ∈ T.v.toValuationSubring := by
+  intro h
+  have hx := AlgebraicCurve.Place.ord_nonneg_of_mem T.v (h T.x (Algebra.subset_adjoin rfl))
+  rw [T.hxv] at hx
+  exact absurd hx (by decide)
+
+end Gates
+end AlgebraicCurve
+end
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg\
+  " in
+open _root_.P2MW.S_AlgebraicCurve_linearIndependent_pow_mul.AlgebraicCurve in
+theorem solution {K : Type*} {E : Type*} {F : Type*} [Field K] [Field E] [Field F] [Algebra K E]
+    [Algebra K F] [Algebra E F] [IsScalarTower K E F] {x : E} {n : ℕ} {u : Fin n → F}
+    (hx : LinearIndependent K (fun j : ℕ => x ^ j)) (hu : LinearIndependent E u) :
+    LinearIndependent K (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2) :=
+  AlgebraicCurve.linearIndependent_pow_mul_port (K := K) (F := F) (E := E) (x := x) (n := n) (u :=
+    u) (hx := hx) (hu := hu)
+
+end S_AlgebraicCurve_linearIndependent_pow_mul
+end P2MW
+export P2MW.S_AlgebraicCurve_linearIndependent_pow_mul (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace AlgebraicCurve
+theorem linearIndependent_pow_mul {K : Type*} {E : Type*} {F : Type*} [Field K] [Field E] [Field F]
+    [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F] {x : E} {n : ℕ} {u : Fin n → F}
+    (hx : LinearIndependent K (fun j : ℕ => x ^ j)) (hu : LinearIndependent E u) :
+    LinearIndependent K (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2) :=
+  solution hx hu
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_linearIndependent_pow_of_transcendental.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_linearIndependent_pow_of_transcendental.lean
new file mode 100644
index 0000000000..f96ee7cc79
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_linearIndependent_pow_of_transcendental.lean
@@ -0,0 +1,2670 @@
+/-
+Based on Prove2Me node AlgebraicCurve.linearIndependent_pow_of_transcendental
+(91b673f4-9d35-56a2-9173-4ba86b8a9b0f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7bb118b2-b1ad-5474-a7e5-6f4cf10556e9
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.LinearAlgebra.LinearIndependent.Defs
+public import Mathlib.RingTheory.Algebraic.Defs
+
+import Mathlib.Algebra.Polynomial.Basis
+import Mathlib.Data.Int.LeastGreatest
+import Mathlib.LinearAlgebra.Matrix.FiniteDimensional
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PoleDivisorPackage
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_restrict_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_placeInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Powers of a transcendental element are linearly independent
+
+Theorem statement: `AlgebraicCurve.linearIndependent_pow_of_transcendental`
+(`91b673f4-9d35-56a2-9173-4ba86b8a9b0f`), by Claude, 2026-09-05.
+
+Proof: submission `7bb118b2-b1ad-5474-a7e5-6f4cf10556e9`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $A$ be commutative rings with $A$ a $K$-algebra, and let $x \in A$. Assume $x$ is
+transcendental over $K$, that is, $x$ is not algebraic over $K$: there is no nonzero polynomial $p
+\in K[X]$ with $p(x) = 0$ (evaluation via the $K$-algebra map $K[X] \to A$ sending $X$ to $x$). The
+conclusion is that the family of powers $(x^j)_{j \in \mathbb{N}}$, indexed by all natural numbers
+$j$ including $j = 0$, is linearly independent over $K$ as a family in the $K$-module $A$: every
+$K$-linear combination of finitely many powers $x^j$ that vanishes has all its coefficients zero.
+Note that $K$ is only assumed to be a commutative ring, not a field, so linear independence is that
+of a family in a module over a commutative ring; equivalently, the statement says that the
+$K$-algebra homomorphism $K[X] \to A$ determined by $X \mapsto x$ is injective, the monomials
+forming a $K$-basis of $K[X]$.
+
+This is the standard equivalence between transcendence of an element over the base and injectivity
+of the associated polynomial evaluation map, in the form of linear independence of the monomials
+$x^j$. It supplies the independence datum used when a rational function field is presented as a
+transcendental extension, and is invoked in the construction of integral models and in the
+computation of the genus of a curve with a principal divisor of the form $P - Q$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_linearIndependent_pow_of_transcendental.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_linearIndependent_pow_of_transcendental
+
+
+open Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "degree degree_single principal smul_def smul_apply pullback \
+  pullback_apply degree_pullback"
+end Divisor
+variable {D : Divisor K F}
+p2m_open_scoped "AlgebraicCurve.Divisor" in
+theorem Divisor.degree_nonneg_of_nonneg [IsCurveOver K F]
+    {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) : 0 ≤ Divisor.degree D := by
+  rw [Divisor.degree_eq_sum_support]
+  exact Finset.sum_nonneg fun v _ => mul_nonneg (hD v) (Int.natCast_nonneg _)
+theorem lSpace_eq_bot_of_degree_neg [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) : LSpace D = ⊥ := by
+  rw [eq_bot_iff]
+  intro f hf
+  rw [Submodule.mem_bot]
+  by_contra hf0
+  obtain ⟨P, hPord, hPdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+  have heff : ∀ v : Place K F, 0 ≤ (P + D) v := by
+    intro v
+    rw [Finsupp.add_apply, hPord]
+    rcases mem_lSpace_iff_ord.mp hf with rfl | h
+    · exact absurd rfl hf0
+    · linarith [h v]
+  have hdegPD : 0 ≤ Divisor.degree (P + D) := Divisor.degree_nonneg_of_nonneg heff
+  rw [map_add, hPdeg, zero_add] at hdegPD
+  exact absurd hdegPD (not_le.mpr hD)
+end AlgebraicCurve
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~restrict_plac\
+  eOfPrime~placeOfPrime~comap_algebraMap_ne_top"
+
+variable (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mk_mem_maximalIdeal_iff {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    (⟨f, hf⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring
+      ↔ f = 0 ∨ 0 < v.ord f := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  constructor
+  · intro hu
+    rcases eq_or_ne f 0 with rfl | hf0
+    · exact Or.inl rfl
+    · refine Or.inr ?_
+      rcases lt_or_eq_of_le (AlgebraicCurve.Place.ord_nonneg_of_mem v hf) with h | h
+      · exact h
+      · exfalso
+        apply hu
+        rw [← v.adicValuation_coe_eq_one_iff ⟨f, hf⟩]
+        change v.adicValuation f = 1
+        rw [v.adicValuation_eq_exp_neg_ord hf0, ← h, neg_zero, WithZero.exp_zero]
+  · intro h hu
+    have hne : f ≠ 0 := fun h0 => hu.ne_zero (Subtype.ext h0)
+    have h0 : v.ord f = 0 := by
+      obtain ⟨u, hu'⟩ := hu
+      have hcoe : f = ((u : v.toValuationSubring) : F) := by rw [hu']
+      rw [hcoe]; exact v.ord_coe_unit u
+    rcases h with rfl | hpos
+    · exact hne rfl
+    · omega
+
+p2m_export "AlgebraicCurve.Place" "mk_mem_maximalIdeal_iff"
+end Place
+
+theorem ell_le_ell_sub_single_add_deg [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    ell D ≤ ell (D - Finsupp.single P 1) + P.deg := by
+  classical
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible P.toValuationSubring
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by
+    simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := by
+    intro g hg
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ g : F, g ∈ LSpace D → t ^ (D P) * g ∈ P.toValuationSubring := by
+    intro g hg
+    rcases eq_or_ne g 0 with rfl | hg0
+    · simp
+    · refine AlgebraicCurve.Place.mem_of_ord_nonneg P (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have := (mem_lSpace_iff_ord.mp hg).resolve_left hg0 P
+      linarith
+  let ψ : LSpace D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun f => ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+      map_add' := by intro f g; apply Subtype.ext; push_cast; ring
+      map_smul' := by
+        intro c f; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap]
+        ring }
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : LSpace D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ f : LSpace D, φ f = 0 ↔
+      (⟨t ^ (D P) * (f : F), hmem _ f.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := by
+    intro f
+    rw [show φ f = IsLocalRing.residue P.toValuationSubring ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+          from hres (ψ f),
+      IsLocalRing.residue_eq_zero_iff]
+  have hED : E ≤ D := by
+    rw [Finsupp.le_def]; intro v; rw [hE, Finsupp.sub_apply]
+    have : (0 : ℤ) ≤ Finsupp.single P 1 v := by
+      rcases eq_or_ne v P with rfl | hv
+      · simp
+      · simp [Finsupp.single_eq_of_ne hv]
+    linarith
+  have hsub : LSpace E ≤ LSpace D := lSpace_mono hED
+  have hker : LinearMap.ker φ = (LSpace E).comap (LSpace D).subtype := by
+    ext f
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi f, P.mk_mem_maximalIdeal_iff]
+    rcases eq_or_ne (f : F) 0 with hf0 | hf0
+    · simp only [hf0, mul_zero, true_or, true_iff]
+      exact (LSpace E).zero_mem
+    · rw [mem_lSpace_iff_ord]
+      have hfD := (mem_lSpace_iff_ord.mp f.2).resolve_left hf0
+      constructor
+      · rintro (h | h)
+        · exact absurd h (mul_ne_zero htn0 hf0)
+        · refine Or.inr (fun v => ?_)
+          rcases eq_or_ne v P with rfl | hv
+          · rw [hEP]; rw [hordmul hf0] at h; omega
+          · rw [hEv v hv]; exact hfD v
+      · rintro (h | h)
+        · exact absurd h hf0
+        · refine Or.inr ?_
+          have hP := h P
+          rw [hEP] at hP
+          rw [hordmul hf0]; omega
+  have hkerfin : finrank K (LinearMap.ker φ) = ell E := by
+    rw [hker, LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe hsub)]
+  have hquot : finrank K (LSpace D ⧸ LinearMap.ker φ) ≤ P.deg := by
+    rw [LinearEquiv.finrank_eq φ.quotKerEquivRange]
+    exact Submodule.finrank_le (LinearMap.range φ)
+  by_cases hfin : FiniteDimensional K (LSpace D)
+  · have := hfin
+    have hrn := Submodule.finrank_quotient_add_finrank (LinearMap.ker φ)
+    rw [hkerfin] at hrn
+    have hb : ell D = finrank K (LSpace D) := rfl
+    omega
+  · have h0 : ell D = 0 := by rw [ell]; exact finrank_of_infinite_dimensional hfin
+    omega
+
+theorem one_le_deg [IsCurveOver K F] (P : Place K F) : 1 ≤ P.deg := by
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  exact Module.finrank_pos
+
+theorem ell_le_degree_add_ellZero [IsCurveOver K F] {D : Divisor K F}
+    (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D : Divisor K F, (∀ v, 0 ≤ D v) →
+      (Divisor.degree D).toNat = m →
+      (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) by
+    exact H (Divisor.degree D).toNat D hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D hD hm
+    by_cases hD0 : D = 0
+    · subst hD0; simp
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ D P := by
+        have hne : D P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hD P; omega
+      set E : Divisor K F := D - Finsupp.single P 1 with hE
+      have hEeff : ∀ v, 0 ≤ E v := by
+        intro v; rw [hE, Finsupp.sub_apply]
+        rcases eq_or_ne v P with rfl | hv
+        · rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have hdegE : Divisor.degree E = Divisor.degree D - P.deg := by
+        rw [hE, map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hDnn : 0 ≤ Divisor.degree D := Divisor.degree_nonneg_of_nonneg hD
+      have hEnn : 0 ≤ Divisor.degree E := Divisor.degree_nonneg_of_nonneg hEeff
+      have hmlt : (Divisor.degree E).toNat < m := by rw [← hm]; omega
+      have hIH := IH _ hmlt E hEeff rfl
+      have hstep := ell_le_ell_sub_single_add_deg D P
+      rw [← hE] at hstep
+      have hstep' : (ell D : ℤ) ≤ (ell E : ℤ) + P.deg := by exact_mod_cast hstep
+      rw [hdegE] at hIH
+      linarith
+
+theorem ell_le_degree_add_one_of_effective [IsCurveOver K F]
+    (hC : ConstantsAreBase K F) {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  have h := ell_le_degree_add_ellZero hD
+  rw [ell_zero_eq_one_of_constantsAreBase hC] at h
+  exact_mod_cast h
+
+def lSpaceShiftEquiv (D : Divisor K F) {g : F} (hg : g ≠ 0)
+    {Dg : Divisor K F} (hDg : ∀ v, Dg v = v.ord g) :
+    LSpace D ≃ₗ[K] LSpace (D + Dg) where
+  toFun h := ⟨(h : F) * g⁻¹, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (h : F) 0 with hh0 | hh0
+    · left; rw [hh0, zero_mul]
+    · right; intro v
+      rw [Finsupp.add_apply, hDg, v.ord_mul hh0 (inv_ne_zero hg), v.ord_inv]
+      have := (mem_lSpace_iff_ord.mp h.2).resolve_left hh0 v
+      linarith⟩
+  invFun k := ⟨(k : F) * g, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (k : F) 0 with hk0 | hk0
+    · left; rw [hk0, zero_mul]
+    · right; intro v
+      have := (mem_lSpace_iff_ord.mp k.2).resolve_left hk0 v
+      rw [Finsupp.add_apply, hDg] at this
+      rw [v.ord_mul hk0 hg]
+      linarith⟩
+  map_add' h₁ h₂ := by apply Subtype.ext; push_cast; ring
+  map_smul' c h := by
+    apply Subtype.ext
+    simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def]
+    ring
+  left_inv h := by
+    apply Subtype.ext
+    change (h : F) * g⁻¹ * g = (h : F)
+    rw [mul_assoc, inv_mul_cancel₀ hg, mul_one]
+  right_inv k := by
+    apply Subtype.ext
+    change (k : F) * g * g⁻¹ = (k : F)
+    rw [mul_assoc, mul_inv_cancel₀ hg, mul_one]
+
+theorem ell_le_degree_add_one [IsCurveOver K F] (hC : ConstantsAreBase K F)
+    {D : Divisor K F} (hD : 0 ≤ Divisor.degree D) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  rcases eq_or_ne (ell D) 0 with h0 | h0
+  · rw [h0]; push_cast; linarith
+  · have hbot : LSpace D ≠ ⊥ := fun h => h0 (by rw [ell, h, finrank_bot])
+    obtain ⟨g, hgL, hg0⟩ := (Submodule.ne_bot_iff _).mp hbot
+    obtain ⟨Dg, hDgord, hDgdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) g hg0
+    have heff : ∀ v, 0 ≤ (D + Dg) v := by
+      intro v; rw [Finsupp.add_apply, hDgord]
+      have := (mem_lSpace_iff_ord.mp hgL).resolve_left hg0 v
+      linarith
+    have hdeg : Divisor.degree (D + Dg) = Divisor.degree D := by
+      rw [map_add, hDgdeg, add_zero]
+    have hell : ell D = ell (D + Dg) :=
+      LinearEquiv.finrank_eq (lSpaceShiftEquiv D hg0 hDgord)
+    have hfin := ell_le_degree_add_one_of_effective hC heff
+    rw [hdeg] at hfin
+    rw [hell]; exact hfin
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion factor mk mem_bot subtype_injective \
+  mk.injEq Quotient.subsingleton_iff Quotient.mk span restrictScalars inhabited \
+  inclusion_injective comapSubtypeEquivOfLe mem_comap finrank_quotient_add_finrank mem_top \
+  Quotient.equiv mkQ mem_map coe_subtype map_smul' zero one quotientQuotientEquivQuotient \
+  coe_eq_zero finrank_le range_subtype Quotient.mk_surjective map mem_inf mem_sup \
+  Quotient.mk_eq_zero topEquiv map_injective_of_injective comap_subtype_self mapQ subsingleton_iff \
+  module smul_def mk_eq_zero coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono \
+  map_sup coe_zero smul"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+def nestedComapMapMkQEquiv {A B C : Submodule K X} (_hAB : A ≤ B) (hBC : B ≤ C) :
+    ((B.comap C.subtype).map (A.comap C.subtype).mkQ : Submodule K _)
+      ≃ₗ[K] B ⧸ A.comap B.subtype := by
+  set S := A.comap C.subtype with hS
+  set T := B.comap C.subtype with hT
+  let ψ : (T : Type _) →ₗ[K] (C ⧸ S) := S.mkQ ∘ₗ T.subtype
+  have hker : LinearMap.ker ψ = S.comap T.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = T.map S.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let e1 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (T.map S.mkQ : Submodule K _) :=
+    (Submodule.Quotient.equiv _ (LinearMap.ker ψ) (LinearEquiv.refl K T)
+        (by rw [hker]; simp)).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have hmap : (S.comap T.subtype).map
+      (Submodule.comapSubtypeEquivOfLe hBC : (T : Type _) →ₗ[K] B) = A.comap B.subtype := by
+    ext ⟨b, hb⟩
+    simp only [mem_map, mem_comap, Submodule.coe_subtype, hS]
+    constructor
+    · rintro ⟨⟨⟨x, hxC⟩, hxB⟩, hxA, hxeq⟩
+      have hx : x = b := congrArg Subtype.val hxeq
+      subst hx; exact hxA
+    · intro hbA
+      exact ⟨⟨⟨b, hBC hb⟩, hb⟩, hbA, rfl⟩
+  let e2 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (B ⧸ A.comap B.subtype) :=
+    Submodule.Quotient.equiv _ _ (Submodule.comapSubtypeEquivOfLe hBC) hmap
+  exact e1.symm.trans e2
+
+theorem finrank_quotient_chain {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCB : Module.Finite K (C ⧸ B.comap C.subtype)]
+    [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (C ⧸ A.comap C.subtype) ∧
+      finrank K (C ⧸ A.comap C.subtype)
+        = finrank K (C ⧸ B.comap C.subtype) + finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (T.map S.mkQ : Submodule K _) := Module.Finite.equiv eK.symm
+  have : Module.Finite K ((C ⧸ S) ⧸ T.map S.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (C ⧸ S) := Module.Finite.of_submodule_quotient (T.map S.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+theorem finrank_quotient_chain' {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCA : Module.Finite K (C ⧸ A.comap C.subtype)] :
+    Module.Finite K (C ⧸ B.comap C.subtype) ∧
+      finrank K (C ⧸ B.comap C.subtype)
+        = finrank K (C ⧸ A.comap C.subtype) - finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (C ⧸ T) := Module.Finite.equiv e3
+  refine ⟨this, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+def adeleBddQuotSingleEquivResidueField (D : Divisor K F) (P : Place K F) :
+    (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+      ≃ₗ[K] P.ResidueField := by
+  classical
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  let π : P.toValuationSubring :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose
+  have hπ : Irreducible π :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose_spec
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := fun {g} hg => by
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ α : Place K F → F, α ∈ adeleBdd D → t ^ (D P) * α P ∈ P.toValuationSubring := by
+    intro α hα
+    rcases eq_or_ne (α P) 0 with hg0 | hg0
+    · simp [hg0]
+    · refine AlgebraicCurve.Place.mem_of_ord_nonneg P (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have h := hα P
+      rw [P.adicValuation_eq_exp_neg_ord hg0, WithZero.exp_le_exp] at h
+      linarith
+  let ψ : adeleBdd D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun α => ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩
+      map_add' := by
+        intro α β; apply Subtype.ext
+        simp only [Submodule.coe_add, Pi.add_apply]
+        push_cast; ring
+      map_smul' := by
+        intro c α; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap, Pi.smul_apply]
+        ring }
+  have hψ_apply : ∀ α : adeleBdd D,
+      (ψ α : F) = t ^ (D P) * (α : Place K F → F) P := fun α => rfl
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : adeleBdd D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ α : adeleBdd D, φ α = 0 ↔
+      (⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := fun α => by
+    rw [show φ α = IsLocalRing.residue P.toValuationSubring
+            ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ from hres (ψ α),
+      IsLocalRing.residue_eq_zero_iff]
+  have hker : LinearMap.ker φ = (adeleBdd E).comap (adeleBdd D).subtype := by
+    ext α
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi α, P.mk_mem_maximalIdeal_iff, mem_adeleBdd]
+    have hαD := α.2
+    constructor
+    · rintro (h | h) v
+      · have hα0 : (α : Place K F → F) P = 0 := by
+          rcases mul_eq_zero.mp h with h' | h'
+          · exact absurd h' htn0
+          · exact h'
+        by_cases hv : v = P
+        · subst v; rw [hα0, Valuation.map_zero]; exact zero_le
+        · rw [hEv v hv]; exact hαD v
+      · by_cases hv : v = P
+        · subst v
+          rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+          · rw [hα0, Valuation.map_zero]; exact zero_le
+          · rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP]
+            rw [hordmul hα0] at h; omega
+        · rw [hEv v hv]; exact hαD v
+    · intro h
+      rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+      · left; rw [hα0, mul_zero]
+      · right
+        have hP := h P
+        rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP] at hP
+        rw [hordmul hα0]; omega
+  have hsurj : Function.Surjective φ := by
+    intro c
+    obtain ⟨cl, hcl⟩ := IsLocalRing.residue_surjective (R := P.toValuationSubring) c
+    set f : F := (cl : F) * t ^ (-(D P)) with hf
+    have hαD : Pi.single P f ∈ adeleBdd D := by
+      intro v
+      by_cases hv : v = P
+      · subst v
+        simp only [Pi.single_eq_same]
+        rcases eq_or_ne (cl : F) 0 with hc0 | hc0
+        · rw [hf, hc0, zero_mul, Valuation.map_zero]; exact zero_le
+        · have hf0 : f ≠ 0 := by rw [hf]; exact mul_ne_zero hc0 (zpow_ne_zero _ ht0)
+          rw [P.adicValuation_eq_exp_neg_ord hf0, WithZero.exp_le_exp]
+          rw [hf, P.ord_mul hc0 (zpow_ne_zero _ ht0), P.ord_zpow, ht1, mul_one]
+          have hclnn := AlgebraicCurve.Place.ord_nonneg_of_mem P cl.2
+          linarith
+      · rw [Pi.single_eq_of_ne hv, Valuation.map_zero]; exact zero_le
+    refine ⟨⟨Pi.single P f, hαD⟩, ?_⟩
+    change res (ψ ⟨Pi.single P f, hαD⟩) = c
+    rw [hres]
+    rw [show (ψ ⟨Pi.single P f, hαD⟩ : P.toValuationSubring) = cl from ?_, hcl]
+    apply Subtype.ext
+    rw [hψ_apply]
+    change t ^ (D P) * (Pi.single P f : Place K F → F) P = (cl : F)
+    rw [show (Pi.single P f : Place K F → F) P = f from Pi.single_eq_same _ _, hf,
+      mul_comm (cl : F), ← mul_assoc, ← zpow_add₀ ht0, add_neg_cancel, zpow_zero, one_mul]
+  exact (Submodule.Quotient.equiv _ _ (LinearEquiv.refl K _) (by rw [← hker]; simp)).trans
+    (φ.quotKerEquivOfSurjective hsurj)
+
+theorem finrank_adeleBdd_quotient_single [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    Module.Finite K
+        (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype) ∧
+      finrank K
+          (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+        = P.deg := by
+  have := IsCurveOver.finite_residueField (K := K) P
+  exact ⟨Module.Finite.equiv (adeleBddQuotSingleEquivResidueField D P).symm,
+    (adeleBddQuotSingleEquivResidueField D P).finrank_eq⟩
+
+theorem finrank_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+      (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+        = Divisor.degree D₂ - Divisor.degree D₁ := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D₁ D₂ : Divisor K F, D₁ ≤ D₂ →
+      (Divisor.degree (D₂ - D₁)).toNat = m →
+      Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+        (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+          = Divisor.degree D₂ - Divisor.degree D₁ from
+    H _ D₁ D₂ hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D₁ D₂ hD hm
+    have hEeff : ∀ v, 0 ≤ (D₂ - D₁) v := fun v => by
+      rw [Finsupp.sub_apply]; have := hD v; omega
+    by_cases hD0 : D₂ - D₁ = 0
+    · have hD12 : D₁ = D₂ := (sub_eq_zero.mp hD0).symm
+      subst hD12
+      rw [Submodule.comap_subtype_self]
+      have : Subsingleton (adeleBdd D₁ ⧸ (⊤ : Submodule K (adeleBdd D₁))) :=
+        Submodule.Quotient.subsingleton_iff.mpr rfl
+      exact ⟨Module.Finite.of_finite, by simp [Module.finrank_zero_of_subsingleton]⟩
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ (D₂ - D₁) P := by
+        have hne : (D₂ - D₁) P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hEeff P; omega
+      set D₂' : Divisor K F := D₂ - Finsupp.single P 1 with hD₂'
+      have h12' : D₁ ≤ D₂' := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]
+          have := hPpos; rw [Finsupp.sub_apply] at this; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have h2'2 : D₂' ≤ D₂ := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]
+      have hdegD₂' : Divisor.degree D₂' = Divisor.degree D₂ - P.deg := by
+        rw [hD₂', map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hEnn : 0 ≤ Divisor.degree (D₂ - D₁) := Divisor.degree_nonneg_of_nonneg hEeff
+      have hE'nn : 0 ≤ Divisor.degree (D₂' - D₁) := Divisor.degree_nonneg_of_nonneg
+        (fun v => by rw [Finsupp.sub_apply]; have := h12' v; omega)
+      have hdegdiff : Divisor.degree (D₂' - D₁) = Divisor.degree (D₂ - D₁) - P.deg := by
+        simp only [hD₂', map_sub, Divisor.degree_single, one_mul]; ring
+      have hmlt : (Divisor.degree (D₂' - D₁)).toNat < m := by rw [← hm]; omega
+      obtain ⟨hfin', hrank'⟩ := IH _ hmlt D₁ D₂' h12' rfl
+      obtain ⟨hfinS, hrankS⟩ := finrank_adeleBdd_quotient_single (K := K) D₂ P
+      rw [← hD₂'] at hfinS hrankS
+      have := hfin'; have := hfinS
+      obtain ⟨hfin, hrank⟩ := Submodule.finrank_quotient_chain
+        (A := adeleBdd D₁) (B := adeleBdd D₂') (C := adeleBdd D₂)
+        (adeleBdd_mono h12') (adeleBdd_mono h2'2)
+      refine ⟨hfin, ?_⟩
+      rw [hrank, hrankS]
+      push_cast
+      linarith [hrank', hdegD₂']
+
+theorem module_finite_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  (finrank_adeleBdd_quotient hD).1
+
+theorem finrank_adeleBdd_quotient_eq [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+      = Divisor.degree D₂ - Divisor.degree D₁ :=
+  (finrank_adeleBdd_quotient hD).2
+
+def lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (_hD : D₁ ≤ D₂) :
+    (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      →ₗ[K] (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  Submodule.mapQ _ _
+    ((diagonalHom K F).restrict
+      (p := (LSpace D₂ : Submodule K F)) (q := (adeleBdd D₂ : Submodule K _))
+      (fun f hf => diagonal_mem_adeleBdd_iff.mpr hf))
+    (fun f hf => by
+      simp only [Submodule.mem_comap, Submodule.coe_subtype] at hf ⊢
+      exact diagonal_mem_adeleBdd_iff.mpr hf)
+
+theorem lSpaceQuotientToAdeleBddQuotient_injective {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Function.Injective (lSpaceQuotientToAdeleBddQuotient hD) := by
+  rw [injective_iff_map_eq_zero]
+  intro x hx
+  obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+  rw [Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype]
+  rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk f)
+        = Submodule.Quotient.mk ((diagonalHom K F).restrict
+            (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f) from rfl,
+    Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype] at hx
+  exact diagonal_mem_adeleBdd_iff.mp hx
+
+
+theorem ell_sub_ell_le_degree_sub_degree [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)] :
+    (ell D₂ : ℤ) - (ell D₁ : ℤ) ≤ Divisor.degree D₂ - Divisor.degree D₁ := by
+  have := module_finite_adeleBdd_quotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    rw [hℓ₁]; exact (Submodule.finrank_quotient_add_finrank _).symm
+  have hemb : finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      ≤ finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+    LinearMap.finrank_le_finrank_of_injective (lSpaceQuotientToAdeleBddQuotient_injective hD)
+  have hloc := finrank_adeleBdd_quotient_eq hD
+  have : (ell D₂ : ℤ) - (ell D₁ : ℤ)
+      = (finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) : ℤ) := by
+    rw [hL]; push_cast; ring
+  rw [this, ← hloc]
+  exact_mod_cast hemb
+
+theorem adeleBdd_inf_sup_globalSub {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F)
+      = adeleBdd D₁ ⊔ adeleBdd D₂ ⊓ globalSub K F := by
+  rw [inf_comm, sup_inf_assoc_of_le _ (adeleBdd_mono hD), inf_comm]
+
+theorem map_diagonal_lSpace_inf_adeleBdd {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (LSpace D₂).map (diagonalHom K F) ⊓ adeleBdd D₁ = (LSpace D₁).map (diagonalHom K F) := by
+  rw [map_diagonal_lSpace, map_diagonal_lSpace, inf_right_comm,
+    inf_eq_right.mpr (adeleBdd_mono hD)]
+
+theorem gate_finrank_adeleBdd_quotient_single_point [IsCurveOver K F] (P : Place K F) :
+    (finrank K (adeleBdd (Finsupp.single P 1 : Divisor K F)
+        ⧸ (adeleBdd (0 : Divisor K F)).comap (adeleBdd (Finsupp.single P 1)).subtype) : ℤ)
+      = (P.deg : ℤ) := by
+  classical
+  have h01 : (0 : Divisor K F) ≤ Finsupp.single P 1 := by
+    intro v; rw [Finsupp.zero_apply, Finsupp.single_apply]; split_ifs <;> omega
+  have h := finrank_adeleBdd_quotient_eq (K := K) h01
+  rw [h, map_zero, sub_zero, Divisor.degree_single, one_mul]
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion factor mk mem_bot subtype_injective \
+  mk.injEq Quotient.subsingleton_iff Quotient.mk span restrictScalars inhabited \
+  inclusion_injective comapSubtypeEquivOfLe mem_comap finrank_quotient_add_finrank mem_top \
+  Quotient.equiv mkQ mem_map coe_subtype map_smul' zero one quotientQuotientEquivQuotient \
+  coe_eq_zero finrank_le range_subtype Quotient.mk_surjective map mem_inf mem_sup \
+  Quotient.mk_eq_zero topEquiv map_injective_of_injective comap_subtype_self mapQ subsingleton_iff \
+  module smul_def mk_eq_zero coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono \
+  map_sup coe_zero smul"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+theorem comap_subtype_sup_of_le_of_le {S T C : Submodule K X} (hS : S ≤ C) (hT : T ≤ C) :
+    S.comap C.subtype ⊔ T.comap C.subtype = (S ⊔ T).comap C.subtype := by
+  apply Submodule.map_injective_of_injective (f := C.subtype) C.subtype_injective
+  rw [Submodule.map_sup, Submodule.map_comap_subtype, Submodule.map_comap_subtype,
+    Submodule.map_comap_subtype, inf_eq_right.mpr hS, inf_eq_right.mpr hT,
+    inf_eq_right.mpr (sup_le hS hT)]
+
+theorem finrank_quotient_chain_top {M : Type*} [AddCommGroup M] [Module K M]
+    {A B : Submodule K M} (hAB : A ≤ B)
+    [hMB : Module.Finite K (M ⧸ B)] [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (M ⧸ A) ∧
+      finrank K (M ⧸ A) = finrank K (M ⧸ B) + finrank K (B ⧸ A.comap B.subtype) := by
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  let ψ : (B : Type _) →ₗ[K] (M ⧸ A) := A.mkQ ∘ₗ B.subtype
+  have hker : LinearMap.ker ψ = A.comap B.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = B.map A.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let eK : (B ⧸ A.comap B.subtype) ≃ₗ[K] (B.map A.mkQ : Submodule K (M ⧸ A)) :=
+    (Submodule.quotEquivOfEq _ _ hker.symm).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have : Module.Finite K (B.map A.mkQ : Submodule K (M ⧸ A)) := Module.Finite.equiv eK
+  have : Module.Finite K ((M ⧸ A) ⧸ B.map A.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (M ⧸ A) := Module.Finite.of_submodule_quotient (B.map A.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (B.map A.mkQ)
+  rw [LinearEquiv.finrank_eq e3, ← LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem globalSub_le_adeleSpace [HasPrincipalDivisors K F] :
+    globalSub K F ≤ adeleSpace K F := by
+  rintro _ ⟨f, rfl⟩
+  exact diagonal_mem_adeleSpace f
+
+theorem adeleBdd_sup_globalSub_le_adeleSpace [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+  sup_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_eq_comap [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBddPrincipal K F D = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype :=
+  Submodule.comap_subtype_sup_of_le_of_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_mono {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBddPrincipal K F D₁ ≤ adeleBddPrincipal K F D₂ :=
+  sup_le_sup_right (Submodule.comap_mono (adeleBdd_mono hD)) _
+
+section FiniteLSpace
+
+variable [IsCurveOver K F]
+
+theorem finiteDimensional_lSpace [hL0 : FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (D : Divisor K F) : FiniteDimensional K (LSpace D) := by
+  have h0D : (0 : Divisor K F) ≤ D ⊔ 0 := le_sup_right
+  have hDD : D ≤ D ⊔ 0 := le_sup_left
+  suffices h : FiniteDimensional K (LSpace (D ⊔ 0)) by
+    exact Module.Finite.of_injective (Submodule.inclusion (lSpace_mono hDD))
+      (Submodule.inclusion_injective _)
+  have := module_finite_adeleBdd_quotient (K := K) h0D
+  have hfinQ : FiniteDimensional K
+      (LSpace (D ⊔ 0) ⧸ (LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype) :=
+    Module.Finite.of_injective _ (lSpaceQuotientToAdeleBddQuotient_injective h0D)
+  have : FiniteDimensional K
+      ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype : Submodule K _) :=
+    Module.Finite.equiv (Submodule.comapSubtypeEquivOfLe (lSpace_mono h0D)).symm
+  exact Module.Finite.of_submodule_quotient
+    ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype)
+
+end FiniteLSpace
+
+
+theorem range_lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD)
+      = ((adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype).map
+          ((adeleBdd D₁).comap (adeleBdd D₂).subtype).mkQ := by
+  classical
+  ext z
+  obtain ⟨α, rfl⟩ := Submodule.Quotient.mk_surjective _ z
+  simp only [LinearMap.mem_range, Submodule.mem_map, Submodule.mem_comap, Submodule.coe_subtype,
+    Submodule.mkQ_apply]
+  constructor
+  · rintro ⟨x, hx⟩
+    obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+    have hxeq : Submodule.Quotient.mk
+        ((diagonalHom K F).restrict (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f)
+        = (Submodule.Quotient.mk α :
+            adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) := hx
+    refine ⟨α, ?_, rfl⟩
+    have hdiag2 : (diagonalHom K F (f : F)) ∈ adeleBdd D₂ := diagonal_mem_adeleBdd_iff.mpr f.2
+    have hsub : (α : Place K F → F) - diagonalHom K F (f : F) ∈ adeleBdd D₁ := by
+      have hq := (Submodule.Quotient.eq _).mp hxeq.symm
+      simpa using hq
+    refine Submodule.mem_sup.mpr ⟨(α : Place K F → F) - diagonalHom K F (f : F), hsub,
+      diagonalHom K F (f : F), diagonal_mem_globalSub _, ?_⟩
+    abel
+  · rintro ⟨β, hβ, hβeq⟩
+    have hβ' : (β : Place K F → F) ∈ adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F) :=
+      Submodule.mem_inf.mpr ⟨β.2, hβ⟩
+    rw [adeleBdd_inf_sup_globalSub hD, ← map_diagonal_lSpace] at hβ'
+    obtain ⟨γ, hγ, δ, ⟨f, hf, hfδ⟩, hsum⟩ := Submodule.mem_sup.mp hβ'
+    refine ⟨Submodule.Quotient.mk ⟨f, hf⟩, ?_⟩
+    rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk ⟨f, hf⟩)
+          = Submodule.Quotient.mk ((diagonalHom K F).restrict
+              (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) ⟨f, hf⟩) from rfl,
+      ← hβeq, Submodule.Quotient.eq]
+    refine Submodule.mem_comap.mpr ?_
+    change diagonalHom K F f - (β : Place K F → F) ∈ adeleBdd D₁
+    have hβsub : diagonalHom K F f - (β : Place K F → F) = -γ := by
+      rw [← hsum, hfδ]; ring
+    rw [hβsub]; exact (adeleBdd D₁).neg_mem hγ
+
+
+theorem finrank_adeleBddSup_quotient [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) [hL : FiniteDimensional K (LSpace D₂)] :
+    Module.Finite K (↥(adeleBdd D₂ ⊔ globalSub K F)
+        ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) ∧
+      (finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+          ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) : ℤ)
+        = (Divisor.degree D₂ - ell D₂) - (Divisor.degree D₁ - ell D₁) := by
+  classical
+  let A : Submodule K (adeleBdd D₂) := (adeleBdd D₁).comap (adeleBdd D₂).subtype
+  let B : Submodule K (adeleBdd D₂) :=
+    (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype
+  have hAB : A ≤ B := Submodule.comap_mono le_sup_left
+  have hfinA : Module.Finite K (adeleBdd D₂ ⧸ A) := module_finite_adeleBdd_quotient hD
+  have hdimA : (finrank K (adeleBdd D₂ ⧸ A) : ℤ) = Divisor.degree D₂ - Divisor.degree D₁ :=
+    finrank_adeleBdd_quotient_eq hD
+  have hran : LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD) = B.map A.mkQ :=
+    range_lSpaceQuotientToAdeleBddQuotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hdimL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K)
+      ((LSpace D₁).comap (LSpace D₂).subtype)
+    rw [← hℓ₁] at h; exact h.symm
+  have hdimB : ell D₂ = finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) + ell D₁ := by
+    rw [← hran, LinearMap.finrank_range_of_inj
+      (lSpaceQuotientToAdeleBddQuotient_injective hD)]
+    exact hdimL
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  have hfinB : Module.Finite K (adeleBdd D₂ ⧸ B) := Module.Finite.equiv e3
+  have hdim2 : finrank K (adeleBdd D₂ ⧸ A)
+      = finrank K (adeleBdd D₂ ⧸ B) + finrank K (B.map A.mkQ : Submodule K _) := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K) (M := adeleBdd D₂ ⧸ A)
+      (B.map A.mkQ)
+    rw [LinearEquiv.finrank_eq e3] at h; omega
+  have e2 := LinearMap.quotientInfEquivSupQuotient (R := K)
+    (adeleBdd D₂) (adeleBdd D₁ ⊔ globalSub K F)
+  have hsup : adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F) = adeleBdd D₂ ⊔ globalSub K F := by
+    rw [← sup_assoc, sup_eq_left.mpr (adeleBdd_mono hD)]
+  have hB' : (adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype = B := by
+    rw [Submodule.comap_subtype_self, top_inf_eq]
+  let eL : (adeleBdd D₂ ⧸ B) ≃ₗ[K]
+      (adeleBdd D₂ ⧸ ((adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+        (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype)) :=
+    Submodule.quotEquivOfEq _ _ hB'.symm
+  have hfin_iso : Module.Finite K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype) :=
+    Module.Finite.equiv (eL.trans e2)
+  have hdim_iso : finrank K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype)
+      = finrank K (adeleBdd D₂ ⧸ B) :=
+    (LinearEquiv.finrank_eq (eL.trans e2)).symm
+  have hcast : (finrank K (adeleBdd D₂ ⧸ A) : ℤ)
+      = (finrank K (adeleBdd D₂ ⧸ B) : ℤ) + ((ell D₂ : ℤ) - (ell D₁ : ℤ)) := by
+    have hb : (ell D₂ : ℤ)
+        = (finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) : ℤ) + (ell D₁ : ℤ) := by
+      exact_mod_cast hdimB
+    push_cast [hdim2]; linarith
+  have hgoal : (finrank K (adeleBdd D₂ ⧸ B) : ℤ)
+      = Divisor.degree D₂ - ↑(ell D₂) - (Divisor.degree D₁ - ↑(ell D₁)) := by
+    linarith [hdimA, hcast]
+  clear_value eL
+  exact hsup ▸ ⟨hfin_iso, by rw [hdim_iso]; exact hgoal⟩
+
+section Index
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+
+theorem adeleBddSup_eq_of_degree_sub_ell_eq {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)]
+    (heq : Divisor.degree D₂ - ell D₂ = Divisor.degree D₁ - ell D₁) :
+    adeleBdd D₂ ⊔ globalSub K F = adeleBdd D₁ ⊔ globalSub K F := by
+  obtain ⟨hfin, hdim⟩ := finrank_adeleBddSup_quotient hD
+  rw [heq, sub_self] at hdim
+  refine le_antisymm ?_ (sup_le_sup_right (adeleBdd_mono hD) _)
+  have := hfin
+  have hd0 : finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) = 0 := by
+    exact_mod_cast hdim
+  have hsub : Subsingleton (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) :=
+    Module.finrank_zero_iff.mp hd0
+  have htop := Submodule.Quotient.subsingleton_iff.mp hsub
+  intro x hx
+  have hxc : (⟨x, hx⟩ : ↥(adeleBdd D₂ ⊔ globalSub K F)) ∈
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype := by
+    rw [htop]; exact Submodule.mem_top
+  exact hxc
+
+end Index
+
+namespace RiemannGenusReachedAt
+p2m_export "AlgebraicCurve.RiemannGenusReachedAt" "finite mk eq isMax"
+end RiemannGenusReachedAt
+namespace RiemannGenusReachedAt
+p2m_open_scoped "AlgebraicCurve.RiemannGenusReachedAt" in
+private theorem _root_.AlgebraicCurve.RiemannGenusReachedAt.eq_of_ge [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {D : Divisor K F} (hD : D₀ ≤ D) :
+    Divisor.degree D - ell D = γ - 1 := by
+  have := finiteDimensional_lSpace (K := K) D
+  have hge : Divisor.degree D₀ - (ell D₀ : ℤ) ≤ Divisor.degree D - ell D := by
+    have := ell_sub_ell_le_degree_sub_degree (K := K) hD
+    linarith
+  exact le_antisymm (h.isMax D) (h.eq ▸ hge)
+
+end RiemannGenusReachedAt
+p2m_export "AlgebraicCurve" "RiemannGenusReachedAt.eq_of_ge"
+
+theorem adeleSpace_eq_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    adeleSpace K F = adeleBdd D₀ ⊔ globalSub K F := by
+  refine le_antisymm ?_ (adeleBdd_sup_globalSub_le_adeleSpace D₀)
+  rw [adeleSpace, iSup_le_iff]
+  intro D
+  refine le_trans (adeleBdd_mono (le_sup_left : D ≤ D ⊔ D₀)) ?_
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have heq : Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) = Divisor.degree D₀ - ell D₀ :=
+    (h.eq_of_ge le_sup_right).trans h.eq.symm
+  have hsup := adeleBddSup_eq_of_degree_sub_ell_eq (K := K)
+    (le_sup_right : D₀ ≤ D ⊔ D₀) heq
+  rw [← hsup]
+  exact le_sup_left
+
+theorem indexOfSpecialty_eq_zero_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    indexOfSpecialty D₀ = 0 := by
+  rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap, ← adeleSpace_eq_of_genusReached h,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.finrank_zero_of_subsingleton
+
+
+
+theorem gate_indexOfSpecialty_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  have h1 := (indexOfSpecialty_eq_of_genusReached h D₀).2
+  have h2 := h.eq
+  have h3 := indexOfSpecialty_eq_zero_of_genusReached h
+  exact_mod_cast h3
+
+theorem gate_riemannInequality_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Divisor.degree D + 1 - γ ≤ (ell D : ℤ) := by
+  have heq := (indexOfSpecialty_eq_of_genusReached h D).2
+  have hnn : (0 : ℤ) ≤ indexOfSpecialty D := Int.natCast_nonneg _
+  linarith
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem adeleSpaceMul_add [HasPrincipalDivisors K F] (f g : F) :
+    adeleSpaceMul K F (f + g) = adeleSpaceMul K F f + adeleSpaceMul K F g := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, LinearMap.add_apply, Submodule.coe_add,
+    Pi.add_apply, add_mul]
+
+theorem adeleSpaceMul_zero [HasPrincipalDivisors K F] :
+    adeleSpaceMul K F (0 : F) = 0 := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, zero_mul, LinearMap.zero_apply,
+    Submodule.coe_zero, Pi.zero_apply]
+
+theorem weilSmul_add_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f + g) φ = weilSmul K F f φ + weilSmul K F g φ := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_add, LinearMap.add_apply, map_add]
+
+theorem weilSmul_zero_left [HasPrincipalDivisors K F]
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (0 : F) φ = 0 := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_zero, LinearMap.zero_apply, map_zero]
+
+theorem weilSmul_neg_left [HasPrincipalDivisors K F] (f : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (-f) φ = -weilSmul K F f φ := by
+  have h := weilSmul_add_left (K := K) (F := F) f (-f) φ
+  rw [add_neg_cancel, weilSmul_zero_left] at h
+  exact (neg_eq_of_add_eq_zero_right h.symm).symm
+
+theorem weilSmul_sub_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f - g) φ = weilSmul K F f φ - weilSmul K F g φ := by
+  rw [sub_eq_add_neg, weilSmul_add_left, weilSmul_neg_left, sub_eq_add_neg]
+
+theorem weilSmul_eq_zero_iff_left [HasPrincipalDivisors K F]
+    {f : F} {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    weilSmul K F f φ = 0 ↔ f = 0 := by
+  refine ⟨fun h => ?_, fun h => h ▸ weilSmul_zero_left φ⟩
+  by_contra hf
+  exact hφ (weilSmul_injective hf (h.trans (map_zero (weilSmul K F f)).symm))
+
+theorem weilSmul_left_injective [HasPrincipalDivisors K F]
+    {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    Function.Injective (fun f : F => weilSmul K F f φ) := by
+  intro f g hfg
+  have hsub : weilSmul K F (f - g) φ = 0 := by
+    rw [weilSmul_sub_left, sub_eq_zero]; exact hfg
+  exact sub_eq_zero.mp ((weilSmul_eq_zero_iff_left hφ).mp hsub)
+
+variable (K F) in
+def doubleResiduePairing [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) :
+    LSpace (W - D) × LSpace (W - D) →ₗ[K] omegaSpace D :=
+  (residuePairing K F W D hφ).coprod (residuePairing K F W D hμ)
+
+theorem doubleResiduePairing_apply_coe [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (g h : LSpace (W - D)) :
+    (doubleResiduePairing K F W D hφ hμ (g, h) : Module.Dual K (adeleSpace K F))
+      = weilSmul K F (g : F) φ + weilSmul K F (h : F) μ := by
+  simp only [doubleResiduePairing, LinearMap.coprod_apply, Submodule.coe_add,
+    residuePairing_apply_coe]
+
+theorem doubleResiduePairing_injective [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ) :
+    Function.Injective (doubleResiduePairing K F W D hφ hμ) := by
+  rw [injective_iff_map_eq_zero]
+  rintro ⟨g, h⟩ heq
+  have heq' : weilSmul K F (g : F) φ + weilSmul K F (h : F) μ = 0 := by
+    have hcoe := congrArg Subtype.val heq
+    rwa [doubleResiduePairing_apply_coe, Submodule.coe_zero] at hcoe
+  rcases eq_or_ne (h : F) 0 with hh0 | hh0
+  · rw [hh0, weilSmul_zero_left, add_zero] at heq'
+    have hg0 : (g : F) = 0 := (weilSmul_eq_zero_iff_left hφ0).mp heq'
+    exact Prod.ext (Subtype.ext hg0) (Subtype.ext hh0)
+  · exfalso
+    have hμeq : weilSmul K F (h : F) μ = -weilSmul K F (g : F) φ := by
+      have h2 : weilSmul K F (h : F) μ + weilSmul K F (g : F) φ = 0 := by
+        rw [add_comm]; exact heq'
+      exact eq_neg_of_add_eq_zero_left h2
+    have hLHS : weilSmul K F (h : F)⁻¹ (weilSmul K F (h : F) μ) = μ := by
+      rw [← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hh0, weilSmul_one,
+        LinearMap.id_apply]
+    have hRHS : weilSmul K F (h : F)⁻¹ (-weilSmul K F (g : F) φ)
+        = weilSmul K F (-(g : F) * (h : F)⁻¹) φ := by
+      rw [map_neg, ← LinearMap.comp_apply, ← weilSmul_mul, neg_mul, weilSmul_neg_left]
+    exact hindep (-(g : F) * (h : F)⁻¹) (by rw [← hLHS, hμeq, hRHS])
+
+theorem two_mul_ell_le_indexOfSpecialty [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ)
+    [Module.Finite K (omegaSpace (K := K) (F := F) D)]
+    [Module.Finite K (LSpace (K := K) (F := F) (W - D))] :
+    2 * ell (W - D) ≤ indexOfSpecialty D := by
+  have hinj := doubleResiduePairing_injective W D hφ hμ hφ0 hindep
+  have hle := LinearMap.finrank_le_finrank_of_injective hinj
+  rw [Module.finrank_prod] at hle
+  rw [← finrank_omegaSpace_eq_indexOfSpecialty, two_mul]
+  exact hle
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+section Finiteness
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+theorem omegaSpace_finite_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Module.Finite K (omegaSpace (K := K) (F := F) D) := by
+  have := (indexOfSpecialty_eq_of_genusReached h D).1
+  exact Module.Finite.equiv (omegaSpaceEquivIndexDual D).symm
+
+end Finiteness
+
+section ParametricRankOne
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+
+theorem exists_weilSmul_eq_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {φ μ : Module.Dual K (adeleSpace K F)} {W : Divisor K F}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (hφ0 : φ ≠ 0) :
+    ∃ f : F, μ = weilSmul K F f φ := by
+  by_contra hcon
+  push Not at hcon
+  obtain ⟨P⟩ := ‹Nonempty (Place K F)›
+  set n : ℕ := 3 * γ.natAbs + 2 * (Divisor.degree W).natAbs + 4 with hn
+  set D : Divisor K F := -Finsupp.single P (n : ℤ) with hD
+  have hdegD : Divisor.degree D = -(n : ℤ) * (P.deg : ℤ) := by
+    rw [hD, map_neg, Divisor.degree_single]; ring
+  have hdegWD : Divisor.degree (W - D) = Divisor.degree W + (n : ℤ) * (P.deg : ℤ) := by
+    rw [map_sub, hdegD]; ring
+  have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+  have habsγ : -(|γ|) ≤ γ ∧ γ ≤ |γ| := ⟨neg_abs_le _, le_abs_self _⟩
+  have habsW : -|Divisor.degree W| ≤ Divisor.degree W ∧
+      Divisor.degree W ≤ |Divisor.degree W| := ⟨neg_abs_le _, le_abs_self _⟩
+  have hn_ge : 3 * |γ| + 2 * |Divisor.degree W| + 4 ≤ (n : ℤ) := by
+    rw [hn]; push_cast [Int.natCast_natAbs]; ring_nf; omega
+  have hndegP : (n : ℤ) ≤ (n : ℤ) * (P.deg : ℤ) := by nlinarith [Int.natCast_nonneg n]
+  have hellD : ell D = 0 := ell_eq_zero_of_degree_neg (by rw [hdegD]; nlinarith)
+  have hiD : (indexOfSpecialty D : ℤ) = (n : ℤ) * (P.deg : ℤ) - 1 + γ := by
+    have hidx := (indexOfSpecialty_eq_of_genusReached h D).2
+    rw [hellD, hdegD] at hidx; push_cast at hidx; linarith
+  have hlowerWD : Divisor.degree W + (n : ℤ) * (P.deg : ℤ) + 1 - γ
+      ≤ (ell (W - D) : ℤ) := by
+    have hlow := gate_riemannInequality_of_genusReached h (W - D)
+    rw [hdegWD] at hlow; exact hlow
+  have := omegaSpace_finite_of_genusReached h D
+  have := finiteDimensional_lSpace (K := K) (W - D)
+  have hdbl : (2 * ell (W - D) : ℤ) ≤ (indexOfSpecialty D : ℤ) := by
+    exact_mod_cast two_mul_ell_le_indexOfSpecialty W D hφ hμ hφ0 hcon
+  rw [hiD] at hdbl
+  nlinarith [habsγ.1, habsγ.2, habsW.1, habsW.2]
+
+theorem weilDifferentialRankOne_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    WeilDifferentialRankOne K F := by
+  intro φ hφmem hφ0 μ hμmem
+  obtain ⟨W₁, hφW₁⟩ := mem_weilDifferentialModule_iff.mp hφmem
+  obtain ⟨W₂, hμW₂⟩ := mem_weilDifferentialModule_iff.mp hμmem
+  have hφW : φ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_left hφW₁
+  have hμW : μ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_right hμW₂
+  obtain ⟨f, hf⟩ := exists_weilSmul_eq_of_genusReached h hφW hμW hφ0
+  exact ⟨f, hf, fun f' hf' => weilSmul_left_injective hφ0 (hf'.symm.trans hf)⟩
+
+end ParametricRankOne
+
+theorem residuePairing_surjective_of_rankOne_max [HasPrincipalDivisors K F]
+    (hRankOne : WeilDifferentialRankOne K F)
+    {W : Divisor K F} {φ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hφ0 : φ ≠ 0)
+    (hWmax : ∀ E : Divisor K F, φ ∈ omegaSpace E → E ≤ W) (D : Divisor K F) :
+    Function.Surjective (residuePairing K F W D hφ) := by
+  rintro ⟨μ, hμD⟩
+  have hφmem : φ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule W hφ
+  have hμmem : μ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule D hμD
+  obtain ⟨f, hf, -⟩ := hRankOne hφmem hφ0 hμmem
+  rcases eq_or_ne f 0 with rfl | hf0
+  · have hμ0 : (⟨μ, hμD⟩ : omegaSpace D) = 0 :=
+      Subtype.ext (hf.trans (weilSmul_zero_left φ))
+    exact ⟨0, (map_zero _).trans hμ0.symm⟩
+  · obtain ⟨P, hPord, _⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+    have hPinv : ∀ v, (-P) v = v.ord f⁻¹ := fun v => by
+      rw [Finsupp.neg_apply, hPord v, v.ord_inv]
+    have hinv : weilSmul K F f⁻¹ μ = φ := by
+      rw [hf, ← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hf0, weilSmul_one,
+        LinearMap.id_apply]
+    have hφD : φ ∈ omegaSpace (D + -P) := by
+      rw [← hinv]; exact weilSmul_mem_omegaSpace_add (inv_ne_zero hf0) hPinv hμD
+    have hDP : D + -P ≤ W := hWmax _ hφD
+    have hfL : f ∈ LSpace (W - D) := by
+      rw [mem_lSpace_iff_ord]; refine Or.inr fun v => ?_
+      have hv := hDP v
+      rw [Finsupp.add_apply, Finsupp.neg_apply, hPord v] at hv
+      rw [Finsupp.sub_apply]; linarith
+    exact ⟨⟨f, hfL⟩, Subtype.ext hf.symm⟩
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem exists_riemannGenusReachedAt_of_bounded
+    [IsCurveOver K F] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    ∃ (γ : ℤ) (D₀ : Divisor K F), RiemannGenusReachedAt γ D₀ := by
+  obtain ⟨γ, hγ⟩ := hbdd
+  obtain ⟨M, ⟨D₀, hD₀⟩, hMmax⟩ :=
+    Int.exists_greatest_of_bdd
+      (P := fun n => ∃ D : Divisor K F, Divisor.degree D - ell D = n)
+      ⟨γ, fun n ⟨D, hD⟩ => hD ▸ hγ D⟩
+      ⟨Divisor.degree (0 : Divisor K F) - ell (0 : Divisor K F), 0, rfl⟩
+  refine ⟨M + 1, D₀, ?_, ?_, ?_⟩
+  · exact finiteDimensional_lSpace D₀
+  · rw [hD₀]; ring
+  · intro D
+    have := hMmax (Divisor.degree D - ell D) ⟨D, rfl⟩
+    linarith
+
+theorem stichtenothGenusExists_of_bounded
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hbdd : RiemannGenusBounded K F) :
+    StichtenothGenusExists K F :=
+  ⟨‹_›, ‹_›, exists_riemannGenusReachedAt_of_bounded hbdd⟩
+
+
+theorem indexOfSpecialty_sub_of_ge [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₀ D : Divisor K F} (hD : D₀ ≤ D)
+    [FiniteDimensional K (LSpace D)]
+    [hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀)] :
+    Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D) ∧
+      (Divisor.degree D - ell D) - (Divisor.degree D₀ - ell D₀)
+        = (indexOfSpecialty D₀ : ℤ) - (indexOfSpecialty D : ℤ) := by
+  have hABsub : adeleBdd D₀ ⊔ globalSub K F ≤ adeleBdd D ⊔ globalSub K F :=
+    sup_le_sup_right (adeleBdd_mono hD) _
+  have hBCsub : adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+    adeleBdd_sup_globalSub_le_adeleSpace _
+  obtain ⟨hfinBA, hdimBA⟩ := finrank_adeleBddSup_quotient (K := K) hD
+  have := hfinBA
+  have hfinCA : Module.Finite K (adeleSpace K F ⧸
+      (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [← adeleBddPrincipal_eq_comap]; exact hfin
+  obtain ⟨hfinCB, hdimCB⟩ := Submodule.finrank_quotient_chain'
+    (A := adeleBdd D₀ ⊔ globalSub K F) (B := adeleBdd D ⊔ globalSub K F)
+    (C := adeleSpace K F) hABsub hBCsub
+  have hi0 : indexOfSpecialty D₀
+      = finrank K (adeleSpace K F ⧸
+        (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap]
+  have hiD : indexOfSpecialty D
+      = finrank K (adeleSpace K F ⧸
+        (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype) := by
+    rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap]
+  have := hfinCB
+  obtain ⟨_, hdimCA⟩ := Submodule.finrank_quotient_chain
+    (A := adeleBdd D₀ ⊔ globalSub K F) (B := adeleBdd D ⊔ globalSub K F)
+    (C := adeleSpace K F) hABsub hBCsub
+  refine ⟨?_, ?_⟩
+  · rw [show adeleBddPrincipal K F D
+        = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype
+      from adeleBddPrincipal_eq_comap D]
+    exact hfinCB
+  · have hcast : (indexOfSpecialty D₀ : ℤ)
+        = (indexOfSpecialty D : ℤ)
+          + (finrank K (↥(adeleBdd D ⊔ globalSub K F)
+              ⧸ (adeleBdd D₀ ⊔ globalSub K F).comap
+                (adeleBdd D ⊔ globalSub K F).subtype) : ℤ) := by
+      rw [hiD, hi0]; exact_mod_cast hdimCA
+    linarith [hdimBA, hcast]
+
+theorem degreeSub_ell_le_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {D₀ : Divisor K F}
+    (hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀))
+    (D : Divisor K F) :
+    Divisor.degree D - ell D ≤ (Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀ := by
+  have := hfin
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have hmono : Divisor.degree D - (ell D : ℤ)
+      ≤ Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) (le_sup_left : D ≤ D ⊔ D₀)
+    linarith
+  obtain ⟨_, heq⟩ :=
+    indexOfSpecialty_sub_of_ge (K := K) (le_sup_right : D₀ ≤ D ⊔ D₀)
+  have hi0 : (0 : ℤ) ≤ indexOfSpecialty (D ⊔ D₀) := Int.natCast_nonneg _
+  linarith
+
+theorem riemannGenusBounded_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hfin : IndexOfSpecialtyFinite K F) :
+    RiemannGenusBounded K F := by
+  obtain ⟨D₀, hD₀⟩ := hfin
+  exact ⟨(Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀,
+    degreeSub_ell_le_of_indexFinite hD₀⟩
+
+theorem stichtenothGenusExists_of_indexFinite
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (hfin : IndexOfSpecialtyFinite K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_bounded (riemannGenusBounded_of_indexFinite hfin)
+
+theorem indexOfSpecialtyFinite_of_stichtenothGenusExists
+    [IsCurveOver K F] (hSG : StichtenothGenusExists K F) :
+    IndexOfSpecialtyFinite K F := by
+  obtain ⟨hne, hL0, γ, D₀, hD₀⟩ := hSG
+  have := hne; have := hL0
+  refine ⟨D₀, ?_⟩
+  rw [show adeleBddPrincipal K F D₀
+      = (adeleBdd D₀ ⊔ globalSub K F).comap (adeleSpace K F).subtype
+    from adeleBddPrincipal_eq_comap D₀, ← adeleSpace_eq_of_genusReached hD₀,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.Finite.of_finite
+
+theorem stichtenothGenusExists_iff_indexFinite
+    [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] :
+    StichtenothGenusExists K F ↔ IndexOfSpecialtyFinite K F :=
+  ⟨indexOfSpecialtyFinite_of_stichtenothGenusExists,
+    stichtenothGenusExists_of_indexFinite⟩
+
+theorem gate_indexOfSpecialty_engine_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  exact_mod_cast indexOfSpecialty_eq_zero_of_genusReached h
+
+theorem gate_stichtenothGenus_le_of_indexFinite [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {D₀ : Divisor K F}
+    (hfin : Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F D₀))
+    {γ : ℤ} {D₁ : Divisor K F} (h : RiemannGenusReachedAt γ D₁) :
+    γ - 1 ≤ (Divisor.degree D₀ - ell D₀) + indexOfSpecialty D₀ := by
+  have := degreeSub_ell_le_of_indexFinite hfin D₁
+  rw [h.eq] at this; exact this
+
+theorem gate_riemannGenusBounded_of_reachedAt
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    RiemannGenusBounded K F :=
+  ⟨γ - 1, h.isMax⟩
+
+theorem gate_indexOfSpecialtyFinite_at_zero [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    Module.Finite K (adeleSpace K F ⧸ adeleBddPrincipal K F (0 : Divisor K F)) :=
+  (indexOfSpecialty_eq_of_genusReached h 0).1
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem mul_mem_lSpace_add {D E : Divisor K F} {f g : F}
+    (hf : f ∈ LSpace D) (hg : g ∈ LSpace E) :
+    f * g ∈ LSpace (D + E) := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · rw [zero_mul]; exact (LSpace _).zero_mem
+  rcases eq_or_ne g 0 with rfl | hg0
+  · rw [mul_zero]; exact (LSpace _).zero_mem
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun v => ?_
+  rw [Finsupp.add_apply, neg_add, v.ord_mul hf0 hg0]
+  exact add_le_add ((mem_lSpace_iff_ord.mp hf).resolve_left hf0 v)
+    ((mem_lSpace_iff_ord.mp hg).resolve_left hg0 v)
+
+theorem pow_mem_lSpace_nsmul {B : Divisor K F} {f : F} (hf : f ∈ LSpace B) (j : ℕ) :
+    f ^ j ∈ LSpace (j • B) := by
+  induction j with
+  | zero => simpa using one_mem_lSpace_zero (K := K) (F := F)
+  | succ j ih =>
+    rw [pow_succ, succ_nsmul]
+    exact mul_mem_lSpace_add ih hf
+
+namespace PoleDivisorPackage
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degB_eq u B hB_eff n lin_indep mk c x hn_pos \
+  hu_mem mk.injEq hx_mem"
+p2m_open "AlgebraicCurve.PoleDivisorPackage"
+
+variable (P : PoleDivisorPackage K F)
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.pow_mul_u_mem_lSpace (j : ℕ) (i : Fin P.n)
+    :
+    P.x ^ j * P.u i ∈ LSpace ((j + P.c) • P.B) := by
+  rw [add_nsmul]
+  exact mul_mem_lSpace_add (pow_mem_lSpace_nsmul P.hx_mem j) (P.hu_mem i)
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "pow_mul_u_mem_lSpace"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.pow_mul_u_mem_lSpace_of_le {j m : ℕ}
+    (hjm : j + P.c ≤ m) (i : Fin P.n) :
+    P.x ^ j * P.u i ∈ LSpace (m • P.B) := by
+  refine lSpace_mono ?_ (P.pow_mul_u_mem_lSpace j i)
+  intro v
+  have hBv : (0 : ℤ) ≤ P.B v := P.hB_eff v
+  change ((j + P.c) • P.B) v ≤ (m • P.B) v
+  simp only [Finsupp.smul_apply, nsmul_eq_mul]
+  exact mul_le_mul_of_nonneg_right (by exact_mod_cast hjm) hBv
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "pow_mul_u_mem_lSpace_of_le"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.ell_nsmul_poleDivisor_ge [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    (P.n : ℤ) * (m - P.c + 1) ≤ ell (m • P.B) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  set g : Fin (m - P.c + 1) × Fin P.n → LSpace (m • P.B) :=
+    fun p => ⟨P.x ^ (p.1 : ℕ) * P.u p.2,
+      P.pow_mul_u_mem_lSpace_of_le (by have := p.1.isLt; omega) p.2⟩
+    with hgdef
+  have hsub : LinearIndependent K (fun p => (g p : F)) := by
+    have heq : (fun p => (g p : F))
+        = (fun p : ℕ × Fin P.n => P.x ^ p.1 * P.u p.2)
+            ∘ (fun p : Fin (m - P.c + 1) × Fin P.n => ((p.1 : ℕ), p.2)) := by
+      funext p; rfl
+    rw [heq]
+    refine P.lin_indep.comp _ ?_
+    intro p q hpq
+    simp only [Prod.mk.injEq] at hpq
+    exact Prod.ext (Fin.val_injective hpq.1) hpq.2
+  have hg : LinearIndependent K g := hsub.of_comp (LSpace (m • P.B)).subtype
+  have hcard := hg.fintype_card_le_finrank
+  rw [Fintype.card_prod, Fintype.card_fin, Fintype.card_fin] at hcard
+  have hZ : ((m - P.c + 1) * P.n : ℤ) ≤ (ell (m • P.B) : ℤ) := by exact_mod_cast hcard
+  have heq : (((m - P.c + 1 : ℕ) : ℤ) * P.n : ℤ) = (P.n : ℤ) * ((m : ℤ) - P.c + 1) := by
+    rw [Nat.cast_add, Nat.cast_sub hm, Nat.cast_one]; ring
+  linarith
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "ell_nsmul_poleDivisor_ge"
+
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.degree_nsmul_sub_ell_le [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))] {m : ℕ} (hm : P.c ≤ m) :
+    Divisor.degree (m • P.B) - ell (m • P.B) ≤ (P.n : ℤ) * (P.c - 1) := by
+  have hge := P.ell_nsmul_poleDivisor_ge hm
+  have hdeg : Divisor.degree (m • P.B) = (m : ℤ) * P.n := by
+    rw [show m • P.B = (m : ℤ) • P.B from (natCast_zsmul _ _).symm,
+      Divisor.degree.map_zsmul, smul_eq_mul, P.degB_eq]
+  linarith
+
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degree_nsmul_sub_ell_le"
+end PoleDivisorPackage
+
+namespace PoleDivisorPackage
+p2m_export "AlgebraicCurve.PoleDivisorPackage" "degB_eq u B hB_eff n lin_indep mk c x hn_pos \
+  hu_mem mk.injEq hx_mem"
+end PoleDivisorPackage
+namespace PoleDivisorPackage
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.ell_nsmul_sub_pos [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) {A : Divisor K F} (hA : 0 ≤ A) {m : ℕ} (hm : P.c ≤ m)
+    (hbig : Divisor.degree A < (P.n : ℤ) * (m - P.c + 1)) :
+    0 < ell (m • P.B - A) := by
+  have := finiteDimensional_lSpace (K := K) (m • P.B)
+  have hle : m • P.B - A ≤ m • P.B := by
+    intro v
+    have hAv : (0 : ℤ) ≤ A v := hA v
+    rw [Finsupp.sub_apply]
+    linarith
+  have h48 := ell_sub_ell_le_degree_sub_degree (K := K) hle
+  rw [map_sub, sub_sub_cancel] at h48
+  have h412 := P.ell_nsmul_poleDivisor_ge hm
+  have : (0 : ℤ) < (ell (m • P.B - A) : ℤ) := by linarith
+  exact_mod_cast this
+
+end PoleDivisorPackage
+p2m_export "AlgebraicCurve" "PoleDivisorPackage.ell_nsmul_sub_pos"
+namespace PoleDivisorPackage
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+private theorem _root_.AlgebraicCurve.PoleDivisorPackage.degree_sub_ell_le [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) (D : Divisor K F) :
+    Divisor.degree D - ell D ≤ (P.n : ℤ) * (P.c - 1) := by
+  classical
+  set D' : Divisor K F := D ⊔ 0 with hD'def
+  have hD'eff : 0 ≤ D' := le_sup_right
+  have hDD' : D ≤ D' := le_sup_left
+  have := finiteDimensional_lSpace (K := K) D'
+  have hmono : Divisor.degree D - (ell D : ℤ) ≤ Divisor.degree D' - ell D' := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hDD'
+    linarith
+  set m : ℕ := P.c + (Divisor.degree D').toNat with hmdef
+  have hcm : P.c ≤ m := Nat.le_add_right _ _
+  have hdegD' : 0 ≤ Divisor.degree D' := Divisor.degree_nonneg_of_nonneg hD'eff
+  have hbig : Divisor.degree D' < (P.n : ℤ) * (m - P.c + 1) := by
+    have hcast : ((m : ℤ) - P.c) = Divisor.degree D' := by
+      simp only [hmdef, Nat.cast_add, add_sub_cancel_left, Int.toNat_of_nonneg hdegD']
+    rw [hcast]
+    have hn1 : (1 : ℤ) ≤ P.n := by exact_mod_cast P.hn_pos
+    nlinarith
+  have hellpos := P.ell_nsmul_sub_pos hD'eff hcm hbig
+  have hnebot : LSpace (m • P.B - D') ≠ ⊥ :=
+    fun h => by rw [ell, h, finrank_bot] at hellpos; exact lt_irrefl 0 hellpos
+  obtain ⟨z, hzL, hz0⟩ := (Submodule.ne_bot_iff _).mp hnebot
+  obtain ⟨Dz, hDzord, hDzdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) z hz0
+  have hzmem := (mem_lSpace_iff_ord.mp hzL).resolve_left hz0
+  have hD'le : D' ≤ m • P.B + Dz := by
+    intro v
+    have := hzmem v
+    simp only [Finsupp.add_apply, Finsupp.sub_apply, neg_sub] at this ⊢
+    rw [hDzord]; linarith
+  have hellshift : ell (m • P.B + Dz) = ell (m • P.B) :=
+    (LinearEquiv.finrank_eq (lSpaceShiftEquiv (m • P.B) hz0 hDzord)).symm
+  have hdegshift : Divisor.degree (m • P.B + Dz) = Divisor.degree (m • P.B) := by
+    rw [map_add, hDzdeg, add_zero]
+  have := finiteDimensional_lSpace (K := K) (m • P.B + Dz)
+  have hmono' : Divisor.degree D' - (ell D' : ℤ)
+      ≤ Divisor.degree (m • P.B + Dz) - ell (m • P.B + Dz) := by
+    have h := ell_sub_ell_le_degree_sub_degree (K := K) hD'le
+    linarith
+  rw [hellshift, hdegshift] at hmono'
+  have h412 := P.degree_nsmul_sub_ell_le hcm
+  linarith
+
+end PoleDivisorPackage
+p2m_export "AlgebraicCurve" "PoleDivisorPackage.degree_sub_ell_le"
+
+theorem riemannGenusBounded_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    RiemannGenusBounded K F :=
+  ⟨(P.n : ℤ) * (P.c - 1), P.degree_sub_ell_le⟩
+
+theorem stichtenothGenusExists_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_bounded (riemannGenusBounded_of_poleDivisorPackage P)
+
+theorem indexOfSpecialtyFinite_of_poleDivisorPackage [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_stichtenothGenusExists
+    (stichtenothGenusExists_of_poleDivisorPackage P)
+
+theorem indexOfSpecialtyFinite_of_hasPoleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (h : HasPoleDivisorPackage K F) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_poleDivisorPackage h.some
+
+theorem stichtenothGenusExists_of_hasPoleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (h : HasPoleDivisorPackage K F) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_poleDivisorPackage h.some
+
+theorem gate_stichtenothGenus_le_of_poleDivisorPackage [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F)
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    γ ≤ (P.n : ℤ) * (P.c - 1) + 1 := by
+  have := P.degree_sub_ell_le D₀
+  rw [h.eq] at this; linarith
+
+theorem gate_ell_c_nsmul_ge [IsCurveOver K F]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (P : PoleDivisorPackage K F) :
+    (P.n : ℤ) ≤ ell (P.c • P.B) := by
+  have h := P.ell_nsmul_poleDivisor_ge (le_refl P.c)
+  simp only [sub_self, zero_add, mul_one] at h
+  exact h
+
+theorem gate_x_transcendental_of_poleDivisorPackage (P : PoleDivisorPackage K F) :
+    LinearIndependent K (fun j : ℕ => P.x ^ j * P.u ⟨0, P.hn_pos⟩) := by
+  refine P.lin_indep.comp (fun j => (j, ⟨0, P.hn_pos⟩)) ?_
+  intro a b hab
+  exact (Prod.mk.injEq .. ▸ hab).1
+
+theorem gate_u_linearIndependent_of_poleDivisorPackage (P : PoleDivisorPackage K F) :
+    LinearIndependent K P.u := by
+  have h : LinearIndependent K (fun i : Fin P.n => P.x ^ (0 : ℕ) * P.u i) := by
+    refine P.lin_indep.comp (fun i => (0, i)) ?_
+    intro a b hab
+    exact (Prod.mk.injEq .. ▸ hab).2
+  simpa using h
+
+end AlgebraicCurve
+
+end
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+scoped instance instSumRamificationInertia_port {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F']
+    [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+    [HasPrincipalDivisors K F'] : SumRamificationInertia K F F' :=
+  ⟨fun v => Place.sum_ramificationIndex_mul_inertiaDeg v⟩
+end AlgebraicCurve
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+
+namespace TranscendenceTower
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF poleDivisor RegularOutside hx_indep hxreg v \
+  mk.injEq mk hvdeg x hxv"
+p2m_open "AlgebraicCurve.TranscendenceTower"
+
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F]
+variable (T : TranscendenceTower K E F)
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.x_ne_zero : T.x ≠ 0 := fun h => by
+  have := T.hxv; rw [h, Place.ord_zero] at this; exact absurd this (by decide)
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "x_ne_zero"
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+theorem xF_ne_zero : T.xF ≠ 0 :=
+  fun h => T.x_ne_zero ((algebraMap E F).injective (by rwa [map_zero]))
+
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.poleDivisor_apply (w : Place K F) :
+    T.poleDivisor w = (w.ramificationIndex E : ℤ) * (Finsupp.single T.v 1) (w.restrict E) :=
+  Divisor.pullback_apply (Finsupp.single T.v 1) w
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "poleDivisor_apply"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.poleDivisor_nonneg :
+    0 ≤ T.poleDivisor := by
+  classical
+  intro w
+  rw [Finsupp.coe_zero, Pi.zero_apply, T.poleDivisor_apply, Finsupp.single_apply]
+  refine mul_nonneg (Int.natCast_nonneg _) ?_
+  split_ifs <;> simp
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "poleDivisor_nonneg"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.xF_mem_lSpace_poleDivisor :
+    T.xF ∈ LSpace T.poleDivisor := by
+  classical
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun w => ?_
+  rw [T.poleDivisor_apply, Place.ord_restrict, Finsupp.single_apply]
+  rcases eq_or_ne (w.restrict E) T.v with hw | hw
+  · simp only [hw, T.hxv, ite_true, mul_one, mul_neg_one, le_refl]
+  · simp only [ite_eq_right (Ne.symm hw), mul_zero, neg_zero]
+    exact mul_nonneg (Int.natCast_nonneg _) (T.hxreg _ hw)
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF_mem_lSpace_poleDivisor"
+
+private theorem _root_.AlgebraicCurve.TranscendenceTower.degree_poleDivisor_eq_finrank :
+    Divisor.degree T.poleDivisor = (Module.finrank E F : ℤ) := by
+  rw [poleDivisor, Divisor.degree_pullback, Divisor.degree_single, T.hvdeg]
+  push_cast; ring
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "degree_poleDivisor_eq_finrank"
+omit [FiniteDimensional E F] in
+private theorem
+  _root_.AlgebraicCurve.TranscendenceTower.mem_lSpace_nsmul_poleDivisor_of_regular_outside {f : F}
+    (hreg : ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord f)
+    {c : ℕ} (hc : ∀ w ∈ T.v.fiber F, -(c : ℤ) ≤ w.ord f) :
+    f ∈ LSpace (c • T.poleDivisor) := by
+  classical
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact (LSpace _).zero_mem
+  rw [mem_lSpace_iff_ord]
+  refine Or.inr fun w => ?_
+  rw [Finsupp.smul_apply, T.poleDivisor_apply, Finsupp.single_apply, nsmul_eq_mul]
+  rcases eq_or_ne (w.restrict E) T.v with hw | hw
+  · simp only [hw, ite_true, mul_one]
+    have he : (1 : ℤ) ≤ w.ramificationIndex E := by
+      exact_mod_cast w.ramificationIndex_pos (F := E)
+    have hbdd := hc w (Place.mem_fiber.mpr hw)
+    nlinarith [Int.natCast_nonneg c]
+  · simp only [ite_eq_right (Ne.symm hw), mul_zero, neg_zero]
+    exact hreg w hw
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "mem_lSpace_nsmul_poleDivisor_of_regular_outside"
+omit [FiniteDimensional E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.exists_forall_mem_lSpace_nsmul_poleDivisor
+    {n : ℕ} (u : Fin n → F)
+    (hreg : ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)) :
+    ∃ c : ℕ, ∀ i, u i ∈ LSpace (c • T.poleDivisor) := by
+  classical
+  refine ⟨(Finset.univ : Finset (Fin n)).sup fun i =>
+    (T.v.fiber F).sup fun w => (-(w.ord (u i))).toNat,
+    fun i => T.mem_lSpace_nsmul_poleDivisor_of_regular_outside (hreg i) ?_⟩
+  intro w hw
+  have h1 : (-(w.ord (u i))).toNat
+      ≤ (T.v.fiber F).sup fun w' => (-(w'.ord (u i))).toNat :=
+    Finset.le_sup (f := fun w' => (-(w'.ord (u i))).toNat) hw
+  have h2 : ((T.v.fiber F).sup fun w' => (-(w'.ord (u i))).toNat)
+      ≤ (Finset.univ : Finset (Fin n)).sup fun i' =>
+          (T.v.fiber F).sup fun w' => (-(w'.ord (u i'))).toNat :=
+    Finset.le_sup (f := fun i' => (T.v.fiber F).sup fun w' => (-(w'.ord (u i'))).toNat)
+      (Finset.mem_univ i)
+  have htnat : -(w.ord (u i)) ≤ ((-(w.ord (u i))).toNat : ℤ) := Int.self_le_toNat _
+  omega
+
+p2m_export "AlgebraicCurve.TranscendenceTower" "exists_forall_mem_lSpace_nsmul_poleDivisor"
+end TranscendenceTower
+
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F]
+
+section PrincipalDivisors
+
+variable [HasPrincipalDivisors K F]
+
+namespace IntegralBasisInLSpace
+p2m_export "AlgebraicCurve.IntegralBasisInLSpace" "hu_indep c u mk.injEq hu_mem mk"
+end IntegralBasisInLSpace
+p2m_open_scoped "AlgebraicCurve.IntegralBasisInLSpace" in
+def IntegralBasisInLSpace.ofRegularOutside (T : TranscendenceTower K E F)
+    (u : Fin (Module.finrank E F) → F) (hu_indep : LinearIndependent E u)
+    (hreg : ∀ i, ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord (u i)) :
+    IntegralBasisInLSpace T where
+  c := (T.exists_forall_mem_lSpace_nsmul_poleDivisor u hreg).choose
+  u := u
+  hu_indep := hu_indep
+  hu_mem := (T.exists_forall_mem_lSpace_nsmul_poleDivisor u hreg).choose_spec
+
+omit [FiniteDimensional E F] in
+theorem hasIntegralBasisInLSpace_of_regularOutside (T : TranscendenceTower K E F)
+    (h : HasIntegralBasisRegularOutside K E F T) :
+    HasIntegralBasisInLSpace K E F T := by
+  obtain ⟨u, hu_indep, hreg⟩ := h
+  exact ⟨IntegralBasisInLSpace.ofRegularOutside T u hu_indep hreg⟩
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] [HasPrincipalDivisors K F] in
+theorem linearIndependent_pow_mul {x : E} {n : ℕ} {u : Fin n → F}
+    (hx : LinearIndependent K (fun j : ℕ => x ^ j)) (hu : LinearIndependent E u) :
+    LinearIndependent K (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2) := by
+  have heq : (fun p : ℕ × Fin n => (algebraMap E F x) ^ p.1 * u p.2)
+      = (fun p : ℕ × Fin n => (x ^ p.1) • u p.2) := by
+    funext p
+    rw [Algebra.smul_def, map_pow]
+  rw [heq]
+  exact linearIndependent_smul (R := K) (S := E) (A := F) hx hu
+
+p2m_open_scoped "AlgebraicCurve.PoleDivisorPackage" in
+def PoleDivisorPackage.ofTranscendenceTower (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    PoleDivisorPackage K F where
+  x := T.xF
+  B := T.poleDivisor
+  hB_eff := T.poleDivisor_nonneg
+  hx_mem := T.xF_mem_lSpace_poleDivisor
+  n := Module.finrank E F
+  hn_pos := Module.finrank_pos
+  degB_eq := T.degree_poleDivisor_eq_finrank
+  c := IB.c
+  u := IB.u
+  hu_mem := IB.hu_mem
+  lin_indep := linearIndependent_pow_mul T.hx_indep IB.hu_indep
+
+theorem hasPoleDivisorPackage_of_transcendenceTower
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    HasPoleDivisorPackage K F :=
+  ⟨PoleDivisorPackage.ofTranscendenceTower T IB⟩
+
+theorem hasPoleDivisorPackage_of_hasIntegralBasisInLSpace
+    (T : TranscendenceTower K E F) (h : HasIntegralBasisInLSpace K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_transcendenceTower T h.some
+
+theorem hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside
+    (T : TranscendenceTower K E F) (h : HasIntegralBasisRegularOutside K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisInLSpace T
+    (hasIntegralBasisInLSpace_of_regularOutside T h)
+
+end PrincipalDivisors
+
+theorem indexOfSpecialtyFinite_of_transcendenceTower [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    IndexOfSpecialtyFinite K F :=
+  indexOfSpecialtyFinite_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem stichtenothGenusExists_of_transcendenceTower [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem gate_ofTranscendenceTower_n_eq [HasPrincipalDivisors K F] (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    (PoleDivisorPackage.ofTranscendenceTower T IB).n = Module.finrank E F := rfl
+
+theorem gate_ofTranscendenceTower_B_eq [HasPrincipalDivisors K F] (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    (PoleDivisorPackage.ofTranscendenceTower T IB).B = T.poleDivisor := rfl
+
+theorem gate_ofTranscendenceTower_x_transcendental [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F)
+    (IB : IntegralBasisInLSpace T) :
+    LinearIndependent K
+      (fun j : ℕ => T.xF ^ j *
+        (PoleDivisorPackage.ofTranscendenceTower T IB).u ⟨0, Module.finrank_pos⟩) :=
+  gate_x_transcendental_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB)
+
+theorem gate_degree_pullback_single_of_deg_eq [HasPrincipalDivisors K F]
+    (v : Place K E) (d : ℕ) (hd : v.deg = d) :
+    Divisor.degree (Divisor.pullback F (Finsupp.single v (1 : ℤ)))
+      = (Module.finrank E F : ℤ) * d := by
+  rw [Divisor.degree_pullback, Divisor.degree_single, hd]; ring
+
+theorem gate_stichtenothGenus_le_of_transcendenceTower [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (IB : IntegralBasisInLSpace T)
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    γ ≤ (Module.finrank E F : ℤ) * (IB.c - 1) + 1 :=
+  gate_stichtenothGenus_le_of_poleDivisorPackage
+    (PoleDivisorPackage.ofTranscendenceTower T IB) h
+
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open Module
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~restrict_plac\
+  eOfPrime~placeOfPrime~comap_algebraMap_ne_top"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral {f : F}
+    (hf : IsIntegral w.toValuationSubring f) :
+    f ∈ w.toValuationSubring := by
+  obtain ⟨y, hy⟩ := IsIntegrallyClosed.isIntegral_iff.mp hf
+  exact hy ▸ y.2
+
+p2m_export "AlgebraicCurve.Place" "mem_of_isIntegral"
+
+theorem ord_nonneg_of_isIntegral {f : F} (hf : IsIntegral w.toValuationSubring f) :
+    0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral hf)
+
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral_of_algebraMap_mem {A : Type*}
+    [CommRing A] [Algebra A F]
+    (hA : ∀ a : A, algebraMap A F a ∈ w.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : f ∈ w.toValuationSubring := by
+  let : Algebra A w.toValuationSubring :=
+    ((algebraMap A F).codRestrict w.toValuationSubring.toSubring hA).toAlgebra
+  have : IsScalarTower A w.toValuationSubring F :=
+    IsScalarTower.of_algebraMap_eq fun a => rfl
+  exact w.mem_of_isIntegral hf.tower_top
+
+p2m_export "AlgebraicCurve.Place" "mem_of_isIntegral_of_algebraMap_mem"
+
+theorem ord_nonneg_of_isIntegral_of_algebraMap_mem {A : Type*} [CommRing A] [Algebra A F]
+    (hA : ∀ a : A, algebraMap A F a ∈ w.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : 0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral_of_algebraMap_mem hA hf)
+
+end Place
+
+section Bridge
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+variable {A : Type*} [CommRing A] [Algebra A E] [Algebra A F] [IsScalarTower A E F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_zero ord_mul ord_inv ord_coe_unit ord_coe_irreducible \
+  ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum mk.injEq algebraMap_mem' \
+  toValuationSubring mk ramificationIndex ramificationIndex_pos restrict mem_restrict_iff \
+  ord_restrict deg_restrict_mul_inertiaDeg fiber mem_fiber adicValuation_eq_exp_neg_ord \
+  sum_ramificationIndex_mul_inertiaDeg exists_restrict_eq"
+end Place
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.mem_of_isIntegral_of_restrict [Algebra.IsIntegral E F]
+    (w : Place K F)
+    {u : Place K E} (hw : w.restrict E = u)
+    (hA : ∀ a : A, algebraMap A E a ∈ u.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : f ∈ w.toValuationSubring := by
+  refine w.mem_of_isIntegral_of_algebraMap_mem (fun a => ?_) hf
+  rw [IsScalarTower.algebraMap_apply A E F, ← w.mem_restrict_iff, hw]
+  exact hA a
+
+end Place
+p2m_export "AlgebraicCurve" "Place.mem_of_isIntegral_of_restrict"
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.ord_nonneg_of_isIntegral_of_restrict
+    [Algebra.IsIntegral E F] (w : Place K F)
+    {u : Place K E} (hw : w.restrict E = u)
+    (hA : ∀ a : A, algebraMap A E a ∈ u.toValuationSubring)
+    {f : F} (hf : IsIntegral A f) : 0 ≤ w.ord f :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem w (w.mem_of_isIntegral_of_restrict hw hA hf)
+
+end Place
+p2m_export "AlgebraicCurve" "Place.ord_nonneg_of_isIntegral_of_restrict"
+namespace TranscendenceTower
+p2m_export "AlgebraicCurve.TranscendenceTower" "xF poleDivisor RegularOutside hx_indep hxreg v \
+  mk.injEq mk hvdeg x hxv"
+end TranscendenceTower
+namespace TranscendenceTower
+p2m_open_scoped "AlgebraicCurve.TranscendenceTower" in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.ord_nonneg_of_isIntegral_of_regularOutside
+    [Algebra.IsIntegral E F] (T : TranscendenceTower K E F) (hA : T.RegularOutside A)
+    {f : F} (hf : IsIntegral A f) :
+    ∀ w : Place K F, w.restrict E ≠ T.v → 0 ≤ w.ord f := fun w hw =>
+  w.ord_nonneg_of_isIntegral_of_restrict rfl (hA _ hw) hf
+
+end TranscendenceTower
+p2m_export "AlgebraicCurve" "TranscendenceTower.ord_nonneg_of_isIntegral_of_regularOutside"
+end Bridge
+
+section Headline
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+variable [FiniteDimensional E F] [Algebra.IsSeparable E F]
+
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+theorem linearIndependent_reindex_basis {s : Finset F} (b : Basis s E F) :
+    LinearIndependent E (fun i : Fin (Module.finrank E F) =>
+      b ((Fintype.equivFinOfCardEq (Module.finrank_eq_card_basis b).symm).symm i)) :=
+  b.linearIndependent.comp _ (Equiv.injective _)
+
+theorem hasIntegralBasisRegularOutside_of_isFractionRing
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    HasIntegralBasisRegularOutside K E F T := by
+  obtain ⟨s, b, hint⟩ := FiniteDimensional.exists_is_basis_integral A E F
+  set e : Fin (Module.finrank E F) ≃ s :=
+    (Fintype.equivFinOfCardEq (Module.finrank_eq_card_basis b).symm).symm
+  refine ⟨fun i => b (e i), linearIndependent_reindex_basis b, fun i w hw => ?_⟩
+  exact T.ord_nonneg_of_isIntegral_of_regularOutside hA (hint (e i)) w hw
+
+theorem hasIntegralBasisRegularOutside_of_hasRegularFractionSubring
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    HasIntegralBasisRegularOutside K E F T := by
+  obtain ⟨A, hfrac, hreg⟩ := h
+  have : IsFractionRing A E := hfrac
+  exact hasIntegralBasisRegularOutside_of_isFractionRing (A := A) T
+    (fun u hu a => hreg u hu (a : E) a.property)
+
+theorem hasPoleDivisorPackage_of_isFractionRing [HasPrincipalDivisors K F]
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside T
+    (hasIntegralBasisRegularOutside_of_isFractionRing T hA)
+
+theorem stichtenothGenusExists_of_isFractionRing [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {A : Type*} [CommRing A] [IsDomain A] [Algebra A E] [IsFractionRing A E]
+    [Algebra A F] [IsScalarTower A E F]
+    (T : TranscendenceTower K E F) (hA : T.RegularOutside A) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasPoleDivisorPackage
+    (hasPoleDivisorPackage_of_isFractionRing T hA)
+
+theorem hasPoleDivisorPackage_of_hasRegularFractionSubring [HasPrincipalDivisors K F]
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    HasPoleDivisorPackage K F :=
+  hasPoleDivisorPackage_of_hasIntegralBasisRegularOutside T
+    (hasIntegralBasisRegularOutside_of_hasRegularFractionSubring T h)
+
+theorem stichtenothGenusExists_of_hasRegularFractionSubring [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F) (h : HasRegularFractionSubring K E F T) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasPoleDivisorPackage
+    (hasPoleDivisorPackage_of_hasRegularFractionSubring T h)
+
+namespace TranscendenceTower
+p2m_open_scoped "AlgebraicCurve.TranscendenceTower" in
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+private theorem _root_.AlgebraicCurve.TranscendenceTower.adjoin_x_regularOutside (T :
+  TranscendenceTower K E F) :
+    ∀ u : Place K E, u ≠ T.v →
+      ∀ a ∈ Algebra.adjoin K {T.x}, a ∈ u.toValuationSubring := by
+  intro u hu a ha
+  let S : Subalgebra K E :=
+    { u.toValuationSubring.toSubsemiring with
+      algebraMap_mem' := u.algebraMap_mem' }
+  suffices h : a ∈ S from h
+  refine Algebra.adjoin_le ?_ ha
+  intro y hy
+  rw [Set.mem_singleton_iff] at hy
+  subst hy
+  change T.x ∈ u.toValuationSubring
+  exact AlgebraicCurve.Place.mem_of_ord_nonneg u T.x_ne_zero (T.hxreg u hu)
+
+end TranscendenceTower
+p2m_export "AlgebraicCurve" "TranscendenceTower.adjoin_x_regularOutside"
+omit [FiniteDimensional E F] [Algebra.IsSeparable E F] in
+theorem hasRegularFractionSubring_of_adjoin_x_isFractionRing
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    HasRegularFractionSubring K E F T :=
+  ⟨Algebra.adjoin K {T.x}, hfrac, T.adjoin_x_regularOutside⟩
+
+theorem hasIntegralBasisRegularOutside_of_adjoin_x_isFractionRing
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    HasIntegralBasisRegularOutside K E F T :=
+  hasIntegralBasisRegularOutside_of_hasRegularFractionSubring T
+    (hasRegularFractionSubring_of_adjoin_x_isFractionRing T hfrac)
+
+theorem stichtenothGenusExists_of_adjoin_x_isFractionRing [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (T : TranscendenceTower K E F)
+    (hfrac : IsFractionRing (Algebra.adjoin K {T.x}) E) :
+    StichtenothGenusExists K F :=
+  stichtenothGenusExists_of_hasRegularFractionSubring T
+    (hasRegularFractionSubring_of_adjoin_x_isFractionRing T hfrac)
+
+end Headline
+
+section Gates
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem gate_mem_of_isIntegral_recovers_comap (w : Place K F) (E : Type*) [Field E]
+    [Algebra E F] [Algebra.IsIntegral E F]
+    (hE : ∀ a : E, algebraMap E F a ∈ w.toValuationSubring) (f : F) :
+    f ∈ w.toValuationSubring := by
+  let : Algebra E w.toValuationSubring :=
+    ((algebraMap E F).codRestrict w.toValuationSubring.toSubring hE).toAlgebra
+  have : IsScalarTower E w.toValuationSubring F :=
+    IsScalarTower.of_algebraMap_eq fun _ => rfl
+  exact w.mem_of_isIntegral (Algebra.IsIntegral.isIntegral (R := E) f).tower_top
+
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+
+theorem gate_bridge_recovers_hxreg [Algebra.IsIntegral E F]
+    (T : TranscendenceTower K E F) (w : Place K F) (hw : w.restrict E ≠ T.v) :
+    0 ≤ w.ord T.xF := by
+  rw [TranscendenceTower.xF, Place.ord_restrict]
+  exact mul_nonneg (Int.natCast_nonneg _) (T.hxreg _ hw)
+
+theorem gate_regularOutside_mono (T : TranscendenceTower K E F) {A A' : Subalgebra K E}
+    (hle : A ≤ A')
+    (hA' : ∀ u : Place K E, u ≠ T.v → ∀ a ∈ A', a ∈ u.toValuationSubring) :
+    ∀ u : Place K E, u ≠ T.v → ∀ a ∈ A, a ∈ u.toValuationSubring :=
+  fun u hu a ha => hA' u hu a (hle ha)
+
+theorem gate_bot_regularOutside (T : TranscendenceTower K E F) :
+    ∀ u : Place K E, u ≠ T.v → ∀ a ∈ (⊥ : Subalgebra K E), a ∈ u.toValuationSubring := by
+  intro u _ a ha
+  obtain ⟨c, rfl⟩ := Algebra.mem_bot.mp ha
+  exact u.algebraMap_mem' c
+
+theorem gate_adjoin_x_not_regular_at_v (T : TranscendenceTower K E F) :
+    ¬ ∀ a ∈ Algebra.adjoin K {T.x}, a ∈ T.v.toValuationSubring := by
+  intro h
+  have hx := AlgebraicCurve.Place.ord_nonneg_of_mem T.v (h T.x (Algebra.subset_adjoin rfl))
+  rw [T.hxv] at hx
+  exact absurd hx (by decide)
+
+end Gates
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open Module Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+section Transcendental
+
+variable {K A : Type*} [CommRing K] [CommRing A] [Algebra K A]
+
+theorem linearIndependent_pow_of_transcendental_port {x : A} (hx : Transcendental K x) :
+    LinearIndependent K (fun j : ℕ => x ^ j) := by
+  have hinj : Function.Injective (Polynomial.aeval x : K[X] →ₐ[K] A) :=
+    transcendental_iff_injective.mp hx
+  have hXj : LinearIndependent K (fun j : ℕ => (X : K[X]) ^ j) := by
+    have hb := (Polynomial.basisMonomials K).linearIndependent
+    simp only [Polynomial.coe_basisMonomials] at hb
+    convert hb using 2 with j
+    exact (Polynomial.monomial_one_right_eq_X_pow j).symm
+  have heq : (fun j : ℕ => x ^ j)
+      = (fun j : ℕ => (Polynomial.aeval x : K[X] →ₐ[K] A) (X ^ j)) := by
+    funext j; simp
+  rw [heq]
+  exact hXj.map' (Polynomial.aeval x).toLinearMap
+    (LinearMap.ker_eq_bot_of_injective hinj)
+
+theorem transcendental_of_linearIndependent_pow {x : A}
+    (hx : LinearIndependent K (fun j : ℕ => x ^ j)) :
+    Transcendental K x := by
+  rw [transcendental_iff]
+  intro p hp
+  rw [Polynomial.aeval_eq_sum_range, ← Fin.sum_univ_eq_sum_range] at hp
+  ext j
+  rcases lt_or_ge j (p.natDegree + 1) with hj | hj
+  · exact (Fintype.linearIndependent_iff.mp
+      (hx.comp (Fin.val : Fin (p.natDegree + 1) → ℕ) Fin.val_injective))
+      (fun i => p.coeff i) hp ⟨j, hj⟩
+  · exact p.coeff_eq_zero_of_natDegree_lt (Nat.lt_of_succ_le hj)
+
+end Transcendental
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "algebraMap_mem_ofHeightOneSpectrum placeInfty \
+  ord_placeInfty deg_placeInfty eq_ofHeightOneSpectrum_or_eq_placeInfty"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+
+theorem ord_placeInfty_X : (placeInfty K).ord (RatFunc.X : RatFunc K) = -1 := by
+  rw [ord_placeInfty (K := K) RatFunc.X_ne_zero, RatFunc.intDegree_X]
+
+theorem algebraMap_polynomial_mem_of_ne_placeInfty
+    {u : Place K (RatFunc K)} (hu : u ≠ placeInfty K) (q : K[X]) :
+    algebraMap K[X] (RatFunc K) q ∈ u.toValuationSubring := by
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty u with ⟨w, hw⟩ | hw
+  · subst hw; exact algebraMap_mem_ofHeightOneSpectrum K w q
+  · exact absurd hw hu
+
+theorem ord_X_nonneg_of_ne_placeInfty
+    {u : Place K (RatFunc K)} (hu : u ≠ placeInfty K) :
+    0 ≤ u.ord (RatFunc.X : RatFunc K) := by
+  rw [← RatFunc.algebraMap_X]
+  exact AlgebraicCurve.Place.ord_nonneg_of_mem u (algebraMap_polynomial_mem_of_ne_placeInfty K hu
+    Polynomial.X)
+
+variable (F : Type*) [Field F] [Algebra K F] [Algebra (RatFunc K) F]
+  [IsScalarTower K (RatFunc K) F]
+
+def transcendenceTower : TranscendenceTower K (RatFunc K) F where
+  x := RatFunc.X
+  hx_indep := linearIndependent_pow_of_transcendental_port RatFunc.transcendental_X
+  v := placeInfty K
+  hvdeg := deg_placeInfty K
+  hxv := ord_placeInfty_X K
+  hxreg := fun _ hu => ord_X_nonneg_of_ne_placeInfty K hu
+
+@[scoped simp]
+theorem transcendenceTower_x : (transcendenceTower K F).x = RatFunc.X := rfl
+
+@[scoped simp]
+theorem transcendenceTower_v : (transcendenceTower K F).v = placeInfty K := rfl
+
+omit [DecidableEq (RatFunc K)] in
+theorem aeval_X_eq_algebraMap (q : K[X]) :
+    (Polynomial.aeval (R := K) (RatFunc.X : RatFunc K)) q
+      = algebraMap K[X] (RatFunc K) q := by
+  have hext : (Polynomial.aeval (R := K) (RatFunc.X : RatFunc K))
+      = IsScalarTower.toAlgHom K K[X] (RatFunc K) :=
+    Polynomial.algHom_ext (by simp [RatFunc.algebraMap_X])
+  rw [hext]; rfl
+
+omit [DecidableEq (RatFunc K)] in
+theorem algebraMap_polynomial_mem_adjoin_X (q : K[X]) :
+    algebraMap K[X] (RatFunc K) q ∈ Algebra.adjoin K {(RatFunc.X : RatFunc K)} := by
+  rw [Algebra.adjoin_singleton_eq_range_aeval]
+  exact ⟨q, aeval_X_eq_algebraMap K q⟩
+
+omit [DecidableEq (RatFunc K)] in
+theorem isFractionRing_adjoin_X :
+    IsFractionRing (Algebra.adjoin K {(RatFunc.X : RatFunc K)}) (RatFunc K) := by
+  refine IsFractionRing.of_field _ _ fun z => ?_
+  refine ⟨⟨algebraMap K[X] (RatFunc K) z.num, algebraMap_polynomial_mem_adjoin_X K z.num⟩,
+    ⟨algebraMap K[X] (RatFunc K) z.denom, algebraMap_polynomial_mem_adjoin_X K z.denom⟩, ?_⟩
+  change z = algebraMap K[X] (RatFunc K) z.num / algebraMap K[X] (RatFunc K) z.denom
+  exact z.num_div_denom.symm
+
+theorem hasRegularFractionSubring :
+    HasRegularFractionSubring K (RatFunc K) F (transcendenceTower K F) :=
+  hasRegularFractionSubring_of_adjoin_x_isFractionRing
+    (transcendenceTower K F) (isFractionRing_adjoin_X K)
+
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+
+theorem hasIntegralBasisRegularOutside :
+    HasIntegralBasisRegularOutside K (RatFunc K) F (transcendenceTower K F) :=
+  hasIntegralBasisRegularOutside_of_adjoin_x_isFractionRing
+    (transcendenceTower K F) (isFractionRing_adjoin_X K)
+
+section PrincipalDivisors
+
+variable [HasPrincipalDivisors K F]
+
+omit [DecidableEq (RatFunc K)] in
+theorem hasPoleDivisorPackage_of_ratFunc_tower :
+    HasPoleDivisorPackage K F := by
+  classical
+  exact
+    hasPoleDivisorPackage_of_hasRegularFractionSubring
+      (transcendenceTower K F) (hasRegularFractionSubring K F)
+
+end PrincipalDivisors
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+omit [DecidableEq (RatFunc K)] in
+theorem stichtenothGenusExists_of_ratFunc_tower :
+    StichtenothGenusExists K F := by
+  classical
+  exact
+    stichtenothGenusExists_of_adjoin_x_isFractionRing
+      (transcendenceTower K F) (isFractionRing_adjoin_X K)
+
+omit [DecidableEq (RatFunc K)] in
+theorem indexOfSpecialtyFinite_of_ratFunc_tower :
+    IndexOfSpecialtyFinite K F := by
+  classical
+  exact
+    indexOfSpecialtyFinite_of_stichtenothGenusExists
+      (stichtenothGenusExists_of_ratFunc_tower K F)
+
+end RationalFunctionField
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open Module Polynomial IsDedekindDomain
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Place.ord_zero Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors Place.ofHeightOneSpectrum \
+  HasPrincipalDivisors.exists_divisor Place.algebraMap_mem' Place.ord_restrict \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Divisor.pullback Divisor.pullback_apply \
+  Divisor.degree_pullback SumRamificationInertia IsCurveOver IsCurveOver.finite_residueField \
+  LSpace ell mem_lSpace_iff_ord lSpace_mono one_mem_lSpace_zero ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists \
+  RiemannGenusBounded IndexOfSpecialtyFinite PoleDivisorPackage HasPoleDivisorPackage \
+  TranscendenceTower TranscendenceTower.xF TranscendenceTower.poleDivisor IntegralBasisInLSpace \
+  HasIntegralBasisInLSpace HasIntegralBasisRegularOutside HasRegularFractionSubring \
+  TranscendenceTower.hx_indep Place.sum_ramificationIndex_mul_inertiaDeg \
+  RationalFunctionField.ord_placeInfty Place.exists_restrict_eq"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "algebraMap_mem_ofHeightOneSpectrum placeInfty \
+  ord_placeInfty deg_placeInfty eq_ofHeightOneSpectrum_or_eq_placeInfty"
+p2m_open "AlgebraicCurve.RationalFunctionField"
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+variable (F : Type*) [Field F] [Algebra K F] [Algebra (RatFunc K) F]
+  [IsScalarTower K (RatFunc K) F]
+
+section LyingOver
+
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+
+omit [DecidableEq (RatFunc K)] in
+omit [DecidableEq (RatFunc K)] in
+private theorem _root_.AlgebraicCurve.RationalFunctionField.exists_restrict_eq (v : Place K (RatFunc
+  K)) :
+    ∃ w : Place K F, w.restrict (RatFunc K) = v :=
+  Place.exists_restrict_eq v
+
+p2m_export "AlgebraicCurve.RationalFunctionField" "exists_restrict_eq"
+
+omit [DecidableEq (RatFunc K)] in
+theorem nonempty_place_of_ratFunc_tower : Nonempty (Place K F) := by
+  classical
+  exact
+    (exists_restrict_eq K F (placeInfty K)).nonempty
+
+end LyingOver
+
+omit [DecidableEq (RatFunc K)] [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F] in
+theorem finiteDimensional_lSpace_zero_of_constantsAreBase (hC : ConstantsAreBase K F) :
+    FiniteDimensional K (LSpace (0 : Divisor K F)) := by
+  rw [show LSpace (0 : Divisor K F) = LinearMap.range (Algebra.linearMap K F) from hC]
+  exact LinearMap.finiteDimensional_range _
+
+variable [FiniteDimensional (RatFunc K) F] [Algebra.IsSeparable (RatFunc K) F]
+variable [IsCurveOver K F]
+
+omit [DecidableEq (RatFunc K)] in
+theorem stichtenothGenusExists (hC : ConstantsAreBase K F) :
+    StichtenothGenusExists K F := by
+  classical
+  exact
+    haveI := nonempty_place_of_ratFunc_tower K F
+    haveI := finiteDimensional_lSpace_zero_of_constantsAreBase K F hC
+    stichtenothGenusExists_of_ratFunc_tower K F
+
+omit [DecidableEq (RatFunc K)] in
+theorem indexOfSpecialtyFinite (hC : ConstantsAreBase K F) :
+    IndexOfSpecialtyFinite K F := by
+  classical
+  exact
+    indexOfSpecialtyFinite_of_stichtenothGenusExists (stichtenothGenusExists K F hC)
+
+omit [DecidableEq (RatFunc K)] in
+theorem riemannGenusBounded (hC : ConstantsAreBase K F) : RiemannGenusBounded K F := by
+  classical
+  exact
+    haveI := nonempty_place_of_ratFunc_tower K F
+    haveI := finiteDimensional_lSpace_zero_of_constantsAreBase K F hC
+    riemannGenusBounded_of_poleDivisorPackage (hasPoleDivisorPackage_of_ratFunc_tower K F).some
+
+end RationalFunctionField
+end AlgebraicCurve
+end
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg\
+  " in
+open _root_.P2MW.S_AlgebraicCurve_linearIndependent_pow_of_transcendental.AlgebraicCurve Polynomial
+  in
+theorem solution {K : Type*} {A : Type*} [CommRing K] [CommRing A] [Algebra K A] {x : A}
+    (hx : Transcendental K x) :
+    LinearIndependent K (fun j : ℕ => x ^ j) :=
+  AlgebraicCurve.linearIndependent_pow_of_transcendental_port (K := K) (A := A) (x := x) (hx := hx)
+
+end S_AlgebraicCurve_linearIndependent_pow_of_transcendental
+end P2MW
+export P2MW.S_AlgebraicCurve_linearIndependent_pow_of_transcendental (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace AlgebraicCurve
+theorem linearIndependent_pow_of_transcendental {K : Type*} {A : Type*} [CommRing K] [CommRing A]
+    [Algebra K A] {x : A} (hx : Transcendental K x) :
+    LinearIndependent K (fun j : ℕ => x ^ j) :=
+  solution hx
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_mem_regularDiffs_iff.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_mem_regularDiffs_iff.lean
new file mode 100644
index 0000000000..63fa62913b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_mem_regularDiffs_iff.lean
@@ -0,0 +1,167 @@
+/-
+Based on Prove2Me node AlgebraicCurve.mem_regularDiffs_iff
+(c78e2722-9ac8-5fec-a22e-e8e1fc265734) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f7202914-2575-53c8-bccf-95e2d60ba9bc
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_diffCoeff_smul_D_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ordDiff_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ordDiff_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_min_ord_le_ord_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_eq_one
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Regular differentials already form a K-subspace
+
+Theorem statement: `AlgebraicCurve.mem_regularDiffs_iff` (`c78e2722-9ac8-5fec-a22e-e8e1fc265734`),
+by Claude, 2026-09-05.
+
+Proof: submission `f7202914-2575-53c8-bccf-95e2d60ba9bc`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, $K$ of characteristic zero, and let $x \in F$ be
+an element such that $F$ is algebraic over the intermediate field $K(x)$ obtained by adjoining $x$
+to $K$ inside $F$; thus $F$ is a function field of one variable over $K$, presented by the chosen
+generator $x$. Here a place of $F/K$ is a valuation subring $\mathcal{O}_v \subseteq F$ that
+contains the image of $K$, is not all of $F$, and is a principal ideal ring; for such a $v$ and a
+Kähler differential $\omega \in \Omega[F\!/\!K]$ the order $\operatorname{ordDiff}_v(\omega) \in
+\mathbb{Z}$ is the valuation $v.\mathrm{ord}$ of the coefficient $\mathrm{diffCoeff}$ of $\omega$
+with respect to the differential of the chosen uniformiser of $v$, and
+[`AlgebraicCurve.IsRegularDiff K F ω`](def/AlgebraicCurve_Differentials.html#L48) asserts $0 \le
+\operatorname{ordDiff}_v(\omega)$ for every place $v$ of $F/K$. The submodule
+[`AlgebraicCurve.regularDiffs K F`](def/AlgebraicCurve_Differentials.html#L56) is by definition the
+$K$-span inside $\Omega[F\!/\!K]$ of the set of differentials satisfying this regularity condition.
+The theorem asserts, for every $\omega \in \Omega[F\!/\!K]$, that $\omega$ lies in
+[`AlgebraicCurve.regularDiffs K F`](def/AlgebraicCurve_Differentials.html#L56) if and only if
+$\omega$ is itself regular in the above sense: the span contains nothing beyond its generators.
+
+The statement says that the regular (everywhere holomorphic) differentials of a characteristic-zero
+function field of one variable are closed under addition and under scalar multiplication by $K$, so
+that the $K$-space of regular differentials may be described interchangeably as a span or by the
+local conditions $\operatorname{ordDiff}_v \ge 0$. It is used on the modular-curve side, in the
+identifications of integrality conditions for differentials of the form $g \cdot \mathrm{d}t$ lying
+in the space of regular differentials.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_mem_regularDiffs_iff.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_mem_regularDiffs_iff
+
+noncomputable section
+open KaehlerDifferential
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place.diffCoeff Place.ordDiff_def IsRegularDiff regularDiffs \
+  mem_regularDiffs_of_isRegularDiff Place Place.diffCoeff_smul_D_of_ord_ne_zero \
+  Place.diffCoeff_smul_D_eq Place.ordDiff_zero Place.ordDiff_smul"
+namespace FF2Tail
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] [CharZero K] (x : F)
+  [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F]
+
+include x in
+theorem diffCoeff_add (v : Place K F) {t : F} (ht : v.ord t ≠ 0) (ω₁ ω₂ : Ω[F⁄K]) :
+    Place.diffCoeff t (ω₁ + ω₂) = Place.diffCoeff t ω₁ + Place.diffCoeff t ω₂ := by
+  have h1 := Place.diffCoeff_smul_D_of_ord_ne_zero x v ht ω₁
+  have h2 := Place.diffCoeff_smul_D_of_ord_ne_zero x v ht ω₂
+  conv_lhs => rw [← h1, ← h2, ← add_smul]
+  exact Place.diffCoeff_smul_D_eq x v ht _
+
+include x in
+theorem min_ordDiff_le_ordDiff_add (v : Place K F) {ω₁ ω₂ : Ω[F⁄K]} (h₁₂ : ω₁ + ω₂ ≠ 0) :
+    min (v.ordDiff ω₁) (v.ordDiff ω₂) ≤ v.ordDiff (ω₁ + ω₂) := by
+  rcases eq_or_ne ω₁ 0 with rfl | h₁
+  · rw [zero_add]; exact min_le_right _ _
+  rcases eq_or_ne ω₂ 0 with rfl | h₂
+  · rw [add_zero]; exact min_le_left _ _
+  have hu : v.ord v.uniformizer_alt ≠ 0 := by
+    rw [v.ord_uniformizer_alt v.exists_ord_eq_one]; exact one_ne_zero
+  have hcoe : ∀ ω : Ω[F⁄K], ω ≠ 0 → Place.diffCoeff v.uniformizer_alt ω ≠ 0 := by
+    intro ω hω h0
+    have := Place.diffCoeff_smul_D_of_ord_ne_zero x v hu ω
+    rw [h0, zero_smul] at this
+    exact hω this.symm
+  simp only [Place.ordDiff_def]
+  rw [diffCoeff_add x v hu]
+  exact v.min_ord_le_ord_add (hcoe _ h₁) (hcoe _ h₂) (by
+    rw [← diffCoeff_add x v hu]; exact hcoe _ h₁₂)
+
+include x in
+theorem isRegularDiff_zero : IsRegularDiff K F (0 : Ω[F⁄K]) := fun v => by
+  rw [Place.ordDiff_zero x v]
+
+include x in
+theorem isRegularDiff_add {ω₁ ω₂ : Ω[F⁄K]} (h₁ : IsRegularDiff K F ω₁) (h₂ : IsRegularDiff K F ω₂) :
+    IsRegularDiff K F (ω₁ + ω₂) := by
+  intro v
+  rcases eq_or_ne (ω₁ + ω₂) 0 with h12 | h12
+  · rw [h12, Place.ordDiff_zero x v]
+  · exact le_trans (le_min (h₁ v) (h₂ v)) (min_ordDiff_le_ordDiff_add x v h12)
+
+include x in
+theorem isRegularDiff_smul (c : K) {ω : Ω[F⁄K]} (h : IsRegularDiff K F ω) :
+    IsRegularDiff K F (c • ω) := by
+  intro v
+  rcases eq_or_ne c 0 with rfl | hc
+  · rw [zero_smul]; exact isRegularDiff_zero x v
+  rcases eq_or_ne ω 0 with rfl | hω
+  · rw [smul_zero]; exact isRegularDiff_zero x v
+  rw [← algebraMap_smul F c ω, Place.ordDiff_smul x v ((map_ne_zero _).mpr hc) hω, v.ord_algebraMap,
+    zero_add]
+  exact h v
+
+include x in
+theorem mem_regularDiffs_iff (ω : Ω[F⁄K]) : ω ∈ regularDiffs K F ↔ IsRegularDiff K F ω := by
+  refine ⟨fun h => ?_, mem_regularDiffs_of_isRegularDiff⟩
+  induction h using Submodule.span_induction with
+  | mem ω hω => exact hω
+  | zero => exact isRegularDiff_zero x
+  | add ω₁ ω₂ _ _ h₁ h₂ => exact isRegularDiff_add x h₁ h₂
+  | smul c ω _ h => exact isRegularDiff_smul x c h
+
+end AlgebraicCurve.FF2Tail
+
+end
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [CharZero K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F] (ω : Ω[F⁄K]) :
+    ω ∈ AlgebraicCurve.regularDiffs K F ↔ AlgebraicCurve.IsRegularDiff K F ω :=
+  AlgebraicCurve.FF2Tail.mem_regularDiffs_iff x ω
+
+end S_AlgebraicCurve_mem_regularDiffs_iff
+end P2MW
+export P2MW.S_AlgebraicCurve_mem_regularDiffs_iff (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.mem_regularDiffs_iff {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [CharZero K] (x : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({x} : Set F)) F] (ω : Ω[F⁄K]) :
+    ω ∈ AlgebraicCurve.regularDiffs K F ↔ AlgebraicCurve.IsRegularDiff K F ω :=
+  solution x ω
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_mem_riemannRochSpace_of_sum_basis_smul_algebraMap_mem_mapDomain.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_mem_riemannRochSpace_of_sum_basis_smul_algebraMap_mem_mapDomain.lean
new file mode 100644
index 0000000000..9543503f03
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_mem_riemannRochSpace_of_sum_basis_smul_algebraMap_mem_mapDomain.lean
@@ -0,0 +1,124 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.mem_riemannRochSpace_of_sum_basis_smul_algebraMap_mem_mapDomain
+(06c6adb2-c531-5d3d-bfcb-11accfee1ba9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4e3b1c0e-e920-5f51-b86a-2cd9e07d5408
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_sum_algebraMap_mul_le_ord_of_linearIndependent_of_constantFieldExtension
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Coefficients of a constant-field-extension Riemann–Roch element descend
+
+Theorem statement: `AlgebraicCurve.mem_riemannRochSpace_of_sum_basis_smul_algebraMap_mem_mapDomain`
+(`06c6adb2-c531-5d3d-bfcb-11accfee1ba9`), by Claude, 2026-09-05.
+
+Proof: submission `4e3b1c0e-e920-5f51-b86a-2cd9e07d5408`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K\subseteq K'$ be algebraically closed fields and $F/K$, $F'/K'$ function-field extensions
+satisfying `IsCurveOver`, i.e. every nonzero element has a principal divisor of degree $0$ recording
+its orders, each place has residue field finite over the base field, and the module of Kähler
+differentials is free of rank one; the algebra maps $K\to K'$, $K\to F$, $K'\to F'$, $F\to F'$,
+$K\to F'$ form scalar towers. Assume $F$ is finite over $K(x)$ for some $x$ transcendental over $K$,
+likewise $F'$ over $K'(x')$, and that $F'$ is generated over $K'$ by the image of $F$, that is, the
+$K'$-subfield adjoining $\mathrm{range}(F\to F')$ is everything. Let $\mathrm{lift}$ be an injective
+map from places of $F/K$ to places of $F'/K'$ with
+$\mathrm{ord}_{\mathrm{lift}\,P}(f)=\mathrm{ord}_P(f)$ for every place $P$ and every $f\in F$. Let
+$D$ be a divisor of $F/K$ (a finitely supported integer function on places), $B:\iota\to K'$ a
+$K$-linearly independent family and $g:\iota\to_{\mathrm f} F$. If $\sum_{j\in\mathrm{supp}\,g}
+B_j\,g_j$ lies in the Riemann–Roch space of the pushforward divisor $\mathrm{lift}_*D$ in $F'$, then
+every $g_j$ lies in the Riemann–Roch space of $D$ in $F$.
+
+This is the descent half of the identification $L'(\mathrm{Con}\,D)=K'\otimes_K L_K(D)$ for a
+constant field extension, as in Stichtenoth, Theorem 3.6.3(a). It is used in
+[`AlgebraicCurve.
+lSpace_mapDomain_subset_span_image_lSpace_of_constantFieldExtension_of_isAlgClosed`]
+(thm.html#AlgebraicCurve.
+lSpace_mapDomain_subset_span_image_lSpace_of_constantFieldExtension_of_isAlgClosed),
+which expresses the Riemann–Roch space of the lifted divisor as the $K'$-span of the image of the
+original Riemann–Roch space.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_mem_riemannRochSpace_of_sum_basis_smul_algebraMap_mem_mapDomain.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_mem_riemannRochSpace_of_sum_basis_smul_algebraMap_mem_mapDomain
+
+
+open AlgebraicCurve
+
+theorem solution
+    (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [IsAlgClosed K'] [IsCurveOver K F] [IsCurveOver K' F']
+    (lift : Place K F → Place K' F')
+    (hlift_ord : ∀ (P : Place K F) (f : F), (lift P).ord (algebraMap F F' f) = P.ord f)
+    (hlift_inj : Function.Injective lift)
+    (D : Divisor K F) {ι : Type*} (B : ι → K') (hB : LinearIndependent K B)
+    (g : ι →₀ F)
+    (hmem : (∑ j ∈ g.support, algebraMap K' F' (B j) * algebraMap F F' (g j))
+      ∈ LSpace (K := K') (Finsupp.mapDomain lift D)) :
+    ∀ j, g j ∈ LSpace (K := K) D := by
+  classical
+  intro j₀
+  rcases eq_or_ne (g j₀) 0 with hj0 | hj0
+  · rw [hj0]; exact zero_mem _
+  have hj0supp : j₀ ∈ g.support := Finsupp.mem_support_iff.mpr hj0
+  have hgne : g ≠ 0 := fun h => hj0 (by rw [h]; rfl)
+  refine mem_lSpace_iff_ord.mpr (Or.inr fun v => ?_)
+  obtain ⟨hne, hle⟩ :=
+    Place.ord_sum_algebraMap_mul_le_ord_of_linearIndependent_of_constantFieldExtension
+      K F K' F' lift hlift_ord v B hB g hgne
+  have hordSig : -(Finsupp.mapDomain lift D) (lift v) ≤
+      (lift v).ord (∑ j ∈ g.support, algebraMap K' F' (B j) * algebraMap F F' (g j)) :=
+    (mem_lSpace_iff_ord.mp hmem).resolve_left hne (lift v)
+  rw [Finsupp.mapDomain_apply_of_injective hlift_inj] at hordSig
+  exact hordSig.trans (hle j₀ hj0supp)
+
+end S_AlgebraicCurve_mem_riemannRochSpace_of_sum_basis_smul_algebraMap_mem_mapDomain
+end P2MW
+export P2MW.S_AlgebraicCurve_mem_riemannRochSpace_of_sum_basis_smul_algebraMap_mem_mapDomain
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.mem_riemannRochSpace_of_sum_basis_smul_algebraMap_mem_mapDomain
+    (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [IsAlgClosed K'] [IsCurveOver K F] [IsCurveOver K' F']
+    (lift : Place K F → Place K' F')
+    (hlift_ord : ∀ (P : Place K F) (f : F), (lift P).ord (algebraMap F F' f) = P.ord f)
+    (hlift_inj : Function.Injective lift)
+    (D : Divisor K F) {ι : Type*} (B : ι → K') (hB : LinearIndependent K B)
+    (g : ι →₀ F)
+    (hmem : (∑ j ∈ g.support, algebraMap K' F' (B j) * algebraMap F F' (g j))
+      ∈ LSpace (K := K') (Finsupp.mapDomain lift D)) :
+    ∀ j, g j ∈ LSpace (K := K) D :=
+  solution K F K' F' lift hlift_ord hlift_inj D B hB g hmem
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_mem_span_range_algebraMap_of_constantFieldExtension_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_mem_span_range_algebraMap_of_constantFieldExtension_of_isAlgClosed.lean
new file mode 100644
index 0000000000..f929b4b8ea
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_mem_span_range_algebraMap_of_constantFieldExtension_of_isAlgClosed.lean
@@ -0,0 +1,964 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.mem_span_range_algebraMap_of_constantFieldExtension_of_isAlgClosed
+(f41197aa-9dea-5a56-87b6-eb8ecdcf9037) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f2919514-e3d1-5ee8-a4d9-14e60337ae93
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.PicardGroup
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import Mathlib.RingTheory.Valuation.LocalSubring
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_comap_algebraMap_eq_of_constantFieldExtension_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom_of_isSeparable
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_separating_transcendental_of_perfectField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_linearIndependent_of_constantFieldExtension_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Regularity at all new places forces membership in K'· F
+
+Theorem statement:
+`AlgebraicCurve.mem_span_range_algebraMap_of_constantFieldExtension_of_isAlgClosed`
+(`f41197aa-9dea-5a56-87b6-eb8ecdcf9037`), by Claude, 2026-09-05.
+
+Proof: submission `f2919514-e3d1-5ee8-a4d9-14e60337ae93`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K, F, K', F'$ be fields with $F$ an algebra over $K$, $F'$ an algebra over $K'$, together with
+algebra maps $K \to K'$, $F \to F'$ and $K \to F'$ making both $K \to K' \to F'$ and $K \to F \to
+F'$ scalar towers, and assume $K$ and $K'$ are algebraically closed. Assume $F$ is a one-variable
+function field over $K$ in the sense that some $x \in F$ is transcendental over $K$ with $F$
+finite-dimensional over $K(x)$, and likewise for $F'$ over $K'$. Assume further that $F$ is a curve
+over $K$ and $F'$ a curve over $K'$, i.e. in each case: every nonzero function $f$ has a divisor $D$
+with $D(v) = \operatorname{ord}_v(f)$ at every place $v$ and $\deg D = 0$; every place has residue
+field finite over the base field; and the module of Kähler differentials is free of rank one over
+the function field. Here a place of $F/K$ is a valuation subring of $F$ containing the image of $K$,
+different from $F$ itself, and a principal ideal ring. Assume the image of $F$ generates $F'$ over
+$K'$, i.e. the intermediate field of $F'/K'$ generated by the range of $F \to F'$ is all of $F'$.
+Let $z \in F'$ be such that $z$ lies in the valuation ring of every place $v'$ of $F'/K'$ whose
+valuation ring contracts along $F \to F'$ to the valuation ring of no place of $F/K$. Then $z$ lies
+in the $K'$-span of the image of $F$ in $F'$.
+
+This is the classical statement that a function on a constant field extension $F' = K'\cdot F$ which
+is regular at every place of $F'/K'$ not lying over a place of $F/K$ already belongs to $K' \cdot F$
+(Chevalley; Stichtenoth, Theorem 3.6.3), here in a form free of any hypothesis on the
+characteristic, both base fields being algebraically closed. It is the substantive input to the
+results identifying $L_{K'}(\mathrm{Con}\,D)$ with the $K'$-span of the image of $L_K(D)$ and
+comparing the corresponding dimensions under constant field extension.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_mem_span_range_algebraMap_of_constantFieldExtension_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_mem_span_range_algebraMap_of_constantFieldExtension_of_isAlgClosed
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_mem_span_range_algebraMap_of_constantFieldExtension_of_isAlgClosed.Algebrai\
+  cCurve Polynomial"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ord Place.ord_zero Divisor Divisor.degree \
+  HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.deg_eq_one_of_isAlgClosed IsCurveOver.finiteResidue \
+  Place.exists_comap_algebraMap_eq_of_constantFieldExtension_of_isAlgClosed \
+  Place.exists_toValuationSubring_eq_comap_ringHom_of_isSeparable \
+  exists_separating_transcendental_of_perfectField \
+  Place.mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed \
+  linearIndependent_of_constantFieldExtension_of_isAlgClosed"
+namespace W7XH
+p2m_open "AlgebraicCurve"
+
+section Basic
+
+variable {k L : Type*} [Field k] [Field L] [Algebra k L] (w : Place k L)
+
+theorem ord_nonneg_of_mem {f : L} (hf : f ∈ w.toValuationSubring) : 0 ≤ w.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · simp
+  have h1 : w.adicValuation f ≤ 1 := by
+    have h := w.adicValuation_coe ⟨f, hf⟩
+    rw [show ((⟨f, hf⟩ : w.toValuationSubring) : L) = f from rfl] at h
+    rw [h]
+    exact IsDedekindDomain.HeightOneSpectrum.intValuation_le_one _ _
+  have hne := w.adicValuation_ne_zero hf0
+  have h2 : WithZero.log (w.adicValuation f) ≤ 0 :=
+    (WithZero.log_le_iff_le_exp hne).2 (by simpa using h1)
+  simp only [Place.ord]
+  omega
+
+theorem mem_of_ord_nonneg {f : L} (hf : 0 ≤ w.ord f) : f ∈ w.toValuationSubring := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact zero_mem _
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  obtain ⟨u, hu⟩ := w.exists_unit_mul_zpow hf0 hπ
+  obtain ⟨n, hn⟩ := Int.eq_ofNat_of_zero_le hf
+  rw [hu, hn, zpow_natCast]
+  exact mul_mem (u : w.toValuationSubring).2 (pow_mem π.2 n)
+
+theorem not_mem_of_ord_neg {f : L} (hf : w.ord f < 0) : f ∉ w.toValuationSubring := fun h => by
+  have := ord_nonneg_of_mem w h
+  omega
+
+theorem ord_eq_zero_of_mem_of_inv_mem {f : L} (hf : f ∈ w.toValuationSubring)
+    (hfi : f⁻¹ ∈ w.toValuationSubring) : w.ord f = 0 := by
+  have h1 := ord_nonneg_of_mem w hf
+  have h2 := ord_nonneg_of_mem w hfi
+  rw [w.ord_inv] at h2
+  omega
+
+theorem ord_algebraMap (a : k) : w.ord (algebraMap k L a) = 0 := by
+  rcases eq_or_ne a 0 with rfl | ha
+  · simp
+  exact ord_eq_zero_of_mem_of_inv_mem w (w.algebraMap_mem' a)
+    (by rw [← map_inv₀]; exact w.algebraMap_mem' a⁻¹)
+
+theorem irreducible_coe_ne_zero {π : w.toValuationSubring} (hπ : Irreducible π) : (π : L) ≠ 0 := by
+  intro h
+  exact hπ.ne_zero (by exact_mod_cast h)
+
+theorem ord_coe_isUnit {X : w.toValuationSubring} (h : IsUnit X) : w.ord (X : L) = 0 := by
+  obtain ⟨u, rfl⟩ := h
+  exact w.ord_coe_unit u
+
+theorem mem_maximalIdeal_of_ord_pos {Y : w.toValuationSubring} (h : 0 < w.ord (Y : L)) :
+    Y ∈ IsLocalRing.maximalIdeal w.toValuationSubring := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  intro hu
+  have := ord_coe_isUnit w hu
+  omega
+
+theorem isUnit_add_of_mem_maximalIdeal {X Y : w.toValuationSubring} (hX : IsUnit X)
+    (hY : Y ∈ IsLocalRing.maximalIdeal w.toValuationSubring) : IsUnit (X + Y) := by
+  by_contra h
+  have h1 : X + Y ∈ IsLocalRing.maximalIdeal w.toValuationSubring :=
+    (IsLocalRing.mem_maximalIdeal _).2 (mem_nonunits_iff.2 h)
+  have h2 : X ∈ IsLocalRing.maximalIdeal w.toValuationSubring := by
+    simpa using sub_mem h1 hY
+  exact (IsLocalRing.mem_maximalIdeal _).1 h2 hX
+
+theorem ord_algebraMap_add_eq_zero {a : k} (ha : a ≠ 0) {f : L} (hf : 0 < w.ord f) :
+    w.ord (algebraMap k L a + f) = 0 := by
+  have hfmem : f ∈ w.toValuationSubring := mem_of_ord_nonneg w hf.le
+  have hX : IsUnit (algebraMap k w.toValuationSubring a) := (IsUnit.mk0 a ha).map _
+  have hY : (⟨f, hfmem⟩ : w.toValuationSubring) ∈ IsLocalRing.maximalIdeal w.toValuationSubring :=
+    mem_maximalIdeal_of_ord_pos w (by simpa using hf)
+  have h := ord_coe_isUnit w (isUnit_add_of_mem_maximalIdeal w hX hY)
+  simpa using h
+
+theorem ord_mul_of_ord_eq_zero {f g : L} (hf : w.ord f = 0) (hf0 : f ≠ 0) :
+    w.ord (f * g) = w.ord g := by
+  rcases eq_or_ne g 0 with rfl | hg
+  · simp
+  rw [w.ord_mul hf0 hg, hf, zero_add]
+
+theorem exists_sub_algebraMap_mem_maximalIdeal [IsAlgClosed k] [IsCurveOver k L]
+    (X : w.toValuationSubring) :
+    ∃ a : k, X - algebraMap k w.toValuationSubring a ∈
+      IsLocalRing.maximalIdeal w.toValuationSubring := by
+  have : Module.Finite k w.ResidueField := IsCurveOver.finiteResidue w
+  have : Algebra.IsIntegral k w.ResidueField := Algebra.IsIntegral.of_finite k _
+  have hbij : Function.Bijective (algebraMap k w.ResidueField) :=
+    IsAlgClosed.algebraMap_bijective_of_isIntegral
+  obtain ⟨a, ha⟩ := hbij.2 (IsLocalRing.residue w.toValuationSubring X)
+  refine ⟨a, ?_⟩
+  rw [← IsLocalRing.residue_eq_zero_iff, map_sub, sub_eq_zero, ← ha,
+    IsScalarTower.algebraMap_apply k w.toValuationSubring w.ResidueField,
+    IsLocalRing.ResidueField.algebraMap_eq]
+
+theorem exists_ord_sub_algebraMap_pos [IsAlgClosed k] [IsCurveOver k L] {f : L}
+    (hf : f ∈ w.toValuationSubring) :
+    ∃ a : k, f = algebraMap k L a ∨ 0 < w.ord (f - algebraMap k L a) := by
+  obtain ⟨a, ha⟩ := exists_sub_algebraMap_mem_maximalIdeal w ⟨f, hf⟩
+  refine ⟨a, ?_⟩
+  by_cases h : f = algebraMap k L a
+  · exact Or.inl h
+  right
+  have hne : (⟨f, hf⟩ - algebraMap k w.toValuationSubring a : w.toValuationSubring) ≠ 0 := by
+    intro h0
+    apply h
+    have := congrArg Subtype.val h0
+    simpa [sub_eq_zero] using this
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff] at ha
+  have hord : w.ord ((⟨f, hf⟩ - algebraMap k w.toValuationSubring a : w.toValuationSubring) : L)
+      ≠ 0 := by
+    intro h0
+    apply ha
+    obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+    have hX0 : ((⟨f, hf⟩ - algebraMap k w.toValuationSubring a : w.toValuationSubring) : L) ≠ 0 :=
+      fun h' => hne (by exact_mod_cast h')
+    obtain ⟨u, hu⟩ := w.exists_unit_mul_zpow hX0 hπ
+    rw [h0, zpow_zero, mul_one] at hu
+    rw [Subtype.ext hu]
+    exact Units.isUnit u
+  have hnn := ord_nonneg_of_mem w
+    ((⟨f, hf⟩ - algebraMap k w.toValuationSubring a : w.toValuationSubring)).2
+  have : ((⟨f, hf⟩ - algebraMap k w.toValuationSubring a : w.toValuationSubring) : L)
+      = f - algebraMap k L a := by simp
+  rw [this] at hord hnn
+  omega
+
+theorem aeval_mem {t : L} (ht : t ∈ w.toValuationSubring) (p : k[X]) :
+    aeval t p ∈ w.toValuationSubring := by
+  induction p using Polynomial.induction_on' with
+  | add p q hp hq => rw [map_add]; exact add_mem hp hq
+  | monomial n a =>
+    rw [aeval_monomial]
+    exact mul_mem (w.algebraMap_mem' a) (pow_mem ht n)
+
+end Basic
+
+section Algebra
+
+theorem linearIndependent_pow_of_transcendental {R A : Type*} [CommRing R] [Ring A] [Algebra R A]
+    {x : A} (hx : Transcendental R x) : LinearIndependent R fun n : ℕ => x ^ n := by
+  rw [linearIndependent_iff]
+  intro l hl
+  have hinj := transcendental_iff_injective.mp hx
+  have h0 : aeval x (Polynomial.ofFinsupp (.ofCoeff l)) = 0 := by
+    rw [Finsupp.linearCombination_apply] at hl
+    rw [aeval_def, eval₂_eq_sum, Polynomial.sum, Polynomial.support_ofFinsupp,
+      AddMonoidAlgebra.coeff_ofCoeff]
+    rw [Finsupp.sum] at hl
+    convert hl using 2 with n hn
+    rw [Polynomial.coeff_ofFinsupp, Algebra.smul_def]
+  have h1 : (Polynomial.ofFinsupp (.ofCoeff l) : R[X]) = 0 := hinj (by rw [h0, map_zero])
+  exact AddMonoidAlgebra.ofCoeff_eq_zero.mp (Polynomial.ofFinsupp_eq_zero.mp h1)
+
+theorem isIntegral_of_forall_mem_valuationSubring {R L : Type*} [CommRing R] [Field L]
+    [Algebra R L] (w : L)
+    (h : ∀ B : ValuationSubring L, (∀ r : R, algebraMap R L r ∈ B) → w ∈ B) :
+    IsIntegral R w := by
+  classical
+  by_contra hni
+  have hw0 : w ≠ 0 := by rintro rfl; exact hni isIntegral_zero
+  set S : Subalgebra R L := Algebra.adjoin R {w⁻¹} with hS
+  have hwS : w⁻¹ ∈ S := Algebra.subset_adjoin (Set.mem_singleton _)
+  set A : Subring L := S.toSubring with hA
+  set I : Ideal A := Ideal.span {(⟨w⁻¹, hwS⟩ : A)} with hI
+  have hI : I ≠ ⊤ := by
+    intro htop
+    have h1 : (1 : A) ∈ I := htop ▸ Submodule.mem_top
+    rw [hI, Ideal.mem_span_singleton'] at h1
+    obtain ⟨a, ha⟩ := h1
+    have haS : (a : L) ∈ S := a.2
+    rw [hS, Algebra.adjoin_singleton_eq_range_aeval] at haS
+    obtain ⟨f, hf⟩ := haS
+    have haw : (a : L) * w⁻¹ = 1 := by
+      have := congrArg Subtype.val ha
+      simpa using this
+    set n := f.natDegree with hn
+    apply hni
+    set g : R[X] := ∑ i ∈ Finset.range (n + 1), C (f.coeff i) * X ^ (n - i) with hg
+    have hgdeg : g.degree < (n + 1 : ℕ) := by
+      rw [hg]
+      refine lt_of_le_of_lt (Polynomial.degree_sum_le _ _) ?_
+      rw [Finset.sup_lt_iff (WithBot.bot_lt_coe _)]
+      intro i hi
+      refine lt_of_le_of_lt (degree_C_mul_X_pow_le _ _) ?_
+      exact_mod_cast Nat.lt_succ_of_le (Nat.sub_le n i)
+    refine ⟨X ^ (n + 1) - g, monic_X_pow_sub hgdeg, ?_⟩
+    have hfw : (aeval w⁻¹ f : L) = ∑ i ∈ Finset.range (n + 1), algebraMap R L (f.coeff i) * w⁻¹ ^ i
+      :=
+      by
+      rw [aeval_def, eval₂_eq_sum_range]
+    have hkey : w ^ (n + 1) = ∑ i ∈ Finset.range (n + 1), algebraMap R L (f.coeff i) * w ^ (n - i)
+      :=
+      by
+      have h2 : w ^ (n + 1) = w ^ (n + 1) * ((a : L) * w⁻¹) := by rw [haw, mul_one]
+      rw [h2, ← hf, show ((aeval w⁻¹).toRingHom f : L) = aeval w⁻¹ f from rfl, hfw,
+        Finset.sum_mul, Finset.mul_sum]
+      refine Finset.sum_congr rfl fun i hi => ?_
+      have hi' : i ≤ n := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)
+      have : w ^ (n + 1) = w ^ (n - i) * w ^ i * w := by
+        rw [← pow_add, Nat.sub_add_cancel hi', pow_succ]
+      rw [this, inv_pow]
+      have hwi : w ^ i ≠ 0 := pow_ne_zero _ hw0
+      field_simp
+    rw [← aeval_def, map_sub, map_pow, aeval_X, hg, map_sum]
+    simp only [map_mul, aeval_C, map_pow, aeval_X]
+    rw [hkey, sub_self]
+  obtain ⟨B, hAB, hIB⟩ := Ideal.image_subset_nonunits_valuationSubring I hI
+  have hwB : w⁻¹ ∈ B.nonunits := by
+    apply hIB
+    refine ⟨⟨w⁻¹, hwS⟩, ?_, rfl⟩
+    exact Ideal.subset_span (Set.mem_singleton _)
+  have hwB' : w ∉ B := by
+    intro hw
+    rw [ValuationSubring.mem_nonunits_iff] at hwB
+    have h1 : B.valuation w ≤ 1 := (B.valuation_le_one_iff w).mpr hw
+    have h2 : B.valuation w ≠ 0 := by
+      rw [Valuation.ne_zero_iff]; exact hw0
+    have h3 : B.valuation w⁻¹ = (B.valuation w)⁻¹ := map_inv₀ _ _
+    rw [h3] at hwB
+    have h4 : 1 ≤ (B.valuation w)⁻¹ := one_le_inv_iff₀.mpr ⟨zero_lt_iff.mpr h2, h1⟩
+    exact absurd (lt_of_le_of_lt h4 hwB) (lt_irrefl _)
+  apply hwB'
+  apply h
+  intro r
+  apply hAB
+  change algebraMap R L r ∈ S
+  exact S.algebraMap_mem r
+
+end Algebra
+
+section CFE
+
+variable {K F K' F' : Type*} [Field K] [Field F] [Field K'] [Field F'] [Algebra K F]
+  [Algebra K' F'] [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F']
+  [IsScalarTower K F F']
+
+theorem degree_eq_sum [IsAlgClosed K] [IsCurveOver K F] (E : Divisor K F) :
+    E.degree = E.sum fun _ n => n := by
+  simp [Divisor.degree, Finsupp.liftAddHom_apply, IsCurveOver.deg_eq_one_of_isAlgClosed]
+
+theorem algebraMap_mem_adjoin_simple {x a : F}
+    (ha : a ∈ IntermediateField.adjoin K ({x} : Set F)) :
+    algebraMap F F' a ∈ IntermediateField.adjoin K' ({algebraMap F F' x} : Set F') := by
+  rw [IntermediateField.mem_adjoin_simple_iff] at ha ⊢
+  obtain ⟨r, s, rfl⟩ := ha
+  refine ⟨r.map (algebraMap K K'), s.map (algebraMap K K'), ?_⟩
+  rw [aeval_map_algebraMap, aeval_map_algebraMap, map_div₀, aeval_algebraMap_apply,
+    aeval_algebraMap_apply]
+
+theorem mem_range_of_isAlgebraic [IsAlgClosed K'] {t : F'} (ht : IsAlgebraic K' t) :
+    t ∈ (algebraMap K' F').range := by
+  have hint : IsIntegral K' t := ht.isIntegral
+  exact minpoly.mem_range_of_degree_eq_one K' _
+    (IsAlgClosed.degree_eq_one_of_irreducible K' (minpoly.irreducible hint))
+
+theorem transcendental_algebraMap [IsAlgClosed K] [IsAlgClosed K']
+    (hfg : ∃ x : F, Transcendental K x ∧
+      FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    [IsCurveOver K F]
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤)
+    {x : F} (hx : Transcendental K x) :
+    Transcendental K' (algebraMap F F' x) := by
+  obtain ⟨j, hj, hfin⟩ := id hfg
+  have := hfin
+  obtain ⟨v, hv⟩ : ∃ v : Place K F, v.ord x ≠ 0 := by
+    by_contra h
+    push Not at h
+    obtain ⟨a, ha⟩ := Place.mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed j hj h
+    exact hx (ha ▸ isAlgebraic_algebraMap a)
+  obtain ⟨P', -, hord, -⟩ :=
+    Place.exists_comap_algebraMap_eq_of_constantFieldExtension_of_isAlgClosed K F K' F' hfg hfg'
+      hgen v
+  intro halg
+  obtain ⟨a, ha⟩ := mem_range_of_isAlgebraic halg
+  have h1 := hord x
+  rw [← ha, ord_algebraMap] at h1
+  exact hv h1.symm
+
+theorem algebraMap_mem_of_new (x : F)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F]
+    (W : Place K' F')
+    (hW : ∀ v : Place K F, W.toValuationSubring.comap (algebraMap F F') ≠ v.toValuationSubring)
+    (f : F) : algebraMap F F' f ∈ W.toValuationSubring := by
+  by_contra hf
+  set A := W.toValuationSubring.comap (algebraMap F F') with hA
+  have hAK : ∀ a : K, algebraMap K F a ∈ A := fun a => by
+    rw [hA, ValuationSubring.mem_comap, ← IsScalarTower.algebraMap_apply,
+      IsScalarTower.algebraMap_apply K K' F']
+    exact W.algebraMap_mem' _
+  have hAtop : A ≠ ⊤ := by
+    intro h
+    apply hf
+    have : f ∈ A := h ▸ Subring.mem_top f
+    exact (ValuationSubring.mem_comap).1 this
+  have hfA : f ∉ A := fun h => hf ((ValuationSubring.mem_comap).mp (hA ▸ h))
+  obtain ⟨v, hv₀⟩ := Place.exists_toValuationSubring_eq_comap_ringHom_of_isSeparable
+      (K := K) x (RingHom.id F) A hAK ⟨f, hfA⟩
+  have hv : v.toValuationSubring = A := by
+    rw [hv₀]; ext g; simp [ValuationSubring.mem_comap]
+  exact hW v hv.symm
+
+theorem exists_ord_sub_pos [IsAlgClosed K'] [IsCurveOver K' F']
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    {x' : F'} (hx' : Transcendental K' x') (c : K') :
+    ∃ v' : Place K' F', 0 < v'.ord (x' - algebraMap K' F' c) := by
+  classical
+  obtain ⟨j, hj, hfin⟩ := id hfg'
+  have := hfin
+  set u := x' - algebraMap K' F' c with hu
+  have hu_nmem : u ∉ (algebraMap K' F').range := by
+    rintro ⟨a, ha⟩
+    apply hx'
+    have : x' = algebraMap K' F' (a + c) := by rw [map_add, ha, hu]; ring
+    rw [this]
+    exact isAlgebraic_algebraMap _
+  have hu0 : u ≠ 0 := fun h => hu_nmem ⟨0, by rw [map_zero, h]⟩
+  obtain ⟨v₀, hv₀⟩ : ∃ v : Place K' F', v.ord u ≠ 0 := by
+    by_contra h
+    push Not at h
+    exact hu_nmem (Place.mem_range_algebraMap_of_forall_ord_eq_zero_of_isAlgClosed j hj h)
+  by_contra hneg
+  push Not at hneg
+  obtain ⟨D, hD, hdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K') u hu0
+  have hdeg' : (D.sum fun _ n => n) = 0 := by rw [← degree_eq_sum, hdeg]
+  rw [Finsupp.sum] at hdeg'
+  have hall := (Finset.sum_eq_zero_iff_of_nonpos (fun v _ => by rw [hD]; exact hneg v)).1 hdeg'
+  have hv₀mem : v₀ ∈ D.support := by rw [Finsupp.mem_support_iff, hD]; exact hv₀
+  exact hv₀ (by rw [← hD]; exact hall v₀ hv₀mem)
+
+theorem trace_mem [IsAlgClosed K] [IsAlgClosed K'] [IsCurveOver K F] [IsCurveOver K' F']
+    {x : F} (hx : Transcendental K x)
+    (hfg' : ∃ j : F', Transcendental K' j ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({j} : Set F')) F')
+    [FiniteDimensional (IntermediateField.adjoin K' ({algebraMap F F' x} : Set F')) F']
+    {c : K'} (hc : c ∉ Set.range (algebraMap K K'))
+    (v' : Place K' F') (hv' : 0 < v'.ord (algebraMap F F' x - algebraMap K' F' c))
+    (w : F')
+    (hw : ∀ W : Place K' F',
+      (∀ v : Place K F, W.toValuationSubring.comap (algebraMap F F') ≠ v.toValuationSubring) →
+        w ∈ W.toValuationSubring) :
+    ((Algebra.trace (IntermediateField.adjoin K' ({algebraMap F F' x} : Set F')) F' w :
+      IntermediateField.adjoin K' ({algebraMap F F' x} : Set F')) : F') ∈ v'.toValuationSubring
+        := by
+  set x' := algebraMap F F' x with hx'
+  set kx' : IntermediateField K' F' := IntermediateField.adjoin K' ({x'} : Set F') with hkx'
+  set R : ValuationSubring kx' := v'.toValuationSubring.comap (algebraMap kx' F') with hR
+  have hRmem : ∀ g : kx', g ∈ R ↔ (g : F') ∈ v'.toValuationSubring := fun g =>
+    ValuationSubring.mem_comap
+  have hx'c_mem : x' - algebraMap K' F' c ∈ v'.toValuationSubring := mem_of_ord_nonneg v' hv'.le
+  have hx'v' : x' ∈ v'.toValuationSubring := by
+    have := add_mem hx'c_mem (v'.algebraMap_mem' c)
+    simpa using this
+  have hx'k : x' ∈ kx' := IntermediateField.mem_adjoin_simple_self K' x'
+  have hnew : ∀ W : Place K' F',
+      (∀ g : F', g ∈ kx' → g ∈ v'.toValuationSubring → g ∈ W.toValuationSubring) →
+      ∀ v : Place K F, W.toValuationSubring.comap (algebraMap F F') ≠ v.toValuationSubring := by
+    intro W hmemW v heq
+    have hcomap : ∀ f : F, f ∈ v.toValuationSubring ↔ algebraMap F F' f ∈ W.toValuationSubring := by
+      intro f
+      rw [← heq, ValuationSubring.mem_comap]
+    have hxv : x ∈ v.toValuationSubring := (hcomap x).2 (hmemW x' hx'k hx'v')
+    obtain ⟨a, ha⟩ := exists_ord_sub_algebraMap_pos v hxv
+    rcases ha with ha | ha
+    · exact hx (ha ▸ isAlgebraic_algebraMap a)
+    set u := x - algebraMap K F a with hu
+    have hui : u⁻¹ ∉ v.toValuationSubring := not_mem_of_ord_neg v (by rw [v.ord_inv]; omega)
+    apply hui
+    rw [hcomap, map_inv₀]
+    have hφu : algebraMap F F' u = x' - algebraMap K' F' (algebraMap K K' a) := by
+      rw [hu, map_sub, ← IsScalarTower.algebraMap_apply, ← IsScalarTower.algebraMap_apply]
+    have hca : c - algebraMap K K' a ≠ 0 := by
+      intro h
+      exact hc ⟨a, (sub_eq_zero.mp h).symm⟩
+    have hord0 : v'.ord (algebraMap F F' u) = 0 := by
+      rw [hφu]
+      have : x' - algebraMap K' F' (algebraMap K K' a) =
+          algebraMap K' F' (c - algebraMap K K' a) + (x' - algebraMap K' F' c) := by
+        rw [map_sub]; ring
+      rw [this]
+      exact ord_algebraMap_add_eq_zero v' hca hv'
+    apply hmemW
+    · rw [hφu]
+      exact inv_mem (sub_mem hx'k (kx'.algebraMap_mem _))
+    · apply mem_of_ord_nonneg
+      rw [v'.ord_inv, hord0, neg_zero]
+  have hint : IsIntegral R w := by
+    apply isIntegral_of_forall_mem_valuationSubring
+    intro B hB
+    have hB' : ∀ g : F', g ∈ kx' → g ∈ v'.toValuationSubring → g ∈ B := by
+      intro g hg1 hg2
+      exact hB ⟨⟨g, hg1⟩, (hRmem _).2 hg2⟩
+    by_contra hwB
+    have hBtop : B ≠ ⊤ := fun h => hwB (h ▸ Subring.mem_top w)
+    have hBK : ∀ a : K', algebraMap K' F' a ∈ B := fun a =>
+      hB' _ (kx'.algebraMap_mem a) (v'.algebraMap_mem' a)
+    obtain ⟨j₀, hj₀, hfin₀⟩ := id hfg'
+    obtain ⟨j, _hj, hfin, hsep_j⟩ :=
+      AlgebraicCurve.exists_separating_transcendental_of_perfectField hj₀ hfin₀
+    have := hfin; have := hsep_j
+    obtain ⟨W, hW₀⟩ :=
+      Place.exists_toValuationSubring_eq_comap_ringHom_of_isSeparable
+        (K := K') j (RingHom.id F') B (by simpa using hBK) ⟨w, by simpa using hwB⟩
+    have hW : W.toValuationSubring = B := by
+      rw [hW₀]; ext g; simp [ValuationSubring.mem_comap]
+    have hWnew := hnew W (fun g hg1 hg2 => by rw [hW]; exact hB' g hg1 hg2)
+    exact hwB (hW ▸ hw W hWnew)
+  have htr : IsIntegral R (Algebra.trace kx' F' w) := Algebra.isIntegral_trace hint
+  obtain ⟨y, hy⟩ := (IsIntegrallyClosed.isIntegral_iff (R := R) (K := kx')).mp htr
+  have hmem : Algebra.trace kx' F' w ∈ R := hy ▸ y.2
+  exact (hRmem _).1 hmem
+
+end CFE
+
+section PF
+
+variable {K F K' F' : Type*} [Field K] [Field F] [Field K'] [Field F'] [Algebra K F]
+  [Algebra K' F'] [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F']
+  [IsScalarTower K F F']
+
+variable (F F') in
+theorem span_range_eq_adjoin (R : Type*) [CommSemiring R] [Algebra R F'] :
+    Subalgebra.toSubmodule (Algebra.adjoin R (Set.range (algebraMap F F'))) =
+      Submodule.span R (Set.range (algebraMap F F')) := by
+  rw [Algebra.adjoin_eq_span]
+  have : Set.range (algebraMap F F') = ((algebraMap F F').range.toSubmonoid : Set F') := by
+    ext y; simp
+  rw [this, Submonoid.closure_eq]
+
+theorem mem_span_of_regular [IsAlgClosed K'] [IsCurveOver K' F']
+    (hfg' : ∃ j : F', Transcendental K' j ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({j} : Set F')) F')
+    {x : F} (hx' : Transcendental K' (algebraMap F F' x))
+    {t : F'} (ht : t ∈ IntermediateField.adjoin K' ({algebraMap F F' x} : Set F'))
+    (hreg : ∀ c : K', c ∉ Set.range (algebraMap K K') →
+      ∀ v' : Place K' F', 0 < v'.ord (algebraMap F F' x - algebraMap K' F' c) → 0 ≤ v'.ord t) :
+    t ∈ Submodule.span K' (Set.range (algebraMap F F')) := by
+  classical
+  set x' := algebraMap F F' x with hx'def
+  rcases eq_or_ne t 0 with rfl | ht0
+  · exact zero_mem _
+  rw [IntermediateField.mem_adjoin_simple_iff] at ht
+  obtain ⟨p₀, q₀, hpq₀⟩ := ht
+  have hq₀0 : q₀ ≠ 0 := by
+    rintro rfl
+    apply ht0
+    rw [hpq₀, map_zero, div_zero]
+  have haq₀ : aeval x' q₀ ≠ 0 := by
+    intro h
+    apply ht0
+    rw [hpq₀, h, div_zero]
+  set g := gcd p₀ q₀ with hg
+  have hg0 : g ≠ 0 := fun h => hq₀0 ((gcd_eq_zero_iff p₀ q₀).1 h).2
+  set p := p₀ / g with hp
+  set q := q₀ / g with hq
+  have hcop : IsCoprime p q := isCoprime_div_gcd_div_gcd hq₀0
+  have hp₀ : p₀ = g * p := (EuclideanDomain.mul_div_cancel' hg0 (gcd_dvd_left _ _)).symm
+  have hq₀' : q₀ = g * q := (EuclideanDomain.mul_div_cancel' hg0 (gcd_dvd_right _ _)).symm
+  have hag : aeval x' g ≠ 0 := by
+    intro h
+    apply haq₀
+    rw [hq₀', map_mul, h, zero_mul]
+  have haq : aeval x' q ≠ 0 := by
+    intro h
+    apply haq₀
+    rw [hq₀', map_mul, h, mul_zero]
+  have hq0 : q ≠ 0 := by
+    rintro h
+    exact haq (by rw [h, map_zero])
+  have ht' : t = aeval x' p / aeval x' q := by
+    rw [hpq₀, hp₀, hq₀', map_mul, map_mul, mul_div_mul_left _ _ hag]
+  have hap : aeval x' p ≠ 0 := by
+    intro h
+    apply ht0
+    rw [ht', h, zero_div]
+  have hroots : ∀ c ∈ q.roots, c ∈ Set.range (algebraMap K K') := by
+    intro c hc
+    by_contra hcK
+    have hqc : q.IsRoot c := (mem_roots hq0).1 hc
+    obtain ⟨v', hv'⟩ := exists_ord_sub_pos hfg' hx' c
+    have h0t := hreg c hcK v' hv'
+    have hsub_ne : x' - algebraMap K' F' c ≠ 0 := by
+      intro h
+      rw [h, Place.ord_zero] at hv'
+      exact lt_irrefl _ hv'
+    have hx'mem : x' ∈ v'.toValuationSubring := by
+      have := add_mem (mem_of_ord_nonneg v' hv'.le) (v'.algebraMap_mem' c)
+      simpa using this
+    obtain ⟨q₂, hq₂⟩ := dvd_iff_isRoot.2 hqc
+    have haq2_ne : aeval x' q₂ ≠ 0 := by
+      intro h
+      apply haq
+      rw [hq₂, map_mul, h, mul_zero]
+    have hordq : 1 ≤ v'.ord (aeval x' q) := by
+      rw [hq₂, map_mul, map_sub, aeval_X, aeval_C, v'.ord_mul hsub_ne haq2_ne]
+      have := ord_nonneg_of_mem v' (aeval_mem v' hx'mem q₂)
+      omega
+    have hpc : eval c p ≠ 0 := by
+      intro h
+      exact Polynomial.not_isUnit_X_sub_C c
+        (hcop.isUnit_of_dvd' (dvd_iff_isRoot.2 h) (dvd_iff_isRoot.2 hqc))
+    have hordp : v'.ord (aeval x' p) = 0 := by
+      have hp_eq : p = C (eval c p) + (X - C c) * (p /ₘ (X - C c)) := by
+        have := modByMonic_add_div p (X - C c)
+        rw [modByMonic_X_sub_C_eq_C_eval] at this
+        exact this.symm
+      rcases eq_or_ne (aeval x' (p /ₘ (X - C c))) 0 with h2 | h2
+      · rw [hp_eq, map_add, map_mul, h2, mul_zero, add_zero, aeval_C, ord_algebraMap]
+      · rw [hp_eq, map_add, map_mul, aeval_C, map_sub, aeval_X, aeval_C]
+        apply ord_algebraMap_add_eq_zero v' hpc
+        rw [v'.ord_mul hsub_ne h2]
+        have := ord_nonneg_of_mem v' (aeval_mem v' hx'mem (p /ₘ (X - C c)))
+        omega
+    have : v'.ord t = v'.ord (aeval x' p) - v'.ord (aeval x' q) := by
+      rw [ht', div_eq_mul_inv, v'.ord_mul hap (inv_ne_zero haq), v'.ord_inv]
+      ring
+    omega
+  set A : Subalgebra K' F' := Algebra.adjoin K' (Set.range (algebraMap F F')) with hA
+  suffices hmem : t ∈ A by
+    have : t ∈ Subalgebra.toSubmodule A := hmem
+    rwa [span_range_eq_adjoin] at this
+  have hφA : ∀ f : F, algebraMap F F' f ∈ A := fun f => Algebra.subset_adjoin ⟨f, rfl⟩
+  have hx'A : x' ∈ A := hφA x
+  have hpA : aeval x' p ∈ A := by
+    rw [aeval_eq_sum_range]
+    exact Subalgebra.sum_mem _ fun i _ => Subalgebra.smul_mem _ (Subalgebra.pow_mem _ hx'A _) _
+  have hsplit : Multiset.card q.roots = q.natDegree :=
+    splits_iff_card_roots.1 (IsAlgClosed.splits q)
+  have hq_eq := C_leadingCoeff_mul_prod_multiset_X_sub_C hsplit
+  have hlc : q.leadingCoeff ≠ 0 := leadingCoeff_ne_zero.2 hq0
+  have hprod : aeval x' (q.roots.map fun c => X - C c).prod =
+      (q.roots.map fun c => x' - algebraMap K' F' c).prod := by
+    rw [map_multiset_prod, Multiset.map_map]
+    congr 1
+    apply Multiset.map_congr rfl
+    intro c _
+    simp
+  have hinvA : (aeval x' q)⁻¹ ∈ A := by
+    rw [← hq_eq, map_mul, aeval_C, hprod, mul_inv, ← Multiset.prod_map_inv]
+    refine Subalgebra.mul_mem _ ?_ ?_
+    · rw [← map_inv₀]
+      exact A.algebraMap_mem _
+    · refine multiset_prod_mem _ (fun y hy => ?_)
+      rw [Multiset.mem_map] at hy
+      obtain ⟨c, hc, rfl⟩ := hy
+      obtain ⟨a, rfl⟩ := hroots c hc
+      have : (x' - algebraMap K' F' (algebraMap K K' a))⁻¹ =
+          algebraMap F F' (x - algebraMap K F a)⁻¹ := by
+        rw [map_inv₀, map_sub, ← IsScalarTower.algebraMap_apply,
+          ← IsScalarTower.algebraMap_apply]
+      rw [this]
+      exact hφA _
+  rw [ht', div_eq_mul_inv]
+  exact A.mul_mem hpA hinvA
+
+end PF
+
+section BaseChange
+
+variable {K F K' F' : Type*} [Field K] [Field F] [Field K'] [Field F'] [Algebra K F]
+  [Algebra K' F'] [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F']
+  [IsScalarTower K F F']
+
+variable (K K' F') in
+def iota (x : F) :
+    IntermediateField.adjoin K ({x} : Set F) →+*
+      IntermediateField.adjoin K' ({algebraMap F F' x} : Set F') where
+  toFun a := ⟨algebraMap F F' a, algebraMap_mem_adjoin_simple a.2⟩
+  map_one' := Subtype.ext (by simp)
+  map_mul' a b := Subtype.ext (by simp)
+  map_zero' := Subtype.ext (by simp)
+  map_add' a b := Subtype.ext (by simp)
+
+@[scoped simp] theorem coe_iota (x : F) (a : IntermediateField.adjoin K ({x} : Set F)) :
+    ((iota K K' F' x a : IntermediateField.adjoin K' ({algebraMap F F' x} : Set F')) : F') =
+      algebraMap F F' a := rfl
+
+theorem algebraMap_smul (x : F) (a : IntermediateField.adjoin K ({x} : Set F)) (f : F) :
+    algebraMap F F' (a • f) = iota K K' F' x a • algebraMap F F' f := by
+  rw [Algebra.smul_def, Algebra.smul_def, map_mul]
+  rfl
+
+theorem exists_basis [IsAlgClosed K] [IsAlgClosed K']
+    (hfg : ∃ x : F, Transcendental K x ∧
+      FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    [IsCurveOver K F]
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤)
+    {x : F} (hx : Transcendental K x)
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    {n : ℕ} (y : Module.Basis (Fin n) (IntermediateField.adjoin K ({x} : Set F)) F) :
+    ∃ y' : Module.Basis (Fin n) (IntermediateField.adjoin K' ({algebraMap F F' x} : Set F')) F',
+      ∀ i, y' i = algebraMap F F' (y i) := by
+  classical
+  let kx : IntermediateField K F := IntermediateField.adjoin K ({x} : Set F)
+  set x' := algebraMap F F' x with hx'def
+  set kx' : IntermediateField K' F' := IntermediateField.adjoin K' ({x'} : Set F') with hkx'
+  have hx' : Transcendental K' x' := transcendental_algebraMap hfg hfg' hgen hx
+  have hli : LinearIndependent kx' (fun i => algebraMap F F' (y i)) := by
+    rw [linearIndependent_iff']
+    intro s r hr i hi
+    have hden : ∀ i, ∃ b : K'[X], aeval x' b ≠ 0 ∧
+        ∃ P : K'[X], aeval x' b * (r i : F') = aeval x' P := by
+      intro i
+      have hri : (r i : F') ∈ IntermediateField.adjoin K' ({x'} : Set F') := (r i).2
+      rw [IntermediateField.mem_adjoin_simple_iff] at hri
+      obtain ⟨P, b, hPb⟩ := hri
+      by_cases hb : aeval x' b = 0
+      · refine ⟨1, by simp, 0, ?_⟩
+        rw [hPb, hb, div_zero]
+        simp
+      · exact ⟨b, hb, P, by rw [hPb, mul_div_cancel₀ _ hb]⟩
+    choose b hb P hP using hden
+    set B := ∏ j, aeval x' (b j) with hB
+    have hB0 : B ≠ 0 := Finset.prod_ne_zero_iff.2 fun j _ => hb j
+    set Q : Fin n → K'[X] := fun i => (∏ j ∈ Finset.univ.erase i, b j) * P i with hQ
+    have hBQ : ∀ i, B * (r i : F') = aeval x' (Q i) := by
+      intro i
+      simp only [hQ]
+      rw [map_mul, map_prod, ← hP i, ← mul_assoc, hB,
+        Finset.prod_erase_mul _ _ (Finset.mem_univ i)]
+    set N := (Finset.univ.sup fun i => (Q i).natDegree) + 1 with hN
+    have hQN : ∀ i, (Q i).natDegree < N := fun i =>
+      Nat.lt_succ_of_le (Finset.le_sup (f := fun i => (Q i).natDegree) (Finset.mem_univ i))
+    have hrel : ∑ p ∈ Finset.range N ×ˢ s,
+        algebraMap K' F' ((Q p.2).coeff p.1) * algebraMap F F' (x ^ p.1 * y p.2) = 0 := by
+      have h0 : ∑ i ∈ s, (r i : F') * algebraMap F F' (y i) = 0 := by
+        simpa [Algebra.smul_def] using hr
+      have h1 : ∑ i ∈ s, aeval x' (Q i) * algebraMap F F' (y i) = 0 := by
+        have : ∑ i ∈ s, aeval x' (Q i) * algebraMap F F' (y i) =
+            B * ∑ i ∈ s, (r i : F') * algebraMap F F' (y i) := by
+          rw [Finset.mul_sum]
+          refine Finset.sum_congr rfl fun i _ => ?_
+          rw [← hBQ, mul_assoc]
+        rw [this, h0, mul_zero]
+      rw [Finset.sum_product_right, ← h1]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [aeval_def, eval₂_eq_sum_range' _ (hQN i), Finset.sum_mul]
+      refine Finset.sum_congr rfl fun a _ => ?_
+      rw [map_mul, map_pow]
+      ring
+    have hKind : LinearIndependent K (fun p : ℕ × Fin n => x ^ p.1 * y p.2) := by
+      have hxk : Transcendental K (⟨x, IntermediateField.mem_adjoin_simple_self K x⟩ : kx) := by
+        rw [← transcendental_algebraMap_iff (FaithfulSMul.algebraMap_injective kx F)]
+        exact hx
+      have h1 := linearIndependent_pow_of_transcendental hxk
+      have h2 := linearIndependent_smul h1 y.linearIndependent
+      convert h2 using 1
+    have hK'ind := AlgebraicCurve.linearIndependent_of_constantFieldExtension_of_isAlgClosed
+      K F K' F' hfg hfg' hgen hKind
+    have hrel' : ∑ p ∈ Finset.range N ×ˢ s,
+        (Q p.2).coeff p.1 • algebraMap F F' (x ^ p.1 * y p.2) = 0 := by
+      simpa only [Algebra.smul_def] using hrel
+    have hcoeff := (linearIndependent_iff'.1 hK'ind) _ _ hrel'
+    have hQi : Q i = 0 := by
+      ext a
+      rw [coeff_zero]
+      by_cases ha : a < N
+      · exact hcoeff (a, i) (Finset.mk_mem_product (Finset.mem_range.2 ha) hi)
+      · exact coeff_eq_zero_of_natDegree_lt (lt_of_lt_of_le (hQN i) (not_lt.1 ha))
+    have h1 : B * (r i : F') = 0 := by rw [hBQ, hQi, map_zero]
+    have h2 : (r i : F') = 0 := (mul_eq_zero.1 h1).resolve_left hB0
+    exact_mod_cast h2
+  have hsp : ⊤ ≤ Submodule.span kx' (Set.range fun i => algebraMap F F' (y i)) := by
+    have hφ : ∀ f : F, algebraMap F F' f ∈
+        Submodule.span kx' (Set.range fun i => algebraMap F F' (y i)) := by
+      intro f
+      rw [← y.sum_repr f, map_sum]
+      refine Submodule.sum_mem _ fun i _ => ?_
+      rw [algebraMap_smul (K' := K') (F' := F')]
+      exact Submodule.smul_mem _ _ (Submodule.subset_span ⟨i, rfl⟩)
+    have : Algebra.IsIntegral kx F := Algebra.IsIntegral.of_finite kx F
+    have halg : ∀ g ∈ Set.range (algebraMap F F'), IsAlgebraic kx' g := by
+      rintro _ ⟨f, rfl⟩
+      have hint : IsIntegral kx f := Algebra.IsIntegral.isIntegral f
+      have : IsIntegral kx' (algebraMap F F' f) := by
+        refine ⟨(minpoly kx f).map (iota K K' F' x), (minpoly.monic hint).map _, ?_⟩
+        rw [eval₂_map]
+        have hcomp : (algebraMap kx' F').comp (iota K K' F' x) =
+            (algebraMap F F').comp (algebraMap kx F) := by
+          ext a
+          rfl
+        rw [hcomp, ← hom_eval₂, ← aeval_def, minpoly.aeval, map_zero]
+      exact this.isAlgebraic
+    have hmem : ∀ z : F', z ∈ Submodule.span kx' (Set.range (algebraMap F F')) := by
+      intro z
+      set E : IntermediateField kx' F' := IntermediateField.adjoin kx' (Set.range (algebraMap F F'))
+        with hE
+      have hzE : z ∈ E := by
+        have hle : IntermediateField.adjoin K' (Set.range (algebraMap F F')) ≤
+            IntermediateField.restrictScalars K' E :=
+          IntermediateField.adjoin_le_iff.mpr (IntermediateField.subset_adjoin _ _)
+        have := hle (hgen ▸ IntermediateField.mem_top (x := z))
+        exact (IntermediateField.mem_restrictScalars K').1 this
+      have hzA : z ∈ Algebra.adjoin kx' (Set.range (algebraMap F F')) := by
+        rw [← IntermediateField.adjoin_toSubalgebra_of_isAlgebraic halg]
+        exact hzE
+      have : z ∈ Subalgebra.toSubmodule (Algebra.adjoin kx' (Set.range (algebraMap F F'))) := hzA
+      rwa [span_range_eq_adjoin] at this
+    intro z _
+    have := hmem z
+    refine (Submodule.span_le.2 ?_) this
+    rintro _ ⟨f, rfl⟩
+    exact hφ f
+  exact ⟨Module.Basis.mk hli hsp, fun i => by rw [Module.Basis.mk_apply]⟩
+
+theorem trace_algebraMap {x : F} {n : ℕ}
+    (y : Module.Basis (Fin n) (IntermediateField.adjoin K ({x} : Set F)) F)
+    (y' : Module.Basis (Fin n) (IntermediateField.adjoin K' ({algebraMap F F' x} : Set F')) F')
+    (hy : ∀ i, y' i = algebraMap F F' (y i)) (f : F) :
+    Algebra.trace (IntermediateField.adjoin K' ({algebraMap F F' x} : Set F')) F'
+        (algebraMap F F' f) =
+      iota K K' F' x (Algebra.trace (IntermediateField.adjoin K ({x} : Set F)) F f) := by
+  classical
+  have hrepr : ∀ g : F, ∀ i, y'.repr (algebraMap F F' g) i = iota K K' F' x (y.repr g i) := by
+    intro g i
+    have : algebraMap F F' g = ∑ j, iota K K' F' x (y.repr g j) • y' j := by
+      conv_lhs => rw [← y.sum_repr g, map_sum]
+      refine Finset.sum_congr rfl fun j _ => ?_
+      rw [algebraMap_smul (K' := K') (F' := F'), hy]
+    rw [this, y'.repr_sum_self]
+  rw [Algebra.trace_eq_matrix_trace y, Algebra.trace_eq_matrix_trace y']
+  simp only [Matrix.trace, Matrix.diag, map_sum]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [Algebra.leftMulMatrix_eq_repr_mul, Algebra.leftMulMatrix_eq_repr_mul, hy, ← map_mul,
+    hrepr]
+
+theorem eq_sum_trace_mul {x : F} {n : ℕ}
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F]
+    [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F]
+    (y : Module.Basis (Fin n) (IntermediateField.adjoin K ({x} : Set F)) F)
+    (y' : Module.Basis (Fin n) (IntermediateField.adjoin K' ({algebraMap F F' x} : Set F')) F')
+    (hy : ∀ i, y' i = algebraMap F F' (y i)) (z : F') :
+    z = ∑ i, (Algebra.trace (IntermediateField.adjoin K' ({algebraMap F F' x} : Set F')) F'
+        (z * algebraMap F F'
+          ((Algebra.traceForm (IntermediateField.adjoin K ({x} : Set F)) F).dualBasis
+            (traceForm_nondegenerate _ F) y i)) : F') * algebraMap F F' (y i) := by
+  classical
+  let kx : IntermediateField K F := IntermediateField.adjoin K ({x} : Set F)
+  let kx' : IntermediateField K' F' := IntermediateField.adjoin K' ({algebraMap F F' x} : Set F')
+  set yd := (Algebra.traceForm kx F).dualBasis (traceForm_nondegenerate kx F) y with hyd
+  suffices h : ∀ i, y'.repr z i = Algebra.trace kx' F' (z * algebraMap F F' (yd i)) by
+    conv_lhs => rw [← y'.sum_repr z]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [h i, Algebra.smul_def, hy]
+    rfl
+  intro i
+  let L₁ : F' →ₗ[kx'] kx' := y'.coord i
+  let L₂ : F' →ₗ[kx'] kx' :=
+    (Algebra.trace kx' F') ∘ₗ (LinearMap.mulRight kx' (algebraMap F F' (yd i)))
+  have hL : L₁ = L₂ := by
+    refine y'.ext fun j => ?_
+    simp only [L₁, L₂, Module.Basis.coord_apply, Module.Basis.repr_self, LinearMap.comp_apply,
+      LinearMap.mulRight_apply]
+    rw [hy, ← map_mul, mul_comm, trace_algebraMap y y' hy, ← Algebra.traceForm_apply, hyd,
+      LinearMap.BilinForm.apply_dualBasis_left]
+    split_ifs with h
+    · subst h
+      simp
+    · rw [map_zero, Finsupp.single_apply, ite_eq_right h]
+  exact LinearMap.congr_fun hL z
+
+end BaseChange
+
+section Main
+
+theorem mem_span_range_algebraMap_of_constantFieldExtension
+    (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [IsAlgClosed K']
+    (hfg : ∃ x : F, Transcendental K x ∧ FiniteDimensional (IntermediateField.adjoin K ({x} : Set
+      F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    [IsCurveOver K F] [IsCurveOver K' F']
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤)
+    (z : F')
+    (hz : ∀ v' : Place K' F',
+      (∀ v : Place K F, v'.toValuationSubring.comap (algebraMap F F') ≠ v.toValuationSubring) →
+        z ∈ v'.toValuationSubring) :
+    z ∈ Submodule.span K' (Set.range (algebraMap F F')) := by
+  classical
+  obtain ⟨x₀, hx₀, hfin₀⟩ := id hfg
+  obtain ⟨x, hx, hfin, hsep_kx⟩ :=
+    AlgebraicCurve.exists_separating_transcendental_of_perfectField hx₀ hfin₀
+  have := hfin
+  set kx : IntermediateField K F := IntermediateField.adjoin K ({x} : Set F) with hkx
+  set x' := algebraMap F F' x with hx'def
+  set kx' : IntermediateField K' F' := IntermediateField.adjoin K' ({x'} : Set F') with hkx'
+  have : Algebra.IsSeparable kx F := hsep_kx
+  have hx' : Transcendental K' x' := transcendental_algebraMap hfg hfg' hgen hx
+  let y : Module.Basis (Fin (Module.finrank kx F)) kx F := Module.finBasis kx F
+  obtain ⟨y', hy⟩ := exists_basis hfg hfg' hgen hx y
+  have : FiniteDimensional kx' F' := Module.Finite.of_basis y'
+  set yd := (Algebra.traceForm kx F).dualBasis (traceForm_nondegenerate kx F) y with hyd
+  have ht : ∀ i, ((Algebra.trace kx' F' (z * algebraMap F F' (yd i)) : kx') : F') ∈
+      Submodule.span K' (Set.range (algebraMap F F')) := by
+    intro i
+    refine mem_span_of_regular (K := K) hfg' hx' (Subtype.mem _) ?_
+    intro c hc v' hv'
+    apply ord_nonneg_of_mem
+    apply trace_mem hx hfg' hc v' hv'
+    intro W hW
+    exact mul_mem (hz W hW) (algebraMap_mem_of_new x W hW _)
+  have hA : ∀ t, t ∈ Submodule.span K' (Set.range (algebraMap F F')) → ∀ f : F,
+      t * algebraMap F F' f ∈ Submodule.span K' (Set.range (algebraMap F F')) := by
+    intro t ht f
+    rw [← span_range_eq_adjoin] at ht ⊢
+    exact (Algebra.adjoin K' _).mul_mem ht (Algebra.subset_adjoin ⟨f, rfl⟩)
+  rw [eq_sum_trace_mul y y' hy z]
+  exact Submodule.sum_mem _ fun i _ => hA _ (ht i) _
+
+end Main
+
+end AlgebraicCurve.W7XH
+
+theorem solution
+    (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [IsAlgClosed K']
+    (hfg : ∃ x : F, Transcendental K x ∧ FiniteDimensional (IntermediateField.adjoin K ({x} : Set
+      F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    [IsCurveOver K F] [IsCurveOver K' F']
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤)
+    (z : F')
+    (hz : ∀ v' : Place K' F',
+      (∀ v : Place K F, v'.toValuationSubring.comap (algebraMap F F') ≠ v.toValuationSubring) →
+        z ∈ v'.toValuationSubring) :
+    z ∈ Submodule.span K' (Set.range (algebraMap F F')) :=
+  AlgebraicCurve.W7XH.mem_span_range_algebraMap_of_constantFieldExtension K F K' F' hfg hfg' hgen z
+    hz
+
+end S_AlgebraicCurve_mem_span_range_algebraMap_of_constantFieldExtension_of_isAlgClosed
+end P2MW
+export P2MW.S_AlgebraicCurve_mem_span_range_algebraMap_of_constantFieldExtension_of_isAlgClosed
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.mem_span_range_algebraMap_of_constantFieldExtension_of_isAlgClosed
+    (K F K' F' : Type*)
+    [Field K] [Field F] [Field K'] [Field F'] [Algebra K F] [Algebra K' F']
+    [Algebra K K'] [Algebra F F'] [Algebra K F'] [IsScalarTower K K' F'] [IsScalarTower K F F']
+    [IsAlgClosed K] [IsAlgClosed K']
+    (hfg : ∃ x : F, Transcendental K x ∧ FiniteDimensional (IntermediateField.adjoin K ({x} : Set
+      F)) F)
+    (hfg' : ∃ x : F', Transcendental K' x ∧
+      FiniteDimensional (IntermediateField.adjoin K' ({x} : Set F')) F')
+    [IsCurveOver K F] [IsCurveOver K' F']
+    (hgen : IntermediateField.adjoin K' (Set.range (algebraMap F F')) = ⊤)
+    (z : F')
+    (hz : ∀ v' : Place K' F',
+      (∀ v : Place K F, v'.toValuationSubring.comap (algebraMap F F') ≠ v.toValuationSubring) →
+        z ∈ v'.toValuationSubring) :
+    z ∈ Submodule.span K' (Set.range (algebraMap F F')) :=
+  solution K F K' F' hfg hfg' hgen z hz
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_natCard_place_ord_sub_pos_le_natCard_doubleCoset.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_natCard_place_ord_sub_pos_le_natCard_doubleCoset.lean
new file mode 100644
index 0000000000..6b1a544028
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_natCard_place_ord_sub_pos_le_natCard_doubleCoset.lean
@@ -0,0 +1,265 @@
+/-
+Based on Prove2Me node AlgebraicCurve.natCard_place_ord_sub_pos_le_natCard_doubleCoset
+(a8948f35-1276-5c68-b561-d7d44877ac1f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission aeb90d32-1173-5e98-8a5a-a92484d290c8
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.GroupTheory.DoubleCoset
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_BaseChangeGalois
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_restrictAlong_eq_natCard_algHom_of_isGalois
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Places over a point bounded by double cosets
+
+Theorem statement: `AlgebraicCurve.natCard_place_ord_sub_pos_le_natCard_doubleCoset`
+(`a8948f35-1276-5c68-b561-d7d44877ac1f`), by Claude, 2026-09-05.
+
+Proof: submission `aeb90d32-1173-5e98-8a5a-a92484d290c8`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field and $L$ a field extension of $K$, let $t \in L$, and assume
+$L$ is a finite Galois extension of the intermediate field $K\langle t\rangle = K(t)$ generated by
+$t$. Let $\Gamma_0$ be a group and $\sigma \colon \Gamma_0 \to \operatorname{Aut}_{K(t)}(L)$ a
+surjective group homomorphism, and let $\Gamma, K_{\mathrm{st}} \le \Gamma_0$ be subgroups with
+$\Gamma$ of finite index. Let $E$ be an intermediate field of $L/K(t)$ such that $\sigma(\gamma)$
+fixes every element of $E$ pointwise for all $\gamma \in \Gamma$, let $c \in K$, and let $W$ be a
+place of $L$ over $K$ — that is, a valuation subring of $L$ containing the image of $K$, different
+from $L$ itself and a principal ideal ring — with $\operatorname{ord}_W(t - c) > 0$, where
+$\operatorname{ord}_W$ is minus the logarithm of the associated adic valuation. Assume $W$ is
+stabilised by each $\sigma(k)$, $k \in K_{\mathrm{st}}$, acting through the semilinear automorphism
+$(\sigma(k), \mathrm{id}_K)$ of $L/K$. Finally let $x \in E$ be an element whose image in $L$ is
+$t$. Then the number of places $P$ of $E$ over $K$ with $\operatorname{ord}_P(x - c) > 0$ is at most
+the number of double cosets $\Gamma \backslash \Gamma_0 / K_{\mathrm{st}}$.
+
+This is the upper-bound half of Hilbert's decomposition theory for the fibre of $E \to
+\mathbb{A}^1_K$, $x \mapsto c$: the places of $E$ above $t = c$ are parametrised by a quotient of
+$\Gamma_0$ on which the double cosets $\Gamma \gamma K_{\mathrm{st}}$ act trivially. It is applied
+in the study of fibres of the $j$-invariant map on modular curves, where $\Gamma_0$, $\Gamma$ and
+$K_{\mathrm{st}}$ are a modular group, a congruence subgroup and a cusp stabiliser.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_natCard_place_ord_sub_pos_le_natCard_doubleCoset.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_natCard_place_ord_sub_pos_le_natCard_doubleCoset
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_natCard_place_ord_sub_pos_le_natCard_doubleCoset.AlgebraicCurve"
+open scoped IntermediateField
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place SemilinearAut SemilinearAut.ofAlgAut \
+  Place.ord_restrictAlong_eq_natCard_algHom_of_isGalois"
+namespace PlacesLeDoubleCoset
+p2m_open "AlgebraicCurve"
+
+variable {K : Type*} [Field K] {L : Type*} [Field L] [Algebra K L]
+
+theorem apply_eq_self_of_mem_adjoin (ψ : L →ₐ[K] L) (t : L) (hψ : ψ t = t) {x : L}
+    (hx : x ∈ K⟮t⟯) : ψ x = x := by
+  let S : IntermediateField K L := (AlgHom.equalizer ψ (AlgHom.id K L)).toIntermediateField
+    (fun y hy => by
+      rw [AlgHom.mem_equalizer] at hy ⊢
+      simp only [AlgHom.coe_id, id_eq] at hy ⊢
+      rw [map_inv₀, hy])
+  have hle : K⟮t⟯ ≤ S := by
+    rw [IntermediateField.adjoin_le_iff, Set.singleton_subset_iff]
+    change t ∈ AlgHom.equalizer ψ (AlgHom.id K L)
+    rw [AlgHom.mem_equalizer]
+    simpa using hψ
+  have := hle hx
+  change x ∈ AlgHom.equalizer ψ (AlgHom.id K L) at this
+  rw [AlgHom.mem_equalizer] at this
+  simpa using this
+
+theorem algHom_apply_algebraMap (t : L) (E : IntermediateField K⟮t⟯ L) (x : E) (hx : (x : L) = t)
+    (ψ : E →ₐ[K] L) (hψ : ψ x = t) (l : K⟮t⟯) : ψ (algebraMap K⟮t⟯ E l) = l := by
+  let θ : K⟮t⟯ →ₐ[K] L := ψ.comp (IsScalarTower.toAlgHom K K⟮t⟯ E)
+  have hgen : ∀ (z : L) (hz : z ∈ ({t} : Set L)),
+      θ ⟨z, IntermediateField.subset_adjoin _ _ hz⟩ =
+        (IntermediateField.val K⟮t⟯) ⟨z, IntermediateField.subset_adjoin _ _ hz⟩ := by
+    intro z hz
+    rw [Set.mem_singleton_iff] at hz
+    have hz' : (⟨z, IntermediateField.subset_adjoin _ _ (by rw [hz]; rfl)⟩ : K⟮t⟯) =
+        ⟨t, IntermediateField.mem_adjoin_simple_self K t⟩ := Subtype.ext hz
+    rw [hz']
+    change ψ (algebraMap K⟮t⟯ E ⟨t, _⟩) = t
+    have : algebraMap K⟮t⟯ E ⟨t, IntermediateField.mem_adjoin_simple_self K t⟩ = x := by
+      apply Subtype.ext
+      rw [hx]
+      rfl
+    rw [this, hψ]
+  have hθ : θ = IntermediateField.val K⟮t⟯ := IntermediateField.adjoin_algHom_ext K hgen
+  exact congrArg (fun φ : K⟮t⟯ →ₐ[K] L => φ l) hθ
+
+theorem isIntegral_of_apply_eq_sub (t : L) [FiniteDimensional K⟮t⟯ L]
+    (E : IntermediateField K⟮t⟯ L) (x : E) (hx : (x : L) = t)
+    (ψ : E →ₐ[K] L) (hψ : ψ x = t) : ψ.toRingHom.IsIntegral := by
+  intro y
+  have hy : IsIntegral K⟮t⟯ y := IsIntegral.of_finite K⟮t⟯ y
+  refine ⟨(minpoly K⟮t⟯ y).map (algebraMap K⟮t⟯ E), (minpoly.monic hy).map _, ?_⟩
+  rw [Polynomial.eval₂_map]
+  have hcomp : ψ.toRingHom.comp (algebraMap K⟮t⟯ E) = algebraMap K⟮t⟯ L := by
+    ext e
+    exact algHom_apply_algebraMap t E x hx ψ hψ e
+  rw [hcomp]
+  exact minpoly.aeval K⟮t⟯ y
+
+theorem finite_doubleCosetQuotient {Γ₀ : Type*} [Group Γ₀] (Γ Kst : Subgroup Γ₀) [Γ.FiniteIndex] :
+    Finite (DoubleCoset.Quotient (Γ : Set Γ₀) (Kst : Set Γ₀)) := by
+  have : Finite (Γ₀ ⧸ Γ) := Subgroup.finite_quotient_of_finiteIndex
+  have : Finite (Quotient (QuotientGroup.rightRel Γ)) :=
+    Finite.of_equiv _ (QuotientGroup.quotientRightRelEquivQuotientLeftRel Γ).symm
+  let π : Quotient (QuotientGroup.rightRel Γ) → DoubleCoset.Quotient (Γ : Set Γ₀) (Kst : Set Γ₀) :=
+    Quotient.lift (fun a => DoubleCoset.mk Γ Kst a) (by
+      intro a b hab
+      have hab' : b * a⁻¹ ∈ Γ := QuotientGroup.rightRel_apply.mp hab
+      change DoubleCoset.mk Γ Kst a = DoubleCoset.mk Γ Kst b
+      rw [DoubleCoset.eq]
+      exact ⟨b * a⁻¹, hab', 1, Kst.one_mem, by group⟩)
+  refine Finite.of_surjective π ?_
+  intro q
+  obtain ⟨γ, rfl⟩ : ∃ γ, DoubleCoset.mk Γ Kst γ = q := ⟨q.out, DoubleCoset.out_eq' q⟩
+  exact ⟨Quotient.mk _ γ, rfl⟩
+
+end AlgebraicCurve.PlacesLeDoubleCoset
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_natCard_place_ord_sub_pos_le_natCard_doubleCoset.AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_natCard_place_ord_sub_pos_le_natCard_doubleCoset.AlgebraicCurve.PlacesLeDou\
+  bleCoset"
+open scoped IntermediateField
+
+set_option synthInstance.maxHeartbeats 1600000 in
+theorem solution
+    (K : Type*) [Field K] [IsAlgClosed K] {L : Type*} [Field L] [Algebra K L]
+    (t : L) (hfin : FiniteDimensional K⟮t⟯ L) (hgal : IsGalois K⟮t⟯ L)
+    {Γ₀ : Type*} [Group Γ₀] (σ : Γ₀ →* (L ≃ₐ[K⟮t⟯] L)) (hσ : Function.Surjective σ)
+    (Γ Kst : Subgroup Γ₀) [Γ.FiniteIndex]
+    (E : IntermediateField K⟮t⟯ L) (hE : ∀ γ ∈ Γ, ∀ e : E, σ γ (e : L) = e)
+    (c : K) (W : AlgebraicCurve.Place K L) (hW : 0 < W.ord (t - algebraMap K L c))
+    (hD : ∀ k ∈ Kst, AlgebraicCurve.SemilinearAut.ofAlgAut ((σ k).restrictScalars K) • W = W)
+    (x : E) (hx : (x : L) = t) :
+    Nat.card {P : AlgebraicCurve.Place K E // 0 < P.ord (x - algebraMap K E c)} ≤
+      Nat.card (DoubleCoset.Quotient (Γ : Set Γ₀) (Kst : Set Γ₀)) := by
+  classical
+  have := hfin
+  have := hgal
+  have hint : ∀ ψ : E →ₐ[K] L, ψ x = t → ψ.toRingHom.IsIntegral :=
+    fun ψ hψ => isIntegral_of_apply_eq_sub t E x hx ψ hψ
+  have hDH := AlgebraicCurve.Place.ord_restrictAlong_eq_natCard_algHom_of_isGalois K x t c
+    (E.val.restrictScalars K) hx hfin hgal hint W hW
+  let ψ : Γ₀ → (E →ₐ[K] L) := fun γ =>
+    ((σ γ⁻¹).restrictScalars K : L →ₐ[K] L).comp (E.val.restrictScalars K)
+  have hψapply : ∀ (γ : Γ₀) (e : E), ψ γ e = σ γ⁻¹ e := fun _ _ => rfl
+  have hψ : ∀ γ, ψ γ x = t := by
+    intro γ
+    rw [hψapply]
+    have : (x : L) = ((⟨t, IntermediateField.mem_adjoin_simple_self K t⟩ : K⟮t⟯) : L) := hx
+    rw [this]
+    exact (σ γ⁻¹).commutes (⟨t, IntermediateField.mem_adjoin_simple_self K t⟩ : K⟮t⟯)
+  have hcongr : ∀ (ψ₁ ψ₂ : E →ₐ[K] L) (h₁ : ψ₁.toRingHom.IsIntegral) (h₂ : ψ₂.toRingHom.IsIntegral),
+      ψ₁ = ψ₂ → W.restrictAlong ψ₁ h₁ = W.restrictAlong ψ₂ h₂ := by
+    rintro ψ₁ ψ₂ h₁ h₂ rfl; rfl
+  let T := {P : AlgebraicCurve.Place K E // 0 < P.ord (x - algebraMap K E c)}
+  let f : Γ₀ → T := fun γ => ⟨W.restrictAlong (ψ γ) (hint _ (hψ γ)), hDH.2.1 (ψ γ) (hψ γ)⟩
+  have hsurj : Function.Surjective f := by
+    rintro ⟨P, hP⟩
+    obtain ⟨ψ', hψ', hres⟩ := hDH.2.2.1 P hP
+    let ψ'' : E →ₐ[K⟮t⟯] L :=
+      { ψ'.toRingHom with
+        commutes' := fun l => algHom_apply_algebraMap t E x hx ψ' hψ' l }
+    have hψ''apply : ∀ e : E, ψ'' e = ψ' e := fun _ => rfl
+    let φ : L →ₐ[K⟮t⟯] L := ψ''.liftNormal L
+    have hφE : ∀ e : E, φ (e : L) = ψ' e := by
+      intro e
+      have h := AlgHom.liftNormal_commutes ψ'' L e
+      simp only [IntermediateField.algebraMap_apply, Algebra.algebraMap_self, RingHom.id_apply] at h
+      exact h
+    have hφinj : Function.Injective φ := φ.toRingHom.injective
+    have hφsurj : Function.Surjective φ :=
+      (LinearMap.injective_iff_surjective (f := φ.toLinearMap)).mp hφinj
+    let g : L ≃ₐ[K⟮t⟯] L := AlgEquiv.ofBijective φ ⟨hφinj, hφsurj⟩
+    have hgapply : ∀ z : L, g z = φ z := fun _ => rfl
+    obtain ⟨γ₀, hγ₀⟩ := hσ g
+    refine ⟨γ₀⁻¹, ?_⟩
+    apply Subtype.ext
+    change W.restrictAlong (ψ γ₀⁻¹) (hint _ (hψ γ₀⁻¹)) = P
+    rw [← hres]
+    apply hcongr
+    apply AlgHom.ext
+    intro e
+    rw [hψapply, inv_inv, hγ₀, hgapply, hφE]
+  have hconst : ∀ (γ : Γ₀) (a : Γ₀) (_ : a ∈ Γ) (b : Γ₀) (_ : b ∈ Kst), f (a * γ * b) = f γ := by
+    intro γ a ha b hb
+    apply Subtype.ext
+    change W.restrictAlong (ψ (a * γ * b)) (hint _ (hψ (a * γ * b))) = W.restrictAlong (ψ γ) (hint _
+      (hψ γ))
+    symm
+    apply (hDH.2.2.2.1 (ψ γ) (ψ (a * γ * b)) (hψ γ) (hψ (a * γ * b))).mpr
+    refine ⟨σ b⁻¹, hD b⁻¹ (Kst.inv_mem hb), ?_⟩
+    apply AlgHom.ext
+    intro e
+    change ψ (a * γ * b) e = σ b⁻¹ (ψ γ e)
+    rw [hψapply, hψapply, mul_inv_rev, mul_inv_rev, map_mul, map_mul, AlgEquiv.mul_apply,
+      AlgEquiv.mul_apply,
+      hE a⁻¹ (Γ.inv_mem ha) e]
+  let fbar : DoubleCoset.Quotient (Γ : Set Γ₀) (Kst : Set Γ₀) → T :=
+    Quotient.lift f (by
+      intro γ γ' hrel
+      obtain ⟨a, ha, b, hb, rfl⟩ := DoubleCoset.rel_iff.mp hrel
+      exact (hconst γ a ha b hb).symm)
+  have hfbar : Function.Surjective fbar := by
+    intro p
+    obtain ⟨γ, rfl⟩ := hsurj p
+    exact ⟨DoubleCoset.mk Γ Kst γ, rfl⟩
+  have : Finite (DoubleCoset.Quotient (Γ : Set Γ₀) (Kst : Set Γ₀)) :=
+    finite_doubleCosetQuotient Γ Kst
+  exact Nat.card_le_card_of_surjective fbar hfbar
+
+end S_AlgebraicCurve_natCard_place_ord_sub_pos_le_natCard_doubleCoset
+end P2MW
+export P2MW.S_AlgebraicCurve_natCard_place_ord_sub_pos_le_natCard_doubleCoset (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+open scoped IntermediateField
+theorem AlgebraicCurve.natCard_place_ord_sub_pos_le_natCard_doubleCoset
+    (K : Type*) [Field K] [IsAlgClosed K] {L : Type*} [Field L] [Algebra K L]
+    (t : L) (hfin : FiniteDimensional K⟮t⟯ L) (hgal : IsGalois K⟮t⟯ L)
+    {Γ₀ : Type*} [Group Γ₀] (σ : Γ₀ →* (L ≃ₐ[K⟮t⟯] L)) (hσ : Function.Surjective σ)
+    (Γ Kst : Subgroup Γ₀) [Γ.FiniteIndex]
+    (E : IntermediateField K⟮t⟯ L) (hE : ∀ γ ∈ Γ, ∀ e : E, σ γ (e : L) = e)
+    (c : K) (W : AlgebraicCurve.Place K L) (hW : 0 < W.ord (t - algebraMap K L c))
+    (hD : ∀ k ∈ Kst, AlgebraicCurve.SemilinearAut.ofAlgAut ((σ k).restrictScalars K) • W = W)
+    (x : E) (hx : (x : L) = t) :
+    Nat.card {P : AlgebraicCurve.Place K E // 0 < P.ord (x - algebraMap K E c)} ≤
+      Nat.card (DoubleCoset.Quotient (Γ : Set Γ₀) (Kst : Set Γ₀)) :=
+  solution K t hfin hgal σ hσ Γ Kst E hE c W hW hD x hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_nonempty_place_of_transcendental_of_finiteDimensional.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_nonempty_place_of_transcendental_of_finiteDimensional.lean
new file mode 100644
index 0000000000..ad3be8a7ee
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_nonempty_place_of_transcendental_of_finiteDimensional.lean
@@ -0,0 +1,107 @@
+/-
+Based on Prove2Me node AlgebraicCurve.nonempty_place_of_transcendental_of_finiteDimensional
+(dff9f726-b8a3-5722-b5dc-2bd154d4e1ca) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 940dcebf-d996-5d62-a393-409885fe5686
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.Algebra.Lie.OfAssociative
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_nonempty_place_of_ratFunc_tower
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of a place for a finite separable extension of k(x)
+
+Theorem statement: `AlgebraicCurve.nonempty_place_of_transcendental_of_finiteDimensional`
+(`dff9f726-b8a3-5722-b5dc-2bd154d4e1ca`), by Claude, 2026-09-05.
+
+Proof: submission `940dcebf-d996-5d62-a393-409885fe5686`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $k$ be a field and $F$ a field equipped with a $k$-algebra structure, and let $x \in F$ be
+transcendental over $k$. Write $E = k(x)$ for the intermediate field `IntermediateField.adjoin k
+{x}` of $F/k$ generated by $x$. Assume that $F$ is finite-dimensional as an $E$-vector space and
+that the extension $F/E$ is separable. The conclusion is that the type [`AlgebraicCurve.Place k
+F`](def/AlgebraicCurve_DivisorClassGroup.html#L22) is nonempty, that is, there exists a valuation
+subring $\mathcal{O}$ of $F$ such that $\mathrm{algebraMap}\,k\,F\,(a) \in \mathcal{O}$ for every $a
+\in k$, such that $\mathcal{O} \neq F$ (the subring is not the whole field), and such that
+$\mathcal{O}$ is a principal ideal ring. Thus a function field $F$ over $k$, presented as a finite
+separable extension of a rational function field in one transcendental element, carries at least one
+place in the sense used throughout this development.
+
+This is the existence of places on an algebraic function field of one variable: every such $F/k$
+admits a nontrivial $k$-valuation subring with principal maximal ideal, for instance an extension to
+$F$ of the $x$-adic valuation of $k(x)$. It serves as the entry point for producing places on the
+function fields of modular curves, and is used downstream in the work with semistable coverings,
+integral models and the finite-dimensionality of Riemann–Roch spaces.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_nonempty_place_of_transcendental_of_finiteDimensional.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_nonempty_place_of_transcendental_of_finiteDimensional
+
+theorem solution
+    (k : Type*) [Field k] {F : Type*} [Field F] [Algebra k F] (x : F) (hx : Transcendental k x)
+    (hfin : FiniteDimensional ↥(IntermediateField.adjoin k ({x} : Set F)) F)
+    [Algebra.IsSeparable ↥(IntermediateField.adjoin k ({x} : Set F)) F] :
+    Nonempty (AlgebraicCurve.Place k F) := by
+  classical
+  set E := IntermediateField.adjoin k ({x} : Set F) with hE
+  have : FiniteDimensional ↥E F := hfin
+  let e : RatFunc k ≃ₐ[k] ↥E := RatFunc.algEquivOfTranscendental x hx
+  let algRE : Algebra (RatFunc k) ↥E := e.toAlgHom.toRingHom.toAlgebra
+  let algRF : Algebra (RatFunc k) F := ((algebraMap ↥E F).comp e.toAlgHom.toRingHom).toAlgebra
+  have : IsScalarTower (RatFunc k) ↥E F := IsScalarTower.of_algebraMap_eq (fun r => rfl)
+  have : IsScalarTower k (RatFunc k) F := IsScalarTower.of_algebraMap_eq (fun c => by
+    change algebraMap k F c = algebraMap ↥E F (e (algebraMap k (RatFunc k) c))
+    rw [e.commutes, ← IsScalarTower.algebraMap_apply])
+  have : IsScalarTower k (RatFunc k) ↥E := IsScalarTower.of_algebraMap_eq (fun c => by
+    change algebraMap k ↥E c = e (algebraMap k (RatFunc k) c)
+    rw [e.commutes])
+  have : Module.Finite (RatFunc k) ↥E :=
+    Module.Finite.of_surjective (Algebra.linearMap (RatFunc k) ↥E) e.surjective
+  have : FiniteDimensional (RatFunc k) F := Module.Finite.trans ↥E F
+  have : Algebra.IsSeparable (RatFunc k) ↥E := by
+    refine ⟨fun y => ?_⟩
+    obtain ⟨r, rfl⟩ := e.surjective y
+    change IsSeparable (RatFunc k) (algebraMap (RatFunc k) ↥E r)
+    exact isSeparable_algebraMap r
+  have : Algebra.IsSeparable (RatFunc k) F := Algebra.IsSeparable.trans (RatFunc k) ↥E F
+  exact AlgebraicCurve.RationalFunctionField.nonempty_place_of_ratFunc_tower k F
+
+end S_AlgebraicCurve_nonempty_place_of_transcendental_of_finiteDimensional
+end P2MW
+export P2MW.S_AlgebraicCurve_nonempty_place_of_transcendental_of_finiteDimensional (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem AlgebraicCurve.nonempty_place_of_transcendental_of_finiteDimensional
+    (k : Type*) [Field k] {F : Type*} [Field F] [Algebra k F] (x : F) (hx : Transcendental k x)
+    (hfin : FiniteDimensional ↥(IntermediateField.adjoin k ({x} : Set F)) F)
+    [Algebra.IsSeparable ↥(IntermediateField.adjoin k ({x} : Set F)) F] :
+    Nonempty (AlgebraicCurve.Place k F) :=
+  solution k x hx hfin
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_normFormulaAlong.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_normFormulaAlong.lean
new file mode 100644
index 0000000000..dec7091545
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_normFormulaAlong.lean
@@ -0,0 +1,94 @@
+/-
+Based on Prove2Me node AlgebraicCurve.normFormulaAlong
+(0a836ca9-bde8-5a32-b34d-1f0bf43c2174) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9c76cc3b-ad4f-5f4a-9873-dbbcc0897fb8
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_pushforwardNormFormula
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Pushforward norm formula along a finite separable K-morphism
+
+Theorem statement: `AlgebraicCurve.normFormulaAlong` (`0a836ca9-bde8-5a32-b34d-1f0bf43c2174`), by
+Claude, 2026-09-05.
+
+Proof: submission `9c76cc3b-ad4f-5f4a-9873-dbbcc0897fb8`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $F'$ be fields, with $F$ and $F'$ algebras over $K$ and $F$ of characteristic zero,
+and let $\varphi : F \to F'$ be a $K$-algebra homomorphism. Assume $F'$ has principal divisors over
+$K$, i.e. every nonzero $f \in F'$ admits a divisor $D$ (a finitely supported $\mathbb{Z}$-valued
+function on the places of $F'$ over $K$, a place being a valuation subring containing the image of
+$K$, distinct from the whole field, and a principal ideal ring) with $D(w) = \operatorname{ord}_w f$
+at every place $w$ and $\deg D = 0$. Assume further that, when $F'$ is regarded as an $F$-algebra
+through $\varphi$, it is a finite $F$-module (`FiniteAlong`) and a separable $F$-algebra
+(`SeparableAlong`). The conclusion is `NormFormulaAlong K φ hfin`, which unfolds to the assertion
+that, with respect to this $F$-algebra structure on $F'$, for every nonzero $f \in F'$, every
+divisor $D$ on $F'$ satisfying $D(w) = \operatorname{ord}_w f$ at all places $w$ of $F'$, and every
+place $v$ of $F$, the pushforward of $D$ to the divisors of $F$ takes at $v$ the value
+$\operatorname{ord}_v\bigl(N_{F'/F}(f)\bigr)$.
+
+This is the compatibility of the divisor pushforward with the field norm,
+$\varphi_*(\operatorname{div} f) = \operatorname{div}(N_{F'/F} f)$, in the form required for a
+morphism of curves presented as an explicit $K$-algebra map rather than by an ambient tower of
+algebras. It supplies the norm-formula hypothesis used in the construction of correspondences and
+their action on Picard groups and Tate modules.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_normFormulaAlong.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_normFormulaAlong
+
+open AlgebraicCurve AlgebraicCurve.SemilinearAut
+open scoped Pointwise
+
+noncomputable section
+
+theorem solution {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+    [CharZero F] (φ : F →ₐ[K] F') [HasPrincipalDivisors K F'] (hfin : FiniteAlong K φ)
+    (hsep : SeparableAlong K φ) :
+    NormFormulaAlong K φ hfin := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have : Module.Finite F F' := hfin
+  have : Algebra.IsSeparable F F' := hsep
+  exact Divisor.pushforwardNormFormula
+
+end
+
+end S_AlgebraicCurve_normFormulaAlong
+end P2MW
+export P2MW.S_AlgebraicCurve_normFormulaAlong (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve AlgebraicCurve.SemilinearAut
+theorem AlgebraicCurve.normFormulaAlong {K F F' : Type*} [Field K] [Field F] [Field F']
+    [Algebra K F] [Algebra K F'] [CharZero F] (φ : F →ₐ[K] F') [HasPrincipalDivisors K F']
+    (hfin : FiniteAlong K φ) (hsep : SeparableAlong K φ) :
+    NormFormulaAlong K φ hfin :=
+  solution φ hfin hsep
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_omegaSpace_finite_of_genusReached.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_omegaSpace_finite_of_genusReached.lean
new file mode 100644
index 0000000000..317d9823c3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_omegaSpace_finite_of_genusReached.lean
@@ -0,0 +1,1344 @@
+/-
+Based on Prove2Me node AlgebraicCurve.omegaSpace_finite_of_genusReached
+(d286f11c-bbba-5dce-8654-5a8dd94c63db) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4215658d-98da-5ea8-a71f-c932aa8e1714
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import Mathlib.LinearAlgebra.Matrix.FiniteDimensional
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finite-dimensionality of the space Ω(D)
+
+Theorem statement: `AlgebraicCurve.omegaSpace_finite_of_genusReached`
+(`d286f11c-bbba-5dce-8654-5a8dd94c63db`), by Claude, 2026-09-05.
+
+Proof: submission `4215658d-98da-5ea8-a71f-c932aa8e1714`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K \subseteq F$ be fields with $F$ a $K$-algebra satisfying `IsCurveOver K F`, that is: every
+nonzero $f \in F$ has a principal divisor of degree $0$, each place $v$ of $F/K$ has residue field
+finite over $K$, and the module of Kähler differentials $\Omega[F/K]$ is free of rank one over $F$.
+Assume further that the set `Place K F` of places is nonempty and that $L(0) = \{f \in F : v(f) \le
+1 \text{ for all } v\}$, the Riemann–Roch space of the zero divisor, is finite-dimensional over $K$.
+Let $\gamma$ be an integer and $D_0$ a divisor (a finitely supported function from places to
+$\mathbb{Z}$) for which `RiemannGenusReachedAt γ D₀` holds, i.e. $L(D_0)$ is finite-dimensional over
+$K$, $\deg D_0 - \mathrm{ell}(D_0) = \gamma - 1$, and $\deg D - \mathrm{ell}(D) \le \gamma - 1$ for
+every divisor $D$, where $\deg$ is the additive extension of $v \mapsto \deg v$ and `ell` the
+dimension invariant of the Riemann–Roch spaces. Then for every divisor $D$ the space `omegaSpace D`,
+consisting of those $K$-linear functionals on the adele space $\bigsqcup_E$ `adeleBdd E` $\subseteq
+(\mathrm{Place}\,K\,F \to F)$ that annihilate the submodule generated by `adeleBdd D` together with
+`globalSub K F`, is a finite-dimensional $K$-vector space.
+
+This is the finiteness of the space of Weil differentials bounded by a divisor $D$, dual to the
+finiteness of the adelic cohomology $H^1(D)$ in the adelic (repartition) approach to the
+Riemann–Roch theorem. It serves as the finiteness side condition in
+[`AlgebraicCurve.exists_indexOfSpecialty_nsmul_single_eq_zero_of_genusReached`]
+(thm.html#AlgebraicCurve.exists_indexOfSpecialty_nsmul_single_eq_zero_of_genusReached),
+where the rank-one property of the space of differentials is established.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_omegaSpace_finite_of_genusReached.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_omegaSpace_finite_of_genusReached
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_coe_unit ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow toValuationSubring mk adicValuation_eq_exp_neg_ord"
+p2m_open "AlgebraicCurve.Place"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+p2m_export "AlgebraicCurve.Place" "ord_nonneg_of_mem"
+p2m_export "AlgebraicCurve.Place" "mem_of_ord_nonneg"
+theorem mem_iff_ord_nonneg {f : F} (hf : f ≠ 0) :
+    f ∈ v.toValuationSubring ↔ 0 ≤ v.ord f :=
+  ⟨v.ord_nonneg_of_mem, v.mem_of_ord_nonneg hf⟩
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "degree degree_single principal smul_def smul_apply"
+end Divisor
+variable {D : Divisor K F}
+p2m_open_scoped "AlgebraicCurve.Divisor" in
+theorem Divisor.degree_nonneg_of_nonneg [IsCurveOver K F]
+    {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) : 0 ≤ Divisor.degree D := by
+  rw [Divisor.degree_eq_sum_support]
+  exact Finset.sum_nonneg fun v _ => mul_nonneg (hD v) (Int.natCast_nonneg _)
+theorem lSpace_eq_bot_of_degree_neg [IsCurveOver K F]
+    (hD : Divisor.degree D < 0) : LSpace D = ⊥ := by
+  rw [eq_bot_iff]
+  intro f hf
+  rw [Submodule.mem_bot]
+  by_contra hf0
+  obtain ⟨P, hPord, hPdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+  have heff : ∀ v : Place K F, 0 ≤ (P + D) v := by
+    intro v
+    rw [Finsupp.add_apply, hPord]
+    rcases mem_lSpace_iff_ord.mp hf with rfl | h
+    · exact absurd rfl hf0
+    · linarith [h v]
+  have hdegPD : 0 ≤ Divisor.degree (P + D) := Divisor.degree_nonneg_of_nonneg heff
+  rw [map_add, hPdeg, zero_add] at hdegPD
+  exact absurd hdegPD (not_le.mpr hD)
+end AlgebraicCurve
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_coe_unit ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow toValuationSubring mk adicValuation_eq_exp_neg_ord"
+p2m_open "AlgebraicCurve.Place"
+
+variable (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.mk_mem_maximalIdeal_iff {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    (⟨f, hf⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring
+      ↔ f = 0 ∨ 0 < v.ord f := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  constructor
+  · intro hu
+    rcases eq_or_ne f 0 with rfl | hf0
+    · exact Or.inl rfl
+    · refine Or.inr ?_
+      rcases lt_or_eq_of_le (v.ord_nonneg_of_mem hf) with h | h
+      · exact h
+      · exfalso
+        apply hu
+        rw [← v.adicValuation_coe_eq_one_iff ⟨f, hf⟩]
+        change v.adicValuation f = 1
+        rw [v.adicValuation_eq_exp_neg_ord hf0, ← h, neg_zero, WithZero.exp_zero]
+  · intro h hu
+    have hne : f ≠ 0 := fun h0 => hu.ne_zero (Subtype.ext h0)
+    have h0 : v.ord f = 0 := by
+      obtain ⟨u, hu'⟩ := hu
+      have hcoe : f = ((u : v.toValuationSubring) : F) := by rw [hu']
+      rw [hcoe]; exact v.ord_coe_unit u
+    rcases h with rfl | hpos
+    · exact hne rfl
+    · omega
+
+p2m_export "AlgebraicCurve.Place" "mk_mem_maximalIdeal_iff"
+end Place
+
+theorem ell_le_ell_sub_single_add_deg [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    ell D ≤ ell (D - Finsupp.single P 1) + P.deg := by
+  classical
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible P.toValuationSubring
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by
+    simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := by
+    intro g hg
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ g : F, g ∈ LSpace D → t ^ (D P) * g ∈ P.toValuationSubring := by
+    intro g hg
+    rcases eq_or_ne g 0 with rfl | hg0
+    · simp
+    · refine P.mem_of_ord_nonneg (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have := (mem_lSpace_iff_ord.mp hg).resolve_left hg0 P
+      linarith
+  let ψ : LSpace D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun f => ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+      map_add' := by intro f g; apply Subtype.ext; push_cast; ring
+      map_smul' := by
+        intro c f; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap]
+        ring }
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : LSpace D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ f : LSpace D, φ f = 0 ↔
+      (⟨t ^ (D P) * (f : F), hmem _ f.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := by
+    intro f
+    rw [show φ f = IsLocalRing.residue P.toValuationSubring ⟨t ^ (D P) * (f : F), hmem _ f.2⟩
+          from hres (ψ f),
+      IsLocalRing.residue_eq_zero_iff]
+  have hED : E ≤ D := by
+    rw [Finsupp.le_def]; intro v; rw [hE, Finsupp.sub_apply]
+    have : (0 : ℤ) ≤ Finsupp.single P 1 v := by
+      rcases eq_or_ne v P with rfl | hv
+      · simp
+      · simp [Finsupp.single_eq_of_ne hv]
+    linarith
+  have hsub : LSpace E ≤ LSpace D := lSpace_mono hED
+  have hker : LinearMap.ker φ = (LSpace E).comap (LSpace D).subtype := by
+    ext f
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi f, P.mk_mem_maximalIdeal_iff]
+    rcases eq_or_ne (f : F) 0 with hf0 | hf0
+    · simp only [hf0, mul_zero, true_or, true_iff]
+      exact (LSpace E).zero_mem
+    · rw [mem_lSpace_iff_ord]
+      have hfD := (mem_lSpace_iff_ord.mp f.2).resolve_left hf0
+      constructor
+      · rintro (h | h)
+        · exact absurd h (mul_ne_zero htn0 hf0)
+        · refine Or.inr (fun v => ?_)
+          rcases eq_or_ne v P with rfl | hv
+          · rw [hEP]; rw [hordmul hf0] at h; omega
+          · rw [hEv v hv]; exact hfD v
+      · rintro (h | h)
+        · exact absurd h hf0
+        · refine Or.inr ?_
+          have hP := h P
+          rw [hEP] at hP
+          rw [hordmul hf0]; omega
+  have hkerfin : finrank K (LinearMap.ker φ) = ell E := by
+    rw [hker, LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe hsub)]
+  have hquot : finrank K (LSpace D ⧸ LinearMap.ker φ) ≤ P.deg := by
+    rw [LinearEquiv.finrank_eq φ.quotKerEquivRange]
+    exact Submodule.finrank_le (LinearMap.range φ)
+  by_cases hfin : FiniteDimensional K (LSpace D)
+  · have := hfin
+    have hrn := Submodule.finrank_quotient_add_finrank (LinearMap.ker φ)
+    rw [hkerfin] at hrn
+    have hb : ell D = finrank K (LSpace D) := rfl
+    omega
+  · have h0 : ell D = 0 := by rw [ell]; exact finrank_of_infinite_dimensional hfin
+    omega
+
+theorem one_le_deg [IsCurveOver K F] (P : Place K F) : 1 ≤ P.deg := by
+  have : Module.Finite K P.ResidueField := IsCurveOver.finite_residueField P
+  exact Module.finrank_pos
+
+theorem ell_le_degree_add_ellZero [IsCurveOver K F] {D : Divisor K F}
+    (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D : Divisor K F, (∀ v, 0 ≤ D v) →
+      (Divisor.degree D).toNat = m →
+      (ell D : ℤ) ≤ Divisor.degree D + ell (0 : Divisor K F) by
+    exact H (Divisor.degree D).toNat D hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D hD hm
+    by_cases hD0 : D = 0
+    · subst hD0; simp
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ D P := by
+        have hne : D P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hD P; omega
+      set E : Divisor K F := D - Finsupp.single P 1 with hE
+      have hEeff : ∀ v, 0 ≤ E v := by
+        intro v; rw [hE, Finsupp.sub_apply]
+        rcases eq_or_ne v P with rfl | hv
+        · rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have hdegE : Divisor.degree E = Divisor.degree D - P.deg := by
+        rw [hE, map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hDnn : 0 ≤ Divisor.degree D := Divisor.degree_nonneg_of_nonneg hD
+      have hEnn : 0 ≤ Divisor.degree E := Divisor.degree_nonneg_of_nonneg hEeff
+      have hmlt : (Divisor.degree E).toNat < m := by rw [← hm]; omega
+      have hIH := IH _ hmlt E hEeff rfl
+      have hstep := ell_le_ell_sub_single_add_deg D P
+      rw [← hE] at hstep
+      have hstep' : (ell D : ℤ) ≤ (ell E : ℤ) + P.deg := by exact_mod_cast hstep
+      rw [hdegE] at hIH
+      linarith
+
+theorem ell_le_degree_add_one_of_effective [IsCurveOver K F]
+    (hC : ConstantsAreBase K F) {D : Divisor K F} (hD : ∀ v, 0 ≤ D v) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  have h := ell_le_degree_add_ellZero hD
+  rw [ell_zero_eq_one_of_constantsAreBase hC] at h
+  exact_mod_cast h
+
+def lSpaceShiftEquiv (D : Divisor K F) {g : F} (hg : g ≠ 0)
+    {Dg : Divisor K F} (hDg : ∀ v, Dg v = v.ord g) :
+    LSpace D ≃ₗ[K] LSpace (D + Dg) where
+  toFun h := ⟨(h : F) * g⁻¹, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (h : F) 0 with hh0 | hh0
+    · left; rw [hh0, zero_mul]
+    · right; intro v
+      rw [Finsupp.add_apply, hDg, v.ord_mul hh0 (inv_ne_zero hg), v.ord_inv]
+      have := (mem_lSpace_iff_ord.mp h.2).resolve_left hh0 v
+      linarith⟩
+  invFun k := ⟨(k : F) * g, by
+    rw [mem_lSpace_iff_ord]
+    rcases eq_or_ne (k : F) 0 with hk0 | hk0
+    · left; rw [hk0, zero_mul]
+    · right; intro v
+      have := (mem_lSpace_iff_ord.mp k.2).resolve_left hk0 v
+      rw [Finsupp.add_apply, hDg] at this
+      rw [v.ord_mul hk0 hg]
+      linarith⟩
+  map_add' h₁ h₂ := by apply Subtype.ext; push_cast; ring
+  map_smul' c h := by
+    apply Subtype.ext
+    simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def]
+    ring
+  left_inv h := by
+    apply Subtype.ext
+    change (h : F) * g⁻¹ * g = (h : F)
+    rw [mul_assoc, inv_mul_cancel₀ hg, mul_one]
+  right_inv k := by
+    apply Subtype.ext
+    change (k : F) * g * g⁻¹ = (k : F)
+    rw [mul_assoc, mul_inv_cancel₀ hg, mul_one]
+
+theorem ell_le_degree_add_one [IsCurveOver K F] (hC : ConstantsAreBase K F)
+    {D : Divisor K F} (hD : 0 ≤ Divisor.degree D) :
+    (ell D : ℤ) ≤ Divisor.degree D + 1 := by
+  rcases eq_or_ne (ell D) 0 with h0 | h0
+  · rw [h0]; push_cast; linarith
+  · have hbot : LSpace D ≠ ⊥ := fun h => h0 (by rw [ell, h, finrank_bot])
+    obtain ⟨g, hgL, hg0⟩ := (Submodule.ne_bot_iff _).mp hbot
+    obtain ⟨Dg, hDgord, hDgdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) g hg0
+    have heff : ∀ v, 0 ≤ (D + Dg) v := by
+      intro v; rw [Finsupp.add_apply, hDgord]
+      have := (mem_lSpace_iff_ord.mp hgL).resolve_left hg0 v
+      linarith
+    have hdeg : Divisor.degree (D + Dg) = Divisor.degree D := by
+      rw [map_add, hDgdeg, add_zero]
+    have hell : ell D = ell (D + Dg) :=
+      LinearEquiv.finrank_eq (lSpaceShiftEquiv D hg0 hDgord)
+    have hfin := ell_le_degree_add_one_of_effective hC heff
+    rw [hdeg] at hfin
+    rw [hell]; exact hfin
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+p2m_open "Module IsLocalRing Module.IsLocalRing IsDedekindDomain WithZero"
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion mk mem_bot subtype_injective \
+  Quotient.subsingleton_iff Quotient.mk restrictScalars inclusion_injective comapSubtypeEquivOfLe \
+  mem_comap finrank_quotient_add_finrank mem_top Quotient.equiv mkQ mem_map coe_subtype map_smul' \
+  zero one quotientQuotientEquivQuotient coe_eq_zero finrank_le range_subtype \
+  Quotient.mk_surjective map mem_inf mem_sup Quotient.mk_eq_zero topEquiv \
+  map_injective_of_injective comap_subtype_self mapQ subsingleton_iff module smul_def mk_eq_zero \
+  coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono map_sup coe_zero"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+def nestedComapMapMkQEquiv {A B C : Submodule K X} (_hAB : A ≤ B) (hBC : B ≤ C) :
+    ((B.comap C.subtype).map (A.comap C.subtype).mkQ : Submodule K _)
+      ≃ₗ[K] B ⧸ A.comap B.subtype := by
+  set S := A.comap C.subtype with hS
+  set T := B.comap C.subtype with hT
+  let ψ : (T : Type _) →ₗ[K] (C ⧸ S) := S.mkQ ∘ₗ T.subtype
+  have hker : LinearMap.ker ψ = S.comap T.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = T.map S.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let e1 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (T.map S.mkQ : Submodule K _) :=
+    (Submodule.Quotient.equiv _ (LinearMap.ker ψ) (LinearEquiv.refl K T)
+        (by rw [hker]; simp)).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have hmap : (S.comap T.subtype).map
+      (Submodule.comapSubtypeEquivOfLe hBC : (T : Type _) →ₗ[K] B) = A.comap B.subtype := by
+    ext ⟨b, hb⟩
+    simp only [mem_map, mem_comap, Submodule.coe_subtype, hS]
+    constructor
+    · rintro ⟨⟨⟨x, hxC⟩, hxB⟩, hxA, hxeq⟩
+      have hx : x = b := congrArg Subtype.val hxeq
+      subst hx; exact hxA
+    · intro hbA
+      exact ⟨⟨⟨b, hBC hb⟩, hb⟩, hbA, rfl⟩
+  let e2 : (T ⧸ S.comap T.subtype) ≃ₗ[K] (B ⧸ A.comap B.subtype) :=
+    Submodule.Quotient.equiv _ _ (Submodule.comapSubtypeEquivOfLe hBC) hmap
+  exact e1.symm.trans e2
+
+theorem finrank_quotient_chain {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCB : Module.Finite K (C ⧸ B.comap C.subtype)]
+    [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (C ⧸ A.comap C.subtype) ∧
+      finrank K (C ⧸ A.comap C.subtype)
+        = finrank K (C ⧸ B.comap C.subtype) + finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (T.map S.mkQ : Submodule K _) := Module.Finite.equiv eK.symm
+  have : Module.Finite K ((C ⧸ S) ⧸ T.map S.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (C ⧸ S) := Module.Finite.of_submodule_quotient (T.map S.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+theorem finrank_quotient_chain' {A B C : Submodule K X} (hAB : A ≤ B) (hBC : B ≤ C)
+    [hCA : Module.Finite K (C ⧸ A.comap C.subtype)] :
+    Module.Finite K (C ⧸ B.comap C.subtype) ∧
+      finrank K (C ⧸ B.comap C.subtype)
+        = finrank K (C ⧸ A.comap C.subtype) - finrank K (B ⧸ A.comap B.subtype) := by
+  set S := A.comap C.subtype
+  set T := B.comap C.subtype
+  have hST : S ≤ T := comap_mono hAB
+  have e3 := Submodule.quotientQuotientEquivQuotient S T hST
+  have eK := nestedComapMapMkQEquiv (K := K) hAB hBC
+  have : Module.Finite K (C ⧸ T) := Module.Finite.equiv e3
+  refine ⟨this, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (T.map S.mkQ)
+  rw [LinearEquiv.finrank_eq e3, LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+def adeleBddQuotSingleEquivResidueField (D : Divisor K F) (P : Place K F) :
+    (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+      ≃ₗ[K] P.ResidueField := by
+  classical
+  set E : Divisor K F := D - Finsupp.single P 1 with hE
+  have hEP : E P = D P - 1 := by rw [hE, Finsupp.sub_apply, Finsupp.single_eq_same]
+  have hEv : ∀ v, v ≠ P → E v = D v := by
+    intro v hv; rw [hE, Finsupp.sub_apply, Finsupp.single_eq_of_ne hv, sub_zero]
+  let π : P.toValuationSubring :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose
+  have hπ : Irreducible π :=
+    (IsDiscreteValuationRing.exists_irreducible P.toValuationSubring).choose_spec
+  set t : F := (π : F) with ht
+  have ht0 : t ≠ 0 := by simpa [ht, ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have ht1 : P.ord t = 1 := P.ord_coe_irreducible hπ
+  have htn0 : t ^ (D P) ≠ 0 := zpow_ne_zero _ ht0
+  have hordmul : ∀ {g : F}, g ≠ 0 → P.ord (t ^ (D P) * g) = D P + P.ord g := fun {g} hg => by
+    rw [P.ord_mul htn0 hg, P.ord_zpow, ht1, mul_one]
+  have hmem : ∀ α : Place K F → F, α ∈ adeleBdd D → t ^ (D P) * α P ∈ P.toValuationSubring := by
+    intro α hα
+    rcases eq_or_ne (α P) 0 with hg0 | hg0
+    · simp [hg0]
+    · refine P.mem_of_ord_nonneg (mul_ne_zero htn0 hg0) ?_
+      rw [hordmul hg0]
+      have h := hα P
+      rw [P.adicValuation_eq_exp_neg_ord hg0, WithZero.exp_le_exp] at h
+      linarith
+  let ψ : adeleBdd D →ₗ[K] P.toValuationSubring :=
+    { toFun := fun α => ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩
+      map_add' := by
+        intro α β; apply Subtype.ext
+        simp only [Submodule.coe_add, Pi.add_apply]
+        push_cast; ring
+      map_smul' := by
+        intro c α; apply Subtype.ext
+        simp only [RingHom.id_apply, SetLike.val_smul, Algebra.smul_def, MulMemClass.coe_mul,
+          Place.coe_algebraMap, Pi.smul_apply]
+        ring }
+  have hψ_apply : ∀ α : adeleBdd D,
+      (ψ α : F) = t ^ (D P) * (α : Place K F → F) P := fun α => rfl
+  let res : P.toValuationSubring →ₗ[K] P.ResidueField :=
+    (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K
+  have hres : ∀ x : P.toValuationSubring, res x = IsLocalRing.residue _ x := by
+    intro x
+    change (Algebra.linearMap P.toValuationSubring P.ResidueField).restrictScalars K x = _
+    rw [LinearMap.restrictScalars_apply, Algebra.linearMap_apply,
+      IsLocalRing.ResidueField.algebraMap_eq]
+  let φ : adeleBdd D →ₗ[K] P.ResidueField := res ∘ₗ ψ
+  have hphi : ∀ α : adeleBdd D, φ α = 0 ↔
+      (⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ : P.toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal P.toValuationSubring := fun α => by
+    rw [show φ α = IsLocalRing.residue P.toValuationSubring
+            ⟨t ^ (D P) * (α : Place K F → F) P, hmem _ α.2⟩ from hres (ψ α),
+      IsLocalRing.residue_eq_zero_iff]
+  have hker : LinearMap.ker φ = (adeleBdd E).comap (adeleBdd D).subtype := by
+    ext α
+    simp only [LinearMap.mem_ker, Submodule.mem_comap, Submodule.coe_subtype]
+    rw [hphi α, P.mk_mem_maximalIdeal_iff, mem_adeleBdd]
+    have hαD := α.2
+    constructor
+    · rintro (h | h) v
+      · have hα0 : (α : Place K F → F) P = 0 := by
+          rcases mul_eq_zero.mp h with h' | h'
+          · exact absurd h' htn0
+          · exact h'
+        by_cases hv : v = P
+        · subst v; rw [hα0, Valuation.map_zero]; exact zero_le
+        · rw [hEv v hv]; exact hαD v
+      · by_cases hv : v = P
+        · subst v
+          rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+          · rw [hα0, Valuation.map_zero]; exact zero_le
+          · rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP]
+            rw [hordmul hα0] at h; omega
+        · rw [hEv v hv]; exact hαD v
+    · intro h
+      rcases eq_or_ne ((α : Place K F → F) P) 0 with hα0 | hα0
+      · left; rw [hα0, mul_zero]
+      · right
+        have hP := h P
+        rw [P.adicValuation_eq_exp_neg_ord hα0, WithZero.exp_le_exp, hEP] at hP
+        rw [hordmul hα0]; omega
+  have hsurj : Function.Surjective φ := by
+    intro c
+    obtain ⟨cl, hcl⟩ := IsLocalRing.residue_surjective (R := P.toValuationSubring) c
+    set f : F := (cl : F) * t ^ (-(D P)) with hf
+    have hαD : Pi.single P f ∈ adeleBdd D := by
+      intro v
+      by_cases hv : v = P
+      · subst v
+        simp only [Pi.single_eq_same]
+        rcases eq_or_ne (cl : F) 0 with hc0 | hc0
+        · rw [hf, hc0, zero_mul, Valuation.map_zero]; exact zero_le
+        · have hf0 : f ≠ 0 := by rw [hf]; exact mul_ne_zero hc0 (zpow_ne_zero _ ht0)
+          rw [P.adicValuation_eq_exp_neg_ord hf0, WithZero.exp_le_exp]
+          rw [hf, P.ord_mul hc0 (zpow_ne_zero _ ht0), P.ord_zpow, ht1, mul_one]
+          have hclnn := P.ord_nonneg_of_mem cl.2
+          linarith
+      · rw [Pi.single_eq_of_ne hv, Valuation.map_zero]; exact zero_le
+    refine ⟨⟨Pi.single P f, hαD⟩, ?_⟩
+    change res (ψ ⟨Pi.single P f, hαD⟩) = c
+    rw [hres]
+    rw [show (ψ ⟨Pi.single P f, hαD⟩ : P.toValuationSubring) = cl from ?_, hcl]
+    apply Subtype.ext
+    rw [hψ_apply]
+    change t ^ (D P) * (Pi.single P f : Place K F → F) P = (cl : F)
+    rw [show (Pi.single P f : Place K F → F) P = f from Pi.single_eq_same _ _, hf,
+      mul_comm (cl : F), ← mul_assoc, ← zpow_add₀ ht0, add_neg_cancel, zpow_zero, one_mul]
+  exact (Submodule.Quotient.equiv _ _ (LinearEquiv.refl K _) (by rw [← hker]; simp)).trans
+    (φ.quotKerEquivOfSurjective hsurj)
+
+theorem finrank_adeleBdd_quotient_single [IsCurveOver K F] (D : Divisor K F) (P : Place K F) :
+    Module.Finite K
+        (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype) ∧
+      finrank K
+          (adeleBdd D ⧸ (adeleBdd (D - Finsupp.single P 1)).comap (adeleBdd D).subtype)
+        = P.deg := by
+  have := IsCurveOver.finite_residueField (K := K) P
+  exact ⟨Module.Finite.equiv (adeleBddQuotSingleEquivResidueField D P).symm,
+    (adeleBddQuotSingleEquivResidueField D P).finrank_eq⟩
+
+theorem finrank_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+      (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+        = Divisor.degree D₂ - Divisor.degree D₁ := by
+  classical
+  suffices H : ∀ m : ℕ, ∀ D₁ D₂ : Divisor K F, D₁ ≤ D₂ →
+      (Divisor.degree (D₂ - D₁)).toNat = m →
+      Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) ∧
+        (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+          = Divisor.degree D₂ - Divisor.degree D₁ from
+    H _ D₁ D₂ hD rfl
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m IH =>
+    intro D₁ D₂ hD hm
+    have hEeff : ∀ v, 0 ≤ (D₂ - D₁) v := fun v => by
+      rw [Finsupp.sub_apply]; have := hD v; omega
+    by_cases hD0 : D₂ - D₁ = 0
+    · have hD12 : D₁ = D₂ := (sub_eq_zero.mp hD0).symm
+      subst hD12
+      rw [Submodule.comap_subtype_self]
+      have : Subsingleton (adeleBdd D₁ ⧸ (⊤ : Submodule K (adeleBdd D₁))) :=
+        Submodule.Quotient.subsingleton_iff.mpr rfl
+      exact ⟨Module.Finite.of_finite, by simp [Module.finrank_zero_of_subsingleton]⟩
+    · obtain ⟨P, hP⟩ := Finsupp.support_nonempty_iff.mpr hD0
+      have hPpos : 1 ≤ (D₂ - D₁) P := by
+        have hne : (D₂ - D₁) P ≠ 0 := Finsupp.mem_support_iff.mp hP
+        have := hEeff P; omega
+      set D₂' : Divisor K F := D₂ - Finsupp.single P 1 with hD₂'
+      have h12' : D₁ ≤ D₂' := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]
+          have := hPpos; rw [Finsupp.sub_apply] at this; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]; exact hD v
+      have h2'2 : D₂' ≤ D₂ := by
+        intro v; rw [hD₂', Finsupp.sub_apply]
+        by_cases hv : v = P
+        · subst v; rw [Finsupp.single_eq_same]; omega
+        · rw [Finsupp.single_eq_of_ne hv, sub_zero]
+      have hdegD₂' : Divisor.degree D₂' = Divisor.degree D₂ - P.deg := by
+        rw [hD₂', map_sub, Divisor.degree_single, one_mul]
+      have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+      have hEnn : 0 ≤ Divisor.degree (D₂ - D₁) := Divisor.degree_nonneg_of_nonneg hEeff
+      have hE'nn : 0 ≤ Divisor.degree (D₂' - D₁) := Divisor.degree_nonneg_of_nonneg
+        (fun v => by rw [Finsupp.sub_apply]; have := h12' v; omega)
+      have hdegdiff : Divisor.degree (D₂' - D₁) = Divisor.degree (D₂ - D₁) - P.deg := by
+        simp only [hD₂', map_sub, Divisor.degree_single, one_mul]; ring
+      have hmlt : (Divisor.degree (D₂' - D₁)).toNat < m := by rw [← hm]; omega
+      obtain ⟨hfin', hrank'⟩ := IH _ hmlt D₁ D₂' h12' rfl
+      obtain ⟨hfinS, hrankS⟩ := finrank_adeleBdd_quotient_single (K := K) D₂ P
+      rw [← hD₂'] at hfinS hrankS
+      have := hfin'; have := hfinS
+      obtain ⟨hfin, hrank⟩ := Submodule.finrank_quotient_chain
+        (A := adeleBdd D₁) (B := adeleBdd D₂') (C := adeleBdd D₂)
+        (adeleBdd_mono h12') (adeleBdd_mono h2'2)
+      refine ⟨hfin, ?_⟩
+      rw [hrank, hrankS]
+      push_cast
+      linarith [hrank', hdegD₂']
+
+theorem module_finite_adeleBdd_quotient [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Module.Finite K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  (finrank_adeleBdd_quotient hD).1
+
+theorem finrank_adeleBdd_quotient_eq [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) : ℤ)
+      = Divisor.degree D₂ - Divisor.degree D₁ :=
+  (finrank_adeleBdd_quotient hD).2
+
+def lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (_hD : D₁ ≤ D₂) :
+    (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      →ₗ[K] (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+  Submodule.mapQ _ _
+    ((diagonalHom K F).restrict
+      (p := (LSpace D₂ : Submodule K F)) (q := (adeleBdd D₂ : Submodule K _))
+      (fun f hf => diagonal_mem_adeleBdd_iff.mpr hf))
+    (fun f hf => by
+      simp only [Submodule.mem_comap, Submodule.coe_subtype] at hf ⊢
+      exact diagonal_mem_adeleBdd_iff.mpr hf)
+
+theorem lSpaceQuotientToAdeleBddQuotient_injective {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    Function.Injective (lSpaceQuotientToAdeleBddQuotient hD) := by
+  rw [injective_iff_map_eq_zero]
+  intro x hx
+  obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+  rw [Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype]
+  rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk f)
+        = Submodule.Quotient.mk ((diagonalHom K F).restrict
+            (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f) from rfl,
+    Submodule.Quotient.mk_eq_zero, Submodule.mem_comap, Submodule.coe_subtype] at hx
+  exact diagonal_mem_adeleBdd_iff.mp hx
+
+
+theorem ell_sub_ell_le_degree_sub_degree [IsCurveOver K F] {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)] :
+    (ell D₂ : ℤ) - (ell D₁ : ℤ) ≤ Divisor.degree D₂ - Divisor.degree D₁ := by
+  have := module_finite_adeleBdd_quotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    rw [hℓ₁]; exact (Submodule.finrank_quotient_add_finrank _).symm
+  have hemb : finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype)
+      ≤ finrank K (adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) :=
+    LinearMap.finrank_le_finrank_of_injective (lSpaceQuotientToAdeleBddQuotient_injective hD)
+  have hloc := finrank_adeleBdd_quotient_eq hD
+  have : (ell D₂ : ℤ) - (ell D₁ : ℤ)
+      = (finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) : ℤ) := by
+    rw [hL]; push_cast; ring
+  rw [this, ← hloc]
+  exact_mod_cast hemb
+
+theorem adeleBdd_inf_sup_globalSub {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F)
+      = adeleBdd D₁ ⊔ adeleBdd D₂ ⊓ globalSub K F := by
+  rw [inf_comm, sup_inf_assoc_of_le _ (adeleBdd_mono hD), inf_comm]
+
+theorem map_diagonal_lSpace_inf_adeleBdd {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    (LSpace D₂).map (diagonalHom K F) ⊓ adeleBdd D₁ = (LSpace D₁).map (diagonalHom K F) := by
+  rw [map_diagonal_lSpace, map_diagonal_lSpace, inf_right_comm,
+    inf_eq_right.mpr (adeleBdd_mono hD)]
+
+theorem gate_finrank_adeleBdd_quotient_single_point [IsCurveOver K F] (P : Place K F) :
+    (finrank K (adeleBdd (Finsupp.single P 1 : Divisor K F)
+        ⧸ (adeleBdd (0 : Divisor K F)).comap (adeleBdd (Finsupp.single P 1)).subtype) : ℤ)
+      = (P.deg : ℤ) := by
+  classical
+  have h01 : (0 : Divisor K F) ≤ Finsupp.single P 1 := by
+    intro v; rw [Finsupp.zero_apply, Finsupp.single_apply]; split_ifs <;> omega
+  have h := finrank_adeleBdd_quotient_eq (K := K) h01
+  rw [h, map_zero, sub_zero, Divisor.degree_single, one_mul]
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq Quotient.eq inclusion mk mem_bot subtype_injective \
+  Quotient.subsingleton_iff Quotient.mk restrictScalars inclusion_injective comapSubtypeEquivOfLe \
+  mem_comap finrank_quotient_add_finrank mem_top Quotient.equiv mkQ mem_map coe_subtype map_smul' \
+  zero one quotientQuotientEquivQuotient coe_eq_zero finrank_le range_subtype \
+  Quotient.mk_surjective map mem_inf mem_sup Quotient.mk_eq_zero topEquiv \
+  map_injective_of_injective comap_subtype_self mapQ subsingleton_iff module smul_def mk_eq_zero \
+  coe_add mkQ_apply ext ker_mkQ map_comap_subtype comap comap_mono map_sup coe_zero"
+p2m_open "Submodule"
+
+variable {K X : Type*} [Field K] [AddCommGroup X] [Module K X]
+
+theorem comap_subtype_sup_of_le_of_le {S T C : Submodule K X} (hS : S ≤ C) (hT : T ≤ C) :
+    S.comap C.subtype ⊔ T.comap C.subtype = (S ⊔ T).comap C.subtype := by
+  apply Submodule.map_injective_of_injective (f := C.subtype) C.subtype_injective
+  rw [Submodule.map_sup, Submodule.map_comap_subtype, Submodule.map_comap_subtype,
+    Submodule.map_comap_subtype, inf_eq_right.mpr hS, inf_eq_right.mpr hT,
+    inf_eq_right.mpr (sup_le hS hT)]
+
+theorem finrank_quotient_chain_top {M : Type*} [AddCommGroup M] [Module K M]
+    {A B : Submodule K M} (hAB : A ≤ B)
+    [hMB : Module.Finite K (M ⧸ B)] [hBA : Module.Finite K (B ⧸ A.comap B.subtype)] :
+    Module.Finite K (M ⧸ A) ∧
+      finrank K (M ⧸ A) = finrank K (M ⧸ B) + finrank K (B ⧸ A.comap B.subtype) := by
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  let ψ : (B : Type _) →ₗ[K] (M ⧸ A) := A.mkQ ∘ₗ B.subtype
+  have hker : LinearMap.ker ψ = A.comap B.subtype := by
+    simp only [ψ, LinearMap.ker_comp, ker_mkQ]
+  have hran : LinearMap.range ψ = B.map A.mkQ := by
+    simp only [ψ, LinearMap.range_comp, range_subtype]
+  let eK : (B ⧸ A.comap B.subtype) ≃ₗ[K] (B.map A.mkQ : Submodule K (M ⧸ A)) :=
+    (Submodule.quotEquivOfEq _ _ hker.symm).trans
+      (ψ.quotKerEquivRange.trans (LinearEquiv.ofEq _ _ hran))
+  have : Module.Finite K (B.map A.mkQ : Submodule K (M ⧸ A)) := Module.Finite.equiv eK
+  have : Module.Finite K ((M ⧸ A) ⧸ B.map A.mkQ) := Module.Finite.equiv e3.symm
+  have hfin : Module.Finite K (M ⧸ A) := Module.Finite.of_submodule_quotient (B.map A.mkQ)
+  refine ⟨hfin, ?_⟩
+  have h := Submodule.finrank_quotient_add_finrank (R := K) (B.map A.mkQ)
+  rw [LinearEquiv.finrank_eq e3, ← LinearEquiv.finrank_eq eK] at h
+  omega
+
+end Submodule
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem globalSub_le_adeleSpace [HasPrincipalDivisors K F] :
+    globalSub K F ≤ adeleSpace K F := by
+  rintro _ ⟨f, rfl⟩
+  exact diagonal_mem_adeleSpace f
+
+theorem adeleBdd_sup_globalSub_le_adeleSpace [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBdd D ⊔ globalSub K F ≤ adeleSpace K F :=
+  sup_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_eq_comap [HasPrincipalDivisors K F] (D : Divisor K F) :
+    adeleBddPrincipal K F D = (adeleBdd D ⊔ globalSub K F).comap (adeleSpace K F).subtype :=
+  Submodule.comap_subtype_sup_of_le_of_le adeleBdd_le_adeleSpace globalSub_le_adeleSpace
+
+theorem adeleBddPrincipal_mono {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    adeleBddPrincipal K F D₁ ≤ adeleBddPrincipal K F D₂ :=
+  sup_le_sup_right (Submodule.comap_mono (adeleBdd_mono hD)) _
+
+section FiniteLSpace
+
+variable [IsCurveOver K F]
+
+theorem finiteDimensional_lSpace [hL0 : FiniteDimensional K (LSpace (0 : Divisor K F))]
+    (D : Divisor K F) : FiniteDimensional K (LSpace D) := by
+  have h0D : (0 : Divisor K F) ≤ D ⊔ 0 := le_sup_right
+  have hDD : D ≤ D ⊔ 0 := le_sup_left
+  suffices h : FiniteDimensional K (LSpace (D ⊔ 0)) by
+    exact Module.Finite.of_injective (Submodule.inclusion (lSpace_mono hDD))
+      (Submodule.inclusion_injective _)
+  have := module_finite_adeleBdd_quotient (K := K) h0D
+  have hfinQ : FiniteDimensional K
+      (LSpace (D ⊔ 0) ⧸ (LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype) :=
+    Module.Finite.of_injective _ (lSpaceQuotientToAdeleBddQuotient_injective h0D)
+  have : FiniteDimensional K
+      ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype : Submodule K _) :=
+    Module.Finite.equiv (Submodule.comapSubtypeEquivOfLe (lSpace_mono h0D)).symm
+  exact Module.Finite.of_submodule_quotient
+    ((LSpace (0 : Divisor K F)).comap (LSpace (D ⊔ 0)).subtype)
+
+end FiniteLSpace
+
+
+theorem range_lSpaceQuotientToAdeleBddQuotient {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) :
+    LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD)
+      = ((adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype).map
+          ((adeleBdd D₁).comap (adeleBdd D₂).subtype).mkQ := by
+  classical
+  ext z
+  obtain ⟨α, rfl⟩ := Submodule.Quotient.mk_surjective _ z
+  simp only [LinearMap.mem_range, Submodule.mem_map, Submodule.mem_comap, Submodule.coe_subtype,
+    Submodule.mkQ_apply]
+  constructor
+  · rintro ⟨x, hx⟩
+    obtain ⟨f, rfl⟩ := Submodule.Quotient.mk_surjective _ x
+    have hxeq : Submodule.Quotient.mk
+        ((diagonalHom K F).restrict (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) f)
+        = (Submodule.Quotient.mk α :
+            adeleBdd D₂ ⧸ (adeleBdd D₁).comap (adeleBdd D₂).subtype) := hx
+    refine ⟨α, ?_, rfl⟩
+    have hdiag2 : (diagonalHom K F (f : F)) ∈ adeleBdd D₂ := diagonal_mem_adeleBdd_iff.mpr f.2
+    have hsub : (α : Place K F → F) - diagonalHom K F (f : F) ∈ adeleBdd D₁ := by
+      have hq := (Submodule.Quotient.eq _).mp hxeq.symm
+      simpa using hq
+    refine Submodule.mem_sup.mpr ⟨(α : Place K F → F) - diagonalHom K F (f : F), hsub,
+      diagonalHom K F (f : F), diagonal_mem_globalSub _, ?_⟩
+    abel
+  · rintro ⟨β, hβ, hβeq⟩
+    have hβ' : (β : Place K F → F) ∈ adeleBdd D₂ ⊓ (adeleBdd D₁ ⊔ globalSub K F) :=
+      Submodule.mem_inf.mpr ⟨β.2, hβ⟩
+    rw [adeleBdd_inf_sup_globalSub hD, ← map_diagonal_lSpace] at hβ'
+    obtain ⟨γ, hγ, δ, ⟨f, hf, hfδ⟩, hsum⟩ := Submodule.mem_sup.mp hβ'
+    refine ⟨Submodule.Quotient.mk ⟨f, hf⟩, ?_⟩
+    rw [show (lSpaceQuotientToAdeleBddQuotient hD) (Submodule.Quotient.mk ⟨f, hf⟩)
+          = Submodule.Quotient.mk ((diagonalHom K F).restrict
+              (fun g hg => diagonal_mem_adeleBdd_iff.mpr hg) ⟨f, hf⟩) from rfl,
+      ← hβeq, Submodule.Quotient.eq]
+    refine Submodule.mem_comap.mpr ?_
+    change diagonalHom K F f - (β : Place K F → F) ∈ adeleBdd D₁
+    have hβsub : diagonalHom K F f - (β : Place K F → F) = -γ := by
+      rw [← hsum, hfδ]; ring
+    rw [hβsub]; exact (adeleBdd D₁).neg_mem hγ
+
+
+theorem finrank_adeleBddSup_quotient [IsCurveOver K F] [Nonempty (Place K F)]
+    {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂) [hL : FiniteDimensional K (LSpace D₂)] :
+    Module.Finite K (↥(adeleBdd D₂ ⊔ globalSub K F)
+        ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) ∧
+      (finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+          ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) : ℤ)
+        = (Divisor.degree D₂ - ell D₂) - (Divisor.degree D₁ - ell D₁) := by
+  classical
+  let A : Submodule K (adeleBdd D₂) := (adeleBdd D₁).comap (adeleBdd D₂).subtype
+  let B : Submodule K (adeleBdd D₂) :=
+    (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype
+  have hAB : A ≤ B := Submodule.comap_mono le_sup_left
+  have hfinA : Module.Finite K (adeleBdd D₂ ⧸ A) := module_finite_adeleBdd_quotient hD
+  have hdimA : (finrank K (adeleBdd D₂ ⧸ A) : ℤ) = Divisor.degree D₂ - Divisor.degree D₁ :=
+    finrank_adeleBdd_quotient_eq hD
+  have hran : LinearMap.range (lSpaceQuotientToAdeleBddQuotient hD) = B.map A.mkQ :=
+    range_lSpaceQuotientToAdeleBddQuotient hD
+  have hℓ₁ : ell D₁ = finrank K ((LSpace D₁).comap (LSpace D₂).subtype) :=
+    (LinearEquiv.finrank_eq (Submodule.comapSubtypeEquivOfLe (lSpace_mono hD))).symm
+  have hdimL : ell D₂
+      = finrank K (LSpace D₂ ⧸ (LSpace D₁).comap (LSpace D₂).subtype) + ell D₁ := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K)
+      ((LSpace D₁).comap (LSpace D₂).subtype)
+    rw [← hℓ₁] at h; exact h.symm
+  have hdimB : ell D₂ = finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) + ell D₁ := by
+    rw [← hran, LinearMap.finrank_range_of_inj
+      (lSpaceQuotientToAdeleBddQuotient_injective hD)]
+    exact hdimL
+  have e3 := Submodule.quotientQuotientEquivQuotient A B hAB
+  have hfinB : Module.Finite K (adeleBdd D₂ ⧸ B) := Module.Finite.equiv e3
+  have hdim2 : finrank K (adeleBdd D₂ ⧸ A)
+      = finrank K (adeleBdd D₂ ⧸ B) + finrank K (B.map A.mkQ : Submodule K _) := by
+    have h := Submodule.finrank_quotient_add_finrank (R := K) (M := adeleBdd D₂ ⧸ A)
+      (B.map A.mkQ)
+    rw [LinearEquiv.finrank_eq e3] at h; omega
+  have e2 := LinearMap.quotientInfEquivSupQuotient (R := K)
+    (adeleBdd D₂) (adeleBdd D₁ ⊔ globalSub K F)
+  have hsup : adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F) = adeleBdd D₂ ⊔ globalSub K F := by
+    rw [← sup_assoc, sup_eq_left.mpr (adeleBdd_mono hD)]
+  have hB' : (adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype = B := by
+    rw [Submodule.comap_subtype_self, top_inf_eq]
+  let eL : (adeleBdd D₂ ⧸ B) ≃ₗ[K]
+      (adeleBdd D₂ ⧸ ((adeleBdd D₂).comap (adeleBdd D₂).subtype ⊓
+        (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂).subtype)) :=
+    Submodule.quotEquivOfEq _ _ hB'.symm
+  have hfin_iso : Module.Finite K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype) :=
+    Module.Finite.equiv (eL.trans e2)
+  have hdim_iso : finrank K (↥(adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)) ⧸
+        (adeleBdd D₁ ⊔ globalSub K F).comap
+          (adeleBdd D₂ ⊔ (adeleBdd D₁ ⊔ globalSub K F)).subtype)
+      = finrank K (adeleBdd D₂ ⧸ B) :=
+    (LinearEquiv.finrank_eq (eL.trans e2)).symm
+  have hcast : (finrank K (adeleBdd D₂ ⧸ A) : ℤ)
+      = (finrank K (adeleBdd D₂ ⧸ B) : ℤ) + ((ell D₂ : ℤ) - (ell D₁ : ℤ)) := by
+    have hb : (ell D₂ : ℤ)
+        = (finrank K (B.map A.mkQ : Submodule K (adeleBdd D₂ ⧸ A)) : ℤ) + (ell D₁ : ℤ) := by
+      exact_mod_cast hdimB
+    push_cast [hdim2]; linarith
+  have hgoal : (finrank K (adeleBdd D₂ ⧸ B) : ℤ)
+      = Divisor.degree D₂ - ↑(ell D₂) - (Divisor.degree D₁ - ↑(ell D₁)) := by
+    linarith [hdimA, hcast]
+  clear_value eL
+  exact hsup ▸ ⟨hfin_iso, by rw [hdim_iso]; exact hgoal⟩
+
+section Index
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+
+theorem adeleBddSup_eq_of_degree_sub_ell_eq {D₁ D₂ : Divisor K F} (hD : D₁ ≤ D₂)
+    [FiniteDimensional K (LSpace D₂)]
+    (heq : Divisor.degree D₂ - ell D₂ = Divisor.degree D₁ - ell D₁) :
+    adeleBdd D₂ ⊔ globalSub K F = adeleBdd D₁ ⊔ globalSub K F := by
+  obtain ⟨hfin, hdim⟩ := finrank_adeleBddSup_quotient hD
+  rw [heq, sub_self] at hdim
+  refine le_antisymm ?_ (sup_le_sup_right (adeleBdd_mono hD) _)
+  have := hfin
+  have hd0 : finrank K (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) = 0 := by
+    exact_mod_cast hdim
+  have hsub : Subsingleton (↥(adeleBdd D₂ ⊔ globalSub K F)
+      ⧸ (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype) :=
+    Module.finrank_zero_iff.mp hd0
+  have htop := Submodule.Quotient.subsingleton_iff.mp hsub
+  intro x hx
+  have hxc : (⟨x, hx⟩ : ↥(adeleBdd D₂ ⊔ globalSub K F)) ∈
+      (adeleBdd D₁ ⊔ globalSub K F).comap (adeleBdd D₂ ⊔ globalSub K F).subtype := by
+    rw [htop]; exact Submodule.mem_top
+  exact hxc
+
+end Index
+
+namespace RiemannGenusReachedAt
+p2m_export "AlgebraicCurve.RiemannGenusReachedAt" "finite mk eq isMax"
+end RiemannGenusReachedAt
+namespace RiemannGenusReachedAt
+p2m_open_scoped "AlgebraicCurve.RiemannGenusReachedAt" in
+private theorem _root_.AlgebraicCurve.RiemannGenusReachedAt.eq_of_ge [IsCurveOver K F]
+    [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {D : Divisor K F} (hD : D₀ ≤ D) :
+    Divisor.degree D - ell D = γ - 1 := by
+  have := finiteDimensional_lSpace (K := K) D
+  have hge : Divisor.degree D₀ - (ell D₀ : ℤ) ≤ Divisor.degree D - ell D := by
+    have := ell_sub_ell_le_degree_sub_degree (K := K) hD
+    linarith
+  exact le_antisymm (h.isMax D) (h.eq ▸ hge)
+
+end RiemannGenusReachedAt
+p2m_export "AlgebraicCurve" "RiemannGenusReachedAt.eq_of_ge"
+
+theorem adeleSpace_eq_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    adeleSpace K F = adeleBdd D₀ ⊔ globalSub K F := by
+  refine le_antisymm ?_ (adeleBdd_sup_globalSub_le_adeleSpace D₀)
+  rw [adeleSpace, iSup_le_iff]
+  intro D
+  refine le_trans (adeleBdd_mono (le_sup_left : D ≤ D ⊔ D₀)) ?_
+  have := finiteDimensional_lSpace (K := K) (D ⊔ D₀)
+  have heq : Divisor.degree (D ⊔ D₀) - ell (D ⊔ D₀) = Divisor.degree D₀ - ell D₀ :=
+    (h.eq_of_ge le_sup_right).trans h.eq.symm
+  have hsup := adeleBddSup_eq_of_degree_sub_ell_eq (K := K)
+    (le_sup_right : D₀ ≤ D ⊔ D₀) heq
+  rw [← hsup]
+  exact le_sup_left
+
+theorem indexOfSpecialty_eq_zero_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    indexOfSpecialty D₀ = 0 := by
+  rw [indexOfSpecialty_eq, adeleBddPrincipal_eq_comap, ← adeleSpace_eq_of_genusReached h,
+    Submodule.comap_subtype_self]
+  have : Subsingleton (adeleSpace K F ⧸ (⊤ : Submodule K (adeleSpace K F))) :=
+    Submodule.Quotient.subsingleton_iff.mpr rfl
+  exact Module.finrank_zero_of_subsingleton
+
+
+
+theorem gate_indexOfSpecialty_at_witness [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    (indexOfSpecialty D₀ : ℤ) = 0 := by
+  have h1 := (indexOfSpecialty_eq_of_genusReached h D₀).2
+  have h2 := h.eq
+  have h3 := indexOfSpecialty_eq_zero_of_genusReached h
+  exact_mod_cast h3
+
+theorem gate_riemannInequality_of_genusReached [IsCurveOver K F] [Nonempty (Place K F)]
+    [FiniteDimensional K (LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Divisor.degree D + 1 - γ ≤ (ell D : ℤ) := by
+  have heq := (indexOfSpecialty_eq_of_genusReached h D).2
+  have hnn : (0 : ℤ) ≤ indexOfSpecialty D := Int.natCast_nonneg _
+  linarith
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem adeleSpaceMul_add [HasPrincipalDivisors K F] (f g : F) :
+    adeleSpaceMul K F (f + g) = adeleSpaceMul K F f + adeleSpaceMul K F g := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, LinearMap.add_apply, Submodule.coe_add,
+    Pi.add_apply, add_mul]
+
+theorem adeleSpaceMul_zero [HasPrincipalDivisors K F] :
+    adeleSpaceMul K F (0 : F) = 0 := by
+  refine LinearMap.ext fun α => Subtype.ext (funext fun v => ?_)
+  simp only [adeleSpaceMul_coe, mulAdele_apply, zero_mul, LinearMap.zero_apply,
+    Submodule.coe_zero, Pi.zero_apply]
+
+theorem weilSmul_add_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f + g) φ = weilSmul K F f φ + weilSmul K F g φ := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_add, LinearMap.add_apply, map_add]
+
+theorem weilSmul_zero_left [HasPrincipalDivisors K F]
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (0 : F) φ = 0 := by
+  ext α
+  simp only [weilSmul_apply, adeleSpaceMul_zero, LinearMap.zero_apply, map_zero]
+
+theorem weilSmul_neg_left [HasPrincipalDivisors K F] (f : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (-f) φ = -weilSmul K F f φ := by
+  have h := weilSmul_add_left (K := K) (F := F) f (-f) φ
+  rw [add_neg_cancel, weilSmul_zero_left] at h
+  exact (neg_eq_of_add_eq_zero_right h.symm).symm
+
+theorem weilSmul_sub_left [HasPrincipalDivisors K F] (f g : F)
+    (φ : Module.Dual K (adeleSpace K F)) :
+    weilSmul K F (f - g) φ = weilSmul K F f φ - weilSmul K F g φ := by
+  rw [sub_eq_add_neg, weilSmul_add_left, weilSmul_neg_left, sub_eq_add_neg]
+
+theorem weilSmul_eq_zero_iff_left [HasPrincipalDivisors K F]
+    {f : F} {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    weilSmul K F f φ = 0 ↔ f = 0 := by
+  refine ⟨fun h => ?_, fun h => h ▸ weilSmul_zero_left φ⟩
+  by_contra hf
+  exact hφ (weilSmul_injective hf (h.trans (map_zero (weilSmul K F f)).symm))
+
+theorem weilSmul_left_injective [HasPrincipalDivisors K F]
+    {φ : Module.Dual K (adeleSpace K F)} (hφ : φ ≠ 0) :
+    Function.Injective (fun f : F => weilSmul K F f φ) := by
+  intro f g hfg
+  have hsub : weilSmul K F (f - g) φ = 0 := by
+    rw [weilSmul_sub_left, sub_eq_zero]; exact hfg
+  exact sub_eq_zero.mp ((weilSmul_eq_zero_iff_left hφ).mp hsub)
+
+variable (K F) in
+def doubleResiduePairing [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) :
+    LSpace (W - D) × LSpace (W - D) →ₗ[K] omegaSpace D :=
+  (residuePairing K F W D hφ).coprod (residuePairing K F W D hμ)
+
+theorem doubleResiduePairing_apply_coe [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (g h : LSpace (W - D)) :
+    (doubleResiduePairing K F W D hφ hμ (g, h) : Module.Dual K (adeleSpace K F))
+      = weilSmul K F (g : F) φ + weilSmul K F (h : F) μ := by
+  simp only [doubleResiduePairing, LinearMap.coprod_apply, Submodule.coe_add,
+    residuePairing_apply_coe]
+
+theorem doubleResiduePairing_injective [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ) :
+    Function.Injective (doubleResiduePairing K F W D hφ hμ) := by
+  rw [injective_iff_map_eq_zero]
+  rintro ⟨g, h⟩ heq
+  have heq' : weilSmul K F (g : F) φ + weilSmul K F (h : F) μ = 0 := by
+    have hcoe := congrArg Subtype.val heq
+    rwa [doubleResiduePairing_apply_coe, Submodule.coe_zero] at hcoe
+  rcases eq_or_ne (h : F) 0 with hh0 | hh0
+  · rw [hh0, weilSmul_zero_left, add_zero] at heq'
+    have hg0 : (g : F) = 0 := (weilSmul_eq_zero_iff_left hφ0).mp heq'
+    exact Prod.ext (Subtype.ext hg0) (Subtype.ext hh0)
+  · exfalso
+    have hμeq : weilSmul K F (h : F) μ = -weilSmul K F (g : F) φ := by
+      have h2 : weilSmul K F (h : F) μ + weilSmul K F (g : F) φ = 0 := by
+        rw [add_comm]; exact heq'
+      exact eq_neg_of_add_eq_zero_left h2
+    have hLHS : weilSmul K F (h : F)⁻¹ (weilSmul K F (h : F) μ) = μ := by
+      rw [← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hh0, weilSmul_one,
+        LinearMap.id_apply]
+    have hRHS : weilSmul K F (h : F)⁻¹ (-weilSmul K F (g : F) φ)
+        = weilSmul K F (-(g : F) * (h : F)⁻¹) φ := by
+      rw [map_neg, ← LinearMap.comp_apply, ← weilSmul_mul, neg_mul, weilSmul_neg_left]
+    exact hindep (-(g : F) * (h : F)⁻¹) (by rw [← hLHS, hμeq, hRHS])
+
+theorem two_mul_ell_le_indexOfSpecialty [HasPrincipalDivisors K F] (W D : Divisor K F)
+    {φ μ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W)
+    (hφ0 : φ ≠ 0) (hindep : ∀ f : F, μ ≠ weilSmul K F f φ)
+    [Module.Finite K (omegaSpace (K := K) (F := F) D)]
+    [Module.Finite K (LSpace (K := K) (F := F) (W - D))] :
+    2 * ell (W - D) ≤ indexOfSpecialty D := by
+  have hinj := doubleResiduePairing_injective W D hφ hμ hφ0 hindep
+  have hle := LinearMap.finrank_le_finrank_of_injective hinj
+  rw [Module.finrank_prod] at hle
+  rw [← finrank_omegaSpace_eq_indexOfSpecialty, two_mul]
+  exact hle
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+open Module IsDedekindDomain WithZero
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.coe_algebraMap Divisor Divisor.degree \
+  Divisor.degree_single HasPrincipalDivisors HasPrincipalDivisors.exists_divisor IsCurveOver \
+  IsCurveOver.finite_residueField LSpace ell mem_lSpace_iff_ord lSpace_mono ConstantsAreBase \
+  ell_zero_eq_one_of_constantsAreBase adeleBdd mem_adeleBdd adeleBdd_mono diagonalHom \
+  diagonalHom_injective diagonal_mem_adeleBdd_iff adeleSpace adeleBdd_le_adeleSpace \
+  diagonal_mem_adeleSpace globalSub diagonal_mem_globalSub map_diagonal_lSpace \
+  finrank_adeleBdd_inf_global_eq_ell indexOfSpecialty adeleBddPrincipal indexOfSpecialty_eq \
+  omegaSpace omegaSpace_antitone omegaSpaceEquivIndexDual finrank_omegaSpace_eq_indexOfSpecialty \
+  weilDifferentialModule omegaSpace_le_weilDifferentialModule mem_weilDifferentialModule_iff \
+  mulAdele_apply adeleSpaceMul adeleSpaceMul_coe weilSmul weilSmul_apply weilSmul_one weilSmul_mul \
+  weilSmul_injective weilSmul_mem_omegaSpace_add residuePairing residuePairing_apply_coe \
+  WeilDifferentialRankOne RiemannGenusReachedAt RiemannGenusReached StichtenothGenusExists"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+section Finiteness
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+theorem omegaSpace_finite_of_genusReached_port
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Module.Finite K (omegaSpace (K := K) (F := F) D) := by
+  have := (indexOfSpecialty_eq_of_genusReached h D).1
+  exact Module.Finite.equiv (omegaSpaceEquivIndexDual D).symm
+
+end Finiteness
+
+section ParametricRankOne
+
+variable [IsCurveOver K F] [Nonempty (Place K F)]
+  [FiniteDimensional K (LSpace (0 : Divisor K F))]
+
+
+theorem exists_weilSmul_eq_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀)
+    {φ μ : Module.Dual K (adeleSpace K F)} {W : Divisor K F}
+    (hφ : φ ∈ omegaSpace W) (hμ : μ ∈ omegaSpace W) (hφ0 : φ ≠ 0) :
+    ∃ f : F, μ = weilSmul K F f φ := by
+  by_contra hcon
+  push Not at hcon
+  obtain ⟨P⟩ := ‹Nonempty (Place K F)›
+  set n : ℕ := 3 * γ.natAbs + 2 * (Divisor.degree W).natAbs + 4 with hn
+  set D : Divisor K F := -Finsupp.single P (n : ℤ) with hD
+  have hdegD : Divisor.degree D = -(n : ℤ) * (P.deg : ℤ) := by
+    rw [hD, map_neg, Divisor.degree_single]; ring
+  have hdegWD : Divisor.degree (W - D) = Divisor.degree W + (n : ℤ) * (P.deg : ℤ) := by
+    rw [map_sub, hdegD]; ring
+  have hPdeg1 : 1 ≤ (P.deg : ℤ) := by exact_mod_cast one_le_deg P
+  have habsγ : -(|γ|) ≤ γ ∧ γ ≤ |γ| := ⟨neg_abs_le _, le_abs_self _⟩
+  have habsW : -|Divisor.degree W| ≤ Divisor.degree W ∧
+      Divisor.degree W ≤ |Divisor.degree W| := ⟨neg_abs_le _, le_abs_self _⟩
+  have hn_ge : 3 * |γ| + 2 * |Divisor.degree W| + 4 ≤ (n : ℤ) := by
+    rw [hn]; push_cast [Int.natCast_natAbs]; ring_nf; omega
+  have hndegP : (n : ℤ) ≤ (n : ℤ) * (P.deg : ℤ) := by nlinarith [Int.natCast_nonneg n]
+  have hellD : ell D = 0 := ell_eq_zero_of_degree_neg (by rw [hdegD]; nlinarith)
+  have hiD : (indexOfSpecialty D : ℤ) = (n : ℤ) * (P.deg : ℤ) - 1 + γ := by
+    have hidx := (indexOfSpecialty_eq_of_genusReached h D).2
+    rw [hellD, hdegD] at hidx; push_cast at hidx; linarith
+  have hlowerWD : Divisor.degree W + (n : ℤ) * (P.deg : ℤ) + 1 - γ
+      ≤ (ell (W - D) : ℤ) := by
+    have hlow := gate_riemannInequality_of_genusReached h (W - D)
+    rw [hdegWD] at hlow; exact hlow
+  have := omegaSpace_finite_of_genusReached_port h D
+  have := finiteDimensional_lSpace (K := K) (W - D)
+  have hdbl : (2 * ell (W - D) : ℤ) ≤ (indexOfSpecialty D : ℤ) := by
+    exact_mod_cast two_mul_ell_le_indexOfSpecialty W D hφ hμ hφ0 hcon
+  rw [hiD] at hdbl
+  nlinarith [habsγ.1, habsγ.2, habsW.1, habsW.2]
+
+theorem weilDifferentialRankOne_of_genusReached
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) :
+    WeilDifferentialRankOne K F := by
+  intro φ hφmem hφ0 μ hμmem
+  obtain ⟨W₁, hφW₁⟩ := mem_weilDifferentialModule_iff.mp hφmem
+  obtain ⟨W₂, hμW₂⟩ := mem_weilDifferentialModule_iff.mp hμmem
+  have hφW : φ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_left hφW₁
+  have hμW : μ ∈ omegaSpace (W₁ ⊓ W₂) := omegaSpace_antitone inf_le_right hμW₂
+  obtain ⟨f, hf⟩ := exists_weilSmul_eq_of_genusReached h hφW hμW hφ0
+  exact ⟨f, hf, fun f' hf' => weilSmul_left_injective hφ0 (hf'.symm.trans hf)⟩
+
+end ParametricRankOne
+
+theorem residuePairing_surjective_of_rankOne_max [HasPrincipalDivisors K F]
+    (hRankOne : WeilDifferentialRankOne K F)
+    {W : Divisor K F} {φ : Module.Dual K (adeleSpace K F)}
+    (hφ : φ ∈ omegaSpace W) (hφ0 : φ ≠ 0)
+    (hWmax : ∀ E : Divisor K F, φ ∈ omegaSpace E → E ≤ W) (D : Divisor K F) :
+    Function.Surjective (residuePairing K F W D hφ) := by
+  rintro ⟨μ, hμD⟩
+  have hφmem : φ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule W hφ
+  have hμmem : μ ∈ weilDifferentialModule K F := omegaSpace_le_weilDifferentialModule D hμD
+  obtain ⟨f, hf, -⟩ := hRankOne hφmem hφ0 hμmem
+  rcases eq_or_ne f 0 with rfl | hf0
+  · have hμ0 : (⟨μ, hμD⟩ : omegaSpace D) = 0 :=
+      Subtype.ext (hf.trans (weilSmul_zero_left φ))
+    exact ⟨0, (map_zero _).trans hμ0.symm⟩
+  · obtain ⟨P, hPord, _⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+    have hPinv : ∀ v, (-P) v = v.ord f⁻¹ := fun v => by
+      rw [Finsupp.neg_apply, hPord v, v.ord_inv]
+    have hinv : weilSmul K F f⁻¹ μ = φ := by
+      rw [hf, ← LinearMap.comp_apply, ← weilSmul_mul, mul_inv_cancel₀ hf0, weilSmul_one,
+        LinearMap.id_apply]
+    have hφD : φ ∈ omegaSpace (D + -P) := by
+      rw [← hinv]; exact weilSmul_mem_omegaSpace_add (inv_ne_zero hf0) hPinv hμD
+    have hDP : D + -P ≤ W := hWmax _ hφD
+    have hfL : f ∈ LSpace (W - D) := by
+      rw [mem_lSpace_iff_ord]; refine Or.inr fun v => ?_
+      have hv := hDP v
+      rw [Finsupp.add_apply, Finsupp.neg_apply, hPord v] at hv
+      rw [Finsupp.sub_apply]; linarith
+    exact ⟨⟨f, hfL⟩, Subtype.ext hf.symm⟩
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_omegaSpace_finite_of_genusReached.AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] [IsCurveOver K F]
+    [Nonempty (Place K F)] [FiniteDimensional K ↥(LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Module.Finite K ↥(omegaSpace (K := K) (F := F) D) :=
+  AlgebraicCurve.omegaSpace_finite_of_genusReached_port (K := K) (F := F) (γ := γ) (D₀ := D₀) (h :=
+    h) (D := D)
+
+end S_AlgebraicCurve_omegaSpace_finite_of_genusReached
+end P2MW
+export P2MW.S_AlgebraicCurve_omegaSpace_finite_of_genusReached (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace AlgebraicCurve
+theorem omegaSpace_finite_of_genusReached {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [IsCurveOver K F] [Nonempty (Place K F)] [FiniteDimensional K ↥(LSpace (0 : Divisor K F))]
+    {γ : ℤ} {D₀ : Divisor K F} (h : RiemannGenusReachedAt γ D₀) (D : Divisor K F) :
+    Module.Finite K ↥(omegaSpace (K := K) (F := F) D) :=
+  solution h D
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_regularDiffs_eq_regularDifferentials.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_regularDiffs_eq_regularDifferentials.lean
new file mode 100644
index 0000000000..ca938e9e96
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_regularDiffs_eq_regularDifferentials.lean
@@ -0,0 +1,132 @@
+/-
+Based on Prove2Me node AlgebraicCurve.regularDiffs_eq_regularDifferentials
+(eeb90197-6a18-5d59-b415-d945e788feee) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4125e8ef-2377-55ef-9706-f390b8849cab
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RegularDifferentials
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ordDiff_eq_ordDifferential
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_dCoordGenerates_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Two descriptions of the regular differentials agree
+
+Theorem statement: `AlgebraicCurve.regularDiffs_eq_regularDifferentials`
+(`eeb90197-6a18-5d59-b415-d945e788feee`), by Claude, 2026-09-05.
+
+Proof: submission `4125e8ef-2377-55ef-9706-f390b8849cab`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, $K$ of characteristic zero, $F$ essentially of
+finite type over $K$, and assume [`AlgebraicCurve.IsCurveOver K
+F`](def/AlgebraicCurve_IsCurveOver.html#L15): the divisor axiom `HasPrincipalDivisors` (every
+nonzero $f \in F$ admits a divisor $D$ with $D(v) = \operatorname{ord}_v(f)$ at every place $v$ and
+$\deg D = 0$), finiteness of each residue field $\kappa(v)$ as a $K$-module, and freeness of
+$\Omega_{F/K}$ over $F$ of rank one. Here a place $v$ is a valuation subring $\mathcal{O}_v
+\subseteq F$ containing the image of $K$, distinct from $F$ itself, and a principal ideal ring. The
+assertion is an equality of two $K$-submodules of $\Omega_{F/K}$: on one side
+[`AlgebraicCurve.regularDiffs K F`](def/AlgebraicCurve_Differentials.html#L56), the $K$-span of the
+set of $\omega$ with $0 \le v.\mathrm{ordDiff}\,\omega$ for every place $v$; on the other
+[`AlgebraicCurve.regularDifferentials K F`](def/AlgebraicCurve_RegularDifferentials.html#L26), the
+set of $\omega$ such that at every place $v$ there exists $f \in \mathcal{O}_v$ with $\omega = f
+\cdot d\pi_v$, where $d\pi_v$ is the Kähler differential of a uniformiser at $v$. The two coincide.
+
+This identifies the space of everywhere-regular (holomorphic) differentials defined by
+non-negativity of the order of $\omega$ at all places with the space defined by local integrality of
+the coefficient against $d\pi_v$; the latter is the space whose dimension is the genus in the
+Riemann–Roch formalism. The identification is used in the dimension computations for spaces of
+regular differentials on modular curves and in the integrality arguments attached to them.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_regularDiffs_eq_regularDifferentials.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_regularDiffs_eq_regularDifferentials
+
+open AlgebraicCurve
+
+namespace S12R
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem mem_iff_ord_nonneg (w : Place K F) {x : F} (hx : x ≠ 0) :
+    x ∈ w.toValuationSubring ↔ 0 ≤ w.ord x := by
+  rw [Place.mem_iff_adicValuation_le_one, Place.ord, neg_nonneg,
+    WithZero.log_le_iff_le_exp (w.adicValuation_ne_zero hx), WithZero.exp_zero]
+
+theorem mem_of_ord_nonneg (w : Place K F) {x : F} (h : 0 ≤ w.ord x) : x ∈ w.toValuationSubring := by
+  rcases eq_or_ne x 0 with rfl | hx
+  · exact zero_mem _
+  · exact (mem_iff_ord_nonneg w hx).mpr h
+
+theorem ord_nonneg_of_mem (w : Place K F) {x : F} (h : x ∈ w.toValuationSubring) : 0 ≤ w.ord x := by
+  rcases eq_or_ne x 0 with rfl | hx
+  · rw [Place.ord_zero]
+  · exact (mem_iff_ord_nonneg w hx).mp h
+
+theorem regularDiffs_eq [CharZero K] [Algebra.EssFiniteType K F] [IsCurveOver K F] :
+    regularDiffs K F = regularDifferentials K F := by
+  have : PerfectField K := inferInstance
+  have hgen : ∀ v : Place K F, v.DCoordGenerates := AlgebraicCurve.dCoordGenerates_of_isCurveOver
+  have key : ∀ (ω : Ω[F⁄K]) (v : Place K F),
+      0 ≤ v.ordDiff ω ↔ ∃ f ∈ v.toValuationSubring, ω = f • v.dCoord := by
+    intro ω v
+    rw [AlgebraicCurve.Place.ordDiff_eq_ordDifferential v ω]
+    constructor
+    · intro h
+      exact ⟨v.differentialCoeff ω, mem_of_ord_nonneg v h, (v.differentialCoeff_smul_dCoord ω).symm⟩
+    · rintro ⟨f, hf, rfl⟩
+      change 0 ≤ v.ord (v.differentialCoeff (f • v.dCoord))
+      rw [v.differentialCoeff_unique (rfl : f • v.dCoord = f • v.dCoord)]
+      exact ord_nonneg_of_mem v hf
+  apply le_antisymm
+  · rw [regularDiffs_eq_span]
+    refine Submodule.span_le.mpr (fun ω hω => ?_)
+    rw [SetLike.mem_coe, mem_regularDifferentials_iff]
+    exact fun v => (key ω v).mp (hω v)
+  · intro ω hω
+    rw [mem_regularDifferentials_iff] at hω
+    exact mem_regularDiffs_of_isRegularDiff (fun v => (key ω v).mpr (hω v))
+
+end S12R
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [CharZero K] [Algebra.EssFiniteType K F] [AlgebraicCurve.IsCurveOver K F] :
+    AlgebraicCurve.regularDiffs K F = AlgebraicCurve.regularDifferentials K F := by
+  exact S12R.regularDiffs_eq
+
+end S_AlgebraicCurve_regularDiffs_eq_regularDifferentials
+end P2MW
+export P2MW.S_AlgebraicCurve_regularDiffs_eq_regularDifferentials (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.regularDiffs_eq_regularDifferentials {K F : Type*} [Field K] [Field F]
+    [Algebra K F]
+    [CharZero K] [Algebra.EssFiniteType K F] [AlgebraicCurve.IsCurveOver K F] :
+    AlgebraicCurve.regularDiffs K F = AlgebraicCurve.regularDifferentials K F :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_residueTheoremK_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_residueTheoremK_of_isAlgClosed.lean
new file mode 100644
index 0000000000..7928417d8c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_residueTheoremK_of_isAlgClosed.lean
@@ -0,0 +1,2671 @@
+/-
+Based on Prove2Me node AlgebraicCurve.residueTheoremK_of_isAlgClosed
+(0b4c7479-cbcc-5c87-9c16-80c7c5d57ccc) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 72e99470-19e3-5ea5-be87-5fc25dbfd308
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_LocalResidue
+
+import Mathlib.Algebra.Module.StablyFree.Basic
+import Mathlib.Analysis.Normed.Unbundled.SpectralNorm
+import Mathlib.RingTheory.Etale.Weakly
+import Mathlib.RingTheory.Norm.Transitivity
+import Mathlib.RingTheory.TotallySplit
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Definitions.Defs_AlgebraicCurve_residueTheorem_sharedLibrary
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_residueTheoremK_ratFunc_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_residueTraceCompletionCommute
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ramificationIndex_eq_ramificationIdx_fiberCenter
+
+
+/-!
+# Residue theorem over an algebraically closed base field
+
+Theorem statement: `AlgebraicCurve.residueTheoremK_of_isAlgClosed`
+(`0b4c7479-cbcc-5c87-9c16-80c7c5d57ccc`), by Claude, 2026-09-05.
+
+Proof: submission `72e99470-19e3-5ea5-be87-5fc25dbfd308`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field and $F$ a field equipped with a $K$-algebra structure,
+subject to the following hypotheses. Geometric structure of $F/K$: every nonzero $\omega \in
+\Omega[F⁄K]$ admits a divisor $D$ on the places of $F/K$ with $D(v) =
+v.\mathrm{ordDifferential}\,\omega$ for all $v$ (`HasCanonicalDivisor`); for every place $w$ the
+element $w.\mathrm{dCoord}$ spans $\Omega[F⁄K]$ over $F$ (`DCoordGenerates`); every $f \neq 0$ in
+$F$ has a divisor of degree $0$ recording the orders $v.\mathrm{ord}\,f$ (`HasPrincipalDivisors`);
+each residue field $\kappa(v)$ is finite-dimensional over $K$; $\Omega[F⁄K]$ is nontrivial, and
+`IsCurveOver K F` holds, i.e. principal divisors exist, residue fields are finite over $K$, and
+$\Omega[F⁄K]$ is free of rank one over $F$. Local residues: each place of $F/K$ carries a local
+residue datum, and indeed `HasCanonicalLocalResidueKStar K F` provides a chosen family of canonical
+local residue data — $K$-linear maps $\mathrm{res}_v : F \to \kappa(v)$ vanishing on the valuation
+subring, sending $f$ with $\pi_v f$ integral to the residue class of $\pi_v f$, and annihilating
+$(\pi_v^{n+1})^{-1}$ for $n \geq 1$. Presentation over a rational function field: $F$ is an algebra
+over $\mathrm{RatFunc}\,K$, compatibly with $K$, integral, module-finite and separable over it,
+while $\mathrm{RatFunc}\,K$ itself satisfies the same curve package over $K$ (`IsCurveOver`, finite
+residue fields at all places, nontrivial $\Omega[\mathrm{RatFunc}\,K⁄K]$, and `DCoordGenerates` at
+every place). The conclusion is `ResidueTheoremK K F`: for every family $R$ assigning to each place
+$v$ of $F/K$ a canonical local residue datum, every nonzero $\omega \in \Omega[F⁄K]$ and every $f
+\in F$, the Weil functional $\mathrm{weilOfKaehlerK}\,R\,\omega$ vanishes on the diagonal adèle of
+$f$. Some hypotheses overlap: `IsCurveOver K F` already yields principal divisors and finiteness of
+the residue fields, and `HasCanonicalLocalResidueKStar K F` already yields `HasLocalResidue K F`.
+
+This is the residue theorem for the function field $F/K$ in its canonical $K$-valued (Tate) form:
+the sum of the local residues of $f\,\omega$ over all places vanishes, expressed as the vanishing of
+the associated adelic Weil functional on the diagonal copy of $F$. It is the input for the duality
+step behind Riemann–Roch for function fields and for the construction of differentials with
+prescribed orders, and is used by
+[`AlgebraicCurve.functionFieldRiemannRoch_of_isAlgClosed`]
+(thm.html#AlgebraicCurve.functionFieldRiemannRoch_of_isAlgClosed),
+[`AlgebraicCurve.residueTheorem_of_isAlgClosed`]
+(thm.html#AlgebraicCurve.residueTheorem_of_isAlgClosed)
+and
+[`AlgebraicCurve.exists_ordDifferential_ge_neg_one_and_evalAt_eq_of_degree_eq_zero`]
+(thm.html#AlgebraicCurve.exists_ordDifferential_ge_neg_one_and_evalAt_eq_of_degree_eq_zero);
+its proof reduces the general case to the rational function field by the trace compatibility of
+residues under the finite separable extension $F/\mathrm{RatFunc}\,K$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_residueTheoremK_of_isAlgClosed.lean
+
+*Attribution:* this file contains material adapted from third-party Apache-2.0 sources (one short
+lemma (`IsLocalRing.maximalIdeal_le`): `FLT/Mathlib/RingTheory/LocalRing/MaximalIdeal/Basic.lean` —
+© 2025 Salvatore Mercuri; authors: Salvatore Mercuri, Kevin Buzzard). See ATTRIBUTION.md and NOTICE
+in the source repository.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+open AlgebraicCurve Place RationalFunctionField IntermediateField
+  IsDedekindDomain HeightOneSpectrum IsLocalRing KaehlerDifferential ModularCurve
+  ModularCurve.KwF4R1V391a Module Polynomial TensorProduct
+  Valuation.IsRankOneDiscrete WithZero WithZeroMulInt
+
+open scoped Valued
+
+section privateSection
+
+section
+
+theorem IsLocalRing.maximalIdeal_le {R : Type*} [CommSemiring R] [IsLocalRing R] {J : Ideal R}
+    (hJ : J ≠ ⊤) (h : IsLocalRing.maximalIdeal R ≤ J) :
+    J.IsMaximal :=
+  (IsLocalRing.maximalIdeal.isMaximal R).eq_of_le hJ h ▸ IsLocalRing.maximalIdeal.isMaximal R
+
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+namespace Place
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+attribute [local instance 0] valuationSubringAlgebra
+
+section Assembly
+
+variable (v : Place K F)
+
+theorem sum_ramificationIndex_mul_inertiaDeg [HasPrincipalDivisors K F'] :
+    ∑ w ∈ v.fiber F', (w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ)
+      = (Module.finrank F F' : ℤ) := by
+  classical
+  have hkey := sum_ramificationIdx'_mul_inertiaDeg'_integralClosureAt (F' := F') v
+  rw [← hkey]
+  push_cast
+  refine Finset.sum_bij
+    (fun w hw => (fiberCenter F' v (Place.mem_fiber.mp hw)).asIdeal) ?_ ?_ ?_ ?_
+  · intro w hw
+    rw [IsDedekindDomain.mem_primesOverFinset_iff (maximalIdeal_ne_bot v)]
+    exact ⟨(fiberCenter F' v (Place.mem_fiber.mp hw)).isPrime,
+      fiberCenter_liesOver (Place.mem_fiber.mp hw)⟩
+  · intro w hw w' hw' h
+    exact eq_of_fiberCenter_eq (Place.mem_fiber.mp hw) (Place.mem_fiber.mp hw')
+      (HeightOneSpectrum.ext h)
+  · intro P hP
+    rw [IsDedekindDomain.mem_primesOverFinset_iff (maximalIdeal_ne_bot v)] at hP
+    obtain ⟨hP1, hP2⟩ := hP
+    have hPne : P ≠ ⊥ := by
+      intro h
+      apply maximalIdeal_ne_bot v
+      have h2 := hP2.over
+      rw [h, Ideal.under_def, Ideal.comap_bot_of_injective _
+        (algebraMap_integralClosureAt_injective v)] at h2
+      exact h2
+    refine ⟨placeOfPrime ⟨P, hP1, hPne⟩,
+      Place.mem_fiber.mpr (restrict_placeOfPrime ⟨P, hP1, hPne⟩), ?_⟩
+    exact congrArg HeightOneSpectrum.asIdeal
+      (fiberCenter_placeOfPrime (⟨P, hP1, hPne⟩ :
+        HeightOneSpectrum (integralClosureAt F' v)))
+  · intro w hw
+    rw [ramificationIndex_eq_ramificationIdx_fiberCenter _ (Place.mem_fiber.mp hw),
+      inertiaDeg_eq_inertiaDeg_fiberCenter (Place.mem_fiber.mp hw)]
+
+end Assembly
+end Place
+end AlgebraicCurve
+end
+section
+
+
+noncomputable section
+
+namespace AlgebraicCurve
+namespace Place
+
+section IntegerComap
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+variable (F)
+variable [Algebra F F'] [IsScalarTower K F F'] [Algebra.IsIntegral F F'] (W : Place K F')
+
+theorem kw_ffgc_adicCompletionComapIntegers_mem_maximalIdeal
+    {x : (W.restrict F).adicCompletionIntegers}
+    (hx : x ∈ maximalIdeal (W.restrict F).adicCompletionIntegers) :
+    kw_ffgc_adicCompletionComapIntegers F W x ∈ maximalIdeal W.adicCompletionIntegers := by
+  have hrpos := W.ramificationIndex_pos (F := F)
+  rw [show maximalIdeal (W.restrict F).adicCompletionIntegers
+      = (W.restrict F).heightOneSpectrum.completionIdeal F from rfl,
+    HeightOneSpectrum.mem_completionIdeal_iff] at hx
+  rw [show maximalIdeal W.adicCompletionIntegers
+      = W.heightOneSpectrum.completionIdeal F' from rfl,
+    HeightOneSpectrum.mem_completionIdeal_iff, kw_ffgc_adicCompletionComapIntegers_coe,
+    kw_ffgc_valued_adicCompletionComap]
+  calc Valued.v (x : (W.restrict F).adicCompletion) ^ W.ramificationIndex F
+      < 1 ^ W.ramificationIndex F := pow_lt_pow_left₀ hx (zero_le) hrpos.ne'
+    _ = 1 := one_pow _
+
+scoped instance kw_ffgc_isLocalHom_adicCompletionComapIntegers :
+    IsLocalHom (kw_ffgc_adicCompletionComapIntegers F W) where
+  map_nonunit x hx := by
+    by_contra hnu
+    exact (IsLocalRing.notMem_maximalIdeal.mpr hx)
+      (kw_ffgc_adicCompletionComapIntegers_mem_maximalIdeal F W
+        ((IsLocalRing.mem_maximalIdeal x).mpr hnu))
+
+end IntegerComap
+end Place
+end AlgebraicCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+namespace Place
+
+section CompletionAlgebra
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+variable (F)
+variable [Algebra F F'] [IsScalarTower K F F'] [Algebra.IsIntegral F F'] (W : Place K F')
+
+scoped instance kw_ffgc_isIntegrallyClosed_adicCompletionIntegers :
+    IsIntegrallyClosed (W.restrict F).adicCompletionIntegers :=
+  Valuation.Integers.isIntegrallyClosed
+    (HeightOneSpectrum.adicCompletionIntegers.integers
+      (K := F) (v := (W.restrict F).heightOneSpectrum))
+
+end CompletionAlgebra
+section SpectralSetup
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (V : Place K F)
+
+theorem kw_ffgc_norm_adicCompletion_eq (x : V.adicCompletion) :
+    letI := kw_ffgc_rankOne_adicCompletion V
+    ‖x‖ = (WithZeroMulInt.toNNReal (two_ne_zero) (Valued.v x) : ℝ) := by
+  let := kw_ffgc_rankOne_adicCompletion V
+  have h := valueGroup₀_equiv_withZeroMulInt_restrict_apply_of_surjective
+    (V.heightOneSpectrum.valuedAdicCompletion_surjective F) x
+  simp only [Valued.toNormedField.norm_def, Valuation.RankOne.hom]
+  rw [← h]; rfl
+
+end SpectralSetup
+section AbsoluteValue
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+variable (F)
+variable [Algebra F F'] [IsScalarTower K F F'] [Algebra.IsIntegral F F'] (W : Place K F')
+
+theorem kw_ffgc_absoluteValue_extends (c : (W.restrict F).adicCompletion) :
+    letI := kw_ffgc_rankOne_adicCompletion (W.restrict F)
+    kw_ffgc_absoluteValue F W
+      (algebraMap (W.restrict F).adicCompletion W.adicCompletion c) = ‖c‖ := by
+  let := kw_ffgc_rankOne_adicCompletion (W.restrict F)
+  let := kw_ffgc_rankOne_adicCompletion W
+  have hr : (0 : ℝ) < (W.ramificationIndex F : ℝ) :=
+    Nat.cast_pos.mpr (W.ramificationIndex_pos (F := F))
+  change ‖algebraMap (W.restrict F).adicCompletion W.adicCompletion c‖
+      ^ ((W.ramificationIndex F : ℝ))⁻¹ = ‖c‖
+  rw [kw_ffgc_norm_adicCompletion_eq W, kw_ffgc_norm_adicCompletion_eq (W.restrict F),
+    kw_ffgc_algebraMap_adicCompletionComap_eq, kw_ffgc_valued_adicCompletionComap,
+    map_pow, NNReal.coe_pow, ← Real.rpow_natCast, ← Real.rpow_mul (NNReal.coe_nonneg _),
+    mul_inv_cancel₀ hr.ne', Real.rpow_one]
+
+end AbsoluteValue
+section IntegralClosure
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+variable (F)
+variable [Algebra F F'] [IsScalarTower K F F'] [Algebra.IsIntegral F F'] (W : Place K F')
+
+theorem kw_ffgc_isIntegral_adicCompletionIntegers_of_algebraic
+    [Algebra.IsAlgebraic (W.restrict F).adicCompletion W.adicCompletion]
+    (x : W.adicCompletionIntegers) :
+    _root_.IsIntegral (W.restrict F).adicCompletionIntegers x := by
+  let := kw_ffgc_rankOne_adicCompletion (W.restrict F)
+  let := kw_ffgc_rankOne_adicCompletion W
+  let : NontriviallyNormedField (W.restrict F).adicCompletion :=
+    Valued.toNontriviallyNormedField (W.restrict F).adicCompletion ℤᵐ⁰
+  have : IsUltrametricDist (W.restrict F).adicCompletion :=
+    IsUltrametricDist.isUltrametricDist_of_isNonarchimedean_norm
+      (fun a b => Valuation.norm_add_le Valued.v a b)
+  have hr : (0 : ℝ) < ((W.ramificationIndex F : ℝ))⁻¹ :=
+    inv_pos.mpr (Nat.cast_pos.mpr (W.ramificationIndex_pos (F := F)))
+  have hxn : ‖(x : W.adicCompletion)‖ ≤ 1 :=
+    (Valued.toNormedField.norm_le_one_iff).mpr x.2
+  have hsn : spectralNorm (W.restrict F).adicCompletion W.adicCompletion
+        (x : W.adicCompletion)
+      = ‖(x : W.adicCompletion)‖ ^ ((W.ramificationIndex F : ℝ))⁻¹ :=
+    (spectralNorm_unique_field_norm_ext (f := kw_ffgc_absoluteValue F W)
+      (kw_ffgc_absoluteValue_extends F W) (x : W.adicCompletion)).symm
+  have hspec : spectralValue (minpoly (W.restrict F).adicCompletion
+      (x : W.adicCompletion)) ≤ 1 := by
+    change spectralNorm (W.restrict F).adicCompletion W.adicCompletion
+      (x : W.adicCompletion) ≤ 1
+    rw [hsn]; exact Real.rpow_le_one (norm_nonneg _) hxn hr.le
+  have hmon : (minpoly (W.restrict F).adicCompletion (x : W.adicCompletion)).Monic :=
+    minpoly.monic (Algebra.IsAlgebraic.isAlgebraic
+      (R := (W.restrict F).adicCompletion) (x : W.adicCompletion)).isIntegral
+  have hlift : minpoly (W.restrict F).adicCompletion (x : W.adicCompletion)
+      ∈ Polynomial.lifts (algebraMap (W.restrict F).adicCompletionIntegers
+          (W.restrict F).adicCompletion) := by
+    refine (Polynomial.lifts_iff_coeff_lifts _).mpr fun n => ⟨⟨_, ?_⟩, rfl⟩
+    exact (Valued.toNormedField.norm_le_one_iff).mp
+      ((spectralValue_le_one_iff hmon).mp hspec n)
+  obtain ⟨P, hP, -, hPmon⟩ := Polynomial.lifts_and_degree_eq_and_monic hlift hmon
+  have hxintW : _root_.IsIntegral (W.restrict F).adicCompletionIntegers (x : W.adicCompletion) := by
+    refine ⟨P, hPmon, ?_⟩
+    rw [← Polynomial.aeval_def,
+      ← Polynomial.aeval_map_algebraMap (W.restrict F).adicCompletion, hP, minpoly.aeval]
+  exact (isIntegral_algHom_iff
+    (IsScalarTower.toAlgHom (W.restrict F).adicCompletionIntegers
+      W.adicCompletionIntegers W.adicCompletion)
+    Subtype.val_injective).mp hxintW
+
+theorem kw_ffgc_isIntegralClosure_adicCompletionIntegers
+    [Algebra.IsAlgebraic (W.restrict F).adicCompletion W.adicCompletion] :
+    IsIntegralClosure W.adicCompletionIntegers (W.restrict F).adicCompletionIntegers
+      W.adicCompletion where
+  algebraMap_injective := Subtype.val_injective
+  isIntegral_iff {x} := by
+    constructor
+    · intro hx
+      have hxW : _root_.IsIntegral W.adicCompletionIntegers x := hx.tower_top
+      have : IsIntegrallyClosed W.adicCompletionIntegers :=
+        Valuation.Integers.isIntegrallyClosed
+          (HeightOneSpectrum.adicCompletionIntegers.integers
+            (K := F') (v := W.heightOneSpectrum))
+      exact IsIntegrallyClosed.isIntegral_iff.mp hxW
+    · rintro ⟨y, rfl⟩
+      exact (kw_ffgc_isIntegral_adicCompletionIntegers_of_algebraic F W y).map
+        (IsScalarTower.toAlgHom (W.restrict F).adicCompletionIntegers
+          W.adicCompletionIntegers W.adicCompletion)
+
+end IntegralClosure
+end Place
+end AlgebraicCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+namespace Place
+
+section CompletionTrace
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+variable (F)
+variable [Algebra F F'] [IsScalarTower K F F'] [Algebra.IsIntegral F F'] (W : Place K F')
+
+theorem kw_ffgc_completionTraceF'_apply [FiniteDimensional F F'] (g : F') :
+    kw_ffgc_completionTraceF' F W g
+      = Algebra.trace (W.restrict F).adicCompletion W.adicCompletion
+          (algebraMap F' W.adicCompletion g) := rfl
+
+end CompletionTrace
+section ResidueCompletion
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (V : Place K F)
+
+def kw_ffgc_residueFieldEquivCompletionResidueField :
+    V.ResidueField ≃+* IsLocalRing.ResidueField V.adicCompletionIntegers :=
+  ResidueFieldEquivCompletionResidueField F V.heightOneSpectrum
+
+end ResidueCompletion
+end Place
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable (v : Place K F)
+
+private theorem subsingleton_canonicalLocalResidueDataK_of_surj
+    (hsurj : Function.Surjective (algebraMap K v.ResidueField)) :
+    Subsingleton v.CanonicalLocalResidueDataK := by
+  constructor
+  intro R₁ R₂
+  have hres : R₁.res = R₂.res := by
+    ext f
+    obtain ⟨n, hn⟩ := v.exists_mem_poleSubmodule f
+    exact v.canonicalLocalResidueDataK_agree_on_poleSubmodule_of_surj hsurj R₁ R₂ n hn
+  obtain ⟨⟨r₁, h₁a, h₁b⟩, h₁c⟩ := R₁
+  obtain ⟨⟨r₂, h₂a, h₂b⟩, h₂c⟩ := R₂
+  congr 2
+
+end Place
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+section FiberReindex
+
+variable {K E F : Type*} [Field K] [Field E] [Field F]
+variable [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F] [HasPrincipalDivisors K F]
+
+variable {M : Type*} [AddCommMonoid M]
+
+theorem finsum_place_eq_finsum_fiber_sum (g : Place K F → M)
+    (hg : (Function.support g).Finite) :
+    ∑ᶠ w, g w = ∑ᶠ v : Place K E, ∑ w ∈ v.fiber F, g w := by
+  classical
+  set S := hg.toFinset with hS
+  set T := S.image (fun w => w.restrict E) with hT
+  rw [finsum_eq_finsetSum_of_support_subset g
+    (s := S) (fun w hw => (hS ▸ hg.mem_toFinset.mpr hw))]
+  have hsup : Function.support (fun v : Place K E => ∑ w ∈ v.fiber F, g w) ⊆ ↑T := by
+    intro v hv
+    simp only [Function.mem_support] at hv
+    obtain ⟨w, hwfib, hwne⟩ := Finset.exists_ne_zero_of_sum_ne_zero hv
+    exact Finset.mem_coe.mpr (hT ▸ Finset.mem_image.mpr
+      ⟨w, hS ▸ hg.mem_toFinset.mpr hwne, Place.mem_fiber.mp hwfib⟩)
+  rw [finsum_eq_finsetSum_of_support_subset _ hsup]
+  have hfib : ∀ v ∈ T, ∑ w ∈ v.fiber F, g w
+      = ∑ w ∈ S with w.restrict E = v, g w := by
+    intro v _
+    refine (Finset.sum_subset ?_ ?_).symm
+    · intro w hw
+      exact Place.mem_fiber.mpr (Finset.mem_filter.mp hw).2
+    · intro w hwfib hwfilt
+      by_contra hgw
+      exact hwfilt (Finset.mem_filter.mpr
+        ⟨hS ▸ hg.mem_toFinset.mpr hgw, Place.mem_fiber.mp hwfib⟩)
+  rw [Finset.sum_congr rfl hfib]
+  exact (Finset.sum_fiberwise_of_maps_to
+    (fun w hw => hT ▸ Finset.mem_image.mpr ⟨w, hw, rfl⟩) g).symm
+
+end FiberReindex
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+@[scoped simp]
+private theorem mem_regularSubmodule (w : Place K F) (ωF : Ω[F⁄K])
+    (f : F) :
+    f ∈ w.regularSubmodule ωF ↔ f * w.differentialCoeff ωF ∈ w.toValuationSubring := Iff.rfl
+
+end Place
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+private def regularPoleSubmodule (w : Place K F) (ωF : Ω[F⁄K]) (n : ℕ) :
+    Submodule K F :=
+  (w.poleSubmodule n).comap (LinearMap.mulRight K (w.differentialCoeff ωF))
+
+@[scoped simp]
+private theorem mem_regularPoleSubmodule (w : Place K F) (ωF : Ω[F⁄K])
+    (n : ℕ) (f : F) :
+    f ∈ w.regularPoleSubmodule ωF n
+      ↔ w.uniformizer ^ n * (f * w.differentialCoeff ωF) ∈ w.toValuationSubring := Iff.rfl
+
+theorem regularPoleSubmodule_zero (w : Place K F) (ωF : Ω[F⁄K]) :
+    w.regularPoleSubmodule ωF 0 = w.regularSubmodule ωF := by
+  ext f
+  simp only [mem_regularPoleSubmodule, pow_zero, one_mul, mem_regularSubmodule]
+
+private theorem regularPoleSubmodule_mono (w : Place K F) (ωF : Ω[F⁄K])
+    :
+    Monotone (w.regularPoleSubmodule ωF) :=
+  fun _ _ hmn => Submodule.comap_mono (w.poleSubmodule_mono hmn)
+
+private theorem iSup_regularPoleSubmodule_eq_top (w : Place K F)
+    (ωF : Ω[F⁄K]) :
+    ⨆ n, w.regularPoleSubmodule ωF n = ⊤ := by
+  rw [eq_top_iff]
+  intro f _
+  have hmem : f * w.differentialCoeff ωF ∈ ⨆ n, w.poleSubmodule n :=
+    w.iSup_poleSubmodule_eq_top ▸ Submodule.mem_top
+  obtain ⟨n, hn⟩ := (Submodule.mem_iSup_of_directed _
+    (Monotone.directed_le w.poleSubmodule_mono)).mp hmem
+  exact Submodule.mem_iSup_of_mem n hn
+
+private theorem exists_mem_regularPoleSubmodule (w : Place K F)
+    (ωF : Ω[F⁄K]) (f : F) :
+    ∃ n, f ∈ w.regularPoleSubmodule ωF n := by
+  have h : f ∈ ⨆ n, w.regularPoleSubmodule ωF n :=
+    (w.iSup_regularPoleSubmodule_eq_top ωF) ▸ Submodule.mem_top
+  exact (Submodule.mem_iSup_of_directed _
+    (Monotone.directed_le (w.regularPoleSubmodule_mono ωF))).mp h
+
+end Place
+end AlgebraicCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+section CorrectedCarrier
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+variable (E : Type*) [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+
+variable [HasCanonicalLocalResidueKStar K E] [HasCanonicalLocalResidueKStar K F]
+variable [Algebra.IsIntegral E F]
+
+def FiberKaehlerCotraceResidueIdentity : Prop :=
+  ∀ [HasPrincipalDivisors K E] [HasPrincipalDivisors K F]
+    {ωE : Ω[E⁄K]} (_ : ωE ≠ 0) (_ : kaehlerPullback K F E ωE ≠ 0)
+    (v : Place K E) (f : F),
+    ∑ w ∈ v.fiber F, kaehlerResidueTerm (kaehlerPullback K F E ωE) (diagonalHom K F f) w
+      = kaehlerResidueTerm ωE (diagonalHom K E (Algebra.trace E F f)) v
+
+end CorrectedCarrier
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+section KaehlerCotrace
+
+variable (K E F : Type*) [Field K] [Field E] [Field F]
+  [Algebra K E] [Algebra K F] [Algebra E F] [IsScalarTower K E F]
+
+variable {K E F}
+
+theorem kaehlerCotrace_D (e : E) :
+    kaehlerCotrace K E F (KaehlerDifferential.D K E e)
+      = KaehlerDifferential.D K F (algebraMap E F e) :=
+  KaehlerDifferential.map_D K K E F e
+
+theorem kaehlerCotrace_smul_algebraMap (e : E) (ωE : Ω[E⁄K]) :
+    kaehlerCotrace K E F (e • ωE) = (algebraMap E F e) • kaehlerCotrace K E F ωE := by
+  rw [LinearMap.map_smul, algebra_compatible_smul F e]
+
+end KaehlerCotrace
+end AlgebraicCurve
+end
+section
+
+namespace AlgebraicCurve
+
+section SeparatingWitness
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F]
+    [IsScalarTower K E F]
+
+theorem kaehlerCotrace_dCoord_ne_zero_of_exists
+    (v : Place K E) [v.DCoordGenerates]
+    {ωE₀ : Ω[E⁄K]} (h : kaehlerCotrace K E F ωE₀ ≠ 0) :
+    kaehlerCotrace K E F v.dCoord ≠ 0 := by
+  intro hdc
+  apply h
+  rw [← v.differentialCoeff_smul_dCoord ωE₀, kaehlerCotrace_smul_algebraMap, hdc, smul_zero]
+
+theorem exists_kaehlerCotrace_ne_zero_of_D_algebraMap_ne_zero
+    {e : E} (he : KaehlerDifferential.D K F (algebraMap E F e) ≠ 0) :
+    ∃ ωE : Ω[E⁄K], kaehlerCotrace K E F ωE ≠ 0 :=
+  ⟨KaehlerDifferential.D K E e, by rw [kaehlerCotrace_D]; exact he⟩
+
+end SeparatingWitness
+end AlgebraicCurve
+end
+section
+
+namespace AlgebraicCurve
+
+section CotraceInjective
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+
+theorem kaehlerCotrace_injective_iff_dCoord_ne_zero
+    (v : Place K E) [v.DCoordGenerates] [Nontrivial Ω[E⁄K]] :
+    Function.Injective (kaehlerCotrace K E F) ↔ kaehlerCotrace K E F v.dCoord ≠ 0 := by
+  constructor
+  · intro hinj h0
+    exact v.dCoord_ne_zero (hinj (h0.trans (_root_.map_zero _).symm))
+  · intro hne ωE ωE' heq
+    obtain ⟨e, rfl⟩ := v.exists_eq_smul_dCoord ωE
+    obtain ⟨e', rfl⟩ := v.exists_eq_smul_dCoord ωE'
+    rw [kaehlerCotrace_smul_algebraMap, kaehlerCotrace_smul_algebraMap] at heq
+    have hee' : algebraMap E F e = algebraMap E F e' :=
+      smul_left_injective F hne heq
+    rw [(algebraMap E F).injective hee']
+
+
+theorem kaehlerCotrace_injective_of_exists_ne_zero
+    (v : Place K E) [v.DCoordGenerates] [Nontrivial Ω[E⁄K]]
+    {ωE₀ : Ω[E⁄K]} (h : kaehlerCotrace K E F ωE₀ ≠ 0) :
+    Function.Injective (kaehlerCotrace K E F) :=
+  (kaehlerCotrace_injective_iff_dCoord_ne_zero v).mpr
+    (kaehlerCotrace_dCoord_ne_zero_of_exists v h)
+
+theorem kaehlerCotrace_injective_of_D_algebraMap_ne_zero
+    (v : Place K E) [v.DCoordGenerates] [Nontrivial Ω[E⁄K]]
+    {e : E} (he : KaehlerDifferential.D K F (algebraMap E F e) ≠ 0) :
+    Function.Injective (kaehlerCotrace K E F) :=
+  let ⟨_, hωE⟩ := exists_kaehlerCotrace_ne_zero_of_D_algebraMap_ne_zero he
+  kaehlerCotrace_injective_of_exists_ne_zero v hωE
+
+end CotraceInjective
+end AlgebraicCurve
+end
+section
+
+namespace AlgebraicCurve
+
+section CotraceDX
+
+variable (K : Type*) [Field K]
+variable (F : Type*) [Field F] [Algebra K F]
+variable [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+
+theorem kaehlerCotrace_dX_eq :
+    kaehlerCotrace K (RatFunc K) F (dX K)
+      = KaehlerDifferential.D K F (algebraMap (RatFunc K) F RatFunc.X) :=
+  kaehlerCotrace_D RatFunc.X
+
+end CotraceDX
+section SeparatingCarrier
+
+variable (K : Type*) [Field K]
+variable (F : Type*) [Field F] [Algebra K F] [HasCanonicalLocalResidueKStar K F]
+    [Algebra (RatFunc K) F]
+
+def IsSeparatingTranscendental : Prop :=
+  KaehlerDifferential.D K F (algebraMap (RatFunc K) F RatFunc.X) ≠ 0
+
+end SeparatingCarrier
+section SeparatingEngine
+
+variable (K : Type*) [Field K]
+variable (F : Type*) [Field F] [Algebra K F]
+variable [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+
+theorem kaehlerCotrace_dX_ne_zero_of_isSeparatingTranscendental
+    (hsep : IsSeparatingTranscendental K F) :
+    kaehlerCotrace K (RatFunc K) F (dX K) ≠ 0 := by
+  rw [kaehlerCotrace_dX_eq]; exact hsep
+
+theorem isSeparatingTranscendental_iff_kaehlerCotrace_dX_ne_zero :
+    IsSeparatingTranscendental K F ↔ kaehlerCotrace K (RatFunc K) F (dX K) ≠ 0 := by
+  rw [IsSeparatingTranscendental, kaehlerCotrace_dX_eq]
+
+end SeparatingEngine
+end AlgebraicCurve
+end
+section
+
+namespace AlgebraicCurve
+
+section SepIffInjective
+
+variable (K : Type*) [Field K]
+variable (F : Type*) [Field F] [Algebra K F]
+variable [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+
+theorem isSeparatingTranscendental_iff_kaehlerCotrace_injective
+    [HasCanonicalLocalResidueKStar K (RatFunc K)]
+    (v : Place K (RatFunc K)) [v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]] :
+    IsSeparatingTranscendental K F ↔ Function.Injective (kaehlerCotrace K (RatFunc K) F) := by
+  constructor
+  · exact fun hsep => kaehlerCotrace_injective_of_D_algebraMap_ne_zero v hsep
+  · intro hinj
+    rw [isSeparatingTranscendental_iff_kaehlerCotrace_dX_ne_zero]
+    exact fun h0 => dX_ne_zero K (hinj (h0.trans (_root_.map_zero _).symm))
+
+end SepIffInjective
+section MapBaseChangeSurj
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F]
+    [IsScalarTower K E F]
+
+theorem surjective_mapBaseChange_of_formallyUnramified [Algebra.FormallyUnramified E F] :
+    Function.Surjective (KaehlerDifferential.mapBaseChange K E F) := by
+  rw [← LinearMap.range_eq_top, KaehlerDifferential.range_mapBaseChange]
+  exact LinearMap.ker_eq_top.mpr (Subsingleton.elim _ _)
+
+end MapBaseChangeSurj
+section CotraceNeZero
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F]
+    [IsScalarTower K E F]
+
+theorem exists_kaehlerCotrace_ne_zero_of_formallyUnramified
+    [Algebra.FormallyUnramified E F] [Nontrivial Ω[F⁄K]] :
+    ∃ ωE : Ω[E⁄K], kaehlerCotrace K E F ωE ≠ 0 := by
+  by_contra h
+  simp only [not_exists, not_not] at h
+  have hmap0 : ∀ t, KaehlerDifferential.mapBaseChange K E F t = 0 := by
+    intro t
+    induction t using TensorProduct.inductionOn with
+    | tmul f ωE =>
+        rw [KaehlerDifferential.mapBaseChange_tmul]
+        change f • kaehlerCotrace K E F ωE = 0
+        rw [h ωE, smul_zero]
+    | add a b ha hb => rw [map_add, ha, hb, add_zero]
+  obtain ⟨ωF, hωF⟩ := exists_ne (0 : Ω[F⁄K])
+  obtain ⟨t, ht⟩ := surjective_mapBaseChange_of_formallyUnramified (K := K) (E := E) (F := F) ωF
+  exact hωF (ht ▸ hmap0 t)
+
+end CotraceNeZero
+section CotraceInjective
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F]
+    [IsScalarTower K E F]
+
+theorem kaehlerCotrace_injective_of_formallyUnramified
+    (v : Place K E) [v.DCoordGenerates] [Nontrivial Ω[E⁄K]]
+    [Algebra.FormallyUnramified E F] [Nontrivial Ω[F⁄K]] :
+    Function.Injective (kaehlerCotrace K E F) := by
+  obtain ⟨ωE₀, hωE₀⟩ :=
+    exists_kaehlerCotrace_ne_zero_of_formallyUnramified (K := K) (E := E) (F := F)
+  exact kaehlerCotrace_injective_of_exists_ne_zero v hωE₀
+
+end CotraceInjective
+section SepDischarge
+
+variable (K : Type*) [Field K]
+variable (F : Type*) [Field F] [Algebra K F]
+variable [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+
+theorem isSeparatingTranscendental_of_formallyUnramified
+    [HasCanonicalLocalResidueKStar K (RatFunc K)]
+    (v : Place K (RatFunc K)) [v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+    [Algebra.FormallyUnramified (RatFunc K) F] [Nontrivial Ω[F⁄K]] :
+    IsSeparatingTranscendental K F :=
+  (isSeparatingTranscendental_iff_kaehlerCotrace_injective K F v).mpr
+    (kaehlerCotrace_injective_of_formallyUnramified v)
+
+theorem isSeparatingTranscendental_of_isSeparable
+    [HasCanonicalLocalResidueKStar K (RatFunc K)]
+    (v : Place K (RatFunc K)) [v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+    [Algebra.IsSeparable (RatFunc K) F] [Nontrivial Ω[F⁄K]] :
+    IsSeparatingTranscendental K F :=
+  haveI := Algebra.FormallyUnramified.of_isSeparable (RatFunc K) F
+  isSeparatingTranscendental_of_formallyUnramified K F v
+
+end SepDischarge
+end AlgebraicCurve
+end
+section
+
+namespace AlgebraicCurve
+
+section CotraceDXSeparable
+
+variable (K : Type*) [Field K]
+variable (F : Type*) [Field F] [Algebra K F]
+variable [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+
+theorem kaehlerCotrace_dX_ne_zero_of_isSeparable
+    [HasCanonicalLocalResidueKStar K (RatFunc K)]
+    (v : Place K (RatFunc K)) [v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+    [Algebra.IsSeparable (RatFunc K) F] [Nontrivial Ω[F⁄K]] :
+    kaehlerCotrace K (RatFunc K) F (dX K) ≠ 0 :=
+  kaehlerCotrace_dX_ne_zero_of_isSeparatingTranscendental K F
+    (isSeparatingTranscendental_of_isSeparable K F v)
+
+end CotraceDXSeparable
+end AlgebraicCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+section CurrencyBridge
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F]
+    [IsScalarTower K E F]
+
+theorem kaehlerPullback_eq_kaehlerCotrace (ωE : Ω[E⁄K]) :
+    kaehlerPullback K F E ωE = kaehlerCotrace K E F ωE := rfl
+
+end CurrencyBridge
+section NamedRows
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F] [HasCanonicalLocalResidueKStar K F]
+variable (E : Type*) [Field E] [Algebra K E] [HasCanonicalLocalResidueKStar K E] [Algebra E F]
+    [IsScalarTower K E F]
+variable [HasLocalResidue K E] [HasLocalResidue K F]
+variable [Algebra.IsIntegral E F]
+
+def CotraceResidueIdentityOnFiberLocalized : Prop :=
+  ∀ [HasPrincipalDivisors K E] [HasPrincipalDivisors K F]
+    {ωE : Ω[E⁄K]} (_ : ωE ≠ 0) (_ : kaehlerPullback K F E ωE ≠ 0)
+    (v : Place K E) (p : F),
+    (∀ w₁ ∈ v.fiber F, ∀ w₂ ∈ v.fiber F,
+      p ∉ w₁.regularSubmodule (kaehlerPullback K F E ωE) →
+      p ∉ w₂.regularSubmodule (kaehlerPullback K F E ωE) → w₁ = w₂) →
+    ∑ w ∈ v.fiber F, kaehlerResidueTerm (kaehlerPullback K F E ωE) (diagonalHom K F p) w
+      = kaehlerResidueTerm ωE (diagonalHom K E (Algebra.trace E F p)) v
+
+def CotraceFiberLocalizedPolarApprox : Prop :=
+  ∀ [HasPrincipalDivisors K E] [HasPrincipalDivisors K F]
+    {ωE : Ω[E⁄K]} (_ : ωE ≠ 0) (_ : kaehlerPullback K F E ωE ≠ 0)
+    (v : Place K E) (w : Place K F) (_ : w ∈ v.fiber F) (n : ℕ) (f : F)
+    (_ : f ∈ w.regularPoleSubmodule (kaehlerPullback K F E ωE) (n + 1)),
+    ∃ p : F,
+      f - p ∈ w.regularPoleSubmodule (kaehlerPullback K F E ωE) n ∧
+      ∀ w' ∈ v.fiber F, w' ≠ w → p ∈ w'.regularSubmodule (kaehlerPullback K F E ωE)
+
+end NamedRows
+end AlgebraicCurve
+end
+section S18AliasT2
+open scoped AlgebraicCurve in
+theorem AlgebraicCurve.p0n22_cpf_residueTheoremK_ratFunc_of_isAlgClosed
+    (K : Type*) [Field K] [IsAlgClosed K]
+    [AlgebraicCurve.HasCanonicalLocalResidueKStar K (RatFunc K)]
+    [AlgebraicCurve.HasCanonicalDivisor (K := K) (F := RatFunc K)]
+    [∀ v : AlgebraicCurve.Place K (RatFunc K), v.DCoordGenerates] :
+    AlgebraicCurve.ResidueTheoremK K (RatFunc K) := by
+  classical
+  exact
+    AlgebraicCurve.residueTheoremK_ratFunc_of_isAlgClosed K
+end S18AliasT2
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+section Engine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable [HasCanonicalDivisor (K := K) (F := F)]
+variable [∀ w : Place K F, w.DCoordGenerates]
+variable {E : Type*} [Field E] [Algebra K E]
+variable [HasCanonicalDivisor (K := K) (F := E)]
+variable [∀ v : Place K E, v.DCoordGenerates]
+variable [Algebra E F] [IsScalarTower K E F] [Algebra.IsIntegral E F]
+
+theorem residueTheoremK_of_cotraceResidueIdentityK
+    [HasPrincipalDivisors K E] [HasPrincipalDivisors K F]
+    (hE : ResidueTheoremK K E)
+    {ωE₀ : Ω[E⁄K]} (hωE₀ : ωE₀ ≠ 0) (hgen : kaehlerPullback K F E ωE₀ ≠ 0)
+    (hIdentK : FiberKaehlerCotraceResidueIdentityK K F E) :
+    ResidueTheoremK K F := by
+  intro RfamF _ ωF hωF f
+  have : Nontrivial Ω[F⁄K] := ⟨ωF, 0, hωF⟩
+  rcases isEmpty_or_nonempty (Place K F) with hempty | hne
+  · rw [weilOfKaehlerK_apply]
+    exact finsum_eq_zero_of_forall_eq_zero fun w => (hempty.false w).elim
+  obtain ⟨w₀⟩ := hne
+  obtain ⟨RfamE, hident⟩ := hIdentK RfamF hωE₀ hgen
+  have hcoeff : w₀.differentialCoeff (kaehlerPullback K F E ωE₀) ≠ 0 :=
+    w₀.differentialCoeff_ne_zero hgen
+  have hωF_eq : ωF = (w₀.differentialCoeff ωF
+      * (w₀.differentialCoeff (kaehlerPullback K F E ωE₀))⁻¹)
+        • kaehlerPullback K F E ωE₀ := by
+    have key : (w₀.differentialCoeff ωF
+        * (w₀.differentialCoeff (kaehlerPullback K F E ωE₀))⁻¹)
+          • kaehlerPullback K F E ωE₀ = ωF := by
+      calc (w₀.differentialCoeff ωF
+            * (w₀.differentialCoeff (kaehlerPullback K F E ωE₀))⁻¹)
+              • kaehlerPullback K F E ωE₀
+          = (w₀.differentialCoeff ωF
+              * (w₀.differentialCoeff (kaehlerPullback K F E ωE₀))⁻¹)
+                • (w₀.differentialCoeff (kaehlerPullback K F E ωE₀) • w₀.dCoord) := by
+            rw [w₀.differentialCoeff_smul_dCoord]
+        _ = ((w₀.differentialCoeff ωF
+              * (w₀.differentialCoeff (kaehlerPullback K F E ωE₀))⁻¹)
+                * w₀.differentialCoeff (kaehlerPullback K F E ωE₀)) • w₀.dCoord := by
+            rw [smul_smul]
+        _ = w₀.differentialCoeff ωF • w₀.dCoord := by
+            rw [mul_assoc, inv_mul_cancel₀ hcoeff, mul_one]
+        _ = ωF := w₀.differentialCoeff_smul_dCoord ωF
+    exact key.symm
+  have hterm : ∀ w : Place K F,
+      kaehlerResidueTermKFam RfamF ωF (diagonalHom K F f) w
+        = kaehlerResidueTermKFam RfamF (kaehlerPullback K F E ωE₀)
+            (diagonalHom K F ((w₀.differentialCoeff ωF
+              * (w₀.differentialCoeff (kaehlerPullback K F E ωE₀))⁻¹) * f)) w := by
+    intro w
+    conv_lhs => rw [hωF_eq]
+    exact kaehlerResidueTermKFam_smul_diagonal RfamF _ (kaehlerPullback K F E ωE₀) f w
+  have hsup : (Function.support (kaehlerResidueTermKFam RfamF (kaehlerPullback K F E ωE₀)
+      (diagonalHom K F ((w₀.differentialCoeff ωF
+        * (w₀.differentialCoeff (kaehlerPullback K F E ωE₀))⁻¹) * f)))).Finite :=
+    kaehlerResidueTermKFam_support_finite_of_adeleSpace RfamF hgen
+      (diagonal_mem_adeleSpace _)
+  calc weilOfKaehlerK RfamF hωF ⟨diagonalHom K F f, diagonal_mem_adeleSpace f⟩
+      = ∑ᶠ w : Place K F, kaehlerResidueTermKFam RfamF ωF (diagonalHom K F f) w :=
+        weilOfKaehlerK_apply RfamF hωF _
+    _ = ∑ᶠ w : Place K F, kaehlerResidueTermKFam RfamF (kaehlerPullback K F E ωE₀)
+          (diagonalHom K F ((w₀.differentialCoeff ωF
+            * (w₀.differentialCoeff (kaehlerPullback K F E ωE₀))⁻¹) * f)) w :=
+        finsum_congr hterm
+    _ = ∑ᶠ v : Place K E, ∑ w ∈ v.fiber F,
+          kaehlerResidueTermKFam RfamF (kaehlerPullback K F E ωE₀)
+            (diagonalHom K F ((w₀.differentialCoeff ωF
+              * (w₀.differentialCoeff (kaehlerPullback K F E ωE₀))⁻¹) * f)) w :=
+        finsum_place_eq_finsum_fiber_sum (E := E) _ hsup
+    _ = ∑ᶠ v : Place K E, kaehlerResidueTermKFam RfamE ωE₀
+          (diagonalHom K E (Algebra.trace E F ((w₀.differentialCoeff ωF
+            * (w₀.differentialCoeff (kaehlerPullback K F E ωE₀))⁻¹) * f))) v :=
+        finsum_congr fun v => hident v _
+    _ = 0 := by
+        have h0 := hE RfamE hωE₀ (Algebra.trace E F ((w₀.differentialCoeff ωF
+          * (w₀.differentialCoeff (kaehlerPullback K F E ωE₀))⁻¹) * f))
+        rw [weilOfKaehlerK_apply] at h0
+        exact h0
+
+end Engine
+section RatFuncFloorSupply
+
+variable {K F : Type*} [Field K] [IsAlgClosed K]
+variable [Field F] [Algebra K F]
+variable [HasCanonicalDivisor (K := K) (F := F)] [∀ w : Place K F, w.DCoordGenerates]
+variable [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+variable [Algebra.IsIntegral (RatFunc K) F]
+
+theorem residueTheoremK_of_cotraceResidueIdentityK_ratFunc_isAlgClosed
+    [HasPrincipalDivisors K F]
+    (hgen : kaehlerPullback K F (RatFunc K) (dX K) ≠ 0)
+    (hIdentK : FiberKaehlerCotraceResidueIdentityK K F (RatFunc K)) :
+    ResidueTheoremK K F := by
+  classical
+  exact
+    residueTheoremK_of_cotraceResidueIdentityK
+      (p0n22_cpf_residueTheoremK_ratFunc_of_isAlgClosed K)
+      (dX_ne_zero K) hgen hIdentK
+
+end RatFuncFloorSupply
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace Cotpk43T3
+
+local notation "Qbar" => AlgebraicClosure ℚ
+
+section DVRSandwich
+
+variable {k F : Type*} [Field k] [Field F] [Algebra k F]
+
+theorem cotpk43_t3_toValuationSubring_eq_of_dedekind_le
+    (O : ValuationSubring F) (hO : IsDedekindDomain O)
+    (v : Place k F) (hle : O ≤ v.toValuationSubring) :
+    v.toValuationSubring = O := by
+  have := hO
+  have hSP : O.ofPrime (O.idealOfLE v.toValuationSubring hle) = v.toValuationSubring :=
+    ValuationSubring.ofPrime_idealOfLE O v.toValuationSubring hle
+  rcases eq_or_ne (O.idealOfLE v.toValuationSubring hle) ⊥ with hP | hP
+  · exfalso
+    apply v.ne_top'
+    have h2 : O.ofPrime ⊥ ≤ O.ofPrime (O.idealOfLE v.toValuationSubring hle) :=
+      ValuationSubring.ofPrime_le_of_le (h := hP.le)
+    rw [ValuationSubring.ofPrime_bot] at h2
+    exact top_le_iff.mp (le_trans h2 hSP.le)
+  · have hPmax : (O.idealOfLE v.toValuationSubring hle).IsMaximal :=
+      Ideal.IsPrime.isMaximal inferInstance hP
+    have hPeq : O.idealOfLE v.toValuationSubring hle = IsLocalRing.maximalIdeal O :=
+      IsLocalRing.eq_maximalIdeal hPmax
+    have h3 : O.ofPrime (O.idealOfLE v.toValuationSubring hle)
+        = O.ofPrime (IsLocalRing.maximalIdeal O) :=
+      le_antisymm (ValuationSubring.ofPrime_le_of_le (h := hPeq.ge))
+        (ValuationSubring.ofPrime_le_of_le (h := hPeq.le))
+    rw [ValuationSubring.ofPrime_top] at h3
+    rw [hSP] at h3
+    exact h3
+
+theorem cotpk43_t3_place_eq_of_dedekind_le
+    (O : ValuationSubring F) (hO : IsDedekindDomain O)
+    (v w : Place k F) (hv : O ≤ v.toValuationSubring) (hw : O ≤ w.toValuationSubring) :
+    v = w :=
+  Place.ext ((cotpk43_t3_toValuationSubring_eq_of_dedekind_le O hO v hv).trans
+    (cotpk43_t3_toValuationSubring_eq_of_dedekind_le O hO w hw).symm)
+
+theorem cotpk43_t3_place_eq_of_toValuationSubring_le
+    (v w : Place k F) (h : v.toValuationSubring ≤ w.toValuationSubring) : v = w :=
+  cotpk43_t3_place_eq_of_dedekind_le v.toValuationSubring inferInstance v w le_rfl h
+
+end DVRSandwich
+end Cotpk43T3
+end
+
+noncomputable section
+
+namespace ModularCurve
+
+section Toolkit
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem gf24a9r_ord_neg (v : Place K F) (g : F) : v.ord (-g) = v.ord g := by
+  simp only [Place.ord, Valuation.map_neg]
+
+theorem gf24a9r_ord_pow (v : Place K F) (g : F) (m : ℕ) :
+    v.ord (g ^ m) = (m : ℤ) * v.ord g := by
+  rw [show (g ^ m : F) = g ^ (m : ℤ) from (zpow_natCast g m).symm, v.ord_zpow]
+
+theorem gf24a9r_one_add_ne_zero_of_ord_pos (v : Place K F) {g : F}
+    (h : 0 < v.ord g) : (1 : F) + g ≠ 0 := by
+  intro hcon
+  have hg1 : g = -(1 : F) := by
+    rw [add_comm] at hcon
+    exact eq_neg_of_add_eq_zero_left hcon
+  have h0 : v.ord g = 0 := by rw [hg1, gf24a9r_ord_neg, v.ord_one]
+  omega
+
+theorem gf24a9r_ord_one_add_of_ord_pos (v : Place K F) {g : F} (hg : g ≠ 0)
+    (h : 0 < v.ord g) : v.ord (1 + g) = 0 := by
+  have hmin := v.ord_add_eq_min (f := (1 : F)) one_ne_zero hg
+    (by rw [v.ord_one]; omega)
+  rw [v.ord_one] at hmin
+  rw [hmin, min_eq_left h.le]
+
+theorem gf24a9r_ord_one_add_of_ord_neg (v : Place K F) {g : F} (hg : g ≠ 0)
+    (h : v.ord g < 0) : v.ord (1 + g) = v.ord g := by
+  have hmin := v.ord_add_eq_min (f := (1 : F)) one_ne_zero hg
+    (by rw [v.ord_one]; omega)
+  rw [v.ord_one] at hmin
+  rw [hmin, min_eq_right h.le]
+
+theorem gf24a9r_exists_ord_pos_ord_neg {w₁ w₂ : Place K F} (h : w₁ ≠ w₂) :
+    ∃ u : F, u ≠ 0 ∧ 0 < w₁.ord u ∧ w₂.ord u < 0 := by
+  have h12 : ¬(w₁.toValuationSubring ≤ w₂.toValuationSubring) := fun hle =>
+    h (Cotpk43T3.cotpk43_t3_place_eq_of_toValuationSubring_le w₁ w₂ hle)
+  have h21 : ¬(w₂.toValuationSubring ≤ w₁.toValuationSubring) := fun hle =>
+    h.symm (Cotpk43T3.cotpk43_t3_place_eq_of_toValuationSubring_le w₂ w₁ hle)
+  obtain ⟨x, hx1, hx2⟩ := IsConcreteLE.not_le_iff_exists.mp h12
+  obtain ⟨y, hy2, hy1⟩ := IsConcreteLE.not_le_iff_exists.mp h21
+  have hx0 : x ≠ 0 := by rintro rfl; exact hx2 (zero_mem _)
+  have hy0 : y ≠ 0 := by rintro rfl; exact hy1 (zero_mem _)
+  have hx1o : 0 ≤ w₁.ord x := w₁.ord_nonneg_of_mem hx1
+  have hy2o : 0 ≤ w₂.ord y := w₂.ord_nonneg_of_mem hy2
+  have hx2o : w₂.ord x < 0 := by
+    by_contra hcon
+    rw [not_lt] at hcon
+    exact hx2 (w₂.mem_of_ord_nonneg hx0 hcon)
+  have hy1o : w₁.ord y < 0 := by
+    by_contra hcon
+    rw [not_lt] at hcon
+    exact hy1 (w₁.mem_of_ord_nonneg hy0 hcon)
+  refine ⟨x * y⁻¹, mul_ne_zero hx0 (inv_ne_zero hy0), ?_, ?_⟩
+  · rw [w₁.ord_mul hx0 (inv_ne_zero hy0), w₁.ord_inv]
+    omega
+  · rw [w₂.ord_mul hx0 (inv_ne_zero hy0), w₂.ord_inv]
+    omega
+
+theorem gf24a9r_exists_separator (w : Place K F) (S : Finset (Place K F)) (hw : w ∉ S) :
+    ∃ u : F, u ≠ 0 ∧ 0 < w.ord u ∧ ∀ w' ∈ S, w'.ord u < 0 := by
+  classical
+  revert hw
+  induction S using Finset.induction_on with
+  | empty =>
+    intro _
+    obtain ⟨g, hg0, hgord⟩ := w.exists_ord_pos
+    exact ⟨g, hg0, hgord, fun w' hw' => absurd hw' (Finset.notMem_empty w')⟩
+  | @insert a S' ha ih =>
+    intro hw
+    have hwa : w ≠ a := fun hcon => hw (hcon ▸ Finset.mem_insert_self a S')
+    have hwS' : w ∉ S' := fun hcon => hw (Finset.mem_insert_of_mem hcon)
+    obtain ⟨y, hy0, hyw, hyS'⟩ := ih hwS'
+    obtain ⟨z, hz0, hzw, hza⟩ := gf24a9r_exists_ord_pos_ord_neg hwa
+    rcases lt_trichotomy (a.ord y) 0 with hneg | hzero | hpos
+    · refine ⟨y, hy0, hyw, fun w' hw' => ?_⟩
+      rcases Finset.mem_insert.mp hw' with rfl | hw'S'
+      · exact hneg
+      · exact hyS' w' hw'S'
+    · obtain ⟨r, hr1, hrB⟩ : ∃ r : ℕ, 1 ≤ r ∧ ∀ w' ∈ S', w'.ord z < (r : ℤ) := by
+        refine ⟨S'.sup (fun w' => (w'.ord z).toNat) + 1, Nat.le_add_left 1 _,
+          fun w' hw' => ?_⟩
+        have hle : (w'.ord z).toNat ≤ S'.sup (fun p => (p.ord z).toNat) :=
+          Finset.le_sup (f := fun p => (p.ord z).toNat) hw'
+        have h1 : w'.ord z ≤ ((w'.ord z).toNat : ℤ) := Int.self_le_toNat _
+        have h2 : ((w'.ord z).toNat : ℤ)
+            ≤ ((S'.sup (fun p => (p.ord z).toNat) : ℕ) : ℤ) := by exact_mod_cast hle
+        omega
+      have hyr0 : y ^ r ≠ 0 := pow_ne_zero r hy0
+      have hordeq : ∀ p : Place K F, p.ord (y ^ r * z) = (r : ℤ) * p.ord y + p.ord z :=
+        fun p => by rw [p.ord_mul hyr0 hz0, gf24a9r_ord_pow]
+      refine ⟨y ^ r * z, mul_ne_zero hyr0 hz0, ?_, fun w' hw' => ?_⟩
+      · rw [hordeq w]
+        have hnn : 0 ≤ (r : ℤ) * w.ord y := mul_nonneg (by omega) hyw.le
+        linarith
+      · rcases Finset.mem_insert.mp hw' with rfl | hw'S'
+        · rw [hordeq w', hzero, mul_zero, zero_add]
+          exact hza
+        · rw [hordeq w']
+          have h1 : w'.ord y ≤ -1 := by have := hyS' w' hw'S'; omega
+          have h2 : (r : ℤ) * w'.ord y ≤ (r : ℤ) * (-1) :=
+            mul_le_mul_of_nonneg_left h1 (by omega)
+          have h3 := hrB w' hw'S'
+          linarith
+    · obtain ⟨r, hr1, hrB⟩ : ∃ r : ℕ, 1 ≤ r ∧ ∀ w' ∈ S', w'.ord z < (r : ℤ) := by
+        refine ⟨S'.sup (fun w' => (w'.ord z).toNat) + 1, Nat.le_add_left 1 _,
+          fun w' hw' => ?_⟩
+        have hle : (w'.ord z).toNat ≤ S'.sup (fun p => (p.ord z).toNat) :=
+          Finset.le_sup (f := fun p => (p.ord z).toNat) hw'
+        have h1 : w'.ord z ≤ ((w'.ord z).toNat : ℤ) := Int.self_le_toNat _
+        have h2 : ((w'.ord z).toNat : ℤ)
+            ≤ ((S'.sup (fun p => (p.ord z).toNat) : ℕ) : ℤ) := by exact_mod_cast hle
+        omega
+      have hyr0 : y ^ r ≠ 0 := pow_ne_zero r hy0
+      have hone : (1 : F) + y ^ r ≠ 0 :=
+        gf24a9r_one_add_ne_zero_of_ord_pos a
+          (by rw [gf24a9r_ord_pow]; exact mul_pos (by omega) hpos)
+      have hordw : w.ord (1 + y ^ r) = 0 :=
+        gf24a9r_ord_one_add_of_ord_pos w hyr0
+          (by rw [gf24a9r_ord_pow]; exact mul_pos (by omega) hyw)
+      have horda : a.ord (1 + y ^ r) = 0 :=
+        gf24a9r_ord_one_add_of_ord_pos a hyr0
+          (by rw [gf24a9r_ord_pow]; exact mul_pos (by omega) hpos)
+      refine ⟨z * (1 + y ^ r), mul_ne_zero hz0 hone, ?_, fun w' hw' => ?_⟩
+      · rw [w.ord_mul hz0 hone, hordw]
+        omega
+      · rcases Finset.mem_insert.mp hw' with rfl | hw'S'
+        · rw [w'.ord_mul hz0 hone, horda]
+          omega
+        · have hyneg : w'.ord (y ^ r) < 0 := by
+            rw [gf24a9r_ord_pow]
+            exact mul_neg_of_pos_of_neg (by omega) (hyS' w' hw'S')
+          have hordw' : w'.ord (1 + y ^ r) = (r : ℤ) * w'.ord y := by
+            rw [gf24a9r_ord_one_add_of_ord_neg w' hyr0 hyneg, gf24a9r_ord_pow]
+          rw [w'.ord_mul hz0 hone, hordw']
+          have h1 : w'.ord y ≤ -1 := by have := hyS' w' hw'S'; omega
+          have h2 : (r : ℤ) * w'.ord y ≤ (r : ℤ) * (-1) :=
+            mul_le_mul_of_nonneg_left h1 (by omega)
+          have h3 := hrB w' hw'S'
+          linarith
+
+end Toolkit
+section RowB
+
+theorem gf24a9r_cotraceFiberLocalizedPolarApprox
+    (K F : Type*) [Field K] [Field F] [Algebra K F]
+    (E : Type*) [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+    [HasLocalResidue K E] [HasCanonicalLocalResidueKStar K E] [HasLocalResidue K F]
+    [HasCanonicalLocalResidueKStar K F]
+    [Algebra.IsIntegral E F] :
+    CotraceFiberLocalizedPolarApprox K F E := by
+  intro _instE _instF ωE _hωE _hgen v w _hwfib n f hf
+  classical
+  set ωF := kaehlerPullback K F E ωE
+  rcases eq_or_ne f 0 with rfl | hf0
+  · refine ⟨0, ?_, fun w' _ _ => Submodule.zero_mem _⟩
+    rw [sub_zero]
+    exact Submodule.zero_mem _
+  obtain ⟨u, hu0, huw, huS⟩ :=
+    gf24a9r_exists_separator w ((v.fiber F).erase w) (Finset.notMem_erase w _)
+  obtain ⟨r, hr1, hrB⟩ : ∃ r : ℕ, 1 ≤ r ∧ ∀ w' ∈ (v.fiber F).erase w,
+      -(w'.ord (f * w'.differentialCoeff ωF)) < (r : ℤ) := by
+    refine ⟨((v.fiber F).erase w).sup
+        (fun w' => (-(w'.ord (f * w'.differentialCoeff ωF))).toNat) + 1,
+      Nat.le_add_left 1 _, fun w' hw' => ?_⟩
+    have hle : (-(w'.ord (f * w'.differentialCoeff ωF))).toNat
+        ≤ ((v.fiber F).erase w).sup
+          (fun p => (-(p.ord (f * p.differentialCoeff ωF))).toNat) :=
+      Finset.le_sup (f := fun p => (-(p.ord (f * p.differentialCoeff ωF))).toNat) hw'
+    have h1 : -(w'.ord (f * w'.differentialCoeff ωF))
+        ≤ ((-(w'.ord (f * w'.differentialCoeff ωF))).toNat : ℤ) := Int.self_le_toNat _
+    have h2 : ((-(w'.ord (f * w'.differentialCoeff ωF))).toNat : ℤ)
+        ≤ ((((v.fiber F).erase w).sup
+          (fun p => (-(p.ord (f * p.differentialCoeff ωF))).toNat) : ℕ) : ℤ) := by
+      exact_mod_cast hle
+    omega
+  have hr1' : (1 : ℤ) ≤ (r : ℤ) := by exact_mod_cast hr1
+  have hur0 : u ^ r ≠ 0 := pow_ne_zero r hu0
+  have hone : (1 : F) + u ^ r ≠ 0 :=
+    gf24a9r_one_add_ne_zero_of_ord_pos w
+      (by rw [gf24a9r_ord_pow]; exact mul_pos (by omega) huw)
+  have hinv0 : ((1 : F) + u ^ r)⁻¹ ≠ 0 := inv_ne_zero hone
+  have hordw_one : w.ord (1 + u ^ r) = 0 :=
+    gf24a9r_ord_one_add_of_ord_pos w hur0
+      (by rw [gf24a9r_ord_pow]; exact mul_pos (by omega) huw)
+  refine ⟨f * ((1 : F) + u ^ r)⁻¹, ?_, ?_⟩
+  · have hdiff : f - f * ((1 : F) + u ^ r)⁻¹ = f * u ^ r * ((1 : F) + u ^ r)⁻¹ := by
+      have hcancel := mul_inv_cancel₀ hone
+      calc f - f * ((1 : F) + u ^ r)⁻¹
+          = f * (((1 : F) + u ^ r) * ((1 : F) + u ^ r)⁻¹)
+            - f * ((1 : F) + u ^ r)⁻¹ := by rw [hcancel, mul_one]
+        _ = f * u ^ r * ((1 : F) + u ^ r)⁻¹ := by ring
+    rw [hdiff]
+    refine (w.mem_regularPoleSubmodule ωF n _).mpr ?_
+    rcases eq_or_ne (w.differentialCoeff ωF) 0 with hdc | hdc
+    · rw [hdc, mul_zero, mul_zero]
+      exact zero_mem _
+    · have hin : 0 ≤ w.ord (w.uniformizer ^ (n + 1) * (f * w.differentialCoeff ωF)) :=
+        w.ord_nonneg_of_mem ((w.mem_regularPoleSubmodule ωF (n + 1) f).mp hf)
+      rw [w.ord_mul (w.uniformizer_pow_ne_zero _) (mul_ne_zero hf0 hdc),
+        w.ord_uniformizer_pow, w.ord_mul hf0 hdc] at hin
+      have hX0 : f * u ^ r * ((1 : F) + u ^ r)⁻¹ ≠ 0 :=
+        mul_ne_zero (mul_ne_zero hf0 hur0) hinv0
+      refine w.mem_of_ord_nonneg
+        (mul_ne_zero (w.uniformizer_pow_ne_zero n) (mul_ne_zero hX0 hdc)) ?_
+      rw [w.ord_mul (w.uniformizer_pow_ne_zero n) (mul_ne_zero hX0 hdc),
+        w.ord_uniformizer_pow, w.ord_mul hX0 hdc,
+        w.ord_mul (mul_ne_zero hf0 hur0) hinv0, w.ord_mul hf0 hur0,
+        w.ord_inv, hordw_one, gf24a9r_ord_pow]
+      have hru : (1 : ℤ) ≤ (r : ℤ) * w.ord u := by
+        have huw1 : (1 : ℤ) ≤ w.ord u := by omega
+        nlinarith [hr1', huw1]
+      push_cast at hin ⊢
+      linarith
+  · intro w' hw'fib hne
+    have hw'S : w' ∈ (v.fiber F).erase w := Finset.mem_erase.mpr ⟨hne, hw'fib⟩
+    have hu_neg : w'.ord u < 0 := huS w' hw'S
+    refine (w'.mem_regularSubmodule ωF _).mpr ?_
+    rcases eq_or_ne (w'.differentialCoeff ωF) 0 with hdc | hdc
+    · rw [hdc, mul_zero]
+      exact zero_mem _
+    · have hre : f * ((1 : F) + u ^ r)⁻¹ * w'.differentialCoeff ωF
+          = f * w'.differentialCoeff ωF * ((1 : F) + u ^ r)⁻¹ := by ring
+      rw [hre]
+      have hfdc : f * w'.differentialCoeff ωF ≠ 0 := mul_ne_zero hf0 hdc
+      have hurneg : w'.ord (u ^ r) < 0 := by
+        rw [gf24a9r_ord_pow]
+        exact mul_neg_of_pos_of_neg (by omega) hu_neg
+      have hordw' : w'.ord (1 + u ^ r) = (r : ℤ) * w'.ord u := by
+        rw [gf24a9r_ord_one_add_of_ord_neg w' hur0 hurneg, gf24a9r_ord_pow]
+      refine w'.mem_of_ord_nonneg (mul_ne_zero hfdc hinv0) ?_
+      rw [w'.ord_mul hfdc hinv0, w'.ord_inv, hordw']
+      have h1 : w'.ord u ≤ -1 := by omega
+      have h2 : (r : ℤ) * w'.ord u ≤ (r : ℤ) * (-1) :=
+        mul_le_mul_of_nonneg_left h1 (by omega)
+      have h3 := hrB w' hw'S
+      linarith
+
+end RowB
+end ModularCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+section Additivity
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem kaehlerResidueTermKFam_diagonal_add
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK) (ω : Ω[F⁄K])
+    (v : Place K F) (g₁ g₂ : F) :
+    kaehlerResidueTermKFam Rfam ω (diagonalHom K F (g₁ + g₂)) v
+      = kaehlerResidueTermKFam Rfam ω (diagonalHom K F g₁) v
+        + kaehlerResidueTermKFam Rfam ω (diagonalHom K F g₂) v := by
+  simp only [kaehlerResidueTermKFam_apply, diagonalHom_apply]
+  rw [add_mul, map_add, map_add]
+
+theorem kaehlerResidueTermKFam_diagonal_zero
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK) (ω : Ω[F⁄K])
+    (v : Place K F) :
+    kaehlerResidueTermKFam Rfam ω (diagonalHom K F (0 : F)) v = 0 := by
+  rw [kaehlerResidueTermKFam_apply, diagonalHom_apply, zero_mul, _root_.map_zero, _root_.map_zero]
+
+end Additivity
+section Engine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E]
+variable [Algebra E F] [IsScalarTower K E F] [Algebra.IsIntegral E F]
+
+theorem cotraceFiberIdentityK_zero
+    [HasPrincipalDivisors K F]
+    (RfamF : ∀ w : Place K F, w.CanonicalLocalResidueDataK)
+    (RfamE : ∀ v : Place K E, v.CanonicalLocalResidueDataK)
+    (ωE : Ω[E⁄K]) (v : Place K E) :
+    ∑ w ∈ v.fiber F, kaehlerResidueTermKFam RfamF (kaehlerPullback K F E ωE)
+        (diagonalHom K F (0 : F)) w
+      = kaehlerResidueTermKFam RfamE ωE (diagonalHom K E (Algebra.trace E F (0 : F))) v := by
+  rw [Finset.sum_eq_zero (fun w _ => kaehlerResidueTermKFam_diagonal_zero RfamF _ w),
+    _root_.map_zero (Algebra.trace E F), kaehlerResidueTermKFam_diagonal_zero RfamE ωE v]
+
+theorem cotraceFiberIdentityK_add
+    [HasPrincipalDivisors K F]
+    (RfamF : ∀ w : Place K F, w.CanonicalLocalResidueDataK)
+    (RfamE : ∀ v : Place K E, v.CanonicalLocalResidueDataK)
+    {ωE : Ω[E⁄K]} (v : Place K E) {g p : F}
+    (hg : ∑ w ∈ v.fiber F, kaehlerResidueTermKFam RfamF (kaehlerPullback K F E ωE)
+        (diagonalHom K F g) w
+      = kaehlerResidueTermKFam RfamE ωE (diagonalHom K E (Algebra.trace E F g)) v)
+    (hp : ∑ w ∈ v.fiber F, kaehlerResidueTermKFam RfamF (kaehlerPullback K F E ωE)
+        (diagonalHom K F p) w
+      = kaehlerResidueTermKFam RfamE ωE (diagonalHom K E (Algebra.trace E F p)) v) :
+    ∑ w ∈ v.fiber F, kaehlerResidueTermKFam RfamF (kaehlerPullback K F E ωE)
+        (diagonalHom K F (g + p)) w
+      = kaehlerResidueTermKFam RfamE ωE (diagonalHom K E (Algebra.trace E F (g + p))) v := by
+  calc ∑ w ∈ v.fiber F, kaehlerResidueTermKFam RfamF (kaehlerPullback K F E ωE)
+          (diagonalHom K F (g + p)) w
+      = ∑ w ∈ v.fiber F,
+          (kaehlerResidueTermKFam RfamF (kaehlerPullback K F E ωE) (diagonalHom K F g) w
+            + kaehlerResidueTermKFam RfamF (kaehlerPullback K F E ωE)
+                (diagonalHom K F p) w) :=
+        Finset.sum_congr rfl fun w _ =>
+          kaehlerResidueTermKFam_diagonal_add RfamF (kaehlerPullback K F E ωE) w g p
+    _ = (∑ w ∈ v.fiber F, kaehlerResidueTermKFam RfamF (kaehlerPullback K F E ωE)
+            (diagonalHom K F g) w)
+          + ∑ w ∈ v.fiber F, kaehlerResidueTermKFam RfamF (kaehlerPullback K F E ωE)
+              (diagonalHom K F p) w :=
+        Finset.sum_add_distrib
+    _ = kaehlerResidueTermKFam RfamE ωE (diagonalHom K E (Algebra.trace E F g)) v
+          + kaehlerResidueTermKFam RfamE ωE (diagonalHom K E (Algebra.trace E F p)) v := by
+        rw [hg, hp]
+    _ = kaehlerResidueTermKFam RfamE ωE
+          (diagonalHom K E (Algebra.trace E F g + Algebra.trace E F p)) v :=
+        (kaehlerResidueTermKFam_diagonal_add RfamE ωE v _ _).symm
+    _ = kaehlerResidueTermKFam RfamE ωE
+          (diagonalHom K E (Algebra.trace E F (g + p))) v := by
+        rw [← map_add]
+
+theorem cotraceFiberIdentityK_of_uniform_layer
+    [HasPrincipalDivisors K E] [HasPrincipalDivisors K F]
+    (RfamF : ∀ w : Place K F, w.CanonicalLocalResidueDataK)
+    (RfamE : ∀ v : Place K E, v.CanonicalLocalResidueDataK)
+    {ωE : Ω[E⁄K]} (hωE : ωE ≠ 0) (hgen : kaehlerPullback K F E ωE ≠ 0)
+    (hA' : ∀ (v : Place K E) (p : F),
+        (∀ w₁ ∈ v.fiber F, ∀ w₂ ∈ v.fiber F,
+          p ∉ w₁.regularSubmodule (kaehlerPullback K F E ωE) →
+          p ∉ w₂.regularSubmodule (kaehlerPullback K F E ωE) → w₁ = w₂) →
+        ∑ w ∈ v.fiber F, kaehlerResidueTermKFam RfamF (kaehlerPullback K F E ωE)
+            (diagonalHom K F p) w
+          = kaehlerResidueTermKFam RfamE ωE (diagonalHom K E (Algebra.trace E F p)) v)
+    (hB : CotraceFiberLocalizedPolarApprox K F E)
+    (v : Place K E) :
+    ∀ (N : ℕ) (f : F),
+      (∀ w ∈ v.fiber F, f ∈ w.regularPoleSubmodule (kaehlerPullback K F E ωE) N) →
+      ∑ w ∈ v.fiber F, kaehlerResidueTermKFam RfamF (kaehlerPullback K F E ωE)
+          (diagonalHom K F f) w
+        = kaehlerResidueTermKFam RfamE ωE (diagonalHom K E (Algebra.trace E F f)) v := by
+  intro N
+  induction N with
+  | zero =>
+    intro f hf
+    refine hA' v f ?_
+    intro w₁ hw₁ w₂ hw₂ hp₁ hp₂
+    exfalso
+    have hreg := hf w₁ hw₁
+    rw [Place.regularPoleSubmodule_zero] at hreg
+    exact hp₁ hreg
+  | succ N ih =>
+    intro f hf
+    classical
+    choose! q hq1 hq2 using fun (w : Place K F) (hw : w ∈ v.fiber F) =>
+      hB hωE hgen v w hw N f (hf w hw)
+    have hrem : ∀ w₀ ∈ v.fiber F,
+        f - ∑ w ∈ v.fiber F, q w
+          ∈ w₀.regularPoleSubmodule (kaehlerPullback K F E ωE) N := by
+      intro w₀ hw₀
+      have hsplit : ∑ w ∈ v.fiber F, q w
+          = q w₀ + ∑ w ∈ (v.fiber F).erase w₀, q w :=
+        (Finset.add_sum_erase _ q hw₀).symm
+      have heq : f - ∑ w ∈ v.fiber F, q w
+          = (f - q w₀) - ∑ w ∈ (v.fiber F).erase w₀, q w := by
+        rw [hsplit]; ring
+      rw [heq]
+      refine Submodule.sub_mem _ (hq1 w₀ hw₀) (Submodule.sum_mem _ ?_)
+      intro w hw
+      have hwfib : w ∈ v.fiber F := Finset.mem_of_mem_erase hw
+      have hwne : w ≠ w₀ := Finset.ne_of_mem_erase hw
+      have hq_reg : q w ∈ w₀.regularSubmodule (kaehlerPullback K F E ωE) :=
+        hq2 w hwfib w₀ hw₀ (Ne.symm hwne)
+      rw [← Place.regularPoleSubmodule_zero] at hq_reg
+      exact w₀.regularPoleSubmodule_mono _ (Nat.zero_le N) hq_reg
+    have hrem_ident := ih (f - ∑ w ∈ v.fiber F, q w) hrem
+    have happrox_ident : ∀ w ∈ v.fiber F,
+        ∑ w' ∈ v.fiber F, kaehlerResidueTermKFam RfamF (kaehlerPullback K F E ωE)
+            (diagonalHom K F (q w)) w'
+          = kaehlerResidueTermKFam RfamE ωE
+              (diagonalHom K E (Algebra.trace E F (q w))) v := by
+      intro w hw
+      refine hA' v (q w) ?_
+      intro w₁ hw₁ w₂ hw₂ hp₁ hp₂
+      have h₁ : w₁ = w := by
+        by_contra hne
+        exact hp₁ (hq2 w hw w₁ hw₁ hne)
+      have h₂ : w₂ = w := by
+        by_contra hne
+        exact hp₂ (hq2 w hw w₂ hw₂ hne)
+      rw [h₁, h₂]
+    have hsum_ident :
+        ∑ w' ∈ v.fiber F, kaehlerResidueTermKFam RfamF (kaehlerPullback K F E ωE)
+            (diagonalHom K F (∑ w ∈ v.fiber F, q w)) w'
+          = kaehlerResidueTermKFam RfamE ωE
+              (diagonalHom K E (Algebra.trace E F (∑ w ∈ v.fiber F, q w))) v :=
+      Finset.sum_induction q
+        (fun x => ∑ w' ∈ v.fiber F, kaehlerResidueTermKFam RfamF (kaehlerPullback K F E ωE)
+            (diagonalHom K F x) w'
+          = kaehlerResidueTermKFam RfamE ωE (diagonalHom K E (Algebra.trace E F x)) v)
+        (fun a b ha hb => cotraceFiberIdentityK_add RfamF RfamE v ha hb)
+        (cotraceFiberIdentityK_zero RfamF RfamE ωE v)
+        happrox_ident
+    have hcombined := cotraceFiberIdentityK_add RfamF RfamE v hrem_ident hsum_ident
+    rwa [sub_add_cancel] at hcombined
+
+theorem fiberKaehlerCotraceResidueIdentityK_of_rowAK_rowB
+    (hA : CotraceResidueIdentityOnFiberLocalizedK K F E)
+    (hB : CotraceFiberLocalizedPolarApprox K F E) :
+    FiberKaehlerCotraceResidueIdentityK K F E := by
+  intro instE instF RfamF ωE hωE hgen
+  obtain ⟨RfamE, hA'⟩ := hA RfamF hωE hgen
+  refine ⟨RfamE, fun v f => ?_⟩
+  classical
+  choose nfun hnfun using fun w : Place K F =>
+    w.exists_mem_regularPoleSubmodule (kaehlerPullback K F E ωE) f
+  refine cotraceFiberIdentityK_of_uniform_layer RfamF RfamE hωE hgen hA' hB v
+    (∑ w ∈ v.fiber F, nfun w) f (fun w hw => ?_)
+  exact w.regularPoleSubmodule_mono _
+    (Finset.single_le_sum (fun _ _ => Nat.zero_le _) hw) (hnfun w)
+
+end Engine
+section RowBDischarged
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] [HasCanonicalLocalResidueKStar K F]
+variable {E : Type*} [Field E] [Algebra K E] [HasCanonicalLocalResidueKStar K E]
+variable [Algebra E F] [IsScalarTower K E F] [Algebra.IsIntegral E F]
+variable [HasLocalResidue K E] [HasLocalResidue K F]
+
+theorem fiberKaehlerCotraceResidueIdentityK_of_rowAK
+    (hA : CotraceResidueIdentityOnFiberLocalizedK K F E) :
+    FiberKaehlerCotraceResidueIdentityK K F E :=
+  fiberKaehlerCotraceResidueIdentityK_of_rowAK_rowB hA
+    (ModularCurve.gf24a9r_cotraceFiberLocalizedPolarApprox K F E)
+
+end RowBDischarged
+section CompositeRatFunc
+
+variable {K F : Type*} [Field K] [IsAlgClosed K]
+variable [Field F] [Algebra K F] [HasCanonicalLocalResidueKStar K F]
+variable [HasCanonicalDivisor (K := K) (F := F)] [∀ w : Place K F, w.DCoordGenerates]
+variable [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+variable [Algebra.IsIntegral (RatFunc K) F] [HasLocalResidue K F]
+
+theorem residueTheoremK_of_rowAK_ratFunc_isAlgClosed
+    [HasPrincipalDivisors K F]
+    (hgen : kaehlerPullback K F (RatFunc K) (dX K) ≠ 0)
+    (hA : CotraceResidueIdentityOnFiberLocalizedK K F (RatFunc K)) :
+    ResidueTheoremK K F := by
+  classical
+  exact
+    residueTheoremK_of_cotraceResidueIdentityK_ratFunc_isAlgClosed hgen
+      (fiberKaehlerCotraceResidueIdentityK_of_rowAK hA)
+
+end CompositeRatFunc
+end AlgebraicCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+section DataKStarSeam
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] [HasCanonicalLocalResidueKStar K F]
+
+theorem kaehlerResidueTermKFam_dataKStar (ω : Ω[F⁄K]) (α : Place K F → F) (v : Place K F) :
+    kaehlerResidueTermKFam (HasCanonicalLocalResidueKStar.dataKStar) ω α v
+      = kaehlerResidueTerm ω α v := rfl
+
+theorem kaehlerResidueTermKFam_eq_of_subsingleton
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK) (ω : Ω[F⁄K]) (α : Place K F → F)
+    (v : Place K F) (hsub : Subsingleton v.CanonicalLocalResidueDataK) :
+    kaehlerResidueTermKFam Rfam ω α v = kaehlerResidueTerm ω α v := by
+  have hR : Rfam v = HasCanonicalLocalResidueKStar.dataKStar v := hsub.elim _ _
+  rw [kaehlerResidueTermKFam_apply, hR]
+  rfl
+
+end DataKStarSeam
+section AlgClosedSurj
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+private theorem surjective_algebraMap_residueField_of_isAlgClosed_of_finiteResidue
+    [IsAlgClosed K] (v : Place K F) [v.FiniteResidue] :
+    Function.Surjective (algebraMap K v.ResidueField) := by
+  have : Module.Finite K v.ResidueField := Place.FiniteResidue.finite
+  have : Algebra.IsIntegral K v.ResidueField := Algebra.IsIntegral.of_finite K v.ResidueField
+  exact (IsAlgClosed.algebraMap_bijective_of_isIntegral (k := K)
+    (K := v.ResidueField)).surjective
+
+end Place
+namespace Place
+private theorem subsingleton_canonicalLocalResidueDataK_of_isAlgClosed_of_finiteResidue
+    [IsAlgClosed K] (v : Place K F) [v.FiniteResidue] :
+    Subsingleton v.CanonicalLocalResidueDataK :=
+  v.subsingleton_canonicalLocalResidueDataK_of_surj
+    v.surjective_algebraMap_residueField_of_isAlgClosed_of_finiteResidue
+
+end Place
+end AlgClosedSurj
+section SubsingletonBridge
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] [HasCanonicalLocalResidueKStar K F]
+variable {E : Type*} [Field E] [Algebra K E] [HasCanonicalLocalResidueKStar K E]
+variable [Algebra E F] [IsScalarTower K E F] [Algebra.IsIntegral E F]
+
+theorem cotraceResidueIdentityOnFiberLocalizedK_of_committed
+    (hsubF : ∀ w : Place K F, Subsingleton w.CanonicalLocalResidueDataK)
+    (h : CotraceResidueIdentityOnFiberLocalized K F E) :
+    CotraceResidueIdentityOnFiberLocalizedK K F E := by
+  intro _ _ RfamF ωE hωE hgen
+  refine ⟨HasCanonicalLocalResidueKStar.dataKStar, fun v p hloc => ?_⟩
+  calc ∑ w ∈ v.fiber F, kaehlerResidueTermKFam RfamF (kaehlerPullback K F E ωE)
+          (diagonalHom K F p) w
+      = ∑ w ∈ v.fiber F, kaehlerResidueTerm (kaehlerPullback K F E ωE)
+          (diagonalHom K F p) w := by
+        refine Finset.sum_congr rfl fun w _ => ?_
+        exact kaehlerResidueTermKFam_eq_of_subsingleton RfamF _ _ w (hsubF w)
+    _ = kaehlerResidueTerm ωE (diagonalHom K E (Algebra.trace E F p)) v :=
+        h hωE hgen v p hloc
+    _ = kaehlerResidueTermKFam (HasCanonicalLocalResidueKStar.dataKStar) ωE
+          (diagonalHom K E (Algebra.trace E F p)) v :=
+        (kaehlerResidueTermKFam_dataKStar ωE _ v).symm
+
+end SubsingletonBridge
+end AlgebraicCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+section KaehlerPullbackSmul
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+
+theorem kw_mlc_hrtCharP7_kaehlerPullback_smul (g : E) (ωE : Ω[E⁄K]) :
+    kaehlerPullback K F E (g • ωE) = (algebraMap E F g) • kaehlerPullback K F E ωE := by
+  change (KaehlerDifferential.map K K E F) (g • ωE)
+    = (algebraMap E F g) • (KaehlerDifferential.map K K E F) ωE
+  rw [LinearMap.map_smul, algebra_compatible_smul F g]
+
+end KaehlerPullbackSmul
+end AlgebraicCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+section FKCRIWire
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F] [HasCanonicalLocalResidueKStar K F]
+variable (E : Type*) [Field E] [Algebra K E] [HasCanonicalLocalResidueKStar K E]
+variable [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+theorem kw_mlc_hrtCharP9_cotraceResidueIdentityOnFiberLocalized_of_fkcri
+    (h : FiberKaehlerCotraceResidueIdentity K F E) :
+    CotraceResidueIdentityOnFiberLocalized K F E := by
+  intro _ _ ωE hωE hgen v p _
+  exact h hωE hgen v p
+
+end FKCRIWire
+section FKCRIProduction
+
+variable {K F : Type*} [Field K] [IsAlgClosed K]
+variable [Field F] [Algebra K F] [HasCanonicalLocalResidueKStar K F]
+variable [HasCanonicalDivisor (K := K) (F := F)] [∀ w : Place K F, w.DCoordGenerates]
+variable [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+variable [Algebra.IsIntegral (RatFunc K) F]
+variable [HasLocalResidue K F]
+variable [∀ w : Place K F, w.FiniteResidue]
+
+theorem residueTheoremK_of_fiberKaehlerCotraceResidueIdentity_ratFunc_isAlgClosed
+    [HasPrincipalDivisors K F]
+    (hgen : kaehlerPullback K F (RatFunc K) (dX K) ≠ 0)
+    (hFKCRI : FiberKaehlerCotraceResidueIdentity K F (RatFunc K)) :
+    ResidueTheoremK K F := by
+  classical
+  exact
+    residueTheoremK_of_rowAK_ratFunc_isAlgClosed hgen
+      (cotraceResidueIdentityOnFiberLocalizedK_of_committed
+        (fun w => w.subsingleton_canonicalLocalResidueDataK_of_isAlgClosed_of_finiteResidue)
+        (kw_mlc_hrtCharP9_cotraceResidueIdentityOnFiberLocalized_of_fkcri K F (RatFunc K)
+          hFKCRI))
+
+end FKCRIProduction
+end AlgebraicCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+section LocalResidueCompletion
+
+variable {K E : Type*} [Field K] [Field E] [Algebra K E]
+
+variable [HasCanonicalLocalResidueKStar K E]
+
+theorem kwHgfV352_localResidueCompletion_spec (v : Place K E) (xh : v.adicCompletion)
+    {x : E} (hx : algebraMap E v.adicCompletion x - xh ∈ v.adicCompletionIntegers) :
+    kwHgfV352_localResidueCompletion v xh = v.localResidue x := by
+  unfold kwHgfV352_localResidueCompletion
+  set x₀ := (kwHgfV352_exists_sub_mem_adicCompletionIntegers v xh).choose
+  have hx₀ := (kwHgfV352_exists_sub_mem_adicCompletionIntegers v xh).choose_spec
+  have heq : algebraMap E v.adicCompletion (x₀ - x)
+      = (algebraMap E v.adicCompletion x₀ - xh) - (algebraMap E v.adicCompletion x - xh) := by
+    rw [map_sub]; ring
+  have hdiff : algebraMap E v.adicCompletion (x₀ - x) ∈ v.adicCompletionIntegers :=
+    heq ▸ sub_mem hx₀ hx
+  have hov : x₀ - x ∈ v.toValuationSubring :=
+    (kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff v _).mp hdiff
+  have hzero : v.localResidue (x₀ - x) = 0 :=
+    v.localResidue_eq_zero_of_ord_nonneg (Or.inr (v.ord_nonneg_of_mem hov))
+  rw [map_sub, sub_eq_zero] at hzero
+  exact hzero
+
+theorem kwHgfV352_localResidueCompletion_algebraMap (v : Place K E) (x : E) :
+    kwHgfV352_localResidueCompletion v (algebraMap E v.adicCompletion x)
+      = v.localResidue x :=
+  kwHgfV352_localResidueCompletion_spec v _
+    (by rw [sub_self]; exact zero_mem _)
+
+theorem kwHgfV352_localResidueCompletion_add (v : Place K E)
+    (xh yh : v.adicCompletion) :
+    kwHgfV352_localResidueCompletion v (xh + yh)
+      = kwHgfV352_localResidueCompletion v xh
+        + kwHgfV352_localResidueCompletion v yh := by
+  obtain ⟨x, hx⟩ := kwHgfV352_exists_sub_mem_adicCompletionIntegers v xh
+  obtain ⟨y, hy⟩ := kwHgfV352_exists_sub_mem_adicCompletionIntegers v yh
+  have heq : algebraMap E v.adicCompletion (x + y) - (xh + yh)
+      = (algebraMap E v.adicCompletion x - xh) + (algebraMap E v.adicCompletion y - yh) := by
+    rw [map_add]; ring
+  rw [kwHgfV352_localResidueCompletion_spec v xh hx,
+    kwHgfV352_localResidueCompletion_spec v yh hy,
+    kwHgfV352_localResidueCompletion_spec v (xh + yh) (x := x + y)
+      (heq ▸ add_mem hx hy),
+    map_add]
+
+theorem kwHgfV352_localResidueCompletion_sum (v : Place K E) {ι : Type*}
+    (s : Finset ι) (f : ι → v.adicCompletion) :
+    kwHgfV352_localResidueCompletion v (∑ i ∈ s, f i)
+      = ∑ i ∈ s, kwHgfV352_localResidueCompletion v (f i) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty =>
+    simp only [Finset.sum_empty]
+    rw [show (0 : v.adicCompletion) = algebraMap E v.adicCompletion 0 from (_root_.map_zero _).symm,
+      kwHgfV352_localResidueCompletion_algebraMap, _root_.map_zero]
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha, kwHgfV352_localResidueCompletion_add, ih,
+      Finset.sum_insert ha]
+
+end LocalResidueCompletion
+end AlgebraicCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+section ChainRule
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Nontrivial Ω[F⁄K]]
+
+theorem Place.differentialCoeff_kaehlerPullback [Nontrivial Ω[E⁄K]]
+    (v : Place K E) [v.DCoordGenerates] (w : Place K F) [w.DCoordGenerates]
+    (ωE : Ω[E⁄K]) :
+    w.differentialCoeff (kaehlerPullback K F E ωE)
+      = algebraMap E F (v.differentialCoeff ωE)
+        * w.differentialCoeff (kaehlerPullback K F E v.dCoord) := by
+  conv_lhs => rw [← v.differentialCoeff_smul_dCoord ωE,
+    kw_mlc_hrtCharP7_kaehlerPullback_smul, w.differentialCoeff_smul]
+
+end ChainRule
+end AlgebraicCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+section OmegaShift
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [HasCanonicalLocalResidueKStar K F]
+variable [Nontrivial Ω[F⁄K]]
+
+theorem kaehlerResidueTerm_kaehlerPullback_diagonal_eq_dCoord_shift
+    [Nontrivial Ω[E⁄K]] (v : Place K E) [v.DCoordGenerates]
+    (w : Place K F) [w.DCoordGenerates] (ωE : Ω[E⁄K]) (g : F) :
+    kaehlerResidueTerm (kaehlerPullback K F E ωE) (diagonalHom K F g) w
+      = kaehlerResidueTerm (kaehlerPullback K F E v.dCoord)
+          (diagonalHom K F (g * algebraMap E F (v.differentialCoeff ωE))) w := by
+  unfold kaehlerResidueTerm
+  congr 2
+  change g * w.differentialCoeff (kaehlerPullback K F E ωE)
+    = g * algebraMap E F (v.differentialCoeff ωE)
+        * w.differentialCoeff (kaehlerPullback K F E v.dCoord)
+  rw [Place.differentialCoeff_kaehlerPullback v w ωE, mul_assoc]
+
+end OmegaShift
+end AlgebraicCurve
+end
+
+noncomputable section
+
+namespace ModularCurve
+
+section CompletionTraceAtLinear
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F] [HasPrincipalDivisors K F]
+variable [FiniteDimensional E F]
+
+omit [HasPrincipalDivisors K F] in
+theorem kwF4R1V391a_completionTraceF'_mul_algebraMap (w : Place K F) (g : F) (c : E) :
+    kw_ffgc_completionTraceF' E w (g * algebraMap E F c)
+      = kw_ffgc_completionTraceF' E w g
+          * algebraMap E (w.restrict E).adicCompletion c := by
+  rw [kw_ffgc_completionTraceF'_apply, kw_ffgc_completionTraceF'_apply, map_mul,
+    kw_ffgc_adicCompletionComap_algebraMap_algebraMap E w c,
+    mul_comm (algebraMap F w.adicCompletion g) _, ← Algebra.smul_def,
+    LinearMap.map_smul, smul_eq_mul, mul_comm]
+
+theorem kwF4R1V391a_completionTraceAt_mul_algebraMap
+    (v : Place K E) (w : Place K F) (hw : w ∈ v.fiber F) (g : F) (c : E) :
+    kwHgfV352_completionTraceAt v w hw (g * algebraMap E F c)
+      = kwHgfV352_completionTraceAt v w hw g * algebraMap E v.adicCompletion c := by
+  have hv : w.restrict E = v := Place.mem_fiber.mp hw
+  subst hv
+  change (Place.mem_fiber.mp hw ▸ kw_ffgc_completionTraceF' E w (g * algebraMap E F c))
+    = (Place.mem_fiber.mp hw ▸ kw_ffgc_completionTraceF' E w g)
+        * algebraMap E (w.restrict E).adicCompletion c
+  rw [kwF4R1V391a_completionTraceF'_mul_algebraMap w g c]
+
+end CompletionTraceAtLinear
+
+end ModularCurve
+
+end
+
+
+section
+
+namespace FLT
+namespace Gapsw7X3xCrossPlaceTraceDecomposition
+
+open scoped NumberField TensorProduct
+
+theorem gapsw7_x3x_trace_pi (R : Type*) [CommRing R] {ι : Type*} [Fintype ι]
+    (S : ι → Type*) [∀ i, CommRing (S i)] [∀ i, Algebra R (S i)]
+    [∀ i, Module.Free R (S i)] [∀ i, Module.Finite R (S i)]
+    (x : ∀ i, S i) :
+    Algebra.trace R (∀ i, S i) x = ∑ i, Algebra.trace R (S i) (x i) := by
+  have _em := Classical.em
+  classical
+  let b : ∀ i, Module.Basis (Module.Free.ChooseBasisIndex R (S i)) R (S i) :=
+    fun i => Module.Free.chooseBasis R (S i)
+  have key : Algebra.leftMulMatrix (Pi.basis b) x
+      = Matrix.blockDiagonal' (fun i => Algebra.leftMulMatrix (b i) (x i)) := by
+    refine Matrix.ext fun ji ji' => ?_
+    obtain ⟨i, j⟩ := ji
+    obtain ⟨i', j'⟩ := ji'
+    rcases eq_or_ne i i' with rfl | hne
+    · rw [Matrix.blockDiagonal'_apply_eq, Algebra.leftMulMatrix_eq_repr_mul,
+        Algebra.leftMulMatrix_eq_repr_mul, Pi.basis_apply, Pi.basis_repr]
+      have hx : (x * Pi.single i (b i j')) i = x i * b i j' := by
+        simp
+      rw [hx]
+    · rw [Matrix.blockDiagonal'_apply_ne _ _ _ hne,
+        Algebra.leftMulMatrix_eq_repr_mul, Pi.basis_apply, Pi.basis_repr]
+      have hx : (x * Pi.single i' (b i' j')) i = 0 := by
+        simp [Pi.single_eq_of_ne hne]
+      rw [hx]
+      simp
+  rw [Algebra.trace_eq_matrix_trace (Pi.basis b), key,
+    Matrix.trace_blockDiagonal']
+  exact Finset.sum_congr rfl fun i _ =>
+    (Algebra.trace_eq_matrix_trace (b i) (x i)).symm
+
+theorem gapsw7_x3x_trace_baseChange (R A B : Type*) [CommRing R] [CommRing A]
+    [CommRing B] [Algebra R A] [Algebra R B] [Module.Free R B]
+    [Module.Finite R B] (b : B) :
+    Algebra.trace A (A ⊗[R] B) ((1 : A) ⊗ₜ[R] b)
+      = algebraMap R A (Algebra.trace R B b) := by
+  have _em := Classical.em
+  have h := LinearMap.trace_baseChange (Algebra.lmul R B b) A
+  rw [Algebra.baseChange_lmul] at h
+  exact h
+
+theorem gapsw7_x3x_trace_decomposition_of_prod_iso (R A B : Type*)
+    [CommRing R] [CommRing A] [CommRing B] [Algebra R A] [Algebra R B]
+    [Module.Free R B] [Module.Finite R B] {ι : Type*} [Fintype ι]
+    (S : ι → Type*) [∀ i, CommRing (S i)] [∀ i, Algebra A (S i)]
+    [∀ i, Module.Free A (S i)] [∀ i, Module.Finite A (S i)]
+    (e : (A ⊗[R] B) ≃ₐ[A] ∀ i, S i) (b : B) :
+    algebraMap R A (Algebra.trace R B b)
+      = ∑ i, Algebra.trace A (S i) (e ((1 : A) ⊗ₜ[R] b) i) := by
+  have _em := Classical.em
+  rw [← gapsw7_x3x_trace_baseChange R A B b,
+    ← Algebra.trace_eq_of_algEquiv e ((1 : A) ⊗ₜ[R] b),
+    gapsw7_x3x_trace_pi A S]
+
+end Gapsw7X3xCrossPlaceTraceDecomposition
+end FLT
+end
+
+noncomputable section
+
+namespace ModularCurve
+namespace KwF4R1V384a
+
+section FiberAlgebra
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F] [HasPrincipalDivisors K E] [HasPrincipalDivisors K F]
+
+scoped instance kwF4R1V384a_instAlgebraFiberCompletion (v : Place K E) (w' : v.fiber F) :
+    Algebra v.adicCompletion w'.1.adicCompletion := by
+  rcases w' with ⟨w', hw'⟩
+  have hv : w'.restrict E = v := Place.mem_fiber.mp hw'
+  subst hv
+  exact kw_ffgc_algebraAdicCompletionComap E w'
+
+scoped instance kwF4R1V384a_instIsScalarTowerFiberCompletion (v : Place K E) (w' : v.fiber F) :
+    IsScalarTower E v.adicCompletion w'.1.adicCompletion := by
+  rcases w' with ⟨w', hw'⟩
+  have hv : w'.restrict E = v := Place.mem_fiber.mp hw'
+  subst hv
+  refine IsScalarTower.of_algebraMap_eq fun e => ?_
+  rw [show algebraMap E w'.adicCompletion e = algebraMap F w'.adicCompletion (algebraMap E F e)
+    from IsScalarTower.algebraMap_apply E F w'.adicCompletion e]
+  exact kw_ffgc_adicCompletionComap_algebraMap_algebraMap E w' e
+
+scoped instance kwF4R1V384a_instFiniteDimensionalFiberCompletion [FiniteDimensional E F]
+    (v : Place K E) (w' : v.fiber F) :
+    FiniteDimensional v.adicCompletion w'.1.adicCompletion := by
+  rcases w' with ⟨w', hw'⟩
+  have hv : w'.restrict E = v := Place.mem_fiber.mp hw'
+  subst hv
+  exact kw_ffgc_finiteDimensional_adicCompletion E w'
+
+end FiberAlgebra
+section SemilocalDiag
+
+variable {K : Type*} (F : Type*) [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F] [HasPrincipalDivisors K E] [HasPrincipalDivisors K F]
+
+def kwF4R1V384a_semilocalComponent (v : Place K E) (w' : v.fiber F) :
+    v.adicCompletion ⊗[E] F →ₐ[v.adicCompletion] w'.1.adicCompletion :=
+  Algebra.TensorProduct.lift (Algebra.ofId v.adicCompletion w'.1.adicCompletion)
+    (IsScalarTower.toAlgHom E F w'.1.adicCompletion) (fun _ _ => mul_comm _ _)
+
+set_option backward.isDefEq.respectTransparency.types false in
+omit [HasPrincipalDivisors K E] in
+@[scoped simp]
+theorem kwF4R1V384a_semilocalComponent_tmul (v : Place K E) (w' : v.fiber F)
+    (c : v.adicCompletion) (g : F) :
+    kwF4R1V384a_semilocalComponent F v w' (c ⊗ₜ[E] g)
+      = algebraMap v.adicCompletion w'.1.adicCompletion c
+          * algebraMap F w'.1.adicCompletion g := by
+  unfold kwF4R1V384a_semilocalComponent
+  rw [Algebra.TensorProduct.lift_tmul]
+  rfl
+
+def kwF4R1V384a_semilocalDiag (v : Place K E) :
+    v.adicCompletion ⊗[E] F →ₐ[v.adicCompletion]
+      ((w' : v.fiber F) → w'.1.adicCompletion) :=
+  AlgHom.pi (kwF4R1V384a_semilocalComponent F v)
+
+variable {F}
+
+omit [HasPrincipalDivisors K E] in
+@[scoped simp]
+theorem kwF4R1V384a_semilocalDiag_apply (v : Place K E) (x : v.adicCompletion ⊗[E] F)
+    (w' : v.fiber F) :
+    kwF4R1V384a_semilocalDiag F v x w' = kwF4R1V384a_semilocalComponent F v w' x := rfl
+
+omit [HasPrincipalDivisors K E] in
+theorem kwF4R1V384a_semilocalDiag_one_tmul (v : Place K E) (g : F) (w' : v.fiber F) :
+    kwF4R1V384a_semilocalDiag F v ((1 : v.adicCompletion) ⊗ₜ[E] g) w'
+      = algebraMap F w'.1.adicCompletion g := by
+  rw [kwF4R1V384a_semilocalDiag_apply, kwF4R1V384a_semilocalComponent_tmul,
+    map_one, one_mul]
+
+end SemilocalDiag
+section Mint
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+variable (E : Type*) [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+def KwF4R1V384aCompletionSemilocalBij : Prop :=
+  ∀ [HasPrincipalDivisors K E] [HasPrincipalDivisors K F] [FiniteDimensional E F]
+    (v : Place K E),
+    Function.Bijective (kwF4R1V384a_semilocalDiag (K := K) (E := E) F v)
+
+end Mint
+section PerComponentSurjective
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F] [HasPrincipalDivisors K F]
+variable [FiniteDimensional E F]
+
+omit [HasPrincipalDivisors K F] [FiniteDimensional E F] in
+theorem kwF4R1V384a_completionLinearCombination_surjective
+    (w' : Place K F) {ι : Type*} [Fintype ι] (b : Module.Basis ι E F) :
+    Function.Surjective (kw_ffgc_completionLinearCombination E w' b) := by
+  let := kw_ffgc_rankOne_adicCompletion (K := K) (w'.restrict E)
+  let : NontriviallyNormedField (w'.restrict E).adicCompletion :=
+    Valued.toNontriviallyNormedField (w'.restrict E).adicCompletion
+      (WithZero (Multiplicative ℤ))
+  rw [← Set.range_eq_univ, ← LinearMap.coe_range,
+    ← (LinearMap.range (kw_ffgc_completionLinearCombination E w' b))
+        |>.closed_of_finiteDimensional.closure_eq]
+  exact (kw_ffgc_denseRange_completionLinearCombination E w' b).closure_range
+
+theorem kwF4R1V384a_semilocalComponent_surjective (v : Place K E) (w' : v.fiber F) :
+    Function.Surjective (kwF4R1V384a_semilocalComponent F v w') := by
+  rcases w' with ⟨w', hw'⟩
+  have hv : w'.restrict E = v := Place.mem_fiber.mp hw'
+  subst hv
+  intro y
+  let b := Module.finBasis E F
+  obtain ⟨c, hc⟩ := kwF4R1V384a_completionLinearCombination_surjective w' b y
+  refine ⟨∑ i, c i ⊗ₜ[E] b i, ?_⟩
+  rw [map_sum, ← hc]
+  unfold kw_ffgc_completionLinearCombination
+  rw [Fintype.linearCombination_apply]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [kwF4R1V384a_semilocalComponent_tmul, Algebra.smul_def]
+
+end PerComponentSurjective
+section SpecificMints
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+variable (E : Type*) [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+def KwF4R1V384aDistinctKernels : Prop :=
+  ∀ [HasPrincipalDivisors K E] [HasPrincipalDivisors K F] [FiniteDimensional E F]
+    (v : Place K E) (w' w'' : v.fiber F), w' ≠ w'' →
+    RingHom.ker (kwF4R1V384a_semilocalComponent (K := K) (E := E) F v w').toRingHom
+      ≠ RingHom.ker (kwF4R1V384a_semilocalComponent (K := K) (E := E) F v w'').toRingHom
+
+def KwF4R1V384aFinrankCompletionEF : Prop :=
+  ∀ [HasPrincipalDivisors K E] [HasPrincipalDivisors K F] [FiniteDimensional E F]
+    (v : Place K E) (w' : v.fiber F),
+    (Module.finrank v.adicCompletion w'.1.adicCompletion : ℤ)
+      = (w'.1.ramificationIndex E : ℤ) * (w'.1.inertiaDeg E : ℤ)
+
+end SpecificMints
+section BijEngine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+scoped instance kwF4R1V384a_ker_semilocalComponent_isMaximal
+    [HasPrincipalDivisors K E] [HasPrincipalDivisors K F] [FiniteDimensional E F]
+    (v : Place K E) (w' : v.fiber F) :
+    (RingHom.ker (kwF4R1V384a_semilocalComponent F v w').toRingHom).IsMaximal :=
+  RingHom.ker_isMaximal_of_surjective (kwF4R1V384a_semilocalComponent F v w').toRingHom
+    (kwF4R1V384a_semilocalComponent_surjective v w')
+
+theorem kwF4R1V384a_semilocalDiag_surjective_of_distinctKernels
+    [HasPrincipalDivisors K E] [HasPrincipalDivisors K F] [FiniteDimensional E F]
+    (hdist : KwF4R1V384aDistinctKernels K F E) (v : Place K E) :
+    Function.Surjective (kwF4R1V384a_semilocalDiag F v) := by
+  classical
+  intro y
+  let m : v.fiber F → Ideal (v.adicCompletion ⊗[E] F) :=
+    fun w' => RingHom.ker (kwF4R1V384a_semilocalComponent F v w').toRingHom
+  have : ∀ w', (m w').IsMaximal :=
+    kwF4R1V384a_ker_semilocalComponent_isMaximal v
+  have hcop : Pairwise (Function.onFun IsCoprime m) := fun i j hij =>
+    Ideal.isCoprime_of_isMaximal (I := m i) (J := m j) (hdist v i j hij)
+  choose xw hxw using fun w' => kwF4R1V384a_semilocalComponent_surjective v w' (y w')
+  obtain ⟨xbar, hxbar⟩ :=
+    Ideal.quotientInfToPiQuotient_surj hcop (fun w' => Ideal.Quotient.mk (m w') (xw w'))
+  obtain ⟨x, rfl⟩ := Ideal.Quotient.mk_surjective xbar
+  refine ⟨x, funext fun w' => ?_⟩
+  change kwF4R1V384a_semilocalComponent F v w' x = y w'
+  have hcomp : Ideal.Quotient.mk (m w') x = Ideal.Quotient.mk (m w') (xw w') := by
+    have := congrFun hxbar w'
+    rwa [Ideal.quotientInfToPiQuotient_mk' m x w'] at this
+  have hmod : x - xw w' ∈ m w' := Ideal.Quotient.eq.mp hcomp
+  have hzero : kwF4R1V384a_semilocalComponent F v w' (x - xw w') = 0 := hmod
+  rw [map_sub, sub_eq_zero] at hzero
+  rw [hzero, hxw w']
+
+scoped instance kwF4R1V384a_instModuleFiberCompletion
+    [HasPrincipalDivisors K E] [HasPrincipalDivisors K F]
+    (v : Place K E) (w' : v.fiber F) :
+    Module v.adicCompletion w'.1.adicCompletion :=
+  Algebra.toModule
+
+theorem kwF4R1V384a_completionSemilocalBij_of_distinctKernels_finrankEF
+    [Algebra.IsSeparable E F]
+    (hdist : KwF4R1V384aDistinctKernels K F E)
+    (hef : KwF4R1V384aFinrankCompletionEF K F E) :
+    KwF4R1V384aCompletionSemilocalBij K F E := by
+  intro _ _ _ v
+  have hsurj := kwF4R1V384a_semilocalDiag_surjective_of_distinctKernels hdist v
+  refine ⟨?_, hsurj⟩
+  let srPi : Semiring ((w' : v.fiber F) → w'.1.adicCompletion) := inferInstance
+  let algPi : Algebra v.adicCompletion ((w' : v.fiber F) → w'.1.adicCompletion) :=
+    inferInstance
+  let modPi : Module v.adicCompletion ((w' : v.fiber F) → w'.1.adicCompletion) :=
+    @Algebra.toModule _ _ _ srPi algPi
+  have hdimcod : Module.finrank v.adicCompletion ((w' : v.fiber F) → w'.1.adicCompletion)
+      = Module.finrank E F := by
+    have hpi : (Module.finrank v.adicCompletion ((w' : v.fiber F) → w'.1.adicCompletion) : ℕ)
+        = ∑ w' : v.fiber F, Module.finrank v.adicCompletion w'.1.adicCompletion := by
+      convert Module.finrank_pi_fintype v.adicCompletion using 2 <;>
+        exact fun i => inferInstance
+    rw [hpi]
+    have hsum := Place.sum_ramificationIndex_mul_inertiaDeg (K := K) (F := E) (F' := F) v
+    rw [← Nat.cast_inj (R := ℤ), Nat.cast_sum]
+    calc ∑ w' : v.fiber F,
+          ((Module.finrank v.adicCompletion w'.1.adicCompletion : ℤ))
+        = ∑ w' : v.fiber F,
+            ((w'.1.ramificationIndex E : ℤ) * (w'.1.inertiaDeg E : ℤ)) :=
+          Finset.sum_congr rfl fun w' _ => hef v w'
+      _ = ∑ w' ∈ v.fiber F,
+            ((w'.ramificationIndex E : ℤ) * (w'.inertiaDeg E : ℤ)) :=
+          Finset.sum_attach (v.fiber F)
+            (fun w => (w.ramificationIndex E : ℤ) * (w.inertiaDeg E : ℤ))
+      _ = (Module.finrank E F : ℤ) := hsum
+  have hdimdom : Module.finrank v.adicCompletion (v.adicCompletion ⊗[E] F)
+      = Module.finrank E F := by
+    rw [Module.finrank_tensorProduct, Module.finrank_self, one_mul]
+  have hsurj' : Function.Surjective
+      (kwF4R1V384a_semilocalDiag F v).toLinearMap := hsurj
+  have fdPi : FiniteDimensional v.adicCompletion
+      ((w' : v.fiber F) → w'.1.adicCompletion) := inferInstance
+  exact (@LinearMap.injective_iff_surjective_of_finrank_eq_finrank
+    v.adicCompletion (v.adicCompletion ⊗[E] F) _ _ _
+    ((w' : v.fiber F) → w'.1.adicCompletion) _ modPi _ fdPi
+    (hdimdom.trans hdimcod.symm)
+    (kwF4R1V384a_semilocalDiag F v).toLinearMap).mpr hsurj'
+
+end BijEngine
+section Headline
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+open FLT.Gapsw7X3xCrossPlaceTraceDecomposition
+
+theorem kwF4R1V384a_trace_algebraMap_eq_completionTraceAt
+    [HasPrincipalDivisors K E] [HasPrincipalDivisors K F] [FiniteDimensional E F]
+    (v : Place K E) (w' : v.fiber F) (g : F) :
+    Algebra.trace v.adicCompletion w'.1.adicCompletion (algebraMap F w'.1.adicCompletion g)
+      = AlgebraicCurve.kwHgfV352_completionTraceAt v w'.1 w'.2 g := by
+  rcases w' with ⟨w', hw'⟩
+  have hv : w'.restrict E = v := Place.mem_fiber.mp hw'
+  subst hv
+  rfl
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+theorem kwF4R1V384a_completionTraceSum_of_semilocalBij
+    (hbij : KwF4R1V384aCompletionSemilocalBij K F E) :
+    AlgebraicCurve.KwHgfV352CompletionTraceSum K F E := by
+  classical
+  intro _ _ _ v g
+  let e : v.adicCompletion ⊗[E] F ≃ₐ[v.adicCompletion]
+      ((w' : v.fiber F) → w'.1.adicCompletion) :=
+    AlgEquiv.ofBijective (kwF4R1V384a_semilocalDiag F v) (hbij v)
+  rw [gapsw7_x3x_trace_decomposition_of_prod_iso E v.adicCompletion F
+        (fun w' : v.fiber F => w'.1.adicCompletion) e g]
+  refine Finset.sum_congr rfl fun w' _ => ?_
+  rw [show e ((1 : v.adicCompletion) ⊗ₜ[E] g) w'
+      = kwF4R1V384a_semilocalDiag F v ((1 : v.adicCompletion) ⊗ₜ[E] g) w' from rfl,
+    kwF4R1V384a_semilocalDiag_one_tmul,
+    kwF4R1V384a_trace_algebraMap_eq_completionTraceAt]
+
+theorem kwF4R1V384a_completionTraceSum_of_distinctKernels_finrankEF
+    [Algebra.IsSeparable E F]
+    (hdist : KwF4R1V384aDistinctKernels K F E)
+    (hef : KwF4R1V384aFinrankCompletionEF K F E) :
+    AlgebraicCurve.KwHgfV352CompletionTraceSum K F E :=
+  kwF4R1V384a_completionTraceSum_of_semilocalBij
+    (kwF4R1V384a_completionSemilocalBij_of_distinctKernels_finrankEF hdist hef)
+
+end Headline
+end KwF4R1V384a
+end ModularCurve
+end
+
+noncomputable section
+
+namespace ModularCurve
+namespace KwF4R1V386a
+
+open ModularCurve.KwF4R1V384a
+
+section IsSeparableLift
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+theorem kwF4R1V386a_isSeparable_algebraMap_fiberCompletion
+    [HasPrincipalDivisors K E] [HasPrincipalDivisors K F]
+    [FiniteDimensional E F] [Algebra.IsSeparable E F]
+    (v : Place K E) (w' : v.fiber F) (g : F) :
+    IsSeparable v.adicCompletion (algebraMap F w'.1.adicCompletion g) := by
+  have hroot : Polynomial.aeval (R := v.adicCompletion)
+      (algebraMap F w'.1.adicCompletion g)
+      ((minpoly E g).map (algebraMap E v.adicCompletion)) = 0 := by
+    rw [Polynomial.aeval_map_algebraMap,
+      show algebraMap F w'.1.adicCompletion g
+          = IsScalarTower.toAlgHom E F w'.1.adicCompletion g from rfl,
+      Polynomial.aeval_algHom_apply, minpoly.aeval, _root_.map_zero]
+  have hmapsep : ((minpoly E g).map (algebraMap E v.adicCompletion)).Separable :=
+    Polynomial.Separable.map (Algebra.IsSeparable.isSeparable E g)
+  exact hmapsep.of_dvd (minpoly.dvd v.adicCompletion _ hroot)
+
+theorem kwF4R1V386a_isSeparable_fiberCompletion
+    [HasPrincipalDivisors K E] [HasPrincipalDivisors K F]
+    [FiniteDimensional E F] [Algebra.IsSeparable E F]
+    (v : Place K E) (w' : v.fiber F) :
+    Algebra.IsSeparable v.adicCompletion w'.1.adicCompletion := by
+  have hgen : Algebra.adjoin v.adicCompletion
+      (Set.range (algebraMap F w'.1.adicCompletion)) = ⊤ := by
+    rw [Algebra.eq_top_iff]
+    intro y
+    obtain ⟨x, rfl⟩ := kwF4R1V384a_semilocalComponent_surjective v w' y
+    induction x using TensorProduct.inductionOn with
+    | tmul c g =>
+      rw [kwF4R1V384a_semilocalComponent_tmul, ← Algebra.smul_def]
+      exact Subalgebra.smul_mem _ (Algebra.subset_adjoin (Set.mem_range_self g)) c
+    | add x y hx hy => rw [map_add]; exact add_mem hx hy
+  have hsep : ∀ x ∈ Set.range (algebraMap F w'.1.adicCompletion),
+      IsSeparable v.adicCompletion x := by
+    rintro _ ⟨g, rfl⟩
+    exact kwF4R1V386a_isSeparable_algebraMap_fiberCompletion v w' g
+  have hgenI : IntermediateField.adjoin v.adicCompletion
+      (Set.range (algebraMap F w'.1.adicCompletion)) = ⊤ := by
+    rw [eq_top_iff]; intro x _
+    exact IntermediateField.algebra_adjoin_le_adjoin _ _ (hgen ▸ Algebra.mem_top)
+  have hsepAdj : Algebra.IsSeparable v.adicCompletion
+      (IntermediateField.adjoin v.adicCompletion
+        (Set.range (algebraMap F w'.1.adicCompletion))) :=
+    (IntermediateField.isSeparable_adjoin_iff_isSeparable v.adicCompletion
+      w'.1.adicCompletion).mpr hsep
+  rw [hgenI] at hsepAdj
+  exact Algebra.IsSeparable.of_algHom v.adicCompletion
+    (⊤ : IntermediateField v.adicCompletion w'.1.adicCompletion)
+    (IntermediateField.topEquiv (F := v.adicCompletion)
+      (E := w'.1.adicCompletion)).symm.toAlgHom
+
+end IsSeparableLift
+section DistinctKernels
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+theorem kwF4R1V386a_spectralNorm_eq_absoluteValue [FiniteDimensional E F]
+    (w' : Place K F) (y : w'.adicCompletion) :
+    letI := kw_ffgc_rankOne_adicCompletion (w'.restrict E)
+    letI : NontriviallyNormedField (w'.restrict E).adicCompletion :=
+      Valued.toNontriviallyNormedField (w'.restrict E).adicCompletion ℤᵐ⁰
+    spectralNorm (w'.restrict E).adicCompletion w'.adicCompletion y
+      = kw_ffgc_absoluteValue E w' y := by
+  let := kw_ffgc_rankOne_adicCompletion (w'.restrict E)
+  let : NontriviallyNormedField (w'.restrict E).adicCompletion :=
+    Valued.toNontriviallyNormedField (w'.restrict E).adicCompletion ℤᵐ⁰
+  have : IsUltrametricDist (w'.restrict E).adicCompletion :=
+    IsUltrametricDist.isUltrametricDist_of_isNonarchimedean_norm
+      (fun a b => Valuation.norm_add_le Valued.v a b)
+  have : Algebra.IsAlgebraic (w'.restrict E).adicCompletion w'.adicCompletion :=
+    Algebra.IsAlgebraic.of_finite _ _
+  exact (spectralNorm_unique_field_norm_ext (f := kw_ffgc_absoluteValue E w')
+    (kw_ffgc_absoluteValue_extends E w') y).symm
+
+theorem kwF4R1V386a_spectralNorm_eq_absoluteValue_fiber
+    [HasPrincipalDivisors K E] [HasPrincipalDivisors K F] [FiniteDimensional E F]
+    (v : Place K E) (w' : v.fiber F) (y : w'.1.adicCompletion) :
+    letI := kw_ffgc_rankOne_adicCompletion v
+    letI : NontriviallyNormedField v.adicCompletion :=
+      Valued.toNontriviallyNormedField v.adicCompletion ℤᵐ⁰
+    spectralNorm v.adicCompletion w'.1.adicCompletion y
+      = kw_ffgc_absoluteValue E w'.1 y := by
+  rcases w' with ⟨w', hw'⟩
+  have hv : w'.restrict E = v := Place.mem_fiber.mp hw'
+  subst hv
+  exact kwF4R1V386a_spectralNorm_eq_absoluteValue (K := K) (E := E) w' y
+
+theorem kwF4R1V386a_valuedAlgebraMap_le_one_iff (w' : Place K F) (g : F) :
+    Valued.v (algebraMap F w'.adicCompletion g) ≤ 1 ↔ g ∈ w'.toValuationSubring := by
+  have hval : Valued.v (algebraMap F w'.adicCompletion g) = w'.adicValuation g :=
+    IsDedekindDomain.HeightOneSpectrum.valuedAdicCompletion_eq_valuation'
+      (v := w'.heightOneSpectrum) (K := F) g
+  rw [hval]
+  rcases eq_or_ne g 0 with rfl | hg
+  · simp only [_root_.map_zero, zero_le_one, w'.toValuationSubring.zero_mem]
+  · rw [w'.mem_iff_ord_nonneg hg, Place.ord, neg_nonneg]
+    have hvne : w'.adicValuation g ≠ 0 := w'.adicValuation_ne_zero hg
+    rw [show (0 : ℤ) = WithZero.log (1 : ℤᵐ⁰) from WithZero.log_one.symm]
+    exact ⟨fun hle => WithZero.log_le_log hvne one_ne_zero |>.mpr hle,
+      fun hlog => (WithZero.log_le_log hvne one_ne_zero).mp hlog⟩
+
+omit [Algebra K E] [IsScalarTower K E F] in
+theorem kwF4R1V386a_absoluteValue_algebraMap_le_one_iff
+    (w' : Place K F) (g : F) :
+    kw_ffgc_absoluteValue E w' (algebraMap F w'.adicCompletion g) ≤ 1
+      ↔ g ∈ w'.toValuationSubring := by
+  let := kw_ffgc_rankOne_adicCompletion w'
+  have hr : (0 : ℝ) < ((w'.ramificationIndex E : ℝ))⁻¹ :=
+    inv_pos.mpr (Nat.cast_pos.mpr (w'.ramificationIndex_pos (F := E)))
+  change ‖algebraMap F w'.adicCompletion g‖ ^ ((w'.ramificationIndex E : ℝ))⁻¹ ≤ 1
+    ↔ g ∈ w'.toValuationSubring
+  constructor
+  · intro hle
+    have hn : ‖algebraMap F w'.adicCompletion g‖ ≤ 1 := by
+      by_contra hgt
+      have hgt' : 1 < ‖algebraMap F w'.adicCompletion g‖ := not_le.mp hgt
+      exact absurd ((Real.one_lt_rpow_iff_of_pos (lt_trans one_pos hgt')).mpr
+        (Or.inl ⟨hgt', hr⟩)) (not_lt.mpr hle)
+    rw [Valued.toNormedField.norm_le_one_iff] at hn
+    exact (kwF4R1V386a_valuedAlgebraMap_le_one_iff w' g).mp hn
+  · intro hmem
+    have hn : ‖algebraMap F w'.adicCompletion g‖ ≤ 1 := by
+      rw [Valued.toNormedField.norm_le_one_iff]
+      exact (kwF4R1V386a_valuedAlgebraMap_le_one_iff w' g).mpr hmem
+    calc ‖algebraMap F w'.adicCompletion g‖ ^ ((w'.ramificationIndex E : ℝ))⁻¹
+        ≤ 1 ^ ((w'.ramificationIndex E : ℝ))⁻¹ :=
+          Real.rpow_le_rpow (norm_nonneg _) hn hr.le
+      _ = 1 := Real.one_rpow _
+
+set_option backward.isDefEq.respectTransparency.types false in
+theorem kwF4R1V386a_distinctKernels :
+    KwF4R1V384aDistinctKernels K F E := by
+  intro _ _ _ v w' w'' hne hker
+  apply hne
+  have hsurj' := kwF4R1V384a_semilocalComponent_surjective v w'
+  have hann : ∀ a ∈ RingHom.ker (kwF4R1V384a_semilocalComponent F v w').toRingHom,
+      kwF4R1V384a_semilocalComponent F v w'' a = 0 := fun a ha => by
+    have : a ∈ RingHom.ker (kwF4R1V384a_semilocalComponent F v w'').toRingHom :=
+      hker ▸ ha
+    exact this
+  let σ : w'.1.adicCompletion →ₐ[v.adicCompletion] w''.1.adicCompletion :=
+    (Ideal.Quotient.liftₐ _ (kwF4R1V384a_semilocalComponent F v w'') hann).comp
+      (Ideal.quotientKerAlgEquivOfSurjective hsurj').symm.toAlgHom
+  have hσcomp : ∀ x, σ (kwF4R1V384a_semilocalComponent F v w' x)
+      = kwF4R1V384a_semilocalComponent F v w'' x := by
+    intro x
+    have hstep1 : (Ideal.quotientKerAlgEquivOfSurjective hsurj').symm
+        (kwF4R1V384a_semilocalComponent F v w' x) = Ideal.Quotient.mk _ x := by
+      rw [show kwF4R1V384a_semilocalComponent F v w' x
+          = Ideal.quotientKerAlgEquivOfSurjective hsurj' (Ideal.Quotient.mk _ x) from rfl,
+        AlgEquiv.symm_apply_apply]
+    simp only [σ, AlgHom.coe_comp, Function.comp_apply, Ideal.Quotient.liftₐ_apply]
+    erw [hstep1, Ideal.Quotient.lift_mk]
+  have hσF : ∀ g : F, σ (algebraMap F w'.1.adicCompletion g)
+      = algebraMap F w''.1.adicCompletion g := by
+    intro g
+    have h' := hσcomp ((1 : v.adicCompletion) ⊗ₜ[E] g)
+    rwa [kwF4R1V384a_semilocalComponent_tmul, map_one, one_mul,
+      kwF4R1V384a_semilocalComponent_tmul, map_one, one_mul] at h'
+  let := kw_ffgc_rankOne_adicCompletion v
+  let : NontriviallyNormedField v.adicCompletion :=
+    Valued.toNontriviallyNormedField v.adicCompletion ℤᵐ⁰
+  have hσinj : Function.Injective σ := σ.toRingHom.injective
+  have hσspec : ∀ y, spectralNorm v.adicCompletion w''.1.adicCompletion (σ y)
+      = spectralNorm v.adicCompletion w'.1.adicCompletion y := by
+    intro y
+    unfold spectralNorm
+    congr 1
+    exact minpoly.algHom_eq σ hσinj y
+  refine Subtype.ext ?_
+  refine AlgebraicCurve.Place.ext (K := K) (F := F) (SetLike.ext fun g => ?_)
+  rw [← kwF4R1V386a_absoluteValue_algebraMap_le_one_iff (K := K) (E := E) w'.1 g,
+    ← kwF4R1V386a_absoluteValue_algebraMap_le_one_iff (K := K) (E := E) w''.1 g,
+    ← kwF4R1V386a_spectralNorm_eq_absoluteValue_fiber (K := K) (E := E) v w'
+      (algebraMap F w'.1.adicCompletion g),
+    ← kwF4R1V386a_spectralNorm_eq_absoluteValue_fiber (K := K) (E := E) v w''
+      (algebraMap F w''.1.adicCompletion g),
+    ← hσF g, hσspec]
+
+end DistinctKernels
+section FinrankCompletionEF
+
+open Valuation
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+theorem kwF4R1V386a_ramificationIdx_completion_eq
+    (w' : Place K F) :
+    (maximalIdeal (w'.restrict E).adicCompletionIntegers).ramificationIdx'
+      (maximalIdeal w'.adicCompletionIntegers) = w'.ramificationIndex E := by
+  set e := w'.ramificationIndex E with he
+  have hepos : 0 < e := w'.ramificationIndex_pos (F := E)
+  obtain ⟨π, hπval⟩ := IsDedekindDomain.HeightOneSpectrum.adicCompletion.exists_uniformizer E
+    (w'.restrict E).heightOneSpectrum
+  have hmap : (maximalIdeal (w'.restrict E).adicCompletionIntegers).map
+      (algebraMap (w'.restrict E).adicCompletionIntegers w'.adicCompletionIntegers)
+        = Ideal.span {algebraMap _ w'.adicCompletionIntegers π} := by
+    rw [show maximalIdeal ((w'.restrict E).adicCompletionIntegers : Type _)
+        = (w'.restrict E).heightOneSpectrum.completionIdeal E from rfl,
+      IsDedekindDomain.HeightOneSpectrum.completionIdeal,
+      IsDedekindDomain.HeightOneSpectrum.adicCompletion.maximalIdeal_eq_span_uniformizer E
+        _ hπval,
+      Ideal.map_span, Set.image_singleton]
+  have hπval' : Valued.v (π : (w'.restrict E).adicCompletion)
+      = (↑(Multiplicative.ofAdd (-1 : ℤ)) : ℤᵐ⁰) := hπval
+  have hval : Valued.v ((algebraMap (w'.restrict E).adicCompletionIntegers
+        w'.adicCompletionIntegers π : w'.adicCompletionIntegers) : w'.adicCompletion)
+      = (↑(Multiplicative.ofAdd (-(e : ℤ))) : ℤᵐ⁰) := by
+    rw [show ((algebraMap _ w'.adicCompletionIntegers π
+          : w'.adicCompletionIntegers) : w'.adicCompletion)
+        = kw_ffgc_adicCompletionComap E w' (π : (w'.restrict E).adicCompletion) from
+      (kw_ffgc_adicCompletionComapIntegers_coe E w' π).symm,
+      kw_ffgc_valued_adicCompletionComap, hπval', ← WithZero.coe_pow, WithZero.coe_inj,
+      ← ofAdd_nsmul, nsmul_eq_mul, mul_neg_one, he]
+  refine Ideal.ramificationIdx'_spec ?_ ?_
+  · rw [hmap, Ideal.span_singleton_le_iff_mem,
+      show maximalIdeal (w'.adicCompletionIntegers : Type _)
+        = w'.heightOneSpectrum.completionIdeal F from rfl,
+      IsDedekindDomain.HeightOneSpectrum.adicCompletion.mem_completionIdeal_pow, hval]
+  · rw [hmap, Ideal.span_singleton_le_iff_mem,
+      show maximalIdeal (w'.adicCompletionIntegers : Type _)
+        = w'.heightOneSpectrum.completionIdeal F from rfl,
+      IsDedekindDomain.HeightOneSpectrum.adicCompletion.mem_completionIdeal_pow, hval]
+    simp only [WithZero.coe_le_coe, Multiplicative.ofAdd_le, not_le]
+    omega
+
+theorem kwF4R1V386a_integersToCompletion_commute
+    (w' : Place K F) (a : (w'.restrict E).toValuationSubring) :
+    algebraMap (w'.restrict E).adicCompletionIntegers w'.adicCompletionIntegers
+        (algebraMap (w'.restrict E).toValuationSubring
+          (w'.restrict E).adicCompletionIntegers a)
+      = algebraMap w'.toValuationSubring w'.adicCompletionIntegers
+          (restrictInclusion E w' a) := by
+  apply Subtype.ext
+  exact (kw_ffgc_adicCompletionComap_algebraMap_algebraMap E w' (a : E)).symm
+
+theorem kwF4R1V386a_inertiaDeg_completion_eq
+    (w' : Place K F) :
+    (maximalIdeal w'.adicCompletionIntegers).inertiaDeg
+      (w'.restrict E).adicCompletionIntegers = w'.inertiaDeg E := by
+  have : IsLocalHom (algebraMap (w'.restrict E).adicCompletionIntegers
+      w'.adicCompletionIntegers) :=
+    kw_ffgc_isLocalHom_adicCompletionComapIntegers E w'
+  have : (maximalIdeal w'.adicCompletionIntegers).LiesOver
+      (maximalIdeal (w'.restrict E).adicCompletionIntegers) := by
+    have hcomap : (maximalIdeal w'.adicCompletionIntegers).comap
+        (algebraMap (w'.restrict E).adicCompletionIntegers w'.adicCompletionIntegers)
+        = maximalIdeal (w'.restrict E).adicCompletionIntegers :=
+      ((IsLocalRing.local_hom_TFAE (algebraMap (w'.restrict E).adicCompletionIntegers
+        w'.adicCompletionIntegers)).out 1 5).mp ‹IsLocalHom _›
+    exact ⟨hcomap.symm⟩
+  rw [Ideal.inertiaDeg_eq_of_isMaximal
+    (maximalIdeal (w'.restrict E).adicCompletionIntegers)
+    (maximalIdeal w'.adicCompletionIntegers)]
+  symm
+  refine Algebra.finrank_eq_of_equiv_equiv
+    (kw_ffgc_residueFieldEquivCompletionResidueField (w'.restrict E))
+    (kw_ffgc_residueFieldEquivCompletionResidueField w') ?_
+  ext a
+  obtain ⟨a, rfl⟩ := IsLocalRing.residue_surjective a
+  simp only [RingHom.coe_comp, Function.comp_apply]
+  exact congrArg (IsLocalRing.residue w'.adicCompletionIntegers)
+    (kwF4R1V386a_integersToCompletion_commute (K := K) (E := E) w' a)
+
+theorem kwF4R1V386a_finrankCompletionEF [Algebra.IsSeparable E F] :
+    KwF4R1V384aFinrankCompletionEF K F E := by
+  intro _ _ _ v wfib
+  have hv : wfib.1.restrict E = v := Place.mem_fiber.mp wfib.2
+  have hsep : Algebra.IsSeparable v.adicCompletion wfib.1.adicCompletion :=
+    kwF4R1V386a_isSeparable_fiberCompletion v wfib
+  rcases wfib with ⟨w', hw'⟩
+  dsimp only at hv hsep ⊢
+  subst hv
+  have : Algebra.IsSeparable (w'.restrict E).adicCompletion w'.adicCompletion := hsep
+  have : Algebra.IsAlgebraic (w'.restrict E).adicCompletion w'.adicCompletion :=
+    Algebra.IsAlgebraic.of_finite _ _
+  have : IsIntegralClosure w'.adicCompletionIntegers
+      (w'.restrict E).adicCompletionIntegers w'.adicCompletion :=
+    kw_ffgc_isIntegralClosure_adicCompletionIntegers E w'
+  have : IsNoetherian (w'.restrict E).adicCompletionIntegers w'.adicCompletionIntegers :=
+    IsIntegralClosure.isNoetherian (w'.restrict E).adicCompletionIntegers
+      (w'.restrict E).adicCompletion w'.adicCompletion w'.adicCompletionIntegers
+  have : Module.Finite (w'.restrict E).adicCompletionIntegers w'.adicCompletionIntegers :=
+    Module.IsNoetherian.finite _ _
+  have hinj : Function.Injective
+      (algebraMap (w'.restrict E).adicCompletionIntegers w'.adicCompletion) := by
+    intro x y hxy
+    apply Subtype.ext
+    apply (algebraMap (w'.restrict E).adicCompletion w'.adicCompletion).injective
+    simpa [IsScalarTower.algebraMap_apply
+      (w'.restrict E).adicCompletionIntegers
+      (w'.restrict E).adicCompletion w'.adicCompletion] using hxy
+  let : Module.IsTorsionFree
+      (w'.restrict E).adicCompletionIntegers w'.adicCompletion :=
+    Module.IsTorsionFree.comap
+      (algebraMap (w'.restrict E).adicCompletionIntegers w'.adicCompletion)
+      (fun _ hr => .of_ne_zero <| by simpa only [map_zero] using hinj.ne hr.ne_zero)
+      (fun r x => Algebra.smul_def r x)
+  let : Module.IsTorsionFree
+      (w'.restrict E).adicCompletionIntegers w'.adicCompletionIntegers :=
+    IsIntegralClosure.isTorsionFree
+      (w'.restrict E).adicCompletionIntegers w'.adicCompletion
+  have hpne : maximalIdeal (w'.restrict E).adicCompletionIntegers ≠ ⊥ := by
+    intro h
+    exact IsDiscreteValuationRing.not_isField _
+      ((IsLocalRing.isField_iff_maximalIdeal_eq).mpr h)
+  have hef :
+      (maximalIdeal (w'.restrict E).adicCompletionIntegers).ramificationIdx'
+          (maximalIdeal w'.adicCompletionIntegers) *
+        (maximalIdeal w'.adicCompletionIntegers).inertiaDeg
+          (w'.restrict E).adicCompletionIntegers =
+            Module.finrank (w'.restrict E).adicCompletion w'.adicCompletion := by
+    rw [Ideal.ramificationIdx'_eq_ramificationIdx
+      (maximalIdeal (w'.restrict E).adicCompletionIntegers)
+      (maximalIdeal w'.adicCompletionIntegers) hpne]
+    calc
+      _ = ∑ q : (maximalIdeal
+            (w'.restrict E).adicCompletionIntegers).primesOver
+              w'.adicCompletionIntegers,
+          q.1.ramificationIdx (w'.restrict E).adicCompletionIntegers *
+            q.1.inertiaDeg (w'.restrict E).adicCompletionIntegers := by
+              symm
+              let q : (maximalIdeal
+                  (w'.restrict E).adicCompletionIntegers).primesOver
+                    w'.adicCompletionIntegers :=
+                ⟨maximalIdeal w'.adicCompletionIntegers, by
+                  rw [IsLocalRing.primesOver_eq w'.adicCompletionIntegers hpne]
+                  simp⟩
+              apply Finset.sum_eq_single q
+              · intro b _ hb
+                have : b = q := by
+                  apply Subtype.ext
+                  have hb : b.1 ∈ ({maximalIdeal w'.adicCompletionIntegers} :
+                      Set (Ideal w'.adicCompletionIntegers)) := by
+                    rw [← IsLocalRing.primesOver_eq w'.adicCompletionIntegers hpne]
+                    exact b.2
+                  simpa using hb
+                exact (hb this).elim
+              · simp
+      _ = Module.finrank (w'.restrict E).adicCompletionIntegers
+          w'.adicCompletionIntegers :=
+            Ideal.sum_ramification_inertia_eq_finrank
+              (maximalIdeal (w'.restrict E).adicCompletionIntegers)
+              w'.adicCompletionIntegers
+      _ = Module.finrank (w'.restrict E).adicCompletion w'.adicCompletion :=
+        IsIntegralClosure.rank (w'.restrict E).adicCompletionIntegers
+          (w'.restrict E).adicCompletion w'.adicCompletion w'.adicCompletionIntegers
+  rw [kwF4R1V386a_ramificationIdx_completion_eq (K := K) w',
+    kwF4R1V386a_inertiaDeg_completion_eq (K := K) w'] at hef
+  exact_mod_cast hef.symm
+
+end FinrankCompletionEF
+section Headline
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+theorem kwF4R1V386a_completionTraceSum_of_isSeparable [Algebra.IsSeparable E F] :
+    AlgebraicCurve.KwHgfV352CompletionTraceSum K F E :=
+  kwF4R1V384a_completionTraceSum_of_distinctKernels_finrankEF
+    kwF4R1V386a_distinctKernels kwF4R1V386a_finrankCompletionEF
+
+end Headline
+end KwF4R1V386a
+end ModularCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+section Headline
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable [HasCanonicalLocalResidueKStar K F]
+variable {E : Type*} [Field E] [Algebra K E]
+variable [HasCanonicalLocalResidueKStar K E]
+variable [Algebra E F] [IsScalarTower K E F] [Algebra.IsIntegral E F]
+variable [∀ w : Place K F, w.FiniteResidue] [FiniteDimensional E F]
+variable [Nontrivial Ω[E⁄K]] [∀ v : Place K E, v.DCoordGenerates]
+variable [Nontrivial Ω[F⁄K]] [∀ w : Place K F, w.DCoordGenerates]
+
+theorem kw_es_fiberKaehlerCotraceResidueIdentity_of_RTCC_CTS
+    [HasPrincipalDivisors K E] [HasPrincipalDivisors K F]
+    (hRTCC : KwF4R1V391aResidueTraceCompletionCommute K F E)
+    (hCTS : KwHgfV352CompletionTraceSum K F E) :
+    FiberKaehlerCotraceResidueIdentity K F E := by
+  intro _ _ ωE _hωE _hωF v f
+  calc ∑ w ∈ v.fiber F,
+          kaehlerResidueTerm (kaehlerPullback K F E ωE) (diagonalHom K F f) w
+      = ∑ w' ∈ (v.fiber F).attach,
+          Algebra.trace K v.ResidueField
+            (kwHgfV352_localResidueCompletion v
+              (kwHgfV352_completionTraceAt v w'.1 w'.2 f
+                * algebraMap E v.adicCompletion (v.differentialCoeff ωE))) := by
+        rw [← Finset.sum_attach (v.fiber F)
+          (fun w => kaehlerResidueTerm (kaehlerPullback K F E ωE) (diagonalHom K F f) w)]
+        refine Finset.sum_congr rfl fun w' _ => ?_
+        rw [kaehlerResidueTerm_kaehlerPullback_diagonal_eq_dCoord_shift v w'.1 ωE f,
+          hRTCC v w'.1 w'.2 (f * algebraMap E F (v.differentialCoeff ωE)),
+          kwF4R1V391a_completionTraceAt_mul_algebraMap v w'.1 w'.2 f
+            (v.differentialCoeff ωE)]
+    _ = Algebra.trace K v.ResidueField
+          (kwHgfV352_localResidueCompletion v
+            ((∑ w' ∈ (v.fiber F).attach, kwHgfV352_completionTraceAt v w'.1 w'.2 f)
+              * algebraMap E v.adicCompletion (v.differentialCoeff ωE))) := by
+        rw [Finset.sum_mul,
+          kwHgfV352_localResidueCompletion_sum v (v.fiber F).attach _,
+          map_sum]
+    _ = Algebra.trace K v.ResidueField
+          (kwHgfV352_localResidueCompletion v
+            (algebraMap E v.adicCompletion (Algebra.trace E F f)
+              * algebraMap E v.adicCompletion (v.differentialCoeff ωE))) := by
+        rw [← hCTS v f]
+    _ = Algebra.trace K v.ResidueField
+          (v.localResidue (Algebra.trace E F f * v.differentialCoeff ωE)) := by
+        rw [← map_mul, kwHgfV352_localResidueCompletion_algebraMap v]
+    _ = kaehlerResidueTerm ωE (diagonalHom K E (Algebra.trace E F f)) v := by
+        unfold kaehlerResidueTerm; rw [diagonalHom_apply]
+
+end Headline
+section Compose
+
+variable {K F : Type*} [Field K] [IsAlgClosed K]
+variable [Field F] [Algebra K F] [HasCanonicalLocalResidueKStar K F]
+variable [HasCanonicalDivisor (K := K) (F := F)] [∀ w : Place K F, w.DCoordGenerates]
+variable [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+variable [Algebra.IsIntegral (RatFunc K) F] [Module.Finite (RatFunc K) F]
+variable [HasLocalResidue K F]
+variable [∀ w : Place K F, w.FiniteResidue]
+variable [Nontrivial Ω[F⁄K]]
+
+theorem kw_es_residueTheoremK_of_RTCC_isAlgClosed
+    [HasPrincipalDivisors K F] [Algebra.IsSeparable (RatFunc K) F]
+    [Nontrivial Ω[(RatFunc K)⁄K]] [∀ v : Place K (RatFunc K), v.DCoordGenerates]
+    (hgen : kaehlerPullback K F (RatFunc K) (dX K) ≠ 0)
+    (hRTCC : KwF4R1V391aResidueTraceCompletionCommute K F (RatFunc K)) :
+    ResidueTheoremK K F := by
+  classical
+  have hCTS : KwHgfV352CompletionTraceSum K F (RatFunc K) :=
+    KwF4R1V386a.kwF4R1V386a_completionTraceSum_of_isSeparable (K := K) (F := F) (E := RatFunc K)
+  exact residueTheoremK_of_fiberKaehlerCotraceResidueIdentity_ratFunc_isAlgClosed hgen
+    (kw_es_fiberKaehlerCotraceResidueIdentity_of_RTCC_CTS hRTCC hCTS)
+
+theorem kw_es_residueTheoremK_of_RTCC_isAlgClosed'
+    [HasPrincipalDivisors K F] [Algebra.IsSeparable (RatFunc K) F]
+    [Nontrivial Ω[(RatFunc K)⁄K]] [∀ v : Place K (RatFunc K), v.DCoordGenerates]
+    (hRTCC : KwF4R1V391aResidueTraceCompletionCommute K F (RatFunc K)) :
+    ResidueTheoremK K F := by
+  classical
+  exact
+    kw_es_residueTheoremK_of_RTCC_isAlgClosed
+      (kaehlerPullback_eq_kaehlerCotrace (K := K) (F := F) (E := RatFunc K) (dX K) ▸
+        kaehlerCotrace_dX_ne_zero_of_isSeparable K F (RationalFunctionField.placeInfty K))
+      hRTCC
+
+end Compose
+end AlgebraicCurve
+end
+section S18AliasSR
+open scoped ModularCurve in
+theorem ModularCurve.KwTateRR3.kwTateRR3_RTCC_of_isSeparable
+    {K F E : Type*} [Field K] [Field F] [Algebra K F]
+    [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+    [Algebra.IsIntegral E F]
+    [∀ u : AlgebraicCurve.Place K E, u.FiniteResidue]
+    [AlgebraicCurve.IsCurveOver K F] [AlgebraicCurve.IsCurveOver K E] [PerfectField K]
+    [Nontrivial Ω[F⁄K]] [∀ w : AlgebraicCurve.Place K F, w.DCoordGenerates]
+    [Algebra.IsSeparable E F] :
+    ModularCurve.KwF4R1V391a.KwF4R1V391aResidueTraceCompletionCommute K F E :=
+  AlgebraicCurve.residueTraceCompletionCommute
+end S18AliasSR
+section
+
+open LinearMap Submodule
+open ModularCurve.KwF4gRRTate
+
+noncomputable section
+
+namespace ModularCurve
+namespace KwTateRR3
+
+section RTKCapstone
+
+variable {K F : Type*} [Field K] [IsAlgClosed K]
+variable [Field F] [Algebra K F]
+variable [HasCanonicalDivisor (K := K) (F := F)] [∀ w : Place K F, w.DCoordGenerates]
+variable [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+variable [Algebra.IsIntegral (RatFunc K) F] [Module.Finite (RatFunc K) F]
+variable [HasLocalResidue K F]
+variable [∀ w : Place K F, w.FiniteResidue]
+variable [Nontrivial Ω[F⁄K]]
+variable [IsCurveOver K F]
+variable [∀ u : Place K (RatFunc K), u.FiniteResidue]
+
+theorem kwTateRR3_residueTheoremK_of_isAlgClosed
+    [Algebra.IsSeparable (RatFunc K) F]
+    [Nontrivial Ω[(RatFunc K)⁄K]] [∀ v : Place K (RatFunc K), v.DCoordGenerates] :
+    ResidueTheoremK K F := by
+  classical
+  exact
+    kw_es_residueTheoremK_of_RTCC_isAlgClosed'
+      (kwTateRR3_RTCC_of_isSeparable (E := RatFunc K))
+
+end RTKCapstone
+end KwTateRR3
+end ModularCurve
+end
+end
+theorem solution
+    {K F : Type*} [Field K] [IsAlgClosed K]
+    [Field F] [Algebra K F]
+    [AlgebraicCurve.HasCanonicalDivisor (K := K) (F := F)]
+    [∀ w : AlgebraicCurve.Place K F, w.DCoordGenerates]
+    [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [Algebra.IsIntegral (RatFunc K) F] [Module.Finite (RatFunc K) F]
+    [AlgebraicCurve.HasLocalResidue K F]
+    [∀ w : AlgebraicCurve.Place K F, w.FiniteResidue]
+    [Nontrivial Ω[F⁄K]]
+    [AlgebraicCurve.IsCurveOver K F] [AlgebraicCurve.IsCurveOver K (RatFunc K)]
+    [∀ u : AlgebraicCurve.Place K (RatFunc K), u.FiniteResidue]
+    [AlgebraicCurve.HasCanonicalLocalResidueKStar K F]
+    [Algebra.IsSeparable (RatFunc K) F]
+    [Nontrivial Ω[(RatFunc K)⁄K]] [∀ v : AlgebraicCurve.Place K (RatFunc K), v.DCoordGenerates] :
+    AlgebraicCurve.ResidueTheoremK K F := by
+  classical
+  exact
+    ModularCurve.KwTateRR3.kwTateRR3_residueTheoremK_of_isAlgClosed
+
+end
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.residueTheoremK_of_isAlgClosed
+    {K F : Type*} [Field K] [IsAlgClosed K]
+    [Field F] [Algebra K F]
+    [AlgebraicCurve.HasCanonicalDivisor (K := K) (F := F)]
+    [∀ w : AlgebraicCurve.Place K F, w.DCoordGenerates]
+    [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [Algebra.IsIntegral (RatFunc K) F] [Module.Finite (RatFunc K) F]
+    [AlgebraicCurve.HasLocalResidue K F]
+    [∀ w : AlgebraicCurve.Place K F, w.FiniteResidue]
+    [Nontrivial Ω[F⁄K]]
+    [AlgebraicCurve.IsCurveOver K F] [AlgebraicCurve.IsCurveOver K (RatFunc K)]
+    [∀ u : AlgebraicCurve.Place K (RatFunc K), u.FiniteResidue]
+    [AlgebraicCurve.HasCanonicalLocalResidueKStar K F]
+    [Algebra.IsSeparable (RatFunc K) F]
+    [Nontrivial Ω[(RatFunc K)⁄K]] [∀ v : AlgebraicCurve.Place K (RatFunc K), v.DCoordGenerates] :
+    AlgebraicCurve.ResidueTheoremK K F := by
+  classical
+  exact
+    solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_residueTheoremK_ratFunc_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_residueTheoremK_ratFunc_of_isAlgClosed.lean
new file mode 100644
index 0000000000..c32ece3f59
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_residueTheoremK_ratFunc_of_isAlgClosed.lean
@@ -0,0 +1,5761 @@
+/-
+Based on Prove2Me node AlgebraicCurve.residueTheoremK_ratFunc_of_isAlgClosed
+(74e12376-4ca7-54f2-9fc3-7fcedc86b3f2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7ccd254a-780d-5a1a-a743-8b3c63a9deae
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_LocalResidue
+
+import Mathlib.Algebra.BigOperators.Field
+import Mathlib.Algebra.GroupWithZero.Submonoid.CancelMulZero
+import Mathlib.Algebra.Polynomial.PartialFractions
+import Mathlib.Analysis.Normed.Ring.Lemmas
+import Mathlib.FieldTheory.Galois.Abelian
+import Mathlib.NumberTheory.RatFunc.Ostrowski
+import Mathlib.RingTheory.AdicCompletion.Completeness
+import Mathlib.RingTheory.Artinian.Instances
+import Mathlib.RingTheory.Norm.Transitivity
+import Mathlib.RingTheory.PicardGroup
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_CanonicalLocalResidueInstanceV2
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Definitions.Defs_AlgebraicCurve_residueTheorem_sharedLibrary
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty_X
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_placeInfty
+
+/-!
+# Residue theorem for K(x), K algebraically closed
+
+Theorem statement: `AlgebraicCurve.residueTheoremK_ratFunc_of_isAlgClosed`
+(`74e12376-4ca7-54f2-9fc3-7fcedc86b3f2`), by Claude, 2026-09-05.
+
+Proof: submission `7ccd254a-780d-5a1a-a743-8b3c63a9deae`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field, and take $F = \mathrm{RatFunc}\,K$ to be the rational
+function field over $K$, equipped with decidable equality. Here a place $v$ of $F/K$ is a valuation
+subring of $F$ containing the image of $K$, different from $F$ itself, and a principal ideal ring.
+Assume: a chosen family, one for each place $v$, of canonical local residue data at $v$, i.e. local
+residue data whose functional satisfies $\mathrm{res}\,(\pi_v^{n+1})^{-1} = 0$ for all $n \ge 1$,
+$\pi_v$ the uniformizer of $v$; that every nonzero $\omega \in \Omega_{F/K}$ admits a finitely
+supported divisor $D$ on places with $D(v) = v.\mathrm{ordDifferential}\,\omega$, the valuation at
+$v$ of the differential coefficient of $\omega$, at every $v$; and that at each place $v$ the single
+differential $d\pi_v$ spans $\Omega_{F/K}$ over $F$. The conclusion is the proposition
+$\mathrm{ResidueTheoremK}\,K\,(\mathrm{RatFunc}\,K)$: for every family $R = (\mathrm{res}_v)_v$ of
+canonical local residue data at all places (not merely the chosen one), assuming moreover that every
+nonzero element of $F$ has a degree-zero divisor recording its valuations, and for every nonzero
+$\omega \in \Omega_{F/K}$ and every $f \in F$, the Weil functional
+$\mathrm{weilOfKaehlerK}\,R\,\omega$ on the adele space, given by the (finitely supported) sum over
+places of the local residue terms of $\omega$, annihilates the adele obtained by embedding $f$
+diagonally.
+
+This is the residue theorem on $\mathbb{P}^1$, the genus-zero case of the global residue relation
+underlying Tate's treatment of Riemann–Roch and of duality for curves. It is used as the base case
+from which the residue theorem for a general function field over an algebraically closed field,
+[`AlgebraicCurve.residueTheoremK_of_isAlgClosed`]
+(thm.html#AlgebraicCurve.residueTheoremK_of_isAlgClosed),
+is deduced.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_residueTheoremK_ratFunc_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+open AlgebraicCurve Place RationalFunctionField IntermediateField
+  algebraAdjoinAdjoin IsDedekindDomain IsLocalRing KaehlerDifferential
+  Module Polynomial WithZero ModularCurve
+
+section privateSection
+
+
+noncomputable section
+
+namespace FLT
+namespace EulerDualBasis
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+  [FiniteDimensional K L] [Algebra.IsSeparable K L]
+
+omit [FiniteDimensional K L] [Algebra.IsSeparable K L] in
+theorem coeff_minpolyDiv_dim_sub_one (pb : PowerBasis K L) :
+    (minpolyDiv K pb.gen).coeff (pb.dim - 1) = 1 := by
+  have h1 : (minpolyDiv K pb.gen).natDegree = pb.dim - 1 := by
+    rw [natDegree_minpolyDiv, pb.natDegree_minpoly]
+  rw [← h1]
+  exact (minpolyDiv_monic pb.isIntegral_gen).coeff_natDegree
+
+theorem traceDual_eq_one_div_of_val_eq (pb : PowerBasis K L) {j : Fin pb.dim}
+    (hj : (j : ℕ) = pb.dim - 1) :
+    pb.basis.traceDual j = 1 / aeval pb.gen (derivative (minpoly K pb.gen)) := by
+  rw [Module.Basis.traceDual_powerBasis_eq]
+  rw [hj, coeff_minpolyDiv_dim_sub_one]
+
+theorem trace_pow_div_aeval_derivative_minpoly_of_lt (pb : PowerBasis K L) {k : ℕ}
+    (hk : k < pb.dim - 1) :
+    Algebra.trace K L
+      (pb.gen ^ k / aeval pb.gen (derivative (minpoly K pb.gen))) = 0 := by
+  have hd : 0 < pb.dim := by omega
+  have hk' : k < pb.dim := by omega
+  have hlt : pb.dim - 1 < pb.dim := by omega
+  have key := pb.basis.trace_mul_traceDual ⟨k, hk'⟩ ⟨pb.dim - 1, hlt⟩
+  rw [traceDual_eq_one_div_of_val_eq pb rfl, pb.basis_eq_pow, mul_one_div] at key
+  grind
+
+theorem trace_pow_div_aeval_derivative_minpoly_self (pb : PowerBasis K L)
+    (hd : 0 < pb.dim) :
+    Algebra.trace K L
+      (pb.gen ^ (pb.dim - 1) / aeval pb.gen (derivative (minpoly K pb.gen))) = 1 := by
+  have hlt : pb.dim - 1 < pb.dim := by omega
+  have key := pb.basis.trace_mul_traceDual ⟨pb.dim - 1, hlt⟩ ⟨pb.dim - 1, hlt⟩
+  rw [traceDual_eq_one_div_of_val_eq pb rfl, pb.basis_eq_pow, mul_one_div] at key
+  grind
+
+variable {F : Type*} [Field F] [CharZero F] {g : F[X]} [Fact (Irreducible g)]
+
+theorem trace_root_pow_div_derivative_of_lt (hg : g.Monic) {k : ℕ}
+    (hk : k < g.natDegree - 1) :
+    Algebra.trace F (AdjoinRoot g)
+      (AdjoinRoot.root g ^ k / aeval (AdjoinRoot.root g) (derivative g)) = 0 := by
+  have : FiniteDimensional F (AdjoinRoot g) :=
+    Module.Finite.of_basis (AdjoinRoot.powerBasis hg.ne_zero).basis
+  have hmin : minpoly F (AdjoinRoot.powerBasis hg.ne_zero).gen = g :=
+    AdjoinRoot.minpoly_powerBasis_gen_of_monic hg
+  have h := trace_pow_div_aeval_derivative_minpoly_of_lt
+    (AdjoinRoot.powerBasis hg.ne_zero) (k := k)
+    (by rwa [AdjoinRoot.powerBasis_dim])
+  rwa [hmin, AdjoinRoot.powerBasis_gen] at h
+
+theorem trace_root_pow_div_derivative_self (hg : g.Monic) (hd : 0 < g.natDegree) :
+    Algebra.trace F (AdjoinRoot g)
+      (AdjoinRoot.root g ^ (g.natDegree - 1) /
+        aeval (AdjoinRoot.root g) (derivative g)) = 1 := by
+  have : FiniteDimensional F (AdjoinRoot g) :=
+    Module.Finite.of_basis (AdjoinRoot.powerBasis hg.ne_zero).basis
+  have hmin : minpoly F (AdjoinRoot.powerBasis hg.ne_zero).gen = g :=
+    AdjoinRoot.minpoly_powerBasis_gen_of_monic hg
+  have h := trace_pow_div_aeval_derivative_minpoly_self
+    (AdjoinRoot.powerBasis hg.ne_zero)
+    (by rwa [AdjoinRoot.powerBasis_dim])
+  rwa [hmin, AdjoinRoot.powerBasis_gen, AdjoinRoot.powerBasis_dim] at h
+
+end EulerDualBasis
+end FLT
+
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+namespace RationalFunctionField
+
+variable (K : Type*) [Field K]
+
+theorem ord_finitePlace_ne_zero_iff {p : K[X]} (hp : Irreducible p) {q : K[X]} (hq : q ≠ 0) :
+    (finitePlace K hp).ord (algebraMap K[X] (RatFunc K) q) ≠ 0 ↔ p ∣ q := by
+  rw [finitePlace, Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) _ hq,
+    heightOneSpectrumOfIrreducible_asIdeal, Ideal.mem_span_singleton]
+
+end RationalFunctionField
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+  [∀ v : Place K F, v.DCoordGenerates]
+
+theorem exists_smul_eq_of_ne_zero (v : Place K F) {ω ω₀ : Ω[F⁄K]}
+    (hω : ω ≠ 0) (hω₀ : ω₀ ≠ 0) : ∃ g : F, g ≠ 0 ∧ ω = g • ω₀ := by
+  set a := v.differentialCoeff ω with ha
+  set b := v.differentialCoeff ω₀ with hb
+  have h0 : b ≠ 0 := v.differentialCoeff_ne_zero hω₀
+  refine ⟨a * b⁻¹, mul_ne_zero (v.differentialCoeff_ne_zero hω) (inv_ne_zero h0), ?_⟩
+  have hω₀eq : ω₀ = b • v.dCoord := hb ▸ (v.differentialCoeff_smul_dCoord ω₀).symm
+  rw [hω₀eq, smul_smul, mul_assoc, inv_mul_cancel₀ h0, mul_one]
+  exact ha ▸ (v.differentialCoeff_smul_dCoord ω).symm
+
+end AlgebraicCurve
+end
+section
+
+namespace AlgebraicCurve
+
+namespace Place
+
+section Transport
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private noncomputable def uniformizerSubring' : v.toValuationSubring :=
+  (IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose
+
+private scoped instance instSMulCommClass_subring : SMulCommClass K v.toValuationSubring F :=
+  IsScalarTower.to_smulCommClass
+
+private theorem kaehlerMap_subring_D_uniformizer :
+    KaehlerDifferential.map K K v.toValuationSubring F
+      (KaehlerDifferential.D K v.toValuationSubring v.uniformizerSubring') = v.dCoord := by
+  rw [KaehlerDifferential.map_D K K v.toValuationSubring F]
+  rfl
+
+end Transport
+end Place
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def ValSubringKaehlerSpanTop : Prop :=
+  ∀ v : Place K F,
+    Submodule.span v.toValuationSubring
+      {KaehlerDifferential.D K v.toValuationSubring (Place.uniformizerSubring' v)} = ⊤
+
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable [HasCanonicalLocalResidueKStar K F] [HasCanonicalDivisor (K := K) (F := F)]
+variable [∀ v : Place K F, v.DCoordGenerates] [Nontrivial Ω[F⁄K]]
+variable [HasPrincipalDivisors K F]
+
+variable (K F) in
+def principalAdele : F →ₗ[K] adeleSpace K F where
+  toFun f := ⟨diagonalHom K F f, diagonal_mem_adeleSpace f⟩
+  map_add' f g := Subtype.ext ((diagonalHom K F).map_add f g)
+  map_smul' c f := Subtype.ext ((diagonalHom K F).map_smul c f)
+
+section P1NamedRows
+
+variable (K)
+variable [HasCanonicalLocalResidueKStar K (RatFunc K)]
+    [HasCanonicalDivisor (K := K) (F := RatFunc K)]
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+variable [HasPrincipalDivisors K (RatFunc K)]
+
+def P1PolynomialGenerators : Set (RatFunc K) := Set.range fun n : ℕ => RatFunc.X ^ n
+
+def P1PrincipalPartGenerators : Set (RatFunc K) :=
+  {f | ∃ (p c : K[X]) (m : ℕ), p.Monic ∧ Irreducible p ∧ c.degree < p.degree ∧ 1 ≤ m ∧
+    f = algebraMap K[X] (RatFunc K) c / (algebraMap K[X] (RatFunc K) p) ^ m}
+
+def P1PartialFractionGenerators : Set (RatFunc K) :=
+  P1PolynomialGenerators K ∪ P1PrincipalPartGenerators K
+
+end P1NamedRows
+section P1Gates
+
+theorem gate_algebraMap_polynomial_mem_span_P1PolynomialGenerators (q : K[X]) :
+    algebraMap K[X] (RatFunc K) q ∈ Submodule.span K (P1PolynomialGenerators K) := by
+  rw [← Polynomial.sum_C_mul_X_pow_eq q, Polynomial.sum, map_sum]
+  refine Submodule.sum_mem _ fun i _ => ?_
+  rw [map_mul, map_pow, RatFunc.algebraMap_C, RatFunc.algebraMap_X,
+    ← RatFunc.smul_eq_C_mul]
+  exact Submodule.smul_mem _ _ (Submodule.subset_span ⟨i, rfl⟩)
+
+end P1Gates
+end AlgebraicCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable (v : Place K F)
+
+theorem mk_mem_maximalIdeal_iff {f : F} (hf : f ∈ v.toValuationSubring) :
+    (⟨f, hf⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring
+      ↔ f = 0 ∨ 0 < v.ord f := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  constructor
+  · intro hu
+    rcases eq_or_ne f 0 with rfl | hf0
+    · exact Or.inl rfl
+    · refine Or.inr ?_
+      rcases lt_or_eq_of_le (v.ord_nonneg_of_mem hf) with h | h
+      · exact h
+      · exfalso
+        apply hu
+        rw [← v.adicValuation_coe_eq_one_iff ⟨f, hf⟩]
+        change v.adicValuation f = 1
+        rw [v.adicValuation_eq_exp_neg_ord hf0, ← h, _root_.neg_zero, WithZero.exp_zero]
+  · intro h hu
+    have hne : f ≠ 0 := fun h0 => hu.ne_zero (Subtype.ext h0)
+    have h0 : v.ord f = 0 := by
+      obtain ⟨u, hu'⟩ := hu
+      have hcoe : f = ((u : v.toValuationSubring) : F) := by rw [hu']
+      rw [hcoe]; exact v.ord_coe_unit u
+    rcases h with rfl | hpos
+    · exact hne rfl
+    · omega
+
+end Place
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace ModularCurve
+
+namespace MilneAvAg9bRd14CubeRowCartierSliceStart
+
+private theorem
+  ag9b14c_res_uniformizer_zpow_eq_zero_of_ne_neg_one
+    {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) (R : v.CanonicalLocalResidueDataK)
+    {j : ℤ} (hj : j ≠ -1) :
+    R.res (v.uniformizer ^ j) = 0 := by
+  by_cases h0 : 0 ≤ j
+  · refine R.res_of_mem _ (v.mem_of_ord_nonneg (zpow_ne_zero j v.uniformizer_ne_zero) ?_)
+    rw [v.ord_zpow, v.ord_uniformizer, mul_one]
+    exact h0
+  · have hn1 : 1 ≤ (-j - 1).toNat := by omega
+    have hjn : j = -(((-j - 1).toNat + 1 : ℕ) : ℤ) := by omega
+    rw [hjn, _root_.zpow_neg, zpow_natCast]
+    exact R.res_higherPoleMonomial _ hn1
+
+end MilneAvAg9bRd14CubeRowCartierSliceStart
+
+open MilneAvAg9bRd14CubeRowCartierSliceStart
+
+end ModularCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable [HasCanonicalLocalResidueKStar K F] [HasCanonicalDivisor (K := K) (F := F)]
+variable [∀ v : Place K F, v.DCoordGenerates] [Nontrivial Ω[F⁄K]]
+variable [HasPrincipalDivisors K F]
+
+section RatFuncIntegrality
+
+variable (K)
+variable [DecidableEq (RatFunc K)]
+
+theorem algebraMap_polynomial_mem_of_ne_placeInfty'
+    {v : Place K (RatFunc K)} (hv : v ≠ placeInfty K) (q : K[X]) :
+    algebraMap K[X] (RatFunc K) q ∈ v.toValuationSubring := by
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+  · exact algebraMap_mem_ofHeightOneSpectrum K w q
+  · exact absurd rfl hv
+
+theorem pow_X_mem_of_ne_placeInfty
+    {v : Place K (RatFunc K)} (hv : v ≠ placeInfty K) (n : ℕ) :
+    (RatFunc.X : RatFunc K) ^ n ∈ v.toValuationSubring := by
+  have h : algebraMap K[X] (RatFunc K) (Polynomial.X ^ n) ∈ v.toValuationSubring :=
+    algebraMap_polynomial_mem_of_ne_placeInfty' K hv (Polynomial.X ^ n)
+  rwa [map_pow, RatFunc.algebraMap_X] at h
+
+theorem pow_X_mul_mem_of_ne_placeInfty
+    {v : Place K (RatFunc K)} (hv : v ≠ placeInfty K) (n : ℕ)
+    {g : RatFunc K} (hg : g ∈ v.toValuationSubring) :
+    (RatFunc.X : RatFunc K) ^ n * g ∈ v.toValuationSubring :=
+  mul_mem (pow_X_mem_of_ne_placeInfty K hv n) hg
+
+end RatFuncIntegrality
+section P1PolynomialSubrows
+
+variable (K)
+variable [DecidableEq (RatFunc K)]
+variable [HasCanonicalLocalResidueKStar K (RatFunc K)]
+    [HasCanonicalDivisor (K := K) (F := RatFunc K)]
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+variable [HasPrincipalDivisors K (RatFunc K)]
+
+def P1DifferentialCoeffRegularFinite {ω₀ : Ω[(RatFunc K)⁄K]} (_hω₀ : ω₀ ≠ 0) : Prop :=
+  ∀ v : Place K (RatFunc K), v ≠ placeInfty K →
+    v.differentialCoeff ω₀ ∈ v.toValuationSubring
+
+end P1PolynomialSubrows
+section P1PrincipalPartSubrows
+
+variable (K)
+variable [DecidableEq (RatFunc K)]
+variable [HasCanonicalLocalResidueKStar K (RatFunc K)]
+    [HasCanonicalDivisor (K := K) (F := RatFunc K)]
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+variable [HasPrincipalDivisors K (RatFunc K)]
+
+abbrev p1PrincipalPartAtom (p c : K[X]) (m : ℕ) : RatFunc K :=
+  algebraMap K[X] (RatFunc K) c / (algebraMap K[X] (RatFunc K) p) ^ m
+
+variable {K}
+
+omit [HasCanonicalLocalResidueKStar K (RatFunc K)] [HasCanonicalDivisor (K := K) (F := RatFunc K)]
+  [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+  [HasPrincipalDivisors K (RatFunc K)] in
+theorem finitePlace_ne_placeInfty {p : K[X]} (hp : Irreducible p) :
+    finitePlace K hp ≠ placeInfty K :=
+  fun h => placeInfty_ne_ofHeightOneSpectrum K _ h.symm
+
+end P1PrincipalPartSubrows
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+namespace RationalFunctionField
+
+variable (K : Type*) [Field K]
+
+theorem exists_ord_finitePlace_eq_nsmul {p : K[X]} (hp : Irreducible p) {q : K[X]}
+    (hq : q ≠ 0) :
+    ∃ m : ℕ, (finitePlace K hp).ord (algebraMap K[X] (RatFunc K) q)
+      = m * (finitePlace K hp).ord (algebraMap K[X] (RatFunc K) p) := by
+  obtain ⟨m, b, hb, rfl⟩ := WfDvdMonoid.max_power_factor hq hp
+  have hinj := IsFractionRing.injective K[X] (RatFunc K)
+  have hp0 : p ≠ 0 := hp.ne_zero
+  have hb0 : b ≠ 0 := by
+    rintro rfl
+    exact hq (mul_zero _)
+  have hordb : (finitePlace K hp).ord (algebraMap K[X] (RatFunc K) b) = 0 := by
+    by_contra hcon
+    exact hb ((ord_finitePlace_ne_zero_iff K hp hb0).mp hcon)
+  refine ⟨m, ?_⟩
+  rw [map_mul, map_pow,
+    (finitePlace K hp).ord_mul (pow_ne_zero _ ((map_ne_zero_iff _ hinj).mpr hp0))
+      ((map_ne_zero_iff _ hinj).mpr hb0),
+    hordb, add_zero, ← zpow_natCast, (finitePlace K hp).ord_zpow]
+
+theorem ord_finitePlace_dvd {p : K[X]} (hp : Irreducible p) {f : RatFunc K} (hf : f ≠ 0) :
+    (finitePlace K hp).ord (algebraMap K[X] (RatFunc K) p) ∣ (finitePlace K hp).ord f := by
+  have hinj := IsFractionRing.injective K[X] (RatFunc K)
+  obtain ⟨a, ha⟩ := exists_ord_finitePlace_eq_nsmul K hp (RatFunc.num_ne_zero hf)
+  obtain ⟨b, hb⟩ := exists_ord_finitePlace_eq_nsmul K hp f.denom_ne_zero
+  have hnum' : algebraMap K[X] (RatFunc K) f.num ≠ 0 :=
+    (map_ne_zero_iff _ hinj).mpr (RatFunc.num_ne_zero hf)
+  have hden' : algebraMap K[X] (RatFunc K) f.denom ≠ 0 :=
+    (map_ne_zero_iff _ hinj).mpr f.denom_ne_zero
+  rw [show f = algebraMap K[X] (RatFunc K) f.num * (algebraMap K[X] (RatFunc K) f.denom)⁻¹ by
+      rw [← div_eq_mul_inv, f.num_div_denom],
+    (finitePlace K hp).ord_mul hnum' (inv_ne_zero hden'), (finitePlace K hp).ord_inv, ha, hb]
+  exact ⟨(a : ℤ) - b, by ring⟩
+
+theorem ord_finitePlace_self {p : K[X]} (hp : Irreducible p) :
+    (finitePlace K hp).ord (algebraMap K[X] (RatFunc K) p) = 1 := by
+  have hnonneg : 0 ≤ (finitePlace K hp).ord (algebraMap K[X] (RatFunc K) p) :=
+    (finitePlace K hp).ord_nonneg_of_mem (algebraMap_mem_ofHeightOneSpectrum K _ p)
+  obtain ⟨π, hπ⟩ :=
+    IsDiscreteValuationRing.exists_irreducible (finitePlace K hp).toValuationSubring
+  have hπ0 : (π : RatFunc K) ≠ 0 := by
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have hdvd : (finitePlace K hp).ord (algebraMap K[X] (RatFunc K) p) ∣ 1 :=
+    (finitePlace K hp).ord_coe_irreducible hπ ▸ ord_finitePlace_dvd K hp hπ0
+  rcases Int.isUnit_iff.mp (isUnit_of_dvd_one hdvd) with h | h
+  · exact h
+  · omega
+
+section PlaceInfty
+
+variable [DecidableEq (RatFunc K)]
+
+theorem ord_placeInfty_algebraMap' {q : K[X]} (hq : q ≠ 0) :
+    (placeInfty K).ord (algebraMap K[X] (RatFunc K) q) = -(q.natDegree : ℤ) := by
+  have hq' : algebraMap K[X] (RatFunc K) q ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hq
+  rw [ord_placeInfty_eq_intDegree_mul K hq', ord_placeInfty_X, RatFunc.intDegree_polynomial]
+  ring
+
+end PlaceInfty
+end RationalFunctionField
+end AlgebraicCurve
+end
+section
+
+namespace AlgebraicCurve
+
+namespace Place
+
+section CotangentEngine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private noncomputable def uniformizerSubring'' : v.toValuationSubring :=
+  (IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose
+
+@[reducible] private noncomputable def polynomialAlgebra :
+    Algebra K[X] v.toValuationSubring :=
+  (Polynomial.aeval (R := K) v.uniformizerSubring'').toRingHom.toAlgebra
+
+private theorem polynomialAlgebra_algebraMap_X :
+    letI := v.polynomialAlgebra
+    algebraMap K[X] v.toValuationSubring X = v.uniformizerSubring'' :=
+  aeval_X _
+
+private lemma polynomialIsScalarTower :
+    letI := v.polynomialAlgebra
+    IsScalarTower K K[X] v.toValuationSubring := by
+  let := v.polynomialAlgebra
+  refine IsScalarTower.of_algebraMap_eq fun a => ?_
+  change _ = aeval v.uniformizerSubring'' (algebraMap K K[X] a)
+  simp [Polynomial.algebraMap_eq, aeval_C]
+
+private theorem range_mapBaseChange_le_span_D_uniformizer :
+    letI := v.polynomialAlgebra
+    letI := v.polynomialIsScalarTower
+    LinearMap.range (KaehlerDifferential.mapBaseChange K K[X] v.toValuationSubring)
+      ≤ Submodule.span v.toValuationSubring
+          {KaehlerDifferential.D K v.toValuationSubring v.uniformizerSubring''} := by
+  let := v.polynomialAlgebra
+  let := v.polynomialIsScalarTower
+  rintro _ ⟨t, rfl⟩
+  induction t with
+  | add x y hx hy => rw [map_add]; exact add_mem hx hy
+  | tmul b ω =>
+    rw [KaehlerDifferential.mapBaseChange_tmul,
+      show ω = (KaehlerDifferential.polynomialEquiv K ω) • (KaehlerDifferential.D K K[X] X) from
+        ((KaehlerDifferential.polynomialEquiv K).symm_apply_apply ω).symm.trans
+          (KaehlerDifferential.polynomialEquiv_symm K _),
+      LinearMap.map_smul, KaehlerDifferential.map_D,
+      show algebraMap K[X] v.toValuationSubring X = v.uniformizerSubring'' from aeval_X _,
+      ← algebraMap_smul (A := v.toValuationSubring)]
+    exact Submodule.smul_mem _ b
+      (Submodule.smul_mem _ _ (Submodule.mem_span_singleton_self _))
+
+private theorem range_mapBaseChange_eq_top_of_subsingleton
+    (hsub :
+      letI := v.polynomialAlgebra
+      Subsingleton Ω[v.toValuationSubring⁄K[X]]) :
+    letI := v.polynomialAlgebra
+    letI := v.polynomialIsScalarTower
+    LinearMap.range (KaehlerDifferential.mapBaseChange K K[X] v.toValuationSubring) = ⊤ := by
+  let := v.polynomialAlgebra
+  let := v.polynomialIsScalarTower
+  rw [KaehlerDifferential.range_mapBaseChange]
+  exact LinearMap.ker_eq_top.mpr (Subsingleton.elim _ _)
+
+private theorem span_D_uniformizer_eq_top_of_subsingleton
+    (hsub :
+      letI := v.polynomialAlgebra
+      Subsingleton Ω[v.toValuationSubring⁄K[X]]) :
+    Submodule.span v.toValuationSubring
+      {KaehlerDifferential.D K v.toValuationSubring v.uniformizerSubring''} = ⊤ := by
+  refine top_le_iff.mp ?_
+  rw [← v.range_mapBaseChange_eq_top_of_subsingleton hsub]
+  exact v.range_mapBaseChange_le_span_D_uniformizer
+
+end CotangentEngine
+end Place
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def ValSubringPolynomialFormallyUnramified : Prop :=
+  ∀ v : Place K F,
+    letI := v.polynomialAlgebra
+    Subsingleton Ω[v.toValuationSubring⁄K[X]]
+
+variable {K F}
+
+theorem valSubringKaehlerSpanTop_of_polynomialFormallyUnramified
+    (hfu : ValSubringPolynomialFormallyUnramified K F) :
+    ValSubringKaehlerSpanTop K F :=
+  fun v => v.span_D_uniformizer_eq_top_of_subsingleton (hfu v)
+
+end AlgebraicCurve
+end
+noncomputable section
+
+open UniqueFactorizationMonoid
+
+namespace AlgebraicCurve
+
+variable {K : Type*} [Field K]
+
+theorem exists_monic_irreducible_factorization {d : K[X]} (hd : d.Monic) :
+    ∃ (s : Finset K[X]) (n : K[X] → ℕ),
+      (∀ p ∈ s, p.Monic) ∧ (∀ p ∈ s, Irreducible p) ∧
+      (Set.Pairwise (s : Set K[X]) fun i j => IsCoprime i j) ∧
+      d = ∏ p ∈ s, p ^ n p := by
+  classical
+  refine ⟨(normalizedFactors d).toFinset,
+    fun p => (normalizedFactors d).count p, ?_, ?_, ?_, ?_⟩
+  · intro p hp
+    exact ((Polynomial.mem_normalizedFactors_iff hd.ne_zero).mp
+      (Multiset.mem_toFinset.mp hp)).2.1
+  · intro p hp
+    exact irreducible_of_normalized_factor p (Multiset.mem_toFinset.mp hp)
+  · intro p hp q hq hne
+    have hp' := Multiset.mem_toFinset.mp hp
+    have hq' := Multiset.mem_toFinset.mp hq
+    rw [(irreducible_of_normalized_factor p hp').coprime_iff_not_dvd]
+    exact fun hdvd => hne (normalizedFactors_eq_of_dvd d p hp' q hq' hdvd)
+  · calc d = (normalizedFactors d).prod := by
+            rw [prod_normalizedFactors_eq hd.ne_zero, hd.normalize_eq_self]
+      _ = ∏ p ∈ (normalizedFactors d).toFinset, p ^ (normalizedFactors d).count p :=
+            Finset.prod_multiset_count _
+
+theorem algebraMap_mem_span_P1PartialFractionGenerators (q : K[X]) :
+    algebraMap K[X] (RatFunc K) q ∈ Submodule.span K (P1PartialFractionGenerators K) :=
+  Submodule.span_mono Set.subset_union_left
+    (gate_algebraMap_polynomial_mem_span_P1PolynomialGenerators q)
+
+theorem div_pow_mem_span_P1PartialFractionGenerators
+    {p c : K[X]} (hpmon : p.Monic) (hpirr : Irreducible p)
+    (hdeg : c.degree < p.degree) {m : ℕ} (hm : 1 ≤ m) :
+    algebraMap K[X] (RatFunc K) c / (algebraMap K[X] (RatFunc K) p) ^ m
+      ∈ Submodule.span K (P1PartialFractionGenerators K) := by
+  exact Submodule.subset_span (Or.inr ⟨p, c, m, hpmon, hpirr, hdeg, hm, rfl⟩)
+
+theorem ratFunc_mem_span_P1PartialFractionGenerators (f : RatFunc K) :
+    f ∈ Submodule.span K (P1PartialFractionGenerators K) := by
+  classical
+  have hdenmon : f.denom.Monic := RatFunc.monic_denom f
+  obtain ⟨s, n, hmon, hirr, hcop, hdfac⟩ :=
+    exists_monic_irreducible_factorization hdenmon
+  have hginv : ∀ p ∈ s,
+      (algebraMap K[X] (RatFunc K) p)⁻¹ * algebraMap K[X] (RatFunc K) p = 1 :=
+    fun p hp => inv_mul_cancel₀ (RatFunc.algebraMap_ne_zero (hmon p hp).ne_zero)
+  obtain ⟨q, r, hr, hpfrac⟩ :=
+    Polynomial.mul_prod_pow_inverse_eq_quo_add_sum_rem_mul_pow_inverse
+      (K := RatFunc K) f.num hmon hcop n hginv
+  have hLHS : algebraMap K[X] (RatFunc K) f.num *
+      ∏ p ∈ s, ((algebraMap K[X] (RatFunc K) p)⁻¹) ^ n p = f := by
+    have hprod : ∏ p ∈ s, ((algebraMap K[X] (RatFunc K) p)⁻¹) ^ n p
+        = (algebraMap K[X] (RatFunc K) f.denom)⁻¹ := by
+      rw [hdfac, map_prod]
+      rw [← Finset.prod_inv_distrib]
+      exact Finset.prod_congr rfl fun p _ => by rw [map_pow, inv_pow]
+    rw [hprod, ← div_eq_mul_inv, RatFunc.num_div_denom]
+  rw [← hLHS, hpfrac]
+  refine Submodule.add_mem _ (algebraMap_mem_span_P1PartialFractionGenerators q) ?_
+  refine Submodule.sum_mem _ fun p hp => ?_
+  refine Submodule.sum_mem _ fun j _ => ?_
+  rw [inv_pow, ← div_eq_mul_inv]
+  exact div_pow_mem_span_P1PartialFractionGenerators (hmon p hp) (hirr p hp)
+    (hr p hp j) j.succ_pos
+
+theorem p1PartialFractionSpan_eq_top :
+    Submodule.span K (P1PartialFractionGenerators K) = ⊤ :=
+  Submodule.eq_top_iff'.mpr ratFunc_mem_span_P1PartialFractionGenerators
+
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem gate_localResidueData_uniformizer_inv (v : Place K F) (R : v.LocalResidueData) :
+    R.res v.uniformizer⁻¹ = 1 := by
+  rw [v.localResidueData_res_eq_simplePoleResidueAux R
+      (gate_uniformizer_inv_mem_simplePoleSubmodule v).1,
+    Place.simplePoleResidueAux_apply]
+  have h1 :
+      (⟨v.uniformizer * v.uniformizer⁻¹,
+        (gate_uniformizer_inv_mem_simplePoleSubmodule v).1⟩ : v.toValuationSubring) = 1 :=
+    Subtype.ext (mul_inv_cancel₀ v.uniformizer_ne_zero)
+  rw [h1, map_one]
+
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable (K : Type*) [Field K]
+
+section OrdIntegrand
+
+
+theorem p1PrincipalPartAtom_ne_zero {p : K[X]} (hp : p ≠ 0) {c : K[X]} (hc : c ≠ 0)
+    (m : ℕ) : p1PrincipalPartAtom K p c m ≠ 0 := by
+  simp only [p1PrincipalPartAtom, ne_eq, div_eq_zero_iff, not_or]
+  exact ⟨(map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hc,
+    pow_ne_zero _ ((map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hp)⟩
+
+end OrdIntegrand
+end AlgebraicCurve
+end
+section
+
+open scoped TensorProduct
+
+namespace AlgebraicCurve
+
+namespace Place
+
+section ResidueEngine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private noncomputable def uniformizerSubring''' :
+    v.toValuationSubring :=
+  (IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose
+
+private theorem irreducible_uniformizerSubring''' :
+    Irreducible v.uniformizerSubring''' :=
+  (IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose_spec
+
+private theorem maximalIdeal_eq_span_uniformizer :
+    IsLocalRing.maximalIdeal v.toValuationSubring = Ideal.span {v.uniformizerSubring'''} :=
+  (IsDiscreteValuationRing.irreducible_iff_uniformizer _).mp v.irreducible_uniformizerSubring'''
+
+private theorem D_polynomialAlgebra_uniformizer :
+    letI := v.polynomialAlgebra
+    KaehlerDifferential.D K[X] v.toValuationSubring v.uniformizerSubring''' = 0 := by
+  let := v.polynomialAlgebra
+  rw [show v.uniformizerSubring''' = algebraMap K[X] v.toValuationSubring X from
+    (v.polynomialAlgebra_algebraMap_X).symm]
+  exact (KaehlerDifferential.D K[X] v.toValuationSubring).map_algebraMap X
+
+private theorem ker_algebraMap_residueField_eq_span :
+    RingHom.ker (algebraMap v.toValuationSubring v.ResidueField)
+      = Ideal.span {v.uniformizerSubring'''} := by
+  rw [IsLocalRing.ResidueField.algebraMap_eq, IsLocalRing.ker_residue,
+    v.maximalIdeal_eq_span_uniformizer]
+
+private theorem
+  formallyUnramified_polynomial_residueField_of_isSeparable
+    [Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring)] :
+    letI := v.polynomialAlgebra
+    Algebra.FormallyUnramified K[X] (IsLocalRing.ResidueField v.toValuationSubring) := by
+  let := v.polynomialAlgebra
+  let := v.polynomialIsScalarTower
+  have : Algebra.FormallyUnramified K (IsLocalRing.ResidueField v.toValuationSubring) :=
+    Algebra.FormallyUnramified.of_isSeparable K _
+  exact Algebra.FormallyUnramified.of_restrictScalars K K[X] _
+
+private theorem subsingleton_residueKaehler_of_isSeparable
+    [Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring)] :
+    letI := v.polynomialAlgebra
+    Subsingleton Ω[(IsLocalRing.ResidueField v.toValuationSubring)⁄K[X]] := by
+  let := v.polynomialAlgebra
+  have := v.formallyUnramified_polynomial_residueField_of_isSeparable
+  exact Algebra.FormallyUnramified.subsingleton_kaehlerDifferential
+
+private theorem
+  subsingleton_residueTensor_polynomialKaehler_of_isSeparable
+    [Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring)] :
+    letI := v.polynomialAlgebra
+    Subsingleton (v.ResidueField ⊗[v.toValuationSubring] Ω[v.toValuationSubring⁄K[X]]) := by
+  let := v.polynomialAlgebra
+  let := v.polynomialIsScalarTower
+  have := v.subsingleton_residueKaehler_of_isSeparable
+  refine subsingleton_of_forall_eq 0 fun t => ?_
+  obtain ⟨c, rfl⟩ :=
+    ((KaehlerDifferential.exact_kerCotangentToTensor_mapBaseChange K[X]
+      v.toValuationSubring v.ResidueField
+      Ideal.Quotient.mk_surjective) t).mp (Subsingleton.elim _ _)
+  obtain ⟨⟨x, hx⟩, rfl⟩ := Ideal.toCotangent_surjective _ c
+  simp only [KaehlerDifferential.kerCotangentToTensor_toCotangent]
+  rw [v.ker_algebraMap_residueField_eq_span] at hx
+  induction hx using Submodule.span_induction with
+  | mem y hy =>
+    rcases hy with rfl
+    rw [v.D_polynomialAlgebra_uniformizer, TensorProduct.tmul_zero]
+  | zero => simp
+  | add y z _ _ hy hz =>
+    rw [map_add, TensorProduct.tmul_add, hy, hz, add_zero]
+  | smul a y hy IH =>
+    have hres : (algebraMap v.toValuationSubring v.ResidueField y) = 0 := by
+      rw [IsLocalRing.ResidueField.algebraMap_eq, IsLocalRing.residue_eq_zero_iff,
+        v.maximalIdeal_eq_span_uniformizer]
+      exact hy
+    rw [smul_eq_mul, Derivation.leibniz, TensorProduct.tmul_add,
+      TensorProduct.tmul_smul, IH, smul_zero, zero_add,
+      ← TensorProduct.smul_tmul, ← Algebra.algebraMap_eq_smul_one, hres,
+      TensorProduct.zero_tmul]
+
+private theorem finite_polynomialKaehler_of_finite_kaehler
+    [Module.Finite v.toValuationSubring Ω[v.toValuationSubring⁄K]] :
+    letI := v.polynomialAlgebra
+    Module.Finite v.toValuationSubring Ω[v.toValuationSubring⁄K[X]] := by
+  let := v.polynomialAlgebra
+  let := v.polynomialIsScalarTower
+  exact Module.Finite.of_surjective
+    (KaehlerDifferential.map K K[X] v.toValuationSubring v.toValuationSubring)
+    (KaehlerDifferential.map_surjective K K[X] v.toValuationSubring)
+
+private theorem subsingleton_polynomialKaehler_of_isSeparable_of_finite
+    [Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring)]
+    [Module.Finite v.toValuationSubring Ω[v.toValuationSubring⁄K]] :
+    letI := v.polynomialAlgebra
+    Subsingleton Ω[v.toValuationSubring⁄K[X]] := by
+  let := v.polynomialAlgebra
+  have := v.finite_polynomialKaehler_of_finite_kaehler
+  have := v.subsingleton_residueTensor_polynomialKaehler_of_isSeparable
+  exact (IsLocalRing.subsingleton_tensorProduct (R := v.toValuationSubring)).mp ‹_›
+
+private theorem isSeparable_residueField_of_charZero_of_finiteResidue
+    [CharZero K] [v.FiniteResidue] :
+    Algebra.IsSeparable K (IsLocalRing.ResidueField v.toValuationSubring) := by
+  have : Module.Finite K (IsLocalRing.ResidueField v.toValuationSubring) :=
+    Place.FiniteResidue.finite
+  have : Algebra.IsAlgebraic K (IsLocalRing.ResidueField v.toValuationSubring) :=
+    Algebra.IsAlgebraic.of_finite K _
+  exact Algebra.IsAlgebraic.isSeparable_of_perfectField
+
+private theorem subsingleton_polynomialKaehler_of_charZero_of_finite
+    [CharZero K] [v.FiniteResidue]
+    [Module.Finite v.toValuationSubring Ω[v.toValuationSubring⁄K]] :
+    letI := v.polynomialAlgebra
+    Subsingleton Ω[v.toValuationSubring⁄K[X]] := by
+  have := v.isSeparable_residueField_of_charZero_of_finiteResidue
+  exact v.subsingleton_polynomialKaehler_of_isSeparable_of_finite
+
+end ResidueEngine
+end Place
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def ValSubringKaehlerFinite : Prop :=
+  ∀ v : Place K F, Module.Finite v.toValuationSubring Ω[v.toValuationSubring⁄K]
+
+variable {K F}
+
+theorem valSubringPolynomialFormallyUnramified_of_kaehlerFinite_of_charZero
+    [CharZero K] [∀ v : Place K F, v.FiniteResidue]
+    (hfin : ValSubringKaehlerFinite K F) :
+    ValSubringPolynomialFormallyUnramified K F := by
+  intro v
+  have := hfin v
+  exact v.subsingleton_polynomialKaehler_of_charZero_of_finite
+
+theorem valSubringKaehlerSpanTop_of_kaehlerFinite_of_charZero
+    [CharZero K] [∀ v : Place K F, v.FiniteResidue]
+    (hfin : ValSubringKaehlerFinite K F) :
+    ValSubringKaehlerSpanTop K F :=
+  valSubringKaehlerSpanTop_of_polynomialFormallyUnramified
+    (valSubringPolynomialFormallyUnramified_of_kaehlerFinite_of_charZero hfin)
+
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem gate_canonicalLocalResidueDataK_uniformizer_inv (v : Place K F)
+    (R : v.CanonicalLocalResidueDataK) : R.res v.uniformizer⁻¹ = 1 :=
+  gate_localResidueData_uniformizer_inv v R.toLocalResidueData
+
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace ModularCurve
+
+namespace MilneAvAg9bRd15UnitNormalFormLaurentSeed
+
+private theorem
+  ag9b15u_eq_zero_or_one_le_ord_of_residue_eq_zero
+    {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+    {g : F} (hg : g ∈ v.toValuationSubring)
+    (h0 : IsLocalRing.residue _ (⟨g, hg⟩ : v.toValuationSubring) = 0) :
+    g = 0 ∨ 1 ≤ v.ord g := by
+  rcases eq_or_ne g 0 with rfl | hg0
+  · exact Or.inl rfl
+  right
+  have hnn : 0 ≤ v.ord g := v.ord_nonneg_of_mem hg
+  rcases eq_or_ne (v.ord g) 0 with hz | hnz
+  · exfalso
+    have hmemi : g⁻¹ ∈ v.toValuationSubring := by
+      refine v.mem_of_ord_nonneg (inv_ne_zero hg0) ?_
+      rw [v.ord_inv, hz, _root_.neg_zero]
+    rw [IsLocalRing.residue_eq_zero_iff, IsLocalRing.mem_maximalIdeal,
+      mem_nonunits_iff] at h0
+    exact h0 ⟨⟨⟨g, hg⟩, ⟨g⁻¹, hmemi⟩, Subtype.ext (mul_inv_cancel₀ hg0),
+      Subtype.ext (inv_mul_cancel₀ hg0)⟩, rfl⟩
+  · omega
+
+private theorem
+  ag9b15u_exists_unit_normal_form_of_surj
+    {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+    (hsurj : Function.Surjective (algebraMap K v.ResidueField))
+    {w : F} (hw0 : w ≠ 0) (hw : v.ord w = 0) :
+    ∃ (c : K) (s : F), c ≠ 0 ∧ (s = 0 ∨ 1 ≤ v.ord s) ∧
+      w = algebraMap K F c * (1 + s) := by
+  have hwmem : w ∈ v.toValuationSubring := v.mem_of_ord_nonneg hw0 hw.ge
+  have hwinv : w⁻¹ ∈ v.toValuationSubring := by
+    refine v.mem_of_ord_nonneg (inv_ne_zero hw0) ?_
+    rw [v.ord_inv, hw, _root_.neg_zero]
+  have hres0 : IsLocalRing.residue _ (⟨w, hwmem⟩ : v.toValuationSubring) ≠ 0 := by
+    intro h0
+    rw [IsLocalRing.residue_eq_zero_iff, IsLocalRing.mem_maximalIdeal,
+      mem_nonunits_iff] at h0
+    exact h0 ⟨⟨⟨w, hwmem⟩, ⟨w⁻¹, hwinv⟩, Subtype.ext (mul_inv_cancel₀ hw0),
+      Subtype.ext (inv_mul_cancel₀ hw0)⟩, rfl⟩
+  obtain ⟨c, hc⟩ := hsurj (IsLocalRing.residue _ (⟨w, hwmem⟩ : v.toValuationSubring))
+  have hc0 : c ≠ 0 := by
+    rintro rfl
+    rw [_root_.map_zero] at hc
+    exact hres0 hc.symm
+  have ha0 : algebraMap K F c ≠ 0 :=
+    fun h => hc0 ((algebraMap K F).injective (h.trans (_root_.map_zero _).symm))
+  refine ⟨c, w * (algebraMap K F c)⁻¹ - 1, hc0, ?_, ?_⟩
+  · have hainv : (algebraMap K F c)⁻¹ ∈ v.toValuationSubring := by
+      rw [← map_inv₀]
+      exact v.algebraMap_mem' c⁻¹
+    have hsmem : w * (algebraMap K F c)⁻¹ - 1 ∈ v.toValuationSubring :=
+      sub_mem (mul_mem hwmem hainv) (one_mem _)
+    refine ag9b15u_eq_zero_or_one_le_ord_of_residue_eq_zero v hsmem ?_
+    have hfact : (⟨w * (algebraMap K F c)⁻¹ - 1, hsmem⟩ : v.toValuationSubring)
+        = ⟨w, hwmem⟩ * ⟨(algebraMap K F c)⁻¹, hainv⟩ - 1 :=
+      Subtype.ext (by push_cast; ring)
+    have hainv_res : IsLocalRing.residue _
+        ((⟨(algebraMap K F c)⁻¹, hainv⟩ : v.toValuationSubring))
+        = (IsLocalRing.residue _ (⟨w, hwmem⟩ : v.toValuationSubring))⁻¹ := by
+      have h1 : (⟨(algebraMap K F c)⁻¹, hainv⟩ : v.toValuationSubring)
+          = algebraMap K v.toValuationSubring c⁻¹ :=
+        Subtype.ext (by rw [v.coe_algebraMap, map_inv₀])
+      rw [h1, ← IsLocalRing.ResidueField.algebraMap_eq,
+        ← IsScalarTower.algebraMap_apply K v.toValuationSubring v.ResidueField,
+        map_inv₀, hc, IsLocalRing.ResidueField.algebraMap_eq]
+    rw [hfact, map_sub, map_mul, map_one, hainv_res, mul_inv_cancel₀ hres0, sub_self]
+  · have hrw : (1 : F) + (w * (algebraMap K F c)⁻¹ - 1) = w * (algebraMap K F c)⁻¹ := by
+      ring
+    rw [hrw, mul_comm w (algebraMap K F c)⁻¹, ← mul_assoc,
+      mul_inv_cancel₀ ha0, one_mul]
+
+private theorem
+  ag9b15u_exists_K_truncation_of_mem_poleSubmodule
+    {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+    (hsurj : Function.Surjective (algebraMap K v.ResidueField))
+    (n : ℕ) {f : F} (hf : f ∈ v.poleSubmodule n) :
+    ∃ c : ℕ → K,
+      f - ∑ j ∈ Finset.range n, algebraMap K F (c j) * (v.uniformizer ^ (j + 1))⁻¹
+        ∈ v.toValuationSubring := by
+  induction n generalizing f with
+  | zero =>
+    refine ⟨0, ?_⟩
+    rw [Finset.range_zero, Finset.sum_empty, sub_zero]
+    rwa [← SetLike.mem_coe, v.coe_poleSubmodule_zero] at hf
+  | succ n ih =>
+    obtain ⟨ctop, hctop⟩ := hsurj (v.laurentTailCoeff (n + 1) ⟨f, hf⟩)
+    have hclift : IsLocalRing.residue _ (algebraMap K v.toValuationSubring ctop)
+        = v.laurentTailCoeff (n + 1) ⟨f, hf⟩ := by
+      rw [← hctop, IsScalarTower.algebraMap_apply K v.toValuationSubring v.ResidueField,
+        IsLocalRing.ResidueField.algebraMap_eq]
+    have hrem : f - algebraMap K F ctop * (v.uniformizer ^ (n + 1))⁻¹
+        ∈ v.poleSubmodule n := by
+      have h := v.laurentTail_remainder_mem_poleSubmodule hf hclift
+      rwa [v.coe_algebraMap] at h
+    obtain ⟨c', hc'⟩ := ih hrem
+    refine ⟨fun j => if j = n then ctop else c' j, ?_⟩
+    have hstep : ∑ j ∈ Finset.range (n + 1),
+        algebraMap K F (if j = n then ctop else c' j) * (v.uniformizer ^ (j + 1))⁻¹
+        = (∑ j ∈ Finset.range n, algebraMap K F (c' j) * (v.uniformizer ^ (j + 1))⁻¹)
+          + algebraMap K F ctop * (v.uniformizer ^ (n + 1))⁻¹ := by
+      rw [Finset.sum_range_succ, ite_eq_left rfl]
+      congr 1
+      refine Finset.sum_congr rfl fun j hj => ?_
+      rw [ite_eq_right (Finset.mem_range.mp hj).ne]
+    rw [hstep, show f - ((∑ j ∈ Finset.range n,
+          algebraMap K F (c' j) * (v.uniformizer ^ (j + 1))⁻¹)
+          + algebraMap K F ctop * (v.uniformizer ^ (n + 1))⁻¹)
+        = f - algebraMap K F ctop * (v.uniformizer ^ (n + 1))⁻¹
+          - ∑ j ∈ Finset.range n,
+              algebraMap K F (c' j) * (v.uniformizer ^ (j + 1))⁻¹ from by ring]
+    exact hc'
+
+private theorem
+  ag9b15u_differentialCoeff_D_unit_mul_uniformizer
+    {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) [v.DCoordGenerates] [Nontrivial Ω[F⁄K]] (w : F) :
+    v.differentialCoeff (KaehlerDifferential.D K F (w * v.uniformizer))
+      = w + v.uniformizer * v.differentialCoeff (KaehlerDifferential.D K F w) := by
+  refine v.differentialCoeff_unique ?_
+  calc KaehlerDifferential.D K F (w * v.uniformizer)
+      = w • KaehlerDifferential.D K F v.uniformizer
+        + v.uniformizer • KaehlerDifferential.D K F w := by
+        rw [Derivation.leibniz]
+    _ = w • v.dCoord + v.uniformizer •
+          (v.differentialCoeff (KaehlerDifferential.D K F w) • v.dCoord) := by
+        rw [show KaehlerDifferential.D K F v.uniformizer = v.dCoord from rfl,
+          v.differentialCoeff_smul_dCoord]
+    _ = (w + v.uniformizer * v.differentialCoeff (KaehlerDifferential.D K F w))
+          • v.dCoord := by
+        rw [smul_smul, add_smul]
+
+end MilneAvAg9bRd15UnitNormalFormLaurentSeed
+end ModularCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable (K : Type*) [Field K]
+
+variable {K}
+
+section PerPlace
+
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+variable {w : HeightOneSpectrum K[X]}
+
+local notation "v" => Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w
+
+theorem differentialCoeff_dX_mem_ofHeightOneSpectrum {p : K[X]}
+    (hp : Irreducible p) (hwp : w.asIdeal = Ideal.span {p}) (hsep : p.Separable) :
+    (v).differentialCoeff (dX K) ∈ (v).toValuationSubring :=
+  (v).mem_of_ord_nonneg ((v).differentialCoeff_ne_zero (dX_ne_zero K))
+    (ord_differentialCoeff_dX_ofHeightOneSpectrum hp hwp hsep).ge
+
+end PerPlace
+section Discharge
+
+variable (K)
+variable [CharZero K] [DecidableEq (RatFunc K)]
+variable
+    [HasCanonicalDivisor (K := K) (F := RatFunc K)]
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+omit [HasCanonicalDivisor (K := K) (F := RatFunc K)]
+  in
+theorem p1DifferentialCoeffRegularFinite_dX :
+    P1DifferentialCoeffRegularFinite K (dX_ne_zero K) := by
+  intro v hvinf
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+  · obtain ⟨p, hp, hwp⟩ := exists_irreducible_span K w
+    exact differentialCoeff_dX_mem_ofHeightOneSpectrum hp hwp hp.separable
+  · exact absurd rfl hvinf
+
+end Discharge
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable {K : Type*} [Field K] [DecidableEq (RatFunc K)]
+
+variable (K)
+
+omit [DecidableEq (RatFunc K)] in
+theorem ord_ofHeightOneSpectrum_irreducible_eq_zero_of_ne
+    (w : HeightOneSpectrum K[X]) {p : K[X]} (hp : Irreducible p)
+    (hne : w ≠ heightOneSpectrumOfIrreducible K hp) :
+    (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord
+      (algebraMap K[X] (RatFunc K) p) = 0 := by
+  by_contra hord
+  refine hne (HeightOneSpectrum.ext ?_)
+  have hmem : p ∈ w.asIdeal :=
+    (Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w hp.ne_zero).mp hord
+  exact ((PrincipalIdealRing.isMaximal_of_irreducible hp).eq_of_le
+    (w.isPrime.isMaximal w.ne_bot).ne_top
+    ((Ideal.span_singleton_le_iff_mem w.asIdeal).mpr hmem)).symm
+
+theorem ord_algebraMap_irreducible_eq_zero_of_ne
+    {p : K[X]} (hp : Irreducible p) {v : Place K (RatFunc K)}
+    (hvp : v ≠ finitePlace K hp) (hvinf : v ≠ placeInfty K) :
+    v.ord (algebraMap K[X] (RatFunc K) p) = 0 := by
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+  · refine ord_ofHeightOneSpectrum_irreducible_eq_zero_of_ne K w hp ?_
+    rintro rfl; exact hvp rfl
+  · exact absurd rfl hvinf
+
+theorem inv_algebraMap_pow_mem_of_ne_finitePlace
+    {p : K[X]} (hp : Irreducible p) {v : Place K (RatFunc K)}
+    (hvp : v ≠ finitePlace K hp) (hvinf : v ≠ placeInfty K) (m : ℕ) :
+    ((algebraMap K[X] (RatFunc K) p) ^ m)⁻¹ ∈ v.toValuationSubring := by
+  have hp0 : algebraMap K[X] (RatFunc K) p ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hp.ne_zero
+  refine v.mem_of_ord_nonneg (inv_ne_zero (pow_ne_zero m hp0)) ?_
+  rw [v.ord_inv, ← zpow_natCast, v.ord_zpow,
+    ord_algebraMap_irreducible_eq_zero_of_ne K hp hvp hvinf, mul_zero, _root_.neg_zero]
+
+theorem p1PrincipalPartAtom_mem_of_ne_finitePlace
+    {p : K[X]} (hp : Irreducible p) (c : K[X]) (m : ℕ) {v : Place K (RatFunc K)}
+    (hvp : v ≠ finitePlace K hp) (hvinf : v ≠ placeInfty K) :
+    p1PrincipalPartAtom K p c m ∈ v.toValuationSubring := by
+  unfold p1PrincipalPartAtom
+  rw [div_eq_mul_inv]
+  exact mul_mem (algebraMap_polynomial_mem_of_ne_placeInfty' K hvinf c)
+    (inv_algebraMap_pow_mem_of_ne_finitePlace K hp hvp hvinf m)
+
+theorem ord_placeInfty_p1PrincipalPartAtom
+    {p : K[X]} (hp : p ≠ 0) {c : K[X]} (hc : c ≠ 0) (m : ℕ) :
+    (placeInfty K).ord (p1PrincipalPartAtom K p c m)
+      = (m : ℤ) * p.natDegree - c.natDegree := by
+  have hinj := IsFractionRing.injective K[X] (RatFunc K)
+  have hp' : algebraMap K[X] (RatFunc K) p ≠ 0 := (map_ne_zero_iff _ hinj).mpr hp
+  have hc' : algebraMap K[X] (RatFunc K) c ≠ 0 := (map_ne_zero_iff _ hinj).mpr hc
+  unfold p1PrincipalPartAtom
+  rw [div_eq_mul_inv, (placeInfty K).ord_mul hc' (inv_ne_zero (pow_ne_zero m hp')),
+    (placeInfty K).ord_inv, ← zpow_natCast, (placeInfty K).ord_zpow,
+    ord_placeInfty_algebraMap' K hc, ord_placeInfty_algebraMap' K hp]
+  ring
+
+theorem one_le_ord_placeInfty_p1PrincipalPartAtom
+    {p : K[X]} (hp : Irreducible p) {c : K[X]} (hc : c ≠ 0) {m : ℕ}
+    (hdeg : c.degree < p.degree) (hm : 1 ≤ m) :
+    1 ≤ (placeInfty K).ord (p1PrincipalPartAtom K p c m) := by
+  rw [ord_placeInfty_p1PrincipalPartAtom K hp.ne_zero hc]
+  have hndeg : c.natDegree < p.natDegree :=
+    Polynomial.natDegree_lt_natDegree hc hdeg
+  have hpdeg : 1 ≤ (p.natDegree : ℤ) := by exact_mod_cast hp.natDegree_pos
+  have hm' : 1 ≤ (m : ℤ) := by exact_mod_cast hm
+  nlinarith
+
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+section SurjectivePlaceInfty
+
+variable (K) [DecidableEq (RatFunc K)]
+
+theorem surjective_algebraMap_residueField_placeInfty :
+    Function.Surjective (algebraMap K (placeInfty K).ResidueField) := by
+  intro z
+  obtain ⟨c, hc⟩ :=
+    (finrank_eq_one_iff_of_nonzero' (1 : (placeInfty K).ResidueField) one_ne_zero).mp
+      (show Module.finrank K (placeInfty K).ResidueField = 1 from deg_placeInfty K) z
+  exact ⟨c, by rw [Algebra.algebraMap_eq_smul_one]; exact hc⟩
+
+end SurjectivePlaceInfty
+section NamedRow
+
+variable (K F)
+variable [∀ v : Place K F, v.DCoordGenerates] [Nontrivial Ω[F⁄K]]
+
+def CanonicalLocalResidueKDifferentialCoordIndep : Prop :=
+  ∀ (v : Place K F) (π' : F), v.ord π' = 1 →
+    ∀ (R : v.CanonicalLocalResidueDataK) (n : ℕ), 1 ≤ n →
+      R.res (v.differentialCoeff (KaehlerDifferential.D K F π') * ((π') ^ (n + 1))⁻¹) = 0
+
+end NamedRow
+section XInvCoordinate
+
+variable (K) [DecidableEq (RatFunc K)]
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+omit [DecidableEq (RatFunc K)]
+  [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]] in
+theorem ratFuncX_inv_pow_inv (m : ℕ) :
+    (((RatFunc.X : RatFunc K)⁻¹) ^ m)⁻¹ = (RatFunc.X : RatFunc K) ^ m := by
+  rw [inv_pow, inv_inv]
+
+theorem X_pow_mul_differentialCoeff_D_X_eq_neg (n : ℕ) :
+    (RatFunc.X : RatFunc K) ^ n
+        * (placeInfty K).differentialCoeff (KaehlerDifferential.D K (RatFunc K) RatFunc.X)
+      = -((placeInfty K).differentialCoeff
+            (KaehlerDifferential.D K (RatFunc K) (RatFunc.X : RatFunc K)⁻¹)
+          * (((RatFunc.X : RatFunc K)⁻¹) ^ (n + 2))⁻¹) := by
+  rw [ratFuncX_inv_pow_inv, differentialCoeff_placeInfty_D_X_eq K]
+  ring
+
+end XInvCoordinate
+section Bridge
+
+variable (K) [DecidableEq (RatFunc K)]
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+theorem canonicalLocalResidueDataK_res_X_pow_mul_D_X_of_coordIndep
+    (hcoord : CanonicalLocalResidueKDifferentialCoordIndep K (RatFunc K))
+    (R : (placeInfty K).CanonicalLocalResidueDataK) (n : ℕ) :
+    R.res ((RatFunc.X : RatFunc K) ^ n
+        * (placeInfty K).differentialCoeff
+            (KaehlerDifferential.D K (RatFunc K) RatFunc.X)) = 0 := by
+  rw [X_pow_mul_differentialCoeff_D_X_eq_neg K n, _root_.map_neg, neg_eq_zero]
+  exact hcoord (placeInfty K) (RatFunc.X : RatFunc K)⁻¹ (ord_placeInfty_X_inv K) R (n + 1)
+    (by omega)
+
+theorem canonicalLocalResidueDataK_kaehlerResidueTerm_X_pow_of_coordIndep
+    (_hwd : OrdDifferentialWellDefined K (RatFunc K))
+    (hcoord : CanonicalLocalResidueKDifferentialCoordIndep K (RatFunc K))
+    (R : (placeInfty K).CanonicalLocalResidueDataK) (n : ℕ) :
+    Algebra.trace K (placeInfty K).ResidueField
+        (R.res (diagonalHom K (RatFunc K) ((RatFunc.X : RatFunc K) ^ n) (placeInfty K)
+          * (placeInfty K).differentialCoeff
+              (KaehlerDifferential.D K (RatFunc K) RatFunc.X))) = 0 := by
+  rw [diagonalHom_apply,
+    canonicalLocalResidueDataK_res_X_pow_mul_D_X_of_coordIndep K hcoord R n, _root_.map_zero]
+
+end Bridge
+end AlgebraicCurve
+end
+section
+
+namespace AlgebraicCurve
+
+namespace Place
+
+section EftEngine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem finite_kaehler_of_essFiniteType [Algebra.EssFiniteType K
+  v.toValuationSubring] :
+    Module.Finite v.toValuationSubring Ω[v.toValuationSubring⁄K] :=
+  KaehlerDifferential.finite K v.toValuationSubring
+
+end EftEngine
+end Place
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def ValSubringEssFiniteType : Prop :=
+  ∀ v : Place K F, Algebra.EssFiniteType K v.toValuationSubring
+
+variable {K F}
+
+theorem valSubringKaehlerFinite_of_essFiniteType
+    (heft : ValSubringEssFiniteType K F) :
+    ValSubringKaehlerFinite K F := fun v =>
+  haveI := heft v
+  v.finite_kaehler_of_essFiniteType
+
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+theorem ordDifferentialWellDefined_ratFunc (K : Type*) [Field K] [CharZero K] :
+    OrdDifferentialWellDefined K (RatFunc K) := by
+  classical
+  intro v π π' hπ hπ'
+  have hπ0 : π ≠ 0 := by
+    intro h
+    rw [h, v.ord_zero] at hπ
+    exact zero_ne_one hπ
+  have hπ'0 : π' ≠ 0 := by
+    intro h
+    rw [h, v.ord_zero] at hπ'
+    exact zero_ne_one hπ'
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+  · obtain ⟨p, hp, hwp⟩ := exists_irreducible_span K w
+    obtain ⟨h1ne, h1ord⟩ :=
+      ratFuncDXCoeff_ne_zero_and_ord_eq_zero_of_ord_eq_one hp hwp hp.separable hπ0 hπ
+    obtain ⟨h2ne, h2ord⟩ :=
+      ratFuncDXCoeff_ne_zero_and_ord_eq_zero_of_ord_eq_one hp hwp hp.separable hπ'0 hπ'
+    exact exists_ord_zero_smul_of_smul_dX_eq h1ne h2ne (h2ord.trans h1ord.symm)
+      (D_eq_ratFuncDXCoeff_smul_dX K π) (D_eq_ratFuncDXCoeff_smul_dX K π')
+  · obtain ⟨e, he0, heord, hDe⟩ := exists_dXCoeff_ord_two_of_ord_placeInfty_eq_one hπ0 hπ
+    obtain ⟨e', he'0, he'ord, hDe'⟩ := exists_dXCoeff_ord_two_of_ord_placeInfty_eq_one hπ'0 hπ'
+    exact exists_ord_zero_smul_of_smul_dX_eq he0 he'0 (he'ord.trans heord.symm) hDe hDe'
+
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable {K : Type*} [Field K] [DecidableEq (RatFunc K)]
+
+variable (K)
+
+theorem two_le_ord_placeInfty_p1PrincipalPartAtom
+    {p : K[X]} (hp : Irreducible p) {c : K[X]} (hc : c ≠ 0) {m : ℕ}
+    (hdeg : c.degree < p.degree) (hm : 2 ≤ m) :
+    2 ≤ (placeInfty K).ord (p1PrincipalPartAtom K p c m) := by
+  rw [ord_placeInfty_p1PrincipalPartAtom K hp.ne_zero hc]
+  have hndeg : c.natDegree < p.natDegree :=
+    Polynomial.natDegree_lt_natDegree hc hdeg
+  have hpdeg : 1 ≤ (p.natDegree : ℤ) := by exact_mod_cast hp.natDegree_pos
+  have hm' : 2 ≤ (m : ℤ) := by exact_mod_cast hm
+  nlinarith
+
+omit [DecidableEq (RatFunc K)] in
+theorem not_dvd_of_degree_lt {p c : K[X]} (hc : c ≠ 0)
+    (hdeg : c.degree < p.degree) : ¬ p ∣ c :=
+  fun hdvd => not_lt.mpr (Polynomial.degree_le_of_dvd hdvd hc) hdeg
+
+omit [DecidableEq (RatFunc K)] in
+theorem ord_finitePlace_of_degree_lt {p : K[X]} (hp : Irreducible p) {c : K[X]} (hc : c ≠ 0)
+    (hdeg : c.degree < p.degree) :
+    (finitePlace K hp).ord (algebraMap K[X] (RatFunc K) c) = 0 :=
+  not_ne_iff.mp fun h =>
+    not_dvd_of_degree_lt K hc hdeg ((ord_finitePlace_ne_zero_iff K hp hc).mp h)
+
+omit [DecidableEq (RatFunc K)] in
+theorem ord_finitePlace_p1PrincipalPartAtom {p : K[X]} (hp : Irreducible p)
+    {c : K[X]} (hc : c ≠ 0) (hdeg : c.degree < p.degree) (m : ℕ) :
+    (finitePlace K hp).ord (p1PrincipalPartAtom K p c m) = -(m : ℤ) := by
+  have hinj := IsFractionRing.injective K[X] (RatFunc K)
+  have hp' : algebraMap K[X] (RatFunc K) p ≠ 0 := (map_ne_zero_iff _ hinj).mpr hp.ne_zero
+  have hc' : algebraMap K[X] (RatFunc K) c ≠ 0 := (map_ne_zero_iff _ hinj).mpr hc
+  unfold p1PrincipalPartAtom
+  rw [div_eq_mul_inv, (finitePlace K hp).ord_mul hc' (inv_ne_zero (pow_ne_zero m hp')),
+    (finitePlace K hp).ord_inv, ← zpow_natCast, (finitePlace K hp).ord_zpow,
+    ord_finitePlace_of_degree_lt K hp hc hdeg, ord_finitePlace_self K hp]
+  ring
+
+section UnitFinite
+
+variable
+    [HasCanonicalDivisor (K := K) (F := RatFunc K)]
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates]
+
+variable {K}
+
+omit [HasCanonicalDivisor (K := K) (F := RatFunc K)]
+  in
+theorem p1DifferentialCoeffRegularFinite_of_unitFinite
+    {ω₀ : Ω[(RatFunc K)⁄K]} (hω₀ : ω₀ ≠ 0)
+    (hunit : P1DifferentialCoeffUnitFinite K hω₀) :
+    P1DifferentialCoeffRegularFinite K hω₀ :=
+  fun v hv => v.mem_of_ord_nonneg (v.differentialCoeff_ne_zero hω₀) (hunit v hv).ge
+
+end UnitFinite
+end AlgebraicCurve
+end
+section
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+
+section PCoordinateIdentity
+
+
+omit [DecidableEq (RatFunc K)]
+  in
+theorem derivative_monic_natDegree_one_eq_one {p : K[X]} (hpmon : p.Monic)
+    (hdeg : p.natDegree = 1) : derivative p = 1 := by
+  rw [hpmon.eq_X_add_C hdeg, derivative_add, derivative_X, derivative_C, add_zero]
+
+omit [DecidableEq (RatFunc K)]
+  in
+theorem D_algebraMap_polynomial_degOne {p : K[X]} (hpmon : p.Monic) (hdeg : p.natDegree = 1) :
+    KaehlerDifferential.D K (RatFunc K) (algebraMap K[X] (RatFunc K) p) = dX K := by
+  rw [D_algebraMap_polynomial K p, derivative_monic_natDegree_one_eq_one K hpmon hdeg, map_one,
+    one_smul]
+
+omit [DecidableEq (RatFunc K)]
+  in
+theorem eq_C_coeff_zero_of_degree_lt_degOne {p c : K[X]} (hpirr : Irreducible p)
+    (hdeg : p.natDegree = 1) (hcdeg : c.degree < p.degree) : c = C (c.coeff 0) := by
+  have hpdeg : p.degree = (1 : ℕ) := by
+    rw [degree_eq_natDegree hpirr.ne_zero, hdeg]
+  rw [hpdeg, Nat.cast_one] at hcdeg
+  exact eq_C_of_degree_le_zero (Nat.WithBot.lt_one_iff_le_zero.mp hcdeg)
+
+omit [DecidableEq (RatFunc K)]
+  in
+theorem p1PrincipalPartAtom_mul_differentialCoeff_dX_degOne
+    {p c : K[X]} (hpmon : p.Monic) (hpirr : Irreducible p) (hdeg : p.natDegree = 1)
+    (hcdeg : c.degree < p.degree) (m : ℕ) :
+    p1PrincipalPartAtom K p c m * (finitePlace K hpirr).differentialCoeff (dX K)
+      = c.coeff 0 • ((finitePlace K hpirr).differentialCoeff
+            (KaehlerDifferential.D K (RatFunc K) (algebraMap K[X] (RatFunc K) p))
+          * ((algebraMap K[X] (RatFunc K) p) ^ m)⁻¹) := by
+  have hc : algebraMap K[X] (RatFunc K) c = algebraMap K (RatFunc K) (c.coeff 0) := by
+    conv_lhs => rw [eq_C_coeff_zero_of_degree_lt_degOne K hpirr hdeg hcdeg]
+    rw [C_eq_algebraMap, ← IsScalarTower.algebraMap_apply K K[X] (RatFunc K)]
+  rw [D_algebraMap_polynomial_degOne K hpmon hdeg, Algebra.smul_def,
+    show p1PrincipalPartAtom K p c m
+      = algebraMap K[X] (RatFunc K) c / (algebraMap K[X] (RatFunc K) p) ^ m from rfl, hc]
+  ring
+
+end PCoordinateIdentity
+section NamedHigherDeg
+
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+def P1FinitePlaceCanonicalResidueAtomMGeTwoHigherDeg : Prop :=
+  ∀ (p c : K[X]) (m : ℕ) (_ : p.Monic) (hpirr : Irreducible p),
+    c.degree < p.degree → 2 ≤ m → 2 ≤ p.natDegree →
+    ∀ R : (finitePlace K hpirr).CanonicalLocalResidueDataK,
+      R.res (p1PrincipalPartAtom K p c m * (finitePlace K hpirr).differentialCoeff (dX K)) = 0
+
+end NamedHigherDeg
+section DegOneDischarge
+
+
+omit [DecidableEq (RatFunc K)]
+  in
+theorem p1FinitePlaceCanonicalResidueAtom_of_coordIndep_degOne
+    (hcoord : CanonicalLocalResidueKDifferentialCoordIndep K (RatFunc K))
+    {p c : K[X]} {m : ℕ} (hpmon : p.Monic) (hpirr : Irreducible p)
+    (hcdeg : c.degree < p.degree) (hm : 2 ≤ m) (hdeg : p.natDegree = 1)
+    (R : (finitePlace K hpirr).CanonicalLocalResidueDataK) :
+    R.res (p1PrincipalPartAtom K p c m * (finitePlace K hpirr).differentialCoeff (dX K)) = 0 := by
+  rw [p1PrincipalPartAtom_mul_differentialCoeff_dX_degOne K hpmon hpirr hdeg hcdeg m, map_smul,
+    show m = (m - 1) + 1 from (Nat.sub_add_cancel (by omega)).symm,
+    hcoord (finitePlace K hpirr) (algebraMap K[X] (RatFunc K) p) (ord_finitePlace_self K hpirr)
+      R (m - 1) (by omega),
+    smul_zero]
+
+end DegOneDischarge
+section AlgClosed
+
+variable [IsAlgClosed K]
+
+omit [DecidableEq (RatFunc K)]
+  in
+theorem p1FinitePlaceCanonicalResidueAtomMGeTwoHigherDeg_of_algClosed :
+    P1FinitePlaceCanonicalResidueAtomMGeTwoHigherDeg K := by
+  intro p c m _ hpirr _ _ hdeg
+  have h1 : p.natDegree = 1 := by
+    have h := IsAlgClosed.degree_eq_one_of_irreducible K hpirr
+    rw [degree_eq_natDegree hpirr.ne_zero] at h
+    exact_mod_cast h
+  omega
+
+end AlgClosed
+end AlgebraicCurve
+end
+section
+
+namespace ValuationSubring
+
+variable {F : Type*} [Field F]
+
+private theorem ofPrime_congr {R : ValuationSubring F} {P Q : Ideal R}
+    [P.IsPrime] [Q.IsPrime] (h : P = Q) : R.ofPrime P = R.ofPrime Q := by
+  subst h; congr
+
+theorem eq_top_of_idealOfLE_eq_bot {R S : ValuationSubring F} (h : R ≤ S)
+    (hbot : idealOfLE R S h = ⊥) : S = ⊤ := by
+  have : IsDomain R := Subring.instIsDomainSubtypeMem R.toSubring
+  rw [← ofPrime_idealOfLE R S h, ofPrime_congr hbot, ofPrime_bot]
+
+theorem idealOfLE_ne_bot_of_ne_top {R S : ValuationSubring F} (h : R ≤ S)
+    (hS : S ≠ ⊤) : idealOfLE R S h ≠ ⊥ :=
+  fun hbot => hS (eq_top_of_idealOfLE_eq_bot h hbot)
+
+theorem eq_of_isDiscreteValuationRing_of_le {R S : ValuationSubring F}
+    [IsDiscreteValuationRing R] (h : R ≤ S) (hS : S ≠ ⊤) : R = S := by
+  have : IsDomain R := Subring.instIsDomainSubtypeMem R.toSubring
+  have : IsDedekindDomain R := IsPrincipalIdealRing.isDedekindDomain R
+  have hne : idealOfLE R S h ≠ ⊥ := idealOfLE_ne_bot_of_ne_top h hS
+  have hmax : (idealOfLE R S h).IsMaximal := (prime_idealOfLE R S h).isMaximal hne
+  have heq : idealOfLE R S h = IsLocalRing.maximalIdeal R := IsLocalRing.eq_maximalIdeal hmax
+  rw [← ofPrime_idealOfLE R S h, ofPrime_congr heq, ofPrime_top]
+
+end ValuationSubring
+namespace AlgebraicCurve
+
+namespace Place
+
+section CenterIdeal
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+variable (A : Subalgebra K F) (hA : (A : Set F) ⊆ (v.toValuationSubring : Set F))
+
+@[reducible] private noncomputable def modelInclusion :
+    A →+* v.toValuationSubring :=
+  (Subring.inclusion (show A.toSubring ≤ v.toValuationSubring.toSubring from hA))
+
+@[scoped simp] theorem coe_modelInclusion (a : A) :
+    ((v.modelInclusion A hA a : v.toValuationSubring) : F) = (a : F) := rfl
+
+@[reducible] private noncomputable def modelAlgebra :
+    Algebra A v.toValuationSubring :=
+  (v.modelInclusion A hA).toAlgebra
+
+@[reducible] private noncomputable def centerIdeal : Ideal A :=
+  letI := v.modelAlgebra A hA
+  (IsLocalRing.maximalIdeal v.toValuationSubring).comap (algebraMap A v.toValuationSubring)
+
+scoped instance centerIdeal_isPrime : (v.centerIdeal A hA).IsPrime :=
+  letI := v.modelAlgebra A hA
+  Ideal.comap_isPrime _ _
+
+private theorem isUnit_modelInclusion_of_not_mem_centerIdeal {s : A}
+    (hs : s ∉ v.centerIdeal A hA) :
+    IsUnit (v.modelInclusion A hA s) := by
+  let := v.modelAlgebra A hA
+  rw [centerIdeal, Ideal.mem_comap, IsLocalRing.mem_maximalIdeal, mem_nonunits_iff,
+    not_not] at hs
+  exact hs
+
+private theorem isUnit_modelInclusion_of_mem_primeCompl (s :
+  (v.centerIdeal A hA).primeCompl) :
+    IsUnit (v.modelInclusion A hA (s : A)) :=
+  v.isUnit_modelInclusion_of_not_mem_centerIdeal A hA s.2
+
+private theorem modelAlgebra_isScalarTower :
+    letI := v.modelAlgebra A hA
+    IsScalarTower K A v.toValuationSubring := by
+  let := v.modelAlgebra A hA
+  refine IsScalarTower.of_algebraMap_eq fun c => ?_
+  apply Subtype.ext
+  simp only [coe_modelInclusion, RingHom.algebraMap_toAlgebra]
+  rfl
+
+private theorem essFiniteType_of_finiteType_isLocalization_centerIdeal
+    [Algebra.FiniteType K A]
+    (hloc : letI := v.modelAlgebra A hA
+            IsLocalization.AtPrime v.toValuationSubring (v.centerIdeal A hA)) :
+    Algebra.EssFiniteType K v.toValuationSubring := by
+  let := v.modelAlgebra A hA
+  have := v.modelAlgebra_isScalarTower A hA
+  have : Algebra.EssFiniteType A v.toValuationSubring :=
+    Algebra.EssFiniteType.of_isLocalization _ (v.centerIdeal A hA).primeCompl
+  exact Algebra.EssFiniteType.comp K A v.toValuationSubring
+
+end CenterIdeal
+end Place
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def ValSubringDedekindModel : Prop :=
+  ∀ v : Place K F,
+    ∃ (A : Subalgebra K F) (hA : (A : Set F) ⊆ (v.toValuationSubring : Set F)),
+      Algebra.FiniteType K A ∧
+      (letI := v.modelAlgebra A hA
+       IsLocalization.AtPrime v.toValuationSubring (v.centerIdeal A hA))
+
+variable {K F}
+
+theorem valSubringEssFiniteType_of_dedekindModel
+    (hmodel : ValSubringDedekindModel K F) :
+    ValSubringEssFiniteType K F := fun v => by
+  obtain ⟨A, hA, hft, hloc⟩ := hmodel v
+  exact v.essFiniteType_of_finiteType_isLocalization_centerIdeal A hA hloc
+
+theorem valSubringKaehlerFinite_of_dedekindModel
+    (hmodel : ValSubringDedekindModel K F) :
+    ValSubringKaehlerFinite K F :=
+  valSubringKaehlerFinite_of_essFiniteType
+    (valSubringEssFiniteType_of_dedekindModel hmodel)
+
+end AlgebraicCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+
+section UnitFinite
+
+variable [CharZero K]
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+theorem p1DifferentialCoeffUnitFinite_dX :
+    P1DifferentialCoeffUnitFinite K (dX_ne_zero K) := by
+  intro v hvinf
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+  · obtain ⟨p, hp, hwp⟩ := exists_irreducible_span K w
+    exact ord_differentialCoeff_dX_ofHeightOneSpectrum hp hwp hp.separable
+  · exact absurd rfl hvinf
+
+end UnitFinite
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] [HasCanonicalLocalResidueKStar K F]
+
+section MOneSimplePoleBounds
+
+variable (K)
+variable [DecidableEq (RatFunc K)]
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates]
+
+theorem ord_finitePlace_mOneAtom_mul_differentialCoeff
+    {ω₀ : Ω[(RatFunc K)⁄K]} (hω₀ : ω₀ ≠ 0)
+    (hunit : ∀ v : Place K (RatFunc K), v ≠ placeInfty K → v.ord (v.differentialCoeff ω₀) = 0)
+    {p : K[X]} (hp : Irreducible p) {c : K[X]} (hc : c ≠ 0)
+    (hdeg : c.degree < p.degree) :
+    (finitePlace K hp).ord
+        (p1PrincipalPartAtom K p c 1 * (finitePlace K hp).differentialCoeff ω₀) = -1 := by
+  have hatom0 : p1PrincipalPartAtom K p c 1 ≠ 0 := by
+    simp only [p1PrincipalPartAtom, ne_eq, div_eq_zero_iff, not_or]
+    exact ⟨(map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hc,
+      pow_ne_zero _ ((map_ne_zero_iff _
+        (IsFractionRing.injective K[X] (RatFunc K))).mpr hp.ne_zero)⟩
+  rw [(finitePlace K hp).ord_mul hatom0 ((finitePlace K hp).differentialCoeff_ne_zero hω₀),
+    ord_finitePlace_p1PrincipalPartAtom K hp hc hdeg 1,
+    hunit (finitePlace K hp) (finitePlace_ne_placeInfty hp)]
+  norm_num
+
+theorem ord_placeInfty_mOneAtom_mul_differentialCoeff_ge_neg_one
+    {ω₀ : Ω[(RatFunc K)⁄K]} (hω₀ : ω₀ ≠ 0)
+    (hInfty : (placeInfty K).ordDifferential ω₀ = -2)
+    {p : K[X]} (hp : Irreducible p) {c : K[X]} (hc : c ≠ 0)
+    (hdeg : c.degree < p.degree) :
+    -1 ≤ (placeInfty K).ord
+        (p1PrincipalPartAtom K p c 1 * (placeInfty K).differentialCoeff ω₀) := by
+  have hatom0 : p1PrincipalPartAtom K p c 1 ≠ 0 := by
+    simp only [p1PrincipalPartAtom, ne_eq, div_eq_zero_iff, not_or]
+    exact ⟨(map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hc,
+      pow_ne_zero _ ((map_ne_zero_iff _
+        (IsFractionRing.injective K[X] (RatFunc K))).mpr hp.ne_zero)⟩
+  rw [(placeInfty K).ord_mul hatom0 ((placeInfty K).differentialCoeff_ne_zero hω₀)]
+  have h1 : 1 ≤ (placeInfty K).ord (p1PrincipalPartAtom K p c 1) :=
+    one_le_ord_placeInfty_p1PrincipalPartAtom K hp hc hdeg le_rfl
+  have hordD : (placeInfty K).ord ((placeInfty K).differentialCoeff ω₀) = -2 := hInfty
+  omega
+
+theorem p1MOneAtom_mul_differentialCoeff_mem_simplePole_finitePlace
+    {ω₀ : Ω[(RatFunc K)⁄K]} (hω₀ : ω₀ ≠ 0)
+    (hunit : ∀ v : Place K (RatFunc K), v ≠ placeInfty K → v.ord (v.differentialCoeff ω₀) = 0)
+    {p : K[X]} (hp : Irreducible p) (c : K[X]) (hdeg : c.degree < p.degree) :
+    p1PrincipalPartAtom K p c 1 * (finitePlace K hp).differentialCoeff ω₀
+      ∈ (finitePlace K hp).simplePoleSubmodule := by
+  rcases eq_or_ne c 0 with rfl | hc
+  · change algebraMap K[X] (RatFunc K) 0 / (algebraMap K[X] (RatFunc K) p) ^ 1
+        * (finitePlace K hp).differentialCoeff ω₀ ∈ _
+    rw [_root_.map_zero, zero_div, zero_mul]; exact zero_mem _
+  · have hatom0 : p1PrincipalPartAtom K p c 1 ≠ 0 := by
+      simp only [p1PrincipalPartAtom, ne_eq, div_eq_zero_iff, not_or]
+      exact ⟨(map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hc,
+        pow_ne_zero _ ((map_ne_zero_iff _
+          (IsFractionRing.injective K[X] (RatFunc K))).mpr hp.ne_zero)⟩
+    rw [← (finitePlace K hp).poleSubmodule_one, Place.mem_poleSubmodule, pow_one]
+    refine (finitePlace K hp).mem_of_ord_nonneg
+      (mul_ne_zero (finitePlace K hp).uniformizer_ne_zero
+        (mul_ne_zero hatom0 ((finitePlace K hp).differentialCoeff_ne_zero hω₀))) ?_
+    rw [(finitePlace K hp).ord_mul (finitePlace K hp).uniformizer_ne_zero
+        (mul_ne_zero hatom0 ((finitePlace K hp).differentialCoeff_ne_zero hω₀)),
+      (finitePlace K hp).ord_uniformizer,
+      ord_finitePlace_mOneAtom_mul_differentialCoeff K hω₀ hunit hp hc hdeg]
+    omega
+
+theorem p1MOneAtom_mul_differentialCoeff_mem_simplePole_placeInfty
+    {ω₀ : Ω[(RatFunc K)⁄K]} (hω₀ : ω₀ ≠ 0)
+    (hInfty : (placeInfty K).ordDifferential ω₀ = -2)
+    {p : K[X]} (hp : Irreducible p) (c : K[X]) (hdeg : c.degree < p.degree) :
+    p1PrincipalPartAtom K p c 1 * (placeInfty K).differentialCoeff ω₀
+      ∈ (placeInfty K).simplePoleSubmodule := by
+  rcases eq_or_ne c 0 with rfl | hc
+  · change algebraMap K[X] (RatFunc K) 0 / (algebraMap K[X] (RatFunc K) p) ^ 1
+        * (placeInfty K).differentialCoeff ω₀ ∈ _
+    rw [_root_.map_zero, zero_div, zero_mul]; exact zero_mem _
+  · have hatom0 : p1PrincipalPartAtom K p c 1 ≠ 0 := by
+      simp only [p1PrincipalPartAtom, ne_eq, div_eq_zero_iff, not_or]
+      exact ⟨(map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hc,
+        pow_ne_zero _ ((map_ne_zero_iff _
+          (IsFractionRing.injective K[X] (RatFunc K))).mpr hp.ne_zero)⟩
+    rw [← (placeInfty K).poleSubmodule_one, Place.mem_poleSubmodule, pow_one]
+    refine (placeInfty K).mem_of_ord_nonneg
+      (mul_ne_zero (placeInfty K).uniformizer_ne_zero
+        (mul_ne_zero hatom0 ((placeInfty K).differentialCoeff_ne_zero hω₀))) ?_
+    rw [(placeInfty K).ord_mul (placeInfty K).uniformizer_ne_zero
+        (mul_ne_zero hatom0 ((placeInfty K).differentialCoeff_ne_zero hω₀)),
+      (placeInfty K).ord_uniformizer]
+    have h := ord_placeInfty_mOneAtom_mul_differentialCoeff_ge_neg_one K hω₀ hInfty hp hc hdeg
+    omega
+
+end MOneSimplePoleBounds
+section MOneSimplePoleRow
+
+variable (K)
+variable [DecidableEq (RatFunc K)]
+variable [HasLocalResidue K (RatFunc K)] [HasCanonicalLocalResidueKStar K (RatFunc K)]
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates]
+
+def P1PrincipalPartMOneSimplePoleCancel {ω₀ : Ω[(RatFunc K)⁄K]} (_hω₀ : ω₀ ≠ 0) : Prop :=
+  ∀ (p c : K[X]) (_ : p.Monic) (hpirr : Irreducible p), c.degree < p.degree →
+    ∀ (hfmem : p1PrincipalPartAtom K p c 1 * (finitePlace K hpirr).differentialCoeff ω₀
+        ∈ (finitePlace K hpirr).simplePoleSubmodule)
+      (himem : p1PrincipalPartAtom K p c 1 * (placeInfty K).differentialCoeff ω₀
+        ∈ (placeInfty K).simplePoleSubmodule),
+    Algebra.trace K (finitePlace K hpirr).ResidueField
+        ((finitePlace K hpirr).simplePoleResidueAux ⟨_, hfmem⟩)
+      + Algebra.trace K (placeInfty K).ResidueField
+          ((placeInfty K).simplePoleResidueAux ⟨_, himem⟩)
+      = 0
+
+end MOneSimplePoleRow
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+
+section TraceRow
+
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+def P1FinitePlaceCanonicalResidueAtomMGeTwoTrace : Prop :=
+  ∀ (p c : K[X]) (m : ℕ) (_ : p.Monic) (hpirr : Irreducible p), c.degree < p.degree → 2 ≤ m →
+    ∀ R : (finitePlace K hpirr).CanonicalLocalResidueDataK,
+      Algebra.trace K (finitePlace K hpirr).ResidueField
+          (R.res (p1PrincipalPartAtom K p c m
+            * (finitePlace K hpirr).differentialCoeff (dX K))) = 0
+
+def P1FinitePlaceCanonicalResidueAtomMGeTwoTraceHigherDeg : Prop :=
+  ∀ (p c : K[X]) (m : ℕ) (_ : p.Monic) (hpirr : Irreducible p),
+    c.degree < p.degree → 2 ≤ m → 2 ≤ p.natDegree →
+    ∀ R : (finitePlace K hpirr).CanonicalLocalResidueDataK,
+      Algebra.trace K (finitePlace K hpirr).ResidueField
+          (R.res (p1PrincipalPartAtom K p c m
+            * (finitePlace K hpirr).differentialCoeff (dX K))) = 0
+
+end TraceRow
+section Monotonicity
+
+
+omit [DecidableEq (RatFunc K)]
+  in
+theorem p1FinitePlaceCanonicalResidueAtomMGeTwoTraceHigherDeg_of_higherDeg
+    (h : P1FinitePlaceCanonicalResidueAtomMGeTwoHigherDeg K) :
+    P1FinitePlaceCanonicalResidueAtomMGeTwoTraceHigherDeg K :=
+  fun p c m hpmon hpirr hdeg hm hpdeg R => by
+    rw [h p c m hpmon hpirr hdeg hm hpdeg R, _root_.map_zero]
+
+end Monotonicity
+section DegOneDischarge
+
+
+omit [DecidableEq (RatFunc K)]
+  in
+theorem p1FinitePlaceCanonicalResidueAtomTrace_of_coordIndep_degOne
+    (hcoord : CanonicalLocalResidueKDifferentialCoordIndep K (RatFunc K))
+    {p c : K[X]} {m : ℕ} (hpmon : p.Monic) (hpirr : Irreducible p)
+    (hcdeg : c.degree < p.degree) (hm : 2 ≤ m) (hdeg : p.natDegree = 1)
+    (R : (finitePlace K hpirr).CanonicalLocalResidueDataK) :
+    Algebra.trace K (finitePlace K hpirr).ResidueField
+        (R.res (p1PrincipalPartAtom K p c m
+          * (finitePlace K hpirr).differentialCoeff (dX K))) = 0 := by
+  rw [p1FinitePlaceCanonicalResidueAtom_of_coordIndep_degOne K hcoord hpmon hpirr hcdeg hm
+    hdeg R, _root_.map_zero]
+
+omit [DecidableEq (RatFunc K)]
+  in
+theorem p1FinitePlaceCanonicalResidueAtomMGeTwoTrace_of_coordIndep_higherDeg
+    (hcoord : CanonicalLocalResidueKDifferentialCoordIndep K (RatFunc K))
+    (hHigh : P1FinitePlaceCanonicalResidueAtomMGeTwoTraceHigherDeg K) :
+    P1FinitePlaceCanonicalResidueAtomMGeTwoTrace K := by
+  intro p c m hpmon hpirr hcdeg hm R
+  have hpos := hpirr.natDegree_pos
+  rcases Nat.lt_or_ge p.natDegree 2 with hdeg | hdeg
+  · exact p1FinitePlaceCanonicalResidueAtomTrace_of_coordIndep_degOne K hcoord hpmon hpirr
+      hcdeg hm (by omega) R
+  · exact hHigh p c m hpmon hpirr hcdeg hm hdeg R
+
+end DegOneDischarge
+section AlgClosed
+
+variable [IsAlgClosed K]
+
+omit [DecidableEq (RatFunc K)]
+  in
+theorem p1FinitePlaceCanonicalResidueAtomMGeTwoTraceHigherDeg_of_algClosed :
+    P1FinitePlaceCanonicalResidueAtomMGeTwoTraceHigherDeg K :=
+  p1FinitePlaceCanonicalResidueAtomMGeTwoTraceHigherDeg_of_higherDeg K
+    (p1FinitePlaceCanonicalResidueAtomMGeTwoHigherDeg_of_algClosed K)
+
+end AlgClosed
+end AlgebraicCurve
+end
+section
+
+namespace AlgebraicCurve
+
+namespace Place
+
+section CenterNonzero
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+  (A : Subalgebra K F) (hA : (A : Set F) ⊆ (v.toValuationSubring : Set F))
+
+private theorem inv_mem_of_not_mem_centerIdeal {a : A} (ha : a ∉ v.centerIdeal A hA) :
+    ((a : F))⁻¹ ∈ v.toValuationSubring := by
+  obtain ⟨u, hu⟩ := v.isUnit_modelInclusion_of_not_mem_centerIdeal A hA ha
+  have huF : ((u : v.toValuationSubring) : F) = (a : F) :=
+    congrArg (Subtype.val : v.toValuationSubring → F) hu
+  have huinvF : ((u⁻¹ : v.toValuationSubringˣ).1 : F) * (a : F) = 1 := by
+    have h1 : ((u⁻¹ : v.toValuationSubringˣ).1 : F) * ((u : v.toValuationSubring) : F)
+        = ((1 : v.toValuationSubring) : F) :=
+      congrArg (Subtype.val : v.toValuationSubring → F) u.inv_mul
+    rw [huF] at h1; exact h1
+  have : ((u⁻¹ : v.toValuationSubringˣ).1 : F) = (a : F)⁻¹ :=
+    eq_inv_of_mul_eq_one_left huinvF
+  exact this ▸ ((u⁻¹ : v.toValuationSubringˣ).1 : v.toValuationSubring).2
+
+private theorem div_mem_of_not_mem_centerIdeal (r : A) {a : A}
+    (ha : a ∉ v.centerIdeal A hA) :
+    (r : F) / (a : F) ∈ v.toValuationSubring := by
+  rw [div_eq_mul_inv]
+  exact v.toValuationSubring.toSubring.mul_mem (hA r.2)
+    (inv_mem_of_not_mem_centerIdeal v A hA ha)
+
+private theorem centerIdeal_ne_bot_of_isFractionRing [IsFractionRing A
+  F] :
+    v.centerIdeal A hA ≠ ⊥ := by
+  obtain ⟨f, hf⟩ : ∃ f : F, f ∉ v.toValuationSubring := by
+    by_contra h; push Not at h
+    exact v.ne_top' (ValuationSubring.toSubring_injective (top_le_iff.mp fun x _ => h x))
+  obtain ⟨r, s, hs, hfrs⟩ := IsFractionRing.div_surjective (A := A) f
+  have hsP : s ∈ v.centerIdeal A hA := by
+    by_contra hsP
+    apply hf
+    have : algebraMap A F r / algebraMap A F s ∈ v.toValuationSubring :=
+      div_mem_of_not_mem_centerIdeal v A hA r hsP
+    rwa [hfrs] at this
+  intro hbot
+  exact (nonZeroDivisors.ne_zero hs) (Ideal.mem_bot.mp (hbot ▸ hsP))
+
+end CenterNonzero
+section LocalizationSubalgebra
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+  (A : Subalgebra K F) (hA : (A : Set F) ⊆ (v.toValuationSubring : Set F))
+
+@[reducible] private noncomputable def centerLocalizationSubalgebra
+  [IsFractionRing A F] :
+    Subalgebra A F :=
+  Localization.subalgebra.ofField F (v.centerIdeal A hA).primeCompl
+    (v.centerIdeal A hA).primeCompl_le_nonZeroDivisors
+
+scoped instance centerLocalizationSubalgebra_isLocalization [IsFractionRing A F] :
+    IsLocalization.AtPrime (v.centerLocalizationSubalgebra A hA) (v.centerIdeal A hA) :=
+  Localization.subalgebra.isLocalization_ofField F _ _
+
+scoped instance centerLocalizationSubalgebra_isDomain [IsFractionRing A F] :
+    IsDomain (v.centerLocalizationSubalgebra A hA) :=
+  inferInstanceAs (IsDomain (_ : Subalgebra A F))
+
+private theorem centerLocalizationSubalgebra_isDiscreteValuationRing
+    [IsDedekindDomain A] [IsFractionRing A F] :
+    IsDiscreteValuationRing (v.centerLocalizationSubalgebra A hA) :=
+  IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain A
+    (v.centerIdeal_ne_bot_of_isFractionRing A hA) _
+
+scoped instance centerLocalizationSubalgebra_isFractionRing [IsFractionRing A F] :
+    IsFractionRing (v.centerLocalizationSubalgebra A hA) F :=
+  inferInstanceAs (IsFractionRing (Localization.subalgebra.ofField F _ _) F)
+
+private theorem centerLocalizationSubalgebra_subset [IsFractionRing A
+  F] :
+    ((v.centerLocalizationSubalgebra A hA : Subalgebra A F) : Set F)
+      ⊆ (v.toValuationSubring : Set F) := by
+  intro x hx
+  obtain ⟨a, s, hs, rfl⟩ := hx
+  rw [← div_eq_mul_inv]
+  exact div_mem_of_not_mem_centerIdeal v A hA a hs
+
+private noncomputable def centerLocalizationValuationSubring
+    [IsDedekindDomain A] [IsFractionRing A F] : ValuationSubring F where
+  toSubring := (v.centerLocalizationSubalgebra A hA).toSubring
+  mem_or_inv_mem' x := by
+    have := v.centerLocalizationSubalgebra_isDiscreteValuationRing A hA
+    rcases ValuationRing.isInteger_or_isInteger (v.centerLocalizationSubalgebra A hA) x with
+      ⟨a, ha⟩ | ⟨a, ha⟩
+    · exact Or.inl (ha ▸ a.2)
+    · exact Or.inr (ha ▸ a.2)
+
+theorem coe_centerLocalizationValuationSubring [IsDedekindDomain A] [IsFractionRing A F] :
+    ((v.centerLocalizationValuationSubring A hA : ValuationSubring F) : Set F)
+      = ((v.centerLocalizationSubalgebra A hA : Subalgebra A F) : Set F) := rfl
+
+scoped instance centerLocalizationValuationSubring_isDiscreteValuationRing
+    [IsDedekindDomain A] [IsFractionRing A F] :
+    IsDiscreteValuationRing (v.centerLocalizationValuationSubring A hA) :=
+  v.centerLocalizationSubalgebra_isDiscreteValuationRing A hA
+
+private theorem centerLocalizationValuationSubring_le
+    [IsDedekindDomain A] [IsFractionRing A F] :
+    v.centerLocalizationValuationSubring A hA ≤ v.toValuationSubring :=
+  v.centerLocalizationSubalgebra_subset A hA
+
+private theorem centerLocalizationValuationSubring_eq
+    [IsDedekindDomain A] [IsFractionRing A F] :
+    v.centerLocalizationValuationSubring A hA = v.toValuationSubring :=
+  ValuationSubring.eq_of_isDiscreteValuationRing_of_le
+    (v.centerLocalizationValuationSubring_le A hA) v.ne_top'
+
+theorem coe_centerLocalizationSubalgebra_eq [IsDedekindDomain A] [IsFractionRing A F] :
+    ((v.centerLocalizationSubalgebra A hA : Subalgebra A F) : Set F)
+      = (v.toValuationSubring : Set F) := by
+  rw [← coe_centerLocalizationValuationSubring]
+  exact congrArg (SetLike.coe) (v.centerLocalizationValuationSubring_eq A hA)
+
+private theorem mem_centerLocalizationSubalgebra_of_mem
+    [IsDedekindDomain A] [IsFractionRing A F]
+    (x : F) (hx : x ∈ v.toValuationSubring) :
+    x ∈ (v.centerLocalizationSubalgebra A hA : Subalgebra A F) := by
+  rw [← SetLike.mem_coe, coe_centerLocalizationSubalgebra_eq]; exact hx
+
+private theorem isLocalization_centerIdeal_of_isDedekindDomain
+    [IsDedekindDomain A] [IsFractionRing A F] :
+    letI := v.modelAlgebra A hA
+    IsLocalization.AtPrime v.toValuationSubring (v.centerIdeal A hA) := by
+  let := v.modelAlgebra A hA
+  refine (isLocalization_iff _ _).mpr ⟨?_, ?_, ?_⟩
+  · exact v.isUnit_modelInclusion_of_mem_primeCompl A hA
+  · intro x
+    have hxP : (x : F) ∈ (v.centerLocalizationSubalgebra A hA : Subalgebra A F) :=
+      v.mem_centerLocalizationSubalgebra_of_mem A hA (x : F) x.2
+    obtain ⟨a, s, hs, hxeq⟩ := hxP
+    refine ⟨⟨a, ⟨s, hs⟩⟩, Subtype.ext ?_⟩
+    change (x : F) * ((s : A) : F) = ((a : A) : F)
+    have halg_s : algebraMap A F s = ((s : A) : F) := rfl
+    have halg_a : algebraMap A F a = ((a : A) : F) := rfl
+    have hs0 : algebraMap A F s ≠ 0 := by
+      intro hF
+      have hsne : s ≠ 0 := fun h => (h ▸ hs) (Ideal.zero_mem _)
+      exact hsne (Subtype.ext (p := (· ∈ A)) (halg_s ▸ hF))
+    rw [← halg_s, ← halg_a, hxeq, mul_assoc, inv_mul_cancel₀ hs0, mul_one]
+  · intro a₁ a₂ h
+    have hF : (a₁ : F) = (a₂ : F) :=
+      congrArg (Subtype.val : v.toValuationSubring → F) h
+    exact ⟨1, by rw [show a₁ = a₂ from Subtype.ext hF]⟩
+
+end LocalizationSubalgebra
+end Place
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def ValSubringDedekindFractionModel : Prop :=
+  ∀ v : Place K F,
+    ∃ (A : Subalgebra K F) (_ : (A : Set F) ⊆ (v.toValuationSubring : Set F)),
+      Algebra.FiniteType K A ∧ IsDedekindDomain A ∧ IsFractionRing A F
+
+variable {K F}
+
+theorem valSubringDedekindModel_of_dedekindFractionModel
+    (hfrac : ValSubringDedekindFractionModel K F) :
+    ValSubringDedekindModel K F := fun v => by
+  obtain ⟨A, hA, hft, hded, hfracA⟩ := hfrac v
+  exact ⟨A, hA, hft, v.isLocalization_centerIdeal_of_isDedekindDomain A hA⟩
+
+theorem valSubringKaehlerFinite_of_dedekindFractionModel
+    (hfrac : ValSubringDedekindFractionModel K F) :
+    ValSubringKaehlerFinite K F :=
+  valSubringKaehlerFinite_of_dedekindModel
+    (valSubringDedekindModel_of_dedekindFractionModel hfrac)
+
+end AlgebraicCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+
+section EulerGeneral
+
+variable [CharZero K] {p : K[X]} [Fact (Irreducible p)]
+
+omit [DecidableEq (RatFunc K)] in
+omit [CharZero K] in
+theorem aeval_root_eq_sum_range {c : K[X]} {d : ℕ} (hd : c.natDegree < d) :
+    (aeval (AdjoinRoot.root p) c : AdjoinRoot p)
+      = ∑ k ∈ Finset.range d, c.coeff k • AdjoinRoot.root p ^ k := by
+  classical
+  rw [aeval_def, eval₂_eq_sum_range' (algebraMap K (AdjoinRoot p)) hd]
+  exact Finset.sum_congr rfl fun k _ => (Algebra.smul_def _ _).symm
+
+omit [DecidableEq (RatFunc K)] in
+theorem trace_adjoinRoot_mk_div_mk_derivative_of_degree_lt (hpmon : p.Monic)
+    {c : K[X]} (hdeg : c.degree < p.degree) :
+    Algebra.trace K (AdjoinRoot p)
+        (AdjoinRoot.mk p c / AdjoinRoot.mk p (derivative p))
+      = c.coeff (p.natDegree - 1) := by
+  classical
+  have : FiniteDimensional K (AdjoinRoot p) :=
+    Module.Finite.of_basis (AdjoinRoot.powerBasis hpmon.ne_zero).basis
+  have hpd : 0 < p.natDegree := (Fact.out : Irreducible p).natDegree_pos
+  have hcd : c.natDegree < p.natDegree := by
+    rcases eq_or_ne c 0 with rfl | hc
+    · simpa using hpd
+    · exact natDegree_lt_natDegree hc hdeg
+  rw [← AdjoinRoot.aeval_eq, ← AdjoinRoot.aeval_eq,
+    aeval_root_eq_sum_range K hcd, Finset.sum_div, map_sum]
+  trans ∑ k ∈ Finset.range p.natDegree,
+      c.coeff k * Algebra.trace K (AdjoinRoot p)
+        (AdjoinRoot.root p ^ k / aeval (AdjoinRoot.root p) (derivative p))
+  · refine Finset.sum_congr rfl fun k _ => ?_
+    rw [Algebra.smul_def, mul_div_assoc, ← Algebra.smul_def, map_smul, smul_eq_mul]
+  rw [Finset.sum_eq_single (p.natDegree - 1)]
+  · rw [FLT.EulerDualBasis.trace_root_pow_div_derivative_self hpmon hpd, mul_one]
+  · intro k hk hkne
+    have hk' : k < p.natDegree - 1 :=
+      lt_of_le_of_ne (Nat.le_sub_one_of_lt (Finset.mem_range.mp hk)) hkne
+    rw [FLT.EulerDualBasis.trace_root_pow_div_derivative_of_lt hpmon hk', mul_zero]
+  · intro h
+    exact absurd (Finset.mem_range.mpr (Nat.sub_lt hpd one_pos)) h
+
+end EulerGeneral
+section AlgEquiv
+
+variable {p : K[X]} (hpirr : Irreducible p)
+
+def finitePlaceResidueFieldAlgEquivAdjoinRoot :
+    AdjoinRoot p ≃ₐ[K] (finitePlace K hpirr).ResidueField :=
+  residueFieldEquivOfHeightOneSpectrum K (heightOneSpectrumOfIrreducible K hpirr)
+
+omit [DecidableEq (RatFunc K)] in
+theorem finitePlaceResidueFieldAlgEquivAdjoinRoot_mk (q : K[X]) :
+    finitePlaceResidueFieldAlgEquivAdjoinRoot K hpirr (AdjoinRoot.mk p q)
+      = IsLocalRing.residue _ ⟨algebraMap K[X] (RatFunc K) q,
+          algebraMap_mem_ofHeightOneSpectrum K _ q⟩ := by
+  classical
+  exact
+    rfl
+
+end AlgEquiv
+section TraceTransport
+
+variable {p : K[X]} (hpirr : Irreducible p)
+
+omit [DecidableEq (RatFunc K)] in
+theorem trace_finitePlace_residueField_eq_trace_adjoinRoot
+    (y : (finitePlace K hpirr).ResidueField) :
+    Algebra.trace K (finitePlace K hpirr).ResidueField y
+      = Algebra.trace K (AdjoinRoot p)
+          ((finitePlaceResidueFieldAlgEquivAdjoinRoot K hpirr).symm y) := by
+  classical
+  conv_lhs => rw [← (finitePlaceResidueFieldAlgEquivAdjoinRoot K hpirr).apply_symm_apply y]
+  exact Algebra.trace_eq_of_algEquiv _ _
+
+end TraceTransport
+section BridgeRows
+
+variable [HasLocalResidue K (RatFunc K)] [HasCanonicalLocalResidueKStar K (RatFunc K)]
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates]
+
+def P1FinitePlaceSimplePoleResidueAdjoinRootValue : Prop :=
+  ∀ (p c : K[X]) (_ : p.Monic) (hpirr : Irreducible p), c.degree < p.degree →
+    letI : Fact (Irreducible p) := ⟨hpirr⟩
+    ∀ (hfmem : p1PrincipalPartAtom K p c 1 * (finitePlace K hpirr).differentialCoeff (dX K)
+        ∈ (finitePlace K hpirr).simplePoleSubmodule),
+    (finitePlaceResidueFieldAlgEquivAdjoinRoot K hpirr).symm
+        ((finitePlace K hpirr).simplePoleResidueAux ⟨_, hfmem⟩)
+      = AdjoinRoot.mk p c / AdjoinRoot.mk p (derivative p)
+
+def P1PlaceInftySimplePoleResidueEulerValue : Prop :=
+  ∀ (p c : K[X]) (_ : p.Monic) (_ : Irreducible p), c.degree < p.degree →
+    ∀ (himem : p1PrincipalPartAtom K p c 1 * (placeInfty K).differentialCoeff (dX K)
+        ∈ (placeInfty K).simplePoleSubmodule),
+    Algebra.trace K (placeInfty K).ResidueField
+        ((placeInfty K).simplePoleResidueAux ⟨_, himem⟩)
+      = -(c.coeff (p.natDegree - 1))
+
+end BridgeRows
+
+section FinitePlaceTrace
+
+variable [CharZero K]
+
+omit [DecidableEq (RatFunc K)] in
+theorem trace_finitePlace_simplePoleResidue_of_adjoinRootValue
+    (hbridge : P1FinitePlaceSimplePoleResidueAdjoinRootValue K)
+    {p c : K[X]} (hpmon : p.Monic) (hpirr : Irreducible p) (hdeg : c.degree < p.degree)
+    (hfmem : p1PrincipalPartAtom K p c 1 * (finitePlace K hpirr).differentialCoeff (dX K)
+        ∈ (finitePlace K hpirr).simplePoleSubmodule) :
+    Algebra.trace K (finitePlace K hpirr).ResidueField
+        ((finitePlace K hpirr).simplePoleResidueAux ⟨_, hfmem⟩)
+      = c.coeff (p.natDegree - 1) := by
+  classical
+  have : Fact (Irreducible p) := ⟨hpirr⟩
+  have hval := hbridge p c hpmon hpirr hdeg
+  rw [trace_finitePlace_residueField_eq_trace_adjoinRoot K hpirr, hval hfmem,
+    trace_adjoinRoot_mk_div_mk_derivative_of_degree_lt K hpmon hdeg]
+
+end FinitePlaceTrace
+section HigherDegReduction
+
+variable [CharZero K]
+
+theorem p1PrincipalPartMOneSimplePoleCancel_of_eulerBridge
+    {ω₀ : Ω[(RatFunc K)⁄K]} (hω₀ : ω₀ ≠ 0) (heq : ω₀ = dX K)
+    (hfin : P1FinitePlaceSimplePoleResidueAdjoinRootValue K)
+    (hinf : P1PlaceInftySimplePoleResidueEulerValue K) :
+    P1PrincipalPartMOneSimplePoleCancel K hω₀ := by
+  subst heq
+  intro p c hpmon hpirr hdeg hfmem himem
+  rw [trace_finitePlace_simplePoleResidue_of_adjoinRootValue K hfin hpmon hpirr hdeg hfmem,
+    hinf p c hpmon hpirr hdeg himem, add_neg_cancel]
+
+end HigherDegReduction
+end AlgebraicCurve
+end
+section
+
+namespace AlgebraicCurve
+
+namespace Place
+
+section IntegrallyClosed
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem isIntegrallyClosed_toValuationSubring :
+    IsIntegrallyClosed v.toValuationSubring := inferInstance
+
+private theorem mem_valuationSubring_of_isIntegral {x : F}
+    (hx : _root_.IsIntegral v.toValuationSubring x) :
+    x ∈ v.toValuationSubring := by
+  obtain ⟨y, hy⟩ := (isIntegrallyClosed_iff F).mp (v.isIntegrallyClosed_toValuationSubring) hx
+  exact hy ▸ y.2
+
+variable (B : Subalgebra K F) (hB : (B : Set F) ⊆ (v.toValuationSubring : Set F))
+
+include hB in
+private theorem modelAlgebra_isScalarTower_top :
+    letI := v.modelAlgebra B hB
+    IsScalarTower B v.toValuationSubring F := by
+  let := v.modelAlgebra B hB
+  refine IsScalarTower.of_algebraMap_eq fun b => ?_
+  rfl
+
+include hB in
+private theorem mem_valuationSubring_of_isIntegral_subalgebra {x : F}
+    (hx : _root_.IsIntegral B x) :
+    x ∈ v.toValuationSubring := by
+  let := v.modelAlgebra B hB
+  have := v.modelAlgebra_isScalarTower_top B hB
+  exact v.mem_valuationSubring_of_isIntegral (hx.tower_top (A := v.toValuationSubring))
+
+include hB in
+private theorem integralClosure_subset_valuationSubring :
+    ((integralClosure B F : Subalgebra B F) : Set F)
+      ⊆ (v.toValuationSubring : Set F) := fun _ hx =>
+  v.mem_valuationSubring_of_isIntegral_subalgebra B hB hx
+
+end IntegrallyClosed
+end Place
+section TwoCharts
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def IsAffineChart (A : Subalgebra K F) : Prop :=
+  Algebra.FiniteType K A ∧ IsDedekindDomain A ∧ IsFractionRing A F
+
+def ValSubringTwoAffineCharts : Prop :=
+  ∃ A₀ A₁ : Subalgebra K F, IsAffineChart K F A₀ ∧ IsAffineChart K F A₁
+    ∧ ∀ v : Place K F, (A₀ : Set F) ⊆ (v.toValuationSubring : Set F)
+        ∨ (A₁ : Set F) ⊆ (v.toValuationSubring : Set F)
+
+variable {K F}
+
+theorem valSubringDedekindFractionModel_of_twoAffineCharts
+    (h : ValSubringTwoAffineCharts K F) :
+    ValSubringDedekindFractionModel K F := fun v => by
+  obtain ⟨A₀, A₁, ⟨hft₀, hded₀, hfrac₀⟩, ⟨hft₁, hded₁, hfrac₁⟩, hcover⟩ := h
+  rcases hcover v with h₀ | h₁
+  · exact ⟨A₀, h₀, hft₀, hded₀, hfrac₀⟩
+  · exact ⟨A₁, h₁, hft₁, hded₁, hfrac₁⟩
+
+theorem valSubringKaehlerFinite_of_twoAffineCharts
+    (h : ValSubringTwoAffineCharts K F) :
+    ValSubringKaehlerFinite K F :=
+  valSubringKaehlerFinite_of_dedekindFractionModel
+    (valSubringDedekindFractionModel_of_twoAffineCharts h)
+
+end TwoCharts
+end AlgebraicCurve
+namespace AlgebraicCurve
+
+section Gates
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+@[reducible] private noncomputable def toKSubalgebra (v : Place K F) :
+    Subalgebra K F where
+  __ := v.toValuationSubring.toSubring
+  algebraMap_mem' c := v.algebraMap_mem' c
+
+end Place
+namespace Place
+private theorem coe_toKSubalgebra (v : Place K F) :
+    (v.toKSubalgebra : Set F) = (v.toValuationSubring : Set F) := rfl
+
+end Place
+theorem gate_adjoin_subset_valuationSubring_of_mem (v : Place K F) {t : F}
+    (ht : t ∈ v.toValuationSubring) :
+    ((Algebra.adjoin K {t} : Subalgebra K F) : Set F)
+      ⊆ (v.toValuationSubring : Set F) := by
+  rw [← v.coe_toKSubalgebra]
+  exact Algebra.adjoin_le (Set.singleton_subset_iff.mpr ht)
+
+end Gates
+end AlgebraicCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] [HasCanonicalLocalResidueKStar K F]
+
+namespace Place
+
+variable (v : Place K F)
+
+omit [HasCanonicalLocalResidueKStar K F] in
+private theorem simplePoleResidueAux_mul_of_mem {a : F}
+    (ha : a ∈ v.toValuationSubring)
+    {f : F} (hf : f ∈ v.simplePoleSubmodule)
+    (haf : a * f ∈ v.simplePoleSubmodule) :
+    v.simplePoleResidueAux ⟨a * f, haf⟩
+      = IsLocalRing.residue _ ⟨a, ha⟩ * v.simplePoleResidueAux ⟨f, hf⟩ := by
+  rw [simplePoleResidueAux_apply, simplePoleResidueAux_apply, ← map_mul]
+  exact congrArg (IsLocalRing.residue _) (Subtype.ext (mul_left_comm _ _ _))
+
+omit [HasCanonicalLocalResidueKStar K F] in
+private theorem mul_mem_simplePoleSubmodule_of_mem {a : F}
+    (ha : a ∈ v.toValuationSubring)
+    {f : F} (hf : f ∈ v.simplePoleSubmodule) :
+    a * f ∈ v.simplePoleSubmodule := by
+  rw [mem_simplePoleSubmodule, mul_left_comm]
+  exact mul_mem ha hf
+
+end Place
+section DerivativeRegular
+
+variable (K)
+
+theorem denom_notMem_of_mem_ofHeightOneSpectrum (w : HeightOneSpectrum K[X]) {f : RatFunc K}
+    (hf : f ∈ (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).toValuationSubring) :
+    f.denom ∉ w.asIdeal := by
+  classical
+  intro hd
+  have hxval : w.valuation (RatFunc K) f ≤ 1 :=
+    (Place.isEquiv_adicValuation_ofHeightOneSpectrum (K := K)
+      (F := RatFunc K) w).le_one_iff_le_one.mpr ((Place.mem_iff_adicValuation_le_one _).mp hf)
+  have hden_ne : algebraMap K[X] (RatFunc K) f.denom ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr f.denom_ne_zero
+  have hmul : f * algebraMap K[X] (RatFunc K) f.denom = algebraMap K[X] (RatFunc K) f.num :=
+    ((div_eq_iff hden_ne).mp f.num_div_denom).symm
+  have hnum : f.num ∉ w.asIdeal := by
+    intro hn
+    refine w.isPrime.ne_top ((Ideal.eq_top_iff_one _).mpr ?_)
+    obtain ⟨a, b, hab⟩ := RatFunc.isCoprime_num_denom f
+    exact hab ▸ Ideal.add_mem _ (Ideal.mul_mem_left _ _ hn) (Ideal.mul_mem_left _ _ hd)
+  have h1 : w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) f.num) = 1 :=
+    (HeightOneSpectrum.valuation_eq_one_iff_notMem w).mpr hnum
+  refine absurd h1 (ne_of_lt ?_)
+  calc w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) f.num)
+      = w.valuation (RatFunc K) f
+          * w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) f.denom) := by
+        rw [← map_mul, hmul]
+    _ ≤ w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) f.denom) :=
+        mul_le_of_le_one_left' hxval
+    _ < 1 := (HeightOneSpectrum.valuation_lt_one_iff_mem w f.denom).mpr hd
+
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+private theorem differentialCoeff_add' (v : Place K (RatFunc K)) (ω₁ ω₂ : Ω[(RatFunc K)⁄K]) :
+    v.differentialCoeff (ω₁ + ω₂) = v.differentialCoeff ω₁ + v.differentialCoeff ω₂ := by
+  classical
+  exact
+    v.differentialCoeff_unique
+      (by rw [add_smul, v.differentialCoeff_smul_dCoord, v.differentialCoeff_smul_dCoord])
+
+theorem differentialCoeff_D_algebraMap_polynomial (v : Place K (RatFunc K)) (q : K[X]) :
+    v.differentialCoeff (D K (RatFunc K) (algebraMap K[X] (RatFunc K) q))
+      = algebraMap K[X] (RatFunc K) q.derivative * v.differentialCoeff (dX K) := by
+  classical
+  rw [D_algebraMap_polynomial K q, v.differentialCoeff_smul]
+
+theorem differentialCoeff_D_mem_finitePlace [CharZero K] {p : K[X]} (hpirr : Irreducible p)
+    {f : RatFunc K} (hf : f ∈ (finitePlace K hpirr).toValuationSubring) :
+    (finitePlace K hpirr).differentialCoeff (D K (RatFunc K) f)
+      ∈ (finitePlace K hpirr).toValuationSubring := by
+  classical
+  set v := finitePlace K hpirr
+  set ξ : K[X] := f.num.derivative * f.denom - f.num * f.denom.derivative
+  have hd0 : algebraMap K[X] (RatFunc K) f.denom ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr f.denom_ne_zero
+  have hcoeff : v.differentialCoeff (D K (RatFunc K) f)
+      = algebraMap K[X] (RatFunc K) ξ * ((algebraMap K[X] (RatFunc K) f.denom) ^ 2)⁻¹
+          * v.differentialCoeff (dX K) := by
+    have hkey := denom_sq_smul_D_eq K f
+    refine v.differentialCoeff_unique ?_
+    rw [mul_smul, v.differentialCoeff_smul_dCoord, mul_comm, mul_smul, ← hkey, smul_smul,
+      inv_mul_cancel₀ (pow_ne_zero 2 hd0), one_smul]
+  rw [hcoeff]
+  refine mul_mem (mul_mem ?_ ?_) ?_
+  · exact algebraMap_mem_ofHeightOneSpectrum K _ ξ
+  · have hden_notmem : f.denom ∉ (heightOneSpectrumOfIrreducible K hpirr).asIdeal :=
+      denom_notMem_of_mem_ofHeightOneSpectrum K _ hf
+    have hordd : v.ord (algebraMap K[X] (RatFunc K) f.denom) = 0 := by
+      by_contra h
+      exact hden_notmem ((Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K)
+        (F := RatFunc K) _ f.denom_ne_zero).mp h)
+    refine v.mem_of_ord_nonneg (inv_ne_zero (pow_ne_zero 2 hd0)) ?_
+    rw [v.ord_inv, ← zpow_natCast, v.ord_zpow, hordd, mul_zero, _root_.neg_zero]
+  · exact v.mem_of_ord_nonneg (v.differentialCoeff_ne_zero (dX_ne_zero K))
+      (ord_differentialCoeff_dX_ofHeightOneSpectrum hpirr
+        (heightOneSpectrumOfIrreducible_asIdeal K hpirr) hpirr.separable).ge
+
+end DerivativeRegular
+section LeibnizCore
+
+variable (K)
+variable [CharZero K]
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+omit [CharZero K] [∀ (v : Place K (RatFunc K)), v.DCoordGenerates] [Nontrivial Ω[RatFunc K⁄K]] in
+theorem uniformizer_div_mem_finitePlace {p : K[X]} (hpirr : Irreducible p) :
+    (finitePlace K hpirr).uniformizer / algebraMap K[X] (RatFunc K) p
+      ∈ (finitePlace K hpirr).toValuationSubring := by
+  classical
+  set v := finitePlace K hpirr
+  have hp0 : algebraMap K[X] (RatFunc K) p ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hpirr.ne_zero
+  refine v.mem_of_ord_nonneg (div_ne_zero v.uniformizer_ne_zero hp0) ?_
+  rw [div_eq_mul_inv, v.ord_mul v.uniformizer_ne_zero (inv_ne_zero hp0), v.ord_inv,
+    v.ord_uniformizer, ord_finitePlace_self K hpirr]
+  omega
+
+theorem one_sub_uniformizer_div_mul_differentialCoeff_D
+    {p : K[X]} (hpirr : Irreducible p) :
+    (1 : RatFunc K) - (finitePlace K hpirr).uniformizer / algebraMap K[X] (RatFunc K) p
+        * (finitePlace K hpirr).differentialCoeff
+            (D K (RatFunc K) (algebraMap K[X] (RatFunc K) p))
+      = algebraMap K[X] (RatFunc K) p
+          * (finitePlace K hpirr).differentialCoeff
+              (D K (RatFunc K) ((finitePlace K hpirr).uniformizer
+                / algebraMap K[X] (RatFunc K) p)) := by
+  classical
+  set v := finitePlace K hpirr
+  have hp0 : algebraMap K[X] (RatFunc K) p ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hpirr.ne_zero
+  have hleib : D K (RatFunc K) v.uniformizer
+      = (v.uniformizer / algebraMap K[X] (RatFunc K) p)
+            • D K (RatFunc K) (algebraMap K[X] (RatFunc K) p)
+        + algebraMap K[X] (RatFunc K) p
+            • D K (RatFunc K) (v.uniformizer / algebraMap K[X] (RatFunc K) p) := by
+    have h := (D K (RatFunc K)).leibniz (a := v.uniformizer / algebraMap K[X] (RatFunc K) p)
+      (b := algebraMap K[X] (RatFunc K) p)
+    rw [div_mul_cancel₀ _ hp0] at h
+    exact h
+  have h1 : (1 : RatFunc K)
+      = (v.uniformizer / algebraMap K[X] (RatFunc K) p)
+            * v.differentialCoeff (D K (RatFunc K) (algebraMap K[X] (RatFunc K) p))
+        + algebraMap K[X] (RatFunc K) p
+            * v.differentialCoeff
+                (D K (RatFunc K) (v.uniformizer / algebraMap K[X] (RatFunc K) p)) := by
+    have hcoord : D K (RatFunc K) v.uniformizer = v.dCoord := rfl
+    rw [← v.differentialCoeff_dCoord, ← hcoord, hleib, differentialCoeff_add' K,
+      v.differentialCoeff_smul, v.differentialCoeff_smul]
+  linear_combination h1
+
+theorem uniformizer_div_mul_differentialCoeff_D_mem_finitePlace
+    {p : K[X]} (hpirr : Irreducible p) :
+    (finitePlace K hpirr).uniformizer / algebraMap K[X] (RatFunc K) p
+        * (finitePlace K hpirr).differentialCoeff
+            (D K (RatFunc K) (algebraMap K[X] (RatFunc K) p))
+      ∈ (finitePlace K hpirr).toValuationSubring := by
+  classical
+  set v := finitePlace K hpirr
+  have hp0 : algebraMap K[X] (RatFunc K) p ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hpirr.ne_zero
+  refine mul_mem (uniformizer_div_mem_finitePlace K hpirr) ?_
+  rw [differentialCoeff_D_algebraMap_polynomial K]
+  exact mul_mem (algebraMap_mem_ofHeightOneSpectrum K _ p.derivative)
+    (v.mem_of_ord_nonneg (v.differentialCoeff_ne_zero (dX_ne_zero K))
+      (ord_differentialCoeff_dX_ofHeightOneSpectrum hpirr
+        (heightOneSpectrumOfIrreducible_asIdeal K hpirr) hpirr.separable).ge)
+
+theorem residue_uniformizer_div_mul_differentialCoeff_D_eq_one
+    {p : K[X]} (hpirr : Irreducible p) :
+    IsLocalRing.residue _ ⟨_, uniformizer_div_mul_differentialCoeff_D_mem_finitePlace K hpirr⟩
+      = (1 : (finitePlace K hpirr).ResidueField) := by
+  classical
+  set v := finitePlace K hpirr
+  rw [← sub_eq_zero, show (1 : v.ResidueField) = IsLocalRing.residue _ 1 by simp,
+    ← map_sub, IsLocalRing.residue_eq_zero_iff]
+  have hsubmem : (1 : RatFunc K) - (v.uniformizer / algebraMap K[X] (RatFunc K) p
+      * v.differentialCoeff (D K (RatFunc K) (algebraMap K[X] (RatFunc K) p)))
+        ∈ v.toValuationSubring :=
+    sub_mem (one_mem _) (uniformizer_div_mul_differentialCoeff_D_mem_finitePlace K hpirr)
+  have hcoe : (⟨_, uniformizer_div_mul_differentialCoeff_D_mem_finitePlace K hpirr⟩
+        - 1 : v.toValuationSubring)
+      = -⟨_, hsubmem⟩ :=
+    Subtype.ext (by push_cast; ring)
+  rw [hcoe]
+  refine neg_mem ?_
+  have herr : (1 : RatFunc K) - (v.uniformizer / algebraMap K[X] (RatFunc K) p
+      * v.differentialCoeff (D K (RatFunc K) (algebraMap K[X] (RatFunc K) p)))
+        = algebraMap K[X] (RatFunc K) p
+          * v.differentialCoeff (D K (RatFunc K)
+              (v.uniformizer / algebraMap K[X] (RatFunc K) p)) :=
+    one_sub_uniformizer_div_mul_differentialCoeff_D K hpirr
+  have hpmem : (⟨algebraMap K[X] (RatFunc K) p, algebraMap_mem_ofHeightOneSpectrum K _ p⟩
+      : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring := by
+    rw [Place.mem_maximalIdeal_iff_adicValuation_lt_one]
+    refine (Place.isEquiv_adicValuation_ofHeightOneSpectrum (K := K)
+      (F := RatFunc K) (heightOneSpectrumOfIrreducible K hpirr)).lt_one_iff_lt_one.mp ?_
+    exact (HeightOneSpectrum.valuation_lt_one_iff_mem _ p).mpr
+      (Ideal.mem_span_singleton_self p)
+  have hregmem : v.differentialCoeff (D K (RatFunc K)
+        (v.uniformizer / algebraMap K[X] (RatFunc K) p)) ∈ v.toValuationSubring :=
+    differentialCoeff_D_mem_finitePlace K hpirr (uniformizer_div_mem_finitePlace K hpirr)
+  have hprod : (⟨_, hsubmem⟩ : v.toValuationSubring)
+      = ⟨_, algebraMap_mem_ofHeightOneSpectrum K _ p⟩ * ⟨_, hregmem⟩ :=
+    Subtype.ext herr
+  rw [hprod]
+  exact Ideal.mul_mem_right _ _ hpmem
+
+end LeibnizCore
+section BridgeDischarge
+
+variable (K)
+variable [CharZero K]
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+omit [∀ (v : Place K (RatFunc K)), v.DCoordGenerates] [Nontrivial Ω[RatFunc K⁄K]] in
+theorem residue_algebraMap_derivative_ne_zero {p : K[X]} (hpirr : Irreducible p) :
+    IsLocalRing.residue _ ⟨algebraMap K[X] (RatFunc K) p.derivative,
+        algebraMap_mem_ofHeightOneSpectrum K _ p.derivative⟩
+      ≠ (0 : (finitePlace K hpirr).ResidueField) := by
+  classical
+  rw [ne_eq, IsLocalRing.residue_eq_zero_iff,
+    Place.mem_maximalIdeal_iff_adicValuation_lt_one]
+  intro hlt
+  have hlt' := (Place.isEquiv_adicValuation_ofHeightOneSpectrum (K := K)
+    (F := RatFunc K) (heightOneSpectrumOfIrreducible K hpirr)).lt_one_iff_lt_one.mpr hlt
+  rw [HeightOneSpectrum.valuation_lt_one_iff_mem,
+    heightOneSpectrumOfIrreducible_asIdeal K hpirr, Ideal.mem_span_singleton] at hlt'
+  exact hpirr.not_isUnit (hpirr.separable.isUnit_of_dvd' dvd_rfl hlt')
+
+theorem simplePoleResidueAux_finitePlace_p1PrincipalPartAtom_mOne
+    {p c : K[X]} (hpirr : Irreducible p)
+    (hfmem : p1PrincipalPartAtom K p c 1 * (finitePlace K hpirr).differentialCoeff (dX K)
+        ∈ (finitePlace K hpirr).simplePoleSubmodule) :
+    (finitePlace K hpirr).simplePoleResidueAux ⟨_, hfmem⟩
+      = IsLocalRing.residue _ ⟨algebraMap K[X] (RatFunc K) c,
+            algebraMap_mem_ofHeightOneSpectrum K _ c⟩
+        / IsLocalRing.residue _ ⟨algebraMap K[X] (RatFunc K) p.derivative,
+            algebraMap_mem_ofHeightOneSpectrum K _ p.derivative⟩ := by
+  classical
+  set v := finitePlace K hpirr
+  have hp0 : algebraMap K[X] (RatFunc K) p ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hpirr.ne_zero
+  rw [Place.simplePoleResidueAux_apply, eq_div_iff (residue_algebraMap_derivative_ne_zero K hpirr)]
+  have hkey : (v.uniformizer * (p1PrincipalPartAtom K p c 1 * v.differentialCoeff (dX K)))
+        * algebraMap K[X] (RatFunc K) p.derivative
+      = algebraMap K[X] (RatFunc K) c
+        * (v.uniformizer / algebraMap K[X] (RatFunc K) p
+            * v.differentialCoeff (D K (RatFunc K) (algebraMap K[X] (RatFunc K) p))) := by
+    rw [differentialCoeff_D_algebraMap_polynomial K]
+    change v.uniformizer
+        * (algebraMap K[X] (RatFunc K) c / algebraMap K[X] (RatFunc K) p ^ 1
+            * v.differentialCoeff (dX K))
+        * algebraMap K[X] (RatFunc K) (derivative p)
+      = algebraMap K[X] (RatFunc K) c
+        * (v.uniformizer / algebraMap K[X] (RatFunc K) p
+            * (algebraMap K[X] (RatFunc K) (derivative p) * v.differentialCoeff (dX K)))
+    rw [pow_one, div_mul_eq_mul_div, div_mul_eq_mul_div, mul_div_assoc, mul_div_assoc]
+    ring_nf
+  have hLHSmem : v.uniformizer * (p1PrincipalPartAtom K p c 1 * v.differentialCoeff (dX K))
+      * algebraMap K[X] (RatFunc K) p.derivative ∈ v.toValuationSubring :=
+    mul_mem hfmem (algebraMap_mem_ofHeightOneSpectrum K _ p.derivative)
+  have hRHSmem : algebraMap K[X] (RatFunc K) c
+      * (v.uniformizer / algebraMap K[X] (RatFunc K) p
+          * v.differentialCoeff (D K (RatFunc K) (algebraMap K[X] (RatFunc K) p)))
+        ∈ v.toValuationSubring :=
+    mul_mem (algebraMap_mem_ofHeightOneSpectrum K _ c)
+      (uniformizer_div_mul_differentialCoeff_D_mem_finitePlace K hpirr)
+  calc IsLocalRing.residue _ ⟨_, hfmem⟩ * IsLocalRing.residue _ ⟨_,
+          algebraMap_mem_ofHeightOneSpectrum K _ p.derivative⟩
+      = IsLocalRing.residue _ (⟨_, hfmem⟩ * ⟨_,
+          algebraMap_mem_ofHeightOneSpectrum K _ p.derivative⟩) := (map_mul _ _ _).symm
+    _ = IsLocalRing.residue _ ⟨_, hLHSmem⟩ :=
+        congrArg (IsLocalRing.residue _) (Subtype.ext rfl)
+    _ = IsLocalRing.residue _ ⟨_, hRHSmem⟩ :=
+        congrArg (IsLocalRing.residue _) (Subtype.ext hkey)
+    _ = IsLocalRing.residue _ (⟨_, algebraMap_mem_ofHeightOneSpectrum K _ c⟩
+          * ⟨_, uniformizer_div_mul_differentialCoeff_D_mem_finitePlace K hpirr⟩) :=
+        congrArg (IsLocalRing.residue _) (Subtype.ext rfl)
+    _ = IsLocalRing.residue _ ⟨_, algebraMap_mem_ofHeightOneSpectrum K _ c⟩
+          * IsLocalRing.residue _
+              ⟨_, uniformizer_div_mul_differentialCoeff_D_mem_finitePlace K hpirr⟩ :=
+        map_mul _ _ _
+    _ = IsLocalRing.residue _ ⟨_, algebraMap_mem_ofHeightOneSpectrum K _ c⟩ := by
+        rw [residue_uniformizer_div_mul_differentialCoeff_D_eq_one K hpirr, mul_one]
+
+theorem p1FinitePlaceSimplePoleResidueAdjoinRootValue_dX :
+    P1FinitePlaceSimplePoleResidueAdjoinRootValue K := by
+  classical
+  intro p c _ hpirr _
+  have : Fact (Irreducible p) := ⟨hpirr⟩
+  intro hfmem
+  rw [simplePoleResidueAux_finitePlace_p1PrincipalPartAtom_mOne K hpirr hfmem,
+    AlgEquiv.symm_apply_eq, map_div₀,
+    finitePlaceResidueFieldAlgEquivAdjoinRoot_mk K hpirr c,
+    finitePlaceResidueFieldAlgEquivAdjoinRoot_mk K hpirr p.derivative]
+
+end BridgeDischarge
+section ComposedEngine
+
+variable (K)
+variable [DecidableEq (RatFunc K)] [CharZero K]
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+theorem p1PrincipalPartMOneSimplePoleCancel_of_inftyBridge
+    {ω₀ : Ω[(RatFunc K)⁄K]} (hω₀ : ω₀ ≠ 0) (heq : ω₀ = dX K)
+    (hinf : P1PlaceInftySimplePoleResidueEulerValue K) :
+    P1PrincipalPartMOneSimplePoleCancel K hω₀ :=
+  p1PrincipalPartMOneSimplePoleCancel_of_eulerBridge K hω₀ heq
+    (p1FinitePlaceSimplePoleResidueAdjoinRootValue_dX K) hinf
+
+end ComposedEngine
+end AlgebraicCurve
+end
+section
+
+namespace AlgebraicCurve
+
+section AdjoinRingProperties
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+private theorem _root_.Transcendental.isPrincipalIdealRing_adjoin {t : F} (ht : Transcendental K t)
+    :
+    IsPrincipalIdealRing ↥(Algebra.adjoin K ({t} : Set F)) :=
+  IsPrincipalIdealRing.of_surjective
+    (Polynomial.algEquivOfTranscendental K t ht).toRingHom
+    (Polynomial.algEquivOfTranscendental K t ht).surjective
+
+private theorem _root_.Transcendental.isDedekindDomain_adjoin {t : F} (ht : Transcendental K t) :
+    IsDedekindDomain ↥(Algebra.adjoin K ({t} : Set F)) :=
+  haveI := ht.isPrincipalIdealRing_adjoin
+  inferInstance
+
+private theorem _root_.Transcendental.isIntegrallyClosed_adjoin {t : F} (ht : Transcendental K t) :
+    IsIntegrallyClosed ↥(Algebra.adjoin K ({t} : Set F)) :=
+  haveI := ht.isDedekindDomain_adjoin
+  inferInstance
+
+private theorem _root_.Transcendental.isNoetherianRing_adjoin {t : F} (ht : Transcendental K t) :
+    IsNoetherianRing ↥(Algebra.adjoin K ({t} : Set F)) :=
+  haveI := ht.isPrincipalIdealRing_adjoin
+  inferInstance
+
+private theorem _root_.Algebra.FiniteType.adjoin_singleton (t : F) :
+    Algebra.FiniteType K ↥(Algebra.adjoin K ({t} : Set F)) :=
+  Algebra.FiniteType.adjoin_of_finite (Set.finite_singleton t)
+
+private theorem _root_.Transcendental.inv {t : F} (ht : Transcendental K t) :
+    Transcendental K t⁻¹ := by
+  rw [Transcendental, IsAlgebraic.inv_iff]; exact ht
+
+end AdjoinRingProperties
+section TranscendentalChart
+
+variable (K : Type*) {F : Type*} [Field K] [Field F] [Algebra K F]
+
+@[reducible] noncomputable def transcendentalChart (t : F) : Subalgebra K F :=
+  (integralClosure (Algebra.adjoin K ({t} : Set F)) F).restrictScalars K
+
+theorem coe_transcendentalChart (t : F) :
+    (transcendentalChart K t : Set F)
+      = ((integralClosure (Algebra.adjoin K ({t} : Set F)) F : Subalgebra _ F) : Set F) :=
+  rfl
+
+variable {K}
+
+theorem transcendentalChart_subset_valuationSubring_of_mem (v : Place K F)
+    {t : F} (ht : t ∈ v.toValuationSubring) :
+    (transcendentalChart K t : Set F) ⊆ (v.toValuationSubring : Set F) := by
+  rw [coe_transcendentalChart]
+  exact v.integralClosure_subset_valuationSubring _
+    (gate_adjoin_subset_valuationSubring_of_mem v ht)
+
+theorem transcendentalChart_subset_or_inv_subset (v : Place K F) (t : F) :
+    (transcendentalChart K t : Set F) ⊆ (v.toValuationSubring : Set F)
+      ∨ (transcendentalChart K t⁻¹ : Set F) ⊆ (v.toValuationSubring : Set F) :=
+  (v.toValuationSubring.mem_or_inv_mem t).imp
+    (transcendentalChart_subset_valuationSubring_of_mem v)
+    (transcendentalChart_subset_valuationSubring_of_mem v)
+
+end TranscendentalChart
+section IsAffineChartEngine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+section
+
+variable (B : Subalgebra K F)
+
+theorem isScalarTower_integralClosure_subalgebra :
+    IsScalarTower K B ↥(integralClosure B F) := by
+  refine IsScalarTower.of_algebraMap_eq fun c => ?_
+  exact Subtype.ext rfl
+
+theorem finiteType_integralClosure_of_moduleFinite (hft : Algebra.FiniteType K B)
+    (hfin : Module.Finite B ↥(integralClosure B F)) :
+    Algebra.FiniteType K ↥(integralClosure B F) :=
+  haveI := isScalarTower_integralClosure_subalgebra B
+  haveI := hfin
+  Algebra.FiniteType.trans (S := B) hft inferInstance
+
+end
+theorem isDedekindDomain_integralClosure_adjoin {t : F} (ht : Transcendental K t)
+    [FiniteDimensional K⟮t⟯ F] [Algebra.IsSeparable K⟮t⟯ F] :
+    IsDedekindDomain ↥(integralClosure (Algebra.adjoin K ({t} : Set F)) F) := by
+  have := ht.isDedekindDomain_adjoin
+  exact integralClosure.isDedekindDomain ↥(Algebra.adjoin K ({t} : Set F)) ↥(K⟮t⟯) F
+
+theorem isFractionRing_integralClosure_adjoin (t : F) [FiniteDimensional K⟮t⟯ F] :
+    IsFractionRing ↥(integralClosure (Algebra.adjoin K ({t} : Set F)) F) F :=
+  integralClosure.isFractionRing_of_finite_extension
+    (A := ↥(Algebra.adjoin K ({t} : Set F))) ↥(K⟮t⟯) F
+
+theorem moduleFinite_integralClosure_adjoin {t : F} (ht : Transcendental K t)
+    [FiniteDimensional K⟮t⟯ F] [Algebra.IsSeparable K⟮t⟯ F] :
+    Module.Finite ↥(Algebra.adjoin K ({t} : Set F))
+      ↥(integralClosure (Algebra.adjoin K ({t} : Set F)) F) := by
+  have := ht.isIntegrallyClosed_adjoin
+  have := ht.isNoetherianRing_adjoin
+  exact IsIntegralClosure.finite (A := ↥(Algebra.adjoin K ({t} : Set F)))
+    (K := ↥(K⟮t⟯)) (L := F) (integralClosure ↥(Algebra.adjoin K ({t} : Set F)) F)
+
+theorem finiteType_integralClosure_adjoin {t : F} (ht : Transcendental K t)
+    [FiniteDimensional K⟮t⟯ F] [Algebra.IsSeparable K⟮t⟯ F] :
+    Algebra.FiniteType K ↥(integralClosure (Algebra.adjoin K ({t} : Set F)) F) :=
+  finiteType_integralClosure_of_moduleFinite (Algebra.adjoin K {t})
+    (Algebra.FiniteType.adjoin_singleton t) (moduleFinite_integralClosure_adjoin ht)
+
+theorem isAffineChart_restrictScalars_integralClosure (B : Subalgebra K F)
+    (hft : Algebra.FiniteType K ↥(integralClosure B F))
+    (hded : IsDedekindDomain ↥(integralClosure B F))
+    (hfrac : IsFractionRing ↥(integralClosure B F) F) :
+    IsAffineChart K F ((integralClosure B F).restrictScalars K) :=
+  ⟨hft, hded, hfrac⟩
+
+theorem isAffineChart_transcendentalChart {t : F} (ht : Transcendental K t)
+    [FiniteDimensional K⟮t⟯ F] [Algebra.IsSeparable K⟮t⟯ F] :
+    IsAffineChart K F (transcendentalChart K t) :=
+  isAffineChart_restrictScalars_integralClosure (Algebra.adjoin K {t})
+    (finiteType_integralClosure_adjoin ht)
+    (isDedekindDomain_integralClosure_adjoin ht)
+    (isFractionRing_integralClosure_adjoin t)
+
+end IsAffineChartEngine
+section SeparatingTranscendental
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def HasSeparatingTranscendental : Prop :=
+  ∃ t : F, Transcendental K t
+    ∧ FiniteDimensional K⟮t⟯ F ∧ Algebra.IsSeparable K⟮t⟯ F
+    ∧ FiniteDimensional K⟮t⁻¹⟯ F ∧ Algebra.IsSeparable K⟮t⁻¹⟯ F
+
+variable {K F}
+
+theorem valSubringTwoAffineCharts_of_hasSeparatingTranscendental
+    (h : HasSeparatingTranscendental K F) :
+    ValSubringTwoAffineCharts K F := by
+  obtain ⟨t, ht, hfin, hsep, hfin', hsep'⟩ := h
+  exact ⟨transcendentalChart K t, transcendentalChart K t⁻¹,
+    isAffineChart_transcendentalChart ht,
+    isAffineChart_transcendentalChart ht.inv,
+    fun v => transcendentalChart_subset_or_inv_subset v t⟩
+
+theorem valSubringKaehlerFinite_of_hasSeparatingTranscendental
+    (h : HasSeparatingTranscendental K F) :
+    ValSubringKaehlerFinite K F :=
+  valSubringKaehlerFinite_of_twoAffineCharts
+    (valSubringTwoAffineCharts_of_hasSeparatingTranscendental h)
+
+end SeparatingTranscendental
+end AlgebraicCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+
+section LowDegRegular
+
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+theorem ord_placeInfty_mOneAtom_mul_differentialCoeff_dX
+    (hInfty : (placeInfty K).ord ((placeInfty K).differentialCoeff (dX K)) = -2)
+    {p c : K[X]} (hp : p ≠ 0) (hc : c ≠ 0) :
+    (placeInfty K).ord
+        (p1PrincipalPartAtom K p c 1 * (placeInfty K).differentialCoeff (dX K))
+      = (p.natDegree : ℤ) - c.natDegree - 2 := by
+  have hatom0 : p1PrincipalPartAtom K p c 1 ≠ 0 := by
+    simp only [p1PrincipalPartAtom, ne_eq, div_eq_zero_iff, not_or]
+    exact ⟨(map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hc,
+      pow_ne_zero _ ((map_ne_zero_iff _
+        (IsFractionRing.injective K[X] (RatFunc K))).mpr hp)⟩
+  rw [(placeInfty K).ord_mul hatom0 ((placeInfty K).differentialCoeff_ne_zero (dX_ne_zero K)),
+    ord_placeInfty_p1PrincipalPartAtom K hp hc 1, hInfty]
+  push_cast; ring
+
+theorem p1MOneAtom_mul_differentialCoeff_dX_mem_placeInfty
+    (hInfty : (placeInfty K).ord ((placeInfty K).differentialCoeff (dX K)) = -2)
+    {p c : K[X]} (hp : p ≠ 0) (hcdeg : c = 0 ∨ c.natDegree + 2 ≤ p.natDegree) :
+    p1PrincipalPartAtom K p c 1 * (placeInfty K).differentialCoeff (dX K)
+      ∈ (placeInfty K).toValuationSubring := by
+  rcases hcdeg with rfl | hcdeg
+  · change algebraMap K[X] (RatFunc K) 0 / (algebraMap K[X] (RatFunc K) p) ^ 1
+        * (placeInfty K).differentialCoeff (dX K) ∈ _
+    rw [_root_.map_zero, zero_div, zero_mul]; exact zero_mem _
+  · rcases eq_or_ne c 0 with rfl | hc
+    · change algebraMap K[X] (RatFunc K) 0 / (algebraMap K[X] (RatFunc K) p) ^ 1
+          * (placeInfty K).differentialCoeff (dX K) ∈ _
+      rw [_root_.map_zero, zero_div, zero_mul]; exact zero_mem _
+    have hatom0 : p1PrincipalPartAtom K p c 1 ≠ 0 := by
+      simp only [p1PrincipalPartAtom, ne_eq, div_eq_zero_iff, not_or]
+      exact ⟨(map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hc,
+        pow_ne_zero _ ((map_ne_zero_iff _
+          (IsFractionRing.injective K[X] (RatFunc K))).mpr hp)⟩
+    refine (placeInfty K).mem_of_ord_nonneg
+      (mul_ne_zero hatom0 ((placeInfty K).differentialCoeff_ne_zero (dX_ne_zero K))) ?_
+    rw [ord_placeInfty_mOneAtom_mul_differentialCoeff_dX K hInfty hp hc]
+    omega
+
+end LowDegRegular
+section LowDegValue
+
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+theorem trace_placeInfty_simplePoleResidue_mOne_of_lowDeg
+    (hInfty : (placeInfty K).ord ((placeInfty K).differentialCoeff (dX K)) = -2)
+    {p c : K[X]} (hpirr : Irreducible p)
+    (hcdeg : c = 0 ∨ c.natDegree + 2 ≤ p.natDegree)
+    (himem : p1PrincipalPartAtom K p c 1 * (placeInfty K).differentialCoeff (dX K)
+        ∈ (placeInfty K).simplePoleSubmodule) :
+    Algebra.trace K (placeInfty K).ResidueField
+        ((placeInfty K).simplePoleResidueAux ⟨_, himem⟩)
+      = -(c.coeff (p.natDegree - 1)) := by
+  have hreg := p1MOneAtom_mul_differentialCoeff_dX_mem_placeInfty K hInfty hpirr.ne_zero hcdeg
+  have hLHS : (placeInfty K).simplePoleResidueAux ⟨_, himem⟩ = 0 :=
+    (placeInfty K).simplePoleResidueAux_eq_zero_of_mem hreg
+  rw [hLHS, _root_.map_zero]
+  rcases hcdeg with rfl | hcdeg
+  · simp
+  · rw [coeff_eq_zero_of_natDegree_lt (by omega : c.natDegree < p.natDegree - 1), _root_.neg_zero]
+
+end LowDegValue
+section NamedCarriers
+
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+def P1PlaceInftySimplePoleResidueEulerValueTopDeg : Prop :=
+  ∀ (p c : K[X]) (_ : p.Monic) (_ : Irreducible p), c ≠ 0 → c.natDegree + 1 = p.natDegree →
+    ∀ (himem : p1PrincipalPartAtom K p c 1 * (placeInfty K).differentialCoeff (dX K)
+        ∈ (placeInfty K).simplePoleSubmodule),
+    Algebra.trace K (placeInfty K).ResidueField
+        ((placeInfty K).simplePoleResidueAux ⟨_, himem⟩)
+      = -(c.coeff (p.natDegree - 1))
+
+def P1PlaceInftySimplePoleResidueEulerValueMonomial : Prop :=
+  ∀ (p : K[X]) (_ : p.Monic) (_ : Irreducible p),
+    ∀ (himem : p1PrincipalPartAtom K p (X ^ (p.natDegree - 1)) 1
+          * (placeInfty K).differentialCoeff (dX K)
+        ∈ (placeInfty K).simplePoleSubmodule),
+    Algebra.trace K (placeInfty K).ResidueField
+        ((placeInfty K).simplePoleResidueAux ⟨_, himem⟩)
+      = -1
+
+end NamedCarriers
+section EraseLeadLinearity
+
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+omit [DecidableEq (RatFunc K)] in
+omit [∀ (v : Place K (RatFunc K)), v.DCoordGenerates] [Nontrivial Ω[RatFunc K⁄K]] in
+theorem p1PrincipalPartAtom_add_mul_differentialCoeff (p c₁ c₂ : K[X]) (m : ℕ)
+    (v : Place K (RatFunc K)) (ω : Ω[(RatFunc K)⁄K]) :
+    p1PrincipalPartAtom K p (c₁ + c₂) m * v.differentialCoeff ω
+      = p1PrincipalPartAtom K p c₁ m * v.differentialCoeff ω
+        + p1PrincipalPartAtom K p c₂ m * v.differentialCoeff ω := by
+  change algebraMap K[X] (RatFunc K) (c₁ + c₂) / (algebraMap K[X] (RatFunc K) p) ^ m
+        * v.differentialCoeff ω
+    = algebraMap K[X] (RatFunc K) c₁ / (algebraMap K[X] (RatFunc K) p) ^ m * v.differentialCoeff ω
+      + algebraMap K[X] (RatFunc K) c₂ / (algebraMap K[X] (RatFunc K) p) ^ m
+        * v.differentialCoeff ω
+  rw [map_add]; ring
+
+omit [DecidableEq (RatFunc K)] in
+omit [∀ (v : Place K (RatFunc K)), v.DCoordGenerates] [Nontrivial Ω[RatFunc K⁄K]] in
+theorem p1PrincipalPartAtom_C_mul_mul_differentialCoeff (p c : K[X]) (a : K) (m : ℕ)
+    (v : Place K (RatFunc K)) (ω : Ω[(RatFunc K)⁄K]) :
+    p1PrincipalPartAtom K p (C a * c) m * v.differentialCoeff ω
+      = a • (p1PrincipalPartAtom K p c m * v.differentialCoeff ω) := by
+  change algebraMap K[X] (RatFunc K) (C a * c) / (algebraMap K[X] (RatFunc K) p) ^ m
+        * v.differentialCoeff ω
+    = a • (algebraMap K[X] (RatFunc K) c / (algebraMap K[X] (RatFunc K) p) ^ m
+        * v.differentialCoeff ω)
+  rw [map_mul, C_eq_algebraMap, ← IsScalarTower.algebraMap_apply K K[X] (RatFunc K),
+    Algebra.smul_def]
+  ring
+
+omit [∀ (v : Place K (RatFunc K)), v.DCoordGenerates] [Nontrivial Ω[RatFunc K⁄K]] in
+theorem trace_placeInfty_simplePoleResidueAux_mOne_add
+    {p c₁ c₂ : K[X]} {ω : Ω[(RatFunc K)⁄K]}
+    (h1 : p1PrincipalPartAtom K p c₁ 1 * (placeInfty K).differentialCoeff ω
+        ∈ (placeInfty K).simplePoleSubmodule)
+    (h2 : p1PrincipalPartAtom K p c₂ 1 * (placeInfty K).differentialCoeff ω
+        ∈ (placeInfty K).simplePoleSubmodule)
+    (h12 : p1PrincipalPartAtom K p (c₁ + c₂) 1 * (placeInfty K).differentialCoeff ω
+        ∈ (placeInfty K).simplePoleSubmodule) :
+    Algebra.trace K (placeInfty K).ResidueField
+        ((placeInfty K).simplePoleResidueAux ⟨_, h12⟩)
+      = Algebra.trace K (placeInfty K).ResidueField
+          ((placeInfty K).simplePoleResidueAux ⟨_, h1⟩)
+        + Algebra.trace K (placeInfty K).ResidueField
+            ((placeInfty K).simplePoleResidueAux ⟨_, h2⟩) := by
+  have heq : (⟨_, h12⟩ : (placeInfty K).simplePoleSubmodule)
+      = (⟨_, h1⟩ : (placeInfty K).simplePoleSubmodule) + ⟨_, h2⟩ :=
+    Subtype.ext (p1PrincipalPartAtom_add_mul_differentialCoeff K p c₁ c₂ 1 _ ω)
+  rw [heq, map_add, map_add]
+
+omit [∀ (v : Place K (RatFunc K)), v.DCoordGenerates] [Nontrivial Ω[RatFunc K⁄K]] in
+theorem trace_placeInfty_simplePoleResidueAux_mOne_C_mul
+    {p c : K[X]} {a : K} {ω : Ω[(RatFunc K)⁄K]}
+    (hc : p1PrincipalPartAtom K p c 1 * (placeInfty K).differentialCoeff ω
+        ∈ (placeInfty K).simplePoleSubmodule)
+    (hac : p1PrincipalPartAtom K p (C a * c) 1 * (placeInfty K).differentialCoeff ω
+        ∈ (placeInfty K).simplePoleSubmodule) :
+    Algebra.trace K (placeInfty K).ResidueField
+        ((placeInfty K).simplePoleResidueAux ⟨_, hac⟩)
+      = a * Algebra.trace K (placeInfty K).ResidueField
+          ((placeInfty K).simplePoleResidueAux ⟨_, hc⟩) := by
+  have heq : (⟨_, hac⟩ : (placeInfty K).simplePoleSubmodule)
+      = a • (⟨_, hc⟩ : (placeInfty K).simplePoleSubmodule) :=
+    Subtype.ext (p1PrincipalPartAtom_C_mul_mul_differentialCoeff K p c a 1 _ ω)
+  rw [heq, map_smul, map_smul, smul_eq_mul]
+
+theorem p1PlaceInftySimplePoleResidueEulerValue_of_topDeg
+    (hInfty : (placeInfty K).ord ((placeInfty K).differentialCoeff (dX K)) = -2)
+    (htop : P1PlaceInftySimplePoleResidueEulerValueTopDeg K) :
+    P1PlaceInftySimplePoleResidueEulerValue K := by
+  intro p c hpmon hpirr hcdeg himem
+  rcases eq_or_ne c 0 with rfl | hc
+  · exact trace_placeInfty_simplePoleResidue_mOne_of_lowDeg K hInfty hpirr (.inl rfl) himem
+  have hndeg : c.natDegree < p.natDegree := natDegree_lt_natDegree hc hcdeg
+  rcases (by omega : c.natDegree + 2 ≤ p.natDegree ∨ c.natDegree + 1 = p.natDegree) with h | h
+  · exact trace_placeInfty_simplePoleResidue_mOne_of_lowDeg K hInfty hpirr (.inr h) himem
+  · exact htop p c hpmon hpirr hc h himem
+
+theorem p1PlaceInftySimplePoleResidueEulerValueTopDeg_of_monomial
+    (hInfty : (placeInfty K).ord ((placeInfty K).differentialCoeff (dX K)) = -2)
+    (hmono : P1PlaceInftySimplePoleResidueEulerValueMonomial K) :
+    P1PlaceInftySimplePoleResidueEulerValueTopDeg K := by
+  intro p c hpmon hpirr hc hcnd himem
+  have hInfty' : (placeInfty K).ordDifferential (dX K) = -2 := hInfty
+  have hXd : (X ^ (p.natDegree - 1) : K[X]).degree < p.degree := by
+    rw [degree_X_pow, degree_eq_natDegree hpirr.ne_zero]
+    exact_mod_cast (by omega : p.natDegree - 1 < p.natDegree)
+  have hXmem := p1MOneAtom_mul_differentialCoeff_mem_simplePole_placeInfty K
+    (dX_ne_zero K) hInfty' hpirr (X ^ (p.natDegree - 1)) hXd
+  have hCXmem : p1PrincipalPartAtom K p (C c.leadingCoeff * X ^ (p.natDegree - 1)) 1
+        * (placeInfty K).differentialCoeff (dX K)
+      ∈ (placeInfty K).simplePoleSubmodule := by
+    rw [p1PrincipalPartAtom_C_mul_mul_differentialCoeff K]
+    exact (placeInfty K).simplePoleSubmodule.smul_mem _ hXmem
+  have hELdeg : c.eraseLead = 0 ∨ c.eraseLead.natDegree + 2 ≤ p.natDegree := by
+    rcases Polynomial.eraseLead_natDegree_lt_or_eraseLead_eq_zero c with h | h
+    · exact .inr (by omega)
+    · exact .inl h
+  have hELmem : p1PrincipalPartAtom K p c.eraseLead 1 * (placeInfty K).differentialCoeff (dX K)
+      ∈ (placeInfty K).simplePoleSubmodule :=
+    (placeInfty K).mem_simplePoleSubmodule_of_mem
+      (p1MOneAtom_mul_differentialCoeff_dX_mem_placeInfty K hInfty hpirr.ne_zero hELdeg)
+  have hcnd' : c.natDegree = p.natDegree - 1 := by omega
+  have hcdecomp : c = C c.leadingCoeff * X ^ (p.natDegree - 1) + c.eraseLead := by
+    conv_lhs => rw [← Polynomial.eraseLead_add_C_mul_X_pow c, add_comm, hcnd']
+  have h12mem : p1PrincipalPartAtom K p
+        (C c.leadingCoeff * X ^ (p.natDegree - 1) + c.eraseLead) 1
+          * (placeInfty K).differentialCoeff (dX K)
+      ∈ (placeInfty K).simplePoleSubmodule := by
+    rw [p1PrincipalPartAtom_add_mul_differentialCoeff K]; exact add_mem hCXmem hELmem
+  have heq : (⟨_, himem⟩ : (placeInfty K).simplePoleSubmodule) = ⟨_, h12mem⟩ := by
+    refine Subtype.ext ?_
+    change algebraMap K[X] (RatFunc K) c / (algebraMap K[X] (RatFunc K) p) ^ 1
+          * (placeInfty K).differentialCoeff (dX K)
+      = algebraMap K[X] (RatFunc K) (C c.leadingCoeff * X ^ (p.natDegree - 1) + c.eraseLead)
+          / (algebraMap K[X] (RatFunc K) p) ^ 1 * (placeInfty K).differentialCoeff (dX K)
+    rw [← hcdecomp]
+  have hELcoeff : c.eraseLead.coeff (p.natDegree - 1) = 0 := by
+    rcases hELdeg with h | h
+    · rw [h, coeff_zero]
+    · exact coeff_eq_zero_of_natDegree_lt (by omega)
+  have hLead : c.leadingCoeff = c.coeff (p.natDegree - 1) := by
+    rw [leadingCoeff, hcnd']
+  rw [heq, trace_placeInfty_simplePoleResidueAux_mOne_add K hCXmem hELmem,
+    trace_placeInfty_simplePoleResidueAux_mOne_C_mul K hXmem,
+    hmono p hpmon hpirr hXmem,
+    trace_placeInfty_simplePoleResidue_mOne_of_lowDeg K hInfty hpirr hELdeg hELmem,
+    hELcoeff, _root_.neg_zero, add_zero, hLead]
+  ring
+
+theorem p1PlaceInftySimplePoleResidueEulerValue_of_monomial
+    (hInfty : (placeInfty K).ord ((placeInfty K).differentialCoeff (dX K)) = -2)
+    (hmono : P1PlaceInftySimplePoleResidueEulerValueMonomial K) :
+    P1PlaceInftySimplePoleResidueEulerValue K :=
+  p1PlaceInftySimplePoleResidueEulerValue_of_topDeg K hInfty
+    (p1PlaceInftySimplePoleResidueEulerValueTopDeg_of_monomial K hInfty hmono)
+
+end EraseLeadLinearity
+section ComposedEngine
+
+variable [CharZero K]
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+theorem p1PrincipalPartMOneSimplePoleCancel_of_inftyMonomial
+    (hwd : OrdDifferentialWellDefined K (RatFunc K))
+    {ω₀ : Ω[(RatFunc K)⁄K]} (hω₀ : ω₀ ≠ 0) (heq : ω₀ = dX K)
+    (hmono : P1PlaceInftySimplePoleResidueEulerValueMonomial K) :
+    P1PrincipalPartMOneSimplePoleCancel K hω₀ :=
+  p1PrincipalPartMOneSimplePoleCancel_of_inftyBridge K hω₀ heq
+    (p1PlaceInftySimplePoleResidueEulerValue_of_monomial K
+      (ordDifferential_placeInfty_D_ratFuncX K hwd) hmono)
+
+end ComposedEngine
+end AlgebraicCurve
+end
+section
+
+namespace IntermediateField
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem adjoin_simple_inv (t : F) : K⟮t⁻¹⟯ = K⟮t⟯ := by
+  refine le_antisymm (adjoin_simple_le_iff.mpr ?_) (adjoin_simple_le_iff.mpr ?_)
+  · exact inv_mem (mem_adjoin_simple_self K t)
+  · have h : (t⁻¹)⁻¹ ∈ (K⟮t⁻¹⟯ : IntermediateField K F) :=
+      inv_mem (mem_adjoin_simple_self K t⁻¹)
+    rwa [inv_inv] at h
+
+theorem algebraMap_comp_equivOfEq {S T : IntermediateField K F} (h : S = T) :
+    (algebraMap T F).comp ((IntermediateField.equivOfEq h).toRingEquiv : S →+* T)
+      = ((RingEquiv.refl F : F ≃+* F) : F →+* F).comp (algebraMap S F) := by
+  ext x; rfl
+
+theorem finiteDimensional_of_eq {S T : IntermediateField K F} (h : S = T)
+    [FiniteDimensional ↥S F] : FiniteDimensional ↥T F :=
+  Module.Finite.of_equiv_equiv (IntermediateField.equivOfEq h).toRingEquiv (RingEquiv.refl F)
+    (algebraMap_comp_equivOfEq h)
+
+theorem isSeparable_of_eq {S T : IntermediateField K F} (h : S = T)
+    [Algebra.IsSeparable ↥S F] : Algebra.IsSeparable ↥T F :=
+  Algebra.IsSeparable.of_equiv_equiv (IntermediateField.equivOfEq h).toRingEquiv
+    (RingEquiv.refl F) (algebraMap_comp_equivOfEq h)
+
+theorem finiteDimensional_adjoin_inv (t : F) [FiniteDimensional K⟮t⟯ F] :
+    FiniteDimensional K⟮t⁻¹⟯ F :=
+  finiteDimensional_of_eq (adjoin_simple_inv t).symm
+
+theorem isSeparable_adjoin_inv (t : F) [Algebra.IsSeparable K⟮t⟯ F] :
+    Algebra.IsSeparable K⟮t⁻¹⟯ F :=
+  isSeparable_of_eq (adjoin_simple_inv t).symm
+
+end IntermediateField
+namespace AlgebraicCurve
+
+section CharZeroSeparable
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem isSeparable_of_charZero_of_finiteDimensional [CharZero K]
+    (S : IntermediateField K F) [FiniteDimensional ↥S F] :
+    Algebra.IsSeparable ↥S F :=
+  haveI : CharZero ↥S := IntermediateField.charZero S
+  Algebra.IsSeparable.of_integral ↥S F
+
+theorem isSeparable_adjoin_of_charZero_of_finiteDimensional [CharZero K] (t : F)
+    [FiniteDimensional K⟮t⟯ F] : Algebra.IsSeparable K⟮t⟯ F :=
+  isSeparable_of_charZero_of_finiteDimensional K⟮t⟯
+
+end CharZeroSeparable
+section SeparatingTranscendentalCore
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def HasSeparatingTranscendentalCore : Prop :=
+  ∃ t : F, Transcendental K t ∧ FiniteDimensional K⟮t⟯ F
+
+variable {K F}
+
+theorem hasSeparatingTranscendental_of_core [CharZero K]
+    (h : HasSeparatingTranscendentalCore K F) :
+    HasSeparatingTranscendental K F := by
+  obtain ⟨t, ht, hfin⟩ := h
+  have : Algebra.IsSeparable K⟮t⟯ F :=
+    isSeparable_adjoin_of_charZero_of_finiteDimensional t
+  exact ⟨t, ht, hfin, ‹_›,
+    IntermediateField.finiteDimensional_adjoin_inv t,
+    IntermediateField.isSeparable_adjoin_inv t⟩
+
+theorem valSubringKaehlerFinite_of_core [CharZero K]
+    (h : HasSeparatingTranscendentalCore K F) :
+    ValSubringKaehlerFinite K F :=
+  valSubringKaehlerFinite_of_hasSeparatingTranscendental
+    (hasSeparatingTranscendental_of_core h)
+
+end SeparatingTranscendentalCore
+end AlgebraicCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+
+section MonicRatioResidue
+
+theorem ord_placeInfty_X_pow_natDegree_div {p : K[X]} (hp : p ≠ 0) :
+    (placeInfty K).ord
+        (algebraMap K[X] (RatFunc K) (X ^ p.natDegree) / algebraMap K[X] (RatFunc K) p) = 0 := by
+  have hp' : algebraMap K[X] (RatFunc K) p ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hp
+  have hXd : (X ^ p.natDegree : K[X]) ≠ 0 := pow_ne_zero _ X_ne_zero
+  have hXd' : algebraMap K[X] (RatFunc K) (X ^ p.natDegree) ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hXd
+  rw [div_eq_mul_inv, (placeInfty K).ord_mul hXd' (inv_ne_zero hp'),
+    (placeInfty K).ord_inv, ord_placeInfty_algebraMap' K hXd, ord_placeInfty_algebraMap' K hp,
+    natDegree_X_pow]
+  ring
+
+theorem X_pow_natDegree_div_mem_placeInfty {p : K[X]} (hp : p ≠ 0) :
+    algebraMap K[X] (RatFunc K) (X ^ p.natDegree) / algebraMap K[X] (RatFunc K) p
+      ∈ (placeInfty K).toValuationSubring := by
+  have hp' : algebraMap K[X] (RatFunc K) p ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hp
+  have hXd' : algebraMap K[X] (RatFunc K) (X ^ p.natDegree) ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr
+      (pow_ne_zero _ X_ne_zero)
+  exact (placeInfty K).mem_of_ord_nonneg (div_ne_zero hXd' hp')
+    (ord_placeInfty_X_pow_natDegree_div K hp).ge
+
+omit [DecidableEq (RatFunc K)] in
+theorem degree_X_pow_natDegree_sub_lt_of_monic {p : K[X]} (hpmon : p.Monic) :
+    ((X : K[X]) ^ p.natDegree - p).degree < p.degree := by
+  classical
+  have hdeg : ((X : K[X]) ^ p.natDegree).degree = p.degree := by
+    rw [degree_X_pow, degree_eq_natDegree hpmon.ne_zero]
+  refine (Polynomial.degree_sub_lt_left hdeg (pow_ne_zero _ X_ne_zero) ?_).trans_le hdeg.le
+  rw [Polynomial.leadingCoeff_X_pow, hpmon]
+
+theorem residue_placeInfty_X_pow_natDegree_div_monic_eq_one {p : K[X]} (hpmon : p.Monic) :
+    IsLocalRing.residue _ ⟨_, X_pow_natDegree_div_mem_placeInfty K hpmon.ne_zero⟩
+      = (1 : (placeInfty K).ResidueField) := by
+  rw [← sub_eq_zero, show (1 : (placeInfty K).ResidueField) = IsLocalRing.residue _ 1 from
+      (map_one _).symm, ← map_sub, IsLocalRing.residue_eq_zero_iff]
+  set d := p.natDegree
+  have hp' : algebraMap K[X] (RatFunc K) p ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hpmon.ne_zero
+  have hsubmem : algebraMap K[X] (RatFunc K) (X ^ d - p) / algebraMap K[X] (RatFunc K) p
+      ∈ (placeInfty K).toValuationSubring := by
+    rcases eq_or_ne ((X : K[X]) ^ d - p) 0 with h0 | h0
+    · simp only [h0, _root_.map_zero, zero_div]; exact zero_mem _
+    have h0' : algebraMap K[X] (RatFunc K) (X ^ d - p) ≠ 0 :=
+      (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr h0
+    refine (placeInfty K).mem_of_ord_nonneg (div_ne_zero h0' hp') ?_
+    rw [div_eq_mul_inv, (placeInfty K).ord_mul h0' (inv_ne_zero hp'),
+      (placeInfty K).ord_inv, ord_placeInfty_algebraMap' K h0,
+      ord_placeInfty_algebraMap' K hpmon.ne_zero]
+    have hlt : ((X : K[X]) ^ d - p).natDegree < d :=
+      Polynomial.natDegree_lt_natDegree h0 (degree_X_pow_natDegree_sub_lt_of_monic K hpmon)
+    omega
+  have hcoe : (⟨_, X_pow_natDegree_div_mem_placeInfty K hpmon.ne_zero⟩
+        - 1 : (placeInfty K).toValuationSubring)
+      = ⟨_, hsubmem⟩ := by
+    refine Subtype.ext ?_
+    change algebraMap K[X] (RatFunc K) (X ^ d) / algebraMap K[X] (RatFunc K) p - 1
+      = algebraMap K[X] (RatFunc K) (X ^ d - p) / algebraMap K[X] (RatFunc K) p
+    rw [map_sub, sub_div, div_self hp']
+  rw [hcoe, Place.mk_mem_maximalIdeal_iff]
+  rcases eq_or_ne ((X : K[X]) ^ d - p) 0 with h0 | h0
+  · exact .inl (by simp [h0])
+  · refine .inr ?_
+    have h0' : algebraMap K[X] (RatFunc K) (X ^ d - p) ≠ 0 :=
+      (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr h0
+    rw [div_eq_mul_inv, (placeInfty K).ord_mul h0' (inv_ne_zero hp'),
+      (placeInfty K).ord_inv, ord_placeInfty_algebraMap' K h0,
+      ord_placeInfty_algebraMap' K hpmon.ne_zero]
+    have hlt : ((X : K[X]) ^ d - p).natDegree < d :=
+      Polynomial.natDegree_lt_natDegree h0 (degree_X_pow_natDegree_sub_lt_of_monic K hpmon)
+    omega
+
+end MonicRatioResidue
+section NamedCarrier
+
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+def P1PlaceInftySimplePoleResidueEulerValueX : Prop :=
+  ∀ (himem : p1PrincipalPartAtom K (X : K[X]) 1 1 * (placeInfty K).differentialCoeff (dX K)
+        ∈ (placeInfty K).simplePoleSubmodule),
+    Algebra.trace K (placeInfty K).ResidueField
+        ((placeInfty K).simplePoleResidueAux ⟨_, himem⟩)
+      = -1
+
+end NamedCarrier
+section MonicRatioReduction
+
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+omit [∀ (v : Place K (RatFunc K)), v.DCoordGenerates] [Nontrivial Ω[RatFunc K⁄K]] in
+theorem p1MonomialAtom_eq_monicRatio_mul {p : K[X]} (hpdeg : 1 ≤ p.natDegree) :
+    p1PrincipalPartAtom K p (X ^ (p.natDegree - 1)) 1 * (placeInfty K).differentialCoeff (dX K)
+      = (algebraMap K[X] (RatFunc K) (X ^ p.natDegree) / algebraMap K[X] (RatFunc K) p)
+        * (p1PrincipalPartAtom K (X : K[X]) 1 1
+            * (placeInfty K).differentialCoeff (dX K)) := by
+  change algebraMap K[X] (RatFunc K) (X ^ (p.natDegree - 1)) / algebraMap K[X] (RatFunc K) p ^ 1
+        * (placeInfty K).differentialCoeff (dX K)
+    = algebraMap K[X] (RatFunc K) (X ^ p.natDegree) / algebraMap K[X] (RatFunc K) p
+        * (algebraMap K[X] (RatFunc K) 1 / algebraMap K[X] (RatFunc K) X ^ 1
+            * (placeInfty K).differentialCoeff (dX K))
+  have hXd : algebraMap K[X] (RatFunc K) (X ^ p.natDegree)
+      = algebraMap K[X] (RatFunc K) (X ^ (p.natDegree - 1)) * algebraMap K[X] (RatFunc K) X := by
+    rw [← map_mul, ← pow_succ, Nat.sub_add_cancel hpdeg]
+  have hX0 : algebraMap K[X] (RatFunc K) (X : K[X]) ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr X_ne_zero
+  rw [pow_one, pow_one, map_one, hXd, one_div]
+  field_simp
+
+theorem p1XInvAtom_mul_differentialCoeff_dX_mem_simplePole_placeInfty
+    (hInfty : (placeInfty K).ordDifferential (dX K) = -2) :
+    p1PrincipalPartAtom K (X : K[X]) 1 1 * (placeInfty K).differentialCoeff (dX K)
+      ∈ (placeInfty K).simplePoleSubmodule :=
+  p1MOneAtom_mul_differentialCoeff_mem_simplePole_placeInfty K (dX_ne_zero K) hInfty
+    irreducible_X 1 (by rw [degree_one, degree_X]; decide)
+
+theorem simplePoleResidueAux_placeInfty_monomial_eq_X
+    (hInfty : (placeInfty K).ordDifferential (dX K) = -2)
+    {p : K[X]} (hpmon : p.Monic) (hpirr : Irreducible p)
+    (himem : p1PrincipalPartAtom K p (X ^ (p.natDegree - 1)) 1
+          * (placeInfty K).differentialCoeff (dX K)
+        ∈ (placeInfty K).simplePoleSubmodule) :
+    (placeInfty K).simplePoleResidueAux ⟨_, himem⟩
+      = (placeInfty K).simplePoleResidueAux
+          ⟨_, p1XInvAtom_mul_differentialCoeff_dX_mem_simplePole_placeInfty K hInfty⟩ := by
+  set hXmem := p1XInvAtom_mul_differentialCoeff_dX_mem_simplePole_placeInfty K hInfty
+  have hfact := p1MonomialAtom_eq_monicRatio_mul K hpirr.natDegree_pos
+  have hRatioMem := X_pow_natDegree_div_mem_placeInfty K hpmon.ne_zero
+  have hprodmem : (algebraMap K[X] (RatFunc K) (X ^ p.natDegree)
+          / algebraMap K[X] (RatFunc K) p)
+        * (p1PrincipalPartAtom K (X : K[X]) 1 1 * (placeInfty K).differentialCoeff (dX K))
+      ∈ (placeInfty K).simplePoleSubmodule :=
+    (placeInfty K).mul_mem_simplePoleSubmodule_of_mem hRatioMem hXmem
+  have heq : (⟨_, himem⟩ : (placeInfty K).simplePoleSubmodule) = ⟨_, hprodmem⟩ :=
+    Subtype.ext hfact
+  rw [heq, (placeInfty K).simplePoleResidueAux_mul_of_mem hRatioMem hXmem,
+    residue_placeInfty_X_pow_natDegree_div_monic_eq_one K hpmon, one_mul]
+
+theorem p1PlaceInftySimplePoleResidueEulerValueMonomial_of_X
+    (hInfty : (placeInfty K).ordDifferential (dX K) = -2)
+    (hX : P1PlaceInftySimplePoleResidueEulerValueX K) :
+    P1PlaceInftySimplePoleResidueEulerValueMonomial K := by
+  intro p hpmon hpirr himem
+  rw [simplePoleResidueAux_placeInfty_monomial_eq_X K hInfty hpmon hpirr himem]
+  exact hX _
+
+end MonicRatioReduction
+section ComposedEngine
+
+variable [CharZero K]
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+theorem p1PrincipalPartMOneSimplePoleCancel_of_inftyX
+    (hwd : OrdDifferentialWellDefined K (RatFunc K))
+    {ω₀ : Ω[(RatFunc K)⁄K]} (hω₀ : ω₀ ≠ 0) (heq : ω₀ = dX K)
+    (hX : P1PlaceInftySimplePoleResidueEulerValueX K) :
+    P1PrincipalPartMOneSimplePoleCancel K hω₀ :=
+  p1PrincipalPartMOneSimplePoleCancel_of_inftyMonomial K hwd hω₀ heq
+    (p1PlaceInftySimplePoleResidueEulerValueMonomial_of_X K
+      (ordDifferential_placeInfty_D_ratFuncX K hwd) hX)
+
+end ComposedEngine
+end AlgebraicCurve
+end
+section
+
+namespace IntermediateField
+
+variable {K E : Type*} [Field K] [Field E] [Algebra K E]
+
+theorem finiteDimensional_top : FiniteDimensional ↥(⊤ : IntermediateField K E) E :=
+  Module.Finite.of_surjective (Algebra.linearMap (↥(⊤ : IntermediateField K E)) E)
+    fun x => ⟨⟨x, mem_top⟩, rfl⟩
+
+theorem adjoin_simple_gen_eq_top (α : E) :
+    K⟮AdjoinSimple.gen K α⟯ = (⊤ : IntermediateField K ↥K⟮α⟯) :=
+  (K⟮α⟯).lift_injective <| by
+    rw [lift_adjoin_simple, AdjoinSimple.coe_gen, lift_top]
+
+theorem transcendental_gen {α : E} (hα : Transcendental K α) :
+    Transcendental K (AdjoinSimple.gen K α) := by
+  rw [show α = algebraMap K⟮α⟯ E (AdjoinSimple.gen K α) from
+    (AdjoinSimple.algebraMap_gen K α).symm] at hα
+  exact (transcendental_algebraMap_iff (algebraMap K⟮α⟯ E).injective).mp hα
+
+end IntermediateField
+namespace AlgebraicCurve
+
+section PurelyTranscendentalSimple
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def IsPurelyTranscendentalSimple : Prop :=
+  ∃ t : F, Transcendental K t ∧ K⟮t⟯ = (⊤ : IntermediateField K F)
+
+variable {K F}
+
+theorem hasSeparatingTranscendentalCore_of_isPurelyTranscendentalSimple
+    (h : IsPurelyTranscendentalSimple K F) :
+    HasSeparatingTranscendentalCore K F := by
+  obtain ⟨t, ht, htop⟩ := h
+  have : FiniteDimensional ↥(⊤ : IntermediateField K F) F :=
+    IntermediateField.finiteDimensional_top
+  exact ⟨t, ht, IntermediateField.finiteDimensional_of_eq htop.symm⟩
+
+end PurelyTranscendentalSimple
+section SelfAdjoinInstance
+
+variable {K E : Type*} [Field K] [Field E] [Algebra K E]
+
+theorem isPurelyTranscendentalSimple_adjoin_simple {α : E} (hα : Transcendental K α) :
+    IsPurelyTranscendentalSimple K ↥K⟮α⟯ :=
+  ⟨AdjoinSimple.gen K α, IntermediateField.transcendental_gen hα,
+    IntermediateField.adjoin_simple_gen_eq_top α⟩
+
+end SelfAdjoinInstance
+end AlgebraicCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] [HasCanonicalLocalResidueKStar K F]
+
+section NamedRow
+
+variable (K F)
+variable [∀ v : Place K F, v.DCoordGenerates] [Nontrivial Ω[F⁄K]]
+
+def CanonicalLocalResidueKSimplePoleCoordIndep : Prop :=
+  ∀ (v : Place K F) (π' : F), v.ord π' = 1 →
+    ∀ (R : v.CanonicalLocalResidueDataK),
+      R.res (v.differentialCoeff (KaehlerDifferential.D K F π') * (π')⁻¹) = 1
+
+end NamedRow
+section XInvCoordinate
+
+variable (K) [DecidableEq (RatFunc K)]
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+theorem p1XAtom_mul_differentialCoeff_dX_eq_neg :
+    p1PrincipalPartAtom K (X : K[X]) 1 1 * (placeInfty K).differentialCoeff (dX K)
+      = -((placeInfty K).differentialCoeff
+            (KaehlerDifferential.D K (RatFunc K) (RatFunc.X : RatFunc K)⁻¹)
+          * ((RatFunc.X : RatFunc K)⁻¹)⁻¹) := by
+  change algebraMap K[X] (RatFunc K) 1 / algebraMap K[X] (RatFunc K) X ^ 1
+        * (placeInfty K).differentialCoeff (dX K)
+      = -((placeInfty K).differentialCoeff
+            (KaehlerDifferential.D K (RatFunc K) (RatFunc.X : RatFunc K)⁻¹)
+          * ((RatFunc.X : RatFunc K)⁻¹)⁻¹)
+  rw [show (dX K) = KaehlerDifferential.D K (RatFunc K) RatFunc.X from rfl,
+    differentialCoeff_placeInfty_D_X_eq K, RatFunc.algebraMap_X, map_one, pow_one, inv_inv,
+    one_div]
+  field_simp [RatFunc.X_ne_zero (K := K), sq, mul_comm]
+
+end XInvCoordinate
+section InftyXDischarge
+
+variable (K) [DecidableEq (RatFunc K)]
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+omit [∀ (v : Place K (RatFunc K)), v.DCoordGenerates] [Nontrivial Ω[RatFunc K⁄K]] in
+theorem trace_placeInfty_residueField_one :
+    Algebra.trace K (placeInfty K).ResidueField 1 = 1 := by
+  rw [show (1 : (placeInfty K).ResidueField) = algebraMap K _ 1 from (map_one _).symm,
+    Algebra.trace_algebraMap, show Module.finrank K (placeInfty K).ResidueField = 1 from
+      deg_placeInfty K, one_smul]
+
+theorem simplePoleResidueAux_placeInfty_p1XAtom_eq_neg_one
+    (hsp : CanonicalLocalResidueKSimplePoleCoordIndep K (RatFunc K))
+    (himem : p1PrincipalPartAtom K (X : K[X]) 1 1 * (placeInfty K).differentialCoeff (dX K)
+        ∈ (placeInfty K).simplePoleSubmodule) :
+    (placeInfty K).simplePoleResidueAux ⟨_, himem⟩ = -1 := by
+  set R := (placeInfty K).canonicalLocalResidueDataKOfExtend
+  rw [← (placeInfty K).localResidueData_res_eq_simplePoleResidueAux R.toLocalResidueData himem,
+    show R.toLocalResidueData.res = R.res from rfl,
+    p1XAtom_mul_differentialCoeff_dX_eq_neg K, _root_.map_neg,
+    hsp (placeInfty K) (RatFunc.X : RatFunc K)⁻¹ (ord_placeInfty_X_inv K) R]
+
+theorem p1PlaceInftySimplePoleResidueEulerValueX_of_simplePoleCoordIndep
+    (hsp : CanonicalLocalResidueKSimplePoleCoordIndep K (RatFunc K)) :
+    P1PlaceInftySimplePoleResidueEulerValueX K := by
+  intro himem
+  rw [simplePoleResidueAux_placeInfty_p1XAtom_eq_neg_one K hsp himem, _root_.map_neg,
+    trace_placeInfty_residueField_one K]
+
+end InftyXDischarge
+section ComposedEngine
+
+variable (K) [DecidableEq (RatFunc K)] [CharZero K]
+variable [∀ v : Place K (RatFunc K), v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+
+theorem p1PrincipalPartMOneSimplePoleCancel_of_simplePoleCoordIndep
+    (hwd : OrdDifferentialWellDefined K (RatFunc K))
+    {ω₀ : Ω[(RatFunc K)⁄K]} (hω₀ : ω₀ ≠ 0) (heq : ω₀ = dX K)
+    (hsp : CanonicalLocalResidueKSimplePoleCoordIndep K (RatFunc K)) :
+    P1PrincipalPartMOneSimplePoleCancel K hω₀ :=
+  p1PrincipalPartMOneSimplePoleCancel_of_inftyX K hwd hω₀ heq
+    (p1PlaceInftySimplePoleResidueEulerValueX_of_simplePoleCoordIndep K hsp)
+
+end ComposedEngine
+end AlgebraicCurve
+end
+section
+
+namespace IntermediateField
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+
+theorem adjoin_simple_map_algHom' (e : F →ₐ[K] F') (t : F) :
+    (K⟮t⟯).map e = K⟮e t⟯ := by
+  rw [adjoin_map, Set.image_singleton]
+
+theorem adjoin_simple_eq_top_of_algEquiv (e : F ≃ₐ[K] F') {t : F}
+    (htop : K⟮t⟯ = (⊤ : IntermediateField K F)) :
+    K⟮e t⟯ = (⊤ : IntermediateField K F') := by
+  have key : K⟮(e : F →ₐ[K] F') t⟯ = (⊤ : IntermediateField K F') := by
+    rw [← adjoin_simple_map_algHom' (e : F →ₐ[K] F') t, htop,
+      ← AlgHom.fieldRange_eq_map, AlgEquiv.fieldRange_eq_top]
+  exact key
+
+end IntermediateField
+namespace AlgebraicCurve
+
+section Congr
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+
+theorem IsPurelyTranscendentalSimple.congr (e : F ≃ₐ[K] F')
+    (h : IsPurelyTranscendentalSimple K F) : IsPurelyTranscendentalSimple K F' := by
+  obtain ⟨t, ht, htop⟩ := h
+  refine ⟨e t, ?_, IntermediateField.adjoin_simple_eq_top_of_algEquiv e htop⟩
+  unfold Transcendental at ht ⊢
+  rw [show (e t : F') = (e : F →ₐ[K] F') t from rfl,
+    isAlgebraic_algHom_iff (e : F →ₐ[K] F') e.injective]
+  exact ht
+
+end Congr
+section RatFuncInstance
+
+variable (K : Type*) [Field K]
+
+theorem isPurelyTranscendentalSimple_ratFunc :
+    IsPurelyTranscendentalSimple K (RatFunc K) :=
+  (isPurelyTranscendentalSimple_adjoin_simple (RatFunc.transcendental_X (K := K))).congr
+    (RatFunc.algEquivOfTranscendental (RatFunc.X : RatFunc K)
+      (RatFunc.transcendental_X (K := K))).symm
+
+end RatFuncInstance
+section Iff
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem isPurelyTranscendentalSimple_of_ratFuncAlgEquiv
+    (h : Nonempty (RatFunc K ≃ₐ[K] F)) : IsPurelyTranscendentalSimple K F :=
+  (isPurelyTranscendentalSimple_ratFunc K).congr h.some
+
+end Iff
+end AlgebraicCurve
+end
+section
+
+namespace AlgebraicCurve
+
+section AbstractEngine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem Place.dCoordGenerates_of_valSubringKaehlerSpanTop
+    (hspan : ValSubringKaehlerSpanTop K F) (v : Place K F) :
+    v.DCoordGenerates := by
+  constructor
+  rw [eq_top_iff,
+    ← KaehlerDifferential.span_range_map_derivation_of_isLocalization (R := K)
+      (S := v.toValuationSubring) (T := F) (nonZeroDivisors v.toValuationSubring),
+    Submodule.span_le]
+  rintro _ ⟨f, rfl⟩
+  have hDf : KaehlerDifferential.D K v.toValuationSubring f
+      ∈ (⊤ : Submodule v.toValuationSubring Ω[v.toValuationSubring⁄K]) := Submodule.mem_top
+  rw [← hspan v] at hDf
+  have hmap : (KaehlerDifferential.map K K v.toValuationSubring F ∘
+        KaehlerDifferential.D K v.toValuationSubring) f
+      ∈ Submodule.map (KaehlerDifferential.map K K v.toValuationSubring F)
+        (Submodule.span v.toValuationSubring _) :=
+    Submodule.mem_map_of_mem hDf
+  rw [Submodule.map_span, Set.image_singleton,
+    v.kaehlerMap_subring_D_uniformizer] at hmap
+  exact Submodule.span_le_restrictScalars v.toValuationSubring F {v.dCoord} hmap
+
+theorem Place.dCoordGenerates_of_valSubringKaehlerFinite_of_charZero
+    [CharZero K] [∀ v : Place K F, v.FiniteResidue]
+    (hfin : ValSubringKaehlerFinite K F) (v : Place K F) :
+    v.DCoordGenerates :=
+  Place.dCoordGenerates_of_valSubringKaehlerSpanTop
+    (valSubringKaehlerSpanTop_of_kaehlerFinite_of_charZero hfin) v
+
+end AbstractEngine
+section ChainComposites
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+variable [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+
+theorem Place.dCoordGenerates_of_isPurelyTranscendentalSimple
+    [CharZero K] [∀ v : Place K F, v.FiniteResidue]
+    (h : IsPurelyTranscendentalSimple K F) (v : Place K F) :
+    v.DCoordGenerates :=
+  Place.dCoordGenerates_of_valSubringKaehlerFinite_of_charZero
+    (valSubringKaehlerFinite_of_core
+      (hasSeparatingTranscendentalCore_of_isPurelyTranscendentalSimple h)) v
+
+end ChainComposites
+end AlgebraicCurve
+namespace ModularCurve
+
+variable (N : ℕ) [NeZero N]
+
+theorem gate_dCoordGenerates_of_ratFunc_sat
+    {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [CharZero K] [∀ v : Place K F, v.FiniteResidue]
+    (hRat : Nonempty (RatFunc K ≃ₐ[K] F)) (v : Place K F) :
+    v.DCoordGenerates :=
+  Place.dCoordGenerates_of_isPurelyTranscendentalSimple
+    (isPurelyTranscendentalSimple_of_ratFuncAlgEquiv hRat) v
+
+end ModularCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+namespace RationalFunctionField
+
+variable {K : Type*} [Field K]
+
+scoped instance (priority := low) instDCoordGenerates [CharZero K] (v : Place K (RatFunc K)) :
+    v.DCoordGenerates :=
+  ModularCurve.gate_dCoordGenerates_of_ratFunc_sat ⟨AlgEquiv.refl⟩ v
+
+end RationalFunctionField
+end AlgebraicCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+section KaehlerToolbox
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] [HasCanonicalLocalResidueKStar K F]
+
+omit [HasCanonicalLocalResidueKStar K F] in
+theorem D_pow_succ_inv (f : F) (m : ℕ) :
+    KaehlerDifferential.D K F ((f ^ (m + 1))⁻¹)
+      = (-((m + 1 : ℕ) : F) * (f ^ (m + 2))⁻¹) • KaehlerDifferential.D K F f := by
+  rw [← inv_pow f (m + 1), Derivation.leibniz_pow, Derivation.leibniz_inv, Nat.add_sub_cancel,
+    smul_smul, ← Nat.cast_smul_eq_nsmul F (m + 1), smul_smul, ← inv_pow f (m + 2)]
+  congr 1
+  push_cast
+  ring
+
+namespace Place
+
+variable (v : Place K F)
+
+omit [HasCanonicalLocalResidueKStar K F] in
+private theorem differentialCoeff_add'' [v.DCoordGenerates]
+    [Nontrivial Ω[F⁄K]] (ω₁ ω₂ : Ω[F⁄K]) :
+    v.differentialCoeff (ω₁ + ω₂) = v.differentialCoeff ω₁ + v.differentialCoeff ω₂ :=
+  v.differentialCoeff_unique (by
+    rw [add_smul, v.differentialCoeff_smul_dCoord, v.differentialCoeff_smul_dCoord])
+
+omit [HasCanonicalLocalResidueKStar K F] in
+private theorem differentialCoeff_D_uniformizer_pow_inv
+    [v.DCoordGenerates] [Nontrivial Ω[F⁄K]]
+    (m : ℕ) :
+    v.differentialCoeff (KaehlerDifferential.D K F ((v.uniformizer ^ (m + 1))⁻¹))
+      = -((m + 1 : ℕ) : F) * (v.uniformizer ^ (m + 2))⁻¹ := by
+  rw [D_pow_succ_inv, show KaehlerDifferential.D K F v.uniformizer = v.dCoord from rfl,
+    v.differentialCoeff_smul, v.differentialCoeff_dCoord, mul_one]
+
+end Place
+end KaehlerToolbox
+section DXCoeffIntegrality
+
+variable {K : Type*} [Field K]
+
+theorem ratFuncDXCoeff_eq_of_D_eq_smul_dX {f e : RatFunc K}
+    (h : KaehlerDifferential.D K (RatFunc K) f = e • dX K) : ratFuncDXCoeff K f = e := by
+  have key : (ratFuncDXCoeff K f - e) • dX K = 0 := by
+    rw [sub_smul, ← D_eq_ratFuncDXCoeff_smul_dX K f, h, sub_self]
+  rcases smul_eq_zero.mp key with h' | h'
+  · exact sub_eq_zero.mp h'
+  · exact absurd h' (dX_ne_zero K)
+
+theorem ratFuncDXCoeff_zero : ratFuncDXCoeff K (0 : RatFunc K) = 0 :=
+  ratFuncDXCoeff_eq_of_D_eq_smul_dX (by rw [_root_.map_zero, zero_smul])
+
+section FinitePlaces
+
+variable {w : HeightOneSpectrum K[X]}
+
+local notation "vw" => Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w
+
+theorem ord_algebraMap_denom_eq_zero_of_ord_nonneg {p : K[X]}
+    (hp : Irreducible p) (hwp : w.asIdeal = Ideal.span {p}) {f : RatFunc K}
+    (hf : f ≠ 0) (hord : 0 ≤ (vw).ord f) :
+    (vw).ord (algebraMap K[X] (RatFunc K) f.denom) = 0 := by
+  by_contra hne
+  have hpd : p ∣ f.denom := by
+    rw [← Ideal.mem_span_singleton, ← hwp]
+    exact (Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w
+      f.denom_ne_zero).mp hne
+  have hpn : ¬ p ∣ f.num := fun hpn =>
+    hp.not_isUnit (f.isCoprime_num_denom.isUnit_of_dvd' hpn hpd)
+  have hordn : (vw).ord (algebraMap K[X] (RatFunc K) f.num) = 0 := by
+    by_contra h
+    exact hpn (by
+      rw [← Ideal.mem_span_singleton, ← hwp]
+      exact (Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w
+        (RatFunc.num_ne_zero hf)).mp h)
+  have hordd : 0 < (vw).ord (algebraMap K[X] (RatFunc K) f.denom) :=
+    lt_of_le_of_ne ((vw).ord_nonneg_of_mem (algebraMap_mem_ofHeightOneSpectrum K w _))
+      (Ne.symm hne)
+  have hnum0 : algebraMap K[X] (RatFunc K) f.num ≠ 0 :=
+    RatFunc.algebraMap_ne_zero (RatFunc.num_ne_zero hf)
+  have hden0 : algebraMap K[X] (RatFunc K) f.denom ≠ 0 :=
+    RatFunc.algebraMap_ne_zero f.denom_ne_zero
+  rw [← f.num_div_denom, div_eq_mul_inv, (vw).ord_mul hnum0 (inv_ne_zero hden0),
+    (vw).ord_inv, hordn] at hord
+  omega
+
+theorem ratFuncDXCoeff_eq_zero_or_ord_nonneg_of_ord_nonneg {p : K[X]}
+    (hp : Irreducible p) (hwp : w.asIdeal = Ideal.span {p}) {g : RatFunc K}
+    (hg : g ≠ 0) (hord : 0 ≤ (vw).ord g) :
+    ratFuncDXCoeff K g = 0 ∨ 0 ≤ (vw).ord (ratFuncDXCoeff K g) := by
+  rcases eq_or_ne (ratFuncDXCoeff K g) 0 with h0 | hne
+  · exact Or.inl h0
+  refine Or.inr ?_
+  have hW : g.num.derivative * g.denom - g.num * g.denom.derivative ≠ 0 :=
+    wronskian_ne_zero_of_ratFuncDXCoeff_ne_zero K hne
+  have hW' : algebraMap K[X] (RatFunc K)
+      (g.num.derivative * g.denom - g.num * g.denom.derivative) ≠ 0 :=
+    RatFunc.algebraMap_ne_zero hW
+  have hd' : algebraMap K[X] (RatFunc K) g.denom ≠ 0 :=
+    RatFunc.algebraMap_ne_zero g.denom_ne_zero
+  have hWord : 0 ≤ (vw).ord (algebraMap K[X] (RatFunc K)
+      (g.num.derivative * g.denom - g.num * g.denom.derivative)) :=
+    (vw).ord_nonneg_of_mem (algebraMap_mem_ofHeightOneSpectrum K w _)
+  have hden : (vw).ord (algebraMap K[X] (RatFunc K) g.denom) = 0 :=
+    ord_algebraMap_denom_eq_zero_of_ord_nonneg hp hwp hg hord
+  have key : (vw).ord (ratFuncDXCoeff K g)
+      = (vw).ord (algebraMap K[X] (RatFunc K)
+          (g.num.derivative * g.denom - g.num * g.denom.derivative))
+        - 2 * (vw).ord (algebraMap K[X] (RatFunc K) g.denom) := by
+    rw [ratFuncDXCoeff_def, div_eq_mul_inv,
+      (vw).ord_mul hW' (inv_ne_zero (pow_ne_zero 2 hd')), (vw).ord_inv, ← zpow_natCast,
+      (vw).ord_zpow]
+    push_cast
+    ring
+  rw [key, hden]
+  omega
+
+end FinitePlaces
+section PlaceInftySide
+
+variable [DecidableEq (RatFunc K)]
+
+theorem ratFuncDXCoeff_ne_zero_and_ord_placeInfty_eq_two_of_ord_eq_one
+    {f : RatFunc K} (hf : f ≠ 0) (hord : (placeInfty K).ord f = 1) :
+    ratFuncDXCoeff K f ≠ 0 ∧ (placeInfty K).ord (ratFuncDXCoeff K f) = 2 := by
+  obtain ⟨e, he0, heord, hDe⟩ := exists_dXCoeff_ord_two_of_ord_placeInfty_eq_one hf hord
+  rw [ratFuncDXCoeff_eq_of_D_eq_smul_dX hDe]
+  exact ⟨he0, heord⟩
+
+theorem ratFuncDXCoeff_eq_zero_or_two_le_ord_placeInfty_of_ord_nonneg
+    {g : RatFunc K} (hg : g ≠ 0) (hord : 0 ≤ (placeInfty K).ord g) :
+    ratFuncDXCoeff K g = 0 ∨ 2 ≤ (placeInfty K).ord (ratFuncDXCoeff K g) := by
+  rcases eq_or_ne (ratFuncDXCoeff K g) 0 with h0 | hne
+  · exact Or.inl h0
+  refine Or.inr ?_
+  rcases eq_or_lt_of_le hord with heq | hlt
+  · obtain ⟨e, he, hDe⟩ := exists_dXCoeff_ord_ge_two_of_ord_placeInfty_eq_zero hg heq.symm
+    have hee := ratFuncDXCoeff_eq_of_D_eq_smul_dX hDe
+    rcases he with rfl | h2
+    · exact absurd hee hne
+    · rw [hee]; exact h2
+  · have hW : g.num.derivative * g.denom - g.num * g.denom.derivative ≠ 0 :=
+      wronskian_ne_zero_of_ratFuncDXCoeff_ne_zero K hne
+    have h := ord_placeInfty_ratFuncDXCoeff_ge hg hW
+    omega
+
+end PlaceInftySide
+end DXCoeffIntegrality
+section LemmaA
+
+variable {K : Type*} [Field K] [CharZero K]
+
+theorem ratFuncDXCoeff_uniformizer_ne_zero_and_ord_le (v : Place K (RatFunc K))
+    {g : RatFunc K} (hg : g ∈ v.toValuationSubring) :
+    ratFuncDXCoeff K v.uniformizer ≠ 0 ∧
+      (ratFuncDXCoeff K g = 0 ∨
+        v.ord (ratFuncDXCoeff K v.uniformizer) ≤ v.ord (ratFuncDXCoeff K g)) := by
+  classical
+  have hg0 : 0 ≤ v.ord g := v.ord_nonneg_of_mem hg
+  rcases eq_or_ne g 0 with rfl | hgne
+  · refine ⟨?_, Or.inl (ratFuncDXCoeff_zero (K := K))⟩
+    rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+    · obtain ⟨p, hp, hwp⟩ := exists_irreducible_span K w
+      exact (ratFuncDXCoeff_ne_zero_and_ord_eq_zero_of_ord_eq_one hp hwp hp.separable
+        (Place.uniformizer_ne_zero _) (Place.ord_uniformizer _)).1
+    · exact (ratFuncDXCoeff_ne_zero_and_ord_placeInfty_eq_two_of_ord_eq_one
+        ((placeInfty K).uniformizer_ne_zero) ((placeInfty K).ord_uniformizer)).1
+  · rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+    · obtain ⟨p, hp, hwp⟩ := exists_irreducible_span K w
+      obtain ⟨hπne, hπord⟩ := ratFuncDXCoeff_ne_zero_and_ord_eq_zero_of_ord_eq_one hp hwp
+        hp.separable (Place.uniformizer_ne_zero _) (Place.ord_uniformizer _)
+      refine ⟨hπne, ?_⟩
+      rcases ratFuncDXCoeff_eq_zero_or_ord_nonneg_of_ord_nonneg hp hwp hgne hg0 with h0 | hge
+      · exact Or.inl h0
+      · exact Or.inr (by rw [hπord]; exact hge)
+    · obtain ⟨hπne, hπord⟩ :=
+        ratFuncDXCoeff_ne_zero_and_ord_placeInfty_eq_two_of_ord_eq_one
+          (f := (placeInfty K).uniformizer)
+          ((placeInfty K).uniformizer_ne_zero) ((placeInfty K).ord_uniformizer)
+      refine ⟨hπne, ?_⟩
+      rcases ratFuncDXCoeff_eq_zero_or_two_le_ord_placeInfty_of_ord_nonneg hgne hg0
+        with h0 | hge
+      · exact Or.inl h0
+      · exact Or.inr (by rw [hπord]; exact hge)
+
+theorem differentialCoeff_D_eq_ratFuncDXCoeff_div (v : Place K (RatFunc K)) (f : RatFunc K)
+    (hπ : ratFuncDXCoeff K v.uniformizer ≠ 0) :
+    v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) f)
+      = ratFuncDXCoeff K f / ratFuncDXCoeff K v.uniformizer :=
+  v.differentialCoeff_unique (by
+    rw [show v.dCoord = KaehlerDifferential.D K (RatFunc K) v.uniformizer from rfl,
+      D_eq_ratFuncDXCoeff_smul_dX K v.uniformizer, D_eq_ratFuncDXCoeff_smul_dX K f,
+      smul_smul, div_mul_cancel₀ _ hπ])
+
+theorem differentialCoeff_D_mem_of_mem (v : Place K (RatFunc K))
+    {g : RatFunc K} (hg : g ∈ v.toValuationSubring) :
+    v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) g) ∈ v.toValuationSubring := by
+  obtain ⟨hπne, hcase⟩ := ratFuncDXCoeff_uniformizer_ne_zero_and_ord_le v hg
+  rw [differentialCoeff_D_eq_ratFuncDXCoeff_div v g hπne]
+  rcases hcase with h0 | hle
+  · rw [h0, zero_div]; exact zero_mem _
+  · rcases eq_or_ne (ratFuncDXCoeff K g) 0 with h0 | hgne'
+    · rw [h0, zero_div]; exact zero_mem _
+    · refine v.mem_of_ord_nonneg (div_ne_zero hgne' hπne) ?_
+      rw [div_eq_mul_inv, v.ord_mul hgne' (inv_ne_zero hπne), v.ord_inv]
+      omega
+
+end LemmaA
+section ExactDifferentialEngine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable (v : Place K F) [v.DCoordGenerates] [Nontrivial Ω[F⁄K]]
+
+theorem CanonicalLocalResidueDataK.res_differentialCoeff_D_of_mem_poleSubmodule
+    (hsurj : Function.Surjective (algebraMap K v.ResidueField))
+    (hint : ∀ h : F, h ∈ v.toValuationSubring →
+      v.differentialCoeff (KaehlerDifferential.D K F h) ∈ v.toValuationSubring)
+    (R : v.CanonicalLocalResidueDataK) (N : ℕ) {g : F} (hg : g ∈ v.poleSubmodule N) :
+    R.res (v.differentialCoeff (KaehlerDifferential.D K F g)) = 0 := by
+  induction N generalizing g with
+  | zero =>
+    have hg' : g ∈ v.toValuationSubring := by
+      have h := (v.mem_poleSubmodule (n := 0) (f := g)).mp hg
+      rwa [pow_zero, one_mul] at h
+    exact R.res_of_mem _ (hint g hg')
+  | succ N ih =>
+    obtain ⟨c, hc⟩ := hsurj (v.laurentTailCoeff (N + 1) ⟨g, hg⟩)
+    have hclift : IsLocalRing.residue _ (algebraMap K v.toValuationSubring c)
+        = v.laurentTailCoeff (N + 1) ⟨g, hg⟩ := by
+      rw [← hc, IsScalarTower.algebraMap_apply K v.toValuationSubring v.ResidueField,
+        IsLocalRing.ResidueField.algebraMap_eq]
+    have hrem : g - algebraMap K F c * (v.uniformizer ^ (N + 1))⁻¹ ∈ v.poleSubmodule N := by
+      have h := v.laurentTail_remainder_mem_poleSubmodule hg hclift
+      rwa [v.coe_algebraMap] at h
+    have hpeel : R.res (v.differentialCoeff (KaehlerDifferential.D K F
+        (algebraMap K F c * (v.uniformizer ^ (N + 1))⁻¹))) = 0 := by
+      rw [Derivation.leibniz, Derivation.map_algebraMap, smul_zero, add_zero,
+        v.differentialCoeff_smul, v.differentialCoeff_D_uniformizer_pow_inv,
+        show algebraMap K F c * (-((N + 1 : ℕ) : F) * (v.uniformizer ^ (N + 2))⁻¹)
+            = algebraMap K F (c * -((N + 1 : ℕ) : K)) * (v.uniformizer ^ ((N + 1) + 1))⁻¹ by
+          rw [map_mul, _root_.map_neg, map_natCast]; ring]
+      exact R.res_algebraMap_mul_uniformizer_pow_inv v (Nat.le_add_left 1 N) _
+    have hsplit : R.res (v.differentialCoeff (KaehlerDifferential.D K F g))
+        = R.res (v.differentialCoeff (KaehlerDifferential.D K F
+            (g - algebraMap K F c * (v.uniformizer ^ (N + 1))⁻¹)))
+          + R.res (v.differentialCoeff (KaehlerDifferential.D K F
+            (algebraMap K F c * (v.uniformizer ^ (N + 1))⁻¹))) := by
+      conv_lhs => rw [show g = (g - algebraMap K F c * (v.uniformizer ^ (N + 1))⁻¹)
+          + algebraMap K F c * (v.uniformizer ^ (N + 1))⁻¹ by ring]
+      rw [map_add, v.differentialCoeff_add'', map_add]
+    rw [hsplit, ih hrem, hpeel, add_zero]
+
+theorem CanonicalLocalResidueDataK.res_differentialCoeff_D_of_surj
+    (hsurj : Function.Surjective (algebraMap K v.ResidueField))
+    (hint : ∀ h : F, h ∈ v.toValuationSubring →
+      v.differentialCoeff (KaehlerDifferential.D K F h) ∈ v.toValuationSubring)
+    (R : v.CanonicalLocalResidueDataK) (g : F) :
+    R.res (v.differentialCoeff (KaehlerDifferential.D K F g)) = 0 := by
+  obtain ⟨N, hN⟩ := v.exists_mem_poleSubmodule g
+  exact CanonicalLocalResidueDataK.res_differentialCoeff_D_of_mem_poleSubmodule v hsurj hint
+    R N hN
+
+theorem CanonicalLocalResidueDataK.res_differentialCoeff_D_mul_pow_inv_of_surj [CharZero K]
+    (hsurj : Function.Surjective (algebraMap K v.ResidueField))
+    (hint : ∀ h : F, h ∈ v.toValuationSubring →
+      v.differentialCoeff (KaehlerDifferential.D K F h) ∈ v.toValuationSubring)
+    (R : v.CanonicalLocalResidueDataK) (π' : F) {n : ℕ} (hn : 1 ≤ n) :
+    R.res (v.differentialCoeff (KaehlerDifferential.D K F π') * ((π') ^ (n + 1))⁻¹) = 0 := by
+  have : CharZero F := charZero_of_injective_algebraMap (algebraMap K F).injective
+  obtain ⟨m, rfl⟩ := Nat.exists_eq_add_of_le hn
+  have hres : R.res (v.differentialCoeff (KaehlerDifferential.D K F (((π') ^ (m + 1))⁻¹))) = 0 :=
+    CanonicalLocalResidueDataK.res_differentialCoeff_D_of_surj v hsurj hint R _
+  have hpow : v.differentialCoeff (KaehlerDifferential.D K F (((π') ^ (m + 1))⁻¹))
+      = -((m + 1 : ℕ) : F) * (((π') ^ (m + 2))⁻¹
+          * v.differentialCoeff (KaehlerDifferential.D K F π')) := by
+    rw [D_pow_succ_inv, v.differentialCoeff_smul]
+    ring
+  have hne : -(((m + 1 : ℕ) : F)) ≠ 0 := by
+    simp only [ne_eq, neg_eq_zero, Nat.cast_eq_zero]
+    omega
+  have hkey : v.differentialCoeff (KaehlerDifferential.D K F π') * ((π') ^ (1 + m + 1))⁻¹
+      = (-((m + 1 : ℕ) : K))⁻¹
+          • v.differentialCoeff (KaehlerDifferential.D K F (((π') ^ (m + 1))⁻¹)) := by
+    rw [Algebra.smul_def, map_inv₀, _root_.map_neg, map_natCast, hpow,
+      show 1 + m + 1 = m + 2 from by omega, inv_mul_cancel_left₀ hne]
+    ring
+  rw [hkey, map_smul, hres, smul_zero]
+
+theorem CanonicalLocalResidueDataK.res_differentialCoeff_D_mul_inv_of_integral
+    (hint : ∀ h : F, h ∈ v.toValuationSubring →
+      v.differentialCoeff (KaehlerDifferential.D K F h) ∈ v.toValuationSubring)
+    (R : v.CanonicalLocalResidueDataK) {π' : F} (hπ' : v.ord π' = 1) :
+    R.res (v.differentialCoeff (KaehlerDifferential.D K F π') * (π')⁻¹) = 1 := by
+  have hπ'0 : π' ≠ 0 := by
+    intro h
+    rw [h, v.ord_zero] at hπ'
+    exact zero_ne_one hπ'
+  have hπv0 : v.uniformizer ≠ 0 := v.uniformizer_ne_zero
+  set w : F := π' * (v.uniformizer)⁻¹ with hw_def
+  have hw0 : w ≠ 0 := mul_ne_zero hπ'0 (inv_ne_zero hπv0)
+  have hword : v.ord w = 0 := by
+    rw [hw_def, v.ord_mul hπ'0 (inv_ne_zero hπv0), v.ord_inv, hπ', v.ord_uniformizer]
+    ring
+  have hwmem : w ∈ v.toValuationSubring := v.mem_of_ord_nonneg hw0 hword.ge
+  have hwinvmem : w⁻¹ ∈ v.toValuationSubring := by
+    refine v.mem_of_ord_nonneg (inv_ne_zero hw0) ?_
+    rw [v.ord_inv, hword]
+    omega
+  have hπ'_eq : π' = v.uniformizer * w := by
+    rw [hw_def, mul_comm π' (v.uniformizer)⁻¹, ← mul_assoc, mul_inv_cancel₀ hπv0, one_mul]
+  have hD : KaehlerDifferential.D K F π'
+      = v.uniformizer • KaehlerDifferential.D K F w
+        + w • KaehlerDifferential.D K F v.uniformizer := by
+    conv_lhs => rw [hπ'_eq]
+    exact Derivation.leibniz _ _ _
+  have hcoeff : v.differentialCoeff (KaehlerDifferential.D K F π')
+      = v.uniformizer * v.differentialCoeff (KaehlerDifferential.D K F w) + w := by
+    rw [hD, v.differentialCoeff_add'', v.differentialCoeff_smul, v.differentialCoeff_smul,
+      show KaehlerDifferential.D K F v.uniformizer = v.dCoord from rfl,
+      v.differentialCoeff_dCoord, mul_one]
+  have hsplit : v.differentialCoeff (KaehlerDifferential.D K F π') * (π')⁻¹
+      = v.differentialCoeff (KaehlerDifferential.D K F w) * w⁻¹ + (v.uniformizer)⁻¹ := by
+    rw [hcoeff, hπ'_eq, mul_inv]
+    field_simp
+  rw [hsplit, map_add, gate_canonicalLocalResidueDataK_uniformizer_inv v R,
+    R.res_of_mem _ (mul_mem (hint w hwmem) hwinvmem), zero_add]
+
+end Place
+end ExactDifferentialEngine
+section RatFuncClauses
+
+variable {K : Type*} [Field K] [CharZero K]
+
+theorem canonicalLocalResidueDataK_res_differentialCoeff_D_mul_pow_inv_ratFunc
+    (v : Place K (RatFunc K)) (hsurj : Function.Surjective (algebraMap K v.ResidueField))
+    (π' : RatFunc K) (R : v.CanonicalLocalResidueDataK) {n : ℕ} (hn : 1 ≤ n) :
+    R.res (v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) π')
+      * ((π') ^ (n + 1))⁻¹) = 0 :=
+  Place.CanonicalLocalResidueDataK.res_differentialCoeff_D_mul_pow_inv_of_surj v hsurj
+    (fun _ hh => differentialCoeff_D_mem_of_mem v hh) R π' hn
+
+theorem canonicalLocalResidueDataK_res_differentialCoeff_D_mul_inv_ratFunc
+    (v : Place K (RatFunc K)) {π' : RatFunc K} (hπ' : v.ord π' = 1)
+    (R : v.CanonicalLocalResidueDataK) :
+    R.res (v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) π') * (π')⁻¹) = 1 :=
+  Place.CanonicalLocalResidueDataK.res_differentialCoeff_D_mul_inv_of_integral v
+    (fun _ hh => differentialCoeff_D_mem_of_mem v hh) R hπ'
+
+end RatFuncClauses
+theorem canonicalLocalResidueKSimplePoleCoordIndep_ratFunc (K : Type*) [Field K] [CharZero K]
+    [HasCanonicalLocalResidueKStar K (RatFunc K)] :
+    CanonicalLocalResidueKSimplePoleCoordIndep K (RatFunc K) :=
+  fun v _ hπ' R => canonicalLocalResidueDataK_res_differentialCoeff_D_mul_inv_ratFunc v hπ' R
+
+section PlaceInftyConsumers
+
+variable (K : Type*) [Field K] [CharZero K] [DecidableEq (RatFunc K)]
+
+theorem canonicalLocalResidueDataK_res_differentialCoeff_D_mul_pow_inv_placeInfty
+    (π' : RatFunc K) (R : (placeInfty K).CanonicalLocalResidueDataK) {n : ℕ} (hn : 1 ≤ n) :
+    R.res ((placeInfty K).differentialCoeff (KaehlerDifferential.D K (RatFunc K) π')
+      * ((π') ^ (n + 1))⁻¹) = 0 :=
+  canonicalLocalResidueDataK_res_differentialCoeff_D_mul_pow_inv_ratFunc (placeInfty K)
+    (surjective_algebraMap_residueField_placeInfty K) π' R hn
+
+theorem canonicalLocalResidueDataK_res_X_pow_mul_D_X
+    (R : (placeInfty K).CanonicalLocalResidueDataK) (n : ℕ) :
+    R.res ((RatFunc.X : RatFunc K) ^ n
+        * (placeInfty K).differentialCoeff
+            (KaehlerDifferential.D K (RatFunc K) RatFunc.X)) = 0 := by
+  rw [X_pow_mul_differentialCoeff_D_X_eq_neg K n, _root_.map_neg, neg_eq_zero]
+  exact canonicalLocalResidueDataK_res_differentialCoeff_D_mul_pow_inv_placeInfty K
+    (RatFunc.X : RatFunc K)⁻¹ R (Nat.le_add_left 1 n)
+
+theorem canonicalLocalResidueDataK_kaehlerResidueTerm_X_pow
+    (R : (placeInfty K).CanonicalLocalResidueDataK) (n : ℕ) :
+    Algebra.trace K (placeInfty K).ResidueField
+        (R.res (diagonalHom K (RatFunc K) ((RatFunc.X : RatFunc K) ^ n) (placeInfty K)
+          * (placeInfty K).differentialCoeff
+              (KaehlerDifferential.D K (RatFunc K) RatFunc.X))) = 0 := by
+  rw [diagonalHom_apply, canonicalLocalResidueDataK_res_X_pow_mul_D_X K R n, _root_.map_zero]
+
+end PlaceInftyConsumers
+section AlgClosedDischarge
+
+variable (K : Type*) [Field K] [CharZero K]
+
+omit [CharZero K] in
+theorem surjective_algebraMap_residueField_of_deg_eq_one {F : Type*} [Field F] [Algebra K F]
+    (v : Place K F) (hdeg : v.deg = 1) :
+    Function.Surjective (algebraMap K v.ResidueField) := by
+  intro z
+  obtain ⟨c, hc⟩ := (finrank_eq_one_iff_of_nonzero' (1 : v.ResidueField) one_ne_zero).mp
+    (show Module.finrank K v.ResidueField = 1 from hdeg) z
+  exact ⟨c, by rw [Algebra.algebraMap_eq_smul_one]; exact hc⟩
+
+omit [CharZero K] in
+theorem surjective_algebraMap_residueField_ratFunc_of_isAlgClosed [IsAlgClosed K]
+    (v : Place K (RatFunc K)) :
+    Function.Surjective (algebraMap K v.ResidueField) := by
+  classical
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+  · obtain ⟨p, hp, hwp⟩ := exists_irreducible_span K w
+    refine surjective_algebraMap_residueField_of_deg_eq_one K _ ?_
+    rw [deg_ofHeightOneSpectrum K hwp]
+    have h := IsAlgClosed.degree_eq_one_of_irreducible K hp
+    rw [degree_eq_natDegree hp.ne_zero] at h
+    exact_mod_cast h
+  · exact surjective_algebraMap_residueField_placeInfty K
+
+variable [IsAlgClosed K]
+
+theorem canonicalLocalResidueKDifferentialCoordIndep_ratFunc_of_isAlgClosed :
+    CanonicalLocalResidueKDifferentialCoordIndep K (RatFunc K) :=
+  fun v π' _ R _ hn =>
+    canonicalLocalResidueDataK_res_differentialCoeff_D_mul_pow_inv_ratFunc v
+      (surjective_algebraMap_residueField_ratFunc_of_isAlgClosed K v) π' R hn
+
+end AlgClosedDischarge
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+section Profile
+
+variable (K : Type*) [Field K]
+
+section PerfectProfileValues
+
+variable [PerfectField K] [DecidableEq (RatFunc K)]
+
+theorem p1DifferentialCoeffRegularFinite_dX_of_perfectField :
+    P1DifferentialCoeffRegularFinite K (dX_ne_zero K) :=
+  p1DifferentialCoeffRegularFinite_of_unitFinite (dX_ne_zero K)
+    (p1DifferentialCoeffUnitFinite_dX_of_perfectField K)
+
+end PerfectProfileValues
+end Profile
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace ModularCurve
+
+namespace MilneAvAg9bRd13T2CoordIndepChar3
+
+private theorem
+  ag9b13t_res_differentialCoeff_D_mul_pow_inv_of_surj_of_natCast_ne_zero
+    {K F : Type*} [Field K] [Field F] [Algebra K F] [HasCanonicalLocalResidueKStar K F]
+    (v : Place K F) [v.DCoordGenerates] [Nontrivial Ω[F⁄K]]
+    (hsurj : Function.Surjective (algebraMap K v.ResidueField))
+    (hint : ∀ h : F, h ∈ v.toValuationSubring →
+      v.differentialCoeff (KaehlerDifferential.D K F h) ∈ v.toValuationSubring)
+    (R : v.CanonicalLocalResidueDataK) (π' : F) {n : ℕ} (hn : 1 ≤ n)
+    (hnK : (n : K) ≠ 0) :
+    R.res (v.differentialCoeff (KaehlerDifferential.D K F π') * ((π') ^ (n + 1))⁻¹) = 0 := by
+  obtain ⟨m, rfl⟩ := Nat.exists_eq_add_of_le hn
+  have hmK : ((m + 1 : ℕ) : K) ≠ 0 := by
+    rwa [show m + 1 = 1 + m from by omega]
+  have hres : R.res (v.differentialCoeff
+      (KaehlerDifferential.D K F (((π') ^ (m + 1))⁻¹))) = 0 :=
+    Place.CanonicalLocalResidueDataK.res_differentialCoeff_D_of_surj v hsurj hint R _
+  have hpow : v.differentialCoeff (KaehlerDifferential.D K F (((π') ^ (m + 1))⁻¹))
+      = -((m + 1 : ℕ) : F) * (((π') ^ (m + 2))⁻¹
+          * v.differentialCoeff (KaehlerDifferential.D K F π')) := by
+    rw [D_pow_succ_inv, v.differentialCoeff_smul]
+    ring
+  have hne : -(((m + 1 : ℕ) : F)) ≠ 0 := by
+    rw [neg_ne_zero, ← map_natCast (algebraMap K F) (m + 1)]
+    exact (map_ne_zero_iff _ (algebraMap K F).injective).mpr hmK
+  have hkey : v.differentialCoeff (KaehlerDifferential.D K F π') * ((π') ^ (1 + m + 1))⁻¹
+      = (-((m + 1 : ℕ) : K))⁻¹
+          • v.differentialCoeff (KaehlerDifferential.D K F (((π') ^ (m + 1))⁻¹)) := by
+    rw [Algebra.smul_def, map_inv₀, _root_.map_neg, map_natCast, hpow,
+      show 1 + m + 1 = m + 2 from by omega, inv_mul_cancel_left₀ hne]
+    ring
+  rw [hkey, map_smul, hres, smul_zero]
+
+end MilneAvAg9bRd13T2CoordIndepChar3
+
+end ModularCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+section RatFuncPlaceInftyClause
+
+variable {K : Type*} [Field K] [CharZero K] [DecidableEq (RatFunc K)]
+
+theorem residueTheoremK_placeInfty_clause_X_pow
+    (Rfam : ∀ v : Place K (RatFunc K), v.CanonicalLocalResidueDataK) (n : ℕ) :
+    kaehlerResidueTermKFam Rfam (KaehlerDifferential.D K (RatFunc K) RatFunc.X)
+      (diagonalHom K (RatFunc K) ((RatFunc.X : RatFunc K) ^ n)) (placeInfty K) = 0 := by
+  rw [kaehlerResidueTermKFam_apply]
+  exact canonicalLocalResidueDataK_kaehlerResidueTerm_X_pow K (Rfam (placeInfty K)) n
+
+end RatFuncPlaceInftyClause
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+variable (K : Type*) [Field K] [PerfectField K]
+
+section EulerPerfectField
+
+variable {p : K[X]} [Fact (Irreducible p)]
+
+theorem ag9b12c_trace_root_pow_div_derivative_of_lt_of_perfectField (hpmon : p.Monic)
+    {k : ℕ} (hk : k < p.natDegree - 1) :
+    Algebra.trace K (AdjoinRoot p)
+      (AdjoinRoot.root p ^ k / aeval (AdjoinRoot.root p) (derivative p)) = 0 := by
+  have : FiniteDimensional K (AdjoinRoot p) :=
+    Module.Finite.of_basis (AdjoinRoot.powerBasis hpmon.ne_zero).basis
+  have hmin : minpoly K (AdjoinRoot.powerBasis hpmon.ne_zero).gen = p :=
+    AdjoinRoot.minpoly_powerBasis_gen_of_monic hpmon
+  have h := FLT.EulerDualBasis.trace_pow_div_aeval_derivative_minpoly_of_lt
+    (AdjoinRoot.powerBasis hpmon.ne_zero) (k := k)
+    (by rwa [AdjoinRoot.powerBasis_dim])
+  rwa [hmin, AdjoinRoot.powerBasis_gen] at h
+
+theorem ag9b12c_trace_root_pow_div_derivative_self_of_perfectField (hpmon : p.Monic)
+    (hd : 0 < p.natDegree) :
+    Algebra.trace K (AdjoinRoot p)
+      (AdjoinRoot.root p ^ (p.natDegree - 1) /
+        aeval (AdjoinRoot.root p) (derivative p)) = 1 := by
+  have : FiniteDimensional K (AdjoinRoot p) :=
+    Module.Finite.of_basis (AdjoinRoot.powerBasis hpmon.ne_zero).basis
+  have hmin : minpoly K (AdjoinRoot.powerBasis hpmon.ne_zero).gen = p :=
+    AdjoinRoot.minpoly_powerBasis_gen_of_monic hpmon
+  have h := FLT.EulerDualBasis.trace_pow_div_aeval_derivative_minpoly_self
+    (AdjoinRoot.powerBasis hpmon.ne_zero)
+    (by rwa [AdjoinRoot.powerBasis_dim])
+  rwa [hmin, AdjoinRoot.powerBasis_gen, AdjoinRoot.powerBasis_dim] at h
+
+omit [PerfectField K] in
+private theorem ag9b12c_aeval_root_eq_sum_range {c : K[X]} {d : ℕ} (hd : c.natDegree < d) :
+    (aeval (AdjoinRoot.root p) c : AdjoinRoot p)
+      = ∑ k ∈ Finset.range d, c.coeff k • AdjoinRoot.root p ^ k := by
+  rw [aeval_def, eval₂_eq_sum_range' (algebraMap K (AdjoinRoot p)) hd]
+  exact Finset.sum_congr rfl fun k _ => (Algebra.smul_def _ _).symm
+
+theorem ag9b12c_trace_adjoinRoot_mk_div_mk_derivative_of_perfectField (hpmon : p.Monic)
+    {c : K[X]} (hdeg : c.degree < p.degree) :
+    Algebra.trace K (AdjoinRoot p)
+        (AdjoinRoot.mk p c / AdjoinRoot.mk p (derivative p))
+      = c.coeff (p.natDegree - 1) := by
+  have : FiniteDimensional K (AdjoinRoot p) :=
+    Module.Finite.of_basis (AdjoinRoot.powerBasis hpmon.ne_zero).basis
+  have hpd : 0 < p.natDegree := (Fact.out : Irreducible p).natDegree_pos
+  have hcd : c.natDegree < p.natDegree := by
+    rcases eq_or_ne c 0 with rfl | hc
+    · simpa using hpd
+    · exact natDegree_lt_natDegree hc hdeg
+  rw [← AdjoinRoot.aeval_eq, ← AdjoinRoot.aeval_eq,
+    ag9b12c_aeval_root_eq_sum_range K hcd, Finset.sum_div, map_sum]
+  trans ∑ k ∈ Finset.range p.natDegree,
+      c.coeff k * Algebra.trace K (AdjoinRoot p)
+        (AdjoinRoot.root p ^ k / aeval (AdjoinRoot.root p) (derivative p))
+  · refine Finset.sum_congr rfl fun k _ => ?_
+    rw [Algebra.smul_def, mul_div_assoc, ← Algebra.smul_def, map_smul, smul_eq_mul]
+  rw [Finset.sum_eq_single (p.natDegree - 1)]
+  · rw [ag9b12c_trace_root_pow_div_derivative_self_of_perfectField K hpmon hpd, mul_one]
+  · intro k hk hkne
+    have hk' : k < p.natDegree - 1 :=
+      lt_of_le_of_ne (Nat.le_sub_one_of_lt (Finset.mem_range.mp hk)) hkne
+    rw [ag9b12c_trace_root_pow_div_derivative_of_lt_of_perfectField K hpmon hk', mul_zero]
+  · intro h
+    exact absurd (Finset.mem_range.mpr (Nat.sub_lt hpd one_pos)) h
+
+end EulerPerfectField
+section DerivativeRegular
+
+private theorem ag9b12c_differentialCoeff_add (v : Place K (RatFunc K))
+    (ω₁ ω₂ : Ω[(RatFunc K)⁄K]) :
+    v.differentialCoeff (ω₁ + ω₂) = v.differentialCoeff ω₁ + v.differentialCoeff ω₂ :=
+  v.differentialCoeff_unique
+    (by rw [add_smul, v.differentialCoeff_smul_dCoord, v.differentialCoeff_smul_dCoord])
+
+theorem ag9b12c_differentialCoeff_D_mem_finitePlace
+    {p : K[X]} (hpirr : Irreducible p)
+    {f : RatFunc K} (hf : f ∈ (finitePlace K hpirr).toValuationSubring) :
+    (finitePlace K hpirr).differentialCoeff (D K (RatFunc K) f)
+      ∈ (finitePlace K hpirr).toValuationSubring := by
+  classical
+  set v := finitePlace K hpirr
+  set ξ : K[X] := f.num.derivative * f.denom - f.num * f.denom.derivative
+  have hd0 : algebraMap K[X] (RatFunc K) f.denom ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr f.denom_ne_zero
+  have hcoeff : v.differentialCoeff (D K (RatFunc K) f)
+      = algebraMap K[X] (RatFunc K) ξ * ((algebraMap K[X] (RatFunc K) f.denom) ^ 2)⁻¹
+          * v.differentialCoeff (dX K) := by
+    have hkey := denom_sq_smul_D_eq K f
+    refine v.differentialCoeff_unique ?_
+    rw [mul_smul, v.differentialCoeff_smul_dCoord, mul_comm, mul_smul, ← hkey, smul_smul,
+      inv_mul_cancel₀ (pow_ne_zero 2 hd0), one_smul]
+  rw [hcoeff]
+  refine mul_mem (mul_mem ?_ ?_) ?_
+  · exact algebraMap_mem_ofHeightOneSpectrum K _ ξ
+  · have hden_notmem : f.denom ∉ (heightOneSpectrumOfIrreducible K hpirr).asIdeal :=
+      denom_notMem_of_mem_ofHeightOneSpectrum K _ hf
+    have hordd : v.ord (algebraMap K[X] (RatFunc K) f.denom) = 0 := by
+      by_contra h
+      exact hden_notmem ((Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K)
+        (F := RatFunc K) _ f.denom_ne_zero).mp h)
+    refine v.mem_of_ord_nonneg (inv_ne_zero (pow_ne_zero 2 hd0)) ?_
+    rw [v.ord_inv, ← zpow_natCast, v.ord_zpow, hordd, mul_zero, _root_.neg_zero]
+  · exact v.mem_of_ord_nonneg (v.differentialCoeff_ne_zero (dX_ne_zero K))
+      (ord_differentialCoeff_dX_ofHeightOneSpectrum hpirr
+        (heightOneSpectrumOfIrreducible_asIdeal K hpirr)
+        (PerfectField.separable_of_irreducible hpirr)).ge
+
+end DerivativeRegular
+section LeibnizCore
+
+omit [PerfectField K] in
+theorem ag9b12c_uniformizer_div_mem_finitePlace {p : K[X]} (hpirr : Irreducible p) :
+    (finitePlace K hpirr).uniformizer / algebraMap K[X] (RatFunc K) p
+      ∈ (finitePlace K hpirr).toValuationSubring := by
+  set v := finitePlace K hpirr
+  have hp0 : algebraMap K[X] (RatFunc K) p ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hpirr.ne_zero
+  refine v.mem_of_ord_nonneg (div_ne_zero v.uniformizer_ne_zero hp0) ?_
+  rw [div_eq_mul_inv, v.ord_mul v.uniformizer_ne_zero (inv_ne_zero hp0), v.ord_inv,
+    v.ord_uniformizer, ord_finitePlace_self K hpirr]
+  omega
+
+theorem ag9b12c_one_sub_uniformizer_div_mul_differentialCoeff_D
+    {p : K[X]} (hpirr : Irreducible p) :
+    (1 : RatFunc K) - (finitePlace K hpirr).uniformizer / algebraMap K[X] (RatFunc K) p
+        * (finitePlace K hpirr).differentialCoeff
+            (D K (RatFunc K) (algebraMap K[X] (RatFunc K) p))
+      = algebraMap K[X] (RatFunc K) p
+          * (finitePlace K hpirr).differentialCoeff
+              (D K (RatFunc K) ((finitePlace K hpirr).uniformizer
+                / algebraMap K[X] (RatFunc K) p)) := by
+  set v := finitePlace K hpirr
+  have hp0 : algebraMap K[X] (RatFunc K) p ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hpirr.ne_zero
+  have hleib : D K (RatFunc K) v.uniformizer
+      = (v.uniformizer / algebraMap K[X] (RatFunc K) p)
+            • D K (RatFunc K) (algebraMap K[X] (RatFunc K) p)
+        + algebraMap K[X] (RatFunc K) p
+            • D K (RatFunc K) (v.uniformizer / algebraMap K[X] (RatFunc K) p) := by
+    have h := (D K (RatFunc K)).leibniz (a := v.uniformizer / algebraMap K[X] (RatFunc K) p)
+      (b := algebraMap K[X] (RatFunc K) p)
+    rw [div_mul_cancel₀ _ hp0] at h
+    exact h
+  have h1 : (1 : RatFunc K)
+      = (v.uniformizer / algebraMap K[X] (RatFunc K) p)
+            * v.differentialCoeff (D K (RatFunc K) (algebraMap K[X] (RatFunc K) p))
+        + algebraMap K[X] (RatFunc K) p
+            * v.differentialCoeff
+                (D K (RatFunc K) (v.uniformizer / algebraMap K[X] (RatFunc K) p)) := by
+    have hcoord : D K (RatFunc K) v.uniformizer = v.dCoord := rfl
+    rw [← v.differentialCoeff_dCoord, ← hcoord, hleib, ag9b12c_differentialCoeff_add K,
+      v.differentialCoeff_smul, v.differentialCoeff_smul]
+  linear_combination h1
+
+theorem ag9b12c_uniformizer_div_mul_differentialCoeff_D_mem_finitePlace
+    {p : K[X]} (hpirr : Irreducible p) :
+    (finitePlace K hpirr).uniformizer / algebraMap K[X] (RatFunc K) p
+        * (finitePlace K hpirr).differentialCoeff
+            (D K (RatFunc K) (algebraMap K[X] (RatFunc K) p))
+      ∈ (finitePlace K hpirr).toValuationSubring := by
+  classical
+  set v := finitePlace K hpirr
+  refine mul_mem (ag9b12c_uniformizer_div_mem_finitePlace K hpirr) ?_
+  rw [differentialCoeff_D_algebraMap_polynomial K]
+  exact mul_mem (algebraMap_mem_ofHeightOneSpectrum K _ p.derivative)
+    (v.mem_of_ord_nonneg (v.differentialCoeff_ne_zero (dX_ne_zero K))
+      (ord_differentialCoeff_dX_ofHeightOneSpectrum hpirr
+        (heightOneSpectrumOfIrreducible_asIdeal K hpirr)
+        (PerfectField.separable_of_irreducible hpirr)).ge)
+
+theorem ag9b12c_residue_uniformizer_div_mul_differentialCoeff_D_eq_one
+    {p : K[X]} (hpirr : Irreducible p) :
+    IsLocalRing.residue _
+        ⟨_, ag9b12c_uniformizer_div_mul_differentialCoeff_D_mem_finitePlace K hpirr⟩
+      = (1 : (finitePlace K hpirr).ResidueField) := by
+  classical
+  set v := finitePlace K hpirr
+  rw [← sub_eq_zero, show (1 : v.ResidueField) = IsLocalRing.residue _ 1 by simp,
+    ← map_sub, IsLocalRing.residue_eq_zero_iff]
+  have hsubmem : (1 : RatFunc K) - (v.uniformizer / algebraMap K[X] (RatFunc K) p
+      * v.differentialCoeff (D K (RatFunc K) (algebraMap K[X] (RatFunc K) p)))
+        ∈ v.toValuationSubring :=
+    sub_mem (one_mem _)
+      (ag9b12c_uniformizer_div_mul_differentialCoeff_D_mem_finitePlace K hpirr)
+  have hcoe : (⟨_, ag9b12c_uniformizer_div_mul_differentialCoeff_D_mem_finitePlace K hpirr⟩
+        - 1 : v.toValuationSubring)
+      = -⟨_, hsubmem⟩ :=
+    Subtype.ext (by push_cast; ring)
+  rw [hcoe]
+  refine neg_mem ?_
+  have herr : (1 : RatFunc K) - (v.uniformizer / algebraMap K[X] (RatFunc K) p
+      * v.differentialCoeff (D K (RatFunc K) (algebraMap K[X] (RatFunc K) p)))
+        = algebraMap K[X] (RatFunc K) p
+          * v.differentialCoeff (D K (RatFunc K)
+              (v.uniformizer / algebraMap K[X] (RatFunc K) p)) :=
+    ag9b12c_one_sub_uniformizer_div_mul_differentialCoeff_D K hpirr
+  have hpmem : (⟨algebraMap K[X] (RatFunc K) p, algebraMap_mem_ofHeightOneSpectrum K _ p⟩
+      : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring := by
+    rw [Place.mem_maximalIdeal_iff_adicValuation_lt_one]
+    refine (Place.isEquiv_adicValuation_ofHeightOneSpectrum (K := K)
+      (F := RatFunc K) (heightOneSpectrumOfIrreducible K hpirr)).lt_one_iff_lt_one.mp ?_
+    exact (HeightOneSpectrum.valuation_lt_one_iff_mem _ p).mpr
+      (Ideal.mem_span_singleton_self p)
+  have hregmem : v.differentialCoeff (D K (RatFunc K)
+        (v.uniformizer / algebraMap K[X] (RatFunc K) p)) ∈ v.toValuationSubring :=
+    ag9b12c_differentialCoeff_D_mem_finitePlace K hpirr
+      (ag9b12c_uniformizer_div_mem_finitePlace K hpirr)
+  have hprod : (⟨_, hsubmem⟩ : v.toValuationSubring)
+      = ⟨_, algebraMap_mem_ofHeightOneSpectrum K _ p⟩ * ⟨_, hregmem⟩ :=
+    Subtype.ext herr
+  rw [hprod]
+  exact Ideal.mul_mem_right _ _ hpmem
+
+end LeibnizCore
+section BridgeDischarge
+
+theorem ag9b12c_residue_algebraMap_derivative_ne_zero {p : K[X]} (hpirr : Irreducible p) :
+    IsLocalRing.residue _ ⟨algebraMap K[X] (RatFunc K) p.derivative,
+        algebraMap_mem_ofHeightOneSpectrum K _ p.derivative⟩
+      ≠ (0 : (finitePlace K hpirr).ResidueField) := by
+  rw [ne_eq, IsLocalRing.residue_eq_zero_iff,
+    Place.mem_maximalIdeal_iff_adicValuation_lt_one]
+  intro hlt
+  have hlt' := (Place.isEquiv_adicValuation_ofHeightOneSpectrum (K := K)
+    (F := RatFunc K) (heightOneSpectrumOfIrreducible K hpirr)).lt_one_iff_lt_one.mpr hlt
+  rw [HeightOneSpectrum.valuation_lt_one_iff_mem,
+    heightOneSpectrumOfIrreducible_asIdeal K hpirr, Ideal.mem_span_singleton] at hlt'
+  exact hpirr.not_isUnit
+    ((PerfectField.separable_of_irreducible hpirr).isUnit_of_dvd' dvd_rfl hlt')
+
+theorem ag9b12c_simplePoleResidueAux_finitePlace_p1PrincipalPartAtom_mOne
+    {p c : K[X]} (hpirr : Irreducible p)
+    (hfmem : p1PrincipalPartAtom K p c 1 * (finitePlace K hpirr).differentialCoeff (dX K)
+        ∈ (finitePlace K hpirr).simplePoleSubmodule) :
+    (finitePlace K hpirr).simplePoleResidueAux ⟨_, hfmem⟩
+      = IsLocalRing.residue _ ⟨algebraMap K[X] (RatFunc K) c,
+            algebraMap_mem_ofHeightOneSpectrum K _ c⟩
+        / IsLocalRing.residue _ ⟨algebraMap K[X] (RatFunc K) p.derivative,
+            algebraMap_mem_ofHeightOneSpectrum K _ p.derivative⟩ := by
+  classical
+  set v := finitePlace K hpirr
+  rw [Place.simplePoleResidueAux_apply,
+    eq_div_iff (ag9b12c_residue_algebraMap_derivative_ne_zero K hpirr)]
+  have hkey : (v.uniformizer * (p1PrincipalPartAtom K p c 1 * v.differentialCoeff (dX K)))
+        * algebraMap K[X] (RatFunc K) p.derivative
+      = algebraMap K[X] (RatFunc K) c
+        * (v.uniformizer / algebraMap K[X] (RatFunc K) p
+            * v.differentialCoeff (D K (RatFunc K) (algebraMap K[X] (RatFunc K) p))) := by
+    rw [differentialCoeff_D_algebraMap_polynomial K]
+    change v.uniformizer
+        * (algebraMap K[X] (RatFunc K) c / algebraMap K[X] (RatFunc K) p ^ 1
+            * v.differentialCoeff (dX K))
+        * algebraMap K[X] (RatFunc K) (derivative p)
+      = algebraMap K[X] (RatFunc K) c
+        * (v.uniformizer / algebraMap K[X] (RatFunc K) p
+            * (algebraMap K[X] (RatFunc K) (derivative p) * v.differentialCoeff (dX K)))
+    rw [pow_one, div_mul_eq_mul_div, div_mul_eq_mul_div, mul_div_assoc, mul_div_assoc]
+    ring_nf
+  have hLHSmem : v.uniformizer * (p1PrincipalPartAtom K p c 1 * v.differentialCoeff (dX K))
+      * algebraMap K[X] (RatFunc K) p.derivative ∈ v.toValuationSubring :=
+    mul_mem hfmem (algebraMap_mem_ofHeightOneSpectrum K _ p.derivative)
+  have hRHSmem : algebraMap K[X] (RatFunc K) c
+      * (v.uniformizer / algebraMap K[X] (RatFunc K) p
+          * v.differentialCoeff (D K (RatFunc K) (algebraMap K[X] (RatFunc K) p)))
+        ∈ v.toValuationSubring :=
+    mul_mem (algebraMap_mem_ofHeightOneSpectrum K _ c)
+      (ag9b12c_uniformizer_div_mul_differentialCoeff_D_mem_finitePlace K hpirr)
+  calc IsLocalRing.residue _ ⟨_, hfmem⟩ * IsLocalRing.residue _ ⟨_,
+          algebraMap_mem_ofHeightOneSpectrum K _ p.derivative⟩
+      = IsLocalRing.residue _ (⟨_, hfmem⟩ * ⟨_,
+          algebraMap_mem_ofHeightOneSpectrum K _ p.derivative⟩) := (map_mul _ _ _).symm
+    _ = IsLocalRing.residue _ ⟨_, hLHSmem⟩ :=
+        congrArg (IsLocalRing.residue _) (Subtype.ext rfl)
+    _ = IsLocalRing.residue _ ⟨_, hRHSmem⟩ :=
+        congrArg (IsLocalRing.residue _) (Subtype.ext hkey)
+    _ = IsLocalRing.residue _ (⟨_, algebraMap_mem_ofHeightOneSpectrum K _ c⟩
+          * ⟨_, ag9b12c_uniformizer_div_mul_differentialCoeff_D_mem_finitePlace K hpirr⟩) :=
+        congrArg (IsLocalRing.residue _) (Subtype.ext rfl)
+    _ = IsLocalRing.residue _ ⟨_, algebraMap_mem_ofHeightOneSpectrum K _ c⟩
+          * IsLocalRing.residue _
+              ⟨_, ag9b12c_uniformizer_div_mul_differentialCoeff_D_mem_finitePlace K hpirr⟩ :=
+        map_mul _ _ _
+    _ = IsLocalRing.residue _ ⟨_, algebraMap_mem_ofHeightOneSpectrum K _ c⟩ := by
+        rw [ag9b12c_residue_uniformizer_div_mul_differentialCoeff_D_eq_one K hpirr, mul_one]
+
+theorem ag9b12c_p1FinitePlaceSimplePoleResidueAdjoinRootValue_of_perfectField
+    :
+    P1FinitePlaceSimplePoleResidueAdjoinRootValue K := by
+  classical
+  intro p c _ hpirr _
+  have : Fact (Irreducible p) := ⟨hpirr⟩
+  intro hfmem
+  rw [ag9b12c_simplePoleResidueAux_finitePlace_p1PrincipalPartAtom_mOne K hpirr hfmem,
+    AlgEquiv.symm_apply_eq, map_div₀,
+    finitePlaceResidueFieldAlgEquivAdjoinRoot_mk K hpirr c,
+    finitePlaceResidueFieldAlgEquivAdjoinRoot_mk K hpirr p.derivative]
+
+end BridgeDischarge
+section TraceValue
+
+theorem ag9b12c_trace_finitePlace_simplePoleResidue_mOne_of_perfectField
+    {p c : K[X]} (hpmon : p.Monic) (hpirr : Irreducible p) (hdeg : c.degree < p.degree)
+    (hfmem : p1PrincipalPartAtom K p c 1 * (finitePlace K hpirr).differentialCoeff (dX K)
+        ∈ (finitePlace K hpirr).simplePoleSubmodule) :
+    Algebra.trace K (finitePlace K hpirr).ResidueField
+        ((finitePlace K hpirr).simplePoleResidueAux ⟨_, hfmem⟩)
+      = c.coeff (p.natDegree - 1) := by
+  classical
+  have : Fact (Irreducible p) := ⟨hpirr⟩
+  have hval := ag9b12c_p1FinitePlaceSimplePoleResidueAdjoinRootValue_of_perfectField K
+    p c hpmon hpirr hdeg
+  rw [trace_finitePlace_residueField_eq_trace_adjoinRoot K hpirr, hval hfmem,
+    ag9b12c_trace_adjoinRoot_mk_div_mk_derivative_of_perfectField K hpmon hdeg]
+
+theorem ag9b12c_p1MOneSimplePoleCancel_dX_of_inftyEulerValue_of_perfectField
+    [DecidableEq (RatFunc K)]
+    (hinf : P1PlaceInftySimplePoleResidueEulerValue K) :
+    P1PrincipalPartMOneSimplePoleCancel K (dX_ne_zero K) := by
+  intro p c hpmon hpirr hdeg hfmem himem
+  rw [ag9b12c_trace_finitePlace_simplePoleResidue_mOne_of_perfectField K
+      hpmon hpirr hdeg hfmem,
+    hinf p c hpmon hpirr hdeg himem, add_neg_cancel]
+
+end TraceValue
+end AlgebraicCurve
+end
+noncomputable section
+
+namespace AlgebraicCurve
+
+section LemmaAPerfect
+
+variable {K : Type*} [Field K] [PerfectField K]
+
+theorem ag9b13e_ratFuncDXCoeff_uniformizer_ne_zero_and_ord_le_of_perfectField
+    (v : Place K (RatFunc K)) {g : RatFunc K} (hg : g ∈ v.toValuationSubring) :
+    ratFuncDXCoeff K v.uniformizer ≠ 0 ∧
+      (ratFuncDXCoeff K g = 0 ∨
+        v.ord (ratFuncDXCoeff K v.uniformizer) ≤ v.ord (ratFuncDXCoeff K g)) := by
+  classical
+  have hg0 : 0 ≤ v.ord g := v.ord_nonneg_of_mem hg
+  rcases eq_or_ne g 0 with rfl | hgne
+  · refine ⟨?_, Or.inl (ratFuncDXCoeff_zero (K := K))⟩
+    rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+    · obtain ⟨p, hp, hwp⟩ := exists_irreducible_span K w
+      exact (ratFuncDXCoeff_ne_zero_and_ord_eq_zero_of_ord_eq_one hp hwp
+        (PerfectField.separable_of_irreducible hp)
+        (Place.uniformizer_ne_zero _) (Place.ord_uniformizer _)).1
+    · exact (ratFuncDXCoeff_ne_zero_and_ord_placeInfty_eq_two_of_ord_eq_one
+        ((placeInfty K).uniformizer_ne_zero) ((placeInfty K).ord_uniformizer)).1
+  · rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+    · obtain ⟨p, hp, hwp⟩ := exists_irreducible_span K w
+      obtain ⟨hπne, hπord⟩ := ratFuncDXCoeff_ne_zero_and_ord_eq_zero_of_ord_eq_one hp hwp
+        (PerfectField.separable_of_irreducible hp)
+        (Place.uniformizer_ne_zero _) (Place.ord_uniformizer _)
+      refine ⟨hπne, ?_⟩
+      rcases ratFuncDXCoeff_eq_zero_or_ord_nonneg_of_ord_nonneg hp hwp hgne hg0 with h0 | hge
+      · exact Or.inl h0
+      · exact Or.inr (by rw [hπord]; exact hge)
+    · obtain ⟨hπne, hπord⟩ :=
+        ratFuncDXCoeff_ne_zero_and_ord_placeInfty_eq_two_of_ord_eq_one
+          (f := (placeInfty K).uniformizer)
+          ((placeInfty K).uniformizer_ne_zero) ((placeInfty K).ord_uniformizer)
+      refine ⟨hπne, ?_⟩
+      rcases ratFuncDXCoeff_eq_zero_or_two_le_ord_placeInfty_of_ord_nonneg hgne hg0
+        with h0 | hge
+      · exact Or.inl h0
+      · exact Or.inr (by rw [hπord]; exact hge)
+
+theorem ag9b13e_differentialCoeff_D_eq_ratFuncDXCoeff_div_of_perfectField
+    (v : Place K (RatFunc K)) (f : RatFunc K)
+    (hπ : ratFuncDXCoeff K v.uniformizer ≠ 0) :
+    v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) f)
+      = ratFuncDXCoeff K f / ratFuncDXCoeff K v.uniformizer :=
+  v.differentialCoeff_unique (by
+    rw [show v.dCoord = KaehlerDifferential.D K (RatFunc K) v.uniformizer from rfl,
+      D_eq_ratFuncDXCoeff_smul_dX K v.uniformizer, D_eq_ratFuncDXCoeff_smul_dX K f,
+      smul_smul, div_mul_cancel₀ _ hπ])
+
+theorem ag9b13e_differentialCoeff_D_mem_of_mem_of_perfectField (v : Place K (RatFunc K))
+    {g : RatFunc K} (hg : g ∈ v.toValuationSubring) :
+    v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) g) ∈ v.toValuationSubring := by
+  obtain ⟨hπne, hcase⟩ :=
+    ag9b13e_ratFuncDXCoeff_uniformizer_ne_zero_and_ord_le_of_perfectField v hg
+  rw [ag9b13e_differentialCoeff_D_eq_ratFuncDXCoeff_div_of_perfectField v g hπne]
+  rcases hcase with h0 | hle
+  · rw [h0, zero_div]; exact zero_mem _
+  · rcases eq_or_ne (ratFuncDXCoeff K g) 0 with h0 | hgne'
+    · rw [h0, zero_div]; exact zero_mem _
+    · refine v.mem_of_ord_nonneg (div_ne_zero hgne' hπne) ?_
+      rw [div_eq_mul_inv, v.ord_mul hgne' (inv_ne_zero hπne), v.ord_inv]
+      omega
+
+end LemmaAPerfect
+section SimplePoleRowPerfect
+
+variable (K : Type*) [Field K] [PerfectField K]
+
+theorem ag9b13e_canonicalLocalResidueKSimplePoleCoordIndep_ratFunc_of_perfectField :
+    CanonicalLocalResidueKSimplePoleCoordIndep K (RatFunc K) :=
+  fun v _ hπ' R =>
+    Place.CanonicalLocalResidueDataK.res_differentialCoeff_D_mul_inv_of_integral v
+      (fun _ hh => ag9b13e_differentialCoeff_D_mem_of_mem_of_perfectField v hh) R hπ'
+
+end SimplePoleRowPerfect
+section ChainPerfect
+
+variable (K : Type*) [Field K] [PerfectField K] [DecidableEq (RatFunc K)]
+
+theorem ag9b13e_p1PlaceInftySimplePoleResidueEulerValueX_of_perfectField :
+    P1PlaceInftySimplePoleResidueEulerValueX K :=
+  p1PlaceInftySimplePoleResidueEulerValueX_of_simplePoleCoordIndep K
+    (ag9b13e_canonicalLocalResidueKSimplePoleCoordIndep_ratFunc_of_perfectField K)
+
+theorem ag9b13e_p1PlaceInftySimplePoleResidueEulerValueMonomial_of_perfectField :
+    P1PlaceInftySimplePoleResidueEulerValueMonomial K :=
+  p1PlaceInftySimplePoleResidueEulerValueMonomial_of_X K
+    (ordDifferential_dX_placeInfty_of_perfectField K)
+    (ag9b13e_p1PlaceInftySimplePoleResidueEulerValueX_of_perfectField K)
+
+theorem ag9b13e_p1PlaceInftySimplePoleResidueEulerValue_of_perfectField :
+    P1PlaceInftySimplePoleResidueEulerValue K :=
+  p1PlaceInftySimplePoleResidueEulerValue_of_monomial K
+    (ordDifferential_dX_placeInfty_of_perfectField K)
+    (ag9b13e_p1PlaceInftySimplePoleResidueEulerValueMonomial_of_perfectField K)
+
+end ChainPerfect
+end AlgebraicCurve
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+section KernelEngine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable [HasCanonicalDivisor (K := K) (F := F)] [∀ v : Place K F, v.DCoordGenerates]
+variable [HasPrincipalDivisors K F]
+
+def kaehlerResidueFunctionalK (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK)
+    {ω : Ω[F⁄K]} (hω : ω ≠ 0) : F →ₗ[K] K :=
+  (weilOfKaehlerK Rfam hω).comp (principalAdele K F)
+
+theorem kaehlerResidueFunctionalK_eq_finsum
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK) {ω : Ω[F⁄K]} (hω : ω ≠ 0) (f : F) :
+    kaehlerResidueFunctionalK Rfam hω f
+      = ∑ᶠ v, kaehlerResidueTermKFam Rfam ω (diagonalHom K F f) v := rfl
+
+theorem kaehlerResidueFunctionalK_eq_zero_of_term_zero_compl
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK) {ω : Ω[F⁄K]} (hω : ω ≠ 0) {f : F}
+    {T : Finset (Place K F)}
+    (hcompl : ∀ v ∉ T, kaehlerResidueTermKFam Rfam ω (diagonalHom K F f) v = 0)
+    (hsum : ∑ v ∈ T, kaehlerResidueTermKFam Rfam ω (diagonalHom K F f) v = 0) :
+    kaehlerResidueFunctionalK Rfam hω f = 0 := by
+  rw [kaehlerResidueFunctionalK_eq_finsum Rfam hω f,
+    finsum_eq_finsetSum_of_support_subset _
+      (fun v hv => by_contra fun hT => hv (hcompl v hT))]
+  exact hsum
+
+theorem kaehlerResidueFunctionalK_eq_zero_of_singleton
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK) {ω : Ω[F⁄K]} (hω : ω ≠ 0) {f : F}
+    {v₀ : Place K F}
+    (hcompl : ∀ v, v ≠ v₀ → kaehlerResidueTermKFam Rfam ω (diagonalHom K F f) v = 0)
+    (hv₀ : kaehlerResidueTermKFam Rfam ω (diagonalHom K F f) v₀ = 0) :
+    kaehlerResidueFunctionalK Rfam hω f = 0 := by
+  classical
+  refine kaehlerResidueFunctionalK_eq_zero_of_term_zero_compl Rfam hω (T := {v₀}) ?_ ?_
+  · intro v hv
+    exact hcompl v (by simpa using hv)
+  · simpa using hv₀
+
+theorem kaehlerResidueFunctionalK_eq_zero_of_pair
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK) {ω : Ω[F⁄K]} (hω : ω ≠ 0) {f : F}
+    {v₀ v₁ : Place K F} (hne : v₀ ≠ v₁)
+    (hcompl : ∀ v, v ≠ v₀ → v ≠ v₁ → kaehlerResidueTermKFam Rfam ω (diagonalHom K F f) v = 0)
+    (hsum : kaehlerResidueTermKFam Rfam ω (diagonalHom K F f) v₀
+      + kaehlerResidueTermKFam Rfam ω (diagonalHom K F f) v₁ = 0) :
+    kaehlerResidueFunctionalK Rfam hω f = 0 := by
+  classical
+  refine kaehlerResidueFunctionalK_eq_zero_of_term_zero_compl Rfam hω (T := {v₀, v₁}) ?_ ?_
+  · intro v hv
+    simp only [Finset.mem_insert, Finset.mem_singleton, not_or] at hv
+    exact hcompl v hv.1 hv.2
+  · rw [Finset.sum_pair hne]
+    exact hsum
+
+end KernelEngine
+section SimplePoleSeam
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem kaehlerResidueTermKFam_eq_of_mem_simplePoleSubmodule
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK)
+    {ω : Ω[F⁄K]} {f : F} {v : Place K F}
+    (hmem : f * v.differentialCoeff ω ∈ v.simplePoleSubmodule) :
+    kaehlerResidueTermKFam Rfam ω (diagonalHom K F f) v
+      = Algebra.trace K v.ResidueField
+          (v.simplePoleResidueAux ⟨f * v.differentialCoeff ω, hmem⟩) := by
+  rw [kaehlerResidueTermKFam_apply, diagonalHom_apply,
+    (Rfam v).res_simplePole (f * v.differentialCoeff ω) hmem]
+  rfl
+
+end SimplePoleSeam
+section SmulReduction
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable [∀ v : Place K F, v.DCoordGenerates] [Nontrivial Ω[F⁄K]]
+
+variable [HasCanonicalDivisor (K := K) (F := F)]
+
+theorem weilOfKaehlerK_smul_diagonal [HasPrincipalDivisors K F]
+    (Rfam : ∀ v : Place K F, v.CanonicalLocalResidueDataK) {g : F} {ω : Ω[F⁄K]}
+    (hω : ω ≠ 0) (hgω : g • ω ≠ 0) (f : F) :
+    weilOfKaehlerK Rfam hgω ⟨diagonalHom K F f, diagonal_mem_adeleSpace f⟩
+      = weilOfKaehlerK Rfam hω
+          ⟨diagonalHom K F (g * f), diagonal_mem_adeleSpace (g * f)⟩ := by
+  rw [weilOfKaehlerK_apply, weilOfKaehlerK_apply]
+  exact finsum_congr fun v => kaehlerResidueTermKFam_smul_diagonal Rfam g ω f v
+
+end SmulReduction
+section PerGenerator
+
+variable {K : Type*} [Field K] [CharZero K] [DecidableEq (RatFunc K)]
+variable [HasPrincipalDivisors K (RatFunc K)]
+
+omit [DecidableEq (RatFunc K)] in
+theorem kaehlerResidueFunctionalK_dX_X_pow
+    (Rfam : ∀ v : Place K (RatFunc K), v.CanonicalLocalResidueDataK) (n : ℕ) :
+    kaehlerResidueFunctionalK Rfam (dX_ne_zero K) ((RatFunc.X : RatFunc K) ^ n) = 0 := by
+  classical
+  refine kaehlerResidueFunctionalK_eq_zero_of_singleton Rfam (dX_ne_zero K)
+    (v₀ := placeInfty K) ?_ ?_
+  · intro v hv
+    refine kaehlerResidueTermKFam_eq_zero_of_ord_nonneg Rfam ?_
+    rw [diagonalHom_apply]
+    exact Or.inr (v.ord_nonneg_of_mem
+      (pow_X_mul_mem_of_ne_placeInfty K hv n (p1DifferentialCoeffRegularFinite_dX K v hv)))
+  · exact residueTheoremK_placeInfty_clause_X_pow Rfam n
+
+omit [HasPrincipalDivisors K (RatFunc K)] in
+theorem kaehlerResidueTermKFam_atom_eq_zero_of_ne_of_ne
+    (Rfam : ∀ v : Place K (RatFunc K), v.CanonicalLocalResidueDataK)
+    {p : K[X]} (hpirr : Irreducible p) (c : K[X]) (m : ℕ) {v : Place K (RatFunc K)}
+    (hvp : v ≠ finitePlace K hpirr) (hvinf : v ≠ placeInfty K) :
+    kaehlerResidueTermKFam Rfam (dX K)
+      (diagonalHom K (RatFunc K) (p1PrincipalPartAtom K p c m)) v = 0 := by
+  refine kaehlerResidueTermKFam_eq_zero_of_ord_nonneg Rfam ?_
+  rw [diagonalHom_apply]
+  exact Or.inr (v.ord_nonneg_of_mem
+    (mul_mem (p1PrincipalPartAtom_mem_of_ne_finitePlace K hpirr c m hvp hvinf)
+      (p1DifferentialCoeffRegularFinite_dX K v hvinf)))
+
+omit [HasPrincipalDivisors K (RatFunc K)] in
+theorem kaehlerResidueTermKFam_atom_placeInfty_eq_zero_of_two_le
+    (Rfam : ∀ v : Place K (RatFunc K), v.CanonicalLocalResidueDataK)
+    (hwd : OrdDifferentialWellDefined K (RatFunc K))
+    {p : K[X]} (hpirr : Irreducible p) (c : K[X]) {m : ℕ}
+    (hdeg : c.degree < p.degree) (hm : 2 ≤ m) :
+    kaehlerResidueTermKFam Rfam (dX K)
+      (diagonalHom K (RatFunc K) (p1PrincipalPartAtom K p c m)) (placeInfty K) = 0 := by
+  refine kaehlerResidueTermKFam_eq_zero_of_ord_nonneg Rfam ?_
+  rw [diagonalHom_apply]
+  rcases eq_or_ne c 0 with rfl | hc
+  · left
+    change algebraMap K[X] (RatFunc K) 0 / (algebraMap K[X] (RatFunc K) p) ^ m
+        * (placeInfty K).differentialCoeff (dX K) = 0
+    rw [_root_.map_zero, zero_div, zero_mul]
+  · right
+    have hatom0 : p1PrincipalPartAtom K p c m ≠ 0 :=
+      p1PrincipalPartAtom_ne_zero K hpirr.ne_zero hc m
+    have hd0 : (placeInfty K).differentialCoeff (dX K) ≠ 0 :=
+      (placeInfty K).differentialCoeff_ne_zero (dX_ne_zero K)
+    rw [(placeInfty K).ord_mul hatom0 hd0]
+    have h2 : 2 ≤ (placeInfty K).ord (p1PrincipalPartAtom K p c m) :=
+      two_le_ord_placeInfty_p1PrincipalPartAtom K hpirr hc hdeg hm
+    have hordD : (placeInfty K).ord ((placeInfty K).differentialCoeff (dX K)) = -2 :=
+      ordDifferential_placeInfty_D_ratFuncX K hwd
+    omega
+
+omit [DecidableEq (RatFunc K)] in
+omit [CharZero K] [HasPrincipalDivisors K (RatFunc K)] in
+theorem kaehlerResidueTermKFam_atom_finitePlace_eq_zero_of_two_le
+    (Rfam : ∀ v : Place K (RatFunc K), v.CanonicalLocalResidueDataK)
+    (hcoord : CanonicalLocalResidueKDifferentialCoordIndep K (RatFunc K))
+    (hHigh5 : P1FinitePlaceCanonicalResidueAtomMGeTwoTraceHigherDeg K)
+    {p c : K[X]} {m : ℕ} (hpmon : p.Monic) (hpirr : Irreducible p)
+    (hdeg : c.degree < p.degree) (hm : 2 ≤ m) :
+    kaehlerResidueTermKFam Rfam (dX K)
+      (diagonalHom K (RatFunc K) (p1PrincipalPartAtom K p c m)) (finitePlace K hpirr) = 0 := by
+  classical
+  rw [kaehlerResidueTermKFam_apply, diagonalHom_apply]
+  exact p1FinitePlaceCanonicalResidueAtomMGeTwoTrace_of_coordIndep_higherDeg K hcoord hHigh5
+    p c m hpmon hpirr hdeg hm (Rfam (finitePlace K hpirr))
+
+omit [HasPrincipalDivisors K (RatFunc K)] in
+theorem kaehlerResidueTermKFam_atom_mOne_two_place_sum
+    (Rfam : ∀ v : Place K (RatFunc K), v.CanonicalLocalResidueDataK)
+    (hwd : OrdDifferentialWellDefined K (RatFunc K))
+    (hsp : CanonicalLocalResidueKSimplePoleCoordIndep K (RatFunc K))
+    {p c : K[X]} (hpmon : p.Monic) (hpirr : Irreducible p) (hdeg : c.degree < p.degree) :
+    kaehlerResidueTermKFam Rfam (dX K)
+        (diagonalHom K (RatFunc K) (p1PrincipalPartAtom K p c 1)) (finitePlace K hpirr)
+      + kaehlerResidueTermKFam Rfam (dX K)
+          (diagonalHom K (RatFunc K) (p1PrincipalPartAtom K p c 1)) (placeInfty K) = 0 := by
+  have hfmem := p1MOneAtom_mul_differentialCoeff_mem_simplePole_finitePlace K
+    (dX_ne_zero K) (p1DifferentialCoeffUnitFinite_dX K) hpirr c hdeg
+  have himem := p1MOneAtom_mul_differentialCoeff_mem_simplePole_placeInfty K
+    (dX_ne_zero K) (ordDifferential_placeInfty_D_ratFuncX K hwd) hpirr c hdeg
+  rw [kaehlerResidueTermKFam_eq_of_mem_simplePoleSubmodule Rfam hfmem,
+    kaehlerResidueTermKFam_eq_of_mem_simplePoleSubmodule Rfam himem]
+  exact p1PrincipalPartMOneSimplePoleCancel_of_simplePoleCoordIndep K hwd
+    (dX_ne_zero K) rfl hsp p c hpmon hpirr hdeg hfmem himem
+
+omit [DecidableEq (RatFunc K)] in
+theorem kaehlerResidueFunctionalK_dX_atom
+    (Rfam : ∀ v : Place K (RatFunc K), v.CanonicalLocalResidueDataK)
+    (hwd : OrdDifferentialWellDefined K (RatFunc K))
+    (hcoord : CanonicalLocalResidueKDifferentialCoordIndep K (RatFunc K))
+    (hsp : CanonicalLocalResidueKSimplePoleCoordIndep K (RatFunc K))
+    (hHigh5 : P1FinitePlaceCanonicalResidueAtomMGeTwoTraceHigherDeg K)
+    {p c : K[X]} {m : ℕ} (hpmon : p.Monic) (hpirr : Irreducible p)
+    (hdeg : c.degree < p.degree) (hm : 1 ≤ m) :
+    kaehlerResidueFunctionalK Rfam (dX_ne_zero K) (p1PrincipalPartAtom K p c m) = 0 := by
+  classical
+  refine kaehlerResidueFunctionalK_eq_zero_of_pair Rfam (dX_ne_zero K)
+    (finitePlace_ne_placeInfty hpirr)
+    (fun v hvp hvinf => kaehlerResidueTermKFam_atom_eq_zero_of_ne_of_ne Rfam hpirr c m
+      hvp hvinf) ?_
+  rcases eq_or_lt_of_le hm with rfl | hm2
+  · exact kaehlerResidueTermKFam_atom_mOne_two_place_sum Rfam hwd hsp hpmon hpirr hdeg
+  · rw [kaehlerResidueTermKFam_atom_finitePlace_eq_zero_of_two_le Rfam hcoord hHigh5
+        hpmon hpirr hdeg hm2,
+      kaehlerResidueTermKFam_atom_placeInfty_eq_zero_of_two_le Rfam hwd hpirr c hdeg hm2,
+      add_zero]
+
+omit [DecidableEq (RatFunc K)] in
+theorem kaehlerResidueFunctionalK_dX_eq_zero
+    (Rfam : ∀ v : Place K (RatFunc K), v.CanonicalLocalResidueDataK)
+    (hwd : OrdDifferentialWellDefined K (RatFunc K))
+    (hcoord : CanonicalLocalResidueKDifferentialCoordIndep K (RatFunc K))
+    (hsp : CanonicalLocalResidueKSimplePoleCoordIndep K (RatFunc K))
+    (hHigh5 : P1FinitePlaceCanonicalResidueAtomMGeTwoTraceHigherDeg K)
+    (h : RatFunc K) :
+    kaehlerResidueFunctionalK Rfam (dX_ne_zero K) h = 0 := by
+  classical
+  have hker : Submodule.span K (P1PartialFractionGenerators K)
+      ≤ LinearMap.ker (kaehlerResidueFunctionalK Rfam (dX_ne_zero K)) := by
+    rw [Submodule.span_le]
+    rintro s hs
+    rw [SetLike.mem_coe, LinearMap.mem_ker]
+    rcases hs with hpoly | hatom
+    · obtain ⟨n, rfl⟩ := hpoly
+      exact kaehlerResidueFunctionalK_dX_X_pow Rfam n
+    · obtain ⟨p, c, m, hpmon, hpirr, hdeg, hm, rfl⟩ := hatom
+      exact kaehlerResidueFunctionalK_dX_atom Rfam hwd hcoord hsp hHigh5 hpmon hpirr hdeg hm
+  have hh : h ∈ LinearMap.ker (kaehlerResidueFunctionalK Rfam (dX_ne_zero K)) := by
+    apply hker
+    rw [p1PartialFractionSpan_eq_top]
+    exact Submodule.mem_top
+  exact LinearMap.mem_ker.mp hh
+
+end PerGenerator
+section Engine
+
+variable {K : Type*} [Field K] [CharZero K]
+
+theorem residueTheoremK_ratFunc_of_subrows
+    (hwd : OrdDifferentialWellDefined K (RatFunc K))
+    (hcoord : CanonicalLocalResidueKDifferentialCoordIndep K (RatFunc K))
+    (hsp : CanonicalLocalResidueKSimplePoleCoordIndep K (RatFunc K))
+    (hHigh5 : P1FinitePlaceCanonicalResidueAtomMGeTwoTraceHigherDeg K) :
+    ResidueTheoremK K (RatFunc K) := by
+  classical
+  intro Rfam instHPD ω hω f
+  obtain ⟨g, hg, rfl⟩ := exists_smul_eq_of_ne_zero (placeInfty K) hω (dX_ne_zero K)
+  calc weilOfKaehlerK Rfam hω
+        ⟨diagonalHom K (RatFunc K) f, diagonal_mem_adeleSpace f⟩
+      = weilOfKaehlerK Rfam (dX_ne_zero K)
+          ⟨diagonalHom K (RatFunc K) (g * f), diagonal_mem_adeleSpace (g * f)⟩ :=
+        weilOfKaehlerK_smul_diagonal Rfam (dX_ne_zero K) hω f
+    _ = 0 := kaehlerResidueFunctionalK_dX_eq_zero Rfam hwd hcoord hsp hHigh5 (g * f)
+
+end Engine
+section AlgClosedDischarge
+
+variable (K : Type*) [Field K] [CharZero K] [IsAlgClosed K]
+
+theorem residueTheoremK_ratFunc_of_isAlgClosed_main : ResidueTheoremK K (RatFunc K) := by
+  classical
+  exact
+    residueTheoremK_ratFunc_of_subrows
+      (ordDifferentialWellDefined_ratFunc K)
+      (canonicalLocalResidueKDifferentialCoordIndep_ratFunc_of_isAlgClosed K)
+      (canonicalLocalResidueKSimplePoleCoordIndep_ratFunc K)
+      (p1FinitePlaceCanonicalResidueAtomMGeTwoTraceHigherDeg_of_algClosed K)
+
+end AlgClosedDischarge
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+namespace AlgebraicCurve
+
+section MOnePerfect
+
+theorem p0n21_rtk_p1MOneSimplePoleCancel_dX_of_perfectField
+    (K : Type*) [Field K] [PerfectField K] [DecidableEq (RatFunc K)] :
+    P1PrincipalPartMOneSimplePoleCancel K (dX_ne_zero K) :=
+  ag9b12c_p1MOneSimplePoleCancel_dX_of_inftyEulerValue_of_perfectField K
+    (ag9b13e_p1PlaceInftySimplePoleResidueEulerValue_of_perfectField K)
+
+end MOnePerfect
+section PerGenerator
+
+variable {K : Type*} [Field K] [PerfectField K] [DecidableEq (RatFunc K)]
+variable [HasPrincipalDivisors K (RatFunc K)]
+
+omit [DecidableEq (RatFunc K)] in
+theorem p0n21_rtk_kaehlerResidueFunctionalK_dX_X_pow
+    (Rfam : ∀ v : Place K (RatFunc K), v.CanonicalLocalResidueDataK)
+    (hwd : OrdDifferentialWellDefined K (RatFunc K))
+    (hcoord : CanonicalLocalResidueKDifferentialCoordIndep K (RatFunc K)) (n : ℕ) :
+    kaehlerResidueFunctionalK Rfam (dX_ne_zero K) ((RatFunc.X : RatFunc K) ^ n) = 0 := by
+  classical
+  refine kaehlerResidueFunctionalK_eq_zero_of_singleton Rfam (dX_ne_zero K)
+    (v₀ := placeInfty K) ?_ ?_
+  · intro v hv
+    refine kaehlerResidueTermKFam_eq_zero_of_ord_nonneg Rfam ?_
+    rw [diagonalHom_apply]
+    exact Or.inr (v.ord_nonneg_of_mem
+      (pow_X_mul_mem_of_ne_placeInfty K hv n
+        (p1DifferentialCoeffRegularFinite_dX_of_perfectField K v hv)))
+  · rw [kaehlerResidueTermKFam_apply]
+    exact canonicalLocalResidueDataK_kaehlerResidueTerm_X_pow_of_coordIndep K hwd hcoord
+      (Rfam (placeInfty K)) n
+
+omit [HasPrincipalDivisors K (RatFunc K)] in
+theorem p0n21_rtk_kaehlerResidueTermKFam_atom_eq_zero_of_ne_of_ne
+    (Rfam : ∀ v : Place K (RatFunc K), v.CanonicalLocalResidueDataK)
+    {p : K[X]} (hpirr : Irreducible p) (c : K[X]) (m : ℕ) {v : Place K (RatFunc K)}
+    (hvp : v ≠ finitePlace K hpirr) (hvinf : v ≠ placeInfty K) :
+    kaehlerResidueTermKFam Rfam (dX K)
+      (diagonalHom K (RatFunc K) (p1PrincipalPartAtom K p c m)) v = 0 := by
+  refine kaehlerResidueTermKFam_eq_zero_of_ord_nonneg Rfam ?_
+  rw [diagonalHom_apply]
+  exact Or.inr (v.ord_nonneg_of_mem
+    (mul_mem (p1PrincipalPartAtom_mem_of_ne_finitePlace K hpirr c m hvp hvinf)
+      (p1DifferentialCoeffRegularFinite_dX_of_perfectField K v hvinf)))
+
+omit [HasPrincipalDivisors K (RatFunc K)] in
+theorem p0n21_rtk_kaehlerResidueTermKFam_atom_placeInfty_eq_zero_of_two_le
+    (Rfam : ∀ v : Place K (RatFunc K), v.CanonicalLocalResidueDataK)
+    (hwd : OrdDifferentialWellDefined K (RatFunc K))
+    {p : K[X]} (hpirr : Irreducible p) (c : K[X]) {m : ℕ}
+    (hdeg : c.degree < p.degree) (hm : 2 ≤ m) :
+    kaehlerResidueTermKFam Rfam (dX K)
+      (diagonalHom K (RatFunc K) (p1PrincipalPartAtom K p c m)) (placeInfty K) = 0 := by
+  refine kaehlerResidueTermKFam_eq_zero_of_ord_nonneg Rfam ?_
+  rw [diagonalHom_apply]
+  rcases eq_or_ne c 0 with rfl | hc
+  · left
+    change algebraMap K[X] (RatFunc K) 0 / (algebraMap K[X] (RatFunc K) p) ^ m
+        * (placeInfty K).differentialCoeff (dX K) = 0
+    rw [_root_.map_zero, zero_div, zero_mul]
+  · right
+    have hatom0 : p1PrincipalPartAtom K p c m ≠ 0 :=
+      p1PrincipalPartAtom_ne_zero K hpirr.ne_zero hc m
+    have hd0 : (placeInfty K).differentialCoeff (dX K) ≠ 0 :=
+      (placeInfty K).differentialCoeff_ne_zero (dX_ne_zero K)
+    rw [(placeInfty K).ord_mul hatom0 hd0]
+    have h2 : 2 ≤ (placeInfty K).ord (p1PrincipalPartAtom K p c m) :=
+      two_le_ord_placeInfty_p1PrincipalPartAtom K hpirr hc hdeg hm
+    have hordD : (placeInfty K).ord ((placeInfty K).differentialCoeff (dX K)) = -2 :=
+      ordDifferential_placeInfty_D_ratFuncX K hwd
+    omega
+
+omit [DecidableEq (RatFunc K)] in
+omit [PerfectField K] [HasPrincipalDivisors K (RatFunc K)] in
+theorem p0n21_rtk_kaehlerResidueTermKFam_atom_finitePlace_eq_zero_of_two_le
+    (Rfam : ∀ v : Place K (RatFunc K), v.CanonicalLocalResidueDataK)
+    (hcoord : CanonicalLocalResidueKDifferentialCoordIndep K (RatFunc K))
+    (hHigh5 : P1FinitePlaceCanonicalResidueAtomMGeTwoTraceHigherDeg K)
+    {p c : K[X]} {m : ℕ} (hpmon : p.Monic) (hpirr : Irreducible p)
+    (hdeg : c.degree < p.degree) (hm : 2 ≤ m) :
+    kaehlerResidueTermKFam Rfam (dX K)
+      (diagonalHom K (RatFunc K) (p1PrincipalPartAtom K p c m)) (finitePlace K hpirr) = 0 := by
+  classical
+  rw [kaehlerResidueTermKFam_apply, diagonalHom_apply]
+  exact p1FinitePlaceCanonicalResidueAtomMGeTwoTrace_of_coordIndep_higherDeg K hcoord hHigh5
+    p c m hpmon hpirr hdeg hm (Rfam (finitePlace K hpirr))
+
+omit [HasPrincipalDivisors K (RatFunc K)] in
+theorem p0n21_rtk_kaehlerResidueTermKFam_atom_mOne_two_place_sum
+    (Rfam : ∀ v : Place K (RatFunc K), v.CanonicalLocalResidueDataK)
+    (hwd : OrdDifferentialWellDefined K (RatFunc K))
+    {p c : K[X]} (hpmon : p.Monic) (hpirr : Irreducible p) (hdeg : c.degree < p.degree) :
+    kaehlerResidueTermKFam Rfam (dX K)
+        (diagonalHom K (RatFunc K) (p1PrincipalPartAtom K p c 1)) (finitePlace K hpirr)
+      + kaehlerResidueTermKFam Rfam (dX K)
+          (diagonalHom K (RatFunc K) (p1PrincipalPartAtom K p c 1)) (placeInfty K) = 0 := by
+  have hfmem := p1MOneAtom_mul_differentialCoeff_mem_simplePole_finitePlace K
+    (dX_ne_zero K) (p1DifferentialCoeffUnitFinite_dX_of_perfectField K) hpirr c hdeg
+  have himem := p1MOneAtom_mul_differentialCoeff_mem_simplePole_placeInfty K
+    (dX_ne_zero K) (ordDifferential_placeInfty_D_ratFuncX K hwd) hpirr c hdeg
+  rw [kaehlerResidueTermKFam_eq_of_mem_simplePoleSubmodule Rfam hfmem,
+    kaehlerResidueTermKFam_eq_of_mem_simplePoleSubmodule Rfam himem]
+  exact p0n21_rtk_p1MOneSimplePoleCancel_dX_of_perfectField K p c hpmon hpirr hdeg hfmem himem
+
+omit [DecidableEq (RatFunc K)] in
+theorem p0n21_rtk_kaehlerResidueFunctionalK_dX_atom
+    (Rfam : ∀ v : Place K (RatFunc K), v.CanonicalLocalResidueDataK)
+    (hwd : OrdDifferentialWellDefined K (RatFunc K))
+    (hcoord : CanonicalLocalResidueKDifferentialCoordIndep K (RatFunc K))
+    (hHigh5 : P1FinitePlaceCanonicalResidueAtomMGeTwoTraceHigherDeg K)
+    {p c : K[X]} {m : ℕ} (hpmon : p.Monic) (hpirr : Irreducible p)
+    (hdeg : c.degree < p.degree) (hm : 1 ≤ m) :
+    kaehlerResidueFunctionalK Rfam (dX_ne_zero K) (p1PrincipalPartAtom K p c m) = 0 := by
+  classical
+  refine kaehlerResidueFunctionalK_eq_zero_of_pair Rfam (dX_ne_zero K)
+    (finitePlace_ne_placeInfty hpirr)
+    (fun v hvp hvinf => p0n21_rtk_kaehlerResidueTermKFam_atom_eq_zero_of_ne_of_ne Rfam hpirr
+      c m hvp hvinf) ?_
+  rcases eq_or_lt_of_le hm with rfl | hm2
+  · exact p0n21_rtk_kaehlerResidueTermKFam_atom_mOne_two_place_sum Rfam hwd hpmon hpirr hdeg
+  · rw [p0n21_rtk_kaehlerResidueTermKFam_atom_finitePlace_eq_zero_of_two_le Rfam hcoord hHigh5
+        hpmon hpirr hdeg hm2,
+      p0n21_rtk_kaehlerResidueTermKFam_atom_placeInfty_eq_zero_of_two_le Rfam hwd hpirr c
+        hdeg hm2,
+      add_zero]
+
+omit [DecidableEq (RatFunc K)] in
+theorem p0n21_rtk_kaehlerResidueFunctionalK_dX_eq_zero
+    (Rfam : ∀ v : Place K (RatFunc K), v.CanonicalLocalResidueDataK)
+    (hwd : OrdDifferentialWellDefined K (RatFunc K))
+    (hcoord : CanonicalLocalResidueKDifferentialCoordIndep K (RatFunc K))
+    (hHigh5 : P1FinitePlaceCanonicalResidueAtomMGeTwoTraceHigherDeg K)
+    (h : RatFunc K) :
+    kaehlerResidueFunctionalK Rfam (dX_ne_zero K) h = 0 := by
+  classical
+  have hker : Submodule.span K (P1PartialFractionGenerators K)
+      ≤ LinearMap.ker (kaehlerResidueFunctionalK Rfam (dX_ne_zero K)) := by
+    rw [Submodule.span_le]
+    rintro s hs
+    rw [SetLike.mem_coe, LinearMap.mem_ker]
+    rcases hs with hpoly | hatom
+    · obtain ⟨n, rfl⟩ := hpoly
+      exact p0n21_rtk_kaehlerResidueFunctionalK_dX_X_pow Rfam hwd hcoord n
+    · obtain ⟨p, c, m, hpmon, hpirr, hdeg, hm, rfl⟩ := hatom
+      exact p0n21_rtk_kaehlerResidueFunctionalK_dX_atom Rfam hwd hcoord hHigh5 hpmon hpirr
+        hdeg hm
+  have hh : h ∈ LinearMap.ker (kaehlerResidueFunctionalK Rfam (dX_ne_zero K)) := by
+    apply hker
+    rw [p1PartialFractionSpan_eq_top]
+    exact Submodule.mem_top
+  exact LinearMap.mem_ker.mp hh
+
+end PerGenerator
+section EngineCharFree
+
+variable {K : Type*} [Field K] [PerfectField K]
+
+theorem p0n21_rtk_residueTheoremK_ratFunc_of_subrows_charFree
+    (hwd : OrdDifferentialWellDefined K (RatFunc K))
+    (hcoord : CanonicalLocalResidueKDifferentialCoordIndep K (RatFunc K))
+    (hHigh5 : P1FinitePlaceCanonicalResidueAtomMGeTwoTraceHigherDeg K) :
+    ResidueTheoremK K (RatFunc K) := by
+  classical
+  intro Rfam instHPD ω hω f
+  obtain ⟨g, hg, rfl⟩ := exists_smul_eq_of_ne_zero (placeInfty K) hω (dX_ne_zero K)
+  calc weilOfKaehlerK Rfam hω
+        ⟨diagonalHom K (RatFunc K) f, diagonal_mem_adeleSpace f⟩
+      = weilOfKaehlerK Rfam (dX_ne_zero K)
+          ⟨diagonalHom K (RatFunc K) (g * f), diagonal_mem_adeleSpace (g * f)⟩ :=
+        weilOfKaehlerK_smul_diagonal Rfam (dX_ne_zero K) hω f
+    _ = 0 := p0n21_rtk_kaehlerResidueFunctionalK_dX_eq_zero Rfam hwd hcoord hHigh5 (g * f)
+
+theorem p0n21_rtk_residueTheoremK_ratFunc_of_coordIndep_higherDeg_of_perfectField
+    (hcoord : CanonicalLocalResidueKDifferentialCoordIndep K (RatFunc K))
+    (hHigh5 : P1FinitePlaceCanonicalResidueAtomMGeTwoTraceHigherDeg K) :
+    ResidueTheoremK K (RatFunc K) := by
+  classical
+  exact
+    p0n21_rtk_residueTheoremK_ratFunc_of_subrows_charFree
+      (ordDifferentialWellDefined_ratFunc_of_perfectField K) hcoord hHigh5
+
+end EngineCharFree
+section AlgClosedAnyChar
+
+theorem p0n21_rtk_residueTheoremK_ratFunc_of_isAlgClosed_of_coordIndep
+    (K : Type*) [Field K] [IsAlgClosed K]
+    (hcoord : CanonicalLocalResidueKDifferentialCoordIndep K (RatFunc K)) :
+    ResidueTheoremK K (RatFunc K) := by
+  classical
+  exact
+    p0n21_rtk_residueTheoremK_ratFunc_of_coordIndep_higherDeg_of_perfectField hcoord
+      (p1FinitePlaceCanonicalResidueAtomMGeTwoTraceHigherDeg_of_algClosed K)
+
+end AlgClosedAnyChar
+
+section ResidualLocation
+
+theorem p0n21_rtk_surjective_algebraMap_residueField_of_deg_eq_one
+    {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) (hdeg : v.deg = 1) :
+    Function.Surjective (algebraMap K v.ResidueField) := by
+  intro z
+  obtain ⟨c, hc⟩ := (finrank_eq_one_iff_of_nonzero' (1 : v.ResidueField) one_ne_zero).mp
+    (show Module.finrank K v.ResidueField = 1 from hdeg) z
+  exact ⟨c, by rw [Algebra.algebraMap_eq_smul_one]; exact hc⟩
+
+theorem p0n21_rtk_surjective_algebraMap_residueField_ratFunc_of_isAlgClosed
+    (K : Type*) [Field K] [IsAlgClosed K] (v : Place K (RatFunc K)) :
+    Function.Surjective (algebraMap K v.ResidueField) := by
+  classical
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+  · obtain ⟨p, hp, hwp⟩ := exists_irreducible_span K w
+    refine p0n21_rtk_surjective_algebraMap_residueField_of_deg_eq_one _ ?_
+    rw [deg_ofHeightOneSpectrum K hwp]
+    have h := IsAlgClosed.degree_eq_one_of_irreducible K hp
+    rw [degree_eq_natDegree hp.ne_zero] at h
+    exact_mod_cast h
+  · exact surjective_algebraMap_residueField_placeInfty K
+
+end ResidualLocation
+end AlgebraicCurve
+end
+noncomputable section
+
+open MilneAvAg9bRd14CubeRowCartierSliceStart MilneAvAg9bRd13T2CoordIndepChar3
+
+namespace AlgebraicCurve
+
+section CharFreeToolkit
+
+variable {K : Type*} [Field K]
+
+theorem p0n22_cpf_uniformizer_pow_mul_mem_cases
+    (v : Place K (RatFunc K))
+    {σ : RatFunc K} (hσ : σ ∈ v.toValuationSubring) {k : ℕ} (hk : 1 ≤ k) :
+    v.uniformizer ^ k * σ = 0 ∨ 1 ≤ v.ord (v.uniformizer ^ k * σ) := by
+  rcases eq_or_ne σ 0 with rfl | hσ0
+  · exact Or.inl (mul_zero _)
+  · right
+    rw [v.ord_mul (v.uniformizer_pow_ne_zero k) hσ0, v.ord_uniformizer_pow]
+    have := v.ord_nonneg_of_mem hσ
+    omega
+
+theorem p0n22_cpf_one_add_ne_zero
+    (v : Place K (RatFunc K))
+    {g : RatFunc K} (hg : g = 0 ∨ 1 ≤ v.ord g) :
+    (1 : RatFunc K) + g ≠ 0 := by
+  rcases hg with rfl | hord
+  · simp
+  · intro h
+    rw [eq_neg_of_add_eq_zero_right h] at hord
+    have hneg : v.ord (-1 : RatFunc K) = 0 := by
+      have h2 : v.ord ((-1 : RatFunc K) * (-1)) = v.ord (-1 : RatFunc K)
+          + v.ord (-1 : RatFunc K) :=
+        v.ord_mul (neg_ne_zero.mpr one_ne_zero) (neg_ne_zero.mpr one_ne_zero)
+      rw [neg_mul_neg, one_mul, v.ord_one] at h2
+      omega
+    omega
+
+theorem p0n22_cpf_ord_one_add_eq_zero
+    (v : Place K (RatFunc K))
+    {g : RatFunc K} (hg : g = 0 ∨ 1 ≤ v.ord g) :
+    v.ord ((1 : RatFunc K) + g) = 0 := by
+  rcases hg with rfl | hord
+  · rw [add_zero, v.ord_one]
+  · have hg0 : g ≠ 0 := by
+      intro h
+      rw [h, v.ord_zero] at hord
+      omega
+    have h1 := v.ord_add_eq_min (f := (1 : RatFunc K)) (g := g) one_ne_zero hg0
+      (by rw [v.ord_one]; omega)
+    rw [v.ord_one] at h1
+    omega
+
+theorem p0n22_cpf_one_add_inv_mem
+    (v : Place K (RatFunc K))
+    {g : RatFunc K} (hg : g = 0 ∨ 1 ≤ v.ord g) :
+    ((1 : RatFunc K) + g)⁻¹ ∈ v.toValuationSubring := by
+  refine v.mem_of_ord_nonneg (inv_ne_zero (p0n22_cpf_one_add_ne_zero v hg)) ?_
+  rw [v.ord_inv, p0n22_cpf_ord_one_add_eq_zero v hg, _root_.neg_zero]
+
+theorem p0n22_cpf_logDeriv_mul [PerfectField K]
+    (v : Place K (RatFunc K)) [v.DCoordGenerates]
+    [Nontrivial Ω[(RatFunc K)⁄K]]
+    {w₁ w₂ : RatFunc K} (h1 : w₁ ≠ 0) (h2 : w₂ ≠ 0) :
+    v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) (w₁ * w₂))
+        * (w₁ * w₂)⁻¹
+      = v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) w₁) * w₁⁻¹
+        + v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) w₂)
+            * w₂⁻¹ := by
+  rw [Derivation.leibniz, v.differentialCoeff_add'', v.differentialCoeff_smul,
+    v.differentialCoeff_smul]
+  have hc1 : w₁ * w₁⁻¹ = 1 := mul_inv_cancel₀ h1
+  have hc2 : w₂ * w₂⁻¹ = 1 := mul_inv_cancel₀ h2
+  linear_combination
+    (v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) w₂) * w₂⁻¹)
+      * hc1
+    + (v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) w₁) * w₁⁻¹)
+      * hc2
+
+theorem p0n22_cpf_logDeriv_mem [PerfectField K]
+    (v : Place K (RatFunc K)) [v.DCoordGenerates]
+    [Nontrivial Ω[(RatFunc K)⁄K]]
+    {w : RatFunc K} (hw0 : w ≠ 0) (hword : v.ord w = 0) :
+    v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) w) * w⁻¹
+      ∈ v.toValuationSubring := by
+  have hwmem : w ∈ v.toValuationSubring := v.mem_of_ord_nonneg hw0 hword.ge
+  have hwinv : w⁻¹ ∈ v.toValuationSubring := by
+    refine v.mem_of_ord_nonneg (inv_ne_zero hw0) ?_
+    rw [v.ord_inv, hword, _root_.neg_zero]
+  exact mul_mem (ag9b13e_differentialCoeff_D_mem_of_mem_of_perfectField v hwmem) hwinv
+
+theorem p0n22_cpf_differentialCoeff_D_one_add_algebraMap_mul_pow
+    (v : Place K (RatFunc K)) [v.DCoordGenerates]
+    [Nontrivial Ω[(RatFunc K)⁄K]] (a : K) (k : ℕ) :
+    v.differentialCoeff (KaehlerDifferential.D K (RatFunc K)
+        ((1 : RatFunc K)
+          + algebraMap K (RatFunc K) a * v.uniformizer ^ k))
+      = algebraMap K (RatFunc K) a
+        * (((k : ℕ) : RatFunc K) * v.uniformizer ^ (k - 1)) := by
+  refine v.differentialCoeff_unique ?_
+  rw [map_add, Derivation.map_one_eq_zero, zero_add, Derivation.leibniz,
+    Derivation.map_algebraMap, smul_zero, add_zero, Derivation.leibniz_pow,
+    show KaehlerDifferential.D K (RatFunc K) v.uniformizer = v.dCoord from
+      rfl,
+    ← Nat.cast_smul_eq_nsmul (RatFunc K) k, smul_smul, smul_smul, mul_assoc]
+
+theorem p0n22_cpf_differentialCoeff_D_one_add_pow_mul
+    (v : Place K (RatFunc K)) [v.DCoordGenerates]
+    [Nontrivial Ω[(RatFunc K)⁄K]] (σ : RatFunc K) (k : ℕ) :
+    v.differentialCoeff (KaehlerDifferential.D K (RatFunc K)
+        ((1 : RatFunc K) + v.uniformizer ^ k * σ))
+      = v.uniformizer ^ k
+          * v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) σ)
+        + σ * (((k : ℕ) : RatFunc K) * v.uniformizer ^ (k - 1)) := by
+  refine v.differentialCoeff_unique ?_
+  conv_lhs => rw [map_add, Derivation.map_one_eq_zero, zero_add, Derivation.leibniz,
+    Derivation.leibniz_pow,
+    show KaehlerDifferential.D K (RatFunc K) v.uniformizer = v.dCoord from
+      rfl,
+    ← Nat.cast_smul_eq_nsmul (RatFunc K) k,
+    ← v.differentialCoeff_smul_dCoord
+      (KaehlerDifferential.D K (RatFunc K) σ),
+    smul_smul, smul_smul, smul_smul, ← add_smul]
+  exact congrArg (· • v.dCoord) (by ring)
+
+theorem p0n22_cpf_exists_residue_lift_decomp
+    (v : Place K (RatFunc K))
+    (hsurj : Function.Surjective (algebraMap K v.ResidueField))
+    {r : RatFunc K} (hr : r ∈ v.toValuationSubring) :
+    ∃ (d : K) (r' : RatFunc K), r' ∈ v.toValuationSubring ∧
+      r = algebraMap K (RatFunc K) d + v.uniformizer * r' := by
+  obtain ⟨d, hd⟩ := hsurj (IsLocalRing.residue _ (⟨r, hr⟩ : v.toValuationSubring))
+  have hxmem : r - algebraMap K (RatFunc K) d ∈ v.toValuationSubring :=
+    sub_mem hr (v.algebraMap_mem' d)
+  have hres0 : IsLocalRing.residue _
+      (⟨r - algebraMap K (RatFunc K) d, hxmem⟩ : v.toValuationSubring)
+      = 0 := by
+    have hfact : (⟨r - algebraMap K (RatFunc K) d, hxmem⟩
+        : v.toValuationSubring)
+        = ⟨r, hr⟩ - algebraMap K v.toValuationSubring d :=
+      Subtype.ext (by push_cast [v.coe_algebraMap]; ring)
+    have h2 : IsLocalRing.residue _ (algebraMap K v.toValuationSubring d)
+        = IsLocalRing.residue _ (⟨r, hr⟩ : v.toValuationSubring) := by
+      rw [← hd, IsScalarTower.algebraMap_apply K v.toValuationSubring
+        v.ResidueField, IsLocalRing.ResidueField.algebraMap_eq]
+    rw [hfact, map_sub, h2, sub_self]
+  rcases
+    MilneAvAg9bRd15UnitNormalFormLaurentSeed.ag9b15u_eq_zero_or_one_le_ord_of_residue_eq_zero
+      v hxmem hres0 with hx0 | hxord
+  · exact ⟨d, 0, zero_mem _, by rw [mul_zero, add_zero]; exact (sub_eq_zero.mp hx0)⟩
+  · have hxne : r - algebraMap K (RatFunc K) d ≠ 0 := by
+      intro h0
+      rw [h0, v.ord_zero] at hxord
+      omega
+    refine ⟨d, v.uniformizer⁻¹ * (r - algebraMap K (RatFunc K) d), ?_, ?_⟩
+    · refine v.mem_of_ord_nonneg
+        (mul_ne_zero (inv_ne_zero v.uniformizer_ne_zero) hxne) ?_
+      rw [v.ord_mul (inv_ne_zero v.uniformizer_ne_zero) hxne, v.ord_inv,
+        v.ord_uniformizer]
+      omega
+    · rw [← mul_assoc, mul_inv_cancel₀ v.uniformizer_ne_zero, one_mul]
+      ring
+
+theorem p0n22_cpf_exists_elementary_peel
+    (v : Place K (RatFunc K))
+    (hsurj : Function.Surjective (algebraMap K v.ResidueField))
+    {k : ℕ} (hk : 1 ≤ k) {σ : RatFunc K} (hσ : σ ∈ v.toValuationSubring) :
+    ∃ (a : K) (τ : RatFunc K), τ ∈ v.toValuationSubring ∧
+      (1 : RatFunc K) + v.uniformizer ^ k * σ
+        = ((1 : RatFunc K)
+              + algebraMap K (RatFunc K) a * v.uniformizer ^ k)
+          * ((1 : RatFunc K) + v.uniformizer ^ (k + 1) * τ) := by
+  obtain ⟨a, σ', hσ', hdec⟩ := p0n22_cpf_exists_residue_lift_decomp v hsurj hσ
+  have hgcase : algebraMap K (RatFunc K) a * v.uniformizer ^ k = 0
+      ∨ 1 ≤ v.ord (algebraMap K (RatFunc K) a * v.uniformizer ^ k) := by
+    rw [mul_comm]
+    exact p0n22_cpf_uniformizer_pow_mul_mem_cases v (v.algebraMap_mem' a) hk
+  have he0 : (1 : RatFunc K)
+      + algebraMap K (RatFunc K) a * v.uniformizer ^ k ≠ 0 :=
+    p0n22_cpf_one_add_ne_zero v hgcase
+  have heinv : ((1 : RatFunc K)
+      + algebraMap K (RatFunc K) a * v.uniformizer ^ k)⁻¹
+      ∈ v.toValuationSubring :=
+    p0n22_cpf_one_add_inv_mem v hgcase
+  refine ⟨a, σ' * ((1 : RatFunc K)
+    + algebraMap K (RatFunc K) a * v.uniformizer ^ k)⁻¹,
+    mul_mem hσ' heinv, ?_⟩
+  have hce : ((1 : RatFunc K)
+      + algebraMap K (RatFunc K) a * v.uniformizer ^ k)
+      * ((1 : RatFunc K)
+          + algebraMap K (RatFunc K) a * v.uniformizer ^ k)⁻¹ = 1 :=
+    mul_inv_cancel₀ he0
+  rw [hdec]
+  linear_combination (-(v.uniformizer ^ (k + 1) * σ')) * hce
+
+theorem p0n22_cpf_exists_laurent_expansion_one
+    (v : Place K (RatFunc K))
+    (hsurj : Function.Surjective (algebraMap K v.ResidueField))
+    (f : RatFunc K) :
+    ∃ (s : Finset ℤ) (c : ℤ → K) (r : RatFunc K),
+      r ∈ v.toValuationSubring ∧
+      f = (∑ j ∈ s, c j • v.uniformizer ^ j) + v.uniformizer * r := by
+  obtain ⟨N, hN⟩ := v.exists_mem_poleSubmodule f
+  obtain ⟨c0, hc0⟩ :=
+    MilneAvAg9bRd15UnitNormalFormLaurentSeed.ag9b15u_exists_K_truncation_of_mem_poleSubmodule
+      v hsurj N hN
+  obtain ⟨d, r, hr, hdec⟩ := p0n22_cpf_exists_residue_lift_decomp v hsurj hc0
+  refine ⟨insert (0 : ℤ) ((Finset.range N).image fun j : ℕ => -((j : ℤ) + 1)),
+    fun t => if t = 0 then d else c0 (-(t + 1)).toNat, r, hr, ?_⟩
+  have h0not : (0 : ℤ) ∉ (Finset.range N).image (fun j : ℕ => -((j : ℤ) + 1)) := by
+    simp only [Finset.mem_image, Finset.mem_range]
+    rintro ⟨j, _, hj⟩
+    omega
+  have hinj : ∀ x ∈ Finset.range N, ∀ y ∈ Finset.range N,
+      -((x : ℤ) + 1) = -((y : ℤ) + 1) → x = y := fun x _ y _ h => by omega
+  have himg : ∀ j ∈ Finset.range N,
+      (if -((j : ℤ) + 1) = 0 then d else c0 (-(-((j : ℤ) + 1) + 1)).toNat)
+          • v.uniformizer ^ (-((j : ℤ) + 1))
+        = algebraMap K (RatFunc K) (c0 j)
+            * (v.uniformizer ^ (j + 1))⁻¹ := by
+    intro j _
+    rw [ite_eq_right (by omega : ¬(-((j : ℤ) + 1) = (0 : ℤ))),
+      show (-(-((j : ℤ) + 1) + 1)).toNat = j from by omega,
+      Algebra.smul_def, _root_.zpow_neg,
+      show ((j : ℤ) + 1) = ((j + 1 : ℕ) : ℤ) from by push_cast; ring, zpow_natCast]
+  rw [Finset.sum_insert h0not, Finset.sum_image hinj, Finset.sum_congr rfl himg,
+    show ((fun t : ℤ => if t = 0 then d else c0 (-(t + 1)).toNat) 0) = d from by simp,
+    zpow_zero, Algebra.smul_def, mul_one]
+  linear_combination hdec
+
+theorem p0n22_cpf_res_geom_core
+    (v : Place K (RatFunc K)) (R : v.CanonicalLocalResidueDataK)
+    (a : K) {k q : ℕ} (hk : 1 ≤ k) (hq : 1 ≤ q) :
+    R.res (algebraMap K (RatFunc K) a * v.uniformizer ^ (k - 1)
+        * ((1 : RatFunc K)
+            + algebraMap K (RatFunc K) a * v.uniformizer ^ k)⁻¹
+        * (v.uniformizer ^ q)⁻¹)
+      = if k ∣ q
+        then algebraMap K v.ResidueField (a * (-a) ^ (q / k - 1))
+        else 0 := by
+  have hπ0 : (v.uniformizer : RatFunc K) ≠ 0 := v.uniformizer_ne_zero
+  have hgcase : algebraMap K (RatFunc K) a * v.uniformizer ^ k = 0
+      ∨ 1 ≤ v.ord (algebraMap K (RatFunc K) a * v.uniformizer ^ k) := by
+    rw [mul_comm]
+    exact p0n22_cpf_uniformizer_pow_mul_mem_cases v (v.algebraMap_mem' a) hk
+  have hu0 : (1 : RatFunc K)
+      + algebraMap K (RatFunc K) a * v.uniformizer ^ k ≠ 0 :=
+    p0n22_cpf_one_add_ne_zero v hgcase
+  have huinv : ((1 : RatFunc K)
+      + algebraMap K (RatFunc K) a * v.uniformizer ^ k)⁻¹
+      ∈ v.toValuationSubring :=
+    p0n22_cpf_one_add_inv_mem v hgcase
+  have hgeom : ((1 : RatFunc K)
+      + algebraMap K (RatFunc K) a * v.uniformizer ^ k)⁻¹
+      = (∑ t ∈ Finset.range q,
+          (-(algebraMap K (RatFunc K) a * v.uniformizer ^ k)) ^ t)
+        + (-(algebraMap K (RatFunc K) a * v.uniformizer ^ k)) ^ q
+          * ((1 : RatFunc K)
+              + algebraMap K (RatFunc K) a * v.uniformizer ^ k)⁻¹ := by
+    refine (eq_inv_of_mul_eq_one_left ?_).symm
+    rw [add_mul, mul_assoc, inv_mul_cancel₀ hu0, mul_one]
+    have hgs := geom_sum_mul
+      (-(algebraMap K (RatFunc K) a * v.uniformizer ^ k)) q
+    linear_combination -hgs
+  rw [hgeom, mul_add, add_mul, map_add]
+  have htail : R.res ((algebraMap K (RatFunc K) a * v.uniformizer ^ (k - 1)
+      * ((-(algebraMap K (RatFunc K) a * v.uniformizer ^ k)) ^ q
+          * ((1 : RatFunc K)
+              + algebraMap K (RatFunc K) a * v.uniformizer ^ k)⁻¹))
+      * (v.uniformizer ^ q)⁻¹) = 0 := by
+    apply R.res_of_mem
+    have hqle : q ≤ k * q := Nat.le_of_dvd (Nat.mul_pos hk hq) (dvd_mul_left q k)
+    have hpowsplit : (v.uniformizer : RatFunc K) ^ (k * q)
+        = v.uniformizer ^ (k * q - q) * v.uniformizer ^ q := by
+      rw [← pow_add, Nat.sub_add_cancel hqle]
+    have hxq : (-(algebraMap K (RatFunc K) a * v.uniformizer ^ k)) ^ q
+        = algebraMap K (RatFunc K) ((-a) ^ q)
+          * (v.uniformizer ^ (k * q - q) * v.uniformizer ^ q) := by
+      rw [map_pow, _root_.map_neg,
+        show -(algebraMap K (RatFunc K) a * v.uniformizer ^ k)
+            = -algebraMap K (RatFunc K) a * v.uniformizer ^ k from
+          (neg_mul _ _).symm,
+        mul_pow, ← pow_mul, hpowsplit]
+    have hcc : (v.uniformizer : RatFunc K) ^ q
+        * ((v.uniformizer : RatFunc K) ^ q)⁻¹ = 1 :=
+      mul_inv_cancel₀ (pow_ne_zero _ hπ0)
+    have heq : (algebraMap K (RatFunc K) a * v.uniformizer ^ (k - 1)
+        * ((-(algebraMap K (RatFunc K) a * v.uniformizer ^ k)) ^ q
+            * ((1 : RatFunc K)
+                + algebraMap K (RatFunc K) a * v.uniformizer ^ k)⁻¹))
+        * (v.uniformizer ^ q)⁻¹
+        = algebraMap K (RatFunc K) a * v.uniformizer ^ (k - 1)
+          * (algebraMap K (RatFunc K) ((-a) ^ q)
+              * v.uniformizer ^ (k * q - q)
+              * ((1 : RatFunc K)
+                  + algebraMap K (RatFunc K) a * v.uniformizer ^ k)⁻¹) := by
+      rw [hxq]
+      linear_combination (algebraMap K (RatFunc K) a
+        * v.uniformizer ^ (k - 1)
+        * (algebraMap K (RatFunc K) ((-a) ^ q)
+            * v.uniformizer ^ (k * q - q)
+            * ((1 : RatFunc K)
+                + algebraMap K (RatFunc K) a * v.uniformizer ^ k)⁻¹)) * hcc
+    rw [heq]
+    exact mul_mem (mul_mem (v.algebraMap_mem' a) (pow_mem v.uniformizer_mem _))
+      (mul_mem (mul_mem (v.algebraMap_mem' _) (pow_mem v.uniformizer_mem _)) huinv)
+  have hterm : (algebraMap K (RatFunc K) a * v.uniformizer ^ (k - 1)
+      * (∑ t ∈ Finset.range q,
+          (-(algebraMap K (RatFunc K) a * v.uniformizer ^ k)) ^ t))
+      * (v.uniformizer ^ q)⁻¹
+      = ∑ t ∈ Finset.range q, (a * (-a) ^ t)
+          • v.uniformizer ^ ((k : ℤ) * ((t : ℤ) + 1) - 1 - (q : ℤ)) := by
+    rw [Finset.mul_sum, Finset.sum_mul]
+    refine Finset.sum_congr rfl fun t _ => ?_
+    have hxt : (-(algebraMap K (RatFunc K) a * v.uniformizer ^ k)) ^ t
+        = algebraMap K (RatFunc K) ((-a) ^ t)
+          * v.uniformizer ^ (k * t) := by
+      rw [map_pow, _root_.map_neg,
+        show -(algebraMap K (RatFunc K) a * v.uniformizer ^ k)
+            = -algebraMap K (RatFunc K) a * v.uniformizer ^ k from
+          (neg_mul _ _).symm,
+        mul_pow, ← pow_mul]
+    rw [hxt, Algebra.smul_def, map_mul, map_pow, _root_.map_neg,
+      show (k : ℤ) * ((t : ℤ) + 1) - 1 - (q : ℤ)
+          = ((k - 1 : ℕ) : ℤ) + ((k * t : ℕ) : ℤ) + -((q : ℕ) : ℤ) from by
+        push_cast [Nat.cast_sub hk]
+        ring,
+      zpow_add₀ hπ0, zpow_add₀ hπ0, zpow_natCast, zpow_natCast, _root_.zpow_neg, zpow_natCast]
+    ring
+  rw [hterm, map_sum]
+  simp only [map_smul]
+  by_cases hdvd : k ∣ q
+  · rw [ite_eq_left hdvd, htail, add_zero]
+    obtain ⟨e, rfl⟩ := hdvd
+    rcases Nat.eq_zero_or_pos e with rfl | he1
+    · simp at hq
+    · rw [Nat.mul_div_cancel_left e hk]
+      have he_lt : e - 1 < k * e := by
+        have h1 : e ≤ k * e := Nat.le_of_dvd (Nat.mul_pos hk he1) (dvd_mul_left e k)
+        omega
+      have hother : ∀ t ∈ Finset.range (k * e), t ≠ e - 1 →
+          (a * (-a) ^ t) • R.res ((v.uniformizer : RatFunc K)
+            ^ ((k : ℤ) * ((t : ℤ) + 1) - 1 - ((k * e : ℕ) : ℤ))) = 0 := by
+        intro t _ htne
+        have hne : (k : ℤ) * ((t : ℤ) + 1) - 1 - ((k * e : ℕ) : ℤ) ≠ -1 := by
+          intro hcontra
+          have h2 : (k : ℤ) * ((t : ℤ) + 1) = (k : ℤ) * (e : ℤ) := by
+            push_cast at hcontra
+            linarith
+          have hk0 : (k : ℤ) ≠ 0 := by omega
+          have h3 : (t : ℤ) + 1 = (e : ℤ) := mul_left_cancel₀ hk0 h2
+          omega
+        rw [ag9b14c_res_uniformizer_zpow_eq_zero_of_ne_neg_one v R hne, smul_zero]
+      rw [Finset.sum_eq_single_of_mem (e - 1) (Finset.mem_range.mpr he_lt) hother,
+        show (k : ℤ) * (((e - 1 : ℕ) : ℤ) + 1) - 1 - ((k * e : ℕ) : ℤ) = -1 from by
+          push_cast [Nat.cast_sub he1]
+          ring,
+        _root_.zpow_neg, zpow_one, gate_canonicalLocalResidueDataK_uniformizer_inv v R,
+        ← Algebra.algebraMap_eq_smul_one]
+  · rw [ite_eq_right hdvd, htail, add_zero]
+    refine Finset.sum_eq_zero fun t _ => ?_
+    have hne : (k : ℤ) * ((t : ℤ) + 1) - 1 - (q : ℤ) ≠ -1 := by
+      intro hcontra
+      have h2 : (k : ℤ) * ((t : ℤ) + 1) = (q : ℤ) := by linarith
+      have h3 : k * (t + 1) = q := by exact_mod_cast h2
+      exact hdvd ⟨t + 1, h3.symm⟩
+    rw
+      [ag9b14c_res_uniformizer_zpow_eq_zero_of_ne_neg_one v R hne, smul_zero]
+
+theorem p0n22_cpf_res_logDeriv_elementary
+    (v : Place K (RatFunc K)) [v.DCoordGenerates]
+    [Nontrivial Ω[(RatFunc K)⁄K]]
+    (R : v.CanonicalLocalResidueDataK) (a : K) {k q : ℕ} (hk : 1 ≤ k) (hq : 1 ≤ q) :
+    R.res (v.differentialCoeff (KaehlerDifferential.D K (RatFunc K)
+          ((1 : RatFunc K)
+            + algebraMap K (RatFunc K) a * v.uniformizer ^ k))
+        * ((1 : RatFunc K)
+            + algebraMap K (RatFunc K) a * v.uniformizer ^ k)⁻¹
+        * (v.uniformizer ^ q)⁻¹)
+      = ((k : ℕ) : K) • (if k ∣ q
+          then algebraMap K v.ResidueField (a * (-a) ^ (q / k - 1))
+          else 0) := by
+  rw [p0n22_cpf_differentialCoeff_D_one_add_algebraMap_mul_pow v a k]
+  have hsplit : algebraMap K (RatFunc K) a
+        * (((k : ℕ) : RatFunc K) * v.uniformizer ^ (k - 1))
+        * ((1 : RatFunc K)
+            + algebraMap K (RatFunc K) a * v.uniformizer ^ k)⁻¹
+        * (v.uniformizer ^ q)⁻¹
+      = ((k : ℕ) : K) • (algebraMap K (RatFunc K) a
+          * v.uniformizer ^ (k - 1)
+          * ((1 : RatFunc K)
+              + algebraMap K (RatFunc K) a * v.uniformizer ^ k)⁻¹
+          * (v.uniformizer ^ q)⁻¹) := by
+    rw [Algebra.smul_def, map_natCast]
+    ring
+  rw [hsplit, map_smul, p0n22_cpf_res_geom_core v R a hk hq]
+
+theorem p0n22_cpf_res_logDeriv_highLevel_vanish [PerfectField K]
+    (v : Place K (RatFunc K)) [v.DCoordGenerates]
+    [Nontrivial Ω[(RatFunc K)⁄K]]
+    (R : v.CanonicalLocalResidueDataK)
+    {σ : RatFunc K} (hσ : σ ∈ v.toValuationSubring)
+    {k q : ℕ} (hbig : q + 1 ≤ k) :
+    R.res (v.differentialCoeff (KaehlerDifferential.D K (RatFunc K)
+          ((1 : RatFunc K) + v.uniformizer ^ k * σ))
+        * ((1 : RatFunc K) + v.uniformizer ^ k * σ)⁻¹
+        * (v.uniformizer ^ q)⁻¹) = 0 := by
+  have hπ0 : (v.uniformizer : RatFunc K) ≠ 0 := v.uniformizer_ne_zero
+  have hgcase := p0n22_cpf_uniformizer_pow_mul_mem_cases v hσ
+    (show 1 ≤ k by omega)
+  have huinv := p0n22_cpf_one_add_inv_mem v hgcase
+  have hσ' : v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) σ)
+      ∈ v.toValuationSubring :=
+    ag9b13e_differentialCoeff_D_mem_of_mem_of_perfectField v hσ
+  have hkF : ((k : ℕ) : RatFunc K) ∈ v.toValuationSubring := by
+    rw [← map_natCast (algebraMap K (RatFunc K))]
+    exact v.algebraMap_mem' _
+  obtain ⟨e, rfl⟩ : ∃ e, k = q + 1 + e := ⟨k - (q + 1), by omega⟩
+  apply R.res_of_mem
+  rw [p0n22_cpf_differentialCoeff_D_one_add_pow_mul v σ (q + 1 + e)]
+  have hcc : (v.uniformizer : RatFunc K) ^ q
+      * ((v.uniformizer : RatFunc K) ^ q)⁻¹ = 1 :=
+    mul_inv_cancel₀ (pow_ne_zero _ hπ0)
+  have heq : (v.uniformizer ^ (q + 1 + e)
+        * v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) σ)
+        + σ * (((q + 1 + e : ℕ) : RatFunc K) * v.uniformizer ^ (q + 1 + e - 1)))
+        * ((1 : RatFunc K) + v.uniformizer ^ (q + 1 + e) * σ)⁻¹
+        * (v.uniformizer ^ q)⁻¹
+      = (v.uniformizer ^ (1 + e)
+          * v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) σ)
+          + σ * (((q + 1 + e : ℕ) : RatFunc K) * v.uniformizer ^ e))
+        * ((1 : RatFunc K) + v.uniformizer ^ (q + 1 + e) * σ)⁻¹ := by
+    rw [show q + 1 + e - 1 = q + e from by omega]
+    linear_combination ((v.uniformizer ^ (1 + e)
+        * v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) σ)
+        + σ * (((q + 1 + e : ℕ) : RatFunc K) * v.uniformizer ^ e))
+      * ((1 : RatFunc K) + v.uniformizer ^ (q + 1 + e) * σ)⁻¹) * hcc
+  rw [heq]
+  exact mul_mem (add_mem (mul_mem (pow_mem v.uniformizer_mem _) hσ')
+    (mul_mem hσ (mul_mem hkF (pow_mem v.uniformizer_mem _)))) huinv
+
+theorem p0n22_cpf_row_integrand_eq_pow_mul_dlog
+    (v : Place K (RatFunc K)) [v.DCoordGenerates]
+    [Nontrivial Ω[(RatFunc K)⁄K]]
+    {w : RatFunc K} (hw0 : w ≠ 0) (k : ℕ) :
+    v.differentialCoeff (KaehlerDifferential.D K (RatFunc K)
+        (w * v.uniformizer))
+        * ((w * v.uniformizer) ^ (k + 1))⁻¹
+      = (w ^ k * v.uniformizer ^ k)⁻¹
+        * ((v.uniformizer)⁻¹
+            + v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) w)
+                * w⁻¹) := by
+  rw [MilneAvAg9bRd15UnitNormalFormLaurentSeed.ag9b15u_differentialCoeff_D_unit_mul_uniformizer]
+  have hπ0 : (v.uniformizer : RatFunc K) ≠ 0 := v.uniformizer_ne_zero
+  have hcw : w * w⁻¹ = 1 := mul_inv_cancel₀ hw0
+  have hcπ : (v.uniformizer : RatFunc K) * (v.uniformizer)⁻¹ = 1 :=
+    mul_inv_cancel₀ hπ0
+  linear_combination ((w ^ k)⁻¹ * (v.uniformizer ^ (k + 1))⁻¹) * hcw
+    + (v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) w)
+        * (w ^ (k + 1))⁻¹ * (v.uniformizer ^ k)⁻¹) * hcπ
+
+end CharFreeToolkit
+section CharPCartier
+
+variable {p : ℕ} [hp : Fact p.Prime]
+variable {K : Type*} [Field K] [hKp : CharP K p]
+
+theorem p0n22_cpf_res_logDeriv_elementary_cartier
+    (v : Place K (RatFunc K)) [v.DCoordGenerates]
+    [Nontrivial Ω[(RatFunc K)⁄K]]
+    (R : v.CanonicalLocalResidueDataK) (a : K) {k n : ℕ} (hk : 1 ≤ k) (hn : 1 ≤ n) :
+    R.res (v.differentialCoeff (KaehlerDifferential.D K (RatFunc K)
+          ((1 : RatFunc K)
+            + algebraMap K (RatFunc K) a * v.uniformizer ^ k))
+        * ((1 : RatFunc K)
+            + algebraMap K (RatFunc K) a * v.uniformizer ^ k)⁻¹
+        * (v.uniformizer ^ (p * n))⁻¹)
+      = (R.res (v.differentialCoeff (KaehlerDifferential.D K (RatFunc K)
+          ((1 : RatFunc K)
+            + algebraMap K (RatFunc K) a * v.uniformizer ^ k))
+        * ((1 : RatFunc K)
+            + algebraMap K (RatFunc K) a * v.uniformizer ^ k)⁻¹
+        * (v.uniformizer ^ n)⁻¹)) ^ p := by
+  have : CharP v.ResidueField p :=
+    charP_of_injective_ringHom (algebraMap K v.ResidueField).injective p
+  rw [p0n22_cpf_res_logDeriv_elementary v R a hk (Nat.mul_pos hp.out.pos hn),
+    p0n22_cpf_res_logDeriv_elementary v R a hk hn]
+  by_cases hdn : k ∣ n
+  · rw [ite_eq_left (hdn.mul_left p), ite_eq_left hdn]
+    obtain ⟨e, rfl⟩ := hdn
+    rcases Nat.eq_zero_or_pos e with rfl | he1
+    · simp at hn
+    · rw [show p * (k * e) / k = p * e from by
+          rw [show p * (k * e) = k * (p * e) from by ring, Nat.mul_div_cancel_left _ hk],
+        Nat.mul_div_cancel_left e hk]
+      have key : ∀ m : ℕ, 1 ≤ m → a * (-a) ^ (m - 1) = -((-a) ^ m) := by
+        intro m hm
+        obtain ⟨m', rfl⟩ := Nat.exists_eq_add_of_le hm
+        rw [show 1 + m' - 1 = m' from by omega, show 1 + m' = m' + 1 from by omega,
+          pow_succ]
+        ring
+      have hneg : (-((-a) ^ e) : K) ^ p = -(((-a) ^ e) ^ p) := by
+        rw [neg_eq_neg_one_mul, mul_pow, neg_one_pow_char K p, neg_one_mul]
+      have hxp : (a * (-a) ^ (e - 1)) ^ p = a * (-a) ^ (p * e - 1) := by
+        rw [key e he1, key (p * e) (Nat.mul_pos hp.out.pos he1), hneg, ← pow_mul,
+          mul_comm e p]
+      have hfix : ((k : ℕ) : v.ResidueField) ^ p = ((k : ℕ) : v.ResidueField) := by
+        have h := map_natCast (frobenius v.ResidueField p) k
+        rwa [frobenius_def] at h
+      rw [Algebra.smul_def, Algebra.smul_def, map_natCast (algebraMap K v.ResidueField) k,
+        mul_pow, hfix, ← map_pow, hxp]
+  · by_cases hdp : k ∣ p * n
+    · have hpk : p ∣ k := by
+        by_contra hpk
+        exact hdn ((((hp.out.coprime_iff_not_dvd).mpr hpk).symm).dvd_mul_left.mp hdp)
+      have hk0 : ((k : ℕ) : K) = 0 := (CharP.cast_eq_zero_iff K p k).mpr hpk
+      rw [hk0, zero_smul, zero_smul, zero_pow hp.out.ne_zero]
+    · rw [ite_eq_right hdp, ite_eq_right hdn, smul_zero, zero_pow hp.out.ne_zero]
+
+theorem p0n22_cpf_res_logDeriv_principalUnit_cartier_aux [PerfectField K]
+    (v : Place K (RatFunc K)) [v.DCoordGenerates]
+    [Nontrivial Ω[(RatFunc K)⁄K]]
+    (hsurj : Function.Surjective (algebraMap K v.ResidueField))
+    (R : v.CanonicalLocalResidueDataK) {n : ℕ} (hn : 1 ≤ n) :
+    ∀ d k : ℕ, 1 ≤ k → p * n + 1 ≤ k + d →
+      ∀ σ : RatFunc K, σ ∈ v.toValuationSubring →
+        R.res (v.differentialCoeff (KaehlerDifferential.D K (RatFunc K)
+              ((1 : RatFunc K) + v.uniformizer ^ k * σ))
+            * ((1 : RatFunc K) + v.uniformizer ^ k * σ)⁻¹
+            * (v.uniformizer ^ (p * n))⁻¹)
+          = (R.res (v.differentialCoeff (KaehlerDifferential.D K (RatFunc K)
+              ((1 : RatFunc K) + v.uniformizer ^ k * σ))
+            * ((1 : RatFunc K) + v.uniformizer ^ k * σ)⁻¹
+            * (v.uniformizer ^ n)⁻¹)) ^ p := by
+  have : CharP v.ResidueField p :=
+    charP_of_injective_ringHom (algebraMap K v.ResidueField).injective p
+  intro d
+  induction d with
+  | zero =>
+    intro k hk hbound σ hσ
+    have hnp : n ≤ p * n := Nat.le_mul_of_pos_left n hp.out.pos
+    rw [p0n22_cpf_res_logDeriv_highLevel_vanish v R hσ (show p * n + 1 ≤ k by omega),
+      p0n22_cpf_res_logDeriv_highLevel_vanish v R hσ (show n + 1 ≤ k by omega),
+      zero_pow hp.out.ne_zero]
+  | succ d ihd =>
+    intro k hk hbound σ hσ
+    obtain ⟨a, τ, hτ, hfac⟩ := p0n22_cpf_exists_elementary_peel v hsurj hk hσ
+    have hgcase1 : algebraMap K (RatFunc K) a * v.uniformizer ^ k = 0
+        ∨ 1 ≤ v.ord (algebraMap K (RatFunc K) a * v.uniformizer ^ k) := by
+      rw [mul_comm]
+      exact p0n22_cpf_uniformizer_pow_mul_mem_cases v (v.algebraMap_mem' a) hk
+    have h1 : (1 : RatFunc K)
+        + algebraMap K (RatFunc K) a * v.uniformizer ^ k ≠ 0 :=
+      p0n22_cpf_one_add_ne_zero v hgcase1
+    have hgcase2 := p0n22_cpf_uniformizer_pow_mul_mem_cases v hτ
+      (show 1 ≤ k + 1 by omega)
+    have h2 : (1 : RatFunc K) + v.uniformizer ^ (k + 1) * τ ≠ 0 :=
+      p0n22_cpf_one_add_ne_zero v hgcase2
+    rw [hfac, p0n22_cpf_logDeriv_mul v h1 h2, add_mul, add_mul, LinearMap.map_add,
+      LinearMap.map_add, p0n22_cpf_res_logDeriv_elementary_cartier v R a hk hn,
+      ihd (k + 1) (by omega) (by omega) τ hτ, ← add_pow_char]
+
+theorem p0n22_cpf_res_zpow_mul_logDeriv_cartier
+    [PerfectField K]
+    (v : Place K (RatFunc K)) [v.DCoordGenerates]
+    [Nontrivial Ω[(RatFunc K)⁄K]]
+    (hsurj : Function.Surjective (algebraMap K v.ResidueField))
+    (R : v.CanonicalLocalResidueDataK)
+    {w : RatFunc K} (hw0 : w ≠ 0) (hword : v.ord w = 0) (j : ℤ) :
+    R.res (v.uniformizer ^ ((p : ℤ) * j)
+        * (v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) w)
+            * w⁻¹))
+      = (R.res (v.uniformizer ^ j
+        * (v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) w)
+            * w⁻¹))) ^ p := by
+  have hπ0 : (v.uniformizer : RatFunc K) ≠ 0 := v.uniformizer_ne_zero
+  have hL := p0n22_cpf_logDeriv_mem v hw0 hword
+  rcases le_or_gt 0 j with hj | hj
+  · have hmem : ∀ i : ℤ, 0 ≤ i → v.uniformizer ^ i
+        * (v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) w)
+            * w⁻¹) ∈ v.toValuationSubring := by
+      intro i hi
+      refine mul_mem ?_ hL
+      refine v.mem_of_ord_nonneg (zpow_ne_zero i hπ0) ?_
+      rw [v.ord_zpow, v.ord_uniformizer, mul_one]
+      exact hi
+    rw [R.res_of_mem _ (hmem _ (mul_nonneg (Int.natCast_nonneg p) hj)),
+      R.res_of_mem _ (hmem _ hj), zero_pow hp.out.ne_zero]
+  · obtain ⟨c, s, hc0, hs, hwfac⟩ :=
+      MilneAvAg9bRd15UnitNormalFormLaurentSeed.ag9b15u_exists_unit_normal_form_of_surj
+        v hsurj hw0 hword
+    have hcF : algebraMap K (RatFunc K) c ≠ 0 := fun h =>
+      hc0 ((algebraMap K (RatFunc K)).injective
+        (h.trans (_root_.map_zero _).symm))
+    have h1s : (1 : RatFunc K) + s ≠ 0 := by
+      intro h0
+      exact hw0 (by rw [hwfac, h0, mul_zero])
+    have hLw : v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) w)
+        * w⁻¹
+        = v.differentialCoeff (KaehlerDifferential.D K (RatFunc K)
+            ((1 : RatFunc K) + s)) * ((1 : RatFunc K) + s)⁻¹ := by
+      rw [hwfac, p0n22_cpf_logDeriv_mul v hcF h1s, Derivation.map_algebraMap,
+        v.differentialCoeff_zero, zero_mul, zero_add]
+    rcases hs with rfl | hsord
+    · rw [hLw, add_zero, Derivation.map_one_eq_zero, v.differentialCoeff_zero, zero_mul,
+        mul_zero, mul_zero, _root_.map_zero, zero_pow hp.out.ne_zero]
+    · have hs0 : s ≠ 0 := by
+        intro h
+        rw [h, v.ord_zero] at hsord
+        omega
+      have hσmem : v.uniformizer⁻¹ * s ∈ v.toValuationSubring := by
+        refine v.mem_of_ord_nonneg (mul_ne_zero (inv_ne_zero hπ0) hs0) ?_
+        rw [v.ord_mul (inv_ne_zero hπ0) hs0, v.ord_inv, v.ord_uniformizer]
+        omega
+      obtain ⟨n', rfl⟩ : ∃ n' : ℕ, j = -(n' : ℤ) := ⟨(-j).toNat, by omega⟩
+      have hn1 : 1 ≤ n' := by omega
+      rw [hLw, show (p : ℤ) * -(n' : ℤ) = -((p * n' : ℕ) : ℤ) from by push_cast; ring,
+        _root_.zpow_neg, zpow_natCast, _root_.zpow_neg, zpow_natCast,
+        show s = v.uniformizer ^ 1 * (v.uniformizer⁻¹ * s) from by
+          rw [pow_one, ← mul_assoc, mul_inv_cancel₀ hπ0, one_mul],
+        mul_comm ((v.uniformizer ^ (p * n') : RatFunc K)⁻¹) _,
+        mul_comm ((v.uniformizer ^ n' : RatFunc K)⁻¹) _]
+      exact p0n22_cpf_res_logDeriv_principalUnit_cartier_aux v hsurj R hn1 (p * n') 1
+        le_rfl (by omega) _ hσmem
+
+theorem p0n22_cpf_res_pow_mul_dlog_unit [PerfectField K]
+    (v : Place K (RatFunc K)) [v.DCoordGenerates]
+    [Nontrivial Ω[(RatFunc K)⁄K]]
+    (hsurj : Function.Surjective (algebraMap K v.ResidueField))
+    (R : v.CanonicalLocalResidueDataK)
+    {w : RatFunc K} (hw0 : w ≠ 0) (hword : v.ord w = 0) (f : RatFunc K) :
+    R.res (f ^ p * ((v.uniformizer)⁻¹
+        + v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) w)
+            * w⁻¹))
+      = (R.res (f * ((v.uniformizer)⁻¹
+        + v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) w)
+            * w⁻¹))) ^ p := by
+  have : CharP (RatFunc K) p :=
+    charP_of_injective_algebraMap (algebraMap K (RatFunc K)).injective p
+  have : CharP v.ResidueField p :=
+    charP_of_injective_ringHom (algebraMap K v.ResidueField).injective p
+  have hπ0 : (v.uniformizer : RatFunc K) ≠ 0 := v.uniformizer_ne_zero
+  have hL := p0n22_cpf_logDeriv_mem v hw0 hword
+  obtain ⟨s, c, r, hr, hf⟩ := p0n22_cpf_exists_laurent_expansion_one v hsurj f
+  have hππ : (v.uniformizer : RatFunc K) * (v.uniformizer)⁻¹ = 1 :=
+    mul_inv_cancel₀ hπ0
+  have hLHS : f ^ p * ((v.uniformizer)⁻¹
+      + v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) w) * w⁻¹)
+      = (∑ j ∈ s, c j • v.uniformizer ^ j) ^ p * (v.uniformizer)⁻¹
+        + ((∑ j ∈ s, c j • v.uniformizer ^ j) ^ p
+            * (v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) w)
+                * w⁻¹)
+          + (v.uniformizer ^ p * r ^ p * (v.uniformizer)⁻¹
+            + v.uniformizer ^ p * r ^ p
+                * (v.differentialCoeff
+                    (KaehlerDifferential.D K (RatFunc K) w) * w⁻¹))) := by
+    rw [hf, add_pow_char, mul_pow]
+    ring
+  have hRHS : f * ((v.uniformizer)⁻¹
+      + v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) w) * w⁻¹)
+      = (∑ j ∈ s, c j • v.uniformizer ^ j) * (v.uniformizer)⁻¹
+        + ((∑ j ∈ s, c j • v.uniformizer ^ j)
+            * (v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) w)
+                * w⁻¹)
+          + (r + v.uniformizer * r
+              * (v.differentialCoeff
+                  (KaehlerDifferential.D K (RatFunc K) w) * w⁻¹))) := by
+    rw [hf]
+    linear_combination r * hππ
+  have hπp : (v.uniformizer : RatFunc K) ^ p
+      = v.uniformizer ^ (p - 1) * v.uniformizer := by
+    conv_lhs => rw [show p = (p - 1) + 1 from by have h2 := hp.out.two_le; omega]
+    rw [pow_succ]
+  have hm1 : v.uniformizer ^ p * r ^ p * (v.uniformizer)⁻¹ ∈ v.toValuationSubring := by
+    have heq : v.uniformizer ^ p * r ^ p * (v.uniformizer)⁻¹
+        = v.uniformizer ^ (p - 1) * r ^ p := by
+      rw [hπp]
+      linear_combination v.uniformizer ^ (p - 1) * r ^ p * hππ
+    rw [heq]
+    exact mul_mem (pow_mem v.uniformizer_mem _) (pow_mem hr _)
+  have hm2 : v.uniformizer ^ p * r ^ p
+      * (v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) w) * w⁻¹)
+      ∈ v.toValuationSubring :=
+    mul_mem (mul_mem (pow_mem v.uniformizer_mem _) (pow_mem hr _)) hL
+  have hm3 : v.uniformizer * r
+      * (v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) w) * w⁻¹)
+      ∈ v.toValuationSubring :=
+    mul_mem (mul_mem v.uniformizer_mem hr) hL
+  have hpowp : ∀ j : ℤ, ((v.uniformizer : RatFunc K) ^ j) ^ p
+      = v.uniformizer ^ ((p : ℤ) * j) := by
+    intro j
+    rw [← zpow_natCast ((v.uniformizer : RatFunc K) ^ j) p, ← zpow_mul,
+      mul_comm j (p : ℤ)]
+  have hPp : (∑ j ∈ s, c j • (v.uniformizer : RatFunc K) ^ j) ^ p
+      = ∑ j ∈ s, (c j ^ p) • (v.uniformizer : RatFunc K) ^ ((p : ℤ) * j) := by
+    rw [sum_pow_char]
+    exact Finset.sum_congr rfl fun j _ => by rw [_root_.smul_pow, hpowp j]
+  rw [hLHS, hRHS]
+  simp only [map_add]
+  rw [R.res_of_mem _ hm1, R.res_of_mem _ hm2, R.res_of_mem _ hr, R.res_of_mem _ hm3]
+  simp only [add_zero]
+  rw [add_pow_char]
+  congr 1
+  · rw [hPp, Finset.sum_mul, Finset.sum_mul, map_sum, map_sum, sum_pow_char]
+    refine Finset.sum_congr rfl fun j _ => ?_
+    rw [smul_mul_assoc, smul_mul_assoc, map_smul, map_smul]
+    rcases eq_or_ne j 0 with rfl | hj
+    · rw [mul_zero, zpow_zero, one_mul,
+        gate_canonicalLocalResidueDataK_uniformizer_inv v R,
+        ← Algebra.algebraMap_eq_smul_one, ← Algebra.algebraMap_eq_smul_one, map_pow]
+    · have hp0 : (p : ℤ) ≠ 0 := Int.natCast_ne_zero.mpr hp.out.ne_zero
+      have h1 : R.res ((v.uniformizer : RatFunc K) ^ ((p : ℤ) * j)
+          * (v.uniformizer)⁻¹) = 0 := by
+        rw [← zpow_sub_one₀ hπ0]
+        refine ag9b14c_res_uniformizer_zpow_eq_zero_of_ne_neg_one v R ?_
+        intro hcontra
+        have hpj : (p : ℤ) * j = 0 := by linarith
+        rcases mul_eq_zero.mp hpj with h | h
+        · exact hp0 h
+        · exact hj h
+      have h2 : R.res ((v.uniformizer : RatFunc K) ^ j * (v.uniformizer)⁻¹) = 0 := by
+        rw [← zpow_sub_one₀ hπ0]
+        exact ag9b14c_res_uniformizer_zpow_eq_zero_of_ne_neg_one v R (by omega)
+      rw [h1, h2, smul_zero, smul_zero, zero_pow hp.out.ne_zero]
+  · rw [hPp, Finset.sum_mul, Finset.sum_mul, map_sum, map_sum, sum_pow_char]
+    refine Finset.sum_congr rfl fun j _ => ?_
+    rw [smul_mul_assoc, smul_mul_assoc, map_smul, map_smul,
+      p0n22_cpf_res_zpow_mul_logDeriv_cartier v hsurj R hw0 hword j,
+      Algebra.smul_def, Algebra.smul_def, mul_pow, map_pow]
+
+include hp hKp in
+theorem p0n22_cpf_res_row_at_unit_mul_uniformizer [PerfectField K]
+    (v : Place K (RatFunc K)) [v.DCoordGenerates]
+    [Nontrivial Ω[(RatFunc K)⁄K]]
+    (hsurj : Function.Surjective (algebraMap K v.ResidueField))
+    (R : v.CanonicalLocalResidueDataK)
+    {w : RatFunc K} (hw0 : w ≠ 0) (hword : v.ord w = 0) :
+    ∀ n : ℕ, 1 ≤ n →
+      R.res (v.differentialCoeff (KaehlerDifferential.D K (RatFunc K)
+          (w * v.uniformizer))
+        * ((w * v.uniformizer) ^ (n + 1))⁻¹) = 0 := by
+  intro n
+  induction n using Nat.strong_induction_on with
+  | _ n ih =>
+    intro hn
+    by_cases hpn : p ∣ n
+    · obtain ⟨m, rfl⟩ := hpn
+      have hm1 : 1 ≤ m := by
+        rcases Nat.eq_zero_or_pos m with rfl | h
+        · simp at hn
+        · exact h
+      have hmlt : m < p * m := by
+        have h2m : 2 * m ≤ p * m := Nat.mul_le_mul_right m hp.out.two_le
+        omega
+      have hstep : R.res (v.differentialCoeff (KaehlerDifferential.D K
+            (RatFunc K) (w * v.uniformizer))
+            * ((w * v.uniformizer) ^ (p * m + 1))⁻¹)
+          = (R.res (v.differentialCoeff (KaehlerDifferential.D K (RatFunc K)
+              (w * v.uniformizer))
+            * ((w * v.uniformizer) ^ (m + 1))⁻¹)) ^ p := by
+        rw [p0n22_cpf_row_integrand_eq_pow_mul_dlog v hw0 (p * m),
+          p0n22_cpf_row_integrand_eq_pow_mul_dlog v hw0 m]
+        have hfp : ((w ^ m * v.uniformizer ^ m : RatFunc K)⁻¹) ^ p
+            = (w ^ (p * m) * v.uniformizer ^ (p * m))⁻¹ := by
+          rw [inv_pow, mul_pow, ← pow_mul, ← pow_mul, mul_comm m p]
+        rw [← hfp]
+        exact p0n22_cpf_res_pow_mul_dlog_unit v hsurj R hw0 hword
+          ((w ^ m * v.uniformizer ^ m)⁻¹)
+      rw [hstep, ih m hmlt hm1, zero_pow hp.out.ne_zero]
+    · have hnK : ((n : ℕ) : K) ≠ 0 := fun h =>
+        hpn ((CharP.cast_eq_zero_iff K p n).mp h)
+      exact ag9b13t_res_differentialCoeff_D_mul_pow_inv_of_surj_of_natCast_ne_zero v hsurj
+        (fun _ ↦ ag9b13e_differentialCoeff_D_mem_of_mem_of_perfectField v)
+        R _ hn hnK
+
+include hp hKp in
+theorem p0n22_cpf_res_differentialCoeff_D_mul_pow_inv_of_surj [PerfectField K]
+    (v : Place K (RatFunc K)) [v.DCoordGenerates] [Nontrivial Ω[(RatFunc K)⁄K]]
+    (hsurj : Function.Surjective (algebraMap K v.ResidueField))
+    (π' : RatFunc K) (hπ' : v.ord π' = 1)
+    (R : v.CanonicalLocalResidueDataK) (n : ℕ) (hn : 1 ≤ n) :
+    R.res (v.differentialCoeff (KaehlerDifferential.D K (RatFunc K) π')
+      * ((π') ^ (n + 1))⁻¹) = 0 := by
+  have hπ'0 : π' ≠ 0 := by
+    intro h0
+    rw [h0, v.ord_zero] at hπ'
+    omega
+  have hw0 : π' * (v.uniformizer)⁻¹ ≠ 0 :=
+    mul_ne_zero hπ'0 (inv_ne_zero v.uniformizer_ne_zero)
+  have hword : v.ord (π' * (v.uniformizer)⁻¹) = 0 := by
+    have h1 := v.ord_mul hπ'0 (inv_ne_zero v.uniformizer_ne_zero)
+    rw [v.ord_inv, hπ', v.ord_uniformizer] at h1
+    omega
+  have hrec : π' * (v.uniformizer)⁻¹ * v.uniformizer = π' := by
+    rw [mul_assoc, inv_mul_cancel₀ v.uniformizer_ne_zero, mul_one]
+  have h := p0n22_cpf_res_row_at_unit_mul_uniformizer v hsurj R hw0 hword n hn
+  rw [← hrec]
+  exact h
+
+end CharPCartier
+section Headlines
+
+theorem p0n22_cpf_canonicalLocalResidueKDifferentialCoordIndep_ratFunc_of_isAlgClosed
+    (K : Type*) [Field K] [IsAlgClosed K] (p : ℕ) [Fact p.Prime] [CharP K p] :
+    CanonicalLocalResidueKDifferentialCoordIndep K (RatFunc K) :=
+  fun v π' hπ' R =>
+    p0n22_cpf_res_differentialCoeff_D_mul_pow_inv_of_surj (p := p) v
+      (p0n21_rtk_surjective_algebraMap_residueField_ratFunc_of_isAlgClosed K v)
+      π' hπ' R
+
+theorem p0n22_cpf_residueTheoremK_ratFunc_of_isAlgClosed_of_charP
+    (K : Type*) [Field K] [IsAlgClosed K] (p : ℕ) [Fact p.Prime] [CharP K p]
+    :
+    ResidueTheoremK K (RatFunc K) := by
+  classical
+  exact
+    p0n21_rtk_residueTheoremK_ratFunc_of_isAlgClosed_of_coordIndep K
+      (p0n22_cpf_canonicalLocalResidueKDifferentialCoordIndep_ratFunc_of_isAlgClosed K p)
+
+theorem p0n22_cpf_residueTheoremK_ratFunc_of_isAlgClosed_main
+    (K : Type*) [Field K] [IsAlgClosed K] :
+    ResidueTheoremK K (RatFunc K) := by
+  classical
+  rcases CharP.char_is_prime_or_zero K (ringChar K) with hprime | hzero
+  · have : Fact (ringChar K).Prime := ⟨hprime⟩
+    exact p0n22_cpf_residueTheoremK_ratFunc_of_isAlgClosed_of_charP K (ringChar K)
+  · have : CharP K 0 := hzero ▸ ringChar.charP K
+    have : CharZero K := CharP.charP_to_charZero K
+    exact residueTheoremK_ratFunc_of_isAlgClosed_main K
+
+end Headlines
+
+end AlgebraicCurve
+end
+
+theorem solution
+    (K : Type*) [Field K] [IsAlgClosed K]
+    [AlgebraicCurve.HasCanonicalLocalResidueKStar K (RatFunc K)]
+    [AlgebraicCurve.HasCanonicalDivisor (K := K) (F := RatFunc K)]
+    [∀ v : AlgebraicCurve.Place K (RatFunc K), v.DCoordGenerates] :
+    AlgebraicCurve.ResidueTheoremK K (RatFunc K) := by
+  classical
+  exact
+    AlgebraicCurve.p0n22_cpf_residueTheoremK_ratFunc_of_isAlgClosed_main K
+
+end
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.residueTheoremK_ratFunc_of_isAlgClosed
+    (K : Type*) [Field K] [IsAlgClosed K]
+    [AlgebraicCurve.HasCanonicalLocalResidueKStar K (RatFunc K)]
+    [AlgebraicCurve.HasCanonicalDivisor (K := K) (F := RatFunc K)]
+    [∀ v : AlgebraicCurve.Place K (RatFunc K), v.DCoordGenerates] :
+    AlgebraicCurve.ResidueTheoremK K (RatFunc K) := by
+  classical
+  exact
+    _root_.solution K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_residueTraceCompletionCommute.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_residueTraceCompletionCommute.lean
new file mode 100644
index 0000000000..241eedc7a3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_residueTraceCompletionCommute.lean
@@ -0,0 +1,686 @@
+/-
+Based on Prove2Me node AlgebraicCurve.residueTraceCompletionCommute
+(f37f0322-59b0-5873-9a86-0b6e6e89bd53) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8b5b3289-b7d7-5205-936c-0aa9189eac99
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_CanonicalLocalResidueInstanceV2
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_TateResidueCurrency
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_tateAgreement
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_tateChainRule
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_tateCommFinite
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_tateTraceCompat_of_isSeparable
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Residue–trace commutation through the completion, F/E separable
+
+Theorem statement: `AlgebraicCurve.residueTraceCompletionCommute`
+(`f37f0322-59b0-5873-9a86-0b6e6e89bd53`), by Claude, 2026-09-05.
+
+Proof: submission `8b5b3289-b7d7-5205-936c-0aa9189eac99`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K\subseteq E\subseteq F$ be fields with $E$ and $F$ both $K$-algebras and $F$ an $E$-algebra
+forming a scalar tower over $K$, with $F$ integral over $E$ and $F/E$ separable. Assume every place
+$u$ of $E$ over $K$ has residue field finite over $K$, that both $F$ and $E$ carry the curve package
+`IsCurveOver K ·` (principal divisors of degree zero for every nonzero element, residue fields
+finite over $K$ at all places, and $\Omega_{\cdot/K}$ free of rank one), that $K$ is perfect, that
+$\Omega_{F/K}\ne 0$, and that at every place $w$ of $F$ the differential $d\pi_w$ of a uniformiser
+spans $\Omega_{F/K}$. The conclusion is the proposition `KwF4R1V391aResidueTraceCompletionCommute K
+F E`, which internally quantifies over the instance hypotheses that $E$ and $F$ have principal
+divisors, that all places of $F$ have $K$-finite residue fields, that $F$ is finite-dimensional over
+$E$ and $\Omega_{E/K}\ne 0$, and asserts: for every place $v$ of $E$ with $d\pi_v$ spanning
+$\Omega_{E/K}$, every place $w$ of $F$ with $d\pi_w$ spanning $\Omega_{F/K}$ lying in the fibre of
+$v$, and every $g\in F$, the residue term at $w$ of the pullback of $d\pi_v$ along
+$\Omega_{E/K}\to\Omega_{F/K}$ against the constant family $g$ — that is, $\mathrm{Tr}_{\kappa(w)/K}$
+of the local residue at $w$ of $g$ times the `differentialCoeff` of that pulled-back differential —
+equals $\mathrm{Tr}_{\kappa(v)/K}$ of the value obtained by applying the local residue at $v$ to an
+element of $E$ differing from the completed trace $\mathrm{Tr}_{\hat F_w/\hat E_v}(g)\in\hat E_v$ by
+an element of the valuation ring of $\hat E_v$.
+
+This is the local trace–residue compatibility: residues commute with the trace from $F$ to $E$,
+computed through the completions at a place and the places above it. It is assembled from the
+finiteness, agreement, chain-rule and trace-compatibility statements for Tate's residue, and feeds
+the $K$-valued residue theorem for function fields obtained by transporting the residue theorem on
+$\mathbf{P}^1$ along a cotrace.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_residueTraceCompletionCommute.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_residueTraceCompletionCommute
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver diagonalHom_apply \
+  HasCanonicalLocalResidueKStar kaehlerResidueTerm \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff \
+  kwHgfV352_exists_sub_mem_adicCompletionIntegers kaehlerPullback kwHgfV352_localResidueCompletion \
+  kwHgfV352_completionTraceAt tateCommFinite tateTraceCompat_of_isSeparable tateAgreement \
+  tateChainRule"
+end AlgebraicCurve
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver diagonalHom_apply \
+  HasCanonicalLocalResidueKStar kaehlerResidueTerm \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff \
+  kwHgfV352_exists_sub_mem_adicCompletionIntegers kaehlerPullback kwHgfV352_localResidueCompletion \
+  kwHgfV352_completionTraceAt tateCommFinite tateTraceCompat_of_isSeparable tateAgreement \
+  tateChainRule"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext FiniteResidue ord ord_one ord_mul ord_inv \
+  ord_coe_irreducible ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ne_top' toValuationSubring \
+  dCoord DCoordGenerates differentialCoeff uniformizer localResidue \
+  localResidue_eq_zero_of_ord_nonneg ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap adicCompletion \
+  adicCompletionIntegers"
+end AlgebraicCurve.Place
+namespace IntermediateField
+p2m_export "IntermediateField" "toAlgebra val isIntegral_iff ext comap mem_top"
+end IntermediateField
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "HeightOneSpectrum"
+end IsDedekindDomain
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "HeightOneSpectrum"
+namespace HeightOneSpectrum
+p2m_export "IsDedekindDomain.HeightOneSpectrum" "comap adicCompletion adicCompletionIntegers"
+end IsDedekindDomain.HeightOneSpectrum
+namespace KaehlerDifferential
+p2m_export "KaehlerDifferential" "D"
+end KaehlerDifferential
+namespace LinearMap
+p2m_export "LinearMap" "codRestrict inr ext isIntegral"
+end LinearMap
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite \
+  KwF4R1V391a.KwF4R1V391aResidueTraceCompletionCommute"
+namespace KwF4R1V391a
+p2m_export "ModularCurve.KwF4R1V391a" "KwF4R1V391aResidueTraceCompletionCommute"
+end ModularCurve.KwF4R1V391a
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite \
+  KwF4R1V391a.KwF4R1V391aResidueTraceCompletionCommute"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "KwF4gRRTateCommFinite KwF4gRRTateAgreement \
+  KwF4gRRTateChainRule KwF4gRRTateTraceCompat"
+end ModularCurve.KwF4gRRTate
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite \
+  KwF4R1V391a.KwF4R1V391aResidueTraceCompletionCommute"
+end ModularCurve
+namespace MonoidWithZeroHom
+p2m_export "MonoidWithZeroHom" "ext inr"
+end MonoidWithZeroHom
+namespace NNReal
+p2m_export "NNReal" "coe_eq_zero"
+end NNReal
+namespace Polynomial
+p2m_export "Polynomial" "ext_iff toSubring ext ring"
+end Polynomial
+namespace Submodule
+p2m_export "Submodule" "mem_comap mem_top coe_eq_zero ext comap"
+end Submodule
+namespace Valuation
+p2m_export "Valuation" "ext map_sub IsRankOneDiscrete comap"
+end Valuation
+namespace Valued
+p2m_export "Valued" "v"
+end Valued
+section
+
+
+p2m_open "LinearMap P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.Submodule"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite \
+  KwF4R1V391a.KwF4R1V391aResidueTraceCompletionCommute"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "KwF4gRRTateCommFinite KwF4gRRTateAgreement \
+  KwF4gRRTateChainRule KwF4gRRTateTraceCompat"
+end ModularCurve.KwF4gRRTate
+
+end
+
+end
+
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.IsDedekindDomain \
+  WithZero P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.WithZero IsLocalRing \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.IsLocalRing"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver diagonalHom_apply \
+  HasCanonicalLocalResidueKStar kaehlerResidueTerm \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff \
+  kwHgfV352_exists_sub_mem_adicCompletionIntegers kaehlerPullback kwHgfV352_localResidueCompletion \
+  kwHgfV352_completionTraceAt tateCommFinite tateTraceCompat_of_isSeparable tateAgreement \
+  tateChainRule"
+p2m_open "AlgebraicCurve"
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext FiniteResidue ord ord_one ord_mul ord_inv \
+  ord_coe_irreducible ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ne_top' toValuationSubring \
+  dCoord DCoordGenerates differentialCoeff uniformizer localResidue \
+  localResidue_eq_zero_of_ord_nonneg ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap adicCompletion \
+  adicCompletionIntegers"
+end Place
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext FiniteResidue ord ord_one ord_mul ord_inv \
+  ord_coe_irreducible ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ne_top' toValuationSubring \
+  dCoord DCoordGenerates differentialCoeff uniformizer localResidue \
+  localResidue_eq_zero_of_ord_nonneg ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap adicCompletion \
+  adicCompletionIntegers"
+end Place
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext FiniteResidue ord ord_one ord_mul ord_inv \
+  ord_coe_irreducible ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ne_top' toValuationSubring \
+  dCoord DCoordGenerates differentialCoeff uniformizer localResidue \
+  localResidue_eq_zero_of_ord_nonneg ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap adicCompletion \
+  adicCompletionIntegers"
+end Place
+
+end AlgebraicCurve
+
+end
+
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.IsDedekindDomain \
+  WithZero P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.WithZero IsLocalRing \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.IsLocalRing"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver diagonalHom_apply \
+  HasCanonicalLocalResidueKStar kaehlerResidueTerm \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff \
+  kwHgfV352_exists_sub_mem_adicCompletionIntegers kaehlerPullback kwHgfV352_localResidueCompletion \
+  kwHgfV352_completionTraceAt tateCommFinite tateTraceCompat_of_isSeparable tateAgreement \
+  tateChainRule"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext FiniteResidue ord ord_one ord_mul ord_inv \
+  ord_coe_irreducible ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ne_top' toValuationSubring \
+  dCoord DCoordGenerates differentialCoeff uniformizer localResidue \
+  localResidue_eq_zero_of_ord_nonneg ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap adicCompletion \
+  adicCompletionIntegers"
+p2m_open "AlgebraicCurve.Place"
+
+section SinglePlace
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+
+p2m_export "AlgebraicCurve.Place" "ord_nonneg_of_mem"
+
+p2m_export "AlgebraicCurve.Place" "mem_of_ord_nonneg"
+
+p2m_export "AlgebraicCurve.Place" "mem_iff_ord_nonneg"
+
+end SinglePlace
+
+section Restrict
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F'] [Algebra F F']
+
+
+variable (w : Place K F')
+
+
+p2m_export "AlgebraicCurve.Place" "comap_algebraMap_ne_top"
+
+
+
+
+
+p2m_export "AlgebraicCurve.Place" "exists_ord_algebraMap_pos"
+end Restrict
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver diagonalHom_apply \
+  HasCanonicalLocalResidueKStar kaehlerResidueTerm \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff \
+  kwHgfV352_exists_sub_mem_adicCompletionIntegers kaehlerPullback kwHgfV352_localResidueCompletion \
+  kwHgfV352_completionTraceAt tateCommFinite tateTraceCompat_of_isSeparable tateAgreement \
+  tateChainRule"
+p2m_open "AlgebraicCurve"
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [Algebra.IsIntegral F F'] [HasPrincipalDivisors K F']
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext FiniteResidue ord ord_one ord_mul ord_inv \
+  ord_coe_irreducible ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ne_top' toValuationSubring \
+  dCoord DCoordGenerates differentialCoeff uniformizer localResidue \
+  localResidue_eq_zero_of_ord_nonneg ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap adicCompletion \
+  adicCompletionIntegers"
+end Place
+
+end AlgebraicCurve
+
+end
+
+
+section
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.IsDedekindDomain.HeightOneSpectrum \
+  IsLocalRing P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.IsLocalRing WithZero \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.WithZero MonoidWithZeroHom \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.MonoidWithZeroHom"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver diagonalHom_apply \
+  HasCanonicalLocalResidueKStar kaehlerResidueTerm \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff \
+  kwHgfV352_exists_sub_mem_adicCompletionIntegers kaehlerPullback kwHgfV352_localResidueCompletion \
+  kwHgfV352_completionTraceAt tateCommFinite tateTraceCompat_of_isSeparable tateAgreement \
+  tateChainRule"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext FiniteResidue ord ord_one ord_mul ord_inv \
+  ord_coe_irreducible ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ne_top' toValuationSubring \
+  dCoord DCoordGenerates differentialCoeff uniformizer localResidue \
+  localResidue_eq_zero_of_ord_nonneg ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap adicCompletion \
+  adicCompletionIntegers"
+end AlgebraicCurve.Place
+
+end
+end
+
+
+section
+
+
+noncomputable section
+
+p2m_open "Polynomial P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.Polynomial IsLocalRing \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.IsLocalRing IsDedekindDomain \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.IsDedekindDomain"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver diagonalHom_apply \
+  HasCanonicalLocalResidueKStar kaehlerResidueTerm \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff \
+  kwHgfV352_exists_sub_mem_adicCompletionIntegers kaehlerPullback kwHgfV352_localResidueCompletion \
+  kwHgfV352_completionTraceAt tateCommFinite tateTraceCompat_of_isSeparable tateAgreement \
+  tateChainRule"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext FiniteResidue ord ord_one ord_mul ord_inv \
+  ord_coe_irreducible ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ne_top' toValuationSubring \
+  dCoord DCoordGenerates differentialCoeff uniformizer localResidue \
+  localResidue_eq_zero_of_ord_nonneg ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap adicCompletion \
+  adicCompletionIntegers"
+end AlgebraicCurve.Place
+
+end
+end
+
+
+section
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.IsDedekindDomain.HeightOneSpectrum \
+  IsLocalRing P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.IsLocalRing WithZero \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.WithZero"
+
+p2m_open_scoped "Valued P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.Valued WithZero \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.WithZero"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver diagonalHom_apply \
+  HasCanonicalLocalResidueKStar kaehlerResidueTerm \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff \
+  kwHgfV352_exists_sub_mem_adicCompletionIntegers kaehlerPullback kwHgfV352_localResidueCompletion \
+  kwHgfV352_completionTraceAt tateCommFinite tateTraceCompat_of_isSeparable tateAgreement \
+  tateChainRule"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext FiniteResidue ord ord_one ord_mul ord_inv \
+  ord_coe_irreducible ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ne_top' toValuationSubring \
+  dCoord DCoordGenerates differentialCoeff uniformizer localResidue \
+  localResidue_eq_zero_of_ord_nonneg ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap adicCompletion \
+  adicCompletionIntegers"
+end AlgebraicCurve.Place
+
+end
+end
+
+
+
+noncomputable section
+
+p2m_open "KaehlerDifferential \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.KaehlerDifferential"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver diagonalHom_apply \
+  HasCanonicalLocalResidueKStar kaehlerResidueTerm \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff \
+  kwHgfV352_exists_sub_mem_adicCompletionIntegers kaehlerPullback kwHgfV352_localResidueCompletion \
+  kwHgfV352_completionTraceAt tateCommFinite tateTraceCompat_of_isSeparable tateAgreement \
+  tateChainRule"
+p2m_open "AlgebraicCurve"
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext FiniteResidue ord ord_one ord_mul ord_inv \
+  ord_coe_irreducible ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ne_top' toValuationSubring \
+  dCoord DCoordGenerates differentialCoeff uniformizer localResidue \
+  localResidue_eq_zero_of_ord_nonneg ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap adicCompletion \
+  adicCompletionIntegers"
+end Place
+
+end AlgebraicCurve
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite \
+  KwF4R1V391a.KwF4R1V391aResidueTraceCompletionCommute"
+end ModularCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver diagonalHom_apply \
+  HasCanonicalLocalResidueKStar kaehlerResidueTerm \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff \
+  kwHgfV352_exists_sub_mem_adicCompletionIntegers kaehlerPullback kwHgfV352_localResidueCompletion \
+  kwHgfV352_completionTraceAt tateCommFinite tateTraceCompat_of_isSeparable tateAgreement \
+  tateChainRule"
+end AlgebraicCurve
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite \
+  KwF4R1V391a.KwF4R1V391aResidueTraceCompletionCommute"
+end ModularCurve
+
+end
+
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.IsDedekindDomain \
+  WithZero P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.WithZero"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver diagonalHom_apply \
+  HasCanonicalLocalResidueKStar kaehlerResidueTerm \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff \
+  kwHgfV352_exists_sub_mem_adicCompletionIntegers kaehlerPullback kwHgfV352_localResidueCompletion \
+  kwHgfV352_completionTraceAt tateCommFinite tateTraceCompat_of_isSeparable tateAgreement \
+  tateChainRule"
+end AlgebraicCurve
+
+end
+
+
+
+section
+
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.IsDedekindDomain \
+  WithZero P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.WithZero Module \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.Module IsLocalRing \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.IsLocalRing Module.IsLocalRing"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver diagonalHom_apply \
+  HasCanonicalLocalResidueKStar kaehlerResidueTerm \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff \
+  kwHgfV352_exists_sub_mem_adicCompletionIntegers kaehlerPullback kwHgfV352_localResidueCompletion \
+  kwHgfV352_completionTraceAt tateCommFinite tateTraceCompat_of_isSeparable tateAgreement \
+  tateChainRule"
+end AlgebraicCurve
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite \
+  KwF4R1V391a.KwF4R1V391aResidueTraceCompletionCommute"
+end ModularCurve
+
+end
+
+end
+
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.ModularCurve.GF24a9RRDx AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.AlgebraicCurve.Place IsDedekindDomain \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.IsDedekindDomain"
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver diagonalHom_apply \
+  HasCanonicalLocalResidueKStar kaehlerResidueTerm \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff \
+  kwHgfV352_exists_sub_mem_adicCompletionIntegers kaehlerPullback kwHgfV352_localResidueCompletion \
+  kwHgfV352_completionTraceAt tateCommFinite tateTraceCompat_of_isSeparable tateAgreement \
+  tateChainRule"
+p2m_open "AlgebraicCurve"
+
+section LocalResidueCompletion
+
+variable {K E : Type*} [Field K] [Field E] [Algebra K E]
+
+variable [HasCanonicalLocalResidueKStar K E]
+
+theorem kwHgfV352_localResidueCompletion_spec (v : Place K E) (xh : v.adicCompletion)
+    {x : E} (hx : algebraMap E v.adicCompletion x - xh ∈ v.adicCompletionIntegers) :
+    kwHgfV352_localResidueCompletion v xh = v.localResidue x := by
+  unfold kwHgfV352_localResidueCompletion
+  set x₀ := (kwHgfV352_exists_sub_mem_adicCompletionIntegers v xh).choose
+  have hx₀ := (kwHgfV352_exists_sub_mem_adicCompletionIntegers v xh).choose_spec
+  have heq : algebraMap E v.adicCompletion (x₀ - x)
+      = (algebraMap E v.adicCompletion x₀ - xh) - (algebraMap E v.adicCompletion x - xh) := by
+    rw [map_sub]; ring
+  have hdiff : algebraMap E v.adicCompletion (x₀ - x) ∈ v.adicCompletionIntegers :=
+    heq ▸ sub_mem hx₀ hx
+  have hov : x₀ - x ∈ v.toValuationSubring :=
+    (kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff v _).mp hdiff
+  have hzero : v.localResidue (x₀ - x) = 0 :=
+    v.localResidue_eq_zero_of_ord_nonneg (Or.inr (v.ord_nonneg_of_mem hov))
+  rw [map_sub, sub_eq_zero] at hzero
+  exact hzero
+
+theorem kwHgfV352_localResidueCompletion_algebraMap (v : Place K E) (x : E) :
+    kwHgfV352_localResidueCompletion v (algebraMap E v.adicCompletion x)
+      = v.localResidue x :=
+  kwHgfV352_localResidueCompletion_spec v _
+    (by rw [sub_self]; exact zero_mem _)
+
+end LocalResidueCompletion
+
+end AlgebraicCurve
+
+end
+end
+
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.AlgebraicCurve.Place \
+  LinearMap P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite \
+  KwF4R1V391a.KwF4R1V391aResidueTraceCompletionCommute"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "KwF4gRRTateCommFinite KwF4gRRTateAgreement \
+  KwF4gRRTateChainRule KwF4gRRTateTraceCompat"
+end ModularCurve.KwF4gRRTate
+
+end
+
+end
+
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.ModularCurve.GF24a9RRDx"
+p2m_open "ModularCurve.KwF4R1V391a \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.ModularCurve.KwF4R1V391a \
+  ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_residueTraceCompletionCommute.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite \
+  KwF4R1V391a.KwF4R1V391aResidueTraceCompletionCommute"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "KwF4gRRTateCommFinite KwF4gRRTateAgreement \
+  KwF4gRRTateChainRule KwF4gRRTateTraceCompat"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section Wire
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+variable [HasCanonicalLocalResidueKStar K E] [HasCanonicalLocalResidueKStar K F]
+
+theorem kwF4gRRTate_RTCC_of_tate
+    [HasPrincipalDivisors K E] [HasPrincipalDivisors K F]
+    [Nontrivial Ω[F⁄K]] [∀ w : Place K F, w.DCoordGenerates]
+    [∀ u : Place K E, u.FiniteResidue]
+    (hfinF : KwF4gRRTateCommFinite K F) (hfinE : KwF4gRRTateCommFinite K E)
+    (hAF : KwF4gRRTateAgreement K F hfinF) (hAE : KwF4gRRTateAgreement K E hfinE)
+    (hC : KwF4gRRTateChainRule K F E hfinF)
+    (hT : KwF4gRRTateTraceCompat K F E hfinF hfinE) :
+    KwF4R1V391aResidueTraceCompletionCommute K F E := by
+  intro _ _ _ v _ w _ hw g
+  unfold kaehlerResidueTerm
+  rw [diagonalHom_apply]
+  rw [← kwHgfV352_localResidueCompletion_algebraMap w
+    (g * w.differentialCoeff (kaehlerPullback K F E v.dCoord))]
+  have := hfinF w (algebraMap F w.adicCompletion
+    (g * w.differentialCoeff (kaehlerPullback K F E v.dCoord)))
+    (algebraMap F w.adicCompletion w.uniformizer)
+  rw [← hAF w (algebraMap F w.adicCompletion
+    (g * w.differentialCoeff (kaehlerPullback K F E v.dCoord)))]
+  rw [map_mul]
+  have := hfinF w (algebraMap F w.adicCompletion g)
+    (algebraMap F w.adicCompletion (algebraMap E F v.uniformizer))
+  rw [← hC v w hw (algebraMap F w.adicCompletion g)]
+  have := hfinE v (kwHgfV352_completionTraceAt v w hw g)
+    (algebraMap E v.adicCompletion v.uniformizer)
+  rw [hT v w hw g]
+  rw [hAE v (kwHgfV352_completionTraceAt v w hw g)]
+
+end Wire
+
+end ModularCurve.KwF4gRRTate
+
+end
+
+end
+
+
+theorem solution
+    {K F E : Type*} [Field K] [Field F] [Algebra K F]
+    [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+    [Algebra.IsIntegral E F]
+    [∀ u : AlgebraicCurve.Place K E, u.FiniteResidue]
+    [AlgebraicCurve.IsCurveOver K F] [AlgebraicCurve.IsCurveOver K E] [PerfectField K]
+    [Nontrivial Ω[F⁄K]] [∀ w : AlgebraicCurve.Place K F, w.DCoordGenerates]
+    [Algebra.IsSeparable E F] :
+    ModularCurve.KwF4R1V391a.KwF4R1V391aResidueTraceCompletionCommute K F E :=
+  let hF : ModularCurve.KwF4gRRTate.KwF4gRRTateCommFinite K F := AlgebraicCurve.tateCommFinite
+  let hE : ModularCurve.KwF4gRRTate.KwF4gRRTateCommFinite K E := AlgebraicCurve.tateCommFinite
+  ModularCurve.KwF4gRRTate.kwF4gRRTate_RTCC_of_tate hF hE
+    (AlgebraicCurve.tateAgreement hF) (AlgebraicCurve.tateAgreement hE)
+    (AlgebraicCurve.tateChainRule hF) (AlgebraicCurve.tateTraceCompat_of_isSeparable hF hE)
+
+end S_AlgebraicCurve_residueTraceCompletionCommute
+end P2MW
+export P2MW.S_AlgebraicCurve_residueTraceCompletionCommute (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.residueTraceCompletionCommute
+    {K F E : Type*} [Field K] [Field F] [Algebra K F]
+    [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+    [Algebra.IsIntegral E F]
+    [∀ u : AlgebraicCurve.Place K E, u.FiniteResidue]
+    [AlgebraicCurve.IsCurveOver K F] [AlgebraicCurve.IsCurveOver K E] [PerfectField K]
+    [Nontrivial Ω[F⁄K]] [∀ w : AlgebraicCurve.Place K F, w.DCoordGenerates]
+    [Algebra.IsSeparable E F] :
+    ModularCurve.KwF4R1V391a.KwF4R1V391aResidueTraceCompletionCommute K F E :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_separableAlong_of_charZero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_separableAlong_of_charZero.lean
new file mode 100644
index 0000000000..a85daf7552
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_separableAlong_of_charZero.lean
@@ -0,0 +1,82 @@
+/-
+Based on Prove2Me node AlgebraicCurve.separableAlong_of_charZero
+(af5fdffe-01a6-5b74-93da-aaecd5a70e34) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 44cc6042-f4f3-51fa-9c42-cd3e2784896b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integral extensions in characteristic zero are separable along φ
+
+Theorem statement: `AlgebraicCurve.separableAlong_of_charZero`
+(`af5fdffe-01a6-5b74-93da-aaecd5a70e34`), by Claude, 2026-09-05.
+
+Proof: submission `44cc6042-f4f3-51fa-9c42-cd3e2784896b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $F$, $F_1$ be fields, with $F$ and $F_1$ both $K$-algebras, and suppose $F$ has
+characteristic zero. Let $\varphi \colon F \to F_1$ be a $K$-algebra homomorphism whose underlying
+ring homomorphism is integral, that is, every element of $F_1$ satisfies a monic polynomial with
+coefficients in the image $\varphi(F)$. The conclusion is `SeparableAlong K φ`, which by definition
+means the following: equip $F_1$ with the $F$-algebra structure induced by $\varphi$ (the structure
+`algebraAlong φ`, whose structure map is $\varphi$ itself), and then $F_1$ is a separable
+$F$-algebra in the sense of `Algebra.IsSeparable`, i.e. every element of $F_1$ is algebraic over $F$
+with separable minimal polynomial. No hypothesis is imposed on $F_1$ beyond being a field and a
+$K$-algebra; in particular the characteristic hypothesis is placed on the source field $F$, and
+`SeparableAlong` is the formulation that avoids fixing an ambient `Algebra F F₁` instance.
+
+This is the standard fact that an algebraic extension of a field of characteristic zero, such fields
+being perfect, is separable, recast for an extension presented by an explicit embedding $\varphi$
+rather than by an algebra instance. It supplies the separability input required by the fundamental
+identity and the norm formula for correspondences, and is invoked throughout the treatment of curves
+and differentials over fields of characteristic zero.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_separableAlong_of_charZero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_separableAlong_of_charZero
+
+open AlgebraicCurve
+
+theorem solution {K F F₁ : Type*} [Field K] [Field F] [Field F₁] [Algebra K F] [Algebra K F₁]
+    [CharZero F] (φ : F →ₐ[K] F₁) (hφ : φ.toRingHom.IsIntegral) :
+    SeparableAlong K φ := by
+  let := algebraAlong φ
+  have := isIntegral_along φ hφ
+  exact Algebra.IsSeparable.of_integral F F₁
+
+end S_AlgebraicCurve_separableAlong_of_charZero
+end P2MW
+export P2MW.S_AlgebraicCurve_separableAlong_of_charZero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.separableAlong_of_charZero {K F F₁ : Type*} [Field K] [Field F] [Field F₁]
+    [Algebra K F] [Algebra K F₁] [CharZero F] (φ : F →ₐ[K] F₁) (hφ : φ.toRingHom.IsIntegral) :
+    SeparableAlong K φ :=
+  solution φ hφ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_six_mul_degree_eq_mul_finrank_of_forall_eq_weightFloor_of_ord_eq_three_two.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_six_mul_degree_eq_mul_finrank_of_forall_eq_weightFloor_of_ord_eq_three_two.lean
new file mode 100644
index 0000000000..c1b7411f6b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_six_mul_degree_eq_mul_finrank_of_forall_eq_weightFloor_of_ord_eq_three_two.lean
@@ -0,0 +1,371 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.six_mul_degree_eq_mul_finrank_of_forall_eq_weightFloor_of_ord_eq_three_two
+(f86dd52b-1791-5409-af29-3f1659cf67cd) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission df99bc9f-8a31-52d7-bb8e-5bd74ab83aaa
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import Mathlib.RingTheory.Flat.TorsionFree
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Repartitions
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_degree_poleDivisor_eq_finrank_adjoin_of_isAlgClosed_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_transcendental_of_perfectField
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree of the weight-m floor divisor without elliptic places
+
+Theorem statement:
+`AlgebraicCurve.six_mul_degree_eq_mul_finrank_of_forall_eq_weightFloor_of_ord_eq_three_two`
+(`f86dd52b-1791-5409-af29-3f1659cf67cd`), by Claude, 2026-09-05.
+
+Proof: submission `df99bc9f-8a31-52d7-bb8e-5bd74ab83aaa`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $k$ be an algebraically closed field and $F$ a field extension of $k$. Let $y \in F$ be
+transcendental over $k$, and assume that $F$ is finite-dimensional and separable over the
+intermediate field $k(y) =$ `IntermediateField.adjoin k {y}`. Places of $F$ over $k$ are valuation
+subrings of $F$ containing the image of $k$, proper in $F$ and principal ideal rings, and for such a
+place $w$ and $f \in F$, $\operatorname{ord}_w f$ denotes minus the logarithm of the value of $f$
+under the associated adic valuation. Assume that every place $w$ with $\operatorname{ord}_w y > 0$
+in fact has $\operatorname{ord}_w y = 3$, and that every place $w$ with $\operatorname{ord}_w (y -
+1728) > 0$ has $\operatorname{ord}_w (y - 1728) = 2$. Let $m$ be a natural number and let $D$ be a
+divisor, i.e. a finitely supported integer-valued function on places, such that for every place $w$,
+$$D(w) = \bigl[\,0 < \operatorname{ord}_w y\,\bigr]\,\bigl\lfloor 2m\,\operatorname{ord}_w y / 3
+\bigr\rfloor + \bigl[\,0 < \operatorname{ord}_w (y-1728)\,\bigr]\,\bigl\lfloor
+m\,\operatorname{ord}_w (y-1728) / 2 \bigr\rfloor + \bigl[\,\operatorname{ord}_w y < 0\,\bigr]\,
+m\,\operatorname{ord}_w y,$$
+the brackets denoting that the summand is $0$ when the condition fails, and the quotients being
+integer division by $3$ and by $2$ (exact here, by the two hypotheses on $\operatorname{ord}$). Then
+$6 \deg D = m \cdot [F : k(y)]$, where $\deg D$ is the sum of the values $D(w)$ weighted by the
+degrees of the places $w$.
+
+This is the degree computation for the divisor of the $m$-th power of the differential $dj$ on a
+curve whose ramification over the $j$-line is that of $X_1(M) \to X(1)$ with $M \ge 4$, so that
+there are no elliptic places: the contributions $2mn/3$, $mn/2$ and $-mn$ at the places above $j =
+0$, $j = 1728$ and $j = \infty$ combine to $6 \deg D = mn$ with $n = [F : k(y)]$. Together with
+Riemann–Roch it yields the dimension formula for modular forms of even and of odd weight on
+$\Gamma_1(M)$, and it is used by
+[`ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_even`]
+  (thm.html#ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_even)
+and
+[`ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_odd`]
+  (thm.html#ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_odd).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_six_mul_degree_eq_mul_finrank_of_forall_eq_weightFloor_of_ord_eq_three_two.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace
+  P2MW.S_AlgebraicCurve_six_mul_degree_eq_mul_finrank_of_forall_eq_weightFloor_of_ord_eq_three_two
+
+open AlgebraicCurve
+
+namespace DegC2
+
+section Ord
+
+variable {K : Type*} {FF : Type*} [Field K] [Field FF] [Algebra K FF] (w : Place K FF)
+
+theorem mem_iff_le_one {f : FF} : f ∈ w.toValuationSubring ↔ w.adicValuation f ≤ 1 :=
+  Place.mem_iff_adicValuation_le_one w
+
+theorem ord_nonneg_iff {f : FF} (hf : f ≠ 0) : 0 ≤ w.ord f ↔ w.adicValuation f ≤ 1 := by
+  rw [Place.ord, neg_nonneg, WithZero.log_le_iff_le_exp (w.adicValuation_ne_zero hf),
+    WithZero.exp_zero]
+
+theorem ord_pos_iff {f : FF} (hf : f ≠ 0) : 0 < w.ord f ↔ w.adicValuation f < 1 := by
+  rw [Place.ord, neg_pos, ← WithZero.log_one,
+    WithZero.log_lt_log (w.adicValuation_ne_zero hf) one_ne_zero]
+
+theorem ord_neg_iff {f : FF} (hf : f ≠ 0) : w.ord f < 0 ↔ 1 < w.adicValuation f := by
+  rw [Place.ord, neg_lt_zero, ← WithZero.log_one,
+    WithZero.log_lt_log one_ne_zero (w.adicValuation_ne_zero hf)]
+
+theorem ord_nonneg_of_mem {f : FF} (h : f ∈ w.toValuationSubring) : 0 ≤ w.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · rw [Place.ord_zero]
+  · exact (ord_nonneg_iff w hf).2 ((mem_iff_le_one w).1 h)
+
+theorem mem_of_ord_nonneg {f : FF} (h : 0 ≤ w.ord f) : f ∈ w.toValuationSubring := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · exact zero_mem _
+  · exact (mem_iff_le_one w).2 ((ord_nonneg_iff w hf).1 h)
+
+theorem ord_pow (f : FF) (n : ℕ) : w.ord (f ^ n) = n * w.ord f := by
+  rw [← zpow_natCast, Place.ord_zpow]
+
+theorem adicValuation_algebraMap {c : K} (hc : c ≠ 0) :
+    w.adicValuation (algebraMap K FF c) = 1 := by
+  apply le_antisymm (w.adicValuation_algebraMap_le_one c)
+  have h1 : w.adicValuation (algebraMap K FF c) * w.adicValuation (algebraMap K FF c⁻¹) = 1 := by
+    rw [← map_mul, ← map_mul, mul_inv_cancel₀ hc, map_one, map_one]
+  have h2 := w.adicValuation_algebraMap_le_one c⁻¹
+  by_contra h
+  rw [not_le] at h
+  have : w.adicValuation (algebraMap K FF c) * w.adicValuation (algebraMap K FF c⁻¹) < 1 * 1 :=
+    mul_lt_mul_of_lt_of_le_of_nonneg_of_pos h h2 zero_le zero_lt_one
+  rw [h1, one_mul] at this
+  exact lt_irrefl _ this
+
+theorem ord_algebraMap {c : K} (hc : c ≠ 0) : w.ord (algebraMap K FF c) = 0 := by
+  rw [Place.ord, adicValuation_algebraMap w hc, WithZero.log_one, neg_zero]
+
+theorem ord_sub_algebraMap_eq_zero_of_ord_pos {t : FF} (ht : t ≠ 0) {c : K} (hc : c ≠ 0)
+    (h : 0 < w.ord t) :
+    w.ord (t - algebraMap K FF c) = 0 := by
+  have hv : w.adicValuation t < w.adicValuation (algebraMap K FF c) := by
+    rw [adicValuation_algebraMap w hc]; exact (ord_pos_iff w ht).1 h
+  rw [Place.ord, Valuation.map_sub_swap, Valuation.map_sub_eq_of_lt_left _ hv,
+    adicValuation_algebraMap w hc, WithZero.log_one, neg_zero]
+
+theorem ord_sub_algebraMap_eq_of_ord_neg {t : FF} (ht : t ≠ 0) (c : K) (h : w.ord t < 0) :
+    w.ord (t - algebraMap K FF c) = w.ord t := by
+  have hv : w.adicValuation (algebraMap K FF c) < w.adicValuation t :=
+    lt_of_le_of_lt (w.adicValuation_algebraMap_le_one c) ((ord_neg_iff w ht).1 h)
+  rw [Place.ord, Place.ord, Valuation.map_sub_eq_of_lt_left _ hv]
+
+theorem ord_eq_zero_of_ord_sub_algebraMap_pos {t : FF} {c : K} (hc : c ≠ 0)
+    (htc : t - algebraMap K FF c ≠ 0) (h : 0 < w.ord (t - algebraMap K FF c)) :
+    w.ord t = 0 := by
+  have hv : w.adicValuation (t - algebraMap K FF c) < w.adicValuation (algebraMap K FF c) := by
+    rw [adicValuation_algebraMap w hc]; exact (ord_pos_iff w htc).1 h
+  have : t = (t - algebraMap K FF c) + algebraMap K FF c := by ring
+  rw [Place.ord, this, Valuation.map_add_eq_of_lt_right _ hv, adicValuation_algebraMap w hc,
+    WithZero.log_one, neg_zero]
+
+end Ord
+
+theorem ord_eq_of_ord_sub_algebraMap_neg {K : Type*} {FF : Type*} [Field K] [Field FF]
+    [Algebra K FF] (w : Place K FF)
+    {t : FF} (c : K) (htc : t - algebraMap K FF c ≠ 0) (h : w.ord (t - algebraMap K FF c) < 0) :
+    w.ord t = w.ord (t - algebraMap K FF c) := by
+  have := ord_sub_algebraMap_eq_of_ord_neg w htc (-c) h
+  rwa [map_neg, sub_neg_eq_add, sub_add_cancel] at this
+
+end DegC2
+
+open DegC2 in
+theorem solution
+    (k : Type*) [Field k] [IsAlgClosed k] {F : Type*} [Field F] [Algebra k F]
+    (y : F) (hy : Transcendental k y)
+    (hfin : FiniteDimensional ↥(IntermediateField.adjoin k ({y} : Set F)) F)
+    (h0 : ∀ w : AlgebraicCurve.Place k F, 0 < w.ord y → w.ord y = 3)
+    (h1728 : ∀ w : AlgebraicCurve.Place k F, 0 < w.ord (y - 1728) → w.ord (y - 1728) = 2)
+    (m : ℕ) (D : AlgebraicCurve.Divisor k F)
+    (hD : ∀ w : AlgebraicCurve.Place k F,
+      D w = (if 0 < w.ord y then (2 * (m : ℤ) * w.ord y) / 3 else 0)
+          + (if 0 < w.ord (y - 1728) then ((m : ℤ) * w.ord (y - 1728)) / 2 else 0)
+          + (if w.ord y < 0 then (m : ℤ) * w.ord y else 0)) :
+    6 * D.degree = (m : ℤ)
+      * (Module.finrank ↥(IntermediateField.adjoin k ({y} : Set F)) F : ℤ) := by
+  classical
+  have := hfin
+  have : IsCurveOver k F := isCurveOver_of_transcendental_of_perfectField hy hfin
+  have : HasPrincipalDivisors k F := IsCurveOver.hasPrincipalDivisors
+  have hdeg1 : ∀ v : Place k F, v.deg = 1 := IsCurveOver.forall_deg_eq_one_of_isAlgClosed
+  set n : ℤ := (Module.finrank ↥(IntermediateField.adjoin k ({y} : Set F)) F : ℤ) with hn
+  have hc : (1728 : F) = algebraMap k F 1728 := (map_ofNat (algebraMap k F) 1728).symm
+  have hD' : ∀ w : Place k F, D w = (if 0 < w.ord y then (2 * (m : ℤ) * w.ord y) / 3 else 0)
+          + (if 0 < w.ord (y - algebraMap k F 1728)
+              then ((m : ℤ) * w.ord (y - algebraMap k F 1728)) / 2 else 0)
+          + (if w.ord y < 0 then (m : ℤ) * w.ord y else 0) := fun w => by rw [← hc]; exact hD w
+  have h1728' : ∀ w : Place k F,
+      0 < w.ord (y - algebraMap k F 1728) → w.ord (y - algebraMap k F 1728) = 2 :=
+    fun w => by rw [← hc]; exact h1728 w
+  have hy0 : y ≠ 0 := fun h => hy (h ▸ isAlgebraic_zero)
+  have hyc : y - algebraMap k F 1728 ≠ 0 := fun h => hy (by
+    rw [sub_eq_zero] at h; rw [h]; exact isAlgebraic_algebraMap (1728 : k))
+  obtain ⟨Dj, hDj, hDj0⟩ := HasPrincipalDivisors.exists_divisor (K := k) (F := F) y hy0
+  obtain ⟨Dc, hDc, hDc0⟩ := HasPrincipalDivisors.exists_divisor
+      (K := k) (F := F) (y - algebraMap k F 1728) hyc
+  set S0 := Dj.support.filter (fun v => 0 < v.ord y) with hS0def
+  set S1 := Dc.support.filter (fun v => 0 < v.ord (y - algebraMap k F 1728)) with hS1def
+  set T := Dj.support.filter (fun v => v.ord y < 0) with hTdef
+  have hS0 : ∀ v, v ∈ S0 ↔ 0 < v.ord y := fun v => by
+    rw [hS0def, Finset.mem_filter, Finsupp.mem_support_iff, hDj v]
+    exact ⟨And.right, fun h => ⟨ne_of_gt h, h⟩⟩
+  have hS1 : ∀ v, v ∈ S1 ↔ 0 < v.ord (y - algebraMap k F 1728) := fun v => by
+    rw [hS1def, Finset.mem_filter, Finsupp.mem_support_iff, hDc v]
+    exact ⟨And.right, fun h => ⟨ne_of_gt h, h⟩⟩
+  have hT : ∀ v, v ∈ T ↔ v.ord y < 0 := fun v => by
+    rw [hTdef, Finset.mem_filter, Finsupp.mem_support_iff, hDj v]
+    exact ⟨And.right, fun h => ⟨ne_of_lt h, h⟩⟩
+  let P : Divisor k F := ∑ v ∈ T, Finsupp.single v (-(v.ord y))
+  have hP : ∀ v : Place k F, P v = max 0 (-v.ord y) := by
+    intro v
+    simp only [P, Finsupp.coe_finsetSum, Finset.sum_apply, Finsupp.single_apply]
+    rw [Finset.sum_ite_eq' T v]
+    by_cases hv : v ∈ T
+    · rw [ite_eq_left hv, max_eq_right]; have := (hT v).1 hv; omega
+    · rw [ite_eq_right hv, max_eq_left]; have := (hT v).not.1 hv; omega
+  have hPdeg := degree_poleDivisor_eq_finrank_adjoin_of_isAlgClosed_of_transcendental y hy P hP
+  have hPdeg' : Divisor.degree P = ∑ v ∈ T, -(v.ord y) := by
+    simp only [P, map_sum, Divisor.degree_single, hdeg1, Nat.cast_one, mul_one]
+  have hTsum : ∑ v ∈ T, v.ord y = -n := by
+    have : ∑ v ∈ T, -(v.ord y) = n := hPdeg'.symm.trans hPdeg
+    rw [Finset.sum_neg_distrib] at this
+    linarith
+  have hdegsum : ∀ E : Divisor k F, Divisor.degree E = ∑ v ∈ E.support, E v := by
+    intro E
+    conv_lhs => rw [← Finsupp.sum_single E]
+    rw [Finsupp.sum, map_sum]
+    simp only [Divisor.degree_single, hdeg1, Nat.cast_one, mul_one]
+  have hsupp_j : Dj.support = S0 ∪ T := by
+    ext v
+    rw [Finset.mem_union, hS0, hT, Finsupp.mem_support_iff, hDj v]
+    constructor
+    · intro h; rcases lt_trichotomy (v.ord y) 0 with h' | h' | h'
+      · exact Or.inr h'
+      · exact absurd h' h
+      · exact Or.inl h'
+    · rintro (h | h) <;> omega
+  have hdisj_0T : Disjoint S0 T := by
+    rw [Finset.disjoint_left]; intro v h0' hT'
+    have := (hS0 v).1 h0'; have := (hT v).1 hT'; omega
+  have hS0sum : ∑ v ∈ S0, v.ord y = n := by
+    have h := hdegsum Dj
+    rw [hDj0, hsupp_j, Finset.sum_union hdisj_0T] at h
+    simp only [hDj] at h
+    linarith
+  have hnpos : 0 < n := by
+    have : 0 < Module.finrank ↥(IntermediateField.adjoin k ({y} : Set F)) F := Module.finrank_pos
+    rw [hn]; exact_mod_cast this
+  by_cases hk : (1728 : k) = 0
+  · exfalso
+    have hS0ne : S0.Nonempty := by
+      by_contra h
+      rw [Finset.not_nonempty_iff_eq_empty] at h
+      rw [h, Finset.sum_empty] at hS0sum
+      linarith
+    obtain ⟨v, hv⟩ := hS0ne
+    have hv3 := h0 v ((hS0 v).1 hv)
+    have hyy : y - algebraMap k F 1728 = y := by rw [hk, map_zero, sub_zero]
+    have hv2 := h1728' v (by rw [hyy]; exact (hS0 v).1 hv)
+    rw [hyy] at hv2
+    omega
+  have hzero_c : ∀ v : Place k F, 0 < v.ord y → v.ord (y - algebraMap k F 1728) = 0 :=
+    fun v hv => ord_sub_algebraMap_eq_zero_of_ord_pos v hy0 hk hv
+  have hpole_c : ∀ v : Place k F, v.ord y < 0 → v.ord (y - algebraMap k F 1728) = v.ord y :=
+    fun v hv => ord_sub_algebraMap_eq_of_ord_neg v hy0 1728 hv
+  have hzero_j : ∀ v : Place k F, 0 < v.ord (y - algebraMap k F 1728) → v.ord y = 0 :=
+    fun v hv => ord_eq_zero_of_ord_sub_algebraMap_pos v hk hyc hv
+  have hpole_j : ∀ v : Place k F, v.ord (y - algebraMap k F 1728) < 0 →
+      v.ord y = v.ord (y - algebraMap k F 1728) :=
+    fun v hv => ord_eq_of_ord_sub_algebraMap_neg v 1728 hyc hv
+  have hsupp_c : Dc.support = S1 ∪ T := by
+    ext v
+    rw [Finset.mem_union, hS1, hT, Finsupp.mem_support_iff, hDc v]
+    constructor
+    · intro h; rcases lt_trichotomy (v.ord (y - algebraMap k F 1728)) 0 with h' | h' | h'
+      · right; rw [hpole_j v h']; exact h'
+      · exact absurd h' h
+      · exact Or.inl h'
+    · rintro (h | h)
+      · exact ne_of_gt h
+      · rw [hpole_c v h]; exact ne_of_lt h
+  have hdisj_1T : Disjoint S1 T := by
+    rw [Finset.disjoint_left]; intro v h1 hT'
+    have := (hS1 v).1 h1; have := hzero_j v this; have := (hT v).1 hT'; omega
+  have hS1sum : ∑ v ∈ S1, v.ord (y - algebraMap k F 1728) = n := by
+    have h := hdegsum Dc
+    rw [hDc0, hsupp_c, Finset.sum_union hdisj_1T] at h
+    simp only [hDc] at h
+    have : ∑ v ∈ T, v.ord (y - algebraMap k F 1728) = ∑ v ∈ T, v.ord y :=
+      Finset.sum_congr rfl fun v hv => hpole_c v ((hT v).1 hv)
+    linarith
+  have hcnt0 : 3 * (S0.card : ℤ) = n := by
+    rw [← hS0sum, show ∑ v ∈ S0, v.ord y = ∑ v ∈ S0, (3 : ℤ) from
+      Finset.sum_congr rfl fun v hv => h0 v ((hS0 v).1 hv)]
+    simp only [Finset.sum_const]; ring
+  have hcnt1 : 2 * (S1.card : ℤ) = n := by
+    rw [← hS1sum, show ∑ v ∈ S1, v.ord (y - algebraMap k F 1728) = ∑ v ∈ S1, (2 : ℤ) from
+      Finset.sum_congr rfl fun v hv => h1728' v ((hS1 v).1 hv)]
+    simp only [Finset.sum_const]; ring
+  have hDval : ∀ v : Place k F, D v = (if v ∈ S0 then 2 * (m : ℤ) else 0)
+      + (if v ∈ S1 then (m : ℤ) else 0) + (if v ∈ T then (m : ℤ) * v.ord y else 0) := by
+    intro v
+    rw [hD' v]
+    congr 1
+    · congr 1
+      · by_cases h : 0 < v.ord y
+        · rw [ite_eq_left h, ite_eq_left ((hS0 v).2 h), h0 v h]; omega
+        · rw [ite_eq_right h, ite_eq_right (fun h' => h ((hS0 v).1 h'))]
+      · by_cases h : 0 < v.ord (y - algebraMap k F 1728)
+        · rw [ite_eq_left h, ite_eq_left ((hS1 v).2 h), h1728' v h]; omega
+        · rw [ite_eq_right h, ite_eq_right (fun h' => h ((hS1 v).1 h'))]
+    · by_cases h : v.ord y < 0
+      · rw [ite_eq_left h, ite_eq_left ((hT v).2 h)]
+      · rw [ite_eq_right h, ite_eq_right (fun h' => h ((hT v).1 h'))]
+  have hDsupp : D.support ⊆ S0 ∪ S1 ∪ T := by
+    intro v hv
+    rw [Finsupp.mem_support_iff, hDval v] at hv
+    rw [Finset.mem_union, Finset.mem_union]
+    by_contra hnot
+    push Not at hnot
+    obtain ⟨⟨h1, h2⟩, h3⟩ := hnot
+    rw [ite_eq_right h1, ite_eq_right h2, ite_eq_right h3] at hv
+    exact hv (by ring)
+  have hDdeg : Divisor.degree D = ∑ v ∈ S0 ∪ S1 ∪ T, D v := by
+    rw [hdegsum D]
+    exact Finset.sum_subset hDsupp (fun v _ hv => by rwa [Finsupp.mem_support_iff, not_not] at hv)
+  have hsumD : ∑ v ∈ S0 ∪ S1 ∪ T, D v =
+      ∑ v ∈ S0 ∪ S1 ∪ T, ((if v ∈ S0 then 2 * (m : ℤ) else 0) + (if v ∈ S1 then (m : ℤ) else 0) +
+        (if v ∈ T then (m : ℤ) * v.ord y else 0)) := Finset.sum_congr rfl fun v _ => hDval v
+  have hA : ∑ v ∈ S0 ∪ S1 ∪ T, (if v ∈ S0 then 2 * (m : ℤ) else 0) = 2 * (m : ℤ) * S0.card := by
+    rw [Finset.sum_ite_mem, Finset.inter_eq_right.2 (by intro v hv; simp [hv]), Finset.sum_const]
+    simp only [nsmul_eq_mul]; ring
+  have hB : ∑ v ∈ S0 ∪ S1 ∪ T, (if v ∈ S1 then (m : ℤ) else 0) = (m : ℤ) * S1.card := by
+    rw [Finset.sum_ite_mem, Finset.inter_eq_right.2 (by intro v hv; simp [hv]), Finset.sum_const]
+    simp only [nsmul_eq_mul]; ring
+  have hC : ∑ v ∈ S0 ∪ S1 ∪ T, (if v ∈ T then (m : ℤ) * v.ord y else 0) =
+      (m : ℤ) * ∑ v ∈ T, v.ord y := by
+    rw [Finset.sum_ite_mem, Finset.inter_eq_right.2 (by intro v hv; simp [hv]), Finset.mul_sum]
+  rw [hDdeg, hsumD, Finset.sum_add_distrib, Finset.sum_add_distrib, hA, hB, hC, hTsum]
+  linear_combination (4 * (m : ℤ)) * hcnt0 + (3 * (m : ℤ)) * hcnt1
+
+end S_AlgebraicCurve_six_mul_degree_eq_mul_finrank_of_forall_eq_weightFloor_of_ord_eq_three_two
+end P2MW
+export
+  P2MW.S_AlgebraicCurve_six_mul_degree_eq_mul_finrank_of_forall_eq_weightFloor_of_ord_eq_three_two
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.six_mul_degree_eq_mul_finrank_of_forall_eq_weightFloor_of_ord_eq_three_two
+    (k : Type*) [Field k] [IsAlgClosed k] {F : Type*} [Field F] [Algebra k F]
+    (y : F) (hy : Transcendental k y)
+    (hfin : FiniteDimensional ↥(IntermediateField.adjoin k ({y} : Set F)) F)
+    (h0 : ∀ w : AlgebraicCurve.Place k F, 0 < w.ord y → w.ord y = 3)
+    (h1728 : ∀ w : AlgebraicCurve.Place k F, 0 < w.ord (y - 1728) → w.ord (y - 1728) = 2)
+    (m : ℕ) (D : AlgebraicCurve.Divisor k F)
+    (hD : ∀ w : AlgebraicCurve.Place k F,
+      D w = (if 0 < w.ord y then (2 * (m : ℤ) * w.ord y) / 3 else 0)
+          + (if 0 < w.ord (y - 1728) then ((m : ℤ) * w.ord (y - 1728)) / 2 else 0)
+          + (if w.ord y < 0 then (m : ℤ) * w.ord y else 0)) :
+    6 * D.degree = (m : ℤ) * (Module.finrank ↥(IntermediateField.adjoin k ({y} : Set F)) F : ℤ) :=
+  solution k y hy hfin h0 h1728 m D hD
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_stichtenothGenusExists_of_isCurveOver.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_stichtenothGenusExists_of_isCurveOver.lean
new file mode 100644
index 0000000000..abf04d2ac2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_stichtenothGenusExists_of_isCurveOver.lean
@@ -0,0 +1,121 @@
+/-
+Based on Prove2Me node AlgebraicCurve.stichtenothGenusExists_of_isCurveOver
+(78654643-12b2-5eb8-9923-a67195bfef37) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 342da112-481f-5789-897d-970a404f787d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_AdelicIndex
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_IsCurveOver_exists_separating_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_stichtenothGenusExists
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of the Stichtenoth genus for a curve over a perfect field
+
+Theorem statement: `AlgebraicCurve.stichtenothGenusExists_of_isCurveOver`
+(`78654643-12b2-5eb8-9923-a67195bfef37`), by Claude, 2026-09-05.
+
+Proof: submission `342da112-481f-5789-897d-970a404f787d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, $K$ perfect, $F$ essentially of finite type over
+$K$, and suppose $F$ is a curve over $K$ in the sense of `IsCurveOver`: every nonzero $f \in F$ has
+a divisor $D$ with $D(v) = \operatorname{ord}_v f$ at each place $v$ and $\deg D = 0$; for every
+place $v$ (a valuation subring of $F$ containing the image of $K$, distinct from $F$ itself and a
+principal ideal ring) the residue field of $v$ is a finite $K$-module; and $\Omega_{F/K}$ is a free
+$F$-module of rank one. Assume moreover `ConstantsAreBase K F`, i.e. the Riemann–Roch space $L(0)$
+of the zero divisor equals the image of $K$ in $F$. The conclusion `StichtenothGenusExists K F`
+asserts three things: there exists at least one place of $F$ over $K$; $L(0)$ is finite-dimensional
+over $K$; and there are an integer $\gamma$ and a divisor $D_0$ (a finitely supported
+$\mathbb{Z}$-valued function on places) such that $L(D_0)$ is finite-dimensional over $K$, $\deg D_0
+- \ell(D_0) = \gamma - 1$, and $\deg D - \ell(D) \le \gamma - 1$ for every divisor $D$, where $\ell$
+is the dimension invariant `ell` of the Riemann–Roch space.
+
+This is the existence of the genus in Stichtenoth's formulation, the maximum of $\deg D - \ell(D)$
+over all divisors, for an arbitrary one-variable function field over a perfect field whose field of
+constants is the base field; the hypotheses involve no auxiliary rational subfield. It is the form
+in which the genus is used throughout the divisor-theoretic development of curves in the project,
+for instance in the study of $\operatorname{Pic}^0$ and of constant reduction.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_stichtenothGenusExists_of_isCurveOver.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_stichtenothGenusExists_of_isCurveOver
+
+open IntermediateField
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_stichtenothGenusExists_of_isCurveOver.AlgebraicCurve"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "IsCurveOver ConstantsAreBase StichtenothGenusExists \
+  IsCurveOver.exists_separating_transcendental RationalFunctionField.stichtenothGenusExists"
+namespace TowerFreePort
+p2m_open "AlgebraicCurve"
+theorem solution {K : Type*} {F : Type*} [Field K] [Field F] [Algebra K F] [PerfectField K]
+    [Algebra.EssFiniteType K F] [IsCurveOver K F] (hC : ConstantsAreBase K F) :
+    StichtenothGenusExists K F := by
+  classical
+  obtain ⟨x, htr, hfd, hsep⟩ := IsCurveOver.exists_separating_transcendental (K := K) (F := F)
+  have := hfd; have := hsep
+  set e : RatFunc K ≃ₐ[K] K⟮x⟯ := RatFunc.algEquivOfTranscendental x htr with he
+  let : Algebra (RatFunc K) F := ((algebraMap K⟮x⟯ F).comp e.toAlgHom.toRingHom).toAlgebra
+  have hsq : RingHom.comp (algebraMap (RatFunc K) F) (e.symm.toRingEquiv : K⟮x⟯ →+* RatFunc K)
+      = RingHom.comp (RingEquiv.refl F : F →+* F) (algebraMap K⟮x⟯ F) := by
+    refine RingHom.ext fun a => ?_
+    change algebraMap K⟮x⟯ F (e (e.symm a)) = algebraMap K⟮x⟯ F a
+    rw [e.apply_symm_apply]
+  have : IsScalarTower K (RatFunc K) F :=
+    IsScalarTower.of_algebraMap_eq fun a => by
+      change algebraMap K F a = algebraMap K⟮x⟯ F (e (algebraMap K (RatFunc K) a))
+      rw [e.commutes, ← IsScalarTower.algebraMap_apply]
+  have : FiniteDimensional (RatFunc K) F :=
+    Module.Finite.of_equiv_equiv e.symm.toRingEquiv (RingEquiv.refl F) hsq
+  have : Algebra.IsSeparable (RatFunc K) F :=
+    Algebra.IsSeparable.of_equiv_equiv e.symm.toRingEquiv (RingEquiv.refl F) hsq
+  exact RationalFunctionField.stichtenothGenusExists K F hC
+
+end AlgebraicCurve.TowerFreePort
+
+open IntermediateField _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_stichtenothGenusExists_of_isCurveOver.AlgebraicCurve in
+theorem solution {K : Type*} {F : Type*} [Field K] [Field F] [Algebra K F] [PerfectField K]
+    [Algebra.EssFiniteType K F] [IsCurveOver K F] (hC : ConstantsAreBase K F) :
+    StichtenothGenusExists K F :=
+  AlgebraicCurve.TowerFreePort.solution hC
+
+end S_AlgebraicCurve_stichtenothGenusExists_of_isCurveOver
+end P2MW
+export P2MW.S_AlgebraicCurve_stichtenothGenusExists_of_isCurveOver (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace AlgebraicCurve
+theorem stichtenothGenusExists_of_isCurveOver {K : Type*} {F : Type*} [Field K] [Field F]
+    [Algebra K F] [PerfectField K] [Algebra.EssFiniteType K F] [IsCurveOver K F]
+    (hC : ConstantsAreBase K F) :
+    StichtenothGenusExists K F :=
+  solution hC
+end AlgebraicCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_sum_ordDiff_D_le_two_mul_genusFF_of_isSeparable.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_sum_ordDiff_D_le_two_mul_genusFF_of_isSeparable.lean
new file mode 100644
index 0000000000..77875b6c13
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_sum_ordDiff_D_le_two_mul_genusFF_of_isSeparable.lean
@@ -0,0 +1,491 @@
+/-
+Based on Prove2Me node AlgebraicCurve.sum_ordDiff_D_le_two_mul_genusFF_of_isSeparable
+(5d02ada5-b26c-53f6-be3d-8cb835c86687) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 76ea0a99-b13a-57ba-8e6f-a7d87dbc5a9e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Repartitions
+
+import Mathlib.RingTheory.Finiteness.ModuleFinitePresentation
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_D_ne_zero_of_ord_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg_of_perfectField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_sub_one_le_ordDiff_D_of_perfectField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_placeInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_X_nonneg_of_ne_placeInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty_X
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_TranscendenceTower_degree_poleDivisor_eq_finrank
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_TranscendenceTower_poleDivisor_apply
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_constantsAreBase_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_dCoordGenerates_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_degree_canonicalDivisor_eq_of_riemannRoch
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_essFiniteType_of_transcendental_of_finiteDimensional
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_genus_eq_genusFF
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_hasCanonicalDivisor_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_transcendental_of_isSeparable
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_ratFunc
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_linearIndependent_pow_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_stichtenothGenusExists_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_weilDualityAdelic_of_functionFieldRiemannRoch_of_stichtenothGenusExists
+import LeanPool.FLTEichlerShimura.Theorems.Thm_KaehlerDifferential_D_ne_zero_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Hurwitz genus inequality for F/k(x) in differential form
+
+Theorem statement: `AlgebraicCurve.sum_ordDiff_D_le_two_mul_genusFF_of_isSeparable`
+(`5d02ada5-b26c-53f6-be3d-8cb835c86687`), by Claude, 2026-09-05.
+
+Proof: submission `76ea0a99-b13a-57ba-8e6f-a7d87dbc5a9e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $k$ be an algebraically closed field, $F$ a field with a $k$-algebra structure, and $x \in F$
+transcendental over $k$; assume $F$ is finite-dimensional over the intermediate field $k(x) =$
+`IntermediateField.adjoin k {x}` and separable over it. Places of $F/k$ are the valuation subrings
+of $F$ containing $k$, distinct from $F$ itself and principal ideal rings; for such a place $P$,
+$\operatorname{ord}_P$ is the associated normalised additive valuation (minus the logarithm of the
+adic valuation attached to $P$), and $\operatorname{ordDiff}_P(\omega)$ is $\operatorname{ord}_P$ of
+the coefficient $g \in F$ for which $\omega = g \cdot D\,t$, where $t$ is a chosen element of $F$
+with $\operatorname{ord}_P t = 1$ and $D$ is the universal derivation into $\Omega_{F/k}$. Let $T$
+be a finite set of places at which $x$ is regular, i.e. $\operatorname{ord}_P x \ge 0$ for all $P
+\in T$, and $T_\infty$ a finite set of places at which $x$ has a pole, i.e. $\operatorname{ord}_P x
+< 0$ for all $P \in T_\infty$. Then $$\sum_{P \in T} \operatorname{ordDiff}_P(D x) + \sum_{P \in
+T_\infty} (-\operatorname{ord}_P x - 1) \le 2\,g - 2 + 2\,[F : k(x)],$$ where $g = \dim_k H^1(0)$ is
+`genusFF k F`. No disjointness of $T$ and $T_\infty$, and no exhaustiveness, is required.
+
+This is the Riemann–Hurwitz genus formula for the separable extension $F/k(x)$, in the one-sided
+form of an inequality obtained by summing local contributions of the canonical divisor class of $dx$
+over arbitrary finite sets of regular points and poles of $x$ and discarding the remaining
+nonnegative different exponents; as such it is valid in arbitrary characteristic, including wild
+ramification. It underlies the genus estimates for the function fields of modular curves used in the
+comparison of the genera of coverings, and is cited by
+[`AlgebraicCurve.sum_ord_sub_one_le_two_mul_genusFF_of_isSeparable`]
+(thm.html#AlgebraicCurve.sum_ord_sub_one_le_two_mul_genusFF_of_isSeparable)
+and by the genus comparison
+[`ModularCurve.genusFF_xHFunctionFieldBar_le_genusFF_xHFunctionFieldC_of_not_dvd`]
+(thm.html#ModularCurve.genusFF_xHFunctionFieldBar_le_genusFF_xHFunctionFieldC_of_not_dvd).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_sum_ordDiff_D_le_two_mul_genusFF_of_isSeparable.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+open AlgebraicCurve Divisor
+
+namespace P2MW.S_AlgebraicCurve_sum_ordDiff_D_le_two_mul_genusFF_of_isSeparable
+
+noncomputable section
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_sum_ordDiff_D_le_two_mul_genusFF_of_isSeparable.AlgebraicCurve \
+  IntermediateField KaehlerDifferential"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "genusFF Place Divisor Divisor.degree HasPrincipalDivisors \
+  Place.diffCoeff Place.ordDiff Place.ordDiff_def IsCurveOver \
+  IsCurveOver.forall_deg_eq_one_of_isAlgClosed HasCanonicalDivisor canonicalDivisorOf \
+  canonicalDivisorOf_apply genus Place.ordDifferential WeilDualityAdelic FunctionFieldRiemannRoch \
+  ConstantsAreBase StichtenothGenusExists Place.ramificationIndex TranscendenceTower \
+  RationalFunctionField.placeInfty isCurveOver_of_transcendental_of_isSeparable \
+  isCurveOver_ratFunc hasCanonicalDivisor_of_isCurveOver dCoordGenerates_of_isCurveOver \
+  essFiniteType_of_transcendental_of_finiteDimensional \
+  functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver constantsAreBase_of_isAlgClosed \
+  stichtenothGenusExists_of_isCurveOver \
+  weilDualityAdelic_of_functionFieldRiemannRoch_of_stichtenothGenusExists genus_eq_genusFF \
+  degree_canonicalDivisor_eq_of_riemannRoch Place.D_ne_zero_of_ord_eq_one \
+  Place.diffCoeff_smul_D_of_ord_eq_one Place.ord_diffCoeff_D_nonneg_of_perfectField \
+  Place.ord_sub_one_le_ordDiff_D_of_perfectField RationalFunctionField.ord_placeInfty_X \
+  RationalFunctionField.ord_X_nonneg_of_ne_placeInfty RationalFunctionField.deg_placeInfty \
+  linearIndependent_pow_of_transcendental"
+p2m_open "AlgebraicCurve"
+
+namespace HurwitzLineBoundProof
+
+universe u v
+
+section Package
+
+variable (k : Type u) [Field k] {F : Type v} [Field F] [Algebra k F]
+  (x : F) (hx : Transcendental k x) (hfin : FiniteDimensional k⟮x⟯ F)
+  (hsep : Algebra.IsSeparable k⟮x⟯ F)
+
+include hx hfin hsep
+
+theorem isCurveOver_pkg : IsCurveOver k F :=
+  AlgebraicCurve.isCurveOver_of_transcendental_of_isSeparable k F x hx hfin hsep
+
+omit hsep in
+theorem essFiniteType_pkg : Algebra.EssFiniteType k F :=
+  AlgebraicCurve.essFiniteType_of_transcendental_of_finiteDimensional hx hfin
+
+theorem with_ratFunc {P : Prop}
+    (h : ∀ [Algebra (RatFunc k) F] [IsScalarTower k (RatFunc k) F]
+      [FiniteDimensional (RatFunc k) F] [Algebra.IsSeparable (RatFunc k) F],
+      algebraMap (RatFunc k) F RatFunc.X = x →
+      Module.finrank (RatFunc k) F = Module.finrank k⟮x⟯ F → P) : P := by
+  have := hfin
+  have := hsep
+  let e : RatFunc k ≃ₐ[k] k⟮x⟯ := RatFunc.algEquivOfTranscendental x hx
+  let : Algebra (RatFunc k) F := ((algebraMap k⟮x⟯ F).comp e.toAlgHom.toRingHom).toAlgebra
+  have hsq : RingHom.comp (algebraMap (RatFunc k) F) (e.symm.toRingEquiv : k⟮x⟯ →+* RatFunc k)
+      = RingHom.comp (RingEquiv.refl F : F →+* F) (algebraMap k⟮x⟯ F) := by
+    ext y
+    change algebraMap k⟮x⟯ F (e (e.symm y)) = algebraMap k⟮x⟯ F y
+    rw [e.apply_symm_apply]
+  have : IsScalarTower k (RatFunc k) F := IsScalarTower.of_algebraMap_eq fun a => by
+    change algebraMap k F a = algebraMap k⟮x⟯ F (e (algebraMap k (RatFunc k) a))
+    rw [e.commutes, ← IsScalarTower.algebraMap_apply]
+  have hfd : FiniteDimensional (RatFunc k) F :=
+    Module.Finite.of_equiv_equiv e.symm.toRingEquiv (RingEquiv.refl F) hsq
+  have : Algebra.IsSeparable (RatFunc k) F :=
+    Algebra.IsSeparable.of_equiv_equiv e.symm.toRingEquiv (RingEquiv.refl F) hsq
+  have hX : algebraMap (RatFunc k) F RatFunc.X = x := by
+    change algebraMap k⟮x⟯ F (e RatFunc.X) = x
+    have h := RatFunc.algEquivOfTranscendental_X x hx
+    exact h
+  have hn : Module.finrank (RatFunc k) F = Module.finrank k⟮x⟯ F :=
+    Algebra.finrank_eq_of_equiv_equiv e.toRingEquiv (RingEquiv.refl F) (by ext y; rfl)
+  exact h hX hn
+
+variable [IsAlgClosed k]
+
+theorem hasCanonicalDivisor_pkg : HasCanonicalDivisor (K := k) (F := F) := by
+  have := isCurveOver_pkg k x hx hfin hsep
+  have := essFiniteType_pkg k x hx hfin
+  exact AlgebraicCurve.hasCanonicalDivisor_of_isCurveOver
+
+theorem dCoordGenerates_pkg : ∀ v : Place k F, v.DCoordGenerates := by
+  have := isCurveOver_pkg k x hx hfin hsep
+  have := essFiniteType_pkg k x hx hfin
+  exact AlgebraicCurve.dCoordGenerates_of_isCurveOver
+
+theorem riemannRoch_and_constantsAreBase_pkg :
+    haveI := hasCanonicalDivisor_pkg k x hx hfin hsep
+    FunctionFieldRiemannRoch k F ∧ ConstantsAreBase k F := by
+  classical
+  have := hfin
+  have := isCurveOver_pkg k x hx hfin hsep
+  have := hasCanonicalDivisor_pkg k x hx hfin hsep
+  have := dCoordGenerates_pkg k x hx hfin hsep
+  have : IsCurveOver k (RatFunc k) := AlgebraicCurve.isCurveOver_ratFunc k
+  have : Algebra.EssFiniteType (Polynomial k) (RatFunc k) :=
+    Algebra.EssFiniteType.of_isLocalization _ (nonZeroDivisors (Polynomial k))
+  have : Algebra.EssFiniteType k (RatFunc k) :=
+    Algebra.EssFiniteType.comp k (Polynomial k) (RatFunc k)
+  have : ∀ v : Place k (RatFunc k), v.DCoordGenerates :=
+    AlgebraicCurve.dCoordGenerates_of_isCurveOver
+  refine with_ratFunc k x hx hfin hsep ?_
+  intro _ _ _ _ _ _
+  have : Algebra.IsIntegral (RatFunc k) F := Algebra.IsIntegral.of_finite _ _
+  exact ⟨AlgebraicCurve.functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver,
+    AlgebraicCurve.constantsAreBase_of_isAlgClosed k F⟩
+
+theorem genus_eq_genusFF_pkg :
+    haveI := hasCanonicalDivisor_pkg k x hx hfin hsep
+    genus k F = genusFF k F := by
+  have := isCurveOver_pkg k x hx hfin hsep
+  have := hasCanonicalDivisor_pkg k x hx hfin hsep
+  have := dCoordGenerates_pkg k x hx hfin hsep
+  have := essFiniteType_pkg k x hx hfin
+  have rr := riemannRoch_and_constantsAreBase_pkg k x hx hfin hsep
+  have hSG : StichtenothGenusExists k F :=
+    AlgebraicCurve.stichtenothGenusExists_of_isCurveOver rr.2
+  have wda : WeilDualityAdelic k F :=
+    AlgebraicCurve.weilDualityAdelic_of_functionFieldRiemannRoch_of_stichtenothGenusExists rr.1 hSG
+  exact AlgebraicCurve.genus_eq_genusFF rr.1 wda rr.2
+
+theorem degree_canonical_pkg :
+    haveI := hasCanonicalDivisor_pkg k x hx hfin hsep
+    ∀ {ω : Ω[F⁄k]} (hω : ω ≠ 0),
+      Divisor.degree (canonicalDivisorOf hω) = 2 * (genusFF k F : ℤ) - 2 := by
+  intro ω hω
+  have := isCurveOver_pkg k x hx hfin hsep
+  have := hasCanonicalDivisor_pkg k x hx hfin hsep
+  have := dCoordGenerates_pkg k x hx hfin hsep
+  have rr := riemannRoch_and_constantsAreBase_pkg k x hx hfin hsep
+  rw [← genus_eq_genusFF_pkg k x hx hfin hsep]
+  exact AlgebraicCurve.degree_canonicalDivisor_eq_of_riemannRoch rr.1 rr.2 hω
+
+end Package
+
+section Bridge
+
+variable {K : Type u} {F : Type v} [Field K] [Field F] [Algebra K F] [PerfectField K]
+  (x : F) [FiniteDimensional K⟮x⟯ F]
+
+omit [PerfectField K] [FiniteDimensional K⟮x⟯ F] in
+theorem exists_dCoord_eq_D (v : Place K F) : ∃ t : F, v.ord t = 1 ∧ v.dCoord = D K F t :=
+  ⟨((IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose : F),
+    v.ord_coe_irreducible
+      (IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose_spec, rfl⟩
+
+omit [PerfectField K] [FiniteDimensional K⟮x⟯ F] in
+theorem coeff_unique {η : Ω[F⁄K]} (hη : η ≠ 0) {a b : F} (h : a • η = b • η) : a = b := by
+  have h0 : (a - b) • η = 0 := by rw [sub_smul, h, sub_self]
+  rcases smul_eq_zero.mp h0 with h1 | h1
+  · exact sub_eq_zero.mp h1
+  · exact absurd h1 hη
+
+include x in
+theorem ordDiff_eq_ordDifferential (v : Place K F) [v.DCoordGenerates] [Nontrivial Ω[F⁄K]]
+    (ω : Ω[F⁄K]) : v.ordDiff ω = v.ordDifferential ω := by
+  obtain ⟨t₂, ht₂, hdc⟩ := exists_dCoord_eq_D v
+  have ht₁ : v.ord v.uniformizer_alt = 1 := v.ord_uniformizer_alt v.exists_ord_eq_one
+  have hc_smul : Place.diffCoeff v.uniformizer_alt (D K F t₂) • D K F v.uniformizer_alt = D K F t₂
+    :=
+    Place.diffCoeff_smul_D_of_ord_eq_one x v ht₁ _
+  have hc'_smul : Place.diffCoeff t₂ (D K F v.uniformizer_alt) • D K F t₂ = D K F v.uniformizer_alt
+    :=
+    Place.diffCoeff_smul_D_of_ord_eq_one x v ht₂ _
+  have hD₁ : D K F v.uniformizer_alt ≠ 0 := Place.D_ne_zero_of_ord_eq_one x v ht₁
+  have hcc' : Place.diffCoeff t₂ (D K F v.uniformizer_alt) *
+      Place.diffCoeff v.uniformizer_alt (D K F t₂) = 1 := by
+    refine coeff_unique hD₁ ?_
+    rw [mul_smul, hc_smul, hc'_smul, one_smul]
+  have hc0 : Place.diffCoeff v.uniformizer_alt (D K F t₂) ≠ 0 := by
+    intro h0
+    rw [h0, mul_zero] at hcc'
+    exact zero_ne_one hcc'
+  have hc'0 : Place.diffCoeff t₂ (D K F v.uniformizer_alt) ≠ 0 := by
+    intro h0
+    rw [h0, zero_mul] at hcc'
+    exact zero_ne_one hcc'
+  have hordc : v.ord (Place.diffCoeff v.uniformizer_alt (D K F t₂)) = 0 := by
+    have h1 : 0 ≤ v.ord (Place.diffCoeff v.uniformizer_alt (D K F t₂)) :=
+      Place.ord_diffCoeff_D_nonneg_of_perfectField x v ht₁ (by rw [ht₂]; exact zero_le_one)
+    have h2 : 0 ≤ v.ord (Place.diffCoeff t₂ (D K F v.uniformizer_alt)) :=
+      Place.ord_diffCoeff_D_nonneg_of_perfectField x v ht₂ (by rw [ht₁]; exact zero_le_one)
+    have h3 := v.ord_mul hc'0 hc0
+    rw [hcc', v.ord_one] at h3
+    omega
+  have ha : Place.diffCoeff v.uniformizer_alt ω • D K F v.uniformizer_alt = ω :=
+    Place.diffCoeff_smul_D_of_ord_eq_one x v ht₁ ω
+  have hb : v.differentialCoeff ω • v.dCoord = ω := v.differentialCoeff_smul_dCoord ω
+  have hab : Place.diffCoeff v.uniformizer_alt ω =
+      v.differentialCoeff ω * Place.diffCoeff v.uniformizer_alt (D K F t₂) := by
+    refine coeff_unique hD₁ ?_
+    rw [ha, mul_smul, hc_smul, ← hdc, hb]
+  rw [Place.ordDiff_def, Place.ordDifferential, hab]
+  rcases eq_or_ne (v.differentialCoeff ω) 0 with hb0 | hb0
+  · rw [hb0, zero_mul]
+  · rw [v.ord_mul hb0 hc0, hordc, add_zero]
+
+end Bridge
+
+section Poles
+
+variable (k : Type u) [Field k] {F : Type v} [Field F] [Algebra k F]
+  [DecidableEq (RatFunc k)]
+  [Algebra (RatFunc k) F] [IsScalarTower k (RatFunc k) F]
+  [FiniteDimensional (RatFunc k) F] [Algebra.IsSeparable (RatFunc k) F]
+  [HasPrincipalDivisors k F]
+
+omit [FiniteDimensional (RatFunc k) F] [Algebra.IsSeparable (RatFunc k) F]
+  [HasPrincipalDivisors k F] in
+def towerX : TranscendenceTower k (RatFunc k) F where
+  x := RatFunc.X
+  hx_indep := AlgebraicCurve.linearIndependent_pow_of_transcendental
+    (RatFunc.transcendental_X (K := k))
+  v := RationalFunctionField.placeInfty k
+  hvdeg := RationalFunctionField.deg_placeInfty k
+  hxv := RationalFunctionField.ord_placeInfty_X k
+  hxreg := fun _ hu => RationalFunctionField.ord_X_nonneg_of_ne_placeInfty k hu
+
+omit [FiniteDimensional (RatFunc k) F] in
+theorem towerX_poleDivisor_apply (w : Place k F) :
+    (towerX k (F := F)).poleDivisor w =
+      if w.ord (algebraMap (RatFunc k) F RatFunc.X) < 0 then
+        -w.ord (algebraMap (RatFunc k) F RatFunc.X) else 0 := by
+  have happ := (towerX k (F := F)).poleDivisor_apply w
+  have hres := w.ord_restrict (F := RatFunc k) (RatFunc.X : RatFunc k)
+  have hv : (towerX k (F := F)).v = RationalFunctionField.placeInfty k := rfl
+  rw [hv] at happ
+  by_cases hw : w.restrict (RatFunc k) = RationalFunctionField.placeInfty k
+  · rw [hw, RationalFunctionField.ord_placeInfty_X, mul_neg, mul_one] at hres
+    have hepos : 0 < Place.ramificationIndex (F := RatFunc k) w := w.ramificationIndex_pos
+    rw [happ, hw, Finsupp.single_eq_same, mul_one, hres, neg_neg, ite_eq_left]
+    rw [neg_lt_zero]
+    exact_mod_cast hepos
+  · have hnn := RationalFunctionField.ord_X_nonneg_of_ne_placeInfty k hw
+    have h0 : 0 ≤ w.ord (algebraMap (RatFunc k) F RatFunc.X) := by
+      rw [hres]; positivity
+    rw [happ, Finsupp.single_eq_of_ne hw, mul_zero, ite_eq_right (not_lt.mpr h0)]
+
+
+omit [DecidableEq (RatFunc k)] in
+theorem sum_poles_eq_finrank (hdeg1 : ∀ w : Place k F, w.deg = 1) :
+    ∃ P : Finset (Place k F),
+      (∀ w, w ∈ P ↔ w.ord (algebraMap (RatFunc k) F RatFunc.X) < 0) ∧
+      ∑ w ∈ P, (-w.ord (algebraMap (RatFunc k) F RatFunc.X)) =
+        (Module.finrank (RatFunc k) F : ℤ) := by
+  classical
+  have hD := towerX_poleDivisor_apply k (F := F)
+  refine ⟨(towerX k (F := F)).poleDivisor.support, fun w => ?_, ?_⟩
+  · rw [Finsupp.mem_support_iff, hD]
+    split_ifs with h
+    · exact ⟨fun _ => h, fun _ => by omega⟩
+    · exact ⟨fun h0 => absurd rfl h0, fun h' => absurd h' h⟩
+  · rw [← (towerX k (F := F)).degree_poleDivisor_eq_finrank, degree_eq_sum_support]
+    refine Finset.sum_congr rfl fun w hw => ?_
+    rw [hdeg1, Nat.cast_one, mul_one, hD]
+    rw [Finsupp.mem_support_iff, hD] at hw
+    split_ifs at hw ⊢ with h
+    · rfl
+    · exact absurd rfl hw
+
+end Poles
+
+theorem sum_bound {ι : Type*} (f m : ι → ℤ)
+    (S : Finset ι) (hS : ∀ P, P ∉ S → f P = 0) (C : ℤ) (hC : ∑ P ∈ S, f P = C)
+    (Poles : Finset ι) (hPoles : ∀ P, P ∈ Poles ↔ m P < 0) (n : ℤ)
+    (hn : ∑ P ∈ Poles, (-m P) = n)
+    (hreg : ∀ P, 0 ≤ m P → 0 ≤ f P) (hpole : ∀ P, m P - 1 ≤ f P)
+    (T : Finset ι) (hT : ∀ P ∈ T, 0 ≤ m P) (Tinf : Finset ι) (hTinf : ∀ P ∈ Tinf, m P < 0) :
+    ∑ P ∈ T, f P + ∑ P ∈ Tinf, (-m P - 1) ≤ C + 2 * n := by
+  classical
+  set U : Finset ι := S ∪ T ∪ Poles with hU
+  have hSU : S ⊆ U := Finset.subset_union_left.trans Finset.subset_union_left
+  have hTU : T ⊆ U := Finset.subset_union_right.trans Finset.subset_union_left
+  have hPU : Poles ⊆ U \ T := by
+    intro P hP
+    rw [Finset.mem_sdiff]
+    refine ⟨Finset.mem_union_right _ hP, fun hPT => ?_⟩
+    have h1 := (hPoles P).mp hP
+    have h2 := hT P hPT
+    omega
+  have hUsum : ∑ P ∈ U, f P = C := by
+    rw [← hC]; exact (Finset.sum_subset hSU fun P _ hPS => hS P hPS).symm
+  have hsplit : ∑ P ∈ U \ T, f P + ∑ P ∈ T, f P = ∑ P ∈ U, f P := Finset.sum_sdiff hTU
+  let g : ι → ℤ := fun P => if m P < 0 then m P - 1 else 0
+  have hfg : ∀ P, g P ≤ f P := fun P => by
+    change (if m P < 0 then m P - 1 else 0) ≤ f P
+    split_ifs with h
+    · exact hpole P
+    · exact hreg P (not_lt.mp h)
+  have hg1 : ∑ P ∈ U \ T, g P ≤ ∑ P ∈ U \ T, f P := Finset.sum_le_sum fun P _ => hfg P
+  have hg2 : ∑ P ∈ Poles, g P = ∑ P ∈ U \ T, g P := by
+    refine Finset.sum_subset hPU fun P _ hP => ?_
+    change (if m P < 0 then m P - 1 else 0) = 0
+    rw [ite_eq_right (fun h => hP ((hPoles P).mpr h))]
+  have hg3 : ∑ P ∈ Poles, g P = ∑ P ∈ Poles, (m P - 1) :=
+    Finset.sum_congr rfl fun P hP => ite_eq_left ((hPoles P).mp hP)
+  have hcard : ∑ P ∈ Poles, (1 : ℤ) = Poles.card := by simp
+  have hsum1 : ∑ P ∈ Poles, (m P - 1) = -n - Poles.card := by
+    rw [Finset.sum_sub_distrib, hcard, ← hn, Finset.sum_neg_distrib, neg_neg]
+  have hsum2 : ∑ P ∈ Poles, (-m P - 1) = n - Poles.card := by
+    rw [Finset.sum_sub_distrib, hcard, hn]
+  have hTP : Tinf ⊆ Poles := fun P hP => (hPoles P).mpr (hTinf P hP)
+  have hinf : ∑ P ∈ Tinf, (-m P - 1) ≤ ∑ P ∈ Poles, (-m P - 1) :=
+    Finset.sum_le_sum_of_subset_of_nonneg hTP fun P hP _ => by
+      have := (hPoles P).mp hP
+      omega
+  have hTle : ∑ P ∈ T, f P ≤ C + n + Poles.card := by
+    have := hg1; rw [← hg2, hg3, hsum1] at this
+    linarith
+  linarith
+
+theorem main
+    (k : Type u) [Field k] [IsAlgClosed k] {F : Type v} [Field F] [Algebra k F]
+    (x : F) (hx : Transcendental k x)
+    (hfin : FiniteDimensional (IntermediateField.adjoin k ({x} : Set F)) F)
+    (hsep : Algebra.IsSeparable (IntermediateField.adjoin k ({x} : Set F)) F)
+    (T : Finset (Place k F)) (hT : ∀ P ∈ T, 0 ≤ P.ord x)
+    (Tinf : Finset (Place k F)) (hTinf : ∀ P ∈ Tinf, P.ord x < 0) :
+    ∑ P ∈ T, P.ordDiff (KaehlerDifferential.D k F x) + ∑ P ∈ Tinf, (-P.ord x - 1) ≤
+      2 * (genusFF k F : ℤ) - 2 +
+        2 * (Module.finrank (IntermediateField.adjoin k ({x} : Set F)) F : ℤ) := by
+  classical
+  have hC : IsCurveOver k F := isCurveOver_pkg k x hx hfin hsep
+  have hK : HasCanonicalDivisor (K := k) (F := F) := hasCanonicalDivisor_pkg k x hx hfin hsep
+  have hG : ∀ v : Place k F, v.DCoordGenerates := dCoordGenerates_pkg k x hx hfin hsep
+  have hω : KaehlerDifferential.D k F x ≠ 0 :=
+    KaehlerDifferential.D_ne_zero_of_transcendental k x hx
+  have hWapp : ∀ P : Place k F, canonicalDivisorOf hω P = P.ordDiff (D k F x) := fun P => by
+    rw [canonicalDivisorOf_apply, ordDiff_eq_ordDifferential x P]
+  have hWdeg : (canonicalDivisorOf hω).degree = 2 * (genusFF k F : ℤ) - 2 :=
+    degree_canonical_pkg k x hx hfin hsep hω
+  have hdeg1 : ∀ P : Place k F, P.deg = 1 := IsCurveOver.forall_deg_eq_one_of_isAlgClosed
+  have hS : ∀ P, P ∉ (canonicalDivisorOf hω).support → P.ordDiff (D k F x) = 0 := fun P hP => by
+    rw [← hWapp]; exact Finsupp.notMem_support_iff.mp hP
+  have hsumW : ∑ P ∈ (canonicalDivisorOf hω).support, P.ordDiff (D k F x) =
+      2 * (genusFF k F : ℤ) - 2 := by
+    rw [← hWdeg, degree_eq_sum_support]
+    exact (Finset.sum_congr rfl fun P _ => by rw [hWapp, hdeg1, Nat.cast_one, mul_one]).symm
+  obtain ⟨Poles, hPoles, hn⟩ : ∃ Poles : Finset (Place k F), (∀ w, w ∈ Poles ↔ w.ord x < 0) ∧
+      ∑ w ∈ Poles, (-w.ord x) = (Module.finrank k⟮x⟯ F : ℤ) := by
+    refine with_ratFunc k x hx hfin hsep ?_
+    intro _ _ _ _ hX hnn
+    have h := sum_poles_eq_finrank k (F := F) hdeg1
+    rw [hX, hnn] at h
+    exact h
+  have hreg : ∀ P : Place k F, 0 ≤ P.ord x → 0 ≤ P.ordDiff (D k F x) := fun P hP => by
+    rw [Place.ordDiff_def]
+    exact Place.ord_diffCoeff_D_nonneg_of_perfectField x P
+      (P.ord_uniformizer_alt P.exists_ord_eq_one) hP
+  have hpole : ∀ P : Place k F, P.ord x - 1 ≤ P.ordDiff (D k F x) := fun P =>
+    Place.ord_sub_one_le_ordDiff_D_of_perfectField x P hω
+  exact sum_bound (fun P : Place k F => P.ordDiff (D k F x)) (fun P => P.ord x)
+    (canonicalDivisorOf hω).support hS _ hsumW Poles hPoles _ hn hreg hpole T hT Tinf hTinf
+
+end HurwitzLineBoundProof
+
+end AlgebraicCurve
+
+end
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_sum_ordDiff_D_le_two_mul_genusFF_of_isSeparable.AlgebraicCurve"
+
+theorem solution
+    (k : Type*) [Field k] [IsAlgClosed k] {F : Type*} [Field F] [Algebra k F]
+    (x : F) (hx : Transcendental k x)
+    (hfin : FiniteDimensional (IntermediateField.adjoin k ({x} : Set F)) F)
+    (hsep : Algebra.IsSeparable (IntermediateField.adjoin k ({x} : Set F)) F)
+    (T : Finset (Place k F)) (hT : ∀ P ∈ T, 0 ≤ P.ord x)
+    (Tinf : Finset (Place k F)) (hTinf : ∀ P ∈ Tinf, P.ord x < 0) :
+    ∑ P ∈ T, P.ordDiff (KaehlerDifferential.D k F x) + ∑ P ∈ Tinf, (-P.ord x - 1) ≤
+      2 * (genusFF k F : ℤ) - 2 +
+        2 * (Module.finrank (IntermediateField.adjoin k ({x} : Set F)) F : ℤ) :=
+  AlgebraicCurve.HurwitzLineBoundProof.main k x hx hfin hsep T hT Tinf hTinf
+
+end S_AlgebraicCurve_sum_ordDiff_D_le_two_mul_genusFF_of_isSeparable
+end P2MW
+export P2MW.S_AlgebraicCurve_sum_ordDiff_D_le_two_mul_genusFF_of_isSeparable (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.sum_ordDiff_D_le_two_mul_genusFF_of_isSeparable
+    (k : Type*) [Field k] [IsAlgClosed k] {F : Type*} [Field F] [Algebra k F]
+    (x : F) (hx : Transcendental k x)
+    (hfin : FiniteDimensional (IntermediateField.adjoin k ({x} : Set F)) F)
+    (hsep : Algebra.IsSeparable (IntermediateField.adjoin k ({x} : Set F)) F)
+    (T : Finset (Place k F)) (hT : ∀ P ∈ T, 0 ≤ P.ord x)
+    (Tinf : Finset (Place k F)) (hTinf : ∀ P ∈ Tinf, P.ord x < 0) :
+    ∑ P ∈ T, P.ordDiff (KaehlerDifferential.D k F x) + ∑ P ∈ Tinf, (-P.ord x - 1) ≤
+      2 * (genusFF k F : ℤ) - 2 +
+        2 * (Module.finrank (IntermediateField.adjoin k ({x} : Set F)) F : ℤ) :=
+  solution k x hx hfin hsep T hT Tinf hTinf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_sum_ord_sub_one_le_two_mul_genusFF_of_isSeparable.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_sum_ord_sub_one_le_two_mul_genusFF_of_isSeparable.lean
new file mode 100644
index 0000000000..9781b60bb9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_sum_ord_sub_one_le_two_mul_genusFF_of_isSeparable.lean
@@ -0,0 +1,150 @@
+/-
+Based on Prove2Me node AlgebraicCurve.sum_ord_sub_one_le_two_mul_genusFF_of_isSeparable
+(c3b8311a-5293-58eb-8c4d-de3f0a048029) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3a146374-cf5f-5310-bce3-ca8ad94f6bf2
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Repartitions
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_sub_one_le_ordDiff_D_of_perfectField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_sum_ordDiff_D_le_two_mul_genusFF_of_isSeparable
+import LeanPool.FLTEichlerShimura.Theorems.Thm_KaehlerDifferential_D_ne_zero_of_transcendental
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Hurwitz ramification bound for a separable function field over the line
+
+Theorem statement: `AlgebraicCurve.sum_ord_sub_one_le_two_mul_genusFF_of_isSeparable`
+(`c3b8311a-5293-58eb-8c4d-de3f0a048029`), by Claude, 2026-09-05.
+
+Proof: submission `3a146374-cf5f-5310-bce3-ca8ad94f6bf2`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $k$ be an algebraically closed field (no restriction on the characteristic) and let $F$ be a
+field extension of $k$. Let $x \in F$ be transcendental over $k$, and assume that $F$ is
+finite-dimensional and separable over the intermediate field $k(x) =$ `IntermediateField.adjoin k
+{x}`. Places of $F/k$ are, as in this development, valuation subrings of $F$ that contain the image
+of $k$, are proper, and are principal ideal rings; for such a place $P$ and $f \in F$,
+$P.\mathrm{ord}(f)$ is minus the logarithm of the value of $f$ under the $\mathbb{Z}^{m0}$-valued
+adic valuation attached to $P$. Let $T$ be a finite set of places together with a function $a$
+assigning to each place an element $a_P \in k$, such that $\mathrm{ord}_P(x - a_P) > 0$ for every $P
+\in T$, and let $T_\infty$ be a finite set of places with $\mathrm{ord}_P(x) < 0$ for every $P \in
+T_\infty$ (so $T$ and $T_\infty$ are automatically disjoint). Then
+$$\sum_{P \in T}\bigl(\mathrm{ord}_P(x-a_P)-1\bigr)+\sum_{P\in
+T_\infty}\bigl(-\mathrm{ord}_P(x)-1\bigr)\ \le\ 2\,\mathrm{genusFF}(k,F)-2+2\,[F:k(x)],$$
+where $\mathrm{genusFF}(k,F)$ is the $k$-dimension of $H^1$ of the zero divisor of $F/k$.
+
+This is the Riemann–Hurwitz inequality for the extension $F/k(x)$ combined with Dedekind's different
+inequality $d(P\mid p)\ge e(P\mid p)-1$, packaged as a bound over an arbitrary finite family of
+places lying over points $x=a_P$ of the affine line and over poles of $x$, so that no enumeration of
+all ramified places is needed. It is used in the genus estimates for modular curves, for instance in
+[`ModularCurve.LevelN.twelve_mul_add_mul_index_le_genusFF`]
+(thm.html#ModularCurve.LevelN.twelve_mul_add_mul_index_le_genusFF)
+and in the comparisons of `genusFF` for the various modular function fields.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_sum_ord_sub_one_le_two_mul_genusFF_of_isSeparable.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_sum_ord_sub_one_le_two_mul_genusFF_of_isSeparable
+
+open AlgebraicCurve
+
+namespace HurwitzRamificationOverLine
+
+variable {k : Type*} {F : Type*} [Field k] [Field F] [Algebra k F]
+
+theorem ord_nonneg_of_ord_sub_algebraMap_pos (P : Place k F) (x : F) (a : k)
+    (h : 0 < P.ord (x - algebraMap k F a)) : 0 ≤ P.ord x := by
+  have h1 : P.adicValuation (x - algebraMap k F a) ≤ 1 :=
+    P.adicValuation_le_one_iff.mpr (Or.inr h.le)
+  have h2 : P.adicValuation (algebraMap k F a) ≤ 1 := P.adicValuation_algebraMap_le_one a
+  have h3 : P.adicValuation x ≤ 1 := by
+    have hx : x = (x - algebraMap k F a) + algebraMap k F a := by ring
+    rw [hx]
+    exact Valuation.map_add_le _ h1 h2
+  rcases P.adicValuation_le_one_iff.mp h3 with hx0 | hx0
+  · simp [hx0]
+  · exact hx0
+
+theorem D_sub_algebraMap (x : F) (a : k) :
+    KaehlerDifferential.D k F (x - algebraMap k F a) = KaehlerDifferential.D k F x := by
+  rw [map_sub, Derivation.map_algebraMap, sub_zero]
+
+end HurwitzRamificationOverLine
+
+theorem solution
+    (k : Type*) [Field k] [IsAlgClosed k] {F : Type*} [Field F] [Algebra k F]
+    (x : F) (hx : Transcendental k x)
+    (hfin : FiniteDimensional (IntermediateField.adjoin k ({x} : Set F)) F)
+    (hsep : Algebra.IsSeparable (IntermediateField.adjoin k ({x} : Set F)) F)
+    (T : Finset (Place k F)) (a : Place k F → k)
+    (hT : ∀ P ∈ T, 0 < P.ord (x - algebraMap k F (a P)))
+    (Tinf : Finset (Place k F)) (hTinf : ∀ P ∈ Tinf, P.ord x < 0) :
+    ∑ P ∈ T, (P.ord (x - algebraMap k F (a P)) - 1) + ∑ P ∈ Tinf, (-P.ord x - 1) ≤
+      2 * (genusFF k F : ℤ) - 2 +
+        2 * (Module.finrank (IntermediateField.adjoin k ({x} : Set F)) F : ℤ) := by
+  have := hfin
+  have := hsep
+  have hmain :=
+    AlgebraicCurve.sum_ordDiff_D_le_two_mul_genusFF_of_isSeparable k x hx hfin hsep T
+      (fun P hP =>
+        HurwitzRamificationOverLine.ord_nonneg_of_ord_sub_algebraMap_pos P x (a P) (hT P hP))
+      Tinf hTinf
+  have hDx : KaehlerDifferential.D k F x ≠ 0 :=
+    KaehlerDifferential.D_ne_zero_of_transcendental k x hx
+  have hloc : ∀ P ∈ T,
+      P.ord (x - algebraMap k F (a P)) - 1 ≤ P.ordDiff (KaehlerDifferential.D k F x) := by
+    intro P hP
+    have hD : KaehlerDifferential.D k F (x - algebraMap k F (a P)) ≠ 0 := by
+      rwa [HurwitzRamificationOverLine.D_sub_algebraMap]
+    have h :=
+      AlgebraicCurve.Place.ord_sub_one_le_ordDiff_D_of_perfectField (K := k) x P hD
+    rwa [HurwitzRamificationOverLine.D_sub_algebraMap] at h
+  have hsum :
+      ∑ P ∈ T, (P.ord (x - algebraMap k F (a P)) - 1) ≤
+        ∑ P ∈ T, P.ordDiff (KaehlerDifferential.D k F x) :=
+    Finset.sum_le_sum hloc
+  linarith
+
+end S_AlgebraicCurve_sum_ord_sub_one_le_two_mul_genusFF_of_isSeparable
+end P2MW
+export P2MW.S_AlgebraicCurve_sum_ord_sub_one_le_two_mul_genusFF_of_isSeparable (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.sum_ord_sub_one_le_two_mul_genusFF_of_isSeparable
+    (k : Type*) [Field k] [IsAlgClosed k] {F : Type*} [Field F] [Algebra k F]
+    (x : F) (hx : Transcendental k x)
+    (hfin : FiniteDimensional (IntermediateField.adjoin k ({x} : Set F)) F)
+    (hsep : Algebra.IsSeparable (IntermediateField.adjoin k ({x} : Set F)) F)
+    (T : Finset (Place k F)) (a : Place k F → k)
+    (hT : ∀ P ∈ T, 0 < P.ord (x - algebraMap k F (a P)))
+    (Tinf : Finset (Place k F)) (hTinf : ∀ P ∈ Tinf, P.ord x < 0) :
+    ∑ P ∈ T, (P.ord (x - algebraMap k F (a P)) - 1) + ∑ P ∈ Tinf, (-P.ord x - 1) ≤
+      2 * (genusFF k F : ℤ) - 2 +
+        2 * (Module.finrank (IntermediateField.adjoin k ({x} : Set F)) F : ℤ) :=
+  solution k x hx hfin hsep T a hT Tinf hTinf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_tateAgreement.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_tateAgreement.lean
new file mode 100644
index 0000000000..ccec1fde03
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_tateAgreement.lean
@@ -0,0 +1,3896 @@
+/-
+Based on Prove2Me node AlgebraicCurve.tateAgreement
+(e2d67bb2-5c38-50ea-b555-e4672b767b86) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 45a9b7aa-5763-5b25-92a0-3cbfc64f20c8
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_CanonicalLocalResidueInstanceV2
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_TateResidueCurrency
+
+import Mathlib.RingTheory.AdicCompletion.Noetherian
+import Mathlib.RingTheory.AdicCompletion.RingHom
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Tate's residue agrees with the local residue trace
+
+Theorem statement: `AlgebraicCurve.tateAgreement` (`e2d67bb2-5c38-50ea-b555-e4672b767b86`), by
+Claude, 2026-09-05.
+
+Proof: submission `45a9b7aa-5763-5b25-92a0-3cbfc64f20c8`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $L$ be fields with $L$ a $K$-algebra such that [`AlgebraicCurve.IsCurveOver K
+L`](def/AlgebraicCurve_IsCurveOver.html#L15) holds: every nonzero $f \in L$ has an associated
+divisor whose value at each place is $\operatorname{ord}_v(f)$ and whose degree is $0$, every place
+$v$ of $L$ over $K$ (a valuation subring of $L$ containing the image of $K$, distinct from $L$
+itself, and a principal ideal ring) has residue field finite over $K$, and $\Omega_{L/K}$ is free of
+rank $1$ over $L$. Assume in addition that $K$ is perfect and that each place $u$ carries the
+instance `FiniteResidue`, i.e. its residue field is a finite $K$-module. Let `hfin` witness
+`KwF4gRRTateCommFinite K L`: for every place $u$ and all $\hat f, \hat g$ in the adic completion
+$\widehat{L}_u$, the range of the endomorphism `tateCommRestrict` built from the projection
+`tateProj u` of $\widehat{L}_u$ onto the $K$-submodule of adic integers along a chosen complement
+and from the multiplication operators by $\hat f$ and $\hat g$ is finite-dimensional over $K$. The
+conclusion is `KwF4gRRTateAgreement K L hfin`: for every place $u$ with finite residue field and
+every $\hat f \in \widehat{L}_u$, the Tate residue `tateRes u` of $\hat f$ against the image in
+$\widehat{L}_u$ of a uniformizer of $u$ — the trace of the restricted commutator furnished by `hfin`
+— equals $\operatorname{Tr}_{\kappa(u)/K}$ of `kwHgfV352_localResidueCompletion u` $\hat f$, the
+local residue at $u$ evaluated on an element of $L$ differing from $\hat f$ by an adic integer.
+
+This is the comparison, in Tate's treatment of residues of differentials on curves, between the
+commutator-trace definition of the residue on a completion and the trace to $K$ of the classical
+local residue, here at the pairing of an arbitrary element against a uniformizer. It is used by
+[`AlgebraicCurve.residueTraceCompletionCommute`]
+(thm.html#AlgebraicCurve.residueTraceCompletionCommute)
+in establishing the compatibility of residues with traces on completions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_tateAgreement.lean
+
+*Attribution:* this file contains material adapted from third-party Apache-2.0 sources (one short
+lemma (`IsLocalRing.maximalIdeal_le`): `FLT/Mathlib/RingTheory/LocalRing/MaximalIdeal/Basic.lean` —
+© 2025 Salvatore Mercuri; authors: Salvatore Mercuri, Kevin Buzzard). See ATTRIBUTION.md and NOTICE
+in the source repository.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 25600000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_tateAgreement
+
+section
+namespace IsLocalRing
+p2m_export "IsLocalRing" "ResidueField maximalIdeal residue_eq_zero_iff maximalIdeal.isMaximal \
+  residue_surjective of_injective residue"
+end IsLocalRing
+
+end
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.FiniteResidue Place.ord Divisor HasPrincipalDivisors Pic0 \
+  Place.FiniteResidue.finite IsCurveOver HasCanonicalLocalResidueKStar \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff \
+  kwHgfV352_exists_sub_mem_adicCompletionIntegers kwHgfV352_localResidueCompletion \
+  completionSection_nonempty_generic localResidue_eq_resStar"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal adicValuation adicValuation_ne_zero ord ord_zero ord_mul \
+  ord_unit_smul_zpow exists_unit_mul_zpow FiniteResidue.finite algebraMap_mem' toValuationSubring \
+  mk DCoordGenerates uniformizer ord_uniformizer uniformizer_ne_zero localResidue \
+  localResidue_eq_zero_of_ord_nonneg restrict adicCompletion adicCompletionIntegers \
+  uniformizerSubring coe_uniformizerSubring uniformizerSubring_mem_maximalIdeal uniformizer_mem \
+  poleSubmodule mem_poleSubmodule mem_poleSubmodule_iff_ord"
+end Place
+p2m_export "AlgebraicCurve" "Place Place.FiniteResidue Place.ord Divisor HasPrincipalDivisors Pic0 \
+  Place.FiniteResidue.finite IsCurveOver HasCanonicalLocalResidueKStar \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff \
+  kwHgfV352_exists_sub_mem_adicCompletionIntegers kwHgfV352_localResidueCompletion \
+  completionSection_nonempty_generic localResidue_eq_resStar"
+end AlgebraicCurve
+namespace AlgebraicGeometry
+p2m_export "AlgebraicGeometry" "Surjective IsIntegral"
+end AlgebraicGeometry
+namespace CategoryTheory
+p2m_export "CategoryTheory" "inclusion Quotient Injective exp Quotient.equiv comp_apply id_apply \
+  sum Quotient.mk"
+namespace Limits
+p2m_export "CategoryTheory.Limits" "span ker"
+end Limits
+end CategoryTheory
+namespace Classical
+p2m_export "Classical" "choose_spec em choose"
+end Classical
+namespace Filter
+p2m_export "Filter" "mem_bot ker eventually_atTop mk mem_comap map_top atTop mem_ker mem_sup \
+  mem_top comap unique map_mono map"
+end Filter
+namespace IntermediateField
+p2m_export "IntermediateField" "mk val lift inclusion ext algebraMap_apply smul_def mem_inf \
+  finiteDimensional_sup comap mem_top restrictScalars restrictScalars_top mem_bot map_mono \
+  restrict map"
+end IntermediateField
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "HeightOneSpectrum.ext mk HeightOneSpectrum"
+namespace HeightOneSpectrum
+p2m_export "IsDedekindDomain.HeightOneSpectrum" "valuation_of_algebraMap \
+  intValuation_le_pow_iff_mem isMaximal mk mem_adicCompletionIntegers comap \
+  valuedAdicCompletion_eq_valuation' adicCompletion valuation adicCompletionIntegers \
+  valuedAdicCompletion_surjective mem_integers_of_valuation_le_one denseRange_algebraMap \
+  intValuation exists_ofAdd_natCast_lt completionIdeal \
+  adicCompletion.maximalIdeal_eq_span_uniformizer adicCompletion.mem_completionIdeal_pow"
+end HeightOneSpectrum
+end IsDedekindDomain
+namespace IsLocalRing
+p2m_export "IsLocalRing" "ResidueField maximalIdeal residue_eq_zero_iff maximalIdeal.isMaximal \
+  residue_surjective of_injective residue"
+end IsLocalRing
+namespace KaehlerDifferential
+p2m_export "KaehlerDifferential" "finite D map"
+end KaehlerDifferential
+namespace LinearMap
+p2m_export "LinearMap" "mulLeft_apply mem_range range sub_apply ker_eq_bot id range_comp \
+  codRestrict inr mulLeft ker_comp trace_comp_comm' mk coe_coe id_apply finiteDimensional_range \
+  ext comp trace quotKerEquivRange finiteDimensional range_comp_le_range single lsum \
+  restrictScalars ker mem_ker comp_apply trace_conj' mem_range_self restrict"
+end LinearMap
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateAgreement"
+end KwF4gRRTate
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwNo6Pin
+p2m_export "ModularCurve.KwNo6Pin" "aCoeff aCoeff_zero aCoeff_add aCoeff_shift aCoeff_shift_pow \
+  clearedHat resStar aCoeff_clearedHat_of_le resStar_simplePole resStar_higherPoleMonomial"
+end KwNo6Pin
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace Lg37
+p2m_export "ModularCurve.Lg37" "lg37_completion lg37_residueHat lg37_residueHat_algebraMap \
+  Lg37CompletionSection"
+end Lg37
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace Mp72a102T3
+p2m_export "ModularCurve.Mp72a102T3" "mp72a102_t3_evalₐ_zero_depth mp72a102_t3_evalₐ_factor \
+  mp72a102_t3_evalₐ_succ_mul_eq_zero mp72a102_t3_evalDepth_mul mp72a102_t3_sigma_taylor_expansion"
+end Mp72a102T3
+end ModularCurve
+namespace Module
+p2m_export "Module" "Injective support equiv Finite.equiv mk restrictScalars \
+  Finite.of_submodule_quotient mem_support_iff notMem_support_iff"
+end Module
+namespace MonoidWithZeroHom
+p2m_export "MonoidWithZeroHom" "id_apply id ext mk ValueGroup₀ coe_coe comp_apply \
+  ValueGroup₀.embedding ValueGroup₀.embedding_strictMono comp inr"
+end MonoidWithZeroHom
+namespace Mp72a103T2
+p2m_export "Mp72a103T2" "mp72a103_t2_taylor_coeff_eq_zero_of_depth"
+end Mp72a103T2
+namespace Multiplicative
+p2m_export "Multiplicative" "ext"
+end Multiplicative
+namespace NumberField
+p2m_export "NumberField" "mk"
+end NumberField
+namespace Order
+p2m_export "Order" "lt_succ_iff succ one_le_iff_ne_zero Ideal"
+end Order
+namespace PadicInt
+p2m_export "PadicInt" "lift valuation coe_sub ext algebraMap_apply"
+end PadicInt
+namespace Polynomial
+p2m_export "Polynomial" "C support algebraMap_eq unique lsum ext_iff map comp sum coe_sub \
+  mem_support_iff notMem_support_iff erase algebraMap_apply ext ring"
+end Polynomial
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq inclusion mem_sup_right map_top smul_mem' mk mem_bot coe_mem \
+  Quotient.mk span restrictScalars projectionOnto_apply_left restrictScalars_top mem_closure_iff \
+  Quotient.restrictScalarsEquiv mem_comap injective_subtype mem_top Quotient.equiv \
+  mem_span_singleton mkQ map_mono map_smul' equivMapOfInjective zero map_add_le \
+  quotientQuotientEquivQuotient range_subtype disjoint_def Quotient.mk_surjective \
+  restrictScalars_mono map mem_inf inclusion_apply mem_sup Quotient.mk_eq_zero exists_isCompl \
+  projectionOnto finiteDimensional_of_le smul_def mk_eq_zero restrictScalarsEquiv mkQ_apply ext \
+  factor_mk subtype_apply ker_mkQ comap factorPow finiteDimensional_sup projectionOnto_apply_right \
+  liftQ mem_sup_left restrictScalars_mem"
+end Submodule
+namespace TensorProduct
+p2m_export "TensorProduct" "congr lift mk ext map Algebra.smul_def mk_surjective"
+end TensorProduct
+namespace WithZero
+p2m_export "WithZero" "map exp_lt_exp exp_eq_coe_ofAdd exp_neg coe exp_ne_zero exp exp_zero \
+  exp_add lift le exp_nsmul exp_le_exp exp_log"
+end WithZero
+
+section
+
+
+p2m_open "LinearMap P2MW.S_AlgebraicCurve_tateAgreement.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateAgreement.Submodule"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateAgreement"
+end KwF4gRRTate
+end ModularCurve
+
+end
+
+end
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain WithZero \
+  P2MW.S_AlgebraicCurve_tateAgreement.WithZero IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsLocalRing"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.FiniteResidue Place.ord Divisor HasPrincipalDivisors Pic0 \
+  Place.FiniteResidue.finite IsCurveOver HasCanonicalLocalResidueKStar \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff \
+  kwHgfV352_exists_sub_mem_adicCompletionIntegers kwHgfV352_localResidueCompletion \
+  completionSection_nonempty_generic localResidue_eq_resStar"
+p2m_open "AlgebraicCurve"
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal adicValuation adicValuation_ne_zero ord ord_zero ord_mul \
+  ord_unit_smul_zpow exists_unit_mul_zpow FiniteResidue.finite algebraMap_mem' toValuationSubring \
+  mk DCoordGenerates uniformizer ord_uniformizer uniformizer_ne_zero localResidue \
+  localResidue_eq_zero_of_ord_nonneg restrict adicCompletion adicCompletionIntegers \
+  uniformizerSubring coe_uniformizerSubring uniformizerSubring_mem_maximalIdeal uniformizer_mem \
+  poleSubmodule mem_poleSubmodule mem_poleSubmodule_iff_ord"
+end Place
+
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "smul_def"
+end Divisor
+
+namespace Pic0
+p2m_export "AlgebraicCurve.Pic0" "mk mk_surjective"
+end Pic0
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal adicValuation adicValuation_ne_zero ord ord_zero ord_mul \
+  ord_unit_smul_zpow exists_unit_mul_zpow FiniteResidue.finite algebraMap_mem' toValuationSubring \
+  mk DCoordGenerates uniformizer ord_uniformizer uniformizer_ne_zero localResidue \
+  localResidue_eq_zero_of_ord_nonneg restrict adicCompletion adicCompletionIntegers \
+  uniformizerSubring coe_uniformizerSubring uniformizerSubring_mem_maximalIdeal uniformizer_mem \
+  poleSubmodule mem_poleSubmodule mem_poleSubmodule_iff_ord"
+end Place
+
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "smul_def"
+end Divisor
+
+namespace Pic0
+p2m_export "AlgebraicCurve.Pic0" "mk mk_surjective"
+end Pic0
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal adicValuation adicValuation_ne_zero ord ord_zero ord_mul \
+  ord_unit_smul_zpow exists_unit_mul_zpow FiniteResidue.finite algebraMap_mem' toValuationSubring \
+  mk DCoordGenerates uniformizer ord_uniformizer uniformizer_ne_zero localResidue \
+  localResidue_eq_zero_of_ord_nonneg restrict adicCompletion adicCompletionIntegers \
+  uniformizerSubring coe_uniformizerSubring uniformizerSubring_mem_maximalIdeal uniformizer_mem \
+  poleSubmodule mem_poleSubmodule mem_poleSubmodule_iff_ord"
+end Place
+
+end AlgebraicCurve
+
+end
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain WithZero \
+  P2MW.S_AlgebraicCurve_tateAgreement.WithZero IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsLocalRing"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.FiniteResidue Place.ord Divisor HasPrincipalDivisors Pic0 \
+  Place.FiniteResidue.finite IsCurveOver HasCanonicalLocalResidueKStar \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff \
+  kwHgfV352_exists_sub_mem_adicCompletionIntegers kwHgfV352_localResidueCompletion \
+  completionSection_nonempty_generic localResidue_eq_resStar"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal adicValuation adicValuation_ne_zero ord ord_zero ord_mul \
+  ord_unit_smul_zpow exists_unit_mul_zpow FiniteResidue.finite algebraMap_mem' toValuationSubring \
+  mk DCoordGenerates uniformizer ord_uniformizer uniformizer_ne_zero localResidue \
+  localResidue_eq_zero_of_ord_nonneg restrict adicCompletion adicCompletionIntegers \
+  uniformizerSubring coe_uniformizerSubring uniformizerSubring_mem_maximalIdeal uniformizer_mem \
+  poleSubmodule mem_poleSubmodule mem_poleSubmodule_iff_ord"
+p2m_open "AlgebraicCurve.Place"
+
+section SinglePlace
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+p2m_export "AlgebraicCurve.Place" "ord_nonneg_of_mem"
+p2m_export "AlgebraicCurve.Place" "mem_of_ord_nonneg"
+p2m_export "AlgebraicCurve.Place" "mem_iff_ord_nonneg"
+end SinglePlace
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+section
+
+p2m_open_scoped "Multiplicative P2MW.S_AlgebraicCurve_tateAgreement.Multiplicative WithZero \
+  P2MW.S_AlgebraicCurve_tateAgreement.WithZero"
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain.HeightOneSpectrum MonoidWithZeroHom \
+  P2MW.S_AlgebraicCurve_tateAgreement.MonoidWithZeroHom"
+
+namespace MazurTorsion
+
+section Henselian
+
+variable {A : Type*} [CommRing A] [IsDedekindDomain A]
+  (K : Type*) [Field K] [Algebra A K] [IsFractionRing A K]
+  (v : IsDedekindDomain.HeightOneSpectrum A)
+
+theorem isClosed_setOf_valued_le (γ : ℤᵐ⁰) :
+    IsClosed {x : v.adicCompletion K | Valued.v x ≤ γ} := by
+  obtain ⟨z, hz⟩ := valuedAdicCompletion_surjective K v γ
+  have h := Valued.isClosed_closedBall (R := v.adicCompletion K) (Γ₀ := ℤᵐ⁰)
+    ((Valued.v : Valuation (v.adicCompletion K) ℤᵐ⁰).restrict z)
+  convert h using 1
+  ext x
+  simp only [Set.mem_ofPred_eq]
+  rw [Valuation.restrict_le_iff, hz]
+
+set_option synthInstance.maxHeartbeats 1600000 in
+scoped instance instIsAdicCompleteCompletionIdealAdicCompletionIntegers :
+    IsAdicComplete (v.completionIdeal K) (v.adicCompletionIntegers K) where
+  haus' x hx := by
+    have hx' : ∀ n : ℕ, Valued.v x.val ≤ WithZero.exp (-(n : ℤ)) := by
+      intro n
+      have h := hx n
+      simp only [Ideal.smul_eq_mul, Ideal.mul_top, SModEq.zero,
+        adicCompletion.mem_completionIdeal_pow K v] at h
+      exact h
+    by_contra hx0
+    have hxne : x.val ≠ (0 : v.adicCompletion K) := fun h => hx0 (Subtype.ext h)
+    have hvne : Valued.v x.val ≠ 0 :=
+      (Valuation.ne_zero_iff (Valued.v : Valuation (v.adicCompletion K) ℤᵐ⁰)).mpr hxne
+    obtain ⟨k, hk⟩ := exists_ofAdd_natCast_lt hvne
+    exact absurd (hx' k) (not_le.mpr hk)
+  prec' f hf := by
+    classical
+    have hf' : ∀ m n : ℕ, m ≤ n →
+        Valued.v ((f m - f n : v.adicCompletionIntegers K)).val ≤ WithZero.exp (-(m : ℤ)) := by
+      intro m n hmn
+      have h := hf hmn
+      simp only [Ideal.smul_eq_mul, Ideal.mul_top, SModEq.sub_mem,
+        adicCompletion.mem_completionIdeal_pow K v] at h
+      exact h
+    have hcoe : ∀ a b : ℕ, ((f a - f b : v.adicCompletionIntegers K)).val
+        = (f a).val - (f b).val := fun a b => rfl
+    have hcauchy : CauchySeq (fun n => (f n).val : ℕ → v.adicCompletion K) := by
+      rw [(Valued.hasBasis_uniformity (v.adicCompletion K) ℤᵐ⁰).cauchySeq_iff]
+      rintro γ -
+      have hγ0 : (ValueGroup₀.embedding γ.val : ℤᵐ⁰) ≠ 0 := by
+        intro h0
+        exact γ.ne_zero (ValueGroup₀.embedding_strictMono.injective
+          (h0.trans (_root_.map_zero _).symm))
+      obtain ⟨k, hk⟩ := exists_ofAdd_natCast_lt hγ0
+      refine ⟨k, fun m hm n hn => ?_⟩
+      have key : ∀ a b : ℕ, k ≤ a → a ≤ b →
+          Valued.v ((f b).val - (f a).val) < ValueGroup₀.embedding γ.val := by
+        intro a b hka hab
+        have h1 : Valued.v ((f b).val - (f a).val) ≤ WithZero.exp (-(a : ℤ)) := by
+          rw [Valuation.map_sub_swap, ← hcoe a b]
+          exact hf' a b hab
+        have h2 : WithZero.exp (-(a : ℤ)) ≤ WithZero.exp (-(k : ℤ)) := by
+          rw [WithZero.exp_le_exp]
+          omega
+        exact lt_of_le_of_lt (h1.trans h2) hk
+      change ((Valued.v : Valuation (v.adicCompletion K) ℤᵐ⁰).restrict
+        ((f n).val - (f m).val)) < γ.val
+      rw [Valuation.restrict_lt_iff_lt_embedding]
+      rcases le_total m n with hmn | hnm
+      · exact key m n hm hmn
+      · rw [Valuation.map_sub_swap]
+        exact key n m hn hnm
+    obtain ⟨L₀, hL₀⟩ := cauchySeq_tendsto_of_complete hcauchy
+    have hbound : ∀ n : ℕ, Valued.v (L₀ - (f n).val) ≤ WithZero.exp (-(n : ℤ)) := by
+      intro n
+      have hclosed : IsClosed {y : v.adicCompletion K |
+          Valued.v (y - (f n).val) ≤ WithZero.exp (-(n : ℤ))} := by
+        have hpre : {y : v.adicCompletion K |
+            Valued.v (y - (f n).val) ≤ WithZero.exp (-(n : ℤ))}
+              = (fun y => y - (f n).val) ⁻¹'
+                {z : v.adicCompletion K | Valued.v z ≤ WithZero.exp (-(n : ℤ))} := rfl
+        rw [hpre]
+        exact (isClosed_setOf_valued_le K v _).preimage (continuous_sub_right ((f n).val))
+      have hev : ∀ᶠ m in Filter.atTop, (f m).val ∈ {y : v.adicCompletion K |
+          Valued.v (y - (f n).val) ≤ WithZero.exp (-(n : ℤ))} := by
+        refine Filter.eventually_atTop.mpr ⟨n, fun m hm => ?_⟩
+        have h := hf' n m hm
+        rw [hcoe n m] at h
+        rw [Set.mem_ofPred_eq, Valuation.map_sub_swap]
+        exact h
+      exact hclosed.mem_of_tendsto hL₀ hev
+    have hL₀mem : L₀ ∈ v.adicCompletionIntegers K := by
+      rw [mem_adicCompletionIntegers]
+      have h0 : Valued.v (L₀ - (f 0).val) ≤ (1 : ℤᵐ⁰) := by
+        have h := hbound 0
+        simpa using h
+      have h1 : Valued.v ((f 0).val) ≤ (1 : ℤᵐ⁰) := (f 0).2
+      have hmax : Valued.v ((L₀ - (f 0).val) + (f 0).val) ≤ (1 : ℤᵐ⁰) :=
+        Valuation.map_add_le _ h0 h1
+      have hL : (L₀ - (f 0).val) + (f 0).val = L₀ := by ring
+      rwa [hL] at hmax
+    refine ⟨⟨L₀, hL₀mem⟩, fun n => ?_⟩
+    have h : Valued.v ((f n).val - L₀) ≤ WithZero.exp (-(n : ℤ)) := by
+      rw [Valuation.map_sub_swap]
+      exact hbound n
+    simp only [Ideal.smul_eq_mul, Ideal.mul_top, SModEq.sub_mem,
+      adicCompletion.mem_completionIdeal_pow K v]
+    have hsub : ((f n - (⟨L₀, hL₀mem⟩ : v.adicCompletionIntegers K) :
+        v.adicCompletionIntegers K)).val = (f n).val - L₀ := rfl
+    rw [hsub]
+    exact h
+
+end Henselian
+
+end MazurTorsion
+end
+
+section
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain.HeightOneSpectrum IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsLocalRing WithZero \
+  P2MW.S_AlgebraicCurve_tateAgreement.WithZero MonoidWithZeroHom \
+  P2MW.S_AlgebraicCurve_tateAgreement.MonoidWithZeroHom"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.FiniteResidue Place.ord Divisor HasPrincipalDivisors Pic0 \
+  Place.FiniteResidue.finite IsCurveOver HasCanonicalLocalResidueKStar \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff \
+  kwHgfV352_exists_sub_mem_adicCompletionIntegers kwHgfV352_localResidueCompletion \
+  completionSection_nonempty_generic localResidue_eq_resStar"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal adicValuation adicValuation_ne_zero ord ord_zero ord_mul \
+  ord_unit_smul_zpow exists_unit_mul_zpow FiniteResidue.finite algebraMap_mem' toValuationSubring \
+  mk DCoordGenerates uniformizer ord_uniformizer uniformizer_ne_zero localResidue \
+  localResidue_eq_zero_of_ord_nonneg restrict adicCompletion adicCompletionIntegers \
+  uniformizerSubring coe_uniformizerSubring uniformizerSubring_mem_maximalIdeal uniformizer_mem \
+  poleSubmodule mem_poleSubmodule mem_poleSubmodule_iff_ord"
+p2m_open "AlgebraicCurve.Place AlgebraicCurve"
+
+section Henselian
+
+open P2MW.S_AlgebraicCurve_tateAgreement.MazurTorsion
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (V : Place K F)
+
+scoped instance kw_ffgc_isAdicComplete_placeAdicCompletionIntegers :
+    IsAdicComplete (maximalIdeal V.adicCompletionIntegers) V.adicCompletionIntegers :=
+  inferInstance
+
+end Henselian
+end Place
+end AlgebraicCurve
+end
+end
+
+section
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain WithZero \
+  P2MW.S_AlgebraicCurve_tateAgreement.WithZero Module P2MW.S_AlgebraicCurve_tateAgreement.Module \
+  IsLocalRing P2MW.S_AlgebraicCurve_tateAgreement.IsLocalRing Module.IsLocalRing"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace Lg37
+p2m_export "ModularCurve.Lg37" "lg37_completion lg37_residueHat lg37_residueHat_algebraMap \
+  Lg37CompletionSection"
+end Lg37
+end ModularCurve
+end
+end
+
+section
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsLocalRing Polynomial \
+  P2MW.S_AlgebraicCurve_tateAgreement.Polynomial"
+
+p2m_open_scoped "Polynomial P2MW.S_AlgebraicCurve_tateAgreement.Polynomial"
+
+namespace Mp72a103T2
+p2m_export "Mp72a103T2" "mp72a103_t2_taylor_coeff_eq_zero_of_depth"
+p2m_open "Mp72a103T2"
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_tateAgreement.RationalFunctionField AlgebraicCurve.RationalFunctionField \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.RationalFunctionField"
+p2m_open "ModularCurve.Lg37 P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.Lg37 \
+  ModularCurve.Mp72a102T3 P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.Mp72a102T3"
+p2m_open "Mp72a102T2 P2MW.S_AlgebraicCurve_tateAgreement.Mp72a102T2"
+
+section Calculus
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem mp72a103_t2_evalDepth_pow_uniformizer_mul_eq_zero (v : Place K F) :
+    ∀ (m : ℕ) (z : lg37_completion v),
+      AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) m
+        (algebraMap v.toValuationSubring (lg37_completion v)
+            v.uniformizerSubring ^ m * z) = 0 := by
+  intro m
+  induction m with
+  | zero => intro z; exact mp72a102_t3_evalₐ_zero_depth _ _
+  | succ m ih =>
+    intro z
+    have hkill := mp72a102_t3_evalₐ_succ_mul_eq_zero
+      (maximalIdeal v.toValuationSubring) v.uniformizerSubring_mem_maximalIdeal (ih z)
+    have hgoal : algebraMap v.toValuationSubring (lg37_completion v)
+          v.uniformizerSubring ^ (m + 1) * z
+        = algebraMap v.toValuationSubring (lg37_completion v) v.uniformizerSubring
+          * (algebraMap v.toValuationSubring (lg37_completion v)
+              v.uniformizerSubring ^ m * z) := by
+      rw [pow_succ', mul_assoc]
+    rw [hgoal]
+    exact hkill
+
+end Calculus
+end Mp72a103T2
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.GF24a9RRDx AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place IsDedekindDomain \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain"
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.FiniteResidue Place.ord Divisor HasPrincipalDivisors Pic0 \
+  Place.FiniteResidue.finite IsCurveOver HasCanonicalLocalResidueKStar \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff \
+  kwHgfV352_exists_sub_mem_adicCompletionIntegers kwHgfV352_localResidueCompletion \
+  completionSection_nonempty_generic localResidue_eq_resStar"
+p2m_open "AlgebraicCurve"
+
+section LocalResidueCompletion
+
+variable {K E : Type*} [Field K] [Field E] [Algebra K E]
+
+variable [HasCanonicalLocalResidueKStar K E]
+
+theorem kwHgfV352_localResidueCompletion_spec (v : Place K E) (xh : v.adicCompletion)
+    {x : E} (hx : algebraMap E v.adicCompletion x - xh ∈ v.adicCompletionIntegers) :
+    kwHgfV352_localResidueCompletion v xh = v.localResidue x := by
+  unfold kwHgfV352_localResidueCompletion
+  set x₀ := (kwHgfV352_exists_sub_mem_adicCompletionIntegers v xh).choose
+  have hx₀ := (kwHgfV352_exists_sub_mem_adicCompletionIntegers v xh).choose_spec
+  have heq : algebraMap E v.adicCompletion (x₀ - x)
+      = (algebraMap E v.adicCompletion x₀ - xh) - (algebraMap E v.adicCompletion x - xh) := by
+    rw [map_sub]; ring
+  have hdiff : algebraMap E v.adicCompletion (x₀ - x) ∈ v.adicCompletionIntegers :=
+    heq ▸ sub_mem hx₀ hx
+  have hov : x₀ - x ∈ v.toValuationSubring :=
+    (kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff v _).mp hdiff
+  have hzero : v.localResidue (x₀ - x) = 0 :=
+    v.localResidue_eq_zero_of_ord_nonneg (Or.inr (v.ord_nonneg_of_mem hov))
+  rw [map_sub, sub_eq_zero] at hzero
+  exact hzero
+
+theorem kwHgfV352_localResidueCompletion_algebraMap (v : Place K E) (x : E) :
+    kwHgfV352_localResidueCompletion v (algebraMap E v.adicCompletion x)
+      = v.localResidue x :=
+  kwHgfV352_localResidueCompletion_spec v _
+    (by rw [sub_self]; exact zero_mem _)
+
+theorem kwHgfV352_localResidueCompletion_eq_zero_of_mem_integers (v : Place K E)
+    {xh : v.adicCompletion} (hxh : xh ∈ v.adicCompletionIntegers) :
+    kwHgfV352_localResidueCompletion v xh = 0 := by
+  rw [kwHgfV352_localResidueCompletion_spec v xh (x := 0)
+    (by rw [_root_.map_zero, zero_sub]; exact neg_mem hxh)]
+  exact _root_.map_zero _
+
+theorem kwHgfV352_localResidueCompletion_add (v : Place K E)
+    (xh yh : v.adicCompletion) :
+    kwHgfV352_localResidueCompletion v (xh + yh)
+      = kwHgfV352_localResidueCompletion v xh
+        + kwHgfV352_localResidueCompletion v yh := by
+  obtain ⟨x, hx⟩ := kwHgfV352_exists_sub_mem_adicCompletionIntegers v xh
+  obtain ⟨y, hy⟩ := kwHgfV352_exists_sub_mem_adicCompletionIntegers v yh
+  have heq : algebraMap E v.adicCompletion (x + y) - (xh + yh)
+      = (algebraMap E v.adicCompletion x - xh) + (algebraMap E v.adicCompletion y - yh) := by
+    rw [map_add]; ring
+  rw [kwHgfV352_localResidueCompletion_spec v xh hx,
+    kwHgfV352_localResidueCompletion_spec v yh hy,
+    kwHgfV352_localResidueCompletion_spec v (xh + yh) (x := x + y)
+      (heq ▸ add_mem hx hy),
+    map_add]
+
+end LocalResidueCompletion
+end AlgebraicCurve
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateAgreement.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateAgreement.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateAgreement"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section TateProj
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem mem_adicIntegersKSubmod_iff (x : u.adicCompletion) :
+    x ∈ adicIntegersKSubmod u ↔ x ∈ u.adicCompletionIntegers := Iff.rfl
+
+theorem tateProj_mem_integers (x : u.adicCompletion) :
+    tateProj u x ∈ u.adicCompletionIntegers :=
+  (mem_adicIntegersKSubmod_iff u _).mp
+    (Submodule.coe_mem
+      (Submodule.projectionOnto (adicIntegersKSubmod u) _
+        (Classical.choose_spec (Submodule.exists_isCompl (adicIntegersKSubmod u))) x))
+
+theorem tateProj_of_mem {x : u.adicCompletion} (hx : x ∈ u.adicCompletionIntegers) :
+    tateProj u x = x := by
+  have h := Submodule.projectionOnto_apply_left
+    (Classical.choose_spec (Submodule.exists_isCompl (adicIntegersKSubmod u)))
+    (⟨x, (mem_adicIntegersKSubmod_iff u x).mpr hx⟩ : adicIntegersKSubmod u)
+  have hcoe := congrArg (Subtype.val (p := fun y => y ∈ adicIntegersKSubmod u)) h
+  exact hcoe
+
+theorem tateProj_idem : tateProj u ∘ₗ tateProj u = tateProj u := by
+  refine LinearMap.ext fun x => ?_
+  rw [LinearMap.comp_apply]
+  exact tateProj_of_mem u (tateProj_mem_integers u x)
+
+theorem range_tateProj : LinearMap.range (tateProj u) = adicIntegersKSubmod u := by
+  apply le_antisymm
+  · rintro x ⟨y, rfl⟩
+    exact tateProj_mem_integers u y
+  · intro x hx
+    exact ⟨x, tateProj_of_mem u hx⟩
+
+end TateProj
+end KwF4gRRTate
+end ModularCurve
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateAgreement.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateAgreement.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4gRRTate"
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain.HeightOneSpectrum IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsLocalRing"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateAgreement"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section PoleWindow
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+def poleWindowKSubmod (πh : u.adicCompletionIntegers) (M : ℕ) :
+    Submodule K u.adicCompletion where
+  carrier := {x | (πh : u.adicCompletion) ^ M * x ∈ u.adicCompletionIntegers}
+  add_mem' {a b} ha hb := by
+    simp only [Set.mem_ofPred_eq, mul_add] at ha hb ⊢; exact add_mem ha hb
+  zero_mem' := by simp only [Set.mem_ofPred_eq, mul_zero]; exact zero_mem _
+  smul_mem' c x hx := by
+    simp only [Set.mem_ofPred_eq] at hx ⊢
+    rw [Algebra.smul_def, IsScalarTower.algebraMap_apply K L u.adicCompletion, mul_left_comm]
+    exact mul_mem ((kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff u _).mpr
+      (u.algebraMap_mem' c)) hx
+
+theorem mem_poleWindowKSubmod_iff (πh : u.adicCompletionIntegers) (M : ℕ)
+    (x : u.adicCompletion) :
+    x ∈ poleWindowKSubmod u πh M ↔ (πh : u.adicCompletion) ^ M * x ∈ u.adicCompletionIntegers :=
+  Iff.rfl
+
+theorem adicIntegersKSubmod_le_poleWindowKSubmod (πh : u.adicCompletionIntegers) (M : ℕ) :
+    adicIntegersKSubmod u ≤ poleWindowKSubmod u πh M :=
+  fun _ hx => mul_mem (pow_mem πh.2 M) hx
+
+theorem kwF4gRRTate_clearPole (πh : u.adicCompletionIntegers) (hπh : Irreducible πh)
+    (fh : u.adicCompletion) :
+    ∃ M : ℕ, (πh : u.adicCompletion) ^ M * fh ∈ u.adicCompletionIntegers := by
+  obtain ⟨a, b, hb, hfh⟩ := IsFractionRing.div_surjective
+    (A := u.adicCompletionIntegers) (K := u.adicCompletion) fh
+  have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb
+  obtain ⟨M, ub, hbeq⟩ := IsDiscreteValuationRing.eq_unit_mul_pow_irreducible hb0 hπh
+  refine ⟨M, ?_⟩
+  have hcoe : ∀ x : u.adicCompletionIntegers,
+      (x : u.adicCompletion) = algebraMap _ u.adicCompletion x := fun _ => rfl
+  have hbK0 : (b : u.adicCompletion) ≠ 0 := by
+    rw [hcoe]; exact (map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr hb0
+  have hbfh : (b : u.adicCompletion) * fh = (a : u.adicCompletion) := by
+    rw [← hfh, hcoe b, hcoe a, mul_div_cancel₀ _ (hcoe b ▸ hbK0)]
+  have hπheq : ((ub⁻¹ : u.adicCompletionIntegersˣ) : u.adicCompletionIntegers) * b = πh ^ M := by
+    rw [hbeq, ← mul_assoc, ← Units.val_mul, inv_mul_cancel, Units.val_one, one_mul]
+  have hπheqK : ((((ub⁻¹ : u.adicCompletionIntegersˣ) : u.adicCompletionIntegers)
+        : u.adicCompletion)) * (b : u.adicCompletion)
+      = (πh : u.adicCompletion) ^ M := by
+    have := congrArg (algebraMap u.adicCompletionIntegers u.adicCompletion) hπheq
+    simp only [map_mul, map_pow] at this
+    exact this
+  rw [← hπheqK, mul_assoc, hbfh]
+  exact mul_mem (Subtype.coe_prop _) a.2
+
+variable (K L) in
+def KwF4gRRTatePoleWindowFinite : Prop :=
+  ∀ (u : Place K L) [u.FiniteResidue] (πh : u.adicCompletionIntegers) (_ : Irreducible πh)
+    (M : ℕ),
+    FiniteDimensional K
+      (poleWindowKSubmod u πh M ⧸
+        (adicIntegersKSubmod u).comap (poleWindowKSubmod u πh M).subtype)
+
+end PoleWindow
+end KwF4gRRTate
+end ModularCurve
+end
+end
+
+section
+
+p2m_open_scoped "WithZero P2MW.S_AlgebraicCurve_tateAgreement.WithZero Multiplicative \
+  P2MW.S_AlgebraicCurve_tateAgreement.Multiplicative Topology \
+  P2MW.S_AlgebraicCurve_tateAgreement.Topology"
+p2m_open "Filter P2MW.S_AlgebraicCurve_tateAgreement.Filter"
+
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "HeightOneSpectrum.ext mk HeightOneSpectrum"
+namespace HeightOneSpectrum
+p2m_export "IsDedekindDomain.HeightOneSpectrum" "valuation_of_algebraMap \
+  intValuation_le_pow_iff_mem isMaximal mk mem_adicCompletionIntegers comap \
+  valuedAdicCompletion_eq_valuation' adicCompletion valuation adicCompletionIntegers \
+  valuedAdicCompletion_surjective mem_integers_of_valuation_le_one denseRange_algebraMap \
+  intValuation exists_ofAdd_natCast_lt completionIdeal \
+  adicCompletion.maximalIdeal_eq_span_uniformizer adicCompletion.mem_completionIdeal_pow"
+p2m_open "IsDedekindDomain.HeightOneSpectrum IsDedekindDomain"
+
+variable {A : Type*} (K : Type*) [CommRing A] [Field K] [Algebra A K] [IsFractionRing A K]
+    [IsDedekindDomain A] (v : HeightOneSpectrum A)
+
+namespace adicCompletion
+p2m_export "IsDedekindDomain.HeightOneSpectrum.adicCompletion" "uniformizer_ne_zero \
+  maximalIdeal_eq_span_uniformizer mem_completionIdeal_pow"
+p2m_open "IsDedekindDomain.HeightOneSpectrum.adicCompletion"
+
+local notation "vK" => (Valued.v : Valuation (v.adicCompletion K) ℤᵐ⁰)
+
+theorem isOpen_setOf_valued_le {γ : ℤᵐ⁰} (hγ : γ ≠ 0) :
+    IsOpen {y : v.adicCompletion K | Valued.v y ≤ γ} := by
+  obtain ⟨z, hz⟩ := valuedAdicCompletion_surjective K v γ
+  have hz0 : vK z ≠ 0 := by rw [hz]; exact hγ
+  have hr0 : (vK).restrict z ≠ 0 := fun h =>
+    hz0 ((Valuation.restrict_eq_zero_iff vK).mp h)
+  have hset : {y : v.adicCompletion K | Valued.v y ≤ γ}
+      = {y : v.adicCompletion K | (vK).restrict y ≤ (vK).restrict z} := by
+    ext y
+    simp only [Set.mem_ofPred_eq, Valuation.restrict_le_iff, hz]
+  rw [hset]
+  exact Valued.isOpen_closedBall _ hr0
+
+end adicCompletion
+end HeightOneSpectrum
+end IsDedekindDomain
+end
+
+section
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain.HeightOneSpectrum IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsLocalRing WithZero \
+  P2MW.S_AlgebraicCurve_tateAgreement.WithZero"
+p2m_open "ModularCurve.Lg37 P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.Lg37 AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwF4R1V410a
+p2m_open "ModularCurve"
+
+theorem kwF4R1V410a_factorPow_evalₐ {R : Type*} [CommRing R] {I : Ideal R}
+    {m n : ℕ} (hle : m ≤ n) (z : AdicCompletion I R) :
+    Ideal.Quotient.factorPow I hle (AdicCompletion.evalₐ I n z)
+      = AdicCompletion.evalₐ I m z := by
+  rw [← AdicCompletion.factor_eval_eq_evalₐ I z (n := n) (le_of_eq (Ideal.mul_top _)),
+    ← AdicCompletion.factor_eval_eq_evalₐ I z (n := m) (le_of_eq (Ideal.mul_top _)),
+    AdicCompletion.eval_apply, AdicCompletion.eval_apply, ← z.prop hle]
+  obtain ⟨x, hx⟩ := Submodule.Quotient.mk_surjective _ (z.val n)
+  rw [← hx]; rfl
+
+scoped instance kwF4R1V410a_subsingletonHeightOneSpectrumDVR
+    {O : Type*} [CommRing O] [IsDomain O] [IsDiscreteValuationRing O] :
+    Subsingleton (HeightOneSpectrum O) :=
+  ⟨fun a b => IsDedekindDomain.HeightOneSpectrum.ext
+    (((IsDiscreteValuationRing.iff_pid_with_one_nonzero_prime O).mp
+      inferInstance).2.unique ⟨a.3, a.2⟩ ⟨b.3, b.2⟩)⟩
+
+section Bridge
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+local notation "O_w" => w.toValuationSubring
+local notation "𝔪_w" => IsLocalRing.maximalIdeal w.toValuationSubring
+local notation "O_W" => w.adicCompletionIntegers
+local notation "𝔪_W" => w.heightOneSpectrum.completionIdeal F
+
+theorem kwF4R1V410a_algebraMap_mem_completionIdeal_pow_iff (n : ℕ) (x : O_w) :
+    algebraMap (O_w) (O_W) x ∈ (𝔪_W) ^ n ↔ x ∈ (𝔪_w) ^ n := by
+  have hval : Valued.v (algebraMap (O_w) (O_W) x).val
+      = w.heightOneSpectrum.intValuation x := by
+    have h1 : (algebraMap (O_w) (O_W) x).val
+        = ((algebraMap (O_w) F x : F) : w.adicCompletion) := rfl
+    rw [h1, valuedAdicCompletion_eq_valuation' (K := F) w.heightOneSpectrum,
+      valuation_of_algebraMap]
+  rw [adicCompletion.mem_completionIdeal_pow, hval, ← WithZero.exp_eq_coe_ofAdd,
+    intValuation_le_pow_iff_mem, w.heightOneSpectrum_asIdeal]
+
+theorem kwF4R1V410a_exists_sub_mem_completionIdeal_pow (n : ℕ) (y : O_W) :
+    ∃ x : O_w, y - algebraMap (O_w) (O_W) x ∈ (𝔪_W) ^ n := by
+  have hball_open : IsOpen {z : w.adicCompletion |
+      Valued.v (z - y.val) ≤ WithZero.exp (-(n : ℤ))} :=
+    (adicCompletion.isOpen_setOf_valued_le F w.heightOneSpectrum
+      WithZero.exp_ne_zero).preimage (continuous_sub_right y.val)
+  have hy_mem : y.val ∈ {z : w.adicCompletion |
+      Valued.v (z - y.val) ≤ WithZero.exp (-(n : ℤ))} := by
+    simp only [Set.mem_ofPred_eq, sub_self, _root_.map_zero]; exact zero_le
+  have hmeet := mem_closure_iff.mp
+    ((denseRange_algebraMap F w.heightOneSpectrum) y.val) _ hball_open hy_mem
+  have hexists : ∃ z : F, Valued.v (algebraMap F w.adicCompletion z - y.val)
+      ≤ WithZero.exp (-(n : ℤ)) := by
+    rcases hmeet with ⟨z₀, hz₀_ball, z, hz_eq⟩
+    exact ⟨z, hz_eq ▸ hz₀_ball⟩
+  obtain ⟨z, hz⟩ := hexists
+  rw [show algebraMap F w.adicCompletion z = ((z : F) : w.adicCompletion) from rfl] at hz
+  have hz_val_le : w.heightOneSpectrum.valuation F z ≤ 1 := by
+    have hzhat : Valued.v ((z : w.adicCompletion)) ≤ (1 : ℤᵐ⁰) := by
+      calc Valued.v ((z : w.adicCompletion))
+          = Valued.v (((z : w.adicCompletion) - y.val) + y.val) := by ring_nf
+        _ ≤ max (Valued.v ((z : w.adicCompletion) - y.val)) (Valued.v y.val) :=
+            Valuation.map_add _ _ _
+        _ ≤ (1 : ℤᵐ⁰) := max_le
+            (hz.trans (by rw [← WithZero.exp_zero]; exact WithZero.exp_le_exp.mpr (by omega)))
+            y.2
+    rwa [valuedAdicCompletion_eq_valuation'] at hzhat
+  have hz_mem : z ∈ (O_w : ValuationSubring F) := by
+    obtain ⟨r, hr⟩ := mem_integers_of_valuation_le_one F z
+      (fun v' => by
+        obtain rfl : v' = w.heightOneSpectrum := Subsingleton.elim _ _
+        exact hz_val_le)
+    exact hr ▸ r.2
+  refine ⟨⟨z, hz_mem⟩, ?_⟩
+  rw [adicCompletion.mem_completionIdeal_pow, ← WithZero.exp_eq_coe_ofAdd]
+  have hsub : (y - algebraMap (O_w) (O_W) ⟨z, hz_mem⟩ : O_W).val
+      = y.val - ((z : F) : w.adicCompletion) := rfl
+  rw [hsub, Valuation.map_sub_swap]
+  exact hz
+
+def kwF4R1V410a_quotientEquiv (n : ℕ) :
+    (O_w) ⧸ (𝔪_w) ^ n ≃+* (O_W) ⧸ (𝔪_W) ^ n :=
+  RingEquiv.ofBijective
+    (Ideal.quotientMap _ (algebraMap (O_w) (O_W))
+      (fun x hx => (kwF4R1V410a_algebraMap_mem_completionIdeal_pow_iff w n x).mpr hx))
+    ⟨Ideal.quotientMap_injective'
+      (fun x hx => (kwF4R1V410a_algebraMap_mem_completionIdeal_pow_iff w n x).mp
+        (Ideal.mem_comap.mp hx)),
+    fun y => by
+      obtain ⟨y', rfl⟩ := Ideal.Quotient.mk_surjective y
+      obtain ⟨x, hx⟩ := kwF4R1V410a_exists_sub_mem_completionIdeal_pow w n y'
+      refine ⟨Ideal.Quotient.mk _ x, ?_⟩
+      rw [Ideal.quotientMap_mk]
+      exact (Ideal.Quotient.mk_eq_mk_iff_sub_mem _ _).mpr (by
+        rw [← neg_sub, neg_mem_iff]; exact hx)⟩
+
+theorem kwF4R1V410a_quotientEquiv_mk (n : ℕ) (x : O_w) :
+    kwF4R1V410a_quotientEquiv w n (Ideal.Quotient.mk _ x)
+      = Ideal.Quotient.mk _ (algebraMap (O_w) (O_W) x) := rfl
+
+theorem kwF4R1V410a_quotientEquiv_factorPow {m n : ℕ} (hle : m ≤ n)
+    (z : (O_w) ⧸ (𝔪_w) ^ n) :
+    Ideal.Quotient.factorPow (𝔪_W) hle (kwF4R1V410a_quotientEquiv w n z)
+      = kwF4R1V410a_quotientEquiv w m (Ideal.Quotient.factorPow (𝔪_w) hle z) := by
+  obtain ⟨x, rfl⟩ := Ideal.Quotient.mk_surjective z
+  rw [kwF4R1V410a_quotientEquiv_mk, Ideal.Quotient.factor_mk, Ideal.Quotient.factor_mk,
+    kwF4R1V410a_quotientEquiv_mk]
+
+def kwF4R1V410a_forwardFamily (n : ℕ) :
+    lg37_completion w →+* (O_W) ⧸ (𝔪_W) ^ n :=
+  RingHom.comp ((kwF4R1V410a_quotientEquiv w n).toRingHom)
+    ((AdicCompletion.evalₐ (𝔪_w) n).toRingHom)
+
+theorem kwF4R1V410a_forwardFamily_compat {m n : ℕ} (hle : m ≤ n) :
+    (Ideal.Quotient.factorPow (𝔪_W) hle).comp (kwF4R1V410a_forwardFamily w n)
+      = kwF4R1V410a_forwardFamily w m := by
+  refine RingHom.ext fun z => ?_
+  change Ideal.Quotient.factorPow (𝔪_W) hle
+      (kwF4R1V410a_quotientEquiv w n (AdicCompletion.evalₐ (𝔪_w) n z))
+    = kwF4R1V410a_quotientEquiv w m (AdicCompletion.evalₐ (𝔪_w) m z)
+  rw [kwF4R1V410a_quotientEquiv_factorPow w hle, kwF4R1V410a_factorPow_evalₐ hle z]
+
+def kwF4R1V410a_forward : lg37_completion w →+* (O_W) :=
+  haveI := kw_ffgc_isAdicComplete_placeAdicCompletionIntegers w
+  IsAdicComplete.liftRingHom (𝔪_W) (kwF4R1V410a_forwardFamily w)
+    (kwF4R1V410a_forwardFamily_compat w)
+
+theorem kwF4R1V410a_mk_forward (n : ℕ) (z : lg37_completion w) :
+    Ideal.Quotient.mk ((𝔪_W) ^ n) (kwF4R1V410a_forward w z)
+      = kwF4R1V410a_quotientEquiv w n (AdicCompletion.evalₐ (𝔪_w) n z) := by
+  have := kw_ffgc_isAdicComplete_placeAdicCompletionIntegers w
+  exact IsAdicComplete.mk_liftRingHom (𝔪_W) (kwF4R1V410a_forwardFamily w)
+    (kwF4R1V410a_forwardFamily_compat w) n z
+
+def kwF4R1V410a_backwardFamily (n : ℕ) : (O_W) →+* (O_w) ⧸ (𝔪_w) ^ n :=
+  RingHom.comp ((kwF4R1V410a_quotientEquiv w n).symm.toRingHom)
+    (Ideal.Quotient.mk ((𝔪_W) ^ n))
+
+theorem kwF4R1V410a_backwardFamily_compat {m n : ℕ} (hle : m ≤ n) :
+    (Ideal.Quotient.factorPow (𝔪_w) hle).comp (kwF4R1V410a_backwardFamily w n)
+      = kwF4R1V410a_backwardFamily w m := by
+  refine RingHom.ext fun y => ?_
+  change Ideal.Quotient.factorPow (𝔪_w) hle
+      ((kwF4R1V410a_quotientEquiv w n).symm (Ideal.Quotient.mk ((𝔪_W) ^ n) y))
+    = (kwF4R1V410a_quotientEquiv w m).symm (Ideal.Quotient.mk ((𝔪_W) ^ m) y)
+  apply (kwF4R1V410a_quotientEquiv w m).injective
+  rw [RingEquiv.apply_symm_apply, ← kwF4R1V410a_quotientEquiv_factorPow w hle,
+    RingEquiv.apply_symm_apply, Ideal.Quotient.factor_mk]
+
+def kwF4R1V410a_backward : (O_W) →+* lg37_completion w :=
+  AdicCompletion.liftRingHom (𝔪_w) (kwF4R1V410a_backwardFamily w)
+    (kwF4R1V410a_backwardFamily_compat w)
+
+theorem kwF4R1V410a_evalₐ_backward (n : ℕ) (y : O_W) :
+    AdicCompletion.evalₐ (𝔪_w) n (kwF4R1V410a_backward w y)
+      = (kwF4R1V410a_quotientEquiv w n).symm (Ideal.Quotient.mk ((𝔪_W) ^ n) y) :=
+  AdicCompletion.evalₐ_liftRingHom (𝔪_w) (kwF4R1V410a_backwardFamily w)
+    (kwF4R1V410a_backwardFamily_compat w) n y
+
+theorem kwF4R1V410a_forward_backward :
+    (kwF4R1V410a_forward w).comp (kwF4R1V410a_backward w) = RingHom.id _ := by
+  have := kw_ffgc_isAdicComplete_placeAdicCompletionIntegers w
+  have hfun : (fun y => kwF4R1V410a_forward w (kwF4R1V410a_backward w y))
+      = _root_.id := IsHausdorff.funext' (𝔪_W) (fun n y => by
+    rw [kwF4R1V410a_mk_forward, kwF4R1V410a_evalₐ_backward,
+      RingEquiv.apply_symm_apply, _root_.id])
+  exact RingHom.ext (fun y => congrFun hfun y)
+
+theorem kwF4R1V410a_backward_forward :
+    (kwF4R1V410a_backward w).comp (kwF4R1V410a_forward w) = RingHom.id _ := by
+  refine RingHom.ext (fun z => AdicCompletion.ext_evalₐ (fun n => ?_))
+  rw [RingHom.comp_apply, kwF4R1V410a_evalₐ_backward, kwF4R1V410a_mk_forward,
+    RingEquiv.symm_apply_apply, RingHom.id_apply]
+
+def kwF4R1V410a_ringEquiv : lg37_completion w ≃+* (O_W) :=
+  RingEquiv.ofRingHom (kwF4R1V410a_forward w) (kwF4R1V410a_backward w)
+    (kwF4R1V410a_forward_backward w) (kwF4R1V410a_backward_forward w)
+
+theorem kwF4R1V410a_ringEquiv_apply (z : lg37_completion w) :
+    kwF4R1V410a_ringEquiv w z = kwF4R1V410a_forward w z := rfl
+
+theorem kwF4R1V410a_ringEquiv_of (x : O_w) :
+    kwF4R1V410a_ringEquiv w (algebraMap (O_w) (lg37_completion w) x)
+      = algebraMap (O_w) (O_W) x := by
+  have := kw_ffgc_isAdicComplete_placeAdicCompletionIntegers w
+  have hfun : (fun x => kwF4R1V410a_ringEquiv w
+        (algebraMap (O_w) (lg37_completion w) x))
+      = algebraMap (O_w) (O_W) := IsHausdorff.funext' (𝔪_W) (fun n x => by
+    rw [kwF4R1V410a_ringEquiv_apply, kwF4R1V410a_mk_forward,
+      show algebraMap (O_w) (lg37_completion w) x
+        = AdicCompletion.of (𝔪_w) (O_w) x from rfl,
+      AdicCompletion.evalₐ_of, kwF4R1V410a_quotientEquiv_mk])
+  exact congrFun hfun x
+
+end Bridge
+end KwF4R1V410a
+end ModularCurve
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateAgreement.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateAgreement.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4R1V410a"
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain.HeightOneSpectrum IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsLocalRing"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateAgreement"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section PoleWindowShift
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem coe_smul_K (c : K) (x : u.adicCompletionIntegers) :
+    ((c • x : u.adicCompletionIntegers) : u.adicCompletion) = c • (x : u.adicCompletion) := by
+  rw [Algebra.smul_def, Algebra.smul_def]
+  rfl
+
+def poleWindowShift (πh : u.adicCompletionIntegers) (M : ℕ) :
+    poleWindowKSubmod u πh M →ₗ[K] u.adicCompletionIntegers where
+  toFun x := ⟨(πh : u.adicCompletion) ^ M * (x : u.adicCompletion), x.2⟩
+  map_add' x y := by apply Subtype.ext; push_cast; ring
+  map_smul' c x := by
+    apply Subtype.ext
+    rw [coe_smul_K]
+    change (πh : u.adicCompletion) ^ M * (c • (x : u.adicCompletion))
+        = c • ((πh : u.adicCompletion) ^ M * (x : u.adicCompletion))
+    rw [mul_smul_comm]
+
+theorem poleWindowShift_injective (πh : u.adicCompletionIntegers) (hπh : Irreducible πh)
+    (M : ℕ) : Function.Injective (poleWindowShift u πh M) := by
+  rw [← LinearMap.ker_eq_bot, eq_bot_iff]
+  intro x hx
+  rw [LinearMap.mem_ker] at hx
+  have hπhM0 : (πh : u.adicCompletion) ^ M ≠ 0 := by
+    refine pow_ne_zero M ?_
+    intro hz
+    exact hπh.ne_zero (Subtype.ext hz)
+  have hx0 : (x : u.adicCompletion) = 0 := by
+    have := congrArg Subtype.val hx
+    push_cast at this
+    exact (mul_eq_zero.mp this).resolve_left hπhM0
+  exact Subtype.ext hx0
+
+theorem poleWindowShift_surjective (πh : u.adicCompletionIntegers) (hπh : Irreducible πh)
+    (M : ℕ) : Function.Surjective (poleWindowShift u πh M) := by
+  intro y
+  have hπhM0 : (πh : u.adicCompletion) ^ M ≠ 0 := by
+    refine pow_ne_zero M ?_
+    intro hz; exact hπh.ne_zero (Subtype.ext hz)
+  refine ⟨⟨(y : u.adicCompletion) / (πh : u.adicCompletion) ^ M, ?_⟩, ?_⟩
+  · rw [mem_poleWindowKSubmod_iff, mul_div_cancel₀ _ hπhM0]; exact y.2
+  · apply Subtype.ext
+    change (πh : u.adicCompletion) ^ M * ((y : u.adicCompletion) / (πh : u.adicCompletion) ^ M)
+        = (y : u.adicCompletion)
+    rw [mul_div_cancel₀ _ hπhM0]
+
+def poleWindowShiftEquiv (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) (M : ℕ) :
+    poleWindowKSubmod u πh M ≃ₗ[K] u.adicCompletionIntegers :=
+  LinearEquiv.ofBijective (poleWindowShift u πh M)
+    ⟨poleWindowShift_injective u πh hπh M, poleWindowShift_surjective u πh hπh M⟩
+
+def piPowKSubmod (πh : u.adicCompletionIntegers) (M : ℕ) :
+    Submodule K u.adicCompletionIntegers where
+  carrier := {y | ∃ x : u.adicCompletionIntegers, y = πh ^ M * x}
+  add_mem' := by rintro a b ⟨xa, rfl⟩ ⟨xb, rfl⟩; exact ⟨xa + xb, by ring⟩
+  zero_mem' := ⟨0, by ring⟩
+  smul_mem' c y := by
+    rintro ⟨x, rfl⟩
+    exact ⟨c • x, by rw [Algebra.smul_def, Algebra.smul_def, mul_left_comm]⟩
+
+theorem poleWindowShift_image_integers (πh : u.adicCompletionIntegers) (M : ℕ) :
+    Submodule.map (poleWindowShift u πh M)
+        ((adicIntegersKSubmod u).comap (poleWindowKSubmod u πh M).subtype)
+      = piPowKSubmod u πh M := by
+  ext y
+  constructor
+  · rintro ⟨⟨x, hxP⟩, hxA, rfl⟩
+    refine ⟨⟨(x : u.adicCompletion), hxA⟩, ?_⟩
+    apply Subtype.ext; push_cast; rfl
+  · rintro ⟨x, rfl⟩
+    refine ⟨⟨(x : u.adicCompletion),
+      adicIntegersKSubmod_le_poleWindowKSubmod u πh M x.2⟩, x.2, ?_⟩
+    apply Subtype.ext; push_cast; rfl
+
+variable (K L) in
+def KwF4gRRTateDVRQuotPowKFinite : Prop :=
+  ∀ (u : Place K L) [u.FiniteResidue] (πh : u.adicCompletionIntegers) (_ : Irreducible πh)
+    (M : ℕ),
+    FiniteDimensional K (u.adicCompletionIntegers ⧸ piPowKSubmod u πh M)
+
+theorem kwF4gRRTate_poleWindowFinite_of_DVRQuotPowKFinite
+    (hDVR : KwF4gRRTateDVRQuotPowKFinite K L) :
+    KwF4gRRTatePoleWindowFinite K L := by
+  intro u _ πh hπh M
+  have := hDVR u πh hπh M
+  have e := (poleWindowShiftEquiv u πh hπh M).toLinearMap
+  let e' := Submodule.Quotient.equiv
+    ((adicIntegersKSubmod u).comap (poleWindowKSubmod u πh M).subtype)
+    (piPowKSubmod u πh M)
+    (poleWindowShiftEquiv u πh hπh M)
+    (poleWindowShift_image_integers u πh M)
+  exact FiniteDimensional.of_injective e'.toLinearMap e'.injective
+
+end PoleWindowShift
+end KwF4gRRTate
+end ModularCurve
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateAgreement.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateAgreement.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateAgreement"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section AgreementReduce
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem principalPart_mul_zero_of_mem_integers
+    {gh : u.adicCompletion} (hgh : gh ∈ u.adicCompletionIntegers)
+    {a : u.adicCompletion} (ha : a ∈ u.adicCompletionIntegers) :
+    gh * a - tateProj u (gh * a) = 0 := by
+  rw [tateProj_of_mem u (mul_mem hgh ha), sub_self]
+
+theorem tateCommRestrict_single_term
+    {gh : u.adicCompletion} (hgh : gh ∈ u.adicCompletionIntegers)
+    (fh : u.adicCompletion) (a : LinearMap.range (tateProj u)) :
+    (tateCommRestrict (tateProj u) (lmulK u fh) (lmulK u gh) a : u.adicCompletion)
+      = tateProj u (gh * (fh * (a : u.adicCompletion)
+          - tateProj u (fh * (a : u.adicCompletion)))) := by
+  have haInt : (a : u.adicCompletion) ∈ u.adicCompletionIntegers :=
+    (range_tateProj u ▸ a.2 : (a : u.adicCompletion) ∈ adicIntegersKSubmod u)
+  have hcomm : lmulK u fh ∘ₗ lmulK u gh = lmulK u gh ∘ₗ lmulK u fh := by
+    refine LinearMap.ext fun x => ?_; change fh * (gh * x) = gh * (fh * x); ring
+  rw [tateCommRestrict_apply, tateComm_eq_of_commute hcomm]
+  change tateProj u (gh * (fh * ↑a - tateProj u (fh * ↑a)))
+      - tateProj u (fh * (gh * ↑a - tateProj u (gh * ↑a)))
+    = tateProj u (gh * (fh * ↑a - tateProj u (fh * ↑a)))
+  rw [principalPart_mul_zero_of_mem_integers u hgh haInt, mul_zero, _root_.map_zero, sub_zero]
+
+end AgreementReduce
+end KwF4gRRTate
+end ModularCurve
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateAgreement.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateAgreement.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateAgreement"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section FinrankTraceCyclicity
+
+variable {K M N : Type*} [Field K] [AddCommGroup M] [Module K M] [AddCommGroup N] [Module K N]
+
+theorem range_comp_map_left (f : M →ₗ[K] N) (g : N →ₗ[K] M) :
+    ∀ x ∈ LinearMap.range (g ∘ₗ f), f x ∈ LinearMap.range (f ∘ₗ g) := by
+  rintro x ⟨y, rfl⟩
+  exact ⟨f y, rfl⟩
+
+theorem finrankTrace_comp_comm (f : M →ₗ[K] N) (g : N →ₗ[K] M)
+    [FiniteDimensional K (LinearMap.range (g ∘ₗ f))]
+    [FiniteDimensional K (LinearMap.range (f ∘ₗ g))] :
+    finrankTrace (g ∘ₗ f) = finrankTrace (f ∘ₗ g) := by
+  set W := LinearMap.range (g ∘ₗ f)
+  set W' := LinearMap.range (f ∘ₗ g)
+  let fR : W →ₗ[K] W' := f.restrict (range_comp_map_left f g)
+  let gR : W' →ₗ[K] W := g.restrict (range_comp_map_left g f)
+  have hgf : (g ∘ₗ f).restrict (fun x _ => LinearMap.mem_range_self _ x) = gR ∘ₗ fR := by
+    apply LinearMap.ext; intro x; apply Subtype.ext; rfl
+  have hfg : (f ∘ₗ g).restrict (fun x _ => LinearMap.mem_range_self _ x) = fR ∘ₗ gR := by
+    apply LinearMap.ext; intro x; apply Subtype.ext; rfl
+  unfold finrankTrace
+  rw [hgf, hfg, LinearMap.trace_comp_comm']
+
+end FinrankTraceCyclicity
+end KwF4gRRTate
+end ModularCurve
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateAgreement.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateAgreement.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateAgreement"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section DeltaLemmas
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+variable (pA pA' : V →ₗ[K] V)
+
+structure SameRangeIdemProjectors : Prop where
+  idem_pA : ∀ x, pA (pA x) = pA x
+  idem_pA' : ∀ x, pA' (pA' x) = pA' x
+  range_eq : LinearMap.range pA = LinearMap.range pA'
+
+variable {pA pA'}
+
+theorem pA_fixes_range (h : SameRangeIdemProjectors pA pA') :
+    ∀ x ∈ LinearMap.range pA, pA x = x := by
+  rintro x ⟨y, rfl⟩; exact h.idem_pA y
+
+theorem pA'_fixes_range (h : SameRangeIdemProjectors pA pA') :
+    ∀ x ∈ LinearMap.range pA, pA' x = x := by
+  rintro x hx
+  rw [h.range_eq] at hx
+  obtain ⟨y, rfl⟩ := hx
+  exact h.idem_pA' y
+
+theorem delta_zero_on_range (h : SameRangeIdemProjectors pA pA')
+    {x : V} (hx : x ∈ LinearMap.range pA) :
+    (pA - pA') x = 0 := by
+  simp only [LinearMap.sub_apply, pA_fixes_range h x hx, pA'_fixes_range h x hx, sub_self]
+
+theorem delta_range_subset (h : SameRangeIdemProjectors pA pA')
+    (x : V) : (pA - pA') x ∈ LinearMap.range pA := by
+  simp only [LinearMap.sub_apply]
+  refine sub_mem (LinearMap.mem_range_self pA x) ?_
+  rw [h.range_eq]; exact LinearMap.mem_range_self pA' x
+
+end DeltaLemmas
+
+section Mint
+
+variable (K L : Type*) [Field K] [Field L] [Algebra K L]
+
+def KwF4gRRTateProjectorIndep : Prop :=
+  ∀ (u : Place K L) (pA' : u.adicCompletion →ₗ[K] u.adicCompletion),
+    SameRangeIdemProjectors (tateProj u) pA' →
+    ∀ (fh gh : u.adicCompletion), gh ∈ u.adicCompletionIntegers →
+    ∀ [FiniteDimensional K (LinearMap.range
+        (tateCommRestrict (tateProj u) (lmulK u fh) (lmulK u gh)))]
+      [FiniteDimensional K (LinearMap.range
+        (tateCommRestrict pA' (lmulK u fh) (lmulK u gh)))],
+    tateCommTrace (tateProj u) (lmulK u fh) (lmulK u gh)
+      = tateCommTrace pA' (lmulK u fh) (lmulK u gh)
+
+end Mint
+
+section DiffComputation
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable (pA' : u.adicCompletion →ₗ[K] u.adicCompletion)
+
+theorem tateCommRestrict_diff
+    (h : SameRangeIdemProjectors (tateProj u) pA')
+    {gh : u.adicCompletion} (hgh : gh ∈ u.adicCompletionIntegers)
+    (fh : u.adicCompletion) (a : LinearMap.range (tateProj u)) :
+    (tateCommRestrict (tateProj u) (lmulK u fh) (lmulK u gh) a : u.adicCompletion)
+      - tateComm pA' (lmulK u fh) (lmulK u gh) (a : u.adicCompletion)
+      = (tateProj u - pA') (gh * fh * (a : u.adicCompletion))
+        - gh * (tateProj u - pA') (fh * (a : u.adicCompletion)) := by
+  have haO : (a : u.adicCompletion) ∈ u.adicCompletionIntegers :=
+    (range_tateProj u ▸ a.2 : (a : u.adicCompletion) ∈ adicIntegersKSubmod u)
+  have hmemO_of_rangeP : ∀ {x : u.adicCompletion},
+      x ∈ LinearMap.range (tateProj u) → x ∈ u.adicCompletionIntegers := fun {x} hx =>
+    (range_tateProj u ▸ hx : x ∈ adicIntegersKSubmod u)
+  have hmemP_of_O : ∀ {x : u.adicCompletion},
+      x ∈ u.adicCompletionIntegers → x ∈ LinearMap.range (tateProj u) := fun {x} hx => by
+    rw [range_tateProj u]; exact hx
+  rw [tateCommRestrict_single_term u hgh fh a]
+  have hcomm : lmulK u fh ∘ₗ lmulK u gh = lmulK u gh ∘ₗ lmulK u fh := by
+    refine LinearMap.ext fun x => ?_; change fh * (gh * x) = gh * (fh * x); ring
+  have hghaP : gh * (a : u.adicCompletion) ∈ LinearMap.range (tateProj u) :=
+    hmemP_of_O (mul_mem hgh haO)
+  have hpA'_gha : pA' (gh * (a : u.adicCompletion)) = gh * (a : u.adicCompletion) :=
+    pA'_fixes_range h _ hghaP
+  have hpA'_single :
+      tateComm pA' (lmulK u fh) (lmulK u gh) (a : u.adicCompletion)
+      = pA' (gh * (fh * (a : u.adicCompletion)
+          - pA' (fh * (a : u.adicCompletion)))) := by
+    rw [tateComm_eq_of_commute hcomm]
+    change pA' (gh * (fh * ↑a - pA' (fh * ↑a)))
+        - pA' (fh * (gh * ↑a - pA' (gh * ↑a)))
+      = pA' (gh * (fh * ↑a - pA' (fh * ↑a)))
+    rw [hpA'_gha, sub_self, mul_zero, _root_.map_zero, sub_zero]
+  rw [hpA'_single]
+  set fa := fh * (a : u.adicCompletion)
+  have hPfaO : tateProj u fa ∈ u.adicCompletionIntegers :=
+    hmemO_of_rangeP (LinearMap.mem_range_self (tateProj u) fa)
+  have hPfaO' : pA' fa ∈ u.adicCompletionIntegers :=
+    hmemO_of_rangeP (h.range_eq ▸ LinearMap.mem_range_self pA' fa)
+  have hghPfa : tateProj u (gh * tateProj u fa) = gh * tateProj u fa :=
+    tateProj_of_mem u (mul_mem hgh hPfaO)
+  have hghPfa' : pA' (gh * pA' fa) = gh * pA' fa :=
+    pA'_fixes_range h _ (hmemP_of_O (mul_mem hgh hPfaO'))
+  rw [mul_sub, map_sub, mul_sub, map_sub, hghPfa, hghPfa']
+  simp only [LinearMap.sub_apply]
+  rw [show gh * fh * (a : u.adicCompletion) = gh * fa from (mul_assoc gh fh _).symm ▸ rfl]
+  ring
+
+end DiffComputation
+end KwF4gRRTate
+end ModularCurve
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateAgreement.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateAgreement.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateAgreement"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section TraceOnSuperspace
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+theorem finrankTrace_eq_trace_on_superspace
+    (φ : V →ₗ[K] V) (W : Submodule K V) [FiniteDimensional K W]
+    (hrange : LinearMap.range φ ≤ W) (hW : ∀ x ∈ W, φ x ∈ W) :
+    haveI : FiniteDimensional K (LinearMap.range φ) :=
+      Submodule.finiteDimensional_of_le hrange
+    finrankTrace φ = LinearMap.trace K W (φ.restrict hW) := by
+  have : FiniteDimensional K (LinearMap.range φ) := Submodule.finiteDimensional_of_le hrange
+  let i : LinearMap.range φ →ₗ[K] W := Submodule.inclusion hrange
+  let π : W →ₗ[K] LinearMap.range φ :=
+    { toFun := fun w => ⟨φ (w : V), LinearMap.mem_range_self φ (w : V)⟩
+      map_add' := fun w₁ w₂ => by simp
+      map_smul' := fun c w => by simp }
+  have hip : i ∘ₗ π = φ.restrict hW := by
+    apply LinearMap.ext; intro w; apply Subtype.ext; rfl
+  have hpi : π ∘ₗ i = φ.restrict (fun x _ => LinearMap.mem_range_self φ x) := by
+    apply LinearMap.ext; intro x; apply Subtype.ext; rfl
+  unfold finrankTrace
+  rw [← hpi, ← hip, LinearMap.trace_comp_comm']
+
+end TraceOnSuperspace
+
+section Additivity
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+theorem finrankTrace_sub_eq
+    (φ ψ : V →ₗ[K] V)
+    [FiniteDimensional K (LinearMap.range φ)]
+    [FiniteDimensional K (LinearMap.range ψ)] :
+    haveI : FiniteDimensional K
+        ((LinearMap.range φ ⊔ LinearMap.range ψ : Submodule K V) : Type _) :=
+      Submodule.finiteDimensional_sup _ _
+    finrankTrace φ - finrankTrace ψ
+      = LinearMap.trace K (LinearMap.range φ ⊔ LinearMap.range ψ : Submodule K V)
+          ((φ - ψ).restrict
+            (p := (LinearMap.range φ ⊔ LinearMap.range ψ : Submodule K V))
+            (fun x _ => sub_mem
+              (Submodule.mem_sup_left (LinearMap.mem_range_self φ x))
+              (Submodule.mem_sup_right (LinearMap.mem_range_self ψ x)))) := by
+  set W' : Submodule K V := LinearMap.range φ ⊔ LinearMap.range ψ with hW'
+  have : FiniteDimensional K W' := Submodule.finiteDimensional_sup _ _
+  have hφW : ∀ x ∈ W', φ x ∈ W' := fun x _ =>
+    Submodule.mem_sup_left (LinearMap.mem_range_self φ x)
+  have hψW : ∀ x ∈ W', ψ x ∈ W' := fun x _ =>
+    Submodule.mem_sup_right (LinearMap.mem_range_self ψ x)
+  rw [finrankTrace_eq_trace_on_superspace φ W' le_sup_left hφW,
+    finrankTrace_eq_trace_on_superspace ψ W' le_sup_right hψW,
+    ← map_sub]
+  refine congrArg (LinearMap.trace K W') (LinearMap.ext fun x => Subtype.ext ?_)
+  rfl
+
+end Additivity
+end KwF4gRRTate
+end ModularCurve
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateAgreement.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateAgreement.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4gRRTate"
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain.HeightOneSpectrum IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsLocalRing"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateAgreement"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section DVRQuotDischarge
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem piPowKSubmod_eq_restrictScalars (πh : u.adicCompletionIntegers) (M : ℕ) :
+    piPowKSubmod u πh M
+      = (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers).restrictScalars K := by
+  ext y
+  rw [Submodule.restrictScalars_mem, Ideal.mem_span_singleton]
+  exact ⟨fun ⟨x, h⟩ => ⟨x, h⟩, fun ⟨x, h⟩ => ⟨x, h⟩⟩
+
+def quotPiPowEquivIdealQuot (πh : u.adicCompletionIntegers) (M : ℕ) :
+    (u.adicCompletionIntegers ⧸ piPowKSubmod u πh M)
+      ≃ₗ[K] (u.adicCompletionIntegers ⧸ (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers)) :=
+  (Submodule.quotEquivOfEq _ _ (piPowKSubmod_eq_restrictScalars u πh M)).trans
+    (Submodule.Quotient.restrictScalarsEquiv K _)
+
+variable (K L) in
+def KwF4gRRTateDVRCotangentKFinite : Prop :=
+  ∀ (u : Place K L) [u.FiniteResidue] (πh : u.adicCompletionIntegers) (_ : Irreducible πh),
+    FiniteDimensional K
+      (u.adicCompletionIntegers ⧸ (Ideal.span {πh} : Ideal u.adicCompletionIntegers))
+
+theorem range_mulLeft_eq_restrictScalars_span (a : u.adicCompletionIntegers) :
+    LinearMap.range (LinearMap.mulLeft K a)
+      = (Ideal.span {a} : Ideal u.adicCompletionIntegers).restrictScalars K := by
+  ext y
+  simp only [LinearMap.mem_range, LinearMap.mulLeft_apply, Submodule.restrictScalars_mem,
+    Ideal.mem_span_singleton]
+  exact ⟨fun ⟨x, hx⟩ => ⟨x, hx.symm⟩, fun ⟨x, hx⟩ => ⟨x, hx.symm⟩⟩
+
+theorem finiteDimensional_restrictScalarsQuot_pow [u.FiniteResidue]
+    (hCot : KwF4gRRTateDVRCotangentKFinite K L)
+    (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) (M : ℕ) :
+    FiniteDimensional K (u.adicCompletionIntegers ⧸
+      (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers).restrictScalars K) := by
+  induction M with
+  | zero =>
+    rw [pow_zero, Ideal.span_singleton_one, Submodule.restrictScalars_top]
+    infer_instance
+  | succ M ih =>
+    have hle : (Ideal.span {πh ^ (M+1)} : Ideal u.adicCompletionIntegers)
+        ≤ Ideal.span {πh ^ M} := by
+      rw [Ideal.span_singleton_le_span_singleton, pow_succ]; exact ⟨πh, rfl⟩
+    have hle' : (Ideal.span {πh ^ (M+1)} : Ideal u.adicCompletionIntegers).restrictScalars K
+        ≤ (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers).restrictScalars K :=
+      Submodule.restrictScalars_mono K hle
+    set N : Submodule K (u.adicCompletionIntegers ⧸
+        (Ideal.span {πh ^ (M+1)} : Ideal u.adicCompletionIntegers).restrictScalars K) :=
+      (Submodule.restrictScalars K (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers)).map
+        (Submodule.restrictScalars K (Ideal.span {πh ^ (M+1)} : Ideal _)).mkQ with hN_def
+    have hquot : FiniteDimensional K
+        ((u.adicCompletionIntegers ⧸
+          (Ideal.span {πh ^ (M+1)} : Ideal _).restrictScalars K) ⧸ N) := by
+      have := ih
+      exact Module.Finite.equiv
+        (Submodule.quotientQuotientEquivQuotient _ _ hle').symm
+    have hN : FiniteDimensional K N := by
+      set φ : u.adicCompletionIntegers →ₗ[K] (u.adicCompletionIntegers ⧸
+          (Ideal.span {πh ^ (M+1)} : Ideal u.adicCompletionIntegers).restrictScalars K) :=
+        (Submodule.restrictScalars K
+            (Ideal.span {πh ^ (M+1)} : Ideal u.adicCompletionIntegers)).mkQ ∘ₗ
+          LinearMap.mulLeft K (πh ^ M) with hφ_def
+      have hrange : LinearMap.range φ = N := by
+        rw [hφ_def, LinearMap.range_comp, range_mulLeft_eq_restrictScalars_span, hN_def]
+      have hker : LinearMap.ker φ
+          = (Ideal.span {πh} : Ideal u.adicCompletionIntegers).restrictScalars K := by
+        simp only [hφ_def, LinearMap.ker_comp, Submodule.ker_mkQ]
+        ext x
+        simp only [Submodule.mem_comap, LinearMap.mulLeft_apply, Submodule.restrictScalars_mem,
+          Ideal.mem_span_singleton]
+        have hπM : (πh : u.adicCompletionIntegers) ^ M ≠ 0 := pow_ne_zero M hπh.ne_zero
+        constructor
+        · rintro ⟨c, hc⟩
+          exact ⟨c, mul_left_cancel₀ hπM (by rw [hc, pow_succ, mul_assoc])⟩
+        · rintro ⟨c, hc⟩
+          exact ⟨c, by rw [hc, pow_succ, mul_assoc]⟩
+      let e₁ : (u.adicCompletionIntegers ⧸
+            (Ideal.span {πh} : Ideal u.adicCompletionIntegers).restrictScalars K)
+          ≃ₗ[K] (u.adicCompletionIntegers ⧸ LinearMap.ker φ) :=
+        Submodule.quotEquivOfEq _ _ hker.symm
+      let e₂ : (u.adicCompletionIntegers ⧸ LinearMap.ker φ) ≃ₗ[K] LinearMap.range φ :=
+        φ.quotKerEquivRange
+      let e₃ : (LinearMap.range φ : Submodule K _) ≃ₗ[K] N := LinearEquiv.ofEq _ _ hrange
+      have hCK : FiniteDimensional K (u.adicCompletionIntegers ⧸
+          (Ideal.span {πh} : Ideal u.adicCompletionIntegers).restrictScalars K) := by
+        have := hCot u πh hπh
+        exact Module.Finite.equiv
+          (Submodule.Quotient.restrictScalarsEquiv K
+            (Ideal.span {πh} : Ideal u.adicCompletionIntegers)).symm
+      exact Module.Finite.equiv ((e₁.trans e₂).trans e₃)
+    exact Module.Finite.of_submodule_quotient N
+
+theorem finiteDimensional_idealQuot_pow [u.FiniteResidue]
+    (hCot : KwF4gRRTateDVRCotangentKFinite K L)
+    (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) (M : ℕ) :
+    FiniteDimensional K
+      (u.adicCompletionIntegers ⧸ (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers)) := by
+  have := finiteDimensional_restrictScalarsQuot_pow u hCot πh hπh M
+  exact Module.Finite.equiv (Submodule.Quotient.restrictScalarsEquiv K _)
+
+theorem kwF4gRRTate_DVRQuotPowKFinite_of_cotangent
+    (hCot : KwF4gRRTateDVRCotangentKFinite K L) :
+    KwF4gRRTateDVRQuotPowKFinite K L := by
+  intro u _ πh hπh M
+  have := finiteDimensional_idealQuot_pow u hCot πh hπh M
+  exact Module.Finite.equiv (quotPiPowEquivIdealQuot u πh M).symm
+
+end DVRQuotDischarge
+end KwF4gRRTate
+end ModularCurve
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateAgreement.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateAgreement.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4R1V410a"
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain.HeightOneSpectrum IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsLocalRing"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateAgreement"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section DVRCotangentDischarge
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+scoped instance instIsScalarTower_K_toValuationSubring_adicCompletionIntegers :
+    IsScalarTower K u.toValuationSubring u.adicCompletionIntegers := by
+  refine IsScalarTower.of_algebraMap_eq fun k => ?_
+  apply Subtype.ext
+  change algebraMap K u.adicCompletion k
+    = (algebraMap u.toValuationSubring u.adicCompletionIntegers (algebraMap K _ k)).val
+  rw [IsScalarTower.algebraMap_apply K L u.adicCompletion]
+  rfl
+
+theorem span_irreducible_eq_completionIdeal_pow_one
+    (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) :
+    (Ideal.span {πh} : Ideal u.adicCompletionIntegers)
+      = (u.heightOneSpectrum.completionIdeal L) ^ 1 := by
+  rw [pow_one, ← hπh.maximalIdeal_eq]
+
+def quotientEquivKAlg (n : ℕ) :
+    (u.toValuationSubring ⧸ (IsLocalRing.maximalIdeal u.toValuationSubring) ^ n)
+      ≃ₐ[K] (u.adicCompletionIntegers ⧸ (u.heightOneSpectrum.completionIdeal L) ^ n) :=
+  { kwF4R1V410a_quotientEquiv u n with
+    commutes' := fun k => by
+      change kwF4R1V410a_quotientEquiv u n (algebraMap K _ k) = algebraMap K _ k
+      rw [IsScalarTower.algebraMap_apply K u.toValuationSubring
+          (u.toValuationSubring ⧸ (IsLocalRing.maximalIdeal u.toValuationSubring) ^ n),
+        Ideal.Quotient.algebraMap_eq, kwF4R1V410a_quotientEquiv_mk,
+        IsScalarTower.algebraMap_apply K u.adicCompletionIntegers
+          (u.adicCompletionIntegers ⧸ (u.heightOneSpectrum.completionIdeal L) ^ n),
+        Ideal.Quotient.algebraMap_eq,
+        IsScalarTower.algebraMap_apply K u.toValuationSubring u.adicCompletionIntegers] }
+
+def quotSpanIrreducibleEquivResidueField (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) :
+    (u.adicCompletionIntegers ⧸ (Ideal.span {πh} : Ideal u.adicCompletionIntegers))
+      ≃ₗ[K] u.ResidueField :=
+  (Ideal.quotientEquivAlgOfEq K
+      (span_irreducible_eq_completionIdeal_pow_one u πh hπh)).toLinearEquiv.trans
+    ((quotientEquivKAlg u 1).symm.toLinearEquiv.trans
+      (Ideal.quotientEquivAlgOfEq K
+        (pow_one (IsLocalRing.maximalIdeal u.toValuationSubring))).toLinearEquiv)
+
+theorem kwF4gRRTate_DVRCotangentKFinite : KwF4gRRTateDVRCotangentKFinite K L := by
+  intro u _ πh hπh
+  have : Module.Finite K u.ResidueField := FiniteResidue.finite
+  exact Module.Finite.equiv (quotSpanIrreducibleEquivResidueField u πh hπh).symm
+
+end DVRCotangentDischarge
+end KwF4gRRTate
+end ModularCurve
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateAgreement.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateAgreement.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateAgreement"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section DeltaQuotFactor
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+variable {pA pA' : V →ₗ[K] V}
+
+def deltaQuotFactor (h : SameRangeIdemProjectors pA pA') :
+    (V ⧸ LinearMap.range pA) →ₗ[K] LinearMap.range pA :=
+  (LinearMap.range pA).liftQ
+    (LinearMap.codRestrict (LinearMap.range pA) (pA - pA') (delta_range_subset h))
+    (fun x hx => by
+      apply Subtype.ext
+      exact delta_zero_on_range h hx)
+
+theorem deltaQuotFactor_apply (h : SameRangeIdemProjectors pA pA') (x : V) :
+    (deltaQuotFactor h (Submodule.Quotient.mk x) : V) = (pA - pA') x := rfl
+
+end DeltaQuotFactor
+
+section TermRangeFinite
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable [u.FiniteResidue]
+
+def KwF4gRRTatePoleWindowImageFinite : Prop :=
+  ∀ (fh : u.adicCompletion),
+    FiniteDimensional K (Submodule.map (adicIntegersKSubmod u).mkQ
+      (Submodule.map (lmulK u fh) (adicIntegersKSubmod u)))
+
+end TermRangeFinite
+
+section DiffTraceZero
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable (pA' : u.adicCompletion →ₗ[K] u.adicCompletion)
+
+def KwF4gRRTateCommFiniteGen : Prop :=
+  ∀ (_ : SameRangeIdemProjectors (tateProj u) pA') (fh gh : u.adicCompletion),
+    FiniteDimensional K
+      (LinearMap.range (tateCommRestrict pA' (lmulK u fh) (lmulK u gh)))
+
+end DiffTraceZero
+end KwF4gRRTate
+end ModularCurve
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateAgreement.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateAgreement.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateAgreement"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section Composite
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+
+theorem kwF4gRRTate_poleWindowFinite : KwF4gRRTatePoleWindowFinite K L :=
+  kwF4gRRTate_poleWindowFinite_of_DVRQuotPowKFinite
+    (kwF4gRRTate_DVRQuotPowKFinite_of_cotangent
+      kwF4gRRTate_DVRCotangentKFinite)
+
+end Composite
+
+section Subset
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem lmul_adicIntegers_subset_poleWindow (fh : u.adicCompletion)
+    (πh : u.adicCompletionIntegers) (M : ℕ)
+    (hfhM : (πh : u.adicCompletion) ^ M * fh ∈ u.adicCompletionIntegers) :
+    Submodule.map (lmulK u fh) (adicIntegersKSubmod u) ≤ poleWindowKSubmod u πh M := by
+  rintro x ⟨a, ha, rfl⟩
+  rw [mem_poleWindowKSubmod_iff]
+  show (πh : u.adicCompletion) ^ M * (lmulK u fh) a ∈ u.adicCompletionIntegers
+  have : (lmulK u fh) a = fh * a := rfl
+  rw [this, ← mul_assoc]
+  exact mul_mem hfhM (show a ∈ u.adicCompletionIntegers from ha)
+
+end Subset
+
+section Discharge
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable [u.FiniteResidue]
+
+theorem kwF4gRRTate_poleWindowImageFinite :
+    KwF4gRRTatePoleWindowImageFinite u := by
+  intro fh
+  obtain ⟨πh, hπh⟩ := IsDiscreteValuationRing.exists_irreducible u.adicCompletionIntegers
+  obtain ⟨M, hfhM⟩ := kwF4gRRTate_clearPole u πh hπh fh
+  set A := adicIntegersKSubmod u
+  set P := poleWindowKSubmod u πh M
+  have hsub : Submodule.map A.mkQ (Submodule.map (lmulK u fh) A)
+      ≤ Submodule.map A.mkQ P :=
+    Submodule.map_mono (lmul_adicIntegers_subset_poleWindow u fh πh M hfhM)
+  suffices hPim : FiniteDimensional K (Submodule.map A.mkQ P : Submodule K _) by
+    exact Submodule.finiteDimensional_of_le hsub
+  have : FiniteDimensional K (P ⧸ (A.comap P.subtype)) :=
+    kwF4gRRTate_poleWindowFinite (K := K) (L := L) u πh hπh M
+  let r : P →ₗ[K] (u.adicCompletion ⧸ A) := A.mkQ ∘ₗ P.subtype
+  have hrange : LinearMap.range r = Submodule.map A.mkQ P := by
+    rw [LinearMap.range_comp, Submodule.range_subtype]
+  have hker : LinearMap.ker r = A.comap P.subtype := by
+    rw [LinearMap.ker_comp, Submodule.ker_mkQ]
+  have e : (P ⧸ (A.comap P.subtype)) ≃ₗ[K] LinearMap.range r := hker ▸ r.quotKerEquivRange
+  rw [← hrange]
+  exact e.finiteDimensional
+
+end Discharge
+end KwF4gRRTate
+end ModularCurve
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateAgreement.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateAgreement.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateAgreement"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section KerInf
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable (pA' : u.adicCompletion →ₗ[K] u.adicCompletion)
+
+theorem ker_pA'_inf_integers (h : SameRangeIdemProjectors (tateProj u) pA') :
+    LinearMap.ker pA' ⊓ adicIntegersKSubmod u = ⊥ := by
+  rw [eq_bot_iff]
+  intro x hx
+  obtain ⟨hker, hint⟩ := Submodule.mem_inf.mp hx
+  have h0 : pA' x = 0 := LinearMap.mem_ker.mp hker
+  have hxR : x ∈ LinearMap.range (tateProj u) := by rw [range_tateProj u]; exact hint
+  have hpAx : pA' x = x := pA'_fixes_range h x hxR
+  rw [Submodule.mem_bot, ← hpAx, h0]
+
+theorem finiteDimensional_ker_pA'_inf_poleWindow
+    (h : SameRangeIdemProjectors (tateProj u) pA')
+    [u.FiniteResidue] (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) (M : ℕ) :
+    FiniteDimensional K
+      ((LinearMap.ker pA' ⊓ poleWindowKSubmod u πh M : Submodule K _)) := by
+  have := kwF4gRRTate_poleWindowFinite (K := K) (L := L) u πh hπh M
+  set A := adicIntegersKSubmod u
+  set P := poleWindowKSubmod u πh M
+  let A' : Submodule K P := A.comap P.subtype
+  let ι : (LinearMap.ker pA' ⊓ P : Submodule K _) →ₗ[K] P ⧸ A' :=
+    (A'.mkQ).comp (Submodule.inclusion inf_le_right)
+  refine FiniteDimensional.of_injective ι ?_
+  rw [← LinearMap.ker_eq_bot, eq_bot_iff]
+  intro xh hxker
+  obtain ⟨x, hxkp⟩ := xh
+  obtain ⟨hxk, hxp⟩ := Submodule.mem_inf.mp hxkp
+  simp only [ι, LinearMap.mem_ker, LinearMap.comp_apply, Submodule.mkQ_apply,
+    Submodule.Quotient.mk_eq_zero, Submodule.inclusion_apply] at hxker
+  have hxA : x ∈ A := hxker
+  have hx0 : x = 0 := by
+    have hbot : x ∈ (⊥ : Submodule K u.adicCompletion) := by
+      rw [← ker_pA'_inf_integers u pA' h]; exact Submodule.mem_inf.mpr ⟨hxk, hxA⟩
+    exact (Submodule.mem_bot K).mp hbot
+  exact Subtype.ext hx0
+
+end KerInf
+
+section Discharge
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable (pA' : u.adicCompletion →ₗ[K] u.adicCompletion)
+variable [∀ u : Place K L, u.FiniteResidue]
+
+theorem finiteDimensional_principalPart_pA'_range
+    (h : SameRangeIdemProjectors (tateProj u) pA') (fh : u.adicCompletion) :
+    FiniteDimensional K
+      (LinearMap.range
+        ((LinearMap.id - pA') ∘ₗ lmulK u fh ∘ₗ (adicIntegersKSubmod u).subtype)) := by
+  obtain ⟨πh, hπh⟩ := IsDiscreteValuationRing.exists_irreducible u.adicCompletionIntegers
+  obtain ⟨M, hfhM⟩ := kwF4gRRTate_clearPole u πh hπh fh
+  have := finiteDimensional_ker_pA'_inf_poleWindow u pA' h πh hπh M
+  apply Submodule.finiteDimensional_of_le
+    (S₂ := LinearMap.ker pA' ⊓ poleWindowKSubmod u πh M)
+  rintro x ⟨a, rfl⟩
+  refine Submodule.mem_inf.mpr ⟨?_, ?_⟩
+  · rw [LinearMap.mem_ker]
+    simp only [LinearMap.comp_apply, LinearMap.sub_apply, LinearMap.id_apply,
+      Submodule.subtype_apply, map_sub]
+    exact sub_eq_zero.mpr (h.idem_pA' _).symm
+  · simp only [LinearMap.comp_apply, LinearMap.sub_apply, LinearMap.id_apply,
+      Submodule.subtype_apply]
+    refine sub_mem ?_ ?_
+    · exact lmul_adicIntegers_subset_poleWindow u fh πh M hfhM ⟨a, a.2, rfl⟩
+    · refine adicIntegersKSubmod_le_poleWindowKSubmod u πh M ?_
+      have heq : LinearMap.range pA' = adicIntegersKSubmod u := by
+        rw [← h.range_eq, range_tateProj u]
+      exact heq.le (LinearMap.mem_range_self pA' _)
+
+theorem kwF4gRRTate_commFiniteGen :
+    KwF4gRRTateCommFiniteGen u pA' := by
+  intro h fh gh
+  have h3f := finiteDimensional_principalPart_pA'_range u pA' h fh
+  have h3g := finiteDimensional_principalPart_pA'_range u pA' h gh
+  set qf := (LinearMap.id - pA') ∘ₗ lmulK u fh ∘ₗ (adicIntegersKSubmod u).subtype
+  set qg := (LinearMap.id - pA') ∘ₗ lmulK u gh ∘ₗ (adicIntegersKSubmod u).subtype
+  set Wf := LinearMap.range qf
+  set Wg := LinearMap.range qg
+  set S₂ : Submodule K u.adicCompletion :=
+    Submodule.map (pA' ∘ₗ lmulK u gh) Wf ⊔ Submodule.map (pA' ∘ₗ lmulK u fh) Wg with hS₂
+  have : FiniteDimensional K S₂ := by
+    have : FiniteDimensional K (Submodule.map (pA' ∘ₗ lmulK u gh) Wf : Submodule K _) :=
+      inferInstance
+    have : FiniteDimensional K (Submodule.map (pA' ∘ₗ lmulK u fh) Wg : Submodule K _) :=
+      inferInstance
+    exact Submodule.finiteDimensional_sup _ _
+  set R := LinearMap.range (tateCommRestrict pA' (lmulK u fh) (lmulK u gh))
+  suffices himg : Submodule.map (LinearMap.range pA').subtype R ≤ S₂ by
+    have : FiniteDimensional K (Submodule.map (LinearMap.range pA').subtype R) :=
+      Submodule.finiteDimensional_of_le himg
+    exact (Submodule.equivMapOfInjective (LinearMap.range pA').subtype
+        (LinearMap.range pA').injective_subtype R).symm.finiteDimensional
+  rintro x ⟨y, hyR, rfl⟩
+  obtain ⟨a, rfl⟩ := hyR
+  have heq : LinearMap.range pA' = adicIntegersKSubmod u := by
+    rw [← h.range_eq, range_tateProj u]
+  have haO : (a : u.adicCompletion) ∈ adicIntegersKSubmod u := heq.le a.2
+  set aO : adicIntegersKSubmod u := ⟨(a : u.adicCompletion), haO⟩
+  have hcomm : lmulK u fh ∘ₗ lmulK u gh = lmulK u gh ∘ₗ lmulK u fh := by
+    refine LinearMap.ext fun y' => ?_; change fh * (gh * y') = gh * (fh * y'); ring
+  change (tateCommRestrict pA' (lmulK u fh) (lmulK u gh) a : u.adicCompletion) ∈ S₂
+  rw [show (tateCommRestrict pA' (lmulK u fh) (lmulK u gh) a : u.adicCompletion)
+      = tateComm pA' (lmulK u fh) (lmulK u gh) (a : u.adicCompletion) from rfl,
+    tateComm_eq_of_commute hcomm]
+  refine sub_mem (Submodule.mem_sup_left ?_) (Submodule.mem_sup_right ?_)
+  · exact ⟨qf aO, ⟨aO, rfl⟩, rfl⟩
+  · exact ⟨qg aO, ⟨aO, rfl⟩, rfl⟩
+
+end Discharge
+end KwF4gRRTate
+end ModularCurve
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateAgreement.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateAgreement.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateAgreement"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section Additivity
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+theorem finrankTrace_congr {φ ψ : V →ₗ[K] V}
+    [hφ : FiniteDimensional K (LinearMap.range φ)]
+    [hψ : FiniteDimensional K (LinearMap.range ψ)]
+    (h : φ = ψ) : finrankTrace φ = finrankTrace ψ := by
+  subst h; rfl
+
+theorem range_sub_le (φ ψ : V →ₗ[K] V) :
+    LinearMap.range (φ - ψ) ≤ LinearMap.range φ ⊔ LinearMap.range ψ := by
+  rintro x ⟨y, rfl⟩
+  exact sub_mem (Submodule.mem_sup_left (mem_range_self φ y))
+    (Submodule.mem_sup_right (mem_range_self ψ y))
+
+scoped instance instFinDimRangeSub (φ ψ : V →ₗ[K] V)
+    [FiniteDimensional K (LinearMap.range φ)]
+    [FiniteDimensional K (LinearMap.range ψ)] :
+    FiniteDimensional K (LinearMap.range (φ - ψ)) :=
+  haveI : FiniteDimensional K
+      ((LinearMap.range φ ⊔ LinearMap.range ψ : Submodule K V) : Type _) :=
+    Submodule.finiteDimensional_sup _ _
+  Submodule.finiteDimensional_of_le (range_sub_le φ ψ)
+
+theorem finrankTrace_sub (φ ψ : V →ₗ[K] V)
+    [FiniteDimensional K (LinearMap.range φ)]
+    [FiniteDimensional K (LinearMap.range ψ)] :
+    finrankTrace φ - finrankTrace ψ = finrankTrace (φ - ψ) := by
+  set W' : Submodule K V := LinearMap.range φ ⊔ LinearMap.range ψ
+  have : FiniteDimensional K W' := Submodule.finiteDimensional_sup _ _
+  have hφψW : ∀ x ∈ W', (φ - ψ) x ∈ W' := fun x _ =>
+    sub_mem (Submodule.mem_sup_left (mem_range_self φ x))
+      (Submodule.mem_sup_right (mem_range_self ψ x))
+  rw [finrankTrace_sub_eq φ ψ,
+    finrankTrace_eq_trace_on_superspace (φ - ψ) W' (range_sub_le φ ψ) hφψW]
+
+end Additivity
+
+section ConjInvariance
+
+variable {K M N : Type*} [Field K] [AddCommGroup M] [Module K M]
+variable [AddCommGroup N] [Module K N]
+
+theorem range_conj_eq_map (e : M ≃ₗ[K] N) (φ : M →ₗ[K] M) :
+    LinearMap.range (e.conj φ) = (LinearMap.range φ).map (e : M →ₗ[K] N) := by
+  rw [LinearEquiv.conj_apply, LinearMap.range_comp, LinearEquiv.range,
+    Submodule.map_top, LinearMap.range_comp]
+
+theorem finrankTrace_conj (e : M ≃ₗ[K] N) (φ : M →ₗ[K] M)
+    [hφ : FiniteDimensional K (LinearMap.range φ)] :
+    haveI : FiniteDimensional K (LinearMap.range (e.conj φ)) := by
+      rw [range_conj_eq_map]
+      exact (Submodule.equivMapOfInjective _ e.injective _).finiteDimensional
+    finrankTrace (e.conj φ) = finrankTrace φ := by
+  have hgf : ((e : M →ₗ[K] N) ∘ₗ φ) ∘ₗ (e.symm : N →ₗ[K] M) = e.conj φ := by
+    apply LinearMap.ext; intro x
+    simp only [LinearMap.comp_apply, LinearEquiv.coe_coe, LinearEquiv.conj_apply]
+  have hfg : (e.symm : N →ₗ[K] M) ∘ₗ ((e : M →ₗ[K] N) ∘ₗ φ) = φ := by
+    apply LinearMap.ext; intro x
+    simp only [LinearMap.comp_apply, LinearEquiv.coe_coe, LinearEquiv.symm_apply_apply]
+  have : FiniteDimensional K
+      (LinearMap.range (((e : M →ₗ[K] N) ∘ₗ φ) ∘ₗ (e.symm : N →ₗ[K] M))) := by
+    rw [hgf, range_conj_eq_map]
+    exact (Submodule.equivMapOfInjective _ e.injective _).finiteDimensional
+  have : FiniteDimensional K
+      (LinearMap.range ((e.symm : N →ₗ[K] M) ∘ₗ ((e : M →ₗ[K] N) ∘ₗ φ))) := by
+    rw [hfg]; exact hφ
+  have hcyc := finrankTrace_comp_comm (e.symm : N →ₗ[K] M) ((e : M →ₗ[K] N) ∘ₗ φ)
+  have hconj : FiniteDimensional K (LinearMap.range (e.conj φ)) := by
+    rw [range_conj_eq_map]
+    exact (Submodule.equivMapOfInjective _ e.injective _).finiteDimensional
+  exact (finrankTrace_congr hgf.symm).trans (hcyc.trans (finrankTrace_congr hfg))
+
+end ConjInvariance
+
+section TermMaps
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+def alphaMap (c : u.adicCompletion) :
+    LinearMap.range (tateProj u) →ₗ[K] (u.adicCompletion ⧸ LinearMap.range (tateProj u)) :=
+  (LinearMap.range (tateProj u)).mkQ ∘ₗ lmulK u c ∘ₗ (LinearMap.range (tateProj u)).subtype
+
+theorem alphaMap_apply (c : u.adicCompletion) (a : LinearMap.range (tateProj u)) :
+    alphaMap u c a = Submodule.Quotient.mk (c * (a : u.adicCompletion)) := rfl
+
+def mulOnRange {gh : u.adicCompletion} (hgh : gh ∈ u.adicCompletionIntegers) :
+    LinearMap.range (tateProj u) →ₗ[K] LinearMap.range (tateProj u) :=
+  (lmulK u gh).restrict (fun x hx => by
+    have hxO : x ∈ u.adicCompletionIntegers :=
+      (range_tateProj u ▸ hx : x ∈ adicIntegersKSubmod u)
+    have hghx : gh * x ∈ u.adicCompletionIntegers := mul_mem hgh hxO
+    rw [range_tateProj u]
+    exact (show gh * x ∈ adicIntegersKSubmod u from hghx))
+
+theorem mulOnRange_apply {gh : u.adicCompletion} (hgh : gh ∈ u.adicCompletionIntegers)
+    (a : LinearMap.range (tateProj u)) :
+    (mulOnRange u hgh a : u.adicCompletion) = gh * (a : u.adicCompletion) := rfl
+
+variable [u.FiniteResidue]
+
+theorem finiteDimensional_range_alphaMap (c : u.adicCompletion) :
+    FiniteDimensional K (LinearMap.range (alphaMap u c)) := by
+  have hF21 := kwF4gRRTate_poleWindowImageFinite u c
+  set Q1 := u.adicCompletion ⧸ LinearMap.range (tateProj u)
+  set Q2 := u.adicCompletion ⧸ adicIntegersKSubmod u
+  let eQ : Q1 ≃ₗ[K] Q2 := Submodule.quotEquivOfEq _ _ (range_tateProj u)
+  have hmap : (LinearMap.range (alphaMap u c)).map (eQ : Q1 →ₗ[K] Q2)
+      = Submodule.map (adicIntegersKSubmod u).mkQ
+          (Submodule.map (lmulK u c) (adicIntegersKSubmod u)) := by
+    apply le_antisymm
+    · rintro x ⟨y, hy, rfl⟩
+      obtain ⟨a, rfl⟩ := hy
+      refine ⟨c * (a : u.adicCompletion), ⟨(a : u.adicCompletion), ?_, rfl⟩, ?_⟩
+      · exact (range_tateProj u) ▸ a.2
+      · rfl
+    · rintro x ⟨y, ⟨av, hav, rfl⟩, rfl⟩
+      refine ⟨alphaMap u c ⟨av, (range_tateProj u).symm ▸ hav⟩, ⟨_, rfl⟩, ?_⟩
+      rfl
+  have : FiniteDimensional K
+      ((LinearMap.range (alphaMap u c)).map (eQ : Q1 →ₗ[K] Q2)) := by
+    rw [hmap]; exact hF21
+  exact (Submodule.equivMapOfInjective (eQ : Q1 →ₗ[K] Q2) eQ.injective
+    (LinearMap.range (alphaMap u c))).symm.finiteDimensional
+
+end TermMaps
+
+section Cyclicity
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable [u.FiniteResidue]
+variable {pA' : u.adicCompletion →ₗ[K] u.adicCompletion}
+
+scoped instance instFinDimRangeDeltaAlpha (h : SameRangeIdemProjectors (tateProj u) pA')
+    (c : u.adicCompletion) :
+    FiniteDimensional K (LinearMap.range (deltaQuotFactor h ∘ₗ alphaMap u c)) := by
+  have := finiteDimensional_range_alphaMap u c
+  rw [LinearMap.range_comp]
+  infer_instance
+
+scoped instance instFinDimRangeMulDeltaAlpha (h : SameRangeIdemProjectors (tateProj u) pA')
+    (c : u.adicCompletion) {gh : u.adicCompletion} (hgh : gh ∈ u.adicCompletionIntegers) :
+    FiniteDimensional K
+      (LinearMap.range (mulOnRange u hgh ∘ₗ deltaQuotFactor h ∘ₗ alphaMap u c)) := by
+  have := finiteDimensional_range_alphaMap u c
+  rw [LinearMap.range_comp, LinearMap.range_comp]
+  infer_instance
+
+theorem finrankTrace_term_eq (h : SameRangeIdemProjectors (tateProj u) pA')
+    (fh : u.adicCompletion) {gh : u.adicCompletion} (hgh : gh ∈ u.adicCompletionIntegers) :
+    finrankTrace (deltaQuotFactor h ∘ₗ alphaMap u (gh * fh))
+      = finrankTrace (mulOnRange u hgh ∘ₗ deltaQuotFactor h ∘ₗ alphaMap u fh) := by
+  set dQ := deltaQuotFactor h
+  set α₁ := alphaMap u (gh * fh)
+  set α₂ := alphaMap u fh
+  set β := mulOnRange u hgh
+  have hFα₁ : FiniteDimensional K (LinearMap.range α₁) :=
+    finiteDimensional_range_alphaMap u (gh * fh)
+  have hFα₂ : FiniteDimensional K (LinearMap.range α₂) :=
+    finiteDimensional_range_alphaMap u fh
+  have hFS₁ : FiniteDimensional K (LinearMap.range (α₁ ∘ₗ dQ)) := by
+    apply Submodule.finiteDimensional_of_le (S₂ := LinearMap.range α₁)
+    exact LinearMap.range_comp_le_range _ _
+  have hFS₂ : FiniteDimensional K (LinearMap.range (α₂ ∘ₗ (β ∘ₗ dQ))) := by
+    apply Submodule.finiteDimensional_of_le (S₂ := LinearMap.range α₂)
+    exact LinearMap.range_comp_le_range _ _
+  have hFT₂' : FiniteDimensional K (LinearMap.range ((β ∘ₗ dQ) ∘ₗ α₂)) :=
+    instFinDimRangeMulDeltaAlpha u h fh hgh
+  have hcyc₁ : finrankTrace (dQ ∘ₗ α₁) = finrankTrace (α₁ ∘ₗ dQ) :=
+    finrankTrace_comp_comm α₁ dQ
+  have hcyc₂ : finrankTrace ((β ∘ₗ dQ) ∘ₗ α₂) = finrankTrace (α₂ ∘ₗ (β ∘ₗ dQ)) :=
+    finrankTrace_comp_comm α₂ (β ∘ₗ dQ)
+  have hSeq : α₁ ∘ₗ dQ = α₂ ∘ₗ (β ∘ₗ dQ) := by
+    apply LinearMap.ext; intro y
+    simp only [LinearMap.comp_apply]
+    rw [alphaMap_apply, alphaMap_apply, mulOnRange_apply]
+    congr 1
+    ring
+  change finrankTrace (dQ ∘ₗ α₁) = finrankTrace ((β ∘ₗ dQ) ∘ₗ α₂)
+  rw [hcyc₁, hcyc₂]
+  exact finrankTrace_congr hSeq
+
+end Cyclicity
+
+section Headline
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable [∀ u : Place K L, u.FiniteResidue]
+
+theorem kwF4gRRTate_projectorIndep : KwF4gRRTateProjectorIndep K L := by
+  intro u pA' h fh gh hgh _ _
+  set Φ := tateCommRestrict (tateProj u) (lmulK u fh) (lmulK u gh)
+  set Ψ' := tateCommRestrict pA' (lmulK u fh) (lmulK u gh)
+  let e : LinearMap.range pA' ≃ₗ[K] LinearMap.range (tateProj u) :=
+    LinearEquiv.ofEq _ _ h.range_eq.symm
+  set Ψ := e.conj Ψ' with hΨdef
+  have hFΨ : FiniteDimensional K (LinearMap.range Ψ) := by
+    rw [hΨdef, range_conj_eq_map]
+    infer_instance
+  have hΨeq : finrankTrace Ψ = finrankTrace Ψ' := finrankTrace_conj e Ψ'
+  change finrankTrace Φ = finrankTrace Ψ'
+  rw [← hΨeq]
+  set dQ := deltaQuotFactor h
+  set T₁ := dQ ∘ₗ alphaMap u (gh * fh) with hT₁def
+  set T₂ := mulOnRange u hgh ∘ₗ dQ ∘ₗ alphaMap u fh with hT₂def
+  have hΦΨ : Φ - Ψ = T₁ - T₂ := by
+    apply LinearMap.ext; intro a
+    apply Subtype.ext
+    simp only [LinearMap.sub_apply, AddSubgroupClass.coe_sub]
+    have hΦv : (Φ a : u.adicCompletion)
+        = (tateCommRestrict (tateProj u) (lmulK u fh) (lmulK u gh) a : u.adicCompletion) :=
+      rfl
+    have hΨv : (Ψ a : u.adicCompletion) = tateComm pA' (lmulK u fh) (lmulK u gh)
+        (a : u.adicCompletion) := by
+      change ((e.conj Ψ') a : u.adicCompletion) = _
+      simp only [LinearEquiv.conj_apply, LinearMap.comp_apply, LinearEquiv.coe_coe]
+      have he_coe : ∀ (x : LinearMap.range pA'), ((e x : LinearMap.range (tateProj u)) :
+          u.adicCompletion) = (x : u.adicCompletion) := fun x => rfl
+      have hesymm_coe : ∀ (x : LinearMap.range (tateProj u)),
+          ((e.symm x : LinearMap.range pA') : u.adicCompletion)
+          = (x : u.adicCompletion) := fun x => rfl
+      rw [he_coe, tateCommRestrict_apply, hesymm_coe]
+    rw [hΦv, hΨv]
+    rw [tateCommRestrict_diff u pA' h hgh fh a]
+    have hT₁v : (T₁ a : u.adicCompletion)
+        = (tateProj u - pA') (gh * fh * (a : u.adicCompletion)) := by
+      simp only [T₁, LinearMap.comp_apply, dQ]
+      rw [alphaMap_apply, deltaQuotFactor_apply]
+    have hT₂v : (T₂ a : u.adicCompletion)
+        = gh * (tateProj u - pA') (fh * (a : u.adicCompletion)) := by
+      simp only [T₂, LinearMap.comp_apply, dQ]
+      rw [alphaMap_apply, mulOnRange_apply, deltaQuotFactor_apply]
+    rw [hT₁v, hT₂v]
+  have hFT₁ : FiniteDimensional K (LinearMap.range T₁) :=
+    instFinDimRangeDeltaAlpha u h (gh * fh)
+  have hFT₂ : FiniteDimensional K (LinearMap.range T₂) :=
+    instFinDimRangeMulDeltaAlpha u h fh hgh
+  have hchain : finrankTrace Φ - finrankTrace Ψ = finrankTrace T₁ - finrankTrace T₂ := by
+    rw [finrankTrace_sub Φ Ψ, finrankTrace_sub T₁ T₂]
+    exact finrankTrace_congr hΦΨ
+  rw [← sub_eq_zero, hchain, finrankTrace_term_eq u h fh hgh, sub_self]
+
+end Headline
+end KwF4gRRTate
+end ModularCurve
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateAgreement.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateAgreement.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateAgreement"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section CohenMint
+
+variable (K L : Type*) [Field K] [Field L] [Algebra K L]
+variable [HasCanonicalLocalResidueKStar K L]
+
+def KwF4gRRTateCohenTateAgreement : Prop :=
+  ∀ (u : Place K L) [u.FiniteResidue],
+    ∃ (pC : u.adicCompletion →ₗ[K] u.adicCompletion)
+      (_ : SameRangeIdemProjectors (tateProj u) pC),
+    ∀ (fh : u.adicCompletion)
+      [FiniteDimensional K (LinearMap.range
+        (tateCommRestrict pC (lmulK u fh)
+          (lmulK u (algebraMap L u.adicCompletion u.uniformizer))))],
+    tateCommTrace pC (lmulK u fh) (lmulK u (algebraMap L u.adicCompletion u.uniformizer))
+      = Algebra.trace K u.ResidueField (kwHgfV352_localResidueCompletion u fh)
+
+end CohenMint
+
+section Reprice
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable [HasCanonicalLocalResidueKStar K L]
+variable [∀ u : Place K L, u.FiniteResidue]
+
+theorem kwF4gRRTate_agreement_of_cohenTateAgreement
+    (hfin : KwF4gRRTateCommFinite K L)
+    (hCTA : KwF4gRRTateCohenTateAgreement K L) :
+    KwF4gRRTateAgreement K L hfin := by
+  intro u _ fh
+  obtain ⟨pC, hpC, hCTA_u⟩ := hCTA u
+  set ghπ := algebraMap L u.adicCompletion u.uniformizer
+  have hgh : ghπ ∈ u.adicCompletionIntegers :=
+    (kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff u _).mpr u.uniformizer_mem
+  have hF1 := hfin u fh ghπ
+  have hF2 : FiniteDimensional K (LinearMap.range
+      (tateCommRestrict pC (lmulK u fh) (lmulK u ghπ))) :=
+    kwF4gRRTate_commFiniteGen u pC hpC fh ghπ
+  change tateRes u fh ghπ = Algebra.trace K u.ResidueField
+    (kwHgfV352_localResidueCompletion u fh)
+  unfold tateRes
+  rw [kwF4gRRTate_projectorIndep u pC hpC fh ghπ hgh]
+  exact hCTA_u fh
+
+end Reprice
+end KwF4gRRTate
+end ModularCurve
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateAgreement.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateAgreement.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateAgreement"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section CohenKernelData
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable [HasCanonicalLocalResidueKStar K L]
+
+structure TateCohenKernelData (u : Place K L) [u.FiniteResidue] where
+  pC : u.adicCompletion →ₗ[K] u.adicCompletion
+  pC_idem : ∀ x, pC (pC x) = pC x
+  range_pC : LinearMap.range (tateProj u) = LinearMap.range pC
+  liftκ : u.ResidueField →ₗ[K] LinearMap.range pC
+  liftκ_inj : Function.Injective liftκ
+  tateComm_mem_range_liftκ : ∀ (fh : u.adicCompletion) (a : LinearMap.range pC),
+    tateCommRestrict pC (lmulK u fh)
+      (lmulK u (algebraMap L u.adicCompletion u.uniformizer)) a ∈ LinearMap.range liftκ
+  tateComm_liftκ : ∀ (fh : u.adicCompletion) (c : u.ResidueField),
+    tateCommRestrict pC (lmulK u fh)
+      (lmulK u (algebraMap L u.adicCompletion u.uniformizer)) (liftκ c)
+      = liftκ (kwHgfV352_localResidueCompletion u fh * c)
+
+variable {u : Place K L} [u.FiniteResidue]
+
+theorem sameRangeIdemProjectors_of_kernelData (D : TateCohenKernelData u) :
+    SameRangeIdemProjectors (tateProj u) D.pC where
+  idem_pA x := congrFun (congrArg DFunLike.coe (tateProj_idem u)) x
+  idem_pA' := D.pC_idem
+  range_eq := D.range_pC
+
+end CohenKernelData
+
+section TraceComputation
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable [HasCanonicalLocalResidueKStar K L]
+variable {u : Place K L} [u.FiniteResidue]
+
+theorem tateCommTrace_of_kernelData (D : TateCohenKernelData u) (fh : u.adicCompletion)
+    [FiniteDimensional K (LinearMap.range
+      (tateCommRestrict D.pC (lmulK u fh)
+        (lmulK u (algebraMap L u.adicCompletion u.uniformizer))))] :
+    tateCommTrace D.pC (lmulK u fh)
+        (lmulK u (algebraMap L u.adicCompletion u.uniformizer))
+      = Algebra.trace K u.ResidueField (kwHgfV352_localResidueCompletion u fh) := by
+  have : FiniteDimensional K u.ResidueField := Place.FiniteResidue.finite
+  set T := tateCommRestrict D.pC (lmulK u fh)
+    (lmulK u (algebraMap L u.adicCompletion u.uniformizer)) with hT
+  set W : Submodule K (LinearMap.range D.pC) := LinearMap.range D.liftκ with hW
+  have hWfin : FiniteDimensional K W := LinearMap.finiteDimensional_range D.liftκ
+  have hrange : LinearMap.range T ≤ W := by
+    rintro x ⟨a, rfl⟩; exact D.tateComm_mem_range_liftκ fh a
+  have hstab : ∀ x ∈ W, T x ∈ W := by
+    rintro x ⟨c, rfl⟩
+    exact ⟨kwHgfV352_localResidueCompletion u fh * c, (D.tateComm_liftκ fh c).symm⟩
+  let e : u.ResidueField ≃ₗ[K] W := LinearEquiv.ofInjective D.liftκ D.liftκ_inj
+  have he_apply : ∀ c, ((e c : W) : LinearMap.range D.pC) = D.liftκ c := fun c => rfl
+  have hconj : T.restrict hstab
+      = e.conj (Algebra.lmul K u.ResidueField
+          (kwHgfV352_localResidueCompletion u fh)) := by
+    refine LinearMap.ext fun w => ?_
+    obtain ⟨c, rfl⟩ := e.surjective w
+    apply Subtype.ext
+    calc ((T.restrict hstab) (e c) : LinearMap.range D.pC)
+        = T ((e c : W) : LinearMap.range D.pC) := rfl
+      _ = T (D.liftκ c) := by rw [he_apply]
+      _ = D.liftκ (kwHgfV352_localResidueCompletion u fh * c) := D.tateComm_liftκ fh c
+      _ = ((e (kwHgfV352_localResidueCompletion u fh * c) : W) : LinearMap.range D.pC) :=
+            (he_apply _).symm
+      _ = (((e.conj (Algebra.lmul K u.ResidueField
+              (kwHgfV352_localResidueCompletion u fh))) (e c) : W)
+              : LinearMap.range D.pC) := by
+            congr 1
+            rw [LinearEquiv.conj_apply, LinearMap.comp_apply, LinearMap.comp_apply,
+              LinearEquiv.coe_coe, LinearEquiv.coe_coe, LinearEquiv.symm_apply_apply]
+            rfl
+  calc tateCommTrace D.pC (lmulK u fh)
+        (lmulK u (algebraMap L u.adicCompletion u.uniformizer))
+      = finrankTrace T := rfl
+    _ = LinearMap.trace K W (T.restrict hstab) :=
+          finrankTrace_eq_trace_on_superspace T W hrange hstab
+    _ = LinearMap.trace K W (e.conj (Algebra.lmul K u.ResidueField
+          (kwHgfV352_localResidueCompletion u fh))) := by rw [hconj]
+    _ = LinearMap.trace K u.ResidueField (Algebra.lmul K u.ResidueField
+          (kwHgfV352_localResidueCompletion u fh)) :=
+          LinearMap.trace_conj' (N := ↥W) (Algebra.lmul K u.ResidueField
+            (kwHgfV352_localResidueCompletion u fh)) e
+    _ = Algebra.trace K u.ResidueField (kwHgfV352_localResidueCompletion u fh) := rfl
+
+end TraceComputation
+
+section Mint
+
+variable (K L : Type*) [Field K] [Field L] [Algebra K L]
+variable [HasCanonicalLocalResidueKStar K L]
+
+def KwF4gRRTateCohenKernelDataExists : Prop :=
+  ∀ (u : Place K L) [u.FiniteResidue], Nonempty (TateCohenKernelData u)
+
+end Mint
+
+section Headline
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable [HasCanonicalLocalResidueKStar K L]
+
+theorem kwF4gRRTate_cohenTateAgreement_of_kernelData
+    (hD : KwF4gRRTateCohenKernelDataExists K L) :
+    KwF4gRRTateCohenTateAgreement K L := by
+  intro u _
+  obtain ⟨D⟩ := hD u
+  exact ⟨D.pC, sameRangeIdemProjectors_of_kernelData D,
+    fun fh _ => tateCommTrace_of_kernelData D fh⟩
+
+theorem kwF4gRRTate_agreement_of_kernelData
+    [∀ u : Place K L, u.FiniteResidue]
+    (hfin : KwF4gRRTateCommFinite K L)
+    (hD : KwF4gRRTateCohenKernelDataExists K L) :
+    KwF4gRRTateAgreement K L hfin :=
+  kwF4gRRTate_agreement_of_cohenTateAgreement hfin
+    (kwF4gRRTate_cohenTateAgreement_of_kernelData hD)
+
+end Headline
+end KwF4gRRTate
+end ModularCurve
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place FunctionField \
+  P2MW.S_AlgebraicCurve_tateAgreement.FunctionField KaehlerDifferential \
+  P2MW.S_AlgebraicCurve_tateAgreement.KaehlerDifferential"
+p2m_open "ModularCurve.KwF4R1V391a P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4R1V391a \
+  P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4R1V392a"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwF4R1V394a
+p2m_open "ModularCurve"
+
+section LinearWrappers
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+variable [HasCanonicalLocalResidueKStar K E] [HasCanonicalLocalResidueKStar K F]
+variable [HasPrincipalDivisors K F] [FiniteDimensional E F]
+
+theorem kwF4R1V394a_localResidueCompletion_smul
+    (v : Place K E) (c : K) (xh : v.adicCompletion) :
+    kwHgfV352_localResidueCompletion v (c • xh)
+      = c • kwHgfV352_localResidueCompletion v xh := by
+  obtain ⟨x, hx⟩ := kwHgfV352_exists_sub_mem_adicCompletionIntegers v xh
+  have halg : algebraMap E v.adicCompletion (c • x)
+      = c • algebraMap E v.adicCompletion x := by
+    rw [Algebra.smul_def, map_mul, ← IsScalarTower.algebraMap_apply K E v.adicCompletion,
+      ← Algebra.smul_def]
+  have hcx : algebraMap E v.adicCompletion (c • x) - c • xh
+      ∈ v.adicCompletionIntegers := by
+    rw [halg, ← smul_sub, Algebra.smul_def,
+      IsScalarTower.algebraMap_apply K E v.adicCompletion c]
+    refine mul_mem ?_ hx
+    exact (kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff v _).mpr
+      (v.algebraMap_mem' c)
+  rw [kwHgfV352_localResidueCompletion_spec v _ hcx,
+    kwHgfV352_localResidueCompletion_spec v _ hx, map_smul]
+
+end LinearWrappers
+end KwF4R1V394a
+end ModularCurve
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateAgreement.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateAgreement.Submodule IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsLocalRing"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4gRRTate \
+  ModularCurve.Lg37 P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.Lg37 \
+  P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4R1V410a"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwTateRR3
+p2m_open "ModularCurve"
+
+section CohenSectionHat
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+
+def cohenSectionHat (u : Place K L) (S : Lg37CompletionSection u) :
+    u.ResidueField →ₐ[K] u.adicCompletion where
+  toRingHom :=
+    (u.adicCompletionIntegers.subtype).comp
+      ((kwF4R1V410a_ringEquiv u).toRingHom.comp S.lift.toRingHom)
+  commutes' c := by
+    change ((kwF4R1V410a_ringEquiv u (S.lift (algebraMap K u.ResidueField c))
+        : u.adicCompletionIntegers) : u.adicCompletion)
+      = algebraMap K u.adicCompletion c
+    rw [S.lift.commutes c,
+      IsScalarTower.algebraMap_apply K u.toValuationSubring (lg37_completion u) c,
+      kwF4R1V410a_ringEquiv_of u,
+      IsScalarTower.algebraMap_apply K L u.adicCompletion c]
+    rfl
+
+theorem cohenSectionHat_apply (u : Place K L) (S : Lg37CompletionSection u)
+    (a : u.ResidueField) :
+    cohenSectionHat u S a
+      = ((kwF4R1V410a_ringEquiv u (S.lift a) : u.adicCompletionIntegers)
+          : u.adicCompletion) := rfl
+
+theorem cohenSectionHat_mem_integers (u : Place K L) (S : Lg37CompletionSection u)
+    (a : u.ResidueField) :
+    cohenSectionHat u S a ∈ u.adicCompletionIntegers :=
+  (kwF4R1V410a_ringEquiv u (S.lift a)).2
+
+theorem cohenSectionHat_mem_adicIntegersKSubmod (u : Place K L)
+    (S : Lg37CompletionSection u) (a : u.ResidueField) :
+    cohenSectionHat u S a ∈ adicIntegersKSubmod u :=
+  cohenSectionHat_mem_integers u S a
+
+theorem cohenSectionHat_injective (u : Place K L) (S : Lg37CompletionSection u) :
+    Function.Injective (cohenSectionHat u S) :=
+  (cohenSectionHat u S).toRingHom.injective
+
+end CohenSectionHat
+
+section CohenProjC
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+def cohenProjC (B : Submodule K u.adicCompletion)
+    (hcompl : IsCompl (adicIntegersKSubmod u) B) :
+    u.adicCompletion →ₗ[K] u.adicCompletion :=
+  (adicIntegersKSubmod u).subtype ∘ₗ Submodule.projectionOnto (adicIntegersKSubmod u) B hcompl
+
+theorem cohenProjC_mem_integers (B : Submodule K u.adicCompletion)
+    (hcompl : IsCompl (adicIntegersKSubmod u) B) (x : u.adicCompletion) :
+    cohenProjC u B hcompl x ∈ u.adicCompletionIntegers :=
+  (Submodule.projectionOnto (adicIntegersKSubmod u) B hcompl x).2
+
+theorem cohenProjC_of_mem (B : Submodule K u.adicCompletion)
+    (hcompl : IsCompl (adicIntegersKSubmod u) B) {x : u.adicCompletion}
+    (hx : x ∈ u.adicCompletionIntegers) :
+    cohenProjC u B hcompl x = x :=
+  congrArg Subtype.val (Submodule.projectionOnto_apply_left hcompl ⟨x, hx⟩)
+
+theorem cohenProjC_of_mem_B (B : Submodule K u.adicCompletion)
+    (hcompl : IsCompl (adicIntegersKSubmod u) B) {x : u.adicCompletion}
+    (hx : x ∈ B) :
+    cohenProjC u B hcompl x = 0 :=
+  congrArg Subtype.val (Submodule.projectionOnto_apply_right hcompl ⟨x, hx⟩)
+
+theorem cohenProjC_idem (B : Submodule K u.adicCompletion)
+    (hcompl : IsCompl (adicIntegersKSubmod u) B) (x : u.adicCompletion) :
+    cohenProjC u B hcompl (cohenProjC u B hcompl x) = cohenProjC u B hcompl x :=
+  cohenProjC_of_mem u B hcompl (cohenProjC_mem_integers u B hcompl x)
+
+theorem range_cohenProjC (B : Submodule K u.adicCompletion)
+    (hcompl : IsCompl (adicIntegersKSubmod u) B) :
+    LinearMap.range (cohenProjC u B hcompl) = adicIntegersKSubmod u :=
+  le_antisymm (fun _ ⟨y, hy⟩ => hy ▸ cohenProjC_mem_integers u B hcompl y)
+    (fun x hx => ⟨x, cohenProjC_of_mem u B hcompl hx⟩)
+
+theorem sub_cohenProjC_mem_B (B : Submodule K u.adicCompletion)
+    (hcompl : IsCompl (adicIntegersKSubmod u) B) (x : u.adicCompletion) :
+    x - cohenProjC u B hcompl x ∈ B := by
+  have htop : x ∈ adicIntegersKSubmod u ⊔ B := by
+    rw [hcompl.sup_eq_top]; exact Submodule.mem_top
+  obtain ⟨a, ha, b, hb, hab⟩ := Submodule.mem_sup.mp htop
+  subst hab
+  rw [map_add, cohenProjC_of_mem u B hcompl ha,
+    cohenProjC_of_mem_B u B hcompl hb, add_zero, add_sub_cancel_left]
+  exact hb
+
+end CohenProjC
+
+section SingleTerm
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable (B : Submodule K u.adicCompletion) (hcompl : IsCompl (adicIntegersKSubmod u) B)
+
+theorem cohenTateCommRestrict_single_term (fh : u.adicCompletion)
+    (a : LinearMap.range (cohenProjC u B hcompl)) :
+    (tateCommRestrict (cohenProjC u B hcompl) (lmulK u fh)
+        (lmulK u (algebraMap L u.adicCompletion u.uniformizer)) a
+      : u.adicCompletion)
+    = cohenProjC u B hcompl
+        (algebraMap L u.adicCompletion u.uniformizer
+          * (fh * (a : u.adicCompletion)
+              - cohenProjC u B hcompl (fh * (a : u.adicCompletion)))) := by
+  have haInt : (a : u.adicCompletion) ∈ u.adicCompletionIntegers :=
+    (range_cohenProjC u B hcompl ▸ a.2 :
+      (a : u.adicCompletion) ∈ adicIntegersKSubmod u)
+  have hπ : algebraMap L u.adicCompletion u.uniformizer ∈ u.adicCompletionIntegers :=
+    (kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff u _).mpr u.uniformizer_mem
+  have hcomm : lmulK u fh ∘ₗ lmulK u (algebraMap L u.adicCompletion u.uniformizer)
+      = lmulK u (algebraMap L u.adicCompletion u.uniformizer) ∘ₗ lmulK u fh := by
+    refine LinearMap.ext fun x => ?_
+    change fh * (algebraMap L u.adicCompletion u.uniformizer * x) =
+      algebraMap L u.adicCompletion u.uniformizer * (fh * x)
+    ring
+  rw [tateCommRestrict_apply, tateComm_eq_of_commute hcomm]
+  change cohenProjC u B hcompl (_ * (fh * ↑a - cohenProjC u B hcompl (fh * ↑a)))
+      - cohenProjC u B hcompl (fh * (_ * ↑a - cohenProjC u B hcompl (_ * ↑a)))
+    = cohenProjC u B hcompl (_ * (fh * ↑a - cohenProjC u B hcompl (fh * ↑a)))
+  rw [cohenProjC_of_mem u B hcompl (mul_mem hπ haInt), sub_self, mul_zero, _root_.map_zero,
+    sub_zero]
+
+end SingleTerm
+
+section CohenLaurentSpec
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable [HasCanonicalLocalResidueKStar K L]
+
+structure KwTateRR3CohenLaurentSpec (u : Place K L) [u.FiniteResidue] where
+  S : Lg37CompletionSection u
+  B : Submodule K u.adicCompletion
+  hcompl : IsCompl (adicIntegersKSubmod u) B
+  ε : B →ₗ[K] u.ResidueField
+  shift_sub_mem : ∀ z : B,
+    algebraMap L u.adicCompletion u.uniformizer * (z : u.adicCompletion)
+      - cohenSectionHat u S (ε z) ∈ B
+  ε_principalPart_mul_sectionHat : ∀ (fh : u.adicCompletion) (c : u.ResidueField),
+    ε ⟨fh * cohenSectionHat u S c
+          - cohenProjC u B hcompl (fh * cohenSectionHat u S c),
+        sub_cohenProjC_mem_B u B hcompl _⟩
+      = kwHgfV352_localResidueCompletion u fh * c
+
+variable {u : Place K L} [u.FiniteResidue] (D : KwTateRR3CohenLaurentSpec u)
+
+theorem cohenProjC_uniformizer_mul_of_mem_B {x : u.adicCompletion} (hx : x ∈ D.B) :
+    cohenProjC u D.B D.hcompl
+        (algebraMap L u.adicCompletion u.uniformizer * x)
+      = cohenSectionHat u D.S (D.ε ⟨x, hx⟩) := by
+  have hsplit : algebraMap L u.adicCompletion u.uniformizer * x
+      = cohenSectionHat u D.S (D.ε ⟨x, hx⟩)
+        + (algebraMap L u.adicCompletion u.uniformizer * x
+            - cohenSectionHat u D.S (D.ε ⟨x, hx⟩)) := (add_sub_cancel _ _).symm
+  rw [hsplit, map_add, cohenProjC_of_mem u D.B D.hcompl
+      (cohenSectionHat_mem_integers u D.S _),
+    cohenProjC_of_mem_B u D.B D.hcompl (D.shift_sub_mem ⟨x, hx⟩), add_zero]
+
+end CohenLaurentSpec
+
+section Construct
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable [HasCanonicalLocalResidueKStar K L]
+variable {u : Place K L} [u.FiniteResidue]
+
+def cohenLiftκ (D : KwTateRR3CohenLaurentSpec u) :
+    u.ResidueField →ₗ[K] LinearMap.range (cohenProjC u D.B D.hcompl) where
+  toFun c := ⟨cohenSectionHat u D.S c,
+    (range_cohenProjC u D.B D.hcompl).symm ▸
+      cohenSectionHat_mem_adicIntegersKSubmod u D.S c⟩
+  map_add' a b := Subtype.ext (map_add _ a b)
+  map_smul' r a := Subtype.ext ((cohenSectionHat u D.S).toLinearMap.map_smul r a)
+
+theorem cohenLiftκ_coe (D : KwTateRR3CohenLaurentSpec u) (c : u.ResidueField) :
+    ((cohenLiftκ D c : LinearMap.range (cohenProjC u D.B D.hcompl)) : u.adicCompletion)
+      = cohenSectionHat u D.S c := rfl
+
+theorem cohenLiftκ_injective (D : KwTateRR3CohenLaurentSpec u) :
+    Function.Injective (cohenLiftκ D) := by
+  intro a b hab
+  have hval : cohenSectionHat u D.S a = cohenSectionHat u D.S b :=
+    (cohenLiftκ_coe D a).symm.trans
+      ((congrArg Subtype.val hab).trans (cohenLiftκ_coe D b))
+  exact cohenSectionHat_injective u D.S hval
+
+def tateCohenKernelData_of_cohenLaurentSpec (D : KwTateRR3CohenLaurentSpec u) :
+    TateCohenKernelData u where
+  pC := cohenProjC u D.B D.hcompl
+  pC_idem := cohenProjC_idem u D.B D.hcompl
+  range_pC := (range_tateProj u).trans (range_cohenProjC u D.B D.hcompl).symm
+  liftκ := cohenLiftκ D
+  liftκ_inj := cohenLiftκ_injective D
+  tateComm_mem_range_liftκ fh a := by
+    have hmem := sub_cohenProjC_mem_B u D.B D.hcompl (fh * (a : u.adicCompletion))
+    refine ⟨D.ε ⟨_, hmem⟩, ?_⟩
+    apply Subtype.ext
+    rw [cohenLiftκ_coe, cohenTateCommRestrict_single_term u D.B D.hcompl fh a,
+      cohenProjC_uniformizer_mul_of_mem_B D hmem]
+  tateComm_liftκ fh c := by
+    apply Subtype.ext
+    have hmem := sub_cohenProjC_mem_B u D.B D.hcompl (fh * cohenSectionHat u D.S c)
+    rw [cohenLiftκ_coe, cohenTateCommRestrict_single_term u D.B D.hcompl fh (cohenLiftκ D c),
+      cohenLiftκ_coe, cohenProjC_uniformizer_mul_of_mem_B D hmem]
+    congr 1
+    exact D.ε_principalPart_mul_sectionHat fh c
+
+end Construct
+
+section Mint
+
+variable (K L : Type*) [Field K] [Field L] [Algebra K L]
+variable [HasCanonicalLocalResidueKStar K L]
+
+def KwTateRR3CohenLaurentSpecExists : Prop :=
+  ∀ (u : Place K L) [u.FiniteResidue], Nonempty (KwTateRR3CohenLaurentSpec u)
+
+end Mint
+
+section Headline
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable [HasCanonicalLocalResidueKStar K L]
+
+theorem kwTateRR3_cohenKernelDataExists_of_cohenLaurentSpec
+    (hD : KwTateRR3CohenLaurentSpecExists K L) :
+    KwF4gRRTateCohenKernelDataExists K L := fun u _ =>
+  (hD u).map tateCohenKernelData_of_cohenLaurentSpec
+
+end Headline
+end KwTateRR3
+end ModularCurve
+end
+end
+
+section
+
+p2m_open "Polynomial P2MW.S_AlgebraicCurve_tateAgreement.Polynomial IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsLocalRing AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve KaehlerDifferential \
+  P2MW.S_AlgebraicCurve_tateAgreement.KaehlerDifferential"
+p2m_open "ModularCurve.Lg37 P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.Lg37 \
+  ModularCurve.KwNo6Pin P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwNo6Pin \
+  ModularCurve.KwNo6Section P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwNo6Section"
+p2m_open "ModularCurve.Mp72a102T3 P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.Mp72a102T3"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwNo6HrouteR
+p2m_open "ModularCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem aCoeff_sub (v : Place K F) (S : Lg37CompletionSection v) (m : ℕ)
+    (x y : lg37_completion v) :
+    aCoeff v S m (x - y) = aCoeff v S m x - aCoeff v S m y := by
+  rw [eq_sub_iff_add_eq, ← aCoeff_add, sub_add_cancel]
+
+theorem aCoeff_uniformizerHat_pow_mul_eq_zero_of_lt (v : Place K F)
+    (S : Lg37CompletionSection v) {k m : ℕ} (hk : k < m)
+    (x : lg37_completion v) :
+    aCoeff v S k ((algebraMap v.toValuationSubring (lg37_completion v)
+      v.uniformizerSubring) ^ m * x) = 0 := by
+  obtain ⟨j, rfl⟩ := Nat.exists_eq_add_of_lt hk
+  rw [show k + j + 1 = k + (j + 1) from by omega, pow_add, mul_assoc]
+  have hsh := aCoeff_shift_pow v S 0 k
+    ((algebraMap v.toValuationSubring (lg37_completion v)
+      v.uniformizerSubring) ^ (j + 1) * x)
+  rw [Nat.zero_add] at hsh
+  rw [hsh, aCoeff_zero]
+  change lg37_residueHat v _ = 0
+  rw [pow_succ', mul_assoc, map_mul, lg37_residueHat_algebraMap,
+    (IsLocalRing.residue_eq_zero_iff _).mpr v.uniformizerSubring_mem_maximalIdeal, zero_mul]
+
+theorem taylor_choose_eq_aCoeff (v : Place K F) (S : Lg37CompletionSection v)
+    (n : ℕ) (x : lg37_completion v) {k : ℕ} (hk : k < n) :
+    Classical.choose (mp72a102_t3_sigma_taylor_expansion v S n x) k = aCoeff v S k x := by
+  set cc := Classical.choose (mp72a102_t3_sigma_taylor_expansion v S n x)
+  have hcc := Classical.choose_spec (mp72a102_t3_sigma_taylor_expansion v S n x)
+  set cc' := Classical.choose (mp72a102_t3_sigma_taylor_expansion v S (k + 1) x) with hcc'_def
+  have hcc' := Classical.choose_spec (mp72a102_t3_sigma_taylor_expansion v S (k + 1) x)
+  have hfac := mp72a102_t3_evalₐ_factor (maximalIdeal v.toValuationSubring) hk
+    (x - ∑ i ∈ Finset.range n, S.lift (cc i)
+      * algebraMap v.toValuationSubring (lg37_completion v) v.uniformizerSubring ^ i)
+  rw [hcc, _root_.map_zero] at hfac
+  have htail : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) (k + 1)
+      (∑ i ∈ Finset.Ico (k + 1) n, S.lift (cc i)
+        * algebraMap v.toValuationSubring (lg37_completion v)
+            v.uniformizerSubring ^ i) = 0 := by
+    rw [map_sum]
+    refine Finset.sum_eq_zero fun i hi => ?_
+    obtain ⟨j, rfl⟩ := Nat.exists_eq_add_of_le (Finset.mem_Ico.mp hi).1
+    have heq : S.lift (cc (k + 1 + j))
+        * algebraMap v.toValuationSubring (lg37_completion v)
+            v.uniformizerSubring ^ (k + 1 + j)
+        = algebraMap v.toValuationSubring (lg37_completion v)
+              v.uniformizerSubring ^ (k + 1)
+          * (algebraMap v.toValuationSubring (lg37_completion v)
+              v.uniformizerSubring ^ j * S.lift (cc (k + 1 + j))) := by
+      rw [pow_add]; ring
+    rw [heq]
+    exact Mp72a103T2.mp72a103_t2_evalDepth_pow_uniformizer_mul_eq_zero v (k + 1) _
+  have hhead : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) (k + 1)
+      (x - ∑ i ∈ Finset.range (k + 1), S.lift (cc i)
+        * algebraMap v.toValuationSubring (lg37_completion v)
+            v.uniformizerSubring ^ i) = 0 := by
+    have hsplit : x - ∑ i ∈ Finset.range (k + 1), S.lift (cc i)
+          * algebraMap v.toValuationSubring (lg37_completion v)
+              v.uniformizerSubring ^ i
+        = (x - ∑ i ∈ Finset.range n, S.lift (cc i)
+            * algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring ^ i)
+          + ∑ i ∈ Finset.Ico (k + 1) n, S.lift (cc i)
+            * algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring ^ i := by
+      rw [show Finset.range n = Finset.range (k + 1) ∪ Finset.Ico (k + 1) n from by
+          simp only [Finset.range_eq_Ico]
+          exact (Finset.Ico_union_Ico_eq_Ico (Nat.zero_le _) hk).symm,
+        Finset.sum_union (by
+          rw [Finset.range_eq_Ico]; exact Finset.Ico_disjoint_Ico_consecutive 0 (k + 1) n)]
+      ring
+    rw [hsplit, map_add, ← hfac, htail, add_zero]
+  have key : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) (k + 1)
+      (∑ i ∈ Finset.range (k + 1), S.lift ((fun i => cc' i - cc i) i)
+        * algebraMap v.toValuationSubring (lg37_completion v)
+            v.uniformizerSubring ^ i) = 0 := by
+    have e1 : (∑ i ∈ Finset.range (k + 1), S.lift (cc' i - cc i)
+          * algebraMap v.toValuationSubring (lg37_completion v)
+              v.uniformizerSubring ^ i)
+        = (x - ∑ i ∈ Finset.range (k + 1), S.lift (cc i)
+            * algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring ^ i)
+          - (x - ∑ i ∈ Finset.range (k + 1), S.lift (cc' i)
+            * algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring ^ i) := by
+      rw [Finset.sum_congr rfl (fun i _ => by rw [map_sub, sub_mul]),
+        Finset.sum_sub_distrib]
+      ring
+    rw [e1, map_sub, hhead, hcc', sub_zero]
+  have hzero := Mp72a103T2.mp72a103_t2_taylor_coeff_eq_zero_of_depth v S (k + 1)
+    (fun i => cc' i - cc i) key k (Nat.lt_succ_self k)
+  have h := (sub_eq_zero.mp hzero).symm
+  simp only [aCoeff, ← hcc'_def]
+  exact h
+
+theorem exists_approximant (v : Place K F) (S : Lg37CompletionSection v)
+    (a : v.ResidueField) (M : ℕ) :
+    ∃ ℓ : v.toValuationSubring, IsLocalRing.residue _ ℓ = a
+      ∧ ∀ k, 1 ≤ k → k ≤ M →
+        aCoeff v S k (algebraMap v.toValuationSubring (lg37_completion v) ℓ) = 0 := by
+  induction M with
+  | zero =>
+    obtain ⟨ℓ, hℓ⟩ := IsLocalRing.residue_surjective a
+    exact ⟨ℓ, hℓ, fun k hk1 hk0 => absurd (hk1.trans hk0) (by omega)⟩
+  | succ M ih =>
+    obtain ⟨ℓ, hres, hvan⟩ := ih
+    set b := aCoeff v S (M + 1)
+      (algebraMap v.toValuationSubring (lg37_completion v) ℓ) with hb
+    obtain ⟨n, hn⟩ := IsLocalRing.residue_surjective b
+    refine ⟨ℓ - n * v.uniformizerSubring ^ (M + 1), ?_, ?_⟩
+    · rw [map_sub, map_mul, map_pow, hres, sub_eq_self, mul_eq_zero]
+      right
+      exact pow_eq_zero_iff (by omega) |>.mpr
+        ((IsLocalRing.residue_eq_zero_iff _).mpr v.uniformizerSubring_mem_maximalIdeal)
+    · intro k hk1 hkM
+      rw [map_sub, map_mul, map_pow, aCoeff_sub,
+        mul_comm (algebraMap _ _ n) _]
+      rcases Nat.lt_or_ge k (M + 1) with hk | hk
+      · rw [hvan k hk1 (Nat.lt_succ_iff.mp hk),
+          aCoeff_uniformizerHat_pow_mul_eq_zero_of_lt v S hk, sub_zero]
+      · have hkeq : k = M + 1 := le_antisymm hkM hk
+        subst hkeq
+        rw [← hb]
+        have hsh := aCoeff_shift_pow v S 0 (M + 1)
+          (algebraMap v.toValuationSubring (lg37_completion v) n)
+        rw [Nat.zero_add] at hsh
+        rw [hsh, aCoeff_zero, lg37_residueHat_algebraMap, hn, sub_self]
+
+end KwNo6HrouteR
+end ModularCurve
+end
+end
+
+section
+
+p2m_open_scoped "PadicInt P2MW.S_AlgebraicCurve_tateAgreement.PadicInt AlgebraicGeometry \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicGeometry"
+p2m_open "BigOperators P2MW.S_AlgebraicCurve_tateAgreement.BigOperators CategoryTheory \
+  P2MW.S_AlgebraicCurve_tateAgreement.CategoryTheory AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve"
+p2m_open "CategoryTheory P2MW.S_AlgebraicCurve_tateAgreement.CategoryTheory CategoryTheory.Limits \
+  P2MW.S_AlgebraicCurve_tateAgreement.CategoryTheory.Limits AlgebraicGeometry \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicGeometry \
+  P2MW.S_AlgebraicCurve_tateAgreement.NeronModelInfra"
+p2m_open "ModularCurve P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve \
+  P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwOdaDHDR Order \
+  P2MW.S_AlgebraicCurve_tateAgreement.Order Topology P2MW.S_AlgebraicCurve_tateAgreement.Topology"
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve Module \
+  P2MW.S_AlgebraicCurve_tateAgreement.Module CongruenceSubgroup \
+  P2MW.S_AlgebraicCurve_tateAgreement.CongruenceSubgroup"
+p2m_open "AlgebraicCurve.RationalFunctionField \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.RationalFunctionField"
+p2m_open_scoped "TensorProduct P2MW.S_AlgebraicCurve_tateAgreement.TensorProduct"
+p2m_open "IntermediateField P2MW.S_AlgebraicCurve_tateAgreement.IntermediateField \
+  AlgebraicCurve.RationalFunctionField \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.RationalFunctionField"
+p2m_open "AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place"
+p2m_open "ModularCurve.KwNo6Pin P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwNo6Pin"
+open ModularCurve.KwNo6HrouteR
+p2m_open "ModularCurve.Lg37 P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.Lg37 \
+  ModularCurve.Mp72a102T3 P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.Mp72a102T3 Mp72a103T2 \
+  P2MW.S_AlgebraicCurve_tateAgreement.Mp72a103T2 Mp72a102T1 \
+  P2MW.S_AlgebraicCurve_tateAgreement.Mp72a102T1"
+p2m_open "ModularCurve.KwNo6Section P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwNo6Section"
+p2m_open "IsLocalRing P2MW.S_AlgebraicCurve_tateAgreement.IsLocalRing Module.IsLocalRing"
+p2m_open_scoped "Polynomial P2MW.S_AlgebraicCurve_tateAgreement.Polynomial \
+  AlgebraicGeometry.Polynomial"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwOdaDHDR
+p2m_open "ModularCurve"
+
+section Generic
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem kwHgf_v277_aCoeff_section_lift_mul (v : Place K F)
+    (S : Lg37CompletionSection v) (m : ℕ) (a : v.ResidueField)
+    (x : lg37_completion v) :
+    aCoeff v S m (S.lift a * x) = a * aCoeff v S m x := by
+  have hx := Classical.choose_spec (mp72a102_t3_sigma_taylor_expansion v S (m + 1) x)
+  have hax' := Classical.choose_spec
+    (mp72a102_t3_sigma_taylor_expansion v S (m + 1) (S.lift a * x))
+  set ax := Classical.choose (mp72a102_t3_sigma_taylor_expansion v S (m + 1) x)
+    with hax_def
+  set aax := Classical.choose
+    (mp72a102_t3_sigma_taylor_expansion v S (m + 1) (S.lift a * x)) with haax_def
+  have hsmul : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) (m + 1)
+      ((S.lift a * x)
+        - ∑ i ∈ Finset.range (m + 1),
+            S.lift ((fun i => a * ax i) i)
+          * algebraMap v.toValuationSubring (lg37_completion v)
+              v.uniformizerSubring ^ i) = 0 := by
+    have e : (S.lift a * x)
+          - ∑ i ∈ Finset.range (m + 1), S.lift (a * ax i)
+            * algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring ^ i
+        = S.lift a
+          * (x - ∑ i ∈ Finset.range (m + 1), S.lift (ax i)
+              * algebraMap v.toValuationSubring (lg37_completion v)
+                  v.uniformizerSubring ^ i) := by
+      rw [mul_sub, Finset.mul_sum]
+      congr 1
+      refine Finset.sum_congr rfl (fun i _ => ?_)
+      rw [map_mul, mul_assoc]
+    rw [e, mp72a102_t3_evalDepth_mul, hx, mul_zero]
+  have key : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) (m + 1)
+      (∑ i ∈ Finset.range (m + 1),
+          S.lift ((fun i => a * ax i - aax i) i)
+        * algebraMap v.toValuationSubring (lg37_completion v)
+            v.uniformizerSubring ^ i) = 0 := by
+    have e1 : (∑ i ∈ Finset.range (m + 1),
+            S.lift (a * ax i - aax i)
+          * algebraMap v.toValuationSubring (lg37_completion v)
+              v.uniformizerSubring ^ i)
+        = ((S.lift a * x)
+            - ∑ i ∈ Finset.range (m + 1), S.lift (aax i)
+              * algebraMap v.toValuationSubring (lg37_completion v)
+                  v.uniformizerSubring ^ i)
+          - ((S.lift a * x)
+            - ∑ i ∈ Finset.range (m + 1), S.lift (a * ax i)
+              * algebraMap v.toValuationSubring (lg37_completion v)
+                  v.uniformizerSubring ^ i) := by
+      rw [Finset.sum_congr rfl (fun i _ => by rw [map_sub, sub_mul]),
+        Finset.sum_sub_distrib]
+      ring
+    rw [e1, map_sub, hax', hsmul, sub_zero]
+  have hzero := mp72a103_t2_taylor_coeff_eq_zero_of_depth v S (m + 1)
+    (fun i => a * ax i - aax i) key m (Nat.lt_succ_self m)
+  have han : aax m = a * ax m := (sub_eq_zero.mp hzero).symm
+  simp only [aCoeff, ← hax_def, ← haax_def]
+  exact han
+
+end Generic
+end KwOdaDHDR
+end ModularCurve
+end
+end
+
+section
+
+p2m_open_scoped "PadicInt P2MW.S_AlgebraicCurve_tateAgreement.PadicInt AlgebraicGeometry \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicGeometry"
+p2m_open "BigOperators P2MW.S_AlgebraicCurve_tateAgreement.BigOperators CategoryTheory \
+  P2MW.S_AlgebraicCurve_tateAgreement.CategoryTheory AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve"
+p2m_open "CategoryTheory P2MW.S_AlgebraicCurve_tateAgreement.CategoryTheory CategoryTheory.Limits \
+  P2MW.S_AlgebraicCurve_tateAgreement.CategoryTheory.Limits AlgebraicGeometry \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicGeometry \
+  P2MW.S_AlgebraicCurve_tateAgreement.NeronModelInfra"
+p2m_open "ModularCurve P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve \
+  P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwOdaDHDR Order \
+  P2MW.S_AlgebraicCurve_tateAgreement.Order Topology P2MW.S_AlgebraicCurve_tateAgreement.Topology"
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve Module \
+  P2MW.S_AlgebraicCurve_tateAgreement.Module CongruenceSubgroup \
+  P2MW.S_AlgebraicCurve_tateAgreement.CongruenceSubgroup"
+p2m_open "AlgebraicCurve.RationalFunctionField \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.RationalFunctionField"
+p2m_open_scoped "TensorProduct P2MW.S_AlgebraicCurve_tateAgreement.TensorProduct"
+p2m_open "IntermediateField P2MW.S_AlgebraicCurve_tateAgreement.IntermediateField \
+  AlgebraicCurve.RationalFunctionField \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.RationalFunctionField"
+p2m_open "AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place"
+p2m_open "ModularCurve.KwNo6Pin P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwNo6Pin"
+open ModularCurve.KwNo6HrouteR
+p2m_open "ModularCurve.Lg37 P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.Lg37 \
+  ModularCurve.Mp72a102T3 P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.Mp72a102T3 Mp72a103T2 \
+  P2MW.S_AlgebraicCurve_tateAgreement.Mp72a103T2 Mp72a102T1 \
+  P2MW.S_AlgebraicCurve_tateAgreement.Mp72a102T1"
+p2m_open "ModularCurve.KwNo6Section P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwNo6Section"
+p2m_open "IsLocalRing P2MW.S_AlgebraicCurve_tateAgreement.IsLocalRing Module.IsLocalRing"
+p2m_open_scoped "Polynomial P2MW.S_AlgebraicCurve_tateAgreement.Polynomial \
+  AlgebraicGeometry.Polynomial"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwOdaDHDR
+p2m_open "ModularCurve"
+
+section Generic
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem kwHgf_v278_aCoeff_eq_zero_of_evalDepth_zero (v : Place K F)
+    (S : Lg37CompletionSection v) {n : ℕ} (w : lg37_completion v)
+    (hw : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) n w = 0)
+    {k : ℕ} (hk : k < n) :
+    aCoeff v S k w = 0 := by
+  have hspec := Classical.choose_spec (mp72a102_t3_sigma_taylor_expansion v S n w)
+  set cc := Classical.choose (mp72a102_t3_sigma_taylor_expansion v S n w) with hcc_def
+  have hsum : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) n
+      (∑ i ∈ Finset.range n, S.lift ((fun i => cc i) i)
+        * algebraMap v.toValuationSubring (lg37_completion v)
+            v.uniformizerSubring ^ i) = 0 := by
+    have e : (∑ i ∈ Finset.range n, S.lift (cc i)
+          * algebraMap v.toValuationSubring (lg37_completion v)
+              v.uniformizerSubring ^ i)
+        = w - (w - ∑ i ∈ Finset.range n, S.lift (cc i)
+            * algebraMap v.toValuationSubring (lg37_completion v)
+                v.uniformizerSubring ^ i) := by ring
+    simp only at e ⊢
+    rw [e, map_sub, hw, hspec, sub_zero]
+  have hzero := mp72a103_t2_taylor_coeff_eq_zero_of_depth v S n
+    (fun i => cc i) hsum k hk
+  rw [← taylor_choose_eq_aCoeff v S n w hk, ← hcc_def]
+  exact hzero
+
+theorem kwHgf_v278_resStar_approximant_mul (v : Place K F)
+    (S : Lg37CompletionSection v) (ℓ : v.toValuationSubring) (M : ℕ)
+    (hvan : ∀ k, 1 ≤ k → k ≤ M →
+      aCoeff v S k (algebraMap v.toValuationSubring (lg37_completion v) ℓ) = 0)
+    (g : F) (hg : g ∈ v.poleSubmodule (M + 1)) :
+    resStar v S ((ℓ : F) * g) = IsLocalRing.residue _ ℓ * resStar v S g := by
+  set a := IsLocalRing.residue _ ℓ with ha
+  have hgN : (-v.ord g).toNat ≤ M + 1 := by
+    rcases eq_or_ne g 0 with rfl | hg0
+    · rw [v.ord_zero]; simp
+    · have := (v.mem_poleSubmodule_iff_ord hg0).mp hg
+      omega
+  have hlgN : (-v.ord ((ℓ : F) * g)).toNat ≤ M + 1 := by
+    rcases eq_or_ne ((ℓ : F) * g) 0 with h0 | hlg0
+    · rw [h0, v.ord_zero]; simp
+    · have hg0 : g ≠ 0 := right_ne_zero_of_mul hlg0
+      have hl0 : (ℓ : F) ≠ 0 := left_ne_zero_of_mul hlg0
+      have hge := (v.mem_poleSubmodule_iff_ord hg0).mp hg
+      have hlge : (0 : ℤ) ≤ v.ord (ℓ : F) := (v.mem_iff_ord_nonneg hl0).mp ℓ.2
+      rw [v.ord_mul hl0 hg0]
+      omega
+  rw [← aCoeff_clearedHat_of_le v S ((ℓ : F) * g) hlgN,
+    ← aCoeff_clearedHat_of_le v S g hgN]
+  set x := clearedHat v g hgN with hx_def
+  have hιℓx : clearedHat v ((ℓ : F) * g) hlgN
+      = algebraMap v.toValuationSubring (lg37_completion v) ℓ * x := by
+    rw [hx_def]
+    unfold clearedHat
+    rw [← map_mul]
+    congr 1
+    apply Subtype.ext
+    push_cast
+    ring
+  rw [hιℓx]
+  have hsplit : algebraMap v.toValuationSubring (lg37_completion v) ℓ * x
+      = S.lift a * x
+        + (algebraMap v.toValuationSubring (lg37_completion v) ℓ - S.lift a) * x := by
+    ring
+  rw [hsplit, aCoeff_add]
+  rw [kwHgf_v277_aCoeff_section_lift_mul v S (M + 1) a x]
+  suffices hsnd : aCoeff v S (M + 1)
+      ((algebraMap v.toValuationSubring (lg37_completion v) ℓ - S.lift a) * x)
+      = 0 by rw [hsnd, add_zero]
+  set x' := algebraMap v.toValuationSubring (lg37_completion v)
+    ⟨v.uniformizer ^ (M + 1) * g, (v.mem_poleSubmodule).mp hg⟩ with hx'_def
+  have hxfac : x = algebraMap v.toValuationSubring (lg37_completion v)
+      v.uniformizerSubring * x' := by
+    rw [hx_def, hx'_def]
+    unfold clearedHat
+    rw [← map_mul]
+    congr 1
+    apply Subtype.ext
+    push_cast [v.coe_uniformizerSubring]
+    ring
+  rw [hxfac, show
+    (algebraMap v.toValuationSubring (lg37_completion v) ℓ - S.lift a)
+        * (algebraMap v.toValuationSubring (lg37_completion v)
+            v.uniformizerSubring * x')
+      = algebraMap v.toValuationSubring (lg37_completion v) v.uniformizerSubring
+        * ((algebraMap v.toValuationSubring (lg37_completion v) ℓ - S.lift a)
+          * x') from by ring,
+    aCoeff_shift]
+  have hev : AdicCompletion.evalₐ (maximalIdeal v.toValuationSubring) (M + 1)
+      (algebraMap v.toValuationSubring (lg37_completion v) ℓ - S.lift a) = 0 := by
+    have hspec := Classical.choose_spec
+      (mp72a102_t3_sigma_taylor_expansion v S (M + 1)
+        (algebraMap v.toValuationSubring (lg37_completion v) ℓ))
+    set cc := Classical.choose (mp72a102_t3_sigma_taylor_expansion v S (M + 1)
+        (algebraMap v.toValuationSubring (lg37_completion v) ℓ)) with hcc_def
+    have hcc : ∀ k, k < M + 1 → cc k
+        = aCoeff v S k (algebraMap v.toValuationSubring (lg37_completion v) ℓ) :=
+      fun k hk => hcc_def ▸ taylor_choose_eq_aCoeff v S (M + 1) _ hk
+    suffices hsum : (∑ i ∈ Finset.range (M + 1), S.lift (cc i)
+        * algebraMap v.toValuationSubring (lg37_completion v)
+            v.uniformizerSubring ^ i) = S.lift a by
+      rw [← hsum]; exact hspec
+    rw [Finset.sum_eq_single 0
+      (fun i hi hi0 => by
+        rw [hcc i (Finset.mem_range.mp hi),
+          hvan i (Nat.one_le_iff_ne_zero.mpr hi0)
+            (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)),
+          _root_.map_zero, zero_mul])
+      (fun h => absurd (Finset.mem_range.mpr (by omega)) h),
+      pow_zero, mul_one, hcc 0 (by omega), aCoeff_zero,
+      lg37_residueHat_algebraMap, ← ha]
+  exact kwHgf_v278_aCoeff_eq_zero_of_evalDepth_zero v S
+    ((algebraMap v.toValuationSubring (lg37_completion v) ℓ - S.lift a) * x')
+    (by rw [map_mul, hev, zero_mul]) (Nat.lt_succ_self M)
+
+end Generic
+end KwOdaDHDR
+end ModularCurve
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateAgreement.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateAgreement.Submodule IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsLocalRing"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4gRRTate \
+  ModularCurve.Lg37 P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.Lg37 \
+  P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4R1V410a"
+p2m_open "P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwTateRR3 ModularCurve.KwNo6Pin \
+  P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwNo6Pin \
+  P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwNo6HrouteR"
+p2m_open "ModularCurve.Mp72a102T3 P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.Mp72a102T3 \
+  P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwOdaDHDR \
+  P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4R1V394a"
+p2m_open "Mp72a103T2 P2MW.S_AlgebraicCurve_tateAgreement.Mp72a103T2 IsDedekindDomain \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain.HeightOneSpectrum WithZero \
+  P2MW.S_AlgebraicCurve_tateAgreement.WithZero"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwTateRR3
+p2m_open "ModularCurve"
+
+section ApproximantHev
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+
+theorem approximant_evalₐ_sub_lift_eq_zero (u : Place K L) (S : Lg37CompletionSection u)
+    {ℓ : u.toValuationSubring} {M : ℕ}
+    (hvan : ∀ k, 1 ≤ k → k ≤ M →
+      aCoeff u S k (algebraMap u.toValuationSubring (lg37_completion u) ℓ) = 0) :
+    AdicCompletion.evalₐ (maximalIdeal u.toValuationSubring) (M + 1)
+      (algebraMap u.toValuationSubring (lg37_completion u) ℓ
+        - S.lift (IsLocalRing.residue _ ℓ)) = 0 := by
+  set a := IsLocalRing.residue _ ℓ with ha
+  have hspec := Classical.choose_spec
+    (mp72a102_t3_sigma_taylor_expansion u S (M + 1)
+      (algebraMap u.toValuationSubring (lg37_completion u) ℓ))
+  set cc := Classical.choose (mp72a102_t3_sigma_taylor_expansion u S (M + 1)
+      (algebraMap u.toValuationSubring (lg37_completion u) ℓ)) with hcc_def
+  have hcc : ∀ k, k < M + 1 → cc k
+      = aCoeff u S k (algebraMap u.toValuationSubring (lg37_completion u) ℓ) :=
+    fun k hk => hcc_def ▸ taylor_choose_eq_aCoeff u S (M + 1) _ hk
+  suffices hsum : (∑ i ∈ Finset.range (M + 1), S.lift (cc i)
+      * algebraMap u.toValuationSubring (lg37_completion u)
+          u.uniformizerSubring ^ i) = S.lift a by
+    rw [← hsum]; exact hspec
+  rw [Finset.sum_eq_single 0
+    (fun i hi hi0 => by
+      rw [hcc i (Finset.mem_range.mp hi),
+        hvan i (Nat.one_le_iff_ne_zero.mpr hi0)
+          (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)),
+        _root_.map_zero, zero_mul])
+    (fun h => absurd (Finset.mem_range.mpr (by omega)) h),
+    pow_zero, mul_one, hcc 0 (by omega), aCoeff_zero,
+    lg37_residueHat_algebraMap, ← ha]
+
+end ApproximantHev
+
+section V410aBridge
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem v410a_mem_completionIdeal_pow_of_evalₐ_eq_zero (n : ℕ)
+    (z : lg37_completion u)
+    (hz : AdicCompletion.evalₐ (maximalIdeal u.toValuationSubring) n z = 0) :
+    kwF4R1V410a_ringEquiv u z ∈ (u.heightOneSpectrum.completionIdeal L) ^ n := by
+  rw [← Ideal.Quotient.eq_zero_iff_mem, kwF4R1V410a_ringEquiv_apply,
+    kwF4R1V410a_mk_forward u n z, hz, _root_.map_zero]
+
+theorem valued_algebraMap_uniformizer :
+    Valued.v (algebraMap L u.adicCompletion u.uniformizer) = WithZero.exp (-1 : ℤ) := by
+  rw [show algebraMap L u.adicCompletion u.uniformizer
+      = ((u.uniformizer : L) : u.adicCompletion) from rfl,
+    valuedAdicCompletion_eq_valuation' (K := L) u.heightOneSpectrum,
+    show u.heightOneSpectrum.valuation L u.uniformizer = u.adicValuation u.uniformizer
+      from rfl,
+    show u.adicValuation u.uniformizer = WithZero.exp (-(u.ord u.uniformizer)) from by
+      rw [Place.ord, neg_neg,
+        WithZero.exp_log (u.adicValuation_ne_zero u.uniformizer_ne_zero)],
+    u.ord_uniformizer]
+
+theorem v410a_evalDepth_mul_mem_integers (n : ℕ) (z : lg37_completion u)
+    (hz : AdicCompletion.evalₐ (maximalIdeal u.toValuationSubring) n z = 0)
+    (fh : u.adicCompletion)
+    (hfh : (algebraMap L u.adicCompletion u.uniformizer) ^ n * fh ∈ u.adicCompletionIntegers) :
+    ((kwF4R1V410a_ringEquiv u z : u.adicCompletionIntegers) : u.adicCompletion) * fh
+      ∈ u.adicCompletionIntegers := by
+  rw [mem_adicCompletionIntegers, map_mul]
+  have hzmem := v410a_mem_completionIdeal_pow_of_evalₐ_eq_zero u n z hz
+  have hzval : Valued.v
+      ((kwF4R1V410a_ringEquiv u z : u.adicCompletionIntegers) : u.adicCompletion)
+      ≤ WithZero.exp (-(n : ℤ)) := by
+    rw [WithZero.exp_eq_coe_ofAdd]
+    exact (adicCompletion.mem_completionIdeal_pow L u.heightOneSpectrum
+      (kwF4R1V410a_ringEquiv u z)).mp hzmem
+  have hπval : Valued.v ((algebraMap L u.adicCompletion u.uniformizer) ^ n)
+      = WithZero.exp (-(n : ℤ)) := by
+    rw [map_pow, valued_algebraMap_uniformizer u, ← WithZero.exp_nsmul]
+    congr 1; ring
+  have hfhval : Valued.v fh ≤ WithZero.exp (n : ℤ) := by
+    have h1 : Valued.v ((algebraMap L u.adicCompletion u.uniformizer) ^ n * fh) ≤ 1 := hfh
+    rw [map_mul, hπval] at h1
+    calc Valued.v fh
+        = WithZero.exp (n : ℤ) * (WithZero.exp (-(n : ℤ)) * Valued.v fh) := by
+          rw [← mul_assoc, ← WithZero.exp_add, add_neg_cancel, WithZero.exp_zero, one_mul]
+      _ ≤ WithZero.exp (n : ℤ) * 1 := mul_le_mul_of_nonneg_left h1 (zero_le)
+      _ = WithZero.exp (n : ℤ) := mul_one _
+  calc Valued.v ((kwF4R1V410a_ringEquiv u z : u.adicCompletionIntegers)
+          : u.adicCompletion) * Valued.v fh
+      ≤ WithZero.exp (-(n : ℤ)) * WithZero.exp (n : ℤ) := mul_le_mul' hzval hfhval
+    _ = WithZero.exp ((-(n : ℤ)) + (n : ℤ)) := (WithZero.exp_add _ _).symm
+    _ = 1 := by rw [_root_.neg_add_cancel, WithZero.exp_zero]
+
+end V410aBridge
+
+section EpsSpec
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable [IsCurveOver K L] [PerfectField K]
+
+theorem kwTateRR3_localResidueCompletion_sub (u : Place K L) (xh yh : u.adicCompletion) :
+    kwHgfV352_localResidueCompletion u (xh - yh)
+      = kwHgfV352_localResidueCompletion u xh
+        - kwHgfV352_localResidueCompletion u yh := by
+  rw [eq_sub_iff_add_eq, ← kwHgfV352_localResidueCompletion_add, sub_add_cancel]
+
+omit [IsCurveOver K L] [PerfectField K] in
+theorem algebraMap_sub_cohenSectionHat_eq_v410a (u : Place K L)
+    (S : Lg37CompletionSection u) (ℓ : u.toValuationSubring) :
+    algebraMap L u.adicCompletion (ℓ : L)
+        - cohenSectionHat u S (IsLocalRing.residue _ ℓ)
+      = ((kwF4R1V410a_ringEquiv u
+            (algebraMap u.toValuationSubring (lg37_completion u) ℓ
+              - S.lift (IsLocalRing.residue _ ℓ))
+          : u.adicCompletionIntegers) : u.adicCompletion) := by
+  have hℓ : algebraMap L u.adicCompletion (ℓ : L)
+      = ((kwF4R1V410a_ringEquiv u
+            (algebraMap u.toValuationSubring (lg37_completion u) ℓ)
+          : u.adicCompletionIntegers) : u.adicCompletion) := by
+    rw [kwF4R1V410a_ringEquiv_of u ℓ]; rfl
+  rw [hℓ, cohenSectionHat_apply, map_sub]
+  exact (AddSubgroupClass.coe_sub _ _).symm
+
+theorem localResidueCompletion_mul_cohenSectionHat
+    (u : Place K L) (S : Lg37CompletionSection u)
+    (fh : u.adicCompletion) (c : u.ResidueField) :
+    kwHgfV352_localResidueCompletion u (fh * cohenSectionHat u S c)
+      = kwHgfV352_localResidueCompletion u fh * c := by
+  obtain ⟨f, hf⟩ := kwHgfV352_exists_sub_mem_adicCompletionIntegers u fh
+  rcases (em (f ∈ u.toValuationSubring)) with hfmem | hfnmem
+  · have hfh_mem : fh ∈ u.adicCompletionIntegers := by
+      have hfhat : algebraMap L u.adicCompletion f ∈ u.adicCompletionIntegers :=
+        (kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff u f).mpr hfmem
+      have hsub : algebraMap L u.adicCompletion f
+          - (algebraMap L u.adicCompletion f - fh) = fh := by ring
+      exact hsub ▸ sub_mem hfhat hf
+    rw [kwHgfV352_localResidueCompletion_eq_zero_of_mem_integers u hfh_mem, zero_mul,
+      kwHgfV352_localResidueCompletion_eq_zero_of_mem_integers u
+        (mul_mem hfh_mem (cohenSectionHat_mem_integers u S c))]
+  have hf0 : f ≠ 0 := fun h => hfnmem (h ▸ zero_mem _)
+  have hord_neg : u.ord f < 0 :=
+    not_le.mp (fun h => hfnmem ((u.mem_iff_ord_nonneg hf0).mpr h))
+  set M := (-u.ord f).toNat with hM_def
+  have hM_eq : (M : ℤ) = -u.ord f := Int.toNat_of_nonneg (by omega)
+  have hfpole : f ∈ u.poleSubmodule (M + 1) := by
+    rw [u.mem_poleSubmodule_iff_ord hf0]; omega
+  obtain ⟨ℓ, hℓres, hℓvan⟩ := exists_approximant u S c M
+  have hV278 : resStar u S ((ℓ : L) * f) = c * resStar u S f := by
+    rw [← hℓres]
+    exact kwHgf_v278_resStar_approximant_mul u S ℓ M hℓvan f hfpole
+  have hfhLR : kwHgfV352_localResidueCompletion u fh = resStar u S f := by
+    rw [kwHgfV352_localResidueCompletion_spec u fh hf, localResidue_eq_resStar u S f]
+  have hgap : algebraMap L u.adicCompletion ((ℓ : L) * f) - fh * cohenSectionHat u S c
+      ∈ u.adicCompletionIntegers := by
+    have hℓhat_mem : algebraMap L u.adicCompletion (ℓ : L) ∈ u.adicCompletionIntegers :=
+      (kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff u _).mpr ℓ.2
+    have hfirst : algebraMap L u.adicCompletion (ℓ : L)
+        * (algebraMap L u.adicCompletion f - fh) ∈ u.adicCompletionIntegers :=
+      mul_mem hℓhat_mem hf
+    have hsecond : (algebraMap L u.adicCompletion (ℓ : L)
+        - cohenSectionHat u S c) * fh ∈ u.adicCompletionIntegers := by
+      rw [← hℓres, algebraMap_sub_cohenSectionHat_eq_v410a u S ℓ]
+      refine v410a_evalDepth_mul_mem_integers u (M + 1) _
+        (approximant_evalₐ_sub_lift_eq_zero u S hℓvan) fh ?_
+      have hπmem : algebraMap L u.adicCompletion u.uniformizer ^ (M + 1)
+          ∈ u.adicCompletionIntegers := pow_mem
+        ((kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff u _).mpr
+          u.uniformizer_mem) _
+      have hπf : algebraMap L u.adicCompletion u.uniformizer ^ (M + 1)
+          * algebraMap L u.adicCompletion f ∈ u.adicCompletionIntegers := by
+        rw [← map_pow, ← map_mul]
+        exact (kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff u _).mpr
+          ((u.mem_poleSubmodule).mp hfpole)
+      have hdecomp : algebraMap L u.adicCompletion u.uniformizer ^ (M + 1) * fh
+          = algebraMap L u.adicCompletion u.uniformizer ^ (M + 1)
+              * algebraMap L u.adicCompletion f
+            - algebraMap L u.adicCompletion u.uniformizer ^ (M + 1)
+              * (algebraMap L u.adicCompletion f - fh) := by ring
+      rw [hdecomp]; exact sub_mem hπf (mul_mem hπmem hf)
+    have hdecomp : algebraMap L u.adicCompletion ((ℓ : L) * f)
+          - fh * cohenSectionHat u S c
+        = algebraMap L u.adicCompletion (ℓ : L)
+            * (algebraMap L u.adicCompletion f - fh)
+          + (algebraMap L u.adicCompletion (ℓ : L)
+              - cohenSectionHat u S c) * fh := by
+      rw [map_mul]; ring
+    rw [hdecomp]; exact add_mem hfirst hsecond
+  rw [kwHgfV352_localResidueCompletion_spec u _ hgap,
+    localResidue_eq_resStar u S ((ℓ : L) * f), hV278, hfhLR, mul_comm]
+
+end EpsSpec
+
+section ComplMint
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable [HasCanonicalLocalResidueKStar K L]
+
+structure KwTateRR3CohenLaurentCompl (u : Place K L) [u.FiniteResidue] where
+  S : Lg37CompletionSection u
+  B : Submodule K u.adicCompletion
+  hcompl : IsCompl (adicIntegersKSubmod u) B
+  shift_sub_mem : ∀ z : B,
+    algebraMap L u.adicCompletion u.uniformizer * (z : u.adicCompletion)
+      - cohenSectionHat u S (kwHgfV352_localResidueCompletion u (z : u.adicCompletion)) ∈ B
+
+variable (K L) in
+def KwTateRR3CohenLaurentComplExists : Prop :=
+  ∀ (u : Place K L) [u.FiniteResidue], Nonempty (KwTateRR3CohenLaurentCompl u)
+
+end ComplMint
+
+section Construct
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable [IsCurveOver K L] [PerfectField K]
+variable {u : Place K L} [u.FiniteResidue]
+
+def localResidueCompletionₗ (u : Place K L) : u.adicCompletion →ₗ[K] u.ResidueField where
+  toFun := kwHgfV352_localResidueCompletion u
+  map_add' := kwHgfV352_localResidueCompletion_add u
+  map_smul' c x := by
+    rw [RingHom.id_apply]; exact kwF4R1V394a_localResidueCompletion_smul u c x
+
+def cohenLaurentSpec_of_compl (C : KwTateRR3CohenLaurentCompl u) :
+    KwTateRR3CohenLaurentSpec u where
+  S := C.S
+  B := C.B
+  hcompl := C.hcompl
+  ε := (localResidueCompletionₗ u).comp C.B.subtype
+  shift_sub_mem z := C.shift_sub_mem z
+  ε_principalPart_mul_sectionHat fh c := by
+    change kwHgfV352_localResidueCompletion u
+        (fh * cohenSectionHat u C.S c
+          - cohenProjC u C.B C.hcompl (fh * cohenSectionHat u C.S c))
+      = kwHgfV352_localResidueCompletion u fh * c
+    rw [kwTateRR3_localResidueCompletion_sub u,
+      kwHgfV352_localResidueCompletion_eq_zero_of_mem_integers u
+        (cohenProjC_mem_integers u C.B C.hcompl _),
+      sub_zero, localResidueCompletion_mul_cohenSectionHat u C.S fh c]
+
+end Construct
+
+section Headline
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable [IsCurveOver K L] [PerfectField K]
+
+theorem kwTateRR3_cohenLaurentSpecExists_of_complExists
+    (hC : KwTateRR3CohenLaurentComplExists K L) :
+    KwTateRR3CohenLaurentSpecExists K L := fun u _ =>
+  (hC u).map cohenLaurentSpec_of_compl
+
+theorem kwTateRR3_cohenKernelDataExists_of_complExists
+    (hC : KwTateRR3CohenLaurentComplExists K L) :
+    KwF4gRRTateCohenKernelDataExists K L :=
+  kwTateRR3_cohenKernelDataExists_of_cohenLaurentSpec
+    (kwTateRR3_cohenLaurentSpecExists_of_complExists hC)
+
+end Headline
+end KwTateRR3
+end ModularCurve
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateAgreement.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateAgreement.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateAgreement.Submodule IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsLocalRing"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4gRRTate \
+  ModularCurve.Lg37 P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.Lg37 \
+  P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwF4R1V410a"
+p2m_open "P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwTateRR3 ModularCurve.KwNo6Pin \
+  P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwNo6Pin \
+  P2MW.S_AlgebraicCurve_tateAgreement.ModularCurve.KwNo6HrouteR"
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateAgreement.IsDedekindDomain.HeightOneSpectrum WithZero \
+  P2MW.S_AlgebraicCurve_tateAgreement.WithZero"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateAgreement"
+namespace KwTateRR3
+p2m_open "ModularCurve"
+
+section UniformizerHat
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+abbrev uniformizerHat : u.adicCompletion := algebraMap L u.adicCompletion u.uniformizer
+
+theorem uniformizerHat_ne_zero : uniformizerHat u ≠ 0 :=
+  fun h => u.uniformizer_ne_zero
+    ((map_eq_zero_iff _ (algebraMap L u.adicCompletion).injective).mp h)
+
+theorem uniformizerHat_mem_integers : uniformizerHat u ∈ u.adicCompletionIntegers :=
+  (kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff u _).mpr u.uniformizer_mem
+
+theorem irreducible_uniformizerHat :
+    Irreducible (⟨uniformizerHat u, uniformizerHat_mem_integers u⟩
+      : u.adicCompletionIntegers) := by
+  refine (IsDiscreteValuationRing.irreducible_iff_uniformizer _).mpr
+    (adicCompletion.maximalIdeal_eq_span_uniformizer L u.heightOneSpectrum ?_)
+  rw [valued_algebraMap_uniformizer u, WithZero.exp_eq_coe_ofAdd]
+
+end UniformizerHat
+
+section CohenPhi
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable (S : Lg37CompletionSection u)
+
+def cohenΦ : (ℕ →₀ u.ResidueField) →ₗ[K] u.adicCompletion :=
+  Finsupp.lsum K fun j =>
+    lmulK u ((uniformizerHat u)⁻¹ ^ (j + 1)) ∘ₗ (cohenSectionHat u S).toLinearMap
+
+theorem cohenΦ_apply (δ : ℕ →₀ u.ResidueField) :
+    cohenΦ u S δ = δ.sum fun j c => (uniformizerHat u)⁻¹ ^ (j + 1) * cohenSectionHat u S c := by
+  rw [cohenΦ, Finsupp.coe_lsum]; rfl
+
+theorem cohenΦ_single (j : ℕ) (c : u.ResidueField) :
+    cohenΦ u S (Finsupp.single j c)
+      = (uniformizerHat u)⁻¹ ^ (j + 1) * cohenSectionHat u S c := by
+  rw [cohenΦ_apply, Finsupp.sum_single_index]
+  rw [_root_.map_zero, mul_zero]
+
+def cohenB : Submodule K u.adicCompletion := LinearMap.range (cohenΦ u S)
+
+theorem monomial_mem_cohenB (j : ℕ) (c : u.ResidueField) :
+    (uniformizerHat u)⁻¹ ^ (j + 1) * cohenSectionHat u S c ∈ cohenB u S :=
+  ⟨Finsupp.single j c, cohenΦ_single u S j c⟩
+
+end CohenPhi
+
+section LocResComplMonomial
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable [IsCurveOver K L] [PerfectField K] (u : Place K L)
+
+theorem locResCompl_uniformizerHat_inv (S : Lg37CompletionSection u) :
+    kwHgfV352_localResidueCompletion u ((uniformizerHat u)⁻¹) = 1 := by
+  rw [show (uniformizerHat u)⁻¹ = algebraMap L u.adicCompletion (u.uniformizer)⁻¹ from
+      (map_inv₀ (algebraMap L u.adicCompletion) _).symm,
+    kwHgfV352_localResidueCompletion_algebraMap u, localResidue_eq_resStar u S,
+    resStar_simplePole u S _
+      (by rw [mul_inv_cancel₀ u.uniformizer_ne_zero]; exact one_mem _)]
+  exact congrArg (IsLocalRing.residue _)
+    (Subtype.ext (mul_inv_cancel₀ u.uniformizer_ne_zero)) |>.trans (map_one _)
+
+theorem locResCompl_uniformizerHat_inv_pow_succ (S : Lg37CompletionSection u)
+    {j : ℕ} (hj : 1 ≤ j) :
+    kwHgfV352_localResidueCompletion u ((uniformizerHat u)⁻¹ ^ (j + 1)) = 0 := by
+  rw [show (uniformizerHat u)⁻¹ ^ (j + 1)
+        = algebraMap L u.adicCompletion (u.uniformizer ^ (j + 1))⁻¹ by
+      rw [map_inv₀ (algebraMap L u.adicCompletion), map_pow, inv_pow],
+    kwHgfV352_localResidueCompletion_algebraMap u, localResidue_eq_resStar u S,
+    resStar_higherPoleMonomial u S hj]
+
+end LocResComplMonomial
+
+section LocResComplPhi
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable [IsCurveOver K L] [PerfectField K] (u : Place K L)
+variable (S : Lg37CompletionSection u)
+
+theorem locResCompl_cohenΦ (δ : ℕ →₀ u.ResidueField) :
+    kwHgfV352_localResidueCompletion u (cohenΦ u S δ) = δ 0 := by
+  rw [show kwHgfV352_localResidueCompletion u (cohenΦ u S δ)
+      = localResidueCompletionₗ u (cohenΦ u S δ) from rfl,
+    cohenΦ_apply, map_finsuppSum]
+  refine (Finsupp.sum_eq_single 0 (fun j _ hj0 => ?_) (fun _ => ?_)).trans ?_
+  · change kwHgfV352_localResidueCompletion u _ = 0
+    rw [localResidueCompletion_mul_cohenSectionHat u S,
+      locResCompl_uniformizerHat_inv_pow_succ u S (Nat.one_le_iff_ne_zero.mpr hj0), zero_mul]
+  · change kwHgfV352_localResidueCompletion u _ = 0
+    rw [_root_.map_zero, mul_zero]
+    exact _root_.map_zero (localResidueCompletionₗ u)
+  · change kwHgfV352_localResidueCompletion u _ = _
+    rw [zero_add, pow_one, localResidueCompletion_mul_cohenSectionHat u S,
+      locResCompl_uniformizerHat_inv u S, one_mul]
+
+end LocResComplPhi
+
+section ShiftCore
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable (S : Lg37CompletionSection u)
+
+theorem uniformizerHat_mul_cohenΦ (δ : ℕ →₀ u.ResidueField) :
+    uniformizerHat u * cohenΦ u S δ
+      = δ.sum fun j c => (uniformizerHat u)⁻¹ ^ j * cohenSectionHat u S c := by
+  rw [cohenΦ_apply, Finsupp.mul_sum]
+  refine Finsupp.sum_congr fun j _ => ?_
+  rw [pow_succ', ← mul_assoc, ← mul_assoc,
+    mul_inv_cancel₀ (uniformizerHat_ne_zero u), one_mul]
+
+theorem uniformizerHat_mul_cohenΦ_sub_mem (δ : ℕ →₀ u.ResidueField) :
+    uniformizerHat u * cohenΦ u S δ - cohenSectionHat u S (δ 0) ∈ cohenB u S := by
+  rw [uniformizerHat_mul_cohenΦ u S δ, Finsupp.sum,
+    show cohenSectionHat u S (δ 0)
+        = (uniformizerHat u)⁻¹ ^ 0 * cohenSectionHat u S (δ 0) by rw [pow_zero, one_mul]]
+  have hterm : ∀ j ∈ δ.support, j ≠ 0 →
+      (uniformizerHat u)⁻¹ ^ j * cohenSectionHat u S (δ j) ∈ cohenB u S := fun j _ hj0 => by
+    obtain ⟨j', rfl⟩ := Nat.exists_eq_succ_of_ne_zero hj0
+    exact monomial_mem_cohenB u S j' (δ (j' + 1))
+  rcases em ((0 : ℕ) ∈ δ.support) with h0 | h0
+  · rw [← Finset.sum_erase_add _ _ h0, add_sub_cancel_right]
+    exact sum_mem fun j hj => hterm j (Finset.mem_of_mem_erase hj) (Finset.ne_of_mem_erase hj)
+  · rw [Finsupp.notMem_support_iff.mp h0, _root_.map_zero, mul_zero, sub_zero]
+    exact sum_mem fun j hj => hterm j hj fun hj0 => h0 (hj0 ▸ hj)
+
+end ShiftCore
+
+section Disjoint
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable (S : Lg37CompletionSection u)
+
+theorem valued_cohenSectionHat_of_ne_zero {c : u.ResidueField} (hc : c ≠ 0) :
+    Valued.v (cohenSectionHat u S c) = 1 := by
+  refine le_antisymm (cohenSectionHat_mem_integers u S c) ?_
+  have hprod : Valued.v (cohenSectionHat u S c) * Valued.v (cohenSectionHat u S c⁻¹) = 1 := by
+    rw [← map_mul, ← map_mul, mul_inv_cancel₀ hc, map_one, map_one]
+  calc (1 : ℤᵐ⁰)
+      = Valued.v (cohenSectionHat u S c) * Valued.v (cohenSectionHat u S c⁻¹) := hprod.symm
+    _ ≤ Valued.v (cohenSectionHat u S c) * 1 :=
+        mul_le_mul_right (cohenSectionHat_mem_integers u S c⁻¹) _
+    _ = Valued.v (cohenSectionHat u S c) := mul_one _
+
+theorem uniformizerHat_pow_mul_cohenΦ_sub_top (δ : ℕ →₀ u.ResidueField)
+    (hδ : δ.support.Nonempty) :
+    let J := δ.support.max' hδ
+    (uniformizerHat u) ^ (J + 1) * cohenΦ u S δ - cohenSectionHat u S (δ J)
+      = ∑ j ∈ δ.support.erase J,
+          (uniformizerHat u) ^ (J - j) * cohenSectionHat u S (δ j) := by
+  intro J
+  have hJmem : J ∈ δ.support := δ.support.max'_mem hδ
+  rw [cohenΦ_apply, Finsupp.mul_sum, Finsupp.sum,
+    ← Finset.sum_erase_add _ _ hJmem,
+    show (uniformizerHat u) ^ (J + 1) * ((uniformizerHat u)⁻¹ ^ (J + 1)
+            * cohenSectionHat u S (δ J))
+        = cohenSectionHat u S (δ J) by
+      rw [← mul_assoc, ← mul_pow, mul_inv_cancel₀ (uniformizerHat_ne_zero u), one_pow, one_mul],
+    add_sub_cancel_right]
+  refine Finset.sum_congr rfl fun j hj => ?_
+  have hjJ : j < J := lt_of_le_of_ne
+    (δ.support.le_max' j (Finset.mem_of_mem_erase hj)) (Finset.ne_of_mem_erase hj)
+  rw [← mul_assoc]
+  congr 1
+  rw [show J + 1 = (J - j) + (j + 1) by omega, pow_add, mul_assoc,
+    ← mul_pow, mul_inv_cancel₀ (uniformizerHat_ne_zero u), one_pow, mul_one]
+
+theorem cohenΦ_mem_integers_iff_zero (δ : ℕ →₀ u.ResidueField) :
+    cohenΦ u S δ ∈ u.adicCompletionIntegers → δ = 0 := by
+  intro hmem
+  by_contra hδ0
+  have hδne : δ.support.Nonempty := Finsupp.support_nonempty_iff.mpr hδ0
+  set J := δ.support.max' hδne with hJ
+  have hδJ : δ J ≠ 0 := Finsupp.mem_support_iff.mp (δ.support.max'_mem hδne)
+  have hi : Valued.v ((uniformizerHat u) ^ (J + 1) * cohenΦ u S δ)
+      ≤ WithZero.exp (-1 : ℤ) := by
+    rw [map_mul, map_pow, valued_algebraMap_uniformizer u, ← WithZero.exp_nsmul]
+    calc WithZero.exp ((J + 1) • (-1 : ℤ)) * Valued.v (cohenΦ u S δ)
+        ≤ WithZero.exp ((J + 1) • (-1 : ℤ)) * 1 := mul_le_mul_right hmem _
+      _ = WithZero.exp (-((J : ℤ) + 1)) := by rw [mul_one]; congr 1; ring
+      _ ≤ WithZero.exp (-1 : ℤ) := WithZero.exp_le_exp.mpr (by omega)
+  have hii : Valued.v
+      ((uniformizerHat u) ^ (J + 1) * cohenΦ u S δ - cohenSectionHat u S (δ J))
+      ≤ WithZero.exp (-1 : ℤ) := by
+    rw [uniformizerHat_pow_mul_cohenΦ_sub_top u S δ hδne]
+    refine Finset.sum_induction _ (fun x => Valued.v x ≤ WithZero.exp (-1 : ℤ))
+      (fun a b ha hb => (Valued.v.map_add a b).trans (max_le ha hb))
+      ?_ fun j hj => ?_
+    · change Valued.v (0 : u.adicCompletion) ≤ _
+      rw [_root_.map_zero]; exact zero_le
+    · have hjJ : j < J := lt_of_le_of_ne
+        (δ.support.le_max' j (Finset.mem_of_mem_erase hj)) (Finset.ne_of_mem_erase hj)
+      change Valued.v (_ * _) ≤ _
+      rw [map_mul, map_pow, valued_algebraMap_uniformizer u, ← WithZero.exp_nsmul]
+      calc WithZero.exp ((J - j) • (-1 : ℤ)) * Valued.v (cohenSectionHat u S (δ j))
+          ≤ WithZero.exp ((J - j) • (-1 : ℤ)) * 1 :=
+            mul_le_mul_right (cohenSectionHat_mem_integers u S _) _
+        _ = WithZero.exp (-((J - j : ℕ) : ℤ)) := by rw [mul_one]; congr 1; ring
+        _ ≤ WithZero.exp (-1 : ℤ) := WithZero.exp_le_exp.mpr (by omega)
+  have hiii : Valued.v (cohenSectionHat u S (δ J)) ≤ WithZero.exp (-1 : ℤ) := by
+    have hdecomp : cohenSectionHat u S (δ J)
+        = (uniformizerHat u) ^ (J + 1) * cohenΦ u S δ
+          - ((uniformizerHat u) ^ (J + 1) * cohenΦ u S δ - cohenSectionHat u S (δ J)) := by ring
+    rw [hdecomp, sub_eq_add_neg]
+    exact (Valued.v.map_add _ _).trans (max_le hi (by rwa [Valuation.map_neg]))
+  rw [valued_cohenSectionHat_of_ne_zero u S hδJ] at hiii
+  exact absurd hiii (not_le.mpr (by
+    rw [← WithZero.exp_zero]; exact WithZero.exp_lt_exp.mpr (by norm_num)))
+
+theorem disjoint_adicIntegersKSubmod_cohenB :
+    _root_.Disjoint (adicIntegersKSubmod u) (cohenB u S) := by
+  rw [Submodule.disjoint_def]
+  rintro x hxO ⟨δ, rfl⟩
+  rw [cohenΦ_mem_integers_iff_zero u S δ hxO, _root_.map_zero]
+
+end Disjoint
+
+section Codisjoint
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable (u : Place K L)
+variable (S : Lg37CompletionSection u)
+
+theorem uniformizerHat_inv_mul_mem_integers_of_valued_le
+    {y : u.adicCompletion} (hy : Valued.v y ≤ WithZero.exp (-1 : ℤ)) :
+    (uniformizerHat u)⁻¹ * y ∈ u.adicCompletionIntegers := by
+  change Valued.v ((uniformizerHat u)⁻¹ * y) ≤ 1
+  rw [map_mul, map_inv₀, valued_algebraMap_uniformizer u, ← WithZero.exp_neg, neg_neg]
+  calc WithZero.exp (1 : ℤ) * Valued.v y
+      ≤ WithZero.exp (1 : ℤ) * WithZero.exp (-1 : ℤ) := mul_le_mul_right hy _
+    _ = 1 := by rw [← WithZero.exp_add, add_neg_cancel, WithZero.exp_zero]
+
+theorem valued_le_of_mem_completionIdeal {y : u.adicCompletionIntegers}
+    (hy : y ∈ u.heightOneSpectrum.completionIdeal L) :
+    Valued.v (y : u.adicCompletion) ≤ WithZero.exp (-1 : ℤ) := by
+  have := (adicCompletion.mem_completionIdeal_pow L u.heightOneSpectrum y).mp
+    (by rw [pow_one]; exact hy)
+  rwa [← WithZero.exp_eq_coe_ofAdd, show (-((1 : ℕ) : ℤ)) = (-1 : ℤ) by norm_num] at this
+
+theorem exists_residue_peel (ŷ : u.adicCompletionIntegers) :
+    ∃ c : u.ResidueField,
+      (uniformizerHat u)⁻¹ * ((ŷ : u.adicCompletion) - cohenSectionHat u S c)
+        ∈ u.adicCompletionIntegers := by
+  obtain ⟨ℓ, hℓ⟩ := kwF4R1V410a_exists_sub_mem_completionIdeal_pow u 1 ŷ
+  refine ⟨IsLocalRing.residue _ ℓ, uniformizerHat_inv_mul_mem_integers_of_valued_le u ?_⟩
+  have hcoe : ((algebraMap u.toValuationSubring u.adicCompletionIntegers ℓ
+        : u.adicCompletionIntegers) : u.adicCompletion)
+      = algebraMap L u.adicCompletion (ℓ : L) := rfl
+  have hdecomp : (ŷ : u.adicCompletion) - cohenSectionHat u S (IsLocalRing.residue _ ℓ)
+      = ((ŷ - algebraMap u.toValuationSubring u.adicCompletionIntegers ℓ
+            : u.adicCompletionIntegers) : u.adicCompletion)
+        + (algebraMap L u.adicCompletion (ℓ : L)
+            - cohenSectionHat u S (IsLocalRing.residue _ ℓ)) := by
+    push_cast [hcoe]; ring
+  rw [hdecomp]
+  refine (Valued.v.map_add _ _).trans (max_le ?_ ?_)
+  · refine valued_le_of_mem_completionIdeal u ?_
+    rw [← pow_one (u.heightOneSpectrum.completionIdeal L)]; exact hℓ
+  · rw [algebraMap_sub_cohenSectionHat_eq_v410a u S ℓ]
+    refine valued_le_of_mem_completionIdeal u ?_
+    rw [← pow_one (u.heightOneSpectrum.completionIdeal L)]
+    exact v410a_mem_completionIdeal_pow_of_evalₐ_eq_zero u 1 _
+      (approximant_evalₐ_sub_lift_eq_zero u S (M := 0) (ℓ := ℓ)
+        (fun k hk1 hk0 => absurd hk0 (by omega)))
+
+theorem mem_sup_of_uniformizerHat_pow_mul_mem_integers (M : ℕ) :
+    ∀ x : u.adicCompletion, (uniformizerHat u) ^ M * x ∈ u.adicCompletionIntegers →
+      x ∈ adicIntegersKSubmod u ⊔ cohenB u S := by
+  induction M with
+  | zero => intro x hx; rw [pow_zero, one_mul] at hx; exact Submodule.mem_sup_left hx
+  | succ M IH =>
+    intro x hx
+    obtain ⟨c, hc⟩ := exists_residue_peel u S ⟨_, hx⟩
+    have hne := uniformizerHat_ne_zero u
+    have hstep : (uniformizerHat u) ^ M * (x
+        - (uniformizerHat u)⁻¹ ^ (M + 1) * cohenSectionHat u S c)
+        ∈ u.adicCompletionIntegers := by
+      have heq : (uniformizerHat u) ^ M * (x
+            - (uniformizerHat u)⁻¹ ^ (M + 1) * cohenSectionHat u S c)
+          = (uniformizerHat u)⁻¹ * ((uniformizerHat u) ^ (M+1)*x - cohenSectionHat u S c) := by
+        rw [mul_sub, mul_sub,
+          show (uniformizerHat u)⁻¹ * ((uniformizerHat u) ^ (M+1) * x)
+              = (uniformizerHat u) ^ M * x by
+            rw [← mul_assoc, pow_succ', ← mul_assoc, inv_mul_cancel₀ hne, one_mul],
+          show (uniformizerHat u) ^ M * ((uniformizerHat u)⁻¹ ^ (M+1) * cohenSectionHat u S c)
+              = (uniformizerHat u)⁻¹ * cohenSectionHat u S c by
+            rw [← mul_assoc, pow_succ, ← mul_assoc, ← mul_pow,
+              mul_inv_cancel₀ hne, one_pow, one_mul]]
+      rw [heq]; exact hc
+    have hx' := IH _ hstep
+    have hb : (uniformizerHat u)⁻¹ ^ (M + 1) * cohenSectionHat u S c ∈ cohenB u S :=
+      monomial_mem_cohenB u S M c
+    have hx_eq : x = (x - (uniformizerHat u)⁻¹ ^ (M + 1) * cohenSectionHat u S c)
+        + (uniformizerHat u)⁻¹ ^ (M + 1) * cohenSectionHat u S c := by ring
+    rw [hx_eq]
+    exact add_mem hx' (Submodule.mem_sup_right hb)
+
+theorem codisjoint_adicIntegersKSubmod_cohenB :
+    Codisjoint (adicIntegersKSubmod u) (cohenB u S) := by
+  rw [codisjoint_iff, eq_top_iff]
+  intro x _
+  obtain ⟨M, hM⟩ := kwF4gRRTate_clearPole u
+    ⟨uniformizerHat u, uniformizerHat_mem_integers u⟩ (irreducible_uniformizerHat u) x
+  exact mem_sup_of_uniformizerHat_pow_mul_mem_integers u S M x hM
+
+end Codisjoint
+
+section Assembly
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable [IsCurveOver K L] [PerfectField K]
+
+def cohenLaurentCompl_of_section (u : Place K L) [u.FiniteResidue]
+    (S : Lg37CompletionSection u) : KwTateRR3CohenLaurentCompl u where
+  S := S
+  B := cohenB u S
+  hcompl := ⟨disjoint_adicIntegersKSubmod_cohenB u S,
+    codisjoint_adicIntegersKSubmod_cohenB u S⟩
+  shift_sub_mem z := by
+    obtain ⟨δ, hδ⟩ := z.2
+    rw [← hδ, locResCompl_cohenΦ u S δ]
+    exact uniformizerHat_mul_cohenΦ_sub_mem u S δ
+
+end Assembly
+
+section Headline
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable [IsCurveOver K L] [PerfectField K]
+
+theorem kwTateRR3_cohenLaurentComplExists :
+    KwTateRR3CohenLaurentComplExists K L := fun u _ => by
+  have : FiniteDimensional K u.ResidueField := Place.FiniteResidue.finite
+  have : Algebra.IsSeparable K u.ResidueField :=
+    Algebra.IsAlgebraic.isSeparable_of_perfectField
+  exact (completionSection_nonempty_generic u).map (cohenLaurentCompl_of_section u)
+
+theorem kwTateRR3_cohenKernelDataExists :
+    KwF4gRRTateCohenKernelDataExists K L :=
+  kwTateRR3_cohenKernelDataExists_of_complExists kwTateRR3_cohenLaurentComplExists
+
+end Headline
+end KwTateRR3
+end ModularCurve
+end
+end
+
+theorem solution
+    {K L : Type*} [Field K] [Field L] [Algebra K L]
+    [AlgebraicCurve.IsCurveOver K L] [PerfectField K]
+    [∀ u : AlgebraicCurve.Place K L, u.FiniteResidue]
+    (hfin : ModularCurve.KwF4gRRTate.KwF4gRRTateCommFinite K L) :
+    ModularCurve.KwF4gRRTate.KwF4gRRTateAgreement K L hfin :=
+  ModularCurve.KwF4gRRTate.kwF4gRRTate_agreement_of_kernelData hfin
+    ModularCurve.KwTateRR3.kwTateRR3_cohenKernelDataExists
+
+end S_AlgebraicCurve_tateAgreement
+end P2MW
+export P2MW.S_AlgebraicCurve_tateAgreement (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.tateAgreement
+    {K L : Type*} [Field K] [Field L] [Algebra K L]
+    [AlgebraicCurve.IsCurveOver K L] [PerfectField K]
+    [∀ u : AlgebraicCurve.Place K L, u.FiniteResidue]
+    (hfin : ModularCurve.KwF4gRRTate.KwF4gRRTateCommFinite K L) :
+    ModularCurve.KwF4gRRTate.KwF4gRRTateAgreement K L hfin :=
+  solution hfin
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_tateChainRule.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_tateChainRule.lean
new file mode 100644
index 0000000000..e48dc94aff
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_tateChainRule.lean
@@ -0,0 +1,2277 @@
+/-
+Based on Prove2Me node AlgebraicCurve.tateChainRule
+(3923c003-06ed-5e6b-98e9-deccb859eeca) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 94afbce2-9eee-5e62-a161-cc19cce611fe
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_TateResidueCurrency
+
+import Mathlib.Algebra.GroupWithZero.Submonoid.CancelMulZero
+import Mathlib.Algebra.Lie.OfAssociative
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Chain rule for Tate's residue along F/E
+
+Theorem statement: `AlgebraicCurve.tateChainRule` (`3923c003-06ed-5e6b-98e9-deccb859eeca`), by
+Claude, 2026-09-05.
+
+Proof: submission `94afbce2-9eee-5e62-a161-cc19cce611fe`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$, $E$, $F$ be fields with $K \subseteq E \subseteq F$ (compatible algebra structures, forming
+a scalar tower) such that $F$ is integral over $E$, assume that $F/K$ and $E/K$ each carry a chosen
+canonical local residue datum at every place (an instance of `HasCanonicalLocalResidueKStar`, where
+a place of $F$ over $K$ is a proper valuation subring of $F$ containing the image of $K$ whose
+valuation ring is a principal ideal ring), and assume every place $w$ of $F$ has finite residue,
+i.e. its residue field is a finite-dimensional $K$-module. Assume further the hypothesis `hfinF`,
+namely that for every place $u$ of $F$ and all $f,g$ in the adic completion $\widehat F_u$ the range
+of the restricted Tate commutator of the projection `tateProj u` onto the $K$-subspace of adic
+integers (along a chosen complement) with the multiplication operators by $f$ and $g$ is
+finite-dimensional over $K$, so that the trace `tateRes` is defined. The conclusion is the
+proposition `KwF4gRRTateChainRule K F E hfinF`: under the further assumptions, quantified inside
+that proposition, that $K$-principal divisors exist for $E$ and for $F$, that $F/E$ is
+finite-dimensional, that $\Omega_{E/K}$ and $\Omega_{F/K}$ are nontrivial, for every place $v$ of
+$E$ and every place $w$ of $F$ in the fibre of $v$, both satisfying `DCoordGenerates`, and every $f
+\in \widehat F_w$, one has $$\operatorname{tateRes}_w\bigl(f,\ \pi_v\bigr) =
+\operatorname{tateRes}_w\bigl(f \cdot \partial_w(\mathrm{d}\pi_v),\ \pi_w\bigr),$$ where $\pi_v$,
+$\pi_w$ denote the images in $\widehat F_w$ of the uniformisers of $v$ and $w$, and
+$\partial_w(\mathrm{d}\pi_v)$ is the `differentialCoeff` at $w$ of the pullback to $\Omega_{F/K}$ of
+the differential `v.dCoord` in $\Omega_{E/K}$.
+
+This is the chain rule for Tate's trace-theoretic local residue along an extension $F/E$,
+corresponding to Tate's axiom (R4): changing the second argument from a uniformiser of the place
+below to a uniformiser of the place above is compensated by multiplying the first argument by the
+coordinate of the pulled-back differential. It is used in the comparison of residues with traces
+over completions, in
+[`AlgebraicCurve.residueTraceCompletionCommute`]
+(thm.html#AlgebraicCurve.residueTraceCompletionCommute)
+and
+[`AlgebraicCurve.residueTraceCompletionCommute_v2`]
+(thm.html#AlgebraicCurve.residueTraceCompletionCommute_v2).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_tateChainRule.lean
+
+*Attribution:* this file contains material adapted from third-party Apache-2.0 sources (a short
+passage (a few lines): `FLT/Mathlib/RingTheory/Valuation/ValuationSubring.lean` — © 2025 Ruben Van
+de Velde; authors: Ruben Van de Velde, Kevin Buzzard, Salvatore Mercuri;
+`FLT/Mathlib/RingTheory/LocalRing/MaximalIdeal/Basic.lean` — © 2025 Salvatore Mercuri; authors:
+Salvatore Mercuri, Kevin Buzzard). See ATTRIBUTION.md and NOTICE in the source repository.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_tateChainRule
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalDivisor HasCanonicalLocalResidueKStar \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kaehlerPullback"
+end AlgebraicCurve
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalDivisor HasCanonicalLocalResidueKStar \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kaehlerPullback"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_one ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow ne_top' FiniteResidue.finite algebraMap_mem' \
+  toValuationSubring mk dCoord DCoordGenerates differentialCoeff differentialCoeff_smul_dCoord \
+  uniformizer ramificationIndex ramificationIndex_pos exists_ord_eq_ramificationIndex \
+  ramificationIndex_dvd_ord irreducible_mk_comap restrict adicCompletion adicCompletionIntegers"
+end AlgebraicCurve.Place
+namespace Filter
+p2m_export "Filter" "ker mk mem_comap mem_ker mem_top comap unique map_mono map"
+end Filter
+namespace IntermediateField
+p2m_export "IntermediateField" "toAlgebra mk val isIntegral_iff inclusion ext algebraMap_apply \
+  smul_def finiteDimensional_sup comap mem_top restrictScalars restrictScalars_top coe_smul \
+  map_mono smul_mem restrict map"
+end IntermediateField
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "HeightOneSpectrum.ext mk HeightOneSpectrum"
+end IsDedekindDomain
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "HeightOneSpectrum.ext mk HeightOneSpectrum"
+namespace HeightOneSpectrum
+p2m_export "IsDedekindDomain.HeightOneSpectrum" "valuation_of_algebraMap \
+  intValuation_le_pow_iff_mem isMaximal mk comap valuedAdicCompletion_eq_valuation' adicCompletion \
+  valuation adicCompletionIntegers valuedAdicCompletion_surjective \
+  mem_integers_of_valuation_le_one denseRange_algebraMap intValuation completionIdeal \
+  adicCompletion.mem_completionIdeal_pow"
+end IsDedekindDomain.HeightOneSpectrum
+namespace IsLocalRing
+p2m_export "IsLocalRing" "ResidueField maximalIdeal maximalIdeal.isMaximal of_injective"
+end IsLocalRing
+namespace KaehlerDifferential
+p2m_export "KaehlerDifferential" "finite D map_D map"
+end KaehlerDifferential
+namespace LinearMap
+p2m_export "LinearMap" "mulLeft_apply coe_smul mem_range range sub_apply coe_mk add_apply \
+  ker_eq_bot range_zero id range_comp codRestrict smul_apply mulLeft ker_comp trace_comp_comm' mk \
+  id_apply ext comp isIntegral trace quotKerEquivRange finiteDimensional range_comp_le_range \
+  restrictScalars ker mem_ker comp_apply mem_range_self restrict"
+end LinearMap
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+end ModularCurve
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+end ModularCurve
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace adicIntegersKSubmod tateProj lmulK tateRes \
+  KwF4gRRTateCommFinite KwF4gRRTateChainRule"
+end ModularCurve.KwF4gRRTate
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+end ModularCurve
+namespace Module
+p2m_export "Module" "Injective equiv Finite.equiv mk restrictScalars Finite.of_submodule_quotient"
+end Module
+namespace MonoidWithZeroHom
+p2m_export "MonoidWithZeroHom" "id_apply id ext mk coe_mk coe_one comp_apply comp"
+end MonoidWithZeroHom
+namespace Multiplicative
+p2m_export "Multiplicative" "ext smul"
+end Multiplicative
+namespace NumberField
+p2m_export "NumberField" "mk"
+end NumberField
+namespace Polynomial
+p2m_export "Polynomial" "coe_one algebraMap_eq unique ext_iff toSubring map comp coe_mul coe_sub \
+  coe_smul algebraMap_apply ext ring"
+end Polynomial
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq inclusion mem_sup_right coe_smul smul_mem' mk smul_mem \
+  coe_mem Quotient.mk span restrictScalars projectionOnto_apply_left restrictScalars_top \
+  mem_closure_iff Quotient.restrictScalarsEquiv mem_comap mem_top Quotient.equiv \
+  mem_span_singleton mkQ map_mono map_smul' equivMapOfInjective zero quotientQuotientEquivQuotient \
+  coe_eq_zero range_subtype Quotient.mk_surjective restrictScalars_mono map coe_mk exists_isCompl \
+  projectionOnto finiteDimensional_of_le smul_def restrictScalarsEquiv ext ker_mkQ comap \
+  finiteDimensional_sup liftQ mem_sup_left smul restrictScalars_mem"
+end Submodule
+namespace WithZero
+p2m_export "WithZero" "coe_one map coe_mul exp_eq_coe_ofAdd coe exp_ne_zero exp exp_zero exp_le_exp"
+end WithZero
+
+section
+namespace IsLocalRing
+p2m_export "IsLocalRing" "ResidueField maximalIdeal maximalIdeal.isMaximal of_injective"
+end IsLocalRing
+p2m_open_scoped "IsLocalRing" in
+theorem IsLocalRing.maximalIdeal_le {R : Type*} [CommSemiring R] [IsLocalRing R] {J : Ideal R}
+    (hJ : J ≠ ⊤) (h : IsLocalRing.maximalIdeal R ≤ J) :
+    J.IsMaximal :=
+  (IsLocalRing.maximalIdeal.isMaximal R).eq_of_le hJ h ▸ IsLocalRing.maximalIdeal.isMaximal R
+
+scoped instance instAlgebraSubtypeMemValuationSubring_fLT {K L : Type*} [Field K] [Semiring L]
+    (O : ValuationSubring K) [Algebra K L] : Algebra O L where
+  smul r x := r.1 • x
+  algebraMap := (algebraMap K L).comp (algebraMap O K)
+  commutes' _ _ := by simp [Algebra.commutes]
+  smul_def' _ _ := by simp [← Algebra.smul_def]; rfl
+end
+
+section
+
+
+p2m_open "LinearMap P2MW.S_AlgebraicCurve_tateChainRule.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateChainRule.Submodule"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace adicIntegersKSubmod tateProj lmulK tateRes \
+  KwF4gRRTateCommFinite KwF4gRRTateChainRule"
+end ModularCurve.KwF4gRRTate
+
+end
+
+end
+
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateChainRule.IsDedekindDomain WithZero \
+  P2MW.S_AlgebraicCurve_tateChainRule.WithZero IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateChainRule.IsLocalRing"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalDivisor HasCanonicalLocalResidueKStar \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kaehlerPullback"
+p2m_open "AlgebraicCurve"
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_one ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow ne_top' FiniteResidue.finite algebraMap_mem' \
+  toValuationSubring mk dCoord DCoordGenerates differentialCoeff differentialCoeff_smul_dCoord \
+  uniformizer ramificationIndex ramificationIndex_pos exists_ord_eq_ramificationIndex \
+  ramificationIndex_dvd_ord irreducible_mk_comap restrict adicCompletion adicCompletionIntegers"
+end Place
+
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "smul_def smul_apply"
+end Divisor
+
+namespace Pic0
+p2m_export "AlgebraicCurve.Pic0" "mk mk_surjective"
+end Pic0
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_one ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow ne_top' FiniteResidue.finite algebraMap_mem' \
+  toValuationSubring mk dCoord DCoordGenerates differentialCoeff differentialCoeff_smul_dCoord \
+  uniformizer ramificationIndex ramificationIndex_pos exists_ord_eq_ramificationIndex \
+  ramificationIndex_dvd_ord irreducible_mk_comap restrict adicCompletion adicCompletionIntegers"
+end Place
+
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "smul_def smul_apply"
+end Divisor
+
+namespace Pic0
+p2m_export "AlgebraicCurve.Pic0" "mk mk_surjective"
+end Pic0
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_one ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow ne_top' FiniteResidue.finite algebraMap_mem' \
+  toValuationSubring mk dCoord DCoordGenerates differentialCoeff differentialCoeff_smul_dCoord \
+  uniformizer ramificationIndex ramificationIndex_pos exists_ord_eq_ramificationIndex \
+  ramificationIndex_dvd_ord irreducible_mk_comap restrict adicCompletion adicCompletionIntegers"
+end Place
+
+end AlgebraicCurve
+
+end
+
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateChainRule.IsDedekindDomain WithZero \
+  P2MW.S_AlgebraicCurve_tateChainRule.WithZero IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateChainRule.IsLocalRing"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalDivisor HasCanonicalLocalResidueKStar \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kaehlerPullback"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_one ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow ne_top' FiniteResidue.finite algebraMap_mem' \
+  toValuationSubring mk dCoord DCoordGenerates differentialCoeff differentialCoeff_smul_dCoord \
+  uniformizer ramificationIndex ramificationIndex_pos exists_ord_eq_ramificationIndex \
+  ramificationIndex_dvd_ord irreducible_mk_comap restrict adicCompletion adicCompletionIntegers"
+p2m_open "AlgebraicCurve.Place"
+
+section SinglePlace
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+
+p2m_export "AlgebraicCurve.Place" "ord_nonneg_of_mem"
+
+p2m_export "AlgebraicCurve.Place" "mem_of_ord_nonneg"
+
+p2m_export "AlgebraicCurve.Place" "mem_iff_ord_nonneg"
+
+end SinglePlace
+
+section Restrict
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F'] [Algebra F F']
+
+
+variable (w : Place K F')
+
+
+p2m_export "AlgebraicCurve.Place" "comap_algebraMap_ne_top"
+
+
+
+
+
+p2m_export "AlgebraicCurve.Place" "exists_ord_algebraMap_pos"
+end Restrict
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+
+
+section
+
+variable {F : Type*} [Field F]
+
+namespace ValuationSubring
+p2m_export "ValuationSubring" "comap subtype mem_comap toSubring algebraMap_apply ext zero_mem mk \
+  mem_top mul_mem add_mem valuation inclusion"
+end ValuationSubring
+p2m_open_scoped "ValuationSubring" in
+theorem ValuationSubring.valued_eq_one_of_isUnit {K : Type*} [Field K] {Γ₀ : Type*}
+    [LinearOrderedCommGroupWithZero Γ₀] [hv : Valued K Γ₀] (x : hv.v.valuationSubring)
+    (hx : IsUnit x) : Valued.v x.val = 1 := by
+  obtain ⟨u, hu⟩ := hx
+  apply le_antisymm ((hv.v.mem_valuationSubring_iff _).1 x.2)
+  rw [← Valued.v.map_one (R := K), ← Submonoid.coe_one, ← u.mul_inv, hu,
+    Submonoid.coe_mul, Valued.v.map_mul]
+  nth_rw 2 [← mul_one (Valued.v x.val)]
+  exact mul_le_mul_right ((hv.v.mem_valuationSubring_iff _).1 (u⁻¹.val.property)) _
+
+p2m_open_scoped "ValuationSubring" in
+theorem ValuationSubring.isUnit_of_valued_eq_one {K : Type*} [Field K] {Γ₀ : Type*}
+    [LinearOrderedCommGroupWithZero Γ₀] [hv : Valued K Γ₀] (x : hv.v.valuationSubring)
+    (hx : Valued.v x.val = 1) : IsUnit x := by
+  have : IsUnit x.val := by rw [isUnit_iff_ne_zero, ne_eq, ← map_eq_zero hv.v, hx]; aesop
+  obtain ⟨u, hu⟩ := this
+  have hu_inv_le : Valued.v u⁻¹.val ≤ 1 := by
+    rw [← one_mul (Valued.v _), ← hx, ← hu, ← Valued.v.map_mul, u.mul_inv, hu, hx, Valued.v.map_one]
+  rw [isUnit_iff_exists]
+  exact ⟨⟨u⁻¹.val, hu_inv_le⟩, ⟨by aesop, by aesop⟩⟩
+
+p2m_open_scoped "ValuationSubring" in
+theorem ValuationSubring.isUnit_iff_valued_eq_one {K : Type*} [Field K] {Γ₀ : Type*}
+    [LinearOrderedCommGroupWithZero Γ₀] [hv : Valued K Γ₀] (x : hv.v.valuationSubring) :
+    IsUnit x ↔ Valued.v x.val = 1 :=
+  ⟨valued_eq_one_of_isUnit x, isUnit_of_valued_eq_one x⟩
+
+end
+
+
+
+section
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateChainRule.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateChainRule.IsDedekindDomain.HeightOneSpectrum IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateChainRule.IsLocalRing WithZero \
+  P2MW.S_AlgebraicCurve_tateChainRule.WithZero MonoidWithZeroHom \
+  P2MW.S_AlgebraicCurve_tateChainRule.MonoidWithZeroHom"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalDivisor HasCanonicalLocalResidueKStar \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kaehlerPullback"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_one ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow ne_top' FiniteResidue.finite algebraMap_mem' \
+  toValuationSubring mk dCoord DCoordGenerates differentialCoeff differentialCoeff_smul_dCoord \
+  uniformizer ramificationIndex ramificationIndex_pos exists_ord_eq_ramificationIndex \
+  ramificationIndex_dvd_ord irreducible_mk_comap restrict adicCompletion adicCompletionIntegers"
+end AlgebraicCurve.Place
+
+end
+end
+
+
+
+noncomputable section
+
+p2m_open "KaehlerDifferential P2MW.S_AlgebraicCurve_tateChainRule.KaehlerDifferential"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalDivisor HasCanonicalLocalResidueKStar \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kaehlerPullback"
+p2m_open "AlgebraicCurve"
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+namespace IsCurveOver
+p2m_export "AlgebraicCurve.IsCurveOver" "mk"
+end IsCurveOver
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_one ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow ne_top' FiniteResidue.finite algebraMap_mem' \
+  toValuationSubring mk dCoord DCoordGenerates differentialCoeff differentialCoeff_smul_dCoord \
+  uniformizer ramificationIndex ramificationIndex_pos exists_ord_eq_ramificationIndex \
+  ramificationIndex_dvd_ord irreducible_mk_comap restrict adicCompletion adicCompletionIntegers"
+end Place
+
+end AlgebraicCurve
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+end ModularCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalDivisor HasCanonicalLocalResidueKStar \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kaehlerPullback"
+end AlgebraicCurve
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+end ModularCurve
+
+end
+
+
+section
+
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateChainRule.IsDedekindDomain WithZero \
+  P2MW.S_AlgebraicCurve_tateChainRule.WithZero Module P2MW.S_AlgebraicCurve_tateChainRule.Module \
+  IsLocalRing P2MW.S_AlgebraicCurve_tateChainRule.IsLocalRing Module.IsLocalRing"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalDivisor HasCanonicalLocalResidueKStar \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kaehlerPullback"
+p2m_open "AlgebraicCurve"
+
+section CorrectedCarrier
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+variable (E : Type*) [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+
+variable {K F E}
+
+@[scoped simp] theorem kaehlerPullback_D (e : E) :
+    kaehlerPullback K F E (KaehlerDifferential.D K E e)
+      = KaehlerDifferential.D K F (algebraMap E F e) :=
+  KaehlerDifferential.map_D K K E F e
+
+end CorrectedCarrier
+
+end AlgebraicCurve
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+end ModularCurve
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateChainRule.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateChainRule.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateChainRule.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace adicIntegersKSubmod tateProj lmulK tateRes \
+  KwF4gRRTateCommFinite KwF4gRRTateChainRule"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section TateProj
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem mem_adicIntegersKSubmod_iff (x : u.adicCompletion) :
+    x ∈ adicIntegersKSubmod u ↔ x ∈ u.adicCompletionIntegers := Iff.rfl
+
+theorem tateProj_mem_integers (x : u.adicCompletion) :
+    tateProj u x ∈ u.adicCompletionIntegers :=
+  (mem_adicIntegersKSubmod_iff u _).mp
+    (Submodule.coe_mem
+      (Submodule.projectionOnto (adicIntegersKSubmod u) _
+        (Classical.choose_spec (Submodule.exists_isCompl (adicIntegersKSubmod u))) x))
+
+theorem tateProj_of_mem {x : u.adicCompletion} (hx : x ∈ u.adicCompletionIntegers) :
+    tateProj u x = x := by
+  have h := Submodule.projectionOnto_apply_left
+    (Classical.choose_spec (Submodule.exists_isCompl (adicIntegersKSubmod u)))
+    (⟨x, (mem_adicIntegersKSubmod_iff u x).mpr hx⟩ : adicIntegersKSubmod u)
+  have hcoe := congrArg (Subtype.val (p := fun y => y ∈ adicIntegersKSubmod u)) h
+  exact hcoe
+
+theorem tateProj_idem : tateProj u ∘ₗ tateProj u = tateProj u := by
+  refine LinearMap.ext fun x => ?_
+  rw [LinearMap.comp_apply]
+  exact tateProj_of_mem u (tateProj_mem_integers u x)
+
+theorem range_tateProj : LinearMap.range (tateProj u) = adicIntegersKSubmod u := by
+  apply le_antisymm
+  · rintro x ⟨y, rfl⟩
+    exact tateProj_mem_integers u y
+  · intro x hx
+    exact ⟨x, tateProj_of_mem u hx⟩
+
+end TateProj
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateChainRule.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateChainRule.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateChainRule.ModularCurve.KwF4gRRTate"
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateChainRule.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateChainRule.IsDedekindDomain.HeightOneSpectrum IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateChainRule.IsLocalRing"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace adicIntegersKSubmod tateProj lmulK tateRes \
+  KwF4gRRTateCommFinite KwF4gRRTateChainRule"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section PoleWindow
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+def poleWindowKSubmod (πh : u.adicCompletionIntegers) (M : ℕ) :
+    Submodule K u.adicCompletion where
+  carrier := {x | (πh : u.adicCompletion) ^ M * x ∈ u.adicCompletionIntegers}
+  add_mem' {a b} ha hb := by
+    simp only [Set.mem_ofPred_eq, mul_add] at ha hb ⊢; exact add_mem ha hb
+  zero_mem' := by simp only [Set.mem_ofPred_eq, mul_zero]; exact zero_mem _
+  smul_mem' c x hx := by
+    simp only [Set.mem_ofPred_eq] at hx ⊢
+    rw [Algebra.smul_def, IsScalarTower.algebraMap_apply K L u.adicCompletion, mul_left_comm]
+    exact mul_mem ((kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff u _).mpr
+      (u.algebraMap_mem' c)) hx
+
+theorem mem_poleWindowKSubmod_iff (πh : u.adicCompletionIntegers) (M : ℕ)
+    (x : u.adicCompletion) :
+    x ∈ poleWindowKSubmod u πh M ↔ (πh : u.adicCompletion) ^ M * x ∈ u.adicCompletionIntegers :=
+  Iff.rfl
+
+theorem adicIntegersKSubmod_le_poleWindowKSubmod (πh : u.adicCompletionIntegers) (M : ℕ) :
+    adicIntegersKSubmod u ≤ poleWindowKSubmod u πh M :=
+  fun _ hx => mul_mem (pow_mem πh.2 M) hx
+
+theorem kwF4gRRTate_clearPole (πh : u.adicCompletionIntegers) (hπh : Irreducible πh)
+    (fh : u.adicCompletion) :
+    ∃ M : ℕ, (πh : u.adicCompletion) ^ M * fh ∈ u.adicCompletionIntegers := by
+  obtain ⟨a, b, hb, hfh⟩ := IsFractionRing.div_surjective
+    (A := u.adicCompletionIntegers) (K := u.adicCompletion) fh
+  have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb
+  obtain ⟨M, ub, hbeq⟩ := IsDiscreteValuationRing.eq_unit_mul_pow_irreducible hb0 hπh
+  refine ⟨M, ?_⟩
+  have hcoe : ∀ x : u.adicCompletionIntegers,
+      (x : u.adicCompletion) = algebraMap _ u.adicCompletion x := fun _ => rfl
+  have hbK0 : (b : u.adicCompletion) ≠ 0 := by
+    rw [hcoe]; exact (map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr hb0
+  have hbfh : (b : u.adicCompletion) * fh = (a : u.adicCompletion) := by
+    rw [← hfh, hcoe b, hcoe a, mul_div_cancel₀ _ (hcoe b ▸ hbK0)]
+  have hπheq : ((ub⁻¹ : u.adicCompletionIntegersˣ) : u.adicCompletionIntegers) * b = πh ^ M := by
+    rw [hbeq, ← mul_assoc, ← Units.val_mul, inv_mul_cancel, Units.val_one, one_mul]
+  have hπheqK : ((((ub⁻¹ : u.adicCompletionIntegersˣ) : u.adicCompletionIntegers)
+        : u.adicCompletion)) * (b : u.adicCompletion)
+      = (πh : u.adicCompletion) ^ M := by
+    have := congrArg (algebraMap u.adicCompletionIntegers u.adicCompletion) hπheq
+    simp only [map_mul, map_pow] at this
+    exact this
+  rw [← hπheqK, mul_assoc, hbfh]
+  exact mul_mem (Subtype.coe_prop _) a.2
+
+variable (K L) in
+def KwF4gRRTatePoleWindowFinite : Prop :=
+  ∀ (u : Place K L) [u.FiniteResidue] (πh : u.adicCompletionIntegers) (_ : Irreducible πh)
+    (M : ℕ),
+    FiniteDimensional K
+      (poleWindowKSubmod u πh M ⧸
+        (adicIntegersKSubmod u).comap (poleWindowKSubmod u πh M).subtype)
+
+end PoleWindow
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open_scoped "WithZero P2MW.S_AlgebraicCurve_tateChainRule.WithZero Multiplicative \
+  P2MW.S_AlgebraicCurve_tateChainRule.Multiplicative Topology \
+  P2MW.S_AlgebraicCurve_tateChainRule.Topology"
+p2m_open "Filter P2MW.S_AlgebraicCurve_tateChainRule.Filter"
+
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "HeightOneSpectrum.ext mk HeightOneSpectrum"
+namespace HeightOneSpectrum
+p2m_export "IsDedekindDomain.HeightOneSpectrum" "valuation_of_algebraMap \
+  intValuation_le_pow_iff_mem isMaximal mk comap valuedAdicCompletion_eq_valuation' adicCompletion \
+  valuation adicCompletionIntegers valuedAdicCompletion_surjective \
+  mem_integers_of_valuation_le_one denseRange_algebraMap intValuation completionIdeal \
+  adicCompletion.mem_completionIdeal_pow"
+p2m_open "IsDedekindDomain.HeightOneSpectrum IsDedekindDomain"
+
+variable {A : Type*} (K : Type*) [CommRing A] [Field K] [Algebra A K] [IsFractionRing A K]
+    [IsDedekindDomain A] (v : HeightOneSpectrum A)
+
+namespace adicCompletion
+p2m_export "IsDedekindDomain.HeightOneSpectrum.adicCompletion" "mem_completionIdeal_pow"
+p2m_open "IsDedekindDomain.HeightOneSpectrum.adicCompletion"
+
+local notation "vK" => (Valued.v : Valuation (v.adicCompletion K) ℤᵐ⁰)
+
+theorem isOpen_setOf_valued_le {γ : ℤᵐ⁰} (hγ : γ ≠ 0) :
+    IsOpen {y : v.adicCompletion K | Valued.v y ≤ γ} := by
+  obtain ⟨z, hz⟩ := valuedAdicCompletion_surjective K v γ
+  have hz0 : vK z ≠ 0 := by rw [hz]; exact hγ
+  have hr0 : (vK).restrict z ≠ 0 := fun h =>
+    hz0 ((Valuation.restrict_eq_zero_iff vK).mp h)
+  have hset : {y : v.adicCompletion K | Valued.v y ≤ γ}
+      = {y : v.adicCompletion K | (vK).restrict y ≤ (vK).restrict z} := by
+    ext y
+    simp only [Set.mem_ofPred_eq, Valuation.restrict_le_iff, hz]
+  rw [hset]
+  exact Valued.isOpen_closedBall _ hr0
+
+end adicCompletion
+end IsDedekindDomain.HeightOneSpectrum
+end
+
+section
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateChainRule.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateChainRule.IsDedekindDomain.HeightOneSpectrum IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateChainRule.IsLocalRing WithZero \
+  P2MW.S_AlgebraicCurve_tateChainRule.WithZero"
+p2m_open "P2MW.S_AlgebraicCurve_tateChainRule.ModularCurve.Lg37 AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve.Place"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+namespace KwF4R1V410a
+p2m_open "ModularCurve"
+
+scoped instance kwF4R1V410a_subsingletonHeightOneSpectrumDVR
+    {O : Type*} [CommRing O] [IsDomain O] [IsDiscreteValuationRing O] :
+    Subsingleton (HeightOneSpectrum O) :=
+  ⟨fun a b => IsDedekindDomain.HeightOneSpectrum.ext
+    (((IsDiscreteValuationRing.iff_pid_with_one_nonzero_prime O).mp
+      inferInstance).2.unique ⟨a.3, a.2⟩ ⟨b.3, b.2⟩)⟩
+
+section Bridge
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+local notation "O_w" => w.toValuationSubring
+local notation "𝔪_w" => IsLocalRing.maximalIdeal w.toValuationSubring
+local notation "O_W" => w.adicCompletionIntegers
+local notation "𝔪_W" => w.heightOneSpectrum.completionIdeal F
+
+theorem kwF4R1V410a_algebraMap_mem_completionIdeal_pow_iff (n : ℕ) (x : O_w) :
+    algebraMap (O_w) (O_W) x ∈ (𝔪_W) ^ n ↔ x ∈ (𝔪_w) ^ n := by
+  have hval : Valued.v (algebraMap (O_w) (O_W) x).val
+      = w.heightOneSpectrum.intValuation x := by
+    have h1 : (algebraMap (O_w) (O_W) x).val
+        = ((algebraMap (O_w) F x : F) : w.adicCompletion) := rfl
+    rw [h1, valuedAdicCompletion_eq_valuation' (K := F) w.heightOneSpectrum,
+      valuation_of_algebraMap]
+  rw [adicCompletion.mem_completionIdeal_pow, hval, ← WithZero.exp_eq_coe_ofAdd,
+    intValuation_le_pow_iff_mem, w.heightOneSpectrum_asIdeal]
+
+theorem kwF4R1V410a_exists_sub_mem_completionIdeal_pow (n : ℕ) (y : O_W) :
+    ∃ x : O_w, y - algebraMap (O_w) (O_W) x ∈ (𝔪_W) ^ n := by
+  have hball_open : IsOpen {z : w.adicCompletion |
+      Valued.v (z - y.val) ≤ WithZero.exp (-(n : ℤ))} :=
+    (adicCompletion.isOpen_setOf_valued_le F w.heightOneSpectrum
+      WithZero.exp_ne_zero).preimage (continuous_sub_right y.val)
+  have hy_mem : y.val ∈ {z : w.adicCompletion |
+      Valued.v (z - y.val) ≤ WithZero.exp (-(n : ℤ))} := by
+    simp only [Set.mem_ofPred_eq, sub_self, _root_.map_zero]; exact zero_le
+  have hmeet := mem_closure_iff.mp
+    ((denseRange_algebraMap F w.heightOneSpectrum) y.val) _ hball_open hy_mem
+  have hexists : ∃ z : F, Valued.v (algebraMap F w.adicCompletion z - y.val)
+      ≤ WithZero.exp (-(n : ℤ)) := by
+    rcases hmeet with ⟨z₀, hz₀_ball, z, hz_eq⟩
+    exact ⟨z, hz_eq ▸ hz₀_ball⟩
+  obtain ⟨z, hz⟩ := hexists
+  rw [show algebraMap F w.adicCompletion z = ((z : F) : w.adicCompletion) from rfl] at hz
+  have hz_val_le : w.heightOneSpectrum.valuation F z ≤ 1 := by
+    have hzhat : Valued.v ((z : w.adicCompletion)) ≤ (1 : ℤᵐ⁰) := by
+      calc Valued.v ((z : w.adicCompletion))
+          = Valued.v (((z : w.adicCompletion) - y.val) + y.val) := by ring_nf
+        _ ≤ max (Valued.v ((z : w.adicCompletion) - y.val)) (Valued.v y.val) :=
+            Valuation.map_add _ _ _
+        _ ≤ (1 : ℤᵐ⁰) := max_le
+            (hz.trans (by rw [← WithZero.exp_zero]; exact WithZero.exp_le_exp.mpr (by omega)))
+            y.2
+    rwa [valuedAdicCompletion_eq_valuation'] at hzhat
+  have hz_mem : z ∈ (O_w : ValuationSubring F) := by
+    obtain ⟨r, hr⟩ := mem_integers_of_valuation_le_one F z
+      (fun v' => by
+        obtain rfl : v' = w.heightOneSpectrum := Subsingleton.elim _ _
+        exact hz_val_le)
+    exact hr ▸ r.2
+  refine ⟨⟨z, hz_mem⟩, ?_⟩
+  rw [adicCompletion.mem_completionIdeal_pow, ← WithZero.exp_eq_coe_ofAdd]
+  have hsub : (y - algebraMap (O_w) (O_W) ⟨z, hz_mem⟩ : O_W).val
+      = y.val - ((z : F) : w.adicCompletion) := rfl
+  rw [hsub, Valuation.map_sub_swap]
+  exact hz
+
+def kwF4R1V410a_quotientEquiv (n : ℕ) :
+    (O_w) ⧸ (𝔪_w) ^ n ≃+* (O_W) ⧸ (𝔪_W) ^ n :=
+  RingEquiv.ofBijective
+    (Ideal.quotientMap _ (algebraMap (O_w) (O_W))
+      (fun x hx => (kwF4R1V410a_algebraMap_mem_completionIdeal_pow_iff w n x).mpr hx))
+    ⟨Ideal.quotientMap_injective'
+      (fun x hx => (kwF4R1V410a_algebraMap_mem_completionIdeal_pow_iff w n x).mp
+        (Ideal.mem_comap.mp hx)),
+    fun y => by
+      obtain ⟨y', rfl⟩ := Ideal.Quotient.mk_surjective y
+      obtain ⟨x, hx⟩ := kwF4R1V410a_exists_sub_mem_completionIdeal_pow w n y'
+      refine ⟨Ideal.Quotient.mk _ x, ?_⟩
+      rw [Ideal.quotientMap_mk]
+      exact (Ideal.Quotient.mk_eq_mk_iff_sub_mem _ _).mpr (by
+        rw [← neg_sub, neg_mem_iff]; exact hx)⟩
+
+theorem kwF4R1V410a_quotientEquiv_mk (n : ℕ) (x : O_w) :
+    kwF4R1V410a_quotientEquiv w n (Ideal.Quotient.mk _ x)
+      = Ideal.Quotient.mk _ (algebraMap (O_w) (O_W) x) := rfl
+
+end Bridge
+end ModularCurve.KwF4R1V410a
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateChainRule.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateChainRule.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateChainRule.ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateChainRule.ModularCurve.KwF4R1V410a"
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateChainRule.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateChainRule.IsDedekindDomain.HeightOneSpectrum IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateChainRule.IsLocalRing"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace adicIntegersKSubmod tateProj lmulK tateRes \
+  KwF4gRRTateCommFinite KwF4gRRTateChainRule"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section PoleWindowShift
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem coe_smul_K (c : K) (x : u.adicCompletionIntegers) :
+    ((c • x : u.adicCompletionIntegers) : u.adicCompletion) = c • (x : u.adicCompletion) := by
+  rw [Algebra.smul_def, Algebra.smul_def]
+  rfl
+
+def poleWindowShift (πh : u.adicCompletionIntegers) (M : ℕ) :
+    poleWindowKSubmod u πh M →ₗ[K] u.adicCompletionIntegers where
+  toFun x := ⟨(πh : u.adicCompletion) ^ M * (x : u.adicCompletion), x.2⟩
+  map_add' x y := by apply Subtype.ext; push_cast; ring
+  map_smul' c x := by
+    apply Subtype.ext
+    rw [coe_smul_K]
+    change (πh : u.adicCompletion) ^ M * (c • (x : u.adicCompletion))
+        = c • ((πh : u.adicCompletion) ^ M * (x : u.adicCompletion))
+    rw [mul_smul_comm]
+
+theorem poleWindowShift_injective (πh : u.adicCompletionIntegers) (hπh : Irreducible πh)
+    (M : ℕ) : Function.Injective (poleWindowShift u πh M) := by
+  rw [← LinearMap.ker_eq_bot, eq_bot_iff]
+  intro x hx
+  rw [LinearMap.mem_ker] at hx
+  have hπhM0 : (πh : u.adicCompletion) ^ M ≠ 0 := by
+    refine pow_ne_zero M ?_
+    intro hz
+    exact hπh.ne_zero (Subtype.ext hz)
+  have hx0 : (x : u.adicCompletion) = 0 := by
+    have := congrArg Subtype.val hx
+    push_cast at this
+    exact (mul_eq_zero.mp this).resolve_left hπhM0
+  exact Subtype.ext hx0
+
+theorem poleWindowShift_surjective (πh : u.adicCompletionIntegers) (hπh : Irreducible πh)
+    (M : ℕ) : Function.Surjective (poleWindowShift u πh M) := by
+  intro y
+  have hπhM0 : (πh : u.adicCompletion) ^ M ≠ 0 := by
+    refine pow_ne_zero M ?_
+    intro hz; exact hπh.ne_zero (Subtype.ext hz)
+  refine ⟨⟨(y : u.adicCompletion) / (πh : u.adicCompletion) ^ M, ?_⟩, ?_⟩
+  · rw [mem_poleWindowKSubmod_iff, mul_div_cancel₀ _ hπhM0]; exact y.2
+  · apply Subtype.ext
+    change (πh : u.adicCompletion) ^ M * ((y : u.adicCompletion) / (πh : u.adicCompletion) ^ M)
+        = (y : u.adicCompletion)
+    rw [mul_div_cancel₀ _ hπhM0]
+
+def poleWindowShiftEquiv (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) (M : ℕ) :
+    poleWindowKSubmod u πh M ≃ₗ[K] u.adicCompletionIntegers :=
+  LinearEquiv.ofBijective (poleWindowShift u πh M)
+    ⟨poleWindowShift_injective u πh hπh M, poleWindowShift_surjective u πh hπh M⟩
+
+def piPowKSubmod (πh : u.adicCompletionIntegers) (M : ℕ) :
+    Submodule K u.adicCompletionIntegers where
+  carrier := {y | ∃ x : u.adicCompletionIntegers, y = πh ^ M * x}
+  add_mem' := by rintro a b ⟨xa, rfl⟩ ⟨xb, rfl⟩; exact ⟨xa + xb, by ring⟩
+  zero_mem' := ⟨0, by ring⟩
+  smul_mem' c y := by
+    rintro ⟨x, rfl⟩
+    exact ⟨c • x, by rw [Algebra.smul_def, Algebra.smul_def, mul_left_comm]⟩
+
+theorem poleWindowShift_image_integers (πh : u.adicCompletionIntegers) (M : ℕ) :
+    Submodule.map (poleWindowShift u πh M)
+        ((adicIntegersKSubmod u).comap (poleWindowKSubmod u πh M).subtype)
+      = piPowKSubmod u πh M := by
+  ext y
+  constructor
+  · rintro ⟨⟨x, hxP⟩, hxA, rfl⟩
+    refine ⟨⟨(x : u.adicCompletion), hxA⟩, ?_⟩
+    apply Subtype.ext; push_cast; rfl
+  · rintro ⟨x, rfl⟩
+    refine ⟨⟨(x : u.adicCompletion),
+      adicIntegersKSubmod_le_poleWindowKSubmod u πh M x.2⟩, x.2, ?_⟩
+    apply Subtype.ext; push_cast; rfl
+
+variable (K L) in
+def KwF4gRRTateDVRQuotPowKFinite : Prop :=
+  ∀ (u : Place K L) [u.FiniteResidue] (πh : u.adicCompletionIntegers) (_ : Irreducible πh)
+    (M : ℕ),
+    FiniteDimensional K (u.adicCompletionIntegers ⧸ piPowKSubmod u πh M)
+
+theorem kwF4gRRTate_poleWindowFinite_of_DVRQuotPowKFinite
+    (hDVR : KwF4gRRTateDVRQuotPowKFinite K L) :
+    KwF4gRRTatePoleWindowFinite K L := by
+  intro u _ πh hπh M
+  have := hDVR u πh hπh M
+  have e := (poleWindowShiftEquiv u πh hπh M).toLinearMap
+  let e' := Submodule.Quotient.equiv
+    ((adicIntegersKSubmod u).comap (poleWindowKSubmod u πh M).subtype)
+    (piPowKSubmod u πh M)
+    (poleWindowShiftEquiv u πh hπh M)
+    (poleWindowShift_image_integers u πh M)
+  exact FiniteDimensional.of_injective e'.toLinearMap e'.injective
+
+end PoleWindowShift
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateChainRule.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateChainRule.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateChainRule.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace adicIntegersKSubmod tateProj lmulK tateRes \
+  KwF4gRRTateCommFinite KwF4gRRTateChainRule"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section FinrankTraceCyclicity
+
+variable {K M N : Type*} [Field K] [AddCommGroup M] [Module K M] [AddCommGroup N] [Module K N]
+
+theorem range_comp_map_left (f : M →ₗ[K] N) (g : N →ₗ[K] M) :
+    ∀ x ∈ LinearMap.range (g ∘ₗ f), f x ∈ LinearMap.range (f ∘ₗ g) := by
+  rintro x ⟨y, rfl⟩
+  exact ⟨f y, rfl⟩
+
+theorem finrankTrace_comp_comm (f : M →ₗ[K] N) (g : N →ₗ[K] M)
+    [FiniteDimensional K (LinearMap.range (g ∘ₗ f))]
+    [FiniteDimensional K (LinearMap.range (f ∘ₗ g))] :
+    finrankTrace (g ∘ₗ f) = finrankTrace (f ∘ₗ g) := by
+  set W := LinearMap.range (g ∘ₗ f)
+  set W' := LinearMap.range (f ∘ₗ g)
+  let fR : W →ₗ[K] W' := f.restrict (range_comp_map_left f g)
+  let gR : W' →ₗ[K] W := g.restrict (range_comp_map_left g f)
+  have hgf : (g ∘ₗ f).restrict (fun x _ => LinearMap.mem_range_self _ x) = gR ∘ₗ fR := by
+    apply LinearMap.ext; intro x; apply Subtype.ext; rfl
+  have hfg : (f ∘ₗ g).restrict (fun x _ => LinearMap.mem_range_self _ x) = fR ∘ₗ gR := by
+    apply LinearMap.ext; intro x; apply Subtype.ext; rfl
+  unfold finrankTrace
+  rw [hgf, hfg, LinearMap.trace_comp_comm']
+
+end FinrankTraceCyclicity
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateChainRule.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateChainRule.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateChainRule.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace adicIntegersKSubmod tateProj lmulK tateRes \
+  KwF4gRRTateCommFinite KwF4gRRTateChainRule"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section TraceOnSuperspace
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+theorem finrankTrace_eq_trace_on_superspace
+    (φ : V →ₗ[K] V) (W : Submodule K V) [FiniteDimensional K W]
+    (hrange : LinearMap.range φ ≤ W) (hW : ∀ x ∈ W, φ x ∈ W) :
+    haveI : FiniteDimensional K (LinearMap.range φ) :=
+      Submodule.finiteDimensional_of_le hrange
+    finrankTrace φ = LinearMap.trace K W (φ.restrict hW) := by
+  have : FiniteDimensional K (LinearMap.range φ) := Submodule.finiteDimensional_of_le hrange
+  let i : LinearMap.range φ →ₗ[K] W := Submodule.inclusion hrange
+  let π : W →ₗ[K] LinearMap.range φ :=
+    { toFun := fun w => ⟨φ (w : V), LinearMap.mem_range_self φ (w : V)⟩
+      map_add' := fun w₁ w₂ => by simp
+      map_smul' := fun c w => by simp }
+  have hip : i ∘ₗ π = φ.restrict hW := by
+    apply LinearMap.ext; intro w; apply Subtype.ext; rfl
+  have hpi : π ∘ₗ i = φ.restrict (fun x _ => LinearMap.mem_range_self φ x) := by
+    apply LinearMap.ext; intro x; apply Subtype.ext; rfl
+  unfold finrankTrace
+  rw [← hpi, ← hip, LinearMap.trace_comp_comm']
+
+end TraceOnSuperspace
+
+section Additivity
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+theorem finrankTrace_sub_eq
+    (φ ψ : V →ₗ[K] V)
+    [FiniteDimensional K (LinearMap.range φ)]
+    [FiniteDimensional K (LinearMap.range ψ)] :
+    haveI : FiniteDimensional K
+        ((LinearMap.range φ ⊔ LinearMap.range ψ : Submodule K V) : Type _) :=
+      Submodule.finiteDimensional_sup _ _
+    finrankTrace φ - finrankTrace ψ
+      = LinearMap.trace K (LinearMap.range φ ⊔ LinearMap.range ψ : Submodule K V)
+          ((φ - ψ).restrict
+            (p := (LinearMap.range φ ⊔ LinearMap.range ψ : Submodule K V))
+            (fun x _ => sub_mem
+              (Submodule.mem_sup_left (LinearMap.mem_range_self φ x))
+              (Submodule.mem_sup_right (LinearMap.mem_range_self ψ x)))) := by
+  set W' : Submodule K V := LinearMap.range φ ⊔ LinearMap.range ψ with hW'
+  have : FiniteDimensional K W' := Submodule.finiteDimensional_sup _ _
+  have hφW : ∀ x ∈ W', φ x ∈ W' := fun x _ =>
+    Submodule.mem_sup_left (LinearMap.mem_range_self φ x)
+  have hψW : ∀ x ∈ W', ψ x ∈ W' := fun x _ =>
+    Submodule.mem_sup_right (LinearMap.mem_range_self ψ x)
+  rw [finrankTrace_eq_trace_on_superspace φ W' le_sup_left hφW,
+    finrankTrace_eq_trace_on_superspace ψ W' le_sup_right hψW,
+    ← map_sub]
+  refine congrArg (LinearMap.trace K W') (LinearMap.ext fun x => Subtype.ext ?_)
+  rfl
+
+end Additivity
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateChainRule.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateChainRule.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateChainRule.ModularCurve.KwF4gRRTate"
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateChainRule.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateChainRule.IsDedekindDomain.HeightOneSpectrum IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateChainRule.IsLocalRing"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace adicIntegersKSubmod tateProj lmulK tateRes \
+  KwF4gRRTateCommFinite KwF4gRRTateChainRule"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section DVRQuotDischarge
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem piPowKSubmod_eq_restrictScalars (πh : u.adicCompletionIntegers) (M : ℕ) :
+    piPowKSubmod u πh M
+      = (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers).restrictScalars K := by
+  ext y
+  rw [Submodule.restrictScalars_mem, Ideal.mem_span_singleton]
+  exact ⟨fun ⟨x, h⟩ => ⟨x, h⟩, fun ⟨x, h⟩ => ⟨x, h⟩⟩
+
+def quotPiPowEquivIdealQuot (πh : u.adicCompletionIntegers) (M : ℕ) :
+    (u.adicCompletionIntegers ⧸ piPowKSubmod u πh M)
+      ≃ₗ[K] (u.adicCompletionIntegers ⧸ (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers)) :=
+  (Submodule.quotEquivOfEq _ _ (piPowKSubmod_eq_restrictScalars u πh M)).trans
+    (Submodule.Quotient.restrictScalarsEquiv K _)
+
+variable (K L) in
+def KwF4gRRTateDVRCotangentKFinite : Prop :=
+  ∀ (u : Place K L) [u.FiniteResidue] (πh : u.adicCompletionIntegers) (_ : Irreducible πh),
+    FiniteDimensional K
+      (u.adicCompletionIntegers ⧸ (Ideal.span {πh} : Ideal u.adicCompletionIntegers))
+
+theorem range_mulLeft_eq_restrictScalars_span (a : u.adicCompletionIntegers) :
+    LinearMap.range (LinearMap.mulLeft K a)
+      = (Ideal.span {a} : Ideal u.adicCompletionIntegers).restrictScalars K := by
+  ext y
+  simp only [LinearMap.mem_range, LinearMap.mulLeft_apply, Submodule.restrictScalars_mem,
+    Ideal.mem_span_singleton]
+  exact ⟨fun ⟨x, hx⟩ => ⟨x, hx.symm⟩, fun ⟨x, hx⟩ => ⟨x, hx.symm⟩⟩
+
+
+theorem finiteDimensional_restrictScalarsQuot_pow [u.FiniteResidue]
+    (hCot : KwF4gRRTateDVRCotangentKFinite K L)
+    (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) (M : ℕ) :
+    FiniteDimensional K (u.adicCompletionIntegers ⧸
+      (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers).restrictScalars K) := by
+  induction M with
+  | zero =>
+    rw [pow_zero, Ideal.span_singleton_one, Submodule.restrictScalars_top]
+    infer_instance
+  | succ M ih =>
+    have hle : (Ideal.span {πh ^ (M+1)} : Ideal u.adicCompletionIntegers)
+        ≤ Ideal.span {πh ^ M} := by
+      rw [Ideal.span_singleton_le_span_singleton, pow_succ]; exact ⟨πh, rfl⟩
+    have hle' : (Ideal.span {πh ^ (M+1)} : Ideal u.adicCompletionIntegers).restrictScalars K
+        ≤ (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers).restrictScalars K :=
+      Submodule.restrictScalars_mono K hle
+    set N : Submodule K (u.adicCompletionIntegers ⧸
+        (Ideal.span {πh ^ (M+1)} : Ideal u.adicCompletionIntegers).restrictScalars K) :=
+      (Submodule.restrictScalars K (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers)).map
+        (Submodule.restrictScalars K (Ideal.span {πh ^ (M+1)} : Ideal _)).mkQ with hN_def
+    have hquot : FiniteDimensional K
+        ((u.adicCompletionIntegers ⧸
+          (Ideal.span {πh ^ (M+1)} : Ideal _).restrictScalars K) ⧸ N) := by
+      have := ih
+      exact Module.Finite.equiv
+        (Submodule.quotientQuotientEquivQuotient _ _ hle').symm
+    have hN : FiniteDimensional K N := by
+      set φ : u.adicCompletionIntegers →ₗ[K] (u.adicCompletionIntegers ⧸
+          (Ideal.span {πh ^ (M+1)} : Ideal u.adicCompletionIntegers).restrictScalars K) :=
+        (Submodule.restrictScalars K
+            (Ideal.span {πh ^ (M+1)} : Ideal u.adicCompletionIntegers)).mkQ ∘ₗ
+          LinearMap.mulLeft K (πh ^ M) with hφ_def
+      have hrange : LinearMap.range φ = N := by
+        rw [hφ_def, LinearMap.range_comp, range_mulLeft_eq_restrictScalars_span, hN_def]
+      have hker : LinearMap.ker φ
+          = (Ideal.span {πh} : Ideal u.adicCompletionIntegers).restrictScalars K := by
+        simp only [hφ_def, LinearMap.ker_comp, Submodule.ker_mkQ]
+        ext x
+        simp only [Submodule.mem_comap, LinearMap.mulLeft_apply, Submodule.restrictScalars_mem,
+          Ideal.mem_span_singleton]
+        have hπM : (πh : u.adicCompletionIntegers) ^ M ≠ 0 := pow_ne_zero M hπh.ne_zero
+        constructor
+        · rintro ⟨c, hc⟩
+          exact ⟨c, mul_left_cancel₀ hπM (by rw [hc, pow_succ, mul_assoc])⟩
+        · rintro ⟨c, hc⟩
+          exact ⟨c, by rw [hc, pow_succ, mul_assoc]⟩
+      let e₁ : (u.adicCompletionIntegers ⧸
+            (Ideal.span {πh} : Ideal u.adicCompletionIntegers).restrictScalars K)
+          ≃ₗ[K] (u.adicCompletionIntegers ⧸ LinearMap.ker φ) :=
+        Submodule.quotEquivOfEq _ _ hker.symm
+      let e₂ : (u.adicCompletionIntegers ⧸ LinearMap.ker φ) ≃ₗ[K] LinearMap.range φ :=
+        φ.quotKerEquivRange
+      let e₃ : (LinearMap.range φ : Submodule K _) ≃ₗ[K] N := LinearEquiv.ofEq _ _ hrange
+      have hCK : FiniteDimensional K (u.adicCompletionIntegers ⧸
+          (Ideal.span {πh} : Ideal u.adicCompletionIntegers).restrictScalars K) := by
+        have := hCot u πh hπh
+        exact Module.Finite.equiv
+          (Submodule.Quotient.restrictScalarsEquiv K
+            (Ideal.span {πh} : Ideal u.adicCompletionIntegers)).symm
+      exact Module.Finite.equiv ((e₁.trans e₂).trans e₃)
+    exact Module.Finite.of_submodule_quotient N
+
+theorem finiteDimensional_idealQuot_pow [u.FiniteResidue]
+    (hCot : KwF4gRRTateDVRCotangentKFinite K L)
+    (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) (M : ℕ) :
+    FiniteDimensional K
+      (u.adicCompletionIntegers ⧸ (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers)) := by
+  have := finiteDimensional_restrictScalarsQuot_pow u hCot πh hπh M
+  exact Module.Finite.equiv (Submodule.Quotient.restrictScalarsEquiv K _)
+
+theorem kwF4gRRTate_DVRQuotPowKFinite_of_cotangent
+    (hCot : KwF4gRRTateDVRCotangentKFinite K L) :
+    KwF4gRRTateDVRQuotPowKFinite K L := by
+  intro u _ πh hπh M
+  have := finiteDimensional_idealQuot_pow u hCot πh hπh M
+  exact Module.Finite.equiv (quotPiPowEquivIdealQuot u πh M).symm
+
+end DVRQuotDischarge
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateChainRule.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateChainRule.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateChainRule.ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateChainRule.ModularCurve.KwF4R1V410a"
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateChainRule.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateChainRule.IsDedekindDomain.HeightOneSpectrum IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateChainRule.IsLocalRing"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace adicIntegersKSubmod tateProj lmulK tateRes \
+  KwF4gRRTateCommFinite KwF4gRRTateChainRule"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section DVRCotangentDischarge
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+scoped instance instIsScalarTower_K_toValuationSubring_adicCompletionIntegers :
+    IsScalarTower K u.toValuationSubring u.adicCompletionIntegers := by
+  refine IsScalarTower.of_algebraMap_eq fun k => ?_
+  apply Subtype.ext
+  change algebraMap K u.adicCompletion k
+    = (algebraMap u.toValuationSubring u.adicCompletionIntegers (algebraMap K _ k)).val
+  rw [IsScalarTower.algebraMap_apply K L u.adicCompletion]
+  rfl
+
+theorem span_irreducible_eq_completionIdeal_pow_one
+    (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) :
+    (Ideal.span {πh} : Ideal u.adicCompletionIntegers)
+      = (u.heightOneSpectrum.completionIdeal L) ^ 1 := by
+  rw [pow_one, ← hπh.maximalIdeal_eq]
+
+def quotientEquivKAlg (n : ℕ) :
+    (u.toValuationSubring ⧸ (IsLocalRing.maximalIdeal u.toValuationSubring) ^ n)
+      ≃ₐ[K] (u.adicCompletionIntegers ⧸ (u.heightOneSpectrum.completionIdeal L) ^ n) :=
+  { kwF4R1V410a_quotientEquiv u n with
+    commutes' := fun k => by
+      change kwF4R1V410a_quotientEquiv u n (algebraMap K _ k) = algebraMap K _ k
+      rw [IsScalarTower.algebraMap_apply K u.toValuationSubring
+          (u.toValuationSubring ⧸ (IsLocalRing.maximalIdeal u.toValuationSubring) ^ n),
+        Ideal.Quotient.algebraMap_eq, kwF4R1V410a_quotientEquiv_mk,
+        IsScalarTower.algebraMap_apply K u.adicCompletionIntegers
+          (u.adicCompletionIntegers ⧸ (u.heightOneSpectrum.completionIdeal L) ^ n),
+        Ideal.Quotient.algebraMap_eq,
+        IsScalarTower.algebraMap_apply K u.toValuationSubring u.adicCompletionIntegers] }
+
+def quotSpanIrreducibleEquivResidueField (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) :
+    (u.adicCompletionIntegers ⧸ (Ideal.span {πh} : Ideal u.adicCompletionIntegers))
+      ≃ₗ[K] u.ResidueField :=
+  (Ideal.quotientEquivAlgOfEq K
+      (span_irreducible_eq_completionIdeal_pow_one u πh hπh)).toLinearEquiv.trans
+    ((quotientEquivKAlg u 1).symm.toLinearEquiv.trans
+      (Ideal.quotientEquivAlgOfEq K
+        (pow_one (IsLocalRing.maximalIdeal u.toValuationSubring))).toLinearEquiv)
+
+theorem kwF4gRRTate_DVRCotangentKFinite : KwF4gRRTateDVRCotangentKFinite K L := by
+  intro u _ πh hπh
+  have : Module.Finite K u.ResidueField := FiniteResidue.finite
+  exact Module.Finite.equiv (quotSpanIrreducibleEquivResidueField u πh hπh).symm
+
+end DVRCotangentDischarge
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateChainRule.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateChainRule.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateChainRule.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace adicIntegersKSubmod tateProj lmulK tateRes \
+  KwF4gRRTateCommFinite KwF4gRRTateChainRule"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+
+section TermRangeFinite
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable [u.FiniteResidue]
+
+def KwF4gRRTatePoleWindowImageFinite : Prop :=
+  ∀ (fh : u.adicCompletion),
+    FiniteDimensional K (Submodule.map (adicIntegersKSubmod u).mkQ
+      (Submodule.map (lmulK u fh) (adicIntegersKSubmod u)))
+
+end TermRangeFinite
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateChainRule.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateChainRule.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateChainRule.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace adicIntegersKSubmod tateProj lmulK tateRes \
+  KwF4gRRTateCommFinite KwF4gRRTateChainRule"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section Composite
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+
+theorem kwF4gRRTate_poleWindowFinite : KwF4gRRTatePoleWindowFinite K L :=
+  kwF4gRRTate_poleWindowFinite_of_DVRQuotPowKFinite
+    (kwF4gRRTate_DVRQuotPowKFinite_of_cotangent
+      kwF4gRRTate_DVRCotangentKFinite)
+
+end Composite
+
+section Subset
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem lmul_adicIntegers_subset_poleWindow (fh : u.adicCompletion)
+    (πh : u.adicCompletionIntegers) (M : ℕ)
+    (hfhM : (πh : u.adicCompletion) ^ M * fh ∈ u.adicCompletionIntegers) :
+    Submodule.map (lmulK u fh) (adicIntegersKSubmod u) ≤ poleWindowKSubmod u πh M := by
+  rintro x ⟨a, ha, rfl⟩
+  rw [mem_poleWindowKSubmod_iff]
+  show (πh : u.adicCompletion) ^ M * (lmulK u fh) a ∈ u.adicCompletionIntegers
+  have : (lmulK u fh) a = fh * a := rfl
+  rw [this, ← mul_assoc]
+  exact mul_mem hfhM (show a ∈ u.adicCompletionIntegers from ha)
+
+end Subset
+
+section Discharge
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable [u.FiniteResidue]
+
+theorem kwF4gRRTate_poleWindowImageFinite :
+    KwF4gRRTatePoleWindowImageFinite u := by
+  intro fh
+  obtain ⟨πh, hπh⟩ := IsDiscreteValuationRing.exists_irreducible u.adicCompletionIntegers
+  obtain ⟨M, hfhM⟩ := kwF4gRRTate_clearPole u πh hπh fh
+  set A := adicIntegersKSubmod u
+  set P := poleWindowKSubmod u πh M
+  have hsub : Submodule.map A.mkQ (Submodule.map (lmulK u fh) A)
+      ≤ Submodule.map A.mkQ P :=
+    Submodule.map_mono (lmul_adicIntegers_subset_poleWindow u fh πh M hfhM)
+  suffices hPim : FiniteDimensional K (Submodule.map A.mkQ P : Submodule K _) by
+    exact Submodule.finiteDimensional_of_le hsub
+  have : FiniteDimensional K (P ⧸ (A.comap P.subtype)) :=
+    kwF4gRRTate_poleWindowFinite (K := K) (L := L) u πh hπh M
+  let r : P →ₗ[K] (u.adicCompletion ⧸ A) := A.mkQ ∘ₗ P.subtype
+  have hrange : LinearMap.range r = Submodule.map A.mkQ P := by
+    rw [LinearMap.range_comp, Submodule.range_subtype]
+  have hker : LinearMap.ker r = A.comap P.subtype := by
+    rw [LinearMap.ker_comp, Submodule.ker_mkQ]
+  have e : (P ⧸ (A.comap P.subtype)) ≃ₗ[K] LinearMap.range r := hker ▸ r.quotKerEquivRange
+  rw [← hrange]
+  exact e.finiteDimensional
+
+end Discharge
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateChainRule.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateChainRule.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateChainRule.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace adicIntegersKSubmod tateProj lmulK tateRes \
+  KwF4gRRTateCommFinite KwF4gRRTateChainRule"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section Additivity
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+theorem finrankTrace_congr {φ ψ : V →ₗ[K] V}
+    [hφ : FiniteDimensional K (LinearMap.range φ)]
+    [hψ : FiniteDimensional K (LinearMap.range ψ)]
+    (h : φ = ψ) : finrankTrace φ = finrankTrace ψ := by
+  subst h; rfl
+
+theorem range_sub_le (φ ψ : V →ₗ[K] V) :
+    LinearMap.range (φ - ψ) ≤ LinearMap.range φ ⊔ LinearMap.range ψ := by
+  rintro x ⟨y, rfl⟩
+  exact sub_mem (Submodule.mem_sup_left (mem_range_self φ y))
+    (Submodule.mem_sup_right (mem_range_self ψ y))
+
+scoped instance instFinDimRangeSub (φ ψ : V →ₗ[K] V)
+    [FiniteDimensional K (LinearMap.range φ)]
+    [FiniteDimensional K (LinearMap.range ψ)] :
+    FiniteDimensional K (LinearMap.range (φ - ψ)) :=
+  haveI : FiniteDimensional K
+      ((LinearMap.range φ ⊔ LinearMap.range ψ : Submodule K V) : Type _) :=
+    Submodule.finiteDimensional_sup _ _
+  Submodule.finiteDimensional_of_le (range_sub_le φ ψ)
+
+theorem finrankTrace_sub (φ ψ : V →ₗ[K] V)
+    [FiniteDimensional K (LinearMap.range φ)]
+    [FiniteDimensional K (LinearMap.range ψ)] :
+    finrankTrace φ - finrankTrace ψ = finrankTrace (φ - ψ) := by
+  set W' : Submodule K V := LinearMap.range φ ⊔ LinearMap.range ψ
+  have : FiniteDimensional K W' := Submodule.finiteDimensional_sup _ _
+  have hφψW : ∀ x ∈ W', (φ - ψ) x ∈ W' := fun x _ =>
+    sub_mem (Submodule.mem_sup_left (mem_range_self φ x))
+      (Submodule.mem_sup_right (mem_range_self ψ x))
+  rw [finrankTrace_sub_eq φ ψ,
+    finrankTrace_eq_trace_on_superspace (φ - ψ) W' (range_sub_le φ ψ) hφψW]
+
+end Additivity
+
+
+section TermMaps
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+def alphaMap (c : u.adicCompletion) :
+    LinearMap.range (tateProj u) →ₗ[K] (u.adicCompletion ⧸ LinearMap.range (tateProj u)) :=
+  (LinearMap.range (tateProj u)).mkQ ∘ₗ lmulK u c ∘ₗ (LinearMap.range (tateProj u)).subtype
+
+variable [u.FiniteResidue]
+
+theorem finiteDimensional_range_alphaMap (c : u.adicCompletion) :
+    FiniteDimensional K (LinearMap.range (alphaMap u c)) := by
+  have hF21 := kwF4gRRTate_poleWindowImageFinite u c
+  set Q1 := u.adicCompletion ⧸ LinearMap.range (tateProj u)
+  set Q2 := u.adicCompletion ⧸ adicIntegersKSubmod u
+  let eQ : Q1 ≃ₗ[K] Q2 := Submodule.quotEquivOfEq _ _ (range_tateProj u)
+  have hmap : (LinearMap.range (alphaMap u c)).map (eQ : Q1 →ₗ[K] Q2)
+      = Submodule.map (adicIntegersKSubmod u).mkQ
+          (Submodule.map (lmulK u c) (adicIntegersKSubmod u)) := by
+    apply le_antisymm
+    · rintro x ⟨y, hy, rfl⟩
+      obtain ⟨a, rfl⟩ := hy
+      refine ⟨c * (a : u.adicCompletion), ⟨(a : u.adicCompletion), ?_, rfl⟩, ?_⟩
+      · exact (range_tateProj u) ▸ a.2
+      · rfl
+    · rintro x ⟨y, ⟨av, hav, rfl⟩, rfl⟩
+      refine ⟨alphaMap u c ⟨av, (range_tateProj u).symm ▸ hav⟩, ⟨_, rfl⟩, ?_⟩
+      rfl
+  have : FiniteDimensional K
+      ((LinearMap.range (alphaMap u c)).map (eQ : Q1 →ₗ[K] Q2)) := by
+    rw [hmap]; exact hF21
+  exact (Submodule.equivMapOfInjective (eQ : Q1 →ₗ[K] Q2) eQ.injective
+    (LinearMap.range (alphaMap u c))).symm.finiteDimensional
+
+end TermMaps
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateChainRule.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateChainRule.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateChainRule.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace adicIntegersKSubmod tateProj lmulK tateRes \
+  KwF4gRRTateCommFinite KwF4gRRTateChainRule"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section Additivity
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+scoped instance instFinDimRangeNeg (φ : V →ₗ[K] V) [FiniteDimensional K (LinearMap.range φ)] :
+    FiniteDimensional K (LinearMap.range (-φ)) := by
+  have h : LinearMap.range (-φ) = LinearMap.range φ := by
+    apply le_antisymm
+    · rintro x ⟨y, rfl⟩; exact ⟨-y, by simp⟩
+    · rintro x ⟨y, rfl⟩; exact ⟨-y, by simp⟩
+  rw [h]; infer_instance
+
+scoped instance instFinDimRangeZero : FiniteDimensional K (LinearMap.range (0 : V →ₗ[K] V)) := by
+  rw [LinearMap.range_zero]; infer_instance
+
+theorem finrankTrace_zero : finrankTrace (0 : V →ₗ[K] V) = 0 := by
+  unfold finrankTrace
+  have hrest : (0 : V →ₗ[K] V).restrict
+      (p := LinearMap.range (0 : V →ₗ[K] V))
+      (fun x _ => LinearMap.mem_range_self _ x) = 0 := by
+    apply LinearMap.ext; intro; apply Subtype.ext; rfl
+  rw [hrest, _root_.map_zero]
+
+theorem finrankTrace_neg (φ : V →ₗ[K] V) [FiniteDimensional K (LinearMap.range φ)] :
+    finrankTrace (-φ) = -finrankTrace φ := by
+  have hsub := finrankTrace_sub (0 : V →ₗ[K] V) φ
+  rw [finrankTrace_zero, zero_sub] at hsub
+  calc finrankTrace (-φ) = finrankTrace ((0 : V →ₗ[K] V) - φ) :=
+        finrankTrace_congr (zero_sub φ).symm
+    _ = -finrankTrace φ := hsub.symm
+
+scoped instance instFinDimRangeAdd (φ ψ : V →ₗ[K] V)
+    [FiniteDimensional K (LinearMap.range φ)]
+    [FiniteDimensional K (LinearMap.range ψ)] :
+    FiniteDimensional K (LinearMap.range (φ + ψ)) := by
+  rw [show φ + ψ = φ - (-ψ) from (sub_neg_eq_add φ ψ).symm]
+  exact instFinDimRangeSub φ (-ψ)
+
+theorem finrankTrace_add (φ ψ : V →ₗ[K] V)
+    [FiniteDimensional K (LinearMap.range φ)]
+    [FiniteDimensional K (LinearMap.range ψ)] :
+    finrankTrace (φ + ψ) = finrankTrace φ + finrankTrace ψ := by
+  have h := finrankTrace_sub φ (-ψ)
+  rw [finrankTrace_neg, sub_neg_eq_add] at h
+  calc finrankTrace (φ + ψ) = finrankTrace (φ - (-ψ)) :=
+        finrankTrace_congr (sub_neg_eq_add φ ψ).symm
+    _ = finrankTrace φ + finrankTrace ψ := h.symm
+
+end Additivity
+
+section TateCommAddFst
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+theorem tateComm_add_fst (pA φ₁ φ₂ ψ : V →ₗ[K] V) :
+    tateComm pA (φ₁ + φ₂) ψ = tateComm pA φ₁ ψ + tateComm pA φ₂ ψ := by
+  unfold tateComm
+  ext x
+  simp only [LinearMap.add_apply, LinearMap.sub_apply, LinearMap.comp_apply, map_add]
+  abel
+
+theorem tateCommRestrict_add_fst (pA φ₁ φ₂ ψ : V →ₗ[K] V) :
+    tateCommRestrict pA (φ₁ + φ₂) ψ
+      = tateCommRestrict pA φ₁ ψ + tateCommRestrict pA φ₂ ψ := by
+  apply LinearMap.ext; intro a; apply Subtype.ext
+  change (tateCommRestrict pA (φ₁ + φ₂) ψ a : V)
+    = (tateCommRestrict pA φ₁ ψ a : V) + (tateCommRestrict pA φ₂ ψ a : V)
+  rw [tateCommRestrict_apply, tateCommRestrict_apply, tateCommRestrict_apply]
+  exact congrFun (congrArg DFunLike.coe (tateComm_add_fst pA φ₁ φ₂ ψ)) (a : V)
+
+theorem tateCommTrace_add_fst (pA φ₁ φ₂ ψ : V →ₗ[K] V)
+    [FiniteDimensional K (LinearMap.range (tateCommRestrict pA φ₁ ψ))]
+    [FiniteDimensional K (LinearMap.range (tateCommRestrict pA φ₂ ψ))] :
+    haveI : FiniteDimensional K (LinearMap.range (tateCommRestrict pA (φ₁ + φ₂) ψ)) := by
+      rw [tateCommRestrict_add_fst]; exact instFinDimRangeAdd _ _
+    tateCommTrace pA (φ₁ + φ₂) ψ = tateCommTrace pA φ₁ ψ + tateCommTrace pA φ₂ ψ := by
+  have : FiniteDimensional K (LinearMap.range (tateCommRestrict pA (φ₁ + φ₂) ψ)) := by
+    rw [tateCommRestrict_add_fst]; exact instFinDimRangeAdd _ _
+  unfold tateCommTrace
+  rw [← finrankTrace_add]
+  exact finrankTrace_congr (tateCommRestrict_add_fst pA φ₁ φ₂ ψ)
+
+end TateCommAddFst
+
+section TateResAddFst
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem tateRes_add_fst (fh₁ fh₂ gh : u.adicCompletion)
+    [FiniteDimensional K (LinearMap.range
+      (tateCommRestrict (tateProj u) (lmulK u fh₁) (lmulK u gh)))]
+    [FiniteDimensional K (LinearMap.range
+      (tateCommRestrict (tateProj u) (lmulK u fh₂) (lmulK u gh)))] :
+    haveI : FiniteDimensional K (LinearMap.range
+        (tateCommRestrict (tateProj u) (lmulK u (fh₁ + fh₂)) (lmulK u gh))) := by
+      have heq : lmulK u (fh₁ + fh₂) = lmulK u fh₁ + lmulK u fh₂ := map_add _ _ _
+      rw [heq, tateCommRestrict_add_fst]; exact instFinDimRangeAdd _ _
+    tateRes u (fh₁ + fh₂) gh = tateRes u fh₁ gh + tateRes u fh₂ gh := by
+  have heq : lmulK u (fh₁ + fh₂) = lmulK u fh₁ + lmulK u fh₂ := map_add _ _ _
+  have : FiniteDimensional K (LinearMap.range
+      (tateCommRestrict (tateProj u) (lmulK u (fh₁ + fh₂)) (lmulK u gh))) := by
+    rw [heq, tateCommRestrict_add_fst]; exact instFinDimRangeAdd _ _
+  have : FiniteDimensional K (LinearMap.range
+      (tateCommRestrict (tateProj u) (lmulK u fh₁ + lmulK u fh₂) (lmulK u gh))) := by
+    rw [tateCommRestrict_add_fst]; exact instFinDimRangeAdd _ _
+  unfold tateRes
+  have hct := tateCommTrace_add_fst (tateProj u) (lmulK u fh₁) (lmulK u fh₂) (lmulK u gh)
+  unfold tateCommTrace at hct ⊢
+  rw [← hct]
+  exact finrankTrace_congr (by rw [heq])
+
+end TateResAddFst
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateChainRule.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateChainRule.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateChainRule.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace adicIntegersKSubmod tateProj lmulK tateRes \
+  KwF4gRRTateCommFinite KwF4gRRTateChainRule"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section AddSnd
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+theorem tateComm_add_snd (pA φ ψ₁ ψ₂ : V →ₗ[K] V) :
+    tateComm pA φ (ψ₁ + ψ₂) = tateComm pA φ ψ₁ + tateComm pA φ ψ₂ := by
+  unfold tateComm
+  ext x
+  simp only [LinearMap.add_apply, LinearMap.sub_apply, LinearMap.comp_apply, map_add]
+  abel
+
+theorem tateCommRestrict_add_snd (pA φ ψ₁ ψ₂ : V →ₗ[K] V) :
+    tateCommRestrict pA φ (ψ₁ + ψ₂)
+      = tateCommRestrict pA φ ψ₁ + tateCommRestrict pA φ ψ₂ := by
+  apply LinearMap.ext; intro a; apply Subtype.ext
+  change (tateCommRestrict pA φ (ψ₁ + ψ₂) a : V)
+    = (tateCommRestrict pA φ ψ₁ a : V) + (tateCommRestrict pA φ ψ₂ a : V)
+  rw [tateCommRestrict_apply, tateCommRestrict_apply, tateCommRestrict_apply]
+  exact congrFun (congrArg DFunLike.coe (tateComm_add_snd pA φ ψ₁ ψ₂)) (a : V)
+
+theorem tateCommTrace_add_snd (pA φ ψ₁ ψ₂ : V →ₗ[K] V)
+    [FiniteDimensional K (LinearMap.range (tateCommRestrict pA φ ψ₁))]
+    [FiniteDimensional K (LinearMap.range (tateCommRestrict pA φ ψ₂))] :
+    haveI : FiniteDimensional K (LinearMap.range (tateCommRestrict pA φ (ψ₁ + ψ₂))) := by
+      rw [tateCommRestrict_add_snd]; exact instFinDimRangeAdd _ _
+    tateCommTrace pA φ (ψ₁ + ψ₂) = tateCommTrace pA φ ψ₁ + tateCommTrace pA φ ψ₂ := by
+  have : FiniteDimensional K (LinearMap.range (tateCommRestrict pA φ (ψ₁ + ψ₂))) := by
+    rw [tateCommRestrict_add_snd]; exact instFinDimRangeAdd _ _
+  unfold tateCommTrace
+  rw [← finrankTrace_add]
+  exact finrankTrace_congr (tateCommRestrict_add_snd pA φ ψ₁ ψ₂)
+
+end AddSnd
+
+section CommutatorVanish
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+scoped instance instFinDimRangeCompRight (φ ψ : V →ₗ[K] V)
+    [FiniteDimensional K (LinearMap.range ψ)] :
+    FiniteDimensional K (LinearMap.range (φ ∘ₗ ψ)) := by
+  rw [LinearMap.range_comp]; infer_instance
+
+scoped instance instFinDimRangeCompLeft (φ ψ : V →ₗ[K] V)
+    [FiniteDimensional K (LinearMap.range ψ)] :
+    FiniteDimensional K (LinearMap.range (ψ ∘ₗ φ)) :=
+  Submodule.finiteDimensional_of_le (LinearMap.range_comp_le_range _ _)
+
+theorem finrankTrace_commutator_eq_zero (φ ψ : V →ₗ[K] V)
+    [FiniteDimensional K (LinearMap.range ψ)] :
+    finrankTrace (φ ∘ₗ ψ - ψ ∘ₗ φ) = 0 := by
+  rw [← finrankTrace_sub, finrankTrace_comp_comm ψ φ, sub_self]
+
+end CommutatorVanish
+
+section LeibnizAbstract
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+def piRestrict (pA φ : V →ₗ[K] V) : LinearMap.range pA →ₗ[K] LinearMap.range pA :=
+  (pA ∘ₗ φ).restrict (fun x _ => LinearMap.mem_range_self pA (φ x))
+
+theorem piRestrict_apply (pA φ : V →ₗ[K] V) (a : LinearMap.range pA) :
+    (piRestrict pA φ a : V) = pA (φ (a : V)) := rfl
+
+def epsRestrict (pA φ ψ : V →ₗ[K] V) : LinearMap.range pA →ₗ[K] LinearMap.range pA :=
+  (pA ∘ₗ φ ∘ₗ (LinearMap.id - pA) ∘ₗ ψ).restrict
+    (fun _ _ => LinearMap.mem_range_self pA _)
+
+theorem epsRestrict_apply (pA φ ψ : V →ₗ[K] V) (a : LinearMap.range pA) :
+    (epsRestrict pA φ ψ a : V) = pA (φ (ψ (a : V) - pA (ψ (a : V)))) := by
+  change pA (φ ((LinearMap.id (R := K) (M := V) - pA) (ψ (a : V)))) = _
+  rw [LinearMap.sub_apply, LinearMap.id_apply]
+
+theorem piRestrict_comp_eq (pA φ ψ : V →ₗ[K] V) :
+    piRestrict pA (φ ∘ₗ ψ) = piRestrict pA φ ∘ₗ piRestrict pA ψ + epsRestrict pA φ ψ := by
+  apply LinearMap.ext; intro a; apply Subtype.ext
+  change pA (φ (ψ (a : V))) = pA (φ (pA (ψ (a : V)))) + (epsRestrict pA φ ψ a : V)
+  rw [epsRestrict_apply, ← map_add, ← map_add]
+  congr 2
+  abel
+
+theorem tateCommRestrict_eq_bracket (pA f g : V →ₗ[K] V) :
+    tateCommRestrict pA f g
+      = piRestrict pA f ∘ₗ piRestrict pA g - piRestrict pA g ∘ₗ piRestrict pA f := by
+  apply LinearMap.ext; intro a; apply Subtype.ext
+  simp only [LinearMap.sub_apply, AddSubgroupClass.coe_sub, LinearMap.comp_apply]
+  rw [tateCommRestrict_apply, tateComm_apply, piRestrict_apply, piRestrict_apply,
+    piRestrict_apply, piRestrict_apply]
+
+theorem bracket_leibniz_defect {R W : Type*} [CommRing R] [AddCommGroup W] [Module R W]
+    (F G H : W →ₗ[R] W) :
+    (F ∘ₗ (G ∘ₗ H) - (G ∘ₗ H) ∘ₗ F)
+      - ((F ∘ₗ G) ∘ₗ H - H ∘ₗ (F ∘ₗ G))
+      - ((F ∘ₗ H) ∘ₗ G - G ∘ₗ (F ∘ₗ H))
+      = G ∘ₗ (F ∘ₗ H - H ∘ₗ F) - (F ∘ₗ H - H ∘ₗ F) ∘ₗ G := by
+  apply LinearMap.ext; intro x
+  simp only [LinearMap.sub_apply, LinearMap.comp_apply, map_sub]
+  abel
+
+theorem tateCommTrace_leibniz_snd (pA f g h : V →ₗ[K] V)
+    (hfin_fh : FiniteDimensional K (LinearMap.range (tateCommRestrict pA f h)))
+    (hfin_gh : FiniteDimensional K (LinearMap.range (epsRestrict pA g h)))
+    (hfin_fg : FiniteDimensional K (LinearMap.range (epsRestrict pA f g)))
+    (hfin_fh' : FiniteDimensional K (LinearMap.range (epsRestrict pA f h)))
+    [FiniteDimensional K (LinearMap.range (tateCommRestrict pA f (g ∘ₗ h)))]
+    [FiniteDimensional K (LinearMap.range (tateCommRestrict pA (f ∘ₗ g) h))]
+    [FiniteDimensional K (LinearMap.range (tateCommRestrict pA (f ∘ₗ h) g))] :
+    tateCommTrace pA f (g ∘ₗ h)
+      = tateCommTrace pA (f ∘ₗ g) h + tateCommTrace pA (f ∘ₗ h) g := by
+  set A := LinearMap.range pA
+  set F := piRestrict pA f
+  set G := piRestrict pA g
+  set H := piRestrict pA h
+  set εgh := epsRestrict pA g h
+  set εfg := epsRestrict pA f g
+  set εfh := epsRestrict pA f h
+  set CFH := F ∘ₗ H - H ∘ₗ F
+  have : FiniteDimensional K (LinearMap.range εgh) := hfin_gh
+  have : FiniteDimensional K (LinearMap.range εfg) := hfin_fg
+  have : FiniteDimensional K (LinearMap.range εfh) := hfin_fh'
+  have hCFH : FiniteDimensional K (LinearMap.range CFH) := by
+    have : CFH = tateCommRestrict pA f h := (tateCommRestrict_eq_bracket pA f h).symm
+    rw [this]; exact hfin_fh
+  have hLHS : tateCommRestrict pA f (g ∘ₗ h)
+      = (F ∘ₗ (G ∘ₗ H) - (G ∘ₗ H) ∘ₗ F)
+        + (F ∘ₗ εgh - εgh ∘ₗ F) := by
+    rw [tateCommRestrict_eq_bracket, piRestrict_comp_eq]
+    show piRestrict pA f ∘ₗ (piRestrict pA g ∘ₗ piRestrict pA h + epsRestrict pA g h)
+        - (piRestrict pA g ∘ₗ piRestrict pA h + epsRestrict pA g h) ∘ₗ piRestrict pA f = _
+    apply LinearMap.ext; intro a
+    simp only [LinearMap.add_apply, LinearMap.sub_apply, LinearMap.comp_apply, map_add]
+    abel
+  have hRHS₁ : tateCommRestrict pA (f ∘ₗ g) h
+      = ((F ∘ₗ G) ∘ₗ H - H ∘ₗ (F ∘ₗ G))
+        + (εfg ∘ₗ H - H ∘ₗ εfg) := by
+    rw [tateCommRestrict_eq_bracket, piRestrict_comp_eq]
+    show (piRestrict pA f ∘ₗ piRestrict pA g + epsRestrict pA f g) ∘ₗ piRestrict pA h
+        - piRestrict pA h ∘ₗ (piRestrict pA f ∘ₗ piRestrict pA g + epsRestrict pA f g) = _
+    apply LinearMap.ext; intro a
+    simp only [LinearMap.add_apply, LinearMap.sub_apply, LinearMap.comp_apply, map_add]
+    abel
+  have hRHS₂ : tateCommRestrict pA (f ∘ₗ h) g
+      = ((F ∘ₗ H) ∘ₗ G - G ∘ₗ (F ∘ₗ H))
+        + (εfh ∘ₗ G - G ∘ₗ εfh) := by
+    rw [tateCommRestrict_eq_bracket, piRestrict_comp_eq]
+    show (piRestrict pA f ∘ₗ piRestrict pA h + epsRestrict pA f h) ∘ₗ piRestrict pA g
+        - piRestrict pA g ∘ₗ (piRestrict pA f ∘ₗ piRestrict pA h + epsRestrict pA f h) = _
+    apply LinearMap.ext; intro a
+    simp only [LinearMap.add_apply, LinearMap.sub_apply, LinearMap.comp_apply, map_add]
+    abel
+  have hDefect : tateCommRestrict pA f (g ∘ₗ h)
+      - tateCommRestrict pA (f ∘ₗ g) h - tateCommRestrict pA (f ∘ₗ h) g
+      = (G ∘ₗ CFH - CFH ∘ₗ G)
+        + (F ∘ₗ εgh - εgh ∘ₗ F)
+        - (εfg ∘ₗ H - H ∘ₗ εfg)
+        - (εfh ∘ₗ G - G ∘ₗ εfh) := by
+    rw [hLHS, hRHS₁, hRHS₂]
+    have := bracket_leibniz_defect (R := K) F G H
+    change _ = (G ∘ₗ CFH - CFH ∘ₗ G) + _ - _ - _
+    rw [show G ∘ₗ CFH - CFH ∘ₗ G
+      = (F ∘ₗ (G ∘ₗ H) - (G ∘ₗ H) ∘ₗ F)
+        - ((F ∘ₗ G) ∘ₗ H - H ∘ₗ (F ∘ₗ G))
+        - ((F ∘ₗ H) ∘ₗ G - G ∘ₗ (F ∘ₗ H)) from this.symm]
+    abel
+  have hT1 : finrankTrace (G ∘ₗ CFH - CFH ∘ₗ G) = 0 :=
+    finrankTrace_commutator_eq_zero G CFH
+  have hT2 : finrankTrace (F ∘ₗ εgh - εgh ∘ₗ F) = 0 :=
+    finrankTrace_commutator_eq_zero F εgh
+  have hT3' : finrankTrace (H ∘ₗ εfg - εfg ∘ₗ H) = 0 :=
+    finrankTrace_commutator_eq_zero H εfg
+  have hT3 : finrankTrace (εfg ∘ₗ H - H ∘ₗ εfg) = 0 := by
+    have hneg : εfg ∘ₗ H - H ∘ₗ εfg = -(H ∘ₗ εfg - εfg ∘ₗ H) := by abel
+    rw [show finrankTrace (εfg ∘ₗ H - H ∘ₗ εfg)
+        = finrankTrace (-(H ∘ₗ εfg - εfg ∘ₗ H)) from finrankTrace_congr hneg,
+      finrankTrace_neg, hT3', _root_.neg_zero]
+  have hT4' : finrankTrace (G ∘ₗ εfh - εfh ∘ₗ G) = 0 :=
+    finrankTrace_commutator_eq_zero G εfh
+  have hT4 : finrankTrace (εfh ∘ₗ G - G ∘ₗ εfh) = 0 := by
+    have hneg : εfh ∘ₗ G - G ∘ₗ εfh = -(G ∘ₗ εfh - εfh ∘ₗ G) := by abel
+    rw [show finrankTrace (εfh ∘ₗ G - G ∘ₗ εfh)
+        = finrankTrace (-(G ∘ₗ εfh - εfh ∘ₗ G)) from finrankTrace_congr hneg,
+      finrankTrace_neg, hT4', _root_.neg_zero]
+  unfold tateCommTrace
+  set L := tateCommRestrict pA f (g ∘ₗ h)
+  set R₁ := tateCommRestrict pA (f ∘ₗ g) h
+  set R₂ := tateCommRestrict pA (f ∘ₗ h) g
+  set D := L - R₁ - R₂ with hDdef
+  have : FiniteDimensional K (LinearMap.range D) := by
+    rw [hDdef]; exact instFinDimRangeSub _ _
+  have hDtrace : finrankTrace D = 0 := by
+    rw [finrankTrace_congr hDefect]
+    set T1 := G ∘ₗ CFH - CFH ∘ₗ G
+    set T2 := F ∘ₗ εgh - εgh ∘ₗ F
+    set T3 := εfg ∘ₗ H - H ∘ₗ εfg
+    set T4 := εfh ∘ₗ G - G ∘ₗ εfh
+    have : FiniteDimensional K (LinearMap.range T1) := instFinDimRangeSub _ _
+    have : FiniteDimensional K (LinearMap.range T2) := instFinDimRangeSub _ _
+    have : FiniteDimensional K (LinearMap.range T3) := instFinDimRangeSub _ _
+    have : FiniteDimensional K (LinearMap.range T4) := instFinDimRangeSub _ _
+    have : FiniteDimensional K (LinearMap.range (T1 + T2)) := instFinDimRangeAdd _ _
+    have : FiniteDimensional K (LinearMap.range (T1 + T2 - T3)) := instFinDimRangeSub _ _
+    calc finrankTrace (T1 + T2 - T3 - T4)
+        = finrankTrace (T1 + T2 - T3) - finrankTrace T4 := (finrankTrace_sub _ _).symm
+      _ = finrankTrace (T1 + T2) - finrankTrace T3 - finrankTrace T4 := by
+          rw [(finrankTrace_sub (T1 + T2) T3).symm]
+      _ = finrankTrace T1 + finrankTrace T2 - finrankTrace T3 - finrankTrace T4 := by
+          rw [finrankTrace_add T1 T2]
+      _ = 0 := by rw [hT1, hT2, hT3, hT4]; ring
+  have hLdecomp : L = R₁ + R₂ + D := by rw [hDdef]; abel
+  rw [finrankTrace_congr hLdecomp, finrankTrace_add, finrankTrace_add, hDtrace, add_zero]
+
+end LeibnizAbstract
+
+section TateResLeibniz
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable [u.FiniteResidue]
+
+theorem finiteDimensional_range_epsRestrict_lmulK (φ ψ : u.adicCompletion) :
+    FiniteDimensional K (LinearMap.range
+      (epsRestrict (tateProj u) (lmulK u φ) (lmulK u ψ))) := by
+  have hα := finiteDimensional_range_alphaMap u ψ
+  set pA := tateProj u
+  set β : (u.adicCompletion ⧸ LinearMap.range pA) →ₗ[K] LinearMap.range pA :=
+    (LinearMap.range pA).liftQ
+      ((pA ∘ₗ lmulK u φ ∘ₗ (LinearMap.id - pA)).codRestrict (LinearMap.range pA)
+        (fun x => LinearMap.mem_range_self pA _))
+      (by
+        rintro x ⟨y, rfl⟩
+        apply Subtype.ext
+        change (pA ∘ₗ lmulK u φ ∘ₗ (LinearMap.id - pA)) (pA y) = (0 : u.adicCompletion)
+        simp only [LinearMap.comp_apply, LinearMap.sub_apply, LinearMap.id_apply]
+        rw [show pA (pA y) = pA y from congrFun (congrArg DFunLike.coe (tateProj_idem u)) y,
+          sub_self, _root_.map_zero, _root_.map_zero])
+    with hβdef
+  have hfactor : epsRestrict pA (lmulK u φ) (lmulK u ψ) = β ∘ₗ alphaMap u ψ := by
+    apply LinearMap.ext; intro a; apply Subtype.ext
+    rw [epsRestrict_apply]
+    rfl
+  rw [hfactor, LinearMap.range_comp]
+  infer_instance
+
+theorem tateRes_leibniz_snd (hfin : KwF4gRRTateCommFinite K L)
+    (f g h : u.adicCompletion) :
+    haveI := hfin u f (g * h)
+    haveI := hfin u (f * g) h
+    haveI := hfin u (f * h) g
+    tateRes u f (g * h) = tateRes u (f * g) h + tateRes u (f * h) g := by
+  have := hfin u f (g * h)
+  have := hfin u (f * g) h
+  have := hfin u (f * h) g
+  have := hfin u f h
+  have hlmul : ∀ x y : u.adicCompletion, lmulK u (x * y) = lmulK u x ∘ₗ lmulK u y := by
+    intro x y
+    apply LinearMap.ext; intro z
+    change (x * y) * z = x * (y * z)
+    ring
+  have hL : FiniteDimensional K (LinearMap.range
+      (tateCommRestrict (tateProj u) (lmulK u f) (lmulK u g ∘ₗ lmulK u h))) := by
+    rw [← hlmul g h]; exact hfin u f (g * h)
+  have hR₁ : FiniteDimensional K (LinearMap.range
+      (tateCommRestrict (tateProj u) (lmulK u f ∘ₗ lmulK u g) (lmulK u h))) := by
+    rw [← hlmul f g]; exact hfin u (f * g) h
+  have hR₂ : FiniteDimensional K (LinearMap.range
+      (tateCommRestrict (tateProj u) (lmulK u f ∘ₗ lmulK u h) (lmulK u g))) := by
+    rw [← hlmul f h]; exact hfin u (f * h) g
+  have hleib := tateCommTrace_leibniz_snd (tateProj u) (lmulK u f) (lmulK u g) (lmulK u h)
+    (hfin u f h)
+    (finiteDimensional_range_epsRestrict_lmulK u g h)
+    (finiteDimensional_range_epsRestrict_lmulK u f g)
+    (finiteDimensional_range_epsRestrict_lmulK u f h)
+  unfold tateRes
+  unfold tateCommTrace at hleib ⊢
+  rw [finrankTrace_congr (by rw [hlmul g h] : tateCommRestrict (tateProj u) (lmulK u f)
+        (lmulK u (g * h)) = tateCommRestrict (tateProj u) (lmulK u f)
+        (lmulK u g ∘ₗ lmulK u h)),
+    finrankTrace_congr (by rw [hlmul f g] : tateCommRestrict (tateProj u)
+        (lmulK u (f * g)) (lmulK u h) = tateCommRestrict (tateProj u)
+        (lmulK u f ∘ₗ lmulK u g) (lmulK u h)),
+    finrankTrace_congr (by rw [hlmul f h] : tateCommRestrict (tateProj u)
+        (lmulK u (f * h)) (lmulK u g) = tateCommRestrict (tateProj u)
+        (lmulK u f ∘ₗ lmulK u h) (lmulK u g))]
+  exact hleib
+
+end TateResLeibniz
+
+section TateResCongr
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem tateRes_congr_fst {fh₁ fh₂ gh : u.adicCompletion} (heq : fh₁ = fh₂)
+    [h₁ : FiniteDimensional K (LinearMap.range
+      (tateCommRestrict (tateProj u) (lmulK u fh₁) (lmulK u gh)))]
+    [h₂ : FiniteDimensional K (LinearMap.range
+      (tateCommRestrict (tateProj u) (lmulK u fh₂) (lmulK u gh)))] :
+    tateRes u fh₁ gh = tateRes u fh₂ gh := by
+  subst heq; rfl
+
+end TateResCongr
+
+section DerivationFactor
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+def KwF4gRRTateDerivationFactorSnd [HasPrincipalDivisors K F] [Nontrivial Ω[F⁄K]]
+    (hfinF : KwF4gRRTateCommFinite K F) : Prop :=
+  ∀ (w : Place K F) [w.DCoordGenerates] (f : w.adicCompletion) (g : F),
+    haveI := hfinF w f (algebraMap F w.adicCompletion g)
+    haveI := hfinF w (f * algebraMap F w.adicCompletion
+      (w.differentialCoeff (KaehlerDifferential.D K F g)))
+      (algebraMap F w.adicCompletion w.uniformizer)
+    tateRes w f (algebraMap F w.adicCompletion g)
+      = tateRes w (f * algebraMap F w.adicCompletion
+          (w.differentialCoeff (KaehlerDifferential.D K F g)))
+          (algebraMap F w.adicCompletion w.uniformizer)
+
+end DerivationFactor
+
+section Reprice
+
+variable {K F E : Type*} [Field K] [Field F] [Algebra K F]
+variable [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+theorem kwF4gRRTate_chainRule_of_derivationFactor
+    (hfinF : KwF4gRRTateCommFinite K F)
+    (hDF : ∀ [HasPrincipalDivisors K F] [Nontrivial Ω[F⁄K]],
+      KwF4gRRTateDerivationFactorSnd K F hfinF) :
+    KwF4gRRTateChainRule K F E hfinF := by
+  intro _ _ _ _ _ v _ w _ _ fh
+  have hDFw := hDF w fh (algebraMap E F v.uniformizer)
+  have hker : KaehlerDifferential.D K F (algebraMap E F v.uniformizer)
+      = kaehlerPullback K F E v.dCoord :=
+    (kaehlerPullback_D (K := K) (F := F) (E := E) v.uniformizer).symm
+  have hX : fh * algebraMap F w.adicCompletion
+        (w.differentialCoeff (kaehlerPullback K F E v.dCoord))
+      = fh * algebraMap F w.adicCompletion
+        (w.differentialCoeff (KaehlerDifferential.D K F (algebraMap E F v.uniformizer))) := by
+    rw [hker]
+  have := hfinF w fh (algebraMap F w.adicCompletion (algebraMap E F v.uniformizer))
+  have := hfinF w (fh * algebraMap F w.adicCompletion
+    (w.differentialCoeff (KaehlerDifferential.D K F (algebraMap E F v.uniformizer))))
+    (algebraMap F w.adicCompletion w.uniformizer)
+  have := hfinF w (fh * algebraMap F w.adicCompletion
+    (w.differentialCoeff (kaehlerPullback K F E v.dCoord)))
+    (algebraMap F w.adicCompletion w.uniformizer)
+  calc tateRes w fh (algebraMap F w.adicCompletion (algebraMap E F v.uniformizer))
+      = tateRes w (fh * algebraMap F w.adicCompletion
+          (w.differentialCoeff (KaehlerDifferential.D K F (algebraMap E F v.uniformizer))))
+          (algebraMap F w.adicCompletion w.uniformizer) := hDFw
+    _ = tateRes w (fh * algebraMap F w.adicCompletion
+          (w.differentialCoeff (kaehlerPullback K F E v.dCoord)))
+          (algebraMap F w.adicCompletion w.uniformizer) := tateRes_congr_fst w hX.symm
+
+end Reprice
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateChainRule.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateChainRule.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateChainRule.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateChainRule.ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateChainRule.ModularCurve.KwF4R1V473a"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateChainRule"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace adicIntegersKSubmod tateProj lmulK tateRes \
+  KwF4gRRTateCommFinite KwF4gRRTateChainRule"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section DualDom
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+def DualDom (w : Place K F) : Type _ := w.adicCompletion →ₗ[K] K
+
+scoped instance (w : Place K F) : AddCommGroup (DualDom w) :=
+  inferInstanceAs (AddCommGroup (w.adicCompletion →ₗ[K] K))
+
+def DualDom.toLM {w : Place K F} (φ : DualDom w) : w.adicCompletion →ₗ[K] K := φ
+
+@[scoped ext] theorem DualDom.ext {w : Place K F} {φ ψ : DualDom w}
+    (h : ∀ x, φ.toLM x = ψ.toLM x) : φ = ψ := LinearMap.ext h
+
+@[scoped simp] theorem DualDom.toLM_add {w : Place K F} (φ ψ : DualDom w) :
+    (φ + ψ).toLM = φ.toLM + ψ.toLM := rfl
+
+scoped instance (w : Place K F) : Module F (DualDom w) where
+  smul h φ := φ.toLM ∘ₗ lmulK w (algebraMap F w.adicCompletion h)
+  one_smul φ := DualDom.ext fun x => by
+    change φ.toLM (algebraMap F w.adicCompletion 1 * x) = φ.toLM x
+    rw [_root_.map_one, one_mul]
+  mul_smul a b φ := DualDom.ext fun x => by
+    change φ.toLM (algebraMap F _ (a * b) * x) = φ.toLM (algebraMap F _ b * (algebraMap F _ a * x))
+    rw [(algebraMap F w.adicCompletion).map_mul, mul_comm (algebraMap F _ a), mul_assoc]
+  smul_zero a := DualDom.ext fun _ => rfl
+  smul_add a φ ψ := DualDom.ext fun _ => rfl
+  add_smul a b φ := DualDom.ext fun x => by
+    change φ.toLM (algebraMap F _ (a + b) * x)
+      = φ.toLM (algebraMap F _ a * x) + φ.toLM (algebraMap F _ b * x)
+    rw [(algebraMap F w.adicCompletion).map_add, add_mul, φ.toLM.map_add]
+  zero_smul φ := DualDom.ext fun x => by
+    change φ.toLM (algebraMap F _ 0 * x) = 0
+    rw [(algebraMap F w.adicCompletion).map_zero, zero_mul, φ.toLM.map_zero]
+
+@[scoped simp] theorem DualDom.smul_apply {w : Place K F} (h : F) (φ : DualDom w)
+    (x : w.adicCompletion) :
+    (h • φ).toLM x = φ.toLM (algebraMap F w.adicCompletion h * x) := rfl
+
+scoped instance (w : Place K F) : Module K (DualDom w) :=
+  inferInstanceAs (Module K (w.adicCompletion →ₗ[K] K))
+
+theorem DualDom.k_smul_apply {w : Place K F} (c : K) (φ : DualDom w)
+    (x : w.adicCompletion) :
+    (c • φ).toLM x = c • φ.toLM x := rfl
+
+scoped instance (w : Place K F) : IsScalarTower K F (DualDom w) where
+  smul_assoc c h φ := DualDom.ext fun x => by
+    change φ.toLM (algebraMap F _ (c • h) * x) = c • φ.toLM (algebraMap F _ h * x)
+    rw [Algebra.smul_def, (algebraMap F w.adicCompletion).map_mul,
+      ← IsScalarTower.algebraMap_apply K F w.adicCompletion,
+      Algebra.algebraMap_eq_smul_one, smul_mul_assoc, one_mul, smul_mul_assoc, φ.toLM.map_smul]
+
+end DualDom
+
+section GenericFactor
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {M : Type*} [AddCommGroup M] [Module K M] [Module F M] [IsScalarTower K F M]
+
+theorem derivation_apply_eq_diffCoeff_smul (w : Place K F) [w.DCoordGenerates]
+    (δ : Derivation K F M) (g : F) :
+    δ g = w.differentialCoeff (KaehlerDifferential.D K F g) • δ w.uniformizer := by
+  have hL := Derivation.liftKaehlerDifferential_comp_D δ
+  have hLπ : δ.liftKaehlerDifferential w.dCoord = δ w.uniformizer := hL w.uniformizer
+  calc δ g = δ.liftKaehlerDifferential (KaehlerDifferential.D K F g) := (hL g).symm
+    _ = δ.liftKaehlerDifferential
+        (w.differentialCoeff (KaehlerDifferential.D K F g) • w.dCoord) := by
+          rw [w.differentialCoeff_smul_dCoord]
+    _ = w.differentialCoeff (KaehlerDifferential.D K F g) • δ w.uniformizer := by
+          rw [map_smul, hLπ]
+
+end GenericFactor
+
+section TateResDerivation
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem range_smul_le {V : Type*} [AddCommGroup V] [Module K V]
+    (c : K) (φ : V →ₗ[K] V) : LinearMap.range (c • φ) ≤ LinearMap.range φ := by
+  rintro y ⟨x, rfl⟩
+  exact (LinearMap.range φ).smul_mem c (LinearMap.mem_range_self φ x)
+
+theorem finDimRangeSMul {V : Type*} [AddCommGroup V] [Module K V]
+    (c : K) (φ : V →ₗ[K] V) [FiniteDimensional K (LinearMap.range φ)] :
+    FiniteDimensional K (LinearMap.range (c • φ)) :=
+  Submodule.finiteDimensional_of_le (range_smul_le c φ)
+
+theorem finrankTrace_smul {V : Type*} [AddCommGroup V] [Module K V]
+    (c : K) (φ : V →ₗ[K] V) [FiniteDimensional K (LinearMap.range φ)] :
+    haveI := finDimRangeSMul c φ
+    finrankTrace (c • φ) = c • finrankTrace φ := by
+  have := finDimRangeSMul c φ
+  have hW : ∀ x ∈ LinearMap.range φ, (c • φ) x ∈ LinearMap.range φ := fun x _ =>
+    range_smul_le c φ (LinearMap.mem_range_self _ x)
+  rw [finrankTrace_eq_trace_on_superspace (c • φ) (LinearMap.range φ) (range_smul_le c φ) hW]
+  unfold finrankTrace
+  rw [← LinearMap.map_smul]
+  exact congrArg (LinearMap.trace K _) (LinearMap.ext fun x => Subtype.ext rfl)
+
+theorem tateCommRestrict_smul_snd {V : Type*} [AddCommGroup V] [Module K V]
+    (pA φ ψ : V →ₗ[K] V) (c : K) :
+    tateCommRestrict pA φ (c • ψ) = c • tateCommRestrict pA φ ψ := by
+  apply LinearMap.ext; intro a; apply Subtype.ext
+  change (tateCommRestrict pA φ (c • ψ) a : V) = (c • tateCommRestrict pA φ ψ a : V)
+  rw [tateCommRestrict_apply, tateCommRestrict_apply]
+  unfold tateComm
+  simp only [LinearMap.smul_apply, LinearMap.sub_apply, LinearMap.comp_apply, map_smul, smul_sub]
+
+theorem tateCommRestrict_smul_fst {V : Type*} [AddCommGroup V] [Module K V]
+    (pA φ ψ : V →ₗ[K] V) (c : K) :
+    tateCommRestrict pA (c • φ) ψ = c • tateCommRestrict pA φ ψ := by
+  apply LinearMap.ext; intro a; apply Subtype.ext
+  change (tateCommRestrict pA (c • φ) ψ a : V) = (c • tateCommRestrict pA φ ψ a : V)
+  rw [tateCommRestrict_apply, tateCommRestrict_apply]
+  unfold tateComm
+  simp only [LinearMap.smul_apply, LinearMap.sub_apply, LinearMap.comp_apply, map_smul, smul_sub]
+
+theorem tateRes_congr_snd (u : Place K F) {fh gh₁ gh₂ : u.adicCompletion} (heq : gh₁ = gh₂)
+    [h₁ : FiniteDimensional K (LinearMap.range
+      (tateCommRestrict (tateProj u) (lmulK u fh) (lmulK u gh₁)))]
+    [h₂ : FiniteDimensional K (LinearMap.range
+      (tateCommRestrict (tateProj u) (lmulK u fh) (lmulK u gh₂)))] :
+    tateRes u fh gh₁ = tateRes u fh gh₂ := by
+  subst heq; rfl
+
+theorem tateRes_add_snd (u : Place K F) (hfin : KwF4gRRTateCommFinite K F)
+    (f g h : u.adicCompletion) :
+    haveI := hfin u f (g + h); haveI := hfin u f g; haveI := hfin u f h
+    tateRes u f (g + h) = tateRes u f g + tateRes u f h := by
+  have := hfin u f (g + h); have := hfin u f g; have := hfin u f h
+  have heq : lmulK u (g + h) = lmulK u g + lmulK u h := map_add _ _ _
+  have : FiniteDimensional K (LinearMap.range
+      (tateCommRestrict (tateProj u) (lmulK u f) (lmulK u g + lmulK u h))) := by
+    rw [← heq]; exact hfin u f (g + h)
+  unfold tateRes
+  have hct := tateCommTrace_add_snd (tateProj u) (lmulK u f) (lmulK u g) (lmulK u h)
+  unfold tateCommTrace at hct ⊢
+  rw [← hct]
+  exact finrankTrace_congr (by rw [heq])
+
+def tateResFstLM (w : Place K F) (hfin : KwF4gRRTateCommFinite K F)
+    (gh : w.adicCompletion) : DualDom w where
+  toFun f := haveI := hfin w f gh; tateRes w f gh
+  map_add' f₁ f₂ := by
+    have := hfin w f₁ gh; have := hfin w f₂ gh
+    exact tateRes_add_fst w f₁ f₂ gh
+  map_smul' c f := by
+    have := hfin w f gh; have := hfin w (c • f) gh
+    change tateRes w (c • f) gh = c • tateRes w f gh
+    have heq : tateCommRestrict (tateProj w) (lmulK w (c • f)) (lmulK w gh)
+        = c • tateCommRestrict (tateProj w) (lmulK w f) (lmulK w gh) := by
+      rw [show lmulK w (c • f) = c • lmulK w f from map_smul _ _ _,
+        tateCommRestrict_smul_fst]
+    have := finDimRangeSMul c (tateCommRestrict (tateProj w) (lmulK w f) (lmulK w gh))
+    unfold tateRes tateCommTrace
+    rw [finrankTrace_congr heq, finrankTrace_smul]
+
+@[scoped simp] theorem tateResFstLM_apply (w : Place K F) (hfin : KwF4gRRTateCommFinite K F)
+    (gh f : w.adicCompletion) :
+    (tateResFstLM w hfin gh).toLM f = haveI := hfin w f gh; tateRes w f gh := rfl
+
+variable [HasPrincipalDivisors K F] [Nontrivial Ω[F⁄K]]
+
+def tateResSndDer (w : Place K F) [w.DCoordGenerates] [w.FiniteResidue]
+    (hfin : KwF4gRRTateCommFinite K F) : Derivation K F (DualDom w) :=
+  Derivation.mk'
+    { toFun := fun g => tateResFstLM w hfin (algebraMap F w.adicCompletion g)
+      map_add' := fun g h => DualDom.ext fun f => by
+        simp only [tateResFstLM_apply, DualDom.toLM_add, map_add]
+        exact tateRes_add_snd w hfin f _ _
+      map_smul' := fun c g => DualDom.ext fun f => by
+        simp only [tateResFstLM_apply, RingHom.id_apply, DualDom.k_smul_apply]
+        have := hfin w f (algebraMap F _ (c • g))
+        have := hfin w f (algebraMap F _ g)
+        change tateRes w f (algebraMap F _ (c • g)) = c • tateRes w f (algebraMap F _ g)
+        have heq : tateCommRestrict (tateProj w) (lmulK w f)
+              (lmulK w (algebraMap F _ (c • g)))
+            = c • tateCommRestrict (tateProj w) (lmulK w f)
+              (lmulK w (algebraMap F _ g)) := by
+          rw [show lmulK w (algebraMap F _ (c • g)) = c • lmulK w (algebraMap F _ g) from by
+              rw [Algebra.smul_def, (algebraMap F w.adicCompletion).map_mul,
+                ← IsScalarTower.algebraMap_apply K F w.adicCompletion,
+                Algebra.algebraMap_eq_smul_one, smul_mul_assoc, one_mul]
+              exact map_smul _ _ _,
+            tateCommRestrict_smul_snd]
+        have := finDimRangeSMul c
+          (tateCommRestrict (tateProj w) (lmulK w f) (lmulK w (algebraMap F _ g)))
+        unfold tateRes tateCommTrace
+        rw [finrankTrace_congr heq, finrankTrace_smul] }
+    (fun g h => DualDom.ext fun f => by
+      simp only [LinearMap.coe_mk, AddHom.coe_mk, tateResFstLM_apply, DualDom.toLM_add]
+      have := hfin w f (algebraMap F _ (g * h))
+      have := hfin w (algebraMap F _ g * f) (algebraMap F _ h)
+      have := hfin w (algebraMap F _ h * f) (algebraMap F _ g)
+      have := hfin w f (algebraMap F _ g * algebraMap F _ h)
+      have := hfin w (f * algebraMap F _ g) (algebraMap F _ h)
+      have := hfin w (f * algebraMap F _ h) (algebraMap F _ g)
+      change tateRes w f (algebraMap F _ (g * h))
+        = tateRes w (algebraMap F _ g * f) (algebraMap F _ h)
+          + tateRes w (algebraMap F _ h * f) (algebraMap F _ g)
+      rw [tateRes_congr_snd w ((algebraMap F w.adicCompletion).map_mul g h),
+        tateRes_leibniz_snd w hfin f (algebraMap F _ g) (algebraMap F _ h),
+        tateRes_congr_fst w (mul_comm f (algebraMap F _ g)),
+        tateRes_congr_fst w (mul_comm f (algebraMap F _ h))])
+
+omit [HasPrincipalDivisors K F] [Nontrivial Ω[F⁄K]] in
+@[scoped simp] theorem tateResSndDer_apply (w : Place K F) [w.DCoordGenerates] [w.FiniteResidue]
+    (hfin : KwF4gRRTateCommFinite K F) (g : F) (f : w.adicCompletion) :
+    ((tateResSndDer w hfin) g).toLM f
+      = haveI := hfin w f (algebraMap F _ g); tateRes w f (algebraMap F _ g) := rfl
+
+end TateResDerivation
+
+section Headline
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable [HasPrincipalDivisors K F] [Nontrivial Ω[F⁄K]]
+
+theorem kwTateRR2_derivationFactorSnd [∀ w : Place K F, w.FiniteResidue]
+    (hfinF : KwF4gRRTateCommFinite K F) :
+    KwF4gRRTateDerivationFactorSnd K F hfinF := by
+  intro w _ f g
+  have := hfinF w f (algebraMap F _ g)
+  have := hfinF w (f * algebraMap F _ (w.differentialCoeff (KaehlerDifferential.D K F g)))
+    (algebraMap F _ w.uniformizer)
+  have hδ := derivation_apply_eq_diffCoeff_smul (M := DualDom w) w (tateResSndDer w hfinF) g
+  have := hfinF w (algebraMap F _ (w.differentialCoeff (KaehlerDifferential.D K F g)) * f)
+    (algebraMap F _ w.uniformizer)
+  calc tateRes w f (algebraMap F _ g)
+      = ((tateResSndDer w hfinF) g).toLM f := (tateResSndDer_apply w hfinF g f).symm
+    _ = (w.differentialCoeff (KaehlerDifferential.D K F g)
+          • (tateResSndDer w hfinF) w.uniformizer).toLM f := by rw [hδ]
+    _ = ((tateResSndDer w hfinF) w.uniformizer).toLM
+          (algebraMap F _ (w.differentialCoeff (KaehlerDifferential.D K F g)) * f) :=
+        DualDom.smul_apply _ _ _
+    _ = tateRes w (algebraMap F _ (w.differentialCoeff (KaehlerDifferential.D K F g)) * f)
+          (algebraMap F _ w.uniformizer) := tateResSndDer_apply w hfinF w.uniformizer _
+    _ = tateRes w (f * algebraMap F _ (w.differentialCoeff (KaehlerDifferential.D K F g)))
+          (algebraMap F _ w.uniformizer) :=
+        tateRes_congr_fst w (mul_comm _ f)
+
+end Headline
+end ModularCurve.KwF4gRRTate
+end
+end
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] {E : Type*} [Field E] [Algebra K E]
+    [Algebra E F] [IsScalarTower K E F] [Algebra.IsIntegral E F]
+    [AlgebraicCurve.HasCanonicalLocalResidueKStar K F]
+    [AlgebraicCurve.HasCanonicalLocalResidueKStar K E]
+    [∀ w : AlgebraicCurve.Place K F, w.FiniteResidue]
+    (hfinF : ModularCurve.KwF4gRRTate.KwF4gRRTateCommFinite K F) :
+    ModularCurve.KwF4gRRTate.KwF4gRRTateChainRule K F E hfinF :=
+  ModularCurve.KwF4gRRTate.kwF4gRRTate_chainRule_of_derivationFactor hfinF
+    (fun {_ _} => ModularCurve.KwF4gRRTate.kwTateRR2_derivationFactorSnd hfinF)
+
+end S_AlgebraicCurve_tateChainRule
+end P2MW
+export P2MW.S_AlgebraicCurve_tateChainRule (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.tateChainRule
+    {K F : Type*} [Field K] [Field F] [Algebra K F]
+    {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+    [Algebra.IsIntegral E F]
+    [AlgebraicCurve.HasCanonicalLocalResidueKStar K F]
+    [AlgebraicCurve.HasCanonicalLocalResidueKStar K E]
+    [∀ w : AlgebraicCurve.Place K F, w.FiniteResidue]
+    (hfinF : ModularCurve.KwF4gRRTate.KwF4gRRTateCommFinite K F) :
+    ModularCurve.KwF4gRRTate.KwF4gRRTateChainRule K F E hfinF :=
+  solution hfinF
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_tateCommFinite.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_tateCommFinite.lean
new file mode 100644
index 0000000000..a99dbe476b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_tateCommFinite.lean
@@ -0,0 +1,1101 @@
+/-
+Based on Prove2Me node AlgebraicCurve.tateCommFinite
+(b8c365b4-ee08-5ae5-8611-88da8054c1dc) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3fc410a6-b073-5f8b-80d6-2ab30f5c86fb
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_TateResidueCurrency
+
+import Mathlib.Algebra.GroupWithZero.Submonoid.CancelMulZero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Tate's commutator has finite K-rank at every place
+
+Theorem statement: `AlgebraicCurve.tateCommFinite` (`b8c365b4-ee08-5ae5-8611-88da8054c1dc`), by
+Claude, 2026-09-05.
+
+Proof: submission `3fc410a6-b073-5f8b-80d6-2ab30f5c86fb`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $L$ be fields with $L$ a $K$-algebra, and assume that every place $u$ of $L$ over $K$ —
+that is, every valuation subring of $L$ which contains the image of $K$, is not all of $L$, and is a
+principal ideal ring — has finite residue in the sense that the residue field of that valuation
+subring is a finite-dimensional $K$-module. The conclusion is the predicate
+[`ModularCurve.KwF4gRRTate.KwF4gRRTateCommFinite K
+L`](def/AlgebraicCurve_TateResidueCurrency.html#L300), which asserts: for every such place $u$ and
+all elements $fh$, $gh$ of the adic completion $\hat L_u$ of $L$ at the height-one prime associated
+with $u$, the range of `tateCommRestrict (tateProj u) (lmulK u fh) (lmulK u gh)` is
+finite-dimensional over $K$. Here `tateProj u` is the $K$-linear idempotent on $\hat L_u$ obtained
+by projecting onto the $K$-submodule `adicIntegersKSubmod u` along a chosen complement and then
+including it back, `lmulK u fh` and `lmulK u gh` are multiplication by $fh$ and by $gh$ on $\hat
+L_u$ as $K$-linear maps, and `tateCommRestrict` is Tate's commutator `tateComm` built from these
+three endomorphisms, restricted to the range of the projection, which it preserves.
+
+This is the finite-potence (finite rank) input in Tate's construction of the abstract residue on a
+curve, where $\operatorname{res}_u(f\,dg)$ is the trace of the commutator $[p_u\mu_f, p_u\mu_g]$:
+without the finiteness of the range of that commutator the trace is not defined. It is used by
+[`AlgebraicCurve.residueTraceCompletionCommute`]
+(thm.html#AlgebraicCurve.residueTraceCompletionCommute)
+and
+[`AlgebraicCurve.residueTraceCompletionCommute_v2`]
+(thm.html#AlgebraicCurve.residueTraceCompletionCommute_v2),
+which compare the residue–trace construction with completion.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_tateCommFinite.lean
+
+*Attribution:* this file contains material adapted from third-party Apache-2.0 sources (portions
+(≈4%): `FLT/Mathlib/RingTheory/Valuation/ValuationSubring.lean` — © 2025 Ruben Van de Velde;
+authors: Ruben Van de Velde, Kevin Buzzard, Salvatore Mercuri;
+`FLT/Mathlib/RingTheory/LocalRing/MaximalIdeal/Basic.lean` — © 2025 Salvatore Mercuri; authors:
+Salvatore Mercuri, Kevin Buzzard). See ATTRIBUTION.md and NOTICE in the source repository.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_tateCommFinite
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor Pic0 HasCanonicalLocalResidueKStar \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff"
+end AlgebraicCurve
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor Pic0 HasCanonicalLocalResidueKStar \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_unit_smul_zpow exists_unit_mul_zpow FiniteResidue.finite \
+  algebraMap_mem' toValuationSubring mk restrict adicCompletion adicCompletionIntegers"
+end AlgebraicCurve.Place
+namespace Filter
+p2m_export "Filter" "mem_bot ker mk mem_comap mem_ker comap unique map"
+end Filter
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "HeightOneSpectrum.ext mk HeightOneSpectrum"
+end IsDedekindDomain
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "HeightOneSpectrum.ext mk HeightOneSpectrum"
+namespace HeightOneSpectrum
+p2m_export "IsDedekindDomain.HeightOneSpectrum" "valuation_of_algebraMap \
+  intValuation_le_pow_iff_mem isMaximal mk comap valuedAdicCompletion_eq_valuation' adicCompletion \
+  valuation adicCompletionIntegers valuedAdicCompletion_surjective \
+  mem_integers_of_valuation_le_one denseRange_algebraMap intValuation completionIdeal \
+  adicCompletion.mem_completionIdeal_pow"
+end IsDedekindDomain.HeightOneSpectrum
+namespace IsLocalRing
+p2m_export "IsLocalRing" "ResidueField maximalIdeal maximalIdeal.isMaximal of_injective"
+end IsLocalRing
+namespace LinearMap
+p2m_export "LinearMap" "mulLeft_apply mem_range range sub_apply ker_eq_bot id range_comp mulLeft \
+  ker_comp mk id_apply ext comp quotKerEquivRange restrictScalars ker mem_ker comp_apply \
+  mem_range_self restrict"
+end LinearMap
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite"
+end ModularCurve
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "tateCommRestrict_apply tateComm_eq_of_commute \
+  adicIntegersKSubmod tateProj lmulK KwF4gRRTateCommFinite"
+end ModularCurve.KwF4gRRTate
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite"
+end ModularCurve
+namespace MonoidWithZeroHom
+p2m_export "MonoidWithZeroHom" "id_apply id ext mk coe_one comp_apply comp"
+end MonoidWithZeroHom
+namespace Multiplicative
+p2m_export "Multiplicative" "ext"
+end Multiplicative
+namespace NumberField
+p2m_export "NumberField" "mk"
+end NumberField
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq inclusion mem_sup_right smul_mem' mk mem_bot coe_mem \
+  Quotient.mk span restrictScalars projectionOnto_apply_left restrictScalars_top mem_closure_iff \
+  comapSubtypeEquivOfLe Quotient.restrictScalarsEquiv mem_comap Quotient.equiv mem_span_singleton \
+  mkQ map_smul' zero quotientQuotientEquivQuotient Quotient.mk_surjective restrictScalars_mono map \
+  mem_inf inclusion_apply Quotient.mk_eq_zero exists_isCompl projectionOnto \
+  finiteDimensional_of_le smul_def mk_eq_zero restrictScalarsEquiv mkQ_apply ext subtype_apply \
+  ker_mkQ comap finiteDimensional_sup mem_sup_left restrictScalars_mem"
+end Submodule
+namespace WithZero
+p2m_export "WithZero" "coe_one map coe_mul exp_eq_coe_ofAdd exp_ne_zero exp exp_zero exp_le_exp"
+end WithZero
+
+section
+namespace IsLocalRing
+p2m_export "IsLocalRing" "ResidueField maximalIdeal maximalIdeal.isMaximal of_injective"
+end IsLocalRing
+p2m_open_scoped "IsLocalRing" in
+theorem IsLocalRing.maximalIdeal_le {R : Type*} [CommSemiring R] [IsLocalRing R] {J : Ideal R}
+    (hJ : J ≠ ⊤) (h : IsLocalRing.maximalIdeal R ≤ J) :
+    J.IsMaximal :=
+  (IsLocalRing.maximalIdeal.isMaximal R).eq_of_le hJ h ▸ IsLocalRing.maximalIdeal.isMaximal R
+
+end
+
+section
+
+
+p2m_open "LinearMap P2MW.S_AlgebraicCurve_tateCommFinite.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateCommFinite.Submodule"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "tateCommRestrict_apply tateComm_eq_of_commute \
+  adicIntegersKSubmod tateProj lmulK KwF4gRRTateCommFinite"
+end ModularCurve.KwF4gRRTate
+
+end
+
+end
+
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateCommFinite.IsDedekindDomain WithZero \
+  P2MW.S_AlgebraicCurve_tateCommFinite.WithZero IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateCommFinite.IsLocalRing"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor Pic0 HasCanonicalLocalResidueKStar \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff"
+p2m_open "AlgebraicCurve"
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_unit_smul_zpow exists_unit_mul_zpow FiniteResidue.finite \
+  algebraMap_mem' toValuationSubring mk restrict adicCompletion adicCompletionIntegers"
+end Place
+
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "smul_def"
+end Divisor
+
+namespace Pic0
+p2m_export "AlgebraicCurve.Pic0" "mk mk_surjective"
+end Pic0
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_unit_smul_zpow exists_unit_mul_zpow FiniteResidue.finite \
+  algebraMap_mem' toValuationSubring mk restrict adicCompletion adicCompletionIntegers"
+end Place
+
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "smul_def"
+end Divisor
+
+namespace Pic0
+p2m_export "AlgebraicCurve.Pic0" "mk mk_surjective"
+end Pic0
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_unit_smul_zpow exists_unit_mul_zpow FiniteResidue.finite \
+  algebraMap_mem' toValuationSubring mk restrict adicCompletion adicCompletionIntegers"
+end Place
+
+end AlgebraicCurve
+
+end
+
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateCommFinite.IsDedekindDomain WithZero \
+  P2MW.S_AlgebraicCurve_tateCommFinite.WithZero IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateCommFinite.IsLocalRing"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor Pic0 HasCanonicalLocalResidueKStar \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_unit_smul_zpow exists_unit_mul_zpow FiniteResidue.finite \
+  algebraMap_mem' toValuationSubring mk restrict adicCompletion adicCompletionIntegers"
+end Place
+
+end AlgebraicCurve
+
+end
+
+
+
+section
+
+variable {F : Type*} [Field F]
+
+namespace ValuationSubring
+p2m_export "ValuationSubring" "comap subtype mem_comap subtype_apply algebraMap_apply ext zero_mem \
+  mk mul_mem add_mem valuation inclusion"
+end ValuationSubring
+p2m_open_scoped "ValuationSubring" in
+theorem ValuationSubring.valued_eq_one_of_isUnit {K : Type*} [Field K] {Γ₀ : Type*}
+    [LinearOrderedCommGroupWithZero Γ₀] [hv : Valued K Γ₀] (x : hv.v.valuationSubring)
+    (hx : IsUnit x) : Valued.v x.val = 1 := by
+  obtain ⟨u, hu⟩ := hx
+  apply le_antisymm ((hv.v.mem_valuationSubring_iff _).1 x.2)
+  rw [← Valued.v.map_one (R := K), ← Submonoid.coe_one, ← u.mul_inv, hu,
+    Submonoid.coe_mul, Valued.v.map_mul]
+  nth_rw 2 [← mul_one (Valued.v x.val)]
+  exact mul_le_mul_right ((hv.v.mem_valuationSubring_iff _).1 (u⁻¹.val.property)) _
+
+p2m_open_scoped "ValuationSubring" in
+theorem ValuationSubring.isUnit_of_valued_eq_one {K : Type*} [Field K] {Γ₀ : Type*}
+    [LinearOrderedCommGroupWithZero Γ₀] [hv : Valued K Γ₀] (x : hv.v.valuationSubring)
+    (hx : Valued.v x.val = 1) : IsUnit x := by
+  have : IsUnit x.val := by rw [isUnit_iff_ne_zero, ne_eq, ← map_eq_zero hv.v, hx]; aesop
+  obtain ⟨u, hu⟩ := this
+  have hu_inv_le : Valued.v u⁻¹.val ≤ 1 := by
+    rw [← one_mul (Valued.v _), ← hx, ← hu, ← Valued.v.map_mul, u.mul_inv, hu, hx, Valued.v.map_one]
+  rw [isUnit_iff_exists]
+  exact ⟨⟨u⁻¹.val, hu_inv_le⟩, ⟨by aesop, by aesop⟩⟩
+
+p2m_open_scoped "ValuationSubring" in
+theorem ValuationSubring.isUnit_iff_valued_eq_one {K : Type*} [Field K] {Γ₀ : Type*}
+    [LinearOrderedCommGroupWithZero Γ₀] [hv : Valued K Γ₀] (x : hv.v.valuationSubring) :
+    IsUnit x ↔ Valued.v x.val = 1 :=
+  ⟨valued_eq_one_of_isUnit x, isUnit_of_valued_eq_one x⟩
+
+end
+
+
+
+section
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateCommFinite.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateCommFinite.IsDedekindDomain.HeightOneSpectrum IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateCommFinite.IsLocalRing WithZero \
+  P2MW.S_AlgebraicCurve_tateCommFinite.WithZero MonoidWithZeroHom \
+  P2MW.S_AlgebraicCurve_tateCommFinite.MonoidWithZeroHom"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor Pic0 HasCanonicalLocalResidueKStar \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_unit_smul_zpow exists_unit_mul_zpow FiniteResidue.finite \
+  algebraMap_mem' toValuationSubring mk restrict adicCompletion adicCompletionIntegers"
+end AlgebraicCurve.Place
+
+end
+end
+
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateCommFinite.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateCommFinite.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateCommFinite.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateCommFinite.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateCommFinite.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "tateCommRestrict_apply tateComm_eq_of_commute \
+  adicIntegersKSubmod tateProj lmulK KwF4gRRTateCommFinite"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section TateProj
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem mem_adicIntegersKSubmod_iff (x : u.adicCompletion) :
+    x ∈ adicIntegersKSubmod u ↔ x ∈ u.adicCompletionIntegers := Iff.rfl
+
+theorem tateProj_mem_integers (x : u.adicCompletion) :
+    tateProj u x ∈ u.adicCompletionIntegers :=
+  (mem_adicIntegersKSubmod_iff u _).mp
+    (Submodule.coe_mem
+      (Submodule.projectionOnto (adicIntegersKSubmod u) _
+        (Classical.choose_spec (Submodule.exists_isCompl (adicIntegersKSubmod u))) x))
+
+theorem tateProj_of_mem {x : u.adicCompletion} (hx : x ∈ u.adicCompletionIntegers) :
+    tateProj u x = x := by
+  have h := Submodule.projectionOnto_apply_left
+    (Classical.choose_spec (Submodule.exists_isCompl (adicIntegersKSubmod u)))
+    (⟨x, (mem_adicIntegersKSubmod_iff u x).mpr hx⟩ : adicIntegersKSubmod u)
+  have hcoe := congrArg (Subtype.val (p := fun y => y ∈ adicIntegersKSubmod u)) h
+  exact hcoe
+
+theorem range_tateProj : LinearMap.range (tateProj u) = adicIntegersKSubmod u := by
+  apply le_antisymm
+  · rintro x ⟨y, rfl⟩
+    exact tateProj_mem_integers u y
+  · intro x hx
+    exact ⟨x, tateProj_of_mem u hx⟩
+
+end TateProj
+
+end ModularCurve.KwF4gRRTate
+
+end
+
+end
+
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateCommFinite.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateCommFinite.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateCommFinite.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateCommFinite.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateCommFinite.ModularCurve.KwF4gRRTate"
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateCommFinite.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateCommFinite.IsDedekindDomain.HeightOneSpectrum IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateCommFinite.IsLocalRing"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "tateCommRestrict_apply tateComm_eq_of_commute \
+  adicIntegersKSubmod tateProj lmulK KwF4gRRTateCommFinite"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section PoleWindow
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+def poleWindowKSubmod (πh : u.adicCompletionIntegers) (M : ℕ) :
+    Submodule K u.adicCompletion where
+  carrier := {x | (πh : u.adicCompletion) ^ M * x ∈ u.adicCompletionIntegers}
+  add_mem' {a b} ha hb := by
+    simp only [Set.mem_ofPred_eq, mul_add] at ha hb ⊢; exact add_mem ha hb
+  zero_mem' := by simp only [Set.mem_ofPred_eq, mul_zero]; exact zero_mem _
+  smul_mem' c x hx := by
+    simp only [Set.mem_ofPred_eq] at hx ⊢
+    rw [Algebra.smul_def, IsScalarTower.algebraMap_apply K L u.adicCompletion, mul_left_comm]
+    exact mul_mem ((kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff u _).mpr
+      (u.algebraMap_mem' c)) hx
+
+theorem mem_poleWindowKSubmod_iff (πh : u.adicCompletionIntegers) (M : ℕ)
+    (x : u.adicCompletion) :
+    x ∈ poleWindowKSubmod u πh M ↔ (πh : u.adicCompletion) ^ M * x ∈ u.adicCompletionIntegers :=
+  Iff.rfl
+
+theorem adicIntegersKSubmod_le_poleWindowKSubmod (πh : u.adicCompletionIntegers) (M : ℕ) :
+    adicIntegersKSubmod u ≤ poleWindowKSubmod u πh M :=
+  fun _ hx => mul_mem (pow_mem πh.2 M) hx
+
+theorem kwF4gRRTate_clearPole (πh : u.adicCompletionIntegers) (hπh : Irreducible πh)
+    (fh : u.adicCompletion) :
+    ∃ M : ℕ, (πh : u.adicCompletion) ^ M * fh ∈ u.adicCompletionIntegers := by
+  obtain ⟨a, b, hb, hfh⟩ := IsFractionRing.div_surjective
+    (A := u.adicCompletionIntegers) (K := u.adicCompletion) fh
+  have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb
+  obtain ⟨M, ub, hbeq⟩ := IsDiscreteValuationRing.eq_unit_mul_pow_irreducible hb0 hπh
+  refine ⟨M, ?_⟩
+  have hcoe : ∀ x : u.adicCompletionIntegers,
+      (x : u.adicCompletion) = algebraMap _ u.adicCompletion x := fun _ => rfl
+  have hbK0 : (b : u.adicCompletion) ≠ 0 := by
+    rw [hcoe]; exact (map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr hb0
+  have hbfh : (b : u.adicCompletion) * fh = (a : u.adicCompletion) := by
+    rw [← hfh, hcoe b, hcoe a, mul_div_cancel₀ _ (hcoe b ▸ hbK0)]
+  have hπheq : ((ub⁻¹ : u.adicCompletionIntegersˣ) : u.adicCompletionIntegers) * b = πh ^ M := by
+    rw [hbeq, ← mul_assoc, ← Units.val_mul, inv_mul_cancel, Units.val_one, one_mul]
+  have hπheqK : ((((ub⁻¹ : u.adicCompletionIntegersˣ) : u.adicCompletionIntegers)
+        : u.adicCompletion)) * (b : u.adicCompletion)
+      = (πh : u.adicCompletion) ^ M := by
+    have := congrArg (algebraMap u.adicCompletionIntegers u.adicCompletion) hπheq
+    simp only [map_mul, map_pow] at this
+    exact this
+  rw [← hπheqK, mul_assoc, hbfh]
+  exact mul_mem (Subtype.coe_prop _) a.2
+
+variable (K L) in
+def KwF4gRRTateClearPole : Prop :=
+  ∀ (u : Place K L) (πh : u.adicCompletionIntegers) (_ : Irreducible πh)
+    (fh : u.adicCompletion),
+    ∃ M : ℕ, (πh : u.adicCompletion) ^ M * fh ∈ u.adicCompletionIntegers
+
+theorem kwF4gRRTate_clearPole_discharged : KwF4gRRTateClearPole K L :=
+  fun u πh hπh fh => kwF4gRRTate_clearPole u πh hπh fh
+
+theorem lmul_mem_poleWindow (πh : u.adicCompletionIntegers) (M : ℕ) (fh : u.adicCompletion)
+    (hM : (πh : u.adicCompletion) ^ M * fh ∈ u.adicCompletionIntegers)
+    {a : u.adicCompletion} (ha : a ∈ u.adicCompletionIntegers) :
+    fh * a ∈ poleWindowKSubmod u πh M := by
+  rw [mem_poleWindowKSubmod_iff, ← mul_assoc]; exact mul_mem hM ha
+
+variable (K L) in
+def KwF4gRRTatePoleWindowFinite : Prop :=
+  ∀ (u : Place K L) [u.FiniteResidue] (πh : u.adicCompletionIntegers) (_ : Irreducible πh)
+    (M : ℕ),
+    FiniteDimensional K
+      (poleWindowKSubmod u πh M ⧸
+        (adicIntegersKSubmod u).comap (poleWindowKSubmod u πh M).subtype)
+
+theorem ker_tateProj_inf_integers :
+    LinearMap.ker (tateProj u) ⊓ adicIntegersKSubmod u = ⊥ := by
+  rw [eq_bot_iff]
+  intro x hx
+  obtain ⟨hker, hint⟩ := Submodule.mem_inf.mp hx
+  have h0 : tateProj u x = 0 := LinearMap.mem_ker.mp hker
+  rw [Submodule.mem_bot, ← tateProj_of_mem u hint, h0]
+
+theorem finiteDimensional_ker_inf_poleWindow [u.FiniteResidue]
+    (hPW : KwF4gRRTatePoleWindowFinite K L)
+    (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) (M : ℕ) :
+    FiniteDimensional K
+      ((LinearMap.ker (tateProj u) ⊓ poleWindowKSubmod u πh M : Submodule K _)) := by
+  have := hPW u πh hπh M
+  set A := adicIntegersKSubmod u
+  set P := poleWindowKSubmod u πh M
+  let A' : Submodule K P := A.comap P.subtype
+  let ι : (LinearMap.ker (tateProj u) ⊓ P : Submodule K _) →ₗ[K] P ⧸ A' :=
+    (A'.mkQ).comp (Submodule.inclusion inf_le_right)
+  refine FiniteDimensional.of_injective ι ?_
+  rw [← LinearMap.ker_eq_bot, eq_bot_iff]
+  intro xh hxker
+  obtain ⟨x, hxkp⟩ := xh
+  obtain ⟨hxk, hxp⟩ := Submodule.mem_inf.mp hxkp
+  simp only [ι, LinearMap.mem_ker, LinearMap.comp_apply, Submodule.mkQ_apply,
+    Submodule.Quotient.mk_eq_zero, Submodule.inclusion_apply] at hxker
+  have hxA : x ∈ A := hxker
+  have hx0 : x = 0 := by
+    have hbot : x ∈ (⊥ : Submodule K u.adicCompletion) := by
+      rw [← ker_tateProj_inf_integers u]; exact Submodule.mem_inf.mpr ⟨hxk, hxA⟩
+    exact (Submodule.mem_bot K).mp hbot
+  exact Subtype.ext hx0
+
+theorem finiteDimensional_principalPart_range [u.FiniteResidue]
+    (hCP : KwF4gRRTateClearPole K L) (hPW : KwF4gRRTatePoleWindowFinite K L)
+    (fh : u.adicCompletion) :
+    FiniteDimensional K
+      (LinearMap.range
+        ((LinearMap.id - tateProj u) ∘ₗ lmulK u fh ∘ₗ (adicIntegersKSubmod u).subtype)) := by
+  obtain ⟨πh, hπh⟩ := IsDiscreteValuationRing.exists_irreducible u.adicCompletionIntegers
+  obtain ⟨M, hM⟩ := hCP u πh hπh fh
+  have := finiteDimensional_ker_inf_poleWindow u hPW πh hπh M
+  refine Submodule.finiteDimensional_of_le
+    (S₂ := LinearMap.ker (tateProj u) ⊓ poleWindowKSubmod u πh M) ?_
+  rintro y ⟨⟨a, ha⟩, rfl⟩
+  simp only [LinearMap.comp_apply, Submodule.subtype_apply, LinearMap.sub_apply,
+    LinearMap.id_apply]
+  refine Submodule.mem_inf.mpr ⟨?_, ?_⟩
+  · rw [LinearMap.mem_ker, map_sub, tateProj_of_mem u (tateProj_mem_integers u _), sub_self]
+  · exact sub_mem (lmul_mem_poleWindow u πh M fh hM ha)
+      (adicIntegersKSubmod_le_poleWindowKSubmod u πh M (tateProj_mem_integers u _))
+
+theorem tateComm_target_le_range (pA φ ψ : u.adicCompletion →ₗ[K] u.adicCompletion)
+    (Rf Rg : Submodule K u.adicCompletion) :
+    Submodule.map (pA ∘ₗ ψ) Rf ⊔ Submodule.map (pA ∘ₗ φ) Rg ≤ LinearMap.range pA := by
+  refine sup_le ?_ ?_ <;>
+  · rintro y ⟨x, _, rfl⟩; exact LinearMap.mem_range_self pA _
+
+theorem kwF4gRRTate_commFinite_of_clearPole_of_poleWindowFinite
+    [∀ u : Place K L, u.FiniteResidue]
+    (hCP : KwF4gRRTateClearPole K L) (hPW : KwF4gRRTatePoleWindowFinite K L) :
+    KwF4gRRTateCommFinite K L := by
+  intro u fh gh
+  have hcomm : lmulK u fh ∘ₗ lmulK u gh = lmulK u gh ∘ₗ lmulK u fh := by
+    ext x : 1
+    change fh * (gh * x) = gh * (fh * x)
+    ring
+  have hRf := finiteDimensional_principalPart_range u hCP hPW fh
+  have hRg := finiteDimensional_principalPart_range u hCP hPW gh
+  set pA := tateProj u
+  set A := adicIntegersKSubmod u
+  set Rf := LinearMap.range ((LinearMap.id - pA) ∘ₗ lmulK u fh ∘ₗ A.subtype)
+  set Rg := LinearMap.range ((LinearMap.id - pA) ∘ₗ lmulK u gh ∘ₗ A.subtype)
+  set S : Submodule K u.adicCompletion :=
+    Submodule.map (pA ∘ₗ lmulK u gh) Rf ⊔ Submodule.map (pA ∘ₗ lmulK u fh) Rg
+  have : FiniteDimensional K (Submodule.map (pA ∘ₗ lmulK u gh) Rf) := Module.Finite.map _ _
+  have : FiniteDimensional K (Submodule.map (pA ∘ₗ lmulK u fh) Rg) := Module.Finite.map _ _
+  have hSfin : FiniteDimensional K S := Submodule.finiteDimensional_sup _ _
+  have hSle : S ≤ LinearMap.range pA :=
+    tateComm_target_le_range u pA (lmulK u fh) (lmulK u gh) Rf Rg
+  have : FiniteDimensional K (S.comap (LinearMap.range pA).subtype) := by
+    have e := Submodule.comapSubtypeEquivOfLe hSle
+    exact FiniteDimensional.of_injective e.toLinearMap e.injective
+  refine Submodule.finiteDimensional_of_le (S₂ := S.comap (LinearMap.range pA).subtype) ?_
+  rintro y ⟨⟨a, haR⟩, rfl⟩
+  have haA : a ∈ adicIntegersKSubmod u := range_tateProj u ▸ haR
+  rw [Submodule.mem_comap, Submodule.subtype_apply, tateCommRestrict_apply,
+    tateComm_eq_of_commute hcomm a]
+  refine sub_mem (Submodule.mem_sup_left ?_) (Submodule.mem_sup_right ?_)
+  · exact ⟨(lmulK u fh) a - pA ((lmulK u fh) a), ⟨⟨a, haA⟩, rfl⟩, rfl⟩
+  · exact ⟨(lmulK u gh) a - pA ((lmulK u gh) a), ⟨⟨a, haA⟩, rfl⟩, rfl⟩
+
+theorem kwF4gRRTate_commFinite_of_poleWindowFinite [∀ u : Place K L, u.FiniteResidue]
+    (hPW : KwF4gRRTatePoleWindowFinite K L) :
+    KwF4gRRTateCommFinite K L :=
+  kwF4gRRTate_commFinite_of_clearPole_of_poleWindowFinite
+    kwF4gRRTate_clearPole_discharged hPW
+
+end PoleWindow
+
+end ModularCurve.KwF4gRRTate
+
+end
+
+end
+
+
+section
+
+
+p2m_open_scoped "WithZero P2MW.S_AlgebraicCurve_tateCommFinite.WithZero Multiplicative \
+  P2MW.S_AlgebraicCurve_tateCommFinite.Multiplicative Topology \
+  P2MW.S_AlgebraicCurve_tateCommFinite.Topology"
+p2m_open "Filter P2MW.S_AlgebraicCurve_tateCommFinite.Filter"
+
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "HeightOneSpectrum.ext mk HeightOneSpectrum"
+namespace HeightOneSpectrum
+p2m_export "IsDedekindDomain.HeightOneSpectrum" "valuation_of_algebraMap \
+  intValuation_le_pow_iff_mem isMaximal mk comap valuedAdicCompletion_eq_valuation' adicCompletion \
+  valuation adicCompletionIntegers valuedAdicCompletion_surjective \
+  mem_integers_of_valuation_le_one denseRange_algebraMap intValuation completionIdeal \
+  adicCompletion.mem_completionIdeal_pow"
+p2m_open "IsDedekindDomain.HeightOneSpectrum IsDedekindDomain"
+
+variable {A : Type*} (K : Type*) [CommRing A] [Field K] [Algebra A K] [IsFractionRing A K]
+    [IsDedekindDomain A] (v : HeightOneSpectrum A)
+
+namespace adicCompletion
+p2m_export "IsDedekindDomain.HeightOneSpectrum.adicCompletion" "mem_completionIdeal_pow"
+p2m_open "IsDedekindDomain.HeightOneSpectrum.adicCompletion"
+
+local notation "vK" => (Valued.v : Valuation (v.adicCompletion K) ℤᵐ⁰)
+
+theorem isOpen_setOf_valued_le {γ : ℤᵐ⁰} (hγ : γ ≠ 0) :
+    IsOpen {y : v.adicCompletion K | Valued.v y ≤ γ} := by
+  obtain ⟨z, hz⟩ := valuedAdicCompletion_surjective K v γ
+  have hz0 : vK z ≠ 0 := by rw [hz]; exact hγ
+  have hr0 : (vK).restrict z ≠ 0 := fun h =>
+    hz0 ((Valuation.restrict_eq_zero_iff vK).mp h)
+  have hset : {y : v.adicCompletion K | Valued.v y ≤ γ}
+      = {y : v.adicCompletion K | (vK).restrict y ≤ (vK).restrict z} := by
+    ext y
+    simp only [Set.mem_ofPred_eq, Valuation.restrict_le_iff, hz]
+  rw [hset]
+  exact Valued.isOpen_closedBall _ hr0
+
+end adicCompletion
+
+end IsDedekindDomain.HeightOneSpectrum
+
+end
+
+
+section
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateCommFinite.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateCommFinite.IsDedekindDomain.HeightOneSpectrum IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateCommFinite.IsLocalRing WithZero \
+  P2MW.S_AlgebraicCurve_tateCommFinite.WithZero"
+p2m_open "P2MW.S_AlgebraicCurve_tateCommFinite.ModularCurve.Lg37 AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_tateCommFinite.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateCommFinite.AlgebraicCurve.Place"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite"
+namespace KwF4R1V410a
+p2m_open "ModularCurve"
+
+scoped instance kwF4R1V410a_subsingletonHeightOneSpectrumDVR
+    {O : Type*} [CommRing O] [IsDomain O] [IsDiscreteValuationRing O] :
+    Subsingleton (HeightOneSpectrum O) :=
+  ⟨fun a b => IsDedekindDomain.HeightOneSpectrum.ext
+    (((IsDiscreteValuationRing.iff_pid_with_one_nonzero_prime O).mp
+      inferInstance).2.unique ⟨a.3, a.2⟩ ⟨b.3, b.2⟩)⟩
+
+section Bridge
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+local notation "O_w" => w.toValuationSubring
+local notation "𝔪_w" => IsLocalRing.maximalIdeal w.toValuationSubring
+local notation "O_W" => w.adicCompletionIntegers
+local notation "𝔪_W" => w.heightOneSpectrum.completionIdeal F
+
+theorem kwF4R1V410a_algebraMap_mem_completionIdeal_pow_iff (n : ℕ) (x : O_w) :
+    algebraMap (O_w) (O_W) x ∈ (𝔪_W) ^ n ↔ x ∈ (𝔪_w) ^ n := by
+  have hval : Valued.v (algebraMap (O_w) (O_W) x).val
+      = w.heightOneSpectrum.intValuation x := by
+    have h1 : (algebraMap (O_w) (O_W) x).val
+        = ((algebraMap (O_w) F x : F) : w.adicCompletion) := rfl
+    rw [h1, valuedAdicCompletion_eq_valuation' (K := F) w.heightOneSpectrum,
+      valuation_of_algebraMap]
+  rw [adicCompletion.mem_completionIdeal_pow, hval, ← WithZero.exp_eq_coe_ofAdd,
+    intValuation_le_pow_iff_mem, w.heightOneSpectrum_asIdeal]
+
+theorem kwF4R1V410a_exists_sub_mem_completionIdeal_pow (n : ℕ) (y : O_W) :
+    ∃ x : O_w, y - algebraMap (O_w) (O_W) x ∈ (𝔪_W) ^ n := by
+  have hball_open : IsOpen {z : w.adicCompletion |
+      Valued.v (z - y.val) ≤ WithZero.exp (-(n : ℤ))} :=
+    (adicCompletion.isOpen_setOf_valued_le F w.heightOneSpectrum
+      WithZero.exp_ne_zero).preimage (continuous_sub_right y.val)
+  have hy_mem : y.val ∈ {z : w.adicCompletion |
+      Valued.v (z - y.val) ≤ WithZero.exp (-(n : ℤ))} := by
+    simp only [Set.mem_ofPred_eq, sub_self, _root_.map_zero]; exact zero_le
+  have hmeet := mem_closure_iff.mp
+    ((denseRange_algebraMap F w.heightOneSpectrum) y.val) _ hball_open hy_mem
+  have hexists : ∃ z : F, Valued.v (algebraMap F w.adicCompletion z - y.val)
+      ≤ WithZero.exp (-(n : ℤ)) := by
+    rcases hmeet with ⟨z₀, hz₀_ball, z, hz_eq⟩
+    exact ⟨z, hz_eq ▸ hz₀_ball⟩
+  obtain ⟨z, hz⟩ := hexists
+  rw [show algebraMap F w.adicCompletion z = ((z : F) : w.adicCompletion) from rfl] at hz
+  have hz_val_le : w.heightOneSpectrum.valuation F z ≤ 1 := by
+    have hzhat : Valued.v ((z : w.adicCompletion)) ≤ (1 : ℤᵐ⁰) := by
+      calc Valued.v ((z : w.adicCompletion))
+          = Valued.v (((z : w.adicCompletion) - y.val) + y.val) := by ring_nf
+        _ ≤ max (Valued.v ((z : w.adicCompletion) - y.val)) (Valued.v y.val) :=
+            Valuation.map_add _ _ _
+        _ ≤ (1 : ℤᵐ⁰) := max_le
+            (hz.trans (by rw [← WithZero.exp_zero]; exact WithZero.exp_le_exp.mpr (by omega)))
+            y.2
+    rwa [valuedAdicCompletion_eq_valuation'] at hzhat
+  have hz_mem : z ∈ (O_w : ValuationSubring F) := by
+    obtain ⟨r, hr⟩ := mem_integers_of_valuation_le_one F z
+      (fun v' => by
+        obtain rfl : v' = w.heightOneSpectrum := Subsingleton.elim _ _
+        exact hz_val_le)
+    exact hr ▸ r.2
+  refine ⟨⟨z, hz_mem⟩, ?_⟩
+  rw [adicCompletion.mem_completionIdeal_pow, ← WithZero.exp_eq_coe_ofAdd]
+  have hsub : (y - algebraMap (O_w) (O_W) ⟨z, hz_mem⟩ : O_W).val
+      = y.val - ((z : F) : w.adicCompletion) := rfl
+  rw [hsub, Valuation.map_sub_swap]
+  exact hz
+
+def kwF4R1V410a_quotientEquiv (n : ℕ) :
+    (O_w) ⧸ (𝔪_w) ^ n ≃+* (O_W) ⧸ (𝔪_W) ^ n :=
+  RingEquiv.ofBijective
+    (Ideal.quotientMap _ (algebraMap (O_w) (O_W))
+      (fun x hx => (kwF4R1V410a_algebraMap_mem_completionIdeal_pow_iff w n x).mpr hx))
+    ⟨Ideal.quotientMap_injective'
+      (fun x hx => (kwF4R1V410a_algebraMap_mem_completionIdeal_pow_iff w n x).mp
+        (Ideal.mem_comap.mp hx)),
+    fun y => by
+      obtain ⟨y', rfl⟩ := Ideal.Quotient.mk_surjective y
+      obtain ⟨x, hx⟩ := kwF4R1V410a_exists_sub_mem_completionIdeal_pow w n y'
+      refine ⟨Ideal.Quotient.mk _ x, ?_⟩
+      rw [Ideal.quotientMap_mk]
+      exact (Ideal.Quotient.mk_eq_mk_iff_sub_mem _ _).mpr (by
+        rw [← neg_sub, neg_mem_iff]; exact hx)⟩
+
+theorem kwF4R1V410a_quotientEquiv_mk (n : ℕ) (x : O_w) :
+    kwF4R1V410a_quotientEquiv w n (Ideal.Quotient.mk _ x)
+      = Ideal.Quotient.mk _ (algebraMap (O_w) (O_W) x) := rfl
+
+end Bridge
+
+end ModularCurve.KwF4R1V410a
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateCommFinite.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateCommFinite.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateCommFinite.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateCommFinite.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateCommFinite.ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateCommFinite.ModularCurve.KwF4R1V410a"
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateCommFinite.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateCommFinite.IsDedekindDomain.HeightOneSpectrum IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateCommFinite.IsLocalRing"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "tateCommRestrict_apply tateComm_eq_of_commute \
+  adicIntegersKSubmod tateProj lmulK KwF4gRRTateCommFinite"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section PoleWindowShift
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem coe_smul_K (c : K) (x : u.adicCompletionIntegers) :
+    ((c • x : u.adicCompletionIntegers) : u.adicCompletion) = c • (x : u.adicCompletion) := by
+  rw [Algebra.smul_def, Algebra.smul_def]
+  rfl
+
+def poleWindowShift (πh : u.adicCompletionIntegers) (M : ℕ) :
+    poleWindowKSubmod u πh M →ₗ[K] u.adicCompletionIntegers where
+  toFun x := ⟨(πh : u.adicCompletion) ^ M * (x : u.adicCompletion), x.2⟩
+  map_add' x y := by apply Subtype.ext; push_cast; ring
+  map_smul' c x := by
+    apply Subtype.ext
+    rw [coe_smul_K]
+    change (πh : u.adicCompletion) ^ M * (c • (x : u.adicCompletion))
+        = c • ((πh : u.adicCompletion) ^ M * (x : u.adicCompletion))
+    rw [mul_smul_comm]
+
+theorem poleWindowShift_injective (πh : u.adicCompletionIntegers) (hπh : Irreducible πh)
+    (M : ℕ) : Function.Injective (poleWindowShift u πh M) := by
+  rw [← LinearMap.ker_eq_bot, eq_bot_iff]
+  intro x hx
+  rw [LinearMap.mem_ker] at hx
+  have hπhM0 : (πh : u.adicCompletion) ^ M ≠ 0 := by
+    refine pow_ne_zero M ?_
+    intro hz
+    exact hπh.ne_zero (Subtype.ext hz)
+  have hx0 : (x : u.adicCompletion) = 0 := by
+    have := congrArg Subtype.val hx
+    exact (mul_eq_zero.mp this).resolve_left hπhM0
+  exact Subtype.ext hx0
+
+theorem poleWindowShift_surjective (πh : u.adicCompletionIntegers) (hπh : Irreducible πh)
+    (M : ℕ) : Function.Surjective (poleWindowShift u πh M) := by
+  intro y
+  have hπhM0 : (πh : u.adicCompletion) ^ M ≠ 0 := by
+    refine pow_ne_zero M ?_
+    intro hz; exact hπh.ne_zero (Subtype.ext hz)
+  refine ⟨⟨(y : u.adicCompletion) / (πh : u.adicCompletion) ^ M, ?_⟩, ?_⟩
+  · rw [mem_poleWindowKSubmod_iff, mul_div_cancel₀ _ hπhM0]; exact y.2
+  · apply Subtype.ext
+    change (πh : u.adicCompletion) ^ M * ((y : u.adicCompletion) / (πh : u.adicCompletion) ^ M)
+        = (y : u.adicCompletion)
+    rw [mul_div_cancel₀ _ hπhM0]
+
+def poleWindowShiftEquiv (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) (M : ℕ) :
+    poleWindowKSubmod u πh M ≃ₗ[K] u.adicCompletionIntegers :=
+  LinearEquiv.ofBijective (poleWindowShift u πh M)
+    ⟨poleWindowShift_injective u πh hπh M, poleWindowShift_surjective u πh hπh M⟩
+
+def piPowKSubmod (πh : u.adicCompletionIntegers) (M : ℕ) :
+    Submodule K u.adicCompletionIntegers where
+  carrier := {y | ∃ x : u.adicCompletionIntegers, y = πh ^ M * x}
+  add_mem' := by rintro a b ⟨xa, rfl⟩ ⟨xb, rfl⟩; exact ⟨xa + xb, by ring⟩
+  zero_mem' := ⟨0, by ring⟩
+  smul_mem' c y := by
+    rintro ⟨x, rfl⟩
+    exact ⟨c • x, by rw [Algebra.smul_def, Algebra.smul_def, mul_left_comm]⟩
+
+theorem poleWindowShift_image_integers (πh : u.adicCompletionIntegers) (M : ℕ) :
+    Submodule.map (poleWindowShift u πh M)
+        ((adicIntegersKSubmod u).comap (poleWindowKSubmod u πh M).subtype)
+      = piPowKSubmod u πh M := by
+  ext y
+  constructor
+  · rintro ⟨⟨x, hxP⟩, hxA, rfl⟩
+    refine ⟨⟨(x : u.adicCompletion), hxA⟩, ?_⟩
+    apply Subtype.ext; push_cast; rfl
+  · rintro ⟨x, rfl⟩
+    refine ⟨⟨(x : u.adicCompletion),
+      adicIntegersKSubmod_le_poleWindowKSubmod u πh M x.2⟩, x.2, ?_⟩
+    apply Subtype.ext; push_cast; rfl
+
+variable (K L) in
+def KwF4gRRTateDVRQuotPowKFinite : Prop :=
+  ∀ (u : Place K L) [u.FiniteResidue] (πh : u.adicCompletionIntegers) (_ : Irreducible πh)
+    (M : ℕ),
+    FiniteDimensional K (u.adicCompletionIntegers ⧸ piPowKSubmod u πh M)
+
+theorem kwF4gRRTate_poleWindowFinite_of_DVRQuotPowKFinite
+    (hDVR : KwF4gRRTateDVRQuotPowKFinite K L) :
+    KwF4gRRTatePoleWindowFinite K L := by
+  intro u _ πh hπh M
+  have := hDVR u πh hπh M
+  have e := (poleWindowShiftEquiv u πh hπh M).toLinearMap
+  let e' := Submodule.Quotient.equiv
+    ((adicIntegersKSubmod u).comap (poleWindowKSubmod u πh M).subtype)
+    (piPowKSubmod u πh M)
+    (poleWindowShiftEquiv u πh hπh M)
+    (poleWindowShift_image_integers u πh M)
+  exact FiniteDimensional.of_injective e'.toLinearMap e'.injective
+
+theorem kwF4gRRTate_commFinite_of_DVRQuotPowKFinite [∀ u : Place K L, u.FiniteResidue]
+    (hDVR : KwF4gRRTateDVRQuotPowKFinite K L) :
+    KwF4gRRTateCommFinite K L :=
+  kwF4gRRTate_commFinite_of_poleWindowFinite
+    (kwF4gRRTate_poleWindowFinite_of_DVRQuotPowKFinite hDVR)
+
+end PoleWindowShift
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateCommFinite.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateCommFinite.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateCommFinite.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateCommFinite.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateCommFinite.ModularCurve.KwF4gRRTate"
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateCommFinite.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateCommFinite.IsDedekindDomain.HeightOneSpectrum IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateCommFinite.IsLocalRing"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "tateCommRestrict_apply tateComm_eq_of_commute \
+  adicIntegersKSubmod tateProj lmulK KwF4gRRTateCommFinite"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section DVRQuotDischarge
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem piPowKSubmod_eq_restrictScalars (πh : u.adicCompletionIntegers) (M : ℕ) :
+    piPowKSubmod u πh M
+      = (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers).restrictScalars K := by
+  ext y
+  rw [Submodule.restrictScalars_mem, Ideal.mem_span_singleton]
+  exact ⟨fun ⟨x, h⟩ => ⟨x, h⟩, fun ⟨x, h⟩ => ⟨x, h⟩⟩
+
+def quotPiPowEquivIdealQuot (πh : u.adicCompletionIntegers) (M : ℕ) :
+    (u.adicCompletionIntegers ⧸ piPowKSubmod u πh M)
+      ≃ₗ[K] (u.adicCompletionIntegers ⧸ (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers)) :=
+  (Submodule.quotEquivOfEq _ _ (piPowKSubmod_eq_restrictScalars u πh M)).trans
+    (Submodule.Quotient.restrictScalarsEquiv K _)
+
+variable (K L) in
+def KwF4gRRTateDVRCotangentKFinite : Prop :=
+  ∀ (u : Place K L) [u.FiniteResidue] (πh : u.adicCompletionIntegers) (_ : Irreducible πh),
+    FiniteDimensional K
+      (u.adicCompletionIntegers ⧸ (Ideal.span {πh} : Ideal u.adicCompletionIntegers))
+
+theorem range_mulLeft_eq_restrictScalars_span (a : u.adicCompletionIntegers) :
+    LinearMap.range (LinearMap.mulLeft K a)
+      = (Ideal.span {a} : Ideal u.adicCompletionIntegers).restrictScalars K := by
+  ext y
+  simp only [LinearMap.mem_range, LinearMap.mulLeft_apply, Submodule.restrictScalars_mem,
+    Ideal.mem_span_singleton]
+  exact ⟨fun ⟨x, hx⟩ => ⟨x, hx.symm⟩, fun ⟨x, hx⟩ => ⟨x, hx.symm⟩⟩
+
+
+theorem finiteDimensional_restrictScalarsQuot_pow [u.FiniteResidue]
+    (hCot : KwF4gRRTateDVRCotangentKFinite K L)
+    (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) (M : ℕ) :
+    FiniteDimensional K (u.adicCompletionIntegers ⧸
+      (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers).restrictScalars K) := by
+  induction M with
+  | zero =>
+    rw [pow_zero, Ideal.span_singleton_one, Submodule.restrictScalars_top]
+    infer_instance
+  | succ M ih =>
+    have hle : (Ideal.span {πh ^ (M+1)} : Ideal u.adicCompletionIntegers)
+        ≤ Ideal.span {πh ^ M} := by
+      rw [Ideal.span_singleton_le_span_singleton, pow_succ]; exact ⟨πh, rfl⟩
+    have hle' : (Ideal.span {πh ^ (M+1)} : Ideal u.adicCompletionIntegers).restrictScalars K
+        ≤ (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers).restrictScalars K :=
+      Submodule.restrictScalars_mono K hle
+    set N : Submodule K (u.adicCompletionIntegers ⧸
+        (Ideal.span {πh ^ (M+1)} : Ideal u.adicCompletionIntegers).restrictScalars K) :=
+      (Submodule.restrictScalars K (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers)).map
+        (Submodule.restrictScalars K (Ideal.span {πh ^ (M+1)} : Ideal _)).mkQ with hN_def
+    have hquot : FiniteDimensional K
+        ((u.adicCompletionIntegers ⧸
+          (Ideal.span {πh ^ (M+1)} : Ideal _).restrictScalars K) ⧸ N) := by
+      have := ih
+      exact Module.Finite.equiv
+        (Submodule.quotientQuotientEquivQuotient _ _ hle').symm
+    have hN : FiniteDimensional K N := by
+      set φ : u.adicCompletionIntegers →ₗ[K] (u.adicCompletionIntegers ⧸
+          (Ideal.span {πh ^ (M+1)} : Ideal u.adicCompletionIntegers).restrictScalars K) :=
+        (Submodule.restrictScalars K
+            (Ideal.span {πh ^ (M+1)} : Ideal u.adicCompletionIntegers)).mkQ ∘ₗ
+          LinearMap.mulLeft K (πh ^ M) with hφ_def
+      have hrange : LinearMap.range φ = N := by
+        rw [hφ_def, LinearMap.range_comp, range_mulLeft_eq_restrictScalars_span, hN_def]
+      have hker : LinearMap.ker φ
+          = (Ideal.span {πh} : Ideal u.adicCompletionIntegers).restrictScalars K := by
+        simp only [hφ_def, LinearMap.ker_comp, Submodule.ker_mkQ]
+        ext x
+        simp only [Submodule.mem_comap, LinearMap.mulLeft_apply, Submodule.restrictScalars_mem,
+          Ideal.mem_span_singleton]
+        have hπM : (πh : u.adicCompletionIntegers) ^ M ≠ 0 := pow_ne_zero M hπh.ne_zero
+        constructor
+        · rintro ⟨c, hc⟩
+          exact ⟨c, mul_left_cancel₀ hπM (by rw [hc, pow_succ, mul_assoc])⟩
+        · rintro ⟨c, hc⟩
+          exact ⟨c, by rw [hc, pow_succ, mul_assoc]⟩
+      let e₁ : (u.adicCompletionIntegers ⧸
+            (Ideal.span {πh} : Ideal u.adicCompletionIntegers).restrictScalars K)
+          ≃ₗ[K] (u.adicCompletionIntegers ⧸ LinearMap.ker φ) :=
+        Submodule.quotEquivOfEq _ _ hker.symm
+      let e₂ : (u.adicCompletionIntegers ⧸ LinearMap.ker φ) ≃ₗ[K] LinearMap.range φ :=
+        φ.quotKerEquivRange
+      let e₃ : (LinearMap.range φ : Submodule K _) ≃ₗ[K] N := LinearEquiv.ofEq _ _ hrange
+      have hCK : FiniteDimensional K (u.adicCompletionIntegers ⧸
+          (Ideal.span {πh} : Ideal u.adicCompletionIntegers).restrictScalars K) := by
+        have := hCot u πh hπh
+        exact Module.Finite.equiv
+          (Submodule.Quotient.restrictScalarsEquiv K
+            (Ideal.span {πh} : Ideal u.adicCompletionIntegers)).symm
+      exact Module.Finite.equiv ((e₁.trans e₂).trans e₃)
+    exact Module.Finite.of_submodule_quotient N
+
+theorem finiteDimensional_idealQuot_pow [u.FiniteResidue]
+    (hCot : KwF4gRRTateDVRCotangentKFinite K L)
+    (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) (M : ℕ) :
+    FiniteDimensional K
+      (u.adicCompletionIntegers ⧸ (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers)) := by
+  have := finiteDimensional_restrictScalarsQuot_pow u hCot πh hπh M
+  exact Module.Finite.equiv (Submodule.Quotient.restrictScalarsEquiv K _)
+
+theorem kwF4gRRTate_DVRQuotPowKFinite_of_cotangent
+    (hCot : KwF4gRRTateDVRCotangentKFinite K L) :
+    KwF4gRRTateDVRQuotPowKFinite K L := by
+  intro u _ πh hπh M
+  have := finiteDimensional_idealQuot_pow u hCot πh hπh M
+  exact Module.Finite.equiv (quotPiPowEquivIdealQuot u πh M).symm
+
+theorem kwF4gRRTate_commFinite_of_cotangent [∀ u : Place K L, u.FiniteResidue]
+    (hCot : KwF4gRRTateDVRCotangentKFinite K L) :
+    KwF4gRRTateCommFinite K L :=
+  kwF4gRRTate_commFinite_of_DVRQuotPowKFinite
+    (kwF4gRRTate_DVRQuotPowKFinite_of_cotangent hCot)
+
+end DVRQuotDischarge
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateCommFinite.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateCommFinite.AlgebraicCurve.Place LinearMap \
+  P2MW.S_AlgebraicCurve_tateCommFinite.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateCommFinite.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate P2MW.S_AlgebraicCurve_tateCommFinite.ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateCommFinite.ModularCurve.KwF4R1V410a"
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateCommFinite.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateCommFinite.IsDedekindDomain.HeightOneSpectrum IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateCommFinite.IsLocalRing"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "tateCommRestrict_apply tateComm_eq_of_commute \
+  adicIntegersKSubmod tateProj lmulK KwF4gRRTateCommFinite"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section DVRCotangentDischarge
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+scoped instance instIsScalarTower_K_toValuationSubring_adicCompletionIntegers :
+    IsScalarTower K u.toValuationSubring u.adicCompletionIntegers := by
+  refine IsScalarTower.of_algebraMap_eq fun k => ?_
+  apply Subtype.ext
+  change algebraMap K u.adicCompletion k
+    = (algebraMap u.toValuationSubring u.adicCompletionIntegers (algebraMap K _ k)).val
+  rw [IsScalarTower.algebraMap_apply K L u.adicCompletion]
+  rfl
+
+theorem span_irreducible_eq_completionIdeal_pow_one
+    (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) :
+    (Ideal.span {πh} : Ideal u.adicCompletionIntegers)
+      = (u.heightOneSpectrum.completionIdeal L) ^ 1 := by
+  rw [pow_one, ← hπh.maximalIdeal_eq]
+
+def quotientEquivKAlg (n : ℕ) :
+    (u.toValuationSubring ⧸ (IsLocalRing.maximalIdeal u.toValuationSubring) ^ n)
+      ≃ₐ[K] (u.adicCompletionIntegers ⧸ (u.heightOneSpectrum.completionIdeal L) ^ n) :=
+  { kwF4R1V410a_quotientEquiv u n with
+    commutes' := fun k => by
+      change kwF4R1V410a_quotientEquiv u n (algebraMap K _ k) = algebraMap K _ k
+      rw [IsScalarTower.algebraMap_apply K u.toValuationSubring
+          (u.toValuationSubring ⧸ (IsLocalRing.maximalIdeal u.toValuationSubring) ^ n),
+        Ideal.Quotient.algebraMap_eq, kwF4R1V410a_quotientEquiv_mk,
+        IsScalarTower.algebraMap_apply K u.adicCompletionIntegers
+          (u.adicCompletionIntegers ⧸ (u.heightOneSpectrum.completionIdeal L) ^ n),
+        Ideal.Quotient.algebraMap_eq,
+        IsScalarTower.algebraMap_apply K u.toValuationSubring u.adicCompletionIntegers] }
+
+def quotSpanIrreducibleEquivResidueField (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) :
+    (u.adicCompletionIntegers ⧸ (Ideal.span {πh} : Ideal u.adicCompletionIntegers))
+      ≃ₗ[K] u.ResidueField :=
+  (Ideal.quotientEquivAlgOfEq K
+      (span_irreducible_eq_completionIdeal_pow_one u πh hπh)).toLinearEquiv.trans
+    ((quotientEquivKAlg u 1).symm.toLinearEquiv.trans
+      (Ideal.quotientEquivAlgOfEq K
+        (pow_one (IsLocalRing.maximalIdeal u.toValuationSubring))).toLinearEquiv)
+
+theorem kwF4gRRTate_DVRCotangentKFinite : KwF4gRRTateDVRCotangentKFinite K L := by
+  intro u _ πh hπh
+  have : Module.Finite K u.ResidueField := FiniteResidue.finite
+  exact Module.Finite.equiv (quotSpanIrreducibleEquivResidueField u πh hπh).symm
+
+theorem kwF4gRRTate_commFinite [∀ u : Place K L, u.FiniteResidue] :
+    KwF4gRRTateCommFinite K L :=
+  kwF4gRRTate_commFinite_of_cotangent kwF4gRRTate_DVRCotangentKFinite
+
+end DVRCotangentDischarge
+end ModularCurve.KwF4gRRTate
+end
+end
+
+theorem solution {K L : Type*} [Field K] [Field L] [Algebra K L]
+    [∀ u : AlgebraicCurve.Place K L, u.FiniteResidue] :
+    ModularCurve.KwF4gRRTate.KwF4gRRTateCommFinite K L :=
+  ModularCurve.KwF4gRRTate.kwF4gRRTate_commFinite
+
+end S_AlgebraicCurve_tateCommFinite
+end P2MW
+export P2MW.S_AlgebraicCurve_tateCommFinite (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.tateCommFinite
+    {K L : Type*} [Field K] [Field L] [Algebra K L]
+    [∀ u : AlgebraicCurve.Place K L, u.FiniteResidue] :
+    ModularCurve.KwF4gRRTate.KwF4gRRTateCommFinite K L :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_tateTraceCompat_of_isSeparable.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_tateTraceCompat_of_isSeparable.lean
new file mode 100644
index 0000000000..dec6e5f714
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_tateTraceCompat_of_isSeparable.lean
@@ -0,0 +1,3715 @@
+/-
+Based on Prove2Me node AlgebraicCurve.tateTraceCompat_of_isSeparable
+(f5ada583-996c-5e80-8e5c-654a26d8f916) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2b36baea-dcba-5e19-8675-70302df4f486
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_TateResidueCurrency
+
+import Mathlib.Algebra.GroupWithZero.Submonoid.CancelMulZero
+import Mathlib.Algebra.Lie.OfAssociative
+import Mathlib.Analysis.Normed.Unbundled.SpectralNorm
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Trace compatibility of Tate's local residue for separable F/E
+
+Theorem statement: `AlgebraicCurve.tateTraceCompat_of_isSeparable`
+(`f5ada583-996c-5e80-8e5c-654a26d8f916`), by Claude, 2026-09-05.
+
+Proof: submission `2b36baea-dcba-5e19-8675-70302df4f486`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, $F$ a field extension of $K$, and $E$ an intermediate field, in the sense that
+$E$ is a $K$-algebra, $F$ is an $E$-algebra and the scalar actions form a tower $K \subseteq E
+\subseteq F$; assume $F$ is integral and separable over $E$. Assume furthermore that canonical local
+residue data are fixed at every place of $F$ and of $E$ over $K$ (the classes
+[`AlgebraicCurve.HasCanonicalLocalResidueKStar`](def/AlgebraicCurve_LocalResidue.html#L51) for $K
+\subseteq F$ and $K \subseteq E$, which assign to each place a residue functional killing
+$\pi^{-(n+1)}$ for all $n \ge 1$), and that every place of $F$ over $K$ and every place of $E$ over
+$K$ has residue field finite-dimensional over $K$; here a place of a field $L$ over $K$ is a
+valuation subring of $L$ containing the image of $K$, different from all of $L$, and a principal
+ideal ring. Let $h_F$ and $h_E$ be witnesses that Tate's commutators have finite rank: for every
+place $u$ of $F$ (respectively of $E$) and all $f, g$ in the adic completion $\widehat L_u$, the
+range of the restriction of the commutator built from the projector `tateProj` $u$ (projection onto
+the $K$-submodule of adic integers along a chosen complement) and the multiplication operators by
+$f$ and by $g$ is finite-dimensional over $K$, so that the residue symbol `tateRes` $u$ $f$ $g$, the
+trace of that restricted commutator, is defined. The conclusion is the proposition
+`KwF4gRRTateTraceCompat K F E h_F h_E`: for all instances making principal divisors available for $K
+\subseteq E$ and $K \subseteq F$ and making $F$ finite-dimensional over $E$, for every place $v$ of
+$E$, every place $w$ of $F$ in the fibre of $v$, and every $g \in F$, the residue symbol at $w$ of
+the image of $g$ in $\widehat F_w$ against the image of the uniformiser $\pi_v$ of $v$ equals the
+residue symbol at $v$ of the completed trace of $g$ from $w$ down to $v$ against the image of
+$\pi_v$ in $\widehat E_v$, the required finiteness instances being those provided by $h_F$ and
+$h_E$.
+
+This is Tate's trace formula for the local residue symbol: the residue at a place $w$ of $F$
+computed against a uniformiser pulled back from $E$ agrees with the residue at the place $v$ below
+of the local trace. It is used in the proofs that taking residues commutes with the trace map,
+[`AlgebraicCurve.residueTraceCompletionCommute`]
+(thm.html#AlgebraicCurve.residueTraceCompletionCommute)
+and
+[`AlgebraicCurve.residueTraceCompletionCommute_v2`]
+(thm.html#AlgebraicCurve.residueTraceCompletionCommute_v2);
+the finiteness witnesses appear explicitly as arguments because the proposition asserted depends on
+them.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_tateTraceCompat_of_isSeparable.lean
+
+*Attribution:* this file contains material adapted from third-party Apache-2.0 sources (a short
+passage (a few lines): `FLT/Mathlib/RingTheory/Valuation/ValuationSubring.lean` — © 2025 Ruben Van
+de Velde; authors: Ruben Van de Velde, Kevin Buzzard, Salvatore Mercuri;
+`FLT/Mathlib/RingTheory/LocalRing/MaximalIdeal/Basic.lean` — © 2025 Salvatore Mercuri; authors:
+Salvatore Mercuri, Kevin Buzzard). See ATTRIBUTION.md and NOTICE in the source repository.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalLocalResidueKStar Place.mem_restrict_iff Place.mem_fiber Place.restrict_mem_fiber \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kwHgfV352_completionTraceAt"
+end AlgebraicCurve
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalLocalResidueKStar Place.mem_restrict_iff Place.mem_fiber Place.restrict_mem_fiber \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kwHgfV352_completionTraceAt"
+end AlgebraicCurve
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalLocalResidueKStar Place.mem_restrict_iff Place.mem_fiber Place.restrict_mem_fiber \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kwHgfV352_completionTraceAt"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_one ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow ne_top' FiniteResidue.finite algebraMap_mem' \
+  toValuationSubring mk uniformizer ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap restrict \
+  mem_restrict_iff fiber mem_fiber restrict_mem_fiber adicCompletion adicCompletionIntegers \
+  kw_ffgc_adicCompletionComap kw_ffgc_valued_adicCompletionComap \
+  kw_ffgc_adicCompletionComapIntegers kw_ffgc_algebraAdicCompletionComap \
+  kw_ffgc_algebraMap_adicCompletionComap_eq kw_ffgc_rankOne_adicCompletion kw_ffgc_absoluteValue \
+  kw_ffgc_adicCompletionComap_algebraMap_algebraMap kw_ffgc_completionLinearCombination \
+  kw_ffgc_denseRange_completionLinearCombination kw_ffgc_completionTraceF'"
+end AlgebraicCurve.Place
+namespace Filter
+p2m_export "Filter" "mem_bot ker mk pi mem_comap map_top mem_ker mem_top comap unique map_mono map"
+end Filter
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "HeightOneSpectrum.adicCompletionIntegers \
+  HeightOneSpectrum.adicCompletionIntegers.integers HeightOneSpectrum.ext mk HeightOneSpectrum"
+end IsDedekindDomain
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "HeightOneSpectrum.adicCompletionIntegers \
+  HeightOneSpectrum.adicCompletionIntegers.integers HeightOneSpectrum.ext mk HeightOneSpectrum"
+namespace HeightOneSpectrum
+p2m_export "IsDedekindDomain.HeightOneSpectrum" "valuation_of_algebraMap \
+  intValuation_le_pow_iff_mem isMaximal mk comap valuedAdicCompletion_eq_valuation' adicCompletion \
+  valuation adicCompletionIntegers valuedAdicCompletion_surjective adicCompletionIntegers.integers \
+  mem_integers_of_valuation_le_one denseRange_algebraMap intValuation completionIdeal \
+  adicCompletion.mem_completionIdeal_pow"
+end IsDedekindDomain.HeightOneSpectrum
+namespace IsLocalRing
+p2m_export "IsLocalRing" "ResidueField maximalIdeal maximalIdeal.isMaximal of_injective"
+end IsLocalRing
+namespace KaehlerDifferential
+p2m_export "KaehlerDifferential" "finite D map"
+end KaehlerDifferential
+namespace LinearMap
+p2m_export "LinearMap" "mulLeft_apply single_apply toMatrix mem_range range sub_apply coe_range \
+  rank add_apply trace_eq_matrix_trace ker_eq_bot range_zero restrictScalars_apply id sum_apply \
+  range_comp codRestrict zero_apply smul_apply mulLeft ker_comp trace_comp_comm' mk coe_coe \
+  id_apply pi proj ext comp isIntegral trace quotKerEquivRange finiteDimensional \
+  range_comp_le_range single comp_assoc restrictScalars ker proj_apply mem_ker comp_apply \
+  toMatrix_mulVec_repr mem_range_self restrict pi_apply"
+end LinearMap
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+end ModularCurve
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+end ModularCurve
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+end ModularCurve
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateTraceCompat"
+end ModularCurve.KwF4gRRTate
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+end ModularCurve
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+end ModularCurve
+namespace Module
+p2m_export "Module" "Basis.repr_reindex_apply Injective Free.chooseBasis Free.ChooseBasisIndex \
+  isTorsionFree_iff_algebraMap_injective Basis.localizationLocalization_apply equiv Finite.equiv \
+  finrank Free mk IsTorsionFree free_of_finite_type_torsion_free' restrictScalars \
+  Basis.equivFun_apply IsNoetherian.finite Finite.of_submodule_quotient finBasis \
+  Basis.localizationLocalization_repr_algebraMap finrank_eq_card_chooseBasisIndex \
+  Basis.reindex_apply Basis"
+end Module
+namespace MonoidWithZeroHom
+p2m_export "MonoidWithZeroHom" "id_apply id ext mk coe_coe coe_one comp_apply comp_assoc comp"
+end MonoidWithZeroHom
+namespace Multiplicative
+p2m_export "Multiplicative" "ext smul"
+end Multiplicative
+namespace NNReal
+p2m_export "NNReal" "pi rpow_le_one rpow_natCast smul_def coe_pow coe_one rpow_mul coe_eq_zero \
+  rpow_one coe_nonneg"
+end NNReal
+namespace NumberField
+p2m_export "NumberField" "mk"
+end NumberField
+namespace Polynomial
+p2m_export "Polynomial" "X coe_one aeval_map_algebraMap aeval_def algebraMap_eq unique aeval \
+  ext_iff toSubring coe_pow isLocalization map lifts_and_degree_eq_and_monic comp_assoc Monic comp \
+  coe_mul coe_sub Separable lifts_iff_coeff_lifts algebraMap_apply ext funext ring \
+  aeval_algHom_apply lifts Separable.map"
+end Polynomial
+namespace Submodule
+p2m_export "Submodule" "quotEquivOfEq inclusion mem_sup_right map_top smul_mem' mk smul_mem \
+  mem_bot coe_mem Quotient.mk span restrictScalars projectionOnto_apply_left restrictScalars_top \
+  mem_closure_iff Quotient.restrictScalarsEquiv mem_comap injective_subtype mem_top Quotient.equiv \
+  mem_span_singleton mkQ map_mono map_smul' equivMapOfInjective zero quotientQuotientEquivQuotient \
+  coe_eq_zero range_subtype Quotient.mk_surjective restrictScalars_mono map mem_inf \
+  inclusion_apply Quotient.mk_eq_zero exists_isCompl projectionOnto finiteDimensional_of_le \
+  closure_eq topEquiv smul_def mk_eq_zero restrictScalarsEquiv closed_of_finiteDimensional \
+  mkQ_apply pi ext subtype_apply ker_mkQ add comap finiteDimensional_sup liftQ mem_sup_left smul \
+  restrictScalars_mem"
+end Submodule
+namespace TensorProduct
+p2m_export "TensorProduct" "congr lift mk ext tmul map Algebra.smul_def mk_surjective"
+end TensorProduct
+namespace Valuation
+p2m_export "Valuation" "norm_add_le map_add' valuationSubring ext mem_valuationSubring_iff map_sub \
+  map Integers.isIntegrallyClosed Integers IsRankOneDiscrete congr RankOne.hom restrict_le_iff \
+  coe_coe restrict norm_def comap restrict_eq_zero_iff mk map_sub_swap norm_nonneg RankOne \
+  isOpen_closedBall"
+end Valuation
+namespace Valuation
+p2m_export "Valuation" "norm_add_le map_add' valuationSubring ext mem_valuationSubring_iff map_sub \
+  map Integers.isIntegrallyClosed Integers IsRankOneDiscrete congr RankOne.hom restrict_le_iff \
+  coe_coe restrict norm_def comap restrict_eq_zero_iff mk map_sub_swap norm_nonneg RankOne \
+  isOpen_closedBall"
+namespace IsRankOneDiscrete
+p2m_export "Valuation.IsRankOneDiscrete" "valueGroup₀_equiv_withZeroMulInt_restrict_apply_of_surjec\
+  tive mk"
+end Valuation.IsRankOneDiscrete
+namespace Valued
+p2m_export "Valued" "mk toNormedField.norm_def v toNontriviallyNormedField \
+  toNormedField.norm_le_one_iff isOpen_closedBall toNormedField ResidueField maximalIdeal"
+end Valued
+namespace WithZero
+p2m_export "WithZero" "coe_one map coe_mul exp_eq_coe_ofAdd coe exp_ne_zero exp exp_zero lift \
+  coe_pow le exp_le_exp"
+end WithZero
+namespace WithZeroMulInt
+p2m_export "WithZeroMulInt" "toNNReal"
+end WithZeroMulInt
+
+section
+namespace IsLocalRing
+p2m_export "IsLocalRing" "ResidueField maximalIdeal maximalIdeal.isMaximal of_injective"
+end IsLocalRing
+p2m_open_scoped "IsLocalRing" in
+theorem IsLocalRing.maximalIdeal_le {R : Type*} [CommSemiring R] [IsLocalRing R] {J : Ideal R}
+    (hJ : J ≠ ⊤) (h : IsLocalRing.maximalIdeal R ≤ J) :
+    J.IsMaximal :=
+  (IsLocalRing.maximalIdeal.isMaximal R).eq_of_le hJ h ▸ IsLocalRing.maximalIdeal.isMaximal R
+
+scoped instance instAlgebraSubtypeMemValuationSubring_fLT {K L : Type*} [Field K] [Semiring L]
+    (O : ValuationSubring K) [Algebra K L] : Algebra O L where
+  smul r x := r.1 • x
+  algebraMap := (algebraMap K L).comp (algebraMap O K)
+  commutes' _ _ := by simp [Algebra.commutes]
+  smul_def' _ _ := by simp [← Algebra.smul_def]; rfl
+end
+
+section
+
+
+p2m_open "LinearMap P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Submodule"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateTraceCompat"
+end ModularCurve.KwF4gRRTate
+
+end
+
+end
+
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain \
+  WithZero P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.WithZero IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsLocalRing"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalLocalResidueKStar Place.mem_restrict_iff Place.mem_fiber Place.restrict_mem_fiber \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kwHgfV352_completionTraceAt"
+p2m_open "AlgebraicCurve"
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_one ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow ne_top' FiniteResidue.finite algebraMap_mem' \
+  toValuationSubring mk uniformizer ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap restrict \
+  mem_restrict_iff fiber mem_fiber restrict_mem_fiber adicCompletion adicCompletionIntegers \
+  kw_ffgc_adicCompletionComap kw_ffgc_valued_adicCompletionComap \
+  kw_ffgc_adicCompletionComapIntegers kw_ffgc_algebraAdicCompletionComap \
+  kw_ffgc_algebraMap_adicCompletionComap_eq kw_ffgc_rankOne_adicCompletion kw_ffgc_absoluteValue \
+  kw_ffgc_adicCompletionComap_algebraMap_algebraMap kw_ffgc_completionLinearCombination \
+  kw_ffgc_denseRange_completionLinearCombination kw_ffgc_completionTraceF'"
+end Place
+
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "smul_def smul_apply"
+end Divisor
+
+namespace Pic0
+p2m_export "AlgebraicCurve.Pic0" "mk mk_surjective"
+end Pic0
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_one ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow ne_top' FiniteResidue.finite algebraMap_mem' \
+  toValuationSubring mk uniformizer ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap restrict \
+  mem_restrict_iff fiber mem_fiber restrict_mem_fiber adicCompletion adicCompletionIntegers \
+  kw_ffgc_adicCompletionComap kw_ffgc_valued_adicCompletionComap \
+  kw_ffgc_adicCompletionComapIntegers kw_ffgc_algebraAdicCompletionComap \
+  kw_ffgc_algebraMap_adicCompletionComap_eq kw_ffgc_rankOne_adicCompletion kw_ffgc_absoluteValue \
+  kw_ffgc_adicCompletionComap_algebraMap_algebraMap kw_ffgc_completionLinearCombination \
+  kw_ffgc_denseRange_completionLinearCombination kw_ffgc_completionTraceF'"
+end Place
+
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "smul_def smul_apply"
+end Divisor
+
+namespace Pic0
+p2m_export "AlgebraicCurve.Pic0" "mk mk_surjective"
+end Pic0
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_one ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow ne_top' FiniteResidue.finite algebraMap_mem' \
+  toValuationSubring mk uniformizer ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap restrict \
+  mem_restrict_iff fiber mem_fiber restrict_mem_fiber adicCompletion adicCompletionIntegers \
+  kw_ffgc_adicCompletionComap kw_ffgc_valued_adicCompletionComap \
+  kw_ffgc_adicCompletionComapIntegers kw_ffgc_algebraAdicCompletionComap \
+  kw_ffgc_algebraMap_adicCompletionComap_eq kw_ffgc_rankOne_adicCompletion kw_ffgc_absoluteValue \
+  kw_ffgc_adicCompletionComap_algebraMap_algebraMap kw_ffgc_completionLinearCombination \
+  kw_ffgc_denseRange_completionLinearCombination kw_ffgc_completionTraceF'"
+end Place
+
+end AlgebraicCurve
+
+end
+
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain \
+  WithZero P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.WithZero IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsLocalRing"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalLocalResidueKStar Place.mem_restrict_iff Place.mem_fiber Place.restrict_mem_fiber \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kwHgfV352_completionTraceAt"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_one ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow ne_top' FiniteResidue.finite algebraMap_mem' \
+  toValuationSubring mk uniformizer ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap restrict \
+  mem_restrict_iff fiber mem_fiber restrict_mem_fiber adicCompletion adicCompletionIntegers \
+  kw_ffgc_adicCompletionComap kw_ffgc_valued_adicCompletionComap \
+  kw_ffgc_adicCompletionComapIntegers kw_ffgc_algebraAdicCompletionComap \
+  kw_ffgc_algebraMap_adicCompletionComap_eq kw_ffgc_rankOne_adicCompletion kw_ffgc_absoluteValue \
+  kw_ffgc_adicCompletionComap_algebraMap_algebraMap kw_ffgc_completionLinearCombination \
+  kw_ffgc_denseRange_completionLinearCombination kw_ffgc_completionTraceF'"
+p2m_open "AlgebraicCurve.Place"
+
+section SinglePlace
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+
+p2m_export "AlgebraicCurve.Place" "ord_nonneg_of_mem"
+
+p2m_export "AlgebraicCurve.Place" "mem_of_ord_nonneg"
+
+p2m_export "AlgebraicCurve.Place" "mem_iff_ord_nonneg"
+
+end SinglePlace
+
+section Restrict
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F'] [Algebra F F']
+
+
+variable (w : Place K F')
+
+
+p2m_export "AlgebraicCurve.Place" "comap_algebraMap_ne_top"
+
+
+
+
+
+p2m_export "AlgebraicCurve.Place" "exists_ord_algebraMap_pos"
+end Restrict
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+
+
+section
+
+variable {F : Type*} [Field F]
+
+namespace ValuationSubring
+p2m_export "ValuationSubring" "comap subtype mem_comap subtype_apply toSubring algebraMap_apply \
+  ext zero_mem mk mem_top mul_mem algebraMap_injective add_mem eq_top_iff valuation inclusion"
+end ValuationSubring
+p2m_open_scoped "ValuationSubring" in
+theorem ValuationSubring.valued_eq_one_of_isUnit {K : Type*} [Field K] {Γ₀ : Type*}
+    [LinearOrderedCommGroupWithZero Γ₀] [hv : Valued K Γ₀] (x : hv.v.valuationSubring)
+    (hx : IsUnit x) : Valued.v x.val = 1 := by
+  obtain ⟨u, hu⟩ := hx
+  apply le_antisymm ((hv.v.mem_valuationSubring_iff _).1 x.2)
+  rw [← Valued.v.map_one (R := K), ← Submonoid.coe_one, ← u.mul_inv, hu,
+    Submonoid.coe_mul, Valued.v.map_mul]
+  nth_rw 2 [← mul_one (Valued.v x.val)]
+  exact mul_le_mul_right ((hv.v.mem_valuationSubring_iff _).1 (u⁻¹.val.property)) _
+
+p2m_open_scoped "ValuationSubring" in
+theorem ValuationSubring.isUnit_of_valued_eq_one {K : Type*} [Field K] {Γ₀ : Type*}
+    [LinearOrderedCommGroupWithZero Γ₀] [hv : Valued K Γ₀] (x : hv.v.valuationSubring)
+    (hx : Valued.v x.val = 1) : IsUnit x := by
+  have : IsUnit x.val := by rw [isUnit_iff_ne_zero, ne_eq, ← map_eq_zero hv.v, hx]; aesop
+  obtain ⟨u, hu⟩ := this
+  have hu_inv_le : Valued.v u⁻¹.val ≤ 1 := by
+    rw [← one_mul (Valued.v _), ← hx, ← hu, ← Valued.v.map_mul, u.mul_inv, hu, hx, Valued.v.map_one]
+  rw [isUnit_iff_exists]
+  exact ⟨⟨u⁻¹.val, hu_inv_le⟩, ⟨by aesop, by aesop⟩⟩
+
+p2m_open_scoped "ValuationSubring" in
+theorem ValuationSubring.isUnit_iff_valued_eq_one {K : Type*} [Field K] {Γ₀ : Type*}
+    [LinearOrderedCommGroupWithZero Γ₀] [hv : Valued K Γ₀] (x : hv.v.valuationSubring) :
+    IsUnit x ↔ Valued.v x.val = 1 :=
+  ⟨valued_eq_one_of_isUnit x, isUnit_of_valued_eq_one x⟩
+
+end
+
+
+
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalLocalResidueKStar Place.mem_restrict_iff Place.mem_fiber Place.restrict_mem_fiber \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kwHgfV352_completionTraceAt"
+p2m_open "AlgebraicCurve"
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [Algebra.IsIntegral F F'] [HasPrincipalDivisors K F']
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_one ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow ne_top' FiniteResidue.finite algebraMap_mem' \
+  toValuationSubring mk uniformizer ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap restrict \
+  mem_restrict_iff fiber mem_fiber restrict_mem_fiber adicCompletion adicCompletionIntegers \
+  kw_ffgc_adicCompletionComap kw_ffgc_valued_adicCompletionComap \
+  kw_ffgc_adicCompletionComapIntegers kw_ffgc_algebraAdicCompletionComap \
+  kw_ffgc_algebraMap_adicCompletionComap_eq kw_ffgc_rankOne_adicCompletion kw_ffgc_absoluteValue \
+  kw_ffgc_adicCompletionComap_algebraMap_algebraMap kw_ffgc_completionLinearCombination \
+  kw_ffgc_denseRange_completionLinearCombination kw_ffgc_completionTraceF'"
+end Place
+
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "smul_def smul_apply"
+end Divisor
+
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "smul_def smul_apply"
+end Divisor
+
+end AlgebraicCurve
+
+end
+
+
+section
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain.HeightOneSpectrum \
+  IsLocalRing P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsLocalRing WithZero \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.WithZero MonoidWithZeroHom \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.MonoidWithZeroHom"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalLocalResidueKStar Place.mem_restrict_iff Place.mem_fiber Place.restrict_mem_fiber \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kwHgfV352_completionTraceAt"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_one ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow ne_top' FiniteResidue.finite algebraMap_mem' \
+  toValuationSubring mk uniformizer ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap restrict \
+  mem_restrict_iff fiber mem_fiber restrict_mem_fiber adicCompletion adicCompletionIntegers \
+  kw_ffgc_adicCompletionComap kw_ffgc_valued_adicCompletionComap \
+  kw_ffgc_adicCompletionComapIntegers kw_ffgc_algebraAdicCompletionComap \
+  kw_ffgc_algebraMap_adicCompletionComap_eq kw_ffgc_rankOne_adicCompletion kw_ffgc_absoluteValue \
+  kw_ffgc_adicCompletionComap_algebraMap_algebraMap kw_ffgc_completionLinearCombination \
+  kw_ffgc_denseRange_completionLinearCombination kw_ffgc_completionTraceF'"
+end AlgebraicCurve.Place
+
+end
+end
+
+
+section
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain.HeightOneSpectrum \
+  IsLocalRing P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsLocalRing WithZero \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.WithZero MonoidWithZeroHom \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.MonoidWithZeroHom"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalLocalResidueKStar Place.mem_restrict_iff Place.mem_fiber Place.restrict_mem_fiber \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kwHgfV352_completionTraceAt"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_one ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow ne_top' FiniteResidue.finite algebraMap_mem' \
+  toValuationSubring mk uniformizer ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap restrict \
+  mem_restrict_iff fiber mem_fiber restrict_mem_fiber adicCompletion adicCompletionIntegers \
+  kw_ffgc_adicCompletionComap kw_ffgc_valued_adicCompletionComap \
+  kw_ffgc_adicCompletionComapIntegers kw_ffgc_algebraAdicCompletionComap \
+  kw_ffgc_algebraMap_adicCompletionComap_eq kw_ffgc_rankOne_adicCompletion kw_ffgc_absoluteValue \
+  kw_ffgc_adicCompletionComap_algebraMap_algebraMap kw_ffgc_completionLinearCombination \
+  kw_ffgc_denseRange_completionLinearCombination kw_ffgc_completionTraceF'"
+end AlgebraicCurve.Place
+
+end
+end
+
+
+section
+
+
+noncomputable section
+
+p2m_open "Polynomial P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Polynomial IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsLocalRing IsDedekindDomain \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalLocalResidueKStar Place.mem_restrict_iff Place.mem_fiber Place.restrict_mem_fiber \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kwHgfV352_completionTraceAt"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_one ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow ne_top' FiniteResidue.finite algebraMap_mem' \
+  toValuationSubring mk uniformizer ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap restrict \
+  mem_restrict_iff fiber mem_fiber restrict_mem_fiber adicCompletion adicCompletionIntegers \
+  kw_ffgc_adicCompletionComap kw_ffgc_valued_adicCompletionComap \
+  kw_ffgc_adicCompletionComapIntegers kw_ffgc_algebraAdicCompletionComap \
+  kw_ffgc_algebraMap_adicCompletionComap_eq kw_ffgc_rankOne_adicCompletion kw_ffgc_absoluteValue \
+  kw_ffgc_adicCompletionComap_algebraMap_algebraMap kw_ffgc_completionLinearCombination \
+  kw_ffgc_denseRange_completionLinearCombination kw_ffgc_completionTraceF'"
+p2m_open "AlgebraicCurve.Place AlgebraicCurve"
+
+section CompletionAlgebra
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+variable (F)
+variable [Algebra F F'] [IsScalarTower K F F'] [Algebra.IsIntegral F F'] (W : Place K F')
+
+scoped instance kw_ffgc_isIntegrallyClosed_adicCompletionIntegers :
+    IsIntegrallyClosed (W.restrict F).adicCompletionIntegers :=
+  Valuation.Integers.isIntegrallyClosed
+    (HeightOneSpectrum.adicCompletionIntegers.integers
+      (K := F) (v := (W.restrict F).heightOneSpectrum))
+
+theorem kw_ffgc_adicCompletionComapIntegers_injective :
+    Function.Injective (kw_ffgc_adicCompletionComapIntegers F W) := by
+  intro a b hab
+  exact Subtype.ext ((kw_ffgc_adicCompletionComap F W).injective
+    (congrArg Subtype.val hab))
+
+scoped instance kw_ffgc_isTorsionFree_adicCompletionComapIntegers :
+    Module.IsTorsionFree (W.restrict F).adicCompletionIntegers W.adicCompletionIntegers :=
+  Module.isTorsionFree_iff_algebraMap_injective.mpr
+    (kw_ffgc_adicCompletionComapIntegers_injective F W)
+
+end CompletionAlgebra
+
+section SpectralSetup
+
+p2m_open_scoped "Valued P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Valued NNReal \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.NNReal WithZero \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.WithZero"
+
+p2m_open "WithZeroMulInt P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.WithZeroMulInt \
+  Valuation.IsRankOneDiscrete \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Valuation.IsRankOneDiscrete"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (V : Place K F)
+
+theorem kw_ffgc_norm_adicCompletion_eq (x : V.adicCompletion) :
+    letI := kw_ffgc_rankOne_adicCompletion V
+    ‖x‖ = (WithZeroMulInt.toNNReal (two_ne_zero) (Valued.v x) : ℝ) := by
+  let := kw_ffgc_rankOne_adicCompletion V
+  have h := valueGroup₀_equiv_withZeroMulInt_restrict_apply_of_surjective
+    (V.heightOneSpectrum.valuedAdicCompletion_surjective F) x
+  simp only [Valued.toNormedField.norm_def, Valuation.RankOne.hom]
+  rw [← h]; rfl
+
+end SpectralSetup
+
+section AbsoluteValue
+
+p2m_open_scoped "Valued P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Valued NNReal \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.NNReal WithZero \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.WithZero"
+
+p2m_open "WithZeroMulInt P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.WithZeroMulInt \
+  Valuation.IsRankOneDiscrete \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Valuation.IsRankOneDiscrete"
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+variable (F)
+variable [Algebra F F'] [IsScalarTower K F F'] [Algebra.IsIntegral F F'] (W : Place K F')
+
+theorem kw_ffgc_absoluteValue_extends (c : (W.restrict F).adicCompletion) :
+    letI := kw_ffgc_rankOne_adicCompletion (W.restrict F)
+    kw_ffgc_absoluteValue F W
+      (algebraMap (W.restrict F).adicCompletion W.adicCompletion c) = ‖c‖ := by
+  let := kw_ffgc_rankOne_adicCompletion (W.restrict F)
+  let := kw_ffgc_rankOne_adicCompletion W
+  have hr : (0 : ℝ) < (W.ramificationIndex F : ℝ) :=
+    Nat.cast_pos.mpr (W.ramificationIndex_pos (F := F))
+  change ‖algebraMap (W.restrict F).adicCompletion W.adicCompletion c‖
+      ^ ((W.ramificationIndex F : ℝ))⁻¹ = ‖c‖
+  rw [kw_ffgc_norm_adicCompletion_eq W, kw_ffgc_norm_adicCompletion_eq (W.restrict F),
+    kw_ffgc_algebraMap_adicCompletionComap_eq, kw_ffgc_valued_adicCompletionComap,
+    map_pow, NNReal.coe_pow, ← Real.rpow_natCast, ← Real.rpow_mul (NNReal.coe_nonneg _),
+    mul_inv_cancel₀ hr.ne', Real.rpow_one]
+
+end AbsoluteValue
+
+section IntegralClosure
+
+p2m_open_scoped "Valued P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Valued NNReal \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.NNReal WithZero \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.WithZero"
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+variable (F)
+variable [Algebra F F'] [IsScalarTower K F F'] [Algebra.IsIntegral F F'] (W : Place K F')
+
+theorem kw_ffgc_isIntegral_adicCompletionIntegers_of_algebraic
+    [Algebra.IsAlgebraic (W.restrict F).adicCompletion W.adicCompletion]
+    (x : W.adicCompletionIntegers) :
+    _root_.IsIntegral (W.restrict F).adicCompletionIntegers x := by
+  let := kw_ffgc_rankOne_adicCompletion (W.restrict F)
+  let := kw_ffgc_rankOne_adicCompletion W
+  let : NontriviallyNormedField (W.restrict F).adicCompletion :=
+    Valued.toNontriviallyNormedField (W.restrict F).adicCompletion ℤᵐ⁰
+  have : IsUltrametricDist (W.restrict F).adicCompletion :=
+    IsUltrametricDist.isUltrametricDist_of_isNonarchimedean_norm
+      (fun a b => Valuation.norm_add_le Valued.v a b)
+  have hr : (0 : ℝ) < ((W.ramificationIndex F : ℝ))⁻¹ :=
+    inv_pos.mpr (Nat.cast_pos.mpr (W.ramificationIndex_pos (F := F)))
+  have hxn : ‖(x : W.adicCompletion)‖ ≤ 1 :=
+    (Valued.toNormedField.norm_le_one_iff).mpr x.2
+  have hsn : spectralNorm (W.restrict F).adicCompletion W.adicCompletion
+        (x : W.adicCompletion)
+      = ‖(x : W.adicCompletion)‖ ^ ((W.ramificationIndex F : ℝ))⁻¹ :=
+    (spectralNorm_unique_field_norm_ext (f := kw_ffgc_absoluteValue F W)
+      (kw_ffgc_absoluteValue_extends F W) (x : W.adicCompletion)).symm
+  have hspec : spectralValue (minpoly (W.restrict F).adicCompletion
+      (x : W.adicCompletion)) ≤ 1 := by
+    change spectralNorm (W.restrict F).adicCompletion W.adicCompletion
+      (x : W.adicCompletion) ≤ 1
+    rw [hsn]; exact Real.rpow_le_one (norm_nonneg _) hxn hr.le
+  have hmon : (minpoly (W.restrict F).adicCompletion (x : W.adicCompletion)).Monic :=
+    minpoly.monic (Algebra.IsAlgebraic.isAlgebraic
+      (R := (W.restrict F).adicCompletion) (x : W.adicCompletion)).isIntegral
+  have hlift : minpoly (W.restrict F).adicCompletion (x : W.adicCompletion)
+      ∈ Polynomial.lifts (algebraMap (W.restrict F).adicCompletionIntegers
+          (W.restrict F).adicCompletion) := by
+    refine (Polynomial.lifts_iff_coeff_lifts _).mpr fun n => ⟨⟨_, ?_⟩, rfl⟩
+    exact (Valued.toNormedField.norm_le_one_iff).mp
+      ((spectralValue_le_one_iff hmon).mp hspec n)
+  obtain ⟨P, hP, -, hPmon⟩ := Polynomial.lifts_and_degree_eq_and_monic hlift hmon
+  have hxintW : _root_.IsIntegral (W.restrict F).adicCompletionIntegers (x : W.adicCompletion) := by
+    refine ⟨P, hPmon, ?_⟩
+    rw [← Polynomial.aeval_def,
+      ← Polynomial.aeval_map_algebraMap (W.restrict F).adicCompletion, hP, minpoly.aeval]
+  exact (isIntegral_algHom_iff
+    (IsScalarTower.toAlgHom (W.restrict F).adicCompletionIntegers
+      W.adicCompletionIntegers W.adicCompletion)
+    Subtype.val_injective).mp hxintW
+
+theorem kw_ffgc_isIntegralClosure_adicCompletionIntegers
+    [Algebra.IsAlgebraic (W.restrict F).adicCompletion W.adicCompletion] :
+    IsIntegralClosure W.adicCompletionIntegers (W.restrict F).adicCompletionIntegers
+      W.adicCompletion where
+  algebraMap_injective := Subtype.val_injective
+  isIntegral_iff {x} := by
+    constructor
+    · intro hx
+      have hxW : _root_.IsIntegral W.adicCompletionIntegers x := hx.tower_top
+      have : IsIntegrallyClosed W.adicCompletionIntegers :=
+        Valuation.Integers.isIntegrallyClosed
+          (HeightOneSpectrum.adicCompletionIntegers.integers
+            (K := F') (v := W.heightOneSpectrum))
+      exact IsIntegrallyClosed.isIntegral_iff.mp hxW
+    · rintro ⟨y, rfl⟩
+      exact (kw_ffgc_isIntegral_adicCompletionIntegers_of_algebraic F W y).map
+        (IsScalarTower.toAlgHom (W.restrict F).adicCompletionIntegers
+          W.adicCompletionIntegers W.adicCompletion)
+
+end IntegralClosure
+
+end AlgebraicCurve.Place
+end
+end
+
+section
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain.HeightOneSpectrum \
+  IsLocalRing P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsLocalRing WithZero \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.WithZero"
+
+p2m_open_scoped "Valued P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Valued WithZero \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.WithZero"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalLocalResidueKStar Place.mem_restrict_iff Place.mem_fiber Place.restrict_mem_fiber \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kwHgfV352_completionTraceAt"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_one ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow ne_top' FiniteResidue.finite algebraMap_mem' \
+  toValuationSubring mk uniformizer ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap restrict \
+  mem_restrict_iff fiber mem_fiber restrict_mem_fiber adicCompletion adicCompletionIntegers \
+  kw_ffgc_adicCompletionComap kw_ffgc_valued_adicCompletionComap \
+  kw_ffgc_adicCompletionComapIntegers kw_ffgc_algebraAdicCompletionComap \
+  kw_ffgc_algebraMap_adicCompletionComap_eq kw_ffgc_rankOne_adicCompletion kw_ffgc_absoluteValue \
+  kw_ffgc_adicCompletionComap_algebraMap_algebraMap kw_ffgc_completionLinearCombination \
+  kw_ffgc_denseRange_completionLinearCombination kw_ffgc_completionTraceF'"
+p2m_open "AlgebraicCurve.Place AlgebraicCurve"
+
+
+section CompletionTrace
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+variable (F)
+variable [Algebra F F'] [IsScalarTower K F F'] [Algebra.IsIntegral F F'] (W : Place K F')
+
+theorem kw_ffgc_completionTraceF'_apply [FiniteDimensional F F'] (g : F') :
+    kw_ffgc_completionTraceF' F W g
+      = Algebra.trace (W.restrict F).adicCompletion W.adicCompletion
+          (algebraMap F' W.adicCompletion g) := rfl
+
+end CompletionTrace
+end AlgebraicCurve.Place
+end
+end
+
+
+noncomputable section
+
+p2m_open "KaehlerDifferential \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.KaehlerDifferential"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalLocalResidueKStar Place.mem_restrict_iff Place.mem_fiber Place.restrict_mem_fiber \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kwHgfV352_completionTraceAt"
+p2m_open "AlgebraicCurve"
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+namespace IsCurveOver
+p2m_export "AlgebraicCurve.IsCurveOver" "mk"
+end IsCurveOver
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_one ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow ne_top' FiniteResidue.finite algebraMap_mem' \
+  toValuationSubring mk uniformizer ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap restrict \
+  mem_restrict_iff fiber mem_fiber restrict_mem_fiber adicCompletion adicCompletionIntegers \
+  kw_ffgc_adicCompletionComap kw_ffgc_valued_adicCompletionComap \
+  kw_ffgc_adicCompletionComapIntegers kw_ffgc_algebraAdicCompletionComap \
+  kw_ffgc_algebraMap_adicCompletionComap_eq kw_ffgc_rankOne_adicCompletion kw_ffgc_absoluteValue \
+  kw_ffgc_adicCompletionComap_algebraMap_algebraMap kw_ffgc_completionLinearCombination \
+  kw_ffgc_denseRange_completionLinearCombination kw_ffgc_completionTraceF'"
+end Place
+end AlgebraicCurve
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+end ModularCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalLocalResidueKStar Place.mem_restrict_iff Place.mem_fiber Place.restrict_mem_fiber \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kwHgfV352_completionTraceAt"
+end AlgebraicCurve
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+end ModularCurve
+end
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain \
+  WithZero P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.WithZero Module \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Module IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsLocalRing Module.IsLocalRing"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalLocalResidueKStar Place.mem_restrict_iff Place.mem_fiber Place.restrict_mem_fiber \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kwHgfV352_completionTraceAt"
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ResidueField FiniteResidue heightOneSpectrum \
+  heightOneSpectrum_asIdeal ord ord_one ord_mul ord_inv ord_coe_irreducible ord_zpow \
+  ord_unit_smul_zpow exists_unit_mul_zpow ne_top' FiniteResidue.finite algebraMap_mem' \
+  toValuationSubring mk uniformizer ramificationIndex ramificationIndex_pos \
+  exists_ord_eq_ramificationIndex ramificationIndex_dvd_ord irreducible_mk_comap restrict \
+  mem_restrict_iff fiber mem_fiber restrict_mem_fiber adicCompletion adicCompletionIntegers \
+  kw_ffgc_adicCompletionComap kw_ffgc_valued_adicCompletionComap \
+  kw_ffgc_adicCompletionComapIntegers kw_ffgc_algebraAdicCompletionComap \
+  kw_ffgc_algebraMap_adicCompletionComap_eq kw_ffgc_rankOne_adicCompletion kw_ffgc_absoluteValue \
+  kw_ffgc_adicCompletionComap_algebraMap_algebraMap kw_ffgc_completionLinearCombination \
+  kw_ffgc_denseRange_completionLinearCombination kw_ffgc_completionTraceF'"
+p2m_open "AlgebraicCurve.Place"
+
+variable (v : Place K F)
+
+private def _root_.AlgebraicCurve.Place.uniformizerSubring : v.toValuationSubring :=
+  (IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose
+
+p2m_export "AlgebraicCurve.Place" "uniformizerSubring"
+private theorem _root_.AlgebraicCurve.Place.uniformizer_mem :
+    v.uniformizer ∈ v.toValuationSubring :=
+  v.uniformizerSubring.2
+
+p2m_export "AlgebraicCurve.Place" "uniformizer_mem"
+end Place
+end AlgebraicCurve
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.GF24a9RRDx \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  IsDedekindDomain P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain"
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Divisor HasPrincipalDivisors Pic0 IsCurveOver \
+  HasCanonicalLocalResidueKStar Place.mem_restrict_iff Place.mem_fiber Place.restrict_mem_fiber \
+  kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff kwHgfV352_completionTraceAt"
+end AlgebraicCurve
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  LinearMap P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateTraceCompat"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section TateProj
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem mem_adicIntegersKSubmod_iff (x : u.adicCompletion) :
+    x ∈ adicIntegersKSubmod u ↔ x ∈ u.adicCompletionIntegers := Iff.rfl
+
+theorem tateProj_mem_integers (x : u.adicCompletion) :
+    tateProj u x ∈ u.adicCompletionIntegers :=
+  (mem_adicIntegersKSubmod_iff u _).mp
+    (Submodule.coe_mem
+      (Submodule.projectionOnto (adicIntegersKSubmod u) _
+        (Classical.choose_spec (Submodule.exists_isCompl (adicIntegersKSubmod u))) x))
+
+theorem tateProj_of_mem {x : u.adicCompletion} (hx : x ∈ u.adicCompletionIntegers) :
+    tateProj u x = x := by
+  have h := Submodule.projectionOnto_apply_left
+    (Classical.choose_spec (Submodule.exists_isCompl (adicIntegersKSubmod u)))
+    (⟨x, (mem_adicIntegersKSubmod_iff u x).mpr hx⟩ : adicIntegersKSubmod u)
+  have hcoe := congrArg (Subtype.val (p := fun y => y ∈ adicIntegersKSubmod u)) h
+  exact hcoe
+
+theorem tateProj_idem : tateProj u ∘ₗ tateProj u = tateProj u := by
+  refine LinearMap.ext fun x => ?_
+  rw [LinearMap.comp_apply]
+  exact tateProj_of_mem u (tateProj_mem_integers u x)
+
+theorem range_tateProj : LinearMap.range (tateProj u) = adicIntegersKSubmod u := by
+  apply le_antisymm
+  · rintro x ⟨y, rfl⟩
+    exact tateProj_mem_integers u y
+  · intro x hx
+    exact ⟨x, tateProj_of_mem u hx⟩
+
+end TateProj
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  LinearMap P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4gRRTate"
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain.HeightOneSpectrum \
+  IsLocalRing P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsLocalRing"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateTraceCompat"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section PoleWindow
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+def poleWindowKSubmod (πh : u.adicCompletionIntegers) (M : ℕ) :
+    Submodule K u.adicCompletion where
+  carrier := {x | (πh : u.adicCompletion) ^ M * x ∈ u.adicCompletionIntegers}
+  add_mem' {a b} ha hb := by
+    simp only [Set.mem_ofPred_eq, mul_add] at ha hb ⊢; exact add_mem ha hb
+  zero_mem' := by simp only [Set.mem_ofPred_eq, mul_zero]; exact zero_mem _
+  smul_mem' c x hx := by
+    simp only [Set.mem_ofPred_eq] at hx ⊢
+    rw [Algebra.smul_def, IsScalarTower.algebraMap_apply K L u.adicCompletion, mul_left_comm]
+    exact mul_mem ((kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff u _).mpr
+      (u.algebraMap_mem' c)) hx
+
+theorem mem_poleWindowKSubmod_iff (πh : u.adicCompletionIntegers) (M : ℕ)
+    (x : u.adicCompletion) :
+    x ∈ poleWindowKSubmod u πh M ↔ (πh : u.adicCompletion) ^ M * x ∈ u.adicCompletionIntegers :=
+  Iff.rfl
+
+theorem adicIntegersKSubmod_le_poleWindowKSubmod (πh : u.adicCompletionIntegers) (M : ℕ) :
+    adicIntegersKSubmod u ≤ poleWindowKSubmod u πh M :=
+  fun _ hx => mul_mem (pow_mem πh.2 M) hx
+
+theorem kwF4gRRTate_clearPole (πh : u.adicCompletionIntegers) (hπh : Irreducible πh)
+    (fh : u.adicCompletion) :
+    ∃ M : ℕ, (πh : u.adicCompletion) ^ M * fh ∈ u.adicCompletionIntegers := by
+  obtain ⟨a, b, hb, hfh⟩ := IsFractionRing.div_surjective
+    (A := u.adicCompletionIntegers) (K := u.adicCompletion) fh
+  have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb
+  obtain ⟨M, ub, hbeq⟩ := IsDiscreteValuationRing.eq_unit_mul_pow_irreducible hb0 hπh
+  refine ⟨M, ?_⟩
+  have hcoe : ∀ x : u.adicCompletionIntegers,
+      (x : u.adicCompletion) = algebraMap _ u.adicCompletion x := fun _ => rfl
+  have hbK0 : (b : u.adicCompletion) ≠ 0 := by
+    rw [hcoe]; exact (map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr hb0
+  have hbfh : (b : u.adicCompletion) * fh = (a : u.adicCompletion) := by
+    rw [← hfh, hcoe b, hcoe a, mul_div_cancel₀ _ (hcoe b ▸ hbK0)]
+  have hπheq : ((ub⁻¹ : u.adicCompletionIntegersˣ) : u.adicCompletionIntegers) * b = πh ^ M := by
+    rw [hbeq, ← mul_assoc, ← Units.val_mul, inv_mul_cancel, Units.val_one, one_mul]
+  have hπheqK : ((((ub⁻¹ : u.adicCompletionIntegersˣ) : u.adicCompletionIntegers)
+        : u.adicCompletion)) * (b : u.adicCompletion)
+      = (πh : u.adicCompletion) ^ M := by
+    have := congrArg (algebraMap u.adicCompletionIntegers u.adicCompletion) hπheq
+    simp only [map_mul, map_pow] at this
+    exact this
+  rw [← hπheqK, mul_assoc, hbfh]
+  exact mul_mem (Subtype.coe_prop _) a.2
+
+variable (K L) in
+def KwF4gRRTatePoleWindowFinite : Prop :=
+  ∀ (u : Place K L) [u.FiniteResidue] (πh : u.adicCompletionIntegers) (_ : Irreducible πh)
+    (M : ℕ),
+    FiniteDimensional K
+      (poleWindowKSubmod u πh M ⧸
+        (adicIntegersKSubmod u).comap (poleWindowKSubmod u πh M).subtype)
+
+end PoleWindow
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open_scoped "WithZero P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.WithZero \
+  Multiplicative P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Multiplicative Topology \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Topology"
+p2m_open "Filter P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Filter"
+
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "HeightOneSpectrum.adicCompletionIntegers \
+  HeightOneSpectrum.adicCompletionIntegers.integers HeightOneSpectrum.ext mk HeightOneSpectrum"
+namespace HeightOneSpectrum
+p2m_export "IsDedekindDomain.HeightOneSpectrum" "valuation_of_algebraMap \
+  intValuation_le_pow_iff_mem isMaximal mk comap valuedAdicCompletion_eq_valuation' adicCompletion \
+  valuation adicCompletionIntegers valuedAdicCompletion_surjective adicCompletionIntegers.integers \
+  mem_integers_of_valuation_le_one denseRange_algebraMap intValuation completionIdeal \
+  adicCompletion.mem_completionIdeal_pow"
+p2m_open "IsDedekindDomain.HeightOneSpectrum IsDedekindDomain"
+
+variable {A : Type*} (K : Type*) [CommRing A] [Field K] [Algebra A K] [IsFractionRing A K]
+    [IsDedekindDomain A] (v : HeightOneSpectrum A)
+
+namespace adicCompletion
+p2m_export "IsDedekindDomain.HeightOneSpectrum.adicCompletion" "mem_completionIdeal_pow"
+p2m_open "IsDedekindDomain.HeightOneSpectrum.adicCompletion"
+
+local notation "vK" => (Valued.v : Valuation (v.adicCompletion K) ℤᵐ⁰)
+
+theorem isOpen_setOf_valued_le {γ : ℤᵐ⁰} (hγ : γ ≠ 0) :
+    IsOpen {y : v.adicCompletion K | Valued.v y ≤ γ} := by
+  obtain ⟨z, hz⟩ := valuedAdicCompletion_surjective K v γ
+  have hz0 : vK z ≠ 0 := by rw [hz]; exact hγ
+  have hr0 : (vK).restrict z ≠ 0 := fun h =>
+    hz0 ((Valuation.restrict_eq_zero_iff vK).mp h)
+  have hset : {y : v.adicCompletion K | Valued.v y ≤ γ}
+      = {y : v.adicCompletion K | (vK).restrict y ≤ (vK).restrict z} := by
+    ext y
+    simp only [Set.mem_ofPred_eq, Valuation.restrict_le_iff, hz]
+  rw [hset]
+  exact Valued.isOpen_closedBall _ hr0
+
+end adicCompletion
+end IsDedekindDomain.HeightOneSpectrum
+end
+
+section
+
+
+noncomputable section
+
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain.HeightOneSpectrum \
+  IsLocalRing P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsLocalRing WithZero \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.WithZero"
+p2m_open "P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.Lg37 AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4R1V410a
+p2m_open "ModularCurve"
+
+scoped instance kwF4R1V410a_subsingletonHeightOneSpectrumDVR
+    {O : Type*} [CommRing O] [IsDomain O] [IsDiscreteValuationRing O] :
+    Subsingleton (HeightOneSpectrum O) :=
+  ⟨fun a b => IsDedekindDomain.HeightOneSpectrum.ext
+    (((IsDiscreteValuationRing.iff_pid_with_one_nonzero_prime O).mp
+      inferInstance).2.unique ⟨a.3, a.2⟩ ⟨b.3, b.2⟩)⟩
+
+section Bridge
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+local notation "O_w" => w.toValuationSubring
+local notation "𝔪_w" => IsLocalRing.maximalIdeal w.toValuationSubring
+local notation "O_W" => w.adicCompletionIntegers
+local notation "𝔪_W" => w.heightOneSpectrum.completionIdeal F
+
+theorem kwF4R1V410a_algebraMap_mem_completionIdeal_pow_iff (n : ℕ) (x : O_w) :
+    algebraMap (O_w) (O_W) x ∈ (𝔪_W) ^ n ↔ x ∈ (𝔪_w) ^ n := by
+  have hval : Valued.v (algebraMap (O_w) (O_W) x).val
+      = w.heightOneSpectrum.intValuation x := by
+    have h1 : (algebraMap (O_w) (O_W) x).val
+        = ((algebraMap (O_w) F x : F) : w.adicCompletion) := rfl
+    rw [h1, valuedAdicCompletion_eq_valuation' (K := F) w.heightOneSpectrum,
+      valuation_of_algebraMap]
+  rw [adicCompletion.mem_completionIdeal_pow, hval, ← WithZero.exp_eq_coe_ofAdd,
+    intValuation_le_pow_iff_mem, w.heightOneSpectrum_asIdeal]
+
+theorem kwF4R1V410a_exists_sub_mem_completionIdeal_pow (n : ℕ) (y : O_W) :
+    ∃ x : O_w, y - algebraMap (O_w) (O_W) x ∈ (𝔪_W) ^ n := by
+  have hball_open : IsOpen {z : w.adicCompletion |
+      Valued.v (z - y.val) ≤ WithZero.exp (-(n : ℤ))} :=
+    (adicCompletion.isOpen_setOf_valued_le F w.heightOneSpectrum
+      WithZero.exp_ne_zero).preimage (continuous_sub_right y.val)
+  have hy_mem : y.val ∈ {z : w.adicCompletion |
+      Valued.v (z - y.val) ≤ WithZero.exp (-(n : ℤ))} := by
+    simp only [Set.mem_ofPred_eq, sub_self, _root_.map_zero]; exact zero_le
+  have hmeet := mem_closure_iff.mp
+    ((denseRange_algebraMap F w.heightOneSpectrum) y.val) _ hball_open hy_mem
+  have hexists : ∃ z : F, Valued.v (algebraMap F w.adicCompletion z - y.val)
+      ≤ WithZero.exp (-(n : ℤ)) := by
+    rcases hmeet with ⟨z₀, hz₀_ball, z, hz_eq⟩
+    exact ⟨z, hz_eq ▸ hz₀_ball⟩
+  obtain ⟨z, hz⟩ := hexists
+  rw [show algebraMap F w.adicCompletion z = ((z : F) : w.adicCompletion) from rfl] at hz
+  have hz_val_le : w.heightOneSpectrum.valuation F z ≤ 1 := by
+    have hzhat : Valued.v ((z : w.adicCompletion)) ≤ (1 : ℤᵐ⁰) := by
+      calc Valued.v ((z : w.adicCompletion))
+          = Valued.v (((z : w.adicCompletion) - y.val) + y.val) := by ring_nf
+        _ ≤ max (Valued.v ((z : w.adicCompletion) - y.val)) (Valued.v y.val) :=
+            Valuation.map_add _ _ _
+        _ ≤ (1 : ℤᵐ⁰) := max_le
+            (hz.trans (by rw [← WithZero.exp_zero]; exact WithZero.exp_le_exp.mpr (by omega)))
+            y.2
+    rwa [valuedAdicCompletion_eq_valuation'] at hzhat
+  have hz_mem : z ∈ (O_w : ValuationSubring F) := by
+    obtain ⟨r, hr⟩ := mem_integers_of_valuation_le_one F z
+      (fun v' => by
+        obtain rfl : v' = w.heightOneSpectrum := Subsingleton.elim _ _
+        exact hz_val_le)
+    exact hr ▸ r.2
+  refine ⟨⟨z, hz_mem⟩, ?_⟩
+  rw [adicCompletion.mem_completionIdeal_pow, ← WithZero.exp_eq_coe_ofAdd]
+  have hsub : (y - algebraMap (O_w) (O_W) ⟨z, hz_mem⟩ : O_W).val
+      = y.val - ((z : F) : w.adicCompletion) := rfl
+  rw [hsub, Valuation.map_sub_swap]
+  exact hz
+
+def kwF4R1V410a_quotientEquiv (n : ℕ) :
+    (O_w) ⧸ (𝔪_w) ^ n ≃+* (O_W) ⧸ (𝔪_W) ^ n :=
+  RingEquiv.ofBijective
+    (Ideal.quotientMap _ (algebraMap (O_w) (O_W))
+      (fun x hx => (kwF4R1V410a_algebraMap_mem_completionIdeal_pow_iff w n x).mpr hx))
+    ⟨Ideal.quotientMap_injective'
+      (fun x hx => (kwF4R1V410a_algebraMap_mem_completionIdeal_pow_iff w n x).mp
+        (Ideal.mem_comap.mp hx)),
+    fun y => by
+      obtain ⟨y', rfl⟩ := Ideal.Quotient.mk_surjective y
+      obtain ⟨x, hx⟩ := kwF4R1V410a_exists_sub_mem_completionIdeal_pow w n y'
+      refine ⟨Ideal.Quotient.mk _ x, ?_⟩
+      rw [Ideal.quotientMap_mk]
+      exact (Ideal.Quotient.mk_eq_mk_iff_sub_mem _ _).mpr (by
+        rw [← neg_sub, neg_mem_iff]; exact hx)⟩
+
+theorem kwF4R1V410a_quotientEquiv_mk (n : ℕ) (x : O_w) :
+    kwF4R1V410a_quotientEquiv w n (Ideal.Quotient.mk _ x)
+      = Ideal.Quotient.mk _ (algebraMap (O_w) (O_W) x) := rfl
+
+end Bridge
+end ModularCurve.KwF4R1V410a
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  LinearMap P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4R1V410a"
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain.HeightOneSpectrum \
+  IsLocalRing P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsLocalRing"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateTraceCompat"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section PoleWindowShift
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem coe_smul_K (c : K) (x : u.adicCompletionIntegers) :
+    ((c • x : u.adicCompletionIntegers) : u.adicCompletion) = c • (x : u.adicCompletion) := by
+  rw [Algebra.smul_def, Algebra.smul_def]
+  rfl
+
+def poleWindowShift (πh : u.adicCompletionIntegers) (M : ℕ) :
+    poleWindowKSubmod u πh M →ₗ[K] u.adicCompletionIntegers where
+  toFun x := ⟨(πh : u.adicCompletion) ^ M * (x : u.adicCompletion), x.2⟩
+  map_add' x y := by apply Subtype.ext; push_cast; ring
+  map_smul' c x := by
+    apply Subtype.ext
+    rw [coe_smul_K]
+    change (πh : u.adicCompletion) ^ M * (c • (x : u.adicCompletion))
+        = c • ((πh : u.adicCompletion) ^ M * (x : u.adicCompletion))
+    rw [mul_smul_comm]
+
+theorem poleWindowShift_injective (πh : u.adicCompletionIntegers) (hπh : Irreducible πh)
+    (M : ℕ) : Function.Injective (poleWindowShift u πh M) := by
+  rw [← LinearMap.ker_eq_bot, eq_bot_iff]
+  intro x hx
+  rw [LinearMap.mem_ker] at hx
+  have hπhM0 : (πh : u.adicCompletion) ^ M ≠ 0 := by
+    refine pow_ne_zero M ?_
+    intro hz
+    exact hπh.ne_zero (Subtype.ext hz)
+  have hx0 : (x : u.adicCompletion) = 0 := by
+    have := congrArg Subtype.val hx
+    push_cast at this
+    exact (mul_eq_zero.mp this).resolve_left hπhM0
+  exact Subtype.ext hx0
+
+theorem poleWindowShift_surjective (πh : u.adicCompletionIntegers) (hπh : Irreducible πh)
+    (M : ℕ) : Function.Surjective (poleWindowShift u πh M) := by
+  intro y
+  have hπhM0 : (πh : u.adicCompletion) ^ M ≠ 0 := by
+    refine pow_ne_zero M ?_
+    intro hz; exact hπh.ne_zero (Subtype.ext hz)
+  refine ⟨⟨(y : u.adicCompletion) / (πh : u.adicCompletion) ^ M, ?_⟩, ?_⟩
+  · rw [mem_poleWindowKSubmod_iff, mul_div_cancel₀ _ hπhM0]; exact y.2
+  · apply Subtype.ext
+    change (πh : u.adicCompletion) ^ M * ((y : u.adicCompletion) / (πh : u.adicCompletion) ^ M)
+        = (y : u.adicCompletion)
+    rw [mul_div_cancel₀ _ hπhM0]
+
+def poleWindowShiftEquiv (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) (M : ℕ) :
+    poleWindowKSubmod u πh M ≃ₗ[K] u.adicCompletionIntegers :=
+  LinearEquiv.ofBijective (poleWindowShift u πh M)
+    ⟨poleWindowShift_injective u πh hπh M, poleWindowShift_surjective u πh hπh M⟩
+
+def piPowKSubmod (πh : u.adicCompletionIntegers) (M : ℕ) :
+    Submodule K u.adicCompletionIntegers where
+  carrier := {y | ∃ x : u.adicCompletionIntegers, y = πh ^ M * x}
+  add_mem' := by rintro a b ⟨xa, rfl⟩ ⟨xb, rfl⟩; exact ⟨xa + xb, by ring⟩
+  zero_mem' := ⟨0, by ring⟩
+  smul_mem' c y := by
+    rintro ⟨x, rfl⟩
+    exact ⟨c • x, by rw [Algebra.smul_def, Algebra.smul_def, mul_left_comm]⟩
+
+theorem poleWindowShift_image_integers (πh : u.adicCompletionIntegers) (M : ℕ) :
+    Submodule.map (poleWindowShift u πh M)
+        ((adicIntegersKSubmod u).comap (poleWindowKSubmod u πh M).subtype)
+      = piPowKSubmod u πh M := by
+  ext y
+  constructor
+  · rintro ⟨⟨x, hxP⟩, hxA, rfl⟩
+    refine ⟨⟨(x : u.adicCompletion), hxA⟩, ?_⟩
+    apply Subtype.ext; push_cast; rfl
+  · rintro ⟨x, rfl⟩
+    refine ⟨⟨(x : u.adicCompletion),
+      adicIntegersKSubmod_le_poleWindowKSubmod u πh M x.2⟩, x.2, ?_⟩
+    apply Subtype.ext; push_cast; rfl
+
+variable (K L) in
+def KwF4gRRTateDVRQuotPowKFinite : Prop :=
+  ∀ (u : Place K L) [u.FiniteResidue] (πh : u.adicCompletionIntegers) (_ : Irreducible πh)
+    (M : ℕ),
+    FiniteDimensional K (u.adicCompletionIntegers ⧸ piPowKSubmod u πh M)
+
+theorem kwF4gRRTate_poleWindowFinite_of_DVRQuotPowKFinite
+    (hDVR : KwF4gRRTateDVRQuotPowKFinite K L) :
+    KwF4gRRTatePoleWindowFinite K L := by
+  intro u _ πh hπh M
+  have := hDVR u πh hπh M
+  have e := (poleWindowShiftEquiv u πh hπh M).toLinearMap
+  let e' := Submodule.Quotient.equiv
+    ((adicIntegersKSubmod u).comap (poleWindowKSubmod u πh M).subtype)
+    (piPowKSubmod u πh M)
+    (poleWindowShiftEquiv u πh hπh M)
+    (poleWindowShift_image_integers u πh M)
+  exact FiniteDimensional.of_injective e'.toLinearMap e'.injective
+
+end PoleWindowShift
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  LinearMap P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateTraceCompat"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section AgreementReduce
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem principalPart_mul_zero_of_mem_integers
+    {gh : u.adicCompletion} (hgh : gh ∈ u.adicCompletionIntegers)
+    {a : u.adicCompletion} (ha : a ∈ u.adicCompletionIntegers) :
+    gh * a - tateProj u (gh * a) = 0 := by
+  rw [tateProj_of_mem u (mul_mem hgh ha), sub_self]
+
+theorem tateCommRestrict_single_term
+    {gh : u.adicCompletion} (hgh : gh ∈ u.adicCompletionIntegers)
+    (fh : u.adicCompletion) (a : LinearMap.range (tateProj u)) :
+    (tateCommRestrict (tateProj u) (lmulK u fh) (lmulK u gh) a : u.adicCompletion)
+      = tateProj u (gh * (fh * (a : u.adicCompletion)
+          - tateProj u (fh * (a : u.adicCompletion)))) := by
+  have haInt : (a : u.adicCompletion) ∈ u.adicCompletionIntegers :=
+    (range_tateProj u ▸ a.2 : (a : u.adicCompletion) ∈ adicIntegersKSubmod u)
+  have hcomm : lmulK u fh ∘ₗ lmulK u gh = lmulK u gh ∘ₗ lmulK u fh := by
+    refine LinearMap.ext fun x => ?_; change fh * (gh * x) = gh * (fh * x); ring
+  rw [tateCommRestrict_apply, tateComm_eq_of_commute hcomm]
+  change tateProj u (gh * (fh * ↑a - tateProj u (fh * ↑a)))
+      - tateProj u (fh * (gh * ↑a - tateProj u (gh * ↑a)))
+    = tateProj u (gh * (fh * ↑a - tateProj u (fh * ↑a)))
+  rw [principalPart_mul_zero_of_mem_integers u hgh haInt, mul_zero, _root_.map_zero, sub_zero]
+
+end AgreementReduce
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  LinearMap P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateTraceCompat"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section FinrankTraceCyclicity
+
+variable {K M N : Type*} [Field K] [AddCommGroup M] [Module K M] [AddCommGroup N] [Module K N]
+
+theorem range_comp_map_left (f : M →ₗ[K] N) (g : N →ₗ[K] M) :
+    ∀ x ∈ LinearMap.range (g ∘ₗ f), f x ∈ LinearMap.range (f ∘ₗ g) := by
+  rintro x ⟨y, rfl⟩
+  exact ⟨f y, rfl⟩
+
+theorem finrankTrace_comp_comm (f : M →ₗ[K] N) (g : N →ₗ[K] M)
+    [FiniteDimensional K (LinearMap.range (g ∘ₗ f))]
+    [FiniteDimensional K (LinearMap.range (f ∘ₗ g))] :
+    finrankTrace (g ∘ₗ f) = finrankTrace (f ∘ₗ g) := by
+  set W := LinearMap.range (g ∘ₗ f)
+  set W' := LinearMap.range (f ∘ₗ g)
+  let fR : W →ₗ[K] W' := f.restrict (range_comp_map_left f g)
+  let gR : W' →ₗ[K] W := g.restrict (range_comp_map_left g f)
+  have hgf : (g ∘ₗ f).restrict (fun x _ => LinearMap.mem_range_self _ x) = gR ∘ₗ fR := by
+    apply LinearMap.ext; intro x; apply Subtype.ext; rfl
+  have hfg : (f ∘ₗ g).restrict (fun x _ => LinearMap.mem_range_self _ x) = fR ∘ₗ gR := by
+    apply LinearMap.ext; intro x; apply Subtype.ext; rfl
+  unfold finrankTrace
+  rw [hgf, hfg, LinearMap.trace_comp_comm']
+
+end FinrankTraceCyclicity
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  LinearMap P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateTraceCompat"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section DeltaLemmas
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+variable (pA pA' : V →ₗ[K] V)
+
+structure SameRangeIdemProjectors : Prop where
+  idem_pA : ∀ x, pA (pA x) = pA x
+  idem_pA' : ∀ x, pA' (pA' x) = pA' x
+  range_eq : LinearMap.range pA = LinearMap.range pA'
+
+variable {pA pA'}
+
+theorem pA_fixes_range (h : SameRangeIdemProjectors pA pA') :
+    ∀ x ∈ LinearMap.range pA, pA x = x := by
+  rintro x ⟨y, rfl⟩; exact h.idem_pA y
+
+theorem pA'_fixes_range (h : SameRangeIdemProjectors pA pA') :
+    ∀ x ∈ LinearMap.range pA, pA' x = x := by
+  rintro x hx
+  rw [h.range_eq] at hx
+  obtain ⟨y, rfl⟩ := hx
+  exact h.idem_pA' y
+
+theorem delta_zero_on_range (h : SameRangeIdemProjectors pA pA')
+    {x : V} (hx : x ∈ LinearMap.range pA) :
+    (pA - pA') x = 0 := by
+  simp only [LinearMap.sub_apply, pA_fixes_range h x hx, pA'_fixes_range h x hx, sub_self]
+
+theorem delta_range_subset (h : SameRangeIdemProjectors pA pA')
+    (x : V) : (pA - pA') x ∈ LinearMap.range pA := by
+  simp only [LinearMap.sub_apply]
+  refine sub_mem (LinearMap.mem_range_self pA x) ?_
+  rw [h.range_eq]; exact LinearMap.mem_range_self pA' x
+
+end DeltaLemmas
+
+section Mint
+
+variable (K L : Type*) [Field K] [Field L] [Algebra K L]
+
+def KwF4gRRTateProjectorIndep : Prop :=
+  ∀ (u : Place K L) (pA' : u.adicCompletion →ₗ[K] u.adicCompletion),
+    SameRangeIdemProjectors (tateProj u) pA' →
+    ∀ (fh gh : u.adicCompletion), gh ∈ u.adicCompletionIntegers →
+    ∀ [FiniteDimensional K (LinearMap.range
+        (tateCommRestrict (tateProj u) (lmulK u fh) (lmulK u gh)))]
+      [FiniteDimensional K (LinearMap.range
+        (tateCommRestrict pA' (lmulK u fh) (lmulK u gh)))],
+    tateCommTrace (tateProj u) (lmulK u fh) (lmulK u gh)
+      = tateCommTrace pA' (lmulK u fh) (lmulK u gh)
+
+end Mint
+
+section DiffComputation
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable (pA' : u.adicCompletion →ₗ[K] u.adicCompletion)
+
+theorem tateCommRestrict_diff
+    (h : SameRangeIdemProjectors (tateProj u) pA')
+    {gh : u.adicCompletion} (hgh : gh ∈ u.adicCompletionIntegers)
+    (fh : u.adicCompletion) (a : LinearMap.range (tateProj u)) :
+    (tateCommRestrict (tateProj u) (lmulK u fh) (lmulK u gh) a : u.adicCompletion)
+      - tateComm pA' (lmulK u fh) (lmulK u gh) (a : u.adicCompletion)
+      = (tateProj u - pA') (gh * fh * (a : u.adicCompletion))
+        - gh * (tateProj u - pA') (fh * (a : u.adicCompletion)) := by
+  have haO : (a : u.adicCompletion) ∈ u.adicCompletionIntegers :=
+    (range_tateProj u ▸ a.2 : (a : u.adicCompletion) ∈ adicIntegersKSubmod u)
+  have hmemO_of_rangeP : ∀ {x : u.adicCompletion},
+      x ∈ LinearMap.range (tateProj u) → x ∈ u.adicCompletionIntegers := fun {x} hx =>
+    (range_tateProj u ▸ hx : x ∈ adicIntegersKSubmod u)
+  have hmemP_of_O : ∀ {x : u.adicCompletion},
+      x ∈ u.adicCompletionIntegers → x ∈ LinearMap.range (tateProj u) := fun {x} hx => by
+    rw [range_tateProj u]; exact hx
+  rw [tateCommRestrict_single_term u hgh fh a]
+  have hcomm : lmulK u fh ∘ₗ lmulK u gh = lmulK u gh ∘ₗ lmulK u fh := by
+    refine LinearMap.ext fun x => ?_; change fh * (gh * x) = gh * (fh * x); ring
+  have hghaP : gh * (a : u.adicCompletion) ∈ LinearMap.range (tateProj u) :=
+    hmemP_of_O (mul_mem hgh haO)
+  have hpA'_gha : pA' (gh * (a : u.adicCompletion)) = gh * (a : u.adicCompletion) :=
+    pA'_fixes_range h _ hghaP
+  have hpA'_single :
+      tateComm pA' (lmulK u fh) (lmulK u gh) (a : u.adicCompletion)
+      = pA' (gh * (fh * (a : u.adicCompletion)
+          - pA' (fh * (a : u.adicCompletion)))) := by
+    rw [tateComm_eq_of_commute hcomm]
+    change pA' (gh * (fh * ↑a - pA' (fh * ↑a)))
+        - pA' (fh * (gh * ↑a - pA' (gh * ↑a)))
+      = pA' (gh * (fh * ↑a - pA' (fh * ↑a)))
+    rw [hpA'_gha, sub_self, mul_zero, _root_.map_zero, sub_zero]
+  rw [hpA'_single]
+  set fa := fh * (a : u.adicCompletion)
+  have hPfaO : tateProj u fa ∈ u.adicCompletionIntegers :=
+    hmemO_of_rangeP (LinearMap.mem_range_self (tateProj u) fa)
+  have hPfaO' : pA' fa ∈ u.adicCompletionIntegers :=
+    hmemO_of_rangeP (h.range_eq ▸ LinearMap.mem_range_self pA' fa)
+  have hghPfa : tateProj u (gh * tateProj u fa) = gh * tateProj u fa :=
+    tateProj_of_mem u (mul_mem hgh hPfaO)
+  have hghPfa' : pA' (gh * pA' fa) = gh * pA' fa :=
+    pA'_fixes_range h _ (hmemP_of_O (mul_mem hgh hPfaO'))
+  rw [mul_sub, map_sub, mul_sub, map_sub, hghPfa, hghPfa']
+  simp only [LinearMap.sub_apply]
+  rw [show gh * fh * (a : u.adicCompletion) = gh * fa from (mul_assoc gh fh _).symm ▸ rfl]
+  ring
+
+end DiffComputation
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  LinearMap P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateTraceCompat"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section TraceOnSuperspace
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+theorem finrankTrace_eq_trace_on_superspace
+    (φ : V →ₗ[K] V) (W : Submodule K V) [FiniteDimensional K W]
+    (hrange : LinearMap.range φ ≤ W) (hW : ∀ x ∈ W, φ x ∈ W) :
+    haveI : FiniteDimensional K (LinearMap.range φ) :=
+      Submodule.finiteDimensional_of_le hrange
+    finrankTrace φ = LinearMap.trace K W (φ.restrict hW) := by
+  have : FiniteDimensional K (LinearMap.range φ) := Submodule.finiteDimensional_of_le hrange
+  let i : LinearMap.range φ →ₗ[K] W := Submodule.inclusion hrange
+  let π : W →ₗ[K] LinearMap.range φ :=
+    { toFun := fun w => ⟨φ (w : V), LinearMap.mem_range_self φ (w : V)⟩
+      map_add' := fun w₁ w₂ => by simp
+      map_smul' := fun c w => by simp }
+  have hip : i ∘ₗ π = φ.restrict hW := by
+    apply LinearMap.ext; intro w; apply Subtype.ext; rfl
+  have hpi : π ∘ₗ i = φ.restrict (fun x _ => LinearMap.mem_range_self φ x) := by
+    apply LinearMap.ext; intro x; apply Subtype.ext; rfl
+  unfold finrankTrace
+  rw [← hpi, ← hip, LinearMap.trace_comp_comm']
+
+end TraceOnSuperspace
+
+section Additivity
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+theorem finrankTrace_sub_eq
+    (φ ψ : V →ₗ[K] V)
+    [FiniteDimensional K (LinearMap.range φ)]
+    [FiniteDimensional K (LinearMap.range ψ)] :
+    haveI : FiniteDimensional K
+        ((LinearMap.range φ ⊔ LinearMap.range ψ : Submodule K V) : Type _) :=
+      Submodule.finiteDimensional_sup _ _
+    finrankTrace φ - finrankTrace ψ
+      = LinearMap.trace K (LinearMap.range φ ⊔ LinearMap.range ψ : Submodule K V)
+          ((φ - ψ).restrict
+            (p := (LinearMap.range φ ⊔ LinearMap.range ψ : Submodule K V))
+            (fun x _ => sub_mem
+              (Submodule.mem_sup_left (LinearMap.mem_range_self φ x))
+              (Submodule.mem_sup_right (LinearMap.mem_range_self ψ x)))) := by
+  set W' : Submodule K V := LinearMap.range φ ⊔ LinearMap.range ψ with hW'
+  have : FiniteDimensional K W' := Submodule.finiteDimensional_sup _ _
+  have hφW : ∀ x ∈ W', φ x ∈ W' := fun x _ =>
+    Submodule.mem_sup_left (LinearMap.mem_range_self φ x)
+  have hψW : ∀ x ∈ W', ψ x ∈ W' := fun x _ =>
+    Submodule.mem_sup_right (LinearMap.mem_range_self ψ x)
+  rw [finrankTrace_eq_trace_on_superspace φ W' le_sup_left hφW,
+    finrankTrace_eq_trace_on_superspace ψ W' le_sup_right hψW,
+    ← map_sub]
+  refine congrArg (LinearMap.trace K W') (LinearMap.ext fun x => Subtype.ext ?_)
+  rfl
+
+end Additivity
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  LinearMap P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4gRRTate"
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain.HeightOneSpectrum \
+  IsLocalRing P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsLocalRing"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateTraceCompat"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section DVRQuotDischarge
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem piPowKSubmod_eq_restrictScalars (πh : u.adicCompletionIntegers) (M : ℕ) :
+    piPowKSubmod u πh M
+      = (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers).restrictScalars K := by
+  ext y
+  rw [Submodule.restrictScalars_mem, Ideal.mem_span_singleton]
+  exact ⟨fun ⟨x, h⟩ => ⟨x, h⟩, fun ⟨x, h⟩ => ⟨x, h⟩⟩
+
+def quotPiPowEquivIdealQuot (πh : u.adicCompletionIntegers) (M : ℕ) :
+    (u.adicCompletionIntegers ⧸ piPowKSubmod u πh M)
+      ≃ₗ[K] (u.adicCompletionIntegers ⧸ (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers)) :=
+  (Submodule.quotEquivOfEq _ _ (piPowKSubmod_eq_restrictScalars u πh M)).trans
+    (Submodule.Quotient.restrictScalarsEquiv K _)
+
+variable (K L) in
+def KwF4gRRTateDVRCotangentKFinite : Prop :=
+  ∀ (u : Place K L) [u.FiniteResidue] (πh : u.adicCompletionIntegers) (_ : Irreducible πh),
+    FiniteDimensional K
+      (u.adicCompletionIntegers ⧸ (Ideal.span {πh} : Ideal u.adicCompletionIntegers))
+
+theorem range_mulLeft_eq_restrictScalars_span (a : u.adicCompletionIntegers) :
+    LinearMap.range (LinearMap.mulLeft K a)
+      = (Ideal.span {a} : Ideal u.adicCompletionIntegers).restrictScalars K := by
+  ext y
+  simp only [LinearMap.mem_range, LinearMap.mulLeft_apply, Submodule.restrictScalars_mem,
+    Ideal.mem_span_singleton]
+  exact ⟨fun ⟨x, hx⟩ => ⟨x, hx.symm⟩, fun ⟨x, hx⟩ => ⟨x, hx.symm⟩⟩
+
+
+theorem finiteDimensional_restrictScalarsQuot_pow [u.FiniteResidue]
+    (hCot : KwF4gRRTateDVRCotangentKFinite K L)
+    (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) (M : ℕ) :
+    FiniteDimensional K (u.adicCompletionIntegers ⧸
+      (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers).restrictScalars K) := by
+  induction M with
+  | zero =>
+    rw [pow_zero, Ideal.span_singleton_one, Submodule.restrictScalars_top]
+    infer_instance
+  | succ M ih =>
+    have hle : (Ideal.span {πh ^ (M+1)} : Ideal u.adicCompletionIntegers)
+        ≤ Ideal.span {πh ^ M} := by
+      rw [Ideal.span_singleton_le_span_singleton, pow_succ]; exact ⟨πh, rfl⟩
+    have hle' : (Ideal.span {πh ^ (M+1)} : Ideal u.adicCompletionIntegers).restrictScalars K
+        ≤ (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers).restrictScalars K :=
+      Submodule.restrictScalars_mono K hle
+    set N : Submodule K (u.adicCompletionIntegers ⧸
+        (Ideal.span {πh ^ (M+1)} : Ideal u.adicCompletionIntegers).restrictScalars K) :=
+      (Submodule.restrictScalars K (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers)).map
+        (Submodule.restrictScalars K (Ideal.span {πh ^ (M+1)} : Ideal _)).mkQ with hN_def
+    have hquot : FiniteDimensional K
+        ((u.adicCompletionIntegers ⧸
+          (Ideal.span {πh ^ (M+1)} : Ideal _).restrictScalars K) ⧸ N) := by
+      have := ih
+      exact Module.Finite.equiv
+        (Submodule.quotientQuotientEquivQuotient _ _ hle').symm
+    have hN : FiniteDimensional K N := by
+      set φ : u.adicCompletionIntegers →ₗ[K] (u.adicCompletionIntegers ⧸
+          (Ideal.span {πh ^ (M+1)} : Ideal u.adicCompletionIntegers).restrictScalars K) :=
+        (Submodule.restrictScalars K
+            (Ideal.span {πh ^ (M+1)} : Ideal u.adicCompletionIntegers)).mkQ ∘ₗ
+          LinearMap.mulLeft K (πh ^ M) with hφ_def
+      have hrange : LinearMap.range φ = N := by
+        rw [hφ_def, LinearMap.range_comp, range_mulLeft_eq_restrictScalars_span, hN_def]
+      have hker : LinearMap.ker φ
+          = (Ideal.span {πh} : Ideal u.adicCompletionIntegers).restrictScalars K := by
+        simp only [hφ_def, LinearMap.ker_comp, Submodule.ker_mkQ]
+        ext x
+        simp only [Submodule.mem_comap, LinearMap.mulLeft_apply, Submodule.restrictScalars_mem,
+          Ideal.mem_span_singleton]
+        have hπM : (πh : u.adicCompletionIntegers) ^ M ≠ 0 := pow_ne_zero M hπh.ne_zero
+        constructor
+        · rintro ⟨c, hc⟩
+          exact ⟨c, mul_left_cancel₀ hπM (by rw [hc, pow_succ, mul_assoc])⟩
+        · rintro ⟨c, hc⟩
+          exact ⟨c, by rw [hc, pow_succ, mul_assoc]⟩
+      let e₁ : (u.adicCompletionIntegers ⧸
+            (Ideal.span {πh} : Ideal u.adicCompletionIntegers).restrictScalars K)
+          ≃ₗ[K] (u.adicCompletionIntegers ⧸ LinearMap.ker φ) :=
+        Submodule.quotEquivOfEq _ _ hker.symm
+      let e₂ : (u.adicCompletionIntegers ⧸ LinearMap.ker φ) ≃ₗ[K] LinearMap.range φ :=
+        φ.quotKerEquivRange
+      let e₃ : (LinearMap.range φ : Submodule K _) ≃ₗ[K] N := LinearEquiv.ofEq _ _ hrange
+      have hCK : FiniteDimensional K (u.adicCompletionIntegers ⧸
+          (Ideal.span {πh} : Ideal u.adicCompletionIntegers).restrictScalars K) := by
+        have := hCot u πh hπh
+        exact Module.Finite.equiv
+          (Submodule.Quotient.restrictScalarsEquiv K
+            (Ideal.span {πh} : Ideal u.adicCompletionIntegers)).symm
+      exact Module.Finite.equiv ((e₁.trans e₂).trans e₃)
+    exact Module.Finite.of_submodule_quotient N
+
+theorem finiteDimensional_idealQuot_pow [u.FiniteResidue]
+    (hCot : KwF4gRRTateDVRCotangentKFinite K L)
+    (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) (M : ℕ) :
+    FiniteDimensional K
+      (u.adicCompletionIntegers ⧸ (Ideal.span {πh ^ M} : Ideal u.adicCompletionIntegers)) := by
+  have := finiteDimensional_restrictScalarsQuot_pow u hCot πh hπh M
+  exact Module.Finite.equiv (Submodule.Quotient.restrictScalarsEquiv K _)
+
+theorem kwF4gRRTate_DVRQuotPowKFinite_of_cotangent
+    (hCot : KwF4gRRTateDVRCotangentKFinite K L) :
+    KwF4gRRTateDVRQuotPowKFinite K L := by
+  intro u _ πh hπh M
+  have := finiteDimensional_idealQuot_pow u hCot πh hπh M
+  exact Module.Finite.equiv (quotPiPowEquivIdealQuot u πh M).symm
+
+end DVRQuotDischarge
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  LinearMap P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4R1V410a"
+p2m_open "IsDedekindDomain P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain \
+  IsDedekindDomain.HeightOneSpectrum \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain.HeightOneSpectrum \
+  IsLocalRing P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsLocalRing"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateTraceCompat"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section DVRCotangentDischarge
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+scoped instance instIsScalarTower_K_toValuationSubring_adicCompletionIntegers :
+    IsScalarTower K u.toValuationSubring u.adicCompletionIntegers := by
+  refine IsScalarTower.of_algebraMap_eq fun k => ?_
+  apply Subtype.ext
+  change algebraMap K u.adicCompletion k
+    = (algebraMap u.toValuationSubring u.adicCompletionIntegers (algebraMap K _ k)).val
+  rw [IsScalarTower.algebraMap_apply K L u.adicCompletion]
+  rfl
+
+theorem span_irreducible_eq_completionIdeal_pow_one
+    (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) :
+    (Ideal.span {πh} : Ideal u.adicCompletionIntegers)
+      = (u.heightOneSpectrum.completionIdeal L) ^ 1 := by
+  rw [pow_one, ← hπh.maximalIdeal_eq]
+
+def quotientEquivKAlg (n : ℕ) :
+    (u.toValuationSubring ⧸ (IsLocalRing.maximalIdeal u.toValuationSubring) ^ n)
+      ≃ₐ[K] (u.adicCompletionIntegers ⧸ (u.heightOneSpectrum.completionIdeal L) ^ n) :=
+  { kwF4R1V410a_quotientEquiv u n with
+    commutes' := fun k => by
+      change kwF4R1V410a_quotientEquiv u n (algebraMap K _ k) = algebraMap K _ k
+      rw [IsScalarTower.algebraMap_apply K u.toValuationSubring
+          (u.toValuationSubring ⧸ (IsLocalRing.maximalIdeal u.toValuationSubring) ^ n),
+        Ideal.Quotient.algebraMap_eq, kwF4R1V410a_quotientEquiv_mk,
+        IsScalarTower.algebraMap_apply K u.adicCompletionIntegers
+          (u.adicCompletionIntegers ⧸ (u.heightOneSpectrum.completionIdeal L) ^ n),
+        Ideal.Quotient.algebraMap_eq,
+        IsScalarTower.algebraMap_apply K u.toValuationSubring u.adicCompletionIntegers] }
+
+def quotSpanIrreducibleEquivResidueField (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) :
+    (u.adicCompletionIntegers ⧸ (Ideal.span {πh} : Ideal u.adicCompletionIntegers))
+      ≃ₗ[K] u.ResidueField :=
+  (Ideal.quotientEquivAlgOfEq K
+      (span_irreducible_eq_completionIdeal_pow_one u πh hπh)).toLinearEquiv.trans
+    ((quotientEquivKAlg u 1).symm.toLinearEquiv.trans
+      (Ideal.quotientEquivAlgOfEq K
+        (pow_one (IsLocalRing.maximalIdeal u.toValuationSubring))).toLinearEquiv)
+
+theorem kwF4gRRTate_DVRCotangentKFinite : KwF4gRRTateDVRCotangentKFinite K L := by
+  intro u _ πh hπh
+  have : Module.Finite K u.ResidueField := FiniteResidue.finite
+  exact Module.Finite.equiv (quotSpanIrreducibleEquivResidueField u πh hπh).symm
+
+end DVRCotangentDischarge
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  LinearMap P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateTraceCompat"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section DeltaQuotFactor
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+variable {pA pA' : V →ₗ[K] V}
+
+def deltaQuotFactor (h : SameRangeIdemProjectors pA pA') :
+    (V ⧸ LinearMap.range pA) →ₗ[K] LinearMap.range pA :=
+  (LinearMap.range pA).liftQ
+    (LinearMap.codRestrict (LinearMap.range pA) (pA - pA') (delta_range_subset h))
+    (fun x hx => by
+      apply Subtype.ext
+      exact delta_zero_on_range h hx)
+
+theorem deltaQuotFactor_apply (h : SameRangeIdemProjectors pA pA') (x : V) :
+    (deltaQuotFactor h (Submodule.Quotient.mk x) : V) = (pA - pA') x := rfl
+
+end DeltaQuotFactor
+
+section TermRangeFinite
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable [u.FiniteResidue]
+
+def KwF4gRRTatePoleWindowImageFinite : Prop :=
+  ∀ (fh : u.adicCompletion),
+    FiniteDimensional K (Submodule.map (adicIntegersKSubmod u).mkQ
+      (Submodule.map (lmulK u fh) (adicIntegersKSubmod u)))
+
+end TermRangeFinite
+
+section DiffTraceZero
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable (pA' : u.adicCompletion →ₗ[K] u.adicCompletion)
+
+def KwF4gRRTateCommFiniteGen : Prop :=
+  ∀ (_ : SameRangeIdemProjectors (tateProj u) pA') (fh gh : u.adicCompletion),
+    FiniteDimensional K
+      (LinearMap.range (tateCommRestrict pA' (lmulK u fh) (lmulK u gh)))
+
+end DiffTraceZero
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  LinearMap P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateTraceCompat"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section Composite
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+
+theorem kwF4gRRTate_poleWindowFinite : KwF4gRRTatePoleWindowFinite K L :=
+  kwF4gRRTate_poleWindowFinite_of_DVRQuotPowKFinite
+    (kwF4gRRTate_DVRQuotPowKFinite_of_cotangent
+      kwF4gRRTate_DVRCotangentKFinite)
+
+end Composite
+
+section Subset
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem lmul_adicIntegers_subset_poleWindow (fh : u.adicCompletion)
+    (πh : u.adicCompletionIntegers) (M : ℕ)
+    (hfhM : (πh : u.adicCompletion) ^ M * fh ∈ u.adicCompletionIntegers) :
+    Submodule.map (lmulK u fh) (adicIntegersKSubmod u) ≤ poleWindowKSubmod u πh M := by
+  rintro x ⟨a, ha, rfl⟩
+  rw [mem_poleWindowKSubmod_iff]
+  show (πh : u.adicCompletion) ^ M * (lmulK u fh) a ∈ u.adicCompletionIntegers
+  have : (lmulK u fh) a = fh * a := rfl
+  rw [this, ← mul_assoc]
+  exact mul_mem hfhM (show a ∈ u.adicCompletionIntegers from ha)
+
+end Subset
+
+section Discharge
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable [u.FiniteResidue]
+
+theorem kwF4gRRTate_poleWindowImageFinite :
+    KwF4gRRTatePoleWindowImageFinite u := by
+  intro fh
+  obtain ⟨πh, hπh⟩ := IsDiscreteValuationRing.exists_irreducible u.adicCompletionIntegers
+  obtain ⟨M, hfhM⟩ := kwF4gRRTate_clearPole u πh hπh fh
+  set A := adicIntegersKSubmod u
+  set P := poleWindowKSubmod u πh M
+  have hsub : Submodule.map A.mkQ (Submodule.map (lmulK u fh) A)
+      ≤ Submodule.map A.mkQ P :=
+    Submodule.map_mono (lmul_adicIntegers_subset_poleWindow u fh πh M hfhM)
+  suffices hPim : FiniteDimensional K (Submodule.map A.mkQ P : Submodule K _) by
+    exact Submodule.finiteDimensional_of_le hsub
+  have : FiniteDimensional K (P ⧸ (A.comap P.subtype)) :=
+    kwF4gRRTate_poleWindowFinite (K := K) (L := L) u πh hπh M
+  let r : P →ₗ[K] (u.adicCompletion ⧸ A) := A.mkQ ∘ₗ P.subtype
+  have hrange : LinearMap.range r = Submodule.map A.mkQ P := by
+    rw [LinearMap.range_comp, Submodule.range_subtype]
+  have hker : LinearMap.ker r = A.comap P.subtype := by
+    rw [LinearMap.ker_comp, Submodule.ker_mkQ]
+  have e : (P ⧸ (A.comap P.subtype)) ≃ₗ[K] LinearMap.range r := hker ▸ r.quotKerEquivRange
+  rw [← hrange]
+  exact e.finiteDimensional
+
+end Discharge
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  LinearMap P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateTraceCompat"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section KerInf
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable (pA' : u.adicCompletion →ₗ[K] u.adicCompletion)
+
+theorem ker_pA'_inf_integers (h : SameRangeIdemProjectors (tateProj u) pA') :
+    LinearMap.ker pA' ⊓ adicIntegersKSubmod u = ⊥ := by
+  rw [eq_bot_iff]
+  intro x hx
+  obtain ⟨hker, hint⟩ := Submodule.mem_inf.mp hx
+  have h0 : pA' x = 0 := LinearMap.mem_ker.mp hker
+  have hxR : x ∈ LinearMap.range (tateProj u) := by rw [range_tateProj u]; exact hint
+  have hpAx : pA' x = x := pA'_fixes_range h x hxR
+  rw [Submodule.mem_bot, ← hpAx, h0]
+
+theorem finiteDimensional_ker_pA'_inf_poleWindow
+    (h : SameRangeIdemProjectors (tateProj u) pA')
+    [u.FiniteResidue] (πh : u.adicCompletionIntegers) (hπh : Irreducible πh) (M : ℕ) :
+    FiniteDimensional K
+      ((LinearMap.ker pA' ⊓ poleWindowKSubmod u πh M : Submodule K _)) := by
+  have := kwF4gRRTate_poleWindowFinite (K := K) (L := L) u πh hπh M
+  set A := adicIntegersKSubmod u
+  set P := poleWindowKSubmod u πh M
+  let A' : Submodule K P := A.comap P.subtype
+  let ι : (LinearMap.ker pA' ⊓ P : Submodule K _) →ₗ[K] P ⧸ A' :=
+    (A'.mkQ).comp (Submodule.inclusion inf_le_right)
+  refine FiniteDimensional.of_injective ι ?_
+  rw [← LinearMap.ker_eq_bot, eq_bot_iff]
+  intro xh hxker
+  obtain ⟨x, hxkp⟩ := xh
+  obtain ⟨hxk, hxp⟩ := Submodule.mem_inf.mp hxkp
+  simp only [ι, LinearMap.mem_ker, LinearMap.comp_apply, Submodule.mkQ_apply,
+    Submodule.Quotient.mk_eq_zero, Submodule.inclusion_apply] at hxker
+  have hxA : x ∈ A := hxker
+  have hx0 : x = 0 := by
+    have hbot : x ∈ (⊥ : Submodule K u.adicCompletion) := by
+      rw [← ker_pA'_inf_integers u pA' h]; exact Submodule.mem_inf.mpr ⟨hxk, hxA⟩
+    exact (Submodule.mem_bot K).mp hbot
+  exact Subtype.ext hx0
+
+end KerInf
+
+section Discharge
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable (pA' : u.adicCompletion →ₗ[K] u.adicCompletion)
+variable [∀ u : Place K L, u.FiniteResidue]
+
+theorem finiteDimensional_principalPart_pA'_range
+    (h : SameRangeIdemProjectors (tateProj u) pA') (fh : u.adicCompletion) :
+    FiniteDimensional K
+      (LinearMap.range
+        ((LinearMap.id - pA') ∘ₗ lmulK u fh ∘ₗ (adicIntegersKSubmod u).subtype)) := by
+  obtain ⟨πh, hπh⟩ := IsDiscreteValuationRing.exists_irreducible u.adicCompletionIntegers
+  obtain ⟨M, hfhM⟩ := kwF4gRRTate_clearPole u πh hπh fh
+  have := finiteDimensional_ker_pA'_inf_poleWindow u pA' h πh hπh M
+  apply Submodule.finiteDimensional_of_le
+    (S₂ := LinearMap.ker pA' ⊓ poleWindowKSubmod u πh M)
+  rintro x ⟨a, rfl⟩
+  refine Submodule.mem_inf.mpr ⟨?_, ?_⟩
+  · rw [LinearMap.mem_ker]
+    simp only [LinearMap.comp_apply, LinearMap.sub_apply, LinearMap.id_apply,
+      Submodule.subtype_apply, map_sub]
+    exact sub_eq_zero.mpr (h.idem_pA' _).symm
+  · simp only [LinearMap.comp_apply, LinearMap.sub_apply, LinearMap.id_apply,
+      Submodule.subtype_apply]
+    refine sub_mem ?_ ?_
+    · exact lmul_adicIntegers_subset_poleWindow u fh πh M hfhM ⟨a, a.2, rfl⟩
+    · refine adicIntegersKSubmod_le_poleWindowKSubmod u πh M ?_
+      have heq : LinearMap.range pA' = adicIntegersKSubmod u := by
+        rw [← h.range_eq, range_tateProj u]
+      exact heq.le (LinearMap.mem_range_self pA' _)
+
+theorem kwF4gRRTate_commFiniteGen :
+    KwF4gRRTateCommFiniteGen u pA' := by
+  intro h fh gh
+  have h3f := finiteDimensional_principalPart_pA'_range u pA' h fh
+  have h3g := finiteDimensional_principalPart_pA'_range u pA' h gh
+  set qf := (LinearMap.id - pA') ∘ₗ lmulK u fh ∘ₗ (adicIntegersKSubmod u).subtype
+  set qg := (LinearMap.id - pA') ∘ₗ lmulK u gh ∘ₗ (adicIntegersKSubmod u).subtype
+  set Wf := LinearMap.range qf
+  set Wg := LinearMap.range qg
+  set S₂ : Submodule K u.adicCompletion :=
+    Submodule.map (pA' ∘ₗ lmulK u gh) Wf ⊔ Submodule.map (pA' ∘ₗ lmulK u fh) Wg with hS₂
+  have : FiniteDimensional K S₂ := by
+    have : FiniteDimensional K (Submodule.map (pA' ∘ₗ lmulK u gh) Wf : Submodule K _) :=
+      inferInstance
+    have : FiniteDimensional K (Submodule.map (pA' ∘ₗ lmulK u fh) Wg : Submodule K _) :=
+      inferInstance
+    exact Submodule.finiteDimensional_sup _ _
+  set R := LinearMap.range (tateCommRestrict pA' (lmulK u fh) (lmulK u gh))
+  suffices himg : Submodule.map (LinearMap.range pA').subtype R ≤ S₂ by
+    have : FiniteDimensional K (Submodule.map (LinearMap.range pA').subtype R) :=
+      Submodule.finiteDimensional_of_le himg
+    exact (Submodule.equivMapOfInjective (LinearMap.range pA').subtype
+        (LinearMap.range pA').injective_subtype R).symm.finiteDimensional
+  rintro x ⟨y, hyR, rfl⟩
+  obtain ⟨a, rfl⟩ := hyR
+  have heq : LinearMap.range pA' = adicIntegersKSubmod u := by
+    rw [← h.range_eq, range_tateProj u]
+  have haO : (a : u.adicCompletion) ∈ adicIntegersKSubmod u := heq.le a.2
+  set aO : adicIntegersKSubmod u := ⟨(a : u.adicCompletion), haO⟩
+  have hcomm : lmulK u fh ∘ₗ lmulK u gh = lmulK u gh ∘ₗ lmulK u fh := by
+    refine LinearMap.ext fun y' => ?_; change fh * (gh * y') = gh * (fh * y'); ring
+  change (tateCommRestrict pA' (lmulK u fh) (lmulK u gh) a : u.adicCompletion) ∈ S₂
+  rw [show (tateCommRestrict pA' (lmulK u fh) (lmulK u gh) a : u.adicCompletion)
+      = tateComm pA' (lmulK u fh) (lmulK u gh) (a : u.adicCompletion) from rfl,
+    tateComm_eq_of_commute hcomm]
+  refine sub_mem (Submodule.mem_sup_left ?_) (Submodule.mem_sup_right ?_)
+  · exact ⟨qf aO, ⟨aO, rfl⟩, rfl⟩
+  · exact ⟨qg aO, ⟨aO, rfl⟩, rfl⟩
+
+end Discharge
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  LinearMap P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateTraceCompat"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section Additivity
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+theorem finrankTrace_congr {φ ψ : V →ₗ[K] V}
+    [hφ : FiniteDimensional K (LinearMap.range φ)]
+    [hψ : FiniteDimensional K (LinearMap.range ψ)]
+    (h : φ = ψ) : finrankTrace φ = finrankTrace ψ := by
+  subst h; rfl
+
+theorem range_sub_le (φ ψ : V →ₗ[K] V) :
+    LinearMap.range (φ - ψ) ≤ LinearMap.range φ ⊔ LinearMap.range ψ := by
+  rintro x ⟨y, rfl⟩
+  exact sub_mem (Submodule.mem_sup_left (mem_range_self φ y))
+    (Submodule.mem_sup_right (mem_range_self ψ y))
+
+scoped instance instFinDimRangeSub (φ ψ : V →ₗ[K] V)
+    [FiniteDimensional K (LinearMap.range φ)]
+    [FiniteDimensional K (LinearMap.range ψ)] :
+    FiniteDimensional K (LinearMap.range (φ - ψ)) :=
+  haveI : FiniteDimensional K
+      ((LinearMap.range φ ⊔ LinearMap.range ψ : Submodule K V) : Type _) :=
+    Submodule.finiteDimensional_sup _ _
+  Submodule.finiteDimensional_of_le (range_sub_le φ ψ)
+
+theorem finrankTrace_sub (φ ψ : V →ₗ[K] V)
+    [FiniteDimensional K (LinearMap.range φ)]
+    [FiniteDimensional K (LinearMap.range ψ)] :
+    finrankTrace φ - finrankTrace ψ = finrankTrace (φ - ψ) := by
+  set W' : Submodule K V := LinearMap.range φ ⊔ LinearMap.range ψ
+  have : FiniteDimensional K W' := Submodule.finiteDimensional_sup _ _
+  have hφψW : ∀ x ∈ W', (φ - ψ) x ∈ W' := fun x _ =>
+    sub_mem (Submodule.mem_sup_left (mem_range_self φ x))
+      (Submodule.mem_sup_right (mem_range_self ψ x))
+  rw [finrankTrace_sub_eq φ ψ,
+    finrankTrace_eq_trace_on_superspace (φ - ψ) W' (range_sub_le φ ψ) hφψW]
+
+end Additivity
+
+section ConjInvariance
+
+variable {K M N : Type*} [Field K] [AddCommGroup M] [Module K M]
+variable [AddCommGroup N] [Module K N]
+
+theorem range_conj_eq_map (e : M ≃ₗ[K] N) (φ : M →ₗ[K] M) :
+    LinearMap.range (e.conj φ) = (LinearMap.range φ).map (e : M →ₗ[K] N) := by
+  rw [LinearEquiv.conj_apply, LinearMap.range_comp, LinearEquiv.range,
+    Submodule.map_top, LinearMap.range_comp]
+
+theorem finrankTrace_conj (e : M ≃ₗ[K] N) (φ : M →ₗ[K] M)
+    [hφ : FiniteDimensional K (LinearMap.range φ)] :
+    haveI : FiniteDimensional K (LinearMap.range (e.conj φ)) := by
+      rw [range_conj_eq_map]
+      exact (Submodule.equivMapOfInjective _ e.injective _).finiteDimensional
+    finrankTrace (e.conj φ) = finrankTrace φ := by
+  have hgf : ((e : M →ₗ[K] N) ∘ₗ φ) ∘ₗ (e.symm : N →ₗ[K] M) = e.conj φ := by
+    apply LinearMap.ext; intro x
+    simp only [LinearMap.comp_apply, LinearEquiv.coe_coe, LinearEquiv.conj_apply]
+  have hfg : (e.symm : N →ₗ[K] M) ∘ₗ ((e : M →ₗ[K] N) ∘ₗ φ) = φ := by
+    apply LinearMap.ext; intro x
+    simp only [LinearMap.comp_apply, LinearEquiv.coe_coe, LinearEquiv.symm_apply_apply]
+  have : FiniteDimensional K
+      (LinearMap.range (((e : M →ₗ[K] N) ∘ₗ φ) ∘ₗ (e.symm : N →ₗ[K] M))) := by
+    rw [hgf, range_conj_eq_map]
+    exact (Submodule.equivMapOfInjective _ e.injective _).finiteDimensional
+  have : FiniteDimensional K
+      (LinearMap.range ((e.symm : N →ₗ[K] M) ∘ₗ ((e : M →ₗ[K] N) ∘ₗ φ))) := by
+    rw [hfg]; exact hφ
+  have hcyc := finrankTrace_comp_comm (e.symm : N →ₗ[K] M) ((e : M →ₗ[K] N) ∘ₗ φ)
+  have hconj : FiniteDimensional K (LinearMap.range (e.conj φ)) := by
+    rw [range_conj_eq_map]
+    exact (Submodule.equivMapOfInjective _ e.injective _).finiteDimensional
+  exact (finrankTrace_congr hgf.symm).trans (hcyc.trans (finrankTrace_congr hfg))
+
+end ConjInvariance
+
+section TermMaps
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+def alphaMap (c : u.adicCompletion) :
+    LinearMap.range (tateProj u) →ₗ[K] (u.adicCompletion ⧸ LinearMap.range (tateProj u)) :=
+  (LinearMap.range (tateProj u)).mkQ ∘ₗ lmulK u c ∘ₗ (LinearMap.range (tateProj u)).subtype
+
+theorem alphaMap_apply (c : u.adicCompletion) (a : LinearMap.range (tateProj u)) :
+    alphaMap u c a = Submodule.Quotient.mk (c * (a : u.adicCompletion)) := rfl
+
+def mulOnRange {gh : u.adicCompletion} (hgh : gh ∈ u.adicCompletionIntegers) :
+    LinearMap.range (tateProj u) →ₗ[K] LinearMap.range (tateProj u) :=
+  (lmulK u gh).restrict (fun x hx => by
+    have hxO : x ∈ u.adicCompletionIntegers :=
+      (range_tateProj u ▸ hx : x ∈ adicIntegersKSubmod u)
+    have hghx : gh * x ∈ u.adicCompletionIntegers := mul_mem hgh hxO
+    rw [range_tateProj u]
+    exact (show gh * x ∈ adicIntegersKSubmod u from hghx))
+
+theorem mulOnRange_apply {gh : u.adicCompletion} (hgh : gh ∈ u.adicCompletionIntegers)
+    (a : LinearMap.range (tateProj u)) :
+    (mulOnRange u hgh a : u.adicCompletion) = gh * (a : u.adicCompletion) := rfl
+
+variable [u.FiniteResidue]
+
+theorem finiteDimensional_range_alphaMap (c : u.adicCompletion) :
+    FiniteDimensional K (LinearMap.range (alphaMap u c)) := by
+  have hF21 := kwF4gRRTate_poleWindowImageFinite u c
+  set Q1 := u.adicCompletion ⧸ LinearMap.range (tateProj u)
+  set Q2 := u.adicCompletion ⧸ adicIntegersKSubmod u
+  let eQ : Q1 ≃ₗ[K] Q2 := Submodule.quotEquivOfEq _ _ (range_tateProj u)
+  have hmap : (LinearMap.range (alphaMap u c)).map (eQ : Q1 →ₗ[K] Q2)
+      = Submodule.map (adicIntegersKSubmod u).mkQ
+          (Submodule.map (lmulK u c) (adicIntegersKSubmod u)) := by
+    apply le_antisymm
+    · rintro x ⟨y, hy, rfl⟩
+      obtain ⟨a, rfl⟩ := hy
+      refine ⟨c * (a : u.adicCompletion), ⟨(a : u.adicCompletion), ?_, rfl⟩, ?_⟩
+      · exact (range_tateProj u) ▸ a.2
+      · rfl
+    · rintro x ⟨y, ⟨av, hav, rfl⟩, rfl⟩
+      refine ⟨alphaMap u c ⟨av, (range_tateProj u).symm ▸ hav⟩, ⟨_, rfl⟩, ?_⟩
+      rfl
+  have : FiniteDimensional K
+      ((LinearMap.range (alphaMap u c)).map (eQ : Q1 →ₗ[K] Q2)) := by
+    rw [hmap]; exact hF21
+  exact (Submodule.equivMapOfInjective (eQ : Q1 →ₗ[K] Q2) eQ.injective
+    (LinearMap.range (alphaMap u c))).symm.finiteDimensional
+
+end TermMaps
+
+section Cyclicity
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable [u.FiniteResidue]
+variable {pA' : u.adicCompletion →ₗ[K] u.adicCompletion}
+
+scoped instance instFinDimRangeDeltaAlpha (h : SameRangeIdemProjectors (tateProj u) pA')
+    (c : u.adicCompletion) :
+    FiniteDimensional K (LinearMap.range (deltaQuotFactor h ∘ₗ alphaMap u c)) := by
+  have := finiteDimensional_range_alphaMap u c
+  rw [LinearMap.range_comp]
+  infer_instance
+
+scoped instance instFinDimRangeMulDeltaAlpha (h : SameRangeIdemProjectors (tateProj u) pA')
+    (c : u.adicCompletion) {gh : u.adicCompletion} (hgh : gh ∈ u.adicCompletionIntegers) :
+    FiniteDimensional K
+      (LinearMap.range (mulOnRange u hgh ∘ₗ deltaQuotFactor h ∘ₗ alphaMap u c)) := by
+  have := finiteDimensional_range_alphaMap u c
+  rw [LinearMap.range_comp, LinearMap.range_comp]
+  infer_instance
+
+theorem finrankTrace_term_eq (h : SameRangeIdemProjectors (tateProj u) pA')
+    (fh : u.adicCompletion) {gh : u.adicCompletion} (hgh : gh ∈ u.adicCompletionIntegers) :
+    finrankTrace (deltaQuotFactor h ∘ₗ alphaMap u (gh * fh))
+      = finrankTrace (mulOnRange u hgh ∘ₗ deltaQuotFactor h ∘ₗ alphaMap u fh) := by
+  set dQ := deltaQuotFactor h
+  set α₁ := alphaMap u (gh * fh)
+  set α₂ := alphaMap u fh
+  set β := mulOnRange u hgh
+  have hFα₁ : FiniteDimensional K (LinearMap.range α₁) :=
+    finiteDimensional_range_alphaMap u (gh * fh)
+  have hFα₂ : FiniteDimensional K (LinearMap.range α₂) :=
+    finiteDimensional_range_alphaMap u fh
+  have hFS₁ : FiniteDimensional K (LinearMap.range (α₁ ∘ₗ dQ)) := by
+    apply Submodule.finiteDimensional_of_le (S₂ := LinearMap.range α₁)
+    exact LinearMap.range_comp_le_range _ _
+  have hFS₂ : FiniteDimensional K (LinearMap.range (α₂ ∘ₗ (β ∘ₗ dQ))) := by
+    apply Submodule.finiteDimensional_of_le (S₂ := LinearMap.range α₂)
+    exact LinearMap.range_comp_le_range _ _
+  have hFT₂' : FiniteDimensional K (LinearMap.range ((β ∘ₗ dQ) ∘ₗ α₂)) :=
+    instFinDimRangeMulDeltaAlpha u h fh hgh
+  have hcyc₁ : finrankTrace (dQ ∘ₗ α₁) = finrankTrace (α₁ ∘ₗ dQ) :=
+    finrankTrace_comp_comm α₁ dQ
+  have hcyc₂ : finrankTrace ((β ∘ₗ dQ) ∘ₗ α₂) = finrankTrace (α₂ ∘ₗ (β ∘ₗ dQ)) :=
+    finrankTrace_comp_comm α₂ (β ∘ₗ dQ)
+  have hSeq : α₁ ∘ₗ dQ = α₂ ∘ₗ (β ∘ₗ dQ) := by
+    apply LinearMap.ext; intro y
+    simp only [LinearMap.comp_apply]
+    rw [alphaMap_apply, alphaMap_apply, mulOnRange_apply]
+    congr 1
+    ring
+  change finrankTrace (dQ ∘ₗ α₁) = finrankTrace ((β ∘ₗ dQ) ∘ₗ α₂)
+  rw [hcyc₁, hcyc₂]
+  exact finrankTrace_congr hSeq
+
+end Cyclicity
+
+section Headline
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+variable [∀ u : Place K L, u.FiniteResidue]
+
+theorem kwF4gRRTate_projectorIndep : KwF4gRRTateProjectorIndep K L := by
+  intro u pA' h fh gh hgh _ _
+  set Φ := tateCommRestrict (tateProj u) (lmulK u fh) (lmulK u gh)
+  set Ψ' := tateCommRestrict pA' (lmulK u fh) (lmulK u gh)
+  let e : LinearMap.range pA' ≃ₗ[K] LinearMap.range (tateProj u) :=
+    LinearEquiv.ofEq _ _ h.range_eq.symm
+  set Ψ := e.conj Ψ' with hΨdef
+  have hFΨ : FiniteDimensional K (LinearMap.range Ψ) := by
+    rw [hΨdef, range_conj_eq_map]
+    infer_instance
+  have hΨeq : finrankTrace Ψ = finrankTrace Ψ' := finrankTrace_conj e Ψ'
+  change finrankTrace Φ = finrankTrace Ψ'
+  rw [← hΨeq]
+  set dQ := deltaQuotFactor h
+  set T₁ := dQ ∘ₗ alphaMap u (gh * fh) with hT₁def
+  set T₂ := mulOnRange u hgh ∘ₗ dQ ∘ₗ alphaMap u fh with hT₂def
+  have hΦΨ : Φ - Ψ = T₁ - T₂ := by
+    apply LinearMap.ext; intro a
+    apply Subtype.ext
+    simp only [LinearMap.sub_apply, AddSubgroupClass.coe_sub]
+    have hΦv : (Φ a : u.adicCompletion)
+        = (tateCommRestrict (tateProj u) (lmulK u fh) (lmulK u gh) a : u.adicCompletion) :=
+      rfl
+    have hΨv : (Ψ a : u.adicCompletion) = tateComm pA' (lmulK u fh) (lmulK u gh)
+        (a : u.adicCompletion) := by
+      change ((e.conj Ψ') a : u.adicCompletion) = _
+      simp only [LinearEquiv.conj_apply, LinearMap.comp_apply, LinearEquiv.coe_coe]
+      have he_coe : ∀ (x : LinearMap.range pA'), ((e x : LinearMap.range (tateProj u)) :
+          u.adicCompletion) = (x : u.adicCompletion) := fun x => rfl
+      have hesymm_coe : ∀ (x : LinearMap.range (tateProj u)),
+          ((e.symm x : LinearMap.range pA') : u.adicCompletion)
+          = (x : u.adicCompletion) := fun x => rfl
+      rw [he_coe, tateCommRestrict_apply, hesymm_coe]
+    rw [hΦv, hΨv]
+    rw [tateCommRestrict_diff u pA' h hgh fh a]
+    have hT₁v : (T₁ a : u.adicCompletion)
+        = (tateProj u - pA') (gh * fh * (a : u.adicCompletion)) := by
+      simp only [T₁, LinearMap.comp_apply, dQ]
+      rw [alphaMap_apply, deltaQuotFactor_apply]
+    have hT₂v : (T₂ a : u.adicCompletion)
+        = gh * (tateProj u - pA') (fh * (a : u.adicCompletion)) := by
+      simp only [T₂, LinearMap.comp_apply, dQ]
+      rw [alphaMap_apply, mulOnRange_apply, deltaQuotFactor_apply]
+    rw [hT₁v, hT₂v]
+  have hFT₁ : FiniteDimensional K (LinearMap.range T₁) :=
+    instFinDimRangeDeltaAlpha u h (gh * fh)
+  have hFT₂ : FiniteDimensional K (LinearMap.range T₂) :=
+    instFinDimRangeMulDeltaAlpha u h fh hgh
+  have hchain : finrankTrace Φ - finrankTrace Ψ = finrankTrace T₁ - finrankTrace T₂ := by
+    rw [finrankTrace_sub Φ Ψ, finrankTrace_sub T₁ T₂]
+    exact finrankTrace_congr hΦΨ
+  rw [← sub_eq_zero, hchain, finrankTrace_term_eq u h fh hgh, sub_self]
+
+end Headline
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  LinearMap P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateTraceCompat"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section Additivity
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+scoped instance instFinDimRangeNeg (φ : V →ₗ[K] V) [FiniteDimensional K (LinearMap.range φ)] :
+    FiniteDimensional K (LinearMap.range (-φ)) := by
+  have h : LinearMap.range (-φ) = LinearMap.range φ := by
+    apply le_antisymm
+    · rintro x ⟨y, rfl⟩; exact ⟨-y, by simp⟩
+    · rintro x ⟨y, rfl⟩; exact ⟨-y, by simp⟩
+  rw [h]; infer_instance
+
+scoped instance instFinDimRangeZero : FiniteDimensional K (LinearMap.range (0 : V →ₗ[K] V)) := by
+  rw [LinearMap.range_zero]; infer_instance
+
+theorem finrankTrace_zero : finrankTrace (0 : V →ₗ[K] V) = 0 := by
+  unfold finrankTrace
+  have hrest : (0 : V →ₗ[K] V).restrict
+      (p := LinearMap.range (0 : V →ₗ[K] V))
+      (fun x _ => LinearMap.mem_range_self _ x) = 0 := by
+    apply LinearMap.ext; intro; apply Subtype.ext; rfl
+  rw [hrest, _root_.map_zero]
+
+theorem finrankTrace_neg (φ : V →ₗ[K] V) [FiniteDimensional K (LinearMap.range φ)] :
+    finrankTrace (-φ) = -finrankTrace φ := by
+  have hsub := finrankTrace_sub (0 : V →ₗ[K] V) φ
+  rw [finrankTrace_zero, zero_sub] at hsub
+  calc finrankTrace (-φ) = finrankTrace ((0 : V →ₗ[K] V) - φ) :=
+        finrankTrace_congr (zero_sub φ).symm
+    _ = -finrankTrace φ := hsub.symm
+
+scoped instance instFinDimRangeAdd (φ ψ : V →ₗ[K] V)
+    [FiniteDimensional K (LinearMap.range φ)]
+    [FiniteDimensional K (LinearMap.range ψ)] :
+    FiniteDimensional K (LinearMap.range (φ + ψ)) := by
+  rw [show φ + ψ = φ - (-ψ) from (sub_neg_eq_add φ ψ).symm]
+  exact instFinDimRangeSub φ (-ψ)
+
+theorem finrankTrace_add (φ ψ : V →ₗ[K] V)
+    [FiniteDimensional K (LinearMap.range φ)]
+    [FiniteDimensional K (LinearMap.range ψ)] :
+    finrankTrace (φ + ψ) = finrankTrace φ + finrankTrace ψ := by
+  have h := finrankTrace_sub φ (-ψ)
+  rw [finrankTrace_neg, sub_neg_eq_add] at h
+  calc finrankTrace (φ + ψ) = finrankTrace (φ - (-ψ)) :=
+        finrankTrace_congr (sub_neg_eq_add φ ψ).symm
+    _ = finrankTrace φ + finrankTrace ψ := h.symm
+
+end Additivity
+
+section TateCommAddFst
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+theorem tateComm_add_fst (pA φ₁ φ₂ ψ : V →ₗ[K] V) :
+    tateComm pA (φ₁ + φ₂) ψ = tateComm pA φ₁ ψ + tateComm pA φ₂ ψ := by
+  unfold tateComm
+  ext x
+  simp only [LinearMap.add_apply, LinearMap.sub_apply, LinearMap.comp_apply, map_add]
+  abel
+
+theorem tateCommRestrict_add_fst (pA φ₁ φ₂ ψ : V →ₗ[K] V) :
+    tateCommRestrict pA (φ₁ + φ₂) ψ
+      = tateCommRestrict pA φ₁ ψ + tateCommRestrict pA φ₂ ψ := by
+  apply LinearMap.ext; intro a; apply Subtype.ext
+  change (tateCommRestrict pA (φ₁ + φ₂) ψ a : V)
+    = (tateCommRestrict pA φ₁ ψ a : V) + (tateCommRestrict pA φ₂ ψ a : V)
+  rw [tateCommRestrict_apply, tateCommRestrict_apply, tateCommRestrict_apply]
+  exact congrFun (congrArg DFunLike.coe (tateComm_add_fst pA φ₁ φ₂ ψ)) (a : V)
+
+theorem tateCommTrace_add_fst (pA φ₁ φ₂ ψ : V →ₗ[K] V)
+    [FiniteDimensional K (LinearMap.range (tateCommRestrict pA φ₁ ψ))]
+    [FiniteDimensional K (LinearMap.range (tateCommRestrict pA φ₂ ψ))] :
+    haveI : FiniteDimensional K (LinearMap.range (tateCommRestrict pA (φ₁ + φ₂) ψ)) := by
+      rw [tateCommRestrict_add_fst]; exact instFinDimRangeAdd _ _
+    tateCommTrace pA (φ₁ + φ₂) ψ = tateCommTrace pA φ₁ ψ + tateCommTrace pA φ₂ ψ := by
+  have : FiniteDimensional K (LinearMap.range (tateCommRestrict pA (φ₁ + φ₂) ψ)) := by
+    rw [tateCommRestrict_add_fst]; exact instFinDimRangeAdd _ _
+  unfold tateCommTrace
+  rw [← finrankTrace_add]
+  exact finrankTrace_congr (tateCommRestrict_add_fst pA φ₁ φ₂ ψ)
+
+end TateCommAddFst
+
+section TateResAddFst
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem tateRes_add_fst (fh₁ fh₂ gh : u.adicCompletion)
+    [FiniteDimensional K (LinearMap.range
+      (tateCommRestrict (tateProj u) (lmulK u fh₁) (lmulK u gh)))]
+    [FiniteDimensional K (LinearMap.range
+      (tateCommRestrict (tateProj u) (lmulK u fh₂) (lmulK u gh)))] :
+    haveI : FiniteDimensional K (LinearMap.range
+        (tateCommRestrict (tateProj u) (lmulK u (fh₁ + fh₂)) (lmulK u gh))) := by
+      have heq : lmulK u (fh₁ + fh₂) = lmulK u fh₁ + lmulK u fh₂ := map_add _ _ _
+      rw [heq, tateCommRestrict_add_fst]; exact instFinDimRangeAdd _ _
+    tateRes u (fh₁ + fh₂) gh = tateRes u fh₁ gh + tateRes u fh₂ gh := by
+  have heq : lmulK u (fh₁ + fh₂) = lmulK u fh₁ + lmulK u fh₂ := map_add _ _ _
+  have : FiniteDimensional K (LinearMap.range
+      (tateCommRestrict (tateProj u) (lmulK u (fh₁ + fh₂)) (lmulK u gh))) := by
+    rw [heq, tateCommRestrict_add_fst]; exact instFinDimRangeAdd _ _
+  have : FiniteDimensional K (LinearMap.range
+      (tateCommRestrict (tateProj u) (lmulK u fh₁ + lmulK u fh₂) (lmulK u gh))) := by
+    rw [tateCommRestrict_add_fst]; exact instFinDimRangeAdd _ _
+  unfold tateRes
+  have hct := tateCommTrace_add_fst (tateProj u) (lmulK u fh₁) (lmulK u fh₂) (lmulK u gh)
+  unfold tateCommTrace at hct ⊢
+  rw [← hct]
+  exact finrankTrace_congr (by rw [heq])
+
+end TateResAddFst
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  LinearMap P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateTraceCompat"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section DualAmbient
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+def tateCommDual (pA φ ψ : V →ₗ[K] V) : V →ₗ[K] V :=
+  φ ∘ₗ pA ∘ₗ ψ ∘ₗ pA - ψ ∘ₗ pA ∘ₗ φ ∘ₗ pA
+
+theorem tateCommDual_apply (pA φ ψ : V →ₗ[K] V) (x : V) :
+    tateCommDual pA φ ψ x = φ (pA (ψ (pA x))) - ψ (pA (φ (pA x))) := rfl
+
+theorem tateCommTrace_eq_finrankTrace_tateCommDual {pA φ ψ : V →ₗ[K] V}
+    [hR : FiniteDimensional K (LinearMap.range (tateCommRestrict pA φ ψ))]
+    [hD : FiniteDimensional K (LinearMap.range (tateCommDual pA φ ψ))] :
+    tateCommTrace pA φ ψ = finrankTrace (tateCommDual pA φ ψ) := by
+  set r : V →ₗ[K] LinearMap.range pA :=
+    pA.codRestrict (LinearMap.range pA) (fun x => LinearMap.mem_range_self pA x) with hr
+  set incl : LinearMap.range pA →ₗ[K] V := (LinearMap.range pA).subtype with hincl
+  set X : V →ₗ[K] V := φ ∘ₗ pA ∘ₗ ψ - ψ ∘ₗ pA ∘ₗ φ with hX
+  have hinclr : incl ∘ₗ r = pA := by
+    apply LinearMap.ext; intro x; rfl
+  have htateCommDual : X ∘ₗ pA = tateCommDual pA φ ψ := by
+    apply LinearMap.ext; intro x
+    simp only [hX, LinearMap.comp_apply, LinearMap.sub_apply, tateCommDual_apply]
+  have htateCommRestrict : r ∘ₗ X ∘ₗ incl = tateCommRestrict pA φ ψ := by
+    apply LinearMap.ext; intro a; apply Subtype.ext
+    change pA (X (a : V)) = (tateCommRestrict pA φ ψ a : V)
+    rw [tateCommRestrict_apply, tateComm_apply]
+    simp only [hX, LinearMap.sub_apply, LinearMap.comp_apply, map_sub]
+  have heqXir : (X ∘ₗ incl) ∘ₗ r = tateCommDual pA φ ψ := by
+    rw [LinearMap.comp_assoc, hinclr, htateCommDual]
+  have hRfg : FiniteDimensional K (LinearMap.range (r ∘ₗ (X ∘ₗ incl))) :=
+    htateCommRestrict.symm ▸ hR
+  have hRgf : FiniteDimensional K (LinearMap.range ((X ∘ₗ incl) ∘ₗ r)) :=
+    heqXir.symm ▸ hD
+  calc tateCommTrace pA φ ψ
+      = finrankTrace (tateCommRestrict pA φ ψ) := rfl
+    _ = finrankTrace (r ∘ₗ (X ∘ₗ incl)) := (finrankTrace_congr htateCommRestrict).symm
+    _ = finrankTrace ((X ∘ₗ incl) ∘ₗ r) := finrankTrace_comp_comm (X ∘ₗ incl) r
+    _ = finrankTrace (tateCommDual pA φ ψ) := finrankTrace_congr heqXir
+
+end DualAmbient
+
+section FinsetAdditivity
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+scoped instance instFinDimRangeSum {ι : Type*} (s : Finset ι) (f : ι → V →ₗ[K] V)
+    [∀ i, FiniteDimensional K (LinearMap.range (f i))] :
+    FiniteDimensional K (LinearMap.range (∑ i ∈ s, f i)) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => rw [Finset.sum_empty]; exact instFinDimRangeZero
+  | insert a s ha ih => rw [Finset.sum_insert ha]; exact instFinDimRangeAdd _ _
+
+theorem finrankTrace_sum {ι : Type*} (s : Finset ι) (f : ι → V →ₗ[K] V)
+    [∀ i, FiniteDimensional K (LinearMap.range (f i))] :
+    finrankTrace (∑ i ∈ s, f i) = ∑ i ∈ s, finrankTrace (f i) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty =>
+    calc finrankTrace (∑ i ∈ (∅ : Finset ι), f i)
+        = finrankTrace (0 : V →ₗ[K] V) := finrankTrace_congr Finset.sum_empty
+      _ = 0 := finrankTrace_zero
+      _ = ∑ i ∈ (∅ : Finset ι), finrankTrace (f i) := Finset.sum_empty.symm
+  | insert a s ha ih =>
+    have := instFinDimRangeSum s f
+    have hRHS : (∑ i ∈ insert a s, finrankTrace (f i) : K)
+        = finrankTrace (f a) + ∑ i ∈ s, finrankTrace (f i) := Finset.sum_insert ha
+    rw [hRHS, ← ih]
+    calc finrankTrace (∑ i ∈ insert a s, f i)
+        = finrankTrace (f a + ∑ i ∈ s, f i) := finrankTrace_congr (Finset.sum_insert ha)
+      _ = finrankTrace (f a) + finrankTrace (∑ i ∈ s, f i) := finrankTrace_add _ _
+
+end FinsetAdditivity
+
+section LemmaC
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+
+theorem finiteDimensional_range_comp_middle
+    {M₁ M₂ M₃ M₄ : Type*} [AddCommGroup M₁] [AddCommGroup M₂] [AddCommGroup M₃]
+    [AddCommGroup M₄] [Module K M₁] [Module K M₂] [Module K M₃] [Module K M₄]
+    (A : M₃ →ₗ[K] M₄) (δ : M₂ →ₗ[K] M₃) (B : M₁ →ₗ[K] M₂)
+    [FiniteDimensional K (LinearMap.range δ)] :
+    FiniteDimensional K (LinearMap.range (A ∘ₗ δ ∘ₗ B)) := by
+  apply Submodule.finiteDimensional_of_le (S₂ := Submodule.map A (LinearMap.range δ))
+  rintro x ⟨y, rfl⟩
+  exact ⟨δ (B y), LinearMap.mem_range_self _ _, rfl⟩
+
+end LemmaC
+
+section AmbientFinite
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+variable [u.FiniteResidue]
+
+theorem finiteDimensional_range_tateCommDual_tateProj
+    (fh : u.adicCompletion) {gh : u.adicCompletion} (hgh : gh ∈ u.adicCompletionIntegers) :
+    FiniteDimensional K
+      (LinearMap.range (tateCommDual (tateProj u) (lmulK u fh) (lmulK u gh))) := by
+  have hker : LinearMap.range (tateProj u)
+      ≤ LinearMap.ker (LinearMap.id - tateProj u) := by
+    rintro x ⟨y, rfl⟩
+    simp only [LinearMap.mem_ker, LinearMap.sub_apply, LinearMap.id_apply,
+      tateProj_of_mem u (tateProj_mem_integers u y), sub_self]
+  set pre : u.adicCompletion →ₗ[K] LinearMap.range (tateProj u) :=
+    (tateProj u).codRestrict (LinearMap.range (tateProj u))
+      (fun x => LinearMap.mem_range_self _ x) with hpre
+  set post : (u.adicCompletion ⧸ LinearMap.range (tateProj u)) →ₗ[K] u.adicCompletion :=
+    (lmulK u gh) ∘ₗ Submodule.liftQ _ (LinearMap.id - tateProj u) hker with hpost
+  have hfactor : tateCommDual (tateProj u) (lmulK u fh) (lmulK u gh)
+      = post ∘ₗ alphaMap u fh ∘ₗ pre := by
+    apply LinearMap.ext; intro x
+    change fh * tateProj u (gh * tateProj u x) - gh * tateProj u (fh * tateProj u x)
+      = gh * (fh * tateProj u x - tateProj u (fh * tateProj u x))
+    rw [tateProj_of_mem u (mul_mem hgh (tateProj_mem_integers u x))]
+    ring
+  rw [hfactor]
+  have := finiteDimensional_range_alphaMap u fh
+  exact finiteDimensional_range_comp_middle post (alphaMap u fh) pre
+
+end AmbientFinite
+
+section TateResSum
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (u : Place K L)
+
+theorem tateRes_sum_fst {ι : Type*} (s : Finset ι) (f : ι → u.adicCompletion)
+    (gh : u.adicCompletion) (hfin : KwF4gRRTateCommFinite K L) :
+    haveI := fun i => hfin u (f i) gh
+    haveI := hfin u (∑ i ∈ s, f i) gh
+    ∑ i ∈ s, tateRes u (f i) gh = tateRes u (∑ i ∈ s, f i) gh := by
+  have := fun i => hfin u (f i) gh
+  classical
+  induction s using Finset.induction_on with
+  | empty =>
+    have := hfin u (0 : u.adicCompletion) gh
+    rw [Finset.sum_empty, Finset.sum_empty]
+    unfold tateRes tateCommTrace
+    have h0 : tateCommRestrict (tateProj u) (lmulK u 0) (lmulK u gh) = 0 := by
+      apply LinearMap.ext; intro a; apply Subtype.ext
+      rw [tateCommRestrict_apply, tateComm_apply]
+      simp [lmulK]
+    rw [finrankTrace_congr h0, finrankTrace_zero]
+  | insert a s ha ih =>
+    have := hfin u (∑ i ∈ s, f i) gh
+    have := hfin u (∑ i ∈ insert a s, f i) gh
+    have := hfin u (f a + ∑ i ∈ s, f i) gh
+    rw [Finset.sum_insert ha, Finset.sum_insert ha, ih,
+      tateRes_add_fst u (f a) (∑ i ∈ s, f i) gh]
+
+end TateResSum
+
+section BlockSumMint
+
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+variable (E : Type*) [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+def KwF4gRRTateTraceCompatBlockSum (hfinF : KwF4gRRTateCommFinite K F)
+    (hfinE : KwF4gRRTateCommFinite K E) : Prop :=
+  ∀ [HasPrincipalDivisors K E] [HasPrincipalDivisors K F] [FiniteDimensional E F]
+    (v : Place K E) (w : Place K F) (_ : w ∈ v.fiber F) (g : F),
+    haveI := hfinF w (algebraMap F w.adicCompletion g)
+      (algebraMap F w.adicCompletion (algebraMap E F v.uniformizer))
+    let b := Module.finBasis (w.restrict E).adicCompletion w.adicCompletion
+    let M := LinearMap.toMatrix b b
+      (Algebra.lmul (w.restrict E).adicCompletion w.adicCompletion
+        (algebraMap F w.adicCompletion g))
+    haveI := fun i => hfinE (w.restrict E) (M i i)
+      (algebraMap E (w.restrict E).adicCompletion (w.restrict E).uniformizer)
+    tateRes w (algebraMap F w.adicCompletion g)
+        (algebraMap F w.adicCompletion (algebraMap E F v.uniformizer))
+      = ∑ i, tateRes (w.restrict E) (M i i)
+          (algebraMap E (w.restrict E).adicCompletion (w.restrict E).uniformizer)
+
+end BlockSumMint
+
+section Headline
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+theorem kwF4gRRTate_traceCompat_of_blockSum
+    (hfinF : KwF4gRRTateCommFinite K F) (hfinE : KwF4gRRTateCommFinite K E)
+    (hBS : KwF4gRRTateTraceCompatBlockSum K F E hfinF hfinE) :
+    KwF4gRRTateTraceCompat K F E hfinF hfinE := by
+  intro _ _ _ v w hw g
+  have hv : w.restrict E = v := Place.mem_fiber.mp hw
+  subst hv
+  set V₀ := (w.restrict E).adicCompletion
+  set W₀ := w.adicCompletion
+  set b : Module.Basis (Fin (Module.finrank V₀ W₀)) V₀ W₀ := Module.finBasis V₀ W₀ with hb
+  set M := LinearMap.toMatrix b b (Algebra.lmul V₀ W₀ (algebraMap F W₀ g)) with hM
+  set πv := algebraMap E V₀ (w.restrict E).uniformizer
+  have hfiw := hfinF w (algebraMap F W₀ g)
+    (algebraMap F W₀ (algebraMap E F (w.restrict E).uniformizer))
+  have hfiv := fun i => hfinE (w.restrict E) (M i i) πv
+  have hfisum := hfinE (w.restrict E) (∑ i, M i i) πv
+  have hBSw := hBS (w.restrict E) w hw g
+  simp only at hBSw
+  rw [hBSw]
+  rw [tateRes_sum_fst (w.restrict E) Finset.univ (fun i => M i i) πv hfinE]
+  have hdiag : ∑ i, M i i = Algebra.trace V₀ W₀ (algebraMap F W₀ g) := by
+    have htr := LinearMap.trace_eq_matrix_trace (R := V₀) b
+      (Algebra.lmul V₀ W₀ (algebraMap F W₀ g))
+    rw [show (Algebra.trace V₀ W₀ (algebraMap F W₀ g) : V₀)
+      = LinearMap.trace V₀ W₀ (Algebra.lmul V₀ W₀ (algebraMap F W₀ g)) from rfl, htr,
+      hM, Matrix.trace]
+    rfl
+  have hcast : kwHgfV352_completionTraceAt (w.restrict E) w hw g
+      = kw_ffgc_completionTraceF' E w g := rfl
+  have hτ : ∑ i, M i i = kwHgfV352_completionTraceAt (w.restrict E) w hw g := by
+    rw [hcast, kw_ffgc_completionTraceF'_apply, hdiag]
+  rw [show (∑ i ∈ Finset.univ, M i i) = ∑ i, M i i from rfl, hτ]
+
+end Headline
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  LinearMap P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateTraceCompat"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section ConjNaturality
+
+variable {K M N : Type*} [Field K] [AddCommGroup M] [Module K M]
+variable [AddCommGroup N] [Module K N]
+
+theorem tateCommDual_conj (e : M ≃ₗ[K] N) (pA φ ψ : M →ₗ[K] M) :
+    e.conj (tateCommDual pA φ ψ) = tateCommDual (e.conj pA) (e.conj φ) (e.conj ψ) := by
+  apply LinearMap.ext; intro x
+  simp only [LinearEquiv.conj_apply, tateCommDual_apply, LinearMap.comp_apply,
+    LinearEquiv.coe_coe, map_sub, LinearEquiv.symm_apply_apply]
+
+end ConjNaturality
+
+section ProdProj
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (v : Place K L)
+
+def prodTateProj (ι : Type*) :
+    (ι → v.adicCompletion) →ₗ[K] (ι → v.adicCompletion) :=
+  LinearMap.pi (fun i => tateProj v ∘ₗ LinearMap.proj i)
+
+theorem prodTateProj_apply {ι : Type*} (x : ι → v.adicCompletion) (i : ι) :
+    prodTateProj v ι x i = tateProj v (x i) := rfl
+
+theorem prodTateProj_idem {ι : Type*} (x : ι → v.adicCompletion) :
+    prodTateProj v ι (prodTateProj v ι x) = prodTateProj v ι x :=
+  funext fun i => congrFun (congrArg DFunLike.coe (tateProj_idem v)) (x i)
+
+end ProdProj
+
+section BlockDecomp
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L] (v : Place K L)
+variable {n : ℕ}
+
+def matMulLin (M : Matrix (Fin n) (Fin n) v.adicCompletion) :
+    (Fin n → v.adicCompletion) →ₗ[K] (Fin n → v.adicCompletion) :=
+  LinearMap.pi (fun i => ∑ j, lmulK v (M i j) ∘ₗ LinearMap.proj j)
+
+theorem matMulLin_apply (M : Matrix (Fin n) (Fin n) v.adicCompletion)
+    (x : Fin n → v.adicCompletion) (i : Fin n) :
+    matMulLin v M x i = ∑ j, M i j * x j := by
+  simp only [matMulLin, LinearMap.pi_apply, LinearMap.sum_apply, LinearMap.comp_apply,
+    LinearMap.proj_apply]
+  rfl
+
+def scalarLin (πv : v.adicCompletion) :
+    (Fin n → v.adicCompletion) →ₗ[K] (Fin n → v.adicCompletion) :=
+  LinearMap.pi (fun i => lmulK v πv ∘ₗ LinearMap.proj i)
+
+theorem scalarLin_apply (πv : v.adicCompletion) (x : Fin n → v.adicCompletion) (i : Fin n) :
+    scalarLin v πv x i = πv * x i := rfl
+
+theorem tateCommDual_prodTateProj_eq_blockSum
+    (M : Matrix (Fin n) (Fin n) v.adicCompletion) (πv : v.adicCompletion) :
+    tateCommDual (prodTateProj v (Fin n)) (matMulLin v M) (scalarLin v πv)
+      = ∑ i, ∑ j, LinearMap.single K (fun _ => v.adicCompletion) i
+          ∘ₗ tateCommDual (tateProj v) (lmulK v (M i j)) (lmulK v πv)
+          ∘ₗ LinearMap.proj j := by
+  apply LinearMap.ext; intro x; funext i
+  have hRHS : ((∑ i', ∑ j, LinearMap.single K (fun _ => v.adicCompletion) i'
+          ∘ₗ tateCommDual (tateProj v) (lmulK v (M i' j)) (lmulK v πv)
+          ∘ₗ LinearMap.proj j) x) i
+      = ∑ j, tateCommDual (tateProj v) (lmulK v (M i j)) (lmulK v πv) (x j) := by
+    simp only [LinearMap.sum_apply, LinearMap.comp_apply, LinearMap.proj_apply,
+      Finset.sum_apply, LinearMap.single_apply]
+    rw [Finset.sum_eq_single i (fun i' _ hi' => ?_) (fun h => absurd (Finset.mem_univ i) h)]
+    · simp only [Pi.single_eq_same]
+    · exact Finset.sum_eq_zero fun j _ => Pi.single_eq_of_ne' hi' _
+  rw [hRHS, tateCommDual_apply]
+  simp only [prodTateProj_apply, matMulLin_apply, scalarLin_apply, Pi.sub_apply]
+  rw [show tateProj v (∑ j, M i j * tateProj v (x j))
+      = ∑ j, tateProj v (M i j * tateProj v (x j)) from map_sum _ _ _,
+    Finset.mul_sum, ← Finset.sum_sub_distrib]
+  refine Finset.sum_congr rfl fun j _ => ?_
+  rw [tateCommDual_apply]; rfl
+
+end BlockDecomp
+
+section BlockTrace
+
+variable {K V : Type*} [Field K] [AddCommGroup V] [Module K V]
+variable {n : ℕ}
+
+theorem finrankTrace_blockSum (T : Fin n → Fin n → (V →ₗ[K] V))
+    [hT : ∀ i j, FiniteDimensional K (LinearMap.range (T i j))] :
+    haveI : ∀ (i j : Fin n), FiniteDimensional K (LinearMap.range
+        (LinearMap.single K (fun _ : Fin n => V) i ∘ₗ T i j
+          ∘ₗ (LinearMap.proj j : (Fin n → V) →ₗ[K] V))) :=
+      fun i j => finiteDimensional_range_comp_middle
+        (LinearMap.single K (fun _ : Fin n => V) i) (T i j)
+        (LinearMap.proj j : (Fin n → V) →ₗ[K] V)
+    finrankTrace (∑ i, ∑ j, LinearMap.single K (fun _ : Fin n => V) i
+        ∘ₗ T i j ∘ₗ (LinearMap.proj j : (Fin n → V) →ₗ[K] V))
+      = ∑ i, finrankTrace (T i i) := by
+  have : ∀ (i j : Fin n), FiniteDimensional K (LinearMap.range
+      (LinearMap.single K (fun _ : Fin n => V) i ∘ₗ T i j
+        ∘ₗ (LinearMap.proj j : (Fin n → V) →ₗ[K] V))) :=
+    fun i j => finiteDimensional_range_comp_middle
+      (LinearMap.single K (fun _ : Fin n => V) i) (T i j)
+      (LinearMap.proj j : (Fin n → V) →ₗ[K] V)
+  have : ∀ (i : Fin n), FiniteDimensional K (LinearMap.range
+      (∑ j, LinearMap.single K (fun _ : Fin n => V) i ∘ₗ T i j
+        ∘ₗ (LinearMap.proj j : (Fin n → V) →ₗ[K] V))) :=
+    fun i => instFinDimRangeSum _ _
+  rw [finrankTrace_sum]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [finrankTrace_sum]
+  have hassoc : ∀ (j : Fin n), LinearMap.single K (fun _ : Fin n => V) i ∘ₗ T i j
+      ∘ₗ (LinearMap.proj j : (Fin n → V) →ₗ[K] V)
+      = (LinearMap.single K (fun _ : Fin n => V) i ∘ₗ T i j)
+        ∘ₗ (LinearMap.proj j : (Fin n → V) →ₗ[K] V) := fun j => rfl
+  have hswap : ∀ (j : Fin n), (LinearMap.proj j : (Fin n → V) →ₗ[K] V)
+      ∘ₗ (LinearMap.single K (fun _ : Fin n => V) i ∘ₗ T i j)
+      = if j = i then T i i else 0 := fun j => by
+    apply LinearMap.ext; intro y
+    simp only [LinearMap.comp_apply, LinearMap.proj_apply, LinearMap.single_apply]
+    by_cases hji : j = i
+    · subst hji; rw [ite_eq_left rfl, Pi.single_eq_same]
+    · rw [ite_eq_right hji, Pi.single_eq_of_ne hji, LinearMap.zero_apply]
+  rw [Finset.sum_eq_single i (fun j _ hj => ?_) (fun h => absurd (Finset.mem_univ i) h)]
+  · have hfi : FiniteDimensional K (LinearMap.range
+        ((LinearMap.single K (fun _ : Fin n => V) i ∘ₗ T i i)
+          ∘ₗ (LinearMap.proj i : (Fin n → V) →ₗ[K] V))) := hassoc i ▸ inferInstance
+    have hgi : FiniteDimensional K (LinearMap.range
+        ((LinearMap.proj i : (Fin n → V) →ₗ[K] V)
+          ∘ₗ (LinearMap.single K (fun _ : Fin n => V) i ∘ₗ T i i))) := by
+      rw [hswap i, ite_eq_left rfl]; exact hT i i
+    calc finrankTrace (LinearMap.single K (fun _ : Fin n => V) i ∘ₗ T i i
+            ∘ₗ (LinearMap.proj i : (Fin n → V) →ₗ[K] V))
+        = finrankTrace ((LinearMap.single K (fun _ : Fin n => V) i ∘ₗ T i i)
+            ∘ₗ (LinearMap.proj i : (Fin n → V) →ₗ[K] V)) := finrankTrace_congr (hassoc i)
+      _ = finrankTrace ((LinearMap.proj i : (Fin n → V) →ₗ[K] V)
+            ∘ₗ (LinearMap.single K (fun _ : Fin n => V) i ∘ₗ T i i)) :=
+          finrankTrace_comp_comm _ _
+      _ = finrankTrace (T i i) := finrankTrace_congr (by rw [hswap i, ite_eq_left rfl])
+  · have hfj : FiniteDimensional K (LinearMap.range
+        ((LinearMap.single K (fun _ : Fin n => V) i ∘ₗ T i j)
+          ∘ₗ (LinearMap.proj j : (Fin n → V) →ₗ[K] V))) := hassoc j ▸ inferInstance
+    have hgj : FiniteDimensional K (LinearMap.range
+        ((LinearMap.proj j : (Fin n → V) →ₗ[K] V)
+          ∘ₗ (LinearMap.single K (fun _ : Fin n => V) i ∘ₗ T i j))) := by
+      rw [hswap j, ite_eq_right hj]; exact instFinDimRangeZero
+    calc finrankTrace (LinearMap.single K (fun _ : Fin n => V) i ∘ₗ T i j
+            ∘ₗ (LinearMap.proj j : (Fin n → V) →ₗ[K] V))
+        = finrankTrace ((LinearMap.single K (fun _ : Fin n => V) i ∘ₗ T i j)
+            ∘ₗ (LinearMap.proj j : (Fin n → V) →ₗ[K] V)) := finrankTrace_congr (hassoc j)
+      _ = finrankTrace ((LinearMap.proj j : (Fin n → V) →ₗ[K] V)
+            ∘ₗ (LinearMap.single K (fun _ : Fin n => V) i ∘ₗ T i j)) :=
+          finrankTrace_comp_comm _ _
+      _ = finrankTrace (0 : V →ₗ[K] V) := finrankTrace_congr (by rw [hswap j, ite_eq_right hj])
+      _ = 0 := finrankTrace_zero
+
+end BlockTrace
+
+section Headline
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+scoped instance instIsScalarTowerKVhatWhat (w : Place K F) :
+    IsScalarTower K (w.restrict E).adicCompletion w.adicCompletion :=
+  IsScalarTower.of_algebraMap_eq fun c => by
+    rw [IsScalarTower.algebraMap_apply K F w.adicCompletion c,
+      IsScalarTower.algebraMap_apply K E F c,
+      IsScalarTower.algebraMap_apply K E (w.restrict E).adicCompletion c]
+    exact kw_ffgc_adicCompletionComap_algebraMap_algebraMap E w (algebraMap K E c)
+
+end Headline
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  LinearMap P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateTraceCompat"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section Freeness
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+theorem kwF4gRRTate_free_adicCompletionIntegers (w : Place K F) [FiniteDimensional E F]
+    [Algebra.IsSeparable (w.restrict E).adicCompletion w.adicCompletion] :
+    Module.Free (w.restrict E).adicCompletionIntegers w.adicCompletionIntegers := by
+  have : Algebra.IsAlgebraic (w.restrict E).adicCompletion w.adicCompletion :=
+    Algebra.IsAlgebraic.of_finite _ _
+  have : IsIntegralClosure w.adicCompletionIntegers (w.restrict E).adicCompletionIntegers
+      w.adicCompletion := kw_ffgc_isIntegralClosure_adicCompletionIntegers E w
+  have : IsNoetherian (w.restrict E).adicCompletionIntegers w.adicCompletionIntegers :=
+    IsIntegralClosure.isNoetherian (w.restrict E).adicCompletionIntegers
+      (w.restrict E).adicCompletion w.adicCompletion w.adicCompletionIntegers
+  have : Module.Finite (w.restrict E).adicCompletionIntegers w.adicCompletionIntegers :=
+    Module.IsNoetherian.finite _ _
+  exact Module.free_of_finite_type_torsion_free'
+
+end Freeness
+
+section IntegralBasisMint
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+structure IntegralBasisData (w : Place K F) [FiniteDimensional E F] where
+  basis : Module.Basis
+    (Fin (Module.finrank (w.restrict E).adicCompletion w.adicCompletion))
+    (w.restrict E).adicCompletion w.adicCompletion
+  basis_mem : ∀ i, basis i ∈ w.adicCompletionIntegers
+  mem_integers_iff : ∀ y, y ∈ w.adicCompletionIntegers
+    ↔ ∀ i, basis.repr y i ∈ (w.restrict E).adicCompletionIntegers
+
+variable (K F E) in
+def KwF4gRRTateIntegralBasisCompat : Prop :=
+  ∀ [HasPrincipalDivisors K E] [HasPrincipalDivisors K F] [FiniteDimensional E F]
+    (w : Place K F), Nonempty (IntegralBasisData (E := E) w)
+
+end IntegralBasisMint
+
+section IntegralProdProj
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+variable (w : Place K F) [FiniteDimensional E F] (D : IntegralBasisData (E := E) w)
+
+def integralBasisEquivFunK : w.adicCompletion ≃ₗ[K]
+    (Fin (Module.finrank (w.restrict E).adicCompletion w.adicCompletion)
+      → (w.restrict E).adicCompletion) :=
+  D.basis.equivFun.restrictScalars K
+
+theorem integralBasisEquivFunK_apply (y : w.adicCompletion) :
+    integralBasisEquivFunK w D y = D.basis.equivFun y := rfl
+
+def integralProdProj : w.adicCompletion →ₗ[K] w.adicCompletion :=
+  (integralBasisEquivFunK w D).symm.conj (prodTateProj (w.restrict E) _)
+
+theorem integralProdProj_idem (y : w.adicCompletion) :
+    integralProdProj w D (integralProdProj w D y) = integralProdProj w D y := by
+  unfold integralProdProj
+  simp only [LinearEquiv.conj_apply, LinearMap.comp_apply, LinearEquiv.coe_coe,
+    LinearEquiv.symm_apply_apply]
+  rw [prodTateProj_idem]
+
+theorem range_integralProdProj :
+    LinearMap.range (integralProdProj w D) = adicIntegersKSubmod w := by
+  apply le_antisymm
+  · rintro y ⟨z, rfl⟩
+    rw [mem_adicIntegersKSubmod_iff, D.mem_integers_iff]
+    intro i
+    have : D.basis.repr (integralProdProj w D z) i
+        = tateProj (w.restrict E) ((D.basis.equivFun z) i) := by
+      have hipp : integralProdProj w D z
+          = D.basis.equivFun.symm (prodTateProj (w.restrict E) _ (D.basis.equivFun z)) := by
+        unfold integralProdProj
+        simp only [LinearEquiv.conj_apply, LinearMap.comp_apply, LinearEquiv.coe_coe,
+          LinearEquiv.symm_symm, integralBasisEquivFunK, LinearEquiv.restrictScalars_apply,
+          LinearEquiv.restrictScalars_symm_apply]
+      rw [hipp, ← Module.Basis.equivFun_apply, LinearEquiv.apply_symm_apply,
+        prodTateProj_apply]
+    rw [this]
+    exact tateProj_mem_integers (w.restrict E) _
+  · intro y hy
+    refine ⟨y, ?_⟩
+    have hrepr := (D.mem_integers_iff y).mp ((mem_adicIntegersKSubmod_iff w y).mp hy)
+    unfold integralProdProj
+    simp only [LinearEquiv.conj_apply, LinearMap.comp_apply, LinearEquiv.coe_coe,
+      LinearEquiv.symm_symm]
+    rw [show prodTateProj (w.restrict E) _ ((integralBasisEquivFunK w D) y)
+      = (integralBasisEquivFunK w D) y from ?_]
+    · exact (integralBasisEquivFunK w D).symm_apply_apply y
+    · funext i
+      rw [prodTateProj_apply, integralBasisEquivFunK_apply, Module.Basis.equivFun_apply]
+      exact tateProj_of_mem (w.restrict E) (hrepr i)
+
+theorem sameRangeIdemProjectors_integralProdProj :
+    SameRangeIdemProjectors (tateProj w) (integralProdProj w D) where
+  idem_pA x := congrFun (congrArg DFunLike.coe (tateProj_idem w)) x
+  idem_pA' := integralProdProj_idem w D
+  range_eq := (range_tateProj w).trans (range_integralProdProj w D).symm
+
+end IntegralProdProj
+
+section Headline
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+theorem integralBasisEquivFunK_conj_lmulK_algebraMap (w : Place K F) [FiniteDimensional E F]
+    (D : IntegralBasisData (E := E) w) (g : F) :
+    (integralBasisEquivFunK w D).conj (lmulK w (algebraMap F w.adicCompletion g))
+      = matMulLin (w.restrict E)
+          (LinearMap.toMatrix D.basis D.basis
+            (Algebra.lmul (w.restrict E).adicCompletion w.adicCompletion
+              (algebraMap F w.adicCompletion g))) := by
+  apply LinearMap.ext; intro x; funext i
+  rw [matMulLin_apply, LinearEquiv.conj_apply, LinearMap.comp_apply, LinearMap.comp_apply,
+    LinearEquiv.coe_coe, LinearEquiv.coe_coe]
+  change D.basis.equivFun (algebraMap F w.adicCompletion g * (D.basis.equivFun.symm x)) i
+    = ∑ j, (LinearMap.toMatrix D.basis D.basis
+        (Algebra.lmul (w.restrict E).adicCompletion w.adicCompletion
+          (algebraMap F w.adicCompletion g))) i j * x j
+  have hreprsymm : ⇑(D.basis.repr (D.basis.equivFun.symm x)) = x := by
+    funext j; rw [← Module.Basis.equivFun_apply, LinearEquiv.apply_symm_apply]
+  rw [Module.Basis.equivFun_apply,
+    show algebraMap F w.adicCompletion g * D.basis.equivFun.symm x
+    = Algebra.lmul (w.restrict E).adicCompletion w.adicCompletion
+        (algebraMap F w.adicCompletion g) (D.basis.equivFun.symm x) from rfl,
+    ← LinearMap.toMatrix_mulVec_repr D.basis D.basis, hreprsymm, Matrix.mulVec]
+  rfl
+
+theorem integralBasisEquivFunK_conj_lmulK_scalar (w : Place K F) [FiniteDimensional E F]
+    (D : IntegralBasisData (E := E) w) (e : E) :
+    (integralBasisEquivFunK w D).conj
+        (lmulK w (algebraMap F w.adicCompletion (algebraMap E F e)))
+      = scalarLin (w.restrict E) (algebraMap E (w.restrict E).adicCompletion e) := by
+  apply LinearMap.ext; intro x; funext i
+  rw [scalarLin_apply, LinearEquiv.conj_apply, LinearMap.comp_apply, LinearMap.comp_apply,
+    LinearEquiv.coe_coe, LinearEquiv.coe_coe]
+  change D.basis.equivFun (algebraMap F w.adicCompletion (algebraMap E F e)
+      * (D.basis.equivFun.symm x)) i
+    = algebraMap E (w.restrict E).adicCompletion e * x i
+  have halg : algebraMap F w.adicCompletion (algebraMap E F e)
+      = algebraMap (w.restrict E).adicCompletion w.adicCompletion
+          (algebraMap E (w.restrict E).adicCompletion e) :=
+    kw_ffgc_adicCompletionComap_algebraMap_algebraMap E w e
+  rw [halg, ← Algebra.smul_def, map_smul, LinearEquiv.apply_symm_apply,
+    Pi.smul_apply, smul_eq_mul]
+
+theorem kwF4gRRTate_blockSum_of_integralBasisCompat
+    [∀ w : Place K F, w.FiniteResidue] [∀ v : Place K E, v.FiniteResidue]
+    (hfinF : KwF4gRRTateCommFinite K F) (hfinE : KwF4gRRTateCommFinite K E)
+    (hIBC : KwF4gRRTateIntegralBasisCompat K F E) :
+    KwF4gRRTateTraceCompatBlockSum K F E hfinF hfinE := by
+  intro _ _ _ v w hw g
+  have hv : w.restrict E = v := Place.mem_fiber.mp hw
+  subst hv
+  obtain ⟨D⟩ := hIBC w
+  set V₀ := (w.restrict E).adicCompletion
+  set W₀ := w.adicCompletion
+  set n := Module.finrank V₀ W₀
+  set b : Module.Basis (Fin n) V₀ W₀ := Module.finBasis V₀ W₀ with hb
+  set M := LinearMap.toMatrix b b (Algebra.lmul V₀ W₀ (algebraMap F W₀ g)) with hM
+  set M' := LinearMap.toMatrix D.basis D.basis
+    (Algebra.lmul V₀ W₀ (algebraMap F W₀ g)) with hM'
+  set πv := algebraMap E V₀ (w.restrict E).uniformizer with hπv
+  set ghF := algebraMap F W₀ (algebraMap E F (w.restrict E).uniformizer) with hghF
+  set eD : W₀ ≃ₗ[K] (Fin n → V₀) := integralBasisEquivFunK w D with heD
+  set P := prodTateProj (w.restrict E) (Fin n) with hP
+  set pI := integralProdProj w D with hpI
+  have hghmem : ghF ∈ w.adicCompletionIntegers := by
+    rw [hghF]; exact (kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff w _).mpr
+      ((Place.mem_restrict_iff w).mp (w.restrict E).uniformizer_mem)
+  have hπvmem : πv ∈ (w.restrict E).adicCompletionIntegers := by
+    rw [hπv]; exact (kwHgfV352_algebraMap_mem_adicCompletionIntegers_iff _ _).mpr
+      (w.restrict E).uniformizer_mem
+  have hFw := hfinF w (algebraMap F W₀ g) ghF
+  have hFv := fun i => hfinE (w.restrict E) (M i i) πv
+  have hFv' := fun i => hfinE (w.restrict E) (M' i i) πv
+  have hFpI : FiniteDimensional K (LinearMap.range
+      (tateCommRestrict pI (lmulK w (algebraMap F W₀ g)) (lmulK w ghF))) :=
+    kwF4gRRTate_commFiniteGen w pI
+      (sameRangeIdemProjectors_integralProdProj w D) (algebraMap F W₀ g) ghF
+  have hD1 : FiniteDimensional K (LinearMap.range
+      (tateCommDual (tateProj w) (lmulK w (algebraMap F W₀ g)) (lmulK w ghF))) :=
+    finiteDimensional_range_tateCommDual_tateProj w (algebraMap F W₀ g) hghmem
+  have hTij' : ∀ (i j : Fin n), FiniteDimensional K (LinearMap.range
+      (tateCommDual (tateProj (w.restrict E)) (lmulK (w.restrict E) (M' i j))
+        (lmulK (w.restrict E) πv))) := fun i j =>
+    finiteDimensional_range_tateCommDual_tateProj (w.restrict E) (M' i j) hπvmem
+  have hTii : ∀ (i : Fin n), FiniteDimensional K (LinearMap.range
+      (tateCommDual (tateProj (w.restrict E)) (lmulK (w.restrict E) (M i i))
+        (lmulK (w.restrict E) πv))) := fun i =>
+    finiteDimensional_range_tateCommDual_tateProj (w.restrict E) (M i i) hπvmem
+  have hPconj : eD.conj pI = P := by
+    apply LinearMap.ext; intro x
+    simp only [heD, hpI, integralProdProj, hP, LinearEquiv.conj_apply, LinearMap.comp_apply,
+      LinearEquiv.coe_coe, LinearEquiv.symm_symm, LinearEquiv.apply_symm_apply]
+    rfl
+  have hTCDconj : eD.conj (tateCommDual pI (lmulK w (algebraMap F W₀ g)) (lmulK w ghF))
+      = tateCommDual P (matMulLin (w.restrict E) M') (scalarLin (w.restrict E) πv) := by
+    rw [tateCommDual_conj, hPconj, heD, integralBasisEquivFunK_conj_lmulK_algebraMap,
+      integralBasisEquivFunK_conj_lmulK_scalar]
+  have hBlk' : ∀ (i j : Fin n), FiniteDimensional K (LinearMap.range
+      (LinearMap.single K (fun _ : Fin n => V₀) i
+        ∘ₗ tateCommDual (tateProj (w.restrict E)) (lmulK (w.restrict E) (M' i j))
+            (lmulK (w.restrict E) πv)
+        ∘ₗ (LinearMap.proj j : (Fin n → V₀) →ₗ[K] V₀))) :=
+    fun i j => finiteDimensional_range_comp_middle _ _ _
+  have hBlkI' : ∀ (i : Fin n), FiniteDimensional K (LinearMap.range
+      (∑ j, LinearMap.single K (fun _ : Fin n => V₀) i
+        ∘ₗ tateCommDual (tateProj (w.restrict E)) (lmulK (w.restrict E) (M' i j))
+            (lmulK (w.restrict E) πv)
+        ∘ₗ (LinearMap.proj j : (Fin n → V₀) →ₗ[K] V₀))) :=
+    fun i => instFinDimRangeSum _ _
+  have hBlkSum' : FiniteDimensional K (LinearMap.range
+      (∑ i, ∑ j, LinearMap.single K (fun _ : Fin n => V₀) i
+        ∘ₗ tateCommDual (tateProj (w.restrict E)) (lmulK (w.restrict E) (M' i j))
+            (lmulK (w.restrict E) πv)
+        ∘ₗ (LinearMap.proj j : (Fin n → V₀) →ₗ[K] V₀))) := instFinDimRangeSum _ _
+  set rTCDpI := LinearMap.range
+    (tateCommDual pI (lmulK w (algebraMap F W₀ g)) (lmulK w ghF)) with hrTCDpI
+  have hmapfin : FiniteDimensional K (rTCDpI.map (eD : W₀ →ₗ[K] (Fin n → V₀))) := by
+    rw [hrTCDpI, ← range_conj_eq_map, hTCDconj, tateCommDual_prodTateProj_eq_blockSum]
+    exact hBlkSum'
+  have hDpI : FiniteDimensional K rTCDpI :=
+    (Submodule.equivMapOfInjective (eD : W₀ →ₗ[K] (Fin n → V₀))
+      eD.injective rTCDpI).symm.finiteDimensional
+  have hDpI' : FiniteDimensional K (LinearMap.range
+      (tateCommDual pI (lmulK w (algebraMap F W₀ g)) (lmulK w ghF))) := hrTCDpI ▸ hDpI
+  have hDeDconj : FiniteDimensional K (LinearMap.range
+      (eD.conj (tateCommDual pI (lmulK w (algebraMap F W₀ g)) (lmulK w ghF)))) := by
+    rw [range_conj_eq_map, ← hrTCDpI]; exact hmapfin
+  have hDP : FiniteDimensional K (LinearMap.range
+      (tateCommDual P (matMulLin (w.restrict E) M') (scalarLin (w.restrict E) πv))) :=
+    hTCDconj ▸ hDeDconj
+  simp only
+  have hchain : tateRes w (algebraMap F W₀ g) ghF
+      = ∑ i, tateRes (w.restrict E) (M' i i) πv := by
+    calc tateRes w (algebraMap F W₀ g) ghF
+        = tateCommTrace (tateProj w) (lmulK w (algebraMap F W₀ g)) (lmulK w ghF) := rfl
+      _ = tateCommTrace pI (lmulK w (algebraMap F W₀ g)) (lmulK w ghF) :=
+          kwF4gRRTate_projectorIndep w pI
+            (sameRangeIdemProjectors_integralProdProj w D)
+            (algebraMap F W₀ g) ghF hghmem
+      _ = finrankTrace (tateCommDual pI (lmulK w (algebraMap F W₀ g)) (lmulK w ghF)) :=
+          tateCommTrace_eq_finrankTrace_tateCommDual
+      _ = finrankTrace (eD.conj (tateCommDual pI (lmulK w (algebraMap F W₀ g))
+            (lmulK w ghF))) := (finrankTrace_conj eD _).symm
+      _ = finrankTrace (tateCommDual P (matMulLin (w.restrict E) M')
+            (scalarLin (w.restrict E) πv)) := finrankTrace_congr hTCDconj
+      _ = finrankTrace (∑ i, ∑ j, LinearMap.single K (fun _ : Fin n => V₀) i
+            ∘ₗ tateCommDual (tateProj (w.restrict E)) (lmulK (w.restrict E) (M' i j))
+                (lmulK (w.restrict E) πv)
+            ∘ₗ (LinearMap.proj j : (Fin n → V₀) →ₗ[K] V₀)) :=
+          finrankTrace_congr (tateCommDual_prodTateProj_eq_blockSum (w.restrict E) M' πv)
+      _ = ∑ i, finrankTrace (tateCommDual (tateProj (w.restrict E))
+            (lmulK (w.restrict E) (M' i i)) (lmulK (w.restrict E) πv)) :=
+          finrankTrace_blockSum _
+      _ = ∑ i, tateRes (w.restrict E) (M' i i) πv := by
+          refine Finset.sum_congr rfl fun i _ => ?_
+          exact (tateCommTrace_eq_finrankTrace_tateCommDual
+            (pA := tateProj (w.restrict E))).symm
+  have hFsum := hfinE (w.restrict E) (∑ i, M' i i) πv
+  have hFsumM := hfinE (w.restrict E) (∑ i, M i i) πv
+  have htr : (∑ i, M' i i : V₀) = ∑ i, M i i := by
+    have h1 : (∑ i, M' i i : V₀) = Algebra.trace V₀ W₀ (algebraMap F W₀ g) := by
+      rw [show (Algebra.trace V₀ W₀ (algebraMap F W₀ g) : V₀)
+        = LinearMap.trace V₀ W₀ (Algebra.lmul V₀ W₀ (algebraMap F W₀ g)) from rfl,
+        LinearMap.trace_eq_matrix_trace (R := V₀) D.basis, hM', Matrix.trace]
+      rfl
+    have h2 : (∑ i, M i i : V₀) = Algebra.trace V₀ W₀ (algebraMap F W₀ g) := by
+      rw [show (Algebra.trace V₀ W₀ (algebraMap F W₀ g) : V₀)
+        = LinearMap.trace V₀ W₀ (Algebra.lmul V₀ W₀ (algebraMap F W₀ g)) from rfl,
+        LinearMap.trace_eq_matrix_trace (R := V₀) b, hM, Matrix.trace]
+      rfl
+    rw [h1, h2]
+  rw [hchain, tateRes_sum_fst (w.restrict E) Finset.univ (fun i => M' i i) πv hfinE,
+    tateRes_sum_fst (w.restrict E) Finset.univ (fun i => M i i) πv hfinE,
+    show (∑ i ∈ Finset.univ, M' i i) = ∑ i, M' i i from rfl,
+    show (∑ i ∈ Finset.univ, M i i) = ∑ i, M i i from rfl, htr]
+
+theorem kwF4gRRTate_traceCompat_of_integralBasisCompat
+    [HasCanonicalLocalResidueKStar K F] [HasCanonicalLocalResidueKStar K E]
+    [∀ w : Place K F, w.FiniteResidue] [∀ v : Place K E, v.FiniteResidue]
+    (hfinF : KwF4gRRTateCommFinite K F) (hfinE : KwF4gRRTateCommFinite K E)
+    (hIBC : KwF4gRRTateIntegralBasisCompat K F E) :
+    KwF4gRRTateTraceCompat K F E hfinF hfinE :=
+  kwF4gRRTate_traceCompat_of_blockSum hfinF hfinE
+    (kwF4gRRTate_blockSum_of_integralBasisCompat hfinF hfinE hIBC)
+
+end Headline
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  LinearMap P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4gRRTate"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateTraceCompat"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section Construct
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+variable (w : Place K F) [FiniteDimensional E F]
+variable [Algebra.IsSeparable (w.restrict E).adicCompletion w.adicCompletion]
+variable [Module.IsTorsionFree (w.restrict E).adicCompletionIntegers w.adicCompletion]
+
+scoped instance instIsLocalizationAlgebraMapSubmonoid :
+    haveI : Algebra.IsAlgebraic (w.restrict E).adicCompletion w.adicCompletion :=
+      Algebra.IsAlgebraic.of_finite _ _
+    haveI := kw_ffgc_isIntegralClosure_adicCompletionIntegers E w
+    IsLocalization (Algebra.algebraMapSubmonoid w.adicCompletionIntegers
+      (nonZeroDivisors (w.restrict E).adicCompletionIntegers)) w.adicCompletion := by
+  have : Algebra.IsAlgebraic (w.restrict E).adicCompletion w.adicCompletion :=
+    Algebra.IsAlgebraic.of_finite _ _
+  have := kw_ffgc_isIntegralClosure_adicCompletionIntegers E w
+  exact IsIntegralClosure.isLocalization (w.restrict E).adicCompletionIntegers
+    (w.restrict E).adicCompletion w.adicCompletion w.adicCompletionIntegers
+
+def integralBasisDataOf : IntegralBasisData (E := E) w := by
+  haveI : Algebra.IsAlgebraic (w.restrict E).adicCompletion w.adicCompletion :=
+    Algebra.IsAlgebraic.of_finite _ _
+  haveI hIC := kw_ffgc_isIntegralClosure_adicCompletionIntegers E w
+  haveI hFree := kwF4gRRTate_free_adicCompletionIntegers (E := E) w
+  haveI : IsNoetherian (w.restrict E).adicCompletionIntegers w.adicCompletionIntegers :=
+    IsIntegralClosure.isNoetherian (w.restrict E).adicCompletionIntegers
+      (w.restrict E).adicCompletion w.adicCompletion w.adicCompletionIntegers
+  let c := Module.Free.chooseBasis (w.restrict E).adicCompletionIntegers w.adicCompletionIntegers
+  let c' := c.localizationLocalization (w.restrict E).adicCompletion
+    (nonZeroDivisors (w.restrict E).adicCompletionIntegers) w.adicCompletion
+  have hrank : Module.finrank (w.restrict E).adicCompletionIntegers w.adicCompletionIntegers
+      = Module.finrank (w.restrict E).adicCompletion w.adicCompletion :=
+    IsIntegralClosure.rank (w.restrict E).adicCompletionIntegers
+      (w.restrict E).adicCompletion w.adicCompletion w.adicCompletionIntegers
+  let e : Module.Free.ChooseBasisIndex (w.restrict E).adicCompletionIntegers
+        w.adicCompletionIntegers
+      ≃ Fin (Module.finrank (w.restrict E).adicCompletion w.adicCompletion) :=
+    (Fintype.equivFinOfCardEq (by
+      rw [← hrank, Module.finrank_eq_card_chooseBasisIndex]))
+  let c'' := c'.reindex e
+  refine { basis := c'', basis_mem := ?_, mem_integers_iff := ?_ }
+  · intro i
+    rw [show c'' i = c' (e.symm i) from Module.Basis.reindex_apply c' e i,
+      Module.Basis.localizationLocalization_apply]
+    exact (c (e.symm i)).2
+  · intro y
+    constructor
+    · intro hy i
+      obtain ⟨z, hz⟩ : ∃ z : w.adicCompletionIntegers,
+          algebraMap w.adicCompletionIntegers w.adicCompletion z = y := ⟨⟨y, hy⟩, rfl⟩
+      rw [← hz, Module.Basis.repr_reindex_apply,
+        Module.Basis.localizationLocalization_repr_algebraMap]
+      exact (c.repr z (e.symm i)).2
+    · intro hrepr
+      have hsum : y = ∑ i, c''.repr y i • c'' i := (c''.sum_repr y).symm
+      rw [hsum]
+      refine sum_mem fun i _ => ?_
+      have hci : c'' i ∈ w.adicCompletionIntegers := by
+        rw [show c'' i = c' (e.symm i) from Module.Basis.reindex_apply c' e i,
+          Module.Basis.localizationLocalization_apply]
+        exact (c (e.symm i)).2
+      rw [show c''.repr y i • c'' i
+        = algebraMap (w.restrict E).adicCompletion w.adicCompletion (c''.repr y i) * c'' i
+        from Algebra.smul_def _ _]
+      refine mul_mem ?_ hci
+      obtain ⟨a, ha⟩ : ∃ a : (w.restrict E).adicCompletionIntegers,
+          (a : (w.restrict E).adicCompletion) = c''.repr y i := ⟨⟨_, hrepr i⟩, rfl⟩
+      rw [← ha]
+      exact (algebraMap (w.restrict E).adicCompletionIntegers w.adicCompletionIntegers a).2
+
+end Construct
+end ModularCurve.KwF4gRRTate
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  IsDedekindDomain P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain \
+  TensorProduct P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.TensorProduct"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4R1V384a
+p2m_open "ModularCurve"
+
+section FiberAlgebra
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F] [HasPrincipalDivisors K E] [HasPrincipalDivisors K F]
+
+scoped instance kwF4R1V384a_instAlgebraFiberCompletion (v : Place K E) (w' : v.fiber F) :
+    Algebra v.adicCompletion w'.1.adicCompletion := by
+  rcases w' with ⟨w', hw'⟩
+  have hv : w'.restrict E = v := Place.mem_fiber.mp hw'
+  subst hv
+  exact kw_ffgc_algebraAdicCompletionComap E w'
+
+scoped instance kwF4R1V384a_instIsScalarTowerFiberCompletion (v : Place K E) (w' : v.fiber F) :
+    IsScalarTower E v.adicCompletion w'.1.adicCompletion := by
+  rcases w' with ⟨w', hw'⟩
+  have hv : w'.restrict E = v := Place.mem_fiber.mp hw'
+  subst hv
+  refine IsScalarTower.of_algebraMap_eq fun e => ?_
+  rw [show algebraMap E w'.adicCompletion e = algebraMap F w'.adicCompletion (algebraMap E F e)
+    from IsScalarTower.algebraMap_apply E F w'.adicCompletion e]
+  exact kw_ffgc_adicCompletionComap_algebraMap_algebraMap E w' e
+
+end FiberAlgebra
+
+section SemilocalDiag
+
+variable {K : Type*} (F : Type*) [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F] [HasPrincipalDivisors K E] [HasPrincipalDivisors K F]
+
+def kwF4R1V384a_semilocalComponent (v : Place K E) (w' : v.fiber F) :
+    v.adicCompletion ⊗[E] F →ₐ[v.adicCompletion] w'.1.adicCompletion :=
+  Algebra.TensorProduct.lift (Algebra.ofId v.adicCompletion w'.1.adicCompletion)
+    (IsScalarTower.toAlgHom E F w'.1.adicCompletion) (fun _ _ => mul_comm _ _)
+
+omit [HasPrincipalDivisors K E] in
+@[scoped simp]
+theorem kwF4R1V384a_semilocalComponent_tmul (v : Place K E) (w' : v.fiber F)
+    (c : v.adicCompletion) (g : F) :
+    kwF4R1V384a_semilocalComponent F v w' (c ⊗ₜ[E] g)
+      = algebraMap v.adicCompletion w'.1.adicCompletion c
+          * algebraMap F w'.1.adicCompletion g := by
+  unfold kwF4R1V384a_semilocalComponent
+  rw [Algebra.TensorProduct.lift_tmul]
+  rfl
+
+end SemilocalDiag
+
+
+section PerComponentSurjective
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F] [HasPrincipalDivisors K F]
+variable [FiniteDimensional E F]
+
+omit [HasPrincipalDivisors K F] [FiniteDimensional E F] in
+theorem kwF4R1V384a_completionLinearCombination_surjective
+    (w' : Place K F) {ι : Type*} [Fintype ι] (b : Module.Basis ι E F) :
+    Function.Surjective (kw_ffgc_completionLinearCombination E w' b) := by
+  let := kw_ffgc_rankOne_adicCompletion (K := K) (w'.restrict E)
+  let : NontriviallyNormedField (w'.restrict E).adicCompletion :=
+    Valued.toNontriviallyNormedField (w'.restrict E).adicCompletion
+      (WithZero (Multiplicative ℤ))
+  rw [← Set.range_eq_univ, ← LinearMap.coe_range,
+    ← (LinearMap.range (kw_ffgc_completionLinearCombination E w' b))
+        |>.closed_of_finiteDimensional.closure_eq]
+  exact (kw_ffgc_denseRange_completionLinearCombination E w' b).closure_range
+
+theorem kwF4R1V384a_semilocalComponent_surjective (v : Place K E) (w' : v.fiber F) :
+    Function.Surjective (kwF4R1V384a_semilocalComponent F v w') := by
+  rcases w' with ⟨w', hw'⟩
+  have hv : w'.restrict E = v := Place.mem_fiber.mp hw'
+  subst hv
+  intro y
+  let b := Module.finBasis E F
+  obtain ⟨c, hc⟩ := kwF4R1V384a_completionLinearCombination_surjective w' b y
+  refine ⟨∑ i, c i ⊗ₜ[E] b i, ?_⟩
+  rw [map_sum, ← hc]
+  unfold kw_ffgc_completionLinearCombination
+  rw [Fintype.linearCombination_apply]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [kwF4R1V384a_semilocalComponent_tmul, Algebra.smul_def]
+
+end PerComponentSurjective
+
+
+section BijEngine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+scoped instance kwF4R1V384a_instModuleFiberCompletion
+    [HasPrincipalDivisors K E] [HasPrincipalDivisors K F]
+    (v : Place K E) (w' : v.fiber F) :
+    Module v.adicCompletion w'.1.adicCompletion :=
+  Algebra.toModule
+
+end BijEngine
+end ModularCurve.KwF4R1V384a
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  IsDedekindDomain P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsDedekindDomain \
+  TensorProduct P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.TensorProduct IsLocalRing \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.IsLocalRing"
+p2m_open_scoped "AlgebraicCurve.Place \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place Valued \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Valued NNReal \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.NNReal WithZero \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.WithZero"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4R1V386a
+p2m_open "ModularCurve"
+
+open ModularCurve.KwF4R1V384a
+
+section IsSeparableLift
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+theorem kwF4R1V386a_isSeparable_algebraMap_fiberCompletion
+    [HasPrincipalDivisors K E] [HasPrincipalDivisors K F]
+    [FiniteDimensional E F] [Algebra.IsSeparable E F]
+    (v : Place K E) (w' : v.fiber F) (g : F) :
+    IsSeparable v.adicCompletion (algebraMap F w'.1.adicCompletion g) := by
+  have hroot : Polynomial.aeval (R := v.adicCompletion)
+      (algebraMap F w'.1.adicCompletion g)
+      ((minpoly E g).map (algebraMap E v.adicCompletion)) = 0 := by
+    rw [Polynomial.aeval_map_algebraMap,
+      show algebraMap F w'.1.adicCompletion g
+          = IsScalarTower.toAlgHom E F w'.1.adicCompletion g from rfl,
+      Polynomial.aeval_algHom_apply, minpoly.aeval, _root_.map_zero]
+  have hmapsep : ((minpoly E g).map (algebraMap E v.adicCompletion)).Separable :=
+    Polynomial.Separable.map (Algebra.IsSeparable.isSeparable E g)
+  exact hmapsep.of_dvd (minpoly.dvd v.adicCompletion _ hroot)
+
+set_option synthInstance.maxHeartbeats 8000000 in
+theorem kwF4R1V386a_isSeparable_fiberCompletion
+    [HasPrincipalDivisors K E] [HasPrincipalDivisors K F]
+    [FiniteDimensional E F] [Algebra.IsSeparable E F]
+    (v : Place K E) (w' : v.fiber F) :
+    Algebra.IsSeparable v.adicCompletion w'.1.adicCompletion := by
+  have hgen : Algebra.adjoin v.adicCompletion
+      (Set.range (algebraMap F w'.1.adicCompletion)) = ⊤ := by
+    rw [Algebra.eq_top_iff]
+    intro y
+    obtain ⟨x, rfl⟩ := kwF4R1V384a_semilocalComponent_surjective v w' y
+    induction x using TensorProduct.inductionOn with
+    | tmul c g =>
+      rw [kwF4R1V384a_semilocalComponent_tmul, ← Algebra.smul_def]
+      exact Subalgebra.smul_mem _ (Algebra.subset_adjoin (Set.mem_range_self g)) c
+    | add x y hx hy => rw [map_add]; exact add_mem hx hy
+  have hsep : ∀ x ∈ Set.range (algebraMap F w'.1.adicCompletion),
+      IsSeparable v.adicCompletion x := by
+    rintro _ ⟨g, rfl⟩
+    exact kwF4R1V386a_isSeparable_algebraMap_fiberCompletion v w' g
+  have hgenI : IntermediateField.adjoin v.adicCompletion
+      (Set.range (algebraMap F w'.1.adicCompletion)) = ⊤ := by
+    rw [eq_top_iff]; intro x _
+    exact IntermediateField.algebra_adjoin_le_adjoin _ _ (hgen ▸ Algebra.mem_top)
+  have hsepAdj : Algebra.IsSeparable v.adicCompletion
+      (IntermediateField.adjoin v.adicCompletion
+        (Set.range (algebraMap F w'.1.adicCompletion))) :=
+    (IntermediateField.isSeparable_adjoin_iff_isSeparable v.adicCompletion
+      w'.1.adicCompletion).mpr hsep
+  rw [hgenI] at hsepAdj
+  exact Algebra.IsSeparable.of_algHom v.adicCompletion
+    (⊤ : IntermediateField v.adicCompletion w'.1.adicCompletion)
+    (IntermediateField.topEquiv (F := v.adicCompletion)
+      (E := w'.1.adicCompletion)).symm.toAlgHom
+
+end IsSeparableLift
+end ModularCurve.KwF4R1V386a
+end
+end
+
+section
+
+
+p2m_open "AlgebraicCurve P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve \
+  AlgebraicCurve.Place P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.AlgebraicCurve.Place \
+  LinearMap P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.LinearMap Submodule \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.Submodule"
+p2m_open "ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4gRRTate \
+  P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable.ModularCurve.KwF4R1V386a"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "KwF4gRRTate.KwF4gRRTateCommFinite KwF4gRRTate.KwF4gRRTateTraceCompat"
+namespace KwF4gRRTate
+p2m_export "ModularCurve.KwF4gRRTate" "finrankTrace tateComm tateComm_apply tateCommRestrict \
+  tateCommRestrict_apply tateCommTrace tateComm_eq_of_commute adicIntegersKSubmod tateProj lmulK \
+  tateRes KwF4gRRTateCommFinite KwF4gRRTateTraceCompat"
+p2m_open "ModularCurve.KwF4gRRTate ModularCurve"
+
+section IsSeparableLift
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+theorem kwTateRR3_isSeparable_completion_of_global
+    [HasPrincipalDivisors K E] [HasPrincipalDivisors K F]
+    [FiniteDimensional E F] [Algebra.IsSeparable E F]
+    (w : Place K F) :
+    Algebra.IsSeparable (w.restrict E).adicCompletion w.adicCompletion :=
+  kwF4R1V386a_isSeparable_fiberCompletion (K := K) (F := F) (E := E)
+    (w.restrict E) ⟨w, Place.restrict_mem_fiber w⟩
+
+end IsSeparableLift
+
+section IsTorsionFree
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+theorem kwTateRR3_isTorsionFree_integersCompletion (w : Place K F) :
+    Module.IsTorsionFree (w.restrict E).adicCompletionIntegers w.adicCompletion :=
+  .trans_faithfulSMul (w.restrict E).adicCompletionIntegers (w.restrict E).adicCompletion
+    w.adicCompletion
+
+end IsTorsionFree
+
+section Headline
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+variable [Algebra.IsIntegral E F]
+
+theorem kwTateRR3_integralBasisCompat_of_isSeparable_global [Algebra.IsSeparable E F] :
+    KwF4gRRTateIntegralBasisCompat K F E := by
+  intro _ _ _ w
+  have := kwTateRR3_isSeparable_completion_of_global (K := K) (E := E) w
+  have := kwTateRR3_isTorsionFree_integersCompletion (K := K) (E := E) w
+  exact ⟨integralBasisDataOf w⟩
+
+theorem kwTateRR3_traceCompat_of_isSeparable_global [Algebra.IsSeparable E F]
+    [HasCanonicalLocalResidueKStar K F] [HasCanonicalLocalResidueKStar K E]
+    [∀ w : Place K F, w.FiniteResidue] [∀ v : Place K E, v.FiniteResidue]
+    (hfinF : KwF4gRRTateCommFinite K F) (hfinE : KwF4gRRTateCommFinite K E) :
+    KwF4gRRTateTraceCompat K F E hfinF hfinE :=
+  kwF4gRRTate_traceCompat_of_integralBasisCompat hfinF hfinE
+    kwTateRR3_integralBasisCompat_of_isSeparable_global
+
+end Headline
+end ModularCurve.KwF4gRRTate
+end
+end
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] {E : Type*} [Field E] [Algebra K E]
+    [Algebra E F] [IsScalarTower K E F] [Algebra.IsIntegral E F] [Algebra.IsSeparable E F]
+    [AlgebraicCurve.HasCanonicalLocalResidueKStar K F]
+    [AlgebraicCurve.HasCanonicalLocalResidueKStar K E]
+    [∀ w : AlgebraicCurve.Place K F, w.FiniteResidue]
+    [∀ v : AlgebraicCurve.Place K E, v.FiniteResidue]
+    (hfinF : ModularCurve.KwF4gRRTate.KwF4gRRTateCommFinite K F)
+    (hfinE : ModularCurve.KwF4gRRTate.KwF4gRRTateCommFinite K E) :
+    ModularCurve.KwF4gRRTate.KwF4gRRTateTraceCompat K F E hfinF hfinE :=
+  ModularCurve.KwF4gRRTate.kwTateRR3_traceCompat_of_isSeparable_global hfinF hfinE
+
+end S_AlgebraicCurve_tateTraceCompat_of_isSeparable
+end P2MW
+export P2MW.S_AlgebraicCurve_tateTraceCompat_of_isSeparable (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.tateTraceCompat_of_isSeparable
+    {K F : Type*} [Field K] [Field F] [Algebra K F]
+    {E : Type*} [Field E] [Algebra K E] [Algebra E F] [IsScalarTower K E F]
+    [Algebra.IsIntegral E F] [Algebra.IsSeparable E F]
+    [AlgebraicCurve.HasCanonicalLocalResidueKStar K F]
+    [AlgebraicCurve.HasCanonicalLocalResidueKStar K E]
+    [∀ w : AlgebraicCurve.Place K F, w.FiniteResidue]
+    [∀ v : AlgebraicCurve.Place K E, v.FiniteResidue]
+    (hfinF : ModularCurve.KwF4gRRTate.KwF4gRRTateCommFinite K F)
+    (hfinE : ModularCurve.KwF4gRRTate.KwF4gRRTateCommFinite K E) :
+    ModularCurve.KwF4gRRTate.KwF4gRRTateTraceCompat K F E hfinF hfinE :=
+  solution hfinF hfinE
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_twelve_mul_eq_of_sum_ordDiff_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_twelve_mul_eq_of_sum_ordDiff_eq.lean
new file mode 100644
index 0000000000..3fca9380b0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_twelve_mul_eq_of_sum_ordDiff_eq.lean
@@ -0,0 +1,235 @@
+/-
+Based on Prove2Me node AlgebraicCurve.twelve_mul_eq_of_sum_ordDiff_eq
+(87a3f72e-4e44-5a3f-a6bd-f44abfb9c185) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a63255dd-b4ba-54e6-864a-7b55a6eaeb1e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Riemann–Hurwitz bookkeeping for a j-type map
+
+Theorem statement: `AlgebraicCurve.twelve_mul_eq_of_sum_ordDiff_eq`
+(`87a3f72e-4e44-5a3f-a6bd-f44abfb9c185`), by Claude, 2026-09-05.
+
+Proof: submission `a63255dd-b4ba-54e6-864a-7b55a6eaeb1e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F/K$ be an extension of fields, and let a `Place` of $F$ over $K$ mean a valuation subring of
+$F$ that contains the image of $K$, is proper in $F$, and is a principal ideal ring; for such a $v$,
+$v.\mathrm{ord}$ is minus the logarithm of the associated height-one adic valuation, and for a
+differential $\omega \in \Omega[F/K]$, $v.\mathrm{ordDiff}\,\omega$ is $v.\mathrm{ord}$ of the
+coefficient $g$ in a representation $\omega = g\,\mathrm{d}u$, where $u$ is a chosen element with
+$v.\mathrm{ord}\,u = 1$ (both choices being made by definite selection, with default $0$). Fix $t
+\in F$, finite sets of places $S_0, S_1, S_\infty$, a natural number $\psi$ and an integer $g$,
+subject to: for $v \in S_0$, $v.\mathrm{ordDiff}(\mathrm{d}t) = v.\mathrm{ord}\,t - 1$ with $0 <
+v.\mathrm{ord}\,t$ and $v.\mathrm{ord}\,t \mid 3$; for $v \in S_1$, $v.\mathrm{ordDiff}(\mathrm{d}t)
+= v.\mathrm{ord}(t - 1728) - 1$ with $0 < v.\mathrm{ord}(t-1728)$ and $v.\mathrm{ord}(t-1728) \mid
+2$, where $1728$ is taken from $K$; for $v \in S_\infty$, $v.\mathrm{ordDiff}(\mathrm{d}t) =
+v.\mathrm{ord}\,t - 1$ with $v.\mathrm{ord}\,t < 0$; the three fibre sums $\sum_{S_0}
+v.\mathrm{ord}\,t$, $\sum_{S_1} v.\mathrm{ord}(t-1728)$ and $\sum_{S_\infty} -v.\mathrm{ord}\,t$ all
+equal $\psi$; and, for a finite set $S$ whose members are exactly those of $S_0 \cup S_1 \cup
+S_\infty$, $\sum_{v \in S} v.\mathrm{ordDiff}(\mathrm{d}t) = 2g - 2$. Then $12g = 12 + \psi -
+3\varepsilon_2 - 4\varepsilon_3 - 6\,\#S_\infty$, where $\varepsilon_2$ is the number of $v \in S_1$
+with $v.\mathrm{ord}(t-1728) = 1$ and $\varepsilon_3$ the number of $v \in S_0$ with
+$v.\mathrm{ord}\,t = 1$.
+
+This is the arithmetic core of the classical Riemann–Hurwitz computation of the genus of a curve
+carrying a $j$-type map of degree $\psi$, in the form $g = 1 + \psi/12 - \varepsilon_2/4 -
+\varepsilon_3/3 - \varepsilon_\infty/2$, with $g$ and $\psi$ entering only as parameters and nothing
+assumed about $K$. It is used by
+[`ModularCurve.genus_modularFunctionFieldBar_eq_genusFormula`]
+(thm.html#ModularCurve.genus_modularFunctionFieldBar_eq_genusFormula)
+and
+[`ModularCurve.genus_modularFunctionFieldBar_eq_genusFormula_of_prime`]
+(thm.html#ModularCurve.genus_modularFunctionFieldBar_eq_genusFormula_of_prime)
+to obtain the genus formula for the modular curves once the local order data of the $j$-map has been
+established.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_twelve_mul_eq_of_sum_ordDiff_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_twelve_mul_eq_of_sum_ordDiff_eq
+
+open AlgebraicCurve
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (t : F) (S₀ S₁ Sinf : Finset (Place
+  K F)) (ψ : ℕ) (g : ℤ) (h₀ : ∀ v ∈ S₀, v.ordDiff (KaehlerDifferential.D K F t) = v.ord t - 1 ∧ 0 <
+  v.ord t ∧ v.ord t ∣ 3) (h₁ : ∀ v ∈ S₁, v.ordDiff (KaehlerDifferential.D K F t) = v.ord (t -
+  algebraMap K F 1728) - 1 ∧ 0 < v.ord (t - algebraMap K F 1728) ∧ v.ord (t - algebraMap K F 1728) ∣
+  2) (hinf : ∀ v ∈ Sinf, v.ordDiff (KaehlerDifferential.D K F t) = v.ord t - 1 ∧ v.ord t < 0) (hψ₀ :
+  ∑ v ∈ S₀, v.ord t = ψ) (hψ₁ : ∑ v ∈ S₁, v.ord (t - algebraMap K F 1728) = ψ) (hψinf : ∑ v ∈ Sinf,
+  -v.ord t = ψ) (S : Finset (Place K F)) (hS : ∀ v, v ∈ S ↔ v ∈ S₀ ∨ v ∈ S₁ ∨ v ∈ Sinf) (hcan : ∑ v
+  ∈ S, v.ordDiff (KaehlerDifferential.D K F t) = 2 * g - 2) :
+    12 * g = 12 + ψ - 3 * ((S₁.filter fun v => v.ord (t - algebraMap K F 1728) = 1).card : ℤ) - 4 *
+      ((S₀.filter fun v => v.ord t = 1).card : ℤ) - 6 * (Sinf.card : ℤ) := by
+  let : DecidableEq (Place K F) := Classical.decEq _
+  have houter : Disjoint (S₀ ∪ S₁) Sinf := by
+    rw [Finset.disjoint_left]
+    intro v hv hvi
+    have hi1 := (hinf v hvi).1
+    have hi2 := (hinf v hvi).2
+    rcases Finset.mem_union.mp hv with h | h
+    · have := (h₀ v h).2.1
+      omega
+    · have h1 := (h₁ v h).1
+      have h2 := (h₁ v h).2.1
+      omega
+  have hSeq : S = (S₀ ∪ S₁) ∪ Sinf := by
+    ext v
+    rw [hS v, Finset.mem_union, Finset.mem_union, or_assoc]
+  have hov : ∀ v ∈ S₀ ∩ S₁, v.ordDiff (KaehlerDifferential.D K F t) = 0 := by
+    intro v hv
+    obtain ⟨hv0, hv1⟩ := Finset.mem_inter.mp hv
+    obtain ⟨e0, p0, d3⟩ := h₀ v hv0
+    obtain ⟨e1, p1, d2⟩ := h₁ v hv1
+    have hle3 : v.ord t ≤ 3 := Int.le_of_dvd (by omega) d3
+    have hne2 : ¬ v.ord t = 2 := by
+      intro h
+      rw [h] at d3
+      omega
+    have hle2 : v.ord (t - algebraMap K F 1728) ≤ 2 := Int.le_of_dvd (by omega) d2
+    omega
+  have hzero : ∑ v ∈ S₀ ∩ S₁, v.ordDiff (KaehlerDifferential.D K F t) = 0 := by
+    rw [Finset.sum_congr rfl hov, Finset.sum_const, smul_zero]
+  have hinner : ∑ v ∈ S₀ ∪ S₁, v.ordDiff (KaehlerDifferential.D K F t) = (∑ v ∈ S₀, v.ordDiff
+    (KaehlerDifferential.D K F t)) + ∑ v ∈ S₁, v.ordDiff (KaehlerDifferential.D K F t) :=
+    by
+    have h :=
+      Finset.sum_union_inter (s₁ := S₀) (s₂ := S₁) (f := fun v => v.ordDiff (KaehlerDifferential.D K
+        F t))
+    rw [hzero] at h
+    omega
+  rw [hSeq, Finset.sum_union houter, hinner] at hcan
+  have hE0 : (∑ v ∈ S₀, v.ordDiff (KaehlerDifferential.D K F t)) + (S₀.card : ℤ) = (ψ : ℤ) := by
+    have hpt : ∀ v ∈ S₀, v.ordDiff (KaehlerDifferential.D K F t) + 1 = v.ord t := by
+      intro v hv
+      have h := (h₀ v hv).1
+      omega
+    have hdist : ∑ v ∈ S₀, (v.ordDiff (KaehlerDifferential.D K F t) + 1) = (∑ v ∈ S₀, v.ordDiff
+      (KaehlerDifferential.D K F t)) + (S₀.card : ℤ) :=
+      by
+      rw [Finset.sum_add_distrib, Finset.sum_const, nsmul_eq_mul, mul_one]
+    rw [← hdist, Finset.sum_congr rfl hpt, hψ₀]
+  have hE1 : (∑ v ∈ S₁, v.ordDiff (KaehlerDifferential.D K F t)) + (S₁.card : ℤ) = (ψ : ℤ) := by
+    have hpt : ∀ v ∈ S₁, v.ordDiff (KaehlerDifferential.D K F t) + 1 = v.ord (t - algebraMap K F
+      1728) :=
+      by
+      intro v hv
+      have h := (h₁ v hv).1
+      omega
+    have hdist : ∑ v ∈ S₁, (v.ordDiff (KaehlerDifferential.D K F t) + 1) = (∑ v ∈ S₁, v.ordDiff
+      (KaehlerDifferential.D K F t)) + (S₁.card : ℤ) :=
+      by
+      rw [Finset.sum_add_distrib, Finset.sum_const, nsmul_eq_mul, mul_one]
+    rw [← hdist, Finset.sum_congr rfl hpt, hψ₁]
+  have hEinf : (∑ v ∈ Sinf, v.ordDiff (KaehlerDifferential.D K F t)) + (Sinf.card : ℤ) + (ψ : ℤ) = 0
+    :=
+    by
+    have hpt : ∀ v ∈ Sinf, (v.ordDiff (KaehlerDifferential.D K F t) + 1) + -v.ord t = 0 := by
+      intro v hv
+      have h := (hinf v hv).1
+      omega
+    have hz : ∑ v ∈ Sinf, ((v.ordDiff (KaehlerDifferential.D K F t) + 1) + -v.ord t) = 0 := by
+      rw [Finset.sum_congr rfl hpt, Finset.sum_const, smul_zero]
+    rw [Finset.sum_add_distrib, Finset.sum_add_distrib, Finset.sum_const, nsmul_eq_mul,
+      mul_one] at hz
+    have hneg := hψinf
+    omega
+  have key0 : ∀ v ∈ S₀.filter (fun v => ¬ v.ord t = 1), v.ord t = 3 := by
+    intro v hv
+    obtain ⟨hvS, hne⟩ := Finset.mem_filter.mp hv
+    obtain ⟨-, hp, hd⟩ := h₀ v hvS
+    have hle : v.ord t ≤ 3 := Int.le_of_dvd (by omega) hd
+    have h2 : ¬ v.ord t = 2 := by
+      intro h
+      rw [h] at hd
+      omega
+    omega
+  have hsplit0 : (∑ v ∈ S₀.filter (fun v => v.ord t = 1), v.ord t) + ∑ v ∈ S₀.filter (fun v => ¬
+    v.ord t = 1), v.ord t = ∑ v ∈ S₀, v.ord t :=
+    by
+    rw [Finset.sum_filter_add_sum_filter_not]
+  have hA0 : ∑ v ∈ S₀.filter (fun v => v.ord t = 1), v.ord t = ((S₀.filter fun v => v.ord t =
+    1).card : ℤ) :=
+    by
+    rw [Finset.sum_congr rfl (fun v hv => (Finset.mem_filter.mp hv).2), Finset.sum_const,
+      nsmul_eq_mul, mul_one]
+  have hB0 : ∑ v ∈ S₀.filter (fun v => ¬ v.ord t = 1), v.ord t = ((S₀.filter (fun v => ¬ v.ord t =
+    1)).card : ℤ) * 3 :=
+    by
+    rw [Finset.sum_congr rfl key0, Finset.sum_const, nsmul_eq_mul]
+  have hcards0 : (S₀.filter fun v => v.ord t = 1).card + (S₀.filter (fun v => ¬ v.ord t = 1)).card =
+    S₀.card :=
+    by
+    rw [Finset.card_filter_add_card_filter_not]
+  have key1 : ∀ v ∈ S₁.filter (fun v => ¬ v.ord (t - algebraMap K F 1728) = 1), v.ord (t -
+    algebraMap K F 1728) = 2 :=
+    by
+    intro v hv
+    obtain ⟨hvS, hne⟩ := Finset.mem_filter.mp hv
+    obtain ⟨-, hp, hd⟩ := h₁ v hvS
+    have hle : v.ord (t - algebraMap K F 1728) ≤ 2 := Int.le_of_dvd (by omega) hd
+    omega
+  have hsplit1 : (∑ v ∈ S₁.filter (fun v => v.ord (t - algebraMap K F 1728) = 1), v.ord (t -
+    algebraMap K F 1728)) + ∑ v ∈ S₁.filter (fun v => ¬ v.ord (t - algebraMap K F 1728) = 1), v.ord
+    (t - algebraMap K F 1728) = ∑ v ∈ S₁, v.ord (t - algebraMap K F 1728) :=
+    by
+    rw [Finset.sum_filter_add_sum_filter_not]
+  have hA1 : ∑ v ∈ S₁.filter (fun v => v.ord (t - algebraMap K F 1728) = 1), v.ord (t - algebraMap K
+    F 1728) = ((S₁.filter fun v => v.ord (t - algebraMap K F 1728) = 1).card : ℤ) :=
+    by
+    rw [Finset.sum_congr rfl (fun v hv => (Finset.mem_filter.mp hv).2), Finset.sum_const,
+      nsmul_eq_mul, mul_one]
+  have hB1 : ∑ v ∈ S₁.filter (fun v => ¬ v.ord (t - algebraMap K F 1728) = 1), v.ord (t - algebraMap
+    K F 1728) = ((S₁.filter (fun v => ¬ v.ord (t - algebraMap K F 1728) = 1)).card : ℤ) * 2 :=
+    by
+    rw [Finset.sum_congr rfl key1, Finset.sum_const, nsmul_eq_mul]
+  have hcards1 : (S₁.filter fun v => v.ord (t - algebraMap K F 1728) = 1).card + (S₁.filter (fun v
+    => ¬ v.ord (t - algebraMap K F 1728) = 1)).card = S₁.card :=
+    by
+    rw [Finset.card_filter_add_card_filter_not]
+  omega
+
+end S_AlgebraicCurve_twelve_mul_eq_of_sum_ordDiff_eq
+end P2MW
+export P2MW.S_AlgebraicCurve_twelve_mul_eq_of_sum_ordDiff_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem AlgebraicCurve.twelve_mul_eq_of_sum_ordDiff_eq {K F : Type*} [Field K] [Field F] [Algebra K
+  F] (t : F) (S₀ S₁ Sinf : Finset (Place K F)) (ψ : ℕ) (g : ℤ) (h₀ : ∀ v ∈ S₀, v.ordDiff
+  (KaehlerDifferential.D K F t) = v.ord t - 1 ∧ 0 < v.ord t ∧ v.ord t ∣ 3) (h₁ : ∀ v ∈ S₁, v.ordDiff
+  (KaehlerDifferential.D K F t) = v.ord (t - algebraMap K F 1728) - 1 ∧ 0 < v.ord (t - algebraMap K
+  F 1728) ∧ v.ord (t - algebraMap K F 1728) ∣ 2) (hinf : ∀ v ∈ Sinf, v.ordDiff
+  (KaehlerDifferential.D K F t) = v.ord t - 1 ∧ v.ord t < 0) (hψ₀ : ∑ v ∈ S₀, v.ord t = ψ) (hψ₁ : ∑
+  v ∈ S₁, v.ord (t - algebraMap K F 1728) = ψ) (hψinf : ∑ v ∈ Sinf, -v.ord t = ψ) (S : Finset (Place
+  K F)) (hS : ∀ v, v ∈ S ↔ v ∈ S₀ ∨ v ∈ S₁ ∨ v ∈ Sinf) (hcan : ∑ v ∈ S, v.ordDiff
+  (KaehlerDifferential.D K F t) = 2 * g - 2) :
+    12 * g = 12 + ψ - 3 * ((S₁.filter fun v => v.ord (t - algebraMap K F 1728) = 1).card : ℤ) - 4 *
+      ((S₀.filter fun v => v.ord t = 1).card : ℤ) - 6 * (Sinf.card : ℤ) :=
+  solution t S₀ S₁ Sinf ψ g h₀ h₁ hinf hψ₀ hψ₁ hψinf S hS hcan
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_weilDualityAdelic_of_functionFieldRiemannRoch_of_stichtenothGenusExists.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_weilDualityAdelic_of_functionFieldRiemannRoch_of_stichtenothGenusExists.lean
new file mode 100644
index 0000000000..540c7b4865
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_weilDualityAdelic_of_functionFieldRiemannRoch_of_stichtenothGenusExists.lean
@@ -0,0 +1,127 @@
+/-
+Based on Prove2Me node
+AlgebraicCurve.weilDualityAdelic_of_functionFieldRiemannRoch_of_stichtenothGenusExists
+(d4f063ae-a924-5f01-9ff2-f039622ce835) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7d34e6b1-f520-5ec8-8ad5-a738bb62ab90
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RiemannRochRows
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_zero_of_degree_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_indexOfSpecialty_eq_of_genusReached
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Weil duality from Riemann–Roch and existence of the genus
+
+Theorem statement:
+`AlgebraicCurve.weilDualityAdelic_of_functionFieldRiemannRoch_of_stichtenothGenusExists`
+(`d4f063ae-a924-5f01-9ff2-f039622ce835`), by Claude, 2026-09-05.
+
+Proof: submission `7d34e6b1-f520-5ec8-8ad5-a738bb62ab90`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra. Two hypotheses are assumed. First,
+`FunctionFieldRiemannRoch K F`: whenever $F/K$ carries the curve structure `IsCurveOver` (principal
+divisors, each place with residue field finite-dimensional over $K$, and $\Omega_{F/K}$ free of rank
+one over $F$), `HasCanonicalDivisor` holds (every nonzero $\omega \in \Omega_{F/K}$ has a divisor
+whose value at each place $v$ is $\operatorname{ord}_v$ of the differential), and every place
+satisfies `DCoordGenerates` (its coordinate differential spans $\Omega_{F/K}$ over $F$), then for
+every nonzero $\omega$ and every divisor $D$ one has $\ell(D) - \ell(K_\omega - D) = \deg D + 1 -
+g$, where $K_\omega$ is the canonical divisor attached to $\omega$, $\ell$ denotes $\dim_K$ of the
+Riemann–Roch space and $g$ is the genus defined from the degree of a canonical divisor. Second,
+`StichtenothGenusExists K F`: the set of places is non-empty, $L(0)$ is finite-dimensional over $K$,
+and there are an integer $\gamma$ and a divisor $D_0$ with $L(D_0)$ finite-dimensional, $\deg D_0 -
+\ell(D_0) = \gamma - 1$, and $\deg D - \ell(D) \le \gamma - 1$ for all divisors $D$. The conclusion
+is `WeilDualityAdelic K F`: under the same three instance assumptions, for every nonzero $\omega \in
+\Omega_{F/K}$ and every divisor $D$, the index of specialty $i(D)$, namely $\dim_K$ of the adele
+space modulo the sum of the bounded adeles of $D$ and the global subspace, equals $\ell(K_\omega -
+D)$.
+
+This is the dimension form of Serre–Weil duality for a function field of one variable, $i(D) =
+\ell(W - D)$ for $W$ canonical, here derived from the Riemann–Roch equality together with Riemann's
+theorem on the existence of the genus rather than from a theory of Weil differentials. It feeds the
+adelic side of the Riemann–Roch package and is used, among other places, in the counting of torsion
+in $\mathrm{Pic}^0$ and in the characterisation of genus zero.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_weilDualityAdelic_of_functionFieldRiemannRoch_of_stichtenothGenusExists.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_de39a060
+
+
+open AlgebraicCurve
+
+theorem solution
+    {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (hRR : AlgebraicCurve.FunctionFieldRiemannRoch K F)
+    (hSG : AlgebraicCurve.StichtenothGenusExists K F) :
+    AlgebraicCurve.WeilDualityAdelic K F := by
+  intro _instCurve _instCan _instDC ω hω D
+  obtain ⟨⟨v⟩, hfd, γ, D₀, hγ⟩ := hSG
+  have : Nonempty (Place K F) := ⟨v⟩
+  have : FiniteDimensional K ↥(LSpace (0 : Divisor K F)) := hfd
+  have hi : ∀ D' : Divisor K F,
+      (indexOfSpecialty D' : ℤ) = (ell D' : ℤ) - (Divisor.degree D' + 1 - γ) :=
+    fun D' => (indexOfSpecialty_eq_of_genusReached hγ D').2
+  have hdegv : 0 < (v.deg : ℤ) := by
+    have : Module.Finite K v.ResidueField := IsCurveOver.finiteResidue v
+    exact_mod_cast (Module.finrank_pos : 0 < Module.finrank K v.ResidueField)
+  have hγle : γ ≤ (genus K F : ℤ) := by
+    have h₁ := hRR hω D₀
+    have h₂ := hγ.eq
+    have h₃ : (0 : ℤ) ≤ (ell (canonicalDivisorOf hω - D₀) : ℤ) := Nat.cast_nonneg _
+    linarith
+  have hgeγ : (genus K F : ℤ) ≤ γ := by
+    set D₁ : Divisor K F := canonicalDivisorOf hω + Finsupp.single v 1 with hD₁
+    have hKD : canonicalDivisorOf hω - D₁ = -Finsupp.single v 1 := by
+      rw [hD₁]; abel
+    have hneg : Divisor.degree (canonicalDivisorOf hω - D₁) < 0 := by
+      rw [hKD, map_neg, Divisor.degree_single]
+      linarith
+    have hℓ : ell (canonicalDivisorOf hω - D₁) = 0 := ell_eq_zero_of_degree_neg hneg
+    have h₁ := hRR hω D₁
+    have h₂ := hγ.isMax D₁
+    rw [hℓ] at h₁
+    push_cast at h₁
+    linarith
+  have hγg : γ = (genus K F : ℤ) := le_antisymm hγle hgeγ
+  have h₁ := hi D
+  have h₂ := hRR hω D
+  rw [hγg] at h₁
+  linarith
+
+end S_OVERLONG_de39a060
+end P2MW
+export P2MW.S_OVERLONG_de39a060
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.weilDualityAdelic_of_functionFieldRiemannRoch_of_stichtenothGenusExists
+    {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (hRR : AlgebraicCurve.FunctionFieldRiemannRoch K F)
+    (hSG : AlgebraicCurve.StichtenothGenusExists K F) :
+    AlgebraicCurve.WeilDualityAdelic K F :=
+  solution hRR hSG
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_weilDualityAdelic_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_weilDualityAdelic_of_isAlgClosed.lean
new file mode 100644
index 0000000000..90bb18a913
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_AlgebraicCurve_weilDualityAdelic_of_isAlgClosed.lean
@@ -0,0 +1,139 @@
+/-
+Based on Prove2Me node AlgebraicCurve.weilDualityAdelic_of_isAlgClosed
+(c3739bd6-5f0a-590c-91c9-7b991a50d3c6) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 31192539-73c9-5b40-8166-5c0017e12da2
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_LocalResidue
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RiemannRochRows
+
+import Mathlib.RingTheory.Finiteness.ModuleFinitePresentation
+import Mathlib.RingTheory.TotallySplit
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_constantsAreBase_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_stichtenothGenusExists_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_weilDualityAdelic_of_functionFieldRiemannRoch_of_stichtenothGenusExists
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Adelic Weil duality over an algebraically closed constant field
+
+Theorem statement: `AlgebraicCurve.weilDualityAdelic_of_isAlgClosed`
+(`c3739bd6-5f0a-590c-91c9-7b991a50d3c6`), by Claude, 2026-09-05.
+
+Proof: submission `31192539-73c9-5b40-8166-5c0017e12da2`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field and $F$ a field equipped with a $K$-algebra structure,
+subject to the following hypotheses. First, the divisor-theoretic data on $F/K$:
+`HasCanonicalDivisor` for $F/K$, i.e. every nonzero differential $\omega \in \Omega_{F/K}$ admits a
+divisor (a finitely supported integer-valued function on places) whose value at each place $v$ is
+$v.\mathrm{ordDifferential}\,\omega$; `HasPrincipalDivisors` for $F/K$, i.e. every $f \neq 0$ has a
+degree-zero divisor with values $v.\mathrm{ord}\,f$; `DCoordGenerates` at every place $w$ of $F/K$,
+i.e. $w.\mathrm{dCoord}$ spans the relevant $F$-module; `FiniteResidue` at every place, i.e. each
+residue field is finite over $K$; and $\Omega_{F/K}$ nontrivial. Second, `IsCurveOver K F`, i.e.
+principal divisors exist with degree zero, all residue fields are finite over $K$, and
+$\Omega_{F/K}$ is free of rank one over $F$; likewise `IsCurveOver K (RatFunc K)`, together with
+finiteness of residue fields, `DCoordGenerates` at all places, and nontriviality of
+$\Omega_{K(x)/K}$ for the rational function field. Third, a presentation of $F$ over the rational
+function field: a $K(x)$-algebra structure on $F$ compatible with $K$, integral, module-finite,
+finite-dimensional and separable. Fourth, the residue data: `HasLocalResidue K F`, i.e. each place
+carries a $K$-linear map $F \to$ residue field vanishing on the valuation subring and sending $f$
+with $\pi f$ integral to the residue class of $\pi f$; `HasCanonicalLocalResidueKStar K F`,
+providing a canonical local residue datum over $K$ at every place; and `HasSeparableResidue K F`,
+i.e. the trace form $\mathrm{Tr}_{K}$ of each residue field is a nonzero $K$-linear map. Then
+`WeilDualityAdelic K F` holds: for any instances of `IsCurveOver K F`, `HasCanonicalDivisor` and
+`DCoordGenerates` at all places, and for every nonzero $\omega \in \Omega_{F/K}$ and every divisor
+$D$, the index of specialty of $D$ — the $K$-dimension of the adele space modulo the sum of the
+bounded adeles attached to $D$ and the image of the global subspace — equals, as an integer, the
+invariant `ell` of the divisor $(\omega) - D$, where $(\omega)$ is the canonical divisor attached to
+$\omega$.
+
+This is the dimension form of Serre–Weil duality for a function field of one variable over an
+algebraically closed constant field, $i(D) = \ell((\omega) - D)$. It is used in the modular-curve
+part of the development, where it supports the computation of the degree of a canonical divisor as
+$2g - 2$ and the identification of the genus of the modular function field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_weilDualityAdelic_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_weilDualityAdelic_of_isAlgClosed
+
+
+open AlgebraicCurve
+
+theorem solution
+    {K F : Type*} [Field K] [IsAlgClosed K]
+    [Field F] [Algebra K F]
+    [AlgebraicCurve.HasCanonicalDivisor (K := K) (F := F)]
+    [∀ w : AlgebraicCurve.Place K F, w.DCoordGenerates]
+    [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [Algebra.IsIntegral (RatFunc K) F]
+    [AlgebraicCurve.HasLocalResidue K F]
+    [∀ w : AlgebraicCurve.Place K F, w.FiniteResidue]
+    [Nontrivial Ω[F⁄K]]
+    [AlgebraicCurve.IsCurveOver K F] [AlgebraicCurve.IsCurveOver K (RatFunc K)]
+    [∀ u : AlgebraicCurve.Place K (RatFunc K), u.FiniteResidue]
+    [AlgebraicCurve.HasCanonicalLocalResidueKStar K F]
+    [Algebra.IsSeparable (RatFunc K) F]
+    [Nontrivial Ω[(RatFunc K)⁄K]] [∀ v : AlgebraicCurve.Place K (RatFunc K), v.DCoordGenerates]
+    [FiniteDimensional (RatFunc K) F] [AlgebraicCurve.HasSeparableResidue K F] :
+    AlgebraicCurve.WeilDualityAdelic K F := by
+  classical
+  have hC : ConstantsAreBase K F := constantsAreBase_of_isAlgClosed K F
+  have : Algebra.EssFiniteType (Polynomial K) (RatFunc K) :=
+    Algebra.EssFiniteType.of_isLocalization (RatFunc K) (nonZeroDivisors (Polynomial K))
+  have : Algebra.EssFiniteType K (RatFunc K) :=
+    Algebra.EssFiniteType.comp K (Polynomial K) (RatFunc K)
+  have : Algebra.EssFiniteType K F := Algebra.EssFiniteType.comp K (RatFunc K) F
+  intro _i1 _i2 _i3 ω hω D
+  exact weilDualityAdelic_of_functionFieldRiemannRoch_of_stichtenothGenusExists (K := K) (F := F)
+    functionFieldRiemannRoch_of_isAlgClosed (stichtenothGenusExists_of_isCurveOver hC) hω D
+
+end S_AlgebraicCurve_weilDualityAdelic_of_isAlgClosed
+end P2MW
+export P2MW.S_AlgebraicCurve_weilDualityAdelic_of_isAlgClosed (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem AlgebraicCurve.weilDualityAdelic_of_isAlgClosed
+    {K F : Type*} [Field K] [IsAlgClosed K]
+    [Field F] [Algebra K F]
+    [AlgebraicCurve.HasCanonicalDivisor (K := K) (F := F)]
+    [∀ w : AlgebraicCurve.Place K F, w.DCoordGenerates]
+    [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [Algebra.IsIntegral (RatFunc K) F]
+    [AlgebraicCurve.HasLocalResidue K F]
+    [∀ w : AlgebraicCurve.Place K F, w.FiniteResidue]
+    [Nontrivial Ω[F⁄K]]
+    [AlgebraicCurve.IsCurveOver K F] [AlgebraicCurve.IsCurveOver K (RatFunc K)]
+    [∀ u : AlgebraicCurve.Place K (RatFunc K), u.FiniteResidue]
+    [AlgebraicCurve.HasCanonicalLocalResidueKStar K F]
+    [Algebra.IsSeparable (RatFunc K) F]
+    [Nontrivial Ω[(RatFunc K)⁄K]] [∀ v : AlgebraicCurve.Place K (RatFunc K), v.DCoordGenerates]
+    [FiniteDimensional (RatFunc K) F] [AlgebraicCurve.HasSeparableResidue K F] :
+    AlgebraicCurve.WeilDualityAdelic K F := by
+  classical
+  exact solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_CohCarrier_index_gammaH_eq_index_gamma0_mul_index.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_CohCarrier_index_gammaH_eq_index_gamma0_mul_index.lean
new file mode 100644
index 0000000000..878e1d2c38
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_CohCarrier_index_gammaH_eq_index_gamma0_mul_index.lean
@@ -0,0 +1,110 @@
+/-
+Based on Prove2Me node CohCarrier.index_gammaH_eq_index_gamma0_mul_index
+(08c97bc6-c88b-5445-977e-d55a3eb472fb) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 763fa740-d423-5f46-b4de-f73f0e624b4e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_CohCarrier_Level
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Index of Γ_H(M) as product of indices
+
+Theorem statement: `CohCarrier.index_gammaH_eq_index_gamma0_mul_index`
+(`08c97bc6-c88b-5445-977e-d55a3eb472fb`), by Claude, 2026-09-05.
+
+Proof: submission `763fa740-d423-5f46-b4de-f73f0e624b4e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a natural number, assumed nonzero, and let $H$ be a subgroup of the unit group
+$(\mathbb{Z}/M)^\times$. Write $\Gamma_0(M)$ for the congruence subgroup of
+$\mathrm{SL}_2(\mathbb{Z})$ consisting of matrices whose lower-left entry is divisible by $M$, and
+let [`CohCarrier.gamma0Units`](def/CohCarrier_Level.html#L121) be the group homomorphism
+$\Gamma_0(M) \to (\mathbb{Z}/M)^\times$ sending $\gamma$ to the unit with value the reduction mod
+$M$ of the lower-right entry of $\gamma$ and inverse the reduction of the upper-left entry. The
+subgroup [`CohCarrier.GammaH M H`](def/CohCarrier_Level.html#L133) of $\mathrm{SL}_2(\mathbb{Z})$
+is, by definition, the image under the inclusion $\Gamma_0(M) \hookrightarrow
+\mathrm{SL}_2(\mathbb{Z})$ of the preimage of $H$ under this homomorphism, i.e. the set of $\gamma
+\in \Gamma_0(M)$ whose lower-right entry reduces into $H$. The assertion is the equality of natural
+numbers
+$$[\mathrm{SL}_2(\mathbb{Z}) : \Gamma_H(M)] = [\mathrm{SL}_2(\mathbb{Z}) : \Gamma_0(M)] \cdot
+[(\mathbb{Z}/M)^\times : H],$$
+the first two indices being taken in $\mathrm{SL}_2(\mathbb{Z})$ and the last in
+$(\mathbb{Z}/M)^\times$.
+
+This is the standard multiplicativity of indices for the intermediate congruence subgroups
+$\Gamma_1(M) \le \Gamma_H(M) \le \Gamma_0(M)$, in the form that reduces the index of $\Gamma_H(M)$
+to the classical index $\psi(M)$ of $\Gamma_0(M)$ times the index of $H$ in $(\mathbb{Z}/M)^\times$.
+It is used in the cohomological bookkeeping for the carrier modules at level $H$, for instance in
+the vanishing statement
+[`CohCarrier.subsingleton_H2_gamma0_of_isUnit_index`]
+(thm.html#CohCarrier.subsingleton_H2_gamma0_of_isUnit_index)
+and in the diamond-operator orbit estimates at full level.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_CohCarrier_index_gammaH_eq_index_gamma0_mul_index.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_CohCarrier_index_gammaH_eq_index_gamma0_mul_index
+
+open scoped MatrixGroups in
+private theorem igIDX_gamma0Units_surjective (M : ℕ) [NeZero M] :
+    Function.Surjective (CohCarrier.gamma0Units M) := by
+  intro u
+  have hAD : (((((u⁻¹ : (ZMod M)ˣ) : ZMod M).val : ℤ) * ((u : ZMod M).val : ℤ) - 1 : ℤ) : ZMod M) =
+    0 :=
+    by
+    simp
+  obtain ⟨k, hk⟩ := (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp hAD
+  let γ : SL(2, ℤ) :=
+    ⟨!![(((u⁻¹ : (ZMod M)ˣ) : ZMod M).val : ℤ), k; (M : ℤ), ((u : ZMod M).val : ℤ)], by
+    rw [Matrix.det_fin_two_of]
+    linarith⟩
+  have hγ0 : γ ∈ CongruenceSubgroup.Gamma0 M := by
+    rw [CongruenceSubgroup.Gamma0_mem]
+    simp [γ]
+  refine ⟨⟨γ, hγ0⟩, Units.ext ?_⟩
+  simp only [CohCarrier.gamma0Units, MonoidHom.coe_mk, OneHom.coe_mk, CongruenceSubgroup.Gamma0Map]
+  simp [γ]
+
+open scoped MatrixGroups in
+theorem solution (M : ℕ) [NeZero M]
+    (H : Subgroup (ZMod M)ˣ) :
+    (CohCarrier.GammaH M H).index = (CongruenceSubgroup.Gamma0 M).index * H.index := by
+  rw [CohCarrier.GammaH, Subgroup.index_map_subtype,
+    Subgroup.index_comap_of_surjective _ (igIDX_gamma0Units_surjective M), mul_comm]
+
+end S_CohCarrier_index_gammaH_eq_index_gamma0_mul_index
+end P2MW
+export P2MW.S_CohCarrier_index_gammaH_eq_index_gamma0_mul_index (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups in
+theorem CohCarrier.index_gammaH_eq_index_gamma0_mul_index (M : ℕ) [NeZero M]
+    (H : Subgroup (ZMod M)ˣ) :
+    (CohCarrier.GammaH M H).index = (CongruenceSubgroup.Gamma0 M).index * H.index :=
+  solution M H
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Complex_exists_hasDerivAt_of_starConvex.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Complex_exists_hasDerivAt_of_starConvex.lean
new file mode 100644
index 0000000000..5423c8519e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Complex_exists_hasDerivAt_of_starConvex.lean
@@ -0,0 +1,212 @@
+/-
+Based on Prove2Me node Complex.exists_hasDerivAt_of_starConvex
+(620cd8a6-4810-566a-8993-a7ccfbce4fdf) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b2777dd9-297d-5449-95aa-f047de9cea72
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.CStarAlgebra.Classes
+public import Mathlib.Analysis.Calculus.Deriv.Basic
+
+import Mathlib.Analysis.Complex.CauchyIntegral
+import Mathlib.Analysis.LocallyConvex.AbsConvexOpen
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Primitives of holomorphic functions on star-shaped domains
+
+Theorem statement: `Complex.exists_hasDerivAt_of_starConvex`
+(`620cd8a6-4810-566a-8993-a7ccfbce4fdf`), by Claude, 2026-09-05.
+
+Proof: submission `b2777dd9-297d-5449-95aa-f047de9cea72`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $U \subseteq \mathbb{C}$ be an open set, let $q \in U$, and suppose $U$ is star-convex with
+respect to $q$ over $\mathbb{R}$, i.e. for every $z \in U$ and every $t \in [0,1]$ the point $(1-t)q
++ tz$ lies in $U$. Let $f : \mathbb{C} \to \mathbb{C}$ be complex differentiable on $U$ (in the
+sense of `DifferentiableOn ℂ f U`, differentiability within $U$ at each point of $U$). The
+conclusion asserts the existence of a function $g : \mathbb{C} \to \mathbb{C}$, defined on all of
+$\mathbb{C}$, such that $g(q) = 0$ and such that for every $z \in U$ the function $g$ has derivative
+$f(z)$ at $z$ in the strong sense of `HasDerivAt g (f z) z`, that is, differentiability at $z$ with
+respect to the full neighbourhood filter of $z$ in $\mathbb{C}$, not merely within $U$. Thus $f$
+admits a primitive on $U$ normalised to vanish at the centre $q$.
+
+This is the holomorphic Poincaré lemma for star-shaped domains: a holomorphic function on a star
+domain is the derivative of a holomorphic function, the star-shaped generalisation of the disc case
+available in Mathlib. It is used in the construction of primitives on the cells of a dissection of
+an algebraic curve, in the comparison of path integrals with periods and residues, and in the
+construction of Eichler integrals of Eisenstein series.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Complex_exists_hasDerivAt_of_starConvex.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_Complex_exists_hasDerivAt_of_starConvex
+
+open scoped Interval Topology
+open Set Filter MeasureTheory intervalIntegral Metric
+
+namespace RadialPrimitive
+
+theorem main {U : Set ℂ} (hU : IsOpen U) {q : ℂ}
+    (hstar : StarConvex ℝ q U) {f : ℂ → ℂ} (hf : DifferentiableOn ℂ f U) :
+    ∃ g : ℂ → ℂ, g q = 0 ∧ ∀ z ∈ U, HasDerivAt g (f z) z := by
+  have hseg : ∀ z ∈ U, ∀ t ∈ Icc (0 : ℝ) 1, q + (t : ℂ) * (z - q) ∈ U := by
+    intro z hz t ht
+    have h := hstar hz (sub_nonneg.2 ht.2) ht.1 (sub_add_cancel 1 t)
+    have heq : (1 - t) • q + t • z = q + (t : ℂ) * (z - q) := by
+      rw [Complex.real_smul, Complex.real_smul]
+      push_cast
+      ring
+    rw [heq] at h
+    exact h
+  set F : ℂ → ℝ → ℂ := fun w t => (w - q) * f (q + (t : ℂ) * (w - q)) with hF
+  set F' : ℂ → ℝ → ℂ := fun w t =>
+    f (q + (t : ℂ) * (w - q)) + (w - q) * ((t : ℂ) * deriv f (q + (t : ℂ) * (w - q))) with hF'
+  have hfc : ContinuousOn f U := hf.continuousOn
+  have hf'c : ContinuousOn (deriv f) U := ((hf.analyticOnNhd hU).deriv).continuousOn
+  have hpath : ∀ w, Continuous fun t : ℝ => q + (t : ℂ) * (w - q) := by
+    intro w; fun_prop
+  have hFc : ∀ w ∈ U, ContinuousOn (F w) (Icc (0 : ℝ) 1) := by
+    intro w hw
+    refine continuousOn_const.mul (hfc.comp (hpath w).continuousOn fun t ht => hseg w hw t ht)
+  have hF'c : ∀ w ∈ U, ContinuousOn (F' w) (Icc (0 : ℝ) 1) := by
+    intro w hw
+    refine (hfc.comp (hpath w).continuousOn fun t ht => hseg w hw t ht).add ?_
+    refine continuousOn_const.mul (Complex.continuous_ofReal.continuousOn.mul ?_)
+    exact hf'c.comp (hpath w).continuousOn fun t ht => hseg w hw t ht
+  have hmeas : ∀ G : ℝ → ℂ, ContinuousOn G (Icc (0 : ℝ) 1) →
+      AEStronglyMeasurable G (volume.restrict (Ι (0 : ℝ) 1)) := by
+    intro G hG
+    rw [uIoc_of_le zero_le_one]
+    exact (hG.aestronglyMeasurable measurableSet_Icc).mono_measure
+      (Measure.restrict_mono Ioc_subset_Icc_self le_rfl)
+  refine ⟨fun w => ∫ t in (0 : ℝ)..1, F w t, ?_, fun z₀ hz₀ => ?_⟩
+  · simp only [hF, sub_self, zero_mul, intervalIntegral.integral_zero]
+  obtain ⟨δ, hδ, hball⟩ : ∃ δ > 0, closedBall z₀ δ ⊆ U :=
+    nhds_basis_closedBall.mem_iff.1 (hU.mem_nhds hz₀)
+  set K : Set ℂ :=
+    (fun p : ℂ × ℝ => q + (p.2 : ℂ) * (p.1 - q)) '' (closedBall z₀ δ ×ˢ Icc (0 : ℝ) 1) with hK
+  have hKc : IsCompact K :=
+    ((isCompact_closedBall z₀ δ).prod isCompact_Icc).image (by fun_prop)
+  have hKU : K ⊆ U := by
+    rintro _ ⟨⟨w, t⟩, ⟨hw, ht⟩, rfl⟩
+    exact hseg w (hball hw) t ht
+  obtain ⟨M₁, hM₁⟩ := hKc.exists_bound_of_continuousOn (hfc.mono hKU)
+  obtain ⟨M₂, hM₂⟩ := hKc.exists_bound_of_continuousOn (hf'c.mono hKU)
+  have hM₁0 : 0 ≤ M₁ := (norm_nonneg _).trans (hM₁ _ ⟨⟨z₀, 0⟩, ⟨mem_closedBall_self hδ.le,
+    left_mem_Icc.2 zero_le_one⟩, rfl⟩)
+  have hM₂0 : 0 ≤ M₂ := (norm_nonneg _).trans (hM₂ _ ⟨⟨z₀, 0⟩, ⟨mem_closedBall_self hδ.le,
+    left_mem_Icc.2 zero_le_one⟩, rfl⟩)
+  have hmemK : ∀ w ∈ closedBall z₀ δ, ∀ t ∈ Ι (0 : ℝ) 1, q + (t : ℂ) * (w - q) ∈ K := by
+    intro w hw t ht
+    rw [uIoc_of_le zero_le_one] at ht
+    exact ⟨⟨w, t⟩, ⟨hw, Ioc_subset_Icc_self ht⟩, rfl⟩
+  have hdiffF : ∀ t ∈ Ι (0 : ℝ) 1, ∀ w ∈ closedBall z₀ δ,
+      HasDerivAt (fun w => F w t) (F' w t) w := by
+    intro t ht w hw
+    have hp : q + (t : ℂ) * (w - q) ∈ U := hKU (hmemK w hw t ht)
+    have h1 : HasDerivAt (fun w : ℂ => w - q) 1 w := (hasDerivAt_id w).sub_const q
+    have h2 : HasDerivAt (fun w : ℂ => q + (t : ℂ) * (w - q)) ((t : ℂ) * 1) w :=
+      (h1.const_mul (t : ℂ)).const_add q
+    have h3 : HasDerivAt f (deriv f (q + (t : ℂ) * (w - q))) (q + (t : ℂ) * (w - q)) :=
+      (hf.differentiableAt (hU.mem_nhds hp)).hasDerivAt
+    have h4 := h1.mul (h3.comp w h2)
+    refine h4.congr_deriv ?_
+    simp only [hF', mul_one, one_mul, Function.comp_apply]
+    ring
+  have hbound : ∀ t ∈ Ι (0 : ℝ) 1, ∀ w ∈ closedBall z₀ δ,
+      ‖F' w t‖ ≤ M₁ + (δ + ‖z₀ - q‖) * M₂ := by
+    intro t ht w hw
+    have hK' := hmemK w hw t ht
+    have ht1 : ‖(t : ℂ)‖ ≤ 1 := by
+      rw [uIoc_of_le zero_le_one] at ht
+      rw [Complex.norm_real, Real.norm_eq_abs, abs_of_pos ht.1]
+      exact ht.2
+    have hwq : ‖w - q‖ ≤ δ + ‖z₀ - q‖ := by
+      have : w - q = (w - z₀) + (z₀ - q) := by ring
+      rw [this]
+      refine (norm_add_le _ _).trans (add_le_add ?_ le_rfl)
+      rwa [← dist_eq_norm]
+    calc ‖F' w t‖ ≤ ‖f (q + (t : ℂ) * (w - q))‖ +
+          ‖w - q‖ * (‖(t : ℂ)‖ * ‖deriv f (q + (t : ℂ) * (w - q))‖) := by
+            simp only [hF']
+            refine (norm_add_le _ _).trans (add_le_add le_rfl ?_)
+            rw [norm_mul, norm_mul]
+      _ ≤ M₁ + (δ + ‖z₀ - q‖) * (1 * M₂) := by
+            gcongr
+            · exact hM₁ _ hK'
+            · exact hM₂ _ hK'
+      _ = M₁ + (δ + ‖z₀ - q‖) * M₂ := by ring
+  have hz₀U : ∀ᶠ w in 𝓝 z₀, w ∈ U := hU.mem_nhds hz₀
+  have key := intervalIntegral.hasDerivAt_integral_of_dominated_loc_of_deriv_le
+    (μ := volume) (a := (0 : ℝ)) (b := 1) (F := F) (F' := F') (x₀ := z₀) (s := closedBall z₀ δ)
+    (bound := fun _ => M₁ + (δ + ‖z₀ - q‖) * M₂)
+    (closedBall_mem_nhds z₀ hδ)
+    (hz₀U.mono fun w hw => hmeas _ (hFc w hw))
+    ((hFc z₀ hz₀).intervalIntegrable_of_Icc (zero_le_one' ℝ))
+    (hmeas _ (hF'c z₀ hz₀))
+    (Eventually.of_forall fun t ht w hw => hbound t ht w hw)
+    _root_.intervalIntegrable_const
+    (Eventually.of_forall fun t ht w hw => hdiffF t ht w hw)
+  have hval : (∫ t in (0 : ℝ)..1, F' z₀ t) = f z₀ := by
+    set v : ℂ := z₀ - q with hv
+    have hG : ∀ t ∈ uIcc (0 : ℝ) 1,
+        HasDerivAt (fun t : ℝ => (t : ℂ) * f (q + (t : ℂ) * v)) (F' z₀ t) t := by
+      intro t ht
+      rw [uIcc_of_le zero_le_one] at ht
+      have hp : q + (t : ℂ) * v ∈ U := hseg z₀ hz₀ t ht
+      have h1 : HasDerivAt (fun t : ℝ => (t : ℂ)) 1 t := (hasDerivAt_id t).ofReal_comp
+      have h2 : HasDerivAt (fun t : ℝ => q + (t : ℂ) * v) (1 * v) t :=
+        (h1.mul_const v).const_add q
+      have h3 : HasDerivAt f (deriv f (q + (t : ℂ) * v)) (q + (t : ℂ) * v) :=
+        (hf.differentiableAt (hU.mem_nhds hp)).hasDerivAt
+      have h4 := h1.mul (h3.comp t h2)
+      refine h4.congr_deriv ?_
+      simp only [hF', one_mul, Function.comp_apply, hv]
+      ring
+    rw [intervalIntegral.integral_eq_sub_of_hasDerivAt hG
+      ((hF'c z₀ hz₀).intervalIntegrable_of_Icc (zero_le_one' ℝ))]
+    simp only [Complex.ofReal_one, Complex.ofReal_zero, one_mul, zero_mul, sub_zero]
+    congr 1
+    rw [hv]
+    ring
+  rw [← hval]
+  exact key.2
+
+end RadialPrimitive
+
+theorem solution {U : Set ℂ} (hU : IsOpen U) {q : ℂ} (hq : q ∈ U)
+    (hstar : StarConvex ℝ q U) {f : ℂ → ℂ} (hf : DifferentiableOn ℂ f U) :
+    ∃ g : ℂ → ℂ, g q = 0 ∧ ∀ z ∈ U, HasDerivAt g (f z) z := by
+  have _hq := hq
+  exact RadialPrimitive.main hU hstar hf
+
+end S_Complex_exists_hasDerivAt_of_starConvex
+end P2MW
+export P2MW.S_Complex_exists_hasDerivAt_of_starConvex (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem Complex.exists_hasDerivAt_of_starConvex {U : Set ℂ} (hU : IsOpen U) {q : ℂ} (hq : q ∈ U)
+    (hstar : StarConvex ℝ q U) {f : ℂ → ℂ} (hf : DifferentiableOn ℂ f U) :
+    ∃ g : ℂ → ℂ, g q = 0 ∧ ∀ z ∈ U, HasDerivAt g (f z) z :=
+  solution hU hq hstar hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Complex_integral_modularFundamentalDomain_eq_boundary_of_hasFDerivAt.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Complex_integral_modularFundamentalDomain_eq_boundary_of_hasFDerivAt.lean
new file mode 100644
index 0000000000..f07e631bf3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Complex_integral_modularFundamentalDomain_eq_boundary_of_hasFDerivAt.lean
@@ -0,0 +1,730 @@
+/-
+Based on Prove2Me node Complex.integral_modularFundamentalDomain_eq_boundary_of_hasFDerivAt
+(9d9521ac-ade0-5beb-9c73-dcdf69ae7004) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8ed62e5d-d6dc-5fce-822e-99319d90d3e6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.CStarAlgebra.Classes
+public import Mathlib.Analysis.Calculus.FDeriv.Defs
+public import Mathlib.LinearAlgebra.Complex.FiniteDimensional
+public import Mathlib.MeasureTheory.Integral.IntervalIntegral.Basic
+
+import Mathlib.Algebra.Order.Star.Real
+import Mathlib.Analysis.LocallyConvex.AbsConvexOpen
+import Mathlib.MeasureTheory.Integral.ExpDecay
+import Mathlib.MeasureTheory.Measure.Lebesgue.Complex
+import Mathlib.Order.CompletePartialOrder
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Stokes' theorem for Φ dz on the modular fundamental domain
+
+Theorem statement: `Complex.integral_modularFundamentalDomain_eq_boundary_of_hasFDerivAt`
+(`9d9521ac-ade0-5beb-9c73-dcdf69ae7004`), by Claude, 2026-09-05.
+
+Proof: submission `8ed62e5d-d6dc-5fce-822e-99319d90d3e6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\mathcal D = \{z \in \mathbb C : |\operatorname{Re} z| \le 1/2,\ \|z\| \ge 1,\
+\operatorname{Im} z > 0\}$, the standard fundamental set for $\mathrm{SL}_2(\mathbb Z)$ acting on
+the upper half-plane, equipped with planar Lebesgue measure. Let $\Phi : \mathbb C \to \mathbb C$ be
+a function, $\Phi'$ an assignment to each point of a continuous $\mathbb R$-linear map $\mathbb C
+\to \mathbb C$, $U \subseteq \mathbb C$ an open set containing $\mathcal D$, and $\delta > 0$.
+Assume that $\Phi$ has Fréchet derivative $\Phi'(z)$ at every $z \in U$ (as a map of real normed
+spaces), that $\Phi'$ is continuous on $U$, and that there exist constants $C$ and $C'$ with
+$\|\Phi(z)\| \le C\,e^{-\delta \operatorname{Im} z}$ and $\|\Phi'(z)\| \le C'\,e^{-\delta
+\operatorname{Im} z}$ for all $z \in U$. Then $$\int_{\mathcal D} \bigl( i\,\Phi'(z)(1) -
+\Phi'(z)(i) \bigr) = i\int_{\sqrt 3/2}^{\infty} \Phi\bigl(\tfrac12 + iy\bigr)\,dy - i\int_{\sqrt
+3/2}^{\infty} \Phi\bigl(-\tfrac12 + iy\bigr)\,dy - \int_{\pi/3}^{2\pi/3} \Phi(e^{i\theta})\, i
+e^{i\theta}\,d\theta,$$ the two vertical integrals being taken over the ray $(\sqrt3/2, \infty)$ and
+the arc integral being an interval integral in $\theta$.
+
+This is Green's (Stokes') theorem for the $1$-form $\Phi\,dz$ on the closed fundamental domain
+$\mathcal D$: the left-hand side is the area integral of $d(\Phi\,dz) = (i\Phi_x - \Phi_y)\,dx\wedge
+dy$, normalised as in Mathlib's rectangle version, and the right-hand side is the integral of
+$\Phi\,dz$ over the boundary of $\mathcal D$ — the two vertical sides $\operatorname{Re} z = \pm
+1/2$ and the unit-circle arc from $e^{2\pi i/3}$ to $e^{\pi i/3}$ — the contribution near the cusp
+being killed by the exponential decay hypotheses; for holomorphic $\Phi$ the left-hand side vanishes
+and one recovers Cauchy's theorem for $\mathcal D$. It underlies the computation of Petersson
+products and period integrals over fundamental sets in terms of side-pairing data, used in the study
+of the Eichler–Shimura map.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Complex_integral_modularFundamentalDomain_eq_boundary_of_hasFDerivAt.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_Complex_integral_modularFundamentalDomain_eq_boundary_of_hasFDerivAt
+
+open MeasureTheory Set Filter Topology
+
+noncomputable section
+
+namespace Complex
+p2m_export "Complex" "re sqrt sin_pi_div_two real_smul hasDerivAt_cos im ofRealCLM mk_eq_add_mul_I \
+  sin measurableEquivRealProd_symm_apply norm_def sin_pi_sub volume_preserving_equiv_real_prod \
+  norm_I cos_pi_sub exp sin_sq cos_sq' exp_ofReal_mul_I_im \
+  integral_boundary_rect_of_hasFDerivAt_real_off_countable measurableEquivRealProd \
+  exp_ofReal_mul_I_re normSq_mk hasDerivAt_sin continuous_ofReal ext I continuous_sin I_mul_I cos \
+  continuous_cos"
+namespace GreenFD
+p2m_open "Complex"
+
+def D : Set ℂ := {z : ℂ | |z.re| ≤ 1 / 2 ∧ 1 ≤ ‖z‖ ∧ 0 < z.im}
+
+def h (x : ℝ) : ℝ := Real.sqrt (1 - x ^ 2)
+
+def T : Set (ℝ × ℝ) := {p | |p.1| ≤ 1 / 2 ∧ h p.1 ≤ p.2}
+
+lemma three_quarters_le {x : ℝ} (hx : |x| ≤ 1 / 2) : 3 / 4 ≤ 1 - x ^ 2 := by
+  have h1 : x ^ 2 ≤ (1 / 2) ^ 2 := by
+    rw [← sq_abs]; exact pow_le_pow_left₀ (abs_nonneg x) hx 2
+  linarith
+
+lemma sqrt3_sq : (Real.sqrt 3 / 2) ^ 2 = 3 / 4 := by
+  rw [div_pow, Real.sq_sqrt (by norm_num)]; norm_num
+
+lemma sqrt3_pos : 0 < Real.sqrt 3 / 2 := by positivity
+
+lemma sqrt3_lt_one : Real.sqrt 3 / 2 < 1 := by
+  rw [div_lt_one two_pos, Real.sqrt_lt' two_pos]; norm_num
+
+lemma sqrt3_le_h {x : ℝ} (hx : |x| ≤ 1 / 2) : Real.sqrt 3 / 2 ≤ h x := by
+  unfold h
+  rw [Real.le_sqrt' sqrt3_pos, sqrt3_sq]
+  exact three_quarters_le hx
+
+lemma h_pos {x : ℝ} (hx : |x| ≤ 1 / 2) : 0 < h x := lt_of_lt_of_le sqrt3_pos (sqrt3_le_h hx)
+
+lemma h_le_one (x : ℝ) : h x ≤ 1 := by
+  unfold h
+  rw [Real.sqrt_le_left zero_le_one]
+  nlinarith [sq_nonneg x]
+
+lemma h_sq {x : ℝ} (hx : |x| ≤ 1 / 2) : h x ^ 2 = 1 - x ^ 2 :=
+  Real.sq_sqrt (le_trans (by norm_num) (three_quarters_le hx))
+
+lemma mem_D_iff {x y : ℝ} : (⟨x, y⟩ : ℂ) ∈ D ↔ |x| ≤ 1 / 2 ∧ h x ≤ y := by
+  simp only [D, mem_ofPred_eq, Complex.norm_def, Complex.normSq_mk, Real.one_le_sqrt]
+  constructor
+  · rintro ⟨hx, hn, hy⟩
+    refine ⟨hx, ?_⟩
+    unfold h
+    rw [Real.sqrt_le_iff]
+    exact ⟨hy.le, by nlinarith⟩
+  · rintro ⟨hx, hy⟩
+    have hpos := h_pos hx
+    have hy' := hy
+    unfold h at hy'
+    rw [Real.sqrt_le_iff] at hy'
+    exact ⟨hx, by nlinarith [hy'.2], lt_of_lt_of_le hpos hy⟩
+
+lemma mk_mem_D {x y : ℝ} (hx : |x| ≤ 1 / 2) (hy : h x ≤ y) : (⟨x, y⟩ : ℂ) ∈ D :=
+  mem_D_iff.mpr ⟨hx, hy⟩
+
+lemma preimage_D : (measurableEquivRealProd.symm : ℝ × ℝ → ℂ) ⁻¹' D = T := by
+  ext ⟨x, y⟩
+  simp only [mem_preimage, measurableEquivRealProd_symm_apply, T, mem_ofPred_eq]
+  exact mem_D_iff
+
+lemma isClosed_T : IsClosed T := by
+  have h1 : IsClosed {p : ℝ × ℝ | |p.1| ≤ 1 / 2} :=
+    isClosed_le (continuous_abs.comp continuous_fst) continuous_const
+  have h2 : IsClosed {p : ℝ × ℝ | h p.1 ≤ p.2} := by
+    refine isClosed_le ?_ continuous_snd
+    exact (Real.continuous_sqrt.comp (continuous_const.sub (continuous_fst.pow 2)))
+  simpa [T, Set.ofPred_and] using h1.inter h2
+
+lemma measurableSet_T : MeasurableSet T := isClosed_T.measurableSet
+
+lemma T_subset_prod : T ⊆ Icc (-(1 / 2 : ℝ)) (1 / 2) ×ˢ Ioi (0 : ℝ) := by
+  rintro ⟨x, y⟩ ⟨hx, hy⟩
+  exact ⟨abs_le.mp hx, lt_of_lt_of_le (h_pos hx) hy⟩
+
+lemma setIntegral_D (G : ℂ → ℂ) : ∫ z in D, G z = ∫ p in T, G ⟨p.1, p.2⟩ := by
+  rw [← preimage_D]
+  exact ((Complex.volume_preserving_equiv_real_prod.symm _).setIntegral_preimage_emb
+    measurableEquivRealProd.symm.measurableEmbedding G D).symm
+
+lemma integrableOn_T_of_bound {G : ℝ × ℝ → ℂ} {C δ : ℝ} (hδ : 0 < δ)
+    (hG : ContinuousOn G T) (hb : ∀ p ∈ T, ‖G p‖ ≤ C * Real.exp (-δ * p.2)) :
+    IntegrableOn G T := by
+  have hdom : IntegrableOn (fun p : ℝ × ℝ => (C : ℝ) * Real.exp (-δ * p.2))
+      (Icc (-(1 / 2 : ℝ)) (1 / 2) ×ˢ Ioi (0 : ℝ)) := by
+    rw [IntegrableOn, Measure.volume_eq_prod, ← Measure.prod_restrict]
+    have h1 : Integrable (fun _ : ℝ => (C : ℝ)) (volume.restrict (Icc (-(1 / 2 : ℝ)) (1 / 2))) :=
+      integrable_const _
+    have h2 : Integrable (fun y : ℝ => Real.exp (-δ * y)) (volume.restrict (Ioi (0 : ℝ))) :=
+      exp_neg_integrableOn_Ioi 0 hδ
+    exact h1.mul_prod h2
+  refine Integrable.mono' (hdom.mono_set T_subset_prod)
+    (hG.aestronglyMeasurable measurableSet_T) ?_
+  exact (ae_restrict_iff' measurableSet_T).mpr (Eventually.of_forall hb)
+
+lemma setIntegral_T_eq_x_y {G : ℝ × ℝ → ℂ} (hG : IntegrableOn G T) :
+    ∫ p in T, G p = ∫ x in Icc (-(1 / 2 : ℝ)) (1 / 2), ∫ y in Ici (h x), G (x, y) := by
+  have hi : Integrable (T.indicator G) (volume.prod volume) := by
+    rw [← Measure.volume_eq_prod]; exact hG.integrable_indicator measurableSet_T
+  rw [← integral_indicator measurableSet_T, Measure.volume_eq_prod, integral_prod _ hi]
+  have hS : {x : ℝ | |x| ≤ 1 / 2} = Icc (-(1 / 2 : ℝ)) (1 / 2) := by
+    ext x; simp [abs_le]
+  rw [← hS, ← integral_indicator (measurableSet_le continuous_abs.measurable measurable_const)]
+  congr 1 with x
+  by_cases hx : |x| ≤ 1 / 2
+  · rw [indicator_of_mem (by exact hx), ← integral_indicator measurableSet_Ici]
+    congr 1 with y
+    by_cases hy : h x ≤ y
+    · rw [indicator_of_mem (show (x, y) ∈ T from ⟨hx, hy⟩), indicator_of_mem (by exact hy)]
+    · rw [indicator_of_notMem (show (x, y) ∉ T from fun hm => hy hm.2),
+        indicator_of_notMem (by exact hy)]
+  · rw [indicator_of_notMem (by exact hx)]
+    have : ∀ y, T.indicator G (x, y) = 0 := fun y =>
+      indicator_of_notMem (show (x, y) ∉ T from fun hm => hx hm.1) _
+    simp [this]
+
+lemma setIntegral_T_eq_y_x {G : ℝ × ℝ → ℂ} (hG : IntegrableOn G T) :
+    ∫ p in T, G p = ∫ y, ∫ x in {x | |x| ≤ 1 / 2 ∧ h x ≤ y}, G (x, y) := by
+  have hi : Integrable (T.indicator G) (volume.prod volume) := by
+    rw [← Measure.volume_eq_prod]; exact hG.integrable_indicator measurableSet_T
+  rw [← integral_indicator measurableSet_T, Measure.volume_eq_prod, integral_prod_symm _ hi]
+  congr 1 with y
+  have hm : MeasurableSet {x : ℝ | |x| ≤ 1 / 2 ∧ h x ≤ y} := by
+    have : IsClosed {x : ℝ | |x| ≤ 1 / 2 ∧ h x ≤ y} := by
+      rw [Set.ofPred_and]
+      exact (isClosed_le continuous_abs continuous_const).inter
+        (isClosed_le (Real.continuous_sqrt.comp (continuous_const.sub (continuous_id.pow 2)))
+          continuous_const)
+    exact this.measurableSet
+  rw [← integral_indicator hm]
+  congr 1 with x
+
+section Hyp
+
+variable (Φ : ℂ → ℂ) (Φ' : ℂ → ℂ →L[ℝ] ℂ) (U : Set ℂ) (δ : ℝ) (hδ : 0 < δ) (hU : IsOpen U)
+  (hDU : D ⊆ U) (hd : ∀ z ∈ U, HasFDerivAt Φ (Φ' z) z) (hc : ContinuousOn Φ' U)
+  (hΦ : ∃ C : ℝ, ∀ z ∈ U, ‖Φ z‖ ≤ C * Real.exp (-δ * z.im))
+  (hΦ' : ∃ C : ℝ, ∀ z ∈ U, ‖Φ' z‖ ≤ C * Real.exp (-δ * z.im))
+
+lemma mk_eq (x y : ℝ) : (⟨x, y⟩ : ℂ) = (x : ℂ) + (y : ℂ) * I := Complex.mk_eq_add_mul_I x y
+
+lemma hasDerivAt_vert {x y : ℝ} (hz : (⟨x, y⟩ : ℂ) ∈ U)
+    (hd : ∀ z ∈ U, HasFDerivAt Φ (Φ' z) z) :
+    HasDerivAt (fun t : ℝ => Φ ⟨x, t⟩) (Φ' ⟨x, y⟩ I) y := by
+  have h1 : HasDerivAt (fun t : ℝ => (x : ℂ) + (t : ℂ) * I) I y := by
+    simpa using ((Complex.ofRealCLM.hasDerivAt (x := y)).mul_const I).const_add (x : ℂ)
+  have h2 : (fun t : ℝ => Φ ⟨x, t⟩) = Φ ∘ fun t : ℝ => (x : ℂ) + (t : ℂ) * I := by
+    ext t; simp [mk_eq]
+  rw [h2]
+  have hz' : (x : ℂ) + (y : ℂ) * I ∈ U := by rwa [← mk_eq]
+  have := (hd _ hz').comp_hasDerivAt y h1
+  rwa [← mk_eq] at this
+
+lemma hasDerivAt_horiz {x y : ℝ} (hz : (⟨x, y⟩ : ℂ) ∈ U)
+    (hd : ∀ z ∈ U, HasFDerivAt Φ (Φ' z) z) :
+    HasDerivAt (fun t : ℝ => Φ ⟨t, y⟩) (Φ' ⟨x, y⟩ 1) x := by
+  have h1 : HasDerivAt (fun t : ℝ => (t : ℂ) + (y : ℂ) * I) 1 x := by
+    simpa using (Complex.ofRealCLM.hasDerivAt (x := x)).add_const ((y : ℂ) * I)
+  have h2 : (fun t : ℝ => Φ ⟨t, y⟩) = Φ ∘ fun t : ℝ => (t : ℂ) + (y : ℂ) * I := by
+    ext t; simp [mk_eq]
+  rw [h2]
+  have hz' : (x : ℂ) + (y : ℂ) * I ∈ U := by rwa [← mk_eq]
+  have := (hd _ hz').comp_hasDerivAt x h1
+  rwa [← mk_eq] at this
+
+lemma continuous_mk_left (x : ℝ) : Continuous fun t : ℝ => (⟨x, t⟩ : ℂ) := by
+  simp only [mk_eq]
+  exact (continuous_const.add (Complex.continuous_ofReal.mul continuous_const))
+
+lemma continuous_mk_right (y : ℝ) : Continuous fun t : ℝ => (⟨t, y⟩ : ℂ) := by
+  simp only [mk_eq]
+  exact (Complex.continuous_ofReal.add continuous_const)
+
+lemma tendsto_const_mul_exp {δ : ℝ} (hδ : 0 < δ) (C : ℝ) :
+    Tendsto (fun t : ℝ => C * Real.exp (-δ * t)) atTop (𝓝 0) := by
+  have h1 : Tendsto (fun t : ℝ => Real.exp (-δ * t)) atTop (𝓝 0) := by
+    refine Real.tendsto_exp_comp_nhds_zero.mpr ?_
+    exact (tendsto_id (α := ℝ) (x := atTop)).const_mul_atTop_of_neg (neg_lt_zero.mpr hδ)
+  simpa using h1.const_mul C
+
+include hδ hDU hd hc hΦ hΦ' in
+lemma integral_vert {x : ℝ} (hx : |x| ≤ 1 / 2) :
+    ∫ y in Ioi (h x), Φ' ⟨x, y⟩ I = -Φ ⟨x, h x⟩ := by
+  obtain ⟨C, hC⟩ := hΦ
+  obtain ⟨C', hC'⟩ := hΦ'
+  have hmem : ∀ t ∈ Ici (h x), (⟨x, t⟩ : ℂ) ∈ U := fun t ht => hDU (mk_mem_D hx ht)
+  have hderiv : ∀ t ∈ Ici (h x), HasDerivAt (fun t : ℝ => Φ ⟨x, t⟩) (Φ' ⟨x, t⟩ I) t :=
+    fun t ht => hasDerivAt_vert Φ Φ' U (hmem t ht) hd
+  have hcont : ContinuousOn (fun t : ℝ => Φ' ⟨x, t⟩ I) (Ici (h x)) := by
+    have h1 : ContinuousOn (fun t : ℝ => Φ' ⟨x, t⟩) (Ici (h x)) :=
+      hc.comp (continuous_mk_left x).continuousOn hmem
+    exact h1.clm_apply continuousOn_const
+  have hint : IntegrableOn (fun t : ℝ => Φ' ⟨x, t⟩ I) (Ioi (h x)) := by
+    have hdom : IntegrableOn (fun t : ℝ => C' * Real.exp (-δ * t)) (Ioi (h x)) :=
+      (exp_neg_integrableOn_Ioi _ hδ).const_mul C'
+    refine Integrable.mono' hdom
+      ((hcont.mono Ioi_subset_Ici_self).aestronglyMeasurable measurableSet_Ioi) ?_
+    refine (ae_restrict_iff' measurableSet_Ioi).mpr (Eventually.of_forall fun t ht => ?_)
+    calc ‖Φ' ⟨x, t⟩ I‖ ≤ ‖Φ' ⟨x, t⟩‖ * ‖I‖ := ContinuousLinearMap.le_opNorm _ _
+      _ = ‖Φ' ⟨x, t⟩‖ := by rw [Complex.norm_I, mul_one]
+      _ ≤ C' * Real.exp (-δ * t) := hC' _ (hmem t (mem_Ici.mpr (le_of_lt ht)))
+  have hlim : Tendsto (fun t : ℝ => Φ ⟨x, t⟩) atTop (𝓝 0) := by
+    refine squeeze_zero_norm' ?_ (tendsto_const_mul_exp hδ C)
+    filter_upwards [Ici_mem_atTop (h x)] with t ht
+    exact hC _ (hmem t ht)
+  rw [integral_Ioi_of_hasDerivAt_of_tendsto' hderiv hint hlim, zero_sub]
+
+include hd in
+lemma integral_horiz {a b y : ℝ} (hab : a ≤ b) (hmem : ∀ t ∈ Icc a b, (⟨t, y⟩ : ℂ) ∈ U)
+    (hc : ContinuousOn Φ' U) :
+    ∫ t in a..b, Φ' ⟨t, y⟩ 1 = Φ ⟨b, y⟩ - Φ ⟨a, y⟩ := by
+  have hderiv : ∀ t ∈ uIcc a b, HasDerivAt (fun t : ℝ => Φ ⟨t, y⟩) (Φ' ⟨t, y⟩ 1) t := by
+    intro t ht
+    rw [uIcc_of_le hab] at ht
+    exact hasDerivAt_horiz Φ Φ' U (hmem t ht) hd
+  have hcont : ContinuousOn (fun t : ℝ => Φ' ⟨t, y⟩ 1) (uIcc a b) := by
+    rw [uIcc_of_le hab]
+    have h1 : ContinuousOn (fun t : ℝ => Φ' ⟨t, y⟩) (Icc a b) :=
+      hc.comp (continuous_mk_right y).continuousOn hmem
+    exact h1.clm_apply continuousOn_const
+  exact intervalIntegral.integral_eq_sub_of_hasDerivAt hderiv (hcont.intervalIntegrable)
+
+def r (y : ℝ) : ℝ := Real.sqrt (1 - y ^ 2)
+
+lemma r_nonneg (y : ℝ) : 0 ≤ r y := Real.sqrt_nonneg _
+
+lemma r_one : r 1 = 0 := by simp [r]
+
+lemma r_pos {y : ℝ} (hy0 : 0 ≤ y) (hy : y < 1) : 0 < r y := by
+  unfold r; apply Real.sqrt_pos.mpr; nlinarith
+
+lemma r_le_half {y : ℝ} (hy : Real.sqrt 3 / 2 ≤ y) : r y ≤ 1 / 2 := by
+  unfold r
+  rw [Real.sqrt_le_left (by norm_num)]
+  have := sqrt3_sq
+  nlinarith [sqrt3_pos]
+
+lemma r_lt_half {y : ℝ} (hy : Real.sqrt 3 / 2 < y) : r y < 1 / 2 := by
+  unfold r
+  rw [Real.sqrt_lt' (by norm_num)]
+  have := sqrt3_sq
+  nlinarith [sqrt3_pos]
+
+lemma h_half : h (1 / 2) = Real.sqrt 3 / 2 := by
+  unfold h
+  rw [show (1 : ℝ) - (1 / 2) ^ 2 = (Real.sqrt 3 / 2) ^ 2 by rw [sqrt3_sq]; norm_num,
+    Real.sqrt_sq sqrt3_pos.le]
+
+lemma h_neg (x : ℝ) : h (-x) = h x := by simp [h]
+
+lemma h_r {y : ℝ} (hy0 : 0 ≤ y) (hy1 : y ≤ 1) : h (r y) = y := by
+  unfold h r
+  rw [Real.sq_sqrt (by nlinarith), sub_sub_cancel, Real.sqrt_sq hy0]
+
+lemma h_le_iff {x y : ℝ} (hy : 0 ≤ y) : h x ≤ y ↔ r y ≤ |x| := by
+  unfold h r
+  rw [Real.sqrt_le_left hy, Real.sqrt_le_left (abs_nonneg x), sq_abs]
+  constructor <;> intro h <;> linarith
+
+lemma slice_of_one_le {y : ℝ} (hy : 1 ≤ y) :
+    {x : ℝ | |x| ≤ 1 / 2 ∧ h x ≤ y} = Icc (-(1 / 2)) (1 / 2) := by
+  ext x
+  simp only [mem_ofPred_eq, mem_Icc, abs_le]
+  exact ⟨fun h => h.1, fun h => ⟨h, (h_le_one x).trans hy⟩⟩
+
+lemma slice_of_lt_one {y : ℝ} (hy0 : 0 ≤ y) (hy : y < 1) :
+    {x : ℝ | |x| ≤ 1 / 2 ∧ h x ≤ y} = Icc (-(1 / 2)) (-r y) ∪ Icc (r y) (1 / 2) := by
+  have hr := r_pos hy0 hy
+  ext x
+  simp only [mem_ofPred_eq, mem_union, mem_Icc, h_le_iff hy0, abs_le, le_abs']
+  constructor
+  · rintro ⟨⟨h1, h2⟩, h3 | h3⟩
+    · exact Or.inl ⟨h1, h3⟩
+    · exact Or.inr ⟨h3, h2⟩
+  · rintro (⟨h1, h2⟩ | ⟨h1, h2⟩)
+    · exact ⟨⟨h1, by linarith⟩, Or.inl h2⟩
+    · exact ⟨⟨by linarith, h2⟩, Or.inr h1⟩
+
+lemma slice_of_lt {y : ℝ} (hy : y < Real.sqrt 3 / 2) : {x : ℝ | |x| ≤ 1 / 2 ∧ h x ≤ y} = ∅ := by
+  ext x
+  simp only [mem_ofPred_eq, mem_empty_iff_false, iff_false, not_and, not_le]
+  exact fun hx => lt_of_lt_of_le hy (sqrt3_le_h hx)
+
+lemma mem_D_r {y : ℝ} (hy : Real.sqrt 3 / 2 ≤ y) (hy1 : y ≤ 1) : (⟨r y, y⟩ : ℂ) ∈ D := by
+  have hy0 : 0 ≤ y := sqrt3_pos.le.trans hy
+  refine mk_mem_D ?_ (h_r hy0 hy1).le
+  rw [abs_of_nonneg (r_nonneg y)]; exact r_le_half hy
+
+lemma mem_D_neg_r {y : ℝ} (hy : Real.sqrt 3 / 2 ≤ y) (hy1 : y ≤ 1) : (⟨-r y, y⟩ : ℂ) ∈ D := by
+  have hy0 : 0 ≤ y := sqrt3_pos.le.trans hy
+  refine mk_mem_D ?_ (by rw [h_neg]; exact (h_r hy0 hy1).le)
+  rw [abs_neg, abs_of_nonneg (r_nonneg y)]; exact r_le_half hy
+
+lemma continuous_r :
+    Continuous r := Real.continuous_sqrt.comp (continuous_const.sub (continuous_id.pow 2))
+
+lemma continuous_mk2 : Continuous fun p : ℝ × ℝ => (⟨p.1, p.2⟩ : ℂ) := by
+  simp only [mk_eq]
+  exact ((Complex.continuous_ofReal.comp continuous_fst).add
+    ((Complex.continuous_ofReal.comp continuous_snd).mul continuous_const))
+
+def corr (y : ℝ) : ℂ := Φ ⟨-r y, y⟩ - Φ ⟨r y, y⟩
+
+include hd hDU in
+lemma continuousOn_corr : ContinuousOn (corr Φ) (Icc (Real.sqrt 3 / 2) 1) := by
+  have hΦc : ContinuousOn Φ U := fun z hz => (hd z hz).continuousAt.continuousWithinAt
+  apply ContinuousOn.sub
+  · refine hΦc.comp (continuous_mk2.comp (continuous_r.neg.prodMk continuous_id)).continuousOn ?_
+    exact fun y hy => hDU (mem_D_neg_r hy.1 hy.2)
+  · refine hΦc.comp (continuous_mk2.comp (continuous_r.prodMk continuous_id)).continuousOn ?_
+    exact fun y hy => hDU (mem_D_r hy.1 hy.2)
+
+include hδ hd hDU hΦ in
+lemma integrableOn_vert {x : ℝ} (hx : |x| ≤ 1 / 2) :
+    IntegrableOn (fun y : ℝ => Φ ⟨x, y⟩) (Ioi (h x)) := by
+  obtain ⟨C, hC⟩ := hΦ
+  have hΦc : ContinuousOn Φ U := fun z hz => (hd z hz).continuousAt.continuousWithinAt
+  have hmem : ∀ t ∈ Ioi (h x), (⟨x, t⟩ : ℂ) ∈ U := fun t ht => hDU (mk_mem_D hx (le_of_lt ht))
+  have hcont : ContinuousOn (fun t : ℝ => Φ ⟨x, t⟩) (Ioi (h x)) :=
+    hΦc.comp (continuous_mk_left x).continuousOn hmem
+  have hdom : IntegrableOn (fun t : ℝ => C * Real.exp (-δ * t)) (Ioi (h x)) :=
+    (exp_neg_integrableOn_Ioi _ hδ).const_mul C
+  refine Integrable.mono' hdom (hcont.aestronglyMeasurable measurableSet_Ioi) ?_
+  exact (ae_restrict_iff' measurableSet_Ioi).mpr (Eventually.of_forall fun t ht => hC _ (hmem t ht))
+
+include hd hDU hc in
+lemma sliceIntegral {y : ℝ} (hy : Real.sqrt 3 / 2 < y) :
+    ∫ x in {x : ℝ | |x| ≤ 1 / 2 ∧ h x ≤ y}, Φ' ⟨x, y⟩ 1 =
+      (Φ ⟨1 / 2, y⟩ - Φ ⟨-(1 / 2), y⟩) + (Iic (1 : ℝ)).indicator (corr Φ) y := by
+  have hy0 : 0 ≤ y := sqrt3_pos.le.trans hy.le
+  rcases lt_or_ge y 1 with hy1 | hy1
+  · rw [indicator_of_mem (show y ∈ Iic (1 : ℝ) from hy1.le), slice_of_lt_one hy0 hy1]
+    have hr := r_pos hy0 hy1
+    have hr' := r_lt_half hy
+    have hmem : ∀ t : ℝ, |t| ≤ 1 / 2 → r y ≤ |t| → (⟨t, y⟩ : ℂ) ∈ U :=
+      fun t ht ht' => hDU (mk_mem_D ht ((h_le_iff hy0).mpr ht'))
+    have hmem₁ : ∀ t ∈ Icc (-(1 / 2 : ℝ)) (-r y), (⟨t, y⟩ : ℂ) ∈ U := fun t ht =>
+      hmem t (abs_le.mpr ⟨ht.1, by linarith [ht.2]⟩) (le_abs'.mpr (Or.inl ht.2))
+    have hmem₂ : ∀ t ∈ Icc (r y) (1 / 2 : ℝ), (⟨t, y⟩ : ℂ) ∈ U := fun t ht =>
+      hmem t (abs_le.mpr ⟨by linarith [ht.1], ht.2⟩) (le_abs'.mpr (Or.inr ht.1))
+    have hcont : ∀ s : Set ℝ, (∀ t ∈ s, (⟨t, y⟩ : ℂ) ∈ U) →
+        ContinuousOn (fun t : ℝ => Φ' ⟨t, y⟩ 1) s := fun s hs =>
+      (hc.comp (continuous_mk_right y).continuousOn hs).clm_apply continuousOn_const
+    rw [setIntegral_union (Set.disjoint_iff.mpr ?_) measurableSet_Icc
+      ((hcont _ hmem₁).integrableOn_Icc) ((hcont _ hmem₂).integrableOn_Icc),
+      integral_Icc_eq_integral_Ioc, integral_Icc_eq_integral_Ioc,
+      ← intervalIntegral.integral_of_le (by linarith), ← intervalIntegral.integral_of_le hr'.le,
+      integral_horiz Φ Φ' U hd (by linarith) hmem₁ hc, integral_horiz Φ Φ' U hd hr'.le hmem₂ hc]
+    · simp only [corr]; ring
+    · rintro t ⟨⟨-, h1⟩, ⟨h2, -⟩⟩; exact absurd (h2.trans h1) (by linarith)
+  · rw [slice_of_one_le hy1, integral_Icc_eq_integral_Ioc,
+      ← intervalIntegral.integral_of_le (by norm_num)]
+    have hmem : ∀ t ∈ Icc (-(1 / 2 : ℝ)) (1 / 2), (⟨t, y⟩ : ℂ) ∈ U := fun t ht =>
+      hDU (mk_mem_D (abs_le.mpr ⟨ht.1, ht.2⟩) ((h_le_one t).trans hy1))
+    rw [integral_horiz Φ Φ' U hd (by norm_num) hmem hc]
+    rcases hy1.lt_or_eq with hy1 | rfl
+    · rw [indicator_of_notMem (show y ∉ Iic (1 : ℝ) from not_le.mpr hy1), add_zero]
+    · simp [corr, r_one]
+
+include hδ hDU hd hc hΦ hΦ' in
+lemma integral_T_horiz :
+    ∫ p in T, Φ' ⟨p.1, p.2⟩ 1 =
+      ((∫ y in Ioi (Real.sqrt 3 / 2), Φ ⟨1 / 2, y⟩) - ∫ y in Ioi (Real.sqrt 3 / 2), Φ ⟨-(1 / 2), y⟩)
+        + ∫ y in (Real.sqrt 3 / 2)..1, corr Φ y := by
+  obtain ⟨C', hC'⟩ := hΦ'
+  have hG : IntegrableOn (fun p : ℝ × ℝ => Φ' ⟨p.1, p.2⟩ 1) T := by
+    refine integrableOn_T_of_bound hδ ?_ (C := C') fun p hp => ?_
+    · refine (hc.comp (continuous_mk2.continuousOn (s := T))
+        fun p hp => hDU (mk_mem_D hp.1 hp.2)).clm_apply
+        continuousOn_const
+    · calc ‖Φ' ⟨p.1, p.2⟩ 1‖ ≤ ‖Φ' ⟨p.1, p.2⟩‖ * ‖(1 : ℂ)‖ := ContinuousLinearMap.le_opNorm _ _
+        _ = ‖Φ' ⟨p.1, p.2⟩‖ := by rw [norm_one, mul_one]
+        _ ≤ C' * Real.exp (-δ * p.2) := hC' _ (hDU (mk_mem_D hp.1 hp.2))
+  rw [setIntegral_T_eq_y_x hG]
+  have hae : (fun y => ∫ x in {x : ℝ | |x| ≤ 1 / 2 ∧ h x ≤ y}, Φ' ⟨x, y⟩ 1) =ᵐ[volume]
+      (Ioi (Real.sqrt 3 / 2)).indicator fun y =>
+        (Φ ⟨1 / 2, y⟩ - Φ ⟨-(1 / 2), y⟩) + (Iic (1 : ℝ)).indicator (corr Φ) y := by
+    have : ∀ᵐ y : ℝ ∂volume, y ∉ ({Real.sqrt 3 / 2} : Set ℝ) :=
+      measure_eq_zero_iff_ae_notMem.mp Real.volume_singleton
+    filter_upwards [this] with y hy
+    rcases lt_or_gt_of_ne (fun h : y = Real.sqrt 3 / 2 => hy h) with hy | hy
+    · rw [indicator_of_notMem (show y ∉ Ioi (Real.sqrt 3 / 2) from not_lt.mpr hy.le),
+        slice_of_lt hy, Measure.restrict_empty, integral_zero_measure]
+    · rw [indicator_of_mem (show y ∈ Ioi (Real.sqrt 3 / 2) from hy)]
+      exact sliceIntegral Φ Φ' U hDU hd hc hy
+  rw [integral_congr_ae hae, integral_indicator measurableSet_Ioi]
+  have h1 : IntegrableOn (fun y : ℝ => Φ ⟨1 / 2, y⟩) (Ioi (Real.sqrt 3 / 2)) := by
+    have := integrableOn_vert Φ Φ' U δ hδ hDU hd hΦ (x := 1 / 2) (by rw [abs_of_pos (by norm_num)])
+    rwa [h_half] at this
+  have h2 : IntegrableOn (fun y : ℝ => Φ ⟨-(1 / 2), y⟩) (Ioi (Real.sqrt 3 / 2)) := by
+    have := integrableOn_vert Φ Φ' U δ hδ hDU hd hΦ (x := -(1 / 2))
+      (by rw [abs_neg, abs_of_pos (by norm_num)])
+    rwa [h_neg, h_half] at this
+  have h3 : IntegrableOn ((Iic (1 : ℝ)).indicator (corr Φ)) (Ioi (Real.sqrt 3 / 2)) := by
+    rw [IntegrableOn, integrable_indicator_iff measurableSet_Iic, IntegrableOn,
+      Measure.restrict_restrict measurableSet_Iic,
+      show Iic (1 : ℝ) ∩ Ioi (Real.sqrt 3 / 2) = Ioc (Real.sqrt 3 / 2) 1 by
+        rw [inter_comm, Ioi_inter_Iic]]
+    exact ((continuousOn_corr Φ Φ' U hDU hd).integrableOn_Icc).mono_set Ioc_subset_Icc_self
+  have h12 : IntegrableOn (fun y : ℝ => Φ ⟨1 / 2, y⟩ - Φ ⟨-(1 / 2), y⟩) (Ioi (Real.sqrt 3 / 2)) :=
+    h1.sub h2
+  rw [integral_add h12 h3, integral_sub h1 h2, setIntegral_indicator measurableSet_Iic,
+    Ioi_inter_Iic, intervalIntegral.integral_of_le sqrt3_lt_one.le]
+
+include hδ hDU hc hΦ' in
+lemma integrableOn_T_apply (v : ℂ) : IntegrableOn (fun p : ℝ × ℝ => Φ' ⟨p.1, p.2⟩ v) T := by
+  obtain ⟨C', hC'⟩ := hΦ'
+  refine integrableOn_T_of_bound hδ ?_ (C := C' * ‖v‖) fun p hp => ?_
+  · exact (hc.comp (continuous_mk2.continuousOn (s := T))
+      fun p hp => hDU (mk_mem_D hp.1 hp.2)).clm_apply
+      continuousOn_const
+  · calc ‖Φ' ⟨p.1, p.2⟩ v‖ ≤ ‖Φ' ⟨p.1, p.2⟩‖ * ‖v‖ := ContinuousLinearMap.le_opNorm _ _
+      _ ≤ C' * Real.exp (-δ * p.2) * ‖v‖ :=
+          mul_le_mul_of_nonneg_right (hC' _ (hDU (mk_mem_D hp.1 hp.2))) (norm_nonneg _)
+      _ = C' * ‖v‖ * Real.exp (-δ * p.2) := by ring
+
+include hδ hDU hd hc hΦ hΦ' in
+lemma integral_T_vert :
+    ∫ p in T, Φ' ⟨p.1, p.2⟩ I = -∫ x in (-(1 / 2 : ℝ))..(1 / 2), Φ ⟨x, h x⟩ := by
+  rw [setIntegral_T_eq_x_y (integrableOn_T_apply Φ' U δ hδ hDU hc hΦ' I),
+    intervalIntegral.integral_of_le (by norm_num), ← integral_Icc_eq_integral_Ioc, ← integral_neg]
+  refine setIntegral_congr_fun measurableSet_Icc fun x hx => ?_
+  have hx' : |x| ≤ 1 / 2 := abs_le.mpr ⟨hx.1, hx.2⟩
+  rw [integral_Ici_eq_integral_Ioi]
+  exact integral_vert Φ Φ' U δ hδ hDU hd hc hΦ hΦ' hx'
+
+def γ (θ : ℝ) : ℂ := ⟨Real.cos θ, Real.sin θ⟩
+
+lemma exp_mul_I_eq (θ : ℝ) : Complex.exp (θ * I) = γ θ :=
+  Complex.ext (Complex.exp_ofReal_mul_I_re θ) (Complex.exp_ofReal_mul_I_im θ)
+
+lemma continuous_γ : Continuous γ :=
+  continuous_mk2.comp (Real.continuous_cos.prodMk Real.continuous_sin)
+
+lemma cos_two_pi_div_three : Real.cos (2 * Real.pi / 3) = -(1 / 2) := by
+  rw [show 2 * Real.pi / 3 = Real.pi - Real.pi / 3 by ring, Real.cos_pi_sub, Real.cos_pi_div_three]
+
+lemma sin_two_pi_div_three : Real.sin (2 * Real.pi / 3) = Real.sqrt 3 / 2 := by
+  rw [show 2 * Real.pi / 3 = Real.pi - Real.pi / 3 by ring, Real.sin_pi_sub, Real.sin_pi_div_three]
+
+lemma pi_div_three_le : Real.pi / 3 ≤ 2 * Real.pi / 3 := by linarith [Real.pi_pos]
+
+lemma abs_cos_le {θ : ℝ} (hθ : θ ∈ Icc (Real.pi / 3) (2 * Real.pi / 3)) :
+    |Real.cos θ| ≤ 1 / 2 := by
+  have hπ := Real.pi_pos
+  rw [abs_le]
+  constructor
+  · have := Real.cos_le_cos_of_nonneg_of_le_pi (by linarith [hθ.1]) (by linarith) hθ.2
+    rw [cos_two_pi_div_three] at this
+    exact this
+  · have := Real.cos_le_cos_of_nonneg_of_le_pi (by linarith) (by linarith [hθ.2]) hθ.1
+    rwa [Real.cos_pi_div_three] at this
+
+lemma sin_nonneg_arc {θ : ℝ} (hθ : θ ∈ Icc (Real.pi / 3) (2 * Real.pi / 3)) : 0 ≤ Real.sin θ :=
+  Real.sin_nonneg_of_nonneg_of_le_pi (by linarith [hθ.1, Real.pi_pos])
+    (by linarith [hθ.2, Real.pi_pos])
+
+lemma h_cos {θ : ℝ} (hθ : θ ∈ Icc (Real.pi / 3) (2 * Real.pi / 3)) :
+    h (Real.cos θ) = Real.sin θ := by
+  unfold h
+  rw [← Real.sin_sq θ, Real.sqrt_sq (sin_nonneg_arc hθ)]
+
+lemma r_sin (θ : ℝ) : r (Real.sin θ) = |Real.cos θ| := by
+  unfold r
+  rw [← Real.cos_sq' θ, Real.sqrt_sq_eq_abs]
+
+lemma γ_mem_D {θ : ℝ} (hθ : θ ∈ Icc (Real.pi / 3) (2 * Real.pi / 3)) : γ θ ∈ D :=
+  mk_mem_D (abs_cos_le hθ) (h_cos hθ).le
+
+lemma continuousOn_Φ (hd : ∀ z ∈ U, HasFDerivAt Φ (Φ' z) z) : ContinuousOn Φ U :=
+  fun z hz => (hd z hz).continuousAt.continuousWithinAt
+
+include hd hDU in
+lemma continuousOn_arc : ContinuousOn (fun θ => Φ (γ θ)) (Icc (Real.pi / 3) (2 * Real.pi / 3)) :=
+  (continuousOn_Φ Φ Φ' U hd).comp continuous_γ.continuousOn fun _ hθ => hDU (γ_mem_D hθ)
+
+lemma arc_sin :
+    ∫ θ in (Real.pi / 3)..(2 * Real.pi / 3), Real.sin θ • Φ (γ θ) =
+      ∫ x in (-(1 / 2 : ℝ))..(1 / 2), Φ ⟨x, h x⟩ := by
+  have hab := pi_div_three_le
+  have key : ∫ θ in (Real.pi / 3)..(2 * Real.pi / 3),
+      (-Real.sin θ) • ((fun x : ℝ => Φ ⟨x, h x⟩) ∘ Real.cos) θ =
+        -∫ x in (-(1 / 2 : ℝ))..(1 / 2), Φ ⟨x, h x⟩ := by
+    rw [intervalIntegral.integral_deriv_smul_comp_of_deriv_nonpos Real.continuous_cos.continuousOn
+      (fun θ _ => Real.hasDerivAt_cos θ) (fun θ hθ => ?_), Real.cos_pi_div_three,
+      cos_two_pi_div_three, intervalIntegral.integral_symm]
+    rw [min_eq_left hab, max_eq_right hab] at hθ
+    exact neg_nonpos.mpr (sin_nonneg_arc (Ioo_subset_Icc_self hθ))
+  calc ∫ θ in (Real.pi / 3)..(2 * Real.pi / 3), Real.sin θ • Φ (γ θ)
+      = ∫ θ in (Real.pi / 3)..(2 * Real.pi / 3),
+          -((-Real.sin θ) • ((fun x : ℝ => Φ ⟨x, h x⟩) ∘ Real.cos) θ) := by
+        refine intervalIntegral.integral_congr fun θ hθ => ?_
+        rw [uIcc_of_le hab] at hθ
+        simp only [Function.comp_apply, neg_smul, neg_neg, h_cos hθ, γ]
+    _ = _ := by rw [intervalIntegral.integral_neg, key, neg_neg]
+
+include hd hDU in
+lemma arc_cos :
+    ∫ θ in (Real.pi / 3)..(2 * Real.pi / 3), Real.cos θ • Φ (γ θ) =
+      -∫ y in (Real.sqrt 3 / 2)..1, corr Φ y := by
+  have hπ := Real.pi_pos
+  have h1 : Real.pi / 3 ≤ Real.pi / 2 := by linarith
+  have h2 : Real.pi / 2 ≤ 2 * Real.pi / 3 := by linarith
+  have hΦc := continuousOn_Φ Φ Φ' U hd
+  have hcont : ContinuousOn (fun θ => Real.cos θ • Φ (γ θ)) (Icc (Real.pi / 3) (2 * Real.pi / 3)) :=
+    Real.continuous_cos.continuousOn.smul (continuousOn_arc Φ Φ' U hDU hd)
+  have hi1 : IntervalIntegrable (fun θ => Real.cos θ • Φ (γ θ)) volume (Real.pi / 3) (Real.pi / 2)
+    :=
+    (hcont.mono (by rw [uIcc_of_le h1]; exact Icc_subset_Icc_right h2)).intervalIntegrable
+  have hi2 : IntervalIntegrable (fun θ => Real.cos θ • Φ (γ θ)) volume (Real.pi / 2)
+      (2 * Real.pi / 3) :=
+    (hcont.mono (by rw [uIcc_of_le h2]; exact Icc_subset_Icc_left h1)).intervalIntegrable
+  rw [← intervalIntegral.integral_add_adjacent_intervals hi1 hi2]
+  have k1 : ∫ θ in (Real.pi / 3)..(Real.pi / 2), Real.cos θ • Φ (γ θ) =
+      ∫ y in (Real.sqrt 3 / 2)..1, Φ ⟨r y, y⟩ := by
+    rw [← Real.sin_pi_div_three, ← Real.sin_pi_div_two,
+      ← intervalIntegral.integral_deriv_smul_comp_of_deriv_nonneg (g := fun y : ℝ => Φ ⟨r y, y⟩)
+        Real.continuous_sin.continuousOn (fun θ _ => Real.hasDerivAt_sin θ) (fun θ hθ => ?_)]
+    · refine intervalIntegral.integral_congr fun θ hθ => ?_
+      rw [uIcc_of_le h1] at hθ
+      have hc0 : 0 ≤ Real.cos θ := Real.cos_nonneg_of_mem_Icc ⟨by linarith [hθ.1], hθ.2⟩
+      simp only [Function.comp_apply, γ, r_sin, abs_of_nonneg hc0]
+    · rw [min_eq_left h1, max_eq_right h1] at hθ
+      exact Real.cos_nonneg_of_mem_Icc ⟨by linarith [hθ.1], hθ.2.le⟩
+  have k2 : ∫ θ in (Real.pi / 2)..(2 * Real.pi / 3), Real.cos θ • Φ (γ θ) =
+      -∫ y in (Real.sqrt 3 / 2)..1, Φ ⟨-r y, y⟩ := by
+    rw [← sin_two_pi_div_three, ← Real.sin_pi_div_two,
+      ← intervalIntegral.integral_symm (Real.sin (2 * Real.pi / 3)) (Real.sin (Real.pi / 2)),
+      ← intervalIntegral.integral_deriv_smul_comp_of_deriv_nonpos (g := fun y : ℝ => Φ ⟨-r y, y⟩)
+        Real.continuous_sin.continuousOn (fun θ _ => Real.hasDerivAt_sin θ) (fun θ hθ => ?_)]
+    · refine intervalIntegral.integral_congr fun θ hθ => ?_
+      rw [uIcc_of_le h2] at hθ
+      have hc0 : Real.cos θ ≤ 0 := Real.cos_nonpos_of_pi_div_two_le_of_le hθ.1 (by linarith [hθ.2])
+      simp only [Function.comp_apply, γ, r_sin, abs_of_nonpos hc0, neg_neg]
+    · rw [min_eq_left h2, max_eq_right h2] at hθ
+      exact Real.cos_nonpos_of_pi_div_two_le_of_le hθ.1.le (by linarith [hθ.2])
+  have hg1 : IntervalIntegrable (fun y : ℝ => Φ ⟨r y, y⟩) volume (Real.sqrt 3 / 2) 1 := by
+    refine (ContinuousOn.mono ?_ (by rw [uIcc_of_le sqrt3_lt_one.le])).intervalIntegrable
+    exact hΦc.comp (continuous_mk2.comp (continuous_r.prodMk continuous_id)).continuousOn
+      fun y hy => hDU (mem_D_r hy.1 hy.2)
+  have hg2 : IntervalIntegrable (fun y : ℝ => Φ ⟨-r y, y⟩) volume (Real.sqrt 3 / 2) 1 := by
+    refine (ContinuousOn.mono ?_ (by rw [uIcc_of_le sqrt3_lt_one.le])).intervalIntegrable
+    exact hΦc.comp (continuous_mk2.comp (continuous_r.neg.prodMk continuous_id)).continuousOn
+      fun y hy => hDU (mem_D_neg_r hy.1 hy.2)
+  rw [k1, k2, show (corr Φ) = fun y => Φ ⟨-r y, y⟩ - Φ ⟨r y, y⟩ from rfl,
+    intervalIntegral.integral_sub hg2 hg1]
+  ring
+
+lemma arc_integrand (θ : ℝ) :
+    Φ (Complex.exp (θ * I)) * (I * Complex.exp (θ * I)) =
+      -(Real.sin θ • Φ (γ θ)) + I * (Real.cos θ • Φ (γ θ)) := by
+  rw [exp_mul_I_eq, Complex.real_smul, Complex.real_smul]
+  have e : (γ θ : ℂ) = (Real.cos θ : ℂ) + (Real.sin θ : ℂ) * I := mk_eq _ _
+  generalize Φ (γ θ) = w
+  rw [e]
+  linear_combination ((Real.sin θ : ℂ) * w) * Complex.I_mul_I
+
+include hd hDU in
+lemma arc_split :
+    ∫ θ in (Real.pi / 3)..(2 * Real.pi / 3), Φ (Complex.exp (θ * I)) * (I * Complex.exp (θ * I)) =
+      -(∫ θ in (Real.pi / 3)..(2 * Real.pi / 3), Real.sin θ • Φ (γ θ)) +
+        I * ∫ θ in (Real.pi / 3)..(2 * Real.pi / 3), Real.cos θ • Φ (γ θ) := by
+  have hab := pi_div_three_le
+  have harc := continuousOn_arc Φ Φ' U hDU hd
+  have hi1 : IntervalIntegrable (fun θ => Real.sin θ • Φ (γ θ)) volume (Real.pi / 3)
+      (2 * Real.pi / 3) := by
+    refine (ContinuousOn.mono ?_ (by rw [uIcc_of_le hab])).intervalIntegrable
+    exact Real.continuous_sin.continuousOn.smul harc
+  have hi2 : IntervalIntegrable (fun θ => Real.cos θ • Φ (γ θ)) volume (Real.pi / 3)
+      (2 * Real.pi / 3) := by
+    refine (ContinuousOn.mono ?_ (by rw [uIcc_of_le hab])).intervalIntegrable
+    exact Real.continuous_cos.continuousOn.smul harc
+  have hi1' : IntervalIntegrable (fun θ => -(Real.sin θ • Φ (γ θ))) volume (Real.pi / 3)
+      (2 * Real.pi / 3) := hi1.neg
+  have hi2' : IntervalIntegrable (fun θ => I * (Real.cos θ • Φ (γ θ))) volume (Real.pi / 3)
+      (2 * Real.pi / 3) := hi2.const_mul I
+  rw [← intervalIntegral.integral_neg, ← intervalIntegral.integral_const_mul,
+    ← intervalIntegral.integral_add hi1' hi2']
+  exact intervalIntegral.integral_congr fun θ _ => arc_integrand Φ θ
+
+include hδ hDU hd hc hΦ hΦ' in
+theorem main :
+    (∫ z in D, (I • Φ' z 1 - Φ' z I)) =
+      I • (∫ y in Ioi (Real.sqrt 3 / 2), Φ (1 / 2 + y * I))
+        - I • (∫ y in Ioi (Real.sqrt 3 / 2), Φ (-(1 / 2) + y * I))
+        - ∫ θ in (Real.pi / 3)..(2 * Real.pi / 3),
+            Φ (Complex.exp (θ * I)) * (I * Complex.exp (θ * I)) := by
+  have hT := setIntegral_D (fun z => I • Φ' z 1 - Φ' z I)
+  beta_reduce at hT
+  rw [hT]
+  have hA : Integrable (fun p : ℝ × ℝ => Φ' ⟨p.1, p.2⟩ I) (volume.restrict T) :=
+    integrableOn_T_apply Φ' U δ hδ hDU hc hΦ' I
+  have hB : Integrable (fun p : ℝ × ℝ => I • Φ' ⟨p.1, p.2⟩ 1) (volume.restrict T) :=
+    (integrableOn_T_apply Φ' U δ hδ hDU hc hΦ' 1).smul I
+  rw [integral_sub hB hA, integral_smul, integral_T_horiz Φ Φ' U δ hδ hDU hd hc hΦ hΦ',
+    integral_T_vert Φ Φ' U δ hδ hDU hd hc hΦ hΦ', arc_split Φ Φ' U hDU hd,
+    arc_sin Φ, arc_cos Φ Φ' U hDU hd]
+  have e1 : ∀ y : ℝ, ((1 : ℂ) / 2 + y * I) = (⟨1 / 2, y⟩ : ℂ) := fun y =>
+    Complex.ext (by simp) (by simp)
+  have e2 : ∀ y : ℝ, (-((1 : ℂ) / 2) + y * I) = (⟨-(1 / 2), y⟩ : ℂ) := fun y =>
+    Complex.ext (by simp) (by simp)
+  simp_rw [e1, e2]
+  simp only [smul_eq_mul]
+  ring
+
+end Hyp
+
+end Complex.GreenFD
+
+end
+
+theorem solution
+    (Φ : ℂ → ℂ) (Φ' : ℂ → ℂ →L[ℝ] ℂ) (U : Set ℂ) (δ : ℝ) (hδ : 0 < δ)
+    (hDU : {z : ℂ | |z.re| ≤ 1 / 2 ∧ 1 ≤ ‖z‖ ∧ 0 < z.im} ⊆ U)
+    (hd : ∀ z ∈ U, HasFDerivAt Φ (Φ' z) z) (hc : ContinuousOn Φ' U)
+    (hΦ : ∃ C : ℝ, ∀ z ∈ U, ‖Φ z‖ ≤ C * Real.exp (-δ * z.im))
+    (hΦ' : ∃ C : ℝ, ∀ z ∈ U, ‖Φ' z‖ ≤ C * Real.exp (-δ * z.im)) :
+    (∫ z in {z : ℂ | |z.re| ≤ 1 / 2 ∧ 1 ≤ ‖z‖ ∧ 0 < z.im}, (Complex.I • Φ' z 1 - Φ' z Complex.I)) =
+      Complex.I • (∫ y in Set.Ioi (Real.sqrt 3 / 2), Φ (1 / 2 + y * Complex.I))
+        - Complex.I • (∫ y in Set.Ioi (Real.sqrt 3 / 2), Φ (-(1 / 2) + y * Complex.I))
+        - ∫ θ in (Real.pi / 3)..(2 * Real.pi / 3),
+            Φ (Complex.exp (θ * Complex.I)) * (Complex.I * Complex.exp (θ * Complex.I)) :=
+  Complex.GreenFD.main Φ Φ' U δ hδ hDU hd hc hΦ hΦ'
+
+end S_Complex_integral_modularFundamentalDomain_eq_boundary_of_hasFDerivAt
+end P2MW
+export P2MW.S_Complex_integral_modularFundamentalDomain_eq_boundary_of_hasFDerivAt (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open MeasureTheory
+theorem Complex.integral_modularFundamentalDomain_eq_boundary_of_hasFDerivAt
+    (Φ : ℂ → ℂ) (Φ' : ℂ → ℂ →L[ℝ] ℂ) (U : Set ℂ) (δ : ℝ) (hδ : 0 < δ)
+    (hDU : {z : ℂ | |z.re| ≤ 1 / 2 ∧ 1 ≤ ‖z‖ ∧ 0 < z.im} ⊆ U)
+    (hd : ∀ z ∈ U, HasFDerivAt Φ (Φ' z) z) (hc : ContinuousOn Φ' U)
+    (hΦ : ∃ C : ℝ, ∀ z ∈ U, ‖Φ z‖ ≤ C * Real.exp (-δ * z.im))
+    (hΦ' : ∃ C : ℝ, ∀ z ∈ U, ‖Φ' z‖ ≤ C * Real.exp (-δ * z.im)) :
+    (∫ z in {z : ℂ | |z.re| ≤ 1 / 2 ∧ 1 ≤ ‖z‖ ∧ 0 < z.im}, (Complex.I • Φ' z 1 - Φ' z Complex.I)) =
+      Complex.I • (∫ y in Set.Ioi (Real.sqrt 3 / 2), Φ (1 / 2 + y * Complex.I))
+        - Complex.I • (∫ y in Set.Ioi (Real.sqrt 3 / 2), Φ (-(1 / 2) + y * Complex.I))
+        - ∫ θ in (Real.pi / 3)..(2 * Real.pi / 3),
+            Φ (Complex.exp (θ * Complex.I)) * (Complex.I * Complex.exp (θ * Complex.I)) :=
+  solution Φ Φ' U δ hδ hDU hd hc hΦ hΦ'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_CongruenceSubgroup_Gamma0_le_closure_T_union_setOf_dvd.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_CongruenceSubgroup_Gamma0_le_closure_T_union_setOf_dvd.lean
new file mode 100644
index 0000000000..acff530ca4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_CongruenceSubgroup_Gamma0_le_closure_T_union_setOf_dvd.lean
@@ -0,0 +1,167 @@
+/-
+Based on Prove2Me node CongruenceSubgroup.Gamma0_le_closure_T_union_setOf_dvd
+(168c8591-27b0-566d-a1ab-9f5ebc191205) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8c5228fe-c9a1-5798-981d-7911de1bcddf
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+
+import Mathlib.Data.ZMod.Units
+import Mathlib.RingTheory.Int.Basic
+import Mathlib.Tactic.Group
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Γ₀(M) lies in the subgroup generated by T and q∣ b
+
+Theorem statement: `CongruenceSubgroup.Gamma0_le_closure_T_union_setOf_dvd`
+(`168c8591-27b0-566d-a1ab-9f5ebc191205`), by Claude, 2026-09-05.
+
+Proof: submission `8c5228fe-c9a1-5798-981d-7911de1bcddf`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a natural number and let $q$ be a non-zero natural number. Inside
+$\mathrm{SL}_2(\mathbb{Z})$, consider the set consisting of the translation matrix
+$T=\begin{pmatrix}1&1\\0&1\end{pmatrix}$ (Mathlib's `ModularGroup.T`) together with all
+$\gamma\in\mathrm{SL}_2(\mathbb{Z})$ whose lower-left entry $\gamma_{1,0}$ is divisible by $M$ and
+whose upper-right entry $\gamma_{0,1}$ is divisible by $q$, the divisibilities being taken in
+$\mathbb{Z}$ with $M$ and $q$ cast from $\mathbb{N}$. The assertion is the inclusion of subgroups
+$\Gamma_0(M)\le\langle\{T\}\cup\{\gamma: M\mid \gamma_{1,0},\ q\mid\gamma_{0,1}\}\rangle$, where
+$\Gamma_0(M)$ is `CongruenceSubgroup.Gamma0 M`, the subgroup of matrices whose lower-left entry
+vanishes in $\mathbb{Z}/M$, and the right-hand side is the subgroup generated by the displayed set.
+No primality is assumed of $q$, and $M$ is an arbitrary natural number; only $q\neq 0$ is required.
+
+A generation statement for $\Gamma_0(M)$: every element of $\Gamma_0(M)$ is a product of
+translations and of elements of $\Gamma_0(M)$ whose upper-right entry is divisible by a prescribed
+non-zero integer $q$. It is used in the proof of
+[`CuspForm.eq_zero_of_prime_not_dvd_of_qCoeff_eq_zero`]
+(thm.html#CuspForm.eq_zero_of_prime_not_dvd_of_qCoeff_eq_zero),
+where a vanishing property invariant under translations need only be checked on matrices with $q\mid
+b$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_CongruenceSubgroup_Gamma0_le_closure_T_union_setOf_dvd.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_CongruenceSubgroup_Gamma0_le_closure_T_union_setOf_dvd
+
+namespace AlliAux1Gen
+
+theorem exists_isCoprime_add_mul (a c : ℤ) {q : ℕ} (hq : q ≠ 0) (hac : IsCoprime a c) :
+    ∃ j : ℤ, IsCoprime (a + j * c) (q : ℤ) := by
+  classical
+  let ps : Finset ℕ := {p ∈ q.primeFactors | ¬ (p : ℤ) ∣ a}
+  refine ⟨((ps.prod id : ℕ) : ℤ), ?_⟩
+  set j : ℤ := ((ps.prod id : ℕ) : ℤ) with hjdef
+  rw [Int.isCoprime_iff_gcd_eq_one]
+  by_contra hne
+  obtain ⟨p, pp, hp⟩ := Nat.exists_prime_and_dvd hne
+  have hp1 : (p : ℤ) ∣ a + j * c :=
+    (Int.natCast_dvd_natCast.mpr hp).trans (Int.gcd_dvd_left _ _)
+  have hp2 : p ∣ q := by
+    have h : (p : ℤ) ∣ (q : ℤ) := (Int.natCast_dvd_natCast.mpr hp).trans (Int.gcd_dvd_right _ _)
+    exact Int.natCast_dvd_natCast.mp h
+  have ppZ : Prime (p : ℤ) := Nat.prime_iff_prime_int.mp pp
+  by_cases hpa : (p : ℤ) ∣ a
+  · have hjc : (p : ℤ) ∣ j * c := by
+      have := dvd_sub hp1 hpa
+      rwa [add_sub_cancel_left] at this
+    rcases ppZ.dvd_or_dvd hjc with h | h
+    · have h' : p ∣ ps.prod id := Int.natCast_dvd_natCast.mp h
+      obtain ⟨r, hr, hpr⟩ := (pp.prime.dvd_finsetProd_iff id).mp h'
+      have hr' := (Finset.mem_filter.mp hr)
+      have hreq : p = r :=
+        (Nat.prime_dvd_prime_iff_eq pp (Nat.prime_of_mem_primeFactors hr'.1)).mp hpr
+      exact hr'.2 (hreq ▸ hpa)
+    · exact ppZ.not_isUnit (hac.isUnit_of_dvd' hpa h)
+  · have pps : p ∈ ps :=
+      Finset.mem_filter.mpr ⟨Nat.mem_primeFactors.mpr ⟨pp, hp2, hq⟩, hpa⟩
+    have hpj : (p : ℤ) ∣ j := Int.natCast_dvd_natCast.mpr (Finset.dvd_prod_of_mem id pps)
+    have : (p : ℤ) ∣ a := by
+      have := dvd_sub hp1 (hpj.mul_right c)
+      rwa [add_sub_cancel_right] at this
+    exact hpa this
+
+open Matrix.SpecialLinearGroup in
+theorem T_zpow_mul_mul_T_zpow_apply (j j' : ℤ) (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) :
+    ((ModularGroup.T ^ j * γ * ModularGroup.T ^ j' :
+        Matrix.SpecialLinearGroup (Fin 2) ℤ) : Matrix (Fin 2) (Fin 2) ℤ) 1 0
+        = (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 0 ∧
+      ((ModularGroup.T ^ j * γ * ModularGroup.T ^ j' :
+        Matrix.SpecialLinearGroup (Fin 2) ℤ) : Matrix (Fin 2) (Fin 2) ℤ) 0 1
+        = ((γ : Matrix (Fin 2) (Fin 2) ℤ) 0 0 + j * (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 0) * j'
+          + ((γ : Matrix (Fin 2) (Fin 2) ℤ) 0 1 + j * (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 1) := by
+  constructor <;>
+  · simp [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_T_zpow, Matrix.mul_apply,
+      Matrix.vecMul, dotProduct, Fin.sum_univ_succ]
+
+end AlliAux1Gen
+
+theorem solution (M : ℕ) {q : ℕ} (hq : q ≠ 0) :
+    CongruenceSubgroup.Gamma0 M ≤ Subgroup.closure
+      ({ModularGroup.T} ∪ {γ : Matrix.SpecialLinearGroup (Fin 2) ℤ |
+        (M : ℤ) ∣ (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 0 ∧ (q : ℤ) ∣ (γ : Matrix (Fin 2) (Fin 2) ℤ) 0
+          1}) := by
+  intro γ hγ
+  set H := Subgroup.closure
+      ({ModularGroup.T} ∪ {γ : Matrix.SpecialLinearGroup (Fin 2) ℤ |
+        (M : ℤ) ∣ (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 0 ∧ (q : ℤ) ∣ (γ : Matrix (Fin 2) (Fin 2) ℤ) 0
+          1})
+    with hH
+  have hT : ModularGroup.T ∈ H := Subgroup.subset_closure (Or.inl rfl)
+  have hc : (M : ℤ) ∣ (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 0 :=
+    (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp (CongruenceSubgroup.Gamma0_mem.mp hγ)
+  obtain ⟨j, hj⟩ := AlliAux1Gen.exists_isCoprime_add_mul
+    ((γ : Matrix (Fin 2) (Fin 2) ℤ) 0 0) ((γ : Matrix (Fin 2) (Fin 2) ℤ) 1 0) hq
+    (Matrix.SpecialLinearGroup.isCoprime_col γ 0)
+  obtain ⟨u, v, huv⟩ := hj
+  set a₁ : ℤ := (γ : Matrix (Fin 2) (Fin 2) ℤ) 0 0 + j * (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 0 with ha₁
+  set b₁ : ℤ := (γ : Matrix (Fin 2) (Fin 2) ℤ) 0 1 + j * (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 1 with hb₁
+  set j' : ℤ := -(b₁ * u) with hj'
+  have hmem : ModularGroup.T ^ j * γ * ModularGroup.T ^ j' ∈ H := by
+    refine Subgroup.subset_closure (Or.inr ?_)
+    obtain ⟨h10, h01⟩ := AlliAux1Gen.T_zpow_mul_mul_T_zpow_apply j j' γ
+    refine ⟨?_, ?_⟩
+    · rw [h10]; exact hc
+    · rw [h01]
+      refine ⟨b₁ * v, ?_⟩
+      have : a₁ * j' + b₁ = b₁ * (1 - u * a₁) := by rw [hj']; ring
+      rw [← ha₁, ← hb₁, this, ← huv]
+      ring
+  have hγeq : γ = ModularGroup.T ^ (-j) * (ModularGroup.T ^ j * γ * ModularGroup.T ^ j')
+      * ModularGroup.T ^ (-j') := by group
+  rw [hγeq]
+  exact H.mul_mem (H.mul_mem (H.zpow_mem hT _) hmem) (H.zpow_mem hT _)
+
+end S_CongruenceSubgroup_Gamma0_le_closure_T_union_setOf_dvd
+end P2MW
+export P2MW.S_CongruenceSubgroup_Gamma0_le_closure_T_union_setOf_dvd (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem CongruenceSubgroup.Gamma0_le_closure_T_union_setOf_dvd (M : ℕ) {q : ℕ} (hq : q ≠ 0) :
+    CongruenceSubgroup.Gamma0 M ≤ Subgroup.closure
+      ({ModularGroup.T} ∪ {γ : Matrix.SpecialLinearGroup (Fin 2) ℤ |
+        (M : ℤ) ∣ (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 0 ∧ (q : ℤ) ∣ (γ : Matrix (Fin 2) (Fin 2) ℤ) 0
+          1}) :=
+  solution M hq
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_CongruenceSubgroup_closure_T_U_neg_one_eq_Gamma0_three.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_CongruenceSubgroup_closure_T_U_neg_one_eq_Gamma0_three.lean
new file mode 100644
index 0000000000..2d88d44395
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_CongruenceSubgroup_closure_T_U_neg_one_eq_Gamma0_three.lean
@@ -0,0 +1,311 @@
+/-
+Based on Prove2Me node CongruenceSubgroup.closure_T_U_neg_one_eq_Gamma0_three
+(ee2e87fa-6ddf-5fb1-b8a6-43ad24a595b2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d00a3882-a8c7-5dbc-8397-bc8df7d69c69
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+
+import Mathlib.Algebra.Field.ZMod
+import Mathlib.Analysis.Complex.UpperHalfPlane.Manifold
+import Mathlib.GroupTheory.Schreier
+import Mathlib.LinearAlgebra.Matrix.FixedDetMatrices
+import Mathlib.NumberTheory.ModularForms.SlashActions
+import Mathlib.Tactic.NormNum.Prime
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Γ₀(3) is generated by T, U and -1
+
+Theorem statement: `CongruenceSubgroup.closure_T_U_neg_one_eq_Gamma0_three`
+(`ee2e87fa-6ddf-5fb1-b8a6-43ad24a595b2`), by Claude, 2026-09-05.
+
+Proof: submission `d00a3882-a8c7-5dbc-8397-bc8df7d69c69`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $U$ be an element of $\mathrm{SL}_2(\mathbb{Z})$ whose underlying integer $2\times 2$ matrix is
+$\begin{pmatrix} 1 & 0 \\ -3 & 1\end{pmatrix}$. The assertion is an equality of subgroups of
+$\mathrm{SL}_2(\mathbb{Z})$: the subgroup generated by the three-element set consisting of
+`ModularGroup.T`, that is the translation matrix $\begin{pmatrix} 1 & 1 \\ 0 & 1\end{pmatrix}$, of
+$U$, and of the central element $-1$, coincides with the congruence subgroup
+`CongruenceSubgroup.Gamma0 3`, namely the subgroup of those elements of $\mathrm{SL}_2(\mathbb{Z})$
+whose lower-left entry is congruent to $0$ modulo $3$. Since the equality is of subgroups, both
+inclusions are contained in it: each of $T$, $U$ and $-1$ has lower-left entry divisible by $3$, and
+conversely every matrix in $\Gamma_0(3)$ is a word in these three elements and their inverses.
+
+This is the classical determination, going back to Rademacher, of generators for $\Gamma_0(3)$: the
+stabiliser $T$ of the cusp $\infty$, the stabiliser $U$ of the cusp $0$ (a conjugate of $T^{-1}$ by
+the Fricke involution $W_3 = \begin{pmatrix} 0 & -1 \\ 3 & 0\end{pmatrix}$), together with the
+centre. It is used in
+[`ModularForm.exists_weight_one_gamma1_three_slash_fricke_eq_smul`]
+(thm.html#ModularForm.exists_weight_one_gamma1_three_slash_fricke_eq_smul),
+where the behaviour of a weight one form of level $3$ under the Fricke involution is pinned down by
+checking finitely many generators.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_CongruenceSubgroup_closure_T_U_neg_one_eq_Gamma0_three.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_CongruenceSubgroup_closure_T_U_neg_one_eq_Gamma0_three
+
+
+open Matrix CongruenceSubgroup Subgroup ModularForm UpperHalfPlane
+open scoped MatrixGroups ModularForm Manifold Pointwise
+
+namespace A2Gamma0Three
+
+namespace Gamma0Three
+
+def repOfLabel : Option (ZMod 3) → SL(2, ℤ)
+  | none => 1
+  | some k => ⟨!![0, -1; 1, (k.val : ℤ)], by simp [Matrix.det_fin_two_of]⟩
+
+@[scoped simp] lemma repOfLabel_none : repOfLabel none = 1 := rfl
+
+@[scoped simp] lemma repOfLabel_some_one_zero (k : ZMod 3) : repOfLabel (some k) 1 0 = 1 := rfl
+
+@[scoped simp] lemma repOfLabel_some_one_one (k : ZMod 3) :
+    repOfLabel (some k) 1 1 = (k.val : ℤ) := rfl
+
+@[scoped simp] lemma one_apply_one_zero : (1 : SL(2, ℤ)) 1 0 = 0 := rfl
+
+@[scoped simp] lemma one_apply_one_one : (1 : SL(2, ℤ)) 1 1 = 1 := rfl
+
+def transversal : Set SL(2, ℤ) := Set.range repOfLabel
+
+lemma one_mem_transversal : (1 : SL(2, ℤ)) ∈ transversal := ⟨none, rfl⟩
+
+def label (g : SL(2, ℤ)) : Option (ZMod 3) :=
+  if (g 1 0 : ZMod 3) = 0 then none
+  else some ((g 1 1 : ZMod 3) / (g 1 0 : ZMod 3))
+
+private lemma intCast_val (k : ZMod 3) : (((k.val : ℕ) : ℤ) : ZMod 3) = k := by
+  exact_mod_cast ZMod.natCast_rightInverse k
+
+lemma apply_one_one_ne_zero (g : SL(2, ℤ)) (hc : (g 1 0 : ZMod 3) = 0) :
+    (g 1 1 : ZMod 3) ≠ 0 := by
+  intro hd
+  have hdet : (g 0 0 : ℤ) * g 1 1 - g 0 1 * g 1 0 = 1 := by
+    have h2 := g.2
+    rw [Matrix.det_fin_two] at h2
+    exact h2
+  have hcast : (g 0 0 : ZMod 3) * (g 1 1 : ZMod 3)
+      - (g 0 1 : ZMod 3) * (g 1 0 : ZMod 3) = 1 := by
+    have h3 : (((g 0 0 : ℤ) * g 1 1 - g 0 1 * g 1 0 : ℤ) : ZMod 3) = ((1 : ℤ) : ZMod 3) := by
+      rw [hdet]
+    push_cast at h3
+    exact h3
+  rw [hc, hd, mul_zero, mul_zero, sub_zero] at hcast
+  exact zero_ne_one hcast
+
+private theorem mul_entry (A B : SL(2, ℤ)) (i j : Fin 2) :
+    (A * B) i j = A i 0 * B 0 j + A i 1 * B 1 j := by
+  show ((A * B : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) i j = _
+  rw [Matrix.SpecialLinearGroup.coe_mul, Matrix.mul_apply, Fin.sum_univ_two]
+
+private theorem inv_entries (A : SL(2, ℤ)) :
+    A⁻¹ 0 0 = A 1 1 ∧ A⁻¹ 0 1 = -A 0 1 ∧ A⁻¹ 1 0 = -A 1 0 ∧ A⁻¹ 1 1 = A 0 0 := by
+  have h : ((A⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) =
+      !![A 1 1, -A 0 1; -A 1 0, A 0 0] := by
+    rw [Matrix.SpecialLinearGroup.coe_inv, Matrix.adjugate_fin_two]
+  refine ⟨?_, ?_, ?_, ?_⟩ <;> simp [h]
+
+lemma mul_inv_apply_one_zero (g h : SL(2, ℤ)) :
+    (g * h⁻¹) 1 0 = g 1 0 * h 1 1 - g 1 1 * h 1 0 := by
+  rw [mul_entry, (inv_entries h).1, (inv_entries h).2.2.1]
+  ring
+
+theorem mul_inv_mem_iff (g h : SL(2, ℤ)) :
+    g * h⁻¹ ∈ Gamma0 3 ↔
+      (g 1 0 : ZMod 3) * (h 1 1 : ZMod 3) = (g 1 1 : ZMod 3) * (h 1 0 : ZMod 3) := by
+  rw [Gamma0_mem, mul_inv_apply_one_zero]
+  push_cast
+  exact sub_eq_zero
+
+theorem mul_inv_repOfLabel_mem_iff (g : SL(2, ℤ)) (l : Option (ZMod 3)) :
+    g * (repOfLabel l)⁻¹ ∈ Gamma0 3 ↔ l = label g := by
+  rw [mul_inv_mem_iff]
+  unfold label
+  cases l with
+  | none =>
+    rw [repOfLabel_none, one_apply_one_one, one_apply_one_zero, Int.cast_one, mul_one,
+      Int.cast_zero, mul_zero]
+    by_cases hc : (g 1 0 : ZMod 3) = 0
+    · rw [ite_eq_left hc]
+      exact iff_of_true hc rfl
+    · rw [ite_eq_right hc]
+      exact iff_of_false hc (by simp)
+  | some k =>
+    rw [repOfLabel_some_one_one, repOfLabel_some_one_zero, Int.cast_one, mul_one,
+      intCast_val]
+    by_cases hc : (g 1 0 : ZMod 3) = 0
+    · rw [ite_eq_left hc]
+      refine iff_of_false (fun hcontra => ?_) (by simp)
+      rw [hc, zero_mul] at hcontra
+      exact apply_one_one_ne_zero g hc hcontra.symm
+    · rw [ite_eq_right hc, Option.some_inj, eq_div_iff hc]
+      constructor <;> intro h <;> linear_combination h
+
+theorem isComplement_transversal :
+    IsComplement (Gamma0 3 : Set SL(2, ℤ)) transversal := by
+  rw [isComplement_iff_existsUnique_mul_inv_mem]
+  intro g
+  refine ⟨⟨repOfLabel (label g), ⟨label g, rfl⟩⟩, ?_, ?_⟩
+  · exact (mul_inv_repOfLabel_mem_iff g (label g)).mpr rfl
+  · rintro ⟨x, l, rfl⟩ ht
+    exact Subtype.ext (congrArg repOfLabel ((mul_inv_repOfLabel_mem_iff g l).mp ht))
+
+lemma coe_toRightFun (g : SL(2, ℤ)) :
+    (isComplement_transversal.toRightFun g : SL(2, ℤ)) = repOfLabel (label g) := by
+  have huniq := isComplement_iff_existsUnique_mul_inv_mem.mp isComplement_transversal g
+  have h1 : g * ((isComplement_transversal.toRightFun g : SL(2, ℤ)))⁻¹
+      ∈ (Gamma0 3 : Set SL(2, ℤ)) :=
+    isComplement_transversal.mul_inv_toRightFun_mem g
+  have h2 : g * (((⟨repOfLabel (label g), ⟨label g, rfl⟩⟩ : transversal) : SL(2, ℤ)))⁻¹
+      ∈ (Gamma0 3 : Set SL(2, ℤ)) :=
+    (mul_inv_repOfLabel_mem_iff g (label g)).mpr rfl
+  exact congrArg Subtype.val (huniq.unique h1 h2)
+
+def schreierGen (l : Option (ZMod 3)) (s : SL(2, ℤ)) : SL(2, ℤ) :=
+  repOfLabel l * s * (repOfLabel (label (repOfLabel l * s)))⁻¹
+
+theorem schreierGen_mem (l : Option (ZMod 3)) (s : SL(2, ℤ)) :
+    schreierGen l s ∈ Gamma0 3 :=
+  (mul_inv_repOfLabel_mem_iff (repOfLabel l * s) (label (repOfLabel l * s))).mpr rfl
+
+def schreierGens : Set SL(2, ℤ) :=
+  {x | ∃ l : Option (ZMod 3),
+    x = schreierGen l ModularGroup.S ∨ x = schreierGen l ModularGroup.T}
+
+theorem closure_schreierGens : Subgroup.closure schreierGens = Gamma0 3 := by
+  refine le_antisymm ((Subgroup.closure_le _).mpr ?_) ?_
+  · rintro x ⟨l, rfl | rfl⟩ <;> exact schreierGen_mem _ _
+  · rw [← Subgroup.closure_mul_image_eq isComplement_transversal one_mem_transversal
+      SpecialLinearGroup.SL2Z_generators]
+    refine Subgroup.closure_mono ?_
+    rintro x ⟨g, hg, rfl⟩
+    rw [Set.mem_mul] at hg
+    obtain ⟨r, hr, s, hs, rfl⟩ := hg
+    obtain ⟨l, rfl⟩ := hr
+    simp only [coe_toRightFun]
+    simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hs
+    rcases hs with rfl | rfl
+    · exact ⟨l, Or.inl rfl⟩
+    · exact ⟨l, Or.inr rfl⟩
+
+end Gamma0Three
+
+def U₃ : SL(2, ℤ) := ⟨!![1, 0; -3, 1], by simp [Matrix.det_fin_two_of]⟩
+
+@[scoped simp] lemma U₃_one_zero : U₃ 1 0 = -3 := rfl
+@[scoped simp] lemma U₃_one_one : U₃ 1 1 = 1 := rfl
+
+lemma T_mem_gamma0_three : ModularGroup.T ∈ Gamma0 3 := by
+  rw [Gamma0_mem]; decide
+
+lemma U₃_mem_gamma0_three : U₃ ∈ Gamma0 3 := by
+  rw [Gamma0_mem]; decide
+
+lemma neg_one_mem_gamma0_three : (-1 : SL(2, ℤ)) ∈ Gamma0 3 := by
+  rw [Gamma0_mem]; decide
+
+def gens : Set SL(2, ℤ) := {ModularGroup.T, U₃, -1}
+
+lemma gens_subset_gamma0_three : gens ⊆ (Gamma0 3 : Subgroup SL(2, ℤ)) := by
+  rintro x (rfl | rfl | rfl)
+  · exact T_mem_gamma0_three
+  · exact U₃_mem_gamma0_three
+  · exact neg_one_mem_gamma0_three
+
+namespace Gamma0Three
+
+private lemma schreierGen_eq_one :
+    schreierGen (some 0) ModularGroup.T = 1 ∧ schreierGen (some 1) ModularGroup.T = 1 ∧
+    schreierGen none ModularGroup.S = 1 := by decide +kernel
+
+private lemma schreierGen_none_T : schreierGen none ModularGroup.T = ModularGroup.T := by
+  decide
+
+private lemma schreierGen_two_T : schreierGen (some 2) ModularGroup.T = U₃ := by decide +kernel
+
+private lemma schreierGen_zero_S : schreierGen (some 0) ModularGroup.S = -1 := by decide
+
+private lemma schreierGen_one_S :
+    schreierGen (some 1) ModularGroup.S = ModularGroup.T⁻¹ * U₃⁻¹ := by decide +kernel
+
+private lemma schreierGen_two_S :
+    schreierGen (some 2) ModularGroup.S = -1 * (U₃ * ModularGroup.T) := by decide +kernel
+
+lemma schreierGens_subset_closure_gens :
+    schreierGens ⊆ (Subgroup.closure gens : Set SL(2, ℤ)) := by
+  have hT : ModularGroup.T ∈ Subgroup.closure gens :=
+    Subgroup.subset_closure (Or.inl rfl)
+  have hU : U₃ ∈ Subgroup.closure gens :=
+    Subgroup.subset_closure (Or.inr (Or.inl rfl))
+  have hneg : (-1 : SL(2, ℤ)) ∈ Subgroup.closure gens :=
+    Subgroup.subset_closure (Or.inr (Or.inr rfl))
+  have hcases : ∀ j : ZMod 3, j = 0 ∨ j = 1 ∨ j = 2 := by decide
+  rintro x ⟨l, rfl | rfl⟩
+  · rcases l with _ | k
+    · rw [schreierGen_eq_one.2.2]; exact one_mem _
+    · rcases hcases k with rfl | rfl | rfl
+      · rw [schreierGen_zero_S]; exact hneg
+      · rw [schreierGen_one_S]; exact mul_mem (inv_mem hT) (inv_mem hU)
+      · rw [schreierGen_two_S]; exact mul_mem hneg (mul_mem hU hT)
+  · rcases l with _ | k
+    · rw [schreierGen_none_T]; exact hT
+    · rcases hcases k with rfl | rfl | rfl
+      · rw [schreierGen_eq_one.1]; exact one_mem _
+      · rw [schreierGen_eq_one.2.1]; exact one_mem _
+      · rw [schreierGen_two_T]; exact hU
+
+end Gamma0Three
+
+theorem closure_T_U_neg_one_eq : Subgroup.closure gens = Gamma0 3 := by
+  refine le_antisymm ((Subgroup.closure_le _).mpr gens_subset_gamma0_three) ?_
+  rw [← Gamma0Three.closure_schreierGens]
+  exact (Subgroup.closure_le _).mpr Gamma0Three.schreierGens_subset_closure_gens
+
+theorem mem_closure_gens {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 3) : γ ∈ Subgroup.closure gens :=
+  closure_T_U_neg_one_eq ▸ hγ
+
+end A2Gamma0Three
+
+open scoped MatrixGroups in
+theorem solution (U : SL(2, ℤ)) (hU : (U : Matrix (Fin 2) (Fin 2) ℤ) = !![1, 0; -3, 1]) :
+    Subgroup.closure ({ModularGroup.T, U, -1} : Set SL(2, ℤ)) = CongruenceSubgroup.Gamma0 3 := by
+  have hU' : U = A2Gamma0Three.U₃ := Subtype.ext hU
+  subst hU'
+  exact A2Gamma0Three.closure_T_U_neg_one_eq
+
+end S_CongruenceSubgroup_closure_T_U_neg_one_eq_Gamma0_three
+end P2MW
+export P2MW.S_CongruenceSubgroup_closure_T_U_neg_one_eq_Gamma0_three (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups in
+theorem CongruenceSubgroup.closure_T_U_neg_one_eq_Gamma0_three (U : SL(2, ℤ))
+    (hU : (U : Matrix (Fin 2) (Fin 2) ℤ) = !![1, 0; -3, 1]) :
+    Subgroup.closure ({ModularGroup.T, U, -1} : Set SL(2, ℤ)) = CongruenceSubgroup.Gamma0 3 :=
+  solution U hU
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_CongruenceSubgroup_conj_T_zpow_mem_Gamma1_of_mem_sup_zpowers_neg_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_CongruenceSubgroup_conj_T_zpow_mem_Gamma1_of_mem_sup_zpowers_neg_one.lean
new file mode 100644
index 0000000000..fc0854a7eb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_CongruenceSubgroup_conj_T_zpow_mem_Gamma1_of_mem_sup_zpowers_neg_one.lean
@@ -0,0 +1,147 @@
+/-
+Based on Prove2Me node CongruenceSubgroup.conj_T_zpow_mem_Gamma1_of_mem_sup_zpowers_neg_one
+(985a4f11-d773-5ca7-90a1-5d6ab46e8aa4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3761268e-163f-5b0c-8713-5137caf71e30
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Regularity of the cusps of Γ₁(M) for M ∤ 4
+
+Theorem statement: `CongruenceSubgroup.conj_T_zpow_mem_Gamma1_of_mem_sup_zpowers_neg_one`
+(`985a4f11-d773-5ca7-90a1-5d6ab46e8aa4`), by Claude, 2026-09-05.
+
+Proof: submission `3761268e-163f-5b0c-8713-5137caf71e30`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a natural number with $M \nmid 4$, let $\sigma \in \mathrm{SL}_2(\mathbb{Z})$, and let $h
+\in \mathbb{Z}$, where $T = \begin{pmatrix} 1 & 1 \\ 0 & 1\end{pmatrix}$ denotes the standard
+parabolic generator `ModularGroup.T`. Assume that the conjugate $\sigma T^{h} \sigma^{-1}$ lies in
+the subgroup of $\mathrm{SL}_2(\mathbb{Z})$ generated by $\Gamma_1(M)$ together with $-I$, i.e. in
+the join (as subgroups) of `CongruenceSubgroup.Gamma1 M` and the subgroup of integral powers of
+$-1$. Then $\sigma T^{h} \sigma^{-1}$ already lies in $\Gamma_1(M)$ itself, that is, its reduction
+modulo $M$ has upper-left and lower-right entries congruent to $1$ and lower-left entry congruent to
+$0$. Thus, for $M$ not dividing $4$, a parabolic element of $\pm\Gamma_1(M)$ conjugate in
+$\mathrm{SL}_2(\mathbb{Z})$ to a power of $T$ cannot be of the form $-\gamma$ with $\gamma \in
+\Gamma_1(M)$; the hypothesis $M \nmid 4$ is needed, since the cusp $1/2$ of $\Gamma_1(4)$ is
+irregular.
+
+This is the statement that all cusps of $\Gamma_1(M)$ are regular when $M \nmid 4$: a parabolic
+stabiliser element in $\pm\Gamma_1(M)$ comes from $\Gamma_1(M)$ with the correct sign. It is used in
+the computation of the order of vanishing of a modular form at a cusp in terms of the width of that
+cusp, via
+[`ModularCurve.ord_eq_neg_width_of_order_eq_mul_ord_of_qExpansion_slash`]
+(thm.html#ModularCurve.ord_eq_neg_width_of_order_eq_mul_ord_of_qExpansion_slash).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_CongruenceSubgroup_conj_T_zpow_mem_Gamma1_of_mem_sup_zpowers_neg_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_CongruenceSubgroup_conj_T_zpow_mem_Gamma1_of_mem_sup_zpowers_neg_one
+
+open scoped MatrixGroups
+
+namespace RegCuspAux
+
+def pmGamma1 (M : ℕ) : Subgroup SL(2, ℤ) where
+  carrier := {g | g ∈ CongruenceSubgroup.Gamma1 M ∨ -g ∈ CongruenceSubgroup.Gamma1 M}
+  one_mem' := Or.inl (one_mem _)
+  mul_mem' := by
+    rintro a b (ha | ha) (hb | hb)
+    · exact Or.inl (mul_mem ha hb)
+    · exact Or.inr (by rw [← mul_neg]; exact mul_mem ha hb)
+    · exact Or.inr (by rw [← neg_mul]; exact mul_mem ha hb)
+    · exact Or.inl (by rw [← neg_mul_neg]; exact mul_mem ha hb)
+  inv_mem' := by
+    rintro a (ha | ha)
+    · exact Or.inl (inv_mem ha)
+    · refine Or.inr ?_
+      have h : (-a)⁻¹ = -a⁻¹ := inv_eq_of_mul_eq_one_right (by rw [neg_mul_neg, mul_inv_cancel])
+      rw [← h]; exact inv_mem ha
+
+theorem mem_pmGamma1_iff (M : ℕ) (g : SL(2, ℤ)) :
+    g ∈ pmGamma1 M ↔ g ∈ CongruenceSubgroup.Gamma1 M ∨ -g ∈ CongruenceSubgroup.Gamma1 M := Iff.rfl
+
+theorem sup_le_pmGamma1 (M : ℕ) :
+    CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) ≤ pmGamma1 M :=
+  sup_le (fun _ hg => Or.inl hg)
+    (Subgroup.zpowers_le.2 (Or.inr (by rw [neg_neg]; exact one_mem _)))
+
+theorem trace_conj_T_zpow (σ : SL(2, ℤ)) (h : ℤ) :
+    ((σ * ModularGroup.T ^ h * σ⁻¹ : SL(2, ℤ)) 0 0 : ℤ) + (σ * ModularGroup.T ^ h * σ⁻¹ : SL(2, ℤ))
+      1 1 = 2 := by
+  have h1 : Matrix.trace ((σ * ModularGroup.T ^ h * σ⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) =
+      Matrix.trace ((ModularGroup.T ^ h : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) := by
+    rw [Matrix.SpecialLinearGroup.coe_mul, Matrix.SpecialLinearGroup.coe_mul, Matrix.mul_assoc,
+      Matrix.trace_mul_comm, Matrix.mul_assoc, ← Matrix.SpecialLinearGroup.coe_mul, inv_mul_cancel,
+      Matrix.SpecialLinearGroup.coe_one, Matrix.mul_one]
+  rw [Matrix.trace_fin_two, Matrix.trace_fin_two] at h1
+  have h2 : ((ModularGroup.T ^ h : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) = !![1, h; 0, 1] :=
+    ModularGroup.coe_T_zpow h
+  rw [h2] at h1
+  simpa using h1
+
+end RegCuspAux
+
+theorem solution (M : ℕ) (hM : ¬ M ∣ 4)
+    (σ : SL(2, ℤ)) (h : ℤ) (hmem : σ * ModularGroup.T ^ h * σ⁻¹ ∈ CongruenceSubgroup.Gamma1 M ⊔
+      Subgroup.zpowers (-1 : SL(2, ℤ))) :
+    σ * ModularGroup.T ^ h * σ⁻¹ ∈ CongruenceSubgroup.Gamma1 M := by
+  rcases (RegCuspAux.sup_le_pmGamma1 M hmem) with hg | hg
+  · exact hg
+  · exfalso
+    apply hM
+    set g : SL(2, ℤ) := σ * ModularGroup.T ^ h * σ⁻¹ with hgdef
+    have htr : (g 0 0 : ℤ) + g 1 1 = 2 := RegCuspAux.trace_conj_T_zpow σ h
+    have hneg := (CongruenceSubgroup.Gamma1_mem M (-g)).1 hg
+    have e00 : ((-g : SL(2, ℤ)) 0 0 : ℤ) = -(g 0 0) := by
+      simp [Matrix.SpecialLinearGroup.coe_neg]
+    have e11 : ((-g : SL(2, ℤ)) 1 1 : ℤ) = -(g 1 1) := by
+      simp [Matrix.SpecialLinearGroup.coe_neg]
+    have h00 : (((-(g 0 0) : ℤ)) : ZMod M) = 1 := by rw [← e00]; exact hneg.1
+    have h11 : (((-(g 1 1) : ℤ)) : ZMod M) = 1 := by rw [← e11]; exact hneg.2.1
+    have h2 : (((-2 : ℤ)) : ZMod M) = ((2 : ℤ) : ZMod M) := by
+      have : (((-(g 0 0 + g 1 1) : ℤ)) : ZMod M) = 2 := by
+        push_cast at h00 h11 ⊢
+        linear_combination h00 + h11
+      rw [htr] at this
+      exact_mod_cast this
+    have h3 := ((ZMod.intCast_eq_intCast_iff (-2) 2 M).1 h2).dvd
+    norm_num at h3
+    exact_mod_cast h3
+
+end S_CongruenceSubgroup_conj_T_zpow_mem_Gamma1_of_mem_sup_zpowers_neg_one
+end P2MW
+export P2MW.S_CongruenceSubgroup_conj_T_zpow_mem_Gamma1_of_mem_sup_zpowers_neg_one (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem CongruenceSubgroup.conj_T_zpow_mem_Gamma1_of_mem_sup_zpowers_neg_one (M : ℕ) (hM : ¬ M ∣ 4)
+    (σ : SL(2, ℤ)) (h : ℤ) (hmem : σ * ModularGroup.T ^ h * σ⁻¹ ∈ CongruenceSubgroup.Gamma1 M ⊔
+      Subgroup.zpowers (-1 : SL(2, ℤ))) :
+    σ * ModularGroup.T ^ h * σ⁻¹ ∈ CongruenceSubgroup.Gamma1 M :=
+  solution M hM σ h hmem
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_CongruenceSubgroup_eq_one_or_eq_neg_one_of_mem_Gamma1_of_smul_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_CongruenceSubgroup_eq_one_or_eq_neg_one_of_mem_Gamma1_of_smul_eq.lean
new file mode 100644
index 0000000000..d5696a4e66
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_CongruenceSubgroup_eq_one_or_eq_neg_one_of_mem_Gamma1_of_smul_eq.lean
@@ -0,0 +1,177 @@
+/-
+Based on Prove2Me node CongruenceSubgroup.eq_one_or_eq_neg_one_of_mem_Gamma1_of_smul_eq
+(7f7c71ea-e040-56c3-a693-c3f8106ba88b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e3200307-a462-5d5e-b237-fa2ef88b1f46
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.Complex.UpperHalfPlane.MoebiusAction
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Analysis.Complex.UpperHalfPlane.FixedPoints
+import Mathlib.Data.Int.Star
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Elements of ±Γ₁(M), M ≥ 4, fixing a point of H
+
+Theorem statement: `CongruenceSubgroup.eq_one_or_eq_neg_one_of_mem_Gamma1_of_smul_eq`
+(`7f7c71ea-e040-56c3-a693-c3f8106ba88b`), by Claude, 2026-09-05.
+
+Proof: submission `e3200307-a462-5d5e-b237-fa2ef88b1f46`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a natural number with $4 \le M$, and let $\gamma \in \mathrm{SL}_2(\mathbb{Z})$ be such
+that either $\gamma$ or $-\gamma$ lies in the congruence subgroup $\Gamma_1(M)$ (in Mathlib's
+formulation, `CongruenceSubgroup.Gamma1 M`, whose membership condition is that the $(0,0)$ and
+$(1,1)$ entries reduce to $1$ in $\mathbb{Z}/M$ and the $(1,0)$ entry reduces to $0$). Suppose there
+is a point $\tau$ of the upper half plane $\mathfrak{H}$ fixed by $\gamma$ for the usual action of
+$\mathrm{SL}_2(\mathbb{Z})$ on $\mathfrak{H}$ by fractional linear transformations, i.e. $\gamma
+\cdot \tau = \tau$. Then $\gamma = 1$ or $\gamma = -1$ in $\mathrm{SL}_2(\mathbb{Z})$. Thus the
+group $\pm\Gamma_1(M)$ acts on $\mathfrak{H}$ with trivial stabilisers modulo $\pm 1$ once $M \ge
+4$.
+
+This is the group-theoretic statement that $\Gamma_1(M)$ has no elliptic elements for $M \ge 4$, so
+that the modular curve $X_1(M)$ has no elliptic points (Diamond–Shurman, Exercise 2.3.7). It is used
+in the computation of genera and orders of vanishing on modular curves of level $\Gamma_1(M)$,
+specifically by
+[`ModularCurve.FullLevel.genusFF_fieldBar_eq`](thm.html#ModularCurve.FullLevel.genusFF_fieldBar_eq)
+and by
+[`ModularCurve.
+ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1_algebraicClosure`]
+(thm.html#ModularCurve.
+ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1_algebraicClosure).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_CongruenceSubgroup_eq_one_or_eq_neg_one_of_mem_Gamma1_of_smul_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_CongruenceSubgroup_eq_one_or_eq_neg_one_of_mem_Gamma1_of_smul_eq
+
+open scoped MatrixGroups
+open UpperHalfPlane
+
+namespace CongruenceSubgroup
+p2m_export "CongruenceSubgroup" "Gamma1_mem Gamma1"
+p2m_open "CongruenceSubgroup"
+
+theorem sq_trace_lt_four_or_eq_of_smul_eq (γ : SL(2, ℤ)) (τ : ℍ) (hτ : γ • τ = τ) :
+    (γ 0 0 + γ 1 1) ^ 2 < 4 ∨ γ = 1 ∨ γ = -1 := by
+  set g : GL (Fin 2) ℝ := Matrix.SpecialLinearGroup.mapGL ℝ γ with hg
+  have hgij : ∀ i j, g i j = ((γ i j : ℤ) : ℝ) := fun i j => by
+    simp [hg, Matrix.SpecialLinearGroup.mapGL, Matrix.SpecialLinearGroup.toGL]
+  have hfix : g • τ = τ := hτ
+  have hdet : g.val.det = 1 := by
+    rw [Matrix.det_fin_two]
+    simp only [hgij]
+    have h := γ.2
+    rw [Matrix.det_fin_two] at h
+    exact_mod_cast h
+  have hdetpos : 0 < g.val.det := by rw [hdet]; exact one_pos
+  by_cases hgc : g ∈ Subgroup.center (GL (Fin 2) ℝ)
+  · right
+    rw [Matrix.GeneralLinearGroup.mem_center_iff_val_mem_range_scalar] at hgc
+    obtain ⟨r, hr⟩ := hgc
+    have h00 : ((γ 0 0 : ℤ) : ℝ) = r := by rw [← hgij]; simp [← hr]
+    have h11 : ((γ 1 1 : ℤ) : ℝ) = r := by rw [← hgij]; simp [← hr]
+    have h01 : ((γ 0 1 : ℤ) : ℝ) = 0 := by rw [← hgij]; simp [← hr]
+    have h10 : ((γ 1 0 : ℤ) : ℝ) = 0 := by rw [← hgij]; simp [← hr]
+    have e01 : γ 0 1 = 0 := by exact_mod_cast h01
+    have e10 : γ 1 0 = 0 := by exact_mod_cast h10
+    have e0011 : γ 0 0 = γ 1 1 := by exact_mod_cast h00.trans h11.symm
+    have hd := γ.2
+    rw [Matrix.det_fin_two, e01, e10, ← e0011, mul_zero, sub_zero] at hd
+    have hsq : γ 0 0 = 1 ∨ γ 0 0 = -1 := by
+      rcases Int.eq_one_or_neg_one_of_mul_eq_one hd with h | h
+      · exact Or.inl h
+      · exact Or.inr h
+    rcases hsq with h1 | h1
+    · left
+      ext i j
+      fin_cases i <;> fin_cases j <;> simp [h1, e01, e10, ← e0011]
+    · right
+      ext i j
+      fin_cases i <;> fin_cases j <;> simp [h1, e01, e10, ← e0011]
+  · left
+    have hell := UpperHalfPlane.isElliptic_of_exists_smul_eq_self hdetpos hgc ⟨τ, hfix⟩
+    have h' : g.val.discr < 0 := hell
+    rw [Matrix.discr_fin_two, Matrix.trace_fin_two, hdet] at h'
+    have h'' : (((γ 0 0 + γ 1 1 : ℤ) : ℝ)) ^ 2 < 4 := by
+      push_cast
+      rw [← hgij 0 0, ← hgij 1 1]
+      linarith
+    exact_mod_cast h''
+
+theorem eq_one_or_eq_neg_one_of_mem_Gamma1_of_smul_eq (M : ℕ) (hM : 4 ≤ M) (γ : SL(2, ℤ))
+    (hγ : γ ∈ Gamma1 M ∨ -γ ∈ Gamma1 M) (τ : ℍ) (hτ : γ • τ = τ) : γ = 1 ∨ γ = -1 := by
+  rcases sq_trace_lt_four_or_eq_of_smul_eq γ τ hτ with hlt | h | h
+  · exfalso
+    set t : ℤ := γ 0 0 + γ 1 1 with ht
+    have ht1 : -1 ≤ t ∧ t ≤ 1 := by constructor <;> nlinarith
+    have hdvd : (M : ℤ) ∣ t - 2 ∨ (M : ℤ) ∣ t + 2 := by
+      rcases hγ with h | h
+      · left
+        rw [Gamma1_mem] at h
+        rw [← ZMod.intCast_zmod_eq_zero_iff_dvd, ht]
+        push_cast
+        rw [h.1, h.2.1]
+        norm_num
+      · right
+        rw [Gamma1_mem] at h
+        have h0 : (((-γ) 0 0 : ℤ) : ZMod M) = 1 := h.1
+        have h1 : (((-γ) 1 1 : ℤ) : ZMod M) = 1 := h.2.1
+        rw [Matrix.SpecialLinearGroup.coe_neg, Matrix.neg_apply, Int.cast_neg,
+          neg_eq_iff_eq_neg] at h0 h1
+        rw [← ZMod.intCast_zmod_eq_zero_iff_dvd, ht]
+        push_cast
+        rw [h0, h1]
+        norm_num
+    have hM' : (4 : ℤ) ≤ M := by exact_mod_cast hM
+    rcases hdvd with hd | hd
+    · have hne : t - 2 ≠ 0 := by omega
+      have hle := Int.le_of_dvd (by omega : 0 < -(t - 2)) ((dvd_neg).mpr hd)
+      omega
+    · have hle := Int.le_of_dvd (by omega : 0 < t + 2) hd
+      omega
+  · exact Or.inl h
+  · exact Or.inr h
+
+end CongruenceSubgroup
+
+theorem solution (M : ℕ) (hM : 4 ≤ M)
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma1 M ∨ -γ ∈ CongruenceSubgroup.Gamma1 M)
+    (τ : UpperHalfPlane) (hτ : γ • τ = τ) : γ = 1 ∨ γ = -1 :=
+  CongruenceSubgroup.eq_one_or_eq_neg_one_of_mem_Gamma1_of_smul_eq M hM γ hγ τ hτ
+
+end S_CongruenceSubgroup_eq_one_or_eq_neg_one_of_mem_Gamma1_of_smul_eq
+end P2MW
+export P2MW.S_CongruenceSubgroup_eq_one_or_eq_neg_one_of_mem_Gamma1_of_smul_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem CongruenceSubgroup.eq_one_or_eq_neg_one_of_mem_Gamma1_of_smul_eq (M : ℕ) (hM : 4 ≤ M)
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma1 M ∨ -γ ∈ CongruenceSubgroup.Gamma1 M)
+    (τ : UpperHalfPlane) (hτ : γ • τ = τ)
+    : γ = 1 ∨ γ = -1 :=
+  solution M hM γ hγ τ hτ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_CongruenceSubgroup_index_gamma1_sup_zpowers_neg_one_eq_three_mul_natCard_doubleCoset_and_eq_two_mul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_CongruenceSubgroup_index_gamma1_sup_zpowers_neg_one_eq_three_mul_natCard_doubleCoset_and_eq_two_mul.lean
new file mode 100644
index 0000000000..ef8d20dbb3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_CongruenceSubgroup_index_gamma1_sup_zpowers_neg_one_eq_three_mul_natCard_doubleCoset_and_eq_two_mul.lean
@@ -0,0 +1,359 @@
+/-
+Based on Prove2Me node
+CongruenceSubgroup.index_gamma1_sup_zpowers_neg_one_eq_three_mul_natCard_doubleCoset_and_eq_two_mul
+(ada43ca0-92a2-54ff-9dd3-dd3210222059) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 739c700b-2696-57cd-b5e1-f0321c11c27f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.GroupTheory.DoubleCoset
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Index of ±Γ₁(M) and elliptic double-coset counts
+
+Theorem statement:
+`CongruenceSubgroup.
+index_gamma1_sup_zpowers_neg_one_eq_three_mul_natCard_doubleCoset_and_eq_two_mul`
+(`ada43ca0-92a2-54ff-9dd3-dd3210222059`), by Claude, 2026-09-05.
+
+Proof: submission `739c700b-2696-57cd-b5e1-f0321c11c27f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a natural number, nonzero, with $5 \le M$. Inside $\mathrm{SL}_2(\mathbb{Z})$ consider
+the congruence subgroup $\Gamma_1(M)$ and the subgroup $\langle -1\rangle =$ `Subgroup.zpowers (-1)`
+generated by the central element $-1$; write $n$ for the index of their join $\Gamma_1(M) \sqcup
+\langle -1\rangle$ (the subgroup generated by $\Gamma_1(M)$ and $-1$, i.e. $\pm\Gamma_1(M)$) in
+$\mathrm{SL}_2(\mathbb{Z})$, as a natural number. The theorem asserts the conjunction of two
+equalities. First, $n = 3\,\#\bigl(\Gamma_1(M)\backslash \mathrm{SL}_2(\mathbb{Z})/\langle
+ST\rangle\bigr)$, where the right-hand factor is the cardinality of the set of double cosets of the
+underlying set of $\Gamma_1(M)$ and the underlying set of the cyclic subgroup generated by $S T$,
+with $S$ and $T$ the standard generators `ModularGroup.S` and `ModularGroup.T` of
+$\mathrm{SL}_2(\mathbb{Z})$. Second, $n = 2\,\#\bigl(\Gamma_1(M)\backslash
+\mathrm{SL}_2(\mathbb{Z})/\langle S\rangle\bigr)$, the double cosets now being taken with respect to
+the cyclic subgroup generated by $S$. Both cardinalities are `Nat.card` of the corresponding
+double-coset quotients.
+
+This is the standard count of the elliptic points of order $3$ and order $2$ on the modular curve
+$X_1(M)$: for $M \ge 5$ the groups $\langle ST\rangle$ of order $6$ and $\langle S\rangle$ of order
+$4$ act freely on the cosets $\Gamma_1(M)\backslash\mathrm{SL}_2(\mathbb{Z})$, so the two
+double-coset sets have $n/3$ and $n/2$ elements, and they compute the numbers of points of $X_1(M)$
+above $j = 0$ and $j = 1728$ in characteristic zero. It is used in the local analysis of valuations
+on the function field of $X_1(M)$ over $\mathbb{C}$, in particular in the determination of
+ramification indices above the $j$-line.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_CongruenceSubgroup_index_gamma1_sup_zpowers_neg_one_eq_three_mul_natCard_doubleCoset_and_eq_two_mul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_69aa16e5
+
+open scoped MatrixGroups
+
+namespace DCCount
+
+section General
+
+variable {G : Type*} [Group G] (Γ K : Subgroup G)
+
+noncomputable def dcMap :
+    DoubleCoset.Quotient (Γ : Set G) (K : Set G) × K → _root_.Quotient (QuotientGroup.rightRel Γ) :=
+  fun qk => Quotient.mk'' (qk.1.out * (qk.2 : G))
+
+theorem dcMap_apply (q : DoubleCoset.Quotient (Γ : Set G) (K : Set G)) (k : K) :
+    dcMap Γ K (q, k) = Quotient.mk'' (q.out * (k : G)) := rfl
+
+theorem dcMap_surjective : Function.Surjective (dcMap Γ K) := by
+  intro x
+  refine Quotient.inductionOn' x (fun g => ?_)
+  obtain ⟨h, hh, k, hk, he⟩ := DoubleCoset.mk_out_eq_mul Γ K g
+  refine ⟨(DoubleCoset.mk Γ K g, ⟨k⁻¹, K.inv_mem hk⟩), ?_⟩
+  rw [dcMap_apply]
+  refine Quotient.sound' (QuotientGroup.rightRel_apply.mpr ?_)
+  rw [he]
+  have : g * (h * g * k * k⁻¹)⁻¹ = h⁻¹ := by group
+  rw [this]
+  exact Γ.inv_mem hh
+
+theorem dcMap_injective (hfree : ∀ g : G, ∀ k ∈ K, g * k * g⁻¹ ∈ Γ → k = 1) :
+    Function.Injective (dcMap Γ K) := by
+  rintro ⟨q₁, k₁⟩ ⟨q₂, k₂⟩ h
+  rw [dcMap_apply, dcMap_apply] at h
+  have h' : (q₂.out * (k₂ : G)) * (q₁.out * (k₁ : G))⁻¹ ∈ Γ :=
+    QuotientGroup.rightRel_apply.mp (Quotient.exact' h)
+  have hq : DoubleCoset.mk Γ K q₁.out = DoubleCoset.mk Γ K q₂.out :=
+    DoubleCoset.eq.mpr ⟨(q₂.out * (k₂ : G)) * (q₁.out * (k₁ : G))⁻¹, h', (k₁ : G) * (k₂ : G)⁻¹,
+      K.mul_mem k₁.2 (K.inv_mem k₂.2), by group⟩
+  rw [DoubleCoset.out_eq', DoubleCoset.out_eq'] at hq
+  subst hq
+  have h'' : q₁.out * ((k₂ : G) * (k₁ : G)⁻¹) * q₁.out⁻¹ ∈ Γ := by
+    simpa only [mul_inv_rev, mul_assoc] using h'
+  have hk : (k₂ : G) * (k₁ : G)⁻¹ = 1 := hfree q₁.out _ (K.mul_mem k₂.2 (K.inv_mem k₁.2)) h''
+  rw [mul_inv_eq_one] at hk
+  rw [Subtype.ext hk]
+
+theorem index_eq_natCard_doubleCoset_mul (hfree : ∀ g : G, ∀ k ∈ K, g * k * g⁻¹ ∈ Γ → k = 1) :
+    Γ.index = Nat.card (DoubleCoset.Quotient (Γ : Set G) (K : Set G)) * Nat.card K :=
+  calc Γ.index = Nat.card (G ⧸ Γ) := rfl
+    _ = Nat.card (_root_.Quotient (QuotientGroup.rightRel Γ)) :=
+        Nat.card_congr (QuotientGroup.quotientRightRelEquivQuotientLeftRel Γ).symm
+    _ = Nat.card (DoubleCoset.Quotient (Γ : Set G) (K : Set G) × K) :=
+        Nat.card_congr (Equiv.ofBijective (dcMap Γ K)
+          ⟨dcMap_injective Γ K hfree, dcMap_surjective Γ K⟩).symm
+    _ = _ := Nat.card_prod _ _
+
+theorem exists_pow_eq_of_mem_zpowers {x y : G} {m : ℕ} (hm : 0 < m) (hx : x ^ m = 1)
+    (hy : y ∈ Subgroup.zpowers x) : ∃ r : ℕ, r < m ∧ x ^ r = y := by
+  obtain ⟨k, rfl⟩ := Subgroup.mem_zpowers_iff.1 hy
+  have h0 : 0 ≤ k % (m : ℤ) := Int.emod_nonneg k (by exact_mod_cast hm.ne')
+  have h1 : k % (m : ℤ) < m := Int.emod_lt_of_pos k (by exact_mod_cast hm)
+  refine ⟨(k % (m : ℤ)).toNat, by omega, ?_⟩
+  rw [zpow_eq_zpow_emod' k hx, ← zpow_natCast, Int.toNat_of_nonneg h0]
+
+end General
+
+open Matrix.SpecialLinearGroup ModularGroup CongruenceSubgroup
+
+theorem trace_conj (g k : SL(2, ℤ)) :
+    Matrix.trace ((g * k * g⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) =
+      Matrix.trace (k : Matrix (Fin 2) (Fin 2) ℤ) := by
+  rw [mul_assoc, coe_mul, Matrix.trace_mul_comm, ← coe_mul, mul_assoc, inv_mul_cancel, mul_one]
+
+theorem trace_mod_of_mem_Gamma1 {M : ℕ} {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma1 M) :
+    ((Matrix.trace (γ : Matrix (Fin 2) (Fin 2) ℤ) : ℤ) : ZMod M) = 2 := by
+  rw [Gamma1_mem] at hγ
+  rw [Matrix.trace_fin_two, Int.cast_add, hγ.1, hγ.2.1]
+  norm_num
+
+theorem not_mem_Gamma1_of_trace {M : ℕ} (hM : 5 ≤ M) {γ : SL(2, ℤ)} (t : ℤ)
+    (ht : Matrix.trace (γ : Matrix (Fin 2) (Fin 2) ℤ) = t) (ht' : t = 0 ∨ t = 1 ∨ t = -1 ∨ t = -2) :
+    γ ∉ Gamma1 M := by
+  intro hγ
+  have h := trace_mod_of_mem_Gamma1 hγ
+  rw [ht, show (2 : ZMod M) = ((2 : ℤ) : ZMod M) by
+    norm_num, ZMod.intCast_eq_intCast_iff_dvd_sub] at h
+  have hpos : (0 : ℤ) < 2 - t := by rcases ht' with rfl | rfl | rfl | rfl <;> norm_num
+  have hle := Int.le_of_dvd hpos h
+  have hM' : (5 : ℤ) ≤ M := by exact_mod_cast hM
+  rcases ht' with rfl | rfl | rfl | rfl <;> omega
+
+theorem neg_one_not_mem_Gamma1 {M : ℕ} (hM : 5 ≤ M) : (-1 : SL(2, ℤ)) ∉ Gamma1 M :=
+  not_mem_Gamma1_of_trace hM (-2)
+    (by rw [coe_neg, Matrix.SpecialLinearGroup.coe_one, Matrix.trace_neg, Matrix.trace_one,
+      Fintype.card_fin]; norm_num)
+    (by norm_num)
+
+theorem S_sq : ModularGroup.S ^ 2 = (-1 : SL(2, ℤ)) :=
+  Subtype.ext (by rw [coe_pow, pow_two, S_mul_S_eq, coe_neg, Matrix.SpecialLinearGroup.coe_one])
+
+theorem S_pow_four : ModularGroup.S ^ 4 = (1 : SL(2, ℤ)) := by
+  rw [show (4 : ℕ) = 2 * 2 from rfl, pow_mul, S_sq, neg_one_sq]
+
+theorem coe_ST : ((ModularGroup.S * ModularGroup.T : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) =
+    !![0, -1; 1, 1] := by
+  rw [coe_mul, coe_S, coe_T, Matrix.mul_fin_two]
+  norm_num
+
+theorem coe_ST_sq :
+    (((ModularGroup.S * ModularGroup.T) ^ 2 : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) =
+    !![-1, -1; 1, 0] := by
+  rw [coe_pow, coe_ST, pow_two, Matrix.mul_fin_two]
+  norm_num
+
+theorem ST_pow_three : (ModularGroup.S * ModularGroup.T) ^ 3 = (-1 : SL(2, ℤ)) := by
+  apply Subtype.ext
+  rw [pow_succ, coe_mul, coe_ST_sq, coe_ST, coe_neg, Matrix.SpecialLinearGroup.coe_one,
+    Matrix.mul_fin_two, Matrix.one_fin_two]
+  ext i j
+  fin_cases i <;> fin_cases j <;> norm_num
+
+theorem ST_pow_six : (ModularGroup.S * ModularGroup.T) ^ 6 = (1 : SL(2, ℤ)) := by
+  rw [show (6 : ℕ) = 3 * 2 from rfl, pow_mul, ST_pow_three, neg_one_sq]
+
+theorem mem_zpowers_neg_one_iff {x : SL(2, ℤ)} :
+    x ∈ Subgroup.zpowers (-1 : SL(2, ℤ)) ↔ x = 1 ∨ x = -1 := by
+  constructor
+  · intro hx
+    obtain ⟨r, hr, rfl⟩ := exists_pow_eq_of_mem_zpowers (m := 2) (by norm_num) neg_one_sq hx
+    interval_cases r
+    · exact Or.inl (pow_zero _)
+    · exact Or.inr (pow_one _)
+  · rintro (rfl | rfl)
+    · exact Subgroup.one_mem _
+    · exact Subgroup.mem_zpowers _
+
+theorem zpowers_neg_one_normal : (Subgroup.zpowers (-1 : SL(2, ℤ))).Normal :=
+  ⟨fun n hn g => by
+    rw [mem_zpowers_neg_one_iff] at hn
+    rw [mem_zpowers_neg_one_iff]
+    rcases hn with rfl | rfl
+    · exact Or.inl (by group)
+    · exact Or.inr (by rw [mul_neg_one, neg_mul, mul_inv_cancel])⟩
+
+theorem relIndex_Gamma1_sup {M : ℕ} (hM : 5 ≤ M) :
+    (Gamma1 M).relIndex (Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))) = 2 := by
+  have := zpowers_neg_one_normal
+  rw [Subgroup.relIndex_eq_two_iff]
+  refine ⟨-1, Subgroup.mem_sup_right (Subgroup.mem_zpowers _), fun b hb => ?_⟩
+  rw [Subgroup.mem_sup_of_normal_right] at hb
+  obtain ⟨γ, hγ, z, hz, rfl⟩ := hb
+  rw [mem_zpowers_neg_one_iff] at hz
+  rcases hz with rfl | rfl
+  · refine Or.inr ⟨by rwa [mul_one], fun h => neg_one_not_mem_Gamma1 hM ?_⟩
+    have := (Gamma1 M).mul_mem ((Gamma1 M).inv_mem hγ) h
+    rwa [mul_one, inv_mul_cancel_left] at this
+  · refine Or.inl ⟨by rwa [mul_neg_one, mul_neg_one,
+      neg_neg], fun h => neg_one_not_mem_Gamma1 hM ?_⟩
+    have := (Gamma1 M).mul_mem ((Gamma1 M).inv_mem hγ) h
+    rwa [inv_mul_cancel_left] at this
+
+theorem index_Gamma1_eq {M : ℕ} (hM : 5 ≤ M) :
+    (Gamma1 M).index = 2 * (Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index := by
+  have h := Subgroup.relIndex_mul_index (H := Gamma1 M)
+    (K := Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))) le_sup_left
+  rw [relIndex_Gamma1_sup hM] at h
+  exact h.symm
+
+theorem free_S {M : ℕ} (hM : 5 ≤ M) (g : SL(2, ℤ)) (k : SL(2, ℤ))
+    (hk : k ∈ Subgroup.zpowers ModularGroup.S) (hmem : g * k * g⁻¹ ∈ Gamma1 M) : k = 1 := by
+  obtain ⟨r, hr, rfl⟩ := exists_pow_eq_of_mem_zpowers (m := 4) (by norm_num) S_pow_four hk
+  interval_cases r
+  · exact pow_zero _
+  · exact absurd hmem (not_mem_Gamma1_of_trace hM 0
+      (by rw [trace_conj, pow_one, coe_S, Matrix.trace_fin_two_of]; norm_num) (by norm_num))
+  · exact absurd hmem (not_mem_Gamma1_of_trace hM (-2)
+      (by rw [trace_conj, S_sq, coe_neg, Matrix.SpecialLinearGroup.coe_one, Matrix.trace_neg,
+        Matrix.trace_one, Fintype.card_fin]
+          norm_num) (by norm_num))
+  · exact absurd hmem (not_mem_Gamma1_of_trace hM 0
+      (by rw [trace_conj, pow_succ, S_sq, neg_one_mul, coe_neg, Matrix.trace_neg, coe_S,
+            Matrix.trace_fin_two_of]; norm_num) (by norm_num))
+
+theorem free_ST {M : ℕ} (hM : 5 ≤ M) (g : SL(2, ℤ)) (k : SL(2, ℤ))
+    (hk : k ∈ Subgroup.zpowers (ModularGroup.S * ModularGroup.T)) (hmem : g * k * g⁻¹ ∈ Gamma1 M) :
+    k = 1 := by
+  obtain ⟨r, hr, rfl⟩ := exists_pow_eq_of_mem_zpowers (m := 6) (by norm_num) ST_pow_six hk
+  interval_cases r
+  · exact pow_zero _
+  · exact absurd hmem (not_mem_Gamma1_of_trace hM 1
+      (by rw [trace_conj, pow_one, coe_ST, Matrix.trace_fin_two_of]; norm_num) (by norm_num))
+  · exact absurd hmem (not_mem_Gamma1_of_trace hM (-1)
+      (by rw [trace_conj, coe_ST_sq, Matrix.trace_fin_two_of]; norm_num) (by norm_num))
+  · exact absurd hmem (not_mem_Gamma1_of_trace hM (-2)
+      (by rw [trace_conj, ST_pow_three, coe_neg, Matrix.SpecialLinearGroup.coe_one,
+        Matrix.trace_neg, Matrix.trace_one,
+            Fintype.card_fin]; norm_num) (by norm_num))
+  · exact absurd hmem (not_mem_Gamma1_of_trace hM (-1)
+      (by rw [trace_conj, pow_succ, ST_pow_three, neg_one_mul, coe_neg, Matrix.trace_neg, coe_ST,
+            Matrix.trace_fin_two_of]; norm_num) (by norm_num))
+  · exact absurd hmem (not_mem_Gamma1_of_trace hM 1
+      (by rw [trace_conj, show (5 : ℕ) = 3 + 2 from rfl, pow_add, ST_pow_three, neg_one_mul,
+        coe_neg,
+            Matrix.trace_neg, coe_ST_sq, Matrix.trace_fin_two_of]; norm_num) (by norm_num))
+
+theorem natCard_zpowers_S : Nat.card (Subgroup.zpowers ModularGroup.S) = 4 := by
+  rw [Nat.card_zpowers]
+  refine (orderOf_eq_iff (by norm_num)).2 ⟨S_pow_four, fun m hm hm0 h => ?_⟩
+  interval_cases m
+  · have h' := congrArg (fun A : SL(2, ℤ) => (A : Matrix (Fin 2) (Fin 2) ℤ) 0 0) h
+    rw [pow_one, coe_S, Matrix.SpecialLinearGroup.coe_one] at h'
+    norm_num at h'
+  · have h' := congrArg (fun A : SL(2, ℤ) => (A : Matrix (Fin 2) (Fin 2) ℤ) 0 0) h
+    rw [S_sq, coe_neg, Matrix.SpecialLinearGroup.coe_one] at h'
+    norm_num at h'
+  · have h' := congrArg (fun A : SL(2, ℤ) => (A : Matrix (Fin 2) (Fin 2) ℤ) 0 0) h
+    rw [pow_succ, S_sq, neg_one_mul, coe_neg, coe_S, Matrix.SpecialLinearGroup.coe_one] at h'
+    norm_num at h'
+
+theorem natCard_zpowers_ST : Nat.card (Subgroup.zpowers (ModularGroup.S * ModularGroup.T)) = 6 := by
+  rw [Nat.card_zpowers]
+  refine (orderOf_eq_iff (by norm_num)).2 ⟨ST_pow_six, fun m hm hm0 h => ?_⟩
+  interval_cases m
+  · have h' := congrArg (fun A : SL(2, ℤ) => (A : Matrix (Fin 2) (Fin 2) ℤ) 0 0) h
+    rw [pow_one, coe_ST, Matrix.SpecialLinearGroup.coe_one] at h'
+    norm_num at h'
+  · have h' := congrArg (fun A : SL(2, ℤ) => (A : Matrix (Fin 2) (Fin 2) ℤ) 1 1) h
+    rw [coe_ST_sq, Matrix.SpecialLinearGroup.coe_one] at h'
+    norm_num at h'
+  · have h' := congrArg (fun A : SL(2, ℤ) => (A : Matrix (Fin 2) (Fin 2) ℤ) 0 0) h
+    rw [ST_pow_three, coe_neg, Matrix.SpecialLinearGroup.coe_one] at h'
+    norm_num at h'
+  · have h' := congrArg (fun A : SL(2, ℤ) => (A : Matrix (Fin 2) (Fin 2) ℤ) 0 0) h
+    rw [pow_succ, ST_pow_three, neg_one_mul, coe_neg, coe_ST,
+      Matrix.SpecialLinearGroup.coe_one] at h'
+    norm_num at h'
+  · have h' := congrArg (fun A : SL(2, ℤ) => (A : Matrix (Fin 2) (Fin 2) ℤ) 1 1) h
+    rw [show (5 : ℕ) = 3 + 2 from rfl, pow_add, ST_pow_three, neg_one_mul, coe_neg, coe_ST_sq,
+      Matrix.SpecialLinearGroup.coe_one] at h'
+    norm_num at h'
+
+end DCCount
+
+open DCCount in
+theorem solution
+    (M : ℕ) [NeZero M] (hM : 5 ≤ M) :
+    (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index =
+        3 * Nat.card (DoubleCoset.Quotient
+          (CongruenceSubgroup.Gamma1 M : Set SL(2, ℤ))
+          (Subgroup.zpowers (ModularGroup.S * ModularGroup.T) : Set SL(2, ℤ))) ∧
+      (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index =
+        2 * Nat.card (DoubleCoset.Quotient
+          (CongruenceSubgroup.Gamma1 M : Set SL(2, ℤ))
+          (Subgroup.zpowers ModularGroup.S : Set SL(2, ℤ))) := by
+  have h2 := index_Gamma1_eq hM
+  have hST := index_eq_natCard_doubleCoset_mul (CongruenceSubgroup.Gamma1 M)
+    (Subgroup.zpowers (ModularGroup.S * ModularGroup.T)) (free_ST hM)
+  have hS := index_eq_natCard_doubleCoset_mul (CongruenceSubgroup.Gamma1 M)
+    (Subgroup.zpowers ModularGroup.S) (free_S hM)
+  rw [natCard_zpowers_ST] at hST
+  rw [natCard_zpowers_S] at hS
+  constructor <;> omega
+
+end S_OVERLONG_69aa16e5
+end P2MW
+export
+  P2MW.S_OVERLONG_69aa16e5
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+
+namespace CongruenceSubgroup
+
+theorem index_gamma1_sup_zpowers_neg_one_eq_three_mul_natCard_doubleCoset_and_eq_two_mul
+    (M : ℕ) [NeZero M] (hM : 5 ≤ M) :
+    (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index =
+        3 * Nat.card (DoubleCoset.Quotient
+          (CongruenceSubgroup.Gamma1 M : Set SL(2, ℤ))
+          (Subgroup.zpowers (ModularGroup.S * ModularGroup.T) : Set SL(2, ℤ))) ∧
+      (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index =
+        2 * Nat.card (DoubleCoset.Quotient
+          (CongruenceSubgroup.Gamma1 M : Set SL(2, ℤ))
+          (Subgroup.zpowers ModularGroup.S : Set SL(2, ℤ))) :=
+  solution M hM
+
+end CongruenceSubgroup
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_CongruenceSubgroup_one_mem_strictPeriods_Gamma0.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_CongruenceSubgroup_one_mem_strictPeriods_Gamma0.lean
new file mode 100644
index 0000000000..5d43055e17
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_CongruenceSubgroup_one_mem_strictPeriods_Gamma0.lean
@@ -0,0 +1,88 @@
+/-
+Based on Prove2Me node CongruenceSubgroup.one_mem_strictPeriods_Gamma0
+(78b85fa4-bdd5-57a2-975e-2c775a128376) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 92a02cbc-2583-5f49-b340-9ac317890855
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Cusps
+
+import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+import Mathlib.Algebra.Lie.OfAssociative
+import Mathlib.Algebra.Algebra.Rat
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# 1 is a strict period of Γ₀(N)
+
+Theorem statement: `CongruenceSubgroup.one_mem_strictPeriods_Gamma0`
+(`78b85fa4-bdd5-57a2-975e-2c775a128376`), by Claude, 2026-09-05.
+
+Proof: submission `92a02cbc-2583-5f49-b340-9ac317890855`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+For every natural number $N$, the real number $1$ belongs to the additive subgroup of strict
+periods, `Subgroup.strictPeriods`, of the image of $\Gamma_0(N)$ in $\mathrm{GL}_2(\mathbb{R})$.
+Here $\Gamma_0(N) \subseteq \mathrm{SL}_2(\mathbb{Z})$ is `CongruenceSubgroup.Gamma0 N`, the
+subgroup of integral matrices of determinant $1$ whose lower-left entry is divisible by $N$, and the
+ambient group is its image under the homomorphism `Matrix.SpecialLinearGroup.mapGL ℝ` which sends an
+element of $\mathrm{SL}_2(\mathbb{Z})$ to the corresponding invertible real $2 \times 2$ matrix; for
+a subgroup $\Gamma$ of $\mathrm{GL}_2(\mathbb{R})$, Mathlib's `Subgroup.strictPeriods` is the
+additive subgroup of those $x \in \mathbb{R}$ for which the upper triangular unipotent matrix with
+off-diagonal entry $x$ lies in $\Gamma$. Thus the assertion is exactly that the translation
+$\begin{pmatrix}1&1\\0&1\end{pmatrix}$ lies in the image of $\Gamma_0(N)$, with no hypothesis on $N$
+(the degenerate value $N = 0$ is included).
+
+This is the statement that the cusp $\infty$ of $\Gamma_0(N)$ has width dividing $1$, i.e. that
+forms of level $\Gamma_0(N)$ are invariant under $\tau \mapsto \tau + 1$ and so admit a
+$q$-expansion in $q = e^{2\pi i \tau}$. It is the side condition required by Mathlib's $q$-expansion
+theory, and is invoked throughout the treatment of $q$-coefficients of modular and cusp forms of
+level $\Gamma_0(N)$, for instance in the normalisation of Hecke eigenforms and in the construction
+of ring homomorphisms out of Hecke algebras.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_CongruenceSubgroup_one_mem_strictPeriods_Gamma0.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_CongruenceSubgroup_one_mem_strictPeriods_Gamma0
+
+open scoped MatrixGroups
+
+theorem solution (N : ℕ) :
+    (1 : ℝ) ∈ (Subgroup.map (Matrix.SpecialLinearGroup.mapGL ℝ) (CongruenceSubgroup.Gamma0
+      N)).strictPeriods := by
+  have hT : ModularGroup.T ∈ CongruenceSubgroup.Gamma0 N := by
+    rw [CongruenceSubgroup.Gamma0_mem]
+    simp [ModularGroup.T]
+  have h := Subgroup.strictPeriods_eq_zmultiples_one_of_T_mem hT
+  rw [h]
+  exact AddSubgroup.mem_zmultiples (1 : ℝ)
+
+end S_CongruenceSubgroup_one_mem_strictPeriods_Gamma0
+end P2MW
+export P2MW.S_CongruenceSubgroup_one_mem_strictPeriods_Gamma0 (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem CongruenceSubgroup.one_mem_strictPeriods_Gamma0 (N : ℕ) :
+    (1 : ℝ) ∈ (Subgroup.map (Matrix.SpecialLinearGroup.mapGL ℝ) (CongruenceSubgroup.Gamma0
+      N)).strictPeriods :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspFormClass_isZeroAt_heckeT.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspFormClass_isZeroAt_heckeT.lean
new file mode 100644
index 0000000000..db071039da
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspFormClass_isZeroAt_heckeT.lean
@@ -0,0 +1,216 @@
+/-
+Based on Prove2Me node CuspFormClass.isZeroAt_heckeT
+(5abc8999-77a2-5cb0-bba7-bacfd5d3df35) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission bbe5a43e-5a11-5fd0-9437-ab991aeeb955
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Vanishing of Tₚ f at the cusps of Γ
+
+Theorem statement: `CuspFormClass.isZeroAt_heckeT` (`5abc8999-77a2-5cb0-bba7-bacfd5d3df35`), by
+Claude, 2026-09-05.
+
+Proof: submission `bbe5a43e-5a11-5fd0-9437-ab991aeeb955`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a type of functions from the upper half-plane $\mathbb{H}$ to $\mathbb{C}$ (via a
+`FunLike` instance), let $\Gamma$ be a subgroup of $\mathrm{GL}_2(\mathbb{R})$ which is arithmetic
+in the sense of `Subgroup.IsArithmetic`, let $k \in \mathbb{Z}$, and assume $F$ is a class of cusp
+forms of weight $k$ on $\Gamma$ (`CuspFormClass F Γ k`: holomorphy, weight-$k$ invariance under
+$\Gamma$, and vanishing at all cusps of $\Gamma$). Let $f : F$, let $p$ be a natural number, and let
+$c \in \mathbb{P}^1(\mathbb{R}) =$ `OnePoint ℝ` satisfy `IsCusp c Γ`. Then the function
+$$\mathrm{heckeT}\,k\,p\,f \;=\; \sum_{j < p} f \mid_k \mathrm{heckeMatrix}\,p\,j \;+\; f \mid_k
+\mathrm{heckeDiagMatrix}\,p$$ is zero at $c$ in the sense of `OnePoint.IsZeroAt … k`, i.e. for every
+$g \in \mathrm{GL}_2(\mathbb{R})$ carrying $\infty$ to $c$ the weight-$k$ slash of this function by
+$g$ tends to $0$ along the filter at $i\infty$. Here $\mathrm{heckeDiagMatrix}\,p$ is the identity
+for $p = 0$ and $\begin{pmatrix} p & 0 \\ 0 & 1\end{pmatrix}$ otherwise, and
+$\mathrm{heckeMatrix}\,p\,j$ is the identity for $p = 0$ and $\begin{pmatrix} 1 & j \\ 0 &
+p\end{pmatrix}$ otherwise. No condition relating $p$ to the level of $\Gamma$ is assumed.
+
+This is the cusp condition for the weight-$k$ Hecke operator $T_p$: applying $T_p$ to a cusp form
+again gives a function vanishing at every cusp of $\Gamma$. It supplies the `zero_at_cusps`
+component needed to package $T_p f$ as a cusp form, and is used in the construction of
+Hecke-eigenform bases and in the comparison of eigenforms of different level.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_CuspFormClass_isZeroAt_heckeT.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_CuspFormClass_isZeroAt_heckeT
+
+namespace ModularForm
+p2m_export "ModularForm" "add ext upperTriangularGL heckeMatrix heckeDiagMatrix heckeMatrix_zero \
+  heckeDiagMatrix_zero heckeU heckeT heckeU_def heckeT_eq_heckeU_add"
+namespace S06W2
+p2m_open "ModularForm"
+
+open UpperHalfPlane OnePoint
+p2m_open_scoped "MatrixGroups ModularForm P2MW.S_CuspFormClass_isZeroAt_heckeT.ModularForm"
+
+section RatCusps
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} [Γ.IsArithmetic] {k : ℤ}
+
+theorem isCusp_ratCast_smul {c : OnePoint ℝ} (hc : IsCusp c Γ) (g : GL (Fin 2) ℚ) :
+    IsCusp (Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) g • c) Γ := by
+  rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z, isCusp_SL2Z_iff] at hc ⊢
+  obtain ⟨c, rfl⟩ := hc
+  exact ⟨g • c, by rw [← Rat.coe_castHom, OnePoint.map_smul]⟩
+
+theorem isBoundedAt_slash_ratCast [ModularFormClass F Γ k] (f : F) (g : GL (Fin 2) ℚ)
+    {c : OnePoint ℝ}
+    (hc : IsCusp c Γ) : c.IsBoundedAt (⇑f ∣[k] (Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) g)) k
+      :=
+  OnePoint.IsBoundedAt.smul_iff.mp (ModularFormClass.bdd_at_cusps f (isCusp_ratCast_smul hc g))
+
+theorem isZeroAt_slash_ratCast [CuspFormClass F Γ k] (f : F) (g : GL (Fin 2) ℚ) {c : OnePoint ℝ}
+    (hc : IsCusp c Γ) : c.IsZeroAt (⇑f ∣[k] (Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) g)) k :=
+  OnePoint.IsZeroAt.smul_iff.mp (CuspFormClass.zero_at_cusps f (isCusp_ratCast_smul hc g))
+
+end RatCusps
+
+section HeckeMatrices
+
+def ratUpperTriangularGL (a b d : ℚ) (had : a * d ≠ 0) : GL (Fin 2) ℚ :=
+  Matrix.GeneralLinearGroup.mkOfDetNeZero !![a, b; 0, d]
+    (by rwa [Matrix.det_fin_two_of, mul_zero, sub_zero])
+
+theorem upperTriangularGL_eq_map (a b d : ℚ) (had : a * d ≠ 0) :
+    upperTriangularGL a b d (by exact_mod_cast had) =
+      Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) (ratUpperTriangularGL a b d had) := by
+  ext i j
+  fin_cases i <;> fin_cases j <;>
+    simp [ratUpperTriangularGL, upperTriangularGL, Matrix.GeneralLinearGroup.mkOfDetNeZero]
+
+theorem exists_heckeMatrix_eq_map (p j : ℕ) :
+    ∃ g : GL (Fin 2) ℚ, heckeMatrix p j = Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) g := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · exact ⟨1, by rw [heckeMatrix_zero, map_one]⟩
+  · refine ⟨ratUpperTriangularGL 1 j p (by rw [one_mul]; exact_mod_cast hp), ?_⟩
+    ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp [heckeMatrix, hp, ratUpperTriangularGL, upperTriangularGL,
+        Matrix.GeneralLinearGroup.mkOfDetNeZero]
+
+theorem exists_heckeDiagMatrix_eq_map (p : ℕ) :
+    ∃ g : GL (Fin 2) ℚ, heckeDiagMatrix p = Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) g := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · exact ⟨1, by rw [heckeDiagMatrix_zero, map_one]⟩
+  · refine ⟨ratUpperTriangularGL p 0 1 (by rw [mul_one]; exact_mod_cast hp), ?_⟩
+    ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp [heckeDiagMatrix, hp, ratUpperTriangularGL, upperTriangularGL,
+        Matrix.GeneralLinearGroup.mkOfDetNeZero]
+
+end HeckeMatrices
+
+section Cusps
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} [Γ.IsArithmetic] {k : ℤ}
+
+theorem isBoundedAt_sum {ι : Type*} {c : OnePoint ℝ} {k : ℤ} (s : Finset ι)
+    {f : ι → ℍ → ℂ} (hf : ∀ i ∈ s, c.IsBoundedAt (f i) k) : c.IsBoundedAt (∑ i ∈ s, f i) k := by
+  classical
+  induction s using Finset.induction_on with
+  | empty =>
+    intro g _
+    rw [Finset.sum_empty, SlashAction.zero_slash]
+    exact Filter.const_boundedAtFilter _ (0 : ℂ)
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha]
+    exact (hf a (Finset.mem_insert_self a s)).add (ih fun i hi => hf i (Finset.mem_insert_of_mem
+      hi))
+
+theorem isZeroAt_sum {ι : Type*} {c : OnePoint ℝ} {k : ℤ} (s : Finset ι)
+    {f : ι → ℍ → ℂ} (hf : ∀ i ∈ s, c.IsZeroAt (f i) k) : c.IsZeroAt (∑ i ∈ s, f i) k := by
+  classical
+  induction s using Finset.induction_on with
+  | empty =>
+    intro g _
+    rw [Finset.sum_empty, SlashAction.zero_slash]
+    exact Filter.zero_zeroAtFilter _
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha]
+    exact (hf a (Finset.mem_insert_self a s)).add (ih fun i hi => hf i (Finset.mem_insert_of_mem
+      hi))
+
+theorem isBoundedAt_heckeU [ModularFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ}
+    (hc : IsCusp c Γ) :
+    c.IsBoundedAt (heckeU k p ⇑f) k := by
+  rw [heckeU_def]
+  refine isBoundedAt_sum _ fun j _ => ?_
+  obtain ⟨g, hg⟩ := exists_heckeMatrix_eq_map p j
+  rw [hg]
+  exact isBoundedAt_slash_ratCast f g hc
+
+theorem isBoundedAt_heckeT [ModularFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ}
+    (hc : IsCusp c Γ) :
+    c.IsBoundedAt (heckeT k p ⇑f) k := by
+  rw [heckeT_eq_heckeU_add]
+  refine (isBoundedAt_heckeU f p hc).add ?_
+  obtain ⟨g, hg⟩ := exists_heckeDiagMatrix_eq_map p
+  rw [hg]
+  exact isBoundedAt_slash_ratCast f g hc
+
+theorem isZeroAt_heckeU [CuspFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ} (hc : IsCusp c Γ) :
+    c.IsZeroAt (heckeU k p ⇑f) k := by
+  rw [heckeU_def]
+  refine isZeroAt_sum _ fun j _ => ?_
+  obtain ⟨g, hg⟩ := exists_heckeMatrix_eq_map p j
+  rw [hg]
+  exact isZeroAt_slash_ratCast f g hc
+
+theorem isZeroAt_heckeT [CuspFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ} (hc : IsCusp c Γ) :
+    c.IsZeroAt (heckeT k p ⇑f) k := by
+  rw [heckeT_eq_heckeU_add]
+  refine (isZeroAt_heckeU f p hc).add ?_
+  obtain ⟨g, hg⟩ := exists_heckeDiagMatrix_eq_map p
+  rw [hg]
+  exact isZeroAt_slash_ratCast f g hc
+
+end Cusps
+
+end ModularForm.S06W2
+
+theorem solution {F : Type*} [FunLike F UpperHalfPlane ℂ]
+    {Γ : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)} [Γ.IsArithmetic] {k : ℤ}
+    [CuspFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ} (hc : IsCusp c Γ) :
+    OnePoint.IsZeroAt c (ModularForm.heckeT k p ⇑f) k :=
+  ModularForm.S06W2.isZeroAt_heckeT f p hc
+
+end S_CuspFormClass_isZeroAt_heckeT
+end P2MW
+export P2MW.S_CuspFormClass_isZeroAt_heckeT (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem CuspFormClass.isZeroAt_heckeT {F : Type*} [FunLike F UpperHalfPlane ℂ]
+    {Γ : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)} [Γ.IsArithmetic] {k : ℤ}
+    [CuspFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ} (hc : IsCusp c Γ) :
+    OnePoint.IsZeroAt c (ModularForm.heckeT k p ⇑f) k :=
+  solution f p hc
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspFormClass_isZeroAt_heckeU.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspFormClass_isZeroAt_heckeU.lean
new file mode 100644
index 0000000000..bf0c0a5a87
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspFormClass_isZeroAt_heckeU.lean
@@ -0,0 +1,215 @@
+/-
+Based on Prove2Me node CuspFormClass.isZeroAt_heckeU
+(ece42e12-8ebf-578b-a9e3-e516f92a3dae) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 36a4c2f8-0236-5129-84d4-38efaca790a4
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Uₚ f vanishes at every cusp when f is a cusp form
+
+Theorem statement: `CuspFormClass.isZeroAt_heckeU` (`ece42e12-8ebf-578b-a9e3-e516f92a3dae`), by
+Claude, 2026-09-05.
+
+Proof: submission `36a4c2f8-0236-5129-84d4-38efaca790a4`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a type of functions from the upper half-plane $\mathbb{H}$ to $\mathbb{C}$, let $\Gamma$
+be a subgroup of $\mathrm{GL}_2(\mathbb{R})$ that is arithmetic, let $k$ be an integer, and suppose
+$F$ is a class of weight-$k$ cusp forms on $\Gamma$ (in particular each $f : F$ is holomorphic,
+invariant under the weight-$k$ slash action of $\Gamma$, and vanishes at all cusps of $\Gamma$). Let
+$f : F$, let $p$ be a natural number, and let $c \in \mathbb{P}^1(\mathbb{R}) =$ `OnePoint ℝ` be a
+cusp of $\Gamma$, i.e. `IsCusp c Γ` holds. The conclusion is that the function
+$$\mathrm{heckeU}\,k\,p\,f \;=\; \sum_{j=0}^{p-1} f \mid_k \begin{pmatrix} 1 & j \\ 0 &
+p\end{pmatrix},$$ where for $p \neq 0$ the $j$-th matrix is `upperTriangularGL 1 j p` and for $p =
+0$ the sum is empty, vanishes at the cusp $c$ in weight $k$ in the sense of `OnePoint.IsZeroAt`. No
+congruence or level condition on $\Gamma$ relative to $p$ is assumed: the assertion is about the
+function $U_p f$ on $\mathbb{H}$ and the cusps of the given $\Gamma$ only.
+
+This is the cusp-vanishing half of the statement that the Hecke operator $U_p$ preserves cusp forms,
+and it supplies the `zero_at_cusps` condition needed to package $U_p f$ as a cusp form (for instance
+on $\Gamma_0(N)$ with $p \mid N$). It is used in the construction of the $U_p$ and $T_p$ action on
+spaces of cusp forms, and thence in the level-lowering and oldform/newform arguments that decompose
+eigenforms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_CuspFormClass_isZeroAt_heckeU.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_CuspFormClass_isZeroAt_heckeU
+
+namespace ModularForm
+p2m_export "ModularForm" "add ext upperTriangularGL heckeMatrix heckeDiagMatrix heckeMatrix_zero \
+  heckeDiagMatrix_zero heckeU heckeT heckeU_def heckeT_eq_heckeU_add"
+namespace S06W2
+p2m_open "ModularForm"
+
+open UpperHalfPlane OnePoint
+p2m_open_scoped "MatrixGroups ModularForm P2MW.S_CuspFormClass_isZeroAt_heckeU.ModularForm"
+
+section RatCusps
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} [Γ.IsArithmetic] {k : ℤ}
+
+theorem isCusp_ratCast_smul {c : OnePoint ℝ} (hc : IsCusp c Γ) (g : GL (Fin 2) ℚ) :
+    IsCusp (Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) g • c) Γ := by
+  rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z, isCusp_SL2Z_iff] at hc ⊢
+  obtain ⟨c, rfl⟩ := hc
+  exact ⟨g • c, by rw [← Rat.coe_castHom, OnePoint.map_smul]⟩
+
+theorem isBoundedAt_slash_ratCast [ModularFormClass F Γ k] (f : F) (g : GL (Fin 2) ℚ)
+    {c : OnePoint ℝ}
+    (hc : IsCusp c Γ) : c.IsBoundedAt (⇑f ∣[k] (Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) g)) k
+      :=
+  OnePoint.IsBoundedAt.smul_iff.mp (ModularFormClass.bdd_at_cusps f (isCusp_ratCast_smul hc g))
+
+theorem isZeroAt_slash_ratCast [CuspFormClass F Γ k] (f : F) (g : GL (Fin 2) ℚ) {c : OnePoint ℝ}
+    (hc : IsCusp c Γ) : c.IsZeroAt (⇑f ∣[k] (Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) g)) k :=
+  OnePoint.IsZeroAt.smul_iff.mp (CuspFormClass.zero_at_cusps f (isCusp_ratCast_smul hc g))
+
+end RatCusps
+
+section HeckeMatrices
+
+def ratUpperTriangularGL (a b d : ℚ) (had : a * d ≠ 0) : GL (Fin 2) ℚ :=
+  Matrix.GeneralLinearGroup.mkOfDetNeZero !![a, b; 0, d]
+    (by rwa [Matrix.det_fin_two_of, mul_zero, sub_zero])
+
+theorem upperTriangularGL_eq_map (a b d : ℚ) (had : a * d ≠ 0) :
+    upperTriangularGL a b d (by exact_mod_cast had) =
+      Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) (ratUpperTriangularGL a b d had) := by
+  ext i j
+  fin_cases i <;> fin_cases j <;>
+    simp [ratUpperTriangularGL, upperTriangularGL, Matrix.GeneralLinearGroup.mkOfDetNeZero]
+
+theorem exists_heckeMatrix_eq_map (p j : ℕ) :
+    ∃ g : GL (Fin 2) ℚ, heckeMatrix p j = Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) g := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · exact ⟨1, by rw [heckeMatrix_zero, map_one]⟩
+  · refine ⟨ratUpperTriangularGL 1 j p (by rw [one_mul]; exact_mod_cast hp), ?_⟩
+    ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp [heckeMatrix, hp, ratUpperTriangularGL, upperTriangularGL,
+        Matrix.GeneralLinearGroup.mkOfDetNeZero]
+
+theorem exists_heckeDiagMatrix_eq_map (p : ℕ) :
+    ∃ g : GL (Fin 2) ℚ, heckeDiagMatrix p = Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) g := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · exact ⟨1, by rw [heckeDiagMatrix_zero, map_one]⟩
+  · refine ⟨ratUpperTriangularGL p 0 1 (by rw [mul_one]; exact_mod_cast hp), ?_⟩
+    ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp [heckeDiagMatrix, hp, ratUpperTriangularGL, upperTriangularGL,
+        Matrix.GeneralLinearGroup.mkOfDetNeZero]
+
+end HeckeMatrices
+
+section Cusps
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} [Γ.IsArithmetic] {k : ℤ}
+
+theorem isBoundedAt_sum {ι : Type*} {c : OnePoint ℝ} {k : ℤ} (s : Finset ι)
+    {f : ι → ℍ → ℂ} (hf : ∀ i ∈ s, c.IsBoundedAt (f i) k) : c.IsBoundedAt (∑ i ∈ s, f i) k := by
+  classical
+  induction s using Finset.induction_on with
+  | empty =>
+    intro g _
+    rw [Finset.sum_empty, SlashAction.zero_slash]
+    exact Filter.const_boundedAtFilter _ (0 : ℂ)
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha]
+    exact (hf a (Finset.mem_insert_self a s)).add (ih fun i hi => hf i (Finset.mem_insert_of_mem
+      hi))
+
+theorem isZeroAt_sum {ι : Type*} {c : OnePoint ℝ} {k : ℤ} (s : Finset ι)
+    {f : ι → ℍ → ℂ} (hf : ∀ i ∈ s, c.IsZeroAt (f i) k) : c.IsZeroAt (∑ i ∈ s, f i) k := by
+  classical
+  induction s using Finset.induction_on with
+  | empty =>
+    intro g _
+    rw [Finset.sum_empty, SlashAction.zero_slash]
+    exact Filter.zero_zeroAtFilter _
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha]
+    exact (hf a (Finset.mem_insert_self a s)).add (ih fun i hi => hf i (Finset.mem_insert_of_mem
+      hi))
+
+theorem isBoundedAt_heckeU [ModularFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ}
+    (hc : IsCusp c Γ) :
+    c.IsBoundedAt (heckeU k p ⇑f) k := by
+  rw [heckeU_def]
+  refine isBoundedAt_sum _ fun j _ => ?_
+  obtain ⟨g, hg⟩ := exists_heckeMatrix_eq_map p j
+  rw [hg]
+  exact isBoundedAt_slash_ratCast f g hc
+
+theorem isBoundedAt_heckeT [ModularFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ}
+    (hc : IsCusp c Γ) :
+    c.IsBoundedAt (heckeT k p ⇑f) k := by
+  rw [heckeT_eq_heckeU_add]
+  refine (isBoundedAt_heckeU f p hc).add ?_
+  obtain ⟨g, hg⟩ := exists_heckeDiagMatrix_eq_map p
+  rw [hg]
+  exact isBoundedAt_slash_ratCast f g hc
+
+theorem isZeroAt_heckeU [CuspFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ} (hc : IsCusp c Γ) :
+    c.IsZeroAt (heckeU k p ⇑f) k := by
+  rw [heckeU_def]
+  refine isZeroAt_sum _ fun j _ => ?_
+  obtain ⟨g, hg⟩ := exists_heckeMatrix_eq_map p j
+  rw [hg]
+  exact isZeroAt_slash_ratCast f g hc
+
+theorem isZeroAt_heckeT [CuspFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ} (hc : IsCusp c Γ) :
+    c.IsZeroAt (heckeT k p ⇑f) k := by
+  rw [heckeT_eq_heckeU_add]
+  refine (isZeroAt_heckeU f p hc).add ?_
+  obtain ⟨g, hg⟩ := exists_heckeDiagMatrix_eq_map p
+  rw [hg]
+  exact isZeroAt_slash_ratCast f g hc
+
+end Cusps
+
+end ModularForm.S06W2
+
+theorem solution {F : Type*} [FunLike F UpperHalfPlane ℂ]
+    {Γ : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)} [Γ.IsArithmetic] {k : ℤ}
+    [CuspFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ} (hc : IsCusp c Γ) :
+    OnePoint.IsZeroAt c (ModularForm.heckeU k p ⇑f) k :=
+  ModularForm.S06W2.isZeroAt_heckeU f p hc
+
+end S_CuspFormClass_isZeroAt_heckeU
+end P2MW
+export P2MW.S_CuspFormClass_isZeroAt_heckeU (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem CuspFormClass.isZeroAt_heckeU {F : Type*} [FunLike F UpperHalfPlane ℂ]
+    {Γ : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)} [Γ.IsArithmetic] {k : ℤ}
+    [CuspFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ} (hc : IsCusp c Γ) :
+    OnePoint.IsZeroAt c (ModularForm.heckeU k p ⇑f) k :=
+  solution f p hc
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_dimFormula_le_finrank_gamma0.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_dimFormula_le_finrank_gamma0.lean
new file mode 100644
index 0000000000..81fe4b5ed7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_dimFormula_le_finrank_gamma0.lean
@@ -0,0 +1,323 @@
+/-
+Based on Prove2Me node CuspForm.dimFormula_le_finrank_gamma0
+(1382ecca-b09e-5965-92e5-54fd6407c802) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 47fd9cdf-6087-5f7c-acbb-6ca482fba83e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+
+import Mathlib.Analysis.CStarAlgebra.Classes
+import LeanPool.FLTEichlerShimura.Theorems.Thm_CongruenceSubgroup_one_mem_strictPeriods_Gamma0
+import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_finiteDimensional_Gamma0
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_degree_add_one_sub_genusFF_le_finrank_riemannRochSpace
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_cuspForm_qExpansion_eq_coeffMap_mul_thetaL_pow_of_isIntegral
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_divisor_degree_weight_and_isIntegral_of_mem_riemannRochSpace
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_genus_eq_genusFF_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_genus_modularFunctionFieldBar_eq_genusFormula
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasCanonicalDivisor_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_theta_coeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Lower bound for dim S_k(Γ₀(N)), k≥ 4 even
+
+Theorem statement: `CuspForm.dimFormula_le_finrank_gamma0` (`1382ecca-b09e-5965-92e5-54fd6407c802`),
+by Claude, 2026-09-05.
+
+Proof: submission `47fd9cdf-6087-5f7c-acbb-6ca482fba83e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number with $N \neq 0$ and let $k$ be a natural number with $4 \le k$ and $k$
+even. Write $\nu_2(N)$ for the number of $x \in \mathbb{Z}/N$ with $x^2 + 1 = 0$, $\nu_3(N)$ for the
+number of $x \in \mathbb{Z}/N$ with $x^2 + x + 1 = 0$, $\nu_\infty(N) = \sum_{d \mid N}
+\varphi(\gcd(d, N/d))$, and $\psi(N) = \sum_{d \mid N,\ d \text{ squarefree}} N/d$; let $g(N) \in
+\mathbb{Q}$ be the rational number $1 + \psi(N)/12 - \nu_2(N)/4 - \nu_3(N)/3 - \nu_\infty(N)/2$.
+Then the inequality
+$$(k-1)\bigl(g(N) - 1\bigr) + \lfloor k/4 \rfloor\, \nu_2(N) + \lfloor k/3 \rfloor\, \nu_3(N) +
+\bigl(k/2 - 1\bigr)\, \nu_\infty(N) \ \le\ \dim_{\mathbb{C}} S_k(\Gamma_0(N))$$
+holds in $\mathbb{Q}$, where $\lfloor k/4 \rfloor$ and $\lfloor k/3 \rfloor$ denote the quotients of
+$k$ by $4$ and by $3$ in the natural numbers, cast to $\mathbb{Q}$, while $k/2$ is computed in
+$\mathbb{Q}$, and the right-hand side is the $\mathbb{C}$-dimension of the space of cusp forms of
+weight $k$ (viewed as an integer weight) for the congruence subgroup $\Gamma_0(N)$, cast to
+$\mathbb{Q}$.
+
+The right-hand side is the classical dimension of $S_k(\Gamma_0(N))$ for even $k \ge 4$, and the
+left-hand side is the value predicted by the Riemann–Roch dimension formula expressed through the
+genus, elliptic-point and cusp numerics of $X_0(N)$; only the inequality ‘at least’ is asserted
+here, which is the half obtained from the Riemann inequality applied to an explicit divisor on the
+modular function field. It is used in the comparison of Eichler–Shimura and Hecke data
+([`HeckeEis.isCompl_range_eichlerShimuraMap_range_conj`]
+(thm.html#HeckeEis.isCompl_range_eichlerShimuraMap_range_conj))
+and in the corresponding lower bound for spaces of mod $p$ cusp forms
+([`ModPForms.dimFormulaCusp_le_finrank_modPCusp`]
+(thm.html#ModPForms.dimFormulaCusp_le_finrank_modPCusp)).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_CuspForm_dimFormula_le_finrank_gamma0.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_CuspForm_dimFormula_le_finrank_gamma0
+
+open ModularCurve AlgebraicCurve
+
+
+theorem linearIndependent_ringHom_comp_of_linearIndependent' {K L : Type*} [Field K] [Field L]
+    (ι : K →+* L) {n : ℕ} {X : Type*} {v : Fin n → X → K} (hv : LinearIndependent K v) :
+    LinearIndependent L (fun i x => ι (v i x)) := by
+  classical
+  let : Algebra K L := ι.toAlgebra
+  rw [Fintype.linearIndependent_iff] at hv ⊢
+  intro c hc i
+  let B := Module.Basis.ofVectorSpace K L
+  have hrel : ∀ k, ∑ j, (B.repr (c j) k) • v j = 0 := by
+    intro k
+    funext x
+    have hx := congr_fun hc x
+    simp only [Finset.sum_apply, Pi.smul_apply, smul_eq_mul, Pi.zero_apply] at hx ⊢
+    have hx' : ∑ j, (v j x) • c j = 0 := by
+      rw [← hx]
+      refine Finset.sum_congr rfl fun j _ => ?_
+      rw [Algebra.smul_def, RingHom.algebraMap_toAlgebra, mul_comm]
+    have h2 : B.repr (∑ j, (v j x) • c j) k = 0 := by
+      rw [hx', map_zero, Finsupp.zero_apply]
+    rw [map_sum, Finsupp.finsetSum_apply] at h2
+    rw [← h2]
+    refine Finset.sum_congr rfl fun j _ => ?_
+    rw [map_smul, Finsupp.smul_apply, smul_eq_mul, mul_comm]
+  have hzero : B.repr (c i) = 0 := by
+    ext k
+    rw [Finsupp.zero_apply]
+    exact hv _ (hrel k) i
+  exact (LinearEquiv.map_eq_zero_iff B.repr).mp hzero
+
+theorem thetaL_coeffEmb_jq_pow_ne_zero (m : ℕ) :
+    ModularCurve.thetaL ℂ (ModularCurve.coeffEmb ℂ ModularCurve.jq) ^ m ≠ 0 := by
+  apply pow_ne_zero
+  intro h
+  have h2 := congrArg (fun s : LaurentSeries ℂ => s.coeff (-1)) h
+  rw [ModularCurve.thetaL_apply, ModularCurve.theta_coeff, ModularCurve.coeffEmb_coeff,
+    ModularCurve.coeff_jq_neg_one,
+    map_one, HahnSeries.coeff_zero] at h2
+  norm_num at h2
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+theorem solution (N : ℕ) [NeZero N] (k : ℕ) (hk : 4 ≤ k) (hke : Even k) :
+    (((k : ℚ) - 1) * (ModularCurve.genusFormula N - 1) + ((k / 4 : ℕ) : ℚ) * (ModularCurve.nuTwo N :
+      ℚ)
+        + ((k / 3 : ℕ) : ℚ) * (ModularCurve.nuThree N : ℚ) + ((k : ℚ) / 2 - 1) *
+          (ModularCurve.cuspCount N : ℚ))
+      ≤ (Module.finrank ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) (k : ℤ)) : ℚ) := by
+  classical
+  obtain ⟨m, hkm⟩ : ∃ m, k = 2 * m := by obtain ⟨r, hr⟩ := hke; exact ⟨r, by omega⟩
+  subst hkm
+  have hm : 1 ≤ m := by omega
+  have hCD := ModularCurve.hasCanonicalDivisor_modularFunctionFieldBar N
+  have hfinS := CuspForm.finiteDimensional_Gamma0 N (2 * (m : ℤ))
+  obtain ⟨D, hdeg, hint⟩ :=
+    ModularCurve.exists_divisor_degree_weight_and_isIntegral_of_mem_riemannRochSpace N m hm
+  have hk4 : (2 * m / 4 : ℕ) = m / 2 := by omega
+  have hLHS : (((2 * m : ℕ) : ℚ) - 1) * (ModularCurve.genusFormula N - 1) + ((2 * m / 4 : ℕ) : ℚ) *
+    (ModularCurve.nuTwo N : ℚ)
+        + ((2 * m / 3 : ℕ) : ℚ) * (ModularCurve.nuThree N : ℚ) + (((2 * m : ℕ) : ℚ) / 2 - 1) *
+          (ModularCurve.cuspCount N : ℚ)
+      = (D.degree : ℚ) + 1 - ModularCurve.genusFormula N := by
+    rw [hdeg, hk4]
+    push_cast
+    ring
+  rw [hLHS]
+  have hRR := ModularCurve.degree_add_one_sub_genusFF_le_finrank_riemannRochSpace N D
+  have hg1 := ModularCurve.genus_eq_genusFF_modularFunctionFieldBar N
+  have hg2 := ModularCurve.genus_modularFunctionFieldBar_eq_genusFormula N
+  have hgen : ModularCurve.genusFormula N = (genusFF (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar
+    N) : ℚ) :=
+    by
+    rw [← hg2, hg1]
+  have hcast : (2 * (m : ℤ)) = ((2 * m : ℕ) : ℤ) := by push_cast; ring
+  have hRR' : (D.degree : ℚ) + 1 - ModularCurve.genusFormula N
+      ≤ (Module.finrank (AlgebraicClosure ℚ) ↥(riemannRochSpace D) : ℚ) := by
+    rw [hgen]
+    exact_mod_cast hRR
+  refine hRR'.trans ?_
+  rw [show ((2 * m : ℕ) : ℤ) = 2 * (m : ℤ) by push_cast; ring]
+  suffices key : Module.finrank (AlgebraicClosure ℚ) ↥(riemannRochSpace D)
+      ≤ Module.finrank ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) (2 * (m : ℤ))) by
+    exact_mod_cast key
+  by_cases hfin : Module.Finite (AlgebraicClosure ℚ) ↥(riemannRochSpace D)
+  swap
+  · rw [Module.finrank_of_not_finite hfin]; exact Nat.zero_le _
+  let b := Module.finBasis (AlgebraicClosure ℚ) ↥(riemannRochSpace D)
+  set r := Module.finrank (AlgebraicClosure ℚ) ↥(riemannRochSpace D) with hr
+  have : Algebra.IsAlgebraic ℚ (AlgebraicClosure ℚ) := AlgebraicClosure.isAlgebraic ℚ
+  let ι₀ : AlgebraicClosure ℚ →+* ℂ := (IsAlgClosed.lift : AlgebraicClosure ℚ →ₐ[ℚ] ℂ).toRingHom
+  have hex : ∀ i : Fin r, ∃ f : CuspForm (CongruenceSubgroup.Gamma0 N) (2 * (m : ℤ)),
+      HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 f) =
+        ModularCurve.coeffMap ι₀ (((b i : ↥(riemannRochSpace D)) : ↥(modularFunctionFieldBar N)) :
+          LaurentSeries (AlgebraicClosure ℚ)) *
+          ModularCurve.thetaL ℂ (ModularCurve.coeffEmb ℂ ModularCurve.jq) ^ m := by
+    intro i
+    obtain ⟨h₁, h₂⟩ := hint ((b i : ↥(riemannRochSpace D)) : ↥(modularFunctionFieldBar N)) (b i).2
+    exact ModularCurve.exists_cuspForm_qExpansion_eq_coeffMap_mul_thetaL_pow_of_isIntegral N m hm ι₀
+      _ h₁ h₂
+  choose f hf using hex
+  let v : Fin r → ℤ → AlgebraicClosure ℚ :=
+    fun i n => ((((b i : ↥(riemannRochSpace D)) : ↥(modularFunctionFieldBar N)) : LaurentSeries
+      (AlgebraicClosure ℚ))).coeff n
+  have hcoeff_sum : ∀ (s : Finset (Fin r)) (x : Fin r → LaurentSeries (AlgebraicClosure ℚ)) (n : ℤ),
+      (∑ i ∈ s, x i).coeff n = ∑ i ∈ s, (x i).coeff n := by
+    intro s x n
+    induction s using Finset.induction_on with
+    | empty => simp
+    | insert a s ha ih => rw [Finset.sum_insert ha, Finset.sum_insert ha, HahnSeries.coeff_add, ih]
+  have hcoeff_sumC : ∀ (s : Finset (Fin r)) (x : Fin r → LaurentSeries ℂ) (n : ℤ),
+      (∑ i ∈ s, x i).coeff n = ∑ i ∈ s, (x i).coeff n := by
+    intro s x n
+    induction s using Finset.induction_on with
+    | empty => simp
+    | insert a s ha ih => rw [Finset.sum_insert ha, Finset.sum_insert ha, HahnSeries.coeff_add, ih]
+  let E : ↥(riemannRochSpace D) →ₗ[AlgebraicClosure ℚ] (ℤ → AlgebraicClosure ℚ) :=
+    { toFun := fun y n => (((y : ↥(riemannRochSpace D)) : ↥(modularFunctionFieldBar N)) :
+      LaurentSeries (AlgebraicClosure ℚ)).coeff n
+      map_add' := by
+        intro y y'
+        funext n
+        first
+          | rfl
+      map_smul' := by
+        intro d y
+        funext n
+        simp only [Submodule.coe_smul, RingHom.id_apply, Pi.smul_apply, smul_eq_mul]
+        first
+          | rw [IntermediateField.coe_smul, HahnSeries.coeff_smul, smul_eq_mul]
+          | rw [IntermediateField.coe_smul, Algebra.smul_def,
+              ModularCurve.algebraMap_laurentSeries_eq_single,
+              HahnSeries.coeff_single_zero_mul] }
+  have hE : ∀ y n, E y n = (((y : ↥(riemannRochSpace D)) : ↥(modularFunctionFieldBar N)) :
+    LaurentSeries (AlgebraicClosure ℚ)).coeff n :=
+    fun _ _ => rfl
+  have hEinj : Function.Injective E := by
+    intro y y' h
+    apply Subtype.ext
+    apply Subtype.ext
+    ext n
+    exact congr_fun h n
+  have hv : LinearIndependent (AlgebraicClosure ℚ) v := by
+    rw [Fintype.linearIndependent_iff]
+    intro d hd
+    have hsum : E (∑ i, d i • b i) = 0 := by
+      rw [map_sum]
+      funext n
+      have hdn := congr_fun hd n
+      simp only [Finset.sum_apply, Pi.smul_apply, smul_eq_mul, Pi.zero_apply] at hdn
+      rw [Finset.sum_apply, Pi.zero_apply, ← hdn]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [map_smul, Pi.smul_apply, smul_eq_mul, hE]
+    have hzero' : (∑ i, d i • b i) = 0 := hEinj (by rw [hsum, map_zero])
+    exact Fintype.linearIndependent_iff.mp b.linearIndependent d hzero'
+  have hvC : LinearIndependent ℂ (fun i n => ι₀ (v i n)) :=
+    linearIndependent_ringHom_comp_of_linearIndependent' ι₀ hv
+  have hΓ := CongruenceSubgroup.one_mem_strictPeriods_Gamma0 N
+  have hcadd : ∀ φ ψ : CuspForm (CongruenceSubgroup.Gamma0 N) (2 * (m : ℤ)), ⇑(φ + ψ) = ⇑φ + ⇑ψ :=
+    fun _ _ => rfl
+  have hcsmul : ∀ (x : ℂ) (φ : CuspForm (CongruenceSubgroup.Gamma0 N) (2 * (m : ℤ))), ⇑(x • φ) = x •
+    ⇑φ :=
+    fun _ _ => rfl
+  have hczero : ⇑(0 : CuspForm (CongruenceSubgroup.Gamma0 N) (2 * (m : ℤ))) = 0 := rfl
+  have hqadd : ∀ φ ψ : CuspForm (CongruenceSubgroup.Gamma0 N) (2 * (m : ℤ)),
+      UpperHalfPlane.qExpansion 1 (⇑φ + ⇑ψ) = UpperHalfPlane.qExpansion 1 ⇑φ +
+        UpperHalfPlane.qExpansion 1 ⇑ψ := by
+    intro φ ψ
+    first
+      | exact ModularForm.qExpansion_add one_pos hΓ φ ψ
+  have hqsmul : ∀ (x : ℂ) (φ : CuspForm (CongruenceSubgroup.Gamma0 N) (2 * (m : ℤ))),
+      UpperHalfPlane.qExpansion 1 (x • ⇑φ) = x • UpperHalfPlane.qExpansion 1 ⇑φ := by
+    intro x φ
+    first
+      | exact ModularForm.qExpansion_smul one_pos hΓ x φ
+  have hqzero : UpperHalfPlane.qExpansion 1 (0 : UpperHalfPlane → ℂ) = 0 := by
+    first
+      | exact UpperHalfPlane.qExpansion_zero 1
+  have hT := thetaL_coeffEmb_jq_pow_ne_zero m
+  have hli : LinearIndependent ℂ f := by
+    rw [Fintype.linearIndependent_iff]
+    intro c hc
+    have hqsum : ∀ s : Finset (Fin r),
+        UpperHalfPlane.qExpansion 1 ⇑(∑ i ∈ s, c i • f i) = ∑ i ∈ s, c i • UpperHalfPlane.qExpansion
+          1 ⇑(f i) := by
+      intro s
+      induction s using Finset.induction_on with
+      | empty => rw [Finset.sum_empty, Finset.sum_empty, hczero, hqzero]
+      | insert a s ha ih =>
+        rw [Finset.sum_insert ha, Finset.sum_insert ha, hcadd, hqadd, hcsmul, hqsmul, ih]
+    have hq : ∑ i, c i • UpperHalfPlane.qExpansion 1 ⇑(f i) = 0 := by
+      rw [← hqsum Finset.univ, hc, hczero, hqzero]
+    have hq' : HahnSeries.ofPowerSeries ℤ ℂ (∑ i, c i • UpperHalfPlane.qExpansion 1 ⇑(f i)) = 0 :=
+      by
+      rw [hq, map_zero]
+    rw [map_sum] at hq'
+    have hterm : ∀ i, HahnSeries.ofPowerSeries ℤ ℂ (c i • UpperHalfPlane.qExpansion 1 ⇑(f i)) =
+        HahnSeries.C (c i) * (ModularCurve.coeffMap ι₀
+          (((b i : ↥(riemannRochSpace D)) : ↥(modularFunctionFieldBar N)) : LaurentSeries
+            (AlgebraicClosure ℚ)) *
+            ModularCurve.thetaL ℂ (ModularCurve.coeffEmb ℂ ModularCurve.jq) ^ m) := by
+      intro i
+      rw [PowerSeries.smul_eq_C_mul, map_mul, HahnSeries.ofPowerSeries_C, hf i]
+    simp_rw [hterm] at hq'
+    have hqL : (∑ i, HahnSeries.C (c i) * ModularCurve.coeffMap ι₀
+          (((b i : ↥(riemannRochSpace D)) : ↥(modularFunctionFieldBar N)) : LaurentSeries
+            (AlgebraicClosure ℚ))) *
+        ModularCurve.thetaL ℂ (ModularCurve.coeffEmb ℂ ModularCurve.jq) ^ m = 0 := by
+      rw [Finset.sum_mul, ← hq']
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [mul_assoc]
+    have hqL' : ∑ i, HahnSeries.C (c i) * ModularCurve.coeffMap ι₀
+        (((b i : ↥(riemannRochSpace D)) : ↥(modularFunctionFieldBar N)) : LaurentSeries
+          (AlgebraicClosure ℚ)) = 0 :=
+      (mul_eq_zero.mp hqL).resolve_right hT
+    have hrel : ∑ i, c i • (fun n => ι₀ (v i n)) = 0 := by
+      funext n
+      simp only [Finset.sum_apply, Pi.smul_apply, smul_eq_mul, Pi.zero_apply]
+      have h1 := congrArg (fun s : LaurentSeries ℂ => s.coeff n) hqL'
+      rw [hcoeff_sumC, HahnSeries.coeff_zero] at h1
+      rw [← h1]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [HahnSeries.C_mul_eq_smul, HahnSeries.coeff_smul, smul_eq_mul, ModularCurve.coeffMap_coeff]
+    exact Fintype.linearIndependent_iff.mp hvC c hrel
+  have hcard := hli.fintype_card_le_finrank
+  rw [Fintype.card_fin] at hcard
+  exact hcard
+
+end S_CuspForm_dimFormula_le_finrank_gamma0
+end P2MW
+export P2MW.S_CuspForm_dimFormula_le_finrank_gamma0 (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem CuspForm.dimFormula_le_finrank_gamma0 (N : ℕ) [NeZero N] (k : ℕ) (hk : 4 ≤ k) (hke : Even k)
+    :
+    (((k : ℚ) - 1) * (ModularCurve.genusFormula N - 1) + ((k / 4 : ℕ) : ℚ) * (ModularCurve.nuTwo N :
+      ℚ)
+        + ((k / 3 : ℕ) : ℚ) * (ModularCurve.nuThree N : ℚ) + ((k : ℚ) / 2 - 1) *
+          (ModularCurve.cuspCount N : ℚ))
+      ≤ (Module.finrank ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) (k : ℤ)) : ℚ) :=
+  solution N k hk hke
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_eq_zero_of_prime_not_dvd_of_qCoeff_eq_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_eq_zero_of_prime_not_dvd_of_qCoeff_eq_zero.lean
new file mode 100644
index 0000000000..b1ba93ef72
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_eq_zero_of_prime_not_dvd_of_qCoeff_eq_zero.lean
@@ -0,0 +1,538 @@
+/-
+Based on Prove2Me node CuspForm.eq_zero_of_prime_not_dvd_of_qCoeff_eq_zero
+(2792e208-01d1-53ad-a3f4-f3ce15b04e66) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4e7e7214-66b3-5401-b7a2-255331bfe9f1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_FreyPackage_ModMCarrier_Rescale
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperatorForms
+import LeanPool.FLTEichlerShimura.Theorems.Thm_CongruenceSubgroup_Gamma0_le_closure_T_union_setOf_dvd
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularFormClass_qCoeff_comp_heckeDiagMatrix_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_finiteDimensional_Gamma0
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularFormClass_eq_of_forall_qCoeff_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Vanishing of a cusp form supported on multiples of p ∤ m
+
+Theorem statement: `CuspForm.eq_zero_of_prime_not_dvd_of_qCoeff_eq_zero`
+(`2792e208-01d1-53ad-a3f4-f3ce15b04e66`), by Claude, 2026-09-05.
+
+Proof: submission `4e7e7214-66b3-5401-b7a2-255331bfe9f1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $m$ and $p$ be natural numbers with $m \neq 0$, let $p$ be prime and suppose $p \nmid m$. Let
+$F$ be a cusp form of weight $2$ for the congruence subgroup $\Gamma_0(m)$ of
+$\mathrm{SL}_2(\mathbb{Z})$ (as a subgroup of $\mathrm{GL}_2(\mathbb{R})$), i.e. an element of
+`CuspForm (CongruenceSubgroup.Gamma0 m) 2`. Write $a_n(F)$ for the $n$-th coefficient of the
+$q$-expansion of $F$ of width $1$, that is, [`ModularFormClass.qCoeff F
+n`](def/FLTPrelim_Modularity.html#L19) is the coefficient of $q^n$ in `qExpansion 1 F`. The
+hypothesis is that $a_n(F) = 0$ for every natural number $n$ not divisible by $p$; note that this
+includes $n = 0$ only when $p \nmid 0$ fails, so the condition is imposed exactly at those $n$ prime
+to the divisibility by $p$, and in particular at $n = 1$. The conclusion is that $F$ is the zero
+cusp form.
+
+This is the half of Atkin–Lehner's lemma on forms supported on multiples of a fixed integer in the
+case where that integer is a prime not dividing the level: a cusp form of weight $2$ and level $m$
+whose $q$-expansion is concentrated on multiples of such a prime $p$ vanishes identically. It is
+used in the study of the Hecke action on cusp forms of level $\Gamma_0(m)$, notably in the lemmas on
+the operator $U$ and on $q$-coefficients of newforms that feed the level-lowering arguments.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_CuspForm_eq_zero_of_prime_not_dvd_of_qCoeff_eq_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_CuspForm_eq_zero_of_prime_not_dvd_of_qCoeff_eq_zero
+
+noncomputable section
+
+open UpperHalfPlane ModularForm OnePoint Function
+open scoped MatrixGroups ModularForm Topology
+
+namespace AlliAux1Nonlac
+
+theorem qParam_vadd_pow {q n : ℕ} (hq : q ≠ 0) (hn : q ∣ n) (τ : ℍ) :
+    Periodic.qParam 1 ((((q : ℝ)⁻¹ +ᵥ τ : ℍ) : ℂ)) ^ n = Periodic.qParam 1 (τ : ℂ) ^ n := by
+  obtain ⟨k, rfl⟩ := hn
+  have hq' : (q : ℂ) ≠ 0 := by exact_mod_cast hq
+  unfold Periodic.qParam
+  rw [← Complex.exp_nat_mul, ← Complex.exp_nat_mul, UpperHalfPlane.coe_vadd]
+  push_cast
+  have hqq : (q : ℂ) * (q : ℂ)⁻¹ = 1 := mul_inv_cancel₀ hq'
+  rw [show (q : ℂ) * (k : ℂ) * (2 * Real.pi * Complex.I * (((q : ℂ))⁻¹ + (τ : ℂ)) / 1)
+      = (q : ℂ) * (k : ℂ) * (2 * Real.pi * Complex.I * (τ : ℂ) / 1) + (k : ℂ) * (2 * Real.pi *
+        Complex.I)
+      by linear_combination ((k : ℂ) * (2 * Real.pi * Complex.I)) * hqq,
+    Complex.exp_add, Complex.exp_nat_mul_two_pi_mul_I, mul_one]
+
+theorem apply_vadd_eq {m q : ℕ} [NeZero m] (hq : q ≠ 0)
+    (F : CuspForm (CongruenceSubgroup.Gamma0 m) 2)
+    (hF : ∀ n : ℕ, ¬ q ∣ n → ModularFormClass.qCoeff F n = 0) (τ : ℍ) :
+    F ((q : ℝ)⁻¹ +ᵥ τ) = F τ := by
+  have hper : Periodic (⇑F ∘ ofComplex) 1 :=
+    SlashInvariantFormClass.periodic_comp_ofComplex F (by simp)
+  have h1 := UpperHalfPlane.hasSum_qExpansion one_pos hper (CuspFormClass.holo F)
+    (ModularFormClass.bdd_at_infty F) τ
+  have h2 := UpperHalfPlane.hasSum_qExpansion one_pos hper (CuspFormClass.holo F)
+    (ModularFormClass.bdd_at_infty F) ((q : ℝ)⁻¹ +ᵥ τ)
+  have hfun : (fun n : ℕ => (qExpansion 1 ⇑F).coeff n • Periodic.qParam 1
+        ((((q : ℝ)⁻¹ +ᵥ τ : ℍ) : ℂ)) ^ n)
+      = fun n : ℕ => (qExpansion 1 ⇑F).coeff n • Periodic.qParam 1 (τ : ℂ) ^ n := by
+    funext n
+    by_cases hn : q ∣ n
+    · rw [qParam_vadd_pow hq hn]
+    · have h0 : (qExpansion 1 ⇑F).coeff n = 0 := hF n hn
+      rw [h0, zero_smul, zero_smul]
+  rw [hfun] at h2
+  exact h2.unique h1
+
+abbrev B (q : ℕ) : GL (Fin 2) ℝ := heckeDiagMatrix q
+
+def Tq (q : ℕ) : GL (Fin 2) ℝ :=
+  upperTriangularGL 1 ((q : ℝ)⁻¹) 1 (by norm_num)
+
+theorem T_mul_B {q : ℕ} (hq : q ≠ 0) :
+    (Matrix.SpecialLinearGroup.mapGL ℝ ModularGroup.T : GL (Fin 2) ℝ) * B q = B q * Tq q := by
+  have hq' : (q : ℝ) ≠ 0 := by exact_mod_cast hq
+  apply Units.ext
+  rw [Units.val_mul, Units.val_mul]
+  change ((ModularGroup.T : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).map (algebraMap ℤ ℝ) *
+      ((heckeDiagMatrix q : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ)
+    = ((heckeDiagMatrix q : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) *
+      ((Tq q : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ)
+  rw [val_heckeDiagMatrix hq, ModularGroup.coe_T, Tq, val_upperTriangularGL]
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp [Matrix.mul_apply, Fin.sum_univ_two, hq']
+
+theorem Binv_mul_T {q : ℕ} (hq : q ≠ 0) :
+    (B q)⁻¹ * (Matrix.SpecialLinearGroup.mapGL ℝ ModularGroup.T : GL (Fin 2) ℝ)
+      = Tq q * (B q)⁻¹ := by
+  rw [inv_mul_eq_iff_eq_mul, ← mul_assoc, ← T_mul_B hq, mul_assoc, mul_inv_cancel, mul_one]
+
+theorem slash_Tq_apply {q : ℕ} (f : ℍ → ℂ) (τ : ℍ) :
+    (f ∣[(2 : ℤ)] Tq q) τ = f ((q : ℝ)⁻¹ +ᵥ τ) := by
+  have hdet : ((Tq q).det : ℝ) = 1 := by
+    simp [Tq, Matrix.det_fin_two_of]
+  have hdetpos : 0 < ((Tq q).det : ℝ) := by rw [hdet]; exact one_pos
+  have hσ : UpperHalfPlane.σ (Tq q) = .refl ℝ ℂ := by
+    rw [UpperHalfPlane.σ, ite_eq_left hdetpos]
+  have hdenom : UpperHalfPlane.denom (Tq q) τ = 1 := by
+    simp [UpperHalfPlane.denom, Tq]
+  have hsmul : (Tq q • τ : ℍ) = (q : ℝ)⁻¹ +ᵥ τ := by
+    apply UpperHalfPlane.ext
+    rw [UpperHalfPlane.coe_smul_of_det_pos hdetpos, UpperHalfPlane.coe_vadd, hdenom, div_one]
+    simp [UpperHalfPlane.num, Tq, add_comm]
+  rw [ModularForm.slash_apply, hσ, hdet, hdenom, hsmul]
+  simp
+
+theorem exists_inv_cocycle {q R : ℕ} {γ : SL(2, ℤ)}
+    (hc : (R : ℤ) ∣ (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 0)
+    (hb : (q : ℤ) ∣ (γ : Matrix (Fin 2) (Fin 2) ℤ) 0 1) :
+    ∃ γ' : SL(2, ℤ), γ' ∈ CongruenceSubgroup.Gamma0 (q * R) ∧
+      (γ : Matrix (Fin 2) (Fin 2) ℤ) * FreyPackage.ModMCarrier.diagMatInt q
+        = FreyPackage.ModMCarrier.diagMatInt q * (γ' : Matrix (Fin 2) (Fin 2) ℤ) := by
+  have hdet : (γ : Matrix (Fin 2) (Fin 2) ℤ) 0 0 * (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 1 -
+      (γ : Matrix (Fin 2) (Fin 2) ℤ) 0 1 * (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 0 = 1 := by
+    have := γ.det_coe; rwa [Matrix.det_fin_two] at this
+  set a : ℤ := (γ : Matrix (Fin 2) (Fin 2) ℤ) 0 0 with ha
+  set b : ℤ := (γ : Matrix (Fin 2) (Fin 2) ℤ) 0 1 with hb'
+  set c : ℤ := (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 0 with hc'
+  set e : ℤ := (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 1 with he
+  have hγmat : (γ : Matrix (Fin 2) (Fin 2) ℤ) = !![a, b; c, e] := by
+    rw [ha, hb', hc', he]; exact Matrix.eta_fin_two _
+  obtain ⟨b₁, hb₁⟩ := hb
+  obtain ⟨c₁, hc₁⟩ := hc
+  have hdetδ : Matrix.det !![a, b₁; c * (q : ℤ), e] = 1 := by
+    rw [Matrix.det_fin_two_of]; linear_combination hdet + c * hb₁
+  refine ⟨⟨_, hdetδ⟩, ?_, ?_⟩
+  · rw [CongruenceSubgroup.Gamma0_mem]
+    change ((c * (q : ℤ) : ℤ) : ZMod (q * R)) = 0
+    rw [ZMod.intCast_zmod_eq_zero_iff_dvd, hc₁]
+    exact ⟨c₁, by push_cast; ring⟩
+  · change (γ : Matrix (Fin 2) (Fin 2) ℤ) * FreyPackage.ModMCarrier.diagMatInt q
+      = FreyPackage.ModMCarrier.diagMatInt q * !![a, b₁; c * (q : ℤ), e]
+    rw [hγmat]; unfold FreyPackage.ModMCarrier.diagMatInt
+    rw [Matrix.mul_fin_two, Matrix.mul_fin_two]
+    refine Matrix.ext fun i j => ?_
+    fin_cases i <;> fin_cases j
+    · change (a * (q : ℤ) + b * 0 : ℤ) = (q : ℤ) * a + 0 * (c * (q : ℤ)); ring
+    · change (a * 0 + b * 1 : ℤ) = (q : ℤ) * b₁ + 0 * e; linear_combination hb₁
+    · change (c * (q : ℤ) + e * 0 : ℤ) = 0 * a + 1 * (c * (q : ℤ)); ring
+    · change (c * 0 + e * 1 : ℤ) = 0 * b₁ + 1 * e; ring
+
+theorem map_int_mul_eq (A C : Matrix (Fin 2) (Fin 2) ℤ) :
+    (A * C).map (algebraMap ℤ ℝ) = A.map (algebraMap ℤ ℝ) * C.map (algebraMap ℤ ℝ) := by
+  rw [← RingHom.mapMatrix_apply, ← RingHom.mapMatrix_apply, ← RingHom.mapMatrix_apply, map_mul]
+
+theorem Binv_mul_mapGL {q R : ℕ} (hq : q ≠ 0) {γ : SL(2, ℤ)}
+    (hc : (R : ℤ) ∣ (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 0)
+    (hb : (q : ℤ) ∣ (γ : Matrix (Fin 2) (Fin 2) ℤ) 0 1) :
+    ∃ γ' : SL(2, ℤ), γ' ∈ CongruenceSubgroup.Gamma0 (q * R) ∧
+      (B q)⁻¹ * (Matrix.SpecialLinearGroup.mapGL ℝ γ : GL (Fin 2) ℝ)
+        = (Matrix.SpecialLinearGroup.mapGL ℝ γ' : GL (Fin 2) ℝ) * (B q)⁻¹ := by
+  obtain ⟨γ', hγ', hconj⟩ := exists_inv_cocycle hc hb
+  refine ⟨γ', hγ', ?_⟩
+  have hGL : (Matrix.SpecialLinearGroup.mapGL ℝ γ : GL (Fin 2) ℝ) * B q
+      = B q * (Matrix.SpecialLinearGroup.mapGL ℝ γ' : GL (Fin 2) ℝ) := by
+    apply Units.ext
+    rw [Units.val_mul, Units.val_mul]
+    change ((γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).map (algebraMap ℤ ℝ) *
+        ((heckeDiagMatrix q : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ)
+      = ((heckeDiagMatrix q : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) *
+        ((γ' : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).map (algebraMap ℤ ℝ)
+    rw [← FreyPackage.ModMCarrier.diagMatInt_map_eq hq, ← map_int_mul_eq, ← map_int_mul_eq, hconj]
+  rw [inv_mul_eq_iff_eq_mul, ← mul_assoc, ← hGL, mul_assoc, mul_inv_cancel, mul_one]
+
+def stab (f : ℍ → ℂ) (k : ℤ) : Subgroup SL(2, ℤ) where
+  carrier := {g | f ∣[k] (Matrix.SpecialLinearGroup.mapGL ℝ g : GL (Fin 2) ℝ) = f}
+  one_mem' := by
+    change f ∣[k] (Matrix.SpecialLinearGroup.mapGL ℝ (1 : SL(2, ℤ)) : GL (Fin 2) ℝ) = f
+    rw [map_one, SlashAction.slash_one]
+  mul_mem' := by
+    intro a b ha hb
+    change f ∣[k] (Matrix.SpecialLinearGroup.mapGL ℝ (a * b) : GL (Fin 2) ℝ) = f
+    rw [map_mul, SlashAction.slash_mul, ha, hb]
+  inv_mem' := by
+    intro a ha
+    change f ∣[k] (Matrix.SpecialLinearGroup.mapGL ℝ a⁻¹ : GL (Fin 2) ℝ) = f
+    calc f ∣[k] (Matrix.SpecialLinearGroup.mapGL ℝ a⁻¹ : GL (Fin 2) ℝ)
+        = (f ∣[k] (Matrix.SpecialLinearGroup.mapGL ℝ a : GL (Fin 2) ℝ)) ∣[k]
+            (Matrix.SpecialLinearGroup.mapGL ℝ a⁻¹ : GL (Fin 2) ℝ) := by rw [ha]
+      _ = f ∣[k] ((Matrix.SpecialLinearGroup.mapGL ℝ a : GL (Fin 2) ℝ) *
+            (Matrix.SpecialLinearGroup.mapGL ℝ a⁻¹ : GL (Fin 2) ℝ)) :=
+          (SlashAction.slash_mul k _ _ f).symm
+      _ = f := by rw [← map_mul, mul_inv_cancel, map_one, SlashAction.slash_one]
+
+theorem mem_stab_iff (f : ℍ → ℂ) (k : ℤ) (g : SL(2, ℤ)) :
+    g ∈ stab f k ↔ f ∣[k] (Matrix.SpecialLinearGroup.mapGL ℝ g : GL (Fin 2) ℝ) = f := Iff.rfl
+
+theorem isCusp_smul_of_rat {c : OnePoint ℝ} (hc : IsCusp c 𝒮ℒ) {g : GL (Fin 2) ℝ}
+    (gQ : GL (Fin 2) ℚ) (hg : gQ.map (Rat.castHom ℝ) = g) : IsCusp (g • c) 𝒮ℒ := by
+  subst hg
+  rw [isCusp_SL2Z_iff] at hc ⊢
+  obtain ⟨c₀, rfl⟩ := hc
+  exact ⟨gQ • c₀, by rw [← Rat.coe_castHom, OnePoint.map_smul]⟩
+
+section build
+
+variable {m q R : ℕ} [NeZero m] [NeZero R]
+
+def descend (hq : q ≠ 0) (hmR : m ∣ q * R) (F : CuspForm (CongruenceSubgroup.Gamma0 m) 2)
+    (hF : ∀ n : ℕ, ¬ q ∣ n → ModularFormClass.qCoeff F n = 0) :
+    CuspForm (CongruenceSubgroup.Gamma0 R) 2 :=
+  { toFun := ⇑F ∣[(2 : ℤ)] (B q)⁻¹
+    slash_action_eq' := fun γ hγ => by
+      obtain ⟨g, hg, rfl⟩ := Subgroup.mem_map.mp hγ
+      have hgen : Subgroup.closure ({ModularGroup.T} ∪ {γ : SL(2, ℤ) |
+            (R : ℤ) ∣ (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 0 ∧
+            (q : ℤ) ∣ (γ : Matrix (Fin 2) (Fin 2) ℤ) 0 1})
+          ≤ stab (⇑F ∣[(2 : ℤ)] (B q)⁻¹) 2 := by
+        rw [Subgroup.closure_le]
+        rintro g (hT | ⟨hgc, hgb⟩)
+        · rw [Set.mem_singleton_iff] at hT
+          subst hT
+          rw [SetLike.mem_coe, mem_stab_iff, ← SlashAction.slash_mul, Binv_mul_T hq,
+            SlashAction.slash_mul]
+          congr 1
+          funext τ
+          rw [slash_Tq_apply]
+          exact apply_vadd_eq hq F hF τ
+        · obtain ⟨g', hg', hconj⟩ := Binv_mul_mapGL (R := R) hq hgc hgb
+          rw [SetLike.mem_coe, mem_stab_iff, ← SlashAction.slash_mul, hconj,
+            SlashAction.slash_mul]
+          congr 1
+          have hg'm : g' ∈ CongruenceSubgroup.Gamma0 m := by
+            rw [CongruenceSubgroup.Gamma0_mem, ZMod.intCast_zmod_eq_zero_iff_dvd] at hg' ⊢
+            exact (Int.natCast_dvd_natCast.mpr hmR).trans (by exact_mod_cast hg')
+          exact SlashInvariantFormClass.slash_action_eq F _
+            (Subgroup.mem_map.mpr ⟨g', hg'm, rfl⟩)
+      have hle := (CongruenceSubgroup.Gamma0_le_closure_T_union_setOf_dvd R hq).trans hgen
+      exact (mem_stab_iff _ _ _).mp (hle hg)
+    holo' := (CuspFormClass.holo F).slash (2 : ℤ) (B q)⁻¹
+    zero_at_cusps' := fun {c} hc => by
+      refine IsZeroAt.smul_iff.mp (CuspFormClass.zero_at_cusps F ?_)
+      rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z] at hc ⊢
+      exact isCusp_smul_of_rat hc (FreyPackage.ModMCarrier.heckeDiagMatrixQ hq)⁻¹
+        (by rw [map_inv, FreyPackage.ModMCarrier.heckeDiagMatrixQ_map]) }
+
+theorem coe_descend (hq : q ≠ 0) (hmR : m ∣ q * R) (F : CuspForm (CongruenceSubgroup.Gamma0 m) 2)
+    (hF : ∀ n : ℕ, ¬ q ∣ n → ModularFormClass.qCoeff F n = 0) :
+    ⇑(descend hq hmR F hF) = ⇑F ∣[(2 : ℤ)] (B q)⁻¹ := rfl
+
+end build
+
+def Sc (p : ℕ) (hp : p ≠ 0) : GL (Fin 2) ℝ :=
+  upperTriangularGL p 0 p (by exact_mod_cast Nat.mul_ne_zero hp hp)
+
+theorem slash_Sc {p : ℕ} (hp : p ≠ 0) (f : ℍ → ℂ) : f ∣[(2 : ℤ)] Sc p hp = f := by
+  have hp' : (p : ℝ) ≠ 0 := by exact_mod_cast hp
+  have hpC : (p : ℂ) ≠ 0 := by exact_mod_cast hp
+  have hdet : ((Sc p hp).det : ℝ) = ((p * p : ℕ) : ℝ) := by
+    push_cast
+    simp [Sc, Matrix.det_fin_two_of]
+  have hdetpos : 0 < ((Sc p hp).det : ℝ) := by rw [hdet]; positivity
+  have hσ : UpperHalfPlane.σ (Sc p hp) = .refl ℝ ℂ := by
+    rw [UpperHalfPlane.σ, ite_eq_left hdetpos]
+  funext τ
+  have hdenom : UpperHalfPlane.denom (Sc p hp) τ = p := by
+    simp [UpperHalfPlane.denom, Sc]
+  have hsmul : (Sc p hp • τ : ℍ) = τ := by
+    apply UpperHalfPlane.ext
+    rw [UpperHalfPlane.coe_smul_of_det_pos hdetpos, hdenom]
+    simp [UpperHalfPlane.num, Sc, hpC]
+  rw [ModularForm.slash_apply, hσ, hdet, hdenom, hsmul]
+  simp only [ContinuousAlgEquiv.refl_apply, Nat.abs_cast, Complex.ofReal_natCast]
+  rw [show ((2 : ℤ) - 1) = 1 by norm_num, zpow_one, zpow_neg, mul_assoc]
+  push_cast
+  rw [show ((p : ℂ) * p) * ((p : ℂ) ^ (2 : ℤ))⁻¹ = 1 by rw [zpow_two]; field_simp, mul_one]
+
+theorem B_mul_heckeMatrix {p : ℕ} (hp : p ≠ 0) (j : ℕ) :
+    B p * heckeMatrix p j
+      = Sc p hp * (Matrix.SpecialLinearGroup.mapGL ℝ (ModularGroup.T ^ (j : ℤ)) : GL (Fin 2) ℝ)
+        := by
+  apply Units.ext
+  rw [Units.val_mul, Units.val_mul]
+  change ((heckeDiagMatrix p : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) *
+      ((heckeMatrix p j : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ)
+    = ((Sc p hp : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) *
+      ((ModularGroup.T ^ (j : ℤ) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).map (algebraMap ℤ ℝ)
+  rw [val_heckeDiagMatrix hp, val_heckeMatrix hp, Sc, val_upperTriangularGL]
+  have hT : ((ModularGroup.T ^ (j : ℤ) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) = !![1, (j : ℤ); 0,
+    1] :=
+    ModularGroup.coe_T_zpow (j : ℤ)
+  rw [hT]
+  ext i k
+  fin_cases i <;> fin_cases k <;> simp [Matrix.mul_apply, Fin.sum_univ_two]
+
+theorem heckeMatrix_eq {p : ℕ} (hp : p ≠ 0) (j : ℕ) :
+    heckeMatrix p j = (B p)⁻¹ * (Sc p hp *
+      (Matrix.SpecialLinearGroup.mapGL ℝ (ModularGroup.T ^ (j : ℤ)) : GL (Fin 2) ℝ)) := by
+  rw [eq_inv_mul_iff_mul_eq, B_mul_heckeMatrix hp]
+
+section up
+
+variable {m p : ℕ} [NeZero m]
+
+theorem heckeU_eq (hp : p.Prime) (F : CuspForm (CongruenceSubgroup.Gamma0 m) 2)
+    (hF : ∀ n : ℕ, ¬ p ∣ n → ModularFormClass.qCoeff F n = 0) :
+    heckeU 2 p ⇑F = (p : ℂ) • ⇑(descend hp.ne_zero (dvd_mul_left m p) F hF) := by
+  rw [heckeU_def]
+  have hterm : ∀ j ∈ Finset.range p, ⇑F ∣[(2 : ℤ)] heckeMatrix p j
+      = ⇑(descend hp.ne_zero (dvd_mul_left m p) F hF) := by
+    intro j _
+    rw [heckeMatrix_eq hp.ne_zero, SlashAction.slash_mul, SlashAction.slash_mul,
+      ← coe_descend hp.ne_zero (dvd_mul_left m p) F hF, slash_Sc]
+    exact SlashInvariantFormClass.slash_action_eq _ _
+      (Subgroup.mem_map.mpr ⟨ModularGroup.T ^ (j : ℤ),
+        Subgroup.zpow_mem _ (by simp [CongruenceSubgroup.Gamma0_mem, ModularGroup.coe_T]) _, rfl⟩)
+  rw [Finset.sum_congr rfl hterm, Finset.sum_const, Finset.card_range, ← Nat.cast_smul_eq_nsmul ℂ]
+
+def lift (hp : p.Prime) (hpm : ¬ p ∣ m) (F : CuspForm (CongruenceSubgroup.Gamma0 m) 2)
+    (hF : ∀ n : ℕ, ¬ p ∣ n → ModularFormClass.qCoeff F n = 0) :
+    CuspForm (CongruenceSubgroup.Gamma0 m) 2 :=
+  CuspForm.heckeTLin 2 hp hpm F - (p : ℂ) • descend hp.ne_zero (dvd_mul_left m p) F hF
+
+theorem coe_lift (hp : p.Prime) (hpm : ¬ p ∣ m) (F : CuspForm (CongruenceSubgroup.Gamma0 m) 2)
+    (hF : ∀ n : ℕ, ¬ p ∣ n → ModularFormClass.qCoeff F n = 0) :
+    ⇑(lift hp hpm F hF) = ⇑F ∣[(2 : ℤ)] B p := by
+  rw [lift, FunLike.coe_sub, FunLike.coe_smul, CuspForm.coe_heckeTLin_apply,
+    heckeT_eq_heckeU_add, heckeU_eq hp F hF]
+  abel
+
+theorem coe_lift_apply (hp : p.Prime) (hpm : ¬ p ∣ m) (F : CuspForm (CongruenceSubgroup.Gamma0 m) 2)
+    (hF : ∀ n : ℕ, ¬ p ∣ n → ModularFormClass.qCoeff F n = 0) (τ : ℍ) :
+    (lift hp hpm F hF) τ = (p : ℂ) * F (heckeDiagMatrix p • τ) := by
+  rw [show (lift hp hpm F hF) τ = (⇑(lift hp hpm F hF)) τ from rfl, coe_lift,
+    slash_heckeDiagMatrix_apply 2 hp.ne_zero]
+  norm_num
+
+theorem qCoeff_lift (hp : p.Prime) (hpm : ¬ p ∣ m) (F : CuspForm (CongruenceSubgroup.Gamma0 m) 2)
+    (hF : ∀ n : ℕ, ¬ p ∣ n → ModularFormClass.qCoeff F n = 0) (n : ℕ) :
+    ModularFormClass.qCoeff (lift hp hpm F hF) n
+      = if p ∣ n then (p : ℂ) * ModularFormClass.qCoeff F (n / p) else 0 := by
+  have hpC : (p : ℂ) ≠ 0 := by exact_mod_cast hp.ne_zero
+  have hΓ : (1 : ℝ) ∈ ((CongruenceSubgroup.Gamma0 m : Subgroup SL(2, ℤ)) :
+      Subgroup (GL (Fin 2) ℝ)).strictPeriods := by simp
+  have hfun : (fun τ : ℍ => F (heckeDiagMatrix p • τ)) = (p : ℂ)⁻¹ • ⇑(lift hp hpm F hF) := by
+    funext τ
+    rw [Pi.smul_apply, smul_eq_mul, coe_lift_apply, ← mul_assoc, inv_mul_cancel₀ hpC, one_mul]
+  have h1 := ModularFormClass.qCoeff_comp_heckeDiagMatrix_smul F hΓ hp.ne_zero n
+  rw [hfun] at h1
+  have h2 : ModularFormClass.qCoeff ((p : ℂ)⁻¹ • ⇑(lift hp hpm F hF)) n
+      = (p : ℂ)⁻¹ * ModularFormClass.qCoeff (lift hp hpm F hF) n := by
+    unfold ModularFormClass.qCoeff
+    rw [ModularForm.qExpansion_smul one_pos hΓ, _root_.map_smul, smul_eq_mul]
+  rw [h2] at h1
+  have h3 := congrArg (fun z : ℂ => (p : ℂ) * z) h1
+  rw [← mul_assoc, mul_inv_cancel₀ hpC, one_mul] at h3
+  rw [h3]
+  split_ifs <;> simp
+
+def Supp (m p : ℕ) : Type :=
+  {G : CuspForm (CongruenceSubgroup.Gamma0 m) 2 // ∀ n : ℕ, ¬ p ∣ n → ModularFormClass.qCoeff G n =
+    0}
+
+def step (hp : p.Prime) (hpm : ¬ p ∣ m) (G : Supp m p) : Supp m p :=
+  ⟨lift hp hpm G.1 G.2, fun n hn => by rw [qCoeff_lift, ite_eq_right hn]⟩
+
+def iter (hp : p.Prime) (hpm : ¬ p ∣ m) (G : Supp m p) (a : ℕ) : Supp m p :=
+  (step hp hpm)^[a] G
+
+theorem qCoeff_iter (hp : p.Prime) (hpm : ¬ p ∣ m) (G : Supp m p) (a n : ℕ) :
+    ModularFormClass.qCoeff (iter hp hpm G a).1 n
+      = if p ^ a ∣ n then (p : ℂ) ^ a * ModularFormClass.qCoeff G.1 (n / p ^ a) else 0 := by
+  induction a generalizing n with
+  | zero => simp [iter]
+  | succ a ih =>
+    rw [iter, Function.iterate_succ_apply', ← iter]
+    change ModularFormClass.qCoeff (lift hp hpm (iter hp hpm G a).1 (iter hp hpm G a).2) n = _
+    rw [qCoeff_lift]
+    by_cases hpn : p ∣ n
+    · rw [ite_eq_left hpn, ih (n / p)]
+      by_cases hpa : p ^ a ∣ n / p
+      · have h' : p ^ (a + 1) ∣ n := by
+          rw [pow_succ]
+          have := Nat.mul_dvd_of_dvd_div hpn hpa
+          rwa [mul_comm] at this
+        rw [ite_eq_left hpa, ite_eq_left h', Nat.div_div_eq_div_mul, mul_comm p (p ^ a), ← pow_succ]
+        ring
+      · have h' : ¬ p ^ (a + 1) ∣ n := by
+          intro h
+          apply hpa
+          rw [Nat.dvd_div_iff_mul_dvd hpn, mul_comm, ← pow_succ]
+          exact h
+        rw [ite_eq_right hpa, ite_eq_right h', mul_zero]
+    · have h' : ¬ p ^ (a + 1) ∣ n := fun h => hpn ((dvd_pow_self p (Nat.succ_ne_zero a)).trans h)
+      rw [ite_eq_right hpn, ite_eq_right h']
+
+def qCoeffLin (m n : ℕ) [NeZero m] : CuspForm (CongruenceSubgroup.Gamma0 m) 2 →ₗ[ℂ] ℂ where
+  toFun G := ModularFormClass.qCoeff G n
+  map_add' f g := by
+    have hΓ : (1 : ℝ) ∈ ((CongruenceSubgroup.Gamma0 m : Subgroup SL(2, ℤ)) :
+        Subgroup (GL (Fin 2) ℝ)).strictPeriods := by simp
+    change ModularFormClass.qCoeff (⇑(f + g)) n = _
+    unfold ModularFormClass.qCoeff
+    rw [FunLike.coe_add, ModularForm.qExpansion_add one_pos hΓ f g, map_add]
+  map_smul' c f := by
+    have hΓ : (1 : ℝ) ∈ ((CongruenceSubgroup.Gamma0 m : Subgroup SL(2, ℤ)) :
+        Subgroup (GL (Fin 2) ℝ)).strictPeriods := by simp
+    change ModularFormClass.qCoeff (⇑(c • f)) n = _
+    unfold ModularFormClass.qCoeff
+    rw [FunLike.coe_smul, ModularForm.qExpansion_smul one_pos hΓ, _root_.map_smul]
+    rfl
+
+theorem qCoeffLin_apply (m n : ℕ) [NeZero m] (G : CuspForm (CongruenceSubgroup.Gamma0 m) 2) :
+    qCoeffLin m n G = ModularFormClass.qCoeff G n := rfl
+
+theorem qCoeff_zero' (m n : ℕ) [NeZero m] :
+    ModularFormClass.qCoeff (0 : CuspForm (CongruenceSubgroup.Gamma0 m) 2) n = 0 := by
+  rw [← qCoeffLin_apply, map_zero]
+
+end up
+
+end AlliAux1Nonlac
+
+open AlliAux1Nonlac in
+theorem solution {m p : ℕ} [NeZero m] (hp : p.Prime) (hpm : ¬ p ∣ m)
+    (F : CuspForm (CongruenceSubgroup.Gamma0 m) 2)
+    (hF : ∀ n : ℕ, ¬ p ∣ n → ModularFormClass.qCoeff F n = 0) : F = 0 := by
+  classical
+  have hΓ : (1 : ℝ) ∈ ((CongruenceSubgroup.Gamma0 m : Subgroup SL(2, ℤ)) :
+      Subgroup (GL (Fin 2) ℝ)).strictPeriods := by simp
+  by_contra hne
+  have hex : ∃ n : ℕ, ModularFormClass.qCoeff F n ≠ 0 := by
+    by_contra h
+    push Not at h
+    exact hne (ModularFormClass.eq_of_forall_qCoeff_eq hΓ fun n => by rw [h n, qCoeff_zero'])
+  set n₀ := Nat.find hex with hn₀def
+  have hn₀ : ModularFormClass.qCoeff F n₀ ≠ 0 := Nat.find_spec hex
+  have hmin : ∀ n < n₀, ModularFormClass.qCoeff F n = 0 := fun n hn => by
+    have := Nat.find_min hex hn
+    simpa using this
+  have hn₀pos : 0 < n₀ := by
+    rw [Nat.pos_iff_ne_zero]
+    intro h0
+    apply hn₀
+    rw [h0]
+    exact CuspFormClass.qExpansion_coeff_zero F one_pos hΓ
+  have := CuspForm.finiteDimensional_Gamma0 m 2
+  set d := Module.finrank ℂ (CuspForm (CongruenceSubgroup.Gamma0 m) 2) with hd
+  let G₀ : Supp m p := ⟨F, hF⟩
+  have hpC : (p : ℂ) ≠ 0 := by exact_mod_cast hp.ne_zero
+  have hcoef : ∀ a b : ℕ, ModularFormClass.qCoeff (iter hp hpm G₀ b).1 (n₀ * p ^ a)
+      = if b = a then (p : ℂ) ^ a * ModularFormClass.qCoeff F n₀ else
+        if b < a then ModularFormClass.qCoeff (iter hp hpm G₀ b).1 (n₀ * p ^ a) else 0 := by
+    intro a b
+    rcases lt_trichotomy b a with hlt | rfl | hgt
+    · rw [ite_eq_right hlt.ne, ite_eq_left hlt]
+    · rw [ite_eq_left rfl, qCoeff_iter, ite_eq_left (dvd_mul_left _ _), Nat.mul_div_cancel _
+        (pow_pos hp.pos _)]
+    · rw [ite_eq_right hgt.ne', ite_eq_right (not_lt.mpr hgt.le), qCoeff_iter]
+      split_ifs with hdvd
+      · have hq : n₀ * p ^ a / p ^ b < n₀ := by
+          rw [Nat.div_lt_iff_lt_mul (pow_pos hp.pos _)]
+          calc n₀ * p ^ a < n₀ * p ^ b :=
+                Nat.mul_lt_mul_of_pos_left (Nat.pow_lt_pow_right hp.one_lt hgt) hn₀pos
+            _ = n₀ * p ^ b := rfl
+        rw [hmin _ hq, mul_zero]
+      · rfl
+  have hli : LinearIndependent ℂ (fun a : Fin (d + 1) => (iter hp hpm G₀ a).1) := by
+    rw [Fintype.linearIndependent_iff]
+    intro g hg
+    suffices H : ∀ k : ℕ, ∀ a : Fin (d + 1), (a : ℕ) = k → g a = 0 from fun a => H a a rfl
+    intro k
+    induction k using Nat.strong_induction_on with
+    | _ k ih =>
+      intro a hak
+      have happ := congrArg (qCoeffLin m (n₀ * p ^ k)) hg
+      rw [map_sum, map_zero] at happ
+      simp only [_root_.map_smul, qCoeffLin_apply, smul_eq_mul] at happ
+      rw [Finset.sum_eq_single a] at happ
+      · rw [hcoef k a, ite_eq_left hak] at happ
+        rcases mul_eq_zero.mp happ with h | h
+        · exact h
+        · exfalso
+          exact (mul_ne_zero (pow_ne_zero _ hpC) hn₀) h
+      · intro b _ hba
+        rcases lt_or_gt_of_ne (fun h : (b : ℕ) = a => hba (Fin.ext h)) with hlt | hgt
+        · rw [ih b (hak ▸ hlt) b rfl, zero_mul]
+        · rw [hcoef k b, ite_eq_right (by omega), ite_eq_right (by omega), mul_zero]
+      · intro ha; exact absurd (Finset.mem_univ a) ha
+  have hcard := hli.fintype_card_le_finrank
+  rw [Fintype.card_fin] at hcard
+  omega
+
+end
+end S_CuspForm_eq_zero_of_prime_not_dvd_of_qCoeff_eq_zero
+end P2MW
+export P2MW.S_CuspForm_eq_zero_of_prime_not_dvd_of_qCoeff_eq_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem CuspForm.eq_zero_of_prime_not_dvd_of_qCoeff_eq_zero
+    {m p : ℕ} [NeZero m] (hp : p.Prime) (hpm : ¬ p ∣ m)
+    (F : CuspForm (CongruenceSubgroup.Gamma0 m) 2)
+    (hF : ∀ n : ℕ, ¬ p ∣ n → ModularFormClass.qCoeff F n = 0) : F = 0 :=
+  solution hp hpm F hF
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_exists_degeneracy_Gamma0.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_exists_degeneracy_Gamma0.lean
new file mode 100644
index 0000000000..831a30aea2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_exists_degeneracy_Gamma0.lean
@@ -0,0 +1,185 @@
+/-
+Based on Prove2Me node CuspForm.exists_degeneracy_Gamma0
+(cd45b6a6-d6e5-5d9d-90de-20b47b250822) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5dfddee9-0801-5571-954e-ed420edd1af8
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+public import Mathlib.NumberTheory.ModularForms.Basic
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+
+import Mathlib.NumberTheory.ModularForms.NormTrace
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degeneracy map f(τ)↦ f(dτ) from Γ₀(M) to Γ₀(N)
+
+Theorem statement: `CuspForm.exists_degeneracy_Gamma0` (`cd45b6a6-d6e5-5d9d-90de-20b47b250822`), by
+Claude, 2026-09-05.
+
+Proof: submission `5dfddee9-0801-5571-954e-ed420edd1af8`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $k$ be an integer, let $M$, $N$, $d$ be natural numbers with $N$ nonzero, and assume $d\,M \mid
+N$. Let $f$ be a cusp form of weight $k$ for the congruence subgroup $\Gamma_0(M)$ (viewed, as in
+Mathlib, as a subgroup of $\mathrm{GL}_2(\mathbb{R})$ via $\mathrm{SL}_2(\mathbb{Z})$). Here
+[`ModularForm.heckeDiagMatrix d`](def/ModularForm_HeckeOperator.html#L21) denotes the element of
+$\mathrm{GL}_2(\mathbb{R})$ equal to the identity when $d = 0$ and to the upper triangular matrix
+$\begin{pmatrix} d & 0\\ 0 & 1\end{pmatrix}$ (with nonzero determinant $d$) otherwise; note that the
+divisibility hypothesis together with $N \neq 0$ forces $d \neq 0$. The assertion is that there
+exists a cusp form $g$ of weight $k$ for $\Gamma_0(N)$ whose underlying function on the upper
+half-plane is exactly $\tau \mapsto f\bigl(\mathrm{heckeDiagMatrix}(d) \cdot \tau\bigr)$, i.e.
+$g(\tau) = f(d\tau)$, with no normalising scalar in the conclusion. Thus holomorphy, the weight-$k$
+invariance under $\Gamma_0(N)$ and vanishing at all cusps hold for $\tau \mapsto f(d\tau)$.
+
+This is the degeneracy (level-raising) map $V_d \colon S_k(\Gamma_0(M)) \to S_k(\Gamma_0(N))$, $f
+\mapsto f(d\tau)$, for $d\,M \mid N$, which produces the oldforms at level $N$ coming from level
+$M$. It is used in the project to move cusp forms to larger level, for instance in the construction
+of normalised eigenforms at multiplied level and in identities for eta products.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_CuspForm_exists_degeneracy_Gamma0.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_CuspForm_exists_degeneracy_Gamma0
+
+p2m_open_scoped "MatrixGroups ModularForm P2MW.S_CuspForm_exists_degeneracy_Gamma0.ModularForm \
+  Pointwise"
+
+noncomputable section
+
+namespace ModularForm
+p2m_export "ModularForm" "translate IsGLPos.coe_smul coe_smul holo' ext smul_apply bdd_at_cusps' \
+  coe_translate heckeDiagMatrix val_heckeDiagMatrix slash_heckeDiagMatrix_apply"
+namespace DegeneracyPort
+p2m_open "ModularForm"
+
+variable {k : ℤ}
+
+def restrictMF {Γ Γ' : Subgroup (GL (Fin 2) ℝ)} (h : Γ' ≤ Γ) (F : ModularForm Γ k) :
+    ModularForm Γ' k where
+  toFun := F
+  slash_action_eq' γ hγ := SlashInvariantForm.slash_action_eqn F γ (h hγ)
+  holo' := F.holo'
+  bdd_at_cusps' hc := F.bdd_at_cusps' (hc.mono h)
+
+def restrictCF {Γ Γ' : Subgroup (GL (Fin 2) ℝ)} (h : Γ' ≤ Γ) (F : CuspForm Γ k) :
+    CuspForm Γ' k where
+  toFun := F
+  slash_action_eq' γ hγ := SlashInvariantForm.slash_action_eqn F γ (h hγ)
+  holo' := F.holo'
+  zero_at_cusps' hc := F.zero_at_cusps' (hc.mono h)
+
+@[scoped simp] theorem coe_restrictMF {Γ Γ' : Subgroup (GL (Fin 2) ℝ)} (h : Γ' ≤ Γ) (F : ModularForm
+  Γ k) :
+    ⇑(restrictMF h F) = ⇑F := rfl
+
+@[scoped simp] theorem coe_restrictCF {Γ Γ' : Subgroup (GL (Fin 2) ℝ)} (h : Γ' ≤ Γ) (F : CuspForm Γ
+  k) :
+    ⇑(restrictCF h F) = ⇑F := rfl
+
+theorem Gamma0_le_conj_Gamma0 {M N d : ℕ} (hd : d ≠ 0) (hdiv : d * M ∣ N) :
+    ((CongruenceSubgroup.Gamma0 N : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) ≤
+      ConjAct.toConjAct (heckeDiagMatrix d)⁻¹ •
+        ((CongruenceSubgroup.Gamma0 M : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) := by
+  rintro _ ⟨A, hA, rfl⟩
+  rw [Subgroup.mem_pointwise_smul_iff_inv_smul_mem, ConjAct.toConjAct_inv, inv_inv,
+    ConjAct.toConjAct_smul]
+  have hN : (N : ℤ) ∣ (A : Matrix (Fin 2) (Fin 2) ℤ) 1 0 :=
+    (ZMod.intCast_zmod_eq_zero_iff_dvd _ N).mp (CongruenceSubgroup.Gamma0_mem.mp hA)
+  obtain ⟨c', hc'⟩ : (d : ℤ) ∣ (A : Matrix (Fin 2) (Fin 2) ℤ) 1 0 :=
+    (Int.natCast_dvd_natCast.mpr (Dvd.intro _ rfl : d ∣ d * M)).trans
+      ((Int.natCast_dvd_natCast.mpr hdiv).trans hN)
+  have hMc' : (M : ℤ) ∣ c' := by
+    have h1 : (d : ℤ) * M ∣ (d : ℤ) * c' := by
+      rw [← hc']; exact_mod_cast (Int.natCast_dvd_natCast.mpr hdiv).trans hN
+    exact (mul_dvd_mul_iff_left (by exact_mod_cast hd)).mp h1
+  have hdet : (A : Matrix (Fin 2) (Fin 2) ℤ) 0 0 * (A : Matrix (Fin 2) (Fin 2) ℤ) 1 1 -
+      (A : Matrix (Fin 2) (Fin 2) ℤ) 0 1 * (A : Matrix (Fin 2) (Fin 2) ℤ) 1 0 = 1 := by
+    rw [← Matrix.det_fin_two, A.det_coe]
+  let B : SL(2, ℤ) :=
+    ⟨!![(A : Matrix (Fin 2) (Fin 2) ℤ) 0 0, d * (A : Matrix (Fin 2) (Fin 2) ℤ) 0 1;
+      c', (A : Matrix (Fin 2) (Fin 2) ℤ) 1 1], by
+    rw [Matrix.det_fin_two_of]
+    linear_combination hdet + (A : Matrix (Fin 2) (Fin 2) ℤ) 0 1 * hc'⟩
+  refine ⟨B, ?_, ?_⟩
+  · rw [SetLike.mem_coe, CongruenceSubgroup.Gamma0_mem]
+    change ((c' : ℤ) : ZMod M) = 0
+    exact (ZMod.intCast_zmod_eq_zero_iff_dvd _ M).mpr hMc'
+  · rw [eq_mul_inv_iff_mul_eq]
+    apply Units.ext
+    simp only [Units.val_mul, Matrix.SpecialLinearGroup.mapGL_coe_matrix, val_heckeDiagMatrix hd]
+    ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp [Matrix.mul_apply, Fin.sum_univ_two, B, hc', mul_comm]
+
+theorem exists_modularForm {M N d : ℕ} [NeZero N] (hdiv : d * M ∣ N)
+    (f : ModularForm (CongruenceSubgroup.Gamma0 M) k) :
+    ∃ g : ModularForm (CongruenceSubgroup.Gamma0 N) k,
+      ⇑g = fun τ ↦ f (ModularForm.heckeDiagMatrix d • τ) := by
+  have hd : d ≠ 0 := by
+    rintro rfl
+    rw [zero_mul, zero_dvd_iff] at hdiv
+    exact NeZero.ne N hdiv
+  have hdk : ((d : ℂ) ^ (k - 1)) ≠ 0 := zpow_ne_zero _ (Nat.cast_ne_zero.mpr hd)
+  refine ⟨((d : ℂ) ^ (k - 1))⁻¹ •
+    restrictMF (Gamma0_le_conj_Gamma0 hd hdiv) (ModularForm.translate f (heckeDiagMatrix d)), ?_⟩
+  funext τ
+  rw [FunLike.coe_smul, Pi.smul_apply, coe_restrictMF, ModularForm.coe_translate,
+    slash_heckeDiagMatrix_apply k hd, smul_eq_mul, ← mul_assoc, inv_mul_cancel₀ hdk, one_mul]
+
+theorem exists_cuspForm {M N d : ℕ} [NeZero N] (hdiv : d * M ∣ N)
+    (f : CuspForm (CongruenceSubgroup.Gamma0 M) k) :
+    ∃ g : CuspForm (CongruenceSubgroup.Gamma0 N) k,
+      ⇑g = fun τ ↦ f (ModularForm.heckeDiagMatrix d • τ) := by
+  have hd : d ≠ 0 := by
+    rintro rfl
+    rw [zero_mul, zero_dvd_iff] at hdiv
+    exact NeZero.ne N hdiv
+  have hdk : ((d : ℂ) ^ (k - 1)) ≠ 0 := zpow_ne_zero _ (Nat.cast_ne_zero.mpr hd)
+  refine ⟨((d : ℂ) ^ (k - 1))⁻¹ •
+    restrictCF (Gamma0_le_conj_Gamma0 hd hdiv) (CuspForm.translate f (heckeDiagMatrix d)), ?_⟩
+  funext τ
+  rw [FunLike.coe_smul, Pi.smul_apply, coe_restrictCF]
+  change ((d : ℂ) ^ (k - 1))⁻¹ • (⇑f ∣[k] heckeDiagMatrix d) τ = _
+  rw [slash_heckeDiagMatrix_apply k hd, smul_eq_mul, ← mul_assoc, inv_mul_cancel₀ hdk, one_mul]
+
+end ModularForm.DegeneracyPort
+end
+
+theorem solution {k : ℤ} {M N d : ℕ} [NeZero N] (hd : d * M ∣ N)
+    (f : CuspForm (CongruenceSubgroup.Gamma0 M) k) :
+    ∃ g : CuspForm (CongruenceSubgroup.Gamma0 N) k, ⇑g = fun τ ↦ f (ModularForm.heckeDiagMatrix d •
+      τ) :=
+  ModularForm.DegeneracyPort.exists_cuspForm hd f
+
+end S_CuspForm_exists_degeneracy_Gamma0
+end P2MW
+export P2MW.S_CuspForm_exists_degeneracy_Gamma0 (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem CuspForm.exists_degeneracy_Gamma0 {k : ℤ} {M N d : ℕ} [NeZero N] (hd : d * M ∣ N)
+    (f : CuspForm (CongruenceSubgroup.Gamma0 M) k) :
+    ∃ g : CuspForm (CongruenceSubgroup.Gamma0 N) k, ⇑g = fun τ ↦ f (ModularForm.heckeDiagMatrix d •
+      τ) :=
+  solution hd f
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_exists_gamma0_apply_eq_eta_mul_pow_twentyfour.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_exists_gamma0_apply_eq_eta_mul_pow_twentyfour.lean
new file mode 100644
index 0000000000..1c7b8dad3f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_exists_gamma0_apply_eq_eta_mul_pow_twentyfour.lean
@@ -0,0 +1,949 @@
+/-
+Based on Prove2Me node CuspForm.exists_gamma0_apply_eq_eta_mul_pow_twentyfour
+(671719a8-48b0-5419-8716-07a0faae6ea4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ad59456f-adc8-5d6d-bdc8-19e513b7dd2a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.DedekindEta
+
+import Mathlib.AlgebraicTopology.FundamentalGroupoid.SimplyConnected
+import Mathlib.Data.Int.Star
+import Mathlib.GroupTheory.Schreier
+import Mathlib.LinearAlgebra.Matrix.FixedDetMatrices
+import Mathlib.NumberTheory.ModularForms.Discriminant
+import Mathlib.RingTheory.SimpleRing.Principal
+import Mathlib.Tactic.NormNum.Prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_exists_degeneracy_Gamma0
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# η(Nτ)²⁴ is a weight-12 cusp form on Γ₀(N)
+
+Theorem statement: `CuspForm.exists_gamma0_apply_eq_eta_mul_pow_twentyfour`
+(`671719a8-48b0-5419-8716-07a0faae6ea4`), by Claude, 2026-09-05.
+
+Proof: submission `ad59456f-adc8-5d6d-bdc8-19e513b7dd2a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, assumed nonzero. The assertion is that there exists a cusp form $g$ of
+weight $12$ for the congruence subgroup $\Gamma_0(N)$ — an element of `CuspForm
+(CongruenceSubgroup.Gamma0 N) 12`, so a holomorphic function on the upper half-plane, weight-$12$
+equivariant for $\Gamma_0(N)$ and with vanishing constant terms in its expansions at all cusps —
+whose values are given on the nose by the twenty-fourth power of the Dedekind eta function evaluated
+at $N$ times the argument: for every $\tau$ in the upper half-plane, $g(\tau) = \eta(N\tau)^{24}$,
+where $\eta$ is `ModularForm.eta` and $N\tau$ is the product of $N$ with the complex number
+underlying $\tau$. Since $\eta^{24} = \Delta$, the assertion is that $\tau \mapsto \Delta(N\tau)$ is
+a weight-$12$ cusp form of level $N$. The result is phrased purely existentially, so it names no
+distinguished element of $S_{12}(\Gamma_0(N))$; in particular it records that this space is nonzero
+for every $N \geq 1$.
+
+This is the statement that the level-one discriminant form $\Delta$, pulled back along $\tau \mapsto
+N\tau$, lies in $S_{12}(\Gamma_0(N))$; it is obtained from the degeneracy map of
+[`CuspForm.exists_degeneracy_Gamma0`](thm.html#CuspForm.exists_degeneracy_Gamma0), which transports
+a cusp form of weight $k$ and level $M$ to level $N$ whenever $d M \mid N$, by composition with the
+action of the diagonal matrix attached to $d$, taken here with $M = 1$ and $d = N$. It underlies the
+constructions of eta products of level $4$ and level $11$ and the scaling identity for the twelfth
+power of the level-$11$ eta product.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_CuspForm_exists_gamma0_apply_eq_eta_mul_pow_twentyfour.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_CuspForm_exists_gamma0_apply_eq_eta_mul_pow_twentyfour
+
+p2m_open "Set Function Complex Function.Complex ModularForm CongruenceSubgroup Filter"
+
+p2m_open "UpperHalfPlane~I"
+
+open scoped Real ModularForm MatrixGroups Topology Manifold
+
+local notation "𝕢" => Periodic.qParam
+
+local notation "ℍₒ" => upperHalfPlaneSet
+
+noncomputable section
+
+namespace ModularCurve
+
+noncomputable def etaProductEleven (z : ℂ) : ℂ := η z ^ 2 * η (11 * z) ^ 2
+
+lemma mem_upperHalfPlaneSet_eleven_mul {z : ℂ} (hz : z ∈ ℍₒ) : (11 : ℂ) * z ∈ ℍₒ := by
+  have hz' : 0 < z.im := hz
+  have h11 : ((11 : ℂ) * z).im = 11 * z.im := by
+    simp [Complex.mul_im]
+  change 0 < ((11 : ℂ) * z).im
+  rw [h11]
+  positivity
+
+theorem etaProductEleven_ne_zero {z : ℂ} (hz : z ∈ ℍₒ) : etaProductEleven z ≠ 0 :=
+  mul_ne_zero (pow_ne_zero 2 (eta_ne_zero hz))
+    (pow_ne_zero 2 (eta_ne_zero (mem_upperHalfPlaneSet_eleven_mul hz)))
+
+theorem differentiableAt_etaProductEleven {z : ℂ} (hz : z ∈ ℍₒ) :
+    DifferentiableAt ℂ etaProductEleven z := by
+  refine DifferentiableAt.mul ?_ ?_
+  · exact (differentiableAt_eta_of_mem_upperHalfPlaneSet hz).pow 2
+  · exact (((differentiableAt_eta_of_mem_upperHalfPlaneSet
+      (mem_upperHalfPlaneSet_eleven_mul hz)).comp z (by fun_prop)).pow 2)
+
+lemma qParam_24_sq_mul_qParam_24_eleven_sq (z : ℂ) :
+    (𝕢 24 z) ^ 2 * (𝕢 24 ((11 : ℂ) * z)) ^ 2 = 𝕢 1 z := by
+  simp only [Periodic.qParam, ← Complex.exp_nat_mul, ← Complex.exp_add]
+  congr 1
+  push_cast
+  ring
+
+theorem etaProductEleven_eq_q_prod (z : ℂ) :
+    etaProductEleven z =
+      𝕢 1 z * ((∏' n, (1 - eta_q n z)) ^ 2 * (∏' n, (1 - eta_q n ((11 : ℂ) * z))) ^ 2) := by
+  simp only [etaProductEleven, ModularForm.eta]
+  rw [show ∀ a b c d : ℂ, (a * b) ^ 2 * (c * d) ^ 2 = a ^ 2 * c ^ 2 * (b ^ 2 * d ^ 2) by
+    intros; ring]
+  rw [qParam_24_sq_mul_qParam_24_eleven_sq]
+
+theorem etaProductEleven_T_invariant (z : ℂ) :
+    etaProductEleven (z + 1) = etaProductEleven z := by
+  have hq : 𝕢 1 (z + 1) = 𝕢 1 z := by
+    simp only [Periodic.qParam]
+    rw [Complex.exp_eq_exp_iff_exists_int]
+    exact ⟨1, by push_cast; ring⟩
+  have hq11 : 𝕢 1 ((11 : ℂ) * (z + 1)) = 𝕢 1 ((11 : ℂ) * z) := by
+    simp only [Periodic.qParam]
+    rw [Complex.exp_eq_exp_iff_exists_int]
+    exact ⟨11, by push_cast; ring⟩
+  rw [etaProductEleven_eq_q_prod, etaProductEleven_eq_q_prod, hq]
+  congr 2
+  · congr 1
+    refine tprod_congr fun n => ?_
+    rw [eta_q, eta_q, hq]
+  · congr 1
+    refine tprod_congr fun n => ?_
+    rw [eta_q, eta_q, hq11]
+
+def EtaProductIsCuspForm : Prop :=
+  ∃ f : CuspForm (Gamma0 11) 2, ∀ z : ℍ, f z = etaProductEleven z
+
+theorem exists_cuspForm_ne_zero_of_etaProduct (h : EtaProductIsCuspForm) :
+    ∃ f : CuspForm (Gamma0 11) 2, f ≠ 0 := by
+  obtain ⟨f, hf⟩ := h
+  refine ⟨f, fun hzero => ?_⟩
+  have hI : (Complex.I : ℂ) ∈ ℍₒ := by
+    change (0 : ℝ) < (Complex.I).im
+    simp
+  have := hf ⟨Complex.I, hI⟩
+  rw [hzero] at this
+  exact etaProductEleven_ne_zero hI (by simpa using this.symm)
+
+end ModularCurve
+
+namespace ModularCurve
+
+lemma csqrt_sq {w : ℂ} (hw : w ≠ 0) : Complex.sqrt w ^ 2 = w := by
+  rw [sqrt_eq_exp hw, ← Complex.exp_nat_mul]
+  rw [show ((2 : ℕ) : ℂ) * (Complex.log w / 2) = Complex.log w by push_cast; ring]
+  exact Complex.exp_log hw
+
+theorem eta_sq_S {w : ℂ} (hw : w ∈ ℍₒ) :
+    η (-1 / w) ^ 2 = -Complex.I * w * η w ^ 2 := by
+  have hw0 : w ≠ 0 := by
+    rintro rfl
+    simp only [mem_ofPred_eq, Complex.zero_im, lt_self_iff_false] at hw
+  have h := eta_comp_eq_csqrt_I_inv hw
+  simp only [Function.comp_apply, Pi.smul_apply, Pi.mul_apply, smul_eq_mul] at h
+  rw [h, mul_pow, mul_pow, inv_pow, csqrt_sq Complex.I_ne_zero, csqrt_sq hw0, Complex.inv_I]
+  ring
+
+theorem etaProductEleven_fricke {w : ℂ} (hw : w ∈ ℍₒ) :
+    etaProductEleven (-1 / (11 * w)) = -(11 * w ^ 2) * etaProductEleven w := by
+  have hw0 : w ≠ 0 := by
+    rintro rfl
+    simp only [mem_ofPred_eq, Complex.zero_im, lt_self_iff_false] at hw
+  have h11w : (11 : ℂ) * w ∈ ℍₒ := mem_upperHalfPlaneSet_eleven_mul hw
+  have key : (11 : ℂ) * (-1 / (11 * w)) = -1 / w := by
+    field_simp
+  rw [etaProductEleven, key, eta_sq_S h11w, eta_sq_S hw, etaProductEleven]
+  rw [show -Complex.I * ((11 : ℂ) * w) * η ((11 : ℂ) * w) ^ 2 * (-Complex.I * w * η w ^ 2)
+      = Complex.I ^ 2 * ((11 : ℂ) * w ^ 2) * (η w ^ 2 * η ((11 : ℂ) * w) ^ 2) by ring,
+    Complex.I_sq]
+  ring
+
+lemma Gamma0_one_eq_top : (Gamma0 1 : Subgroup SL(2, ℤ)) = ⊤ := by
+  ext A
+  simp [CongruenceSubgroup.Gamma0_mem, eq_iff_true_of_subsingleton]
+
+lemma coe_Gamma0_one_eq_SL :
+    ((Gamma0 1 : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) = 𝒮ℒ := by
+  rw [Gamma0_one_eq_top]
+  ext x
+  simp [Subgroup.mem_map, MonoidHom.mem_range]
+
+def transportCuspForm {Γ₁ Γ₂ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} (h : Γ₁ = Γ₂) (f : CuspForm Γ₁ k) :
+    CuspForm Γ₂ k := h ▸ f
+
+@[scoped simp] lemma transportCuspForm_coe {Γ₁ Γ₂ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} (h : Γ₁ = Γ₂)
+    (f : CuspForm Γ₁ k) : ⇑(transportCuspForm h f) = ⇑f := by subst h; rfl
+
+def deltaGamma0 : CuspForm (Gamma0 1) 12 :=
+  transportCuspForm coe_Gamma0_one_eq_SL.symm CuspForm.discriminant
+
+@[scoped simp] lemma deltaGamma0_coe : ⇑deltaGamma0 = ModularForm.discriminant := by
+  simp [deltaGamma0]
+
+private lemma eleven_mul_one_dvd : 11 * 1 ∣ 11 := by norm_num
+
+def deltaEleven : CuspForm (Gamma0 11) 12 :=
+  (CuspForm.exists_degeneracy_Gamma0 (N := 11) eleven_mul_one_dvd deltaGamma0).choose
+
+lemma deltaEleven_coe :
+    ⇑deltaEleven = fun τ : ℍ => deltaGamma0 (ModularForm.heckeDiagMatrix 11 • τ) :=
+  (CuspForm.exists_degeneracy_Gamma0 (N := 11) eleven_mul_one_dvd deltaGamma0).choose_spec
+
+def deltaElevenFun : ℍ → ℂ := ⇑deltaEleven
+
+lemma deltaElevenFun_apply (τ : ℍ) :
+    deltaElevenFun τ = η ((11 : ℂ) * τ) ^ 24 := by
+  change deltaEleven τ = _
+  rw [deltaEleven_coe]
+  simp only [deltaGamma0_coe, ModularForm.discriminant]
+  rw [ModularForm.coe_heckeDiagMatrix_smul (by norm_num : (11 : ℕ) ≠ 0)]
+  norm_num
+
+lemma deltaElevenFun_slash {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 11) :
+    deltaElevenFun ∣[(12 : ℤ)] γ = deltaElevenFun := by
+  have h := deltaEleven.slash_action_eq' (Matrix.SpecialLinearGroup.mapGL ℝ γ)
+    (Subgroup.mem_map.mpr ⟨γ, hγ, rfl⟩)
+  rw [ModularForm.SL_slash]
+  exact h
+
+lemma etaProductEleven_pow_twelve (τ : ℍ) :
+    etaProductEleven (τ : ℂ) ^ 12 = ModularForm.discriminant τ * deltaElevenFun τ := by
+  rw [deltaElevenFun_apply, etaProductEleven]
+  change (η (τ : ℂ) ^ 2 * η ((11 : ℂ) * τ) ^ 2) ^ 12 = η (τ : ℂ) ^ 24 * η ((11 : ℂ) * τ) ^ 24
+  ring
+
+private lemma mem_Gamma0_one (γ : SL(2, ℤ)) : γ ∈ Gamma0 1 := by
+  rw [Gamma0_mem]
+  exact Subsingleton.elim _ _
+
+lemma discriminant_smul (γ : SL(2, ℤ)) (τ : ℍ) :
+    ModularForm.discriminant (γ • τ) = denom γ τ ^ (12 : ℤ) * ModularForm.discriminant τ := by
+  have h := SlashInvariantForm.slash_action_eqn_SL'' deltaGamma0 (mem_Gamma0_one γ) τ
+  rwa [deltaGamma0_coe] at h
+
+lemma deltaElevenFun_smul {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 11) (τ : ℍ) :
+    deltaElevenFun (γ • τ) = denom γ τ ^ (12 : ℤ) * deltaElevenFun τ :=
+  SlashInvariantForm.slash_action_eqn_SL'' deltaEleven hγ τ
+
+theorem etaProductEleven_pow_twelve_smul {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 11) (τ : ℍ) :
+    etaProductEleven ((γ • τ : ℍ) : ℂ) ^ 12
+      = denom γ τ ^ (24 : ℤ) * etaProductEleven (τ : ℂ) ^ 12 := by
+  calc etaProductEleven ((γ • τ : ℍ) : ℂ) ^ 12
+      = ModularForm.discriminant (γ • τ) * deltaElevenFun (γ • τ) :=
+        etaProductEleven_pow_twelve (γ • τ)
+    _ = (denom γ τ ^ (12 : ℤ) * denom γ τ ^ (12 : ℤ))
+          * (ModularForm.discriminant τ * deltaElevenFun τ) := by
+        rw [discriminant_smul γ τ, deltaElevenFun_smul hγ τ]; ring
+    _ = denom γ τ ^ (24 : ℤ) * etaProductEleven (τ : ℂ) ^ 12 := by
+        rw [← zpow_add₀ (denom_ne_zero _ τ), etaProductEleven_pow_twelve τ]
+        norm_num
+
+private lemma finite_twelfthRoots : {x : ℂ | x ^ 12 = 1}.Finite := by
+  have hsub : {x : ℂ | x ^ 12 = 1}
+      ⊆ {x : ℂ | Polynomial.IsRoot (Polynomial.X ^ 12 - Polynomial.C 1 : Polynomial ℂ) x} := by
+    intro x hx
+    simp only [mem_ofPred_eq, Polynomial.IsRoot, Polynomial.eval_sub, Polynomial.eval_pow,
+      Polynomial.eval_X, Polynomial.eval_C]
+    rw [Set.mem_ofPred_eq] at hx
+    rw [hx]
+    ring
+  exact (Polynomial.finite_setOfPred_isRoot
+    (Polynomial.X_pow_sub_C_ne_zero (n := 12) (by norm_num) 1)).subset hsub
+
+private noncomputable def etaRatio (γ : SL(2, ℤ)) (τ : ℍ) : ℂ :=
+  etaProductEleven ((γ • τ : ℍ) : ℂ) / (denom γ τ ^ (2 : ℤ) * etaProductEleven (τ : ℂ))
+
+private lemma etaRatio_den_ne_zero (γ : SL(2, ℤ)) (τ : ℍ) :
+    denom γ τ ^ (2 : ℤ) * etaProductEleven (τ : ℂ) ≠ 0 :=
+  mul_ne_zero (zpow_ne_zero _ (denom_ne_zero _ τ)) (etaProductEleven_ne_zero τ.2)
+
+private lemma etaRatio_pow_twelve {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 11) (τ : ℍ) :
+    etaRatio γ τ ^ 12 = 1 := by
+  rw [etaRatio, div_pow, mul_pow, etaProductEleven_pow_twelve_smul hγ τ]
+  rw [show ((denom γ τ ^ (2 : ℤ)) ^ (12 : ℕ)) = denom γ τ ^ (24 : ℤ) by
+    rw [← zpow_natCast (denom γ τ ^ (2 : ℤ)) 12, ← zpow_mul]; norm_num]
+  rw [div_eq_one_iff_eq (by
+    exact mul_ne_zero (zpow_ne_zero _ (denom_ne_zero _ τ))
+      (pow_ne_zero _ (etaProductEleven_ne_zero τ.2)))]
+
+private lemma continuousOn_etaProductEleven : ContinuousOn etaProductEleven ℍₒ :=
+  fun _ hw => (differentiableAt_etaProductEleven hw).continuousAt.continuousWithinAt
+
+private lemma continuous_etaRatio (γ : SL(2, ℤ)) : Continuous (etaRatio γ) := by
+  have hsmul : Continuous fun τ : ℍ => ((γ • τ : ℍ) : ℂ) :=
+    UpperHalfPlane.continuous_coe.comp (continuous_const_smul (γ : GL (Fin 2) ℝ))
+  apply Continuous.div
+  · exact continuousOn_etaProductEleven.comp_continuous hsmul fun τ => (γ • τ).2
+  · apply Continuous.mul
+    · have hden : Continuous fun τ : ℍ => denom γ (τ : ℂ) := by
+        simp only [UpperHalfPlane.denom]
+        fun_prop
+      exact hden.zpow₀ 2 fun τ => Or.inl (denom_ne_zero _ τ)
+    · exact continuousOn_etaProductEleven.comp_continuous UpperHalfPlane.continuous_coe
+        fun τ => τ.2
+  · exact fun τ => etaRatio_den_ne_zero γ τ
+
+noncomputable def etaMultiplier (γ : SL(2, ℤ)) : ℂ := etaRatio γ UpperHalfPlane.I
+
+private lemma etaRatio_eq_etaMultiplier {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 11) (τ : ℍ) :
+    etaRatio γ τ = etaMultiplier γ := by
+  refine IsPreconnected.constant_of_mapsTo (T := {x : ℂ | x ^ 12 = 1}) (isPreconnected_univ)
+    finite_twelfthRoots.isDiscrete (continuous_etaRatio γ).continuousOn
+    (fun u _ => ?_) (mem_univ τ) (mem_univ UpperHalfPlane.I)
+  exact etaRatio_pow_twelve hγ u
+
+theorem etaMultiplier_pow_twelve {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 11) :
+    etaMultiplier γ ^ 12 = 1 :=
+  etaRatio_pow_twelve hγ UpperHalfPlane.I
+
+theorem etaMultiplier_ne_zero {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 11) : etaMultiplier γ ≠ 0 :=
+  fun h => one_ne_zero (by rw [← etaMultiplier_pow_twelve hγ, h]; norm_num)
+
+theorem etaProductEleven_smul {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 11) (τ : ℍ) :
+    etaProductEleven ((γ • τ : ℍ) : ℂ)
+      = etaMultiplier γ * (denom γ τ ^ (2 : ℤ) * etaProductEleven (τ : ℂ)) := by
+  rw [← etaRatio_eq_etaMultiplier hγ τ, etaRatio, div_mul_cancel₀]
+  exact etaRatio_den_ne_zero γ τ
+
+theorem etaProduct_slash_eq {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 11) :
+    (fun τ : ℍ => etaProductEleven (τ : ℂ)) ∣[(2 : ℤ)] γ
+      = etaMultiplier γ • fun τ : ℍ => etaProductEleven (τ : ℂ) := by
+  ext τ
+  have hd : denom γ τ ^ (2 : ℤ) * (denom γ τ ^ (2 : ℤ))⁻¹ = 1 :=
+    mul_inv_cancel₀ (zpow_ne_zero _ (denom_ne_zero _ τ))
+  rw [SL_slash_apply]
+  simp only [Pi.smul_apply, smul_eq_mul]
+  rw [etaProductEleven_smul hγ τ, zpow_neg]
+  linear_combination (etaMultiplier γ * etaProductEleven (τ : ℂ)) * hd
+
+theorem etaMultiplier_mul {γ₁ γ₂ : SL(2, ℤ)} (h₁ : γ₁ ∈ Gamma0 11) (h₂ : γ₂ ∈ Gamma0 11) :
+    etaMultiplier (γ₁ * γ₂) = etaMultiplier γ₁ * etaMultiplier γ₂ := by
+  have key : (etaMultiplier (γ₁ * γ₂)) • (fun τ : ℍ => etaProductEleven (τ : ℂ))
+      = (etaMultiplier γ₁ * etaMultiplier γ₂) • (fun τ : ℍ => etaProductEleven (τ : ℂ)) := by
+    rw [← etaProduct_slash_eq (mul_mem h₁ h₂), SlashAction.slash_mul, etaProduct_slash_eq h₁,
+      ModularForm.SL_smul_slash, etaProduct_slash_eq h₂, smul_smul]
+  have h := congr_fun key UpperHalfPlane.I
+  simp only [Pi.smul_apply, smul_eq_mul] at h
+  exact mul_right_cancel₀ (etaProductEleven_ne_zero UpperHalfPlane.I.2) h
+
+theorem etaMultiplier_T : etaMultiplier ModularGroup.T = 1 := by
+  rw [etaMultiplier, etaRatio]
+  have hsmul : ((ModularGroup.T • UpperHalfPlane.I : ℍ) : ℂ) = (UpperHalfPlane.I : ℂ) + 1 := by
+    rw [modular_T_smul]
+    simp [UpperHalfPlane.coe_vadd, add_comm]
+  have hden : denom ModularGroup.T (UpperHalfPlane.I : ℂ) = 1 := by
+    simp [UpperHalfPlane.denom, ModularGroup.T]
+  rw [hsmul, hden, etaProductEleven_T_invariant, one_zpow, one_mul, div_self]
+  exact etaProductEleven_ne_zero (by simp [UpperHalfPlane.coe_I])
+
+lemma T_mem_Gamma0 : ModularGroup.T ∈ Gamma0 11 := by
+  rw [Gamma0_mem]
+  simp [ModularGroup.T]
+
+theorem etaMultiplier_neg_one : etaMultiplier (-1) = 1 := by
+  rw [etaMultiplier, etaRatio]
+  have hsmul : ((-1 : SL(2, ℤ)) • UpperHalfPlane.I : ℍ) = UpperHalfPlane.I := by
+    rw [show (-1 : SL(2, ℤ)) = -(1 : SL(2, ℤ)) from rfl, ModularGroup.SL_neg_smul, one_smul]
+  have hden : denom (-1 : SL(2, ℤ)) (UpperHalfPlane.I : ℂ) = -1 := by
+    simp [UpperHalfPlane.denom]
+  rw [hsmul, hden]
+  rw [show ((-1 : ℂ) ^ (2 : ℤ)) = 1 by norm_num, one_mul, div_self]
+  exact etaProductEleven_ne_zero (by simp [UpperHalfPlane.coe_I])
+
+lemma neg_one_mem_Gamma0 : (-1 : SL(2, ℤ)) ∈ Gamma0 11 := by
+  rw [Gamma0_mem]
+  simp
+
+def EtaMultiplierTrivial : Prop :=
+  ∀ γ : SL(2, ℤ), γ ∈ Gamma0 11 → etaMultiplier γ = 1
+
+theorem etaProductEleven_smul_of_trivial (h : EtaMultiplierTrivial) {γ : SL(2, ℤ)}
+    (hγ : γ ∈ Gamma0 11) (τ : ℍ) :
+    etaProductEleven ((γ • τ : ℍ) : ℂ) = denom γ τ ^ (2 : ℤ) * etaProductEleven (τ : ℂ) := by
+  rw [etaProductEleven_smul hγ τ, h γ hγ, one_mul]
+
+theorem slashInvariant_of_etaMultiplierTrivial (h : EtaMultiplierTrivial) {γ : SL(2, ℤ)}
+    (hγ : γ ∈ Gamma0 11) :
+    (fun τ : ℍ => etaProductEleven (τ : ℂ)) ∣[(2 : ℤ)] γ
+      = fun τ : ℍ => etaProductEleven (τ : ℂ) := by
+  ext τ
+  rw [SL_slash_apply, etaProductEleven_smul_of_trivial h hγ τ, zpow_neg, mul_comm,
+    inv_mul_cancel_left₀ (zpow_ne_zero _ (denom_ne_zero _ τ))]
+
+end ModularCurve
+
+namespace ModularCurve
+
+theorem etaProductEleven_pow_twelve_classical (τ : ℍ) :
+    etaProductEleven (τ : ℂ) ^ 12 = ModularForm.discriminant τ * deltaEleven τ :=
+  etaProductEleven_pow_twelve τ
+
+theorem mdifferentiable_etaProductEleven :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fun τ : ℍ => etaProductEleven (τ : ℂ)) := by
+  rw [UpperHalfPlane.mdifferentiable_iff]
+  refine DifferentiableOn.congr (f := etaProductEleven)
+    (fun z hz => (differentiableAt_etaProductEleven hz).differentiableWithinAt)
+    (fun z hz => ?_)
+  simp [Function.comp_apply, ofComplex_apply_of_im_pos hz]
+
+def EtaProductVanishesAtCusps : Prop :=
+  ∀ ⦃c : OnePoint ℝ⦄, IsCusp c ((Gamma0 11 : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) →
+    OnePoint.IsZeroAt c (fun τ : ℍ => etaProductEleven (τ : ℂ)) 2
+
+theorem etaProductIsCuspForm_of_trivial (h : EtaMultiplierTrivial)
+    (hcusp : EtaProductVanishesAtCusps) : EtaProductIsCuspForm := by
+  refine ⟨{ toFun := fun τ : ℍ => etaProductEleven (τ : ℂ)
+            slash_action_eq' := ?_
+            holo' := mdifferentiable_etaProductEleven
+            zero_at_cusps' := fun {c} hc => hcusp hc }, fun z => rfl⟩
+  intro g hg
+  obtain ⟨γ, hγ, rfl⟩ := Subgroup.mem_map.mp hg
+  exact slashInvariant_of_etaMultiplierTrivial h hγ
+
+theorem exists_cuspForm_ne_zero_of_trivial (h : EtaMultiplierTrivial)
+    (hcusp : EtaProductVanishesAtCusps) :
+    ∃ f : CuspForm (Gamma0 11) 2, f ≠ 0 :=
+  exists_cuspForm_ne_zero_of_etaProduct (etaProductIsCuspForm_of_trivial h hcusp)
+
+end ModularCurve
+
+namespace ModularCurve
+
+namespace Gamma0Eleven
+
+open Matrix CongruenceSubgroup Subgroup
+open scoped MatrixGroups Pointwise
+
+scoped instance fact_prime_eleven_gamma0Gens : Fact (Nat.Prime 11) := ⟨by norm_num⟩
+
+def repOfLabel : Option (ZMod 11) → SL(2, ℤ)
+  | none => 1
+  | some k => ⟨!![0, -1; 1, (k.val : ℤ)], by simp [Matrix.det_fin_two_of]⟩
+
+@[scoped simp] lemma repOfLabel_none : repOfLabel none = 1 := rfl
+
+@[scoped simp] lemma repOfLabel_some_one_zero (k : ZMod 11) : repOfLabel (some k) 1 0 = 1 := rfl
+
+@[scoped simp] lemma repOfLabel_some_one_one (k : ZMod 11) :
+    repOfLabel (some k) 1 1 = (k.val : ℤ) := rfl
+
+@[scoped simp] lemma one_apply_one_zero : (1 : SL(2, ℤ)) 1 0 = 0 := rfl
+
+@[scoped simp] lemma one_apply_one_one : (1 : SL(2, ℤ)) 1 1 = 1 := rfl
+
+def transversal : Set SL(2, ℤ) := Set.range repOfLabel
+
+lemma one_mem_transversal : (1 : SL(2, ℤ)) ∈ transversal := ⟨none, rfl⟩
+
+def label (g : SL(2, ℤ)) : Option (ZMod 11) :=
+  if (g 1 0 : ZMod 11) = 0 then none
+  else some ((g 1 1 : ZMod 11) / (g 1 0 : ZMod 11))
+
+private lemma intCast_val (k : ZMod 11) : (((k.val : ℕ) : ℤ) : ZMod 11) = k := by
+  exact_mod_cast ZMod.natCast_rightInverse k
+
+lemma apply_one_one_ne_zero (g : SL(2, ℤ)) (hc : (g 1 0 : ZMod 11) = 0) :
+    (g 1 1 : ZMod 11) ≠ 0 := by
+  intro hd
+  have hdet : (g 0 0 : ℤ) * g 1 1 - g 0 1 * g 1 0 = 1 := by
+    have h2 := g.2
+    rw [Matrix.det_fin_two] at h2
+    exact h2
+  have hcast : (g 0 0 : ZMod 11) * (g 1 1 : ZMod 11)
+      - (g 0 1 : ZMod 11) * (g 1 0 : ZMod 11) = 1 := by
+    have h3 : (((g 0 0 : ℤ) * g 1 1 - g 0 1 * g 1 0 : ℤ) : ZMod 11) = ((1 : ℤ) : ZMod 11) := by
+      rw [hdet]
+    push_cast at h3
+    exact h3
+  rw [hc, hd, mul_zero, mul_zero, sub_zero] at hcast
+  exact zero_ne_one hcast
+
+lemma mul_inv_apply_one_zero (g h : SL(2, ℤ)) :
+    (g * h⁻¹) 1 0 = g 1 0 * h 1 1 - g 1 1 * h 1 0 := by
+  change ((g : Matrix (Fin 2) (Fin 2) ℤ) * ((h⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)) 1 0
+      = (g : Matrix (Fin 2) (Fin 2) ℤ) 1 0 * (h : Matrix (Fin 2) (Fin 2) ℤ) 1 1
+        - (g : Matrix (Fin 2) (Fin 2) ℤ) 1 1 * (h : Matrix (Fin 2) (Fin 2) ℤ) 1 0
+  rw [Matrix.SpecialLinearGroup.coe_inv, Matrix.adjugate_fin_two, Matrix.mul_apply,
+    Fin.sum_univ_two]
+  change (g : Matrix (Fin 2) (Fin 2) ℤ) 1 0 * (h : Matrix (Fin 2) (Fin 2) ℤ) 1 1
+      + (g : Matrix (Fin 2) (Fin 2) ℤ) 1 1 * -((h : Matrix (Fin 2) (Fin 2) ℤ) 1 0) = _
+  ring
+
+theorem mul_inv_mem_iff (g h : SL(2, ℤ)) :
+    g * h⁻¹ ∈ Gamma0 11 ↔
+      (g 1 0 : ZMod 11) * (h 1 1 : ZMod 11) = (g 1 1 : ZMod 11) * (h 1 0 : ZMod 11) := by
+  rw [Gamma0_mem, mul_inv_apply_one_zero]
+  push_cast
+  exact sub_eq_zero
+
+theorem mul_inv_repOfLabel_mem_iff (g : SL(2, ℤ)) (l : Option (ZMod 11)) :
+    g * (repOfLabel l)⁻¹ ∈ Gamma0 11 ↔ l = label g := by
+  rw [mul_inv_mem_iff]
+  unfold label
+  cases l with
+  | none =>
+    rw [repOfLabel_none, one_apply_one_one, one_apply_one_zero, Int.cast_one, mul_one,
+      Int.cast_zero, mul_zero]
+    by_cases hc : (g 1 0 : ZMod 11) = 0
+    · rw [ite_eq_left hc]
+      exact iff_of_true hc rfl
+    · rw [ite_eq_right hc]
+      exact iff_of_false hc (by simp)
+  | some k =>
+    rw [repOfLabel_some_one_one, repOfLabel_some_one_zero, Int.cast_one, mul_one,
+      intCast_val]
+    by_cases hc : (g 1 0 : ZMod 11) = 0
+    · rw [ite_eq_left hc]
+      refine iff_of_false (fun hcontra => ?_) (by simp)
+      rw [hc, zero_mul] at hcontra
+      exact apply_one_one_ne_zero g hc hcontra.symm
+    · rw [ite_eq_right hc, Option.some_inj, eq_div_iff hc]
+      constructor <;> intro h <;> linear_combination h
+
+theorem isComplement_transversal :
+    IsComplement (Gamma0 11 : Set SL(2, ℤ)) transversal := by
+  rw [isComplement_iff_existsUnique_mul_inv_mem]
+  intro g
+  refine ⟨⟨repOfLabel (label g), ⟨label g, rfl⟩⟩, ?_, ?_⟩
+  · exact (mul_inv_repOfLabel_mem_iff g (label g)).mpr rfl
+  · rintro ⟨x, l, rfl⟩ ht
+    exact Subtype.ext (congrArg repOfLabel ((mul_inv_repOfLabel_mem_iff g l).mp ht))
+
+lemma coe_toRightFun (g : SL(2, ℤ)) :
+    (isComplement_transversal.toRightFun g : SL(2, ℤ)) = repOfLabel (label g) := by
+  have huniq := isComplement_iff_existsUnique_mul_inv_mem.mp isComplement_transversal g
+  have h1 : g * ((isComplement_transversal.toRightFun g : SL(2, ℤ)))⁻¹
+      ∈ (Gamma0 11 : Set SL(2, ℤ)) :=
+    isComplement_transversal.mul_inv_toRightFun_mem g
+  have h2 : g * (((⟨repOfLabel (label g), ⟨label g, rfl⟩⟩ : transversal) : SL(2, ℤ)))⁻¹
+      ∈ (Gamma0 11 : Set SL(2, ℤ)) :=
+    (mul_inv_repOfLabel_mem_iff g (label g)).mpr rfl
+  exact congrArg Subtype.val (huniq.unique h1 h2)
+
+def schreierGen (l : Option (ZMod 11)) (s : SL(2, ℤ)) : SL(2, ℤ) :=
+  repOfLabel l * s * (repOfLabel (label (repOfLabel l * s)))⁻¹
+
+theorem schreierGen_mem (l : Option (ZMod 11)) (s : SL(2, ℤ)) :
+    schreierGen l s ∈ Gamma0 11 :=
+  (mul_inv_repOfLabel_mem_iff (repOfLabel l * s) (label (repOfLabel l * s))).mpr rfl
+
+def schreierGens : Set SL(2, ℤ) :=
+  {x | ∃ l : Option (ZMod 11),
+    x = schreierGen l ModularGroup.S ∨ x = schreierGen l ModularGroup.T}
+
+theorem closure_schreierGens : Subgroup.closure schreierGens = Gamma0 11 := by
+  refine le_antisymm ((Subgroup.closure_le _).mpr ?_) ?_
+  · rintro x ⟨l, rfl | rfl⟩ <;> exact schreierGen_mem _ _
+  · rw [← Subgroup.closure_mul_image_eq isComplement_transversal one_mem_transversal
+      SpecialLinearGroup.SL2Z_generators]
+    refine Subgroup.closure_mono ?_
+    rintro x ⟨g, hg, rfl⟩
+    rw [Set.mem_mul] at hg
+    obtain ⟨r, hr, s, hs, rfl⟩ := hg
+    obtain ⟨l, rfl⟩ := hr
+    simp only [coe_toRightFun]
+    simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hs
+    rcases hs with rfl | rfl
+    · exact ⟨l, Or.inl rfl⟩
+    · exact ⟨l, Or.inr rfl⟩
+
+theorem schreier_induction {p : (g : SL(2, ℤ)) → g ∈ Gamma0 11 → Prop}
+    (gen : ∀ (l : Option (ZMod 11)) (s : SL(2, ℤ)),
+      s = ModularGroup.S ∨ s = ModularGroup.T → p (schreierGen l s) (schreierGen_mem l s))
+    (one : p 1 (one_mem _))
+    (mul : ∀ x y hx hy, p x hx → p y hy → p (x * y) (mul_mem hx hy))
+    (inv : ∀ x hx, p x hx → p x⁻¹ (inv_mem hx))
+    {g : SL(2, ℤ)} (hg : g ∈ Gamma0 11) : p g hg := by
+  have hg' : g ∈ Subgroup.closure schreierGens := by
+    rw [closure_schreierGens]; exact hg
+  have key : ∀ (x : SL(2, ℤ)) (hx : x ∈ Subgroup.closure schreierGens),
+      p x (closure_schreierGens ▸ hx) := by
+    intro x hx
+    induction hx using Subgroup.closure_induction with
+    | mem y hy =>
+      obtain ⟨l, rfl | rfl⟩ := hy
+      · exact gen l ModularGroup.S (Or.inl rfl)
+      · exact gen l ModularGroup.T (Or.inr rfl)
+    | one => exact one
+    | mul y z hy hz hpy hpz => exact mul y z _ _ hpy hpz
+    | inv y hy hpy => exact inv y _ hpy
+  exact key g hg'
+
+end Gamma0Eleven
+end ModularCurve
+
+namespace ModularCurve
+
+theorem etaMultiplier_one : etaMultiplier 1 = 1 := by
+  have h := etaMultiplier_mul T_mem_Gamma0 (one_mem _)
+  rw [mul_one, etaMultiplier_T, one_mul] at h
+  exact h.symm
+
+theorem etaMultiplier_inv_eq_one {g : SL(2, ℤ)} (hg : g ∈ Gamma0 11)
+    (h : etaMultiplier g = 1) : etaMultiplier g⁻¹ = 1 := by
+  have h2 := etaMultiplier_mul (inv_mem hg) hg
+  rw [inv_mul_cancel, etaMultiplier_one, h, mul_one] at h2
+  exact h2.symm
+
+theorem etaMultiplier_T_inv : etaMultiplier (ModularGroup.T)⁻¹ = 1 :=
+  etaMultiplier_inv_eq_one T_mem_Gamma0 etaMultiplier_T
+
+theorem etaMultiplier_T_pow (n : ℕ) : etaMultiplier (ModularGroup.T ^ n) = 1 := by
+  induction n with
+  | zero => simpa using etaMultiplier_one
+  | succ n ih =>
+    rw [pow_succ, etaMultiplier_mul (pow_mem T_mem_Gamma0 n) T_mem_Gamma0, ih,
+      etaMultiplier_T, mul_one]
+
+theorem etaMultiplier_T_pow_inv (n : ℕ) : etaMultiplier (ModularGroup.T ^ n)⁻¹ = 1 :=
+  etaMultiplier_inv_eq_one (pow_mem T_mem_Gamma0 n) (etaMultiplier_T_pow n)
+
+private lemma neg_eq_neg_one_mul (g : SL(2, ℤ)) : -g = -1 * g := by
+  apply Subtype.ext
+  simp only [Matrix.SpecialLinearGroup.coe_neg, Matrix.SpecialLinearGroup.coe_mul,
+    Matrix.SpecialLinearGroup.coe_one]
+  exact (neg_one_mul _).symm
+
+private lemma neg_mem_Gamma0 {g : SL(2, ℤ)} (hg : g ∈ Gamma0 11) : -g ∈ Gamma0 11 := by
+  rw [neg_eq_neg_one_mul]
+  exact mul_mem neg_one_mem_Gamma0 hg
+
+theorem etaMultiplier_neg {g : SL(2, ℤ)} (hg : g ∈ Gamma0 11) :
+    etaMultiplier (-g) = etaMultiplier g := by
+  rw [neg_eq_neg_one_mul, etaMultiplier_mul neg_one_mem_Gamma0 hg, etaMultiplier_neg_one,
+    one_mul]
+
+section Fricke
+
+private lemma sqrt_eleven_mul_I_sq : ((Real.sqrt 11 : ℂ) * Complex.I) ^ 2 = -11 := by
+  rw [mul_pow, Complex.I_sq, ← Complex.ofReal_pow, Real.sq_sqrt (by norm_num : (0:ℝ) ≤ 11)]
+  norm_num
+
+private lemma etaMultiplier_eq_one_of_apply_eq_aux (γ : SL(2, ℤ))
+    (hsym : γ 1 0 = 11 * γ 0 1) (hA : 0 < γ 0 0) : etaMultiplier γ = 1 := by
+  have hdet : γ 0 0 * γ 1 1 - γ 0 1 * γ 1 0 = 1 := by
+    have h2 := γ.2
+    rw [Matrix.det_fin_two] at h2
+    exact h2
+  have hAD : (γ 0 0 : ℤ) * γ 1 1 = 1 + 11 * γ 0 1 ^ 2 := by
+    linear_combination hdet + γ 0 1 * hsym
+  have hγ : γ ∈ Gamma0 11 := by
+    rw [Gamma0_mem, hsym]
+    push_cast
+    exact mul_eq_zero_of_left (by decide) _
+  have hADc : ((γ 0 0 : ℤ) : ℂ) * ((γ 1 1 : ℤ) : ℂ) = 1 + 11 * ((γ 0 1 : ℤ) : ℂ) ^ 2 := by
+    exact_mod_cast congrArg (fun n : ℤ => (n : ℂ)) hAD
+  have hsymc : ((γ 1 0 : ℤ) : ℂ) = 11 * ((γ 0 1 : ℤ) : ℂ) := by exact_mod_cast hsym
+  have hAne : ((γ 0 0 : ℤ) : ℂ) ≠ 0 := by
+    exact_mod_cast (Int.cast_ne_zero (α := ℂ)).mpr hA.ne'
+  obtain ⟨s, hs_def⟩ : ∃ s : ℂ, s = (Real.sqrt 11 : ℂ) * Complex.I := ⟨_, rfl⟩
+  have hs2 : s ^ 2 = -11 := by rw [hs_def]; exact sqrt_eleven_mul_I_sq
+  obtain ⟨z₀, hz₀_def⟩ :
+      ∃ z : ℂ, z = (-(11 * ((γ 0 1 : ℤ) : ℂ)) + s) / (11 * ((γ 0 0 : ℤ) : ℂ)) := ⟨_, rfl⟩
+  have h11A : (11 : ℂ) * ((γ 0 0 : ℤ) : ℂ) ≠ 0 := mul_ne_zero (by norm_num) hAne
+  have hz₀_mul : 11 * ((γ 0 0 : ℤ) : ℂ) * z₀ = -(11 * ((γ 0 1 : ℤ) : ℂ)) + s := by
+    rw [hz₀_def]
+    field_simp
+  have hz₀ : z₀ ∈ ℍₒ := by
+    change (0 : ℝ) < z₀.im
+    have hnum : (-(11 * ((γ 0 1 : ℤ) : ℂ)) + s).im = Real.sqrt 11 := by
+      rw [hs_def]
+      simp
+    have hden : (11 : ℂ) * ((γ 0 0 : ℤ) : ℂ) = (((11 * γ 0 0 : ℤ)) : ℂ) := by push_cast; ring
+    rw [hz₀_def, hden, Complex.div_intCast_im, hnum]
+    apply div_pos (Real.sqrt_pos.mpr (by norm_num))
+    exact_mod_cast Int.mul_pos (by norm_num) hA
+  have hz₀ne : z₀ ≠ 0 := by
+    intro h
+    rw [h] at hz₀
+    simp only [Set.mem_ofPred_eq, Complex.zero_im, lt_self_iff_false] at hz₀
+  have key1 : 11 * ((γ 0 0 : ℤ) : ℂ) * z₀ ^ 2 + 22 * ((γ 0 1 : ℤ) : ℂ) * z₀
+      + ((γ 1 1 : ℤ) : ℂ) = 0 := by
+    apply mul_left_cancel₀ h11A
+    rw [mul_zero]
+    calc 11 * ((γ 0 0 : ℤ) : ℂ)
+          * (11 * ((γ 0 0 : ℤ) : ℂ) * z₀ ^ 2 + 22 * ((γ 0 1 : ℤ) : ℂ) * z₀ + ((γ 1 1 : ℤ) : ℂ))
+        = (11 * ((γ 0 0 : ℤ) : ℂ) * z₀) ^ 2
+            + 22 * ((γ 0 1 : ℤ) : ℂ) * (11 * ((γ 0 0 : ℤ) : ℂ) * z₀)
+            + 11 * (((γ 0 0 : ℤ) : ℂ) * ((γ 1 1 : ℤ) : ℂ)) := by ring
+      _ = (-(11 * ((γ 0 1 : ℤ) : ℂ)) + s) ^ 2
+            + 22 * ((γ 0 1 : ℤ) : ℂ) * (-(11 * ((γ 0 1 : ℤ) : ℂ)) + s)
+            + 11 * (1 + 11 * ((γ 0 1 : ℤ) : ℂ) ^ 2) := by rw [hz₀_mul, hADc]
+      _ = 0 := by linear_combination hs2
+  have key2 : (11 * ((γ 0 1 : ℤ) : ℂ) * z₀ + ((γ 1 1 : ℤ) : ℂ)) ^ 2 = -(11 * z₀ ^ 2) := by
+    have h1 : 11 * ((γ 0 1 : ℤ) : ℂ) * z₀ + ((γ 1 1 : ℤ) : ℂ) = -(z₀ * s) := by
+      linear_combination key1 - z₀ * hz₀_mul
+    rw [h1, neg_sq, mul_pow, hs2]
+    ring
+  have hden : 11 * ((γ 0 1 : ℤ) : ℂ) * z₀ + ((γ 1 1 : ℤ) : ℂ) ≠ 0 := by
+    intro h
+    have h0 : (11 : ℂ) * z₀ ^ 2 = 0 := by
+      linear_combination key2 - (11 * ((γ 0 1 : ℤ) : ℂ) * z₀ + ((γ 1 1 : ℤ) : ℂ)) * h
+    exact (mul_ne_zero (by norm_num) (pow_ne_zero 2 hz₀ne)) h0
+  have h11z : (11 : ℂ) * z₀ ≠ 0 := mul_ne_zero (by norm_num) hz₀ne
+  set τ₀ : ℍ := ⟨z₀, hz₀⟩
+  have hcoe : (τ₀ : ℂ) = z₀ := rfl
+  have hsmul : ((γ • τ₀ : ℍ) : ℂ) = -1 / (11 * z₀) := by
+    rw [UpperHalfPlane.coe_specialLinearGroup_apply]
+    simp only [eq_intCast]
+    push_cast
+    rw [hcoe, hsymc, div_eq_div_iff hden h11z]
+    linear_combination key1
+  have hdenom : UpperHalfPlane.denom γ τ₀ = 11 * ((γ 0 1 : ℤ) : ℂ) * z₀ + ((γ 1 1 : ℤ) : ℂ) := by
+    rw [ModularGroup.denom_apply, hcoe, hsymc]
+  have hlaw := etaProductEleven_smul hγ τ₀
+  rw [hsmul, hcoe, etaProductEleven_fricke hz₀, hdenom] at hlaw
+  rw [show (2 : ℤ) = ((2 : ℕ) : ℤ) from rfl, zpow_natCast, key2] at hlaw
+  have hX : -(11 * z₀ ^ 2) * etaProductEleven z₀ ≠ 0 := by
+    apply mul_ne_zero
+    · simpa using mul_ne_zero (show (11 : ℂ) ≠ 0 by norm_num) (pow_ne_zero 2 hz₀ne)
+    · exact etaProductEleven_ne_zero hz₀
+  have h1 : (1 : ℂ) * (-(11 * z₀ ^ 2) * etaProductEleven z₀)
+      = etaMultiplier γ * (-(11 * z₀ ^ 2) * etaProductEleven z₀) := by
+    rw [one_mul]
+    exact hlaw
+  exact (mul_right_cancel₀ hX h1).symm
+
+theorem etaMultiplier_eq_one_of_apply_eq (γ : SL(2, ℤ)) (hsym : γ 1 0 = 11 * γ 0 1) :
+    etaMultiplier γ = 1 := by
+  have hdet : γ 0 0 * γ 1 1 - γ 0 1 * γ 1 0 = 1 := by
+    have h2 := γ.2
+    rw [Matrix.det_fin_two] at h2
+    exact h2
+  have hneg_entry : ∀ i j : Fin 2, (-γ : SL(2, ℤ)) i j = -(γ i j) := by
+    intro i j
+    simp [Matrix.SpecialLinearGroup.coe_neg]
+  rcases lt_trichotomy ((γ 0 0 : ℤ)) 0 with hA | hA | hA
+  · have hγ : γ ∈ Gamma0 11 := by
+      rw [Gamma0_mem, hsym]
+      push_cast
+      exact mul_eq_zero_of_left (by decide) _
+    have h1 : etaMultiplier (-γ) = 1 := by
+      apply etaMultiplier_eq_one_of_apply_eq_aux
+      · rw [hneg_entry, hneg_entry, hsym]
+        ring
+      · rw [hneg_entry]
+        omega
+    have h2 := etaMultiplier_neg hγ
+    rw [h1] at h2
+    exact h2.symm
+  · exfalso
+    have hsq : -11 * γ 0 1 ^ 2 = 1 := by
+      linear_combination hdet + γ 0 1 * hsym - γ 1 1 * hA
+    nlinarith [sq_nonneg (γ 0 1), hsq]
+  · exact etaMultiplier_eq_one_of_apply_eq_aux γ hsym hA
+
+end Fricke
+
+section Generators
+
+open ModularCurve.Gamma0Eleven
+
+private lemma eq_one_of_mul_left {g h : SL(2, ℤ)} (hg : g ∈ Gamma0 11) (hh : h ∈ Gamma0 11)
+    (h1 : etaMultiplier (h * g) = 1) (h2 : etaMultiplier h = 1) : etaMultiplier g = 1 := by
+  rw [etaMultiplier_mul hh hg, h2, one_mul] at h1
+  exact h1
+
+private lemma eq_one_of_mul_right {g h : SL(2, ℤ)} (hg : g ∈ Gamma0 11) (hh : h ∈ Gamma0 11)
+    (h1 : etaMultiplier (g * h) = 1) (h2 : etaMultiplier h = 1) : etaMultiplier g = 1 := by
+  rw [etaMultiplier_mul hg hh, h2, mul_one] at h1
+  exact h1
+
+private lemma schreierGen_T_eq_one : ∀ k : ZMod 11, k ≠ 10 →
+    schreierGen (some k) ModularGroup.T = 1 := by decide +kernel
+
+theorem etaMultiplier_schreierGen (l : Option (ZMod 11)) (s : SL(2, ℤ))
+    (hs : s = ModularGroup.S ∨ s = ModularGroup.T) :
+    etaMultiplier (schreierGen l s) = 1 := by
+  have hTinv : (ModularGroup.T)⁻¹ ∈ Gamma0 11 := inv_mem T_mem_Gamma0
+  have hT2 : ModularGroup.T ^ 2 ∈ Gamma0 11 := pow_mem T_mem_Gamma0 2
+  have hT2inv : (ModularGroup.T ^ 2)⁻¹ ∈ Gamma0 11 := inv_mem hT2
+  rcases hs with rfl | rfl
+  · rcases l with _ | k
+    · rw [show schreierGen none ModularGroup.S = 1 by decide +kernel]
+      exact etaMultiplier_one
+    · fin_cases k
+      · refine Eq.trans (congrArg etaMultiplier ?_) etaMultiplier_neg_one
+        decide
+      · refine eq_one_of_mul_left (schreierGen_mem _ _) hT2 ?_ (etaMultiplier_T_pow 2)
+        exact etaMultiplier_eq_one_of_apply_eq _ (by decide +kernel)
+      · refine eq_one_of_mul_left (schreierGen_mem _ _) T_mem_Gamma0 ?_ etaMultiplier_T
+        exact etaMultiplier_eq_one_of_apply_eq _ (by decide +kernel)
+      · refine eq_one_of_mul_left (schreierGen_mem _ _) T_mem_Gamma0 ?_ etaMultiplier_T
+        exact etaMultiplier_eq_one_of_apply_eq _ (by decide +kernel)
+      · refine eq_one_of_mul_left (schreierGen_mem _ _) T_mem_Gamma0 ?_ etaMultiplier_T
+        exact etaMultiplier_eq_one_of_apply_eq _ (by decide +kernel)
+      · refine eq_one_of_mul_right (schreierGen_mem _ _) hTinv ?_ etaMultiplier_T_inv
+        exact etaMultiplier_eq_one_of_apply_eq _ (by decide +kernel)
+      · refine eq_one_of_mul_left (schreierGen_mem _ _) T_mem_Gamma0 ?_ etaMultiplier_T
+        exact etaMultiplier_eq_one_of_apply_eq _ (by decide +kernel)
+      · refine eq_one_of_mul_right (schreierGen_mem _ _) hTinv ?_ etaMultiplier_T_inv
+        exact etaMultiplier_eq_one_of_apply_eq _ (by decide +kernel)
+      · refine eq_one_of_mul_right (schreierGen_mem _ _) hTinv ?_ etaMultiplier_T_inv
+        exact etaMultiplier_eq_one_of_apply_eq _ (by decide +kernel)
+      · refine eq_one_of_mul_right (schreierGen_mem _ _) hTinv ?_ etaMultiplier_T_inv
+        exact etaMultiplier_eq_one_of_apply_eq _ (by decide +kernel)
+      · refine eq_one_of_mul_right (schreierGen_mem _ _) hT2inv ?_ (etaMultiplier_T_pow_inv 2)
+        exact etaMultiplier_eq_one_of_apply_eq _ (by decide +kernel)
+  · rcases l with _ | k
+    · refine Eq.trans (congrArg etaMultiplier ?_) etaMultiplier_T
+      decide
+    · by_cases hk : k = 10
+      · subst hk
+        refine eq_one_of_mul_left (schreierGen_mem _ _) hTinv ?_ etaMultiplier_T_inv
+        exact etaMultiplier_eq_one_of_apply_eq _ (by decide +kernel)
+      · rw [schreierGen_T_eq_one k hk]
+        exact etaMultiplier_one
+
+end Generators
+
+theorem etaMultiplier_eq_one {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 11) : etaMultiplier γ = 1 := by
+  refine Gamma0Eleven.schreier_induction (p := fun g _ => etaMultiplier g = 1)
+    (fun l s hs => etaMultiplier_schreierGen l s hs) etaMultiplier_one
+    (fun x y hx hy hpx hpy => ?_) (fun x hx hpx => etaMultiplier_inv_eq_one hx hpx) hγ
+  show etaMultiplier (x * y) = 1
+  rw [etaMultiplier_mul hx hy, hpx, hpy, one_mul]
+
+theorem etaMultiplier_trivial : EtaMultiplierTrivial := fun _ hγ => etaMultiplier_eq_one hγ
+
+theorem etaProductEleven_transform {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 11) (τ : ℍ) :
+    etaProductEleven ((γ • τ : ℍ) : ℂ)
+      = UpperHalfPlane.denom γ τ ^ (2 : ℤ) * etaProductEleven (τ : ℂ) :=
+  etaProductEleven_smul_of_trivial etaMultiplier_trivial hγ τ
+
+theorem etaProductEleven_slash_invariant {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 11) :
+    (fun τ : ℍ => etaProductEleven (τ : ℂ)) ∣[(2 : ℤ)] γ
+      = fun τ : ℍ => etaProductEleven (τ : ℂ) :=
+  slashInvariant_of_etaMultiplierTrivial etaMultiplier_trivial hγ
+
+theorem etaProductIsCuspForm_of_vanishesAtCusps (hcusp : EtaProductVanishesAtCusps) :
+    EtaProductIsCuspForm :=
+  etaProductIsCuspForm_of_trivial etaMultiplier_trivial hcusp
+
+theorem exists_cuspForm_ne_zero_of_vanishesAtCusps (hcusp : EtaProductVanishesAtCusps) :
+    ∃ f : CuspForm (Gamma0 11) 2, f ≠ 0 :=
+  exists_cuspForm_ne_zero_of_trivial etaMultiplier_trivial hcusp
+
+end ModularCurve
+
+namespace ModularCurve
+
+open OnePoint Matrix.SpecialLinearGroup
+
+lemma tendsto_zero_of_pow_tendsto_zero {α : Type*} {l : Filter α} {g : α → ℂ} {n : ℕ}
+    (h : Tendsto (fun x => g x ^ n) l (𝓝 0)) : Tendsto g l (𝓝 0) := by
+  rw [NormedAddGroup.tendsto_nhds_zero] at h ⊢
+  intro ε hε
+  filter_upwards [h (ε ^ n) (by positivity)] with x hx
+  rw [norm_pow] at hx
+  exact lt_of_pow_lt_pow_left₀ n hε.le hx
+
+lemma discriminant_slash_isZeroAtImInfty (γ : SL(2, ℤ)) :
+    IsZeroAtImInfty (ModularForm.discriminant ∣[(12 : ℤ)] γ) := by
+  rw [SlashInvariantForm.slash_action_generators_SL2Z ModularForm.discriminant_S_invariant
+    ModularForm.discriminant_T_invariant γ]
+  exact ModularForm.discriminant_isZeroAtImInfty
+
+lemma isCusp_mapGL_smul_infty_Gamma0 (γ : SL(2, ℤ)) :
+    IsCusp (mapGL ℝ γ • (∞ : OnePoint ℝ))
+      ((Gamma0 11 : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) := by
+  rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z]
+  exact isCusp_SL2Z_iff'.mpr ⟨γ, rfl⟩
+
+lemma discriminantRescale_slash_isZeroAtImInfty (γ : SL(2, ℤ)) :
+    IsZeroAtImInfty
+      ((⇑(deltaEleven) : ℍ → ℂ) ∣[(12 : ℤ)] γ) :=
+  (deltaEleven).zero_at_cusps' (isCusp_mapGL_smul_infty_Gamma0 γ)
+    (mapGL ℝ γ) rfl
+
+private lemma zpow_neg_two_pow_twelve {x : ℂ} (hx : x ≠ 0) :
+    (x ^ (-2 : ℤ)) ^ (12 : ℕ) = x ^ (-12 : ℤ) * x ^ (-12 : ℤ) := by
+  rw [← zpow_natCast (x ^ (-2 : ℤ)) 12, ← zpow_mul, ← zpow_add₀ hx]
+  norm_num
+
+lemma etaProductEleven_slash_pow_twelve (γ : SL(2, ℤ)) (τ : ℍ) :
+    (((fun w : ℍ => etaProductEleven (w : ℂ)) ∣[(2 : ℤ)] γ) τ) ^ (12 : ℕ)
+      = (ModularForm.discriminant ∣[(12 : ℤ)] γ) τ
+        * ((⇑(deltaEleven) : ℍ → ℂ) ∣[(12 : ℤ)] γ) τ := by
+  have hd : denom γ τ ≠ 0 := denom_ne_zero _ τ
+  simp only [SL_slash_apply]
+  rw [mul_pow, etaProductEleven_pow_twelve_classical (γ • τ), zpow_neg_two_pow_twelve hd]
+  ring
+
+theorem etaProductEleven_slash_isZeroAtImInfty (γ : SL(2, ℤ)) :
+    IsZeroAtImInfty ((fun w : ℍ => etaProductEleven (w : ℂ)) ∣[(2 : ℤ)] γ) := by
+  refine tendsto_zero_of_pow_tendsto_zero (n := 12) ?_
+  have hprod : Tendsto
+      (fun τ : ℍ => (ModularForm.discriminant ∣[(12 : ℤ)] γ) τ
+        * ((⇑(deltaEleven) : ℍ → ℂ) ∣[(12 : ℤ)] γ) τ)
+      atImInfty (𝓝 0) := by
+    rw [show (0 : ℂ) = 0 * 0 by ring]
+    exact (discriminant_slash_isZeroAtImInfty γ).mul
+      (discriminantRescale_slash_isZeroAtImInfty γ)
+  exact hprod.congr fun τ => (etaProductEleven_slash_pow_twelve γ τ).symm
+
+theorem etaProductVanishesAtCusps : EtaProductVanishesAtCusps := by
+  intro c hc
+  rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z] at hc
+  obtain ⟨γ, rfl⟩ := isCusp_SL2Z_iff'.mp hc
+  exact (OnePoint.isZeroAt_iff_exists_SL2Z (isCusp_SL2Z_iff'.mpr ⟨γ, rfl⟩)).mpr
+    ⟨γ, rfl, etaProductEleven_slash_isZeroAtImInfty γ⟩
+
+theorem etaProductIsCuspForm : EtaProductIsCuspForm :=
+  etaProductIsCuspForm_of_vanishesAtCusps etaProductVanishesAtCusps
+
+theorem exists_cuspForm_ne_zero_S2_Gamma0_eleven :
+    ∃ f : CuspForm (Gamma0 11) 2, f ≠ 0 :=
+  exists_cuspForm_ne_zero_of_etaProduct etaProductIsCuspForm
+
+end ModularCurve
+
+theorem solution (N : ℕ) [NeZero N] :
+    ∃ g : CuspForm (CongruenceSubgroup.Gamma0 N) 12,
+      ∀ τ : UpperHalfPlane, g τ = ModularForm.eta (N * (τ : ℂ)) ^ 24 := by
+  obtain ⟨g, hg⟩ := CuspForm.exists_degeneracy_Gamma0 (N := N) (d := N) (M := 1)
+    (dvd_of_eq (mul_one N)) ModularCurve.deltaGamma0
+  refine ⟨g, fun τ => ?_⟩
+  rw [hg]
+  simp only [ModularCurve.deltaGamma0_coe, ModularForm.discriminant]
+  rw [ModularForm.coe_heckeDiagMatrix_smul (NeZero.ne N)]
+
+end
+end S_CuspForm_exists_gamma0_apply_eq_eta_mul_pow_twentyfour
+end P2MW
+export P2MW.S_CuspForm_exists_gamma0_apply_eq_eta_mul_pow_twentyfour (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem CuspForm.exists_gamma0_apply_eq_eta_mul_pow_twentyfour (N : ℕ) [NeZero N] :
+    ∃ g : CuspForm (CongruenceSubgroup.Gamma0 N) 12,
+      ∀ τ : UpperHalfPlane, g τ = ModularForm.eta (N * (τ : ℂ)) ^ 24 :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_exists_gamma0_four_apply_eq_eta_pow_mul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_exists_gamma0_four_apply_eq_eta_pow_mul.lean
new file mode 100644
index 0000000000..223cd1cf24
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_exists_gamma0_four_apply_eq_eta_pow_mul.lean
@@ -0,0 +1,680 @@
+/-
+Based on Prove2Me node CuspForm.exists_gamma0_four_apply_eq_eta_pow_mul
+(90051634-9f66-535b-b6be-e9977b9d4dee) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9f9d7099-dd4e-5af0-8131-7c3e5d2d1482
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.DedekindEta
+
+import Mathlib.Data.Int.Star
+import Mathlib.NumberTheory.ModularForms.Discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_exists_gamma0_apply_eq_eta_mul_pow_twentyfour
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Eta products of level 4 are cusp forms on Γ₀(4)
+
+Theorem statement: `CuspForm.exists_gamma0_four_apply_eq_eta_pow_mul`
+(`90051634-9f66-535b-b6be-e9977b9d4dee`), by Claude, 2026-09-05.
+
+Proof: submission `9f9d7099-dd4e-5af0-8131-7c3e5d2d1482`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $a,b,c$ be natural numbers, not all zero (i.e. $0 < a+b+c$), subject to the four arithmetic
+conditions $24 \mid a+2b+4c$, $24 \mid 4a+2b+c$, $b$ even, and $4 \mid a+b+c$. The assertion is that
+there exists a cusp form $f$ for the congruence subgroup $\Gamma_0(4)$, of weight equal to the
+integer obtained from the natural-number quotient $(a+b+c)/2$ (exact here, since $4 \mid a+b+c$),
+such that for every point $z$ of the upper half-plane the value $f(z)$ equals
+$$\eta(z)^{a}\,\eta(2z)^{b}\,\eta(4z)^{c},$$
+where $\eta$ denotes the Dedekind eta function as a function on the complex numbers and $z$ is
+regarded as a complex number. Thus the eta product is realised as an element of the space of cusp
+forms of that weight and level in the sense of Mathlib: weakly modular of the stated weight for
+$\Gamma_0(4)$ with trivial character, holomorphic, and vanishing at the cusps.
+
+This is the Gordon–Hughes–Newman holomorphy criterion for eta products, specialised to level $4$ and
+the divisors $1,2,4$: the two divisibility conditions make the orders at the cusps $\infty$ and $0$
+integral, while the parity of $b$ together with $4 \mid a+b+c$ trivialises the quadratic character
+attached to the product. It supplies the modular forms used in the identities
+[`ModularForm.E4_mul_etaProduct_eq`](thm.html#ModularForm.E4_mul_etaProduct_eq),
+[`ModularForm.E4_mul_eta_pow_eight_eq`](thm.html#ModularForm.E4_mul_eta_pow_eight_eq) and
+[`ModularForm.eta_pow_twentyfour_eq`](thm.html#ModularForm.eta_pow_twentyfour_eq).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_CuspForm_exists_gamma0_four_apply_eq_eta_pow_mul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_CuspForm_exists_gamma0_four_apply_eq_eta_pow_mul
+
+open scoped MatrixGroups ModularForm Real UpperHalfPlane
+open ModularGroup Complex
+open ModularForm (eta eta_q eta_q_eq_cexp)
+
+noncomputable section
+
+namespace EtaGamma0Four
+
+def Fc (a b c : ℕ) (w : ℂ) : ℂ := η w ^ a * η (2 * w) ^ b * η (4 * w) ^ c
+
+def F (a b c : ℕ) (z : ℍ) : ℂ := Fc a b c z
+
+def Gc (a b c : ℕ) (w : ℂ) : ℂ := η w ^ a * η (w / 2) ^ b * η (w / 4) ^ c
+
+lemma eta_q_add_int (n : ℕ) (w : ℂ) (m : ℤ) : eta_q n (w + m) = eta_q n w := by
+  rw [eta_q_eq_cexp, eta_q_eq_cexp]
+  have : 2 * ↑π * I * (↑n + 1) * (w + ↑m) =
+      2 * ↑π * I * (↑n + 1) * w + ((((n : ℤ) + 1) * m : ℤ) : ℂ) * (2 * π * I) := by push_cast; ring
+  rw [this, Complex.exp_add, Complex.exp_int_mul_two_pi_mul_I, mul_one]
+
+lemma eta_add_int (w : ℂ) (m : ℤ) : η (w + m) = cexp (π * I * m / 12) * η w := by
+  unfold ModularForm.eta
+  simp_rw [eta_q_add_int]
+  rw [Function.Periodic.qParam, Function.Periodic.qParam, ← mul_assoc]
+  congr 1
+  rw [← Complex.exp_add]
+  congr 1
+  push_cast
+  ring
+
+lemma eta_add_int_pow (w : ℂ) (m : ℤ) (e : ℕ) :
+    η (w + m) ^ e = cexp (π * I * (m * e) / 12) * η w ^ e := by
+  rw [eta_add_int, mul_pow, ← Complex.exp_nat_mul]
+  congr 2
+  ring
+
+lemma cexp_phase_eq_one (s : ℤ) (h : (24 : ℤ) ∣ s) : cexp (π * I * s / 12) = 1 := by
+  obtain ⟨t, rfl⟩ := h
+  have : (π * I * ((24 * t : ℤ) : ℂ) / 12) = t * (2 * π * I) := by push_cast; ring
+  rw [this, Complex.exp_int_mul_two_pi_mul_I]
+
+lemma Fc_add_int (a b c : ℕ) (w : ℂ) (m : ℤ) :
+    Fc a b c (w + m) = cexp (π * I * ((m * (a + 2 * b + 4 * c : ℕ) : ℤ) : ℂ) / 12) * Fc a b c w :=
+      by
+  unfold Fc
+  have h2 : 2 * (w + m) = 2 * w + ((2 * m : ℤ) : ℂ) := by push_cast; ring
+  have h4 : 4 * (w + m) = 4 * w + ((4 * m : ℤ) : ℂ) := by push_cast; ring
+  rw [h2, h4, eta_add_int_pow, eta_add_int_pow, eta_add_int_pow]
+  have : cexp (π * I * (m * a) / 12) * η w ^ a * (cexp (π * I * (((2 * m : ℤ) : ℂ) * b) / 12) * η (2
+    * w) ^ b) *
+      (cexp (π * I * (((4 * m : ℤ) : ℂ) * c) / 12) * η (4 * w) ^ c) =
+      (cexp (π * I * (m * a) / 12) * cexp (π * I * (((2 * m : ℤ) : ℂ) * b) / 12) *
+        cexp (π * I * (((4 * m : ℤ) : ℂ) * c) / 12)) * (η w ^ a * η (2 * w) ^ b * η (4 * w) ^ c)
+          := by
+          ring
+  rw [this, ← Complex.exp_add, ← Complex.exp_add]
+  congr 2
+  push_cast
+  ring
+
+lemma Gc_add_four_mul_int (a b c : ℕ) (w : ℂ) (m : ℤ) :
+    Gc a b c (w + ((4 * m : ℤ) : ℂ)) = cexp (π * I * ((m * (4 * a + 2 * b + c : ℕ) : ℤ) : ℂ) / 12) *
+      Gc a b c w := by
+  unfold Gc
+  have h2 : (w + ((4 * m : ℤ) : ℂ)) / 2 = w / 2 + ((2 * m : ℤ) : ℂ) := by push_cast; ring
+  have h4 : (w + ((4 * m : ℤ) : ℂ)) / 4 = w / 4 + ((m : ℤ) : ℂ) := by push_cast; ring
+  rw [h2, h4, eta_add_int_pow, eta_add_int_pow, eta_add_int_pow]
+  have : cexp (π * I * (((4 * m : ℤ) : ℂ) * a) / 12) * η w ^ a * (cexp (π * I * (((2 * m : ℤ) : ℂ) *
+    b) / 12) * η (w / 2) ^ b) *
+      (cexp (π * I * ((m : ℂ) * c) / 12) * η (w / 4) ^ c) =
+      (cexp (π * I * (((4 * m : ℤ) : ℂ) * a) / 12) * cexp (π * I * (((2 * m : ℤ) : ℂ) * b) / 12) *
+        cexp (π * I * ((m : ℂ) * c) / 12)) * (η w ^ a * η (w / 2) ^ b * η (w / 4) ^ c) := by ring
+  rw [this, ← Complex.exp_add, ← Complex.exp_add]
+  congr 2
+  push_cast
+  ring
+
+lemma Fc_add_one (a b c : ℕ) (h₁ : 24 ∣ a + 2 * b + 4 * c) (w : ℂ) :
+    Fc a b c (w + 1) = Fc a b c w := by
+  have := Fc_add_int a b c w 1
+  rw [Int.cast_one] at this
+  rw [this, cexp_phase_eq_one _ (by rw [one_mul]; exact Int.natCast_dvd_natCast.mpr h₁), one_mul]
+
+lemma Gc_sub_four (a b c : ℕ) (h₂ : 24 ∣ 4 * a + 2 * b + c) (w : ℂ) :
+    Gc a b c (w + ((-4 : ℤ) : ℂ)) = Gc a b c w := by
+  have := Gc_add_four_mul_int a b c w (-1)
+  rw [show ((4 * (-1 : ℤ) : ℤ)) = -4 by norm_num] at this
+  rw [this, cexp_phase_eq_one _ ?_, one_mul]
+  rw [neg_mul, one_mul, dvd_neg]
+  exact Int.natCast_dvd_natCast.mpr h₂
+
+lemma sqrt_sq (w : ℂ) : Complex.sqrt w ^ 2 = w := by
+  have h := Complex.cpow_nat_inv_pow w two_ne_zero
+  have h2 : ((2 : ℕ) : ℂ)⁻¹ = (2 : ℂ)⁻¹ := by norm_num
+  rw [h2] at h
+  exact h
+
+lemma eta_neg_inv (w : ℂ) (hw : 0 < w.im) :
+    η (-w⁻¹) = (Complex.sqrt I)⁻¹ * (Complex.sqrt w * η w) := by
+  have := ModularForm.eta_comp_eq_csqrt_I_inv hw
+  rw [show -w⁻¹ = -1 / w by rw [neg_div, one_div]]
+  simpa only [Function.comp, Pi.smul_apply, Pi.mul_apply, smul_eq_mul] using this
+
+lemma eta_neg_inv_pow (w : ℂ) (hw : 0 < w.im) (e : ℕ) :
+    η (-w⁻¹) ^ (2 * e) = (I⁻¹ * w) ^ e * η w ^ (2 * e) := by
+  rw [eta_neg_inv w hw]
+  have : ((Complex.sqrt I)⁻¹ * (Complex.sqrt w * η w)) ^ (2 * e) =
+      ((Complex.sqrt I ^ 2)⁻¹ * (Complex.sqrt w ^ 2)) ^ e * (η w ^ 2) ^ e := by ring
+  rw [this, sqrt_sq, sqrt_sq, ← pow_mul]
+
+def CS (a' b' c' : ℕ) : ℂ := (I⁻¹) ^ (a' + b' + c') * (2⁻¹ : ℂ) ^ b' * (4⁻¹ : ℂ) ^ c'
+
+lemma CS_ne_zero (a' b' c' : ℕ) : CS a' b' c' ≠ 0 := by
+  unfold CS
+  exact mul_ne_zero (mul_ne_zero (pow_ne_zero _ (inv_ne_zero I_ne_zero)) (pow_ne_zero _ (by
+    norm_num)))
+    (pow_ne_zero _ (by norm_num))
+
+lemma Fc_neg_inv (a' b' c' : ℕ) (z : ℂ) (hz : 0 < z.im) :
+    Fc (2 * a') (2 * b') (2 * c') (-z⁻¹) =
+      CS a' b' c' * z ^ (a' + b' + c') * Gc (2 * a') (2 * b') (2 * c') z := by
+  unfold Fc Gc CS
+  have h2 : 2 * -z⁻¹ = -(z / 2)⁻¹ := by rw [inv_div]; ring
+  have h4 : 4 * -z⁻¹ = -(z / 4)⁻¹ := by rw [inv_div]; ring
+  have hz2 : 0 < (z / 2).im := by rw [Complex.div_ofNat_im]; positivity
+  have hz4 : 0 < (z / 4).im := by rw [Complex.div_ofNat_im]; positivity
+  rw [h2, h4, eta_neg_inv_pow z hz, eta_neg_inv_pow _ hz2, eta_neg_inv_pow _ hz4]
+  ring
+
+lemma coe_S_smul (z : ℍ) : ((ModularGroup.S • z : ℍ) : ℂ) = -((z : ℂ))⁻¹ := by
+  rw [UpperHalfPlane.modular_S_smul]; simp [inv_neg]
+
+lemma denom_SL (γ : SL(2, ℤ)) (z : ℍ) :
+    UpperHalfPlane.denom (Matrix.SpecialLinearGroup.toGL ((Matrix.SpecialLinearGroup.map
+      (Int.castRingHom ℝ)) γ)) (z : ℂ) =
+      (γ 1 0 : ℂ) * z + (γ 1 1 : ℂ) := by
+  simp [UpperHalfPlane.denom]
+
+lemma denom_S (z : ℍ) :
+    UpperHalfPlane.denom (Matrix.SpecialLinearGroup.toGL ((Matrix.SpecialLinearGroup.map
+      (Int.castRingHom ℝ)) ModularGroup.S)) (z : ℂ) = z := by
+  rw [denom_SL]; simp [ModularGroup.coe_S]
+
+lemma denom_T_zpow (n : ℤ) (z : ℍ) :
+    UpperHalfPlane.denom (Matrix.SpecialLinearGroup.toGL ((Matrix.SpecialLinearGroup.map
+      (Int.castRingHom ℝ)) (ModularGroup.T ^ n))) (z : ℂ) = 1 := by
+  rw [denom_SL]; simp [ModularGroup.coe_T_zpow]
+
+lemma coe_T_zpow_smul (n : ℤ) (z : ℍ) : ((ModularGroup.T ^ n • z : ℍ) : ℂ) = (z : ℂ) + n := by
+  rw [UpperHalfPlane.modular_T_zpow_smul, UpperHalfPlane.coe_vadd]; push_cast; ring
+
+lemma F_slash_S (a' b' c' : ℕ) :
+    (F (2 * a') (2 * b') (2 * c')) ∣[((a' + b' + c' : ℕ) : ℤ)] ModularGroup.S =
+      fun z : ℍ => CS a' b' c' * Gc (2 * a') (2 * b') (2 * c') z := by
+  ext z
+  rw [ModularForm.SL_slash_apply, denom_S, F, coe_S_smul, Fc_neg_inv _ _ _ _ z.im_pos, zpow_neg,
+    zpow_natCast]
+  have hz : (z : ℂ) ^ (a' + b' + c') ≠ 0 := pow_ne_zero _ z.ne_zero
+  field_simp
+
+lemma F_slash_S_slash_T (a' b' c' : ℕ) (h₂ : 24 ∣ 4 * (2 * a') + 2 * (2 * b') + 2 * c') :
+    ((F (2 * a') (2 * b') (2 * c')) ∣[((a' + b' + c' : ℕ) : ℤ)] ModularGroup.S) ∣[((a' + b' + c' :
+      ℕ) : ℤ)]
+      (ModularGroup.T ^ (-4 : ℤ)) =
+      (F (2 * a') (2 * b') (2 * c')) ∣[((a' + b' + c' : ℕ) : ℤ)] ModularGroup.S := by
+  rw [F_slash_S]
+  ext z
+  rw [ModularForm.SL_slash_apply, denom_T_zpow, one_zpow, mul_one, coe_T_zpow_smul]
+  rw [Gc_sub_four _ _ _ h₂]
+
+end EtaGamma0Four
+
+section gen
+open Matrix.SpecialLinearGroup ModularGroup
+
+namespace EtaGamma0Four
+
+def R : SL(2, ℤ) := ⟨!![1, 0; 4, 1], by norm_num [Matrix.det_fin_two_of]⟩
+
+@[scoped simp] lemma coe_R : (R : Matrix (Fin 2) (Fin 2) ℤ) = !![1, 0; 4, 1] := rfl
+
+def H : Subgroup SL(2, ℤ) := Subgroup.closure {ModularGroup.T, R, -1}
+
+lemma T_mem : ModularGroup.T ∈ H := Subgroup.subset_closure (by simp)
+lemma R_mem : R ∈ H := Subgroup.subset_closure (by simp)
+lemma neg_one_mem : (-1 : SL(2, ℤ)) ∈ H := Subgroup.subset_closure (by simp)
+
+lemma coe_R_zpow (n : ℤ) :
+    ((R ^ n : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) = !![1, 0; 4 * n, 1] := by
+  induction n using Int.induction_on with
+  | zero => simp [Matrix.one_fin_two]
+  | succ n ih =>
+    rw [zpow_add_one, Matrix.SpecialLinearGroup.coe_mul, ih, coe_R]
+    ext i j; fin_cases i <;> fin_cases j <;> simp [Matrix.mul_apply, Fin.sum_univ_two] ; ring
+  | pred n ih =>
+    rw [zpow_sub_one, Matrix.SpecialLinearGroup.coe_mul, ih, Matrix.SpecialLinearGroup.coe_inv,
+      coe_R]
+    ext i j; fin_cases i <;> fin_cases j <;>
+      simp [Matrix.mul_apply, Fin.sum_univ_two, Matrix.adjugate_fin_two_of] ; ring
+
+lemma mul_T_zpow_apply (A : SL(2, ℤ)) (n : ℤ) :
+    (A * ModularGroup.T ^ n) 1 0 = A 1 0 ∧ (A * ModularGroup.T ^ n) 1 1 = A 1 0 * n + A 1 1 ∧
+    (A * ModularGroup.T ^ n) 0 0 = A 0 0 ∧ (A * ModularGroup.T ^ n) 0 1 = A 0 0 * n + A 0 1 := by
+  refine ⟨?_, ?_, ?_, ?_⟩ <;>
+  · change ((A : Matrix (Fin 2) (Fin 2) ℤ) * ((ModularGroup.T ^ n : SL(2,ℤ)) : Matrix (Fin 2) (Fin
+      2) ℤ)) _ _ = _
+    rw [ModularGroup.coe_T_zpow]
+    simp [Matrix.mul_apply, Fin.sum_univ_two]
+
+lemma mul_R_zpow_apply (A : SL(2, ℤ)) (n : ℤ) :
+    (A * R ^ n) 1 0 = A 1 0 + A 1 1 * (4 * n) ∧ (A * R ^ n) 1 1 = A 1 1 ∧
+    (A * R ^ n) 0 0 = A 0 0 + A 0 1 * (4 * n) ∧ (A * R ^ n) 0 1 = A 0 1 := by
+  refine ⟨?_, ?_, ?_, ?_⟩ <;>
+  · change ((A : Matrix (Fin 2) (Fin 2) ℤ) * ((R ^ n : SL(2,ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)) _ _ = _
+    rw [coe_R_zpow]
+    simp [Matrix.mul_apply, Fin.sum_univ_two]
+
+lemma det_eq (A : SL(2, ℤ)) : A 0 0 * A 1 1 - A 0 1 * A 1 0 = 1 := by
+  have := A.det_coe
+  rw [Matrix.det_fin_two] at this
+  exact this
+
+lemma mem_H_of_apply_one_zero_eq_zero (A : SL(2, ℤ)) (h : A 1 0 = 0) : A ∈ H := by
+  have hdet := det_eq A
+  rw [h, mul_zero, sub_zero] at hdet
+  rcases Int.eq_one_or_neg_one_of_mul_eq_one hdet with h00 | h00
+  · have h11 : A 1 1 = 1 := by rw [h00, one_mul] at hdet; exact hdet
+    have : A = ModularGroup.T ^ (A 0 1) := by
+      ext i j
+      rw [ModularGroup.coe_T_zpow]
+      fin_cases i <;> fin_cases j <;> simp [h, h00, h11]
+    rw [this]
+    exact Subgroup.zpow_mem _ T_mem _
+  · have h11 : A 1 1 = -1 := by rw [h00] at hdet; linarith
+    have : A = -1 * ModularGroup.T ^ (-(A 0 1)) := by
+      ext i j
+      rw [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_T_zpow]
+      fin_cases i <;> fin_cases j <;> simp [h, h00, h11]
+    rw [this]
+    exact Subgroup.mul_mem _ neg_one_mem (Subgroup.zpow_mem _ T_mem _)
+
+lemma mem_H_of_four_dvd :
+    ∀ (n : ℕ) (A : SL(2, ℤ)), (A 1 0).natAbs = n → (4 : ℤ) ∣ A 1 0 → A ∈ H := by
+  intro n
+  induction n using Nat.strong_induction_on with
+  | _ n ih =>
+  intro A hn h4
+  by_cases hc : A 1 0 = 0
+  · exact mem_H_of_apply_one_zero_eq_zero A hc
+  set c := A 1 0 with hc_def
+  set d := A 1 1 with hd_def
+  have hdet := det_eq A
+  have hd2 : ¬ (2 : ℤ) ∣ d := by
+    intro hd
+    have : (2 : ℤ) ∣ A 0 0 * A 1 1 - A 0 1 * A 1 0 :=
+      dvd_sub (dvd_mul_of_dvd_right hd _) (dvd_mul_of_dvd_right ((by
+        norm_num : (2:ℤ) ∣ 4).trans h4) _)
+    rw [hdet] at this
+    norm_num at this
+  have hm0 : 0 < c.natAbs := Int.natAbs_pos.mpr hc
+  have hmc : ((c.natAbs : ℕ) : ℤ) = |c| := Int.natCast_natAbs c
+  set d₁ : ℤ := Int.bmod d c.natAbs with hd₁
+  have hd₁_eq : d₁ = d - (c.natAbs : ℤ) * Int.bdiv d c.natAbs := by
+    have := Int.bdiv_add_bmod d c.natAbs
+    rw [hd₁]; linarith
+  have hd₁_lb : -(((c.natAbs : ℕ) : ℤ) / 2) ≤ d₁ := Int.le_bmod hm0
+  have hd₁_ub : d₁ < (((c.natAbs : ℕ) : ℤ) + 1) / 2 := Int.bmod_lt hm0
+  obtain ⟨n₁, hn₁⟩ : ∃ n₁ : ℤ, c * n₁ = -((c.natAbs : ℤ) * Int.bdiv d c.natAbs) := by
+    rw [hmc]
+    rcases abs_cases c with ⟨h, -⟩ | ⟨h, -⟩ <;> rw [h]
+    exacts [⟨-(Int.bdiv d c.natAbs), by ring⟩, ⟨Int.bdiv d c.natAbs, by ring⟩]
+  set A₁ := A * ModularGroup.T ^ n₁ with hA₁
+  obtain ⟨hA₁c, hA₁d, -, -⟩ := mul_T_zpow_apply A n₁
+  have hA₁d' : A₁ 1 1 = d₁ := by rw [hA₁d, hd₁_eq, ← hc_def, ← hd_def, hn₁]; ring
+  have hm4 : (4 : ℤ) ∣ ((c.natAbs : ℕ) : ℤ) := Int.dvd_natAbs.mpr h4
+  have hd₁2 : ¬ (2 : ℤ) ∣ d₁ := by
+    intro h2
+    apply hd2
+    have : (2 : ℤ) ∣ ((c.natAbs : ℕ) : ℤ) * Int.bdiv d c.natAbs :=
+      dvd_mul_of_dvd_left ((by norm_num : (2:ℤ) ∣ 4).trans hm4) _
+    have := dvd_add h2 this
+    rwa [hd₁_eq, sub_add_cancel] at this
+  have hd₁0 : d₁ ≠ 0 := by rintro h0; exact hd₁2 (h0 ▸ dvd_zero 2)
+  have hm'0 : 0 < (4 * d₁).natAbs := Int.natAbs_pos.mpr (by positivity)
+  have hmm' : (((4 * d₁).natAbs : ℕ) : ℤ) = 4 * |d₁| :=
+    by rw [Int.natCast_natAbs, abs_mul]; norm_num
+  set c' : ℤ := Int.bmod c (4 * d₁).natAbs with hc'
+  have hc'_eq : c' = c - (((4 * d₁).natAbs : ℕ) : ℤ) * Int.bdiv c (4 * d₁).natAbs := by
+    have := Int.bdiv_add_bmod c (4 * d₁).natAbs
+    rw [hc']; linarith
+  have hc'_lb : -((((4 * d₁).natAbs : ℕ) : ℤ) / 2) ≤ c' := Int.le_bmod hm'0
+  have hc'_ub : c' < ((((4 * d₁).natAbs : ℕ) : ℤ) + 1) / 2 := Int.bmod_lt hm'0
+  obtain ⟨n₂, hn₂⟩ : ∃ n₂ : ℤ, d₁ * (4 * n₂) = -((((4 * d₁).natAbs : ℕ) : ℤ) * Int.bdiv c (4 *
+    d₁).natAbs) :=
+    by
+    rw [hmm']
+    rcases abs_cases d₁ with ⟨h, -⟩ | ⟨h, -⟩ <;> rw [h]
+    exacts [⟨-(Int.bdiv c (4 * d₁).natAbs), by ring⟩, ⟨Int.bdiv c (4 * d₁).natAbs, by ring⟩]
+  set A₂ := A₁ * R ^ n₂ with hA₂
+  obtain ⟨hA₂c, hA₂d, -, -⟩ := mul_R_zpow_apply A₁ n₂
+  have hA₂c' : A₂ 1 0 = c' := by rw [hA₂c, hA₁c, hA₁d', ← hc_def, hn₂, hc'_eq]; ring
+  have h4c' : (4 : ℤ) ∣ c' := by
+    rw [hc'_eq]
+    exact dvd_sub h4 (dvd_mul_of_dvd_left (Int.dvd_natAbs.mpr (dvd_mul_right 4 d₁)) _)
+  have hd₁odd : d₁ % 2 = 1 := Int.two_dvd_ne_zero.mp hd₁2
+  have hlt : c'.natAbs < n := by
+    rw [← hn]
+    zify
+    rw [hmc] at hm4 hd₁_lb hd₁_ub
+    rw [hmm'] at hc'_lb hc'_ub
+    rcases abs_cases c with ⟨habs, _⟩ | ⟨habs, _⟩ <;> rcases abs_cases d₁ with ⟨habs₁, _⟩ | ⟨habs₁,
+      _⟩ <;>
+      rcases abs_cases c' with ⟨habs', _⟩ | ⟨habs', _⟩ <;> omega
+  have hA₂H : A₂ ∈ H := ih _ hlt A₂ (by rw [hA₂c']) (by rw [hA₂c']; exact h4c')
+  have : A = A₂ * R ^ (-n₂) * ModularGroup.T ^ (-n₁) := by
+    rw [hA₂, hA₁]; group
+  rw [this]
+  exact Subgroup.mul_mem _ (Subgroup.mul_mem _ hA₂H (Subgroup.zpow_mem _ R_mem _))
+    (Subgroup.zpow_mem _ T_mem _)
+
+theorem Gamma0_four_le_H : CongruenceSubgroup.Gamma0 4 ≤ H := by
+  intro A hA
+  have h4 : (4 : ℤ) ∣ A 1 0 :=
+    (ZMod.intCast_zmod_eq_zero_iff_dvd _ 4).mp (CongruenceSubgroup.Gamma0_mem.mp hA)
+  exact mem_H_of_four_dvd _ A rfl h4
+
+end EtaGamma0Four
+end gen
+
+namespace EtaGamma0Four
+
+open scoped MatrixGroups ModularForm Real UpperHalfPlane
+open ModularGroup Complex
+open ModularForm (eta)
+
+lemma coe_T_smul (z : ℍ) : ((ModularGroup.T • z : ℍ) : ℂ) = (z : ℂ) + 1 := by
+  rw [UpperHalfPlane.modular_T_smul, UpperHalfPlane.coe_vadd]; push_cast; ring
+
+lemma denom_T (z : ℍ) :
+    UpperHalfPlane.denom (Matrix.SpecialLinearGroup.toGL ((Matrix.SpecialLinearGroup.map
+      (Int.castRingHom ℝ)) ModularGroup.T)) (z : ℂ) = 1 := by
+  rw [denom_SL]; simp [ModularGroup.coe_T]
+
+lemma F_slash_T (a b c : ℕ) (k : ℤ) (h₁ : 24 ∣ a + 2 * b + 4 * c) :
+    (F a b c) ∣[k] ModularGroup.T = F a b c := by
+  ext z
+  rw [ModularForm.SL_slash_apply, denom_T, one_zpow, mul_one, F, F, coe_T_smul, Fc_add_one _ _ _ h₁]
+
+lemma F_slash_neg_one (a b c : ℕ) (k : ℤ) (hk : Even k) :
+    (F a b c) ∣[k] (-1 : SL(2, ℤ)) = F a b c := by
+  ext z
+  rw [ModularForm.SL_slash_apply, denom_SL]
+  have h1 : ((-1 : SL(2, ℤ)) • z) = z := by
+    apply UpperHalfPlane.ext
+    rw [UpperHalfPlane.specialLinearGroup_apply]
+    simp [Matrix.SpecialLinearGroup.coe_neg]
+  have h10 : ((-1 : SL(2, ℤ)) 1 0 : ℤ) = 0 := by
+    simp [Matrix.SpecialLinearGroup.coe_neg]
+  have h11 : ((-1 : SL(2, ℤ)) 1 1 : ℤ) = -1 := by
+    simp [Matrix.SpecialLinearGroup.coe_neg]
+  rw [h1, h10, h11]
+  push_cast
+  rw [zero_mul, zero_add, (Even.neg hk).neg_one_zpow, mul_one]
+
+lemma F_slash_R (a' b' c' : ℕ) (h₂ : 24 ∣ 4 * (2 * a') + 2 * (2 * b') + 2 * c') :
+    (F (2 * a') (2 * b') (2 * c')) ∣[((a' + b' + c' : ℕ) : ℤ)] R = F (2 * a') (2 * b') (2 * c') :=
+      by
+  have hR : R = ModularGroup.S * ModularGroup.T ^ (-4 : ℤ) * ModularGroup.S⁻¹ := by
+    ext i j
+    rw [Matrix.SpecialLinearGroup.coe_mul, Matrix.SpecialLinearGroup.coe_mul,
+      Matrix.SpecialLinearGroup.coe_inv,
+      ModularGroup.coe_T_zpow, ModularGroup.coe_S, coe_R]
+    fin_cases i <;> fin_cases j <;> simp [Matrix.mul_apply, Fin.sum_univ_two,
+      Matrix.adjugate_fin_two_of]
+  rw [hR, SlashAction.slash_mul, SlashAction.slash_mul, F_slash_S_slash_T _ _ _ h₂, ←
+    SlashAction.slash_mul,
+    mul_inv_cancel, SlashAction.slash_one]
+
+def genGL :
+    Set (GL (Fin 2) ℝ) := (Matrix.SpecialLinearGroup.mapGL ℝ : SL(2, ℤ) →* GL (Fin 2) ℝ) ''
+      {ModularGroup.T, R, -1}
+
+lemma map_H : H.map (Matrix.SpecialLinearGroup.mapGL ℝ) = Subgroup.closure genGL := by
+  rw [H, MonoidHom.map_closure]; rfl
+
+lemma slash_eq_of_generators {f : ℍ → ℂ} {k : ℤ} (hT : f ∣[k] ModularGroup.T = f)
+    (hR : f ∣[k] R = f)
+    (hN : f ∣[k] (-1 : SL(2, ℤ)) = f) :
+    ∀ γ ∈ ((CongruenceSubgroup.Gamma0 4 : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)), f ∣[k] γ =
+      f := by
+  have hgen : ∀ γ ∈ Subgroup.closure genGL, f ∣[k] γ = f := by
+    rw [SlashInvariantForm.slash_action_generators (rfl : Subgroup.closure genGL = Subgroup.closure
+      genGL)]
+    rintro _ ⟨g, hg, rfl⟩
+    simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hg
+    rcases hg with rfl | rfl | rfl
+    · exact hT
+    · exact hR
+    · exact hN
+  rintro _ ⟨A, hA, rfl⟩
+  apply hgen
+  rw [← map_H]
+  exact Subgroup.mem_map_of_mem _ (Gamma0_four_le_H hA)
+
+lemma F_mdifferentiable (a b c : ℕ) :
+    MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) (F a b c) := by
+  rw [UpperHalfPlane.mdifferentiable_iff]
+  have hFc : DifferentiableOn ℂ (Fc a b c) {z : ℂ | 0 < z.im} := by
+    intro z hz
+    apply DifferentiableAt.differentiableWithinAt
+    have hz' : 0 < z.im := hz
+    have h2 : 0 < (2 * z).im := by
+      simp only [mul_im, re_ofNat, im_ofNat, zero_mul, add_zero, Nat.ofNat_pos,
+        mul_pos_iff_of_pos_left]; positivity
+    have h4 : 0 < (4 * z).im := by
+      simp only [mul_im, re_ofNat, im_ofNat, zero_mul, add_zero, Nat.ofNat_pos,
+        mul_pos_iff_of_pos_left]; positivity
+    unfold Fc
+    refine ((ModularForm.differentiableAt_eta_of_mem_upperHalfPlaneSet hz').pow _ |>.mul
+      (((ModularForm.differentiableAt_eta_of_mem_upperHalfPlaneSet h2).comp z
+        (differentiableAt_id.const_mul _)).pow _)).mul
+      (((ModularForm.differentiableAt_eta_of_mem_upperHalfPlaneSet h4).comp z
+        (differentiableAt_id.const_mul _)).pow _)
+  refine hFc.congr fun z hz => ?_
+  have hz' : 0 < z.im := hz
+  simp [F, Function.comp, UpperHalfPlane.ofComplex_apply_of_im_pos hz']
+
+end EtaGamma0Four
+
+namespace EtaGamma0Four
+
+open scoped MatrixGroups ModularForm Real UpperHalfPlane
+open Complex
+open ModularForm (eta)
+
+lemma Gamma0_le {N M : ℕ} (h : N ∣ M) :
+    CongruenceSubgroup.Gamma0 M ≤ CongruenceSubgroup.Gamma0 N := by
+  intro A hA
+  rw [CongruenceSubgroup.Gamma0_mem] at hA ⊢
+  rw [ZMod.intCast_zmod_eq_zero_iff_dvd] at hA ⊢
+  exact (Int.natCast_dvd_natCast.mpr h).trans hA
+
+lemma GammaGL_le {N M : ℕ} (h : N ∣ M) :
+    ((CongruenceSubgroup.Gamma0 M : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) ≤
+      ((CongruenceSubgroup.Gamma0 N : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) :=
+  Subgroup.map_mono (Gamma0_le h)
+
+lemma isBoundedAtImInfty_pow {f : ℍ → ℂ} (hf : UpperHalfPlane.IsBoundedAtImInfty f) :
+    ∀ n : ℕ, UpperHalfPlane.IsBoundedAtImInfty (f ^ n)
+  | 0 => by rw [pow_zero]; exact Filter.const_boundedAtFilter _ _
+  | n + 1 => by rw [pow_succ]; exact Filter.BoundedAtFilter.mul (isBoundedAtImInfty_pow hf n) hf
+
+lemma isZeroAtImInfty_pow {f : ℍ → ℂ} (hf : UpperHalfPlane.IsZeroAtImInfty f) {n : ℕ} (hn : 0 < n) :
+    UpperHalfPlane.IsZeroAtImInfty (f ^ n) := by
+  obtain ⟨m, rfl⟩ := Nat.exists_eq_add_of_lt hn
+  rw [pow_succ]
+  exact Filter.BoundedAtFilter.mul_zeroAtFilter
+    (isBoundedAtImInfty_pow (Filter.ZeroAtFilter.boundedAtFilter hf) _) hf
+
+lemma isZeroAtImInfty_of_pow {f : ℍ → ℂ} {n : ℕ} (hn : 0 < n)
+    (h : UpperHalfPlane.IsZeroAtImInfty (f ^ n)) : UpperHalfPlane.IsZeroAtImInfty f := by
+  rw [UpperHalfPlane.isZeroAtImInfty_iff] at h ⊢
+  intro ε hε
+  obtain ⟨A, hA⟩ := h (ε ^ n) (pow_pos hε n)
+  refine ⟨A, fun z hz => ?_⟩
+  have := hA z hz
+  rw [Pi.pow_apply, norm_pow] at this
+  exact (pow_le_pow_iff_left₀ (norm_nonneg _) hε.le hn.ne').mp this
+
+lemma isZeroAtImInfty_triple {f₁ f₂ f₄ : ℍ → ℂ} (h₁ : UpperHalfPlane.IsZeroAtImInfty f₁)
+    (h₂ : UpperHalfPlane.IsZeroAtImInfty f₂) (h₄ : UpperHalfPlane.IsZeroAtImInfty f₄)
+    {α β γ : ℕ} (hE : 0 < α + β + γ) :
+    UpperHalfPlane.IsZeroAtImInfty (f₁ ^ α * f₂ ^ β * f₄ ^ γ) := by
+  have b₁ := isBoundedAtImInfty_pow (Filter.ZeroAtFilter.boundedAtFilter h₁) α
+  have b₂ := isBoundedAtImInfty_pow (Filter.ZeroAtFilter.boundedAtFilter h₂) β
+  have b₄ := isBoundedAtImInfty_pow (Filter.ZeroAtFilter.boundedAtFilter h₄) γ
+  rcases Nat.eq_zero_or_pos α with hα | hα
+  · rcases Nat.eq_zero_or_pos β with hβ | hβ
+    · have hγ : 0 < γ := by omega
+      exact Filter.BoundedAtFilter.mul_zeroAtFilter (Filter.BoundedAtFilter.mul b₁ b₂)
+        (isZeroAtImInfty_pow h₄ hγ)
+    · exact Filter.ZeroAtFilter.mul_boundedAtFilter
+        (Filter.BoundedAtFilter.mul_zeroAtFilter b₁ (isZeroAtImInfty_pow h₂ hβ)) b₄
+  · exact Filter.ZeroAtFilter.mul_boundedAtFilter
+      (Filter.ZeroAtFilter.mul_boundedAtFilter (isZeroAtImInfty_pow h₁ hα) b₂) b₄
+
+lemma F_isZeroAt (α β γ : ℕ) (hE : 0 < α + β + γ)
+    (g₁ : CuspForm (CongruenceSubgroup.Gamma0 1) 12) (hg₁ : ∀ τ : ℍ, g₁ τ = η (1 * (τ : ℂ)) ^ 24)
+    (g₂ : CuspForm (CongruenceSubgroup.Gamma0 2) 12) (hg₂ : ∀ τ : ℍ, g₂ τ = η (2 * (τ : ℂ)) ^ 24)
+    (g₄ : CuspForm (CongruenceSubgroup.Gamma0 4) 12) (hg₄ : ∀ τ : ℍ, g₄ τ = η (4 * (τ : ℂ)) ^ 24)
+    {c : OnePoint ℝ}
+    (hc : IsCusp c ((CongruenceSubgroup.Gamma0 4 : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ))) :
+    c.IsZeroAt (F (4 * α) (4 * β) (4 * γ)) ((2 * (α + β + γ) : ℕ) : ℤ) := by
+  intro g hg
+  have hz₁ : UpperHalfPlane.IsZeroAtImInfty ((⇑g₁) ∣[(12 : ℤ)] g) := by
+    have := g₁.zero_at_cusps' (hc.mono (GammaGL_le (one_dvd 4))) g hg
+    simpa using this
+  have hz₂ : UpperHalfPlane.IsZeroAtImInfty ((⇑g₂) ∣[(12 : ℤ)] g) := by
+    have := g₂.zero_at_cusps' (hc.mono (GammaGL_le (by norm_num : 2 ∣ 4))) g hg
+    simpa using this
+  have hz₄ : UpperHalfPlane.IsZeroAtImInfty ((⇑g₄) ∣[(12 : ℤ)] g) := by
+    have := g₄.zero_at_cusps' hc g hg
+    simpa using this
+  set E := α + β + γ with hEdef
+  set Dt : ℂ := ((|((Matrix.GeneralLinearGroup.det g : ℝˣ) : ℝ)| : ℝ) : ℂ) with hDt
+  have hD : Dt ≠ 0 := by
+    rw [hDt]; exact_mod_cast abs_ne_zero.mpr (Matrix.GeneralLinearGroup.det g).ne_zero
+  have key : ∀ τ : ℍ, ((F (4 * α) (4 * β) (4 * γ)) ∣[((2 * E : ℕ) : ℤ)] g) τ ^ 6 * Dt ^ 6 =
+      (((⇑g₁) ∣[(12 : ℤ)] g) τ) ^ α * (((⇑g₂) ∣[(12 : ℤ)] g) τ) ^ β * (((⇑g₄) ∣[(12 : ℤ)] g) τ) ^ γ
+        * Dt ^ E := by
+    intro τ
+    simp only [ModularForm.slash_def]
+    rw [hg₁, hg₂, hg₄]
+    have hd : UpperHalfPlane.denom g τ ≠ 0 := UpperHalfPlane.denom_ne_zero g τ
+    have hF : UpperHalfPlane.σ g (F (4 * α) (4 * β) (4 * γ) (g • τ)) ^ 6 =
+        UpperHalfPlane.σ g (η (1 * ((g • τ : ℍ) : ℂ)) ^ 24) ^ α * UpperHalfPlane.σ g (η (2 * ((g • τ
+          : ℍ) : ℂ)) ^ 24) ^ β *
+          UpperHalfPlane.σ g (η (4 * ((g • τ : ℍ) : ℂ)) ^ 24) ^ γ := by
+      rw [← map_pow, ← map_pow, ← map_pow, ← map_pow, ← map_mul, ← map_mul]
+      congr 1
+      simp only [F, Fc, one_mul]
+      ring
+    rw [show ((2 * E : ℕ) : ℤ) - 1 = ((2 * E : ℕ) : ℤ) + (-1) by
+      ring, zpow_add₀ hD, zpow_natCast, zpow_neg_one,
+      zpow_neg, zpow_natCast, show (12 : ℤ) - 1 = 11 by norm_num, zpow_ofNat, zpow_neg, zpow_ofNat]
+    rw [← hDt]
+    set d := UpperHalfPlane.denom g τ
+    set X := UpperHalfPlane.σ g (F (4 * α) (4 * β) (4 * γ) (g • τ))
+    set s₁ := UpperHalfPlane.σ g (η (1 * ((g • τ : ℍ) : ℂ)) ^ 24)
+    set s₂ := UpperHalfPlane.σ g (η (2 * ((g • τ : ℍ) : ℂ)) ^ 24)
+    set s₄ := UpperHalfPlane.σ g (η (4 * ((g • τ : ℍ) : ℂ)) ^ 24)
+    have hX : (X * (Dt ^ (2 * E) * Dt⁻¹) * (d ^ (2 * E))⁻¹) ^ 6 * Dt ^ 6 = X ^ 6 * Dt ^ (12 * E) *
+      (d ^ (12 * E))⁻¹ :=
+      by
+      field_simp
+      ring
+    rw [hX, hF, hEdef]
+    simp only [← inv_pow]
+    ring
+  have h6 : UpperHalfPlane.IsZeroAtImInfty (((F (4 * α) (4 * β) (4 * γ)) ∣[((2 * E : ℕ) : ℤ)] g) ^
+    6) :=
+    by
+    have hfun : ((F (4 * α) (4 * β) (4 * γ)) ∣[((2 * E : ℕ) : ℤ)] g) ^ 6 = fun τ =>
+        ((((⇑g₁) ∣[(12 : ℤ)] g) ^ α * ((⇑g₂) ∣[(12 : ℤ)] g) ^ β * ((⇑g₄) ∣[(12 : ℤ)] g) ^ γ) τ) *
+          (Dt ^ E * (Dt ^ 6)⁻¹) := by
+      funext τ
+      have := key τ
+      simp only [Pi.pow_apply, Pi.mul_apply]
+      field_simp
+      linear_combination this
+    rw [hfun]
+    have := (isZeroAtImInfty_triple hz₁ hz₂ hz₄ hE).mul_const (Dt ^ E * (Dt ^ 6)⁻¹)
+    simp only [Pi.mul_apply, Pi.pow_apply, zero_mul] at this
+    exact this
+  exact isZeroAtImInfty_of_pow (by norm_num) h6
+
+end EtaGamma0Four
+
+open scoped MatrixGroups in
+open EtaGamma0Four in
+theorem solution (a b c : ℕ) (h0 : 0 < a + b + c)
+    (h₁ : 24 ∣ a + 2 * b + 4 * c) (h₂ : 24 ∣ 4 * a + 2 * b + c) (hb : Even b) (h4 : 4 ∣ a + b + c) :
+    ∃ f : CuspForm (CongruenceSubgroup.Gamma0 4) (((a + b + c) / 2 : ℕ) : ℤ),
+      ∀ z : UpperHalfPlane, f z = ModularForm.eta (z : ℂ) ^ a * ModularForm.eta (2 * (z : ℂ)) ^ b *
+        ModularForm.eta (4 * (z : ℂ)) ^ c := by
+  have hb' : b % 2 = 0 := Nat.even_iff.mp hb
+  obtain ⟨α, rfl⟩ : 4 ∣ a := by omega
+  obtain ⟨β, rfl⟩ : 4 ∣ b := by omega
+  obtain ⟨γ, rfl⟩ : 4 ∣ c := by omega
+  have hE : 0 < α + β + γ := by omega
+  have hk : (4 * α + 4 * β + 4 * γ) / 2 = 2 * α + 2 * β + 2 * γ := by omega
+  rw [hk]
+  have e1 : 4 * α = 2 * (2 * α) := by ring
+  have e2 : 4 * β = 2 * (2 * β) := by ring
+  have e3 : 4 * γ = 2 * (2 * γ) := by ring
+  obtain ⟨g₁, hg₁⟩ := CuspForm.exists_gamma0_apply_eq_eta_mul_pow_twentyfour 1
+  obtain ⟨g₂, hg₂⟩ := CuspForm.exists_gamma0_apply_eq_eta_mul_pow_twentyfour 2
+  obtain ⟨g₄, hg₄⟩ := CuspForm.exists_gamma0_apply_eq_eta_mul_pow_twentyfour 4
+  push_cast at hg₁ hg₂ hg₄
+  have hslash : ∀ γ' ∈ ((CongruenceSubgroup.Gamma0 4 : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2)
+    ℝ)),
+      (F (2 * (2 * α)) (2 * (2 * β)) (2 * (2 * γ))) ∣[((2 * α + 2 * β + 2 * γ : ℕ) : ℤ)] γ' =
+        F (2 * (2 * α)) (2 * (2 * β)) (2 * (2 * γ)) := by
+    refine slash_eq_of_generators (F_slash_T _ _ _ _ (by omega)) (F_slash_R _ _ _ (by omega))
+      (F_slash_neg_one _ _ _ _ ?_)
+    exact ⟨α + β + γ, by push_cast; ring⟩
+  refine ⟨{ toFun := F (2 * (2 * α)) (2 * (2 * β)) (2 * (2 * γ))
+            slash_action_eq' := hslash
+            holo' := F_mdifferentiable _ _ _
+            zero_at_cusps' := ?_ }, fun z => ?_⟩
+  · intro c hc
+    have := F_isZeroAt α β γ hE g₁ (by simpa using hg₁) g₂ hg₂ g₄ hg₄ hc
+    rw [← e1, ← e2, ← e3]
+    convert this using 2
+    ring
+  · change F (2 * (2 * α)) (2 * (2 * β)) (2 * (2 * γ)) z = _
+    rw [← e1, ← e2, ← e3]
+    rfl
+
+end
+end S_CuspForm_exists_gamma0_four_apply_eq_eta_pow_mul
+end P2MW
+export P2MW.S_CuspForm_exists_gamma0_four_apply_eq_eta_pow_mul (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem CuspForm.exists_gamma0_four_apply_eq_eta_pow_mul (a b c : ℕ) (h0 : 0 < a + b + c)
+    (h₁ : 24 ∣ a + 2 * b + 4 * c) (h₂ : 24 ∣ 4 * a + 2 * b + c) (hb : Even b) (h4 : 4 ∣ a + b + c) :
+    ∃ f : CuspForm (CongruenceSubgroup.Gamma0 4) (((a + b + c) / 2 : ℕ) : ℤ),
+      ∀ z : UpperHalfPlane, f z = ModularForm.eta (z : ℂ) ^ a * ModularForm.eta (2 * (z : ℂ)) ^ b *
+        ModularForm.eta (4 * (z : ℂ)) ^ c :=
+  solution a b c h0 h₁ h₂ hb h4
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_finiteDimensional_Gamma0.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_finiteDimensional_Gamma0.lean
new file mode 100644
index 0000000000..8f396d19c3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_finiteDimensional_Gamma0.lean
@@ -0,0 +1,86 @@
+/-
+Based on Prove2Me node CuspForm.finiteDimensional_Gamma0
+(d4990a57-82fa-5677-bf03-0541b34d4fe3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission da0e1191-2dc8-5a4c-a9d4-b0a6c991427c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_finiteDimensional_of_isArithmetic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finite-dimensionality of S_k(Γ₀(N))
+
+Theorem statement: `CuspForm.finiteDimensional_Gamma0` (`d4990a57-82fa-5677-bf03-0541b34d4fe3`), by
+Claude, 2026-09-05.
+
+Proof: submission `da0e1191-2dc8-5a4c-a9d4-b0a6c991427c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number that is nonzero, and let $k$ be an arbitrary integer (no positivity or
+parity restriction is imposed; for $k$ in the ranges where the space vanishes the assertion is
+vacuous). Consider the congruence subgroup $\Gamma_0(N)$, consisting of the determinant-one integral
+$2\times 2$ matrices whose lower-left entry is divisible by $N$, regarded as a group of real
+$2\times 2$ matrices, and the complex vector space $\mathrm{CuspForm}\,(\Gamma_0(N))\,k =
+S_k(\Gamma_0(N))$ of weight-$k$ cusp forms for it: holomorphic functions on the upper half-plane
+which are invariant under the weight-$k$ slash action of $\Gamma_0(N)$ and which vanish at the
+cusps, in the sense that every translate under the relevant group elements tends to $0$ as the
+imaginary part tends to infinity. The assertion is that this space is finite-dimensional as a vector
+space over $\mathbb{C}$.
+
+This is the classical finite-dimensionality of the space of cusp forms of weight $k$ and level $N$,
+specialised to the group $\Gamma_0(N)$ in which the modularity statements of the argument are
+phrased (notably $S_2(\Gamma_0(N))$ and its normalised Hecke eigenforms). It is invoked throughout
+the newform and Hecke-algebra part of the development, for instance in the construction of bases
+attached to the cohomological realisation of modular forms and in the characterisation of newforms
+by their Hecke eigenvalues.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_CuspForm_finiteDimensional_Gamma0.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_CuspForm_finiteDimensional_Gamma0
+
+open UpperHalfPlane ModularForm SlashInvariantForm Matrix.SpecialLinearGroup ConjAct
+open scoped MatrixGroups ModularForm Topology Manifold Pointwise
+
+noncomputable section
+
+theorem solution (N : ℕ) [NeZero N] (k : ℤ) :
+    FiniteDimensional ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) k) := by
+  exact CuspForm.finiteDimensional_of_isArithmetic _ k
+end
+
+end S_CuspForm_finiteDimensional_Gamma0
+end P2MW
+export P2MW.S_CuspForm_finiteDimensional_Gamma0 (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane
+open scoped MatrixGroups
+theorem CuspForm.finiteDimensional_Gamma0 (N : ℕ) [NeZero N] (k : ℤ) :
+    FiniteDimensional ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) k) :=
+  solution N k
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_finiteDimensional_of_isArithmetic.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_finiteDimensional_of_isArithmetic.lean
new file mode 100644
index 0000000000..c1a6603676
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_finiteDimensional_of_isArithmetic.lean
@@ -0,0 +1,70 @@
+/-
+Based on Prove2Me node CuspForm.finiteDimensional_of_isArithmetic
+(3eaacdc5-f6ba-524f-b5f6-1207ebd87fc8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ada4bc9f-6bd1-5efa-bc1b-27ad499b21b8
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+
+import Mathlib.NumberTheory.ModularForms.CuspFormSubmodule
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_finiteDimensional_of_isArithmetic
+
+/-!
+# Finite-dimensionality of cusp forms for arithmetic G
+
+Theorem statement: `CuspForm.finiteDimensional_of_isArithmetic`
+(`3eaacdc5-f6ba-524f-b5f6-1207ebd87fc8`), by Claude, 2026-09-05.
+
+Proof: submission `ada4bc9f-6bd1-5efa-bc1b-27ad499b21b8`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\mathcal{G}$ be a subgroup of $\mathrm{GL}_2(\mathbb{R})$ which is arithmetic (the Mathlib
+predicate `Subgroup.IsArithmetic`) and all of whose elements have determinant one (the predicate
+`Subgroup.HasDetOne`, which is what provides the $\mathbb{C}$-module structure on the space of
+forms), and let $k$ be an arbitrary integer, with no positivity or parity restriction. Then the
+space `CuspForm 𝒢 k` of weight-$k$ cusp forms on $\mathcal{G}$, that is, of holomorphic functions on
+the upper half-plane satisfying the weight-$k$ slash invariance under $\mathcal{G}$ together with
+the cuspidal decay condition at the cusps, is a finite-dimensional complex vector space. No
+dimension formula, and no nonvanishing or vanishing statement for particular $k$, is asserted: the
+conclusion is exactly the `FiniteDimensional ℂ (CuspForm 𝒢 k)` instance.
+
+This is the classical finite-dimensionality theorem for spaces of cusp forms on an arithmetic group,
+in the form of a typeclass instance usable for arbitrary arithmetic $\mathcal{G}$ of determinant
+one. It is what makes the Hecke operators on cusp forms of level $\Gamma_0(N)$ a commuting family of
+endomorphisms of a finite-dimensional space, and is invoked throughout the treatment of eigenforms,
+of Eichler–Shimura cohomology and of the $q$-expansion arguments used in level changing.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_CuspForm_finiteDimensional_of_isArithmetic.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+theorem solution (𝒢 : Subgroup (GL (Fin 2) ℝ)) [𝒢.IsArithmetic] [𝒢.HasDetOne] (k : ℤ) :
+    FiniteDimensional ℂ (CuspForm 𝒢 k) := by
+  have := ModularForm.finiteDimensional_of_isArithmetic 𝒢 k
+  exact Module.Finite.of_injective CuspForm.toModularFormₗ CuspForm.toModularFormₗ_injective
+
+end privateSection
+
+public section publicSection
+
+open UpperHalfPlane
+open scoped MatrixGroups
+theorem CuspForm.finiteDimensional_of_isArithmetic (𝒢 : Subgroup (GL (Fin 2) ℝ)) [𝒢.IsArithmetic]
+    [𝒢.HasDetOne] (k : ℤ) :
+    FiniteDimensional ℂ (CuspForm 𝒢 k) :=
+  solution 𝒢 k
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_genusFormula_le_finrank_gamma0_weight_two.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_genusFormula_le_finrank_gamma0_weight_two.lean
new file mode 100644
index 0000000000..8bb0bdab33
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_genusFormula_le_finrank_gamma0_weight_two.lean
@@ -0,0 +1,253 @@
+/-
+Based on Prove2Me node CuspForm.genusFormula_le_finrank_gamma0_weight_two
+(5abf5b1f-1c20-5f08-aca1-04c7c391943e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 0ac98354-05c8-5929-8e62-aec697f33338
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finite_and_finrank_regularDifferentials_eq_genus
+import LeanPool.FLTEichlerShimura.Theorems.Thm_CongruenceSubgroup_one_mem_strictPeriods_Gamma0
+import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_finiteDimensional_Gamma0
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_diffQExpBar_injective_of_neZero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_essFiniteType_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_cuspForm_coeffMap_diffQExpBar_eq_qExpansion_of_mem_regularDifferentialsBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_genus_modularFunctionFieldBar_eq_genusFormula
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasCanonicalDivisor_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCurveOver_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Genus formula bounds dim_ℂ S₂(Γ₀(N)) from below
+
+Theorem statement: `CuspForm.genusFormula_le_finrank_gamma0_weight_two`
+(`5abf5b1f-1c20-5f08-aca1-04c7c391943e`), by Claude, 2026-09-05.
+
+Proof: submission `0ac98354-05c8-5929-8e62-aec697f33338`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+For every natural number $N \neq 0$, the rational number [`ModularCurve.genusFormula
+N`](def/ModularCurve_GenusNumerics.html#L20) is at most the complex dimension of the space of
+weight-two cusp forms for $\Gamma_0(N)$, the latter being the rank `Module.finrank ℂ (CuspForm
+(CongruenceSubgroup.Gamma0 N) 2)` viewed as a rational number. Here [`ModularCurve.genusFormula
+N`](def/ModularCurve_GenusNumerics.html#L20) is the explicit rational combination $$1 +
+\frac{\psi(N)}{12} - \frac{\nu_2(N)}{4} - \frac{\nu_3(N)}{3} - \frac{\nu_\infty(N)}{2},$$ in which
+$\psi(N)$ is `dedekindPsi N`, defined as the sum of $N/d$ over the squarefree divisors $d$ of $N$;
+$\nu_2(N)$ is `nuTwo N`, the number of elements $x$ of $\mathbb{Z}/N\mathbb{Z}$ with $x^2 + 1 = 0$;
+$\nu_3(N)$ is `nuThree N`, the number of elements $x$ of $\mathbb{Z}/N\mathbb{Z}$ with $x^2 + x + 1
+= 0$; and $\nu_\infty(N)$ is `cuspCount N`, the sum of $\varphi(\gcd(d, N/d))$ over the divisors $d$
+of $N$. Thus the assertion is one inequality between two explicitly given rational numbers, with no
+hypothesis on $N$ beyond its being nonzero.
+
+This is the lower-bound half of the classical dimension formula $\dim_{\mathbb C} S_2(\Gamma_0(N)) =
+g(X_0(N))$, the genus being computed by the Riemann–Hurwitz count for $X_0(N) \to X(1)$; the proof
+passes through regular differentials on the modular function field over $\overline{\mathbb Q}$ and
+their $q$-expansions. Together with the matching upper bound it yields
+[`CuspForm.finrank_gamma0_weight_two_eq_genusFormula`]
+(thm.html#CuspForm.finrank_gamma0_weight_two_eq_genusFormula),
+and it is used in the Eichler–Shimura decomposition and in the dimension estimates for mod $p$ cusp
+forms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_CuspForm_genusFormula_le_finrank_gamma0_weight_two.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_CuspForm_genusFormula_le_finrank_gamma0_weight_two
+
+open ModularCurve AlgebraicCurve
+
+
+theorem linearIndependent_ringHom_comp_of_linearIndependent {K L : Type*} [Field K] [Field L]
+    (ι : K →+* L) {n : ℕ} {X : Type*} {v : Fin n → X → K} (hv : LinearIndependent K v) :
+    LinearIndependent L (fun i x => ι (v i x)) := by
+  classical
+  let : Algebra K L := ι.toAlgebra
+  rw [Fintype.linearIndependent_iff] at hv ⊢
+  intro c hc i
+  let B := Module.Basis.ofVectorSpace K L
+  have hrel : ∀ k, ∑ j, (B.repr (c j) k) • v j = 0 := by
+    intro k
+    funext x
+    have hx := congr_fun hc x
+    simp only [Finset.sum_apply, Pi.smul_apply, smul_eq_mul, Pi.zero_apply] at hx ⊢
+    have hx' : ∑ j, (v j x) • c j = 0 := by
+      rw [← hx]
+      refine Finset.sum_congr rfl fun j _ => ?_
+      rw [Algebra.smul_def, RingHom.algebraMap_toAlgebra, mul_comm]
+    have h2 : B.repr (∑ j, (v j x) • c j) k = 0 := by
+      rw [hx', map_zero, Finsupp.zero_apply]
+    rw [map_sum, Finsupp.finsetSum_apply] at h2
+    rw [← h2]
+    refine Finset.sum_congr rfl fun j _ => ?_
+    rw [map_smul, Finsupp.smul_apply, smul_eq_mul, mul_comm]
+  have hzero : B.repr (c i) = 0 := by
+    ext k
+    rw [Finsupp.zero_apply]
+    exact hv _ (hrel k) i
+  exact (LinearEquiv.map_eq_zero_iff B.repr).mp hzero
+
+theorem solution (N : ℕ) [NeZero N] :
+    ModularCurve.genusFormula N ≤ (Module.finrank ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) 2) : ℚ)
+      := by
+  classical
+  have hCO := ModularCurve.isCurveOver_modularFunctionFieldBar N
+  have hEFT := ModularCurve.essFiniteType_modularFunctionFieldBar N
+  have hCD := ModularCurve.hasCanonicalDivisor_modularFunctionFieldBar N
+  have hfinS := CuspForm.finiteDimensional_Gamma0 N 2
+  obtain ⟨hfinΩ, hrank⟩ :=
+    AlgebraicCurve.finite_and_finrank_regularDifferentials_eq_genus
+      (K := AlgebraicClosure ℚ) (F := ↥(modularFunctionFieldBar N))
+  rw [← ModularCurve.genus_modularFunctionFieldBar_eq_genusFormula N, ← hrank]
+  have : Module.Finite (AlgebraicClosure ℚ) ↥(regularDifferentialsBar N) := hfinΩ
+  suffices key : Module.finrank (AlgebraicClosure ℚ) ↥(regularDifferentialsBar N)
+      ≤ Module.finrank ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) 2) by
+    first | exact Nat.cast_le.mpr key
+  let b := Module.finBasis (AlgebraicClosure ℚ) ↥(regularDifferentialsBar N)
+  have : Algebra.IsAlgebraic ℚ (AlgebraicClosure ℚ) := AlgebraicClosure.isAlgebraic ℚ
+  let ι₀ : AlgebraicClosure ℚ →+* ℂ := (IsAlgClosed.lift : AlgebraicClosure ℚ →ₐ[ℚ] ℂ).toRingHom
+  have hex : ∀ i : Fin (Module.finrank (AlgebraicClosure ℚ) ↥(regularDifferentialsBar N)),
+      ∃ f : CuspForm (CongruenceSubgroup.Gamma0 N) 2,
+        ModularCurve.coeffMap ι₀
+            (ModularCurve.diffQExpBar N (b i : Ω[modularFunctionFieldBar N⁄AlgebraicClosure ℚ])) =
+          HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 f) := fun i =>
+    ModularCurve.exists_cuspForm_coeffMap_diffQExpBar_eq_qExpansion_of_mem_regularDifferentialsBar
+      N ι₀ (b i : Ω[modularFunctionFieldBar N⁄AlgebraicClosure ℚ]) (b i).2
+  choose f hf using hex
+  let v : Fin (Module.finrank (AlgebraicClosure ℚ) ↥(regularDifferentialsBar N)) → ℤ →
+    AlgebraicClosure ℚ :=
+    fun i n => (ModularCurve.diffQExpBar N (b i : Ω[modularFunctionFieldBar N⁄AlgebraicClosure
+      ℚ])).coeff n
+  have hv_def : ∀ i n, v i n =
+      (ModularCurve.diffQExpBar N (b i : Ω[modularFunctionFieldBar N⁄AlgebraicClosure ℚ])).coeff n
+        :=
+    fun _ _ => rfl
+  let Θ : Ω[modularFunctionFieldBar N⁄AlgebraicClosure ℚ] →ₗ[AlgebraicClosure ℚ] LaurentSeries
+    (AlgebraicClosure ℚ) :=
+    (ModularCurve.diffQExpBar N).restrictScalars (AlgebraicClosure ℚ)
+  have hΘ : ∀ ω, Θ ω = ModularCurve.diffQExpBar N ω := fun ω => rfl
+  have hcoeff_sum : ∀ (s : Finset (Fin (Module.finrank (AlgebraicClosure ℚ)
+    ↥(regularDifferentialsBar N))))
+      (x : Fin (Module.finrank (AlgebraicClosure ℚ) ↥(regularDifferentialsBar N)) → LaurentSeries
+        (AlgebraicClosure ℚ))
+      (n : ℤ), (∑ i ∈ s, x i).coeff n = ∑ i ∈ s, (x i).coeff n := by
+    intro s x n
+    induction s using Finset.induction_on with
+    | empty => simp
+    | insert a s ha ih => rw [Finset.sum_insert ha, Finset.sum_insert ha, HahnSeries.coeff_add, ih]
+  have hv : LinearIndependent (AlgebraicClosure ℚ) v := by
+    rw [Fintype.linearIndependent_iff]
+    intro d hd
+    have hsum : Θ ((∑ i, d i • b i : ↥(regularDifferentialsBar N)) : Ω[modularFunctionFieldBar
+      N⁄AlgebraicClosure ℚ]) = 0 :=
+      by
+      rw [Submodule.coe_sum, map_sum]
+      ext n
+      have hdn := congr_fun hd n
+      simp only [Finset.sum_apply, Pi.smul_apply, smul_eq_mul, Pi.zero_apply] at hdn
+      rw [hcoeff_sum, HahnSeries.coeff_zero, ← hdn]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [Submodule.coe_smul, map_smul, HahnSeries.coeff_smul, smul_eq_mul]
+      rw [hΘ, hv_def]
+    rw [hΘ] at hsum
+    have hzero : ((∑ i, d i • b i : ↥(regularDifferentialsBar N)) : Ω[modularFunctionFieldBar
+      N⁄AlgebraicClosure ℚ]) = 0 :=
+      ModularCurve.diffQExpBar_injective_of_neZero N (by rw [hsum, map_zero])
+    have hzero' : (∑ i, d i • b i) = 0 := by
+      first | exact (Submodule.coe_eq_zero).mp hzero
+    exact Fintype.linearIndependent_iff.mp b.linearIndependent d hzero'
+  have hvC : LinearIndependent ℂ (fun i n => ι₀ (v i n)) :=
+    linearIndependent_ringHom_comp_of_linearIndependent ι₀ hv
+  have hΓ := CongruenceSubgroup.one_mem_strictPeriods_Gamma0 N
+  have hcadd : ∀ φ ψ : CuspForm (CongruenceSubgroup.Gamma0 N) 2, ⇑(φ + ψ) = ⇑φ + ⇑ψ :=
+    fun _ _ => rfl
+  have hcsmul : ∀ (x : ℂ) (φ : CuspForm (CongruenceSubgroup.Gamma0 N) 2), ⇑(x • φ) = x • ⇑φ :=
+    fun _ _ => rfl
+  have hczero : ⇑(0 : CuspForm (CongruenceSubgroup.Gamma0 N) 2) = 0 := rfl
+  have hqadd : ∀ φ ψ : CuspForm (CongruenceSubgroup.Gamma0 N) 2,
+      UpperHalfPlane.qExpansion 1 (⇑φ + ⇑ψ) = UpperHalfPlane.qExpansion 1 ⇑φ +
+        UpperHalfPlane.qExpansion 1 ⇑ψ := by
+    intro φ ψ
+    first
+      | exact ModularForm.qExpansion_add one_pos hΓ φ ψ
+  have hqsmul : ∀ (x : ℂ) (φ : CuspForm (CongruenceSubgroup.Gamma0 N) 2),
+      UpperHalfPlane.qExpansion 1 (x • ⇑φ) = x • UpperHalfPlane.qExpansion 1 ⇑φ := by
+    intro x φ
+    first
+      | exact ModularForm.qExpansion_smul one_pos hΓ x φ
+  have hqzero : UpperHalfPlane.qExpansion 1 (0 : UpperHalfPlane → ℂ) = 0 := by
+    first
+      | exact UpperHalfPlane.qExpansion_zero 1
+  have hli : LinearIndependent ℂ f := by
+    rw [Fintype.linearIndependent_iff]
+    intro c hc
+    have hqsum : ∀ s : Finset (Fin (Module.finrank (AlgebraicClosure ℚ) ↥(regularDifferentialsBar
+      N))),
+        UpperHalfPlane.qExpansion 1 ⇑(∑ i ∈ s, c i • f i) =
+          ∑ i ∈ s, c i • UpperHalfPlane.qExpansion 1 ⇑(f i) := by
+      intro s
+      induction s using Finset.induction_on with
+      | empty => rw [Finset.sum_empty, Finset.sum_empty, hczero, hqzero]
+      | insert a s ha ih =>
+        rw [Finset.sum_insert ha, Finset.sum_insert ha, hcadd, hqadd, hcsmul, hqsmul, ih]
+    have hq : ∑ i, c i • UpperHalfPlane.qExpansion 1 ⇑(f i) = 0 := by
+      rw [← hqsum Finset.univ, hc, hczero, hqzero]
+    have hrel : ∑ i, c i • (fun n => ι₀ (v i n)) = 0 := by
+      funext n
+      simp only [Finset.sum_apply, Pi.smul_apply, smul_eq_mul, Pi.zero_apply]
+      have hvi : ∀ i, ι₀ (v i n) =
+          (HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 ⇑(f i))).coeff n := by
+        intro i
+        rw [← hf i, ModularCurve.coeffMap_coeff]
+      simp_rw [hvi]
+      rcases n with m | m
+      · have h1 := congr_arg (PowerSeries.coeff m) hq
+        rw [map_sum, map_zero] at h1
+        rw [← h1]
+        refine Finset.sum_congr rfl fun i _ => ?_
+        rw [map_smul, smul_eq_mul]
+        first | rw [Int.ofNat_eq_natCast]
+        rw [HahnSeries.ofPowerSeries_apply_coeff]
+      · refine Finset.sum_eq_zero fun i _ => ?_
+        rw [HahnSeries.ofPowerSeries_apply, HahnSeries.embDomain_of_notMem_range, mul_zero]
+        rintro ⟨k, hk⟩
+        exact absurd hk (by simp)
+    exact Fintype.linearIndependent_iff.mp hvC c hrel
+  have hcard := hli.fintype_card_le_finrank
+  rw [Fintype.card_fin] at hcard
+  exact hcard
+
+end S_CuspForm_genusFormula_le_finrank_gamma0_weight_two
+end P2MW
+export P2MW.S_CuspForm_genusFormula_le_finrank_gamma0_weight_two (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem CuspForm.genusFormula_le_finrank_gamma0_weight_two (N : ℕ) [NeZero N] :
+    ModularCurve.genusFormula N ≤ (Module.finrank ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) 2) : ℚ)
+      :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_heckeTLin_comm.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_heckeTLin_comm.lean
new file mode 100644
index 0000000000..dea79fa7af
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_heckeTLin_comm.lean
@@ -0,0 +1,83 @@
+/-
+Based on Prove2Me node CuspForm.heckeTLin_comm
+(1ccd37ab-7f09-5da6-b86f-6e430c5a535d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6fd25224-0228-5d30-8d52-b0c34d7acec2
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperatorForms
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularFormClass_heckeT_heckeT_comm
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Hecke operators Tₚ, T_q commute on cusp forms
+
+Theorem statement: `CuspForm.heckeTLin_comm` (`1ccd37ab-7f09-5da6-b86f-6e430c5a535d`), by Claude,
+2026-09-05.
+
+Proof: submission `6fd25224-0228-5d30-8d52-b0c34d7acec2`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, $k$ an integer, and let $p$, $q$ be natural numbers that are prime and
+do not divide $N$ (so that $N \neq 0$). For such data the operator
+[`CuspForm.heckeTLin`](def/ModularForm_HeckeOperatorForms.html#L69) is the $\mathbb{C}$-linear
+endomorphism of the space $S_k(\Gamma_0(N))$ of weight-$k$ cusp forms for $\Gamma_0(N)$ which sends
+a cusp form $f$ to the cusp form whose underlying function on the upper half-plane is
+$\mathrm{heckeT}\,k\,p\,f = \mathrm{heckeU}\,k\,p\,f + f\mid_k \mathrm{heckeDiagMatrix}\,p$, the
+weight-$k$ modularity under $\Gamma_0(N)$, holomorphy and vanishing at the cusps of this function
+being part of the construction, together with additivity and $\mathbb{C}$-homogeneity in $f$. The
+theorem asserts that the two endomorphisms obtained in this way from $(p, hp, hpN)$ and from $(q,
+hq, hqN)$ commute, that is, $T_p \circ T_q = T_q \circ T_p$ as linear maps $S_k(\Gamma_0(N)) \to
+S_k(\Gamma_0(N))$. Nothing is asserted about operators attached to primes dividing $N$.
+
+This is the pairwise commutativity of the Hecke operators $T_p$ at primes of good level, which
+allows $\{T_p\}_{p \nmid N}$ to be treated as a commuting family of endomorphisms of
+$S_k(\Gamma_0(N))$ and hence the Hecke algebra to be viewed as a commutative subalgebra of the
+endomorphism ring. It is used in the analysis of newforms, for instance in identifying a newform up
+to scalar as a common eigenvector of the $T_p$ and in computing the simultaneous eigenspaces of the
+$T_p$ and of their duals.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_CuspForm_heckeTLin_comm.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_CuspForm_heckeTLin_comm
+
+theorem solution {N : ℕ} (k : ℤ) {p q : ℕ} (hp : p.Prime) (hpN : ¬ p ∣ N)
+    (hq : q.Prime) (hqN : ¬ q ∣ N) :
+    Commute (CuspForm.heckeTLin k hp hpN) (CuspForm.heckeTLin k hq hqN) := by
+  by_cases hpq : p = q
+  · subst hpq; exact Commute.refl _
+  · rw [commute_iff_eq]; ext f τ
+    simpa using congrFun (ModularFormClass.heckeT_heckeT_comm f (by simp)
+      ((Nat.coprime_primes hp hq).mpr hpq)) τ
+
+end S_CuspForm_heckeTLin_comm
+end P2MW
+export P2MW.S_CuspForm_heckeTLin_comm (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem CuspForm.heckeTLin_comm {N : ℕ} (k : ℤ) {p q : ℕ} (hp : p.Prime) (hpN : ¬ p ∣ N)
+    (hq : q.Prime) (hqN : ¬ q ∣ N) :
+    Commute (CuspForm.heckeTLin k hp hpN) (CuspForm.heckeTLin k hq hqN) :=
+  solution k hp hpN hq hqN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_heckeTLin_heckeULin_comm.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_heckeTLin_heckeULin_comm.lean
new file mode 100644
index 0000000000..eea426f8ac
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_heckeTLin_heckeULin_comm.lean
@@ -0,0 +1,85 @@
+/-
+Based on Prove2Me node CuspForm.heckeTLin_heckeULin_comm
+(ec98f7b8-bb6c-565e-8a22-659275b8f372) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 84800b90-33d8-5727-83e3-b99766941ba4
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperatorForms
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularFormClass_heckeT_heckeU_comm
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Tₚ and U_q commute on S_k(Γ₀(N))
+
+Theorem statement: `CuspForm.heckeTLin_heckeULin_comm` (`ec98f7b8-bb6c-565e-8a22-659275b8f372`), by
+Claude, 2026-09-05.
+
+Proof: submission `84800b90-33d8-5727-83e3-b99766941ba4`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, assumed nonzero, let $k$ be an integer, and let $p,q$ be natural
+numbers with $p$ prime, $p \nmid N$ and $q \mid N$. The assertion is that the two
+$\mathbb{C}$-linear endomorphisms [`CuspForm.heckeTLin k hp
+hpN`](def/ModularForm_HeckeOperatorForms.html#L69) and [`CuspForm.heckeULin k
+hqN`](def/ModularForm_HeckeOperatorForms.html#L83) of the space $S_k(\Gamma_0(N))$ of weight-$k$
+cusp forms for `CongruenceSubgroup.Gamma0 N` commute, i.e. their two composites in either order are
+equal as linear maps. Here [`CuspForm.heckeULin k hqN`](def/ModularForm_HeckeOperatorForms.html#L83)
+is the map sending a cusp form $f$ to the cusp form with underlying function
+$\mathrm{heckeU}\,k\,q\,f = \sum_{j<q} f \mid[k]\,(\mathrm{heckeMatrix}\, q\,j)$, the weight-$k$
+slash action applied to the $q$ matrices `heckeMatrix q j` for $j$ in `Finset.range q` and summed;
+and [`CuspForm.heckeTLin k hp hpN`](def/ModularForm_HeckeOperatorForms.html#L69) sends $f$ to the
+cusp form with underlying function $\mathrm{heckeT}\,k\,p\,f = \mathrm{heckeU}\,k\,p\,f + f
+\mid[k]\,(\mathrm{heckeDiagMatrix}\, p)$, the same sum of $p$ slashes together with one further
+slash by the diagonal matrix `heckeDiagMatrix p`. In both cases the hypotheses on $p$ and on $q$
+enter in verifying that the resulting function is again $\Gamma_0(N)$-invariant of weight $k$,
+holomorphic and vanishing at the cusps.
+
+This is the coprime case of the commutativity of the Hecke algebra acting on cusp forms, in the
+mixed form pairing a good Hecke operator $T_p$ with $p \nmid N$ against a $U_q$ with $q \mid N$. It
+is used downstream wherever a family of Hecke operators must be diagonalised simultaneously or
+generate a commutative subalgebra of $\mathrm{End}_{\mathbb{C}} S_k(\Gamma_0(N))$, for instance in
+the construction of normalised eigenforms from systems of $T_p$-eigenvalues and in the analysis of
+$U_q$ on newforms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_CuspForm_heckeTLin_heckeULin_comm.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_CuspForm_heckeTLin_heckeULin_comm
+
+theorem solution {N : ℕ} [NeZero N] (k : ℤ) {p q : ℕ} (hp : p.Prime) (hpN : ¬ p ∣ N) (hqN : q ∣ N) :
+    Commute (CuspForm.heckeTLin k hp hpN) (CuspForm.heckeULin k hqN) := by
+  rw [commute_iff_eq]; ext f τ
+  simpa using congrFun (ModularFormClass.heckeT_heckeU_comm f (by simp)
+    ((Nat.Prime.coprime_iff_not_dvd hp).mpr fun h => hpN (h.trans hqN))) τ
+
+end S_CuspForm_heckeTLin_heckeULin_comm
+end P2MW
+export P2MW.S_CuspForm_heckeTLin_heckeULin_comm (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem CuspForm.heckeTLin_heckeULin_comm {N : ℕ} [NeZero N] (k : ℤ) {p q : ℕ} (hp : p.Prime)
+    (hpN : ¬ p ∣ N) (hqN : q ∣ N) :
+    Commute (CuspForm.heckeTLin k hp hpN) (CuspForm.heckeULin k hqN) :=
+  solution k hp hpN hqN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_heckeULin_comm.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_heckeULin_comm.lean
new file mode 100644
index 0000000000..722e394a5f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_CuspForm_heckeULin_comm.lean
@@ -0,0 +1,80 @@
+/-
+Based on Prove2Me node CuspForm.heckeULin_comm
+(1a0bb677-dd7a-5d47-abbc-26825c474234) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a3d29882-3a25-524d-bcfa-f938897fcf12
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperatorForms
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularFormClass_heckeU_heckeU_comm
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Commutativity of Uₚ and U_q on S_k(Γ₀(N))
+
+Theorem statement: `CuspForm.heckeULin_comm` (`1a0bb677-dd7a-5d47-abbc-26825c474234`), by Claude,
+2026-09-05.
+
+Proof: submission `a3d29882-3a25-524d-bcfa-f938897fcf12`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, assumed nonzero, let $k$ be an integer, and let $p,q$ be natural
+numbers with $p \mid N$ and $q \mid N$. For a divisor $p$ of $N$, [`CuspForm.heckeULin k
+hpN`](def/ModularForm_HeckeOperatorForms.html#L83) is the $\mathbb{C}$-linear endomorphism of the
+space `CuspForm (CongruenceSubgroup.Gamma0 N) k` of weight $k$ cusp forms on $\Gamma_0(N)$ that
+sends $f$ to the cusp form whose underlying function on the upper half plane is
+$\mathrm{heckeU}\,k\,p\,f = \sum_{j<p} f \mid_k \mathrm{heckeMatrix}\,p\,j$, the slash invariance
+under $\Gamma_0(N)$, the holomorphy and the vanishing at the cusps of this sum being supplied by the
+construction; the divisibility proofs are literally arguments of the operators, which is why they
+occur as binders. The assertion is that these two endomorphisms commute in the ring of
+$\mathbb{C}$-linear endomorphisms of $S_k(\Gamma_0(N))$, i.e. `Commute (CuspForm.heckeULin k hpN)
+(CuspForm.heckeULin k hqN)`, so $U_p U_q = U_q U_p$. No primality of $p$ or $q$ is required.
+
+This is the commutativity of the Hecke operators $U_p$ for primes dividing the level, part of the
+commutativity of the full Hecke algebra acting on $S_k(\Gamma_0(N))$. It is used in the construction
+of normalized Hecke eigenforms
+([`CuspForm.exists_isNormalizedEigenform_of_forall_heckeTLin_eq_smul`]
+(thm.html#CuspForm.exists_isNormalizedEigenform_of_forall_heckeTLin_eq_smul),
+[`CuspForm.exists_normalized_eigenvector`](thm.html#CuspForm.exists_normalized_eigenvector)) and in
+computing traces of the $U$-operators
+([`CuspForm.traceLin_heckeULin`](thm.html#CuspForm.traceLin_heckeULin)).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_CuspForm_heckeULin_comm.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_CuspForm_heckeULin_comm
+
+theorem solution {N : ℕ} [NeZero N] (k : ℤ) {p q : ℕ} (hpN : p ∣ N) (hqN : q ∣ N) :
+    Commute (CuspForm.heckeULin k hpN) (CuspForm.heckeULin k hqN) := by
+  rw [commute_iff_eq]; ext f τ
+  simpa using congrFun (ModularFormClass.heckeU_heckeU_comm f (by simp) p q) τ
+
+end S_CuspForm_heckeULin_comm
+end P2MW
+export P2MW.S_CuspForm_heckeULin_comm (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem CuspForm.heckeULin_comm {N : ℕ} [NeZero N] (k : ℤ) {p q : ℕ} (hpN : p ∣ N) (hqN : q ∣ N) :
+    Commute (CuspForm.heckeULin k hpN) (CuspForm.heckeULin k hqN) :=
+  solution k hpN hqN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinSeries_eisensteinG1_apply_smul_and_eisensteinG1_add.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinSeries_eisensteinG1_apply_smul_and_eisensteinG1_add.lean
new file mode 100644
index 0000000000..de8aa219f3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinSeries_eisensteinG1_apply_smul_and_eisensteinG1_add.lean
@@ -0,0 +1,297 @@
+/-
+Based on Prove2Me node EisensteinSeries.eisensteinG1_apply_smul_and_eisensteinG1_add
+(37be3f3a-8caf-5da4-8af8-f54d5fd49f35) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b7a79bb4-808e-55bd-bbd1-57236831cadc
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EisensteinSeries_WeierstrassZeta
+
+import Mathlib.NumberTheory.ModularForms.EisensteinSeries.E2.Transform
+import LeanPool.FLTEichlerShimura.Theorems.Thm_EisensteinSeries_weierstrassZeta_add_one_and_add_tau_and_smul
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Weight-one Eisenstein functions: SL₂(ℤ)-covariance and N-periodicity
+
+Theorem statement: `EisensteinSeries.eisensteinG1_apply_smul_and_eisensteinG1_add`
+(`37be3f3a-8caf-5da4-8af8-f54d5fd49f35`), by Claude, 2026-09-05.
+
+Proof: submission `b7a79bb4-808e-55bd-bbd1-57236831cadc`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a positive integer $N$ and a point $\tau$ of the upper half-plane. For $v\in\mathbb Z^2$ put
+$$g_1^{v}(\tau)=\frac1N\Bigl(Z\bigl(\tau,\tfrac{v_0\tau+v_1}{N}\bigr)-\frac{v_0(\tau G_2(\tau)-2\pi
+i)+v_1G_2(\tau)}{N}\Bigr),$$ where $Z(\tau,z)=1/z+\sum_{v\neq
+0}\bigl(1/(z-(v_0\tau+v_1))+1/(v_0\tau+v_1)+z/(v_0\tau+v_1)^2\bigr)$ is the Weierstrass zeta
+function of the lattice $\mathbb Z\tau+\mathbb Z$ (the sum being over $v\in\mathbb Z^2$, the term at
+$v=0$ being replaced by $0$) and $G_2$ is the weight-two Eisenstein series, these being
+[`EisensteinSeries.weierstrassZeta`](def/EisensteinSeries_WeierstrassZeta.html#L5) and
+[`EisensteinSeries.eisensteinG1`](def/EisensteinSeries_WeierstrassZeta.html#L9). The theorem asserts
+the conjunction of two statements. First, for every $\gamma\in SL_2(\mathbb Z)$ and every
+$v\in\mathbb Z^2$, $$g_1^{v}(\gamma\tau)=\mathrm{denom}(\gamma,\tau)\,g_1^{v\gamma}(\tau),$$ where
+$\mathrm{denom}(\gamma,\tau)=c\tau+d$ for $\gamma=\begin{pmatrix}a&b\\c&d\end{pmatrix}$ and
+$v\gamma$ is the vector–matrix product of the row vector $v$ with $\gamma$. Second, for all
+$v,w\in\mathbb Z^2$ such that it is not the case that $N$ divides every coordinate of $v$,
+$$g_1^{v+Nw}(\tau)=g_1^{v}(\tau).$$
+
+These are the two defining properties of the weight-one Eisenstein functions $g_1^{v}$ of level $N$
+attached to vectors $v\in\mathbb Z^2$: together they show that $v\mapsto g_1^{v}$ descends to a
+family indexed by the non-zero classes $v\in(\mathbb Z/N)^2$, weakly modular of weight one for
+$\Gamma(N)$ and permuted by the right action of $SL_2(\mathbb Z)$. They are used in establishing
+boundedness at $i\infty$ and the $q$-expansion of $g_1^{v}$, and ultimately in the construction of a
+weight-one Eisenstein series with prescribed $q$-coefficients attached to an odd primitive
+character.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_EisensteinSeries_eisensteinG1_apply_smul_and_eisensteinG1_add.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_EisensteinSeries_eisensteinG1_apply_smul_and_eisensteinG1_add
+
+open scoped Topology Real MatrixGroups Matrix
+p2m_open "UpperHalfPlane~I"
+open EisensteinSeries Filter Complex
+
+noncomputable section
+
+namespace WZC
+
+variable (τ : ℍ)
+
+def om (v : Fin 2 → ℤ) : ℂ := (v 0 : ℂ) * τ + v 1
+
+lemma om_smul (γ : SL(2, ℤ)) (v : Fin 2 → ℤ) :
+    om (γ • τ) v = om τ (v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ)) / denom γ τ := by
+  have h := eisSummand_SL2_apply (-1) v γ τ
+  simp only [eisSummand, neg_neg, zpow_one, zpow_neg] at h
+  simpa [om, div_eq_inv_mul] using h
+
+lemma coe_smul_eq (γ : SL(2, ℤ)) :
+    ((γ • τ : ℍ) : ℂ) = (((γ 0 0 : ℤ) : ℂ) * τ + ((γ 0 1 : ℤ) : ℂ)) / denom γ τ := by
+  have := om_smul τ γ ![1, 0]
+  simp only [om, Fin.isValue, Matrix.cons_val_zero, Int.cast_one, ModularGroup.sl_moeb, one_mul,
+    Matrix.cons_val_one, Matrix.cons_val_fin_one, Int.cast_zero, add_zero, Matrix.vecMul,
+    Matrix.cons_dotProduct, Matrix.head_val', Matrix.tail_val', zero_mul,
+    Matrix.dotProduct_of_isEmpty] at this
+  exact this
+
+lemma denom_eq (γ : SL(2, ℤ)) :
+    (denom γ τ : ℂ) = ((γ 1 0 : ℤ) : ℂ) * τ + ((γ 1 1 : ℤ) : ℂ) := by
+  simp [ModularGroup.denom_apply]
+
+lemma G2_smul (γ : SL(2, ℤ)) :
+    G2 (γ • τ) = denom γ τ ^ 2 * G2 τ - 2 * π * I * ((γ 1 0 : ℤ) : ℂ) * denom γ τ := by
+  have hD : (denom γ τ : ℂ) ≠ 0 := denom_ne_zero _ τ
+  have h := congr_fun (G2_slash_action γ) τ
+  rw [ModularForm.SL_slash_apply, Pi.sub_apply] at h
+  simp only [D2] at h
+  rw [zpow_neg, mul_inv_eq_iff_eq_mul₀ (zpow_ne_zero _ hD)] at h
+  rw [h]
+  field_simp
+
+lemma det_eq (γ : SL(2, ℤ)) :
+    ((γ 0 0 : ℤ) : ℂ) * ((γ 1 1 : ℤ) : ℂ) - ((γ 0 1 : ℤ) : ℂ) * ((γ 1 0 : ℤ) : ℂ) = 1 := by
+  have h := Matrix.SpecialLinearGroup.det_coe γ
+  rw [Matrix.det_fin_two] at h
+  exact_mod_cast h
+
+theorem eisensteinG1_smul (N : ℕ) (γ : SL(2, ℤ)) (v : Fin 2 → ℤ) :
+    eisensteinG1 N v (γ • τ) =
+      denom γ τ * eisensteinG1 N (v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ)) τ := by
+  have hD : (denom γ τ : ℂ) ≠ 0 := denom_ne_zero _ τ
+  have hZ := (EisensteinSeries.weierstrassZeta_add_one_and_add_tau_and_smul τ).2.2 γ
+    (om τ (v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ)) / N)
+  have hom : (((v 0 : ℤ) : ℂ) * ((γ • τ : ℍ) : ℂ) + v 1) / N =
+      om τ (v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ)) / N / denom γ τ := by
+    have := om_smul τ γ v
+    simp only [om] at this ⊢
+    rw [this]
+    ring
+  have hdet := det_eq γ
+  have hDe := denom_eq τ γ
+  have hsm := coe_smul_eq τ γ
+  have hG := G2_smul τ γ
+  have hv0 : (((v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ)) 0 : ℤ) : ℂ) =
+      (v 0 : ℂ) * ((γ 0 0 : ℤ) : ℂ) + (v 1 : ℂ) * ((γ 1 0 : ℤ) : ℂ) := by
+    simp [Matrix.vecMul, Matrix.vec2_dotProduct]
+  have hv1 : (((v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ)) 1 : ℤ) : ℂ) =
+      (v 0 : ℂ) * ((γ 0 1 : ℤ) : ℂ) + (v 1 : ℂ) * ((γ 1 1 : ℤ) : ℂ) := by
+    simp [Matrix.vecMul, Matrix.vec2_dotProduct]
+  have hR : eisensteinG1 N (v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ)) τ =
+      1 / (N : ℂ) * (weierstrassZeta τ (om τ (v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ)) / N) -
+        ((((v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ)) 0 : ℤ) : ℂ) * ((τ : ℂ) * G2 τ - 2 * π * I) +
+          (((v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ)) 1 : ℤ) : ℂ) * G2 τ) / N) := rfl
+  have hL : eisensteinG1 N v (γ • τ) =
+      1 / (N : ℂ) * (weierstrassZeta (γ • τ) ((((v 0 : ℤ) : ℂ) * ((γ • τ : ℍ) : ℂ) + v 1) / N) -
+        (((v 0 : ℤ) : ℂ) * (((γ • τ : ℍ) : ℂ) * G2 (γ • τ) - 2 * π * I) +
+          ((v 1 : ℤ) : ℂ) * G2 (γ • τ)) / N) := rfl
+  rw [hL, hR, hom, hZ, hG, hsm, hv0, hv1]
+  generalize weierstrassZeta τ (om τ (v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ)) / N) = Zv
+  have hx : (((γ 0 0 : ℤ) : ℂ) * τ + ((γ 0 1 : ℤ) : ℂ)) / denom γ τ *
+      (denom γ τ ^ 2 * G2 τ - 2 * π * I * ((γ 1 0 : ℤ) : ℂ) * denom γ τ) =
+      (((γ 0 0 : ℤ) : ℂ) * τ + ((γ 0 1 : ℤ) : ℂ)) * (denom γ τ * G2 τ - 2 * π * I * ((γ 1 0 : ℤ) :
+        ℂ)) := by
+    field_simp
+  rw [hx, hDe]
+  linear_combination (-(2 * π * I * (v 0 : ℂ) * (1 / (N : ℂ)) * (1 / (N : ℂ)))) * hdet
+
+def NotLat (τ : ℍ) (z : ℂ) : Prop := ∀ v : Fin 2 → ℤ, z ≠ (v 0 : ℂ) * τ + v 1
+
+variable {τ}
+
+lemma NotLat.add_intCast {z : ℂ} (hz : NotLat τ z) (n : ℤ) : NotLat τ (z + n) := by
+  intro v hv
+  apply hz (v - ![0, n])
+  simp only [Pi.sub_apply, Matrix.cons_val_zero, Matrix.cons_val_one, sub_zero, Int.cast_sub]
+  linear_combination hv
+
+lemma NotLat.add_intCast_mul {z : ℂ} (hz : NotLat τ z) (n : ℤ) : NotLat τ (z + n * τ) := by
+  intro v hv
+  apply hz (v - ![n, 0])
+  simp only [Pi.sub_apply, Matrix.cons_val_zero, Matrix.cons_val_one, sub_zero, Int.cast_sub,
+    ]
+  linear_combination hv
+
+variable (τ)
+
+lemma weierstrassZeta_add_int {z : ℂ} (hz : NotLat τ z) (n : ℤ) :
+    weierstrassZeta τ (z + n) = weierstrassZeta τ z + n * G2 τ := by
+  have h1 := (EisensteinSeries.weierstrassZeta_add_one_and_add_tau_and_smul τ).1
+  induction n using Int.induction_on with
+  | zero => simp
+  | succ n ih =>
+      have := h1 (z + n) (hz.add_intCast n)
+      push_cast at this ih ⊢
+      rw [← add_assoc, this, ih]
+      ring
+  | pred n ih =>
+      have := h1 (z + (-(n : ℤ) - 1 : ℤ)) (hz.add_intCast _)
+      push_cast at this ih ⊢
+      rw [show z + (-(n : ℂ) - 1) + 1 = z + -(n : ℂ) by ring, ih] at this
+      linear_combination -this
+
+lemma weierstrassZeta_add_int_mul {z : ℂ} (hz : NotLat τ z) (m : ℤ) :
+    weierstrassZeta τ (z + m * τ) =
+      weierstrassZeta τ z + m * ((τ : ℂ) * G2 τ - 2 * π * I) := by
+  have h2 := (EisensteinSeries.weierstrassZeta_add_one_and_add_tau_and_smul τ).2.1
+  induction m using Int.induction_on with
+  | zero => simp
+  | succ n ih =>
+      have := h2 (z + n * τ) (hz.add_intCast_mul n)
+      push_cast at this ih ⊢
+      rw [show z + ((n : ℂ) + 1) * τ = z + n * τ + τ by ring, this, ih]
+      ring
+  | pred n ih =>
+      have := h2 (z + (-(n : ℤ) - 1 : ℤ) * τ) (hz.add_intCast_mul _)
+      push_cast at this ih ⊢
+      rw [show z + (-(n : ℂ) - 1) * τ + τ = z + -(n : ℂ) * τ by ring, ih] at this
+      linear_combination -this
+
+lemma weierstrassZeta_add_lattice {z : ℂ} (hz : NotLat τ z) (w : Fin 2 → ℤ) :
+    weierstrassZeta τ (z + ((w 0 : ℂ) * τ + w 1)) =
+      weierstrassZeta τ z + (w 0 : ℂ) * ((τ : ℂ) * G2 τ - 2 * π * I) + (w 1 : ℂ) * G2 τ := by
+  rw [show z + ((w 0 : ℂ) * τ + w 1) = (z + (w 0 : ℂ) * τ) + w 1 by ring,
+    weierstrassZeta_add_int τ ((hz.add_intCast_mul (w 0))) (w 1),
+    weierstrassZeta_add_int_mul τ hz (w 0)]
+
+lemma om_injective : Function.Injective (om τ) := by
+  intro u v huv
+  have h : om τ (u - v) = 0 := by
+    simp only [om, Pi.sub_apply, Int.cast_sub] at huv ⊢
+    linear_combination huv
+  by_contra hne
+  have hne' : u - v ≠ 0 := sub_ne_zero.mpr hne
+  have := UpperHalfPlane.linear_ne_zero (cd := fun i => ((u - v) i : ℝ)) τ
+    (by
+      intro h0
+      apply hne'
+      funext i
+      have := congr_fun h0 i
+      simp only [Pi.zero_apply] at this ⊢
+      exact_mod_cast this)
+  apply this
+  simpa [om] using h
+
+lemma notLat_of_not_dvd (N : ℕ) [NeZero N] {v : Fin 2 → ℤ} (hv : ¬ ∀ i, (N : ℤ) ∣ v i) :
+    NotLat τ (om τ v / N) := by
+  intro u hu
+  apply hv
+  have hN : (N : ℂ) ≠ 0 := by exact_mod_cast NeZero.ne N
+  have h : om τ v = om τ ((N : ℤ) • u) := by
+    rw [div_eq_iff hN] at hu
+    simp only [om, Pi.smul_apply, smul_eq_mul, Int.cast_mul, Int.cast_natCast] at hu ⊢
+    linear_combination hu
+  have := om_injective τ h
+  intro i
+  rw [this]
+  simp
+
+theorem eisensteinG1_add (N : ℕ) [NeZero N] (v w : Fin 2 → ℤ) (hv : ¬ ∀ i, (N : ℤ) ∣ v i) :
+    eisensteinG1 N (v + (N : ℤ) • w) τ = eisensteinG1 N v τ := by
+  have hN : (N : ℂ) ≠ 0 := by exact_mod_cast NeZero.ne N
+  have hz : NotLat τ (om τ v / N) := notLat_of_not_dvd τ N hv
+  have hL := weierstrassZeta_add_lattice τ hz w
+  unfold eisensteinG1
+  have e1 : ((((v + (N : ℤ) • w) 0 : ℤ) : ℂ) * τ + (((v + (N : ℤ) • w) 1 : ℤ) : ℂ)) / N =
+      om τ v / N + ((w 0 : ℂ) * τ + w 1) := by
+    simp only [om, Pi.add_apply, Pi.smul_apply, smul_eq_mul, Int.cast_add, Int.cast_mul,
+      Int.cast_natCast]
+    field_simp
+    ring
+  rw [e1, hL]
+  simp only [om, Pi.add_apply, Pi.smul_apply, smul_eq_mul, Int.cast_add, Int.cast_mul,
+    Int.cast_natCast]
+  field_simp
+  ring
+
+end WZC
+
+end
+
+theorem solution (N : ℕ) [NeZero N] (τ : UpperHalfPlane) :
+    (∀ (γ : SL(2, ℤ)) (v : Fin 2 → ℤ),
+        EisensteinSeries.eisensteinG1 N v (γ • τ) =
+          UpperHalfPlane.denom γ τ *
+            EisensteinSeries.eisensteinG1 N (v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ)) τ) ∧
+    (∀ v w : Fin 2 → ℤ, (¬ ∀ i, (N : ℤ) ∣ v i) →
+        EisensteinSeries.eisensteinG1 N (v + (N : ℤ) • w) τ = EisensteinSeries.eisensteinG1 N v τ)
+          :=
+  ⟨fun γ v => WZC.eisensteinG1_smul τ N γ v, fun v w hv => WZC.eisensteinG1_add τ N v w hv⟩
+
+end S_EisensteinSeries_eisensteinG1_apply_smul_and_eisensteinG1_add
+end P2MW
+export P2MW.S_EisensteinSeries_eisensteinG1_apply_smul_and_eisensteinG1_add (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Real MatrixGroups Matrix
+theorem EisensteinSeries.eisensteinG1_apply_smul_and_eisensteinG1_add (N : ℕ) [NeZero N]
+    (τ : UpperHalfPlane) :
+    (∀ (γ : SL(2, ℤ)) (v : Fin 2 → ℤ),
+        EisensteinSeries.eisensteinG1 N v (γ • τ) =
+          UpperHalfPlane.denom γ τ *
+            EisensteinSeries.eisensteinG1 N (v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ)) τ) ∧
+    (∀ v w : Fin 2 → ℤ, (¬ ∀ i, (N : ℤ) ∣ v i) →
+        EisensteinSeries.eisensteinG1 N (v + (N : ℤ) • w) τ =
+          EisensteinSeries.eisensteinG1 N v τ) :=
+  solution N τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinSeries_exists_modularForm_coe_eq_eisensteinG.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinSeries_exists_modularForm_coe_eq_eisensteinG.lean
new file mode 100644
index 0000000000..5da0b34bc5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinSeries_exists_modularForm_coe_eq_eisensteinG.lean
@@ -0,0 +1,232 @@
+/-
+Based on Prove2Me node EisensteinSeries.exists_modularForm_coe_eq_eisensteinG
+(e1744b9b-f828-54d3-9880-5ef3bfb5dc4b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4ed15b6d-2f05-5d8e-820e-3ac6e3ef8f2e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EisensteinSeries_EisensteinG
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Analysis.Complex.LocallyUniformLimit
+import Mathlib.Data.Int.Star
+import Mathlib.NumberTheory.ModularForms.EisensteinSeries.IsBoundedAtImInfty
+import Mathlib.NumberTheory.ModularForms.EisensteinSeries.MDifferentiable
+import Mathlib.NumberTheory.ModularForms.Identities
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Congruence-class Eisenstein series G_kᵃ as a modular form
+
+Theorem statement: `EisensteinSeries.exists_modularForm_coe_eq_eisensteinG`
+(`e1744b9b-f828-54d3-9880-5ef3bfb5dc4b`), by Claude, 2026-09-05.
+
+Proof: submission `4ed15b6d-2f05-5d8e-820e-3ac6e3ef8f2e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $N \neq 0$, an integer $k$ with $3 \le k$, and a vector $a \colon
+\mathrm{Fin}\,2 \to \mathbb{Z}/N\mathbb{Z}$. Here [`EisensteinSeries.eisensteinG N k
+a`](def/EisensteinSeries_EisensteinG.html#L5) denotes the function on the upper half-plane whose
+value at $z$ is the unconditional (`tsum`) sum of `eisSummand k v z`, i.e. of $(v_0 z + v_1)^{-k}$,
+over the subtype of integer vectors $v \colon \mathrm{Fin}\,2 \to \mathbb{Z}$ whose coordinatewise
+reduction modulo $N$ equals $a$. The theorem asserts two things. First, there exists a modular form
+$F$ of weight $k$ for the principal congruence subgroup $\Gamma(N)$ — so $F$ is holomorphic on the
+upper half-plane, invariant in weight $k$ under $\Gamma(N)$, and has the growth condition at the
+cusps built into `ModularForm` — whose underlying function is exactly [`EisensteinSeries.eisensteinG
+N k a`](def/EisensteinSeries_EisensteinG.html#L5). Second, for every $\gamma \in
+\mathrm{SL}(2,\mathbb{Z})$ the weight-$k$ slash action satisfies $G_k^{a} \mid[k]\, \gamma = G_k^{a
+\cdot \gamma}$, where $a \cdot \gamma$ is the vector–matrix product `a ᵥ* γ` of $a$ with the
+reduction of $\gamma$ modulo $N$.
+
+This is the standard fact that, for weight at least $3$, the Eisenstein series attached to a residue
+class $a \in (\mathbb{Z}/N\mathbb{Z})^2$ is a modular form on $\Gamma(N)$ and that
+$\mathrm{SL}(2,\mathbb{Z})$ permutes this family according to the right action on residue classes.
+It supplies the Eisenstein input for the constructions of weight-three and weight-four forms on
+$\Gamma_1(N)$ with integral $q$-expansions and prescribed slash behaviour, including the Siegel unit
+construction.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_EisensteinSeries_exists_modularForm_coe_eq_eisensteinG.lean
+
+*Attribution:* this file contains material adapted from third-party Apache-2.0 sources
+(`Mathlib/NumberTheory/ModularForms/EisensteinSeries/IsBoundedAtImInfty.lean`: Copyright (c) 2024
+Chris Birkbeck; Authors: Chris Birkbeck). See ATTRIBUTION.md and NOTICE in the source repository.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_EisensteinSeries_exists_modularForm_coe_eq_eisensteinG
+
+open scoped MatrixGroups CongruenceSubgroup ModularForm Topology Manifold Matrix
+p2m_open "UpperHalfPlane~I"
+open EisensteinSeries Filter Complex
+
+namespace CardG1
+
+variable {N : ℕ} {k : ℤ}
+
+def congrSet (N : ℕ) (a : Fin 2 → ZMod N) : Set (Fin 2 → ℤ) := {v | ((↑) : ℤ → ZMod N) ∘ v = a}
+
+lemma eisensteinG_eq (N : ℕ) (k : ℤ) (a : Fin 2 → ZMod N) :
+    EisensteinSeries.eisensteinG N k a = fun z => ∑' v : congrSet N a, eisSummand k v z := rfl
+
+lemma vecMul_mem_congrSet {a : Fin 2 → ZMod N} {v : Fin 2 → ℤ} (hv : v ∈ congrSet N a)
+    (γ : SL(2, ℤ)) : v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ) ∈ congrSet N (a ᵥ* γ) := by
+  simp only [congrSet, Set.mem_ofPred_eq] at hv ⊢
+  have := RingHom.map_vecMul (m := Fin 2) (n := Fin 2) (Int.castRingHom (ZMod N)) γ v
+  simp only [eq_intCast, Int.coe_castRingHom] at this
+  simp_rw [Function.comp_def, this, ← hv]
+  rfl
+
+def congrSetEquiv (a : Fin 2 → ZMod N) (γ : SL(2, ℤ)) : congrSet N a ≃ congrSet N (a ᵥ* γ) where
+  toFun v := ⟨v.1 ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ), vecMul_mem_congrSet v.2 γ⟩
+  invFun v := ⟨v.1 ᵥ* ((γ⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ), by
+      have := vecMul_mem_congrSet v.2 γ⁻¹
+      rw [Matrix.vecMul_vecMul, ← Matrix.SpecialLinearGroup.coe_mul] at this
+      simpa only [map_inv, mul_inv_cancel, Matrix.SpecialLinearGroup.coe_one, Matrix.vecMul_one]
+        using this⟩
+  left_inv v := by simp_rw [Matrix.vecMul_vecMul, ← Matrix.SpecialLinearGroup.coe_mul,
+    mul_inv_cancel, Matrix.SpecialLinearGroup.coe_one, Matrix.vecMul_one]
+  right_inv v := by simp_rw [Matrix.vecMul_vecMul, ← Matrix.SpecialLinearGroup.coe_mul,
+    inv_mul_cancel, Matrix.SpecialLinearGroup.coe_one, Matrix.vecMul_one]
+
+theorem eisensteinG_slash_apply (N : ℕ) (k : ℤ) (a : Fin 2 → ZMod N) (γ : SL(2, ℤ)) :
+    EisensteinSeries.eisensteinG N k a ∣[k] γ = EisensteinSeries.eisensteinG N k (a ᵥ* γ) := by
+  ext1 z
+  simp_rw [ModularForm.SL_slash_apply, zpow_neg,
+    mul_inv_eq_iff_eq_mul₀ (zpow_ne_zero _ <| denom_ne_zero _ z), eisensteinG_eq,
+    eisSummand_SL2_apply, tsum_mul_left, mul_comm (_ ^ k)]
+  congr 1
+  exact (congrSetEquiv a γ).tsum_eq (fun v => eisSummand k v z)
+
+noncomputable def eisensteinGSIF (N : ℕ) (k : ℤ) (a : Fin 2 → ZMod N) :
+    SlashInvariantForm Γ(N) k where
+  toFun := EisensteinSeries.eisensteinG N k a
+  slash_action_eq' A hA := by
+    obtain ⟨A, (hA : A ∈ Γ(N)), rfl⟩ := hA
+    simp [Matrix.SpecialLinearGroup.mapGL, ← ModularForm.SL_slash, eisensteinG_slash_apply,
+      CongruenceSubgroup.Gamma_mem'.mp hA]
+
+lemma eisensteinGSIF_apply (N : ℕ) (k : ℤ) (a : Fin 2 → ZMod N) (z : ℍ) :
+    eisensteinGSIF N k a z = EisensteinSeries.eisensteinG N k a z := rfl
+
+lemma coe_eisensteinGSIF (N : ℕ) (k : ℤ) (a : Fin 2 → ZMod N) :
+    ⇑(eisensteinGSIF N k a) = EisensteinSeries.eisensteinG N k a := rfl
+
+theorem eisensteinG_tendstoLocallyUniformly (hk : 3 ≤ k) (a : Fin 2 → ZMod N) :
+    TendstoLocallyUniformly (fun (s : Finset (congrSet N a)) => (∑ x ∈ s, eisSummand k x ·))
+      (EisensteinSeries.eisensteinG N k a ·) Filter.atTop := by
+  have hk' : (2 : ℝ) < k := by norm_cast
+  have p_sum : Summable fun x : congrSet N a => ‖x.val‖ ^ (-k) :=
+    mod_cast (summable_one_div_norm_rpow hk').subtype (· ∈ congrSet N a)
+  simp only [tendstoLocallyUniformly_iff_forall_isCompact, eisensteinG_eq]
+  intro K hK
+  obtain ⟨A, B, hB, HABK⟩ := subset_verticalStrip_of_isCompact hK
+  refine (tendstoUniformlyOn_tsum (hu := p_sum.mul_left <| r ⟨⟨A, B⟩, hB⟩ ^ (-k : ℝ))
+    (fun p z hz => ?_)).mono HABK
+  simpa only [eisSummand, one_div, ← zpow_neg, norm_zpow, ← Real.rpow_intCast,
+    Int.cast_neg] using summand_bound_of_mem_verticalStrip (by positivity) p hB hz
+
+lemma eisensteinG_tendstoLocallyUniformlyOn (hk : 3 ≤ k) (a : Fin 2 → ZMod N) :
+    TendstoLocallyUniformlyOn (fun (s : Finset (congrSet N a)) =>
+      ↑ₕ(fun (z : ℍ) => ∑ x ∈ s, eisSummand k x z)) (↑ₕ(eisensteinGSIF N k a))
+          Filter.atTop {z : ℂ | 0 < z.im} := by
+  rw [← upperHalfPlaneSet, ← UpperHalfPlane.range_coe, ← Set.image_univ]
+  apply TendstoLocallyUniformlyOn.comp (s := ⊤) _ _ _ (OpenPartialHomeomorph.continuousOn_symm _)
+  · simp only [Set.top_eq_univ, tendstoLocallyUniformlyOn_univ]
+    apply eisensteinG_tendstoLocallyUniformly hk
+  · simp only [Topology.IsOpenEmbedding.toOpenPartialHomeomorph_target, Set.top_eq_univ,
+      Set.mapsTo_range_iff, Set.mem_univ, forall_const]
+
+theorem eisensteinGSIF_mdifferentiable (hk : 3 ≤ k) (a : Fin 2 → ZMod N) :
+    MDiff (eisensteinGSIF N k a) := by
+  intro τ
+  suffices DifferentiableAt ℂ (↑ₕeisensteinGSIF N k a) τ.1 by
+    convert!
+      MDifferentiableAt.comp τ (DifferentiableAt.mdifferentiableAt this) τ.mdifferentiable_coe
+    exact funext fun z => (comp_ofComplex (eisensteinGSIF N k a) z).symm
+  refine DifferentiableOn.differentiableAt ?_ (isOpen_upperHalfPlaneSet.mem_nhds τ.2)
+  exact (eisensteinG_tendstoLocallyUniformlyOn hk a).differentiableOn
+    (Eventually.of_forall fun s => DifferentiableOn.fun_sum
+    fun _ _ => eisSummand_extension_differentiableOn _ _) isOpen_upperHalfPlaneSet
+
+lemma norm_le_tsum_norm (N : ℕ) (a : Fin 2 → ZMod N) (k : ℤ) (hk : 3 ≤ k) (z : ℍ) :
+    ‖EisensteinSeries.eisensteinG N k a z‖ ≤ ∑' (x : Fin 2 → ℤ), ‖eisSummand k x z‖ := by
+  rw [eisensteinG_eq]
+  apply le_trans (norm_tsum_le_tsum_norm ((summable_norm_eisSummand hk z).subtype _))
+    (Summable.tsum_subtype_le (fun (x : Fin 2 → ℤ) => ‖(eisSummand k x z)‖) _ (fun _ => norm_nonneg
+      _)
+      (summable_norm_eisSummand hk z))
+
+theorem isBoundedAtImInfty_eisensteinGSIF_slash [NeZero N] (a : Fin 2 → ZMod N)
+    (hk : 3 ≤ k) (A : SL(2, ℤ)) : IsBoundedAtImInfty (eisensteinGSIF N k a ∣[k] A) := by
+  simp_rw [UpperHalfPlane.isBoundedAtImInfty_iff, coe_eisensteinGSIF] at *
+  refine ⟨∑'(x : Fin 2 → ℤ), r ⟨⟨N, 2⟩, Nat.ofNat_pos⟩ ^ (-k) * ‖x‖ ^ (-k), 2, ?_⟩
+  intro z hz
+  obtain ⟨n, hn⟩ := (ModularGroup_T_zpow_mem_verticalStrip z (NeZero.pos N))
+  rw [eisensteinG_slash_apply, ← eisensteinGSIF_apply,
+    ← SlashInvariantForm.T_zpow_width_invariant N k n (eisensteinGSIF N k (a ᵥ* A)) z]
+  apply le_trans (norm_le_tsum_norm N (a ᵥ* A) k hk _)
+  have hk' : (2 : ℝ) < k := by norm_cast
+  apply (summable_norm_eisSummand hk _).tsum_le_tsum _
+  · exact_mod_cast (summable_one_div_norm_rpow hk').mul_left <| r ⟨⟨N, 2⟩, Nat.ofNat_pos⟩ ^ (-k)
+  · intro x
+    simp_rw [eisSummand, norm_zpow]
+    exact_mod_cast
+      summand_bound_of_mem_verticalStrip (lt_trans two_pos hk').le x two_pos
+      (verticalStrip_anti_right N hz hn)
+
+noncomputable def eisensteinGMF [NeZero N] (hk : 3 ≤ k) (a : Fin 2 → ZMod N) :
+    ModularForm Γ(N) k where
+  toFun := eisensteinGSIF N k a
+  slash_action_eq' := (eisensteinGSIF N k a).slash_action_eq'
+  holo' := eisensteinGSIF_mdifferentiable hk a
+  bdd_at_cusps' {c} hc := by
+    rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z] at hc
+    rw [OnePoint.isBoundedAt_iff_forall_SL2Z hc]
+    exact fun γ hγ => isBoundedAtImInfty_eisensteinGSIF_slash a hk γ
+
+lemma coe_eisensteinGMF [NeZero N] (hk : 3 ≤ k) (a : Fin 2 → ZMod N) :
+    ⇑(eisensteinGMF hk a) = EisensteinSeries.eisensteinG N k a := rfl
+
+end CardG1
+
+theorem solution (N : ℕ) [NeZero N] (k : ℤ) (hk : 3 ≤ k) (a : Fin 2 → ZMod N) :
+    (∃ F : ModularForm Γ(N) k, ⇑F = EisensteinSeries.eisensteinG N k a) ∧
+      ∀ γ : SL(2, ℤ), EisensteinSeries.eisensteinG N k a ∣[k] γ =
+        EisensteinSeries.eisensteinG N k (a ᵥ* γ) :=
+  ⟨⟨CardG1.eisensteinGMF hk a, rfl⟩, CardG1.eisensteinG_slash_apply N k a⟩
+
+end S_EisensteinSeries_exists_modularForm_coe_eq_eisensteinG
+end P2MW
+export P2MW.S_EisensteinSeries_exists_modularForm_coe_eq_eisensteinG (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Matrix
+open scoped MatrixGroups CongruenceSubgroup ModularForm
+theorem EisensteinSeries.exists_modularForm_coe_eq_eisensteinG
+    (N : ℕ) [NeZero N] (k : ℤ) (hk : 3 ≤ k) (a : Fin 2 → ZMod N) :
+    (∃ F : ModularForm Γ(N) k, ⇑F = EisensteinSeries.eisensteinG N k a) ∧
+      ∀ γ : SL(2, ℤ), EisensteinSeries.eisensteinG N k a ∣[k] γ =
+        EisensteinSeries.eisensteinG N k (a ᵥ* γ) :=
+  solution N k hk a
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinSeries_hasSum_weierstrassZeta_sub_mul_G2.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinSeries_hasSum_weierstrassZeta_sub_mul_G2.lean
new file mode 100644
index 0000000000..4369e2c089
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinSeries_hasSum_weierstrassZeta_sub_mul_G2.lean
@@ -0,0 +1,617 @@
+/-
+Based on Prove2Me node EisensteinSeries.hasSum_weierstrassZeta_sub_mul_G2
+(64168bde-187a-5996-8d94-81ff1cdc577b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 28f49e40-abcd-51a0-a61f-1646f0393344
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EisensteinSeries_WeierstrassZeta
+
+import Mathlib.Data.Int.Star
+import Mathlib.NumberTheory.ModularForms.EisensteinSeries.E2.Summable
+import Mathlib.Topology.Separation.CompletelyRegular
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cotangent expansion of the Weierstrass zeta function
+
+Theorem statement: `EisensteinSeries.hasSum_weierstrassZeta_sub_mul_G2`
+(`64168bde-187a-5996-8d94-81ff1cdc577b`), by Claude, 2026-09-05.
+
+Proof: submission `28f49e40-abcd-51a0-a61f-1646f0393344`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\tau$ be a point of the upper half-plane, and let $z$ be a complex number which avoids the
+lattice $\mathbb{Z}\tau+\mathbb{Z}$, in the sense that $z \neq v_0\tau + v_1$ for every integer
+vector $v \colon \mathrm{Fin}\,2 \to \mathbb{Z}$. Write $Z(\tau,z) =
+\mathtt{weierstrassZeta}\,\tau\,z$ for the Weierstrass zeta value, defined as $1/z$ plus the
+unordered sum over all $v \colon \mathrm{Fin}\,2 \to \mathbb{Z}$ of the term
+$\frac{1}{z-(v_0\tau+v_1)} + \frac{1}{v_0\tau+v_1} + \frac{z}{(v_0\tau+v_1)^2}$, the term at $v = 0$
+being set to $0$. Then the sequence indexed by $m \in \mathbb{N}$ whose $m$-th term is
+$$\pi\cot\bigl(\pi(z+(m+1)\tau)\bigr) + \pi\cot\bigl(\pi(z-(m+1)\tau)\bigr)$$ is summable, with sum
+$Z(\tau,z) - z\cdot(\mathtt{EisensteinSeries.G2}\ \tau) - \pi\cot(\pi z)$; here
+`EisensteinSeries.G2` is the project's weight-two Eisenstein series attached to $\tau$. Since the
+assertion is phrased as `HasSum` for a $\mathbb{C}$-valued family indexed by $\mathbb{N}$, it
+includes unconditional (hence absolute) convergence of the series over $m \geq 1$, and the classical
+identity $Z(\tau,z) = z\,G_2(\tau) + \pi\cot(\pi z) + \sum_{m \geq 1}\bigl(\pi\cot(\pi(z+m\tau)) +
+\pi\cot(\pi(z-m\tau))\bigr)$ after rearrangement.
+
+This is the cotangent (Fourier-type) expansion of the Weierstrass zeta function of the lattice
+$\mathbb{Z}\tau+\mathbb{Z}$, the analytic identity from which the quasi-period relations of
+$Z(\tau,\cdot)$ and the $q$-expansion of weight-two Eisenstein series are read off. It is used in
+the derivation of the transformation behaviour of the zeta function under $z \mapsto z+1$, $z
+\mapsto z+\tau$ and scaling, and in the boundedness and summation statement for the weight-one
+Eisenstein series $\mathtt{eisensteinG1}$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_EisensteinSeries_hasSum_weierstrassZeta_sub_mul_G2.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_EisensteinSeries_hasSum_weierstrassZeta_sub_mul_G2
+
+open scoped Topology Real
+p2m_open "UpperHalfPlane~I"
+open EisensteinSeries Filter Complex Asymptotics
+
+noncomputable section
+
+namespace WZA
+
+variable (τ : ℍ)
+
+def om (v : Fin 2 → ℤ) : ℂ := (v 0 : ℂ) * τ + v 1
+
+def zterm (z : ℂ) (v : Fin 2 → ℤ) : ℂ :=
+  if v = 0 then 0 else (1 / (z - om τ v) + 1 / om τ v + z / om τ v ^ 2)
+
+lemma weierstrassZeta_eq (z : ℂ) : weierstrassZeta τ z = 1 / z + ∑' v, zterm τ z v := rfl
+
+lemma om_ne_zero {v : Fin 2 → ℤ} (hv : v ≠ 0) : om τ v ≠ 0 := by
+  have := UpperHalfPlane.linear_ne_zero (cd := fun i => (v i : ℝ)) τ
+    (by
+      intro h
+      apply hv
+      funext i
+      have := congr_fun h i
+      simpa using this)
+  simpa [om] using this
+
+lemma om_zero : om τ 0 = 0 := by simp [om]
+
+lemma norm_om_ge {v : Fin 2 → ℤ} (hv : v ≠ 0) : r τ * ‖v‖ ≤ ‖om τ v‖ := by
+  simpa [om] using r_mul_max_le τ hv
+
+lemma zterm_eq_of_ne (z : ℂ) {v : Fin 2 → ℤ} (hv : v ≠ 0) (hz : z ≠ om τ v) :
+    zterm τ z v = z ^ 2 / (om τ v ^ 2 * (z - om τ v)) := by
+  have h1 : om τ v ≠ 0 := om_ne_zero τ hv
+  have h2 : z - om τ v ≠ 0 := sub_ne_zero.mpr hz
+  rw [zterm, ite_eq_right hv]
+  field_simp
+  ring
+
+lemma eventually_le_norm (R : ℝ) : ∀ᶠ v : Fin 2 → ℤ in cofinite, R ≤ ‖v‖ := by
+  have hfin : Set.Finite (Metric.closedBall (0 : Fin 2 → ℤ) R) :=
+    (isCompact_closedBall (0 : Fin 2 → ℤ) R).finite_of_discrete
+  filter_upwards [hfin.compl_mem_cofinite] with v hv
+  simp only [Set.mem_compl_iff, Metric.mem_closedBall, dist_zero_right, not_le] at hv
+  exact hv.le
+
+lemma zterm_isBigO (z : ℂ) :
+    zterm τ z =O[cofinite] fun v : Fin 2 → ℤ => (‖v‖ ^ (3 : ℝ))⁻¹ := by
+  have hr : 0 < r τ := r_pos τ
+  rw [Asymptotics.isBigO_iff]
+  refine ⟨2 * ‖z‖ ^ 2 * (r τ)⁻¹ ^ 3, ?_⟩
+  filter_upwards [eventually_le_norm (2 * ‖z‖ / r τ + 1)] with v hv
+  have hv1 : 1 ≤ ‖v‖ := by
+    have : 0 ≤ 2 * ‖z‖ / r τ := by positivity
+    linarith
+  have hv0 : v ≠ 0 := by
+    intro h; rw [h, norm_zero] at hv1; exact absurd hv1 (by norm_num)
+  have hom : r τ * ‖v‖ ≤ ‖om τ v‖ := norm_om_ge τ hv0
+  have hom2 : 2 * ‖z‖ ≤ ‖om τ v‖ := by
+    have : 2 * ‖z‖ ≤ r τ * ‖v‖ := by
+      have h1 : 2 * ‖z‖ / r τ ≤ ‖v‖ := by linarith
+      have := (div_le_iff₀ hr).mp h1
+      linarith
+    linarith
+  have hompos : 0 < ‖om τ v‖ := norm_pos_iff.mpr (om_ne_zero τ hv0)
+  have hz : z ≠ om τ v := by
+    intro h
+    rw [← h] at hom2 hompos
+    have : ‖z‖ = 0 := by linarith
+    rw [this] at hompos
+    exact lt_irrefl _ hompos
+  have hsub : ‖om τ v‖ / 2 ≤ ‖z - om τ v‖ := by
+    have := norm_sub_norm_le (om τ v) z
+    rw [norm_sub_rev] at this
+    linarith
+  rw [zterm_eq_of_ne τ z hv0 hz]
+  rw [norm_div, norm_mul, norm_pow, norm_pow, Real.norm_of_nonneg (by positivity)]
+  have hpos3 : 0 < ‖om τ v‖ ^ 2 * ‖z - om τ v‖ := by
+    apply mul_pos (by positivity)
+    linarith
+  calc ‖z‖ ^ 2 / (‖om τ v‖ ^ 2 * ‖z - om τ v‖)
+      ≤ ‖z‖ ^ 2 / (‖om τ v‖ ^ 2 * (‖om τ v‖ / 2)) := by
+        apply div_le_div_of_nonneg_left (by positivity) (by positivity)
+        exact mul_le_mul_of_nonneg_left hsub (by positivity)
+    _ = 2 * ‖z‖ ^ 2 * (‖om τ v‖ ^ 3)⁻¹ := by
+        field_simp
+    _ ≤ 2 * ‖z‖ ^ 2 * ((r τ * ‖v‖) ^ 3)⁻¹ := by
+        apply mul_le_mul_of_nonneg_left _ (by positivity)
+        apply inv_anti₀ (by positivity)
+        exact pow_le_pow_left₀ (by positivity) hom 3
+    _ = 2 * ‖z‖ ^ 2 * (r τ)⁻¹ ^ 3 * (‖v‖ ^ (3 : ℝ))⁻¹ := by
+        rw [show (3 : ℝ) = ((3 : ℕ) : ℝ) by norm_num, Real.rpow_natCast, mul_pow, mul_inv, inv_pow]
+        ring
+
+lemma summable_zterm (z : ℂ) : Summable (zterm τ z) :=
+  summable_of_isBigO_rpow_norm (by norm_num) (zterm_isBigO τ z)
+
+lemma summable_zterm_prod (z : ℂ) : Summable fun p : ℤ × ℤ => zterm τ z ![p.1, p.2] := by
+  apply (finTwoArrowEquiv _).symm.summable_iff.mpr (summable_zterm τ z)
+
+def row (z : ℂ) (m : ℤ) : ℂ := ∑' n : ℤ, zterm τ z ![m, n]
+
+lemma summable_row (z : ℂ) : Summable (row τ z) :=
+  (summable_zterm_prod τ z).prod
+
+lemma summable_zterm_right (z : ℂ) (m : ℤ) : Summable fun n : ℤ => zterm τ z ![m, n] :=
+  (summable_zterm_prod τ z).prod_factor m
+
+lemma tsum_zterm_eq_tsum_row (z : ℂ) : ∑' v, zterm τ z v = ∑' m, row τ z m := by
+  rw [← (finTwoArrowEquiv _).symm.tsum_eq]
+  exact (summable_zterm_prod τ z).tsum_prod' (summable_zterm_right τ z)
+
+end WZA
+
+namespace WZA
+
+local notation "ℂ_ℤ" => Complex.integerComplement
+
+lemma cot_neg (x : ℂ) : Complex.cot (-x) = -Complex.cot x := by
+  simp [Complex.cot_eq_cos_div_sin, Complex.sin_neg, Complex.cos_neg, div_neg]
+
+lemma intComp_add_ne_zero {w : ℂ} (hw : w ∈ ℂ_ℤ) (n : ℤ) : w + n ≠ 0 := by
+  intro h
+  rw [Complex.mem_integerComplement_iff] at hw
+  exact hw ⟨-n, by rw [Int.cast_neg]; linear_combination -h⟩
+
+lemma summable_inv_mul_linear (w w' : ℂ) :
+    Summable fun n : ℤ => ((w + n) * (w' + n))⁻¹ := by
+  apply summable_inv_of_isBigO_rpow_inv (a := 2) (by norm_num)
+  have h1 := linear_inv_isBigO_right 1 w
+  have h2 := linear_inv_isBigO_right 1 w'
+  simp only [Int.cast_one, one_mul] at h1 h2
+  refine ((h1.mul h2).congr_left ?_).congr_right ?_
+  · intro n; rw [mul_inv]
+  · intro n
+    rw [← mul_inv, Real.rpow_two, sq_abs, sq]
+
+lemma hasSum_inv_linear_sub (w w' : ℂ) (hw : w ∈ ℂ_ℤ) (hw' : w' ∈ ℂ_ℤ) :
+    HasSum (fun n : ℤ => 1 / (w + n) - 1 / (w' + n))
+      (π * Complex.cot (π * w) - π * Complex.cot (π * w')) := by
+  set g : ℤ → ℂ := fun n => 1 / (w + n) - 1 / (w' + n) with hg
+  have hgs : Summable g := by
+    apply (( summable_inv_mul_linear w w').mul_left (w' - w)).congr
+    intro n
+    have h1 := intComp_add_ne_zero hw n
+    have h2 := intComp_add_ne_zero hw' n
+    simp only [hg]
+    field_simp
+    ring
+  rw [hgs.hasSum_iff]
+  have hnat : Summable fun n : ℕ => g n := hgs.comp_injective Nat.cast_injective
+  have hneg : Summable fun n : ℕ => g (-(n + 1 : ℤ)) :=
+    hgs.comp_injective (fun a b hab => by simpa using hab)
+  rw [tsum_of_nat_of_neg_add_one hnat hneg, hnat.tsum_eq_zero_add]
+  have hnat1 : Summable fun n : ℕ => g ((n + 1 : ℕ) : ℤ) :=
+    hgs.comp_injective (fun a b hab => by simpa using hab)
+  have hcw := summable_cotTerm hw
+  have hcw' := summable_cotTerm hw'
+  have key : ∀ n : ℕ, g ((n + 1 : ℕ) : ℤ) + g (-(n + 1 : ℤ)) = cotTerm w n - cotTerm w' n := by
+    intro n
+    simp only [hg, cotTerm]
+    push_cast
+    ring
+  rw [add_assoc, ← hnat1.tsum_add hneg, tsum_congr key, hcw.tsum_sub hcw', ← cot_series_rep' hw,
+    ← cot_series_rep' hw']
+  simp only [hg]
+  ring
+
+variable (τ : ℍ)
+variable {τ}
+
+def IsLatticePt (τ : ℍ) (z : ℂ) : Prop := ∃ v : Fin 2 → ℤ, z = om τ v
+
+lemma intComp_of_not_isLatticePt {z : ℂ} (hz : ¬ IsLatticePt τ z) (m : ℤ) :
+    (m : ℂ) * τ - z ∈ ℂ_ℤ := by
+  rw [Complex.mem_integerComplement_iff]
+  rintro ⟨k, hk⟩
+  exact hz ⟨![m, -k], by simp [om]; linear_combination hk⟩
+
+lemma intComp_self_of_not_isLatticePt {z : ℂ} (hz : ¬ IsLatticePt τ z) : z ∈ ℂ_ℤ := by
+  rw [Complex.mem_integerComplement_iff]
+  rintro ⟨k, hk⟩
+  exact hz ⟨![0, k], by simp [om, hk]⟩
+
+lemma ne_zero_of_not_isLatticePt {z : ℂ} (hz : ¬ IsLatticePt τ z) : z ≠ 0 := by
+  rintro rfl
+  exact hz ⟨0, by simp [om]⟩
+
+lemma intComp_mul_of_ne_zero (τ : ℍ) {m : ℤ} (hm : m ≠ 0) : (m : ℂ) * τ ∈ ℂ_ℤ := by
+  rw [Complex.mem_integerComplement_iff]
+  rintro ⟨k, hk⟩
+  have := congr_arg Complex.im hk
+  simp only [Complex.intCast_im, Complex.mul_im, Complex.intCast_re, UpperHalfPlane.coe_im,
+    UpperHalfPlane.coe_re, zero_mul, add_zero] at this
+  have h2 : (m : ℝ) * τ.im ≠ 0 := mul_ne_zero (by exact_mod_cast hm) τ.im_ne_zero
+  exact h2 this.symm
+
+variable (τ)
+
+def E2row (m : ℤ) : ℂ := ∑' n : ℤ, 1 / ((m : ℂ) * τ + n) ^ 2
+
+lemma summable_E2row_summand (m : ℤ) : Summable fun n : ℤ => 1 / ((m : ℂ) * τ + n) ^ 2 := by
+  simpa [one_div] using linear_right_summable (τ : ℂ) m (k := 2) le_rfl
+
+lemma E2row_eq_e2Summand (m : ℤ) : E2row τ m = e2Summand m τ := by
+  simp only [E2row, e2Summand, eisSummand, one_div]
+  refine tsum_congr fun n => ?_
+  simp [zpow_ofNat]
+
+lemma row_of_ne_zero {z : ℂ} (hz : ¬ IsLatticePt τ z) {m : ℤ} (hm : m ≠ 0) :
+    row τ z m = (π * Complex.cot (π * ((m : ℂ) * τ)) + π * Complex.cot (π * (z - (m : ℂ) * τ))) +
+      z * E2row τ m := by
+  have hw : (m : ℂ) * τ ∈ ℂ_ℤ := intComp_mul_of_ne_zero τ hm
+  have hw' : (m : ℂ) * τ - z ∈ ℂ_ℤ := intComp_of_not_isLatticePt hz m
+  have h1 := hasSum_inv_linear_sub _ _ hw hw'
+  have h2 := (summable_E2row_summand τ m).hasSum
+  have h3 := h1.add (h2.mul_left z)
+  rw [row]
+  have hv : ∀ n : ℤ, (![m, n] : Fin 2 → ℤ) ≠ 0 := by
+    intro n h
+    have := congr_fun h 0
+    simp [hm] at this
+  have key : ∀ n : ℤ, zterm τ z ![m, n] =
+      (1 / ((m : ℂ) * τ + n) - 1 / ((m : ℂ) * τ - z + n)) + z * (1 / ((m : ℂ) * τ + n) ^ 2) := by
+    intro n
+    rw [zterm, ite_eq_right (hv n)]
+    simp only [om, Matrix.cons_val_zero, Matrix.cons_val_one]
+    have e1 : z - ((m : ℂ) * τ + n) = -((m : ℂ) * τ - z + n) := by ring
+    rw [e1, one_div_neg_eq_neg_one_div]
+    ring
+  rw [tsum_congr key, h3.tsum_eq, E2row]
+  congr 1
+  rw [show π * ((m : ℂ) * τ - z) = -(π * (z - (m : ℂ) * τ)) by ring, cot_neg]
+  ring
+
+def azero (z : ℂ) (n : ℤ) : ℂ := if n = 0 then 0 else 1 / (z - n) + 1 / n
+
+lemma tsum_azero {z : ℂ} (hzC : z ∈ ℂ_ℤ) (has : Summable (azero z)) :
+    ∑' n, azero z n = π * Complex.cot (π * z) - 1 / z := by
+  have hnat : Summable fun n : ℕ => azero z n := has.comp_injective Nat.cast_injective
+  have hneg : Summable fun n : ℕ => azero z (-(n + 1 : ℤ)) :=
+    has.comp_injective (fun x y hxy => by simpa using hxy)
+  have hnat1 : Summable fun n : ℕ => azero z ((n + 1 : ℕ) : ℤ) :=
+    has.comp_injective (fun x y hxy => by simpa using hxy)
+  rw [tsum_of_nat_of_neg_add_one hnat hneg, hnat.tsum_eq_zero_add]
+  have key : ∀ n : ℕ, azero z ((n + 1 : ℕ) : ℤ) + azero z (-(n + 1 : ℤ)) = cotTerm z n := by
+    intro n
+    have h1 : ((n + 1 : ℕ) : ℤ) ≠ 0 := by omega
+    have h2 : (-(n + 1 : ℤ)) ≠ 0 := by omega
+    have h3 : ((n : ℂ) + 1) ≠ 0 := Nat.cast_add_one_ne_zero n
+    have h4 : z - ((n : ℂ) + 1) ≠ 0 := by
+      simpa [sub_eq_add_neg] using integerComplement_add_ne_zero hzC (-(n + 1) : ℤ)
+    have h5 : z + ((n : ℂ) + 1) ≠ 0 := by
+      simpa using integerComplement_add_ne_zero hzC ((n : ℤ) + 1)
+    simp only [azero, ite_eq_right h1, ite_eq_right h2, cotTerm]
+    push_cast
+    simp only [sub_neg_eq_add, div_neg, one_div]
+    ring
+  rw [add_assoc, ← hnat1.tsum_add hneg, tsum_congr key, ← cot_series_rep' hzC]
+  simp [azero]
+
+lemma row_zero {z : ℂ} (hz : ¬ IsLatticePt τ z) :
+    row τ z 0 = (π * Complex.cot (π * z) - 1 / z) + z * E2row τ 0 := by
+  have hzC : z ∈ ℂ_ℤ := intComp_self_of_not_isLatticePt hz
+  have hkey : ∀ n : ℤ, zterm τ z ![0, n] = azero z n + z * (1 / (((0 : ℤ) : ℂ) * τ + n) ^ 2) := by
+    intro n
+    by_cases hn : n = 0
+    · subst hn
+      have h00 : (![0, 0] : Fin 2 → ℤ) = 0 := by
+        funext i; fin_cases i <;> rfl
+      rw [zterm, ite_eq_left h00]
+      simp [azero]
+    · have hv : (![0, n] : Fin 2 → ℤ) ≠ 0 := by
+        intro h; exact hn (by simpa using congr_fun h 1)
+      rw [zterm, ite_eq_right hv, azero, ite_eq_right hn]
+      simp only [om, Matrix.cons_val_zero, Matrix.cons_val_one, Int.cast_zero, zero_mul,
+        zero_add]
+      ring
+  have hbs := summable_E2row_summand τ 0
+  have has : Summable (azero z) := by
+    have : Summable fun n : ℤ => zterm τ z ![0, n] - z * (1 / (((0 : ℤ) : ℂ) * τ + n) ^ 2) :=
+      (summable_zterm_right τ z 0).sub (hbs.mul_left z)
+    apply this.congr
+    intro n; rw [hkey]; ring
+  rw [row, tsum_congr hkey, has.tsum_add (hbs.mul_left z), tsum_mul_left, tsum_azero hzC has,
+    E2row]
+
+lemma norm_cexp_two_pi_I (w : ℂ) : ‖cexp (2 * π * I * w)‖ = Real.exp (-2 * π * w.im) := by
+  rw [Complex.norm_exp]
+  congr 1
+  simp [Complex.mul_re, Complex.mul_im, mul_comm]
+
+lemma pi_cot_add_eq (w : ℂ) (hq : cexp (2 * π * I * w) ≠ 1) :
+    π * Complex.cot (π * w) + π * I =
+      2 * π * cexp (2 * π * I * w) / (I * (1 - cexp (2 * π * I * w))) := by
+  rw [Complex.cot_pi_eq_exp_ratio]
+  set q := cexp (2 * π * I * w) with hq_def
+  have h1 : (1 - q) ≠ 0 := sub_ne_zero.mpr (Ne.symm hq)
+  have h2 : I * (1 - q) ≠ 0 := mul_ne_zero I_ne_zero h1
+  rw [eq_div_iff h2, add_mul, mul_assoc, div_mul_cancel₀ _ h2]
+  ring_nf
+  rw [I_sq]
+  ring
+
+lemma norm_pi_cot_add_le {w : ℂ} {Y : ℝ} (hY : 0 < Y) (hw : Y ≤ w.im) :
+    ‖π * Complex.cot (π * w) + π * I‖ ≤
+      2 * π * Real.exp (-2 * π * w.im) / (1 - Real.exp (-2 * π * Y)) := by
+  have hq : ‖cexp (2 * π * I * w)‖ = Real.exp (-2 * π * w.im) := norm_cexp_two_pi_I w
+  have hqY : Real.exp (-2 * π * w.im) ≤ Real.exp (-2 * π * Y) := by
+    apply Real.exp_le_exp.mpr
+    nlinarith [Real.pi_pos]
+  have hY1 : Real.exp (-2 * π * Y) < 1 := by
+    rw [Real.exp_lt_one_iff]
+    nlinarith [Real.pi_pos]
+  have hq1 : ‖cexp (2 * π * I * w)‖ < 1 := by rw [hq]; linarith
+  have hne : cexp (2 * π * I * w) ≠ 1 := by
+    intro h; rw [h, norm_one] at hq1; exact lt_irrefl _ hq1
+  rw [pi_cot_add_eq w hne, norm_div, norm_mul, norm_mul, norm_mul, Complex.norm_I, one_mul,
+    Complex.norm_two, Complex.norm_real, Real.norm_of_nonneg Real.pi_pos.le, hq]
+  have hden : 1 - Real.exp (-2 * π * Y) ≤ ‖1 - cexp (2 * π * I * w)‖ := by
+    calc 1 - Real.exp (-2 * π * Y) ≤ 1 - ‖cexp (2 * π * I * w)‖ := by rw [hq]; linarith
+      _ = ‖(1 : ℂ)‖ - ‖cexp (2 * π * I * w)‖ := by rw [norm_one]
+      _ ≤ ‖1 - cexp (2 * π * I * w)‖ := norm_sub_norm_le _ _
+  have hpos : 0 < 1 - Real.exp (-2 * π * Y) := by linarith
+  exact div_le_div_of_nonneg_left (by positivity) hpos hden
+
+lemma norm_pi_cot_sub_le {w : ℂ} {Y : ℝ} (hY : 0 < Y) (hw : w.im ≤ -Y) :
+    ‖π * Complex.cot (π * w) - π * I‖ ≤
+      2 * π * Real.exp (2 * π * w.im) / (1 - Real.exp (-2 * π * Y)) := by
+  have hw' : Y ≤ (-w).im := by simp; linarith
+  have := norm_pi_cot_add_le hY hw'
+  rw [show π * (-w) = -(π * w) by ring, cot_neg] at this
+  rw [show π * Complex.cot (π * w) - π * I = -(π * -Complex.cot (π * w) + π * I) by ring, norm_neg]
+  simpa using this
+
+def crow (z : ℂ) (m : ℤ) : ℂ :=
+  if m = 0 then π * Complex.cot (π * z) - 1 / z
+  else π * Complex.cot (π * ((m : ℂ) * τ)) + π * Complex.cot (π * (z - (m : ℂ) * τ))
+
+lemma row_eq_crow_add {z : ℂ} (hz : ¬ IsLatticePt τ z) (m : ℤ) :
+    row τ z m = crow τ z m + z * E2row τ m := by
+  by_cases hm : m = 0
+  · subst hm; rw [row_zero τ hz, crow, ite_eq_left rfl]
+  · rw [row_of_ne_zero τ hz hm, crow, ite_eq_right hm]
+
+lemma im_int_mul (m : ℤ) : ((m : ℂ) * τ).im = m * τ.im := by simp
+
+lemma summable_crow_nat (z : ℂ) : Summable fun n : ℕ => crow τ z n := by
+  have hτ : 0 < τ.im := τ.2
+  set ρ : ℝ := Real.exp (-2 * π * τ.im) with hρ
+  have hρ0 : 0 ≤ ρ := (Real.exp_pos _).le
+  have hρ1 : ρ < 1 := by rw [hρ, Real.exp_lt_one_iff]; nlinarith [Real.pi_pos]
+  set K : ℝ := 1 - ρ with hK
+  have hKpos : 0 < K := by rw [hK]; linarith
+  set A : ℝ := 2 * π / K * (1 + Real.exp (2 * π * z.im)) with hA
+  refine Summable.of_norm_bounded_eventually (g := fun n : ℕ => A * ρ ^ n)
+    ((summable_geometric_of_lt_one hρ0 hρ1).mul_left A) ?_
+  obtain ⟨N₀, hN₀⟩ : ∃ N₀ : ℕ, z.im / τ.im + 1 ≤ N₀ := exists_nat_ge _
+  rw [Nat.cofinite_eq_atTop, Filter.eventually_atTop]
+  refine ⟨max N₀ 1, fun n hn => ?_⟩
+  have hn1 : 1 ≤ n := le_of_max_le_right hn
+  have hn0 : (n : ℤ) ≠ 0 := by omega
+  have hnN : (N₀ : ℝ) ≤ n := by exact_mod_cast le_of_max_le_left hn
+  rw [crow, ite_eq_right hn0]
+  have hIm1 : τ.im ≤ (((n : ℤ) : ℂ) * τ).im := by
+    rw [im_int_mul]; push_cast
+    have : (1 : ℝ) ≤ n := by exact_mod_cast hn1
+    nlinarith
+  have hIm2 : (z - ((n : ℤ) : ℂ) * τ).im ≤ -τ.im := by
+    rw [Complex.sub_im, im_int_mul]; push_cast
+    have h1 : z.im / τ.im + 1 ≤ n := le_trans hN₀ hnN
+    have h2 := (div_le_iff₀ hτ).mp (by linarith : z.im / τ.im ≤ n - 1)
+    nlinarith
+  have hb1 := norm_pi_cot_add_le hτ hIm1
+  have hb2 := norm_pi_cot_sub_le hτ hIm2
+  have hsplit : π * Complex.cot (π * (((n : ℤ) : ℂ) * τ)) + π * Complex.cot (π * (z - ((n : ℤ) : ℂ)
+    * τ)) =
+      (π * Complex.cot (π * (((n : ℤ) : ℂ) * τ)) + π * I) +
+        (π * Complex.cot (π * (z - ((n : ℤ) : ℂ) * τ)) - π * I) := by ring
+  rw [hsplit]
+  refine (norm_add_le _ _).trans ?_
+  have e1 : Real.exp (-2 * π * (((n : ℤ) : ℂ) * τ).im) = ρ ^ n := by
+    rw [im_int_mul, hρ, ← Real.exp_nat_mul]; push_cast; ring_nf
+  have e2 : Real.exp (2 * π * (z - ((n : ℤ) : ℂ) * τ).im) = Real.exp (2 * π * z.im) * ρ ^ n := by
+    rw [Complex.sub_im, im_int_mul, hρ, ← Real.exp_nat_mul, ← Real.exp_add]; push_cast; ring_nf
+  rw [e1] at hb1
+  rw [e2] at hb2
+  calc _ ≤ 2 * π * ρ ^ n / (1 - ρ) + 2 * π * (Real.exp (2 * π * z.im) * ρ ^ n) / (1 - ρ) :=
+        add_le_add hb1 hb2
+    _ = A * ρ ^ n := by rw [hA, hK]; field_simp
+
+lemma summable_crow_neg (z : ℂ) : Summable fun n : ℕ => crow τ z (-n) := by
+  have hτ : 0 < τ.im := τ.2
+  set ρ : ℝ := Real.exp (-2 * π * τ.im) with hρ
+  have hρ0 : 0 ≤ ρ := (Real.exp_pos _).le
+  have hρ1 : ρ < 1 := by rw [hρ, Real.exp_lt_one_iff]; nlinarith [Real.pi_pos]
+  set K : ℝ := 1 - ρ with hK
+  have hKpos : 0 < K := by rw [hK]; linarith
+  set A : ℝ := 2 * π / K * (1 + Real.exp (-2 * π * z.im)) with hA
+  refine Summable.of_norm_bounded_eventually (g := fun n : ℕ => A * ρ ^ n)
+    ((summable_geometric_of_lt_one hρ0 hρ1).mul_left A) ?_
+  obtain ⟨N₀, hN₀⟩ : ∃ N₀ : ℕ, -z.im / τ.im + 1 ≤ N₀ := exists_nat_ge _
+  rw [Nat.cofinite_eq_atTop, Filter.eventually_atTop]
+  refine ⟨max N₀ 1, fun n hn => ?_⟩
+  have hn1 : 1 ≤ n := le_of_max_le_right hn
+  have hn0 : (-(n : ℤ)) ≠ 0 := by omega
+  have hnN : (N₀ : ℝ) ≤ n := by exact_mod_cast le_of_max_le_left hn
+  rw [crow, ite_eq_right hn0]
+  have hIm1 : τ.im ≤ (((n : ℤ) : ℂ) * τ).im := by
+    rw [im_int_mul]; push_cast
+    have : (1 : ℝ) ≤ n := by exact_mod_cast hn1
+    nlinarith
+  have hIm2 : τ.im ≤ (z + ((n : ℤ) : ℂ) * τ).im := by
+    rw [Complex.add_im, im_int_mul]; push_cast
+    have h1 : -z.im / τ.im + 1 ≤ n := le_trans hN₀ hnN
+    have h2 := (div_le_iff₀ hτ).mp (by linarith : -z.im / τ.im ≤ n - 1)
+    nlinarith
+  have hb1 := norm_pi_cot_add_le hτ hIm1
+  have hb2 := norm_pi_cot_add_le hτ hIm2
+  have hsplit : π * Complex.cot (π * (((-(n : ℤ) : ℤ) : ℂ) * τ)) +
+      π * Complex.cot (π * (z - ((-(n : ℤ) : ℤ) : ℂ) * τ)) =
+      (π * Complex.cot (π * (z + ((n : ℤ) : ℂ) * τ)) + π * I) -
+        (π * Complex.cot (π * (((n : ℤ) : ℂ) * τ)) + π * I) := by
+    push_cast
+    rw [show π * (-(n : ℂ) * τ) = -(π * ((n : ℂ) * τ)) by ring, cot_neg]
+    ring_nf
+  rw [hsplit]
+  refine (norm_sub_le _ _).trans ?_
+  have e1 : Real.exp (-2 * π * (((n : ℤ) : ℂ) * τ).im) = ρ ^ n := by
+    rw [im_int_mul, hρ, ← Real.exp_nat_mul]; push_cast; ring_nf
+  have e2 : Real.exp (-2 * π * (z + ((n : ℤ) : ℂ) * τ).im) = Real.exp (-2 * π * z.im) * ρ ^ n := by
+    rw [Complex.add_im, im_int_mul, hρ, ← Real.exp_nat_mul, ← Real.exp_add]; push_cast; ring_nf
+  rw [e2] at hb2
+  rw [e1] at hb1
+  calc _ ≤ 2 * π * (Real.exp (-2 * π * z.im) * ρ ^ n) / (1 - ρ) + 2 * π * ρ ^ n / (1 - ρ) :=
+        add_le_add hb2 hb1
+    _ = A * ρ ^ n := by rw [hA, hK]; field_simp; try ring_nf
+
+lemma summable_crow (z : ℂ) : Summable (crow τ z) :=
+  summable_int_iff_summable_nat_and_neg.mpr ⟨summable_crow_nat τ z, summable_crow_neg τ z⟩
+
+lemma not_isLatticePt_half : ¬ IsLatticePt τ (1 / 2 : ℂ) := by
+  rintro ⟨v, hv⟩
+  have him := congr_arg Complex.im hv
+  simp only [om, Complex.add_im, Complex.mul_im, Complex.intCast_re, Complex.intCast_im,
+    UpperHalfPlane.coe_im, UpperHalfPlane.coe_re, zero_mul, add_zero] at him
+  norm_num at him
+  have hv0 : v 0 = 0 := by
+    rcases him with h | h
+    · exact_mod_cast h
+    · exact absurd h τ.im_ne_zero
+  have hre := congr_arg Complex.re hv
+  simp only [om, hv0, Int.cast_zero, zero_mul, zero_add] at hre
+  norm_num at hre
+  have h2 : (2 : ℝ) * (v 1 : ℤ) = 1 := by rw [← hre]; norm_num
+  have h3 : (2 * v 1 : ℤ) = 1 := by exact_mod_cast h2
+  omega
+
+lemma summable_E2row : Summable (E2row τ) := by
+  set z : ℂ := 1 / 2 with hzdef
+  have hz : ¬ IsLatticePt τ z := not_isLatticePt_half τ
+  have hz0 : z ≠ 0 := by rw [hzdef]; norm_num
+  have h : Summable fun m => z * E2row τ m := by
+    have := (summable_row τ z).sub (summable_crow τ z)
+    apply this.congr
+    intro m; rw [row_eq_crow_add τ hz]; ring
+  have := h.mul_left z⁻¹
+  simpa [hz0] using this
+
+lemma hasSum_E2row : HasSum (E2row τ) (G2 τ) := by
+  have h1 : HasSum (E2row τ) (∑' m, E2row τ m) (SummationFilter.symmetricIcc ℤ) :=
+    (summable_E2row τ).hasSum.mono_left (SummationFilter.symmetricIcc ℤ).le_atTop
+  have h2 : HasSum (e2Summand · τ) (G2 τ) (SummationFilter.symmetricIcc ℤ) := by
+    rw [G2_eq_tsum_cexp]; exact hasSum_e2Summand_symmetricIcc τ
+  have h3 : (E2row τ) = (e2Summand · τ) := funext (E2row_eq_e2Summand τ)
+  rw [h3] at h1 ⊢
+  rw [← h1.unique h2]
+  exact (h3 ▸ summable_E2row τ).hasSum
+
+theorem hasSum_weierstrassZeta_sub {z : ℂ} (hz : ¬ IsLatticePt τ z) :
+    HasSum (fun m : ℕ => π * Complex.cot (π * (z + ((m : ℂ) + 1) * τ)) +
+        π * Complex.cot (π * (z - ((m : ℂ) + 1) * τ)))
+      (weierstrassZeta τ z - z * G2 τ - π * Complex.cot (π * z)) := by
+  have hrow : ∑' m, row τ z m = ∑' m, crow τ z m + z * G2 τ := by
+    rw [tsum_congr (row_eq_crow_add τ hz), (summable_crow τ z).tsum_add
+      ((summable_E2row τ).mul_left z), tsum_mul_left, (hasSum_E2row τ).tsum_eq]
+  have hZ : weierstrassZeta τ z - z * G2 τ = 1 / z + ∑' m, crow τ z m := by
+    rw [weierstrassZeta_eq, tsum_zterm_eq_tsum_row, hrow]; ring
+  have hC := summable_crow τ z
+  have hnat : Summable fun n : ℕ => crow τ z n := hC.comp_injective Nat.cast_injective
+  have hnat1 : Summable fun n : ℕ => crow τ z ((n + 1 : ℕ) : ℤ) :=
+    hC.comp_injective (fun x y hxy => by simpa using hxy)
+  have hneg : Summable fun n : ℕ => crow τ z (-(n + 1 : ℤ)) :=
+    hC.comp_injective (fun x y hxy => by simpa using hxy)
+  have htot : ∑' m, crow τ z m =
+      crow τ z 0 + ∑' n : ℕ, (crow τ z ((n + 1 : ℕ) : ℤ) + crow τ z (-(n + 1 : ℤ))) := by
+    rw [tsum_of_nat_of_neg_add_one hnat hneg, hnat.tsum_eq_zero_add, add_assoc,
+      hnat1.tsum_add hneg]
+    push_cast
+    rfl
+  have key : ∀ n : ℕ, crow τ z ((n + 1 : ℕ) : ℤ) + crow τ z (-(n + 1 : ℤ)) =
+      π * Complex.cot (π * (z + ((n : ℂ) + 1) * τ)) +
+        π * Complex.cot (π * (z - ((n : ℂ) + 1) * τ)) := by
+    intro n
+    have h1 : ((n + 1 : ℕ) : ℤ) ≠ 0 := by omega
+    have h2 : (-(n + 1 : ℤ)) ≠ 0 := by omega
+    rw [crow, ite_eq_right h1, crow, ite_eq_right h2]
+    push_cast
+    rw [show π * (-((n : ℂ) + 1) * τ) = -(π * (((n : ℂ) + 1) * τ)) by ring, cot_neg]
+    ring_nf
+  have h0 : crow τ z 0 = π * Complex.cot (π * z) - 1 / z := by simp [crow]
+  have hs : Summable fun n : ℕ => π * Complex.cot (π * (z + ((n : ℂ) + 1) * τ)) +
+      π * Complex.cot (π * (z - ((n : ℂ) + 1) * τ)) := (hnat1.add hneg).congr key
+  convert hs.hasSum using 1
+  rw [hZ, htot, h0, ← tsum_congr key]
+  ring
+
+end WZA
+
+end
+
+theorem solution (τ : UpperHalfPlane) (z : ℂ)
+    (hz : ∀ v : Fin 2 → ℤ, z ≠ (v 0 : ℂ) * τ + v 1) :
+    HasSum (fun m : ℕ => π * Complex.cot (π * (z + ((m : ℂ) + 1) * τ)) +
+        π * Complex.cot (π * (z - ((m : ℂ) + 1) * τ)))
+      (EisensteinSeries.weierstrassZeta τ z - z * EisensteinSeries.G2 τ -
+        π * Complex.cot (π * z)) := by
+  have hz' : ¬ WZA.IsLatticePt τ z := by
+    rintro ⟨v, hv⟩
+    exact hz v (by simpa [WZA.om] using hv)
+  exact WZA.hasSum_weierstrassZeta_sub τ hz'
+
+end S_EisensteinSeries_hasSum_weierstrassZeta_sub_mul_G2
+end P2MW
+export P2MW.S_EisensteinSeries_hasSum_weierstrassZeta_sub_mul_G2 (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Real
+theorem EisensteinSeries.hasSum_weierstrassZeta_sub_mul_G2 (τ : UpperHalfPlane) (z : ℂ)
+    (hz : ∀ v : Fin 2 → ℤ, z ≠ (v 0 : ℂ) * τ + v 1) :
+    HasSum (fun m : ℕ => π * Complex.cot (π * (z + ((m : ℂ) + 1) * τ)) +
+        π * Complex.cot (π * (z - ((m : ℂ) + 1) * τ)))
+      (EisensteinSeries.weierstrassZeta τ z - z * EisensteinSeries.G2 τ -
+        π * Complex.cot (π * z)) :=
+  solution τ z hz
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinSeries_isBoundedAtImInfty_eisensteinG1_and_hasSum_eisensteinG1.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinSeries_isBoundedAtImInfty_eisensteinG1_and_hasSum_eisensteinG1.lean
new file mode 100644
index 0000000000..f0368ae268
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinSeries_isBoundedAtImInfty_eisensteinG1_and_hasSum_eisensteinG1.lean
@@ -0,0 +1,624 @@
+/-
+Based on Prove2Me node EisensteinSeries.isBoundedAtImInfty_eisensteinG1_and_hasSum_eisensteinG1
+(e0e677e3-63c7-5e91-858c-f661bdd1468a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6567b791-59e4-5f00-8ce3-0c993224cf14
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.Complex.UpperHalfPlane.FunctionsBoundedAtInfty
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EisensteinSeries_WeierstrassZeta
+
+import Mathlib.Analysis.SpecialFunctions.Trigonometric.Cotangent
+import Mathlib.Analysis.Complex.UpperHalfPlane.Exp
+import Mathlib.NumberTheory.TsumDivisorsAntidiagonal
+import Mathlib.Topology.UniformSpace.Uniformizable
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_EisensteinSeries_hasSum_weierstrassZeta_sub_mul_G2
+import LeanPool.FLTEichlerShimura.Theorems.Thm_EisensteinSeries_eisensteinG1_apply_smul_and_eisensteinG1_add
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Boundedness at i∞ and q-expansion of g₁^v
+
+Theorem statement: `EisensteinSeries.isBoundedAtImInfty_eisensteinG1_and_hasSum_eisensteinG1`
+(`e0e677e3-63c7-5e91-858c-f661bdd1468a`), by Claude, 2026-09-05.
+
+Proof: submission `6567b791-59e4-5f00-8ce3-0c993224cf14`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a non-zero natural number. For $v=(v_0,v_1)\in\mathbb Z^2$ write $g_1^{v}$ for the
+function on the upper half-plane given by
+[`EisensteinSeries.eisensteinG1`](def/EisensteinSeries_WeierstrassZeta.html#L9), namely
+$$g_1^{v}(\tau)=\frac1N\Bigl(Z\bigl(\tau,\tfrac{v_0\tau+v_1}{N}\bigr)-\frac{v_0\,(\tau\,G_2(\tau)-2
+\pi
+i)+v_1\,G_2(\tau)}{N}\Bigr),$$ where $Z(\tau,z)=\frac1z+\sum_{v\in\mathbb
+Z^2,\,v\neq0}\bigl(\frac1{z-(v_0\tau+v_1)}+\frac1{v_0\tau+v_1}+\frac{z}{(v_0\tau+v_1)^2}\bigr)$ is
+the Weierstrass zeta function of the lattice $\mathbb Z\tau+\mathbb Z$ (the sum being a `tsum`), and
+$G_2$ is the function `EisensteinSeries.G2` supplying the quasi-period normalisation. The theorem
+asserts two statements. First, for every $v\colon\mathrm{Fin}\,2\to\mathbb Z$ such that it is not
+the case that $N$ divides every component $v_i$, the function $g_1^{v}$ is bounded at $i\infty$ in
+the sense of `UpperHalfPlane.IsBoundedAtImInfty`. Second, for every $b\in\mathbb Z$ with $N\nmid b$
+and every $\tau$ in the upper half-plane, the $\mathbb N$-indexed family whose $n$-th term is
+$c_n\,e^{2\pi i\tau n}$, with $c_0=\frac{\pi}{N}\cot\bigl(\frac{\pi b}{N}\bigr)$ and, for $n\geq1$,
+$c_n=-\frac{2\pi i}{N}\sum_{k\mid n}\bigl(e^{2\pi i b k/N}-e^{-2\pi i b k/N}\bigr)$ (the sum over
+the divisors of $n$), has sum $g_1^{(0,b)}(\tau)$, where $(0,b)$ is the vector `![0, b]`.
+
+This is the classical analytic input on the weight-one Eisenstein functions $g_1^{v}$ of level $N$:
+boundedness at the cusp $i\infty$, which together with the transformation law
+$g_1^{v}(\gamma\tau)=(c\tau+d)\,g_1^{v\gamma}(\tau)$ gives boundedness at all cusps, and the
+$q$-expansion in the case $v=(0,b)$, which has no fractional powers of $q$. It is used in the
+construction of weight-one Eisenstein series with nebentypus and their $q$-expansion coefficients,
+via
+[`ModularForm.exists_weightOne_eisenstein_qCoeff_eq_of_isPrimitive_of_odd`]
+(thm.html#ModularForm.exists_weightOne_eisenstein_qCoeff_eq_of_isPrimitive_of_odd).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_EisensteinSeries_isBoundedAtImInfty_eisensteinG1_and_hasSum_eisensteinG1.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_EisensteinSeries_isBoundedAtImInfty_eisensteinG1_and_hasSum_eisensteinG1
+
+open scoped Topology Real MatrixGroups Matrix
+p2m_open "UpperHalfPlane~I"
+open EisensteinSeries Filter Complex
+
+noncomputable section
+
+namespace WZD
+
+local notation "ℂ_ℤ" => Complex.integerComplement
+
+lemma cot_neg (x : ℂ) : Complex.cot (-x) = -Complex.cot x := by
+  simp [Complex.cot_eq_cos_div_sin, Complex.sin_neg, Complex.cos_neg, div_neg]
+
+lemma norm_cexp_two_pi_I (w : ℂ) : ‖cexp (2 * π * I * w)‖ = Real.exp (-2 * π * w.im) := by
+  rw [Complex.norm_exp]
+  congr 1
+  simp [Complex.mul_re, Complex.mul_im, mul_comm]
+
+lemma pi_cot_add_eq (w : ℂ) (hq : cexp (2 * π * I * w) ≠ 1) :
+    π * Complex.cot (π * w) + π * I =
+      2 * π * cexp (2 * π * I * w) / (I * (1 - cexp (2 * π * I * w))) := by
+  rw [Complex.cot_pi_eq_exp_ratio]
+  set q := cexp (2 * π * I * w) with hq_def
+  have h1 : (1 - q) ≠ 0 := sub_ne_zero.mpr (Ne.symm hq)
+  have h2 : I * (1 - q) ≠ 0 := mul_ne_zero I_ne_zero h1
+  rw [eq_div_iff h2, add_mul, mul_assoc, div_mul_cancel₀ _ h2]
+  ring_nf
+  rw [I_sq]
+  ring
+
+lemma norm_pi_cot_add_le {w : ℂ} {Y : ℝ} (hY : 0 < Y) (hw : Y ≤ w.im) :
+    ‖π * Complex.cot (π * w) + π * I‖ ≤
+      2 * π * Real.exp (-2 * π * w.im) / (1 - Real.exp (-2 * π * Y)) := by
+  have hq : ‖cexp (2 * π * I * w)‖ = Real.exp (-2 * π * w.im) := norm_cexp_two_pi_I w
+  have hqY : Real.exp (-2 * π * w.im) ≤ Real.exp (-2 * π * Y) := by
+    apply Real.exp_le_exp.mpr
+    nlinarith [Real.pi_pos]
+  have hY1 : Real.exp (-2 * π * Y) < 1 := by
+    rw [Real.exp_lt_one_iff]
+    nlinarith [Real.pi_pos]
+  have hq1 : ‖cexp (2 * π * I * w)‖ < 1 := by rw [hq]; linarith
+  have hne : cexp (2 * π * I * w) ≠ 1 := by
+    intro h; rw [h, norm_one] at hq1; exact lt_irrefl _ hq1
+  rw [pi_cot_add_eq w hne, norm_div, norm_mul, norm_mul, norm_mul, Complex.norm_I, one_mul,
+    Complex.norm_two, Complex.norm_real, Real.norm_of_nonneg Real.pi_pos.le, hq]
+  have hden : 1 - Real.exp (-2 * π * Y) ≤ ‖1 - cexp (2 * π * I * w)‖ := by
+    calc 1 - Real.exp (-2 * π * Y) ≤ 1 - ‖cexp (2 * π * I * w)‖ := by rw [hq]; linarith
+      _ = ‖(1 : ℂ)‖ - ‖cexp (2 * π * I * w)‖ := by rw [norm_one]
+      _ ≤ ‖1 - cexp (2 * π * I * w)‖ := norm_sub_norm_le _ _
+  have hpos : 0 < 1 - Real.exp (-2 * π * Y) := by linarith
+  exact div_le_div_of_nonneg_left (by positivity) hpos hden
+
+lemma norm_pi_cot_sub_le {w : ℂ} {Y : ℝ} (hY : 0 < Y) (hw : w.im ≤ -Y) :
+    ‖π * Complex.cot (π * w) - π * I‖ ≤
+      2 * π * Real.exp (2 * π * w.im) / (1 - Real.exp (-2 * π * Y)) := by
+  have hw' : Y ≤ (-w).im := by simp; linarith
+  have := norm_pi_cot_add_le hY hw'
+  rw [show π * (-w) = -(π * w) by ring, cot_neg] at this
+  rw [show π * Complex.cot (π * w) - π * I = -(π * -Complex.cot (π * w) + π * I) by ring, norm_neg]
+  simpa using this
+
+lemma hasSum_pi_cot_add {w : ℂ} (hw : 0 < w.im) :
+    HasSum (fun k : ℕ+ => -2 * π * I * cexp (2 * π * I * w) ^ (k : ℕ))
+      (π * Complex.cot (π * w) + π * I) := by
+  have hq1 : ‖cexp (2 * π * I * w)‖ < 1 := by
+    simpa using UpperHalfPlane.norm_exp_two_pi_I_lt_one ⟨w, hw⟩
+  have hgeom : Summable fun n : ℕ => cexp (2 * π * I * w) ^ n :=
+    summable_geometric_of_norm_lt_one hq1
+  have h := pi_mul_cot_pi_q_exp ⟨w, hw⟩
+  simp only [] at h
+  rw [hgeom.tsum_eq_zero_add, ← tsum_pnat_eq_tsum_succ (f := fun n => cexp (2 * π * I * w) ^ n)]
+    at h
+  have hs : Summable fun k : ℕ+ => -2 * π * I * cexp (2 * π * I * w) ^ (k : ℕ) :=
+    (hgeom.subtype _).mul_left _
+  convert hs.hasSum using 1
+  rw [tsum_mul_left, h]
+  ring
+
+variable (N : ℕ) [NeZero N] (τ : ℍ)
+
+def om (v : Fin 2 → ℤ) : ℂ := (v 0 : ℂ) * τ + v 1
+
+def NotLat (τ : ℍ) (z : ℂ) : Prop := ∀ v : Fin 2 → ℤ, z ≠ (v 0 : ℂ) * τ + v 1
+
+lemma om_injective : Function.Injective (om τ) := by
+  intro u v huv
+  have h : om τ (u - v) = 0 := by
+    simp only [om, Pi.sub_apply, Int.cast_sub] at huv ⊢
+    linear_combination huv
+  by_contra hne
+  have hne' : u - v ≠ 0 := sub_ne_zero.mpr hne
+  have := UpperHalfPlane.linear_ne_zero (cd := fun i => ((u - v) i : ℝ)) τ
+    (by
+      intro h0
+      apply hne'
+      funext i
+      have := congr_fun h0 i
+      simp only [Pi.zero_apply] at this ⊢
+      exact_mod_cast this)
+  apply this
+  simpa [om] using h
+
+lemma notLat_of_not_dvd {v : Fin 2 → ℤ} (hv : ¬ ∀ i, (N : ℤ) ∣ v i) :
+    NotLat τ (om τ v / N) := by
+  intro u hu
+  apply hv
+  have hN : (N : ℂ) ≠ 0 := by exact_mod_cast NeZero.ne N
+  have h : om τ v = om τ ((N : ℤ) • u) := by
+    rw [div_eq_iff hN] at hu
+    simp only [om, Pi.smul_apply, smul_eq_mul, Int.cast_mul, Int.cast_natCast] at hu ⊢
+    linear_combination hu
+  have := om_injective τ h
+  intro i
+  rw [this]
+  simp
+
+def pval (z : ℂ) : ℂ := weierstrassZeta τ z - z * G2 τ - π * Complex.cot (π * z)
+
+def ser (z : ℂ) (m : ℕ) : ℂ :=
+  π * Complex.cot (π * (z + ((m : ℂ) + 1) * τ)) + π * Complex.cot (π * (z - ((m : ℂ) + 1) * τ))
+
+lemma hasSum_ser {z : ℂ} (hz : NotLat τ z) : HasSum (ser τ z) (pval τ z) :=
+  EisensteinSeries.hasSum_weierstrassZeta_sub_mul_G2 τ z hz
+
+lemma eisensteinG1_eq (v : Fin 2 → ℤ) :
+    eisensteinG1 N v τ = 1 / (N : ℂ) *
+      (pval τ (om τ v / N) + π * Complex.cot (π * (om τ v / N)) + 2 * π * I * (v 0 : ℂ) / N) := by
+  have hN : (N : ℂ) ≠ 0 := by exact_mod_cast NeZero.ne N
+  unfold eisensteinG1 pval
+  simp only [om]
+  congr 1
+  field_simp
+  ring
+
+omit [NeZero N] in
+lemma dvd_of_dvd_reduce (v : Fin 2 → ℤ) (h : ∀ i, (N : ℤ) ∣ (![v 0 % N, v 1] : Fin 2 → ℤ) i) :
+    ∀ i, (N : ℤ) ∣ v i := by
+  rw [Fin.forall_fin_two] at h ⊢
+  simp only [Matrix.cons_val_zero, Matrix.cons_val_one] at h
+  refine ⟨?_, h.2⟩
+  rw [← Int.emod_add_mul_ediv (v 0) N]
+  exact dvd_add h.1 (dvd_mul_right _ _)
+
+lemma exists_reduce (v : Fin 2 → ℤ) (hv : ¬ ∀ i, (N : ℤ) ∣ v i) :
+    ∃ v' : Fin 2 → ℤ, 0 ≤ v' 0 ∧ v' 0 < N ∧ (¬ ∀ i, (N : ℤ) ∣ v' i) ∧
+      eisensteinG1 N v = eisensteinG1 N v' := by
+  have hN0 : (N : ℤ) ≠ 0 := by exact_mod_cast NeZero.ne N
+  have hNpos : (0 : ℤ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  refine ⟨![v 0 % N, v 1], Int.emod_nonneg _ hN0, Int.emod_lt_of_pos _ hNpos,
+    fun h => hv (dvd_of_dvd_reduce N v h), ?_⟩
+  funext τ'
+  have hper := (EisensteinSeries.eisensteinG1_apply_smul_and_eisensteinG1_add N τ').2
+    ![v 0 % N, v 1] ![v 0 / N, 0] (fun h => hv (dvd_of_dvd_reduce N v h))
+  rw [← hper]
+  congr 1
+  funext i
+  rw [Pi.add_apply, Pi.smul_apply, smul_eq_mul]
+  fin_cases i
+  · change v 0 = v 0 % N + N * (v 0 / N)
+    linarith [Int.mul_ediv_add_emod (v 0) N]
+  · simp
+
+def rho : ℝ := Real.exp (-2 * π)
+
+lemma rho_nonneg : 0 ≤ rho := (Real.exp_pos _).le
+
+lemma rho_lt_one : rho < 1 := by
+  rw [rho, Real.exp_lt_one_iff]; nlinarith [Real.pi_pos]
+
+def Kof (Y : ℝ) : ℝ := 1 - Real.exp (-2 * π * Y)
+
+lemma Kof_pos {Y : ℝ} (hY : 0 < Y) : 0 < Kof Y := by
+  rw [Kof, sub_pos, Real.exp_lt_one_iff]; nlinarith [Real.pi_pos]
+
+lemma norm_ser_le {τ : ℍ} (hτ : 1 ≤ τ.im) {z : ℂ} {α : ℝ} (hα0 : 0 ≤ α)
+    (hα1 : α ≤ 1 - 1 / N) (hzim : z.im = α * τ.im) (m : ℕ) :
+    ‖ser τ z m‖ ≤ (2 * π / Kof 1 + 2 * π / Kof (1 / N)) * rho ^ m := by
+  have hτpos : 0 < τ.im := τ.2
+  have hNpos : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  have hNinv : 0 < 1 / (N : ℝ) := by positivity
+  have hm0 : (0 : ℝ) ≤ m := Nat.cast_nonneg m
+  have hK1 := Kof_pos one_pos
+  have hKN := Kof_pos hNinv
+  have him_add : (z + ((m : ℂ) + 1) * τ).im = (α + (m + 1)) * τ.im := by
+    simp only [Complex.add_im, Complex.mul_im, Complex.add_re, Complex.natCast_re,
+      Complex.one_re, Complex.natCast_im, Complex.one_im, add_zero, UpperHalfPlane.coe_im,
+      UpperHalfPlane.coe_re, zero_mul, hzim]
+    ring
+  have him_sub : (z - ((m : ℂ) + 1) * τ).im = (α - (m + 1)) * τ.im := by
+    simp only [Complex.sub_im, Complex.add_im, Complex.mul_im, Complex.add_re,
+      Complex.natCast_re, Complex.one_re, Complex.natCast_im, Complex.one_im, add_zero,
+      UpperHalfPlane.coe_im, UpperHalfPlane.coe_re, zero_mul, hzim]
+    ring
+  have hατ : 0 ≤ α * τ.im := mul_nonneg hα0 hτpos.le
+  have hIm1 : 1 ≤ (z + ((m : ℂ) + 1) * τ).im := by rw [him_add]; nlinarith
+  have hIm1' : (m : ℝ) ≤ (z + ((m : ℂ) + 1) * τ).im := by rw [him_add]; nlinarith
+  have hA := norm_pi_cot_add_le one_pos hIm1
+  have hexpA : Real.exp (-2 * π * (z + ((m : ℂ) + 1) * τ).im) ≤ rho ^ m := by
+    rw [rho, ← Real.exp_nat_mul]
+    apply Real.exp_le_exp.mpr
+    nlinarith [Real.pi_pos]
+  have hA' : ‖π * Complex.cot (π * (z + ((m : ℂ) + 1) * τ)) + π * I‖ ≤ 2 * π / Kof 1 * rho ^ m := by
+    refine hA.trans ?_
+    rw [show (1 - Real.exp (-2 * π * 1)) = Kof 1 from rfl]
+    calc 2 * π * Real.exp (-2 * π * (z + ((m : ℂ) + 1) * τ).im) / Kof 1
+        ≤ 2 * π * rho ^ m / Kof 1 := by
+          apply div_le_div_of_nonneg_right _ hK1.le
+          exact mul_le_mul_of_nonneg_left hexpA (by positivity)
+      _ = 2 * π / Kof 1 * rho ^ m := by ring
+  have hcoefneg : α - (m + 1) ≤ 0 := by linarith
+  have h3 : (α - (m + 1)) * τ.im ≤ (α - (m + 1)) * 1 := mul_le_mul_of_nonpos_left hτ hcoefneg
+  have hIm2 : (z - ((m : ℂ) + 1) * τ).im ≤ -(1 / N) := by rw [him_sub]; nlinarith
+  have hIm2' : (z - ((m : ℂ) + 1) * τ).im ≤ -m := by rw [him_sub]; nlinarith
+  have hB := norm_pi_cot_sub_le hNinv hIm2
+  have hexpB : Real.exp (2 * π * (z - ((m : ℂ) + 1) * τ).im) ≤ rho ^ m := by
+    rw [rho, ← Real.exp_nat_mul]
+    apply Real.exp_le_exp.mpr
+    nlinarith [Real.pi_pos]
+  have hB' : ‖π * Complex.cot (π * (z - ((m : ℂ) + 1) * τ)) - π * I‖ ≤
+      2 * π / Kof (1 / N) * rho ^ m := by
+    refine hB.trans ?_
+    rw [show (1 - Real.exp (-2 * π * (1 / N))) = Kof (1 / N) from rfl]
+    calc 2 * π * Real.exp (2 * π * (z - ((m : ℂ) + 1) * τ).im) / Kof (1 / N)
+        ≤ 2 * π * rho ^ m / Kof (1 / N) := by
+          apply div_le_div_of_nonneg_right _ hKN.le
+          exact mul_le_mul_of_nonneg_left hexpB (by positivity)
+      _ = 2 * π / Kof (1 / N) * rho ^ m := by ring
+  calc ‖ser τ z m‖ = ‖(π * Complex.cot (π * (z + ((m : ℂ) + 1) * τ)) + π * I) +
+        (π * Complex.cot (π * (z - ((m : ℂ) + 1) * τ)) - π * I)‖ := by
+          simp only [ser]; ring_nf
+    _ ≤ _ := norm_add_le _ _
+    _ ≤ 2 * π / Kof 1 * rho ^ m + 2 * π / Kof (1 / N) * rho ^ m := add_le_add hA' hB'
+    _ = (2 * π / Kof 1 + 2 * π / Kof (1 / N)) * rho ^ m := by ring
+
+lemma norm_pval_le {τ : ℍ} (hτ : 1 ≤ τ.im) {z : ℂ} (hzn : NotLat τ z) {α : ℝ} (hα0 : 0 ≤ α)
+    (hα1 : α ≤ 1 - 1 / N) (hzim : z.im = α * τ.im) :
+    ‖pval τ z‖ ≤ (2 * π / Kof 1 + 2 * π / Kof (1 / N)) * (1 - rho)⁻¹ := by
+  have hgeo : HasSum (fun m : ℕ => (2 * π / Kof 1 + 2 * π / Kof (1 / N)) * rho ^ m)
+      ((2 * π / Kof 1 + 2 * π / Kof (1 / N)) * (1 - rho)⁻¹) :=
+    (hasSum_geometric_of_lt_one rho_nonneg rho_lt_one).mul_left _
+  exact (hasSum_ser τ hzn).norm_le_of_bounded hgeo (norm_ser_le N hτ hα0 hα1 hzim)
+
+lemma norm_pi_cot_le_of_im {z : ℂ} (hIm : 1 / (N : ℝ) ≤ z.im) :
+    ‖π * Complex.cot (π * z)‖ ≤ π + 2 * π / Kof (1 / N) := by
+  have hNpos : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  have hNinv : 0 < 1 / (N : ℝ) := by positivity
+  have hKN := Kof_pos hNinv
+  have h6 := norm_pi_cot_add_le hNinv hIm
+  rw [show (1 - Real.exp (-2 * π * (1 / N))) = Kof (1 / N) from rfl] at h6
+  have h7 : ‖π * Complex.cot (π * z) + π * I‖ ≤ 2 * π / Kof (1 / N) := by
+    refine h6.trans ?_
+    apply div_le_div_of_nonneg_right _ hKN.le
+    have : Real.exp (-2 * π * z.im) ≤ 1 := by
+      rw [Real.exp_le_one_iff]
+      have : 0 ≤ z.im := le_trans hNinv.le hIm
+      nlinarith [Real.pi_pos]
+    nlinarith [Real.pi_pos]
+  calc ‖π * Complex.cot (π * z)‖ = ‖(π * Complex.cot (π * z) + π * I) - π * I‖ := by ring_nf
+    _ ≤ ‖π * Complex.cot (π * z) + π * I‖ + ‖(π : ℂ) * I‖ := norm_sub_le _ _
+    _ ≤ 2 * π / Kof (1 / N) + π := by
+        apply add_le_add h7
+        rw [norm_mul, Complex.norm_real, Complex.norm_I, mul_one,
+          Real.norm_of_nonneg Real.pi_pos.le]
+    _ = π + 2 * π / Kof (1 / N) := by ring
+
+theorem isBoundedAtImInfty_eisensteinG1 (v : Fin 2 → ℤ) (hv : ¬ ∀ i, (N : ℤ) ∣ v i) :
+    IsBoundedAtImInfty (eisensteinG1 N v) := by
+  obtain ⟨v', h0, h1, hv', heq⟩ := exists_reduce N v hv
+  rw [heq]
+  have hN : (N : ℂ) ≠ 0 := by exact_mod_cast NeZero.ne N
+  have hNpos : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  have hα0 : (0 : ℝ) ≤ (v' 0 : ℝ) / N := div_nonneg (by exact_mod_cast h0) hNpos.le
+  have hα1 : (v' 0 : ℝ) / N ≤ 1 - 1 / N := by
+    have : (v' 0 : ℝ) ≤ N - 1 := by
+      have : v' 0 ≤ (N : ℤ) - 1 := by omega
+      exact_mod_cast this
+    rw [div_le_iff₀ hNpos]
+    field_simp
+    nlinarith
+  rw [UpperHalfPlane.isBoundedAtImInfty_iff]
+  refine ⟨1 / N * ((2 * π / Kof 1 + 2 * π / Kof (1 / N)) * (1 - rho)⁻¹ +
+    max (π + 2 * π / Kof (1 / N)) ‖π * Complex.cot (π * ((v' 1 : ℂ) / N))‖ + 2 * π), 1,
+    fun τ hτ => ?_⟩
+  have hτpos : 0 < τ.im := τ.2
+  have hzn : NotLat τ (om τ v' / N) := notLat_of_not_dvd N τ hv'
+  have hzim : (om τ v' / N).im = (v' 0 : ℝ) / N * τ.im := by
+    simp only [om]
+    rw [Complex.div_natCast_im]
+    simp
+    ring
+  have hpval := norm_pval_le N hτ hzn hα0 hα1 hzim
+  have hcot : ‖π * Complex.cot (π * (om τ v' / N))‖ ≤
+      max (π + 2 * π / Kof (1 / N)) ‖π * Complex.cot (π * ((v' 1 : ℂ) / N))‖ := by
+    by_cases ha0 : v' 0 = 0
+    · have : om τ v' / N = ((v' 1 : ℤ) : ℂ) / N := by
+        simp only [om, ha0, Int.cast_zero, zero_mul, zero_add]
+      rw [this]
+      exact le_max_right _ _
+    · refine le_trans (norm_pi_cot_le_of_im N ?_) (le_max_left _ _)
+      rw [hzim]
+      have ha1 : (1 : ℝ) ≤ v' 0 := by
+        have : (1 : ℤ) ≤ v' 0 := by omega
+        exact_mod_cast this
+      calc 1 / (N : ℝ) ≤ (v' 0 : ℝ) / N := div_le_div_of_nonneg_right ha1 hNpos.le
+        _ = (v' 0 : ℝ) / N * 1 := by ring
+        _ ≤ (v' 0 : ℝ) / N * τ.im := mul_le_mul_of_nonneg_left hτ hα0
+  have hconst : ‖2 * π * I * (v' 0 : ℂ) / N‖ ≤ 2 * π := by
+    rw [norm_div, norm_mul, norm_mul, norm_mul, Complex.norm_I, Complex.norm_two,
+      Complex.norm_real, Real.norm_of_nonneg Real.pi_pos.le, Complex.norm_intCast,
+      Complex.norm_natCast, mul_one, div_le_iff₀ hNpos]
+    apply mul_le_mul_of_nonneg_left _ (by positivity)
+    rw [abs_of_nonneg (by exact_mod_cast h0)]
+    exact_mod_cast h1.le
+  rw [eisensteinG1_eq N τ v', norm_mul, norm_div, norm_one, Complex.norm_natCast]
+  apply mul_le_mul_of_nonneg_left _ (by positivity)
+  exact (norm_add_le _ _).trans
+    (add_le_add ((norm_add_le _ _).trans (add_le_add hpval hcot)) hconst)
+
+def Fterm (τ : ℍ) (z : ℂ) (p : ℕ+ × ℕ+) : ℂ :=
+  -(2 * π * I) * (cexp (2 * π * I * (p.2 : ℕ) * z) - cexp (-(2 * π * I * (p.2 : ℕ) * z))) *
+    cexp (2 * π * I * τ) ^ ((p.1 : ℕ) * (p.2 : ℕ))
+
+lemma norm_cexp_real {z : ℂ} (hz : z.im = 0) (k : ℕ) :
+    ‖cexp (2 * π * I * k * z)‖ = 1 ∧ ‖cexp (-(2 * π * I * k * z))‖ = 1 := by
+  have hzre : (z.re : ℂ) = z := by
+    apply Complex.ext <;> simp [hz]
+  have e : 2 * π * I * k * z = ((2 * π * k * z.re : ℝ) : ℂ) * I := by
+    conv_lhs => rw [← hzre]
+    push_cast; ring
+  constructor
+  · rw [e, Complex.norm_exp_ofReal_mul_I]
+  · rw [e, show -((((2 * π * k * z.re : ℝ)) : ℂ) * I) = ((-(2 * π * k * z.re) : ℝ) : ℂ) * I by
+      push_cast; ring, Complex.norm_exp_ofReal_mul_I]
+
+lemma summable_Fterm {z : ℂ} (hz : z.im = 0) : Summable (Fterm τ z) := by
+  have hq1 : ‖cexp (2 * π * I * τ)‖ < 1 := UpperHalfPlane.norm_exp_two_pi_I_lt_one τ
+  have hr' : ‖(‖cexp (2 * π * I * τ)‖ : ℝ)‖ < 1 := by simpa using hq1
+  have := summable_prod_mul_pow 0 hr'
+  simp only [pow_zero, one_mul] at this
+  refine Summable.of_norm_bounded (this.mul_left (4 * π)) fun p => ?_
+  obtain ⟨e1, e2⟩ := norm_cexp_real hz p.2
+  simp only [Fterm, norm_mul, norm_neg, norm_pow, Complex.norm_I, Complex.norm_two, mul_one,
+    Complex.norm_real, Real.norm_of_nonneg Real.pi_pos.le]
+  have : ‖cexp (2 * π * I * (p.2 : ℕ) * z) - cexp (-(2 * π * I * (p.2 : ℕ) * z))‖ ≤ 2 := by
+    refine (norm_sub_le _ _).trans ?_
+    rw [e1, e2]; norm_num
+  calc 2 * π * ‖cexp (2 * π * I * (p.2 : ℕ) * z) - cexp (-(2 * π * I * (p.2 : ℕ) * z))‖ *
+        ‖cexp (2 * π * I * τ)‖ ^ ((p.1 : ℕ) * (p.2 : ℕ))
+      ≤ 2 * π * 2 * ‖cexp (2 * π * I * τ)‖ ^ ((p.1 : ℕ) * (p.2 : ℕ)) := by gcongr
+    _ = 4 * π * ‖cexp (2 * π * I * τ)‖ ^ ((p.1 : ℕ) * (p.2 : ℕ)) := by ring
+
+lemma hasSum_Fterm_row {z : ℂ} (hz : z.im = 0) (m : ℕ+) :
+    HasSum (fun k : ℕ+ => Fterm τ z (m, k))
+      (π * Complex.cot (π * (z + ((m : ℕ) : ℂ) * τ)) +
+        π * Complex.cot (π * (z - ((m : ℕ) : ℂ) * τ))) := by
+  have hτ : 0 < τ.im := τ.2
+  have hmpos : (0 : ℝ) < ((m : ℕ) : ℝ) := by exact_mod_cast m.2
+  have hw1 : 0 < (z + ((m : ℕ) : ℂ) * τ).im := by
+    simp only [add_im, hz, mul_im, natCast_re, coe_im, natCast_im, coe_re, zero_mul, add_zero,
+      zero_add, Nat.cast_pos, PNat.pos, mul_pos_iff_of_pos_left]; positivity
+  have hw2 : 0 < (((m : ℕ) : ℂ) * τ - z).im := by
+    simp only [sub_im, mul_im, natCast_re, coe_im, natCast_im, coe_re, zero_mul, add_zero, hz,
+      sub_zero, Nat.cast_pos, PNat.pos, mul_pos_iff_of_pos_left]; positivity
+  have h1 := hasSum_pi_cot_add hw1
+  have h2 := hasSum_pi_cot_add hw2
+  have h2' : HasSum (fun k : ℕ+ => -(-2 * π * I * cexp (2 * π * I * (((m : ℕ) : ℂ) * τ - z)) ^ (k :
+    ℕ)))
+      (π * Complex.cot (π * (z - ((m : ℕ) : ℂ) * τ)) - π * I) := by
+    convert h2.neg using 1
+    rw [show π * (((m : ℕ) : ℂ) * τ - z) = -(π * (z - ((m : ℕ) : ℂ) * τ)) by ring, cot_neg]
+    ring
+  have h3 := h1.add h2'
+  have hval : π * Complex.cot (π * (z + ((m : ℕ) : ℂ) * τ)) + π * I +
+      (π * Complex.cot (π * (z - ((m : ℕ) : ℂ) * τ)) - π * I) =
+      π * Complex.cot (π * (z + ((m : ℕ) : ℂ) * τ)) +
+        π * Complex.cot (π * (z - ((m : ℕ) : ℂ) * τ)) := by ring
+  rw [hval] at h3
+  refine h3.congr_fun fun k => ?_
+  have e1 : cexp (2 * π * I * (z + ((m : ℕ) : ℂ) * τ)) ^ (k : ℕ) =
+      cexp (2 * π * I * ((k : ℕ) : ℂ) * z) * cexp (2 * π * I * τ) ^ ((m : ℕ) * (k : ℕ)) := by
+    rw [← Complex.exp_nat_mul, ← Complex.exp_nat_mul, ← Complex.exp_add]
+    congr 1
+    push_cast
+    ring
+  have e2 : cexp (2 * π * I * (((m : ℕ) : ℂ) * τ - z)) ^ (k : ℕ) =
+      cexp (-(2 * π * I * ((k : ℕ) : ℂ) * z)) * cexp (2 * π * I * τ) ^ ((m : ℕ) * (k : ℕ)) := by
+    rw [← Complex.exp_nat_mul, ← Complex.exp_nat_mul, ← Complex.exp_add]
+    congr 1
+    push_cast
+    ring
+  simp only [Fterm]
+  rw [e1, e2]
+  ring
+
+lemma tsum_Fterm_eq_pval {z : ℂ} (hzn : NotLat τ z) (hz : z.im = 0) :
+    ∑' p, Fterm τ z p = pval τ z := by
+  have hrows : HasSum (fun m : ℕ+ => π * Complex.cot (π * (z + ((m : ℕ) : ℂ) * τ)) +
+      π * Complex.cot (π * (z - ((m : ℕ) : ℂ) * τ))) (∑' p, Fterm τ z p) :=
+    (summable_Fterm τ hz).hasSum.prod_fiberwise (fun m => hasSum_Fterm_row τ hz m)
+  rw [← hrows.tsum_eq, tsum_pnat_eq_tsum_succ (f := fun m : ℕ =>
+      π * Complex.cot (π * (z + (m : ℂ) * τ)) + π * Complex.cot (π * (z - (m : ℂ) * τ))),
+    ← (hasSum_ser τ hzn).tsum_eq]
+  refine tsum_congr fun m => ?_
+  simp only [ser]
+  push_cast
+  ring_nf
+
+def coef (z : ℂ) (n : ℕ) : ℂ :=
+  -(2 * π * I) * ∑ k ∈ n.divisors, (cexp (2 * π * I * k * z) - cexp (-(2 * π * I * k * z)))
+
+lemma tsum_regroup {z : ℂ} (hz : z.im = 0) :
+    ∑' p, Fterm τ z p = ∑' n : ℕ+, coef z n * cexp (2 * π * I * τ) ^ (n : ℕ) := by
+  have hFs := summable_Fterm τ hz
+  generalize hF : Fterm τ z = F at hFs ⊢
+  rw [← sigmaAntidiagonalEquivProd.tsum_eq]
+  have hs' : Summable (fun x : Σ n : ℕ+, ((n : ℕ)).divisorsAntidiagonal =>
+      F (sigmaAntidiagonalEquivProd x)) := (Equiv.summable_iff _).mpr hFs
+  rw [hs'.tsum_sigma]
+  refine tsum_congr fun n => ?_
+  rw [tsum_fintype, Finset.univ_eq_attach, coef, Finset.mul_sum, Finset.sum_mul,
+    ← Nat.sum_divisorsAntidiagonal' (fun _ k => -(2 * π * I) *
+      (cexp (2 * π * I * k * z) - cexp (-(2 * π * I * k * z))) * cexp (2 * π * I * τ) ^ (n : ℕ)),
+    ← Finset.sum_attach ((n : ℕ)).divisorsAntidiagonal]
+  refine Finset.sum_congr rfl fun x _ => ?_
+  have hx : x.1.1 * x.1.2 = n := (Nat.mem_divisorsAntidiagonal.mp x.2).1
+  have e1 : ((sigmaAntidiagonalEquivProd ⟨n, x⟩).1 : ℕ) = x.1.1 := rfl
+  have e2 : ((sigmaAntidiagonalEquivProd ⟨n, x⟩).2 : ℕ) = x.1.2 := rfl
+  rw [← hF]
+  simp only [Fterm]
+  rw [e1, e2, hx]
+
+lemma summable_regroup {z : ℂ} (hz : z.im = 0) :
+    Summable fun n : ℕ+ => coef z n * cexp (2 * π * I * τ) ^ (n : ℕ) := by
+  have hFs := summable_Fterm τ hz
+  generalize hF : Fterm τ z = F at hFs
+  have hs' : Summable (fun x : Σ n : ℕ+, ((n : ℕ)).divisorsAntidiagonal =>
+      F (sigmaAntidiagonalEquivProd x)) := (Equiv.summable_iff _).mpr hFs
+  refine hs'.sigma.congr fun n => ?_
+  rw [tsum_fintype, Finset.univ_eq_attach, coef, Finset.mul_sum, Finset.sum_mul,
+    ← Nat.sum_divisorsAntidiagonal' (fun _ k => -(2 * π * I) *
+      (cexp (2 * π * I * k * z) - cexp (-(2 * π * I * k * z))) * cexp (2 * π * I * τ) ^ (n : ℕ)),
+    ← Finset.sum_attach ((n : ℕ)).divisorsAntidiagonal]
+  refine Finset.sum_congr rfl fun x _ => ?_
+  have hx : x.1.1 * x.1.2 = n := (Nat.mem_divisorsAntidiagonal.mp x.2).1
+  have e1 : ((sigmaAntidiagonalEquivProd ⟨n, x⟩).1 : ℕ) = x.1.1 := rfl
+  have e2 : ((sigmaAntidiagonalEquivProd ⟨n, x⟩).2 : ℕ) = x.1.2 := rfl
+  rw [← hF]
+  simp only [Fterm]
+  rw [e1, e2, hx]
+
+lemma hasSum_regroup {z : ℂ} (hz : z.im = 0) :
+    HasSum (fun n : ℕ+ => coef z n * cexp (2 * π * I * τ) ^ (n : ℕ)) (∑' p, Fterm τ z p) := by
+  rw [tsum_regroup τ hz]
+  exact (summable_regroup τ hz).hasSum
+
+lemma coef_eq (b : ℤ) (n : ℕ) :
+    coef ((b : ℂ) / N) n = -(2 * π * I) * ∑ k ∈ n.divisors,
+      (cexp (2 * π * I * b * k / N) - cexp (-(2 * π * I * b * k / N))) := by
+  have hN : (N : ℂ) ≠ 0 := by exact_mod_cast NeZero.ne N
+  rw [coef]
+  congr 1
+  refine Finset.sum_congr rfl fun k _ => ?_
+  rw [show 2 * π * I * (k : ℂ) * ((b : ℂ) / N) = 2 * π * I * b * k / N by ring]
+
+theorem hasSum_eisensteinG1 (b : ℤ) (hb : ¬ (N : ℤ) ∣ b) :
+    HasSum (fun n : ℕ => (if n = 0 then π / N * Complex.cot (π * b / N) else
+        -(2 * π * I) / N * ∑ k ∈ n.divisors,
+          (cexp (2 * π * I * b * k / N) - cexp (-(2 * π * I * b * k / N)))) *
+        cexp (2 * π * I * τ) ^ n)
+      (eisensteinG1 N ![0, b] τ) := by
+  have hN : (N : ℂ) ≠ 0 := by exact_mod_cast NeZero.ne N
+  have hv : ¬ ∀ i, (N : ℤ) ∣ (![0, b] : Fin 2 → ℤ) i := fun h => hb (by simpa using h 1)
+  have hzb : om τ ![0, b] / N = (b : ℂ) / N := by simp [om]
+  have hzn : NotLat τ ((b : ℂ) / N) := hzb ▸ notLat_of_not_dvd N τ hv
+  have hzim : ((b : ℂ) / N).im = 0 := by
+    rw [Complex.div_natCast_im]; simp
+  have hg : eisensteinG1 N ![0, b] τ =
+      1 / (N : ℂ) * (pval τ ((b : ℂ) / N) + π * Complex.cot (π * ((b : ℂ) / N))) := by
+    rw [eisensteinG1_eq N τ, hzb]
+    simp
+  have hmain : HasSum (fun n : ℕ+ => coef ((b : ℂ) / N) n * cexp (2 * π * I * τ) ^ (n : ℕ))
+      (pval τ ((b : ℂ) / N)) := by
+    rw [← tsum_Fterm_eq_pval τ hzn hzim]
+    exact hasSum_regroup τ hzim
+  set f : ℕ → ℂ := fun n => (if n = 0 then π / N * Complex.cot (π * b / N) else
+      -(2 * π * I) / N * ∑ k ∈ n.divisors,
+        (cexp (2 * π * I * b * k / N) - cexp (-(2 * π * I * b * k / N)))) *
+      cexp (2 * π * I * τ) ^ n with hf
+  have hfpos : ∀ n : ℕ+,
+      f n = 1 / (N : ℂ) * (coef ((b : ℂ) / N) n * cexp (2 * π * I * τ) ^ (n : ℕ)) := by
+    intro n
+    have hn : (n : ℕ) ≠ 0 := n.ne_zero
+    simp only [hf, ite_eq_right hn, coef_eq N]
+    field_simp
+  have htail : HasSum (fun n : ℕ+ => f n) (1 / (N : ℂ) * pval τ ((b : ℂ) / N)) :=
+    (hmain.mul_left (1 / (N : ℂ))).congr_fun hfpos
+  have hs1 : Summable fun n : ℕ => f (n + 1) := summable_pnat_iff_summable_succ.mp htail.summable
+  have htail' : HasSum (fun n : ℕ => f (n + 1)) (1 / (N : ℂ) * pval τ ((b : ℂ) / N)) := by
+    rw [← htail.tsum_eq, tsum_pnat_eq_tsum_succ (f := f)]
+    exact hs1.hasSum
+  have htot := htail'.zero_add
+  have hf0 : f 0 = π / N * Complex.cot (π * b / N) := by simp [hf]
+  rw [hf0] at htot
+  change HasSum f (eisensteinG1 N ![0, b] τ)
+  rw [hg]
+  convert htot using 1
+  rw [show π * ((b : ℂ) / N) = π * b / N by ring]
+  ring
+
+end WZD
+
+end
+
+theorem solution (N : ℕ) [NeZero N] :
+    (∀ v : Fin 2 → ℤ, (¬ ∀ i, (N : ℤ) ∣ v i) →
+        UpperHalfPlane.IsBoundedAtImInfty (EisensteinSeries.eisensteinG1 N v)) ∧
+    (∀ (b : ℤ), ¬ (N : ℤ) ∣ b → ∀ τ : UpperHalfPlane,
+        HasSum (fun n : ℕ => (if n = 0 then π / N * Complex.cot (π * b / N) else
+            -(2 * π * Complex.I) / N * ∑ k ∈ n.divisors,
+              (Complex.exp (2 * π * Complex.I * b * k / N) -
+                Complex.exp (-(2 * π * Complex.I * b * k / N)))) *
+            Complex.exp (2 * π * Complex.I * τ) ^ n)
+          (EisensteinSeries.eisensteinG1 N ![0, b] τ)) :=
+  ⟨fun v hv => WZD.isBoundedAtImInfty_eisensteinG1 N v hv,
+    fun b hb τ => WZD.hasSum_eisensteinG1 N τ b hb⟩
+
+end S_EisensteinSeries_isBoundedAtImInfty_eisensteinG1_and_hasSum_eisensteinG1
+end P2MW
+export P2MW.S_EisensteinSeries_isBoundedAtImInfty_eisensteinG1_and_hasSum_eisensteinG1 (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Real
+theorem EisensteinSeries.isBoundedAtImInfty_eisensteinG1_and_hasSum_eisensteinG1 (N : ℕ) [NeZero N]
+    :
+    (∀ v : Fin 2 → ℤ, (¬ ∀ i, (N : ℤ) ∣ v i) →
+        UpperHalfPlane.IsBoundedAtImInfty (EisensteinSeries.eisensteinG1 N v)) ∧
+    (∀ (b : ℤ), ¬ (N : ℤ) ∣ b → ∀ τ : UpperHalfPlane,
+        HasSum (fun n : ℕ => (if n = 0 then π / N * Complex.cot (π * b / N) else
+            -(2 * π * Complex.I) / N * ∑ k ∈ n.divisors,
+              (Complex.exp (2 * π * Complex.I * b * k / N) -
+                Complex.exp (-(2 * π * Complex.I * b * k / N)))) *
+            Complex.exp (2 * π * Complex.I * τ) ^ n)
+          (EisensteinSeries.eisensteinG1 N ![0, b] τ)) :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinSeries_qExpansion_eisensteinG_coeff.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinSeries_qExpansion_eisensteinG_coeff.lean
new file mode 100644
index 0000000000..bd2186dca4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinSeries_qExpansion_eisensteinG_coeff.lean
@@ -0,0 +1,713 @@
+/-
+Based on Prove2Me node EisensteinSeries.qExpansion_eisensteinG_coeff
+(7770826f-045e-5a13-95de-30e4d07d530f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 536fe46e-11ce-5003-8dbe-aabc7cade6f6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.SpecialFunctions.Complex.CircleAddChar
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EisensteinSeries_EisensteinG
+
+import Mathlib.Data.Int.Star
+import Mathlib.NumberTheory.ModularForms.EisensteinSeries.QExpansion
+import Mathlib.Topology.Separation.CompletelyRegular
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# q_N-expansion of the level-N Eisenstein series G_kᵃ
+
+Theorem statement: `EisensteinSeries.qExpansion_eisensteinG_coeff`
+(`7770826f-045e-5a13-95de-30e4d07d530f`), by Claude, 2026-09-05.
+
+Proof: submission `536fe46e-11ce-5003-8dbe-aabc7cade6f6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N\ge 1$, let $k$ be a natural number with $3\le k$, let $a=(a_0,a_1)\in(\mathbb Z/N\mathbb
+Z)^2$, and let $n\ge 0$. Consider the Eisenstein series $G^a_{N,k}$ of weight $k$ attached to the
+congruence class $a$, defined on the upper half-plane by the sum $\sum_v
+\mathrm{eisSummand}\,k\,v\,z$ over all $v\colon \mathrm{Fin}\,2\to\mathbb Z$ whose reduction modulo
+$N$ is $a$, i.e. $\sum_{v\equiv a\ (N)}(v_0 z+v_1)^{-k}$. The assertion is an identity for the
+$n$-th coefficient of its width-$N$ $q$-expansion at $i\infty$ (in the variable $q_N=e^{2\pi i
+z/N}$). For $n=0$ the coefficient is $\sum_{d\equiv a_1\ (N)} (d^k)^{-1}$, the sum being over all
+integers $d$ congruent to $a_1$ modulo $N$ (the term $d=0$ contributing $0$), if $a_0=0$, and $0$
+otherwise. For $n\ge 1$ it equals $$\frac{(-2\pi i)^k}{(k-1)!\,N^k}\sum_{m\mid
+n}m^{k-1}\Bigl(\bigl[\,n/m\equiv a_0\,\bigr]\,\psi(a_1 m)+(-1)^k\bigl[\,n/m\equiv
+-a_0\,\bigr]\,\psi(-a_1 m)\Bigr),$$ where $m$ runs over the positive divisors of $n$, the brackets
+are the indicator of the stated congruence in $\mathbb Z/N\mathbb Z$, and $\psi$ is the standard
+additive character $x\mapsto e^{2\pi i x/N}$ of $\mathbb Z/N\mathbb Z$.
+
+This is the classical Fourier expansion of the congruence-class Eisenstein series of level
+$\Gamma(N)$ and weight $k\ge 3$: constant term a partial zeta value, higher coefficients twisted
+divisor sums with values in $\frac{(-2\pi i)^k}{(k-1)!N^k}\mathbb Z[\zeta_N]$. It underlies the
+construction of weight-three modular forms on $\Gamma_1(N)$ with prescribed integral $q$-expansions
+and prescribed behaviour under slash operators, used in the Siegel-unit part of the argument.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_EisensteinSeries_qExpansion_eisensteinG_coeff.lean
+
+*Attribution:* this file contains material adapted from third-party Apache-2.0 sources
+(`Mathlib/NumberTheory/ModularForms/EisensteinSeries/IsBoundedAtImInfty.lean`: Copyright (c) 2024
+Chris Birkbeck; Authors: Chris Birkbeck). See ATTRIBUTION.md and NOTICE in the source repository.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_EisensteinSeries_qExpansion_eisensteinG_coeff
+
+open scoped MatrixGroups CongruenceSubgroup ModularForm Topology Manifold Matrix Nat
+p2m_open "UpperHalfPlane~I"
+open EisensteinSeries Filter Complex Real
+
+noncomputable section
+
+namespace CardC
+
+variable {N : ℕ} {k : ℤ}
+
+def congrSet (N : ℕ) (a : Fin 2 → ZMod N) : Set (Fin 2 → ℤ) := {v | ((↑) : ℤ → ZMod N) ∘ v = a}
+
+lemma eisensteinG_eq (N : ℕ) (k : ℤ) (a : Fin 2 → ZMod N) :
+    EisensteinSeries.eisensteinG N k a = fun z => ∑' v : congrSet N a, eisSummand k v z := rfl
+
+lemma vecMul_mem_congrSet {a : Fin 2 → ZMod N} {v : Fin 2 → ℤ} (hv : v ∈ congrSet N a)
+    (γ : SL(2, ℤ)) : v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ) ∈ congrSet N (a ᵥ* γ) := by
+  simp only [congrSet, Set.mem_ofPred_eq] at hv ⊢
+  have := RingHom.map_vecMul (m := Fin 2) (n := Fin 2) (Int.castRingHom (ZMod N)) γ v
+  simp only [eq_intCast, Int.coe_castRingHom] at this
+  simp_rw [Function.comp_def, this, ← hv]
+  rfl
+
+def congrSetEquiv (a : Fin 2 → ZMod N) (γ : SL(2, ℤ)) : congrSet N a ≃ congrSet N (a ᵥ* γ) where
+  toFun v := ⟨v.1 ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ), vecMul_mem_congrSet v.2 γ⟩
+  invFun v := ⟨v.1 ᵥ* ((γ⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ), by
+      have := vecMul_mem_congrSet v.2 γ⁻¹
+      rw [Matrix.vecMul_vecMul, ← Matrix.SpecialLinearGroup.coe_mul] at this
+      simpa only [map_inv, mul_inv_cancel, Matrix.SpecialLinearGroup.coe_one, Matrix.vecMul_one]
+        using this⟩
+  left_inv v := by simp_rw [Matrix.vecMul_vecMul, ← Matrix.SpecialLinearGroup.coe_mul,
+    mul_inv_cancel, Matrix.SpecialLinearGroup.coe_one, Matrix.vecMul_one]
+  right_inv v := by simp_rw [Matrix.vecMul_vecMul, ← Matrix.SpecialLinearGroup.coe_mul,
+    inv_mul_cancel, Matrix.SpecialLinearGroup.coe_one, Matrix.vecMul_one]
+
+theorem eisensteinG_slash_apply (N : ℕ) (k : ℤ) (a : Fin 2 → ZMod N) (γ : SL(2, ℤ)) :
+    EisensteinSeries.eisensteinG N k a ∣[k] γ = EisensteinSeries.eisensteinG N k (a ᵥ* γ) := by
+  ext1 z
+  simp_rw [ModularForm.SL_slash_apply, zpow_neg,
+    mul_inv_eq_iff_eq_mul₀ (zpow_ne_zero _ <| denom_ne_zero _ z), eisensteinG_eq,
+    eisSummand_SL2_apply, tsum_mul_left, mul_comm (_ ^ k)]
+  congr 1
+  exact (congrSetEquiv a γ).tsum_eq (fun v => eisSummand k v z)
+
+def eisensteinGSIF (N : ℕ) (k : ℤ) (a : Fin 2 → ZMod N) : SlashInvariantForm Γ(N) k where
+  toFun := EisensteinSeries.eisensteinG N k a
+  slash_action_eq' A hA := by
+    obtain ⟨A, (hA : A ∈ Γ(N)), rfl⟩ := hA
+    simp [Matrix.SpecialLinearGroup.mapGL, ← ModularForm.SL_slash, eisensteinG_slash_apply,
+      CongruenceSubgroup.Gamma_mem'.mp hA]
+
+lemma coe_eisensteinGSIF (N : ℕ) (k : ℤ) (a : Fin 2 → ZMod N) :
+    ⇑(eisensteinGSIF N k a) = EisensteinSeries.eisensteinG N k a := rfl
+
+theorem eisensteinG_tendstoLocallyUniformly (hk : 3 ≤ k) (a : Fin 2 → ZMod N) :
+    TendstoLocallyUniformly (fun (s : Finset (congrSet N a)) => (∑ x ∈ s, eisSummand k x ·))
+      (EisensteinSeries.eisensteinG N k a ·) Filter.atTop := by
+  have hk' : (2 : ℝ) < k := by norm_cast
+  have p_sum : Summable fun x : congrSet N a => ‖x.val‖ ^ (-k) :=
+    mod_cast (summable_one_div_norm_rpow hk').subtype (· ∈ congrSet N a)
+  simp only [tendstoLocallyUniformly_iff_forall_isCompact, eisensteinG_eq]
+  intro K hK
+  obtain ⟨A, B, hB, HABK⟩ := subset_verticalStrip_of_isCompact hK
+  refine (tendstoUniformlyOn_tsum (hu := p_sum.mul_left <| r ⟨⟨A, B⟩, hB⟩ ^ (-k : ℝ))
+    (fun p z hz => ?_)).mono HABK
+  simpa only [eisSummand, one_div, ← zpow_neg, norm_zpow, ← Real.rpow_intCast,
+    Int.cast_neg] using summand_bound_of_mem_verticalStrip (by positivity) p hB hz
+
+lemma eisensteinG_tendstoLocallyUniformlyOn (hk : 3 ≤ k) (a : Fin 2 → ZMod N) :
+    TendstoLocallyUniformlyOn (fun (s : Finset (congrSet N a)) =>
+      ↑ₕ(fun (z : ℍ) => ∑ x ∈ s, eisSummand k x z)) (↑ₕ(eisensteinGSIF N k a))
+          Filter.atTop {z : ℂ | 0 < z.im} := by
+  rw [← upperHalfPlaneSet, ← UpperHalfPlane.range_coe, ← Set.image_univ]
+  apply TendstoLocallyUniformlyOn.comp (s := ⊤) _ _ _ (OpenPartialHomeomorph.continuousOn_symm _)
+  · simp only [Set.top_eq_univ, tendstoLocallyUniformlyOn_univ]
+    apply eisensteinG_tendstoLocallyUniformly hk
+  · simp only [Topology.IsOpenEmbedding.toOpenPartialHomeomorph_target, Set.top_eq_univ,
+      Set.mapsTo_range_iff, Set.mem_univ, forall_const]
+
+theorem eisensteinGSIF_mdifferentiable (hk : 3 ≤ k) (a : Fin 2 → ZMod N) :
+    MDiff (eisensteinGSIF N k a) := by
+  intro τ
+  suffices DifferentiableAt ℂ (↑ₕeisensteinGSIF N k a) τ.1 by
+    convert!
+      MDifferentiableAt.comp τ (DifferentiableAt.mdifferentiableAt this) τ.mdifferentiable_coe
+    exact funext fun z => (comp_ofComplex (eisensteinGSIF N k a) z).symm
+  refine DifferentiableOn.differentiableAt ?_ (isOpen_upperHalfPlaneSet.mem_nhds τ.2)
+  exact (eisensteinG_tendstoLocallyUniformlyOn hk a).differentiableOn
+    (Eventually.of_forall fun s => DifferentiableOn.fun_sum
+    fun _ _ => eisSummand_extension_differentiableOn _ _) isOpen_upperHalfPlaneSet
+
+lemma norm_le_tsum_norm (N : ℕ) (a : Fin 2 → ZMod N) (k : ℤ) (hk : 3 ≤ k) (z : ℍ) :
+    ‖EisensteinSeries.eisensteinG N k a z‖ ≤ ∑' (x : Fin 2 → ℤ), ‖eisSummand k x z‖ := by
+  rw [eisensteinG_eq]
+  apply le_trans (norm_tsum_le_tsum_norm ((summable_norm_eisSummand hk z).subtype _))
+    (Summable.tsum_subtype_le (fun (x : Fin 2 → ℤ) => ‖(eisSummand k x z)‖) _ (fun _ => norm_nonneg
+      _)
+      (summable_norm_eisSummand hk z))
+
+theorem isBoundedAtImInfty_eisensteinG [NeZero N] (a : Fin 2 → ZMod N) (hk : 3 ≤ k) :
+    IsBoundedAtImInfty (EisensteinSeries.eisensteinG N k a) := by
+  simp_rw [UpperHalfPlane.isBoundedAtImInfty_iff]
+  refine ⟨∑'(x : Fin 2 → ℤ), r ⟨⟨N, 2⟩, Nat.ofNat_pos⟩ ^ (-k) * ‖x‖ ^ (-k), 2, ?_⟩
+  intro z hz
+  obtain ⟨n, hn⟩ := (ModularGroup_T_zpow_mem_verticalStrip z (NeZero.pos N))
+  rw [← coe_eisensteinGSIF, ← SlashInvariantForm.T_zpow_width_invariant N k n (eisensteinGSIF N k a)
+    z,
+    coe_eisensteinGSIF]
+  apply le_trans (norm_le_tsum_norm N a k hk _)
+  have hk' : (2 : ℝ) < k := by norm_cast
+  apply (summable_norm_eisSummand hk _).tsum_le_tsum _
+  · exact_mod_cast (summable_one_div_norm_rpow hk').mul_left <| r ⟨⟨N, 2⟩, Nat.ofNat_pos⟩ ^ (-k)
+  · intro x
+    simp_rw [eisSummand, norm_zpow]
+    exact_mod_cast
+      summand_bound_of_mem_verticalStrip (lt_trans two_pos hk').le x two_pos
+      (verticalStrip_anti_right N hz hn)
+
+lemma slash_T_zpow_apply (h : ℍ → ℂ) (b : ℤ) (τ : ℍ) :
+    (h ∣[k] (ModularGroup.T ^ b)) τ = h (((b : ℝ)) +ᵥ τ) := by
+  rw [ModularForm.SL_slash_apply, ModularGroup.denom_apply, UpperHalfPlane.modular_T_zpow_smul]
+  simp [ModularGroup.coe_T_zpow]
+
+lemma periodic_eisensteinG (k : ℤ) (a : Fin 2 → ZMod N) :
+    Function.Periodic (EisensteinSeries.eisensteinG N k a ∘ ofComplex) (N : ℝ) := by
+  have hT : EisensteinSeries.eisensteinG N k a ∣[k] (ModularGroup.T ^ (N : ℤ)) =
+      EisensteinSeries.eisensteinG N k a := by
+    have hmem : ModularGroup.T ^ (N : ℤ) ∈ Γ(N) := by
+      simpa using CongruenceSubgroup.ModularGroup_T_pow_mem_Gamma (N : ℤ) (N : ℤ) dvd_rfl
+    have := SlashInvariantForm.slash_action_eqn (eisensteinGSIF N k a)
+      (Matrix.SpecialLinearGroup.mapGL ℝ (ModularGroup.T ^ (N : ℤ))) ⟨_, hmem, rfl⟩
+    simp only [Matrix.SpecialLinearGroup.mapGL, algebraMap_int_eq, zpow_natCast, MonoidHom.coe_comp,
+      Function.comp_apply, map_pow, ModularForm.SL_slash] at this ⊢
+    exact this
+  intro w
+  by_cases hw : 0 < w.im
+  · have hw' : 0 < (w + ((N : ℝ) : ℂ)).im := by simpa using hw
+    simp only [Function.comp_apply]
+    rw [ofComplex_apply_of_im_pos hw', ofComplex_apply_of_im_pos hw]
+    have h1 : (⟨w + ((N : ℝ) : ℂ), hw'⟩ : ℍ) = (((N : ℤ) : ℝ)) +ᵥ (⟨w, hw⟩ : ℍ) := by
+      apply UpperHalfPlane.ext; simp [UpperHalfPlane.coe_vadd, add_comm]
+    rw [h1, ← slash_T_zpow_apply (EisensteinSeries.eisensteinG N k a) (N : ℤ), hT]
+  · have hw' : (w + ((N : ℝ) : ℂ)).im ≤ 0 := by simpa using hw
+    simp only [Function.comp_apply]
+    rw [ofComplex_apply_of_im_nonpos hw', ofComplex_apply_of_im_nonpos (not_lt.mp hw)]
+
+theorem qExpansion_coeff_eq [NeZero N] (hk : 3 ≤ k) (a : Fin 2 → ZMod N) {c : ℕ → ℂ}
+    (hsum : ∀ τ : ℍ, HasSum (fun m => c m * Function.Periodic.qParam N τ ^ m)
+      (EisensteinSeries.eisensteinG N k a τ)) (n : ℕ) :
+    (qExpansion N (EisensteinSeries.eisensteinG N k a)).coeff n = c n := by
+  have hN : (0 : ℝ) < N := by exact_mod_cast NeZero.pos N
+  have hA : AnalyticAt ℂ (cuspFunction N ⇑(eisensteinGSIF N k a)) 0 :=
+    analyticAt_cuspFunction_zero hN (periodic_eisensteinG k a) (eisensteinGSIF_mdifferentiable hk a)
+      (isBoundedAtImInfty_eisensteinG a hk)
+  have := qExpansion_coeff_unique (eisensteinGSIF N k a) hN hA (c := c)
+    (fun τ => by have h__af := hsum τ; simp only [smul_eq_mul] at h__af ⊢; exact h__af) n
+  rw [coe_eisensteinGSIF] at this
+  exact this.symm
+
+section expansion
+
+variable [NeZero N] {k : ℕ}
+
+abbrev cls (N : ℕ) (b : ZMod N) : Type := {d : ℤ // (d : ZMod N) = b}
+
+def congrSetEquivSigma (a : Fin 2 → ZMod N) : congrSet N a ≃ (Σ _ : cls N (a 0), cls N (a 1)) where
+  toFun v := ⟨⟨v.1 0, congr_fun v.2 0⟩, ⟨v.1 1, congr_fun v.2 1⟩⟩
+  invFun p := ⟨![p.1.1, p.2.1], by
+    change ((↑) : ℤ → ZMod N) ∘ ![p.1.1, p.2.1] = a
+    funext i; fin_cases i
+    · simpa using p.1.2
+    · simpa using p.2.2⟩
+  left_inv v := by
+    apply Subtype.ext
+    funext i; fin_cases i <;> rfl
+  right_inv p := by
+    rcases p with ⟨⟨c, hc⟩, ⟨d, hd⟩⟩
+    rfl
+
+omit [NeZero N] in
+lemma eisSummand_natCast (v : Fin 2 → ℤ) (z : ℍ) :
+    eisSummand (k : ℤ) v z = ((((v 0 : ℂ)) * z + v 1) ^ k)⁻¹ := by
+  rw [eisSummand, zpow_neg, zpow_natCast]
+
+omit [NeZero N] in
+lemma eisensteinG_eq_tsum_tsum (hk : 3 ≤ k) (a : Fin 2 → ZMod N) (τ : ℍ) :
+    EisensteinSeries.eisensteinG N k a τ =
+      ∑' c : cls N (a 0), ∑' d : cls N (a 1), ((((c.1 : ℂ)) * τ + d.1) ^ k)⁻¹ := by
+  have hk' : 3 ≤ ((k : ℕ) : ℤ) := by exact_mod_cast hk
+  rw [eisensteinG_eq]
+  dsimp only
+  rw [← (congrSetEquivSigma a).symm.tsum_eq]
+  have hs : Summable (fun p : Σ _ : cls N (a 0), cls N (a 1) =>
+      eisSummand (k : ℤ) ((congrSetEquivSigma a).symm p).1 τ) :=
+    (congrSetEquivSigma a).symm.summable_iff.mpr ((summable_norm_eisSummand hk' τ).of_norm.subtype
+      _)
+  rw [hs.tsum_sigma]
+  refine tsum_congr fun c => tsum_congr fun d => ?_
+  rw [eisSummand_natCast]
+  rfl
+
+def clsEquiv (b : ZMod N) : ℤ ≃ cls N b where
+  toFun j := ⟨(b.val : ℤ) + N * j, by simp⟩
+  invFun d := (d.1 - b.val) / N
+  left_inv j := by
+    have hN : (N : ℤ) ≠ 0 := by exact_mod_cast NeZero.ne N
+    simp only [add_sub_cancel_left]
+    exact Int.mul_ediv_cancel_left _ hN
+  right_inv d := by
+    apply Subtype.ext
+    have hdvd : (N : ℤ) ∣ d.1 - b.val := by
+      rw [← ZMod.intCast_zmod_eq_zero_iff_dvd]
+      push_cast
+      rw [d.2, ZMod.natCast_zmod_val, sub_self]
+    simp only
+    rw [Int.mul_ediv_cancel' hdvd]
+    ring
+
+def wpt (c : ℕ) (hc : 0 < c) (bv : ℕ) (τ : ℍ) : ℍ :=
+  ⟨(((c : ℂ)) * τ + bv) / N, by
+    have hN : (0 : ℝ) < N := by exact_mod_cast NeZero.pos N
+    rw [Complex.div_natCast_im]
+    apply div_pos _ hN
+    simp only [Complex.add_im, Complex.mul_im, Complex.natCast_re, Complex.natCast_im, zero_mul,
+      add_zero, UpperHalfPlane.coe_im, UpperHalfPlane.coe_re]
+    exact mul_pos (Nat.cast_pos.mpr hc) τ.2⟩
+
+lemma stdAddChar_mul_natCast (b : ZMod N) (bv : ℕ) (hbv : (bv : ZMod N) = b) (m : ℕ) :
+    ZMod.stdAddChar (b * (m : ZMod N)) = cexp (2 * π * I * (((bv * m : ℕ) : ℤ) : ℂ) / N) := by
+  have : (b * (m : ZMod N) : ZMod N) = (((bv * m : ℕ) : ℤ) : ZMod N) := by
+    rw [← hbv]; push_cast; ring
+  rw [this, ZMod.stdAddChar_coe]
+
+lemma tsum_int_eq (hk : 2 ≤ k) (b : ZMod N) (bv : ℕ) (hbv : (bv : ZMod N) = b) (c : ℕ) (hc : 0 < c)
+    (τ : ℍ) :
+    ∑' j : ℤ, ((((c : ℂ)) * τ + ((bv : ℂ) + (N : ℂ) * j)) ^ k)⁻¹ =
+      ((N : ℂ) ^ k)⁻¹ * ((-2 * π * I) ^ k / (k - 1)!) *
+        ∑' m : ℕ+, ((m : ℕ) : ℂ) ^ (k - 1) *
+          (ZMod.stdAddChar (b * ((m : ℕ) : ZMod N)) * Function.Periodic.qParam N τ ^ ((m : ℕ) * c))
+            := by
+  have hN : (N : ℂ) ≠ 0 := by exact_mod_cast NeZero.ne N
+  have hfac : ∀ j : ℤ, ((((c : ℂ)) * τ + ((bv : ℂ) + (N : ℂ) * j)) ^ k)⁻¹ =
+      ((N : ℂ) ^ k)⁻¹ * (1 / (((wpt (N := N) c hc bv τ : ℍ) : ℂ) + j) ^ k) := by
+    intro j
+    rw [one_div, ← mul_inv, ← mul_pow]
+    congr 2
+    simp only [wpt, UpperHalfPlane.coe_mk]
+    field_simp
+    ring
+  simp_rw [hfac]
+  rw [tsum_mul_left, mul_assoc]
+  congr 1
+  obtain ⟨k', rfl⟩ : ∃ k', k = k' + 1 := ⟨k - 1, by omega⟩
+  have hk1 : 1 ≤ k' := by omega
+  rw [EisensteinSeries.qExpansion_identity_pnat hk1 (wpt (N := N) c hc bv τ)]
+  simp only [Nat.add_sub_cancel]
+  congr 1
+  refine tsum_congr fun m => ?_
+  congr 1
+  rw [stdAddChar_mul_natCast b bv hbv, Function.Periodic.qParam, ← Complex.exp_nat_mul,
+    ← Complex.exp_nat_mul, ← Complex.exp_add]
+  congr 1
+  simp only [wpt, UpperHalfPlane.coe_mk]
+  push_cast
+  field_simp
+  ring
+
+lemma tsum_cls_eq (hk : 2 ≤ k) (b : ZMod N) (c : ℕ) (hc : 0 < c) (τ : ℍ) :
+    ∑' d : cls N b, ((((c : ℂ)) * τ + d.1) ^ k)⁻¹ =
+      ((N : ℂ) ^ k)⁻¹ * ((-2 * π * I) ^ k / (k - 1)!) *
+        ∑' m : ℕ+, ((m : ℕ) : ℂ) ^ (k - 1) *
+          (ZMod.stdAddChar (b * ((m : ℕ) : ZMod N)) * Function.Periodic.qParam N τ ^ ((m : ℕ) * c))
+            := by
+  rw [← (clsEquiv b).tsum_eq]
+  have : ∀ j : ℤ, ((((c : ℂ)) * τ + ((clsEquiv b j).1 : ℂ)) ^ k)⁻¹ =
+      ((((c : ℂ)) * τ + (((b.val : ℕ) : ℂ) + (N : ℂ) * j)) ^ k)⁻¹ := by
+    intro j
+    simp only [clsEquiv, Equiv.coe_fn_mk, Int.cast_add, Int.cast_mul, Int.cast_natCast]
+  simp_rw [this]
+  exact tsum_int_eq hk b b.val (ZMod.natCast_zmod_val b) c hc τ
+
+def clsNegEquiv (b : ZMod N) : cls N b ≃ cls N (-b) where
+  toFun d := ⟨-d.1, by simp [d.2]⟩
+  invFun d := ⟨-d.1, by simp [d.2]⟩
+  left_inv d := by apply Subtype.ext; simp
+  right_inv d := by apply Subtype.ext; simp
+
+omit [NeZero N] in
+lemma tsum_cls_neg_eq (b : ZMod N) (c : ℕ) (τ : ℍ) :
+    ∑' d : cls N b, (((((-(c : ℤ) : ℤ) : ℂ)) * τ + d.1) ^ k)⁻¹ =
+      (-1) ^ k * ∑' d : cls N (-b), ((((c : ℂ)) * τ + d.1) ^ k)⁻¹ := by
+  rw [← (clsNegEquiv b).symm.tsum_eq, ← tsum_mul_left]
+  refine tsum_congr fun d => ?_
+  simp only [clsNegEquiv, Equiv.coe_fn_symm_mk, Int.cast_neg, Int.cast_natCast]
+  rw [show (-(c : ℂ)) * τ + -((d.1 : ℤ) : ℂ) = (-1) * ((c : ℂ) * τ + d.1) by ring, mul_pow, mul_inv,
+    ← inv_pow, inv_neg, inv_one]
+
+omit [NeZero N] in
+lemma tsum_cls_split (b : ZMod N) (F : ℤ → ℂ) (hF : Summable F) :
+    ∑' c : cls N b, F c.1 =
+      (if (0 : ZMod N) = b then F 0 else 0) +
+        ∑' c : ℕ+, (if ((c : ℕ) : ZMod N) = b then F c else 0) +
+        ∑' c : ℕ+, (if ((-((c : ℕ) : ℤ) : ℤ) : ZMod N) = b then F (-((c : ℕ) : ℤ)) else 0) := by
+  set G : ℤ → ℂ := fun c => if ((c : ZMod N)) = b then F c else 0 with hG
+  have hG' : Summable G := by
+    refine Summable.of_norm_bounded hF.norm fun c => ?_
+    simp only [hG]; split_ifs <;> simp
+  have h1 : ∑' c : cls N b, F c.1 = ∑' c : ℤ, G c := by
+    rw [show (∑' c : cls N b, F c.1) = ∑' c : ({c : ℤ | (c : ZMod N) = b} : Set ℤ), F c from rfl,
+      tsum_subtype]
+    refine tsum_congr fun c => ?_
+    simp only [Set.indicator_apply, Set.mem_ofPred_eq, hG]
+  have hs1 : Summable fun n : ℕ => G n := hG'.comp_injective Nat.cast_injective
+  have hs2 : Summable fun n : ℕ => G (-(n + 1)) :=
+    hG'.comp_injective (i := fun n : ℕ => (-(n + 1) : ℤ)) (fun m n h => by simpa using h)
+  rw [h1, tsum_of_nat_of_neg_add_one hs1 hs2, hs1.tsum_eq_zero_add]
+  congr 1
+  · congr 1
+    · simp [hG]
+    · rw [tsum_pnat_eq_tsum_succ (f := fun c : ℕ => if ((c : ℕ) : ZMod N) = b then F c else 0)]
+      simp [hG]
+  · rw [tsum_pnat_eq_tsum_succ (f := fun c : ℕ =>
+      if ((-((c : ℕ) : ℤ) : ℤ) : ZMod N) = b then F (-((c : ℕ) : ℤ)) else 0)]
+    refine tsum_congr fun c => ?_
+    simp [hG]
+
+lemma tsum_prod_eq_tsum_antidiagonal {F G : ℕ → ℂ} {r : ℂ} (e : ℕ) (h : ℕ+ × ℕ+ → ℂ)
+    (hs : Summable h)
+    (hh : ∀ p, h p = F p.1 * ((((p.2 : ℕ) : ℂ)) ^ e * (G p.2 * r ^ ((p.2 : ℕ) * p.1)))) :
+    ∑' p : ℕ+ × ℕ+, h p =
+      ∑' n : ℕ+, (∑ x ∈ (n : ℕ).divisorsAntidiagonal, F x.1 * G x.2 * ((x.2 : ℕ) : ℂ) ^ e) *
+        r ^ (n : ℕ) := by
+  rw [← sigmaAntidiagonalEquivProd.tsum_eq]
+  have hs' : Summable (fun x : Σ n : ℕ+, ((n : ℕ)).divisorsAntidiagonal =>
+      h (sigmaAntidiagonalEquivProd x)) := (Equiv.summable_iff _).mpr hs
+  rw [hs'.tsum_sigma]
+  refine tsum_congr fun n => ?_
+  rw [tsum_fintype, Finset.sum_mul, Finset.univ_eq_attach,
+    ← Finset.sum_attach ((n : ℕ)).divisorsAntidiagonal]
+  refine Finset.sum_congr rfl fun x _ => ?_
+  have hx : x.1.1 * x.1.2 = n := (Nat.mem_divisorsAntidiagonal.mp x.2).1
+  have e1 : ((sigmaAntidiagonalEquivProd ⟨n, x⟩).1 : ℕ) = x.1.1 := rfl
+  have e2 : ((sigmaAntidiagonalEquivProd ⟨n, x⟩).2 : ℕ) = x.1.2 := rfl
+  rw [hh, e1, e2, mul_comm x.1.2 x.1.1, hx]
+  ring
+
+lemma tsum_tsum_eq_tsum_antidiagonal {F G : ℕ → ℂ} (hF : ∀ c, ‖F c‖ ≤ 1) (hG : ∀ m, ‖G m‖ ≤ 1)
+    {r : ℂ} (hr : ‖r‖ < 1) (e : ℕ) :
+    ∑' c : ℕ+, F c * ∑' m : ℕ+, (((m : ℕ) : ℂ)) ^ e * (G m * r ^ ((m : ℕ) * c)) =
+      ∑' n : ℕ+, (∑ x ∈ (n : ℕ).divisorsAntidiagonal, F x.1 * G x.2 * ((x.2 : ℕ) : ℂ) ^ e) *
+        r ^ (n : ℕ) := by
+  let h : ℕ+ × ℕ+ → ℂ := fun p => F p.1 * ((((p.2 : ℕ) : ℂ)) ^ e * (G p.2 * r ^ ((p.2 : ℕ) * p.1)))
+  have hr' : ‖(‖r‖ : ℝ)‖ < 1 := by simpa using hr
+  have hs : Summable h := by
+    refine Summable.of_norm_bounded (summable_prod_mul_pow e hr') fun p => ?_
+    simp only [h, norm_mul, norm_pow, Complex.norm_natCast]
+    calc ‖F ↑p.1‖ * ((p.2 : ℝ) ^ e * (‖G ↑p.2‖ * ‖r‖ ^ ((p.2 : ℕ) * (p.1 : ℕ))))
+        ≤ 1 * ((p.2 : ℝ) ^ e * (1 * ‖r‖ ^ ((p.2 : ℕ) * (p.1 : ℕ)))) := by
+          gcongr
+          · exact hF _
+          · exact hG _
+      _ = (p.2 : ℝ) ^ e * ‖r‖ ^ ((p.1 : ℕ) * (p.2 : ℕ)) := by rw [mul_comm (p.2 : ℕ)]; ring
+  rw [← tsum_prod_eq_tsum_antidiagonal e h hs (fun p => rfl), hs.tsum_prod]
+  exact tsum_congr fun c => (tsum_mul_left).symm
+
+omit [NeZero N] in
+lemma summable_inner (hk : 3 ≤ k) (b : ZMod N) (τ : ℍ) :
+    Summable fun c : ℤ => ∑' d : cls N b, ((((c : ℂ)) * τ + d.1) ^ k)⁻¹ := by
+  have hk' : 3 ≤ ((k : ℕ) : ℤ) := by exact_mod_cast hk
+  have hfull : Summable fun p : ℤ × ℤ => ‖eisSummand (k : ℤ) ![p.1, p.2] τ‖ := by
+    have := (summable_norm_eisSummand hk' τ)
+    rw [← (finTwoArrowEquiv ℤ).symm.summable_iff] at this
+    refine this.congr fun p => ?_
+    simp only [Function.comp_apply, finTwoArrowEquiv_symm_apply]
+  refine Summable.of_norm_bounded hfull.prod fun c => ?_
+  have hsub : Summable fun d : cls N b => ‖((((c : ℂ)) * τ + d.1) ^ k)⁻¹‖ := by
+    have := (hfull.prod_factor c)
+    refine (this.subtype (fun d : ℤ => (d : ZMod N) = b)).congr fun d => ?_
+    simp [eisSummand_natCast]
+  refine (norm_tsum_le_tsum_norm hsub).trans ?_
+  have :=
+    Summable.tsum_subtype_le (fun d : ℤ => ‖((((c : ℂ)) * τ + d) ^ k)⁻¹‖) {d : ℤ | (d : ZMod N) = b}
+    (fun _ => norm_nonneg _) ((hfull.prod_factor c).congr fun d => by simp [eisSummand_natCast])
+  refine this.trans (le_of_eq (tsum_congr fun d => ?_))
+  simp [eisSummand_natCast]
+
+def kappa (N k : ℕ) : ℂ := ((N : ℂ) ^ k)⁻¹ * ((-2 * π * I) ^ k / (k - 1)!)
+
+def Splus (N k : ℕ) [NeZero N] (a : Fin 2 → ZMod N) (n : ℕ+) : ℂ :=
+  ∑ x ∈ (n : ℕ).divisorsAntidiagonal,
+    (if ((x.1 : ℕ) : ZMod N) = a 0 then (1 : ℂ) else 0) * ZMod.stdAddChar (a 1 * ((x.2 : ℕ) : ZMod
+      N)) *
+      ((x.2 : ℕ) : ℂ) ^ (k - 1)
+
+def Sminus (N k : ℕ) [NeZero N] (a : Fin 2 → ZMod N) (n : ℕ+) : ℂ :=
+  ∑ x ∈ (n : ℕ).divisorsAntidiagonal,
+    (if ((x.1 : ℕ) : ZMod N) = -a 0 then (1 : ℂ) else 0) * ZMod.stdAddChar (-a 1 * ((x.2 : ℕ) : ZMod
+      N)) *
+      ((x.2 : ℕ) : ℂ) ^ (k - 1)
+
+def coefFun (N k : ℕ) [NeZero N] (a : Fin 2 → ZMod N) (n : ℕ) : ℂ :=
+  if h : n = 0 then (if a 0 = 0 then ∑' d : cls N (a 1), (((d.1 : ℂ)) ^ k)⁻¹ else 0)
+  else kappa N k * (Splus N k a ⟨n, Nat.pos_of_ne_zero h⟩ + (-1) ^ k * Sminus N k a ⟨n,
+    Nat.pos_of_ne_zero h⟩)
+
+lemma norm_stdAddChar (x : ZMod N) : ‖ZMod.stdAddChar x‖ = 1 := by
+  rw [ZMod.stdAddChar_apply]; exact Circle.norm_coe _
+
+lemma norm_qParam_lt_one (τ : ℍ) : ‖Function.Periodic.qParam N τ‖ < 1 := by
+  rw [Function.Periodic.norm_qParam, Real.exp_lt_one_iff]
+  have hN : (0 : ℝ) < N := by exact_mod_cast NeZero.pos N
+  have hτ : 0 < τ.im := τ.im_pos
+  rw [UpperHalfPlane.coe_im]
+  exact div_neg_of_neg_of_pos (by nlinarith [Real.pi_pos]) hN
+
+lemma norm_divisorSum_le (hk : 1 ≤ k) (b b' : ZMod N) (n : ℕ+) :
+    ‖∑ x ∈ (n : ℕ).divisorsAntidiagonal,
+      (if ((x.1 : ℕ) : ZMod N) = b then (1 : ℂ) else 0) * ZMod.stdAddChar (b' * ((x.2 : ℕ) : ZMod
+        N)) *
+        ((x.2 : ℕ) : ℂ) ^ (k - 1)‖ ≤ ((n : ℕ) : ℝ) ^ k := by
+  refine (norm_sum_le _ _).trans ?_
+  have hle : ∀ x ∈ (n : ℕ).divisorsAntidiagonal,
+      ‖(if ((x.1 : ℕ) : ZMod N) = b then (1 : ℂ) else 0) * ZMod.stdAddChar (b' * ((x.2 : ℕ) : ZMod
+        N)) *
+        ((x.2 : ℕ) : ℂ) ^ (k - 1)‖ ≤ (fun i j : ℕ => ((j : ℝ)) ^ (k - 1)) x.1 x.2 := by
+    intro x hx
+    rw [norm_mul, norm_mul, norm_stdAddChar, mul_one, norm_pow, Complex.norm_natCast]
+    calc ‖(if ((x.1 : ℕ) : ZMod N) = b then (1 : ℂ) else 0)‖ * (x.2 : ℝ) ^ (k - 1)
+        ≤ 1 * (x.2 : ℝ) ^ (k - 1) := by
+          gcongr; split_ifs <;> simp
+      _ = (x.2 : ℝ) ^ (k - 1) := one_mul _
+  refine (Finset.sum_le_sum hle).trans ?_
+  rw [Nat.sum_divisorsAntidiagonal (fun i j : ℕ => ((j : ℝ)) ^ (k - 1))]
+  have hle2 : ∀ i ∈ (n : ℕ).divisors, (((n : ℕ) / i : ℕ) : ℝ) ^ (k - 1) ≤ ((n : ℕ) : ℝ) ^ (k - 1) :=
+    by
+    intro i hi
+    gcongr
+    exact_mod_cast Nat.div_le_self _ _
+  refine (Finset.sum_le_card_nsmul _ _ _ hle2).trans ?_
+  rw [nsmul_eq_mul]
+  calc ((((n : ℕ).divisors.card : ℕ) : ℝ)) * ((n : ℕ) : ℝ) ^ (k - 1)
+      ≤ ((n : ℕ) : ℝ) * ((n : ℕ) : ℝ) ^ (k - 1) := by
+        gcongr; exact_mod_cast Nat.card_divisors_le_self _
+    _ = ((n : ℕ) : ℝ) ^ k := by rw [← pow_succ']; congr 1; omega
+
+lemma summable_divisorSum_mul_pow (hk : 1 ≤ k) (b b' : ZMod N) {r : ℂ} (hr : ‖r‖ < 1) :
+    Summable fun n : ℕ+ => (∑ x ∈ (n : ℕ).divisorsAntidiagonal,
+      (if ((x.1 : ℕ) : ZMod N) = b then (1 : ℂ) else 0) * ZMod.stdAddChar (b' * ((x.2 : ℕ) : ZMod
+        N)) *
+        ((x.2 : ℕ) : ℂ) ^ (k - 1)) * r ^ (n : ℕ) := by
+  have hs : Summable fun n : ℕ => ‖((n : ℂ)) ^ k * r ^ n‖ :=
+    summable_norm_pow_mul_geometric_of_norm_lt_one k hr
+  refine Summable.of_norm_bounded (hs.subtype _) fun n => ?_
+  simp only [Function.comp_apply, norm_mul, norm_pow, Complex.norm_natCast]
+  exact mul_le_mul_of_nonneg_right (norm_divisorSum_le hk b b' n) (by positivity)
+
+theorem eisensteinG_eq_expansion (hk : 3 ≤ k) (a : Fin 2 → ZMod N) (τ : ℍ) :
+    EisensteinSeries.eisensteinG N k a τ =
+      (if a 0 = 0 then ∑' d : cls N (a 1), (((d.1 : ℂ)) ^ k)⁻¹ else 0) +
+        ∑' n : ℕ+, kappa N k * (Splus N k a n + (-1) ^ k * Sminus N k a n) *
+          Function.Periodic.qParam N τ ^ (n : ℕ) := by
+  set q := Function.Periodic.qParam N τ with hq
+  have hqn : ‖q‖ < 1 := norm_qParam_lt_one τ
+  rw [eisensteinG_eq_tsum_tsum hk a τ,
+    tsum_cls_split (a 0) (fun c : ℤ => ∑' d : cls N (a 1), ((((c : ℂ)) * τ + d.1) ^ k)⁻¹)
+      (summable_inner hk (a 1) τ)]
+  have hpos : ∀ c : ℕ+, (∑' d : cls N (a 1), (((((c : ℕ) : ℤ) : ℂ) * τ + d.1) ^ k)⁻¹) =
+      kappa N k * ∑' m : ℕ+, ((m : ℕ) : ℂ) ^ (k - 1) *
+        (ZMod.stdAddChar (a 1 * ((m : ℕ) : ZMod N)) * q ^ ((m : ℕ) * (c : ℕ))) := by
+    intro c
+    have := tsum_cls_eq (show 2 ≤ k by omega) (a 1) (c : ℕ) c.2 τ
+    simpa [kappa] using this
+  have hneg : ∀ c : ℕ+, (∑' d : cls N (a 1), ((((-((c : ℕ) : ℤ) : ℤ) : ℂ) * τ + d.1) ^ k)⁻¹) =
+      (-1) ^ k * (kappa N k * ∑' m : ℕ+, ((m : ℕ) : ℂ) ^ (k - 1) *
+        (ZMod.stdAddChar (-a 1 * ((m : ℕ) : ZMod N)) * q ^ ((m : ℕ) * (c : ℕ)))) := by
+    intro c
+    rw [tsum_cls_neg_eq (a 1) (c : ℕ) τ, tsum_cls_eq (show 2 ≤ k by
+      omega) (-a 1) (c : ℕ) c.2 τ, kappa]
+  simp only [Int.cast_zero, zero_mul, zero_add]
+  have e0 : (if (0 : ZMod N) = a 0 then ∑' d : cls N (a 1), (((d.1 : ℂ)) ^ k)⁻¹ else 0) =
+      (if a 0 = 0 then ∑' d : cls N (a 1), (((d.1 : ℂ)) ^ k)⁻¹ else 0) := by
+    simp only [eq_comm]
+  have epos : (∑' c : ℕ+, if (((c : ℕ)) : ZMod N) = a 0 then
+      ∑' d : cls N (a 1), (((((c : ℕ) : ℤ) : ℂ) * τ + d.1) ^ k)⁻¹ else 0) =
+      kappa N k * ∑' n : ℕ+, Splus N k a n * q ^ (n : ℕ) := by
+    have h1 : ∀ c : ℕ+, (if (((c : ℕ)) : ZMod N) = a 0 then
+        ∑' d : cls N (a 1), (((((c : ℕ) : ℤ) : ℂ) * τ + d.1) ^ k)⁻¹ else 0) =
+        kappa N k * ((if (((c : ℕ) : ℕ) : ZMod N) = a 0 then (1 : ℂ) else 0) *
+          ∑' m : ℕ+, ((m : ℕ) : ℂ) ^ (k - 1) *
+            (ZMod.stdAddChar (a 1 * ((m : ℕ) : ZMod N)) * q ^ ((m : ℕ) * (c : ℕ)))) := by
+      intro c
+      rw [hpos c]
+      split_ifs <;> simp
+    simp_rw [h1]
+    rw [tsum_mul_left]
+    congr 1
+    exact tsum_tsum_eq_tsum_antidiagonal (F := fun c : ℕ => if ((c : ℕ) : ZMod N) = a 0 then (1 : ℂ)
+      else 0)
+      (G := fun m : ℕ => ZMod.stdAddChar (a 1 * ((m : ℕ) : ZMod N)))
+      (fun c => by split_ifs <;> simp) (fun m => (norm_stdAddChar _).le) hqn (k - 1)
+  have eneg : (∑' c : ℕ+, if ((-((c : ℕ) : ℤ) : ℤ) : ZMod N) = a 0 then
+      ∑' d : cls N (a 1), ((((-((c : ℕ) : ℤ) : ℤ) : ℂ) * τ + d.1) ^ k)⁻¹ else 0) =
+      (-1) ^ k * (kappa N k * ∑' n : ℕ+, Sminus N k a n * q ^ (n : ℕ)) := by
+    have h1 : ∀ c : ℕ+, (if ((-((c : ℕ) : ℤ) : ℤ) : ZMod N) = a 0 then
+        ∑' d : cls N (a 1), ((((-((c : ℕ) : ℤ) : ℤ) : ℂ) * τ + d.1) ^ k)⁻¹ else 0) =
+        (-1) ^ k * (kappa N k * ((if (((c : ℕ) : ℕ) : ZMod N) = -a 0 then (1 : ℂ) else 0) *
+          ∑' m : ℕ+, ((m : ℕ) : ℂ) ^ (k - 1) *
+            (ZMod.stdAddChar (-a 1 * ((m : ℕ) : ZMod N)) * q ^ ((m : ℕ) * (c : ℕ))))) := by
+      intro c
+      rw [hneg c]
+      have hiff : ((-((c : ℕ) : ℤ) : ℤ) : ZMod N) = a 0 ↔ (((c : ℕ) : ℕ) : ZMod N) = -a 0 := by
+        rw [Int.cast_neg, Int.cast_natCast, neg_eq_iff_eq_neg]
+      simp only [hiff]
+      split_ifs <;> simp
+    simp_rw [h1]
+    rw [tsum_mul_left, tsum_mul_left]
+    congr 2
+    exact tsum_tsum_eq_tsum_antidiagonal (F := fun c : ℕ => if ((c : ℕ) : ZMod N) = -a 0 then (1 :
+      ℂ) else 0)
+      (G := fun m : ℕ => ZMod.stdAddChar (-a 1 * ((m : ℕ) : ZMod N)))
+      (fun c => by split_ifs <;> simp) (fun m => (norm_stdAddChar _).le) hqn (k - 1)
+  rw [e0, epos, eneg, add_assoc]
+  congr 1
+  have hs1 : Summable fun n : ℕ+ => kappa N k * (Splus N k a n * q ^ (n : ℕ)) :=
+    (summable_divisorSum_mul_pow (show 1 ≤ k by omega) (a 0) (a 1) hqn).mul_left _
+  have hs2 : Summable fun n : ℕ+ => (-1) ^ k * (kappa N k * (Sminus N k a n * q ^ (n : ℕ))) :=
+    ((summable_divisorSum_mul_pow (show 1 ≤ k by omega) (-a 0) (-a 1) hqn).mul_left _).mul_left _
+  change kappa N k * ∑' n : ℕ+, Splus N k a n * q ^ (n : ℕ) +
+    (-1) ^ k * (kappa N k * ∑' n : ℕ+, Sminus N k a n * q ^ (n : ℕ)) = _
+  rw [← tsum_mul_left, ← tsum_mul_left, ← tsum_mul_left, ← hs1.tsum_add hs2]
+  refine tsum_congr fun n => ?_
+  ring
+
+theorem hasSum_coefFun (hk : 3 ≤ k) (a : Fin 2 → ZMod N) (τ : ℍ) :
+    HasSum (fun n : ℕ => coefFun N k a n * Function.Periodic.qParam N τ ^ n)
+      (EisensteinSeries.eisensteinG N k a τ) := by
+  set q := Function.Periodic.qParam N τ with hq
+  have hqn : ‖q‖ < 1 := norm_qParam_lt_one τ
+  have hs1 := summable_divisorSum_mul_pow (show 1 ≤ k by omega) (a 0) (a 1) hqn
+  have hs2 := summable_divisorSum_mul_pow (show 1 ≤ k by omega) (-a 0) (-a 1) hqn
+  have hpn : ∀ n : ℕ+, coefFun N k a n * q ^ (n : ℕ) =
+      kappa N k * (Splus N k a n + (-1) ^ k * Sminus N k a n) * q ^ (n : ℕ) := by
+    intro n
+    simp only [coefFun, PNat.ne_zero, ↓reduceDIte]
+    rfl
+  have hsum : Summable fun n : ℕ+ => coefFun N k a n * q ^ (n : ℕ) := by
+    simp_rw [hpn]
+    have := ((hs1.add (hs2.mul_left ((-1 : ℂ) ^ k))).mul_left (kappa N k))
+    refine this.congr fun n => ?_
+    simp only [Splus, Sminus]
+    ring
+  have hsumN : Summable fun n : ℕ => coefFun N k a n * q ^ n := summable_pnat_iff_summable_nat.mp
+    hsum
+  have htsum : ∑' n : ℕ, coefFun N k a n * q ^ n = EisensteinSeries.eisensteinG N k a τ := by
+    rw [← tsum_zero_pnat_eq_tsum_nat hsumN, eisensteinG_eq_expansion hk a τ]
+    simp_rw [hpn]
+    congr 1
+    simp [coefFun]
+  exact htsum ▸ hsumN.hasSum
+
+theorem qExpansion_coeff_formula (hk : 3 ≤ k) (a : Fin 2 → ZMod N) (n : ℕ) :
+    (qExpansion N (EisensteinSeries.eisensteinG N k a)).coeff n =
+      if n = 0 then
+        (if a 0 = 0 then ∑' d : {d : ℤ // (d : ZMod N) = a 1}, ((d : ℂ) ^ k)⁻¹ else 0)
+      else
+        (-2 * π * I) ^ k / ((k - 1)! * (N : ℂ) ^ k) *
+          ∑ m ∈ n.divisors,
+            ((if ((n / m : ℕ) : ZMod N) = a 0 then ZMod.stdAddChar (a 1 * (m : ZMod N)) else 0) +
+              (-1) ^ k *
+                (if ((n / m : ℕ) : ZMod N) = -a 0 then ZMod.stdAddChar (-(a 1 * (m : ZMod N))) else
+                  0)) *
+            (m : ℂ) ^ (k - 1) := by
+  have hk' : 3 ≤ ((k : ℕ) : ℤ) := by exact_mod_cast hk
+  rw [qExpansion_coeff_eq hk' a (hasSum_coefFun hk a) n, coefFun]
+  by_cases hn : n = 0
+  · subst hn
+    rfl
+  · rw [dite_eq_right hn, ite_eq_right hn]
+    have hN : (N : ℂ) ≠ 0 := by exact_mod_cast NeZero.ne N
+    simp only [kappa, Splus, Sminus]
+    rw [Nat.sum_divisorsAntidiagonal' (fun i j : ℕ =>
+        (if ((i : ℕ) : ZMod N) = a 0 then (1 : ℂ) else 0) * ZMod.stdAddChar (a 1 * ((j : ℕ) : ZMod
+      N)) *
+          ((j : ℕ) : ℂ) ^ (k - 1)),
+      Nat.sum_divisorsAntidiagonal' (fun i j : ℕ =>
+        (if ((i : ℕ) : ZMod N) = -a 0 then (1 : ℂ) else 0) * ZMod.stdAddChar (-a 1 * ((j : ℕ) : ZMod
+      N)) *
+          ((j : ℕ) : ℂ) ^ (k - 1))]
+    simp only [PNat.mk_coe]
+    rw [Finset.mul_sum, ← Finset.sum_add_distrib, Finset.mul_sum, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun m _ => ?_
+    rw [neg_mul]
+    split_ifs <;> field_simp <;> ring_nf
+
+end expansion
+
+end CardC
+
+end
+
+open CardC in
+theorem solution (N : ℕ) [NeZero N] (k : ℕ) (hk : 3 ≤ k)
+    (a : Fin 2 → ZMod N) (n : ℕ) :
+    (UpperHalfPlane.qExpansion N (EisensteinSeries.eisensteinG N k a)).coeff n =
+      if n = 0 then
+        (if a 0 = 0 then ∑' d : {d : ℤ // (d : ZMod N) = a 1}, ((d : ℂ) ^ k)⁻¹ else 0)
+      else
+        (-2 * π * I) ^ k / ((k - 1)! * (N : ℂ) ^ k) *
+          ∑ m ∈ n.divisors,
+            ((if ((n / m : ℕ) : ZMod N) = a 0 then ZMod.stdAddChar (a 1 * (m : ZMod N)) else 0) +
+              (-1) ^ k *
+                (if ((n / m : ℕ) : ZMod N) = -a 0 then ZMod.stdAddChar (-(a 1 * (m : ZMod N))) else
+                  0)) *
+            (m : ℂ) ^ (k - 1) :=
+  CardC.qExpansion_coeff_formula hk a n
+
+end S_EisensteinSeries_qExpansion_eisensteinG_coeff
+end P2MW
+export P2MW.S_EisensteinSeries_qExpansion_eisensteinG_coeff (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Real Complex
+open scoped Nat
+theorem EisensteinSeries.qExpansion_eisensteinG_coeff (N : ℕ) [NeZero N] (k : ℕ) (hk : 3 ≤ k)
+    (a : Fin 2 → ZMod N) (n : ℕ) :
+    (UpperHalfPlane.qExpansion N (EisensteinSeries.eisensteinG N k a)).coeff n =
+      if n = 0 then
+        (if a 0 = 0 then ∑' d : {d : ℤ // (d : ZMod N) = a 1}, ((d : ℂ) ^ k)⁻¹ else 0)
+      else
+        (-2 * π * I) ^ k / ((k - 1)! * (N : ℂ) ^ k) *
+          ∑ m ∈ n.divisors,
+            ((if ((n / m : ℕ) : ZMod N) = a 0 then ZMod.stdAddChar (a 1 * (m : ZMod N)) else 0) +
+              (-1) ^ k *
+                (if ((n / m : ℕ) : ZMod N) = -a 0 then ZMod.stdAddChar (-(a 1 * (m : ZMod N))) else
+                  0)) *
+            (m : ℂ) ^ (k - 1) :=
+  solution N k hk a n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinSeries_sum_eisensteinG_vecCons_eq_mul_tsum_divisorSum_mul_cexp_pow.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinSeries_sum_eisensteinG_vecCons_eq_mul_tsum_divisorSum_mul_cexp_pow.lean
new file mode 100644
index 0000000000..a825e1d81f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinSeries_sum_eisensteinG_vecCons_eq_mul_tsum_divisorSum_mul_cexp_pow.lean
@@ -0,0 +1,356 @@
+/-
+Based on Prove2Me node EisensteinSeries.sum_eisensteinG_vecCons_eq_mul_tsum_divisorSum_mul_cexp_pow
+(faa7043a-9f5d-5d08-a50f-6a3f813098e8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 62569af8-a07d-5730-9bd8-c74f309f7f70
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.SpecialFunctions.Trigonometric.Basic
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EisensteinSeries_EisensteinG
+
+import Mathlib.NumberTheory.ModularForms.EisensteinSeries.QExpansion
+import Mathlib.Topology.Separation.CompletelyRegular
+
+/-!
+# q-expansion of level-N Eisenstein series summed over one row class
+
+Theorem statement: `EisensteinSeries.sum_eisensteinG_vecCons_eq_mul_tsum_divisorSum_mul_cexp_pow`
+(`faa7043a-9f5d-5d08-a50f-6a3f813098e8`), by Claude, 2026-09-05.
+
+Proof: submission `62569af8-a07d-5730-9bd8-c74f309f7f70`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a positive natural number, let $a \in \mathbb{Z}/N$ with $a \neq 0$, let $k$ be a natural
+number with $3 \le k$ and $k$ even, and let $z$ lie in the upper half-plane. For $v \in
+(\mathbb{Z}/N)^2$, [`EisensteinSeries.eisensteinG N k v
+z`](def/EisensteinSeries_EisensteinG.html#L5) is the sum of `eisSummand k w z`, i.e. of $(w_0 z +
+w_1)^{-k}$, over all $w \in \mathbb{Z}^2$ whose componentwise reduction modulo $N$ equals $v$ — the
+full congruence class, with no coprimality condition imposed. The assertion is that $$\sum_{e \in
+\mathbb{Z}/N} \mathrm{eisensteinG}\,N\,k\,(a,e)\,(z) = \frac{(-2\pi i)^k}{(k-1)!} \sum_{n \ge 0}
+\Big( \sum_{d \mid n} \big( [\,n/d \equiv a\,]\, d^{k-1} + [\,n/d \equiv -a\,]\, d^{k-1} \big) \Big)
+q^n,$$ where $q = \exp(2\pi i z)$, the bracket denotes the indicator of the stated congruence in
+$\mathbb{Z}/N$, and the inner sum runs over the divisors of $n$ (so the $n = 0$ term vanishes). The
+coefficient is written as a sum of two separate indicator terms, so for $n/d$ with $a = -a$ a
+divisor contributes twice.
+
+This is the Lipschitz–Hecke $q$-expansion for Eisenstein series of level $N$, here in the form
+obtained by summing the series over all rows congruent to a fixed nonzero first residue $a$; the
+hypothesis $a \neq 0$ removes the row $m = 0$ and hence the constant term, and evenness of $k$
+identifies the rows $m$ and $-m$. It supplies the explicit expansion used in
+[`ModularForm.exists_gamma1_weight_four_isIntegralQExp_partialDivisorSum_slash_eq`]
+(thm.html#ModularForm.exists_gamma1_weight_four_isIntegralQExp_partialDivisorSum_slash_eq),
+where a weight-four form with integral $q$-expansion and prescribed partial divisor-sum coefficients
+is produced.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_EisensteinSeries_sum_eisensteinG_vecCons_eq_mul_tsum_divisorSum_mul_cexp_pow.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+open scoped Real UpperHalfPlane
+
+local notation "𝕢" z => Complex.exp (2 * π * Complex.I * z)
+
+section privateSection
+
+private theorem tsum_nat_eq_tsum_pnat_of_zero
+    (h : ℕ → ℂ) (h0 : h 0 = 0) (hs : Summable fun n => h (n + 1)) :
+    ∑' n : ℕ, h n = ∑' n : ℕ+, h n := by
+  rw [tsum_eq_zero_add' hs, h0, zero_add, tsum_pnat_eq_tsum_succ]
+
+private theorem sum_eisensteinG_eq_tsum_indicator
+    (N : ℕ) [NeZero N] (a : ZMod N) {k : ℕ} (hk : 3 ≤ k) (z : ℍ) :
+    ∑ e : ZMod N, EisensteinSeries.eisensteinG N k ![a, e] z =
+      ∑' v, ({v : Fin 2 → ℤ | v 0 = a}).indicator
+        (fun v => EisensteinSeries.eisSummand k v z) v := by
+  classical
+  have hk3 : (3 : ℤ) ≤ (k : ℤ) := mod_cast hk
+  let f : (Fin 2 → ℤ) → ℂ := fun v => EisensteinSeries.eisSummand k v z
+  have hfsum : Summable fun v => ‖f v‖ := EisensteinSeries.summable_norm_eisSummand hk3 z
+  let S : Set (Fin 2 → ℤ) := {v | ((v 0 : ℤ) : ZMod N) = a}
+  change ∑ e : ZMod N, EisensteinSeries.eisensteinG N k ![a, e] z =
+    ∑' v, S.indicator f v
+  have hS : ∀ e : ZMod N, EisensteinSeries.eisensteinG N k ![a, e] z =
+      ∑' v, ({v : Fin 2 → ℤ | ((↑) : ℤ → ZMod N) ∘ v = ![a, e]}).indicator f v := by
+    intro e
+    rw [EisensteinSeries.eisensteinG, ← tsum_subtype]
+    rfl
+  simp_rw [hS]
+  rw [← Summable.tsum_finsetSum (fun e _ => hfsum.of_norm.indicator _)]
+  refine tsum_congr fun v => ?_
+  simp only [Set.indicator_apply, Set.mem_ofPred_eq]
+  by_cases hv : v ∈ S
+  · have hv' : ((v 0 : ℤ) : ZMod N) = a := hv
+    rw [ite_eq_left hv, Finset.sum_eq_single ((v 1 : ℤ) : ZMod N)]
+    · rw [ite_eq_left]
+      funext i
+      fin_cases i <;> simp [hv']
+    · intro e _ hne
+      rw [ite_eq_right]
+      intro h
+      apply hne
+      have := congrFun h 1
+      simpa using this.symm
+    · grind
+  · rw [ite_eq_right hv]
+    refine Finset.sum_eq_zero fun e _ => ?_
+    rw [ite_eq_right]
+    intro h
+    apply hv
+    change ((v 0 : ℤ) : ZMod N) = a
+    have := congrFun h 0
+    simpa using this
+
+noncomputable def eisSummand_row_sum (k : ℕ) (z : ℍ) (m : ℤ) :=
+  ∑' n, EisensteinSeries.eisSummand k ![m, n] z
+
+private theorem eisSummand_row_sum_eq_qExpansion
+    {k : ℕ} (hk1 : 1 ≤ k - 1) (hkk : k - 1 + 1 = k) (z : ℍ) (m : ℕ+) :
+    eisSummand_row_sum k z m =
+      ((-2 * π * Complex.I) ^ k / Nat.factorial (k - 1)) *
+        ∑' d : ℕ+, (((d : ℕ) : ℂ) ^ (k - 1)) *
+          (𝕢 z) ^ (m * d : ℕ) := by
+  let q := 𝕢 z
+  let C := (-2 * π * Complex.I) ^ k / Nat.factorial (k - 1)
+  have hm : 0 < (m : ℕ) := m.pos
+  have hz' : 0 < (((m : ℕ) : ℂ) * (z : ℂ)).im := by
+    simpa [Complex.mul_im] using mul_pos (Nat.cast_pos.mpr hm : (0 : ℝ) < m) z.im_pos
+  have H := EisensteinSeries.qExpansion_identity
+    (k := k - 1) hk1 ⟨((m : ℕ) : ℂ) * z, hz'⟩
+  rw [hkk] at H
+  have hlhs : eisSummand_row_sum k z m =
+      ∑' n : ℤ, 1 / (((⟨((m : ℕ) : ℂ) * z, hz'⟩ : ℍ) : ℂ) + n) ^ k := by
+    refine tsum_congr fun n => ?_
+    simp only [EisensteinSeries.eisSummand, Matrix.cons_val_zero, Matrix.cons_val_one]
+    rw [zpow_neg, zpow_natCast, one_div]
+    norm_cast
+  rw [hlhs, H]
+  congr 1
+  have hqm : Complex.exp
+      (2 * π * Complex.I * (((⟨((m : ℕ) : ℂ) * z, hz'⟩ : ℍ) : ℂ))) =
+        q ^ (m : ℕ) := by
+    rw [UpperHalfPlane.coe_mk, ← Complex.exp_nat_mul]
+    grind
+  simp_rw [hqm, ← pow_mul]
+  refine tsum_nat_eq_tsum_pnat_of_zero
+    (fun d => ((d : ℂ) ^ (k - 1)) * q ^ ((m : ℕ) * d)) (by
+      simp [zero_pow (by omega : k - 1 ≠ 0)]) ?_
+  have hqn : ‖q‖ < 1 := UpperHalfPlane.norm_exp_two_pi_I_lt_one z
+  have hqn' : ‖q ^ (m : ℕ)‖ < 1 := by
+    rw [norm_pow]
+    exact pow_lt_one₀ (norm_nonneg _) hqn (by omega)
+  have hs := summable_pow_mul_geometric_of_norm_lt_one (k - 1) hqn'
+  simp_rw [← pow_mul] at hs
+  simpa [q] using (summable_nat_add_iff 1).mpr hs
+
+theorem solution
+    (N : ℕ) [NeZero N] (a : ZMod N) (ha : a ≠ 0) {k : ℕ} (hk : 3 ≤ k) (hk2 : Even k) (z : ℍ) :
+    ∑ e : ZMod N, EisensteinSeries.eisensteinG N k ![a, e] z =
+      ((-2 * π * Complex.I) ^ k / (Nat.factorial (k - 1) : ℂ)) *
+        ∑' n : ℕ, (∑ d ∈ n.divisors,
+            ((if ((n / d : ℕ) : ZMod N) = a then (d : ℂ) ^ (k - 1) else 0) +
+              (if ((n / d : ℕ) : ZMod N) = -a then (d : ℂ) ^ (k - 1) else 0))) *
+          (𝕢 z) ^ n := by
+  classical
+  set q : ℂ := 𝕢 z
+  have hqn : ‖q‖ < 1 := UpperHalfPlane.norm_exp_two_pi_I_lt_one z
+  obtain ⟨C, hC⟩ : ∃ C : ℂ, C = (-2 * π * Complex.I) ^ k / (Nat.factorial (k - 1) : ℂ) := ⟨_, rfl⟩
+  rw [← hC]
+  have hk1 : 1 ≤ k - 1 := by omega
+  have hkk : k - 1 + 1 = k := by omega
+  have hk3 : (3 : ℤ) ≤ (k : ℤ) := by exact_mod_cast hk
+  have hkeven : Even (-(k : ℤ)) := (Int.even_coe_nat k |>.mpr hk2).neg
+  let f : (Fin 2 → ℤ) → ℂ := fun v => EisensteinSeries.eisSummand k v z
+  have hfsum : Summable fun v => ‖f v‖ := EisensteinSeries.summable_norm_eisSummand hk3 z
+  let S : Set (Fin 2 → ℤ) := {v | ((v 0 : ℤ) : ZMod N) = a}
+  have h1 : ∑ e : ZMod N, EisensteinSeries.eisensteinG N k ![a, e] z =
+      ∑' v, S.indicator f v :=
+    sum_eisensteinG_eq_tsum_indicator N a hk z
+  let row : ℤ → ℂ := eisSummand_row_sum k z
+  let F : ℤ × ℤ → ℂ := (S.indicator f) ∘ (finTwoArrowEquiv ℤ).symm
+  have hF : ∀ p : ℤ × ℤ, F p = if ((p.1 : ℤ) : ZMod N) = a then f ![p.1, p.2] else 0 := fun p => by
+    simp only [F, Function.comp_apply, finTwoArrowEquiv_symm_apply, Set.indicator_apply, S,
+      Set.mem_ofPred_eq, Matrix.cons_val_zero]
+    rfl
+  have hFsum : Summable F := (Equiv.summable_iff _).mpr (hfsum.of_norm.indicator S)
+  let G : ℤ → ℂ := fun m => if m = a then row m else 0
+  have h2 : ∑' v, S.indicator f v = ∑' m : ℤ, G m := by
+    rw [← ((finTwoArrowEquiv ℤ).symm.tsum_eq (S.indicator f)),
+      show (fun c : ℤ × ℤ => S.indicator f ((finTwoArrowEquiv ℤ).symm c)) = F from rfl,
+      hFsum.tsum_prod]
+    exact tsum_congr fun m => by grind [eisSummand_row_sum, tsum_zero]
+  have hGsum : Summable G := hFsum.prod.congr fun _ ↦ by
+    grind [eisSummand_row_sum, tsum_zero]
+  have hrowsum : Summable row := by
+    have hall : Summable (f ∘ (finTwoArrowEquiv ℤ).symm) := (Equiv.summable_iff _).mpr hfsum.of_norm
+    refine hall.prod.congr fun m => ?_
+    simp only [Function.comp_apply, finTwoArrowEquiv_symm_apply]
+    rfl
+  have hrow_neg : ∀ m : ℤ, row (-m) = row m := by
+    intro m
+    simp only [row, eisSummand_row_sum]
+    rw [← (Equiv.neg ℤ).tsum_eq]
+    refine tsum_congr fun n => ?_
+    simp [EisensteinSeries.eisSummand, ← neg_add, -neg_add_rev, hkeven.neg_zpow]
+  have hG0 : ∀ m : ℕ,
+      G (m : ℤ) = (if ((m : ℕ) : ZMod N) = a then (1 : ℂ) else 0) * row m := fun m => by
+    dsimp only [G]
+    rw [Int.cast_natCast, boole_mul]
+  have hGneg : ∀ m : ℕ, G (-((m : ℤ) + 1)) =
+      (if (((m + 1 : ℕ)) : ZMod N) = -a then (1 : ℂ) else 0) * row ((m : ℤ) + 1) := fun m => by
+    dsimp only [G]
+    rw [hrow_neg, boole_mul]
+    have : ((((-((m : ℤ) + 1)) : ℤ) : ZMod N) = a) ↔ (((m + 1 : ℕ) : ZMod N) = -a) := by
+      push_cast
+      rw [neg_eq_iff_eq_neg]
+    simp only [this]
+  have hsumA : Summable fun m : ℕ => (if ((m : ℕ) : ZMod N) = a then (1 : ℂ) else 0) * row m := by
+    have := hGsum.comp_injective Nat.cast_injective
+    refine this.congr fun m => ?_
+    exact hG0 m
+  have hsumB : Summable fun m : ℕ => (if ((m : ℕ) : ZMod N) = -a then (1 : ℂ) else 0) * row m := by
+    have := hrowsum.comp_injective Nat.cast_injective
+    refine Summable.of_norm_bounded this.norm fun m => ?_
+    simp only [Function.comp_apply, norm_mul]
+    split_ifs <;> simp
+  have h3 : ∑' m : ℤ, G m =
+      ∑' m : ℕ, ((if ((m : ℕ) : ZMod N) = a then (1 : ℂ) else 0) +
+        (if ((m : ℕ) : ZMod N) = -a then (1 : ℂ) else 0)) * row m := by
+    have hinj : Function.Injective (fun n : ℕ => -((n : ℤ) + 1)) := by
+      intro x y h
+      simp only [neg_inj, add_left_inj, Nat.cast_inj] at h
+      exact h
+    have hsN : Summable fun n : ℕ => G (n : ℤ) := hGsum.comp_injective Nat.cast_injective
+    have hsNeg : Summable fun n : ℕ => G (-((n : ℤ) + 1)) := hGsum.comp_injective hinj
+    rw [tsum_of_nat_of_neg_add_one (f := G) hsN hsNeg]
+    simp only [hG0, hGneg]
+    have hB' : ∑' m : ℕ, (if ((m + 1 : ℕ) : ZMod N) = -a then (1 : ℂ) else 0) * row ((m : ℤ) + 1) =
+        ∑' m : ℕ, (if ((m : ℕ) : ZMod N) = -a then (1 : ℂ) else 0) * row m := by
+      rw [hsumB.tsum_eq_zero_add]
+      have h0 : ¬ ((0 : ℕ) : ZMod N) = -a := by
+        rw [Nat.cast_zero, eq_comm, neg_eq_zero]
+        exact ha
+      rw [ite_eq_right h0, zero_mul, zero_add]
+      push_cast
+      rfl
+    rw [hB', ← hsumA.tsum_add hsumB]
+    exact tsum_congr fun m => by ring
+  let w : ℕ → ℂ := fun m =>
+      (if ((m : ℕ) : ZMod N) = a then (1 : ℂ) else 0) + (if ((m : ℕ) : ZMod N) = -a then (1 : ℂ)
+        else 0)
+  have hw0 : w 0 = 0 := by
+    have h1 : ¬ ((0 : ℕ) : ZMod N) = a := by rw [Nat.cast_zero]; exact fun h => ha h.symm
+    have h2 : ¬ ((0 : ℕ) : ZMod N) = -a := by
+      rw [Nat.cast_zero, eq_comm, neg_eq_zero]; exact ha
+    dsimp only [w]
+    rw [ite_eq_right h1, ite_eq_right h2, add_zero]
+  have hwnorm : ∀ m, ‖w m‖ ≤ 2 := fun m => by
+    dsimp only [w]
+    refine (norm_add_le _ _).trans ?_
+    have : ∀ P : Prop, ∀ _ : Decidable P, ‖(if P then (1 : ℂ) else 0)‖ ≤ 1 := by
+      intro P _; split_ifs <;> simp
+    linarith [this (((m : ℕ) : ZMod N) = a) inferInstance, this (((m : ℕ) : ZMod N) = -a)
+      inferInstance]
+  have hrow : ∀ m : ℕ+, row m =
+      C * ∑' d : ℕ+, (((d : ℕ) : ℂ) ^ (k - 1)) * q ^ ((m : ℕ) * (d : ℕ)) := by
+    intro m
+    simpa only [hC, row, f, eisSummand_row_sum]
+      using eisSummand_row_sum_eq_qExpansion hk1 hkk z m
+  let gP : ℕ+ × ℕ+ → ℂ :=
+    fun c => w c.1 * ((((c.2 : ℕ) : ℂ) ^ (k - 1)) * q ^ ((c.1 : ℕ) * (c.2 : ℕ)))
+  have hgP : Summable gP := by
+    refine Summable.of_norm_bounded ((summable_prod_mul_pow (𝕜 := ℂ) (k - 1) hqn).norm.mul_left 2)
+      fun c => ?_
+    simp only [gP, norm_mul]
+    gcongr
+    exact hwnorm _
+  have h5 : ∑' m : ℕ, ((if ((m : ℕ) : ZMod N) = a then (1 : ℂ) else 0) +
+        (if ((m : ℕ) : ZMod N) = -a then (1 : ℂ) else 0)) * row m = C * ∑' c : ℕ+ × ℕ+, gP c := by
+    have e : (fun m : ℕ => ((if ((m : ℕ) : ZMod N) = a then (1 : ℂ) else 0) +
+        (if ((m : ℕ) : ZMod N) = -a then (1 : ℂ) else 0)) * row m) = fun m => w m * row m := by
+      rfl
+    rw [e]
+    have hsw : Summable (fun m : ℕ => w (m + 1) * row ((m + 1 : ℕ) : ℤ)) := by
+      have := (hsumA.add hsumB)
+      have h' : Summable fun m : ℕ => w m * row m := by
+        refine this.congr fun m => ?_
+        grind
+      exact (summable_nat_add_iff 1).mpr h'
+    rw [tsum_nat_eq_tsum_pnat_of_zero (fun m => w m * row m) (by simp [hw0]) hsw,
+      hgP.tsum_prod, ← tsum_mul_left]
+    refine tsum_congr fun m => ?_
+    rw [hrow m, ← mul_assoc, mul_comm (w m) C, mul_assoc, ← tsum_mul_left]
+  have h6 : ∑' c : ℕ+ × ℕ+, gP c =
+      ∑' n : ℕ+, (∑ i ∈ (n : ℕ).divisors, w ((n : ℕ) / i) * ((i : ℂ) ^ (k - 1))) * q ^ (n : ℕ) := by
+    have hs' : Summable (fun c : (n : ℕ+) × {x // x ∈ (n : ℕ).divisorsAntidiagonal} =>
+        gP (sigmaAntidiagonalEquivProd c)) := sigmaAntidiagonalEquivProd.summable_iff.mpr hgP
+    rw [← sigmaAntidiagonalEquivProd.tsum_eq, hs'.tsum_sigma]
+    refine tsum_congr fun n => ?_
+    simp only [tsum_fintype, Finset.univ_eq_attach, sigmaAntidiagonalEquivProd,
+      divisorsAntidiagonalFactors, Equiv.coe_fn_mk, PNat.mk_coe, gP]
+    rw [Finset.sum_attach ((n : ℕ).divisorsAntidiagonal)
+      (fun p : ℕ × ℕ => w p.1 * (((p.2 : ℂ) ^ (k - 1)) * q ^ (p.1 * p.2))),
+      Nat.sum_divisorsAntidiagonal' (fun x y => w x * (((y : ℂ) ^ (k - 1)) * q ^ (x * y))),
+      Finset.sum_mul]
+    refine Finset.sum_congr rfl fun i hi => ?_
+    rw [Nat.div_mul_cancel (Nat.dvd_of_mem_divisors hi)]
+    ring
+  rw [h1, h2, h3, h5, h6]
+  congr 1
+  have hfin : Summable fun n : ℕ+ =>
+      (∑ i ∈ (n : ℕ).divisors, w ((n : ℕ) / i) * ((i : ℂ) ^ (k - 1))) * q ^ (n : ℕ) := by
+    have hs' : Summable (fun c : (n : ℕ+) × {x // x ∈ (n : ℕ).divisorsAntidiagonal} =>
+        gP (sigmaAntidiagonalEquivProd c)) := sigmaAntidiagonalEquivProd.summable_iff.mpr hgP
+    refine hs'.sigma.congr fun n => ?_
+    simp only [tsum_fintype, Finset.univ_eq_attach, sigmaAntidiagonalEquivProd,
+      divisorsAntidiagonalFactors, Equiv.coe_fn_mk, PNat.mk_coe, gP]
+    rw [Finset.sum_attach ((n : ℕ).divisorsAntidiagonal)
+      (fun p : ℕ × ℕ => w p.1 * (((p.2 : ℂ) ^ (k - 1)) * q ^ (p.1 * p.2))),
+      Nat.sum_divisorsAntidiagonal' (fun x y => w x * (((y : ℂ) ^ (k - 1)) * q ^ (x * y))),
+      Finset.sum_mul]
+    refine Finset.sum_congr rfl fun i hi => ?_
+    rw [Nat.div_mul_cancel (Nat.dvd_of_mem_divisors hi)]
+    ring
+  symm
+  refine (tsum_nat_eq_tsum_pnat_of_zero (fun n : ℕ => (∑ d ∈ n.divisors,
+      ((if ((n / d : ℕ) : ZMod N) = a then (d : ℂ) ^ (k - 1) else 0) +
+        (if ((n / d : ℕ) : ZMod N) = -a then (d : ℂ) ^ (k - 1) else 0))) * q ^ n)
+      (by simp) ?_).trans ?_
+  · have := (Equiv.pnatEquivNat.symm.summable_iff).mpr hfin
+    refine this.congr fun n => ?_
+    simp only [Function.comp_apply, Equiv.pnatEquivNat_symm_apply, Nat.succPNat_coe,
+      Nat.succ_eq_add_one]
+    congr 1
+    exact Finset.sum_congr rfl fun i _ => by grind
+  · refine tsum_congr fun n => ?_
+    congr 1
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [add_mul, boole_mul, boole_mul]
+
+end privateSection
+
+public section publicSection
+
+open scoped Real in
+theorem EisensteinSeries.sum_eisensteinG_vecCons_eq_mul_tsum_divisorSum_mul_cexp_pow
+    (N : ℕ) [NeZero N] (a : ZMod N) (ha : a ≠ 0) {k : ℕ} (hk : 3 ≤ k) (hk2 : Even k)
+    (z : ℍ) :
+    ∑ e : ZMod N, EisensteinSeries.eisensteinG N k ![a, e] z =
+      ((-2 * π * Complex.I) ^ k / (Nat.factorial (k - 1) : ℂ)) *
+        ∑' n : ℕ, (∑ d ∈ n.divisors,
+            ((if ((n / d : ℕ) : ZMod N) = a then (d : ℂ) ^ (k - 1) else 0) +
+              (if ((n / d : ℕ) : ZMod N) = -a then (d : ℂ) ^ (k - 1) else 0))) *
+          (𝕢 z) ^ n :=
+  solution N a ha hk hk2 z
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinSeries_weierstrassZeta_add_one_and_add_tau_and_smul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinSeries_weierstrassZeta_add_one_and_add_tau_and_smul.lean
new file mode 100644
index 0000000000..dc44a41df9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinSeries_weierstrassZeta_add_one_and_add_tau_and_smul.lean
@@ -0,0 +1,366 @@
+/-
+Based on Prove2Me node EisensteinSeries.weierstrassZeta_add_one_and_add_tau_and_smul
+(9b5842de-612d-5bc9-94e6-354e3293212b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f5c56077-8682-5e1c-90d2-348553fe3395
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EisensteinSeries_WeierstrassZeta
+
+import Mathlib.Analysis.SpecialFunctions.Trigonometric.Cotangent
+import LeanPool.FLTEichlerShimura.Theorems.Thm_EisensteinSeries_hasSum_weierstrassZeta_sub_mul_G2
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Quasi-periods of the Weierstrass ζ-function and its SL₂(ℤ)-homogeneity
+
+Theorem statement: `EisensteinSeries.weierstrassZeta_add_one_and_add_tau_and_smul`
+(`9b5842de-612d-5bc9-94e6-354e3293212b`), by Claude, 2026-09-05.
+
+Proof: submission `f5c56077-8682-5e1c-90d2-348553fe3395`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a point $\tau$ of the upper half-plane, and let $\zeta(\tau,z)$ denote
+[`EisensteinSeries.weierstrassZeta τ z`](def/EisensteinSeries_WeierstrassZeta.html#L5), namely $1/z$
+plus the sum over all $v\in\mathbb Z^2$, the term at $v=0$ being set to $0$, of
+$\frac{1}{z-(v_0\tau+v_1)}+\frac{1}{v_0\tau+v_1}+\frac{z}{(v_0\tau+v_1)^2}$. The theorem asserts
+three statements simultaneously. First, for every $z\in\mathbb C$ such that $z\neq v_0\tau+v_1$ for
+all $v\in\mathbb Z^2$ (that is, $z$ lies outside the lattice $\mathbb Z\tau+\mathbb Z$), one has
+$\zeta(\tau,z+1)=\zeta(\tau,z)+G_2(\tau)$, where $G_2$ is `EisensteinSeries.G2`. Secondly, for every
+such $z$, $\zeta(\tau,z+\tau)=\zeta(\tau,z)+\bigl(\tau\,G_2(\tau)-2\pi i\bigr)$. Thirdly, for every
+$\gamma\in SL(2,\mathbb Z)$ and every $z\in\mathbb C$, with no restriction on $z$,
+$$\zeta\bigl(\gamma\cdot\tau,\
+z/\mathrm{denom}(\gamma,\tau)\bigr)=\mathrm{denom}(\gamma,\tau)\cdot\zeta(\tau,z),$$ where
+$\mathrm{denom}(\gamma,\tau)=c\tau+d$ for $\gamma=\begin{pmatrix}a&b\\c&d\end{pmatrix}$ and
+$\gamma\cdot\tau$ is the usual action on the upper half-plane.
+
+The first two clauses identify the quasi-periods of the Weierstrass $\zeta$-function of the lattice
+$\mathbb Z\tau+\mathbb Z$ as $\eta_2=G_2(\tau)$ attached to the period $1$ and $\eta_1=\tau
+G_2(\tau)-2\pi i$ attached to the period $\tau$, so that Legendre's relation
+$\eta_2\cdot\tau-\eta_1\cdot 1=2\pi i$ holds; the third expresses the homogeneity of degree $-1$ of
+$\zeta$ in the lattice, reflecting $\mathbb Z(\gamma\tau)+\mathbb Z=(c\tau+d)^{-1}(\mathbb
+Z\tau+\mathbb Z)$. It is used in the treatment of the weight-one Eisenstein series, via
+[`EisensteinSeries.eisensteinG1_apply_smul_and_eisensteinG1_add`]
+(thm.html#EisensteinSeries.eisensteinG1_apply_smul_and_eisensteinG1_add).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_EisensteinSeries_weierstrassZeta_add_one_and_add_tau_and_smul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_EisensteinSeries_weierstrassZeta_add_one_and_add_tau_and_smul
+
+open scoped Topology Real MatrixGroups Matrix
+p2m_open "UpperHalfPlane~I"
+open EisensteinSeries Filter Complex Asymptotics
+
+noncomputable section
+
+namespace WZB
+
+variable (τ : ℍ)
+
+local notation "ℂ_ℤ" => Complex.integerComplement
+
+def om (v : Fin 2 → ℤ) : ℂ := (v 0 : ℂ) * τ + v 1
+
+def zterm (z : ℂ) (v : Fin 2 → ℤ) : ℂ :=
+  if v = 0 then 0 else (1 / (z - om τ v) + 1 / om τ v + z / om τ v ^ 2)
+
+lemma weierstrassZeta_eq (z : ℂ) : weierstrassZeta τ z = 1 / z + ∑' v, zterm τ z v := rfl
+
+lemma om_smul (γ : SL(2, ℤ)) (v : Fin 2 → ℤ) :
+    om (γ • τ) v = om τ (v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ)) / denom γ τ := by
+  have h := eisSummand_SL2_apply (-1) v γ τ
+  simp only [eisSummand, neg_neg, zpow_one, zpow_neg] at h
+  simpa [om, div_eq_inv_mul] using h
+
+def vecMulEquiv (γ : SL(2, ℤ)) : (Fin 2 → ℤ) ≃ (Fin 2 → ℤ) where
+  toFun v := v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ)
+  invFun v := v ᵥ* ((γ⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)
+  left_inv v := by
+    simp_rw [Matrix.vecMul_vecMul, ← Matrix.SpecialLinearGroup.coe_mul, mul_inv_cancel,
+      Matrix.SpecialLinearGroup.coe_one, Matrix.vecMul_one]
+  right_inv v := by
+    simp_rw [Matrix.vecMul_vecMul, ← Matrix.SpecialLinearGroup.coe_mul, inv_mul_cancel,
+      Matrix.SpecialLinearGroup.coe_one, Matrix.vecMul_one]
+
+lemma vecMul_eq_zero_iff (γ : SL(2, ℤ)) (v : Fin 2 → ℤ) :
+    v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ) = 0 ↔ v = 0 := by
+  constructor
+  · intro h
+    have := congr_arg (vecMulEquiv γ).symm h
+    rw [show (vecMulEquiv γ).symm (v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ)) = v from
+      (vecMulEquiv γ).symm_apply_apply v] at this
+    rw [this]
+    simp [vecMulEquiv]
+  · rintro rfl; simp
+
+lemma zterm_smul (γ : SL(2, ℤ)) (z : ℂ) (v : Fin 2 → ℤ) :
+    zterm (γ • τ) (z / denom γ τ) v =
+      denom γ τ * zterm τ z (v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ)) := by
+  have hD : denom (γ : GL (Fin 2) ℝ) τ ≠ 0 := denom_ne_zero _ τ
+  by_cases hv : v = 0
+  · subst hv
+    simp [zterm]
+  · have hv' : v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ) ≠ 0 := by
+      rwa [Ne, vecMul_eq_zero_iff]
+    rw [zterm, ite_eq_right hv, zterm, ite_eq_right hv', om_smul]
+    set D : ℂ := denom (γ : GL (Fin 2) ℝ) τ with hDdef
+    set w : ℂ := om τ (v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ))
+    rw [show z / D - w / D = (z - w) / D by ring, one_div_div, one_div_div,
+      show z / D / (w / D) ^ 2 = D * (z / w ^ 2) by
+        field_simp]
+    rw [div_eq_mul_one_div D (z - w), div_eq_mul_one_div D w]
+    ring
+
+theorem weierstrassZeta_smul (γ : SL(2, ℤ)) (z : ℂ) :
+    weierstrassZeta (γ • τ) (z / denom γ τ) = denom γ τ * weierstrassZeta τ z := by
+  have hD : denom (γ : GL (Fin 2) ℝ) τ ≠ 0 := denom_ne_zero _ τ
+  rw [weierstrassZeta_eq, weierstrassZeta_eq, one_div_div]
+  simp_rw [zterm_smul]
+  rw [tsum_mul_left]
+  rw [show ∑' v, zterm τ z (v ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ)) = ∑' v, zterm τ z v from
+    (vecMulEquiv γ).tsum_eq (zterm τ z)]
+  rw [div_eq_mul_one_div]
+  ring
+
+lemma cot_neg (x : ℂ) : Complex.cot (-x) = -Complex.cot x := by
+  simp [Complex.cot_eq_cos_div_sin, Complex.sin_neg, Complex.cos_neg, div_neg]
+
+lemma cot_pi_add_one (w : ℂ) : Complex.cot (π * (w + 1)) = Complex.cot (π * w) := by
+  rw [Complex.cot_pi_eq_exp_ratio, Complex.cot_pi_eq_exp_ratio]
+  have : cexp (2 * π * I * (w + 1)) = cexp (2 * π * I * w) := by
+    rw [mul_add, Complex.exp_add, mul_one, Complex.exp_two_pi_mul_I, mul_one]
+  rw [this]
+
+lemma cot_pi_add_intCast (w : ℂ) (n : ℤ) : Complex.cot (π * (w + n)) = Complex.cot (π * w) := by
+  induction n using Int.induction_on with
+  | zero => simp
+  | succ n ih => rw [← ih]; push_cast; rw [← add_assoc, cot_pi_add_one]
+  | pred n ih =>
+      rw [← ih]; push_cast
+      rw [show w + -(n : ℂ) = (w + (-(n : ℂ) - 1)) + 1 by ring, cot_pi_add_one]
+
+lemma norm_cexp_two_pi_I (w : ℂ) : ‖cexp (2 * π * I * w)‖ = Real.exp (-2 * π * w.im) := by
+  rw [Complex.norm_exp]
+  congr 1
+  simp [Complex.mul_re, Complex.mul_im, mul_comm]
+
+lemma pi_cot_add_eq (w : ℂ) (hq : cexp (2 * π * I * w) ≠ 1) :
+    π * Complex.cot (π * w) + π * I =
+      2 * π * cexp (2 * π * I * w) / (I * (1 - cexp (2 * π * I * w))) := by
+  rw [Complex.cot_pi_eq_exp_ratio]
+  set q := cexp (2 * π * I * w) with hq_def
+  have h1 : (1 - q) ≠ 0 := sub_ne_zero.mpr (Ne.symm hq)
+  have h2 : I * (1 - q) ≠ 0 := mul_ne_zero I_ne_zero h1
+  rw [eq_div_iff h2, add_mul, mul_assoc, div_mul_cancel₀ _ h2]
+  ring_nf
+  rw [I_sq]
+  ring
+
+lemma norm_pi_cot_add_le {w : ℂ} {Y : ℝ} (hY : 0 < Y) (hw : Y ≤ w.im) :
+    ‖π * Complex.cot (π * w) + π * I‖ ≤
+      2 * π * Real.exp (-2 * π * w.im) / (1 - Real.exp (-2 * π * Y)) := by
+  have hq : ‖cexp (2 * π * I * w)‖ = Real.exp (-2 * π * w.im) := norm_cexp_two_pi_I w
+  have hqY : Real.exp (-2 * π * w.im) ≤ Real.exp (-2 * π * Y) := by
+    apply Real.exp_le_exp.mpr
+    nlinarith [Real.pi_pos]
+  have hY1 : Real.exp (-2 * π * Y) < 1 := by
+    rw [Real.exp_lt_one_iff]
+    nlinarith [Real.pi_pos]
+  have hq1 : ‖cexp (2 * π * I * w)‖ < 1 := by rw [hq]; linarith
+  have hne : cexp (2 * π * I * w) ≠ 1 := by
+    intro h; rw [h, norm_one] at hq1; exact lt_irrefl _ hq1
+  rw [pi_cot_add_eq w hne, norm_div, norm_mul, norm_mul, norm_mul, Complex.norm_I, one_mul,
+    Complex.norm_two, Complex.norm_real, Real.norm_of_nonneg Real.pi_pos.le, hq]
+  have hden : 1 - Real.exp (-2 * π * Y) ≤ ‖1 - cexp (2 * π * I * w)‖ := by
+    calc 1 - Real.exp (-2 * π * Y) ≤ 1 - ‖cexp (2 * π * I * w)‖ := by rw [hq]; linarith
+      _ = ‖(1 : ℂ)‖ - ‖cexp (2 * π * I * w)‖ := by rw [norm_one]
+      _ ≤ ‖1 - cexp (2 * π * I * w)‖ := norm_sub_norm_le _ _
+  have hpos : 0 < 1 - Real.exp (-2 * π * Y) := by linarith
+  exact div_le_div_of_nonneg_left (by positivity) hpos hden
+
+lemma norm_pi_cot_sub_le {w : ℂ} {Y : ℝ} (hY : 0 < Y) (hw : w.im ≤ -Y) :
+    ‖π * Complex.cot (π * w) - π * I‖ ≤
+      2 * π * Real.exp (2 * π * w.im) / (1 - Real.exp (-2 * π * Y)) := by
+  have hw' : Y ≤ (-w).im := by simp; linarith
+  have := norm_pi_cot_add_le hY hw'
+  rw [show π * (-w) = -(π * w) by ring, cot_neg] at this
+  rw [show π * Complex.cot (π * w) - π * I = -(π * -Complex.cot (π * w) + π * I) by ring, norm_neg]
+  simpa using this
+
+lemma tendsto_pi_cot_add (z : ℂ) :
+    Tendsto (fun M : ℕ => π * Complex.cot (π * (z + (M : ℂ) * τ))) atTop (𝓝 (-(π * I))) := by
+  have hτ : 0 < τ.im := τ.2
+  set ρ : ℝ := Real.exp (-2 * π * τ.im) with hρ
+  have hρ0 : 0 ≤ ρ := (Real.exp_pos _).le
+  have hρ1 : ρ < 1 := by rw [hρ, Real.exp_lt_one_iff]; nlinarith [Real.pi_pos]
+  rw [tendsto_iff_norm_sub_tendsto_zero]
+  simp_rw [sub_neg_eq_add]
+  have hgeom : Tendsto (fun M : ℕ => 2 * π * Real.exp (-2 * π * z.im) / (1 - ρ) * ρ ^ M)
+      atTop (𝓝 0) := by
+    simpa using (tendsto_pow_atTop_nhds_zero_of_lt_one hρ0 hρ1).const_mul
+      (2 * π * Real.exp (-2 * π * z.im) / (1 - ρ))
+  refine squeeze_zero' (Eventually.of_forall fun M => norm_nonneg _) ?_ hgeom
+  obtain ⟨N₀, hN₀⟩ : ∃ N₀ : ℕ, -z.im / τ.im + 1 ≤ N₀ := exists_nat_ge _
+  rw [Filter.eventually_atTop]
+  refine ⟨N₀, fun M hM => ?_⟩
+  have hMN : (N₀ : ℝ) ≤ M := by exact_mod_cast hM
+  have hIm : τ.im ≤ (z + (M : ℂ) * τ).im := by
+    simp only [Complex.add_im, Complex.mul_im, Complex.natCast_re, Complex.natCast_im,
+      UpperHalfPlane.coe_im, UpperHalfPlane.coe_re, zero_mul, add_zero]
+    have h1 : -z.im / τ.im + 1 ≤ M := le_trans hN₀ hMN
+    have h2 := (div_le_iff₀ hτ).mp (by linarith : -z.im / τ.im ≤ M - 1)
+    nlinarith
+  refine (norm_pi_cot_add_le hτ hIm).trans (le_of_eq ?_)
+  have : Real.exp (-2 * π * (z + (M : ℂ) * τ).im) = Real.exp (-2 * π * z.im) * ρ ^ M := by
+    simp only [Complex.add_im, Complex.mul_im, Complex.natCast_re, Complex.natCast_im,
+      UpperHalfPlane.coe_im, UpperHalfPlane.coe_re, zero_mul, add_zero]
+    rw [hρ, ← Real.exp_nat_mul, ← Real.exp_add]; ring_nf
+  rw [this]; ring
+
+lemma tendsto_pi_cot_sub (z : ℂ) :
+    Tendsto (fun M : ℕ => π * Complex.cot (π * (z - (M : ℂ) * τ))) atTop (𝓝 (π * I)) := by
+  have h := (tendsto_pi_cot_add τ (-z)).neg
+  rw [neg_neg] at h
+  refine h.congr fun M => ?_
+  rw [show π * (-z + (M : ℂ) * τ) = -(π * (z - (M : ℂ) * τ)) by ring, cot_neg]
+  ring
+
+def NotLat (τ : ℍ) (z : ℂ) : Prop := ∀ v : Fin 2 → ℤ, z ≠ (v 0 : ℂ) * τ + v 1
+
+variable {τ}
+
+lemma NotLat.add_intCast {z : ℂ} (hz : NotLat τ z) (n : ℤ) : NotLat τ (z + n) := by
+  intro v hv
+  apply hz (v - ![0, n])
+  simp only [Pi.sub_apply, Matrix.cons_val_zero, Matrix.cons_val_one, sub_zero, Int.cast_sub]
+  linear_combination hv
+
+lemma NotLat.add_intCast_mul {z : ℂ} (hz : NotLat τ z) (n : ℤ) : NotLat τ (z + n * τ) := by
+  intro v hv
+  apply hz (v - ![n, 0])
+  simp only [Pi.sub_apply, Matrix.cons_val_zero, Matrix.cons_val_one, sub_zero, Int.cast_sub,
+    ]
+  linear_combination hv
+
+variable (τ)
+
+def ser (z : ℂ) (m : ℕ) : ℂ :=
+  π * Complex.cot (π * (z + ((m : ℂ) + 1) * τ)) + π * Complex.cot (π * (z - ((m : ℂ) + 1) * τ))
+
+def pval (z : ℂ) : ℂ := weierstrassZeta τ z - z * G2 τ - π * Complex.cot (π * z)
+
+lemma hasSum_ser {z : ℂ} (hz : NotLat τ z) : HasSum (ser τ z) (pval τ z) :=
+  EisensteinSeries.hasSum_weierstrassZeta_sub_mul_G2 τ z hz
+
+theorem weierstrassZeta_add_one {z : ℂ} (hz : NotLat τ z) :
+    weierstrassZeta τ (z + 1) = weierstrassZeta τ z + G2 τ := by
+  have h1 := hasSum_ser τ hz
+  have h2 := hasSum_ser τ (by simpa using hz.add_intCast 1)
+  have hser : ser τ (z + 1) = ser τ z := by
+    funext m
+    simp only [ser]
+    rw [show z + 1 + ((m : ℂ) + 1) * τ = (z + ((m : ℂ) + 1) * τ) + 1 by ring, cot_pi_add_one,
+      show z + 1 - ((m : ℂ) + 1) * τ = (z - ((m : ℂ) + 1) * τ) + 1 by ring, cot_pi_add_one]
+  rw [hser] at h2
+  have := h1.unique h2
+  simp only [pval, cot_pi_add_one] at this
+  linear_combination -this
+
+lemma telescope (A B : ℕ → ℂ) (M : ℕ) :
+    ∑ m ∈ Finset.range M, (A (m + 2) + B m) - ∑ m ∈ Finset.range M, (A (m + 1) + B (m + 1)) =
+      (A (M + 1) - A 1) + (B 0 - B M) := by
+  induction M with
+  | zero => simp
+  | succ M ih =>
+      rw [Finset.sum_range_succ, Finset.sum_range_succ]
+      linear_combination ih
+
+theorem weierstrassZeta_add_tau {z : ℂ} (hz : NotLat τ z) :
+    weierstrassZeta τ (z + τ) = weierstrassZeta τ z + ((τ : ℂ) * G2 τ - 2 * π * I) := by
+  set A : ℕ → ℂ := fun k => π * Complex.cot (π * (z + (k : ℂ) * τ)) with hA
+  set B : ℕ → ℂ := fun k => π * Complex.cot (π * (z - (k : ℂ) * τ)) with hB
+  have h1 := hasSum_ser τ hz
+  have h2 := hasSum_ser τ (by simpa using hz.add_intCast_mul 1)
+  have hser1 : ser τ z = fun m => A (m + 1) + B (m + 1) := by
+    funext m; simp only [ser, hA, hB]; push_cast; ring_nf
+  have hser2 : ser τ (z + τ) = fun m => A (m + 2) + B m := by
+    funext m; simp only [ser, hA, hB]; push_cast; ring_nf
+  rw [hser1] at h1
+  rw [hser2] at h2
+  have t1 := h1.tendsto_sum_nat
+  have t2 := h2.tendsto_sum_nat
+  have t3 : Tendsto (fun M : ℕ => (A (M + 1) - A 1) + (B 0 - B M)) atTop
+      (𝓝 ((-(π * I) - A 1) + (B 0 - π * I))) := by
+    have tA : Tendsto (fun M : ℕ => A (M + 1)) atTop (𝓝 (-(π * I))) := by
+      have := (tendsto_pi_cot_add τ z).comp (tendsto_add_atTop_nat 1)
+      refine this.congr fun M => ?_
+      simp [hA, Function.comp]
+    have tB : Tendsto (fun M : ℕ => B M) atTop (𝓝 (π * I)) := tendsto_pi_cot_sub τ z
+    exact (tA.sub_const _).add (tB.const_sub _)
+  have t4 : Tendsto (fun M : ℕ => ∑ m ∈ Finset.range M, (A (m + 2) + B m) -
+      ∑ m ∈ Finset.range M, (A (m + 1) + B (m + 1))) atTop
+      (𝓝 (pval τ (z + τ) - pval τ z)) := t2.sub t1
+  have heq := tendsto_nhds_unique (t4.congr (telescope A B)) t3
+  have hA1 : A 1 = π * Complex.cot (π * (z + τ)) := by simp [hA]
+  have hB0 : B 0 = π * Complex.cot (π * z) := by simp [hB]
+  simp only [pval, hA1, hB0] at heq
+  linear_combination heq
+
+end WZB
+
+end
+
+theorem solution (τ : UpperHalfPlane) :
+    (∀ z : ℂ, (∀ v : Fin 2 → ℤ, z ≠ (v 0 : ℂ) * τ + v 1) →
+        EisensteinSeries.weierstrassZeta τ (z + 1) =
+          EisensteinSeries.weierstrassZeta τ z + EisensteinSeries.G2 τ) ∧
+    (∀ z : ℂ, (∀ v : Fin 2 → ℤ, z ≠ (v 0 : ℂ) * τ + v 1) →
+        EisensteinSeries.weierstrassZeta τ (z + τ) =
+          EisensteinSeries.weierstrassZeta τ z +
+            ((τ : ℂ) * EisensteinSeries.G2 τ - 2 * π * Complex.I)) ∧
+    (∀ (γ : SL(2, ℤ)) (z : ℂ),
+        EisensteinSeries.weierstrassZeta (γ • τ) (z / UpperHalfPlane.denom γ τ) =
+          UpperHalfPlane.denom γ τ * EisensteinSeries.weierstrassZeta τ z) :=
+  ⟨fun _ hz => WZB.weierstrassZeta_add_one τ hz, fun _ hz => WZB.weierstrassZeta_add_tau τ hz,
+    fun γ z => WZB.weierstrassZeta_smul τ γ z⟩
+
+end S_EisensteinSeries_weierstrassZeta_add_one_and_add_tau_and_smul
+end P2MW
+export P2MW.S_EisensteinSeries_weierstrassZeta_add_one_and_add_tau_and_smul (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Real MatrixGroups
+theorem EisensteinSeries.weierstrassZeta_add_one_and_add_tau_and_smul (τ : UpperHalfPlane) :
+    (∀ z : ℂ, (∀ v : Fin 2 → ℤ, z ≠ (v 0 : ℂ) * τ + v 1) →
+        EisensteinSeries.weierstrassZeta τ (z + 1) =
+          EisensteinSeries.weierstrassZeta τ z + EisensteinSeries.G2 τ) ∧
+    (∀ z : ℂ, (∀ v : Fin 2 → ℤ, z ≠ (v 0 : ℂ) * τ + v 1) →
+        EisensteinSeries.weierstrassZeta τ (z + τ) =
+          EisensteinSeries.weierstrassZeta τ z +
+            ((τ : ℂ) * EisensteinSeries.G2 τ - 2 * π * Complex.I)) ∧
+    (∀ (γ : SL(2, ℤ)) (z : ℂ),
+        EisensteinSeries.weierstrassZeta (γ • τ) (z / UpperHalfPlane.denom γ τ) =
+          UpperHalfPlane.denom γ τ * EisensteinSeries.weierstrassZeta τ z) :=
+  solution τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinWeightOne_e1Chi3IsModular.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinWeightOne_e1Chi3IsModular.lean
new file mode 100644
index 0000000000..a7fae75cb3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_EisensteinWeightOne_e1Chi3IsModular.lean
@@ -0,0 +1,3712 @@
+/-
+Based on Prove2Me node EisensteinWeightOne.e1Chi3IsModular
+(b77f5563-c246-5dea-ac05-9934aeb4fd42) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 05ae20e1-f8e9-58f0-8f6e-80658e2f6e5f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_EisensteinChiNegThree
+
+import Mathlib.Algebra.Ring.IsFormallyReal
+import Mathlib.Analysis.Complex.LocallyUniformLimit
+import Mathlib.Analysis.PSeries
+import Mathlib.Data.Int.Star
+import Mathlib.FieldTheory.Finite.Basic
+import Mathlib.GroupTheory.Schreier
+import Mathlib.LinearAlgebra.Matrix.FixedDetMatrices
+import Mathlib.NumberTheory.ArithmeticFunction.Defs
+import Mathlib.NumberTheory.ModularForms.JacobiTheta.TwoVariable
+import Mathlib.RingTheory.Int.Basic
+import Mathlib.Tactic.NormNum.Prime
+import Mathlib.Topology.Separation.CompletelyRegular
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Modularity of the weight-one Eisenstein series E₁(1,χ₋₃)
+
+Theorem statement: `EisensteinWeightOne.e1Chi3IsModular` (`b77f5563-c246-5dea-ac05-9934aeb4fd42`),
+by Claude, 2026-09-05.
+
+Proof: submission `05ae20e1-f8e9-58f0-8f6e-80658e2f6e5f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+The assertion is the proposition
+[`EisensteinWeightOne.E1Chi3IsModular`](def/ModularForm_EisensteinChiNegThree.html#L21), which
+states that there exists a modular form $f$ of weight $1$ for the congruence subgroup $\Gamma_1(3)$
+such that for every point $z$ of the upper half-plane,
+$$f(z) = \sum_{n=0}^{\infty} a_n\, e^{2\pi i n z},$$
+the sum being the unconditional (`tsum`) sum over $n : \mathbb{N}$ of the complex numbers obtained
+by casting the coefficients $a_n$ of the formal power series `e1Chi3` $\in \mathbb{Z}[\![q]\!]$ into
+$\mathbb{C}$. The coefficients of `e1Chi3` are given explicitly: $a_0 = 1$ and $a_n =
+6\,\cdot$`sigmaChi`$(n)$ for $n \neq 0$, where `sigmaChi` is the integer-valued arithmetic function
+appearing in that definition (the twisted divisor sum attached to the quadratic character of
+conductor $3$). Thus the theorem asserts that this formal $q$-series is the $q$-expansion of an
+actual weight-one modular form on $\Gamma_1(3)$, holomorphic on the upper half-plane and satisfying
+the growth condition built into Mathlib's `ModularForm`. There are no free variables or hypotheses.
+
+Classically this is the statement that the weight-one Eisenstein series $E_1(1,\chi_{-3}) = 1 +
+6\sum_{n\ge 1}\sigma_{\chi_{-3}}(n)q^n$ of nebentypus the quadratic character of conductor $3$ is a
+modular form on $\Gamma_1(3)$. It provides the analytic input for the weight-one to weight-two
+congruence step in the Langlands–Tunnell part of the argument, and is used by the constructions of
+integral $q$-expansions on modular curves and by the passage from a realized weight-one object of
+nebentypus $\chi_{-3}$ to a cusp form.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_EisensteinWeightOne_e1Chi3IsModular.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_EisensteinWeightOne_e1Chi3IsModular
+
+namespace S17E1
+section File_FLT_Modularity_EisensteinWeightOne
+
+namespace FLT
+namespace EisensteinWeightOne
+
+p2m_open "Finset Nat Finset.Nat ArithmeticFunction CongruenceSubgroup"
+
+def chiNegThree (n : ℕ) : ℤ :=
+  if n % 3 = 1 then 1 else if n % 3 = 2 then -1 else 0
+
+@[scoped simp] theorem chiNegThree_zero : chiNegThree 0 = 0 := rfl
+
+@[scoped simp] theorem chiNegThree_one : chiNegThree 1 = 1 := rfl
+
+@[scoped simp] theorem chiNegThree_two : chiNegThree 2 = -1 := rfl
+
+@[scoped simp] theorem chiNegThree_three : chiNegThree 3 = 0 := rfl
+
+theorem chiNegThree_mod (n : ℕ) : chiNegThree (n % 3) = chiNegThree n := by
+  simp only [chiNegThree, Nat.mod_mod_of_dvd n (dvd_refl 3)]
+
+theorem chiNegThree_eq_zero_iff {n : ℕ} : chiNegThree n = 0 ↔ 3 ∣ n := by
+  simp only [chiNegThree]
+  have h3 : n % 3 = 0 ∨ n % 3 = 1 ∨ n % 3 = 2 := by omega
+  rcases h3 with h | h | h <;> simp [h] <;> omega
+
+theorem chiNegThree_mul (m n : ℕ) : chiNegThree (m * n) = chiNegThree m * chiNegThree n := by
+  simp only [chiNegThree]
+  rw [Nat.mul_mod]
+  have hm : m % 3 = 0 ∨ m % 3 = 1 ∨ m % 3 = 2 := by omega
+  have hn : n % 3 = 0 ∨ n % 3 = 1 ∨ n % 3 = 2 := by omega
+  rcases hm with h | h | h <;> rcases hn with h' | h' | h' <;> rw [h, h'] <;> decide
+
+theorem chiNegThree_pow (p j : ℕ) : chiNegThree (p ^ j) = chiNegThree p ^ j := by
+  induction j with
+  | zero => simp
+  | succ j ih => rw [pow_succ, chiNegThree_mul, ih, pow_succ]
+
+def sigmaChi (n : ℕ) : ℤ :=
+  ∑ d ∈ n.divisors, chiNegThree d
+
+@[scoped simp] theorem sigmaChi_zero : sigmaChi 0 = 0 := by simp [sigmaChi]
+
+def chiNegThreeArith : ArithmeticFunction ℤ :=
+  ⟨chiNegThree, chiNegThree_zero⟩
+
+@[scoped simp] theorem chiNegThreeArith_apply {n : ℕ} : chiNegThreeArith n = chiNegThree n := rfl
+
+def zetaInt : ArithmeticFunction ℤ :=
+  ⟨fun n => if n = 0 then 0 else 1, rfl⟩
+
+@[scoped simp] theorem zetaInt_apply {n : ℕ} : zetaInt n = if n = 0 then 0 else 1 := rfl
+
+theorem isMultiplicative_chiNegThreeArith : chiNegThreeArith.IsMultiplicative :=
+  ⟨chiNegThree_one, fun {m n} _ => chiNegThree_mul m n⟩
+
+theorem isMultiplicative_zetaInt : zetaInt.IsMultiplicative := by
+  refine ⟨by simp, fun {m n} _ => ?_⟩
+  rcases eq_or_ne m 0 with rfl | hm
+  · simp
+  rcases eq_or_ne n 0 with rfl | hn
+  · simp
+  simp [hm, hn, Nat.mul_ne_zero hm hn]
+
+theorem sigmaChi_eq_mul_apply (n : ℕ) : sigmaChi n = (zetaInt * chiNegThreeArith) n := by
+  rcases eq_or_ne n 0 with rfl | hn
+  · simp
+  unfold sigmaChi
+  calc ∑ d ∈ n.divisors, chiNegThree d
+      = ∑ d ∈ n.divisors, chiNegThree (n / d) := (Nat.sum_div_divisors n chiNegThree).symm
+    _ = ∑ d ∈ n.divisors, zetaInt d * chiNegThreeArith (n / d) :=
+        Finset.sum_congr rfl fun d hd => by
+          have hd0 : d ≠ 0 := (Nat.pos_of_mem_divisors hd).ne'
+          simp [hd0]
+    _ = ∑ x ∈ n.divisorsAntidiagonal, zetaInt x.1 * chiNegThreeArith x.2 :=
+        (Nat.sum_divisorsAntidiagonal fun d e => zetaInt d * chiNegThreeArith e).symm
+    _ = (zetaInt * chiNegThreeArith) n := ArithmeticFunction.mul_apply.symm
+
+theorem isMultiplicative_zetaInt_mul_chi :
+    (zetaInt * chiNegThreeArith).IsMultiplicative :=
+  isMultiplicative_zetaInt.mul isMultiplicative_chiNegThreeArith
+
+theorem sigmaChi_mul_of_coprime (m n : ℕ) (h : Nat.Coprime m n) :
+    sigmaChi (m * n) = sigmaChi m * sigmaChi n := by
+  simp only [sigmaChi_eq_mul_apply]
+  exact isMultiplicative_zetaInt_mul_chi.map_mul_of_coprime h
+
+theorem sigmaChi_prime {p : ℕ} (hp : p.Prime) : sigmaChi p = 1 + chiNegThree p := by
+  rw [sigmaChi, Nat.Prime.divisors hp, Finset.sum_pair hp.one_lt.ne, chiNegThree_one]
+
+theorem sigmaChi_one : sigmaChi 1 = 1 := by decide
+
+theorem sigmaChi_two : sigmaChi 2 = 0 := by decide
+
+theorem sigmaChi_three : sigmaChi 3 = 1 := by decide
+
+theorem sigmaChi_four : sigmaChi 4 = 1 := by decide
+
+theorem sigmaChi_five : sigmaChi 5 = 0 := by decide
+
+theorem sigmaChi_six : sigmaChi 6 = 0 := by decide
+
+theorem sigmaChi_seven : sigmaChi 7 = 2 := by decide
+
+def e1Chi3 : PowerSeries ℤ :=
+  PowerSeries.mk fun n => if n = 0 then 1 else 6 * sigmaChi n
+
+theorem coeff_e1Chi3 (n : ℕ) :
+    PowerSeries.coeff n e1Chi3 = if n = 0 then 1 else 6 * sigmaChi n := by
+  rw [e1Chi3, PowerSeries.coeff_mk]
+
+@[scoped simp] theorem constantCoeff_e1Chi3 : PowerSeries.constantCoeff e1Chi3 = 1 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff, coeff_e1Chi3]
+  simp
+
+theorem coeff_e1Chi3_of_ne_zero {n : ℕ} (hn : n ≠ 0) :
+    PowerSeries.coeff n e1Chi3 = 6 * sigmaChi n := by
+  rw [coeff_e1Chi3, ite_eq_right hn]
+
+theorem coeff_one_e1Chi3 : PowerSeries.coeff 1 e1Chi3 = 6 := by
+  rw [coeff_e1Chi3]
+  norm_num [sigmaChi_one]
+
+theorem coeff_two_e1Chi3 : PowerSeries.coeff 2 e1Chi3 = 0 := by
+  rw [coeff_e1Chi3]
+  norm_num [sigmaChi_two]
+
+theorem coeff_three_e1Chi3 : PowerSeries.coeff 3 e1Chi3 = 6 := by
+  rw [coeff_e1Chi3]
+  norm_num [sigmaChi_three]
+
+theorem coeff_four_e1Chi3 : PowerSeries.coeff 4 e1Chi3 = 6 := by
+  rw [coeff_e1Chi3]
+  norm_num [sigmaChi_four]
+
+theorem coeff_seven_e1Chi3 : PowerSeries.coeff 7 e1Chi3 = 12 := by
+  rw [coeff_e1Chi3]
+  norm_num [sigmaChi_seven]
+
+theorem six_dvd_coeff_e1Chi3_of_ne_zero {n : ℕ} (hn : n ≠ 0) :
+    (6 : ℤ) ∣ PowerSeries.coeff n e1Chi3 :=
+  ⟨sigmaChi n, coeff_e1Chi3_of_ne_zero hn⟩
+
+theorem three_dvd_coeff_e1Chi3_of_ne_zero {n : ℕ} (hn : n ≠ 0) :
+    (3 : ℤ) ∣ PowerSeries.coeff n e1Chi3 :=
+  dvd_trans (by norm_num) (six_dvd_coeff_e1Chi3_of_ne_zero hn)
+
+theorem three_dvd_coeff_e1Chi3_sub_one (n : ℕ) :
+    (3 : ℤ) ∣ PowerSeries.coeff n (e1Chi3 - 1) := by
+  rw [map_sub, PowerSeries.coeff_one]
+  rcases eq_or_ne n 0 with rfl | hn
+  · simp [coeff_e1Chi3]
+  · rw [ite_eq_right hn, sub_zero]
+    exact three_dvd_coeff_e1Chi3_of_ne_zero hn
+
+def E1Chi3IsModular : Prop :=
+  ∃ f : ModularForm (Gamma1 3) 1, ∀ z : UpperHalfPlane,
+    f z = ∑' n : ℕ,
+      ((PowerSeries.coeff n e1Chi3 : ℤ) : ℂ) *
+        Complex.exp (2 * (Real.pi : ℂ) * Complex.I * (n : ℂ) * (z : ℂ))
+
+end FLT.EisensteinWeightOne
+end File_FLT_Modularity_EisensteinWeightOne
+
+section File_FLT_AnalyticCore_LatticeSumPlumbing
+
+open Complex Real Set
+
+namespace FLT
+namespace AnalyticCore
+namespace LatticeSum
+
+def hexForm (v : ℤ × ℤ) : ℤ :=
+  v.1 ^ 2 + v.1 * v.2 + v.2 ^ 2
+
+@[scoped simp] lemma hexForm_mk (m n : ℤ) : hexForm (m, n) = m ^ 2 + m * n + n ^ 2 := rfl
+
+lemma two_mul_hexForm (v : ℤ × ℤ) :
+    2 * hexForm v = (v.1 + v.2) ^ 2 + v.1 ^ 2 + v.2 ^ 2 := by
+  simp only [hexForm]; ring
+
+lemma hexForm_nonneg (v : ℤ × ℤ) : 0 ≤ hexForm v := by
+  obtain ⟨a, b⟩ := v
+  simp only [hexForm_mk]
+  nlinarith [sq_nonneg (a + b), sq_nonneg a, sq_nonneg b]
+
+lemma hexForm_eq_zero_iff (v : ℤ × ℤ) : hexForm v = 0 ↔ v = (0, 0) := by
+  obtain ⟨a, b⟩ := v
+  simp only [hexForm_mk, Prod.mk.injEq]
+  constructor
+  · intro h
+    constructor <;> nlinarith [sq_nonneg (a + b), sq_nonneg a, sq_nonneg b, sq_nonneg (a - b)]
+  · rintro ⟨rfl, rfl⟩; ring
+
+lemma sq_add_sq_le_two_mul_hexForm (v : ℤ × ℤ) :
+    v.1 ^ 2 + v.2 ^ 2 ≤ 2 * hexForm v := by
+  obtain ⟨a, b⟩ := v
+  simp only [hexForm_mk]
+  nlinarith [sq_nonneg (a + b)]
+
+def hexFormNat (v : ℤ × ℤ) : ℕ :=
+  (hexForm v).toNat
+
+@[scoped simp] lemma coe_hexFormNat (v : ℤ × ℤ) : (hexFormNat v : ℤ) = hexForm v :=
+  Int.toNat_of_nonneg (hexForm_nonneg v)
+
+lemma hexFormNat_eq_iff (v : ℤ × ℤ) (n : ℕ) : hexFormNat v = n ↔ hexForm v = (n : ℤ) := by
+  rw [← coe_hexFormNat, Int.natCast_inj]
+
+@[scoped simp] lemma hexFormNat_zero : hexFormNat (0, 0) = 0 := by
+  rw [hexFormNat_eq_iff]; rfl
+
+noncomputable def latticeTerm (τ : ℂ) (v : ℤ × ℤ) : ℂ :=
+  Complex.exp (2 * (π : ℂ) * Complex.I * (hexFormNat v : ℂ) * τ)
+
+lemma norm_latticeTerm (τ : ℂ) (v : ℤ × ℤ) :
+    ‖latticeTerm τ v‖ = Real.exp (-(2 * π * (hexFormNat v : ℝ) * τ.im)) := by
+  rw [latticeTerm, show (2 * (π : ℂ) * Complex.I * (hexFormNat v : ℂ) * τ)
+      = ((2 * π * (hexFormNat v : ℝ) : ℝ) : ℂ) * τ * Complex.I by push_cast; ring]
+  rw [Complex.norm_exp, mul_I_re, im_ofReal_mul]
+
+lemma norm_latticeTerm_le_of_le_im {T : ℝ} (hT : 0 < T) {τ : ℂ} (hτ : T ≤ τ.im) (v : ℤ × ℤ) :
+    ‖latticeTerm τ v‖ ≤
+      Real.exp (-(π * T * (v.1 : ℝ) ^ 2)) * Real.exp (-(π * T * (v.2 : ℝ) ^ 2)) := by
+  rw [norm_latticeTerm, ← Real.exp_add, Real.exp_le_exp]
+  have hQ : (v.1 : ℝ) ^ 2 + (v.2 : ℝ) ^ 2 ≤ 2 * (hexFormNat v : ℝ) := by
+    have := sq_add_sq_le_two_mul_hexForm v
+    have h2 : ((2 * hexForm v : ℤ) : ℝ) = 2 * (hexFormNat v : ℝ) := by
+      push_cast [coe_hexFormNat]; ring_nf
+      norm_cast
+      simp [coe_hexFormNat]
+    calc (v.1 : ℝ) ^ 2 + (v.2 : ℝ) ^ 2 = ((v.1 ^ 2 + v.2 ^ 2 : ℤ) : ℝ) := by push_cast; ring
+      _ ≤ ((2 * hexForm v : ℤ) : ℝ) := by exact_mod_cast this
+      _ = 2 * (hexFormNat v : ℝ) := h2
+  have hQ0 : (0 : ℝ) ≤ (hexFormNat v : ℝ) := Nat.cast_nonneg _
+  nlinarith [mul_le_mul_of_nonneg_left hQ (by positivity : (0 : ℝ) ≤ π * T),
+    mul_le_mul_of_nonneg_left hτ (by positivity : (0 : ℝ) ≤ 2 * π * (hexFormNat v : ℝ))]
+
+lemma summable_gaussian_int {t : ℝ} (ht : 0 < t) :
+    Summable fun m : ℤ ↦ Real.exp (-(π * t * (m : ℝ) ^ 2)) := by
+  have h := summable_pow_mul_jacobiTheta₂_term_bound 0 ht 0
+  simpa only [pow_zero, one_mul, mul_zero, zero_mul, sub_zero, neg_mul, mul_assoc] using h
+
+lemma summable_gaussian_prod {t : ℝ} (ht : 0 < t) :
+    Summable fun v : ℤ × ℤ ↦
+      Real.exp (-(π * t * (v.1 : ℝ) ^ 2)) * Real.exp (-(π * t * (v.2 : ℝ) ^ 2)) :=
+  (summable_gaussian_int ht).mul_of_nonneg (summable_gaussian_int ht)
+    (fun _ ↦ (Real.exp_pos _).le) (fun _ ↦ (Real.exp_pos _).le)
+
+theorem summable_latticeTerm {τ : ℂ} (hτ : 0 < τ.im) : Summable (latticeTerm τ) :=
+  (summable_gaussian_prod hτ).of_norm_bounded (norm_latticeTerm_le_of_le_im hτ le_rfl)
+
+theorem not_summable_latticeTerm_zero : ¬ Summable (latticeTerm 0) := by
+  have h : latticeTerm 0 = fun _ ↦ (1 : ℂ) := by
+    funext v; simp [latticeTerm]
+  rw [h, summable_const_iff]
+  exact one_ne_zero
+
+noncomputable def latticeSum (τ : ℂ) : ℂ :=
+  ∑' v : ℤ × ℤ, latticeTerm τ v
+
+lemma finite_fiber_hexFormNat (n : ℕ) : (hexFormNat ⁻¹' {n}).Finite := by
+  apply Set.Finite.subset
+    ((Finset.Icc (-(2 * n : ℤ)) (2 * n) ×ˢ Finset.Icc (-(2 * n : ℤ)) (2 * n)).finite_toSet)
+  rintro ⟨a, b⟩ hv
+  simp only [Set.mem_preimage, Set.mem_singleton_iff, hexFormNat_eq_iff] at hv
+  have hbox : a ^ 2 + b ^ 2 ≤ 2 * (n : ℤ) := by
+    have := sq_add_sq_le_two_mul_hexForm (a, b)
+    simp only [hexForm_mk] at this hv
+    omega
+  have ha2 : a ^ 2 ≤ 2 * (n : ℤ) := by nlinarith [sq_nonneg b]
+  have hb2 : b ^ 2 ≤ 2 * (n : ℤ) := by nlinarith [sq_nonneg a]
+  simp only [Finset.coe_product, Set.mem_prod, Finset.mem_coe, Finset.mem_Icc]
+  refine ⟨⟨?_, ?_⟩, ?_, ?_⟩
+  · nlinarith [Int.le_self_sq (-a)]
+  · nlinarith [Int.le_self_sq a]
+  · nlinarith [Int.le_self_sq (-b)]
+  · nlinarith [Int.le_self_sq b]
+
+noncomputable def repCount (n : ℕ) : ℕ :=
+  (hexFormNat ⁻¹' {n}).ncard
+
+@[scoped simp] theorem repCount_zero : repCount 0 = 1 := by
+  have h : hexFormNat ⁻¹' {0} = {((0 : ℤ), (0 : ℤ))} := by
+    ext v
+    simp only [Set.mem_preimage, Set.mem_singleton_iff, hexFormNat_eq_iff, Int.natCast_zero,
+      hexForm_eq_zero_iff]
+  rw [repCount, h, Set.ncard_singleton]
+
+theorem repCount_one : repCount 1 = 6 := by
+  have h : hexFormNat ⁻¹' {1} =
+      (↑({((1 : ℤ), (0 : ℤ)), (-1, 0), (0, 1), (0, -1), (1, -1), (-1, 1)} :
+        Finset (ℤ × ℤ)) : Set (ℤ × ℤ)) := by
+    ext ⟨a, b⟩
+    simp only [Set.mem_preimage, Set.mem_singleton_iff, hexFormNat_eq_iff, Int.natCast_one,
+      hexForm_mk, Finset.coe_insert, Set.mem_insert_iff, Finset.coe_singleton,
+      Set.mem_singleton_iff, Prod.mk.injEq]
+    constructor
+    · intro hab
+      have hbox : a ^ 2 + b ^ 2 ≤ 2 := by nlinarith [sq_nonneg (a + b)]
+      obtain ⟨ha1, ha2⟩ : -1 ≤ a ∧ a ≤ 1 := by
+        constructor <;> nlinarith [Int.le_self_sq (-a), Int.le_self_sq a, sq_nonneg b]
+      obtain ⟨hb1, hb2⟩ : -1 ≤ b ∧ b ≤ 1 := by
+        constructor <;> nlinarith [Int.le_self_sq (-b), Int.le_self_sq b, sq_nonneg a]
+      interval_cases a <;> interval_cases b <;> omega
+    · rintro (⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩) <;>
+        decide
+  rw [repCount, h, Set.ncard_coe_finset]
+  decide
+
+lemma tsum_fiber_eq (τ : ℂ) (n : ℕ) :
+    ∑' v : (hexFormNat ⁻¹' {n}), latticeTerm τ v
+      = (repCount n : ℂ) * Complex.exp (2 * (π : ℂ) * Complex.I * (n : ℂ) * τ) := by
+  have hconst : ∀ v : (hexFormNat ⁻¹' {n}),
+      latticeTerm τ v = Complex.exp (2 * (π : ℂ) * Complex.I * (n : ℂ) * τ) := by
+    rintro ⟨v, hv⟩
+    simp only [Set.mem_preimage, Set.mem_singleton_iff] at hv
+    simp [latticeTerm, hv]
+  rw [tsum_congr hconst, tsum_const, Nat.card_coe_set_eq, nsmul_eq_mul, repCount]
+
+theorem hasSum_repCount_qpow {τ : ℂ} (hτ : 0 < τ.im) :
+    HasSum (fun n : ℕ ↦ (repCount n : ℂ) * Complex.exp (2 * (π : ℂ) * Complex.I * (n : ℂ) * τ))
+      (latticeSum τ) := by
+  have h := ((summable_latticeTerm hτ).hasSum).tsum_fiberwise hexFormNat
+  simp only [tsum_fiber_eq τ] at h
+  exact h
+
+theorem latticeSum_eq_tsum_repCount {τ : ℂ} (hτ : 0 < τ.im) :
+    latticeSum τ
+      = ∑' n : ℕ, (repCount n : ℂ) * Complex.exp (2 * (π : ℂ) * Complex.I * (n : ℂ) * τ) :=
+  (hasSum_repCount_qpow hτ).tsum_eq.symm
+
+open FLT.EisensteinWeightOne in
+def RepresentationCountAgrees : Prop :=
+  ∀ n : ℕ, (repCount n : ℤ) = PowerSeries.coeff n e1Chi3
+
+open FLT.EisensteinWeightOne in
+theorem representationCountAgrees_zero : (repCount 0 : ℤ) = PowerSeries.coeff 0 e1Chi3 := by
+  simp [repCount_zero, coeff_e1Chi3]
+
+open FLT.EisensteinWeightOne in
+theorem representationCountAgrees_one : (repCount 1 : ℤ) = PowerSeries.coeff 1 e1Chi3 := by
+  rw [repCount_one, coeff_one_e1Chi3]; rfl
+
+open FLT.EisensteinWeightOne in
+theorem latticeSum_eq_e1Chi3_qSeries (hW1 : RepresentationCountAgrees) (z : UpperHalfPlane) :
+    latticeSum z
+      = ∑' n : ℕ, ((PowerSeries.coeff n e1Chi3 : ℤ) : ℂ) *
+          Complex.exp (2 * (π : ℂ) * Complex.I * (n : ℂ) * (z : ℂ)) := by
+  rw [latticeSum_eq_tsum_repCount (UpperHalfPlane.coe_im z ▸ z.2)]
+  refine tsum_congr fun n ↦ ?_
+  congr 1
+  rw [← hW1 n]
+  push_cast
+  rfl
+
+theorem repCount_zero_summand (τ : ℂ) :
+    (repCount 0 : ℂ) * Complex.exp (2 * (π : ℂ) * Complex.I * (0 : ℂ) * τ) = 1 := by
+  simp [repCount_zero]
+
+theorem repCount_one_summand (τ : ℂ) :
+    (repCount 1 : ℂ) * Complex.exp (2 * (π : ℂ) * Complex.I * (1 : ℂ) * τ)
+      = 6 * Complex.exp (2 * (π : ℂ) * Complex.I * τ) := by
+  rw [repCount_one]
+  norm_num
+
+end FLT.AnalyticCore.LatticeSum
+end File_FLT_AnalyticCore_LatticeSumPlumbing
+
+section File_FLT_AnalyticCore_RankTwoPoissonSummation
+
+open Complex Real
+
+open scoped Topology
+
+namespace FLT
+namespace AnalyticCore
+
+noncomputable section
+
+def hexThetaTerm (σ : ℂ) (p : ℤ × ℤ) : ℂ :=
+  cexp (2 * π * I * σ * ((p.1 : ℂ) ^ 2 + (p.1 : ℂ) * (p.2 : ℂ) + (p.2 : ℂ) ^ 2))
+
+def hexTheta (σ : ℂ) : ℂ :=
+  ∑' p : ℤ × ℤ, hexThetaTerm σ p
+
+lemma hexThetaTerm_swap (σ : ℂ) (x y : ℤ) :
+    hexThetaTerm σ (x, y) = hexThetaTerm σ (y, x) := by
+  unfold hexThetaTerm
+  congr 1
+  push_cast
+  ring
+
+lemma hexThetaTerm_zero_zero (σ : ℂ) : hexThetaTerm σ (0, 0) = 1 := by
+  simp [hexThetaTerm]
+
+lemma norm_hexThetaTerm (σ : ℂ) (p : ℤ × ℤ) :
+    ‖hexThetaTerm σ p‖ =
+      rexp (-(2 * π * σ.im) * ((p.1 : ℝ) ^ 2 + (p.1 : ℝ) * (p.2 : ℝ) + (p.2 : ℝ) ^ 2)) := by
+  rw [hexThetaTerm, Complex.norm_exp]
+  congr 1
+  rw [show (2 * (π : ℂ) * I * σ * ((p.1 : ℂ) ^ 2 + (p.1 : ℂ) * (p.2 : ℂ) + (p.2 : ℂ) ^ 2)) =
+      (((2 * π * ((p.1 : ℝ) ^ 2 + (p.1 : ℝ) * (p.2 : ℝ) + (p.2 : ℝ) ^ 2) : ℝ)) : ℂ) * (σ * I) by
+    push_cast; ring]
+  rw [Complex.re_ofReal_mul, Complex.mul_I_re]
+  ring
+
+lemma sq_add_sq_le_two_mul_form (x y : ℝ) :
+    x ^ 2 + y ^ 2 ≤ 2 * (x ^ 2 + x * y + y ^ 2) := by
+  nlinarith [sq_nonneg (x + y)]
+
+lemma summable_norm_cexp_neg_quadratic {a : ℂ} (ha : 0 < a.re) (b : ℂ) :
+    Summable fun n : ℤ => ‖cexp (-π * a * (n : ℂ) ^ 2 + 2 * π * b * (n : ℂ))‖ := by
+  rw [summable_norm_iff]
+  have hre : (-(π : ℂ) * a).re < 0 := by
+    rw [neg_mul, neg_re, Complex.re_ofReal_mul, neg_lt_zero]
+    exact mul_pos pi_pos ha
+  have hO : (fun x : ℝ => cexp (-(π : ℂ) * a * (x : ℂ) ^ 2 + 2 * π * b * (x : ℂ)))
+      =O[Filter.cocompact ℝ] fun x : ℝ => |x| ^ (-2 : ℝ) :=
+    (cexp_neg_quadratic_isLittleO_abs_rpow_cocompact hre (2 * π * b) (-2)).isBigO
+  have hZ := hO.comp_tendsto Int.tendsto_coe_cofinite
+  simp only [Function.comp_def, Complex.ofReal_intCast] at hZ
+  exact summable_of_isBigO (Real.summable_abs_int_rpow one_lt_two) hZ
+
+lemma summable_cexp_neg_quadratic {a : ℂ} (ha : 0 < a.re) (b : ℂ) :
+    Summable fun n : ℤ => cexp (-π * a * (n : ℂ) ^ 2 + 2 * π * b * (n : ℂ)) :=
+  (summable_norm_cexp_neg_quadratic ha b).of_norm
+
+lemma summable_rexp_neg_mul_int_sq {c : ℝ} (hc : 0 < c) :
+    Summable fun n : ℤ => rexp (-(c * (n : ℝ) ^ 2)) := by
+  have h0 : (0 : ℝ) < ((c / π : ℝ) : ℂ).re := by
+    rw [Complex.ofReal_re]
+    exact div_pos hc pi_pos
+  refine (summable_norm_cexp_neg_quadratic h0 0).congr fun n => ?_
+  rw [mul_zero, zero_mul, add_zero, Complex.norm_exp]
+  congr 1
+  rw [show (-(π : ℂ) * ((c / π : ℝ) : ℂ) * (n : ℂ) ^ 2) = ((-(c * (n : ℝ) ^ 2) : ℝ) : ℂ) by
+    push_cast
+    field_simp]
+  exact Complex.ofReal_re _
+
+lemma summable_hexThetaTerm {σ : ℂ} (hσ : 0 < σ.im) : Summable (hexThetaTerm σ) := by
+  apply Summable.of_norm
+  have hbound : ∀ p : ℤ × ℤ, ‖hexThetaTerm σ p‖ ≤
+      rexp (-(π * σ.im * (p.1 : ℝ) ^ 2)) * rexp (-(π * σ.im * (p.2 : ℝ) ^ 2)) := by
+    intro p
+    rw [norm_hexThetaTerm, ← Real.exp_add, Real.exp_le_exp]
+    nlinarith [sq_add_sq_le_two_mul_form (p.1 : ℝ) (p.2 : ℝ), mul_pos pi_pos hσ]
+  exact Summable.of_nonneg_of_le (fun p => norm_nonneg _) hbound
+    (Summable.mul_of_nonneg
+      (summable_rexp_neg_mul_int_sq (mul_pos pi_pos hσ))
+      (summable_rexp_neg_mul_int_sq (mul_pos pi_pos hσ))
+      (fun n => (Real.exp_pos _).le) (fun n => (Real.exp_pos _).le))
+
+lemma ne_zero_of_im_pos {σ : ℂ} (hσ : 0 < σ.im) : σ ≠ 0 := by
+  rintro rfl
+  simp at hσ
+
+lemma re_neg_two_I_mul {σ : ℂ} (hσ : 0 < σ.im) : 0 < (-2 * I * σ).re := by
+  rw [show (-2 * I * σ : ℂ) = ((-2 : ℝ) : ℂ) * (σ * I) by push_cast; ring,
+    Complex.re_ofReal_mul, Complex.mul_I_re]
+  linarith
+
+lemma re_neg_three_I_mul_div_two {σ : ℂ} (hσ : 0 < σ.im) : 0 < (-3 * I * σ / 2).re := by
+  rw [show (-3 * I * σ / 2 : ℂ) = ((-3 / 2 : ℝ) : ℂ) * (σ * I) by push_cast; ring,
+    Complex.re_ofReal_mul, Complex.mul_I_re]
+  linarith
+
+lemma im_neg_one_div_three_mul_pos {σ : ℂ} (hσ : 0 < σ.im) : 0 < (-1 / (3 * σ)).im := by
+  have h3σ : (3 : ℂ) * σ ≠ 0 := mul_ne_zero (by norm_num) (ne_zero_of_im_pos hσ)
+  have him : ((3 : ℂ) * σ).im = 3 * σ.im := by
+    simp [Complex.mul_im]
+  rw [show (-1 / (3 * σ) : ℂ) = -((3 : ℂ) * σ)⁻¹ by rw [neg_div, one_div]]
+  rw [Complex.neg_im, Complex.inv_im, neg_div, neg_neg, him]
+  exact div_pos (by linarith) (Complex.normSq_pos.mpr h3σ)
+
+lemma neg_pi_div_neg_two_I_mul {σ : ℂ} (hσ : σ ≠ 0) :
+    -(π : ℂ) / (-2 * I * σ) = -((π : ℂ) * I) / (2 * σ) := by
+  rw [div_eq_div_iff (mul_ne_zero (mul_ne_zero (by norm_num) Complex.I_ne_zero) hσ)
+    (mul_ne_zero (by norm_num) hσ)]
+  linear_combination (-2 * (π : ℂ) * σ) * Complex.I_sq
+
+lemma neg_pi_div_neg_three_I_mul_div_two {σ : ℂ} (hσ : σ ≠ 0) :
+    -(π : ℂ) / (-3 * I * σ / 2) = -(2 * (π : ℂ) * I) / (3 * σ) := by
+  rw [div_eq_div_iff
+    (div_ne_zero (mul_ne_zero (mul_ne_zero (by norm_num) Complex.I_ne_zero) hσ) (by norm_num))
+    (mul_ne_zero (by norm_num) hσ)]
+  linear_combination (-3 * (π : ℂ) * σ) * Complex.I_sq
+
+lemma I_mul_I_mul (w : ℂ) : I * (I * w) = -w := by
+  rw [← mul_assoc, Complex.I_mul_I, neg_one_mul]
+
+lemma exponent_initial (σ : ℂ) (x y : ℤ) :
+    2 * π * I * σ * ((x : ℂ) ^ 2 + (x : ℂ) * (y : ℂ) + (y : ℂ) ^ 2) =
+      2 * π * I * σ * (x : ℂ) ^ 2 +
+        (-π * (-2 * I * σ) * (y : ℂ) ^ 2 + 2 * π * (I * σ * (x : ℂ)) * (y : ℂ)) := by
+  ring
+
+lemma exponent_split {σ : ℂ} (hσ : σ ≠ 0) (x m : ℤ) :
+    2 * π * I * σ * (x : ℂ) ^ 2 +
+        -π / (-2 * I * σ) * ((m : ℂ) + I * (I * σ * (x : ℂ))) ^ 2 =
+      (-π * (-3 * I * σ / 2) * (x : ℂ) ^ 2 + 2 * π * (I * (m : ℂ) / 2) * (x : ℂ)) +
+        -π / (-2 * I * σ) * (m : ℂ) ^ 2 := by
+  rw [show I * (I * σ * (x : ℂ)) = -(σ * (x : ℂ)) by
+    linear_combination (σ * (x : ℂ)) * Complex.I_sq, neg_pi_div_neg_two_I_mul hσ]
+  field_simp
+  ring
+
+lemma exponent_total {σ : ℂ} (hσ : σ ≠ 0) (m k : ℤ) :
+    -π / (-2 * I * σ) * (m : ℂ) ^ 2 +
+        -π / (-3 * I * σ / 2) * ((k : ℂ) + I * (I * (m : ℂ) / 2)) ^ 2 =
+      2 * π * I * (-1 / (3 * σ)) *
+        ((k : ℂ) ^ 2 + (k : ℂ) * (-(m : ℂ)) + (-(m : ℂ)) ^ 2) := by
+  rw [show I * (I * (m : ℂ) / 2) = -((m : ℂ) / 2) by
+    linear_combination ((m : ℂ) / 2) * Complex.I_sq, neg_pi_div_neg_two_I_mul hσ,
+    neg_pi_div_neg_three_I_mul_div_two hσ]
+  field_simp
+  ring
+
+lemma inner_poisson {σ : ℂ} (hσ : 0 < σ.im) (x : ℤ) :
+    (∑' y : ℤ, hexThetaTerm σ (x, y)) =
+      1 / (-2 * I * σ) ^ (1 / 2 : ℂ) *
+        ∑' m : ℤ,
+          (cexp (-π * (-3 * I * σ / 2) * (x : ℂ) ^ 2 + 2 * π * (I * (m : ℂ) / 2) * (x : ℂ)) *
+            cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2)) := by
+  have ha : 0 < (-2 * I * σ).re := re_neg_two_I_mul hσ
+  have hσ0 : σ ≠ 0 := ne_zero_of_im_pos hσ
+  calc
+    (∑' y : ℤ, hexThetaTerm σ (x, y)) =
+        ∑' y : ℤ, cexp (2 * π * I * σ * (x : ℂ) ^ 2) *
+          cexp (-π * (-2 * I * σ) * (y : ℂ) ^ 2 + 2 * π * (I * σ * (x : ℂ)) * (y : ℂ)) := by
+      refine tsum_congr fun y => ?_
+      rw [hexThetaTerm, ← Complex.exp_add]
+      exact congrArg cexp (exponent_initial σ x y)
+    _ = cexp (2 * π * I * σ * (x : ℂ) ^ 2) *
+        ∑' y : ℤ, cexp (-π * (-2 * I * σ) * (y : ℂ) ^ 2 + 2 * π * (I * σ * (x : ℂ)) * (y : ℂ)) :=
+      tsum_mul_left
+    _ = cexp (2 * π * I * σ * (x : ℂ) ^ 2) *
+        (1 / (-2 * I * σ) ^ (1 / 2 : ℂ) *
+          ∑' m : ℤ, cexp (-π / (-2 * I * σ) * ((m : ℂ) + I * (I * σ * (x : ℂ))) ^ 2)) := by
+      rw [Complex.tsum_exp_neg_quadratic ha (I * σ * (x : ℂ))]
+    _ = 1 / (-2 * I * σ) ^ (1 / 2 : ℂ) *
+        ∑' m : ℤ, cexp (2 * π * I * σ * (x : ℂ) ^ 2) *
+          cexp (-π / (-2 * I * σ) * ((m : ℂ) + I * (I * σ * (x : ℂ))) ^ 2) := by
+      rw [tsum_mul_left]
+      ring
+    _ = 1 / (-2 * I * σ) ^ (1 / 2 : ℂ) *
+        ∑' m : ℤ,
+          (cexp (-π * (-3 * I * σ / 2) * (x : ℂ) ^ 2 + 2 * π * (I * (m : ℂ) / 2) * (x : ℂ)) *
+            cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2)) := by
+      congr 1
+      refine tsum_congr fun m => ?_
+      rw [← Complex.exp_add, ← Complex.exp_add]
+      exact congrArg cexp (exponent_split hσ0 x m)
+
+lemma outer_poisson {σ : ℂ} (hσ : 0 < σ.im) (m : ℤ) :
+    (∑' x : ℤ,
+        (cexp (-π * (-3 * I * σ / 2) * (x : ℂ) ^ 2 + 2 * π * (I * (m : ℂ) / 2) * (x : ℂ)) *
+          cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2))) =
+      1 / (-3 * I * σ / 2) ^ (1 / 2 : ℂ) *
+        ∑' k : ℤ, hexThetaTerm (-1 / (3 * σ)) (k, -m) := by
+  have ha : 0 < (-3 * I * σ / 2).re := re_neg_three_I_mul_div_two hσ
+  have hσ0 : σ ≠ 0 := ne_zero_of_im_pos hσ
+  calc
+    (∑' x : ℤ,
+        (cexp (-π * (-3 * I * σ / 2) * (x : ℂ) ^ 2 + 2 * π * (I * (m : ℂ) / 2) * (x : ℂ)) *
+          cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2))) =
+        (∑' x : ℤ,
+          cexp (-π * (-3 * I * σ / 2) * (x : ℂ) ^ 2 + 2 * π * (I * (m : ℂ) / 2) * (x : ℂ))) *
+          cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2) :=
+      tsum_mul_right
+    _ = (1 / (-3 * I * σ / 2) ^ (1 / 2 : ℂ) *
+          ∑' k : ℤ, cexp (-π / (-3 * I * σ / 2) * ((k : ℂ) + I * (I * (m : ℂ) / 2)) ^ 2)) *
+          cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2) := by
+      rw [Complex.tsum_exp_neg_quadratic ha (I * (m : ℂ) / 2)]
+    _ = 1 / (-3 * I * σ / 2) ^ (1 / 2 : ℂ) *
+          ∑' k : ℤ, cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2) *
+            cexp (-π / (-3 * I * σ / 2) * ((k : ℂ) + I * (I * (m : ℂ) / 2)) ^ 2) := by
+      rw [tsum_mul_left]
+      ring
+    _ = 1 / (-3 * I * σ / 2) ^ (1 / 2 : ℂ) *
+          ∑' k : ℤ, hexThetaTerm (-1 / (3 * σ)) (k, -m) := by
+      congr 1
+      refine tsum_congr fun k => ?_
+      rw [← Complex.exp_add, hexThetaTerm]
+      refine congrArg cexp ?_
+      push_cast
+      exact exponent_total hσ0 m k
+
+lemma summable_middle {σ : ℂ} (hσ : 0 < σ.im) :
+    Summable (Function.uncurry fun x m : ℤ =>
+      cexp (-π * (-3 * I * σ / 2) * (x : ℂ) ^ 2 + 2 * π * (I * (m : ℂ) / 2) * (x : ℂ)) *
+        cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2)) := by
+  have ha₁ : 0 < (-3 * I * σ / 2).re := re_neg_three_I_mul_div_two hσ
+  have ha₂ : 0 < ((-2 * I * σ)⁻¹).re := by
+    rw [Complex.inv_re]
+    exact div_pos (re_neg_two_I_mul hσ) (Complex.normSq_pos.mpr
+      (mul_ne_zero (mul_ne_zero (by norm_num) Complex.I_ne_zero) (ne_zero_of_im_pos hσ)))
+  apply Summable.of_norm
+  refine Summable.congr
+    (Summable.mul_of_nonneg (summable_norm_cexp_neg_quadratic ha₁ 0)
+      (summable_norm_cexp_neg_quadratic ha₂ 0)
+      (fun x => norm_nonneg _) (fun m => norm_nonneg _)) ?_
+  rintro ⟨x, m⟩
+  simp only [Function.uncurry_apply_pair, norm_mul]
+  congr 1
+  · rw [Complex.norm_exp, Complex.norm_exp]
+    congr 1
+    simp only [Complex.add_re]
+    congr 1
+    rw [show (2 * (π : ℂ) * (0 : ℂ) * (x : ℂ)) = (0 : ℂ) by ring,
+      show (2 * (π : ℂ) * (I * (m : ℂ) / 2) * (x : ℂ)) =
+        ((π * (m : ℝ) * (x : ℝ) : ℝ) : ℂ) * I by push_cast; ring]
+    rw [Complex.zero_re, Complex.re_ofReal_mul, Complex.I_re, mul_zero]
+  · refine congrArg norm (congrArg cexp ?_)
+    rw [mul_zero, zero_mul, add_zero, div_eq_mul_inv]
+
+theorem hexTheta_eq_mul_self_neg_inv {σ : ℂ} (hσ : 0 < σ.im) :
+    hexTheta σ =
+      1 / (-2 * I * σ) ^ (1 / 2 : ℂ) * (1 / (-3 * I * σ / 2) ^ (1 / 2 : ℂ)) *
+        hexTheta (-1 / (3 * σ)) := by
+  have hσ' : 0 < (-1 / (3 * σ)).im := im_neg_one_div_three_mul_pos hσ
+  calc
+    hexTheta σ = ∑' x : ℤ, ∑' y : ℤ, hexThetaTerm σ (x, y) :=
+      (summable_hexThetaTerm hσ).tsum_prod
+    _ = ∑' x : ℤ, (1 / (-2 * I * σ) ^ (1 / 2 : ℂ) *
+          ∑' m : ℤ,
+            (cexp (-π * (-3 * I * σ / 2) * (x : ℂ) ^ 2 + 2 * π * (I * (m : ℂ) / 2) * (x : ℂ)) *
+              cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2))) :=
+      tsum_congr fun x => inner_poisson hσ x
+    _ = 1 / (-2 * I * σ) ^ (1 / 2 : ℂ) *
+          ∑' x : ℤ, ∑' m : ℤ,
+            (cexp (-π * (-3 * I * σ / 2) * (x : ℂ) ^ 2 + 2 * π * (I * (m : ℂ) / 2) * (x : ℂ)) *
+              cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2)) :=
+      tsum_mul_left
+    _ = 1 / (-2 * I * σ) ^ (1 / 2 : ℂ) *
+          ∑' m : ℤ, ∑' x : ℤ,
+            (cexp (-π * (-3 * I * σ / 2) * (x : ℂ) ^ 2 + 2 * π * (I * (m : ℂ) / 2) * (x : ℂ)) *
+              cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2)) := by
+      congr 1
+      exact ((summable_middle hσ).tsum_comm).symm
+    _ = 1 / (-2 * I * σ) ^ (1 / 2 : ℂ) *
+          ∑' m : ℤ, (1 / (-3 * I * σ / 2) ^ (1 / 2 : ℂ) *
+            ∑' k : ℤ, hexThetaTerm (-1 / (3 * σ)) (k, -m)) := by
+      congr 1
+      exact tsum_congr fun m => outer_poisson hσ m
+    _ = 1 / (-2 * I * σ) ^ (1 / 2 : ℂ) * (1 / (-3 * I * σ / 2) ^ (1 / 2 : ℂ) *
+          ∑' m : ℤ, ∑' k : ℤ, hexThetaTerm (-1 / (3 * σ)) (k, -m)) := by
+      rw [tsum_mul_left]
+    _ = 1 / (-2 * I * σ) ^ (1 / 2 : ℂ) * (1 / (-3 * I * σ / 2) ^ (1 / 2 : ℂ)) *
+          hexTheta (-1 / (3 * σ)) := by
+      have hS : (∑' m : ℤ, ∑' k : ℤ, hexThetaTerm (-1 / (3 * σ)) (k, -m)) =
+          hexTheta (-1 / (3 * σ)) :=
+        calc
+          (∑' m : ℤ, ∑' k : ℤ, hexThetaTerm (-1 / (3 * σ)) (k, -m)) =
+              ∑' m : ℤ, ∑' k : ℤ, hexThetaTerm (-1 / (3 * σ)) (-m, k) :=
+            tsum_congr fun m => tsum_congr fun k => hexThetaTerm_swap _ k (-m)
+          _ = ∑' m : ℤ, ∑' k : ℤ, hexThetaTerm (-1 / (3 * σ)) (m, k) :=
+            tsum_comp_neg fun m => ∑' k : ℤ, hexThetaTerm (-1 / (3 * σ)) (m, k)
+          _ = hexTheta (-1 / (3 * σ)) := ((summable_hexThetaTerm hσ').tsum_prod).symm
+      rw [hS]
+      ring
+
+lemma re_cpow_half_pos {z : ℂ} (hz : 0 < z.re) : 0 < (z ^ (1 / 2 : ℂ)).re := by
+  have hz0 : z ≠ 0 := fun h => by simp [h] at hz
+  have harg : |Complex.arg z| < π / 2 := Complex.abs_arg_lt_pi_div_two_iff.mpr (Or.inl hz)
+  rw [abs_lt] at harg
+  rw [show (1 / 2 : ℂ) = ((1 / 2 : ℝ) : ℂ) by norm_num, Complex.cpow_ofReal_re]
+  exact mul_pos (Real.rpow_pos_of_pos (norm_pos_iff.mpr hz0) _)
+    (Real.cos_pos_of_mem_Ioo ⟨by linarith [harg.1, pi_pos], by linarith [harg.2, pi_pos]⟩)
+
+lemma re_cpow_half_mul_cpow_half_pos {a b : ℂ} (ha : 0 < a.re) (hb : 0 < b.re) :
+    0 < (a ^ (1 / 2 : ℂ) * b ^ (1 / 2 : ℂ)).re := by
+  have ha0 : a ≠ 0 := fun h => by simp [h] at ha
+  have hb0 : b ≠ 0 := fun h => by simp [h] at hb
+  have harga : |Complex.arg a| < π / 2 := Complex.abs_arg_lt_pi_div_two_iff.mpr (Or.inl ha)
+  have hargb : |Complex.arg b| < π / 2 := Complex.abs_arg_lt_pi_div_two_iff.mpr (Or.inl hb)
+  rw [abs_lt] at harga hargb
+  have hcos : 0 < Real.cos (Complex.arg a * (1 / 2) + Complex.arg b * (1 / 2)) :=
+    Real.cos_pos_of_mem_Ioo
+      ⟨by linarith [harga.1, hargb.1], by linarith [harga.2, hargb.2]⟩
+  rw [Real.cos_add] at hcos
+  have hra : 0 < ‖a‖ ^ (1 / 2 : ℝ) := Real.rpow_pos_of_pos (norm_pos_iff.mpr ha0) _
+  have hrb : 0 < ‖b‖ ^ (1 / 2 : ℝ) := Real.rpow_pos_of_pos (norm_pos_iff.mpr hb0) _
+  rw [show (1 / 2 : ℂ) = ((1 / 2 : ℝ) : ℂ) by norm_num, Complex.mul_re,
+    Complex.cpow_ofReal_re, Complex.cpow_ofReal_re, Complex.cpow_ofReal_im,
+    Complex.cpow_ofReal_im]
+  nlinarith [mul_pos hra hrb, hcos]
+
+lemma eq_of_sq_eq_sq_of_re_pos {a b : ℂ} (h : a ^ 2 = b ^ 2) (ha : 0 < a.re)
+    (hb : 0 < b.re) : a = b := by
+  rcases sq_eq_sq_iff_eq_or_eq_neg.mp h with h' | h'
+  · exact h'
+  · exfalso
+    rw [h', Complex.neg_re] at ha
+    linarith
+
+lemma sq_cpow_half {z : ℂ} (hz : z ≠ 0) : (z ^ (1 / 2 : ℂ)) ^ 2 = z := by
+  rw [sq, ← Complex.cpow_add _ _ hz]
+  norm_num
+
+lemma cpow_half_mul_cpow_half {σ : ℂ} (hσ : 0 < σ.im) :
+    (-2 * I * σ) ^ (1 / 2 : ℂ) * (-3 * I * σ / 2) ^ (1 / 2 : ℂ) =
+      -I * (Real.sqrt 3 : ℂ) * σ := by
+  have hσ0 : σ ≠ 0 := ne_zero_of_im_pos hσ
+  have ha : (-2 : ℂ) * I * σ ≠ 0 :=
+    mul_ne_zero (mul_ne_zero (by norm_num) Complex.I_ne_zero) hσ0
+  have hb : (-3 : ℂ) * I * σ / 2 ≠ 0 :=
+    div_ne_zero (mul_ne_zero (mul_ne_zero (by norm_num) Complex.I_ne_zero) hσ0) (by norm_num)
+  have hs3 : ((Real.sqrt 3 : ℝ) : ℂ) ^ 2 = 3 := by
+    rw [← Complex.ofReal_pow, Real.sq_sqrt (by norm_num : (0 : ℝ) ≤ 3)]
+    norm_num
+  refine eq_of_sq_eq_sq_of_re_pos ?_
+    (re_cpow_half_mul_cpow_half_pos (re_neg_two_I_mul hσ) (re_neg_three_I_mul_div_two hσ)) ?_
+  · rw [mul_pow, sq_cpow_half ha, sq_cpow_half hb,
+      show (-I * ((Real.sqrt 3 : ℝ) : ℂ) * σ) ^ 2 =
+        ((Real.sqrt 3 : ℝ) : ℂ) ^ 2 * (I ^ 2 * σ ^ 2) by ring,
+      hs3]
+    ring
+  · rw [show (-I * ((Real.sqrt 3 : ℝ) : ℂ) * σ) = ((Real.sqrt 3 : ℝ) : ℂ) * (σ * -I) by ring,
+      Complex.re_ofReal_mul, mul_neg, Complex.neg_re, Complex.mul_I_re, neg_neg]
+    exact mul_pos (Real.sqrt_pos.mpr (by norm_num)) hσ
+
+lemma cpow_half_ne_zero {z : ℂ} (hz : z ≠ 0) : z ^ (1 / 2 : ℂ) ≠ 0 := fun h =>
+  hz ((Complex.cpow_eq_zero_iff _ _).mp h).1
+
+theorem hexTheta_fricke {σ : ℂ} (hσ : 0 < σ.im) :
+    hexTheta (-1 / (3 * σ)) = -I * (Real.sqrt 3 : ℂ) * σ * hexTheta σ := by
+  have hσ0 : σ ≠ 0 := ne_zero_of_im_pos hσ
+  have ha : (-2 : ℂ) * I * σ ≠ 0 :=
+    mul_ne_zero (mul_ne_zero (by norm_num) Complex.I_ne_zero) hσ0
+  have hb : (-3 : ℂ) * I * σ / 2 ≠ 0 :=
+    div_ne_zero (mul_ne_zero (mul_ne_zero (by norm_num) Complex.I_ne_zero) hσ0) (by norm_num)
+  have hu : (-2 * I * σ) ^ (1 / 2 : ℂ) ≠ 0 := cpow_half_ne_zero ha
+  have hv : (-3 * I * σ / 2) ^ (1 / 2 : ℂ) ≠ 0 := cpow_half_ne_zero hb
+  have hone : (-2 * I * σ) ^ (1 / 2 : ℂ) * (-3 * I * σ / 2) ^ (1 / 2 : ℂ) *
+      (1 / (-2 * I * σ) ^ (1 / 2 : ℂ) * (1 / (-3 * I * σ / 2) ^ (1 / 2 : ℂ))) = 1 := by
+    field_simp
+  rw [hexTheta_eq_mul_self_neg_inv hσ, ← cpow_half_mul_cpow_half hσ, ← mul_assoc, hone,
+    one_mul]
+
+lemma hexTheta_mul_I_eq_ofReal (t : ℝ) :
+    hexTheta (I * (t : ℂ)) =
+      ((∑' p : ℤ × ℤ,
+        rexp (-(2 * π * t) * ((p.1 : ℝ) ^ 2 + (p.1 : ℝ) * (p.2 : ℝ) + (p.2 : ℝ) ^ 2))) : ℝ) := by
+  rw [hexTheta, Complex.ofReal_tsum]
+  refine tsum_congr fun p => ?_
+  rw [hexThetaTerm, Complex.ofReal_exp]
+  refine congrArg cexp ?_
+  push_cast
+  linear_combination (2 * (π : ℂ) * (t : ℂ) *
+    ((p.1 : ℂ) ^ 2 + (p.1 : ℂ) * (p.2 : ℂ) + (p.2 : ℂ) ^ 2)) * Complex.I_sq
+
+lemma hexTheta_mul_I_ne_zero {t : ℝ} (ht : 0 < t) : hexTheta (I * (t : ℂ)) ≠ 0 := by
+  have him : (I * (t : ℂ)).im = t := by simp
+  have hsum : Summable (hexThetaTerm (I * (t : ℂ))) :=
+    summable_hexThetaTerm (by rw [him]; exact ht)
+  have hsum' : Summable fun p : ℤ × ℤ =>
+      rexp (-(2 * π * t) * ((p.1 : ℝ) ^ 2 + (p.1 : ℝ) * (p.2 : ℝ) + (p.2 : ℝ) ^ 2)) := by
+    refine (summable_norm_iff.mpr hsum).congr fun p => ?_
+    rw [norm_hexThetaTerm, him]
+  rw [hexTheta_mul_I_eq_ofReal t, Ne, Complex.ofReal_eq_zero]
+  exact (hsum'.tsum_pos (fun p => (Real.exp_pos _).le) (0, 0) (Real.exp_pos _)).ne'
+
+def frickeFixedPoint : ℂ := I / (Real.sqrt 3 : ℂ)
+
+lemma sqrt_three_ne_zero : ((Real.sqrt 3 : ℝ) : ℂ) ≠ 0 :=
+  Complex.ofReal_ne_zero.mpr (Real.sqrt_pos.mpr (by norm_num)).ne'
+
+lemma frickeFixedPoint_im_pos : 0 < frickeFixedPoint.im := by
+  rw [frickeFixedPoint, show (I / ((Real.sqrt 3 : ℝ) : ℂ)) =
+    ((((Real.sqrt 3)⁻¹ : ℝ)) : ℂ) * I by push_cast; ring, Complex.mul_I_im,
+    Complex.ofReal_re]
+  positivity
+
+lemma three_mul_frickeFixedPoint_sq : 3 * frickeFixedPoint ^ 2 = -1 := by
+  rw [frickeFixedPoint, div_pow, Complex.I_sq,
+    show ((Real.sqrt 3 : ℝ) : ℂ) ^ 2 = 3 by
+      rw [← Complex.ofReal_pow, Real.sq_sqrt (by norm_num : (0 : ℝ) ≤ 3)]; norm_num]
+  norm_num
+
+lemma frickeFixedPoint_fixed : -1 / (3 * frickeFixedPoint) = frickeFixedPoint := by
+  have h0 : frickeFixedPoint ≠ 0 := by
+    rw [frickeFixedPoint]
+    exact div_ne_zero Complex.I_ne_zero sqrt_three_ne_zero
+  rw [div_eq_iff (mul_ne_zero (by norm_num) h0)]
+  linear_combination -three_mul_frickeFixedPoint_sq
+
+lemma neg_I_mul_sqrt_three_mul_frickeFixedPoint :
+    -I * (Real.sqrt 3 : ℂ) * frickeFixedPoint = 1 := by
+  rw [frickeFixedPoint, show -I * ((Real.sqrt 3 : ℝ) : ℂ) * (I / ((Real.sqrt 3 : ℝ) : ℂ)) =
+    -(I * I) * (((Real.sqrt 3 : ℝ) : ℂ) / ((Real.sqrt 3 : ℝ) : ℂ)) by ring,
+    Complex.I_mul_I, div_self sqrt_three_ne_zero]
+  norm_num
+
+lemma I_mul_sqrt_three_mul_frickeFixedPoint :
+    I * (Real.sqrt 3 : ℂ) * frickeFixedPoint = -1 := by
+  linear_combination -neg_I_mul_sqrt_three_mul_frickeFixedPoint
+
+lemma hexTheta_frickeFixedPoint_ne_zero : hexTheta frickeFixedPoint ≠ 0 := by
+  rw [show frickeFixedPoint = I * ((((Real.sqrt 3)⁻¹ : ℝ)) : ℂ) by
+    rw [frickeFixedPoint]; push_cast; ring]
+  exact hexTheta_mul_I_ne_zero (by positivity)
+
+theorem not_hexTheta_eq_neg_multiplier_mul :
+    ¬ (hexTheta (-1 / (3 * frickeFixedPoint)) =
+        I * (Real.sqrt 3 : ℂ) * frickeFixedPoint * hexTheta frickeFixedPoint) := by
+  intro hcon
+  rw [frickeFixedPoint_fixed, I_mul_sqrt_three_mul_frickeFixedPoint, neg_one_mul] at hcon
+  exact hexTheta_frickeFixedPoint_ne_zero (CharZero.eq_neg_self_iff.mp hcon)
+
+end
+end FLT.AnalyticCore
+end File_FLT_AnalyticCore_RankTwoPoissonSummation
+
+section File_FLT_AnalyticCore_TwoGeneratorSweep
+
+open Matrix CongruenceSubgroup Subgroup ModularForm UpperHalfPlane
+open scoped MatrixGroups ModularForm Manifold Pointwise
+
+namespace FLT
+namespace AnalyticCore
+
+namespace Gamma0Three
+
+def repOfLabel : Option (ZMod 3) → SL(2, ℤ)
+  | none => 1
+  | some k => ⟨!![0, -1; 1, (k.val : ℤ)], by simp [Matrix.det_fin_two_of]⟩
+
+@[scoped simp] lemma repOfLabel_none : repOfLabel none = 1 := rfl
+
+@[scoped simp] lemma repOfLabel_some_one_zero (k : ZMod 3) : repOfLabel (some k) 1 0 = 1 := rfl
+
+@[scoped simp] lemma repOfLabel_some_one_one (k : ZMod 3) :
+    repOfLabel (some k) 1 1 = (k.val : ℤ) := rfl
+
+@[scoped simp] lemma one_apply_one_zero : (1 : SL(2, ℤ)) 1 0 = 0 := rfl
+
+@[scoped simp] lemma one_apply_one_one : (1 : SL(2, ℤ)) 1 1 = 1 := rfl
+
+def transversal : Set SL(2, ℤ) := Set.range repOfLabel
+
+lemma one_mem_transversal : (1 : SL(2, ℤ)) ∈ transversal := ⟨none, rfl⟩
+
+def label (g : SL(2, ℤ)) : Option (ZMod 3) :=
+  if (g 1 0 : ZMod 3) = 0 then none
+  else some ((g 1 1 : ZMod 3) / (g 1 0 : ZMod 3))
+
+private lemma intCast_val (k : ZMod 3) : (((k.val : ℕ) : ℤ) : ZMod 3) = k := by
+  exact_mod_cast ZMod.natCast_rightInverse k
+
+lemma apply_one_one_ne_zero (g : SL(2, ℤ)) (hc : (g 1 0 : ZMod 3) = 0) :
+    (g 1 1 : ZMod 3) ≠ 0 := by
+  intro hd
+  have hdet : (g 0 0 : ℤ) * g 1 1 - g 0 1 * g 1 0 = 1 := by
+    have h2 := g.2
+    rw [Matrix.det_fin_two] at h2
+    exact h2
+  have hcast : (g 0 0 : ZMod 3) * (g 1 1 : ZMod 3)
+      - (g 0 1 : ZMod 3) * (g 1 0 : ZMod 3) = 1 := by
+    have h3 : (((g 0 0 : ℤ) * g 1 1 - g 0 1 * g 1 0 : ℤ) : ZMod 3) = ((1 : ℤ) : ZMod 3) := by
+      rw [hdet]
+    push_cast at h3
+    exact h3
+  rw [hc, hd, mul_zero, mul_zero, sub_zero] at hcast
+  exact zero_ne_one hcast
+
+private theorem mul_entry (A B : SL(2, ℤ)) (i j : Fin 2) :
+    (A * B) i j = A i 0 * B 0 j + A i 1 * B 1 j := by
+  show ((A * B : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) i j = _
+  rw [Matrix.SpecialLinearGroup.coe_mul, Matrix.mul_apply, Fin.sum_univ_two]
+
+private theorem inv_entries (A : SL(2, ℤ)) :
+    A⁻¹ 0 0 = A 1 1 ∧ A⁻¹ 0 1 = -A 0 1 ∧ A⁻¹ 1 0 = -A 1 0 ∧ A⁻¹ 1 1 = A 0 0 := by
+  have h : ((A⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) =
+      !![A 1 1, -A 0 1; -A 1 0, A 0 0] := by
+    rw [Matrix.SpecialLinearGroup.coe_inv, Matrix.adjugate_fin_two]
+  refine ⟨?_, ?_, ?_, ?_⟩ <;> simp [h]
+
+lemma mul_inv_apply_one_zero (g h : SL(2, ℤ)) :
+    (g * h⁻¹) 1 0 = g 1 0 * h 1 1 - g 1 1 * h 1 0 := by
+  rw [mul_entry, (inv_entries h).1, (inv_entries h).2.2.1]
+  ring
+
+theorem mul_inv_mem_iff (g h : SL(2, ℤ)) :
+    g * h⁻¹ ∈ Gamma0 3 ↔
+      (g 1 0 : ZMod 3) * (h 1 1 : ZMod 3) = (g 1 1 : ZMod 3) * (h 1 0 : ZMod 3) := by
+  rw [Gamma0_mem, mul_inv_apply_one_zero]
+  push_cast
+  exact sub_eq_zero
+
+theorem mul_inv_repOfLabel_mem_iff (g : SL(2, ℤ)) (l : Option (ZMod 3)) :
+    g * (repOfLabel l)⁻¹ ∈ Gamma0 3 ↔ l = label g := by
+  rw [mul_inv_mem_iff]
+  unfold label
+  cases l with
+  | none =>
+    rw [repOfLabel_none, one_apply_one_one, one_apply_one_zero, Int.cast_one, mul_one,
+      Int.cast_zero, mul_zero]
+    by_cases hc : (g 1 0 : ZMod 3) = 0
+    · rw [ite_eq_left hc]
+      exact iff_of_true hc rfl
+    · rw [ite_eq_right hc]
+      exact iff_of_false hc (by simp)
+  | some k =>
+    rw [repOfLabel_some_one_one, repOfLabel_some_one_zero, Int.cast_one, mul_one,
+      intCast_val]
+    by_cases hc : (g 1 0 : ZMod 3) = 0
+    · rw [ite_eq_left hc]
+      refine iff_of_false (fun hcontra => ?_) (by simp)
+      rw [hc, zero_mul] at hcontra
+      exact apply_one_one_ne_zero g hc hcontra.symm
+    · rw [ite_eq_right hc, Option.some_inj, eq_div_iff hc]
+      constructor <;> intro h <;> linear_combination h
+
+theorem isComplement_transversal :
+    IsComplement (Gamma0 3 : Set SL(2, ℤ)) transversal := by
+  rw [isComplement_iff_existsUnique_mul_inv_mem]
+  intro g
+  refine ⟨⟨repOfLabel (label g), ⟨label g, rfl⟩⟩, ?_, ?_⟩
+  · exact (mul_inv_repOfLabel_mem_iff g (label g)).mpr rfl
+  · rintro ⟨x, l, rfl⟩ ht
+    exact Subtype.ext (congrArg repOfLabel ((mul_inv_repOfLabel_mem_iff g l).mp ht))
+
+lemma coe_toRightFun (g : SL(2, ℤ)) :
+    (isComplement_transversal.toRightFun g : SL(2, ℤ)) = repOfLabel (label g) := by
+  have huniq := isComplement_iff_existsUnique_mul_inv_mem.mp isComplement_transversal g
+  have h1 : g * ((isComplement_transversal.toRightFun g : SL(2, ℤ)))⁻¹
+      ∈ (Gamma0 3 : Set SL(2, ℤ)) :=
+    isComplement_transversal.mul_inv_toRightFun_mem g
+  have h2 : g * (((⟨repOfLabel (label g), ⟨label g, rfl⟩⟩ : transversal) : SL(2, ℤ)))⁻¹
+      ∈ (Gamma0 3 : Set SL(2, ℤ)) :=
+    (mul_inv_repOfLabel_mem_iff g (label g)).mpr rfl
+  exact congrArg Subtype.val (huniq.unique h1 h2)
+
+def schreierGen (l : Option (ZMod 3)) (s : SL(2, ℤ)) : SL(2, ℤ) :=
+  repOfLabel l * s * (repOfLabel (label (repOfLabel l * s)))⁻¹
+
+theorem schreierGen_mem (l : Option (ZMod 3)) (s : SL(2, ℤ)) :
+    schreierGen l s ∈ Gamma0 3 :=
+  (mul_inv_repOfLabel_mem_iff (repOfLabel l * s) (label (repOfLabel l * s))).mpr rfl
+
+def schreierGens : Set SL(2, ℤ) :=
+  {x | ∃ l : Option (ZMod 3),
+    x = schreierGen l ModularGroup.S ∨ x = schreierGen l ModularGroup.T}
+
+theorem closure_schreierGens : Subgroup.closure schreierGens = Gamma0 3 := by
+  refine le_antisymm ((Subgroup.closure_le _).mpr ?_) ?_
+  · rintro x ⟨l, rfl | rfl⟩ <;> exact schreierGen_mem _ _
+  · rw [← Subgroup.closure_mul_image_eq isComplement_transversal one_mem_transversal
+      SpecialLinearGroup.SL2Z_generators]
+    refine Subgroup.closure_mono ?_
+    rintro x ⟨g, hg, rfl⟩
+    rw [Set.mem_mul] at hg
+    obtain ⟨r, hr, s, hs, rfl⟩ := hg
+    obtain ⟨l, rfl⟩ := hr
+    simp only [coe_toRightFun]
+    simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hs
+    rcases hs with rfl | rfl
+    · exact ⟨l, Or.inl rfl⟩
+    · exact ⟨l, Or.inr rfl⟩
+
+end Gamma0Three
+
+def U₃ : SL(2, ℤ) := ⟨!![1, 0; -3, 1], by simp [Matrix.det_fin_two_of]⟩
+
+@[scoped simp] lemma U₃_one_zero : U₃ 1 0 = -3 := rfl
+@[scoped simp] lemma U₃_one_one : U₃ 1 1 = 1 := rfl
+
+lemma T_mem_gamma0_three : ModularGroup.T ∈ Gamma0 3 := by
+  rw [Gamma0_mem]; decide
+
+lemma U₃_mem_gamma0_three : U₃ ∈ Gamma0 3 := by
+  rw [Gamma0_mem]; decide
+
+lemma neg_one_mem_gamma0_three : (-1 : SL(2, ℤ)) ∈ Gamma0 3 := by
+  rw [Gamma0_mem]; decide
+
+def gens : Set SL(2, ℤ) := {ModularGroup.T, U₃, -1}
+
+lemma gens_subset_gamma0_three : gens ⊆ (Gamma0 3 : Subgroup SL(2, ℤ)) := by
+  rintro x (rfl | rfl | rfl)
+  · exact T_mem_gamma0_three
+  · exact U₃_mem_gamma0_three
+  · exact neg_one_mem_gamma0_three
+
+namespace Gamma0Three
+
+private lemma schreierGen_eq_one :
+    schreierGen (some 0) ModularGroup.T = 1 ∧ schreierGen (some 1) ModularGroup.T = 1 ∧
+    schreierGen none ModularGroup.S = 1 := by decide +kernel
+
+private lemma schreierGen_none_T : schreierGen none ModularGroup.T = ModularGroup.T := by
+  decide
+
+private lemma schreierGen_two_T : schreierGen (some 2) ModularGroup.T = U₃ := by decide +kernel
+
+private lemma schreierGen_zero_S : schreierGen (some 0) ModularGroup.S = -1 := by decide
+
+private lemma schreierGen_one_S :
+    schreierGen (some 1) ModularGroup.S = ModularGroup.T⁻¹ * U₃⁻¹ := by decide +kernel
+
+private lemma schreierGen_two_S :
+    schreierGen (some 2) ModularGroup.S = -1 * (U₃ * ModularGroup.T) := by decide +kernel
+
+lemma schreierGens_subset_closure_gens :
+    schreierGens ⊆ (Subgroup.closure gens : Set SL(2, ℤ)) := by
+  have hT : ModularGroup.T ∈ Subgroup.closure gens :=
+    Subgroup.subset_closure (Or.inl rfl)
+  have hU : U₃ ∈ Subgroup.closure gens :=
+    Subgroup.subset_closure (Or.inr (Or.inl rfl))
+  have hneg : (-1 : SL(2, ℤ)) ∈ Subgroup.closure gens :=
+    Subgroup.subset_closure (Or.inr (Or.inr rfl))
+  have hcases : ∀ j : ZMod 3, j = 0 ∨ j = 1 ∨ j = 2 := by decide
+  rintro x ⟨l, rfl | rfl⟩
+  · rcases l with _ | k
+    · rw [schreierGen_eq_one.2.2]; exact one_mem _
+    · rcases hcases k with rfl | rfl | rfl
+      · rw [schreierGen_zero_S]; exact hneg
+      · rw [schreierGen_one_S]; exact mul_mem (inv_mem hT) (inv_mem hU)
+      · rw [schreierGen_two_S]; exact mul_mem hneg (mul_mem hU hT)
+  · rcases l with _ | k
+    · rw [schreierGen_none_T]; exact hT
+    · rcases hcases k with rfl | rfl | rfl
+      · rw [schreierGen_eq_one.1]; exact one_mem _
+      · rw [schreierGen_eq_one.2.1]; exact one_mem _
+      · rw [schreierGen_two_T]; exact hU
+
+end Gamma0Three
+
+theorem closure_T_U_neg_one_eq : Subgroup.closure gens = Gamma0 3 := by
+  refine le_antisymm ((Subgroup.closure_le _).mpr gens_subset_gamma0_three) ?_
+  rw [← Gamma0Three.closure_schreierGens]
+  exact (Subgroup.closure_le _).mpr Gamma0Three.schreierGens_subset_closure_gens
+
+theorem mem_closure_gens {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 3) : γ ∈ Subgroup.closure gens :=
+  closure_T_U_neg_one_eq ▸ hγ
+
+theorem TU_pow_three : (ModularGroup.T * U₃) ^ 3 = 1 := by decide
+
+theorem TU_ne_one : ModularGroup.T * U₃ ≠ 1 := by decide
+
+theorem TU_sq_ne_one : (ModularGroup.T * U₃) ^ 2 ≠ 1 := by decide
+
+theorem U₃_not_mem_gamma0_nine : U₃ ∉ Gamma0 9 := by
+  rw [Gamma0_mem]; decide
+
+def chi3 (γ : SL(2, ℤ)) : ℤ :=
+  if (γ 1 1 : ZMod 3) = 1 then 1 else -1
+
+lemma chi3_eq_one_or_neg_one (γ : SL(2, ℤ)) : chi3 γ = 1 ∨ chi3 γ = -1 := by
+  unfold chi3; split <;> simp
+
+lemma chi3_mul_self (γ : SL(2, ℤ)) : chi3 γ * chi3 γ = 1 := by
+  rcases chi3_eq_one_or_neg_one γ with h | h <;> rw [h] <;> norm_num
+
+@[scoped simp] lemma chi3_one : chi3 1 = 1 := by unfold chi3; norm_num
+
+@[scoped simp] lemma chi3_T : chi3 ModularGroup.T = 1 := by
+  unfold chi3; rw [show (ModularGroup.T 1 1 : ZMod 3) = 1 by decide]; simp
+
+@[scoped simp] lemma chi3_U₃ : chi3 U₃ = 1 := by
+  unfold chi3; rw [show (U₃ 1 1 : ZMod 3) = 1 by decide]; simp
+
+@[scoped simp] lemma chi3_neg_one : chi3 (-1 : SL(2, ℤ)) = -1 := by
+  unfold chi3; rw [show ((-1 : SL(2, ℤ)) 1 1 : ZMod 3) = 2 by decide]; decide
+
+lemma apply_one_one_ne_zero_of_mem {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 3) :
+    (γ 1 1 : ZMod 3) ≠ 0 :=
+  Gamma0Three.apply_one_one_ne_zero γ (Gamma0_mem.mp hγ)
+
+lemma coe_mul_apply_one_one {γ δ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 3) (hδ : δ ∈ Gamma0 3) :
+    ((γ * δ) 1 1 : ZMod 3) = (γ 1 1 : ZMod 3) * (δ 1 1 : ZMod 3) := by
+  have := map_mul (Gamma0Map 3) (⟨γ, hγ⟩ : Gamma0 3) (⟨δ, hδ⟩ : Gamma0 3)
+  simpa [Gamma0Map] using this
+
+theorem chi3_mul {γ δ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 3) (hδ : δ ∈ Gamma0 3) :
+    chi3 (γ * δ) = chi3 γ * chi3 δ := by
+  have key : ∀ x : ZMod 3, x ≠ 0 → x = 1 ∨ x = 2 := by decide
+  unfold chi3
+  rw [coe_mul_apply_one_one hγ hδ]
+  rcases key _ (apply_one_one_ne_zero_of_mem hγ) with h1 | h1 <;>
+    rcases key _ (apply_one_one_ne_zero_of_mem hδ) with h2 | h2 <;>
+      rw [h1, h2] <;> decide
+
+theorem chi3_eq_one_of_mem_Gamma1 {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma1 3) : chi3 γ = 1 := by
+  unfold chi3
+  rw [((Gamma1_mem 3 γ).mp hγ).2.1]
+  simp
+
+theorem chi3_eq_chiNegThree (d : ℕ) (hd : (d : ZMod 3) ≠ 0) (γ : SL(2, ℤ))
+    (hγd : (γ 1 1 : ZMod 3) = (d : ZMod 3)) :
+    chi3 γ = FLT.EisensteinWeightOne.chiNegThree d := by
+  have key : ∀ x : ZMod 3, x ≠ 0 → x = 1 ∨ x = 2 := by decide
+  have hval : d % 3 = (d : ZMod 3).val := by rw [ZMod.val_natCast]
+  unfold chi3 FLT.EisensteinWeightOne.chiNegThree
+  rw [hγd, hval]
+  rcases key _ hd with h | h <;> rw [h] <;> decide
+
+section Sweep
+
+variable (F : ℍ → ℂ)
+
+theorem slash_neg_one :
+    F ∣[(1 : ℤ)] (-1 : SL(2, ℤ)) = ((chi3 (-1 : SL(2, ℤ)) : ℤ) : ℂ) • F := by
+  rw [chi3_neg_one]
+  ext τ
+  rw [ModularForm.SL_slash_apply]
+  have hsmul : ((-1 : SL(2, ℤ)) • τ : ℍ) = τ := by
+    rw [show (-1 : SL(2, ℤ)) = -(1 : SL(2, ℤ)) from rfl, ModularGroup.SL_neg_smul, one_smul]
+  have hden : denom (-1 : SL(2, ℤ)) τ = -1 := by
+    rw [ModularGroup.denom_apply]
+    norm_num [show ((-1 : SL(2, ℤ)) 1 0) = 0 from rfl, show ((-1 : SL(2, ℤ)) 1 1) = -1 from rfl]
+  rw [hsmul, hden]
+  have hpow : ((-1 : ℂ)) ^ (-(1 : ℤ)) = -1 := by norm_num
+  rw [hpow]
+  simp only [Pi.smul_apply, smul_eq_mul]
+  push_cast
+  ring
+
+theorem slash_eq_chi3_smul
+    (hT : F ∣[(1 : ℤ)] ModularGroup.T = F) (hU : F ∣[(1 : ℤ)] U₃ = F)
+    {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 3) :
+    F ∣[(1 : ℤ)] γ = (chi3 γ : ℂ) • F := by
+  let p : (g : SL(2, ℤ)) → g ∈ Subgroup.closure gens → Prop :=
+    fun g _ => F ∣[(1 : ℤ)] g = (chi3 g : ℂ) • F
+  have hmem_iff : ∀ {g : SL(2, ℤ)}, g ∈ Subgroup.closure gens ↔ g ∈ Gamma0 3 := by
+    intro g; rw [closure_T_U_neg_one_eq]
+  refine Subgroup.closure_induction (k := gens) (p := p) ?_ ?_ ?_ ?_ (hmem_iff.mpr hγ)
+  · rintro x (rfl | rfl | rfl)
+    · change F ∣[(1 : ℤ)] ModularGroup.T = (chi3 ModularGroup.T : ℂ) • F
+      rw [hT, chi3_T]; simp
+    · change F ∣[(1 : ℤ)] U₃ = (chi3 U₃ : ℂ) • F
+      rw [hU, chi3_U₃]; simp
+    · exact slash_neg_one F
+  · change F ∣[(1 : ℤ)] (1 : SL(2, ℤ)) = (chi3 1 : ℂ) • F
+    rw [SlashAction.slash_one, chi3_one]
+    simp
+  · intro x y hx hy hpx hpy
+    change F ∣[(1 : ℤ)] (x * y) = (chi3 (x * y) : ℂ) • F
+    have hx' : x ∈ Gamma0 3 := hmem_iff.mp hx
+    have hy' : y ∈ Gamma0 3 := hmem_iff.mp hy
+    calc F ∣[(1 : ℤ)] (x * y) = (F ∣[(1 : ℤ)] x) ∣[(1 : ℤ)] y := by
+            rw [SlashAction.slash_mul]
+      _ = ((chi3 x : ℂ) • F) ∣[(1 : ℤ)] y := by rw [hpx]
+      _ = (chi3 x : ℂ) • (F ∣[(1 : ℤ)] y) := by rw [ModularForm.SL_smul_slash]
+      _ = (chi3 x : ℂ) • ((chi3 y : ℂ) • F) := by rw [hpy]
+      _ = ((chi3 x * chi3 y : ℤ) : ℂ) • F := by rw [smul_smul]; norm_num
+      _ = (chi3 (x * y) : ℂ) • F := by rw [← chi3_mul hx' hy']
+  · intro x hx hpx
+    change F ∣[(1 : ℤ)] x⁻¹ = (chi3 x⁻¹ : ℂ) • F
+    have hx' : x ∈ Gamma0 3 := hmem_iff.mp hx
+    have hxinv : x⁻¹ ∈ Gamma0 3 := inv_mem hx'
+    have hchi : chi3 x⁻¹ = chi3 x := by
+      have h1 : chi3 (x⁻¹ * x) = chi3 x⁻¹ * chi3 x := chi3_mul hxinv hx'
+      rw [inv_mul_cancel, chi3_one] at h1
+      rcases chi3_eq_one_or_neg_one x with h | h <;>
+        rcases chi3_eq_one_or_neg_one x⁻¹ with h' | h' <;> rw [h, h'] <;> rw [h, h'] at h1 <;>
+          omega
+    have h2 : (F ∣[(1 : ℤ)] x) ∣[(1 : ℤ)] x⁻¹ = ((chi3 x : ℂ) • F) ∣[(1 : ℤ)] x⁻¹ := by
+      rw [hpx]
+    rw [← SlashAction.slash_mul, mul_inv_cancel, SlashAction.slash_one,
+      ModularForm.SL_smul_slash] at h2
+    have h3 := congrArg (fun G => (chi3 x : ℂ) • G) h2
+    simp only [smul_smul] at h3
+    rw [show ((chi3 x : ℂ) * (chi3 x : ℂ)) = ((chi3 x * chi3 x : ℤ) : ℂ) by push_cast; ring,
+      chi3_mul_self] at h3
+    rw [hchi]
+    simpa using h3.symm
+
+theorem slash_eq_self_of_mem_Gamma1
+    (hT : F ∣[(1 : ℤ)] ModularGroup.T = F) (hU : F ∣[(1 : ℤ)] U₃ = F)
+    {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma1 3) :
+    F ∣[(1 : ℤ)] γ = F := by
+  rw [slash_eq_chi3_smul F hT hU (Gamma1_in_Gamma0 3 hγ), chi3_eq_one_of_mem_Gamma1 hγ]
+  simp
+
+end Sweep
+
+theorem eq_zero_of_slashInvariant_gamma0
+    (F : ℍ → ℂ) (h : ∀ γ ∈ Gamma0 3, F ∣[(1 : ℤ)] γ = F) : F = 0 := by
+  have h1 : ((chi3 (-1 : SL(2, ℤ)) : ℤ) : ℂ) • F = F :=
+    (slash_neg_one F).symm.trans (h (-1) neg_one_mem_gamma0_three)
+  rw [chi3_neg_one] at h1
+  ext τ
+  have h2 : ((-1 : ℤ) : ℂ) * F τ = F τ := by
+    have := congrFun h1 τ
+    simpa [Pi.smul_apply, smul_eq_mul] using this
+  have h3 : (2 : ℂ) * F τ = 0 := by push_cast at h2; linear_combination -h2
+  simpa [two_ne_zero] using mul_eq_zero.mp h3
+
+section Packaging
+
+def slashInvariantForm_of_T_U (F : ℍ → ℂ)
+    (hT : F ∣[(1 : ℤ)] ModularGroup.T = F) (hU : F ∣[(1 : ℤ)] U₃ = F) :
+    SlashInvariantForm (Gamma1 3) 1 where
+  toFun := F
+  slash_action_eq' := by
+    rintro γ ⟨δ, hδ, rfl⟩
+    exact slash_eq_self_of_mem_Gamma1 F hT hU hδ
+
+@[scoped simp] lemma coe_slashInvariantForm_of_T_U (F : ℍ → ℂ)
+    (hT : F ∣[(1 : ℤ)] ModularGroup.T = F) (hU : F ∣[(1 : ℤ)] U₃ = F) :
+    ⇑(slashInvariantForm_of_T_U F hT hU) = F := rfl
+
+theorem e1Chi3IsModular_of_analytic_inputs (F : ℍ → ℂ)
+    (hT : F ∣[(1 : ℤ)] ModularGroup.T = F) (hU : F ∣[(1 : ℤ)] U₃ = F)
+    (hholo : MDiff F)
+    (hbdd : ∀ c : OnePoint ℝ, IsCusp c ((Gamma1 3 : Subgroup SL(2, ℤ)) :
+      Subgroup (GL (Fin 2) ℝ)) → c.IsBoundedAt F 1)
+    (hq : ∀ z : ℍ, F z = ∑' n : ℕ,
+      ((PowerSeries.coeff n FLT.EisensteinWeightOne.e1Chi3 : ℤ) : ℂ) *
+        Complex.exp (2 * (Real.pi : ℂ) * Complex.I * (n : ℂ) * (z : ℂ))) :
+    FLT.EisensteinWeightOne.E1Chi3IsModular := by
+  exact ⟨{ slashInvariantForm_of_T_U F hT hU with
+            holo' := hholo
+            bdd_at_cusps' := fun {c} hc => hbdd c hc }, fun z => hq z⟩
+
+end Packaging
+end FLT.AnalyticCore
+end File_FLT_AnalyticCore_TwoGeneratorSweep
+
+section File_FLT_AnalyticCore_EisensteinModularityAssembly
+
+open Complex Real Matrix CongruenceSubgroup Subgroup ModularForm UpperHalfPlane
+open FLT.AnalyticCore.LatticeSum FLT.EisensteinWeightOne
+open scoped MatrixGroups ModularForm Manifold
+
+namespace FLT
+namespace AnalyticCore
+
+noncomputable section
+
+lemma latticeTerm_eq_hexThetaTerm (τ : ℂ) (v : ℤ × ℤ) :
+    latticeTerm τ v = hexThetaTerm τ v := by
+  unfold latticeTerm hexThetaTerm
+  congr 1
+  have h : ((hexFormNat v : ℤ) : ℂ) = (v.1 : ℂ) ^ 2 + (v.1 : ℂ) * (v.2 : ℂ) + (v.2 : ℂ) ^ 2 := by
+    rw [coe_hexFormNat]
+    unfold hexForm
+    push_cast
+    ring
+  push_cast at h
+  rw [h]
+  ring
+
+theorem latticeSum_eq_hexTheta (τ : ℂ) : latticeSum τ = hexTheta τ :=
+  tsum_congr fun v => latticeTerm_eq_hexThetaTerm τ v
+
+def hexThetaH : ℍ → ℂ := fun τ => latticeSum (τ : ℂ)
+
+@[scoped simp] lemma hexThetaH_apply (τ : ℍ) : hexThetaH τ = latticeSum (τ : ℂ) := rfl
+
+lemma hexThetaH_eq_hexTheta (τ : ℍ) : hexThetaH τ = hexTheta (τ : ℂ) :=
+  latticeSum_eq_hexTheta _
+
+lemma hexThetaTerm_add_one (σ : ℂ) (v : ℤ × ℤ) :
+    hexThetaTerm (σ + 1) v = hexThetaTerm σ v := by
+  rw [← latticeTerm_eq_hexThetaTerm, ← latticeTerm_eq_hexThetaTerm]
+  unfold latticeTerm
+  rw [show 2 * (π : ℂ) * Complex.I * (hexFormNat v : ℂ) * (σ + 1)
+      = 2 * (π : ℂ) * Complex.I * (hexFormNat v : ℂ) * σ
+        + (hexFormNat v : ℂ) * (2 * (π : ℂ) * Complex.I) by ring,
+    Complex.exp_add, Complex.exp_nat_mul_two_pi_mul_I, mul_one]
+
+theorem hexTheta_add_one (σ : ℂ) : hexTheta (σ + 1) = hexTheta σ :=
+  tsum_congr fun v => hexThetaTerm_add_one σ v
+
+theorem hexThetaH_slash_T : hexThetaH ∣[(1 : ℤ)] ModularGroup.T = hexThetaH := by
+  funext z
+  refine (slash_action_eq'_iff 1 hexThetaH ModularGroup.T z).mpr ?_
+  rw [show ModularGroup.T 1 0 = 0 from rfl, show ModularGroup.T 1 1 = 1 from rfl,
+    modular_T_smul]
+  simp only [Int.cast_zero, Int.cast_one, zero_mul, zero_add, zpow_one, one_mul]
+  change latticeSum (((1 : ℝ) +ᵥ z : ℍ) : ℂ) = latticeSum (z : ℂ)
+  rw [UpperHalfPlane.coe_vadd, latticeSum_eq_hexTheta, latticeSum_eq_hexTheta,
+    Complex.ofReal_one, add_comm, hexTheta_add_one]
+
+lemma sqrt_three_mul_sqrt_three : ((Real.sqrt 3 : ℝ) : ℂ) * ((Real.sqrt 3 : ℝ) : ℂ) = 3 := by
+  rw [← Complex.ofReal_mul, Real.mul_self_sqrt (by norm_num : (0 : ℝ) ≤ 3)]
+  norm_num
+
+lemma U_denom_ne_zero {z : ℂ} (hz : 0 < z.im) : (-3 : ℂ) * z + 1 ≠ 0 := by
+  intro h
+  have him : ((-3 : ℂ) * z + 1).im = -3 * z.im := by
+    simp [Complex.add_im, Complex.mul_im]
+  rw [h] at him
+  simp only [Complex.zero_im] at him
+  nlinarith
+
+lemma U_smul_eq_fricke_translate_fricke {z : ℂ} (hz : 0 < z.im) :
+    z / ((-3) * z + 1) = -1 / (3 * (-1 / (3 * z) + 1)) := by
+  have hz0 : z ≠ 0 := ne_zero_of_im_pos hz
+  have hden : (-3 : ℂ) * z + 1 ≠ 0 := U_denom_ne_zero hz
+  have h1 : (3 : ℂ) * (-1 / (3 * z) + 1) = (3 * z - 1) / z := by
+    field_simp
+    ring
+  have h2 : ((3 : ℂ) * z - 1) / z ≠ 0 := by
+    refine div_ne_zero (fun h => hden ?_) hz0
+    linear_combination -h
+  rw [h1, div_eq_div_iff hden h2, mul_div_assoc', div_eq_iff hz0]
+  ring
+
+lemma fricke_double_multiplier {z : ℂ} (hz : 0 < z.im) :
+    -Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * (-1 / (3 * z) + 1)
+      * (-Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * z) = (-3) * z + 1 := by
+  have hz0 : z ≠ 0 := ne_zero_of_im_pos hz
+  have key : (-1 / (3 * z) + 1) * z = z - 1 / 3 := by
+    field_simp
+    ring
+  calc -Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * (-1 / (3 * z) + 1)
+        * (-Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * z)
+      = (Complex.I * Complex.I) * (((Real.sqrt 3 : ℝ) : ℂ) * ((Real.sqrt 3 : ℝ) : ℂ))
+          * ((-1 / (3 * z) + 1) * z) := by ring
+    _ = (-1) * 3 * (z - 1 / 3) := by rw [Complex.I_mul_I, sqrt_three_mul_sqrt_three, key]
+    _ = (-3) * z + 1 := by ring
+
+theorem hexTheta_U_law {z : ℂ} (hz : 0 < z.im) :
+    hexTheta (z / ((-3) * z + 1)) = ((-3) * z + 1) * hexTheta z := by
+  have hσ : 0 < (-1 / (3 * z)).im := im_neg_one_div_three_mul_pos hz
+  have hσ1 : 0 < (-1 / (3 * z) + 1).im := by
+    rwa [Complex.add_im, Complex.one_im, add_zero]
+  calc hexTheta (z / ((-3) * z + 1))
+      = hexTheta (-1 / (3 * (-1 / (3 * z) + 1))) := by
+        rw [U_smul_eq_fricke_translate_fricke hz]
+    _ = -Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * (-1 / (3 * z) + 1)
+          * hexTheta (-1 / (3 * z) + 1) := hexTheta_fricke hσ1
+    _ = -Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * (-1 / (3 * z) + 1)
+          * hexTheta (-1 / (3 * z)) := by rw [hexTheta_add_one]
+    _ = -Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * (-1 / (3 * z) + 1)
+          * (-Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * z * hexTheta z) := by
+        rw [hexTheta_fricke hz]
+    _ = ((-3) * z + 1) * hexTheta z := by
+        rw [show -Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * (-1 / (3 * z) + 1)
+              * (-Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * z * hexTheta z)
+            = -Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * (-1 / (3 * z) + 1)
+              * (-Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * z) * hexTheta z by ring,
+          fricke_double_multiplier hz]
+
+lemma coe_U_smul (z : ℍ) : ((U₃ • z : ℍ) : ℂ) = (z : ℂ) / ((-3) * (z : ℂ) + 1) := by
+  rw [UpperHalfPlane.coe_specialLinearGroup_apply]
+  simp only [show U₃ 0 0 = 1 from rfl, show U₃ 0 1 = 0 from rfl,
+    show U₃ 1 0 = -3 from rfl, show U₃ 1 1 = 1 from rfl, eq_intCast]
+  push_cast
+  rw [one_mul, add_zero]
+
+theorem hexThetaH_slash_U : hexThetaH ∣[(1 : ℤ)] U₃ = hexThetaH := by
+  funext z
+  refine (slash_action_eq'_iff 1 hexThetaH U₃ z).mpr ?_
+  have hz : 0 < (z : ℂ).im := by rw [UpperHalfPlane.coe_im]; exact z.im_pos
+  rw [U₃_one_zero, U₃_one_one]
+  push_cast
+  rw [zpow_one]
+  change latticeSum ((U₃ • z : ℍ) : ℂ) = _ * latticeSum (z : ℂ)
+  rw [coe_U_smul, latticeSum_eq_hexTheta, latticeSum_eq_hexTheta, hexTheta_U_law hz]
+
+def thetaBound : ℝ :=
+  ∑' v : ℤ × ℤ, Real.exp (-(π * (v.1 : ℝ) ^ 2)) * Real.exp (-(π * (v.2 : ℝ) ^ 2))
+
+lemma thetaBound_nonneg : 0 ≤ thetaBound :=
+  tsum_nonneg fun _ => mul_nonneg (Real.exp_pos _).le (Real.exp_pos _).le
+
+theorem norm_latticeSum_le_of_one_le_im {τ : ℂ} (hτ : 1 ≤ τ.im) :
+    ‖latticeSum τ‖ ≤ thetaBound := by
+  have hτ0 : 0 < τ.im := lt_of_lt_of_le one_pos hτ
+  have hdom : ∀ v : ℤ × ℤ, ‖latticeTerm τ v‖
+      ≤ Real.exp (-(π * (v.1 : ℝ) ^ 2)) * Real.exp (-(π * (v.2 : ℝ) ^ 2)) := by
+    intro v
+    have h := norm_latticeTerm_le_of_le_im one_pos hτ v
+    simpa only [mul_one, one_mul] using h
+  have hgauss : Summable fun v : ℤ × ℤ =>
+      Real.exp (-(π * (v.1 : ℝ) ^ 2)) * Real.exp (-(π * (v.2 : ℝ) ^ 2)) := by
+    simpa only [mul_one, one_mul] using summable_gaussian_prod one_pos
+  have hsum_norm : Summable fun v : ℤ × ℤ => ‖latticeTerm τ v‖ :=
+    Summable.of_nonneg_of_le (fun _ => norm_nonneg _) hdom hgauss
+  calc ‖latticeSum τ‖ ≤ ∑' v : ℤ × ℤ, ‖latticeTerm τ v‖ := norm_tsum_le_tsum_norm hsum_norm
+    _ ≤ ∑' v : ℤ × ℤ, Real.exp (-(π * (v.1 : ℝ) ^ 2)) * Real.exp (-(π * (v.2 : ℝ) ^ 2)) :=
+        hsum_norm.tsum_le_tsum hdom hgauss
+    _ = thetaBound := rfl
+
+theorem isBoundedAtImInfty_hexThetaH : IsBoundedAtImInfty hexThetaH := by
+  refine UpperHalfPlane.isBoundedAtImInfty_iff.mpr ⟨thetaBound, 1, fun z hz => ?_⟩
+  exact norm_latticeSum_le_of_one_le_im (by rwa [UpperHalfPlane.coe_im])
+
+lemma im_add_natCast_div_three (w : ℂ) (n : ℕ) : ((w + (n : ℂ)) / 3).im = w.im / 3 := by
+  rw [show (3 : ℂ) = ((3 : ℝ) : ℂ) by norm_num, Complex.div_ofReal_im]
+  simp [Complex.add_im]
+
+lemma norm_neg_I_div_sqrt_three_le_one :
+    ‖(-Complex.I / ((Real.sqrt 3 : ℝ) : ℂ))‖ ≤ 1 := by
+  have h3 : (1 : ℝ) ≤ Real.sqrt 3 := by
+    nlinarith [Real.sq_sqrt (show (0 : ℝ) ≤ 3 by norm_num), Real.sqrt_nonneg 3]
+  rw [norm_div, norm_neg, Complex.norm_I, Complex.norm_real, Real.norm_eq_abs,
+    abs_of_nonneg (Real.sqrt_nonneg 3), div_le_one (by linarith)]
+  exact h3
+
+theorem hexThetaH_slash_repOfLabel_apply (k : ZMod 3) (z : ℍ) :
+    (hexThetaH ∣[(1 : ℤ)] Gamma0Three.repOfLabel (some k)) z
+      = (-Complex.I / ((Real.sqrt 3 : ℝ) : ℂ)) * hexTheta (((z : ℂ) + (k.val : ℂ)) / 3) := by
+  have hz : 0 < (z : ℂ).im := by rw [UpperHalfPlane.coe_im]; exact z.im_pos
+  have hden_im : ((z : ℂ) + (k.val : ℂ)).im = (z : ℂ).im := by
+    simp only [Complex.add_im, Complex.natCast_im, add_zero]
+  have hden_ne : (z : ℂ) + (k.val : ℂ) ≠ 0 := by
+    intro h
+    rw [← Complex.zero_im, ← h, hden_im] at hz
+    exact lt_irrefl _ hz
+  have hσ_im : 0 < (((z : ℂ) + (k.val : ℂ)) / 3).im := by
+    rw [im_add_natCast_div_three]
+    positivity
+  have hsmul : ((Gamma0Three.repOfLabel (some k) • z : ℍ) : ℂ)
+      = -1 / ((z : ℂ) + (k.val : ℂ)) := by
+    rw [UpperHalfPlane.coe_specialLinearGroup_apply]
+    simp only [show Gamma0Three.repOfLabel (some k) 0 0 = 0 from rfl,
+      show Gamma0Three.repOfLabel (some k) 0 1 = -1 from rfl,
+      show Gamma0Three.repOfLabel (some k) 1 0 = 1 from rfl,
+      show Gamma0Three.repOfLabel (some k) 1 1 = (k.val : ℤ) from rfl, eq_intCast]
+    push_cast
+    rw [zero_mul, zero_add, one_mul]
+  have hdenom : denom (Gamma0Three.repOfLabel (some k)) z = (z : ℂ) + (k.val : ℂ) := by
+    rw [ModularGroup.denom_apply,
+      show Gamma0Three.repOfLabel (some k) 1 0 = 1 from rfl,
+      show Gamma0Three.repOfLabel (some k) 1 1 = (k.val : ℤ) from rfl]
+    push_cast
+    rw [one_mul]
+  have hfricke : hexTheta (-1 / ((z : ℂ) + (k.val : ℂ)))
+      = -Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * (((z : ℂ) + (k.val : ℂ)) / 3)
+        * hexTheta (((z : ℂ) + (k.val : ℂ)) / 3) := by
+    have h := hexTheta_fricke hσ_im
+    rw [show (3 : ℂ) * (((z : ℂ) + (k.val : ℂ)) / 3) = (z : ℂ) + (k.val : ℂ) by ring] at h
+    exact h
+  have hmul : -Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * (((z : ℂ) + (k.val : ℂ)) / 3)
+      * ((z : ℂ) + (k.val : ℂ))⁻¹ = -Complex.I / ((Real.sqrt 3 : ℝ) : ℂ) := by
+    rw [eq_div_iff sqrt_three_ne_zero,
+      show -Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * (((z : ℂ) + (k.val : ℂ)) / 3)
+          * ((z : ℂ) + (k.val : ℂ))⁻¹ * ((Real.sqrt 3 : ℝ) : ℂ)
+        = -Complex.I * (((Real.sqrt 3 : ℝ) : ℂ) * ((Real.sqrt 3 : ℝ) : ℂ))
+          * (((z : ℂ) + (k.val : ℂ)) * ((z : ℂ) + (k.val : ℂ))⁻¹) / 3 by ring,
+      sqrt_three_mul_sqrt_three, mul_inv_cancel₀ hden_ne]
+    ring
+  rw [ModularForm.SL_slash_apply, hdenom, _root_.zpow_neg, zpow_one]
+  change latticeSum ((Gamma0Three.repOfLabel (some k) • z : ℍ) : ℂ) * _ = _
+  rw [hsmul, latticeSum_eq_hexTheta, hfricke]
+  linear_combination (hexTheta (((z : ℂ) + (k.val : ℂ)) / 3)) * hmul
+
+theorem isBoundedAtImInfty_hexThetaH_slash (γ : SL(2, ℤ)) :
+    IsBoundedAtImInfty (hexThetaH ∣[(1 : ℤ)] γ) := by
+  set r := Gamma0Three.repOfLabel (Gamma0Three.label γ) with hr
+  have hδ : γ * r⁻¹ ∈ Gamma0 3 :=
+    (Gamma0Three.mul_inv_repOfLabel_mem_iff γ (Gamma0Three.label γ)).mpr rfl
+  have hfact : γ = γ * r⁻¹ * r := (inv_mul_cancel_right γ r).symm
+  rw [hfact, SlashAction.slash_mul,
+    slash_eq_chi3_smul hexThetaH hexThetaH_slash_T hexThetaH_slash_U hδ,
+    ModularForm.SL_smul_slash]
+  refine Filter.BoundedAtFilter.smul _ ?_
+  rcases hcase : Gamma0Three.label γ with _ | k
+  · rw [hr, hcase, Gamma0Three.repOfLabel_none, SlashAction.slash_one]
+    exact isBoundedAtImInfty_hexThetaH
+  · rw [hr, hcase]
+    refine UpperHalfPlane.isBoundedAtImInfty_iff.mpr ⟨thetaBound, 3, fun z hz => ?_⟩
+    rw [hexThetaH_slash_repOfLabel_apply k z, norm_mul]
+    have him : 1 ≤ (((z : ℂ) + (k.val : ℂ)) / 3).im := by
+      rw [im_add_natCast_div_three, UpperHalfPlane.coe_im, le_div_iff₀ (by norm_num)]
+      linarith
+    have hbound : ‖hexTheta (((z : ℂ) + (k.val : ℂ)) / 3)‖ ≤ thetaBound := by
+      rw [← latticeSum_eq_hexTheta]
+      exact norm_latticeSum_le_of_one_le_im him
+    calc ‖(-Complex.I / ((Real.sqrt 3 : ℝ) : ℂ))‖ * ‖hexTheta (((z : ℂ) + (k.val : ℂ)) / 3)‖
+        ≤ 1 * thetaBound :=
+          mul_le_mul norm_neg_I_div_sqrt_three_le_one hbound (norm_nonneg _) zero_le_one
+      _ = thetaBound := one_mul _
+
+theorem hexThetaH_isBoundedAt_cusp (c : OnePoint ℝ)
+    (hc : IsCusp c ((Gamma1 3 : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ))) :
+    c.IsBoundedAt hexThetaH 1 := by
+  rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z] at hc
+  obtain ⟨γ, rfl⟩ := isCusp_SL2Z_iff'.mp hc
+  refine (OnePoint.isBoundedAt_iff rfl).mpr ?_
+  exact isBoundedAtImInfty_hexThetaH_slash γ
+
+theorem e1Chi3IsModular_of_mdiff_of_repCount
+    (hholo : MDiff hexThetaH) (hW1 : RepresentationCountAgrees) :
+    E1Chi3IsModular :=
+  e1Chi3IsModular_of_analytic_inputs hexThetaH
+    hexThetaH_slash_T
+    hexThetaH_slash_U
+    hholo
+    (fun c hc => hexThetaH_isBoundedAt_cusp c hc)
+    (fun z => latticeSum_eq_e1Chi3_qSeries hW1 z)
+
+theorem hexThetaH_ne_zero : hexThetaH ≠ 0 := by
+  intro h
+  have hpt : hexThetaH ⟨frickeFixedPoint, frickeFixedPoint_im_pos⟩ = 0 := by rw [h]; rfl
+  rw [hexThetaH_apply, latticeSum_eq_hexTheta] at hpt
+  exact hexTheta_frickeFixedPoint_ne_zero hpt
+
+theorem not_hexTheta_U_law_weight_zero :
+    ¬ (∀ z : ℂ, 0 < z.im → hexTheta (z / ((-3) * z + 1)) = hexTheta z) := by
+  intro hcon
+  have h0 : 0 < frickeFixedPoint.im := frickeFixedPoint_im_pos
+  have h1 := hcon frickeFixedPoint h0
+  have h2 := hexTheta_U_law h0
+  rw [h1] at h2
+  have h3 : (-3 : ℂ) * frickeFixedPoint * hexTheta frickeFixedPoint = 0 := by
+    linear_combination -h2
+  rcases mul_eq_zero.mp h3 with h4 | h4
+  · exact mul_ne_zero (by norm_num : (-3 : ℂ) ≠ 0) (ne_zero_of_im_pos h0) h4
+  · exact hexTheta_frickeFixedPoint_ne_zero h4
+
+theorem hexThetaH_slash_TU :
+    hexThetaH ∣[(1 : ℤ)] (ModularGroup.T * U₃) = hexThetaH := by
+  rw [SlashAction.slash_mul, hexThetaH_slash_T, hexThetaH_slash_U]
+
+end
+end FLT.AnalyticCore
+end File_FLT_AnalyticCore_EisensteinModularityAssembly
+
+section File_FLT_AnalyticCore_ThetaHolomorphy
+
+open Complex Real Filter
+open FLT.AnalyticCore.LatticeSum FLT.EisensteinWeightOne
+open scoped Manifold Topology
+
+namespace FLT
+namespace AnalyticCore
+
+noncomputable section
+
+lemma differentiable_latticeTerm (v : ℤ × ℤ) :
+    Differentiable ℂ fun τ : ℂ => latticeTerm τ v := by
+  unfold latticeTerm
+  fun_prop
+
+def thetaBoundAt (T : ℝ) : ℝ :=
+  ∑' v : ℤ × ℤ, Real.exp (-(π * T * (v.1 : ℝ) ^ 2)) * Real.exp (-(π * T * (v.2 : ℝ) ^ 2))
+
+theorem norm_latticeSum_le_of_le_im {T : ℝ} (hT : 0 < T) {τ : ℂ} (hτ : T ≤ τ.im) :
+    ‖latticeSum τ‖ ≤ thetaBoundAt T := by
+  have hdom : ∀ v : ℤ × ℤ, ‖latticeTerm τ v‖
+      ≤ Real.exp (-(π * T * (v.1 : ℝ) ^ 2)) * Real.exp (-(π * T * (v.2 : ℝ) ^ 2)) :=
+    fun v => norm_latticeTerm_le_of_le_im hT hτ v
+  have hgauss : Summable fun v : ℤ × ℤ =>
+      Real.exp (-(π * T * (v.1 : ℝ) ^ 2)) * Real.exp (-(π * T * (v.2 : ℝ) ^ 2)) :=
+    summable_gaussian_prod hT
+  have hsum_norm : Summable fun v : ℤ × ℤ => ‖latticeTerm τ v‖ :=
+    Summable.of_nonneg_of_le (fun _ => norm_nonneg _) hdom hgauss
+  calc ‖latticeSum τ‖ ≤ ∑' v : ℤ × ℤ, ‖latticeTerm τ v‖ := norm_tsum_le_tsum_norm hsum_norm
+    _ ≤ ∑' v : ℤ × ℤ, Real.exp (-(π * T * (v.1 : ℝ) ^ 2))
+          * Real.exp (-(π * T * (v.2 : ℝ) ^ 2)) :=
+        hsum_norm.tsum_le_tsum hdom hgauss
+    _ = thetaBoundAt T := rfl
+
+theorem thetaBoundAt_one_eq : thetaBoundAt 1 = thetaBound := by
+  unfold thetaBoundAt thetaBound
+  simp only [mul_one]
+
+lemma isOpen_lt_im (T : ℝ) : IsOpen {z : ℂ | T < z.im} :=
+  isOpen_lt continuous_const Complex.continuous_im
+
+theorem differentiableOn_latticeSum_of_lt_im {T : ℝ} (hT : 0 < T) :
+    DifferentiableOn ℂ latticeSum {z : ℂ | T < z.im} := by
+  have h := Complex.differentiableOn_tsum_of_summable_norm
+    (F := fun (v : ℤ × ℤ) (τ : ℂ) => latticeTerm τ v)
+    (summable_gaussian_prod hT)
+    (fun v => (differentiable_latticeTerm v).differentiableOn)
+    (isOpen_lt_im T)
+    (fun v w hw => norm_latticeTerm_le_of_le_im hT (le_of_lt hw) v)
+  exact h
+
+theorem differentiableAt_latticeSum {τ : ℂ} (hτ : 0 < τ.im) :
+    DifferentiableAt ℂ latticeSum τ := by
+  have hT : (0 : ℝ) < τ.im / 2 := by positivity
+  have hmem : τ ∈ {z : ℂ | τ.im / 2 < z.im} := by
+    simp only [Set.mem_ofPred_eq]
+    linarith
+  exact (differentiableOn_latticeSum_of_lt_im hT).differentiableAt
+    ((isOpen_lt_im _).mem_nhds hmem)
+
+theorem differentiableOn_latticeSum :
+    DifferentiableOn ℂ latticeSum {z : ℂ | 0 < z.im} :=
+  fun _ hz => (differentiableAt_latticeSum hz).differentiableWithinAt
+
+theorem mdifferentiable_hexThetaH : MDiff hexThetaH := by
+  rw [UpperHalfPlane.mdifferentiable_iff]
+  refine DifferentiableOn.congr (f := latticeSum) differentiableOn_latticeSum
+    (fun z hz => ?_)
+  simp [hexThetaH, Function.comp_apply, UpperHalfPlane.ofComplex_apply_of_im_pos hz]
+
+theorem e1Chi3IsModular_of_repCount (hW1 : RepresentationCountAgrees) :
+    E1Chi3IsModular :=
+  e1Chi3IsModular_of_mdiff_of_repCount mdifferentiable_hexThetaH hW1
+
+theorem differentiableAt_latticeSum_I : DifferentiableAt ℂ latticeSum Complex.I :=
+  differentiableAt_latticeSum (by simp)
+
+theorem not_summable_gaussian_prod_zero :
+    ¬ Summable (fun v : ℤ × ℤ =>
+      Real.exp (-(π * 0 * (v.1 : ℝ) ^ 2)) * Real.exp (-(π * 0 * (v.2 : ℝ) ^ 2))) := by
+  have h : (fun v : ℤ × ℤ =>
+      Real.exp (-(π * 0 * (v.1 : ℝ) ^ 2)) * Real.exp (-(π * 0 * (v.2 : ℝ) ^ 2)))
+      = fun _ => (1 : ℝ) := by
+    funext v
+    simp
+  rw [h, summable_const_iff]
+  exact one_ne_zero
+
+theorem continuous_hexThetaH : Continuous hexThetaH :=
+  mdifferentiable_hexThetaH.continuous
+
+end
+end FLT.AnalyticCore
+end File_FLT_AnalyticCore_ThetaHolomorphy
+
+section File_FLT_AnalyticCore_RepresentationNumberIdentity
+
+namespace FLT
+namespace AnalyticCore
+
+open Finset FLT.EisensteinWeightOne
+
+private def _root_.S17E1.FLT.AnalyticCore.hexForm (x y : ℤ) : ℤ := x * x + x * y + y * y
+
+p2m_export "S17E1.FLT.AnalyticCore" "hexForm"
+
+theorem four_mul_hexForm (x y : ℤ) :
+    4 * hexForm x y = (2 * x + y) ^ 2 + 3 * y ^ 2 := by
+  unfold hexForm; ring
+
+theorem hexForm_nonneg (x y : ℤ) : 0 ≤ hexForm x y := by
+  nlinarith [four_mul_hexForm x y, sq_nonneg (2 * x + y), sq_nonneg y]
+
+theorem hexForm_eq_zero_iff {x y : ℤ} : hexForm x y = 0 ↔ x = 0 ∧ y = 0 := by
+  constructor
+  · intro h
+    have h4 := four_mul_hexForm x y
+    rw [h, mul_zero] at h4
+    have hy : y = 0 := by nlinarith [sq_nonneg (2 * x + y), sq_nonneg y]
+    have hx : x = 0 := by nlinarith [sq_nonneg (2 * x + y), sq_nonneg y]
+    exact ⟨hx, hy⟩
+  · rintro ⟨rfl, rfl⟩
+    rfl
+
+theorem hexForm_swap (x y : ℤ) : hexForm y x = hexForm x y := by
+  unfold hexForm; ring
+
+theorem hexForm_neg (x y : ℤ) : hexForm (-x) (-y) = hexForm x y := by
+  unfold hexForm; ring
+
+noncomputable def reprBox (n : ℕ) : Finset (ℤ × ℤ) :=
+  Finset.Icc (-(n : ℤ)) (n : ℤ) ×ˢ Finset.Icc (-(n : ℤ)) (n : ℤ)
+
+noncomputable def reprSols (n : ℕ) : Finset (ℤ × ℤ) :=
+  (reprBox n).filter fun p => hexForm p.1 p.2 = (n : ℤ)
+
+noncomputable def reprCount (n : ℕ) : ℕ := (reprSols n).card
+
+theorem snd_abs_le_of_hexForm_eq {x y : ℤ} {n : ℕ} (h : hexForm x y = (n : ℤ)) :
+    -(n : ℤ) ≤ y ∧ y ≤ (n : ℤ) := by
+  have h4 : (2 * x + y) ^ 2 + 3 * y ^ 2 = 4 * (n : ℤ) := by
+    rw [← four_mul_hexForm, h]
+  have h3 : 3 * y ^ 2 ≤ 4 * (n : ℤ) := by nlinarith [sq_nonneg (2 * x + y)]
+  have hn : (0 : ℤ) ≤ (n : ℤ) := Int.natCast_nonneg n
+  constructor
+  · nlinarith [sq_nonneg (y + (n : ℤ)), sq_nonneg y]
+  · nlinarith [sq_nonneg (y - (n : ℤ)), sq_nonneg y]
+
+theorem mem_reprBox_of_hexForm_eq {x y : ℤ} {n : ℕ} (h : hexForm x y = (n : ℤ)) :
+    (x, y) ∈ reprBox n := by
+  have hy := snd_abs_le_of_hexForm_eq h
+  have hx := snd_abs_le_of_hexForm_eq (x := y) (y := x) (by rwa [hexForm_swap])
+  simp only [reprBox, Finset.mem_product, Finset.mem_Icc]
+  exact ⟨⟨hx.1, hx.2⟩, ⟨hy.1, hy.2⟩⟩
+
+theorem mem_reprSols_iff {p : ℤ × ℤ} {n : ℕ} :
+    p ∈ reprSols n ↔ hexForm p.1 p.2 = (n : ℤ) := by
+  constructor
+  · intro hp
+    exact (Finset.mem_filter.mp hp).2
+  · intro hp
+    exact Finset.mem_filter.mpr ⟨by simpa using mem_reprBox_of_hexForm_eq hp, hp⟩
+
+def unitRot (p : ℤ × ℤ) : ℤ × ℤ := (-p.2, p.1 + p.2)
+
+theorem hexForm_unitRot (p : ℤ × ℤ) :
+    hexForm (unitRot p).1 (unitRot p).2 = hexForm p.1 p.2 := by
+  obtain ⟨x, y⟩ := p
+  simp only [unitRot, hexForm]
+  ring
+
+theorem unitRot_sq (p : ℤ × ℤ) : unitRot (unitRot p) = (-p.1 - p.2, p.1) := by
+  obtain ⟨x, y⟩ := p
+  simp only [unitRot, Prod.mk.injEq]
+  exact ⟨by ring, by ring⟩
+
+theorem unitRot_cube (p : ℤ × ℤ) :
+    unitRot (unitRot (unitRot p)) = (-p.1, -p.2) := by
+  obtain ⟨x, y⟩ := p
+  simp only [unitRot, Prod.mk.injEq]
+  exact ⟨by ring, by ring⟩
+
+theorem unitRot_six_iterate (p : ℤ × ℤ) :
+    unitRot (unitRot (unitRot (unitRot (unitRot (unitRot p))))) = p := by
+  obtain ⟨x, y⟩ := p
+  simp only [unitRot, Prod.mk.injEq]
+  exact ⟨by ring, by ring⟩
+
+theorem unitRot_injective : Function.Injective unitRot := by
+  intro p q h
+  obtain ⟨x, y⟩ := p
+  obtain ⟨a, b⟩ := q
+  simp only [unitRot, Prod.mk.injEq] at h
+  exact Prod.ext (by omega) (by omega)
+
+theorem eq_zero_of_unitRot_eq_self {p : ℤ × ℤ} (h : unitRot p = p) : p = (0, 0) := by
+  obtain ⟨x, y⟩ := p
+  simp only [unitRot, Prod.mk.injEq] at h ⊢
+  omega
+
+theorem eq_zero_of_unitRot_sq_eq_self {p : ℤ × ℤ} (h : unitRot (unitRot p) = p) :
+    p = (0, 0) := by
+  obtain ⟨x, y⟩ := p
+  rw [unitRot_sq] at h
+  simp only [Prod.mk.injEq] at h ⊢
+  omega
+
+theorem eq_zero_of_unitRot_cube_eq_self {p : ℤ × ℤ}
+    (h : unitRot (unitRot (unitRot p)) = p) : p = (0, 0) := by
+  obtain ⟨x, y⟩ := p
+  rw [unitRot_cube] at h
+  simp only [Prod.mk.injEq] at h ⊢
+  omega
+
+def unitRotOrbit (p : ℤ × ℤ) : Finset (ℤ × ℤ) :=
+  {p, unitRot p, unitRot (unitRot p), unitRot (unitRot (unitRot p)),
+    unitRot (unitRot (unitRot (unitRot p))),
+    unitRot (unitRot (unitRot (unitRot (unitRot p))))}
+
+theorem mem_unitRotOrbit_self (p : ℤ × ℤ) : p ∈ unitRotOrbit p := by
+  simp [unitRotOrbit]
+
+theorem unitRot_mem_unitRotOrbit {p q : ℤ × ℤ} (hq : q ∈ unitRotOrbit p) :
+    unitRot q ∈ unitRotOrbit p := by
+  simp only [unitRotOrbit, Finset.mem_insert, Finset.mem_singleton] at hq ⊢
+  rcases hq with rfl | rfl | rfl | rfl | rfl | rfl
+  · tauto
+  · tauto
+  · tauto
+  · tauto
+  · tauto
+  · exact Or.inl (unitRot_six_iterate p)
+
+theorem mem_unitRotOrbit_of_unitRot_mem {p q : ℤ × ℤ} (hq : unitRot q ∈ unitRotOrbit p) :
+    q ∈ unitRotOrbit p := by
+  have h5 : ∀ r ∈ unitRotOrbit p,
+      unitRot (unitRot (unitRot (unitRot (unitRot r)))) ∈ unitRotOrbit p := fun r hr =>
+    unitRot_mem_unitRotOrbit (unitRot_mem_unitRotOrbit (unitRot_mem_unitRotOrbit
+      (unitRot_mem_unitRotOrbit (unitRot_mem_unitRotOrbit hr))))
+  have := h5 _ hq
+  rwa [unitRot_six_iterate] at this
+
+theorem card_unitRotOrbit {p : ℤ × ℤ} (hp : p ≠ (0, 0)) : (unitRotOrbit p).card = 6 := by
+  obtain ⟨x, y⟩ := p
+  have hxy : ¬(x = 0 ∧ y = 0) := by
+    intro ⟨hx, hy⟩; exact hp (by simp [hx, hy])
+  simp only [unitRotOrbit, unitRot]
+  rw [Finset.card_insert_of_notMem, Finset.card_insert_of_notMem,
+    Finset.card_insert_of_notMem, Finset.card_insert_of_notMem,
+    Finset.card_insert_of_notMem, Finset.card_singleton]
+  all_goals try simp only [Finset.mem_insert, Finset.mem_singleton, Prod.mk.injEq, not_or]
+  all_goals omega
+
+theorem six_dvd_card_of_unitRot_invariant :
+    ∀ s : Finset (ℤ × ℤ), ((0 : ℤ), (0 : ℤ)) ∉ s → (∀ p ∈ s, unitRot p ∈ s) →
+      6 ∣ s.card := by
+  intro s
+  induction s using Finset.strongInduction with
+  | _ s ih =>
+    intro h0 hinv
+    rcases s.eq_empty_or_nonempty with rfl | ⟨p, hp⟩
+    · simp
+    · have hpne : p ≠ (0, 0) := fun h => h0 (h ▸ hp)
+      have horb_sub : unitRotOrbit p ⊆ s := by
+        intro q hq
+        simp only [unitRotOrbit, Finset.mem_insert, Finset.mem_singleton] at hq
+        rcases hq with rfl | rfl | rfl | rfl | rfl | rfl
+        · exact hp
+        · exact hinv _ hp
+        · exact hinv _ (hinv _ hp)
+        · exact hinv _ (hinv _ (hinv _ hp))
+        · exact hinv _ (hinv _ (hinv _ (hinv _ hp)))
+        · exact hinv _ (hinv _ (hinv _ (hinv _ (hinv _ hp))))
+      have hssub : s \ unitRotOrbit p ⊂ s :=
+        Finset.sdiff_ssubset horb_sub ⟨p, mem_unitRotOrbit_self p⟩
+      have h0' : ((0 : ℤ), (0 : ℤ)) ∉ s \ unitRotOrbit p := fun h =>
+        h0 (Finset.mem_sdiff.mp h).1
+      have hinv' : ∀ q ∈ s \ unitRotOrbit p, unitRot q ∈ s \ unitRotOrbit p := by
+        intro q hq
+        rw [Finset.mem_sdiff] at hq ⊢
+        exact ⟨hinv _ hq.1, fun hmem => hq.2 (mem_unitRotOrbit_of_unitRot_mem hmem)⟩
+      have hrec := ih _ hssub h0' hinv'
+      have hcard : (s \ unitRotOrbit p).card + (unitRotOrbit p).card = s.card :=
+        Finset.card_sdiff_add_card_eq_card horb_sub
+      rw [card_unitRotOrbit hpne] at hcard
+      omega
+
+theorem six_dvd_reprCount {n : ℕ} (hn : n ≠ 0) : 6 ∣ reprCount n := by
+  apply six_dvd_card_of_unitRot_invariant
+  · intro h
+    have := mem_reprSols_iff.mp h
+    simp only [hexForm] at this
+    omega
+  · intro p hp
+    have hQ : hexForm (unitRot p).1 (unitRot p).2 = (n : ℤ) := by
+      rw [hexForm_unitRot]; exact mem_reprSols_iff.mp hp
+    exact mem_reprSols_iff.mpr hQ
+
+theorem reprCount_zero : reprCount 0 = 1 := by decide
+
+theorem reprCount_one : reprCount 1 = 6 := by decide
+
+theorem reprCount_two : reprCount 2 = 0 := by decide
+
+theorem reprCount_three : reprCount 3 = 6 := by decide
+
+theorem reprCount_four : reprCount 4 = 6 := by decide
+
+theorem reprCount_five : reprCount 5 = 0 := by decide
+
+theorem reprCount_six : reprCount 6 = 0 := by decide
+
+theorem reprCount_seven : reprCount 7 = 12 := by decide
+
+theorem reprCount_thirteen : reprCount 13 = 12 := by decide
+
+theorem reprCount_eq_coeff_e1Chi3_zero :
+    (reprCount 0 : ℤ) = PowerSeries.coeff 0 e1Chi3 := by
+  rw [reprCount_zero, coeff_e1Chi3]; norm_num
+
+theorem reprCount_eq_coeff_e1Chi3_one :
+    (reprCount 1 : ℤ) = PowerSeries.coeff 1 e1Chi3 := by
+  rw [reprCount_one, coeff_one_e1Chi3]; norm_num
+
+theorem reprCount_eq_coeff_e1Chi3_two :
+    (reprCount 2 : ℤ) = PowerSeries.coeff 2 e1Chi3 := by
+  rw [reprCount_two, coeff_two_e1Chi3]; norm_num
+
+theorem reprCount_eq_coeff_e1Chi3_three :
+    (reprCount 3 : ℤ) = PowerSeries.coeff 3 e1Chi3 := by
+  rw [reprCount_three, coeff_three_e1Chi3]; norm_num
+
+theorem reprCount_eq_coeff_e1Chi3_four :
+    (reprCount 4 : ℤ) = PowerSeries.coeff 4 e1Chi3 := by
+  rw [reprCount_four, coeff_four_e1Chi3]; norm_num
+
+theorem reprCount_eq_coeff_e1Chi3_seven :
+    (reprCount 7 : ℤ) = PowerSeries.coeff 7 e1Chi3 := by
+  rw [reprCount_seven, coeff_seven_e1Chi3]; norm_num
+
+theorem reprCount_eq_coeff_e1Chi3_thirteen :
+    (reprCount 13 : ℤ) = PowerSeries.coeff 13 e1Chi3 := by
+  rw [reprCount_thirteen, coeff_e1Chi3_of_ne_zero (by norm_num)]
+  have : sigmaChi 13 = 2 := by decide
+  rw [this]; norm_num
+
+def ReprCountEqCoeffE1Chi3 : Prop :=
+  ∀ n : ℕ, (reprCount n : ℤ) = PowerSeries.coeff n e1Chi3
+
+noncomputable def thetaHexQExpansion : PowerSeries ℤ :=
+  PowerSeries.mk fun n => (reprCount n : ℤ)
+
+theorem thetaHexQExpansion_eq_e1Chi3 (h : ReprCountEqCoeffE1Chi3) :
+    thetaHexQExpansion = e1Chi3 := by
+  ext n
+  rw [thetaHexQExpansion, PowerSeries.coeff_mk]
+  exact h n
+
+theorem reprCountEqCoeffE1Chi3_on_table :
+    ∀ n ∈ ({0, 1, 2, 3, 4, 7, 13} : Finset ℕ),
+      (reprCount n : ℤ) = PowerSeries.coeff n e1Chi3 := by
+  intro n hn
+  fin_cases hn
+  · exact reprCount_eq_coeff_e1Chi3_zero
+  · exact reprCount_eq_coeff_e1Chi3_one
+  · exact reprCount_eq_coeff_e1Chi3_two
+  · exact reprCount_eq_coeff_e1Chi3_three
+  · exact reprCount_eq_coeff_e1Chi3_four
+  · exact reprCount_eq_coeff_e1Chi3_seven
+  · exact reprCount_eq_coeff_e1Chi3_thirteen
+
+noncomputable def gaussianCountThree : ℕ :=
+  ((reprBox 3).filter fun p => p.1 * p.1 + p.2 * p.2 = (3 : ℤ)).card
+
+theorem gaussianCountThree_ne : gaussianCountThree ≠ reprCount 3 := by decide
+
+theorem multiplier_six_load_bearing : (reprCount 1 : ℤ) ≠ sigmaChi 1 := by
+  rw [reprCount_one, sigmaChi_one]; norm_num
+
+end FLT.AnalyticCore
+end File_FLT_AnalyticCore_RepresentationNumberIdentity
+
+section File_FLT_ModularCurve_Numerics_NuThree
+
+namespace ModularCurve
+
+noncomputable def nuThree (N : ℕ) : ℕ := Nat.card {x : ZMod N // x ^ 2 + x + 1 = 0}
+
+theorem not_sq_add_self_add_one_eq_zero_zmod_nine (y : ZMod 9) : y ^ 2 + y + 1 ≠ 0 := by
+  revert y
+  decide
+
+theorem nuThree_eq_zero_of_nine_dvd {N : ℕ} (h : 9 ∣ N) : nuThree N = 0 := by
+  have hempty : IsEmpty {x : ZMod N // x ^ 2 + x + 1 = 0} := by
+    refine ⟨fun z => ?_⟩
+    obtain ⟨x, hx⟩ := z
+    refine not_sq_add_self_add_one_eq_zero_zmod_nine (ZMod.castHom h (ZMod 9) x) ?_
+    have hx9 := congrArg (ZMod.castHom h (ZMod 9)) hx
+    simpa only [map_add, map_pow, map_one, map_zero] using hx9
+  exact @Nat.card_of_isEmpty _ hempty
+
+section Prime
+
+variable {p : ℕ}
+
+theorem sq_add_self_add_one_eq_zero_iff_orderOf_eq_three (hp : p.Prime) (hp3 : p ≠ 3)
+    (x : ZMod p) : x ^ 2 + x + 1 = 0 ↔ orderOf x = 3 := by
+  have : Fact p.Prime := ⟨hp⟩
+  have : Fact (Nat.Prime 3) := ⟨by norm_num⟩
+  constructor
+  · intro hx
+    refine orderOf_eq_prime ?_ ?_
+    · linear_combination (x - 1) * hx
+    · rintro rfl
+      have h3 : (3 : ZMod p) = 0 := by linear_combination hx
+      have hcast : ((3 : ℕ) : ZMod p) = 0 := by exact_mod_cast h3
+      have hdvd : p ∣ 3 := (CharP.cast_eq_zero_iff (ZMod p) p 3).mp hcast
+      exact hp3 ((Nat.prime_dvd_prime_iff_eq hp Nat.prime_three).mp hdvd)
+  · intro hx
+    have hx3 : x ^ 3 = 1 := by rw [← hx]; exact pow_orderOf_eq_one x
+    have hx1 : x ≠ 1 := by
+      rintro rfl
+      rw [orderOf_one] at hx
+      omega
+    have hfac : (x - 1) * (x ^ 2 + x + 1) = 0 := by linear_combination hx3
+    rcases mul_eq_zero.mp hfac with h | h
+    · exact absurd (by linear_combination h : x = 1) hx1
+    · exact h
+
+theorem sq_add_self_add_one_eq_zero_iff_of_prime (hp : p.Prime) {ζ x : ZMod p}
+    (hζ : ζ ^ 2 + ζ + 1 = 0) : x ^ 2 + x + 1 = 0 ↔ x = ζ ∨ x = -1 - ζ := by
+  have : Fact p.Prime := ⟨hp⟩
+  constructor
+  · intro hx
+    have hfac : (x - ζ) * (x + ζ + 1) = 0 := by linear_combination hx - hζ
+    rcases mul_eq_zero.mp hfac with hd | hd
+    · exact Or.inl (by linear_combination hd)
+    · exact Or.inr (by linear_combination hd)
+  · rintro (rfl | rfl)
+    · exact hζ
+    · linear_combination hζ
+
+theorem ne_neg_one_sub_of_sq_add_self_add_one_eq_zero (hp : p.Prime) (hp3 : p ≠ 3)
+    {ζ : ZMod p} (hζ : ζ ^ 2 + ζ + 1 = 0) : ζ ≠ -1 - ζ := by
+  have : Fact p.Prime := ⟨hp⟩
+  intro hcontra
+  have h3 : (3 : ZMod p) = 0 := by linear_combination 4 * hζ - (2 * ζ + 1) * hcontra
+  have hcast : ((3 : ℕ) : ZMod p) = 0 := by exact_mod_cast h3
+  have hdvd : p ∣ 3 := (CharP.cast_eq_zero_iff (ZMod p) p 3).mp hcast
+  exact hp3 ((Nat.prime_dvd_prime_iff_eq hp Nat.prime_three).mp hdvd)
+
+theorem exists_orderOf_eq_three (hp : p.Prime) (h1 : p % 3 = 1) :
+    ∃ x : ZMod p, orderOf x = 3 := by
+  have : Fact p.Prime := ⟨hp⟩
+  have : Fact (Nat.Prime 3) := ⟨by norm_num⟩
+  have hdvd : 3 ∣ Fintype.card (ZMod p)ˣ := by
+    rw [ZMod.card_units p]
+    have := hp.two_le
+    omega
+  obtain ⟨u, hu⟩ := exists_prime_orderOf_dvd_card 3 hdvd
+  exact ⟨(u : ZMod p), by rw [orderOf_units]; exact hu⟩
+
+theorem nuThree_prime (hp : p.Prime) (hp3 : p ≠ 3) :
+    nuThree p = if p % 3 = 1 then 2 else 0 := by
+  have : Fact p.Prime := ⟨hp⟩
+  by_cases h1 : p % 3 = 1
+  · rw [ite_eq_left h1]
+    obtain ⟨ζ, hζord⟩ := exists_orderOf_eq_three hp h1
+    have hζ : ζ ^ 2 + ζ + 1 = 0 :=
+      (sq_add_self_add_one_eq_zero_iff_orderOf_eq_three hp hp3 ζ).mpr hζord
+    have hζ' : (-1 - ζ) ^ 2 + (-1 - ζ) + 1 = 0 := by linear_combination hζ
+    have hne : ζ ≠ -1 - ζ := ne_neg_one_sub_of_sq_add_self_add_one_eq_zero hp hp3 hζ
+    change Nat.card {x : ZMod p // x ^ 2 + x + 1 = 0} = 2
+    rw [Nat.card_eq_two_iff]
+    refine ⟨⟨ζ, hζ⟩, ⟨-1 - ζ, hζ'⟩, ?_, ?_⟩
+    · simp only [ne_eq, Subtype.mk.injEq]
+      exact hne
+    · rw [Set.eq_univ_iff_forall]
+      rintro ⟨x, hx⟩
+      simp only [Set.mem_insert_iff, Set.mem_singleton_iff, Subtype.mk.injEq]
+      exact (sq_add_self_add_one_eq_zero_iff_of_prime hp hζ).mp hx
+  · rw [ite_eq_right h1]
+    have hempty : IsEmpty {x : ZMod p // x ^ 2 + x + 1 = 0} := by
+      refine ⟨fun z => ?_⟩
+      obtain ⟨x, hx⟩ := z
+      have hord : orderOf x = 3 :=
+        (sq_add_self_add_one_eq_zero_iff_orderOf_eq_three hp hp3 x).mp hx
+      have hx0 : x ≠ 0 := by
+        rintro rfl
+        exact one_ne_zero (α := ZMod p) (by linear_combination hx)
+      have hdvd : (3 : ℕ) ∣ p - 1 := by
+        rw [← hord]
+        exact ZMod.orderOf_dvd_card_sub_one hx0
+      have := hp.two_le
+      omega
+    exact @Nat.card_of_isEmpty _ hempty
+
+theorem nuThree_eq_zero_of_mod_three_eq_two (hp : p.Prime) (h2 : p % 3 = 2) :
+    nuThree p = 0 := by
+  have hp3 : p ≠ 3 := by rintro rfl; omega
+  have hne1 : ¬p % 3 = 1 := by omega
+  rw [nuThree_prime hp hp3, ite_eq_right hne1]
+
+theorem nuThree_eq_two_of_mod_three_eq_one (hp : p.Prime) (h1 : p % 3 = 1) :
+    nuThree p = 2 := by
+  have hp3 : p ≠ 3 := by rintro rfl; omega
+  rw [nuThree_prime hp hp3, ite_eq_left h1]
+
+end Prime
+
+theorem nuThree_three : nuThree 3 = 1 := by
+  have hcard : nuThree 3 = Fintype.card {x : ZMod 3 // x ^ 2 + x + 1 = 0} :=
+    Nat.card_eq_fintype_card
+  rw [hcard]
+  decide
+
+section Multiplicative
+
+variable {A B : Type*} [Ring A] [Ring B]
+
+theorem fst_sq_add_self_add_one (y : A × B) : (y ^ 2 + y + 1).1 = y.1 ^ 2 + y.1 + 1 := by
+  rw [pow_two, pow_two, Prod.fst_add, Prod.fst_add, Prod.fst_mul, Prod.fst_one]
+
+theorem snd_sq_add_self_add_one (y : A × B) : (y ^ 2 + y + 1).2 = y.2 ^ 2 + y.2 + 1 := by
+  rw [pow_two, pow_two, Prod.snd_add, Prod.snd_add, Prod.snd_mul, Prod.snd_one]
+
+theorem sq_add_self_add_one_eq_zero_prod_iff (y : A × B) :
+    y ^ 2 + y + 1 = 0 ↔ y.1 ^ 2 + y.1 + 1 = 0 ∧ y.2 ^ 2 + y.2 + 1 = 0 := by
+  constructor
+  · intro hy
+    refine ⟨?_, ?_⟩
+    · rw [← fst_sq_add_self_add_one, hy, Prod.fst_zero]
+    · rw [← snd_sq_add_self_add_one, hy, Prod.snd_zero]
+  · rintro ⟨h1, h2⟩
+    calc y ^ 2 + y + 1 = ((y ^ 2 + y + 1).1, (y ^ 2 + y + 1).2) := rfl
+      _ = ((0 : A), (0 : B)) := by
+          rw [fst_sq_add_self_add_one, snd_sq_add_self_add_one, h1, h2]
+      _ = (0 : A × B) := rfl
+
+theorem sq_add_self_add_one_eq_zero_iff_map {R S : Type*} [Ring R] [Ring S] (f : R ≃+* S)
+    (x : R) : x ^ 2 + x + 1 = 0 ↔ f x ^ 2 + f x + 1 = 0 := by
+  constructor
+  · intro hx
+    have hmap := congrArg f hx
+    simpa only [map_add, map_pow, map_one, map_zero] using hmap
+  · intro hx
+    have hmap := congrArg f.symm hx
+    simpa only [map_add, map_pow, map_one, map_zero, RingEquiv.symm_apply_apply] using hmap
+
+end Multiplicative
+
+theorem nuThree_mul_of_coprime {M N : ℕ} (h : Nat.Coprime M N) :
+    nuThree (M * N) = nuThree M * nuThree N := by
+  have key : ∀ x : ZMod (M * N),
+      x ^ 2 + x + 1 = 0 ↔
+        ((ZMod.chineseRemainder h) x).1 ^ 2 + ((ZMod.chineseRemainder h) x).1 + 1 = 0 ∧
+          ((ZMod.chineseRemainder h) x).2 ^ 2 + ((ZMod.chineseRemainder h) x).2 + 1 = 0 := by
+    intro x
+    rw [sq_add_self_add_one_eq_zero_iff_map (ZMod.chineseRemainder h) x,
+      sq_add_self_add_one_eq_zero_prod_iff]
+  have e₁ : {x : ZMod (M * N) // x ^ 2 + x + 1 = 0} ≃
+      {c : ZMod M × ZMod N // c.1 ^ 2 + c.1 + 1 = 0 ∧ c.2 ^ 2 + c.2 + 1 = 0} :=
+    Equiv.subtypeEquiv (ZMod.chineseRemainder h).toEquiv key
+  have e₂ : {c : ZMod M × ZMod N // c.1 ^ 2 + c.1 + 1 = 0 ∧ c.2 ^ 2 + c.2 + 1 = 0} ≃
+      {a : ZMod M // a ^ 2 + a + 1 = 0} × {b : ZMod N // b ^ 2 + b + 1 = 0} :=
+    Equiv.subtypeProdEquivProd
+      (p := fun a : ZMod M => a ^ 2 + a + 1 = 0)
+      (q := fun b : ZMod N => b ^ 2 + b + 1 = 0)
+  change Nat.card {x : ZMod (M * N) // x ^ 2 + x + 1 = 0} =
+    Nat.card {a : ZMod M // a ^ 2 + a + 1 = 0} * Nat.card {b : ZMod N // b ^ 2 + b + 1 = 0}
+  rw [Nat.card_congr (e₁.trans e₂), Nat.card_prod]
+
+theorem nuThree_one : nuThree 1 = 1 := by
+  have hcard : nuThree 1 = Fintype.card {x : ZMod 1 // x ^ 2 + x + 1 = 0} :=
+    Nat.card_eq_fintype_card
+  rw [hcard]
+  decide
+
+theorem nuThree_seven : nuThree 7 = 2 :=
+  nuThree_eq_two_of_mod_three_eq_one (by norm_num) (by norm_num)
+
+theorem nuThree_eleven : nuThree 11 = 0 :=
+  nuThree_eq_zero_of_mod_three_eq_two (by norm_num) (by norm_num)
+
+theorem nuThree_thirteen : nuThree 13 = 2 :=
+  nuThree_eq_two_of_mod_three_eq_one (by norm_num) (by norm_num)
+
+theorem nuThree_nineteen : nuThree 19 = 2 :=
+  nuThree_eq_two_of_mod_three_eq_one (by norm_num) (by norm_num)
+
+end ModularCurve
+end File_FLT_ModularCurve_Numerics_NuThree
+
+section File_FLT_AnalyticCore_SplittingLawHalf
+
+namespace FLT
+namespace AnalyticCore
+
+open Finset FLT.EisensteinWeightOne
+
+theorem hexForm_mul (a b c d : ℤ) :
+    hexForm a b * hexForm c d = hexForm (a * c - b * d) (a * d + b * c + b * d) := by
+  simp only [hexForm]; ring
+
+theorem hexForm_two_neg_one : hexForm 2 (-1) = 3 := by decide
+
+theorem hexForm_smul (c x y : ℤ) : hexForm (c * x) (c * y) = c ^ 2 * hexForm x y := by
+  simp only [hexForm]; ring
+
+section Inert
+
+variable {p : ℕ}
+
+theorem not_isRoot_of_inert (hp : p.Prime) (h2 : p % 3 = 2) (t : ZMod p) :
+    t ^ 2 + t + 1 ≠ 0 := by
+  have : Fact p.Prime := ⟨hp⟩
+  intro ht
+  have hp3 : p ≠ 3 := by rintro rfl; omega
+  have hord : orderOf t = 3 :=
+    (ModularCurve.sq_add_self_add_one_eq_zero_iff_orderOf_eq_three hp hp3 t).mp ht
+  have ht0 : t ≠ 0 := by
+    rintro rfl
+    exact one_ne_zero (α := ZMod p) (by linear_combination ht)
+  have hdvd : (3 : ℕ) ∣ p - 1 := hord ▸ ZMod.orderOf_dvd_card_sub_one ht0
+  have := hp.two_le
+  omega
+
+theorem inert_dvd_right_of_dvd_hexForm (hp : p.Prime) (h2 : p % 3 = 2) {x y : ℤ}
+    (h : (p : ℤ) ∣ hexForm x y) : (p : ℤ) ∣ y := by
+  have : Fact p.Prime := ⟨hp⟩
+  rw [← ZMod.intCast_zmod_eq_zero_iff_dvd] at h ⊢
+  by_contra hy
+  have hyu : (y : ZMod p) * (y : ZMod p)⁻¹ = 1 := mul_inv_cancel₀ hy
+  have hQ : (x : ZMod p) ^ 2 + (x : ZMod p) * (y : ZMod p) + (y : ZMod p) ^ 2 = 0 := by
+    have h' : ((hexForm x y : ℤ) : ZMod p) = 0 := h
+    push_cast [hexForm] at h'
+    linear_combination h'
+  refine not_isRoot_of_inert hp h2 ((x : ZMod p) * (y : ZMod p)⁻¹) ?_
+  linear_combination ((y : ZMod p)⁻¹ * (y : ZMod p)⁻¹) * hQ +
+    (-((x : ZMod p) * (y : ZMod p)⁻¹) - 1 - (y : ZMod p) * (y : ZMod p)⁻¹) * hyu
+
+theorem inert_dvd_of_dvd_hexForm (hp : p.Prime) (h2 : p % 3 = 2) {x y : ℤ}
+    (h : (p : ℤ) ∣ hexForm x y) : (p : ℤ) ∣ x ∧ (p : ℤ) ∣ y := by
+  refine ⟨?_, inert_dvd_right_of_dvd_hexForm hp h2 h⟩
+  exact inert_dvd_right_of_dvd_hexForm hp h2 (x := y) (y := x) (by rwa [hexForm_swap])
+
+theorem inert_sq_dvd_of_dvd_hexForm (hp : p.Prime) (h2 : p % 3 = 2) {x y : ℤ}
+    (h : (p : ℤ) ∣ hexForm x y) : (p : ℤ) ^ 2 ∣ hexForm x y := by
+  obtain ⟨⟨x', rfl⟩, ⟨y', rfl⟩⟩ := inert_dvd_of_dvd_hexForm hp h2 h
+  exact ⟨hexForm x' y', by rw [hexForm_smul]⟩
+
+theorem reprCount_eq_zero_of_inert (hp : p.Prime) (h2 : p % 3 = 2) :
+    reprCount p = 0 := by
+  rw [reprCount, Finset.card_eq_zero, Finset.eq_empty_iff_forall_notMem]
+  rintro ⟨x, y⟩ hxy
+  have hQ : hexForm x y = (p : ℤ) := mem_reprSols_iff.mp hxy
+  have hpd : (p : ℤ) ∣ hexForm x y := by rw [hQ]
+  have hsq : (p : ℤ) ^ 2 ∣ (p : ℤ) := by
+    have h' := inert_sq_dvd_of_dvd_hexForm hp h2 hpd
+    rwa [hQ] at h'
+  have hple : (p : ℤ) ^ 2 ≤ (p : ℤ) := Int.le_of_dvd (by exact_mod_cast hp.pos) hsq
+  have hp2 : (2 : ℤ) ≤ (p : ℤ) := by exact_mod_cast hp.two_le
+  nlinarith
+
+theorem reprCount_eq_zero_of_inert_dvd_of_not_sq_dvd (hp : p.Prime) (h2 : p % 3 = 2)
+    {n : ℕ} (hdvd : p ∣ n) (hnsq : ¬p ^ 2 ∣ n) : reprCount n = 0 := by
+  rw [reprCount, Finset.card_eq_zero, Finset.eq_empty_iff_forall_notMem]
+  rintro ⟨x, y⟩ hxy
+  have hQ : hexForm x y = (n : ℤ) := mem_reprSols_iff.mp hxy
+  have hpd : (p : ℤ) ∣ hexForm x y := by rw [hQ]; exact_mod_cast hdvd
+  have hsq : (p : ℤ) ^ 2 ∣ (n : ℤ) := by
+    have h' := inert_sq_dvd_of_dvd_hexForm hp h2 hpd
+    rwa [hQ] at h'
+  refine hnsq ?_
+  have : ((p ^ 2 : ℕ) : ℤ) ∣ (n : ℤ) := by push_cast; exact hsq
+  exact_mod_cast this
+
+theorem sigmaChi_eq_zero_of_inert_dvd_of_not_sq_dvd (hp : p.Prime) (h2 : p % 3 = 2)
+    {n : ℕ} (hdvd : p ∣ n) (hnsq : ¬p ^ 2 ∣ n) : sigmaChi n = 0 := by
+  obtain ⟨m, rfl⟩ := hdvd
+  have hpm : ¬p ∣ m := fun hm => hnsq (by obtain ⟨m', rfl⟩ := hm; exact ⟨m', by ring⟩)
+  have hcop : Nat.Coprime p m := (Nat.Prime.coprime_iff_not_dvd hp).mpr hpm
+  rw [sigmaChi_mul_of_coprime p m hcop, sigmaChi_prime hp]
+  have hchi : chiNegThree p = -1 := by
+    simp [chiNegThree, h2]
+  rw [hchi]; ring
+
+theorem reprCount_eq_coeff_of_inert_exactly_dvd (hp : p.Prime) (h2 : p % 3 = 2)
+    {n : ℕ} (hn : n ≠ 0) (hdvd : p ∣ n) (hnsq : ¬p ^ 2 ∣ n) :
+    (reprCount n : ℤ) = PowerSeries.coeff n e1Chi3 := by
+  rw [reprCount_eq_zero_of_inert_dvd_of_not_sq_dvd hp h2 hdvd hnsq,
+    coeff_e1Chi3_of_ne_zero hn,
+    sigmaChi_eq_zero_of_inert_dvd_of_not_sq_dvd hp h2 hdvd hnsq]
+  ring
+
+theorem reprSols_sq_mul_of_inert (hp : p.Prime) (h2 : p % 3 = 2) (m : ℕ) :
+    reprSols (p ^ 2 * m)
+      = (reprSols m).image fun q => ((p : ℤ) * q.1, (p : ℤ) * q.2) := by
+  ext ⟨x, y⟩
+  simp only [Finset.mem_image, mem_reprSols_iff, Prod.mk.injEq, Prod.exists]
+  constructor
+  · intro hQ
+    have hpd : (p : ℤ) ∣ hexForm x y := by
+      rw [hQ]; push_cast; exact ⟨(p : ℤ) * m, by ring⟩
+    obtain ⟨⟨x', rfl⟩, ⟨y', rfl⟩⟩ := inert_dvd_of_dvd_hexForm hp h2 hpd
+    refine ⟨x', y', ?_, rfl, rfl⟩
+    have hp0 : ((p : ℤ) ^ 2) ≠ 0 := pow_ne_zero 2 (by exact_mod_cast hp.pos.ne')
+    refine mul_left_cancel₀ hp0 ?_
+    rw [← hexForm_smul, hQ]; push_cast; ring
+  · rintro ⟨u, v, hQ, rfl, rfl⟩
+    rw [hexForm_smul, hQ]; push_cast; ring
+
+theorem reprCount_sq_mul_of_inert (hp : p.Prime) (h2 : p % 3 = 2) (m : ℕ) :
+    reprCount (p ^ 2 * m) = reprCount m := by
+  rw [reprCount, reprCount, reprSols_sq_mul_of_inert hp h2 m]
+  refine Finset.card_image_of_injOn fun q _ q' _ h => ?_
+  have hp0 : (p : ℤ) ≠ 0 := by exact_mod_cast hp.pos.ne'
+  simp only [Prod.mk.injEq] at h
+  exact Prod.ext (mul_left_cancel₀ hp0 h.1) (mul_left_cancel₀ hp0 h.2)
+
+end Inert
+
+theorem hexForm_ramified_ascent (u v : ℤ) :
+    hexForm (2 * u + v) (v - u) = 3 * hexForm u v := by
+  simp only [hexForm]; ring
+
+theorem three_dvd_sub_of_dvd_hexForm {x y : ℤ} (h : (3 : ℤ) ∣ hexForm x y) :
+    (3 : ℤ) ∣ x - y := by
+  have hsq : (3 : ℤ) ∣ (x - y) ^ 2 := by
+    obtain ⟨c, hc⟩ := h
+    refine ⟨c - x * y, ?_⟩
+    simp only [hexForm] at hc
+    linear_combination hc
+  exact (by norm_num : Prime (3 : ℤ)).dvd_of_dvd_pow hsq
+
+theorem reprSols_three_mul (m : ℕ) :
+    reprSols (3 * m) = (reprSols m).image fun q => (2 * q.1 + q.2, q.2 - q.1) := by
+  ext ⟨x, y⟩
+  simp only [Finset.mem_image, mem_reprSols_iff, Prod.mk.injEq, Prod.exists]
+  constructor
+  · intro hQ
+    have h3 : (3 : ℤ) ∣ hexForm x y := by rw [hQ]; push_cast; exact ⟨m, by ring⟩
+    obtain ⟨u, hu⟩ := three_dvd_sub_of_dvd_hexForm h3
+    refine ⟨u, y + u, ?_, by linarith, by ring⟩
+    refine mul_left_cancel₀ (by norm_num : (3 : ℤ) ≠ 0) ?_
+    rw [← hexForm_ramified_ascent]
+    have hx : 2 * u + (y + u) = x := by linarith
+    have hy : (y + u) - u = y := by ring
+    rw [hx, hy, hQ]; push_cast; ring
+  · rintro ⟨u, v, hQ, rfl, rfl⟩
+    rw [hexForm_ramified_ascent, hQ]; push_cast; ring
+
+theorem reprCount_three_mul (m : ℕ) : reprCount (3 * m) = reprCount m := by
+  rw [reprCount, reprCount, reprSols_three_mul m]
+  refine Finset.card_image_of_injOn fun q _ q' _ h => ?_
+  simp only [Prod.mk.injEq] at h
+  obtain ⟨h1, h2⟩ := h
+  exact Prod.ext (by linarith) (by linarith)
+
+theorem sigmaChi_prime_pow {p : ℕ} (hp : p.Prime) (k : ℕ) :
+    sigmaChi (p ^ k) = ∑ j ∈ Finset.range (k + 1), chiNegThree p ^ j := by
+  rw [sigmaChi, Nat.divisors_prime_pow hp, Finset.sum_map]
+  exact Finset.sum_congr rfl fun j _ => chiNegThree_pow p j
+
+theorem sigmaChi_three_pow (k : ℕ) : sigmaChi (3 ^ k) = 1 := by
+  rw [sigmaChi_prime_pow (by norm_num) k]
+  rw [show chiNegThree 3 = 0 from chiNegThree_three]
+  rw [Finset.sum_congr rfl fun j _ => zero_pow_eq j]
+  simp
+
+theorem sigmaChi_inert_pow {p : ℕ} (hp : p.Prime) (h2 : p % 3 = 2) (k : ℕ) :
+    sigmaChi (p ^ k) = if Even k then 1 else 0 := by
+  rw [sigmaChi_prime_pow hp k]
+  have hchi : chiNegThree p = -1 := by
+    simp [chiNegThree, h2]
+  rw [hchi, neg_one_geom_sum]
+  rcases Nat.even_or_odd k with hk | hk
+  · rw [ite_eq_left hk, ite_eq_right (Nat.not_even_iff_odd.mpr hk.add_one)]
+  · rw [ite_eq_right (Nat.not_even_iff_odd.mpr hk), ite_eq_left hk.add_one]
+
+theorem reprCount_three_pow (k : ℕ) : reprCount (3 ^ k) = 6 := by
+  induction k with
+  | zero => simpa using reprCount_one
+  | succ k ih => rw [pow_succ, mul_comm, reprCount_three_mul, ih]
+
+theorem reprCount_inert_pow {p : ℕ} (hp : p.Prime) (h2 : p % 3 = 2) (k : ℕ) :
+    reprCount (p ^ k) = if Even k then 6 else 0 := by
+  have heven : ∀ j : ℕ, reprCount (p ^ (2 * j)) = 6 := by
+    intro j
+    induction j with
+    | zero => simpa using reprCount_one
+    | succ j ih =>
+      have hstep : p ^ (2 * (j + 1)) = p ^ 2 * p ^ (2 * j) := by ring
+      rw [hstep, reprCount_sq_mul_of_inert hp h2, ih]
+  have hodd : ∀ j : ℕ, reprCount (p ^ (2 * j + 1)) = 0 := by
+    intro j
+    induction j with
+    | zero => simpa using reprCount_eq_zero_of_inert hp h2
+    | succ j ih =>
+      have hstep : p ^ (2 * (j + 1) + 1) = p ^ 2 * p ^ (2 * j + 1) := by ring
+      rw [hstep, reprCount_sq_mul_of_inert hp h2, ih]
+  rcases Nat.even_or_odd k with hk | hk
+  · obtain ⟨j, hj⟩ := hk
+    rw [ite_eq_left ⟨j, hj⟩, hj, ← two_mul, heven]
+  · obtain ⟨j, hj⟩ := hk
+    rw [ite_eq_right (Nat.not_even_iff_odd.mpr ⟨j, hj⟩), hj, hodd]
+
+theorem exists_dvd_hexForm_of_split {p : ℕ} (hp : p.Prime) (h1 : p % 3 = 1) :
+    ∃ a : ℤ, (p : ℤ) ∣ hexForm a 1 := by
+  have : Fact p.Prime := ⟨hp⟩
+  have hp3 : p ≠ 3 := by rintro rfl; omega
+  obtain ⟨t, ht⟩ := ModularCurve.exists_orderOf_eq_three hp h1
+  have hroot : t ^ 2 + t + 1 = 0 :=
+    (ModularCurve.sq_add_self_add_one_eq_zero_iff_orderOf_eq_three hp hp3 t).mpr ht
+  obtain ⟨a, rfl⟩ := ZMod.intCast_surjective t
+  refine ⟨a, ?_⟩
+  rw [← ZMod.intCast_zmod_eq_zero_iff_dvd]
+  push_cast [hexForm]
+  linear_combination hroot
+
+def OrbitCountMultiplicative : Prop :=
+  ∀ m n : ℕ, Nat.Coprime m n → 6 * reprCount (m * n) = reprCount m * reprCount n
+
+def SplitPrimePowCount : Prop :=
+  ∀ p k : ℕ, p.Prime → p % 3 = 1 → reprCount (p ^ k) = 6 * (k + 1)
+
+theorem sigmaChi_split_pow {p : ℕ} (hp : p.Prime) (h1 : p % 3 = 1) (k : ℕ) :
+    sigmaChi (p ^ k) = k + 1 := by
+  rw [sigmaChi_prime_pow hp k]
+  have hchi : chiNegThree p = 1 := by
+    simp [chiNegThree, h1]
+  rw [hchi]
+  simp
+
+theorem reprCountEqCoeffE1Chi3_of_residuals
+    (hmul : OrbitCountMultiplicative) (hsplit : SplitPrimePowCount) :
+    ReprCountEqCoeffE1Chi3 := by
+  intro n
+  induction n using Nat.recOnPosPrimePosCoprime with
+  | zero => exact reprCount_eq_coeff_e1Chi3_zero
+  | one => exact reprCount_eq_coeff_e1Chi3_one
+  | prime_pow p k hp hk =>
+    have hp' : p.Prime := hp
+    have hpk : p ^ k ≠ 0 := pow_ne_zero k hp'.pos.ne'
+    rw [coeff_e1Chi3_of_ne_zero hpk]
+    rcases (by omega : p % 3 = 0 ∨ p % 3 = 1 ∨ p % 3 = 2) with h0 | h1 | h2
+    · have hp3 : p = 3 := ((Nat.prime_dvd_prime_iff_eq Nat.prime_three hp').mp
+        (Nat.dvd_of_mod_eq_zero h0)).symm
+      subst hp3
+      rw [reprCount_three_pow, sigmaChi_three_pow]
+      norm_num
+    · rw [hsplit p k hp' h1, sigmaChi_split_pow hp' h1]
+      push_cast
+      ring
+    · rw [reprCount_inert_pow hp' h2, sigmaChi_inert_pow hp' h2]
+      rcases Nat.even_or_odd k with hk' | hk'
+      · rw [ite_eq_left hk', ite_eq_left hk']; norm_num
+      · rw [ite_eq_right (Nat.not_even_iff_odd.mpr hk'),
+          ite_eq_right (Nat.not_even_iff_odd.mpr hk')]
+        norm_num
+  | coprime a b ha hb hab iha ihb =>
+    have ha0 : a ≠ 0 := by omega
+    have hb0 : b ≠ 0 := by omega
+    have hab0 : a * b ≠ 0 := Nat.mul_ne_zero ha0 hb0
+    refine mul_left_cancel₀ (by norm_num : (6 : ℤ) ≠ 0) ?_
+    have hkey : (6 : ℤ) * (reprCount (a * b) : ℤ)
+        = (reprCount a : ℤ) * (reprCount b : ℤ) := by
+      exact_mod_cast hmul a b hab
+    rw [hkey, iha, ihb, coeff_e1Chi3_of_ne_zero ha0, coeff_e1Chi3_of_ne_zero hb0,
+      coeff_e1Chi3_of_ne_zero hab0, sigmaChi_mul_of_coprime a b hab]
+    ring
+
+theorem reprCount_twelve : reprCount 12 = 6 := by decide
+
+theorem reprCount_nine : reprCount 9 = 6 := by decide
+
+theorem reprCount_ten : reprCount 10 = 0 := by decide
+
+theorem orbitCountMultiplicative_three_four :
+    6 * reprCount (3 * 4) = reprCount 3 * reprCount 4 := by
+  norm_num [reprCount_twelve, reprCount_three, reprCount_four]
+
+theorem orbitCountMultiplicative_not_without_coprime :
+    ¬(∀ m n : ℕ, 6 * reprCount (m * n) = reprCount m * reprCount n) := by
+  intro h
+  have h22 := h 2 2
+  rw [reprCount_two] at h22
+  norm_num [show (2 : ℕ) * 2 = 4 from rfl, reprCount_four] at h22
+
+theorem splitPrimePowCount_at_seven : reprCount (7 ^ 1) = 6 * (1 + 1) := by
+  norm_num [reprCount_seven]
+
+theorem splitPrimePowCount_not_at_inert : reprCount (2 ^ 1) ≠ 6 * (1 + 1) := by
+  norm_num [reprCount_two]
+
+theorem residuals_jointly_satisfiable_on_table :
+    (6 * reprCount (3 * 4) = reprCount 3 * reprCount 4) ∧
+      (reprCount (7 ^ 1) = 6 * (1 + 1)) :=
+  ⟨orbitCountMultiplicative_three_four, splitPrimePowCount_at_seven⟩
+
+end FLT.AnalyticCore
+end File_FLT_AnalyticCore_SplittingLawHalf
+
+section File_FLT_AnalyticCore_OrbitCountMultiplicative
+
+namespace FLT
+namespace AnalyticCore
+
+open Finset
+
+@[scoped ext]
+structure HexInt where
+
+  re : ℤ
+  im : ℤ
+  deriving DecidableEq
+
+namespace HexInt
+
+scoped instance : Zero HexInt := ⟨⟨0, 0⟩⟩
+
+@[scoped simp] theorem re_zero : (0 : HexInt).re = 0 := rfl
+@[scoped simp] theorem im_zero : (0 : HexInt).im = 0 := rfl
+
+scoped instance : One HexInt := ⟨⟨1, 0⟩⟩
+
+@[scoped simp] theorem re_one : (1 : HexInt).re = 1 := rfl
+@[scoped simp] theorem im_one : (1 : HexInt).im = 0 := rfl
+
+scoped instance : Add HexInt := ⟨fun z w => ⟨z.re + w.re, z.im + w.im⟩⟩
+
+@[scoped simp] theorem re_add (z w : HexInt) : (z + w).re = z.re + w.re := rfl
+@[scoped simp] theorem im_add (z w : HexInt) : (z + w).im = z.im + w.im := rfl
+
+scoped instance : Neg HexInt := ⟨fun z => ⟨-z.re, -z.im⟩⟩
+
+@[scoped simp] theorem re_neg (z : HexInt) : (-z).re = -z.re := rfl
+@[scoped simp] theorem im_neg (z : HexInt) : (-z).im = -z.im := rfl
+
+scoped instance : Mul HexInt :=
+  ⟨fun z w => ⟨z.re * w.re - z.im * w.im, z.re * w.im + z.im * w.re + z.im * w.im⟩⟩
+
+@[scoped simp] theorem re_mul (z w : HexInt) : (z * w).re = z.re * w.re - z.im * w.im := rfl
+@[scoped simp] theorem im_mul (z w : HexInt) :
+    (z * w).im = z.re * w.im + z.im * w.re + z.im * w.im := rfl
+
+scoped instance addCommGroup : AddCommGroup HexInt := by
+  refine
+  { sub := fun a b => a + -b
+    nsmul := @nsmulRec HexInt ⟨0⟩ ⟨(· + ·)⟩
+    zsmul := @zsmulRec HexInt ⟨0⟩ ⟨(· + ·)⟩ ⟨Neg.neg⟩ (@nsmulRec HexInt ⟨0⟩ ⟨(· + ·)⟩)
+    add_assoc := ?_
+    zero_add := ?_
+    add_zero := ?_
+    neg_add_cancel := ?_
+    add_comm := ?_ } <;>
+  intros <;>
+  ext <;>
+  simp [add_comm, add_left_comm]
+
+@[scoped simp] theorem re_sub (z w : HexInt) : (z - w).re = z.re - w.re := rfl
+@[scoped simp] theorem im_sub (z w : HexInt) : (z - w).im = z.im - w.im := rfl
+
+scoped instance addGroupWithOne : AddGroupWithOne HexInt :=
+  { HexInt.addCommGroup with
+    natCast := fun n => ⟨(n : ℤ), 0⟩
+    intCast := fun n => ⟨n, 0⟩ }
+
+scoped instance commRing : CommRing HexInt := by
+  refine
+  { HexInt.addGroupWithOne with
+    npow := @npowRec HexInt ⟨1⟩ ⟨(· * ·)⟩
+    add_comm := ?_
+    left_distrib := ?_
+    right_distrib := ?_
+    zero_mul := ?_
+    mul_zero := ?_
+    mul_assoc := ?_
+    one_mul := ?_
+    mul_one := ?_
+    mul_comm := ?_ } <;>
+  intros <;>
+  ext <;>
+  simp <;>
+  ring
+
+scoped instance : Nontrivial HexInt :=
+  ⟨⟨0, 1, fun h => one_ne_zero (α := ℤ) (by simpa using congrArg HexInt.re h.symm)⟩⟩
+
+@[scoped simp] theorem re_intCast (n : ℤ) : (n : HexInt).re = n := by cases n <;> rfl
+@[scoped simp] theorem im_intCast (n : ℤ) : (n : HexInt).im = 0 := by cases n <;> rfl
+@[scoped simp] theorem re_natCast (n : ℕ) : (n : HexInt).re = n := rfl
+@[scoped simp] theorem im_natCast (n : ℕ) : (n : HexInt).im = 0 := rfl
+
+def conj (z : HexInt) : HexInt := ⟨z.re + z.im, -z.im⟩
+
+@[scoped simp] theorem re_conj (z : HexInt) : z.conj.re = z.re + z.im := rfl
+@[scoped simp] theorem im_conj (z : HexInt) : z.conj.im = -z.im := rfl
+
+@[scoped simp] theorem conj_zero : (0 : HexInt).conj = 0 := by ext <;> simp [conj]
+
+def norm (z : HexInt) : ℤ := hexForm z.re z.im
+
+theorem norm_def (z : HexInt) : z.norm = z.re * z.re + z.re * z.im + z.im * z.im := rfl
+
+@[scoped simp] theorem norm_mk (a b : ℤ) : norm ⟨a, b⟩ = hexForm a b := rfl
+
+@[scoped simp] theorem norm_zero : (0 : HexInt).norm = 0 := rfl
+
+@[scoped simp] theorem norm_one : (1 : HexInt).norm = 1 := rfl
+
+@[scoped simp] theorem norm_intCast (n : ℤ) : (n : HexInt).norm = n ^ 2 := by
+  simp only [norm, re_intCast, im_intCast, hexForm]; ring
+
+@[scoped simp] theorem norm_natCast (n : ℕ) : ((n : ℕ) : HexInt).norm = (n : ℤ) ^ 2 := by
+  simp only [norm, re_natCast, im_natCast, hexForm]; ring
+
+theorem norm_mul (z w : HexInt) : (z * w).norm = z.norm * w.norm := by
+  simp only [norm, re_mul, im_mul, hexForm]; ring
+
+def normHom : HexInt →* ℤ where
+  toFun := norm
+  map_one' := norm_one
+  map_mul' := norm_mul
+
+@[scoped simp] theorem normHom_apply (z : HexInt) : normHom z = z.norm := rfl
+
+theorem norm_nonneg (z : HexInt) : 0 ≤ z.norm := hexForm_nonneg _ _
+
+theorem norm_eq_zero_iff {z : HexInt} : z.norm = 0 ↔ z = 0 := by
+  rw [norm, hexForm_eq_zero_iff, HexInt.ext_iff, re_zero, im_zero]
+
+theorem norm_pos {z : HexInt} (hz : z ≠ 0) : 0 < z.norm :=
+  lt_of_le_of_ne (norm_nonneg z) fun h => hz (norm_eq_zero_iff.mp h.symm)
+
+theorem mul_conj (z : HexInt) : z * z.conj = (z.norm : HexInt) := by
+  ext <;> simp only [re_mul, im_mul, re_conj, im_conj, re_intCast, im_intCast, norm,
+    hexForm] <;> ring
+
+theorem norm_conj (z : HexInt) : z.conj.norm = z.norm := by
+  simp only [norm, re_conj, im_conj, hexForm]; ring
+
+theorem norm_dvd_norm {z w : HexInt} (h : z ∣ w) : z.norm ∣ w.norm := by
+  obtain ⟨c, rfl⟩ := h
+  exact ⟨c.norm, norm_mul z c⟩
+
+theorem isUnit_iff_norm_eq_one {z : HexInt} : IsUnit z ↔ z.norm = 1 := by
+  constructor
+  · intro h
+    obtain ⟨w, hw⟩ := isUnit_iff_exists_inv.mp h
+    have h1 : z.norm * w.norm = 1 := by rw [← norm_mul, hw, norm_one]
+    rcases Int.isUnit_iff.mp (isUnit_of_dvd_one ⟨w.norm, h1.symm⟩) with h2 | h2
+    · exact h2
+    · exact absurd (h2 ▸ norm_nonneg z) (by norm_num)
+  · intro h
+    exact isUnit_of_dvd_one ⟨z.conj, (show z * z.conj = 1 by
+      rw [mul_conj, h, Int.cast_one]).symm⟩
+
+def nearestDiv (u n : ℤ) : ℤ := (2 * u + n) / (2 * n)
+
+theorem nearestDiv_bound {n : ℤ} (hn : 0 < n) (u : ℤ) :
+    -n ≤ 2 * (u - n * nearestDiv u n) ∧ 2 * (u - n * nearestDiv u n) < n := by
+  have h2n : (0 : ℤ) < 2 * n := by linarith
+  have hdiv := Int.mul_ediv_add_emod (2 * u + n) (2 * n)
+  have hge := Int.emod_nonneg (2 * u + n) (by positivity : (2 : ℤ) * n ≠ 0)
+  have hlt := Int.emod_lt_of_pos (2 * u + n) h2n
+  have key : 2 * (u - n * nearestDiv u n) = (2 * u + n) % (2 * n) - n := by
+    unfold nearestDiv
+    linear_combination -hdiv
+  constructor <;> rw [key] <;> linarith
+
+scoped instance : Div HexInt :=
+  ⟨fun x y => ⟨nearestDiv (x * y.conj).re y.norm, nearestDiv (x * y.conj).im y.norm⟩⟩
+
+theorem div_def (x y : HexInt) :
+    x / y = ⟨nearestDiv (x * y.conj).re y.norm, nearestDiv (x * y.conj).im y.norm⟩ := rfl
+
+theorem div_zero' (x : HexInt) : x / 0 = 0 := by
+  ext <;> simp [div_def, nearestDiv]
+
+scoped instance : Mod HexInt := ⟨fun x y => x - y * (x / y)⟩
+
+theorem mod_def (x y : HexInt) : x % y = x - y * (x / y) := rfl
+
+theorem norm_mod_lt (x : HexInt) {y : HexInt} (hy : y ≠ 0) : (x % y).norm < y.norm := by
+  have hn : 0 < y.norm := norm_pos hy
+  have hkey : (x % y) * y.conj = x * y.conj - (y.norm : HexInt) * (x / y) := by
+    rw [mod_def, sub_mul, mul_comm y (x / y), mul_assoc, mul_conj]; ring
+  have hre : ((x % y) * y.conj).re
+      = (x * y.conj).re - y.norm * nearestDiv (x * y.conj).re y.norm := by
+    rw [hkey]
+    simp only [re_sub, re_mul, im_mul, im_intCast, re_intCast, div_def]
+    ring
+  have him : ((x % y) * y.conj).im
+      = (x * y.conj).im - y.norm * nearestDiv (x * y.conj).im y.norm := by
+    rw [hkey]
+    simp only [im_sub, re_mul, im_mul, im_intCast, re_intCast, div_def]
+    ring
+  obtain ⟨hA1, hA2⟩ := nearestDiv_bound hn (x * y.conj).re
+  obtain ⟨hB1, hB2⟩ := nearestDiv_bound hn (x * y.conj).im
+  set A := ((x % y) * y.conj).re with hA_def
+  set B := ((x % y) * y.conj).im with hB_def
+  rw [← hre] at hA1 hA2
+  rw [← him] at hB1 hB2
+  have hbound : 4 * hexForm A B ≤ 3 * y.norm ^ 2 := by
+    have h1 : (0 : ℤ) ≤ (y.norm - 2 * A) * (y.norm + 2 * A) := by nlinarith
+    have h2 : (0 : ℤ) ≤ (y.norm - 2 * B) * (y.norm + 2 * B) := by nlinarith
+    have h3 : (0 : ℤ) ≤ (y.norm - 2 * A) * (y.norm + 2 * B) := by nlinarith
+    have h4 : (0 : ℤ) ≤ (y.norm + 2 * A) * (y.norm - 2 * B) := by nlinarith
+    simp only [hexForm]
+    nlinarith
+  have hprod : hexForm A B = (x % y).norm * y.norm := by
+    rw [hA_def, hB_def]
+    have : ((x % y) * y.conj).norm = (x % y).norm * y.norm := by
+      rw [norm_mul, norm_conj]
+    simpa [norm] using this
+  rw [hprod] at hbound
+  nlinarith
+
+theorem natAbs_norm_mod_lt (x : HexInt) {y : HexInt} (hy : y ≠ 0) :
+    (x % y).norm.natAbs < y.norm.natAbs := by
+  have h := norm_mod_lt x hy
+  have h1 := norm_nonneg (x % y)
+  have h2 := norm_nonneg y
+  omega
+
+theorem natAbs_norm_le_natAbs_norm_mul (a : HexInt) {b : HexInt} (hb : b ≠ 0) :
+    a.norm.natAbs ≤ (a * b).norm.natAbs := by
+  have h1 : a.norm ≤ (a * b).norm := by
+    rw [norm_mul]
+    have hb1 : 1 ≤ b.norm := norm_pos hb
+    nlinarith [norm_nonneg a]
+  have h2 := norm_nonneg a
+  omega
+
+scoped instance : EuclideanDomain HexInt :=
+  { HexInt.commRing, (inferInstance : Nontrivial HexInt) with
+    quotient := (· / ·)
+    quotient_zero := div_zero'
+    remainder := (· % ·)
+    quotient_mul_add_remainder_eq := fun a b => by rw [mod_def]; ring
+    r := _
+    r_wellFounded := (measure (Int.natAbs ∘ norm)).wf
+    remainder_lt := fun a _ hb => natAbs_norm_mod_lt a hb
+    mul_left_not_lt := fun a _ hb => not_lt.mpr (natAbs_norm_le_natAbs_norm_mul a hb) }
+
+def unitFinset : Finset HexInt :=
+  {⟨1, 0⟩, ⟨0, 1⟩, ⟨-1, 1⟩, ⟨-1, 0⟩, ⟨0, -1⟩, ⟨1, -1⟩}
+
+theorem card_unitFinset : unitFinset.card = 6 := by decide
+
+theorem norm_eq_one_iff_mem {z : HexInt} : z.norm = 1 ↔ z ∈ unitFinset := by
+  constructor
+  · intro h
+    obtain ⟨a, b⟩ := z
+    have hab : hexForm a b = ((1 : ℕ) : ℤ) := by exact_mod_cast h
+    have hb := snd_abs_le_of_hexForm_eq hab
+    have ha := snd_abs_le_of_hexForm_eq (x := b) (y := a) (by rwa [hexForm_swap])
+    push_cast at ha hb
+    obtain ⟨ha1, ha2⟩ := ha
+    obtain ⟨hb1, hb2⟩ := hb
+    interval_cases a <;> interval_cases b <;> revert h <;> decide
+  · intro h
+    fin_cases h <;> decide
+
+theorem isUnit_iff_mem {z : HexInt} : IsUnit z ↔ z ∈ unitFinset := by
+  rw [isUnit_iff_norm_eq_one, norm_eq_one_iff_mem]
+
+theorem conj_mem_unitFinset {u : HexInt} (hu : u ∈ unitFinset) : u.conj ∈ unitFinset := by
+  fin_cases hu <;> decide
+
+private theorem exists_nat_prime_dvd_of_dvd_natCast {π : HexInt} (hπ : Prime π) :
+    ∀ k : ℕ, k ≠ 0 → π ∣ (k : HexInt) → ∃ q : ℕ, q.Prime ∧ π ∣ (q : HexInt) := by
+  intro k
+  induction k using Nat.strong_induction_on with
+  | _ k ih =>
+    intro hk0 hπk
+    rcases eq_or_ne k 1 with rfl | hk1
+    · exact absurd (isUnit_of_dvd_one (by simpa using hπk)) hπ.not_isUnit
+    have hkp : k.minFac.Prime := Nat.minFac_prime hk1
+    have hkd : k.minFac ∣ k := Nat.minFac_dvd k
+    have hsplit : (k : HexInt) = (k.minFac : HexInt) * ((k / k.minFac : ℕ) : HexInt) := by
+      rw [← Nat.cast_mul, Nat.mul_div_cancel' hkd]
+    rcases hπ.dvd_or_dvd (hsplit ▸ hπk) with h | h
+    · exact ⟨k.minFac, hkp, h⟩
+    · refine ih (k / k.minFac) (Nat.div_lt_self (by omega) hkp.one_lt)
+        (Nat.div_pos (Nat.le_of_dvd (by omega) hkd) hkp.pos).ne' h
+
+theorem exists_nat_prime_dvd {π : HexInt} (hπ : Prime π) :
+    ∃ q : ℕ, q.Prime ∧ π ∣ (q : HexInt) := by
+  have h0 : π.norm ≠ 0 := fun h => hπ.ne_zero (norm_eq_zero_iff.mp h)
+  have hnn := norm_nonneg π
+  have hπk : π ∣ ((π.norm.toNat : ℕ) : HexInt) := by
+    have h1 : π ∣ π * π.conj := dvd_mul_right _ _
+    rw [mul_conj] at h1
+    rwa [show ((π.norm.toNat : ℕ) : HexInt) = ((π.norm : ℤ) : HexInt) by
+      rw [← Int.cast_natCast, Int.toNat_of_nonneg hnn]]
+  exact exists_nat_prime_dvd_of_dvd_natCast hπ π.norm.toNat (by omega) hπk
+
+theorem norm_eq_of_prime_of_dvd {π : HexInt} (hπ : Prime π) {p : ℕ} (hp : p.Prime)
+    (hdvd : (p : ℤ) ∣ π.norm) : π.norm = (p : ℤ) ∨ π.norm = (p : ℤ) ^ 2 := by
+  obtain ⟨q, hq, hπq⟩ := exists_nat_prime_dvd hπ
+  have hnq : π.norm ∣ (q : ℤ) ^ 2 := by
+    have := norm_dvd_norm hπq
+    rwa [norm_natCast] at this
+  have h0 : π.norm ≠ 0 := fun h => hπ.ne_zero (norm_eq_zero_iff.mp h)
+  have h1 : π.norm ≠ 1 := fun h => hπ.not_isUnit (isUnit_iff_norm_eq_one.mpr h)
+  have hnn := norm_nonneg π
+  have hnat : π.norm.toNat ∣ q ^ 2 := by
+    have : ((π.norm.toNat : ℕ) : ℤ) ∣ ((q ^ 2 : ℕ) : ℤ) := by
+      rw [Int.toNat_of_nonneg hnn]; push_cast; exact hnq
+    exact_mod_cast this
+  obtain ⟨j, hj2, hjeq⟩ := (Nat.dvd_prime_pow hq).mp hnat
+  have hpnat : p ∣ π.norm.toNat := by
+    have : ((p : ℕ) : ℤ) ∣ ((π.norm.toNat : ℕ) : ℤ) := by
+      rw [Int.toNat_of_nonneg hnn]; exact hdvd
+    exact_mod_cast this
+  rw [hjeq] at hpnat
+  have hpq : p = q := by
+    have := hp.dvd_of_dvd_pow hpnat
+    exact (Nat.prime_dvd_prime_iff_eq hp hq).mp this
+  subst hpq
+  have hcast : π.norm = ((p ^ j : ℕ) : ℤ) := by
+    rw [← hjeq, Int.toNat_of_nonneg hnn]
+  interval_cases j
+  · exfalso
+    apply h1
+    simp only [pow_zero, Nat.cast_one] at hcast
+    exact hcast
+  · left; rw [hcast]; push_cast; ring
+  · right; rw [hcast]; push_cast; ring
+
+theorem exists_dvd_norm_eq {γ : HexInt} (hγ : γ ≠ 0) {p : ℕ} (hp : p.Prime)
+    (hdvd : (p : ℤ) ∣ γ.norm) :
+    ∃ δ : HexInt, δ ∣ γ ∧ (δ.norm = (p : ℤ) ∨ δ.norm = (p : ℤ) ^ 2) := by
+  obtain ⟨f, hfprime, hfprod⟩ := UniqueFactorizationMonoid.exists_prime_factors γ hγ
+  have hnormprod : (f.map norm).prod = γ.norm := by
+    have h1 : (f.map norm).prod = (f.prod).norm := by
+      rw [show (f.map norm) = f.map normHom from rfl, ← MonoidHom.map_multiset_prod]
+      rfl
+    rw [h1]
+    obtain ⟨u, hu⟩ := hfprod
+    rw [← hu, norm_mul, isUnit_iff_norm_eq_one.mp u.isUnit, mul_one]
+  have hpprime : Prime (p : ℤ) := Nat.prime_iff_prime_int.mp hp
+  obtain ⟨x, hxmem, hpx⟩ := hpprime.exists_mem_multiset_dvd (hnormprod ▸ hdvd)
+  obtain ⟨π, hπmem, rfl⟩ := Multiset.mem_map.mp hxmem
+  have hπ : Prime π := hfprime π hπmem
+  refine ⟨π, ?_, norm_eq_of_prime_of_dvd hπ hp hpx⟩
+  exact (Multiset.dvd_prod hπmem).trans hfprod.dvd
+
+theorem exists_factorization :
+    ∀ m n : ℕ, Nat.Coprime m n → ∀ γ : HexInt, γ.norm = (m : ℤ) * (n : ℤ) →
+      ∃ α β : HexInt, γ = α * β ∧ α.norm = (m : ℤ) ∧ β.norm = (n : ℤ) := by
+  intro m
+  induction m using Nat.strong_induction_on with
+  | _ m ih =>
+    intro n hmn γ hγ
+    rcases Nat.eq_zero_or_pos m with rfl | hm0
+    · have hn1 : n = 1 := by simpa using hmn
+      subst hn1
+      have hγ0 : γ = 0 := norm_eq_zero_iff.mp (by simpa using hγ)
+      exact ⟨0, 1, by simp [hγ0], by simp, by simp⟩
+    rcases eq_or_ne m 1 with rfl | hm1
+    · exact ⟨1, γ, by simp, by simp, by simpa using hγ⟩
+    have hm2 : 2 ≤ m := by omega
+    set p := m.minFac with hp_def
+    have hp : p.Prime := Nat.minFac_prime hm1
+    have hpm : p ∣ m := Nat.minFac_dvd m
+    have hγ0 : γ ≠ 0 := by
+      intro h
+      rw [h, norm_zero] at hγ
+      rcases mul_eq_zero.mp hγ.symm with h' | h'
+      · have : m = 0 := by exact_mod_cast h'
+        omega
+      · have hn0 : n = 0 := by exact_mod_cast h'
+        rw [hn0] at hmn
+        have := Nat.coprime_zero_right m |>.mp hmn
+        omega
+    have hpγ : (p : ℤ) ∣ γ.norm := by
+      rw [hγ]
+      exact Dvd.dvd.mul_right (Int.natCast_dvd_natCast.mpr hpm) _
+    obtain ⟨δ, hδγ, hδnorm⟩ := exists_dvd_norm_eq hγ0 hp hpγ
+    obtain ⟨γ', rfl⟩ := hδγ
+    rcases hδnorm with hδp | hδp
+    · have hlt : m / p < m := Nat.div_lt_self (by omega) hp.one_lt
+      have hdvd' : m / p ∣ m := ⟨p, (Nat.div_mul_cancel hpm).symm⟩
+      have hcop : Nat.Coprime (m / p) n := Nat.Coprime.coprime_dvd_left hdvd' hmn
+      have hp0 : (p : ℤ) ≠ 0 := by exact_mod_cast hp.pos.ne'
+      have hγ' : γ'.norm = ((m / p : ℕ) : ℤ) * (n : ℤ) := by
+        have h1 : (p : ℤ) * γ'.norm = (m : ℤ) * (n : ℤ) := by
+          rw [← hδp, ← norm_mul]; exact hγ
+        have h2 : ((m / p : ℕ) : ℤ) * (p : ℤ) = (m : ℤ) := by
+          exact_mod_cast Nat.div_mul_cancel hpm
+        apply mul_left_cancel₀ hp0
+        rw [h1, ← h2]; ring
+      obtain ⟨α', β, rfl, hα', hβ⟩ := ih (m / p) hlt n hcop γ' hγ'
+      refine ⟨δ * α', β, by ring, ?_, hβ⟩
+      rw [norm_mul, hδp, hα']
+      exact_mod_cast congrArg (Nat.cast (R := ℤ)) (Nat.mul_div_cancel' hpm)
+    · have hsq : p ^ 2 ∣ m := by
+        have h1 : ((p ^ 2 : ℕ) : ℤ) ∣ ((m * n : ℕ) : ℤ) := by
+          push_cast
+          rw [← hδp]
+          calc δ.norm ∣ (δ * γ').norm := norm_dvd_norm (dvd_mul_right δ γ')
+            _ = (m : ℤ) * (n : ℤ) := hγ
+        have h2 : p ^ 2 ∣ m * n := by exact_mod_cast h1
+        exact ((Nat.Coprime.coprime_dvd_left hpm hmn).pow_left 2).dvd_of_dvd_mul_right h2
+      have hp2 : 1 < p ^ 2 := by nlinarith [hp.one_lt]
+      have hlt : m / p ^ 2 < m := Nat.div_lt_self (by omega) hp2
+      have hdvd' : m / p ^ 2 ∣ m := ⟨p ^ 2, (Nat.div_mul_cancel hsq).symm⟩
+      have hcop : Nat.Coprime (m / p ^ 2) n := Nat.Coprime.coprime_dvd_left hdvd' hmn
+      have hp0 : ((p : ℤ)) ^ 2 ≠ 0 := pow_ne_zero 2 (by exact_mod_cast hp.pos.ne')
+      have hγ' : γ'.norm = ((m / p ^ 2 : ℕ) : ℤ) * (n : ℤ) := by
+        have h1 : (p : ℤ) ^ 2 * γ'.norm = (m : ℤ) * (n : ℤ) := by
+          rw [← hδp, ← norm_mul]; exact hγ
+        have h2 : ((m / p ^ 2 : ℕ) : ℤ) * ((p : ℤ)) ^ 2 = (m : ℤ) := by
+          exact_mod_cast Nat.div_mul_cancel hsq
+        apply mul_left_cancel₀ hp0
+        rw [h1, ← h2]; ring
+      obtain ⟨α', β, rfl, hα', hβ⟩ := ih (m / p ^ 2) hlt n hcop γ' hγ'
+      refine ⟨δ * α', β, by ring, ?_, hβ⟩
+      rw [norm_mul, hδp, hα']
+      exact_mod_cast congrArg (Nat.cast (R := ℤ)) (Nat.mul_div_cancel' hsq)
+
+theorem dvd_of_mul_eq_mul {α β α' β' : HexInt} {m n : ℕ} (hmn : Nat.Coprime m n)
+    (hα : α.norm = (m : ℤ)) (hβ' : β'.norm = (n : ℤ))
+    (heq : α * β = α' * β') : α ∣ α' := by
+  classical
+  have hcop : IsCoprime α β' := by
+    rw [← EuclideanDomain.gcd_isUnit_iff]
+    set d := EuclideanDomain.gcd α β' with hd
+    have hd1 : d.norm ∣ (m : ℤ) := hα ▸ norm_dvd_norm (EuclideanDomain.gcd_dvd_left α β')
+    have hd2 : d.norm ∣ (n : ℤ) := hβ' ▸ norm_dvd_norm (EuclideanDomain.gcd_dvd_right α β')
+    have hdnat1 : d.norm.natAbs ∣ m := by
+      have := Int.natAbs_dvd_natAbs.mpr hd1
+      simpa using this
+    have hdnat2 : d.norm.natAbs ∣ n := by
+      have := Int.natAbs_dvd_natAbs.mpr hd2
+      simpa using this
+    have hd1' : d.norm.natAbs = 1 := Nat.eq_one_of_dvd_one (hmn ▸ Nat.dvd_gcd hdnat1 hdnat2)
+    refine isUnit_iff_norm_eq_one.mpr ?_
+    have := norm_nonneg d
+    omega
+  exact hcop.dvd_of_dvd_mul_right (heq ▸ dvd_mul_right α β)
+
+theorem eq_unit_mul_of_mul_eq_mul {α β α' β' : HexInt} {m n : ℕ} (hmn : Nat.Coprime m n)
+    (hm : m ≠ 0)
+    (hα : α.norm = (m : ℤ)) (_hβ : β.norm = (n : ℤ))
+    (hα' : α'.norm = (m : ℤ)) (hβ' : β'.norm = (n : ℤ))
+    (heq : α' * β' = α * β) :
+    ∃ u ∈ unitFinset, α' = u * α ∧ β' = u.conj * β := by
+  have hm' : (m : ℤ) ≠ 0 := by exact_mod_cast hm
+  have hα0 : α ≠ 0 := fun h => hm' (by rw [← hα, h, norm_zero])
+  obtain ⟨u, hu⟩ := dvd_of_mul_eq_mul hmn hα hβ' heq.symm
+  have hunorm : u.norm = 1 := by
+    have h3 : (m : ℤ) * u.norm = (m : ℤ) * 1 := by
+      rw [mul_one]
+      conv_rhs => rw [← hα', hu]
+      rw [norm_mul, hα]
+    exact mul_left_cancel₀ hm' h3
+  have hu0 : u ≠ 0 := fun h => by simp [h] at hunorm
+  have huα : α' = u * α := by rw [hu, mul_comm]
+  refine ⟨u, norm_eq_one_iff_mem.mp hunorm, huα, ?_⟩
+  have hcancel : (u * α) * β' = (u * α) * (u.conj * β) := by
+    have h4 : (u * α) * β' = α * β := by rw [← huα]; exact heq
+    rw [h4]
+    calc α * β = (u * u.conj) * (α * β) := by
+          rw [mul_conj, hunorm, Int.cast_one, one_mul]
+      _ = (u * α) * (u.conj * β) := by ring
+  exact mul_left_cancel₀ (mul_ne_zero hu0 hα0) hcancel
+
+def toPair (z : HexInt) : ℤ × ℤ := (z.re, z.im)
+
+def ofPair (p : ℤ × ℤ) : HexInt := ⟨p.1, p.2⟩
+
+@[scoped simp] theorem toPair_ofPair (p : ℤ × ℤ) : toPair (ofPair p) = p := rfl
+
+@[scoped simp] theorem ofPair_toPair (z : HexInt) : ofPair (toPair z) = z := rfl
+
+theorem toPair_injective : Function.Injective toPair := fun z w h => by
+  have h1 := congrArg Prod.fst h
+  have h2 := congrArg Prod.snd h
+  exact HexInt.ext h1 h2
+
+@[scoped simp] theorem norm_ofPair (p : ℤ × ℤ) : (ofPair p).norm = hexForm p.1 p.2 := rfl
+
+theorem mem_reprSols_iff_norm {p : ℤ × ℤ} {n : ℕ} :
+    p ∈ reprSols n ↔ (ofPair p).norm = (n : ℤ) := mem_reprSols_iff
+
+theorem mul_mem_reprSols {m n : ℕ} {pq : (ℤ × ℤ) × (ℤ × ℤ)}
+    (h : pq ∈ reprSols m ×ˢ reprSols n) :
+    toPair (ofPair pq.1 * ofPair pq.2) ∈ reprSols (m * n) := by
+  rw [Finset.mem_product] at h
+  rw [mem_reprSols_iff_norm, ofPair_toPair, norm_mul,
+    mem_reprSols_iff_norm.mp h.1, mem_reprSols_iff_norm.mp h.2]
+  push_cast
+  ring
+
+theorem card_fiber {m n : ℕ} (hmn : Nat.Coprime m n) (hm : m ≠ 0) (_hn : n ≠ 0)
+    {γp : ℤ × ℤ} (hγp : γp ∈ reprSols (m * n)) :
+    ((reprSols m ×ˢ reprSols n).filter
+      fun pq => toPair (ofPair pq.1 * ofPair pq.2) = γp).card = 6 := by
+  classical
+  have hγnorm : (ofPair γp).norm = (m : ℤ) * (n : ℤ) := by
+    rw [mem_reprSols_iff_norm.mp hγp]; push_cast; ring
+  obtain ⟨α₀, β₀, hγeq, hα₀, hβ₀⟩ := exists_factorization m n hmn (ofPair γp) hγnorm
+  have hα₀0 : α₀ ≠ 0 := fun h => hm (by
+    rw [h, norm_zero] at hα₀
+    exact_mod_cast hα₀.symm)
+  have hγp_pair : γp = toPair (α₀ * β₀) := by rw [← hγeq, toPair_ofPair]
+  have himage : ((reprSols m ×ˢ reprSols n).filter
+      fun pq => toPair (ofPair pq.1 * ofPair pq.2) = γp)
+      = unitFinset.image fun u => (toPair (u * α₀), toPair (u.conj * β₀)) := by
+    ext ⟨P, Q⟩
+    simp only [Finset.mem_filter, Finset.mem_product, Finset.mem_image]
+    constructor
+    · rintro ⟨⟨hP, hQ⟩, heq⟩
+      have heq' : ofPair P * ofPair Q = α₀ * β₀ := by
+        rw [← hγeq]
+        exact toPair_injective (by rw [heq]; rfl)
+      obtain ⟨u, humem, huP, huQ⟩ :=
+        eq_unit_mul_of_mul_eq_mul hmn hm
+          hα₀ hβ₀ (mem_reprSols_iff_norm.mp hP) (mem_reprSols_iff_norm.mp hQ) heq'
+      exact ⟨u, humem, by rw [← huP, ← huQ, toPair_ofPair, toPair_ofPair]⟩
+    · rintro ⟨u, humem, heq⟩
+      have hunorm : u.norm = 1 := norm_eq_one_iff_mem.mpr humem
+      have hP : P = toPair (u * α₀) := (congrArg Prod.fst heq).symm
+      have hQ : Q = toPair (u.conj * β₀) := (congrArg Prod.snd heq).symm
+      have hconjnorm : u.conj.norm = 1 := by rw [norm_conj]; exact hunorm
+      refine ⟨⟨?_, ?_⟩, ?_⟩
+      · rw [hP, mem_reprSols_iff_norm, ofPair_toPair, norm_mul, hunorm, one_mul, hα₀]
+      · rw [hQ, mem_reprSols_iff_norm, ofPair_toPair, norm_mul, hconjnorm, one_mul, hβ₀]
+      · rw [hP, hQ, ofPair_toPair, ofPair_toPair, hγp_pair]
+        congr 1
+        calc u * α₀ * (u.conj * β₀) = (u * u.conj) * (α₀ * β₀) := by ring
+          _ = α₀ * β₀ := by rw [mul_conj, hunorm, Int.cast_one, one_mul]
+  rw [himage]
+  rw [Finset.card_image_of_injOn, card_unitFinset]
+  intro u _ u' _ h
+  have h1 : toPair (u * α₀) = toPair (u' * α₀) := congrArg Prod.fst h
+  exact mul_right_cancel₀ hα₀0 (toPair_injective h1)
+
+theorem orbitCountMultiplicative_holds : OrbitCountMultiplicative := by
+  classical
+  intro m n hmn
+  rcases eq_or_ne m 0 with rfl | hm
+  · have hn1 : n = 1 := by simpa using hmn
+    subst hn1
+    simp [reprCount_zero, reprCount_one]
+  rcases eq_or_ne n 0 with rfl | hn
+  · have hm1 : m = 1 := by simpa using hmn
+    subst hm1
+    simp [reprCount_zero, reprCount_one]
+  have hcount : (reprSols m ×ˢ reprSols n).card
+      = ∑ γp ∈ reprSols (m * n), ((reprSols m ×ˢ reprSols n).filter
+          fun pq => toPair (ofPair pq.1 * ofPair pq.2) = γp).card :=
+    Finset.card_eq_sum_card_fiberwise fun pq hpq => mul_mem_reprSols hpq
+  have hfibers : ∀ γp ∈ reprSols (m * n),
+      ((reprSols m ×ˢ reprSols n).filter
+        fun pq => toPair (ofPair pq.1 * ofPair pq.2) = γp).card = 6 :=
+    fun γp hγp => card_fiber hmn hm hn hγp
+  rw [Finset.sum_congr rfl hfibers, Finset.sum_const, smul_eq_mul] at hcount
+  rw [Finset.card_product] at hcount
+  unfold reprCount
+  omega
+
+end HexInt
+
+open HexInt in
+theorem reprCountEqCoeffE1Chi3_of_splitPrimePowCount (hsplit : SplitPrimePowCount) :
+    ReprCountEqCoeffE1Chi3 :=
+  reprCountEqCoeffE1Chi3_of_residuals orbitCountMultiplicative_holds hsplit
+
+set_option maxRecDepth 16384 in
+theorem reprCount_twentyone : reprCount 21 = 12 := by decide
+
+theorem orbitCount_at_three_seven :
+    6 * reprCount (3 * 7) = reprCount 3 * reprCount 7 :=
+  HexInt.orbitCountMultiplicative_holds 3 7 (by norm_num)
+
+theorem orbitCount_at_three_four :
+    6 * reprCount (3 * 4) = reprCount 3 * reprCount 4 :=
+  HexInt.orbitCountMultiplicative_holds 3 4 (by norm_num)
+
+theorem orbitCount_three_seven_consistency :
+    6 * reprCount 21 = reprCount 3 * reprCount 7 := by
+  rw [reprCount_twentyone, reprCount_three, reprCount_seven]
+
+theorem orbitCount_coprimality_load_bearing :
+    OrbitCountMultiplicative ∧
+      ¬(∀ m n : ℕ, 6 * reprCount (m * n) = reprCount m * reprCount n) :=
+  ⟨HexInt.orbitCountMultiplicative_holds, orbitCountMultiplicative_not_without_coprime⟩
+
+end FLT.AnalyticCore
+end File_FLT_AnalyticCore_OrbitCountMultiplicative
+
+section File_FLT_AnalyticCore_CountIdentification
+
+namespace FLT
+namespace AnalyticCore
+
+open FLT.EisensteinWeightOne
+
+theorem latticeSum_hexForm_eq (v : ℤ × ℤ) : LatticeSum.hexForm v = hexForm v.1 v.2 := by
+  simp only [LatticeSum.hexForm, hexForm]
+  ring
+
+theorem preimage_hexFormNat_eq_coe_reprSols (n : ℕ) :
+    LatticeSum.hexFormNat ⁻¹' {n} = ↑(reprSols n) := by
+  ext v
+  simp only [Set.mem_preimage, Set.mem_singleton_iff, LatticeSum.hexFormNat_eq_iff,
+    Finset.mem_coe, mem_reprSols_iff, latticeSum_hexForm_eq]
+
+theorem repCount_eq_reprCount (n : ℕ) : LatticeSum.repCount n = reprCount n := by
+  rw [LatticeSum.repCount, preimage_hexFormNat_eq_coe_reprSols, Set.ncard_coe_finset]
+  rfl
+
+theorem representationCountAgrees_iff_reprCountEqCoeffE1Chi3 :
+    LatticeSum.RepresentationCountAgrees ↔ ReprCountEqCoeffE1Chi3 := by
+  constructor
+  · intro h n
+    rw [← repCount_eq_reprCount]
+    exact h n
+  · intro h n
+    rw [repCount_eq_reprCount]
+    exact h n
+
+theorem representationCountAgrees_of_reprCountEqCoeffE1Chi3
+    (h : ReprCountEqCoeffE1Chi3) : LatticeSum.RepresentationCountAgrees :=
+  representationCountAgrees_iff_reprCountEqCoeffE1Chi3.mpr h
+
+theorem representationCountAgrees_of_splitPrimePowCount
+    (hsplit : SplitPrimePowCount) : LatticeSum.RepresentationCountAgrees :=
+  representationCountAgrees_of_reprCountEqCoeffE1Chi3
+    (reprCountEqCoeffE1Chi3_of_splitPrimePowCount hsplit)
+
+theorem latticeSum_eq_e1Chi3_qSeries_of_reprCount
+    (h : ReprCountEqCoeffE1Chi3) (z : UpperHalfPlane) :
+    LatticeSum.latticeSum z
+      = ∑' n : ℕ, ((PowerSeries.coeff n e1Chi3 : ℤ) : ℂ) *
+          Complex.exp (2 * (Real.pi : ℂ) * Complex.I * (n : ℂ) * (z : ℂ)) :=
+  LatticeSum.latticeSum_eq_e1Chi3_qSeries
+    (representationCountAgrees_of_reprCountEqCoeffE1Chi3 h) z
+
+theorem repCount_one_two_routes :
+    LatticeSum.repCount 1 = reprCount 1 ∧ LatticeSum.repCount 1 = 6 ∧ reprCount 1 = 6 :=
+  ⟨repCount_eq_reprCount 1, LatticeSum.repCount_one, reprCount_one⟩
+
+theorem latticeSum_repCount_seven : LatticeSum.repCount 7 = 12 := by
+  rw [repCount_eq_reprCount]
+  exact reprCount_seven
+
+theorem latticeSum_repCount_thirteen : LatticeSum.repCount 13 = 12 := by
+  rw [repCount_eq_reprCount]
+  exact reprCount_thirteen
+
+theorem representationCountAgrees_on_table :
+    ∀ n ∈ ({0, 1, 2, 3, 4, 7, 13} : Finset ℕ),
+      (LatticeSum.repCount n : ℤ) = PowerSeries.coeff n e1Chi3 := by
+  intro n hn
+  rw [repCount_eq_reprCount]
+  exact reprCountEqCoeffE1Chi3_on_table n hn
+
+end FLT.AnalyticCore
+end File_FLT_AnalyticCore_CountIdentification
+
+section File_FLT_AnalyticCore_SplitPrimePowCount
+
+namespace FLT
+namespace AnalyticCore
+
+open Finset
+
+def emul (z w : ℤ × ℤ) : ℤ × ℤ :=
+  (z.1 * w.1 - z.2 * w.2, z.1 * w.2 + z.2 * w.1 + z.2 * w.2)
+
+theorem hexForm_emul_mk (a b : ℤ) (w : ℤ × ℤ) :
+    hexForm (emul (a, b) w).1 (emul (a, b) w).2 = hexForm a b * hexForm w.1 w.2 :=
+  (hexForm_mul a b w.1 w.2).symm
+
+theorem hexForm_conj (a b : ℤ) : hexForm (a + b) (-b) = hexForm a b := by
+  simp only [hexForm]; ring
+
+theorem emul_assoc (z w v : ℤ × ℤ) : emul (emul z w) v = emul z (emul w v) := by
+  simp only [emul, Prod.mk.injEq]
+  exact ⟨by ring, by ring⟩
+
+theorem emul_conj_self (a b : ℤ) : emul (a, b) (a + b, -b) = (hexForm a b, 0) := by
+  simp only [emul, hexForm, Prod.mk.injEq]
+  exact ⟨by ring, by ring⟩
+
+theorem emul_conj_self' (a b : ℤ) : emul (a + b, -b) (a, b) = (hexForm a b, 0) := by
+  simp only [emul, hexForm, Prod.mk.injEq]
+  exact ⟨by ring, by ring⟩
+
+theorem emul_intCast (n : ℤ) (z : ℤ × ℤ) : emul (n, 0) z = (n * z.1, n * z.2) := by
+  simp only [emul, Prod.mk.injEq]
+  exact ⟨by ring, by ring⟩
+
+theorem ne_zero_of_hexForm_eq_prime {p : ℕ} (hp : p.Prime) {a b : ℤ}
+    (hπ : hexForm a b = (p : ℤ)) : ¬(a = 0 ∧ b = 0) := by
+  rintro ⟨rfl, rfl⟩
+  have h0 : hexForm (0 : ℤ) 0 = 0 := by simp [hexForm]
+  rw [h0] at hπ
+  exact hp.ne_zero (by exact_mod_cast hπ.symm)
+
+theorem emul_left_cancel {a b : ℤ} (hz : ¬(a = 0 ∧ b = 0)) {w v : ℤ × ℤ}
+    (h : emul (a, b) w = emul (a, b) v) : w = v := by
+  obtain ⟨c, d⟩ := w
+  obtain ⟨e, f⟩ := v
+  simp only [emul, Prod.mk.injEq] at h
+  obtain ⟨h1, h2⟩ := h
+  have hQ : hexForm a b ≠ 0 := fun h0 => hz (hexForm_eq_zero_iff.mp h0)
+  have hc : hexForm a b * (c - e) = 0 := by
+    simp only [hexForm]; linear_combination (a + b) * h1 + b * h2
+  have hd : hexForm a b * (d - f) = 0 := by
+    simp only [hexForm]; linear_combination a * h2 - b * h1
+  have hce : c = e := by
+    rcases mul_eq_zero.mp hc with h | h
+    · exact absurd h hQ
+    · linarith
+  have hdf : d = f := by
+    rcases mul_eq_zero.mp hd with h | h
+    · exact absurd h hQ
+    · linarith
+  exact Prod.ext hce hdf
+
+theorem emul_injOn {a b : ℤ} (hz : ¬(a = 0 ∧ b = 0)) (s : Finset (ℤ × ℤ)) :
+    Set.InjOn (emul (a, b)) ↑s := fun _ _ _ _ h => emul_left_cancel hz h
+
+theorem thue_lemma (p : ℕ) (hp : p.Prime) (t : ZMod p) :
+    ∃ x y : ℤ, ¬(x = 0 ∧ y = 0) ∧ x.natAbs ≤ p.sqrt ∧ y.natAbs ≤ p.sqrt ∧
+      (x : ZMod p) = t * (y : ZMod p) := by
+  have : Fact p.Prime := ⟨hp⟩
+  have hlt : (Finset.univ : Finset (ZMod p)).card <
+      (Finset.range (p.sqrt + 1) ×ˢ Finset.range (p.sqrt + 1)).card := by
+    rw [Finset.card_product, Finset.card_range, Finset.card_univ, ZMod.card]
+    exact Nat.lt_succ_sqrt p
+  obtain ⟨a, ha, b, hb, hab, hfab⟩ :=
+    Finset.exists_ne_map_eq_of_card_lt_of_maps_to hlt
+      (f := fun q : ℕ × ℕ => (q.1 : ZMod p) - t * (q.2 : ZMod p))
+      (fun q _ => Finset.mem_univ _)
+  simp only [Finset.mem_product, Finset.mem_range] at ha hb
+  refine ⟨(a.1 : ℤ) - (b.1 : ℤ), (a.2 : ℤ) - (b.2 : ℤ), ?_, by omega, by omega, ?_⟩
+  · rintro ⟨h1, h2⟩
+    refine hab (Prod.ext ?_ ?_) <;> omega
+  · have hkey : (a.1 : ZMod p) - t * (a.2 : ZMod p)
+        = (b.1 : ZMod p) - t * (b.2 : ZMod p) := hfab
+    push_cast
+    linear_combination hkey
+
+theorem sqrt_mul_self_lt_of_prime {p : ℕ} (hp : p.Prime) : p.sqrt * p.sqrt < p := by
+  rcases lt_or_eq_of_le (Nat.sqrt_le p) with h | h
+  · exact h
+  · exfalso
+    rcases hp.eq_one_or_self_of_dvd p.sqrt ⟨p.sqrt, h.symm⟩ with h1 | h1
+    · rw [h1, one_mul] at h
+      exact hp.one_lt.ne h
+    · rw [h1] at h
+      have h2 := hp.two_le
+      nlinarith
+
+theorem exists_hexForm_eq_prime {p : ℕ} (hp : p.Prime) (h1 : p % 3 = 1) :
+    ∃ x y : ℤ, hexForm x y = (p : ℤ) := by
+  have : Fact p.Prime := ⟨hp⟩
+  have hp3 : p ≠ 3 := by omega
+  obtain ⟨t, ht3⟩ := ModularCurve.exists_orderOf_eq_three hp h1
+  have htroot : t ^ 2 + t + 1 = 0 :=
+    (ModularCurve.sq_add_self_add_one_eq_zero_iff_orderOf_eq_three hp hp3 t).mpr ht3
+  obtain ⟨x, y, hxy0, hxabs, hyabs, hcong⟩ := thue_lemma p hp t
+  have hdvd : (p : ℤ) ∣ hexForm x y := by
+    rw [← ZMod.intCast_zmod_eq_zero_iff_dvd]
+    push_cast [hexForm]
+    linear_combination ((x : ZMod p) + t * (y : ZMod p) + (y : ZMod p)) * hcong +
+      (y : ZMod p) ^ 2 * htroot
+  have hpos : 0 < hexForm x y := by
+    rcases (hexForm_nonneg x y).lt_or_eq with h | h
+    · exact h
+    · exact absurd (hexForm_eq_zero_iff.mp h.symm) hxy0
+  have hsq : (p.sqrt : ℤ) * (p.sqrt : ℤ) < (p : ℤ) := by
+    exact_mod_cast sqrt_mul_self_lt_of_prime hp
+  have hb1 : (0 : ℤ) ≤ ((p.sqrt : ℤ) - x) * ((p.sqrt : ℤ) + x) :=
+    mul_nonneg (by omega) (by omega)
+  have hb2 : (0 : ℤ) ≤ ((p.sqrt : ℤ) - y) * ((p.sqrt : ℤ) + y) :=
+    mul_nonneg (by omega) (by omega)
+  have hb3 : (0 : ℤ) ≤ ((p.sqrt : ℤ) - x) * ((p.sqrt : ℤ) + y) :=
+    mul_nonneg (by omega) (by omega)
+  have hb4 : (0 : ℤ) ≤ ((p.sqrt : ℤ) + x) * ((p.sqrt : ℤ) - y) :=
+    mul_nonneg (by omega) (by omega)
+  have hlt : hexForm x y < 3 * (p : ℤ) := by
+    simp only [hexForm]
+    nlinarith
+  obtain ⟨m, hm⟩ := hdvd
+  have hppos : (0 : ℤ) < (p : ℤ) := by exact_mod_cast hp.pos
+  have hm1 : 0 < m := by
+    rcases lt_trichotomy m 0 with h | h | h
+    · nlinarith [mul_neg_of_pos_of_neg hppos h]
+    · subst h
+      rw [mul_zero] at hm
+      omega
+    · exact h
+  have hm2 : m < 3 := by
+    have hmm : (p : ℤ) * m < (p : ℤ) * 3 := by linarith
+    exact lt_of_mul_lt_mul_left hmm (le_of_lt hppos)
+  interval_cases m
+  · exact ⟨x, y, by linarith⟩
+  · exfalso
+    have h2d : ((2 : ℕ) : ℤ) ∣ hexForm x y := ⟨(p : ℤ), by push_cast; linarith⟩
+    obtain ⟨hx2, hy2⟩ := inert_dvd_of_dvd_hexForm Nat.prime_two (by norm_num) h2d
+    obtain ⟨x', rfl⟩ := hx2
+    obtain ⟨y', rfl⟩ := hy2
+    rw [hexForm_smul] at hm
+    have h2p : ((2 : ℕ) : ℤ) ∣ (p : ℤ) := by
+      refine ⟨hexForm x' y', ?_⟩
+      push_cast at hm ⊢
+      nlinarith [hm]
+    have hpeq : p = 2 :=
+      ((Nat.prime_dvd_prime_iff_eq Nat.prime_two hp).mp (by exact_mod_cast h2p)).symm
+    omega
+
+theorem dvd_fst_of_dvd_snd_of_sq_dvd_hexForm {p : ℕ} (hp : p.Prime) {S T : ℤ}
+    (hN : ((p : ℤ)) ^ 2 ∣ hexForm S T) (hT : (p : ℤ) ∣ T) : (p : ℤ) ∣ S := by
+  have h1 : (p : ℤ) ∣ S * S := by
+    have hrw : S * S = hexForm S T - S * T - T * T := by simp only [hexForm]; ring
+    rw [hrw]
+    exact dvd_sub (dvd_sub ((dvd_pow_self _ two_ne_zero).trans hN) (hT.mul_left S))
+      (hT.mul_left T)
+  rcases Int.Prime.dvd_mul' hp h1 with h | h <;> exact h
+
+theorem exists_eq_emul_conj_of_dvd {p : ℕ} (hp : p.Prime) {a b : ℤ} {z : ℤ × ℤ}
+    (hπ : hexForm a b = (p : ℤ))
+    (hS : (p : ℤ) ∣ (emul (a, b) z).1) (hT : (p : ℤ) ∣ (emul (a, b) z).2) :
+    ∃ v : ℤ × ℤ, z = emul (a + b, -b) v ∧
+      (p : ℤ) * hexForm v.1 v.2 = hexForm z.1 z.2 := by
+  obtain ⟨c, hc⟩ := hS
+  obtain ⟨d, hd⟩ := hT
+  have hw0 : ¬(a = 0 ∧ b = 0) := ne_zero_of_hexForm_eq_prime hp hπ
+  have hkey : emul (a, b) (emul (a + b, -b) (c, d)) = emul (a, b) z := by
+    rw [← emul_assoc, emul_conj_self, hπ, emul_intCast]
+    exact (Prod.ext hc hd).symm
+  have hz : z = emul (a + b, -b) (c, d) := (emul_left_cancel hw0 hkey).symm
+  refine ⟨(c, d), hz, ?_⟩
+  rw [hz, hexForm_emul_mk, hexForm_conj, hπ]
+
+theorem exists_emul_of_dvd_hexForm {p : ℕ} (hp : p.Prime) {a b x y : ℤ}
+    (hπ : hexForm a b = (p : ℤ)) (hz : (p : ℤ) ∣ hexForm x y) :
+    (∃ v : ℤ × ℤ, (x, y) = emul (a, b) v ∧
+        (p : ℤ) * hexForm v.1 v.2 = hexForm x y) ∨
+    (∃ v : ℤ × ℤ, (x, y) = emul (a + b, -b) v ∧
+        (p : ℤ) * hexForm v.1 v.2 = hexForm x y) := by
+  have hπ' : hexForm (a + b) (-b) = (p : ℤ) := (hexForm_conj a b).trans hπ
+  obtain ⟨m, hm⟩ := hz
+  have htt : (p : ℤ) ∣ (emul (a + b, -b) (x, y)).2 * (emul (a, b) (x, y)).2 := by
+    refine ⟨y ^ 2 - b ^ 2 * m, ?_⟩
+    have hrw : (emul (a + b, -b) (x, y)).2 * (emul (a, b) (x, y)).2
+        = y ^ 2 * hexForm a b - b ^ 2 * hexForm x y := by
+      simp only [emul, hexForm]; ring
+    rw [hrw, hπ, hm]
+    ring
+  have hN1 : ((p : ℤ)) ^ 2 ∣
+      hexForm (emul (a + b, -b) (x, y)).1 (emul (a + b, -b) (x, y)).2 := by
+    rw [hexForm_emul_mk]
+    refine ⟨m, ?_⟩
+    have hxy : hexForm ((x : ℤ), (y : ℤ)).1 ((x : ℤ), (y : ℤ)).2 = hexForm x y := rfl
+    rw [hxy, hπ', hm]
+    ring
+  have hN2 : ((p : ℤ)) ^ 2 ∣ hexForm (emul (a, b) (x, y)).1 (emul (a, b) (x, y)).2 := by
+    rw [hexForm_emul_mk]
+    refine ⟨m, ?_⟩
+    have hxy : hexForm ((x : ℤ), (y : ℤ)).1 ((x : ℤ), (y : ℤ)).2 = hexForm x y := rfl
+    rw [hxy, hπ, hm]
+    ring
+  rcases Int.Prime.dvd_mul' hp htt with hT | hT
+  · left
+    have hS := dvd_fst_of_dvd_snd_of_sq_dvd_hexForm hp hN1 hT
+    obtain ⟨v, hv, hnorm⟩ := exists_eq_emul_conj_of_dvd hp hπ' hS hT
+    have hconv : ((a + b) + -b, -(-b)) = ((a : ℤ), (b : ℤ)) := by
+      simp only [Prod.mk.injEq]
+      exact ⟨by ring, by ring⟩
+    rw [hconv] at hv
+    exact ⟨v, hv, hnorm⟩
+  · right
+    have hS := dvd_fst_of_dvd_snd_of_sq_dvd_hexForm hp hN2 hT
+    obtain ⟨v, hv, hnorm⟩ := exists_eq_emul_conj_of_dvd hp hπ hS hT
+    exact ⟨v, hv, hnorm⟩
+
+theorem dvd_of_dvd_lin {p : ℕ} (hp : p.Prime) (h1 : p % 3 = 1) {a b x y : ℤ}
+    (hπ : hexForm a b = (p : ℤ))
+    (hT : (p : ℤ) ∣ a * y - b * x) (hT' : (p : ℤ) ∣ a * y + b * x + b * y) :
+    (p : ℤ) ∣ x ∧ (p : ℤ) ∣ y := by
+  have hp4 : 4 ≤ p := by
+    have h2 := hp.two_le
+    omega
+  have hp4' : (4 : ℤ) ≤ (p : ℤ) := by exact_mod_cast hp4
+  have hpb : ¬ (p : ℤ) ∣ b := by
+    intro hb
+    have ha2 : (p : ℤ) ∣ a * a := by
+      have hrw : a * a = hexForm a b - b * (a + b) := by simp only [hexForm]; ring
+      rw [hrw, hπ]
+      exact dvd_sub (dvd_refl _) (hb.mul_right _)
+    have ha : (p : ℤ) ∣ a := by
+      rcases Int.Prime.dvd_mul' hp ha2 with h | h <;> exact h
+    obtain ⟨a', rfl⟩ := ha
+    obtain ⟨b', rfl⟩ := hb
+    rw [hexForm_smul] at hπ
+    have hppos : (0 : ℤ) < (p : ℤ) := by linarith
+    have hcancel : (p : ℤ) * ((p : ℤ) * hexForm a' b') = (p : ℤ) * 1 := by
+      linear_combination hπ
+    have hone : (p : ℤ) * hexForm a' b' = 1 :=
+      mul_left_cancel₀ hppos.ne' hcancel
+    have hle : (p : ℤ) ≤ 1 := Int.le_of_dvd one_pos ⟨hexForm a' b', hone.symm⟩
+    linarith
+  have h2xy : (p : ℤ) ∣ b * (2 * x + y) := by
+    have hrw : b * (2 * x + y) = (a * y + b * x + b * y) - (a * y - b * x) := by ring
+    rw [hrw]
+    exact dvd_sub hT' hT
+  have hy2ab : (p : ℤ) ∣ y * (2 * a + b) := by
+    have hrw : y * (2 * a + b) = (a * y + b * x + b * y) + (a * y - b * x) := by ring
+    rw [hrw]
+    exact dvd_add hT' hT
+  have h2x : (p : ℤ) ∣ 2 * x + y := by
+    rcases Int.Prime.dvd_mul' hp h2xy with h | h
+    · exact absurd h hpb
+    · exact h
+  have hy : (p : ℤ) ∣ y := by
+    rcases Int.Prime.dvd_mul' hp hy2ab with h | h
+    · exact h
+    · exfalso
+      have h4 : (2 * a + b) ^ 2 + 3 * b ^ 2 = 4 * (p : ℤ) := by
+        rw [← four_mul_hexForm, hπ]
+      have h3b : (p : ℤ) ∣ 3 * (b * b) := by
+        have hrw : 3 * (b * b) = 4 * (p : ℤ) - (2 * a + b) * (2 * a + b) := by
+          linear_combination h4
+        rw [hrw]
+        exact dvd_sub ((dvd_refl _).mul_left 4) (h.mul_left _)
+      rcases Int.Prime.dvd_mul' hp h3b with h3 | hbb
+      · have hle : (p : ℤ) ≤ 3 := Int.le_of_dvd (by norm_num) h3
+        linarith
+      · rcases Int.Prime.dvd_mul' hp hbb with h | h <;> exact hpb h
+  refine ⟨?_, hy⟩
+  have h2x' : (p : ℤ) ∣ 2 * x := by
+    have hrw : 2 * x = (2 * x + y) - y := by ring
+    rw [hrw]
+    exact dvd_sub h2x hy
+  rcases Int.Prime.dvd_mul' hp h2x' with h | h
+  · exfalso
+    have hle : (p : ℤ) ≤ 2 := Int.le_of_dvd (by norm_num) h
+    linarith
+  · exact h
+
+theorem dvd_of_emul_eq_of_emul_eq {p : ℕ} (hp : p.Prime) (h1 : p % 3 = 1) {a b x y : ℤ}
+    (hπ : hexForm a b = (p : ℤ)) {w1 w2 : ℤ × ℤ}
+    (he1 : emul (a, b) w1 = (x, y)) (he2 : emul (a + b, -b) w2 = (x, y)) :
+    (p : ℤ) ∣ x ∧ (p : ℤ) ∣ y := by
+  apply dvd_of_dvd_lin hp h1 hπ
+  · have hchain : emul (a + b, -b) ((x : ℤ), (y : ℤ))
+        = ((p : ℤ) * w1.1, (p : ℤ) * w1.2) := by
+      rw [← he1, ← emul_assoc, emul_conj_self', hπ, emul_intCast]
+    have h2 : (emul (a + b, -b) ((x : ℤ), (y : ℤ))).2 = (p : ℤ) * w1.2 := by
+      rw [hchain]
+    refine ⟨w1.2, ?_⟩
+    have h2' : (a + b) * y + -b * x + -b * y = (p : ℤ) * w1.2 := h2
+    linear_combination h2'
+  · have hchain : emul (a, b) ((x : ℤ), (y : ℤ)) = ((p : ℤ) * w2.1, (p : ℤ) * w2.2) := by
+      rw [← he2, ← emul_assoc, emul_conj_self, hπ, emul_intCast]
+    have h2 : (emul (a, b) ((x : ℤ), (y : ℤ))).2 = (p : ℤ) * w2.2 := by
+      rw [hchain]
+    refine ⟨w2.2, ?_⟩
+    have h2' : a * y + b * x + b * y = (p : ℤ) * w2.2 := h2
+    linear_combination h2'
+
+theorem emul_mem_reprSols {p : ℕ} {a b : ℤ} (hπ : hexForm a b = (p : ℤ)) {n : ℕ}
+    {w : ℤ × ℤ} (hw : w ∈ reprSols n) : emul (a, b) w ∈ reprSols (p * n) := by
+  rw [mem_reprSols_iff, hexForm_emul_mk, hπ, mem_reprSols_iff.mp hw, Nat.cast_mul]
+
+theorem reprSols_mul_eq_union {p : ℕ} (hp : p.Prime) {a b : ℤ}
+    (hπ : hexForm a b = (p : ℤ)) (n : ℕ) :
+    reprSols (p * n) =
+      (reprSols n).image (emul (a, b)) ∪ (reprSols n).image (emul (a + b, -b)) := by
+  have hπ' : hexForm (a + b) (-b) = (p : ℤ) := (hexForm_conj a b).trans hπ
+  have hp0 : (p : ℤ) ≠ 0 := Nat.cast_ne_zero.mpr hp.ne_zero
+  ext q
+  constructor
+  · intro hq
+    obtain ⟨x, y⟩ := q
+    have hQ : hexForm x y = ((p * n : ℕ) : ℤ) := mem_reprSols_iff.mp hq
+    have hdvd : (p : ℤ) ∣ hexForm x y := by
+      rw [hQ, Nat.cast_mul]
+      exact dvd_mul_right _ _
+    rcases exists_emul_of_dvd_hexForm hp hπ hdvd with ⟨v, hv, hnorm⟩ | ⟨v, hv, hnorm⟩
+    · refine Finset.mem_union_left _ (Finset.mem_image.mpr ⟨v, ?_, hv.symm⟩)
+      rw [mem_reprSols_iff]
+      apply mul_left_cancel₀ hp0
+      rw [hnorm, hQ, Nat.cast_mul]
+    · refine Finset.mem_union_right _ (Finset.mem_image.mpr ⟨v, ?_, hv.symm⟩)
+      rw [mem_reprSols_iff]
+      apply mul_left_cancel₀ hp0
+      rw [hnorm, hQ, Nat.cast_mul]
+  · intro hq
+    rcases Finset.mem_union.mp hq with hq | hq
+    · obtain ⟨w, hw, rfl⟩ := Finset.mem_image.mp hq
+      exact emul_mem_reprSols hπ hw
+    · obtain ⟨w, hw, rfl⟩ := Finset.mem_image.mp hq
+      exact emul_mem_reprSols hπ' hw
+
+theorem inter_image_one_eq_empty {p : ℕ} (hp : p.Prime) (h1 : p % 3 = 1) {a b : ℤ}
+    (hπ : hexForm a b = (p : ℤ)) :
+    (reprSols 1).image (emul (a, b)) ∩ (reprSols 1).image (emul (a + b, -b)) = ∅ := by
+  rw [Finset.eq_empty_iff_forall_notMem]
+  rintro ⟨x, y⟩ hq
+  rw [Finset.mem_inter] at hq
+  obtain ⟨w1, hw1, he1⟩ := Finset.mem_image.mp hq.1
+  obtain ⟨w2, hw2, he2⟩ := Finset.mem_image.mp hq.2
+  obtain ⟨hx, hy⟩ := dvd_of_emul_eq_of_emul_eq hp h1 hπ he1 he2
+  have hmem : ((x : ℤ), (y : ℤ)) ∈ reprSols (p * 1) := by
+    rw [← he1]
+    exact emul_mem_reprSols hπ hw1
+  have hQ : hexForm x y = ((p * 1 : ℕ) : ℤ) := mem_reprSols_iff.mp hmem
+  obtain ⟨x', rfl⟩ := hx
+  obtain ⟨y', rfl⟩ := hy
+  rw [hexForm_smul] at hQ
+  have hppos : (0 : ℤ) < (p : ℤ) := by exact_mod_cast hp.pos
+  have hcancel : (p : ℤ) * ((p : ℤ) * hexForm x' y') = (p : ℤ) * 1 := by
+    rw [Nat.mul_one] at hQ
+    linear_combination hQ
+  have hone : (p : ℤ) * hexForm x' y' = 1 := mul_left_cancel₀ hppos.ne' hcancel
+  have hle : (p : ℤ) ≤ 1 := Int.le_of_dvd one_pos ⟨hexForm x' y', hone.symm⟩
+  have hgt := hp.one_lt
+  have hgt' : (1 : ℤ) < (p : ℤ) := by exact_mod_cast hgt
+  linarith
+
+theorem inter_image_eq_dilate {p : ℕ} (hp : p.Prime) (h1 : p % 3 = 1) {a b : ℤ}
+    (hπ : hexForm a b = (p : ℤ)) (m : ℕ) :
+    (reprSols (p * m)).image (emul (a, b)) ∩
+        (reprSols (p * m)).image (emul (a + b, -b))
+      = (reprSols m).image (fun w : ℤ × ℤ => ((p : ℤ) * w.1, (p : ℤ) * w.2)) := by
+  have hπ' : hexForm (a + b) (-b) = (p : ℤ) := (hexForm_conj a b).trans hπ
+  have hp0 : (p : ℤ) ≠ 0 := Nat.cast_ne_zero.mpr hp.ne_zero
+  ext q
+  simp only [Finset.mem_inter, Finset.mem_image]
+  constructor
+  · rintro ⟨⟨w1, hw1, he1⟩, ⟨w2, hw2, he2⟩⟩
+    obtain ⟨x, y⟩ := q
+    obtain ⟨hx, hy⟩ := dvd_of_emul_eq_of_emul_eq hp h1 hπ he1 he2
+    have hmem : ((x : ℤ), (y : ℤ)) ∈ reprSols (p * (p * m)) := by
+      rw [← he1]
+      exact emul_mem_reprSols hπ hw1
+    have hQ : hexForm x y = ((p * (p * m) : ℕ) : ℤ) := mem_reprSols_iff.mp hmem
+    obtain ⟨x', rfl⟩ := hx
+    obtain ⟨y', rfl⟩ := hy
+    refine ⟨(x', y'), ?_, rfl⟩
+    rw [mem_reprSols_iff]
+    rw [hexForm_smul] at hQ
+    have hcancel : (p : ℤ) ^ 2 * hexForm x' y' = (p : ℤ) ^ 2 * (m : ℤ) := by
+      push_cast at hQ
+      linear_combination hQ
+    exact mul_left_cancel₀ (pow_ne_zero 2 hp0) hcancel
+  · rintro ⟨w, hw, heq⟩
+    obtain ⟨c, d⟩ := w
+    refine ⟨⟨emul (a + b, -b) (c, d), emul_mem_reprSols hπ' hw, ?_⟩,
+      ⟨emul (a, b) (c, d), emul_mem_reprSols hπ hw, ?_⟩⟩
+    · rw [← emul_assoc, emul_conj_self, hπ, emul_intCast]
+      exact heq
+    · rw [← emul_assoc, emul_conj_self', hπ, emul_intCast]
+      exact heq
+
+theorem card_image_emul {p : ℕ} (hp : p.Prime) {a b : ℤ} (hπ : hexForm a b = (p : ℤ))
+    (s : Finset (ℤ × ℤ)) : (s.image (emul (a, b))).card = s.card :=
+  Finset.card_image_of_injOn (emul_injOn (ne_zero_of_hexForm_eq_prime hp hπ) s)
+
+theorem card_image_dilate {p : ℕ} (hp : p.Prime) (s : Finset (ℤ × ℤ)) :
+    (s.image (fun w : ℤ × ℤ => ((p : ℤ) * w.1, (p : ℤ) * w.2))).card = s.card := by
+  apply Finset.card_image_of_injOn
+  intro w1 _ w2 _ h
+  have hp0 : (p : ℤ) ≠ 0 := Nat.cast_ne_zero.mpr hp.ne_zero
+  simp only [Prod.mk.injEq] at h
+  exact Prod.ext (mul_left_cancel₀ hp0 h.1) (mul_left_cancel₀ hp0 h.2)
+
+theorem reprCount_eq_twelve_of_split {p : ℕ} (hp : p.Prime) (h1 : p % 3 = 1) :
+    reprCount p = 12 := by
+  obtain ⟨a, b, hπ⟩ := exists_hexForm_eq_prime hp h1
+  have hπ' : hexForm (a + b) (-b) = (p : ℤ) := (hexForm_conj a b).trans hπ
+  have hcui := Finset.card_union_add_card_inter ((reprSols 1).image (emul (a, b)))
+    ((reprSols 1).image (emul (a + b, -b)))
+  rw [inter_image_one_eq_empty hp h1 hπ, Finset.card_empty, card_image_emul hp hπ,
+    card_image_emul hp hπ'] at hcui
+  have hone : (reprSols 1).card = 6 := reprCount_one
+  have hgoal : reprCount (p * 1) = 12 := by
+    change (reprSols (p * 1)).card = 12
+    rw [reprSols_mul_eq_union hp hπ 1]
+    omega
+  simpa using hgoal
+
+theorem reprCount_mul_mul {p : ℕ} (hp : p.Prime) (h1 : p % 3 = 1) {a b : ℤ}
+    (hπ : hexForm a b = (p : ℤ)) (m : ℕ) :
+    reprCount (p * (p * m)) + reprCount m = 2 * reprCount (p * m) := by
+  have hπ' : hexForm (a + b) (-b) = (p : ℤ) := (hexForm_conj a b).trans hπ
+  have hcui := Finset.card_union_add_card_inter
+    ((reprSols (p * m)).image (emul (a, b)))
+    ((reprSols (p * m)).image (emul (a + b, -b)))
+  rw [inter_image_eq_dilate hp h1 hπ m, card_image_dilate hp, card_image_emul hp hπ,
+    card_image_emul hp hπ'] at hcui
+  change (reprSols (p * (p * m))).card + (reprSols m).card = 2 * (reprSols (p * m)).card
+  rw [reprSols_mul_eq_union hp hπ (p * m)]
+  omega
+
+theorem splitPrimePowCount : SplitPrimePowCount := by
+  intro p k hp h1
+  obtain ⟨a, b, hπ⟩ := exists_hexForm_eq_prime hp h1
+  suffices h : ∀ j : ℕ, reprCount (p ^ j) = 6 * (j + 1) ∧
+      reprCount (p ^ (j + 1)) = 6 * (j + 1 + 1) from (h k).1
+  intro j
+  induction j with
+  | zero =>
+    refine ⟨?_, ?_⟩
+    · simpa using reprCount_one
+    · simpa using reprCount_eq_twelve_of_split hp h1
+  | succ j ih =>
+    refine ⟨ih.2, ?_⟩
+    have hrec := reprCount_mul_mul hp h1 hπ (p ^ j)
+    rw [show p * (p * p ^ j) = p ^ (j + 1 + 1) by ring,
+      show p * p ^ j = p ^ (j + 1) by ring] at hrec
+    omega
+
+theorem reprCountEqCoeffE1Chi3 : ReprCountEqCoeffE1Chi3 :=
+  reprCountEqCoeffE1Chi3_of_residuals HexInt.orbitCountMultiplicative_holds
+    splitPrimePowCount
+
+theorem reprCount_seven_of_split : reprCount 7 = 12 :=
+  reprCount_eq_twelve_of_split (by norm_num) (by norm_num)
+
+theorem reprCount_thirteen_of_split : reprCount 13 = 12 :=
+  reprCount_eq_twelve_of_split (by norm_num) (by norm_num)
+
+theorem hexForm_two_one : hexForm 2 1 = 7 := by decide
+
+theorem not_exists_hexForm_eq_two : ¬∃ x y : ℤ, hexForm x y = ((2 : ℕ) : ℤ) := by
+  rintro ⟨x, y, hxy⟩
+  have hmem : ((x : ℤ), (y : ℤ)) ∈ reprSols 2 := mem_reprSols_iff.mpr hxy
+  have h2 : (reprSols 2).card = 0 := reprCount_two
+  rw [Finset.card_eq_zero] at h2
+  rw [h2] at hmem
+  exact absurd hmem (Finset.notMem_empty _)
+
+end FLT.AnalyticCore
+end File_FLT_AnalyticCore_SplitPrimePowCount
+
+section File_FLT_AnalyticCore_E1Chi3Modular
+
+open Complex Real CongruenceSubgroup
+open FLT.AnalyticCore.LatticeSum FLT.EisensteinWeightOne
+open scoped UpperHalfPlane
+
+namespace FLT
+namespace AnalyticCore
+
+noncomputable section
+
+theorem representationCountAgrees : RepresentationCountAgrees :=
+  representationCountAgrees_of_reprCountEqCoeffE1Chi3 reprCountEqCoeffE1Chi3
+
+theorem e1Chi3IsModular : E1Chi3IsModular :=
+  e1Chi3IsModular_of_repCount representationCountAgrees
+
+def e1Chi3ModularForm : ModularForm (Gamma1 3) 1 :=
+  e1Chi3IsModular.choose
+
+theorem e1Chi3ModularForm_apply (z : UpperHalfPlane) :
+    e1Chi3ModularForm z = ∑' n : ℕ,
+      ((PowerSeries.coeff n e1Chi3 : ℤ) : ℂ) *
+        Complex.exp (2 * (Real.pi : ℂ) * Complex.I * (n : ℂ) * (z : ℂ)) :=
+  e1Chi3IsModular.choose_spec z
+
+theorem e1Chi3ModularForm_eq_latticeSum (z : UpperHalfPlane) :
+    e1Chi3ModularForm z = latticeSum z := by
+  rw [e1Chi3ModularForm_apply]
+  exact (latticeSum_eq_e1Chi3_qSeries representationCountAgrees z).symm
+
+theorem e1Chi3ModularForm_ne_zero : e1Chi3ModularForm ≠ 0 := by
+  intro h
+  have hpt : e1Chi3ModularForm ⟨frickeFixedPoint, frickeFixedPoint_im_pos⟩ = 0 := by
+    rw [h]; rfl
+  rw [e1Chi3ModularForm_eq_latticeSum, latticeSum_eq_hexTheta] at hpt
+  exact hexTheta_frickeFixedPoint_ne_zero hpt
+
+def mulE1Chi3 (g : CuspForm (Gamma1 3) 1) : CuspForm (Gamma1 3) 2 :=
+  CuspForm.mcast (by norm_num) (g.mulModularForm e1Chi3ModularForm)
+
+theorem mulE1Chi3_apply (g : CuspForm (Gamma1 3) 1) (z : UpperHalfPlane) :
+    mulE1Chi3 g z = g z * e1Chi3ModularForm z :=
+  rfl
+
+theorem exists_cuspForm_two_mul_e1Chi3 (g : CuspForm (Gamma1 3) 1) :
+    ∃ h : CuspForm (Gamma1 3) 2, ∀ z : UpperHalfPlane,
+      h z = g z * ∑' n : ℕ,
+        ((PowerSeries.coeff n e1Chi3 : ℤ) : ℂ) *
+          Complex.exp (2 * (Real.pi : ℂ) * Complex.I * (n : ℂ) * (z : ℂ)) :=
+  ⟨mulE1Chi3 g, fun z => by rw [mulE1Chi3_apply, e1Chi3ModularForm_apply]⟩
+
+end
+end FLT.AnalyticCore
+end File_FLT_AnalyticCore_E1Chi3Modular
+end S17E1
+
+theorem solution : EisensteinWeightOne.E1Chi3IsModular := by
+  obtain ⟨f, hf⟩ := S17E1.FLT.AnalyticCore.e1Chi3IsModular
+  exact ⟨f, fun z => by rw [hf z]; rfl⟩
+
+end S_EisensteinWeightOne_e1Chi3IsModular
+end P2MW
+export P2MW.S_EisensteinWeightOne_e1Chi3IsModular (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open EisensteinWeightOne
+theorem EisensteinWeightOne.e1Chi3IsModular :
+    EisensteinWeightOne.E1Chi3IsModular :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Field_nonempty_ringHom_complex_of_countable.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Field_nonempty_ringHom_complex_of_countable.lean
new file mode 100644
index 0000000000..b4401ca6f5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Field_nonempty_ringHom_complex_of_countable.lean
@@ -0,0 +1,118 @@
+/-
+Based on Prove2Me node Field.nonempty_ringHom_complex_of_countable
+(b0d9247e-2403-5333-8974-53b3fcd60c6b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 49ffa1c1-9056-5743-88c2-7a71f441c292
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Basic.Complex.Basic
+public import Mathlib.Basic.Countable.Defs
+
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.FieldTheory.IsAlgClosed.Classification
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Countable fields of characteristic zero embed into ℂ
+
+Theorem statement: `Field.nonempty_ringHom_complex_of_countable`
+(`b0d9247e-2403-5333-8974-53b3fcd60c6b`), by Claude, 2026-09-05.
+
+Proof: submission `49ffa1c1-9056-5743-88c2-7a71f441c292`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a type in an arbitrary universe, equipped with a field structure, of characteristic zero,
+and countable (in the sense that its underlying type admits an injection into $\mathbb{N}$, i.e. is
+finite or countably infinite). The assertion is that the type $K \to+^* \mathbb{C}$ of ring
+homomorphisms from $K$ to the field of complex numbers is nonempty: there exists at least one ring
+homomorphism $K \to \mathbb{C}$. Since $K$ is a field, any such homomorphism is automatically
+injective, so the conclusion is an embedding of $K$ as a subfield of $\mathbb{C}$; the statement
+itself, however, asserts only the existence of a ring homomorphism, with no further properties and
+no compatibility with prescribed data. Note that the conclusion is a statement of nonemptiness (a
+`Prop`), not a chosen map, and that the universe of $K$ is unrestricted, so the cardinality
+comparison involved is a cross-universe one.
+
+This is the set-theoretic half of the Lefschetz principle for countable fields of characteristic
+zero. It is used to transfer a statement about $j$-invariants and modular polynomials from an
+arbitrary countable characteristic-zero base field to $\mathbb{C}$, in the proof of
+[`WeierstrassCurve.Affine.
+eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward`]
+(thm.html#WeierstrassCurve.Affine.
+eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Field_nonempty_ringHom_complex_of_countable.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_Field_nonempty_ringHom_complex_of_countable
+
+open Cardinal
+
+universe u
+
+theorem solution
+    (K : Type u) [Field K] [CharZero K] [Countable K] : Nonempty (K →+* ℂ) := by
+  classical
+  have : FaithfulSMul ℚ K :=
+    (faithfulSMul_iff_algebraMap_injective ℚ K).2 (algebraMap ℚ K).injective
+  have : FaithfulSMul ℚ ℂ :=
+    (faithfulSMul_iff_algebraMap_injective ℚ ℂ).2 (algebraMap ℚ ℂ).injective
+  obtain ⟨s, hs⟩ := exists_isTranscendenceBasis ℚ K
+  obtain ⟨t, ht⟩ := exists_isTranscendenceBasis ℚ ℂ
+  have hct : #ℂ = #t :=
+    IsAlgClosed.cardinal_eq_cardinal_transcendence_basis_of_aleph0_lt' (R := ℚ) _ ht
+      mk_le_aleph0 (by rw [mk_complex]; exact aleph0_lt_continuum)
+  have h1 : Cardinal.lift.{0} #s ≤ Cardinal.lift.{u} #t := by
+    rw [← hct, mk_complex, lift_continuum]
+    calc Cardinal.lift.{0} #s ≤ Cardinal.lift.{0} ℵ₀ := lift_le.2 mk_le_aleph0
+      _ = ℵ₀ := lift_aleph0
+      _ ≤ 𝔠 := aleph0_le_continuum
+  obtain ⟨e⟩ := Cardinal.lift_mk_le'.1 h1
+  have hind : AlgebraicIndependent ℚ (fun i : s => ((e i : t) : ℂ)) :=
+    ht.1.comp e e.injective
+  set A := Algebra.adjoin ℚ (Set.range ((↑) : s → K)) with hA
+  let g : A →ₐ[ℚ] ℂ :=
+    (MvPolynomial.aeval (fun i : s => ((e i : t) : ℂ))).comp hs.1.aevalEquiv.symm.toAlgHom
+  have hg : Function.Injective g :=
+    (algebraicIndependent_iff_injective_aeval.1 hind).comp hs.1.aevalEquiv.symm.injective
+  have : Algebra.IsAlgebraic A K := hs.isAlgebraic
+  let : Algebra A ℂ := g.toRingHom.toAlgebra
+  have : Module.IsTorsionFree A ℂ :=
+    Module.isTorsionFree_iff_algebraMap_injective.mpr hg
+  have : Module.IsTorsionFree A K :=
+    Module.isTorsionFree_iff_algebraMap_injective.mpr Subtype.val_injective
+  exact ⟨(IsAlgClosed.lift (R := A) (S := K) (M := ℂ)).toRingHom⟩
+
+end S_Field_nonempty_ringHom_complex_of_countable
+end P2MW
+export P2MW.S_Field_nonempty_ringHom_complex_of_countable (solution)
+
+end privateSection
+
+public section publicSection
+
+
+universe u
+theorem Field.nonempty_ringHom_complex_of_countable
+    (K : Type u) [Field K] [CharZero K] [Countable K]
+    : Nonempty (K →+* ℂ) :=
+  solution K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_charEq_on_torsionBy_of_line_of_isotropic.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_charEq_on_torsionBy_of_line_of_isotropic.lean
new file mode 100644
index 0000000000..ebc790f0a1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_charEq_on_torsionBy_of_line_of_isotropic.lean
@@ -0,0 +1,201 @@
+/-
+Based on Prove2Me node FrobeniusEndo.charEq_on_torsionBy_of_line_of_isotropic
+(67890f76-48e1-5f59-a7a0-2d55a92a1ff0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f05fd6cb-a139-5abd-afc4-53e210da18c9
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusEndo
+public import Mathlib.LinearAlgebra.Determinant
+
+import Mathlib.LinearAlgebra.Dimension.Free
+import Mathlib.FieldTheory.Finiteness
+import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_trace_det_frob_of_line_of_isotropic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Characteristic equation of σ on p-torsion at an isotropic prime
+
+Theorem statement: `FrobeniusEndo.charEq_on_torsionBy_of_line_of_isotropic`
+(`67890f76-48e1-5f59-a7a0-2d55a92a1ff0`), by Claude, 2026-09-05.
+
+Proof: submission `f05fd6cb-a139-5abd-afc4-53e210da18c9`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R\to S\to K$ be a tower of commutative rings with $K$ a field, $W$ a Weierstrass curve over
+$R$, and $\sigma$ an $S$-algebra automorphism of $K$, acting on the group
+$(W\!\!\restriction_K).\mathrm{Point}$ of $K$-points of the base change of $W$ to $K$; let $p$ be a
+prime. Write $\mathrm{frobEnd}\,W\,\sigma$ for the additive endomorphism of this group induced by
+$\sigma$, and, for integers $m,n$,
+$\mathrm{kerDeg}(\psi,m,n)=\mathrm{Nat.card}\,\ker\big(m\cdot\mathrm{id}-n\cdot\psi\big)$ (so $0$
+when the kernel is infinite). Assume: the $p$-torsion submodule $\{P : pP=0\}$ of
+$(W\!\!\restriction_K).\mathrm{Point}$ has cardinality exactly $p^2$; $p\neq 0$ in $K$; there are
+$a\in\mathbb{Z}$ and $q\in\mathbb{N}$ such that for every natural $m$ with $1\le m\le 2p$ and $m\neq
+0$ in $K$ one has $\mathrm{kerDeg}(\mathrm{frobEnd}\,W\,\sigma,m,1)=m^2-am+q$, and this quantity is
+nonzero for all such $m$; and $X^2-\bar aX+\bar q$ has a root in $\mathbb{Z}/p$. Then for every
+$K$-point $P$ with $p\cdot P=0$ one has $\sigma(\sigma P)-a\,\sigma P+q\,P=0$, the multiples being
+integer scalar multiples in the group of points.
+
+This is the pointwise characteristic equation for the action of $\sigma$ on the $p$-torsion, in the
+shape used for the Frobenius of an elliptic curve over a finite field: from the linear growth of the
+kernel counts $\#\ker(m-\sigma)$ along the line $m^2-am+q$ one recovers the trace and determinant of
+$\sigma$ on the two-dimensional $\mathbb{F}_p$-space of $p$-torsion, and hence the relation
+$\sigma^2-a\sigma+q=0$ on that space. It feeds
+[`FrobeniusEndo.frobCharEqOnPoints_of_line`](thm.html#FrobeniusEndo.frobCharEqOnPoints_of_line),
+where the relation at a single auxiliary prime at which $X^2-aX+q$ splits is promoted to an identity
+on all points.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_FrobeniusEndo_charEq_on_torsionBy_of_line_of_isotropic.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_FrobeniusEndo_charEq_on_torsionBy_of_line_of_isotropic
+
+p2m_open "WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo \
+  P2MW.S_FrobeniusEndo_charEq_on_torsionBy_of_line_of_isotropic.FrobeniusEndo"
+
+namespace FrobeniusEndo
+p2m_export "FrobeniusEndo" "kerDeg frobEnd trace_det_frob_of_line_of_isotropic"
+p2m_open "FrobeniusEndo"
+
+section CayleyHamilton
+
+variable {R M : Type*} [CommRing R] [AddCommGroup M] [Module R M]
+
+theorem linearMap_mul_sub_trace_smul_add_det_smul_of_basis_fin_two
+    (b : Module.Basis (Fin 2) R M) (φ : M →ₗ[R] M) :
+    φ * φ - (LinearMap.trace R M φ) • φ + (LinearMap.det φ) • (1 : M →ₗ[R] M) = 0 := by
+  classical
+  have hmat : ∀ A : Matrix (Fin 2) (Fin 2) R,
+      A * A - A.trace • A + A.det • (1 : Matrix (Fin 2) (Fin 2) R) = 0 := by
+    intro A
+    ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp [Matrix.mul_apply, Fin.sum_univ_two, Matrix.trace_fin_two, Matrix.det_fin_two,
+        Matrix.add_apply, Matrix.sub_apply, Matrix.smul_apply, smul_eq_mul] <;>
+      ring
+  apply (LinearMap.toMatrix b b).injective
+  have htr : LinearMap.trace R M φ = (LinearMap.toMatrix b b φ).trace :=
+    LinearMap.trace_eq_matrix_trace R b φ
+  have hdet : LinearMap.det φ = (LinearMap.toMatrix b b φ).det :=
+    (LinearMap.det_toMatrix b φ).symm
+  have hone : LinearMap.toMatrix b b (1 : M →ₗ[R] M) = (1 : Matrix (Fin 2) (Fin 2) R) := by
+    simp
+  rw [map_add, map_sub, map_smul, map_smul, _root_.map_zero, LinearMap.toMatrix_mul b, hone,
+    htr, hdet]
+  exact hmat _
+
+end CayleyHamilton
+
+section RankTwo
+
+variable {p : ℕ} [Fact p.Prime] {V : Type*} [AddCommGroup V] [Module (ZMod p) V]
+
+theorem finrank_eq_two_of_natCard (hV : Nat.card V = p ^ 2) : Module.finrank (ZMod p) V = 2 := by
+  have : Finite V :=
+    Nat.finite_of_card_ne_zero (by rw [hV]; exact pow_ne_zero 2 (Fact.out : p.Prime).ne_zero)
+  have h := Module.natCard_eq_pow_finrank (K := ZMod p) (V := V)
+  rw [hV, Nat.card_zmod] at h
+  exact (Nat.pow_right_injective (Fact.out : p.Prime).two_le h).symm
+
+noncomputable def basisOfNatCard (hV : Nat.card V = p ^ 2) : Module.Basis (Fin 2) (ZMod p) V :=
+  haveI : Finite V := Nat.finite_of_card_ne_zero (by
+    rw [hV]; exact pow_ne_zero 2 (Fact.out : p.Prime).ne_zero)
+  Module.finBasisOfFinrankEq (ZMod p) V (finrank_eq_two_of_natCard hV)
+
+end RankTwo
+
+section Pencil
+
+variable {R : Type*} {S : Type*} {K : Type*} [CommRing R] [CommRing S] [Field K] [DecidableEq K]
+  [Algebra R S] [Algebra R K] [Algebra S K] [IsScalarTower R S K]
+  (W : WeierstrassCurve R) (σ : K ≃ₐ[S] K) (p : ℕ)
+
+lemma coe_galois_smul_torsionBy (x : Submodule.torsionBy ℤ (W⁄K).Point p) :
+    ((σ • x : Submodule.torsionBy ℤ (W⁄K).Point p) : (W⁄K).Point) = σ • (x : (W⁄K).Point) :=
+  rfl
+
+end Pencil
+
+section Endgame
+
+variable {R : Type*} {S : Type*} {K : Type*} [CommRing R] [CommRing S] [Field K] [DecidableEq K]
+  [Algebra R S] [Algebra R K] [Algebra S K] [IsScalarTower R S K]
+  (W : WeierstrassCurve R) (σ : K ≃ₐ[S] K) (p : ℕ) [Fact p.Prime]
+
+theorem charEq_on_torsionBy_of_isotropic
+    (hfull : Nat.card (Submodule.torsionBy ℤ (W⁄K).Point p) = p ^ 2) (hpK : (p : K) ≠ 0) {a : ℤ}
+    {q : ℕ}
+    (hline : ∀ m : ℕ, 1 ≤ m → m ≤ 2 * p → (m : K) ≠ 0 →
+      ((kerDeg (frobEnd W σ) m 1 : ℕ) : ℤ) = (m : ℤ) ^ 2 - a * m + q)
+    (hpos : ∀ m : ℕ, 1 ≤ m → m ≤ 2 * p → (m : K) ≠ 0 → kerDeg (frobEnd W σ) m 1 ≠ 0)
+    (hiso : ∃ c : ZMod p, c ^ 2 - (a : ZMod p) * c + (q : ZMod p) = 0)
+    (P : (W⁄K).Point) (hP : (p : ℤ) • P = 0) :
+    σ • (σ • P) - a • (σ • P) + (q : ℤ) • P = 0 := by
+  classical
+  obtain ⟨htr, hdet⟩ := trace_det_frob_of_line_of_isotropic W σ p hfull hpK a q hline hpos hiso
+  rw [galoisTrace_def] at htr
+  have hEnd := linearMap_mul_sub_trace_smul_add_det_smul_of_basis_fin_two (basisOfNatCard hfull)
+    (galoisRepModuleEnd S W p σ)
+  rw [htr, hdet] at hEnd
+  rw [show ((q : ZMod p)) = (((q : ℤ) : ZMod p)) by push_cast; ring] at hEnd
+  rw [Int.cast_smul_eq_zsmul, Int.cast_smul_eq_zsmul] at hEnd
+  have hmem : P ∈ Submodule.torsionBy ℤ (W⁄K).Point p := (Submodule.mem_torsionBy_iff _ _).mpr hP
+  have hx := LinearMap.ext_iff.mp hEnd ⟨P, hmem⟩
+  simp only [LinearMap.add_apply, LinearMap.sub_apply, LinearMap.smul_apply,
+    Module.End.mul_apply, Module.End.one_apply, LinearMap.zero_apply] at hx
+  have hcoe := congrArg Subtype.val hx
+  simpa only [Submodule.coe_sub, Submodule.coe_add, Submodule.coe_smul_of_tower,
+    galoisRepModuleEnd_apply, coe_galois_smul_torsionBy, ZeroMemClass.coe_zero] using hcoe
+
+end Endgame
+
+end FrobeniusEndo
+
+theorem solution {R : Type*} {S : Type*} {K : Type*} [CommRing R] [CommRing S] [Field K]
+  [DecidableEq K] [Algebra R S] [Algebra R K] [Algebra S K] [IsScalarTower R S K] (W :
+  WeierstrassCurve R) (σ : K ≃ₐ[S] K) (p : ℕ) [Fact p.Prime] (hfull : Nat.card (Submodule.torsionBy
+  ℤ (W⁄K).Point p) = p ^ 2) (hpK : (p : K) ≠ 0) (a : ℤ) (q : ℕ) (hline : ∀ m : ℕ, 1 ≤ m → m ≤ 2 * p
+  → (m : K) ≠ 0 → ((kerDeg (frobEnd W σ) m 1 : ℕ) : ℤ) = (m : ℤ) ^ 2 - a * m + q) (hpos : ∀ m : ℕ, 1
+  ≤ m → m ≤ 2 * p → (m : K) ≠ 0 → kerDeg (frobEnd W σ) m 1 ≠ 0) (hiso : ∃ c : ZMod p, c ^ 2 - (a :
+  ZMod p) * c + (q : ZMod p) = 0) (P : (W⁄K).Point) (hP : (p : ℤ) • P = 0) :
+    σ • (σ • P) - a • (σ • P) + (q : ℤ) • P = 0 :=
+  FrobeniusEndo.charEq_on_torsionBy_of_isotropic W σ p hfull hpK hline hpos hiso P hP
+
+end S_FrobeniusEndo_charEq_on_torsionBy_of_line_of_isotropic
+end P2MW
+export P2MW.S_FrobeniusEndo_charEq_on_torsionBy_of_line_of_isotropic (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo
+
+theorem FrobeniusEndo.charEq_on_torsionBy_of_line_of_isotropic {R : Type*} {S : Type*} {K : Type*}
+  [CommRing R] [CommRing S] [Field K] [DecidableEq K] [Algebra R S] [Algebra R K] [Algebra S K]
+  [IsScalarTower R S K] (W : WeierstrassCurve R) (σ : K ≃ₐ[S] K) (p : ℕ) [Fact p.Prime] (hfull :
+  Nat.card (Submodule.torsionBy ℤ (W⁄K).Point p) = p ^ 2) (hpK : (p : K) ≠ 0) (a : ℤ) (q : ℕ) (hline
+  : ∀ m : ℕ, 1 ≤ m → m ≤ 2 * p → (m : K) ≠ 0 → ((kerDeg (frobEnd W σ) m 1 : ℕ) : ℤ) = (m : ℤ) ^ 2 -
+  a * m + q) (hpos : ∀ m : ℕ, 1 ≤ m → m ≤ 2 * p → (m : K) ≠ 0 → kerDeg (frobEnd W σ) m 1 ≠ 0) (hiso
+  : ∃ c : ZMod p, c ^ 2 - (a : ZMod p) * c + (q : ZMod p) = 0) (P : (W⁄K).Point) (hP : (p : ℤ) • P =
+  0) :
+    σ • (σ • P) - a • (σ • P) + (q : ℤ) • P = 0 :=
+  solution W σ p hfull hpK a q hline hpos hiso P hP
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_det_frobPencilEnd_eq_zero_iff_dvd_kerDeg.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_det_frobPencilEnd_eq_zero_iff_dvd_kerDeg.lean
new file mode 100644
index 0000000000..36555a9aac
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_det_frobPencilEnd_eq_zero_iff_dvd_kerDeg.lean
@@ -0,0 +1,169 @@
+/-
+Based on Prove2Me node FrobeniusEndo.det_frobPencilEnd_eq_zero_iff_dvd_kerDeg
+(a3aa1ea4-c840-55bc-ab5b-e662f9e8a3cc) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 06de0199-abd1-5669-8f61-5717b335730b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusEndo
+public import Mathlib.LinearAlgebra.Determinant
+
+import Mathlib.GroupTheory.Perm.Cycle.Type
+import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_dvd_kerDeg_of_det_frobPencilEnd_eq_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Vanishing of det(̄ m-̄ nσ) on p-torsion versus p∣#ker
+
+Theorem statement: `FrobeniusEndo.det_frobPencilEnd_eq_zero_iff_dvd_kerDeg`
+(`a3aa1ea4-c840-55bc-ab5b-e662f9e8a3cc`), by Claude, 2026-09-05.
+
+Proof: submission `06de0199-abd1-5669-8f61-5717b335730b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$, $S$ be commutative rings and $K$ a field, with algebra structures making $R\to S\to K$ a
+scalar tower, let $W$ be a Weierstrass curve over $R$, let $\sigma$ be an $S$-algebra automorphism
+of $K$, and let $p$ be a prime. Write $(W\!\downharpoonright\!K)$ for the base change of $W$ to $K$
+and $(W\!\downharpoonright\!K).\mathrm{Point}$ for its group of $K$-points; $\sigma$ acts on this
+group, and `frobEnd W σ` is the resulting additive endomorphism. For integers $m,n$, `kerDeg
+(frobEnd W σ) m n` is the cardinality (in the sense of `Nat.card`, hence $0$ for an infinite set) of
+the kernel of the additive endomorphism $m\cdot\mathrm{id}-n\cdot\sigma$ of
+$(W\!\downharpoonright\!K).\mathrm{Point}$, and `frobPencilEnd W σ p m n` is the
+$\mathbb{Z}/p$-linear endomorphism $\bar m\cdot 1-\bar n\cdot\rho(\sigma)$ of the $p$-torsion
+submodule $\{P: p\cdot P=0\}$, where $\rho(\sigma)$ is the endomorphism induced by the action of
+$\sigma$. Assume the $p$-torsion submodule has nonzero `Nat.card` (i.e. is finite) and that
+$\mathrm{kerDeg}(\mathrm{frobEnd}\ W\ \sigma)\ m\ n\neq 0$. Then $\det(\bar m\cdot1-\bar
+n\cdot\rho(\sigma))=0$ if and only if $p$ divides $\mathrm{kerDeg}(\mathrm{frobEnd}\ W\ \sigma)\ m\
+n$.
+
+This is the dictionary between the kernel counts $\#\ker(m-n\sigma)$ on $K$-points and the
+eigenvalues of $\sigma$ on the $p$-torsion: $\bar m/\bar n$ is an eigenvalue of the mod $p$ Galois
+representation exactly when $p$ divides the kernel count. It is used in the computation of the trace
+and determinant of Frobenius on $p$-torsion from kernel degrees, via
+[`FrobeniusEndo.trace_det_frob_of_line_of_isotropic`]
+(thm.html#FrobeniusEndo.trace_det_frob_of_line_of_isotropic).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_FrobeniusEndo_det_frobPencilEnd_eq_zero_iff_dvd_kerDeg.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_FrobeniusEndo_det_frobPencilEnd_eq_zero_iff_dvd_kerDeg
+
+p2m_open "WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo \
+  P2MW.S_FrobeniusEndo_det_frobPencilEnd_eq_zero_iff_dvd_kerDeg.FrobeniusEndo"
+
+namespace FrobeniusEndo
+p2m_export "FrobeniusEndo" "linePencil linePencil_apply kerDeg kerDeg_def frobEnd frobEnd_apply \
+  frobPencilEnd dvd_kerDeg_of_det_frobPencilEnd_eq_zero"
+p2m_open "FrobeniusEndo"
+
+section Pencil
+
+variable {R : Type*} {S : Type*} {K : Type*} [CommRing R] [CommRing S] [Field K] [DecidableEq K]
+  [Algebra R S] [Algebra R K] [Algebra S K] [IsScalarTower R S K]
+  (W : WeierstrassCurve R) (σ : K ≃ₐ[S] K) (p : ℕ)
+
+lemma coe_galois_smul_torsionBy (x : Submodule.torsionBy ℤ (W⁄K).Point p) :
+    ((σ • x : Submodule.torsionBy ℤ (W⁄K).Point p) : (W⁄K).Point) = σ • (x : (W⁄K).Point) :=
+  rfl
+
+lemma coe_frobPencilEnd_apply (m n : ℤ) (x : Submodule.torsionBy ℤ (W⁄K).Point p) :
+    ((frobPencilEnd W σ p m n x : Submodule.torsionBy ℤ (W⁄K).Point p) : (W⁄K).Point)
+      = linePencil (frobEnd W σ) m n x := by
+  simp only [LinearMap.sub_apply, LinearMap.smul_apply, Module.End.one_apply, linePencil_apply,
+    frobEnd_apply, Int.cast_smul_eq_zsmul, Submodule.coe_sub, Submodule.coe_smul_of_tower]
+  rfl
+
+lemma frobPencilEnd_eq_zero_iff (m n : ℤ) (x : Submodule.torsionBy ℤ (W⁄K).Point p) :
+    frobPencilEnd W σ p m n x = 0 ↔ (x : (W⁄K).Point) ∈ (linePencil (frobEnd W σ) m n).ker := by
+  rw [AddMonoidHom.mem_ker, ← coe_frobPencilEnd_apply, ZeroMemClass.coe_eq_zero]
+
+lemma frobPencilEnd_natCast_one (m : ℕ) :
+    frobPencilEnd W σ p (m : ℤ) 1
+      = (m : ZMod p) • (1 : Module.End (ZMod p) (Submodule.torsionBy ℤ (W⁄K).Point p))
+          - galoisRepModuleEnd S W p σ := by
+  simp only [frobPencilEnd, Int.cast_natCast, Int.cast_one, one_smul]
+
+end Pencil
+
+section Dictionary
+
+variable {R : Type*} {S : Type*} {K : Type*} [CommRing R] [CommRing S] [Field K] [DecidableEq K]
+  [Algebra R S] [Algebra R K] [Algebra S K] [IsScalarTower R S K]
+  (W : WeierstrassCurve R) (σ : K ≃ₐ[S] K) (p : ℕ) [Fact p.Prime]
+
+theorem det_eq_zero_of_dvd_kerDeg [Finite (Submodule.torsionBy ℤ (W⁄K).Point p)] {m n : ℤ}
+    (hpos : kerDeg (frobEnd W σ) m n ≠ 0) (hdvd : p ∣ kerDeg (frobEnd W σ) m n) :
+    LinearMap.det (frobPencilEnd W σ p m n) = 0 := by
+  have hfin : Finite ((linePencil (frobEnd W σ) m n).ker) := Nat.finite_of_card_ne_zero hpos
+  have : Fintype ((linePencil (frobEnd W σ) m n).ker) := Fintype.ofFinite _
+  have hdvd' : p ∣ Fintype.card ((linePencil (frobEnd W σ) m n).ker) := by
+    rwa [kerDeg_def, Nat.card_eq_fintype_card] at hdvd
+  obtain ⟨y, hyord⟩ := exists_prime_addOrderOf_dvd_card p hdvd'
+  have hyp : p • (y : (W⁄K).Point) = 0 := by
+    have h1 : p • y = 0 := by
+      rw [← hyord]
+      exact addOrderOf_nsmul_eq_zero y
+    exact congrArg Subtype.val h1
+  have hy0 : (y : (W⁄K).Point) ≠ 0 := by
+    intro h0
+    have hy0' : y = 0 := Subtype.ext h0
+    rw [hy0', addOrderOf_zero] at hyord
+    exact (Fact.out : p.Prime).ne_one hyord.symm
+  rw [LinearMap.det_eq_zero_iff_ker_ne_bot, Submodule.ne_bot_iff]
+  refine ⟨⟨(y : (W⁄K).Point), ?_⟩, ?_, ?_⟩
+  · rw [Submodule.mem_torsionBy_iff, Nat.cast_smul_eq_nsmul]
+    exact hyp
+  · rw [LinearMap.mem_ker, frobPencilEnd_eq_zero_iff]
+    exact y.2
+  · intro h0
+    exact hy0 (congrArg Subtype.val h0)
+
+end Dictionary
+
+end FrobeniusEndo
+
+theorem solution {R : Type*} {S : Type*} {K : Type*} [CommRing R] [CommRing S] [Field K]
+    [DecidableEq K] [Algebra R S] [Algebra R K] [Algebra S K] [IsScalarTower R S K]
+    (W : WeierstrassCurve R) (σ : K ≃ₐ[S] K) (p : ℕ) [Fact p.Prime]
+    (hfin : Nat.card (Submodule.torsionBy ℤ (W⁄K).Point p) ≠ 0) {m n : ℤ}
+    (hpos : kerDeg (frobEnd W σ) m n ≠ 0) :
+    LinearMap.det (frobPencilEnd W σ p m n) = 0 ↔ p ∣ kerDeg (frobEnd W σ) m n :=
+  haveI : Finite (Submodule.torsionBy ℤ (W⁄K).Point p) := Nat.finite_of_card_ne_zero hfin
+  ⟨FrobeniusEndo.dvd_kerDeg_of_det_frobPencilEnd_eq_zero W σ p,
+    FrobeniusEndo.det_eq_zero_of_dvd_kerDeg W σ p hpos⟩
+
+end S_FrobeniusEndo_det_frobPencilEnd_eq_zero_iff_dvd_kerDeg
+end P2MW
+export P2MW.S_FrobeniusEndo_det_frobPencilEnd_eq_zero_iff_dvd_kerDeg (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo
+
+theorem FrobeniusEndo.det_frobPencilEnd_eq_zero_iff_dvd_kerDeg {R : Type*} {S : Type*} {K : Type*}
+    [CommRing R] [CommRing S] [Field K] [DecidableEq K] [Algebra R S] [Algebra R K] [Algebra S K]
+    [IsScalarTower R S K] (W : WeierstrassCurve R) (σ : K ≃ₐ[S] K) (p : ℕ) [Fact p.Prime]
+    (hfin : Nat.card (Submodule.torsionBy ℤ (W⁄K).Point p) ≠ 0) {m n : ℤ}
+    (hpos : kerDeg (frobEnd W σ) m n ≠ 0) :
+    LinearMap.det (frobPencilEnd W σ p m n) = 0 ↔ p ∣ kerDeg (frobEnd W σ) m n :=
+  solution W σ p hfin hpos
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_dvd_kerDeg_of_det_frobPencilEnd_eq_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_dvd_kerDeg_of_det_frobPencilEnd_eq_zero.lean
new file mode 100644
index 0000000000..049651ca74
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_dvd_kerDeg_of_det_frobPencilEnd_eq_zero.lean
@@ -0,0 +1,160 @@
+/-
+Based on Prove2Me node FrobeniusEndo.dvd_kerDeg_of_det_frobPencilEnd_eq_zero
+(5a10417c-da45-5279-9d83-dc69611125a6) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 75562eaa-8abf-56d0-87ab-e4cc32a05fb0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusEndo
+public import Mathlib.LinearAlgebra.Determinant
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Singular pencil on p-torsion forces p ∣ #ker([m]-[n]σ)
+
+Theorem statement: `FrobeniusEndo.dvd_kerDeg_of_det_frobPencilEnd_eq_zero`
+(`5a10417c-da45-5279-9d83-dc69611125a6`), by Claude, 2026-09-05.
+
+Proof: submission `75562eaa-8abf-56d0-87ab-e4cc32a05fb0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ and $S$ be commutative rings and $K$ a field with decidable equality, equipped with
+$R$-algebra structures on $S$ and $K$ and an $S$-algebra structure on $K$ forming a scalar tower;
+let $W$ be a Weierstrass curve over $R$, let $\sigma$ be an $S$-algebra automorphism of $K$, and let
+$p$ be a natural number assumed prime. Write $(W⁄K).\mathrm{Point}$ for the group of points of the
+base change of $W$ to $K$, on which $\sigma$ acts; let $T = \mathrm{Submodule.torsionBy}\
+\mathbb{Z}\ (W⁄K).\mathrm{Point}\ p$ be the subgroup of points killed by $p$, viewed as a
+$\mathbb{Z}/p$-module, and let `galoisRepModuleEnd` be the $\mathbb{Z}/p$-linear endomorphism of $T$
+induced by the action of $\sigma$. For integers $m, n$, the hypothesis is that the determinant of
+the $\mathbb{Z}/p$-linear endomorphism $\bar m \cdot 1 - \bar n \cdot
+\mathrm{galoisRepModuleEnd}(\sigma)$ of $T$ vanishes (by Mathlib's convention this determinant is
+$1$ unless $T$ is finite and free, so the hypothesis also constrains $T$). The conclusion is that
+$p$ divides $\mathrm{kerDeg}$ of the $\sigma$-action at $(m,n)$, namely $\mathrm{Nat.card}$ of the
+kernel of the additive endomorphism $m \cdot \mathrm{id} - n \cdot (P \mapsto \sigma \cdot P)$ of
+$(W⁄K).\mathrm{Point}$, this cardinality being $0$ when the kernel is infinite.
+
+This is the forward half of the dictionary between the $\mathbb{F}_p$-spectrum of a Galois
+automorphism acting on the $p$-torsion and the kernel counts $\#\ker([m]-[n]\sigma)$, the counts
+through which the trace of Frobenius is read off modulo $p$. It is used in the equivalence
+[`FrobeniusEndo.det_frobPencilEnd_eq_zero_iff_dvd_kerDeg`]
+(thm.html#FrobeniusEndo.det_frobPencilEnd_eq_zero_iff_dvd_kerDeg)
+and in
+[`FrobeniusEndo.trace_det_frob_of_line_of_isotropic`]
+(thm.html#FrobeniusEndo.trace_det_frob_of_line_of_isotropic).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_FrobeniusEndo_dvd_kerDeg_of_det_frobPencilEnd_eq_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_FrobeniusEndo_dvd_kerDeg_of_det_frobPencilEnd_eq_zero
+
+p2m_open "WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo \
+  P2MW.S_FrobeniusEndo_dvd_kerDeg_of_det_frobPencilEnd_eq_zero.FrobeniusEndo"
+
+namespace FrobeniusEndo
+p2m_export "FrobeniusEndo" "linePencil linePencil_apply kerDeg kerDeg_def frobEnd frobEnd_apply \
+  frobPencilEnd"
+p2m_open "FrobeniusEndo"
+
+section Pencil
+
+variable {R : Type*} {S : Type*} {K : Type*} [CommRing R] [CommRing S] [Field K] [DecidableEq K]
+  [Algebra R S] [Algebra R K] [Algebra S K] [IsScalarTower R S K]
+  (W : WeierstrassCurve R) (σ : K ≃ₐ[S] K) (p : ℕ)
+
+lemma coe_galois_smul_torsionBy (x : Submodule.torsionBy ℤ (W⁄K).Point p) :
+    ((σ • x : Submodule.torsionBy ℤ (W⁄K).Point p) : (W⁄K).Point) = σ • (x : (W⁄K).Point) :=
+  rfl
+
+lemma coe_frobPencilEnd_apply (m n : ℤ) (x : Submodule.torsionBy ℤ (W⁄K).Point p) :
+    ((frobPencilEnd W σ p m n x : Submodule.torsionBy ℤ (W⁄K).Point p) : (W⁄K).Point)
+      = linePencil (frobEnd W σ) m n x := by
+  simp only [LinearMap.sub_apply, LinearMap.smul_apply, Module.End.one_apply, linePencil_apply,
+    frobEnd_apply, Int.cast_smul_eq_zsmul, Submodule.coe_sub, Submodule.coe_smul_of_tower]
+  rfl
+
+lemma frobPencilEnd_eq_zero_iff (m n : ℤ) (x : Submodule.torsionBy ℤ (W⁄K).Point p) :
+    frobPencilEnd W σ p m n x = 0 ↔ (x : (W⁄K).Point) ∈ (linePencil (frobEnd W σ) m n).ker := by
+  rw [AddMonoidHom.mem_ker, ← coe_frobPencilEnd_apply, ZeroMemClass.coe_eq_zero]
+
+lemma frobPencilEnd_natCast_one (m : ℕ) :
+    frobPencilEnd W σ p (m : ℤ) 1
+      = (m : ZMod p) • (1 : Module.End (ZMod p) (Submodule.torsionBy ℤ (W⁄K).Point p))
+          - galoisRepModuleEnd S W p σ := by
+  simp only [frobPencilEnd, Int.cast_natCast, Int.cast_one, one_smul]
+
+end Pencil
+
+section Dictionary
+
+variable {R : Type*} {S : Type*} {K : Type*} [CommRing R] [CommRing S] [Field K] [DecidableEq K]
+  [Algebra R S] [Algebra R K] [Algebra S K] [IsScalarTower R S K]
+  (W : WeierstrassCurve R) (σ : K ≃ₐ[S] K) (p : ℕ) [Fact p.Prime]
+
+theorem dvd_kerDeg_of_det_eq_zero {m n : ℤ}
+    (hdet : LinearMap.det (frobPencilEnd W σ p m n) = 0) :
+    p ∣ kerDeg (frobEnd W σ) m n := by
+  have hker : LinearMap.ker (frobPencilEnd W σ p m n) ≠ ⊥ :=
+    bot_lt_iff_ne_bot.mp (LinearMap.bot_lt_ker_of_det_eq_zero hdet)
+  obtain ⟨x, hxker, hx0⟩ := (Submodule.ne_bot_iff _).mp hker
+  rw [LinearMap.mem_ker, frobPencilEnd_eq_zero_iff] at hxker
+  have hx0' : (x : (W⁄K).Point) ≠ 0 := fun h0 => hx0 (Subtype.ext h0)
+  have hxp : p • (x : (W⁄K).Point) = 0 := by
+    have hx_tors : ((p : ℤ)) • (x : (W⁄K).Point) = 0 := (Submodule.mem_torsionBy_iff _ _).mp x.2
+    rwa [Nat.cast_smul_eq_nsmul] at hx_tors
+  set y : (linePencil (frobEnd W σ) m n).ker := ⟨_, hxker⟩ with hy
+  have hyp : p • y = 0 := Subtype.ext hxp
+  have hy0 : y ≠ 0 := fun h0 => hx0' (congrArg Subtype.val h0)
+  have hyord : addOrderOf y = p := by
+    have h1 : addOrderOf y ∣ p := addOrderOf_dvd_of_nsmul_eq_zero hyp
+    rcases (Nat.Prime.eq_one_or_self_of_dvd (Fact.out : p.Prime) _ h1) with h | h
+    · exact absurd (AddMonoid.addOrderOf_eq_one_iff.mp h) hy0
+    · exact h
+  rw [kerDeg_def, ← hyord]
+  exact addOrderOf_dvd_natCard y
+
+end Dictionary
+
+end FrobeniusEndo
+
+theorem solution {R : Type*} {S : Type*} {K : Type*} [CommRing R] [CommRing S] [Field K]
+    [DecidableEq K] [Algebra R S] [Algebra R K] [Algebra S K] [IsScalarTower R S K]
+    (W : WeierstrassCurve R) (σ : K ≃ₐ[S] K) (p : ℕ) [Fact p.Prime] {m n : ℤ}
+    (h : LinearMap.det (frobPencilEnd W σ p m n) = 0) :
+    p ∣ kerDeg (frobEnd W σ) m n :=
+  FrobeniusEndo.dvd_kerDeg_of_det_eq_zero W σ p h
+
+end S_FrobeniusEndo_dvd_kerDeg_of_det_frobPencilEnd_eq_zero
+end P2MW
+export P2MW.S_FrobeniusEndo_dvd_kerDeg_of_det_frobPencilEnd_eq_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo
+
+theorem FrobeniusEndo.dvd_kerDeg_of_det_frobPencilEnd_eq_zero {R : Type*} {S : Type*} {K : Type*}
+    [CommRing R] [CommRing S] [Field K] [DecidableEq K] [Algebra R S] [Algebra R K] [Algebra S K]
+    [IsScalarTower R S K] (W : WeierstrassCurve R) (σ : K ≃ₐ[S] K) (p : ℕ) [Fact p.Prime] {m n : ℤ}
+    (h : LinearMap.det (frobPencilEnd W σ p m n) = 0) :
+    p ∣ kerDeg (frobEnd W σ) m n :=
+  solution W σ p h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_exists_prime_gt_and_quadratic_root.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_exists_prime_gt_and_quadratic_root.lean
new file mode 100644
index 0000000000..36708ade3f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_exists_prime_gt_and_quadratic_root.lean
@@ -0,0 +1,154 @@
+/-
+Based on Prove2Me node FrobeniusEndo.exists_prime_gt_and_quadratic_root
+(dcb7dd3d-04e4-5222-a410-47227e815957) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f05aadc3-6e54-50a8-98f3-437377ece549
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Data.ZMod.Basic
+
+import Mathlib.Data.Nat.Factorial.Basic
+import Mathlib.Data.Nat.Prime.Basic
+import Mathlib.Tactic.Linarith
+import Mathlib.Tactic.LinearCombination
+import Mathlib.Tactic.Ring
+import Mathlib.Tactic.NormNum
+import Mathlib.Tactic.Positivity
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Roots of X²-aX+q modulo arbitrarily large primes
+
+Theorem statement: `FrobeniusEndo.exists_prime_gt_and_quadratic_root`
+(`dcb7dd3d-04e4-5222-a410-47227e815957`), by Claude, 2026-09-05.
+
+Proof: submission `f05aadc3-6e54-50a8-98f3-437377ece549`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $a$ and $q$ be integers with $q \ge 1$, and let $N$ be a natural number. The assertion is that
+there exists a natural number $r$ with $N < r$ such that $r$ is prime and such that there is an
+element $c$ of $\mathbb{Z}/r\mathbb{Z}$ satisfying $c^2 - \bar a\,c + \bar q = 0$, where $\bar a$
+and $\bar q$ denote the images of $a$ and $q$ under the canonical ring map $\mathbb{Z} \to
+\mathbb{Z}/r\mathbb{Z}$. Thus the monic quadratic $X^2 - aX + q$ acquires a root modulo some prime
+exceeding any prescribed bound; since $N$ is arbitrary, the set of primes modulo which this
+quadratic has a root is infinite. Only the lower bound $q \ge 1$ on the constant term is assumed;
+$a$ is an arbitrary integer, and no irreducibility, discriminant or congruence condition is imposed.
+
+This is the Euclid/Schur-type statement that a non-constant monic integer polynomial — here a
+quadratic — has roots modulo infinitely many primes, proved without any reciprocity or density
+input. It supplies auxiliary primes $r$, larger than any given bound, at which the characteristic
+polynomial $X^2 - a_\ell X + \ell$ of a Frobenius endomorphism splits over $\mathbb{F}_r$; it is
+used in
+[`FrobeniusEndo.frobCharEqOnPoints_of_line`](thm.html#FrobeniusEndo.frobCharEqOnPoints_of_line).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_FrobeniusEndo_exists_prime_gt_and_quadratic_root.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_FrobeniusEndo_exists_prime_gt_and_quadratic_root
+
+namespace FrobeniusEndo
+
+theorem exists_prime_gt_and_quadratic_root (a q : ℤ) (hq : 1 ≤ q) (N : ℕ) :
+    ∃ r : ℕ, N < r ∧ r.Prime ∧
+      ∃ c : ZMod r, c ^ 2 - (a : ZMod r) * c + (q : ZMod r) = 0 := by
+  classical
+  set P : ℕ := (N + 3).factorial with hPdef
+  have hP6 : 6 ≤ P := by
+    have h3 : 3 ≤ N + 3 := by omega
+    have h6 : Nat.factorial 3 ≤ (N + 3).factorial := Nat.factorial_le h3
+    rw [hPdef]
+    simpa [Nat.factorial] using h6
+  have hP1 : 1 ≤ P := by omega
+  have hPz : (1 : ℤ) ≤ (P : ℤ) := by exact_mod_cast hP1
+  set t : ℤ := |a| + 2 with htdef
+  have ht2 : 2 ≤ t := by
+    have := abs_nonneg a
+    omega
+  have hta : a < t := by
+    have := le_abs_self a
+    omega
+  set h : ℤ := q * (P : ℤ) ^ 2 * t ^ 2 - a * (P : ℤ) * t + 1 with hhdef
+  have hmodP : h - (P : ℤ) * (q * (P : ℤ) * t ^ 2 - a * t) = 1 := by
+    rw [hhdef]; ring
+  have hPt : (0 : ℤ) < (P : ℤ) * t :=
+    mul_pos (by linarith : (0 : ℤ) < (P : ℤ)) (by linarith : (0 : ℤ) < t)
+  have hne1 : h ≠ 1 := by
+    intro h1
+    have hzero : (P : ℤ) * t * (q * (P : ℤ) * t - a) = 0 := by
+      have hsub : h - 1 = 0 := by omega
+      rw [hhdef] at hsub
+      linear_combination hsub
+    have hfac : q * (P : ℤ) * t - a = 0 := by
+      rcases mul_eq_zero.mp hzero with h' | h'
+      · exact absurd h' (ne_of_gt hPt)
+      · exact h'
+    nlinarith [mul_nonneg (by linarith : (0 : ℤ) ≤ q - 1) (le_of_lt hPt),
+      mul_nonneg (by linarith : (0 : ℤ) ≤ (P : ℤ) - 1) (by linarith : (0 : ℤ) ≤ t)]
+  have hnem1 : h ≠ -1 := by
+    intro h1
+    have hdvd2 : (P : ℤ) ∣ 2 :=
+      ⟨-(q * (P : ℤ) * t ^ 2 - a * t), by linear_combination - hmodP + h1⟩
+    have h2 : (P : ℤ) ≤ 2 := Int.le_of_dvd (by norm_num) hdvd2
+    have h6 : (6 : ℤ) ≤ (P : ℤ) := by exact_mod_cast hP6
+    omega
+  have habs : h.natAbs ≠ 1 := by omega
+  obtain ⟨r, hrprime, hrdvd⟩ := Nat.exists_prime_and_dvd habs
+  have hrdvdh : (r : ℤ) ∣ h :=
+    (Int.natCast_dvd_natCast.mpr hrdvd).trans (Int.natAbs_dvd.mpr dvd_rfl)
+  refine ⟨r, ?_, hrprime, ?_⟩
+  · by_contra hle
+    have hle' : r ≤ N := not_lt.mp hle
+    have hrP : (r : ℤ) ∣ (P : ℤ) := by
+      exact_mod_cast Nat.dvd_factorial hrprime.pos (by omega)
+    have hr1 : (r : ℤ) ∣ 1 := by
+      have := dvd_sub hrdvdh (Dvd.dvd.mul_right hrP (q * (P : ℤ) * t ^ 2 - a * t))
+      rwa [hmodP] at this
+    have : r ∣ 1 := by exact_mod_cast hr1
+    exact hrprime.one_lt.ne' (Nat.dvd_one.mp this)
+  · set n₀ : ℤ := q * (P : ℤ) * t with hn₀
+    have hval : n₀ ^ 2 - a * n₀ + q = q * h := by
+      rw [hn₀, hhdef]; ring
+    have hdvdval : (r : ℤ) ∣ n₀ ^ 2 - a * n₀ + q := by
+      rw [hval]
+      exact Dvd.dvd.mul_left hrdvdh q
+    refine ⟨(n₀ : ZMod r), ?_⟩
+    have hcast : ((n₀ ^ 2 - a * n₀ + q : ℤ) : ZMod r) = 0 :=
+      (ZMod.intCast_zmod_eq_zero_iff_dvd _ r).mpr hdvdval
+    push_cast at hcast
+    linear_combination hcast
+
+end FrobeniusEndo
+
+theorem solution (a q : ℤ) (hq : 1 ≤ q) (N : ℕ) :
+    ∃ r : ℕ, N < r ∧ r.Prime ∧ ∃ c : ZMod r, c ^ 2 - (a : ZMod r) * c + (q : ZMod r) = 0 :=
+  FrobeniusEndo.exists_prime_gt_and_quadratic_root a q hq N
+
+end S_FrobeniusEndo_exists_prime_gt_and_quadratic_root
+end P2MW
+export P2MW.S_FrobeniusEndo_exists_prime_gt_and_quadratic_root (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem FrobeniusEndo.exists_prime_gt_and_quadratic_root (a q : ℤ) (hq : 1 ≤ q) (N : ℕ) :
+    ∃ r : ℕ, N < r ∧ r.Prime ∧ ∃ c : ZMod r, c ^ 2 - (a : ZMod r) * c + (q : ZMod r) = 0 :=
+  solution a q hq N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_exists_x_linePencil_frobEnd_mul_collision_sq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_exists_x_linePencil_frobEnd_mul_collision_sq.lean
new file mode 100644
index 0000000000..9391f9f5dd
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_exists_x_linePencil_frobEnd_mul_collision_sq.lean
@@ -0,0 +1,901 @@
+/-
+Based on Prove2Me node FrobeniusEndo.exists_x_linePencil_frobEnd_mul_collision_sq
+(f00d7229-dcf6-50af-ac82-30046e1d8e1c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d8d5fe41-b4ec-52b0-9115-94fbad0fd6dc
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusEndo
+public import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_zsmul_x_mul_psi_sq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_zsmul_y_mul_psi_cube
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# x([m]P-π P) as a rational function of x(P)
+
+Theorem statement: `FrobeniusEndo.exists_x_linePencil_frobEnd_mul_collision_sq`
+(`f00d7229-dcf6-50af-ac82-30046e1d8e1c`), by Claude, 2026-09-05.
+
+Proof: submission `d8d5fe41-b4ec-52b0-9115-94fbad0fd6dc`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring, $F$ a finite field with $q = \#F$ elements, and $k$ an algebraically
+closed field with decidable equality, forming a tower $R \to F \to k$ of algebras, and let $W$ be a
+Weierstrass curve over $R$ whose base change $W_{/k}$ is elliptic. Let $\sigma$ be an $F$-algebra
+automorphism of $k$ with $\sigma(x) = x^{q}$ for all $x \in k$, and let $m$ be an integer such that
+the set of abscissae $x \in k$ carrying an affine point $(x,y)$ of $W_{/k}$ with $m \cdot (x,y) = 0$
+is finite. Then there is a polynomial $U \in k[X]$ with the following two properties. First, if $m
+\neq 0$ in $k$, then $\deg U = 2|m|^{2} + 2q - 1$. Secondly, let $(x,y)$ and $(x_1,y_1)$ be
+nonsingular affine points of $W_{/k}$ with $m \cdot (x,y) = (x_1,y_1)$, and suppose that the
+division polynomials $\Psi_m^{2}$, the collision polynomial $\Phi_m - X^{q}\Psi_m^{2}$, and
+$\Psi_2^{2}$ of $W_{/k}$ all have nonzero value at $x$. Then the image of $(x,y)$ under the
+endomorphism $m \cdot \mathrm{id} - \mathrm{frobEnd}$ of $W_{/k}(k)$, where $\mathrm{frobEnd}$ is
+the additive endomorphism given by the action of $\sigma$ on points, is nonzero; and whenever that
+image is the affine point $(x',y')$, one has $x' \cdot \bigl((\Phi_m - X^{q}\Psi_m^{2})(x)\bigr)^{2}
+= U(x)$.
+
+This is the rationality and degree statement underlying Manin's elementary proof of the Hasse bound:
+the abscissa of $[m]P - \pi P$, multiplied by the square of the collision polynomial $\Phi_m -
+X^{q}\Psi_m^{2}$, is a polynomial in $x(P)$ of degree $2m^{2} + 2q - 1$. It feeds the computation of
+the degree of $\ker([m] - \pi)$, in the form used by
+[`FrobeniusEndo.kerDeg_frobEnd_line_one_pos_and_eq_finiteField`]
+(thm.html#FrobeniusEndo.kerDeg_frobEnd_line_one_pos_and_eq_finiteField)
+and
+[`FrobeniusEndo.kerDeg_frobEnd_line_one_pos_and_eq_of_torsion`]
+(thm.html#FrobeniusEndo.kerDeg_frobEnd_line_one_pos_and_eq_of_torsion).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_FrobeniusEndo_exists_x_linePencil_frobEnd_mul_collision_sq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_FrobeniusEndo_exists_x_linePencil_frobEnd_mul_collision_sq
+
+open Polynomial
+open scoped Polynomial.Bivariate
+p2m_open "WeierstrassCurve~evalEval_ψ_sq~evalEval_φ WeierstrassCurve.Affine \
+  WeierstrassCurve.Affine.Point FrobeniusEndo"
+
+namespace FrobLineH3
+
+section Valuation
+
+variable {K : Type*} [Field K] (W : WeierstrassCurve K)
+
+noncomputable def ν (g : W.toAffine.CoordinateRing) : ℕ :=
+  (Algebra.norm K[X] g).natDegree
+
+lemma ν_smul_basis_of_ne (p q : K[X]) (hq : q ≠ 0) :
+    ν W (p • (1 : W.toAffine.CoordinateRing) + q • CoordinateRing.mk W Y)
+      = max (2 * p.natDegree) (2 * q.natDegree + 3) := by
+  unfold ν
+  have hdeg := CoordinateRing.degree_norm_smul_basis (W' := W.toAffine) p q
+  rw [degree_eq_natDegree hq] at hdeg
+  have h3 : (2 • ((q.natDegree : ℕ) : WithBot ℕ)) + 3 = ((2 * q.natDegree + 3 : ℕ) : WithBot ℕ) :=
+    by
+    rw [two_nsmul, two_mul]; norm_cast
+  rw [h3] at hdeg
+  by_cases hp : p = 0
+  · subst hp
+    rw [degree_zero] at hdeg
+    have h2 : (2 • (⊥ : WithBot ℕ)) = ⊥ := by rw [two_nsmul]; rfl
+    rw [h2, max_bot_left] at hdeg
+    rw [natDegree_eq_of_degree_eq_some hdeg, natDegree_zero, mul_zero, Nat.zero_max]
+  · rw [degree_eq_natDegree hp] at hdeg
+    have h2 : (2 • ((p.natDegree : ℕ) : WithBot ℕ)) = ((2 * p.natDegree : ℕ) : WithBot ℕ) := by
+      rw [two_nsmul, two_mul]; norm_cast
+    rw [h2] at hdeg
+    change _ = ((max (2 * p.natDegree) (2 * q.natDegree + 3) : ℕ) : WithBot ℕ) at hdeg
+    exact natDegree_eq_of_degree_eq_some hdeg
+
+lemma ν_smul_one (p : K[X]) : ν W (p • (1 : W.toAffine.CoordinateRing)) = 2 * p.natDegree := by
+  unfold ν
+  have h := CoordinateRing.norm_smul_basis (W' := W.toAffine) p 0
+  rw [zero_smul, add_zero] at h
+  rw [h, mul_zero, zero_mul, sub_zero, zero_pow two_ne_zero, zero_mul, sub_zero, natDegree_pow]
+
+lemma two_mul_natDegree_le_ν (p q : K[X]) :
+    2 * p.natDegree ≤ ν W (p • (1 : W.toAffine.CoordinateRing) + q • CoordinateRing.mk W Y) := by
+  by_cases hq : q = 0
+  · subst hq
+    rw [zero_smul, add_zero, ν_smul_one]
+  · rw [ν_smul_basis_of_ne W p q hq]
+    exact le_max_left _ _
+
+lemma ν_mk_C (p : K[X]) : ν W (CoordinateRing.mk W (C p)) = 2 * p.natDegree := by
+  have h := ν_smul_one W p
+  rwa [CoordinateRing.smul, mul_one] at h
+
+lemma norm_ne_zero_of_ne_zero {g : W.toAffine.CoordinateRing} (hg : g ≠ 0) :
+    Algebra.norm K[X] g ≠ 0 := by
+  obtain ⟨p, q, rfl⟩ := CoordinateRing.exists_smul_basis_eq g
+  by_cases hq : q = 0
+  · subst hq
+    have hp : p ≠ 0 := by
+      rintro rfl
+      exact hg (by rw [zero_smul, zero_smul, add_zero])
+    rw [zero_smul, add_zero, CoordinateRing.smul, mul_one]
+    have h := CoordinateRing.norm_smul_basis (W' := W.toAffine) p 0
+    rw [zero_smul, add_zero, CoordinateRing.smul, mul_one] at h
+    rw [h]
+    simpa using pow_ne_zero 2 hp
+  · intro h0
+    have h := ν_smul_basis_of_ne W p q hq
+    unfold ν at h
+    rw [h0, natDegree_zero] at h
+    omega
+
+lemma ν_mul_le (g h : W.toAffine.CoordinateRing) : ν W (g * h) ≤ ν W g + ν W h := by
+  unfold ν
+  rw [_root_.map_mul]
+  exact natDegree_mul_le
+
+lemma ν_mul (g h : W.toAffine.CoordinateRing) (hg : g ≠ 0) (hh : h ≠ 0) :
+    ν W (g * h) = ν W g + ν W h := by
+  unfold ν
+  rw [_root_.map_mul]
+  exact natDegree_mul (norm_ne_zero_of_ne_zero W hg) (norm_ne_zero_of_ne_zero W hh)
+
+lemma ν_pow_le (g : W.toAffine.CoordinateRing) (n : ℕ) : ν W (g ^ n) ≤ n * ν W g := by
+  unfold ν
+  rw [_root_.map_pow]
+  exact natDegree_pow_le
+
+lemma ν_pow (g : W.toAffine.CoordinateRing) (hg : g ≠ 0) (n : ℕ) : ν W (g ^ n) = n * ν W g := by
+  have hn : Algebra.norm K[X] g ≠ 0 := norm_ne_zero_of_ne_zero W hg
+  unfold ν
+  rw [_root_.map_pow]
+  exact natDegree_pow _ _
+
+lemma ν_add_le (g h : W.toAffine.CoordinateRing) : ν W (g + h) ≤ max (ν W g) (ν W h) := by
+  obtain ⟨p, q, rfl⟩ := CoordinateRing.exists_smul_basis_eq g
+  obtain ⟨p', q', rfl⟩ := CoordinateRing.exists_smul_basis_eq h
+  have hsum : p • (1 : W.toAffine.CoordinateRing) + q • CoordinateRing.mk W Y
+      + (p' • (1 : W.toAffine.CoordinateRing) + q' • CoordinateRing.mk W Y)
+      = (p + p') • (1 : W.toAffine.CoordinateRing) + (q + q') • CoordinateRing.mk W Y := by
+    rw [add_smul, add_smul]; abel
+  rw [hsum]
+  have hp := natDegree_add_le p p'
+  have hq := natDegree_add_le q q'
+  have l2 := two_mul_natDegree_le_ν W p q
+  have l3 := two_mul_natDegree_le_ν W p' q'
+  have hP : 2 * (p + p').natDegree
+      ≤ max (ν W (p • (1 : W.toAffine.CoordinateRing) + q • CoordinateRing.mk W Y))
+          (ν W (p' • (1 : W.toAffine.CoordinateRing) + q' • CoordinateRing.mk W Y)) := by
+    rcases le_max_iff.mp hp with h1 | h1
+    · exact le_max_of_le_left ((Nat.mul_le_mul_left 2 h1).trans l2)
+    · exact le_max_of_le_right ((Nat.mul_le_mul_left 2 h1).trans l3)
+  by_cases h1 : q + q' = 0
+  · rw [h1, zero_smul, add_zero, ν_smul_one]
+    exact hP
+  · rw [ν_smul_basis_of_ne W _ _ h1, max_le_iff]
+    refine ⟨hP, ?_⟩
+    rcases le_max_iff.mp hq with h2 | h2
+    · by_cases h3 : q = 0
+      · subst h3
+        rw [zero_add] at h1 h2 ⊢
+        rw [natDegree_zero] at h2
+        apply le_max_of_le_right
+        rw [ν_smul_basis_of_ne W p' q' h1]
+        apply le_max_of_le_right
+        omega
+      · apply le_max_of_le_left
+        rw [ν_smul_basis_of_ne W p q h3]
+        apply le_max_of_le_right
+        omega
+    · by_cases h3 : q' = 0
+      · subst h3
+        rw [add_zero] at h1 h2 ⊢
+        rw [natDegree_zero] at h2
+        apply le_max_of_le_left
+        rw [ν_smul_basis_of_ne W p q h1]
+        apply le_max_of_le_right
+        omega
+      · apply le_max_of_le_right
+        rw [ν_smul_basis_of_ne W p' q' h3]
+        apply le_max_of_le_right
+        omega
+
+lemma ν_neg (g : W.toAffine.CoordinateRing) : ν W (-g) = ν W g := by
+  unfold ν
+  obtain ⟨p, q, rfl⟩ := CoordinateRing.exists_smul_basis_eq g
+  have : -(p • (1 : W.toAffine.CoordinateRing) + q • CoordinateRing.mk W Y)
+      = (-p) • (1 : W.toAffine.CoordinateRing) + (-q) • CoordinateRing.mk W Y := by
+    rw [neg_smul, neg_smul, neg_add]
+  rw [this, CoordinateRing.norm_smul_basis, CoordinateRing.norm_smul_basis]
+  congr 1
+  ring
+
+lemma ν_sub_le (g h : W.toAffine.CoordinateRing) : ν W (g - h) ≤ max (ν W g) (ν W h) := by
+  rw [sub_eq_add_neg, ← ν_neg W h]
+  exact ν_add_le W g (-h)
+
+lemma ν_add_eq_of_lt {g h : W.toAffine.CoordinateRing} {N : ℕ} (hg : ν W g = N)
+    (hh : ν W h < N) : ν W (g + h) = N := by
+  apply le_antisymm
+  · exact (ν_add_le W g h).trans (max_le hg.le hh.le)
+  · have h1 : ν W g ≤ max (ν W (g + h)) (ν W (-h)) := by
+      have := ν_add_le W (g + h) (-h)
+      rwa [add_neg_cancel_right] at this
+    rw [ν_neg] at h1
+    rcases le_max_iff.mp h1 with h2 | h2
+    · rwa [hg] at h2
+    · omega
+
+lemma ν_mk_Y : ν W (CoordinateRing.mk W Y) = 3 := by
+  have h := ν_smul_basis_of_ne W 0 1 one_ne_zero
+  rw [zero_smul, zero_add, one_smul] at h
+  rw [h, natDegree_zero, natDegree_one]
+  rfl
+
+lemma ν_mk_negPolynomial : ν W (CoordinateRing.mk W W.toAffine.negPolynomial) = 3 := by
+  have h := ν_smul_basis_of_ne W (-(C W.a₁ * X + C W.a₃)) (-1) (by norm_num)
+  have e : (-(C W.a₁ * X + C W.a₃)) • (1 : W.toAffine.CoordinateRing) + (-1 : K[X]) •
+    CoordinateRing.mk W Y
+      = CoordinateRing.mk W W.toAffine.negPolynomial := by
+    rw [CoordinateRing.smul, CoordinateRing.smul, mul_one, ← _root_.map_mul, ← _root_.map_add,
+      Affine.negPolynomial]
+    congr 1
+    simp only [map_neg, map_add, map_mul, map_one]
+    ring
+  rw [e] at h
+  rw [h, natDegree_neg, natDegree_neg, natDegree_one]
+  have : (C W.a₁ * X + C W.a₃).natDegree ≤ 1 := natDegree_linear_le
+  omega
+
+lemma natDegree_of_ν_even {p q : K[X]} {n : ℕ}
+    (h : ν W (p • (1 : W.toAffine.CoordinateRing) + q • CoordinateRing.mk W Y) = 2 * n) :
+    p.natDegree = n := by
+  by_cases hq : q = 0
+  · subst hq
+    rw [zero_smul, add_zero, ν_smul_one] at h
+    omega
+  · rw [ν_smul_basis_of_ne W p q hq] at h
+    rcases max_choice (2 * p.natDegree) (2 * q.natDegree + 3) with h1 | h1 <;> rw [h1] at h <;>
+      omega
+
+end Valuation
+
+section ChordAndG
+
+variable {K : Type*} [Field K]
+
+def starRHS (W : WeierstrassCurve K) (x₁ y₁ x₂ y₂ : K) : K :=
+  x₁ * x₂ * (x₁ + x₂) + 2 * W.a₂ * (x₁ * x₂) + W.a₄ * (x₁ + x₂) + 2 * W.a₆
+    - W.a₁ * (x₁ * y₂ + x₂ * y₁) - W.a₃ * (y₁ + y₂) - 2 * (y₁ * y₂)
+
+noncomputable def Gpoly (W : WeierstrassCurve K) (q : ℕ) (m : ℤ) : K[X][Y] :=
+  C (W.Φ m * X ^ q * (W.Φ m + X ^ q * W.ΨSq m) + C (2 * W.a₂) * (W.Φ m * X ^ q * W.ΨSq m)
+      + C W.a₄ * ((W.Φ m + X ^ q * W.ΨSq m) * W.ΨSq m) + C (2 * W.a₆) * W.ΨSq m ^ 2)
+    - C (C W.a₁ * (W.Φ m * W.ΨSq m)) * W.toAffine.negPolynomial ^ q
+    - C (C W.a₁ * X ^ q) * (W.ω m * W.ψ m)
+    - C (C W.a₃) * (W.ω m * W.ψ m)
+    - C (C W.a₃ * W.ΨSq m ^ 2) * W.toAffine.negPolynomial ^ q
+    - 2 * (W.ω m * W.ψ m) * W.toAffine.negPolynomial ^ q
+
+theorem addX_slope_mul_sub_sq [DecidableEq K] (W : WeierstrassCurve K) {x₁ x₂ y₁ y₂ : K}
+    (h₁ : W.toAffine.Equation x₁ y₁) (h₂ : W.toAffine.Equation x₂ y₂) (hx : x₁ ≠ x₂) :
+    W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) * (x₁ - x₂) ^ 2
+      = starRHS W x₁ y₁ x₂ y₂ := by
+  rw [WeierstrassCurve.Affine.slope_of_X_ne hx]
+  rw [WeierstrassCurve.Affine.equation_iff] at h₁ h₂
+  have hx' : x₁ - x₂ ≠ 0 := sub_ne_zero.mpr hx
+  have hL : (y₁ - y₂) / (x₁ - x₂) * (x₁ - x₂) = y₁ - y₂ := div_mul_cancel₀ _ hx'
+  unfold starRHS WeierstrassCurve.Affine.addX
+  linear_combination h₁ + h₂
+    + ((y₁ - y₂) / (x₁ - x₂) * (x₁ - x₂) + (y₁ - y₂) + W.a₁ * (x₁ - x₂)) * hL
+
+theorem starRHS_mul_psi_pow_four (W : WeierstrassCurve K) (q : ℕ) (m : ℤ) {x y x₁ y₁ : K}
+    (e₁ : x₁ * (W.ψ m).evalEval x y ^ 2 = (W.Φ m).eval x)
+    (e₂ : y₁ * (W.ψ m).evalEval x y ^ 3 = (W.ω m).evalEval x y)
+    (e₃ : (W.ψ m).evalEval x y ^ 2 = (W.ΨSq m).eval x) :
+    starRHS W x₁ y₁ (x ^ q) (W.toAffine.negY x y ^ q) * (W.ψ m).evalEval x y ^ 4
+      = (Gpoly W q m).evalEval x y := by
+  have h2 : (2 : K[X][Y]).evalEval x y = 2 := by simp [Polynomial.evalEval]
+  unfold starRHS Gpoly
+  simp only [Polynomial.evalEval_sub, Polynomial.evalEval_mul, Polynomial.evalEval_pow,
+    Polynomial.evalEval_C, Polynomial.eval_mul, Polynomial.eval_add, Polynomial.eval_pow,
+    Polynomial.eval_C, Polynomial.eval_X, h2, WeierstrassCurve.Affine.evalEval_negPolynomial]
+  linear_combination
+    (x ^ q * (x₁ * (W.ψ m).evalEval x y ^ 2 + (W.Φ m).eval x)
+        + (x ^ q) ^ 2 * (W.ψ m).evalEval x y ^ 2 + 2 * W.a₂ * x ^ q * (W.ψ m).evalEval x y ^ 2
+        + W.a₄ * (W.ψ m).evalEval x y ^ 2
+        - W.a₁ * W.toAffine.negY x y ^ q * (W.ψ m).evalEval x y ^ 2) * e₁
+    + (-(W.a₁ * x ^ q * (W.ψ m).evalEval x y) - W.a₃ * (W.ψ m).evalEval x y
+        - 2 * W.toAffine.negY x y ^ q * (W.ψ m).evalEval x y) * e₂
+    + ((x ^ q) ^ 2 * (W.Φ m).eval x + 2 * W.a₂ * x ^ q * (W.Φ m).eval x + W.a₄ * (W.Φ m).eval x
+        + W.a₄ * x ^ q * ((W.ψ m).evalEval x y ^ 2 + (W.ΨSq m).eval x)
+        + 2 * W.a₆ * ((W.ψ m).evalEval x y ^ 2 + (W.ΨSq m).eval x)
+        - W.a₁ * W.toAffine.negY x y ^ q * (W.Φ m).eval x
+        - W.a₃ * W.toAffine.negY x y ^ q * ((W.ψ m).evalEval x y ^ 2 + (W.ΨSq m).eval x)) * e₃
+
+end ChordAndG
+
+section EZ
+
+variable {K : Type*} [Field K]
+
+noncomputable def EZpoly (W : WeierstrassCurve K) (m : ℤ) : K[X][Y] :=
+  (W.ω m * W.ψ m) ^ 2
+    + C (C W.a₁ * W.Φ m * W.ΨSq m + C W.a₃ * W.ΨSq m ^ 2) * (W.ω m * W.ψ m)
+    - C (W.Φ m ^ 3 * W.ΨSq m + C W.a₂ * W.Φ m ^ 2 * W.ΨSq m ^ 2 + C W.a₄ * W.Φ m * W.ΨSq m ^ 3
+        + C W.a₆ * W.ΨSq m ^ 4)
+
+end EZ
+
+section PoleOrders
+
+variable {K : Type*} [Field K] (W : WeierstrassCurve K)
+
+lemma ν_zero : ν W 0 = 0 := by
+  have h : (0 : W.toAffine.CoordinateRing) = CoordinateRing.mk W (C 0) := by
+    rw [_root_.map_zero, _root_.map_zero]
+  rw [h, ν_mk_C, natDegree_zero, mul_zero]
+
+lemma ν_sub_eq_of_lt {g h : W.toAffine.CoordinateRing} {N : ℕ} (hg : ν W g = N)
+    (hh : ν W h < N) : ν W (g - h) = N := by
+  rw [sub_eq_add_neg]
+  exact ν_add_eq_of_lt W hg (by rwa [ν_neg])
+
+lemma ν_mk_C_le {p : K[X]} {d : ℕ} (h : p.natDegree ≤ d) :
+    ν W (CoordinateRing.mk W (C p)) ≤ 2 * d := by
+  rw [ν_mk_C]; omega
+
+lemma ν_mk_negPolynomial_pow_le (q : ℕ) :
+    ν W (CoordinateRing.mk W (W.toAffine.negPolynomial ^ q)) ≤ 3 * q := by
+  rw [_root_.map_pow]
+  refine (ν_pow_le W _ q).trans ?_
+  rw [ν_mk_negPolynomial, mul_comm]
+
+lemma ν_two : ν W (2 : W.toAffine.CoordinateRing) = 0 := by
+  have h : CoordinateRing.mk W (C (C (2 : K))) = 2 := by
+    rw [map_ofNat C 2, map_ofNat C 2, map_ofNat]
+  rw [← h, ν_mk_C, natDegree_C, mul_zero]
+
+theorem ν_omega_psi_le (m : ℤ) (hm : m ≠ 0)
+    (hEZ : WeierstrassCurve.Affine.CoordinateRing.mk W (EZpoly W m) = 0) :
+    ν W (WeierstrassCurve.Affine.CoordinateRing.mk W (W.ω m * W.ψ m)) ≤ 4 * m.natAbs ^ 2 - 1 := by
+  set N2 := m.natAbs ^ 2 with hN2def
+  have hN2 : 1 ≤ N2 := Nat.one_le_pow _ _ (Int.natAbs_pos.mpr hm)
+  have hΦ_le : (W.Φ m).natDegree ≤ N2 := W.natDegree_Φ_le m
+  have hΨ_le : (W.ΨSq m).natDegree ≤ N2 - 1 := W.natDegree_ΨSq_le m
+  set Z := CoordinateRing.mk W (W.ω m * W.ψ m) with hZ
+  set α := CoordinateRing.mk W (C (C W.a₁ * W.Φ m * W.ΨSq m + C W.a₃ * W.ΨSq m ^ 2)) with hα
+  set β := CoordinateRing.mk W (C (W.Φ m ^ 3 * W.ΨSq m + C W.a₂ * W.Φ m ^ 2 * W.ΨSq m ^ 2
+      + C W.a₄ * W.Φ m * W.ΨSq m ^ 3 + C W.a₆ * W.ΨSq m ^ 4)) with hβ
+  have hrel : Z ^ 2 + α * Z = β := by
+    apply sub_eq_zero.mp
+    rw [hZ, hα, hβ, ← _root_.map_pow, ← _root_.map_mul, ← _root_.map_add, ← _root_.map_sub]
+    exact hEZ
+  have hα_le : ν W α ≤ 4 * N2 - 2 := by
+    have h1 : (C W.a₁ * W.Φ m * W.ΨSq m).natDegree ≤ N2 + (N2 - 1) :=
+      natDegree_mul_le.trans (add_le_add ((natDegree_C_mul_le _ _).trans hΦ_le) hΨ_le)
+    have h2 : (C W.a₃ * W.ΨSq m ^ 2).natDegree ≤ 2 * (N2 - 1) :=
+      (natDegree_C_mul_le _ _).trans (natDegree_pow_le.trans (Nat.mul_le_mul_left 2 hΨ_le))
+    have h : (C W.a₁ * W.Φ m * W.ΨSq m + C W.a₃ * W.ΨSq m ^ 2).natDegree ≤ 2 * N2 - 1 :=
+      (natDegree_add_le _ _).trans (max_le (h1.trans (by omega)) (h2.trans (by omega)))
+    refine (ν_mk_C_le W h).trans ?_
+    omega
+  have hβ_le : ν W β ≤ 8 * N2 - 2 := by
+    have hΦ2 : (W.Φ m ^ 2).natDegree ≤ 2 * N2 :=
+      natDegree_pow_le.trans (Nat.mul_le_mul_left 2 hΦ_le)
+    have hΦ3 : (W.Φ m ^ 3).natDegree ≤ 3 * N2 :=
+      natDegree_pow_le.trans (Nat.mul_le_mul_left 3 hΦ_le)
+    have hΨ2 : (W.ΨSq m ^ 2).natDegree ≤ 2 * (N2 - 1) :=
+      natDegree_pow_le.trans (Nat.mul_le_mul_left 2 hΨ_le)
+    have hΨ3 : (W.ΨSq m ^ 3).natDegree ≤ 3 * (N2 - 1) :=
+      natDegree_pow_le.trans (Nat.mul_le_mul_left 3 hΨ_le)
+    have hΨ4 : (W.ΨSq m ^ 4).natDegree ≤ 4 * (N2 - 1) :=
+      natDegree_pow_le.trans (Nat.mul_le_mul_left 4 hΨ_le)
+    have t1 : (W.Φ m ^ 3 * W.ΨSq m).natDegree ≤ 3 * N2 + (N2 - 1) :=
+      natDegree_mul_le.trans (add_le_add hΦ3 hΨ_le)
+    have t2 : (C W.a₂ * W.Φ m ^ 2 * W.ΨSq m ^ 2).natDegree ≤ 2 * N2 + 2 * (N2 - 1) :=
+      natDegree_mul_le.trans (add_le_add ((natDegree_C_mul_le _ _).trans hΦ2) hΨ2)
+    have t3 : (C W.a₄ * W.Φ m * W.ΨSq m ^ 3).natDegree ≤ N2 + 3 * (N2 - 1) :=
+      natDegree_mul_le.trans (add_le_add ((natDegree_C_mul_le _ _).trans hΦ_le) hΨ3)
+    have t4 : (C W.a₆ * W.ΨSq m ^ 4).natDegree ≤ 4 * (N2 - 1) :=
+      (natDegree_C_mul_le _ _).trans hΨ4
+    have h : (W.Φ m ^ 3 * W.ΨSq m + C W.a₂ * W.Φ m ^ 2 * W.ΨSq m ^ 2
+        + C W.a₄ * W.Φ m * W.ΨSq m ^ 3 + C W.a₆ * W.ΨSq m ^ 4).natDegree ≤ 4 * N2 - 1 :=
+      (natDegree_add_le _ _).trans (max_le ((natDegree_add_le _ _).trans
+        (max_le ((natDegree_add_le _ _).trans (max_le (t1.trans (by omega)) (t2.trans (by omega))))
+          (t3.trans (by omega)))) (t4.trans (by omega)))
+    refine (ν_mk_C_le W h).trans ?_
+    omega
+  by_cases hZ0 : Z = 0
+  · rw [hZ0, ν_zero]
+    exact Nat.zero_le _
+  · by_contra hlt
+    push Not at hlt
+    have h2Z : ν W (Z ^ 2) = 2 * ν W Z := by
+      rw [pow_two, ν_mul W Z Z hZ0 hZ0]; ring
+    have hαZ : ν W (α * Z) < 2 * ν W Z := (ν_mul_le W α Z).trans_lt (by omega)
+    have hsum : ν W (Z ^ 2 + α * Z) = 2 * ν W Z := ν_add_eq_of_lt W h2Z hαZ
+    rw [hrel] at hsum
+    omega
+
+theorem ν_Gpoly (q : ℕ) (hq : 2 ≤ q) (m : ℤ) (hm : (m : K) ≠ 0)
+    (hZ : ν W (WeierstrassCurve.Affine.CoordinateRing.mk W (W.ω m * W.ψ m)) ≤ 4 * m.natAbs ^ 2 - 1)
+      :
+    ν W (WeierstrassCurve.Affine.CoordinateRing.mk W (Gpoly W q m)) = 4 * m.natAbs ^ 2 + 4 * q - 2
+      := by
+  set N2 := m.natAbs ^ 2 with hN2def
+  have hm0 : m ≠ 0 := by
+    rintro rfl
+    exact hm (by simp)
+  have hN2 : 1 ≤ N2 := Nat.one_le_pow _ _ (Int.natAbs_pos.mpr hm0)
+  have hΦ : (W.Φ m).natDegree = N2 := W.natDegree_Φ m
+  have hΦ_le : (W.Φ m).natDegree ≤ N2 := hΦ.le
+  have hΨ : (W.ΨSq m).natDegree = N2 - 1 := W.natDegree_ΨSq hm
+  have hΨ_le : (W.ΨSq m).natDegree ≤ N2 - 1 := hΨ.le
+  have hlcΨ : (W.ΨSq m).leadingCoeff ≠ 0 := by
+    rw [W.leadingCoeff_ΨSq hm]
+    exact pow_ne_zero 2 hm
+  have hΨ0 : W.ΨSq m ≠ 0 := leadingCoeff_ne_zero.mp hlcΨ
+  have hlc : (W.Φ m * W.ΨSq m).leadingCoeff ≠ 0 := by
+    rw [leadingCoeff_mul, W.leadingCoeff_Φ, one_mul]
+    exact hlcΨ
+  have hΦΨ0 : W.Φ m * W.ΨSq m ≠ 0 := leadingCoeff_ne_zero.mp hlc
+  have hΦΨ : (W.Φ m * W.ΨSq m).natDegree = 2 * N2 - 1 := by
+    rw [natDegree_mul (W.Φ_ne_zero m) hΨ0, hΦ, hΨ]; omega
+  have hXq : ((X : K[X]) ^ q).natDegree = q := natDegree_X_pow q
+  set D := 2 * N2 + 2 * q - 1 with hD
+  have hD1 : 1 ≤ D := by omega
+  set B₀ : K[X] := W.Φ m * X ^ q * (W.Φ m + X ^ q * W.ΨSq m)
+      + C (2 * W.a₂) * (W.Φ m * X ^ q * W.ΨSq m)
+      + C W.a₄ * ((W.Φ m + X ^ q * W.ΨSq m) * W.ΨSq m) + C (2 * W.a₆) * W.ΨSq m ^ 2 with hB₀
+  set Rest : K[X] := W.Φ m * W.Φ m * X ^ q
+      + C (2 * W.a₂) * (W.Φ m * X ^ q * W.ΨSq m)
+      + C W.a₄ * ((W.Φ m + X ^ q * W.ΨSq m) * W.ΨSq m) + C (2 * W.a₆) * W.ΨSq m ^ 2 with hRest
+  have hdecomp : B₀ = W.Φ m * W.ΨSq m * X ^ (2 * q) + Rest := by
+    rw [hB₀, hRest]; ring
+  have hmain_deg : (W.Φ m * W.ΨSq m * X ^ (2 * q)).natDegree = D := by
+    rw [natDegree_mul hΦΨ0 (pow_ne_zero _ X_ne_zero), natDegree_X_pow, hΦΨ]; omega
+  have hmain_coeff : (W.Φ m * W.ΨSq m * X ^ (2 * q)).coeff D = (W.Φ m * W.ΨSq m).leadingCoeff := by
+    rw [show D = (2 * N2 - 1) + 2 * q by omega, coeff_mul_X_pow, leadingCoeff, hΦΨ]
+  have hRest_le : Rest.natDegree ≤ D - 1 := by
+    have hsum : (W.Φ m + X ^ q * W.ΨSq m).natDegree ≤ q + (N2 - 1) := by
+      refine (natDegree_add_le _ _).trans (max_le (hΦ_le.trans (by omega)) ?_)
+      exact natDegree_mul_le.trans (add_le_add hXq.le hΨ_le)
+    have r1 : (W.Φ m * W.Φ m * X ^ q).natDegree ≤ N2 + N2 + q :=
+      natDegree_mul_le.trans (add_le_add (natDegree_mul_le.trans (add_le_add hΦ_le hΦ_le)) hXq.le)
+    have r2 : (C (2 * W.a₂) * (W.Φ m * X ^ q * W.ΨSq m)).natDegree ≤ N2 + q + (N2 - 1) :=
+      (natDegree_C_mul_le _ _).trans (natDegree_mul_le.trans
+        (add_le_add (natDegree_mul_le.trans (add_le_add hΦ_le hXq.le)) hΨ_le))
+    have r3 : (C W.a₄ * ((W.Φ m + X ^ q * W.ΨSq m) * W.ΨSq m)).natDegree ≤ q + (N2 - 1) + (N2 - 1)
+      :=
+      (natDegree_C_mul_le _ _).trans (natDegree_mul_le.trans (add_le_add hsum hΨ_le))
+    have r4 : (C (2 * W.a₆) * W.ΨSq m ^ 2).natDegree ≤ 2 * (N2 - 1) :=
+      (natDegree_C_mul_le _ _).trans (natDegree_pow_le.trans (Nat.mul_le_mul_left 2 hΨ_le))
+    rw [hRest]
+    exact (natDegree_add_le _ _).trans (max_le ((natDegree_add_le _ _).trans
+      (max_le ((natDegree_add_le _ _).trans (max_le (r1.trans (by omega)) (r2.trans (by omega))))
+        (r3.trans (by omega)))) (r4.trans (by omega)))
+  have hB₀deg : B₀.natDegree = D := by
+    apply natDegree_eq_of_le_of_coeff_ne_zero
+    · rw [hdecomp]
+      exact (natDegree_add_le _ _).trans (max_le hmain_deg.le (hRest_le.trans (Nat.sub_le D 1)))
+    · rw [hdecomp, coeff_add, hmain_coeff,
+        coeff_eq_zero_of_natDegree_lt (hRest_le.trans_lt (by omega)), add_zero]
+      exact hlc
+  set NN := 4 * N2 + 4 * q - 2 with hNN
+  have hνB₀ : ν W (CoordinateRing.mk W (C B₀)) = NN := by
+    rw [ν_mk_C, hB₀deg]; omega
+  have hnegq := ν_mk_negPolynomial_pow_le W q
+  have t6 : ν W (CoordinateRing.mk W (C (C W.a₁ * (W.Φ m * W.ΨSq m)) * W.toAffine.negPolynomial ^
+    q))
+      < NN := by
+    rw [_root_.map_mul]
+    have h1 : (C W.a₁ * (W.Φ m * W.ΨSq m)).natDegree ≤ 2 * N2 - 1 :=
+      (natDegree_C_mul_le _ _).trans hΦΨ.le
+    have := (ν_mul_le W _ _).trans (add_le_add (ν_mk_C_le W h1) hnegq)
+    omega
+  have t7 : ν W (CoordinateRing.mk W (C (C W.a₁ * X ^ q) * (W.ω m * W.ψ m))) < NN := by
+    rw [_root_.map_mul]
+    have h1 : (C W.a₁ * X ^ q : K[X]).natDegree ≤ q := (natDegree_C_mul_le _ _).trans hXq.le
+    have := (ν_mul_le W _ _).trans (add_le_add (ν_mk_C_le W h1) hZ)
+    omega
+  have t8 : ν W (CoordinateRing.mk W (C (C W.a₃) * (W.ω m * W.ψ m))) < NN := by
+    rw [_root_.map_mul]
+    have h1 : (C W.a₃ : K[X]).natDegree ≤ 0 := (natDegree_C _).le
+    have := (ν_mul_le W _ _).trans (add_le_add (ν_mk_C_le W h1) hZ)
+    omega
+  have t8' : ν W (CoordinateRing.mk W (C (C W.a₃ * W.ΨSq m ^ 2) * W.toAffine.negPolynomial ^ q))
+      < NN := by
+    rw [_root_.map_mul]
+    have h1 : (C W.a₃ * W.ΨSq m ^ 2).natDegree ≤ 2 * (N2 - 1) :=
+      (natDegree_C_mul_le _ _).trans (natDegree_pow_le.trans (Nat.mul_le_mul_left 2 hΨ_le))
+    have := (ν_mul_le W _ _).trans (add_le_add (ν_mk_C_le W h1) hnegq)
+    omega
+  have t9 : ν W (CoordinateRing.mk W (2 * (W.ω m * W.ψ m) * W.toAffine.negPolynomial ^ q)) < NN :=
+    by
+    rw [_root_.map_mul, _root_.map_mul, map_ofNat]
+    have := (ν_mul_le W _ _).trans (add_le_add ((ν_mul_le W _ _).trans
+      (add_le_add (ν_two W).le hZ)) hnegq)
+    omega
+  unfold Gpoly
+  rw [_root_.map_sub, _root_.map_sub, _root_.map_sub, _root_.map_sub, _root_.map_sub]
+  exact ν_sub_eq_of_lt W (ν_sub_eq_of_lt W (ν_sub_eq_of_lt W (ν_sub_eq_of_lt W
+    (ν_sub_eq_of_lt W hνB₀ t6) t7) t8) t8') t9
+
+end PoleOrders
+
+section OnCurve
+
+variable {K : Type*} [Field K] (W : WeierstrassCurve K)
+
+lemma evalEval_eq_of_mk_eq {x y : K} (h : W.toAffine.Equation x y) {a b : K[X][Y]}
+    (hab : CoordinateRing.mk W a = CoordinateRing.mk W b) : a.evalEval x y = b.evalEval x y := by
+  have e := congrArg (AdjoinRoot.evalEval (p := W.toAffine.polynomial) h) hab
+  rwa [AdjoinRoot.evalEval_mk, AdjoinRoot.evalEval_mk] at e
+
+lemma evalEval_eq_zero_of_mk_eq_zero {x y : K} (h : W.toAffine.Equation x y) {a : K[X][Y]}
+    (ha : CoordinateRing.mk W a = 0) : a.evalEval x y = 0 := by
+  have e := evalEval_eq_of_mk_eq W h (b := 0) (by rw [ha, _root_.map_zero])
+  rwa [evalEval_zero] at e
+
+lemma evalEval_ψ_sq {x y : K} (h : W.toAffine.Equation x y) (n : ℤ) :
+    (W.ψ n).evalEval x y ^ 2 = (W.ΨSq n).eval x := by
+  have e := evalEval_eq_of_mk_eq W h (a := W.ψ n ^ 2) (b := C (W.ΨSq n))
+    (by rw [map_pow, Affine.CoordinateRing.mk_ψ, Affine.CoordinateRing.mk_Ψ_sq])
+  rwa [evalEval_pow, evalEval_C] at e
+
+lemma evalEval_φ {x y : K} (h : W.toAffine.Equation x y) (n : ℤ) :
+    (W.φ n).evalEval x y = (W.Φ n).eval x := by
+  have e := evalEval_eq_of_mk_eq W h (Affine.CoordinateRing.mk_φ W n)
+  rwa [evalEval_C] at e
+
+lemma sub_negY_sq {x y : K} (h : W.toAffine.Equation x y) :
+    (y - W.toAffine.negY x y) ^ 2 = W.Ψ₂Sq.eval x := by
+  have e := evalEval_eq_of_mk_eq W h (a := W.ψ₂ ^ 2) (b := C W.Ψ₂Sq)
+    (by rw [map_pow, Affine.CoordinateRing.mk_ψ₂_sq])
+  rw [evalEval_pow, evalEval_C, WeierstrassCurve.ψ₂, Affine.evalEval_polynomialY] at e
+  rw [← e, Affine.negY]
+  ring
+
+lemma Ψ₂Sq_ne_zero [W.IsElliptic] : W.Ψ₂Sq ≠ 0 := by
+  intro h0
+  have c3 : (4 : K) = 0 := by
+    have := congrArg (fun p => p.coeff 3) h0
+    simpa [WeierstrassCurve.Ψ₂Sq, coeff_X, coeff_C, coeff_X_pow] using this
+  have c2 : W.b₂ = 0 := by
+    have := congrArg (fun p => p.coeff 2) h0
+    simpa [WeierstrassCurve.Ψ₂Sq, coeff_X, coeff_C, coeff_X_pow] using this
+  have c1 : 2 * W.b₄ = 0 := by
+    have := congrArg (fun p => p.coeff 1) h0
+    simpa [WeierstrassCurve.Ψ₂Sq, coeff_X, coeff_C, coeff_X_pow] using this
+  have c0 : W.b₆ = 0 := by
+    have := congrArg (fun p => p.coeff 0) h0
+    simpa [WeierstrassCurve.Ψ₂Sq, coeff_X, coeff_C, coeff_X_pow] using this
+  apply W.isUnit_Δ.ne_zero
+  rw [WeierstrassCurve.Δ, c2, c0]
+  linear_combination (-(2 : K) * W.b₄ ^ 3) * c3
+
+end OnCurve
+
+section Transfer
+
+variable {K : Type*} [Field K] (W : WeierstrassCurve K)
+
+lemma exists_equation [IsAlgClosed K] (x : K) : ∃ y : K, W.toAffine.Equation x y := by
+  obtain ⟨y, hy⟩ := IsAlgClosed.exists_root
+    (C 1 * X ^ 2 + C (W.a₁ * x + W.a₃) * X + C (-(x ^ 3 + W.a₂ * x ^ 2 + W.a₄ * x + W.a₆)))
+    (natDegree_pos_iff_degree_pos.mp (by rw [natDegree_quadratic one_ne_zero]; norm_num)).ne'
+  refine ⟨y, (W.toAffine.equation_iff x y).mpr ?_⟩
+  simp only [IsRoot, eval_add, eval_mul, eval_pow, eval_C, eval_X, one_mul] at hy
+  linear_combination hy
+
+noncomputable def redX (g : K[X][Y]) : K[X] := (g %ₘ W.toAffine.polynomial).coeff 0
+
+noncomputable def redY (g : K[X][Y]) : K[X] := (g %ₘ W.toAffine.polynomial).coeff 1
+
+lemma modByMonic_eq (g : K[X][Y]) :
+    g %ₘ W.toAffine.polynomial = C (redY W g) * Y + C (redX W g) := by
+  have hlt := natDegree_modByMonic_lt g W.toAffine.monic_polynomial
+    (by
+      intro h1
+      have := congrArg natDegree h1
+      rw [Affine.natDegree_polynomial, natDegree_one] at this
+      exact two_ne_zero this)
+  rw [Affine.natDegree_polynomial] at hlt
+  exact eq_X_add_C_of_natDegree_le_one (by omega)
+
+lemma mk_eq_smul_basis (g : K[X][Y]) :
+    CoordinateRing.mk W g
+      = redX W g • (1 : W.toAffine.CoordinateRing) + redY W g • CoordinateRing.mk W Y := by
+  have hdiv := modByMonic_add_div g W.toAffine.polynomial
+  have e : CoordinateRing.mk W g = CoordinateRing.mk W (g %ₘ W.toAffine.polynomial) := by
+    conv_lhs => rw [← hdiv]
+    rw [map_add, map_mul, AdjoinRoot.mk_self, zero_mul, add_zero]
+  rw [e, modByMonic_eq, map_add, map_mul, CoordinateRing.smul, CoordinateRing.smul, mul_one,
+    add_comm]
+
+lemma evalEval_eq_redX_add_redY {x y : K} (h : W.toAffine.Equation x y) (g : K[X][Y]) :
+    g.evalEval x y = (redX W g).eval x + (redY W g).eval x * y := by
+  have hdiv := modByMonic_add_div g W.toAffine.polynomial
+  have e : g.evalEval x y = (g %ₘ W.toAffine.polynomial).evalEval x y := by
+    conv_lhs => rw [← hdiv]
+    rw [evalEval_add, evalEval_mul]
+    have h0 : W.toAffine.polynomial.evalEval x y = 0 := h
+    rw [h0, zero_mul, add_zero]
+  rw [e, modByMonic_eq, evalEval_add, evalEval_mul, evalEval_C, evalEval_C, evalEval_X]
+  ring
+
+lemma mk_eq_zero_of_evalEval_eq_zero [IsAlgClosed K] [W.IsElliptic] {T : Set K} (hT : T.Finite)
+    (g : K[X][Y]) (hg : ∀ {x y : K}, W.toAffine.Equation x y → x ∉ T → g.evalEval x y = 0) :
+    CoordinateRing.mk W g = 0 := by
+  have hbad : (T ∪ {x : K | W.Ψ₂Sq.IsRoot x}).Finite :=
+    hT.union (Polynomial.finite_setOfPred_isRoot (Ψ₂Sq_ne_zero W))
+  have key : ∀ x : K, x ∉ T ∪ {x : K | W.Ψ₂Sq.IsRoot x} →
+      (redY W g).eval x = 0 ∧ (redX W g).eval x = 0 := by
+    intro x hx
+    simp only [Set.mem_union, Set.mem_ofPred_eq, not_or] at hx
+    obtain ⟨hxT, hxΨ⟩ := hx
+    obtain ⟨y, hy⟩ := exists_equation W x
+    have hy' : W.toAffine.Equation x (W.toAffine.negY x y) := (Affine.equation_neg x y).mpr hy
+    have e1 := evalEval_eq_redX_add_redY W hy g
+    have e2 := evalEval_eq_redX_add_redY W hy' g
+    rw [hg hy hxT] at e1
+    rw [hg hy' hxT] at e2
+    have hne : y - W.toAffine.negY x y ≠ 0 := by
+      intro h0
+      apply hxΨ
+      rw [IsRoot, ← sub_negY_sq W hy, h0, zero_pow two_ne_zero]
+    have hY : (redY W g).eval x = 0 := by
+      have : (redY W g).eval x * (y - W.toAffine.negY x y) = 0 := by linear_combination e2 - e1
+      exact (mul_eq_zero.mp this).resolve_right hne
+    refine ⟨hY, ?_⟩
+    rw [hY, zero_mul, add_zero] at e1
+    exact e1.symm
+  have hY0 : redY W g = 0 := by
+    apply Polynomial.eq_zero_of_infinite_isRoot
+    exact Set.Infinite.mono (fun x hx => (key x hx).1) hbad.infinite_compl
+  have hX0 : redX W g = 0 := by
+    apply Polynomial.eq_zero_of_infinite_isRoot
+    exact Set.Infinite.mono (fun x hx => (key x hx).2) hbad.infinite_compl
+  rw [mk_eq_smul_basis, hY0, hX0, zero_smul, zero_smul, add_zero]
+
+end Transfer
+
+section EZvanish
+
+variable {K : Type*} [Field K] [DecidableEq K] (W : WeierstrassCurve K) [W.IsElliptic]
+
+lemma evalEval_EZpoly_eq_zero (m : ℤ) {x y : K} (h : W.toAffine.Nonsingular x y) {x₁ y₁ : K}
+    (h₁ : W.toAffine.Nonsingular x₁ y₁) (hmP : m • Point.some x y h = Point.some x₁ y₁ h₁) :
+    (EZpoly W m).evalEval x y = 0 := by
+  have e₁ := WeierstrassCurve.Affine.Point.zsmul_x_mul_psi_sq W m h h₁ hmP
+  have e₂ := WeierstrassCurve.Affine.Point.zsmul_y_mul_psi_cube W m h h₁ hmP
+  rw [evalEval_φ W h.1] at e₁
+  have e₃ := evalEval_ψ_sq W h.1 m
+  have heq : y₁ ^ 2 + W.a₁ * x₁ * y₁ + W.a₃ * y₁ = x₁ ^ 3 + W.a₂ * x₁ ^ 2 + W.a₄ * x₁ + W.a₆ :=
+    (W.toAffine.equation_iff x₁ y₁).mp h₁.1
+  unfold EZpoly
+  simp only [evalEval_sub, evalEval_add, evalEval_mul, evalEval_pow, evalEval_C, eval_add, eval_mul,
+    eval_pow, eval_C]
+  rw [← e₁, ← e₂, ← e₃]
+  linear_combination ((W.ψ m).evalEval x y) ^ 8 * heq
+
+end EZvanish
+
+section Frobenius
+
+variable {R : Type*} [CommRing R] {F : Type*} [Field F] [Fintype F] {k : Type*} [Field k]
+  [Algebra R F] [Algebra R k] [Algebra F k] [IsScalarTower R F k]
+  (W : WeierstrassCurve R) (σ : k ≃ₐ[F] k) (hσ : ∀ x : k, σ x = x ^ Fintype.card F)
+
+include hσ in
+lemma pow_card_algebraMap (a : R) : (algebraMap R k a) ^ Fintype.card F = algebraMap R k a := by
+  rw [← hσ, IsScalarTower.algebraMap_apply R F k, AlgEquiv.commutes]
+
+include hσ in
+lemma negY_pow_card (x y : k) :
+    ((W⁄k).negY x y) ^ Fintype.card F = (W⁄k).negY (x ^ Fintype.card F) (y ^ Fintype.card F) := by
+  have h1 : (W⁄k).a₁ = algebraMap R k W.a₁ := rfl
+  have h3 : (W⁄k).a₃ = algebraMap R k W.a₃ := rfl
+  rw [Affine.negY, Affine.negY, ← hσ, ← hσ, ← hσ, map_sub, map_sub, map_neg, map_mul, h1, h3,
+    IsScalarTower.algebraMap_apply R F k, IsScalarTower.algebraMap_apply R F k, AlgEquiv.commutes,
+    AlgEquiv.commutes]
+
+include hσ in
+lemma smul_some_eq [DecidableEq k] {x y : k} (h : (W⁄k).Nonsingular x y) :
+    ∃ h' : (W⁄k).Nonsingular (x ^ Fintype.card F) (y ^ Fintype.card F),
+      σ • (Point.some x y h : (W⁄k).Point) = Point.some (x ^ Fintype.card F) (y ^ Fintype.card F) h'
+        := by
+  have e : ∃ h₀ : (W⁄k).Nonsingular (σ x) (σ y),
+      σ • (Point.some x y h : (W⁄k).Point) = Point.some (σ x) (σ y) h₀ := ⟨_, rfl⟩
+  obtain ⟨h₀, e⟩ := e
+  rw [e]
+  have key : ∀ (x' y' : k) (h₀ : (W⁄k).Nonsingular x' y'), x' = x ^ Fintype.card F →
+      y' = y ^ Fintype.card F → ∃ h' : (W⁄k).Nonsingular (x ^ Fintype.card F) (y ^ Fintype.card F),
+        (Point.some x' y' h₀ : (W⁄k).Point) = Point.some (x ^ Fintype.card F) (y ^ Fintype.card F)
+          h' := by
+    rintro _ _ h₀ rfl rfl
+    exact ⟨h₀, rfl⟩
+  exact key _ _ h₀ (hσ x) (hσ y)
+
+end Frobenius
+
+section Main
+
+variable {R : Type*} [CommRing R] {F : Type*} [Field F] [Fintype F] {k : Type*} [Field k]
+  [DecidableEq k] [Algebra R F] [Algebra R k] [Algebra F k] [IsScalarTower R F k]
+
+lemma key_step (W : WeierstrassCurve R) [(W⁄k).IsElliptic] (σ : k ≃ₐ[F] k)
+    (hσ : ∀ x : k, σ x = x ^ Fintype.card F) (m : ℤ)
+    {x y : k} (h : (W⁄k).Nonsingular x y) {x₁ y₁ : k} (h₁ : (W⁄k).Nonsingular x₁ y₁)
+    (hmP : m • Point.some x y h = Point.some x₁ y₁ h₁)
+    (hC : ((W⁄k).Φ m - Polynomial.X ^ Fintype.card F * (W⁄k).ΨSq m).eval x ≠ 0) :
+    linePencil (frobEnd W σ) m 1 (Point.some x y h) ≠ 0 ∧
+    ∀ {x' y' : k} (h' : (W⁄k).Nonsingular x' y'),
+      linePencil (frobEnd W σ) m 1 (Point.some x y h) = Point.some x' y' h' →
+      x' * ((W⁄k).Φ m - Polynomial.X ^ Fintype.card F * (W⁄k).ΨSq m).eval x ^ 2
+        = (Gpoly (W⁄k) (Fintype.card F) m).evalEval x y := by
+  have e₁ := WeierstrassCurve.Affine.Point.zsmul_x_mul_psi_sq (W⁄k) m h h₁ hmP
+  have e₂ := WeierstrassCurve.Affine.Point.zsmul_y_mul_psi_cube (W⁄k) m h h₁ hmP
+  rw [evalEval_φ (W⁄k) h.1] at e₁
+  have e₃ := evalEval_ψ_sq (W⁄k) h.1 m
+  have hCval : ((W⁄k).Φ m - Polynomial.X ^ Fintype.card F * (W⁄k).ΨSq m).eval x
+      = (x₁ - x ^ Fintype.card F) * ((W⁄k).ψ m).evalEval x y ^ 2 := by
+    rw [eval_sub, eval_mul, eval_pow, eval_X, ← e₃]
+    linear_combination -e₁
+  have hx₁ : x₁ ≠ x ^ Fintype.card F := by
+    intro hx
+    apply hC
+    rw [hCval, hx, sub_self, zero_mul]
+  obtain ⟨hq', hσP⟩ := smul_some_eq W σ hσ h
+  have hnegσP : -(σ • (Point.some x y h : (W⁄k).Point))
+      = Point.some (x ^ Fintype.card F) ((W⁄k).negY (x ^ Fintype.card F) (y ^ Fintype.card F))
+          ((Affine.nonsingular_neg ..).mpr hq') := by
+    rw [hσP, neg_some]
+  have hA : linePencil (frobEnd W σ) m 1 (Point.some x y h)
+      = Point.some x₁ y₁ h₁ + Point.some (x ^ Fintype.card F)
+          ((W⁄k).negY (x ^ Fintype.card F) (y ^ Fintype.card F)) ((Affine.nonsingular_neg ..).mpr
+            hq') := by
+    rw [linePencil_apply, frobEnd_apply, one_zsmul, hmP, sub_eq_add_neg, hnegσP]
+  rw [add_of_X_ne hx₁] at hA
+  refine ⟨by rw [hA]; exact Point.some_ne_zero _, ?_⟩
+  intro x' y' h' hrepr
+  rw [hA, Point.some.injEq] at hrepr
+  obtain ⟨hx', -⟩ := hrepr
+  have hchord := addX_slope_mul_sub_sq (W⁄k) h₁.1 (((Affine.nonsingular_neg ..).mpr hq')).1 hx₁
+  rw [hx'] at hchord
+  have hbook := starRHS_mul_psi_pow_four (W⁄k) (Fintype.card F) m e₁ e₂ e₃
+  rw [hCval]
+  calc x' * ((x₁ - x ^ Fintype.card F) * ((W⁄k).ψ m).evalEval x y ^ 2) ^ 2
+      = (x' * (x₁ - x ^ Fintype.card F) ^ 2) * ((W⁄k).ψ m).evalEval x y ^ 4 := by ring
+    _ = starRHS (W⁄k) x₁ y₁ (x ^ Fintype.card F)
+          ((W⁄k).negY (x ^ Fintype.card F) (y ^ Fintype.card F)) * ((W⁄k).ψ m).evalEval x y ^ 4 :=
+            by
+        rw [hchord]
+    _ = starRHS (W⁄k) x₁ y₁ (x ^ Fintype.card F) ((W⁄k).toAffine.negY x y ^ Fintype.card F)
+          * ((W⁄k).ψ m).evalEval x y ^ 4 := by
+        rw [← negY_pow_card W σ hσ]
+    _ = (Gpoly (W⁄k) (Fintype.card F) m).evalEval x y := hbook
+
+theorem exists_x_linePencil_frobEnd_mul_collision_sq [IsAlgClosed k] (W : WeierstrassCurve R)
+    [(W⁄k).IsElliptic] (σ : k ≃ₐ[F] k) (hσ : ∀ x : k, σ x = x ^ Fintype.card F) (m : ℤ)
+    (hfin : {x : k | ∃ (y : k) (h : (W⁄k).Nonsingular x y), m • Point.some x y h = 0}.Finite) :
+    ∃ U : Polynomial k, ((m : k) ≠ 0 → U.natDegree = 2 * m.natAbs ^ 2 + 2 * Fintype.card F - 1) ∧
+      ∀ {x y : k} (h : (W⁄k).Nonsingular x y) {x₁ y₁ : k} (h₁ : (W⁄k).Nonsingular x₁ y₁),
+        m • Point.some x y h = Point.some x₁ y₁ h₁ → ((W⁄k).ΨSq m).eval x ≠ 0 →
+        ((W⁄k).Φ m - Polynomial.X ^ Fintype.card F * (W⁄k).ΨSq m).eval x ≠ 0 →
+        (W⁄k).Ψ₂Sq.eval x ≠ 0 →
+        linePencil (frobEnd W σ) m 1 (Point.some x y h) ≠ 0 ∧
+        ∀ {x' y' : k} (h' : (W⁄k).Nonsingular x' y'),
+          linePencil (frobEnd W σ) m 1 (Point.some x y h) = Point.some x' y' h' →
+          x' * ((W⁄k).Φ m - Polynomial.X ^ Fintype.card F * (W⁄k).ΨSq m).eval x ^ 2 = U.eval x := by
+  refine ⟨redX (W⁄k) (Gpoly (W⁄k) (Fintype.card F) m), ?_, ?_⟩
+  · intro hmk
+    have hm0 : m ≠ 0 := by
+      rintro rfl
+      exact hmk (by simp)
+    have hq2 : 2 ≤ Fintype.card F := Fintype.one_lt_card
+    have hEZ : CoordinateRing.mk (W⁄k) (EZpoly (W⁄k) m) = 0 := by
+      refine mk_eq_zero_of_evalEval_eq_zero (W⁄k) hfin _ (fun {x y} hxy hxT => ?_)
+      have hns : (W⁄k).Nonsingular x y := (Affine.equation_iff_nonsingular (W := W⁄k)).mp hxy
+      rcases hmP : m • (Point.some x y hns : (W⁄k).Point) with _ | ⟨x₁, y₁, h₁⟩
+      · exact absurd ⟨y, hns, hmP⟩ hxT
+      · exact evalEval_EZpoly_eq_zero (W⁄k) m hns h₁ hmP
+    have hZ := ν_omega_psi_le (W⁄k) m hm0 hEZ
+    have hGν := ν_Gpoly (W⁄k) (Fintype.card F) hq2 m hmk hZ
+    rw [mk_eq_smul_basis (W⁄k) (Gpoly (W⁄k) (Fintype.card F) m)] at hGν
+    have hn : 4 * m.natAbs ^ 2 + 4 * Fintype.card F - 2 = 2 * (2 * m.natAbs ^ 2 + 2 * Fintype.card F
+      - 1) :=
+      by
+      omega
+    rw [hn] at hGν
+    exact natDegree_of_ν_even (W⁄k) hGν
+  · intro x y h x₁ y₁ h₁ hmP hΨ hC hΨ₂
+    obtain ⟨hA, hval⟩ := key_step W σ hσ m h h₁ hmP hC
+    refine ⟨hA, fun {x' y'} h' hrepr => ?_⟩
+    have e1 := hval h' hrepr
+    have hn : (W⁄k).Nonsingular x ((W⁄k).negY x y) := (Affine.nonsingular_neg ..).mpr h
+    have hn₁ : (W⁄k).Nonsingular x₁ ((W⁄k).negY x₁ y₁) := (Affine.nonsingular_neg ..).mpr h₁
+    have hmP' : m • (Point.some x ((W⁄k).negY x y) hn : (W⁄k).Point)
+        = Point.some x₁ ((W⁄k).negY x₁ y₁) hn₁ := by
+      have : (Point.some x ((W⁄k).negY x y) hn : (W⁄k).Point) = -Point.some x y h := by
+        rw [neg_some]
+      rw [this, smul_neg, hmP, neg_some]
+    obtain ⟨-, hval'⟩ := key_step W σ hσ m hn hn₁ hmP' hC
+    have hn' : (W⁄k).Nonsingular x' ((W⁄k).negY x' y') := (Affine.nonsingular_neg ..).mpr h'
+    have hrepr' : linePencil (frobEnd W σ) m 1 (Point.some x ((W⁄k).negY x y) hn)
+        = Point.some x' ((W⁄k).negY x' y') hn' := by
+      have : (Point.some x ((W⁄k).negY x y) hn : (W⁄k).Point) = -Point.some x y h := by
+        rw [neg_some]
+      rw [this, map_neg, hrepr, neg_some]
+    have e2 := hval' hn' hrepr'
+    rw [evalEval_eq_redX_add_redY (W⁄k) h.1] at e1
+    rw [evalEval_eq_redX_add_redY (W⁄k) hn.1] at e2
+    have hne : y - (W⁄k).negY x y ≠ 0 := by
+      intro h0
+      apply hΨ₂
+      rw [← sub_negY_sq (W⁄k) h.1, h0, zero_pow two_ne_zero]
+    have hY : (redY (W⁄k) (Gpoly (W⁄k) (Fintype.card F) m)).eval x = 0 := by
+      have : (redY (W⁄k) (Gpoly (W⁄k) (Fintype.card F) m)).eval x * (y - (W⁄k).negY x y) = 0 := by
+        linear_combination e2 - e1
+      exact (mul_eq_zero.mp this).resolve_right hne
+    rw [e1, hY, zero_mul, add_zero]
+
+end Main
+
+end FrobLineH3
+
+p2m_open "WeierstrassCurve~evalEval_ψ_sq~evalEval_φ" in
+open WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo in
+theorem solution {R : Type*} [CommRing R] {F : Type*} [Field F] [Fintype F] {k : Type*} [Field k]
+    [DecidableEq k] [Algebra R F] [Algebra R k] [Algebra F k] [IsScalarTower R F k] [IsAlgClosed k]
+    (W : WeierstrassCurve R) [(W⁄k).IsElliptic] (σ : k ≃ₐ[F] k)
+    (hσ : ∀ x : k, σ x = x ^ Fintype.card F) (m : ℤ)
+    (hfin : {x : k | ∃ (y : k) (h : (W⁄k).Nonsingular x y), m • Point.some x y h = 0}.Finite) :
+    ∃ U : Polynomial k, ((m : k) ≠ 0 → U.natDegree = 2 * m.natAbs ^ 2 + 2 * Fintype.card F - 1) ∧ ∀
+      {x y : k} (h : (W⁄k).Nonsingular x y) {x₁ y₁ : k} (h₁ : (W⁄k).Nonsingular x₁ y₁), m •
+      Point.some x y h = Point.some x₁ y₁ h₁ → ((W⁄k).ΨSq m).eval x ≠ 0 → ((W⁄k).Φ m - Polynomial.X
+      ^ Fintype.card F * (W⁄k).ΨSq m).eval x ≠ 0 → (W⁄k).Ψ₂Sq.eval x ≠ 0 → linePencil (frobEnd W σ)
+      m 1 (Point.some x y h) ≠ 0 ∧ ∀ {x' y' : k} (h' : (W⁄k).Nonsingular x' y'), linePencil (frobEnd
+      W σ) m 1 (Point.some x y h) = Point.some x' y' h' → x' * ((W⁄k).Φ m - Polynomial.X ^
+      Fintype.card F * (W⁄k).ΨSq m).eval x ^ 2 = U.eval x :=
+  FrobLineH3.exists_x_linePencil_frobEnd_mul_collision_sq W σ hσ m hfin
+
+end S_FrobeniusEndo_exists_x_linePencil_frobEnd_mul_collision_sq
+end P2MW
+export P2MW.S_FrobeniusEndo_exists_x_linePencil_frobEnd_mul_collision_sq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo
+
+theorem FrobeniusEndo.exists_x_linePencil_frobEnd_mul_collision_sq {R : Type*} [CommRing R]
+    {F : Type*} [Field F] [Fintype F] {k : Type*} [Field k] [DecidableEq k] [Algebra R F]
+    [Algebra R k] [Algebra F k] [IsScalarTower R F k] [IsAlgClosed k] (W : WeierstrassCurve R)
+    [(W⁄k).IsElliptic] (σ : k ≃ₐ[F] k) (hσ : ∀ x : k, σ x = x ^ Fintype.card F) (m : ℤ)
+    (hfin : {x : k | ∃ (y : k) (h : (W⁄k).Nonsingular x y), m • Point.some x y h = 0}.Finite) :
+    ∃ U : Polynomial k, ((m : k) ≠ 0 → U.natDegree = 2 * m.natAbs ^ 2 + 2 * Fintype.card F - 1) ∧ ∀
+      {x y : k} (h : (W⁄k).Nonsingular x y) {x₁ y₁ : k} (h₁ : (W⁄k).Nonsingular x₁ y₁), m •
+      Point.some x y h = Point.some x₁ y₁ h₁ → ((W⁄k).ΨSq m).eval x ≠ 0 → ((W⁄k).Φ m - Polynomial.X
+      ^ Fintype.card F * (W⁄k).ΨSq m).eval x ≠ 0 → (W⁄k).Ψ₂Sq.eval x ≠ 0 → linePencil (frobEnd W σ)
+      m 1 (Point.some x y h) ≠ 0 ∧ ∀ {x' y' : k} (h' : (W⁄k).Nonsingular x' y'), linePencil (frobEnd
+      W σ) m 1 (Point.some x y h) = Point.some x' y' h' → x' * ((W⁄k).Φ m - Polynomial.X ^
+      Fintype.card F * (W⁄k).ΨSq m).eval x ^ 2 = U.eval x :=
+  solution W σ hσ m hfin
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_ne_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_ne_zero.lean
new file mode 100644
index 0000000000..41658360d8
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_ne_zero.lean
@@ -0,0 +1,1536 @@
+/-
+Based on Prove2Me node FrobeniusEndo.frobCharEqOnPoints_of_charEq_on_torsion_of_trace_ne_zero
+(0a9ee3ec-4873-551c-bcd9-6c5ce00e5c79) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8cb83367-7f9b-5c80-9c55-d96e0aa012aa
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusEndo
+
+import Mathlib.NumberTheory.EllipticDivisibilitySequence
+import Mathlib.Algebra.Ring.NegOnePow
+import Mathlib.Data.Fin.VecNotation
+import Mathlib.Data.Fin.Tuple.Sort
+import Mathlib.Algebra.GroupWithZero.NonZeroDivisors
+import Mathlib.Algebra.MvPolynomial.CommRing
+import Mathlib.Algebra.MvPolynomial.Basic
+import Mathlib.Tactic.LinearCombination
+import Mathlib.Tactic.Ring
+import Mathlib.Tactic.Abel
+import Mathlib.Tactic.IntervalCases
+import Mathlib.Tactic.FieldSimp
+import Mathlib.GroupTheory.Perm.Basic
+import Mathlib.GroupTheory.Perm.Sign
+import Mathlib.GroupTheory.Perm.Cycle.Type
+import Mathlib.Algebra.Polynomial.Bivariate
+import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+import Mathlib.AlgebraicGeometry.EllipticCurve.Jacobian.Point
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+import Mathlib.FieldTheory.IsAlgClosed.Basic
+import Mathlib.FieldTheory.Separable
+import Mathlib.Data.Nat.Factorization.Induction
+import Mathlib.Logic.Embedding.Set
+import Mathlib.SetTheory.Cardinal.Finite
+import Mathlib.Data.Set.Card
+import Mathlib.Algebra.Module.Torsion.Basic
+import Mathlib.Algebra.Polynomial.Roots
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_EDSEngine
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Frobenius characteristic relation on all points from large torsion
+
+Theorem statement: `FrobeniusEndo.frobCharEqOnPoints_of_charEq_on_torsion_of_trace_ne_zero`
+(`0a9ee3ec-4873-551c-bcd9-6c5ce00e5c79`), by Claude, 2026-09-05.
+
+Proof: submission `8cb83367-7f9b-5c80-9c55-d96e0aa012aa`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring, $F$ a finite field and $k$ a field, equipped with $R$-algebra
+structures on $F$ and $k$ and an $F$-algebra structure on $k$ forming a scalar tower over $R$, and
+let $W$ be a Weierstrass curve over $R$ (no smoothness or discriminant hypothesis is imposed). Let
+$\sigma : k \simeq_{F} k$ be an $F$-algebra automorphism of $k$ which is the $q$-power map,
+$\sigma(x) = x^{q}$ for all $x \in k$, where $q = \#F$; $\sigma$ acts on the group
+$(W\!\restriction_{k}).\mathrm{Point}$ of points of the base change of $W$ to $k$. Let $a$ be a
+nonzero integer. Assume that for every natural number $N$ there exists a prime $r > N$ such that the
+$r$-torsion submodule $\mathrm{Submodule.torsionBy}\ \mathbb{Z}\
+(W\!\restriction_{k}).\mathrm{Point}\ r$ has exactly $r^{2}$ elements and such that every
+$r$-torsion point $P$ satisfies $\sigma\cdot(\sigma\cdot P) - a\cdot(\sigma\cdot P) + q\cdot P = 0$.
+The conclusion is `FrobCharEqOnPoints W σ a q`, that is, the same relation $\sigma\cdot(\sigma\cdot
+P) - a\cdot(\sigma\cdot P) + q\cdot P = 0$ holds for every point $P$ of
+$(W\!\restriction_{k}).\mathrm{Point}$, with no torsion restriction.
+
+This is the evaluation step in the elementary derivation of the characteristic equation $\pi^{2} -
+a\pi + q = 0$ for the $q$-power Frobenius on an elliptic curve: the relation, once known on the
+$r$-torsion for arbitrarily large primes $r$, propagates to all points. It is used by
+[`FrobeniusEndo.frobCharEqOnPoints_of_line`](thm.html#FrobeniusEndo.frobCharEqOnPoints_of_line), and
+is the $a \neq 0$ case, the vanishing-trace case being treated separately.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_ne_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_ne_zero
+
+section PortCardMulX
+
+namespace PortCard
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_ne_zero.WeierstrassCurve \
+  WeierstrassCurve.Affine \
+  P2MW.S_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_ne_zero.WeierstrassCurve.Af\
+  fine WeierstrassCurve.Affine.Point \
+  P2MW.S_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_ne_zero.WeierstrassCurve.Af\
+  fine.Point Polynomial"
+open scoped Polynomial.Bivariate
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+theorem zsmul_some_eq_some_of_evalEval_ψ_ne_zero {x y : F} (h : W.toAffine.Nonsingular x y)
+    {n : ℤ} (hψ : (W.ψ n).evalEval x y ≠ 0) :
+    ∃ (x' y' : F) (h' : W.toAffine.Nonsingular x' y'),
+      n • Point.some x y h = Point.some x' y' h' ∧
+        x' * (W.ψ n).evalEval x y ^ 2 = (W.φ n).evalEval x y ∧
+        x' * (W.ΨSq n).eval x = (W.Φ n).eval x := by
+  have heq : W.toAffine.Equation x y := h.left
+  have hψsq := W.evalEval_ψ_sq heq n
+  have key := zsmul_eq_smulEval W h n
+  have hVz : smulEval W x y n 2 ≠ 0 := hψ
+  have hV := key ▸ (n • Jacobian.Point.fromAffine (Point.some x y h)).nonsingular
+  have hQeq : (n • Jacobian.Point.fromAffine (Point.some x y h)) =
+      Jacobian.Point.mk hV := Jacobian.Point.ext key
+  refine ⟨smulEval W x y n 0 / smulEval W x y n 2 ^ 2,
+    smulEval W x y n 1 / smulEval W x y n 2 ^ 3,
+    (Jacobian.nonsingular_of_Z_ne_zero hVz).mp hV, ?_, ?_, ?_⟩
+  · calc n • Point.some x y h
+        = Jacobian.Point.toAffineAddEquiv W
+            (n • Jacobian.Point.fromAffine (Point.some x y h)) := by
+          rw [map_zsmul, ← Jacobian.Point.toAffineAddEquiv_symm_apply,
+            AddEquiv.apply_symm_apply]
+      _ = _ := by
+          rw [hQeq, Jacobian.Point.toAffineAddEquiv_apply]
+          exact Jacobian.Point.toAffineLift_of_Z_ne_zero hVz
+  · change (W.φ n).evalEval x y / (W.ψ n).evalEval x y ^ 2 * (W.ψ n).evalEval x y ^ 2 =
+        (W.φ n).evalEval x y
+    rw [div_mul_cancel₀ _ (pow_ne_zero 2 hψ)]
+  · change (W.φ n).evalEval x y / (W.ψ n).evalEval x y ^ 2 * (W.ΨSq n).eval x = (W.Φ n).eval x
+    rw [← hψsq, div_mul_cancel₀ _ (pow_ne_zero 2 hψ), W.evalEval_φ heq]
+
+theorem zsmul_some_eq_some_of_eval_ΨSq_ne_zero {x y : F} (h : W.toAffine.Nonsingular x y)
+    {n : ℤ} (hn : (W.ΨSq n).eval x ≠ 0) :
+    ∃ (x' y' : F) (h' : W.toAffine.Nonsingular x' y'),
+      n • Point.some x y h = Point.some x' y' h' ∧ x' * (W.ΨSq n).eval x = (W.Φ n).eval x := by
+  have hψ : (W.ψ n).evalEval x y ≠ 0 := fun h0 =>
+    hn (by rw [← W.evalEval_ψ_sq h.left n, h0]; exact zero_pow two_ne_zero)
+  obtain ⟨x', y', h', hP, -, hx⟩ := zsmul_some_eq_some_of_evalEval_ψ_ne_zero W h hψ
+  exact ⟨x', y', h', hP, hx⟩
+
+theorem zsmul_some_eq_zero_iff_eval_ΨSq {x y : F} (h : W.toAffine.Nonsingular x y) (n : ℤ) :
+    n • Point.some x y h = 0 ↔ (W.ΨSq n).eval x = 0 := by
+  rw [W.smul_eq_zero_iff_evalEval_ψ h n, ← W.evalEval_ψ_sq h.left n]
+  exact ⟨fun h0 => by rw [h0]; exact zero_pow two_ne_zero, fun h0 => (sq_eq_zero_iff).mp h0⟩
+
+theorem zsmul_some_eq_some_div {x y : F} (h : W.toAffine.Nonsingular x y) {n : ℤ}
+    (hψ : (W.ψ n).evalEval x y ≠ 0) :
+    ∃ (y' : F) (h' : W.toAffine.Nonsingular ((W.Φ n).eval x / (W.ΨSq n).eval x) y'),
+      n • Point.some x y h = Point.some ((W.Φ n).eval x / (W.ΨSq n).eval x) y' h' := by
+  obtain ⟨x', y', h', hP, -, hx⟩ := zsmul_some_eq_some_of_evalEval_ψ_ne_zero W h hψ
+  have hΨ : (W.ΨSq n).eval x ≠ 0 := by
+    rw [← W.evalEval_ψ_sq h.left n]; exact pow_ne_zero 2 hψ
+  obtain rfl : x' = (W.Φ n).eval x / (W.ΨSq n).eval x := by rw [eq_div_iff hΨ]; exact hx
+  exact ⟨y', h', hP⟩
+
+end PortCard
+
+end PortCardMulX
+
+open Polynomial
+
+universe u
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine a₃ a₁ map b₂ Jacobian.nonsingular_of_Z_ne_zero \
+  Jacobian.Point.toAffineAddEquiv_symm_apply natDegree_ΨSq_le mk a₄ Jacobian a₂ a₆ \
+  Affine.Point.some Affine.Point.X_eq_iff Affine.Point.map_injective Jacobian.Point.ext \
+  Jacobian.Point.fromAffine Jacobian.Point.toAffineAddEquiv_apply ΨSq toAffine Affine.Point \
+  map_injective Jacobian.Point.toAffineAddEquiv b₆ b₈ Affine.Point.some_ne_zero Δ \
+  Affine.Point.add_of_X_ne Jacobian.Point Affine.Point.neg_some j b₄ natDegree_Φ_le \
+  Jacobian.Point.toAffineLift_of_Z_ne_zero Jacobian.Point.mk smulEval zsmul_eq_smulEval \
+  evalEval_ψ_sq evalEval_φ smul_eq_zero_iff_evalEval_ψ"
+p2m_open "WeierstrassCurve"
+
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY slope_of_X_ne slope map Point.some \
+  Point.X_eq_iff Nonsingular Point.map_injective Point addX Point.some_ne_zero Point.add_of_X_ne \
+  equation_iff polynomial Point.neg_some Point.mk"
+namespace Point
+p2m_export "WeierstrassCurve.Affine.Point" "some neg_zero X_eq_iff map_injective map_zero map \
+  some_ne_zero add_of_X_ne zero neg_some mk"
+p2m_open "WeierstrassCurve.Affine.Point WeierstrassCurve.Affine"
+
+variable {R : Type u} [CommRing R] {W : Affine R}
+
+private def _root_.WeierstrassCurve.Affine.Point.xOrZero : W.Point → R
+  | .zero => 0
+  | .some x _ _ => x
+
+p2m_export "WeierstrassCurve.Affine.Point" "xOrZero"
+@[scoped simp] lemma xOrZero_zero : ((.zero : W.Point)).xOrZero = 0 := rfl
+
+@[scoped simp] lemma xOrZero_some {x y : R} (h : W.Nonsingular x y) :
+    (Point.some x y h).xOrZero = x := rfl
+
+end Affine.Point
+
+section AddQuad
+
+variable {R : Type u} [CommRing R] (W : WeierstrassCurve R)
+
+private def _root_.WeierstrassCurve.addQuad (a b c : R) : R :=
+  (a * b) ^ 2 - W.b₄ * (a * b) - W.b₆ * (a + b) - W.b₈
+    - c * (2 * (a * b) * (a + b) + W.b₂ * (a * b) + W.b₄ * (a + b) + W.b₆)
+    + c ^ 2 * (a - b) ^ 2
+
+p2m_export "WeierstrassCurve" "addQuad"
+lemma addQuad_def (a b c : R) :
+    W.addQuad a b c =
+      (a * b) ^ 2 - W.b₄ * (a * b) - W.b₆ * (a + b) - W.b₈
+        - c * (2 * (a * b) * (a + b) + W.b₂ * (a * b) + W.b₄ * (a + b) + W.b₆)
+        + c ^ 2 * (a - b) ^ 2 := rfl
+
+end AddQuad
+
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY slope_of_X_ne slope map Point.some \
+  Point.X_eq_iff Nonsingular Point.map_injective Point addX Point.some_ne_zero Point.add_of_X_ne \
+  equation_iff polynomial Point.neg_some Point.mk"
+p2m_open "WeierstrassCurve.Affine"
+
+variable {F : Type u} [Field F] {W : Affine F}
+
+section slope
+
+variable [DecidableEq F]
+
+lemma addX_mul_sq_of_X_ne {x₁ x₂ : F} (y₁ y₂ : F) (hx : x₁ ≠ x₂) :
+    W.addX x₁ x₂ (W.slope x₁ x₂ y₁ y₂) * (x₁ - x₂) ^ 2 =
+      (y₁ - y₂) ^ 2 + W.a₁ * (y₁ - y₂) * (x₁ - x₂) - (W.a₂ + x₁ + x₂) * (x₁ - x₂) ^ 2 := by
+  have hd : x₁ - x₂ ≠ 0 := sub_ne_zero.mpr hx
+  rw [slope_of_X_ne hx, addX]
+  field_simp
+  ring
+
+theorem addX_add_addX_negY_mul_sq {x₁ x₂ y₁ y₂ : F} (h₁ : W.Equation x₁ y₁)
+    (h₂ : W.Equation x₂ y₂) (hx : x₁ ≠ x₂) :
+    (W.addX x₁ x₂ (W.slope x₁ x₂ y₁ y₂) +
+        W.addX x₁ x₂ (W.slope x₁ x₂ y₁ (W.negY x₂ y₂))) * (x₁ - x₂) ^ 2 =
+      2 * (x₁ * x₂) * (x₁ + x₂) + W.b₂ * (x₁ * x₂) + W.b₄ * (x₁ + x₂) + W.b₆ := by
+    have e₁ := addX_mul_sq_of_X_ne (W := W) y₁ y₂ hx
+    have e₂ := addX_mul_sq_of_X_ne (W := W) y₁ (W.negY x₂ y₂) hx
+    rw [equation_iff] at h₁ h₂
+    rw [add_mul, e₁, e₂, negY, b₂, b₄, b₆]
+    linear_combination 2 * h₁ + 2 * h₂
+
+theorem addX_mul_addX_negY_mul_sq {x₁ x₂ y₁ y₂ : F} (h₁ : W.Equation x₁ y₁)
+    (h₂ : W.Equation x₂ y₂) (hx : x₁ ≠ x₂) :
+    W.addX x₁ x₂ (W.slope x₁ x₂ y₁ y₂) *
+        W.addX x₁ x₂ (W.slope x₁ x₂ y₁ (W.negY x₂ y₂)) * (x₁ - x₂) ^ 2 =
+      (x₁ * x₂) ^ 2 - W.b₄ * (x₁ * x₂) - W.b₆ * (x₁ + x₂) - W.b₈ := by
+    have hd : x₁ - x₂ ≠ 0 := sub_ne_zero.mpr hx
+    have hd2 : (x₁ - x₂) ^ 2 ≠ 0 := pow_ne_zero 2 hd
+    have e₁ := addX_mul_sq_of_X_ne (W := W) y₁ y₂ hx
+    have e₂ := addX_mul_sq_of_X_ne (W := W) y₁ (W.negY x₂ y₂) hx
+    have key : ((y₁ - y₂) ^ 2 + W.a₁ * (y₁ - y₂) * (x₁ - x₂) -
+          (W.a₂ + x₁ + x₂) * (x₁ - x₂) ^ 2) *
+        ((y₁ - W.negY x₂ y₂) ^ 2 + W.a₁ * (y₁ - W.negY x₂ y₂) * (x₁ - x₂) -
+          (W.a₂ + x₁ + x₂) * (x₁ - x₂) ^ 2) =
+        ((x₁ * x₂) ^ 2 - W.b₄ * (x₁ * x₂) - W.b₆ * (x₁ + x₂) - W.b₈) * (x₁ - x₂) ^ 2 := by
+      rw [equation_iff] at h₁ h₂
+      rw [negY, b₄, b₆, b₈]
+      linear_combination
+        (W.a₁ ^ 2 * x₁ * x₂ - W.a₁ ^ 2 * x₂ ^ 2 + W.a₁ * W.a₃ * x₁ - W.a₁ * W.a₃ * x₂ +
+            W.a₁ * x₁ * y₁ - 2 * W.a₁ * x₂ * y₂ - W.a₂ * x₁ ^ 2 + 4 * W.a₂ * x₁ * x₂ -
+            2 * W.a₂ * x₂ ^ 2 + W.a₃ * y₁ - 2 * W.a₃ * y₂ + W.a₄ * x₁ + W.a₆ - x₁ ^ 3 +
+            2 * x₁ ^ 2 * x₂ + 2 * x₁ * x₂ ^ 2 - 2 * x₂ ^ 3 + y₁ ^ 2 - 2 * y₂ ^ 2) * h₁ +
+        (-W.a₁ ^ 2 * x₁ ^ 2 + W.a₁ ^ 2 * x₁ * x₂ - W.a₁ * W.a₃ * x₁ + W.a₁ * W.a₃ * x₂ +
+            W.a₁ * x₂ * y₂ - 4 * W.a₂ * x₁ ^ 2 + 4 * W.a₂ * x₁ * x₂ - W.a₂ * x₂ ^ 2 +
+            W.a₃ * y₂ - 2 * W.a₄ * x₁ + W.a₄ * x₂ - W.a₆ - 4 * x₁ ^ 3 + 2 * x₁ ^ 2 * x₂ +
+            2 * x₁ * x₂ ^ 2 - x₂ ^ 3 + y₂ ^ 2) * h₂
+    apply mul_left_cancel₀ hd2
+    calc (x₁ - x₂) ^ 2 * (W.addX x₁ x₂ (W.slope x₁ x₂ y₁ y₂) *
+            W.addX x₁ x₂ (W.slope x₁ x₂ y₁ (W.negY x₂ y₂)) * (x₁ - x₂) ^ 2)
+        = (W.addX x₁ x₂ (W.slope x₁ x₂ y₁ y₂) * (x₁ - x₂) ^ 2) *
+            (W.addX x₁ x₂ (W.slope x₁ x₂ y₁ (W.negY x₂ y₂)) * (x₁ - x₂) ^ 2) := by ring
+      _ = ((y₁ - y₂) ^ 2 + W.a₁ * (y₁ - y₂) * (x₁ - x₂) -
+              (W.a₂ + x₁ + x₂) * (x₁ - x₂) ^ 2) *
+            ((y₁ - W.negY x₂ y₂) ^ 2 + W.a₁ * (y₁ - W.negY x₂ y₂) * (x₁ - x₂) -
+              (W.a₂ + x₁ + x₂) * (x₁ - x₂) ^ 2) := by rw [e₁, e₂]
+      _ = ((x₁ * x₂) ^ 2 - W.b₄ * (x₁ * x₂) - W.b₆ * (x₁ + x₂) - W.b₈) * (x₁ - x₂) ^ 2 := key
+      _ = (x₁ - x₂) ^ 2 *
+            ((x₁ * x₂) ^ 2 - W.b₄ * (x₁ * x₂) - W.b₆ * (x₁ + x₂) - W.b₈) := by ring
+
+lemma addQuad_eval {x₁ x₂ y₁ y₂ : F} (h₁ : W.Equation x₁ y₁) (h₂ : W.Equation x₂ y₂)
+    (hx : x₁ ≠ x₂) (c : F) :
+    (W.addX x₁ x₂ (W.slope x₁ x₂ y₁ y₂) - c) *
+        (W.addX x₁ x₂ (W.slope x₁ x₂ y₁ (W.negY x₂ y₂)) - c) * (x₁ - x₂) ^ 2 =
+      W.addQuad x₁ x₂ c := by
+  have hs := addX_add_addX_negY_mul_sq h₁ h₂ hx
+  have hp := addX_mul_addX_negY_mul_sq h₁ h₂ hx
+  rw [addQuad_def]
+  linear_combination hp - c * hs
+
+lemma mfred {x y : F} (h : W.Nonsingular x y) (m : ℕ)
+    (hm : m • (Point.some x y h : W.Point) ≠ 0) :
+    (W.ΨSq (m : ℤ)).eval x ≠ 0 ∧
+      (m • (Point.some x y h : W.Point)).xOrZero * (W.ΨSq (m : ℤ)).eval x =
+        (W.Φ (m : ℤ)).eval x := by
+  have hmz : (m : ℤ) • (Point.some x y h : W.Point) ≠ 0 := by rwa [natCast_zsmul]
+  have hΨ : (W.ΨSq (m : ℤ)).eval x ≠ 0 := fun h0 =>
+    hmz ((PortCard.zsmul_some_eq_zero_iff_eval_ΨSq W h (m : ℤ)).mpr h0)
+  obtain ⟨x', y', h', hP, hx⟩ := PortCard.zsmul_some_eq_some_of_eval_ΨSq_ne_zero W h hΨ
+  refine ⟨hΨ, ?_⟩
+  rw [← natCast_zsmul, hP, Point.xOrZero_some]
+  exact hx
+
+end slope
+end Affine
+
+section PolyDef
+
+variable {k : Type*} [Field k] (W : WeierstrassCurve k) (a : ℤ) (q : ℕ)
+
+noncomputable def charEqSNum : Polynomial k :=
+  (W.Φ (a.natAbs : ℤ)).comp (X ^ q)
+
+noncomputable def charEqSDen : Polynomial k :=
+  (W.ΨSq (a.natAbs : ℤ)).comp (X ^ q)
+
+noncomputable def charEqTNum : Polynomial k :=
+  W.Φ (q : ℤ)
+
+noncomputable def charEqTDen : Polynomial k :=
+  W.ΨSq (q : ℤ)
+
+noncomputable def charEqDelta : Polynomial k :=
+  charEqSNum W a q * charEqTDen W q - charEqTNum W q * charEqSDen W a q
+
+noncomputable def charEqQuad : Polynomial k :=
+  (charEqSNum W a q * charEqTNum W q) ^ 2
+    - C W.b₄ * (charEqSNum W a q * charEqTNum W q) * (charEqSDen W a q * charEqTDen W q)
+    - C W.b₆ * (charEqSNum W a q * charEqTDen W q + charEqTNum W q * charEqSDen W a q)
+        * (charEqSDen W a q * charEqTDen W q)
+    - C W.b₈ * (charEqSDen W a q * charEqTDen W q) ^ 2
+    - X ^ q ^ 2 *
+        (C 2 * (charEqSNum W a q * charEqTNum W q)
+            * (charEqSNum W a q * charEqTDen W q + charEqTNum W q * charEqSDen W a q)
+          + C W.b₂ * (charEqSNum W a q * charEqTNum W q)
+              * (charEqSDen W a q * charEqTDen W q)
+          + C W.b₄ * (charEqSNum W a q * charEqTDen W q + charEqTNum W q * charEqSDen W a q)
+              * (charEqSDen W a q * charEqTDen W q)
+          + C W.b₆ * (charEqSDen W a q * charEqTDen W q) ^ 2)
+    + (X ^ q ^ 2) ^ 2 * charEqDelta W a q ^ 2
+
+noncomputable def charEqPoly : Polynomial k :=
+  charEqDelta W a q * charEqQuad W a q
+
+def charEqBlockBound (a : ℤ) (q : ℕ) : ℕ :=
+  a.natAbs ^ 2 * q + q ^ 2
+
+def charEqDegBound (a : ℤ) (q : ℕ) : ℕ :=
+  8 * charEqBlockBound a q
+
+def charEqPrimeBound (a : ℤ) (q : ℕ) : ℕ :=
+  2 * charEqDegBound a q + a.natAbs + q + 2
+
+lemma charEqDelta_eval {x xS xT : k}
+    (hS : (charEqSNum W a q).eval x = xS * (charEqSDen W a q).eval x)
+    (hT : (charEqTNum W q).eval x = xT * (charEqTDen W q).eval x) :
+    (charEqDelta W a q).eval x =
+      (charEqSDen W a q).eval x * (charEqTDen W q).eval x * (xS - xT) := by
+  simp only [charEqDelta, eval_sub, eval_mul]
+  rw [hS, hT]
+  ring
+
+lemma charEqQuad_eval {x xS xT : k}
+    (hS : (charEqSNum W a q).eval x = xS * (charEqSDen W a q).eval x)
+    (hT : (charEqTNum W q).eval x = xT * (charEqTDen W q).eval x) :
+    (charEqQuad W a q).eval x =
+      ((charEqSDen W a q).eval x) ^ 2 * ((charEqTDen W q).eval x) ^ 2
+        * W.addQuad xS xT (x ^ q ^ 2) := by
+  simp only [charEqQuad, charEqDelta, eval_add, eval_sub, eval_mul, eval_pow, eval_C, eval_X]
+  rw [hS, hT, addQuad_def]
+  ring
+
+lemma natDegree_charEqSNum_le : (charEqSNum W a q).natDegree ≤ charEqBlockBound a q := by
+  refine natDegree_comp_le.trans (le_trans ?_ (Nat.le_add_right _ _))
+  have h1 : (W.Φ (a.natAbs : ℤ)).natDegree ≤ a.natAbs ^ 2 := by
+    have h := W.natDegree_Φ_le (a.natAbs : ℤ)
+    have heq : ((a.natAbs : ℤ)).natAbs = a.natAbs := by omega
+    rwa [heq] at h
+  have h2 : (X ^ q : Polynomial k).natDegree ≤ q := le_of_eq (natDegree_X_pow q)
+  exact Nat.mul_le_mul h1 h2
+
+lemma natDegree_charEqSDen_le : (charEqSDen W a q).natDegree ≤ charEqBlockBound a q := by
+  refine natDegree_comp_le.trans (le_trans ?_ (Nat.le_add_right _ _))
+  have h1 : (W.ΨSq (a.natAbs : ℤ)).natDegree ≤ a.natAbs ^ 2 := by
+    have h := W.natDegree_ΨSq_le (a.natAbs : ℤ)
+    have heq : ((a.natAbs : ℤ)).natAbs = a.natAbs := by omega
+    rw [heq] at h
+    exact h.trans (Nat.sub_le _ _)
+  have h2 : (X ^ q : Polynomial k).natDegree ≤ q := le_of_eq (natDegree_X_pow q)
+  exact Nat.mul_le_mul h1 h2
+
+lemma natDegree_charEqTNum_le : (charEqTNum W q).natDegree ≤ charEqBlockBound a q := by
+  refine le_trans ?_ (Nat.le_add_left _ _)
+  have h := W.natDegree_Φ_le (q : ℤ)
+  have heq : ((q : ℤ)).natAbs = q := by omega
+  rw [heq] at h
+  exact h
+
+lemma natDegree_charEqTDen_le : (charEqTDen W q).natDegree ≤ charEqBlockBound a q := by
+  refine le_trans ?_ (Nat.le_add_left _ _)
+  have h := W.natDegree_ΨSq_le (q : ℤ)
+  have heq : ((q : ℤ)).natAbs = q := by omega
+  rw [heq] at h
+  exact h.trans (Nat.sub_le _ _)
+
+lemma natDegree_charEqDelta_le :
+    (charEqDelta W a q).natDegree ≤ 2 * charEqBlockBound a q := by
+  have hSN := natDegree_charEqSNum_le W a q
+  have hSD := natDegree_charEqSDen_le W a q
+  have hTN := natDegree_charEqTNum_le W a q
+  have hTD := natDegree_charEqTDen_le W a q
+  refine (natDegree_sub_le _ _).trans (max_le ?_ ?_)
+  · exact (natDegree_mul_le.trans (Nat.add_le_add hSN hTD)).trans (le_of_eq (two_mul _).symm)
+  · exact (natDegree_mul_le.trans (Nat.add_le_add hTN hSD)).trans (le_of_eq (two_mul _).symm)
+
+private lemma natDegree_two_block_le_aux {p₁ p₂ : Polynomial k}
+    (h₁ : p₁.natDegree ≤ charEqBlockBound a q) (h₂ : p₂.natDegree ≤ charEqBlockBound a q) :
+    (p₁ * p₂).natDegree ≤ 2 * charEqBlockBound a q :=
+  natDegree_mul_le.trans ((Nat.add_le_add h₁ h₂).trans (le_of_eq (two_mul _).symm))
+
+private lemma natDegree_C_mul_mul_le_aux (c : k) {p₁ p₂ : Polynomial k}
+    (h₁ : p₁.natDegree ≤ 2 * charEqBlockBound a q)
+    (h₂ : p₂.natDegree ≤ 2 * charEqBlockBound a q) :
+    (C c * p₁ * p₂).natDegree ≤ 4 * charEqBlockBound a q := by
+  have hfirst : (C c * p₁).natDegree ≤ 2 * charEqBlockBound a q := by
+    refine natDegree_mul_le.trans ?_
+    rw [natDegree_C, Nat.zero_add]
+    exact h₁
+  refine natDegree_mul_le.trans ?_
+  calc (C c * p₁).natDegree + p₂.natDegree
+      ≤ 2 * charEqBlockBound a q + 2 * charEqBlockBound a q := Nat.add_le_add hfirst h₂
+    _ = 4 * charEqBlockBound a q := by ring
+
+private lemma le_six_blocks_of_le_four {n : ℕ} (h : n ≤ 4 * charEqBlockBound a q) :
+    n ≤ 6 * charEqBlockBound a q :=
+  h.trans (Nat.mul_le_mul (by norm_num) le_rfl)
+
+private lemma natDegree_C_mul_sq_le_aux (c : k) {p : Polynomial k}
+    (h : p.natDegree ≤ 2 * charEqBlockBound a q) :
+    (C c * p ^ 2).natDegree ≤ 4 * charEqBlockBound a q := by
+  refine natDegree_mul_le.trans ?_
+  rw [natDegree_C, Nat.zero_add]
+  refine natDegree_pow_le.trans ?_
+  calc 2 * p.natDegree ≤ 2 * (2 * charEqBlockBound a q) := Nat.mul_le_mul le_rfl h
+    _ = 4 * charEqBlockBound a q := by ring
+
+private lemma natDegree_charEqQuad_le :
+    (charEqQuad W a q).natDegree ≤ 6 * charEqBlockBound a q := by
+  have hSN := natDegree_charEqSNum_le W a q
+  have hSD := natDegree_charEqSDen_le W a q
+  have hTN := natDegree_charEqTNum_le W a q
+  have hTD := natDegree_charEqTDen_le W a q
+  have hX : (X ^ q ^ 2 : Polynomial k).natDegree ≤ charEqBlockBound a q :=
+    le_trans (le_of_eq (natDegree_X_pow _)) (Nat.le_add_left _ _)
+  have hNN := natDegree_two_block_le_aux a q hSN hTN
+  have hDD := natDegree_two_block_le_aux a q hSD hTD
+  have hcross : (charEqSNum W a q * charEqTDen W q
+      + charEqTNum W q * charEqSDen W a q).natDegree ≤ 2 * charEqBlockBound a q :=
+    (natDegree_add_le _ _).trans (max_le (natDegree_two_block_le_aux a q hSN hTD)
+      (natDegree_two_block_le_aux a q hTN hSD))
+  have hDelta := natDegree_charEqDelta_le W a q
+  have h1 : ((charEqSNum W a q * charEqTNum W q) ^ 2).natDegree
+      ≤ 6 * charEqBlockBound a q := by
+    refine le_six_blocks_of_le_four a q (natDegree_pow_le.trans ?_)
+    calc 2 * (charEqSNum W a q * charEqTNum W q).natDegree
+        ≤ 2 * (2 * charEqBlockBound a q) := Nat.mul_le_mul le_rfl hNN
+      _ = 4 * charEqBlockBound a q := by ring
+  have h2 : (C W.b₄ * (charEqSNum W a q * charEqTNum W q)
+      * (charEqSDen W a q * charEqTDen W q)).natDegree ≤ 6 * charEqBlockBound a q :=
+    le_six_blocks_of_le_four a q (natDegree_C_mul_mul_le_aux a q W.b₄ hNN hDD)
+  have h3 : (C W.b₆ * (charEqSNum W a q * charEqTDen W q + charEqTNum W q * charEqSDen W a q)
+      * (charEqSDen W a q * charEqTDen W q)).natDegree ≤ 6 * charEqBlockBound a q :=
+    le_six_blocks_of_le_four a q (natDegree_C_mul_mul_le_aux a q W.b₆ hcross hDD)
+  have h4 : (C W.b₈ * (charEqSDen W a q * charEqTDen W q) ^ 2).natDegree
+      ≤ 6 * charEqBlockBound a q :=
+    le_six_blocks_of_le_four a q (natDegree_C_mul_sq_le_aux a q W.b₈ hDD)
+  have h5 : (X ^ q ^ 2 *
+      (C 2 * (charEqSNum W a q * charEqTNum W q)
+          * (charEqSNum W a q * charEqTDen W q + charEqTNum W q * charEqSDen W a q)
+        + C W.b₂ * (charEqSNum W a q * charEqTNum W q)
+            * (charEqSDen W a q * charEqTDen W q)
+        + C W.b₄ * (charEqSNum W a q * charEqTDen W q + charEqTNum W q * charEqSDen W a q)
+            * (charEqSDen W a q * charEqTDen W q)
+        + C W.b₆ * (charEqSDen W a q * charEqTDen W q) ^ 2)).natDegree
+      ≤ 6 * charEqBlockBound a q := by
+    have hin : (C 2 * (charEqSNum W a q * charEqTNum W q)
+          * (charEqSNum W a q * charEqTDen W q + charEqTNum W q * charEqSDen W a q)
+        + C W.b₂ * (charEqSNum W a q * charEqTNum W q)
+            * (charEqSDen W a q * charEqTDen W q)
+        + C W.b₄ * (charEqSNum W a q * charEqTDen W q + charEqTNum W q * charEqSDen W a q)
+            * (charEqSDen W a q * charEqTDen W q)
+        + C W.b₆ * (charEqSDen W a q * charEqTDen W q) ^ 2).natDegree
+        ≤ 4 * charEqBlockBound a q := by
+      refine (natDegree_add_le _ _).trans (max_le ((natDegree_add_le _ _).trans (max_le
+        ((natDegree_add_le _ _).trans (max_le ?_ ?_)) ?_)) ?_)
+      · exact natDegree_C_mul_mul_le_aux a q 2 hNN hcross
+      · exact natDegree_C_mul_mul_le_aux a q W.b₂ hNN hDD
+      · exact natDegree_C_mul_mul_le_aux a q W.b₄ hcross hDD
+      · exact natDegree_C_mul_sq_le_aux a q W.b₆ hDD
+    refine natDegree_mul_le.trans ?_
+    calc (X ^ q ^ 2 : Polynomial k).natDegree
+          + (C 2 * (charEqSNum W a q * charEqTNum W q)
+              * (charEqSNum W a q * charEqTDen W q + charEqTNum W q * charEqSDen W a q)
+            + C W.b₂ * (charEqSNum W a q * charEqTNum W q)
+                * (charEqSDen W a q * charEqTDen W q)
+            + C W.b₄ * (charEqSNum W a q * charEqTDen W q
+                + charEqTNum W q * charEqSDen W a q)
+                * (charEqSDen W a q * charEqTDen W q)
+            + C W.b₆ * (charEqSDen W a q * charEqTDen W q) ^ 2).natDegree
+        ≤ charEqBlockBound a q + 4 * charEqBlockBound a q := Nat.add_le_add hX hin
+      _ ≤ 6 * charEqBlockBound a q := by
+          rw [show charEqBlockBound a q + 4 * charEqBlockBound a q
+            = 5 * charEqBlockBound a q from by ring]
+          exact Nat.mul_le_mul (by norm_num) le_rfl
+  have h6 : ((X ^ q ^ 2) ^ 2 * charEqDelta W a q ^ 2).natDegree
+      ≤ 6 * charEqBlockBound a q := by
+    refine natDegree_mul_le.trans ?_
+    have hX2 : ((X ^ q ^ 2 : Polynomial k) ^ 2).natDegree ≤ 2 * charEqBlockBound a q :=
+      natDegree_pow_le.trans (Nat.mul_le_mul le_rfl hX)
+    have hD2 : (charEqDelta W a q ^ 2).natDegree ≤ 4 * charEqBlockBound a q := by
+      refine natDegree_pow_le.trans ?_
+      calc 2 * (charEqDelta W a q).natDegree ≤ 2 * (2 * charEqBlockBound a q) :=
+            Nat.mul_le_mul le_rfl hDelta
+        _ = 4 * charEqBlockBound a q := by ring
+    calc ((X ^ q ^ 2 : Polynomial k) ^ 2).natDegree + (charEqDelta W a q ^ 2).natDegree
+        ≤ 2 * charEqBlockBound a q + 4 * charEqBlockBound a q := Nat.add_le_add hX2 hD2
+      _ = 6 * charEqBlockBound a q := by ring
+  unfold charEqQuad
+  exact (natDegree_add_le _ _).trans (max_le ((natDegree_sub_le _ _).trans (max_le
+    ((natDegree_sub_le _ _).trans (max_le ((natDegree_sub_le _ _).trans (max_le
+      ((natDegree_sub_le _ _).trans (max_le h1 h2)) h3)) h4)) h5)) h6)
+
+lemma natDegree_charEqPoly_le :
+    (charEqPoly W a q).natDegree ≤ charEqDegBound a q := by
+  have h1 := natDegree_charEqDelta_le W a q
+  have h2 := natDegree_charEqQuad_le W a q
+  unfold charEqPoly charEqDegBound
+  refine natDegree_mul_le.trans ?_
+  calc (charEqDelta W a q).natDegree + (charEqQuad W a q).natDegree
+      ≤ 2 * charEqBlockBound a q + 6 * charEqBlockBound a q := Nat.add_le_add h1 h2
+    _ = 8 * charEqBlockBound a q := by ring
+
+end PolyDef
+
+section PointHelpers
+
+variable {k : Type*} [Field k]
+
+private lemma some_congr_charEq {V : WeierstrassCurve k} {x₁ x₂ y₁ y₂ : k}
+    (hx : x₁ = x₂) (hy : y₁ = y₂) (h₁ : V.toAffine.Nonsingular x₁ y₁)
+    (h₂ : V.toAffine.Nonsingular x₂ y₂) :
+    Affine.Point.some x₁ y₁ h₁ = Affine.Point.some x₂ y₂ h₂ := by
+  subst hx; subst hy; rfl
+
+private lemma xOrZero_neg_charEq {V : WeierstrassCurve k}
+    (P : V.toAffine.Point) : (-P).xOrZero = P.xOrZero := by
+  classical
+  cases P with
+  | zero =>
+      change (-(0 : V.toAffine.Point)).xOrZero = (0 : V.toAffine.Point).xOrZero
+      rw [neg_zero]
+  | some x y h =>
+      rw [Affine.Point.neg_some, Affine.Point.xOrZero_some, Affine.Point.xOrZero_some]
+
+private lemma exists_some_of_ne_zero_charEq {V : WeierstrassCurve k} {P : V.toAffine.Point}
+    (hP : P ≠ 0) :
+    ∃ (x y : k) (h : V.toAffine.Nonsingular x y), P = Affine.Point.some x y h := by
+  cases P with
+  | zero => exact absurd rfl hP
+  | some x y h => exact ⟨x, y, h, rfl⟩
+
+private lemma eq_zero_of_nsmul_eq_zero_of_lt_prime {G : Type*} [AddCommGroup G] {r m : ℕ}
+    (hr : r.Prime) (hm0 : 0 < m) (hmr : m < r) {x : G} (hxr : r • x = 0) (hxm : m • x = 0) :
+    x = 0 := by
+  have h1 : addOrderOf x ∣ m := addOrderOf_dvd_of_nsmul_eq_zero hxm
+  have h2 : addOrderOf x ∣ r := addOrderOf_dvd_of_nsmul_eq_zero hxr
+  have hnd : ¬ r ∣ m := fun hdvd => absurd (Nat.le_of_dvd hm0 hdvd) (not_le.mpr hmr)
+  have hco : Nat.Coprime r m := (Nat.Prime.coprime_iff_not_dvd hr).mpr hnd
+  have hgcd : Nat.gcd m r = 1 := hco.symm
+  have h3 : addOrderOf x ∣ Nat.gcd m r := Nat.dvd_gcd h1 h2
+  rw [hgcd] at h3
+  have h4 : addOrderOf x = 1 := Nat.dvd_one.mp h3
+  have h5 := addOrderOf_nsmul_eq_zero x
+  rwa [h4, one_nsmul] at h5
+
+private lemma lowTorsionFree_of_prime_torsion [DecidableEq k] {V : WeierstrassCurve k}
+    {P : V.toAffine.Point} (hP0 : P ≠ 0) {r : ℕ} (hr : r.Prime) (hPr : (r : ℤ) • P = 0) :
+    ∀ j : ℕ, 1 ≤ j → j ≤ r - 1 → j • P ≠ 0 := by
+  intro j hj1 hjr hcontra
+  have hPr' : r • P = 0 := by rwa [natCast_zsmul] at hPr
+  exact hP0 (eq_zero_of_nsmul_eq_zero_of_lt_prime hr (by omega) (by omega) hPr' hcontra)
+
+end PointHelpers
+
+section Forward
+
+variable {k : Type*} [Field k] [DecidableEq k] {V : WeierstrassCurve k} {q : ℕ}
+  (Fr : V.toAffine.Point →+ V.toAffine.Point)
+  (hFr : ∀ {x y : k} (h : V.toAffine.Nonsingular x y),
+    ∃ h' : V.toAffine.Nonsingular (x ^ q) (y ^ q),
+      Fr (Affine.Point.some x y h) = Affine.Point.some (x ^ q) (y ^ q) h')
+  (hinj : Function.Injective Fr)
+
+include hFr hinj in
+theorem charEqPoly_eval_eq_zero_of_charEq_at (hq1 : 1 ≤ q)
+    {a : ℤ} (ha : a ≠ 0) {r : ℕ} (hr : r.Prime)
+    (hq_lt : q < r) (ha_lt : a.natAbs < r)
+    {P : V.toAffine.Point} (hP0 : P ≠ 0) (hPr : (r : ℤ) • P = 0)
+    (hkill : Fr (Fr P) - a • Fr P + (q : ℤ) • P = 0) :
+    (charEqPoly V a q).eval P.xOrZero = 0 := by
+  classical
+  obtain ⟨x, y, h, rfl⟩ := exists_some_of_ne_zero_charEq hP0
+  rw [Affine.Point.xOrZero_some]
+  have ha1 : 1 ≤ a.natAbs := Int.natAbs_pos.mpr ha
+  have hfree := lowTorsionFree_of_prime_torsion (Affine.Point.some_ne_zero h) hr hPr
+  have hT0 : q • (Affine.Point.some x y h : V.toAffine.Point) ≠ 0 :=
+    hfree q hq1 (by omega)
+  have hMT := Affine.mfred h q hT0
+  obtain ⟨hns', hFP⟩ := hFr h
+  have hS0 : a.natAbs • (Affine.Point.some (x ^ q) (y ^ q) hns' : V.toAffine.Point) ≠ 0 := by
+    intro hcontra
+    apply hfree a.natAbs ha1 (by omega)
+    apply hinj
+    rw [map_nsmul, hFP, hcontra, map_zero]
+  have hMS := Affine.mfred hns' a.natAbs hS0
+  obtain ⟨xT, yT, hTns, hTpt⟩ := exists_some_of_ne_zero_charEq hT0
+  obtain ⟨xS, yS, hSns, hSpt⟩ := exists_some_of_ne_zero_charEq hS0
+  have hTclear : (V.Φ ((q : ℕ) : ℤ)).eval x = xT * (V.ΨSq ((q : ℕ) : ℤ)).eval x := by
+    rw [← hMT.2, hTpt, Affine.Point.xOrZero_some]
+  have hSclear : (V.Φ ((a.natAbs : ℕ) : ℤ)).eval (x ^ q) =
+      xS * (V.ΨSq ((a.natAbs : ℕ) : ℤ)).eval (x ^ q) := by
+    rw [← hMS.2, hSpt, Affine.Point.xOrZero_some]
+  have hSnum : (charEqSNum V a q).eval x = xS * (charEqSDen V a q).eval x := by
+    simp only [charEqSNum, charEqSDen, eval_comp, eval_pow, eval_X]
+    exact hSclear
+  have hTnum : (charEqTNum V q).eval x = xT * (charEqTDen V q).eval x := by
+    simp only [charEqTNum, charEqTDen]
+    exact hTclear
+  by_cases hxx : xS = xT
+  · have hd : (charEqDelta V a q).eval x = 0 := by
+      rw [charEqDelta_eval V a q hSnum hTnum, hxx]
+      ring
+    unfold charEqPoly
+    rw [eval_mul, hd, zero_mul]
+  · have hkill' : Fr (Fr (Affine.Point.some x y h)) =
+        a • Fr (Affine.Point.some x y h) - (q : ℤ) • (Affine.Point.some x y h : V.toAffine.Point) :=
+          by
+      have h0 := hkill
+      rw [sub_add_eq_add_sub, sub_eq_zero] at h0
+      exact eq_sub_of_add_eq h0
+    obtain ⟨hns₂, hFP₂⟩ := hFr hns'
+    have hns'' : V.toAffine.Nonsingular (x ^ q ^ 2) (y ^ q ^ 2) := by
+      have h2 := hns₂
+      rwa [← pow_mul, ← pow_mul, ← pow_two] at h2
+    have hF2 : Fr (Fr (Affine.Point.some x y h)) =
+        Affine.Point.some (x ^ q ^ 2) (y ^ q ^ 2) hns'' := by
+      rw [hFP, hFP₂]
+      exact some_congr_charEq (by rw [← pow_mul, ← pow_two]) (by rw [← pow_mul, ← pow_two]) _ _
+    have hxF2 : (x : k) ^ q ^ 2 =
+        (a • Fr (Affine.Point.some x y h)
+          - (q : ℤ) • (Affine.Point.some x y h : V.toAffine.Point)).xOrZero := by
+      rw [← hkill', hF2, Affine.Point.xOrZero_some]
+    have hquadzero : V.addQuad xS xT (x ^ q ^ 2) = 0 := by
+      have haddq :
+          (V.toAffine.addX xS xT (V.toAffine.slope xS xT yS yT) - x ^ q ^ 2) *
+            (V.toAffine.addX xS xT (V.toAffine.slope xS xT yS (V.toAffine.negY xT yT))
+              - x ^ q ^ 2) * (xS - xT) ^ 2 =
+            V.addQuad xS xT (x ^ q ^ 2) :=
+        Affine.addQuad_eval hSns.left hTns.left hxx (x ^ q ^ 2)
+      rw [← haddq]
+      rcases Int.natAbs_eq a with hsign | hsign
+      · have hrhs : a • Fr (Affine.Point.some x y h)
+            - (q : ℤ) • (Affine.Point.some x y h : V.toAffine.Point) =
+            (Affine.Point.some xS yS hSns : V.toAffine.Point) + (- Affine.Point.some xT yT hTns) :=
+              by
+          rw [hsign, natCast_zsmul, natCast_zsmul, hFP, hSpt, hTpt, sub_eq_add_neg]
+        have hx2 : (x : k) ^ q ^ 2 =
+            V.toAffine.addX xS xT (V.toAffine.slope xS xT yS (V.toAffine.negY xT yT)) := by
+          rw [hxF2, hrhs, Affine.Point.neg_some, Affine.Point.add_of_X_ne hxx,
+            Affine.Point.xOrZero_some]
+        rw [show (V.toAffine.addX xS xT (V.toAffine.slope xS xT yS (V.toAffine.negY xT yT))
+            - x ^ q ^ 2) = 0 from by rw [hx2]; ring]
+        ring
+      · have hrhs : a • Fr (Affine.Point.some x y h)
+            - (q : ℤ) • (Affine.Point.some x y h : V.toAffine.Point) =
+            - ((Affine.Point.some xS yS hSns : V.toAffine.Point) + Affine.Point.some xT yT hTns) :=
+              by
+          rw [hsign, neg_zsmul, natCast_zsmul, natCast_zsmul, hFP, hSpt, hTpt]
+          abel
+        have hx2 : (x : k) ^ q ^ 2 =
+            V.toAffine.addX xS xT (V.toAffine.slope xS xT yS yT) := by
+          rw [hxF2, hrhs, xOrZero_neg_charEq, Affine.Point.add_of_X_ne hxx,
+            Affine.Point.xOrZero_some]
+        rw [show (V.toAffine.addX xS xT (V.toAffine.slope xS xT yS yT) - x ^ q ^ 2) = 0 from by
+          rw [hx2]; ring]
+        ring
+    calc (charEqPoly V a q).eval x
+        = (charEqDelta V a q).eval x * (charEqQuad V a q).eval x := by
+          unfold charEqPoly
+          rw [eval_mul]
+      _ = (charEqDelta V a q).eval x *
+            (((charEqSDen V a q).eval x) ^ 2 * ((charEqTDen V q).eval x) ^ 2
+              * V.addQuad xS xT (x ^ q ^ 2)) := by
+          rw [charEqQuad_eval V a q hSnum hTnum]
+      _ = 0 := by rw [hquadzero]; ring
+
+end Forward
+
+section Counting
+
+variable {k : Type*} [Field k] [DecidableEq k] {V : WeierstrassCurve k} {q : ℕ}
+  (Fr : V.toAffine.Point →+ V.toAffine.Point)
+  (hFr : ∀ {x y : k} (h : V.toAffine.Nonsingular x y),
+    ∃ h' : V.toAffine.Nonsingular (x ^ q) (y ^ q),
+      Fr (Affine.Point.some x y h) = Affine.Point.some (x ^ q) (y ^ q) h')
+  (hinj : Function.Injective Fr)
+
+include hFr hinj in
+theorem charEqPoly_eq_zero_of_forall_torsionBy (hq1 : 1 ≤ q)
+    {a : ℤ} (ha : a ≠ 0) {r : ℕ} (hr : r.Prime)
+    (hrB : charEqPrimeBound a q < r)
+    (hcard : Nat.card (Submodule.torsionBy ℤ V.toAffine.Point r) = r ^ 2)
+    (hkill : ∀ P : V.toAffine.Point, (r : ℤ) • P = 0 →
+      Fr (Fr P) - a • Fr P + (q : ℤ) • P = 0) :
+    charEqPoly V a q = 0 := by
+  classical
+  have hq_lt : q < r := by
+    have hb : q ≤ charEqPrimeBound a q := by
+      change q ≤ 2 * charEqDegBound a q + a.natAbs + q + 2
+      omega
+    omega
+  have ha_lt : a.natAbs < r := by
+    have hb : a.natAbs ≤ charEqPrimeBound a q := by
+      change a.natAbs ≤ 2 * charEqDegBound a q + a.natAbs + q + 2
+      omega
+    omega
+  have hfin : Finite (Submodule.torsionBy ℤ V.toAffine.Point r) := by
+    apply Nat.finite_of_card_ne_zero
+    rw [hcard]
+    exact pow_ne_zero 2 hr.pos.ne'
+  have : Fintype (Submodule.torsionBy ℤ V.toAffine.Point r) := Fintype.ofFinite _
+  have hcardT : Fintype.card (Submodule.torsionBy ℤ V.toAffine.Point r) = r ^ 2 := by
+    rw [← Nat.card_eq_fintype_card]
+    exact hcard
+  have hs₀card : (Finset.univ.erase
+      (0 : Submodule.torsionBy ℤ V.toAffine.Point r)).card + 1 = r ^ 2 := by
+    rw [Finset.card_erase_add_one (Finset.mem_univ 0), Finset.card_univ, hcardT]
+  have hcount : (Finset.univ.erase
+        (0 : Submodule.torsionBy ℤ V.toAffine.Point r)).card
+      ≤ 2 * ((Finset.univ.erase
+          (0 : Submodule.torsionBy ℤ V.toAffine.Point r)).image
+          (fun P : Submodule.torsionBy ℤ V.toAffine.Point r =>
+            ((P : V.toAffine.Point)).xOrZero)).card := by
+    apply Finset.card_le_mul_card_image
+    intro z hz
+    obtain ⟨P₀, hP₀mem, hP₀x⟩ := Finset.mem_image.mp hz
+    have hP₀ne : (P₀ : V.toAffine.Point) ≠ 0 := by
+      intro hc
+      exact (Finset.mem_erase.mp hP₀mem).1 (ZeroMemClass.coe_eq_zero.mp hc)
+    obtain ⟨xP, yP, hPns, hPeq⟩ := exists_some_of_ne_zero_charEq hP₀ne
+    refine le_trans (Finset.card_le_card (t := {P₀, -P₀}) ?_) ?_
+    · intro Q hQ
+      have hQmem := (Finset.mem_filter.mp hQ).1
+      have hQx : ((Q : V.toAffine.Point)).xOrZero = z :=
+        (Finset.mem_filter.mp hQ).2
+      have hQne : (Q : V.toAffine.Point) ≠ 0 := by
+        intro hc
+        exact (Finset.mem_erase.mp hQmem).1 (ZeroMemClass.coe_eq_zero.mp hc)
+      obtain ⟨xQ, yQ, hQns, hQeq⟩ := exists_some_of_ne_zero_charEq hQne
+      have hxx : xQ = xP := by
+        have h1 : xQ = z := by
+          rw [hQeq, Affine.Point.xOrZero_some] at hQx
+          exact hQx
+        have h2 : xP = z := by
+          rw [hPeq, Affine.Point.xOrZero_some] at hP₀x
+          exact hP₀x
+        rw [h1, h2]
+      rcases (Affine.Point.X_eq_iff (h₁ := hQns) (h₂ := hPns)).mp hxx with heq | heq
+      · have hQP : Q = P₀ := Subtype.ext (by rw [hQeq, heq, ← hPeq])
+        exact Finset.mem_insert.mpr (Or.inl hQP)
+      · have hQP : Q = -P₀ := Subtype.ext (by rw [hQeq, heq, ← hPeq]; simp)
+        exact Finset.mem_insert.mpr (Or.inr (Finset.mem_singleton.mpr hQP))
+    · have h1 := Finset.card_insert_le P₀
+        ({-P₀} : Finset (Submodule.torsionBy ℤ V.toAffine.Point r))
+      have h2 : ({-P₀} : Finset
+          (Submodule.torsionBy ℤ V.toAffine.Point r)).card = 1 :=
+        Finset.card_singleton _
+      omega
+  have hroot : ∀ z ∈ (Finset.univ.erase
+      (0 : Submodule.torsionBy ℤ V.toAffine.Point r)).image
+      (fun P : Submodule.torsionBy ℤ V.toAffine.Point r =>
+        ((P : V.toAffine.Point)).xOrZero),
+      (charEqPoly V a q).eval z = 0 := by
+    intro z hz
+    obtain ⟨P, hPmem, rfl⟩ := Finset.mem_image.mp hz
+    have hPne : (P : V.toAffine.Point) ≠ 0 := by
+      intro hc
+      exact (Finset.mem_erase.mp hPmem).1 (ZeroMemClass.coe_eq_zero.mp hc)
+    have hPtor : (r : ℤ) • (P : V.toAffine.Point) = 0 :=
+      (Submodule.mem_torsionBy_iff _ _).mp P.2
+    exact charEqPoly_eval_eq_zero_of_charEq_at Fr hFr hinj hq1 ha hr hq_lt ha_lt hPne hPtor
+      (hkill _ hPtor)
+  by_contra hne
+  have hsle : ((Finset.univ.erase
+      (0 : Submodule.torsionBy ℤ V.toAffine.Point r)).image
+      (fun P : Submodule.torsionBy ℤ V.toAffine.Point r =>
+        ((P : V.toAffine.Point)).xOrZero)).card
+      ≤ (charEqPoly V a q).natDegree := by
+    have hsub : (Finset.univ.erase
+        (0 : Submodule.torsionBy ℤ V.toAffine.Point r)).image
+        (fun P : Submodule.torsionBy ℤ V.toAffine.Point r =>
+          ((P : V.toAffine.Point)).xOrZero)
+        ⊆ (charEqPoly V a q).roots.toFinset := by
+      intro z hz
+      rw [Multiset.mem_toFinset, Polynomial.mem_roots']
+      exact ⟨hne, hroot z hz⟩
+    calc ((Finset.univ.erase
+          (0 : Submodule.torsionBy ℤ V.toAffine.Point r)).image
+          (fun P : Submodule.torsionBy ℤ V.toAffine.Point r =>
+            ((P : V.toAffine.Point)).xOrZero)).card
+        ≤ (charEqPoly V a q).roots.toFinset.card :=
+          Finset.card_le_card hsub
+      _ ≤ Multiset.card (charEqPoly V a q).roots :=
+          Multiset.toFinset_card_le _
+      _ ≤ (charEqPoly V a q).natDegree :=
+          Polynomial.card_roots' _
+  have hdegle := natDegree_charEqPoly_le V a q
+  have hbig : 2 * charEqDegBound a q + 4 ≤ r := by
+    have heq : charEqPrimeBound a q
+        = 2 * charEqDegBound a q + a.natAbs + q + 2 := rfl
+    omega
+  have h2r : 2 ≤ r := by omega
+  have h2rle : 2 * r ≤ r ^ 2 := by
+    rw [pow_two]
+    exact Nat.mul_le_mul h2r le_rfl
+  have hup : r ^ 2 ≤ 2 * charEqDegBound a q + 1 := by
+    calc r ^ 2 = (Finset.univ.erase
+          (0 : Submodule.torsionBy ℤ V.toAffine.Point r)).card + 1 :=
+          hs₀card.symm
+      _ ≤ 2 * ((Finset.univ.erase
+            (0 : Submodule.torsionBy ℤ V.toAffine.Point r)).image
+            (fun P : Submodule.torsionBy ℤ V.toAffine.Point r =>
+              ((P : V.toAffine.Point)).xOrZero)).card + 1 := by omega
+      _ ≤ 2 * (charEqPoly V a q).natDegree + 1 := by omega
+      _ ≤ 2 * charEqDegBound a q + 1 := by omega
+  have hdown : 4 * charEqDegBound a q + 8 ≤ r ^ 2 :=
+    calc 4 * charEqDegBound a q + 8
+        = 2 * (2 * charEqDegBound a q + 4) := by ring
+      _ ≤ 2 * r := by omega
+      _ ≤ r ^ 2 := h2rle
+  have hcontr := hdown.trans hup
+  omega
+
+end Counting
+
+section Endgame
+
+variable {k : Type*} [Field k] [DecidableEq k] {V : WeierstrassCurve k} {q : ℕ}
+  (Fr : V.toAffine.Point →+ V.toAffine.Point)
+  (hFr : ∀ {x y : k} (h : V.toAffine.Nonsingular x y),
+    ∃ h' : V.toAffine.Nonsingular (x ^ q) (y ^ q),
+      Fr (Affine.Point.some x y h) = Affine.Point.some (x ^ q) (y ^ q) h')
+  (hinj : Function.Injective Fr)
+
+include hinj in
+private lemma frob_eq_zero_of {P : V.toAffine.Point} (h : Fr P = 0) : P = 0 :=
+  hinj (by rw [h, map_zero])
+
+include hFr hinj in
+theorem charEq_cases_of_charEqPoly_eq_zero (hq1 : 1 ≤ q) {a : ℤ} (ha : a ≠ 0)
+    (hpoly : charEqPoly V a q = 0)
+    {Q : V.toAffine.Point}
+    (hQ : ∀ j : ℕ, 1 ≤ j → j ≤ q + a.natAbs → j • Q ≠ 0) :
+    (Fr (Fr Q) - a • Fr Q + (q : ℤ) • Q = 0)
+    ∨ (Fr (Fr Q) + a • Fr Q - (q : ℤ) • Q = 0)
+    ∨ (Fr (Fr Q) - a • Fr Q - (q : ℤ) • Q = 0)
+    ∨ (Fr (Fr Q) + a • Fr Q + (q : ℤ) • Q = 0)
+    ∨ (a • Fr Q - (q : ℤ) • Q = 0)
+    ∨ (a • Fr Q + (q : ℤ) • Q = 0) := by
+  classical
+  have ha1 : 1 ≤ a.natAbs := Int.natAbs_pos.mpr ha
+  have hQ0 : Q ≠ 0 := by
+    intro h0
+    exact hQ 1 le_rfl (by omega) (by rw [h0, smul_zero])
+  obtain ⟨x, y, h, rfl⟩ := exists_some_of_ne_zero_charEq hQ0
+  have hT0 : q • (Affine.Point.some x y h : V.toAffine.Point) ≠ 0 :=
+    hQ q hq1 (Nat.le_add_right _ _)
+  have hMT := Affine.mfred h q hT0
+  obtain ⟨hns', hFP⟩ := hFr h
+  have hS0 : a.natAbs • (Affine.Point.some (x ^ q) (y ^ q) hns' : V.toAffine.Point) ≠ 0 := by
+    intro hcontra
+    have hcontra' : Fr (a.natAbs • (Affine.Point.some x y h : V.toAffine.Point)) = 0 := by
+      rw [map_nsmul, hFP]
+      exact hcontra
+    exact hQ a.natAbs ha1 (Nat.le_add_left _ _) (frob_eq_zero_of Fr hinj hcontra')
+  have hMS := Affine.mfred hns' a.natAbs hS0
+  obtain ⟨xT, yT, hTns, hTpt⟩ := exists_some_of_ne_zero_charEq hT0
+  obtain ⟨xS, yS, hSns, hSpt⟩ := exists_some_of_ne_zero_charEq hS0
+  have hTclear : (V.Φ ((q : ℕ) : ℤ)).eval x = xT * (V.ΨSq ((q : ℕ) : ℤ)).eval x := by
+    rw [← hMT.2, hTpt, Affine.Point.xOrZero_some]
+  have hSclear : (V.Φ ((a.natAbs : ℕ) : ℤ)).eval (x ^ q) =
+      xS * (V.ΨSq ((a.natAbs : ℕ) : ℤ)).eval (x ^ q) := by
+    rw [← hMS.2, hSpt, Affine.Point.xOrZero_some]
+  have hSnum : (charEqSNum V a q).eval x = xS * (charEqSDen V a q).eval x := by
+    simp only [charEqSNum, charEqSDen, eval_comp, eval_pow, eval_X]
+    exact hSclear
+  have hTnum : (charEqTNum V q).eval x = xT * (charEqTDen V q).eval x := by
+    simp only [charEqTNum, charEqTDen]
+    exact hTclear
+  have hDS : (charEqSDen V a q).eval x ≠ 0 := by
+    simp only [charEqSDen, eval_comp, eval_pow, eval_X]
+    exact hMS.1
+  have hDT : (charEqTDen V q).eval x ≠ 0 := by
+    simp only [charEqTDen]
+    exact hMT.1
+  have hzero : (charEqDelta V a q).eval x * (charEqQuad V a q).eval x = 0 := by
+    have h0 : (charEqDelta V a q * charEqQuad V a q) = 0 := hpoly
+    calc (charEqDelta V a q).eval x * (charEqQuad V a q).eval x
+        = (charEqDelta V a q * charEqQuad V a q).eval x := (eval_mul).symm
+      _ = (0 : Polynomial k).eval x := by rw [h0]
+      _ = 0 := eval_zero
+  rw [charEqDelta_eval V a q hSnum hTnum, charEqQuad_eval V a q hSnum hTnum] at hzero
+  have hkey : xS = xT ∨ V.addQuad xS xT (x ^ q ^ 2) = 0 := by
+    rcases mul_eq_zero.mp hzero with h1 | h2
+    · rcases mul_eq_zero.mp h1 with h1a | h1b
+      · rcases mul_eq_zero.mp h1a with hbad | hbad
+        · exact absurd hbad hDS
+        · exact absurd hbad hDT
+      · exact Or.inl (sub_eq_zero.mp h1b)
+    · rcases mul_eq_zero.mp h2 with h2a | h2b
+      · rcases mul_eq_zero.mp h2a with hbad | hbad
+        · exact absurd (sq_eq_zero_iff.mp hbad) hDS
+        · exact absurd (sq_eq_zero_iff.mp hbad) hDT
+      · exact Or.inr h2b
+  by_cases hxx : xS = xT
+  · rcases (Affine.Point.X_eq_iff (h₁ := hSns) (h₂ := hTns)).mp hxx with hpe | hpe
+    · have hrel : a.natAbs • Fr (Affine.Point.some x y h)
+          = q • (Affine.Point.some x y h : V.toAffine.Point) := by
+        rw [hFP, hSpt, hpe]
+        exact hTpt.symm
+      rcases Int.natAbs_eq a with hsign | hsign
+      · refine Or.inr (Or.inr (Or.inr (Or.inr (Or.inl ?_))))
+        rw [hsign, natCast_zsmul, natCast_zsmul, hrel]
+        abel
+      · refine Or.inr (Or.inr (Or.inr (Or.inr (Or.inr ?_))))
+        rw [hsign, neg_zsmul, natCast_zsmul, natCast_zsmul, hrel]
+        abel
+    · have hrel : a.natAbs • Fr (Affine.Point.some x y h)
+          = -(q • (Affine.Point.some x y h : V.toAffine.Point)) := by
+        rw [hFP, hSpt, hpe, hTpt]
+      rcases Int.natAbs_eq a with hsign | hsign
+      · refine Or.inr (Or.inr (Or.inr (Or.inr (Or.inr ?_))))
+        rw [hsign, natCast_zsmul, natCast_zsmul, hrel]
+        abel
+      · refine Or.inr (Or.inr (Or.inr (Or.inr (Or.inl ?_))))
+        rw [hsign, neg_zsmul, natCast_zsmul, natCast_zsmul, hrel]
+        abel
+  · have hquad : V.addQuad xS xT (x ^ q ^ 2) = 0 := hkey.resolve_left hxx
+    have hfact : (V.toAffine.addX xS xT (V.toAffine.slope xS xT yS yT) - x ^ q ^ 2)
+        * (V.toAffine.addX xS xT (V.toAffine.slope xS xT yS (V.toAffine.negY xT yT))
+          - x ^ q ^ 2)
+        * (xS - xT) ^ 2
+        = V.addQuad xS xT (x ^ q ^ 2) :=
+      Affine.addQuad_eval hSns.left hTns.left hxx (x ^ q ^ 2)
+    rw [hquad] at hfact
+    have hxsub : xS - xT ≠ 0 := sub_ne_zero.mpr hxx
+    have hroots : V.toAffine.addX xS xT (V.toAffine.slope xS xT yS yT) = x ^ q ^ 2
+        ∨ V.toAffine.addX xS xT (V.toAffine.slope xS xT yS (V.toAffine.negY xT yT))
+          = x ^ q ^ 2 := by
+      have h2 : (V.toAffine.addX xS xT (V.toAffine.slope xS xT yS yT) - x ^ q ^ 2)
+          * (V.toAffine.addX xS xT (V.toAffine.slope xS xT yS (V.toAffine.negY xT yT))
+            - x ^ q ^ 2) = 0 := by
+        rcases mul_eq_zero.mp hfact with hgood | hbad
+        · exact hgood
+        · exact absurd (sq_eq_zero_iff.mp hbad) hxsub
+      rcases mul_eq_zero.mp h2 with hgood | hgood
+      · exact Or.inl (sub_eq_zero.mp hgood)
+      · exact Or.inr (sub_eq_zero.mp hgood)
+    obtain ⟨hns₂, hFP₂⟩ := hFr hns'
+    have hns'' : V.toAffine.Nonsingular (x ^ q ^ 2) (y ^ q ^ 2) := by
+      have h2 := hns₂
+      rwa [← pow_mul, ← pow_mul, ← pow_two] at h2
+    have hF2 : Fr (Fr (Affine.Point.some x y h)) =
+        Affine.Point.some (x ^ q ^ 2) (y ^ q ^ 2) hns'' := by
+      rw [hFP, hFP₂]
+      exact some_congr_charEq (by rw [← pow_mul, ← pow_two]) (by rw [← pow_mul, ← pow_two]) _ _
+    rcases hroots with hroot | hroot
+    · have hXeq : (Affine.Point.some (x ^ q ^ 2) (y ^ q ^ 2) hns'' : V.toAffine.Point)
+            = Affine.Point.some xS yS hSns + Affine.Point.some xT yT hTns
+          ∨ (Affine.Point.some (x ^ q ^ 2) (y ^ q ^ 2) hns'' : V.toAffine.Point)
+            = -(Affine.Point.some xS yS hSns + Affine.Point.some xT yT hTns) := by
+        rw [Affine.Point.add_of_X_ne hxx]
+        exact (Affine.Point.X_eq_iff (h₁ := hns'')).mp hroot.symm
+      rcases hXeq with hpe | hpe
+      · have hrel : Fr (Fr (Affine.Point.some x y h))
+            = a.natAbs • Fr (Affine.Point.some x y h)
+              + q • (Affine.Point.some x y h : V.toAffine.Point) := by
+          rw [hF2, hFP, hSpt, hTpt]
+          exact hpe
+        rcases Int.natAbs_eq a with hsign | hsign
+        · refine Or.inr (Or.inr (Or.inl ?_))
+          rw [hsign, natCast_zsmul, natCast_zsmul, hrel]
+          abel
+        · refine Or.inr (Or.inl ?_)
+          rw [hsign, neg_zsmul, natCast_zsmul, natCast_zsmul, hrel]
+          abel
+      · have hrel : Fr (Fr (Affine.Point.some x y h))
+            = -(a.natAbs • Fr (Affine.Point.some x y h)
+              + q • (Affine.Point.some x y h : V.toAffine.Point)) := by
+          rw [hF2, hFP, hSpt, hTpt]
+          exact hpe
+        rcases Int.natAbs_eq a with hsign | hsign
+        · refine Or.inr (Or.inr (Or.inr (Or.inl ?_)))
+          rw [hsign, natCast_zsmul, natCast_zsmul, hrel]
+          abel
+        · refine Or.inl ?_
+          rw [hsign, neg_zsmul, natCast_zsmul, natCast_zsmul, hrel]
+          abel
+    · have hXeq : (Affine.Point.some (x ^ q ^ 2) (y ^ q ^ 2) hns'' : V.toAffine.Point)
+            = Affine.Point.some xS yS hSns + -(Affine.Point.some xT yT hTns)
+          ∨ (Affine.Point.some (x ^ q ^ 2) (y ^ q ^ 2) hns'' : V.toAffine.Point)
+            = -(Affine.Point.some xS yS hSns + -(Affine.Point.some xT yT hTns)) := by
+        rw [Affine.Point.neg_some, Affine.Point.add_of_X_ne hxx]
+        exact (Affine.Point.X_eq_iff (h₁ := hns'')).mp hroot.symm
+      rcases hXeq with hpe | hpe
+      · have hrel : Fr (Fr (Affine.Point.some x y h))
+            = a.natAbs • Fr (Affine.Point.some x y h)
+              + -(q • (Affine.Point.some x y h : V.toAffine.Point)) := by
+          rw [hF2, hFP, hSpt, hTpt]
+          exact hpe
+        rcases Int.natAbs_eq a with hsign | hsign
+        · refine Or.inl ?_
+          rw [hsign, natCast_zsmul, natCast_zsmul, hrel]
+          abel
+        · refine Or.inr (Or.inr (Or.inr (Or.inl ?_)))
+          rw [hsign, neg_zsmul, natCast_zsmul, natCast_zsmul, hrel]
+          abel
+      · have hrel : Fr (Fr (Affine.Point.some x y h))
+            = -(a.natAbs • Fr (Affine.Point.some x y h)
+              + -(q • (Affine.Point.some x y h : V.toAffine.Point))) := by
+          rw [hF2, hFP, hSpt, hTpt]
+          exact hpe
+        rcases Int.natAbs_eq a with hsign | hsign
+        · refine Or.inr (Or.inl ?_)
+          rw [hsign, natCast_zsmul, natCast_zsmul, hrel]
+          abel
+        · refine Or.inr (Or.inr (Or.inl ?_))
+          rw [hsign, neg_zsmul, natCast_zsmul, natCast_zsmul, hrel]
+          abel
+
+section SubLemmas
+
+variable {a : ℤ}
+
+private lemma charEq_sub_one {X Y : V.toAffine.Point}
+    (hX : Fr (Fr X) - a • Fr X + (q : ℤ) • X = 0)
+    (hY : Fr (Fr Y) - a • Fr Y + (q : ℤ) • Y = 0) :
+    Fr (Fr (X - Y)) - a • Fr (X - Y) + (q : ℤ) • (X - Y) = 0 := by
+  rw [map_sub, map_sub, zsmul_sub, zsmul_sub]
+  calc Fr (Fr X) - Fr (Fr Y) - (a • Fr X - a • Fr Y) + ((q : ℤ) • X - (q : ℤ) • Y)
+      = (Fr (Fr X) - a • Fr X + (q : ℤ) • X) - (Fr (Fr Y) - a • Fr Y + (q : ℤ) • Y) := by abel
+    _ = 0 - 0 := by rw [hX, hY]
+    _ = 0 := by rw [sub_zero]
+
+private lemma charEq_sub_two {X Y : V.toAffine.Point}
+    (hX : Fr (Fr X) + a • Fr X - (q : ℤ) • X = 0)
+    (hY : Fr (Fr Y) + a • Fr Y - (q : ℤ) • Y = 0) :
+    Fr (Fr (X - Y)) + a • Fr (X - Y) - (q : ℤ) • (X - Y) = 0 := by
+  rw [map_sub, map_sub, zsmul_sub, zsmul_sub]
+  calc Fr (Fr X) - Fr (Fr Y) + (a • Fr X - a • Fr Y) - ((q : ℤ) • X - (q : ℤ) • Y)
+      = (Fr (Fr X) + a • Fr X - (q : ℤ) • X) - (Fr (Fr Y) + a • Fr Y - (q : ℤ) • Y) := by abel
+    _ = 0 - 0 := by rw [hX, hY]
+    _ = 0 := by rw [sub_zero]
+
+private lemma charEq_sub_three {X Y : V.toAffine.Point}
+    (hX : Fr (Fr X) - a • Fr X - (q : ℤ) • X = 0)
+    (hY : Fr (Fr Y) - a • Fr Y - (q : ℤ) • Y = 0) :
+    Fr (Fr (X - Y)) - a • Fr (X - Y) - (q : ℤ) • (X - Y) = 0 := by
+  rw [map_sub, map_sub, zsmul_sub, zsmul_sub]
+  calc Fr (Fr X) - Fr (Fr Y) - (a • Fr X - a • Fr Y) - ((q : ℤ) • X - (q : ℤ) • Y)
+      = (Fr (Fr X) - a • Fr X - (q : ℤ) • X) - (Fr (Fr Y) - a • Fr Y - (q : ℤ) • Y) := by abel
+    _ = 0 - 0 := by rw [hX, hY]
+    _ = 0 := by rw [sub_zero]
+
+private lemma charEq_sub_four {X Y : V.toAffine.Point}
+    (hX : Fr (Fr X) + a • Fr X + (q : ℤ) • X = 0)
+    (hY : Fr (Fr Y) + a • Fr Y + (q : ℤ) • Y = 0) :
+    Fr (Fr (X - Y)) + a • Fr (X - Y) + (q : ℤ) • (X - Y) = 0 := by
+  rw [map_sub, map_sub, zsmul_sub, zsmul_sub]
+  calc Fr (Fr X) - Fr (Fr Y) + (a • Fr X - a • Fr Y) + ((q : ℤ) • X - (q : ℤ) • Y)
+      = (Fr (Fr X) + a • Fr X + (q : ℤ) • X) - (Fr (Fr Y) + a • Fr Y + (q : ℤ) • Y) := by abel
+    _ = 0 - 0 := by rw [hX, hY]
+    _ = 0 := by rw [sub_zero]
+
+private lemma charEq_sub_five {X Y : V.toAffine.Point}
+    (hX : a • Fr X - (q : ℤ) • X = 0)
+    (hY : a • Fr Y - (q : ℤ) • Y = 0) :
+    a • Fr (X - Y) - (q : ℤ) • (X - Y) = 0 := by
+  rw [map_sub, zsmul_sub, zsmul_sub]
+  calc a • Fr X - a • Fr Y - ((q : ℤ) • X - (q : ℤ) • Y)
+      = (a • Fr X - (q : ℤ) • X) - (a • Fr Y - (q : ℤ) • Y) := by abel
+    _ = 0 - 0 := by rw [hX, hY]
+    _ = 0 := by rw [sub_zero]
+
+private lemma charEq_sub_six {X Y : V.toAffine.Point}
+    (hX : a • Fr X + (q : ℤ) • X = 0)
+    (hY : a • Fr Y + (q : ℤ) • Y = 0) :
+    a • Fr (X - Y) + (q : ℤ) • (X - Y) = 0 := by
+  rw [map_sub, zsmul_sub, zsmul_sub]
+  calc a • Fr X - a • Fr Y + ((q : ℤ) • X - (q : ℤ) • Y)
+      = (a • Fr X + (q : ℤ) • X) - (a • Fr Y + (q : ℤ) • Y) := by abel
+    _ = 0 - 0 := by rw [hX, hY]
+    _ = 0 := by rw [sub_zero]
+
+end SubLemmas
+
+section Elim
+
+variable {a : ℤ} {r : ℕ}
+
+include hinj in
+private lemma charEq_elim_two (hr : r.Prime) (h2r : 2 < r)
+    {D : V.toAffine.Point} (hDr : (r : ℤ) • D = 0)
+    (h₁ : Fr (Fr D) - a • Fr D + (q : ℤ) • D = 0)
+    (h₂ : Fr (Fr D) + a • Fr D - (q : ℤ) • D = 0) :
+    D = 0 := by
+  have hsum : Fr (Fr D) + Fr (Fr D) = 0 := by
+    calc Fr (Fr D) + Fr (Fr D)
+        = (Fr (Fr D) - a • Fr D + (q : ℤ) • D) + (Fr (Fr D) + a • Fr D - (q : ℤ) • D) := by abel
+      _ = 0 + 0 := by rw [h₁, h₂]
+      _ = 0 := by rw [add_zero]
+  have h2D : (2 : ℕ) • D = 0 := by
+    have hFF : Fr (Fr ((2 : ℕ) • D)) = 0 := by
+      rw [map_nsmul, map_nsmul, two_nsmul]
+      exact hsum
+    exact frob_eq_zero_of Fr hinj (frob_eq_zero_of Fr hinj hFF)
+  have hDr' : r • D = 0 := by rwa [natCast_zsmul] at hDr
+  exact eq_zero_of_nsmul_eq_zero_of_lt_prime hr (by norm_num) h2r hDr' h2D
+
+private lemma charEq_elim_three (hq1 : 1 ≤ q) (hr : r.Prime) (h2q : 2 * q < r)
+    {D : V.toAffine.Point} (hDr : (r : ℤ) • D = 0)
+    (h₁ : Fr (Fr D) - a • Fr D + (q : ℤ) • D = 0)
+    (h₃ : Fr (Fr D) - a • Fr D - (q : ℤ) • D = 0) :
+    D = 0 := by
+  have hsum : (q : ℤ) • D + (q : ℤ) • D = 0 := by
+    calc (q : ℤ) • D + (q : ℤ) • D
+        = (Fr (Fr D) - a • Fr D + (q : ℤ) • D) - (Fr (Fr D) - a • Fr D - (q : ℤ) • D) := by abel
+      _ = 0 - 0 := by rw [h₁, h₃]
+      _ = 0 := by rw [sub_zero]
+  have h2qD : (2 * q) • D = 0 := by
+    have hsum' : q • D + q • D = 0 := by
+      rwa [natCast_zsmul] at hsum
+    rw [two_mul, add_nsmul]
+    exact hsum'
+  have hDr' : r • D = 0 := by rwa [natCast_zsmul] at hDr
+  exact eq_zero_of_nsmul_eq_zero_of_lt_prime hr (by omega) h2q hDr' h2qD
+
+include hinj in
+private lemma charEq_elim_four (ha : a ≠ 0) (hr : r.Prime) (h2a : 2 * a.natAbs < r)
+    {D : V.toAffine.Point} (hDr : (r : ℤ) • D = 0)
+    (h₁ : Fr (Fr D) - a • Fr D + (q : ℤ) • D = 0)
+    (h₄ : Fr (Fr D) + a • Fr D + (q : ℤ) • D = 0) :
+    D = 0 := by
+  have hsum : a • Fr D + a • Fr D = 0 := by
+    calc a • Fr D + a • Fr D
+        = (Fr (Fr D) + a • Fr D + (q : ℤ) • D) - (Fr (Fr D) - a • Fr D + (q : ℤ) • D) := by abel
+      _ = 0 - 0 := by rw [h₁, h₄]
+      _ = 0 := by rw [sub_zero]
+  have hcol : Fr ((a + a) • D) = 0 := by
+    rw [map_zsmul, add_zsmul]
+    exact hsum
+  have haaD : (a + a) • D = 0 := frob_eq_zero_of Fr hinj hcol
+  have haaD' : (a + a).natAbs • D = 0 := natAbs_nsmul_eq_zero.mpr haaD
+  have hpos : 0 < (a + a).natAbs := Int.natAbs_pos.mpr (by omega)
+  have hlt : (a + a).natAbs < r := by
+    have hle : (a + a).natAbs ≤ 2 * a.natAbs := by
+      calc (a + a).natAbs ≤ a.natAbs + a.natAbs := Int.natAbs_add_le a a
+        _ = 2 * a.natAbs := by ring
+    omega
+  have hDr' : r • D = 0 := by rwa [natCast_zsmul] at hDr
+  exact eq_zero_of_nsmul_eq_zero_of_lt_prime hr hpos hlt hDr' haaD'
+
+include hinj in
+private lemma charEq_elim_five
+    {D : V.toAffine.Point}
+    (h₁ : Fr (Fr D) - a • Fr D + (q : ℤ) • D = 0)
+    (h₅ : a • Fr D - (q : ℤ) • D = 0) :
+    D = 0 := by
+  have hF2 : Fr (Fr D) - (a • Fr D - (q : ℤ) • D) = 0 := by
+    calc Fr (Fr D) - (a • Fr D - (q : ℤ) • D)
+        = Fr (Fr D) - a • Fr D + (q : ℤ) • D := by abel
+      _ = 0 := h₁
+  rw [h₅, sub_zero] at hF2
+  exact frob_eq_zero_of Fr hinj (frob_eq_zero_of Fr hinj hF2)
+
+include hinj in
+private lemma charEq_elim_six (ha : a ≠ 0) (hr : r.Prime)
+    (h6lt : 2 * (a.natAbs * a.natAbs) + q < r)
+    {D : V.toAffine.Point} (hDr : (r : ℤ) • D = 0)
+    (h₁ : Fr (Fr D) - a • Fr D + (q : ℤ) • D = 0)
+    (h₆ : a • Fr D + (q : ℤ) • D = 0) :
+    D = 0 := by
+  have hF2 : Fr (Fr D) - (a + a) • Fr D = 0 := by
+    calc Fr (Fr D) - (a + a) • Fr D
+        = (Fr (Fr D) - a • Fr D + (q : ℤ) • D) - (a • Fr D + (q : ℤ) • D) := by
+          rw [add_zsmul]; abel
+      _ = 0 - 0 := by rw [h₁, h₆]
+      _ = 0 := by rw [sub_zero]
+  have hFD : Fr D = (a + a) • D := by
+    apply hinj
+    rw [map_zsmul]
+    exact sub_eq_zero.mp hF2
+  have h6' : a • ((a + a) • D) + (q : ℤ) • D = 0 := by
+    rw [← hFD]
+    exact h₆
+  have hfin : (a * (a + a) + (q : ℤ)) • D = 0 := by
+    calc (a * (a + a) + (q : ℤ)) • D
+        = (a * (a + a)) • D + (q : ℤ) • D := by rw [add_zsmul]
+      _ = a • ((a + a) • D) + (q : ℤ) • D := by rw [smul_smul]
+      _ = 0 := h6'
+  have hsq : 0 < a * a := mul_self_pos.mpr ha
+  have hexpand : a * (a + a) = a * a + a * a := by ring
+  have hposZ : (0 : ℤ) < a * (a + a) + (q : ℤ) := by
+    have hqz : (0 : ℤ) ≤ (q : ℤ) := Int.natCast_nonneg _
+    linarith [hsq, hexpand, hqz]
+  have hltZ : a * (a + a) + (q : ℤ) < (r : ℤ) := by
+    have hcast : ((2 * (a.natAbs * a.natAbs) + q : ℕ) : ℤ) < (r : ℤ) := by
+      exact_mod_cast h6lt
+    push_cast at hcast
+    rw [abs_mul_abs_self] at hcast
+    linarith [hcast, hexpand]
+  have hfinN : (a * (a + a) + (q : ℤ)).natAbs • D = 0 :=
+    natAbs_nsmul_eq_zero.mpr hfin
+  have hposN : 0 < (a * (a + a) + (q : ℤ)).natAbs :=
+    Int.natAbs_pos.mpr (ne_of_gt hposZ)
+  have hltN : (a * (a + a) + (q : ℤ)).natAbs < r := by
+    have hcast : (((a * (a + a) + (q : ℤ)).natAbs : ℤ)) < (r : ℤ) := by
+      rw [Int.natAbs_of_nonneg (le_of_lt hposZ)]
+      exact hltZ
+    exact_mod_cast hcast
+  have hDr' : r • D = 0 := by rwa [natCast_zsmul] at hDr
+  exact eq_zero_of_nsmul_eq_zero_of_lt_prime hr hposN hltN hDr' hfinN
+
+end Elim
+
+include hFr hinj in
+theorem frobPointCharEq_of_charEq_on_torsionBy (hq1 : 1 ≤ q)
+    {a : ℤ} (ha : a ≠ 0) {r : ℕ} (hr : r.Prime)
+    (hrB : charEqPrimeBound a q < r)
+    (hcard : Nat.card (Submodule.torsionBy ℤ V.toAffine.Point r) = r ^ 2)
+    (hkill : ∀ P : V.toAffine.Point, (r : ℤ) • P = 0 →
+      Fr (Fr P) - a • Fr P + (q : ℤ) • P = 0) (P : V.toAffine.Point) :
+    Fr (Fr P) - a • Fr P + (q : ℤ) • P = 0 := by
+  classical
+  have hpoly : charEqPoly V a q = 0 :=
+    charEqPoly_eq_zero_of_forall_torsionBy Fr hFr hinj hq1 ha hr hrB hcard hkill
+  have ha1 : 1 ≤ a.natAbs := Int.natAbs_pos.mpr ha
+  have hPBmul : charEqPrimeBound a q
+      = 16 * (a.natAbs * a.natAbs * q + q * q) + a.natAbs + q + 2 := by
+    change 2 * (8 * (a.natAbs ^ 2 * q + q ^ 2)) + a.natAbs + q + 2 = _
+    rw [pow_two, pow_two]
+    ring
+  have hf2 : q ≤ q * q := le_mul_of_one_le_right (Nat.zero_le _) hq1
+  have hf3 : a.natAbs ≤ a.natAbs * a.natAbs := le_mul_of_one_le_right (Nat.zero_le _) ha1
+  have hf4 : a.natAbs * a.natAbs ≤ a.natAbs * a.natAbs * q :=
+    le_mul_of_one_le_right (Nat.zero_le _) hq1
+  have hf0 : (0 : ℕ) ≤ a.natAbs * a.natAbs * q := Nat.zero_le _
+  have hf0' : (0 : ℕ) ≤ q * q := Nat.zero_le _
+  have h2_lt : 2 < r := by
+    have h := hrB
+    rw [hPBmul] at h
+    have h1 : 1 ≤ q * q := le_trans hq1 hf2
+    linarith [hf0]
+  have h2q_lt : 2 * q < r := by
+    have h := hrB
+    rw [hPBmul] at h
+    linarith [hf0, hf2]
+  have h2a_lt : 2 * a.natAbs < r := by
+    have h := hrB
+    rw [hPBmul] at h
+    linarith [hf0', hf3, hf4]
+  have h6_lt : 2 * (a.natAbs * a.natAbs) + q < r := by
+    have h := hrB
+    rw [hPBmul] at h
+    linarith [hf0', hf4]
+  have hM5_lt : q + a.natAbs + 5 < r := by
+    have h := hrB
+    rw [hPBmul] at h
+    have h1 : 1 ≤ q * q := le_trans hq1 hf2
+    linarith [hf0]
+  have hfin : Finite (Submodule.torsionBy ℤ V.toAffine.Point r) := by
+    apply Nat.finite_of_card_ne_zero
+    rw [hcard]
+    exact pow_ne_zero 2 hr.pos.ne'
+  have : Fintype (Submodule.torsionBy ℤ V.toAffine.Point r) := Fintype.ofFinite _
+  have hcardT : Fintype.card (Submodule.torsionBy ℤ V.toAffine.Point r) = r ^ 2 := by
+    rw [← Nat.card_eq_fintype_card]
+    exact hcard
+  set Sdeg : Finset (Submodule.torsionBy ℤ V.toAffine.Point r) :=
+    Finset.univ.filter (fun T => ∃ j : ℕ, 1 ≤ j ∧ j ≤ q + a.natAbs ∧
+      j • (P + (T : V.toAffine.Point)) = 0) with hSdeg_def
+  set S2 : Finset (Submodule.torsionBy ℤ V.toAffine.Point r) :=
+    Finset.univ.filter (fun T =>
+      Fr (Fr (P + (T : V.toAffine.Point))) + a • Fr (P + (T : V.toAffine.Point))
+        - (q : ℤ) • (P + (T : V.toAffine.Point)) = 0) with hS2_def
+  set S3 : Finset (Submodule.torsionBy ℤ V.toAffine.Point r) :=
+    Finset.univ.filter (fun T =>
+      Fr (Fr (P + (T : V.toAffine.Point))) - a • Fr (P + (T : V.toAffine.Point))
+        - (q : ℤ) • (P + (T : V.toAffine.Point)) = 0) with hS3_def
+  set S4 : Finset (Submodule.torsionBy ℤ V.toAffine.Point r) :=
+    Finset.univ.filter (fun T =>
+      Fr (Fr (P + (T : V.toAffine.Point))) + a • Fr (P + (T : V.toAffine.Point))
+        + (q : ℤ) • (P + (T : V.toAffine.Point)) = 0) with hS4_def
+  set S5 : Finset (Submodule.torsionBy ℤ V.toAffine.Point r) :=
+    Finset.univ.filter (fun T =>
+      a • Fr (P + (T : V.toAffine.Point)) - (q : ℤ) • (P + (T : V.toAffine.Point)) = 0)
+    with hS5_def
+  set S6 : Finset (Submodule.torsionBy ℤ V.toAffine.Point r) :=
+    Finset.univ.filter (fun T =>
+      a • Fr (P + (T : V.toAffine.Point)) + (q : ℤ) • (P + (T : V.toAffine.Point)) = 0)
+    with hS6_def
+  have htorsub : ∀ T₁ T₂ : Submodule.torsionBy ℤ V.toAffine.Point r,
+      (r : ℤ) • ((T₁ : V.toAffine.Point) - (T₂ : V.toAffine.Point)) = 0 := by
+    intro T₁ T₂
+    rw [zsmul_sub, (Submodule.mem_torsionBy_iff _ _).mp T₁.2,
+      (Submodule.mem_torsionBy_iff _ _).mp T₂.2, sub_zero]
+  have htransub : ∀ T₁ T₂ : Submodule.torsionBy ℤ V.toAffine.Point r,
+      (P + (T₁ : V.toAffine.Point)) - (P + (T₂ : V.toAffine.Point))
+        = (T₁ : V.toAffine.Point) - (T₂ : V.toAffine.Point) := by
+    intro T₁ T₂
+    abel
+  have hSdeg_card : Sdeg.card ≤ q + a.natAbs := by
+    have hsubset : Sdeg ⊆ (Finset.Icc 1 (q + a.natAbs)).biUnion (fun j =>
+        Finset.univ.filter
+          (fun T : Submodule.torsionBy ℤ V.toAffine.Point r =>
+            j • (P + (T : V.toAffine.Point)) = 0)) := by
+      intro T hT
+      rw [hSdeg_def, Finset.mem_filter] at hT
+      obtain ⟨_, j, hj1, hjM, hj0⟩ := hT
+      exact Finset.mem_biUnion.mpr ⟨j, Finset.mem_Icc.mpr ⟨hj1, hjM⟩,
+        Finset.mem_filter.mpr ⟨Finset.mem_univ _, hj0⟩⟩
+    calc Sdeg.card
+        ≤ ((Finset.Icc 1 (q + a.natAbs)).biUnion (fun j =>
+            Finset.univ.filter
+              (fun T : Submodule.torsionBy ℤ V.toAffine.Point r =>
+                j • (P + (T : V.toAffine.Point)) = 0))).card :=
+          Finset.card_le_card hsubset
+      _ ≤ ∑ j ∈ Finset.Icc 1 (q + a.natAbs),
+            (Finset.univ.filter
+              (fun T : Submodule.torsionBy ℤ V.toAffine.Point r =>
+                j • (P + (T : V.toAffine.Point)) = 0)).card :=
+          Finset.card_biUnion_le
+      _ ≤ ∑ _j ∈ Finset.Icc 1 (q + a.natAbs), 1 := by
+          apply Finset.sum_le_sum
+          intro j hj
+          rw [Finset.card_le_one]
+          intro T₁ hT₁ T₂ hT₂
+          rw [Finset.mem_filter] at hT₁ hT₂
+          have hd : j • ((T₁ : V.toAffine.Point) - (T₂ : V.toAffine.Point)) = 0 := by
+            have hsub : j • ((P + (T₁ : V.toAffine.Point))
+                - (P + (T₂ : V.toAffine.Point))) = 0 := by
+              rw [nsmul_sub, hT₁.2, hT₂.2, sub_zero]
+            rwa [htransub] at hsub
+          have hd_r : r • ((T₁ : V.toAffine.Point) - (T₂ : V.toAffine.Point)) = 0 := by
+            have h0 := htorsub T₁ T₂
+            rwa [natCast_zsmul] at h0
+          have hj1 : 1 ≤ j := (Finset.mem_Icc.mp hj).1
+          have hjM : j ≤ q + a.natAbs := (Finset.mem_Icc.mp hj).2
+          have hzero : (T₁ : V.toAffine.Point) - (T₂ : V.toAffine.Point) = 0 :=
+            eq_zero_of_nsmul_eq_zero_of_lt_prime hr (by omega) (by omega) hd_r hd
+          exact Subtype.ext (sub_eq_zero.mp hzero)
+      _ = q + a.natAbs := by
+          rw [Finset.sum_const, smul_eq_mul, mul_one, Nat.card_Icc]
+          omega
+  have hS2_card : S2.card ≤ 1 := by
+    rw [hS2_def, Finset.card_le_one]
+    intro T₁ hT₁ T₂ hT₂
+    rw [Finset.mem_filter] at hT₁ hT₂
+    have hd := charEq_sub_two Fr hT₁.2 hT₂.2
+    rw [htransub] at hd
+    have hd1 := hkill _ (htorsub T₁ T₂)
+    exact Subtype.ext (sub_eq_zero.mp
+      (charEq_elim_two Fr hinj hr h2_lt (htorsub T₁ T₂) hd1 hd))
+  have hS3_card : S3.card ≤ 1 := by
+    rw [hS3_def, Finset.card_le_one]
+    intro T₁ hT₁ T₂ hT₂
+    rw [Finset.mem_filter] at hT₁ hT₂
+    have hd := charEq_sub_three Fr hT₁.2 hT₂.2
+    rw [htransub] at hd
+    have hd1 := hkill _ (htorsub T₁ T₂)
+    exact Subtype.ext (sub_eq_zero.mp
+      (charEq_elim_three Fr hq1 hr h2q_lt (htorsub T₁ T₂) hd1 hd))
+  have hS4_card : S4.card ≤ 1 := by
+    rw [hS4_def, Finset.card_le_one]
+    intro T₁ hT₁ T₂ hT₂
+    rw [Finset.mem_filter] at hT₁ hT₂
+    have hd := charEq_sub_four Fr hT₁.2 hT₂.2
+    rw [htransub] at hd
+    have hd1 := hkill _ (htorsub T₁ T₂)
+    exact Subtype.ext (sub_eq_zero.mp
+      (charEq_elim_four Fr hinj ha hr h2a_lt (htorsub T₁ T₂) hd1 hd))
+  have hS5_card : S5.card ≤ 1 := by
+    rw [hS5_def, Finset.card_le_one]
+    intro T₁ hT₁ T₂ hT₂
+    rw [Finset.mem_filter] at hT₁ hT₂
+    have hd := charEq_sub_five Fr hT₁.2 hT₂.2
+    rw [htransub] at hd
+    have hd1 := hkill _ (htorsub T₁ T₂)
+    exact Subtype.ext (sub_eq_zero.mp (charEq_elim_five Fr hinj hd1 hd))
+  have hS6_card : S6.card ≤ 1 := by
+    rw [hS6_def, Finset.card_le_one]
+    intro T₁ hT₁ T₂ hT₂
+    rw [Finset.mem_filter] at hT₁ hT₂
+    have hd := charEq_sub_six Fr hT₁.2 hT₂.2
+    rw [htransub] at hd
+    have hd1 := hkill _ (htorsub T₁ T₂)
+    exact Subtype.ext (sub_eq_zero.mp
+      (charEq_elim_six Fr hinj ha hr h6_lt (htorsub T₁ T₂) hd1 hd))
+  have hbad_card : (Sdeg ∪ S2 ∪ S3 ∪ S4 ∪ S5 ∪ S6).card ≤ q + a.natAbs + 5 := by
+    have h6 := Finset.card_union_le (Sdeg ∪ S2 ∪ S3 ∪ S4 ∪ S5) S6
+    have h5 := Finset.card_union_le (Sdeg ∪ S2 ∪ S3 ∪ S4) S5
+    have h4 := Finset.card_union_le (Sdeg ∪ S2 ∪ S3) S4
+    have h3 := Finset.card_union_le (Sdeg ∪ S2) S3
+    have h2 := Finset.card_union_le Sdeg S2
+    omega
+  have hexistsT : ∃ T : Submodule.torsionBy ℤ V.toAffine.Point r,
+      T ∉ Sdeg ∪ S2 ∪ S3 ∪ S4 ∪ S5 ∪ S6 := by
+    by_contra hcon
+    have hall : Finset.univ ⊆ Sdeg ∪ S2 ∪ S3 ∪ S4 ∪ S5 ∪ S6 := by
+      intro T _
+      by_contra hnot
+      exact hcon ⟨T, hnot⟩
+    have hcard' := Finset.card_le_card hall
+    rw [Finset.card_univ, hcardT] at hcard'
+    have hr2 : r ≤ r ^ 2 := by
+      rw [pow_two]
+      exact le_mul_of_one_le_right (Nat.zero_le _) hr.one_lt.le
+    omega
+  obtain ⟨T, hT⟩ := hexistsT
+  simp only [Finset.mem_union, not_or] at hT
+  obtain ⟨⟨⟨⟨⟨hTdeg, hT2⟩, hT3⟩, hT4⟩, hT5⟩, hT6⟩ := hT
+  have hgood : ∀ j : ℕ, 1 ≤ j → j ≤ q + a.natAbs →
+      j • (P + (T : V.toAffine.Point)) ≠ 0 := by
+    intro j hj1 hjM hcontra
+    exact hTdeg (by
+      rw [hSdeg_def]
+      exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, ⟨j, hj1, hjM, hcontra⟩⟩)
+  rcases charEq_cases_of_charEqPoly_eq_zero Fr hFr hinj hq1 ha hpoly hgood
+    with h1 | h2 | h3 | h4 | h5 | h6
+  · have hTr : (r : ℤ) • (T : V.toAffine.Point) = 0 :=
+      (Submodule.mem_torsionBy_iff _ _).mp T.2
+    have hT1 := hkill _ hTr
+    have hP1 := charEq_sub_one Fr h1 hT1
+    rwa [add_sub_cancel_right] at hP1
+  · exact absurd (by
+      rw [hS2_def]
+      exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, h2⟩) hT2
+  · exact absurd (by
+      rw [hS3_def]
+      exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, h3⟩) hT3
+  · exact absurd (by
+      rw [hS4_def]
+      exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, h4⟩) hT4
+  · exact absurd (by
+      rw [hS5_def]
+      exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, h5⟩) hT5
+  · exact absurd (by
+      rw [hS6_def]
+      exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, h6⟩) hT6
+
+end Endgame
+end WeierstrassCurve
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_ne_zero.WeierstrassCurve \
+  WeierstrassCurve.Affine \
+  P2MW.S_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_ne_zero.WeierstrassCurve.Af\
+  fine WeierstrassCurve.Affine.Point \
+  P2MW.S_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_ne_zero.WeierstrassCurve.Af\
+  fine.Point FrobeniusEndo"
+
+theorem solution {R : Type*} [CommRing R] {F : Type*} [Field F] [Fintype F] {k : Type*} [Field k]
+  [DecidableEq k] [Algebra R F] [Algebra R k] [Algebra F k] [IsScalarTower R F k] (W :
+  WeierstrassCurve R) (σ : k ≃ₐ[F] k) (hσ : ∀ x : k, σ x = x ^ Fintype.card F) {a : ℤ} (ha : a ≠ 0)
+  (hkill : ∀ N : ℕ, ∃ r : ℕ, N < r ∧ r.Prime ∧ Nat.card (Submodule.torsionBy ℤ (W⁄k).Point r) = r ^
+  2 ∧ ∀ P : (W⁄k).Point, (r : ℤ) • P = 0 → σ • (σ • P) - a • (σ • P) + (Fintype.card F : ℤ) • P = 0)
+  :
+    FrobCharEqOnPoints W σ a (Fintype.card F) := by
+  have hinj : Function.Injective (frobEnd W σ) := Affine.Point.map_injective σ.toAlgHom
+  have hFr : ∀ {x y : k} (h : (W⁄k).Nonsingular x y),
+      ∃ h' : (W⁄k).Nonsingular (x ^ Fintype.card F) (y ^ Fintype.card F),
+        frobEnd W σ (Point.some x y h) = Point.some (x ^ Fintype.card F) (y ^ Fintype.card F) h' :=
+          by
+    intro x y h
+    obtain ⟨h', e⟩ : ∃ h', σ • (Point.some x y h : (W⁄k).Point) = Point.some (σ x) (σ y) h' :=
+      ⟨_, rfl⟩
+    have h'' : (W⁄k).Nonsingular (x ^ Fintype.card F) (y ^ Fintype.card F) := by
+      rw [← hσ x, ← hσ y]
+      exact h'
+    refine ⟨h'', ?_⟩
+    rw [frobEnd_apply, e]
+    exact some_congr_charEq (hσ x) (hσ y) _ _
+  have hq1 : 1 ≤ Fintype.card F := Fintype.card_pos
+  obtain ⟨r, hrB, hr, hcard, hkillr⟩ := hkill (charEqPrimeBound a (Fintype.card F))
+  intro P
+  exact frobPointCharEq_of_charEq_on_torsionBy (V := W⁄k) (frobEnd W σ) hFr hinj hq1 ha hr hrB
+    hcard hkillr P
+
+end S_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_ne_zero
+end P2MW
+export P2MW.S_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_ne_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo
+
+theorem FrobeniusEndo.frobCharEqOnPoints_of_charEq_on_torsion_of_trace_ne_zero {R : Type*} [CommRing
+  R] {F : Type*} [Field F] [Fintype F] {k : Type*} [Field k] [DecidableEq k] [Algebra R F] [Algebra
+  R k] [Algebra F k] [IsScalarTower R F k] (W : WeierstrassCurve R) (σ : k ≃ₐ[F] k) (hσ : ∀ x : k, σ
+  x = x ^ Fintype.card F) {a : ℤ} (ha : a ≠ 0) (hkill : ∀ N : ℕ, ∃ r : ℕ, N < r ∧ r.Prime ∧ Nat.card
+  (Submodule.torsionBy ℤ (W⁄k).Point r) = r ^ 2 ∧ ∀ P : (W⁄k).Point, (r : ℤ) • P = 0 → σ • (σ • P) -
+  a • (σ • P) + (Fintype.card F : ℤ) • P = 0) :
+    FrobCharEqOnPoints W σ a (Fintype.card F) :=
+  solution W σ hσ ha hkill
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_zero.lean
new file mode 100644
index 0000000000..a18bc17fe1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_zero.lean
@@ -0,0 +1,421 @@
+/-
+Based on Prove2Me node FrobeniusEndo.frobCharEqOnPoints_of_charEq_on_torsion_of_trace_zero
+(2dd30633-f8c1-5409-85ad-47dc9b7594f9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5816c352-242f-557c-b60e-39f7d929fdf2
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusEndo
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_zsmul_some_eq_some_div
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_smul_some_eq_zero_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_evalEval_psi_sq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Frobenius characteristic equation on points, trace-zero case
+
+Theorem statement: `FrobeniusEndo.frobCharEqOnPoints_of_charEq_on_torsion_of_trace_zero`
+(`2dd30633-f8c1-5409-85ad-47dc9b7594f9`), by Claude, 2026-09-05.
+
+Proof: submission `5816c352-242f-557c-b60e-39f7d929fdf2`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring, $F$ a finite field, $k$ a field, and suppose $F$ and $k$ are
+$R$-algebras, $k$ an $F$-algebra, the three structures forming a scalar tower; write $q =
+\operatorname{card} F$. Let $W$ be a Weierstrass curve over $R$ and let $\sigma$ be an $F$-algebra
+automorphism of $k$ with $\sigma(x) = x^{q}$ for every $x \in k$, acting on the group
+$(W\!⁄k).\mathrm{Point}$ of points of the base change of $W$ to $k$ through the associated scalar
+action. Assume that for every natural number $N$ there is a prime $r > N$ such that the
+$\mathbb{Z}$-submodule of $r$-torsion points of $(W\!⁄k).\mathrm{Point}$ has exactly $r^{2}$
+elements and such that every $P$ with $r \cdot P = 0$ satisfies $\sigma\cdot(\sigma\cdot P) + q\cdot
+P = 0$. The conclusion is `FrobCharEqOnPoints W σ 0 q`, that is, $\sigma\cdot(\sigma\cdot P) -
+0\cdot(\sigma\cdot P) + q\cdot P = 0$ for every point $P$ of $(W\!⁄k).\mathrm{Point}$.
+
+This is the trace-zero branch of the assertion that the $q$-power Frobenius satisfies its
+characteristic equation $X^{2} - aX + q$ pointwise on the $k$-points of a Weierstrass curve,
+obtained by passing from cofinally many full $r$-torsion subgroups to all points. It is used in the
+proof of
+[`FrobeniusEndo.frobCharEqOnPoints_of_line`](thm.html#FrobeniusEndo.frobCharEqOnPoints_of_line),
+where the torsion hypothesis is supplied by a count of the kernels of $m - \pi$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_zero
+
+p2m_open "WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo \
+  P2MW.S_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_zero.FrobeniusEndo"
+open Polynomial
+
+namespace FrobeniusEndo
+p2m_export "FrobeniusEndo" "FrobCharEqOnPoints"
+namespace TraceZeroPort
+p2m_open "FrobeniusEndo"
+
+universe u v w
+
+variable {R : Type u} [CommRing R] {F : Type v} [Field F] [Fintype F] {k : Type w} [Field k]
+  [DecidableEq k] [Algebra R F] [Algebra R k] [Algebra F k] [IsScalarTower R F k]
+  (W : WeierstrassCurve R) (σ : k ≃ₐ[F] k)
+
+theorem eq_zero_of_zsmul_eq_zero_of_isCoprime {G : Type*} [AddCommGroup G] {a b : ℤ}
+    (hab : IsCoprime a b) {X : G} (ha : a • X = 0) (hb : b • X = 0) : X = 0 := by
+  obtain ⟨u, v, huv⟩ := hab
+  calc X = (u * a + v * b) • X := by rw [huv, one_smul]
+    _ = 0 := by rw [add_smul, mul_smul, mul_smul, ha, hb, smul_zero, smul_zero, add_zero]
+
+omit [DecidableEq k] in
+theorem some_eq_or_eq_neg_of_x_eq {V : WeierstrassCurve k} {x y₁ y₂ : k}
+    (h₁ : V.toAffine.Nonsingular x y₁) (h₂ : V.toAffine.Nonsingular x y₂) :
+    (Point.some x y₁ h₁ : V.toAffine.Point) = Point.some x y₂ h₂ ∨
+      (Point.some x y₁ h₁ : V.toAffine.Point) = -Point.some x y₂ h₂ := by
+  classical
+  by_cases hy : y₁ = V.toAffine.negY x y₂
+  · right
+    rw [Affine.Point.neg_some]
+    subst hy
+    rfl
+  · left
+    have := Affine.Y_eq_of_Y_ne h₁.1 h₂.1 rfl hy
+    subst this
+    rfl
+
+def xOf {V : WeierstrassCurve k} : V.toAffine.Point → k
+  | 0 => 0
+  | (Point.some x _ _) => x
+
+omit [DecidableEq k] in
+@[scoped simp] theorem xOf_some {V : WeierstrassCurve k} {x y : k} (h : V.toAffine.Nonsingular x y)
+  :
+    xOf (Point.some x y h) = x := rfl
+
+omit [Fintype F] in
+theorem smul_some (x y : k) (h : (W⁄k).Nonsingular x y) :
+    ∃ h' : (W⁄k).Nonsingular (σ x) (σ y), σ • (Point.some x y h : (W⁄k).Point) = Point.some (σ x) (σ
+      y) h' :=
+  ⟨_, rfl⟩
+
+theorem smul_smul_some (hσ : ∀ x : k, σ x = x ^ Fintype.card F) (x y : k)
+    (h : (W⁄k).Nonsingular x y) :
+    ∃ h' : (W⁄k).Nonsingular (x ^ (Fintype.card F) ^ 2) (y ^ (Fintype.card F) ^ 2),
+      σ • (σ • (Point.some x y h : (W⁄k).Point)) =
+        Point.some (x ^ (Fintype.card F) ^ 2) (y ^ (Fintype.card F) ^ 2) h' := by
+  obtain ⟨h₁, e₁⟩ := smul_some W σ x y h
+  obtain ⟨h₂, e₂⟩ := smul_some W σ (σ x) (σ y) h₁
+  have hx : σ (σ x) = x ^ (Fintype.card F) ^ 2 := by rw [hσ, hσ, ← pow_mul, ← pow_two]
+  have hy : σ (σ y) = y ^ (Fintype.card F) ^ 2 := by rw [hσ, hσ, ← pow_mul, ← pow_two]
+  refine ⟨hx ▸ hy ▸ h₂, ?_⟩
+  rw [e₁, e₂]
+  congr 1
+
+noncomputable def compPoly : k[X] :=
+  X ^ (Fintype.card F) ^ 2 * (W⁄k).ΨSq (Fintype.card F : ℤ) - (W⁄k).Φ (Fintype.card F : ℤ)
+
+omit [Field F] [Algebra R F] [Algebra F k] [IsScalarTower R F k] in
+theorem exists_zsmul_eq_some (x y : k) (h : (W⁄k).Nonsingular x y)
+    (hq : (Fintype.card F : ℤ) • (Point.some x y h : (W⁄k).Point) ≠ 0) :
+    ((W⁄k).ΨSq (Fintype.card F : ℤ)).eval x ≠ 0 ∧
+    ∃ (y' : k) (h' : (W⁄k).Nonsingular
+        (((W⁄k).Φ (Fintype.card F : ℤ)).eval x / ((W⁄k).ΨSq (Fintype.card F : ℤ)).eval x) y'),
+      (Fintype.card F : ℤ) • (Point.some x y h : (W⁄k).Point) =
+        Point.some (((W⁄k).Φ (Fintype.card F : ℤ)).eval x / ((W⁄k).ΨSq (Fintype.card F : ℤ)).eval x)
+          y' h' := by
+  have hψ : ((W⁄k).ψ (Fintype.card F : ℤ)).evalEval x y ≠ 0 := fun h0 =>
+    hq ((WeierstrassCurve.Affine.Point.smul_some_eq_zero_iff (W⁄k) h (Fintype.card F : ℤ)).mpr h0)
+  refine ⟨?_, WeierstrassCurve.Affine.Point.zsmul_some_eq_some_div (W⁄k) h hψ⟩
+  rw [← WeierstrassCurve.Affine.evalEval_psi_sq (W⁄k) h.1 (Fintype.card F : ℤ)]
+  exact pow_ne_zero 2 hψ
+
+theorem compPoly_eval_eq_zero (hσ : ∀ x : k, σ x = x ^ Fintype.card F)
+    (x y : k) (h : (W⁄k).Nonsingular x y)
+    (hq : (Fintype.card F : ℤ) • (Point.some x y h : (W⁄k).Point) ≠ 0)
+    (hrel : σ • (σ • (Point.some x y h : (W⁄k).Point)) +
+      (Fintype.card F : ℤ) • (Point.some x y h : (W⁄k).Point) = 0) :
+    (compPoly W (F := F) (k := k)).eval x = 0 := by
+  obtain ⟨hΨ, y', h', e⟩ := exists_zsmul_eq_some W x y h hq
+  obtain ⟨h₂, e₂⟩ := smul_smul_some W σ hσ x y h
+  have hneg := eq_neg_of_add_eq_zero_left hrel
+  rw [e₂, e, Affine.Point.neg_some] at hneg
+  have hx : x ^ (Fintype.card F) ^ 2 =
+      ((W⁄k).Φ (Fintype.card F : ℤ)).eval x / ((W⁄k).ΨSq (Fintype.card F : ℤ)).eval x :=
+    (Affine.Point.some.injEq _ _ _ _ _ _ |>.mp hneg).1
+  simp only [compPoly, eval_sub, eval_mul, eval_pow, eval_X, hx, div_mul_cancel₀ _ hΨ, sub_self]
+
+theorem dichotomy_of_compPoly_eq_zero (hσ : ∀ x : k, σ x = x ^ Fintype.card F)
+    (hZ : compPoly W (F := F) (k := k) = 0)
+    (x y : k) (h : (W⁄k).Nonsingular x y)
+    (hq : (Fintype.card F : ℤ) • (Point.some x y h : (W⁄k).Point) ≠ 0) :
+    σ • (σ • (Point.some x y h : (W⁄k).Point)) =
+        -((Fintype.card F : ℤ) • (Point.some x y h : (W⁄k).Point)) ∨
+      σ • (σ • (Point.some x y h : (W⁄k).Point)) =
+        (Fintype.card F : ℤ) • (Point.some x y h : (W⁄k).Point) := by
+  obtain ⟨hΨ, y', h', e⟩ := exists_zsmul_eq_some W x y h hq
+  obtain ⟨h₂, e₂⟩ := smul_smul_some W σ hσ x y h
+  have hroot : (compPoly W (F := F) (k := k)).eval x = 0 := by rw [hZ, eval_zero]
+  have hx : x ^ (Fintype.card F) ^ 2 =
+      ((W⁄k).Φ (Fintype.card F : ℤ)).eval x / ((W⁄k).ΨSq (Fintype.card F : ℤ)).eval x := by
+    rw [eq_div_iff hΨ]
+    simpa only [compPoly, eval_sub, eval_mul, eval_pow, eval_X, sub_eq_zero] using hroot
+  rw [e₂, e]
+  have key := some_eq_or_eq_neg_of_x_eq (V := (W⁄k)) (hx ▸ h₂) h'
+  rcases key with h1 | h1
+  · right
+    rw [← h1]
+    congr 1
+  · left
+    rw [← h1]
+    congr 1
+
+theorem torsion_eq_zero_of_zsmul_eq_zero {r : ℕ} (hr : r.Prime) {n : ℕ} (hn0 : 0 < n) (hnr : n < r)
+    {T : (W⁄k).Point} (hT : (r : ℤ) • T = 0) (hnT : (n : ℤ) • T = 0) : T = 0 :=
+  eq_zero_of_zsmul_eq_zero_of_isCoprime (Nat.isCoprime_iff_coprime.mpr (Nat.coprime_of_lt_prime
+    hn0.ne' hnr hr))
+    hT hnT
+
+omit [DecidableEq k] in
+theorem exists_eq_some_of_ne_zero {V : WeierstrassCurve k} {P : V.toAffine.Point} (hP : P ≠ 0) :
+    ∃ (x y : k) (h : V.toAffine.Nonsingular x y), P = Point.some x y h := by
+  rcases P with _ | ⟨x, y, h⟩
+  · exact absurd rfl hP
+  · exact ⟨x, y, h, rfl⟩
+
+theorem compPoly_eq_zero (hσ : ∀ x : k, σ x = x ^ Fintype.card F) {r : ℕ} (hr : r.Prime)
+    (hqr : Fintype.card F < r)
+    (hdeg : 2 * (compPoly W (F := F) (k := k)).natDegree + 2 < r)
+    (hcard : Nat.card (Submodule.torsionBy ℤ (W⁄k).Point r) = r ^ 2)
+    (hrel : ∀ P : (W⁄k).Point, (r : ℤ) • P = 0 →
+      σ • (σ • P) + (Fintype.card F : ℤ) • P = 0) :
+    compPoly W (F := F) (k := k) = 0 := by
+  classical
+  by_contra hZ
+  set Z := compPoly W (F := F) (k := k) with hZdef
+  set Tor := Submodule.torsionBy ℤ (W⁄k).Point r with hTor
+  have hq0 : 0 < Fintype.card F := Fintype.card_pos
+  have hr0 : r ^ 2 ≠ 0 := pow_ne_zero 2 hr.ne_zero
+  have : Finite Tor := Nat.finite_of_card_ne_zero (by rw [hcard]; exact hr0)
+  let : Fintype Tor := Fintype.ofFinite Tor
+  have hcardF : Fintype.card Tor = r ^ 2 := by rw [← Nat.card_eq_fintype_card, hcard]
+  have hmemT : ∀ T : Tor, (r : ℤ) • (T : (W⁄k).Point) = 0 := fun T =>
+    (Submodule.mem_torsionBy_iff _ _).mp T.2
+  let s : Finset Tor := Finset.univ.erase 0
+  have hs : s.card = r ^ 2 - 1 := by
+    rw [Finset.card_erase_of_mem (Finset.mem_univ _), Finset.card_univ, hcardF]
+  let f : Tor → k := fun T => xOf (T : (W⁄k).Point)
+  have hne : ∀ T ∈ s, (T : (W⁄k).Point) ≠ 0 := by
+    intro T hT h0
+    exact (Finset.mem_erase.mp hT).1 (Subtype.ext h0)
+  have hroot : ∀ T ∈ s, Z.IsRoot (f T) := by
+    intro T hT
+    obtain ⟨x, y, h, e⟩ := exists_eq_some_of_ne_zero (hne T hT)
+    have hq : (Fintype.card F : ℤ) • (Point.some x y h : (W⁄k).Point) ≠ 0 := by
+      intro h0
+      apply hne T hT
+      rw [e]
+      exact torsion_eq_zero_of_zsmul_eq_zero W hr hq0 hqr (e ▸ hmemT T) h0
+    have := compPoly_eval_eq_zero W σ hσ x y h hq (e ▸ hrel _ (hmemT T))
+    change Z.eval (xOf (T : (W⁄k).Point)) = 0
+    rw [e, xOf_some]
+    exact this
+  have himage : s.image f ⊆ Z.roots.toFinset := by
+    intro a ha
+    obtain ⟨T, hT, rfl⟩ := Finset.mem_image.mp ha
+    rw [Multiset.mem_toFinset, Polynomial.mem_roots hZ]
+    exact hroot T hT
+  have hcard_image : (s.image f).card ≤ Z.natDegree :=
+    (Finset.card_le_card himage).trans ((Multiset.toFinset_card_le _).trans (Polynomial.card_roots'
+      Z))
+  have hfib : ∀ a ∈ s.image f, (s.filter (fun T => f T = a)).card ≤ 2 := by
+    intro a ha
+    obtain ⟨T₀, hT₀, rfl⟩ := Finset.mem_image.mp ha
+    obtain ⟨x₀, y₀, h₀, e₀⟩ := exists_eq_some_of_ne_zero (hne T₀ hT₀)
+    have hsub : s.filter (fun T => f T = f T₀) ⊆ {T₀, -T₀} := by
+      intro T hT
+      rw [Finset.mem_filter] at hT
+      obtain ⟨x, y, h, e⟩ := exists_eq_some_of_ne_zero (hne T hT.1)
+      have hx : x = x₀ := by
+        have := hT.2
+        simp only [f, e, e₀, xOf_some] at this
+        exact this
+      subst hx
+      rw [Finset.mem_insert, Finset.mem_singleton]
+      rcases some_eq_or_eq_neg_of_x_eq (V := (W⁄k)) h h₀ with h1 | h1
+      · left; apply Subtype.ext; rw [e, e₀]; exact h1
+      · right; apply Subtype.ext; rw [Submodule.coe_neg, e, e₀]; exact h1
+    exact (Finset.card_le_card hsub).trans Finset.card_le_two
+  have hcount : s.card ≤ 2 * (s.image f).card := Finset.card_le_mul_card_image s 2 hfib
+  have h1 : r ^ 2 - 1 ≤ 2 * Z.natDegree := by
+    rw [← hs]; exact hcount.trans (Nat.mul_le_mul_left 2 hcard_image)
+  have h2 : r ≤ r ^ 2 := Nat.le_self_pow two_ne_zero r
+  omega
+
+theorem charEq_of_compPoly_eq_zero (hσ : ∀ x : k, σ x = x ^ Fintype.card F)
+    (hZ : compPoly W (F := F) (k := k) = 0) {r : ℕ} (hr : r.Prime)
+    (h2qr : 2 * Fintype.card F < r)
+    (hcard : Nat.card (Submodule.torsionBy ℤ (W⁄k).Point r) = r ^ 2)
+    (hrel : ∀ P : (W⁄k).Point, (r : ℤ) • P = 0 →
+      σ • (σ • P) + (Fintype.card F : ℤ) • P = 0)
+    (P : (W⁄k).Point) :
+    σ • (σ • P) + (Fintype.card F : ℤ) • P = 0 := by
+  classical
+  by_contra hP
+  set q : ℕ := Fintype.card F with hq
+  set Tor := Submodule.torsionBy ℤ (W⁄k).Point r with hTor
+  have hq0 : 0 < q := Fintype.card_pos
+  have : Finite Tor := Nat.finite_of_card_ne_zero (by rw [hcard]; exact pow_ne_zero 2 hr.ne_zero)
+  let : Fintype Tor := Fintype.ofFinite Tor
+  have hcardF : Fintype.card Tor = r ^ 2 := by rw [← Nat.card_eq_fintype_card, hcard]
+  have hmemT : ∀ T : Tor, (r : ℤ) • (T : (W⁄k).Point) = 0 := fun T =>
+    (Submodule.mem_torsionBy_iff _ _).mp T.2
+  have hmem_sub : ∀ T T' : Tor, (r : ℤ) • ((T : (W⁄k).Point) - T') = 0 := fun T T' => by
+    rw [smul_sub, hmemT, hmemT, sub_zero]
+  let B₁ : Tor → Prop := fun T => P + T = 0
+  let B₂ : Tor → Prop := fun T => (q : ℤ) • (P + (T : (W⁄k).Point)) = 0
+  let B₃ : Tor → Prop :=
+    fun T => σ • (σ • (P + (T : (W⁄k).Point))) = (q : ℤ) • (P + (T : (W⁄k).Point))
+  have hcover : ∀ T : Tor, B₁ T ∨ B₂ T ∨ B₃ T := by
+    intro T
+    by_contra hnot
+    push Not at hnot
+    obtain ⟨h₁, h₂, h₃⟩ := hnot
+    obtain ⟨x, y, h, e⟩ := exists_eq_some_of_ne_zero h₁
+    have hqT : (Fintype.card F : ℤ) • (Point.some x y h : (W⁄k).Point) ≠ 0 := by rw [← e]; exact h₂
+    rcases dichotomy_of_compPoly_eq_zero W σ hσ hZ x y h hqT with h4 | h4
+    · rw [← e, smul_add, smul_add, smul_add] at h4
+      apply hP
+      have hT := hrel _ (hmemT T)
+      have key : σ • (σ • P) + (q : ℤ) • P =
+          (σ • (σ • P) + σ • (σ • (T : (W⁄k).Point))) + ((q : ℤ) • P + (q : ℤ) • (T : (W⁄k).Point))
+            - (σ • (σ • (T : (W⁄k).Point)) + (q : ℤ) • (T : (W⁄k).Point)) := by abel
+      rw [key, h4, hT, sub_zero, neg_add_cancel]
+    · exact h₃ (by rw [← e] at h4; exact h4)
+  have hB₁ : ∀ T T' : Tor, B₁ T → B₁ T' → T = T' := by
+    intro T T' hT hT'
+    apply Subtype.ext
+    exact add_left_cancel (hT.trans hT'.symm)
+  have hB₂ : ∀ T T' : Tor, B₂ T → B₂ T' → T = T' := by
+    intro T T' hT hT'
+    have hsub : (q : ℤ) • ((T : (W⁄k).Point) - T') = 0 := by
+      have : (T : (W⁄k).Point) - T' = (P + T) - (P + T') := by abel
+      rw [this, smul_sub, hT, hT', sub_zero]
+    have h0 := torsion_eq_zero_of_zsmul_eq_zero W hr hq0 (by omega) (hmem_sub T T') hsub
+    exact Subtype.ext (sub_eq_zero.mp h0)
+  have hB₃ : ∀ T T' : Tor, B₃ T → B₃ T' → T = T' := by
+    have pin : ∀ T : Tor, B₃ T →
+        σ • (σ • P) - (q : ℤ) • P = (2 * q : ℤ) • (T : (W⁄k).Point) := by
+      intro T hT
+      have hT' := hrel _ (hmemT T)
+      have h3 : σ • (σ • P) + σ • (σ • (T : (W⁄k).Point)) =
+          (q : ℤ) • P + (q : ℤ) • (T : (W⁄k).Point) := by
+        have := hT
+        simp only [B₃, smul_add] at this
+        exact this
+      have hb : σ • (σ • (T : (W⁄k).Point)) = -((q : ℤ) • (T : (W⁄k).Point)) :=
+        eq_neg_of_add_eq_zero_left hT'
+      rw [hb] at h3
+      rw [mul_smul, two_smul]
+      have key : σ • (σ • P) - (q : ℤ) • P =
+          (σ • (σ • P) + -((q : ℤ) • (T : (W⁄k).Point))) - (q : ℤ) • P + (q : ℤ) • (T : (W⁄k).Point)
+            := by
+        abel
+      rw [key, h3]
+      abel
+    intro T T' hT hT'
+    have h := (pin T hT).symm.trans (pin T' hT')
+    have hsub : (2 * q : ℤ) • ((T : (W⁄k).Point) - T') = 0 := by rw [smul_sub, h, sub_self]
+    have hsub' : ((2 * q : ℕ) : ℤ) • ((T : (W⁄k).Point) - T') = 0 := by push_cast; exact hsub
+    have h0 := torsion_eq_zero_of_zsmul_eq_zero W hr (by omega) h2qr (hmem_sub T T') hsub'
+    exact Subtype.ext (sub_eq_zero.mp h0)
+  have hle : ∀ (B : Tor → Prop) [DecidablePred B], (∀ T T' : Tor, B T → B T' → T = T') →
+      (Finset.univ.filter B).card ≤ 1 := by
+    intro B _ hB
+    exact Finset.card_le_one.mpr fun a ha b hb =>
+      hB a b (Finset.mem_filter.mp ha).2 (Finset.mem_filter.mp hb).2
+  have hunion : (Finset.univ : Finset Tor) ⊆
+      Finset.univ.filter B₁ ∪ Finset.univ.filter B₂ ∪ Finset.univ.filter B₃ := by
+    intro T _
+    rcases hcover T with h | h | h
+    · exact Finset.mem_union_left _ (Finset.mem_union_left _ (Finset.mem_filter.mpr ⟨Finset.mem_univ
+        _, h⟩))
+    · exact Finset.mem_union_left _ (Finset.mem_union_right _ (Finset.mem_filter.mpr
+        ⟨Finset.mem_univ _, h⟩))
+    · exact Finset.mem_union_right _ (Finset.mem_filter.mpr ⟨Finset.mem_univ _, h⟩)
+  have h3 : r ^ 2 ≤ 3 := by
+    calc r ^ 2 = (Finset.univ : Finset Tor).card := by rw [Finset.card_univ, hcardF]
+      _ ≤ (Finset.univ.filter B₁ ∪ Finset.univ.filter B₂ ∪ Finset.univ.filter B₃).card :=
+          Finset.card_le_card hunion
+      _ ≤ (Finset.univ.filter B₁ ∪ Finset.univ.filter B₂).card + (Finset.univ.filter B₃).card :=
+          Finset.card_union_le _ _
+      _ ≤ ((Finset.univ.filter B₁).card + (Finset.univ.filter B₂).card) + (Finset.univ.filter
+        B₃).card :=
+          Nat.add_le_add_right (Finset.card_union_le _ _) _
+      _ ≤ (1 + 1) + 1 := Nat.add_le_add (Nat.add_le_add (hle B₁ hB₁) (hle B₂ hB₂)) (hle B₃ hB₃)
+  have h9 : 3 ≤ r := by omega
+  have : 9 ≤ r ^ 2 := by nlinarith
+  omega
+
+theorem frobCharEqOnPoints_of_charEq_on_torsion_of_trace_zero
+    (hσ : ∀ x : k, σ x = x ^ Fintype.card F)
+    (hkill : ∀ N : ℕ, ∃ r : ℕ, N < r ∧ r.Prime ∧
+      Nat.card (Submodule.torsionBy ℤ (W⁄k).Point r) = r ^ 2 ∧
+      ∀ P : (W⁄k).Point, (r : ℤ) • P = 0 → σ • (σ • P) + (Fintype.card F : ℤ) • P = 0) :
+    FrobCharEqOnPoints W σ 0 (Fintype.card F) := by
+  obtain ⟨r, hNr, hr, hcard, hrel⟩ :=
+    hkill (max (2 * Fintype.card F) (2 * (compPoly W (F := F) (k := k)).natDegree + 2))
+  have h2q : 2 * Fintype.card F < r := lt_of_le_of_lt (le_max_left _ _) hNr
+  have hdeg : 2 * (compPoly W (F := F) (k := k)).natDegree + 2 < r :=
+    lt_of_le_of_lt (le_max_right _ _) hNr
+  have hZ := compPoly_eq_zero W σ hσ hr (by omega) hdeg hcard hrel
+  intro P
+  rw [zero_smul, sub_zero]
+  exact charEq_of_compPoly_eq_zero W σ hσ hZ hr h2q hcard hrel P
+
+end FrobeniusEndo.TraceZeroPort
+
+open _root_.FrobeniusEndo
+  _root_.P2MW.S_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_zero.FrobeniusEndo in
+theorem solution {R : Type*} [CommRing R] {F : Type*} [Field F] [Fintype F] {k : Type*} [Field k]
+    [DecidableEq k] [Algebra R F] [Algebra R k] [Algebra F k] [IsScalarTower R F k]
+    (W : WeierstrassCurve R) (σ : k ≃ₐ[F] k) (hσ : ∀ x : k, σ x = x ^ Fintype.card F)
+    (hkill : ∀ N : ℕ, ∃ r : ℕ, N < r ∧ r.Prime ∧ Nat.card (Submodule.torsionBy ℤ (W⁄k).Point r) = r
+      ^ 2 ∧
+      ∀ P : (W⁄k).Point, (r : ℤ) • P = 0 → σ • (σ • P) + (Fintype.card F : ℤ) • P = 0) :
+    FrobCharEqOnPoints W σ 0 (Fintype.card F) :=
+  FrobeniusEndo.TraceZeroPort.frobCharEqOnPoints_of_charEq_on_torsion_of_trace_zero W σ hσ hkill
+
+end S_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_zero
+end P2MW
+export P2MW.S_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo
+
+theorem FrobeniusEndo.frobCharEqOnPoints_of_charEq_on_torsion_of_trace_zero {R : Type*} [CommRing R]
+  {F : Type*} [Field F] [Fintype F] {k : Type*} [Field k] [DecidableEq k] [Algebra R F] [Algebra R
+  k] [Algebra F k] [IsScalarTower R F k] (W : WeierstrassCurve R) (σ : k ≃ₐ[F] k) (hσ : ∀ x : k, σ x
+  = x ^ Fintype.card F) (hkill : ∀ N : ℕ, ∃ r : ℕ, N < r ∧ r.Prime ∧ Nat.card (Submodule.torsionBy ℤ
+  (W⁄k).Point r) = r ^ 2 ∧ ∀ P : (W⁄k).Point, (r : ℤ) • P = 0 → σ • (σ • P) + (Fintype.card F : ℤ) •
+  P = 0) :
+    FrobCharEqOnPoints W σ 0 (Fintype.card F) :=
+  solution W σ hσ hkill
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_frobCharEqOnPoints_of_frobenius.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_frobCharEqOnPoints_of_frobenius.lean
new file mode 100644
index 0000000000..786d0b4011
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_frobCharEqOnPoints_of_frobenius.lean
@@ -0,0 +1,106 @@
+/-
+Based on Prove2Me node FrobeniusEndo.frobCharEqOnPoints_of_frobenius
+(fec843be-6909-5c6e-93ce-0bb605f7b389) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ce878657-908a-5076-8c90-565e4d684373
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusEndo
+public import Mathlib.LinearAlgebra.Determinant
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_frobCharEqOnPoints_of_line
+import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_kerDeg_frobEnd_line_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_kerDeg_frobEnd_line_one_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsion_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Frobenius satisfies π²-aπ+q=0 on all k-points
+
+Theorem statement: `FrobeniusEndo.frobCharEqOnPoints_of_frobenius`
+(`fec843be-6909-5c6e-93ce-0bb605f7b389`), by Claude, 2026-09-05.
+
+Proof: submission `ce878657-908a-5076-8c90-565e4d684373`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring, $F$ a finite field, and $k$ an algebraically closed field, equipped
+with $R$-algebra structures on $F$ and $k$ and an $F$-algebra structure on $k$ forming a scalar
+tower over $R$. Let $W$ be a Weierstrass curve over $R$ whose base change $W⁄k$ to $k$ is elliptic,
+and let $\sigma : k \simeq_{\mathrm{alg}[F]} k$ be an $F$-algebra automorphism of $k$ which is the
+$q$-power map, $\sigma x = x^{q}$ for all $x \in k$, where $q = \#F$; assume moreover that $q$ is
+prime. Then `FrobCharEqOnPoints W σ a q` holds with $a = q + 1 - \#(W⁄F).\mathrm{Point}$ (the
+cardinality of the group of points of the base change of $W$ to $F$, as an integer) and with $q =
+\#F$: that is, for every point $P$ of the elliptic curve $W⁄k$ over $k$,
+$$\sigma \bullet (\sigma \bullet P) - a \bullet (\sigma \bullet P) + q \bullet P = 0,$$
+where $\sigma \bullet$ denotes the induced action of $\sigma$ on points and the integer multiples
+are taken in the group $(W⁄k).\mathrm{Point}$. Thus Frobenius satisfies the relation $\pi^{2} - a\pi
++ q = 0$ pointwise on $(W⁄k).\mathrm{Point}$.
+
+This is the pointwise form of the statement that the characteristic polynomial of the Frobenius
+endomorphism of an elliptic curve over a finite field $\mathbb{F}_q$ is $X^{2} - aX + q$ with $a = q
++ 1 - \#E(\mathbb{F}_q)$, here under the restriction that $q$ is prime. It feeds the computation of
+the trace and determinant of Frobenius on torsion, via
+[`FrobeniusEndo.galoisTrace_det_frob_of_isAlgClosed`]
+(thm.html#FrobeniusEndo.galoisTrace_det_frob_of_isAlgClosed)
+and
+[`WeierstrassCurve.frobenius_cayleyHamilton_on_torsion`]
+(thm.html#WeierstrassCurve.frobenius_cayleyHamilton_on_torsion),
+which is the special-fibre input needed for the Galois representation attached to the Frey curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_FrobeniusEndo_frobCharEqOnPoints_of_frobenius.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_FrobeniusEndo_frobCharEqOnPoints_of_frobenius
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo
+
+theorem solution {R : Type*} [CommRing R] {F : Type*} [Field F] [Fintype F] {k : Type*} [Field k]
+    [DecidableEq k]
+    [Algebra R F] [Algebra R k] [Algebra F k] [IsScalarTower R F k] [IsAlgClosed k]
+    (W : WeierstrassCurve R) [(W⁄k).IsElliptic] (σ : k ≃ₐ[F] k)
+    (hσ : ∀ x : k, σ x = x ^ Fintype.card F)
+    (hF : (Fintype.card F).Prime) :
+    FrobCharEqOnPoints W σ ((Fintype.card F : ℤ) + 1 - (Nat.card (W⁄F).Point : ℤ)) (Fintype.card F)
+      := by
+  refine FrobeniusEndo.frobCharEqOnPoints_of_line W σ hσ _
+    (fun m hm hmk => FrobeniusEndo.kerDeg_frobEnd_line_one W σ hσ hF m hm hmk)
+    (fun m hm hmk => FrobeniusEndo.kerDeg_frobEnd_line_one_ne_zero W σ hσ hF m hm hmk)
+    (fun r _ hrk => ?_)
+  exact WeierstrassCurve.card_torsion_of_isAlgClosed (K := k) (W⁄k) hrk
+
+end S_FrobeniusEndo_frobCharEqOnPoints_of_frobenius
+end P2MW
+export P2MW.S_FrobeniusEndo_frobCharEqOnPoints_of_frobenius (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo
+
+theorem FrobeniusEndo.frobCharEqOnPoints_of_frobenius {R : Type*} [CommRing R] {F : Type*} [Field F]
+    [Fintype F] {k : Type*} [Field k] [DecidableEq k] [Algebra R F] [Algebra R k] [Algebra F k]
+    [IsScalarTower R F k] [IsAlgClosed k] (W : WeierstrassCurve R) [(W⁄k).IsElliptic]
+    (σ : k ≃ₐ[F] k) (hσ : ∀ x : k, σ x = x ^ Fintype.card F) (hF : (Fintype.card F).Prime) :
+    FrobCharEqOnPoints W σ ((Fintype.card F : ℤ) + 1 - (Nat.card (W⁄F).Point : ℤ)) (Fintype.card F)
+      :=
+  solution W σ hσ hF
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_frobCharEqOnPoints_of_line.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_frobCharEqOnPoints_of_line.lean
new file mode 100644
index 0000000000..fcbc4c4ac4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_frobCharEqOnPoints_of_line.lean
@@ -0,0 +1,141 @@
+/-
+Based on Prove2Me node FrobeniusEndo.frobCharEqOnPoints_of_line
+(cf41822f-465d-5a6a-bfb0-4562cc7041a4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 48336ca9-ef16-589b-9c75-53d99dcf49c0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusEndo
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_exists_prime_gt_and_quadratic_root
+import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_charEq_on_torsionBy_of_line_of_isotropic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_frobCharEqOnPoints_of_charEq_on_torsion_of_trace_zero
+import Mathlib.FieldTheory.Finite.Basic
+import Mathlib.Algebra.CharP.Algebra
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Pointwise characteristic equation of Frobenius from the kernel-count line
+
+Theorem statement: `FrobeniusEndo.frobCharEqOnPoints_of_line`
+(`cf41822f-465d-5a6a-bfb0-4562cc7041a4`), by Claude, 2026-09-05.
+
+Proof: submission `48336ca9-ef16-589b-9c75-53d99dcf49c0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring, $F$ a finite field, $k$ a field, with algebra structures making $R
+\to F \to k$ a scalar tower, let $W$ be a Weierstrass curve over $R$, and let $\sigma$ be an
+$F$-algebra automorphism of $k$ such that $\sigma x = x^{\#F}$ for every $x \in k$; write $q = \#F$
+and let $\pi =$ `frobEnd W σ` be the additive endomorphism of the group of affine points
+$(W\!\!\restriction_k).\mathrm{Point}$ of the base change of $W$ to $k$ given by the action of
+$\sigma$. Fix $a \in \mathbb{Z}$ and assume: (i) for every natural $m \ge 1$ whose image in $k$ is
+nonzero, the number of points in the kernel of the endomorphism $m\cdot\mathrm{id} - \pi$ (counted
+by `Nat.card`) equals $m^2 - am + q$; (ii) for every such $m$ that cardinality is nonzero, i.e. the
+kernel is finite; (iii) for every prime $r$ whose image in $k$ is nonzero, the $r$-torsion submodule
+of the point group has exactly $r^2$ elements. The conclusion is `FrobCharEqOnPoints W σ a q`: for
+every point $P$ of $W$ over $k$, $\sigma\bullet(\sigma\bullet P) - a\bullet(\sigma\bullet P) +
+q\bullet P = 0$.
+
+This is the step, in the kernel-counting treatment of the Frobenius endomorphism of an elliptic
+curve over a finite field, that upgrades the numerical identity $\#\ker([m]-\pi) = m^2 - am + q$ to
+the operator identity $\pi^2 - a\pi + q = 0$ holding at every point. It feeds the derivation of the
+characteristic equation of Frobenius from the geometric Frobenius hypotheses and the computation of
+the trace of Frobenius on the Tate module as $\#W(\mathbb{F}_q)$-related quantity $q + 1 -
+\#W(\mathbb{F}_q)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_FrobeniusEndo_frobCharEqOnPoints_of_line.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_FrobeniusEndo_frobCharEqOnPoints_of_line
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo
+
+theorem solution {R : Type*} [CommRing R] {F : Type*} [Field F] [Fintype F] {k : Type*} [Field k]
+    [DecidableEq k]
+    [Algebra R F] [Algebra R k] [Algebra F k] [IsScalarTower R F k] (W : WeierstrassCurve R)
+    (σ : k ≃ₐ[F] k)
+    (hσ : ∀ x : k, σ x = x ^ Fintype.card F) (a : ℤ)
+    (hline : ∀ m : ℕ, 1 ≤ m → (m : k) ≠ 0 →
+      ((kerDeg (frobEnd W σ) m 1 : ℕ) : ℤ) = (m : ℤ) ^ 2 - a * m + Fintype.card F)
+    (hpos : ∀ m : ℕ, 1 ≤ m → (m : k) ≠ 0 → kerDeg (frobEnd W σ) m 1 ≠ 0)
+    (hcount : ∀ r : ℕ, r.Prime → (r : k) ≠ 0 → Nat.card (Submodule.torsionBy ℤ (W⁄k).Point r) = r ^
+      2) :
+    FrobCharEqOnPoints W σ a (Fintype.card F) := by
+  set q : ℕ := Fintype.card F with hq
+  have hq1 : 1 ≤ q := Fintype.card_pos_iff.mpr ⟨1⟩
+  have hinv : ∀ r : ℕ, r.Prime → q < r → (r : k) ≠ 0 := by
+    intro r hr hqr h0
+    have h0F : (r : F) = 0 := by
+      apply (algebraMap F k).injective
+      rw [map_natCast, _root_.map_zero]
+      exact h0
+    have hdvd_r : ringChar F ∣ r := (ringChar.spec F r).mp h0F
+    have hdvd_q : ringChar F ∣ q := (ringChar.spec F q).mp (FiniteField.cast_card_eq_zero F)
+    have hne1 : ringChar F ≠ 1 := CharP.ringChar_ne_one
+    rcases (Nat.dvd_prime hr).mp hdvd_r with h1 | h2
+    · exact hne1 h1
+    · have hle : ringChar F ≤ q := Nat.le_of_dvd hq1 hdvd_q
+      omega
+  have hkill : ∀ N : ℕ, ∃ r : ℕ, N < r ∧ r.Prime ∧ Nat.card (Submodule.torsionBy ℤ (W⁄k).Point r) =
+    r ^ 2 ∧
+      ∀ P : (W⁄k).Point, (r : ℤ) • P = 0 → σ • (σ • P) - a • (σ • P) + (q : ℤ) • P = 0 := by
+    intro N
+    obtain ⟨r, hNr, hr, c, hc⟩ :=
+      FrobeniusEndo.exists_prime_gt_and_quadratic_root a (q : ℤ) (by exact_mod_cast hq1) (max N q)
+    have hN : N < r := lt_of_le_of_lt (le_max_left N q) hNr
+    have hqr : q < r := lt_of_le_of_lt (le_max_right N q) hNr
+    have hrk : (r : k) ≠ 0 := hinv r hr hqr
+    have hfull : Nat.card (Submodule.torsionBy ℤ (W⁄k).Point r) = r ^ 2 := hcount r hr hrk
+    have : Fact r.Prime := ⟨hr⟩
+    have hiso : ∃ c : ZMod r, c ^ 2 - (a : ZMod r) * c + (q : ZMod r) = 0 :=
+      ⟨c, by exact_mod_cast hc⟩
+    refine ⟨r, hN, hr, hfull, fun P hP => ?_⟩
+    exact FrobeniusEndo.charEq_on_torsionBy_of_line_of_isotropic W σ r hfull hrk a q
+      (fun m hm _ hmk => hline m hm hmk) (fun m hm _ hmk => hpos m hm hmk) hiso P hP
+  rcases eq_or_ne a 0 with rfl | ha
+  · apply FrobeniusEndo.frobCharEqOnPoints_of_charEq_on_torsion_of_trace_zero W σ hσ
+    intro N
+    obtain ⟨r, hN, hr, hfull, hk⟩ := hkill N
+    refine ⟨r, hN, hr, hfull, fun P hP => ?_⟩
+    have := hk P hP
+    rwa [zero_smul, sub_zero] at this
+  · exact FrobeniusEndo.frobCharEqOnPoints_of_charEq_on_torsion_of_trace_ne_zero W σ hσ ha hkill
+
+end S_FrobeniusEndo_frobCharEqOnPoints_of_line
+end P2MW
+export P2MW.S_FrobeniusEndo_frobCharEqOnPoints_of_line (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo
+
+theorem FrobeniusEndo.frobCharEqOnPoints_of_line {R : Type*} [CommRing R] {F : Type*} [Field F]
+  [Fintype F] {k : Type*} [Field k] [DecidableEq k] [Algebra R F] [Algebra R k] [Algebra F k]
+  [IsScalarTower R F k] (W : WeierstrassCurve R) (σ : k ≃ₐ[F] k) (hσ : ∀ x : k, σ x = x ^
+  Fintype.card F) (a : ℤ) (hline : ∀ m : ℕ, 1 ≤ m → (m : k) ≠ 0 → ((kerDeg (frobEnd W σ) m 1 : ℕ) :
+  ℤ) = (m : ℤ) ^ 2 - a * m + Fintype.card F) (hpos : ∀ m : ℕ, 1 ≤ m → (m : k) ≠ 0 → kerDeg (frobEnd
+  W σ) m 1 ≠ 0) (hcount : ∀ r : ℕ, r.Prime → (r : k) ≠ 0 → Nat.card (Submodule.torsionBy ℤ
+  (W⁄k).Point r) = r ^ 2) :
+    FrobCharEqOnPoints W σ a (Fintype.card F) :=
+  solution W σ hσ a hline hpos hcount
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_kerDeg_frobEnd_line_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_kerDeg_frobEnd_line_one.lean
new file mode 100644
index 0000000000..8a098fce77
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_kerDeg_frobEnd_line_one.lean
@@ -0,0 +1,97 @@
+/-
+Based on Prove2Me node FrobeniusEndo.kerDeg_frobEnd_line_one
+(e575b5dc-c8e1-5a4a-90c9-fd4a42af88ad) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b07d107c-5f39-50ad-b44b-748de3f62fa8
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusEndo
+public import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+public import Mathlib.Algebra.Polynomial.Derivative
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_kerDeg_frobEnd_line_one_pos_and_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_kerDeg_frobEnd_one_one
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Kernel-degree line #ker([m]-π)=m²-am+q
+
+Theorem statement: `FrobeniusEndo.kerDeg_frobEnd_line_one` (`e575b5dc-c8e1-5a4a-90c9-fd4a42af88ad`),
+by Claude, 2026-09-05.
+
+Proof: submission `b07d107c-5f39-50ad-b44b-748de3f62fa8`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring, $F$ a finite field, and $k$ an algebraically closed field, equipped
+with $R$-algebra structures on $F$ and $k$ and an $F$-algebra structure on $k$ forming a scalar
+tower over $R$. Let $W$ be a Weierstrass curve over $R$ whose base change $W\!\;\!⁄k$ is elliptic,
+and let $\sigma$ be an $F$-algebra automorphism of $k$ with $\sigma(x)=x^{q}$ for all $x\in k$,
+where $q=\#F$; assume $q$ is prime. Let $m$ be a natural number with $m\ge 1$ whose image in $k$ is
+nonzero. Write $\pi=$ `frobEnd W σ` for the additive endomorphism of the group of affine points of
+$W\!\;\!⁄k$ (point at infinity included) induced by the action of $\sigma$. Then the cardinality of
+the kernel of the endomorphism $m\cdot\mathrm{id}-\pi$ of that group, viewed as an integer, equals
+$$m^{2}-\bigl(q+1-\#(W\!\;\!⁄F)(\text{points})\bigr)\,m+q,$$
+where $\#(W\!\;\!⁄F)(\text{points})$ is `Nat.card (W⁄F).Point`, the number of points of the base
+change of $W$ to $F$.
+
+This is the kernel-degree identity underlying Manin's elementary proof of the Hasse bound: the
+function $m\mapsto\#\ker([m]-\pi)$ is given by the quadratic $m^{2}-am+q$ with $a=q+1-\#W(F)$ the
+trace of Frobenius. It feeds the computation of the trace of Frobenius on torsion, i.e. the
+statement that $\operatorname{tr}\bar\rho_{W,p}(\mathrm{Frob}_q)=q+1-\#W(F)$ at a prime of good
+reduction, and is cited by the determinant/trace computations for the mod $p$ representation and by
+the division-polynomial results on $a_p$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_FrobeniusEndo_kerDeg_frobEnd_line_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_FrobeniusEndo_kerDeg_frobEnd_line_one
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo
+
+theorem solution {R : Type*} [CommRing R] {F : Type*} [Field F] [Fintype F] {k : Type*} [Field k]
+    [DecidableEq k] [Algebra R F] [Algebra R k] [Algebra F k] [IsScalarTower R F k] [IsAlgClosed k]
+    (W : WeierstrassCurve R) [(W⁄k).IsElliptic] (σ : k ≃ₐ[F] k)
+    (hσ : ∀ x : k, σ x = x ^ Fintype.card F) (hF : (Fintype.card F).Prime) (m : ℕ) (hm : 1 ≤ m)
+    (hmk : (m : k) ≠ 0) :
+    ((kerDeg (frobEnd W σ) m 1 : ℕ) : ℤ) = (m : ℤ) ^ 2 - ((Fintype.card F : ℤ) + 1 - (Nat.card
+      (W⁄F).Point : ℤ)) * m + Fintype.card F := by
+  have h := (FrobeniusEndo.kerDeg_frobEnd_line_one_pos_and_eq W σ hσ hF m hm hmk).2
+  rw [FrobeniusEndo.kerDeg_frobEnd_one_one W σ hσ] at h
+  exact h
+
+end S_FrobeniusEndo_kerDeg_frobEnd_line_one
+end P2MW
+export P2MW.S_FrobeniusEndo_kerDeg_frobEnd_line_one (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo
+
+theorem FrobeniusEndo.kerDeg_frobEnd_line_one {R : Type*} [CommRing R] {F : Type*} [Field F]
+    [Fintype F] {k : Type*} [Field k] [DecidableEq k] [Algebra R F] [Algebra R k] [Algebra F k]
+    [IsScalarTower R F k] [IsAlgClosed k] (W : WeierstrassCurve R) [(W⁄k).IsElliptic]
+    (σ : k ≃ₐ[F] k) (hσ : ∀ x : k, σ x = x ^ Fintype.card F) (hF : (Fintype.card F).Prime) (m : ℕ)
+    (hm : 1 ≤ m) (hmk : (m : k) ≠ 0) :
+    ((kerDeg (frobEnd W σ) m 1 : ℕ) : ℤ) = (m : ℤ) ^ 2 - ((Fintype.card F : ℤ) + 1 - (Nat.card
+      (W⁄F).Point : ℤ)) * m + Fintype.card F :=
+  solution W σ hσ hF m hm hmk
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_kerDeg_frobEnd_line_one_ne_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_kerDeg_frobEnd_line_one_ne_zero.lean
new file mode 100644
index 0000000000..d37a6c7d17
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_kerDeg_frobEnd_line_one_ne_zero.lean
@@ -0,0 +1,94 @@
+/-
+Based on Prove2Me node FrobeniusEndo.kerDeg_frobEnd_line_one_ne_zero
+(ebfaccc3-8d45-57a7-9bc9-c94126b990f6) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 65f715f6-f7be-5d44-a8ed-01e0a4709675
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusEndo
+public import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+public import Mathlib.Algebra.Polynomial.Derivative
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_kerDeg_frobEnd_line_one_pos_and_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finiteness of ker([m]-π) on W(k)
+
+Theorem statement: `FrobeniusEndo.kerDeg_frobEnd_line_one_ne_zero`
+(`ebfaccc3-8d45-57a7-9bc9-c94126b990f6`), by Claude, 2026-09-05.
+
+Proof: submission `65f715f6-f7be-5d44-a8ed-01e0a4709675`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring, $F$ a finite field, and $k$ an algebraically closed field with
+decidable equality, equipped with $R$-algebra structures on $F$ and on $k$ and an $F$-algebra
+structure on $k$ forming a scalar tower over $R$. Let $W$ be a Weierstrass curve over $R$ whose base
+change $W⁄k$ to $k$ is elliptic, and let $\sigma : k \simeq_{\mathrm{alg}[F]} k$ be an $F$-algebra
+automorphism of $k$ satisfying $\sigma(x) = x^{\#F}$ for every $x \in k$; assume $\#F$ is prime. Let
+$m$ be a natural number with $1 \le m$ whose image in $k$ is nonzero. Writing $\pi =$ `frobEnd W σ`
+for the additive endomorphism of the group of affine points $(W⁄k).\mathrm{Point}$ induced by the
+action of $\sigma$, the conclusion is that `kerDeg (frobEnd W σ) m 1` is nonzero, where `kerDeg ψ m
+n` denotes `Nat.card` of the kernel of the pencil $m \cdot \mathrm{id} - n \cdot \psi$; thus the
+cardinality of the kernel of $[m] - \pi$ on $(W⁄k).\mathrm{Point}$ is nonzero, i.e. (this kernel
+being nonempty) that kernel is finite.
+
+The assertion is the finiteness half of the standard count of $\ker([m] - \pi)$ for the $\#F$-power
+Frobenius $\pi$ on an elliptic curve over an algebraically closed field, the statement that $[m] -
+\pi$ is a nonzero separable isogeny in Manin's route to the Hasse bound. It serves as the positivity
+input for the passage between divisibility of $\#\ker([m]-\pi)$ by the residue characteristic and
+vanishing of $\det(\bar m - \bar\rho(\pi))$, and is used in the computation of the characteristic
+polynomial of Frobenius on points, in the determinant–trace identification for Galois
+representations over algebraically closed fields, and in the analysis of coefficients of division
+polynomials.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_FrobeniusEndo_kerDeg_frobEnd_line_one_ne_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_FrobeniusEndo_kerDeg_frobEnd_line_one_ne_zero
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo
+
+theorem solution {R : Type*} [CommRing R] {F : Type*} [Field F] [Fintype F] {k : Type*} [Field k]
+    [DecidableEq k] [Algebra R F] [Algebra R k] [Algebra F k] [IsScalarTower R F k] [IsAlgClosed k]
+    (W : WeierstrassCurve R) [(W⁄k).IsElliptic] (σ : k ≃ₐ[F] k)
+    (hσ : ∀ x : k, σ x = x ^ Fintype.card F) (hF : (Fintype.card F).Prime) (m : ℕ) (hm : 1 ≤ m)
+    (hmk : (m : k) ≠ 0) :
+    kerDeg (frobEnd W σ) m 1 ≠ 0 :=
+  Nat.pos_iff_ne_zero.mp (FrobeniusEndo.kerDeg_frobEnd_line_one_pos_and_eq W σ hσ hF m hm hmk).1
+
+end S_FrobeniusEndo_kerDeg_frobEnd_line_one_ne_zero
+end P2MW
+export P2MW.S_FrobeniusEndo_kerDeg_frobEnd_line_one_ne_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo
+
+theorem FrobeniusEndo.kerDeg_frobEnd_line_one_ne_zero {R : Type*} [CommRing R] {F : Type*} [Field F]
+    [Fintype F] {k : Type*} [Field k] [DecidableEq k] [Algebra R F] [Algebra R k] [Algebra F k]
+    [IsScalarTower R F k] [IsAlgClosed k] (W : WeierstrassCurve R) [(W⁄k).IsElliptic]
+    (σ : k ≃ₐ[F] k) (hσ : ∀ x : k, σ x = x ^ Fintype.card F) (hF : (Fintype.card F).Prime) (m : ℕ)
+    (hm : 1 ≤ m) (hmk : (m : k) ≠ 0) :
+    kerDeg (frobEnd W σ) m 1 ≠ 0 :=
+  solution W σ hσ hF m hm hmk
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_kerDeg_frobEnd_line_one_pos_and_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_kerDeg_frobEnd_line_one_pos_and_eq.lean
new file mode 100644
index 0000000000..ada3f9117e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_kerDeg_frobEnd_line_one_pos_and_eq.lean
@@ -0,0 +1,101 @@
+/-
+Based on Prove2Me node FrobeniusEndo.kerDeg_frobEnd_line_one_pos_and_eq
+(b61d4902-cce5-5815-808f-f69879ba6811) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ee2032d3-f4e7-5c3f-8097-7dfac7b5d355
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusEndo
+public import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_kerDeg_frobEnd_line_one_pos_and_eq_of_torsion
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_smul_some_eq_zero_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_evalEval_psi_sq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_isCoprime_Phi_PsiSq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree formula for the Frobenius pencil [m]-π
+
+Theorem statement: `FrobeniusEndo.kerDeg_frobEnd_line_one_pos_and_eq`
+(`b61d4902-cce5-5815-808f-f69879ba6811`), by Claude, 2026-09-05.
+
+Proof: submission `ee2032d3-f4e7-5c3f-8097-7dfac7b5d355`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring, $F$ a finite field, and $k$ a field with decidable equality, equipped
+with $R$- and $F$-algebra structures forming a scalar tower $R \to F \to k$, with $k$ algebraically
+closed (these and the remaining typeclass assumptions are routine). Let $W$ be a Weierstrass curve
+over $R$ whose base change $W_{/k}$ is elliptic, and let $\sigma$ be an $F$-algebra automorphism of
+$k$ such that $\sigma x = x^{\#F}$ for all $x \in k$; assume $q := \#F$ is prime. Write $\pi =$
+`frobEnd W σ` for the additive endomorphism of the group of points $(W_{/k})$.`Point` induced by the
+action of $\sigma$, and for integers $m,n$ let `kerDeg π m n` be the cardinality of the kernel of
+the additive map $m \cdot \mathrm{id} - n \cdot \pi$. Then for every natural number $m \ge 1$ whose
+image in $k$ is nonzero, the kernel of $[m] - \pi$ is finite and nonempty in the sense that `kerDeg
+π m 1` $> 0$, and, as an identity of integers,
+$$\#\ker([m]-\pi) = m^2 - \bigl(q + 1 - \#\ker([1]-\pi)\bigr)m + q.$$
+
+This is the degree computation underlying Manin's elementary proof of Hasse's theorem: the pencil
+$[m] - \pi$ has degree $m^2 - am + q$ with trace $a = q + 1 - \#\ker([1]-\pi)$, the latter kernel
+being the group of $F$-rational points. It feeds the determination of the trace and determinant of
+Frobenius on $p$-torsion, and is used by
+[`FrobeniusEndo.kerDeg_frobEnd_line_one`](thm.html#FrobeniusEndo.kerDeg_frobEnd_line_one) and
+[`FrobeniusEndo.kerDeg_frobEnd_line_one_ne_zero`]
+(thm.html#FrobeniusEndo.kerDeg_frobEnd_line_one_ne_zero).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_FrobeniusEndo_kerDeg_frobEnd_line_one_pos_and_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_FrobeniusEndo_kerDeg_frobEnd_line_one_pos_and_eq
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo
+
+theorem solution {R : Type*} [CommRing R] {F : Type*} [Field F] [Fintype F] {k : Type*} [Field k]
+    [DecidableEq k] [Algebra R F] [Algebra R k] [Algebra F k] [IsScalarTower R F k] [IsAlgClosed k]
+    (W : WeierstrassCurve R) [(W⁄k).IsElliptic] (σ : k ≃ₐ[F] k)
+    (hσ : ∀ x : k, σ x = x ^ Fintype.card F) (hF : (Fintype.card F).Prime) (m : ℕ) (hm : 1 ≤ m)
+    (hmk : (m : k) ≠ 0) :
+    0 < kerDeg (frobEnd W σ) m 1 ∧ ((kerDeg (frobEnd W σ) m 1 : ℕ) : ℤ) = (m : ℤ) ^ 2 -
+      ((Fintype.card F : ℤ) + 1 - kerDeg (frobEnd W σ) 1 1) * m + Fintype.card F := by
+  refine FrobeniusEndo.kerDeg_frobEnd_line_one_pos_and_eq_of_torsion W σ hσ hF ?_
+    (fun n => WeierstrassCurve.isCoprime_Phi_PsiSq (W⁄k) n) m hm hmk
+  intro n x y h h0
+  rw [← WeierstrassCurve.Affine.evalEval_psi_sq (W⁄k) h.1 n,
+    (WeierstrassCurve.Affine.Point.smul_some_eq_zero_iff (W⁄k) h n).mp h0, zero_pow two_ne_zero]
+
+end S_FrobeniusEndo_kerDeg_frobEnd_line_one_pos_and_eq
+end P2MW
+export P2MW.S_FrobeniusEndo_kerDeg_frobEnd_line_one_pos_and_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo
+
+theorem FrobeniusEndo.kerDeg_frobEnd_line_one_pos_and_eq {R : Type*} [CommRing R] {F : Type*}
+    [Field F] [Fintype F] {k : Type*} [Field k] [DecidableEq k] [Algebra R F] [Algebra R k]
+    [Algebra F k] [IsScalarTower R F k] [IsAlgClosed k] (W : WeierstrassCurve R) [(W⁄k).IsElliptic]
+    (σ : k ≃ₐ[F] k) (hσ : ∀ x : k, σ x = x ^ Fintype.card F) (hF : (Fintype.card F).Prime) (m : ℕ)
+    (hm : 1 ≤ m) (hmk : (m : k) ≠ 0) :
+    0 < kerDeg (frobEnd W σ) m 1 ∧ ((kerDeg (frobEnd W σ) m 1 : ℕ) : ℤ) = (m : ℤ) ^ 2 -
+      ((Fintype.card F : ℤ) + 1 - kerDeg (frobEnd W σ) 1 1) * m + Fintype.card F :=
+  solution W σ hσ hF m hm hmk
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_kerDeg_frobEnd_line_one_pos_and_eq_of_torsion.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_kerDeg_frobEnd_line_one_pos_and_eq_of_torsion.lean
new file mode 100644
index 0000000000..c482d1fd24
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_kerDeg_frobEnd_line_one_pos_and_eq_of_torsion.lean
@@ -0,0 +1,624 @@
+/-
+Based on Prove2Me node FrobeniusEndo.kerDeg_frobEnd_line_one_pos_and_eq_of_torsion
+(675ebf6f-69f9-55b3-adef-4ca67b02e463) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission aa830f3a-c4dc-5e41-8f9a-ac9217f03515
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusEndo
+public import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_card_ker_eq_max_natDegree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_natDegree_parallelogram_law
+import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_exists_x_linePencil_frobEnd_mul_collision_sq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_zsmul_x_mul_psi_sq
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+import Mathlib.Algebra.Polynomial.Derivative
+import Mathlib.FieldTheory.RatFunc.Basic
+import Mathlib.FieldTheory.IsAlgClosed.Basic
+import Mathlib.Tactic.LinearCombination
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Kernel count #ker([m]-π)=m²-am+q for the Frobenius pencil
+
+Theorem statement: `FrobeniusEndo.kerDeg_frobEnd_line_one_pos_and_eq_of_torsion`
+(`675ebf6f-69f9-55b3-adef-4ca67b02e463`), by Claude, 2026-09-05.
+
+Proof: submission `aa830f3a-c4dc-5e41-8f9a-ac9217f03515`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring, $F$ a finite field, $k$ an algebraically closed field, with algebra
+maps $R \to F \to k$ forming a scalar tower, and let $W$ be a Weierstrass curve over $R$ whose base
+change $W_{/k}$ is elliptic. Let $\sigma$ be an $F$-algebra automorphism of $k$ with $\sigma(x) =
+x^{q}$ for all $x \in k$, where $q = \#F$, and assume $q$ is prime. Two division-polynomial facts
+are assumed as hypotheses: `htor`, that for every $n \in \mathbb{Z}$ and every nonsingular affine
+point $(x,y)$ of $W_{/k}$ with $n \cdot (x,y) = 0$ one has $\Psi_n^2(x) = 0$; and `hcop`, that
+$\Phi_n$ and $\Psi_n^2$ are coprime for every $n \in \mathbb{Z}$. Finally let $m$ be a natural
+number with $m \ge 1$ whose image in $k$ is nonzero. Writing $\pi$ for the endomorphism `frobEnd` of
+the group $(W_{/k})(k)$ induced by $\sigma$, and $\mathrm{kerDeg}(\pi, a, b) = \#\ker(a - b\pi)$ as
+the cardinality of the kernel of $a \cdot \mathrm{id} - b\pi$, the conclusion is that $\#\ker([m] -
+\pi) > 0$ and, as an identity of integers, $$\#\ker([m]-\pi) = m^2 - \bigl(q + 1 -
+\#\ker([1]-\pi)\bigr)m + q.$$
+
+This is the degree formula at the heart of Manin's elementary proof of the Hasse bound, with the
+trace written as $a = q + 1 - \#\ker(1-\pi)$ rather than through a point count. It is the version
+carrying the two division-polynomial inputs as explicit hypotheses; the hypothesis-free form
+[`FrobeniusEndo.kerDeg_frobEnd_line_one_pos_and_eq`]
+(thm.html#FrobeniusEndo.kerDeg_frobEnd_line_one_pos_and_eq)
+is obtained from it by discharging them.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_FrobeniusEndo_kerDeg_frobEnd_line_one_pos_and_eq_of_torsion.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_FrobeniusEndo_kerDeg_frobEnd_line_one_pos_and_eq_of_torsion
+
+p2m_open "Polynomial WeierstrassCurve~evalEval_ψ_sq~evalEval_φ WeierstrassCurve.Affine \
+  WeierstrassCurve.Affine.Point FrobeniusEndo"
+
+open scoped Polynomial.Bivariate
+
+namespace M4cP4H4
+
+section Wronskian
+
+variable {k : Type*} [Field k]
+
+theorem wronskian_ne_zero_of_natDegree_eq_succ {u v : k[X]} (hv : v ≠ 0)
+    (hdeg : u.natDegree = v.natDegree + 1) :
+    derivative u * v - u * derivative v ≠ 0 := by
+  set e := v.natDegree with he
+  have hu : u ≠ 0 := by
+    intro h0
+    rw [h0, natDegree_zero] at hdeg
+    omega
+  have h1 : (derivative u * v).coeff (e + e) = u.coeff (e + 1) * (e + 1) * v.coeff e := by
+    have hdu : (derivative u).natDegree ≤ e := by
+      have := natDegree_derivative_le u
+      omega
+    rw [coeff_mul_add_eq_of_natDegree_le hdu le_rfl, coeff_derivative]
+  have h2 : (u * derivative v).coeff (e + e) = u.coeff (e + 1) * (v.coeff e * e) := by
+    rcases Nat.eq_zero_or_pos e with he0 | hepos
+    · have h00 : v.natDegree = 0 := by rw [← he]; exact he0
+      have hv' : derivative v = 0 := by
+        rw [eq_C_of_natDegree_eq_zero h00, derivative_C]
+      rw [hv', mul_zero, coeff_zero, he0, Nat.cast_zero, mul_zero, mul_zero]
+    · obtain ⟨e', he'⟩ : ∃ e', e = e' + 1 := ⟨e - 1, by omega⟩
+      have hdv : (derivative v).natDegree ≤ e' := by
+        have := natDegree_derivative_le v
+        omega
+      have hsplit : e + e = (e + 1) + e' := by omega
+      rw [hsplit, coeff_mul_add_eq_of_natDegree_le (le_of_eq hdeg) hdv, coeff_derivative, ← he']
+      rw [he']
+      push_cast
+      ring
+  intro h0
+  have h := congrArg (fun p : k[X] => p.coeff (e + e)) h0
+  simp only [coeff_sub, coeff_zero, h1, h2] at h
+  have hlead : u.coeff (e + 1) * v.coeff e = 0 := by linear_combination h
+  rcases mul_eq_zero.mp hlead with hcu | hcv
+  · exact (leadingCoeff_ne_zero.mpr hu) (by rw [leadingCoeff, hdeg]; exact hcu)
+  · exact (leadingCoeff_ne_zero.mpr hv) hcv
+
+end Wronskian
+
+section Finiteness
+
+variable {k : Type*} [Field k] {W : WeierstrassCurve k}
+
+lemma finite_setOf_X_eq (x₀ : k) :
+    {P : W.toAffine.Point | ∃ y : k, ∃ h : W.toAffine.Nonsingular x₀ y,
+      P = Point.some x₀ y h}.Finite := by
+  have hyfin : {y : k | W.toAffine.Nonsingular x₀ y}.Finite := by
+    by_cases hne : ∃ b : k, W.toAffine.Nonsingular x₀ b
+    · obtain ⟨b, hb⟩ := hne
+      refine Set.Finite.subset
+        ((Set.finite_singleton (W.toAffine.negY x₀ b)).insert b) (fun y hy => ?_)
+      have hyns : W.toAffine.Nonsingular x₀ y := hy
+      simp only [Set.mem_insert_iff, Set.mem_singleton_iff]
+      exact Y_eq_of_X_eq hyns.left hb.left rfl
+    · exact Set.Finite.subset Set.finite_empty (fun y hy => absurd ⟨y, hy⟩ hne)
+  have : Finite {y : k | W.toAffine.Nonsingular x₀ y} := hyfin.to_subtype
+  refine Set.Finite.subset (Set.finite_range
+    (fun z : {y : k | W.toAffine.Nonsingular x₀ y} =>
+      (Point.some x₀ z.1 z.2 : W.toAffine.Point))) ?_
+  rintro P ⟨y, hns, rfl⟩
+  exact ⟨⟨y, hns⟩, rfl⟩
+
+lemma finite_setOf_X_mem {T : Set k} (hT : T.Finite) :
+    {P : W.toAffine.Point | ∃ x ∈ T, ∃ y : k, ∃ h : W.toAffine.Nonsingular x y,
+      P = Point.some x y h}.Finite := by
+  refine Set.Finite.subset (hT.biUnion (fun x₀ _ => finite_setOf_X_eq (W := W) x₀)) ?_
+  rintro P ⟨x, hxT, y, h, rfl⟩
+  exact Set.mem_biUnion hxT ⟨y, h, rfl⟩
+
+end Finiteness
+
+section Reduced
+
+variable {k : Type*} [Field k]
+
+theorem exists_reduced_pair (p : k[X]) {q : k[X]} (hq : q ≠ 0) :
+    ∃ g h : k[X], IsCoprime g h ∧ h ≠ 0 ∧ g * q = p * h ∧
+      (p ≠ 0 → g ≠ 0 ∧ g.natDegree + q.natDegree = p.natDegree + h.natDegree) := by
+  set r : RatFunc k := algebraMap k[X] (RatFunc k) p / algebraMap k[X] (RatFunc k) q with hr
+  refine ⟨r.num, r.denom, RatFunc.isCoprime_num_denom r, RatFunc.denom_ne_zero r,
+    (RatFunc.num_mul_eq_mul_denom_iff hq).mpr hr, fun hp => ?_⟩
+  have hid : r.num * q = p * r.denom := (RatFunc.num_mul_eq_mul_denom_iff hq).mpr hr
+  have hr0 : r ≠ 0 := by
+    rw [hr]
+    exact div_ne_zero (RatFunc.algebraMap_ne_zero hp) (RatFunc.algebraMap_ne_zero hq)
+  have hnum : r.num ≠ 0 := RatFunc.num_ne_zero hr0
+  refine ⟨hnum, ?_⟩
+  have h := congrArg Polynomial.natDegree hid
+  rwa [natDegree_mul hnum hq, natDegree_mul hp (RatFunc.denom_ne_zero r)] at h
+
+end Reduced
+
+section Solver
+
+theorem solver (d : ℤ → ℤ) (q a : ℤ) (good : ℤ → Prop) (h0 : d 0 = q) (h1 : d 1 = 1 - a + q)
+    (hg0 : good 0) (hg1 : good 1) (hgood : ∀ n : ℤ, good n ∨ good (n - 1))
+    (R1 : ∀ n : ℤ, good n → d (n + 1) + d (n - 1) = 2 * d n + 2)
+    (R2 : ∀ n : ℤ, good n → d (n + 2) + d (n - 2) = 2 * d n + 8) :
+    ∀ n : ℕ, d n = (n : ℤ) ^ 2 - a * n + q := by
+  have hm1 : d (-1) = 1 + a + q := by
+    have h := R1 0 hg0
+    norm_num at h
+    rw [h0, h1] at h
+    linear_combination h
+  intro n
+  induction n using Nat.strong_induction_on with
+  | _ n ih =>
+    rcases Nat.lt_or_ge n 2 with hn | hn
+    · interval_cases n
+      · simp [h0]
+      · simp [h1]
+    rcases Nat.lt_or_ge n 4 with hn4 | hn4
+    · interval_cases n
+      · have h := R1 1 hg1
+        have e0 := ih 0 (by norm_num)
+        have e1 := ih 1 (by norm_num)
+        norm_num at h e0 e1 ⊢
+        linear_combination h + 2 * e1 - e0
+      · rcases hgood 2 with hg | hg
+        · have h := R1 2 hg
+          have e1 := ih 1 (by norm_num)
+          have e2 := ih 2 (by norm_num)
+          norm_num at h e1 e2 ⊢
+          linear_combination h + 2 * e2 - e1
+        · norm_num at hg
+          have h := R2 1 hg
+          have e1 := ih 1 (by norm_num)
+          norm_num at h e1 ⊢
+          rw [hm1] at h
+          linear_combination h + 2 * e1
+    · have key : ∀ j : ℕ, j < n → d (j : ℤ) = (j : ℤ) ^ 2 - a * j + q := fun j hj => ih j hj
+      rcases hgood ((n : ℤ) - 1) with hg | hg
+      · have h := R1 ((n : ℤ) - 1) hg
+        have e1 := key (n - 1) (by omega)
+        have e2 := key (n - 2) (by omega)
+        have c1 : ((n - 1 : ℕ) : ℤ) = (n : ℤ) - 1 := by omega
+        have c2 : ((n - 2 : ℕ) : ℤ) = (n : ℤ) - 2 := by omega
+        rw [c1] at e1
+        rw [c2] at e2
+        rw [show (n : ℤ) - 1 + 1 = n by ring, show (n : ℤ) - 1 - 1 = (n : ℤ) - 2 by ring] at h
+        linear_combination h + 2 * e1 - e2
+      · rw [show (n : ℤ) - 1 - 1 = (n : ℤ) - 2 by ring] at hg
+        have h := R2 ((n : ℤ) - 2) hg
+        have e2 := key (n - 2) (by omega)
+        have e4 := key (n - 4) (by omega)
+        have c2 : ((n - 2 : ℕ) : ℤ) = (n : ℤ) - 2 := by omega
+        have c4 : ((n - 4 : ℕ) : ℤ) = (n : ℤ) - 4 := by omega
+        rw [c2] at e2
+        rw [c4] at e4
+        rw [show (n : ℤ) - 2 + 2 = n by ring, show (n : ℤ) - 2 - 2 = (n : ℤ) - 4 by ring] at h
+        linear_combination h + 2 * e2 - e4
+
+end Solver
+
+section Curve
+
+variable {k : Type*} [Field k] {W : WeierstrassCurve k}
+
+lemma evalEval_eq_of_mk_eq {p p' : k[X][Y]}
+    (hmk : Affine.CoordinateRing.mk W p = Affine.CoordinateRing.mk W p') {x y : k}
+    (h : W.toAffine.Equation x y) : p.evalEval x y = p'.evalEval x y := by
+  obtain ⟨r, hr⟩ := AdjoinRoot.mk_eq_mk.mp hmk
+  have h0 : W.toAffine.polynomial.evalEval x y = 0 := h
+  have h1 : (p - p').evalEval x y = 0 := by
+    rw [hr, evalEval_mul, h0, zero_mul]
+  rwa [evalEval_sub, sub_eq_zero] at h1
+
+lemma evalEval_ψ_sq {x y : k} (h : W.toAffine.Equation x y) (n : ℤ) :
+    (W.ψ n).evalEval x y ^ 2 = (W.ΨSq n).eval x := by
+  have hmk : Affine.CoordinateRing.mk W (W.ψ n ^ 2) = Affine.CoordinateRing.mk W (C (W.ΨSq n)) := by
+    rw [map_pow, Affine.CoordinateRing.mk_ψ, Affine.CoordinateRing.mk_Ψ_sq]
+  have h1 := evalEval_eq_of_mk_eq hmk h
+  rwa [evalEval_pow, evalEval_C] at h1
+
+lemma evalEval_φ {x y : k} (h : W.toAffine.Equation x y) (n : ℤ) :
+    (W.φ n).evalEval x y = (W.Φ n).eval x := by
+  have h1 := evalEval_eq_of_mk_eq (Affine.CoordinateRing.mk_φ (W := W) n) h
+  rwa [evalEval_C] at h1
+
+lemma exists_nonsingular [IsAlgClosed k] [W.IsElliptic] (x : k) :
+    ∃ y : k, W.toAffine.Nonsingular x y := by
+  obtain ⟨y, hy⟩ := IsAlgClosed.exists_root
+    (C 1 * X ^ 2 + C (W.a₁ * x + W.a₃) * X +
+      C (-(x ^ 3 + W.a₂ * x ^ 2 + W.a₄ * x + W.a₆)))
+    (natDegree_pos_iff_degree_pos.mp (by rw [natDegree_quadratic one_ne_zero]; norm_num)).ne'
+  refine ⟨y, (equation_iff_nonsingular (W := W)).mp ((W.toAffine.equation_iff x y).mpr ?_)⟩
+  simp only [IsRoot, eval_add, eval_mul, eval_pow, eval_C, eval_X, one_mul] at hy
+  linear_combination hy
+
+lemma zsmul_x_mul_ΨSq [DecidableEq k] [W.IsElliptic] (n : ℤ) {x y : k}
+    (h : W.toAffine.Nonsingular x y) {x' y' : k} (h' : W.toAffine.Nonsingular x' y')
+    (hn : n • Point.some x y h = Point.some x' y' h') :
+    x' * (W.ΨSq n).eval x = (W.Φ n).eval x := by
+  have key := WeierstrassCurve.Affine.Point.zsmul_x_mul_psi_sq W n h h' hn
+  rwa [evalEval_ψ_sq h.left, evalEval_φ h.left] at key
+
+end Curve
+
+section Collision
+
+variable {k : Type*} [Field k] (W : WeierstrassCurve k)
+
+lemma ΨSq_ne_zero_of_isCoprime {n : ℤ} (hn : n ≠ 0) (hcop : IsCoprime (W.Φ n) (W.ΨSq n)) :
+    W.ΨSq n ≠ 0 := by
+  intro h0
+  rw [h0, isCoprime_zero_right] at hcop
+  have hdeg := natDegree_eq_zero_of_isUnit hcop
+  rw [WeierstrassCurve.natDegree_Φ] at hdeg
+  exact hn (Int.natAbs_eq_zero.mp (pow_eq_zero_iff two_ne_zero |>.mp hdeg))
+
+lemma collision_ne_zero {q : ℕ} (hq : q.Prime) (n : ℤ) (hcop : IsCoprime (W.Φ n) (W.ΨSq n)) :
+    W.Φ n - X ^ q * W.ΨSq n ≠ 0 := by
+  intro h0
+  rw [sub_eq_zero] at h0
+  have hdvd : W.ΨSq n ∣ W.Φ n := ⟨X ^ q, by rw [h0, mul_comm]⟩
+  have hunit : IsUnit (W.ΨSq n) := hcop.isUnit_of_dvd' hdvd (dvd_refl _)
+  have hΨdeg : (W.ΨSq n).natDegree = 0 := natDegree_eq_zero_of_isUnit hunit
+  have hdeg := congrArg Polynomial.natDegree h0
+  rw [WeierstrassCurve.natDegree_Φ, natDegree_mul (pow_ne_zero _ X_ne_zero) hunit.ne_zero,
+    natDegree_pow, natDegree_X, mul_one, hΨdeg, add_zero] at hdeg
+  have hsq : n.natAbs * n.natAbs = q := by rw [← sq]; exact hdeg
+  rcases hq.eq_one_or_self_of_dvd n.natAbs ⟨n.natAbs, hsq.symm⟩ with h | h
+  · rw [h, mul_one] at hsq
+    exact hq.one_lt.ne hsq
+  · rw [h] at hsq
+    have h2 := hq.two_le
+    nlinarith
+
+lemma natDegree_collision {q : ℕ} (hq : 2 ≤ q) {n : ℤ} (hnk : (n : k) ≠ 0) :
+    (W.Φ n - X ^ q * W.ΨSq n).natDegree = q + n.natAbs ^ 2 - 1 := by
+  have hn : n ≠ 0 := by
+    rintro rfl
+    exact hnk (by simp)
+  have hn1 : 1 ≤ n.natAbs ^ 2 := Nat.one_le_pow _ _ (Int.natAbs_pos.mpr hn)
+  have hΨ0 : W.ΨSq n ≠ 0 := WeierstrassCurve.ΨSq_ne_zero _ hnk
+  have hdeg2 : (X ^ q * W.ΨSq n).natDegree = q + n.natAbs ^ 2 - 1 := by
+    rw [natDegree_mul (pow_ne_zero _ X_ne_zero) hΨ0, natDegree_pow, natDegree_X, mul_one,
+      WeierstrassCurve.natDegree_ΨSq _ hnk]
+    omega
+  have hlt : (W.Φ n).natDegree < (X ^ q * W.ΨSq n).natDegree := by
+    rw [hdeg2, WeierstrassCurve.natDegree_Φ]
+    omega
+  rw [natDegree_sub_eq_right_of_natDegree_lt hlt, hdeg2]
+
+end Collision
+
+section Bad
+
+variable {k : Type*} [Field k] (W : WeierstrassCurve k) (q : ℕ)
+
+def bad (n : ℤ) : Set k :=
+  {x | W.Ψ₂Sq.eval x = 0 ∨ (n ≠ 0 ∧ ((W.ΨSq n).eval x = 0 ∨ (W.Φ n - X ^ q * W.ΨSq n).eval x = 0))}
+
+lemma not_mem_bad_iff {n : ℤ} {x : k} : x ∉ bad W q n ↔
+    W.Ψ₂Sq.eval x ≠ 0 ∧ (n ≠ 0 → (W.ΨSq n).eval x ≠ 0 ∧ (W.Φ n - X ^ q * W.ΨSq n).eval x ≠ 0) := by
+  simp only [bad, Set.mem_ofPred_eq, not_or, not_and, ne_eq]
+
+lemma finite_setOf_eval_eq_zero {p : k[X]} (hp : p ≠ 0) : {x : k | p.eval x = 0}.Finite :=
+  Polynomial.finite_setOfPred_isRoot hp
+
+lemma bad_finite (hq : q.Prime) (hcop : ∀ n : ℤ, IsCoprime (W.Φ n) (W.ΨSq n))
+    (n : ℤ) : (bad W q n).Finite := by
+  have hΨ₂ : W.Ψ₂Sq ≠ 0 := by
+    rw [← WeierstrassCurve.ΨSq_two]
+    exact ΨSq_ne_zero_of_isCoprime W two_ne_zero (hcop 2)
+  by_cases hn : n = 0
+  · refine (finite_setOf_eval_eq_zero hΨ₂).subset ?_
+    rintro x (hx | ⟨hn', _⟩)
+    · exact hx
+    · exact absurd hn hn'
+  · refine (((finite_setOf_eval_eq_zero hΨ₂).union
+      (finite_setOf_eval_eq_zero (ΨSq_ne_zero_of_isCoprime W hn (hcop n)))).union
+      (finite_setOf_eval_eq_zero (collision_ne_zero W hq n (hcop n)))).subset ?_
+    rintro x (hx | ⟨_, hx | hx⟩)
+    · exact Or.inl (Or.inl hx)
+    · exact Or.inl (Or.inr hx)
+    · exact Or.inr hx
+
+end Bad
+
+section Frobenius
+
+variable {R : Type*} [CommRing R] {F : Type*} [Field F] {k : Type*} [Field k]
+  [DecidableEq k] [Algebra R F] [Algebra R k] [Algebra F k] [IsScalarTower R F k]
+  (W : WeierstrassCurve R) (σ : k ≃ₐ[F] k)
+
+lemma linePencil_frobEnd_apply (n : ℤ) (P : (W⁄k).Point) :
+    linePencil (frobEnd W σ) n 1 P = n • P - σ • P := by
+  rw [linePencil_apply, frobEnd_apply, one_zsmul]
+
+lemma linePencil_frobEnd_add (n j : ℤ) (P : (W⁄k).Point) :
+    linePencil (frobEnd W σ) (n + j) 1 P = linePencil (frobEnd W σ) n 1 P + j • P := by
+  rw [linePencil_frobEnd_apply, linePencil_frobEnd_apply, add_zsmul]
+  abel
+
+lemma linePencil_frobEnd_sub (n j : ℤ) (P : (W⁄k).Point) :
+    linePencil (frobEnd W σ) (n - j) 1 P = linePencil (frobEnd W σ) n 1 P - j • P := by
+  rw [linePencil_frobEnd_apply, linePencil_frobEnd_apply, sub_zsmul]
+  abel
+
+variable [Fintype F]
+
+lemma smul_some (hσ : ∀ x : k, σ x = x ^ Fintype.card F) (x y : k) (h : (W⁄k).Nonsingular x y) :
+    ∃ (x₁ y₁ : k) (h₁ : (W⁄k).Nonsingular x₁ y₁),
+      σ • (Point.some x y h : (W⁄k).Point) = Point.some x₁ y₁ h₁ ∧ x₁ = x ^ Fintype.card F := by
+  have e : σ • (Point.some x y h : (W⁄k).Point) = Point.map σ.toAlgHom (Point.some x y h) := rfl
+  rw [Point.map_some] at e
+  exact ⟨_, _, _, e, hσ x⟩
+
+structure IsMember (n : ℤ) (u v : k[X]) : Prop where
+  cop : IsCoprime u v
+  v_ne : v ≠ 0
+  deg : (n : k) ≠ 0 → u.natDegree = v.natDegree + 1
+  deg0 : n = 0 → u.natDegree = Fintype.card F ∧ v.natDegree = 0
+  ident : ∀ {x y : k} (h : (W⁄k).Nonsingular x y), x ∉ bad (W⁄k) (Fintype.card F) n →
+    ∃ (x' y' : k) (h' : (W⁄k).Nonsingular x' y'),
+      linePencil (frobEnd W σ) n 1 (Point.some x y h) = Point.some x' y' h' ∧
+        x' * v.eval x = u.eval x
+
+lemma IsMember.u_ne {n : ℤ} {u v : k[X]} (hmem : IsMember W σ n u v)
+    (hgood : (n : k) ≠ 0 ∨ n = 0) (hq : 2 ≤ Fintype.card F)
+    : u ≠ 0 ∧ v.natDegree ≤ u.natDegree := by
+  rcases hgood with hg | hg
+  · have h := hmem.deg hg
+    refine ⟨fun h0 => ?_, by omega⟩
+    rw [h0, natDegree_zero] at h
+    omega
+  · obtain ⟨hu, hv⟩ := hmem.deg0 hg
+    refine ⟨fun h0 => ?_, by omega⟩
+    rw [h0, natDegree_zero] at hu
+    omega
+
+variable [IsAlgClosed k] [(W⁄k).IsElliptic]
+
+theorem exists_isMember (hσ : ∀ x : k, σ x = x ^ Fintype.card F) (hF : (Fintype.card F).Prime)
+    (htor : ∀ (n : ℤ) {x y : k} (h : (W⁄k).Nonsingular x y),
+      n • Point.some x y h = 0 → ((W⁄k).ΨSq n).eval x = 0)
+    (hcop : ∀ n : ℤ, IsCoprime ((W⁄k).Φ n) ((W⁄k).ΨSq n)) (n : ℤ) :
+    ∃ u v : k[X], IsMember W σ n u v := by
+  by_cases hn : n = 0
+  · subst hn
+    refine ⟨X ^ Fintype.card F, 1, isCoprime_one_right, one_ne_zero, fun h => (h (by simp)).elim,
+      fun _ => ⟨natDegree_X_pow _, natDegree_one⟩, ?_⟩
+    · intro x y h _
+      obtain ⟨x₁, y₁, h₁, hsm, hx₁⟩ := smul_some W σ hσ x y h
+      have hA : linePencil (frobEnd W σ) 0 1 (Point.some x y h) = -(σ • Point.some x y h) := by
+        rw [linePencil_frobEnd_apply, zero_zsmul, zero_sub]
+      rw [hsm, Affine.Point.neg_some] at hA
+      exact ⟨_, _, _, hA, by rw [eval_one, mul_one, eval_pow, eval_X, hx₁]⟩
+  · have hq2 : 2 ≤ Fintype.card F := hF.two_le
+    have hΨn : (W⁄k).ΨSq n ≠ 0 := ΨSq_ne_zero_of_isCoprime (W⁄k) hn (hcop n)
+    have hCn : (W⁄k).Φ n - X ^ Fintype.card F * (W⁄k).ΨSq n ≠ 0 :=
+      collision_ne_zero (W⁄k) hF n (hcop n)
+    have hfin : {x : k | ∃ (y : k) (h : (W⁄k).Nonsingular x y), n • Point.some x y h = 0}.Finite :=
+      by
+      refine (finite_setOf_eval_eq_zero hΨn).subset ?_
+      rintro x ⟨y, h, h0⟩
+      exact htor n h h0
+    obtain ⟨U, hUdeg, hU⟩ :=
+      FrobeniusEndo.exists_x_linePencil_frobEnd_mul_collision_sq W σ hσ n hfin
+    obtain ⟨u, v, hcopuv, hv0, hid, hdeg⟩ := exists_reduced_pair U (pow_ne_zero 2 hCn)
+    refine ⟨u, v, hcopuv, hv0, fun hnk => ?_, fun h0 => absurd h0 hn, ?_⟩
+    · have hUd := hUdeg hnk
+      have hn1 : 1 ≤ n.natAbs ^ 2 := Nat.one_le_pow _ _ (Int.natAbs_pos.mpr hn)
+      have hU0 : U ≠ 0 := fun h0 => by
+        rw [h0, natDegree_zero] at hUd
+        omega
+      have h := (hdeg hU0).2
+      rw [natDegree_pow, natDegree_collision (W⁄k) hq2 hnk, hUd] at h
+      omega
+    · intro x y h hx
+      rw [not_mem_bad_iff] at hx
+      obtain ⟨hΨ₂x, hx2⟩ := hx
+      obtain ⟨hΨx, hCx⟩ := hx2 hn
+      have hnP : n • (Point.some x y h : (W⁄k).Point) ≠ 0 := fun h0 => hΨx (htor n h h0)
+      rcases hnP_eq : n • (Point.some x y h : (W⁄k).Point) with _ | ⟨x₁, y₁, h₁⟩
+      · exact absurd hnP_eq hnP
+      obtain ⟨hA0, hAx⟩ := hU h h₁ hnP_eq hΨx hCx hΨ₂x
+      rcases hA_eq : linePencil (frobEnd W σ) n 1 (Point.some x y h) with _ | ⟨x', y', h'⟩
+      · exact absurd hA_eq hA0
+      refine ⟨x', y', h', rfl, ?_⟩
+      have hAx' := hAx h' hA_eq
+      have hidx := congrArg (Polynomial.eval x) hid
+      simp only [eval_mul, eval_pow] at hidx
+      have key : (x' * v.eval x) * ((W⁄k).Φ n - X ^ Fintype.card F * (W⁄k).ΨSq n).eval x ^ 2
+          = u.eval x * ((W⁄k).Φ n - X ^ Fintype.card F * (W⁄k).ΨSq n).eval x ^ 2 := by
+        linear_combination (v.eval x) * hAx' - hidx
+      exact mul_right_cancel₀ (pow_ne_zero 2 hCx) key
+
+theorem step (hF : (Fintype.card F).Prime)
+    (htor : ∀ (n : ℤ) {x y : k} (h : (W⁄k).Nonsingular x y),
+      n • Point.some x y h = 0 → ((W⁄k).ΨSq n).eval x = 0)
+    (hcop : ∀ n : ℤ, IsCoprime ((W⁄k).Φ n) ((W⁄k).ΨSq n))
+    (u v : ℤ → k[X]) (hmem : ∀ n, IsMember W σ n (u n) (v n))
+    {n j : ℤ} (hj : j ≠ 0) (hgood : (n : k) ≠ 0 ∨ n = 0) :
+    (u (n + j)).natDegree + (u (n - j)).natDegree = 2 * ((u n).natDegree + j.natAbs ^ 2) := by
+  have hq2 : 2 ≤ Fintype.card F := hF.two_le
+  obtain ⟨hu0, hvu⟩ := IsMember.u_ne W σ (hmem n) hgood hq2
+  have hΨj : (W⁄k).ΨSq j ≠ 0 := ΨSq_ne_zero_of_isCoprime (W⁄k) hj (hcop j)
+  have hts : ((W⁄k).ΨSq j).natDegree < ((W⁄k).Φ j).natDegree := by
+    have h1 := WeierstrassCurve.natDegree_ΨSq_le (W⁄k) j
+    have h2 : 1 ≤ j.natAbs ^ 2 := Nat.one_le_pow _ _ (Int.natAbs_pos.mpr hj)
+    rw [WeierstrassCurve.natDegree_Φ]
+    omega
+  set S : Set k := ((bad (W⁄k) (Fintype.card F) n ∪ bad (W⁄k) (Fintype.card F) (n + j)) ∪
+      bad (W⁄k) (Fintype.card F) (n - j)) ∪ {x | ((W⁄k).ΨSq j).eval x = 0} with hS
+  have hSfin : S.Finite :=
+    (((bad_finite (W⁄k) _ hF hcop n).union (bad_finite (W⁄k) _ hF hcop (n + j))).union
+      (bad_finite (W⁄k) _ hF hcop (n - j))).union (finite_setOf_eval_eq_zero hΨj)
+  obtain ⟨-, -, hdeg, -⟩ := WeierstrassCurve.Affine.Point.natDegree_parallelogram_law (W⁄k) hSfin
+    (hmem n).cop (hcop j) (hmem (n + j)).cop (hmem (n - j)).cop hu0 (hmem n).v_ne hΨj
+    (hmem (n + j)).v_ne (hmem (n - j)).v_ne hvu hts (fun x hxS => by
+      simp only [hS, Set.mem_union, Set.mem_ofPred_eq, not_or] at hxS
+      obtain ⟨⟨⟨hxn, hxp⟩, hxm⟩, hΨjx⟩ := hxS
+      obtain ⟨y, h⟩ := exists_nonsingular (W := W⁄k) x
+      obtain ⟨xa, ya, ha, hAeq, hAid⟩ := (hmem n).ident h hxn
+      have hjP : j • (Point.some x y h : (W⁄k).Point) ≠ 0 := fun h0 => hΨjx (htor j h h0)
+      rcases hB : j • (Point.some x y h : (W⁄k).Point) with _ | ⟨xb, yb, hb⟩
+      · exact absurd hB hjP
+      have hBid : xb * ((W⁄k).ΨSq j).eval x = ((W⁄k).Φ j).eval x := zsmul_x_mul_ΨSq j h hb hB
+      obtain ⟨xp, yp, hp, hPeq, hPid⟩ := (hmem (n + j)).ident h hxp
+      obtain ⟨xm, ym, hm, hMeq, hMid⟩ := (hmem (n - j)).ident h hxm
+      refine ⟨xa, ya, xb, yb, xp, yp, xm, ym, ha, hb, hp, hm, ?_, ?_, hAid, hBid, hPid, hMid⟩
+      · rw [← hAeq, ← hB, ← hPeq, linePencil_frobEnd_add]
+      · rw [← hAeq, ← hB, ← hMeq, linePencil_frobEnd_sub])
+  rw [WeierstrassCurve.natDegree_Φ] at hdeg
+  exact hdeg
+
+theorem card_ker_eq (hF : (Fintype.card F).Prime)
+    (hcop : ∀ n : ℤ, IsCoprime ((W⁄k).Φ n) ((W⁄k).ΨSq n))
+    {m : ℤ} (hmk : (m : k) ≠ 0) {u v : k[X]} (hmem : IsMember W σ m u v) :
+    Nat.card (linePencil (frobEnd W σ) m 1).ker = u.natDegree := by
+  have hdeg := hmem.deg hmk
+  set B : Set (W⁄k).Point := {P | ∃ x ∈ bad (W⁄k) (Fintype.card F) m, ∃ y : k,
+    ∃ h : (W⁄k).Nonsingular x y, P = Point.some x y h} with hB
+  have hBfin : B.Finite := finite_setOf_X_mem (W := W⁄k) (bad_finite (W⁄k) _ hF hcop m)
+  have key := WeierstrassCurve.Affine.Point.card_ker_eq_max_natDegree (W⁄k)
+    (linePencil (frobEnd W σ) m 1) hBfin hmem.cop
+    (wronskian_ne_zero_of_natDegree_eq_succ hmem.v_ne hdeg)
+    (fun {x y} hP hPB _ => by
+      have hx : x ∉ bad (W⁄k) (Fintype.card F) m := fun hx => hPB ⟨x, hx, y, hP, rfl⟩
+      obtain ⟨x', y', h', hAeq, -⟩ := hmem.ident hP hx
+      rw [hAeq]
+      exact Point.some_ne_zero _)
+    (fun {x y} hP {x' y'} hP' hPB heq => by
+      have hx : x ∉ bad (W⁄k) (Fintype.card F) m := fun hx => hPB ⟨x, hx, y, hP, rfl⟩
+      obtain ⟨x'', y'', h'', hAeq, hid⟩ := hmem.ident hP hx
+      rw [hAeq] at heq
+      rw [← (Point.some.inj heq).1]
+      exact hid)
+  rw [key, hdeg]
+  exact max_eq_left (Nat.le_succ _)
+
+theorem main (hσ : ∀ x : k, σ x = x ^ Fintype.card F) (hF : (Fintype.card F).Prime)
+    (htor : ∀ (n : ℤ) {x y : k} (h : (W⁄k).Nonsingular x y),
+      n • Point.some x y h = 0 → ((W⁄k).ΨSq n).eval x = 0)
+    (hcop : ∀ n : ℤ, IsCoprime ((W⁄k).Φ n) ((W⁄k).ΨSq n)) (m : ℕ) (hm : 1 ≤ m)
+    (hmk : (m : k) ≠ 0) :
+    0 < kerDeg (frobEnd W σ) m 1 ∧
+      ((kerDeg (frobEnd W σ) m 1 : ℕ) : ℤ)
+        = (m : ℤ) ^ 2 - ((Fintype.card F : ℤ) + 1 - kerDeg (frobEnd W σ) 1 1) * m
+          + Fintype.card F := by
+  have _hm := hm
+  choose u v hmem using exists_isMember W σ hσ hF htor hcop
+  set d : ℤ → ℤ := fun n => ((u n).natDegree : ℤ) with hd
+  set good : ℤ → Prop := fun n => (n : k) ≠ 0 ∨ n = 0 with hgood_def
+  have hgood : ∀ n : ℤ, good n ∨ good (n - 1) := by
+    intro n
+    by_cases h : (n : k) = 0
+    · right
+      left
+      rw [Int.cast_sub, Int.cast_one, h, zero_sub]
+      exact neg_ne_zero.mpr one_ne_zero
+    · exact Or.inl (Or.inl h)
+  have R1 : ∀ n : ℤ, good n → d (n + 1) + d (n - 1) = 2 * d n + 2 := by
+    intro n hg
+    have h := step W σ hF htor hcop u v hmem one_ne_zero hg
+    simp only [hd]
+    norm_num at h
+    exact_mod_cast (by omega : (u (n + 1)).natDegree + (u (n - 1)).natDegree
+      = 2 * (u n).natDegree + 2)
+  have R2 : ∀ n : ℤ, good n → d (n + 2) + d (n - 2) = 2 * d n + 8 := by
+    intro n hg
+    have h := step W σ hF htor hcop u v hmem two_ne_zero hg
+    simp only [hd]
+    norm_num at h
+    exact_mod_cast (by omega : (u (n + 2)).natDegree + (u (n - 2)).natDegree
+      = 2 * (u n).natDegree + 8)
+  have h0 : d 0 = Fintype.card F := by
+    simp only [hd]
+    exact_mod_cast ((hmem 0).deg0 rfl).1
+  have hE1 : kerDeg (frobEnd W σ) 1 1 = (u 1).natDegree := by
+    rw [kerDeg_def]
+    exact card_ker_eq W σ hF hcop (by simp) (hmem 1)
+  have h1 : d 1 = 1 - ((Fintype.card F : ℤ) + 1 - kerDeg (frobEnd W σ) 1 1) + Fintype.card F := by
+    simp only [hd, hE1]
+    ring
+  have hsol := solver d (Fintype.card F) _ good h0 h1 (Or.inr rfl) (Or.inl (by simp)) hgood R1 R2 m
+  have hmk' : ((m : ℤ) : k) ≠ 0 := by rwa [Int.cast_natCast]
+  have hEm : kerDeg (frobEnd W σ) m 1 = (u m).natDegree := by
+    rw [kerDeg_def]
+    exact card_ker_eq W σ hF hcop hmk' (hmem m)
+  refine ⟨?_, ?_⟩
+  · rw [hEm, (hmem m).deg hmk']
+    exact Nat.succ_pos _
+  · rw [hEm]
+    simpa only [hd] using hsol
+
+end Frobenius
+
+end M4cP4H4
+
+theorem solution {R : Type*} [CommRing R] {F : Type*} [Field F] [Fintype F] {k : Type*} [Field k]
+  [DecidableEq k] [Algebra R F] [Algebra R k] [Algebra F k] [IsScalarTower R F k] [IsAlgClosed k] (W
+  : WeierstrassCurve R) [(W⁄k).IsElliptic] (σ : k ≃ₐ[F] k) (hσ : ∀ x : k, σ x = x ^ Fintype.card F)
+  (hF : (Fintype.card F).Prime) (htor : ∀ (n : ℤ) {x y : k} (h : (W⁄k).Nonsingular x y), n •
+  Point.some x y h = 0 → ((W⁄k).ΨSq n).eval x = 0) (hcop : ∀ n : ℤ, IsCoprime ((W⁄k).Φ n) ((W⁄k).ΨSq
+  n)) (m : ℕ) (hm : 1 ≤ m) (hmk : (m : k) ≠ 0) :
+    0 < kerDeg (frobEnd W σ) m 1 ∧ ((kerDeg (frobEnd W σ) m 1 : ℕ) : ℤ) = (m : ℤ) ^ 2 -
+      ((Fintype.card F : ℤ) + 1 - kerDeg (frobEnd W σ) 1 1) * m + Fintype.card F :=
+  M4cP4H4.main W σ hσ hF htor hcop m hm hmk
+
+end S_FrobeniusEndo_kerDeg_frobEnd_line_one_pos_and_eq_of_torsion
+end P2MW
+export P2MW.S_FrobeniusEndo_kerDeg_frobEnd_line_one_pos_and_eq_of_torsion (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo
+
+theorem FrobeniusEndo.kerDeg_frobEnd_line_one_pos_and_eq_of_torsion {R : Type*} [CommRing R] {F :
+  Type*} [Field F] [Fintype F] {k : Type*} [Field k] [DecidableEq k] [Algebra R F] [Algebra R k]
+  [Algebra F k] [IsScalarTower R F k] [IsAlgClosed k] (W : WeierstrassCurve R) [(W⁄k).IsElliptic] (σ
+  : k ≃ₐ[F] k) (hσ : ∀ x : k, σ x = x ^ Fintype.card F) (hF : (Fintype.card F).Prime) (htor : ∀ (n :
+  ℤ) {x y : k} (h : (W⁄k).Nonsingular x y), n • Point.some x y h = 0 → ((W⁄k).ΨSq n).eval x = 0)
+  (hcop : ∀ n : ℤ, IsCoprime ((W⁄k).Φ n) ((W⁄k).ΨSq n)) (m : ℕ) (hm : 1 ≤ m) (hmk : (m : k) ≠ 0) :
+    0 < kerDeg (frobEnd W σ) m 1 ∧ ((kerDeg (frobEnd W σ) m 1 : ℕ) : ℤ) = (m : ℤ) ^ 2 -
+      ((Fintype.card F : ℤ) + 1 - kerDeg (frobEnd W σ) 1 1) * m + Fintype.card F :=
+  solution W σ hσ hF htor hcop m hm hmk
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_kerDeg_frobEnd_one_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_kerDeg_frobEnd_one_one.lean
new file mode 100644
index 0000000000..b8a5f6e3a5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_kerDeg_frobEnd_one_one.lean
@@ -0,0 +1,174 @@
+/-
+Based on Prove2Me node FrobeniusEndo.kerDeg_frobEnd_one_one
+(f80fdb69-f763-5aae-bae4-cbef67a52b76) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 96c84609-19f0-5f5c-8031-12c9f7ec9ca4
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusEndo
+public import Mathlib.FieldTheory.Finite.Basic
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Fixed points of the q-power Frobenius are the F-rational points
+
+Theorem statement: `FrobeniusEndo.kerDeg_frobEnd_one_one` (`f80fdb69-f763-5aae-bae4-cbef67a52b76`),
+by Claude, 2026-09-05.
+
+Proof: submission `96c84609-19f0-5f5c-8031-12c9f7ec9ca4`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring, $F$ a finite field, $k$ a field, and suppose $F$ and $k$ are
+$R$-algebras, $k$ an $F$-algebra, with the scalar tower condition relating the three structure maps.
+Let $W$ be a Weierstrass curve over $R$ and let $\sigma$ be an $F$-algebra automorphism of $k$
+satisfying $\sigma(x) = x^{\#F}$ for every $x \in k$. Write $(W\!\mathbin{/}k).\mathrm{Point}$ for
+the group of points of the affine curve obtained from $W$ by base change to $k$ (the point at
+infinity together with the nonsingular affine solutions), and let `frobEnd W σ` be the additive
+endomorphism of this group induced by the coordinatewise action of $\sigma$. Then the number `kerDeg
+(frobEnd W σ) 1 1`, defined as $\mathrm{Nat.card}$ of the kernel of the endomorphism $1 \cdot
+\mathrm{id} - 1 \cdot \mathrm{frobEnd}$, equals $\mathrm{Nat.card}$ of
+$(W\!\mathbin{/}F).\mathrm{Point}$, the group of points of the base change of $W$ to $F$. No
+nonsingularity hypothesis on $W$ is imposed; both sides count the point at infinity.
+
+This is the classical identity $E(\mathbb{F}_q) = \ker(1 - \pi_q)$ on the $k$-points of a curve over
+a finite field: the points fixed by the $q$-power Frobenius are exactly those with coordinates in
+$\mathbb{F}_q$. It serves as the $m = 1$ anchor for the computation of $\#\ker(m - \pi)$ in the
+pencil $m \cdot \mathrm{id} - n \cdot \pi$, and is used downstream in the identification of the
+trace of Frobenius on the Tate module with $\#F + 1 - \#(W\!\mathbin{/}F).\mathrm{Point}$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_FrobeniusEndo_kerDeg_frobEnd_one_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_FrobeniusEndo_kerDeg_frobEnd_one_one
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo
+
+namespace M4Wiles
+namespace T2
+
+variable {R : Type*} [CommRing R] {F : Type*} [Field F] [Fintype F] {k : Type*} [Field k]
+    [DecidableEq k]
+  [Algebra R F] [Algebra R k] [Algebra F k] [IsScalarTower R F k]
+
+omit [CommRing R] [Algebra R F] [Algebra R k] [IsScalarTower R F k] in
+open Polynomial in
+omit [DecidableEq k] in
+theorem pow_card_eq_self_iff (x : k) : x ^ Fintype.card F = x ↔ x ∈ Set.range (algebraMap F k) := by
+  classical
+  constructor
+  · intro hx
+    set q := Fintype.card F with hq
+    have hq1 : 1 < q := Fintype.one_lt_card
+    set f : k[X] := X ^ q - X with hf
+    have hf0 : f ≠ 0 := FiniteField.X_pow_card_sub_X_ne_zero k hq1
+    set T : Finset k := Finset.univ.image (algebraMap F k) with hT
+    have hTcard : T.card = q := by
+      rw [hT, Finset.card_image_of_injective _ (algebraMap F k).injective, Finset.card_univ]
+    have hTroots : T ⊆ f.roots.toFinset := by
+      intro y hy
+      obtain ⟨a, -, rfl⟩ := Finset.mem_image.mp hy
+      rw [Multiset.mem_toFinset, mem_roots hf0, IsRoot, hf, eval_sub, eval_pow, eval_X, ← map_pow,
+        FiniteField.pow_card, sub_self]
+    have hle : f.roots.toFinset.card ≤ q :=
+      (Multiset.toFinset_card_le _).trans ((card_roots' f).trans_eq
+        (FiniteField.X_pow_card_sub_X_natDegree_eq k hq1))
+    have heq : T = f.roots.toFinset :=
+      Finset.eq_of_subset_of_card_le hTroots (hle.trans_eq hTcard.symm)
+    have hxroot : x ∈ f.roots.toFinset := by
+      rw [Multiset.mem_toFinset, mem_roots hf0, IsRoot, hf, eval_sub, eval_pow, eval_X, hx,
+        sub_self]
+    rw [← heq, hT, Finset.mem_image] at hxroot
+    obtain ⟨a, -, ha⟩ := hxroot
+    exact ⟨a, ha⟩
+  · rintro ⟨a, rfl⟩
+    rw [← map_pow, FiniteField.pow_card]
+
+variable [DecidableEq F] (W : WeierstrassCurve R) (σ : k ≃ₐ[F] k)
+
+omit [Fintype F] in
+lemma smul_baseChange (P : (W⁄F).Point) :
+    σ • (Point.baseChange F k P) = Point.baseChange F k P := by
+  rw [algEquiv_smul_def]
+  exact map_baseChange (W' := W) σ.toAlgHom P
+
+variable {W σ}
+
+lemma exists_baseChange_eq_of_smul_eq (hσ : ∀ x : k, σ x = x ^ Fintype.card F)
+    {P : (W⁄k).Point} (hP : σ • P = P) : ∃ Q : (W⁄F).Point, Point.baseChange F k Q = P := by
+  rcases P with _ | ⟨x, y, h⟩
+  · exact ⟨0, rfl⟩
+  · have hxy : σ x = x ∧ σ y = y := by
+      rw [algEquiv_smul_def, map_some] at hP
+      simp only [some.injEq] at hP
+      exact hP
+    obtain ⟨a, ha⟩ := (pow_card_eq_self_iff x).mp (by rw [← hσ, hxy.1])
+    obtain ⟨b, hb⟩ := (pow_card_eq_self_iff y).mp (by rw [← hσ, hxy.2])
+    subst ha hb
+    have h' : (W⁄F).Nonsingular a b :=
+      (W.toAffine.baseChange_nonsingular (Algebra.ofId F k).injective (x := a) (y := b)).mp h
+    exact ⟨Point.some a b h', by rw [Point.baseChange, map_some]; rfl⟩
+
+variable (W σ)
+
+omit [DecidableEq F] in
+theorem kerDeg_one_one (hσ : ∀ x : k, σ x = x ^ Fintype.card F) :
+    kerDeg (frobEnd W σ) 1 1 = Nat.card (W⁄F).Point := by
+  classical
+  rw [kerDeg_def]
+  have hmem : ∀ P : (W⁄k).Point, P ∈ (linePencil (frobEnd W σ) 1 1).ker ↔ σ • P = P := by
+    intro P
+    rw [mem_ker_linePencil_iff, one_smul, one_smul, frobEnd_apply, eq_comm]
+  refine Nat.card_congr (Equiv.ofBijective
+    (fun Q : (W⁄F).Point => (⟨Point.baseChange F k Q, (hmem _).mpr (smul_baseChange W σ Q)⟩ :
+      (linePencil (frobEnd W σ) 1 1).ker)) ⟨?_, ?_⟩).symm
+  · intro Q₁ Q₂ hQ
+    exact map_injective (W' := W) (Algebra.ofId F k) (congrArg Subtype.val hQ)
+  · rintro ⟨P, hP⟩
+    obtain ⟨Q, rfl⟩ := exists_baseChange_eq_of_smul_eq hσ ((hmem P).mp hP)
+    exact ⟨Q, rfl⟩
+
+end M4Wiles.T2
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo
+
+theorem solution {R : Type*} [CommRing R] {F : Type*} [Field F] [Fintype F] {k : Type*} [Field k]
+    [DecidableEq k] [Algebra R F] [Algebra R k] [Algebra F k] [IsScalarTower R F k]
+    (W : WeierstrassCurve R) (σ : k ≃ₐ[F] k) (hσ : ∀ x : k, σ x = x ^ Fintype.card F) :
+    kerDeg (frobEnd W σ) 1 1 = Nat.card (W⁄F).Point :=
+  M4Wiles.T2.kerDeg_one_one W σ hσ
+
+end S_FrobeniusEndo_kerDeg_frobEnd_one_one
+end P2MW
+export P2MW.S_FrobeniusEndo_kerDeg_frobEnd_one_one (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo
+
+theorem FrobeniusEndo.kerDeg_frobEnd_one_one {R : Type*} [CommRing R] {F : Type*} [Field F]
+    [Fintype F] {k : Type*} [Field k] [DecidableEq k] [Algebra R F] [Algebra R k] [Algebra F k]
+    [IsScalarTower R F k] (W : WeierstrassCurve R) (σ : k ≃ₐ[F] k)
+    (hσ : ∀ x : k, σ x = x ^ Fintype.card F) :
+    kerDeg (frobEnd W σ) 1 1 = Nat.card (W⁄F).Point :=
+  solution W σ hσ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_trace_det_frob_of_line_of_isotropic.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_trace_det_frob_of_line_of_isotropic.lean
new file mode 100644
index 0000000000..aaabefa220
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_FrobeniusEndo_trace_det_frob_of_line_of_isotropic.lean
@@ -0,0 +1,347 @@
+/-
+Based on Prove2Me node FrobeniusEndo.trace_det_frob_of_line_of_isotropic
+(54d1089d-9e39-52f0-806f-b36250fe9e06) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e469c10b-1167-5e95-bdbe-b2af883f3f43
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusEndo
+public import Mathlib.LinearAlgebra.Determinant
+
+import Mathlib.LinearAlgebra.Dimension.Free
+import Mathlib.FieldTheory.Finiteness
+import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_dvd_kerDeg_of_det_frobPencilEnd_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_det_frobPencilEnd_eq_zero_iff_dvd_kerDeg
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Trace and determinant of σ on p-torsion, isotropic case
+
+Theorem statement: `FrobeniusEndo.trace_det_frob_of_line_of_isotropic`
+(`54d1089d-9e39-52f0-806f-b36250fe9e06`), by Claude, 2026-09-05.
+
+Proof: submission `e469c10b-1167-5e95-bdbe-b2af883f3f43`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R \to S \to K$ be a tower of commutative rings with $K$ a field, let $W$ be a Weierstrass curve
+over $R$, and let $\sigma$ be an $S$-algebra automorphism of $K$, acting on the group
+$(W\!\restriction_K)$-points $(W⁄K).\mathrm{Point}$ of the base change of $W$ to $K$; write
+$\mathrm{frobEnd}\,W\,\sigma$ for the additive endomorphism of that group induced by this action.
+Let $p$ be a prime. Assume the $p$-torsion subgroup $\{P : pP = 0\}$ of $(W⁄K).\mathrm{Point}$ has
+exactly $p^2$ elements, and that $p \ne 0$ in $K$. Let $a$ be an integer and $q$ a natural number,
+and assume the two line hypotheses: for every natural number $m$ with $1 \le m \le 2p$ and $m \ne 0$
+in $K$, the cardinality $\mathrm{kerDeg}$ of the kernel of $m \cdot \mathrm{id} -
+\mathrm{frobEnd}\,W\,\sigma$, that is of $\{P : mP = \sigma P\}$, equals $m^2 - am + q$ (as
+integers, the cardinality being $0$ when the kernel is infinite), and this cardinality is nonzero
+for all such $m$. Assume finally that $c^2 - \bar a c + \bar q = 0$ for some $c \in \mathbb{Z}/p$.
+Then the trace over $\mathbb{Z}/p$ of the induced $\mathbb{Z}/p$-linear endomorphism of the
+$p$-torsion equals $\bar a$, and its determinant equals $\bar q$.
+
+This is the standard determination of the trace and determinant of a Frobenius-type automorphism on
+$E[p]$ from the kernel counts $\#\ker([m]-\sigma) = m^2 - am + q$, here in the case where the
+quadratic $X^2 - \bar aX + \bar q$ already has a root modulo $p$. It feeds the
+characteristic-polynomial statement
+[`FrobeniusEndo.charEq_on_torsionBy_of_line_of_isotropic`]
+(thm.html#FrobeniusEndo.charEq_on_torsionBy_of_line_of_isotropic)
+and the variant
+[`FrobeniusEndo.trace_det_frob_of_line_of_charEqOnPoints`]
+(thm.html#FrobeniusEndo.trace_det_frob_of_line_of_charEqOnPoints),
+which remove the isotropy hypothesis.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_FrobeniusEndo_trace_det_frob_of_line_of_isotropic.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_FrobeniusEndo_trace_det_frob_of_line_of_isotropic
+
+p2m_open "WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo \
+  P2MW.S_FrobeniusEndo_trace_det_frob_of_line_of_isotropic.FrobeniusEndo"
+
+namespace FrobeniusEndo
+p2m_export "FrobeniusEndo" "linePencil linePencil_apply kerDeg frobEnd frobEnd_apply frobPencilEnd \
+  dvd_kerDeg_of_det_frobPencilEnd_eq_zero det_frobPencilEnd_eq_zero_iff_dvd_kerDeg"
+p2m_open "FrobeniusEndo"
+
+section BivariateDet
+
+variable {R : Type*} [CommRing R]
+
+theorem matrix_det_smul_one_sub_smul_fin_two (a c : R) (M : Matrix (Fin 2) (Fin 2) R) :
+    (a • (1 : Matrix (Fin 2) (Fin 2) R) - c • M).det
+      = a ^ 2 - a * c * M.trace + c ^ 2 * M.det := by
+  simp only [Matrix.det_fin_two, Matrix.trace_fin_two, Matrix.sub_apply, Matrix.smul_apply,
+    Matrix.one_apply_eq, Matrix.one_apply_ne (by decide : (0 : Fin 2) ≠ 1),
+    Matrix.one_apply_ne (by decide : (1 : Fin 2) ≠ 0), smul_eq_mul, mul_zero, mul_one]
+  ring
+
+variable {M : Type*} [AddCommGroup M] [Module R M]
+
+theorem linearMap_det_smul_one_sub_smul_of_basis_fin_two (b : Module.Basis (Fin 2) R M)
+    (φ : M →ₗ[R] M) (a c : R) :
+    LinearMap.det (a • (1 : M →ₗ[R] M) - c • φ)
+      = a ^ 2 - a * c * LinearMap.trace R M φ + c ^ 2 * LinearMap.det φ := by
+  rw [LinearMap.trace_eq_matrix_trace R b φ, ← LinearMap.det_toMatrix b φ,
+    ← LinearMap.det_toMatrix b (a • (1 : M →ₗ[R] M) - c • φ), map_sub, map_smul, map_smul,
+    LinearMap.toMatrix_one]
+  exact matrix_det_smul_one_sub_smul_fin_two a c _
+
+end BivariateDet
+
+section RankTwo
+
+variable {p : ℕ} [Fact p.Prime] {V : Type*} [AddCommGroup V] [Module (ZMod p) V]
+
+theorem finrank_eq_two_of_natCard (hV : Nat.card V = p ^ 2) : Module.finrank (ZMod p) V = 2 := by
+  have : Finite V :=
+    Nat.finite_of_card_ne_zero (by rw [hV]; exact pow_ne_zero 2 (Fact.out : p.Prime).ne_zero)
+  have h := Module.natCard_eq_pow_finrank (K := ZMod p) (V := V)
+  rw [hV, Nat.card_zmod] at h
+  exact (Nat.pow_right_injective (Fact.out : p.Prime).two_le h).symm
+
+noncomputable def basisOfNatCard (hV : Nat.card V = p ^ 2) : Module.Basis (Fin 2) (ZMod p) V :=
+  haveI : Finite V := Nat.finite_of_card_ne_zero (by
+    rw [hV]; exact pow_ne_zero 2 (Fact.out : p.Prime).ne_zero)
+  Module.finBasisOfFinrankEq (ZMod p) V (finrank_eq_two_of_natCard hV)
+
+end RankTwo
+
+section Pencil
+
+variable {R : Type*} {S : Type*} {K : Type*} [CommRing R] [CommRing S] [Field K] [DecidableEq K]
+  [Algebra R S] [Algebra R K] [Algebra S K] [IsScalarTower R S K]
+  (W : WeierstrassCurve R) (σ : K ≃ₐ[S] K) (p : ℕ)
+
+lemma coe_galois_smul_torsionBy (x : Submodule.torsionBy ℤ (W⁄K).Point p) :
+    ((σ • x : Submodule.torsionBy ℤ (W⁄K).Point p) : (W⁄K).Point) = σ • (x : (W⁄K).Point) :=
+  rfl
+
+lemma coe_frobPencilEnd_apply (m n : ℤ) (x : Submodule.torsionBy ℤ (W⁄K).Point p) :
+    ((frobPencilEnd W σ p m n x : Submodule.torsionBy ℤ (W⁄K).Point p) : (W⁄K).Point)
+      = linePencil (frobEnd W σ) m n x := by
+  simp only [LinearMap.sub_apply, LinearMap.smul_apply, Module.End.one_apply, linePencil_apply,
+    frobEnd_apply, Int.cast_smul_eq_zsmul, Submodule.coe_sub, Submodule.coe_smul_of_tower]
+  rfl
+
+lemma frobPencilEnd_eq_zero_iff (m n : ℤ) (x : Submodule.torsionBy ℤ (W⁄K).Point p) :
+    frobPencilEnd W σ p m n x = 0 ↔ (x : (W⁄K).Point) ∈ (linePencil (frobEnd W σ) m n).ker := by
+  rw [AddMonoidHom.mem_ker, ← coe_frobPencilEnd_apply, ZeroMemClass.coe_eq_zero]
+
+lemma frobPencilEnd_natCast_one (m : ℕ) :
+    frobPencilEnd W σ p (m : ℤ) 1
+      = (m : ZMod p) • (1 : Module.End (ZMod p) (Submodule.torsionBy ℤ (W⁄K).Point p))
+          - galoisRepModuleEnd S W p σ := by
+  simp only [frobPencilEnd, Int.cast_natCast, Int.cast_one, one_smul]
+
+end Pencil
+
+section Dictionary
+
+variable {R : Type*} {S : Type*} {K : Type*} [CommRing R] [CommRing S] [Field K] [DecidableEq K]
+  [Algebra R S] [Algebra R K] [Algebra S K] [IsScalarTower R S K]
+  (W : WeierstrassCurve R) (σ : K ≃ₐ[S] K) (p : ℕ) [Fact p.Prime]
+
+variable {p} in
+omit [DecidableEq K] in
+lemma exists_pos_natCast_lift (hpK : (p : K) ≠ 0) (c : ZMod p) :
+    ∃ m : ℕ, 1 ≤ m ∧ m ≤ 2 * p ∧ (m : K) ≠ 0 ∧ (m : ZMod p) = c := by
+  classical
+  have hp1 : 1 ≤ p := (Fact.out : p.Prime).one_lt.le
+  have hvlt : c.val < p := ZMod.val_lt c
+  have hvcast : ((c.val : ℕ) : ZMod p) = c := by
+    rw [ZMod.natCast_val, ZMod.cast_id]
+  by_cases hc0 : c = 0
+  · exact ⟨p, hp1, by omega, hpK, by rw [ZMod.natCast_self, hc0]⟩
+  · have hv1 : 1 ≤ c.val := by
+      rcases Nat.eq_zero_or_pos c.val with h | h
+      · exact absurd (by rw [← hvcast, h, Nat.cast_zero]) hc0
+      · exact h
+    by_cases hvk : ((c.val : ℕ) : K) = 0
+    · refine ⟨c.val + p, by omega, by omega, ?_, by
+        rw [Nat.cast_add, ZMod.natCast_self, add_zero, hvcast]⟩
+      intro h0
+      apply hpK
+      have hsub : ((c.val + p : ℕ) : K) - ((c.val : ℕ) : K) = (p : K) := by
+        push_cast; ring
+      rw [h0, hvk, sub_zero] at hsub
+      exact hsub.symm
+    · exact ⟨c.val, hv1, by omega, hvk, hvcast⟩
+
+theorem quadratic_eq_zero_of_det_smul_one_sub_eq_zero (hpK : (p : K) ≠ 0) {a : ℤ} {q : ℕ}
+    (hline : ∀ m : ℕ, 1 ≤ m → m ≤ 2 * p → (m : K) ≠ 0 →
+      ((kerDeg (frobEnd W σ) m 1 : ℕ) : ℤ) = (m : ℤ) ^ 2 - a * m + q)
+    {c : ZMod p}
+    (hdet : LinearMap.det
+        (c • (1 : Module.End (ZMod p) (Submodule.torsionBy ℤ (W⁄K).Point p))
+          - galoisRepModuleEnd S W p σ) = 0) :
+    c ^ 2 - (a : ZMod p) * c + (q : ZMod p) = 0 := by
+  obtain ⟨m, hm1, hmle, hmk, hmc⟩ := exists_pos_natCast_lift (K := K) hpK c
+  have hdet' : LinearMap.det (frobPencilEnd W σ p (m : ℤ) 1) = 0 := by
+    rw [frobPencilEnd_natCast_one, hmc]
+    exact hdet
+  have hdvd : p ∣ kerDeg (frobEnd W σ) (m : ℤ) 1 :=
+    dvd_kerDeg_of_det_frobPencilEnd_eq_zero W σ p hdet'
+  have hdvdZ : (p : ℤ) ∣ ((m : ℤ) ^ 2 - a * (m : ℤ) + (q : ℤ)) := by
+    rw [← hline m hm1 hmle hmk]
+    exact_mod_cast hdvd
+  have hzero : (((m : ℤ) ^ 2 - a * (m : ℤ) + (q : ℤ) : ℤ) : ZMod p) = 0 :=
+    (ZMod.intCast_zmod_eq_zero_iff_dvd _ p).mpr hdvdZ
+  push_cast at hzero
+  rwa [hmc] at hzero
+
+theorem det_smul_one_sub_eq_zero_of_quadratic_eq_zero
+    (hfull : Nat.card (Submodule.torsionBy ℤ (W⁄K).Point p) = p ^ 2) (hpK : (p : K) ≠ 0) {a : ℤ}
+    {q : ℕ}
+    (hline : ∀ m : ℕ, 1 ≤ m → m ≤ 2 * p → (m : K) ≠ 0 →
+      ((kerDeg (frobEnd W σ) m 1 : ℕ) : ℤ) = (m : ℤ) ^ 2 - a * m + q)
+    (hpos : ∀ m : ℕ, 1 ≤ m → m ≤ 2 * p → (m : K) ≠ 0 → kerDeg (frobEnd W σ) m 1 ≠ 0)
+    {c : ZMod p}
+    (hroot : c ^ 2 - (a : ZMod p) * c + (q : ZMod p) = 0) :
+    LinearMap.det
+        (c • (1 : Module.End (ZMod p) (Submodule.torsionBy ℤ (W⁄K).Point p))
+          - galoisRepModuleEnd S W p σ) = 0 := by
+  obtain ⟨m, hm1, hmle, hmk, hmc⟩ := exists_pos_natCast_lift (K := K) hpK c
+  have hzero : (((m : ℤ) ^ 2 - a * (m : ℤ) + (q : ℤ) : ℤ) : ZMod p) = 0 := by
+    push_cast
+    rw [hmc]
+    exact hroot
+  have hdvdZ : (p : ℤ) ∣ ((m : ℤ) ^ 2 - a * (m : ℤ) + (q : ℤ)) :=
+    (ZMod.intCast_zmod_eq_zero_iff_dvd _ p).mp hzero
+  have hdvd : p ∣ kerDeg (frobEnd W σ) (m : ℤ) 1 := by
+    have : (p : ℤ) ∣ (kerDeg (frobEnd W σ) (m : ℤ) 1 : ℤ) := by
+      rw [hline m hm1 hmle hmk]
+      exact hdvdZ
+    exact_mod_cast this
+  have hdet' : LinearMap.det (frobPencilEnd W σ p (m : ℤ) 1) = 0 :=
+    (det_frobPencilEnd_eq_zero_iff_dvd_kerDeg W σ p
+      (by
+        rw [hfull]; exact pow_ne_zero 2 (Fact.out : p.Prime).ne_zero) (hpos m hm1 hmle hmk)).mpr
+          hdvd
+  rwa [frobPencilEnd_natCast_one, hmc] at hdet'
+
+end Dictionary
+
+section Endgame
+
+variable {R : Type*} {S : Type*} {K : Type*} [CommRing R] [CommRing S] [Field K] [DecidableEq K]
+  [Algebra R S] [Algebra R K] [Algebra S K] [IsScalarTower R S K]
+  (W : WeierstrassCurve R) (σ : K ≃ₐ[S] K) (p : ℕ) [Fact p.Prime]
+
+theorem trace_det_of_line_of_isotropic
+    (hfull : Nat.card (Submodule.torsionBy ℤ (W⁄K).Point p) = p ^ 2) (hpK : (p : K) ≠ 0) {a : ℤ}
+    {q : ℕ}
+    (hline : ∀ m : ℕ, 1 ≤ m → m ≤ 2 * p → (m : K) ≠ 0 →
+      ((kerDeg (frobEnd W σ) m 1 : ℕ) : ℤ) = (m : ℤ) ^ 2 - a * m + q)
+    (hpos : ∀ m : ℕ, 1 ≤ m → m ≤ 2 * p → (m : K) ≠ 0 → kerDeg (frobEnd W σ) m 1 ≠ 0)
+    (hiso : ∃ c : ZMod p, c ^ 2 - (a : ZMod p) * c + (q : ZMod p) = 0) :
+    galoisTrace S W p σ = (a : ZMod p) ∧
+      LinearMap.det (galoisRepModuleEnd S W p σ) = (q : ZMod p) := by
+  classical
+  let b : Module.Basis (Fin 2) (ZMod p) (Submodule.torsionBy ℤ (W⁄K).Point p) :=
+    basisOfNatCard hfull
+  rw [galoisTrace_def]
+  set M := galoisRepModuleEnd S W p σ with hM
+  set t := LinearMap.trace (ZMod p) _ M with ht
+  set d := LinearMap.det M with hd
+  have hdf : ∀ c : ZMod p,
+      LinearMap.det (c • (1 : Module.End (ZMod p) (Submodule.torsionBy ℤ (W⁄K).Point p)) - M)
+        = c ^ 2 - c * t + d := by
+    intro c
+    have h := linearMap_det_smul_one_sub_smul_of_basis_fin_two b M c 1
+    simpa using h
+  obtain ⟨lam, hlam⟩ := hiso
+  set mu : ZMod p := (a : ZMod p) - lam with hmu
+  have hmuroot : mu ^ 2 - (a : ZMod p) * mu + (q : ZMod p) = 0 := by
+    rw [hmu]; linear_combination hlam
+  have hdl : LinearMap.det
+      (lam • (1 : Module.End (ZMod p) (Submodule.torsionBy ℤ (W⁄K).Point p)) - M) = 0 :=
+    det_smul_one_sub_eq_zero_of_quadratic_eq_zero W σ p hfull hpK hline hpos hlam
+  have hdmu : LinearMap.det
+      (mu • (1 : Module.End (ZMod p) (Submodule.torsionBy ℤ (W⁄K).Point p)) - M) = 0 :=
+    det_smul_one_sub_eq_zero_of_quadratic_eq_zero W σ p hfull hpK hline hpos hmuroot
+  have el : lam ^ 2 - lam * t + d = 0 := by rw [← hdf lam]; exact hdl
+  have emu : mu ^ 2 - mu * t + d = 0 := by rw [← hdf mu]; exact hdmu
+  have htr : t = (a : ZMod p) := by
+    by_cases hlm : lam = mu
+    · have ha2 : (a : ZMod p) = 2 * lam := by
+        have h := hlm
+        rw [hmu] at h
+        linear_combination -h
+      have hq2 : (q : ZMod p) = lam ^ 2 := by
+        linear_combination hlam + lam * ha2
+      set nu : ZMod p := t - lam with hnu
+      have hnuchar : nu ^ 2 - nu * t + d = 0 := by
+        rw [hnu]; linear_combination el
+      have hdnu : LinearMap.det
+          (nu • (1 : Module.End (ZMod p) (Submodule.torsionBy ℤ (W⁄K).Point p)) - M) = 0 := by
+        rw [hdf nu]; exact hnuchar
+      have hnuq : nu ^ 2 - (a : ZMod p) * nu + (q : ZMod p) = 0 :=
+        quadratic_eq_zero_of_det_smul_one_sub_eq_zero W σ p hpK hline hdnu
+      have hsq : (nu - lam) ^ 2 = 0 := by
+        linear_combination hnuq + nu * ha2 - hq2
+      have hnulam : nu = lam := by
+        have h0 : nu - lam = 0 := pow_eq_zero_iff two_ne_zero |>.mp hsq
+        exact sub_eq_zero.mp h0
+      have htval : t = nu + lam := by rw [hnu]; ring
+      rw [htval, hnulam, ha2]; ring
+    · have hfac : (lam - mu) * (lam + mu - t) = 0 := by
+        linear_combination el - emu
+      rcases mul_eq_zero.mp hfac with h | h
+      · exact absurd (sub_eq_zero.mp h) hlm
+      · have hsum : lam + mu = t := sub_eq_zero.mp h
+        rw [← hsum, hmu]; ring
+  have hdet : d = (q : ZMod p) := by
+    linear_combination el - hlam + lam * htr
+  exact ⟨htr, hdet⟩
+
+end Endgame
+
+end FrobeniusEndo
+
+theorem solution {R : Type*} {S : Type*} {K : Type*} [CommRing R] [CommRing S] [Field K]
+  [DecidableEq K] [Algebra R S] [Algebra R K] [Algebra S K] [IsScalarTower R S K] (W :
+  WeierstrassCurve R) (σ : K ≃ₐ[S] K) (p : ℕ) [Fact p.Prime] (hfull : Nat.card (Submodule.torsionBy
+  ℤ (W⁄K).Point p) = p ^ 2) (hpK : (p : K) ≠ 0) (a : ℤ) (q : ℕ) (hline : ∀ m : ℕ, 1 ≤ m → m ≤ 2 * p
+  → (m : K) ≠ 0 → ((kerDeg (frobEnd W σ) m 1 : ℕ) : ℤ) = (m : ℤ) ^ 2 - a * m + q) (hpos : ∀ m : ℕ, 1
+  ≤ m → m ≤ 2 * p → (m : K) ≠ 0 → kerDeg (frobEnd W σ) m 1 ≠ 0) (hiso : ∃ c : ZMod p, c ^ 2 - (a :
+  ZMod p) * c + (q : ZMod p) = 0) :
+    galoisTrace S W p σ = (a : ZMod p) ∧ LinearMap.det (galoisRepModuleEnd S W p σ) = (q : ZMod p)
+      :=
+  FrobeniusEndo.trace_det_of_line_of_isotropic W σ p hfull hpK hline hpos hiso
+
+end S_FrobeniusEndo_trace_det_frob_of_line_of_isotropic
+end P2MW
+export P2MW.S_FrobeniusEndo_trace_det_frob_of_line_of_isotropic (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point FrobeniusEndo
+
+theorem FrobeniusEndo.trace_det_frob_of_line_of_isotropic {R : Type*} {S : Type*} {K : Type*}
+  [CommRing R] [CommRing S] [Field K] [DecidableEq K] [Algebra R S] [Algebra R K] [Algebra S K]
+  [IsScalarTower R S K] (W : WeierstrassCurve R) (σ : K ≃ₐ[S] K) (p : ℕ) [Fact p.Prime] (hfull :
+  Nat.card (Submodule.torsionBy ℤ (W⁄K).Point p) = p ^ 2) (hpK : (p : K) ≠ 0) (a : ℤ) (q : ℕ) (hline
+  : ∀ m : ℕ, 1 ≤ m → m ≤ 2 * p → (m : K) ≠ 0 → ((kerDeg (frobEnd W σ) m 1 : ℕ) : ℤ) = (m : ℤ) ^ 2 -
+  a * m + q) (hpos : ∀ m : ℕ, 1 ≤ m → m ≤ 2 * p → (m : K) ≠ 0 → kerDeg (frobEnd W σ) m 1 ≠ 0) (hiso
+  : ∃ c : ZMod p, c ^ 2 - (a : ZMod p) * c + (q : ZMod p) = 0) :
+    galoisTrace S W p σ = (a : ZMod p) ∧ LinearMap.det (galoisRepModuleEnd S W p σ) = (q : ZMod p)
+      :=
+  solution W σ p hfull hpK a q hline hpos hiso
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Function_exists_eq_apply_sub_of_sum_range_minimalPeriod_eq_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Function_exists_eq_apply_sub_of_sum_range_minimalPeriod_eq_zero.lean
new file mode 100644
index 0000000000..aee8fd01c0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Function_exists_eq_apply_sub_of_sum_range_minimalPeriod_eq_zero.lean
@@ -0,0 +1,210 @@
+/-
+Copyright (c) 2026 Lean Pool contributors. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Lean Pool contributors
+-/
+
+/-
+Based on Prove2Me node Function.exists_eq_apply_sub_of_sum_range_minimalPeriod_eq_zero
+(a56de2e9-7a5d-52b3-ac23-cf4f9c005577) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 0e225520-8f2c-5b33-894a-9f2b9a1b7c36
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Dynamics.PeriodicPts.Defs
+public import Mathlib.Algebra.BigOperators.Group.Finset.Basic
+
+import Mathlib.Tactic.Push
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Vanishing orbit sums give a coboundary G∘ f-G
+
+Let $X$ be a type, $A$ an additive commutative group, and $f\colon X\to X$ a self-map. Assume that
+every point of $X$ is periodic for $f$, in the sense that its minimal period `Function.minimalPeriod
+f x` is strictly positive, and let $v\colon X\to A$ be an arbitrary function. Assume further that
+for every $x\in X$ the sum of $v$ along the orbit segment of length the minimal period of $x$
+vanishes, i.e. $\sum_{k<\operatorname{minimalPeriod}(f,x)} v(f^{[k]}(x))=0$, the sum being taken
+over `Finset.range (Function.minimalPeriod f x)` with $f^{[k]}$ the $k$-fold iterate. The conclusion
+is the existence of a function $G\colon X\to A$ such that $v(x)=G(f(x))-G(x)$ for every $x\in X$. No
+finiteness, measurability or structure hypotheses are imposed on $X$, and $f$ is not assumed
+injective beyond what pointwise periodicity forces.
+
+This is the elementary statement that, for a pointwise periodic self-map, a function with vanishing
+sums over all minimal orbits is a coboundary for the operator $G\mapsto G\circ f-G$; for $f$ a
+permutation coming from a group element it is the computation of $H^1$ of a cyclic group acting on a
+permutation module. It is used in the construction of parabolic cocycles and the Hecke-equivariant
+comparison for $\Gamma_0(Np)\le\Gamma_0(N)$, notably by
+[`HeckeEis.coeffHeckeFun_mem_coeffParabolicCocycles`](thm.html#HeckeEis.
+coeffHeckeFun_mem_coeffParabolicCocycles) and
+[`HeckeEis.exists_coeffH1par_projLineRepSL_equiv_parabolicHoms`](thm.html#HeckeEis.
+exists_coeffH1par_projLineRepSL_equiv_parabolicHoms).
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/Theorems/Thm_Function_exists_eq_apply_sub_of_sum_range_minimalPeriod_eq_zero.lean
+
+Prove2Me submission: `0e225520-8f2c-5b33-894a-9f2b9a1b7c36` (ACCEPTED).
+-/
+
+section privateSection
+
+
+namespace P2MW.S_Function_exists_eq_apply_sub_of_sum_range_minimalPeriod_eq_zero
+
+namespace Function
+p2m_export "Function"
+  "minimalPeriod_apply_iterate minimalPeriod_pos_iff_mem_periodicPts iterate_succ_apply' \
+    iterate_add_apply iterate_zero_apply isPeriodicPt_minimalPeriod minimalPeriod IsPeriodicPt \
+    iterate_eq_iterate_iff_of_lt_minimalPeriod"
+p2m_open "Function"
+namespace OrbitPrimitive
+
+variable {X : Type*} (f : X → X) (hf : ∀ x : X, 0 < minimalPeriod f x)
+
+def rel (x y : X) : Prop := ∃ k : ℕ, f^[k] x = y
+
+include hf in
+theorem rel_symm {x y : X} (h : rel f x y) : rel f y x := by
+  obtain ⟨k, rfl⟩ := h
+  refine ⟨minimalPeriod f x * k - k, ?_⟩
+  have hper : IsPeriodicPt f (minimalPeriod f x) x := isPeriodicPt_minimalPeriod f x
+  have h1 : f^[minimalPeriod f x * k - k] (f^[k] x) = f^[minimalPeriod f x * k] x := by
+    rw [← iterate_add_apply, Nat.sub_add_cancel (Nat.le_mul_of_pos_left k (hf x))]
+  rw [h1]
+  exact (hper.mul_const k).eq
+
+theorem rel_refl (x : X) : rel f x x := ⟨0, rfl⟩
+
+theorem rel_trans {x y z : X} (h₁ : rel f x y) (h₂ : rel f y z) : rel f x z := by
+  obtain ⟨k, rfl⟩ := h₁
+  obtain ⟨l, rfl⟩ := h₂
+  exact ⟨l + k, by rw [iterate_add_apply]⟩
+
+def orbitSetoid (hf : ∀ x : X, 0 < minimalPeriod f x) : Setoid X where
+  r := rel f
+  iseqv := ⟨rel_refl f, rel_symm f hf, rel_trans f⟩
+
+noncomputable def base (x : X) : X := (Quotient.mk (orbitSetoid f hf) x).out
+
+theorem rel_base (x : X) : rel f (base f hf x) x := by
+  have h : Quotient.mk (orbitSetoid f hf) (base f hf x) = Quotient.mk (orbitSetoid f hf) x :=
+    Quotient.out_eq _
+  exact Quotient.exact (s := orbitSetoid f hf) h
+
+theorem base_apply (x : X) : base f hf (f x) = base f hf x := by
+  unfold base
+  congr 1
+  apply Quotient.sound
+  change rel f (f x) x
+  exact rel_symm f hf ⟨1, rfl⟩
+
+open Classical in
+noncomputable def idx (x : X) : ℕ :=
+  Nat.find (show ∃ k : ℕ, f^[k] (base f hf x) = x from rel_base f hf x)
+
+open Classical in
+theorem iterate_idx (x : X) : f^[idx f hf x] (base f hf x) = x := Nat.find_spec (rel_base f hf x)
+
+open Classical in
+theorem idx_lt (x : X) : idx f hf x < minimalPeriod f (base f hf x) := by
+  by_contra h
+  push Not at h
+  have hm := hf (base f hf x)
+  have key : f^[idx f hf x - minimalPeriod f (base f hf x)] (base f hf x) = x := by
+    have e : f^[idx f hf x - minimalPeriod f (base f hf x)] (f^[minimalPeriod f (base f hf x)] (base
+      f hf x))
+        = f^[idx f hf x] (base f hf x) := by
+      rw [← iterate_add_apply, Nat.sub_add_cancel h]
+    rw [show f^[minimalPeriod f (base f hf x)] (base f hf x) = base f hf x from
+      (isPeriodicPt_minimalPeriod f _).eq, iterate_idx] at e
+    exact e
+  have := Nat.find_min (rel_base f hf x)
+    (m := idx f hf x - minimalPeriod f (base f hf x)) (by
+      unfold idx at *
+      omega)
+  exact this key
+
+theorem minimalPeriod_base (x : X) : minimalPeriod f (base f hf x) = minimalPeriod f x := by
+  conv_rhs => rw [← iterate_idx f hf x]
+  rw [minimalPeriod_apply_iterate (minimalPeriod_pos_iff_mem_periodicPts.mp (hf _))]
+
+open Classical in
+theorem idx_apply (x : X) :
+    (idx f hf (f x) = idx f hf x + 1 ∧ idx f hf x + 1 < minimalPeriod f (base f hf x)) ∨
+    (idx f hf (f x) = 0 ∧ idx f hf x + 1 = minimalPeriod f (base f hf x)) := by
+  have hb : base f hf (f x) = base f hf x := base_apply f hf x
+  have hlt := idx_lt f hf x
+  have hstep : f^[idx f hf x + 1] (base f hf x) = f x := by
+    rw [iterate_succ_apply', iterate_idx]
+  rcases Nat.lt_or_ge (idx f hf x + 1) (minimalPeriod f (base f hf x)) with h | h
+  · left
+    refine ⟨?_, h⟩
+    have hle : idx f hf (f x) ≤ idx f hf x + 1 := by
+      unfold idx
+      exact Nat.find_min' _ (by rw [hb]; exact hstep)
+    have hlt' : idx f hf (f x) < minimalPeriod f (base f hf x) := lt_of_le_of_lt hle h
+    have heq : f^[idx f hf (f x)] (base f hf x) = f^[idx f hf x + 1] (base f hf x) := by
+      rw [hstep, ← hb, iterate_idx]
+    exact (iterate_eq_iterate_iff_of_lt_minimalPeriod hlt' h).mp heq
+  · right
+    have heq : idx f hf x + 1 = minimalPeriod f (base f hf x) := le_antisymm hlt (by exact h)
+    refine ⟨?_, heq⟩
+    have : f x = base f hf x := by
+      rw [← hstep, heq]
+      exact (isPeriodicPt_minimalPeriod f _).eq
+    unfold idx
+    rw [Nat.find_eq_zero]
+    show f^[0] (base f hf (f x)) = f x
+    rw [hb, iterate_zero_apply, this]
+
+end OrbitPrimitive
+
+open OrbitPrimitive in
+theorem OrbitPrimitive.main {X : Type*} {A : Type*} [AddCommGroup A]
+    (f : X → X) (hf : ∀ x : X, 0 < minimalPeriod f x) (v : X → A)
+    (hv : ∀ x : X, ∑ k ∈ Finset.range (minimalPeriod f x), v (f^[k] x) = 0) :
+    ∃ G : X → A, ∀ x : X, v x = G (f x) - G x := by
+  classical
+  refine ⟨fun x => ∑ k ∈ Finset.range (idx f hf x), v (f^[k] (base f hf x)), fun x => ?_⟩
+  simp only
+  rw [base_apply f hf x]
+  rcases idx_apply f hf x with ⟨h1, -⟩ | ⟨h0, hm⟩
+  · rw [h1, Finset.sum_range_succ, iterate_idx, add_sub_cancel_left]
+  · rw [h0, Finset.sum_range_zero, zero_sub]
+    have htot := hv (base f hf x)
+    rw [← hm, Finset.sum_range_succ, iterate_idx] at htot
+    exact (neg_eq_of_add_eq_zero_left htot).symm ▸ (neg_neg _).symm
+
+end Function
+
+theorem solution {X : Type*} {A : Type*} [AddCommGroup A]
+    (f : X → X) (hf : ∀ x : X, 0 < Function.minimalPeriod f x) (v : X → A)
+    (hv : ∀ x : X, ∑ k ∈ Finset.range (Function.minimalPeriod f x), v (f^[k] x) = 0) :
+    ∃ G : X → A, ∀ x : X, v x = G (f x) - G x :=
+  Function.OrbitPrimitive.main f hf v hv
+
+end S_Function_exists_eq_apply_sub_of_sum_range_minimalPeriod_eq_zero
+end P2MW
+export P2MW.S_Function_exists_eq_apply_sub_of_sum_range_minimalPeriod_eq_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+
+theorem Function.exists_eq_apply_sub_of_sum_range_minimalPeriod_eq_zero {X : Type*} {A : Type*}
+  [AddCommGroup A]
+    (f : X → X) (hf : ∀ x : X, 0 < Function.minimalPeriod f x) (v : X → A)
+    (hv : ∀ x : X, ∑ k ∈ Finset.range (Function.minimalPeriod f x), v (f^[k] x) = 0) :
+    ∃ G : X → A, ∀ x : X, v x = G (f x) - G x :=
+      _root_.P2MW.S_Function_exists_eq_apply_sub_of_sum_range_minimalPeriod_eq_zero.solution f hf v
+      hv
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_HasRamBound_add.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_HasRamBound_add.lean
new file mode 100644
index 0000000000..f56ed80a13
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_HasRamBound_add.lean
@@ -0,0 +1,60 @@
+/-
+Based on Prove2Me node HahnSeries.HasRamBound.add
+(e7778773-cac0-5937-8eb3-dd3153fd3da3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c5d9cc7d-b131-598b-b6c2-b36347eb8b3a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_RamificationBound
+
+/-!
+# Ramification bounds are closed under addition
+
+Theorem statement: `HahnSeries.HasRamBound.add` (`e7778773-cac0-5937-8eb3-dd3153fd3da3`), by Claude,
+2026-09-05.
+
+Proof: submission `c5d9cc7d-b131-598b-b6c2-b36347eb8b3a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, let $e$ be a natural number, and let $x$ and $y$ be Hahn series over $K$ with
+value group $\mathbb{Q}$, i.e. elements of `HahnSeries ℚ K`. Say that a Hahn series $z$ satisfies
+`HasRamBound e z` when its support is contained in the range of the map $\mathbb{Z} \to \mathbb{Q}$,
+$k \mapsto k/e$; that is, every exponent at which $z$ has a non-zero coefficient is of the form
+$k/e$ for some integer $k$. Assuming `HasRamBound e x` and `HasRamBound e y`, the conclusion is
+`HasRamBound e (x + y)`: every exponent in the support of $x + y$ is again of the form $k/e$ with $k
+\in \mathbb{Z}$. No positivity assumption on $e$ is made; for $e = 0$ the range in question is the
+singleton $\{0\}$ (division by zero in $\mathbb{Q}$ returning $0$), so in that degenerate case the
+hypotheses and the conclusion say that the series are supported at the exponent $0$ alone.
+
+This is the additive closure half of the statement that the generalised power series with exponents
+in $\tfrac1e\mathbb{Z}$ — the Puiseux series in an $e$-th root of the uniformiser — form a subring,
+indeed a subfield, of `HahnSeries ℚ K`. It is used in the analysis of ramification of $q$-expansions
+on modular curves, feeding into
+[`ModularCurve.ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound`]
+(thm.html#ModularCurve.ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HahnSeries_HasRamBound_add.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+public section publicSection
+
+theorem HahnSeries.HasRamBound.add {K : Type*} [Field K] {e : ℕ} {x y : HahnSeries ℚ K}
+    (hx : HasRamBound e x)
+    (hy : HasRamBound e y) : HasRamBound e (x + y) := by
+  intro g hg
+  rcases support_add_subset x y hg with h | h
+  · exact hx h
+  · exact hy h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_hasRamBound_C.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_hasRamBound_C.lean
new file mode 100644
index 0000000000..f009056176
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_hasRamBound_C.lean
@@ -0,0 +1,209 @@
+/-
+Based on Prove2Me node HahnSeries.hasRamBound_C
+(9a31f41d-5acd-56ab-abb1-78069b4fa34c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b09f942b-bdd8-5040-9ef1-79a0baae5e46
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_RamificationBound
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_mem_puiseuxRamSubfield_iff
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Constant Hahn series have ramification bound e
+
+Theorem statement: `HahnSeries.hasRamBound_C` (`9a31f41d-5acd-56ab-abb1-78069b4fa34c`), by Claude,
+2026-09-05.
+
+Proof: submission `b09f942b-bdd8-5040-9ef1-79a0baae5e46`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, let $e$ be a natural number, and let $a \in K$. Write $C a$ for the constant
+Hahn series in `HahnSeries ℚ K`, that is, the series over the rationals with coefficients in $K$
+whose coefficient at the exponent $0$ is $a$ and whose other coefficients vanish. The assertion is
+`HasRamBound e (C a)`, which by definition says that the support of $C a$ — the set of exponents in
+$\mathbb{Q}$ at which its coefficient is nonzero — is contained in the image of the map $\mathbb{Z}
+\to \mathbb{Q}$, $k \mapsto k/e$. There are no further hypotheses: $a$ may be zero, in which case
+the series is $0$ and its support is empty, and $e$ may be zero, in which case the set $\{k/e : k
+\in \mathbb{Z}\}$ reduces to $\{0\}$ under the convention that division by zero yields zero, so the
+conclusion still holds. Thus constants satisfy the ramification bound $e$ for every $e$
+simultaneously.
+
+This is the statement that the constants of $K$ lie in the subfield of series with exponents in
+$\tfrac{1}{e}\mathbb{Z}$, the first of the closure properties of the Puiseux-type subfield of
+`HahnSeries ℚ K` cut out by a ramification bound. It is used when polynomials with constant
+coefficients are evaluated at series of bounded ramification, and in particular in
+[`ModularCurve.ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound`]
+(thm.html#ModularCurve.ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HahnSeries_hasRamBound_C.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HahnSeries_hasRamBound_C
+
+namespace HahnSeries
+p2m_export "HahnSeries" "support C_apply support_single_subset support_one single support_zero \
+  support_mul_subset support_add_subset C support_neg ramScale puiseuxRamEmb HasRamBound \
+  puiseuxRamSubfield mem_puiseuxRamSubfield_iff"
+p2m_open "HahnSeries"
+
+variable {K : Type*} [Field K] {e : ℕ}
+
+private lemma ramRange_zero_mem : (0 : ℚ) ∈ Set.range (fun k : ℤ => (k : ℚ) / e) :=
+  ⟨0, by simp⟩
+
+private lemma ramRange_add_mem {q r : ℚ} (hq : q ∈ Set.range (fun k : ℤ => (k : ℚ) / e))
+    (hr : r ∈ Set.range (fun k : ℤ => (k : ℚ) / e)) :
+    q + r ∈ Set.range (fun k : ℤ => (k : ℚ) / e) := by
+  obtain ⟨k, rfl⟩ := hq
+  obtain ⟨l, rfl⟩ := hr
+  exact ⟨k + l, by push_cast [add_div]; rfl⟩
+
+private theorem hasRamBound_zero : HasRamBound e (0 : HahnSeries ℚ K) := by
+  intro g hg
+  simp [HahnSeries.support_zero] at hg
+
+private theorem hasRamBound_one : HasRamBound e (1 : HahnSeries ℚ K) := by
+  intro g hg
+  rw [support_one, Set.mem_singleton_iff] at hg
+  exact hg ▸ ramRange_zero_mem
+
+private theorem hasRamBound_C (a : K) : HasRamBound e (C a : HahnSeries ℚ K) := by
+  intro g hg
+  rw [C_apply] at hg
+  have := support_single_subset hg
+  rw [Set.mem_singleton_iff] at this
+  exact this ▸ ramRange_zero_mem
+
+private theorem hasRamBound_natCast (n : ℕ) : HasRamBound e ((n : HahnSeries ℚ K)) := by
+  rw [← map_natCast (C (Γ := ℚ) (R := K)) n]
+  exact hasRamBound_C _
+
+private theorem hasRamBound_intCast (m : ℤ) : HasRamBound e ((m : HahnSeries ℚ K)) := by
+  rw [← map_intCast (C (Γ := ℚ) (R := K)) m]
+  exact hasRamBound_C _
+
+private theorem hasRamBound_single_intCast (he : 0 < e) (k : ℤ) (c : K) :
+    HasRamBound e (single ((k : ℤ) : ℚ) c) := by
+  intro g hg
+  have hmem := support_single_subset hg
+  rw [Set.mem_singleton_iff] at hmem
+  subst hmem
+  refine ⟨k * e, ?_⟩
+  have he' : (e : ℚ) ≠ 0 := Nat.cast_ne_zero.mpr he.ne'
+  push_cast
+  field_simp
+
+private theorem hasRamBound_single_one (he : 0 < e) (c : K) :
+    HasRamBound e (single (1 : ℚ) c) := by
+  have h := hasRamBound_single_intCast (K := K) he 1 c
+  norm_num at h
+  exact h
+
+namespace HasRamBound
+private theorem _root_.HahnSeries.HasRamBound.add {x y : HahnSeries ℚ K} (hx : HasRamBound e x)
+    (hy : HasRamBound e y) : HasRamBound e (x + y) := by
+  intro g hg
+  rcases support_add_subset x y hg with h | h
+  · exact hx h
+  · exact hy h
+
+end HasRamBound
+p2m_export "HahnSeries" "HasRamBound.add"
+namespace HasRamBound
+private theorem _root_.HahnSeries.HasRamBound.neg {x : HahnSeries ℚ K} (hx : HasRamBound e x) :
+    HasRamBound e (-x) := fun g hg => hx (by rwa [support_neg] at hg)
+
+end HasRamBound
+p2m_export "HahnSeries" "HasRamBound.neg"
+private theorem HasRamBound.sub {x y : HahnSeries ℚ K} (hx : HasRamBound e x)
+    (hy : HasRamBound e y) : HasRamBound e (x - y) := by
+  rw [sub_eq_add_neg]
+  exact hx.add hy.neg
+
+namespace HasRamBound
+private theorem _root_.HahnSeries.HasRamBound.mul {x y : HahnSeries ℚ K} (hx : HasRamBound e x)
+    (hy : HasRamBound e y) : HasRamBound e (x * y) := by
+  intro g hg
+  have := support_mul_subset (x := x) (y := y) hg
+  obtain ⟨a, ha, b, hb, rfl⟩ := Set.mem_add.mp this
+  exact ramRange_add_mem (hx ha) (hy hb)
+
+end HasRamBound
+p2m_export "HahnSeries" "HasRamBound.mul"
+private theorem HasRamBound.pow {x : HahnSeries ℚ K} (hx : HasRamBound e x) (n : ℕ) :
+    HasRamBound e (x ^ n) := by
+  induction n with
+  | zero => simpa using hasRamBound_one
+  | succ n ih => rw [pow_succ]; exact ih.mul hx
+
+private theorem HasRamBound.mono {d d' : ℕ} (hdd' : d ∣ d') (hd' : 0 < d')
+    {y : HahnSeries ℚ K} (h : HasRamBound d y) : HasRamBound d' y := by
+  intro g hg
+  obtain ⟨k, hk⟩ := h hg
+  rcases Nat.eq_zero_or_pos d with rfl | hd
+  · refine ⟨0, ?_⟩
+    simp only [Nat.cast_zero, div_zero] at hk
+    rw [← hk]
+    simp
+  · obtain ⟨c, rfl⟩ := hdd'
+    have hc : (c : ℚ) ≠ 0 := by
+      have hc0 : c ≠ 0 := by rintro rfl; omega
+      exact_mod_cast hc0
+    refine ⟨k * c, ?_⟩
+    rw [← hk]
+    push_cast
+    rw [mul_div_mul_right _ _ hc]
+
+namespace HasRamBound
+private theorem _root_.HahnSeries.HasRamBound.inv (he : 0 < e) {y : HahnSeries ℚ K}
+    (hy : HasRamBound e y) : HasRamBound e y⁻¹ :=
+  (mem_puiseuxRamSubfield_iff he).mp (inv_mem ((mem_puiseuxRamSubfield_iff he).mpr hy))
+
+end HasRamBound
+p2m_export "HahnSeries" "HasRamBound.inv"
+private theorem HasRamBound.div (he : 0 < e) {x y : HahnSeries ℚ K}
+    (hx : HasRamBound e x) (hy : HasRamBound e y) : HasRamBound e (x / y) := by
+  rw [div_eq_mul_inv]
+  exact hx.mul (hy.inv he)
+
+end HahnSeries
+
+open _root_.HahnSeries _root_.P2MW.S_HahnSeries_hasRamBound_C.HahnSeries in
+theorem solution {K : Type*} [Field K] {e : ℕ} (a : K) : HasRamBound e (C a : HahnSeries ℚ K) :=
+  HahnSeries.hasRamBound_C a
+
+end S_HahnSeries_hasRamBound_C
+end P2MW
+export P2MW.S_HahnSeries_hasRamBound_C (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open HahnSeries
+theorem HahnSeries.hasRamBound_C {K : Type*} [Field K] {e : ℕ} (a : K) :
+    HasRamBound e (C a : HahnSeries ℚ K) :=
+  solution a
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_hasRamBound_natCast.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_hasRamBound_natCast.lean
new file mode 100644
index 0000000000..79e6f1dbe5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_hasRamBound_natCast.lean
@@ -0,0 +1,212 @@
+/-
+Based on Prove2Me node HahnSeries.hasRamBound_natCast
+(a679ab7b-591e-562e-a4c3-a848edeb09c3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 25baba94-aa42-57f9-b82a-5fc0d8cf080c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_RamificationBound
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_mem_puiseuxRamSubfield_iff
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Natural numbers have every ramification bound in HahnSeries ℚ K
+
+Theorem statement: `HahnSeries.hasRamBound_natCast` (`a679ab7b-591e-562e-a4c3-a848edeb09c3`), by
+Claude, 2026-09-05.
+
+Proof: submission `25baba94-aa42-57f9-b82a-5fc0d8cf080c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, let $e$ be a natural number and let $n$ be a natural number. Consider the ring
+$\mathrm{HahnSeries}\ \mathbb{Q}\ K$ of Hahn series with rational exponents and coefficients in $K$,
+and the image of $n$ in it under the canonical map from $\mathbb{N}$. The assertion is that this
+element satisfies `HasRamBound e`, which by definition means that its support — the set of rational
+exponents at which its coefficient is non-zero — is contained in the set of rationals of the form
+$k/e$ with $k \in \mathbb{Z}$. There are no hypotheses beyond $K$ being a field: in particular $e$
+is allowed to be $0$, in which case $k/e$ is $0$ for every $k$ and the admissible exponent set is
+$\{0\}$, and $n$ is allowed to be $0$, or to have vanishing image in $K$ when $K$ has positive
+characteristic, in which case the series is $0$ and its support is empty. The statement concerns
+natural numbers only, although the same holds for integers.
+
+This records that the prime subring of the Hahn series field sits inside the Puiseux-type subfield
+of series with denominators dividing $e$; by
+[`HahnSeries.mem_puiseuxRamSubfield_iff`](thm.html#HahnSeries.mem_puiseuxRamSubfield_iff) the
+predicate `HasRamBound e` is, for $e>0$, membership in [`HahnSeries.puiseuxRamSubfield K
+he`](def/HahnSeries_RamificationBound.html#L37). It is used when the modular equation, whose
+coefficients are rational integers and hence constant series, is evaluated at a series with
+ramification bound $e$, in
+[`ModularCurve.ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound`]
+(thm.html#ModularCurve.ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HahnSeries_hasRamBound_natCast.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HahnSeries_hasRamBound_natCast
+
+namespace HahnSeries
+p2m_export "HahnSeries" "support C_apply support_single_subset support_one single support_zero \
+  support_mul_subset support_add_subset C support_neg ramScale puiseuxRamEmb HasRamBound \
+  puiseuxRamSubfield mem_puiseuxRamSubfield_iff"
+p2m_open "HahnSeries"
+
+variable {K : Type*} [Field K] {e : ℕ}
+
+private lemma ramRange_zero_mem : (0 : ℚ) ∈ Set.range (fun k : ℤ => (k : ℚ) / e) :=
+  ⟨0, by simp⟩
+
+private lemma ramRange_add_mem {q r : ℚ} (hq : q ∈ Set.range (fun k : ℤ => (k : ℚ) / e))
+    (hr : r ∈ Set.range (fun k : ℤ => (k : ℚ) / e)) :
+    q + r ∈ Set.range (fun k : ℤ => (k : ℚ) / e) := by
+  obtain ⟨k, rfl⟩ := hq
+  obtain ⟨l, rfl⟩ := hr
+  exact ⟨k + l, by push_cast [add_div]; rfl⟩
+
+private theorem hasRamBound_zero : HasRamBound e (0 : HahnSeries ℚ K) := by
+  intro g hg
+  simp [HahnSeries.support_zero] at hg
+
+private theorem hasRamBound_one : HasRamBound e (1 : HahnSeries ℚ K) := by
+  intro g hg
+  rw [support_one, Set.mem_singleton_iff] at hg
+  exact hg ▸ ramRange_zero_mem
+
+private theorem hasRamBound_C (a : K) : HasRamBound e (C a : HahnSeries ℚ K) := by
+  intro g hg
+  rw [C_apply] at hg
+  have := support_single_subset hg
+  rw [Set.mem_singleton_iff] at this
+  exact this ▸ ramRange_zero_mem
+
+private theorem hasRamBound_natCast (n : ℕ) : HasRamBound e ((n : HahnSeries ℚ K)) := by
+  rw [← map_natCast (C (Γ := ℚ) (R := K)) n]
+  exact hasRamBound_C _
+
+private theorem hasRamBound_intCast (m : ℤ) : HasRamBound e ((m : HahnSeries ℚ K)) := by
+  rw [← map_intCast (C (Γ := ℚ) (R := K)) m]
+  exact hasRamBound_C _
+
+private theorem hasRamBound_single_intCast (he : 0 < e) (k : ℤ) (c : K) :
+    HasRamBound e (single ((k : ℤ) : ℚ) c) := by
+  intro g hg
+  have hmem := support_single_subset hg
+  rw [Set.mem_singleton_iff] at hmem
+  subst hmem
+  refine ⟨k * e, ?_⟩
+  have he' : (e : ℚ) ≠ 0 := Nat.cast_ne_zero.mpr he.ne'
+  push_cast
+  field_simp
+
+private theorem hasRamBound_single_one (he : 0 < e) (c : K) :
+    HasRamBound e (single (1 : ℚ) c) := by
+  have h := hasRamBound_single_intCast (K := K) he 1 c
+  norm_num at h
+  exact h
+
+namespace HasRamBound
+private theorem _root_.HahnSeries.HasRamBound.add {x y : HahnSeries ℚ K} (hx : HasRamBound e x)
+    (hy : HasRamBound e y) : HasRamBound e (x + y) := by
+  intro g hg
+  rcases support_add_subset x y hg with h | h
+  · exact hx h
+  · exact hy h
+
+end HasRamBound
+p2m_export "HahnSeries" "HasRamBound.add"
+namespace HasRamBound
+private theorem _root_.HahnSeries.HasRamBound.neg {x : HahnSeries ℚ K} (hx : HasRamBound e x) :
+    HasRamBound e (-x) := fun g hg => hx (by rwa [support_neg] at hg)
+
+end HasRamBound
+p2m_export "HahnSeries" "HasRamBound.neg"
+private theorem HasRamBound.sub {x y : HahnSeries ℚ K} (hx : HasRamBound e x)
+    (hy : HasRamBound e y) : HasRamBound e (x - y) := by
+  rw [sub_eq_add_neg]
+  exact hx.add hy.neg
+
+namespace HasRamBound
+private theorem _root_.HahnSeries.HasRamBound.mul {x y : HahnSeries ℚ K} (hx : HasRamBound e x)
+    (hy : HasRamBound e y) : HasRamBound e (x * y) := by
+  intro g hg
+  have := support_mul_subset (x := x) (y := y) hg
+  obtain ⟨a, ha, b, hb, rfl⟩ := Set.mem_add.mp this
+  exact ramRange_add_mem (hx ha) (hy hb)
+
+end HasRamBound
+p2m_export "HahnSeries" "HasRamBound.mul"
+private theorem HasRamBound.pow {x : HahnSeries ℚ K} (hx : HasRamBound e x) (n : ℕ) :
+    HasRamBound e (x ^ n) := by
+  induction n with
+  | zero => simpa using hasRamBound_one
+  | succ n ih => rw [pow_succ]; exact ih.mul hx
+
+private theorem HasRamBound.mono {d d' : ℕ} (hdd' : d ∣ d') (hd' : 0 < d')
+    {y : HahnSeries ℚ K} (h : HasRamBound d y) : HasRamBound d' y := by
+  intro g hg
+  obtain ⟨k, hk⟩ := h hg
+  rcases Nat.eq_zero_or_pos d with rfl | hd
+  · refine ⟨0, ?_⟩
+    simp only [Nat.cast_zero, div_zero] at hk
+    rw [← hk]
+    simp
+  · obtain ⟨c, rfl⟩ := hdd'
+    have hc : (c : ℚ) ≠ 0 := by
+      have hc0 : c ≠ 0 := by rintro rfl; omega
+      exact_mod_cast hc0
+    refine ⟨k * c, ?_⟩
+    rw [← hk]
+    push_cast
+    rw [mul_div_mul_right _ _ hc]
+
+namespace HasRamBound
+private theorem _root_.HahnSeries.HasRamBound.inv (he : 0 < e) {y : HahnSeries ℚ K}
+    (hy : HasRamBound e y) : HasRamBound e y⁻¹ :=
+  (mem_puiseuxRamSubfield_iff he).mp (inv_mem ((mem_puiseuxRamSubfield_iff he).mpr hy))
+
+end HasRamBound
+p2m_export "HahnSeries" "HasRamBound.inv"
+private theorem HasRamBound.div (he : 0 < e) {x y : HahnSeries ℚ K}
+    (hx : HasRamBound e x) (hy : HasRamBound e y) : HasRamBound e (x / y) := by
+  rw [div_eq_mul_inv]
+  exact hx.mul (hy.inv he)
+
+end HahnSeries
+
+open _root_.HahnSeries _root_.P2MW.S_HahnSeries_hasRamBound_natCast.HahnSeries in
+theorem solution {K : Type*} [Field K] {e : ℕ} (n : ℕ) : HasRamBound e ((n : HahnSeries ℚ K)) :=
+  HahnSeries.hasRamBound_natCast n
+
+end S_HahnSeries_hasRamBound_natCast
+end P2MW
+export P2MW.S_HahnSeries_hasRamBound_natCast (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open HahnSeries
+theorem HahnSeries.hasRamBound_natCast {K : Type*} [Field K] {e : ℕ} (n : ℕ) :
+    HasRamBound e ((n : HahnSeries ℚ K)) :=
+  solution n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_hasRamBound_natDegree_factorial_of_isRoot.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_hasRamBound_natDegree_factorial_of_isRoot.lean
new file mode 100644
index 0000000000..d97b73d4e5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_hasRamBound_natDegree_factorial_of_isRoot.lean
@@ -0,0 +1,402 @@
+/-
+Based on Prove2Me node HahnSeries.hasRamBound_natDegree_factorial_of_isRoot
+(abe0820d-9542-5179-9033-2824fce83cf1) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8773d217-dd86-55d0-8f56-cd15ad6ea50f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_RamificationBound
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.RootsOfUnity.AlgebraicallyClosed
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Newton–Puiseux bound: roots have exponents in tfrac1n!ℤ
+
+Theorem statement: `HahnSeries.hasRamBound_natDegree_factorial_of_isRoot`
+(`abe0820d-9542-5179-9033-2824fce83cf1`), by Claude, 2026-09-05.
+
+Proof: submission `8773d217-dd86-55d0-8f56-cd15ad6ea50f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field of characteristic $0$, and work in the field $\mathbb{K} =$
+`HahnSeries ℚ K` of Hahn series with value group $\mathbb{Q}$ and coefficients in $K$. Let $p \in
+\mathbb{K}[Y]$ be a nonzero polynomial each of whose coefficients $p_i$ ($i \in \mathbb{N}$)
+satisfies [`HahnSeries.HasRamBound 1`](def/HahnSeries_RamificationBound.html#L32), that is, the
+support of $p_i$ is contained in the set of rationals of the form $k/1$ with $k \in \mathbb{Z}$; so
+every coefficient of $p$ is a Laurent series, with integral exponents. Let $y \in \mathbb{K}$ be a
+root of $p$, i.e. $p$ evaluated at $y$ is $0$. The conclusion is that $y$ satisfies
+[`HahnSeries.HasRamBound n!`](def/HahnSeries_RamificationBound.html#L32) where $n =$ `p.natDegree`:
+the support of $y$ is contained in the set of rationals of the form $k/n!$ with $k \in \mathbb{Z}$,
+i.e. $\operatorname{supp}(y) \subseteq \tfrac{1}{n!}\mathbb{Z}$. Note that the hypothesis on the
+coefficients is imposed for all natural numbers $i$, and that the denominator bound is stated as the
+factorial of the degree rather than as an unspecified or optimal integer, so the statement carries
+no existential quantifier.
+
+This is the Newton–Puiseux theorem in the form asserting that an element of the Hahn series field
+$K((t^{\mathbb{Q}}))$ which is algebraic over the Laurent series field $K((t))$ is a Puiseux series,
+with an explicit bound $n!$ on the ramification of its exponents. It is used in the construction and
+comparison of places on modular curves, being cited by
+[`ModularCurve.exists_place_of_emb`](thm.html#ModularCurve.exists_place_of_emb),
+[`ModularCurve.samePlace_iff_exists_hahnTwist`]
+(thm.html#ModularCurve.samePlace_iff_exists_hahnTwist)
+and
+[`ModularCurve.card_eq_natCard_quot_samePlace_of_forall_mem_iff_pos_ord`]
+(thm.html#ModularCurve.card_eq_natCard_quot_samePlace_of_forall_mem_iff_pos_ord).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HahnSeries_hasRamBound_natDegree_factorial_of_isRoot.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HahnSeries_hasRamBound_natDegree_factorial_of_isRoot
+
+
+open Polynomial
+
+namespace HahnSeries
+p2m_export "HahnSeries" "support isPWO_support mem_support coeff_mul coeff coeff_one coeff_zero \
+  map coeff_add isPWO_support' HasRamBound"
+namespace PuiseuxTwist
+p2m_open "HahnSeries"
+
+variable {K : Type*} [Field K]
+
+def twist (χ : Multiplicative ℚ →* Kˣ) (x : HahnSeries ℚ K) : HahnSeries ℚ K where
+  coeff q := (χ (Multiplicative.ofAdd q) : K) * x.coeff q
+  isPWO_support' := x.isPWO_support.mono (by
+    intro q hq
+    rw [Function.mem_support] at hq
+    rw [HahnSeries.mem_support]
+    intro h
+    exact hq (by rw [h, mul_zero]))
+
+@[scoped simp] theorem coeff_twist (χ : Multiplicative ℚ →* Kˣ) (x : HahnSeries ℚ K) (q : ℚ) :
+    (twist χ x).coeff q = (χ (Multiplicative.ofAdd q) : K) * x.coeff q := rfl
+
+theorem support_twist (χ : Multiplicative ℚ →* Kˣ) (x : HahnSeries ℚ K) :
+    (twist χ x).support = x.support := by
+  ext q
+  rw [HahnSeries.mem_support, HahnSeries.mem_support, coeff_twist]
+  constructor
+  · intro h hx
+    exact h (by rw [hx, mul_zero])
+  · intro h hx
+    exact h ((mul_eq_zero.mp hx).resolve_left (Units.ne_zero _))
+
+theorem twist_add (χ : Multiplicative ℚ →* Kˣ) (x y : HahnSeries ℚ K) :
+    twist χ (x + y) = twist χ x + twist χ y := by
+  ext q
+  simp only [coeff_twist, HahnSeries.coeff_add, mul_add]
+
+theorem twist_one (χ : Multiplicative ℚ →* Kˣ) : twist χ (1 : HahnSeries ℚ K) = 1 := by
+  ext q
+  simp only [coeff_twist, HahnSeries.coeff_one]
+  split_ifs with h
+  · subst h
+    rw [ofAdd_zero, map_one, Units.val_one, one_mul]
+  · rw [mul_zero]
+
+open Finset in
+theorem twist_mul (χ : Multiplicative ℚ →* Kˣ) (x y : HahnSeries ℚ K) :
+    twist χ (x * y) = twist χ x * twist χ y := by
+  ext a
+  rw [coeff_twist, HahnSeries.coeff_mul, HahnSeries.coeff_mul, Finset.mul_sum]
+  have hset : antidiagonal (twist χ x).isPWO_support (twist χ y).isPWO_support a
+      = antidiagonal x.isPWO_support y.isPWO_support a := by
+    ext ij
+    simp only [Finset.mem_antidiagonal, support_twist]
+  rw [hset]
+  refine Finset.sum_congr rfl (fun ij hij => ?_)
+  rw [Finset.mem_antidiagonal] at hij
+  obtain ⟨-, -, hsum⟩ := hij
+  simp only [coeff_twist]
+  rw [← hsum, ofAdd_add, map_mul, Units.val_mul]
+  ring
+
+def twistRingHom (χ : Multiplicative ℚ →* Kˣ) : HahnSeries ℚ K →+* HahnSeries ℚ K where
+  toFun := twist χ
+  map_one' := twist_one χ
+  map_mul' := twist_mul χ
+  map_zero' := by ext q; simp only [coeff_twist, HahnSeries.coeff_zero, mul_zero]
+  map_add' := twist_add χ
+
+@[scoped simp] theorem twistRingHom_apply (χ : Multiplicative ℚ →* Kˣ) (x : HahnSeries ℚ K) :
+    twistRingHom χ x = twist χ x := rfl
+
+theorem twist_eq_self_of_hasRamBound_one {χ : Multiplicative ℚ →* Kˣ}
+    (hχ : ∀ k : ℤ, χ (Multiplicative.ofAdd (k : ℚ)) = 1) {z : HahnSeries ℚ K}
+    (hz : HahnSeries.HasRamBound 1 z) : twist χ z = z := by
+  ext q
+  rw [coeff_twist]
+  by_cases hq : q ∈ z.support
+  · obtain ⟨k, hk⟩ := hz hq
+    simp only [Nat.cast_one, div_one] at hk
+    rw [← hk, hχ k, Units.val_one, one_mul]
+  · rw [HahnSeries.mem_support, not_not] at hq
+    rw [hq, mul_zero]
+
+theorem isRoot_twist {χ : Multiplicative ℚ →* Kˣ}
+    (hχ : ∀ k : ℤ, χ (Multiplicative.ofAdd (k : ℚ)) = 1) {p : (HahnSeries ℚ K)[X]}
+    (hcoeff : ∀ i : ℕ, HahnSeries.HasRamBound 1 (p.coeff i)) {y : HahnSeries ℚ K} (hy : p.IsRoot y)
+    :
+    p.IsRoot (twist χ y) := by
+  have hmap : p.map (twistRingHom χ) = p := by
+    ext i
+    rw [Polynomial.coeff_map, twistRingHom_apply, twist_eq_self_of_hasRamBound_one hχ (hcoeff i)]
+  rw [Polynomial.IsRoot.def] at hy ⊢
+  have h : (p.map (twistRingHom χ)).eval (twistRingHom χ y) = 0 := by
+    rw [Polynomial.eval_map_apply, hy, map_zero]
+  rwa [hmap, twistRingHom_apply] at h
+
+section Character
+
+variable [IsAlgClosed K] (ζ : Kˣ)
+
+noncomputable def rootSeq : ℕ → Kˣ
+  | 0 => ζ
+  | m + 1 =>
+    Units.mk0 (Classical.choose (IsAlgClosed.exists_pow_nat_eq ((rootSeq m : Kˣ) : K) m.succ_pos))
+      (by
+        intro h0
+        have h :=
+          Classical.choose_spec (IsAlgClosed.exists_pow_nat_eq ((rootSeq m : Kˣ) : K) m.succ_pos)
+        rw [h0, zero_pow (Nat.succ_ne_zero m)] at h
+        exact (rootSeq m).ne_zero h.symm)
+
+theorem rootSeq_zero : rootSeq ζ 0 = ζ := rfl
+
+theorem rootSeq_succ_pow (m : ℕ) : (rootSeq ζ (m + 1)) ^ (m + 1) = rootSeq ζ m := by
+  apply Units.ext
+  rw [Units.val_pow_eq_pow_val]
+  change (Classical.choose (IsAlgClosed.exists_pow_nat_eq ((rootSeq ζ m : Kˣ) : K) m.succ_pos)) ^
+    (m+1) = _
+  exact Classical.choose_spec (IsAlgClosed.exists_pow_nat_eq ((rootSeq ζ m : Kˣ) : K) m.succ_pos)
+
+theorem rootSeq_add_pow (m j : ℕ) :
+    (rootSeq ζ (m + j)) ^ ((m + j).factorial / m.factorial) = rootSeq ζ m := by
+  induction j with
+  | zero => simp [Nat.div_self (Nat.factorial_pos m)]
+  | succ j ih =>
+    rw [← add_assoc, Nat.factorial_succ, Nat.mul_div_assoc _ (Nat.factorial_dvd_factorial
+      (Nat.le_add_right m j)),
+      pow_mul, rootSeq_succ_pow, ih]
+
+theorem rootSeq_pow_of_le {m M : ℕ} (h : m ≤ M) :
+    (rootSeq ζ M) ^ (M.factorial / m.factorial) = rootSeq ζ m := by
+  obtain ⟨j, rfl⟩ := Nat.exists_eq_add_of_le h
+  exact rootSeq_add_pow ζ m j
+
+variable (b : ℕ)
+
+noncomputable def charFun (x : ℚ) : Kˣ :=
+  (rootSeq ζ x.den) ^ (x.num * (((b * x.den.factorial) / x.den : ℕ) : ℤ))
+
+variable {b}
+
+theorem charFun_eq (x : ℚ) (m : ℕ) (k : ℤ) (hk : x * ((b * m.factorial : ℕ) : ℚ) = k) :
+    charFun ζ b x = (rootSeq ζ m) ^ k := by
+  have hd0 : x.den ≠ 0 := x.den_nz
+  have hdvd : x.den ∣ x.den.factorial := Nat.dvd_factorial x.den_pos le_rfl
+  rw [charFun, ← rootSeq_pow_of_le ζ (Nat.le_add_right x.den m),
+    ← rootSeq_pow_of_le ζ (Nat.le_add_left m x.den),
+    ← zpow_natCast, ← zpow_natCast, ← zpow_mul, ← zpow_mul]
+  congr 1
+  apply mul_left_cancel₀ (show (x.den : ℤ) ≠ 0 by exact_mod_cast hd0)
+  have e1 : (((x.den + m).factorial / x.den.factorial : ℕ) : ℤ) * (x.den.factorial : ℤ)
+      = ((x.den + m).factorial : ℤ) := by
+    exact_mod_cast Nat.div_mul_cancel (Nat.factorial_dvd_factorial (Nat.le_add_right x.den m))
+  have e2 : (((b * x.den.factorial) / x.den : ℕ) : ℤ) * (x.den : ℤ) = b * x.den.factorial := by
+    exact_mod_cast Nat.div_mul_cancel (Dvd.dvd.mul_left hdvd b)
+  have e3 : (((x.den + m).factorial / m.factorial : ℕ) : ℤ) * (m.factorial : ℤ) = ((x.den +
+    m).factorial : ℤ) :=
+    by
+    exact_mod_cast Nat.div_mul_cancel (Nat.factorial_dvd_factorial (Nat.le_add_left m x.den))
+  have e4 : (k : ℤ) * x.den = x.num * (b * m.factorial : ℕ) := by
+    have hq : (k : ℚ) * x.den = x.num * (b * m.factorial : ℕ) := by
+      rw [← hk, mul_right_comm, Rat.mul_den_eq_num]
+    exact_mod_cast hq
+  calc (x.den : ℤ) * ((((x.den + m).factorial / x.den.factorial : ℕ) : ℤ)
+          * (x.num * (((b * x.den.factorial) / x.den : ℕ) : ℤ)))
+      = x.num * ((((b * x.den.factorial) / x.den : ℕ) : ℤ) * x.den)
+          * (((x.den + m).factorial / x.den.factorial : ℕ) : ℤ) := by ring
+    _ = x.num * (b * x.den.factorial) * (((x.den + m).factorial / x.den.factorial : ℕ) : ℤ) := by
+      rw [e2]
+    _ = x.num * b * ((((x.den + m).factorial / x.den.factorial : ℕ) : ℤ) * x.den.factorial) := by
+      ring
+    _ = x.num * b * ((x.den + m).factorial : ℤ) := by rw [e1]
+    _ = x.num * b * ((((x.den + m).factorial / m.factorial : ℕ) : ℤ) * m.factorial) := by rw [e3]
+    _ = (x.num * (b * m.factorial : ℕ)) * (((x.den + m).factorial / m.factorial : ℕ) : ℤ) := by
+          push_cast; ring
+    _ = (k * x.den) * (((x.den + m).factorial / m.factorial : ℕ) : ℤ) := by rw [e4]
+    _ = (x.den : ℤ) * ((((x.den + m).factorial / m.factorial : ℕ) : ℤ) * k) := by ring
+
+theorem exists_int_eq (b : ℕ) (x : ℚ) (m : ℕ) (hm : x.den ∣ m.factorial) :
+    ∃ k : ℤ, x * ((b * m.factorial : ℕ) : ℚ) = k := by
+  obtain ⟨c, hc⟩ := Dvd.dvd.mul_left hm b
+  refine ⟨x.num * c, ?_⟩
+  rw [hc]
+  push_cast
+  rw [← mul_assoc, Rat.mul_den_eq_num]
+
+variable (b)
+
+noncomputable def char : Multiplicative ℚ →* Kˣ where
+  toFun q := charFun ζ b (Multiplicative.toAdd q)
+  map_one' := by
+    change charFun ζ b 0 = 1
+    rw [charFun_eq ζ 0 0 0 (by simp), zpow_zero]
+  map_mul' x y := by
+    change charFun ζ b (Multiplicative.toAdd x + Multiplicative.toAdd y)
+      = charFun ζ b (Multiplicative.toAdd x) * charFun ζ b (Multiplicative.toAdd y)
+    have hm0 : 0 < (Multiplicative.toAdd x).den * (Multiplicative.toAdd y).den :=
+      Nat.pos_of_ne_zero (Nat.mul_ne_zero (Multiplicative.toAdd x).den_nz (Multiplicative.toAdd
+        y).den_nz)
+    have hfac : (Multiplicative.toAdd x).den * (Multiplicative.toAdd y).den ∣
+        ((Multiplicative.toAdd x).den * (Multiplicative.toAdd y).den).factorial :=
+      Nat.dvd_factorial hm0 le_rfl
+    have hu : (Multiplicative.toAdd x).den ∣
+        ((Multiplicative.toAdd x).den * (Multiplicative.toAdd y).den).factorial :=
+      (Dvd.intro _ rfl).trans hfac
+    have hv : (Multiplicative.toAdd y).den ∣
+        ((Multiplicative.toAdd x).den * (Multiplicative.toAdd y).den).factorial :=
+      (Dvd.intro_left _ rfl).trans hfac
+    have huv : (Multiplicative.toAdd x + Multiplicative.toAdd y).den ∣
+        ((Multiplicative.toAdd x).den * (Multiplicative.toAdd y).den).factorial :=
+      (Rat.add_den_dvd _ _).trans hfac
+    obtain ⟨ku, hku⟩ := exists_int_eq b _ _ hu
+    obtain ⟨kv, hkv⟩ := exists_int_eq b _ _ hv
+    have hkuv : (Multiplicative.toAdd x + Multiplicative.toAdd y)
+        * ((b * ((Multiplicative.toAdd x).den * (Multiplicative.toAdd y).den).factorial : ℕ) : ℚ)
+        = (ku + kv : ℤ) := by
+      rw [add_mul, hku, hkv]
+      push_cast
+      ring
+    rw [charFun_eq ζ _ _ _ hkuv, charFun_eq ζ _ _ _ hku, charFun_eq ζ _ _ _ hkv, zpow_add]
+
+theorem char_apply (x : ℚ) : char ζ b (Multiplicative.ofAdd x) = charFun ζ b x := rfl
+
+variable {b}
+
+theorem char_intCast (hζ : ζ ^ b = 1) (k : ℤ) :
+    char ζ b (Multiplicative.ofAdd (k : ℚ)) = 1 := by
+  rw [char_apply, charFun_eq ζ (k : ℚ) 0 (k * b) (by push_cast; simp), rootSeq_zero,
+    mul_comm, zpow_mul, zpow_natCast, hζ, one_zpow]
+
+theorem char_div (hb : 0 < b) (a : ℤ) :
+    char ζ b (Multiplicative.ofAdd ((a : ℚ) / b)) = ζ ^ a := by
+  have hb' : (b : ℚ) ≠ 0 := by exact_mod_cast hb.ne'
+  rw [char_apply, charFun_eq ζ ((a : ℚ) / b) 0 a (by push_cast; simp; field_simp), rootSeq_zero]
+
+end Character
+
+theorem den_le_natDegree [IsAlgClosed K] [CharZero K]
+    {p : (HahnSeries ℚ K)[X]} (hp : p ≠ 0)
+    (hcoeff : ∀ i : ℕ, HahnSeries.HasRamBound 1 (p.coeff i))
+    {y : HahnSeries ℚ K} (hy : p.IsRoot y) {q : ℚ} (hq : q ∈ y.support) :
+    q.den ≤ p.natDegree := by
+  classical
+  have hb : 0 < q.den := q.den_pos
+  have : NeZero q.den := ⟨q.den_nz⟩
+  obtain ⟨μ, hμ⟩ := HasEnoughRootsOfUnity.exists_primitiveRoot K q.den
+  have hcard : Nat.card (rootsOfUnity q.den K) = q.den := hμ.card_rootsOfUnity
+  have hval : ∀ ζ : Kˣ, char ζ q.den (Multiplicative.ofAdd q) = ζ ^ q.num := fun ζ => by
+    have e : Multiplicative.ofAdd q = Multiplicative.ofAdd ((q.num : ℚ) / (q.den : ℚ)) := by
+      rw [Rat.num_div_den]
+    rw [e, char_div ζ hb]
+  let f : rootsOfUnity q.den K → {z : HahnSeries ℚ K // z ∈ p.roots.toFinset} := fun ζ =>
+    ⟨twist (char ((ζ : Kˣ)) q.den) y, by
+      rw [Multiset.mem_toFinset, Polynomial.mem_roots hp]
+      exact isRoot_twist (char_intCast (ζ : Kˣ) ((mem_rootsOfUnity _ _).mp ζ.2)) hcoeff hy⟩
+  have hinj : Function.Injective f := by
+    intro ζ₁ ζ₂ h
+    have hc : (twist (char ((ζ₁ : Kˣ)) q.den) y).coeff q = (twist (char ((ζ₂ : Kˣ)) q.den) y).coeff
+      q :=
+      by
+      have := congrArg Subtype.val h
+      simp only [f] at this
+      rw [this]
+    rw [coeff_twist, coeff_twist, hval, hval] at hc
+    have hyq : y.coeff q ≠ 0 := by rwa [HahnSeries.mem_support] at hq
+    have hc' : ((ζ₁ : Kˣ)) ^ q.num = ((ζ₂ : Kˣ)) ^ q.num :=
+      Units.ext (mul_right_cancel₀ hyq hc)
+    have hg : Int.gcd q.num (q.den : ℤ) = 1 := by
+      first
+        | exact q.reduced
+    have hbez := Int.gcd_eq_gcd_ab q.num (q.den : ℤ)
+    rw [hg, Nat.cast_one] at hbez
+    have h1 : ((ζ₁ : Kˣ)) ^ (q.den : ℤ) = 1 := by
+      rw [zpow_natCast]; exact (mem_rootsOfUnity _ _).mp ζ₁.2
+    have h2 : ((ζ₂ : Kˣ)) ^ (q.den : ℤ) = 1 := by
+      rw [zpow_natCast]; exact (mem_rootsOfUnity _ _).mp ζ₂.2
+    have key : ∀ (ζ : Kˣ), ζ ^ (q.den : ℤ) = 1 →
+        ζ = (ζ ^ q.num) ^ (q.num.gcdA q.den) := fun ζ hζ => by
+      conv_lhs => rw [← zpow_one ζ, hbez, zpow_add, zpow_mul, zpow_mul, hζ, one_zpow, mul_one]
+    apply Subtype.ext
+    rw [key _ h1, key _ h2, hc']
+  have hle : Nat.card (rootsOfUnity q.den K) ≤ Nat.card {z : HahnSeries ℚ K // z ∈ p.roots.toFinset}
+    :=
+    Nat.card_le_card_of_injective f hinj
+  rw [hcard, Nat.card_eq_fintype_card, Fintype.card_coe] at hle
+  exact hle.trans ((Multiset.toFinset_card_le _).trans (Polynomial.card_roots' p))
+
+end HahnSeries.PuiseuxTwist
+
+open HahnSeries.PuiseuxTwist in
+theorem solution
+    {K : Type*} [Field K] [IsAlgClosed K] [CharZero K]
+    {p : Polynomial (HahnSeries ℚ K)} (hp : p ≠ 0)
+    (hcoeff : ∀ i : ℕ, HahnSeries.HasRamBound 1 (p.coeff i))
+    {y : HahnSeries ℚ K} (hy : p.IsRoot y) :
+    HahnSeries.HasRamBound p.natDegree.factorial y := by
+  intro q hq
+  have hb : 0 < q.den := q.den_pos
+  have hle : q.den ≤ p.natDegree := den_le_natDegree hp hcoeff hy hq
+  obtain ⟨c, hc⟩ := Nat.dvd_factorial hb hle
+  refine ⟨q.num * c, ?_⟩
+  have hq' : (q : ℚ) = q.num / q.den := (Rat.num_div_den q).symm
+  rw [hc]
+  have h1 : (q.den : ℚ) ≠ 0 := by exact_mod_cast q.den_nz
+  have h2 : (c : ℚ) ≠ 0 := by
+    have : c ≠ 0 := fun h0 => by rw [h0, mul_zero] at hc; exact Nat.factorial_ne_zero _ hc
+    exact_mod_cast this
+  conv_rhs => rw [hq']
+  push_cast
+  field_simp
+
+end S_HahnSeries_hasRamBound_natDegree_factorial_of_isRoot
+end P2MW
+export P2MW.S_HahnSeries_hasRamBound_natDegree_factorial_of_isRoot (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem HahnSeries.hasRamBound_natDegree_factorial_of_isRoot
+    {K : Type*} [Field K] [IsAlgClosed K] [CharZero K]
+    {p : Polynomial (HahnSeries ℚ K)} (hp : p ≠ 0)
+    (hcoeff : ∀ i : ℕ, HahnSeries.HasRamBound 1 (p.coeff i))
+    {y : HahnSeries ℚ K} (hy : p.IsRoot y) :
+    HahnSeries.HasRamBound p.natDegree.factorial y :=
+  solution hp hcoeff hy
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_hasRamBound_one_of_forall_ringEquiv_apply_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_hasRamBound_one_of_forall_ringEquiv_apply_eq.lean
new file mode 100644
index 0000000000..097131e4ee
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_hasRamBound_one_of_forall_ringEquiv_apply_eq.lean
@@ -0,0 +1,392 @@
+/-
+Based on Prove2Me node HahnSeries.hasRamBound_one_of_forall_ringEquiv_apply_eq
+(4b526abf-db34-59d8-87de-575bb8c429d0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 457d8709-8454-5e41-8f06-d14bae3b65be
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_RamificationBound
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.RootsOfUnity.AlgebraicallyClosed
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Descent to integer exponents in the Hahn field K((t^ℚ))
+
+Theorem statement: `HahnSeries.hasRamBound_one_of_forall_ringEquiv_apply_eq`
+(`4b526abf-db34-59d8-87de-575bb8c429d0`), by Claude, 2026-09-05.
+
+Proof: submission `457d8709-8454-5e41-8f06-d14bae3b65be`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field that is algebraically closed and of characteristic zero, and consider the Hahn
+series field $\mathrm{HahnSeries}\ \mathbb Q\ K$, whose elements are formal series with coefficients
+in $K$ supported on a well-ordered set of rational exponents. For $e : \mathbb N$ and a Hahn series
+$y$, the predicate [`HahnSeries.HasRamBound e y`](def/HahnSeries_RamificationBound.html#L32) asserts
+that the support of $y$ is contained in the set of rationals of the form $k/e$ with $k \in \mathbb
+Z$; thus [`HahnSeries.HasRamBound 1 y`](def/HahnSeries_RamificationBound.html#L32) says exactly that
+every exponent occurring in $y$ is an integer, i.e. that $y$ lies in the Laurent subfield $K((t))
+\subseteq K((t^{\mathbb Q}))$. Let $x$ be a Hahn series with rational exponents over $K$, and assume
+that for every ring isomorphism $\sigma$ of $\mathrm{HahnSeries}\ \mathbb Q\ K$ onto itself which
+preserves `orderTop`, in the sense that $(\sigma z).\mathrm{orderTop} = z.\mathrm{orderTop}$ for all
+$z$, and which fixes every series all of whose exponents are integers, one has $\sigma x = x$. The
+conclusion is that the support of $x$ consists of integers, i.e. [`HahnSeries.HasRamBound 1
+x`](def/HahnSeries_RamificationBound.html#L32) holds.
+
+This is the elementwise form of the descent statement that the fixed field of the
+`orderTop`-preserving automorphisms of $K((t^{\mathbb Q}))$ fixing $K((t))$ pointwise is $K((t))$
+itself, the Galois-theoretic half of the Puiseux tower $K((t)) \subset K((t^{1/e})) \subset
+K((t^{\mathbb Q}))$; note that the automorphisms quantified over are merely ring isomorphisms, not
+assumed $K$-linear. It is used to bound ramification of Puiseux expansions attached to torsion
+points of a Weierstrass curve over a power series ring, in
+[`WeierstrassCurve.hasRamBound_one_of_nsmul_eq_zero_of_isUnit_discriminant_powerSeries`]
+(thm.html#WeierstrassCurve.hasRamBound_one_of_nsmul_eq_zero_of_isUnit_discriminant_powerSeries).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HahnSeries_hasRamBound_one_of_forall_ringEquiv_apply_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HahnSeries_hasRamBound_one_of_forall_ringEquiv_apply_eq
+
+
+namespace HahnSeries
+p2m_export "HahnSeries" "support orderTop support_eq_empty_iff isPWO_support order mem_support \
+  coeff_mul coeff coeff_one coeff_zero map orderTop_of_ne_zero coeff_add isPWO_support' HasRamBound"
+namespace PuiseuxTwist
+p2m_open "HahnSeries"
+
+variable {K : Type*} [Field K]
+
+def twist (χ : Multiplicative ℚ →* Kˣ) (x : HahnSeries ℚ K) : HahnSeries ℚ K where
+  coeff q := (χ (Multiplicative.ofAdd q) : K) * x.coeff q
+  isPWO_support' := x.isPWO_support.mono (by
+    intro q hq
+    rw [Function.mem_support] at hq
+    rw [HahnSeries.mem_support]
+    intro h
+    exact hq (by rw [h, mul_zero]))
+
+@[scoped simp] theorem coeff_twist (χ : Multiplicative ℚ →* Kˣ) (x : HahnSeries ℚ K) (q : ℚ) :
+    (twist χ x).coeff q = (χ (Multiplicative.ofAdd q) : K) * x.coeff q := rfl
+
+theorem support_twist (χ : Multiplicative ℚ →* Kˣ) (x : HahnSeries ℚ K) :
+    (twist χ x).support = x.support := by
+  ext q
+  rw [HahnSeries.mem_support, HahnSeries.mem_support, coeff_twist]
+  constructor
+  · intro h hx
+    exact h (by rw [hx, mul_zero])
+  · intro h hx
+    exact h ((mul_eq_zero.mp hx).resolve_left (Units.ne_zero _))
+
+theorem twist_add (χ : Multiplicative ℚ →* Kˣ) (x y : HahnSeries ℚ K) :
+    twist χ (x + y) = twist χ x + twist χ y := by
+  ext q
+  simp only [coeff_twist, HahnSeries.coeff_add, mul_add]
+
+theorem twist_one (χ : Multiplicative ℚ →* Kˣ) : twist χ (1 : HahnSeries ℚ K) = 1 := by
+  ext q
+  simp only [coeff_twist, HahnSeries.coeff_one]
+  split_ifs with h
+  · subst h
+    rw [ofAdd_zero, map_one, Units.val_one, one_mul]
+  · rw [mul_zero]
+
+open Finset in
+theorem twist_mul (χ : Multiplicative ℚ →* Kˣ) (x y : HahnSeries ℚ K) :
+    twist χ (x * y) = twist χ x * twist χ y := by
+  ext a
+  rw [coeff_twist, HahnSeries.coeff_mul, HahnSeries.coeff_mul, Finset.mul_sum]
+  have hset : antidiagonal (twist χ x).isPWO_support (twist χ y).isPWO_support a
+      = antidiagonal x.isPWO_support y.isPWO_support a := by
+    ext ij
+    simp only [Finset.mem_antidiagonal, support_twist]
+  rw [hset]
+  refine Finset.sum_congr rfl (fun ij hij => ?_)
+  rw [Finset.mem_antidiagonal] at hij
+  obtain ⟨-, -, hsum⟩ := hij
+  simp only [coeff_twist]
+  rw [← hsum, ofAdd_add, map_mul, Units.val_mul]
+  ring
+
+def twistRingHom (χ : Multiplicative ℚ →* Kˣ) : HahnSeries ℚ K →+* HahnSeries ℚ K where
+  toFun := twist χ
+  map_one' := twist_one χ
+  map_mul' := twist_mul χ
+  map_zero' := by ext q; simp only [coeff_twist, HahnSeries.coeff_zero, mul_zero]
+  map_add' := twist_add χ
+
+@[scoped simp] theorem twistRingHom_apply (χ : Multiplicative ℚ →* Kˣ) (x : HahnSeries ℚ K) :
+    twistRingHom χ x = twist χ x := rfl
+
+theorem twist_eq_self_of_hasRamBound_one {χ : Multiplicative ℚ →* Kˣ}
+    (hχ : ∀ k : ℤ, χ (Multiplicative.ofAdd (k : ℚ)) = 1) {z : HahnSeries ℚ K}
+    (hz : HahnSeries.HasRamBound 1 z) : twist χ z = z := by
+  ext q
+  rw [coeff_twist]
+  by_cases hq : q ∈ z.support
+  · obtain ⟨k, hk⟩ := hz hq
+    simp only [Nat.cast_one, div_one] at hk
+    rw [← hk, hχ k, Units.val_one, one_mul]
+  · rw [HahnSeries.mem_support, not_not] at hq
+    rw [hq, mul_zero]
+
+section Character
+
+variable [IsAlgClosed K] (ζ : Kˣ)
+
+noncomputable def rootSeq : ℕ → Kˣ
+  | 0 => ζ
+  | m + 1 =>
+    Units.mk0 (Classical.choose (IsAlgClosed.exists_pow_nat_eq ((rootSeq m : Kˣ) : K) m.succ_pos))
+      (by
+        intro h0
+        have h :=
+          Classical.choose_spec (IsAlgClosed.exists_pow_nat_eq ((rootSeq m : Kˣ) : K) m.succ_pos)
+        rw [h0, zero_pow (Nat.succ_ne_zero m)] at h
+        exact (rootSeq m).ne_zero h.symm)
+
+theorem rootSeq_zero : rootSeq ζ 0 = ζ := rfl
+
+theorem rootSeq_succ_pow (m : ℕ) : (rootSeq ζ (m + 1)) ^ (m + 1) = rootSeq ζ m := by
+  apply Units.ext
+  rw [Units.val_pow_eq_pow_val]
+  change (Classical.choose (IsAlgClosed.exists_pow_nat_eq ((rootSeq ζ m : Kˣ) : K) m.succ_pos)) ^
+    (m+1) = _
+  exact Classical.choose_spec (IsAlgClosed.exists_pow_nat_eq ((rootSeq ζ m : Kˣ) : K) m.succ_pos)
+
+theorem rootSeq_add_pow (m j : ℕ) :
+    (rootSeq ζ (m + j)) ^ ((m + j).factorial / m.factorial) = rootSeq ζ m := by
+  induction j with
+  | zero => simp [Nat.div_self (Nat.factorial_pos m)]
+  | succ j ih =>
+    rw [← add_assoc, Nat.factorial_succ, Nat.mul_div_assoc _ (Nat.factorial_dvd_factorial
+      (Nat.le_add_right m j)),
+      pow_mul, rootSeq_succ_pow, ih]
+
+theorem rootSeq_pow_of_le {m M : ℕ} (h : m ≤ M) :
+    (rootSeq ζ M) ^ (M.factorial / m.factorial) = rootSeq ζ m := by
+  obtain ⟨j, rfl⟩ := Nat.exists_eq_add_of_le h
+  exact rootSeq_add_pow ζ m j
+
+variable (b : ℕ)
+
+noncomputable def charFun (x : ℚ) : Kˣ :=
+  (rootSeq ζ x.den) ^ (x.num * (((b * x.den.factorial) / x.den : ℕ) : ℤ))
+
+variable {b}
+
+theorem charFun_eq (x : ℚ) (m : ℕ) (k : ℤ) (hk : x * ((b * m.factorial : ℕ) : ℚ) = k) :
+    charFun ζ b x = (rootSeq ζ m) ^ k := by
+  have hd0 : x.den ≠ 0 := x.den_nz
+  have hdvd : x.den ∣ x.den.factorial := Nat.dvd_factorial x.den_pos le_rfl
+  rw [charFun, ← rootSeq_pow_of_le ζ (Nat.le_add_right x.den m),
+    ← rootSeq_pow_of_le ζ (Nat.le_add_left m x.den),
+    ← zpow_natCast, ← zpow_natCast, ← zpow_mul, ← zpow_mul]
+  congr 1
+  apply mul_left_cancel₀ (show (x.den : ℤ) ≠ 0 by exact_mod_cast hd0)
+  have e1 : (((x.den + m).factorial / x.den.factorial : ℕ) : ℤ) * (x.den.factorial : ℤ)
+      = ((x.den + m).factorial : ℤ) := by
+    exact_mod_cast Nat.div_mul_cancel (Nat.factorial_dvd_factorial (Nat.le_add_right x.den m))
+  have e2 : (((b * x.den.factorial) / x.den : ℕ) : ℤ) * (x.den : ℤ) = b * x.den.factorial := by
+    exact_mod_cast Nat.div_mul_cancel (Dvd.dvd.mul_left hdvd b)
+  have e3 : (((x.den + m).factorial / m.factorial : ℕ) : ℤ) * (m.factorial : ℤ) = ((x.den +
+    m).factorial : ℤ) :=
+    by
+    exact_mod_cast Nat.div_mul_cancel (Nat.factorial_dvd_factorial (Nat.le_add_left m x.den))
+  have e4 : (k : ℤ) * x.den = x.num * (b * m.factorial : ℕ) := by
+    have hq : (k : ℚ) * x.den = x.num * (b * m.factorial : ℕ) := by
+      rw [← hk, mul_right_comm, Rat.mul_den_eq_num]
+    exact_mod_cast hq
+  calc (x.den : ℤ) * ((((x.den + m).factorial / x.den.factorial : ℕ) : ℤ)
+          * (x.num * (((b * x.den.factorial) / x.den : ℕ) : ℤ)))
+      = x.num * ((((b * x.den.factorial) / x.den : ℕ) : ℤ) * x.den)
+          * (((x.den + m).factorial / x.den.factorial : ℕ) : ℤ) := by ring
+    _ = x.num * (b * x.den.factorial) * (((x.den + m).factorial / x.den.factorial : ℕ) : ℤ) := by
+      rw [e2]
+    _ = x.num * b * ((((x.den + m).factorial / x.den.factorial : ℕ) : ℤ) * x.den.factorial) := by
+      ring
+    _ = x.num * b * ((x.den + m).factorial : ℤ) := by rw [e1]
+    _ = x.num * b * ((((x.den + m).factorial / m.factorial : ℕ) : ℤ) * m.factorial) := by rw [e3]
+    _ = (x.num * (b * m.factorial : ℕ)) * (((x.den + m).factorial / m.factorial : ℕ) : ℤ) := by
+          push_cast; ring
+    _ = (k * x.den) * (((x.den + m).factorial / m.factorial : ℕ) : ℤ) := by rw [e4]
+    _ = (x.den : ℤ) * ((((x.den + m).factorial / m.factorial : ℕ) : ℤ) * k) := by ring
+
+theorem exists_int_eq (b : ℕ) (x : ℚ) (m : ℕ) (hm : x.den ∣ m.factorial) :
+    ∃ k : ℤ, x * ((b * m.factorial : ℕ) : ℚ) = k := by
+  obtain ⟨c, hc⟩ := Dvd.dvd.mul_left hm b
+  refine ⟨x.num * c, ?_⟩
+  rw [hc]
+  push_cast
+  rw [← mul_assoc, Rat.mul_den_eq_num]
+
+variable (b)
+
+noncomputable def char : Multiplicative ℚ →* Kˣ where
+  toFun q := charFun ζ b (Multiplicative.toAdd q)
+  map_one' := by
+    change charFun ζ b 0 = 1
+    rw [charFun_eq ζ 0 0 0 (by simp), zpow_zero]
+  map_mul' x y := by
+    change charFun ζ b (Multiplicative.toAdd x + Multiplicative.toAdd y)
+      = charFun ζ b (Multiplicative.toAdd x) * charFun ζ b (Multiplicative.toAdd y)
+    have hm0 : 0 < (Multiplicative.toAdd x).den * (Multiplicative.toAdd y).den :=
+      Nat.pos_of_ne_zero (Nat.mul_ne_zero (Multiplicative.toAdd x).den_nz (Multiplicative.toAdd
+        y).den_nz)
+    have hfac : (Multiplicative.toAdd x).den * (Multiplicative.toAdd y).den ∣
+        ((Multiplicative.toAdd x).den * (Multiplicative.toAdd y).den).factorial :=
+      Nat.dvd_factorial hm0 le_rfl
+    have hu : (Multiplicative.toAdd x).den ∣
+        ((Multiplicative.toAdd x).den * (Multiplicative.toAdd y).den).factorial :=
+      (Dvd.intro _ rfl).trans hfac
+    have hv : (Multiplicative.toAdd y).den ∣
+        ((Multiplicative.toAdd x).den * (Multiplicative.toAdd y).den).factorial :=
+      (Dvd.intro_left _ rfl).trans hfac
+    have huv : (Multiplicative.toAdd x + Multiplicative.toAdd y).den ∣
+        ((Multiplicative.toAdd x).den * (Multiplicative.toAdd y).den).factorial :=
+      (Rat.add_den_dvd _ _).trans hfac
+    obtain ⟨ku, hku⟩ := exists_int_eq b _ _ hu
+    obtain ⟨kv, hkv⟩ := exists_int_eq b _ _ hv
+    have hkuv : (Multiplicative.toAdd x + Multiplicative.toAdd y)
+        * ((b * ((Multiplicative.toAdd x).den * (Multiplicative.toAdd y).den).factorial : ℕ) : ℚ)
+        = (ku + kv : ℤ) := by
+      rw [add_mul, hku, hkv]
+      push_cast
+      ring
+    rw [charFun_eq ζ _ _ _ hkuv, charFun_eq ζ _ _ _ hku, charFun_eq ζ _ _ _ hkv, zpow_add]
+
+theorem char_apply (x : ℚ) : char ζ b (Multiplicative.ofAdd x) = charFun ζ b x := rfl
+
+variable {b}
+
+theorem char_intCast (hζ : ζ ^ b = 1) (k : ℤ) :
+    char ζ b (Multiplicative.ofAdd (k : ℚ)) = 1 := by
+  rw [char_apply, charFun_eq ζ (k : ℚ) 0 (k * b) (by push_cast; simp), rootSeq_zero,
+    mul_comm, zpow_mul, zpow_natCast, hζ, one_zpow]
+
+theorem char_div (hb : 0 < b) (a : ℤ) :
+    char ζ b (Multiplicative.ofAdd ((a : ℚ) / b)) = ζ ^ a := by
+  have hb' : (b : ℚ) ≠ 0 := by exact_mod_cast hb.ne'
+  rw [char_apply, charFun_eq ζ ((a : ℚ) / b) 0 a (by push_cast; simp; field_simp), rootSeq_zero]
+
+end Character
+
+def twistRingEquiv (χ : Multiplicative ℚ →* Kˣ) : HahnSeries ℚ K ≃+* HahnSeries ℚ K where
+  toFun := twist χ
+  invFun := twist χ⁻¹
+  left_inv x := by
+    ext q
+    rw [coeff_twist, coeff_twist, MonoidHom.inv_apply, ← mul_assoc, Units.inv_mul, one_mul]
+  right_inv x := by
+    ext q
+    rw [coeff_twist, coeff_twist, MonoidHom.inv_apply, ← mul_assoc, Units.mul_inv, one_mul]
+  map_mul' := twist_mul χ
+  map_add' := twist_add χ
+
+@[scoped simp] theorem twistRingEquiv_apply (χ : Multiplicative ℚ →* Kˣ) (x : HahnSeries ℚ K) :
+    twistRingEquiv χ x = twist χ x := rfl
+
+theorem twist_zero (χ : Multiplicative ℚ →* Kˣ) : twist χ (0 : HahnSeries ℚ K) = 0 :=
+  map_zero (twistRingHom χ)
+
+theorem orderTop_twist (χ : Multiplicative ℚ →* Kˣ) (z : HahnSeries ℚ K) :
+    (twist χ z).orderTop = z.orderTop := by
+  by_cases hz : z = 0
+  · subst hz
+    rw [twist_zero]
+  · have hz' : twist χ z ≠ 0 := by
+      intro h
+      apply hz
+      rw [← HahnSeries.support_eq_empty_iff] at h ⊢
+      rwa [support_twist] at h
+    first
+      | rw [HahnSeries.orderTop_of_ne_zero hz, HahnSeries.orderTop_of_ne_zero hz',
+        WithTop.coe_eq_coe]
+    apply le_antisymm
+    · exact Set.IsWF.min_le _ _ (by rw [support_twist]; exact Set.IsWF.min_mem _ _)
+    · exact Set.IsWF.min_le _ _ (by rw [← support_twist χ z]; exact Set.IsWF.min_mem _ _)
+
+end HahnSeries.PuiseuxTwist
+
+open HahnSeries.PuiseuxTwist in
+theorem solution
+    {K : Type*} [Field K] [IsAlgClosed K] [CharZero K] {x : HahnSeries ℚ K}
+    (hx : ∀ σ : HahnSeries ℚ K ≃+* HahnSeries ℚ K,
+      (∀ z : HahnSeries ℚ K, (σ z).orderTop = z.orderTop) →
+      (∀ z : HahnSeries ℚ K, HahnSeries.HasRamBound 1 z → σ z = z) → σ x = x) :
+    HahnSeries.HasRamBound 1 x := by
+  intro q hq
+  have hb : 0 < q.den := q.den_pos
+  have : NeZero q.den := ⟨q.den_nz⟩
+  obtain ⟨μ, hμ⟩ := HasEnoughRootsOfUnity.exists_primitiveRoot K q.den
+  obtain ⟨ζ, rfl⟩ : IsUnit μ := by
+    first | exact hμ.isUnit q.den_nz
+  have hζ : IsPrimitiveRoot ζ q.den := IsPrimitiveRoot.coe_units_iff.mp hμ
+  have hζ1 : ζ ^ q.den = 1 := hζ.pow_eq_one
+  have hfix : twist (char ζ q.den) x = x := by
+    have h := hx (twistRingEquiv (char ζ q.den))
+      (fun z => by rw [twistRingEquiv_apply]; exact orderTop_twist _ z)
+      (fun z hz => by
+        rw [twistRingEquiv_apply]; exact twist_eq_self_of_hasRamBound_one (char_intCast ζ hζ1) hz)
+    rwa [twistRingEquiv_apply] at h
+  have hc : ((char ζ q.den (Multiplicative.ofAdd q) : Kˣ) : K) * x.coeff q = x.coeff q := by
+    have h := congrArg (fun y : HahnSeries ℚ K => y.coeff q) hfix
+    simpa only [coeff_twist] using h
+  have hxq : x.coeff q ≠ 0 := by rwa [HahnSeries.mem_support] at hq
+  have hc1 : ((char ζ q.den (Multiplicative.ofAdd q) : Kˣ) : K) = 1 :=
+    mul_right_cancel₀ hxq (hc.trans (one_mul _).symm)
+  have hval : char ζ q.den (Multiplicative.ofAdd q) = ζ ^ q.num := by
+    have e : Multiplicative.ofAdd q = Multiplicative.ofAdd ((q.num : ℚ) / (q.den : ℚ)) := by
+      rw [Rat.num_div_den]
+    rw [e, char_div ζ hb]
+  have hpow : ζ ^ q.num = 1 := by
+    rw [← hval]
+    exact Units.val_eq_one.mp hc1
+  have hdvd : (q.den : ℤ) ∣ q.num := (hζ.zpow_eq_one_iff_dvd q.num).mp hpow
+  have hdvd' : q.den ∣ q.num.natAbs := by
+    have h := Int.natAbs_dvd_natAbs.mpr hdvd
+    rwa [Int.natAbs_natCast] at h
+  have hden : q.den = 1 := Nat.Coprime.eq_one_of_dvd (Nat.Coprime.symm q.reduced) hdvd'
+  refine ⟨q.num, ?_⟩
+  have h := Rat.num_div_den q
+  rw [hden] at h
+  simpa only [Nat.cast_one, div_one] using h
+
+end S_HahnSeries_hasRamBound_one_of_forall_ringEquiv_apply_eq
+end P2MW
+export P2MW.S_HahnSeries_hasRamBound_one_of_forall_ringEquiv_apply_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem HahnSeries.hasRamBound_one_of_forall_ringEquiv_apply_eq
+    {K : Type*} [Field K] [IsAlgClosed K] [CharZero K] {x : HahnSeries ℚ K}
+    (hx : ∀ σ : HahnSeries ℚ K ≃+* HahnSeries ℚ K,
+      (∀ z : HahnSeries ℚ K, (σ z).orderTop = z.orderTop) →
+      (∀ z : HahnSeries ℚ K, HahnSeries.HasRamBound 1 z → σ z = z) → σ x = x) :
+    HahnSeries.HasRamBound 1 x :=
+  solution hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_hasRamBound_single_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_hasRamBound_single_one.lean
new file mode 100644
index 0000000000..479638fe5c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_hasRamBound_single_one.lean
@@ -0,0 +1,208 @@
+/-
+Based on Prove2Me node HahnSeries.hasRamBound_single_one
+(825977ce-bce1-565e-a85b-a0770e5dcedd) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 27f48f0f-8e57-5e36-afc4-a5223cd25172
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_RamificationBound
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_mem_puiseuxRamSubfield_iff
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The term c t has ramification bound e
+
+Theorem statement: `HahnSeries.hasRamBound_single_one` (`825977ce-bce1-565e-a85b-a0770e5dcedd`), by
+Claude, 2026-09-05.
+
+Proof: submission `27f48f0f-8e57-5e36-afc4-a5223cd25172`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, let $e$ be a natural number with $0 < e$, and let $c \in K$. Consider the Hahn
+series over $K$ with value group $\mathbb{Q}$ given by the single term `single (1 : ℚ) c`, that is,
+the series whose coefficient at the exponent $1$ is $c$ and whose coefficients at all other rational
+exponents vanish. The assertion is that this series satisfies `HasRamBound e`, which by definition
+means that its support — the set of rational exponents at which its coefficient is nonzero — is
+contained in the set $\{k/e : k \in \mathbb{Z}\}$ of rationals with denominator dividing $e$.
+Concretely, the support is $\{1\}$ when $c \neq 0$ and is empty when $c = 0$, and $1 = e/e$ lies in
+the stated range; no hypothesis is imposed on $c$. The positivity of $e$ is needed, since for $e =
+0$ every quotient $k/e$ equals $0$ and the conclusion would fail for $c \neq 0$.
+
+This records that the variable $t$, scaled by an arbitrary constant, lies in the ramification-$e$
+part of the Hahn series field $\mathbb{Q}$-graded over $K$, i.e. in $K((t^{1/e}))$ for every $e \geq
+1$. It is used in the analysis of roots of the modular equation, via
+[`ModularCurve.ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound`]
+(thm.html#ModularCurve.ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HahnSeries_hasRamBound_single_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HahnSeries_hasRamBound_single_one
+
+namespace HahnSeries
+p2m_export "HahnSeries" "support C_apply support_single_subset support_one single support_zero \
+  support_mul_subset support_add_subset C support_neg ramScale puiseuxRamEmb HasRamBound \
+  puiseuxRamSubfield mem_puiseuxRamSubfield_iff"
+p2m_open "HahnSeries"
+
+variable {K : Type*} [Field K] {e : ℕ}
+
+private lemma ramRange_zero_mem : (0 : ℚ) ∈ Set.range (fun k : ℤ => (k : ℚ) / e) :=
+  ⟨0, by simp⟩
+
+private lemma ramRange_add_mem {q r : ℚ} (hq : q ∈ Set.range (fun k : ℤ => (k : ℚ) / e))
+    (hr : r ∈ Set.range (fun k : ℤ => (k : ℚ) / e)) :
+    q + r ∈ Set.range (fun k : ℤ => (k : ℚ) / e) := by
+  obtain ⟨k, rfl⟩ := hq
+  obtain ⟨l, rfl⟩ := hr
+  exact ⟨k + l, by push_cast [add_div]; rfl⟩
+
+private theorem hasRamBound_zero : HasRamBound e (0 : HahnSeries ℚ K) := by
+  intro g hg
+  simp [HahnSeries.support_zero] at hg
+
+private theorem hasRamBound_one : HasRamBound e (1 : HahnSeries ℚ K) := by
+  intro g hg
+  rw [support_one, Set.mem_singleton_iff] at hg
+  exact hg ▸ ramRange_zero_mem
+
+private theorem hasRamBound_C (a : K) : HasRamBound e (C a : HahnSeries ℚ K) := by
+  intro g hg
+  rw [C_apply] at hg
+  have := support_single_subset hg
+  rw [Set.mem_singleton_iff] at this
+  exact this ▸ ramRange_zero_mem
+
+private theorem hasRamBound_natCast (n : ℕ) : HasRamBound e ((n : HahnSeries ℚ K)) := by
+  rw [← map_natCast (C (Γ := ℚ) (R := K)) n]
+  exact hasRamBound_C _
+
+private theorem hasRamBound_intCast (m : ℤ) : HasRamBound e ((m : HahnSeries ℚ K)) := by
+  rw [← map_intCast (C (Γ := ℚ) (R := K)) m]
+  exact hasRamBound_C _
+
+private theorem hasRamBound_single_intCast (he : 0 < e) (k : ℤ) (c : K) :
+    HasRamBound e (single ((k : ℤ) : ℚ) c) := by
+  intro g hg
+  have hmem := support_single_subset hg
+  rw [Set.mem_singleton_iff] at hmem
+  subst hmem
+  refine ⟨k * e, ?_⟩
+  have he' : (e : ℚ) ≠ 0 := Nat.cast_ne_zero.mpr he.ne'
+  push_cast
+  field_simp
+
+private theorem hasRamBound_single_one (he : 0 < e) (c : K) :
+    HasRamBound e (single (1 : ℚ) c) := by
+  have h := hasRamBound_single_intCast (K := K) he 1 c
+  norm_num at h
+  exact h
+
+namespace HasRamBound
+private theorem _root_.HahnSeries.HasRamBound.add {x y : HahnSeries ℚ K} (hx : HasRamBound e x)
+    (hy : HasRamBound e y) : HasRamBound e (x + y) := by
+  intro g hg
+  rcases support_add_subset x y hg with h | h
+  · exact hx h
+  · exact hy h
+
+end HasRamBound
+p2m_export "HahnSeries" "HasRamBound.add"
+namespace HasRamBound
+private theorem _root_.HahnSeries.HasRamBound.neg {x : HahnSeries ℚ K} (hx : HasRamBound e x) :
+    HasRamBound e (-x) := fun g hg => hx (by rwa [support_neg] at hg)
+
+end HasRamBound
+p2m_export "HahnSeries" "HasRamBound.neg"
+private theorem HasRamBound.sub {x y : HahnSeries ℚ K} (hx : HasRamBound e x)
+    (hy : HasRamBound e y) : HasRamBound e (x - y) := by
+  rw [sub_eq_add_neg]
+  exact hx.add hy.neg
+
+namespace HasRamBound
+private theorem _root_.HahnSeries.HasRamBound.mul {x y : HahnSeries ℚ K} (hx : HasRamBound e x)
+    (hy : HasRamBound e y) : HasRamBound e (x * y) := by
+  intro g hg
+  have := support_mul_subset (x := x) (y := y) hg
+  obtain ⟨a, ha, b, hb, rfl⟩ := Set.mem_add.mp this
+  exact ramRange_add_mem (hx ha) (hy hb)
+
+end HasRamBound
+p2m_export "HahnSeries" "HasRamBound.mul"
+private theorem HasRamBound.pow {x : HahnSeries ℚ K} (hx : HasRamBound e x) (n : ℕ) :
+    HasRamBound e (x ^ n) := by
+  induction n with
+  | zero => simpa using hasRamBound_one
+  | succ n ih => rw [pow_succ]; exact ih.mul hx
+
+private theorem HasRamBound.mono {d d' : ℕ} (hdd' : d ∣ d') (hd' : 0 < d')
+    {y : HahnSeries ℚ K} (h : HasRamBound d y) : HasRamBound d' y := by
+  intro g hg
+  obtain ⟨k, hk⟩ := h hg
+  rcases Nat.eq_zero_or_pos d with rfl | hd
+  · refine ⟨0, ?_⟩
+    simp only [Nat.cast_zero, div_zero] at hk
+    rw [← hk]
+    simp
+  · obtain ⟨c, rfl⟩ := hdd'
+    have hc : (c : ℚ) ≠ 0 := by
+      have hc0 : c ≠ 0 := by rintro rfl; omega
+      exact_mod_cast hc0
+    refine ⟨k * c, ?_⟩
+    rw [← hk]
+    push_cast
+    rw [mul_div_mul_right _ _ hc]
+
+namespace HasRamBound
+private theorem _root_.HahnSeries.HasRamBound.inv (he : 0 < e) {y : HahnSeries ℚ K}
+    (hy : HasRamBound e y) : HasRamBound e y⁻¹ :=
+  (mem_puiseuxRamSubfield_iff he).mp (inv_mem ((mem_puiseuxRamSubfield_iff he).mpr hy))
+
+end HasRamBound
+p2m_export "HahnSeries" "HasRamBound.inv"
+private theorem HasRamBound.div (he : 0 < e) {x y : HahnSeries ℚ K}
+    (hx : HasRamBound e x) (hy : HasRamBound e y) : HasRamBound e (x / y) := by
+  rw [div_eq_mul_inv]
+  exact hx.mul (hy.inv he)
+
+end HahnSeries
+
+open _root_.HahnSeries _root_.P2MW.S_HahnSeries_hasRamBound_single_one.HahnSeries in
+theorem solution {K : Type*} [Field K] {e : ℕ} (he : 0 < e) (c : K) :
+    HasRamBound e (single (1 : ℚ) c) :=
+  HahnSeries.hasRamBound_single_one he c
+
+end S_HahnSeries_hasRamBound_single_one
+end P2MW
+export P2MW.S_HahnSeries_hasRamBound_single_one (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open HahnSeries
+theorem HahnSeries.hasRamBound_single_one {K : Type*} [Field K] {e : ℕ} (he : 0 < e) (c : K) :
+    HasRamBound e (single (1 : ℚ) c) :=
+  solution he c
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_isAlgClosed_rat.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_isAlgClosed_rat.lean
new file mode 100644
index 0000000000..9efac7d13b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_isAlgClosed_rat.lean
@@ -0,0 +1,1006 @@
+/-
+Based on Prove2Me node HahnSeries.isAlgClosed_rat
+(bbdcd0be-dc4a-5b24-8384-19f4973c64d8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b71ab900-9f10-587a-bd90-c423ad74768e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+public import Mathlib.RingTheory.HahnSeries.Summable
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Rat.Star
+import Mathlib.RingTheory.HahnSeries.Valuation
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Hahn series with rational exponents over an algebraically closed field
+
+Theorem statement: `HahnSeries.isAlgClosed_rat` (`bbdcd0be-dc4a-5b24-8384-19f4973c64d8`), by Claude,
+2026-09-05.
+
+Proof: submission `b71ab900-9f10-587a-bd90-c423ad74768e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field which is algebraically closed. The assertion is that the Hahn series field
+$\mathrm{HahnSeries}\ \mathbb{Q}\ K$ — the Mal'cev–Neumann field of formal series
+$\sum_{q\in\mathbb{Q}} a_q t^q$ with coefficients $a_q \in K$ whose support $\{q : a_q \neq 0\}$ is
+a well-ordered subset of $\mathbb{Q}$, with the usual pointwise addition and convolution product, a
+field because $\mathbb{Q}$ is a linearly ordered abelian group and $K$ is a field — is itself
+algebraically closed, in the sense of Mathlib's `IsAlgClosed`: every polynomial of positive degree
+over $\mathrm{HahnSeries}\ \mathbb{Q}\ K$ has a root in $\mathrm{HahnSeries}\ \mathbb{Q}\ K$. No
+hypothesis is placed on the characteristic of $K$, so the statement covers both the
+characteristic-zero case, where the Puiseux subfield $\bigcup_{e \geq 1} K((t^{1/e}))$ already
+exhausts the algebraic closure of $K((t))$, and characteristic $p$, where roots may have support of
+order type beyond that of Puiseux series.
+
+In particular $\mathrm{HahnSeries}\ \mathbb{Q}\ K$ receives an embedding of the algebraic closure of
+$K((t))$, since it is an algebraically closed field containing $K((t))$.
+
+This is the algebraic closedness of Hahn (Mal'cev–Neumann) series fields with divisible value group
+and algebraically closed residue field, in the form going back to Mac Lane and Kaplansky's theory of
+maximally complete valued fields; it is the generalised Newton–Puiseux theorem. It is used in the
+project to embed local data at a place of a curve into a field of series with rational exponents,
+for instance in the computations of ramification profiles and in the specialisation arguments for
+modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HahnSeries_isAlgClosed_rat.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HahnSeries_isAlgClosed_rat
+
+open Polynomial HahnSeries
+
+noncomputable section
+
+namespace DorgePuiseux
+
+variable {K : Type*} [Field K]
+
+def newtonInitialForm (f : (HahnSeries ℚ K)[X]) (γ : ℚ) : K[X] :=
+  ∑ i ∈ Finset.range (f.natDegree + 1),
+    Polynomial.C ((f.coeff i).coeff ((f.natDegree - i : ℕ) • γ)) * Polynomial.X ^ i
+
+theorem newtonInitialForm_coeff (f : (HahnSeries ℚ K)[X]) (γ : ℚ) (k : ℕ)
+    (hk : k ≤ f.natDegree) :
+    (newtonInitialForm f γ).coeff k = (f.coeff k).coeff ((f.natDegree - k : ℕ) • γ) := by
+  unfold newtonInitialForm
+  rw [Polynomial.finsetSum_coeff]
+  rw [Finset.sum_eq_single k]
+  · simp
+  · intro j _ hj
+    simp only [Polynomial.coeff_C_mul, Polynomial.coeff_X_pow, ite_eq_right (Ne.symm hj), mul_zero]
+  · intro h
+    exact absurd (Finset.mem_range.mpr (Nat.lt_succ_of_le hk)) h
+
+theorem newtonInitialForm_natDegree_le (f : (HahnSeries ℚ K)[X]) (γ : ℚ) :
+    (newtonInitialForm f γ).natDegree ≤ f.natDegree := by
+  refine Polynomial.natDegree_sum_le_of_forall_le _ _ fun i hi => ?_
+  refine (Polynomial.natDegree_C_mul_le _ _).trans ?_
+  rw [Polynomial.natDegree_X_pow]
+  exact Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)
+
+theorem newtonInitialForm_coeff_natDegree {f : (HahnSeries ℚ K)[X]} (hf : f.Monic) (γ : ℚ) :
+    (newtonInitialForm f γ).coeff f.natDegree = 1 := by
+  rw [newtonInitialForm_coeff f γ f.natDegree le_rfl, Nat.sub_self, zero_smul,
+    Polynomial.Monic.coeff_natDegree hf]
+  simp [HahnSeries.coeff_one]
+
+theorem newtonInitialForm_monic {f : (HahnSeries ℚ K)[X]} (hf : f.Monic) (γ : ℚ) :
+    (newtonInitialForm f γ).Monic := by
+  rw [Polynomial.Monic, Polynomial.leadingCoeff,
+    show (newtonInitialForm f γ).natDegree = f.natDegree from
+      le_antisymm (newtonInitialForm_natDegree_le f γ)
+        (Polynomial.le_natDegree_of_ne_zero
+          (by rw [newtonInitialForm_coeff_natDegree hf]; exact one_ne_zero))]
+  exact newtonInitialForm_coeff_natDegree hf γ
+
+theorem newtonInitialForm_natDegree {f : (HahnSeries ℚ K)[X]} (hf : f.Monic) (γ : ℚ) :
+    (newtonInitialForm f γ).natDegree = f.natDegree :=
+  le_antisymm (newtonInitialForm_natDegree_le f γ)
+    (Polynomial.le_natDegree_of_ne_zero
+      (by rw [newtonInitialForm_coeff_natDegree hf]; exact one_ne_zero))
+
+private theorem nsmul_sub_nsmul {n i : ℕ} (hi : i ≤ n) (γ : ℚ) :
+    n • γ - i • γ = (n - i : ℕ) • γ := by
+  rw [eq_comm, eq_sub_iff_add_eq, ← add_nsmul, Nat.sub_add_cancel hi]
+
+theorem coeff_eval_single (f : (HahnSeries ℚ K)[X]) (γ : ℚ) (c : K) (g : ℚ) :
+    (f.eval (HahnSeries.single γ c)).coeff g =
+      ∑ i ∈ Finset.range (f.natDegree + 1), (f.coeff i).coeff (g - i • γ) * c ^ i := by
+  rw [Polynomial.eval_eq_sum_range, HahnSeries.coeff_sum]
+  refine Finset.sum_congr rfl fun i hi => ?_
+  rw [HahnSeries.single_pow, HahnSeries.coeff_mul_single]
+
+theorem coeff_eval_single_top (f : (HahnSeries ℚ K)[X]) (γ : ℚ) (c : K) :
+    (f.eval (HahnSeries.single γ c)).coeff (f.natDegree • γ) =
+      (newtonInitialForm f γ).eval c := by
+  rw [coeff_eval_single, newtonInitialForm, Polynomial.eval_finsetSum]
+  refine Finset.sum_congr rfl fun i hi => ?_
+  rw [nsmul_sub_nsmul (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)),
+    Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_pow, Polynomial.eval_X]
+
+def IsNewtonSlopeBound (f : (HahnSeries ℚ K)[X]) (γ : ℚ) : Prop :=
+  ∀ i ≤ f.natDegree, f.coeff i ≠ 0 → (f.natDegree - i : ℕ) • γ ≤ (f.coeff i).order
+
+theorem coeff_eval_single_of_lt {f : (HahnSeries ℚ K)[X]} {γ : ℚ}
+    (hslope : IsNewtonSlopeBound f γ) (c : K) {g : ℚ} (hg : g < f.natDegree • γ) :
+    (f.eval (HahnSeries.single γ c)).coeff g = 0 := by
+  rw [coeff_eval_single]
+  refine Finset.sum_eq_zero fun i hi => ?_
+  have hin : i ≤ f.natDegree := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)
+  rcases eq_or_ne (f.coeff i) 0 with hzero | hne
+  · simp [hzero]
+  · have hlt : g - i • γ < (f.coeff i).order := by
+      calc g - i • γ < f.natDegree • γ - i • γ := by linarith
+        _ = (f.natDegree - i : ℕ) • γ := nsmul_sub_nsmul hin γ
+        _ ≤ (f.coeff i).order := hslope i hin hne
+    rw [HahnSeries.coeff_eq_zero_of_lt_order hlt, zero_mul]
+
+theorem newtonStep_orderTop_lt {f : (HahnSeries ℚ K)[X]} {γ : ℚ}
+    (hslope : IsNewtonSlopeBound f γ) {c : K} (hc : (newtonInitialForm f γ).IsRoot c) :
+    ((f.natDegree • γ : ℚ) : WithTop ℚ) <
+      (f.eval (HahnSeries.single γ c)).orderTop := by
+  rcases eq_or_ne (f.eval (HahnSeries.single γ c)) 0 with heq | hne
+  · rw [heq, HahnSeries.orderTop_zero]; exact WithTop.coe_lt_top _
+  · rw [← HahnSeries.order_eq_orderTop_of_ne_zero hne, WithTop.coe_lt_coe]
+    by_contra hle
+    push Not at hle
+    rcases lt_or_eq_of_le hle with hlt | heq
+    · have horder : (f.eval (HahnSeries.single γ c)).coeff
+          (f.eval (HahnSeries.single γ c)).order ≠ 0 :=
+        HahnSeries.coeff_order_eq_zero.not.mpr hne
+      exact horder (coeff_eval_single_of_lt hslope c hlt)
+    · have horder : (f.eval (HahnSeries.single γ c)).coeff (f.natDegree • γ) ≠ 0 := by
+        rw [← heq]; exact HahnSeries.coeff_order_eq_zero.not.mpr hne
+      rw [coeff_eval_single_top, Polynomial.IsRoot.eq_zero hc] at horder
+      exact horder rfl
+
+theorem newtonStep_addVal_lt {f : (HahnSeries ℚ K)[X]} {γ : ℚ}
+    (hslope : IsNewtonSlopeBound f γ) {c : K} (hc : (newtonInitialForm f γ).IsRoot c) :
+    ((f.natDegree • γ : ℚ) : WithTop ℚ) <
+      HahnSeries.addVal ℚ K (f.eval (HahnSeries.single γ c)) := by
+  rw [HahnSeries.addVal_apply]; exact newtonStep_orderTop_lt hslope hc
+
+private def slopeSupport (f : (HahnSeries ℚ K)[X]) [DecidablePred (f.coeff · ≠ 0)] : Finset ℕ :=
+  (Finset.range f.natDegree).filter (fun j => f.coeff j ≠ 0)
+
+private theorem slopeSupport_nonempty {f : (HahnSeries ℚ K)[X]} [DecidablePred (f.coeff · ≠ 0)]
+    (hdeg : 1 ≤ f.natDegree) (h0 : f.coeff 0 ≠ 0) : (slopeSupport f).Nonempty :=
+  ⟨0, Finset.mem_filter.mpr ⟨Finset.mem_range.mpr hdeg, h0⟩⟩
+
+theorem exists_newtonSlope {f : (HahnSeries ℚ K)[X]} (hf : f.Monic)
+    (hdeg : 1 ≤ f.natDegree) (h0 : f.coeff 0 ≠ 0) :
+    ∃ γ : ℚ, IsNewtonSlopeBound f γ ∧
+      ∃ j < f.natDegree, (newtonInitialForm f γ).coeff j ≠ 0 := by
+  classical
+  set n := f.natDegree
+  set φ : ℕ → ℚ := fun j => (f.coeff j).order / (n - j : ℕ)
+  obtain ⟨j₀, hj₀mem, hj₀min⟩ :=
+    Finset.exists_min_image (slopeSupport f) φ (slopeSupport_nonempty hdeg h0)
+  set γ : ℚ := φ j₀
+  obtain ⟨hj₀lt, hj₀ne⟩ := Finset.mem_filter.mp hj₀mem
+  rw [Finset.mem_range] at hj₀lt
+  have hnj₀pos : (0 : ℚ) < ((n - j₀ : ℕ) : ℚ) := by
+    exact_mod_cast Nat.sub_pos_of_lt hj₀lt
+  refine ⟨γ, ?_, j₀, hj₀lt, ?_⟩
+  · intro i hi hne
+    rcases lt_or_eq_of_le hi with hlt | heq
+    · have hmem : i ∈ slopeSupport f :=
+        Finset.mem_filter.mpr ⟨Finset.mem_range.mpr hlt, hne⟩
+      have hni : (0 : ℚ) < ((n - i : ℕ) : ℚ) := by
+        exact_mod_cast Nat.sub_pos_of_lt hlt
+      have hle : γ ≤ φ i := hj₀min i hmem
+      rw [nsmul_eq_mul]
+      calc ((n - i : ℕ) : ℚ) * γ ≤ ((n - i : ℕ) : ℚ) * φ i := by
+            exact mul_le_mul_of_nonneg_left hle (le_of_lt hni)
+        _ = (f.coeff i).order := by
+            simp only [φ]; field_simp
+    · subst heq
+      simp [hf.coeff_natDegree, HahnSeries.order_one]
+  · rw [newtonInitialForm_coeff f γ j₀ (le_of_lt hj₀lt)]
+    have heq : ((n - j₀ : ℕ) • γ : ℚ) = (f.coeff j₀).order := by
+      rw [nsmul_eq_mul]
+      simp only [γ, φ]; field_simp
+    rw [heq, ← HahnSeries.leadingCoeff_eq]
+    exact HahnSeries.leadingCoeff_ne_zero.mpr hj₀ne
+
+theorem exists_ne_zero_root_of_coeff_ne_zero [IsAlgClosed K] {p : K[X]} (hp : p.Monic)
+    {j : ℕ} (hj : j < p.natDegree) (hcoeff : p.coeff j ≠ 0) :
+    ∃ c, c ≠ 0 ∧ p.IsRoot c := by
+  by_contra h
+  push Not at h
+  have hsplit : p.Splits := IsAlgClosed.splits p
+  have hprod := hsplit.eq_prod_roots_of_monic hp
+  have hall0 : ∀ r ∈ p.roots, r = 0 := fun r hr =>
+    by_contra fun hne => (h r hne) (Polynomial.isRoot_of_mem_roots hr)
+  have hcard : p.roots.card = p.natDegree := IsAlgClosed.card_roots_eq_natDegree
+  have hroots : p.roots = Multiset.replicate p.natDegree 0 := by
+    rw [← hcard]
+    exact Multiset.eq_replicate_card.mpr hall0
+  rw [hroots] at hprod
+  simp only [Multiset.map_replicate, map_zero, sub_zero, Multiset.prod_replicate] at hprod
+  rw [hprod, Polynomial.coeff_X_pow] at hcoeff
+  exact hcoeff (ite_eq_right (Nat.ne_of_lt hj))
+
+theorem exists_newtonFirstApprox [IsAlgClosed K] {f : (HahnSeries ℚ K)[X]} (hf : f.Monic)
+    (hdeg : 1 ≤ f.natDegree) (h0 : f.coeff 0 ≠ 0) :
+    ∃ γ : ℚ, ∃ c : K, c ≠ 0 ∧
+      ((f.natDegree • γ : ℚ) : WithTop ℚ) <
+        HahnSeries.addVal ℚ K (f.eval (HahnSeries.single γ c)) := by
+  obtain ⟨γ, hslope, j, hjlt, hjcoeff⟩ := exists_newtonSlope hf hdeg h0
+  obtain ⟨c, hcne, hcroot⟩ := exists_ne_zero_root_of_coeff_ne_zero
+    (newtonInitialForm_monic hf γ) (by rwa [newtonInitialForm_natDegree hf]) hjcoeff
+  exact ⟨γ, c, hcne, newtonStep_addVal_lt hslope hcroot⟩
+
+theorem isRoot_zero_or_exists_newtonFirstApprox [IsAlgClosed K]
+    {f : (HahnSeries ℚ K)[X]} (hf : f.Monic) (hdeg : 1 ≤ f.natDegree) :
+    f.IsRoot 0 ∨ ∃ γ : ℚ, ∃ c : K, c ≠ 0 ∧
+      ((f.natDegree • γ : ℚ) : WithTop ℚ) <
+        HahnSeries.addVal ℚ K (f.eval (HahnSeries.single γ c)) := by
+  rcases eq_or_ne (f.coeff 0) 0 with h0 | h0
+  · left; rw [Polynomial.IsRoot, ← Polynomial.coeff_zero_eq_eval_zero, h0]
+  · right; exact exists_newtonFirstApprox hf hdeg h0
+
+end DorgePuiseux
+
+end
+
+open Polynomial HahnSeries
+
+noncomputable section
+
+namespace DorgePuiseux
+
+variable {K : Type*} [Field K]
+
+private def evalSlopeSupport (f : (HahnSeries ℚ K)[X])
+    [DecidablePred (f.coeff · ≠ 0)] : Finset ℕ :=
+  (Finset.range (f.natDegree + 1)).filter (fun j => 1 ≤ j ∧ f.coeff j ≠ 0)
+
+private theorem evalSlopeSupport_nonempty {f : (HahnSeries ℚ K)[X]} [DecidablePred (f.coeff · ≠ 0)]
+    (hf : f.Monic) (hdeg : 1 ≤ f.natDegree) : (evalSlopeSupport f).Nonempty :=
+  ⟨f.natDegree, Finset.mem_filter.mpr
+    ⟨Finset.self_mem_range_succ _, hdeg, by rw [hf.coeff_natDegree]; exact one_ne_zero⟩⟩
+
+private theorem mem_evalSlopeSupport {f : (HahnSeries ℚ K)[X]} {j : ℕ}
+    [DecidablePred (f.coeff · ≠ 0)] :
+    j ∈ evalSlopeSupport f ↔ j ≤ f.natDegree ∧ 1 ≤ j ∧ f.coeff j ≠ 0 := by
+  simp only [evalSlopeSupport, Finset.mem_filter, Finset.mem_range, Nat.lt_succ_iff]
+
+theorem exists_evalNewtonSlope {f : (HahnSeries ℚ K)[X]} (hf : f.Monic)
+    (hdeg : 1 ≤ f.natDegree) :
+    ∃ γ : ℚ,
+      (∀ j, 1 ≤ j → j ≤ f.natDegree → f.coeff j ≠ 0 →
+        (f.coeff 0).order ≤ (f.coeff j).order + j • γ) ∧
+      ∃ j₀, 1 ≤ j₀ ∧ j₀ ≤ f.natDegree ∧ f.coeff j₀ ≠ 0 ∧
+        (f.coeff 0).order = (f.coeff j₀).order + j₀ • γ := by
+  classical
+  set δ : ℚ := (f.coeff 0).order
+  set ψ : ℕ → ℚ := fun j => (δ - (f.coeff j).order) / (j : ℚ)
+  obtain ⟨j₀, hj₀mem, hj₀max⟩ :=
+    Finset.exists_max_image (evalSlopeSupport f) ψ (evalSlopeSupport_nonempty hf hdeg)
+  obtain ⟨hj₀le, hj₀1, hj₀ne⟩ := mem_evalSlopeSupport.mp hj₀mem
+  set γ : ℚ := ψ j₀
+  have hj₀pos : (0 : ℚ) < (j₀ : ℚ) := by exact_mod_cast hj₀1
+  refine ⟨γ, ?_, j₀, hj₀1, hj₀le, hj₀ne, ?_⟩
+  · intro j hj1 hjle hjne
+    have hjpos : (0 : ℚ) < (j : ℚ) := by exact_mod_cast hj1
+    have hmem : j ∈ evalSlopeSupport f := mem_evalSlopeSupport.mpr ⟨hjle, hj1, hjne⟩
+    have hle : ψ j ≤ γ := hj₀max j hmem
+    rw [nsmul_eq_mul]
+    have hmul : δ - (f.coeff j).order ≤ (j : ℚ) * γ := by
+      rw [div_le_iff₀ hjpos] at hle; linarith [hle]
+    linarith
+  · rw [nsmul_eq_mul]
+    have heq : (j₀ : ℚ) * γ = δ - (f.coeff j₀).order := by
+      simp only [γ, ψ]; field_simp
+    linarith
+
+def evalEdgeForm (f : (HahnSeries ℚ K)[X]) (γ : ℚ) : K[X] :=
+  ∑ j ∈ Finset.range (f.natDegree + 1),
+    Polynomial.C ((f.coeff j).coeff ((f.coeff 0).order - j • γ)) * Polynomial.X ^ j
+
+theorem evalEdgeForm_coeff (f : (HahnSeries ℚ K)[X]) (γ : ℚ) (k : ℕ) (hk : k ≤ f.natDegree) :
+    (evalEdgeForm f γ).coeff k = (f.coeff k).coeff ((f.coeff 0).order - k • γ) := by
+  unfold evalEdgeForm
+  rw [Polynomial.finsetSum_coeff]
+  rw [Finset.sum_eq_single k]
+  · simp
+  · intro j _ hj
+    simp only [Polynomial.coeff_C_mul, Polynomial.coeff_X_pow, ite_eq_right (Ne.symm hj), mul_zero]
+  · intro h
+    exact absurd (Finset.mem_range.mpr (Nat.lt_succ_of_le hk)) h
+
+theorem evalEdgeForm_coeff_zero (f : (HahnSeries ℚ K)[X]) (γ : ℚ) :
+    (evalEdgeForm f γ).coeff 0 = (f.coeff 0).leadingCoeff := by
+  rw [evalEdgeForm_coeff f γ 0 (Nat.zero_le _), zero_smul, sub_zero,
+    ← HahnSeries.leadingCoeff_eq]
+
+theorem evalEdgeForm_coeff_of_eq {f : (HahnSeries ℚ K)[X]} {γ : ℚ} {j₀ : ℕ}
+    (hj₀le : j₀ ≤ f.natDegree) (heq : (f.coeff 0).order = (f.coeff j₀).order + j₀ • γ) :
+    (evalEdgeForm f γ).coeff j₀ = (f.coeff j₀).leadingCoeff := by
+  rw [evalEdgeForm_coeff f γ j₀ hj₀le, heq, add_sub_cancel_right, ← HahnSeries.leadingCoeff_eq]
+
+theorem coeff_eval_single_order_zero (f : (HahnSeries ℚ K)[X]) (γ : ℚ) (c : K) :
+    (f.eval (HahnSeries.single γ c)).coeff (f.coeff 0).order =
+      (evalEdgeForm f γ).eval c := by
+  rw [coeff_eval_single, evalEdgeForm, Polynomial.eval_finsetSum]
+  refine Finset.sum_congr rfl fun j _ => ?_
+  rw [Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_pow, Polynomial.eval_X]
+
+theorem coeff_eval_single_of_lt_order_zero {f : (HahnSeries ℚ K)[X]} {γ : ℚ}
+    (hslope : ∀ j, 1 ≤ j → j ≤ f.natDegree → f.coeff j ≠ 0 →
+      (f.coeff 0).order ≤ (f.coeff j).order + j • γ)
+    (c : K) {g : ℚ} (hg : g < (f.coeff 0).order) :
+    (f.eval (HahnSeries.single γ c)).coeff g = 0 := by
+  rw [coeff_eval_single]
+  refine Finset.sum_eq_zero fun j hj => ?_
+  have hjle : j ≤ f.natDegree := Nat.lt_succ_iff.mp (Finset.mem_range.mp hj)
+  rcases Nat.eq_zero_or_pos j with hzero | hpos
+  · subst hzero
+    rw [zero_smul, sub_zero, HahnSeries.coeff_eq_zero_of_lt_order hg, zero_mul]
+  · rcases eq_or_ne (f.coeff j) 0 with hcoeff | hcoeff
+    · simp [hcoeff]
+    · have hbound : (f.coeff 0).order ≤ (f.coeff j).order + j • γ := hslope j hpos hjle hcoeff
+      have hlt : g - j • γ < (f.coeff j).order := by linarith
+      rw [HahnSeries.coeff_eq_zero_of_lt_order hlt, zero_mul]
+
+theorem exists_addVal_eval_gt_of_eval_zero_ne_zero [IsAlgClosed K]
+    {f : (HahnSeries ℚ K)[X]} (hf : f.Monic) (hdeg : 1 ≤ f.natDegree)
+    (h0 : f.coeff 0 ≠ 0) :
+    ∃ γ : ℚ, ∃ c : K, c ≠ 0 ∧
+      HahnSeries.addVal ℚ K (f.eval 0) <
+        HahnSeries.addVal ℚ K (f.eval (HahnSeries.single γ c)) := by
+  obtain ⟨γ, hslope, j₀, hj₀1, hj₀le, hj₀ne, hj₀eq⟩ := exists_evalNewtonSlope hf hdeg
+  have hconst : (evalEdgeForm f γ).coeff 0 ≠ 0 := by
+    rw [evalEdgeForm_coeff_zero]; exact HahnSeries.leadingCoeff_ne_zero.mpr h0
+  have hj₀coeff : (evalEdgeForm f γ).coeff j₀ ≠ 0 := by
+    rw [evalEdgeForm_coeff_of_eq hj₀le hj₀eq]
+    exact HahnSeries.leadingCoeff_ne_zero.mpr hj₀ne
+  have hdegφ : 1 ≤ (evalEdgeForm f γ).natDegree :=
+    le_trans hj₀1 (Polynomial.le_natDegree_of_ne_zero hj₀coeff)
+  have hdegφ' : (evalEdgeForm f γ).degree ≠ 0 :=
+    (Polynomial.natDegree_pos_iff_degree_pos.mp hdegφ).ne'
+  obtain ⟨c, hc⟩ := IsAlgClosed.exists_root (evalEdgeForm f γ) hdegφ'
+  have hcne : c ≠ 0 := fun hc0 => by
+    rw [Polynomial.IsRoot, hc0, ← Polynomial.coeff_zero_eq_eval_zero] at hc
+    exact hconst hc
+  refine ⟨γ, c, hcne, ?_⟩
+  have hvanish : ∀ g ≤ (f.coeff 0).order,
+      (f.eval (HahnSeries.single γ c)).coeff g = 0 := by
+    intro g hg
+    rcases lt_or_eq_of_le hg with hlt | heq
+    · exact coeff_eval_single_of_lt_order_zero hslope c hlt
+    · subst heq
+      rw [coeff_eval_single_order_zero]; exact hc
+  have heval0 : f.eval 0 = f.coeff 0 := (Polynomial.coeff_zero_eq_eval_zero f).symm
+  rw [heval0, HahnSeries.addVal_apply_of_ne h0, HahnSeries.addVal_apply]
+  rcases eq_or_ne (f.eval (HahnSeries.single γ c)) 0 with heq | hne
+  · rw [heq, HahnSeries.orderTop_zero]; exact WithTop.coe_lt_top _
+  · rw [← HahnSeries.order_eq_orderTop_of_ne_zero hne, WithTop.coe_lt_coe]
+    by_contra hle
+    push Not at hle
+    have horder : (f.eval (HahnSeries.single γ c)).coeff
+        (f.eval (HahnSeries.single γ c)).order ≠ 0 := by
+      rw [← HahnSeries.leadingCoeff_eq]
+      exact HahnSeries.leadingCoeff_ne_zero.mpr hne
+    exact horder (hvanish _ hle)
+
+variable {Γ : Type*} [LinearOrder Γ]
+
+structure IsBallChain {ι : Type*} [LinearOrder ι]
+    (r : ι → HahnSeries Γ K) (δ : ι → WithTop Γ) : Prop where
+  δ_mono : Monotone δ
+  mem_ball : ∀ ⦃i j : ι⦄, i ≤ j → δ i ≤ (r j - r i).orderTop
+
+def pseudoLimitCoeff {ι : Type*} [LinearOrder ι]
+    (r : ι → HahnSeries Γ K) (δ : ι → WithTop Γ) (g : Γ) [Decidable (∃ i, g < δ i)] : K :=
+  if h : ∃ i, (g : WithTop Γ) < δ i then (r h.choose).coeff g else 0
+
+theorem IsBallChain.coeff_eq_of_lt {ι : Type*} [LinearOrder ι]
+    {r : ι → HahnSeries Γ K} {δ : ι → WithTop Γ} (h : IsBallChain r δ)
+    {i j : ι} {g : Γ} (hgi : (g : WithTop Γ) < δ i) (hgj : (g : WithTop Γ) < δ j) :
+    (r i).coeff g = (r j).coeff g := by
+  wlog hij : i ≤ j generalizing i j
+  · exact (this hgj hgi (le_of_not_ge hij)).symm
+  have hdiff : (r j - r i).coeff g = 0 :=
+    HahnSeries.coeff_eq_zero_of_lt_orderTop (lt_of_lt_of_le hgi (h.mem_ball hij))
+  rw [HahnSeries.coeff_sub, sub_eq_zero] at hdiff
+  exact hdiff.symm
+
+theorem IsBallChain.pseudoLimitCoeff_eq {ι : Type*} [LinearOrder ι]
+    {r : ι → HahnSeries Γ K} {δ : ι → WithTop Γ} (h : IsBallChain r δ) {g : Γ}
+    [Decidable (∃ i, g < δ i)] {i : ι} (hgi : (g : WithTop Γ) < δ i) :
+    pseudoLimitCoeff r δ g = (r i).coeff g := by
+  unfold pseudoLimitCoeff
+  rw [dite_eq_left ⟨i, hgi⟩]
+  exact h.coeff_eq_of_lt (Exists.choose_spec (p := fun i => (g : WithTop Γ) < δ i) ⟨i, hgi⟩) hgi
+
+theorem IsBallChain.isPWO_support_pseudoLimitCoeff {ι : Type*} [LinearOrder ι]
+    {r : ι → HahnSeries Γ K} {δ : ι → WithTop Γ} [∀ g, Decidable (∃ i, g < δ i)]
+    (h : IsBallChain r δ) :
+    (Function.support (pseudoLimitCoeff r δ ·)).IsPWO := by
+  refine Set.IsWF.isPWO ?_
+  rw [Set.isWF_iff_no_descending_seq]
+  intro f hanti hf
+  have hf0 : pseudoLimitCoeff r δ (f 0) ≠ 0 := hf 0
+  have hex : ∃ i, ((f 0 : Γ) : WithTop Γ) < δ i := by
+    by_contra hnone
+    rw [pseudoLimitCoeff, dite_eq_right hnone] at hf0; exact hf0 rfl
+  obtain ⟨i₀, hi₀⟩ := hex
+  have hfk : ∀ k, f k ∈ (r i₀).support := by
+    intro k
+    have hfk0 : f k ≤ f 0 := hanti.antitone (Nat.zero_le k)
+    have hfklt : ((f k : Γ) : WithTop Γ) < δ i₀ :=
+      lt_of_le_of_lt (WithTop.coe_le_coe.mpr hfk0) hi₀
+    have heq := h.pseudoLimitCoeff_eq hfklt
+    rw [HahnSeries.mem_support, ← heq]
+    exact hf k
+  have hWF := (r i₀).isWF_support
+  rw [Set.isWF_iff_no_descending_seq] at hWF
+  exact hWF f hanti hfk
+
+def IsBallChain.pseudoLimit {ι : Type*} [LinearOrder ι]
+    {r : ι → HahnSeries Γ K} {δ : ι → WithTop Γ} [∀ g, Decidable (∃ i, g < δ i)]
+    (h : IsBallChain r δ) :
+    HahnSeries Γ K where
+  coeff := (pseudoLimitCoeff r δ ·)
+  isPWO_support' := h.isPWO_support_pseudoLimitCoeff
+
+theorem IsBallChain.coeff_pseudoLimit {ι : Type*} [LinearOrder ι]
+    {r : ι → HahnSeries Γ K} {δ : ι → WithTop Γ} (h : IsBallChain r δ)
+    {g : Γ} {i : ι} [∀ G, Decidable (∃ i, G < δ i)] (hgi : (g : WithTop Γ) < δ i) :
+    h.pseudoLimit.coeff g = (r i).coeff g :=
+  h.pseudoLimitCoeff_eq hgi
+
+theorem IsBallChain.le_orderTop_sub_pseudoLimit {ι : Type*} [LinearOrder ι]
+    {r : ι → HahnSeries Γ K} {δ : ι → WithTop Γ} [∀ g, Decidable (∃ i, g < δ i)]
+    (h : IsBallChain r δ) (i : ι) :
+    δ i ≤ (h.pseudoLimit - r i).orderTop := by
+  rw [HahnSeries.le_orderTop_iff_forall]
+  intro g hg
+  rw [HahnSeries.coeff_sub, h.coeff_pseudoLimit hg, sub_self]
+
+theorem exists_pseudoLimit {ι : Type*} [LinearOrder ι]
+    {r : ι → HahnSeries Γ K} {δ : ι → WithTop Γ} (h : IsBallChain r δ) :
+    ∃ r' : HahnSeries Γ K, ∀ i, δ i ≤ (r' - r i).orderTop := by
+  classical
+  exact ⟨h.pseudoLimit, h.le_orderTop_sub_pseudoLimit⟩
+
+theorem monic_taylor {f : (HahnSeries ℚ K)[X]} (hf : f.Monic) (r : HahnSeries ℚ K) :
+    (Polynomial.taylor r f).Monic := by
+  rw [Polynomial.taylor_apply]
+  exact hf.comp (Polynomial.monic_X_add_C r)
+    (by rw [Polynomial.natDegree_X_add_C]; exact one_ne_zero)
+
+theorem exists_addVal_eval_gt [IsAlgClosed K] {f : (HahnSeries ℚ K)[X]} (hf : f.Monic)
+    (hdeg : 1 ≤ f.natDegree) {r : HahnSeries ℚ K} (hr : f.eval r ≠ 0) :
+    ∃ r' : HahnSeries ℚ K,
+      HahnSeries.addVal ℚ K (f.eval r) < HahnSeries.addVal ℚ K (f.eval r') := by
+  set g := Polynomial.taylor r f with hg
+  have hgmonic : g.Monic := monic_taylor hf r
+  have hgdeg : 1 ≤ g.natDegree := by rw [hg, Polynomial.natDegree_taylor]; exact hdeg
+  have hg0 : g.coeff 0 ≠ 0 := by
+    rw [hg, Polynomial.taylor_coeff_zero]; exact hr
+  obtain ⟨γ, c, _, hlt⟩ :=
+    exists_addVal_eval_gt_of_eval_zero_ne_zero hgmonic hgdeg hg0
+  refine ⟨r + HahnSeries.single γ c, ?_⟩
+  have heval0 : g.eval 0 = f.eval r := by
+    rw [hg, Polynomial.taylor_apply, Polynomial.eval_comp, Polynomial.eval_add,
+      Polynomial.eval_X, Polynomial.eval_C, zero_add]
+  have hevals : g.eval (HahnSeries.single γ c) = f.eval (r + HahnSeries.single γ c) := by
+    rw [hg, Polynomial.taylor_apply, Polynomial.eval_comp, Polynomial.eval_add,
+      Polynomial.eval_X, Polynomial.eval_C, add_comm]
+  rw [← heval0, ← hevals]
+  exact hlt
+
+theorem isRoot_or_not_isMax_addVal_eval [IsAlgClosed K] {f : (HahnSeries ℚ K)[X]}
+    (hf : f.Monic) (hdeg : 1 ≤ f.natDegree) (r : HahnSeries ℚ K) :
+    f.IsRoot r ∨
+      ∃ r', HahnSeries.addVal ℚ K (f.eval r) < HahnSeries.addVal ℚ K (f.eval r') := by
+  rcases eq_or_ne (f.eval r) 0 with heq | hne
+  · left; exact heq
+  · right; exact exists_addVal_eval_gt hf hdeg hne
+
+end DorgePuiseux
+
+end
+
+open Polynomial HahnSeries
+
+noncomputable section
+
+namespace DorgePuiseux
+
+variable {K : Type*} [Field K]
+
+private theorem nsmul_top_withTop {j : ℕ} (hj : 1 ≤ j) : j • (⊤ : WithTop ℚ) = ⊤ := by
+  obtain ⟨k, rfl⟩ := Nat.exists_eq_add_of_le hj
+  rw [add_comm, succ_nsmul, add_top]
+
+private theorem nsmul_coe_withTop (j : ℕ) (q : ℚ) :
+    j • (q : WithTop ℚ) = ((j • q : ℚ) : WithTop ℚ) := by
+  induction j with
+  | zero => simp
+  | succ k ih => rw [succ_nsmul, succ_nsmul, ih]; push_cast; ring_nf
+
+private theorem nsmul_le_nsmul_iff_withTop {j : ℕ} (hj : 1 ≤ j) {a b : WithTop ℚ} :
+    j • a ≤ j • b ↔ a ≤ b := by
+  cases a with
+  | top =>
+    rw [nsmul_top_withTop hj]
+    simp only [top_le_iff]
+    cases b with
+    | top => simp [nsmul_top_withTop hj]
+    | coe q =>
+      rw [nsmul_coe_withTop]
+      exact ⟨fun h => absurd h WithTop.coe_ne_top, fun h => absurd h WithTop.coe_ne_top⟩
+  | coe p =>
+    cases b with
+    | top => simp [nsmul_top_withTop hj, nsmul_coe_withTop]
+    | coe q =>
+      rw [nsmul_coe_withTop, nsmul_coe_withTop, WithTop.coe_le_coe, WithTop.coe_le_coe,
+        nsmul_eq_mul, nsmul_eq_mul]
+      exact mul_le_mul_iff_of_pos_left (by exact_mod_cast hj)
+
+private theorem withTop_add_lt_add_left {a : WithTop ℚ} (ha : a ≠ ⊤) {b c : WithTop ℚ}
+    (h : a + b < a + c) : b < c := by
+  cases a with
+  | top => exact absurd rfl ha
+  | coe p =>
+    cases b with
+    | top => simp only [add_top, ← not_le, le_top, not_true] at h
+    | coe q =>
+      cases c with
+      | top => exact WithTop.coe_lt_top _
+      | coe s =>
+        rw [← WithTop.coe_add, ← WithTop.coe_add, WithTop.coe_lt_coe] at h
+        exact WithTop.coe_lt_coe.mpr (lt_of_add_lt_add_left h)
+
+theorem eval_sub_eval_eq_sum_taylor (f : (HahnSeries ℚ K)[X]) (r h : HahnSeries ℚ K) :
+    f.eval (r + h) - f.eval r =
+      ∑ j ∈ Finset.range (f.natDegree + 1),
+        (if j = 0 then 0 else (Polynomial.taylor r f).coeff j * h ^ j) := by
+  have hnat : (Polynomial.taylor r f).natDegree = f.natDegree := Polynomial.natDegree_taylor f r
+  rw [show r + h = h + r from add_comm r h, ← Polynomial.taylor_eval,
+    Polynomial.eval_eq_sum_range, hnat]
+  rw [show f.eval r = (Polynomial.taylor r f).coeff 0 from (Polynomial.taylor_coeff_zero ..).symm]
+  have h0mem : 0 ∈ Finset.range (f.natDegree + 1) := Finset.mem_range.mpr (Nat.succ_pos _)
+  rw [← Finset.add_sum_erase _ (fun j => (Polynomial.taylor r f).coeff j * h ^ j) h0mem,
+    ← Finset.add_sum_erase _
+      (fun j => if j = 0 then 0 else (Polynomial.taylor r f).coeff j * h ^ j) h0mem]
+  rw [pow_zero, mul_one, add_sub_cancel_left, ite_eq_left rfl, zero_add]
+  refine Finset.sum_congr rfl fun j hj => ?_
+  rw [ite_eq_right (Finset.ne_of_mem_erase hj)]
+
+def KaplanskySlope (f : (HahnSeries ℚ K)[X]) (r r' : HahnSeries ℚ K) : Prop :=
+  ∀ j, 1 ≤ j → j ≤ f.natDegree →
+    HahnSeries.addVal ℚ K (f.eval r) ≤
+      HahnSeries.addVal ℚ K ((Polynomial.taylor r f).coeff j) +
+        j • HahnSeries.addVal ℚ K (r' - r)
+
+theorem KaplanskySlope.refl (f : (HahnSeries ℚ K)[X]) (r : HahnSeries ℚ K) :
+    KaplanskySlope f r r := by
+  intro j hj _
+  rw [sub_self, AddValuation.map_zero, nsmul_top_withTop hj, add_top]
+  exact le_top
+
+theorem KaplanskySlope.addVal_eval_le {f : (HahnSeries ℚ K)[X]} {r r' : HahnSeries ℚ K}
+    (h : KaplanskySlope f r r') :
+    HahnSeries.addVal ℚ K (f.eval r) ≤ HahnSeries.addVal ℚ K (f.eval r') := by
+  have hsum : HahnSeries.addVal ℚ K (f.eval r) ≤
+      HahnSeries.addVal ℚ K (f.eval r' - f.eval r) := by
+    rw [show f.eval r' - f.eval r = f.eval (r + (r' - r)) - f.eval r by ring_nf,
+      eval_sub_eval_eq_sum_taylor]
+    refine (HahnSeries.addVal ℚ K).map_le_sum fun j hj => ?_
+    rcases Nat.eq_zero_or_pos j with rfl | hpos
+    · simp
+    · rw [ite_eq_right hpos.ne', (HahnSeries.addVal ℚ K).map_mul, (HahnSeries.addVal ℚ K).map_pow]
+      exact h j hpos (Nat.lt_succ_iff.mp (Finset.mem_range.mp hj))
+  calc HahnSeries.addVal ℚ K (f.eval r)
+      ≤ min (HahnSeries.addVal ℚ K (f.eval r)) (HahnSeries.addVal ℚ K (f.eval r' - f.eval r)) :=
+        le_min le_rfl hsum
+    _ ≤ HahnSeries.addVal ℚ K (f.eval r + (f.eval r' - f.eval r)) :=
+        (HahnSeries.addVal ℚ K).map_add _ _
+    _ = HahnSeries.addVal ℚ K (f.eval r') := by ring_nf
+
+theorem KaplanskySlope.mono {f : (HahnSeries ℚ K)[X]} {r r' r'' : HahnSeries ℚ K}
+    (h : KaplanskySlope f r r')
+    (hle : HahnSeries.addVal ℚ K (r' - r) ≤ HahnSeries.addVal ℚ K (r'' - r)) :
+    KaplanskySlope f r r'' := by
+  intro j hj hjle
+  exact (h j hj hjle).trans
+    (add_le_add le_rfl ((nsmul_le_nsmul_iff_withTop hj).mpr hle))
+
+theorem exists_addVal_taylor_coeff_of_addVal_eval_lt {f : (HahnSeries ℚ K)[X]}
+    {r r' : HahnSeries ℚ K}
+    (hlt : HahnSeries.addVal ℚ K (f.eval r) < HahnSeries.addVal ℚ K (f.eval r')) :
+    ∃ j, 1 ≤ j ∧ j ≤ f.natDegree ∧
+      HahnSeries.addVal ℚ K ((Polynomial.taylor r' f).coeff j) +
+        j • HahnSeries.addVal ℚ K (r' - r) ≤ HahnSeries.addVal ℚ K (f.eval r) := by
+  by_contra habs
+  push Not at habs
+  have hsum : HahnSeries.addVal ℚ K (f.eval r) <
+      HahnSeries.addVal ℚ K (f.eval (r' + (r - r'))) := by
+    rw [show f.eval (r' + (r - r')) = f.eval r' + (f.eval (r' + (r - r')) - f.eval r') by ring,
+      eval_sub_eval_eq_sum_taylor]
+    refine (HahnSeries.addVal ℚ K).map_lt_add hlt ?_
+    refine (HahnSeries.addVal ℚ K).map_lt_sum (ne_of_lt (lt_of_lt_of_le hlt le_top)) fun j hj => ?_
+    rcases Nat.eq_zero_or_pos j with rfl | hpos
+    · simpa using lt_of_lt_of_le hlt le_top
+    · rw [ite_eq_right hpos.ne', (HahnSeries.addVal ℚ K).map_mul, (HahnSeries.addVal ℚ K).map_pow,
+        show r - r' = -(r' - r) by ring, (HahnSeries.addVal ℚ K).map_neg]
+      exact habs j hpos (Nat.lt_succ_iff.mp (Finset.mem_range.mp hj))
+  rw [show r' + (r - r') = r by ring] at hsum
+  exact lt_irrefl _ hsum
+
+def KaplanskyLE (f : (HahnSeries ℚ K)[X]) (r r' : HahnSeries ℚ K) : Prop :=
+  r = r' ∨ (HahnSeries.addVal ℚ K (f.eval r) < HahnSeries.addVal ℚ K (f.eval r') ∧
+    KaplanskySlope f r r')
+
+theorem KaplanskyLE.refl (f : (HahnSeries ℚ K)[X]) (r : HahnSeries ℚ K) :
+    KaplanskyLE f r r := Or.inl rfl
+
+scoped instance (f : (HahnSeries ℚ K)[X]) : Std.Refl (KaplanskyLE f) := ⟨KaplanskyLE.refl f⟩
+
+theorem KaplanskyLE.addVal_eval_le {f : (HahnSeries ℚ K)[X]} {r r' : HahnSeries ℚ K}
+    (h : KaplanskyLE f r r') :
+    HahnSeries.addVal ℚ K (f.eval r) ≤ HahnSeries.addVal ℚ K (f.eval r') := by
+  rcases h with rfl | ⟨hlt, _⟩
+  · exact le_rfl
+  · exact hlt.le
+
+theorem KaplanskySlope.of_kaplanskyLE_of_lt {f : (HahnSeries ℚ K)[X]}
+    {r r' r'' : HahnSeries ℚ K}
+    (hlt : HahnSeries.addVal ℚ K (f.eval r) < HahnSeries.addVal ℚ K (f.eval r'))
+    (hslope : KaplanskySlope f r r') (h' : KaplanskyLE f r' r'') :
+    KaplanskySlope f r r'' := by
+  rcases h' with rfl | ⟨_, hslope'⟩
+  · exact hslope
+  obtain ⟨j₀, hj₀1, hj₀le, hj₀⟩ := exists_addVal_taylor_coeff_of_addVal_eval_lt hlt
+  have hj₀' := hslope' j₀ hj₀1 hj₀le
+  have hlt'' : HahnSeries.addVal ℚ K ((Polynomial.taylor r' f).coeff j₀) +
+        j₀ • HahnSeries.addVal ℚ K (r' - r) <
+      HahnSeries.addVal ℚ K ((Polynomial.taylor r' f).coeff j₀) +
+        j₀ • HahnSeries.addVal ℚ K (r'' - r') :=
+    lt_of_le_of_lt hj₀ (lt_of_lt_of_le hlt hj₀')
+  have hbne : HahnSeries.addVal ℚ K ((Polynomial.taylor r' f).coeff j₀) ≠ ⊤ := by
+    intro htop; rw [htop, top_add, top_add] at hlt''; exact lt_irrefl _ hlt''
+  have hηle : HahnSeries.addVal ℚ K (r' - r) ≤ HahnSeries.addVal ℚ K (r'' - r') :=
+    (nsmul_le_nsmul_iff_withTop hj₀1).mp (withTop_add_lt_add_left hbne hlt'').le
+  refine hslope.mono ?_
+  calc HahnSeries.addVal ℚ K (r' - r)
+      = min (HahnSeries.addVal ℚ K (r' - r)) (HahnSeries.addVal ℚ K (r'' - r')) :=
+        (min_eq_left hηle).symm
+    _ ≤ HahnSeries.addVal ℚ K ((r' - r) + (r'' - r')) := (HahnSeries.addVal ℚ K).map_add _ _
+    _ = HahnSeries.addVal ℚ K (r'' - r) := by ring_nf
+
+theorem KaplanskyLE.trans {f : (HahnSeries ℚ K)[X]} {r r' r'' : HahnSeries ℚ K}
+    (h : KaplanskyLE f r r') (h' : KaplanskyLE f r' r'') : KaplanskyLE f r r'' := by
+  rcases h with rfl | ⟨hlt, hslope⟩
+  · exact h'
+  exact Or.inr ⟨lt_of_lt_of_le hlt h'.addVal_eval_le, hslope.of_kaplanskyLE_of_lt hlt h'⟩
+
+theorem KaplanskyLE.antisymm {f : (HahnSeries ℚ K)[X]} {r r' : HahnSeries ℚ K}
+    (h : KaplanskyLE f r r') (h' : KaplanskyLE f r' r) : r = r' := by
+  rcases h with rfl | ⟨hlt, _⟩
+  · rfl
+  rcases h' with rfl | ⟨hlt', _⟩
+  · rfl
+  exact absurd hlt (not_lt.mpr hlt'.le)
+
+theorem KaplanskyLE.addVal_sub_le_addVal_sub {f : (HahnSeries ℚ K)[X]}
+    {r r' r'' : HahnSeries ℚ K}
+    (hlt : HahnSeries.addVal ℚ K (f.eval r) < HahnSeries.addVal ℚ K (f.eval r'))
+    (h' : KaplanskyLE f r' r'')
+    (hlt' : HahnSeries.addVal ℚ K (f.eval r') < HahnSeries.addVal ℚ K (f.eval r'')) :
+    HahnSeries.addVal ℚ K (r' - r) ≤ HahnSeries.addVal ℚ K (r'' - r') := by
+  rcases h' with rfl | ⟨_, hslope'⟩
+  · exact absurd hlt' (lt_irrefl _)
+  obtain ⟨j₀, hj₀1, hj₀le, hj₀⟩ := exists_addVal_taylor_coeff_of_addVal_eval_lt hlt
+  have hj₀' := hslope' j₀ hj₀1 hj₀le
+  have hlt'' := lt_of_le_of_lt hj₀ (lt_of_lt_of_le hlt hj₀')
+  have hbne : HahnSeries.addVal ℚ K ((Polynomial.taylor r' f).coeff j₀) ≠ ⊤ := by
+    intro htop; rw [htop, top_add, top_add] at hlt''; exact lt_irrefl _ hlt''
+  exact (nsmul_le_nsmul_iff_withTop hj₀1).mp (withTop_add_lt_add_left hbne hlt'').le
+
+theorem exists_kaplanskyLE_of_eval_ne_zero [IsAlgClosed K] {f : (HahnSeries ℚ K)[X]}
+    (hf : f.Monic) (hdeg : 1 ≤ f.natDegree)
+    {r : HahnSeries ℚ K} (hr : f.eval r ≠ 0) :
+    ∃ r', r ≠ r' ∧ KaplanskyLE f r r' := by
+  set g := Polynomial.taylor r f with hg
+  have hgmonic : g.Monic := monic_taylor hf r
+  have hgdeg : 1 ≤ g.natDegree := by rw [hg, Polynomial.natDegree_taylor]; exact hdeg
+  have hg0 : g.coeff 0 ≠ 0 := by rw [hg, Polynomial.taylor_coeff_zero]; exact hr
+  obtain ⟨γ, hslope, j₀, hj₀1, hj₀le, hj₀ne, hj₀eq⟩ := exists_evalNewtonSlope hgmonic hgdeg
+  have hconst : (evalEdgeForm g γ).coeff 0 ≠ 0 := by
+    rw [evalEdgeForm_coeff_zero]; exact HahnSeries.leadingCoeff_ne_zero.mpr hg0
+  have hj₀coeff : (evalEdgeForm g γ).coeff j₀ ≠ 0 := by
+    rw [evalEdgeForm_coeff_of_eq hj₀le hj₀eq]
+    exact HahnSeries.leadingCoeff_ne_zero.mpr hj₀ne
+  obtain ⟨c, hc⟩ := IsAlgClosed.exists_root (evalEdgeForm g γ)
+    ((Polynomial.natDegree_pos_iff_degree_pos.mp
+      (le_trans hj₀1 (Polynomial.le_natDegree_of_ne_zero hj₀coeff))).ne')
+  have hcne : c ≠ 0 := fun hc0 => by
+    rw [Polynomial.IsRoot, hc0, ← Polynomial.coeff_zero_eq_eval_zero] at hc; exact hconst hc
+  have hvanish : ∀ q ≤ (g.coeff 0).order, (g.eval (HahnSeries.single γ c)).coeff q = 0 := by
+    intro q hq
+    rcases lt_or_eq_of_le hq with hlt' | heq
+    · exact coeff_eval_single_of_lt_order_zero hslope c hlt'
+    · subst heq; rw [coeff_eval_single_order_zero]; exact hc
+  have heval0 : f.eval r = g.coeff 0 := by
+    rw [hg, Polynomial.taylor_coeff_zero]
+  have hltγ : HahnSeries.addVal ℚ K (f.eval r) <
+      HahnSeries.addVal ℚ K (g.eval (HahnSeries.single γ c)) := by
+    rw [heval0, HahnSeries.addVal_apply_of_ne hg0, HahnSeries.addVal_apply]
+    rcases eq_or_ne (g.eval (HahnSeries.single γ c)) 0 with heq | hne
+    · rw [heq, HahnSeries.orderTop_zero]; exact WithTop.coe_lt_top _
+    · rw [← HahnSeries.order_eq_orderTop_of_ne_zero hne, WithTop.coe_lt_coe]
+      by_contra hle
+      have hkey := hvanish (g.eval (HahnSeries.single γ c)).order (not_lt.mp hle)
+      rw [← HahnSeries.leadingCoeff_eq] at hkey
+      exact (HahnSeries.leadingCoeff_ne_zero.mpr hne) hkey
+  have hevals : g.eval (HahnSeries.single γ c) = f.eval (r + HahnSeries.single γ c) := by
+    rw [hg, Polynomial.taylor_eval, add_comm]
+  refine ⟨r + HahnSeries.single γ c, fun heq => hcne ?_, Or.inr ⟨hevals ▸ hltγ, ?_⟩⟩
+  · have h0 : (HahnSeries.single γ c : HahnSeries ℚ K) = 0 := by
+      have heq' : r + HahnSeries.single γ c = r + (0 : HahnSeries ℚ K) := by
+        rw [add_zero]; exact heq.symm
+      exact add_left_cancel heq'
+    exact HahnSeries.single_eq_zero_iff.mp h0
+  · intro j hj hjle
+    rw [add_sub_cancel_left, heval0, HahnSeries.addVal_apply_of_ne hg0]
+    rcases eq_or_ne ((Polynomial.taylor r f).coeff j) 0 with hzero | hne
+    · rw [hzero, AddValuation.map_zero, top_add]; exact le_top
+    · have hjle' : j ≤ g.natDegree := by rw [hg, Polynomial.natDegree_taylor]; exact hjle
+      rw [HahnSeries.addVal_apply_of_ne hne, HahnSeries.addVal_apply,
+        HahnSeries.orderTop_single hcne, ← hg, nsmul_coe_withTop]
+      exact_mod_cast hslope j hj hjle' hne
+
+theorem eval_eq_zero_of_kaplanskyLE_max [IsAlgClosed K] {f : (HahnSeries ℚ K)[X]}
+    (hf : f.Monic) (hdeg : 1 ≤ f.natDegree)
+    {m : HahnSeries ℚ K} (hmax : ∀ r, KaplanskyLE f m r → KaplanskyLE f r m) :
+    f.eval m = 0 := by
+  by_contra hm
+  obtain ⟨r', hne, hle⟩ := exists_kaplanskyLE_of_eval_ne_zero hf hdeg hm
+  exact hne (KaplanskyLE.antisymm hle (hmax r' hle))
+
+section ChainUpperBound
+
+variable {f : (HahnSeries ℚ K)[X]}
+
+theorem kaplanskyChain_addVal_injOn {C : Set (HahnSeries ℚ K)}
+    (hC : IsChain (KaplanskyLE f) C) :
+    Set.InjOn (fun a => HahnSeries.addVal ℚ K (f.eval a)) C := by
+  intro a ha b hb hab
+  rcases hC.total ha hb with h | h
+  · rcases h with rfl | ⟨hlt, _⟩
+    exacts [rfl, absurd hab hlt.ne]
+  · rcases h with rfl | ⟨hlt, _⟩
+    exacts [rfl, absurd hab.symm hlt.ne]
+
+@[reducible] def kaplanskyChainOrder {C : Set (HahnSeries ℚ K)}
+    (hC : IsChain (KaplanskyLE f) C) :
+    LinearOrder ↥C :=
+  LinearOrder.lift' (fun a => HahnSeries.addVal ℚ K (f.eval (a : HahnSeries ℚ K)))
+    (fun a b hab => Subtype.ext (kaplanskyChain_addVal_injOn hC a.2 b.2 hab))
+
+theorem kaplanskyChainOrder_le_iff {C : Set (HahnSeries ℚ K)}
+    (hC : IsChain (KaplanskyLE f) C) {a b : ↥C} :
+    (kaplanskyChainOrder hC).le a b ↔ KaplanskyLE f (a : HahnSeries ℚ K) b := by
+  constructor
+  · intro hle
+    rcases hC.total a.2 b.2 with h | h
+    · exact h
+    · have heq : (a : HahnSeries ℚ K) = b :=
+        kaplanskyChain_addVal_injOn hC a.2 b.2 (le_antisymm hle h.addVal_eval_le)
+      exact heq ▸ KaplanskyLE.refl f a
+  · intro h; exact h.addVal_eval_le
+
+def KaplanskyBelowSlope (f : (HahnSeries ℚ K)[X]) (a : HahnSeries ℚ K) (g : ℚ) : Prop :=
+  ∃ j, 1 ≤ j ∧ j ≤ f.natDegree ∧
+    HahnSeries.addVal ℚ K ((Polynomial.taylor a f).coeff j) + ((j • g : ℚ) : WithTop ℚ) <
+      HahnSeries.addVal ℚ K (f.eval a)
+
+private theorem nsmul_lt_nsmul_iff_withTop {j : ℕ} (hj : 1 ≤ j) {a b : WithTop ℚ} :
+    j • a < j • b ↔ a < b := by
+  rw [lt_iff_le_not_ge, lt_iff_le_not_ge, nsmul_le_nsmul_iff_withTop hj,
+    nsmul_le_nsmul_iff_withTop hj]
+
+theorem KaplanskyBelowSlope.lt_addVal_sub {a b : HahnSeries ℚ K} {g : ℚ}
+    (hbelow : KaplanskyBelowSlope f a g) (hslope : KaplanskySlope f a b) :
+    (g : WithTop ℚ) < HahnSeries.addVal ℚ K (b - a) := by
+  obtain ⟨j, hj1, hjle, hjlt⟩ := hbelow
+  have hj := hslope j hj1 hjle
+  have hbne : HahnSeries.addVal ℚ K ((Polynomial.taylor a f).coeff j) ≠ ⊤ := by
+    intro htop; rw [htop, top_add] at hjlt; exact not_top_lt hjlt
+  have hlt : ((j • g : ℚ) : WithTop ℚ) < j • HahnSeries.addVal ℚ K (b - a) :=
+    withTop_add_lt_add_left hbne (lt_of_lt_of_le hjlt hj)
+  rw [← nsmul_coe_withTop] at hlt
+  exact (nsmul_lt_nsmul_iff_withTop hj1).mp hlt
+
+theorem KaplanskyBelowSlope.of_kaplanskyLE {a b : HahnSeries ℚ K} {g : ℚ}
+    (hbelow : KaplanskyBelowSlope f a g)
+    (hlt : HahnSeries.addVal ℚ K (f.eval a) < HahnSeries.addVal ℚ K (f.eval b))
+    (hslope : KaplanskySlope f a b) :
+    KaplanskyBelowSlope f b g := by
+  obtain ⟨j₀, hj₀1, hj₀le, hj₀⟩ := exists_addVal_taylor_coeff_of_addVal_eval_lt hlt
+  refine ⟨j₀, hj₀1, hj₀le, ?_⟩
+  have hglt : (g : WithTop ℚ) < HahnSeries.addVal ℚ K (b - a) := hbelow.lt_addVal_sub hslope
+  have hbne : HahnSeries.addVal ℚ K ((Polynomial.taylor b f).coeff j₀) ≠ ⊤ := by
+    intro htop; rw [htop, top_add] at hj₀; exact not_top_lt (lt_of_le_of_lt hj₀ hlt)
+  calc HahnSeries.addVal ℚ K ((Polynomial.taylor b f).coeff j₀) + ((j₀ • g : ℚ) : WithTop ℚ)
+      < HahnSeries.addVal ℚ K ((Polynomial.taylor b f).coeff j₀) +
+          j₀ • HahnSeries.addVal ℚ K (b - a) := by
+        rw [← nsmul_coe_withTop]
+        refine WithTop.add_lt_add_left hbne ?_
+        exact (nsmul_lt_nsmul_iff_withTop hj₀1).mpr hglt
+    _ ≤ HahnSeries.addVal ℚ K (f.eval a) := hj₀
+    _ < HahnSeries.addVal ℚ K (f.eval b) := hlt
+
+theorem kaplanskyChain_coeff_eq {C : Set (HahnSeries ℚ K)}
+    (hC : IsChain (KaplanskyLE f) C) {a b : HahnSeries ℚ K} (ha : a ∈ C) (hb : b ∈ C)
+    {g : ℚ} (hga : KaplanskyBelowSlope f a g) (hgb : KaplanskyBelowSlope f b g) :
+    a.coeff g = b.coeff g := by
+  rcases hC.total ha hb with hab | hab
+  · rcases hab with rfl | ⟨_, hslope⟩
+    · rfl
+    have hlt := hga.lt_addVal_sub hslope
+    rw [HahnSeries.addVal_apply] at hlt
+    have hdiff := HahnSeries.coeff_eq_zero_of_lt_orderTop hlt
+    rw [HahnSeries.coeff_sub, sub_eq_zero] at hdiff
+    exact hdiff.symm
+  · rcases hab with rfl | ⟨_, hslope⟩
+    · rfl
+    have hlt := hgb.lt_addVal_sub hslope
+    rw [HahnSeries.addVal_apply] at hlt
+    have hdiff := HahnSeries.coeff_eq_zero_of_lt_orderTop hlt
+    rw [HahnSeries.coeff_sub, sub_eq_zero] at hdiff
+    exact hdiff
+
+def kaplanskyLimitCoeff (C : Set (HahnSeries ℚ K)) (g : ℚ)
+    [Decidable (∃ a ∈ C, KaplanskyBelowSlope f a g)] : K :=
+  if h : ∃ a ∈ C, KaplanskyBelowSlope f a g then h.choose.coeff g else 0
+
+theorem kaplanskyLimitCoeff_eq {C : Set (HahnSeries ℚ K)} (hC : IsChain (KaplanskyLE f) C)
+    {a : HahnSeries ℚ K} (ha : a ∈ C) {g : ℚ} (hga : KaplanskyBelowSlope f a g)
+    [Decidable (∃ a ∈ C, KaplanskyBelowSlope f a g)] :
+    kaplanskyLimitCoeff (f := f) C g = a.coeff g := by
+  unfold kaplanskyLimitCoeff
+  rw [dite_eq_left ⟨a, ha, hga⟩]
+  obtain ⟨hb, hgb⟩ := (⟨a, ha, hga⟩ : ∃ a ∈ C, KaplanskyBelowSlope f a g).choose_spec
+  exact kaplanskyChain_coeff_eq hC hb ha hgb hga
+
+theorem kaplanskyLimitCoeff_isPWO_support {C : Set (HahnSeries ℚ K)}
+    (hC : IsChain (KaplanskyLE f) C) [∀ g, Decidable (∃ a ∈ C, KaplanskyBelowSlope f a g)] :
+    (Function.support (kaplanskyLimitCoeff (f := f) C ·)).IsPWO := by
+  refine Set.IsWF.isPWO ?_
+  rw [Set.isWF_iff_no_descending_seq]
+  intro s hanti hs
+  have hf0 : kaplanskyLimitCoeff (f := f) C (s 0) ≠ 0 := hs 0
+  have hex : ∃ a ∈ C, KaplanskyBelowSlope f a (s 0) := by
+    by_contra hnone; rw [kaplanskyLimitCoeff, dite_eq_right hnone] at hf0; exact hf0 rfl
+  obtain ⟨a₀, ha₀, hga₀⟩ := hex
+  have hsk : ∀ k, s k ∈ a₀.support := by
+    intro k
+    have hsk0 : s k ≤ s 0 := hanti.antitone (Nat.zero_le k)
+    obtain ⟨j, hj1, hjle, hjlt⟩ := hga₀
+    have hgak : KaplanskyBelowSlope f a₀ (s k) := ⟨j, hj1, hjle, by
+      refine lt_of_le_of_lt ?_ hjlt
+      gcongr
+      exact_mod_cast nsmul_le_nsmul_right hsk0 j⟩
+    have heq := kaplanskyLimitCoeff_eq hC ha₀ hgak
+    rw [HahnSeries.mem_support, ← heq]
+    exact hs k
+  have hWF := a₀.isWF_support
+  rw [Set.isWF_iff_no_descending_seq] at hWF
+  exact hWF s hanti hsk
+
+def kaplanskyLimit {C : Set (HahnSeries ℚ K)} (hC : IsChain (KaplanskyLE f) C)
+    [∀ g, Decidable (∃ a ∈ C, KaplanskyBelowSlope f a g)] :
+    HahnSeries ℚ K where
+  coeff := (kaplanskyLimitCoeff (f := f) C ·)
+  isPWO_support' := kaplanskyLimitCoeff_isPWO_support hC
+
+theorem kaplanskySlope_kaplanskyLimit {C : Set (HahnSeries ℚ K)}
+    (hC : IsChain (KaplanskyLE f) C) {a : HahnSeries ℚ K} (ha : a ∈ C)
+    [∀ g, Decidable (∃ a ∈ C, KaplanskyBelowSlope f a g)] :
+    KaplanskySlope f a (kaplanskyLimit hC) := by
+  intro j hj hjle
+  by_contra hlt
+  push Not at hlt
+  have hne : kaplanskyLimit hC - a ≠ 0 := by
+    intro heq
+    rw [heq, AddValuation.map_zero, nsmul_top_withTop hj, add_top] at hlt
+    exact not_top_lt hlt
+  set q : ℚ := (kaplanskyLimit hC - a).order with hq
+  have hqval : HahnSeries.addVal ℚ K (kaplanskyLimit hC - a) = (q : WithTop ℚ) := by
+    rw [HahnSeries.addVal_apply_of_ne hne, hq]
+  rw [hqval, nsmul_coe_withTop] at hlt
+  have hbelow : KaplanskyBelowSlope f a q := ⟨j, hj, hjle, hlt⟩
+  have hcoeff : (kaplanskyLimit hC - a).coeff q = 0 := by
+    rw [HahnSeries.coeff_sub]
+    change kaplanskyLimitCoeff (f := f) C q - a.coeff q = 0
+    rw [kaplanskyLimitCoeff_eq hC ha hbelow, sub_self]
+  rw [hq, ← HahnSeries.leadingCoeff_eq] at hcoeff
+  exact (HahnSeries.leadingCoeff_ne_zero.mpr hne) hcoeff
+
+theorem exists_kaplanskyLE_upperBound {C : Set (HahnSeries ℚ K)}
+    (hC : IsChain (KaplanskyLE f) C) :
+    ∃ ub, ∀ a ∈ C, KaplanskyLE f a ub := by
+  classical
+  by_cases hmax : ∃ m ∈ C, ∀ a ∈ C, KaplanskyLE f a m
+  · obtain ⟨m, _, hm⟩ := hmax; exact ⟨m, hm⟩
+  push Not at hmax
+  have hnomax : ∀ a ∈ C, ∃ b ∈ C, KaplanskyLE f a b ∧ a ≠ b := by
+    intro a ha
+    obtain ⟨b, hb, hnle⟩ := hmax a ha
+    rcases hC.total ha hb with hab | hab
+    · exact ⟨b, hb, hab, fun heq => hnle (heq ▸ KaplanskyLE.refl f a)⟩
+    · exact absurd hab hnle
+  refine ⟨kaplanskyLimit hC, fun a ha => ?_⟩
+  obtain ⟨b, hb, hab, hne⟩ := hnomax a ha
+  have hltab : HahnSeries.addVal ℚ K (f.eval a) < HahnSeries.addVal ℚ K (f.eval b) := by
+    rcases hab with rfl | ⟨hlt, _⟩
+    · exact absurd rfl hne
+    · exact hlt
+  refine Or.inr ⟨?_, kaplanskySlope_kaplanskyLimit hC ha⟩
+  exact lt_of_lt_of_le hltab (kaplanskySlope_kaplanskyLimit hC hb).addVal_eval_le
+
+end ChainUpperBound
+
+theorem exists_isRoot_hahnSeries [IsAlgClosed K] {f : (HahnSeries ℚ K)[X]}
+    (hf : f.Monic) (hdeg : 1 ≤ f.natDegree) :
+    ∃ r : HahnSeries ℚ K, f.IsRoot r := by
+  obtain ⟨m, hmax⟩ := exists_maximal_of_chains_bounded
+    (r := KaplanskyLE f) (fun C hC => exists_kaplanskyLE_upperBound hC)
+    (fun {a b c} => KaplanskyLE.trans)
+  exact ⟨m, eval_eq_zero_of_kaplanskyLE_max hf hdeg hmax⟩
+
+theorem isAlgClosed_hahnSeries_rat [IsAlgClosed K] : IsAlgClosed (HahnSeries ℚ K) := by
+  refine IsAlgClosed.of_exists_root _ fun f hf hirr => ?_
+  have hdeg : 1 ≤ f.natDegree := by
+    by_contra hlt
+    have h1 : f = 1 := hf.natDegree_eq_zero.mp (Nat.lt_one_iff.mp (not_le.mp hlt))
+    exact hirr.not_isUnit (h1 ▸ isUnit_one)
+  exact exists_isRoot_hahnSeries hf hdeg
+
+end DorgePuiseux
+end
+
+theorem solution {K : Type*} [Field K] [IsAlgClosed K] :
+    IsAlgClosed (HahnSeries ℚ K) :=
+  DorgePuiseux.isAlgClosed_hahnSeries_rat
+
+end S_HahnSeries_isAlgClosed_rat
+end P2MW
+export P2MW.S_HahnSeries_isAlgClosed_rat (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem HahnSeries.isAlgClosed_rat {K : Type*} [Field K] [IsAlgClosed K] :
+    IsAlgClosed (HahnSeries ℚ K) :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_mem_puiseuxRamSubfield_iff.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_mem_puiseuxRamSubfield_iff.lean
new file mode 100644
index 0000000000..109dd3ee8e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HahnSeries_mem_puiseuxRamSubfield_iff.lean
@@ -0,0 +1,138 @@
+/-
+Based on Prove2Me node HahnSeries.mem_puiseuxRamSubfield_iff
+(81fd5298-524e-5e5a-b70c-9c519bf44611) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ea9e5ee7-5223-5ca1-9da5-9a9e635cbc6e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_RamificationBound
+
+import Mathlib.Order.CompletePartialOrder
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Membership in the e-ramified Puiseux subfield
+
+Theorem statement: `HahnSeries.mem_puiseuxRamSubfield_iff` (`81fd5298-524e-5e5a-b70c-9c519bf44611`),
+by Claude, 2026-09-05.
+
+Proof: submission `ea9e5ee7-5223-5ca1-9da5-9a9e635cbc6e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, let $e$ be a natural number with $0 < e$, and let $y$ be a Hahn series with
+rational exponents and coefficients in $K$. The theorem asserts the equivalence of two conditions on
+$y$. The first is that $y$ lies in [`HahnSeries.puiseuxRamSubfield K
+he`](def/HahnSeries_RamificationBound.html#L37), the subfield of $K((t^{\mathbb{Q}}))$ defined as
+the field range of the ring homomorphism [`HahnSeries.puiseuxRamEmb
+he`](def/HahnSeries_RamificationBound.html#L29) from $K((t^{\mathbb{Z}}))$ to $K((t^{\mathbb{Q}}))$,
+that is, of the map obtained by transporting the exponent domain along the strictly monotone
+injection `ramScale e` sending $k \in \mathbb{Z}$ to $k/e \in \mathbb{Q}$; equivalently, $y =
+x(t^{1/e})$ for some Laurent–Hahn series $x$ with integer exponents. The second is
+[`HahnSeries.HasRamBound e y`](def/HahnSeries_RamificationBound.html#L32), which by definition says
+that the support of $y$ is contained in the range of $k \mapsto (k : \mathbb{Q})/e$, i.e. every
+exponent occurring in $y$ lies in $\tfrac{1}{e}\mathbb{Z}$.
+
+This is the characterisation of the Puiseux subfield $K((t^{1/e}))$ inside the Hahn field
+$K((t^{\mathbb{Q}}))$ by bounded denominators of exponents; combined with the fact that the
+right-hand side is membership in a subfield, it is the source of the closure of `HasRamBound e`
+under the field operations. It is used in the ramification analysis of places of the modular curves,
+for instance in the statements that the order of a place divides, or equals one, according as all
+Hahn-series embeddings satisfy a given ramification bound.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HahnSeries_mem_puiseuxRamSubfield_iff.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HahnSeries_mem_puiseuxRamSubfield_iff
+
+open HahnSeries
+
+namespace P2MWs13
+namespace Puiseux
+
+variable {K : Type*} [Field K]
+
+theorem hasRamBound_puiseuxRamEmb {e : ℕ} (he : 0 < e) (x : HahnSeries ℤ K) :
+    HasRamBound e (puiseuxRamEmb he x) := by
+  intro q hq
+  have hsub : (puiseuxRamEmb he x).support ⊆ (ramScale e) '' x.support := by
+    unfold puiseuxRamEmb
+    rw [embDomainRingHom_apply]
+    exact HahnSeries.support_embDomain_subset
+  obtain ⟨k, _, rfl⟩ := hsub hq
+  exact ⟨k, rfl⟩
+
+theorem isPWO_ramScale_preimage_support {e : ℕ} (he : 0 < e) (y : HahnSeries ℚ K) :
+    {k : ℤ | y.coeff ((k : ℚ) / e) ≠ 0}.IsPWO := by
+  have hmono : StrictMono (fun k : ℤ => (k : ℚ) / e) :=
+    fun a b hab => div_lt_div_of_pos_right (Int.cast_lt.mpr hab) (Nat.cast_pos.mpr he)
+  have hmap : Set.MapsTo (fun k : ℤ => (k : ℚ) / e)
+      {k : ℤ | y.coeff ((k : ℚ) / e) ≠ 0} y.support := fun k hk => hk
+  rw [Set.isPWO_iff_isWF]
+  refine Set.WellFoundedOn.mono
+    (r' := (fun a b : ℤ => ((a : ℚ) / e : ℚ) < ((b : ℚ) / e : ℚ)))
+    (Set.WellFoundedOn.mapsTo _ hmap y.isPWO_support.isWF)
+    (fun a b hab => hmono hab) (le_refl _)
+
+def puiseuxRamSection {e : ℕ} (he : 0 < e) (y : HahnSeries ℚ K) : HahnSeries ℤ K where
+  coeff k := y.coeff ((k : ℚ) / e)
+  isPWO_support' := isPWO_ramScale_preimage_support he y
+
+theorem puiseuxRamEmb_section {e : ℕ} (he : 0 < e) {y : HahnSeries ℚ K}
+    (hy : HasRamBound e y) : puiseuxRamEmb he (puiseuxRamSection he y) = y := by
+  ext q
+  by_cases hq : q ∈ Set.range (ramScale e)
+  · obtain ⟨k, rfl⟩ := hq
+    simp only [ramScale_apply, puiseuxRamEmb, embDomainRingHom_apply]
+    erw [embDomain_mk_coeff (ramScale_injective he) (fun a b => ramScale_le_iff he a b)]
+    rfl
+  · have hL : (puiseuxRamEmb he (puiseuxRamSection he y)).coeff q = 0 := by
+      simp only [puiseuxRamEmb, embDomainRingHom_apply]
+      exact HahnSeries.embDomain_of_notMem_range (by simpa [Set.range, ramScale_apply] using hq)
+    have hR : y.coeff q = 0 := by
+      by_contra hne
+      exact hq (hy hne)
+    rw [hL, hR]
+
+theorem mem_range_puiseuxRamEmb_iff {e : ℕ} (he : 0 < e) {y : HahnSeries ℚ K} :
+    y ∈ Set.range (puiseuxRamEmb (K := K) he) ↔ HasRamBound e y :=
+  ⟨fun ⟨x, hx⟩ => hx ▸ hasRamBound_puiseuxRamEmb he x,
+    fun hy => ⟨puiseuxRamSection he y, puiseuxRamEmb_section he hy⟩⟩
+
+end P2MWs13.Puiseux
+
+open P2MWs13.Puiseux in
+theorem solution {K : Type*} [Field K] {e : ℕ} (he : 0 < e)
+    {y : HahnSeries ℚ K} :
+    y ∈ HahnSeries.puiseuxRamSubfield K he ↔ HahnSeries.HasRamBound e y := by
+  rw [HahnSeries.puiseuxRamSubfield, RingHom.mem_fieldRange]
+  exact mem_range_puiseuxRamEmb_iff he
+
+end S_HahnSeries_mem_puiseuxRamSubfield_iff
+end P2MW
+export P2MW.S_HahnSeries_mem_puiseuxRamSubfield_iff (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem HahnSeries.mem_puiseuxRamSubfield_iff {K : Type*} [Field K] {e : ℕ} (he : 0 < e)
+    {y : HahnSeries ℚ K} :
+    y ∈ HahnSeries.puiseuxRamSubfield K he ↔ HahnSeries.HasRamBound e y :=
+  solution he
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_add.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_add.lean
new file mode 100644
index 0000000000..af241515d9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_add.lean
@@ -0,0 +1,77 @@
+/-
+Based on Prove2Me node HeckeEis.IsEichlerIntegral.add
+(c1c5c079-2722-5cb7-92f5-1c48ef405037) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c41a27c0-b3cb-570f-b701-838374738f79
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import Mathlib.Analysis.Calculus.Deriv.Add
+
+/-!
+# Additivity of the Eichler integral relation
+
+Theorem statement: `HeckeEis.IsEichlerIntegral.add` (`c1c5c079-2722-5cb7-92f5-1c48ef405037`), by
+Claude, 2026-09-05.
+
+Proof: submission `c41a27c0-b3cb-570f-b701-838374738f79`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $n$ be a natural number, let $f,g:\mathcal H\to\mathbb C$ be functions on the upper half-plane,
+and let $F,G:\mathcal H\to \mathrm{BinaryForm}\,\mathbb C\,n$ be functions with values in the
+submodule of $\mathbb C[X_0,X_1]$ of polynomials homogeneous of degree $n$ ([`HeckeEis.BinaryForm ℂ
+n`](def/HeckeEis_BinaryFormRep.html#L25) is `MvPolynomial.homogeneousSubmodule (Fin 2) ℂ n`). The
+hypotheses are that $F$ is an Eichler integral of $f$ in the sense of
+[`HeckeEis.IsEichlerIntegral`](def/HeckeEis_EichlerIntegral.html#L105), i.e. for every multidegree
+$d:\mathrm{Fin}\,2\to_0\mathbb N$ and every $\tau\in\mathcal H$ the function $z\mapsto
+\mathrm{coeff}_d\big(F(\mathrm{ofComplex}\,z)\big)$ of a complex variable has derivative
+$f(\tau)\cdot \mathrm{coeff}_d\big((\tau X_0+X_1)^n\big)$ at the point $z=\tau$, and that $G$ stands
+in the same relation to $g$. The conclusion is that the pointwise sum $F+G$ is an Eichler integral
+of $f+g$ in exactly the same sense: for all $d$ and $\tau$, the coefficient function of $F+G$ in
+degree $d$ is differentiable at $\tau$ with derivative $(f+g)(\tau)\cdot \mathrm{coeff}_d\big((\tau
+X_0+X_1)^n\big)$. No holomorphy, growth or modularity assumption on $f$, $g$, $F$ or $G$ enters.
+
+This is the additivity half of the bilinearity of the Eichler integral relation $dF=f(\tau)(\tau
+X_0+X_1)^n\,d\tau$ between a weight $n+2$ form and its $\mathrm{Sym}^n$-valued primitive. It is used
+to prove that the Eichler–Shimura map is additive
+([`HeckeEis.eichlerShimuraMap_add`](thm.html#HeckeEis.eichlerShimuraMap_add)), and more generally
+whenever Eichler integrals of sums of translates occur.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_IsEichlerIntegral_add.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+theorem solution {n : ℕ} {f g : UpperHalfPlane → ℂ}
+    {F G : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)}
+    (hF : HeckeEis.IsEichlerIntegral n f F) (hG : HeckeEis.IsEichlerIntegral n g G) :
+    HeckeEis.IsEichlerIntegral n (f + g) (F + G) := by
+  intro d τ
+  have h := (hF d τ).add (hG d τ)
+  simp only [← add_mul] at h
+  refine h.congr_of_eventuallyEq (Filter.Eventually.of_forall fun z => ?_)
+  simp only [Pi.add_apply, Submodule.coe_add, AddMonoidAlgebra.coeff_add, Finsupp.add_apply]
+
+end privateSection
+
+public section publicSection
+
+open scoped MatrixGroups
+theorem HeckeEis.IsEichlerIntegral.add {n : ℕ} {f g : UpperHalfPlane → ℂ}
+    {F G : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)}
+    (hF : HeckeEis.IsEichlerIntegral n f F) (hG : HeckeEis.IsEichlerIntegral n g G) :
+    HeckeEis.IsEichlerIntegral n (f + g) (F + G) := _root_.solution hF hG
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_binarySubst_adjugate_comp_smul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_binarySubst_adjugate_comp_smul.lean
new file mode 100644
index 0000000000..293434b27e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_binarySubst_adjugate_comp_smul.lean
@@ -0,0 +1,284 @@
+/-
+Based on Prove2Me node HeckeEis.IsEichlerIntegral.binarySubst_adjugate_comp_smul
+(7d13aadd-a481-5cb5-934a-fe21684123f3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1e53565a-0ffa-54a9-870c-de4563dcb90f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.SlashActions
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import Mathlib.Analysis.Complex.UpperHalfPlane.Manifold
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Eichler integrals under integral matrices of positive determinant
+
+Theorem statement: `HeckeEis.IsEichlerIntegral.binarySubst_adjugate_comp_smul`
+(`7d13aadd-a481-5cb5-934a-fe21684123f3`), by Claude, 2026-09-05.
+
+Proof: submission `1e53565a-0ffa-54a9-870c-de4563dcb90f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $n \in \mathbb{N}$, a function $f : \mathbb{H} \to \mathbb{C}$ and a function $F$ from
+$\mathbb{H}$ to the submodule [`HeckeEis.BinaryForm ℂ n`](def/HeckeEis_BinaryFormRep.html#L25) of
+degree-$n$ homogeneous polynomials in $\mathbb{C}[X_0,X_1]$, and suppose
+[`HeckeEis.IsEichlerIntegral n f F`](def/HeckeEis_EichlerIntegral.html#L105) holds, i.e. for every
+multidegree $d : \mathrm{Fin}\,2 \to_{0} \mathbb{N}$ and every $\tau \in \mathbb{H}$ the function $z
+\mapsto \operatorname{coeff}_d F(\mathrm{ofComplex}\,z)$ has derivative $f(\tau)\cdot
+\operatorname{coeff}_d\big((\tau X_0 + X_1)^n\big)$ at $z = \tau$. Let $M$ be a $2\times 2$ integer
+matrix with $\det M > 0$, and let $\beta \in \mathrm{GL}_2(\mathbb{R})$ have underlying real matrix
+the entrywise image of $M$ under $\mathbb{Z} \to \mathbb{R}$. The conclusion is that
+[`HeckeEis.IsEichlerIntegral n`](def/HeckeEis_EichlerIntegral.html#L105) again holds for the pair
+consisting of the weight-$(n+2)$ slash $f \mid[(n:\mathbb{Z})+2]\,\beta$, given by $\tau \mapsto
+(\det\beta)^{n+1} j(\beta,\tau)^{-(n+2)} f(\beta\cdot\tau)$, and of the function $\tau \mapsto
+\mathrm{adj}(M)\cdot F(\beta\cdot\tau)$, where $\mathrm{adj}(M)$ acts through [`HeckeEis.binarySubst
+ℂ M.adjugate`](def/HeckeEis_BinaryFormRep.html#L28), the algebra endomorphism of
+$\mathbb{C}[X_0,X_1]$ sending $X_j$ to $\sum_i \mathrm{adj}(M)_{ij} X_i$, restricted to degree-$n$
+forms via [`HeckeEis.binarySubst_mem`](def/HeckeEis_BinaryFormRep.html#L52).
+
+This is the Hecke-equivariance step for Eichler integrals: an Eichler integral of $f$ in weight
+$n+2$ transforms, under an integral matrix of positive determinant, into an Eichler integral of the
+slashed form, with the binary-form values twisted by the adjugate substitution. It is used in the
+computation of the action of the Hecke operators $T_\ell$ and $U_\ell$ on Eichler–Shimura cohomology
+classes, in
+[`HeckeEis.coeffH1Mk_cocycle_heckeTLin_modularForm`]
+(thm.html#HeckeEis.coeffH1Mk_cocycle_heckeTLin_modularForm),
+[`HeckeEis.eichlerShimuraMap_heckeTLin`](thm.html#HeckeEis.eichlerShimuraMap_heckeTLin) and
+[`HeckeEis.eichlerShimuraMap_heckeULin`](thm.html#HeckeEis.eichlerShimuraMap_heckeULin).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_IsEichlerIntegral_binarySubst_adjugate_comp_smul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_IsEichlerIntegral_binarySubst_adjugate_comp_smul
+
+open scoped Manifold MatrixGroups ModularForm
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_mem linePow coe_linePow binarySubst_line \
+  IsEichlerIntegral"
+p2m_open "HeckeEis"
+
+open UpperHalfPlane MvPolynomial
+open scoped Manifold MatrixGroups ModularForm
+
+namespace DetPosAux
+
+variable {n : ℕ}
+
+theorem slash_apply_of_det_pos (f : ℍ → ℂ) (k : ℤ) {β : GL (Fin 2) ℝ} (hβ : 0 < β.val.det) (τ : ℍ) :
+    (f ∣[k] β) τ = f (β • τ) * (↑β.val.det) ^ (k - 1) * denom β ↑τ ^ (-k) := by
+  have hβ' : 0 < β.det.val := by rwa [Matrix.GeneralLinearGroup.val_det_apply]
+  rw [ModularForm.slash_apply, σ, ite_eq_left hβ', ContinuousAlgEquiv.refl_apply]
+  have habs : |β.det.val| = β.val.det := by
+    rw [abs_of_pos hβ', Matrix.GeneralLinearGroup.val_det_apply]
+  rw [habs]
+
+theorem hasDerivAt_comp_smul_of_det_pos {G : ℍ → ℂ} {g : ℂ}
+    {β : GL (Fin 2) ℝ} (hβ : 0 < β.val.det) (τ : ℍ)
+    (hG : HasDerivAt (G ∘ ofComplex) g ↑(β • τ)) :
+    HasDerivAt (fun z : ℂ => G (β • ofComplex z)) (g * (↑β.val.det / denom β ↑τ ^ 2)) ↑τ := by
+  have hfun : (fun z : ℂ => G (β • ofComplex z))
+      = (G ∘ ofComplex) ∘ fun z : ℂ => ((β • ofComplex z : ℍ) : ℂ) := by
+    funext z
+    simp only [Function.comp_apply, ofComplex_apply]
+  have houter : HasDerivAt (G ∘ ofComplex) g ((fun z : ℂ => ((β • ofComplex z : ℍ) : ℂ)) ↑τ) := by
+    simpa only [ofComplex_apply] using hG
+  have hinner : HasDerivAt (fun z : ℂ => ((β • ofComplex z : ℍ) : ℂ)) (↑β.val.det / denom β ↑τ ^ 2)
+    ↑τ :=
+    (UpperHalfPlane.hasStrictDerivAt_smul hβ τ).hasDerivAt
+  have hcomp := houter.comp (↑τ : ℂ) hinner
+  rwa [← hfun] at hcomp
+
+def degExps (n : ℕ) : Finset (Fin 2 →₀ ℕ) :=
+  (Finset.range (n + 1)).image fun k => Finsupp.single 0 k + Finsupp.single 1 (n - k)
+
+theorem mem_degExps_iff (d : Fin 2 →₀ ℕ) : d ∈ degExps n ↔ d.degree = n := by
+  rw [Finsupp.degree_eq_sum, Fin.sum_univ_two]
+  simp only [degExps, Finset.mem_image, Finset.mem_range]
+  constructor
+  · rintro ⟨k, hk, rfl⟩
+    simp
+    omega
+  · intro h
+    refine ⟨d 0, by omega, ?_⟩
+    ext i
+    fin_cases i
+    · simp
+    · simp
+      omega
+
+theorem eq_sum_degExps {K : Type*} [CommRing K] {p : MvPolynomial (Fin 2) K}
+    (hp : p ∈ BinaryForm K n) :
+    p = ∑ e ∈ degExps n, monomial e (AddMonoidAlgebra.coeff p e) := by
+  refine MvPolynomial.ext _ _ fun d => ?_
+  rw [coeff_sum]
+  simp only [coeff_monomial]
+  by_cases hd : d ∈ degExps n
+  · rw [Finset.sum_eq_single d (fun e _ hne => ite_eq_right hne) (fun h => (h hd).elim), ite_eq_left
+      rfl]
+  · rw [Finset.sum_eq_zero (fun e he => ite_eq_right (fun h : e = d => hd (h ▸ he)))]
+    exact ((mem_homogeneousSubmodule n p).mp hp).coeff_eq_zero (by rwa [mem_degExps_iff] at hd)
+
+theorem coeff_binarySubst_eq_sum {K : Type*} [CommRing K] (M : Matrix (Fin 2) (Fin 2) ℤ)
+    (v : ↥(BinaryForm K n))
+    (d : Fin 2 →₀ ℕ) :
+    AddMonoidAlgebra.coeff (binarySubst K M (v : MvPolynomial (Fin 2) K)) d
+      = ∑ e ∈ degExps n, AddMonoidAlgebra.coeff (v : MvPolynomial (Fin 2) K) e *
+        AddMonoidAlgebra.coeff (binarySubst K M (monomial e 1)) d := by
+  conv_lhs => rw [eq_sum_degExps v.2, map_sum, coeff_sum]
+  refine Finset.sum_congr rfl fun e _ => ?_
+  rw [show monomial e (AddMonoidAlgebra.coeff (v : MvPolynomial (Fin 2) K) e) =
+    AddMonoidAlgebra.coeff (v : MvPolynomial (Fin 2) K) e • monomial e (1 : K) by
+      rw [smul_monomial, smul_eq_mul, mul_one],
+    map_smul, coeff_smul, smul_eq_mul]
+
+theorem binarySubst_adjugate_linePow {M : Matrix (Fin 2) (Fin 2) ℤ} (hM : 0 < M.det)
+    {β : GL (Fin 2) ℝ}
+    (hβM : (β : Matrix (Fin 2) (Fin 2) ℝ) = M.map (algebraMap ℤ ℝ)) (τ : ℍ) :
+    binarySubst ℂ M.adjugate ((linePow n ((β • τ : ℍ) : ℂ) : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin
+      2) ℂ)
+      = ((M.det : ℂ) / denom β ↑τ) ^ n • ((linePow n (τ : ℂ) : ↥(BinaryForm ℂ n)) : MvPolynomial
+        (Fin 2) ℂ) := by
+  have hdet : (0 : ℝ) < β.val.det := by
+    rw [hβM, ← RingHom.mapMatrix_apply, ← RingHom.map_det, eq_intCast]
+    exact_mod_cast hM
+  have hdet' : 0 < (↑(Matrix.GeneralLinearGroup.det β) : ℝ) := by
+    rwa [Matrix.GeneralLinearGroup.val_det_apply]
+  have hden : denom β (τ : ℂ) ≠ 0 := denom_ne_zero β τ
+  have hβe : ∀ i j, (β : Matrix (Fin 2) (Fin 2) ℝ) i j = (M i j : ℝ) := fun i j => by
+    rw [hβM]; rfl
+  rw [coe_linePow, coe_linePow, map_pow, binarySubst_line, smul_eq_C_mul, C_pow, ← mul_pow]
+  congr 1
+  set x : ℂ := (M.det : ℂ) / denom β ↑τ with hx
+  have hz : ((β • τ : ℍ) : ℂ) = num β ↑τ / denom β ↑τ := coe_smul_of_det_pos hdet' τ
+  have hnum : num β ↑τ = (M 0 0 : ℂ) * ↑τ + (M 0 1 : ℂ) := by
+    simp [num, hβe]
+  have hdenE : denom β ↑τ = (M 1 0 : ℂ) * ↑τ + (M 1 1 : ℂ) := by
+    simp [denom, hβe]
+  have a00 : M.adjugate 0 0 = M 1 1 := by simp [Matrix.adjugate_fin_two]
+  have a01 : M.adjugate 0 1 = -M 0 1 := by simp [Matrix.adjugate_fin_two]
+  have a10 : M.adjugate 1 0 = -M 1 0 := by simp [Matrix.adjugate_fin_two]
+  have a11 : M.adjugate 1 1 = M 0 0 := by simp [Matrix.adjugate_fin_two]
+  have e0 : ((M.adjugate 0 0 : ℤ) : ℂ) * ((β • τ : ℍ) : ℂ) + ((M.adjugate 0 1 : ℤ) : ℂ) = x * ↑τ :=
+    by
+    rw [a00, a01, hz, hx]
+    field_simp
+    rw [hnum, hdenE, Matrix.det_fin_two]
+    push_cast
+    ring
+  have e1 : ((M.adjugate 1 0 : ℤ) : ℂ) * ((β • τ : ℍ) : ℂ) + ((M.adjugate 1 1 : ℤ) : ℂ) = x := by
+    rw [a10, a11, hz, hx]
+    field_simp
+    rw [hnum, hdenE, Matrix.det_fin_two]
+    push_cast
+    ring
+  rw [e0, e1, map_mul]
+  ring
+
+end DetPosAux
+
+end HeckeEis
+
+open _root_.HeckeEis
+  _root_.P2MW.S_HeckeEis_IsEichlerIntegral_binarySubst_adjugate_comp_smul.HeckeEis
+  HeckeEis.DetPosAux UpperHalfPlane MvPolynomial in
+theorem solution {n : ℕ} {f : UpperHalfPlane → ℂ}
+    {F : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)} (hF : HeckeEis.IsEichlerIntegral n f F)
+    {M : Matrix (Fin 2) (Fin 2) ℤ} (hM : 0 < M.det) {β : GL (Fin 2) ℝ}
+    (hβM : (β : Matrix (Fin 2) (Fin 2) ℝ) = M.map (algebraMap ℤ ℝ)) :
+    HeckeEis.IsEichlerIntegral n (f ∣[((n : ℤ) + 2)] β)
+      (fun τ => ((HeckeEis.binarySubst ℂ M.adjugate).toLinearMap.restrict
+        (fun _ h => HeckeEis.binarySubst_mem ℂ M.adjugate h)) (F (β • τ))) := by
+  intro d τ
+  have hdet : (0 : ℝ) < β.val.det := by
+    rw [hβM, ← RingHom.mapMatrix_apply, ← RingHom.map_det, eq_intCast]
+    exact_mod_cast hM
+  have hdetM : (β.val.det : ℂ) = (M.det : ℂ) := by
+    rw [hβM, ← RingHom.mapMatrix_apply, ← RingHom.map_det]
+    simp
+  have hden : denom β (τ : ℂ) ≠ 0 := denom_ne_zero β τ
+  set c : ℂ := f (β • τ) * (↑β.val.det / denom β ↑τ ^ 2) with hc
+  have hH : ∀ e : Fin 2 →₀ ℕ, HasDerivAt
+      (fun z : ℂ => AddMonoidAlgebra.coeff ((F (β • ofComplex z) : ↥(BinaryForm ℂ n)) : MvPolynomial
+        (Fin 2) ℂ) e)
+      (AddMonoidAlgebra.coeff (((c • linePow n ((β • τ : ℍ) : ℂ)) : ↥(BinaryForm ℂ n)) :
+        MvPolynomial (Fin 2) ℂ) e) ↑τ := by
+    intro e
+    have h1 :=
+      hasDerivAt_comp_smul_of_det_pos (G := fun w : ℍ => AddMonoidAlgebra.coeff ((F w : ↥(BinaryForm
+        ℂ n)) : MvPolynomial (Fin 2) ℂ) e)
+      hdet τ (hF e (β • τ))
+    refine h1.congr_deriv ?_
+    rw [Submodule.coe_smul, coeff_smul, smul_eq_mul, hc]
+    ring
+  have hfun : (fun z : ℂ => AddMonoidAlgebra.coeff ((((binarySubst ℂ
+    M.adjugate).toLinearMap.restrict
+        (fun _ h => binarySubst_mem ℂ M.adjugate h)) (F (β • ofComplex z)) : ↥(BinaryForm ℂ n)) :
+          MvPolynomial (Fin 2) ℂ) d)
+      = fun z : ℂ => ∑ e ∈ degExps n,
+          AddMonoidAlgebra.coeff ((F (β • ofComplex z) : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2)
+            ℂ) e
+            * AddMonoidAlgebra.coeff (binarySubst ℂ M.adjugate (monomial e 1)) d := by
+    funext z
+    exact coeff_binarySubst_eq_sum M.adjugate (F (β • ofComplex z)) d
+  rw [hfun]
+  have h2 : HasDerivAt (fun z : ℂ => ∑ e ∈ degExps n,
+          AddMonoidAlgebra.coeff ((F (β • ofComplex z) : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2)
+            ℂ) e
+            * AddMonoidAlgebra.coeff (binarySubst ℂ M.adjugate (monomial e 1)) d)
+      (∑ e ∈ degExps n, AddMonoidAlgebra.coeff (((c • linePow n ((β • τ : ℍ) : ℂ)) : ↥(BinaryForm ℂ
+        n)) : MvPolynomial (Fin 2) ℂ) e
+            * AddMonoidAlgebra.coeff (binarySubst ℂ M.adjugate (monomial e 1)) d) ↑τ :=
+    HasDerivAt.fun_sum fun e _ => (hH e).mul_const _
+  refine h2.congr_deriv ?_
+  rw [← coeff_binarySubst_eq_sum M.adjugate (c • linePow n ((β • τ : ℍ) : ℂ)) d, Submodule.coe_smul,
+    map_smul,
+    binarySubst_adjugate_linePow hM hβM τ, smul_smul, coeff_smul, smul_eq_mul,
+    slash_apply_of_det_pos f _ hdet τ, hc, hdetM]
+  congr 1
+  rw [show (n : ℤ) + 2 - 1 = ((n + 1 : ℕ) : ℤ) by push_cast; ring, zpow_natCast,
+    show (-((n : ℤ) + 2)) = -(((n + 2 : ℕ) : ℤ)) by push_cast; ring, zpow_neg, zpow_natCast]
+  rw [div_pow]
+  field_simp
+  ring
+
+end
+
+end S_HeckeEis_IsEichlerIntegral_binarySubst_adjugate_comp_smul
+end P2MW
+export P2MW.S_HeckeEis_IsEichlerIntegral_binarySubst_adjugate_comp_smul (solution)
+
+end privateSection
+
+public section publicSection
+
+open scoped MatrixGroups ModularForm
+
+theorem HeckeEis.IsEichlerIntegral.binarySubst_adjugate_comp_smul {n : ℕ} {f : UpperHalfPlane → ℂ}
+    {F : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)} (hF : HeckeEis.IsEichlerIntegral n f F)
+    {M : Matrix (Fin 2) (Fin 2) ℤ} (hM : 0 < M.det) {β : GL (Fin 2) ℝ}
+    (hβM : (β : Matrix (Fin 2) (Fin 2) ℝ) = M.map (algebraMap ℤ ℝ)) :
+    HeckeEis.IsEichlerIntegral n (f ∣[((n : ℤ) + 2)] β)
+      (fun τ => ((HeckeEis.binarySubst ℂ M.adjugate).toLinearMap.restrict
+        (fun _ h => HeckeEis.binarySubst_mem ℂ M.adjugate h)) (F (β • τ))) :=
+  solution hF hM hβM
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_eq_zero_of_eval_eq_const.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_eq_zero_of_eval_eq_const.lean
new file mode 100644
index 0000000000..0c37cc4b9f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_eq_zero_of_eval_eq_const.lean
@@ -0,0 +1,143 @@
+/-
+Based on Prove2Me node HeckeEis.IsEichlerIntegral.eq_zero_of_eval_eq_const
+(fe5d2f3a-0740-57ed-8313-443b017b4ca1) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f8bcd7b6-882a-529b-a52d-d65cdcdbc0ac
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_hasDerivAt_eval_iterate_pderiv
+import LeanPool.FLTEichlerShimura.Theorems.Thm_MvPolynomial_IsHomogeneous_iterate_pderiv_eq_zero_of_lt
+
+/-!
+# Eichler integral with constant evaluation at (1,-τ) integrates zero
+
+Theorem statement: `HeckeEis.IsEichlerIntegral.eq_zero_of_eval_eq_const`
+(`fe5d2f3a-0740-57ed-8313-443b017b4ca1`), by Claude, 2026-09-05.
+
+Proof: submission `f8bcd7b6-882a-529b-a52d-d65cdcdbc0ac`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $n$, a function $g\colon\mathfrak H\to\mathbb C$ on the upper half-plane, and a
+function $G$ on $\mathfrak H$ with values in [`HeckeEis.BinaryForm ℂ
+n`](def/HeckeEis_BinaryFormRep.html#L25), the submodule of $\mathbb C$-coefficient polynomials in
+two variables $X_0,X_1$ that are homogeneous of degree $n$. Assume $G$ is an Eichler integral of $g$
+in the sense of [`HeckeEis.IsEichlerIntegral`](def/HeckeEis_EichlerIntegral.html#L105): for every
+multi-exponent $d\in(\mathrm{Fin}\,2\to_0\mathbb N)$ and every $\tau\in\mathfrak H$, the function
+$z\mapsto$ (coefficient of $d$ in $G(\mathrm{ofComplex}\,z)$), defined on $\mathbb C$ via the
+retraction $\mathrm{ofComplex}$ onto the upper half-plane, is differentiable at $\tau$ with
+derivative $g(\tau)$ times the coefficient of $d$ in $(\tau X_0+X_1)^n$; thus coefficientwise
+$G'(\tau)=g(\tau)\,(\tau X_0+X_1)^n$. Assume further that there is a constant $c\in\mathbb C$ such
+that for every $\tau\in\mathfrak H$ the binary form $G(\tau)$ evaluated at $(X_0,X_1)=(1,-\tau)$,
+the zero of $\tau X_0+X_1$, equals $c$. The conclusion is that $g$ is the zero function on
+$\mathfrak H$.
+
+This is the uniqueness statement underlying the Eichler–Shimura correspondence: evaluation of an
+Eichler integral of weight $n+2$ at the moving point $(1,-\tau)$ determines the integrated function
+up to nothing, so a constant period function forces the form to vanish. It is used for the
+injectivity of the Eichler–Shimura map, via
+[`HeckeEis.eichlerShimuraMap_injective`](thm.html#HeckeEis.eichlerShimuraMap_injective) and
+[`HeckeEis.modularForm_eq_zero_of_coeffH1Mk_cocycle_eq_zero`]
+(thm.html#HeckeEis.modularForm_eq_zero_of_coeffH1Mk_cocycle_eq_zero).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_IsEichlerIntegral_eq_zero_of_eval_eq_const.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+noncomputable section
+
+namespace HeckeEis
+namespace LadderAux
+
+open UpperHalfPlane MvPolynomial Filter Function
+open scoped MatrixGroups Topology
+
+variable {n : ℕ} {g : ℍ → ℂ} {G : ℍ → ↥(BinaryForm ℂ n)}
+
+def rung (G : ℍ → ↥(BinaryForm ℂ n)) (j : ℕ) (τ : ℍ) : ℂ :=
+  MvPolynomial.eval ![(1 : ℂ), -(τ : ℂ)] ((MvPolynomial.pderiv 1)^[j] ((G τ : ↥(BinaryForm ℂ n)) :
+    MvPolynomial (Fin 2) ℂ))
+
+theorem rung_succ_n (G : ℍ → ↥(BinaryForm ℂ n)) (τ : ℍ) : rung G (n + 1) τ = 0 := by
+  rw [rung, MvPolynomial.IsHomogeneous.iterate_pderiv_eq_zero_of_lt ((mem_homogeneousSubmodule n
+    _).mp (G τ).2) 1
+    (Nat.lt_succ_self n), map_zero]
+
+theorem hasDerivAt_rung (hG : IsEichlerIntegral n g G) {j : ℕ} (hj : j ≤ n) (τ : ℍ) :
+    HasDerivAt (rung G j ∘ ofComplex)
+      ((if j = n then ((n.factorial : ℕ) : ℂ) * g τ else 0) - rung G (j + 1) τ) (τ : ℂ) := by
+  have h := hG.hasDerivAt_eval_iterate_pderiv hj τ
+  refine h.congr_of_eventuallyEq ?_
+  filter_upwards [isOpen_upperHalfPlaneSet.mem_nhds τ.2] with z hz
+  simp only [Function.comp_apply, rung]
+  rw [ofComplex_apply_of_im_pos hz]
+
+theorem eq_zero_of_rung_zero_const (hG : IsEichlerIntegral n g G) {c : ℂ}
+    (hc : ∀ τ : ℍ, rung G 0 τ = c) :
+    ∀ τ : ℍ, g τ = 0 := by
+  have hstep : ∀ j : ℕ, j ≤ n → (∃ c : ℂ, ∀ τ : ℍ, rung G j τ = c) →
+      ∀ τ : ℍ, (if j = n then ((n.factorial : ℕ) : ℂ) * g τ else 0) - rung G (j + 1) τ = 0 := by
+    rintro j hj ⟨c', hc'⟩ τ
+    have h1 := hasDerivAt_rung hG hj τ
+    have h2 : HasDerivAt (rung G j ∘ ofComplex) 0 (τ : ℂ) := by
+      refine (hasDerivAt_const (τ : ℂ) c').congr_of_eventuallyEq ?_
+      filter_upwards [isOpen_upperHalfPlaneSet.mem_nhds τ.2] with z hz
+      simp only [Function.comp_apply]
+      exact hc' _
+    exact h1.unique h2
+  have hconst : ∀ j : ℕ, j ≤ n → ∃ c : ℂ, ∀ τ : ℍ, rung G j τ = c := by
+    intro j
+    induction j with
+    | zero => exact fun _ => ⟨c, hc⟩
+    | succ j ih =>
+      intro hj
+      refine ⟨0, fun τ => ?_⟩
+      have := hstep j (by omega) (ih (by omega)) τ
+      rw [ite_eq_right (by omega), zero_sub, neg_eq_zero] at this
+      exact this
+  intro τ
+  have := hstep n le_rfl (hconst n le_rfl) τ
+  rw [ite_eq_left rfl, rung_succ_n, sub_zero] at this
+  have hn : ((n.factorial : ℕ) : ℂ) ≠ 0 := by exact_mod_cast Nat.factorial_ne_zero n
+  exact (mul_eq_zero.mp this).resolve_left hn
+
+end HeckeEis.LadderAux
+
+end
+
+open scoped MatrixGroups in
+theorem solution {n : ℕ} {g : UpperHalfPlane → ℂ}
+    {G : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)} (hG : HeckeEis.IsEichlerIntegral n g G)
+    {c : ℂ}
+    (hc : ∀ τ : UpperHalfPlane,
+      MvPolynomial.eval ![(1 : ℂ), -(τ : ℂ)] ((G τ : ↥(HeckeEis.BinaryForm ℂ n)) : MvPolynomial (Fin
+        2) ℂ) = c) :
+    g = 0 :=
+  funext fun τ => HeckeEis.LadderAux.eq_zero_of_rung_zero_const hG hc τ
+
+end privateSection
+
+public section publicSection
+
+theorem HeckeEis.IsEichlerIntegral.eq_zero_of_eval_eq_const {n : ℕ} {g : UpperHalfPlane → ℂ}
+    {G : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)} (hG : HeckeEis.IsEichlerIntegral n g G)
+    {c : ℂ}
+    (hc : ∀ τ : UpperHalfPlane,
+      MvPolynomial.eval ![(1 : ℂ), -(τ : ℂ)] ((G τ : ↥(HeckeEis.BinaryForm ℂ n)) : MvPolynomial (Fin
+        2) ℂ) = c) :
+    g = 0 := _root_.solution hG hc
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_exists_sub_eq_const.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_exists_sub_eq_const.lean
new file mode 100644
index 0000000000..d75f35e5fa
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_exists_sub_eq_const.lean
@@ -0,0 +1,100 @@
+/-
+Based on Prove2Me node HeckeEis.IsEichlerIntegral.exists_sub_eq_const
+(169dac0f-d214-5bde-beca-b80d527798bc) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1ebccb0b-9fa1-572b-8a80-9f75ddf04174
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import Mathlib.Analysis.Calculus.MeanValue
+import Mathlib.Analysis.InnerProductSpace.Basic
+import Mathlib.Topology.Algebra.Module.ModuleTopology
+
+/-!
+# Eichler integrals of the same form differ by a constant
+
+Theorem statement: `HeckeEis.IsEichlerIntegral.exists_sub_eq_const`
+(`169dac0f-d214-5bde-beca-b80d527798bc`), by Claude, 2026-09-05.
+
+Proof: submission `1ebccb0b-9fa1-572b-8a80-9f75ddf04174`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $n$, a function $f \colon \mathfrak H \to \mathbb C$ on the upper half plane,
+and two functions $F, G \colon \mathfrak H \to \mathrm{BinaryForm}_{\mathbb C}(n)$, where
+$\mathrm{BinaryForm}_{\mathbb C}(n)$ denotes the $\mathbb C$-submodule of $\mathbb C[X_0, X_1]$
+(polynomials in two variables indexed by `Fin 2`) of forms homogeneous of degree $n$. Assume that
+$F$ and $G$ each satisfy [`HeckeEis.IsEichlerIntegral n f`](def/HeckeEis_EichlerIntegral.html#L105),
+that is: for every exponent vector $d \colon \mathrm{Fin}\,2 \to_{\mathrm f} \mathbb N$ and every
+$\tau \in \mathfrak H$, the function $z \mapsto \mathrm{coeff}_d\big(F(\mathrm{ofComplex}\,z)\big)$
+on $\mathbb C$ has complex derivative $f(\tau) \cdot \mathrm{coeff}_d\big((\tau X_0 + X_1)^n\big)$
+at the point $\tau$, and likewise for $G$ (here $\mathrm{ofComplex}$ is the retraction of $\mathbb
+C$ onto $\mathfrak H$, and the coefficients are taken of the underlying polynomial). The conclusion
+is that there exists a single homogeneous form $v \in \mathrm{BinaryForm}_{\mathbb C}(n)$ such that
+$F(\tau) - G(\tau) = v$ for every $\tau \in \mathfrak H$.
+
+This is the uniqueness up to an additive constant of an Eichler integral: a primitive of the
+$\mathrm{Sym}^n$-valued differential $f(\tau)(\tau X_0 + X_1)^n\,d\tau$ is determined by $f$ up to a
+constant binary form. It is used to show that the Eichler–Shimura class attached to a modular form
+does not depend on the chosen primitive, and in the compatibility of that construction with the
+Hecke action.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_IsEichlerIntegral_exists_sub_eq_const.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open UpperHalfPlane HeckeEis
+
+theorem apply_eq_apply_of_hasDerivAt_zero {D : ℂ → ℂ}
+    (hD : ∀ τ : ℍ, HasDerivAt D 0 ↑τ) (z w : ℍ) : D ↑z = D ↑w := by
+  have hmem : ∀ σ : ℍ, (↑σ : ℂ) ∈ {c : ℂ | 0 < c.im} := fun σ => σ.2
+  refine isOpen_upperHalfPlaneSet.is_const_of_fderiv_eq_zero
+    ((convex_halfSpace_im_gt 0).isPreconnected)
+    (fun x hx => ((hD ⟨x, hx⟩).differentiableAt).differentiableWithinAt)
+    (fun x hx => ?_) (hmem z) (hmem w)
+  have h0 := ((hD ⟨x, hx⟩).hasFDerivAt).fderiv
+  rw [Pi.zero_apply, h0]
+  ext1
+  simp
+
+theorem solution {n : ℕ} {f : UpperHalfPlane → ℂ}
+    {F G : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)}
+    (hF : HeckeEis.IsEichlerIntegral n f F) (hG : HeckeEis.IsEichlerIntegral n f G) :
+    ∃ v : ↥(HeckeEis.BinaryForm ℂ n), ∀ τ : UpperHalfPlane, F τ - G τ = v := by
+  refine ⟨F I - G I, fun τ => ?_⟩
+  apply Subtype.ext
+  rw [AddSubgroupClass.coe_sub, AddSubgroupClass.coe_sub]
+  refine MvPolynomial.ext _ _ fun d => ?_
+  rw [AddMonoidAlgebra.coeff_sub, Finsupp.sub_apply, AddMonoidAlgebra.coeff_sub, Finsupp.sub_apply]
+  have key : ∀ σ : ℍ, HasDerivAt
+      (fun z : ℂ => AddMonoidAlgebra.coeff ((F (ofComplex z) : ↥(BinaryForm ℂ n)) :
+          MvPolynomial (Fin 2) ℂ) d
+        - AddMonoidAlgebra.coeff ((G (ofComplex z) : ↥(BinaryForm ℂ n)) :
+          MvPolynomial (Fin 2) ℂ) d) 0 ↑σ :=
+    fun σ => ((hF d σ).sub (hG d σ)).congr_deriv (sub_self _)
+  have hc := apply_eq_apply_of_hasDerivAt_zero key τ I
+  simpa only [ofComplex_apply] using hc
+
+end privateSection
+
+public section publicSection
+
+open scoped MatrixGroups
+theorem HeckeEis.IsEichlerIntegral.exists_sub_eq_const {n : ℕ} {f : UpperHalfPlane → ℂ}
+    {F G : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)}
+    (hF : HeckeEis.IsEichlerIntegral n f F) (hG : HeckeEis.IsEichlerIntegral n f G) :
+    ∃ v : ↥(HeckeEis.BinaryForm ℂ n), ∀ τ : UpperHalfPlane, F τ - G τ = v := _root_.solution hF hG
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_hasDerivAt_eval_iterate_pderiv.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_hasDerivAt_eval_iterate_pderiv.lean
new file mode 100644
index 0000000000..cbe8ec5450
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_hasDerivAt_eval_iterate_pderiv.lean
@@ -0,0 +1,417 @@
+/-
+Based on Prove2Me node HeckeEis.IsEichlerIntegral.hasDerivAt_eval_iterate_pderiv
+(4c48bd9d-6fab-56fd-ba21-25237f94d44e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 90690083-1327-586b-88da-c9ae8d9e3655
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.MvPolynomial.PDeriv
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import Mathlib.Analysis.Calculus.Deriv.Add
+import Mathlib.Analysis.Calculus.Deriv.Mul
+import Mathlib.Analysis.Calculus.Deriv.Pow
+import Mathlib.RingTheory.MvPolynomial.EulerIdentity
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Bol's identity one rung at a time
+
+Theorem statement: `HeckeEis.IsEichlerIntegral.hasDerivAt_eval_iterate_pderiv`
+(`4c48bd9d-6fab-56fd-ba21-25237f94d44e`), by Claude, 2026-09-05.
+
+Proof: submission `90690083-1327-586b-88da-c9ae8d9e3655`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $n \in \mathbb{N}$, a function $g \colon \mathfrak{H} \to \mathbb{C}$ on the upper half-plane,
+and a map $G$ from $\mathfrak{H}$ to the submodule $\mathrm{BinaryForm}\ \mathbb{C}\ n$ of
+$\mathbb{C}$-polynomials in the two variables $X_0, X_1$ that are homogeneous of degree $n$. Assume
+$\mathrm{IsEichlerIntegral}\ n\ g\ G$, i.e. for every exponent vector $d \colon \mathrm{Fin}\ 2
+\to_0 \mathbb{N}$ and every $\tau \in \mathfrak{H}$ the function $z \mapsto
+\operatorname{coeff}_d\bigl(G(\mathrm{ofComplex}\ z)\bigr)$ of a complex variable has derivative
+$g(\tau)\cdot\operatorname{coeff}_d\bigl((\tau X_0 + X_1)^n\bigr)$ at the point $\tau$, where
+$\mathrm{ofComplex}$ is the retraction of $\mathbb{C}$ onto $\mathfrak{H}$. Let $j \le n$ and let
+$\tau \in \mathfrak{H}$. Then the function $z \mapsto \bigl(\partial_{X_1}^{\,j}
+G(\mathrm{ofComplex}\ z)\bigr)(1, -z)$, obtained by applying the partial derivative
+$\mathrm{pderiv}\ 1$ with respect to $X_1$ $j$ times and then evaluating at $X_0 = 1$, $X_1 = -z$,
+has a complex derivative at $\tau$ equal to $$\bigl[j = n\bigr]\, n!\, g(\tau) \;-\;
+\bigl(\partial_{X_1}^{\,j+1} G(\tau)\bigr)(1, -\tau),$$ the first term being $n!\,g(\tau)$ when $j =
+n$ and $0$ otherwise.
+
+This is Bol's identity $\bigl(\tfrac{d}{d\tau}\bigr)^{n+1}\bigl[G(\tau)(1,-\tau)\bigr] = (-1)^n
+n!\,g(\tau)$ for an Eichler integral $G$ of $g$, recorded one derivative at a time so that only
+first derivatives of the intermediate quantities $r_j(\tau) = (\partial_{X_1}^{\,j}
+G(\tau))(1,-\tau)$ occur. It underlies the holomorphy and growth statements
+[`HeckeEis.IsEichlerIntegral.eq_zero_of_eval_eq_const`]
+(thm.html#HeckeEis.IsEichlerIntegral.eq_zero_of_eval_eq_const)
+and
+[`HeckeEis.IsEichlerIntegral.isBoundedAtImInfty_eval`]
+(thm.html#HeckeEis.IsEichlerIntegral.isBoundedAtImInfty_eval),
+and through them the injectivity of the Eichler–Shimura map
+[`HeckeEis.eichlerShimuraMap_injective`](thm.html#HeckeEis.eichlerShimuraMap_injective).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_IsEichlerIntegral_hasDerivAt_eval_iterate_pderiv.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_IsEichlerIntegral_hasDerivAt_eval_iterate_pderiv
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm coe_linePow IsEichlerIntegral"
+namespace BolAux
+p2m_open "HeckeEis"
+
+open UpperHalfPlane MvPolynomial
+open scoped MatrixGroups
+
+variable {K : Type*} [CommRing K]
+
+theorem coeff_pderiv_one (P : MvPolynomial (Fin 2) K) (d : Fin 2 →₀ ℕ) :
+    AddMonoidAlgebra.coeff (pderiv 1 P) d = ((d 1 + 1 : ℕ) : K) * AddMonoidAlgebra.coeff P (d +
+      Finsupp.single 1 1) := by
+  induction P using MvPolynomial.induction_on' with
+  | monomial s a =>
+    rw [pderiv_monomial, coeff_monomial, coeff_monomial]
+    by_cases hs : s = d + Finsupp.single 1 1
+    · subst hs
+      simp only [add_tsub_cancel_right, ↓reduceIte, Finsupp.coe_add, Pi.add_apply,
+        Finsupp.single_eq_same]
+      push_cast
+      ring
+    · rw [ite_eq_right hs, mul_zero]
+      split_ifs with h
+      · have hs1 : s 1 = 0 := by
+          by_contra hne
+          apply hs
+          rw [← h]
+          ext i
+          fin_cases i
+          · simp
+          · simp only [Fin.mk_one, Fin.isValue, Finsupp.coe_add, Finsupp.coe_tsub, Pi.add_apply,
+              Pi.sub_apply,
+              Finsupp.single_eq_same]
+            omega
+        simp [hs1]
+      · rfl
+  | add p q hp hq =>
+    rw [map_add, AddMonoidAlgebra.coeff_add, Finsupp.add_apply, AddMonoidAlgebra.coeff_add,
+      Finsupp.add_apply, hp, hq, mul_add]
+
+theorem coeff_iterate_pderiv_one (P : MvPolynomial (Fin 2) K) (j : ℕ) (d : Fin 2 →₀ ℕ) :
+    AddMonoidAlgebra.coeff ((pderiv 1)^[j] P) d = ((d 1 + j).descFactorial j : K) *
+      AddMonoidAlgebra.coeff P (d + Finsupp.single 1 j) := by
+  induction j generalizing d with
+  | zero => simp
+  | succ j ih =>
+    rw [Function.iterate_succ_apply', coeff_pderiv_one, ih]
+    have e1 : d + Finsupp.single 1 1 + Finsupp.single 1 j = d + Finsupp.single 1 (j + 1) := by
+      rw [add_assoc, ← Finsupp.single_add, add_comm 1 j]
+    have e2 : ((d 1 + 1 : ℕ) : K) * ((((d + Finsupp.single 1 1 : Fin 2 →₀ ℕ) 1 + j).descFactorial j
+      : ℕ) : K)
+        = (((d 1 + (j + 1)).descFactorial (j + 1) : ℕ) : K) := by
+      rw [← Nat.cast_mul]
+      congr 1
+      simp only [Finsupp.coe_add, Pi.add_apply, Finsupp.single_eq_same]
+      rw [show d 1 + (j + 1) = d 1 + 1 + j by ring, Nat.descFactorial_succ, Nat.add_sub_cancel]
+    rw [e1, ← mul_assoc, e2]
+
+theorem isHomogeneous_iterate_pderiv {σ : Type*} {P : MvPolynomial σ K} {n : ℕ} (i : σ)
+    (hP : P.IsHomogeneous n) (j : ℕ) :
+    ((pderiv i)^[j] P).IsHomogeneous (n - j) := by
+  induction j with
+  | zero => simpa using hP
+  | succ j ih =>
+    rw [Function.iterate_succ_apply']
+    simpa [Nat.sub_sub] using ih.pderiv
+
+theorem iterate_pderiv_one_eq_zero_of_lt {n : ℕ} {P : MvPolynomial (Fin 2) K}
+    (hP : P.IsHomogeneous n) {i : ℕ}
+    (hi : n < i) : (pderiv 1)^[i] P = 0 := by
+  ext d
+  rw [coeff_iterate_pderiv_one, AddMonoidAlgebra.coeff_zero, Finsupp.zero_apply]
+  have : AddMonoidAlgebra.coeff P (d + Finsupp.single 1 i) = 0 := by
+    apply hP.coeff_eq_zero
+    rw [Finsupp.degree_eq_sum, Fin.sum_univ_two]
+    simp only [Finsupp.coe_add, Pi.add_apply, Finsupp.single_eq_same, Finsupp.single_apply]
+    simp
+    omega
+  rw [this, mul_zero]
+
+abbrev ex (n m : ℕ) : Fin 2 →₀ ℕ := Finsupp.single 0 (n - m) + Finsupp.single 1 m
+
+@[scoped simp] theorem ex_zero (n m : ℕ) : ex n m 0 = n - m := by simp [ex]
+@[scoped simp] theorem ex_one (n m : ℕ) : ex n m 1 = m := by simp [ex]
+
+theorem eq_ex_of_degree {m : ℕ} {d : Fin 2 →₀ ℕ} (hd : d.degree = m) : d = ex m (d 1) := by
+  rw [Finsupp.degree_eq_sum, Fin.sum_univ_two] at hd
+  ext i
+  fin_cases i
+  · simp; omega
+  · simp
+
+theorem eval_one_eq_sum {m : ℕ} {Q : MvPolynomial (Fin 2) K} (hQ : Q.IsHomogeneous m) (w : K) :
+    eval ![1, w] Q = ∑ k ∈ Finset.range (m + 1), AddMonoidAlgebra.coeff Q (ex m k) * w ^ k := by
+  classical
+  have hF : ∀ d : Fin 2 →₀ ℕ, AddMonoidAlgebra.coeff Q d * ∏ i, (![1, w] : Fin 2 → K) i ^ d i =
+    AddMonoidAlgebra.coeff Q d * w ^ (d 1) :=
+    by
+    intro d
+    simp [Fin.prod_univ_two]
+  rw [eval_eq', Finset.sum_congr rfl (fun d _ => hF d)]
+  have hinj : Set.InjOn (ex m) (Finset.range (m + 1) : Set ℕ) := by
+    intro a _ b _ h
+    have := congrArg (fun f => f 1) h
+    simpa using this
+  rw [show (∑ k ∈ Finset.range (m + 1), AddMonoidAlgebra.coeff Q (ex m k) * w ^ k)
+      = ∑ d ∈ (Finset.range (m + 1)).image (ex m), AddMonoidAlgebra.coeff Q d * w ^ (d 1) by
+    rw [Finset.sum_image hinj]
+    simp]
+  apply Finset.sum_subset
+  · intro d hd
+    have hdeg : d.degree = m := by
+      by_contra hc
+      exact (mem_support_iff.mp hd) (hQ.coeff_eq_zero hc)
+    rw [Finset.mem_image]
+    refine ⟨d 1, ?_, (eq_ex_of_degree hdeg).symm⟩
+    rw [Finset.mem_range, Finsupp.degree_eq_sum, Fin.sum_univ_two] at *
+    omega
+  · intro d _ hd
+    rw [notMem_support_iff.mp hd, zero_mul]
+
+theorem eval_iterate_pderiv_eq_sum {n : ℕ} {P : MvPolynomial (Fin 2) K} (hP : P.IsHomogeneous n)
+    (i : ℕ) (w : K) :
+    eval ![1, w] ((pderiv 1)^[i] P)
+      = ∑ k ∈ Finset.range (n + 1 - i), ((k + i).descFactorial i : K) * AddMonoidAlgebra.coeff P (ex
+        n (k + i)) * w ^ k := by
+  rcases Nat.lt_or_ge n i with hi | hi
+  swap
+  · rw [eval_one_eq_sum (isHomogeneous_iterate_pderiv 1 hP i), show n + 1 - i = n - i + 1 by omega]
+    refine Finset.sum_congr rfl fun k hk => ?_
+    rw [Finset.mem_range] at hk
+    rw [coeff_iterate_pderiv_one, ex_one]
+    have hex : ex (n - i) k + Finsupp.single 1 i = ex n (k + i) := by
+      ext t
+      fin_cases t
+      · simp [ex]; omega
+      · simp [ex]
+    rw [hex]
+  · rw [iterate_pderiv_one_eq_zero_of_lt hP hi, map_zero, show n + 1 - i = 0 by
+    omega, Finset.range_zero,
+      Finset.sum_empty]
+
+theorem coeff_ex_linePow (n m : ℕ) (hm : m ≤ n) (t : K) :
+    AddMonoidAlgebra.coeff ((C t * X 0 + X 1) ^ n) (ex n m) = (n.choose m : K) * t ^ (n - m) := by
+  classical
+  rw [add_pow, coeff_sum]
+  have hterm : ∀ k ∈ Finset.range (n + 1),
+      AddMonoidAlgebra.coeff ((C t * X 0) ^ k * X 1 ^ (n - k) * (n.choose k : MvPolynomial (Fin 2)
+        K)) (ex n m)
+        = if k = n - m then (n.choose m : K) * t ^ (n - m) else 0 := by
+    intro k hk
+    rw [Finset.mem_range] at hk
+    have hmon : (C t * X 0) ^ k * X 1 ^ (n - k) * (n.choose k : MvPolynomial (Fin 2) K)
+        = monomial (Finsupp.single 0 k + Finsupp.single 1 (n - k)) (t ^ k * (n.choose k : K)) := by
+      rw [mul_pow, ← map_pow, X_pow_eq_monomial, X_pow_eq_monomial, C_mul_monomial,
+        monomial_mul_monomial, ← map_natCast C,
+        mul_comm (monomial _ _) (C _), C_mul_monomial]
+      congr 1 ; simp [mul_comm]
+    rw [hmon, coeff_monomial]
+    by_cases hk' : k = n - m
+    · subst hk'
+      rw [ite_eq_left, ite_eq_left rfl, Nat.choose_symm hm, mul_comm]
+      ext i; fin_cases i <;> simp [ex] ; omega
+    · rw [ite_eq_right, ite_eq_right hk']
+      intro h
+      apply hk'
+      have := congrArg (fun f => f 0) h
+      simp [ex] at this
+      omega
+  rw [Finset.sum_congr rfl hterm, Finset.sum_ite_eq' (Finset.range (n + 1)) (n - m),
+    ite_eq_left (Finset.mem_range.mpr (by omega))]
+
+theorem sum_descFactorial_mul_choose_mul_neg_one_pow (n j : ℕ) (hj : j ≤ n) :
+    ∑ k ∈ Finset.range (n + 1 - j), ((k + j).descFactorial j : K) * (n.choose (k + j) : K) * (-1 :
+      K) ^ k
+      = if j = n then (n.factorial : K) else 0 := by
+  have hkey : ∀ k : ℕ, (k + j).descFactorial j * n.choose (k + j) = n.descFactorial j * (n -
+    j).choose k :=
+    by
+    intro k
+    rw [Nat.descFactorial_eq_factorial_mul_choose, Nat.descFactorial_eq_factorial_mul_choose,
+      mul_assoc, mul_assoc,
+      mul_comm ((k+j).choose j), Nat.choose_mul (Nat.le_add_left j k), Nat.add_sub_cancel]
+  have hcast : ∀ k : ℕ, ((k + j).descFactorial j : K) * (n.choose (k + j) : K)
+      = (n.descFactorial j : K) * ((n - j).choose k : K) := by
+    intro k
+    have := congrArg (Nat.cast (R := K)) (hkey k)
+    push_cast at this
+    exact this
+  simp_rw [hcast, mul_assoc, ← Finset.mul_sum]
+  have halt : ∑ k ∈ Finset.range (n + 1 - j), ((n - j).choose k : K) * (-1 : K) ^ k = if n - j = 0
+    then 1 else 0 :=
+    by
+    have h := (Int.alternating_sum_range_choose (n := n - j))
+    rw [show n + 1 - j = n - j + 1 by omega]
+    have : (∑ k ∈ Finset.range (n - j + 1), ((n - j).choose k : K) * (-1 : K) ^ k)
+        = ((∑ m ∈ Finset.range (n - j + 1), (-1 : ℤ) ^ m * ((n - j).choose m : ℤ) : ℤ) : K) := by
+      push_cast
+      exact Finset.sum_congr rfl fun k _ => by ring
+    rw [this, h]
+    split_ifs <;> simp
+  rw [halt]
+  by_cases hjn : j = n
+  · subst hjn; simp [Nat.descFactorial_self]
+  · rw [ite_eq_right (by omega), ite_eq_right hjn, mul_zero]
+
+theorem hasDerivAt_eval_iterate_pderiv {n : ℕ} {g : ℍ → ℂ} {G : ℍ → ↥(BinaryForm ℂ n)}
+    (hG : IsEichlerIntegral n g G) {j : ℕ} (hj : j ≤ n) (τ : ℍ) :
+    HasDerivAt (fun z : ℂ => MvPolynomial.eval ![(1 : ℂ), -z]
+        ((MvPolynomial.pderiv 1)^[j] ((G (ofComplex z) : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2)
+          ℂ)))
+      ((if j = n then ((n.factorial : ℕ) : ℂ) * g τ else 0)
+        - MvPolynomial.eval ![(1 : ℂ), -(τ : ℂ)]
+          ((MvPolynomial.pderiv 1)^[j + 1] ((G τ : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ))) (τ
+            : ℂ) := by
+  have hhom : ∀ σ : ℍ, ((G σ : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ).IsHomogeneous n :=
+    fun σ =>
+    (mem_homogeneousSubmodule n _).mp (G σ).2
+  set c : ℕ → ℂ → ℂ := fun m z => AddMonoidAlgebra.coeff ((G (ofComplex z) : ↥(BinaryForm ℂ n)) :
+    MvPolynomial (Fin 2) ℂ) (ex n m)
+    with hcdef
+  have hc : ∀ m, m ≤ n → HasDerivAt (c m) (g τ * ((n.choose m : ℂ) * (τ : ℂ) ^ (n - m))) (τ : ℂ) :=
+    by
+    intro m hm
+    have h := hG (ex n m) τ
+    rw [coe_linePow, coeff_ex_linePow n m hm] at h
+    exact h
+  have hfun : (fun z : ℂ => MvPolynomial.eval ![(1 : ℂ), -z]
+        ((MvPolynomial.pderiv 1)^[j] ((G (ofComplex z) : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2)
+          ℂ)))
+      = fun z : ℂ => ∑ k ∈ Finset.range (n + 1 - j), ((k + j).descFactorial j : ℂ) * c (k + j) z *
+        (-z) ^ k := by
+    funext z
+    rw [eval_iterate_pderiv_eq_sum (hhom (ofComplex z)) j (-z)]
+  rw [hfun]
+  have hsum : HasDerivAt (fun z : ℂ => ∑ k ∈ Finset.range (n + 1 - j), ((k + j).descFactorial j : ℂ)
+    * c (k + j) z * (-z) ^ k)
+      (∑ k ∈ Finset.range (n + 1 - j), ((k + j).descFactorial j : ℂ)
+        * (g τ * ((n.choose (k + j) : ℂ) * (τ : ℂ) ^ (n - (k + j))) * (-(τ : ℂ)) ^ k
+            + c (k + j) τ * ((k : ℂ) * (-(τ : ℂ)) ^ (k - 1) * (-1)))) (τ : ℂ) := by
+    rw [show (fun z : ℂ => ∑ k ∈ Finset.range (n + 1 - j), ((k + j).descFactorial j : ℂ) * c (k + j)
+      z * (-z) ^ k)
+        = ∑ k ∈ Finset.range (n + 1 - j), ((fun z : ℂ => ((k + j).descFactorial j : ℂ) * c (k + j) z
+      * (-z) ^ k) : ℂ → ℂ) from
+      (Finset.sum_fn (Finset.range (n + 1 - j)) _).symm]
+    apply HasDerivAt.sum
+    intro k hk
+    rw [Finset.mem_range] at hk
+    have h1 := hc (k + j) (by omega)
+    have h2 : HasDerivAt (fun z : ℂ => (-z) ^ k) ((k : ℂ) * (-(τ : ℂ)) ^ (k - 1) * (-1)) (τ : ℂ) :=
+      (hasDerivAt_neg' (τ : ℂ)).pow k
+    have h3 := (h1.mul h2).const_mul ((k + j).descFactorial j : ℂ)
+    have hcofc : c (k + j) (τ : ℂ) = c (k + j) τ := rfl
+    simpa [mul_assoc, ofComplex_apply] using h3
+  refine hsum.congr_deriv ?_
+  rw [Finset.sum_congr rfl fun k _ => mul_add _ _ _, Finset.sum_add_distrib]
+  have hA : ∑ k ∈ Finset.range (n + 1 - j), ((k + j).descFactorial j : ℂ)
+        * (g τ * ((n.choose (k + j) : ℂ) * (τ : ℂ) ^ (n - (k + j))) * (-(τ : ℂ)) ^ k)
+      = (if j = n then ((n.factorial : ℕ) : ℂ) * g τ else 0) := by
+    calc _ = g τ * (τ : ℂ) ^ (n - j) * ∑ k ∈ Finset.range (n + 1 - j),
+              ((k + j).descFactorial j : ℂ) * (n.choose (k + j) : ℂ) * (-1 : ℂ) ^ k := by
+          rw [Finset.mul_sum]
+          refine Finset.sum_congr rfl fun k hk => ?_
+          rw [Finset.mem_range] at hk
+          rw [neg_pow, show n - j = (n - (k + j)) + k by omega, pow_add]
+          ring
+      _ = _ := by
+          rw [sum_descFactorial_mul_choose_mul_neg_one_pow n j hj]
+          split_ifs with h
+          · subst h
+            rw [Nat.sub_self, pow_zero, mul_one, mul_comm]
+          · rw [mul_zero]
+  have hB : ∑ k ∈ Finset.range (n + 1 - j), ((k + j).descFactorial j : ℂ)
+        * (c (k + j) τ * ((k : ℂ) * (-(τ : ℂ)) ^ (k - 1) * (-1)))
+      = - MvPolynomial.eval ![(1 : ℂ), -(τ : ℂ)]
+          ((MvPolynomial.pderiv 1)^[j + 1] ((G τ : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ)) :=
+            by
+    rw [eval_iterate_pderiv_eq_sum (hhom τ) (j + 1), show n + 1 - j = (n - j) + 1 by
+      omega, Finset.sum_range_succ',
+      show n + 1 - (j + 1) = n - j by omega]
+    simp only [CharP.cast_eq_zero, zero_mul, mul_zero, add_zero]
+    rw [← Finset.sum_neg_distrib]
+    refine Finset.sum_congr rfl fun k hk => ?_
+    rw [Finset.mem_range] at hk
+    have hcτ : c (k + 1 + j) (τ : ℂ) = AddMonoidAlgebra.coeff ((G τ : ↥(BinaryForm ℂ n)) :
+      MvPolynomial (Fin 2) ℂ) (ex n (k + 1 + j)) :=
+      by
+      simp only [hcdef, ofComplex_apply]
+    have hidx : k + (j + 1) = k + 1 + j := by ring
+    have hdesc : (((k + 1 + j).descFactorial (j + 1) : ℕ) : ℂ) = (((k + 1 + j).descFactorial j : ℕ)
+      : ℂ) * ((k : ℂ) + 1) :=
+      by
+      rw [Nat.descFactorial_succ, show k + 1 + j - j = k + 1 by omega]
+      push_cast
+      ring
+    rw [hidx, hcτ, hdesc, Nat.add_sub_cancel]
+    push_cast
+    ring
+  rw [hA, hB, sub_eq_add_neg]
+
+end HeckeEis.BolAux
+end
+
+open scoped MatrixGroups in
+theorem solution {n : ℕ} {g : UpperHalfPlane → ℂ}
+    {G : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)} (hG : HeckeEis.IsEichlerIntegral n g G)
+    {j : ℕ} (hj : j ≤ n)
+    (τ : UpperHalfPlane) :
+    HasDerivAt (fun z : ℂ => MvPolynomial.eval ![(1 : ℂ), -z]
+        ((MvPolynomial.pderiv 1)^[j]
+          ((G (UpperHalfPlane.ofComplex z) : ↥(HeckeEis.BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ)))
+      ((if j = n then ((n.factorial : ℕ) : ℂ) * g τ else 0)
+        - MvPolynomial.eval ![(1 : ℂ), -(τ : ℂ)]
+          ((MvPolynomial.pderiv 1)^[j + 1] ((G τ : ↥(HeckeEis.BinaryForm ℂ n)) : MvPolynomial (Fin
+            2) ℂ)))
+      (τ : ℂ) :=
+  HeckeEis.BolAux.hasDerivAt_eval_iterate_pderiv hG hj τ
+
+end S_HeckeEis_IsEichlerIntegral_hasDerivAt_eval_iterate_pderiv
+end P2MW
+export P2MW.S_HeckeEis_IsEichlerIntegral_hasDerivAt_eval_iterate_pderiv (solution)
+
+end privateSection
+
+public section publicSection
+
+open scoped MatrixGroups
+theorem HeckeEis.IsEichlerIntegral.hasDerivAt_eval_iterate_pderiv {n : ℕ} {g : UpperHalfPlane → ℂ}
+    {G : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)} (hG : HeckeEis.IsEichlerIntegral n g G)
+    {j : ℕ} (hj : j ≤ n)
+    (τ : UpperHalfPlane) :
+    HasDerivAt (fun z : ℂ => MvPolynomial.eval ![(1 : ℂ), -z]
+        ((MvPolynomial.pderiv 1)^[j]
+          ((G (UpperHalfPlane.ofComplex z) : ↥(HeckeEis.BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ)))
+      ((if j = n then ((n.factorial : ℕ) : ℂ) * g τ else 0)
+        - MvPolynomial.eval ![(1 : ℂ), -(τ : ℂ)]
+          ((MvPolynomial.pderiv 1)^[j + 1] ((G τ : ↥(HeckeEis.BinaryForm ℂ n)) : MvPolynomial (Fin
+            2) ℂ)))
+      (τ : ℂ) :=
+  solution hG hj τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_isBoundedAtImInfty_eval.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_isBoundedAtImInfty_eval.lean
new file mode 100644
index 0000000000..0c5a10eaf4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_isBoundedAtImInfty_eval.lean
@@ -0,0 +1,275 @@
+/-
+Based on Prove2Me node HeckeEis.IsEichlerIntegral.isBoundedAtImInfty_eval
+(4344e0ba-9030-543a-8d2f-88300d4dc110) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a56da28a-58ec-599b-9fe9-2e29b382543d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.Complex.UpperHalfPlane.FunctionsBoundedAtInfty
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Manifold
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import Mathlib.Geometry.Manifold.MFDeriv.SpecificFunctions
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_hasDerivAt_eval_iterate_pderiv
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_jFactor_pow_mul_eval_binaryFormRepSL
+import LeanPool.FLTEichlerShimura.Theorems.Thm_MvPolynomial_IsHomogeneous_iterate_pderiv_eq_zero_of_lt
+import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_isBoundedAtImInfty_of_hasDerivAt_of_periodic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Boundedness at i∞ of a T^h-equivariant Eichler integral's evaluation
+
+Theorem statement: `HeckeEis.IsEichlerIntegral.isBoundedAtImInfty_eval`
+(`4344e0ba-9030-543a-8d2f-88300d4dc110`), by Claude, 2026-09-05.
+
+Proof: submission `a56da28a-58ec-599b-9fe9-2e29b382543d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $n\in\mathbb N$, a function $g:\mathfrak H\to\mathbb C$ on the upper half-plane, and a function
+$G$ from $\mathfrak H$ to [`HeckeEis.BinaryForm ℂ n`](def/HeckeEis_BinaryFormRep.html#L25), the
+submodule of degree-$n$ homogeneous elements of $\mathbb C[X_0,X_1]$. The hypothesis
+[`HeckeEis.IsEichlerIntegral n g G`](def/HeckeEis_EichlerIntegral.html#L105) says that $G$ is an
+Eichler integral of $g$ coefficientwise: for every multidegree $d$ and every $\tau\in\mathfrak H$,
+the function $z\mapsto \mathrm{coeff}_d\bigl(G(\mathrm{ofComplex}\,z)\bigr)$ on $\mathbb C$ has
+derivative at $\tau$ equal to $g(\tau)\cdot\mathrm{coeff}_d\bigl((\tau X_0+X_1)^n\bigr)$. Assume
+further an integer $h>0$ such that $g\circ\mathrm{ofComplex}$ is periodic with period $h$; that $g$
+is differentiable as a map of complex manifolds $\mathfrak H\to\mathbb C$; that $g$ is bounded at
+$i\infty$ (`UpperHalfPlane.IsBoundedAtImInfty`); and that $G$ is exactly $T^h$-equivariant, i.e.
+$G(h+\tau)=\rho_n(T^h)\,G(\tau)$ for all $\tau$, where $\rho_n=$ [`HeckeEis.binaryFormRepSL ℂ
+n`](def/HeckeEis_BinaryFormRep.html#L61) is the representation of $\mathrm{SL}_2(\mathbb Z)$ on
+binary forms obtained by substituting $X_j\mapsto\sum_i M_{ij}X_i$, and
+$T=\begin{pmatrix}1&1\\0&1\end{pmatrix}$. The conclusion is that the scalar function $\tau\mapsto
+G(\tau)(1,-\tau)$, the evaluation of the binary form $G(\tau)$ at $(X_0,X_1)=(1,-\tau)$, is bounded
+at $i\infty$.
+
+This is the cuspidal growth estimate in the Eichler–Shimura argument: exact equivariance under the
+stabiliser generator $T^h$ forces the polynomial part of an Eichler integral at the cusp to
+contribute only a constant after evaluation at $(1,-\tau)$. It feeds the injectivity of the
+Eichler–Shimura map,
+[`HeckeEis.eichlerShimuraMap_injective`](thm.html#HeckeEis.eichlerShimuraMap_injective), and the
+vanishing statement
+[`HeckeEis.modularForm_eq_zero_of_coeffH1Mk_cocycle_eq_zero`]
+(thm.html#HeckeEis.modularForm_eq_zero_of_coeffH1Mk_cocycle_eq_zero).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_IsEichlerIntegral_isBoundedAtImInfty_eval.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_IsEichlerIntegral_isBoundedAtImInfty_eval
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binaryFormRepSL jFactor IsEichlerIntegral \
+  jFactor_pow_mul_eval_binaryFormRepSL"
+namespace LadderAux2
+p2m_open "HeckeEis"
+
+open UpperHalfPlane MvPolynomial Filter Function
+open scoped MatrixGroups Manifold Topology
+
+variable {n : ℕ} {g : ℍ → ℂ} {G : ℍ → ↥(BinaryForm ℂ n)}
+
+def rung (G : ℍ → ↥(BinaryForm ℂ n)) (j : ℕ) (τ : ℍ) : ℂ :=
+  MvPolynomial.eval ![(1 : ℂ), -(τ : ℂ)] ((MvPolynomial.pderiv 1)^[j] ((G τ : ↥(BinaryForm ℂ n)) :
+    MvPolynomial (Fin 2) ℂ))
+
+theorem rung_zero (G : ℍ → ↥(BinaryForm ℂ n)) (τ : ℍ) :
+    rung G 0 τ = MvPolynomial.eval ![(1 : ℂ), -(τ : ℂ)] ((G τ : ↥(BinaryForm ℂ n)) : MvPolynomial
+      (Fin 2) ℂ) := rfl
+
+theorem rung_succ_n (G : ℍ → ↥(BinaryForm ℂ n)) (τ : ℍ) : rung G (n + 1) τ = 0 := by
+  rw [rung, MvPolynomial.IsHomogeneous.iterate_pderiv_eq_zero_of_lt ((mem_homogeneousSubmodule n
+    _).mp (G τ).2) 1
+    (Nat.lt_succ_self n), map_zero]
+
+theorem hasDerivAt_rung (hG : IsEichlerIntegral n g G) {j : ℕ} (hj : j ≤ n) (τ : ℍ) :
+    HasDerivAt (rung G j ∘ ofComplex)
+      ((if j = n then ((n.factorial : ℕ) : ℂ) * g τ else 0) - rung G (j + 1) τ) (τ : ℂ) := by
+  have h := hG.hasDerivAt_eval_iterate_pderiv hj τ
+  refine h.congr_of_eventuallyEq ?_
+  filter_upwards [isOpen_upperHalfPlaneSet.mem_nhds τ.2] with z hz
+  simp only [Function.comp_apply, rung]
+  rw [ofComplex_apply_of_im_pos hz]
+
+theorem mdifferentiable_rung (hG : IsEichlerIntegral n g G) {j : ℕ} (hj : j ≤ n) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (rung G j) := by
+  rw [UpperHalfPlane.mdifferentiable_iff]
+  intro z hz
+  exact (hasDerivAt_rung hG hj ⟨z, hz⟩).differentiableAt.differentiableWithinAt
+
+theorem ofComplex_coe_add_real (τ : ℍ) (p : ℝ) : ofComplex ((τ : ℂ) + (p : ℂ)) = (p +ᵥ τ) := by
+  have him : 0 < ((τ : ℂ) + (p : ℂ)).im := by simpa using τ.im_pos
+  rw [ofComplex_apply_of_im_pos him]
+  apply UpperHalfPlane.ext
+  simp [UpperHalfPlane.coe_vadd, add_comm]
+
+section Periodic
+
+variable {h : ℤ}
+
+theorem periodic_comp_ofComplex {φ : ℍ → ℂ} {p : ℝ} (hφ : ∀ τ : ℍ, φ (p +ᵥ τ) = φ τ) :
+    Periodic (φ ∘ ofComplex) (p : ℂ) := by
+  intro z
+  simp only [Function.comp_apply]
+  rcases lt_or_ge 0 z.im with hz | hz
+  · rw [← hφ (ofComplex z), ← ofComplex_coe_add_real (ofComplex z) p,
+      ofComplex_apply_of_im_pos hz]
+  · have hz' : (z + (p : ℂ)).im ≤ 0 := by simpa using hz
+    rw [ofComplex_apply_of_im_nonpos hz', ofComplex_apply_of_im_nonpos hz]
+
+theorem rung_zero_vadd
+    (hT : ∀ τ : ℍ, G ((h : ℝ) +ᵥ τ) = binaryFormRepSL ℂ n (ModularGroup.T ^ h) (G τ)) (τ : ℍ) :
+    rung G 0 ((h : ℝ) +ᵥ τ) = rung G 0 τ := by
+  rw [rung_zero, rung_zero, hT]
+  have key := HeckeEis.jFactor_pow_mul_eval_binaryFormRepSL n (ModularGroup.T ^ h) τ (G τ)
+  have hj : jFactor (ModularGroup.T ^ h) τ = 1 := by
+    simp [jFactor, ModularGroup.coe_T_zpow]
+  rw [hj, one_pow, one_mul, UpperHalfPlane.modular_T_zpow_smul] at key
+  simpa using key
+
+theorem rung_vadd (hG : IsEichlerIntegral n g G) (hper : ∀ τ : ℍ, g ((h : ℝ) +ᵥ τ) = g τ)
+    (hT : ∀ τ : ℍ, G ((h : ℝ) +ᵥ τ) = binaryFormRepSL ℂ n (ModularGroup.T ^ h) (G τ)) :
+    ∀ j : ℕ, j ≤ n + 1 → ∀ τ : ℍ, rung G j ((h : ℝ) +ᵥ τ) = rung G j τ := by
+  intro j
+  induction j with
+  | zero => exact fun _ τ => rung_zero_vadd hT τ
+  | succ j ih =>
+    intro hj τ
+    have hj' : j ≤ n := by omega
+    have hperj : Periodic (rung G j ∘ ofComplex) ((h : ℝ) : ℂ) :=
+      periodic_comp_ofComplex (ih (by omega))
+    have h1 : HasDerivAt (rung G j ∘ ofComplex)
+        ((if j = n then ((n.factorial : ℕ) : ℂ) * g ((h : ℝ) +ᵥ τ) else 0) - rung G (j + 1) ((h : ℝ)
+          +ᵥ τ)) (τ : ℂ) := by
+      have h0 := hasDerivAt_rung hG hj' ((h : ℝ) +ᵥ τ)
+      rw [UpperHalfPlane.coe_vadd, add_comm ((h : ℝ) : ℂ) (τ : ℂ)] at h0
+      have h2 := h0.comp_add_const (τ : ℂ) ((h : ℝ) : ℂ)
+      have hfun : (fun x : ℂ => (rung G j ∘ ofComplex) (x + ((h : ℝ) : ℂ))) = rung G j ∘ ofComplex
+        :=
+        funext hperj
+      rwa [hfun] at h2
+    have h3 := hasDerivAt_rung hG hj' τ
+    have h4 := h1.unique h3
+    rw [hper τ] at h4
+    have := congrArg (fun w => (if j = n then ((n.factorial : ℕ) : ℂ) * g τ else 0) - w) h4
+    simpa using this
+
+end Periodic
+
+theorem isBoundedAtImInfty_rung_zero (hG : IsEichlerIntegral n g G) {h : ℤ} (hh : 0 < h)
+    (hper : Periodic (g ∘ ofComplex) ((h : ℝ) : ℂ)) (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hbdd : IsBoundedAtImInfty g)
+    (hT : ∀ τ : ℍ, G ((h : ℝ) +ᵥ τ) = binaryFormRepSL ℂ n (ModularGroup.T ^ h) (G τ)) :
+    IsBoundedAtImInfty (rung G 0) := by
+  have hh' : (0 : ℝ) < (h : ℝ) := by exact_mod_cast hh
+  have hperℍ : ∀ τ : ℍ, g ((h : ℝ) +ᵥ τ) = g τ := by
+    intro τ
+    have := hper (τ : ℂ)
+    simp only [Function.comp_apply] at this
+    rw [ofComplex_coe_add_real τ h, ofComplex_apply] at this
+    exact this
+  have hrper := rung_vadd hG hperℍ hT
+  have key : ∀ i : ℕ, i ≤ n + 1 → IsBoundedAtImInfty (rung G (n + 1 - i)) := by
+    intro i
+    induction i with
+    | zero =>
+      intro _
+      have : rung G (n + 1 - 0) = 0 := funext fun τ => by simpa using rung_succ_n G τ
+      rw [this]
+      exact UpperHalfPlane.zero_form_isBoundedAtImInfty
+    | succ i ih =>
+      intro hi
+      set j := n + 1 - (i + 1) with hjdef
+      have hj : j ≤ n := by omega
+      have hj1 : n + 1 - i = j + 1 := by omega
+      have ih' : IsBoundedAtImInfty (rung G (j + 1)) := by rw [← hj1]; exact ih (by omega)
+      set u : ℍ → ℂ := fun τ => (if j = n then ((n.factorial : ℕ) : ℂ) * g τ else 0) - rung G (j +
+        1) τ with hu
+      have hu_per : Periodic (u ∘ ofComplex) ((h : ℝ) : ℂ) := by
+        apply periodic_comp_ofComplex
+        intro τ
+        simp only [hu, hperℍ τ, hrper (j + 1) (by omega) τ]
+      have hu_hol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) u := by
+        have h2 : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (rung G (j + 1)) := by
+          rcases eq_or_lt_of_le hj with hjn | hjn
+          · have : rung G (j + 1) = fun _ => 0 := funext fun τ => by rw [hjn]; exact rung_succ_n G τ
+            rw [this]; exact mdifferentiable_const
+          · exact mdifferentiable_rung hG (by omega)
+        have h1 : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fun τ : ℍ => (if j = n then ((n.factorial : ℕ) : ℂ) * g
+          τ else 0)) :=
+          by
+          split_ifs
+          · exact mdifferentiable_const.mul hhol
+          · exact mdifferentiable_const
+        exact h1.sub h2
+      have hu_bdd : IsBoundedAtImInfty u := by
+        have h1 : IsBoundedAtImInfty (fun τ : ℍ => (if j = n then ((n.factorial : ℕ) : ℂ) * g τ else
+          0)) :=
+          by
+          split_ifs
+          · exact hbdd.const_mul_left _
+          · exact UpperHalfPlane.zero_form_isBoundedAtImInfty
+        exact h1.sub ih'
+      have hv : ∀ τ : ℍ, HasDerivAt (rung G j ∘ ofComplex) (u τ) (τ : ℂ) :=
+        fun τ => hasDerivAt_rung hG hj τ
+      have hv_per : Periodic (rung G j ∘ ofComplex) ((h : ℝ) : ℂ) :=
+        periodic_comp_ofComplex (hrper j (by omega))
+      exact UpperHalfPlane.isBoundedAtImInfty_of_hasDerivAt_of_periodic hh' hu_per hu_hol hu_bdd hv
+        hv_per
+  simpa using key (n + 1) le_rfl
+
+end HeckeEis.LadderAux2
+
+end
+
+open scoped MatrixGroups Manifold in
+theorem solution {n : ℕ} {g : UpperHalfPlane → ℂ}
+    {G : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)} (hG : HeckeEis.IsEichlerIntegral n g G)
+    {h : ℤ} (hh : 0 < h)
+    (hper : Function.Periodic (g ∘ UpperHalfPlane.ofComplex) ((h : ℝ) : ℂ))
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g) (hbdd : UpperHalfPlane.IsBoundedAtImInfty g)
+    (hT : ∀ τ : UpperHalfPlane, G ((h : ℝ) +ᵥ τ) = HeckeEis.binaryFormRepSL ℂ n (ModularGroup.T ^ h)
+      (G τ)) :
+    UpperHalfPlane.IsBoundedAtImInfty (fun τ : UpperHalfPlane =>
+      MvPolynomial.eval ![(1 : ℂ), -(τ : ℂ)] ((G τ : ↥(HeckeEis.BinaryForm ℂ n)) : MvPolynomial (Fin
+        2) ℂ)) :=
+  HeckeEis.LadderAux2.isBoundedAtImInfty_rung_zero hG hh hper hhol hbdd hT
+
+end S_HeckeEis_IsEichlerIntegral_isBoundedAtImInfty_eval
+end P2MW
+export P2MW.S_HeckeEis_IsEichlerIntegral_isBoundedAtImInfty_eval (solution)
+
+end privateSection
+
+public section publicSection
+
+open scoped Manifold
+theorem HeckeEis.IsEichlerIntegral.isBoundedAtImInfty_eval {n : ℕ} {g : UpperHalfPlane → ℂ}
+    {G : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)} (hG : HeckeEis.IsEichlerIntegral n g G)
+    {h : ℤ} (hh : 0 < h)
+    (hper : Function.Periodic (g ∘ UpperHalfPlane.ofComplex) ((h : ℝ) : ℂ))
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g) (hbdd : UpperHalfPlane.IsBoundedAtImInfty g)
+    (hT : ∀ τ : UpperHalfPlane, G ((h : ℝ) +ᵥ τ) = HeckeEis.binaryFormRepSL ℂ n (ModularGroup.T ^ h)
+      (G τ)) :
+    UpperHalfPlane.IsBoundedAtImInfty (fun τ : UpperHalfPlane =>
+      MvPolynomial.eval ![(1 : ℂ), -(τ : ℂ)] ((G τ : ↥(HeckeEis.BinaryForm ℂ n)) : MvPolynomial (Fin
+        2) ℂ)) :=
+  solution hG hh hper hhol hbdd hT
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_slash.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_slash.lean
new file mode 100644
index 0000000000..e9cd3452a4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_slash.lean
@@ -0,0 +1,281 @@
+/-
+Based on Prove2Me node HeckeEis.IsEichlerIntegral.slash
+(bacf79e5-40a4-5112-a663-bfd1e4b2124b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 17eca34b-5547-504f-859b-c88af1a957f8
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.SlashActions
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import Mathlib.Analysis.Complex.UpperHalfPlane.Manifold
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Eichler integrals transform under SL₂(ℤ)
+
+Theorem statement: `HeckeEis.IsEichlerIntegral.slash` (`bacf79e5-40a4-5112-a663-bfd1e4b2124b`), by
+Claude, 2026-09-05.
+
+Proof: submission `17eca34b-5547-504f-859b-c88af1a957f8`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $n$, a function $f$ on the upper half-plane with values in $\mathbb C$, and a
+function $F$ from the upper half-plane to the submodule $\mathrm{BinaryForm}\ \mathbb C\ n$ of
+binary forms of degree $n$, i.e. the homogeneous polynomials of degree $n$ in $\mathbb C[X_0,X_1]$.
+Assume [`HeckeEis.IsEichlerIntegral n f F`](def/HeckeEis_EichlerIntegral.html#L105), which says: for
+every multidegree $d \in (\mathrm{Fin}\,2 \to_0 \mathbb N)$ and every $\tau$ in the upper
+half-plane, the function $z \mapsto \mathrm{coeff}_d\,F(\mathrm{ofComplex}\,z)$ on $\mathbb C$ has
+complex derivative $f(\tau)\cdot \mathrm{coeff}_d\bigl((\tau X_0 + X_1)^n\bigr)$ at the point
+$\tau$. Let $\delta \in \mathrm{SL}(2,\mathbb Z)$. The conclusion is that the same predicate holds
+for the pair consisting of the weight-$((n:\mathbb Z)+2)$ slash $f \mid[(n:\mathbb Z)+2]\ \delta$
+and the function $\tau \mapsto \rho_n(\delta^{-1})\,F(\delta \cdot \tau)$, where $\rho_n =$
+[`HeckeEis.binaryFormRepSL ℂ n`](def/HeckeEis_BinaryFormRep.html#L61) is the representation of
+$\mathrm{SL}(2,\mathbb Z)$ on degree-$n$ binary forms by the substitution $X_j \mapsto \sum_i g_{ij}
+X_i$: that is, coefficientwise, $z \mapsto \mathrm{coeff}_d\,\rho_n(\delta^{-1})F(\delta\cdot
+\mathrm{ofComplex}\,z)$ has derivative $(f\mid[(n:\mathbb
+Z)+2]\,\delta)(\tau)\cdot\mathrm{coeff}_d((\tau X_0+X_1)^n)$ at every $\tau$.
+
+This is the compatibility of the Eichler integral construction with the weight-$(n+2)$ slash action:
+twisting an Eichler integral of $f$ by $\rho_n(\delta^{-1})$ and precomposing with $\delta$ produces
+an Eichler integral of $f\mid[(n+2)]\delta$. It is the mechanism behind the cocycle relations used
+for equivariance and behaviour at the cusps in the Eichler–Shimura picture, and is invoked in the
+period computations, in
+[`HeckeEis.isEquivariantPrimitiveWith_of_isEichlerIntegral`]
+(thm.html#HeckeEis.isEquivariantPrimitiveWith_of_isEichlerIntegral)
+and in the injectivity of the Eichler–Shimura map.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_IsEichlerIntegral_slash.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_IsEichlerIntegral_slash
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binaryFormRepSL binaryFormRepSL_apply_coe linePow \
+  jFactor jFactor_eq_denom jFactor_ne_zero binaryFormRepSL_linePow IsEichlerIntegral"
+p2m_open "HeckeEis"
+
+open UpperHalfPlane MvPolynomial ModularForm CongruenceSubgroup
+open scoped MatrixGroups ModularForm
+
+namespace EichlerIntegralAux
+
+section Expansion
+
+variable {K : Type*} [CommRing K] {n : ℕ}
+
+variable (n) in
+def degExps : Finset (Fin 2 →₀ ℕ) :=
+  (Finset.range (n + 1)).image fun k => Finsupp.single 0 k + Finsupp.single 1 (n - k)
+
+variable (n) in
+theorem mem_degExps_iff (d : Fin 2 →₀ ℕ) : d ∈ degExps n ↔ d.degree = n := by
+  rw [Finsupp.degree_eq_sum, Fin.sum_univ_two]
+  simp only [degExps, Finset.mem_image, Finset.mem_range]
+  constructor
+  · rintro ⟨k, hk, rfl⟩
+    simp
+    omega
+  · intro h
+    refine ⟨d 0, by omega, ?_⟩
+    ext i
+    fin_cases i <;> simp ; omega
+
+theorem coeff_eq_zero_of_not_mem_degExps {p : MvPolynomial (Fin 2) K} (hp : p ∈ BinaryForm K n)
+    {d : Fin 2 →₀ ℕ} (hd : d ∉ degExps n) : AddMonoidAlgebra.coeff p d = 0 :=
+  ((mem_homogeneousSubmodule n p).mp hp).coeff_eq_zero (by rwa [mem_degExps_iff] at hd)
+
+theorem eq_sum_degExps {p : MvPolynomial (Fin 2) K} (hp : p ∈ BinaryForm K n) :
+    p = ∑ e ∈ degExps n, monomial e (AddMonoidAlgebra.coeff p e) := by
+  refine MvPolynomial.ext _ _ fun d => ?_
+  rw [coeff_sum]
+  simp only [coeff_monomial]
+  by_cases hd : d ∈ degExps n
+  · rw [Finset.sum_eq_single d (fun e _ hne => ite_eq_right hne) (fun h => (h hd).elim), ite_eq_left
+      rfl]
+  · rw [Finset.sum_eq_zero (fun e he => ite_eq_right (fun h : e = d => hd (h ▸ he))),
+      coeff_eq_zero_of_not_mem_degExps hp hd]
+
+theorem coeff_binaryFormRepSL_eq_sum (g : SL(2, ℤ)) (v : ↥(BinaryForm K n)) (d : Fin 2 →₀ ℕ) :
+    AddMonoidAlgebra.coeff ((binaryFormRepSL K n g v : ↥(BinaryForm K n)) : MvPolynomial (Fin 2) K)
+      d
+      = ∑ e ∈ degExps n, AddMonoidAlgebra.coeff (v : MvPolynomial (Fin 2) K) e
+          * AddMonoidAlgebra.coeff (binarySubst K (g : Matrix (Fin 2) (Fin 2) ℤ) (monomial e 1)) d
+            := by
+  rw [binaryFormRepSL_apply_coe]
+  conv_lhs => rw [eq_sum_degExps v.2, map_sum, coeff_sum]
+  refine Finset.sum_congr rfl fun e _ => ?_
+  rw [show monomial e (AddMonoidAlgebra.coeff (v : MvPolynomial (Fin 2) K) e) =
+    AddMonoidAlgebra.coeff (v : MvPolynomial (Fin 2) K) e • monomial e (1 : K) by
+      rw [smul_monomial, smul_eq_mul, mul_one],
+    map_smul, coeff_smul, smul_eq_mul]
+
+end Expansion
+
+section Calculus
+
+theorem apply_eq_apply_of_hasDerivAt_zero {D : ℂ → ℂ}
+    (hD : ∀ τ : ℍ, HasDerivAt D 0 ↑τ) (z w : ℍ) : D ↑z = D ↑w := by
+  have hmem : ∀ σ : ℍ, (↑σ : ℂ) ∈ {c : ℂ | 0 < c.im} := fun σ => σ.2
+  refine isOpen_upperHalfPlaneSet.is_const_of_fderiv_eq_zero
+    ((convex_halfSpace_im_gt 0).isPreconnected)
+    (fun x hx => ((hD ⟨x, hx⟩).differentiableAt).differentiableWithinAt)
+    (fun x hx => ?_) (hmem z) (hmem w)
+  have h0 := ((hD ⟨x, hx⟩).hasFDerivAt).fderiv
+  rw [Pi.zero_apply, h0]
+  ext1
+  simp
+
+theorem hasDerivAt_smul_ofComplex (γ : SL(2, ℤ)) (τ : ℍ) :
+    HasDerivAt (fun z : ℂ => ((γ • ofComplex z : ℍ) : ℂ))
+      (denom (Matrix.SpecialLinearGroup.mapGL ℝ γ) ↑τ ^ (-2 : ℤ)) ↑τ := by
+  set G : GL (Fin 2) ℝ := Matrix.SpecialLinearGroup.mapGL ℝ γ with hG
+  have hdet : (G : Matrix (Fin 2) (Fin 2) ℝ).det = 1 := by
+    rw [← Matrix.GeneralLinearGroup.val_det_apply, hG, Matrix.SpecialLinearGroup.det_mapGL,
+      Units.val_one]
+  have hpos : (0:ℝ) < (G : Matrix (Fin 2) (Fin 2) ℝ).det := by rw [hdet]; norm_num
+  have h1 := (UpperHalfPlane.hasStrictDerivAt_smul hpos τ).hasDerivAt
+  have h2 : (fun z : ℂ => ((G • ofComplex z : ℍ) : ℂ))
+      = fun z : ℂ => ((γ • ofComplex z : ℍ) : ℂ) := by
+    funext z
+    rw [MulAction.compHom_smul_def]
+  rw [h2] at h1
+  convert h1 using 1
+  rw [hdet]
+  push_cast
+  rw [zpow_neg, one_div]
+  norm_cast
+
+theorem hasDerivAt_comp_smul {G : ℍ → ℂ} {g : ℍ → ℂ}
+    (hG : ∀ τ : ℍ, HasDerivAt (G ∘ ofComplex) (g τ) ↑τ) (γ : SL(2, ℤ)) (τ : ℍ) :
+    HasDerivAt (fun z : ℂ => G (γ • ofComplex z))
+      (g (γ • τ) * denom (Matrix.SpecialLinearGroup.mapGL ℝ γ) ↑τ ^ (-2 : ℤ)) ↑τ := by
+  have hfun : (fun z : ℂ => G (γ • ofComplex z))
+      = (G ∘ ofComplex) ∘ (fun z : ℂ => ((γ • ofComplex z : ℍ) : ℂ)) := by
+    funext z
+    simp only [Function.comp_apply, ofComplex_apply]
+  have houter : HasDerivAt (G ∘ ofComplex) (g (γ • τ))
+      ((fun z : ℂ => ((γ • ofComplex z : ℍ) : ℂ)) ↑τ) := by
+    simpa only [ofComplex_apply] using hG (γ • τ)
+  have hcomp := houter.comp (↑τ : ℂ) (hasDerivAt_smul_ofComplex γ τ)
+  rwa [← hfun] at hcomp
+
+end Calculus
+
+section RepDeriv
+
+variable {n : ℕ}
+
+theorem hasDerivAt_coeff_binaryFormRepSL {H : ℂ → ↥(BinaryForm ℂ n)} {w : ↥(BinaryForm ℂ n)}
+    {z₀ : ℂ}
+    (hH : ∀ e : Fin 2 →₀ ℕ, HasDerivAt (fun z : ℂ => AddMonoidAlgebra.coeff ((H z : ↥(BinaryForm ℂ
+      n)) : MvPolynomial (Fin 2) ℂ) e)
+      (AddMonoidAlgebra.coeff ((w : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) e) z₀)
+    (g : SL(2, ℤ)) (d : Fin 2 →₀ ℕ) :
+    HasDerivAt
+      (fun z : ℂ => AddMonoidAlgebra.coeff ((binaryFormRepSL ℂ n g (H z) : ↥(BinaryForm ℂ n)) :
+        MvPolynomial (Fin 2) ℂ) d)
+      (AddMonoidAlgebra.coeff ((binaryFormRepSL ℂ n g w : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2)
+        ℂ) d) z₀ := by
+  have hfun : (fun z : ℂ => AddMonoidAlgebra.coeff ((binaryFormRepSL ℂ n g (H z) : ↥(BinaryForm ℂ
+    n)) : MvPolynomial (Fin 2) ℂ) d)
+      = fun z : ℂ => ∑ e ∈ degExps n,
+          AddMonoidAlgebra.coeff ((H z : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) e
+            * AddMonoidAlgebra.coeff (binarySubst ℂ (g : Matrix (Fin 2) (Fin 2) ℤ) (monomial e 1)) d
+              :=
+    funext fun z => coeff_binaryFormRepSL_eq_sum g (H z) d
+  rw [hfun, coeff_binaryFormRepSL_eq_sum g w d]
+  exact HasDerivAt.fun_sum fun e _ =>
+    (hH e).mul_const (AddMonoidAlgebra.coeff (binarySubst ℂ (g : Matrix (Fin 2) (Fin 2) ℤ) (monomial
+      e 1)) d)
+
+end RepDeriv
+
+end EichlerIntegralAux
+
+open EichlerIntegralAux in
+theorem SolMain.slash {n : ℕ} {f : ℍ → ℂ} {F : ℍ → ↥(BinaryForm ℂ n)}
+    (hF : IsEichlerIntegral n f F) (δ : SL(2, ℤ)) :
+    IsEichlerIntegral n (f ∣[((n : ℤ) + 2)] δ) (fun τ => binaryFormRepSL ℂ n δ⁻¹ (F (δ • τ))) := by
+  intro d τ
+  set c : ℂ := f (δ • τ) * denom (Matrix.SpecialLinearGroup.mapGL ℝ δ) ↑τ ^ (-2 : ℤ) with hc
+  have hH : ∀ e : Fin 2 →₀ ℕ, HasDerivAt
+      (fun z : ℂ => AddMonoidAlgebra.coeff ((F (δ • ofComplex z) : ↥(BinaryForm ℂ n)) : MvPolynomial
+        (Fin 2) ℂ) e)
+      (AddMonoidAlgebra.coeff (((c • linePow n ((δ • τ : ℍ) : ℂ)) : ↥(BinaryForm ℂ n)) :
+        MvPolynomial (Fin 2) ℂ) e) ↑τ := by
+    intro e
+    have h1 := hasDerivAt_comp_smul
+      (G := fun w : ℍ => AddMonoidAlgebra.coeff ((F w : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ)
+        e)
+      (g := fun w : ℍ => f w * AddMonoidAlgebra.coeff ((linePow n (w : ℂ) : ↥(BinaryForm ℂ n)) :
+        MvPolynomial (Fin 2) ℂ) e)
+      (fun w => hF e w) δ τ
+    refine h1.congr_deriv ?_
+    rw [Submodule.coe_smul, coeff_smul, smul_eq_mul, hc]
+    ring
+  have h2 := hasDerivAt_coeff_binaryFormRepSL hH δ⁻¹ d
+  refine h2.congr_deriv ?_
+  have hJ : denom (Matrix.SpecialLinearGroup.mapGL ℝ δ) (τ : ℂ) ≠ 0 := denom_ne_zero _ _
+  have hinv : binaryFormRepSL ℂ n δ⁻¹ (linePow n ((δ • τ : ℍ) : ℂ))
+      = (jFactor δ τ ^ n)⁻¹ • linePow n (τ : ℂ) := by
+    have h := congrArg (binaryFormRepSL ℂ n δ⁻¹) (binaryFormRepSL_linePow n δ τ)
+    rw [← Module.End.mul_apply, ← map_mul, inv_mul_cancel, map_one, Module.End.one_apply,
+      map_smul] at h
+    rw [h, smul_smul, inv_mul_cancel₀ (pow_ne_zero _ (jFactor_ne_zero δ τ)), one_smul]
+  have hslash : (f ∣[((n : ℤ) + 2)] δ) τ
+      = f (δ • τ) * denom (Matrix.SpecialLinearGroup.mapGL ℝ δ) (τ : ℂ) ^ (-((n : ℤ) + 2)) :=
+    SL_slash_apply _ _ _
+  rw [map_smul, hinv, smul_smul, Submodule.coe_smul, coeff_smul, smul_eq_mul, hslash,
+    jFactor_eq_denom, hc]
+  congr 1
+  rw [← zpow_natCast, ← zpow_neg, mul_assoc, ← zpow_add₀ hJ]
+  congr 2
+  ring
+
+end HeckeEis
+
+end
+
+open scoped MatrixGroups ModularForm in
+theorem solution {n : ℕ} {f : UpperHalfPlane → ℂ} {F : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)}
+    (hF : HeckeEis.IsEichlerIntegral n f F) (δ : SL(2, ℤ)) :
+    HeckeEis.IsEichlerIntegral n (f ∣[((n : ℤ) + 2)] δ) (fun τ => HeckeEis.binaryFormRepSL ℂ n δ⁻¹
+      (F (δ • τ))) :=
+  HeckeEis.SolMain.slash hF δ
+
+end S_HeckeEis_IsEichlerIntegral_slash
+end P2MW
+export P2MW.S_HeckeEis_IsEichlerIntegral_slash (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups ModularForm
+theorem HeckeEis.IsEichlerIntegral.slash {n : ℕ} {f : UpperHalfPlane → ℂ}
+    {F : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)}
+    (hF : HeckeEis.IsEichlerIntegral n f F) (δ : SL(2, ℤ)) :
+    HeckeEis.IsEichlerIntegral n (f ∣[((n : ℤ) + 2)] δ) (fun τ => HeckeEis.binaryFormRepSL ℂ n δ⁻¹
+      (F (δ • τ))) :=
+  solution hF δ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_smul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_smul.lean
new file mode 100644
index 0000000000..0711a89699
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_smul.lean
@@ -0,0 +1,76 @@
+/-
+Based on Prove2Me node HeckeEis.IsEichlerIntegral.smul
+(e54577d3-520a-5111-8302-693dd938b73e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1997260b-bede-50d9-8b6e-c7c1edb15fe5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import Mathlib.Analysis.Calculus.Deriv.Mul
+
+/-!
+# Eichler integrals scale: cF is an Eichler integral of cf
+
+Theorem statement: `HeckeEis.IsEichlerIntegral.smul` (`e54577d3-520a-5111-8302-693dd938b73e`), by
+Claude, 2026-09-05.
+
+Proof: submission `1997260b-bede-50d9-8b6e-c7c1edb15fe5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $n$ be a natural number, let $f:\mathfrak H\to\mathbb C$ be a function on the upper half-plane,
+and let $F$ be a function from $\mathfrak H$ to the submodule $\mathrm{BinaryForm}\ \mathbb C\ n$ of
+$\mathbb C[X_0,X_1]$ consisting of the homogeneous polynomials of degree $n$ in two variables.
+Assume $F$ is an Eichler integral of $f$ in the sense of
+[`HeckeEis.IsEichlerIntegral`](def/HeckeEis_EichlerIntegral.html#L105): for every multi-index
+$d\in(\mathrm{Fin}\,2\to_0\mathbb N)$ and every $\tau\in\mathfrak H$, the complex function $z\mapsto
+\mathrm{coeff}_d\bigl(F(\mathrm{ofComplex}\,z)\bigr)$ is differentiable at the point $\tau\in\mathbb
+C$ with derivative $f(\tau)\cdot \mathrm{coeff}_d\bigl((\tau X_0+X_1)^n\bigr)$, where $(\tau
+X_0+X_1)^n$ is [`HeckeEis.linePow n τ`](def/HeckeEis_EichlerIntegral.html#L22) and `ofComplex` is
+the retraction of $\mathbb C$ onto $\mathfrak H$. Then for every scalar $c\in\mathbb C$ the
+pointwise multiple $c\cdot F$ is an Eichler integral of $c\cdot f$ in the same sense, i.e. the
+relation $d(cF)=(cf)(\tau)(\tau X_0+X_1)^n\,d\tau$ holds coefficientwise in the above derivative
+form.
+
+This is the homogeneity half of the linearity of the Eichler integral relation, recorded
+coefficientwise for polynomial-valued primitives. It is used for the scalar-homogeneity of the
+Eichler–Shimura map, [`HeckeEis.eichlerShimuraMap_smul`](thm.html#HeckeEis.eichlerShimuraMap_smul).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_IsEichlerIntegral_smul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open UpperHalfPlane MvPolynomial CongruenceSubgroup
+
+theorem solution {n : ℕ} {f : UpperHalfPlane → ℂ} {F : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)}
+    (hF : HeckeEis.IsEichlerIntegral n f F) (c : ℂ) :
+    HeckeEis.IsEichlerIntegral n (c • f) (c • F) := by
+  intro d τ
+  have h := (hF d τ).const_mul c
+  rw [← mul_assoc] at h
+  refine h.congr_of_eventuallyEq (Filter.Eventually.of_forall fun z => ?_)
+  simp only [Pi.smul_apply, Submodule.coe_smul, coeff_smul, smul_eq_mul]
+
+end privateSection
+
+public section publicSection
+
+open scoped MatrixGroups
+theorem HeckeEis.IsEichlerIntegral.smul {n : ℕ} {f : UpperHalfPlane → ℂ}
+    {F : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)}
+    (hF : HeckeEis.IsEichlerIntegral n f F) (c : ℂ) :
+    HeckeEis.IsEichlerIntegral n (c • f) (c • F) := _root_.solution hF c
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_vadd_sub_T_zpow_apply_mem_range.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_vadd_sub_T_zpow_apply_mem_range.lean
new file mode 100644
index 0000000000..b2303a977a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEichlerIntegral_vadd_sub_T_zpow_apply_mem_range.lean
@@ -0,0 +1,177 @@
+/-
+Based on Prove2Me node HeckeEis.IsEichlerIntegral.vadd_sub_T_zpow_apply_mem_range
+(c06c9099-8cfb-5ca1-83ab-9dffa3cf0345) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4e512fb3-ad49-5597-a7ce-07d88c6caa5d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.Complex.UpperHalfPlane.FunctionsBoundedAtInfty
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Manifold
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_coeff_single_one_eq_eval_of_mem_binaryForm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_mem_range_binaryFormRepSL_T_zpow_sub_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_apply_add_eq_apply_of_hasDerivAt_of_isZeroAtImInfty
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Parabolic condition for Eichler integrals at ∞
+
+Theorem statement: `HeckeEis.IsEichlerIntegral.vadd_sub_T_zpow_apply_mem_range`
+(`c06c9099-8cfb-5ca1-83ab-9dffa3cf0345`), by Claude, 2026-09-05.
+
+Proof: submission `4e512fb3-ad49-5597-a7ce-07d88c6caa5d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $n \in \mathbb{N}$ and a non-zero integer $h$, and let $\rho_n =$ [`HeckeEis.binaryFormRepSL ℂ
+n`](def/HeckeEis_BinaryFormRep.html#L61) be the representation of $\mathrm{SL}_2(\mathbb{Z})$ on the
+submodule $\mathrm{BinaryForm}\,\mathbb{C}\,n$ of degree-$n$ homogeneous elements of
+$\mathbb{C}[X_0,X_1]$ given by the linear substitution $X_j \mapsto \sum_i M_{ij} X_i$ attached to
+the integral matrix $M$ of the group element. Let $g : \mathfrak{H} \to \mathbb{C}$ and $G :
+\mathfrak{H} \to \mathrm{BinaryForm}\,\mathbb{C}\,n$ be functions on the upper half plane such that:
+(i) [`HeckeEis.IsEichlerIntegral n g G`](def/HeckeEis_EichlerIntegral.html#L105) holds, i.e. for
+every multidegree $d$ and every $\tau \in \mathfrak{H}$ the function $z \mapsto
+\mathrm{coeff}_d\,G(z)$ (with $G$ extended to $\mathbb{C}$ through `UpperHalfPlane.ofComplex`) has
+derivative $g(\tau)\,\mathrm{coeff}_d\bigl((\tau X_0 + X_1)^n\bigr)$ at $\tau$; (ii) $g \circ$
+`ofComplex` is periodic with period $h$ (viewed as a complex number); (iii) $g$ is holomorphic, in
+the sense of being differentiable for the complex manifold structures on $\mathfrak{H}$ and
+$\mathbb{C}$; and (iv) $g$ is zero at $i\infty$. Then for every $\tau \in \mathfrak{H}$,
+$$G(h + \tau) - \rho_n(T^h)\,G(\tau) \in \operatorname{range}\bigl(\rho_n(T^h) - 1\bigr),$$
+where $T$ is the standard parabolic generator $\begin{pmatrix}1&1\\0&1\end{pmatrix}$ and $h + \tau$
+denotes the translation action of the real number $h$ on $\mathfrak{H}$.
+
+This is the parabolic (cusp at $\infty$) condition satisfied by the Eichler–Shimura cocycle attached
+to an Eichler integral of a cusp form, stated here for an arbitrary non-zero translation length $h$
+and without reference to any congruence subgroup. It feeds into
+[`HeckeEis.isParabolicCocycle_cocycle_of_isEichlerIntegral`]
+(thm.html#HeckeEis.isParabolicCocycle_cocycle_of_isEichlerIntegral),
+where the cocycle built from $G$ is shown to be parabolic.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_IsEichlerIntegral_vadd_sub_T_zpow_apply_mem_range.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_IsEichlerIntegral_vadd_sub_T_zpow_apply_mem_range
+
+open scoped Manifold MatrixGroups
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binaryFormRepSL binaryFormRepSL_apply_coe linePow \
+  coe_linePow IsEichlerIntegral coeff_single_one_eq_eval_of_mem_binaryForm \
+  mem_range_binaryFormRepSL_T_zpow_sub_one"
+namespace CuspInftySol
+p2m_open "HeckeEis"
+
+p2m_open "UpperHalfPlane MvPolynomial HeckeEis \
+  P2MW.S_HeckeEis_IsEichlerIntegral_vadd_sub_T_zpow_apply_mem_range.HeckeEis"
+open scoped Manifold MatrixGroups
+
+theorem eval_binarySubst_T_zpow (h : ℤ) (P : MvPolynomial (Fin 2) ℂ) :
+    MvPolynomial.eval ![0, 1] (binarySubst ℂ ((ModularGroup.T ^ h : SL(2, ℤ)) : Matrix (Fin 2) (Fin
+      2) ℤ) P)
+      = MvPolynomial.eval ![0, 1] P := by
+  have key : (fun j : Fin 2 => MvPolynomial.eval₂Hom (RingHom.id ℂ) (![0, 1] : Fin 2 → ℂ)
+      (∑ i : Fin 2, C ((((ModularGroup.T ^ h : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) i j : ℤ) : ℂ) *
+        X i))
+      = (![0, 1] : Fin 2 → ℂ) := by
+    funext j
+    fin_cases j <;> simp [ModularGroup.coe_T_zpow, Fin.sum_univ_two]
+  rw [binarySubst, MvPolynomial.aeval_eq_bind₁, MvPolynomial.eval, MvPolynomial.eval₂Hom_bind₁, key]
+
+theorem coeff_single_one_binaryFormRepSL_T_zpow (n : ℕ) (h : ℤ) (P : ↥(BinaryForm ℂ n)) :
+    AddMonoidAlgebra.coeff ((binaryFormRepSL ℂ n (ModularGroup.T ^ h) P : ↥(BinaryForm ℂ n)) :
+      MvPolynomial (Fin 2) ℂ) (Finsupp.single 1 n)
+      = AddMonoidAlgebra.coeff (P : MvPolynomial (Fin 2) ℂ) (Finsupp.single 1 n) := by
+  rw [coeff_single_one_eq_eval_of_mem_binaryForm (binaryFormRepSL ℂ n _ P).2,
+    coeff_single_one_eq_eval_of_mem_binaryForm P.2, binaryFormRepSL_apply_coe,
+    eval_binarySubst_T_zpow]
+
+theorem coeff_single_one_linePow (n : ℕ) (z : ℂ) :
+    AddMonoidAlgebra.coeff ((linePow n z : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ)
+      (Finsupp.single 1 n) = 1 := by
+  rw [coeff_single_one_eq_eval_of_mem_binaryForm (linePow n z).2, coe_linePow]
+  simp
+
+end HeckeEis.CuspInftySol
+
+open _root_.HeckeEis
+  _root_.P2MW.S_HeckeEis_IsEichlerIntegral_vadd_sub_T_zpow_apply_mem_range.HeckeEis
+  HeckeEis.CuspInftySol UpperHalfPlane MvPolynomial in
+theorem solution {n : ℕ} {h : ℤ} (hh : h ≠ 0)
+    {g : UpperHalfPlane → ℂ} {G : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)}
+    (hG : HeckeEis.IsEichlerIntegral n g G)
+    (hper : Function.Periodic (g ∘ UpperHalfPlane.ofComplex) ((h : ℝ) : ℂ))
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g) (hzero : UpperHalfPlane.IsZeroAtImInfty g)
+    (τ : UpperHalfPlane) :
+    G ((h : ℝ) +ᵥ τ) - HeckeEis.binaryFormRepSL ℂ n (ModularGroup.T ^ h) (G τ)
+      ∈ LinearMap.range (HeckeEis.binaryFormRepSL ℂ n (ModularGroup.T ^ h) - 1) := by
+  apply mem_range_binaryFormRepSL_T_zpow_sub_one n hh
+  rw [Submodule.coe_sub, coeff_sub, coeff_single_one_binaryFormRepSL_T_zpow, sub_eq_zero]
+  set φ : ℂ → ℂ := fun z =>
+    AddMonoidAlgebra.coeff ((G (ofComplex z) : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ)
+      (Finsupp.single 1 n) with hφdef
+  have hφ : ∀ σ : ℍ, HasDerivAt φ (g σ) ↑σ := fun σ => by
+    have := hG (Finsupp.single 1 n) σ
+    rw [coeff_single_one_linePow, mul_one] at this
+    exact this
+  suffices hs : φ ((((h : ℝ) +ᵥ τ : ℍ) : ℂ)) = φ (τ : ℂ) by
+    simpa only [hφdef, ofComplex_apply] using hs
+  rw [coe_vadd, add_comm]
+  rcases lt_or_gt_of_ne hh with hneg | hpos
+  · have hper' : Function.Periodic (g ∘ ofComplex) (((-h : ℤ) : ℝ) : ℂ) := by
+      push_cast
+      exact hper.neg
+    have key :=
+      UpperHalfPlane.apply_add_eq_apply_of_hasDerivAt_of_isZeroAtImInfty (h := ((-h : ℤ) : ℝ))
+      (by exact_mod_cast (neg_pos.mpr hneg)) hper' hhol hzero hφ ((h : ℝ) +ᵥ τ)
+    rw [coe_vadd] at key
+    push_cast at key ⊢
+    have e : (h : ℂ) + (τ : ℂ) + -(h : ℂ) = (τ : ℂ) := by ring
+    rw [e] at key
+    rw [add_comm]
+    exact key.symm
+  · have key :=
+      UpperHalfPlane.apply_add_eq_apply_of_hasDerivAt_of_isZeroAtImInfty (h := ((h : ℤ) : ℝ))
+      (by exact_mod_cast hpos) hper hhol hzero hφ τ
+    push_cast at key ⊢
+    exact key
+
+end
+
+end S_HeckeEis_IsEichlerIntegral_vadd_sub_T_zpow_apply_mem_range
+end P2MW
+export P2MW.S_HeckeEis_IsEichlerIntegral_vadd_sub_T_zpow_apply_mem_range (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Manifold MatrixGroups
+theorem HeckeEis.IsEichlerIntegral.vadd_sub_T_zpow_apply_mem_range {n : ℕ} {h : ℤ} (hh : h ≠ 0)
+    {g : UpperHalfPlane → ℂ} {G : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)}
+    (hG : HeckeEis.IsEichlerIntegral n g G)
+    (hper : Function.Periodic (g ∘ UpperHalfPlane.ofComplex) ((h : ℝ) : ℂ))
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g) (hzero : UpperHalfPlane.IsZeroAtImInfty g)
+    (τ : UpperHalfPlane) :
+    G ((h : ℝ) +ᵥ τ) - HeckeEis.binaryFormRepSL ℂ n (ModularGroup.T ^ h) (G τ)
+      ∈ LinearMap.range (HeckeEis.binaryFormRepSL ℂ n (ModularGroup.T ^ h) - 1) :=
+  solution hh hG hper hhol hzero τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEquivariantPrimitiveWith_cocycle_sub_cocycle_mem_coeffCoboundaries.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEquivariantPrimitiveWith_cocycle_sub_cocycle_mem_coeffCoboundaries.lean
new file mode 100644
index 0000000000..f671839701
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_IsEquivariantPrimitiveWith_cocycle_sub_cocycle_mem_coeffCoboundaries.lean
@@ -0,0 +1,82 @@
+/-
+Based on Prove2Me node HeckeEis.IsEquivariantPrimitiveWith.cocycle_sub_cocycle_mem_coeffCoboundaries
+(64d2c2a5-369d-5e77-a6c0-6474236248c2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b1164faf-7cb9-5165-a40e-c88725ea7200
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+/-!
+# Equivariant primitives differing by a constant: cohomologous cocycles
+
+Theorem statement: `HeckeEis.IsEquivariantPrimitiveWith.cocycle_sub_cocycle_mem_coeffCoboundaries`
+(`64d2c2a5-369d-5e77-a6c0-6474236248c2`), by Claude, 2026-09-05.
+
+Proof: submission `b1164faf-7cb9-5165-a40e-c88725ea7200`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a commutative ring, $\Gamma$ a subgroup of $\mathrm{SL}_2(\mathbb{Z})$, and $V$ a
+$K$-module carrying a representation $\rho$ of $\Gamma$. Let $F, G \colon \mathfrak{H} \to V$ be
+functions on the upper half-plane, each of which is an equivariant primitive for $\rho$ in the sense
+of [`HeckeEis.IsEquivariantPrimitiveWith`](def/HeckeEis_EichlerIntegral.html#L68): for every $\gamma
+\in \Gamma$ there exists $c \in V$ with $F(\gamma \tau) - \rho(\gamma) F(\tau) = c$ for all $\tau
+\in \mathfrak{H}$, and likewise for $G$. Assume further that there is $v \in V$ with $F(\tau) -
+G(\tau) = v$ for all $\tau$, i.e. $F$ and $G$ differ by the constant $v$. The associated cocycles
+are the functions $\Gamma \to V$ given by $\gamma \mapsto F(\gamma \cdot i) - \rho(\gamma) F(i)$ and
+$\gamma \mapsto G(\gamma \cdot i) - \rho(\gamma) G(i)$, evaluated at the point $i$ of
+$\mathfrak{H}$. The conclusion is that their difference lies in
+[`HeckeEis.coeffCoboundaries`](def/Gamma0CoeffCohomology.html#L45) $\rho$, the image of the
+$K$-linear map $V \to (\Gamma \to V)$ sending $w$ to $\gamma \mapsto \rho(\gamma) w - w$;
+concretely, the difference is the coboundary attached to $-v$. The proof uses the equivariance
+hypotheses only as the arguments needed to form the two cocycles, not their content.
+
+This is the standard independence statement for the cocycle attached to an Eichler integral:
+changing the primitive by a constant changes its cocycle by a coboundary, so the class in
+coefficient cohomology is well defined. It is used in the identification of the Eichler–Shimura map
+with the class map into parabolic cohomology and in the Hecke-equivariance statements for that map.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_IsEquivariantPrimitiveWith_cocycle_sub_cocycle_mem_coeffCoboundaries.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open UpperHalfPlane HeckeEis
+open scoped MatrixGroups
+
+theorem solution
+    {K : Type*} [CommRing K] {Γ : Subgroup SL(2, ℤ)} {V : Type*} [AddCommGroup V] [Module K V]
+    {ρ : Representation K Γ V} {F G : UpperHalfPlane → V}
+    (hF : HeckeEis.IsEquivariantPrimitiveWith ρ F) (hG : HeckeEis.IsEquivariantPrimitiveWith ρ G)
+    {v : V} (h : ∀ τ : UpperHalfPlane, F τ - G τ = v) :
+    hF.cocycle - hG.cocycle ∈ HeckeEis.coeffCoboundaries ρ := by
+  rw [mem_coeffCoboundaries_iff]
+  refine ⟨-v, funext fun γ => ?_⟩
+  change ρ γ (-v) - -v = (F ((γ : SL(2, ℤ)) • I) - ρ γ (F I)) - (G ((γ : SL(2, ℤ)) • I) - ρ γ (G I))
+  rw [map_neg, sub_eq_iff_eq_add.mp (h ((γ : SL(2, ℤ)) • I)), sub_eq_iff_eq_add.mp (h I), map_add]
+  abel
+
+end privateSection
+
+public section publicSection
+
+open scoped MatrixGroups
+theorem HeckeEis.IsEquivariantPrimitiveWith.cocycle_sub_cocycle_mem_coeffCoboundaries
+    {K : Type*} [CommRing K] {Γ : Subgroup SL(2, ℤ)} {V : Type*} [AddCommGroup V] [Module K V]
+    {ρ : Representation K Γ V} {F G : UpperHalfPlane → V}
+    (hF : HeckeEis.IsEquivariantPrimitiveWith ρ F) (hG : HeckeEis.IsEquivariantPrimitiveWith ρ G)
+    {v : V} (h : ∀ τ : UpperHalfPlane, F τ - G τ = v) :
+    hF.cocycle - hG.cocycle ∈ HeckeEis.coeffCoboundaries ρ := _root_.solution hF hG h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_binaryFormAlphaAdj_comp_binaryFormRepSL_heckeConj.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_binaryFormAlphaAdj_comp_binaryFormRepSL_heckeConj.lean
new file mode 100644
index 0000000000..21f8e52740
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_binaryFormAlphaAdj_comp_binaryFormRepSL_heckeConj.lean
@@ -0,0 +1,127 @@
+/-
+Based on Prove2Me node HeckeEis.binaryFormAlphaAdj_comp_binaryFormRepSL_heckeConj
+(b6bda1d4-8f2d-5ef9-956e-c4fa45302310) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a1f2509f-1d70-5f33-be78-8e47a990f76a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0HeckeOperatorHom
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Hecke conjugation commutes with diag(ℓ,1) on binary forms
+
+Theorem statement: `HeckeEis.binaryFormAlphaAdj_comp_binaryFormRepSL_heckeConj`
+(`b6bda1d4-8f2d-5ef9-956e-c4fa45302310`), by Claude, 2026-09-05.
+
+Proof: submission `a1f2509f-1d70-5f33-be78-8e47a990f76a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a commutative ring $K$ and natural numbers $n$, $N$, $\ell$ with $\ell\neq 0$. Write
+$\mathrm{BinaryForm}\,K\,n$ for the $K$-submodule of degree-$n$ homogeneous polynomials in
+$K[X_0,X_1]$, and for an integral $2\times 2$ matrix $M$ let $\mathrm{binarySubst}\,K\,M$ be the
+$K$-algebra endomorphism of $K[X_0,X_1]$ determined by $X_j\mapsto\sum_i (M_{ij}\bmod K)\,X_i$; this
+preserves $\mathrm{BinaryForm}\,K\,n$, and [`HeckeEis.binaryFormRepSL K
+n`](def/HeckeEis_BinaryFormRep.html#L61) is the resulting representation of $\mathrm{SL}_2(\mathbb
+Z)$ on it, while [`HeckeEis.binaryFormAlphaAdj K n ℓ`](def/HeckeEis_BinaryFormRep.html#L82) is the
+endomorphism induced by $\begin{pmatrix}\ell&0\\0&1\end{pmatrix}$, i.e. $P(X_0,X_1)\mapsto P(\ell
+X_0,X_1)$. Let $u$ lie in [`HeckeEis.heckeUpper N ℓ`](def/Gamma0HeckeOperatorHom.html#L128), the
+subgroup of those $\gamma\in\Gamma_0(N)$ whose upper-right entry is divisible by $\ell$, and let
+$\mathrm{heckeConj}\,N\,\ell\,(u)\in\Gamma_0(N)$ be the element obtained from
+$u=\begin{pmatrix}a&b\\c&d\end{pmatrix}$ by the entrywise recipe $\begin{pmatrix}a&b/\ell\\ \ell
+c&d\end{pmatrix}$. The assertion is the equality of $K$-linear endomorphisms of
+$\mathrm{BinaryForm}\,K\,n$: the representation of $\mathrm{heckeConj}\,N\,\ell\,(u)$ followed by
+`binaryFormAlphaAdj K n ℓ` equals `binaryFormAlphaAdj K n ℓ` followed by the representation of $u$,
+where the representation of $\Gamma_0(N)$ is the restriction of `binaryFormRepSL K n` along the
+inclusion $\Gamma_0(N)\hookrightarrow\mathrm{SL}_2(\mathbb Z)$.
+
+This is the coefficient-module compatibility condition for the degree-$n$ binary-form coefficients
+under conjugation by $\mathrm{diag}(1,\ell)$, the matrix part of the Hecke operator $T_\ell$ on
+$\Gamma_0(N)$. It is what makes the cochain-level Hecke operator with binary-form coefficients
+preserve cocycles and coboundaries, and it is cited in the proofs of the Hecke equivariance of the
+Eichler–Shimura map and of the existence of an integral structure on spaces of cusp forms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_binaryFormAlphaAdj_comp_binaryFormRepSL_heckeConj.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_binaryFormAlphaAdj_comp_binaryFormRepSL_heckeConj
+
+namespace HeckeEis
+p2m_export "HeckeEis" "heckeConjMat heckeUpper mem_heckeUpper heckeConjSL coe_heckeConjSL \
+  heckeConj binarySubst binarySubst_mul binaryFormRepSL binaryFormAlphaAdj"
+p2m_open "HeckeEis"
+
+open CongruenceSubgroup
+open scoped MatrixGroups
+
+theorem alphaAdjMat_mul_heckeConjMat {ℓ : ℕ} {g : Matrix (Fin 2) (Fin 2) ℤ} (hg : (ℓ : ℤ) ∣ g 0 1) :
+    !![(ℓ : ℤ), 0; 0, 1] * heckeConjMat ℓ g = g * !![(ℓ : ℤ), 0; 0, 1] := by
+  ext i j
+  fin_cases i <;> fin_cases j <;>
+    simp [Matrix.mul_apply, Fin.sum_univ_two, heckeConjMat, Int.mul_ediv_cancel' hg, mul_comm]
+
+theorem SolMain.A1 (K : Type*) [CommRing K] (n N ℓ : ℕ) [NeZero ℓ]
+    (u : ↥(heckeUpper N ℓ)) :
+    binaryFormAlphaAdj K n ℓ ∘ₗ ((binaryFormRepSL K n).comp (Gamma0 N).subtype) (heckeConj N ℓ u)
+      = ((binaryFormRepSL K n).comp (Gamma0 N).subtype) (u : Gamma0 N) ∘ₗ binaryFormAlphaAdj K n ℓ
+        := by
+  refine LinearMap.ext fun v => Subtype.ext ?_
+  change binarySubst K !![(ℓ : ℤ), 0; 0, 1]
+      (binarySubst K ((heckeConjSL N ℓ u : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) (v : MvPolynomial
+        (Fin 2) K))
+    = binarySubst K ((((u : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ))
+      (binarySubst K !![(ℓ : ℤ), 0; 0, 1] (v : MvPolynomial (Fin 2) K))
+  rw [← AlgHom.comp_apply, ← binarySubst_mul, ← AlgHom.comp_apply, ← binarySubst_mul,
+    coe_heckeConjSL,
+    alphaAdjMat_mul_heckeConjMat ((mem_heckeUpper N ℓ).mp u.2)]
+
+end HeckeEis
+
+open scoped MatrixGroups in
+theorem solution (K : Type*) [CommRing K] (n N ℓ : ℕ) [NeZero ℓ]
+    (u : ↥(HeckeEis.heckeUpper N ℓ)) :
+    HeckeEis.binaryFormAlphaAdj K n ℓ ∘ₗ ((HeckeEis.binaryFormRepSL K n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype) (HeckeEis.heckeConj N ℓ u)
+      = ((HeckeEis.binaryFormRepSL K n).comp (CongruenceSubgroup.Gamma0 N).subtype) (u :
+        CongruenceSubgroup.Gamma0 N)
+          ∘ₗ HeckeEis.binaryFormAlphaAdj K n ℓ :=
+  HeckeEis.SolMain.A1 K n N ℓ u
+
+end S_HeckeEis_binaryFormAlphaAdj_comp_binaryFormRepSL_heckeConj
+end P2MW
+export P2MW.S_HeckeEis_binaryFormAlphaAdj_comp_binaryFormRepSL_heckeConj (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.binaryFormAlphaAdj_comp_binaryFormRepSL_heckeConj (K : Type*) [CommRing K]
+    (n N ℓ : ℕ) [NeZero ℓ]
+    (u : ↥(HeckeEis.heckeUpper N ℓ)) :
+    HeckeEis.binaryFormAlphaAdj K n ℓ ∘ₗ ((HeckeEis.binaryFormRepSL K n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype) (HeckeEis.heckeConj N ℓ u)
+      = ((HeckeEis.binaryFormRepSL K n).comp (CongruenceSubgroup.Gamma0 N).subtype) (u :
+        CongruenceSubgroup.Gamma0 N)
+          ∘ₗ HeckeEis.binaryFormAlphaAdj K n ℓ :=
+  solution K n N ℓ u
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_binaryFormRepSL_neg_one_apply.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_binaryFormRepSL_neg_one_apply.lean
new file mode 100644
index 0000000000..b587f7e5a5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_binaryFormRepSL_neg_one_apply.lean
@@ -0,0 +1,105 @@
+/-
+Based on Prove2Me node HeckeEis.binaryFormRepSL_neg_one_apply
+(72e9a994-ff75-507c-834e-84b42c3f4cff) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e2a99039-0324-5151-88d4-1a6798bfbb8a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The central element -1 of SL₂(ℤ) acts by (-1)ⁿ
+
+Theorem statement: `HeckeEis.binaryFormRepSL_neg_one_apply`
+(`72e9a994-ff75-507c-834e-84b42c3f4cff`), by Claude, 2026-09-05.
+
+Proof: submission `e2a99039-0324-5151-88d4-1a6798bfbb8a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a commutative ring and $n$ a natural number, and let $\mathrm{BinaryForm}\ K\ n$ denote
+the $K$-submodule of $\mathrm{MvPolynomial}\ (\mathrm{Fin}\ 2)\ K$ consisting of the polynomials
+homogeneous of degree $n$ in two variables. On this submodule [`HeckeEis.binaryFormRepSL K
+n`](def/HeckeEis_BinaryFormRep.html#L61) is the representation of $SL_2(\mathbb{Z})$ obtained by
+restricting the substitution algebra maps
+[`HeckeEis.binarySubst`](def/HeckeEis_BinaryFormRep.html#L28): an integral matrix $M$ acts on
+polynomials by the $K$-algebra homomorphism sending the variable $X_j$ to
+$\sum_{i\in\mathrm{Fin}\,2} (M_{ij} \bmod K)\, X_i$, where the integer entries are mapped into $K$
+along the canonical ring map, and this substitution preserves degree-$n$ homogeneity. The assertion
+is that for every element $P$ of $\mathrm{BinaryForm}\ K\ n$, the action of the group element $-1$
+of $SL(2,\mathbb{Z})$ (the negative of the identity matrix) on $P$ is the scalar multiple $((-1 :
+K)^n)\cdot P$, the equality being one of elements of the submodule. No hypothesis on $K$ beyond
+commutativity is imposed, so the statement also covers rings in which $-1 = 1$.
+
+This records that the central element $-1$ acts on binary forms of degree $n$ — the symmetric power
+$\mathrm{Sym}^n$ of the standard representation — through the sign $(-1)^n$. It is used to remove
+the ambiguous sign in the classification of parabolic elements of $SL_2(\mathbb{Z})$ up to conjugacy
+and, in particular, to show that the relevant cohomology contributions vanish for odd $n$; seven
+later results in the Hecke–Eisenstein development cite it.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_binaryFormRepSL_neg_one_apply.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_binaryFormRepSL_neg_one_apply
+
+open scoped MatrixGroups
+
+open HeckeEis MvPolynomial in
+theorem solution (K : Type*) [CommRing K] (n : ℕ) (P : ↥(HeckeEis.BinaryForm K n)) :
+    HeckeEis.binaryFormRepSL K n (-1) P = ((-1 : K) ^ n) • P := by
+  classical
+  apply Subtype.ext
+  rw [binaryFormRepSL_apply_coe, Submodule.coe_smul]
+  have hhom : (P : MvPolynomial (Fin 2) K).IsHomogeneous n := (mem_homogeneousSubmodule n _).mp P.2
+  have h0 : binarySubst K ((-1 : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) (X 0) = -X 0 := by
+    rw [binarySubst_X]; simp [Matrix.one_apply]
+  have h1 : binarySubst K ((-1 : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) (X 1) = -X 1 := by
+    rw [binarySubst_X]; simp [Matrix.one_apply]
+  conv_lhs => rw [(P : MvPolynomial (Fin 2) K).as_sum]
+  conv_rhs => rw [(P : MvPolynomial (Fin 2) K).as_sum]
+  rw [map_sum, Finset.smul_sum]
+  refine Finset.sum_congr rfl fun d hd => ?_
+  have hdn : d.degree = n := by
+    by_contra hc
+    exact (mem_support_iff.mp hd) (hhom.coeff_eq_zero hc)
+  rw [Finsupp.degree_eq_sum, Fin.sum_univ_two] at hdn
+  have hC : C ((-1 : K) ^ n) = (-1 : MvPolynomial (Fin 2) K) ^ (d 0) * (-1) ^ (d 1) := by
+    rw [map_pow, map_neg, map_one, ← pow_add, hdn]
+  rw [monomial_eq, Finsupp.prod_fintype _ _ (fun i => pow_zero _), Fin.prod_univ_two, map_mul,
+    binarySubst_C,
+    map_mul, map_pow, map_pow, h0, h1, smul_eq_C_mul, hC,
+    neg_pow (X 0 : MvPolynomial (Fin 2) K), neg_pow (X 1 : MvPolynomial (Fin 2) K)]
+  ring
+
+end S_HeckeEis_binaryFormRepSL_neg_one_apply
+end P2MW
+export P2MW.S_HeckeEis_binaryFormRepSL_neg_one_apply (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.binaryFormRepSL_neg_one_apply (K : Type*) [CommRing K] (n : ℕ)
+    (P : ↥(HeckeEis.BinaryForm K n)) :
+    HeckeEis.binaryFormRepSL K n (-1) P = ((-1 : K) ^ n) • P :=
+  solution K n P
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeffH1par_binaryFormRepSL_eq_zero_of_odd.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeffH1par_binaryFormRepSL_eq_zero_of_odd.lean
new file mode 100644
index 0000000000..ebea315daa
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeffH1par_binaryFormRepSL_eq_zero_of_odd.lean
@@ -0,0 +1,166 @@
+/-
+Based on Prove2Me node HeckeEis.coeffH1par_binaryFormRepSL_eq_zero_of_odd
+(cbbf5965-74df-57a7-8920-8fa71b4b4cf4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 88f530b4-4d37-5d07-84f7-12b0c3bfd9c5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+
+import Mathlib.RingTheory.Etale.Weakly
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.SimpleRing.Principal
+import Mathlib.RingTheory.TotallySplit
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_binaryFormRepSL_neg_one_apply
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Vanishing of parabolic H¹ for odd symmetric powers
+
+Theorem statement: `HeckeEis.coeffH1par_binaryFormRepSL_eq_zero_of_odd`
+(`cbbf5965-74df-57a7-8920-8fa71b4b4cf4`), by Claude, 2026-09-05.
+
+Proof: submission `88f530b4-4d37-5d07-84f7-12b0c3bfd9c5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field in which $2 \neq 0$, let $N$ and $n$ be natural numbers with $n$ odd, and
+consider the representation of $\mathrm{SL}(2,\mathbb{Z})$ on the degree-$n$ binary forms
+[`HeckeEis.BinaryForm K n`](def/HeckeEis_BinaryFormRep.html#L25), that is on the submodule
+`MvPolynomial.homogeneousSubmodule (Fin 2) K n` of homogeneous polynomials of degree $n$ in two
+variables over $K$, where a matrix $M$ acts by the substitution $X_j \mapsto \sum_i M_{ij} X_i$ (the
+map [`HeckeEis.binaryFormRepSL K n`](def/HeckeEis_BinaryFormRep.html#L61)). Restrict this
+representation along the inclusion of the congruence subgroup $\Gamma_0(N)$ into
+$\mathrm{SL}(2,\mathbb{Z})$. The assertion is that every element $x$ of
+[`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100) of this restricted representation is
+zero; here `coeffH1par` of a representation $\rho$ of $\Gamma$ on $V$ is the quotient of the
+submodule of parabolic cocycles — those maps $\Gamma \to V$ lying in `coeffCocycles` and satisfying
+`IsParabolicCocycle` — by the preimage, under the inclusion of that submodule into all maps $\Gamma
+\to V$, of `coeffCoboundaries`, the range of `coeffCoboundaryMap`. Thus the parabolic first
+cohomology with coefficients in odd-degree binary forms vanishes, as a type-level statement about
+each of its elements.
+
+This is the odd-weight companion of the Eichler–Shimura statements: since $-1 \in \Gamma_0(N)$ acts
+on binary forms of odd degree $n$ by $-1$, the parabolic cohomology group degenerates. It is used to
+dispose of the odd case in
+[`HeckeEis.isCompl_range_eichlerShimuraMap_range_conj`]
+(thm.html#HeckeEis.isCompl_range_eichlerShimuraMap_range_conj).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_coeffH1par_binaryFormRepSL_eq_zero_of_odd.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_coeffH1par_binaryFormRepSL_eq_zero_of_odd
+
+
+open scoped MatrixGroups
+
+namespace HeckeEis
+p2m_export "HeckeEis" "mem_coeffCocycles_iff mem_coeffCoboundaries_iff coeffH1par \
+  coeffH1parMk_surjective coeffH1parMk_eq_zero_iff BinaryForm binaryFormRepSL \
+  binaryFormRepSL_neg_one_apply"
+namespace OddSol
+p2m_open "HeckeEis"
+
+open CongruenceSubgroup
+
+theorem neg_one_mem (N : ℕ) : (-1 : SL(2, ℤ)) ∈ Gamma0 N := by
+  rw [Gamma0_mem]
+  simp
+
+def m (N : ℕ) : Gamma0 N := ⟨-1, neg_one_mem N⟩
+
+theorem m_mul (N : ℕ) (g : Gamma0 N) : m N * g = g * m N := by
+  apply Subtype.ext
+  change (-1 : SL(2, ℤ)) * g = g * (-1)
+  rw [neg_one_mul, mul_neg_one]
+
+theorem rho_m {K : Type*} [CommRing K] (N n : ℕ) (hn : Odd n) (P : ↥(BinaryForm K n)) :
+    ((binaryFormRepSL K n).comp (Gamma0 N).subtype) (m N) P = -P := by
+  change binaryFormRepSL K n ((m N : Gamma0 N) : SL(2, ℤ)) P = -P
+  rw [show ((m N : Gamma0 N) : SL(2, ℤ)) = -1 from rfl, binaryFormRepSL_neg_one_apply,
+    hn.neg_one_pow]
+  exact neg_one_smul K P
+
+end HeckeEis.OddSol
+
+theorem solution (K : Type*) [Field K] (h2 : (2 : K) ≠ 0) (N n : ℕ) (hn : Odd n)
+    (x : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL K n).comp (CongruenceSubgroup.Gamma0
+      N).subtype)) : x = 0 := by
+  obtain ⟨z, rfl⟩ := HeckeEis.coeffH1parMk_surjective _ x
+  rw [HeckeEis.coeffH1parMk_eq_zero_iff, HeckeEis.mem_coeffCoboundaries_iff]
+  have hz : ∀ g h : CongruenceSubgroup.Gamma0 N, (z : CongruenceSubgroup.Gamma0 N →
+    ↥(HeckeEis.BinaryForm K n)) (g * h)
+      = (z : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm K n)) g +
+        ((HeckeEis.binaryFormRepSL K n).comp (CongruenceSubgroup.Gamma0 N).subtype) g ((z :
+        CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm K n)) h) :=
+    (HeckeEis.mem_coeffCocycles_iff _ _).mp z.2.1
+  have key : ∀ g : CongruenceSubgroup.Gamma0 N,
+      (2 : K) • (z : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm K n)) g = (z :
+        CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm K n)) (HeckeEis.OddSol.m N)
+        - ((HeckeEis.binaryFormRepSL K n).comp (CongruenceSubgroup.Gamma0 N).subtype) g ((z :
+          CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm K n)) (HeckeEis.OddSol.m N)) := by
+    intro g
+    have h1 := hz g (HeckeEis.OddSol.m N)
+    have h3 : (z : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm K n)) (g * HeckeEis.OddSol.m
+      N) = (z : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm K n)) (HeckeEis.OddSol.m N) - (z
+      : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm K n)) g :=
+      by
+      rw [← HeckeEis.OddSol.m_mul, hz, HeckeEis.OddSol.rho_m N n hn]; abel
+    have e := h1.symm.trans h3
+    rw [two_smul]
+    calc (z : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm K n)) g + (z :
+      CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm K n)) g
+        = ((z : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm K n)) g +
+          ((HeckeEis.binaryFormRepSL K n).comp (CongruenceSubgroup.Gamma0 N).subtype) g ((z :
+          CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm K n)) (HeckeEis.OddSol.m N)))
+            + (z : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm K n)) g -
+              ((HeckeEis.binaryFormRepSL K n).comp (CongruenceSubgroup.Gamma0 N).subtype) g ((z :
+              CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm K n)) (HeckeEis.OddSol.m N)) := by
+              abel
+      _ = ((z : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm K n)) (HeckeEis.OddSol.m N) - (z
+        : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm K n)) g) + (z :
+        CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm K n)) g
+            - ((HeckeEis.binaryFormRepSL K n).comp (CongruenceSubgroup.Gamma0 N).subtype) g ((z :
+              CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm K n)) (HeckeEis.OddSol.m N)) := by
+              rw [e]
+      _ = _ := by abel
+  refine ⟨-((2 : K)⁻¹ • (z : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm K n))
+    (HeckeEis.OddSol.m N)), funext fun g => ?_⟩
+  apply smul_right_injective ↥(HeckeEis.BinaryForm K n) h2
+  dsimp only
+  rw [map_neg, LinearMap.map_smul, key g, smul_sub, smul_neg, smul_neg, smul_smul, smul_smul,
+    mul_inv_cancel₀ h2, one_smul, one_smul]
+  abel
+
+end S_HeckeEis_coeffH1par_binaryFormRepSL_eq_zero_of_odd
+end P2MW
+export P2MW.S_HeckeEis_coeffH1par_binaryFormRepSL_eq_zero_of_odd (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.coeffH1par_binaryFormRepSL_eq_zero_of_odd (K : Type*) [Field K] (h2 : (2 : K) ≠ 0)
+    (N n : ℕ) (hn : Odd n)
+    (x : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL K n).comp (CongruenceSubgroup.Gamma0
+      N).subtype)) : x = 0 :=
+  solution K h2 N n hn x
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero.lean
new file mode 100644
index 0000000000..6cd5369ba2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero.lean
@@ -0,0 +1,228 @@
+/-
+Based on Prove2Me node HeckeEis.coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero
+(b8ca5bd8-e4bd-507a-b928-7ea9d7e6c033) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 946f2acf-dae8-5c62-a2c7-f5ead815e7b5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+
+import Mathlib.Algebra.AffineMonoid.Basic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_eq_smul_X_pow_of_binaryFormRepSL_lowerUnipotent_eq_self
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_eq_smul_X_pow_of_binaryFormRepSL_T_zpow_eq_self
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Torsion-freeness of integral parabolic H¹ for Γ₀(N)
+
+Theorem statement: `HeckeEis.coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero`
+(`b8ca5bd8-e4bd-507a-b928-7ea9d7e6c033`), by Claude, 2026-09-05.
+
+Proof: submission `946f2acf-dae8-5c62-a2c7-f5ead815e7b5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix natural numbers $n$ and $N$ with $N \neq 0$. Let $V =$ [`HeckeEis.BinaryForm ℤ
+n`](def/HeckeEis_BinaryFormRep.html#L25) be the $\mathbb{Z}$-submodule of homogeneous polynomials of
+degree $n$ in $\mathbb{Z}[X_0, X_1]$, and let $\rho$ be the representation of $\Gamma_0(N)$ on $V$
+obtained by composing the inclusion $\Gamma_0(N) \hookrightarrow \mathrm{SL}_2(\mathbb{Z})$ with
+[`HeckeEis.binaryFormRepSL ℤ n`](def/HeckeEis_BinaryFormRep.html#L61), the action in which $g$ acts
+by the substitution sending $X_j$ to $\sum_i g_{ij} X_i$. The module
+[`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100) of this representation is the quotient
+of the submodule [`HeckeEis.coeffParabolicCocycles`](def/Gamma0CoeffCohomology.html#L75) of
+functions $z : \Gamma_0(N) \to V$ that lie in
+[`HeckeEis.coeffCocycles`](def/Gamma0CoeffCohomology.html#L13) and satisfy the predicate
+[`HeckeEis.IsParabolicCocycle`](def/Gamma0CoeffCohomology.html#L71), by the preimage, under the
+inclusion of that submodule into $\Gamma_0(N) \to V$, of
+[`HeckeEis.coeffCoboundaries`](def/Gamma0CoeffCohomology.html#L45), the range of the map
+[`HeckeEis.coeffCoboundaryMap`](def/Gamma0CoeffCohomology.html#L30). The assertion is that this
+quotient has no nonzero torsion: for every integer $m \neq 0$ and every class $x$ in it with $m
+\cdot x = 0$, one has $x = 0$.
+
+This is the torsion-freeness of the integral parabolic cohomology group
+$H^1_{\mathrm{par}}(\Gamma_0(N), \mathrm{Sym}^n)$ in its inhomogeneous-cocycle description. It
+underlies the comparison of these groups across coefficient rings: it is used for the injectivity of
+the change-of-coefficients map from $\mathbb{Z}$ to $\mathbb{Q}$, for the construction of a basis of
+the complex parabolic cohomology compatible with the integral one, and for the divisibility
+statement
+[`HeckeEis.exists_eq_prime_smul_of_coeffH1par_map_eq_zero`]
+(thm.html#HeckeEis.exists_eq_prime_smul_of_coeffH1par_map_eq_zero).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst_C binaryFormRepSL binaryFormRepSL_apply_coe \
+  mem_coeffCoboundaries_iff coeffH1par coeffH1parMk_surjective coeffH1parMk_eq_zero_iff \
+  exists_eq_smul_X_pow_of_binaryFormRepSL_T_zpow_eq_self \
+  exists_eq_smul_X_pow_of_binaryFormRepSL_lowerUnipotent_eq_self"
+p2m_open "HeckeEis"
+
+open MvPolynomial CongruenceSubgroup
+open scoped MatrixGroups
+
+namespace TorsionFreeAux
+
+def gammaT (N : ℕ) : Gamma0 N := ⟨ModularGroup.T, by rw [Gamma0_mem]; simp [ModularGroup.coe_T]⟩
+
+@[scoped simp] theorem coe_gammaT (N : ℕ) :
+    ((gammaT N : Gamma0 N) : SL(2, ℤ)) = ModularGroup.T := rfl
+
+def lowerSL (N : ℕ) : SL(2, ℤ) := ⟨!![1, 0; (N : ℤ), 1], by rw [Matrix.det_fin_two_of]; ring⟩
+
+@[scoped simp] theorem coe_lowerSL (N : ℕ) :
+    ((lowerSL N : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) = !![1, 0; (N : ℤ), 1] := rfl
+
+def gammaL (N : ℕ) : Gamma0 N := ⟨lowerSL N, by rw [Gamma0_mem]; simp [lowerSL]⟩
+
+@[scoped simp] theorem coe_gammaL (N : ℕ) : ((gammaL N : Gamma0 N) : SL(2, ℤ)) = lowerSL N := rfl
+
+theorem trace_sq_gammaT (N : ℕ) :
+    (((gammaT N : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace ^ 2 = 4 := by
+  rw [coe_gammaT, ModularGroup.coe_T, Matrix.trace_fin_two_of]; norm_num
+
+theorem trace_sq_gammaL (N : ℕ) :
+    (((gammaL N : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace ^ 2 = 4 := by
+  rw [coe_gammaL, coe_lowerSL, Matrix.trace_fin_two_of]; norm_num
+
+theorem binaryFormRepSL_apply_of_zero {R : Type*} [CommRing R] (g : SL(2, ℤ))
+    (P : ↥(BinaryForm R 0)) :
+    binaryFormRepSL R 0 g P = P := by
+  apply Subtype.ext
+  rw [binaryFormRepSL_apply_coe]
+  have hP : (P : MvPolynomial (Fin 2) R) = MvPolynomial.C (AddMonoidAlgebra.coeff (P : MvPolynomial
+    (Fin 2) R) 0) :=
+    by
+    have h := (MvPolynomial.mem_homogeneousSubmodule 0 (P : MvPolynomial (Fin 2) R)).mp P.2
+    rw [← MvPolynomial.totalDegree_zero_iff_isHomogeneous] at h
+    exact (MvPolynomial.totalDegree_eq_zero_iff_eq_C.mp h)
+  rw [hP, binarySubst_C]
+
+theorem aux_fix {M : Type*} [AddCommGroup M] (f : M →+ M) (m : ℤ) (v w z : M)
+    (hv : f v - v = m • z) (hw : f w - w = z) : f (v - m • w) = v - m • w := by
+  rw [map_sub, map_zsmul, sub_eq_iff_eq_add.mp hv, ← hw, zsmul_sub]
+  abel
+
+theorem aux_div {M : Type*} [AddCommGroup M] (cf : M →+ ℤ) (m c₁ : ℤ) (v w₁ w₂ e : M)
+    (he : cf e = 1) (h1 : v - m • w₁ = c₁ • e) (h2 : cf (v - m • w₂) = 0) :
+    v = m • (w₁ + (cf w₂ - cf w₁) • e) := by
+  have k1 : cf v - m * cf w₁ = c₁ := by
+    have := congrArg cf h1
+    rwa [map_sub, map_zsmul, map_zsmul, he, zsmul_eq_mul, zsmul_eq_mul, mul_one] at this
+  have k2 : cf v - m * cf w₂ = 0 := by rwa [map_sub, map_zsmul, zsmul_eq_mul] at h2
+  have hc : c₁ = m * (cf w₂ - cf w₁) := by linear_combination -k1 + k2
+  rw [sub_eq_iff_eq_add'.mp h1, hc, zsmul_add, mul_zsmul]
+
+theorem aux_cancel {M : Type*} [AddCommGroup M] (f : M →+ M) (m : ℤ)
+    (hinj : ∀ x : M, m • x = 0 → x = 0)
+    (v' z : M) (h : f (m • v') - m • v' = m • z) : f v' - v' = z := by
+  rw [map_zsmul, ← zsmul_sub] at h
+  have h0 : m • (f v' - v' - z) = 0 := by rw [zsmul_sub, h, sub_self]
+  exact sub_eq_zero.mp (hinj _ h0)
+
+end TorsionFreeAux
+
+open TorsionFreeAux in
+theorem SolMain.A4 (n N : ℕ) [NeZero N] (m : ℤ) (hm : m ≠ 0)
+    (x : coeffH1par ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype)) (hx : m • x = 0) : x = 0 := by
+  classical
+  obtain ⟨z, rfl⟩ := coeffH1parMk_surjective _ x
+  rw [← map_zsmul, coeffH1parMk_eq_zero_iff, mem_coeffCoboundaries_iff] at hx
+  obtain ⟨v, hv⟩ := hx
+  have hv' : ∀ g : Gamma0 N, binaryFormRepSL ℤ n (g : SL(2, ℤ)) v - v = m • (z : Gamma0 N →
+    ↥(BinaryForm ℤ n)) g :=
+    fun g => by simpa using congrFun hv g
+  rw [coeffH1parMk_eq_zero_iff, mem_coeffCoboundaries_iff]
+  rcases Nat.eq_zero_or_pos n with hn0 | hnpos
+  · subst hn0
+    refine ⟨0, funext fun g => ?_⟩
+    have h1 : m • (z : Gamma0 N → ↥(BinaryForm ℤ 0)) g = 0 := by
+      rw [← hv' g, sub_eq_zero]
+      exact binaryFormRepSL_apply_of_zero _ _
+    have h2 : (z : Gamma0 N → ↥(BinaryForm ℤ 0)) g = 0 := (smul_eq_zero.mp h1).resolve_left hm
+    rw [h2, sub_eq_zero]
+    exact binaryFormRepSL_apply_of_zero _ _
+  · obtain ⟨w₁, hw₁⟩ := z.2.2 (gammaT N) (trace_sq_gammaT N)
+    obtain ⟨w₂, hw₂⟩ := z.2.2 (gammaL N) (trace_sq_gammaL N)
+    have hfix : ∀ (γ : Gamma0 N) (w : ↥(BinaryForm ℤ n)), (((binaryFormRepSL ℤ n).comp (Gamma0
+      N).subtype) γ - 1) w = (z : Gamma0 N → _) γ →
+        binaryFormRepSL ℤ n (γ : SL(2, ℤ)) (v - m • w) = v - m • w :=
+      fun γ w hw => aux_fix (binaryFormRepSL ℤ n (γ : SL(2, ℤ))).toAddMonoidHom m v w _ (hv' γ)
+        (by rw [LinearMap.sub_apply, Module.End.one_apply] at hw; exact hw)
+    have hjR : ∀ j : ℕ, 1 ≤ j → j ≤ n → (j : ℤ) ≠ 0 :=
+      fun j hj _ => by exact_mod_cast Nat.one_le_iff_ne_zero.mp hj
+    obtain ⟨c₁, hc₁⟩ :=
+      exists_eq_smul_X_pow_of_binaryFormRepSL_T_zpow_eq_self (R := ℤ) n (h := 1) (by norm_num) hjR
+      (v - m • w₁) (by simpa using hfix (gammaT N) w₁ hw₁)
+    have hN : ((N : ℤ) : ℤ) ≠ 0 := by exact_mod_cast NeZero.ne N
+    obtain ⟨c₂, hc₂⟩ :=
+      exists_eq_smul_X_pow_of_binaryFormRepSL_lowerUnipotent_eq_self (R := ℤ) n (h := (N : ℤ)) hN
+        hjR
+      (lowerSL N) (coe_lowerSL N) (v - m • w₂) (hfix (gammaL N) w₂ hw₂)
+    have hX0 : MvPolynomial.X 0 ^ n ∈ BinaryForm ℤ n :=
+      (MvPolynomial.mem_homogeneousSubmodule n _).mpr (MvPolynomial.isHomogeneous_X_pow 0 n)
+    set e : ↥(BinaryForm ℤ n) := ⟨MvPolynomial.X 0 ^ n, hX0⟩ with he
+    have hc₁' : v - m • w₁ = c₁ • e := Subtype.ext (by rw [hc₁]; rfl)
+    set cf : ↥(BinaryForm ℤ n) →ₗ[ℤ] ℤ := (MvPolynomial.lcoeff ℤ (Finsupp.single 0 n)).comp
+      (BinaryForm ℤ n).subtype with hcf
+    have hcf_apply : ∀ Q : ↥(BinaryForm ℤ n), cf Q = AddMonoidAlgebra.coeff (Q : MvPolynomial (Fin
+      2) ℤ) (Finsupp.single 0 n) :=
+      fun Q => rfl
+    have hcfe : cf e = 1 := by rw [hcf_apply]; simp [e, MvPolynomial.coeff_X_pow]
+    have h2 : cf (v - m • w₂) = 0 := by
+      rw [hcf_apply, hc₂, MvPolynomial.coeff_smul, MvPolynomial.coeff_X_pow, ite_eq_right,
+        smul_zero]
+      intro h; have := congrArg (fun d : Fin 2 →₀ ℕ => d 0) h; simp at this; omega
+    have hvm := aux_div cf.toAddMonoidHom m c₁ v w₁ w₂ e hcfe hc₁' h2
+    have hinj : ∀ y : ↥(BinaryForm ℤ n), m • y = 0 → y = 0 :=
+      fun y hy => (smul_eq_zero.mp hy).resolve_left hm
+    refine ⟨w₁ + (cf w₂ - cf w₁) • e, funext fun g =>
+      aux_cancel (binaryFormRepSL ℤ n (g : SL(2, ℤ))).toAddMonoidHom m hinj _ _ ?_⟩
+    have h1 := hv' g
+    rw [hvm] at h1
+    exact h1
+
+end HeckeEis
+
+open scoped MatrixGroups in
+theorem solution (n N : ℕ) [NeZero N] (m : ℤ) (hm : m ≠ 0)
+    (x : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℤ n).comp (CongruenceSubgroup.Gamma0
+      N).subtype))
+    (hx : m • x = 0) : x = 0 :=
+  HeckeEis.SolMain.A4 n N m hm x hx
+
+end S_HeckeEis_coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero
+end P2MW
+export P2MW.S_HeckeEis_coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero (n N : ℕ) [NeZero N] (m : ℤ)
+    (hm : m ≠ 0)
+    (x : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℤ n).comp (CongruenceSubgroup.Gamma0
+      N).subtype))
+    (hx : m • x = 0) : x = 0 :=
+  solution n N m hm x hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeffH1par_map_heckeT_comm.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeffH1par_map_heckeT_comm.lean
new file mode 100644
index 0000000000..4a72d7536c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeffH1par_map_heckeT_comm.lean
@@ -0,0 +1,256 @@
+/-
+Based on Prove2Me node HeckeEis.coeffH1par_map_heckeT_comm
+(08f2087c-284f-5aa2-b92a-542ff3cb8bb4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5399e649-a2b5-528e-8b7b-616c3cf6cb8b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Coefficient change is Hecke-equivariant on parabolic H¹
+
+Theorem statement: `HeckeEis.coeffH1par_map_heckeT_comm` (`08f2087c-284f-5aa2-b92a-542ff3cb8bb4`),
+by Claude, 2026-09-05.
+
+Proof: submission `5399e649-a2b5-528e-8b7b-616c3cf6cb8b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R,R'$ be commutative rings, $\varphi : R \to R'$ a ring homomorphism, and $n,N,\ell$ natural
+numbers with $\ell \neq 0$. For a commutative ring $K$ write $\rho_K$ for the representation of
+$\Gamma_0(N)$ obtained by restricting along $\Gamma_0(N) \hookrightarrow \mathrm{SL}(2,\mathbb{Z})$
+the action of $\mathrm{SL}(2,\mathbb{Z})$ on the degree-$n$ homogeneous part of $K[X_0,X_1]$ by the
+substitution $X_j \mapsto \sum_i M_{ij} X_i$, and write $H^1_{\mathrm{par}}$ for
+[`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100) of $\rho_K$, the quotient of the module
+of parabolic cocycles (functions $z : \Gamma_0(N) \to \mathrm{Sym}^n$ with $z(gh) = z(g) +
+\rho_K(g)z(h)$ and $z(\gamma) \in \mathrm{range}(\rho_K(\gamma) - 1)$ whenever
+$\mathrm{tr}(\gamma)^2 = 4$) by the coboundaries contained in it. Assume given: an additive map
+$\Phi$ from $H^1_{\mathrm{par}}$ over $R$ to $H^1_{\mathrm{par}}$ over $R'$ such that every
+parabolic cocycle $z$ over $R$ admits a parabolic cocycle $w$ over $R'$ with $w(g) =
+\mathrm{map}\,\varphi\,(z(g))$ for all $g \in \Gamma_0(N)$ and $\Phi[z] = [w]$; an $R$-linear
+endomorphism $T$ of $H^1_{\mathrm{par}}$ over $R$ such that every parabolic cocycle $z$ admits a
+parabolic cocycle $w$ equal, as a function, to [`HeckeEis.coeffHeckeFun N
+ℓ`](def/Gamma0CoeffCohomology.html#L129) applied to $z$ with coefficient part the substitution by
+$\mathrm{diag}(\ell,1)$, and $T[z] = [w]$; and an $R'$-linear endomorphism $T'$ of
+$H^1_{\mathrm{par}}$ over $R'$ with the same property over $R'$. Then $T'(\Phi x) = \Phi(T x)$ for
+every $x$ in $H^1_{\mathrm{par}}$ over $R$.
+
+This expresses the Hecke-equivariance of change of coefficient ring on the parabolic cohomology of
+$\Gamma_0(N)$ with binary-form coefficients, the operators $T,T'$ and the map $\Phi$ being specified
+only through their effect on cocycle representatives. It is used when comparing eigenclasses over
+different coefficient rings, for instance in the construction of integral structures on spaces of
+cusp forms and in the passage from an eigenform to an eigenclass over $\mathbb{Z}$ or over a residue
+field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_coeffH1par_map_heckeT_comm.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_coeffH1par_map_heckeT_comm
+
+namespace HeckeEis
+p2m_export "HeckeEis" "coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective \
+  coeffHeckeFun coeffHeckeFun_apply BinaryForm binarySubst binarySubst_X binarySubst_C \
+  binaryFormRepSL binaryFormRepSL_apply_coe binaryFormAlphaAdj binaryFormAlphaAdj_apply_coe"
+p2m_open "HeckeEis"
+
+open MvPolynomial CongruenceSubgroup
+open scoped MatrixGroups
+
+namespace CoeffChangeAux
+
+variable {R R' : Type*} [CommRing R] [CommRing R'] (φ : R →+* R')
+
+theorem map_binarySubst (M : Matrix (Fin 2) (Fin 2) ℤ) (p : MvPolynomial (Fin 2) R) :
+    MvPolynomial.map φ (binarySubst R M p) = binarySubst R' M (MvPolynomial.map φ p) := by
+  have h : (MvPolynomial.map φ).comp (binarySubst R M : MvPolynomial (Fin 2) R →ₐ[R] MvPolynomial
+    (Fin 2) R).toRingHom
+      = (binarySubst R' M : MvPolynomial (Fin 2) R' →ₐ[R'] MvPolynomial (Fin 2) R').toRingHom.comp
+        (MvPolynomial.map φ) := by
+    refine MvPolynomial.ringHom_ext (fun r => ?_) (fun j => ?_)
+    · simp []
+    · simp [binarySubst_X, Fin.sum_univ_two, map_add, map_mul]
+  exact RingHom.congr_fun h p
+
+theorem map_binaryFormRepSL (n : ℕ) (g : SL(2, ℤ)) (v : ↥(BinaryForm R n)) :
+    MvPolynomial.map φ ((binaryFormRepSL R n g v : ↥(BinaryForm R n)) : MvPolynomial (Fin 2) R)
+      = binarySubst R' (g : Matrix (Fin 2) (Fin 2) ℤ) (MvPolynomial.map φ (v : MvPolynomial (Fin 2)
+        R)) := by
+  rw [binaryFormRepSL_apply_coe, map_binarySubst]
+
+theorem map_binaryFormAlphaAdj (n ℓ : ℕ) (v : ↥(BinaryForm R n)) :
+    MvPolynomial.map φ ((binaryFormAlphaAdj R n ℓ v : ↥(BinaryForm R n)) : MvPolynomial (Fin 2) R)
+      = binarySubst R' !![(ℓ : ℤ), 0; 0, 1] (MvPolynomial.map φ (v : MvPolynomial (Fin 2) R)) := by
+  rw [binaryFormAlphaAdj_apply_coe, map_binarySubst]
+
+theorem map_coeffHeckeFun (n N ℓ : ℕ) [NeZero ℓ]
+    (z : Gamma0 N → ↥(BinaryForm R n)) (z' : Gamma0 N → ↥(BinaryForm R' n))
+    (hz : ∀ g : Gamma0 N, ((z' g : ↥(BinaryForm R' n)) : MvPolynomial (Fin 2) R') = MvPolynomial.map
+      φ ((z g : ↥(BinaryForm R n)) : MvPolynomial (Fin 2) R))
+    (g : Gamma0 N) :
+    ((coeffHeckeFun N ℓ ((binaryFormRepSL R' n).comp (Gamma0 N).subtype) (binaryFormAlphaAdj R' n ℓ)
+      z' g : ↥(BinaryForm R' n)) :
+        MvPolynomial (Fin 2) R')
+      = MvPolynomial.map φ ((coeffHeckeFun N ℓ ((binaryFormRepSL R n).comp (Gamma0 N).subtype)
+        (binaryFormAlphaAdj R n ℓ) z g :
+        ↥(BinaryForm R n)) : MvPolynomial (Fin 2) R) := by
+  rw [coeffHeckeFun_apply, coeffHeckeFun_apply, Submodule.coe_sum, Submodule.coe_sum, map_sum]
+  refine Finset.sum_congr rfl fun q _ => ?_
+  change binarySubst R' _ ((binaryFormAlphaAdj R' n ℓ (z' _) : ↥(BinaryForm R' n)) : MvPolynomial
+    (Fin 2) R')
+    = MvPolynomial.map φ (binarySubst R _ ((binaryFormAlphaAdj R n ℓ (z _) : ↥(BinaryForm R n)) :
+      MvPolynomial (Fin 2) R))
+  rw [map_binarySubst, map_binaryFormAlphaAdj, binaryFormAlphaAdj_apply_coe, hz]
+
+end CoeffChangeAux
+
+open CoeffChangeAux in
+theorem SolMain.C1 {R R' : Type*} [CommRing R] [CommRing R'] (φ : R →+* R') (n N ℓ : ℕ) [NeZero ℓ]
+    (Φ : coeffH1par ((binaryFormRepSL R n).comp (Gamma0 N).subtype) →+ coeffH1par ((binaryFormRepSL
+      R' n).comp (Gamma0 N).subtype))
+    (hΦ : ∀ z : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp (Gamma0 N).subtype)),
+      ∃ w : ↥(coeffParabolicCocycles ((binaryFormRepSL R' n).comp (Gamma0 N).subtype)),
+        (∀ g : Gamma0 N, ((w : Gamma0 N → ↥(BinaryForm R' n)) g : MvPolynomial (Fin 2) R')
+            = MvPolynomial.map φ (((z : Gamma0 N → ↥(BinaryForm R n)) g : MvPolynomial (Fin 2) R)))
+              ∧
+        Φ (coeffH1parMk _ z) = coeffH1parMk _ w)
+    (T : coeffH1par ((binaryFormRepSL R n).comp (Gamma0 N).subtype) →ₗ[R] coeffH1par
+      ((binaryFormRepSL R n).comp (Gamma0 N).subtype))
+    (hT : ∀ z : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp (Gamma0 N).subtype)),
+      ∃ w : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp (Gamma0 N).subtype)),
+        (w : Gamma0 N → ↥(BinaryForm R n)) = coeffHeckeFun N ℓ ((binaryFormRepSL R n).comp (Gamma0
+          N).subtype) (binaryFormAlphaAdj R n ℓ) z ∧
+        T (coeffH1parMk _ z) = coeffH1parMk _ w)
+    (T' : coeffH1par ((binaryFormRepSL R' n).comp (Gamma0 N).subtype) →ₗ[R'] coeffH1par
+      ((binaryFormRepSL R' n).comp (Gamma0 N).subtype))
+    (hT' : ∀ z : ↥(coeffParabolicCocycles ((binaryFormRepSL R' n).comp (Gamma0 N).subtype)),
+      ∃ w : ↥(coeffParabolicCocycles ((binaryFormRepSL R' n).comp (Gamma0 N).subtype)),
+        (w : Gamma0 N → ↥(BinaryForm R' n)) = coeffHeckeFun N ℓ ((binaryFormRepSL R' n).comp (Gamma0
+          N).subtype) (binaryFormAlphaAdj R' n ℓ) z ∧
+        T' (coeffH1parMk _ z) = coeffH1parMk _ w)
+    (x : coeffH1par ((binaryFormRepSL R n).comp (Gamma0 N).subtype)) :
+    T' (Φ x) = Φ (T x) := by
+  obtain ⟨z, rfl⟩ := coeffH1parMk_surjective _ x
+  obtain ⟨w, hw, hTw⟩ := hT z
+  obtain ⟨z', hz', hΦz⟩ := hΦ z
+  obtain ⟨w', hw', hΦw⟩ := hΦ w
+  obtain ⟨w'', hw'', hTz'⟩ := hT' z'
+  rw [hTw, hΦw, hΦz, hTz']
+  congr 1
+  apply Subtype.ext
+  funext g
+  apply Subtype.ext
+  rw [hw'', hw' g, map_coeffHeckeFun φ n N ℓ (z : Gamma0 N → ↥(BinaryForm R n)) z' hz' g, ← hw]
+
+end HeckeEis
+
+open scoped MatrixGroups in
+theorem solution {R R' : Type*} [CommRing R] [CommRing R'] (φ : R →+* R') (n N ℓ : ℕ) [NeZero ℓ]
+    (Φ : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL R n).comp (CongruenceSubgroup.Gamma0
+      N).subtype) →+ HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL R' n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype))
+    (hΦ : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL R n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL R' n).comp
+        (CongruenceSubgroup.Gamma0 N).subtype)),
+        (∀ g : CongruenceSubgroup.Gamma0 N, ((w : CongruenceSubgroup.Gamma0 N →
+          ↥(HeckeEis.BinaryForm R' n)) g : MvPolynomial (Fin 2) R')
+            = MvPolynomial.map φ (((z : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm R n)) g
+              : MvPolynomial (Fin 2) R))) ∧
+        Φ (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w)
+    (T : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL R n).comp (CongruenceSubgroup.Gamma0
+      N).subtype) →ₗ[R] HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL R n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype))
+    (hT : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL R n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL R n).comp
+        (CongruenceSubgroup.Gamma0 N).subtype)),
+        (w : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm R n)) = HeckeEis.coeffHeckeFun N ℓ
+          ((HeckeEis.binaryFormRepSL R n).comp (CongruenceSubgroup.Gamma0 N).subtype)
+          (HeckeEis.binaryFormAlphaAdj R n ℓ) z ∧
+        T (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w)
+    (T' : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL R' n).comp (CongruenceSubgroup.Gamma0
+      N).subtype) →ₗ[R'] HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL R' n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype))
+    (hT' : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL R' n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL R' n).comp
+        (CongruenceSubgroup.Gamma0 N).subtype)),
+        (w : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm R' n)) = HeckeEis.coeffHeckeFun N ℓ
+          ((HeckeEis.binaryFormRepSL R' n).comp (CongruenceSubgroup.Gamma0 N).subtype)
+          (HeckeEis.binaryFormAlphaAdj R' n ℓ) z ∧
+        T' (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w)
+    (x : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL R n).comp (CongruenceSubgroup.Gamma0
+      N).subtype)) :
+    T' (Φ x) = Φ (T x) :=
+  HeckeEis.SolMain.C1 φ n N ℓ Φ hΦ T hT T' hT' x
+
+end S_HeckeEis_coeffH1par_map_heckeT_comm
+end P2MW
+export P2MW.S_HeckeEis_coeffH1par_map_heckeT_comm (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.coeffH1par_map_heckeT_comm {R R' : Type*} [CommRing R] [CommRing R'] (φ : R →+* R')
+    (n N ℓ : ℕ) [NeZero ℓ]
+    (Φ : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL R n).comp (CongruenceSubgroup.Gamma0
+      N).subtype) →+ HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL R' n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype))
+    (hΦ : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL R n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL R' n).comp
+        (CongruenceSubgroup.Gamma0 N).subtype)),
+        (∀ g : CongruenceSubgroup.Gamma0 N, ((w : CongruenceSubgroup.Gamma0 N →
+          ↥(HeckeEis.BinaryForm R' n)) g : MvPolynomial (Fin 2) R')
+            = MvPolynomial.map φ (((z : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm R n)) g
+              : MvPolynomial (Fin 2) R))) ∧
+        Φ (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w)
+    (T : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL R n).comp (CongruenceSubgroup.Gamma0
+      N).subtype) →ₗ[R] HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL R n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype))
+    (hT : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL R n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL R n).comp
+        (CongruenceSubgroup.Gamma0 N).subtype)),
+        (w : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm R n)) = HeckeEis.coeffHeckeFun N ℓ
+          ((HeckeEis.binaryFormRepSL R n).comp (CongruenceSubgroup.Gamma0 N).subtype)
+          (HeckeEis.binaryFormAlphaAdj R n ℓ) z ∧
+        T (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w)
+    (T' : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL R' n).comp (CongruenceSubgroup.Gamma0
+      N).subtype) →ₗ[R'] HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL R' n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype))
+    (hT' : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL R' n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL R' n).comp
+        (CongruenceSubgroup.Gamma0 N).subtype)),
+        (w : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm R' n)) = HeckeEis.coeffHeckeFun N ℓ
+          ((HeckeEis.binaryFormRepSL R' n).comp (CongruenceSubgroup.Gamma0 N).subtype)
+          (HeckeEis.binaryFormAlphaAdj R' n ℓ) z ∧
+        T' (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w)
+    (x : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL R n).comp (CongruenceSubgroup.Gamma0
+      N).subtype)) :
+    T' (Φ x) = Φ (T x) :=
+  solution φ n N ℓ Φ hΦ T hT T' hT' x
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeffH1par_map_int_rat_injective.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeffH1par_map_int_rat_injective.lean
new file mode 100644
index 0000000000..7378421ff2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeffH1par_map_int_rat_injective.lean
@@ -0,0 +1,573 @@
+/-
+Based on Prove2Me node HeckeEis.coeffH1par_map_int_rat_injective
+(21ed02fb-bd65-542e-9e28-747806cdc55f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission bcc0f4b0-dc06-597a-8c06-d991869f8366
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+
+import Mathlib.Algebra.MvPolynomial.Monad
+import Mathlib.Analysis.Normed.Ring.Lemmas
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Injectivity of H¹ₚₐᵣ from ℤ to ℚ
+
+Theorem statement: `HeckeEis.coeffH1par_map_int_rat_injective`
+(`21ed02fb-bd65-542e-9e28-747806cdc55f`), by Claude, 2026-09-05.
+
+Proof: submission `bcc0f4b0-dc06-597a-8c06-d991869f8366`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix natural numbers $n$ and $N$ with $N \neq 0$. For a commutative ring $K$, let $\rho_K$ denote the
+representation of $\Gamma_0(N) \le \mathrm{SL}_2(\mathbb Z)$ on the $K$-module of homogeneous
+polynomials of degree $n$ in two variables over $K$ obtained by restricting
+[`HeckeEis.binaryFormRepSL K n`](def/HeckeEis_BinaryFormRep.html#L61), whose value at a matrix $M$
+is the substitution $X_j \mapsto \sum_i M_{ij} X_i$; write $Z_K$ for the submodule of parabolic
+cocycles, that is, maps $z : \Gamma_0(N) \to \mathrm{BinaryForm}\,K\,n$ with $z(gh) = z(g) +
+\rho_K(g)(z(h))$ for all $g,h$ and with $z(\gamma)$ in the range of $\rho_K(\gamma) - 1$ for every
+$\gamma$ whose underlying integral matrix has trace squared equal to $4$, and $H_K = Z_K / (Z_K \cap
+\text{coboundaries})$ for the corresponding quotient
+[`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100), with $[\,\cdot\,]$ the quotient map
+[`HeckeEis.coeffH1parMk`](def/Gamma0CoeffCohomology.html#L111). Let $\Phi : H_{\mathbb Z} \to
+H_{\mathbb Q}$ be an additive group homomorphism such that for every parabolic cocycle $z \in
+Z_{\mathbb Z}$ there is a parabolic cocycle $w \in Z_{\mathbb Q}$ with $w(g)$ equal to the image of
+$z(g)$ under the coefficientwise map $\mathbb Z \to \mathbb Q$ on polynomials, for all $g \in
+\Gamma_0(N)$, and with $\Phi([z]) = [w]$. Then $\Phi$ is injective.
+
+This is the injectivity of the base-change map $H^1_{\mathrm{par}}(\Gamma_0(N), \mathrm{Sym}^n) \to
+H^1_{\mathrm{par}}(\Gamma_0(N), \mathrm{Sym}^n \otimes \mathbb Q)$ on parabolic cohomology with
+binary-form coefficients, stated for any additive map induced on classes by coefficient extension of
+cocycles; it rests on the torsion-freeness statement
+[`HeckeEis.coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero`]
+(thm.html#HeckeEis.coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero).
+It is used in the construction of a $\mathbb Z$-basis of the integral parabolic cohomology
+compatible with its complexification,
+[`HeckeEis.exists_basis_coeffH1par_int_complex`]
+(thm.html#HeckeEis.exists_basis_coeffH1par_int_complex).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_coeffH1par_map_int_rat_injective.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_coeffH1par_map_int_rat_injective
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff IsParabolicCocycle \
+  coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff \
+  coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero"
+namespace CoeffMapAux
+p2m_open "HeckeEis"
+
+open MvPolynomial
+open scoped MatrixGroups
+
+variable {R R' : Type*} [CommRing R] [CommRing R']
+
+theorem binarySubst_eq_bind₁ (S : Type*) [CommRing S] (M : Matrix (Fin 2) (Fin 2) ℤ)
+    (P : MvPolynomial (Fin 2) S) :
+    binarySubst S M P = bind₁ (fun j => ∑ i : Fin 2, C ((M i j : ℤ) : S) * X i) P := by
+  rw [binarySubst, aeval_eq_bind₁]
+
+theorem map_binarySubst_int (φ : ℤ →+* R) (M : Matrix (Fin 2) (Fin 2) ℤ)
+    (P : MvPolynomial (Fin 2) ℤ) :
+    MvPolynomial.map φ (binarySubst ℤ M P) = binarySubst R M (MvPolynomial.map φ P) := by
+  have key : (MvPolynomial.map φ).comp (binarySubst ℤ M : MvPolynomial (Fin 2) ℤ →ₐ[ℤ] MvPolynomial
+    (Fin 2) ℤ).toRingHom
+      = (binarySubst R M : MvPolynomial (Fin 2) R →ₐ[R] MvPolynomial (Fin 2) R).toRingHom.comp
+        (MvPolynomial.map φ) :=
+    MvPolynomial.ringHom_ext (fun a => by simp []) (fun j => by simp [binarySubst_X])
+  exact RingHom.congr_fun key P
+
+def substCoeff (M : Matrix (Fin 2) (Fin 2) ℤ) (d d' : Fin 2 →₀ ℕ) : ℤ :=
+  AddMonoidAlgebra.coeff (binarySubst ℤ M (monomial d' 1)) d
+
+theorem binarySubst_monomial_one (M : Matrix (Fin 2) (Fin 2) ℤ) (d' : Fin 2 →₀ ℕ) :
+    binarySubst R M (monomial d' 1) = MvPolynomial.map (Int.castRingHom R) (binarySubst ℤ M
+      (monomial d' 1)) := by
+  rw [map_binarySubst_int, map_monomial, (Int.castRingHom R).map_one]
+
+theorem coeff_binarySubst (M : Matrix (Fin 2) (Fin 2) ℤ) (P : MvPolynomial (Fin 2) R)
+    (d : Fin 2 →₀ ℕ) :
+    AddMonoidAlgebra.coeff (binarySubst R M P) d = ∑ d' ∈ P.support, (substCoeff M d d' : R) *
+      AddMonoidAlgebra.coeff P d' := by
+  conv_lhs => rw [P.as_sum, map_sum, coeff_sum]
+  refine Finset.sum_congr rfl fun d' _ => ?_
+  rw [show monomial d' (AddMonoidAlgebra.coeff P d') = C (AddMonoidAlgebra.coeff P d') * monomial d'
+    1 by
+    rw [C_mul_monomial, mul_one], map_mul, binarySubst_C,
+    coeff_C_mul, binarySubst_monomial_one, coeff_map, substCoeff, mul_comm]
+  rfl
+
+variable (f : R →+ R')
+
+def pushCoeff (P : MvPolynomial (Fin 2) R) : MvPolynomial (Fin 2) R' :=
+  ∑ d ∈ P.support, monomial d (f (AddMonoidAlgebra.coeff P d))
+
+@[scoped simp] theorem coeff_pushCoeff (P : MvPolynomial (Fin 2) R) (d : Fin 2 →₀ ℕ) :
+    AddMonoidAlgebra.coeff (pushCoeff f P) d = f (AddMonoidAlgebra.coeff P d) := by
+  classical
+  rw [pushCoeff, coeff_sum]
+  simp only [coeff_monomial]
+  rw [Finset.sum_ite_eq']
+  split_ifs with h
+  · rfl
+  · rw [notMem_support_iff.mp h, map_zero]
+
+theorem support_pushCoeff (P : MvPolynomial (Fin 2) R) : (pushCoeff f P).support ⊆ P.support := by
+  intro d hd
+  rw [mem_support_iff, coeff_pushCoeff] at hd
+  rw [mem_support_iff]
+  intro h; exact hd (by rw [h, map_zero])
+
+theorem pushCoeff_mem (n : ℕ) {P : MvPolynomial (Fin 2) R} (hP : P ∈ BinaryForm R n) :
+    pushCoeff f P ∈ BinaryForm R' n := by
+  rw [mem_homogeneousSubmodule] at hP ⊢
+  intro d hd
+  exact hP (mem_support_iff.mp (support_pushCoeff f P (mem_support_iff.mpr hd)))
+
+theorem pushCoeff_add (P Q : MvPolynomial (Fin 2) R) :
+    pushCoeff f (P + Q) = pushCoeff f P + pushCoeff f Q := by
+  ext d; simp
+
+theorem pushCoeff_sub (P Q : MvPolynomial (Fin 2) R) :
+    pushCoeff f (P - Q) = pushCoeff f P - pushCoeff f Q := by
+  ext d; simp
+
+theorem pushCoeff_zero : pushCoeff f (0 : MvPolynomial (Fin 2) R) = 0 := by
+  ext d; simp
+
+theorem eq_pushCoeff_iff (P : MvPolynomial (Fin 2) R) (Q : MvPolynomial (Fin 2) R') :
+    Q = pushCoeff f P ↔ ∀ d, AddMonoidAlgebra.coeff Q d = f (AddMonoidAlgebra.coeff P d) := by
+  constructor
+  · rintro rfl d; exact coeff_pushCoeff f P d
+  · intro h; ext d; rw [h d, coeff_pushCoeff]
+
+theorem pushCoeff_binarySubst (M : Matrix (Fin 2) (Fin 2) ℤ) (P : MvPolynomial (Fin 2) R) :
+    pushCoeff f (binarySubst R M P) = binarySubst R' M (pushCoeff f P) := by
+  classical
+  ext d
+  rw [coeff_pushCoeff, coeff_binarySubst, coeff_binarySubst, map_sum]
+  rw [Finset.sum_subset (support_pushCoeff f P)]
+  · refine Finset.sum_congr rfl fun d' _ => ?_
+    rw [coeff_pushCoeff, ← zsmul_eq_mul, ← zsmul_eq_mul, map_zsmul]
+  · intro d' _ hd'
+    rw [notMem_support_iff.mp hd', mul_zero]
+
+def pushForm (n : ℕ) (P : ↥(BinaryForm R n)) :
+    ↥(BinaryForm R' n) := ⟨pushCoeff f P, pushCoeff_mem f n P.2⟩
+
+@[scoped simp] theorem coe_pushForm (n : ℕ) (P : ↥(BinaryForm R n)) :
+    ((pushForm f n P : ↥(BinaryForm R' n)) : MvPolynomial (Fin 2) R') = pushCoeff f P := rfl
+
+theorem pushForm_add (n : ℕ) (P Q : ↥(BinaryForm R n)) :
+    pushForm f n (P + Q) = pushForm f n P + pushForm f n Q :=
+  Subtype.ext (by simp [pushCoeff_add])
+
+theorem pushForm_sub (n : ℕ) (P Q : ↥(BinaryForm R n)) :
+    pushForm f n (P - Q) = pushForm f n P - pushForm f n Q :=
+  Subtype.ext (by simp [pushCoeff_sub])
+
+theorem pushForm_zero (n : ℕ) :
+    pushForm f n (0 : ↥(BinaryForm R n)) = 0 := Subtype.ext (by simp [pushCoeff_zero])
+
+theorem pushForm_binaryFormRepSL (n : ℕ) (g : SL(2, ℤ)) (P : ↥(BinaryForm R n)) :
+    pushForm f n (binaryFormRepSL R n g P) = binaryFormRepSL R' n g (pushForm f n P) :=
+  Subtype.ext (by simp [pushCoeff_binarySubst])
+
+section Cocycles
+
+variable {Γ : Subgroup SL(2, ℤ)} (n : ℕ)
+
+theorem pushForm_comp_mem_coeffCocycles {z : Γ → ↥(BinaryForm R n)}
+    (hz : z ∈ coeffCocycles ((binaryFormRepSL R n).comp Γ.subtype)) :
+    (fun g => pushForm f n (z g)) ∈ coeffCocycles ((binaryFormRepSL R' n).comp Γ.subtype) := by
+  intro g h
+  change pushForm f n (z (g * h)) = pushForm f n (z g) + binaryFormRepSL R' n ((g : Γ) : SL(2, ℤ))
+    (pushForm f n (z h))
+  rw [hz g h, pushForm_add, ← pushForm_binaryFormRepSL]
+  rfl
+
+theorem isParabolicCocycle_pushForm_comp {z : Γ → ↥(BinaryForm R n)}
+    (hz : IsParabolicCocycle ((binaryFormRepSL R n).comp Γ.subtype) z) :
+    IsParabolicCocycle ((binaryFormRepSL R' n).comp Γ.subtype) (fun g => pushForm f n (z g)) := by
+  intro γ hγ
+  obtain ⟨u, hu⟩ := hz γ hγ
+  refine ⟨pushForm f n u, ?_⟩
+  rw [LinearMap.sub_apply, Module.End.one_apply] at hu ⊢
+  change binaryFormRepSL R n (γ : SL(2, ℤ)) u - u = z γ at hu
+  change binaryFormRepSL R' n (γ : SL(2, ℤ)) (pushForm f n u) - pushForm f n u = pushForm f n (z γ)
+  rw [← hu, pushForm_sub, pushForm_binaryFormRepSL]
+
+theorem pushForm_comp_mem_coeffParabolicCocycles {z : Γ → ↥(BinaryForm R n)}
+    (hz : z ∈ coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype)) :
+    (fun g => pushForm f n (z g)) ∈ coeffParabolicCocycles ((binaryFormRepSL R' n).comp Γ.subtype)
+      :=
+  ⟨pushForm_comp_mem_coeffCocycles f n hz.1, isParabolicCocycle_pushForm_comp f n hz.2⟩
+
+theorem pushForm_comp_mem_coeffCoboundaries {z : Γ → ↥(BinaryForm R n)}
+    (hz : z ∈ coeffCoboundaries ((binaryFormRepSL R n).comp Γ.subtype)) :
+    (fun g => pushForm f n (z g)) ∈ coeffCoboundaries ((binaryFormRepSL R' n).comp Γ.subtype) := by
+  obtain ⟨v, hv⟩ := (mem_coeffCoboundaries_iff _ _).mp hz
+  rw [mem_coeffCoboundaries_iff]
+  refine ⟨pushForm f n v, funext fun g => ?_⟩
+  have h := congrFun hv g
+  change binaryFormRepSL R n (g : SL(2, ℤ)) v - v = z g at h
+  change binaryFormRepSL R' n (g : SL(2, ℤ)) (pushForm f n v) - pushForm f n v = pushForm f n (z g)
+  rw [← h, pushForm_sub, pushForm_binaryFormRepSL]
+
+def pushPar : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))
+    →+ ↥(coeffParabolicCocycles ((binaryFormRepSL R' n).comp Γ.subtype)) where
+  toFun z := ⟨fun g => pushForm f n (z.1 g), pushForm_comp_mem_coeffParabolicCocycles f n z.2⟩
+  map_zero' := by
+    apply Subtype.ext; funext g
+    change pushForm f n ((0 : Γ → ↥(BinaryForm R n)) g) = 0
+    rw [Pi.zero_apply, pushForm_zero]
+  map_add' z w := by
+    apply Subtype.ext; funext g
+    change pushForm f n (z.1 g + w.1 g) = pushForm f n (z.1 g) + pushForm f n (w.1 g)
+    rw [pushForm_add]
+
+@[scoped simp] theorem pushPar_apply_coe (z : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp
+  Γ.subtype))) (g : Γ) :
+    (((pushPar f n z).1 g : ↥(BinaryForm R' n)) : MvPolynomial (Fin 2) R') = pushCoeff f (z.1 g) :=
+      rfl
+
+theorem pushPar_apply_val (z : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype)))
+    (g : Γ) :
+    (pushPar f n z).1 g = pushForm f n (z.1 g) := rfl
+
+theorem mk_eq_mk_iff {S : Type*} [CommRing S]
+    (a b : ↥(coeffParabolicCocycles ((binaryFormRepSL S n).comp Γ.subtype))) :
+    coeffH1parMk _ a = coeffH1parMk _ b ↔
+      ((a - b : ↥(coeffParabolicCocycles ((binaryFormRepSL S n).comp Γ.subtype))).1
+        ∈ coeffCoboundaries ((binaryFormRepSL S n).comp Γ.subtype)) := by
+  rw [← sub_eq_zero, ← map_sub, coeffH1parMk_eq_zero_iff]
+
+theorem pushPar_sub (a b : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))) :
+    pushPar f n (a - b) = pushPar f n a - pushPar f n b :=
+  map_sub (pushPar f n) a b
+
+theorem mk_pushPar_congr {a b : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))}
+    (h : coeffH1parMk _ a = coeffH1parMk _ b) :
+    coeffH1parMk _ (pushPar f n a) = coeffH1parMk _ (pushPar f n b) := by
+  rw [mk_eq_mk_iff] at h ⊢
+  rw [← pushPar_sub]
+  exact pushForm_comp_mem_coeffCoboundaries f n h
+
+def pushH1par :
+    coeffH1par ((binaryFormRepSL R n).comp Γ.subtype) →+
+      coeffH1par ((binaryFormRepSL R' n).comp Γ.subtype) where
+  toFun x := coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) x))
+  map_zero' := by
+    have h0 : coeffH1parMk _ (Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp
+      Γ.subtype)) 0)
+        = coeffH1parMk _ (0 : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))) :=
+          by
+      rw [Function.surjInv_eq (coeffH1parMk_surjective _), map_zero]
+    change coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) 0)) = 0
+    rw [mk_pushPar_congr f n h0, map_zero, map_zero]
+  map_add' x y := by
+    have hxy : coeffH1parMk _ (Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp
+      Γ.subtype)) (x + y))
+        = coeffH1parMk _ (Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp
+          Γ.subtype)) x
+            + Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp Γ.subtype)) y)
+              := by
+      rw [map_add, Function.surjInv_eq (coeffH1parMk_surjective _), Function.surjInv_eq
+        (coeffH1parMk_surjective _),
+        Function.surjInv_eq (coeffH1parMk_surjective _)]
+    change coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) (x + y))) = _
+    rw [mk_pushPar_congr f n hxy, map_add, map_add]
+
+theorem pushH1par_mk (z : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))) :
+    pushH1par f n (coeffH1parMk _ z) = coeffH1parMk _ (pushPar f n z) := by
+  change coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) (coeffH1parMk _
+    z))) = _
+  apply mk_pushPar_congr
+  exact Function.surjInv_eq (coeffH1parMk_surjective _) _
+
+end Cocycles
+
+end HeckeEis.CoeffMapAux
+end
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff IsParabolicCocycle \
+  coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff \
+  coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero"
+namespace CoeffMapAux
+p2m_open "HeckeEis"
+
+open MvPolynomial
+open scoped MatrixGroups
+
+theorem pushCoeff_ringHom_eq_map {R R' : Type*} [CommRing R] [CommRing R'] (φ : R →+* R')
+    (P : MvPolynomial (Fin 2) R) :
+    pushCoeff φ.toAddMonoidHom P = MvPolynomial.map φ P := by
+  ext d
+  rw [coeff_pushCoeff, coeff_map]
+  rfl
+
+end HeckeEis.CoeffMapAux
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff IsParabolicCocycle \
+  coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff \
+  coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero"
+namespace RatAux
+p2m_open "HeckeEis"
+
+open MvPolynomial HeckeEis.CoeffMapAux
+open scoped MatrixGroups
+
+theorem exists_common_den (s : Finset ℚ) : ∃ D : ℤ, D ≠ 0 ∧ ∀ x ∈ s, ∃ m : ℤ, (D : ℚ) * x = m := by
+  classical
+  refine ⟨∏ y ∈ s, (y.den : ℤ), ?_, fun x hx => ?_⟩
+  · rw [Finset.prod_ne_zero_iff]; intro y _; exact_mod_cast y.den_nz
+  · refine ⟨(∏ y ∈ s.erase x, (y.den : ℤ)) * x.num, ?_⟩
+    rw [← Finset.mul_prod_erase s _ hx]
+    push_cast
+    rw [mul_comm ((x.den : ℚ)) _, mul_assoc, Rat.den_mul_eq_num]
+
+def IsInt (P : MvPolynomial (Fin 2) ℚ) : Prop := ∀ d, ∃ m : ℤ, AddMonoidAlgebra.coeff P d = m
+
+theorem IsInt.zero : IsInt 0 := fun d => ⟨0, by simp⟩
+theorem IsInt.add {P Q : MvPolynomial (Fin 2) ℚ} (hP : IsInt P) (hQ : IsInt Q) :
+    IsInt (P + Q) := fun d => by
+  obtain ⟨a, ha⟩ :=
+    hP d; obtain ⟨b, hb⟩ := hQ d; exact ⟨a + b, by
+      rw [AddMonoidAlgebra.coeff_add, Finsupp.add_apply, ha, hb]; push_cast; rfl⟩
+theorem IsInt.neg {P : MvPolynomial (Fin 2) ℚ} (hP : IsInt P) : IsInt (-P) := fun d => by
+  obtain ⟨a, ha⟩ := hP d; exact ⟨-a, by rw [coeff_neg, ha]; push_cast; rfl⟩
+theorem IsInt.zsmul {P : MvPolynomial (Fin 2) ℚ} (hP : IsInt P) (m : ℤ) :
+    IsInt (m • P) := fun d => by
+  obtain ⟨a, ha⟩ := hP d
+  exact ⟨m * a, by rw [← Int.cast_smul_eq_zsmul ℚ m P, coeff_smul, ha, smul_eq_mul]; push_cast; rfl⟩
+theorem IsInt.map (P : MvPolynomial (Fin 2) ℤ) :
+    IsInt (MvPolynomial.map (Int.castRingHom ℚ) P) := fun d =>
+  ⟨AddMonoidAlgebra.coeff P d, by rw [coeff_map]; rfl⟩
+
+theorem IsInt.binarySubst {P : MvPolynomial (Fin 2) ℚ} (hP : IsInt P) (M : Matrix (Fin 2) (Fin 2) ℤ)
+    :
+    IsInt (HeckeEis.binarySubst ℚ M P) := by
+  classical
+  intro d
+  rw [coeff_binarySubst]
+  choose m hm using hP
+  refine ⟨∑ d' ∈ P.support, substCoeff M d d' * m d', ?_⟩
+  push_cast
+  exact Finset.sum_congr rfl fun d' _ => by rw [hm d']
+
+def intModel (P : MvPolynomial (Fin 2) ℚ) :
+    MvPolynomial (Fin 2) ℤ := ∑ d ∈ P.support, monomial d (AddMonoidAlgebra.coeff P d).num
+
+theorem coeff_intModel (P : MvPolynomial (Fin 2) ℚ) (d : Fin 2 →₀ ℕ) :
+    AddMonoidAlgebra.coeff (intModel P) d = (AddMonoidAlgebra.coeff P d).num := by
+  classical
+  rw [intModel, coeff_sum]
+  simp only [coeff_monomial]
+  rw [Finset.sum_ite_eq']
+  split_ifs with h
+  · rfl
+  · rw [notMem_support_iff.mp h, Rat.num_zero]
+
+theorem map_intModel {P : MvPolynomial (Fin 2) ℚ} (hP : IsInt P) :
+    MvPolynomial.map (Int.castRingHom ℚ) (intModel P) = P := by
+  ext d
+  rw [coeff_map, coeff_intModel]
+  obtain ⟨m, hm⟩ := hP d
+  rw [hm, Rat.num_intCast]
+  rfl
+
+theorem intModel_mem (n : ℕ) {P : MvPolynomial (Fin 2) ℚ} (hP : P ∈ BinaryForm ℚ n) :
+    intModel P ∈ BinaryForm ℤ n := by
+  rw [mem_homogeneousSubmodule] at hP ⊢
+  intro d hd
+  rw [coeff_intModel] at hd
+  apply hP
+  intro h
+  exact hd (by rw [h, Rat.num_zero])
+
+theorem exists_isInt_zsmul (P : MvPolynomial (Fin 2) ℚ) : ∃ D : ℤ, D ≠ 0 ∧ IsInt (D • P) := by
+  classical
+  obtain ⟨D, hD, h⟩ := exists_common_den (P.support.image fun d => AddMonoidAlgebra.coeff P d)
+  refine ⟨D, hD, fun d => ?_⟩
+  by_cases hd : d ∈ P.support
+  · obtain ⟨m, hm⟩ := h _ (Finset.mem_image_of_mem _ hd)
+    exact ⟨m, by rw [← Int.cast_smul_eq_zsmul ℚ D, coeff_smul, smul_eq_mul, hm]⟩
+  · exact ⟨0, by rw [← Int.cast_smul_eq_zsmul ℚ D, coeff_smul, notMem_support_iff.mp hd,
+      smul_zero]; simp⟩
+
+theorem exists_isInt_zsmul_family {ι : Type*} (s : Finset ι) (P : ι → MvPolynomial (Fin 2) ℚ) :
+    ∃ D : ℤ, D ≠ 0 ∧ ∀ i ∈ s, IsInt (D • P i) := by
+  classical
+  obtain ⟨D, hD, h⟩ :=
+    exists_common_den (s.biUnion fun i => (P i).support.image fun d => AddMonoidAlgebra.coeff (P i)
+      d)
+  refine ⟨D, hD, fun i hi d => ?_⟩
+  by_cases hd : d ∈ (P i).support
+  · obtain ⟨m, hm⟩ := h _ (Finset.mem_biUnion.mpr ⟨i, hi, Finset.mem_image_of_mem _ hd⟩)
+    exact ⟨m, by rw [← Int.cast_smul_eq_zsmul ℚ D, coeff_smul, smul_eq_mul, hm]⟩
+  · exact ⟨0, by rw [← Int.cast_smul_eq_zsmul ℚ D, coeff_smul, notMem_support_iff.mp hd,
+      smul_zero]; simp⟩
+
+abbrev ιZQ : ℤ →+ ℚ := (Int.castRingHom ℚ).toAddMonoidHom
+
+theorem pushForm_ι_injective (n : ℕ) :
+    Function.Injective (pushForm ιZQ n : ↥(BinaryForm ℤ n) → ↥(BinaryForm ℚ n)) := by
+  intro P Q h
+  apply Subtype.ext
+  ext d
+  have :=
+    congrArg (fun S : ↥(BinaryForm ℚ n) => AddMonoidAlgebra.coeff (S : MvPolynomial (Fin 2) ℚ) d) h
+  simp only [coe_pushForm, coeff_pushCoeff] at this
+  exact Int.cast_injective this
+
+theorem coe_pushForm_ι (n : ℕ) (P : ↥(BinaryForm ℤ n)) :
+    ((pushForm ιZQ n P : ↥(BinaryForm ℚ n)) : MvPolynomial (Fin 2) ℚ) = MvPolynomial.map
+      (Int.castRingHom ℚ) P := by
+  rw [coe_pushForm]; exact pushCoeff_ringHom_eq_map _ _
+
+theorem exists_eq_pushForm_of_isInt (n : ℕ) {Q : ↥(BinaryForm ℚ n)}
+    (hQ : IsInt (Q : MvPolynomial (Fin 2) ℚ)) :
+    ∃ P : ↥(BinaryForm ℤ n), pushForm ιZQ n P = Q := by
+  refine ⟨⟨intModel Q, intModel_mem n Q.2⟩, Subtype.ext ?_⟩
+  rw [coe_pushForm_ι]
+  exact map_intModel hQ
+
+theorem pushForm_zsmul {R R' : Type*} [CommRing R] [CommRing R'] (f : R →+ R') (n : ℕ) (m : ℤ)
+    (P : ↥(BinaryForm R n)) :
+    pushForm f n (m • P) = m • pushForm f n P :=
+  map_zsmul (⟨⟨pushForm f n, pushForm_zero f n⟩, pushForm_add f n⟩ : ↥(BinaryForm R n) →+
+    ↥(BinaryForm R' n)) m P
+
+end HeckeEis.RatAux
+end
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff IsParabolicCocycle \
+  coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff \
+  coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero"
+namespace RatAux
+p2m_open "HeckeEis"
+
+open MvPolynomial HeckeEis.CoeffMapAux CongruenceSubgroup
+open scoped MatrixGroups
+
+theorem injective_of_clause (n N : ℕ) [NeZero N]
+    (Φ : coeffH1par ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype) →+ coeffH1par ((binaryFormRepSL
+      ℚ n).comp (Gamma0 N).subtype))
+    (hΦ : ∀ z : ↥(coeffParabolicCocycles ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype)),
+      ∃ w : ↥(coeffParabolicCocycles ((binaryFormRepSL ℚ n).comp (Gamma0 N).subtype)),
+        (∀ g : Gamma0 N, ((w : Gamma0 N → ↥(BinaryForm ℚ n)) g : MvPolynomial (Fin 2) ℚ)
+            = MvPolynomial.map (Int.castRingHom ℚ) (((z : Gamma0 N → ↥(BinaryForm ℤ n)) g :
+              MvPolynomial (Fin 2) ℤ))) ∧
+        Φ (coeffH1parMk _ z) = coeffH1parMk _ w) :
+    Function.Injective Φ := by
+  classical
+  refine (injective_iff_map_eq_zero Φ).mpr fun x hx => ?_
+  obtain ⟨y, rfl⟩ := coeffH1parMk_surjective _ x
+  obtain ⟨w, hw, hΦw⟩ := hΦ y
+  rw [hΦw, coeffH1parMk_eq_zero_iff] at hx
+  obtain ⟨v, hv⟩ := (mem_coeffCoboundaries_iff _ _).mp hx
+  have hwy : ∀ g, (w : Gamma0 N → ↥(BinaryForm ℚ n)) g = pushForm ιZQ n ((y : Gamma0 N →
+    ↥(BinaryForm ℤ n)) g) :=
+    fun g =>
+    Subtype.ext (by rw [hw g, coe_pushForm_ι])
+  obtain ⟨D, hD, hDv⟩ := exists_isInt_zsmul (v : MvPolynomial (Fin 2) ℚ)
+  obtain ⟨v', hv'⟩ :=
+    exists_eq_pushForm_of_isInt n (Q := D • v) (by simpa [Submodule.coe_smul] using hDv)
+  have hcob : (D • (y : Gamma0 N → ↥(BinaryForm ℤ n))) ∈ coeffCoboundaries ((binaryFormRepSL ℤ
+    n).comp (Gamma0 N).subtype) :=
+    by
+    rw [mem_coeffCoboundaries_iff]
+    refine ⟨v', funext fun g => pushForm_ι_injective n ?_⟩
+    have h1 := congrFun hv g
+    change binaryFormRepSL ℚ n (g : SL(2, ℤ)) v - v = (w : Gamma0 N → ↥(BinaryForm ℚ n)) g at h1
+    change pushForm ιZQ n (binaryFormRepSL ℤ n (g : SL(2, ℤ)) v' - v') = pushForm ιZQ n ((D • (y :
+      Gamma0 N → ↥(BinaryForm ℤ n))) g)
+    rw [pushForm_sub, pushForm_binaryFormRepSL, hv', map_zsmul, ← zsmul_sub, h1, hwy g,
+      Pi.smul_apply, pushForm_zsmul]
+  have h2 : coeffH1parMk ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype) (D • y) = 0 := by
+    rw [coeffH1parMk_eq_zero_iff]
+    simpa [Submodule.coe_smul] using hcob
+  rw [map_smul] at h2
+  exact HeckeEis.coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero n N D hD _ h2
+
+end HeckeEis.RatAux
+end
+
+open scoped MatrixGroups in
+theorem solution (n N : ℕ) [NeZero N]
+    (Φ : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℤ n).comp (CongruenceSubgroup.Gamma0
+      N).subtype) →+ HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℚ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype))
+    (hΦ : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℤ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℚ n).comp
+        (CongruenceSubgroup.Gamma0 N).subtype)),
+        (∀ g : CongruenceSubgroup.Gamma0 N, ((w : CongruenceSubgroup.Gamma0 N →
+          ↥(HeckeEis.BinaryForm ℚ n)) g : MvPolynomial (Fin 2) ℚ)
+            = MvPolynomial.map (Int.castRingHom ℚ)
+                (((z : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℤ n)) g : MvPolynomial
+                  (Fin 2) ℤ))) ∧
+        Φ (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w) :
+    Function.Injective Φ :=
+  HeckeEis.RatAux.injective_of_clause n N Φ hΦ
+
+end S_HeckeEis_coeffH1par_map_int_rat_injective
+end P2MW
+export P2MW.S_HeckeEis_coeffH1par_map_int_rat_injective (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.coeffH1par_map_int_rat_injective (n N : ℕ) [NeZero N]
+    (Φ : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℤ n).comp (CongruenceSubgroup.Gamma0
+      N).subtype) →+ HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℚ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype))
+    (hΦ : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℤ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℚ n).comp
+        (CongruenceSubgroup.Gamma0 N).subtype)),
+        (∀ g : CongruenceSubgroup.Gamma0 N, ((w : CongruenceSubgroup.Gamma0 N →
+          ↥(HeckeEis.BinaryForm ℚ n)) g : MvPolynomial (Fin 2) ℚ)
+            = MvPolynomial.map (Int.castRingHom ℚ)
+                (((z : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℤ n)) g : MvPolynomial
+                  (Fin 2) ℤ))) ∧
+        Φ (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w) :
+    Function.Injective Φ :=
+  solution n N Φ hΦ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeffHeckeFun_mem_coeffCoboundaries.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeffHeckeFun_mem_coeffCoboundaries.lean
new file mode 100644
index 0000000000..1d0cfd8e6a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeffHeckeFun_mem_coeffCoboundaries.lean
@@ -0,0 +1,232 @@
+/-
+Copyright (c) 2026 Lean Pool contributors. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Lean Pool contributors
+-/
+
+/-
+Based on Prove2Me node HeckeEis.coeffHeckeFun_mem_coeffCoboundaries
+(7e920852-4d0d-5756-925e-21e268c92631) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ef4c7cb3-2936-51c4-953d-94be9ec44797
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0HeckeOperatorHom
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cochain Hecke operator preserves coefficient coboundaries
+
+Let $N,\ell$ be natural numbers with $\ell\neq 0$, let $K$ be a commutative ring, $V$ a $K$-module,
+and let $\rho$ be a $K$-linear representation of $\Gamma_0(N)$ on $V$. Write $U=$
+[`HeckeEis.heckeUpper N ℓ`](def/Gamma0HeckeOperatorHom.html#L128) for the subgroup of $\Gamma_0(N)$
+consisting of those matrices $g$ with $\ell \mid g_{01}$, and let [`HeckeEis.heckeConj N
+ℓ`](def/Gamma0HeckeOperatorHom.html#L172) be the group homomorphism $U\to\Gamma_0(N)$ sending
+$g=\begin{pmatrix}a&b\\c&d\end{pmatrix}$ to $\begin{pmatrix}a&b/\ell\\ c\ell&d\end{pmatrix}$, i.e.
+conjugation by $\mathrm{diag}(1,\ell)$. Let $a\colon V\to V$ be $K$-linear and assume
+$a\circ\rho(\mathrm{heckeConj}(u))=\rho(u)\circ a$ for every $u\in U$. Let $z\colon\Gamma_0(N)\to V$
+lie in [`HeckeEis.coeffCoboundaries ρ`](def/Gamma0CoeffCohomology.html#L45), the image of the linear
+map $v\mapsto (g\mapsto \rho(g)v-v)$; that is, $z(g)=\rho(g)v-v$ for some $v\in V$. The conclusion
+is that the function
+$$g\longmapsto \sum_{q\in\Gamma_0(N)/U}\rho\bigl(\overline{g\cdot
+q}\bigr)\,a\bigl(z\bigl(\mathrm{heckeConj}(\overline{g\cdot q}^{-1}\,g\,\overline q)\bigr)\bigr),$$
+where $\overline{\,\cdot\,}$ denotes the chosen representative of a coset and the finite sum is over
+the (finite-index) quotient $\Gamma_0(N)/U$, again lies in [`HeckeEis.coeffCoboundaries
+ρ`](def/Gamma0CoeffCohomology.html#L45).
+
+This is the statement that the cochain-level Hecke operator $T_\ell$ on $V$-valued functions on
+$\Gamma_0(N)$, built from a double-coset decomposition together with an intertwining endomorphism
+$a$ of the coefficient module, carries $1$-coboundaries to $1$-coboundaries. Together with the
+companion statement for cocycles it allows $T_\ell$ to be defined on $H^1(\Gamma_0(N),\rho)$, and it
+is used by the subsequent results on Hecke-equivariant maps to and from coefficient cohomology.
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/Theorems/Thm_HeckeEis_coeffHeckeFun_mem_coeffCoboundaries.lean
+
+Prove2Me submission: `ef4c7cb3-2936-51c4-953d-94be9ec44797` (ACCEPTED).
+-/
+
+section privateSection
+
+
+namespace P2MW.S_HeckeEis_coeffHeckeFun_mem_coeffCoboundaries
+
+open scoped MatrixGroups
+
+namespace HeckeEis
+p2m_export "HeckeEis"
+  "heckeUpper heckeConj transferAux coe_transferAux transferAux_mul coeffCocycles \
+    coeffCoboundaryMap_apply coeffCoboundaries coeffHeckeFun coeffHeckeFun_apply"
+p2m_open "HeckeEis"
+namespace Sh2
+open CongruenceSubgroup
+open scoped MatrixGroups
+
+variable (N ℓ : ℕ) [NeZero ℓ]
+  {K : Type*} [CommRing K] {V : Type*} [AddCommGroup V] [Module K V]
+  (ρ : Representation K (Gamma0 N) V) (a : V →ₗ[K] V)
+  (ha : ∀ u : ↥(heckeUpper N ℓ), a ∘ₗ ρ (heckeConj N ℓ u) = ρ (u : Gamma0 N) ∘ₗ a)
+
+local notation "U" => heckeUpper N ℓ
+local notation "c" => heckeConj N ℓ
+
+include ha in
+theorem ha_apply (u : ↥U) (v : V) : a (ρ (c u) v) = ρ (u : Gamma0 N) (a v) := by
+  have := LinearMap.congr_fun (ha u) v
+  simpa using this
+
+theorem cocycle_one {z : Gamma0 N → V} (hz : z ∈ coeffCocycles ρ) : z 1 = 0 := by
+  have h := hz 1 1
+  rw [mul_one, map_one, Module.End.one_apply] at h
+  have : z 1 + z 1 = z 1 + 0 := by rw [add_zero]; exact h.symm
+  exact add_left_cancel this
+
+theorem cocycle_map_inv {z : Gamma0 N → V} (hz : z ∈ coeffCocycles ρ) (x : ↥U) :
+    z (c x⁻¹) = -(ρ (c x⁻¹) (z (c x))) := by
+  have h1 : z (c x⁻¹ * c x) = z (c x⁻¹) + ρ (c x⁻¹) (z (c x)) := hz _ _
+  rw [← map_mul, inv_mul_cancel, map_one, cocycle_one N ρ hz] at h1
+  exact eq_neg_of_add_eq_zero_left h1.symm
+
+omit [NeZero ℓ] in
+theorem out_mul_transferAux (g : Gamma0 N) (q : Gamma0 N ⧸ U) :
+    (g • q).out * (transferAux U g q : Gamma0 N) = g * q.out := by
+  rw [coe_transferAux, mul_inv_cancel_left]
+
+include ha in
+theorem mem_coeffCocycles {z : Gamma0 N → V} (hz : z ∈ coeffCocycles ρ) :
+    coeffHeckeFun N ℓ ρ a z ∈ coeffCocycles ρ := by
+  let := (heckeUpper N ℓ).fintypeQuotientOfFiniteIndex
+  intro g h
+  simp only [coeffHeckeFun_apply]
+  have key : ∀ q : Gamma0 N ⧸ U,
+      ρ ((g * h) • q).out (a (z (c (transferAux U (g * h) q))))
+        = ρ (g • (h • q)).out (a (z (c (transferAux U g (h • q)))))
+          + ρ g (ρ (h • q).out (a (z (c (transferAux U h q))))) := by
+    intro q
+    rw [transferAux_mul, map_mul, hz, map_add, map_add, mul_smul]
+    congr 1
+    rw [ha_apply N ℓ ρ a ha, ← Module.End.mul_apply, ← map_mul, out_mul_transferAux, map_mul,
+      Module.End.mul_apply]
+  rw [Finset.sum_congr rfl fun q _ => key q, Finset.sum_add_distrib, map_sum]
+  congr 1
+  exact Fintype.sum_bijective (h • ·) (MulAction.bijective h) _ _ fun q => rfl
+
+include ha in
+theorem mem_coeffCoboundaries {z : Gamma0 N → V} (hz : z ∈ coeffCoboundaries ρ) :
+    coeffHeckeFun N ℓ ρ a z ∈ coeffCoboundaries ρ := by
+  let := (heckeUpper N ℓ).fintypeQuotientOfFiniteIndex
+  obtain ⟨v, rfl⟩ := hz
+  refine ⟨∑ q : Gamma0 N ⧸ U, ρ q.out (a v), ?_⟩
+  funext g
+  simp only [coeffCoboundaryMap_apply, coeffHeckeFun_apply, map_sub, map_sum,
+    Finset.sum_sub_distrib]
+  congr 1
+  · refine Finset.sum_congr rfl fun q _ => ?_
+    simp only [ha_apply N ℓ ρ a ha]
+    rw [← Module.End.mul_apply (ρ (g • q).out) (ρ _), ← map_mul, out_mul_transferAux, map_mul,
+      Module.End.mul_apply]
+  · exact (Fintype.sum_bijective (g • ·) (MulAction.bijective g)
+      (fun q : Gamma0 N ⧸ U => ρ (g • q).out (a v)) (fun q : Gamma0 N ⧸ U => ρ q.out (a v)) fun q =>
+        rfl).symm
+
+include ha in
+theorem sum_repr_sub_mem_coeffCoboundaries
+    (s : Gamma0 N ⧸ U → Gamma0 N) (t : Gamma0 N → Gamma0 N ⧸ U → ↥U)
+    (hs : ∀ q, (s q : Gamma0 N ⧸ U) = q)
+    (hst : ∀ g q, s (g • q) * (t g q : Gamma0 N) = g * s q)
+    {z : Gamma0 N → V} (hz : z ∈ coeffCocycles ρ) :
+    (fun g => let := (heckeUpper N ℓ).fintypeQuotientOfFiniteIndex
+        ∑ q : Gamma0 N ⧸ U, ρ (s (g • q)) (a (z (c (t g q)))))
+      - coeffHeckeFun N ℓ ρ a z ∈ coeffCoboundaries ρ := by
+  let := (heckeUpper N ℓ).fintypeQuotientOfFiniteIndex
+  have hu_mem : ∀ q : Gamma0 N ⧸ U, (q.out)⁻¹ * s q ∈ U := fun q =>
+    QuotientGroup.eq.mp ((QuotientGroup.out_eq' q).trans (hs q).symm)
+  have hex : ∀ q : Gamma0 N ⧸ U, ∃ uq : ↥U, s q = q.out * (uq : Gamma0 N) := fun q =>
+    ⟨⟨_, hu_mem q⟩, by rw [Subgroup.coe_mk, mul_inv_cancel_left]⟩
+  choose u hsq using hex
+  have ht : ∀ g q, t g q = (u (g • q))⁻¹ * transferAux U g q * u q := by
+    intro g q
+    apply Subtype.ext
+    have h1 := hst g q
+    rw [hsq, hsq] at h1
+    push_cast [coe_transferAux]
+    calc ((t g q : ↥U) : Gamma0 N)
+        = ((g • q).out * ↑(u (g • q)))⁻¹ * (((g • q).out * ↑(u (g • q))) * ↑(t g q)) := by group
+      _ = ((g • q).out * ↑(u (g • q)))⁻¹ * (g * (q.out * ↑(u q))) := by rw [h1]
+      _ = (↑(u (g • q)))⁻¹ * ((g • q).out⁻¹ * (g * q.out)) * ↑(u q) := by group
+  set F : V := ∑ q : Gamma0 N ⧸ U, ρ q.out (a (z (c (u q)))) with hF
+  refine ⟨F, ?_⟩
+  funext g
+  simp only [coeffCoboundaryMap_apply, Pi.sub_apply, coeffHeckeFun_apply]
+  have key : ∀ q : Gamma0 N ⧸ U,
+      ρ (s (g • q)) (a (z (c (t g q))))
+        = -(ρ (g • q).out (a (z (c (u (g • q))))))
+          + ρ (g • q).out (a (z (c (transferAux U g q))))
+          + ρ g (ρ q.out (a (z (c (u q))))) := by
+    intro q
+    rw [hsq (g • q), ht g q, map_mul c, map_mul c,
+      hz (c (u (g • q))⁻¹ * c (transferAux U g q)) (c (u q)),
+      hz (c (u (g • q))⁻¹) (c (transferAux U g q)),
+      cocycle_map_inv N ℓ ρ hz (u (g • q)), ← map_mul c]
+    simp only [map_add, map_neg, ha_apply N ℓ ρ a ha]
+    have e12 : ∀ v : V, ρ ((g • q).out * ((u (g • q) : ↥U) : Gamma0 N)) (ρ (((u (g • q))⁻¹ : ↥U) :
+      Gamma0 N) v)
+        = ρ (g • q).out v := by
+      intro v
+      rw [← Module.End.mul_apply, ← map_mul, Subgroup.coe_inv, mul_inv_cancel_right]
+    have e3 : ∀ v : V, ρ ((g • q).out * ((u (g • q) : ↥U) : Gamma0 N))
+        (ρ (((u (g • q))⁻¹ * transferAux U g q : ↥U) : Gamma0 N) v) = ρ g (ρ q.out v) := by
+      intro v
+      rw [← Module.End.mul_apply, ← map_mul, ← Module.End.mul_apply, ← map_mul]
+      congr 2
+      rw [Subgroup.coe_mul, Subgroup.coe_inv, ← out_mul_transferAux N ℓ g q]
+      group
+    rw [e12, e12, e3]
+  rw [Finset.sum_congr rfl fun q _ => key q, Finset.sum_add_distrib, Finset.sum_add_distrib,
+    Finset.sum_neg_distrib, ← map_sum]
+  have hre : ∑ q : Gamma0 N ⧸ U, ρ (g • q).out (a (z (c (u (g • q))))) = F :=
+    Fintype.sum_bijective (g • ·) (MulAction.bijective g) _ _ fun q => rfl
+  rw [hre]
+  abel
+
+end Sh2
+end HeckeEis
+
+theorem solution (N ℓ : ℕ) [NeZero ℓ]
+    {K : Type*} [CommRing K] {V : Type*} [AddCommGroup V] [Module K V]
+    (ρ : Representation K (CongruenceSubgroup.Gamma0 N) V) (a : V →ₗ[K] V)
+    (ha : ∀ u : ↥(HeckeEis.heckeUpper N ℓ),
+      a ∘ₗ ρ (HeckeEis.heckeConj N ℓ u) = ρ (u : CongruenceSubgroup.Gamma0 N) ∘ₗ a)
+    {z : CongruenceSubgroup.Gamma0 N → V} (hz : z ∈ HeckeEis.coeffCoboundaries ρ) :
+    HeckeEis.coeffHeckeFun N ℓ ρ a z ∈ HeckeEis.coeffCoboundaries ρ :=
+  HeckeEis.Sh2.mem_coeffCoboundaries N ℓ ρ a ha hz
+
+end S_HeckeEis_coeffHeckeFun_mem_coeffCoboundaries
+end P2MW
+export P2MW.S_HeckeEis_coeffHeckeFun_mem_coeffCoboundaries (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+
+theorem HeckeEis.coeffHeckeFun_mem_coeffCoboundaries (N ℓ : ℕ) [NeZero ℓ]
+    {K : Type*} [CommRing K] {V : Type*} [AddCommGroup V] [Module K V]
+    (ρ : Representation K (CongruenceSubgroup.Gamma0 N) V) (a : V →ₗ[K] V)
+    (ha : ∀ u : ↥(HeckeEis.heckeUpper N ℓ),
+      a ∘ₗ ρ (HeckeEis.heckeConj N ℓ u) = ρ (u : CongruenceSubgroup.Gamma0 N) ∘ₗ a)
+    {z : CongruenceSubgroup.Gamma0 N → V} (hz : z ∈ HeckeEis.coeffCoboundaries ρ) :
+    HeckeEis.coeffHeckeFun N ℓ ρ a z ∈ HeckeEis.coeffCoboundaries ρ :=
+      _root_.P2MW.S_HeckeEis_coeffHeckeFun_mem_coeffCoboundaries.solution N ℓ ρ a ha hz
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeffHeckeFun_mem_coeffCocycles.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeffHeckeFun_mem_coeffCocycles.lean
new file mode 100644
index 0000000000..de080caa16
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeffHeckeFun_mem_coeffCocycles.lean
@@ -0,0 +1,231 @@
+/-
+Copyright (c) 2026 Lean Pool contributors. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Lean Pool contributors
+-/
+
+/-
+Based on Prove2Me node HeckeEis.coeffHeckeFun_mem_coeffCocycles
+(ef9163d8-d772-5478-b82b-14a7128aa783) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ed472e60-a50b-5947-81a9-5baea7bf6ab1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0HeckeOperatorHom
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cochain-level Hecke operator preserves 1-cocycles
+
+Fix natural numbers $N$ and $\ell$ with $\ell \neq 0$, a commutative ring $K$, a $K$-module $V$, and
+a representation $\rho$ of the congruence subgroup $\Gamma_0(N)$ on $V$ over $K$. Write $U =$
+[`HeckeEis.heckeUpper N ℓ`](def/Gamma0HeckeOperatorHom.html#L128) for the subgroup of $\Gamma_0(N)$
+consisting of those elements whose upper-right entry is divisible by $\ell$, and $c =$
+[`HeckeEis.heckeConj N ℓ`](def/Gamma0HeckeOperatorHom.html#L172) for the group homomorphism $U \to
+\Gamma_0(N)$ sending a matrix $\begin{pmatrix} \alpha & \beta \\ \gamma & \delta\end{pmatrix}$ in
+$U$ to $\begin{pmatrix} \alpha & \beta/\ell \\ \gamma\ell & \delta\end{pmatrix}$. Let $a : V \to V$
+be $K$-linear and assume the equivariance $a \circ \rho(c(u)) = \rho(u) \circ a$ for every $u \in
+U$. Let $z : \Gamma_0(N) \to V$ satisfy the inhomogeneous $1$-cocycle identity $z(gh) = z(g) +
+\rho(g)(z(h))$ for all $g, h \in \Gamma_0(N)$. The conclusion is that the function $g \mapsto
+\sum_{q \in \Gamma_0(N)/U} \rho\bigl(\overline{g \cdot
+q}\bigr)\bigl(a\bigl(z\bigl(c(\overline{g\cdot q}^{-1} g \overline{q})\bigr)\bigr)\bigr)$, the sum
+being over the coset space $\Gamma_0(N)/U$ and $\overline{q}$ denoting the chosen representative of
+a coset $q$, again satisfies the same $1$-cocycle identity.
+
+This is the $1$-cocycle level construction of the double-coset Hecke operator $T_\ell$ (restriction
+to $U$, twist by the conjugation $c$ and the intertwiner $a$, then corestriction back to
+$\Gamma_0(N)$) on inhomogeneous cochains with coefficients in an arbitrary representation. It is the
+cocycle half of the input needed to induce $T_\ell$ on $H^1$ and on parabolic cohomology, and is
+cited by the companion statements about coboundaries, parabolic cocycles and the resulting
+Hecke-equivariant maps on $H^1$.
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/Theorems/Thm_HeckeEis_coeffHeckeFun_mem_coeffCocycles.lean
+
+Prove2Me submission: `ed472e60-a50b-5947-81a9-5baea7bf6ab1` (ACCEPTED).
+-/
+
+section privateSection
+
+
+namespace P2MW.S_HeckeEis_coeffHeckeFun_mem_coeffCocycles
+
+open scoped MatrixGroups
+
+namespace HeckeEis
+p2m_export "HeckeEis"
+  "heckeUpper heckeConj transferAux coe_transferAux transferAux_mul coeffCocycles \
+    coeffCoboundaryMap_apply coeffCoboundaries coeffHeckeFun coeffHeckeFun_apply"
+p2m_open "HeckeEis"
+namespace Sh2
+open CongruenceSubgroup
+open scoped MatrixGroups
+
+variable (N ℓ : ℕ) [NeZero ℓ]
+  {K : Type*} [CommRing K] {V : Type*} [AddCommGroup V] [Module K V]
+  (ρ : Representation K (Gamma0 N) V) (a : V →ₗ[K] V)
+  (ha : ∀ u : ↥(heckeUpper N ℓ), a ∘ₗ ρ (heckeConj N ℓ u) = ρ (u : Gamma0 N) ∘ₗ a)
+
+local notation "U" => heckeUpper N ℓ
+local notation "c" => heckeConj N ℓ
+
+include ha in
+theorem ha_apply (u : ↥U) (v : V) : a (ρ (c u) v) = ρ (u : Gamma0 N) (a v) := by
+  have := LinearMap.congr_fun (ha u) v
+  simpa using this
+
+theorem cocycle_one {z : Gamma0 N → V} (hz : z ∈ coeffCocycles ρ) : z 1 = 0 := by
+  have h := hz 1 1
+  rw [mul_one, map_one, Module.End.one_apply] at h
+  have : z 1 + z 1 = z 1 + 0 := by rw [add_zero]; exact h.symm
+  exact add_left_cancel this
+
+theorem cocycle_map_inv {z : Gamma0 N → V} (hz : z ∈ coeffCocycles ρ) (x : ↥U) :
+    z (c x⁻¹) = -(ρ (c x⁻¹) (z (c x))) := by
+  have h1 : z (c x⁻¹ * c x) = z (c x⁻¹) + ρ (c x⁻¹) (z (c x)) := hz _ _
+  rw [← map_mul, inv_mul_cancel, map_one, cocycle_one N ρ hz] at h1
+  exact eq_neg_of_add_eq_zero_left h1.symm
+
+omit [NeZero ℓ] in
+theorem out_mul_transferAux (g : Gamma0 N) (q : Gamma0 N ⧸ U) :
+    (g • q).out * (transferAux U g q : Gamma0 N) = g * q.out := by
+  rw [coe_transferAux, mul_inv_cancel_left]
+
+include ha in
+theorem mem_coeffCocycles {z : Gamma0 N → V} (hz : z ∈ coeffCocycles ρ) :
+    coeffHeckeFun N ℓ ρ a z ∈ coeffCocycles ρ := by
+  let := (heckeUpper N ℓ).fintypeQuotientOfFiniteIndex
+  intro g h
+  simp only [coeffHeckeFun_apply]
+  have key : ∀ q : Gamma0 N ⧸ U,
+      ρ ((g * h) • q).out (a (z (c (transferAux U (g * h) q))))
+        = ρ (g • (h • q)).out (a (z (c (transferAux U g (h • q)))))
+          + ρ g (ρ (h • q).out (a (z (c (transferAux U h q))))) := by
+    intro q
+    rw [transferAux_mul, map_mul, hz, map_add, map_add, mul_smul]
+    congr 1
+    rw [ha_apply N ℓ ρ a ha, ← Module.End.mul_apply, ← map_mul, out_mul_transferAux, map_mul,
+      Module.End.mul_apply]
+  rw [Finset.sum_congr rfl fun q _ => key q, Finset.sum_add_distrib, map_sum]
+  congr 1
+  exact Fintype.sum_bijective (h • ·) (MulAction.bijective h) _ _ fun q => rfl
+
+include ha in
+theorem mem_coeffCoboundaries {z : Gamma0 N → V} (hz : z ∈ coeffCoboundaries ρ) :
+    coeffHeckeFun N ℓ ρ a z ∈ coeffCoboundaries ρ := by
+  let := (heckeUpper N ℓ).fintypeQuotientOfFiniteIndex
+  obtain ⟨v, rfl⟩ := hz
+  refine ⟨∑ q : Gamma0 N ⧸ U, ρ q.out (a v), ?_⟩
+  funext g
+  simp only [coeffCoboundaryMap_apply, coeffHeckeFun_apply, map_sub, map_sum,
+    Finset.sum_sub_distrib]
+  congr 1
+  · refine Finset.sum_congr rfl fun q _ => ?_
+    simp only [ha_apply N ℓ ρ a ha]
+    rw [← Module.End.mul_apply (ρ (g • q).out) (ρ _), ← map_mul, out_mul_transferAux, map_mul,
+      Module.End.mul_apply]
+  · exact (Fintype.sum_bijective (g • ·) (MulAction.bijective g)
+      (fun q : Gamma0 N ⧸ U => ρ (g • q).out (a v)) (fun q : Gamma0 N ⧸ U => ρ q.out (a v)) fun q =>
+        rfl).symm
+
+include ha in
+theorem sum_repr_sub_mem_coeffCoboundaries
+    (s : Gamma0 N ⧸ U → Gamma0 N) (t : Gamma0 N → Gamma0 N ⧸ U → ↥U)
+    (hs : ∀ q, (s q : Gamma0 N ⧸ U) = q)
+    (hst : ∀ g q, s (g • q) * (t g q : Gamma0 N) = g * s q)
+    {z : Gamma0 N → V} (hz : z ∈ coeffCocycles ρ) :
+    (fun g => let := (heckeUpper N ℓ).fintypeQuotientOfFiniteIndex
+        ∑ q : Gamma0 N ⧸ U, ρ (s (g • q)) (a (z (c (t g q)))))
+      - coeffHeckeFun N ℓ ρ a z ∈ coeffCoboundaries ρ := by
+  let := (heckeUpper N ℓ).fintypeQuotientOfFiniteIndex
+  have hu_mem : ∀ q : Gamma0 N ⧸ U, (q.out)⁻¹ * s q ∈ U := fun q =>
+    QuotientGroup.eq.mp ((QuotientGroup.out_eq' q).trans (hs q).symm)
+  have hex : ∀ q : Gamma0 N ⧸ U, ∃ uq : ↥U, s q = q.out * (uq : Gamma0 N) := fun q =>
+    ⟨⟨_, hu_mem q⟩, by rw [Subgroup.coe_mk, mul_inv_cancel_left]⟩
+  choose u hsq using hex
+  have ht : ∀ g q, t g q = (u (g • q))⁻¹ * transferAux U g q * u q := by
+    intro g q
+    apply Subtype.ext
+    have h1 := hst g q
+    rw [hsq, hsq] at h1
+    push_cast [coe_transferAux]
+    calc ((t g q : ↥U) : Gamma0 N)
+        = ((g • q).out * ↑(u (g • q)))⁻¹ * (((g • q).out * ↑(u (g • q))) * ↑(t g q)) := by group
+      _ = ((g • q).out * ↑(u (g • q)))⁻¹ * (g * (q.out * ↑(u q))) := by rw [h1]
+      _ = (↑(u (g • q)))⁻¹ * ((g • q).out⁻¹ * (g * q.out)) * ↑(u q) := by group
+  set F : V := ∑ q : Gamma0 N ⧸ U, ρ q.out (a (z (c (u q)))) with hF
+  refine ⟨F, ?_⟩
+  funext g
+  simp only [coeffCoboundaryMap_apply, Pi.sub_apply, coeffHeckeFun_apply]
+  have key : ∀ q : Gamma0 N ⧸ U,
+      ρ (s (g • q)) (a (z (c (t g q))))
+        = -(ρ (g • q).out (a (z (c (u (g • q))))))
+          + ρ (g • q).out (a (z (c (transferAux U g q))))
+          + ρ g (ρ q.out (a (z (c (u q))))) := by
+    intro q
+    rw [hsq (g • q), ht g q, map_mul c, map_mul c,
+      hz (c (u (g • q))⁻¹ * c (transferAux U g q)) (c (u q)),
+      hz (c (u (g • q))⁻¹) (c (transferAux U g q)),
+      cocycle_map_inv N ℓ ρ hz (u (g • q)), ← map_mul c]
+    simp only [map_add, map_neg, ha_apply N ℓ ρ a ha]
+    have e12 : ∀ v : V, ρ ((g • q).out * ((u (g • q) : ↥U) : Gamma0 N)) (ρ (((u (g • q))⁻¹ : ↥U) :
+      Gamma0 N) v)
+        = ρ (g • q).out v := by
+      intro v
+      rw [← Module.End.mul_apply, ← map_mul, Subgroup.coe_inv, mul_inv_cancel_right]
+    have e3 : ∀ v : V, ρ ((g • q).out * ((u (g • q) : ↥U) : Gamma0 N))
+        (ρ (((u (g • q))⁻¹ * transferAux U g q : ↥U) : Gamma0 N) v) = ρ g (ρ q.out v) := by
+      intro v
+      rw [← Module.End.mul_apply, ← map_mul, ← Module.End.mul_apply, ← map_mul]
+      congr 2
+      rw [Subgroup.coe_mul, Subgroup.coe_inv, ← out_mul_transferAux N ℓ g q]
+      group
+    rw [e12, e12, e3]
+  rw [Finset.sum_congr rfl fun q _ => key q, Finset.sum_add_distrib, Finset.sum_add_distrib,
+    Finset.sum_neg_distrib, ← map_sum]
+  have hre : ∑ q : Gamma0 N ⧸ U, ρ (g • q).out (a (z (c (u (g • q))))) = F :=
+    Fintype.sum_bijective (g • ·) (MulAction.bijective g) _ _ fun q => rfl
+  rw [hre]
+  abel
+
+end Sh2
+end HeckeEis
+
+theorem solution (N ℓ : ℕ) [NeZero ℓ]
+    {K : Type*} [CommRing K] {V : Type*} [AddCommGroup V] [Module K V]
+    (ρ : Representation K (CongruenceSubgroup.Gamma0 N) V) (a : V →ₗ[K] V)
+    (ha : ∀ u : ↥(HeckeEis.heckeUpper N ℓ),
+      a ∘ₗ ρ (HeckeEis.heckeConj N ℓ u) = ρ (u : CongruenceSubgroup.Gamma0 N) ∘ₗ a)
+    {z : CongruenceSubgroup.Gamma0 N → V} (hz : z ∈ HeckeEis.coeffCocycles ρ) :
+    HeckeEis.coeffHeckeFun N ℓ ρ a z ∈ HeckeEis.coeffCocycles ρ :=
+  HeckeEis.Sh2.mem_coeffCocycles N ℓ ρ a ha hz
+
+end S_HeckeEis_coeffHeckeFun_mem_coeffCocycles
+end P2MW
+export P2MW.S_HeckeEis_coeffHeckeFun_mem_coeffCocycles (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+
+theorem HeckeEis.coeffHeckeFun_mem_coeffCocycles (N ℓ : ℕ) [NeZero ℓ]
+    {K : Type*} [CommRing K] {V : Type*} [AddCommGroup V] [Module K V]
+    (ρ : Representation K (CongruenceSubgroup.Gamma0 N) V) (a : V →ₗ[K] V)
+    (ha : ∀ u : ↥(HeckeEis.heckeUpper N ℓ),
+      a ∘ₗ ρ (HeckeEis.heckeConj N ℓ u) = ρ (u : CongruenceSubgroup.Gamma0 N) ∘ₗ a)
+    {z : CongruenceSubgroup.Gamma0 N → V} (hz : z ∈ HeckeEis.coeffCocycles ρ) :
+    HeckeEis.coeffHeckeFun N ℓ ρ a z ∈ HeckeEis.coeffCocycles ρ :=
+      _root_.P2MW.S_HeckeEis_coeffHeckeFun_mem_coeffCocycles.solution N ℓ ρ a ha hz
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeffHeckeFun_mem_coeffParabolicCocycles.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeffHeckeFun_mem_coeffParabolicCocycles.lean
new file mode 100644
index 0000000000..e430db66ce
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeffHeckeFun_mem_coeffParabolicCocycles.lean
@@ -0,0 +1,323 @@
+/-
+Copyright (c) 2026 Lean Pool contributors. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Lean Pool contributors
+-/
+
+/-
+Based on Prove2Me node HeckeEis.coeffHeckeFun_mem_coeffParabolicCocycles
+(600d226f-3cc9-5bc7-917a-bc0a0e9e5854) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a1c720ca-353d-5914-9331-55d4d08f3909
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0HeckeOperatorHom
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+
+import Mathlib.LinearAlgebra.Matrix.Adjugate
+import Mathlib.LinearAlgebra.Matrix.Trace
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Function_exists_eq_apply_sub_of_sum_range_minimalPeriod_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_coeffHeckeFun_mem_coeffCocycles
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Hecke operator preserves parabolic cocycles with coefficients
+
+Let $N$ and $\ell$ be natural numbers with $\ell \neq 0$, let $K$ be a commutative ring, let $V$ be
+a $K$-module and let $\rho$ be a $K$-linear representation of $\Gamma_0(N) \le
+\mathrm{SL}(2,\mathbb{Z})$ on $V$. Write $\mathrm{heckeUpper}\,N\,\ell$ for the subgroup of
+$\Gamma_0(N)$ consisting of those matrices whose upper right entry is divisible by $\ell$, and
+$\mathrm{heckeConj}\,N\,\ell$ for the homomorphism from it to $\Gamma_0(N)$ sending $g$ to
+$!![g_{00}, g_{01}/\ell; \ell\, g_{10}, g_{11}]$, i.e. conjugation by $\mathrm{diag}(1,\ell)$. Let
+$a : V \to V$ be $K$-linear and assume $a \circ \rho(\mathrm{heckeConj}\,N\,\ell\,u) = \rho(u) \circ
+a$ for every $u \in \mathrm{heckeUpper}\,N\,\ell$. Let $z : \Gamma_0(N) \to V$ be a parabolic
+$1$-cocycle, that is: $z(gh) = z(g) + \rho(g)(z(h))$ for all $g,h$, and $z(\gamma) \in
+\mathrm{range}(\rho(\gamma) - 1)$ for every $\gamma \in \Gamma_0(N)$ whose underlying integral
+matrix satisfies $(\operatorname{tr}\gamma)^2 = 4$. Then the function
+$\mathrm{coeffHeckeFun}\,N\,\ell\,\rho\,a\,z$, whose value at $g$ is the sum over the (finitely
+many) cosets $q \in \Gamma_0(N)/\mathrm{heckeUpper}\,N\,\ell$ of $\rho((g \cdot
+q)^{\mathrm{out}})\bigl(a\bigl(z(\mathrm{heckeConj}\,N\,\ell\,((g\cdot q)^{\mathrm{out}})^{-1} g\,
+q^{\mathrm{out}})\bigr)\bigr)$ with $q^{\mathrm{out}}$ the chosen coset representative, is again a
+parabolic $1$-cocycle.
+
+This is the cochain-level statement that the Hecke correspondence at $\ell$, with coefficients
+twisted by the intertwining map $a$, acts on parabolic cocycles of $\Gamma_0(N)$, so that it
+descends to parabolic cohomology; the underlying cocycle property alone is
+[`HeckeEis.coeffHeckeFun_mem_coeffCocycles`](thm.html#HeckeEis.coeffHeckeFun_mem_coeffCocycles), and
+the content added here is the parabolicity condition at elements of trace $\pm 2$. It is used in the
+construction of the Hecke action on $H^1_{\mathrm{par}}$ and in the passage from eigensystems in
+cohomology to modular forms.
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/Theorems/Thm_HeckeEis_coeffHeckeFun_mem_coeffParabolicCocycles.lean
+
+Prove2Me submission: `a1c720ca-353d-5914-9331-55d4d08f3909` (ACCEPTED).
+-/
+
+section privateSection
+
+
+namespace P2MW.S_HeckeEis_coeffHeckeFun_mem_coeffParabolicCocycles
+
+open scoped MatrixGroups
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis"
+  "heckeConjMat heckeUpper coe_heckeConjSL heckeConj coe_heckeConj transferAux coe_transferAux \
+    coeffCocycles mem_coeffCocycles_iff IsParabolicCocycle coeffParabolicCocycles \
+    mem_coeffParabolicCocycles_iff coeffHeckeFun coeffHeckeFun_apply \
+    coeffHeckeFun_mem_coeffCocycles"
+namespace ParabolicHeckeSol
+p2m_open "HeckeEis"
+
+open CongruenceSubgroup Function
+open scoped MatrixGroups
+
+theorem fin_two_sq_eq_trace_smul_sub_one
+    (A : Matrix (Fin 2) (Fin 2) ℤ) (hdet : A.det = 1) :
+    A ^ 2 = A.trace • A - 1 := by
+  have hadj : A.adjugate = A.trace • 1 - A := by
+    ext i j
+    rw [Matrix.adjugate_fin_two]
+    fin_cases i <;> fin_cases j <;>
+      simp [Matrix.trace_fin_two, Matrix.one_fin_two]
+  have hAA : A * A.adjugate = 1 := by rw [Matrix.mul_adjugate, hdet, one_smul]
+  rw [hadj, mul_sub, Matrix.mul_smul, mul_one, ← sq] at hAA
+  have hrearr := sub_sub_cancel (A.trace • A) (A ^ 2)
+  rw [hAA] at hrearr; exact hrearr.symm
+
+theorem trace_sq_pow
+    (A : Matrix (Fin 2) (Fin 2) ℤ) (hdet : A.det = 1) (htr : A.trace ^ 2 = 4) (n : ℕ) :
+    (A ^ n).trace ^ 2 = 4 := by
+  have hrec : ∀ k, (A ^ (k + 2)).trace = A.trace * (A ^ (k + 1)).trace - (A ^ k).trace := by
+    intro k
+    have hstep : A ^ (k + 2) = A.trace • A ^ (k + 1) - A ^ k := by
+      rw [show k + 2 = 2 + k from Nat.add_comm k 2, pow_add,
+        fin_two_sq_eq_trace_smul_sub_one A hdet, sub_mul, smul_mul_assoc,
+        ← pow_succ', one_mul]
+    rw [hstep, Matrix.trace_sub, Matrix.trace_smul, smul_eq_mul]
+  have hinv : ∀ k, ((A ^ k).trace = 2 ∧ (A ^ (k + 1)).trace = A.trace) ∨
+      ((A ^ k).trace = A.trace ∧ (A ^ (k + 1)).trace = 2) := by
+    intro k
+    induction k with
+    | zero =>
+      refine Or.inl ⟨?_, by rw [zero_add, pow_one]⟩
+      rw [pow_zero, Matrix.trace_one, Fintype.card_fin]; rfl
+    | succ m ih =>
+      rcases ih with ⟨he, ho⟩ | ⟨he, ho⟩
+      · exact Or.inr ⟨ho, by rw [hrec m, ho, he, ← sq, htr]; ring⟩
+      · exact Or.inl ⟨ho, by rw [hrec m, ho, he]; ring⟩
+  rcases hinv n with ⟨h, _⟩ | ⟨h, _⟩
+  · rw [h]; norm_num
+  · rw [h]; exact htr
+
+theorem trace_conj (g h : SL(2, ℤ)) :
+    ((g * h * g⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace
+      = ((h : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace := by
+  simp only [Matrix.SpecialLinearGroup.coe_mul]
+  rw [Matrix.trace_mul_comm, ← mul_assoc, ← Matrix.SpecialLinearGroup.coe_mul,
+    inv_mul_cancel, Matrix.SpecialLinearGroup.coe_one, one_mul]
+
+theorem trace_heckeConjMat (ℓ : ℕ) (g : Matrix (Fin 2) (Fin 2) ℤ) : (heckeConjMat ℓ g).trace =
+  g.trace := by
+  simp [heckeConjMat, Matrix.trace_fin_two]
+
+section Orbit
+
+variable {N ℓ : ℕ} [NeZero ℓ] {K : Type*} [CommRing K] {V : Type*} [AddCommGroup V] [Module K V]
+variable (ρ : Representation K (Gamma0 N) V) (a : V →ₗ[K] V)
+
+def S (q : Gamma0 N ⧸ heckeUpper N ℓ) : V →ₗ[K] V := ρ (Quotient.out q) ∘ₗ a
+
+variable {ρ a}
+
+theorem S_heckeConj_transferAux
+    (ha : ∀ u : ↥(heckeUpper N ℓ), a ∘ₗ ρ (heckeConj N ℓ u) = ρ (u : Gamma0 N) ∘ₗ a)
+    (γ : Gamma0 N) (q : Gamma0 N ⧸ heckeUpper N ℓ) (v : V) :
+    S ρ a (γ • q) (ρ (heckeConj N ℓ (transferAux (heckeUpper N ℓ) γ q)) v) = ρ γ (S ρ a q v) := by
+  have h1 := LinearMap.congr_fun (ha (transferAux (heckeUpper N ℓ) γ q)) v
+  rw [LinearMap.comp_apply, LinearMap.comp_apply] at h1
+  rw [S, S, LinearMap.comp_apply, LinearMap.comp_apply, h1, ← Module.End.mul_apply, ← map_mul,
+    coe_transferAux,
+    mul_inv_cancel_left, map_mul, Module.End.mul_apply]
+
+variable (γ : Gamma0 N) (x : Gamma0 N ⧸ heckeUpper N ℓ)
+
+def tau (k : ℕ) : ↥(heckeUpper N ℓ) := transferAux (heckeUpper N ℓ) γ (γ ^ k • x)
+
+def piProd : ℕ → ↥(heckeUpper N ℓ)
+  | 0 => 1
+  | k + 1 => tau γ x k * piProd k
+
+omit [NeZero ℓ] in
+theorem coe_piProd (k : ℕ) :
+    ((piProd γ x k : ↥(heckeUpper N ℓ)) : Gamma0 N) = (Quotient.out (γ ^ k • x))⁻¹ * (γ ^ k *
+      Quotient.out x) := by
+  induction k with
+  | zero => simp [piProd]
+  | succ k ih =>
+    rw [piProd, Subgroup.coe_mul, ih, tau, coe_transferAux, ← mul_smul, ← pow_succ']
+    group
+
+variable {γ x}
+
+theorem P_succ (ha : ∀ u : ↥(heckeUpper N ℓ), a ∘ₗ ρ (heckeConj N ℓ u) = ρ (u : Gamma0 N) ∘ₗ a)
+    {z : Gamma0 N → V} (hz : z ∈ coeffCocycles ρ) (k : ℕ) :
+    S ρ a (γ ^ (k + 1) • x) (z (heckeConj N ℓ (piProd γ x (k + 1))))
+      = S ρ a (γ • (γ ^ k • x)) (z (heckeConj N ℓ (transferAux (heckeUpper N ℓ) γ (γ ^ k • x))))
+        + ρ γ (S ρ a (γ ^ k • x) (z (heckeConj N ℓ (piProd γ x k)))) := by
+  rw [piProd, map_mul, (mem_coeffCocycles_iff ρ z).mp hz, map_add, pow_succ', mul_smul,
+    ← S_heckeConj_transferAux ha γ (γ ^ k • x)]
+  rfl
+
+theorem sum_range_eq (ha : ∀ u : ↥(heckeUpper N ℓ), a ∘ₗ ρ (heckeConj N ℓ u) = ρ (u : Gamma0 N) ∘ₗ
+  a)
+    {z : Gamma0 N → V} (hz : z ∈ coeffCocycles ρ) (m : ℕ) :
+    (LinearMap.range (ρ γ - 1)).mkQ
+        (∑ k ∈ Finset.range m,
+          S ρ a (γ • (γ ^ k • x)) (z (heckeConj N ℓ (transferAux (heckeUpper N ℓ) γ (γ ^ k • x)))))
+      = (LinearMap.range (ρ γ - 1)).mkQ (S ρ a (γ ^ m • x) (z (heckeConj N ℓ (piProd γ x m)))) := by
+  induction m with
+  | zero =>
+    have h0 : z (heckeConj N ℓ (piProd γ x 0)) = 0 := by
+      rw [piProd, map_one]
+      have := (mem_coeffCocycles_iff ρ z).mp hz 1 1
+      rw [mul_one, map_one, Module.End.one_apply] at this
+      simpa using this
+    simp only [Finset.sum_range_zero, h0, map_zero]
+  | succ m ih =>
+    rw [Finset.sum_range_succ, map_add, ih, P_succ ha hz m, map_add]
+    rw [add_comm]
+    congr 1
+    symm
+    rw [← sub_eq_zero, ← map_sub, Submodule.mkQ_apply, Submodule.Quotient.mk_eq_zero]
+    exact ⟨S ρ a (γ ^ m • x) (z (heckeConj N ℓ (piProd γ x m))), by
+      rw [LinearMap.sub_apply, Module.End.one_apply]⟩
+
+theorem P_mem_range (ha : ∀ u : ↥(heckeUpper N ℓ), a ∘ₗ ρ (heckeConj N ℓ u) = ρ (u : Gamma0 N) ∘ₗ a)
+    {z : Gamma0 N → V} {m : ℕ} (hx : γ ^ m • x = x)
+    (hpar : z (heckeConj N ℓ (piProd γ x m)) ∈ LinearMap.range (ρ (heckeConj N ℓ (piProd γ x m)) -
+      1)) :
+    S ρ a (γ ^ m • x) (z (heckeConj N ℓ (piProd γ x m))) ∈ LinearMap.range (ρ γ - 1) := by
+  obtain ⟨w, hw⟩ := hpar
+  have h1 := LinearMap.congr_fun (ha (piProd γ x m)) w
+  rw [LinearMap.comp_apply, LinearMap.comp_apply] at h1
+  have hout : Quotient.out x * ((piProd γ x m : ↥(heckeUpper N ℓ)) : Gamma0 N) = γ ^ m *
+    Quotient.out x := by
+    rw [coe_piProd, hx, mul_inv_cancel_left]
+  rw [← hw, LinearMap.sub_apply, Module.End.one_apply, map_sub, hx, S, LinearMap.comp_apply,
+    LinearMap.comp_apply,
+    h1, ← Module.End.mul_apply, ← map_mul, hout, map_mul, Module.End.mul_apply, map_pow]
+  refine ⟨(∑ i ∈ Finset.range m, (ρ γ) ^ i) (ρ (Quotient.out x) (a w)), ?_⟩
+  rw [← Module.End.mul_apply, mul_geom_sum, LinearMap.sub_apply, Module.End.one_apply]
+
+end Orbit
+
+section Main
+
+variable {N ℓ : ℕ} [NeZero ℓ] {K : Type*} [CommRing K] {V : Type*} [AddCommGroup V] [Module K V]
+variable {ρ : Representation K (Gamma0 N) V} {a : V →ₗ[K] V}
+
+theorem isParabolicCocycle_coeffHeckeFun
+    (ha : ∀ u : ↥(heckeUpper N ℓ), a ∘ₗ ρ (heckeConj N ℓ u) = ρ (u : Gamma0 N) ∘ₗ a)
+    {z : Gamma0 N → V} (hz : z ∈ coeffParabolicCocycles ρ) :
+    IsParabolicCocycle ρ (coeffHeckeFun N ℓ ρ a z) := by
+  let : Fintype (Gamma0 N ⧸ heckeUpper N ℓ) := (heckeUpper N ℓ).fintypeQuotientOfFiniteIndex
+  obtain ⟨hzc, hzp⟩ := (mem_coeffParabolicCocycles_iff ρ z).mp hz
+  intro γ hγ
+  set R : Submodule K V := LinearMap.range (ρ γ - 1) with hR
+  set f : (Gamma0 N ⧸ heckeUpper N ℓ) → (Gamma0 N ⧸ heckeUpper N ℓ) := fun q => γ • q with hf
+  set v : (Gamma0 N ⧸ heckeUpper N ℓ) → V ⧸ R := fun q =>
+    R.mkQ (ρ (Quotient.out (γ • q)) (a (z (heckeConj N ℓ (transferAux (heckeUpper N ℓ) γ q))))) with
+      hv
+  have hfit : ∀ (k : ℕ) (q : Gamma0 N ⧸ heckeUpper N ℓ), f^[k] q = γ ^ k • q := fun k q => congr_fun
+    (smul_iterate γ k) q
+  have hfpos : ∀ q, 0 < minimalPeriod f q := by
+    intro q
+    have hn : 0 < orderOf (MulAction.toPermHom (Gamma0 N) (Gamma0 N ⧸ heckeUpper N ℓ) γ) :=
+      orderOf_pos _
+    refine IsPeriodicPt.minimalPeriod_pos hn ?_
+    have h1 := pow_orderOf_eq_one (MulAction.toPermHom (Gamma0 N) (Gamma0 N ⧸ heckeUpper N ℓ) γ)
+    rw [← map_pow] at h1
+    have h2 := Equiv.congr_fun h1 q
+    rw [MulAction.toPermHom_apply, MulAction.toPerm_apply, Equiv.Perm.one_apply] at h2
+    change f^[_] q = q
+    rw [hfit]
+    exact h2
+  have htr : ∀ (q : Gamma0 N ⧸ heckeUpper N ℓ) (m : ℕ), γ ^ m • q = q →
+      (((heckeConj N ℓ (piProd γ q m) : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace ^ 2
+        = 4 := by
+    intro q m hx
+    rw [coe_heckeConj, coe_heckeConjSL, trace_heckeConjMat, coe_piProd, hx]
+    have e : ((((Quotient.out q)⁻¹ * (γ ^ m * Quotient.out q) : Gamma0 N)) : SL(2, ℤ))
+        = (((Quotient.out q : Gamma0 N) : SL(2, ℤ)))⁻¹ * ((γ : SL(2, ℤ)) ^ m)
+            * ((((Quotient.out q : Gamma0 N) : SL(2, ℤ)))⁻¹)⁻¹ := by
+      rw [inv_inv, Subgroup.coe_mul, Subgroup.coe_mul, Subgroup.coe_inv, Subgroup.coe_pow,
+        mul_assoc]
+    rw [e, trace_conj, Matrix.SpecialLinearGroup.coe_pow]
+    exact trace_sq_pow _ (Matrix.SpecialLinearGroup.det_coe _) hγ m
+  have hsum : ∀ q, ∑ k ∈ Finset.range (minimalPeriod f q), v (f^[k] q) = 0 := by
+    intro q
+    have hx : γ ^ minimalPeriod f q • q = q := by rw [← hfit]; exact iterate_minimalPeriod
+    have key := sum_range_eq (γ := γ) (x := q) ha hzc (minimalPeriod f q)
+    simp only [S, LinearMap.comp_apply] at key
+    simp only [hv, hfit]
+    rw [← map_sum, key, Submodule.mkQ_apply, Submodule.Quotient.mk_eq_zero]
+    have hP := P_mem_range (ρ := ρ) (a := a) ha hx (hzp _ (htr q _ hx))
+    simpa only [S, LinearMap.comp_apply] using hP
+  obtain ⟨G, hG⟩ := Function.exists_eq_apply_sub_of_sum_range_minimalPeriod_eq_zero f hfpos v hsum
+  have htot : ∑ q, v q = 0 := by
+    rw [Finset.sum_congr rfl fun q _ => hG q, Finset.sum_sub_distrib, sub_eq_zero]
+    exact (MulAction.bijective γ).sum_comp G
+  rw [← Submodule.Quotient.mk_eq_zero R, ← Submodule.mkQ_apply, coeffHeckeFun_apply, map_sum]
+  exact htot
+
+end Main
+
+end HeckeEis.ParabolicHeckeSol
+
+end
+
+open _root_.HeckeEis _root_.P2MW.S_HeckeEis_coeffHeckeFun_mem_coeffParabolicCocycles.HeckeEis
+  HeckeEis.ParabolicHeckeSol CongruenceSubgroup in
+theorem solution (N ℓ : ℕ) [NeZero ℓ]
+    {K : Type*} [CommRing K] {V : Type*} [AddCommGroup V] [Module K V]
+    (ρ : Representation K (CongruenceSubgroup.Gamma0 N) V) (a : V →ₗ[K] V)
+    (ha : ∀ u : ↥(HeckeEis.heckeUpper N ℓ),
+      a ∘ₗ ρ (HeckeEis.heckeConj N ℓ u) = ρ (u : CongruenceSubgroup.Gamma0 N) ∘ₗ a)
+    {z : CongruenceSubgroup.Gamma0 N → V} (hz : z ∈ HeckeEis.coeffParabolicCocycles ρ) :
+    HeckeEis.coeffHeckeFun N ℓ ρ a z ∈ HeckeEis.coeffParabolicCocycles ρ :=
+  (mem_coeffParabolicCocycles_iff ρ _).mpr
+    ⟨HeckeEis.coeffHeckeFun_mem_coeffCocycles N ℓ ρ a ha ((mem_coeffParabolicCocycles_iff ρ z).mp
+      hz).1,
+      isParabolicCocycle_coeffHeckeFun ha hz⟩
+
+end S_HeckeEis_coeffHeckeFun_mem_coeffParabolicCocycles
+end P2MW
+export P2MW.S_HeckeEis_coeffHeckeFun_mem_coeffParabolicCocycles (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+
+theorem HeckeEis.coeffHeckeFun_mem_coeffParabolicCocycles (N ℓ : ℕ) [NeZero ℓ]
+    {K : Type*} [CommRing K] {V : Type*} [AddCommGroup V] [Module K V]
+    (ρ : Representation K (CongruenceSubgroup.Gamma0 N) V) (a : V →ₗ[K] V)
+    (ha : ∀ u : ↥(HeckeEis.heckeUpper N ℓ),
+      a ∘ₗ ρ (HeckeEis.heckeConj N ℓ u) = ρ (u : CongruenceSubgroup.Gamma0 N) ∘ₗ a)
+    {z : CongruenceSubgroup.Gamma0 N → V} (hz : z ∈ HeckeEis.coeffParabolicCocycles ρ) :
+    HeckeEis.coeffHeckeFun N ℓ ρ a z ∈ HeckeEis.coeffParabolicCocycles ρ :=
+      _root_.P2MW.S_HeckeEis_coeffHeckeFun_mem_coeffParabolicCocycles.solution N ℓ ρ a ha hz
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeff_single_one_eq_eval_of_mem_binaryForm.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeff_single_one_eq_eval_of_mem_binaryForm.lean
new file mode 100644
index 0000000000..561e3deae0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_coeff_single_one_eq_eval_of_mem_binaryForm.lean
@@ -0,0 +1,108 @@
+/-
+Based on Prove2Me node HeckeEis.coeff_single_one_eq_eval_of_mem_binaryForm
+(0e2ead68-eae4-581f-bf18-2e1442075acd) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9248ead8-a50a-58a9-a798-28397ba270ff
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# X₁ⁿ-coefficient of a binary form as its value at (0,1)
+
+Theorem statement: `HeckeEis.coeff_single_one_eq_eval_of_mem_binaryForm`
+(`0e2ead68-eae4-581f-bf18-2e1442075acd`), by Claude, 2026-09-05.
+
+Proof: submission `9248ead8-a50a-58a9-a798-28397ba270ff`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a commutative ring, let $n$ be a natural number, and let $P$ be a polynomial in the two
+variables indexed by `Fin 2` over $K$, i.e. $P \in K[X_0,X_1]$. Assume $P$ belongs to
+[`HeckeEis.BinaryForm K n`](def/HeckeEis_BinaryFormRep.html#L25), which is by definition the
+$K$-submodule `MvPolynomial.homogeneousSubmodule (Fin 2) K n` of polynomials homogeneous of degree
+$n$: every monomial occurring in $P$ has total degree $n$ (the zero polynomial being included). The
+conclusion is the equality, in $K$, of two quantities: the coefficient of $P$ at the exponent vector
+`Finsupp.single 1 n`, that is the coefficient of the monomial $X_1^{\,n}$, and the evaluation of $P$
+at the point given by the vector `![0, 1]`, i.e. the substitution $X_0 \mapsto 0$, $X_1 \mapsto 1$.
+Thus for a binary form of degree $n$ one has $\operatorname{coeff}_{X_1^n}(P) = P(0,1)$.
+
+This identifies the linear functional 'leading $X_1^n$-coefficient' on degree-$n$ binary forms with
+evaluation at the point $(0:1)$, which in the row-vector convention used for the representation of
+$\mathrm{SL}_2$ on binary forms is the cusp at infinity and is fixed by the upper triangular
+unipotent matrices. It is used in the computations with Eichler integrals and with coefficient
+cocycles, for instance by
+[`HeckeEis.IsEichlerIntegral.coeff_binaryFormRepSL_inv_apply_sub_eq_intervalIntegral_slash`]
+(thm.html#HeckeEis.IsEichlerIntegral.coeff_binaryFormRepSL_inv_apply_sub_eq_intervalIntegral_slash),
+[`HeckeEis.IsEichlerIntegral.vadd_sub_T_zpow_apply_mem_range`]
+(thm.html#HeckeEis.IsEichlerIntegral.vadd_sub_T_zpow_apply_mem_range)
+and
+[`HeckeEis.exists_modularForm_coeffCocycles_sub_cocycle_mem_coeffParabolicCocycles`]
+(thm.html#HeckeEis.exists_modularForm_coeffCocycles_sub_cocycle_mem_coeffParabolicCocycles).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_coeff_single_one_eq_eval_of_mem_binaryForm.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_coeff_single_one_eq_eval_of_mem_binaryForm
+
+open scoped MatrixGroups
+
+open HeckeEis MvPolynomial in
+theorem solution {K : Type*} [CommRing K] {n : ℕ}
+    {P : MvPolynomial (Fin 2) K} (hP : P ∈ HeckeEis.BinaryForm K n) :
+    AddMonoidAlgebra.coeff P (Finsupp.single 1 n) = MvPolynomial.eval ![0, 1] P := by
+  classical
+  have hhom : P.IsHomogeneous n := (mem_homogeneousSubmodule n P).mp hP
+  rw [MvPolynomial.eval_eq]
+  symm
+  rw [Finset.sum_eq_single (Finsupp.single 1 n)]
+  · simp [Finsupp.single_apply]
+  · intro d hd hne
+    have hdn : d.degree = n := by
+      by_contra hc
+      exact (mem_support_iff.mp hd) (hhom.coeff_eq_zero hc)
+    rw [Finsupp.degree_eq_sum, Fin.sum_univ_two] at hdn
+    have hd0 : d 0 ≠ 0 := by
+      intro h0
+      apply hne
+      ext i
+      fin_cases i
+      · simpa using h0
+      · simp
+        omega
+    rw [Finset.prod_eq_zero (Finsupp.mem_support_iff.mpr hd0) (by simp [zero_pow hd0]), mul_zero]
+  · intro hn
+    rw [MvPolynomial.notMem_support_iff.mp hn, zero_mul]
+
+end S_HeckeEis_coeff_single_one_eq_eval_of_mem_binaryForm
+end P2MW
+export P2MW.S_HeckeEis_coeff_single_one_eq_eval_of_mem_binaryForm (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.coeff_single_one_eq_eval_of_mem_binaryForm {K : Type*} [CommRing K] {n : ℕ}
+    {P : MvPolynomial (Fin 2) K} (hP : P ∈ HeckeEis.BinaryForm K n) :
+    AddMonoidAlgebra.coeff P (Finsupp.single 1 n) = MvPolynomial.eval ![0, 1] P :=
+  solution hP
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_eichlerShimuraMap_add.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_eichlerShimuraMap_add.lean
new file mode 100644
index 0000000000..1159179b72
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_eichlerShimuraMap_add.lean
@@ -0,0 +1,161 @@
+/-
+Based on Prove2Me node HeckeEis.eichlerShimuraMap_add
+(ead8ec67-bb2b-59c5-9770-0c35b45076fd) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b03c7104-47bb-598c-b948-3362bff905d2
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_eichlerShimuraMap_eq_coeffH1parMk
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_isEichlerIntegral_isParabolicCocycle
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Additivity of the Eichler–Shimura map on cusp forms
+
+Theorem statement: `HeckeEis.eichlerShimuraMap_add` (`ead8ec67-bb2b-59c5-9770-0c35b45076fd`), by
+Claude, 2026-09-05.
+
+Proof: submission `b03c7104-47bb-598c-b948-3362bff905d2`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix natural numbers $n$ and $N$ with $N \neq 0$, and let $f, g$ be cusp forms of weight $(n :
+\mathbb{Z}) + 2$ for $\Gamma_0(N) \le \mathrm{SL}_2(\mathbb{Z})$. The map
+[`HeckeEis.eichlerShimuraMap n N`](def/HeckeEis_EichlerIntegral.html#L114) is defined on arbitrary
+functions $h : \mathbb{H} \to \mathbb{C}$ and takes values in
+[`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100) of the representation of $\Gamma_0(N)$
+obtained by restricting [`HeckeEis.binaryFormRepSL ℂ n`](def/HeckeEis_BinaryFormRep.html#L61), the
+action of $\mathrm{SL}_2(\mathbb{Z})$ on the submodule $\mathrm{BinaryForm}\,\mathbb{C}\,n$ of
+degree-$n$ homogeneous polynomials in two variables by linear substitution; that target is the
+quotient of the module of parabolic coefficient cocycles by the coboundaries. By definition, the
+value at $h$ is the class of the cocycle $\gamma \mapsto F(\gamma \cdot i) - \rho(\gamma) F(i)$, for
+a choice of $F : \mathbb{H} \to \mathrm{BinaryForm}\,\mathbb{C}\,n$ that is an Eichler integral of
+$h$ (each coefficient of $F$, read as a function of a complex variable, has derivative the
+corresponding coefficient of $h(\tau) \cdot \mathrm{linePow}\,n\,\tau$ at every $\tau \in
+\mathbb{H}$), is an equivariant primitive (for each $\gamma$ the function $\tau \mapsto F(\gamma
+\cdot \tau) - \rho(\gamma)F(\tau)$ is constant), and whose cocycle is parabolic (its value at any
+$\gamma$ with $\mathrm{tr}(\gamma)^2 = 4$ lies in the range of $\rho(\gamma) - 1$); if no such $F$
+exists the value is $0$. The assertion is that the value at the function underlying $f + g$ equals
+the sum of the values at the functions underlying $f$ and at $g$.
+
+This is the additivity half of the linearity of the Eichler–Shimura map from weight-$(n+2)$ cusp
+forms on $\Gamma_0(N)$ to parabolic cohomology with coefficients in binary forms of degree $n$.
+Together with the corresponding homogeneity statement it feeds
+[`HeckeEis.existsEichlerShimuraMapLinear`](thm.html#HeckeEis.existsEichlerShimuraMapLinear), which
+packages the Eichler–Shimura map as a linear map.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_eichlerShimuraMap_add.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_eichlerShimuraMap_add
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "binaryFormRepSL IsParabolicCocycle IsEquivariantPrimitiveWith \
+  IsEichlerIntegral eichlerShimuraMap exists_isEichlerIntegral_isParabolicCocycle \
+  eichlerShimuraMap_eq_coeffH1parMk IsEichlerIntegral.add"
+p2m_open "HeckeEis"
+
+open UpperHalfPlane MvPolynomial CongruenceSubgroup
+open scoped MatrixGroups ModularForm
+
+namespace EichlerLinAux
+
+variable {K : Type*} [CommRing K] {Γ : Subgroup SL(2, ℤ)} {V : Type*} [AddCommGroup V] [Module K V]
+  {ρ : Representation K Γ V} {F G : ℍ → V}
+
+private theorem _root_.HeckeEis.EichlerLinAux.add (hF : IsEquivariantPrimitiveWith ρ F)
+    (hG : IsEquivariantPrimitiveWith ρ G) :
+    IsEquivariantPrimitiveWith ρ (F + G) := fun γ =>
+  ⟨hF.cocycle γ + hG.cocycle γ, fun τ => by
+    rw [Pi.add_apply, Pi.add_apply, map_add, ← hF.sub_eq_cocycle γ τ, ← hG.sub_eq_cocycle γ
+      τ]; abel⟩
+
+p2m_export "HeckeEis.EichlerLinAux" "add"
+theorem cocycle_add (hF : IsEquivariantPrimitiveWith ρ F) (hG : IsEquivariantPrimitiveWith ρ G) :
+    (add hF hG).cocycle = hF.cocycle + hG.cocycle := by
+  funext γ
+  change (F + G) ((γ : SL(2, ℤ)) • I) - ρ γ ((F + G) I) = (F _ - ρ γ (F I)) + (G _ - ρ γ (G I))
+  rw [Pi.add_apply, Pi.add_apply, map_add]
+  abel
+
+theorem smul (hF : IsEquivariantPrimitiveWith ρ F) (c : K) :
+    IsEquivariantPrimitiveWith ρ (c • F) := fun γ =>
+  ⟨c • hF.cocycle γ, fun τ => by
+    rw [Pi.smul_apply, Pi.smul_apply, map_smul, ← hF.sub_eq_cocycle γ τ, smul_sub]⟩
+
+theorem cocycle_smul (hF : IsEquivariantPrimitiveWith ρ F) (c : K) :
+    (smul hF c).cocycle = c • hF.cocycle := by
+  funext γ
+  change (c • F) ((γ : SL(2, ℤ)) • I) - ρ γ ((c • F) I) = c • (F _ - ρ γ (F I))
+  rw [Pi.smul_apply, Pi.smul_apply, map_smul, smul_sub]
+
+end EichlerLinAux
+
+open EichlerLinAux in
+theorem SolMain.esadd (n N : ℕ) [NeZero N] (f g : CuspForm (Gamma0 N) ((n : ℤ) + 2)) :
+    eichlerShimuraMap n N ⇑(f + g) = eichlerShimuraMap n N f + eichlerShimuraMap n N g := by
+  obtain ⟨F, hEF, hF, hpF⟩ := exists_isEichlerIntegral_isParabolicCocycle N n f
+  obtain ⟨G, hEG, hG, hpG⟩ := exists_isEichlerIntegral_isParabolicCocycle N n g
+  have hEFG : IsEichlerIntegral n (⇑(f + g)) (F + G) := by
+    rw [FunLike.coe_add]; exact hEF.add hEG
+  have hpFG : IsParabolicCocycle ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (add hF hG).cocycle
+    :=
+    by
+    intro γ hγ
+    rw [cocycle_add hF hG, Pi.add_apply]
+    exact add_mem (hpF γ hγ) (hpG γ hγ)
+  rw [eichlerShimuraMap_eq_coeffH1parMk n N _ hEFG (add hF hG) hpFG,
+    eichlerShimuraMap_eq_coeffH1parMk n N _ hEF hF hpF, eichlerShimuraMap_eq_coeffH1parMk n N _ hEG
+    hG hpG,
+    ← map_add]
+  congr 1
+  exact Subtype.ext (cocycle_add hF hG)
+
+end HeckeEis
+
+end
+
+open scoped MatrixGroups ModularForm in
+theorem solution (n N : ℕ) [NeZero N]
+    (f g : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2)) :
+    HeckeEis.eichlerShimuraMap n N ⇑(f + g) = HeckeEis.eichlerShimuraMap n N f +
+      HeckeEis.eichlerShimuraMap n N g :=
+  HeckeEis.SolMain.esadd n N f g
+
+end S_HeckeEis_eichlerShimuraMap_add
+end P2MW
+export P2MW.S_HeckeEis_eichlerShimuraMap_add (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups ModularForm
+theorem HeckeEis.eichlerShimuraMap_add (n N : ℕ) [NeZero N]
+    (f g : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2)) :
+    HeckeEis.eichlerShimuraMap n N ⇑(f + g) = HeckeEis.eichlerShimuraMap n N f +
+      HeckeEis.eichlerShimuraMap n N g :=
+  solution n N f g
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_eichlerShimuraMap_eq_coeffH1parMk.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_eichlerShimuraMap_eq_coeffH1parMk.lean
new file mode 100644
index 0000000000..c8d0064254
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_eichlerShimuraMap_eq_coeffH1parMk.lean
@@ -0,0 +1,111 @@
+/-
+Based on Prove2Me node HeckeEis.eichlerShimuraMap_eq_coeffH1parMk
+(c45b784f-df99-52af-9e4f-b91b69432be5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 0f02be45-b7e6-5874-9237-54a5c34d271d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_exists_sub_eq_const
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEquivariantPrimitiveWith_cocycle_sub_cocycle_mem_coeffCoboundaries
+
+/-!
+# Eichler–Shimura map computed by any admissible Eichler integral
+
+Theorem statement: `HeckeEis.eichlerShimuraMap_eq_coeffH1parMk`
+(`c45b784f-df99-52af-9e4f-b91b69432be5`), by Claude, 2026-09-05.
+
+Proof: submission `0f02be45-b7e6-5874-9237-54a5c34d271d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix natural numbers $n$ and $N$ and a function $f\colon\mathfrak H\to\mathbb C$ on the upper
+half-plane, and let $V_n =$ [`HeckeEis.BinaryForm ℂ n`](def/HeckeEis_BinaryFormRep.html#L25) be the
+space of homogeneous polynomials of degree $n$ in two variables $X_0,X_1$ over $\mathbb C$, on which
+$\rho$ denotes the representation `(HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+N).subtype`, i.e. $\mathrm{SL}_2(\mathbb Z)$ acting by the linear substitution $X_j\mapsto\sum_i
+M_{ij}X_i$, restricted to $\Gamma_0(N)$. Let $F\colon\mathfrak H\to V_n$ satisfy three hypotheses:
+(i) $F$ is an Eichler integral of $f$, meaning that for every exponent $d$ and every
+$\tau\in\mathfrak H$ the coefficient function $z\mapsto \mathrm{coeff}_d(F(z))$ has complex
+derivative $f(\tau)\,\mathrm{coeff}_d\big((\tau X_0+X_1)^n\big)$ at $\tau$; (ii) $F$ is an
+equivariant primitive for $\rho$, i.e. for each $\gamma\in\Gamma_0(N)$ the function $\tau\mapsto
+F(\gamma\tau)-\rho(\gamma)F(\tau)$ is a constant of $V_n$; (iii) the associated cocycle
+$z_F(\gamma)=F(\gamma\cdot i)-\rho(\gamma)F(i)$ is parabolic, i.e.
+$z_F(\gamma)\in\mathrm{range}(\rho(\gamma)-1)$ whenever $\mathrm{tr}(\gamma)^2=4$. The conclusion is
+that [`HeckeEis.eichlerShimuraMap n N f`](def/HeckeEis_EichlerIntegral.html#L114), defined by
+choosing some such $F$ when one exists and $0$ otherwise, equals the class of $z_F$ in
+[`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100), the quotient of the module of
+parabolic cocycles by those which are coboundaries.
+
+This identifies the Eichler–Shimura class attached to $f$ with the cohomology class of the cocycle
+of any Eichler integral of $f$ that is an equivariant primitive with parabolic cocycle, so that the
+choice implicit in the definition is immaterial. It is the computational entry point for the
+additivity and Hecke-compatibility statements about the Eichler–Shimura map, being cited by
+[`HeckeEis.eichlerShimuraMap_add`](thm.html#HeckeEis.eichlerShimuraMap_add),
+[`HeckeEis.eichlerShimuraMap_heckeTLin`](thm.html#HeckeEis.eichlerShimuraMap_heckeTLin) and
+[`HeckeEis.eichlerShimuraMap_heckeULin`](thm.html#HeckeEis.eichlerShimuraMap_heckeULin).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_eichlerShimuraMap_eq_coeffH1parMk.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+noncomputable section
+
+namespace HeckeEis
+
+open UpperHalfPlane CongruenceSubgroup
+
+theorem SolMain.eqmk (n N : ℕ) (f : ℍ → ℂ) {F : ℍ → ↥(BinaryForm ℂ n)}
+    (hEI : IsEichlerIntegral n f F)
+    (hF : IsEquivariantPrimitiveWith ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) F)
+    (hpar : IsParabolicCocycle ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) hF.cocycle) :
+    eichlerShimuraMap n N f
+      = coeffH1parMk _ ⟨hF.cocycle, ⟨hF.cocycle_mem_coeffCocycles, hpar⟩⟩ := by
+  obtain ⟨F₀, hEI₀, h₀, hpar₀, heq⟩ := eichlerShimuraMap_def n N f hEI hF hpar
+  rw [heq, ← sub_eq_zero, ← map_sub, coeffH1parMk_eq_zero_iff]
+  obtain ⟨v, hv⟩ := hEI₀.exists_sub_eq_const hEI
+  exact h₀.cocycle_sub_cocycle_mem_coeffCoboundaries hF hv
+
+end HeckeEis
+
+end
+
+theorem solution (n N : ℕ) (f : UpperHalfPlane → ℂ)
+    {F : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)}
+    (hEI : HeckeEis.IsEichlerIntegral n f F)
+    (hF : HeckeEis.IsEquivariantPrimitiveWith
+      ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype) F)
+    (hpar : HeckeEis.IsParabolicCocycle
+      ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype) hF.cocycle) :
+    HeckeEis.eichlerShimuraMap n N f
+      = HeckeEis.coeffH1parMk _ ⟨hF.cocycle, ⟨hF.cocycle_mem_coeffCocycles, hpar⟩⟩ :=
+  HeckeEis.SolMain.eqmk n N f hEI hF hpar
+
+end privateSection
+
+public section publicSection
+
+theorem HeckeEis.eichlerShimuraMap_eq_coeffH1parMk (n N : ℕ) (f : UpperHalfPlane → ℂ)
+    {F : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)}
+    (hEI : HeckeEis.IsEichlerIntegral n f F)
+    (hF : HeckeEis.IsEquivariantPrimitiveWith
+      ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype) F)
+    (hpar : HeckeEis.IsParabolicCocycle
+      ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype) hF.cocycle) :
+    HeckeEis.eichlerShimuraMap n N f
+      = HeckeEis.coeffH1parMk _ ⟨hF.cocycle, ⟨hF.cocycle_mem_coeffCocycles, hpar⟩⟩ :=
+        _root_.solution n N f hEI hF hpar
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_eichlerShimuraMap_heckeTLin.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_eichlerShimuraMap_heckeTLin.lean
new file mode 100644
index 0000000000..ddb5f16892
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_eichlerShimuraMap_heckeTLin.lean
@@ -0,0 +1,1018 @@
+/-
+Based on Prove2Me node HeckeEis.eichlerShimuraMap_heckeTLin
+(e1b2d32e-efa3-5984-adbe-20ce258706cb) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a4c3d2b9-8e60-5ace-85f7-a9537c5d28fd
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperatorForms
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_binarySubst_adjugate_comp_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_binaryFormAlphaAdj_comp_binaryFormRepSL_heckeConj
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_eichlerShimuraMap_eq_coeffH1parMk
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_isEichlerIntegral_isParabolicCocycle
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_isParabolicCocycle_cocycle_of_isEichlerIntegral
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Eichler–Shimura map intertwines T_ℓ with cohomological T_ℓ
+
+Theorem statement: `HeckeEis.eichlerShimuraMap_heckeTLin` (`e1b2d32e-efa3-5984-adbe-20ce258706cb`),
+by Claude, 2026-09-05.
+
+Proof: submission `a4c3d2b9-8e60-5ace-85f7-a9537c5d28fd`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N \ge 1$ and $n \ge 0$, a prime $\ell$ with $\ell \nmid N$, and write $\rho$ for the
+representation of $\Gamma_0(N)$ obtained by restricting along $\Gamma_0(N) \hookrightarrow
+\mathrm{SL}(2,\mathbb{Z})$ the substitution action [`HeckeEis.binaryFormRepSL ℂ
+n`](def/HeckeEis_BinaryFormRep.html#L61) of $\mathrm{SL}(2,\mathbb{Z})$ on the space of degree-$n$
+homogeneous polynomials in two variables over $\mathbb{C}$. Let $T$ be any $\mathbb{C}$-linear
+endomorphism of [`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100) $\rho$, the quotient of
+the module of parabolic cocycles — functions $z : \Gamma_0(N) \to \mathrm{Sym}^n$ with $z(gh) = z(g)
++ \rho(g)z(h)$ and $z(\gamma) \in \mathrm{range}(\rho(\gamma) - 1)$ whenever $\mathrm{tr}(\gamma)^2
+= 4$ — by the submodule of those parabolic cocycles which are coboundaries. Assume $T$ is induced by
+the cochain-level Hecke operator: for every parabolic cocycle $z$ there is a parabolic cocycle $w$
+whose underlying function equals [`HeckeEis.coeffHeckeFun N ℓ`](def/Gamma0CoeffCohomology.html#L129)
+$\rho$ applied to $z$ with coefficient map [`HeckeEis.binaryFormAlphaAdj ℂ n
+ℓ`](def/HeckeEis_BinaryFormRep.html#L82) (substitution by $\mathrm{diag}(\ell,1)$), i.e. the coset
+sum $g \mapsto \sum_{q} \rho((g\cdot
+q)^{\mathrm{out}})\,\alpha\bigl(z(\mathrm{heckeConj}(\mathrm{transferAux}\,g\,q))\bigr)$ over
+$\Gamma_0(N)/\mathrm{heckeUpper}(N,\ell)$, and such that $T[z] = [w]$. Then for every cusp form $f$
+of weight $(n:\mathbb{Z})+2$ on $\Gamma_0(N)$ one has $T(\mathrm{ES}(f)) = \mathrm{ES}(T_\ell f)$,
+where $\mathrm{ES} =$ [`HeckeEis.eichlerShimuraMap n N`](def/HeckeEis_EichlerIntegral.html#L114) and
+$T_\ell =$ [`CuspForm.heckeTLin ((n : ℤ) + 2) hℓ hℓN`](def/ModularForm_HeckeOperatorForms.html#L69).
+
+This is the Hecke-equivariance of the Eichler–Shimura map from weight $n+2$ cusp forms on
+$\Gamma_0(N)$ to parabolic cohomology with coefficients in binary forms of degree $n$, stated for an
+arbitrary endomorphism $T$ of the cohomology that is induced by the explicit coset-sum Hecke
+operator on cocycles, so that no existence or uniqueness statement for the induced operator is
+needed. It supports the construction of integral and mod $p$ eigenclasses in parabolic cohomology
+attached to Hecke eigenforms and the finiteness of the relevant Hecke algebra.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_eichlerShimuraMap_heckeTLin.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_eichlerShimuraMap_heckeTLin
+
+open scoped Manifold MatrixGroups
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_mul binarySubst_mem binaryFormRepSL \
+  binaryFormRepSL_apply_coe binaryFormAlphaAdj binaryFormAlphaAdj_apply_coe alphaMat \
+  alphaMat_apply_zero_zero alphaMat_apply_zero_one alphaMat_apply_one_one det_alphaMat \
+  heckeConjMat heckeConjMat_mul_alphaMat heckeUpper mem_heckeUpper heckeConj transferAux \
+  coe_transferAux HeckeIndexEq IsParabolicCocycle coeffParabolicCocycles coeffH1par coeffH1parMk \
+  coeffHeckeFun coeffHeckeFun_apply IsEquivariantPrimitiveWith IsEquivariantPrimitiveWith.cocycle \
+  IsEichlerIntegral eichlerShimuraMap binaryFormAlphaAdj_comp_binaryFormRepSL_heckeConj \
+  exists_isEichlerIntegral_isParabolicCocycle isParabolicCocycle_cocycle_of_isEichlerIntegral \
+  eichlerShimuraMap_eq_coeffH1parMk"
+namespace HeckeESSol
+p2m_open "HeckeEis"
+
+open UpperHalfPlane Filter Topology Complex
+open scoped MatrixGroups ModularForm
+
+namespace HeckeAnalytic
+
+open Matrix CongruenceSubgroup
+
+def repMat (ℓ : ℕ) : Option (Fin ℓ) → Matrix (Fin 2) (Fin 2) ℤ
+  | none => !![(ℓ : ℤ), 0; 0, 1]
+  | some j => !![1, (j : ℤ); 0, (ℓ : ℤ)]
+
+@[scoped simp] lemma repMat_none (ℓ : ℕ) : repMat ℓ none = !![(ℓ : ℤ), 0; 0, 1] := rfl
+
+@[scoped simp] lemma repMat_some (ℓ : ℕ) (j : Fin ℓ) :
+    repMat ℓ (some j) = !![1, (j : ℤ); 0, (ℓ : ℤ)] :=
+  rfl
+
+lemma det_repMat (ℓ : ℕ) (i : Option (Fin ℓ)) : (repMat ℓ i).det = (ℓ : ℤ) := by
+  cases i <;> simp [repMat, Matrix.det_fin_two_of]
+
+lemma exists_cocycle {N : ℕ} {ℓ : ℕ} (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) {g : SL(2, ℤ)}
+    (hg : g ∈ Gamma0 N) (i : Option (Fin ℓ)) :
+    ∃ δ : SL(2, ℤ), δ ∈ Gamma0 N ∧ ∃ m : Option (Fin ℓ),
+      repMat ℓ i * (g : Matrix (Fin 2) (Fin 2) ℤ)
+        = (δ : Matrix (Fin 2) (Fin 2) ℤ) * repMat ℓ m := by
+  have : NeZero ℓ := ⟨hℓ.ne_zero⟩
+  have : Fact ℓ.Prime := ⟨hℓ⟩
+  have hℓ0 : (ℓ : ℤ) ≠ 0 := by exact_mod_cast hℓ.ne_zero
+  have hdetG : (g : Matrix (Fin 2) (Fin 2) ℤ) 0 0 * (g : Matrix (Fin 2) (Fin 2) ℤ) 1 1 -
+      (g : Matrix (Fin 2) (Fin 2) ℤ) 0 1 * (g : Matrix (Fin 2) (Fin 2) ℤ) 1 0 = 1 := by
+    have := g.det_coe
+    rwa [Matrix.det_fin_two] at this
+  have hNc : (N : ℤ) ∣ (g : Matrix (Fin 2) (Fin 2) ℤ) 1 0 := by
+    have := Gamma0_mem.mp hg
+    rwa [← ZMod.intCast_zmod_eq_zero_iff_dvd]
+  set a : ℤ := (g : Matrix (Fin 2) (Fin 2) ℤ) 0 0 with ha
+  set b : ℤ := (g : Matrix (Fin 2) (Fin 2) ℤ) 0 1 with hb
+  set c : ℤ := (g : Matrix (Fin 2) (Fin 2) ℤ) 1 0 with hc
+  set d : ℤ := (g : Matrix (Fin 2) (Fin 2) ℤ) 1 1 with hd
+  have hgmat : (g : Matrix (Fin 2) (Fin 2) ℤ) = !![a, b; c, d] := by
+    rw [ha, hb, hc, hd]; exact Matrix.eta_fin_two _
+  have key : ∀ p t : ℤ, ¬ (ℓ : ℤ) ∣ p → ∃ j' : Fin ℓ, (ℓ : ℤ) ∣ t - p * (j' : ℤ) := by
+    intro p t hp
+    have hℓpos : (0 : ℤ) < (ℓ : ℤ) := by exact_mod_cast hℓ.pos
+    have hcop : IsCoprime (ℓ : ℤ) p :=
+      (Prime.coprime_iff_not_dvd (Nat.prime_iff_prime_int.mp hℓ)).mpr hp
+    obtain ⟨u, v, huv⟩ := hcop
+    have hmod := Int.emod_add_mul_ediv (v * t) (ℓ : ℤ)
+    have hnonneg : 0 ≤ (v * t) % (ℓ : ℤ) := Int.emod_nonneg _ hℓ0
+    have hlt : (v * t) % (ℓ : ℤ) < (ℓ : ℤ) := Int.emod_lt_of_pos _ hℓpos
+    have hcoe : ((((v * t) % (ℓ : ℤ)).toNat : ℕ) : ℤ) = (v * t) % (ℓ : ℤ) :=
+      Int.toNat_of_nonneg hnonneg
+    refine ⟨⟨((v * t) % (ℓ : ℤ)).toNat, by omega⟩,
+      ⟨t * u + p * ((v * t) / (ℓ : ℤ)), ?_⟩⟩
+    change t - p * ((((v * t) % (ℓ : ℤ)).toNat : ℕ) : ℤ)
+      = (ℓ : ℤ) * (t * u + p * ((v * t) / (ℓ : ℤ)))
+    rw [hcoe]
+    linear_combination (-t) * huv + (-p) * hmod
+  cases i with
+  | none =>
+    by_cases hcdvd : (ℓ : ℤ) ∣ c
+    · obtain ⟨c', hc'⟩ := hcdvd
+      have hdetδ : Matrix.det !![a, (ℓ : ℤ) * b; c', d] = 1 := by
+        rw [Matrix.det_fin_two_of]
+        linear_combination hdetG + b * hc'
+      refine ⟨⟨_, hdetδ⟩, ?_, none, ?_⟩
+      · rw [Gamma0_mem]
+        change ((c' : ℤ) : ZMod N) = 0
+        have hcopN : Nat.Coprime N ℓ := ((Nat.Prime.coprime_iff_not_dvd hℓ).mpr hℓN).symm
+        have hcop : IsCoprime (N : ℤ) (ℓ : ℤ) := Int.isCoprime_iff_gcd_eq_one.mpr (by
+          simpa [Int.gcd_natCast_natCast] using hcopN)
+        have hNc' : (N : ℤ) ∣ c' := by
+          refine hcop.dvd_of_dvd_mul_left ?_
+          rw [← hc']
+          exact hNc
+        rwa [ZMod.intCast_zmod_eq_zero_iff_dvd]
+      · change repMat ℓ none * (g : Matrix (Fin 2) (Fin 2) ℤ)
+          = !![a, (ℓ : ℤ) * b; c', d] * repMat ℓ none
+        rw [hgmat, repMat_none, Matrix.mul_fin_two, Matrix.mul_fin_two]
+        refine Matrix.ext fun x y => ?_
+        fin_cases x <;> fin_cases y
+        · change ((ℓ : ℤ) * a + 0 * c : ℤ) = a * (ℓ : ℤ) + (ℓ : ℤ) * b * 0
+          ring
+        · change ((ℓ : ℤ) * b + 0 * d : ℤ) = a * 0 + (ℓ : ℤ) * b * 1
+          ring
+        · change (0 * a + 1 * c : ℤ) = c' * (ℓ : ℤ) + d * 0
+          linear_combination hc'
+        · change (0 * b + 1 * d : ℤ) = c' * 0 + d * 1
+          ring
+    · obtain ⟨j', hj'⟩ := key c d hcdvd
+      obtain ⟨e, he⟩ := hj'
+      have hdetδ : Matrix.det !![(ℓ : ℤ) * a, b - a * (j' : ℤ); c, e] = 1 := by
+        rw [Matrix.det_fin_two_of]
+        linear_combination hdetG - a * he
+      refine ⟨⟨_, hdetδ⟩, ?_, some j', ?_⟩
+      · rw [Gamma0_mem]
+        change ((c : ℤ) : ZMod N) = 0
+        rwa [ZMod.intCast_zmod_eq_zero_iff_dvd]
+      · change repMat ℓ none * (g : Matrix (Fin 2) (Fin 2) ℤ)
+          = !![(ℓ : ℤ) * a, b - a * (j' : ℤ); c, e] * repMat ℓ (some j')
+        rw [hgmat, repMat_none, repMat_some, Matrix.mul_fin_two, Matrix.mul_fin_two]
+        refine Matrix.ext fun x y => ?_
+        fin_cases x <;> fin_cases y
+        · change ((ℓ : ℤ) * a + 0 * c : ℤ) = (ℓ : ℤ) * a * 1 + (b - a * (j' : ℤ)) * 0
+          ring
+        · change ((ℓ : ℤ) * b + 0 * d : ℤ) = (ℓ : ℤ) * a * (j' : ℤ) + (b - a * (j' : ℤ)) * (ℓ : ℤ)
+          ring
+        · change (0 * a + 1 * c : ℤ) = c * 1 + e * 0
+          ring
+        · change (0 * b + 1 * d : ℤ) = c * (j' : ℤ) + e * (ℓ : ℤ)
+          linear_combination he
+  | some j =>
+    by_cases hpdvd : (ℓ : ℤ) ∣ (a + (j : ℤ) * c)
+    · obtain ⟨p', hp'⟩ := hpdvd
+      have hdetδ : Matrix.det !![p', b + (j : ℤ) * d; c, (ℓ : ℤ) * d] = 1 := by
+        rw [Matrix.det_fin_two_of]
+        linear_combination hdetG - d * hp'
+      refine ⟨⟨_, hdetδ⟩, ?_, none, ?_⟩
+      · rw [Gamma0_mem]
+        change ((c : ℤ) : ZMod N) = 0
+        rwa [ZMod.intCast_zmod_eq_zero_iff_dvd]
+      · change repMat ℓ (some j) * (g : Matrix (Fin 2) (Fin 2) ℤ)
+          = !![p', b + (j : ℤ) * d; c, (ℓ : ℤ) * d] * repMat ℓ none
+        rw [hgmat, repMat_some, repMat_none, Matrix.mul_fin_two, Matrix.mul_fin_two]
+        refine Matrix.ext fun x y => ?_
+        fin_cases x <;> fin_cases y
+        · change (1 * a + (j : ℤ) * c : ℤ) = p' * (ℓ : ℤ) + (b + (j : ℤ) * d) * 0
+          linear_combination hp'
+        · change (1 * b + (j : ℤ) * d : ℤ) = p' * 0 + (b + (j : ℤ) * d) * 1
+          ring
+        · change (0 * a + (ℓ : ℤ) * c : ℤ) = c * (ℓ : ℤ) + (ℓ : ℤ) * d * 0
+          ring
+        · change (0 * b + (ℓ : ℤ) * d : ℤ) = c * 0 + (ℓ : ℤ) * d * 1
+          ring
+    · obtain ⟨j', hj'⟩ := key (a + (j : ℤ) * c) (b + (j : ℤ) * d) hpdvd
+      obtain ⟨e, he⟩ := hj'
+      have hdetδ : Matrix.det
+          !![a + (j : ℤ) * c, e; (ℓ : ℤ) * c, d - c * (j' : ℤ)] = 1 := by
+        rw [Matrix.det_fin_two_of]
+        linear_combination hdetG + c * he
+      refine ⟨⟨_, hdetδ⟩, ?_, some j', ?_⟩
+      · rw [Gamma0_mem]
+        change (((ℓ : ℤ) * c : ℤ) : ZMod N) = 0
+        push_cast
+        rw [show ((c : ℤ) : ZMod N) = 0 from (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mpr hNc,
+          mul_zero]
+      · change repMat ℓ (some j) * (g : Matrix (Fin 2) (Fin 2) ℤ)
+          = !![a + (j : ℤ) * c, e; (ℓ : ℤ) * c, d - c * (j' : ℤ)] * repMat ℓ (some j')
+        rw [hgmat, repMat_some, repMat_some, Matrix.mul_fin_two, Matrix.mul_fin_two]
+        refine Matrix.ext fun x y => ?_
+        fin_cases x <;> fin_cases y
+        · change (1 * a + (j : ℤ) * c : ℤ) = (a + (j : ℤ) * c) * 1 + e * 0
+          ring
+        · change (1 * b + (j : ℤ) * d : ℤ) = (a + (j : ℤ) * c) * (j' : ℤ) + e * (ℓ : ℤ)
+          linear_combination he
+        · change (0 * a + (ℓ : ℤ) * c : ℤ) = (ℓ : ℤ) * c * 1 + (d - c * (j' : ℤ)) * 0
+          ring
+        · change (0 * b + (ℓ : ℤ) * d : ℤ) = (ℓ : ℤ) * c * (j' : ℤ) + (d - c * (j' : ℤ)) * (ℓ : ℤ)
+          ring
+
+def repGL (ℓ : ℕ) [NeZero ℓ] (i : Option (Fin ℓ)) : GL (Fin 2) ℝ :=
+  Matrix.GeneralLinearGroup.mkOfDetNeZero ((repMat ℓ i).map (algebraMap ℤ ℝ)) (by
+    have h : ((repMat ℓ i).map (algebraMap ℤ ℝ)).det = (algebraMap ℤ ℝ) (repMat ℓ i).det := by
+      rw [← RingHom.mapMatrix_apply, ← RingHom.map_det]
+    rw [h, det_repMat]
+    simp [NeZero.ne ℓ])
+
+@[scoped simp] lemma repGL_coe (ℓ : ℕ) [NeZero ℓ] (i : Option (Fin ℓ)) :
+    (repGL ℓ i : Matrix (Fin 2) (Fin 2) ℝ) = (repMat ℓ i).map (algebraMap ℤ ℝ) := rfl
+
+private lemma mapGL_coe' (s : SL(2, ℤ)) :
+    ((Matrix.SpecialLinearGroup.mapGL ℝ s : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ)
+      = (s : Matrix (Fin 2) (Fin 2) ℤ).map (algebraMap ℤ ℝ) := rfl
+
+private lemma map_int_mul (M P : Matrix (Fin 2) (Fin 2) ℤ) :
+    (M * P).map (algebraMap ℤ ℝ) = M.map (algebraMap ℤ ℝ) * P.map (algebraMap ℤ ℝ) := by
+  rw [← RingHom.mapMatrix_apply, ← RingHom.mapMatrix_apply, ← RingHom.mapMatrix_apply, map_mul]
+
+def heckeSlashSum (k : ℤ) (ℓ : ℕ) [NeZero ℓ] (f : ℍ → ℂ) : ℍ → ℂ :=
+  ∑ i : Option (Fin ℓ), f ∣[k] repGL ℓ i
+
+section BoardBridge
+
+variable (ℓ : ℕ) [NeZero ℓ]
+
+theorem repGL_some_eq_heckeMatrix (j : Fin ℓ) :
+    repGL ℓ (some j) = ModularForm.heckeMatrix ℓ j := by
+  refine Units.ext ?_
+  rw [repGL_coe, ModularForm.val_heckeMatrix (NeZero.ne ℓ), repMat_some]
+  ext i k
+  fin_cases i <;> fin_cases k <;> simp
+
+theorem repGL_none_eq_heckeDiagMatrix :
+    repGL ℓ none = ModularForm.heckeDiagMatrix ℓ := by
+  refine Units.ext ?_
+  rw [repGL_coe, ModularForm.val_heckeDiagMatrix (NeZero.ne ℓ), repMat_none]
+  ext i k
+  fin_cases i <;> fin_cases k <;> simp
+
+theorem heckeSlashSum_eq_heckeT (k : ℤ) (f : UpperHalfPlane → ℂ) :
+    heckeSlashSum k ℓ f = ModularForm.heckeT k ℓ f := by
+  rw [heckeSlashSum, ModularForm.heckeT_def, Fintype.sum_option, repGL_none_eq_heckeDiagMatrix,
+    add_comm, ← Fin.sum_univ_eq_sum_range (fun j => f ∣[k] ModularForm.heckeMatrix ℓ j) ℓ]
+  congr 1
+  exact Finset.sum_congr rfl fun j _ => by rw [repGL_some_eq_heckeMatrix]
+
+end BoardBridge
+
+end HeckeAnalytic
+
+p2m_open "UpperHalfPlane Filter Topology Complex Function ModularForm Matrix CongruenceSubgroup \
+  Subgroup HeckeEis P2MW.S_HeckeEis_eichlerShimuraMap_heckeTLin.HeckeEis"
+
+noncomputable local instance (N ℓ : ℕ) [NeZero ℓ] :
+    Fintype (Gamma0 N ⧸ heckeUpper N ℓ) :=
+  (heckeUpper N ℓ).fintypeQuotientOfFiniteIndex
+
+section CosetRep
+
+variable (N ℓ : ℕ) [NeZero ℓ]
+
+private theorem map_int_mul' (M P : Matrix (Fin 2) (Fin 2) ℤ) :
+    (M * P).map (algebraMap ℤ ℝ) = M.map (algebraMap ℤ ℝ) * P.map (algebraMap ℤ ℝ) := by
+  rw [← RingHom.mapMatrix_apply, ← RingHom.mapMatrix_apply, ← RingHom.mapMatrix_apply, map_mul]
+
+noncomputable def alphaGL : GL (Fin 2) ℝ :=
+  Matrix.GeneralLinearGroup.mkOfDetNeZero ((alphaMat ℓ).map (algebraMap ℤ ℝ)) (by
+    have h : ((alphaMat ℓ).map (algebraMap ℤ ℝ)).det = (algebraMap ℤ ℝ) (alphaMat ℓ).det := by
+      rw [← RingHom.mapMatrix_apply, ← RingHom.map_det]
+    rw [h, det_alphaMat]
+    simp [NeZero.ne ℓ])
+
+@[scoped simp]
+theorem alphaGL_coe :
+    (alphaGL ℓ : Matrix (Fin 2) (Fin 2) ℝ) = (alphaMat ℓ).map (algebraMap ℤ ℝ) :=
+  rfl
+
+theorem alphaGL_val_det : (alphaGL ℓ).val.det = (ℓ : ℝ) := by
+  change ((alphaMat ℓ).map (algebraMap ℤ ℝ)).det = (ℓ : ℝ)
+  rw [← RingHom.mapMatrix_apply, ← RingHom.map_det, det_alphaMat]
+  simp
+
+noncomputable def gammaToGL : Gamma0 N →* GL (Fin 2) ℝ :=
+  (Matrix.SpecialLinearGroup.mapGL ℝ).comp (Gamma0 N).subtype
+
+@[scoped simp]
+theorem gammaToGL_apply (x : Gamma0 N) :
+    gammaToGL N x = Matrix.SpecialLinearGroup.mapGL ℝ (x : SL(2, ℤ)) :=
+  rfl
+
+theorem gammaToGL_val_det (x : Gamma0 N) : (gammaToGL N x).val.det = 1 := by
+  rw [gammaToGL_apply, ← Matrix.GeneralLinearGroup.val_det_apply,
+    Matrix.SpecialLinearGroup.det_mapGL, Units.val_one]
+
+theorem gammaToGL_smul (x : Gamma0 N) (z : ℍ) : gammaToGL N x • z = (x : SL(2, ℤ)) • z :=
+  rfl
+
+noncomputable def heckeCosetRep (q : Gamma0 N ⧸ heckeUpper N ℓ) : GL (Fin 2) ℝ :=
+  alphaGL ℓ * gammaToGL N (Quotient.out q)⁻¹
+
+theorem heckeCosetRep_def (q : Gamma0 N ⧸ heckeUpper N ℓ) :
+    heckeCosetRep N ℓ q = alphaGL ℓ * gammaToGL N (Quotient.out q)⁻¹ :=
+  rfl
+
+theorem heckeCosetRep_val_det (q : Gamma0 N ⧸ heckeUpper N ℓ) :
+    (heckeCosetRep N ℓ q).val.det = (ℓ : ℝ) := by
+  rw [heckeCosetRep_def, Units.val_mul, Matrix.det_mul, alphaGL_val_det, gammaToGL_val_det,
+    mul_one]
+
+theorem heckeCosetRep_val_det_pos (q : Gamma0 N ⧸ heckeUpper N ℓ) :
+    0 < (heckeCosetRep N ℓ q).val.det := by
+  rw [heckeCosetRep_val_det]
+  exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne ℓ)
+
+theorem gammaToGL_heckeConj_mul_alphaGL (h : heckeUpper N ℓ) :
+    gammaToGL N (heckeConj N ℓ h) * alphaGL ℓ = alphaGL ℓ * gammaToGL N (h : Gamma0 N) := by
+  apply Units.ext
+  rw [Units.val_mul, Units.val_mul]
+  change (heckeConjMat ℓ ((((h : Gamma0 N) : SL(2, ℤ))) : Matrix (Fin 2) (Fin 2) ℤ)).map
+        (algebraMap ℤ ℝ) * ((alphaMat ℓ).map (algebraMap ℤ ℝ))
+      = ((alphaMat ℓ).map (algebraMap ℤ ℝ))
+        * ((((h : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).map (algebraMap ℤ ℝ))
+  rw [← map_int_mul', ← map_int_mul',
+    heckeConjMat_mul_alphaMat ((mem_heckeUpper N ℓ).mp h.2)]
+
+omit [NeZero ℓ] in
+theorem coe_transferAux_inv_smul (γ : Gamma0 N) (q : Gamma0 N ⧸ heckeUpper N ℓ) :
+    ((transferAux (heckeUpper N ℓ) γ (γ⁻¹ • q) : heckeUpper N ℓ) : Gamma0 N)
+      = (Quotient.out q)⁻¹ * (γ * Quotient.out (γ⁻¹ • q)) := by
+  rw [coe_transferAux, smul_inv_smul]
+
+theorem heckeCosetRep_mul_gammaToGL (γ : Gamma0 N) (q : Gamma0 N ⧸ heckeUpper N ℓ) :
+    heckeCosetRep N ℓ q * gammaToGL N γ
+      = gammaToGL N (heckeConj N ℓ (transferAux (heckeUpper N ℓ) γ (γ⁻¹ • q)))
+        * heckeCosetRep N ℓ (γ⁻¹ • q) := by
+  rw [heckeCosetRep_def, heckeCosetRep_def, ← mul_assoc, gammaToGL_heckeConj_mul_alphaGL,
+    mul_assoc, mul_assoc, ← map_mul (gammaToGL N), ← map_mul (gammaToGL N)]
+  refine congrArg (fun x : Gamma0 N => alphaGL ℓ * gammaToGL N x) ?_
+  rw [coe_transferAux_inv_smul]
+  group
+
+end CosetRep
+
+section QuotSlashSum
+
+variable (N ℓ : ℕ) [NeZero ℓ]
+
+noncomputable def heckeQuotSlashSum (k : ℤ) (f : ℍ → ℂ) : ℍ → ℂ :=
+  ∑ q : Gamma0 N ⧸ heckeUpper N ℓ, f ∣[k] heckeCosetRep N ℓ q
+
+end QuotSlashSum
+
+section Bridge
+
+variable {N : ℕ} [NeZero N] {ℓ : ℕ} [NeZero ℓ]
+
+variable (N ℓ) in
+def HeckeCosetMatch : Prop :=
+  ∃ e : Option (Fin ℓ) ≃ (Gamma0 N ⧸ heckeUpper N ℓ),
+    ∀ i : Option (Fin ℓ), ∃ δ : Gamma0 N,
+      HeckeAnalytic.repGL ℓ i = gammaToGL N δ * heckeCosetRep N ℓ (e i)
+
+omit [NeZero N] in
+theorem heckeSlashSum_eq_heckeQuotSlashSum (hmatch : HeckeCosetMatch N ℓ) (k : ℤ) {f : ℍ → ℂ}
+    (hf : ∀ γ ∈ ((Gamma0 N : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)),
+      f ∣[k] γ = f) :
+    HeckeAnalytic.heckeSlashSum k ℓ f = heckeQuotSlashSum N ℓ k f := by
+  obtain ⟨e, he⟩ := hmatch
+  rw [HeckeAnalytic.heckeSlashSum, heckeQuotSlashSum,
+    ← Equiv.sum_comp e fun q => f ∣[k] heckeCosetRep N ℓ q]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  obtain ⟨δ, hδ⟩ := he i
+  rw [hδ, SlashAction.slash_mul,
+    hf (gammaToGL N δ) (Subgroup.mem_map.mpr ⟨(δ : SL(2, ℤ)), δ.2, rfl⟩)]
+
+end Bridge
+
+open HeckeAnalytic
+
+section Representatives
+
+def unipotentUpper (N : ℕ) (t : ℤ) : Gamma0 N :=
+  ⟨⟨!![1, t; 0, 1], by rw [Matrix.det_fin_two_of]; ring⟩, by
+    rw [Gamma0_mem]
+    change ((0 : ℤ) : ZMod N) = 0
+    exact Int.cast_zero⟩
+
+theorem unipotentUpper_mul (N : ℕ) (s t : ℤ) :
+    unipotentUpper N s * unipotentUpper N t = unipotentUpper N (s + t) := by
+  refine Subtype.ext (Subtype.ext ?_)
+  change (!![1, s; 0, 1] : Matrix (Fin 2) (Fin 2) ℤ) * !![1, t; 0, 1] = !![1, s + t; 0, 1]
+  rw [Matrix.mul_fin_two]
+  refine Matrix.ext fun x y => ?_
+  fin_cases x <;> fin_cases y
+  · change (1 * 1 + s * 0 : ℤ) = 1
+    ring
+  · change (1 * t + s * 1 : ℤ) = s + t
+    ring
+  · change (0 * 1 + 1 * 0 : ℤ) = 0
+    ring
+  · change (0 * t + 1 * 1 : ℤ) = 1
+    ring
+
+theorem unipotentUpper_zero (N : ℕ) : unipotentUpper N 0 = 1 := by
+  refine Subtype.ext (Subtype.ext ?_)
+  change (!![1, 0; 0, 1] : Matrix (Fin 2) (Fin 2) ℤ) = 1
+  rw [Matrix.one_fin_two]
+
+theorem inv_unipotentUpper (N : ℕ) (t : ℤ) :
+    (unipotentUpper N t)⁻¹ = unipotentUpper N (-t) :=
+  inv_eq_of_mul_eq_one_right (by
+    rw [unipotentUpper_mul, show t + -t = 0 by ring, unipotentUpper_zero])
+
+variable {N ℓ : ℕ}
+
+theorem hecke_bezout (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) :
+    (ℓ : ℤ) * Nat.gcdA ℓ N + (N : ℤ) * Nat.gcdB ℓ N = 1 := by
+  have h := Nat.gcd_eq_gcd_ab ℓ N
+  rw [Nat.Coprime.gcd_eq_one ((Nat.Prime.coprime_iff_not_dvd hℓ).mpr hℓN)] at h
+  exact_mod_cast h.symm
+
+theorem not_dvd_gcdB (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) : ¬ (ℓ : ℤ) ∣ Nat.gcdB ℓ N := by
+  intro hdvd
+  have h1 : (ℓ : ℤ) ∣ 1 := by
+    rw [← hecke_bezout hℓ hℓN]
+    exact dvd_add (dvd_mul_right _ _) (hdvd.mul_left _)
+  have h2 : (ℓ : ℤ) ≤ 1 := Int.le_of_dvd one_pos h1
+  have h3 : (1 : ℤ) < (ℓ : ℤ) := by exact_mod_cast hℓ.one_lt
+  omega
+
+def bezoutRep (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) : Gamma0 N :=
+  ⟨⟨!![Nat.gcdA ℓ N, -Nat.gcdB ℓ N; (N : ℤ), (ℓ : ℤ)], by
+    rw [Matrix.det_fin_two_of]
+    linear_combination hecke_bezout hℓ hℓN⟩, by
+    rw [Gamma0_mem]
+    change ((N : ℤ) : ZMod N) = 0
+    rw [Int.cast_natCast]
+    exact ZMod.natCast_self N⟩
+
+def cosetRep (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) : Option (Fin ℓ) → Gamma0 N
+  | none => bezoutRep hℓ hℓN
+  | some j => unipotentUpper N (-(j : ℤ))
+
+@[scoped simp]
+theorem cosetRep_none (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) :
+    cosetRep hℓ hℓN (none : Option (Fin ℓ)) = bezoutRep hℓ hℓN :=
+  rfl
+
+@[scoped simp]
+theorem cosetRep_some (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) (j : Fin ℓ) :
+    cosetRep hℓ hℓN (some j) = unipotentUpper N (-(j : ℤ)) :=
+  rfl
+
+def rawDelta (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) : Option (Fin ℓ) → Gamma0 N
+  | none =>
+    ⟨⟨!![(ℓ : ℤ) * Nat.gcdA ℓ N, -Nat.gcdB ℓ N; (N : ℤ), 1], by
+      rw [Matrix.det_fin_two_of]
+      linear_combination hecke_bezout hℓ hℓN⟩, by
+      rw [Gamma0_mem]
+      change ((N : ℤ) : ZMod N) = 0
+      rw [Int.cast_natCast]
+      exact ZMod.natCast_self N⟩
+  | some _ => 1
+
+theorem repMat_mul_cosetRep (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) (i : Option (Fin ℓ)) :
+    repMat ℓ i * (((cosetRep hℓ hℓN i : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)
+      = (((rawDelta hℓ hℓN i : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)
+          * alphaMat ℓ := by
+  match i with
+  | none =>
+    change !![(ℓ : ℤ), 0; 0, 1] * !![Nat.gcdA ℓ N, -Nat.gcdB ℓ N; (N : ℤ), (ℓ : ℤ)]
+        = !![(ℓ : ℤ) * Nat.gcdA ℓ N, -Nat.gcdB ℓ N; (N : ℤ), 1] * !![1, 0; 0, (ℓ : ℤ)]
+    rw [Matrix.mul_fin_two, Matrix.mul_fin_two]
+    refine Matrix.ext fun x y => ?_
+    fin_cases x <;> fin_cases y
+    · change ((ℓ : ℤ) * Nat.gcdA ℓ N + 0 * (N : ℤ) : ℤ)
+        = (ℓ : ℤ) * Nat.gcdA ℓ N * 1 + -Nat.gcdB ℓ N * 0
+      ring
+    · change ((ℓ : ℤ) * -Nat.gcdB ℓ N + 0 * (ℓ : ℤ) : ℤ)
+        = (ℓ : ℤ) * Nat.gcdA ℓ N * 0 + -Nat.gcdB ℓ N * (ℓ : ℤ)
+      ring
+    · change (0 * Nat.gcdA ℓ N + 1 * (N : ℤ) : ℤ) = (N : ℤ) * 1 + 1 * 0
+      ring
+    · change (0 * -Nat.gcdB ℓ N + 1 * (ℓ : ℤ) : ℤ) = (N : ℤ) * 0 + 1 * (ℓ : ℤ)
+      ring
+  | some j =>
+    change !![1, (j : ℤ); 0, (ℓ : ℤ)] * !![1, -(j : ℤ); 0, 1]
+        = (1 : Matrix (Fin 2) (Fin 2) ℤ) * !![1, 0; 0, (ℓ : ℤ)]
+    rw [Matrix.mul_fin_two, Matrix.one_mul]
+    refine Matrix.ext fun x y => ?_
+    fin_cases x <;> fin_cases y
+    · change (1 * 1 + (j : ℤ) * 0 : ℤ) = 1
+      ring
+    · change (1 * -(j : ℤ) + (j : ℤ) * 1 : ℤ) = 0
+      ring
+    · change (0 * 1 + (ℓ : ℤ) * 0 : ℤ) = 0
+      ring
+    · change (0 * -(j : ℤ) + (ℓ : ℤ) * 1 : ℤ) = (ℓ : ℤ)
+      ring
+
+end Representatives
+
+section Bijection
+
+variable {N ℓ : ℕ}
+
+def cosetOfRep (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) (i : Option (Fin ℓ)) :
+    Gamma0 N ⧸ heckeUpper N ℓ :=
+  (cosetRep hℓ hℓN i : Gamma0 N ⧸ heckeUpper N ℓ)
+
+theorem cosetOfRep_def (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) (i : Option (Fin ℓ)) :
+    cosetOfRep hℓ hℓN i = (cosetRep hℓ hℓN i : Gamma0 N ⧸ heckeUpper N ℓ) :=
+  rfl
+
+private theorem unipotentUpper_mul_mem_iff (s t : ℤ) :
+    unipotentUpper N s * unipotentUpper N t ∈ heckeUpper N ℓ ↔ (ℓ : ℤ) ∣ (s + t) := by
+  rw [unipotentUpper_mul, mem_heckeUpper]
+  exact Iff.rfl
+
+private theorem unipotentUpper_mul_bezoutRep_not_mem (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) (s : ℤ) :
+    unipotentUpper N s * bezoutRep hℓ hℓN ∉ heckeUpper N ℓ := by
+  intro hmem
+  rw [mem_heckeUpper] at hmem
+  have hentry : (((unipotentUpper N s * bezoutRep hℓ hℓN : Gamma0 N) : SL(2, ℤ))) 0 1
+      = 1 * -Nat.gcdB ℓ N + s * (ℓ : ℤ) :=
+    (Matrix.two_mul_expl
+      (((unipotentUpper N s : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)
+      (((bezoutRep hℓ hℓN : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)).2.1
+  rw [hentry,
+    show (1 : ℤ) * -Nat.gcdB ℓ N + s * (ℓ : ℤ) = s * (ℓ : ℤ) - Nat.gcdB ℓ N by ring] at hmem
+  exact not_dvd_gcdB hℓ hℓN ((dvd_sub_right (dvd_mul_left _ _)).mp hmem)
+
+theorem cosetOfRep_injective (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) :
+    Function.Injective (cosetOfRep (N := N) hℓ hℓN) := by
+  intro i i' h
+  rw [cosetOfRep_def, cosetOfRep_def, QuotientGroup.eq] at h
+  match i, i' with
+  | none, none => rfl
+  | some j, none =>
+    exact absurd h (by
+      rw [cosetRep_some, cosetRep_none, inv_unipotentUpper, neg_neg]
+      exact unipotentUpper_mul_bezoutRep_not_mem hℓ hℓN (j : ℤ))
+  | none, some j' =>
+    refine absurd ((heckeUpper N ℓ).inv_mem h) ?_
+    rw [cosetRep_some, cosetRep_none, _root_.mul_inv_rev, inv_inv, inv_unipotentUpper, neg_neg]
+    exact unipotentUpper_mul_bezoutRep_not_mem hℓ hℓN (j' : ℤ)
+  | some j, some j' =>
+    rw [cosetRep_some, cosetRep_some, inv_unipotentUpper, neg_neg,
+      unipotentUpper_mul_mem_iff] at h
+    have hj := j.isLt
+    have hj' := j'.isLt
+    have hzero : (j : ℤ) + -(j' : ℤ) = 0 := by
+      refine Int.eq_zero_of_dvd_of_natAbs_lt_natAbs h ?_
+      rw [Int.natAbs_natCast]
+      omega
+    have hval : (j : ℕ) = (j' : ℕ) := by omega
+    exact congrArg some (Fin.ext hval)
+
+private theorem dvd_of_alphaMat_mul_eq_mul_alphaMat {X Y : Matrix (Fin 2) (Fin 2) ℤ}
+    (h : alphaMat ℓ * X = Y * alphaMat ℓ) : (ℓ : ℤ) ∣ X 0 1 := by
+  have h01 : (alphaMat ℓ * X) 0 1 = (Y * alphaMat ℓ) 0 1 := by rw [h]
+  rw [(Matrix.two_mul_expl (alphaMat ℓ) X).2.1, (Matrix.two_mul_expl Y (alphaMat ℓ)).2.1,
+    alphaMat_apply_zero_zero, alphaMat_apply_zero_one, alphaMat_apply_one_one] at h01
+  exact ⟨Y 0 1, by linear_combination h01⟩
+
+private theorem repMat_some_zero (hpos : 0 < ℓ) : repMat ℓ (some ⟨0, hpos⟩) = alphaMat ℓ := by
+  rw [repMat_some]
+  rfl
+
+theorem cosetOfRep_surjective (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) :
+    Function.Surjective (cosetOfRep (N := N) hℓ hℓN) := by
+  intro q
+  obtain ⟨γ, rfl⟩ : ∃ γ : Gamma0 N, (γ : Gamma0 N ⧸ heckeUpper N ℓ) = q :=
+    ⟨Quotient.out q, QuotientGroup.out_eq' q⟩
+  obtain ⟨δ, -, m, hm⟩ := exists_cocycle hℓ hℓN (γ⁻¹ : Gamma0 N).2 (some ⟨0, hℓ.pos⟩)
+  refine ⟨m, ?_⟩
+  rw [cosetOfRep_def, QuotientGroup.eq, ← (heckeUpper N ℓ).inv_mem_iff, _root_.mul_inv_rev,
+    inv_inv, mem_heckeUpper]
+  refine dvd_of_alphaMat_mul_eq_mul_alphaMat
+    (Y := (δ : Matrix (Fin 2) (Fin 2) ℤ)
+      * (((rawDelta hℓ hℓN m : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)) ?_
+  have hcoe : (((γ⁻¹ * cosetRep hℓ hℓN m : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)
+      = (((γ⁻¹ : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)
+        * (((cosetRep hℓ hℓN m : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) :=
+    rfl
+  calc alphaMat ℓ
+      * (((γ⁻¹ * cosetRep hℓ hℓN m : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)
+      = (alphaMat ℓ * (((γ⁻¹ : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ))
+          * (((cosetRep hℓ hℓN m : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) := by
+        rw [hcoe, mul_assoc]
+    _ = (repMat ℓ (some ⟨0, hℓ.pos⟩)
+          * (((γ⁻¹ : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ))
+          * (((cosetRep hℓ hℓN m : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) := by
+        rw [repMat_some_zero hℓ.pos]
+    _ = ((δ : Matrix (Fin 2) (Fin 2) ℤ) * repMat ℓ m)
+          * (((cosetRep hℓ hℓN m : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) := by
+        rw [hm]
+    _ = (δ : Matrix (Fin 2) (Fin 2) ℤ) * (repMat ℓ m
+          * (((cosetRep hℓ hℓN m : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)) := by
+        rw [mul_assoc]
+    _ = (δ : Matrix (Fin 2) (Fin 2) ℤ)
+          * ((((rawDelta hℓ hℓN m : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)
+            * alphaMat ℓ) := by
+        rw [repMat_mul_cosetRep]
+    _ = ((δ : Matrix (Fin 2) (Fin 2) ℤ)
+          * (((rawDelta hℓ hℓN m : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ))
+          * alphaMat ℓ := by
+        rw [mul_assoc]
+
+noncomputable def heckeCosetEquiv (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) :
+    Option (Fin ℓ) ≃ (Gamma0 N ⧸ heckeUpper N ℓ) :=
+  Equiv.ofBijective (cosetOfRep hℓ hℓN)
+    ⟨cosetOfRep_injective hℓ hℓN, cosetOfRep_surjective hℓ hℓN⟩
+
+@[scoped simp]
+theorem heckeCosetEquiv_apply (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) (i : Option (Fin ℓ)) :
+    heckeCosetEquiv hℓ hℓN i = (cosetRep hℓ hℓN i : Gamma0 N ⧸ heckeUpper N ℓ) :=
+  rfl
+
+end Bijection
+
+section CosetMatch
+
+variable {N ℓ : ℕ} [NeZero ℓ]
+
+private theorem map_int_mul'' (M P : Matrix (Fin 2) (Fin 2) ℤ) :
+    (M * P).map (algebraMap ℤ ℝ) = M.map (algebraMap ℤ ℝ) * P.map (algebraMap ℤ ℝ) := by
+  rw [← RingHom.mapMatrix_apply, ← RingHom.mapMatrix_apply, ← RingHom.mapMatrix_apply, map_mul]
+
+theorem repGL_eq_rawDelta_mul (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) (i : Option (Fin ℓ)) :
+    repGL ℓ i = gammaToGL N (rawDelta hℓ hℓN i)
+      * (alphaGL ℓ * gammaToGL N (cosetRep hℓ hℓN i)⁻¹) := by
+  have key : repGL ℓ i * gammaToGL N (cosetRep hℓ hℓN i)
+      = gammaToGL N (rawDelta hℓ hℓN i) * alphaGL ℓ := by
+    apply Units.ext
+    rw [Units.val_mul, Units.val_mul]
+    change (repMat ℓ i).map (algebraMap ℤ ℝ)
+        * ((((cosetRep hℓ hℓN i : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).map
+            (algebraMap ℤ ℝ))
+      = ((((rawDelta hℓ hℓN i : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).map
+            (algebraMap ℤ ℝ))
+        * ((alphaMat ℓ).map (algebraMap ℤ ℝ))
+    rw [← map_int_mul'', ← map_int_mul'', repMat_mul_cosetRep]
+  calc repGL ℓ i
+      = (repGL ℓ i * gammaToGL N (cosetRep hℓ hℓN i))
+          * (gammaToGL N (cosetRep hℓ hℓN i))⁻¹ := by
+        rw [mul_assoc, mul_inv_cancel, mul_one]
+    _ = (gammaToGL N (rawDelta hℓ hℓN i) * alphaGL ℓ)
+          * (gammaToGL N (cosetRep hℓ hℓN i))⁻¹ := by
+        rw [key]
+    _ = gammaToGL N (rawDelta hℓ hℓN i)
+          * (alphaGL ℓ * gammaToGL N (cosetRep hℓ hℓN i)⁻¹) := by
+        rw [mul_assoc, map_inv]
+
+theorem exists_heckeCosetRep_coe_eq (γ : Gamma0 N) :
+    ∃ ε : Gamma0 N, heckeCosetRep N ℓ (γ : Gamma0 N ⧸ heckeUpper N ℓ)
+      = gammaToGL N ε * (alphaGL ℓ * gammaToGL N γ⁻¹) := by
+  obtain ⟨h, hout⟩ := QuotientGroup.mk_out_eq_mul (heckeUpper N ℓ) γ
+  refine ⟨heckeConj N ℓ h⁻¹, ?_⟩
+  rw [heckeCosetRep_def,
+    show Quotient.out ((γ : Gamma0 N ⧸ heckeUpper N ℓ)) = γ * (h : Gamma0 N) from hout,
+    _root_.mul_inv_rev, map_mul, ← mul_assoc, ← mul_assoc]
+  congr 1
+  exact (gammaToGL_heckeConj_mul_alphaGL N ℓ h⁻¹).symm
+
+theorem heckeCosetMatch (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) : HeckeCosetMatch N ℓ := by
+  refine ⟨heckeCosetEquiv hℓ hℓN, fun i => ?_⟩
+  obtain ⟨ε, hε⟩ := exists_heckeCosetRep_coe_eq (ℓ := ℓ) (cosetRep hℓ hℓN i)
+  refine ⟨rawDelta hℓ hℓN i * ε⁻¹, ?_⟩
+  rw [show heckeCosetEquiv hℓ hℓN i = (cosetRep hℓ hℓN i : Gamma0 N ⧸ heckeUpper N ℓ) from rfl,
+    hε, map_mul, map_inv, mul_assoc, ← mul_assoc ((gammaToGL N ε)⁻¹), inv_mul_cancel, one_mul]
+  exact repGL_eq_rawDelta_mul hℓ hℓN i
+
+end CosetMatch
+end HeckeEis.HeckeESSol
+end
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_mul binarySubst_mem binaryFormRepSL \
+  binaryFormRepSL_apply_coe binaryFormAlphaAdj binaryFormAlphaAdj_apply_coe alphaMat \
+  alphaMat_apply_zero_zero alphaMat_apply_zero_one alphaMat_apply_one_one det_alphaMat \
+  heckeConjMat heckeConjMat_mul_alphaMat heckeUpper mem_heckeUpper heckeConj transferAux \
+  coe_transferAux HeckeIndexEq IsParabolicCocycle coeffParabolicCocycles coeffH1par coeffH1parMk \
+  coeffHeckeFun coeffHeckeFun_apply IsEquivariantPrimitiveWith IsEquivariantPrimitiveWith.cocycle \
+  IsEichlerIntegral eichlerShimuraMap binaryFormAlphaAdj_comp_binaryFormRepSL_heckeConj \
+  exists_isEichlerIntegral_isParabolicCocycle isParabolicCocycle_cocycle_of_isEichlerIntegral \
+  eichlerShimuraMap_eq_coeffH1parMk"
+namespace HeckeESSol
+p2m_open "HeckeEis"
+
+open UpperHalfPlane MvPolynomial CongruenceSubgroup Matrix
+open scoped Manifold MatrixGroups ModularForm
+
+noncomputable local instance (N ℓ : ℕ) [NeZero ℓ] :
+    Fintype (Gamma0 N ⧸ heckeUpper N ℓ) :=
+  (heckeUpper N ℓ).fintypeQuotientOfFiniteIndex
+
+section CoeffTelescoping
+
+variable {N ℓ : ℕ} [NeZero ℓ] {n : ℕ}
+
+variable (N ℓ n) in
+def cosetOp (q : Gamma0 N ⧸ heckeUpper N ℓ) : ↥(BinaryForm ℂ n) →ₗ[ℂ] ↥(BinaryForm ℂ n) :=
+  ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (Quotient.out q) ∘ₗ binaryFormAlphaAdj ℂ n ℓ
+
+variable (N ℓ n) in
+def heckeEichler (F : ℍ → ↥(BinaryForm ℂ n)) (z : ℍ) : ↥(BinaryForm ℂ n) :=
+  ∑ q : Gamma0 N ⧸ heckeUpper N ℓ, cosetOp N ℓ n q (F (heckeCosetRep N ℓ q • z))
+
+theorem smul_smul_eq (γ : Gamma0 N) (q : Gamma0 N ⧸ heckeUpper N ℓ) (z : ℍ) :
+    heckeCosetRep N ℓ q • ((γ : SL(2, ℤ)) • z)
+      = ((heckeConj N ℓ (transferAux (heckeUpper N ℓ) γ (γ⁻¹ • q)) : Gamma0 N) : SL(2, ℤ))
+          • (heckeCosetRep N ℓ (γ⁻¹ • q) • z) := by
+  rw [show ((γ : SL(2, ℤ)) • z) = gammaToGL N γ • z from rfl, ← mul_smul,
+    heckeCosetRep_mul_gammaToGL, mul_smul]
+  rfl
+
+theorem cosetOp_heckeConj_apply (γ : Gamma0 N) (q : Gamma0 N ⧸ heckeUpper N ℓ)
+    (v : ↥(BinaryForm ℂ n)) :
+    cosetOp N ℓ n q (((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (heckeConj N ℓ (transferAux
+      (heckeUpper N ℓ) γ (γ⁻¹ • q))) v)
+      = ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) γ (cosetOp N ℓ n (γ⁻¹ • q) v) := by
+  have h1 := LinearMap.congr_fun
+    (HeckeEis.binaryFormAlphaAdj_comp_binaryFormRepSL_heckeConj ℂ n N ℓ (transferAux (heckeUpper N
+      ℓ) γ (γ⁻¹ • q))) v
+  rw [LinearMap.comp_apply, LinearMap.comp_apply] at h1
+  rw [cosetOp, cosetOp, LinearMap.comp_apply, LinearMap.comp_apply, h1, ← Module.End.mul_apply, ←
+    map_mul,
+    coe_transferAux_inv_smul, mul_inv_cancel_left, map_mul, Module.End.mul_apply]
+
+theorem cosetOp_apply_smul {F : ℍ → ↥(BinaryForm ℂ n)}
+    (hF : IsEquivariantPrimitiveWith ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) F)
+    (γ : Gamma0 N) (q : Gamma0 N ⧸ heckeUpper N ℓ) (z : ℍ) :
+    cosetOp N ℓ n q (F (heckeCosetRep N ℓ q • ((γ : SL(2, ℤ)) • z)))
+      = cosetOp N ℓ n q (hF.cocycle (heckeConj N ℓ (transferAux (heckeUpper N ℓ) γ (γ⁻¹ • q))))
+        + ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) γ (cosetOp N ℓ n (γ⁻¹ • q) (F
+          (heckeCosetRep N ℓ (γ⁻¹ • q) • z))) := by
+  rw [smul_smul_eq, hF.apply_smul, map_add, cosetOp_heckeConj_apply]
+
+theorem sum_cosetOp_cocycle {F : ℍ → ↥(BinaryForm ℂ n)}
+    (hF : IsEquivariantPrimitiveWith ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) F)
+    (γ : Gamma0 N) :
+    ∑ q : Gamma0 N ⧸ heckeUpper N ℓ,
+        cosetOp N ℓ n (γ • q) (hF.cocycle (heckeConj N ℓ (transferAux (heckeUpper N ℓ) γ q)))
+      = coeffHeckeFun N ℓ ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (binaryFormAlphaAdj ℂ n ℓ)
+        hF.cocycle γ := by
+  rw [coeffHeckeFun_apply]
+  refine Finset.sum_congr rfl fun q _ => ?_
+  rw [cosetOp, LinearMap.comp_apply]
+
+theorem sum_cosetOp_smul {F : ℍ → ↥(BinaryForm ℂ n)}
+    (hF : IsEquivariantPrimitiveWith ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) F)
+    (γ : Gamma0 N) (z : ℍ) :
+    ∑ q : Gamma0 N ⧸ heckeUpper N ℓ, cosetOp N ℓ n q (F (heckeCosetRep N ℓ q • ((γ : SL(2, ℤ)) •
+      z)))
+      = coeffHeckeFun N ℓ ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (binaryFormAlphaAdj ℂ n ℓ)
+        hF.cocycle γ
+        + ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) γ (∑ q : Gamma0 N ⧸ heckeUpper N ℓ,
+          cosetOp N ℓ n q (F (heckeCosetRep N ℓ q • z))) := by
+  calc ∑ q : Gamma0 N ⧸ heckeUpper N ℓ, cosetOp N ℓ n q (F (heckeCosetRep N ℓ q • ((γ : SL(2, ℤ)) •
+    z)))
+      = ∑ q : Gamma0 N ⧸ heckeUpper N ℓ,
+          (cosetOp N ℓ n q (hF.cocycle (heckeConj N ℓ (transferAux (heckeUpper N ℓ) γ (γ⁻¹ • q))))
+            + ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) γ (cosetOp N ℓ n (γ⁻¹ • q) (F
+              (heckeCosetRep N ℓ (γ⁻¹ • q) • z)))) :=
+        Finset.sum_congr rfl fun q _ => cosetOp_apply_smul hF γ q z
+    _ = (∑ q : Gamma0 N ⧸ heckeUpper N ℓ,
+            cosetOp N ℓ n q (hF.cocycle (heckeConj N ℓ (transferAux (heckeUpper N ℓ) γ (γ⁻¹ • q)))))
+          + ∑ q : Gamma0 N ⧸ heckeUpper N ℓ,
+            ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) γ (cosetOp N ℓ n (γ⁻¹ • q) (F
+              (heckeCosetRep N ℓ (γ⁻¹ • q) • z))) :=
+        Finset.sum_add_distrib
+    _ = (∑ q : Gamma0 N ⧸ heckeUpper N ℓ,
+            cosetOp N ℓ n (γ • q) (hF.cocycle (heckeConj N ℓ (transferAux (heckeUpper N ℓ) γ q))))
+          + ∑ q : Gamma0 N ⧸ heckeUpper N ℓ,
+            ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) γ (cosetOp N ℓ n q (F (heckeCosetRep N ℓ
+              q • z))) := by
+        rw [(MulAction.bijective (γ⁻¹ : Gamma0 N)).sum_comp
+            (fun q : Gamma0 N ⧸ heckeUpper N ℓ => ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) γ
+          (cosetOp N ℓ n q (F (heckeCosetRep N ℓ q • z)))),
+          ← (MulAction.bijective (γ : Gamma0 N)).sum_comp
+            (fun q : Gamma0 N ⧸ heckeUpper N ℓ =>
+              cosetOp N ℓ n q (hF.cocycle (heckeConj N ℓ (transferAux (heckeUpper N ℓ) γ (γ⁻¹ •
+          q)))))]
+        simp only [inv_smul_smul]
+    _ = coeffHeckeFun N ℓ ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (binaryFormAlphaAdj ℂ n ℓ)
+      hF.cocycle γ
+          + ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) γ (∑ q : Gamma0 N ⧸ heckeUpper N ℓ,
+            cosetOp N ℓ n q (F (heckeCosetRep N ℓ q • z))) := by
+        rw [sum_cosetOp_cocycle hF γ, map_sum]
+
+theorem heckeEichler_smul {F : ℍ → ↥(BinaryForm ℂ n)}
+    (hF : IsEquivariantPrimitiveWith ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) F)
+    (γ : Gamma0 N) (z : ℍ) :
+    heckeEichler N ℓ n F ((γ : SL(2, ℤ)) • z)
+      = coeffHeckeFun N ℓ ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (binaryFormAlphaAdj ℂ n ℓ)
+        hF.cocycle γ
+        + ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) γ (heckeEichler N ℓ n F z) :=
+  sum_cosetOp_smul hF γ z
+
+theorem isEquivariantPrimitiveWith_heckeEichler {F : ℍ → ↥(BinaryForm ℂ n)}
+    (hF : IsEquivariantPrimitiveWith ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) F) :
+    IsEquivariantPrimitiveWith ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (heckeEichler N ℓ n
+      F) := fun γ =>
+  ⟨coeffHeckeFun N ℓ ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (binaryFormAlphaAdj ℂ n ℓ)
+    hF.cocycle γ, fun z => by
+    rw [heckeEichler_smul hF, add_sub_cancel_right]⟩
+
+theorem cocycle_heckeEichler {F : ℍ → ↥(BinaryForm ℂ n)}
+    (hF : IsEquivariantPrimitiveWith ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) F) :
+    (isEquivariantPrimitiveWith_heckeEichler (ℓ := ℓ) hF).cocycle
+      = coeffHeckeFun N ℓ ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (binaryFormAlphaAdj ℂ n ℓ)
+        hF.cocycle := by
+  funext γ
+  rw [IsEquivariantPrimitiveWith.cocycle, heckeEichler_smul hF, add_sub_cancel_right]
+
+end CoeffTelescoping
+
+section EichlerSum
+
+variable {N ℓ : ℕ} [NeZero ℓ] {n : ℕ}
+
+theorem isEichlerIntegral_sum {ι : Type*} (s : Finset ι) {f : ι → ℍ → ℂ}
+    {F : ι → ℍ → ↥(BinaryForm ℂ n)}
+    (h : ∀ i ∈ s, IsEichlerIntegral n (f i) (F i)) :
+    IsEichlerIntegral n (∑ i ∈ s, f i) (fun z => ∑ i ∈ s, F i z) := by
+  intro d τ
+  have hfun : (fun z : ℂ => AddMonoidAlgebra.coeff
+      ((∑ i ∈ s, F i (ofComplex z) : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) d)
+      = fun z : ℂ => ∑ i ∈ s, AddMonoidAlgebra.coeff
+        ((F i (ofComplex z) : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) d := by
+    funext z
+    rw [Submodule.coe_sum, coeff_sum]
+  rw [hfun, Finset.sum_apply, Finset.sum_mul]
+  exact HasDerivAt.fun_sum fun i hi => h i hi d τ
+
+def cosetMat (q : Gamma0 N ⧸ heckeUpper N ℓ) : Matrix (Fin 2) (Fin 2) ℤ :=
+  alphaMat ℓ * ((((Quotient.out q)⁻¹ : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)
+
+omit [NeZero ℓ] in
+theorem det_cosetMat (q : Gamma0 N ⧸ heckeUpper N ℓ) : (cosetMat (ℓ := ℓ) q).det = ℓ := by
+  rw [cosetMat, Matrix.det_mul, det_alphaMat, Matrix.SpecialLinearGroup.det_coe, mul_one]
+
+theorem coe_heckeCosetRep (q : Gamma0 N ⧸ heckeUpper N ℓ) :
+    ((heckeCosetRep N ℓ q : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) = (cosetMat q).map (algebraMap
+      ℤ ℝ) := by
+  rw [heckeCosetRep_def, Units.val_mul, alphaGL_coe, gammaToGL_apply,
+    Matrix.SpecialLinearGroup.mapGL_coe_matrix,
+    Matrix.SpecialLinearGroup.map_apply_coe, RingHom.mapMatrix_apply, cosetMat, ← map_int_mul']
+
+omit [NeZero ℓ] in
+theorem adjugate_cosetMat (q : Gamma0 N ⧸ heckeUpper N ℓ) :
+    (cosetMat (ℓ := ℓ) q).adjugate
+      = (((Quotient.out q : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) * !![(ℓ : ℤ), 0; 0, 1]
+        := by
+  rw [cosetMat, Matrix.adjugate_mul_distrib, ← Matrix.SpecialLinearGroup.coe_inv, Subgroup.coe_inv,
+    inv_inv]
+  congr 1
+  rw [alphaMat, Matrix.adjugate_fin_two]
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp
+
+omit [NeZero ℓ] in
+theorem cosetOp_apply_eq (q : Gamma0 N ⧸ heckeUpper N ℓ) (v : ↥(BinaryForm ℂ n)) :
+    cosetOp N ℓ n q v = ((binarySubst ℂ (cosetMat (ℓ := ℓ) q).adjugate).toLinearMap.restrict
+        (fun _ h => binarySubst_mem ℂ (cosetMat (ℓ := ℓ) q).adjugate h)) v := by
+  apply Subtype.ext
+  rw [cosetOp, LinearMap.comp_apply]
+  change ((((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (Quotient.out q)) (binaryFormAlphaAdj ℂ n
+    ℓ v) : MvPolynomial (Fin 2) ℂ)
+    = binarySubst ℂ (cosetMat (ℓ := ℓ) q).adjugate v
+  rw [MonoidHom.comp_apply, Subgroup.coe_subtype, binaryFormRepSL_apply_coe,
+    binaryFormAlphaAdj_apply_coe,
+    adjugate_cosetMat, binarySubst_mul, AlgHom.comp_apply]
+
+theorem isEichlerIntegral_heckeEichler {f : ℍ → ℂ} {F : ℍ → ↥(BinaryForm ℂ n)}
+    (hF : IsEichlerIntegral n f F) :
+    IsEichlerIntegral n (heckeQuotSlashSum N ℓ ((n : ℤ) + 2) f) (heckeEichler N ℓ n F) := by
+  have h := isEichlerIntegral_sum (Finset.univ : Finset (Gamma0 N ⧸ heckeUpper N ℓ))
+    (f := fun q => f ∣[((n : ℤ) + 2)] heckeCosetRep N ℓ q)
+    (F := fun q z => cosetOp N ℓ n q (F (heckeCosetRep N ℓ q • z)))
+    (fun q _ => by
+      have hq := hF.binarySubst_adjugate_comp_smul (M := cosetMat (ℓ := ℓ) q)
+        (by
+          rw [det_cosetMat]; exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne ℓ)) (coe_heckeCosetRep q)
+      intro d τ
+      have := hq d τ
+      simp only [← cosetOp_apply_eq] at this
+      exact this)
+  exact h
+
+end EichlerSum
+end HeckeEis.HeckeESSol
+end
+
+open _root_.HeckeEis _root_.P2MW.S_HeckeEis_eichlerShimuraMap_heckeTLin.HeckeEis HeckeEis.HeckeESSol
+  CongruenceSubgroup in
+theorem solution (N : ℕ) [NeZero N] (n : ℕ) {ℓ : ℕ} (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N)
+    (T : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+      N).subtype) →ₗ[ℂ]
+      HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+        N).subtype))
+    (hT : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+        ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+          (CongruenceSubgroup.Gamma0 N).subtype)),
+          haveI : NeZero ℓ := ⟨hℓ.ne_zero⟩
+          (w : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n))
+              = HeckeEis.coeffHeckeFun N ℓ ((HeckeEis.binaryFormRepSL ℂ n).comp
+                (CongruenceSubgroup.Gamma0 N).subtype) (HeckeEis.binaryFormAlphaAdj ℂ n ℓ) z ∧
+            T (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w)
+    (f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2)) :
+    T (HeckeEis.eichlerShimuraMap n N f)
+      = HeckeEis.eichlerShimuraMap n N (CuspForm.heckeTLin ((n : ℤ) + 2) hℓ hℓN f) := by
+  have : NeZero ℓ := ⟨hℓ.ne_zero⟩
+  obtain ⟨F, hEI, hF, hpar⟩ := HeckeEis.exists_isEichlerIntegral_isParabolicCocycle N n f
+  have hGEI : IsEichlerIntegral n (CuspForm.heckeTLin ((n : ℤ) + 2) hℓ hℓN f) (heckeEichler N ℓ n F)
+    :=
+    by
+    have h := isEichlerIntegral_heckeEichler (N := N) (ℓ := ℓ) hEI
+    rwa [← heckeSlashSum_eq_heckeQuotSlashSum (heckeCosetMatch hℓ hℓN) _
+      (SlashInvariantFormClass.slash_action_eq f),
+      HeckeAnalytic.heckeSlashSum_eq_heckeT, ← CuspForm.coe_heckeTLin_apply ((n : ℤ) + 2) hℓ hℓN
+      f] at h
+  have hG := isEquivariantPrimitiveWith_heckeEichler (ℓ := ℓ) hF
+  have hGc := cocycle_heckeEichler (ℓ := ℓ) hF
+  have hGpar : IsParabolicCocycle ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) hG.cocycle :=
+    HeckeEis.isParabolicCocycle_cocycle_of_isEichlerIntegral N n _ hGEI hG
+  rw [HeckeEis.eichlerShimuraMap_eq_coeffH1parMk n N _ hGEI hG hGpar,
+    HeckeEis.eichlerShimuraMap_eq_coeffH1parMk n N _ hEI hF hpar]
+  obtain ⟨w, hw, hTw⟩ := hT ⟨hF.cocycle, hF.cocycle_mem_coeffCocycles, hpar⟩
+  rw [hTw]
+  congr 1
+  exact Subtype.ext (hw.trans hGc.symm)
+
+end S_HeckeEis_eichlerShimuraMap_heckeTLin
+end P2MW
+export P2MW.S_HeckeEis_eichlerShimuraMap_heckeTLin (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Manifold MatrixGroups
+theorem HeckeEis.eichlerShimuraMap_heckeTLin (N : ℕ) [NeZero N] (n : ℕ) {ℓ : ℕ} (hℓ : ℓ.Prime)
+    (hℓN : ¬ ℓ ∣ N)
+    (T : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+      N).subtype) →ₗ[ℂ]
+      HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+        N).subtype))
+    (hT : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+        ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+          (CongruenceSubgroup.Gamma0 N).subtype)),
+          haveI : NeZero ℓ := ⟨hℓ.ne_zero⟩
+          (w : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n))
+              = HeckeEis.coeffHeckeFun N ℓ ((HeckeEis.binaryFormRepSL ℂ n).comp
+                (CongruenceSubgroup.Gamma0 N).subtype) (HeckeEis.binaryFormAlphaAdj ℂ n ℓ) z ∧
+            T (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w)
+    (f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2)) :
+    T (HeckeEis.eichlerShimuraMap n N f)
+      = HeckeEis.eichlerShimuraMap n N (CuspForm.heckeTLin ((n : ℤ) + 2) hℓ hℓN f) :=
+  solution N n hℓ hℓN T hT f
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_eichlerShimuraMap_heckeULin.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_eichlerShimuraMap_heckeULin.lean
new file mode 100644
index 0000000000..9b1084c5e1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_eichlerShimuraMap_heckeULin.lean
@@ -0,0 +1,768 @@
+/-
+Based on Prove2Me node HeckeEis.eichlerShimuraMap_heckeULin
+(86a702c9-a5e9-5ffc-8a19-ad22691fe76d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b1ad3626-3786-5318-a545-5b1cbe210850
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperatorForms
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_binarySubst_adjugate_comp_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_binaryFormAlphaAdj_comp_binaryFormRepSL_heckeConj
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_eichlerShimuraMap_eq_coeffH1parMk
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_isEichlerIntegral_isParabolicCocycle
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_isParabolicCocycle_cocycle_of_isEichlerIntegral
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Eichler–Shimura map intertwines U_ℓ for ℓ ∣ N
+
+Theorem statement: `HeckeEis.eichlerShimuraMap_heckeULin` (`86a702c9-a5e9-5ffc-8a19-ad22691fe76d`),
+by Claude, 2026-09-05.
+
+Proof: submission `b1ad3626-3786-5318-a545-5b1cbe210850`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N \ge 1$ and $n \ge 0$, a prime $\ell$ with $\ell \mid N$, and write $\rho$ for the
+representation `(HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype`, i.e. the
+action of $\Gamma_0(N) \le \mathrm{SL}_2(\mathbb{Z})$ by substitution on the space
+[`HeckeEis.BinaryForm ℂ n`](def/HeckeEis_BinaryFormRep.html#L25) of degree-$n$ homogeneous
+polynomials in two variables over $\mathbb{C}$. Here
+[`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100) $\rho$ is the quotient of the submodule
+of parabolic cocycles — functions $z : \Gamma_0(N) \to$ `BinaryForm ℂ n` with $z(gh) = z(g) +
+\rho(g)z(h)$ and $z(\gamma) \in \operatorname{range}(\rho(\gamma) - 1)$ whenever
+$\operatorname{tr}(\gamma)^2 = 4$ — by the coboundaries lying in it. Let $T$ be a
+$\mathbb{C}$-linear endomorphism of this quotient which is assumed to be induced by the
+cochain-level operator: for every parabolic cocycle $z$ there is a parabolic cocycle $w$ whose
+underlying function equals [`HeckeEis.coeffHeckeFun N ℓ`](def/Gamma0CoeffCohomology.html#L129)
+$\rho$ applied to $z$ with coefficient map [`HeckeEis.binaryFormAlphaAdj ℂ n
+ℓ`](def/HeckeEis_BinaryFormRep.html#L82) (substitution by $\mathrm{diag}(\ell,1)$), namely $g
+\mapsto \sum_{q \in \Gamma_0(N)/\,\mathrm{heckeUpper}\,N\,\ell} \rho((g\cdot
+q)^{\mathrm{out}})\bigl(a\,z(\mathrm{heckeConj}\,N\,\ell\,(\mathrm{transferAux}\;g\;q))\bigr)$, and
+such that $T[z] = [w]$. Then for every cusp form $f$ of weight $(n:\mathbb{Z})+2$ on $\Gamma_0(N)$
+one has $T(\mathrm{ES}(f)) = \mathrm{ES}(U_\ell f)$, where $\mathrm{ES} =$
+[`HeckeEis.eichlerShimuraMap n N`](def/HeckeEis_EichlerIntegral.html#L114) and $U_\ell =$
+[`CuspForm.heckeULin ((n : ℤ) + 2) hℓN`](def/ModularForm_HeckeOperatorForms.html#L83).
+
+This is the Hecke-equivariance of the Eichler–Shimura map at the primes dividing the level: the
+degeneracy operator $U_\ell$ on cusp forms of weight $n+2$ corresponds to the cochain-level Hecke
+operator at $\ell$ on parabolic cohomology with coefficients in binary forms of degree $n$. Together
+with the companion statement for primes not dividing $N$ it feeds
+[`HeckeEis.exists_eichlerShimura_coeffH1par_binaryFormRepSL_forall_prime`]
+(thm.html#HeckeEis.exists_eichlerShimura_coeffH1par_binaryFormRepSL_forall_prime),
+which records equivariance simultaneously at all primes.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_eichlerShimuraMap_heckeULin.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_eichlerShimuraMap_heckeULin
+
+
+open scoped Manifold MatrixGroups
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_mul binarySubst_mem binaryFormRepSL \
+  binaryFormRepSL_apply_coe binaryFormAlphaAdj binaryFormAlphaAdj_apply_coe alphaMat det_alphaMat \
+  heckeConjMat heckeConjMat_mul_alphaMat heckeUpper mem_heckeUpper heckeConj transferAux \
+  coe_transferAux IsParabolicCocycle coeffParabolicCocycles coeffH1par coeffH1parMk coeffHeckeFun \
+  coeffHeckeFun_apply IsEquivariantPrimitiveWith IsEquivariantPrimitiveWith.cocycle \
+  IsEichlerIntegral eichlerShimuraMap binaryFormAlphaAdj_comp_binaryFormRepSL_heckeConj \
+  exists_isEichlerIntegral_isParabolicCocycle isParabolicCocycle_cocycle_of_isEichlerIntegral \
+  eichlerShimuraMap_eq_coeffH1parMk"
+namespace HeckeESSol
+p2m_open "HeckeEis"
+
+open UpperHalfPlane Filter Topology Complex
+open scoped MatrixGroups ModularForm
+
+namespace HeckeAnalytic
+
+open Matrix CongruenceSubgroup
+
+def repMat (ℓ : ℕ) : Option (Fin ℓ) → Matrix (Fin 2) (Fin 2) ℤ
+  | none => !![(ℓ : ℤ), 0; 0, 1]
+  | some j => !![1, (j : ℤ); 0, (ℓ : ℤ)]
+
+@[scoped simp] lemma repMat_none (ℓ : ℕ) : repMat ℓ none = !![(ℓ : ℤ), 0; 0, 1] := rfl
+
+@[scoped simp] lemma repMat_some (ℓ : ℕ) (j : Fin ℓ) :
+    repMat ℓ (some j) = !![1, (j : ℤ); 0, (ℓ : ℤ)] :=
+  rfl
+
+lemma det_repMat (ℓ : ℕ) (i : Option (Fin ℓ)) : (repMat ℓ i).det = (ℓ : ℤ) := by
+  cases i <;> simp [repMat, Matrix.det_fin_two_of]
+
+def repGL (ℓ : ℕ) [NeZero ℓ] (i : Option (Fin ℓ)) : GL (Fin 2) ℝ :=
+  Matrix.GeneralLinearGroup.mkOfDetNeZero ((repMat ℓ i).map (algebraMap ℤ ℝ)) (by
+    have h : ((repMat ℓ i).map (algebraMap ℤ ℝ)).det = (algebraMap ℤ ℝ) (repMat ℓ i).det := by
+      rw [← RingHom.mapMatrix_apply, ← RingHom.map_det]
+    rw [h, det_repMat]
+    simp [NeZero.ne ℓ])
+
+@[scoped simp] lemma repGL_coe (ℓ : ℕ) [NeZero ℓ] (i : Option (Fin ℓ)) :
+    (repGL ℓ i : Matrix (Fin 2) (Fin 2) ℝ) = (repMat ℓ i).map (algebraMap ℤ ℝ) := rfl
+
+private lemma mapGL_coe' (s : SL(2, ℤ)) :
+    ((Matrix.SpecialLinearGroup.mapGL ℝ s : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ)
+      = (s : Matrix (Fin 2) (Fin 2) ℤ).map (algebraMap ℤ ℝ) := rfl
+
+private lemma map_int_mul (M P : Matrix (Fin 2) (Fin 2) ℤ) :
+    (M * P).map (algebraMap ℤ ℝ) = M.map (algebraMap ℤ ℝ) * P.map (algebraMap ℤ ℝ) := by
+  rw [← RingHom.mapMatrix_apply, ← RingHom.mapMatrix_apply, ← RingHom.mapMatrix_apply, map_mul]
+
+def heckeUSlashSum (k : ℤ) (ℓ : ℕ) [NeZero ℓ] (f : ℍ → ℂ) : ℍ → ℂ :=
+  ∑ j : Fin ℓ, f ∣[k] repGL ℓ (some j)
+
+section BoardBridge
+
+variable (ℓ : ℕ) [NeZero ℓ]
+
+theorem repGL_some_eq_heckeMatrix (j : Fin ℓ) :
+    repGL ℓ (some j) = ModularForm.heckeMatrix ℓ j := by
+  refine Units.ext ?_
+  rw [repGL_coe, ModularForm.val_heckeMatrix (NeZero.ne ℓ), repMat_some]
+  ext i k
+  fin_cases i <;> fin_cases k <;> simp
+
+theorem heckeUSlashSum_eq_heckeU (k : ℤ) (f : UpperHalfPlane → ℂ) :
+    heckeUSlashSum k ℓ f = ModularForm.heckeU k ℓ f := by
+  rw [heckeUSlashSum,
+    show ModularForm.heckeU k ℓ f = ∑ j ∈ Finset.range ℓ, f ∣[k] ModularForm.heckeMatrix ℓ j
+      from rfl,
+    ← Fin.sum_univ_eq_sum_range (fun j => f ∣[k] ModularForm.heckeMatrix ℓ j) ℓ]
+  exact Finset.sum_congr rfl fun j _ => by rw [repGL_some_eq_heckeMatrix]
+
+end BoardBridge
+
+end HeckeAnalytic
+
+p2m_open "UpperHalfPlane Filter Topology Complex Function ModularForm Matrix CongruenceSubgroup \
+  Subgroup HeckeEis P2MW.S_HeckeEis_eichlerShimuraMap_heckeULin.HeckeEis"
+
+noncomputable local instance (N ℓ : ℕ) [NeZero ℓ] :
+    Fintype (Gamma0 N ⧸ heckeUpper N ℓ) :=
+  (heckeUpper N ℓ).fintypeQuotientOfFiniteIndex
+
+section CosetRep
+
+variable (N ℓ : ℕ) [NeZero ℓ]
+
+private theorem map_int_mul' (M P : Matrix (Fin 2) (Fin 2) ℤ) :
+    (M * P).map (algebraMap ℤ ℝ) = M.map (algebraMap ℤ ℝ) * P.map (algebraMap ℤ ℝ) := by
+  rw [← RingHom.mapMatrix_apply, ← RingHom.mapMatrix_apply, ← RingHom.mapMatrix_apply, map_mul]
+
+noncomputable def alphaGL : GL (Fin 2) ℝ :=
+  Matrix.GeneralLinearGroup.mkOfDetNeZero ((alphaMat ℓ).map (algebraMap ℤ ℝ)) (by
+    have h : ((alphaMat ℓ).map (algebraMap ℤ ℝ)).det = (algebraMap ℤ ℝ) (alphaMat ℓ).det := by
+      rw [← RingHom.mapMatrix_apply, ← RingHom.map_det]
+    rw [h, det_alphaMat]
+    simp [NeZero.ne ℓ])
+
+@[scoped simp]
+theorem alphaGL_coe :
+    (alphaGL ℓ : Matrix (Fin 2) (Fin 2) ℝ) = (alphaMat ℓ).map (algebraMap ℤ ℝ) :=
+  rfl
+
+theorem alphaGL_val_det : (alphaGL ℓ).val.det = (ℓ : ℝ) := by
+  change ((alphaMat ℓ).map (algebraMap ℤ ℝ)).det = (ℓ : ℝ)
+  rw [← RingHom.mapMatrix_apply, ← RingHom.map_det, det_alphaMat]
+  simp
+
+noncomputable def gammaToGL : Gamma0 N →* GL (Fin 2) ℝ :=
+  (Matrix.SpecialLinearGroup.mapGL ℝ).comp (Gamma0 N).subtype
+
+@[scoped simp]
+theorem gammaToGL_apply (x : Gamma0 N) :
+    gammaToGL N x = Matrix.SpecialLinearGroup.mapGL ℝ (x : SL(2, ℤ)) :=
+  rfl
+
+theorem gammaToGL_val_det (x : Gamma0 N) : (gammaToGL N x).val.det = 1 := by
+  rw [gammaToGL_apply, ← Matrix.GeneralLinearGroup.val_det_apply,
+    Matrix.SpecialLinearGroup.det_mapGL, Units.val_one]
+
+theorem gammaToGL_smul (x : Gamma0 N) (z : ℍ) : gammaToGL N x • z = (x : SL(2, ℤ)) • z :=
+  rfl
+
+noncomputable def heckeCosetRep (q : Gamma0 N ⧸ heckeUpper N ℓ) : GL (Fin 2) ℝ :=
+  alphaGL ℓ * gammaToGL N (Quotient.out q)⁻¹
+
+theorem heckeCosetRep_def (q : Gamma0 N ⧸ heckeUpper N ℓ) :
+    heckeCosetRep N ℓ q = alphaGL ℓ * gammaToGL N (Quotient.out q)⁻¹ :=
+  rfl
+
+theorem heckeCosetRep_val_det (q : Gamma0 N ⧸ heckeUpper N ℓ) :
+    (heckeCosetRep N ℓ q).val.det = (ℓ : ℝ) := by
+  rw [heckeCosetRep_def, Units.val_mul, Matrix.det_mul, alphaGL_val_det, gammaToGL_val_det,
+    mul_one]
+
+theorem heckeCosetRep_val_det_pos (q : Gamma0 N ⧸ heckeUpper N ℓ) :
+    0 < (heckeCosetRep N ℓ q).val.det := by
+  rw [heckeCosetRep_val_det]
+  exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne ℓ)
+
+theorem gammaToGL_heckeConj_mul_alphaGL (h : heckeUpper N ℓ) :
+    gammaToGL N (heckeConj N ℓ h) * alphaGL ℓ = alphaGL ℓ * gammaToGL N (h : Gamma0 N) := by
+  apply Units.ext
+  rw [Units.val_mul, Units.val_mul]
+  change (heckeConjMat ℓ ((((h : Gamma0 N) : SL(2, ℤ))) : Matrix (Fin 2) (Fin 2) ℤ)).map
+        (algebraMap ℤ ℝ) * ((alphaMat ℓ).map (algebraMap ℤ ℝ))
+      = ((alphaMat ℓ).map (algebraMap ℤ ℝ))
+        * ((((h : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).map (algebraMap ℤ ℝ))
+  rw [← map_int_mul', ← map_int_mul',
+    heckeConjMat_mul_alphaMat ((mem_heckeUpper N ℓ).mp h.2)]
+
+omit [NeZero ℓ] in
+theorem coe_transferAux_inv_smul (γ : Gamma0 N) (q : Gamma0 N ⧸ heckeUpper N ℓ) :
+    ((transferAux (heckeUpper N ℓ) γ (γ⁻¹ • q) : heckeUpper N ℓ) : Gamma0 N)
+      = (Quotient.out q)⁻¹ * (γ * Quotient.out (γ⁻¹ • q)) := by
+  rw [coe_transferAux, smul_inv_smul]
+
+theorem heckeCosetRep_mul_gammaToGL (γ : Gamma0 N) (q : Gamma0 N ⧸ heckeUpper N ℓ) :
+    heckeCosetRep N ℓ q * gammaToGL N γ
+      = gammaToGL N (heckeConj N ℓ (transferAux (heckeUpper N ℓ) γ (γ⁻¹ • q)))
+        * heckeCosetRep N ℓ (γ⁻¹ • q) := by
+  rw [heckeCosetRep_def, heckeCosetRep_def, ← mul_assoc, gammaToGL_heckeConj_mul_alphaGL,
+    mul_assoc, mul_assoc, ← map_mul (gammaToGL N), ← map_mul (gammaToGL N)]
+  refine congrArg (fun x : Gamma0 N => alphaGL ℓ * gammaToGL N x) ?_
+  rw [coe_transferAux_inv_smul]
+  group
+
+end CosetRep
+
+section QuotSlashSum
+
+variable (N ℓ : ℕ) [NeZero ℓ]
+
+noncomputable def heckeQuotSlashSum (k : ℤ) (f : ℍ → ℂ) : ℍ → ℂ :=
+  ∑ q : Gamma0 N ⧸ heckeUpper N ℓ, f ∣[k] heckeCosetRep N ℓ q
+
+end QuotSlashSum
+
+section UBridge
+
+variable {N : ℕ} [NeZero N] {ℓ : ℕ} [NeZero ℓ]
+
+variable (N ℓ) in
+def UCosetMatch : Prop :=
+  ∃ e : Fin ℓ ≃ (Gamma0 N ⧸ heckeUpper N ℓ),
+    ∀ j : Fin ℓ, ∃ δ : Gamma0 N,
+      HeckeAnalytic.repGL ℓ (some j) = gammaToGL N δ * heckeCosetRep N ℓ (e j)
+
+omit [NeZero N] in
+theorem heckeUSlashSum_eq_heckeQuotSlashSum (hmatch : UCosetMatch N ℓ) (k : ℤ) {f : ℍ → ℂ}
+    (hf : ∀ γ ∈ ((Gamma0 N : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)),
+      f ∣[k] γ = f) :
+    HeckeAnalytic.heckeUSlashSum k ℓ f = heckeQuotSlashSum N ℓ k f := by
+  obtain ⟨e, he⟩ := hmatch
+  rw [HeckeAnalytic.heckeUSlashSum, heckeQuotSlashSum,
+    ← Equiv.sum_comp e fun q => f ∣[k] heckeCosetRep N ℓ q]
+  refine Finset.sum_congr rfl fun j _ => ?_
+  obtain ⟨δ, hδ⟩ := he j
+  rw [hδ, SlashAction.slash_mul,
+    hf (gammaToGL N δ) (Subgroup.mem_map.mpr ⟨(δ : SL(2, ℤ)), δ.2, rfl⟩)]
+
+end UBridge
+
+open HeckeAnalytic
+
+section URepresentatives
+
+def unipotentUpper (N : ℕ) (t : ℤ) : Gamma0 N :=
+  ⟨⟨!![1, t; 0, 1], by rw [Matrix.det_fin_two_of]; ring⟩, by
+    rw [Gamma0_mem]
+    change ((0 : ℤ) : ZMod N) = 0
+    exact Int.cast_zero⟩
+
+theorem unipotentUpper_mul (N : ℕ) (s t : ℤ) :
+    unipotentUpper N s * unipotentUpper N t = unipotentUpper N (s + t) := by
+  refine Subtype.ext (Subtype.ext ?_)
+  change (!![1, s; 0, 1] : Matrix (Fin 2) (Fin 2) ℤ) * !![1, t; 0, 1] = !![1, s + t; 0, 1]
+  rw [Matrix.mul_fin_two]
+  refine Matrix.ext fun x y => ?_
+  fin_cases x <;> fin_cases y
+  · change (1 * 1 + s * 0 : ℤ) = 1
+    ring
+  · change (1 * t + s * 1 : ℤ) = s + t
+    ring
+  · change (0 * 1 + 1 * 0 : ℤ) = 0
+    ring
+  · change (0 * t + 1 * 1 : ℤ) = 1
+    ring
+
+theorem unipotentUpper_zero (N : ℕ) : unipotentUpper N 0 = 1 := by
+  refine Subtype.ext (Subtype.ext ?_)
+  change (!![1, 0; 0, 1] : Matrix (Fin 2) (Fin 2) ℤ) = 1
+  rw [Matrix.one_fin_two]
+
+theorem inv_unipotentUpper (N : ℕ) (t : ℤ) :
+    (unipotentUpper N t)⁻¹ = unipotentUpper N (-t) :=
+  inv_eq_of_mul_eq_one_right (by
+    rw [unipotentUpper_mul, show t + -t = 0 by ring, unipotentUpper_zero])
+
+theorem unipotentUpper_entry_zero_one {N : ℕ} (t : ℤ) :
+    (((unipotentUpper N t : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) 0 1 = t :=
+  rfl
+
+variable {N ℓ : ℕ}
+
+theorem not_dvd_entry_one_one_of_dvd_level (hℓ : ℓ.Prime) (hℓN : ℓ ∣ N) (γ : Gamma0 N) :
+    ¬ (ℓ : ℤ) ∣ ((γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) 1 1 := by
+  set M : Matrix (Fin 2) (Fin 2) ℤ := ((γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) with hM
+  have hdet : M 0 0 * M 1 1 - M 0 1 * M 1 0 = 1 := by
+    have := (γ : SL(2, ℤ)).det_coe
+    rwa [Matrix.det_fin_two] at this
+  have hNc : (N : ℤ) ∣ M 1 0 := by
+    have := Gamma0_mem.mp γ.2
+    rwa [← ZMod.intCast_zmod_eq_zero_iff_dvd]
+  have hℓc : (ℓ : ℤ) ∣ M 1 0 := dvd_trans (Int.natCast_dvd_natCast.mpr hℓN) hNc
+  intro hd
+  have hone : (ℓ : ℤ) ∣ 1 := by
+    have h5 : (ℓ : ℤ) ∣ M 0 0 * M 1 1 - M 0 1 * M 1 0 :=
+      dvd_sub (hd.mul_left (M 0 0)) (hℓc.mul_left (M 0 1))
+    rwa [hdet] at h5
+  have h6 := Int.le_of_dvd one_pos hone
+  have hℓ1 : (1 : ℤ) < (ℓ : ℤ) := by exact_mod_cast hℓ.one_lt
+  omega
+
+variable (N ℓ) in
+def uCosetOfRep (j : Fin ℓ) : Gamma0 N ⧸ heckeUpper N ℓ :=
+  (unipotentUpper N (-(j : ℤ)) : Gamma0 N ⧸ heckeUpper N ℓ)
+
+theorem uCosetOfRep_injective (hℓ : ℓ.Prime) : Function.Injective (uCosetOfRep N ℓ) := by
+  intro j j' h
+  have hmem : (unipotentUpper N (-(j : ℤ)))⁻¹ * unipotentUpper N (-(j' : ℤ))
+      ∈ heckeUpper N ℓ := QuotientGroup.eq.mp h
+  rw [inv_unipotentUpper, unipotentUpper_mul] at hmem
+  have hdvd : (ℓ : ℤ) ∣ ((j : ℤ) + -(j' : ℤ)) := by
+    have := (mem_heckeUpper N ℓ).mp hmem
+    rwa [unipotentUpper_entry_zero_one, neg_neg] at this
+  obtain ⟨m, hm⟩ := hdvd
+  have hj : (j : ℤ) < ℓ := by exact_mod_cast j.2
+  have hj' : (j' : ℤ) < ℓ := by exact_mod_cast j'.2
+  have hj0 : (0 : ℤ) ≤ (j : ℤ) := Int.natCast_nonneg _
+  have hj'0 : (0 : ℤ) ≤ (j' : ℤ) := Int.natCast_nonneg _
+  have hℓ0 : (0 : ℤ) < ℓ := by exact_mod_cast hℓ.pos
+  have hm0 : m = 0 := by
+    rcases lt_trichotomy m 0 with h | h | h
+    · exfalso; nlinarith
+    · exact h
+    · exfalso; nlinarith
+  rw [hm0, mul_zero] at hm
+  ext
+  omega
+
+theorem uCosetOfRep_surjective (hℓ : ℓ.Prime) (hℓN : ℓ ∣ N) :
+    Function.Surjective (uCosetOfRep N ℓ) := by
+  intro q
+  set γ : Gamma0 N := Quotient.out q with hγ
+  set M : Matrix (Fin 2) (Fin 2) ℤ := ((γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) with hM
+  have hd : ¬ (ℓ : ℤ) ∣ M 1 1 := not_dvd_entry_one_one_of_dvd_level hℓ hℓN γ
+  have hℓ0 : (0 : ℤ) < ℓ := by exact_mod_cast hℓ.pos
+  have hcop : IsCoprime ((ℓ : ℤ)) (M 1 1) :=
+    (Prime.coprime_iff_not_dvd (Nat.prime_iff_prime_int.mp hℓ)).mpr hd
+  obtain ⟨u, v, huv⟩ := hcop
+  set j0 : ℤ := (-(M 0 1) * v) % (ℓ : ℤ) with hj0def
+  have hj0nonneg : 0 ≤ j0 := Int.emod_nonneg _ (by omega)
+  have hj0lt : j0 < (ℓ : ℤ) := Int.emod_lt_of_pos _ hℓ0
+  have hjnat : j0.toNat < ℓ := by omega
+  refine ⟨⟨j0.toNat, hjnat⟩, ?_⟩
+  have hcast : (((⟨j0.toNat, hjnat⟩ : Fin ℓ) : ℕ) : ℤ) = j0 := by
+    simp [Int.toNat_of_nonneg hj0nonneg]
+  have hmem : (unipotentUpper N (-((⟨j0.toNat, hjnat⟩ : Fin ℓ) : ℤ)))⁻¹ * γ
+      ∈ heckeUpper N ℓ := by
+    rw [inv_unipotentUpper, neg_neg]
+    refine (mem_heckeUpper N ℓ).mpr ?_
+    have hentry : (((unipotentUpper N ((⟨j0.toNat, hjnat⟩ : Fin ℓ) : ℤ) * γ : Gamma0 N)
+          : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) 0 1
+        = M 0 1 + j0 * M 1 1 := by
+      change ((((unipotentUpper N _ : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)
+          * M) 0 1 = M 0 1 + j0 * M 1 1
+      rw [Matrix.mul_apply, Fin.sum_univ_two]
+      change (1 : ℤ) * M 0 1 + (((⟨j0.toNat, hjnat⟩ : Fin ℓ) : ℕ) : ℤ) * M 1 1
+          = M 0 1 + j0 * M 1 1
+      rw [hcast]
+      ring
+    rw [hentry]
+    refine ⟨M 0 1 * u - (-(M 0 1) * v / (ℓ : ℤ)) * M 1 1, ?_⟩
+    have hemod : j0 + (ℓ : ℤ) * (-(M 0 1) * v / (ℓ : ℤ)) = -(M 0 1) * v :=
+      Int.emod_add_mul_ediv _ _
+    linear_combination (M 1 1) * hemod - (M 0 1) * huv
+  exact (QuotientGroup.eq.mpr hmem).trans (Quotient.out_eq q)
+
+variable (N ℓ) in
+noncomputable def uCosetEquiv (hℓ : ℓ.Prime) (hℓN : ℓ ∣ N) :
+    Fin ℓ ≃ (Gamma0 N ⧸ heckeUpper N ℓ) :=
+  Equiv.ofBijective (uCosetOfRep N ℓ)
+    ⟨uCosetOfRep_injective hℓ, uCosetOfRep_surjective hℓ hℓN⟩
+
+section ExistsCosetRep
+
+variable {N ℓ : ℕ} [NeZero ℓ]
+
+theorem exists_heckeCosetRep_coe_eq (γ : Gamma0 N) :
+    ∃ ε : Gamma0 N, heckeCosetRep N ℓ (γ : Gamma0 N ⧸ heckeUpper N ℓ)
+      = gammaToGL N ε * (alphaGL ℓ * gammaToGL N γ⁻¹) := by
+  obtain ⟨h, hout⟩ := QuotientGroup.mk_out_eq_mul (heckeUpper N ℓ) γ
+  refine ⟨heckeConj N ℓ h⁻¹, ?_⟩
+  rw [heckeCosetRep_def,
+    show Quotient.out ((γ : Gamma0 N ⧸ heckeUpper N ℓ)) = γ * (h : Gamma0 N) from hout,
+    _root_.mul_inv_rev, map_mul, ← mul_assoc, ← mul_assoc]
+  congr 1
+  exact (gammaToGL_heckeConj_mul_alphaGL N ℓ h⁻¹).symm
+
+end ExistsCosetRep
+
+section UCosetMatchDischarge
+
+variable {N ℓ : ℕ}
+
+private theorem map_int_mul_u (M P : Matrix (Fin 2) (Fin 2) ℤ) :
+    (M * P).map (algebraMap ℤ ℝ) = M.map (algebraMap ℤ ℝ) * P.map (algebraMap ℤ ℝ) := by
+  rw [← RingHom.mapMatrix_apply, ← RingHom.mapMatrix_apply, ← RingHom.mapMatrix_apply, map_mul]
+
+variable [NeZero ℓ]
+
+theorem repGL_some_eq_alphaGL_mul (j : Fin ℓ) :
+    HeckeAnalytic.repGL ℓ (some j)
+      = alphaGL ℓ * gammaToGL N (unipotentUpper N (j : ℤ)) := by
+  apply Units.ext
+  rw [Units.val_mul]
+  change (HeckeAnalytic.repMat ℓ (some j)).map (algebraMap ℤ ℝ)
+      = (alphaMat ℓ).map (algebraMap ℤ ℝ)
+        * ((((unipotentUpper N (j : ℤ) : Gamma0 N) : SL(2, ℤ))
+            : Matrix (Fin 2) (Fin 2) ℤ)).map (algebraMap ℤ ℝ)
+  rw [← map_int_mul_u]
+  congr 1
+  change !![1, (j : ℤ); 0, (ℓ : ℤ)] = !![1, 0; 0, (ℓ : ℤ)] * !![1, (j : ℤ); 0, 1]
+  rw [Matrix.mul_fin_two]
+  refine Matrix.ext fun x y => ?_
+  fin_cases x <;> fin_cases y <;> simp
+
+theorem exists_repGL_some_eq_mul_heckeCosetRep (j : Fin ℓ) :
+    ∃ δ : Gamma0 N, HeckeAnalytic.repGL ℓ (some j)
+      = gammaToGL N δ * heckeCosetRep N ℓ (uCosetOfRep N ℓ j) := by
+  obtain ⟨ε, hε⟩ := exists_heckeCosetRep_coe_eq (ℓ := ℓ) (unipotentUpper N (-(j : ℤ)))
+  refine ⟨ε⁻¹, ?_⟩
+  have huq : uCosetOfRep N ℓ j
+      = ((unipotentUpper N (-(j : ℤ)) : Gamma0 N) : Gamma0 N ⧸ heckeUpper N ℓ) := rfl
+  rw [huq, hε, map_inv, ← mul_assoc, inv_mul_cancel, one_mul,
+    inv_unipotentUpper, neg_neg, repGL_some_eq_alphaGL_mul]
+
+theorem uCosetMatch (hℓ : ℓ.Prime) (hℓN : ℓ ∣ N) : UCosetMatch N ℓ :=
+  ⟨uCosetEquiv N ℓ hℓ hℓN, fun j => by
+    have h : uCosetEquiv N ℓ hℓ hℓN j = uCosetOfRep N ℓ j := rfl
+    rw [h]
+    exact exists_repGL_some_eq_mul_heckeCosetRep j⟩
+
+end UCosetMatchDischarge
+end URepresentatives
+end HeckeEis.HeckeESSol
+end
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_mul binarySubst_mem binaryFormRepSL \
+  binaryFormRepSL_apply_coe binaryFormAlphaAdj binaryFormAlphaAdj_apply_coe alphaMat det_alphaMat \
+  heckeConjMat heckeConjMat_mul_alphaMat heckeUpper mem_heckeUpper heckeConj transferAux \
+  coe_transferAux IsParabolicCocycle coeffParabolicCocycles coeffH1par coeffH1parMk coeffHeckeFun \
+  coeffHeckeFun_apply IsEquivariantPrimitiveWith IsEquivariantPrimitiveWith.cocycle \
+  IsEichlerIntegral eichlerShimuraMap binaryFormAlphaAdj_comp_binaryFormRepSL_heckeConj \
+  exists_isEichlerIntegral_isParabolicCocycle isParabolicCocycle_cocycle_of_isEichlerIntegral \
+  eichlerShimuraMap_eq_coeffH1parMk"
+namespace HeckeESSol
+p2m_open "HeckeEis"
+
+open UpperHalfPlane MvPolynomial CongruenceSubgroup Matrix
+open scoped Manifold MatrixGroups ModularForm
+
+noncomputable local instance (N ℓ : ℕ) [NeZero ℓ] :
+    Fintype (Gamma0 N ⧸ heckeUpper N ℓ) :=
+  (heckeUpper N ℓ).fintypeQuotientOfFiniteIndex
+
+section CoeffTelescoping
+
+variable {N ℓ : ℕ} [NeZero ℓ] {n : ℕ}
+
+variable (N ℓ n) in
+def cosetOp (q : Gamma0 N ⧸ heckeUpper N ℓ) : ↥(BinaryForm ℂ n) →ₗ[ℂ] ↥(BinaryForm ℂ n) :=
+  ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (Quotient.out q) ∘ₗ binaryFormAlphaAdj ℂ n ℓ
+
+variable (N ℓ n) in
+def heckeEichler (F : ℍ → ↥(BinaryForm ℂ n)) (z : ℍ) : ↥(BinaryForm ℂ n) :=
+  ∑ q : Gamma0 N ⧸ heckeUpper N ℓ, cosetOp N ℓ n q (F (heckeCosetRep N ℓ q • z))
+
+theorem smul_smul_eq (γ : Gamma0 N) (q : Gamma0 N ⧸ heckeUpper N ℓ) (z : ℍ) :
+    heckeCosetRep N ℓ q • ((γ : SL(2, ℤ)) • z)
+      = ((heckeConj N ℓ (transferAux (heckeUpper N ℓ) γ (γ⁻¹ • q)) : Gamma0 N) : SL(2, ℤ))
+          • (heckeCosetRep N ℓ (γ⁻¹ • q) • z) := by
+  rw [show ((γ : SL(2, ℤ)) • z) = gammaToGL N γ • z from rfl, ← mul_smul,
+    heckeCosetRep_mul_gammaToGL, mul_smul]
+  rfl
+
+theorem cosetOp_heckeConj_apply (γ : Gamma0 N) (q : Gamma0 N ⧸ heckeUpper N ℓ)
+    (v : ↥(BinaryForm ℂ n)) :
+    cosetOp N ℓ n q (((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (heckeConj N ℓ (transferAux
+      (heckeUpper N ℓ) γ (γ⁻¹ • q))) v)
+      = ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) γ (cosetOp N ℓ n (γ⁻¹ • q) v) := by
+  have h1 := LinearMap.congr_fun
+    (HeckeEis.binaryFormAlphaAdj_comp_binaryFormRepSL_heckeConj ℂ n N ℓ (transferAux (heckeUpper N
+      ℓ) γ (γ⁻¹ • q))) v
+  rw [LinearMap.comp_apply, LinearMap.comp_apply] at h1
+  rw [cosetOp, cosetOp, LinearMap.comp_apply, LinearMap.comp_apply, h1, ← Module.End.mul_apply, ←
+    map_mul,
+    coe_transferAux_inv_smul, mul_inv_cancel_left, map_mul, Module.End.mul_apply]
+
+theorem cosetOp_apply_smul {F : ℍ → ↥(BinaryForm ℂ n)}
+    (hF : IsEquivariantPrimitiveWith ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) F)
+    (γ : Gamma0 N) (q : Gamma0 N ⧸ heckeUpper N ℓ) (z : ℍ) :
+    cosetOp N ℓ n q (F (heckeCosetRep N ℓ q • ((γ : SL(2, ℤ)) • z)))
+      = cosetOp N ℓ n q (hF.cocycle (heckeConj N ℓ (transferAux (heckeUpper N ℓ) γ (γ⁻¹ • q))))
+        + ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) γ (cosetOp N ℓ n (γ⁻¹ • q) (F
+          (heckeCosetRep N ℓ (γ⁻¹ • q) • z))) := by
+  rw [smul_smul_eq, hF.apply_smul, map_add, cosetOp_heckeConj_apply]
+
+theorem sum_cosetOp_cocycle {F : ℍ → ↥(BinaryForm ℂ n)}
+    (hF : IsEquivariantPrimitiveWith ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) F)
+    (γ : Gamma0 N) :
+    ∑ q : Gamma0 N ⧸ heckeUpper N ℓ,
+        cosetOp N ℓ n (γ • q) (hF.cocycle (heckeConj N ℓ (transferAux (heckeUpper N ℓ) γ q)))
+      = coeffHeckeFun N ℓ ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (binaryFormAlphaAdj ℂ n ℓ)
+        hF.cocycle γ := by
+  rw [coeffHeckeFun_apply]
+  refine Finset.sum_congr rfl fun q _ => ?_
+  rw [cosetOp, LinearMap.comp_apply]
+
+theorem sum_cosetOp_smul {F : ℍ → ↥(BinaryForm ℂ n)}
+    (hF : IsEquivariantPrimitiveWith ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) F)
+    (γ : Gamma0 N) (z : ℍ) :
+    ∑ q : Gamma0 N ⧸ heckeUpper N ℓ, cosetOp N ℓ n q (F (heckeCosetRep N ℓ q • ((γ : SL(2, ℤ)) •
+      z)))
+      = coeffHeckeFun N ℓ ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (binaryFormAlphaAdj ℂ n ℓ)
+        hF.cocycle γ
+        + ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) γ (∑ q : Gamma0 N ⧸ heckeUpper N ℓ,
+          cosetOp N ℓ n q (F (heckeCosetRep N ℓ q • z))) := by
+  calc ∑ q : Gamma0 N ⧸ heckeUpper N ℓ, cosetOp N ℓ n q (F (heckeCosetRep N ℓ q • ((γ : SL(2, ℤ)) •
+    z)))
+      = ∑ q : Gamma0 N ⧸ heckeUpper N ℓ,
+          (cosetOp N ℓ n q (hF.cocycle (heckeConj N ℓ (transferAux (heckeUpper N ℓ) γ (γ⁻¹ • q))))
+            + ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) γ (cosetOp N ℓ n (γ⁻¹ • q) (F
+              (heckeCosetRep N ℓ (γ⁻¹ • q) • z)))) :=
+        Finset.sum_congr rfl fun q _ => cosetOp_apply_smul hF γ q z
+    _ = (∑ q : Gamma0 N ⧸ heckeUpper N ℓ,
+            cosetOp N ℓ n q (hF.cocycle (heckeConj N ℓ (transferAux (heckeUpper N ℓ) γ (γ⁻¹ • q)))))
+          + ∑ q : Gamma0 N ⧸ heckeUpper N ℓ,
+            ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) γ (cosetOp N ℓ n (γ⁻¹ • q) (F
+              (heckeCosetRep N ℓ (γ⁻¹ • q) • z))) :=
+        Finset.sum_add_distrib
+    _ = (∑ q : Gamma0 N ⧸ heckeUpper N ℓ,
+            cosetOp N ℓ n (γ • q) (hF.cocycle (heckeConj N ℓ (transferAux (heckeUpper N ℓ) γ q))))
+          + ∑ q : Gamma0 N ⧸ heckeUpper N ℓ,
+            ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) γ (cosetOp N ℓ n q (F (heckeCosetRep N ℓ
+              q • z))) := by
+        rw [(MulAction.bijective (γ⁻¹ : Gamma0 N)).sum_comp
+            (fun q : Gamma0 N ⧸ heckeUpper N ℓ => ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) γ
+          (cosetOp N ℓ n q (F (heckeCosetRep N ℓ q • z)))),
+          ← (MulAction.bijective (γ : Gamma0 N)).sum_comp
+            (fun q : Gamma0 N ⧸ heckeUpper N ℓ =>
+              cosetOp N ℓ n q (hF.cocycle (heckeConj N ℓ (transferAux (heckeUpper N ℓ) γ (γ⁻¹ •
+          q)))))]
+        simp only [inv_smul_smul]
+    _ = coeffHeckeFun N ℓ ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (binaryFormAlphaAdj ℂ n ℓ)
+      hF.cocycle γ
+          + ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) γ (∑ q : Gamma0 N ⧸ heckeUpper N ℓ,
+            cosetOp N ℓ n q (F (heckeCosetRep N ℓ q • z))) := by
+        rw [sum_cosetOp_cocycle hF γ, map_sum]
+
+theorem heckeEichler_smul {F : ℍ → ↥(BinaryForm ℂ n)}
+    (hF : IsEquivariantPrimitiveWith ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) F)
+    (γ : Gamma0 N) (z : ℍ) :
+    heckeEichler N ℓ n F ((γ : SL(2, ℤ)) • z)
+      = coeffHeckeFun N ℓ ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (binaryFormAlphaAdj ℂ n ℓ)
+        hF.cocycle γ
+        + ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) γ (heckeEichler N ℓ n F z) :=
+  sum_cosetOp_smul hF γ z
+
+theorem isEquivariantPrimitiveWith_heckeEichler {F : ℍ → ↥(BinaryForm ℂ n)}
+    (hF : IsEquivariantPrimitiveWith ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) F) :
+    IsEquivariantPrimitiveWith ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (heckeEichler N ℓ n
+      F) := fun γ =>
+  ⟨coeffHeckeFun N ℓ ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (binaryFormAlphaAdj ℂ n ℓ)
+    hF.cocycle γ, fun z => by
+    rw [heckeEichler_smul hF, add_sub_cancel_right]⟩
+
+theorem cocycle_heckeEichler {F : ℍ → ↥(BinaryForm ℂ n)}
+    (hF : IsEquivariantPrimitiveWith ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) F) :
+    (isEquivariantPrimitiveWith_heckeEichler (ℓ := ℓ) hF).cocycle
+      = coeffHeckeFun N ℓ ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (binaryFormAlphaAdj ℂ n ℓ)
+        hF.cocycle := by
+  funext γ
+  rw [IsEquivariantPrimitiveWith.cocycle, heckeEichler_smul hF, add_sub_cancel_right]
+
+end CoeffTelescoping
+
+section EichlerSum
+
+variable {N ℓ : ℕ} [NeZero ℓ] {n : ℕ}
+
+theorem isEichlerIntegral_sum {ι : Type*} (s : Finset ι) {f : ι → ℍ → ℂ}
+    {F : ι → ℍ → ↥(BinaryForm ℂ n)}
+    (h : ∀ i ∈ s, IsEichlerIntegral n (f i) (F i)) :
+    IsEichlerIntegral n (∑ i ∈ s, f i) (fun z => ∑ i ∈ s, F i z) := by
+  intro d τ
+  have hfun : (fun z : ℂ => AddMonoidAlgebra.coeff
+      ((∑ i ∈ s, F i (ofComplex z) : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) d)
+      = fun z : ℂ => ∑ i ∈ s, AddMonoidAlgebra.coeff
+        ((F i (ofComplex z) : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) d := by
+    funext z
+    rw [Submodule.coe_sum, coeff_sum]
+  rw [hfun, Finset.sum_apply, Finset.sum_mul]
+  exact HasDerivAt.fun_sum fun i hi => h i hi d τ
+
+def cosetMat (q : Gamma0 N ⧸ heckeUpper N ℓ) : Matrix (Fin 2) (Fin 2) ℤ :=
+  alphaMat ℓ * ((((Quotient.out q)⁻¹ : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)
+
+omit [NeZero ℓ] in
+theorem det_cosetMat (q : Gamma0 N ⧸ heckeUpper N ℓ) : (cosetMat (ℓ := ℓ) q).det = ℓ := by
+  rw [cosetMat, Matrix.det_mul, det_alphaMat, Matrix.SpecialLinearGroup.det_coe, mul_one]
+
+theorem coe_heckeCosetRep (q : Gamma0 N ⧸ heckeUpper N ℓ) :
+    ((heckeCosetRep N ℓ q : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) = (cosetMat q).map (algebraMap
+      ℤ ℝ) := by
+  rw [heckeCosetRep_def, Units.val_mul, alphaGL_coe, gammaToGL_apply,
+    Matrix.SpecialLinearGroup.mapGL_coe_matrix,
+    Matrix.SpecialLinearGroup.map_apply_coe, RingHom.mapMatrix_apply, cosetMat, ← map_int_mul']
+
+omit [NeZero ℓ] in
+theorem adjugate_cosetMat (q : Gamma0 N ⧸ heckeUpper N ℓ) :
+    (cosetMat (ℓ := ℓ) q).adjugate
+      = (((Quotient.out q : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) * !![(ℓ : ℤ), 0; 0, 1]
+        := by
+  rw [cosetMat, Matrix.adjugate_mul_distrib, ← Matrix.SpecialLinearGroup.coe_inv, Subgroup.coe_inv,
+    inv_inv]
+  congr 1
+  rw [alphaMat, Matrix.adjugate_fin_two]
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp
+
+omit [NeZero ℓ] in
+theorem cosetOp_apply_eq (q : Gamma0 N ⧸ heckeUpper N ℓ) (v : ↥(BinaryForm ℂ n)) :
+    cosetOp N ℓ n q v = ((binarySubst ℂ (cosetMat (ℓ := ℓ) q).adjugate).toLinearMap.restrict
+        (fun _ h => binarySubst_mem ℂ (cosetMat (ℓ := ℓ) q).adjugate h)) v := by
+  apply Subtype.ext
+  rw [cosetOp, LinearMap.comp_apply]
+  change ((((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (Quotient.out q)) (binaryFormAlphaAdj ℂ n
+    ℓ v) : MvPolynomial (Fin 2) ℂ)
+    = binarySubst ℂ (cosetMat (ℓ := ℓ) q).adjugate v
+  rw [MonoidHom.comp_apply, Subgroup.coe_subtype, binaryFormRepSL_apply_coe,
+    binaryFormAlphaAdj_apply_coe,
+    adjugate_cosetMat, binarySubst_mul, AlgHom.comp_apply]
+
+theorem isEichlerIntegral_heckeEichler {f : ℍ → ℂ} {F : ℍ → ↥(BinaryForm ℂ n)}
+    (hF : IsEichlerIntegral n f F) :
+    IsEichlerIntegral n (heckeQuotSlashSum N ℓ ((n : ℤ) + 2) f) (heckeEichler N ℓ n F) := by
+  have h := isEichlerIntegral_sum (Finset.univ : Finset (Gamma0 N ⧸ heckeUpper N ℓ))
+    (f := fun q => f ∣[((n : ℤ) + 2)] heckeCosetRep N ℓ q)
+    (F := fun q z => cosetOp N ℓ n q (F (heckeCosetRep N ℓ q • z)))
+    (fun q _ => by
+      have hq := hF.binarySubst_adjugate_comp_smul (M := cosetMat (ℓ := ℓ) q)
+        (by
+          rw [det_cosetMat]; exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne ℓ)) (coe_heckeCosetRep q)
+      intro d τ
+      have := hq d τ
+      simp only [← cosetOp_apply_eq] at this
+      exact this)
+  exact h
+
+end EichlerSum
+end HeckeEis.HeckeESSol
+end
+
+open _root_.HeckeEis _root_.P2MW.S_HeckeEis_eichlerShimuraMap_heckeULin.HeckeEis HeckeEis.HeckeESSol
+  CongruenceSubgroup in
+theorem solution (N : ℕ) [NeZero N] (n : ℕ) {ℓ : ℕ} (hℓ : ℓ.Prime) (hℓN : ℓ ∣ N)
+    (T : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+      N).subtype) →ₗ[ℂ]
+      HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+        N).subtype))
+    (hT : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+        ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+          (CongruenceSubgroup.Gamma0 N).subtype)),
+          haveI : NeZero ℓ := ⟨hℓ.ne_zero⟩
+          (w : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n))
+              = HeckeEis.coeffHeckeFun N ℓ ((HeckeEis.binaryFormRepSL ℂ n).comp
+                (CongruenceSubgroup.Gamma0 N).subtype) (HeckeEis.binaryFormAlphaAdj ℂ n ℓ) z ∧
+            T (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w)
+    (f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2)) :
+    T (HeckeEis.eichlerShimuraMap n N f)
+      = HeckeEis.eichlerShimuraMap n N (CuspForm.heckeULin ((n : ℤ) + 2) hℓN f) := by
+  have : NeZero ℓ := ⟨hℓ.ne_zero⟩
+  obtain ⟨F, hEI, hF, hpar⟩ := HeckeEis.exists_isEichlerIntegral_isParabolicCocycle N n f
+  have hGEI : IsEichlerIntegral n (CuspForm.heckeULin ((n : ℤ) + 2) hℓN f) (heckeEichler N ℓ n F) :=
+    by
+    have h := isEichlerIntegral_heckeEichler (N := N) (ℓ := ℓ) hEI
+    rwa [← heckeUSlashSum_eq_heckeQuotSlashSum (uCosetMatch hℓ hℓN) _
+      (SlashInvariantFormClass.slash_action_eq f),
+      HeckeAnalytic.heckeUSlashSum_eq_heckeU, ← CuspForm.coe_heckeULin_apply ((n : ℤ) + 2) hℓN
+      f] at h
+  have hG := isEquivariantPrimitiveWith_heckeEichler (ℓ := ℓ) hF
+  have hGc := cocycle_heckeEichler (ℓ := ℓ) hF
+  have hGpar : IsParabolicCocycle ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) hG.cocycle :=
+    HeckeEis.isParabolicCocycle_cocycle_of_isEichlerIntegral N n _ hGEI hG
+  rw [HeckeEis.eichlerShimuraMap_eq_coeffH1parMk n N _ hGEI hG hGpar,
+    HeckeEis.eichlerShimuraMap_eq_coeffH1parMk n N _ hEI hF hpar]
+  obtain ⟨w, hw, hTw⟩ := hT ⟨hF.cocycle, hF.cocycle_mem_coeffCocycles, hpar⟩
+  rw [hTw]
+  congr 1
+  exact Subtype.ext (hw.trans hGc.symm)
+
+end S_HeckeEis_eichlerShimuraMap_heckeULin
+end P2MW
+export P2MW.S_HeckeEis_eichlerShimuraMap_heckeULin (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Manifold MatrixGroups
+theorem HeckeEis.eichlerShimuraMap_heckeULin (N : ℕ) [NeZero N] (n : ℕ) {ℓ : ℕ} (hℓ : ℓ.Prime)
+    (hℓN : ℓ ∣ N)
+    (T : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+      N).subtype) →ₗ[ℂ]
+      HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+        N).subtype))
+    (hT : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+        ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+          (CongruenceSubgroup.Gamma0 N).subtype)),
+          haveI : NeZero ℓ := ⟨hℓ.ne_zero⟩
+          (w : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n))
+              = HeckeEis.coeffHeckeFun N ℓ ((HeckeEis.binaryFormRepSL ℂ n).comp
+                (CongruenceSubgroup.Gamma0 N).subtype) (HeckeEis.binaryFormAlphaAdj ℂ n ℓ) z ∧
+            T (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w)
+    (f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2)) :
+    T (HeckeEis.eichlerShimuraMap n N f)
+      = HeckeEis.eichlerShimuraMap n N (CuspForm.heckeULin ((n : ℤ) + 2) hℓN f) :=
+  solution N n hℓ hℓN T hT f
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_eichlerShimuraMap_injective.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_eichlerShimuraMap_injective.lean
new file mode 100644
index 0000000000..7253d4a0a0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_eichlerShimuraMap_injective.lean
@@ -0,0 +1,277 @@
+/-
+Based on Prove2Me node HeckeEis.eichlerShimuraMap_injective
+(9c3ee924-f311-5337-9021-947198d5d895) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5089a8cd-b936-511e-b0bb-1db690e83a66
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import Mathlib.NumberTheory.ModularForms.NormTrace
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_hasDerivAt_eval_iterate_pderiv
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_jFactor_pow_mul_eval_binaryFormRepSL
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_eq_zero_of_eval_eq_const
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_isBoundedAtImInfty_eval
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_slash
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_eichlerShimuraMap_eq_coeffH1parMk
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_existsEichlerShimuraMapLinear
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_isEichlerIntegral_isParabolicCocycle
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Injectivity of the Eichler–Shimura map on cusp forms
+
+Theorem statement: `HeckeEis.eichlerShimuraMap_injective` (`9c3ee924-f311-5337-9021-947198d5d895`),
+by Claude, 2026-09-05.
+
+Proof: submission `5089a8cd-b936-511e-b0bb-1db690e83a66`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N \ge 1$ and let $n \ge 0$ be natural numbers. Write $\rho$ for the representation of
+$\Gamma_0(N)$ obtained by restricting [`HeckeEis.binaryFormRepSL ℂ
+n`](def/HeckeEis_BinaryFormRep.html#L61), the substitution action of $\mathrm{SL}_2(\mathbb{Z})$ on
+the submodule `BinaryForm ℂ n` of degree-$n$ homogeneous polynomials in two variables over
+$\mathbb{C}$, along the inclusion of $\Gamma_0(N)$. The theorem asserts that the assignment sending
+a cusp form $f$ of weight $(n : \mathbb{Z}) + 2$ for $\Gamma_0(N)$ to [`HeckeEis.eichlerShimuraMap n
+N f`](def/HeckeEis_EichlerIntegral.html#L114) is an injective function. Here `eichlerShimuraMap n N
+f` is defined by cases: if there is some $F : \mathbb{H} \to$ `BinaryForm ℂ n` which is an Eichler
+integral of $f$ (for every multidegree $d$ and every $\tau$, the coefficient of $d$ in $F$, read as
+a function of the complex variable, has derivative $f(\tau)$ times the coefficient of $d$ in $(X_0
+\tau + X_1)$-type form `linePow n τ` at $\tau$), which is an equivariant primitive for $\rho$ (for
+each $\gamma$ the difference $F(\gamma \cdot \tau) - \rho(\gamma)(F\tau)$ is independent of $\tau$)
+and whose associated cocycle $\gamma \mapsto F(\gamma \cdot i) - \rho(\gamma)(F i)$ is parabolic
+(for every $\gamma$ whose integral matrix has trace squared equal to $4$, its value lies in the
+image of $\rho(\gamma) - 1$), then the value is the class of that cocycle in `coeffH1par ρ`, the
+quotient of parabolic cocycles by coboundaries; otherwise the value is $0$. Thus two cusp forms of
+weight $n+2$ on $\Gamma_0(N)$ with the same parabolic cohomology class coincide.
+
+This is the injectivity half of the Eichler–Shimura relation between weight-$(n+2)$ cusp forms on
+$\Gamma_0(N)$ and parabolic cohomology of $\Gamma_0(N)$ with coefficients in binary forms of degree
+$n$; it is the weight-$(n+2)$ analogue of injectivity of the period map on weight-$2$ forms. It is
+used in the construction of Hecke eigenclasses in `coeffH1par` attached to eigenforms and in the
+finiteness of the integral Hecke algebra.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_eichlerShimuraMap_injective.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_eichlerShimuraMap_injective
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binaryFormRepSL mem_coeffCoboundaries_iff \
+  coeffH1parMk_eq_zero_iff jFactor_eq_denom IsEichlerIntegral eichlerShimuraMap \
+  jFactor_pow_mul_eval_binaryFormRepSL exists_isEichlerIntegral_isParabolicCocycle \
+  eichlerShimuraMap_eq_coeffH1parMk existsEichlerShimuraMapLinear"
+namespace MainAux
+p2m_open "HeckeEis"
+
+open UpperHalfPlane MvPolynomial CongruenceSubgroup Filter Function
+open scoped MatrixGroups Manifold Topology ModularForm Pointwise
+
+theorem periodic_slash_comp_ofComplex_of_conj_T_zpow_mem {k : ℤ} {Γ : Subgroup SL(2, ℤ)}
+    {F' : Type*}
+    [FunLike F' ℍ ℂ] [SlashInvariantFormClass F' (Γ : Subgroup (GL (Fin 2) ℝ)) k] (f : F')
+    (δ : SL(2, ℤ)) {h : ℤ}
+    (hmem : δ * ModularGroup.T ^ h * δ⁻¹ ∈ Γ) :
+    Function.Periodic (((f : ℍ → ℂ) ∣[k] δ) ∘ ofComplex) ((h : ℝ) : ℂ) := by
+  refine SlashInvariantFormClass.periodic_comp_ofComplex
+    (SlashInvariantForm.translate f (Matrix.SpecialLinearGroup.mapGL ℝ δ)) ?_
+  rw [Subgroup.mem_strictPeriods_iff, map_inv, Subgroup.mem_inv_pointwise_smul_iff,
+    ConjAct.toConjAct_smul]
+  have hTh : Matrix.SpecialLinearGroup.mapGL ℝ (ModularGroup.T ^ h)
+      = Matrix.GeneralLinearGroup.upperRightHom (h : ℝ) := by
+    rw [Units.ext_iff, Matrix.SpecialLinearGroup.mapGL_coe_matrix,
+      Matrix.SpecialLinearGroup.map_apply_coe,
+      ModularGroup.coe_T_zpow, Matrix.GeneralLinearGroup.upperRightHom_apply]
+    ext i j
+    fin_cases i <;> fin_cases j <;> simp
+  rw [← hTh, ← map_mul, ← map_inv, ← map_mul]
+  exact Subgroup.mem_map_of_mem _ hmem
+
+theorem Gamma_le_Gamma0 (N : ℕ) : Gamma N ≤ Gamma0 N := fun _ hA =>
+  Gamma0_mem.mpr (Gamma_mem.mp hA).2.2.1
+
+theorem conj_T_zpow_mem_Gamma0 (N : ℕ) (δ : SL(2, ℤ)) :
+    δ * ModularGroup.T ^ (N : ℤ) * δ⁻¹ ∈ Gamma0 N := by
+  have hTN : ModularGroup.T ^ (N : ℤ) ∈ Gamma N := by
+    have := CongruenceSubgroup.ModularGroup_T_pow_mem_Gamma (N : ℤ) (N : ℤ) dvd_rfl
+    simpa using this
+  exact Gamma_le_Gamma0 N ((CongruenceSubgroup.Gamma_normal N).conj_mem _ hTN δ)
+
+theorem mdifferentiable_eval {n : ℕ} {g : ℍ → ℂ} {G : ℍ → ↥(BinaryForm ℂ n)}
+    (hG : IsEichlerIntegral n g G) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ)
+      (fun τ : ℍ => MvPolynomial.eval ![(1 : ℂ), -(τ : ℂ)] ((G τ : ↥(BinaryForm ℂ n)) : MvPolynomial
+        (Fin 2) ℂ)) := by
+  rw [UpperHalfPlane.mdifferentiable_iff]
+  intro z hz
+  have h := (hG.hasDerivAt_eval_iterate_pderiv (Nat.zero_le n) ⟨z, hz⟩).differentiableAt
+  simp only [Function.iterate_zero, id_eq] at h
+  refine (h.congr_of_eventuallyEq ?_).differentiableWithinAt
+  filter_upwards [isOpen_upperHalfPlaneSet.mem_nhds hz] with w hw
+  simp only [Function.comp_apply]
+  rw [ofComplex_apply_of_im_pos hw]
+
+theorem exists_eq_const_of_slash_invariant {Γ : Subgroup SL(2, ℤ)} [Γ.FiniteIndex] {k : ℤ}
+    (hk : k ≤ 0)
+    {F : ℍ → ℂ} (hinv : ∀ γ ∈ Γ, F ∣[k] γ = F) (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F)
+    (hbdd : ∀ δ : SL(2, ℤ), IsBoundedAtImInfty (F ∣[k] δ)) : ∃ c : ℂ, ∀ τ : ℍ, F τ = c := by
+  let M : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k :=
+    { toFun := F
+      slash_action_eq' := by
+        intro g hg
+        obtain ⟨γ, hγ, rfl⟩ := Subgroup.mem_map.mp hg
+        exact hinv γ hγ
+      holo' := hhol
+      bdd_at_cusps' := by
+        intro c hc
+        have hle : (Γ : Subgroup (GL (Fin 2) ℝ)) ≤ 𝒮ℒ := by
+          rintro g ⟨γ, -, rfl⟩
+          exact ⟨γ, rfl⟩
+        obtain ⟨δ, rfl⟩ := isCusp_SL2Z_iff'.mp (hc.mono hle)
+        rw [OnePoint.isBoundedAt_iff (g := Matrix.SpecialLinearGroup.mapGL ℝ δ) rfl]
+        exact hbdd δ }
+  have hMF : ∀ τ : ℍ, M τ = F τ := fun τ => rfl
+  rcases hk.lt_or_eq with hlt | heq
+  · refine ⟨0, fun τ => ?_⟩
+    have hM : M = 0 := ModularForm.isZero_of_neg_weight hlt M
+    rw [← hMF τ, hM]
+    rfl
+  · subst heq
+    obtain ⟨c, hc⟩ := ModularForm.eq_const_of_weight_zero M
+    exact ⟨c, fun τ => by rw [← hMF τ, hc]; rfl⟩
+
+end HeckeEis.MainAux
+
+open _root_.HeckeEis _root_.P2MW.S_HeckeEis_eichlerShimuraMap_injective.HeckeEis HeckeEis.MainAux
+  UpperHalfPlane CongruenceSubgroup MvPolynomial in
+open scoped ModularForm Pointwise Manifold MatrixGroups in
+theorem solution (N : ℕ) [NeZero N] (n : ℕ) :
+    Function.Injective
+      (fun f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2) ↦ HeckeEis.eichlerShimuraMap n N
+        f) := by
+  have : (Gamma0 N).FiniteIndex := Subgroup.finiteIndex_of_le (Gamma_le_Gamma0 N)
+  obtain ⟨ES, hES⟩ := existsEichlerShimuraMapLinear n N
+  suffices hker : ∀ f : CuspForm (Gamma0 N) ((n : ℤ) + 2), eichlerShimuraMap n N f = 0 → f = 0 by
+    intro f g hfg
+    have h1 : ES (f - g) = 0 := by
+      rw [map_sub, hES, hES, sub_eq_zero]
+      exact hfg
+    rw [hES] at h1
+    exact sub_eq_zero.mp (hker _ h1)
+  intro f hf0
+  set R := binaryFormRepSL ℂ n with hR
+  obtain ⟨F, hEI, hF, hpar⟩ := exists_isEichlerIntegral_isParabolicCocycle N n f
+  rw [eichlerShimuraMap_eq_coeffH1parMk n N f hEI hF hpar, coeffH1parMk_eq_zero_iff] at hf0
+  obtain ⟨v, hv⟩ := (mem_coeffCoboundaries_iff _ _).mp hf0
+  set F₁ : ℍ → ↥(BinaryForm ℂ n) := fun τ => F τ + v with hF₁
+  have hEI₁ : IsEichlerIntegral n f F₁ := by
+    intro d τ
+    have := (hEI d τ).add_const
+      (AddMonoidAlgebra.coeff ((v : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) d)
+    simpa [hF₁, Submodule.coe_add, AddMonoidAlgebra.coeff_add, Finsupp.add_apply] using this
+  have hEq : ∀ γ ∈ Gamma0 N, ∀ τ : ℍ, F₁ (γ • τ) = R γ (F₁ τ) := by
+    intro γ hγ τ
+    have h1 := hF.sub_eq_cocycle ⟨γ, hγ⟩ τ
+    have h2 := congrFun hv ⟨γ, hγ⟩
+    simp only at h2
+    rw [← h2] at h1
+    simp only [hF₁, map_add]
+    change F (γ • τ) + v = R γ (F τ) + R γ v
+    have h3 : F (γ • τ) - R γ (F τ) = R γ v - v := h1
+    rw [sub_eq_iff_eq_add.mp h3]
+    abel
+  set P : ℍ → ℂ := fun τ => MvPolynomial.eval ![(1 : ℂ), -(τ : ℂ)] ((F₁ τ : ↥(BinaryForm ℂ n)) :
+    MvPolynomial (Fin 2) ℂ)
+    with hP
+  set Gδ : SL(2, ℤ) → ℍ → ↥(BinaryForm ℂ n) := fun δ τ => R δ⁻¹ (F₁ (δ • τ)) with hGδ
+  have hGδEI : ∀ δ : SL(2, ℤ), IsEichlerIntegral n (⇑f ∣[((n : ℤ) + 2)] δ) (Gδ δ) :=
+    fun δ => hEI₁.slash δ
+  have hRR : ∀ (δ : SL(2, ℤ)) (τ : ℍ), R δ (Gδ δ τ) = F₁ (δ • τ) := fun δ τ => by
+    simp only [hGδ]
+    rw [← Module.End.mul_apply, ← map_mul, mul_inv_cancel, map_one, Module.End.one_apply]
+  have hslash : ∀ (δ : SL(2, ℤ)) (τ : ℍ), (P ∣[-(n : ℤ)] δ) τ
+      = MvPolynomial.eval ![(1 : ℂ), -(τ : ℂ)] ((Gδ δ τ : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2)
+        ℂ) := by
+    intro δ τ
+    rw [ModularForm.SL_slash_apply, hP, neg_neg]
+    simp only []
+    have key := HeckeEis.jFactor_pow_mul_eval_binaryFormRepSL n δ τ (Gδ δ τ)
+    rw [hRR, jFactor_eq_denom] at key
+    rw [← key, mul_comm, zpow_natCast]
+    rfl
+  have hinv : ∀ γ ∈ Gamma0 N, P ∣[-(n : ℤ)] γ = P := by
+    intro γ hγ
+    funext τ
+    rw [hslash γ τ, hP]
+    simp only [hGδ]
+    rw [hEq γ hγ τ, ← Module.End.mul_apply, ← map_mul, inv_mul_cancel, map_one,
+      Module.End.one_apply]
+  have hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) P := mdifferentiable_eval hEI₁
+  have hNpos : (0 : ℤ) < (N : ℤ) := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  have hbdd : ∀ δ : SL(2, ℤ), IsBoundedAtImInfty (P ∣[-(n : ℤ)] δ) := by
+    intro δ
+    have hfun : P ∣[-(n : ℤ)] δ
+        = fun τ : ℍ => MvPolynomial.eval ![(1 : ℂ), -(τ : ℂ)] ((Gδ δ τ : ↥(BinaryForm ℂ n)) :
+          MvPolynomial (Fin 2) ℂ) :=
+      funext (hslash δ)
+    rw [hfun]
+    have hσ : δ * ModularGroup.T ^ (N : ℤ) * δ⁻¹ ∈ Gamma0 N := conj_T_zpow_mem_Gamma0 N δ
+    have hgper : Function.Periodic ((⇑f ∣[((n : ℤ) + 2)] δ) ∘ ofComplex) (((N : ℤ) : ℝ) : ℂ) :=
+      periodic_slash_comp_ofComplex_of_conj_T_zpow_mem f δ hσ
+    have hghol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (⇑f ∣[((n : ℤ) + 2)] δ) :=
+      (CuspFormClass.holo f).slash _ _
+    have hgbdd : IsBoundedAtImInfty (⇑f ∣[((n : ℤ) + 2)] δ) :=
+      ModularFormClass.bdd_at_infty_slash f δ
+    have hT : ∀ τ : ℍ, Gδ δ ((((N : ℤ) : ℝ)) +ᵥ τ) = R (ModularGroup.T ^ (N : ℤ)) (Gδ δ τ) := by
+      intro τ
+      simp only [hGδ]
+      have h1 := hEq _ hσ (δ • τ)
+      have hpt : ((δ * ModularGroup.T ^ (N : ℤ) * δ⁻¹ : SL(2, ℤ)) • δ • τ) = δ • ((((N : ℤ) : ℝ)) +ᵥ
+        τ) :=
+        by
+        rw [← UpperHalfPlane.modular_T_zpow_smul, smul_smul, smul_smul]
+        congr 1
+        group
+      rw [hpt] at h1
+      rw [h1, ← Module.End.mul_apply, ← map_mul, ← Module.End.mul_apply, ← map_mul]
+      congr 2
+      group
+    exact (hGδEI δ).isBoundedAtImInfty_eval hNpos hgper hghol hgbdd hT
+  obtain ⟨c, hc⟩ :=
+    exists_eq_const_of_slash_invariant (Γ := Gamma0 N) (k := -(n : ℤ)) (by omega) hinv hhol hbdd
+  have hzero : (⇑f : ℍ → ℂ) = 0 := hEI₁.eq_zero_of_eval_eq_const hc
+  exact DFunLike.ext f 0 fun τ => by rw [congrFun hzero τ]; rfl
+
+end S_HeckeEis_eichlerShimuraMap_injective
+end P2MW
+export P2MW.S_HeckeEis_eichlerShimuraMap_injective (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Manifold MatrixGroups ModularForm
+theorem HeckeEis.eichlerShimuraMap_injective (N : ℕ) [NeZero N] (n : ℕ) :
+    Function.Injective
+      (fun f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2) ↦ HeckeEis.eichlerShimuraMap n N
+        f) :=
+  solution N n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_eichlerShimuraMap_smul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_eichlerShimuraMap_smul.lean
new file mode 100644
index 0000000000..75fd3c2490
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_eichlerShimuraMap_smul.lean
@@ -0,0 +1,153 @@
+/-
+Based on Prove2Me node HeckeEis.eichlerShimuraMap_smul
+(92c28018-0953-5786-b828-29d55715c40d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4d19173a-6012-5772-91ac-1c1f519b9f58
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_eichlerShimuraMap_eq_coeffH1parMk
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_isEichlerIntegral_isParabolicCocycle
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Complex homogeneity of the Eichler–Shimura map
+
+Theorem statement: `HeckeEis.eichlerShimuraMap_smul` (`92c28018-0953-5786-b828-29d55715c40d`), by
+Claude, 2026-09-05.
+
+Proof: submission `4d19173a-6012-5772-91ac-1c1f519b9f58`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix natural numbers $n$ and $N$ with $N \neq 0$, a scalar $c \in \mathbb{C}$, and a cusp form $f$ of
+weight $(n : \mathbb{Z}) + 2$ for $\Gamma_0(N)$. Write $\rho$ for the representation of
+$\Gamma_0(N)$ on the space `BinaryForm ℂ n` of homogeneous polynomials of degree $n$ in two
+variables over $\mathbb{C}$ obtained by restricting, along the inclusion of $\Gamma_0(N)$ into
+$\mathrm{SL}_2(\mathbb{Z})$, the substitution action `binaryFormRepSL ℂ n`. For a function $g :
+\mathbb{H} \to \mathbb{C}$, [`HeckeEis.eichlerShimuraMap n N
+g`](def/HeckeEis_EichlerIntegral.html#L114) is defined by cases: if there is an $F : \mathbb{H} \to$
+`BinaryForm ℂ n` which is an Eichler integral of $g$ (each polynomial coefficient of $F$, read as a
+function of the complex variable, has derivative $g(\tau)$ times the corresponding coefficient of
+`linePow n τ` at every point of $\mathbb{H}$), which satisfies `IsEquivariantPrimitiveWith`, i.e.
+$F(\gamma \cdot \tau) - \rho(\gamma)F(\tau)$ is independent of $\tau$ for each $\gamma \in
+\Gamma_0(N)$, and whose associated cocycle $\gamma \mapsto F(\gamma \cdot i) - \rho(\gamma)F(i)$ is
+parabolic (for every $\gamma$ whose integral matrix has trace squared equal to $4$, its value lies
+in the image of $\rho(\gamma) - 1$), then the value is the class of that cocycle in `coeffH1par ρ`,
+the quotient of the parabolic cocycles by the coboundaries; otherwise the value is $0$. The
+assertion is that the value of this map on the function underlying $c \bullet f$ equals $c$ times
+its value on the function underlying $f$, for the $\mathbb{C}$-module structure on `coeffH1par ρ`.
+
+This records the homogeneity half of the $\mathbb{C}$-linearity of the Eichler–Shimura map from
+weight $n+2$ cusp forms on $\Gamma_0(N)$ to parabolic cohomology with coefficients in the $n$-th
+symmetric power. It is used, together with the corresponding additivity statement, to package the
+Eichler–Shimura construction as a linear map in
+[`HeckeEis.existsEichlerShimuraMapLinear`](thm.html#HeckeEis.existsEichlerShimuraMapLinear).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_eichlerShimuraMap_smul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_eichlerShimuraMap_smul
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "binaryFormRepSL IsParabolicCocycle IsEquivariantPrimitiveWith \
+  IsEichlerIntegral eichlerShimuraMap exists_isEichlerIntegral_isParabolicCocycle \
+  eichlerShimuraMap_eq_coeffH1parMk IsEichlerIntegral.smul"
+p2m_open "HeckeEis"
+
+open UpperHalfPlane MvPolynomial CongruenceSubgroup
+open scoped MatrixGroups ModularForm
+
+namespace EichlerLinAux
+
+variable {K : Type*} [CommRing K] {Γ : Subgroup SL(2, ℤ)} {V : Type*} [AddCommGroup V] [Module K V]
+  {ρ : Representation K Γ V} {F G : ℍ → V}
+
+theorem add (hF : IsEquivariantPrimitiveWith ρ F) (hG : IsEquivariantPrimitiveWith ρ G) :
+    IsEquivariantPrimitiveWith ρ (F + G) := fun γ =>
+  ⟨hF.cocycle γ + hG.cocycle γ, fun τ => by
+    rw [Pi.add_apply, Pi.add_apply, map_add, ← hF.sub_eq_cocycle γ τ, ← hG.sub_eq_cocycle γ
+      τ]; abel⟩
+
+theorem cocycle_add (hF : IsEquivariantPrimitiveWith ρ F) (hG : IsEquivariantPrimitiveWith ρ G) :
+    (add hF hG).cocycle = hF.cocycle + hG.cocycle := by
+  funext γ
+  change (F + G) ((γ : SL(2, ℤ)) • I) - ρ γ ((F + G) I) = (F _ - ρ γ (F I)) + (G _ - ρ γ (G I))
+  rw [Pi.add_apply, Pi.add_apply, map_add]
+  abel
+
+private theorem _root_.HeckeEis.EichlerLinAux.smul (hF : IsEquivariantPrimitiveWith ρ F) (c : K) :
+    IsEquivariantPrimitiveWith ρ (c • F) := fun γ =>
+  ⟨c • hF.cocycle γ, fun τ => by
+    rw [Pi.smul_apply, Pi.smul_apply, map_smul, ← hF.sub_eq_cocycle γ τ, smul_sub]⟩
+
+p2m_export "HeckeEis.EichlerLinAux" "smul"
+theorem cocycle_smul (hF : IsEquivariantPrimitiveWith ρ F) (c : K) :
+    (smul hF c).cocycle = c • hF.cocycle := by
+  funext γ
+  change (c • F) ((γ : SL(2, ℤ)) • I) - ρ γ ((c • F) I) = c • (F _ - ρ γ (F I))
+  rw [Pi.smul_apply, Pi.smul_apply, map_smul, smul_sub]
+
+end EichlerLinAux
+
+open EichlerLinAux in
+theorem SolMain.essmul (n N : ℕ) [NeZero N] (c : ℂ) (f : CuspForm (Gamma0 N) ((n : ℤ) + 2)) :
+    eichlerShimuraMap n N ⇑(c • f) = c • eichlerShimuraMap n N f := by
+  obtain ⟨F, hEF, hF, hpF⟩ := exists_isEichlerIntegral_isParabolicCocycle N n f
+  have hEcF : IsEichlerIntegral n (⇑(c • f)) (c • F) := hEF.smul c
+  have hpcF : IsParabolicCocycle ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (smul hF c).cocycle
+    :=
+    by
+    intro γ hγ
+    rw [cocycle_smul hF c, Pi.smul_apply]
+    exact Submodule.smul_mem _ c (hpF γ hγ)
+  rw [eichlerShimuraMap_eq_coeffH1parMk n N _ hEcF (smul hF c) hpcF,
+    eichlerShimuraMap_eq_coeffH1parMk n N _ hEF hF hpF, ← map_smul]
+  congr 1
+  exact Subtype.ext (cocycle_smul hF c)
+
+end HeckeEis
+
+end
+
+open scoped MatrixGroups ModularForm in
+theorem solution (n N : ℕ) [NeZero N] (c : ℂ)
+    (f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2)) :
+    HeckeEis.eichlerShimuraMap n N ⇑(c • f) = c • HeckeEis.eichlerShimuraMap n N f :=
+  HeckeEis.SolMain.essmul n N c f
+
+end S_HeckeEis_eichlerShimuraMap_smul
+end P2MW
+export P2MW.S_HeckeEis_eichlerShimuraMap_smul (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups ModularForm
+theorem HeckeEis.eichlerShimuraMap_smul (n N : ℕ) [NeZero N] (c : ℂ)
+    (f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2)) :
+    HeckeEis.eichlerShimuraMap n N ⇑(c • f) = c • HeckeEis.eichlerShimuraMap n N f :=
+  solution n N c f
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_existsEichlerShimuraMapLinear.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_existsEichlerShimuraMapLinear.lean
new file mode 100644
index 0000000000..e2fb7d419a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_existsEichlerShimuraMapLinear.lean
@@ -0,0 +1,117 @@
+/-
+Based on Prove2Me node HeckeEis.existsEichlerShimuraMapLinear
+(0df9c703-9190-57ad-9fd3-324c5ce3ec81) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ac66899a-e5f4-51ed-b477-7f8271e0cfc5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_eichlerShimuraMap_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_eichlerShimuraMap_smul
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# ℂ-linearity of the Eichler–Shimura map
+
+Theorem statement: `HeckeEis.existsEichlerShimuraMapLinear`
+(`0df9c703-9190-57ad-9fd3-324c5ce3ec81`), by Claude, 2026-09-05.
+
+Proof: submission `ac66899a-e5f4-51ed-b477-7f8271e0cfc5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix natural numbers $n$ and $N$ with $N \neq 0$. Let $\rho$ denote the representation of
+$\Gamma_0(N)$ obtained by restricting [`HeckeEis.binaryFormRepSL ℂ
+n`](def/HeckeEis_BinaryFormRep.html#L61) along the inclusion of $\Gamma_0(N)$ into
+$\mathrm{SL}(2,\mathbb{Z})$, that is, the action of $\mathrm{SL}(2,\mathbb{Z})$ on the space of
+degree-$n$ homogeneous polynomials in $\mathbb{C}[X_0,X_1]$ by the substitution $X_j \mapsto \sum_i
+M_{ij} X_i$ for $M$ the integral matrix underlying the group element. Let
+[`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100) $\rho$ be the quotient of the submodule
+of parabolic cocycles (those cocycles $z : \Gamma_0(N) \to \mathrm{BinaryForm}\,\mathbb{C}\,n$ with
+$z\gamma$ in the range of $\rho\gamma - 1$ whenever the trace of $\gamma$ has square $4$) by the
+submodule of coboundaries. The assertion is that there exists a $\mathbb{C}$-linear map $ES$ from
+the space of cusp forms of weight $(n : \mathbb{Z}) + 2$ for $\Gamma_0(N)$ to this parabolic
+cohomology module such that for every such cusp form $f$ one has $ES\,f =$
+[`HeckeEis.eichlerShimuraMap`](def/HeckeEis_EichlerIntegral.html#L114) $n\,N$ applied to the
+underlying function $\mathbb{H} \to \mathbb{C}$ of $f$; the latter is, by definition, the class of
+the cocycle $\gamma \mapsto F(\gamma \cdot i) - \rho\gamma(F(i))$ of a chosen equivariant primitive
+$F$ that is an Eichler integral of $f$ with parabolic cocycle, when such an $F$ exists, and $0$
+otherwise. The conclusion is a bare existential statement, so no particular linear map is named.
+
+This is the linearity of the classical Eichler–Shimura map $S_{n+2}(\Gamma_0(N)) \to
+H^1_{\mathrm{par}}(\Gamma_0(N), \mathrm{Sym}^n)$, here realised with coefficients in binary forms of
+degree $n$ and with the class of a cusp form defined through a choice of admissible Eichler
+integral. It is used downstream in the injectivity of the Eichler–Shimura map and in the
+construction of integral and mod-$p$ eigenclasses in parabolic cohomology attached to Hecke
+eigenforms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_existsEichlerShimuraMapLinear.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_existsEichlerShimuraMapLinear
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "binaryFormRepSL coeffH1par eichlerShimuraMap eichlerShimuraMap_add \
+  eichlerShimuraMap_smul"
+p2m_open "HeckeEis"
+
+open UpperHalfPlane MvPolynomial CongruenceSubgroup
+open scoped MatrixGroups ModularForm
+
+theorem SolMain.lin (n N : ℕ) [NeZero N] :
+    ∃ ES : CuspForm (Gamma0 N) ((n : ℤ) + 2) →ₗ[ℂ] coeffH1par ((binaryFormRepSL ℂ n).comp (Gamma0
+      N).subtype),
+      ∀ f : CuspForm (Gamma0 N) ((n : ℤ) + 2), ES f = eichlerShimuraMap n N f :=
+  ⟨{ toFun := fun f => eichlerShimuraMap n N ⇑f,
+      map_add' := fun f g => eichlerShimuraMap_add n N f g,
+      map_smul' := fun c f => by rw [RingHom.id_apply]; exact eichlerShimuraMap_smul n N c f },
+    fun _ => rfl⟩
+
+end HeckeEis
+
+end
+
+open scoped MatrixGroups ModularForm in
+theorem solution (n N : ℕ) [NeZero N] :
+    ∃ ES : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2) →ₗ[ℂ] HeckeEis.coeffH1par
+      ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype),
+      ∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2), ES f = HeckeEis.eichlerShimuraMap
+        n N f :=
+  HeckeEis.SolMain.lin n N
+
+end S_HeckeEis_existsEichlerShimuraMapLinear
+end P2MW
+export P2MW.S_HeckeEis_existsEichlerShimuraMapLinear (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups ModularForm
+theorem HeckeEis.existsEichlerShimuraMapLinear (n N : ℕ) [NeZero N] :
+    ∃ ES : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2) →ₗ[ℂ] HeckeEis.coeffH1par
+      ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype),
+      ∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2), ES f = HeckeEis.eichlerShimuraMap
+        n N f :=
+  solution n N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_basis_coeffH1par_int_complex.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_basis_coeffH1par_int_complex.lean
new file mode 100644
index 0000000000..6c39264a1b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_basis_coeffH1par_int_complex.lean
@@ -0,0 +1,453 @@
+/-
+Based on Prove2Me node HeckeEis.exists_basis_coeffH1par_int_complex
+(7a666521-75ef-5177-b04f-d9e0e59dcc7b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 251e56b9-dd31-5580-a10e-a7922e1ee4db
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Basic.Complex.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+
+import Mathlib.GroupTheory.Schreier
+import Mathlib.LinearAlgebra.FreeModule.PID
+import Mathlib.LinearAlgebra.Matrix.FixedDetMatrices
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_coeffH1par_map_int_rat_injective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_coeffH1par_map_ringHom
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_ne_zero_smul_eq_coeffH1par_map_int_rat
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_linearIndependent_coeffH1par_map_rat_complex
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_mem_span_range_coeffH1par_map_rat_complex
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integral basis of parabolic cohomology maps to a complex basis
+
+Theorem statement: `HeckeEis.exists_basis_coeffH1par_int_complex`
+(`7a666521-75ef-5177-b04f-d9e0e59dcc7b`), by Claude, 2026-09-05.
+
+Proof: submission `251e56b9-dd31-5580-a10e-a7922e1ee4db`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix natural numbers $n$ and $N$ with $N \neq 0$, and write $\Gamma = \Gamma_0(N) \le
+\mathrm{SL}_2(\mathbb{Z})$. For a commutative ring $K$, let $\mathrm{BinaryForm}\,K\,n$ be the
+degree-$n$ homogeneous part of $K[X_0,X_1]$ and let
+[`HeckeEis.binaryFormRepSL`](def/HeckeEis_BinaryFormRep.html#L61) be the representation of
+$\mathrm{SL}_2(\mathbb{Z})$ on it in which $g$ acts by the substitution $X_j \mapsto \sum_i g_{ij}
+X_i$; restricting along the inclusion of $\Gamma$ gives a representation $\rho_K$ of $\Gamma$. Here
+[`HeckeEis.coeffParabolicCocycles`](def/Gamma0CoeffCohomology.html#L75) $\rho_K$ is the
+$K$-submodule of maps $z : \Gamma \to \mathrm{BinaryForm}\,K\,n$ satisfying $z(gh) = z(g) +
+\rho_K(g)\,z(h)$ and, for every $\gamma \in \Gamma$ whose integral matrix has $\mathrm{tr}(\gamma)^2
+= 4$, $z(\gamma) \in \mathrm{range}(\rho_K(\gamma) - 1)$; and
+[`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100) $\rho_K$ is its quotient by the
+coboundaries it contains, with quotient map
+[`HeckeEis.coeffH1parMk`](def/Gamma0CoeffCohomology.html#L111). Let $\Phi$ be an additive
+homomorphism from [`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100) $\rho_{\mathbb{Z}}$
+to [`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100) $\rho_{\mathbb{C}}$ such that every
+integral parabolic cocycle $z$ admits a complex parabolic cocycle $w$ with $w(g)$ the image of
+$z(g)$ under coefficientwise application of $\mathbb{Z} \to \mathbb{C}$ for all $g \in \Gamma$, and
+with $\Phi[z] = [w]$. The conclusion: there are a natural number $t$, a $\mathbb{Z}$-basis $b$ of
+[`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100) $\rho_{\mathbb{Z}}$ indexed by
+$\mathrm{Fin}\,t$ and a $\mathbb{C}$-basis $c$ of
+[`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100) $\rho_{\mathbb{C}}$ indexed by the same
+$\mathrm{Fin}\,t$ with $c_i = \Phi(b_i)$ for all $i$.
+
+This is the statement that $H^1_{\mathrm{par}}(\Gamma_0(N), \mathrm{Sym}^n)$ over $\mathbb{Z}$ is
+free of finite rank and forms an integral structure in its complex counterpart, in the
+basis-to-basis form: an operator preserving the integral classes therefore has the same integer
+matrix on both sides. It feeds the construction of integral structures on spaces of cusp forms, the
+passage from complex Hecke eigenforms to mod-$p$ eigenclasses, and the finiteness of the integral
+Hecke algebra.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_exists_basis_coeffH1par_int_complex.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_exists_basis_coeffH1par_int_complex
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binaryFormRepSL coeffCocycles coeffParabolicCocycles coeffH1par \
+  coeffH1parMk coeffH1parMk_surjective exists_coeffH1par_map_ringHom \
+  coeffH1par_map_int_rat_injective exists_ne_zero_smul_eq_coeffH1par_map_int_rat \
+  mem_span_range_coeffH1par_map_rat_complex linearIndependent_coeffH1par_map_rat_complex \
+  coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero"
+namespace GenAux
+p2m_open "HeckeEis"
+
+variable {G : Type*} [Group G] {K : Type*} [CommRing K] {V : Type*} [AddCommGroup V] [Module K V]
+
+theorem coeffCocycles_apply_one {ρ : Representation K G V} {z : G → V} (hz : z ∈ coeffCocycles ρ) :
+    z 1 = 0 := by
+  have h := hz 1 1
+  rw [mul_one, map_one, Module.End.one_apply] at h
+  have : z 1 + z 1 = z 1 + 0 := by rw [add_zero]; exact h.symm
+  exact add_left_cancel this
+
+theorem coeffCocycles_apply_inv {ρ : Representation K G V} {z : G → V} (hz : z ∈ coeffCocycles ρ)
+    (g : G) :
+    z g⁻¹ = -(ρ g⁻¹ (z g)) := by
+  have h := hz g⁻¹ g
+  rw [inv_mul_cancel, coeffCocycles_apply_one hz] at h
+  exact eq_neg_of_add_eq_zero_left h.symm
+
+theorem mem_of_mem_coeffCocycles_of_closure_eq_top {ρ : Representation K G V} {z : G → V}
+    (hz : z ∈ coeffCocycles ρ)
+    (M : AddSubgroup V) (hM : ∀ (g : G) (v : V), v ∈ M → ρ g v ∈ M) {s : Set G}
+    (hs : Subgroup.closure s = ⊤)
+    (h : ∀ g ∈ s, z g ∈ M) (g : G) : z g ∈ M := by
+  let H : Subgroup G :=
+    { carrier := {g | z g ∈ M}
+      one_mem' := by
+        change z 1 ∈ M
+        rw [coeffCocycles_apply_one hz]; exact M.zero_mem
+      mul_mem' := by
+        intro a b ha hb
+        change z (a * b) ∈ M
+        rw [hz a b]
+        exact M.add_mem ha (hM a _ hb)
+      inv_mem' := by
+        intro a ha
+        change z a⁻¹ ∈ M
+        rw [coeffCocycles_apply_inv hz]
+        exact M.neg_mem (hM _ _ ha) }
+  have hle : (⊤ : Subgroup G) ≤ H := by
+    rw [← hs, Subgroup.closure_le]
+    exact h
+  exact hle (Subgroup.mem_top g)
+
+theorem coeffCocycles_eq_of_eqOn {ρ : Representation K G V} {z z' : G → V}
+    (hz : z ∈ coeffCocycles ρ) (hz' : z' ∈ coeffCocycles ρ)
+    {s : Set G} (hs : Subgroup.closure s = ⊤) (h : ∀ g ∈ s, z g = z' g) : z = z' := by
+  have hd : z - z' ∈ coeffCocycles ρ := Submodule.sub_mem _ hz hz'
+  funext g
+  have := mem_of_mem_coeffCocycles_of_closure_eq_top hd ⊥ (fun g v hv => by
+    rw [AddSubgroup.mem_bot] at hv ⊢; rw [hv, map_zero]) hs (fun g hg => by
+    rw [AddSubgroup.mem_bot, Pi.sub_apply, h g hg, sub_self]) g
+  rw [AddSubgroup.mem_bot, Pi.sub_apply] at this
+  exact sub_eq_zero.mp this
+
+end HeckeEis.GenAux
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binaryFormRepSL coeffCocycles coeffParabolicCocycles coeffH1par \
+  coeffH1parMk coeffH1parMk_surjective exists_coeffH1par_map_ringHom \
+  coeffH1par_map_int_rat_injective exists_ne_zero_smul_eq_coeffH1par_map_int_rat \
+  mem_span_range_coeffH1par_map_rat_complex linearIndependent_coeffH1par_map_rat_complex \
+  coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero"
+namespace ZQAux
+p2m_open "HeckeEis"
+open CongruenceSubgroup
+open scoped MatrixGroups
+theorem Gamma_le_Gamma0 (N : ℕ) :
+    Gamma N ≤ Gamma0 N := fun _ hA => Gamma0_mem.mpr (Gamma_mem.mp hA).2.2.1
+scoped instance instGroupFG_Gamma0 (N : ℕ) [NeZero N] : Group.FG (Gamma0 N) := by
+  have : (Gamma0 N).FiniteIndex := Subgroup.finiteIndex_of_le (Gamma_le_Gamma0 N)
+  have : Group.FG SL(2, ℤ) := Group.fg_iff.mpr
+    ⟨{ModularGroup.S, ModularGroup.T}, SpecialLinearGroup.SL2Z_generators,
+      (Set.finite_singleton _).insert _⟩
+  exact Subgroup.fg_of_index_ne_zero _
+end HeckeEis.ZQAux
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binaryFormRepSL coeffCocycles coeffParabolicCocycles coeffH1par \
+  coeffH1parMk coeffH1parMk_surjective exists_coeffH1par_map_ringHom \
+  coeffH1par_map_int_rat_injective exists_ne_zero_smul_eq_coeffH1par_map_int_rat \
+  mem_span_range_coeffH1par_map_rat_complex linearIndependent_coeffH1par_map_rat_complex \
+  coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero"
+namespace RatAux
+p2m_open "HeckeEis"
+theorem exists_common_den (s : Finset ℚ) : ∃ D : ℤ, D ≠ 0 ∧ ∀ x ∈ s, ∃ m : ℤ, (D : ℚ) * x = m := by
+  classical
+  refine ⟨∏ y ∈ s, (y.den : ℤ), ?_, fun x hx => ?_⟩
+  · rw [Finset.prod_ne_zero_iff]; intro y _; exact_mod_cast y.den_nz
+  · refine ⟨(∏ y ∈ s.erase x, (y.den : ℤ)) * x.num, ?_⟩
+    rw [← Finset.mul_prod_erase s _ hx]
+    push_cast
+    rw [mul_comm ((x.den : ℚ)) _, mul_assoc, Rat.den_mul_eq_num]
+end HeckeEis.RatAux
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binaryFormRepSL coeffCocycles coeffParabolicCocycles coeffH1par \
+  coeffH1parMk coeffH1parMk_surjective exists_coeffH1par_map_ringHom \
+  coeffH1par_map_int_rat_injective exists_ne_zero_smul_eq_coeffH1par_map_int_rat \
+  mem_span_range_coeffH1par_map_rat_complex linearIndependent_coeffH1par_map_rat_complex \
+  coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero"
+namespace C2Aux
+p2m_open "HeckeEis"
+
+open MvPolynomial HeckeEis.RatAux HeckeEis.GenAux CongruenceSubgroup
+open scoped MatrixGroups
+
+theorem moduleFinite_binaryForm (n : ℕ) : Module.Finite ℤ ↥(BinaryForm ℤ n) := by
+  classical
+  have hfin : Finite {d : Fin 2 →₀ ℕ | d.degree = n} := by
+    refine Set.Finite.to_subtype ((Set.finite_range (fun k : Fin (n + 1) =>
+      Finsupp.single (0 : Fin 2) (n - (k : ℕ)) + Finsupp.single 1 (k : ℕ))).subset ?_)
+    intro d hd
+    have hsum : d 0 + d 1 = n := by
+      have h := hd
+      rw [Set.mem_ofPred_eq, Finsupp.degree_eq_sum, Fin.sum_univ_two] at h
+      exact h
+    refine ⟨⟨d 1, by omega⟩, ?_⟩
+    ext i
+    fin_cases i
+    · simp only [Fin.zero_eta, Fin.isValue, Finsupp.coe_add, Pi.add_apply, Finsupp.single_apply]
+      simp only [Fin.isValue, ↓reduceIte, one_ne_zero, add_zero]
+      omega
+    · simp only [Fin.mk_one, Fin.isValue, Finsupp.coe_add, Pi.add_apply, Finsupp.single_apply]
+      simp
+  have e : (↥{d : Fin 2 →₀ ℕ | d.degree = n} →₀ ℤ) ≃ₗ[ℤ] ↥(BinaryForm ℤ n) :=
+    (AddMonoidAlgebra.supportedEquivFinsupp (R := ℤ) (S := ℤ) {d : Fin 2 →₀ ℕ | d.degree =
+      n}).symm.trans
+      (LinearEquiv.ofEq _ (BinaryForm ℤ n) (MvPolynomial.homogeneousSubmodule_eq_finsupp_supported
+        (Fin 2) ℤ n).symm)
+  have h := Module.Finite.equiv e
+  convert h
+
+variable (n N : ℕ) [NeZero N]
+
+theorem moduleFinite_coeffParabolicCocycles :
+    Module.Finite ℤ ↥(coeffParabolicCocycles ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype)) := by
+  classical
+  have := moduleFinite_binaryForm n
+  obtain ⟨_, S, _, hS⟩ := Group.fg_iff'.mp (HeckeEis.ZQAux.instGroupFG_Gamma0 N)
+  let ev : ↥(coeffParabolicCocycles ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype)) →ₗ[ℤ] (↥S →
+    ↥(BinaryForm ℤ n)) :=
+    { toFun := fun z g => z.1 g
+      map_add' := fun _ _ => rfl
+      map_smul' := fun _ _ => rfl }
+  have : IsNoetherian ℤ (↥S → ↥(BinaryForm ℤ n)) := isNoetherian_of_isNoetherianRing_of_finite ℤ _
+  refine Module.Finite.of_injective ev fun z z' h => Subtype.ext ?_
+  exact coeffCocycles_eq_of_eqOn z.2.1 z'.2.1 hS fun g hg => congrFun h ⟨g, hg⟩
+
+theorem moduleFinite_coeffH1par :
+    Module.Finite ℤ (coeffH1par ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype)) := by
+  have := moduleFinite_coeffParabolicCocycles n N
+  exact Module.Finite.of_surjective (coeffH1parMk _) (coeffH1parMk_surjective _)
+
+theorem isTorsionFree_coeffH1par :
+    Module.IsTorsionFree ℤ (coeffH1par ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype)) := by
+  refine ⟨fun r hr a b hab => ?_⟩
+  have hr0 : r ≠ 0 := hr.ne_zero
+  have hab' : r • a = r • b := hab
+  have h : r • (a - b) = 0 := by rw [smul_sub, sub_eq_zero]; exact hab'
+  exact sub_eq_zero.mp (HeckeEis.coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero n N r hr0 _
+    h)
+
+theorem free_coeffH1par :
+    Module.Free ℤ (coeffH1par ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype)) := by
+  have := moduleFinite_coeffH1par n N
+  have := isTorsionFree_coeffH1par n N
+  exact Module.free_of_finite_type_torsion_free'
+
+omit [NeZero N] in
+theorem comp_eq_of_clauses
+    (ΦC : coeffH1par ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype) →+ coeffH1par ((binaryFormRepSL
+      ℂ n).comp (Gamma0 N).subtype))
+    (hΦC : ∀ z : ↥(coeffParabolicCocycles ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype)),
+      ∃ w : ↥(coeffParabolicCocycles ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype)),
+        (∀ g : Gamma0 N, ((w : Gamma0 N → ↥(BinaryForm ℂ n)) g : MvPolynomial (Fin 2) ℂ)
+            = MvPolynomial.map (Int.castRingHom ℂ) (((z : Gamma0 N → ↥(BinaryForm ℤ n)) g :
+              MvPolynomial (Fin 2) ℤ))) ∧
+        ΦC (coeffH1parMk _ z) = coeffH1parMk _ w)
+    (ΦQ : coeffH1par ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype) →+ coeffH1par ((binaryFormRepSL
+      ℚ n).comp (Gamma0 N).subtype))
+    (hΦQ : ∀ z : ↥(coeffParabolicCocycles ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype)),
+      ∃ w : ↥(coeffParabolicCocycles ((binaryFormRepSL ℚ n).comp (Gamma0 N).subtype)),
+        (∀ g : Gamma0 N, ((w : Gamma0 N → ↥(BinaryForm ℚ n)) g : MvPolynomial (Fin 2) ℚ)
+            = MvPolynomial.map (Int.castRingHom ℚ) (((z : Gamma0 N → ↥(BinaryForm ℤ n)) g :
+              MvPolynomial (Fin 2) ℤ))) ∧
+        ΦQ (coeffH1parMk _ z) = coeffH1parMk _ w)
+    (Ψ : coeffH1par ((binaryFormRepSL ℚ n).comp (Gamma0 N).subtype) →+ coeffH1par ((binaryFormRepSL
+      ℂ n).comp (Gamma0 N).subtype))
+    (hΨ : ∀ z : ↥(coeffParabolicCocycles ((binaryFormRepSL ℚ n).comp (Gamma0 N).subtype)),
+      ∃ w : ↥(coeffParabolicCocycles ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype)),
+        (∀ g : Gamma0 N, ((w : Gamma0 N → ↥(BinaryForm ℂ n)) g : MvPolynomial (Fin 2) ℂ)
+            = MvPolynomial.map (algebraMap ℚ ℂ) (((z : Gamma0 N → ↥(BinaryForm ℚ n)) g :
+              MvPolynomial (Fin 2) ℚ))) ∧
+        Ψ (coeffH1parMk _ z) = coeffH1parMk _ w)
+    (x : coeffH1par ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype)) : ΦC x = Ψ (ΦQ x) := by
+  obtain ⟨z, rfl⟩ := coeffH1parMk_surjective _ x
+  obtain ⟨w₁, hw₁, h₁⟩ := hΦQ z
+  obtain ⟨w₂, hw₂, h₂⟩ := hΨ w₁
+  obtain ⟨w₃, hw₃, h₃⟩ := hΦC z
+  rw [h₃, h₁, h₂]
+  congr 1
+  apply Subtype.ext; funext g; apply Subtype.ext
+  rw [hw₃ g, hw₂ g, hw₁ g, map_map, RingHom.ext_int ((algebraMap ℚ ℂ).comp (Int.castRingHom ℚ))
+    (Int.castRingHom ℂ)]
+
+end HeckeEis.C2Aux
+end
+open P2MW.S_HeckeEis_exists_basis_coeffH1par_int_complex.HeckeEis
+  P2MW.S_HeckeEis_exists_basis_coeffH1par_int_complex.HeckeEis.ZQAux
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binaryFormRepSL coeffCocycles coeffParabolicCocycles coeffH1par \
+  coeffH1parMk coeffH1parMk_surjective exists_coeffH1par_map_ringHom \
+  coeffH1par_map_int_rat_injective exists_ne_zero_smul_eq_coeffH1par_map_int_rat \
+  mem_span_range_coeffH1par_map_rat_complex linearIndependent_coeffH1par_map_rat_complex \
+  coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero"
+namespace C2Aux
+p2m_open "HeckeEis"
+
+open MvPolynomial HeckeEis.RatAux HeckeEis.GenAux CongruenceSubgroup
+open scoped MatrixGroups
+
+theorem main (n N : ℕ) [NeZero N]
+    (ΦC : coeffH1par ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype) →+ coeffH1par ((binaryFormRepSL
+      ℂ n).comp (Gamma0 N).subtype))
+    (hΦC : ∀ z : ↥(coeffParabolicCocycles ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype)),
+      ∃ w : ↥(coeffParabolicCocycles ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype)),
+        (∀ g : Gamma0 N, ((w : Gamma0 N → ↥(BinaryForm ℂ n)) g : MvPolynomial (Fin 2) ℂ)
+            = MvPolynomial.map (Int.castRingHom ℂ) (((z : Gamma0 N → ↥(BinaryForm ℤ n)) g :
+              MvPolynomial (Fin 2) ℤ))) ∧
+        ΦC (coeffH1parMk _ z) = coeffH1parMk _ w) :
+    ∃ (t : ℕ) (b : Module.Basis (Fin t) ℤ (coeffH1par ((binaryFormRepSL ℤ n).comp (Gamma0
+      N).subtype)))
+      (c : Module.Basis (Fin t) ℂ (coeffH1par ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype))),
+      ∀ i, c i = ΦC (b i) := by
+  classical
+  obtain ⟨ΦQ, hΦQ⟩ := HeckeEis.exists_coeffH1par_map_ringHom (Int.castRingHom ℚ) n (Gamma0 N)
+  obtain ⟨Ψ, hΨ⟩ := HeckeEis.exists_coeffH1par_map_ringHom (algebraMap ℚ ℂ) n (Gamma0 N)
+  have hcomp : ∀ x, ΦC x = Ψ (ΦQ x) := comp_eq_of_clauses n N ΦC hΦC ΦQ hΦQ Ψ hΨ
+  have := moduleFinite_coeffH1par n N
+  have := free_coeffH1par n N
+  let b : Module.Basis (Fin (Module.finrank ℤ (coeffH1par ((binaryFormRepSL ℤ n).comp (Gamma0
+    N).subtype)))) ℤ
+      (coeffH1par ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype)) := Module.finBasis ℤ _
+  have hinjQ : Function.Injective ΦQ := HeckeEis.coeffH1par_map_int_rat_injective n N ΦQ hΦQ
+  have hliQ : LinearIndependent ℚ (fun i => ΦQ (b i)) := by
+    rw [linearIndependent_iff']
+    intro s r hr i hi
+    obtain ⟨D, hD, hden⟩ := exists_common_den (s.image r)
+    choose m hm using fun j (hj : j ∈ s) => hden (r j) (Finset.mem_image_of_mem r hj)
+    have h1 : ΦQ (∑ j ∈ s, (if hj : j ∈ s then m j hj else 0) • b j) = 0 := by
+      rw [map_sum]
+      have : ∀ j ∈ s, ΦQ ((if hj : j ∈ s then m j hj else 0) • b j) = (D : ℚ) • (r j • ΦQ (b j)) :=
+        by
+        intro j hj
+        rw [dite_eq_left hj, map_zsmul, ← mul_smul, hm j hj, Int.cast_smul_eq_zsmul]
+      rw [Finset.sum_congr rfl this, ← Finset.smul_sum, hr, smul_zero]
+    have h2 : (∑ j ∈ s, (if hj : j ∈ s then m j hj else 0) • b j) = 0 :=
+      hinjQ (h1.trans (map_zero ΦQ).symm)
+    have h3 := (linearIndependent_iff'.mp b.linearIndependent) s _ h2 i hi
+    rw [dite_eq_left hi] at h3
+    have h4 := hm i hi
+    rw [h3, Int.cast_zero, mul_eq_zero] at h4
+    exact h4.resolve_left (Int.cast_ne_zero.mpr hD)
+  have hspQ : ⊤ ≤ Submodule.span ℚ (Set.range fun i => ΦQ (b i)) := by
+    intro x _
+    obtain ⟨m, y, hm, hy⟩ := HeckeEis.exists_ne_zero_smul_eq_coeffH1par_map_int_rat n N ΦQ hΦQ x
+    have hx : x = (m : ℚ)⁻¹ • ΦQ y := by
+      rw [hy, ← Int.cast_smul_eq_zsmul ℚ, smul_smul, inv_mul_cancel₀ (Int.cast_ne_zero.mpr hm),
+        one_smul]
+    rw [hx, ← b.sum_repr y, map_sum]
+    refine Submodule.smul_mem _ _ (Submodule.sum_mem _ fun i _ => ?_)
+    rw [map_zsmul, ← Int.cast_smul_eq_zsmul ℚ]
+    exact Submodule.smul_mem _ _ (Submodule.subset_span ⟨i, rfl⟩)
+  let bQ : Module.Basis (Fin (Module.finrank ℤ (coeffH1par ((binaryFormRepSL ℤ n).comp (Gamma0
+    N).subtype)))) ℚ
+      (coeffH1par ((binaryFormRepSL ℚ n).comp (Gamma0 N).subtype)) := Module.Basis.mk hliQ hspQ
+  have hbQ : ∀ i, bQ i = ΦQ (b i) := fun i => Module.Basis.mk_apply _ _ i
+  obtain ⟨S, hS⟩ := Group.fg_def.mp (HeckeEis.ZQAux.instGroupFG_Gamma0 N)
+  have hliC : LinearIndependent ℂ (fun i => Ψ (ΦQ (b i))) :=
+    HeckeEis.linearIndependent_coeffH1par_map_rat_complex n (Gamma0 N) Ψ hΨ (fun i => ΦQ (b i)) hliQ
+  have hspC : ⊤ ≤ Submodule.span ℂ (Set.range fun i => Ψ (ΦQ (b i))) := by
+    intro X _
+    have hX := HeckeEis.mem_span_range_coeffH1par_map_rat_complex n (Gamma0 N) Ψ hΨ X
+    refine Submodule.span_le.mpr ?_ hX
+    rintro _ ⟨x, rfl⟩
+    obtain ⟨D, hD, hden⟩ := exists_common_den (Finset.univ.image fun i => bQ.repr x i)
+    choose m hm using fun i => hden (bQ.repr x i) (Finset.mem_image_of_mem _ (Finset.mem_univ i))
+    have hDx : D • x = ∑ i, m i • ΦQ (b i) := by
+      conv_lhs => rw [← bQ.sum_repr x]
+      rw [Finset.smul_sum]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [hbQ, ← Int.cast_smul_eq_zsmul ℚ, smul_smul, hm i, Int.cast_smul_eq_zsmul]
+    have hΨx : Ψ x = (D : ℂ)⁻¹ • Ψ (D • x) := by
+      rw [map_zsmul, ← Int.cast_smul_eq_zsmul ℂ, smul_smul, inv_mul_cancel₀ (Int.cast_ne_zero.mpr
+        hD), one_smul]
+    rw [SetLike.mem_coe, hΨx, hDx, map_sum]
+    refine Submodule.smul_mem _ _ (Submodule.sum_mem _ fun i _ => ?_)
+    rw [map_zsmul, ← Int.cast_smul_eq_zsmul ℂ]
+    exact Submodule.smul_mem _ _ (Submodule.subset_span ⟨i, rfl⟩)
+  refine ⟨_, b, Module.Basis.mk hliC hspC, fun i => ?_⟩
+  rw [Module.Basis.mk_apply, hcomp]
+
+end HeckeEis.C2Aux
+end
+
+open scoped MatrixGroups in
+theorem solution (n N : ℕ) [NeZero N]
+    (Φ : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℤ n).comp (CongruenceSubgroup.Gamma0
+      N).subtype) →+ HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype))
+    (hΦ : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℤ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+        (CongruenceSubgroup.Gamma0 N).subtype)),
+        (∀ g : CongruenceSubgroup.Gamma0 N, ((w : CongruenceSubgroup.Gamma0 N →
+          ↥(HeckeEis.BinaryForm ℂ n)) g : MvPolynomial (Fin 2) ℂ)
+            = MvPolynomial.map (Int.castRingHom ℂ)
+                (((z : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℤ n)) g : MvPolynomial
+                  (Fin 2) ℤ))) ∧
+        Φ (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w) :
+    ∃ (t : ℕ) (b : Module.Basis (Fin t) ℤ (HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℤ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)))
+      (c : Module.Basis (Fin t) ℂ (HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+        (CongruenceSubgroup.Gamma0 N).subtype))),
+      ∀ i, c i = Φ (b i) :=
+  HeckeEis.C2Aux.main n N Φ hΦ
+
+end S_HeckeEis_exists_basis_coeffH1par_int_complex
+end P2MW
+export P2MW.S_HeckeEis_exists_basis_coeffH1par_int_complex (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.exists_basis_coeffH1par_int_complex (n N : ℕ) [NeZero N]
+    (Φ : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℤ n).comp (CongruenceSubgroup.Gamma0
+      N).subtype) →+ HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype))
+    (hΦ : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℤ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+        (CongruenceSubgroup.Gamma0 N).subtype)),
+        (∀ g : CongruenceSubgroup.Gamma0 N, ((w : CongruenceSubgroup.Gamma0 N →
+          ↥(HeckeEis.BinaryForm ℂ n)) g : MvPolynomial (Fin 2) ℂ)
+            = MvPolynomial.map (Int.castRingHom ℂ)
+                (((z : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℤ n)) g : MvPolynomial
+                  (Fin 2) ℤ))) ∧
+        Φ (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w) :
+    ∃ (t : ℕ) (b : Module.Basis (Fin t) ℤ (HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℤ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)))
+      (c : Module.Basis (Fin t) ℂ (HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+        (CongruenceSubgroup.Gamma0 N).subtype))),
+      ∀ i, c i = Φ (b i) :=
+  solution n N Φ hΦ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_coeffH1par_linearMap_coeffHeckeFun.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_coeffH1par_linearMap_coeffHeckeFun.lean
new file mode 100644
index 0000000000..6e8e432556
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_coeffH1par_linearMap_coeffHeckeFun.lean
@@ -0,0 +1,168 @@
+/-
+Copyright (c) 2026 Lean Pool contributors. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Lean Pool contributors
+-/
+
+/-
+Based on Prove2Me node HeckeEis.exists_coeffH1par_linearMap_coeffHeckeFun
+(5687e012-801a-55f3-80ae-d7d0dbe45568) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 424062d0-1ce2-5345-9953-29cf4d1db00e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0HeckeOperatorHom
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_coeffHeckeFun_mem_coeffCocycles
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_coeffHeckeFun_mem_coeffCoboundaries
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_coeffHeckeFun_mem_coeffParabolicCocycles
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of the induced Hecke endomorphism of H¹ₚₐᵣ
+
+Fix natural numbers $N$ and $\ell$ with $\ell \neq 0$, a commutative ring $K$, a $K$-module $V$, a
+representation $\rho$ of the group $\Gamma_0(N)$ on $V$ over $K$, and a $K$-linear endomorphism $a$
+of $V$. Assume the intertwining hypothesis: for every $u$ in [`HeckeEis.heckeUpper N
+ℓ`](def/Gamma0HeckeOperatorHom.html#L128), the subgroup of those elements of $\Gamma_0(N)$ whose
+upper right entry is divisible by $\ell$, one has $a \circ \rho(\mathrm{heckeConj}(u)) = \rho(u)
+\circ a$, where $\mathrm{heckeConj}(u)$ is the matrix obtained from $u = \begin{pmatrix} \alpha &
+\beta \\ \gamma & \delta\end{pmatrix}$ as $\begin{pmatrix} \alpha & \beta/\ell \\ \gamma\ell &
+\delta\end{pmatrix}$ (conjugation by $\mathrm{diag}(1,\ell)$), viewed again in $\Gamma_0(N)$. The
+conclusion asserts the existence of a $K$-linear endomorphism $T$ of [`HeckeEis.coeffH1par
+ρ`](def/Gamma0CoeffCohomology.html#L100) — the quotient of the submodule of parabolic cocycles
+(functions $z : \Gamma_0(N) \to V$ with $z(gh) = z(g) + \rho(g)z(h)$ and $z(\gamma) \in
+\mathrm{im}(\rho(\gamma) - 1)$ whenever the integral matrix $\gamma$ has $\mathrm{tr}(\gamma)^2 =
+4$) by the parabolic cocycles that are coboundaries — such that for every parabolic cocycle $z$
+there is a parabolic cocycle $w$ whose underlying function $\Gamma_0(N) \to V$ equals
+[`HeckeEis.coeffHeckeFun N ℓ ρ a z`](def/Gamma0CoeffCohomology.html#L129), the finite sum over $q
+\in \Gamma_0(N)/\mathrm{heckeUpper}(N,\ell)$ of $\rho((g\cdot
+q)^{\mathrm{out}})\bigl(a\,z(\mathrm{heckeConj}(\mathrm{transferAux}(g,q)))\bigr)$, and such that
+$T$ sends the class of $z$ to the class of $w$. Thus the statement simultaneously records that the
+cochain-level operator preserves parabolic cocycles and that it descends to the quotient.
+
+This is the construction of the Hecke operator $T_\ell$ on the parabolic cohomology
+$H^1_{\mathrm{par}}(\Gamma_0(N), \rho)$ from its cochain-level avatar, in the classical
+Eichler–Shimura setting where the coefficient datum is a linear map $a$ intertwining $\rho$ with its
+conjugate by $\mathrm{diag}(1,\ell)$. It is used in the construction of Hecke eigenclasses in
+parabolic cohomology of binary-form representations and, through those, in the integral-structure
+statement for cusp forms.
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/Theorems/Thm_HeckeEis_exists_coeffH1par_linearMap_coeffHeckeFun.lean
+
+Prove2Me submission: `424062d0-1ce2-5345-9953-29cf4d1db00e` (ACCEPTED).
+-/
+
+section privateSection
+
+
+namespace P2MW.S_HeckeEis_exists_coeffH1par_linearMap_coeffHeckeFun
+
+open scoped MatrixGroups
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis"
+  "heckeUpper heckeConj coeffCoboundaries coeffParabolicCocycles coeffH1par coeffH1parMk \
+    coeffHeckeFun coeffHeckeFun_apply coeffHeckeFun_mem_coeffCoboundaries \
+    coeffHeckeFun_mem_coeffParabolicCocycles"
+namespace InducedHeckeSol
+p2m_open "HeckeEis"
+
+open CongruenceSubgroup
+open scoped MatrixGroups
+
+variable (N ℓ : ℕ) [NeZero ℓ] {K : Type*} [CommRing K] {V : Type*} [AddCommGroup V] [Module K V]
+variable (ρ : Representation K (Gamma0 N) V) (a : V →ₗ[K] V)
+
+def coeffHeckeLin : (Gamma0 N → V) →ₗ[K] (Gamma0 N → V) where
+  toFun := coeffHeckeFun N ℓ ρ a
+  map_add' z w := by
+    funext g
+    simp only [coeffHeckeFun_apply, Pi.add_apply, map_add, Finset.sum_add_distrib]
+  map_smul' c z := by
+    funext g
+    simp only [coeffHeckeFun_apply, Pi.smul_apply, map_smul, RingHom.id_apply, Finset.smul_sum]
+
+@[scoped simp] theorem coeffHeckeLin_apply (z : Gamma0 N → V) : coeffHeckeLin N ℓ ρ a z =
+  coeffHeckeFun N ℓ ρ a z := rfl
+
+variable {ρ a}
+
+def parabolicHecke (ha : ∀ u : ↥(heckeUpper N ℓ), a ∘ₗ ρ (heckeConj N ℓ u) = ρ (u : Gamma0 N) ∘ₗ
+  a) :
+    ↥(coeffParabolicCocycles ρ) →ₗ[K] ↥(coeffParabolicCocycles ρ) :=
+  (coeffHeckeLin N ℓ ρ a).restrict fun _ hz => HeckeEis.coeffHeckeFun_mem_coeffParabolicCocycles N ℓ
+    ρ a ha hz
+
+theorem coe_parabolicHecke (ha : ∀ u : ↥(heckeUpper N ℓ), a ∘ₗ ρ (heckeConj N ℓ u) = ρ (u : Gamma0
+  N) ∘ₗ a)
+    (z : ↥(coeffParabolicCocycles ρ)) :
+    ((parabolicHecke N ℓ ha z : ↥(coeffParabolicCocycles ρ)) : Gamma0 N → V) = coeffHeckeFun N ℓ ρ a
+      z := rfl
+
+def heckeH1par (ha : ∀ u : ↥(heckeUpper N ℓ), a ∘ₗ ρ (heckeConj N ℓ u) = ρ (u : Gamma0 N) ∘ₗ a) :
+    coeffH1par ρ →ₗ[K] coeffH1par ρ :=
+  Submodule.mapQ ((coeffCoboundaries ρ).comap (coeffParabolicCocycles ρ).subtype)
+    ((coeffCoboundaries ρ).comap (coeffParabolicCocycles ρ).subtype) (parabolicHecke N ℓ ha)
+    (fun z hz => by
+      change ((parabolicHecke N ℓ ha z : ↥(coeffParabolicCocycles ρ)) : Gamma0 N → V) ∈
+        coeffCoboundaries ρ
+      rw [coe_parabolicHecke]
+      exact HeckeEis.coeffHeckeFun_mem_coeffCoboundaries N ℓ ρ a ha hz)
+
+theorem heckeH1par_mk (ha : ∀ u : ↥(heckeUpper N ℓ), a ∘ₗ ρ (heckeConj N ℓ u) = ρ (u : Gamma0 N) ∘ₗ
+  a)
+    (z : ↥(coeffParabolicCocycles ρ)) :
+    heckeH1par N ℓ ha (coeffH1parMk ρ z) = coeffH1parMk ρ (parabolicHecke N ℓ ha z) :=
+  rfl
+
+end HeckeEis.InducedHeckeSol
+
+end
+
+open _root_.HeckeEis _root_.P2MW.S_HeckeEis_exists_coeffH1par_linearMap_coeffHeckeFun.HeckeEis
+  HeckeEis.InducedHeckeSol CongruenceSubgroup in
+theorem solution (N ℓ : ℕ) [NeZero ℓ]
+    {K : Type*} [CommRing K] {V : Type*} [AddCommGroup V] [Module K V]
+    (ρ : Representation K (CongruenceSubgroup.Gamma0 N) V) (a : V →ₗ[K] V)
+    (ha : ∀ u : ↥(HeckeEis.heckeUpper N ℓ),
+      a ∘ₗ ρ (HeckeEis.heckeConj N ℓ u) = ρ (u : CongruenceSubgroup.Gamma0 N) ∘ₗ a) :
+    ∃ T : HeckeEis.coeffH1par ρ →ₗ[K] HeckeEis.coeffH1par ρ,
+      ∀ z : ↥(HeckeEis.coeffParabolicCocycles ρ), ∃ w : ↥(HeckeEis.coeffParabolicCocycles ρ),
+        (w : CongruenceSubgroup.Gamma0 N → V) = HeckeEis.coeffHeckeFun N ℓ ρ a z ∧
+          T (HeckeEis.coeffH1parMk ρ z) = HeckeEis.coeffH1parMk ρ w :=
+  ⟨heckeH1par N ℓ ha, fun z => ⟨parabolicHecke N ℓ ha z, rfl, heckeH1par_mk N ℓ ha z⟩⟩
+
+end S_HeckeEis_exists_coeffH1par_linearMap_coeffHeckeFun
+end P2MW
+export P2MW.S_HeckeEis_exists_coeffH1par_linearMap_coeffHeckeFun (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+
+theorem HeckeEis.exists_coeffH1par_linearMap_coeffHeckeFun (N ℓ : ℕ) [NeZero ℓ]
+    {K : Type*} [CommRing K] {V : Type*} [AddCommGroup V] [Module K V]
+    (ρ : Representation K (CongruenceSubgroup.Gamma0 N) V) (a : V →ₗ[K] V)
+    (ha : ∀ u : ↥(HeckeEis.heckeUpper N ℓ),
+      a ∘ₗ ρ (HeckeEis.heckeConj N ℓ u) = ρ (u : CongruenceSubgroup.Gamma0 N) ∘ₗ a) :
+    ∃ T : HeckeEis.coeffH1par ρ →ₗ[K] HeckeEis.coeffH1par ρ,
+      ∀ z : ↥(HeckeEis.coeffParabolicCocycles ρ), ∃ w : ↥(HeckeEis.coeffParabolicCocycles ρ),
+        (w : CongruenceSubgroup.Gamma0 N → V) = HeckeEis.coeffHeckeFun N ℓ ρ a z ∧
+          T (HeckeEis.coeffH1parMk ρ z) = HeckeEis.coeffH1parMk ρ w :=
+            _root_.P2MW.S_HeckeEis_exists_coeffH1par_linearMap_coeffHeckeFun.solution N ℓ ρ a ha
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_coeffH1par_map_ringHom.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_coeffH1par_map_ringHom.lean
new file mode 100644
index 0000000000..4f586125e9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_coeffH1par_map_ringHom.lean
@@ -0,0 +1,372 @@
+/-
+Based on Prove2Me node HeckeEis.exists_coeffH1par_map_ringHom
+(4a939097-2cd8-5000-a1e3-d6f0a5fa32b7) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 835b0e2a-a3e2-5558-9415-b2758ab30249
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+
+import Mathlib.Algebra.MvPolynomial.Monad
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Change of coefficients for parabolic H¹ of binary forms
+
+Theorem statement: `HeckeEis.exists_coeffH1par_map_ringHom`
+(`4a939097-2cd8-5000-a1e3-d6f0a5fa32b7`), by Claude, 2026-09-05.
+
+Proof: submission `835b0e2a-a3e2-5558-9415-b2758ab30249`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ and $R'$ be commutative rings, $\varphi\colon R\to R'$ a ring homomorphism, $n$ a natural
+number and $\Gamma$ any subgroup of $\mathrm{SL}_2(\mathbb Z)$. For a commutative ring $S$ let
+$\rho_S$ denote the representation of $\Gamma$ obtained by restricting along the inclusion
+$\Gamma\hookrightarrow \mathrm{SL}_2(\mathbb Z)$ the representation
+[`HeckeEis.binaryFormRepSL`](def/HeckeEis_BinaryFormRep.html#L61) of $\mathrm{SL}_2(\mathbb Z)$ on
+the degree-$n$ homogeneous part $\mathrm{BinaryForm}\,S\,n$ of $S[X_0,X_1]$, where a matrix $M$ with
+integer entries acts by the substitution $X_j\mapsto \sum_i (M_{ij}\bmod S)\,X_i$. Here
+[`HeckeEis.coeffParabolicCocycles`](def/Gamma0CoeffCohomology.html#L75) $\rho_S$ is the
+$S$-submodule of maps $z\colon\Gamma\to \mathrm{BinaryForm}\,S\,n$ satisfying the cocycle identity
+$z(gh)=z(g)+\rho_S(g)z(h)$ and, for every $\gamma\in\Gamma$ whose underlying integer matrix has
+trace squared equal to $4$, the condition $z(\gamma)\in \mathrm{range}(\rho_S(\gamma)-1)$;
+[`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100) $\rho_S$ is its quotient by the
+coboundaries lying in it, with quotient map
+[`HeckeEis.coeffH1parMk`](def/Gamma0CoeffCohomology.html#L111). The assertion is that there exists
+an additive group homomorphism $\Phi$ from
+[`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100) $\rho_R$ to
+[`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100) $\rho_{R'}$ such that for every
+parabolic cocycle $z$ over $R$ there is a parabolic cocycle $w$ over $R'$ with
+$w(g)=\mathrm{MvPolynomial.map}\,\varphi\,(z(g))$ in $R'[X_0,X_1]$ for all $g\in\Gamma$, and $\Phi$
+of the class of $z$ equals the class of $w$.
+
+This is the coefficient-change map on parabolic cohomology with binary-form coefficients, induced by
+applying $\varphi$ to the coefficients of a cocycle; the existential formulation packages the map
+together with the fact that it is computed by coefficientwise pushforward of cocycle
+representatives. It is used in the construction of integral structures on spaces of cusp forms and
+in comparing bases and Hecke eigenclasses of $H^1_{\mathrm{par}}$ over different coefficient rings,
+such as $\mathbb Z$ and $\mathbb C$ or a ring and its reduction.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_exists_coeffH1par_map_ringHom.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_exists_coeffH1par_map_ringHom
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff IsParabolicCocycle \
+  coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff"
+namespace CoeffMapAux
+p2m_open "HeckeEis"
+
+open MvPolynomial
+open scoped MatrixGroups
+
+variable {R R' : Type*} [CommRing R] [CommRing R']
+
+theorem binarySubst_eq_bind₁ (S : Type*) [CommRing S] (M : Matrix (Fin 2) (Fin 2) ℤ)
+    (P : MvPolynomial (Fin 2) S) :
+    binarySubst S M P = bind₁ (fun j => ∑ i : Fin 2, C ((M i j : ℤ) : S) * X i) P := by
+  rw [binarySubst, aeval_eq_bind₁]
+
+theorem map_binarySubst_int (φ : ℤ →+* R) (M : Matrix (Fin 2) (Fin 2) ℤ)
+    (P : MvPolynomial (Fin 2) ℤ) :
+    MvPolynomial.map φ (binarySubst ℤ M P) = binarySubst R M (MvPolynomial.map φ P) := by
+  have key : (MvPolynomial.map φ).comp (binarySubst ℤ M : MvPolynomial (Fin 2) ℤ →ₐ[ℤ] MvPolynomial
+    (Fin 2) ℤ).toRingHom
+      = (binarySubst R M : MvPolynomial (Fin 2) R →ₐ[R] MvPolynomial (Fin 2) R).toRingHom.comp
+        (MvPolynomial.map φ) :=
+    MvPolynomial.ringHom_ext (fun a => by simp []) (fun j => by simp [binarySubst_X])
+  exact RingHom.congr_fun key P
+
+def substCoeff (M : Matrix (Fin 2) (Fin 2) ℤ) (d d' : Fin 2 →₀ ℕ) : ℤ :=
+  AddMonoidAlgebra.coeff (binarySubst ℤ M (monomial d' 1)) d
+
+theorem binarySubst_monomial_one (M : Matrix (Fin 2) (Fin 2) ℤ) (d' : Fin 2 →₀ ℕ) :
+    binarySubst R M (monomial d' 1) = MvPolynomial.map (Int.castRingHom R) (binarySubst ℤ M
+      (monomial d' 1)) := by
+  rw [map_binarySubst_int, map_monomial, (Int.castRingHom R).map_one]
+
+theorem coeff_binarySubst (M : Matrix (Fin 2) (Fin 2) ℤ) (P : MvPolynomial (Fin 2) R)
+    (d : Fin 2 →₀ ℕ) :
+    AddMonoidAlgebra.coeff (binarySubst R M P) d =
+      ∑ d' ∈ P.support, (substCoeff M d d' : R) * AddMonoidAlgebra.coeff P d' := by
+  conv_lhs => rw [P.as_sum, map_sum, coeff_sum]
+  refine Finset.sum_congr rfl fun d' _ => ?_
+  rw [show monomial d' (AddMonoidAlgebra.coeff P d') =
+    C (AddMonoidAlgebra.coeff P d') * monomial d' 1 by rw [C_mul_monomial,
+      mul_one], map_mul, binarySubst_C,
+    coeff_C_mul, binarySubst_monomial_one, coeff_map, substCoeff, mul_comm]
+  rfl
+
+variable (f : R →+ R')
+
+def pushCoeff (P : MvPolynomial (Fin 2) R) : MvPolynomial (Fin 2) R' :=
+  ∑ d ∈ P.support, monomial d (f (AddMonoidAlgebra.coeff P d))
+
+@[scoped simp] theorem coeff_pushCoeff (P : MvPolynomial (Fin 2) R) (d : Fin 2 →₀ ℕ) :
+    AddMonoidAlgebra.coeff (pushCoeff f P) d = f (AddMonoidAlgebra.coeff P d) := by
+  classical
+  rw [pushCoeff, coeff_sum]
+  simp only [coeff_monomial]
+  rw [Finset.sum_ite_eq']
+  split_ifs with h
+  · rfl
+  · rw [notMem_support_iff.mp h, map_zero]
+
+theorem support_pushCoeff (P : MvPolynomial (Fin 2) R) : (pushCoeff f P).support ⊆ P.support := by
+  intro d hd
+  rw [mem_support_iff, coeff_pushCoeff] at hd
+  rw [mem_support_iff]
+  intro h; exact hd (by rw [h, map_zero])
+
+theorem pushCoeff_mem (n : ℕ) {P : MvPolynomial (Fin 2) R} (hP : P ∈ BinaryForm R n) :
+    pushCoeff f P ∈ BinaryForm R' n := by
+  rw [mem_homogeneousSubmodule] at hP ⊢
+  intro d hd
+  exact hP (mem_support_iff.mp (support_pushCoeff f P (mem_support_iff.mpr hd)))
+
+theorem pushCoeff_add (P Q : MvPolynomial (Fin 2) R) :
+    pushCoeff f (P + Q) = pushCoeff f P + pushCoeff f Q := by
+  ext d; simp
+
+theorem pushCoeff_sub (P Q : MvPolynomial (Fin 2) R) :
+    pushCoeff f (P - Q) = pushCoeff f P - pushCoeff f Q := by
+  ext d; simp
+
+theorem pushCoeff_zero : pushCoeff f (0 : MvPolynomial (Fin 2) R) = 0 := by
+  ext d; simp
+
+theorem eq_pushCoeff_iff (P : MvPolynomial (Fin 2) R) (Q : MvPolynomial (Fin 2) R') :
+    Q = pushCoeff f P ↔ ∀ d, AddMonoidAlgebra.coeff Q d = f (AddMonoidAlgebra.coeff P d) := by
+  constructor
+  · rintro rfl d; exact coeff_pushCoeff f P d
+  · intro h; ext d; rw [h d, coeff_pushCoeff]
+
+theorem pushCoeff_binarySubst (M : Matrix (Fin 2) (Fin 2) ℤ) (P : MvPolynomial (Fin 2) R) :
+    pushCoeff f (binarySubst R M P) = binarySubst R' M (pushCoeff f P) := by
+  classical
+  ext d
+  rw [coeff_pushCoeff, coeff_binarySubst, coeff_binarySubst, map_sum]
+  rw [Finset.sum_subset (support_pushCoeff f P)]
+  · refine Finset.sum_congr rfl fun d' _ => ?_
+    rw [coeff_pushCoeff, ← zsmul_eq_mul, ← zsmul_eq_mul, map_zsmul]
+  · intro d' _ hd'
+    rw [notMem_support_iff.mp hd', mul_zero]
+
+def pushForm (n : ℕ) (P : ↥(BinaryForm R n)) :
+    ↥(BinaryForm R' n) := ⟨pushCoeff f P, pushCoeff_mem f n P.2⟩
+
+@[scoped simp] theorem coe_pushForm (n : ℕ) (P : ↥(BinaryForm R n)) :
+    ((pushForm f n P : ↥(BinaryForm R' n)) : MvPolynomial (Fin 2) R') = pushCoeff f P := rfl
+
+theorem pushForm_add (n : ℕ) (P Q : ↥(BinaryForm R n)) :
+    pushForm f n (P + Q) = pushForm f n P + pushForm f n Q :=
+  Subtype.ext (by simp [pushCoeff_add])
+
+theorem pushForm_sub (n : ℕ) (P Q : ↥(BinaryForm R n)) :
+    pushForm f n (P - Q) = pushForm f n P - pushForm f n Q :=
+  Subtype.ext (by simp [pushCoeff_sub])
+
+theorem pushForm_zero (n : ℕ) :
+    pushForm f n (0 : ↥(BinaryForm R n)) = 0 := Subtype.ext (by simp [pushCoeff_zero])
+
+theorem pushForm_binaryFormRepSL (n : ℕ) (g : SL(2, ℤ)) (P : ↥(BinaryForm R n)) :
+    pushForm f n (binaryFormRepSL R n g P) = binaryFormRepSL R' n g (pushForm f n P) :=
+  Subtype.ext (by simp [pushCoeff_binarySubst])
+
+section Cocycles
+
+variable {Γ : Subgroup SL(2, ℤ)} (n : ℕ)
+
+theorem pushForm_comp_mem_coeffCocycles {z : Γ → ↥(BinaryForm R n)}
+    (hz : z ∈ coeffCocycles ((binaryFormRepSL R n).comp Γ.subtype)) :
+    (fun g => pushForm f n (z g)) ∈ coeffCocycles ((binaryFormRepSL R' n).comp Γ.subtype) := by
+  intro g h
+  change pushForm f n (z (g * h)) = pushForm f n (z g) + binaryFormRepSL R' n ((g : Γ) : SL(2, ℤ))
+    (pushForm f n (z h))
+  rw [hz g h, pushForm_add, ← pushForm_binaryFormRepSL]
+  rfl
+
+theorem isParabolicCocycle_pushForm_comp {z : Γ → ↥(BinaryForm R n)}
+    (hz : IsParabolicCocycle ((binaryFormRepSL R n).comp Γ.subtype) z) :
+    IsParabolicCocycle ((binaryFormRepSL R' n).comp Γ.subtype) (fun g => pushForm f n (z g)) := by
+  intro γ hγ
+  obtain ⟨u, hu⟩ := hz γ hγ
+  refine ⟨pushForm f n u, ?_⟩
+  rw [LinearMap.sub_apply, Module.End.one_apply] at hu ⊢
+  change binaryFormRepSL R n (γ : SL(2, ℤ)) u - u = z γ at hu
+  change binaryFormRepSL R' n (γ : SL(2, ℤ)) (pushForm f n u) - pushForm f n u = pushForm f n (z γ)
+  rw [← hu, pushForm_sub, pushForm_binaryFormRepSL]
+
+theorem pushForm_comp_mem_coeffParabolicCocycles {z : Γ → ↥(BinaryForm R n)}
+    (hz : z ∈ coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype)) :
+    (fun g => pushForm f n (z g)) ∈ coeffParabolicCocycles ((binaryFormRepSL R' n).comp Γ.subtype)
+      :=
+  ⟨pushForm_comp_mem_coeffCocycles f n hz.1, isParabolicCocycle_pushForm_comp f n hz.2⟩
+
+theorem pushForm_comp_mem_coeffCoboundaries {z : Γ → ↥(BinaryForm R n)}
+    (hz : z ∈ coeffCoboundaries ((binaryFormRepSL R n).comp Γ.subtype)) :
+    (fun g => pushForm f n (z g)) ∈ coeffCoboundaries ((binaryFormRepSL R' n).comp Γ.subtype) := by
+  obtain ⟨v, hv⟩ := (mem_coeffCoboundaries_iff _ _).mp hz
+  rw [mem_coeffCoboundaries_iff]
+  refine ⟨pushForm f n v, funext fun g => ?_⟩
+  have h := congrFun hv g
+  change binaryFormRepSL R n (g : SL(2, ℤ)) v - v = z g at h
+  change binaryFormRepSL R' n (g : SL(2, ℤ)) (pushForm f n v) - pushForm f n v = pushForm f n (z g)
+  rw [← h, pushForm_sub, pushForm_binaryFormRepSL]
+
+def pushPar : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))
+    →+ ↥(coeffParabolicCocycles ((binaryFormRepSL R' n).comp Γ.subtype)) where
+  toFun z := ⟨fun g => pushForm f n (z.1 g), pushForm_comp_mem_coeffParabolicCocycles f n z.2⟩
+  map_zero' := by
+    apply Subtype.ext; funext g
+    change pushForm f n ((0 : Γ → ↥(BinaryForm R n)) g) = 0
+    rw [Pi.zero_apply, pushForm_zero]
+  map_add' z w := by
+    apply Subtype.ext; funext g
+    change pushForm f n (z.1 g + w.1 g) = pushForm f n (z.1 g) + pushForm f n (w.1 g)
+    rw [pushForm_add]
+
+@[scoped simp] theorem pushPar_apply_coe (z : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp
+  Γ.subtype))) (g : Γ) :
+    (((pushPar f n z).1 g : ↥(BinaryForm R' n)) : MvPolynomial (Fin 2) R') = pushCoeff f (z.1 g) :=
+      rfl
+
+theorem pushPar_apply_val (z : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype)))
+    (g : Γ) :
+    (pushPar f n z).1 g = pushForm f n (z.1 g) := rfl
+
+theorem mk_eq_mk_iff {S : Type*} [CommRing S]
+    (a b : ↥(coeffParabolicCocycles ((binaryFormRepSL S n).comp Γ.subtype))) :
+    coeffH1parMk _ a = coeffH1parMk _ b ↔
+      ((a - b : ↥(coeffParabolicCocycles ((binaryFormRepSL S n).comp Γ.subtype))).1
+        ∈ coeffCoboundaries ((binaryFormRepSL S n).comp Γ.subtype)) := by
+  rw [← sub_eq_zero, ← map_sub, coeffH1parMk_eq_zero_iff]
+
+theorem pushPar_sub (a b : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))) :
+    pushPar f n (a - b) = pushPar f n a - pushPar f n b :=
+  map_sub (pushPar f n) a b
+
+theorem mk_pushPar_congr {a b : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))}
+    (h : coeffH1parMk _ a = coeffH1parMk _ b) :
+    coeffH1parMk _ (pushPar f n a) = coeffH1parMk _ (pushPar f n b) := by
+  rw [mk_eq_mk_iff] at h ⊢
+  rw [← pushPar_sub]
+  exact pushForm_comp_mem_coeffCoboundaries f n h
+
+def pushH1par :
+    coeffH1par ((binaryFormRepSL R n).comp Γ.subtype) →+
+      coeffH1par ((binaryFormRepSL R' n).comp Γ.subtype) where
+  toFun x := coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) x))
+  map_zero' := by
+    have h0 : coeffH1parMk _ (Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp
+      Γ.subtype)) 0)
+        = coeffH1parMk _ (0 : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))) :=
+          by
+      rw [Function.surjInv_eq (coeffH1parMk_surjective _), map_zero]
+    change coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) 0)) = 0
+    rw [mk_pushPar_congr f n h0, map_zero, map_zero]
+  map_add' x y := by
+    have hxy : coeffH1parMk _ (Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp
+      Γ.subtype)) (x + y))
+        = coeffH1parMk _ (Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp
+          Γ.subtype)) x
+            + Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp Γ.subtype)) y)
+              := by
+      rw [map_add, Function.surjInv_eq (coeffH1parMk_surjective _), Function.surjInv_eq
+        (coeffH1parMk_surjective _),
+        Function.surjInv_eq (coeffH1parMk_surjective _)]
+    change coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) (x + y))) = _
+    rw [mk_pushPar_congr f n hxy, map_add, map_add]
+
+theorem pushH1par_mk (z : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))) :
+    pushH1par f n (coeffH1parMk _ z) = coeffH1parMk _ (pushPar f n z) := by
+  change coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) (coeffH1parMk _
+    z))) = _
+  apply mk_pushPar_congr
+  exact Function.surjInv_eq (coeffH1parMk_surjective _) _
+
+end Cocycles
+
+end HeckeEis.CoeffMapAux
+end
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff IsParabolicCocycle \
+  coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff"
+namespace CoeffMapAux
+p2m_open "HeckeEis"
+
+open MvPolynomial
+open scoped MatrixGroups
+
+theorem pushCoeff_ringHom_eq_map {R R' : Type*} [CommRing R] [CommRing R'] (φ : R →+* R')
+    (P : MvPolynomial (Fin 2) R) :
+    pushCoeff φ.toAddMonoidHom P = MvPolynomial.map φ P := by
+  ext d
+  rw [coeff_pushCoeff, coeff_map]
+  rfl
+
+end HeckeEis.CoeffMapAux
+
+open scoped MatrixGroups in
+theorem solution {R R' : Type*} [CommRing R] [CommRing R'] (φ : R →+* R') (n : ℕ)
+    (Γ : Subgroup SL(2, ℤ)) :
+    ∃ Φ : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL R n).comp Γ.subtype) →+ HeckeEis.coeffH1par
+      ((HeckeEis.binaryFormRepSL R' n).comp Γ.subtype),
+      ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL R n).comp Γ.subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL R' n).comp Γ.subtype)),
+        (∀ g : Γ, ((w : Γ → ↥(HeckeEis.BinaryForm R' n)) g : MvPolynomial (Fin 2) R')
+            = MvPolynomial.map φ
+                (((z : Γ → ↥(HeckeEis.BinaryForm R n)) g : MvPolynomial (Fin 2) R))) ∧
+        Φ (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w := by
+  refine ⟨HeckeEis.CoeffMapAux.pushH1par φ.toAddMonoidHom n, fun z => ⟨HeckeEis.CoeffMapAux.pushPar
+    φ.toAddMonoidHom n z, ?_,
+    HeckeEis.CoeffMapAux.pushH1par_mk φ.toAddMonoidHom n z⟩⟩
+  intro g
+  rw [HeckeEis.CoeffMapAux.pushPar_apply_coe, HeckeEis.CoeffMapAux.pushCoeff_ringHom_eq_map]
+
+end S_HeckeEis_exists_coeffH1par_map_ringHom
+end P2MW
+export P2MW.S_HeckeEis_exists_coeffH1par_map_ringHom (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.exists_coeffH1par_map_ringHom {R R' : Type*} [CommRing R] [CommRing R']
+    (φ : R →+* R') (n : ℕ)
+    (Γ : Subgroup SL(2, ℤ)) :
+    ∃ Φ : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL R n).comp Γ.subtype) →+ HeckeEis.coeffH1par
+      ((HeckeEis.binaryFormRepSL R' n).comp Γ.subtype),
+      ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL R n).comp Γ.subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL R' n).comp Γ.subtype)),
+        (∀ g : Γ, ((w : Γ → ↥(HeckeEis.BinaryForm R' n)) g : MvPolynomial (Fin 2) R')
+            = MvPolynomial.map φ
+                (((z : Γ → ↥(HeckeEis.BinaryForm R n)) g : MvPolynomial (Fin 2) R))) ∧
+        Φ (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w :=
+  solution φ n Γ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_coeffH1par_semilinearMap_starRingEnd.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_coeffH1par_semilinearMap_starRingEnd.lean
new file mode 100644
index 0000000000..3278823bc9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_coeffH1par_semilinearMap_starRingEnd.lean
@@ -0,0 +1,462 @@
+/-
+Based on Prove2Me node HeckeEis.exists_coeffH1par_semilinearMap_starRingEnd
+(30dc3b73-51ef-56f4-b600-cad9e6be75e4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a7dfacd4-81e3-5b66-933c-ea1fc35adc6f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Basic.Complex.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+
+import Mathlib.Algebra.MvPolynomial.Monad
+import Mathlib.Analysis.CStarAlgebra.Classes
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A conjugate-linear involution on parabolic cohomology
+
+Theorem statement: `HeckeEis.exists_coeffH1par_semilinearMap_starRingEnd`
+(`30dc3b73-51ef-56f4-b600-cad9e6be75e4`), by Claude, 2026-09-05.
+
+Proof: submission `a7dfacd4-81e3-5b66-933c-ea1fc35adc6f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $n$ be a natural number and let $\Gamma$ be any subgroup of $\mathrm{SL}_2(\mathbb{Z})$. Write
+$\rho$ for the restriction along the inclusion $\Gamma \hookrightarrow \mathrm{SL}_2(\mathbb{Z})$ of
+the representation [`HeckeEis.binaryFormRepSL ℂ n`](def/HeckeEis_BinaryFormRep.html#L61) of
+$\mathrm{SL}_2(\mathbb{Z})$ on the space [`HeckeEis.BinaryForm ℂ
+n`](def/HeckeEis_BinaryFormRep.html#L25) of degree-$n$ homogeneous polynomials in two variables over
+$\mathbb{C}$, in which a matrix $M$ acts by the substitution $X_j \mapsto \sum_i M_{ij} X_i$. Recall
+that [`HeckeEis.coeffParabolicCocycles`](def/Gamma0CoeffCohomology.html#L75) $\rho$ consists of the
+functions $z : \Gamma \to$ `BinaryForm ℂ n` satisfying $z(gh) = z(g) + \rho(g)(z(h))$ and, for every
+$\gamma \in \Gamma$ whose underlying integral matrix has $\operatorname{tr}(\gamma)^2 = 4$,
+$z(\gamma) \in \operatorname{range}(\rho(\gamma) - 1)$; and that
+[`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100) $\rho$ is the quotient of this module
+by the preimage of the coboundaries, with
+[`HeckeEis.coeffH1parMk`](def/Gamma0CoeffCohomology.html#L111) the quotient map. The assertion is
+that there exists a map $\Phi$ from [`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100)
+$\rho$ to itself which is semilinear over the complex conjugation $\mathrm{starRingEnd}\ \mathbb{C}$
+(additive, with $\Phi(c \cdot x) = \bar{c} \cdot \Phi(x)$), such that (i) for every parabolic
+cocycle $z$ there is a parabolic cocycle $w$ with $w(g)$ equal to the coefficientwise complex
+conjugate `MvPolynomial.map (starRingEnd ℂ)` of $z(g)$ for all $g \in \Gamma$, and $\Phi$ sends the
+class of $z$ to the class of $w$; and (ii) $\Phi(\Phi(x)) = x$ for all $x$.
+
+This provides the complex conjugation acting on the parabolic cohomology $H^1_{\mathrm{par}}(\Gamma,
+\mathrm{Sym}^n\mathbb{C}^2)$, realised on cocycles by coefficientwise conjugation of binary forms,
+which is available because the $\Gamma$-action is by substitutions with integral coefficients. It is
+used in the Eichler–Shimura part of the development, where the holomorphic and antiholomorphic
+images of the Eichler–Shimura map are compared, in
+[`HeckeEis.exists_eichlerShimura_coeffH1par_binaryFormRepSL_forall_prime`]
+(thm.html#HeckeEis.exists_eichlerShimura_coeffH1par_binaryFormRepSL_forall_prime)
+and
+[`HeckeEis.isCompl_range_eichlerShimuraMap_range_conj`]
+(thm.html#HeckeEis.isCompl_range_eichlerShimuraMap_range_conj).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_exists_coeffH1par_semilinearMap_starRingEnd.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_exists_coeffH1par_semilinearMap_starRingEnd
+
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff IsParabolicCocycle \
+  coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff"
+namespace ConjAux
+p2m_open "HeckeEis"
+
+open MvPolynomial
+open scoped MatrixGroups
+
+variable {R R' : Type*} [CommRing R] [CommRing R']
+
+theorem binarySubst_eq_bind₁ (S : Type*) [CommRing S] (M : Matrix (Fin 2) (Fin 2) ℤ)
+    (P : MvPolynomial (Fin 2) S) :
+    binarySubst S M P = bind₁ (fun j => ∑ i : Fin 2, C ((M i j : ℤ) : S) * X i) P := by
+  rw [binarySubst, aeval_eq_bind₁]
+
+theorem map_binarySubst_int (φ : ℤ →+* R) (M : Matrix (Fin 2) (Fin 2) ℤ)
+    (P : MvPolynomial (Fin 2) ℤ) :
+    MvPolynomial.map φ (binarySubst ℤ M P) = binarySubst R M (MvPolynomial.map φ P) := by
+  have key : (MvPolynomial.map φ).comp (binarySubst ℤ M : MvPolynomial (Fin 2) ℤ →ₐ[ℤ] MvPolynomial
+    (Fin 2) ℤ).toRingHom
+      = (binarySubst R M : MvPolynomial (Fin 2) R →ₐ[R] MvPolynomial (Fin 2) R).toRingHom.comp
+        (MvPolynomial.map φ) :=
+    MvPolynomial.ringHom_ext (fun a => by simp []) (fun j => by simp [binarySubst_X])
+  exact RingHom.congr_fun key P
+
+def substCoeff (M : Matrix (Fin 2) (Fin 2) ℤ) (d d' : Fin 2 →₀ ℕ) : ℤ :=
+  AddMonoidAlgebra.coeff (binarySubst ℤ M (monomial d' 1)) d
+
+theorem binarySubst_monomial_one (M : Matrix (Fin 2) (Fin 2) ℤ) (d' : Fin 2 →₀ ℕ) :
+    binarySubst R M (monomial d' 1) = MvPolynomial.map (Int.castRingHom R) (binarySubst ℤ M
+      (monomial d' 1)) := by
+  rw [map_binarySubst_int, map_monomial, (Int.castRingHom R).map_one]
+
+theorem coeff_binarySubst (M : Matrix (Fin 2) (Fin 2) ℤ) (P : MvPolynomial (Fin 2) R)
+    (d : Fin 2 →₀ ℕ) :
+    AddMonoidAlgebra.coeff (binarySubst R M P) d =
+      ∑ d' ∈ P.support, (substCoeff M d d' : R) * AddMonoidAlgebra.coeff P d' := by
+  conv_lhs => rw [P.as_sum, map_sum, coeff_sum]
+  refine Finset.sum_congr rfl fun d' _ => ?_
+  rw [show monomial d' (AddMonoidAlgebra.coeff P d') =
+    C (AddMonoidAlgebra.coeff P d') * monomial d' 1 by rw [C_mul_monomial,
+      mul_one], map_mul, binarySubst_C,
+    coeff_C_mul, binarySubst_monomial_one, coeff_map, substCoeff, mul_comm]
+  rfl
+
+variable (f : R →+ R')
+
+def pushCoeff (P : MvPolynomial (Fin 2) R) : MvPolynomial (Fin 2) R' :=
+  ∑ d ∈ P.support, monomial d (f (AddMonoidAlgebra.coeff P d))
+
+@[scoped simp] theorem coeff_pushCoeff (P : MvPolynomial (Fin 2) R) (d : Fin 2 →₀ ℕ) :
+    AddMonoidAlgebra.coeff (pushCoeff f P) d = f (AddMonoidAlgebra.coeff P d) := by
+  classical
+  rw [pushCoeff, coeff_sum]
+  simp only [coeff_monomial]
+  rw [Finset.sum_ite_eq']
+  split_ifs with h
+  · rfl
+  · rw [notMem_support_iff.mp h, map_zero]
+
+theorem support_pushCoeff (P : MvPolynomial (Fin 2) R) : (pushCoeff f P).support ⊆ P.support := by
+  intro d hd
+  rw [mem_support_iff, coeff_pushCoeff] at hd
+  rw [mem_support_iff]
+  intro h; exact hd (by rw [h, map_zero])
+
+theorem pushCoeff_mem (n : ℕ) {P : MvPolynomial (Fin 2) R} (hP : P ∈ BinaryForm R n) :
+    pushCoeff f P ∈ BinaryForm R' n := by
+  rw [mem_homogeneousSubmodule] at hP ⊢
+  intro d hd
+  exact hP (mem_support_iff.mp (support_pushCoeff f P (mem_support_iff.mpr hd)))
+
+theorem pushCoeff_add (P Q : MvPolynomial (Fin 2) R) :
+    pushCoeff f (P + Q) = pushCoeff f P + pushCoeff f Q := by
+  ext d; simp
+
+theorem pushCoeff_sub (P Q : MvPolynomial (Fin 2) R) :
+    pushCoeff f (P - Q) = pushCoeff f P - pushCoeff f Q := by
+  ext d; simp
+
+theorem pushCoeff_zero : pushCoeff f (0 : MvPolynomial (Fin 2) R) = 0 := by
+  ext d; simp
+
+theorem eq_pushCoeff_iff (P : MvPolynomial (Fin 2) R) (Q : MvPolynomial (Fin 2) R') :
+    Q = pushCoeff f P ↔ ∀ d, AddMonoidAlgebra.coeff Q d = f (AddMonoidAlgebra.coeff P d) := by
+  constructor
+  · rintro rfl d; exact coeff_pushCoeff f P d
+  · intro h; ext d; rw [h d, coeff_pushCoeff]
+
+theorem pushCoeff_binarySubst (M : Matrix (Fin 2) (Fin 2) ℤ) (P : MvPolynomial (Fin 2) R) :
+    pushCoeff f (binarySubst R M P) = binarySubst R' M (pushCoeff f P) := by
+  classical
+  ext d
+  rw [coeff_pushCoeff, coeff_binarySubst, coeff_binarySubst, map_sum]
+  rw [Finset.sum_subset (support_pushCoeff f P)]
+  · refine Finset.sum_congr rfl fun d' _ => ?_
+    rw [coeff_pushCoeff, ← zsmul_eq_mul, ← zsmul_eq_mul, map_zsmul]
+  · intro d' _ hd'
+    rw [notMem_support_iff.mp hd', mul_zero]
+
+def pushForm (n : ℕ) (P : ↥(BinaryForm R n)) :
+    ↥(BinaryForm R' n) := ⟨pushCoeff f P, pushCoeff_mem f n P.2⟩
+
+@[scoped simp] theorem coe_pushForm (n : ℕ) (P : ↥(BinaryForm R n)) :
+    ((pushForm f n P : ↥(BinaryForm R' n)) : MvPolynomial (Fin 2) R') = pushCoeff f P := rfl
+
+theorem pushForm_add (n : ℕ) (P Q : ↥(BinaryForm R n)) :
+    pushForm f n (P + Q) = pushForm f n P + pushForm f n Q :=
+  Subtype.ext (by simp [pushCoeff_add])
+
+theorem pushForm_sub (n : ℕ) (P Q : ↥(BinaryForm R n)) :
+    pushForm f n (P - Q) = pushForm f n P - pushForm f n Q :=
+  Subtype.ext (by simp [pushCoeff_sub])
+
+theorem pushForm_zero (n : ℕ) :
+    pushForm f n (0 : ↥(BinaryForm R n)) = 0 := Subtype.ext (by simp [pushCoeff_zero])
+
+theorem pushForm_binaryFormRepSL (n : ℕ) (g : SL(2, ℤ)) (P : ↥(BinaryForm R n)) :
+    pushForm f n (binaryFormRepSL R n g P) = binaryFormRepSL R' n g (pushForm f n P) :=
+  Subtype.ext (by simp [pushCoeff_binarySubst])
+
+section Cocycles
+
+variable {Γ : Subgroup SL(2, ℤ)} (n : ℕ)
+
+theorem pushForm_comp_mem_coeffCocycles {z : Γ → ↥(BinaryForm R n)}
+    (hz : z ∈ coeffCocycles ((binaryFormRepSL R n).comp Γ.subtype)) :
+    (fun g => pushForm f n (z g)) ∈ coeffCocycles ((binaryFormRepSL R' n).comp Γ.subtype) := by
+  intro g h
+  change pushForm f n (z (g * h)) = pushForm f n (z g) + binaryFormRepSL R' n ((g : Γ) : SL(2, ℤ))
+    (pushForm f n (z h))
+  rw [hz g h, pushForm_add, ← pushForm_binaryFormRepSL]
+  rfl
+
+theorem isParabolicCocycle_pushForm_comp {z : Γ → ↥(BinaryForm R n)}
+    (hz : IsParabolicCocycle ((binaryFormRepSL R n).comp Γ.subtype) z) :
+    IsParabolicCocycle ((binaryFormRepSL R' n).comp Γ.subtype) (fun g => pushForm f n (z g)) := by
+  intro γ hγ
+  obtain ⟨u, hu⟩ := hz γ hγ
+  refine ⟨pushForm f n u, ?_⟩
+  rw [LinearMap.sub_apply, Module.End.one_apply] at hu ⊢
+  change binaryFormRepSL R n (γ : SL(2, ℤ)) u - u = z γ at hu
+  change binaryFormRepSL R' n (γ : SL(2, ℤ)) (pushForm f n u) - pushForm f n u = pushForm f n (z γ)
+  rw [← hu, pushForm_sub, pushForm_binaryFormRepSL]
+
+theorem pushForm_comp_mem_coeffParabolicCocycles {z : Γ → ↥(BinaryForm R n)}
+    (hz : z ∈ coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype)) :
+    (fun g => pushForm f n (z g)) ∈ coeffParabolicCocycles ((binaryFormRepSL R' n).comp Γ.subtype)
+      :=
+  ⟨pushForm_comp_mem_coeffCocycles f n hz.1, isParabolicCocycle_pushForm_comp f n hz.2⟩
+
+theorem pushForm_comp_mem_coeffCoboundaries {z : Γ → ↥(BinaryForm R n)}
+    (hz : z ∈ coeffCoboundaries ((binaryFormRepSL R n).comp Γ.subtype)) :
+    (fun g => pushForm f n (z g)) ∈ coeffCoboundaries ((binaryFormRepSL R' n).comp Γ.subtype) := by
+  obtain ⟨v, hv⟩ := (mem_coeffCoboundaries_iff _ _).mp hz
+  rw [mem_coeffCoboundaries_iff]
+  refine ⟨pushForm f n v, funext fun g => ?_⟩
+  have h := congrFun hv g
+  change binaryFormRepSL R n (g : SL(2, ℤ)) v - v = z g at h
+  change binaryFormRepSL R' n (g : SL(2, ℤ)) (pushForm f n v) - pushForm f n v = pushForm f n (z g)
+  rw [← h, pushForm_sub, pushForm_binaryFormRepSL]
+
+def pushPar : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))
+    →+ ↥(coeffParabolicCocycles ((binaryFormRepSL R' n).comp Γ.subtype)) where
+  toFun z := ⟨fun g => pushForm f n (z.1 g), pushForm_comp_mem_coeffParabolicCocycles f n z.2⟩
+  map_zero' := by
+    apply Subtype.ext; funext g
+    change pushForm f n ((0 : Γ → ↥(BinaryForm R n)) g) = 0
+    rw [Pi.zero_apply, pushForm_zero]
+  map_add' z w := by
+    apply Subtype.ext; funext g
+    change pushForm f n (z.1 g + w.1 g) = pushForm f n (z.1 g) + pushForm f n (w.1 g)
+    rw [pushForm_add]
+
+@[scoped simp] theorem pushPar_apply_coe (z : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp
+  Γ.subtype))) (g : Γ) :
+    (((pushPar f n z).1 g : ↥(BinaryForm R' n)) : MvPolynomial (Fin 2) R') = pushCoeff f (z.1 g) :=
+      rfl
+
+theorem pushPar_apply_val (z : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype)))
+    (g : Γ) :
+    (pushPar f n z).1 g = pushForm f n (z.1 g) := rfl
+
+theorem mk_eq_mk_iff {S : Type*} [CommRing S]
+    (a b : ↥(coeffParabolicCocycles ((binaryFormRepSL S n).comp Γ.subtype))) :
+    coeffH1parMk _ a = coeffH1parMk _ b ↔
+      ((a - b : ↥(coeffParabolicCocycles ((binaryFormRepSL S n).comp Γ.subtype))).1
+        ∈ coeffCoboundaries ((binaryFormRepSL S n).comp Γ.subtype)) := by
+  rw [← sub_eq_zero, ← map_sub, coeffH1parMk_eq_zero_iff]
+
+theorem pushPar_sub (a b : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))) :
+    pushPar f n (a - b) = pushPar f n a - pushPar f n b :=
+  map_sub (pushPar f n) a b
+
+theorem mk_pushPar_congr {a b : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))}
+    (h : coeffH1parMk _ a = coeffH1parMk _ b) :
+    coeffH1parMk _ (pushPar f n a) = coeffH1parMk _ (pushPar f n b) := by
+  rw [mk_eq_mk_iff] at h ⊢
+  rw [← pushPar_sub]
+  exact pushForm_comp_mem_coeffCoboundaries f n h
+
+def pushH1par :
+    coeffH1par ((binaryFormRepSL R n).comp Γ.subtype) →+
+      coeffH1par ((binaryFormRepSL R' n).comp Γ.subtype) where
+  toFun x := coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) x))
+  map_zero' := by
+    have h0 : coeffH1parMk _ (Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp
+      Γ.subtype)) 0)
+        = coeffH1parMk _ (0 : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))) :=
+          by
+      rw [Function.surjInv_eq (coeffH1parMk_surjective _), map_zero]
+    change coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) 0)) = 0
+    rw [mk_pushPar_congr f n h0, map_zero, map_zero]
+  map_add' x y := by
+    have hxy : coeffH1parMk _ (Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp
+      Γ.subtype)) (x + y))
+        = coeffH1parMk _ (Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp
+          Γ.subtype)) x
+            + Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp Γ.subtype)) y)
+              := by
+      rw [map_add, Function.surjInv_eq (coeffH1parMk_surjective _), Function.surjInv_eq
+        (coeffH1parMk_surjective _),
+        Function.surjInv_eq (coeffH1parMk_surjective _)]
+    change coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) (x + y))) = _
+    rw [mk_pushPar_congr f n hxy, map_add, map_add]
+
+theorem pushH1par_mk (z : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))) :
+    pushH1par f n (coeffH1parMk _ z) = coeffH1parMk _ (pushPar f n z) := by
+  change coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) (coeffH1parMk _
+    z))) = _
+  apply mk_pushPar_congr
+  exact Function.surjInv_eq (coeffH1parMk_surjective _) _
+
+end Cocycles
+
+end HeckeEis.ConjAux
+end
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff IsParabolicCocycle \
+  coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff"
+namespace ConjAux
+p2m_open "HeckeEis"
+
+open MvPolynomial
+open scoped MatrixGroups
+
+theorem pushCoeff_ringHom_eq_map {R R' : Type*} [CommRing R] [CommRing R'] (φ : R →+* R')
+    (P : MvPolynomial (Fin 2) R) :
+    pushCoeff φ.toAddMonoidHom P = MvPolynomial.map φ P := by
+  ext d
+  rw [coeff_pushCoeff, coeff_map]
+  rfl
+
+end HeckeEis.ConjAux
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff IsParabolicCocycle \
+  coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff"
+namespace ConjAux
+p2m_open "HeckeEis"
+
+open MvPolynomial
+open scoped MatrixGroups ComplexConjugate
+
+abbrev cj : ℂ →+ ℂ := (starRingEnd ℂ).toAddMonoidHom
+
+@[scoped simp] theorem cj_apply (c : ℂ) : cj c = (starRingEnd ℂ) c := rfl
+
+theorem pushCoeff_cj_smul (c : ℂ) (P : MvPolynomial (Fin 2) ℂ) :
+    pushCoeff cj (c • P) = (starRingEnd ℂ) c • pushCoeff cj P := by
+  ext d
+  rw [coeff_pushCoeff, coeff_smul, coeff_smul, coeff_pushCoeff, cj_apply, cj_apply, smul_eq_mul,
+    smul_eq_mul, map_mul]
+
+theorem pushCoeff_cj_cj (P : MvPolynomial (Fin 2) ℂ) : pushCoeff cj (pushCoeff cj P) = P := by
+  ext d
+  rw [coeff_pushCoeff, coeff_pushCoeff, cj_apply, cj_apply, Complex.conj_conj]
+
+variable {Γ : Subgroup SL(2, ℤ)} (n : ℕ)
+
+theorem pushPar_cj_smul (c : ℂ)
+    (z : ↥(coeffParabolicCocycles ((binaryFormRepSL ℂ n).comp Γ.subtype))) :
+    pushPar cj n (c • z) = (starRingEnd ℂ) c • pushPar cj n z := by
+  apply Subtype.ext; funext g
+  apply Subtype.ext
+  change pushCoeff cj (((c • z).1 g : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ)
+    = ((((starRingEnd ℂ) c • pushPar cj n z).1 g : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ)
+  have h1 : (((c • z).1 g : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) = c • ((z.1 g :
+    ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) :=
+    rfl
+  have h2 : ((((starRingEnd ℂ) c • pushPar cj n z).1 g : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2)
+    ℂ)
+      = (starRingEnd ℂ) c • (((pushPar cj n z).1 g : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) :=
+        rfl
+  rw [h1, h2, pushPar_apply_coe, pushCoeff_cj_smul]
+
+theorem pushPar_cj_cj (z : ↥(coeffParabolicCocycles ((binaryFormRepSL ℂ n).comp Γ.subtype))) :
+    pushPar cj n (pushPar cj n z) = z := by
+  apply Subtype.ext; funext g
+  apply Subtype.ext
+  rw [pushPar_apply_coe]
+  show pushCoeff cj (((pushPar cj n z).1 g : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) = _
+  rw [pushPar_apply_coe, pushCoeff_cj_cj]
+
+theorem pushH1par_cj_smul (c : ℂ) (x : coeffH1par ((binaryFormRepSL ℂ n).comp Γ.subtype)) :
+    pushH1par cj n (c • x) = (starRingEnd ℂ) c • pushH1par cj n x := by
+  obtain ⟨z, rfl⟩ := coeffH1parMk_surjective _ x
+  rw [← map_smul (coeffH1parMk ((binaryFormRepSL ℂ n).comp Γ.subtype)) c z, pushH1par_mk,
+    pushH1par_mk, pushPar_cj_smul,
+    map_smul (coeffH1parMk ((binaryFormRepSL ℂ n).comp Γ.subtype))]
+
+theorem pushH1par_cj_cj (x : coeffH1par ((binaryFormRepSL ℂ n).comp Γ.subtype)) :
+    pushH1par cj n (pushH1par cj n x) = x := by
+  obtain ⟨z, rfl⟩ := coeffH1parMk_surjective _ x
+  rw [pushH1par_mk, pushH1par_mk, pushPar_cj_cj]
+
+def conjH1par :
+    coeffH1par ((binaryFormRepSL ℂ n).comp Γ.subtype) →ₛₗ[starRingEnd ℂ]
+      coeffH1par ((binaryFormRepSL ℂ n).comp Γ.subtype) where
+  toFun := pushH1par cj n
+  map_add' x y := map_add _ x y
+  map_smul' c x := pushH1par_cj_smul n c x
+
+@[scoped simp] theorem conjH1par_apply (x : coeffH1par ((binaryFormRepSL ℂ n).comp Γ.subtype)) :
+    conjH1par n x = pushH1par cj n x := rfl
+
+theorem pushCoeff_cj_eq_map (P : MvPolynomial (Fin 2) ℂ) :
+    pushCoeff cj P = MvPolynomial.map (starRingEnd ℂ) P := by
+  ext d
+  rw [coeff_pushCoeff, coeff_map]
+  rfl
+
+end HeckeEis.ConjAux
+end
+
+open scoped MatrixGroups in
+theorem solution (n : ℕ) (Γ : Subgroup SL(2, ℤ)) :
+    ∃ Φ : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype) →ₛₗ[starRingEnd ℂ]
+      HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype),
+      (∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype)),
+        ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype)),
+          (∀ g : Γ, ((w : Γ → ↥(HeckeEis.BinaryForm ℂ n)) g : MvPolynomial (Fin 2) ℂ)
+              = MvPolynomial.map (starRingEnd ℂ)
+                  (((z : Γ → ↥(HeckeEis.BinaryForm ℂ n)) g : MvPolynomial (Fin 2) ℂ))) ∧
+          Φ (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w) ∧
+      ∀ x : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype), Φ (Φ x) = x := by
+  refine ⟨HeckeEis.ConjAux.conjH1par n, fun z => ⟨HeckeEis.ConjAux.pushPar HeckeEis.ConjAux.cj n z,
+    ?_, ?_⟩, fun x => ?_⟩
+  · intro g
+    rw [HeckeEis.ConjAux.pushPar_apply_coe, HeckeEis.ConjAux.pushCoeff_cj_eq_map]
+  · rw [HeckeEis.ConjAux.conjH1par_apply, HeckeEis.ConjAux.pushH1par_mk]
+  · rw [HeckeEis.ConjAux.conjH1par_apply, HeckeEis.ConjAux.conjH1par_apply,
+      HeckeEis.ConjAux.pushH1par_cj_cj]
+
+end S_HeckeEis_exists_coeffH1par_semilinearMap_starRingEnd
+end P2MW
+export P2MW.S_HeckeEis_exists_coeffH1par_semilinearMap_starRingEnd (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.exists_coeffH1par_semilinearMap_starRingEnd (n : ℕ) (Γ : Subgroup SL(2, ℤ)) :
+    ∃ Φ : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype) →ₛₗ[starRingEnd ℂ]
+      HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype),
+      (∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype)),
+        ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype)),
+          (∀ g : Γ, ((w : Γ → ↥(HeckeEis.BinaryForm ℂ n)) g : MvPolynomial (Fin 2) ℂ)
+              = MvPolynomial.map (starRingEnd ℂ)
+                  (((z : Γ → ↥(HeckeEis.BinaryForm ℂ n)) g : MvPolynomial (Fin 2) ℂ))) ∧
+          Φ (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w) ∧
+      ∀ x : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype), Φ (Φ x) = x :=
+  solution n Γ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_eichlerShimura_coeffH1par_binaryFormRepSL.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_eichlerShimura_coeffH1par_binaryFormRepSL.lean
new file mode 100644
index 0000000000..d5fce2ec4e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_eichlerShimura_coeffH1par_binaryFormRepSL.lean
@@ -0,0 +1,148 @@
+/-
+Based on Prove2Me node HeckeEis.exists_eichlerShimura_coeffH1par_binaryFormRepSL
+(4c20e75e-94cc-59a9-a6e0-3792a09ffb66) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6320d608-d176-58be-9c6f-8318260b0dc4
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperatorForms
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_eichlerShimura_coeffH1par_binaryFormRepSL_forall_prime
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Hecke-equivariant Eichler–Shimura decomposition of parabolic cohomology
+
+Theorem statement: `HeckeEis.exists_eichlerShimura_coeffH1par_binaryFormRepSL`
+(`4c20e75e-94cc-59a9-a6e0-3792a09ffb66`), by Claude, 2026-09-05.
+
+Proof: submission `6320d608-d176-58be-9c6f-8318260b0dc4`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $N \neq 0$ and a natural number $n$, and let $\rho$ be the representation of
+$\Gamma_0(N)$ obtained by restricting, along the inclusion of $\Gamma_0(N)$ into
+$\mathrm{SL}(2,\mathbb{Z})$, the action
+[`HeckeEis.binaryFormRepSL`](def/HeckeEis_BinaryFormRep.html#L61) of $\mathrm{SL}(2,\mathbb{Z})$ on
+the space [`HeckeEis.BinaryForm ℂ n`](def/HeckeEis_BinaryFormRep.html#L25) of degree-$n$ homogeneous
+polynomials in two variables over $\mathbb{C}$, a matrix $M$ acting by the substitution $X_j \mapsto
+\sum_i M_{ij} X_i$. Write $H^1_{\mathrm{par}}(\rho) =$ [`HeckeEis.coeffH1par
+ρ`](def/Gamma0CoeffCohomology.html#L100), the quotient of the module of parabolic cocycles —
+functions $z \colon \Gamma_0(N) \to$ `BinaryForm ℂ n` with $z(gh) = z(g) + \rho(g)z(h)$ and with
+$z(\gamma) \in \mathrm{range}(\rho(\gamma) - 1)$ whenever $\mathrm{tr}(\gamma)^2 = 4$ — by the
+submodule of those parabolic cocycles that are coboundaries; let `coeffH1parMk` denote the quotient
+map. The assertion is that there exist a $\mathbb{C}$-linear map $\mathrm{ES}$ and a
+conjugate-linear map $\overline{\mathrm{ES}}$ (semilinear for `starRingEnd ℂ`) from the space of
+cusp forms of weight $(n : \mathbb{Z}) + 2$ on $\Gamma_0(N)$ to $H^1_{\mathrm{par}}(\rho)$ such
+that: both are injective; their ranges are complementary submodules of $H^1_{\mathrm{par}}(\rho)$
+(`IsCompl`); and for every prime $\ell$ with $\ell \nmid N$ and every $\mathbb{C}$-linear
+endomorphism $T$ of $H^1_{\mathrm{par}}(\rho)$, if $T$ is induced by the cochain-level Hecke
+operator in the sense that for every parabolic cocycle $z$ there is a parabolic cocycle $w$ whose
+underlying function $\Gamma_0(N) \to$ `BinaryForm ℂ n` equals [`HeckeEis.coeffHeckeFun N ℓ ρ
+(HeckeEis.binaryFormAlphaAdj ℂ n ℓ) z`](def/Gamma0CoeffCohomology.html#L129) (the transfer sum over
+$\Gamma_0(N)/$`heckeUpper N ℓ` with coefficient map given by the substitution $F(X_0, X_1) \mapsto
+F(\ell X_0, X_1)$) and with $T(\text{class of } z) = \text{class of } w$, then $T(\mathrm{ES}\,f) =
+\mathrm{ES}(T_\ell f)$ and $T(\overline{\mathrm{ES}}\,f) = \overline{\mathrm{ES}}(T_\ell f)$ for all
+cusp forms $f$, where $T_\ell$ is
+[`CuspForm.heckeTLin`](def/ModularForm_HeckeOperatorForms.html#L69) in weight $(n:\mathbb{Z})+2$.
+
+This is the Eichler–Shimura isomorphism in weight $n+2$, packaged as an explicit Hecke-equivariant
+direct-sum decomposition $H^1_{\mathrm{par}}(\Gamma_0(N), \mathrm{Sym}^n\mathbb{C}^2) =
+\mathrm{ES}(S_{n+2}) \oplus \overline{\mathrm{ES}}(S_{n+2})$ rather than as a dimension or trace
+identity. It is used to transport eigensystems for the Hecke action on parabolic cohomology back to
+cusp forms, as in
+[`HeckeEis.exists_modularForm_heckeTLin_eq_smul_of_isEigensystemH1`]
+(thm.html#HeckeEis.exists_modularForm_heckeTLin_eq_smul_of_isEigensystemH1).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_exists_eichlerShimura_coeffH1par_binaryFormRepSL.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_exists_eichlerShimura_coeffH1par_binaryFormRepSL
+
+open scoped MatrixGroups
+
+theorem solution (N : ℕ) [NeZero N] (n : ℕ) :
+    ∃ (ES : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2) →ₗ[ℂ]
+          HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+            N).subtype))
+      (ESbar : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2) →ₛₗ[starRingEnd ℂ]
+          HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+            N).subtype)),
+      Function.Injective ES ∧ Function.Injective ESbar ∧
+      IsCompl (LinearMap.range ES) (LinearMap.range ESbar) ∧
+      ∀ (ℓ : ℕ) (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N)
+        (T : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+          N).subtype) →ₗ[ℂ] HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+          (CongruenceSubgroup.Gamma0 N).subtype)),
+        (∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+          (CongruenceSubgroup.Gamma0 N).subtype)),
+            ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+              (CongruenceSubgroup.Gamma0 N).subtype)),
+              haveI : NeZero ℓ := ⟨hℓ.ne_zero⟩
+              (w : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n))
+                  = HeckeEis.coeffHeckeFun N ℓ ((HeckeEis.binaryFormRepSL ℂ n).comp
+                    (CongruenceSubgroup.Gamma0 N).subtype) (HeckeEis.binaryFormAlphaAdj ℂ n ℓ) z ∧
+                T (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w) →
+        (∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2),
+            T (ES f) = ES (CuspForm.heckeTLin ((n : ℤ) + 2) hℓ hℓN f)) ∧
+        (∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2),
+            T (ESbar f) = ESbar (CuspForm.heckeTLin ((n : ℤ) + 2) hℓ hℓN f)) := by
+  obtain ⟨ES, ESbar, h₁, h₂, h₃, h₄, -⟩ :=
+    HeckeEis.exists_eichlerShimura_coeffH1par_binaryFormRepSL_forall_prime N n
+  exact ⟨ES, ESbar, h₁, h₂, h₃, h₄⟩
+
+end S_HeckeEis_exists_eichlerShimura_coeffH1par_binaryFormRepSL
+end P2MW
+export P2MW.S_HeckeEis_exists_eichlerShimura_coeffH1par_binaryFormRepSL (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.exists_eichlerShimura_coeffH1par_binaryFormRepSL (N : ℕ) [NeZero N] (n : ℕ) :
+    ∃ (ES : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2) →ₗ[ℂ]
+          HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+            N).subtype))
+      (ESbar : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2) →ₛₗ[starRingEnd ℂ]
+          HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+            N).subtype)),
+      Function.Injective ES ∧ Function.Injective ESbar ∧
+      IsCompl (LinearMap.range ES) (LinearMap.range ESbar) ∧
+      ∀ (ℓ : ℕ) (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N)
+        (T : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+          N).subtype) →ₗ[ℂ] HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+          (CongruenceSubgroup.Gamma0 N).subtype)),
+        (∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+          (CongruenceSubgroup.Gamma0 N).subtype)),
+            ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+              (CongruenceSubgroup.Gamma0 N).subtype)),
+              haveI : NeZero ℓ := ⟨hℓ.ne_zero⟩
+              (w : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n))
+                  = HeckeEis.coeffHeckeFun N ℓ ((HeckeEis.binaryFormRepSL ℂ n).comp
+                    (CongruenceSubgroup.Gamma0 N).subtype) (HeckeEis.binaryFormAlphaAdj ℂ n ℓ) z ∧
+                T (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w) →
+        (∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2),
+            T (ES f) = ES (CuspForm.heckeTLin ((n : ℤ) + 2) hℓ hℓN f)) ∧
+        (∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2),
+            T (ESbar f) = ESbar (CuspForm.heckeTLin ((n : ℤ) + 2) hℓ hℓN f)) :=
+  solution N n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_eichlerShimura_coeffH1par_binaryFormRepSL_forall_prime.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_eichlerShimura_coeffH1par_binaryFormRepSL_forall_prime.lean
new file mode 100644
index 0000000000..f9f12cf55d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_eichlerShimura_coeffH1par_binaryFormRepSL_forall_prime.lean
@@ -0,0 +1,240 @@
+/-
+Based on Prove2Me node HeckeEis.exists_eichlerShimura_coeffH1par_binaryFormRepSL_forall_prime
+(fd78cd2e-b041-5f16-998b-018ae96c81f7) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ff13b70e-a956-58e1-8df8-8f38f0308172
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperatorForms
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_coeffH1par_map_heckeT_comm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_eichlerShimuraMap_heckeTLin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_eichlerShimuraMap_heckeULin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_eichlerShimuraMap_injective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_existsEichlerShimuraMapLinear
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_coeffH1par_semilinearMap_starRingEnd
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_isCompl_range_eichlerShimuraMap_range_conj
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Hecke-equivariant Eichler–Shimura decomposition of parabolic cohomology
+
+Theorem statement: `HeckeEis.exists_eichlerShimura_coeffH1par_binaryFormRepSL_forall_prime`
+(`fd78cd2e-b041-5f16-998b-018ae96c81f7`), by Claude, 2026-09-05.
+
+Proof: submission `ff13b70e-a956-58e1-8df8-8f38f0308172`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N \ge 1$ and $n \ge 0$ be natural numbers, and let $\rho$ be the representation of
+$\Gamma_0(N)$ on the space $\mathrm{BinaryForm}\,\mathbb{C}\,n$ of homogeneous degree-$n$
+polynomials in $\mathbb{C}[X_0,X_1]$ obtained by restricting [`HeckeEis.binaryFormRepSL ℂ
+n`](def/HeckeEis_BinaryFormRep.html#L61) along the inclusion of $\Gamma_0(N)$ into
+$\mathrm{SL}_2(\mathbb{Z})$, where $g$ acts by the substitution $X_j \mapsto \sum_i g_{ij} X_i$.
+Write $H^1_{\mathrm{par}}(\rho)$ for [`HeckeEis.coeffH1par ρ`](def/Gamma0CoeffCohomology.html#L100),
+the quotient of the submodule of functions $z \colon \Gamma_0(N) \to
+\mathrm{BinaryForm}\,\mathbb{C}\,n$ satisfying the cocycle identity $z(gh) = z(g) + \rho(g)z(h)$ and
+the parabolicity condition $z(\gamma) \in \mathrm{range}(\rho(\gamma) - 1)$ for every $\gamma$ with
+$\mathrm{tr}(\gamma)^2 = 4$, by the coboundaries lying in it;
+[`HeckeEis.coeffH1parMk`](def/Gamma0CoeffCohomology.html#L111) denotes the quotient map. The theorem
+asserts the existence of a $\mathbb{C}$-linear map $\mathrm{ES}$ and a map $\overline{\mathrm{ES}}$
+semilinear for complex conjugation, both from $S_{n+2}(\Gamma_0(N))$, the cusp forms of weight
+$(n:\mathbb{Z})+2$ for $\Gamma_0(N)$, to $H^1_{\mathrm{par}}(\rho)$, such that: both are injective;
+their ranges are complementary submodules of $H^1_{\mathrm{par}}(\rho)$; and, for every prime $\ell$
+and every $\mathbb{C}$-linear endomorphism $T$ of $H^1_{\mathrm{par}}(\rho)$ which is induced at
+cocycle level by [`HeckeEis.coeffHeckeFun N ℓ ρ (HeckeEis.binaryFormAlphaAdj ℂ n
+ℓ)`](def/Gamma0CoeffCohomology.html#L129) — that is, for each parabolic cocycle $z$ there is a
+parabolic cocycle $w$ whose underlying function is the transfer-type sum $g \mapsto \sum_{q \in
+\Gamma_0(N)/\mathrm{heckeUpper}\,N\,\ell} \rho((g \cdot q)^{\mathrm{out}})\bigl(F \mapsto F(\ell
+X_0, X_1)\bigr)\bigl(z(\mathrm{heckeConj}\,N\,\ell\,(\mathrm{transferAux}\,\cdots))\bigr)$ applied
+to $z$, with $T[z] = [w]$ — one has $T \circ \mathrm{ES} = \mathrm{ES} \circ \mathrm{heckeTLin}$ and
+$T \circ \overline{\mathrm{ES}} = \overline{\mathrm{ES}} \circ \mathrm{heckeTLin}$ when $\ell \nmid
+N$, and the same two identities with
+[`CuspForm.heckeULin`](def/ModularForm_HeckeOperatorForms.html#L83) in place of
+[`CuspForm.heckeTLin`](def/ModularForm_HeckeOperatorForms.html#L69) when $\ell \mid N$, where on
+cusp forms $\mathrm{heckeULin}$ is $f \mapsto \sum_{j<\ell} f \mid_{k}
+\mathrm{heckeMatrix}\,\ell\,j$ and $\mathrm{heckeTLin}$ adds to this the term $f \mid_{k}
+\mathrm{heckeDiagMatrix}\,\ell$.
+
+This is the Eichler–Shimura decomposition in weight $n+2$, presented as an explicit pair of
+injections of $S_{n+2}(\Gamma_0(N))$ into parabolic group cohomology with complementary images,
+compatible with the Hecke action at every prime: $T_\ell$ for $\ell \nmid N$ and $U_\ell$ for $\ell
+\mid N$. It is used to transport the Hecke action on cusp forms to a lattice-theoretic setting, and
+is cited in the construction of an integral structure on cusp forms of weight at least two.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_exists_eichlerShimura_coeffH1par_binaryFormRepSL_forall_prime.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_exists_eichlerShimura_coeffH1par_binaryFormRepSL_forall_prime
+
+
+open scoped MatrixGroups
+
+theorem solution (N : ℕ) [NeZero N] (n : ℕ) :
+    ∃ (ES : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2) →ₗ[ℂ]
+          HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+            N).subtype))
+      (ESbar : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2) →ₛₗ[starRingEnd ℂ]
+          HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+            N).subtype)),
+      Function.Injective ES ∧ Function.Injective ESbar ∧
+      IsCompl (LinearMap.range ES) (LinearMap.range ESbar) ∧
+      (∀ (ℓ : ℕ) (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N)
+        (T : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+          N).subtype) →ₗ[ℂ] HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+          (CongruenceSubgroup.Gamma0 N).subtype)),
+        (∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+          (CongruenceSubgroup.Gamma0 N).subtype)),
+            ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+              (CongruenceSubgroup.Gamma0 N).subtype)),
+              haveI : NeZero ℓ := ⟨hℓ.ne_zero⟩
+              (w : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n))
+                  = HeckeEis.coeffHeckeFun N ℓ ((HeckeEis.binaryFormRepSL ℂ n).comp
+                    (CongruenceSubgroup.Gamma0 N).subtype) (HeckeEis.binaryFormAlphaAdj ℂ n ℓ) z ∧
+                T (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w) →
+        (∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2),
+            T (ES f) = ES (CuspForm.heckeTLin ((n : ℤ) + 2) hℓ hℓN f)) ∧
+        (∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2),
+            T (ESbar f) = ESbar (CuspForm.heckeTLin ((n : ℤ) + 2) hℓ hℓN f))) ∧
+      (∀ (ℓ : ℕ) (hℓ : ℓ.Prime) (hℓN : ℓ ∣ N)
+        (T : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+          N).subtype) →ₗ[ℂ] HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+          (CongruenceSubgroup.Gamma0 N).subtype)),
+        (∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+          (CongruenceSubgroup.Gamma0 N).subtype)),
+            ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+              (CongruenceSubgroup.Gamma0 N).subtype)),
+              haveI : NeZero ℓ := ⟨hℓ.ne_zero⟩
+              (w : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n))
+                  = HeckeEis.coeffHeckeFun N ℓ ((HeckeEis.binaryFormRepSL ℂ n).comp
+                    (CongruenceSubgroup.Gamma0 N).subtype) (HeckeEis.binaryFormAlphaAdj ℂ n ℓ) z ∧
+                T (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w) →
+        (∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2),
+            T (ES f) = ES (CuspForm.heckeULin ((n : ℤ) + 2) hℓN f)) ∧
+        (∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2),
+            T (ESbar f) = ESbar (CuspForm.heckeULin ((n : ℤ) + 2) hℓN f))) := by
+  classical
+  obtain ⟨ES, hES⟩ := HeckeEis.existsEichlerShimuraMapLinear n N
+  obtain ⟨Φ, hΦ, hΦΦ⟩ :=
+    HeckeEis.exists_coeffH1par_semilinearMap_starRingEnd n (CongruenceSubgroup.Gamma0 N)
+  let ESbar : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2) →ₛₗ[starRingEnd ℂ]
+    HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype)
+    :=
+    Φ.comp ES
+  have hESbar : ∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2), ESbar f = Φ (ES f) :=
+    fun f => rfl
+  have hinj : Function.Injective ES := by
+    intro a b h
+    have h' : HeckeEis.eichlerShimuraMap n N a = HeckeEis.eichlerShimuraMap n N b :=
+      by rw [← hES, ← hES, h]
+    exact HeckeEis.eichlerShimuraMap_injective N n h'
+  have hΦinj : Function.Injective Φ := fun x y h => by rw [← hΦΦ x, ← hΦΦ y, h]
+  have hcomm : ∀ (ℓ : ℕ) [NeZero ℓ]
+      (T : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+        N).subtype) →ₗ[ℂ] HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+        (CongruenceSubgroup.Gamma0 N).subtype)),
+      (∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+        (CongruenceSubgroup.Gamma0 N).subtype)),
+        ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+          (CongruenceSubgroup.Gamma0 N).subtype)),
+          (w : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n))
+              = HeckeEis.coeffHeckeFun N ℓ ((HeckeEis.binaryFormRepSL ℂ n).comp
+                (CongruenceSubgroup.Gamma0 N).subtype) (HeckeEis.binaryFormAlphaAdj ℂ n ℓ) z ∧
+            T (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w) →
+      ∀ x, T (Φ x) = Φ (T x) := by
+    intro ℓ _ T hT x
+    exact HeckeEis.coeffH1par_map_heckeT_comm (starRingEnd ℂ) n N ℓ Φ.toAddMonoidHom (fun z => hΦ z)
+      T hT T hT x
+  refine ⟨ES, ESbar, hinj, ?_, ?_, ?_, ?_⟩
+  · intro a b h
+    exact hinj (hΦinj h)
+  · exact HeckeEis.isCompl_range_eichlerShimuraMap_range_conj N n ES hES Φ.toAddMonoidHom (fun z =>
+      hΦ z) ESbar hESbar
+  · intro ℓ hℓ hℓN T hT
+    have : NeZero ℓ := ⟨hℓ.ne_zero⟩
+    refine ⟨fun f => ?_, fun f => ?_⟩
+    · rw [hES, hES]
+      exact HeckeEis.eichlerShimuraMap_heckeTLin N n hℓ hℓN T hT f
+    · rw [hESbar, hESbar, hcomm ℓ T hT, hES, hES, HeckeEis.eichlerShimuraMap_heckeTLin N n hℓ hℓN T
+        hT f]
+  · intro ℓ hℓ hℓN T hT
+    have : NeZero ℓ := ⟨hℓ.ne_zero⟩
+    refine ⟨fun f => ?_, fun f => ?_⟩
+    · rw [hES, hES]
+      exact HeckeEis.eichlerShimuraMap_heckeULin N n hℓ hℓN T hT f
+    · rw [hESbar, hESbar, hcomm ℓ T hT, hES, hES, HeckeEis.eichlerShimuraMap_heckeULin N n hℓ hℓN T
+        hT f]
+
+end S_HeckeEis_exists_eichlerShimura_coeffH1par_binaryFormRepSL_forall_prime
+end P2MW
+export P2MW.S_HeckeEis_exists_eichlerShimura_coeffH1par_binaryFormRepSL_forall_prime (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.exists_eichlerShimura_coeffH1par_binaryFormRepSL_forall_prime (N : ℕ) [NeZero N]
+    (n : ℕ) :
+    ∃ (ES : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2) →ₗ[ℂ]
+          HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+            N).subtype))
+      (ESbar : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2) →ₛₗ[starRingEnd ℂ]
+          HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+            N).subtype)),
+      Function.Injective ES ∧ Function.Injective ESbar ∧
+      IsCompl (LinearMap.range ES) (LinearMap.range ESbar) ∧
+      (∀ (ℓ : ℕ) (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N)
+        (T : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+          N).subtype) →ₗ[ℂ] HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+          (CongruenceSubgroup.Gamma0 N).subtype)),
+        (∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+          (CongruenceSubgroup.Gamma0 N).subtype)),
+            ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+              (CongruenceSubgroup.Gamma0 N).subtype)),
+              haveI : NeZero ℓ := ⟨hℓ.ne_zero⟩
+              (w : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n))
+                  = HeckeEis.coeffHeckeFun N ℓ ((HeckeEis.binaryFormRepSL ℂ n).comp
+                    (CongruenceSubgroup.Gamma0 N).subtype) (HeckeEis.binaryFormAlphaAdj ℂ n ℓ) z ∧
+                T (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w) →
+        (∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2),
+            T (ES f) = ES (CuspForm.heckeTLin ((n : ℤ) + 2) hℓ hℓN f)) ∧
+        (∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2),
+            T (ESbar f) = ESbar (CuspForm.heckeTLin ((n : ℤ) + 2) hℓ hℓN f))) ∧
+      (∀ (ℓ : ℕ) (hℓ : ℓ.Prime) (hℓN : ℓ ∣ N)
+        (T : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+          N).subtype) →ₗ[ℂ] HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+          (CongruenceSubgroup.Gamma0 N).subtype)),
+        (∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+          (CongruenceSubgroup.Gamma0 N).subtype)),
+            ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+              (CongruenceSubgroup.Gamma0 N).subtype)),
+              haveI : NeZero ℓ := ⟨hℓ.ne_zero⟩
+              (w : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n))
+                  = HeckeEis.coeffHeckeFun N ℓ ((HeckeEis.binaryFormRepSL ℂ n).comp
+                    (CongruenceSubgroup.Gamma0 N).subtype) (HeckeEis.binaryFormAlphaAdj ℂ n ℓ) z ∧
+                T (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w) →
+        (∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2),
+            T (ES f) = ES (CuspForm.heckeULin ((n : ℤ) + 2) hℓN f)) ∧
+        (∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2),
+            T (ESbar f) = ESbar (CuspForm.heckeULin ((n : ℤ) + 2) hℓN f))) :=
+  solution N n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_eichlerShimura_heckeEquivariant.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_eichlerShimura_heckeEquivariant.lean
new file mode 100644
index 0000000000..15cff57a37
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_eichlerShimura_heckeEquivariant.lean
@@ -0,0 +1,80 @@
+/-
+Copyright (c) 2026 David Loeffler. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: David Loeffler
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_eichlerShimura_coeffH1par_binaryFormRepSL_forall_prime
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_coeffH1par_linearMap_coeffHeckeFun
+public import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_binaryFormAlphaAdj_comp_binaryFormRepSL_heckeConj
+
+/-!
+# Eichler–Shimura decomposition with Hecke operators at every prime
+
+For every nonzero level and weight at least two, the holomorphic and antiholomorphic
+Eichler–Shimura maps are injective and have complementary images in parabolic cohomology.
+The cohomological Hecke operators are supplied, together with their action on arbitrary
+parabolic cocycle representatives. Both maps intertwine these operators with `T_ℓ` away
+from the level and `U_ℓ` at primes dividing the level.
+
+This combines the FLT decomposition theorem with general Hecke descent and the intertwining
+identity for binary-form coefficients; no descent hypothesis is required from the caller.
+-/
+
+public section publicSection
+
+open scoped MatrixGroups
+open CongruenceSubgroup
+
+namespace HeckeEis
+
+/-- The Eichler–Shimura decomposition, with descended Hecke operators and compatibility
+at every prime, including primes dividing the level. -/
+theorem exists_eichlerShimura_heckeEquivariant (N : ℕ) [NeZero N] (n : ℕ) :
+    ∃ (ES : CuspForm (Gamma0 N) ((n : ℤ) + 2) →ₗ[ℂ]
+          coeffH1par ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype))
+      (ESbar : CuspForm (Gamma0 N) ((n : ℤ) + 2) →ₛₗ[starRingEnd ℂ]
+          coeffH1par ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype))
+      (T : (ℓ : ℕ) → ℓ.Prime →
+        coeffH1par ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) →ₗ[ℂ]
+          coeffH1par ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype)),
+      Function.Injective ES ∧ Function.Injective ESbar ∧
+      IsCompl (LinearMap.range ES) (LinearMap.range ESbar) ∧
+      (∀ (ℓ : ℕ) (hℓ : ℓ.Prime)
+        (z : ↥(coeffParabolicCocycles ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype))),
+        ∃ w : ↥(coeffParabolicCocycles ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype)),
+          letI : NeZero ℓ := ⟨hℓ.ne_zero⟩
+          (w : Gamma0 N → ↥(BinaryForm ℂ n)) =
+              coeffHeckeFun N ℓ ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype)
+                (binaryFormAlphaAdj ℂ n ℓ) z ∧
+            T ℓ hℓ (coeffH1parMk _ z) = coeffH1parMk _ w) ∧
+      (∀ (ℓ : ℕ) (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N),
+        (∀ f : CuspForm (Gamma0 N) ((n : ℤ) + 2),
+          T ℓ hℓ (ES f) = ES (CuspForm.heckeTLin ((n : ℤ) + 2) hℓ hℓN f)) ∧
+        (∀ f : CuspForm (Gamma0 N) ((n : ℤ) + 2),
+          T ℓ hℓ (ESbar f) = ESbar (CuspForm.heckeTLin ((n : ℤ) + 2) hℓ hℓN f))) ∧
+      (∀ (ℓ : ℕ) (hℓ : ℓ.Prime) (hℓN : ℓ ∣ N),
+        (∀ f : CuspForm (Gamma0 N) ((n : ℤ) + 2),
+          T ℓ hℓ (ES f) = ES (CuspForm.heckeULin ((n : ℤ) + 2) hℓN f)) ∧
+        (∀ f : CuspForm (Gamma0 N) ((n : ℤ) + 2),
+          T ℓ hℓ (ESbar f) = ESbar (CuspForm.heckeULin ((n : ℤ) + 2) hℓN f))) := by
+  classical
+  obtain ⟨ES, ESbar, hinj, hinjbar, hcompl, hgood, hbad⟩ :=
+    exists_eichlerShimura_coeffH1par_binaryFormRepSL_forall_prime N n
+  have descent := fun (ℓ : ℕ) (hℓ : ℓ.Prime) =>
+    letI : NeZero ℓ := ⟨hℓ.ne_zero⟩
+    exists_coeffH1par_linearMap_coeffHeckeFun N ℓ
+      ((binaryFormRepSL ℂ n).comp (Gamma0 N).subtype) (binaryFormAlphaAdj ℂ n ℓ)
+      (binaryFormAlphaAdj_comp_binaryFormRepSL_heckeConj ℂ n N ℓ)
+  choose T hT using descent
+  refine ⟨ES, ESbar, T, hinj, hinjbar, hcompl, hT, ?_, ?_⟩
+  · intro ℓ hℓ hℓN
+    exact hgood ℓ hℓ hℓN (T ℓ hℓ) (hT ℓ hℓ)
+  · intro ℓ hℓ hℓN
+    exact hbad ℓ hℓ hℓN (T ℓ hℓ) (hT ℓ hℓ)
+
+end HeckeEis
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_eq_smul_X_pow_of_binaryFormRepSL_T_zpow_eq_self.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_eq_smul_X_pow_of_binaryFormRepSL_T_zpow_eq_self.lean
new file mode 100644
index 0000000000..5d26db1499
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_eq_smul_X_pow_of_binaryFormRepSL_T_zpow_eq_self.lean
@@ -0,0 +1,267 @@
+/-
+Based on Prove2Me node HeckeEis.exists_eq_smul_X_pow_of_binaryFormRepSL_T_zpow_eq_self
+(37db5548-5371-5fa4-8056-cad4294d97e5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission cfdb125d-c7b0-513f-88ce-8ba7d6385689
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Forms fixed by T^h are multiples of X₀ⁿ
+
+Theorem statement: `HeckeEis.exists_eq_smul_X_pow_of_binaryFormRepSL_T_zpow_eq_self`
+(`37db5548-5371-5fa4-8056-cad4294d97e5`), by Claude, 2026-09-05.
+
+Proof: submission `cfdb125d-c7b0-513f-88ce-8ba7d6385689`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring which is an integral domain, let $n$ be a natural number, and let $h$
+be an integer whose image in $R$ is nonzero; assume further that for every natural number $j$ with
+$1 \le j \le n$ the image of $j$ in $R$ is nonzero. Let $P$ be an element of [`HeckeEis.BinaryForm R
+n`](def/HeckeEis_BinaryFormRep.html#L25), that is, of the submodule
+`MvPolynomial.homogeneousSubmodule (Fin 2) R n` of polynomials in $R[X_0,X_1]$ homogeneous of degree
+$n$ (the zero polynomial included). Suppose $P$ is fixed by the value at $\mathrm{T}^h$ of the
+representation [`HeckeEis.binaryFormRepSL R n`](def/HeckeEis_BinaryFormRep.html#L61) of
+$\mathrm{SL}_2(\mathbb{Z})$ on that submodule, where $\mathrm{T} =
+\begin{pmatrix}1&1\\0&1\end{pmatrix}$ is `ModularGroup.T` and a matrix $M$ acts by the $R$-algebra
+substitution $X_j \mapsto \sum_i \overline{M_{ij}}\,X_i$; for $M = \mathrm{T}^h$ this is the
+substitution $X_0 \mapsto X_0$, $X_1 \mapsto \overline{h}X_0 + X_1$, so the hypothesis reads $P(X_0,
+hX_0 + X_1) = P(X_0, X_1)$. The conclusion is that there is a scalar $c \in R$ with $P = c \cdot
+X_0^{\,n}$ as polynomials in $R[X_0,X_1]$.
+
+This identifies the fixed subspace of the unipotent element $\mathrm{T}^h$ acting on binary forms of
+degree $n$ — the kernel half of the analysis of $\rho(\mathrm{T}^h) - 1$ on $\mathrm{Sym}^n$ — under
+the numerical hypotheses that $h$ and $1,\dots,n$ are invertible-enough (nonzero) in the domain $R$.
+It is used for the corresponding statement for the lower unipotent matrices,
+[`HeckeEis.exists_eq_smul_X_pow_of_binaryFormRepSL_lowerUnipotent_eq_self`]
+(thm.html#HeckeEis.exists_eq_smul_X_pow_of_binaryFormRepSL_lowerUnipotent_eq_self),
+and in the vanishing result
+[`HeckeEis.coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero`]
+(thm.html#HeckeEis.coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero)
+entering the study of parabolic cohomology with $\mathrm{Sym}^n$ coefficients.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_exists_eq_smul_X_pow_of_binaryFormRepSL_T_zpow_eq_self.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_exists_eq_smul_X_pow_of_binaryFormRepSL_T_zpow_eq_self
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binaryFormRepSL"
+p2m_open "HeckeEis"
+
+open MvPolynomial Polynomial
+open scoped MatrixGroups
+
+namespace UnipotentFixedAux
+
+variable {R : Type*} [CommRing R] {n : ℕ}
+
+private theorem _root_.HeckeEis.UnipotentFixedAux.monomial_eq (n j : ℕ) :
+    (MvPolynomial.monomial (Finsupp.single 0 (n - j) + Finsupp.single 1 j) (1 : R))
+      = MvPolynomial.X 0 ^ (n - j) * MvPolynomial.X 1 ^ j := by
+  rw [MvPolynomial.monomial_eq, MvPolynomial.C_1, one_mul, Finsupp.prod_add_index' (by
+    simp) (by
+      simp [pow_add]),
+    Finsupp.prod_single_index (by simp), Finsupp.prod_single_index (by simp)]
+
+p2m_export "HeckeEis.UnipotentFixedAux" "monomial_eq"
+variable (n) in
+noncomputable def expo (j : ℕ) : Fin 2 →₀ ℕ := Finsupp.single 0 (n - j) + Finsupp.single 1 j
+
+theorem expo_injOn : Set.InjOn (expo n) (Finset.range (n + 1) : Set ℕ) := by
+  intro i _ j _ h
+  have := congrArg (fun d : Fin 2 →₀ ℕ => d 1) h
+  simpa [expo, Finsupp.single_apply] using this
+
+theorem degree_eq_iff (d : Fin 2 →₀ ℕ) :
+    d.degree = n ↔ ∃ j ∈ Finset.range (n + 1), expo n j = d := by
+  rw [Finsupp.degree_eq_sum, Fin.sum_univ_two]
+  constructor
+  · intro h
+    refine ⟨d 1, Finset.mem_range.mpr (by omega), ?_⟩
+    ext i
+    fin_cases i <;> simp [expo] ; omega
+  · rintro ⟨j, hj, rfl⟩
+    rw [Finset.mem_range] at hj
+    simp [expo]
+    omega
+
+theorem eq_sum_range {P : MvPolynomial (Fin 2) R} (hP : P ∈ BinaryForm R n) :
+    P = ∑ j ∈ Finset.range (n + 1), MvPolynomial.monomial (expo n j) (AddMonoidAlgebra.coeff P (expo
+      n j)) := by
+  classical
+  refine MvPolynomial.ext _ _ fun d => ?_
+  rw [MvPolynomial.coeff_sum]
+  simp only [MvPolynomial.coeff_monomial]
+  by_cases hd : d.degree = n
+  · obtain ⟨j, hj, rfl⟩ := (degree_eq_iff d).mp hd
+    rw [Finset.sum_eq_single j (fun i hi hne => ite_eq_right fun h => hne (expo_injOn hi hj h)) (fun
+      h => (h hj).elim),
+      ite_eq_left rfl]
+  · rw [Finset.sum_eq_zero fun i hi => ite_eq_right fun h => hd ((degree_eq_iff d).mpr ⟨i, hi, h⟩)]
+    exact ((MvPolynomial.mem_homogeneousSubmodule n P).mp hP).coeff_eq_zero hd
+
+noncomputable def dehom : MvPolynomial (Fin 2) R →ₐ[R] R[X] := MvPolynomial.aeval ![1, Polynomial.X]
+
+theorem dehom_monomial (j : ℕ) (c : R) :
+    dehom (MvPolynomial.monomial (expo n j) c) = Polynomial.C c * Polynomial.X ^ j := by
+  rw [expo, MvPolynomial.monomial_eq, Finsupp.prod_add_index' (by simp) (by simp [pow_add]),
+    Finsupp.prod_single_index (by simp), Finsupp.prod_single_index (by simp)]
+  simp [dehom, Polynomial.C_mul']
+
+theorem dehom_eq_sum {P : MvPolynomial (Fin 2) R} (hP : P ∈ BinaryForm R n) :
+    dehom P = ∑ j ∈ Finset.range (n + 1), Polynomial.C (AddMonoidAlgebra.coeff P (expo n j)) *
+      Polynomial.X ^ j := by
+  conv_lhs => rw [eq_sum_range hP, map_sum]
+  exact Finset.sum_congr rfl fun j _ => dehom_monomial j _
+
+theorem coeff_dehom {P : MvPolynomial (Fin 2) R} (hP : P ∈ BinaryForm R n) (j : ℕ) :
+    (dehom P).coeff j = if j ∈ Finset.range (n + 1) then AddMonoidAlgebra.coeff P (expo n j) else 0
+      := by
+  rw [dehom_eq_sum hP, Polynomial.finsetSum_coeff]
+  simp only [Polynomial.coeff_C_mul_X_pow]
+  split_ifs with h
+  · rw [Finset.sum_eq_single j (fun i _ hne => ite_eq_right hne.symm) (fun h' => (h' h).elim),
+      ite_eq_left rfl]
+  · exact Finset.sum_eq_zero fun i hi => ite_eq_right fun h' => h (by rw [h']; exact hi)
+
+theorem natDegree_dehom_le {P : MvPolynomial (Fin 2) R} (hP : P ∈ BinaryForm R n) :
+    (dehom P).natDegree ≤ n := by
+  rw [Polynomial.natDegree_le_iff_coeff_eq_zero]
+  intro j hj
+  rw [coeff_dehom hP, ite_eq_right]
+  rw [Finset.mem_range]; omega
+
+theorem dehom_binarySubst_T_zpow (h : ℤ) (P : MvPolynomial (Fin 2) R) :
+    dehom (binarySubst R ((ModularGroup.T ^ h : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) P)
+      = (dehom P).comp (Polynomial.X + Polynomial.C (h : R)) := by
+  revert P
+  refine fun P => ?_
+  have key : (dehom : MvPolynomial (Fin 2) R →ₐ[R] R[X]).comp (binarySubst R ((ModularGroup.T ^ h :
+    SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ))
+      = (Polynomial.aeval (Polynomial.X + Polynomial.C (h : R)) : R[X] →ₐ[R] R[X]).comp dehom := by
+    refine MvPolynomial.algHom_ext fun i => ?_
+    rw [AlgHom.comp_apply, AlgHom.comp_apply, binarySubst_X, ModularGroup.coe_T_zpow]
+    fin_cases i <;> simp [dehom, Fin.sum_univ_two, add_comm]
+  have := congrArg (fun φ => φ P) key
+  simpa [Polynomial.aeval_X, Polynomial.comp_eq_aeval] using this
+
+theorem eq_C_of_comp_X_add_C_eq [IsDomain R] {q : R[X]} (hq : q.natDegree ≤ n) {h : R} (hh : h ≠ 0)
+    (hn : ∀ j : ℕ, 1 ≤ j → j ≤ n → (j : R) ≠ 0) (hinv : q.comp (Polynomial.X + Polynomial.C h) = q)
+    :
+    q = Polynomial.C (q.eval 0) := by
+  classical
+  have hper : ∀ k : ℕ, q.eval ((k : R) * h) = q.eval 0 := by
+    intro k
+    induction k with
+    | zero => simp
+    | succ k ih =>
+      have := congrArg (fun r => Polynomial.eval ((k : R) * h) r) hinv
+      simp only [Polynomial.eval_comp, Polynomial.eval_add, Polynomial.eval_X,
+        Polynomial.eval_C] at this
+      rw [← ih, ← this]
+      congr 1; push_cast; ring
+  set q' : R[X] := q - Polynomial.C (q.eval 0) with hq'
+  have hdeg : q'.natDegree ≤ n := (Polynomial.natDegree_sub_le _ _).trans (by simpa using hq)
+  have hroots : ∀ k ∈ Finset.range (n + 1), q'.eval ((k : R) * h) = 0 := fun k _ => by
+    simp [hq', hper k]
+  have hinj : Set.InjOn (fun k : ℕ => (k : R) * h) (Finset.range (n + 1) : Set ℕ) := by
+    intro i hi j hj hij
+    simp only [Finset.coe_range, Set.mem_Iio] at hi hj
+    have : ((i : R) - (j : R)) * h = 0 := by rw [sub_mul]; exact sub_eq_zero.mpr hij
+    rcases mul_eq_zero.mp this with h0 | h0
+    · by_contra hne
+      rcases Nat.lt_or_gt_of_ne hne with hlt | hlt
+      · have := hn (j - i) (by omega) (by omega)
+        apply this; rw [Nat.cast_sub hlt.le]; linear_combination -h0
+      · have := hn (i - j) (by omega) (by omega)
+        apply this; rw [Nat.cast_sub hlt.le]; linear_combination h0
+    · exact (hh h0).elim
+  have hzero : q' = 0 := by
+    apply Polynomial.eq_zero_of_natDegree_lt_card_of_eval_eq_zero' q' ((Finset.range (n + 1)).image
+      fun k : ℕ => (k : R) * h)
+    · intro x hx
+      obtain ⟨k, hk, rfl⟩ := Finset.mem_image.mp hx
+      exact hroots k hk
+    · rw [Finset.card_image_of_injOn hinj, Finset.card_range]; omega
+  rw [hq', sub_eq_zero] at hzero
+  exact hzero
+
+end UnipotentFixedAux
+
+open UnipotentFixedAux in
+theorem SolMain.A2 {R : Type*} [CommRing R] [IsDomain R] (n : ℕ) {h : ℤ}
+    (hh : (h : R) ≠ 0) (hn : ∀ j : ℕ, 1 ≤ j → j ≤ n → (j : R) ≠ 0) (P : ↥(BinaryForm R n))
+    (hP : binaryFormRepSL R n (ModularGroup.T ^ h) P = P) :
+    ∃ c : R, (P : MvPolynomial (Fin 2) R) = c • MvPolynomial.X 0 ^ n := by
+  classical
+  have hsub : binarySubst R ((ModularGroup.T ^ h : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) (P :
+    MvPolynomial (Fin 2) R) = P :=
+    by
+    simpa using congrArg Subtype.val hP
+  have hq : (dehom (P : MvPolynomial (Fin 2) R)).comp (Polynomial.X + Polynomial.C (h : R)) = dehom
+    (P : MvPolynomial (Fin 2) R) :=
+    by
+    rw [← dehom_binarySubst_T_zpow, hsub]
+  have hconst := eq_C_of_comp_X_add_C_eq (natDegree_dehom_le P.2) hh hn hq
+  refine ⟨AddMonoidAlgebra.coeff (P : MvPolynomial (Fin 2) R) (expo n 0), ?_⟩
+  have hcoeff : ∀ j ∈ Finset.range (n + 1), j ≠ 0 → AddMonoidAlgebra.coeff (P : MvPolynomial (Fin 2)
+    R) (expo n j) = 0 :=
+    by
+    intro j hj hj0
+    have := congrArg (fun r : R[X] => r.coeff j) hconst
+    simp only [Polynomial.coeff_C, ite_eq_right hj0] at this
+    rwa [coeff_dehom P.2, ite_eq_left hj] at this
+  conv_lhs => rw [eq_sum_range P.2]
+  rw [Finset.sum_eq_single 0 (fun j hj hj0 => by rw [hcoeff j hj hj0,
+    map_zero]) (fun h0 => (h0 (by simp)).elim)]
+  rw [expo, Nat.sub_zero, Finsupp.single_zero, add_zero, ← MvPolynomial.C_mul_X_pow_eq_monomial,
+    MvPolynomial.smul_eq_C_mul]
+
+end HeckeEis
+
+open scoped MatrixGroups in
+theorem solution {R : Type*} [CommRing R] [IsDomain R] (n : ℕ)
+    {h : ℤ} (hh : (h : R) ≠ 0) (hn : ∀ j : ℕ, 1 ≤ j → j ≤ n → (j : R) ≠ 0)
+    (P : ↥(HeckeEis.BinaryForm R n))
+    (hP : HeckeEis.binaryFormRepSL R n (ModularGroup.T ^ h) P = P) :
+    ∃ c : R, (P : MvPolynomial (Fin 2) R) = c • MvPolynomial.X 0 ^ n :=
+  HeckeEis.SolMain.A2 n hh hn P hP
+
+end S_HeckeEis_exists_eq_smul_X_pow_of_binaryFormRepSL_T_zpow_eq_self
+end P2MW
+export P2MW.S_HeckeEis_exists_eq_smul_X_pow_of_binaryFormRepSL_T_zpow_eq_self (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.exists_eq_smul_X_pow_of_binaryFormRepSL_T_zpow_eq_self {R : Type*} [CommRing R]
+    [IsDomain R] (n : ℕ)
+    {h : ℤ} (hh : (h : R) ≠ 0) (hn : ∀ j : ℕ, 1 ≤ j → j ≤ n → (j : R) ≠ 0)
+    (P : ↥(HeckeEis.BinaryForm R n))
+    (hP : HeckeEis.binaryFormRepSL R n (ModularGroup.T ^ h) P = P) :
+    ∃ c : R, (P : MvPolynomial (Fin 2) R) = c • MvPolynomial.X 0 ^ n :=
+  solution n hh hn P hP
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_eq_smul_X_pow_of_binaryFormRepSL_lowerUnipotent_eq_self.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_eq_smul_X_pow_of_binaryFormRepSL_lowerUnipotent_eq_self.lean
new file mode 100644
index 0000000000..3163f79896
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_eq_smul_X_pow_of_binaryFormRepSL_lowerUnipotent_eq_self.lean
@@ -0,0 +1,139 @@
+/-
+Based on Prove2Me node HeckeEis.exists_eq_smul_X_pow_of_binaryFormRepSL_lowerUnipotent_eq_self
+(f0572a19-e7e9-5a76-9764-969b69c4c9d7) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 366cfae1-47bc-538a-be49-9d1ca67982e6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_eq_smul_X_pow_of_binaryFormRepSL_T_zpow_eq_self
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Fixed forms of a lower unipotent are multiples of X₁ⁿ
+
+Theorem statement: `HeckeEis.exists_eq_smul_X_pow_of_binaryFormRepSL_lowerUnipotent_eq_self`
+(`f0572a19-e7e9-5a76-9764-969b69c4c9d7`), by Claude, 2026-09-05.
+
+Proof: submission `366cfae1-47bc-538a-be49-9d1ca67982e6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring which is an integral domain, let $n$ be a natural number, and let $h$
+be an integer whose image in $R$ is nonzero; assume moreover that the image in $R$ of every integer
+$j$ with $1 \le j \le n$ is nonzero. Let $g$ be an element of $\mathrm{SL}_2(\mathbb{Z})$ whose
+underlying $2\times 2$ integer matrix is $!![1,0;h,1]$, and let $P$ belong to [`HeckeEis.BinaryForm
+R n`](def/HeckeEis_BinaryFormRep.html#L25), i.e. the submodule of $R$-homogeneous polynomials of
+degree $n$ in $R[X_0,X_1] =$ `MvPolynomial (Fin 2) R`. The action used is [`HeckeEis.binaryFormRepSL
+R n`](def/HeckeEis_BinaryFormRep.html#L61), the representation of $\mathrm{SL}_2(\mathbb{Z})$ on
+this submodule induced by the substitution algebra endomorphism
+[`HeckeEis.binarySubst`](def/HeckeEis_BinaryFormRep.html#L28), which sends $X_j$ to $\sum_{i} M_{ij}
+X_i$ for the matrix $M$ of the group element; for $M = !![1,0;h,1]$ this is $X_0 \mapsto X_0 +
+hX_1$, $X_1 \mapsto X_1$. Assume that $P$ is fixed by $g$ under this action, that is $P(X_0 + hX_1,
+X_1) = P(X_0,X_1)$. The conclusion is that there exists $c \in R$ with $P = c \cdot X_1^{\,n}$ as
+elements of $R[X_0,X_1]$.
+
+This is the determination of the fixed subspace of a lower triangular unipotent matrix acting on
+binary forms of degree $n$ (the symmetric power $\mathrm{Sym}^n$ of the standard representation), in
+the case where $h$ and the integers $1,\dots,n$ are invertible enough to be nonzero in $R$: the
+fixed vectors form the line spanned by $X_1^n$. It is applied to
+$\begin{pmatrix}1&0\\N&1\end{pmatrix} \in \Gamma_0(N)$ in the proof that certain parabolic
+cohomology classes vanish, namely in
+[`HeckeEis.coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero`]
+(thm.html#HeckeEis.coeffH1par_binaryFormRepSL_int_eq_zero_of_smul_eq_zero).
+The group element is specified by its matrix rather than by a fixed presentation, so any element
+with that matrix may be used.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_exists_eq_smul_X_pow_of_binaryFormRepSL_lowerUnipotent_eq_self.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_exists_eq_smul_X_pow_of_binaryFormRepSL_lowerUnipotent_eq_self
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binaryFormRepSL \
+  binaryFormRepSL_apply_coe exists_eq_smul_X_pow_of_binaryFormRepSL_T_zpow_eq_self"
+p2m_open "HeckeEis"
+
+open MvPolynomial
+open scoped MatrixGroups
+
+theorem UnipotentFixedAux.eq_S_mul_T_zpow_neg_mul_S_inv {h : ℤ} (g : SL(2, ℤ))
+    (hg : (g : Matrix (Fin 2) (Fin 2) ℤ) = !![1, 0; h, 1]) :
+    g = ModularGroup.S * ModularGroup.T ^ (-h) * ModularGroup.S⁻¹ := by
+  rw [eq_mul_inv_iff_mul_eq]
+  apply Subtype.ext
+  rw [Matrix.SpecialLinearGroup.coe_mul, Matrix.SpecialLinearGroup.coe_mul, hg,
+    ModularGroup.coe_T_zpow, ModularGroup.coe_S]
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp [Matrix.mul_apply, Fin.sum_univ_two]
+
+theorem UnipotentFixedAux.binarySubst_S_X_zero_pow (R : Type*) [CommRing R] (n : ℕ) :
+    binarySubst R ((ModularGroup.S : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) (MvPolynomial.X 0 ^ n)
+      = (MvPolynomial.X 1 ^ n : MvPolynomial (Fin 2) R) := by
+  rw [map_pow, binarySubst_X, ModularGroup.coe_S]
+  simp [Fin.sum_univ_two]
+
+open UnipotentFixedAux in
+theorem SolMain.A3 {R : Type*} [CommRing R] [IsDomain R] (n : ℕ)
+    {h : ℤ} (hh : (h : R) ≠ 0) (hn : ∀ j : ℕ, 1 ≤ j → j ≤ n → (j : R) ≠ 0)
+    (g : SL(2, ℤ)) (hg : (g : Matrix (Fin 2) (Fin 2) ℤ) = !![1, 0; h, 1])
+    (P : ↥(BinaryForm R n)) (hP : binaryFormRepSL R n g P = P) :
+    ∃ c : R, (P : MvPolynomial (Fin 2) R) = c • MvPolynomial.X 1 ^ n := by
+  have hgS := eq_S_mul_T_zpow_neg_mul_S_inv g hg
+  set Q : ↥(BinaryForm R n) := binaryFormRepSL R n ModularGroup.S⁻¹ P with hQ
+  have hQfix : binaryFormRepSL R n (ModularGroup.T ^ (-h)) Q = Q := by
+    have h1 : binaryFormRepSL R n ModularGroup.S⁻¹ (binaryFormRepSL R n g P) = Q := by rw [hP]
+    rwa [hgS, map_mul, map_mul, Module.End.mul_apply, Module.End.mul_apply, ← Module.End.mul_apply
+      (binaryFormRepSL R n _),
+      ← map_mul, inv_mul_cancel, map_one, Module.End.one_apply] at h1
+  have hh' : ((-h : ℤ) : R) ≠ 0 := by rw [Int.cast_neg]; exact neg_ne_zero.mpr hh
+  obtain ⟨c, hc⟩ := exists_eq_smul_X_pow_of_binaryFormRepSL_T_zpow_eq_self n hh' hn Q hQfix
+  refine ⟨c, ?_⟩
+  have hPQ : P = binaryFormRepSL R n ModularGroup.S Q := by
+    rw [hQ, ← Module.End.mul_apply, ← map_mul, mul_inv_cancel, map_one, Module.End.one_apply]
+  rw [hPQ, binaryFormRepSL_apply_coe, hc, map_smul, binarySubst_S_X_zero_pow]
+
+end HeckeEis
+
+open scoped MatrixGroups in
+theorem solution {R : Type*} [CommRing R] [IsDomain R] (n : ℕ)
+    {h : ℤ} (hh : (h : R) ≠ 0) (hn : ∀ j : ℕ, 1 ≤ j → j ≤ n → (j : R) ≠ 0)
+    (g : SL(2, ℤ)) (hg : (g : Matrix (Fin 2) (Fin 2) ℤ) = !![1, 0; h, 1])
+    (P : ↥(HeckeEis.BinaryForm R n)) (hP : HeckeEis.binaryFormRepSL R n g P = P) :
+    ∃ c : R, (P : MvPolynomial (Fin 2) R) = c • MvPolynomial.X 1 ^ n :=
+  HeckeEis.SolMain.A3 n hh hn g hg P hP
+
+end S_HeckeEis_exists_eq_smul_X_pow_of_binaryFormRepSL_lowerUnipotent_eq_self
+end P2MW
+export P2MW.S_HeckeEis_exists_eq_smul_X_pow_of_binaryFormRepSL_lowerUnipotent_eq_self (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.exists_eq_smul_X_pow_of_binaryFormRepSL_lowerUnipotent_eq_self {R : Type*}
+    [CommRing R] [IsDomain R] (n : ℕ)
+    {h : ℤ} (hh : (h : R) ≠ 0) (hn : ∀ j : ℕ, 1 ≤ j → j ≤ n → (j : R) ≠ 0)
+    (g : SL(2, ℤ)) (hg : (g : Matrix (Fin 2) (Fin 2) ℤ) = !![1, 0; h, 1])
+    (P : ↥(HeckeEis.BinaryForm R n)) (hP : HeckeEis.binaryFormRepSL R n g P = P) :
+    ∃ c : R, (P : MvPolynomial (Fin 2) R) = c • MvPolynomial.X 1 ^ n :=
+  solution n hh hn g hg P hP
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_induced_binaryFormRepSL_top.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_induced_binaryFormRepSL_top.lean
new file mode 100644
index 0000000000..60ae812761
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_induced_binaryFormRepSL_top.lean
@@ -0,0 +1,630 @@
+/-
+Based on Prove2Me node HeckeEis.exists_induced_binaryFormRepSL_top
+(84cf2b36-679f-5fd8-905a-3d592b27e37a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 37254edc-64a7-5a3c-9a7d-24d7387763ad
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Basic.Complex.Basic
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+
+import Mathlib.LinearAlgebra.BilinearForm.Orthogonal
+import Mathlib.LinearAlgebra.Matrix.FixedDetMatrices
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_binaryFormRepSL_neg_one_apply
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_pairing_binaryForm_linePow
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Induced module Ind_{Γ_0(N)}^{SL₂(ℤ)} of binary forms: no invariants, no coinvariants
+
+Theorem statement: `HeckeEis.exists_induced_binaryFormRepSL_top`
+(`84cf2b36-679f-5fd8-905a-3d592b27e37a`), by Claude, 2026-09-05.
+
+Proof: submission `37254edc-64a7-5a3c-9a7d-24d7387763ad`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number that is nonzero and let $n$ be an even natural number with $n \neq 0$.
+Write $\mathrm{BinaryForm}_{\mathbb C}(n)$ for the submodule of degree-$n$ homogeneous elements of
+$\mathbb C[X_0,X_1]$, on which $SL(2,\mathbb Z)$ acts through
+[`HeckeEis.binaryFormRepSL`](def/HeckeEis_BinaryFormRep.html#L61), the representation sending $g$ to
+the substitution $X_j \mapsto \sum_i g_{ij} X_i$. The assertion is that there exists a complex
+representation $W$ of the full subgroup $\top$ of $SL(2,\mathbb Z)$ on the space of functions
+$SL(2,\mathbb Z)/\Gamma_0(N) \to \mathrm{BinaryForm}_{\mathbb C}(n)$ with the following four
+properties. First, $W$ is the induced action: for all $g$, all $f$ and all cosets $x$ one has
+$(W(g)f)(x) = g \cdot f(g^{-1}x)$, the outer action being
+[`HeckeEis.binaryFormRepSL`](def/HeckeEis_BinaryFormRep.html#L61). Second, $W(-1)$ is the identity
+map. Third, $W$ has no nonzero invariants: if $W(g)f = f$ for every $g$, then $f = 0$. Fourth, $W$
+has no coinvariants in the strong form that every $f$ can be written as $(W(S)a - a) + (W(ST)b - b)$
+for some $a, b$, where $S$ and $T$ are the standard generators `ModularGroup.S` and
+`ModularGroup.T`.
+
+This packages the induced module $\mathrm{Ind}_{\Gamma_0(N)}^{SL_2(\mathbb Z)}\mathrm{Sym}^n$
+together with the three facts about it needed for a cohomological count: triviality of the central
+element $-1$, vanishing of invariants, and vanishing of coinvariants in the explicit shape dictated
+by the presentation of $PSL_2(\mathbb Z)$ by $S$ and $ST$. It feeds the bound
+[`HeckeEis.finrank_coeffH1par_le_two_mul_dimFormula`]
+(thm.html#HeckeEis.finrank_coeffH1par_le_two_mul_dimFormula)
+on the dimension of parabolic cohomology in weight $n+2$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_exists_induced_binaryFormRepSL_top.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_exists_induced_binaryFormRepSL_top
+
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  binaryFormRepSL_apply_coe exists_pairing_binaryForm_linePow binaryFormRepSL_neg_one_apply"
+namespace UH3Sol
+p2m_open "HeckeEis"
+
+open scoped MatrixGroups
+open MvPolynomial Finset
+
+variable (N : ℕ) (n : ℕ)
+
+abbrev Gt : Subgroup SL(2, ℤ) := ⊤
+abbrev X0 := SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N
+abbrev Vn := ↥(BinaryForm ℂ n)
+abbrev ρ : Representation ℂ SL(2, ℤ) (Vn n) := binaryFormRepSL ℂ n
+
+def indRep : Representation ℂ ↥Gt (X0 N → Vn n) where
+  toFun g :=
+    { toFun := fun f x => ρ n (g : SL(2, ℤ)) (f (((g : SL(2, ℤ))⁻¹) • x))
+      map_add' := fun f f' => by funext x; simp
+      map_smul' := fun c f => by funext x; simp }
+  map_one' := by
+    apply LinearMap.ext; intro f; funext x
+    simp
+  map_mul' g h := by
+    apply LinearMap.ext; intro f; funext x
+    change ρ n ((g : SL(2, ℤ)) * (h : SL(2, ℤ))) (f (((g : SL(2, ℤ)) * (h : SL(2, ℤ)))⁻¹ • x)) =
+      ρ n (g : SL(2, ℤ)) (ρ n (h : SL(2, ℤ)) (f (((h : SL(2, ℤ))⁻¹) • ((g : SL(2, ℤ))⁻¹) • x)))
+    rw [map_mul, Module.End.mul_apply, mul_inv_rev, mul_smul]
+
+@[scoped simp] theorem indRep_apply (g : ↥Gt) (f : X0 N → Vn n) (x : X0 N) :
+    indRep N n g f x = ρ n (g : SL(2, ℤ)) (f (((g : SL(2, ℤ))⁻¹) • x)) := rfl
+
+variable {N n}
+
+theorem neg_one_mem : (-1 : SL(2, ℤ)) ∈ CongruenceSubgroup.Gamma0 N := by
+  rw [CongruenceSubgroup.Gamma0_mem]; simp
+
+theorem neg_one_smul_coset (x : X0 N) : (-1 : SL(2, ℤ)) • x = x := by
+  induction x using QuotientGroup.induction_on with
+  | H g =>
+    rw [MulAction.Quotient.smul_mk, QuotientGroup.eq]
+    simp only [smul_eq_mul, mul_inv_rev]
+    have : g⁻¹ * (-1 : SL(2, ℤ))⁻¹ * g = -1 := by
+      rw [inv_neg, inv_one, mul_neg_one, neg_mul, inv_mul_cancel]
+    rw [this]
+    exact neg_one_mem
+
+theorem indRep_neg_one (hn : Even n) : indRep N n ⟨-1, Subgroup.mem_top _⟩ = LinearMap.id := by
+  apply LinearMap.ext; intro f; funext x
+  rw [indRep_apply, LinearMap.id_apply]
+  change ρ n (-1) (f ((-1 : SL(2, ℤ))⁻¹ • x)) = f x
+  rw [show ((-1 : SL(2, ℤ)))⁻¹ = -1 by rw [inv_neg,
+    inv_one], neg_one_smul_coset, binaryFormRepSL_neg_one_apply, hn.neg_one_pow, one_smul]
+
+end HeckeEis.UH3Sol
+end
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  binaryFormRepSL_apply_coe exists_pairing_binaryForm_linePow binaryFormRepSL_neg_one_apply"
+namespace UH3Sol
+p2m_open "HeckeEis"
+
+open scoped MatrixGroups
+open MvPolynomial Finset
+
+variable {n : ℕ}
+
+theorem eval_binarySubst (M : Matrix (Fin 2) (Fin 2) ℤ) (v : Fin 2 → ℂ) (P : MvPolynomial (Fin 2) ℂ)
+    :
+    eval v (binarySubst ℂ M P) = eval (fun j => ∑ i : Fin 2, ((M i j : ℤ) : ℂ) * v i) P := by
+  have key : (eval v).comp (binarySubst ℂ M : MvPolynomial (Fin 2) ℂ →ₐ[ℂ] MvPolynomial (Fin 2)
+    ℂ).toRingHom
+      = eval (fun j => ∑ i : Fin 2, ((M i j : ℤ) : ℂ) * v i) :=
+    MvPolynomial.ringHom_ext (fun r => by simp []) (fun j => by simp [binarySubst_X])
+  exact RingHom.congr_fun key P
+
+theorem eval_one_eq_of_T_zpow_fixed (m : ℤ) (P : Vn n) (hP : ρ n (ModularGroup.T ^ m) P = P) (k : ℕ)
+    :
+    eval ![(1 : ℂ), (m : ℂ) * k] (P : MvPolynomial (Fin 2) ℂ) = eval ![(1 : ℂ), 0] (P : MvPolynomial
+      (Fin 2) ℂ) := by
+  have hk : ρ n ((ModularGroup.T ^ m) ^ k) P = P := by
+    induction k with
+    | zero => rw [pow_zero, map_one, Module.End.one_apply]
+    | succ k ih => rw [pow_succ, map_mul, Module.End.mul_apply, hP, ih]
+  have h := congrArg (fun Q : Vn n => eval ![(1 : ℂ), 0] (Q : MvPolynomial (Fin 2) ℂ)) hk
+  rw [binaryFormRepSL_apply_coe, eval_binarySubst, ← zpow_natCast, ← zpow_mul,
+    ModularGroup.coe_T_zpow] at h
+  have hv : (fun j : Fin 2 => ∑ i : Fin 2, (((!![(1 : ℤ), m * (k : ℤ); 0, 1] : Matrix (Fin 2) (Fin
+    2) ℤ) i j : ℤ) : ℂ) * (![(1 : ℂ), 0] : Fin 2 → ℂ) i)
+      = ![(1 : ℂ), (m : ℂ) * k] := by
+    funext j
+    fin_cases j <;> simp [Fin.sum_univ_two]
+  rw [hv] at h
+  exact h
+
+def dehom (P : MvPolynomial (Fin 2) ℂ) : Polynomial ℂ := aeval ![(1 : Polynomial ℂ), Polynomial.X] P
+
+theorem eval_dehom (P : MvPolynomial (Fin 2) ℂ) (t : ℂ) :
+    (dehom P).eval t = eval ![(1 : ℂ), t] P := by
+  rw [dehom, ← Polynomial.coe_aeval_eq_eval, ← AlgHom.comp_apply, MvPolynomial.comp_aeval]
+  change aeval (fun i => Polynomial.aeval t ((![(1 : Polynomial ℂ), Polynomial.X] : Fin 2 →
+    Polynomial ℂ) i)) P = aeval ![(1 : ℂ), t] P
+  congr 2
+  funext j
+  fin_cases j <;> simp
+
+theorem dehom_monomial (d : Fin 2 →₀ ℕ) (c : ℂ) :
+    dehom (monomial d c) = Polynomial.C c * Polynomial.X ^ (d 1) := by
+  rw [dehom, MvPolynomial.aeval_monomial, Finsupp.prod_fintype _ _ (by simp), Fin.prod_univ_two]
+  simp [Polynomial.C_eq_algebraMap]
+
+theorem coeff_dehom_of_isHomogeneous {P : MvPolynomial (Fin 2) ℂ} (hP : P.IsHomogeneous n) (a : ℕ)
+    (ha : a ≤ n) :
+    (dehom P).coeff a = AddMonoidAlgebra.coeff P
+      (Finsupp.single 0 (n - a) + Finsupp.single 1 a) := by
+  classical
+  set da : Fin 2 →₀ ℕ := Finsupp.single 0 (n - a) + Finsupp.single 1 a with hda
+  have hkey : ∀ d ∈ P.support, d 1 = a → d = da := by
+    intro d hd h1
+    have hdeg : d 0 + d 1 = n := by
+      have hw := hP (mem_support_iff.mp hd)
+      have hdeg' : d.degree = n := by rw [Finsupp.degree_eq_weight_one]; exact hw
+      rwa [Finsupp.degree_eq_sum, Fin.sum_univ_two] at hdeg'
+    ext j; fin_cases j
+    · simp [hda]; omega
+    · simp [hda, h1]
+  have hmono : ∀ (d : Fin 2 →₀ ℕ) (c : ℂ), (dehom (monomial d c)).coeff a = if d 1 = a then c else 0
+    :=
+    by
+    intro d c
+    rw [dehom_monomial, Polynomial.coeff_C_mul, Polynomial.coeff_X_pow]
+    split_ifs with h1 h2 h2
+    · rw [mul_one]
+    · exact absurd h1.symm h2
+    · exact absurd h2.symm h1
+    · rw [mul_zero]
+  have hsum : (dehom P).coeff a =
+      ∑ d ∈ P.support, (if d 1 = a then AddMonoidAlgebra.coeff P d else 0) := by
+    conv_lhs => rw [P.as_sum, dehom, map_sum]
+    rw [Polynomial.finsetSum_coeff]
+    exact Finset.sum_congr rfl fun d _ => hmono d _
+  rw [hsum]
+  by_cases hmem : da ∈ P.support
+  · rw [Finset.sum_eq_single_of_mem da hmem]
+    · rw [ite_eq_left]; rw [hda]; simp
+    · intro d hd hne
+      rw [ite_eq_right]
+      intro h; exact hne (hkey d hd h)
+  · rw [Finset.sum_eq_zero, eq_comm]
+    · exact notMem_support_iff.mp hmem
+    · intro d hd
+      rw [ite_eq_right]
+      intro h
+      exact hmem (hkey d hd h ▸ hd)
+
+end HeckeEis.UH3Sol
+end
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  binaryFormRepSL_apply_coe exists_pairing_binaryForm_linePow binaryFormRepSL_neg_one_apply"
+namespace UH3Sol
+p2m_open "HeckeEis"
+
+open scoped MatrixGroups
+open MvPolynomial Finset
+
+variable {n : ℕ}
+
+def dv (n a : ℕ) : Fin 2 →₀ ℕ := Finsupp.single 0 (n - a) + Finsupp.single 1 a
+
+@[scoped simp] theorem dv_zero' (n a : ℕ) : dv n a 0 = n - a := by simp [dv]
+@[scoped simp] theorem dv_one' (n a : ℕ) : dv n a 1 = a := by simp [dv]
+
+theorem coeff_eq_zero_of_T_zpow_fixed {m : ℤ} (hm : m ≠ 0) (P : Vn n)
+    (hP : ρ n (ModularGroup.T ^ m) P = P)
+    (d : Fin 2 →₀ ℕ) (hd : d 1 ≠ 0) :
+    AddMonoidAlgebra.coeff (P : MvPolynomial (Fin 2) ℂ) d = 0 := by
+  classical
+  by_contra hne
+  have hPh : (P : MvPolynomial (Fin 2) ℂ).IsHomogeneous n := (mem_homogeneousSubmodule n _).mp P.2
+  have hdeg : d 0 + d 1 = n := by
+    have hw := hPh hne
+    have hdeg' : d.degree = n := by rw [Finsupp.degree_eq_weight_one]; exact hw
+    rwa [Finsupp.degree_eq_sum, Fin.sum_univ_two] at hdeg'
+  set a := d 1 with ha
+  have hda : d = dv n a := by
+    ext j; fin_cases j
+    · simp; omega
+    · simp [ha]
+  set q := dehom (P : MvPolynomial (Fin 2) ℂ) with hq
+  have hconst : q - Polynomial.C (q.eval 0) = 0 := by
+    apply Polynomial.eq_zero_of_infinite_isRoot
+    have hroots : Set.range (fun k : ℕ => ((m : ℂ) * k)) ⊆ {t | (q - Polynomial.C (q.eval 0)).IsRoot
+      t} :=
+      by
+      rintro _ ⟨k, rfl⟩
+      change (q - Polynomial.C (q.eval 0)).IsRoot _
+      rw [Polynomial.IsRoot, Polynomial.eval_sub, Polynomial.eval_C, hq, eval_dehom, eval_dehom,
+        eval_one_eq_of_T_zpow_fixed m P hP k]
+      simp
+    refine Set.Infinite.mono hroots (Set.infinite_range_of_injective fun k k' h => ?_)
+    have hm' : (m : ℂ) ≠ 0 := Int.cast_ne_zero.mpr hm
+    exact_mod_cast mul_left_cancel₀ hm' h
+  have hcoeff : q.coeff a = 0 := by
+    have := congrArg (fun p => Polynomial.coeff p a) hconst
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_C, Polynomial.coeff_zero] at this
+    rw [ite_eq_right hd] at this
+    simpa using this
+  rw [hq, coeff_dehom_of_isHomogeneous hPh a (by omega)] at hcoeff
+  rw [hda, dv] at hne
+  exact hne hcoeff
+
+theorem eq_of_T_zpow_fixed {m : ℤ} (hm : m ≠ 0) (P : Vn n) (hP : ρ n (ModularGroup.T ^ m) P = P) :
+    (P : MvPolynomial (Fin 2) ℂ) = monomial (Finsupp.single 0 n)
+      (AddMonoidAlgebra.coeff (P : MvPolynomial (Fin 2) ℂ) (Finsupp.single 0 n)) := by
+  classical
+  ext d
+  rw [coeff_monomial]
+  split_ifs with h
+  · rw [h]
+  · by_cases hd1 : d 1 = 0
+    · by_contra hne
+      have hPh : (P : MvPolynomial (Fin 2) ℂ).IsHomogeneous n :=
+        (mem_homogeneousSubmodule n _).mp P.2
+      have hw := hPh hne
+      have hdeg' : d.degree = n := by rw [Finsupp.degree_eq_weight_one]; exact hw
+      rw [Finsupp.degree_eq_sum, Fin.sum_univ_two, hd1, add_zero] at hdeg'
+      apply h
+      ext j; fin_cases j
+      · simp [hdeg']
+      · simp [hd1]
+    · exact coeff_eq_zero_of_T_zpow_fixed hm P hP d hd1
+
+theorem eq_zero_of_T_fixed_of_S_T_fixed (hn0 : n ≠ 0) (v : Vn n)
+    (h1 : ρ n ModularGroup.T v = v)
+    (hN : ∃ m : ℤ, m ≠ 0 ∧ ρ n (ModularGroup.T ^ m) (ρ n ModularGroup.S v) = ρ n ModularGroup.S v) :
+    v = 0 := by
+  classical
+  obtain ⟨m, hm, h2⟩ := hN
+  have e1 := eq_of_T_zpow_fixed (m := 1) one_ne_zero v
+    ((congrArg (fun g => ρ n g v) (zpow_one ModularGroup.T)).trans h1)
+  have e2 := eq_of_T_zpow_fixed hm _ h2
+  set c := AddMonoidAlgebra.coeff (v : MvPolynomial (Fin 2) ℂ) (Finsupp.single 0 n) with hc
+  have hSv : ((ρ n ModularGroup.S v : Vn n) : MvPolynomial (Fin 2) ℂ) = monomial (Finsupp.single 1
+    n) c :=
+    by
+    rw [binaryFormRepSL_apply_coe, e1, ← C_mul_X_pow_eq_monomial, map_mul, binarySubst_C, map_pow,
+      binarySubst_X]
+    simp [ModularGroup.S, Fin.sum_univ_two, C_mul_X_pow_eq_monomial]
+  have hc0 : c = 0 := by
+    have := congrArg (fun P : MvPolynomial (Fin 2) ℂ =>
+      AddMonoidAlgebra.coeff P (Finsupp.single 1 n)) e2
+    rw [hSv, coeff_monomial, coeff_monomial, ite_eq_left rfl, ite_eq_right] at this
+    · exact this
+    · intro h
+      have := congrArg (fun d => d 0) h
+      simp only [Fin.isValue, Finsupp.single_eq_same, ne_eq, zero_ne_one, not_false_eq_true,
+        Finsupp.single_eq_of_ne] at this; exact hn0 this
+  apply Subtype.ext
+  rw [e1, hc0, monomial_zero]
+  simp
+
+end HeckeEis.UH3Sol
+end
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  binaryFormRepSL_apply_coe exists_pairing_binaryForm_linePow binaryFormRepSL_neg_one_apply"
+namespace UH3Sol
+p2m_open "HeckeEis"
+
+open scoped MatrixGroups
+open MvPolynomial Finset
+
+variable {N n : ℕ}
+
+theorem T_mem_Gamma0 : (ModularGroup.T : SL(2, ℤ)) ∈ CongruenceSubgroup.Gamma0 N := by
+  rw [CongruenceSubgroup.Gamma0_mem]; simp [ModularGroup.T]
+
+theorem Sinv_TN_S_mem :
+    (ModularGroup.S : SL(2, ℤ))⁻¹ * ModularGroup.T ^ (N : ℤ) * ModularGroup.S ∈
+      CongruenceSubgroup.Gamma0 N := by
+  rw [CongruenceSubgroup.Gamma0_mem]
+  have hS : ((ModularGroup.S : SL(2, ℤ))⁻¹ : SL(2, ℤ)) = ⟨!![0, 1; -1, 0], by
+    norm_num [Matrix.det_fin_two_of]⟩ :=
+    by
+    apply Subtype.ext
+    rw [Matrix.SpecialLinearGroup.coe_inv]
+    simp [ModularGroup.S, Matrix.adjugate_fin_two_of]
+  rw [Matrix.SpecialLinearGroup.coe_mul, Matrix.SpecialLinearGroup.coe_mul, hS,
+    ModularGroup.coe_T_zpow]
+  simp [ModularGroup.S, Matrix.mul_apply, Fin.sum_univ_two]
+
+theorem indRep_invariants [NeZero N] (hn0 : n ≠ 0) (f : X0 N → Vn n)
+    (hf : ∀ g : ↥Gt, indRep N n g f = f) :
+    f = 0 := by
+  set x0 : X0 N := ((1 : SL(2, ℤ)) : X0 N) with hx0
+  have hpt : ∀ (g : SL(2, ℤ)) (x : X0 N), f x = ρ n g (f (g⁻¹ • x)) := fun g x => by
+    have := congrFun (hf ⟨g, Subgroup.mem_top _⟩) x
+    rw [indRep_apply] at this
+    exact this.symm
+  have htrans : ∀ g : SL(2, ℤ), f (g • x0) = ρ n g (f x0) := fun g => by
+    rw [hpt g (g • x0), inv_smul_smul]
+  set v := f x0 with hv
+  have hmemfix : ∀ γ : SL(2, ℤ), γ ∈ CongruenceSubgroup.Gamma0 N → γ • x0 = x0 := fun γ hγ => by
+    rw [hx0, MulAction.Quotient.smul_mk,
+      QuotientGroup.eq]; simpa using (CongruenceSubgroup.Gamma0 N).inv_mem hγ
+  have h1 : ρ n ModularGroup.T v = v := by
+    have := hpt ModularGroup.T x0
+    rw [hmemfix _ ((CongruenceSubgroup.Gamma0 N).inv_mem T_mem_Gamma0)] at this
+    exact this.symm
+  have h2 : ρ n (ModularGroup.T ^ (N : ℤ)) (ρ n ModularGroup.S v) = ρ n ModularGroup.S v := by
+    rw [← htrans ModularGroup.S]
+    have := hpt (ModularGroup.T ^ (N : ℤ)) (ModularGroup.S • x0)
+    have hfix : (ModularGroup.T ^ (N : ℤ))⁻¹ • ModularGroup.S • x0 = ModularGroup.S • x0 := by
+      rw [hx0, MulAction.Quotient.smul_mk, MulAction.Quotient.smul_mk, QuotientGroup.eq]
+      simp only [smul_eq_mul, mul_one, mul_inv_rev, inv_inv]
+      exact Sinv_TN_S_mem (N := N)
+    rw [hfix] at this
+    exact this.symm
+  have hv0 : v = 0 :=
+    eq_zero_of_T_fixed_of_S_T_fixed hn0 v h1 ⟨N, by exact_mod_cast (NeZero.ne N), h2⟩
+  funext x
+  induction x using QuotientGroup.induction_on with
+  | H g =>
+    have : ((g : SL(2, ℤ)) : X0 N) = g • x0 :=
+      by rw [hx0, MulAction.Quotient.smul_mk, smul_eq_mul, mul_one]
+    rw [this, htrans, hv0, map_zero]
+    rfl
+
+end HeckeEis.UH3Sol
+end
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  binaryFormRepSL_apply_coe exists_pairing_binaryForm_linePow binaryFormRepSL_neg_one_apply"
+namespace UH3Sol
+p2m_open "HeckeEis"
+
+open scoped MatrixGroups
+open MvPolynomial Finset
+open LinearMap (BilinForm)
+
+variable {N n : ℕ} [NeZero N]
+
+noncomputable scoped instance fintypeX0' : Fintype (X0 N) := (CongruenceSubgroup.Gamma0
+  N).fintypeQuotientOfFiniteIndex
+
+section Coinv
+
+variable (B : Vn n →ₗ[ℂ] Vn n →ₗ[ℂ] ℂ)
+  (hBinv : ∀ (g : SL(2, ℤ)) (P Q : Vn n), B (ρ n g P) (ρ n g Q) = B P Q)
+  (hBsymm : ∀ P Q : Vn n, B Q P = (-1) ^ n * B P Q)
+  (hBnd : ∀ P : Vn n, (∀ Q : Vn n, B P Q = 0) → P = 0)
+
+def BW : BilinForm ℂ (X0 N → Vn n) := ∑ x : X0 N, B.compl₁₂ (LinearMap.proj x) (LinearMap.proj x)
+
+@[scoped simp] theorem BW_apply (f f' : X0 N → Vn n) :
+    BW (N := N) B f f' = ∑ x : X0 N, B (f x) (f' x) := by
+  rw [BW, LinearMap.sum_apply, LinearMap.sum_apply]
+  rfl
+
+include hBinv in
+theorem BW_inv (g : ↥Gt) (f f' : X0 N → Vn n) :
+    BW (N := N) B (indRep N n g f) (indRep N n g f') = BW (N := N) B f f' := by
+  rw [BW_apply, BW_apply]
+  simp only [indRep_apply, hBinv]
+  exact Fintype.sum_equiv (MulAction.toPerm ((g : SL(2, ℤ))⁻¹)) _ _ fun x => rfl
+
+include hBsymm in
+theorem BW_isRefl : (BW (N := N) B).IsRefl := by
+  intro f f' h
+  rw [BW_apply] at h ⊢
+  rw [show ∑ x : X0 N, B (f' x) (f x) = (-1) ^ n * ∑ x : X0 N, B (f x) (f' x) by
+    rw [Finset.mul_sum]; exact Finset.sum_congr rfl fun x _ => hBsymm _ _, h, mul_zero]
+
+include hBnd hBsymm in
+theorem BW_nondegenerate : (BW (N := N) B).Nondegenerate := by
+  classical
+  refine ⟨fun f hf => ?_, fun f hf => ?_⟩
+  · funext x
+    apply hBnd
+    intro Q
+    have h := hf (Pi.single x Q)
+    rw [BW_apply, Finset.sum_eq_single x] at h
+    · simpa using h
+    · intro y _ hyx; rw [Pi.single_eq_of_ne hyx, map_zero]
+    · intro h; exact absurd (Finset.mem_univ x) h
+  · funext x
+    apply hBnd
+    intro Q
+    have h := hf (Pi.single x Q)
+    rw [BW_apply, Finset.sum_eq_single x] at h
+    · simp only [Pi.single_eq_same] at h
+      have := hBsymm (f x) Q
+      rw [h] at this
+      have hu : ((-1 : ℂ) ^ n) ≠ 0 := pow_ne_zero _ (by norm_num)
+      exact (mul_eq_zero.mp this.symm).resolve_left hu
+    · intro y _ hyx; rw [Pi.single_eq_of_ne hyx, LinearMap.map_zero₂]
+    · intro h; exact absurd (Finset.mem_univ x) h
+
+theorem finite_binaryForm : Module.Finite ℂ (Vn n) := by
+  classical
+  rw [Module.Finite.iff_fg, show (BinaryForm ℂ n : Submodule ℂ (MvPolynomial (Fin 2) ℂ)) =
+    MvPolynomial.homogeneousSubmodule (Fin 2) ℂ n from rfl,
+    MvPolynomial.homogeneousSubmodule_eq_finsupp_supported,
+    AddMonoidAlgebra.supported_eq_span_single]
+  refine Submodule.fg_span (Set.Finite.image _ ?_)
+  refine Set.Finite.subset (Set.Finite.image (fun i : ℕ => Finsupp.single (0 : Fin 2) i +
+    Finsupp.single 1 (n - i)) (Set.finite_Iic n)) ?_
+  intro d hd
+  have hsum : d 0 + d 1 = n := by
+    have : d.degree = n := hd
+    rw [← this, Finsupp.degree_eq_sum, Fin.sum_univ_two]
+  refine ⟨d 0, (by change d 0 ≤ n; omega), ?_⟩
+  ext j; fin_cases j
+  · simp
+  · simp; omega
+
+include hBinv hBsymm hBnd in
+theorem sup_range_eq_top (hn0 : n ≠ 0) :
+    LinearMap.range (indRep N n ⟨ModularGroup.S, Subgroup.mem_top _⟩ - 1)
+      ⊔ LinearMap.range (indRep N n ⟨ModularGroup.S * ModularGroup.T, Subgroup.mem_top _⟩ - 1) = ⊤
+        := by
+  set W := indRep N n with hW
+  set eS : ↥Gt := ⟨ModularGroup.S, Subgroup.mem_top _⟩
+  set eU : ↥Gt := ⟨ModularGroup.S * ModularGroup.T, Subgroup.mem_top _⟩
+  set M := LinearMap.range (W eS - 1) ⊔ LinearMap.range (W eU - 1) with hM
+  have : Module.Finite ℂ (Vn n) := finite_binaryForm
+  have hrefl := BW_isRefl (N := N) B hBsymm
+  have hnd := BW_nondegenerate (N := N) B hBsymm hBnd
+  have horth : (BW (N := N) B).orthogonal M = ⊥ := by
+    rw [eq_bot_iff]
+    intro f' hf'
+    rw [Submodule.mem_bot]
+    have hfix : ∀ g : ↥Gt, LinearMap.range (W g - 1) ≤ M → W g f' = f' := by
+      intro g hg
+      have key : ∀ a, BW (N := N) B a (W g⁻¹ f' - f') = 0 := by
+        intro a
+        have h1 : BW (N := N) B (W g a - a) f' = 0 := hf' _ (hg ⟨a, rfl⟩)
+        rw [map_sub, LinearMap.sub_apply, sub_eq_zero] at h1
+        have e1 := BW_inv (N := N) B hBinv g a (W g⁻¹ f')
+        have e2 : W g (W g⁻¹ f') = f' := by
+          rw [← Module.End.mul_apply, ← map_mul, mul_inv_cancel, map_one, Module.End.one_apply]
+        rw [e2] at e1
+        rw [map_sub, ← e1, h1, sub_self]
+      have h0 : W g⁻¹ f' - f' = 0 := hnd.2 _ key
+      rw [sub_eq_zero] at h0
+      have h3 := congrArg (W g) h0
+      rw [← Module.End.mul_apply, ← map_mul, mul_inv_cancel, map_one, Module.End.one_apply] at h3
+      exact h3.symm
+    have hS : W eS f' = f' := hfix eS le_sup_left
+    have hU : W eU f' = f' := hfix eU le_sup_right
+    have hT : W ⟨ModularGroup.T, Subgroup.mem_top _⟩ f' = f' := by
+      have e : (⟨ModularGroup.T, Subgroup.mem_top _⟩ : ↥Gt) = eS⁻¹ * eU := by
+        apply Subtype.ext; change ModularGroup.T = ModularGroup.S⁻¹ * (ModularGroup.S *
+          ModularGroup.T); group
+      have hSinv : W eS⁻¹ f' = f' := by
+        conv_lhs => rw [← hS]
+        rw [← Module.End.mul_apply, ← map_mul, inv_mul_cancel, map_one, Module.End.one_apply]
+      rw [e, map_mul, Module.End.mul_apply, hU, hSinv]
+    apply indRep_invariants hn0
+    intro g
+    have hg : (g : SL(2, ℤ)) ∈ Subgroup.closure ({ModularGroup.S, ModularGroup.T} : Set SL(2, ℤ)) :=
+      by
+      rw [SpecialLinearGroup.SL2Z_generators]; trivial
+    have keyc : ∀ x (hx : x ∈ Subgroup.closure ({ModularGroup.S, ModularGroup.T} : Set SL(2, ℤ))), W
+      ⟨x, Subgroup.mem_top _⟩ f' = f' :=
+      by
+      intro x hx
+      induction hx using Subgroup.closure_induction with
+      | mem x hx =>
+        rcases hx with rfl | rfl
+        · exact hS
+        · exact hT
+      | one => rw [show (⟨1, Subgroup.mem_top _⟩ : ↥Gt) = 1 from rfl, map_one, Module.End.one_apply]
+      | mul x y _ _ hx hy =>
+        rw [show (⟨x * y, Subgroup.mem_top _⟩ : ↥Gt) = ⟨x, Subgroup.mem_top _⟩ * ⟨y,
+          Subgroup.mem_top _⟩ from rfl,
+          map_mul, Module.End.mul_apply, hy, hx]
+      | inv x _ hx =>
+        rw [show (⟨x⁻¹, Subgroup.mem_top _⟩ : ↥Gt) = ⟨x, Subgroup.mem_top _⟩⁻¹ from rfl]
+        conv_lhs => rw [← hx]
+        rw [← Module.End.mul_apply, ← map_mul, inv_mul_cancel, map_one, Module.End.one_apply]
+    exact keyc g hg
+  have := LinearMap.BilinForm.orthogonal_orthogonal hnd hrefl M
+  rw [horth] at this
+  rw [← this, eq_top_iff]
+  intro f _ m hm
+  rw [(Submodule.mem_bot ℂ).mp hm]
+  simp
+
+end Coinv
+end HeckeEis.UH3Sol
+end
+
+open scoped MatrixGroups in
+theorem solution (N : ℕ) [NeZero N] (n : ℕ) (hn : Even n) (hn0 : n ≠ 0) :
+    ∃ W : Representation ℂ (⊤ : Subgroup SL(2, ℤ)) (SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N →
+      ↥(HeckeEis.BinaryForm ℂ n)),
+      (∀ (g : (⊤ : Subgroup SL(2, ℤ))) (f : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N →
+        ↥(HeckeEis.BinaryForm ℂ n)) (x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N),
+        W g f x = HeckeEis.binaryFormRepSL ℂ n (g : SL(2, ℤ)) (f (((g : SL(2, ℤ))⁻¹) • x))) ∧
+      W ⟨-1, Subgroup.mem_top _⟩ = LinearMap.id ∧
+      (∀ f : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n), (∀ g : (⊤ :
+        Subgroup SL(2, ℤ)), W g f = f) → f = 0) ∧
+      (∀ f : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n), ∃ a b : SL(2, ℤ) ⧸
+        CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n),
+        f = (W ⟨ModularGroup.S, Subgroup.mem_top _⟩ a - a) + (W ⟨ModularGroup.S * ModularGroup.T,
+          Subgroup.mem_top _⟩ b - b)) := by
+  obtain ⟨B, hBinv, hBsymm, hBnd, -⟩ := HeckeEis.exists_pairing_binaryForm_linePow n
+  refine ⟨HeckeEis.UH3Sol.indRep N n, fun g f x => rfl, HeckeEis.UH3Sol.indRep_neg_one hn,
+    HeckeEis.UH3Sol.indRep_invariants hn0, fun f => ?_⟩
+  have htop := HeckeEis.UH3Sol.sup_range_eq_top (N := N) B hBinv hBsymm hBnd hn0
+  have hf : f ∈ (⊤ : Submodule ℂ _) := trivial
+  rw [← htop, Submodule.mem_sup] at hf
+  obtain ⟨y, ⟨a, rfl⟩, z, ⟨b, rfl⟩, hyz⟩ := hf
+  exact ⟨a, b, by rw [← hyz]; rfl⟩
+
+end S_HeckeEis_exists_induced_binaryFormRepSL_top
+end P2MW
+export P2MW.S_HeckeEis_exists_induced_binaryFormRepSL_top (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.exists_induced_binaryFormRepSL_top (N : ℕ) [NeZero N] (n : ℕ) (hn : Even n)
+    (hn0 : n ≠ 0) :
+    ∃ W : Representation ℂ (⊤ : Subgroup SL(2, ℤ)) (SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N →
+      ↥(HeckeEis.BinaryForm ℂ n)),
+      (∀ (g : (⊤ : Subgroup SL(2, ℤ))) (f : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N →
+        ↥(HeckeEis.BinaryForm ℂ n)) (x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N),
+        W g f x = HeckeEis.binaryFormRepSL ℂ n (g : SL(2, ℤ)) (f (((g : SL(2, ℤ))⁻¹) • x))) ∧
+      W ⟨-1, Subgroup.mem_top _⟩ = LinearMap.id ∧
+      (∀ f : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n), (∀ g : (⊤ :
+        Subgroup SL(2, ℤ)), W g f = f) → f = 0) ∧
+      (∀ f : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n), ∃ a b : SL(2, ℤ) ⧸
+        CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n),
+        f = (W ⟨ModularGroup.S, Subgroup.mem_top _⟩ a - a) + (W ⟨ModularGroup.S * ModularGroup.T,
+          Subgroup.mem_top _⟩ b - b)) :=
+  solution N n hn hn0
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_isEichlerIntegral.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_isEichlerIntegral.lean
new file mode 100644
index 0000000000..13a60d385e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_isEichlerIntegral.lean
@@ -0,0 +1,178 @@
+/-
+Based on Prove2Me node HeckeEis.exists_isEichlerIntegral
+(5099303c-73dd-5949-90e0-b6c69197a54e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 25a8e27a-56dc-5fce-bf8e-304fe712d843
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Manifold
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import Mathlib.Analysis.Calculus.Deriv.Polynomial
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Complex_exists_hasDerivAt_of_starConvex
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of Eichler integrals for holomorphic functions on H
+
+Theorem statement: `HeckeEis.exists_isEichlerIntegral` (`5099303c-73dd-5949-90e0-b6c69197a54e`), by
+Claude, 2026-09-05.
+
+Proof: submission `25a8e27a-56dc-5fce-bf8e-304fe712d843`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $n$ and a function $f$ on the upper half-plane $\mathfrak H$ with values in
+$\mathbb C$ which is holomorphic in the sense of being $\mathrm{MDifferentiable}$ for the model with
+corners $\mathcal I(\mathbb C)$ on source and target. The assertion is that there exists a function
+$F$ on $\mathfrak H$ with values in the submodule [`HeckeEis.BinaryForm ℂ
+n`](def/HeckeEis_BinaryFormRep.html#L25) of $\mathbb C$-valued polynomials in two variables $X_0,
+X_1$ which are homogeneous of degree $n$, such that [`HeckeEis.IsEichlerIntegral n f
+F`](def/HeckeEis_EichlerIntegral.html#L105) holds. Unfolded, the latter says: for every exponent
+vector $d : \mathrm{Fin}\,2 \to_0 \mathbb N$ and every $\tau \in \mathfrak H$, the complex function
+$z \mapsto \operatorname{coeff}_d\bigl(F(\mathrm{ofComplex}\,z)\bigr)$, defined on all of $\mathbb
+C$ via the retraction $\mathrm{ofComplex} : \mathbb C \to \mathfrak H$, has derivative at the point
+$\tau$ equal to $f(\tau)\cdot \operatorname{coeff}_d\bigl((\tau X_0 + X_1)^n\bigr)$, where $(\tau
+X_0+X_1)^n$ is [`HeckeEis.linePow n τ`](def/HeckeEis_EichlerIntegral.html#L22). Thus $F$ is,
+coefficient by coefficient, a primitive of the $\operatorname{Sym}^n$-valued function $\tau \mapsto
+f(\tau)(\tau X_0+X_1)^n$, with the derivative condition recorded in the strong form of `HasDerivAt`
+at every point of $\mathfrak H$.
+
+This is the existence statement for Eichler integrals in weight $n+2$: a holomorphic function on
+$\mathfrak H$ admits a $\operatorname{Sym}^n(\mathbb C^2)$-valued primitive of $f(\tau)(\tau
+X_0+X_1)^n$. It is the purely analytic input to the Eichler–Shimura construction, used downstream to
+attach (parabolic) cocycles to modular forms and to compare Hecke actions on cohomology with Hecke
+actions on forms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_exists_isEichlerIntegral.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_exists_isEichlerIntegral
+
+open scoped Manifold MatrixGroups
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm isHomogeneous_linePow linePow coe_linePow IsEichlerIntegral"
+p2m_open "HeckeEis"
+
+open UpperHalfPlane MvPolynomial
+open scoped Manifold Polynomial
+
+namespace EichlerIntegralExistence
+
+variable (n : ℕ)
+
+def degExps : Finset (Fin 2 →₀ ℕ) :=
+  (Finset.range (n + 1)).image fun k => Finsupp.single 0 k + Finsupp.single 1 (n - k)
+
+theorem mem_degExps_iff (d : Fin 2 →₀ ℕ) : d ∈ degExps n ↔ d.degree = n := by
+  rw [Finsupp.degree_eq_sum, Fin.sum_univ_two]
+  simp only [degExps, Finset.mem_image, Finset.mem_range]
+  constructor
+  · rintro ⟨k, hk, rfl⟩
+    simp
+    omega
+  · intro h
+    refine ⟨d 0, by omega, ?_⟩
+    ext i
+    fin_cases i
+    · simp
+    · simp
+      omega
+
+def linePowPoly : MvPolynomial (Fin 2) ℂ[X] :=
+  (C Polynomial.X * X 0 + X 1) ^ n
+
+theorem coeff_linePow_eq_eval (d : Fin 2 →₀ ℕ) (z : ℂ) :
+    AddMonoidAlgebra.coeff ((C z * X 0 + X 1 : MvPolynomial (Fin 2) ℂ) ^ n) d
+      = Polynomial.eval z (AddMonoidAlgebra.coeff (linePowPoly n) d) := by
+  have h : ((C z * X 0 + X 1 : MvPolynomial (Fin 2) ℂ) ^ n)
+      = MvPolynomial.map (Polynomial.evalRingHom z) (linePowPoly n) := by
+    simp [linePowPoly, MvPolynomial.map_X, MvPolynomial.map_C]
+  rw [h, MvPolynomial.coeff_map]
+  rfl
+
+def assemble (g : (Fin 2 →₀ ℕ) → ℂ → ℂ) (τ : ℍ) : ↥(BinaryForm ℂ n) :=
+  ⟨∑ d ∈ degExps n, monomial d (g d (τ : ℂ)), Submodule.sum_mem _ fun d hd =>
+    (mem_homogeneousSubmodule n _).mpr (isHomogeneous_monomial _ ((mem_degExps_iff n d).mp hd))⟩
+
+theorem coeff_assemble (g : (Fin 2 →₀ ℕ) → ℂ → ℂ) (τ : ℍ) (d : Fin 2 →₀ ℕ) :
+    AddMonoidAlgebra.coeff (assemble n g τ : MvPolynomial (Fin 2) ℂ) d = if d ∈ degExps n then g d
+      (τ : ℂ) else 0 := by
+  change AddMonoidAlgebra.coeff (∑ e ∈ degExps n, monomial e (g e (τ : ℂ))) d = _
+  simp only [coeff_sum, coeff_monomial, Finset.sum_ite_eq']
+
+end EichlerIntegralExistence
+
+end HeckeEis
+
+open _root_.HeckeEis _root_.P2MW.S_HeckeEis_exists_isEichlerIntegral.HeckeEis
+  HeckeEis.EichlerIntegralExistence UpperHalfPlane MvPolynomial in
+theorem solution (n : ℕ) {f : UpperHalfPlane → ℂ}
+    (hf : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) :
+    ∃ F : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n), HeckeEis.IsEichlerIntegral n f F := by
+  let U : Set ℂ := {z | 0 < z.im}
+  have hU : IsOpen U := isOpen_upperHalfPlaneSet
+  have hI : ((I : ℍ) : ℂ) ∈ U := (I : ℍ).im_pos
+  have hstar : StarConvex ℝ ((I : ℍ) : ℂ) U := (convex_halfSpace_im_gt 0).starConvex hI
+  have hfd : DifferentiableOn ℂ (f ∘ ofComplex) U := UpperHalfPlane.mdifferentiable_iff.mp hf
+  have key : ∀ d : Fin 2 →₀ ℕ, ∃ g : ℂ → ℂ, ∀ z ∈ U,
+      HasDerivAt g ((f ∘ ofComplex) z * (AddMonoidAlgebra.coeff (linePowPoly n) d).eval z) z := by
+    intro d
+    obtain ⟨g, -, hg⟩ := Complex.exists_hasDerivAt_of_starConvex hU hI hstar
+      (hfd.mul (Polynomial.differentiable _).differentiableOn)
+    exact ⟨g, hg⟩
+  choose g hg using key
+  refine ⟨assemble n g, fun d τ => ?_⟩
+  simp only [coeff_assemble]
+  by_cases hd : d ∈ degExps n
+  · simp only [ite_eq_left hd]
+    have h2 : (f ∘ ofComplex) (τ : ℂ) * (AddMonoidAlgebra.coeff (linePowPoly n) d).eval (τ : ℂ)
+        = f τ * AddMonoidAlgebra.coeff ((linePow n (τ : ℂ) : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin
+          2) ℂ) d := by
+      rw [Function.comp_apply, ofComplex_apply, coe_linePow, coeff_linePow_eq_eval]
+    rw [← h2]
+    refine (hg d (τ : ℂ) τ.im_pos).congr_of_eventuallyEq ?_
+    filter_upwards [hU.mem_nhds τ.im_pos] with z hz
+    rw [ofComplex_apply_of_im_pos hz]
+  · simp only [ite_eq_right hd]
+    have h0 : AddMonoidAlgebra.coeff ((linePow n (τ : ℂ) : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2)
+      ℂ) d = 0 :=
+      (isHomogeneous_linePow n τ).coeff_eq_zero (by rwa [mem_degExps_iff] at hd)
+    rw [h0, mul_zero]
+    exact hasDerivAt_const _ _
+
+end
+
+end S_HeckeEis_exists_isEichlerIntegral
+end P2MW
+export P2MW.S_HeckeEis_exists_isEichlerIntegral (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Manifold MatrixGroups
+theorem HeckeEis.exists_isEichlerIntegral (n : ℕ) {f : UpperHalfPlane → ℂ}
+    (hf : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) :
+    ∃ F : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n), HeckeEis.IsEichlerIntegral n f F :=
+  solution n hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_isEichlerIntegral_isParabolicCocycle.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_isEichlerIntegral_isParabolicCocycle.lean
new file mode 100644
index 0000000000..9ec6766fd7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_isEichlerIntegral_isParabolicCocycle.lean
@@ -0,0 +1,106 @@
+/-
+Based on Prove2Me node HeckeEis.exists_isEichlerIntegral_isParabolicCocycle
+(a51d2af1-1c2b-53cc-b2bc-fe0a19f583c2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8cc46642-0fa3-54b4-9912-76cccdb56d44
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_isEichlerIntegral
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_isEquivariantPrimitiveWith_of_isEichlerIntegral
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_isParabolicCocycle_cocycle_of_isEichlerIntegral
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of a parabolic Eichler integral for Γ₀(N) cusp forms
+
+Theorem statement: `HeckeEis.exists_isEichlerIntegral_isParabolicCocycle`
+(`a51d2af1-1c2b-53cc-b2bc-fe0a19f583c2`), by Claude, 2026-09-05.
+
+Proof: submission `8cc46642-0fa3-54b4-9912-76cccdb56d44`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N\ge 1$ and $n\ge 0$ be natural numbers and let $f$ be a cusp form of weight $n+2$ for
+$\Gamma_0(N)$. Write $\mathrm{BinaryForm}\,\mathbb{C}\,n$ for the submodule of homogeneous
+polynomials of degree $n$ in $\mathbb{C}[X_0,X_1]$, and let $\rho$ be the representation
+`binaryFormRepSL` of $\mathrm{SL}_2(\mathbb{Z})$ on it by the substitution $X_j\mapsto\sum_i
+g_{ij}X_i$, restricted along the inclusion of $\Gamma_0(N)$. The assertion is that there is a
+function $F$ from the upper half-plane to $\mathrm{BinaryForm}\,\mathbb{C}\,n$ which is an Eichler
+integral of $f$ in the sense that for every exponent vector $d$ and every $\tau\in\mathfrak{H}$ the
+coefficient function $z\mapsto \mathrm{coeff}_d\,F(z)$ is complex differentiable at $\tau$ with
+derivative $f(\tau)\cdot\mathrm{coeff}_d\big((\tau X_0+X_1)^n\big)$; that $F$ is an equivariant
+primitive for $\rho$, i.e. for each $\gamma\in\Gamma_0(N)$ the difference
+$F(\gamma\tau)-\rho(\gamma)F(\tau)$ is independent of $\tau$; and that the resulting cocycle
+$z(\gamma)=F(\gamma\cdot i)-\rho(\gamma)F(i)$ is parabolic, meaning
+$z(\gamma)\in\mathrm{range}(\rho(\gamma)-1)$ for every $\gamma\in\Gamma_0(N)$ with
+$(\operatorname{tr}\gamma)^2=4$. In Lean the equivariance is existentially quantified as a proof
+term $hF$ whose associated cocycle is required to be parabolic; the definition of the cocycle
+ignores that proof argument.
+
+This is the existence statement underlying the Eichler–Shimura construction: every cusp form of
+weight $n+2$ on $\Gamma_0(N)$ has an Eichler integral whose period cocycle is a parabolic
+$1$-cocycle with values in the space of binary forms of degree $n$. It is what guarantees that the
+Eichler–Shimura map sends $f$ to the class of its period cocycle in parabolic cohomology, and it is
+used in the lemmas describing that map's additivity and its compatibility with the Hecke operators
+$T_\ell$ and $U_\ell$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_exists_isEichlerIntegral_isParabolicCocycle.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_exists_isEichlerIntegral_isParabolicCocycle
+
+open scoped Manifold MatrixGroups ModularForm
+
+theorem solution (N n : ℕ) [NeZero N]
+    (f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2)) :
+    ∃ F : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n), HeckeEis.IsEichlerIntegral n f F ∧
+      ∃ hF : HeckeEis.IsEquivariantPrimitiveWith
+          ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype) F,
+        HeckeEis.IsParabolicCocycle
+          ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype) hF.cocycle :=
+            by
+  obtain ⟨F, hEI⟩ :=
+    HeckeEis.exists_isEichlerIntegral n (f := (f : UpperHalfPlane → ℂ)) (CuspFormClass.holo f)
+  have hF : HeckeEis.IsEquivariantPrimitiveWith
+      ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype) F :=
+    HeckeEis.isEquivariantPrimitiveWith_of_isEichlerIntegral hEI
+      (fun γ hγ => SlashInvariantFormClass.slash_action_eq f _ (Subgroup.mem_map_of_mem _ hγ))
+  exact ⟨F, hEI, hF, HeckeEis.isParabolicCocycle_cocycle_of_isEichlerIntegral N n f hEI hF⟩
+
+end S_HeckeEis_exists_isEichlerIntegral_isParabolicCocycle
+end P2MW
+export P2MW.S_HeckeEis_exists_isEichlerIntegral_isParabolicCocycle (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Manifold MatrixGroups
+theorem HeckeEis.exists_isEichlerIntegral_isParabolicCocycle (N n : ℕ) [NeZero N]
+    (f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2)) :
+    ∃ F : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n), HeckeEis.IsEichlerIntegral n f F ∧
+      ∃ hF : HeckeEis.IsEquivariantPrimitiveWith
+          ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype) F,
+        HeckeEis.IsParabolicCocycle
+          ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype) hF.cocycle :=
+  solution N n f
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_ne_zero_smul_eq_coeffH1par_map_int_rat.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_ne_zero_smul_eq_coeffH1par_map_int_rat.lean
new file mode 100644
index 0000000000..ff5d0aa72f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_ne_zero_smul_eq_coeffH1par_map_int_rat.lean
@@ -0,0 +1,979 @@
+/-
+Based on Prove2Me node HeckeEis.exists_ne_zero_smul_eq_coeffH1par_map_int_rat
+(5d43ce16-6cb1-5176-9b4c-6033bc24cf48) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 63b26fbd-fbf2-50ab-b899-b0189a637b4e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+
+import Mathlib.Algebra.CharP.Invertible
+import Mathlib.Algebra.MvPolynomial.Monad
+import Mathlib.GroupTheory.Schreier
+import Mathlib.LinearAlgebra.Matrix.FixedDetMatrices
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_binaryFormRepSL_neg_one_apply
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularGroup_exists_eq_conj_T_zpow_of_trace_sq_eq_four
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Rational parabolic classes have nonzero integral multiples
+
+Theorem statement: `HeckeEis.exists_ne_zero_smul_eq_coeffH1par_map_int_rat`
+(`5d43ce16-6cb1-5176-9b4c-6033bc24cf48`), by Claude, 2026-09-05.
+
+Proof: submission `63b26fbd-fbf2-50ab-b899-b0189a637b4e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix natural numbers $n$ and $N$ with $N \neq 0$, and write $\Gamma_0(N) \le
+\mathrm{SL}_2(\mathbb{Z})$. For a commutative ring $K$, let $\rho_K$ denote the representation
+[`HeckeEis.binaryFormRepSL K n`](def/HeckeEis_BinaryFormRep.html#L61) of $\mathrm{SL}_2(\mathbb{Z})$
+on the degree-$n$ homogeneous part of $K[X_0,X_1]$, where a matrix $M$ acts by the substitution $X_j
+\mapsto \sum_i M_{ij} X_i$, restricted along the inclusion of $\Gamma_0(N)$; and let
+$H^1_{\mathrm{par}}(\Gamma_0(N), \rho_K)$ be
+[`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100) of that representation, namely the
+quotient of the $K$-module of cocycles $z \colon \Gamma_0(N) \to \rho_K$ (so $z(gh) = z(g) +
+\rho_K(g) z(h)$) satisfying $z(\gamma) \in \mathrm{im}(\rho_K(\gamma) - 1)$ for every $\gamma$ whose
+matrix has trace squared equal to $4$, by the submodule of those which are coboundaries. Let $\Phi$
+be an additive homomorphism from $H^1_{\mathrm{par}}(\Gamma_0(N), \rho_{\mathbb{Z}})$ to
+$H^1_{\mathrm{par}}(\Gamma_0(N), \rho_{\mathbb{Q}})$ which is assumed to be induced by coefficient
+extension at cochain level: for every integral parabolic cocycle $z$ there is a rational parabolic
+cocycle $w$ with $w(g)$ the image of $z(g)$ under the coefficient map $\mathbb{Z} \to \mathbb{Q}$ on
+polynomials, for all $g \in \Gamma_0(N)$, and with $\Phi$ of the class of $z$ equal to the class of
+$w$. Then for every class $x$ in $H^1_{\mathrm{par}}(\Gamma_0(N), \rho_{\mathbb{Q}})$ there exist a
+nonzero integer $m$ and a class $y$ in $H^1_{\mathrm{par}}(\Gamma_0(N), \rho_{\mathbb{Z}})$ with
+$\Phi(y) = m \cdot x$.
+
+This says that the integral parabolic cohomology of $\Gamma_0(N)$ with symmetric-power coefficients
+spans the rational one, i.e. that the image of $\Phi$ is of finite index in the sense that every
+rational class becomes integral after multiplication by a suitable nonzero integer. It is used in
+the construction of a basis of $H^1_{\mathrm{par}}$ over $\mathbb{C}$ coming from the integral
+classes, in
+[`HeckeEis.exists_basis_coeffH1par_int_complex`]
+(thm.html#HeckeEis.exists_basis_coeffH1par_int_complex).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_exists_ne_zero_smul_eq_coeffH1par_map_int_rat.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_exists_ne_zero_smul_eq_coeffH1par_map_int_rat
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  binaryFormRepSL_apply_coe coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff \
+  IsParabolicCocycle coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective \
+  coeffH1parMk_eq_zero_iff binaryFormRepSL_neg_one_apply"
+namespace GenAux
+p2m_open "HeckeEis"
+
+variable {G : Type*} [Group G] {K : Type*} [CommRing K] {V : Type*} [AddCommGroup V] [Module K V]
+
+theorem coeffCocycles_apply_one {ρ : Representation K G V} {z : G → V} (hz : z ∈ coeffCocycles ρ) :
+    z 1 = 0 := by
+  have h := hz 1 1
+  rw [mul_one, map_one, Module.End.one_apply] at h
+  have : z 1 + z 1 = z 1 + 0 := by rw [add_zero]; exact h.symm
+  exact add_left_cancel this
+
+theorem coeffCocycles_apply_inv {ρ : Representation K G V} {z : G → V} (hz : z ∈ coeffCocycles ρ)
+    (g : G) :
+    z g⁻¹ = -(ρ g⁻¹ (z g)) := by
+  have h := hz g⁻¹ g
+  rw [inv_mul_cancel, coeffCocycles_apply_one hz] at h
+  exact eq_neg_of_add_eq_zero_left h.symm
+
+theorem mem_of_mem_coeffCocycles_of_closure_eq_top {ρ : Representation K G V} {z : G → V}
+    (hz : z ∈ coeffCocycles ρ)
+    (M : AddSubgroup V) (hM : ∀ (g : G) (v : V), v ∈ M → ρ g v ∈ M) {s : Set G}
+    (hs : Subgroup.closure s = ⊤)
+    (h : ∀ g ∈ s, z g ∈ M) (g : G) : z g ∈ M := by
+  let H : Subgroup G :=
+    { carrier := {g | z g ∈ M}
+      one_mem' := by
+        change z 1 ∈ M
+        rw [coeffCocycles_apply_one hz]; exact M.zero_mem
+      mul_mem' := by
+        intro a b ha hb
+        change z (a * b) ∈ M
+        rw [hz a b]
+        exact M.add_mem ha (hM a _ hb)
+      inv_mem' := by
+        intro a ha
+        change z a⁻¹ ∈ M
+        rw [coeffCocycles_apply_inv hz]
+        exact M.neg_mem (hM _ _ ha) }
+  have hle : (⊤ : Subgroup G) ≤ H := by
+    rw [← hs, Subgroup.closure_le]
+    exact h
+  exact hle (Subgroup.mem_top g)
+
+theorem coeffCocycles_eq_of_eqOn {ρ : Representation K G V} {z z' : G → V}
+    (hz : z ∈ coeffCocycles ρ) (hz' : z' ∈ coeffCocycles ρ)
+    {s : Set G} (hs : Subgroup.closure s = ⊤) (h : ∀ g ∈ s, z g = z' g) : z = z' := by
+  have hd : z - z' ∈ coeffCocycles ρ := Submodule.sub_mem _ hz hz'
+  funext g
+  have := mem_of_mem_coeffCocycles_of_closure_eq_top hd ⊥ (fun g v hv => by
+    rw [AddSubgroup.mem_bot] at hv ⊢; rw [hv, map_zero]) hs (fun g hg => by
+    rw [AddSubgroup.mem_bot, Pi.sub_apply, h g hg, sub_self]) g
+  rw [AddSubgroup.mem_bot, Pi.sub_apply] at this
+  exact sub_eq_zero.mp this
+
+end HeckeEis.GenAux
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  binaryFormRepSL_apply_coe coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff \
+  IsParabolicCocycle coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective \
+  coeffH1parMk_eq_zero_iff binaryFormRepSL_neg_one_apply"
+namespace CoeffMapAux
+p2m_open "HeckeEis"
+
+open MvPolynomial
+open scoped MatrixGroups
+
+variable {R R' : Type*} [CommRing R] [CommRing R']
+
+theorem binarySubst_eq_bind₁ (S : Type*) [CommRing S] (M : Matrix (Fin 2) (Fin 2) ℤ)
+    (P : MvPolynomial (Fin 2) S) :
+    binarySubst S M P = bind₁ (fun j => ∑ i : Fin 2, C ((M i j : ℤ) : S) * X i) P := by
+  rw [binarySubst, aeval_eq_bind₁]
+
+theorem map_binarySubst_int (φ : ℤ →+* R) (M : Matrix (Fin 2) (Fin 2) ℤ)
+    (P : MvPolynomial (Fin 2) ℤ) :
+    MvPolynomial.map φ (binarySubst ℤ M P) = binarySubst R M (MvPolynomial.map φ P) := by
+  have key : (MvPolynomial.map φ).comp (binarySubst ℤ M : MvPolynomial (Fin 2) ℤ →ₐ[ℤ] MvPolynomial
+    (Fin 2) ℤ).toRingHom
+      = (binarySubst R M : MvPolynomial (Fin 2) R →ₐ[R] MvPolynomial (Fin 2) R).toRingHom.comp
+        (MvPolynomial.map φ) :=
+    MvPolynomial.ringHom_ext (fun a => by simp []) (fun j => by simp [binarySubst_X])
+  exact RingHom.congr_fun key P
+
+def substCoeff (M : Matrix (Fin 2) (Fin 2) ℤ) (d d' : Fin 2 →₀ ℕ) : ℤ :=
+  AddMonoidAlgebra.coeff (binarySubst ℤ M (monomial d' 1)) d
+
+theorem binarySubst_monomial_one (M : Matrix (Fin 2) (Fin 2) ℤ) (d' : Fin 2 →₀ ℕ) :
+    binarySubst R M (monomial d' 1) = MvPolynomial.map (Int.castRingHom R) (binarySubst ℤ M
+      (monomial d' 1)) := by
+  rw [map_binarySubst_int, map_monomial, (Int.castRingHom R).map_one]
+
+theorem coeff_binarySubst (M : Matrix (Fin 2) (Fin 2) ℤ) (P : MvPolynomial (Fin 2) R)
+    (d : Fin 2 →₀ ℕ) :
+    AddMonoidAlgebra.coeff (binarySubst R M P) d = ∑ d' ∈ P.support, (substCoeff M d d' : R) *
+      AddMonoidAlgebra.coeff P d' := by
+  conv_lhs => rw [P.as_sum, map_sum, coeff_sum]
+  refine Finset.sum_congr rfl fun d' _ => ?_
+  rw [show monomial d' (AddMonoidAlgebra.coeff P d') = C (AddMonoidAlgebra.coeff P d') * monomial d'
+    1 by
+    rw [C_mul_monomial, mul_one], map_mul, binarySubst_C,
+    coeff_C_mul, binarySubst_monomial_one, coeff_map, substCoeff, mul_comm]
+  rfl
+
+variable (f : R →+ R')
+
+def pushCoeff (P : MvPolynomial (Fin 2) R) : MvPolynomial (Fin 2) R' :=
+  ∑ d ∈ P.support, monomial d (f (AddMonoidAlgebra.coeff P d))
+
+@[scoped simp] theorem coeff_pushCoeff (P : MvPolynomial (Fin 2) R) (d : Fin 2 →₀ ℕ) :
+    AddMonoidAlgebra.coeff (pushCoeff f P) d = f (AddMonoidAlgebra.coeff P d) := by
+  classical
+  rw [pushCoeff, coeff_sum]
+  simp only [coeff_monomial]
+  rw [Finset.sum_ite_eq']
+  split_ifs with h
+  · rfl
+  · rw [notMem_support_iff.mp h, map_zero]
+
+theorem support_pushCoeff (P : MvPolynomial (Fin 2) R) : (pushCoeff f P).support ⊆ P.support := by
+  intro d hd
+  rw [mem_support_iff, coeff_pushCoeff] at hd
+  rw [mem_support_iff]
+  intro h; exact hd (by rw [h, map_zero])
+
+theorem pushCoeff_mem (n : ℕ) {P : MvPolynomial (Fin 2) R} (hP : P ∈ BinaryForm R n) :
+    pushCoeff f P ∈ BinaryForm R' n := by
+  rw [mem_homogeneousSubmodule] at hP ⊢
+  intro d hd
+  exact hP (mem_support_iff.mp (support_pushCoeff f P (mem_support_iff.mpr hd)))
+
+theorem pushCoeff_add (P Q : MvPolynomial (Fin 2) R) :
+    pushCoeff f (P + Q) = pushCoeff f P + pushCoeff f Q := by
+  ext d; simp
+
+theorem pushCoeff_sub (P Q : MvPolynomial (Fin 2) R) :
+    pushCoeff f (P - Q) = pushCoeff f P - pushCoeff f Q := by
+  ext d; simp
+
+theorem pushCoeff_zero : pushCoeff f (0 : MvPolynomial (Fin 2) R) = 0 := by
+  ext d; simp
+
+theorem eq_pushCoeff_iff (P : MvPolynomial (Fin 2) R) (Q : MvPolynomial (Fin 2) R') :
+    Q = pushCoeff f P ↔ ∀ d, AddMonoidAlgebra.coeff Q d = f (AddMonoidAlgebra.coeff P d) := by
+  constructor
+  · rintro rfl d; exact coeff_pushCoeff f P d
+  · intro h; ext d; rw [h d, coeff_pushCoeff]
+
+theorem pushCoeff_binarySubst (M : Matrix (Fin 2) (Fin 2) ℤ) (P : MvPolynomial (Fin 2) R) :
+    pushCoeff f (binarySubst R M P) = binarySubst R' M (pushCoeff f P) := by
+  classical
+  ext d
+  rw [coeff_pushCoeff, coeff_binarySubst, coeff_binarySubst, map_sum]
+  rw [Finset.sum_subset (support_pushCoeff f P)]
+  · refine Finset.sum_congr rfl fun d' _ => ?_
+    rw [coeff_pushCoeff, ← zsmul_eq_mul, ← zsmul_eq_mul, map_zsmul]
+  · intro d' _ hd'
+    rw [notMem_support_iff.mp hd', mul_zero]
+
+def pushForm (n : ℕ) (P : ↥(BinaryForm R n)) :
+    ↥(BinaryForm R' n) := ⟨pushCoeff f P, pushCoeff_mem f n P.2⟩
+
+@[scoped simp] theorem coe_pushForm (n : ℕ) (P : ↥(BinaryForm R n)) :
+    ((pushForm f n P : ↥(BinaryForm R' n)) : MvPolynomial (Fin 2) R') = pushCoeff f P := rfl
+
+theorem pushForm_add (n : ℕ) (P Q : ↥(BinaryForm R n)) :
+    pushForm f n (P + Q) = pushForm f n P + pushForm f n Q :=
+  Subtype.ext (by simp [pushCoeff_add])
+
+theorem pushForm_sub (n : ℕ) (P Q : ↥(BinaryForm R n)) :
+    pushForm f n (P - Q) = pushForm f n P - pushForm f n Q :=
+  Subtype.ext (by simp [pushCoeff_sub])
+
+theorem pushForm_zero (n : ℕ) :
+    pushForm f n (0 : ↥(BinaryForm R n)) = 0 := Subtype.ext (by simp [pushCoeff_zero])
+
+theorem pushForm_binaryFormRepSL (n : ℕ) (g : SL(2, ℤ)) (P : ↥(BinaryForm R n)) :
+    pushForm f n (binaryFormRepSL R n g P) = binaryFormRepSL R' n g (pushForm f n P) :=
+  Subtype.ext (by simp [pushCoeff_binarySubst])
+
+section Cocycles
+
+variable {Γ : Subgroup SL(2, ℤ)} (n : ℕ)
+
+theorem pushForm_comp_mem_coeffCocycles {z : Γ → ↥(BinaryForm R n)}
+    (hz : z ∈ coeffCocycles ((binaryFormRepSL R n).comp Γ.subtype)) :
+    (fun g => pushForm f n (z g)) ∈ coeffCocycles ((binaryFormRepSL R' n).comp Γ.subtype) := by
+  intro g h
+  change pushForm f n (z (g * h)) = pushForm f n (z g) + binaryFormRepSL R' n ((g : Γ) : SL(2, ℤ))
+    (pushForm f n (z h))
+  rw [hz g h, pushForm_add, ← pushForm_binaryFormRepSL]
+  rfl
+
+theorem isParabolicCocycle_pushForm_comp {z : Γ → ↥(BinaryForm R n)}
+    (hz : IsParabolicCocycle ((binaryFormRepSL R n).comp Γ.subtype) z) :
+    IsParabolicCocycle ((binaryFormRepSL R' n).comp Γ.subtype) (fun g => pushForm f n (z g)) := by
+  intro γ hγ
+  obtain ⟨u, hu⟩ := hz γ hγ
+  refine ⟨pushForm f n u, ?_⟩
+  rw [LinearMap.sub_apply, Module.End.one_apply] at hu ⊢
+  change binaryFormRepSL R n (γ : SL(2, ℤ)) u - u = z γ at hu
+  change binaryFormRepSL R' n (γ : SL(2, ℤ)) (pushForm f n u) - pushForm f n u = pushForm f n (z γ)
+  rw [← hu, pushForm_sub, pushForm_binaryFormRepSL]
+
+theorem pushForm_comp_mem_coeffParabolicCocycles {z : Γ → ↥(BinaryForm R n)}
+    (hz : z ∈ coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype)) :
+    (fun g => pushForm f n (z g)) ∈ coeffParabolicCocycles ((binaryFormRepSL R' n).comp Γ.subtype)
+      :=
+  ⟨pushForm_comp_mem_coeffCocycles f n hz.1, isParabolicCocycle_pushForm_comp f n hz.2⟩
+
+theorem pushForm_comp_mem_coeffCoboundaries {z : Γ → ↥(BinaryForm R n)}
+    (hz : z ∈ coeffCoboundaries ((binaryFormRepSL R n).comp Γ.subtype)) :
+    (fun g => pushForm f n (z g)) ∈ coeffCoboundaries ((binaryFormRepSL R' n).comp Γ.subtype) := by
+  obtain ⟨v, hv⟩ := (mem_coeffCoboundaries_iff _ _).mp hz
+  rw [mem_coeffCoboundaries_iff]
+  refine ⟨pushForm f n v, funext fun g => ?_⟩
+  have h := congrFun hv g
+  change binaryFormRepSL R n (g : SL(2, ℤ)) v - v = z g at h
+  change binaryFormRepSL R' n (g : SL(2, ℤ)) (pushForm f n v) - pushForm f n v = pushForm f n (z g)
+  rw [← h, pushForm_sub, pushForm_binaryFormRepSL]
+
+def pushPar : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))
+    →+ ↥(coeffParabolicCocycles ((binaryFormRepSL R' n).comp Γ.subtype)) where
+  toFun z := ⟨fun g => pushForm f n (z.1 g), pushForm_comp_mem_coeffParabolicCocycles f n z.2⟩
+  map_zero' := by
+    apply Subtype.ext; funext g
+    change pushForm f n ((0 : Γ → ↥(BinaryForm R n)) g) = 0
+    rw [Pi.zero_apply, pushForm_zero]
+  map_add' z w := by
+    apply Subtype.ext; funext g
+    change pushForm f n (z.1 g + w.1 g) = pushForm f n (z.1 g) + pushForm f n (w.1 g)
+    rw [pushForm_add]
+
+@[scoped simp] theorem pushPar_apply_coe (z : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp
+  Γ.subtype))) (g : Γ) :
+    (((pushPar f n z).1 g : ↥(BinaryForm R' n)) : MvPolynomial (Fin 2) R') = pushCoeff f (z.1 g) :=
+      rfl
+
+theorem pushPar_apply_val (z : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype)))
+    (g : Γ) :
+    (pushPar f n z).1 g = pushForm f n (z.1 g) := rfl
+
+theorem mk_eq_mk_iff {S : Type*} [CommRing S]
+    (a b : ↥(coeffParabolicCocycles ((binaryFormRepSL S n).comp Γ.subtype))) :
+    coeffH1parMk _ a = coeffH1parMk _ b ↔
+      ((a - b : ↥(coeffParabolicCocycles ((binaryFormRepSL S n).comp Γ.subtype))).1
+        ∈ coeffCoboundaries ((binaryFormRepSL S n).comp Γ.subtype)) := by
+  rw [← sub_eq_zero, ← map_sub, coeffH1parMk_eq_zero_iff]
+
+theorem pushPar_sub (a b : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))) :
+    pushPar f n (a - b) = pushPar f n a - pushPar f n b :=
+  map_sub (pushPar f n) a b
+
+theorem mk_pushPar_congr {a b : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))}
+    (h : coeffH1parMk _ a = coeffH1parMk _ b) :
+    coeffH1parMk _ (pushPar f n a) = coeffH1parMk _ (pushPar f n b) := by
+  rw [mk_eq_mk_iff] at h ⊢
+  rw [← pushPar_sub]
+  exact pushForm_comp_mem_coeffCoboundaries f n h
+
+def pushH1par :
+    coeffH1par ((binaryFormRepSL R n).comp Γ.subtype) →+
+      coeffH1par ((binaryFormRepSL R' n).comp Γ.subtype) where
+  toFun x := coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) x))
+  map_zero' := by
+    have h0 : coeffH1parMk _ (Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp
+      Γ.subtype)) 0)
+        = coeffH1parMk _ (0 : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))) :=
+          by
+      rw [Function.surjInv_eq (coeffH1parMk_surjective _), map_zero]
+    change coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) 0)) = 0
+    rw [mk_pushPar_congr f n h0, map_zero, map_zero]
+  map_add' x y := by
+    have hxy : coeffH1parMk _ (Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp
+      Γ.subtype)) (x + y))
+        = coeffH1parMk _ (Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp
+          Γ.subtype)) x
+            + Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp Γ.subtype)) y)
+              := by
+      rw [map_add, Function.surjInv_eq (coeffH1parMk_surjective _), Function.surjInv_eq
+        (coeffH1parMk_surjective _),
+        Function.surjInv_eq (coeffH1parMk_surjective _)]
+    change coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) (x + y))) = _
+    rw [mk_pushPar_congr f n hxy, map_add, map_add]
+
+theorem pushH1par_mk (z : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))) :
+    pushH1par f n (coeffH1parMk _ z) = coeffH1parMk _ (pushPar f n z) := by
+  change coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) (coeffH1parMk _
+    z))) = _
+  apply mk_pushPar_congr
+  exact Function.surjInv_eq (coeffH1parMk_surjective _) _
+
+end Cocycles
+
+end HeckeEis.CoeffMapAux
+end
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  binaryFormRepSL_apply_coe coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff \
+  IsParabolicCocycle coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective \
+  coeffH1parMk_eq_zero_iff binaryFormRepSL_neg_one_apply"
+namespace CoeffMapAux
+p2m_open "HeckeEis"
+
+open MvPolynomial
+open scoped MatrixGroups
+
+theorem pushCoeff_ringHom_eq_map {R R' : Type*} [CommRing R] [CommRing R'] (φ : R →+* R')
+    (P : MvPolynomial (Fin 2) R) :
+    pushCoeff φ.toAddMonoidHom P = MvPolynomial.map φ P := by
+  ext d
+  rw [coeff_pushCoeff, coeff_map]
+  rfl
+
+end HeckeEis.CoeffMapAux
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  binaryFormRepSL_apply_coe coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff \
+  IsParabolicCocycle coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective \
+  coeffH1parMk_eq_zero_iff binaryFormRepSL_neg_one_apply"
+namespace RatAux
+p2m_open "HeckeEis"
+
+open MvPolynomial HeckeEis.CoeffMapAux
+open scoped MatrixGroups
+
+theorem exists_common_den (s : Finset ℚ) : ∃ D : ℤ, D ≠ 0 ∧ ∀ x ∈ s, ∃ m : ℤ, (D : ℚ) * x = m := by
+  classical
+  refine ⟨∏ y ∈ s, (y.den : ℤ), ?_, fun x hx => ?_⟩
+  · rw [Finset.prod_ne_zero_iff]; intro y _; exact_mod_cast y.den_nz
+  · refine ⟨(∏ y ∈ s.erase x, (y.den : ℤ)) * x.num, ?_⟩
+    rw [← Finset.mul_prod_erase s _ hx]
+    push_cast
+    rw [mul_comm ((x.den : ℚ)) _, mul_assoc, Rat.den_mul_eq_num]
+
+def IsInt (P : MvPolynomial (Fin 2) ℚ) : Prop := ∀ d, ∃ m : ℤ, AddMonoidAlgebra.coeff P d = m
+
+theorem IsInt.zero : IsInt 0 := fun d => ⟨0, by simp⟩
+theorem IsInt.add {P Q : MvPolynomial (Fin 2) ℚ} (hP : IsInt P) (hQ : IsInt Q) :
+    IsInt (P + Q) := fun d => by
+  obtain ⟨a, ha⟩ :=
+    hP d; obtain ⟨b, hb⟩ := hQ d; exact ⟨a + b, by
+      rw [AddMonoidAlgebra.coeff_add, Finsupp.add_apply, ha, hb]; push_cast; rfl⟩
+theorem IsInt.neg {P : MvPolynomial (Fin 2) ℚ} (hP : IsInt P) : IsInt (-P) := fun d => by
+  obtain ⟨a, ha⟩ := hP d; exact ⟨-a, by rw [coeff_neg, ha]; push_cast; rfl⟩
+theorem IsInt.zsmul {P : MvPolynomial (Fin 2) ℚ} (hP : IsInt P) (m : ℤ) :
+    IsInt (m • P) := fun d => by
+  obtain ⟨a, ha⟩ := hP d
+  exact ⟨m * a, by rw [← Int.cast_smul_eq_zsmul ℚ m P, coeff_smul, ha, smul_eq_mul]; push_cast; rfl⟩
+theorem IsInt.map (P : MvPolynomial (Fin 2) ℤ) :
+    IsInt (MvPolynomial.map (Int.castRingHom ℚ) P) := fun d =>
+  ⟨AddMonoidAlgebra.coeff P d, by rw [coeff_map]; rfl⟩
+
+theorem IsInt.binarySubst {P : MvPolynomial (Fin 2) ℚ} (hP : IsInt P) (M : Matrix (Fin 2) (Fin 2) ℤ)
+    :
+    IsInt (HeckeEis.binarySubst ℚ M P) := by
+  classical
+  intro d
+  rw [coeff_binarySubst]
+  choose m hm using hP
+  refine ⟨∑ d' ∈ P.support, substCoeff M d d' * m d', ?_⟩
+  push_cast
+  exact Finset.sum_congr rfl fun d' _ => by rw [hm d']
+
+def intModel (P : MvPolynomial (Fin 2) ℚ) :
+    MvPolynomial (Fin 2) ℤ := ∑ d ∈ P.support, monomial d (AddMonoidAlgebra.coeff P d).num
+
+theorem coeff_intModel (P : MvPolynomial (Fin 2) ℚ) (d : Fin 2 →₀ ℕ) :
+    AddMonoidAlgebra.coeff (intModel P) d = (AddMonoidAlgebra.coeff P d).num := by
+  classical
+  rw [intModel, coeff_sum]
+  simp only [coeff_monomial]
+  rw [Finset.sum_ite_eq']
+  split_ifs with h
+  · rfl
+  · rw [notMem_support_iff.mp h, Rat.num_zero]
+
+theorem map_intModel {P : MvPolynomial (Fin 2) ℚ} (hP : IsInt P) :
+    MvPolynomial.map (Int.castRingHom ℚ) (intModel P) = P := by
+  ext d
+  rw [coeff_map, coeff_intModel]
+  obtain ⟨m, hm⟩ := hP d
+  rw [hm, Rat.num_intCast]
+  rfl
+
+theorem intModel_mem (n : ℕ) {P : MvPolynomial (Fin 2) ℚ} (hP : P ∈ BinaryForm ℚ n) :
+    intModel P ∈ BinaryForm ℤ n := by
+  rw [mem_homogeneousSubmodule] at hP ⊢
+  intro d hd
+  rw [coeff_intModel] at hd
+  apply hP
+  intro h
+  exact hd (by rw [h, Rat.num_zero])
+
+theorem exists_isInt_zsmul (P : MvPolynomial (Fin 2) ℚ) : ∃ D : ℤ, D ≠ 0 ∧ IsInt (D • P) := by
+  classical
+  obtain ⟨D, hD, h⟩ := exists_common_den (P.support.image fun d => AddMonoidAlgebra.coeff P d)
+  refine ⟨D, hD, fun d => ?_⟩
+  by_cases hd : d ∈ P.support
+  · obtain ⟨m, hm⟩ := h _ (Finset.mem_image_of_mem _ hd)
+    exact ⟨m, by rw [← Int.cast_smul_eq_zsmul ℚ D, coeff_smul, smul_eq_mul, hm]⟩
+  · exact ⟨0, by rw [← Int.cast_smul_eq_zsmul ℚ D, coeff_smul, notMem_support_iff.mp hd,
+      smul_zero]; simp⟩
+
+theorem exists_isInt_zsmul_family {ι : Type*} (s : Finset ι) (P : ι → MvPolynomial (Fin 2) ℚ) :
+    ∃ D : ℤ, D ≠ 0 ∧ ∀ i ∈ s, IsInt (D • P i) := by
+  classical
+  obtain ⟨D, hD, h⟩ :=
+    exists_common_den (s.biUnion fun i => (P i).support.image fun d => AddMonoidAlgebra.coeff (P i)
+      d)
+  refine ⟨D, hD, fun i hi d => ?_⟩
+  by_cases hd : d ∈ (P i).support
+  · obtain ⟨m, hm⟩ := h _ (Finset.mem_biUnion.mpr ⟨i, hi, Finset.mem_image_of_mem _ hd⟩)
+    exact ⟨m, by rw [← Int.cast_smul_eq_zsmul ℚ D, coeff_smul, smul_eq_mul, hm]⟩
+  · exact ⟨0, by rw [← Int.cast_smul_eq_zsmul ℚ D, coeff_smul, notMem_support_iff.mp hd,
+      smul_zero]; simp⟩
+
+abbrev ιZQ : ℤ →+ ℚ := (Int.castRingHom ℚ).toAddMonoidHom
+
+theorem pushForm_ι_injective (n : ℕ) :
+    Function.Injective (pushForm ιZQ n : ↥(BinaryForm ℤ n) → ↥(BinaryForm ℚ n)) := by
+  intro P Q h
+  apply Subtype.ext
+  ext d
+  have :=
+    congrArg (fun S : ↥(BinaryForm ℚ n) => AddMonoidAlgebra.coeff (S : MvPolynomial (Fin 2) ℚ) d) h
+  simp only [coe_pushForm, coeff_pushCoeff] at this
+  exact Int.cast_injective this
+
+theorem coe_pushForm_ι (n : ℕ) (P : ↥(BinaryForm ℤ n)) :
+    ((pushForm ιZQ n P : ↥(BinaryForm ℚ n)) : MvPolynomial (Fin 2) ℚ) = MvPolynomial.map
+      (Int.castRingHom ℚ) P := by
+  rw [coe_pushForm]; exact pushCoeff_ringHom_eq_map _ _
+
+theorem exists_eq_pushForm_of_isInt (n : ℕ) {Q : ↥(BinaryForm ℚ n)}
+    (hQ : IsInt (Q : MvPolynomial (Fin 2) ℚ)) :
+    ∃ P : ↥(BinaryForm ℤ n), pushForm ιZQ n P = Q := by
+  refine ⟨⟨intModel Q, intModel_mem n Q.2⟩, Subtype.ext ?_⟩
+  rw [coe_pushForm_ι]
+  exact map_intModel hQ
+
+theorem pushForm_zsmul {R R' : Type*} [CommRing R] [CommRing R'] (f : R →+ R') (n : ℕ) (m : ℤ)
+    (P : ↥(BinaryForm R n)) :
+    pushForm f n (m • P) = m • pushForm f n P :=
+  map_zsmul (⟨⟨pushForm f n, pushForm_zero f n⟩, pushForm_add f n⟩ : ↥(BinaryForm R n) →+
+    ↥(BinaryForm R' n)) m P
+
+end HeckeEis.RatAux
+end
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  binaryFormRepSL_apply_coe coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff \
+  IsParabolicCocycle coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective \
+  coeffH1parMk_eq_zero_iff binaryFormRepSL_neg_one_apply"
+namespace ZQAux
+p2m_open "HeckeEis"
+
+open MvPolynomial HeckeEis.CoeffMapAux HeckeEis.RatAux HeckeEis.GenAux CongruenceSubgroup
+open scoped MatrixGroups
+
+theorem Gamma_le_Gamma0 (N : ℕ) :
+    Gamma N ≤ Gamma0 N := fun _ hA => Gamma0_mem.mpr (Gamma_mem.mp hA).2.2.1
+
+theorem neg_one_mem_Gamma0 (N : ℕ) : (-1 : SL(2, ℤ)) ∈ Gamma0 N := by rw [Gamma0_mem]; simp
+
+theorem conj_T_zpow_mem_Gamma0 (N : ℕ) (δ : SL(2, ℤ)) :
+    δ * ModularGroup.T ^ (N : ℤ) * δ⁻¹ ∈ Gamma0 N := by
+  have hTN : ModularGroup.T ^ (N : ℤ) ∈ Gamma N := by
+    simpa using CongruenceSubgroup.ModularGroup_T_pow_mem_Gamma (N : ℤ) (N : ℤ) dvd_rfl
+  exact Gamma_le_Gamma0 N ((CongruenceSubgroup.Gamma_normal N).conj_mem _ hTN δ)
+
+scoped instance instGroupFG_Gamma0 (N : ℕ) [NeZero N] : Group.FG (Gamma0 N) := by
+  have : (Gamma0 N).FiniteIndex := Subgroup.finiteIndex_of_le (Gamma_le_Gamma0 N)
+  have : Group.FG SL(2, ℤ) := Group.fg_iff.mpr
+    ⟨{ModularGroup.S, ModularGroup.T}, SpecialLinearGroup.SL2Z_generators,
+      (Set.finite_singleton _).insert _⟩
+  exact Subgroup.fg_of_index_ne_zero _
+
+theorem conj_T_zpow_eq (δ : SL(2, ℤ)) (h : ℤ) :
+    δ * ModularGroup.T ^ h * δ⁻¹ = MulAut.conj δ (ModularGroup.T ^ h) := by
+  rw [MulAut.conj_apply]
+
+theorem conj_T_zpow_add (δ : SL(2, ℤ)) (x y : ℤ) :
+    δ * ModularGroup.T ^ (x + y) * δ⁻¹ = (δ * ModularGroup.T ^ x * δ⁻¹) * (δ * ModularGroup.T ^ y *
+      δ⁻¹) := by
+  rw [zpow_add]; group
+
+theorem conj_T_zpow_mul (δ : SL(2, ℤ)) (a k : ℤ) :
+    δ * ModularGroup.T ^ (a * k) * δ⁻¹ = (δ * ModularGroup.T ^ a * δ⁻¹) ^ k := by
+  rw [zpow_mul]
+  have h := map_zpow (MulAut.conj δ) (ModularGroup.T ^ a) k
+  simp only [MulAut.conj_apply] at h
+  exact h
+
+theorem trace_conj_T_zpow (δ : SL(2, ℤ)) (h : ℤ) :
+    ((δ * ModularGroup.T ^ h * δ⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace = 2 := by
+  rw [Matrix.SpecialLinearGroup.coe_mul, Matrix.SpecialLinearGroup.coe_mul, Matrix.trace_mul_cycle,
+    ← Matrix.SpecialLinearGroup.coe_mul, inv_mul_cancel, Matrix.SpecialLinearGroup.coe_one,
+    Matrix.one_mul,
+    ModularGroup.coe_T_zpow, Matrix.trace_fin_two_of]
+  ring
+
+section CuspWidth
+
+variable (N : ℕ) [NeZero N]
+
+theorem exists_pos_conj_T_pow_mem (δ : SL(2, ℤ)) :
+    ∃ a : ℕ, 0 < a ∧ δ * ModularGroup.T ^ (a : ℤ) * δ⁻¹ ∈ Gamma0 N :=
+  ⟨N, Nat.pos_of_ne_zero (NeZero.ne N), conj_T_zpow_mem_Gamma0 N δ⟩
+
+open Classical in
+def cuspWidth (δ : SL(2, ℤ)) : ℕ := Nat.find (exists_pos_conj_T_pow_mem N δ)
+
+open Classical in
+theorem cuspWidth_spec (δ : SL(2, ℤ)) :
+    0 < cuspWidth N δ ∧ δ * ModularGroup.T ^ (cuspWidth N δ : ℤ) * δ⁻¹ ∈ Gamma0 N :=
+  Nat.find_spec (exists_pos_conj_T_pow_mem N δ)
+
+open Classical in
+theorem cuspWidth_min (δ : SL(2, ℤ)) {r : ℕ} (hr : 0 < r)
+    (hmem : δ * ModularGroup.T ^ (r : ℤ) * δ⁻¹ ∈ Gamma0 N) :
+    cuspWidth N δ ≤ r :=
+  Nat.find_min' (exists_pos_conj_T_pow_mem N δ) ⟨hr, hmem⟩
+
+theorem cuspWidth_dvd (δ : SL(2, ℤ)) {h : ℤ} (hh : δ * ModularGroup.T ^ h * δ⁻¹ ∈ Gamma0 N) :
+    (cuspWidth N δ : ℤ) ∣ h := by
+  obtain ⟨ha, hmem⟩ := cuspWidth_spec N δ
+  set a : ℕ := cuspWidth N δ with hadef
+  have ha' : (0 : ℤ) < a := by exact_mod_cast ha
+  have hrmem : δ * ModularGroup.T ^ (h % a) * δ⁻¹ ∈ Gamma0 N := by
+    have e : h % (a : ℤ) = h + (a : ℤ) * (-(h / a)) := by rw [Int.emod_def]; ring
+    rw [e, conj_T_zpow_add, conj_T_zpow_mul]
+    exact Subgroup.mul_mem _ hh (Subgroup.zpow_mem _ hmem _)
+  by_contra hnd
+  have hne : h % (a : ℤ) ≠ 0 := fun h0 => hnd (Int.dvd_of_emod_eq_zero h0)
+  have hnn : 0 ≤ h % (a : ℤ) := Int.emod_nonneg _ ha'.ne'
+  have hlt : h % (a : ℤ) < a := Int.emod_lt_of_pos _ ha'
+  obtain ⟨r, hr⟩ := Int.eq_ofNat_of_zero_le hnn
+  rw [hr] at hne hlt hrmem
+  have hrpos : 0 < r := by omega
+  have := cuspWidth_min N δ hrpos hrmem
+  omega
+
+end CuspWidth
+
+section CuspData
+
+variable (N : ℕ) [NeZero N]
+
+def cuspRep (q : SL(2, ℤ) ⧸ Gamma0 N) : SL(2, ℤ) := (Quotient.out q)⁻¹
+
+omit [NeZero N] in
+theorem mul_cuspRep_inv_mem (σ : SL(2, ℤ)) :
+    σ * (cuspRep N (QuotientGroup.mk σ⁻¹ : SL(2, ℤ) ⧸ Gamma0 N))⁻¹ ∈ Gamma0 N := by
+  set q : SL(2, ℤ) ⧸ Gamma0 N := QuotientGroup.mk σ⁻¹ with hq
+  have hmk : (QuotientGroup.mk (Quotient.out q) : SL(2, ℤ) ⧸ Gamma0 N) = QuotientGroup.mk σ⁻¹ := by
+    rw [hq]; exact Quotient.out_eq _
+  have h2 : (Quotient.out q)⁻¹ * σ⁻¹ ∈ Gamma0 N := QuotientGroup.eq.mp hmk
+  have h3 := Subgroup.inv_mem _ h2
+  rw [mul_inv_rev, inv_inv, inv_inv] at h3
+  simpa only [cuspRep, inv_inv] using h3
+
+def cuspGen (q : SL(2, ℤ) ⧸ Gamma0 N) : Gamma0 N :=
+  ⟨cuspRep N q * ModularGroup.T ^ (cuspWidth N (cuspRep N q) : ℤ) * (cuspRep N q)⁻¹, (cuspWidth_spec
+    N (cuspRep N q)).2⟩
+
+theorem coe_cuspGen (q : SL(2, ℤ) ⧸ Gamma0 N) :
+    ((cuspGen N q : Gamma0 N) : SL(2, ℤ)) = cuspRep N q * ModularGroup.T ^ (cuspWidth N (cuspRep N
+      q) : ℤ) * (cuspRep N q)⁻¹ := rfl
+
+theorem trace_cuspGen_sq (q : SL(2, ℤ) ⧸ Gamma0 N) :
+    (((cuspGen N q : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace ^ 2 = 4 := by
+  rw [coe_cuspGen, trace_conj_T_zpow]; norm_num
+
+end CuspData
+
+section CocycleAlgebra
+
+variable {G : Type*} [Group G] {K : Type*} [CommRing K] {V : Type*} [AddCommGroup V] [Module K V]
+  {ρ : Representation K G V} {y : G → V}
+
+theorem mem_range_of_mem_closure (hy : y ∈ coeffCocycles ρ) (w : V) {s : Set G}
+    (hs : ∀ v ∈ s, y v = ρ v w - w)
+    {g : G} (hg : g ∈ Subgroup.closure s) : y g = ρ g w - w := by
+  induction hg using Subgroup.closure_induction with
+  | mem x hx => exact hs x hx
+  | one => rw [coeffCocycles_apply_one hy, map_one, Module.End.one_apply, sub_self]
+  | mul a b _ _ iha ihb =>
+    rw [hy a b, iha, ihb, map_mul, Module.End.mul_apply, map_sub]
+    abel
+  | inv a _ iha =>
+    rw [coeffCocycles_apply_inv hy, iha, map_sub, ← Module.End.mul_apply, ← map_mul, inv_mul_cancel,
+      map_one,
+      Module.End.one_apply]
+    abel
+
+theorem apply_conj (hy : y ∈ coeffCocycles ρ) (g v : G) :
+    y (g * v * g⁻¹) = ρ g (y v) - (ρ (g * v * g⁻¹) (y g) - y g) := by
+  have h3 : ρ (g * v) (ρ g⁻¹ (y g)) = ρ (g * v * g⁻¹) (y g) := by
+    rw [← Module.End.mul_apply, ← map_mul]
+  rw [hy (g * v) g⁻¹, hy g v, coeffCocycles_apply_inv hy, map_neg, h3]
+  abel
+
+theorem apply_conj_mem_range (hy : y ∈ coeffCocycles ρ) {v : G} {w : V} (hv : y v = ρ v w - w)
+    (g : G) :
+    y (g * v * g⁻¹) ∈ LinearMap.range (ρ (g * v * g⁻¹) - 1) := by
+  refine ⟨ρ g w - y g, ?_⟩
+  rw [apply_conj hy, hv, LinearMap.sub_apply, Module.End.one_apply, map_sub, map_sub]
+  have : ρ (g * v * g⁻¹) (ρ g w) = ρ g (ρ v w) := by
+    rw [← Module.End.mul_apply, ← map_mul, show g * v * g⁻¹ * g = g * v by
+      group, map_mul, Module.End.mul_apply]
+  rw [this]
+  abel
+
+end CocycleAlgebra
+
+theorem isParabolicCocycle_of_cuspWitnesses (n N : ℕ) [NeZero N]
+    (hρm1 : binaryFormRepSL ℤ n (-1) = 1)
+    {y : Gamma0 N → ↥(BinaryForm ℤ n)}
+    (hycoc : y ∈ coeffCocycles ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype))
+    (hWq : ∀ q : SL(2, ℤ) ⧸ Gamma0 N, ∃ W : ↥(BinaryForm ℤ n),
+      y (cuspGen N q) = binaryFormRepSL ℤ n ((cuspGen N q : Gamma0 N) : SL(2, ℤ)) W - W) :
+    IsParabolicCocycle ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype) y := by
+  have hρZ' : ∀ g : Gamma0 N, ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype) g = binaryFormRepSL ℤ
+    n (g : SL(2, ℤ)) :=
+    fun g => rfl
+  set m₁ : Gamma0 N := ⟨-1, neg_one_mem_Gamma0 N⟩ with hm₁
+  intro γ hγ
+  obtain ⟨ε, σ, h, hε, hγeq⟩ :=
+    ModularGroup.exists_eq_conj_T_zpow_of_trace_sq_eq_four (γ : SL(2, ℤ)) hγ
+  set q : SL(2, ℤ) ⧸ Gamma0 N := QuotientGroup.mk σ⁻¹ with hq
+  have hg₀ : σ * (cuspRep N q)⁻¹ ∈ Gamma0 N := mul_cuspRep_inv_mem N σ
+  set g₀ : Gamma0 N := ⟨σ * (cuspRep N q)⁻¹, hg₀⟩ with hg₀def
+  have hσ : σ = (g₀ : SL(2, ℤ)) * cuspRep N q := by simp [hg₀def]
+  have hεmem : ε ∈ Gamma0 N :=
+    hε.elim (fun h => h ▸ Subgroup.one_mem _) (fun h => h ▸ neg_one_mem_Gamma0 N)
+  have hconj_mem : cuspRep N q * ModularGroup.T ^ h * (cuspRep N q)⁻¹ ∈ Gamma0 N := by
+    have e1 : cuspRep N q * ModularGroup.T ^ h * (cuspRep N q)⁻¹ = (g₀ : SL(2, ℤ))⁻¹ * (ε⁻¹ * (γ :
+      SL(2, ℤ))) * g₀ :=
+      by
+      rw [hγeq, hσ]; group
+    rw [e1]
+    exact Subgroup.mul_mem _ (Subgroup.mul_mem _ (Subgroup.inv_mem _ g₀.2)
+      (Subgroup.mul_mem _ (Subgroup.inv_mem _ hεmem) γ.2)) g₀.2
+  obtain ⟨k, hk⟩ := cuspWidth_dvd N (cuspRep N q) hconj_mem
+  have hpow : cuspRep N q * ModularGroup.T ^ h * (cuspRep N q)⁻¹ = ((cuspGen N q : Gamma0 N) : SL(2,
+    ℤ)) ^ k :=
+    by
+    rw [hk, conj_T_zpow_mul, coe_cuspGen]
+  set γ' : Gamma0 N := g₀ * (cuspGen N q) ^ k * g₀⁻¹ with hγ'def
+  have hγ'coe : (γ' : SL(2, ℤ)) = σ * ModularGroup.T ^ h * σ⁻¹ := by
+    simp only [hγ'def, Subgroup.coe_mul, Subgroup.coe_inv, SubgroupClass.coe_zpow, ← hpow, hσ]
+    group
+  obtain ⟨W, hW⟩ := hWq q
+  have hW' : y (cuspGen N q) = ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype) (cuspGen N q) W - W
+    :=
+    hW
+  have hzp : ∀ v ∈ Subgroup.zpowers (cuspGen N q),
+      y v = ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype) v W - W := fun v hv =>
+    mem_range_of_mem_closure hycoc W (s := {cuspGen N q}) (fun v hv => by
+      rw [Set.mem_singleton_iff.mp hv]; exact hW')
+      (by rwa [Subgroup.zpowers_eq_closure] at hv)
+  have hpar' : y γ' ∈ LinearMap.range (((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype) γ' - 1) :=
+    apply_conj_mem_range hycoc (hzp _ (Subgroup.zpow_mem_zpowers _ _)) g₀
+  rcases hε with rfl | rfl
+  · have : γ = γ' := Subtype.ext (by rw [hγ'coe, hγeq, one_mul])
+    rw [this]; exact hpar'
+  · have hγm : γ = m₁ * γ' := Subtype.ext (by rw [Subgroup.coe_mul, hγ'coe, hγeq])
+    have hρm₁ : ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype) m₁ = 1 := by rw [hρZ']; exact hρm1
+    have hym₁ : y m₁ = 0 := by
+      have h1 := hycoc m₁ m₁
+      have hmm : m₁ * m₁ = 1 := Subtype.ext (by simp [hm₁])
+      rw [hmm, coeffCocycles_apply_one hycoc, hρm₁, Module.End.one_apply] at h1
+      apply Subtype.ext; ext d
+      have h2 :=
+        congrArg (fun P : ↥(BinaryForm ℤ n) => AddMonoidAlgebra.coeff (P : MvPolynomial (Fin 2) ℤ)
+          d) h1
+      simp only [Submodule.coe_add, AddMonoidAlgebra.coeff_add, Finsupp.add_apply,
+        Submodule.coe_zero, AddMonoidAlgebra.coeff_zero, Finsupp.zero_apply] at h2
+      simp only [Submodule.coe_zero, AddMonoidAlgebra.coeff_zero, Finsupp.zero_apply]
+      omega
+    rw [hγm, hycoc m₁ γ', hym₁, zero_add, hρm₁, Module.End.one_apply, map_mul, hρm₁, one_mul]
+    exact hpar'
+
+theorem mk_eq_zero_of_odd (n N : ℕ) (hodd : Odd n)
+    (z : ↥(coeffParabolicCocycles ((binaryFormRepSL ℚ n).comp (Gamma0 N).subtype))) : coeffH1parMk _
+      z = 0 := by
+  have hρQ' : ∀ g : Gamma0 N, ((binaryFormRepSL ℚ n).comp (Gamma0 N).subtype) g = binaryFormRepSL ℚ
+    n (g : SL(2, ℤ)) :=
+    fun g => rfl
+  set m₁ : Gamma0 N := ⟨-1, neg_one_mem_Gamma0 N⟩ with hm₁
+  have hρm : ∀ v, ((binaryFormRepSL ℚ n).comp (Gamma0 N).subtype) m₁ v = -v := fun v => by
+    rw [hρQ']
+    change binaryFormRepSL ℚ n (-1) v = -v
+    rw [binaryFormRepSL_neg_one_apply, Odd.neg_one_pow hodd]
+    exact neg_one_smul ℚ v
+  have hz := z.2.1
+  have htwo : ((2 : ℚ) • z.1) ∈ coeffCoboundaries ((binaryFormRepSL ℚ n).comp (Gamma0 N).subtype) :=
+    by
+    rw [mem_coeffCoboundaries_iff]
+    refine ⟨-((z.1) m₁), funext fun g => ?_⟩
+    have hcomm : g * m₁ = m₁ * g := Subtype.ext (by simp [hm₁])
+    have h1 := hz g m₁
+    have h2 := hz m₁ g
+    rw [hcomm, h2, hρm] at h1
+    have h4 : z.1 g + z.1 g = z.1 m₁ - ((binaryFormRepSL ℚ n).comp (Gamma0 N).subtype) g (z.1 m₁) :=
+      by
+      rw [eq_sub_iff_add_eq]
+      calc z.1 g + z.1 g + ((binaryFormRepSL ℚ n).comp (Gamma0 N).subtype) g (z.1 m₁)
+          = z.1 g + (z.1 g + ((binaryFormRepSL ℚ n).comp (Gamma0 N).subtype) g (z.1 m₁)) := by abel
+        _ = z.1 g + (z.1 m₁ + -z.1 g) := by rw [h1]
+        _ = z.1 m₁ := by abel
+    rw [map_neg, Pi.smul_apply, two_smul, h4]
+    abel
+  have : coeffH1parMk ((binaryFormRepSL ℚ n).comp (Gamma0 N).subtype) ((2 : ℚ) • z) = 0 := by
+    rw [coeffH1parMk_eq_zero_iff]; simpa [Submodule.coe_smul] using htwo
+  rw [map_smul, smul_eq_zero] at this
+  exact this.resolve_left two_ne_zero
+
+variable (n N : ℕ) [NeZero N]
+
+theorem main
+    (Φ : coeffH1par ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype) →+ coeffH1par ((binaryFormRepSL
+      ℚ n).comp (Gamma0 N).subtype))
+    (hΦ : ∀ z : ↥(coeffParabolicCocycles ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype)),
+      ∃ w : ↥(coeffParabolicCocycles ((binaryFormRepSL ℚ n).comp (Gamma0 N).subtype)),
+        (∀ g : Gamma0 N, ((w : Gamma0 N → ↥(BinaryForm ℚ n)) g : MvPolynomial (Fin 2) ℚ)
+            = MvPolynomial.map (Int.castRingHom ℚ) (((z : Gamma0 N → ↥(BinaryForm ℤ n)) g :
+              MvPolynomial (Fin 2) ℤ))) ∧
+        Φ (coeffH1parMk _ z) = coeffH1parMk _ w)
+    (x : coeffH1par ((binaryFormRepSL ℚ n).comp (Gamma0 N).subtype)) :
+    ∃ (m : ℤ) (y : coeffH1par ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype)), m ≠ 0 ∧ Φ y = m • x
+      := by
+  classical
+  have : (Gamma0 N).FiniteIndex := Subgroup.finiteIndex_of_le (Gamma_le_Gamma0 N)
+  have : Fintype (SL(2, ℤ) ⧸ Gamma0 N) := Fintype.ofFinite _
+  have hρQ' : ∀ g : Gamma0 N, ((binaryFormRepSL ℚ n).comp (Gamma0 N).subtype) g = binaryFormRepSL ℚ
+    n (g : SL(2, ℤ)) :=
+    fun g => rfl
+  have hρZ' : ∀ g : Gamma0 N, ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype) g = binaryFormRepSL ℤ
+    n (g : SL(2, ℤ)) :=
+    fun g => rfl
+  obtain ⟨z, rfl⟩ := coeffH1parMk_surjective ((binaryFormRepSL ℚ n).comp (Gamma0 N).subtype) x
+  rcases Nat.even_or_odd n with heven | hodd
+  swap
+  · refine ⟨1, 0, one_ne_zero, ?_⟩
+    rw [map_zero, one_smul, mk_eq_zero_of_odd n N hodd z]
+  · have hgen : ∀ (K : Type) [CommRing K] (P : ↥(BinaryForm K n)), ((-1 : K) ^ n) • P = P := by
+      intro K _ P
+      rw [Even.neg_one_pow heven, one_smul]
+    have hρm1 : binaryFormRepSL ℤ n (-1) = 1 := by
+      refine LinearMap.ext fun P => ?_
+      rw [Module.End.one_apply]
+      exact (binaryFormRepSL_neg_one_apply ℤ n P).trans (hgen ℤ P)
+    obtain ⟨_, S, _, hS⟩ := Group.fg_iff'.mp (instGroupFG_Gamma0 N)
+    choose w hw using fun q : SL(2, ℤ) ⧸ Gamma0 N => z.2.2 (cuspGen N q) (trace_cuspGen_sq N q)
+    obtain ⟨D₁, hD₁, hint₁⟩ :=
+      exists_isInt_zsmul_family S (fun g => ((z.1 g : ↥(BinaryForm ℚ n)) : MvPolynomial (Fin 2) ℚ))
+    obtain ⟨D₂, hD₂, hint₂⟩ :=
+      exists_isInt_zsmul_family (Finset.univ : Finset (SL(2, ℤ) ⧸ Gamma0 N))
+      (fun q => ((w q : ↥(BinaryForm ℚ n)) : MvPolynomial (Fin 2) ℚ))
+    have hD : D₁ * D₂ ≠ 0 := mul_ne_zero hD₁ hD₂
+    let M : AddSubgroup ↥(BinaryForm ℚ n) :=
+      { carrier := {P | IsInt (P : MvPolynomial (Fin 2) ℚ)}
+        zero_mem' := by
+          change IsInt ((0 : ↥(BinaryForm ℚ n)) : MvPolynomial (Fin 2) ℚ); simpa using IsInt.zero
+        add_mem' := by
+          intro P Q hP hQ
+          change IsInt ((P + Q : ↥(BinaryForm ℚ n)) : MvPolynomial (Fin 2) ℚ)
+          rw [Submodule.coe_add]; exact hP.add hQ
+        neg_mem' := by
+          intro P hP
+          change IsInt ((-P : ↥(BinaryForm ℚ n)) : MvPolynomial (Fin 2) ℚ)
+          rw [Submodule.coe_neg]; exact hP.neg }
+    have hMρ : ∀ (g : Gamma0 N) (v : ↥(BinaryForm ℚ n)), v ∈ M → ((binaryFormRepSL ℚ n).comp (Gamma0
+      N).subtype) g v ∈ M :=
+      by
+      intro g v hv
+      change IsInt ((((binaryFormRepSL ℚ n).comp (Gamma0 N).subtype) g v : ↥(BinaryForm ℚ n)) :
+        MvPolynomial (Fin 2) ℚ)
+      rw [hρQ', binaryFormRepSL_apply_coe]
+      exact hv.binarySubst _
+    have hint : ∀ g : Gamma0 N, IsInt ((((((D₁ * D₂ : ℤ)) : ℚ) • z).1 g : ↥(BinaryForm ℚ n)) :
+      MvPolynomial (Fin 2) ℚ) :=
+      by
+      intro g
+      refine mem_of_mem_coeffCocycles_of_closure_eq_top ((((D₁ * D₂ : ℤ)) : ℚ) • z).2.1 M hMρ hS
+        (fun g hg => ?_) g
+      change IsInt ((((((D₁ * D₂ : ℤ)) : ℚ) • z).1 g : ↥(BinaryForm ℚ n)) : MvPolynomial (Fin 2) ℚ)
+      rw [show (((((D₁ * D₂ : ℤ)) : ℚ) • z).1 g : ↥(BinaryForm ℚ n)) = (((D₁ * D₂ : ℤ)) : ℚ) • z.1 g
+        from rfl, Submodule.coe_smul,
+        Int.cast_smul_eq_zsmul, mul_comm, mul_smul]
+      exact (hint₁ g hg).zsmul D₂
+    choose y hy using fun g => exists_eq_pushForm_of_isInt n (hint g)
+    have hyv : ∀ g, pushForm ιZQ n (y g) = (((D₁ * D₂ : ℤ)) : ℚ) • z.1 g := fun g => hy g
+    have hycoc : y ∈ coeffCocycles ((binaryFormRepSL ℤ n).comp (Gamma0 N).subtype) := by
+      intro g h
+      apply pushForm_ι_injective n
+      rw [hy, ((((D₁ * D₂ : ℤ)) : ℚ) • z).2.1 g h, hρZ', hρQ', pushForm_add,
+        pushForm_binaryFormRepSL, hy, hy]
+    have hWq : ∀ q, ∃ W : ↥(BinaryForm ℤ n),
+        y (cuspGen N q) = binaryFormRepSL ℤ n ((cuspGen N q : Gamma0 N) : SL(2, ℤ)) W - W := by
+      intro q
+      have hiw : IsInt (((((D₁ * D₂ : ℤ)) : ℚ) • w q : ↥(BinaryForm ℚ n)) : MvPolynomial (Fin 2) ℚ)
+        :=
+        by
+        rw [Submodule.coe_smul, Int.cast_smul_eq_zsmul, mul_smul]
+        exact (hint₂ q (Finset.mem_univ q)).zsmul D₁
+      obtain ⟨W, hW⟩ := exists_eq_pushForm_of_isInt n hiw
+      refine ⟨W, pushForm_ι_injective n ?_⟩
+      have h1 := hw q
+      rw [LinearMap.sub_apply, Module.End.one_apply] at h1
+      rw [hyv, pushForm_sub, pushForm_binaryFormRepSL, hW, ← hρQ', LinearMap.map_smul, ← smul_sub,
+        h1]
+    have hypar := isParabolicCocycle_of_cuspWitnesses n N hρm1 hycoc hWq
+    obtain ⟨w', hw'1, hw'2⟩ := hΦ ⟨y, hycoc, hypar⟩
+    refine ⟨D₁ * D₂, coeffH1parMk _ ⟨y, hycoc, hypar⟩, hD, ?_⟩
+    rw [hw'2]
+    have : w' = (((D₁ * D₂ : ℤ)) : ℚ) • z := by
+      apply Subtype.ext; funext g; apply Subtype.ext
+      rw [hw'1 g]
+      change MvPolynomial.map (Int.castRingHom ℚ) ((y g : ↥(BinaryForm ℤ n)) : MvPolynomial (Fin 2)
+        ℤ) = _
+      rw [← coe_pushForm_ι, hyv]
+      try rfl
+    rw [this, LinearMap.map_smul, Int.cast_smul_eq_zsmul]
+
+end HeckeEis.ZQAux
+end
+
+open scoped MatrixGroups in
+theorem solution (n N : ℕ) [NeZero N]
+    (Φ : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℤ n).comp (CongruenceSubgroup.Gamma0
+      N).subtype)
+        →+ HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℚ n).comp (CongruenceSubgroup.Gamma0
+          N).subtype))
+    (hΦ : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℤ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℚ n).comp
+        (CongruenceSubgroup.Gamma0 N).subtype)),
+        (∀ g : CongruenceSubgroup.Gamma0 N,
+            ((w : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℚ n)) g : MvPolynomial (Fin 2)
+              ℚ)
+              = MvPolynomial.map (Int.castRingHom ℚ)
+                  (((z : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℤ n)) g : MvPolynomial
+                    (Fin 2) ℤ))) ∧
+        Φ (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w)
+    (x : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℚ n).comp (CongruenceSubgroup.Gamma0
+      N).subtype)) :
+    ∃ (m : ℤ) (y : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℤ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+      m ≠ 0 ∧ Φ y = m • x :=
+  HeckeEis.ZQAux.main n N Φ hΦ x
+
+end S_HeckeEis_exists_ne_zero_smul_eq_coeffH1par_map_int_rat
+end P2MW
+export P2MW.S_HeckeEis_exists_ne_zero_smul_eq_coeffH1par_map_int_rat (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.exists_ne_zero_smul_eq_coeffH1par_map_int_rat (n N : ℕ) [NeZero N]
+    (Φ : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℤ n).comp (CongruenceSubgroup.Gamma0
+      N).subtype)
+        →+ HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℚ n).comp (CongruenceSubgroup.Gamma0
+          N).subtype))
+    (hΦ : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℤ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℚ n).comp
+        (CongruenceSubgroup.Gamma0 N).subtype)),
+        (∀ g : CongruenceSubgroup.Gamma0 N,
+            ((w : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℚ n)) g : MvPolynomial (Fin 2)
+              ℚ)
+              = MvPolynomial.map (Int.castRingHom ℚ)
+                  (((z : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℤ n)) g : MvPolynomial
+                    (Fin 2) ℤ))) ∧
+        Φ (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w)
+    (x : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℚ n).comp (CongruenceSubgroup.Gamma0
+      N).subtype)) :
+    ∃ (m : ℤ) (y : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℤ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+      m ≠ 0 ∧ Φ y = m • x :=
+  solution n N Φ hΦ x
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_pairing_binaryForm_linePow.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_pairing_binaryForm_linePow.lean
new file mode 100644
index 0000000000..a3abf21ff6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_exists_pairing_binaryForm_linePow.lean
@@ -0,0 +1,439 @@
+/-
+Based on Prove2Me node HeckeEis.exists_pairing_binaryForm_linePow
+(b04cdc68-d94e-52b6-afd5-12eb7ccba730) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 77cb2e35-f8de-5e33-9dc2-3eadea937c7a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import Mathlib.LinearAlgebra.Lagrange
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# An SL₂(ℤ)-invariant pairing on binary forms of degree n
+
+Theorem statement: `HeckeEis.exists_pairing_binaryForm_linePow`
+(`b04cdc68-d94e-52b6-afd5-12eb7ccba730`), by Claude, 2026-09-05.
+
+Proof: submission `77cb2e35-f8de-5e33-9dc2-3eadea937c7a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $n$ be a natural number and let $V_n$ denote [`HeckeEis.BinaryForm ℂ
+n`](def/HeckeEis_BinaryFormRep.html#L25), the submodule of $\mathbb{C}[X_0,X_1]$ (polynomials in two
+variables indexed by `Fin 2`) consisting of the forms homogeneous of degree $n$. The group
+$SL_2(\mathbb{Z})$ acts on $V_n$ through [`HeckeEis.binaryFormRepSL ℂ
+n`](def/HeckeEis_BinaryFormRep.html#L61), which sends $g$ to the restriction to $V_n$ of the algebra
+endomorphism of $\mathbb{C}[X_0,X_1]$ substituting $\sum_{i} g_{ij} X_i$ for $X_j$; and for $\tau
+\in \mathbb{C}$, [`HeckeEis.linePow n τ`](def/HeckeEis_EichlerIntegral.html#L22) is the element
+$(\tau X_0 + X_1)^n$ of $V_n$. The assertion is that there exists a $\mathbb{C}$-bilinear form $B
+\colon V_n \times V_n \to \mathbb{C}$ (given as an iterated linear map) satisfying four conditions:
+$B(gP, gQ) = B(P,Q)$ for all $g \in SL_2(\mathbb{Z})$ and all $P, Q \in V_n$; $B(Q,P) = (-1)^n
+B(P,Q)$ for all $P,Q$; the left radical of $B$ vanishes, i.e. any $P$ with $B(P,Q)=0$ for every $Q$
+is zero; and the normalisation $B\bigl((\tau X_0 + X_1)^n, (\sigma X_0 + X_1)^n\bigr) = (\tau -
+\sigma)^n$ for all $\tau, \sigma \in \mathbb{C}$. Only the existence of such a $B$ is asserted, not
+uniqueness, and non-degeneracy is stated for the first argument alone.
+
+This is the classical determinant (transvectant) pairing on binary forms of degree $n$, i.e. the
+$SL_2$-invariant, $(-1)^n$-symmetric form on $\mathrm{Sym}^n$ of the standard two-dimensional
+representation, pinned down on $n$-th powers of linear forms by $B(u^n,v^n)=[u,v]^n$. It is used in
+[`HeckeEis.exists_induced_binaryFormRepSL_top`]
+(thm.html#HeckeEis.exists_induced_binaryFormRepSL_top).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_exists_pairing_binaryForm_linePow.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_exists_pairing_binaryForm_linePow
+
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binaryFormRepSL linePow coe_linePow jFactor coe_smul_mul_jFactor \
+  binaryFormRepSL_linePow"
+namespace PairingSol
+p2m_open "HeckeEis"
+
+open MvPolynomial Finset
+open scoped MatrixGroups
+
+variable (n : ℕ)
+
+def ex (i : ℕ) : Fin 2 →₀ ℕ := Finsupp.single 0 i + Finsupp.single 1 (n - i)
+
+@[scoped simp] theorem ex_apply_zero (i : ℕ) : ex n i 0 = i := by simp [ex]
+@[scoped simp] theorem ex_apply_one (i : ℕ) : ex n i 1 = n - i := by simp [ex]
+
+theorem ex_inj {i j : ℕ} (h : ex n i = ex n j) : i = j := by
+  have := congrArg (fun d => d 0) h
+  simpa using this
+
+theorem degree_ex {i : ℕ} (hi : i ≤ n) : (ex n i).degree = n := by
+  rw [ex, (map_add Finsupp.degree), Finsupp.degree_single, Finsupp.degree_single]
+  omega
+
+theorem ex_sub_sub {i : ℕ} (hi : i ≤ n) : ex n (n - (n - i)) = ex n i := by
+  rw [Nat.sub_sub_self hi]
+
+theorem eq_ex_of_degree {d : Fin 2 →₀ ℕ} (hd : d.degree = n) : d = ex n (d 0) ∧ d 0 ≤ n := by
+  have hsum : d 0 + d 1 = n := by
+    rw [← hd, Finsupp.degree_eq_sum, Fin.sum_univ_two]
+  refine ⟨?_, by omega⟩
+  ext j
+  fin_cases j
+  · simp
+  · simp; omega
+
+def wt (i : ℕ) : ℂ := (-1) ^ (n - i) / (n.choose i : ℂ)
+
+theorem choose_ne_zero {i : ℕ} (hi : i ≤ n) : (n.choose i : ℂ) ≠ 0 := by
+  exact_mod_cast (Nat.choose_pos hi).ne'
+
+theorem wt_ne_zero {i : ℕ} (hi : i ≤ n) : wt n i ≠ 0 :=
+  div_ne_zero (pow_ne_zero _ (by norm_num)) (choose_ne_zero n hi)
+
+theorem wt_mul_choose {i : ℕ} (hi : i ≤ n) : wt n i * (n.choose i : ℂ) = (-1) ^ (n - i) := by
+  rw [wt, div_mul_cancel₀ _ (choose_ne_zero n hi)]
+
+def rawPairing : MvPolynomial (Fin 2) ℂ →ₗ[ℂ] MvPolynomial (Fin 2) ℂ →ₗ[ℂ] ℂ :=
+  LinearMap.mk₂ ℂ
+    (fun P Q => ∑ i ∈ range (n + 1), wt n i * AddMonoidAlgebra.coeff P (ex n i) *
+      AddMonoidAlgebra.coeff Q (ex n (n - i)))
+    (fun P P' Q => by
+      rw [← sum_add_distrib]
+      exact sum_congr rfl fun i _ => by rw [AddMonoidAlgebra.coeff_add, Finsupp.add_apply]; ring)
+    (fun c P Q => by
+      rw [smul_eq_mul, mul_sum]
+      exact sum_congr rfl fun i _ => by rw [coeff_smul, smul_eq_mul]; ring)
+    (fun P Q Q' => by
+      rw [← sum_add_distrib]
+      exact sum_congr rfl fun i _ => by rw [AddMonoidAlgebra.coeff_add, Finsupp.add_apply]; ring)
+    (fun c P Q => by
+      rw [smul_eq_mul, mul_sum]
+      exact sum_congr rfl fun i _ => by rw [coeff_smul, smul_eq_mul]; ring)
+
+@[scoped simp] theorem rawPairing_apply (P Q : MvPolynomial (Fin 2) ℂ) :
+    rawPairing n P Q = ∑ i ∈ range (n + 1), wt n i * AddMonoidAlgebra.coeff P (ex n i) *
+      AddMonoidAlgebra.coeff Q (ex n (n - i)) := rfl
+
+def pairing : ↥(BinaryForm ℂ n) →ₗ[ℂ] ↥(BinaryForm ℂ n) →ₗ[ℂ] ℂ :=
+  (rawPairing n).compl₁₂ (BinaryForm ℂ n).subtype (BinaryForm ℂ n).subtype
+
+theorem pairing_apply (P Q : ↥(BinaryForm ℂ n)) :
+    pairing n P Q = ∑ i ∈ range (n + 1),
+      wt n i * AddMonoidAlgebra.coeff (P : MvPolynomial (Fin 2) ℂ) (ex n i) * AddMonoidAlgebra.coeff
+        (Q : MvPolynomial (Fin 2) ℂ) (ex n (n - i)) := rfl
+
+theorem linePow_expand (τ : ℂ) :
+    ((C τ * X 0 + X 1 : MvPolynomial (Fin 2) ℂ)) ^ n
+      = ∑ m ∈ range (n + 1), monomial (ex n m) ((n.choose m : ℂ) * τ ^ m) := by
+  rw [(Commute.all (C τ * X 0) (X 1 : MvPolynomial (Fin 2) ℂ)).add_pow]
+  refine sum_congr rfl fun m hm => ?_
+  rw [mul_pow, ← map_pow, X_pow_eq_monomial, X_pow_eq_monomial, C_mul_monomial,
+    monomial_mul_monomial, ex]
+  rw [mul_comm (monomial _ _) ((n.choose m : MvPolynomial (Fin 2) ℂ)), ← C_eq_coe_nat,
+    C_mul_monomial]
+  simp only [mul_one]
+
+theorem coeff_linePow {i : ℕ} (hi : i ≤ n) (τ : ℂ) :
+    AddMonoidAlgebra.coeff ((linePow n τ : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) (ex n i) =
+      (n.choose i : ℂ) * τ ^ i := by
+  rw [coe_linePow, linePow_expand, coeff_sum]
+  rw [sum_eq_single i]
+  · rw [coeff_monomial, ite_eq_left rfl]
+  · intro m _ hmi
+    rw [coeff_monomial, ite_eq_right (fun h => hmi (ex_inj n h))]
+  · intro h; exact absurd (mem_range.mpr (Nat.lt_succ_of_le hi)) h
+
+theorem pairing_linePow (τ σ : ℂ) : pairing n (linePow n τ) (linePow n σ) = (τ - σ) ^ n := by
+  rw [pairing_apply, sub_eq_add_neg, (Commute.all τ (-σ)).add_pow]
+  refine sum_congr rfl fun i hi => ?_
+  have hi' : i ≤ n := Nat.lt_succ_iff.mp (mem_range.mp hi)
+  rw [coeff_linePow n hi', coeff_linePow n (Nat.sub_le n i), Nat.choose_symm hi', neg_pow σ]
+  have := wt_mul_choose n hi'
+  calc wt n i * ((n.choose i : ℂ) * τ ^ i) * ((n.choose i : ℂ) * σ ^ (n - i))
+        = (wt n i * (n.choose i : ℂ)) * τ ^ i * σ ^ (n - i) * (n.choose i : ℂ) := by ring
+    _ = τ ^ i * ((-1) ^ (n - i) * σ ^ (n - i)) * (n.choose i : ℂ) := by rw [this]; ring
+
+theorem pairing_swap (P Q : ↥(BinaryForm ℂ n)) : pairing n Q P = (-1) ^ n * pairing n P Q := by
+  rw [pairing_apply, pairing_apply, mul_sum, ← sum_range_reflect]
+  refine sum_congr rfl fun i hi => ?_
+  have hi' : i ≤ n := Nat.lt_succ_iff.mp (mem_range.mp hi)
+  rw [show n + 1 - 1 - i = n - i by omega, Nat.sub_sub_self hi']
+  have hw : wt n (n - i) = (-1) ^ n * wt n i := by
+    rw [wt, wt, Nat.sub_sub_self hi', Nat.choose_symm hi']
+    rw [mul_div_assoc', ← pow_add, show n + (n - i) = 2 * (n - i) + i by omega, pow_add, pow_mul]
+    norm_num
+  rw [hw]; ring
+
+theorem monomial_ex_mem {i : ℕ} (hi : i ≤ n) : monomial (ex n i) (1 : ℂ) ∈ BinaryForm ℂ n :=
+  (mem_homogeneousSubmodule n _).mpr (isHomogeneous_monomial _ (degree_ex n hi))
+
+theorem pairing_monomial (P : ↥(BinaryForm ℂ n)) {i : ℕ} (hi : i ≤ n) :
+    pairing n P ⟨monomial (ex n (n - i)) 1, monomial_ex_mem n (Nat.sub_le n i)⟩
+      = wt n i * AddMonoidAlgebra.coeff (P : MvPolynomial (Fin 2) ℂ) (ex n i) := by
+  rw [pairing_apply, sum_eq_single i]
+  · simp
+  · intro j hj hji
+    have hj' : j ≤ n := Nat.lt_succ_iff.mp (mem_range.mp hj)
+    rw [Subtype.coe_mk, coeff_monomial, ite_eq_right, mul_zero]
+    intro h
+    have := ex_inj n h
+    omega
+  · intro h; exact absurd (mem_range.mpr (Nat.lt_succ_of_le hi)) h
+
+theorem eq_zero_of_pairing_eq_zero (P : ↥(BinaryForm ℂ n)) (h : ∀ Q, pairing n P Q = 0) :
+    P = 0 := by
+  have hc : ∀ i ≤ n, AddMonoidAlgebra.coeff (P : MvPolynomial (Fin 2) ℂ) (ex n i) = 0 := by
+    intro i hi
+    have := h ⟨monomial (ex n (n - i)) 1, monomial_ex_mem n (Nat.sub_le n i)⟩
+    rw [pairing_monomial n P hi] at this
+    exact (mul_eq_zero.mp this).resolve_left (wt_ne_zero n hi)
+  apply Subtype.ext
+  change (P : MvPolynomial (Fin 2) ℂ) = 0
+  ext d
+  rw [AddMonoidAlgebra.coeff_zero, Finsupp.zero_apply]
+  by_contra hd
+  have hP : (P : MvPolynomial (Fin 2) ℂ).IsHomogeneous n := (mem_homogeneousSubmodule n _).mp P.2
+  have hdeg : d.degree = n := by
+    rw [Finsupp.degree_eq_weight_one]
+    exact hP hd
+  obtain ⟨hd', hle⟩ := eq_ex_of_degree n hdeg
+  rw [hd'] at hd
+  exact hd (hc _ hle)
+
+end HeckeEis.PairingSol
+end
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binaryFormRepSL linePow coe_linePow jFactor coe_smul_mul_jFactor \
+  binaryFormRepSL_linePow"
+namespace PairingSol
+p2m_open "HeckeEis"
+
+open MvPolynomial Finset UpperHalfPlane
+open scoped MatrixGroups
+
+variable (n : ℕ)
+
+theorem det_coe_complex (g : SL(2, ℤ)) :
+    ((g : Matrix (Fin 2) (Fin 2) ℤ) 0 0 : ℂ) * ((g : Matrix (Fin 2) (Fin 2) ℤ) 1 1 : ℂ)
+      - ((g : Matrix (Fin 2) (Fin 2) ℤ) 0 1 : ℂ) * ((g : Matrix (Fin 2) (Fin 2) ℤ) 1 0 : ℂ) = 1 :=
+        by
+  have h := Matrix.SpecialLinearGroup.det_coe g
+  rw [Matrix.det_fin_two] at h
+  exact_mod_cast h
+
+theorem jFactor_mul_jFactor_mul_sub (g : SL(2, ℤ)) (τ σ : ℍ) :
+    jFactor g τ * jFactor g σ * (((g • τ : ℍ) : ℂ) - ((g • σ : ℍ) : ℂ)) = (τ : ℂ) - (σ : ℂ) := by
+  have hτ := coe_smul_mul_jFactor g τ
+  have hσ := coe_smul_mul_jFactor g σ
+  have hdet := det_coe_complex g
+  have e : jFactor g τ * jFactor g σ * (((g • τ : ℍ) : ℂ) - ((g • σ : ℍ) : ℂ))
+      = jFactor g σ * (((g • τ : ℍ) : ℂ) * jFactor g τ) - jFactor g τ * (((g • σ : ℍ) : ℂ) * jFactor
+        g σ) := by
+        ring
+  rw [e, hτ, hσ, jFactor, jFactor]
+  linear_combination ((τ : ℂ) - (σ : ℂ)) * hdet
+
+theorem pairing_rep_linePow (g : SL(2, ℤ)) (τ σ : ℍ) :
+    pairing n (binaryFormRepSL ℂ n g (linePow n (τ : ℂ))) (binaryFormRepSL ℂ n g (linePow n (σ :
+      ℂ)))
+      = pairing n (linePow n (τ : ℂ)) (linePow n (σ : ℂ)) := by
+  rw [binaryFormRepSL_linePow, binaryFormRepSL_linePow, LinearMap.map_smul₂, LinearMap.map_smul,
+    pairing_linePow,
+    pairing_linePow, smul_eq_mul, smul_eq_mul, ← mul_pow, ← mul_pow, ← mul_assoc,
+    jFactor_mul_jFactor_mul_sub]
+
+def node (j : Fin (n + 1)) : ℍ := ⟨(j : ℂ) + Complex.I, by simp⟩
+
+@[scoped simp] theorem coe_node (j : Fin (n + 1)) :
+    ((node n j : ℍ) : ℂ) = (j : ℂ) + Complex.I := rfl
+
+theorem node_injective : Function.Injective (fun j : Fin (n + 1) => ((node n j : ℍ) : ℂ)) := by
+  intro j j' h
+  simp only [coe_node, add_left_inj, Nat.cast_inj] at h
+  exact Fin.ext (by exact_mod_cast h)
+
+def lineSpan : Submodule ℂ ↥(BinaryForm ℂ n) :=
+  Submodule.span ℂ (Set.range fun τ : ℍ => linePow n (τ : ℂ))
+
+theorem linePow_mem_lineSpan (τ : ℍ) :
+    linePow n (τ : ℂ) ∈ lineSpan n := Submodule.subset_span ⟨τ, rfl⟩
+
+theorem monomial_mem_lineSpan {k : ℕ} (hk : k ≤ n) :
+    (⟨monomial (ex n k) 1, monomial_ex_mem n hk⟩ : ↥(BinaryForm ℂ n)) ∈ lineSpan n := by
+  classical
+  set v : Fin (n + 1) → ℂ := fun j => ((node n j : ℍ) : ℂ) with hv
+  have hvs : Set.InjOn v (Finset.univ : Finset (Fin (n + 1))) := fun a _ b _ h => node_injective n h
+  set L : Fin (n + 1) → Polynomial ℂ := fun j => Lagrange.basis Finset.univ v j with hL
+  have hdeg : ∀ j, (L j).natDegree < n + 1 := by
+    intro j
+    rw [hL, Lagrange.natDegree_basis hvs (Finset.mem_univ j), Finset.card_univ, Fintype.card_fin]
+    omega
+  have heval : ∀ j m : Fin (n + 1), ∑ i : Fin (n + 1), (L j).coeff i * v m ^ (i : ℕ) = if j = m then
+    1 else 0 :=
+    by
+    intro j m
+    rw [Fin.sum_univ_eq_sum_range (fun i => (L j).coeff i * v m ^ i) (n + 1),
+      ← Polynomial.eval_eq_sum_range' (hdeg j)]
+    split_ifs with h
+    · subst h; exact Lagrange.eval_basis_self hvs (Finset.mem_univ j)
+    · exact Lagrange.eval_basis_of_ne h (Finset.mem_univ m)
+  set A : Matrix (Fin (n + 1)) (Fin (n + 1)) ℂ := fun j i => (L j).coeff i with hA
+  set V : Matrix (Fin (n + 1)) (Fin (n + 1)) ℂ := fun i m => v m ^ (i : ℕ) with hV
+  have hAV : A * V = 1 := by
+    ext j m
+    rw [Matrix.mul_apply, Matrix.one_apply]
+    exact heval j m
+  have hVA : V * A = 1 := mul_eq_one_comm.mp hAV
+  have hcol : ∀ i k' : Fin (n + 1), ∑ j : Fin (n + 1), v j ^ (i : ℕ) * (L j).coeff k' = if i = k'
+    then 1 else 0 :=
+    by
+    intro i k'
+    have := congrFun (congrFun hVA i) k'
+    rwa [Matrix.mul_apply, Matrix.one_apply] at this
+  set kk : Fin (n + 1) := ⟨k, Nat.lt_succ_of_le hk⟩ with hkk
+  have hmem : (∑ j : Fin (n + 1), (L j).coeff k • linePow n (v j)) ∈ lineSpan n :=
+    Submodule.sum_mem _ fun j _ => Submodule.smul_mem _ _ (linePow_mem_lineSpan n (node n j))
+  have hcomb : ((∑ j : Fin (n + 1), (L j).coeff k • linePow n (v j) : ↥(BinaryForm ℂ n)) :
+    MvPolynomial (Fin 2) ℂ)
+      = C ((n.choose k : ℂ)) * monomial (ex n k) 1 := by
+    rw [Submodule.coe_sum]
+    simp only [Submodule.coe_smul, coe_linePow, linePow_expand, smul_sum, smul_monomial,
+      smul_eq_mul]
+    rw [Finset.sum_comm]
+    rw [← Fin.sum_univ_eq_sum_range (fun m => ∑ j : Fin (n + 1), monomial (ex n m) ((L j).coeff k *
+      ((n.choose m : ℂ) * v j ^ m))) (n + 1)]
+    have inner : ∀ m : Fin (n + 1), ∑ j : Fin (n + 1), monomial (ex n m) ((L j).coeff k * ((n.choose
+      (m : ℕ) : ℂ) * v j ^ (m : ℕ)))
+        = monomial (ex n m) ((n.choose (m : ℕ) : ℂ) * (if m = kk then 1 else 0)) := by
+      intro m
+      rw [← map_sum, ← hcol m kk]
+      congr 1
+      rw [Finset.mul_sum]
+      exact Finset.sum_congr rfl fun j _ => by ring
+    simp only [inner]
+    rw [Finset.sum_eq_single kk]
+    · rw [ite_eq_left rfl, mul_one, C_mul_monomial, mul_one]
+    · intro m _ hm; rw [ite_eq_right hm, mul_zero, monomial_zero]
+    · intro h; exact absurd (Finset.mem_univ kk) h
+  have hne : (n.choose k : ℂ) ≠ 0 := choose_ne_zero n hk
+  have : (⟨monomial (ex n k) 1, monomial_ex_mem n hk⟩ : ↥(BinaryForm ℂ n))
+      = (n.choose k : ℂ)⁻¹ • ∑ j : Fin (n + 1), (L j).coeff k • linePow n (v j) := by
+    apply Subtype.ext
+    rw [Submodule.coe_smul, hcomb, smul_eq_C_mul, ← mul_assoc, ← C_mul, inv_mul_cancel₀ hne, C_1,
+      one_mul]
+  rw [this]
+  exact Submodule.smul_mem _ _ hmem
+
+theorem lineSpan_eq_top : lineSpan n = ⊤ := by
+  classical
+  have hmono : ∀ d : Fin 2 →₀ ℕ, d.degree = n →
+      (monomial d (1 : ℂ)) ∈ (lineSpan n).map (BinaryForm ℂ n).subtype := by
+    intro d hd
+    obtain ⟨hd', hle⟩ := eq_ex_of_degree n hd
+    refine ⟨⟨monomial (ex n (d 0)) 1, monomial_ex_mem n hle⟩, monomial_mem_lineSpan n hle, ?_⟩
+    change monomial (ex n (d 0)) (1 : ℂ) = monomial d 1
+    rw [← hd']
+  have hle : (BinaryForm ℂ n : Submodule ℂ (MvPolynomial (Fin 2) ℂ)) ≤ (lineSpan n).map (BinaryForm
+    ℂ n).subtype :=
+    by
+    intro φ hφ
+    have hφ' : φ ∈ AddMonoidAlgebra.supported ℂ ℂ {d : Fin 2 →₀ ℕ | d.degree = n} := by
+      rwa [← MvPolynomial.homogeneousSubmodule_eq_finsupp_supported]
+    rw [AddMonoidAlgebra.supported_eq_span_single] at hφ'
+    refine (Submodule.span_le.mpr ?_) hφ'
+    rintro _ ⟨d, hd, rfl⟩
+    exact hmono d hd
+  rw [eq_top_iff]
+  rintro P -
+  obtain ⟨Q, hQ, hQP⟩ := hle P.2
+  have : P = Q := Subtype.ext hQP.symm
+  rw [this]; exact hQ
+
+end HeckeEis.PairingSol
+end
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binaryFormRepSL linePow coe_linePow jFactor coe_smul_mul_jFactor \
+  binaryFormRepSL_linePow"
+namespace PairingSol
+p2m_open "HeckeEis"
+
+open MvPolynomial Finset UpperHalfPlane
+open scoped MatrixGroups
+
+variable (n : ℕ)
+
+theorem pairing_rep (g : SL(2, ℤ)) (P Q : ↥(BinaryForm ℂ n)) :
+    pairing n (binaryFormRepSL ℂ n g P) (binaryFormRepSL ℂ n g Q) = pairing n P Q := by
+  set B₁ : ↥(BinaryForm ℂ n) →ₗ[ℂ] ↥(BinaryForm ℂ n) →ₗ[ℂ] ℂ :=
+    (pairing n).compl₁₂ (binaryFormRepSL ℂ n g) (binaryFormRepSL ℂ n g) with hB₁
+  have hspan : Submodule.span ℂ (Set.range fun τ : ℍ => linePow n (τ : ℂ)) = ⊤ := lineSpan_eq_top n
+  have h1 : ∀ τ : ℍ, B₁ (linePow n (τ : ℂ)) = pairing n (linePow n (τ : ℂ)) := by
+    intro τ
+    refine LinearMap.ext_on hspan ?_
+    rintro _ ⟨σ, rfl⟩
+    exact pairing_rep_linePow n g τ σ
+  have h2 : B₁ = pairing n := by
+    refine LinearMap.ext_on hspan ?_
+    rintro _ ⟨τ, rfl⟩
+    exact h1 τ
+  have := congrFun (congrArg DFunLike.coe (LinearMap.congr_fun h2 P)) Q
+  exact this
+
+end HeckeEis.PairingSol
+end
+
+open scoped MatrixGroups in
+theorem solution (n : ℕ) :
+    ∃ B : ↥(HeckeEis.BinaryForm ℂ n) →ₗ[ℂ] ↥(HeckeEis.BinaryForm ℂ n) →ₗ[ℂ] ℂ,
+      (∀ (g : SL(2, ℤ)) (P Q : ↥(HeckeEis.BinaryForm ℂ n)),
+          B (HeckeEis.binaryFormRepSL ℂ n g P) (HeckeEis.binaryFormRepSL ℂ n g Q) = B P Q) ∧
+      (∀ P Q : ↥(HeckeEis.BinaryForm ℂ n), B Q P = (-1) ^ n * B P Q) ∧
+      (∀ P : ↥(HeckeEis.BinaryForm ℂ n), (∀ Q : ↥(HeckeEis.BinaryForm ℂ n), B P Q = 0) → P = 0) ∧
+      (∀ τ σ : ℂ, B (HeckeEis.linePow n τ) (HeckeEis.linePow n σ) = (τ - σ) ^ n) :=
+  ⟨HeckeEis.PairingSol.pairing n, HeckeEis.PairingSol.pairing_rep n,
+    HeckeEis.PairingSol.pairing_swap n,
+    HeckeEis.PairingSol.eq_zero_of_pairing_eq_zero n, HeckeEis.PairingSol.pairing_linePow n⟩
+
+end S_HeckeEis_exists_pairing_binaryForm_linePow
+end P2MW
+export P2MW.S_HeckeEis_exists_pairing_binaryForm_linePow (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.exists_pairing_binaryForm_linePow (n : ℕ) :
+    ∃ B : ↥(HeckeEis.BinaryForm ℂ n) →ₗ[ℂ] ↥(HeckeEis.BinaryForm ℂ n) →ₗ[ℂ] ℂ,
+      (∀ (g : SL(2, ℤ)) (P Q : ↥(HeckeEis.BinaryForm ℂ n)),
+          B (HeckeEis.binaryFormRepSL ℂ n g P) (HeckeEis.binaryFormRepSL ℂ n g Q) = B P Q) ∧
+      (∀ P Q : ↥(HeckeEis.BinaryForm ℂ n), B Q P = (-1) ^ n * B P Q) ∧
+      (∀ P : ↥(HeckeEis.BinaryForm ℂ n), (∀ Q : ↥(HeckeEis.BinaryForm ℂ n), B P Q = 0) → P = 0) ∧
+      (∀ τ σ : ℂ, B (HeckeEis.linePow n τ) (HeckeEis.linePow n σ) = (τ - σ) ^ n) :=
+  solution n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_finrank_coeffH1par_gamma0_le_finrank_coeffH1par_top_induced.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_finrank_coeffH1par_gamma0_le_finrank_coeffH1par_top_induced.lean
new file mode 100644
index 0000000000..d80755f9b2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_finrank_coeffH1par_gamma0_le_finrank_coeffH1par_top_induced.lean
@@ -0,0 +1,607 @@
+/-
+Based on Prove2Me node HeckeEis.finrank_coeffH1par_gamma0_le_finrank_coeffH1par_top_induced
+(3b95e6da-4049-5a35-810c-3de89df0e00e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c7770f6c-0e05-5212-ac9a-be8ca5205c57
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Basic.Complex.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+
+import Mathlib.Analysis.CStarAlgebra.Classes
+import Mathlib.LinearAlgebra.Matrix.FixedDetMatrices
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularGroup_exists_eq_conj_T_zpow_of_trace_sq_eq_four
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Shapiro's lemma for parabolic cohomology: dimension inequality
+
+Theorem statement: `HeckeEis.finrank_coeffH1par_gamma0_le_finrank_coeffH1par_top_induced`
+(`3b95e6da-4049-5a35-810c-3de89df0e00e`), by Claude, 2026-09-05.
+
+Proof: submission `c7770f6c-0e05-5212-ac9a-be8ca5205c57`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix an integer $N \ge 1$ and $n \ge 0$, and write $V_n$ for [`HeckeEis.BinaryForm ℂ
+n`](def/HeckeEis_BinaryFormRep.html#L25), the submodule of degree-$n$ homogeneous elements of
+$\mathbb{C}[X_0,X_1]$, on which [`HeckeEis.binaryFormRepSL ℂ
+n`](def/HeckeEis_BinaryFormRep.html#L61) has $g \in SL(2,\mathbb{Z})$ act by the linear substitution
+$X_j \mapsto \sum_i g_{ij} X_i$. Let $W$ be a representation of the full subgroup $\top \le
+SL(2,\mathbb{Z})$ on the space of functions $SL(2,\mathbb{Z})/\Gamma_0(N) \to V_n$, and assume that
+$W$ is the induced representation in the sense that $(W(g)f)(x) = g \cdot f(g^{-1} \cdot x)$ for all
+$g$, all $f$ and all cosets $x$, the action on values being `binaryFormRepSL ℂ n`. For a
+representation $\rho$ of a subgroup $\Gamma \le SL(2,\mathbb{Z})$ on a module $V$,
+[`HeckeEis.coeffH1par ρ`](def/Gamma0CoeffCohomology.html#L100) is the quotient of the submodule
+`coeffParabolicCocycles ρ` of those $z : \Gamma \to V$ which lie in `coeffCocycles ρ` and satisfy
+`IsParabolicCocycle ρ z`, by the preimage in it of `coeffCoboundaries ρ`, the range of
+`coeffCoboundaryMap ρ`. The conclusion is the inequality of $\mathbb{C}$-dimensions
+$$\dim_{\mathbb{C}} \mathrm{coeffH1par}\bigl(\mathrm{binaryFormRepSL}\,\mathbb{C}\,n \restriction
+\Gamma_0(N)\bigr) \le \dim_{\mathbb{C}} \mathrm{coeffH1par}(W),$$ the left-hand representation being
+`binaryFormRepSL ℂ n` composed with the inclusion of $\Gamma_0(N)$.
+
+This is one half of Shapiro's lemma for parabolic cohomology of the finite-index subgroup
+$\Gamma_0(N) \le SL(2,\mathbb{Z})$, recorded as the inequality of dimensions rather than as an
+isomorphism of cohomology groups. It feeds the Eichler–Shimura style dimension count
+[`HeckeEis.finrank_coeffH1par_le_two_mul_dimFormula`]
+(thm.html#HeckeEis.finrank_coeffH1par_le_two_mul_dimFormula),
+which bounds the dimension of parabolic cohomology with binary-form coefficients.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_finrank_coeffH1par_gamma0_le_finrank_coeffH1par_top_induced.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_finrank_coeffH1par_gamma0_le_finrank_coeffH1par_top_induced
+
+
+namespace HeckeEis
+p2m_export "HeckeEis" "coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff \
+  coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff \
+  BinaryForm binaryFormRepSL"
+namespace UBSol
+p2m_open "HeckeEis"
+
+open Polynomial
+
+theorem mem_range_of_geomSum_eq_zero {V : Type*} [AddCommGroup V] [Module ℂ V] (A : Module.End ℂ V)
+    {M : ℕ} (hM : 0 < M)
+    (v : V) (hv : aeval A (∑ i ∈ Finset.range M, (X : ℂ[X]) ^ i) v = 0) :
+    v ∈ LinearMap.range (A - 1) := by
+  set Φ : ℂ[X] := ∑ i ∈ Finset.range M, X ^ i with hΦ
+  have hndvd : ¬ (X - C (1 : ℂ)) ∣ Φ := by
+    intro hdvd
+    have h1 : Φ.IsRoot 1 := (Polynomial.dvd_iff_isRoot).mp hdvd
+    rw [Polynomial.IsRoot, hΦ, Polynomial.eval_finsetSum] at h1
+    simp only [Polynomial.eval_pow, Polynomial.eval_X, one_pow, Finset.sum_const, Finset.card_range,
+      nsmul_eq_mul,
+      mul_one] at h1
+    exact (Nat.cast_ne_zero.mpr hM.ne') h1
+  have hcop : IsCoprime (X - C (1 : ℂ)) Φ :=
+    (Polynomial.irreducible_X_sub_C (1 : ℂ)).coprime_iff_not_dvd.mpr hndvd
+  obtain ⟨a, b, hab⟩ := hcop
+  have key : v = aeval A (a * (X - C 1)) v := by
+    have := congrArg (fun p => aeval A p v) hab
+    simp only [map_add, map_mul, map_one, LinearMap.add_apply, Module.End.mul_apply,
+      Module.End.one_apply] at this
+    rw [show aeval A Φ v = 0 from hv, map_zero, add_zero] at this
+    rw [map_mul, Module.End.mul_apply]; exact this.symm
+  rw [key, mul_comm, map_mul, Module.End.mul_apply, map_sub, aeval_X, aeval_C,
+    Algebra.algebraMap_eq_smul_one, one_smul]
+  exact LinearMap.mem_range_self _ _
+
+theorem mem_range_of_sum_pow_apply_eq_zero {V : Type*} [AddCommGroup V] [Module ℂ V]
+    (A : Module.End ℂ V) {M : ℕ} (hM : 0 < M)
+    (v : V) (hv : ∑ i ∈ Finset.range M, (A ^ i) v = 0) : v ∈ LinearMap.range (A - 1) := by
+  apply mem_range_of_geomSum_eq_zero A hM
+  rw [map_sum, LinearMap.coe_sum, Finset.sum_apply]
+  simpa only [map_pow, aeval_X] using hv
+
+end HeckeEis.UBSol
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff \
+  coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff \
+  BinaryForm binaryFormRepSL"
+namespace UBSol
+p2m_open "HeckeEis"
+
+open scoped MatrixGroups
+open MvPolynomial
+
+variable (N : ℕ) (n : ℕ)
+
+abbrev G2 := SL(2, ℤ)
+abbrev Gt : Subgroup SL(2, ℤ) := ⊤
+abbrev Γ0 : Subgroup SL(2, ℤ) := CongruenceSubgroup.Gamma0 N
+abbrev X0 := SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N
+abbrev Vn := ↥(BinaryForm ℂ n)
+abbrev ρ : Representation ℂ SL(2, ℤ) (Vn n) := binaryFormRepSL ℂ n
+abbrev ρΓ : Representation ℂ ↥(Γ0 N) (Vn n) := (binaryFormRepSL ℂ n).comp (Γ0 N).subtype
+
+section Cosets
+
+variable {N}
+
+theorem transfer_mem (g : SL(2, ℤ)) (x : X0 N) : (x.out)⁻¹ * (g * (g⁻¹ • x).out) ∈ Γ0 N := by
+  rw [← QuotientGroup.eq, QuotientGroup.out_eq', ← smul_eq_mul, MulAction.Quotient.coe_smul_out,
+    smul_inv_smul]
+
+def tr (g : SL(2, ℤ)) (x : X0 N) : ↥(Γ0 N) := ⟨(x.out)⁻¹ * (g * (g⁻¹ • x).out), transfer_mem g x⟩
+
+@[scoped simp] theorem coe_tr (g : SL(2, ℤ)) (x : X0 N) :
+    ((tr g x : ↥(Γ0 N)) : SL(2, ℤ)) = (x.out)⁻¹ * (g * (g⁻¹ • x).out) := rfl
+
+theorem tr_mul (g h : SL(2, ℤ)) (x : X0 N) : tr (g * h) x = tr g x * tr h (g⁻¹ • x) := by
+  apply Subtype.ext
+  simp only [coe_tr, Subgroup.coe_mul, mul_inv_rev, mul_smul]
+  group
+
+theorem out_mul_tr (g : SL(2, ℤ)) (x : X0 N) :
+    x.out * ((tr g x : ↥(Γ0 N)) : SL(2, ℤ)) = g * (g⁻¹ • x).out := by
+  rw [coe_tr, mul_inv_cancel_left]
+
+theorem tr_one (x : X0 N) : tr 1 x = 1 := by
+  apply Subtype.ext
+  simp
+
+end Cosets
+
+section Shapiro
+
+variable {N n}
+variable (W : Representation ℂ ↥Gt (X0 N → Vn n))
+  (hW : ∀ (g : ↥Gt) (f : X0 N → Vn n) (x : X0 N), W g f x = ρ n (g : SL(2, ℤ)) (f (((g : SL(2,
+    ℤ))⁻¹) • x)))
+include hW
+
+def Sh (z : ↥(Γ0 N) → Vn n) : ↥Gt → X0 N → Vn n := fun g x => ρ n x.out (z (tr (g : SL(2, ℤ)) x))
+
+omit hW in
+@[scoped simp] theorem Sh_apply (z : ↥(Γ0 N) → Vn n) (g : ↥Gt) (x : X0 N) :
+    Sh z g x = ρ n x.out (z (tr (g : SL(2, ℤ)) x)) := rfl
+
+omit hW in
+theorem Sh_add (z w : ↥(Γ0 N) → Vn n) : Sh (z + w) = Sh z + Sh w := by
+  funext g x; simp
+
+omit hW in
+theorem Sh_sub (z w : ↥(Γ0 N) → Vn n) : Sh (z - w) = Sh z - Sh w := by
+  funext g x; simp
+
+omit hW in
+theorem Sh_smul (c : ℂ) (z : ↥(Γ0 N) → Vn n) : Sh (c • z) = c • Sh z := by
+  funext g x; simp
+
+theorem Sh_mem_coeffCocycles {z : ↥(Γ0 N) → Vn n} (hz : z ∈ coeffCocycles (ρΓ N n)) :
+    Sh z ∈ coeffCocycles W := by
+  intro g h
+  funext x
+  rw [Pi.add_apply, hW, Sh_apply, Sh_apply, Sh_apply]
+  rw [show ((g * h : ↥Gt) : SL(2, ℤ)) = (g : SL(2, ℤ)) * (h : SL(2, ℤ)) from rfl, tr_mul, hz]
+  rw [map_add]
+  rw [add_right_inj]
+  change ρ n x.out (ρ n ((tr (g : SL(2, ℤ)) x : ↥(Γ0 N)) : SL(2, ℤ)) (z (tr (h : SL(2, ℤ)) ((g :
+    SL(2, ℤ))⁻¹ • x)))) = _
+  rw [← Module.End.mul_apply, ← map_mul, out_mul_tr, map_mul, Module.End.mul_apply]
+
+theorem Sh_mem_coeffCoboundaries {z : ↥(Γ0 N) → Vn n} (hz : z ∈ coeffCoboundaries (ρΓ N n)) :
+    Sh z ∈ coeffCoboundaries W := by
+  rw [mem_coeffCoboundaries_iff] at hz ⊢
+  obtain ⟨v, rfl⟩ := hz
+  refine ⟨fun x => ρ n x.out v, funext fun g => funext fun x => ?_⟩
+  rw [Pi.sub_apply, hW, Sh_apply, map_sub]
+  rw [sub_left_inj]
+  change _ = ρ n x.out (ρ n ((tr (g : SL(2, ℤ)) x : ↥(Γ0 N)) : SL(2, ℤ)) v)
+  rw [← Module.End.mul_apply (ρ n x.out), ← map_mul, out_mul_tr, map_mul, Module.End.mul_apply]
+
+theorem mem_coeffCoboundaries_of_Sh {z : ↥(Γ0 N) → Vn n}
+    (h : Sh z ∈ coeffCoboundaries W) : z ∈ coeffCoboundaries (ρΓ N n) := by
+  rw [mem_coeffCoboundaries_iff] at h ⊢
+  obtain ⟨F, hF⟩ := h
+  set x0 : X0 N := ((1 : SL(2, ℤ)) : X0 N) with hx0
+  have hσ0 : x0.out ∈ Γ0 N := by
+    have := QuotientGroup.out_eq' x0
+    rw [hx0, QuotientGroup.eq] at this
+    simpa using this
+  set σ0 : ↥(Γ0 N) := ⟨x0.out, hσ0⟩ with hσ0'
+  have hfix : ∀ γ : ↥(Γ0 N), ((γ : SL(2, ℤ)))⁻¹ • x0 = x0 := by
+    intro γ
+    rw [hx0, MulAction.Quotient.smul_coe, QuotientGroup.eq]
+    simp
+  have key : ∀ γ : ↥(Γ0 N), ρ n x0.out (z (tr (γ : SL(2, ℤ)) x0)) = ρ n (γ : SL(2, ℤ)) (F x0) - F x0
+    :=
+    by
+    intro γ
+    have := congrFun (congrFun hF ⟨(γ : SL(2, ℤ)), Subgroup.mem_top _⟩) x0
+    rw [Pi.sub_apply, hW, Sh_apply] at this
+    simp only [hfix] at this
+    exact this.symm
+  have htr : ∀ γ : ↥(Γ0 N), tr (γ : SL(2, ℤ)) x0 = σ0⁻¹ * γ * σ0 := by
+    intro γ
+    apply Subtype.ext
+    rw [coe_tr, hfix]
+    simp [hσ0', mul_assoc]
+  refine ⟨ρΓ N n σ0⁻¹ (F x0), funext fun δ => ?_⟩
+  have hk := key (σ0 * δ * σ0⁻¹)
+  rw [htr, show σ0⁻¹ * (σ0 * δ * σ0⁻¹) * σ0 = δ by group] at hk
+  have : z δ = ρ n ((σ0 : ↥(Γ0 N)) : SL(2, ℤ))⁻¹ (ρ n (((σ0 * δ * σ0⁻¹ : ↥(Γ0 N))) : SL(2, ℤ)) (F
+    x0) - F x0) :=
+    by
+    rw [← hk, ← Module.End.mul_apply, ← map_mul, inv_mul_cancel, map_one, Module.End.one_apply]
+  rw [this, map_sub, ← Module.End.mul_apply, ← map_mul]
+  refine congrArg₂ (· - ·) ?_ ?_
+  swap
+  · simp only [MonoidHom.coe_comp, Function.comp_apply, Subgroup.coe_subtype, Subgroup.coe_inv]
+  change ρ n ((δ * σ0⁻¹ : ↥(Γ0 N)) : SL(2, ℤ)) (F x0) = _
+  rw [← Module.End.mul_apply (ρ n _), ← map_mul]
+  congr 2
+  rw [Subgroup.coe_mul, Subgroup.coe_mul, Subgroup.coe_mul, Subgroup.coe_inv]
+  group
+
+end Shapiro
+
+end HeckeEis.UBSol
+end
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff \
+  coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff \
+  BinaryForm binaryFormRepSL"
+namespace UBSol
+p2m_open "HeckeEis"
+
+open scoped MatrixGroups
+open MvPolynomial
+
+section Trace
+
+theorem trace_sq_eq_four_iff_exists (g : SL(2, ℤ)) :
+    ((g : Matrix (Fin 2) (Fin 2) ℤ).trace) ^ 2 = 4
+      → ∃ (ε δ : SL(2, ℤ)) (h : ℤ), (ε = 1 ∨ ε = -1) ∧ g = ε * (δ * ModularGroup.T ^ h * δ⁻¹) :=
+  ModularGroup.exists_eq_conj_T_zpow_of_trace_sq_eq_four g
+
+theorem trace_T_zpow (h : ℤ) :
+    ((ModularGroup.T ^ h : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace = 2 := by
+  rw [ModularGroup.coe_T_zpow, Matrix.trace_fin_two_of]; ring
+
+theorem trace_conj (δ g : SL(2, ℤ)) :
+    ((δ * g * δ⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace = ((g : SL(2, ℤ)) : Matrix (Fin 2)
+      (Fin 2) ℤ).trace := by
+  rw [Matrix.SpecialLinearGroup.coe_mul, Matrix.SpecialLinearGroup.coe_mul, Matrix.trace_mul_cycle,
+    ← Matrix.SpecialLinearGroup.coe_mul, inv_mul_cancel, Matrix.SpecialLinearGroup.coe_one,
+    Matrix.one_mul]
+
+theorem trace_sq_of_shape (ε δ : SL(2, ℤ)) (h : ℤ) (hε : ε = 1 ∨ ε = -1) :
+    (((ε * (δ * ModularGroup.T ^ h * δ⁻¹) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace) ^ 2 = 4 :=
+      by
+  rcases hε with rfl | rfl
+  · rw [one_mul, trace_conj, trace_T_zpow]; norm_num
+  · rw [Matrix.SpecialLinearGroup.coe_mul, Matrix.SpecialLinearGroup.coe_neg,
+      Matrix.SpecialLinearGroup.coe_one, neg_mul,
+      one_mul, Matrix.trace_neg, trace_conj, trace_T_zpow]; norm_num
+
+theorem trace_sq_pow (g : SL(2, ℤ)) (hg : ((g : Matrix (Fin 2) (Fin 2) ℤ).trace) ^ 2 = 4) (M : ℕ) :
+    (((g ^ M : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace) ^ 2 = 4 := by
+  obtain ⟨ε, δ, h, hε, rfl⟩ := trace_sq_eq_four_iff_exists g hg
+  have hcomm : Commute ε (δ * ModularGroup.T ^ h * δ⁻¹) := by
+    rcases hε with rfl | rfl
+    · exact Commute.one_left _
+    · exact (Commute.neg_one_left _)
+  rw [hcomm.mul_pow, conj_pow, ← zpow_natCast (ModularGroup.T ^ h) M, ← zpow_mul]
+  have hεM : ε ^ M = 1 ∨ ε ^ M = -1 := by
+    rcases hε with rfl | rfl
+    · left; exact one_pow M
+    · rcases neg_one_pow_eq_or SL(2, ℤ) M with h1 | h1
+      · left; exact h1
+      · right; exact h1
+  exact trace_sq_of_shape (ε ^ M) δ (h * M) hεM
+
+theorem trace_sq_conj' (a g : SL(2, ℤ)) (hg : ((g : Matrix (Fin 2) (Fin 2) ℤ).trace) ^ 2 = 4) :
+    (((a⁻¹ * (g * a) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace) ^ 2 = 4 := by
+  have := trace_conj a⁻¹ g
+  rw [inv_inv, mul_assoc] at this
+  rw [this]; exact hg
+
+end Trace
+
+section Power
+
+variable {N : ℕ} [NeZero N]
+
+noncomputable scoped instance fintypeX0 : Fintype (X0 N) := (CongruenceSubgroup.Gamma0
+  N).fintypeQuotientOfFiniteIndex
+
+theorem exists_pow_smul_eq (g : SL(2, ℤ)) : ∃ M : ℕ, 0 < M ∧ ∀ x : X0 N, g ^ M • x = x := by
+  classical
+  refine ⟨Fintype.card (Equiv.Perm (X0 N)), Fintype.card_pos, fun x => ?_⟩
+  have h : (MulAction.toPermHom SL(2, ℤ) (X0 N) g) ^ Fintype.card (Equiv.Perm (X0 N)) = 1 :=
+    pow_card_eq_one
+  rw [← map_pow] at h
+  have := Equiv.congr_fun h x
+  simpa using this
+
+end Power
+
+section PowerSum
+
+variable {N n : ℕ} {W : Representation ℂ ↥Gt (X0 N → Vn n)}
+
+theorem cocycle_pow {Z : ↥Gt → X0 N → Vn n} (hZ : Z ∈ coeffCocycles W) (g : ↥Gt) (M : ℕ) :
+    Z (g ^ M) = ∑ i ∈ Finset.range M, ((W g) ^ i) (Z g) := by
+  induction M with
+  | zero =>
+    rw [pow_zero, Finset.sum_range_zero]
+    have h := hZ 1 1
+    rw [mul_one, map_one, Module.End.one_apply] at h
+    simpa using h
+  | succ M ih =>
+    rw [pow_succ', hZ, ih, Finset.sum_range_succ', pow_zero, Module.End.one_apply, add_comm,
+      map_sum]
+    congr 1
+    exact Finset.sum_congr rfl fun i _ => by rw [pow_succ', Module.End.mul_apply]
+
+end PowerSum
+
+section Parabolic
+
+variable {N n : ℕ} [NeZero N]
+variable (W : Representation ℂ ↥Gt (X0 N → Vn n))
+  (hW : ∀ (g : ↥Gt) (f : X0 N → Vn n) (x : X0 N), W g f x = ρ n (g : SL(2, ℤ)) (f (((g : SL(2,
+    ℤ))⁻¹) • x)))
+include hW
+
+theorem Sh_mem_coeffParabolicCocycles {z : ↥(Γ0 N) → Vn n}
+    (hz : z ∈ coeffParabolicCocycles (ρΓ N n)) :
+    Sh z ∈ coeffParabolicCocycles W := by
+  classical
+  refine ⟨Sh_mem_coeffCocycles W hW hz.1, fun g hg => ?_⟩
+  obtain ⟨M, hM, hfix⟩ := exists_pow_smul_eq (N := N) (g : SL(2, ℤ))
+  have hfix' : ∀ x : X0 N, ((g : SL(2, ℤ)) ^ M)⁻¹ • x = x := fun x => by
+    conv_lhs => rw [← hfix x]
+    rw [inv_smul_smul]
+  have hγ : ∀ x : X0 N, (((tr ((g : SL(2, ℤ)) ^ M) x : ↥(Γ0 N)) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2)
+    ℤ).trace ^ 2 = 4 :=
+    by
+    intro x
+    rw [coe_tr, hfix']
+    exact trace_sq_conj' _ _ (trace_sq_pow _ hg M)
+  choose u hu using fun x => hz.2 (tr ((g : SL(2, ℤ)) ^ M) x) (hγ x)
+  set F : X0 N → Vn n := fun x => ρ n x.out (u x) with hF
+  set A : Module.End ℂ (X0 N → Vn n) := W g with hA
+  have h1 : Sh z (g ^ M) = (A ^ M - 1) F := by
+    funext x
+    rw [Sh_apply, LinearMap.sub_apply, Module.End.one_apply, hA, ← map_pow, Pi.sub_apply, hW]
+    rw [show (((g ^ M : ↥Gt)) : SL(2, ℤ)) = (g : SL(2, ℤ)) ^ M from rfl, hfix']
+    have hx := hu x
+    rw [LinearMap.sub_apply, Module.End.one_apply] at hx
+    rw [← hx, map_sub]
+    refine congrArg₂ (· - ·) ?_ rfl
+    change ρ n x.out (ρ n ((tr ((g : SL(2, ℤ)) ^ M) x : ↥(Γ0 N)) : SL(2, ℤ)) (u x)) = _
+    rw [← Module.End.mul_apply (ρ n x.out), ← map_mul, out_mul_tr, hfix', map_mul,
+      Module.End.mul_apply]
+  have h2 := cocycle_pow (Sh_mem_coeffCocycles W hW hz.1) g M
+  have h3 : (A ^ M - 1) F = ∑ i ∈ Finset.range M, (A ^ i) ((A - 1) F) := by
+    rw [← geom_sum_mul A M, Module.End.mul_apply, LinearMap.coe_sum, Finset.sum_apply]
+  have hsum : ∑ i ∈ Finset.range M, (A ^ i) (Sh z g - (A - 1) F) = 0 := by
+    simp only [map_sub, Finset.sum_sub_distrib]
+    rw [← h2, ← h3, h1, sub_self]
+  obtain ⟨w, hw⟩ := mem_range_of_sum_pow_apply_eq_zero A hM _ hsum
+  exact ⟨w + F, by rw [map_add, hw, sub_add_cancel]⟩
+
+end Parabolic
+end HeckeEis.UBSol
+end
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff \
+  coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff \
+  BinaryForm binaryFormRepSL"
+namespace UBSol
+p2m_open "HeckeEis"
+
+open scoped MatrixGroups
+open MvPolynomial
+
+section Final
+
+variable {N n : ℕ} [NeZero N]
+variable (W : Representation ℂ ↥Gt (X0 N → Vn n))
+  (hW : ∀ (g : ↥Gt) (f : X0 N → Vn n) (x : X0 N), W g f x = ρ n (g : SL(2, ℤ)) (f (((g : SL(2,
+    ℤ))⁻¹) • x)))
+include hW
+
+omit [NeZero N] hW in
+theorem eq_zero_of_apply_S_T {Z : ↥Gt → X0 N → Vn n} (hZ : Z ∈ coeffCocycles W)
+    (hS : Z ⟨ModularGroup.S, Subgroup.mem_top _⟩ = 0)
+    (hT : Z ⟨ModularGroup.T, Subgroup.mem_top _⟩ = 0) : Z = 0 := by
+  have z1 : Z 1 = 0 := by
+    have h := hZ 1 1
+    rw [mul_one, map_one, Module.End.one_apply] at h
+    simpa using h
+  have zinv : ∀ g : ↥Gt, Z g⁻¹ = -(W g⁻¹ (Z g)) := fun g => by
+    have h := hZ g⁻¹ g
+    rw [inv_mul_cancel, z1] at h
+    exact eq_neg_of_add_eq_zero_left h.symm
+  funext g
+  have hg : (g : SL(2, ℤ)) ∈ Subgroup.closure ({ModularGroup.S, ModularGroup.T} : Set SL(2, ℤ)) :=
+    by
+    rw [SpecialLinearGroup.SL2Z_generators]; trivial
+  have key : ∀ x (hx : x ∈ Subgroup.closure ({ModularGroup.S, ModularGroup.T} : Set SL(2, ℤ))), Z
+    ⟨x, Subgroup.mem_top _⟩ = 0 :=
+    by
+    intro x hx
+    induction hx using Subgroup.closure_induction with
+    | mem x hx =>
+      rcases hx with rfl | rfl
+      · exact hS
+      · exact hT
+    | one => exact z1
+    | mul x y _ _ hx hy =>
+      have := hZ ⟨x, Subgroup.mem_top _⟩ ⟨y, Subgroup.mem_top _⟩
+      rw [hx, hy, map_zero, add_zero] at this
+      exact this
+    | inv x _ hx =>
+      have := zinv ⟨x, Subgroup.mem_top _⟩
+      rw [hx, map_zero, neg_zero] at this
+      exact this
+  rw [key g hg]; rfl
+
+omit hW in
+theorem finite_binaryForm : Module.Finite ℂ (Vn n) := by
+  classical
+  rw [Module.Finite.iff_fg, show (BinaryForm ℂ n : Submodule ℂ (MvPolynomial (Fin 2) ℂ)) =
+    MvPolynomial.homogeneousSubmodule (Fin 2) ℂ n from rfl,
+    MvPolynomial.homogeneousSubmodule_eq_finsupp_supported,
+    AddMonoidAlgebra.supported_eq_span_single]
+  refine Submodule.fg_span (Set.Finite.image _ ?_)
+  refine Set.Finite.subset (Set.Finite.image (fun i : ℕ => Finsupp.single (0 : Fin 2) i +
+    Finsupp.single 1 (n - i)) (Set.finite_Iic n)) ?_
+  intro d hd
+  have hsum : d 0 + d 1 = n := by
+    have : d.degree = n := hd
+    rw [← this, Finsupp.degree_eq_sum, Fin.sum_univ_two]
+  refine ⟨d 0, (by change d 0 ≤ n; omega), ?_⟩
+  ext j; fin_cases j
+  · simp
+  · simp; omega
+
+omit hW in
+theorem finite_coeffParabolicCocycles : Module.Finite ℂ ↥(coeffParabolicCocycles W) := by
+  have : Module.Finite ℂ (Vn n) := finite_binaryForm
+  let E : ↥(coeffParabolicCocycles W) →ₗ[ℂ] (X0 N → Vn n) × (X0 N → Vn n) :=
+    { toFun := fun Z => ((Z : ↥Gt → X0 N → Vn n) ⟨ModularGroup.S, Subgroup.mem_top _⟩,
+                        (Z : ↥Gt → X0 N → Vn n) ⟨ModularGroup.T, Subgroup.mem_top _⟩)
+      map_add' := fun _ _ => rfl
+      map_smul' := fun _ _ => rfl }
+  refine Module.Finite.of_injective E fun Z Z' h => ?_
+  rw [← sub_eq_zero]
+  apply Subtype.ext
+  have h1 := congrArg Prod.fst h
+  have h2 := congrArg Prod.snd h
+  refine eq_zero_of_apply_S_T W (Z - Z').2.1 ?_ ?_
+  · change (Z : ↥Gt → X0 N → Vn n) _ - (Z' : ↥Gt → X0 N → Vn n) _ = 0
+    exact sub_eq_zero.mpr h1
+  · change (Z : ↥Gt → X0 N → Vn n) _ - (Z' : ↥Gt → X0 N → Vn n) _ = 0
+    exact sub_eq_zero.mpr h2
+
+def ShPC : ↥(coeffParabolicCocycles (ρΓ N n)) →ₗ[ℂ] ↥(coeffParabolicCocycles W) where
+  toFun z := ⟨Sh (z : ↥(Γ0 N) → Vn n), Sh_mem_coeffParabolicCocycles W hW z.2⟩
+  map_add' z w := by
+    apply Subtype.ext
+    change Sh ((z : ↥(Γ0 N) → Vn n) + (w : ↥(Γ0 N) → Vn n)) = Sh (z : ↥(Γ0 N) → Vn n) + Sh (w : ↥(Γ0
+      N) → Vn n)
+    exact Sh_add _ _
+  map_smul' c z := by
+    apply Subtype.ext
+    change Sh (c • (z : ↥(Γ0 N) → Vn n)) = c • Sh (z : ↥(Γ0 N) → Vn n)
+    exact Sh_smul _ _
+
+@[scoped simp] theorem coe_ShPC (z : ↥(coeffParabolicCocycles (ρΓ N n))) :
+    ((ShPC W hW z : ↥(coeffParabolicCocycles W)) : ↥Gt → X0 N → Vn n) = Sh (z : ↥(Γ0 N) → Vn n) :=
+      rfl
+
+theorem mk_ShPC_congr {a b : ↥(coeffParabolicCocycles (ρΓ N n))}
+    (h : coeffH1parMk _ a = coeffH1parMk _ b) :
+    coeffH1parMk _ (ShPC W hW a) = coeffH1parMk _ (ShPC W hW b) := by
+  rw [← sub_eq_zero, ← map_sub, coeffH1parMk_eq_zero_iff] at h ⊢
+  change Sh (a : ↥(Γ0 N) → Vn n) - Sh (b : ↥(Γ0 N) → Vn n) ∈ coeffCoboundaries W
+  rw [← Sh_sub]
+  exact Sh_mem_coeffCoboundaries W hW h
+
+def Ψ : coeffH1par (ρΓ N n) →ₗ[ℂ] coeffH1par W where
+  toFun x := coeffH1parMk _ (ShPC W hW (Function.surjInv (coeffH1parMk_surjective _) x))
+  map_add' x y := by
+    rw [← map_add, ← map_add]
+    apply mk_ShPC_congr
+    rw [map_add, Function.surjInv_eq (coeffH1parMk_surjective _), Function.surjInv_eq
+      (coeffH1parMk_surjective _),
+      Function.surjInv_eq (coeffH1parMk_surjective _)]
+  map_smul' c x := by
+    rw [RingHom.id_apply, ← map_smul, ← map_smul]
+    apply mk_ShPC_congr
+    rw [map_smul, Function.surjInv_eq (coeffH1parMk_surjective _), Function.surjInv_eq
+      (coeffH1parMk_surjective _)]
+
+theorem Ψ_mk (z : ↥(coeffParabolicCocycles (ρΓ N n))) :
+    Ψ W hW (coeffH1parMk _ z) = coeffH1parMk _ (ShPC W hW z) := by
+  change coeffH1parMk _ (ShPC W hW (Function.surjInv (coeffH1parMk_surjective _) (coeffH1parMk _
+    z))) = _
+  apply mk_ShPC_congr
+  rw [Function.surjInv_eq (coeffH1parMk_surjective _)]
+
+theorem Ψ_injective : Function.Injective (Ψ W hW) := by
+  rw [← LinearMap.ker_eq_bot, LinearMap.ker_eq_bot']
+  intro x hx
+  obtain ⟨z, rfl⟩ := coeffH1parMk_surjective _ x
+  rw [Ψ_mk, coeffH1parMk_eq_zero_iff, coe_ShPC] at hx
+  rw [coeffH1parMk_eq_zero_iff]
+  exact mem_coeffCoboundaries_of_Sh W hW hx
+
+theorem main :
+    Module.finrank ℂ (coeffH1par (ρΓ N n)) ≤ Module.finrank ℂ (coeffH1par W) := by
+  have := finite_coeffParabolicCocycles W
+  have : Module.Finite ℂ (coeffH1par W) :=
+    Module.Finite.of_surjective (coeffH1parMk W) (coeffH1parMk_surjective W)
+  exact LinearMap.finrank_le_finrank_of_injective (Ψ_injective W hW)
+
+end Final
+end HeckeEis.UBSol
+end
+
+open scoped MatrixGroups in
+theorem solution (N : ℕ) [NeZero N] (n : ℕ)
+    (W : Representation ℂ (⊤ : Subgroup SL(2, ℤ)) (SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N →
+      ↥(HeckeEis.BinaryForm ℂ n)))
+    (hW : ∀ (g : (⊤ : Subgroup SL(2, ℤ))) (f : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N →
+      ↥(HeckeEis.BinaryForm ℂ n)) (x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N),
+      W g f x = HeckeEis.binaryFormRepSL ℂ n (g : SL(2, ℤ)) (f (((g : SL(2, ℤ))⁻¹) • x))) :
+    Module.finrank ℂ (HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype))
+      ≤ Module.finrank ℂ (HeckeEis.coeffH1par W) :=
+  HeckeEis.UBSol.main W hW
+
+end S_HeckeEis_finrank_coeffH1par_gamma0_le_finrank_coeffH1par_top_induced
+end P2MW
+export P2MW.S_HeckeEis_finrank_coeffH1par_gamma0_le_finrank_coeffH1par_top_induced (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.finrank_coeffH1par_gamma0_le_finrank_coeffH1par_top_induced (N : ℕ) [NeZero N]
+    (n : ℕ)
+    (W : Representation ℂ (⊤ : Subgroup SL(2, ℤ)) (SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N →
+      ↥(HeckeEis.BinaryForm ℂ n)))
+    (hW : ∀ (g : (⊤ : Subgroup SL(2, ℤ))) (f : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N →
+      ↥(HeckeEis.BinaryForm ℂ n)) (x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N),
+      W g f x = HeckeEis.binaryFormRepSL ℂ n (g : SL(2, ℤ)) (f (((g : SL(2, ℤ))⁻¹) • x))) :
+    Module.finrank ℂ (HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype))
+      ≤ Module.finrank ℂ (HeckeEis.coeffH1par W) :=
+  solution N n W hW
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_finrank_coeffH1par_le_two_mul_dimFormula.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_finrank_coeffH1par_le_two_mul_dimFormula.lean
new file mode 100644
index 0000000000..7e035ca799
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_finrank_coeffH1par_le_two_mul_dimFormula.lean
@@ -0,0 +1,211 @@
+/-
+Based on Prove2Me node HeckeEis.finrank_coeffH1par_le_two_mul_dimFormula
+(4ef8529a-5a8c-5298-9937-0d3aa73d3421) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 57a143ca-04dc-57e8-85f1-3f8ab778fc5b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Basic.Complex.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+
+import Mathlib.Data.Rat.Star
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_induced_binaryFormRepSL_top
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_finrank_coeffH1par_gamma0_le_finrank_coeffH1par_top_induced
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_finrank_coeffH1par_top_add_le
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_le_finrank_fixed_S_and_ST_binaryFormRepSL
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_le_finrank_fixed_induced_binaryFormRepSL
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_Gamma0_index
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_fixedPoints_ST_cosets_Gamma0_eq_nuThree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_fixedPoints_S_cosets_Gamma0_eq_nuTwo
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_orbitRelQuotient_zpowers_T_gamma0_eq_cuspCount
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Upper bound for parabolic H¹ of Γ₀(N) in binary forms
+
+Theorem statement: `HeckeEis.finrank_coeffH1par_le_two_mul_dimFormula`
+(`4ef8529a-5a8c-5298-9937-0d3aa73d3421`), by Claude, 2026-09-05.
+
+Proof: submission `57a143ca-04dc-57e8-85f1-3f8ab778fc5b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N\ge 1$ and let $n$ be a natural number with $2\le n$ and $n$ even. Consider the representation
+of $\mathrm{SL}_2(\mathbb Z)$ on the space $\mathrm{BinaryForm}\,\mathbb C\,n$ of homogeneous
+polynomials of degree $n$ in two variables over $\mathbb C$, where a matrix $M$ acts by the
+substitution $X_j\mapsto \sum_i M_{ij}X_i$, and restrict it along the inclusion of $\Gamma_0(N)$
+into $\mathrm{SL}_2(\mathbb Z)$. The space
+[`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100) of this restricted representation is
+the quotient of the submodule of those functions $\Gamma_0(N)\to \mathrm{BinaryForm}\,\mathbb C\,n$
+that are cocycles and satisfy the parabolicity condition `IsParabolicCocycle`, by the submodule of
+those among them lying in the image of the coboundary map. The assertion is the inequality, in
+$\mathbb Q$, $$\dim_{\mathbb C}\mathrm{coeffH1par}\le
+2\Bigl[\bigl((n+2)-1\bigr)\bigl(g_N-1\bigr)+\lfloor (n+2)/4\rfloor\,\nu_2(N)+\lfloor
+(n+2)/3\rfloor\,\nu_3(N)+\bigl(\tfrac{n+2}{2}-1\bigr)\,c(N)\Bigr],$$ where the two floor terms are
+natural-number divisions cast into $\mathbb Q$ while $(n+2)/2$ is division in $\mathbb Q$; here
+$\nu_2(N)=\#\{x\in\mathbb Z/N: x^2+1=0\}$, $\nu_3(N)=\#\{x\in\mathbb Z/N: x^2+x+1=0\}$,
+$c(N)=\sum_{d\mid N}\varphi(\gcd(d,N/d))$, and $g_N=1+\psi(N)/12-\nu_2(N)/4-\nu_3(N)/3-c(N)/2$ with
+$\psi(N)=\sum_{d\mid N,\ d\ \text{squarefree}}N/d$.
+
+The bracketed quantity is the classical dimension formula for $S_{n+2}(\Gamma_0(N))$ in terms of the
+genus and the numbers of elliptic points of order $2$, $3$ and of cusps of $X_0(N)$, so the
+statement is the easy half of the Eichler–Shimura comparison: parabolic cohomology in the $n$-th
+symmetric power is at most twice the space of cusp forms of weight $n+2$. It is used in establishing
+that the image of the Eichler–Shimura map and the image of its conjugate are complementary.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_finrank_coeffH1par_le_two_mul_dimFormula.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_finrank_coeffH1par_le_two_mul_dimFormula
+
+
+open scoped MatrixGroups
+
+theorem UHAsm.finite_binaryForm (n : ℕ) : Module.Finite ℂ ↥(HeckeEis.BinaryForm ℂ n) := by
+  classical
+  rw [Module.Finite.iff_fg, show (HeckeEis.BinaryForm ℂ n : Submodule ℂ (MvPolynomial (Fin 2) ℂ)) =
+    MvPolynomial.homogeneousSubmodule (Fin 2) ℂ n from rfl,
+    MvPolynomial.homogeneousSubmodule_eq_finsupp_supported,
+    AddMonoidAlgebra.supported_eq_span_single]
+  refine Submodule.fg_span (Set.Finite.image _ ?_)
+  refine Set.Finite.subset (Set.Finite.image (fun i : ℕ => Finsupp.single (0 : Fin 2) i +
+    Finsupp.single 1 (n - i)) (Set.finite_Iic n)) ?_
+  intro d hd
+  have hsum : d 0 + d 1 = n := by
+    have : d.degree = n := hd
+    rw [← this, Finsupp.degree_eq_sum, Fin.sum_univ_two]
+  refine ⟨d 0, (by change d 0 ≤ n; omega), ?_⟩
+  ext j; fin_cases j
+  · simp
+  · simp; omega
+
+theorem solution (N : ℕ) [NeZero N] (n : ℕ) (hn : 2 ≤ n) (hne : Even n) :
+    (Module.finrank ℂ (HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)) : ℚ)
+      ≤ 2 * ((((n + 2) : ℚ) - 1) * (ModularCurve.genusFormula N - 1) + (((n + 2) / 4 : ℕ) : ℚ) *
+        (ModularCurve.nuTwo N : ℚ)
+        + (((n + 2) / 3 : ℕ) : ℚ) * (ModularCurve.nuThree N : ℚ) + (((n + 2) : ℚ) / 2 - 1) *
+          (ModularCurve.cuspCount N : ℚ)) := by
+  classical
+  have : Module.Finite ℂ ↥(HeckeEis.BinaryForm ℂ n) := UHAsm.finite_binaryForm n
+  have : (CongruenceSubgroup.Gamma0 N).FiniteIndex := inferInstance
+  let : Fintype (SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N) :=
+    (CongruenceSubgroup.Gamma0 N).fintypeQuotientOfFiniteIndex
+  obtain ⟨W, hW, hneg, hinv, hcoinv⟩ :=
+    HeckeEis.exists_induced_binaryFormRepSL_top N n hne (by omega)
+  have hB := HeckeEis.finrank_coeffH1par_gamma0_le_finrank_coeffH1par_top_induced N n W hW
+  have hA := HeckeEis.finrank_coeffH1par_top_add_le W hneg hinv hcoinv
+  obtain ⟨h1, h2⟩ := HeckeEis.le_finrank_fixed_S_and_ST_binaryFormRepSL n hne
+  obtain ⟨hW0, hS, hU, hT⟩ := HeckeEis.le_finrank_fixed_induced_binaryFormRepSL N n hne W hW
+  have hν₂ := ModularCurve.natCard_fixedPoints_S_cosets_Gamma0_eq_nuTwo N
+  have hν₃ := ModularCurve.natCard_fixedPoints_ST_cosets_Gamma0_eq_nuThree N
+  have hc := ModularCurve.natCard_orbitRelQuotient_zpowers_T_gamma0_eq_cuspCount N
+  have hμ := ModularCurve.Gamma0_index N
+  have hle₂ : Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N // ModularGroup.S • x = x} ≤
+    (CongruenceSubgroup.Gamma0 N).index :=
+    by
+    rw [Subgroup.index]; exact Finite.card_subtype_le _
+  have hle₃ : Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N // (ModularGroup.S *
+    ModularGroup.T) • x = x} ≤ (CongruenceSubgroup.Gamma0 N).index :=
+    by
+    rw [Subgroup.index]; exact Finite.card_subtype_le _
+  have hq4 : 2 * ((n + 2) / 4) ≤ n + 1 := by omega
+  have hq3 : 2 * ((n + 2) / 3) ≤ n + 1 := by omega
+  set Hn := Module.finrank ℂ (HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+    (CongruenceSubgroup.Gamma0 N).subtype)) with hHn
+  set Pw := Module.finrank ℂ (HeckeEis.coeffH1par W)
+  set A := Module.finrank ℂ ↥(LinearMap.ker (W ⟨ModularGroup.S, Subgroup.mem_top _⟩ - 1))
+  set Bk := Module.finrank ℂ ↥(LinearMap.ker (W ⟨ModularGroup.S * ModularGroup.T, Subgroup.mem_top
+    _⟩ - 1))
+  set Tk := Module.finrank ℂ ↥(LinearMap.ker (W ⟨ModularGroup.T, Subgroup.mem_top _⟩ - 1))
+  set aS := Module.finrank ℂ ↥(LinearMap.ker (HeckeEis.binaryFormRepSL ℂ n ModularGroup.S - 1))
+  set aU := Module.finrank ℂ ↥(LinearMap.ker (HeckeEis.binaryFormRepSL ℂ n (ModularGroup.S *
+    ModularGroup.T) - 1))
+  set ν₂ := Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N // ModularGroup.S • x = x}
+  set ν₃ := Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N // (ModularGroup.S *
+    ModularGroup.T) • x = x}
+  set cc := Nat.card (MulAction.orbitRel.Quotient (Subgroup.zpowers ModularGroup.T) (SL(2, ℤ) ⧸
+    CongruenceSubgroup.Gamma0 N))
+  set μ := (CongruenceSubgroup.Gamma0 N).index
+  have hmain : 6 * Hn + 3 * (2 * (ν₂ * aS) + (μ - ν₂) * (n + 1)) + 2 * (3 * (ν₃ * aU) + (μ - ν₃) *
+    (n + 1)) + 6 * cc
+      ≤ 6 * ((n + 1) * μ) := by
+    rw [hW0] at hA
+    linarith [hB, hA, hS, hU, hT]
+  have hmain' : 6 * Hn + 3 * (2 * (ν₂ * (n + 1 - 2 * ((n + 2) / 4))) + (μ - ν₂) * (n + 1))
+      + 2 * (3 * (ν₃ * (n + 1 - 2 * ((n + 2) / 3))) + (μ - ν₃) * (n + 1)) + 6 * cc ≤ 6 * ((n + 1) *
+        μ) := by
+    have e1 : ν₂ * (n + 1 - 2 * ((n + 2) / 4)) ≤ ν₂ * aS := Nat.mul_le_mul_left _ h1
+    have e2 : ν₃ * (n + 1 - 2 * ((n + 2) / 3)) ≤ ν₃ * aU := Nat.mul_le_mul_left _ h2
+    omega
+  have hQ : (6 : ℚ) * Hn + 3 * (2 * ((ν₂ : ℚ) * ((n : ℚ) + 1 - 2 * (((n + 2) / 4 : ℕ) : ℚ))) + ((μ :
+    ℚ) - ν₂) * ((n : ℚ) + 1))
+      + 2 * (3 * ((ν₃ : ℚ) * ((n : ℚ) + 1 - 2 * (((n + 2) / 3 : ℕ) : ℚ))) + ((μ : ℚ) - ν₃) * ((n :
+        ℚ) + 1)) + 6 * (cc : ℚ)
+      ≤ 6 * (((n : ℚ) + 1) * μ) := by
+    have := hmain'
+    have c1 : ((n + 1 - 2 * ((n + 2) / 4) : ℕ) : ℚ) = (n : ℚ) + 1 - 2 * (((n + 2) / 4 : ℕ) : ℚ) :=
+      by
+      rw [Nat.cast_sub hq4]; push_cast; ring
+    have c2 : ((n + 1 - 2 * ((n + 2) / 3) : ℕ) : ℚ) = (n : ℚ) + 1 - 2 * (((n + 2) / 3 : ℕ) : ℚ) :=
+      by
+      rw [Nat.cast_sub hq3]; push_cast; ring
+    have c3 : ((μ - ν₂ : ℕ) : ℚ) = (μ : ℚ) - ν₂ := Nat.cast_sub hle₂
+    have c4 : ((μ - ν₃ : ℕ) : ℚ) = (μ : ℚ) - ν₃ := Nat.cast_sub hle₃
+    have := (Nat.cast_le (α := ℚ)).mpr hmain'
+    push_cast [c1, c2, c3, c4] at this
+    linarith
+  rw [hν₂] at hQ; rw [hν₃] at hQ; rw [hc] at hQ; rw [hμ] at hQ
+  have hg : ModularCurve.genusFormula N = 1 + (ModularCurve.dedekindPsi N : ℚ) / 12 -
+    (ModularCurve.nuTwo N : ℚ) / 4
+      - (ModularCurve.nuThree N : ℚ) / 3 - (ModularCurve.cuspCount N : ℚ) / 2 := rfl
+  have key : (12 : ℚ) * ((((n + 2) : ℚ) - 1) * (ModularCurve.genusFormula N - 1) + (((n + 2) / 4 :
+    ℕ) : ℚ) * (ModularCurve.nuTwo N : ℚ)
+        + (((n + 2) / 3 : ℕ) : ℚ) * (ModularCurve.nuThree N : ℚ) + (((n + 2) : ℚ) / 2 - 1) *
+          (ModularCurve.cuspCount N : ℚ))
+      = 6 * (((n : ℚ) + 1) * (ModularCurve.dedekindPsi N : ℚ))
+        - (3 * (2 * ((ModularCurve.nuTwo N : ℚ) * ((n : ℚ) + 1 - 2 * (((n + 2) / 4 : ℕ) : ℚ)))
+              + ((ModularCurve.dedekindPsi N : ℚ) - ModularCurve.nuTwo N) * ((n : ℚ) + 1))
+          + 2 * (3 * ((ModularCurve.nuThree N : ℚ) * ((n : ℚ) + 1 - 2 * (((n + 2) / 3 : ℕ) : ℚ)))
+              + ((ModularCurve.dedekindPsi N : ℚ) - ModularCurve.nuThree N) * ((n : ℚ) + 1))
+          + 6 * (ModularCurve.cuspCount N : ℚ)) := by
+    rw [hg]; ring
+  linarith [hQ, key]
+
+end S_HeckeEis_finrank_coeffH1par_le_two_mul_dimFormula
+end P2MW
+export P2MW.S_HeckeEis_finrank_coeffH1par_le_two_mul_dimFormula (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.finrank_coeffH1par_le_two_mul_dimFormula (N : ℕ) [NeZero N] (n : ℕ) (hn : 2 ≤ n)
+    (hne : Even n) :
+    (Module.finrank ℂ (HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)) : ℚ)
+      ≤ 2 * ((((n + 2) : ℚ) - 1) * (ModularCurve.genusFormula N - 1) + (((n + 2) / 4 : ℕ) : ℚ) *
+        (ModularCurve.nuTwo N : ℚ)
+        + (((n + 2) / 3 : ℕ) : ℚ) * (ModularCurve.nuThree N : ℚ) + (((n + 2) : ℚ) / 2 - 1) *
+          (ModularCurve.cuspCount N : ℚ)) :=
+  solution N n hn hne
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_finrank_coeffH1par_top_add_le.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_finrank_coeffH1par_top_add_le.lean
new file mode 100644
index 0000000000..4e6b60d087
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_finrank_coeffH1par_top_add_le.lean
@@ -0,0 +1,502 @@
+/-
+Based on Prove2Me node HeckeEis.finrank_coeffH1par_top_add_le
+(09d43972-ece9-52d3-bf78-53cfcb5e7dc8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 681a125a-6dca-5d6b-8fc1-b096b029b391
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Basic.Complex.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+
+import Mathlib.Algebra.CharP.Invertible
+import Mathlib.LinearAlgebra.FreeModule.PID
+import Mathlib.LinearAlgebra.Matrix.FixedDetMatrices
+import Mathlib.RingTheory.Finiteness.Prod
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Dimension bound for parabolic cohomology of SL₂(ℤ)
+
+Theorem statement: `HeckeEis.finrank_coeffH1par_top_add_le`
+(`09d43972-ece9-52d3-bf78-53cfcb5e7dc8`), by Claude, 2026-09-05.
+
+Proof: submission `681a125a-6dca-5d6b-8fc1-b096b029b391`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $V$ be a finite-dimensional complex vector space and let $W$ be a representation of the full
+subgroup $\top$ of $SL(2,\mathbb{Z})$ on $V$ over $\mathbb{C}$. Assume: (i) the element $-1$ acts as
+the identity, $W(-1) = \mathrm{id}$; (ii) $W$ has no nonzero invariants, i.e. any $v \in V$ fixed by
+every $g$ is $0$; (iii) the coinvariance condition that every $v \in V$ can be written as $(W(S)a -
+a) + (W(ST)b - b)$ for some $a, b \in V$, where $S$ and $T$ are the standard generators
+`ModularGroup.S` and `ModularGroup.T`. Then the sum of the four complex dimensions
+$$\dim_{\mathbb{C}} H^1_{\mathrm{par}} + \dim_{\mathbb{C}} \ker(W(S) - 1) + \dim_{\mathbb{C}}
+\ker(W(ST) - 1) + \dim_{\mathbb{C}} \ker(W(T) - 1)$$ is at most $\dim_{\mathbb{C}} V$. Here
+$H^1_{\mathrm{par}}$ is [`HeckeEis.coeffH1par W`](def/Gamma0CoeffCohomology.html#L100), the quotient
+of the submodule of those maps $\top \to V$ which are cocycles for $W$ (`coeffCocycles`) and satisfy
+the parabolicity predicate `IsParabolicCocycle`, by the intersection of that submodule with the
+coboundaries, namely the range of `coeffCoboundaryMap` for $W$.
+
+This is the Eichler–Shimura style dimension count for parabolic cohomology of the modular group,
+here in the form of an inequality (classically an equality, with correction terms given by the
+invariants and coinvariants, both assumed to vanish). It is used to bound the dimension of parabolic
+cohomology with coefficients in a representation of $\Gamma_0(N)$ against the weight-$k$ dimension
+formula, via
+[`HeckeEis.finrank_coeffH1par_le_two_mul_dimFormula`]
+(thm.html#HeckeEis.finrank_coeffH1par_le_two_mul_dimFormula).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_finrank_coeffH1par_top_add_le.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_finrank_coeffH1par_top_add_le
+
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "coeffCocycles coeffCoboundaryMap coeffCoboundaryMap_apply coeffCoboundaries \
+  coeffParabolicCocycles coeffCoboundaries_le_coeffParabolicCocycles coeffH1par"
+namespace UASol
+p2m_open "HeckeEis"
+
+open scoped MatrixGroups
+open ModularGroup
+
+abbrev Gt : Subgroup SL(2, ℤ) := ⊤
+
+def eS : ↥Gt := ⟨S, Subgroup.mem_top _⟩
+def eT : ↥Gt := ⟨T, Subgroup.mem_top _⟩
+def eU : ↥Gt := ⟨S * T, Subgroup.mem_top _⟩
+def eN : ↥Gt := ⟨-1, Subgroup.mem_top _⟩
+
+theorem S_mul_S : S * S = -1 := by
+  ext i j; fin_cases i <;> fin_cases j <;> simp [ModularGroup.S]
+
+theorem ST_pow_three : S * T * (S * T) * (S * T) = -1 := by
+  ext i j; fin_cases i <;> fin_cases j <;> simp [ModularGroup.S, ModularGroup.T, Matrix.mul_apply,
+    Fin.sum_univ_two]
+
+theorem eS_mul_eS : eS * eS = eN := Subtype.ext S_mul_S
+theorem eU_mul_eU_mul_eU : eU * eU * eU = eN := Subtype.ext ST_pow_three
+theorem eN_mul_eN :
+    eN * eN = 1 := Subtype.ext (by change (-1 : SL(2, ℤ)) * -1 = 1; rw [neg_mul_neg, one_mul])
+theorem eN_mul_comm (g : ↥Gt) :
+    eN * g = g * eN := Subtype.ext (by change (-1 : SL(2, ℤ)) * g = g * -1; rw [neg_one_mul,
+      mul_neg_one])
+
+theorem eS_inv : eS⁻¹ = eN * eS := by
+  rw [inv_eq_iff_mul_eq_one, eN_mul_comm, ← mul_assoc, eS_mul_eS, eN_mul_eN]
+theorem eT_eq : eT = eS⁻¹ * eU := by
+  apply Subtype.ext
+  change T = S⁻¹ * (S * T)
+  rw [← mul_assoc, inv_mul_cancel, one_mul]
+
+theorem trace_T_sq : ((T : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace ^ 2 = 4 := by
+  simp [ModularGroup.T, Matrix.trace, Fin.sum_univ_two]
+
+variable {V : Type} [AddCommGroup V] [Module ℂ V]
+
+section CocycleFacts
+
+variable (W : Representation ℂ ↥Gt V) (hneg : W eN = LinearMap.id)
+include hneg
+
+theorem W_eS_inv : W eS⁻¹ = W eS := by rw [eS_inv, map_mul, hneg]; rfl
+
+variable {W}
+variable {z : ↥Gt → V} (hz : z ∈ coeffCocycles W)
+include hz
+
+omit hneg in
+theorem z_one : z 1 = 0 := by
+  have h := hz 1 1
+  rw [mul_one, map_one, Module.End.one_apply] at h
+  simpa using h
+
+omit hneg in
+theorem z_inv (g : ↥Gt) : z g⁻¹ = -(W g⁻¹ (z g)) := by
+  have h := hz g⁻¹ g
+  rw [inv_mul_cancel, z_one hz] at h
+  exact eq_neg_of_add_eq_zero_left h.symm
+
+theorem z_eN : z eN = 0 := by
+  have h := hz eN eN
+  rw [eN_mul_eN, z_one hz, hneg, LinearMap.id_apply] at h
+  have h2 : (2 : ℂ) • z eN = 0 := by rw [two_smul]; exact h.symm
+  exact (smul_eq_zero.mp h2).resolve_left two_ne_zero
+
+theorem z_eS_rel : z eS + W eS (z eS) = 0 := by
+  have h := hz eS eS
+  rwa [eS_mul_eS, z_eN hneg hz, eq_comm] at h
+
+theorem z_eU_rel : z eU + W eU (z eU) + W eU (W eU (z eU)) = 0 := by
+  have h2 := hz eU eU
+  have h3 := hz (eU * eU) eU
+  rw [eU_mul_eU_mul_eU, z_eN hneg hz, h2, map_mul, Module.End.mul_apply] at h3
+  exact h3.symm
+
+theorem z_eT : z eT = W eS (z eU - z eS) := by
+  rw [eT_eq, hz, z_inv hz, W_eS_inv W hneg, map_sub]
+  abel
+
+theorem z_eq_zero (hS : z eS = 0) (hU : z eU = 0) : z = 0 := by
+  have hT : z eT = 0 := by rw [z_eT hneg hz, hS, hU, sub_zero, map_zero]
+  funext g
+  have hg : (g : SL(2, ℤ)) ∈ Subgroup.closure ({S, T} : Set SL(2, ℤ)) := by
+    rw [SpecialLinearGroup.SL2Z_generators]; trivial
+  have key : ∀ x (hx : x ∈ Subgroup.closure ({S, T} : Set SL(2, ℤ))), z ⟨x, Subgroup.mem_top _⟩ = 0
+    :=
+    by
+    intro x hx
+    induction hx using Subgroup.closure_induction with
+    | mem x hx =>
+      rcases hx with rfl | rfl
+      · exact hS
+      · exact hT
+    | one => exact z_one hz
+    | mul x y _ _ hx hy =>
+      have := hz ⟨x, Subgroup.mem_top _⟩ ⟨y, Subgroup.mem_top _⟩
+      rw [hx, hy, map_zero, add_zero] at this
+      exact this
+    | inv x _ hx =>
+      have := z_inv hz ⟨x, Subgroup.mem_top _⟩
+      rw [hx, map_zero, neg_zero] at this
+      exact this
+  exact key g hg
+
+end CocycleFacts
+
+section LinAlg
+
+variable [FiniteDimensional ℂ V]
+
+theorem finrank_ker_add_of_sq_eq_one (s : Module.End ℂ V) (hs : s * s = 1) :
+    Module.finrank ℂ ↥(LinearMap.ker (s + 1)) + Module.finrank ℂ ↥(LinearMap.ker (s - 1)) =
+      Module.finrank ℂ V := by
+  have hinf : LinearMap.ker (s + 1) ⊓ LinearMap.ker (s - 1) = ⊥ := by
+    rw [eq_bot_iff]
+    intro v hv
+    rw [Submodule.mem_inf, LinearMap.mem_ker, LinearMap.mem_ker, LinearMap.add_apply,
+      LinearMap.sub_apply,
+      Module.End.one_apply] at hv
+    rw [Submodule.mem_bot]
+    have : (2 : ℂ) • v = 0 := by
+      rw [two_smul]
+      have h := congrArg₂ (· - ·) hv.1 hv.2
+      simp only [sub_zero] at h
+      rw [← h]; abel
+    exact (smul_eq_zero.mp this).resolve_left two_ne_zero
+  have hsup : LinearMap.ker (s + 1) ⊔ LinearMap.ker (s - 1) = ⊤ := by
+    rw [eq_top_iff]
+    intro v _
+    have hv : v = (2 : ℂ)⁻¹ • (v - s v) + (2 : ℂ)⁻¹ • (v + s v) := by
+      rw [← smul_add, show v - s v + (v + s v) = (2 : ℂ) • v by rw [two_smul]; abel, smul_smul,
+        inv_mul_cancel₀ two_ne_zero, one_smul]
+    rw [hv]
+    refine Submodule.add_mem_sup (Submodule.smul_mem _ _ ?_) (Submodule.smul_mem _ _ ?_)
+    · rw [LinearMap.mem_ker, LinearMap.add_apply, Module.End.one_apply, map_sub]
+      have := LinearMap.congr_fun hs v
+      rw [Module.End.mul_apply, Module.End.one_apply] at this
+      rw [this]; abel
+    · rw [LinearMap.mem_ker, LinearMap.sub_apply, Module.End.one_apply, map_add]
+      have := LinearMap.congr_fun hs v
+      rw [Module.End.mul_apply, Module.End.one_apply] at this
+      rw [this]; abel
+  have h := Submodule.finrank_sup_add_finrank_inf_eq (LinearMap.ker (s + 1)) (LinearMap.ker (s - 1))
+  rw [hinf, hsup, finrank_bot, add_zero, finrank_top] at h
+  exact h.symm
+
+theorem finrank_ker_add_of_cube_eq_one (u : Module.End ℂ V) (hu : u * u * u = 1) :
+    Module.finrank ℂ ↥(LinearMap.ker (1 + u + u * u)) + Module.finrank ℂ ↥(LinearMap.ker (u - 1)) =
+      Module.finrank ℂ V := by
+  have hu3 : ∀ v, u (u (u v)) = v := fun v => by
+    have := LinearMap.congr_fun hu v
+    simpa [Module.End.mul_apply] using this
+  have hinf : LinearMap.ker (1 + u + u * u) ⊓ LinearMap.ker (u - 1) = ⊥ := by
+    rw [eq_bot_iff]
+    intro v hv
+    rw [Submodule.mem_inf, LinearMap.mem_ker, LinearMap.mem_ker, LinearMap.sub_apply,
+      Module.End.one_apply, sub_eq_zero] at hv
+    obtain ⟨h1, h2⟩ := hv
+    rw [LinearMap.add_apply, LinearMap.add_apply, Module.End.one_apply, Module.End.mul_apply, h2,
+      h2] at h1
+    rw [Submodule.mem_bot]
+    have : (3 : ℂ) • v = 0 := by
+      rw [show (3 : ℂ) = 1 + 1 + 1 by norm_num, add_smul, add_smul, one_smul]; exact h1
+    exact (smul_eq_zero.mp this).resolve_left three_ne_zero
+  have hsup : LinearMap.ker (1 + u + u * u) ⊔ LinearMap.ker (u - 1) = ⊤ := by
+    rw [eq_top_iff]
+    intro v _
+    have hv : v = (3 : ℂ)⁻¹ • (v + v - u v - u (u v)) + (3 : ℂ)⁻¹ • (v + u v + u (u v)) := by
+      rw [← smul_add, show v + v - u v - u (u v) + (v + u v + u (u v)) = (3 : ℂ) • v by
+        rw [show (3 : ℂ) = 1 + 1 + 1 by norm_num, add_smul, add_smul, one_smul]; abel,
+        smul_smul, inv_mul_cancel₀ three_ne_zero, one_smul]
+    rw [hv]
+    refine Submodule.add_mem_sup (Submodule.smul_mem _ _ ?_) (Submodule.smul_mem _ _ ?_)
+    · rw [LinearMap.mem_ker, LinearMap.add_apply, LinearMap.add_apply, Module.End.one_apply,
+        Module.End.mul_apply]
+      simp only [map_sub, map_add, hu3]
+      abel
+    · rw [LinearMap.mem_ker, LinearMap.sub_apply, Module.End.one_apply]
+      simp only [map_add, hu3]
+      abel
+  have h :=
+    Submodule.finrank_sup_add_finrank_inf_eq (LinearMap.ker (1 + u + u * u)) (LinearMap.ker (u - 1))
+  rw [hinf, hsup, finrank_bot, add_zero, finrank_top] at h
+  exact h.symm
+
+end LinAlg
+
+section Count
+
+variable [FiniteDimensional ℂ V] (W : Representation ℂ ↥Gt V)
+  (hneg : W eN = LinearMap.id)
+  (hinv : ∀ v : V, (∀ g : ↥Gt, W g v = v) → v = 0)
+  (hcoinv : ∀ v : V, ∃ a b : V, v = (W eS a - a) + (W eU b - b))
+include hneg hinv hcoinv
+
+def E : ↥(coeffParabolicCocycles W) →ₗ[ℂ] V × V where
+  toFun z := ((z : ↥Gt → V) eS, (z : ↥Gt → V) eU)
+  map_add' _ _ := rfl
+  map_smul' _ _ := rfl
+
+omit hinv hcoinv in
+omit [FiniteDimensional ℂ V] in
+theorem E_injective : Function.Injective (E W) := by
+  intro z w h
+  rw [← sub_eq_zero]
+  apply Subtype.ext
+  have hz := (z - w).2.1
+  have h1 : ((z - w : ↥(coeffParabolicCocycles W)) : ↥Gt → V) eS = 0 := by
+    have := congrArg Prod.fst h; simpa [E, sub_eq_zero] using this
+  have h2 : ((z - w : ↥(coeffParabolicCocycles W)) : ↥Gt → V) eU = 0 := by
+    have := congrArg Prod.snd h; simpa [E, sub_eq_zero] using this
+  exact z_eq_zero hneg hz h1 h2
+
+def K : Submodule ℂ (V × V) :=
+  (Submodule.prod (LinearMap.ker (W eS + 1)) (LinearMap.ker (1 + W eU + W eU * W eU)))
+    ⊓ LinearMap.ker ((Submodule.mkQ ((LinearMap.range (W eT - 1)).map (W eS))).comp
+        (LinearMap.snd ℂ V V - LinearMap.fst ℂ V V))
+
+omit hinv hcoinv in
+omit [FiniteDimensional ℂ V] in
+theorem E_mem_K (z : ↥(coeffParabolicCocycles W)) : E W z ∈ K W := by
+  have hz := z.2.1
+  refine Submodule.mem_inf.mpr ⟨Submodule.mem_prod.mpr ⟨?_, ?_⟩, LinearMap.mem_ker.mpr ?_⟩
+  · change (z : ↥Gt → V) eS ∈ LinearMap.ker (W eS + 1)
+    rw [LinearMap.mem_ker, LinearMap.add_apply, Module.End.one_apply, add_comm]
+    exact z_eS_rel hneg hz
+  · change (z : ↥Gt → V) eU ∈ LinearMap.ker (1 + W eU + W eU * W eU)
+    rw [LinearMap.mem_ker, LinearMap.add_apply, LinearMap.add_apply, Module.End.one_apply,
+      Module.End.mul_apply]
+    exact z_eU_rel hneg hz
+  · change Submodule.mkQ _ ((z : ↥Gt → V) eU - (z : ↥Gt → V) eS) = 0
+    rw [Submodule.mkQ_apply, Submodule.Quotient.mk_eq_zero]
+    obtain ⟨v, hv⟩ := z.2.2 eT trace_T_sq
+    refine ⟨W eS ((z : ↥Gt → V) eU - (z : ↥Gt → V) eS), ⟨v, ?_⟩, ?_⟩
+    · rw [hv]; exact z_eT hneg hz
+    · change W eS (W eS ((z : ↥Gt → V) eU - (z : ↥Gt → V) eS)) = _
+      rw [← Module.End.mul_apply, ← map_mul, eS_mul_eS, hneg, LinearMap.id_apply]
+
+omit hinv in
+theorem finrank_K_add :
+    Module.finrank ℂ ↥(K W) + Module.finrank ℂ ↥(LinearMap.ker (W eT - 1))
+      = Module.finrank ℂ ↥(LinearMap.ker (W eS + 1)) + Module.finrank ℂ ↥(LinearMap.ker (1 + W eU +
+        W eU * W eU)) := by
+  set A := LinearMap.ker (W eS + 1) with hA
+  set B := LinearMap.ker (1 + W eU + W eU * W eU) with hB
+  set R₁ := (LinearMap.range (W eT - 1)).map (W eS) with hR₁
+  set δ : (V × V) →ₗ[ℂ] V ⧸ R₁ := (Submodule.mkQ R₁).comp (LinearMap.snd ℂ V V - LinearMap.fst ℂ V
+    V) with hδ
+  set δ' : ↥(Submodule.prod A B) →ₗ[ℂ] V ⧸ R₁ := δ.comp (Submodule.prod A B).subtype with hδ'
+  have hsurj : Function.Surjective δ' := by
+    intro q
+    obtain ⟨v, rfl⟩ := Submodule.mkQ_surjective R₁ q
+    obtain ⟨a, b, hv⟩ := hcoinv v
+    refine ⟨⟨(a - W eS a, W eU b - b), Submodule.mem_prod.mpr ⟨?_, ?_⟩⟩, ?_⟩
+    · change a - W eS a ∈ A
+      have h2 : W eS (W eS a) = a := by
+        rw [← Module.End.mul_apply, ← map_mul, eS_mul_eS, hneg, LinearMap.id_apply]
+      rw [hA, LinearMap.mem_ker, LinearMap.add_apply, Module.End.one_apply, map_sub, h2]; abel
+    · change W eU b - b ∈ B
+      have h3 : W eU (W eU (W eU b)) = b := by
+        rw [← Module.End.mul_apply, ← Module.End.mul_apply, ← map_mul, ← map_mul, eU_mul_eU_mul_eU,
+          hneg, LinearMap.id_apply]
+      rw [hB, LinearMap.mem_ker, LinearMap.add_apply, LinearMap.add_apply, Module.End.one_apply,
+        Module.End.mul_apply]
+      simp only [map_sub, h3]; abel
+    · change Submodule.mkQ R₁ ((W eU b - b) - (a - W eS a)) = Submodule.mkQ R₁ v
+      congr 1; rw [hv]; abel
+  have hker : Module.finrank ℂ ↥(LinearMap.ker δ') = Module.finrank ℂ ↥(K W) := by
+    let e : ↥(LinearMap.ker δ') ≃ₗ[ℂ] ↥(K W) :=
+      { toFun := fun p => ⟨(p : ↥(Submodule.prod A B)), (p : ↥(Submodule.prod A B)).2, p.2⟩
+        invFun := fun q => ⟨⟨q, q.2.1⟩, q.2.2⟩
+        left_inv := fun _ => rfl
+        right_inv := fun _ => rfl
+        map_add' := fun _ _ => rfl
+        map_smul' := fun _ _ => rfl }
+    exact LinearEquiv.finrank_eq e
+  have hrn := LinearMap.finrank_range_add_finrank_ker δ'
+  rw [LinearMap.range_eq_top.mpr hsurj, finrank_top, hker] at hrn
+  have hq : Module.finrank ℂ (V ⧸ R₁) = Module.finrank ℂ ↥(LinearMap.ker (W eT - 1)) := by
+    have h1 := Submodule.finrank_quotient_add_finrank R₁
+    have h2 : Module.finrank ℂ ↥R₁ = Module.finrank ℂ ↥(LinearMap.range (W eT - 1)) := by
+      rw [hR₁]
+      have hSinv : Function.Injective (W eS) := by
+        intro x y h
+        have := congrArg (W eS) h
+        rwa [← Module.End.mul_apply, ← map_mul, eS_mul_eS, hneg, ← Module.End.mul_apply, ← map_mul,
+          eS_mul_eS, hneg] at this
+      exact LinearEquiv.finrank_eq (Submodule.equivMapOfInjective _ hSinv _).symm
+    have h3 := LinearMap.finrank_range_add_finrank_ker (W eT - 1)
+    omega
+  have hprod : Module.finrank ℂ ↥(Submodule.prod A B) = Module.finrank ℂ ↥A + Module.finrank ℂ ↥B :=
+    by
+    let e2 : ↥(Submodule.prod A B) ≃ₗ[ℂ] (↥A × ↥B) :=
+      { toFun := fun x => (⟨x.1.1, x.2.1⟩, ⟨x.1.2, x.2.2⟩)
+        invFun := fun y => ⟨(y.1, y.2), y.1.2, y.2.2⟩
+        left_inv := fun _ => rfl
+        right_inv := fun _ => rfl
+        map_add' := fun _ _ => rfl
+        map_smul' := fun _ _ => rfl }
+    rw [LinearEquiv.finrank_eq e2, Module.finrank_prod]
+  omega
+
+end Count
+
+end HeckeEis.UASol
+
+end
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "coeffCocycles coeffCoboundaryMap coeffCoboundaryMap_apply coeffCoboundaries \
+  coeffParabolicCocycles coeffCoboundaries_le_coeffParabolicCocycles coeffH1par"
+namespace UASol
+p2m_open "HeckeEis"
+
+open scoped MatrixGroups
+open ModularGroup
+
+section Final
+
+variable {V : Type} [AddCommGroup V] [Module ℂ V] [FiniteDimensional ℂ V]
+    (W : Representation ℂ ↥Gt V)
+  (hneg : W eN = LinearMap.id)
+  (hinv : ∀ v : V, (∀ g : ↥Gt, W g v = v) → v = 0)
+  (hcoinv : ∀ v : V, ∃ a b : V, v = (W eS a - a) + (W eU b - b))
+include hneg hinv hcoinv
+
+theorem main :
+    Module.finrank ℂ (coeffH1par W)
+      + Module.finrank ℂ ↥(LinearMap.ker (W eS - 1))
+      + Module.finrank ℂ ↥(LinearMap.ker (W eU - 1))
+      + Module.finrank ℂ ↥(LinearMap.ker (W eT - 1))
+      ≤ Module.finrank ℂ V := by
+  classical
+  set PC := coeffParabolicCocycles W with hPC
+  set CB' : Submodule ℂ ↥PC := (coeffCoboundaries W).comap PC.subtype with hCB'
+  have : FiniteDimensional ℂ ↥PC := Module.Finite.of_injective (E W) (E_injective W hneg)
+  have hPK : Module.finrank ℂ ↥PC ≤ Module.finrank ℂ ↥(K W) :=
+    LinearMap.finrank_le_finrank_of_injective
+      (f := LinearMap.codRestrict (K W) (E W) (E_mem_K W hneg))
+      (fun z w h => E_injective W hneg (congrArg Subtype.val h))
+  have hcb_inj : Function.Injective (coeffCoboundaryMap W) := by
+    intro v w h
+    rw [← sub_eq_zero]
+    apply hinv
+    intro g
+    have := congrFun h g
+    rw [coeffCoboundaryMap_apply, coeffCoboundaryMap_apply] at this
+    rw [map_sub]
+    exact sub_eq_sub_iff_sub_eq_sub.mp this
+  let cb' : V →ₗ[ℂ] ↥PC :=
+    LinearMap.codRestrict PC (coeffCoboundaryMap W) fun v =>
+      coeffCoboundaries_le_coeffParabolicCocycles W ⟨v, rfl⟩
+  have hcb'_range : LinearMap.range cb' = CB' := by
+    ext z
+    constructor
+    · rintro ⟨v, rfl⟩
+      change (coeffCoboundaryMap W v) ∈ coeffCoboundaries W
+      exact ⟨v, rfl⟩
+    · rintro ⟨v, hv⟩
+      exact ⟨v, Subtype.ext hv⟩
+  have hCB : Module.finrank ℂ ↥CB' = Module.finrank ℂ V := by
+    rw [← hcb'_range]
+    exact LinearMap.finrank_range_of_inj fun v w h => hcb_inj (congrArg Subtype.val h)
+  have hH : Module.finrank ℂ (coeffH1par W) + Module.finrank ℂ ↥CB' = Module.finrank ℂ ↥PC :=
+    Submodule.finrank_quotient_add_finrank CB'
+  have hK := finrank_K_add W hneg hcoinv
+  have hS := finrank_ker_add_of_sq_eq_one (W eS) (by rw [← map_mul, eS_mul_eS, hneg]; rfl)
+  have hU :=
+    finrank_ker_add_of_cube_eq_one (W eU) (by
+      rw [← map_mul, ← map_mul, eU_mul_eU_mul_eU, hneg]; rfl)
+  omega
+
+end Final
+
+end HeckeEis.UASol
+
+end
+
+open scoped MatrixGroups in
+theorem solution {V : Type} [AddCommGroup V] [Module ℂ V] [FiniteDimensional ℂ V]
+    (W : Representation ℂ (⊤ : Subgroup SL(2, ℤ)) V)
+    (hneg : W ⟨-1, Subgroup.mem_top _⟩ = LinearMap.id)
+    (hinv : ∀ v : V, (∀ g : (⊤ : Subgroup SL(2, ℤ)), W g v = v) → v = 0)
+    (hcoinv : ∀ v : V, ∃ a b : V,
+      v = (W ⟨ModularGroup.S, Subgroup.mem_top _⟩ a - a) + (W ⟨ModularGroup.S * ModularGroup.T,
+        Subgroup.mem_top _⟩ b - b)) :
+    Module.finrank ℂ (HeckeEis.coeffH1par W)
+      + Module.finrank ℂ ↥(LinearMap.ker (W ⟨ModularGroup.S, Subgroup.mem_top _⟩ - 1))
+      + Module.finrank ℂ ↥(LinearMap.ker (W ⟨ModularGroup.S * ModularGroup.T, Subgroup.mem_top _⟩ -
+        1))
+      + Module.finrank ℂ ↥(LinearMap.ker (W ⟨ModularGroup.T, Subgroup.mem_top _⟩ - 1))
+      ≤ Module.finrank ℂ V :=
+  HeckeEis.UASol.main W hneg hinv hcoinv
+
+end S_HeckeEis_finrank_coeffH1par_top_add_le
+end P2MW
+export P2MW.S_HeckeEis_finrank_coeffH1par_top_add_le (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.finrank_coeffH1par_top_add_le {V : Type} [AddCommGroup V] [Module ℂ V]
+    [FiniteDimensional ℂ V]
+    (W : Representation ℂ (⊤ : Subgroup SL(2, ℤ)) V)
+    (hneg : W ⟨-1, Subgroup.mem_top _⟩ = LinearMap.id)
+    (hinv : ∀ v : V, (∀ g : (⊤ : Subgroup SL(2, ℤ)), W g v = v) → v = 0)
+    (hcoinv : ∀ v : V, ∃ a b : V,
+      v = (W ⟨ModularGroup.S, Subgroup.mem_top _⟩ a - a) + (W ⟨ModularGroup.S * ModularGroup.T,
+        Subgroup.mem_top _⟩ b - b)) :
+    Module.finrank ℂ (HeckeEis.coeffH1par W)
+      + Module.finrank ℂ ↥(LinearMap.ker (W ⟨ModularGroup.S, Subgroup.mem_top _⟩ - 1))
+      + Module.finrank ℂ ↥(LinearMap.ker (W ⟨ModularGroup.S * ModularGroup.T, Subgroup.mem_top _⟩ -
+        1))
+      + Module.finrank ℂ ↥(LinearMap.ker (W ⟨ModularGroup.T, Subgroup.mem_top _⟩ - 1))
+      ≤ Module.finrank ℂ V :=
+  solution W hneg hinv hcoinv
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_finrank_coeffH1par_zero_le_two_mul_genusFormula.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_finrank_coeffH1par_zero_le_two_mul_genusFormula.lean
new file mode 100644
index 0000000000..defad19c1a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_finrank_coeffH1par_zero_le_two_mul_genusFormula.lean
@@ -0,0 +1,280 @@
+/-
+Based on Prove2Me node HeckeEis.finrank_coeffH1par_zero_le_two_mul_genusFormula
+(1a32e6da-a69a-5c0e-9765-9a87792e6245) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8eb9a271-e577-5325-8f4f-e4386cc8dea8
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Basic.Complex.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+
+import Mathlib.Analysis.CStarAlgebra.Classes
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_Period_exists_basis_parabolicHoms_castAddHom_comp
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_parabolicHoms_le_two_mul_genusFormula
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Weight-two parabolic cohomology bound for Γ₀(N)
+
+Theorem statement: `HeckeEis.finrank_coeffH1par_zero_le_two_mul_genusFormula`
+(`1a32e6da-a69a-5c0e-9765-9a87792e6245`), by Claude, 2026-09-05.
+
+Proof: submission `8eb9a271-e577-5325-8f4f-e4386cc8dea8`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, assumed nonzero. Consider the representation of $\Gamma_0(N)$ obtained
+by restricting, along the inclusion of $\Gamma_0(N)$ into $\mathrm{SL}(2,\mathbb{Z})$, the
+representation [`HeckeEis.binaryFormRepSL ℂ 0`](def/HeckeEis_BinaryFormRep.html#L61) of
+$\mathrm{SL}(2,\mathbb{Z})$ on the space of homogeneous binary forms of degree $0$ over $\mathbb{C}$
+(a one-dimensional space, on which $g$ acts by the substitution $X_j \mapsto \sum_i g_{ij} X_i$,
+hence trivially in degree $0$). For this representation $\rho$, the space
+[`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100) is the quotient of the submodule of
+parabolic cocycles, i.e. those $z : \Gamma_0(N) \to \mathbb{C}$ lying in `coeffCocycles ρ` and
+satisfying `IsParabolicCocycle ρ`, by the intersection of that submodule with the coboundaries, the
+range of `coeffCoboundaryMap ρ`. The assertion is that the $\mathbb{C}$-dimension of this quotient,
+viewed as a rational number, satisfies $$\dim_{\mathbb C} H^1_{\mathrm{par}} \le 2\Bigl(1 +
+\tfrac{\psi(N)}{12} - \tfrac{\nu_2(N)}{4} - \tfrac{\nu_3(N)}{3} - \tfrac{c(N)}{2}\Bigr),$$ where
+$\psi(N) = \sum_{d \mid N,\ d \text{ squarefree}} N/d$, $\nu_2(N)$ and $\nu_3(N)$ count the
+solutions in $\mathbb{Z}/N$ of $x^2+1=0$ and of $x^2+x+1=0$, and $c(N) = \sum_{d \mid N}
+\varphi(\gcd(d, N/d))$.
+
+This is the weight-two ($n=0$) instance of the bound $\dim H^1_{\mathrm{par}}(\Gamma_0(N),
+\mathrm{Sym}^n) \le 2g(X_0(N))$, stated in the binary-form vocabulary: for trivial coefficients a
+parabolic cocycle is a homomorphism $\Gamma_0(N) \to \mathbb{C}$ killing the parabolic elements, so
+the count reduces to
+[`ModularCurve.finrank_parabolicHoms_le_two_mul_genusFormula`]
+(thm.html#ModularCurve.finrank_parabolicHoms_le_two_mul_genusFormula)
+together with the integral basis statement
+[`ModularCurve.Period.exists_basis_parabolicHoms_castAddHom_comp`]
+(thm.html#ModularCurve.Period.exists_basis_parabolicHoms_castAddHom_comp).
+It supplies the degree-zero slice used by
+[`HeckeEis.isCompl_range_eichlerShimuraMap_range_conj`]
+(thm.html#HeckeEis.isCompl_range_eichlerShimuraMap_range_conj).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_finrank_coeffH1par_zero_le_two_mul_genusFormula.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_finrank_coeffH1par_zero_le_two_mul_genusFormula
+
+
+open scoped MatrixGroups
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "mem_coeffCocycles_iff mem_coeffCoboundaries_iff coeffParabolicCocycles \
+  coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff BinaryForm binarySubst \
+  binarySubst_C binaryFormRepSL"
+namespace N0Sol
+p2m_open "HeckeEis"
+
+open MvPolynomial CongruenceSubgroup ModularCurve.Period
+
+variable (N : ℕ)
+
+abbrev ρ0 :
+    Representation ℂ (Gamma0 N) ↥(BinaryForm ℂ 0) := (binaryFormRepSL ℂ 0).comp (Gamma0 N).subtype
+
+theorem coe_eq_C (P : ↥(BinaryForm ℂ 0)) :
+    (P : MvPolynomial (Fin 2) ℂ) = C (AddMonoidAlgebra.coeff (P : MvPolynomial (Fin 2) ℂ) 0) := by
+  have hP : (P : MvPolynomial (Fin 2) ℂ).IsHomogeneous 0 := (mem_homogeneousSubmodule 0 _).mp P.2
+  ext d
+  rw [coeff_C]
+  split_ifs with hd
+  · rw [← hd]
+  · by_contra h
+    have hw := hP h
+    have hdeg : d.degree = 0 := by rw [Finsupp.degree_eq_weight_one]; exact hw
+    rw [Finsupp.degree_eq_zero_iff] at hdeg
+    exact hd hdeg.symm
+
+theorem ext0 {P Q : ↥(BinaryForm ℂ 0)}
+    (h : AddMonoidAlgebra.coeff (P : MvPolynomial (Fin 2) ℂ) 0 =
+      AddMonoidAlgebra.coeff (Q : MvPolynomial (Fin 2) ℂ) 0) :
+    P = Q := by
+  apply Subtype.ext
+  rw [coe_eq_C P, coe_eq_C Q, h]
+
+theorem rho0_apply (g : Gamma0 N) (P : ↥(BinaryForm ℂ 0)) : ρ0 N g P = P := by
+  apply Subtype.ext
+  change binarySubst ℂ (((g : Gamma0 N) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) (P : MvPolynomial
+    (Fin 2) ℂ) = P
+  conv_lhs => rw [coe_eq_C P]
+  rw [binarySubst_C, ← coe_eq_C P]
+
+variable {N}
+
+def toHom (z : ↥(coeffParabolicCocycles (ρ0 N))) : Additive (Gamma0 N) →+ ℂ where
+  toFun a := AddMonoidAlgebra.coeff
+    (((z : Gamma0 N → ↥(BinaryForm ℂ 0)) (Additive.toMul a) : ↥(BinaryForm ℂ 0)) :
+      MvPolynomial (Fin 2) ℂ) 0
+  map_zero' := by
+    have h := (mem_coeffCocycles_iff (ρ0 N) _).mp z.2.1 1 1
+    rw [mul_one, rho0_apply] at h
+    have h0 : (z : Gamma0 N → ↥(BinaryForm ℂ 0)) 1 = 0 := by
+      have := congrArg (fun v => v - (z : Gamma0 N → ↥(BinaryForm ℂ 0)) 1) h
+      have h0' : (0 : ↥(BinaryForm ℂ 0)) = (z : Gamma0 N → ↥(BinaryForm ℂ 0)) 1 :=
+        by simpa using this
+      exact h0'.symm
+    change AddMonoidAlgebra.coeff
+      (((z : Gamma0 N → ↥(BinaryForm ℂ 0)) 1 : ↥(BinaryForm ℂ 0)) :
+        MvPolynomial (Fin 2) ℂ) 0 = 0
+    rw [h0]; rfl
+  map_add' a b := by
+    change AddMonoidAlgebra.coeff
+      (((z : Gamma0 N → ↥(BinaryForm ℂ 0)) (Additive.toMul a * Additive.toMul b) :
+        ↥(BinaryForm ℂ 0)) : MvPolynomial (Fin 2) ℂ) 0 =
+      AddMonoidAlgebra.coeff
+          (((z : Gamma0 N → ↥(BinaryForm ℂ 0)) (Additive.toMul a) : ↥(BinaryForm ℂ 0)) :
+            MvPolynomial (Fin 2) ℂ) 0 +
+        AddMonoidAlgebra.coeff
+          (((z : Gamma0 N → ↥(BinaryForm ℂ 0)) (Additive.toMul b) : ↥(BinaryForm ℂ 0)) :
+            MvPolynomial (Fin 2) ℂ) 0
+    rw [(mem_coeffCocycles_iff (ρ0 N) _).mp z.2.1, rho0_apply, Submodule.coe_add,
+      AddMonoidAlgebra.coeff_add, Finsupp.add_apply]
+
+@[scoped simp] theorem toHom_apply (z : ↥(coeffParabolicCocycles (ρ0 N))) (g : Gamma0 N) :
+    toHom z (Additive.ofMul g) = AddMonoidAlgebra.coeff
+      (((z : Gamma0 N → ↥(BinaryForm ℂ 0)) g : ↥(BinaryForm ℂ 0)) :
+        MvPolynomial (Fin 2) ℂ) 0 := rfl
+
+theorem toHom_mem (z : ↥(coeffParabolicCocycles (ρ0 N))) :
+    toHom z ∈ parabolicHoms ℂ (Gamma0 N) ℂ := by
+  intro γ hγ
+  rw [toHom_apply]
+  obtain ⟨u, hu⟩ := z.2.2 γ hγ
+  rw [LinearMap.sub_apply, Module.End.one_apply, rho0_apply, sub_self] at hu
+  rw [← hu]; rfl
+
+def φ : ↥(coeffParabolicCocycles (ρ0 N)) →ₗ[ℂ] ↥(parabolicHoms ℂ (Gamma0 N) ℂ) where
+  toFun z := ⟨toHom z, toHom_mem z⟩
+  map_add' z w := by
+    apply Subtype.ext; apply AddMonoidHom.ext; intro a
+    change AddMonoidAlgebra.coeff
+      ((((z + w : ↥(coeffParabolicCocycles (ρ0 N))) : Gamma0 N → ↥(BinaryForm ℂ 0))
+        (Additive.toMul a) : ↥(BinaryForm ℂ 0)) : MvPolynomial (Fin 2) ℂ) 0 = _
+    rw [Submodule.coe_add, Pi.add_apply, Submodule.coe_add, AddMonoidAlgebra.coeff_add,
+      Finsupp.add_apply]
+    rfl
+  map_smul' c z := by
+    apply Subtype.ext; apply AddMonoidHom.ext; intro a
+    change AddMonoidAlgebra.coeff
+      ((((c • z : ↥(coeffParabolicCocycles (ρ0 N))) : Gamma0 N → ↥(BinaryForm ℂ 0))
+        (Additive.toMul a) : ↥(BinaryForm ℂ 0)) : MvPolynomial (Fin 2) ℂ) 0 = _
+    rw [Submodule.coe_smul, Pi.smul_apply, Submodule.coe_smul, coeff_smul]
+    rfl
+
+theorem φ_apply_coe (z : ↥(coeffParabolicCocycles (ρ0 N))) (g : Gamma0 N) :
+    ((φ z : ↥(parabolicHoms ℂ (Gamma0 N) ℂ)) : Additive (Gamma0 N) →+ ℂ) (Additive.ofMul g)
+      = AddMonoidAlgebra.coeff
+        (((z : Gamma0 N → ↥(BinaryForm ℂ 0)) g : ↥(BinaryForm ℂ 0)) :
+          MvPolynomial (Fin 2) ℂ) 0 := rfl
+
+theorem φ_injective : Function.Injective (φ (N := N)) := by
+  intro z w h
+  apply Subtype.ext; funext g
+  apply ext0
+  have :=
+    congrArg (fun ψ : ↥(parabolicHoms ℂ (Gamma0 N) ℂ) => (ψ : Additive (Gamma0 N) →+ ℂ)
+      (Additive.ofMul g)) h
+  simpa [φ_apply_coe] using this
+
+theorem eq_of_mk_eq {a b : ↥(coeffParabolicCocycles (ρ0 N))}
+    (h : coeffH1parMk _ a = coeffH1parMk _ b) :
+    a = b := by
+  rw [← sub_eq_zero, ← map_sub, coeffH1parMk_eq_zero_iff, mem_coeffCoboundaries_iff] at h
+  obtain ⟨v, hv⟩ := h
+  rw [← sub_eq_zero]
+  apply Subtype.ext; funext g
+  have := congrFun hv g
+  rw [rho0_apply, sub_self] at this
+  rw [← this]; rfl
+
+def Ψ : coeffH1par (ρ0 N) →ₗ[ℂ] ↥(parabolicHoms ℂ (Gamma0 N) ℂ) where
+  toFun x := φ (Function.surjInv (coeffH1parMk_surjective (ρ0 N)) x)
+  map_add' x y := by
+    rw [← map_add]
+    congr 1
+    apply eq_of_mk_eq
+    rw [map_add, Function.surjInv_eq (coeffH1parMk_surjective _), Function.surjInv_eq
+      (coeffH1parMk_surjective _),
+      Function.surjInv_eq (coeffH1parMk_surjective _)]
+  map_smul' c x := by
+    rw [RingHom.id_apply, ← map_smul]
+    congr 1
+    apply eq_of_mk_eq
+    rw [map_smul, Function.surjInv_eq (coeffH1parMk_surjective _), Function.surjInv_eq
+      (coeffH1parMk_surjective _)]
+
+theorem Ψ_mk (z : ↥(coeffParabolicCocycles (ρ0 N))) : Ψ (coeffH1parMk _ z) = φ z := by
+  change φ (Function.surjInv (coeffH1parMk_surjective (ρ0 N)) (coeffH1parMk _ z)) = φ z
+  congr 1
+  apply eq_of_mk_eq
+  rw [Function.surjInv_eq (coeffH1parMk_surjective _)]
+
+theorem Ψ_injective : Function.Injective (Ψ (N := N)) := by
+  intro x y h
+  obtain ⟨a, rfl⟩ := coeffH1parMk_surjective _ x
+  obtain ⟨b, rfl⟩ := coeffH1parMk_surjective _ y
+  rw [Ψ_mk, Ψ_mk] at h
+  rw [φ_injective h]
+
+end HeckeEis.N0Sol
+end
+
+theorem solution (N : ℕ) [NeZero N] :
+    (Module.finrank ℂ (HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ 0).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)) : ℚ)
+      ≤ 2 * ModularCurve.genusFormula N := by
+  obtain ⟨t, b, hb⟩ :=
+    ModularCurve.Period.exists_basis_parabolicHoms_castAddHom_comp (CongruenceSubgroup.Gamma0 N)
+  obtain ⟨bK, -⟩ := hb ℂ
+  have : FiniteDimensional ℂ ↥(ModularCurve.Period.parabolicHoms ℂ (CongruenceSubgroup.Gamma0 N) ℂ)
+    :=
+    Module.Finite.of_basis bK
+  have h1 : Module.finrank ℂ (HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ 0).comp
+    (CongruenceSubgroup.Gamma0 N).subtype))
+      ≤ Module.finrank ℂ ↥(ModularCurve.Period.parabolicHoms ℂ (CongruenceSubgroup.Gamma0 N) ℂ) :=
+    LinearMap.finrank_le_finrank_of_injective (HeckeEis.N0Sol.Ψ_injective (N := N))
+  have h2 := ModularCurve.finrank_parabolicHoms_le_two_mul_genusFormula N ℂ
+  calc (Module.finrank ℂ (HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ 0).comp
+    (CongruenceSubgroup.Gamma0 N).subtype)) : ℚ)
+      ≤ Module.finrank ℂ ↥(ModularCurve.Period.parabolicHoms ℂ (CongruenceSubgroup.Gamma0 N) ℂ)
+        := by
+        exact_mod_cast h1
+    _ ≤ 2 * ModularCurve.genusFormula N := h2
+
+end S_HeckeEis_finrank_coeffH1par_zero_le_two_mul_genusFormula
+end P2MW
+export P2MW.S_HeckeEis_finrank_coeffH1par_zero_le_two_mul_genusFormula (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.finrank_coeffH1par_zero_le_two_mul_genusFormula (N : ℕ) [NeZero N] :
+    (Module.finrank ℂ (HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ 0).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)) : ℚ)
+      ≤ 2 * ModularCurve.genusFormula N :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_isCompl_range_eichlerShimuraMap_range_conj.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_isCompl_range_eichlerShimuraMap_range_conj.lean
new file mode 100644
index 0000000000..2e2caa21c8
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_isCompl_range_eichlerShimuraMap_range_conj.lean
@@ -0,0 +1,293 @@
+/-
+Based on Prove2Me node HeckeEis.isCompl_range_eichlerShimuraMap_range_conj
+(5fd6c717-6136-56cd-8686-553176500925) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4bc06185-0433-5d2d-a31f-5a3b5c0c1ae3
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Rat.Star
+import Mathlib.LinearAlgebra.Complex.FiniteDimensional
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_dimFormula_le_finrank_gamma0
+import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_genusFormula_le_finrank_gamma0_weight_two
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_coeffH1par_binaryFormRepSL_eq_zero_of_odd
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_eichlerShimuraMap_injective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_basis_coeffH1par_int_complex
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_coeffH1par_map_ringHom
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_coeffH1par_semilinearMap_starRingEnd
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_finrank_coeffH1par_le_two_mul_dimFormula
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_finrank_coeffH1par_zero_le_two_mul_genusFormula
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_range_eichlerShimuraMap_inf_range_conj_eq_bot
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Eichler–Shimura: images of ES and ̄ES are complementary
+
+Theorem statement: `HeckeEis.isCompl_range_eichlerShimuraMap_range_conj`
+(`5fd6c717-6136-56cd-8686-553176500925`), by Claude, 2026-09-05.
+
+Proof: submission `4bc06185-0433-5d2d-a31f-5a3b5c0c1ae3`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N\ge 1$ and $n\ge 0$, and let $V_n$ be the space of homogeneous binary forms of degree $n$ over
+$\mathbb{C}$, carrying the representation of $\Gamma_0(N)\le \mathrm{SL}_2(\mathbb{Z})$ by
+substitution of the matrix into the variables, and let $H$ be the associated parabolic cohomology
+[`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100): the quotient of the space of cocycles
+$z\colon\Gamma_0(N)\to V_n$ (i.e. $z(gh)=z(g)+g\cdot z(h)$) that are parabolic (for every $\gamma$
+with $(\operatorname{tr}\gamma)^2=4$, $z(\gamma)$ lies in the image of $\rho(\gamma)-1$) by those
+parabolic cocycles which are coboundaries. Assume given: a $\mathbb{C}$-linear map $ES$ from
+$S_{n+2}(\Gamma_0(N))$ (the cusp forms of weight $(n:\mathbb{Z})+2$) to $H$ agreeing pointwise with
+[`HeckeEis.eichlerShimuraMap n N`](def/HeckeEis_EichlerIntegral.html#L114), the class of the cocycle
+of an Eichler integral of $f$ with parabolic cocycle (and $0$ if none exists); an additive
+endomorphism $\Phi$ of $H$ such that each parabolic cocycle $z$ admits a parabolic cocycle $w$ with
+$w(g)$ the coefficientwise complex conjugate of $z(g)$ for all $g$ and $\Phi[z]=[w]$; and a
+$\mathrm{starRingEnd}\,\mathbb{C}$-semilinear (conjugate-linear) map $ESbar$ with
+$ESbar(f)=\Phi(ES(f))$ for all $f$. The conclusion is that the ranges of $ES$ and of $ESbar$ are
+complementary submodules of $H$: their intersection is $0$ and their sum is all of $H$.
+
+This is the Eichler–Shimura isomorphism in its decomposition form,
+$H^1_{\mathrm{par}}(\Gamma_0(N),V_n)=\mathrm{ES}(S_{n+2})\oplus\overline{\mathrm{ES}}(S_{n+2})$,
+stated for an abstract pair $(ES,\Phi)$ satisfying the defining properties of the Eichler–Shimura
+map and of coefficientwise conjugation. It is the analytic input to
+[`HeckeEis.exists_eichlerShimura_coeffH1par_binaryFormRepSL_forall_prime`]
+(thm.html#HeckeEis.exists_eichlerShimura_coeffH1par_binaryFormRepSL_forall_prime),
+which packages the map together with its injectivity, the conjugation and Hecke equivariance at all
+primes.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_isCompl_range_eichlerShimuraMap_range_conj.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_isCompl_range_eichlerShimuraMap_range_conj
+
+
+open scoped MatrixGroups
+
+open Module
+
+namespace ISCAsm
+
+def realOfSemilinear {S H : Type*} [AddCommGroup S] [Module ℂ S] [AddCommGroup H] [Module ℂ H]
+    (T : S →ₛₗ[starRingEnd ℂ] H) : S →ₗ[ℝ] H where
+  toFun := T
+  map_add' := map_add T
+  map_smul' r f := by
+    rw [RingHom.id_apply, ← Complex.coe_smul, LinearMap.map_smulₛₗ, Complex.conj_ofReal,
+      Complex.coe_smul]
+
+@[scoped simp] theorem realOfSemilinear_apply {S H : Type*} [AddCommGroup S] [Module ℂ S]
+  [AddCommGroup H] [Module ℂ H]
+    (T : S →ₛₗ[starRingEnd ℂ] H) (f : S) : realOfSemilinear T f = T f := rfl
+
+theorem isCompl_range_of_finrank_le {S H : Type*} [AddCommGroup S] [Module ℂ S]
+    [FiniteDimensional ℂ S]
+    [AddCommGroup H] [Module ℂ H] [FiniteDimensional ℂ H]
+    (ES : S →ₗ[ℂ] H) (ESbar : S →ₛₗ[starRingEnd ℂ] H)
+    (hinj : Function.Injective ES) (hinjb : Function.Injective ESbar)
+    (hdisj : ∀ f g : S, ES f = ESbar g → f = 0)
+    (hdim : finrank ℂ H ≤ 2 * finrank ℂ S) :
+    IsCompl (LinearMap.range ES) (LinearMap.range ESbar) := by
+  classical
+  let ESR : S →ₗ[ℝ] H := ES.restrictScalars ℝ
+  let EBR : S →ₗ[ℝ] H := realOfSemilinear ESbar
+  have hinjR : Function.Injective ESR := hinj
+  have hinjbR : Function.Injective EBR := hinjb
+  have hdisjR : Disjoint (LinearMap.range ESR) (LinearMap.range EBR) := by
+    rw [Submodule.disjoint_def]
+    rintro x ⟨f, rfl⟩ ⟨g, hg⟩
+    have hf : f = 0 := hdisj f g hg.symm
+    change ESR f = 0
+    rw [hf, map_zero]
+  have hS : finrank ℝ S = 2 * finrank ℂ S := finrank_real_of_complex S
+  have hH : finrank ℝ H = 2 * finrank ℂ H := finrank_real_of_complex H
+  have hp : finrank ℝ (LinearMap.range ESR) = finrank ℝ S := LinearMap.finrank_range_of_inj hinjR
+  have hq : finrank ℝ (LinearMap.range EBR) = finrank ℝ S := LinearMap.finrank_range_of_inj hinjbR
+  have hsup : finrank ℝ ↥(LinearMap.range ESR ⊔ LinearMap.range EBR) = finrank ℝ S + finrank ℝ S :=
+    by
+    have h := Submodule.finrank_sup_add_finrank_inf_eq (LinearMap.range ESR) (LinearMap.range EBR)
+    rw [disjoint_iff.mp hdisjR, finrank_bot, add_zero, hp, hq] at h
+    exact h
+  have htop : LinearMap.range ESR ⊔ LinearMap.range EBR = ⊤ := by
+    apply Submodule.eq_top_of_finrank_eq
+    apply le_antisymm (Submodule.finrank_le _)
+    rw [hsup, hH, hS]
+    omega
+  refine ⟨?_, ?_⟩
+  · rw [Submodule.disjoint_def]
+    rintro x ⟨f, rfl⟩ ⟨g, hg⟩
+    have hf : f = 0 := hdisj f g hg.symm
+    rw [hf, map_zero]
+  · rw [codisjoint_iff, eq_top_iff]
+    intro x _
+    have hx : x ∈ LinearMap.range ESR ⊔ LinearMap.range EBR := by rw [htop]; trivial
+    obtain ⟨a, ha, b, hb, rfl⟩ := Submodule.mem_sup.mp hx
+    obtain ⟨f, rfl⟩ := ha
+    obtain ⟨g, rfl⟩ := hb
+    exact Submodule.add_mem_sup ⟨f, rfl⟩ ⟨g, rfl⟩
+
+theorem isCompl_of_forall_eq_zero {S H : Type*} [AddCommGroup S] [Module ℂ S] [AddCommGroup H]
+    [Module ℂ H]
+    (ES : S →ₗ[ℂ] H) (ESbar : S →ₛₗ[starRingEnd ℂ] H) (h0 : ∀ x : H, x = 0) :
+    IsCompl (LinearMap.range ES) (LinearMap.range ESbar) := by
+  have : Subsingleton H := ⟨fun a b => by rw [h0 a, h0 b]⟩
+  have : Subsingleton (Submodule ℂ H) := (Submodule.subsingleton_iff ℂ).mpr inferInstance
+  exact ⟨disjoint_iff.mpr (Subsingleton.elim _ _), codisjoint_iff.mpr (Subsingleton.elim _ _)⟩
+
+end ISCAsm
+
+theorem ISCAsm.finrank_cuspForm_congr (N : ℕ) {k k' : ℤ} (h : k = k') :
+    Module.finrank ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) k) = Module.finrank ℂ (CuspForm
+      (CongruenceSubgroup.Gamma0 N) k') := by
+  subst h; rfl
+
+theorem solution (N : ℕ) [NeZero N] (n : ℕ)
+    (ES : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2) →ₗ[ℂ] HeckeEis.coeffH1par
+      ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype))
+    (hES : ∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2), ES f =
+      HeckeEis.eichlerShimuraMap n N f)
+    (Φ : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+      N).subtype) →+ HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype))
+    (hΦ : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+        (CongruenceSubgroup.Gamma0 N).subtype)),
+        (∀ g : CongruenceSubgroup.Gamma0 N, ((w : CongruenceSubgroup.Gamma0 N →
+          ↥(HeckeEis.BinaryForm ℂ n)) g : MvPolynomial (Fin 2) ℂ)
+            = MvPolynomial.map (starRingEnd ℂ)
+                (((z : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n)) g : MvPolynomial
+                  (Fin 2) ℂ))) ∧
+        Φ (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w)
+    (ESbar : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2) →ₛₗ[starRingEnd ℂ]
+      HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+      N).subtype))
+    (hESbar : ∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2), ESbar f = Φ (ES f)) :
+    IsCompl (LinearMap.range ES) (LinearMap.range ESbar) := by
+  classical
+  obtain ⟨ΦZ, hΦZ⟩ :=
+    HeckeEis.exists_coeffH1par_map_ringHom (Int.castRingHom ℂ) n (CongruenceSubgroup.Gamma0 N)
+  obtain ⟨t, b, c, -⟩ := HeckeEis.exists_basis_coeffH1par_int_complex n N ΦZ hΦZ
+  have : FiniteDimensional ℂ (HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+    (CongruenceSubgroup.Gamma0 N).subtype)) :=
+    Module.Finite.of_basis c
+  rcases Nat.even_or_odd n with hne | hno
+  swap
+  · exact ISCAsm.isCompl_of_forall_eq_zero ES ESbar
+      (HeckeEis.coeffH1par_binaryFormRepSL_eq_zero_of_odd ℂ two_ne_zero N n hno)
+  have hESinj : Function.Injective ES := by
+    intro a b h
+    have h' : HeckeEis.eichlerShimuraMap n N a = HeckeEis.eichlerShimuraMap n N b :=
+      by rw [← hES, ← hES, h]
+    exact HeckeEis.eichlerShimuraMap_injective N n h'
+  have : FiniteDimensional ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2)) :=
+    Module.Finite.of_injective ES hESinj
+  obtain ⟨Φ', hΦ', hΦ'Φ'⟩ :=
+    HeckeEis.exists_coeffH1par_semilinearMap_starRingEnd n (CongruenceSubgroup.Gamma0 N)
+  have hΦeq : ∀ x, Φ x = Φ' x := by
+    intro x
+    obtain ⟨z, rfl⟩ := HeckeEis.coeffH1parMk_surjective _ x
+    obtain ⟨w, hw, hΦw⟩ := hΦ z
+    obtain ⟨w', hw', hΦ'w⟩ := hΦ' z
+    rw [hΦw, hΦ'w]
+    congr 1
+    apply Subtype.ext; funext g; apply Subtype.ext
+    rw [hw g, hw' g]
+  have hΦinj : Function.Injective Φ := by
+    intro x y h
+    have h2 := congrArg Φ h
+    rw [hΦeq x, hΦeq y, hΦeq, hΦeq, hΦ'Φ', hΦ'Φ'] at h2
+    exact h2
+  have hESbar_inj : Function.Injective ESbar := by
+    intro a b h
+    rw [hESbar, hESbar] at h
+    exact hESinj (hΦinj h)
+  have hdisj : ∀ f g : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2), ES f = ESbar g → f = 0
+    :=
+    by
+    intro f g h
+    rw [hESbar] at h
+    exact HeckeEis.range_eichlerShimuraMap_inf_range_conj_eq_bot N n ES hES Φ hΦ f g h
+  have hdim : Module.finrank ℂ (HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+    (CongruenceSubgroup.Gamma0 N).subtype)) ≤ 2 * Module.finrank ℂ (CuspForm
+    (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2)) :=
+    by
+    rcases Nat.eq_zero_or_pos n with rfl | hpos
+    · have hU := HeckeEis.finrank_coeffH1par_zero_le_two_mul_genusFormula N
+      have hL := CuspForm.genusFormula_le_finrank_gamma0_weight_two N
+      rw [ISCAsm.finrank_cuspForm_congr N (show (2 : ℤ) = ((0 : ℕ) : ℤ) + 2 by norm_num)] at hL
+      have : (Module.finrank ℂ (HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ 0).comp
+        (CongruenceSubgroup.Gamma0 N).subtype)) : ℚ)
+          ≤ 2 * (Module.finrank ℂ (CuspForm (CongruenceSubgroup.Gamma0 N) (((0 : ℕ) : ℤ) + 2)) : ℚ)
+            := by
+            linarith
+      exact_mod_cast this
+    · have hn2 : 2 ≤ n := by
+        obtain ⟨m, rfl⟩ := hne
+        omega
+      have hU := HeckeEis.finrank_coeffH1par_le_two_mul_dimFormula N n hn2 hne
+      have hL := CuspForm.dimFormula_le_finrank_gamma0 N (n + 2) (by omega) (hne.add even_two)
+      rw [ISCAsm.finrank_cuspForm_congr N (show ((n + 2 : ℕ) : ℤ) = (n : ℤ) + 2 by
+        push_cast; ring)] at hL
+      have : (Module.finrank ℂ (HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+        (CongruenceSubgroup.Gamma0 N).subtype)) : ℚ) ≤ 2 * (Module.finrank ℂ (CuspForm
+        (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2)) : ℚ) :=
+        by
+        push_cast at hU hL ⊢
+        linarith
+      exact_mod_cast this
+  exact ISCAsm.isCompl_range_of_finrank_le ES ESbar hESinj hESbar_inj hdisj hdim
+
+end S_HeckeEis_isCompl_range_eichlerShimuraMap_range_conj
+end P2MW
+export P2MW.S_HeckeEis_isCompl_range_eichlerShimuraMap_range_conj (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.isCompl_range_eichlerShimuraMap_range_conj (N : ℕ) [NeZero N] (n : ℕ)
+    (ES : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2) →ₗ[ℂ] HeckeEis.coeffH1par
+      ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype))
+    (hES : ∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2), ES f =
+      HeckeEis.eichlerShimuraMap n N f)
+    (Φ : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+      N).subtype) →+ HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype))
+    (hΦ : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+        (CongruenceSubgroup.Gamma0 N).subtype)),
+        (∀ g : CongruenceSubgroup.Gamma0 N, ((w : CongruenceSubgroup.Gamma0 N →
+          ↥(HeckeEis.BinaryForm ℂ n)) g : MvPolynomial (Fin 2) ℂ)
+            = MvPolynomial.map (starRingEnd ℂ)
+                (((z : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n)) g : MvPolynomial
+                  (Fin 2) ℂ))) ∧
+        Φ (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w)
+    (ESbar : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2) →ₛₗ[starRingEnd ℂ]
+      HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+      N).subtype))
+    (hESbar : ∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2), ESbar f = Φ (ES f)) :
+    IsCompl (LinearMap.range ES) (LinearMap.range ESbar) :=
+  solution N n ES hES Φ hΦ ESbar hESbar
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_isEquivariantPrimitiveWith_of_isEichlerIntegral.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_isEquivariantPrimitiveWith_of_isEichlerIntegral.lean
new file mode 100644
index 0000000000..0c8960542e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_isEquivariantPrimitiveWith_of_isEichlerIntegral.lean
@@ -0,0 +1,122 @@
+/-
+Based on Prove2Me node HeckeEis.isEquivariantPrimitiveWith_of_isEichlerIntegral
+(daa1f7da-7620-5a5c-9047-44d2ff15d46b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission bf4e4bdb-bcbc-5799-b4f4-d133245fc744
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.SlashActions
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_exists_sub_eq_const
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_slash
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Eichler integrals of slash-invariant f are equivariant primitives
+
+Theorem statement: `HeckeEis.isEquivariantPrimitiveWith_of_isEichlerIntegral`
+(`daa1f7da-7620-5a5c-9047-44d2ff15d46b`), by Claude, 2026-09-05.
+
+Proof: submission `bf4e4bdb-bcbc-5799-b4f4-d133245fc744`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $n \in \mathbb{N}$, a subgroup $\Gamma \le \mathrm{SL}_2(\mathbb{Z})$, a function $f :
+\mathfrak{H} \to \mathbb{C}$ on the upper half-plane, and a function $F$ from $\mathfrak{H}$ to
+[`HeckeEis.BinaryForm ℂ n`](def/HeckeEis_BinaryFormRep.html#L25), the submodule of
+$\mathbb{C}[X_0,X_1]$ of forms homogeneous of degree $n$. Assume first that $F$ is an Eichler
+integral of $f$ in the sense of
+[`HeckeEis.IsEichlerIntegral`](def/HeckeEis_EichlerIntegral.html#L105): for every exponent vector $d
+: \mathrm{Fin}\,2 \to_0 \mathbb{N}$ and every $\tau \in \mathfrak{H}$, the function $z \mapsto
+\mathrm{coeff}_d\,F(z)$ (with $F$ extended to $\mathbb{C}$ by `ofComplex`) has complex derivative
+$f(\tau)\cdot \mathrm{coeff}_d\big((\tau X_0 + X_1)^n\big)$ at $z = \tau$. Assume second that $f
+\mid_{n+2} \gamma = f$ for every $\gamma \in \Gamma$, the slash action in weight $(n : \mathbb{Z}) +
+2$. The conclusion is [`HeckeEis.IsEquivariantPrimitiveWith`](def/HeckeEis_EichlerIntegral.html#L68)
+for the restriction to $\Gamma$ of the representation `binaryFormRepSL` of
+$\mathrm{SL}_2(\mathbb{Z})$ on degree-$n$ binary forms, given by the substitution $X_j \mapsto
+\sum_i M_{ij} X_i$: for every $\gamma \in \Gamma$ there is a binary form $c$ of degree $n$ with
+$F(\gamma \cdot \tau) - \rho(\gamma)\,F(\tau) = c$ for all $\tau \in \mathfrak{H}$. No holomorphy or
+growth condition on $f$ is imposed beyond the stated invariance.
+
+This is the first step of Eichler–Shimura theory: the period map attached to an Eichler integral,
+$\gamma \mapsto F(\gamma\tau) - \rho_n(\gamma)F(\tau)$, is independent of $\tau$ and so defines a
+cocycle on $\Gamma$ with values in $\mathrm{Sym}^n$. It is used in the construction of Eichler
+integrals with parabolic cocycles and in the comparison of modular forms with cohomology classes
+under the Hecke action.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_isEquivariantPrimitiveWith_of_isEichlerIntegral.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_isEquivariantPrimitiveWith_of_isEichlerIntegral
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binaryFormRepSL IsEquivariantPrimitiveWith IsEichlerIntegral \
+  IsEichlerIntegral.slash IsEichlerIntegral.exists_sub_eq_const"
+p2m_open "HeckeEis"
+
+open UpperHalfPlane MvPolynomial ModularForm CongruenceSubgroup
+open scoped MatrixGroups ModularForm
+
+theorem SolMain.p1b
+    {n : ℕ} {Γ : Subgroup SL(2, ℤ)} {f : ℍ → ℂ} {F : ℍ → ↥(BinaryForm ℂ n)}
+    (hF : IsEichlerIntegral n f F)
+    (hf : ∀ γ ∈ Γ, (f ∣[((n : ℤ) + 2)] γ) = f) :
+    IsEquivariantPrimitiveWith ((binaryFormRepSL ℂ n).comp Γ.subtype) F := by
+  intro γ
+  have hslash := hF.slash (γ : SL(2, ℤ))
+  rw [hf _ γ.2] at hslash
+  obtain ⟨v, hv⟩ := hslash.exists_sub_eq_const hF
+  refine ⟨binaryFormRepSL ℂ n (γ : SL(2, ℤ)) v, fun τ => ?_⟩
+  change F ((γ : SL(2, ℤ)) • τ) - binaryFormRepSL ℂ n (γ : SL(2, ℤ)) (F τ) = _
+  rw [← hv τ, map_sub, ← Module.End.mul_apply, ← map_mul, mul_inv_cancel, map_one,
+    Module.End.one_apply]
+
+end HeckeEis
+
+end
+
+open scoped MatrixGroups ModularForm in
+theorem solution
+    {n : ℕ} {Γ : Subgroup SL(2, ℤ)} {f : UpperHalfPlane → ℂ}
+    {F : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)}
+    (hF : HeckeEis.IsEichlerIntegral n f F)
+    (hf : ∀ γ ∈ Γ, (f ∣[((n : ℤ) + 2)] γ) = f) :
+    HeckeEis.IsEquivariantPrimitiveWith ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype) F :=
+  HeckeEis.SolMain.p1b hF hf
+
+end S_HeckeEis_isEquivariantPrimitiveWith_of_isEichlerIntegral
+end P2MW
+export P2MW.S_HeckeEis_isEquivariantPrimitiveWith_of_isEichlerIntegral (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups ModularForm
+theorem HeckeEis.isEquivariantPrimitiveWith_of_isEichlerIntegral
+    {n : ℕ} {Γ : Subgroup SL(2, ℤ)} {f : UpperHalfPlane → ℂ}
+    {F : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)}
+    (hF : HeckeEis.IsEichlerIntegral n f F)
+    (hf : ∀ γ ∈ Γ, (f ∣[((n : ℤ) + 2)] γ) = f) :
+    HeckeEis.IsEquivariantPrimitiveWith ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype) F :=
+  solution hF hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_isParabolicCocycle_cocycle_of_isEichlerIntegral.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_isParabolicCocycle_cocycle_of_isEichlerIntegral.lean
new file mode 100644
index 0000000000..ed6bba02c6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_isParabolicCocycle_cocycle_of_isEichlerIntegral.lean
@@ -0,0 +1,225 @@
+/-
+Based on Prove2Me node HeckeEis.isParabolicCocycle_cocycle_of_isEichlerIntegral
+(d7d80da1-bf33-5fbb-9d43-d741a354aaac) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7b4cd390-34f4-528d-a193-f8320f464bae
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import Mathlib.NumberTheory.ModularForms.QExpansion
+import Mathlib.NumberTheory.ModularForms.NormTrace
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_slash
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_vadd_sub_T_zpow_apply_mem_range
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_binaryFormRepSL_neg_one_apply
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularGroup_exists_eq_conj_T_zpow_of_trace_sq_eq_four
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Eichler integrals of cusp forms give parabolic cocycles
+
+Theorem statement: `HeckeEis.isParabolicCocycle_cocycle_of_isEichlerIntegral`
+(`d7d80da1-bf33-5fbb-9d43-d741a354aaac`), by Claude, 2026-09-05.
+
+Proof: submission `7b4cd390-34f4-528d-a193-f8320f464bae`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix natural numbers $N$ (nonzero) and $n$, and let $f$ be a cusp form of weight $(n:\mathbb{Z})+2$
+for $\Gamma_0(N)$. Let $\rho$ denote the representation of $\Gamma_0(N)$ on the space
+[`HeckeEis.BinaryForm ℂ n`](def/HeckeEis_BinaryFormRep.html#L25) of degree-$n$ homogeneous
+polynomials in $X_0,X_1$ over $\mathbb{C}$ obtained by restricting [`HeckeEis.binaryFormRepSL ℂ
+n`](def/HeckeEis_BinaryFormRep.html#L61) along the inclusion of $\Gamma_0(N)$ into
+$\mathrm{SL}_2(\mathbb{Z})$, where a matrix $M$ acts by the substitution $X_j \mapsto \sum_i M_{ij}
+X_i$. Let $F : \mathfrak{H} \to$ [`HeckeEis.BinaryForm ℂ n`](def/HeckeEis_BinaryFormRep.html#L25)
+satisfy two hypotheses. First, $F$ is an Eichler integral of $f$: for every monomial exponent $d$
+and every $\tau \in \mathfrak{H}$, the function $z \mapsto
+\mathrm{coeff}_d\bigl(F(\mathrm{ofComplex}\,z)\bigr)$ is differentiable at $\tau$ with derivative
+$f(\tau)\,\mathrm{coeff}_d\bigl((\tau X_0 + X_1)^n\bigr)$. Second, $F$ is an equivariant primitive
+for $\rho$: for each $\gamma \in \Gamma_0(N)$ the difference $F(\gamma \cdot \tau) -
+\rho(\gamma)F(\tau)$ is independent of $\tau$. The conclusion is that the associated cocycle
+$z(\gamma) = F(\gamma \cdot i) - \rho(\gamma)F(i)$ is parabolic in the sense that for every $\gamma
+\in \Gamma_0(N)$ with $(\mathrm{tr}\,\gamma)^2 = 4$ one has $z(\gamma) \in
+\mathrm{range}\bigl(\rho(\gamma) - 1\bigr)$.
+
+This is the parabolicity (cuspidality) of the Eichler–Shimura cocycle attached to a cusp form of
+weight $n+2$, in the weight-$(n+2)$ coefficient module $\mathrm{Sym}^n$ of binary forms; it is what
+places the cocycle in parabolic cohomology rather than merely in $H^1$. It feeds the construction of
+the Eichler–Shimura map and the computation of its compatibility with the Hecke operators $T$ and
+$U$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_isParabolicCocycle_cocycle_of_isEichlerIntegral.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_isParabolicCocycle_cocycle_of_isEichlerIntegral
+
+open scoped Manifold MatrixGroups
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binaryFormRepSL IsParabolicCocycle IsEquivariantPrimitiveWith \
+  IsEichlerIntegral binaryFormRepSL_neg_one_apply"
+namespace ParabolicSol
+p2m_open "HeckeEis"
+
+p2m_open "UpperHalfPlane MvPolynomial CongruenceSubgroup HeckeEis \
+  P2MW.S_HeckeEis_isParabolicCocycle_cocycle_of_isEichlerIntegral.HeckeEis"
+open scoped Manifold MatrixGroups ModularForm Pointwise
+
+theorem periodic_slash_comp_ofComplex_of_conj_T_zpow_mem {k : ℤ} {Γ : Subgroup SL(2, ℤ)}
+    {F' : Type*}
+    [FunLike F' ℍ ℂ] [SlashInvariantFormClass F' (Γ : Subgroup (GL (Fin 2) ℝ)) k] (f : F')
+    (δ : SL(2, ℤ)) {h : ℤ}
+    (hmem : δ * ModularGroup.T ^ h * δ⁻¹ ∈ Γ) :
+    Function.Periodic (((f : ℍ → ℂ) ∣[k] δ) ∘ ofComplex) ((h : ℝ) : ℂ) := by
+  refine SlashInvariantFormClass.periodic_comp_ofComplex
+    (SlashInvariantForm.translate f (Matrix.SpecialLinearGroup.mapGL ℝ δ)) ?_
+  rw [Subgroup.mem_strictPeriods_iff, map_inv, Subgroup.mem_inv_pointwise_smul_iff,
+    ConjAct.toConjAct_smul]
+  have hTh : Matrix.SpecialLinearGroup.mapGL ℝ (ModularGroup.T ^ h)
+      = Matrix.GeneralLinearGroup.upperRightHom (h : ℝ) := by
+    rw [Units.ext_iff, Matrix.SpecialLinearGroup.mapGL_coe_matrix,
+      Matrix.SpecialLinearGroup.map_apply_coe,
+      ModularGroup.coe_T_zpow, Matrix.GeneralLinearGroup.upperRightHom_apply]
+    ext i j
+    fin_cases i <;> fin_cases j <;> simp
+  rw [← hTh, ← map_mul, ← map_inv, ← map_mul]
+  exact Subgroup.mem_map_of_mem _ hmem
+
+theorem Gamma_le_Gamma0 (N : ℕ) : Gamma N ≤ Gamma0 N := fun _ hA =>
+  Gamma0_mem.mpr (Gamma_mem.mp hA).2.2.1
+
+end HeckeEis.ParabolicSol
+
+open _root_.HeckeEis _root_.P2MW.S_HeckeEis_isParabolicCocycle_cocycle_of_isEichlerIntegral.HeckeEis
+  HeckeEis.ParabolicSol UpperHalfPlane CongruenceSubgroup in
+open scoped ModularForm Pointwise in
+theorem solution (N n : ℕ) [NeZero N]
+    (f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2))
+    {F : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)}
+    (hEI : HeckeEis.IsEichlerIntegral n f F)
+    (hF : HeckeEis.IsEquivariantPrimitiveWith
+      ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype) F) :
+    HeckeEis.IsParabolicCocycle
+      ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype) hF.cocycle := by
+  have : (Gamma0 N).FiniteIndex := Subgroup.finiteIndex_of_le (Gamma_le_Gamma0 N)
+  set ρ := (binaryFormRepSL ℂ n).comp (Gamma0 N).subtype with hρ
+  set R := binaryFormRepSL ℂ n with hR
+  have hρapp : ∀ γ : Gamma0 N, ρ γ = R (γ : SL(2, ℤ)) := fun γ => rfl
+  have hneg1 : (-1 : SL(2, ℤ)) ∈ Gamma0 N := by
+    rw [Gamma0_mem]
+    simp
+  have hRinv : ∀ (x : SL(2, ℤ)) (v : ↥(BinaryForm ℂ n)), R x⁻¹ (R x v) = v := fun x v => by
+    rw [← Module.End.mul_apply, ← map_mul, inv_mul_cancel, map_one, Module.End.one_apply]
+  have hRinv' : ∀ (x : SL(2, ℤ)) (v : ↥(BinaryForm ℂ n)), R x (R x⁻¹ v) = v := fun x v => by
+    rw [← Module.End.mul_apply, ← map_mul, mul_inv_cancel, map_one, Module.End.one_apply]
+  intro γ hγ
+  rcases Nat.even_or_odd n with heven | hodd
+  · obtain ⟨ε, δ, h, hε, hγeq⟩ :=
+      ModularGroup.exists_eq_conj_T_zpow_of_trace_sq_eq_four (γ : SL(2, ℤ)) hγ
+    have hRε : R ε = 1 := by
+      rcases hε with rfl | rfl
+      · exact map_one R
+      · refine LinearMap.ext fun P => ?_
+        rw [hR, binaryFormRepSL_neg_one_apply, Even.neg_one_pow heven, one_smul,
+          Module.End.one_apply]
+    have hRεx : ∀ x : SL(2, ℤ), R (ε * x) = R x := fun x => by rw [map_mul, hRε, one_mul]
+    have hεsmul : ∀ (x : SL(2, ℤ)) (τ : ℍ), (ε * x) • τ = x • τ := by
+      rcases hε with rfl | rfl
+      · intro x τ; rw [one_mul]
+      · intro x τ; rw [neg_one_mul]; exact ModularGroup.SL_neg_smul x τ
+    have hσ : δ * ModularGroup.T ^ h * δ⁻¹ ∈ Gamma0 N := by
+      rcases hε with rfl | rfl
+      · rw [one_mul] at hγeq; rw [← hγeq]; exact γ.2
+      · have e : δ * ModularGroup.T ^ h * δ⁻¹ = -1 * (γ : SL(2, ℤ)) :=
+          by rw [hγeq, ← mul_assoc, neg_one_mul, neg_neg, one_mul]
+        rw [e]; exact Subgroup.mul_mem _ hneg1 γ.2
+    set g : ℍ → ℂ := (f : ℍ → ℂ) ∣[((n : ℤ) + 2)] δ with hg
+    set G : ℍ → ↥(BinaryForm ℂ n) := fun τ => R δ⁻¹ (F (δ • τ)) with hGdef
+    have hGEI : IsEichlerIntegral n g G := hEI.slash δ
+    have hghol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g := (CuspFormClass.holo f).slash _ _
+    have hgzero : IsZeroAtImInfty g := CuspFormClass.zero_at_infty_slash f δ
+    have hgper : Function.Periodic (g ∘ ofComplex) ((h : ℝ) : ℂ) :=
+      periodic_slash_comp_ofComplex_of_conj_T_zpow_mem f δ hσ
+    have hFG : ∀ u : ℍ, F (δ • u) = R δ (G u) := fun u => by rw [hGdef, hRinv']
+    have hcoc : hF.cocycle γ = R δ (G (ModularGroup.T ^ h • I) - R (ModularGroup.T ^ h) (G I)) := by
+      rw [← hF.sub_eq_cocycle γ (δ • I), hρapp, hγeq, hεsmul, hRεx, ← mul_smul,
+        inv_mul_cancel_right, mul_smul,
+        hFG, hFG, map_mul, map_mul, Module.End.mul_apply, Module.End.mul_apply, hRinv, map_sub]
+    have htrans : ∀ y ∈ LinearMap.range (R (ModularGroup.T ^ h) - 1), R δ y ∈ LinearMap.range (ρ γ -
+      1) :=
+      by
+      rintro _ ⟨w, rfl⟩
+      refine ⟨R δ w, ?_⟩
+      rw [LinearMap.sub_apply, Module.End.one_apply, hρapp, hγeq, hRεx, map_mul, map_mul,
+        Module.End.mul_apply,
+        Module.End.mul_apply, hRinv, LinearMap.sub_apply, Module.End.one_apply, map_sub]
+    rw [hcoc]
+    apply htrans
+    rcases eq_or_ne h 0 with rfl | hh
+    · simp
+    · rw [UpperHalfPlane.modular_T_zpow_smul]
+      exact hGEI.vadd_sub_T_zpow_apply_mem_range hh hgper hghol hgzero I
+  · set m : Gamma0 N := ⟨-1, hneg1⟩ with hm
+    have hρm : ∀ v, ρ m v = -v := fun v => by
+      rw [hρapp]
+      change binaryFormRepSL ℂ n (-1) v = -v
+      rw [binaryFormRepSL_neg_one_apply, Odd.neg_one_pow hodd]
+      exact neg_one_smul ℂ v
+    have hz := hF.cocycle_mem_coeffCocycles
+    have hcomm : γ * m = m * γ := Subtype.ext (by simp [hm])
+    have h1 := hz γ m
+    have h2 := hz m γ
+    rw [hcomm, h2, hρm] at h1
+    have h4 : hF.cocycle γ + hF.cocycle γ = hF.cocycle m - ρ γ (hF.cocycle m) := by
+      rw [eq_sub_iff_add_eq]
+      calc hF.cocycle γ + hF.cocycle γ + ρ γ (hF.cocycle m)
+          = hF.cocycle γ + (hF.cocycle γ + ρ γ (hF.cocycle m)) := by abel
+        _ = hF.cocycle γ + (hF.cocycle m + -hF.cocycle γ) := by rw [h1]
+        _ = hF.cocycle m := by abel
+    refine ⟨-((2 : ℂ)⁻¹ • hF.cocycle m), ?_⟩
+    rw [LinearMap.sub_apply, Module.End.one_apply, map_neg, map_smul, sub_neg_eq_add]
+    calc -((2 : ℂ)⁻¹ • ρ γ (hF.cocycle m)) + (2 : ℂ)⁻¹ • hF.cocycle m
+        = (2 : ℂ)⁻¹ • (hF.cocycle m - ρ γ (hF.cocycle m)) := by rw [smul_sub]; abel
+      _ = (2 : ℂ)⁻¹ • (hF.cocycle γ + hF.cocycle γ) := by rw [h4]
+      _ = hF.cocycle γ := by rw [← two_smul ℂ, smul_smul, inv_mul_cancel₀ two_ne_zero, one_smul]
+
+end
+
+end S_HeckeEis_isParabolicCocycle_cocycle_of_isEichlerIntegral
+end P2MW
+export P2MW.S_HeckeEis_isParabolicCocycle_cocycle_of_isEichlerIntegral (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Manifold MatrixGroups
+theorem HeckeEis.isParabolicCocycle_cocycle_of_isEichlerIntegral (N n : ℕ) [NeZero N]
+    (f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2))
+    {F : UpperHalfPlane → ↥(HeckeEis.BinaryForm ℂ n)}
+    (hEI : HeckeEis.IsEichlerIntegral n f F)
+    (hF : HeckeEis.IsEquivariantPrimitiveWith
+      ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype) F) :
+    HeckeEis.IsParabolicCocycle
+      ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype) hF.cocycle :=
+  solution N n f hEI hF
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_jFactor_pow_mul_eval_binaryFormRepSL.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_jFactor_pow_mul_eval_binaryFormRepSL.lean
new file mode 100644
index 0000000000..cdea5c092d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_jFactor_pow_mul_eval_binaryFormRepSL.lean
@@ -0,0 +1,155 @@
+/-
+Based on Prove2Me node HeckeEis.jFactor_pow_mul_eval_binaryFormRepSL
+(494216ec-849a-5e02-bbdf-6d4fb405713d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b44b358b-be4f-5ac3-86ee-b4bfcfc152d6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Weight identity j(g,τ)ⁿ(ρₙ(g)P)(1,-gτ)=P(1,-τ)
+
+Theorem statement: `HeckeEis.jFactor_pow_mul_eval_binaryFormRepSL`
+(`494216ec-849a-5e02-bbdf-6d4fb405713d`), by Claude, 2026-09-05.
+
+Proof: submission `b44b358b-be4f-5ac3-86ee-b4bfcfc152d6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $n$, an element $g\in\mathrm{SL}_2(\mathbb{Z})$, a point $\tau$ of the upper
+half-plane, and an element $P$ of [`HeckeEis.BinaryForm ℂ n`](def/HeckeEis_BinaryFormRep.html#L25),
+that is, of the submodule of $\mathbb{C}[X_0,X_1]$ (polynomials in two variables indexed by `Fin 2`)
+consisting of the forms homogeneous of degree $n$. Here [`HeckeEis.jFactor g
+τ`](def/HeckeEis_EichlerIntegral.html#L28) denotes the complex number $g_{10}\tau+g_{11}$ formed
+from the bottom row of the integer matrix underlying $g$, and [`HeckeEis.binaryFormRepSL ℂ
+n`](def/HeckeEis_BinaryFormRep.html#L61) is the representation of $\mathrm{SL}_2(\mathbb{Z})$ on
+degree-$n$ binary forms obtained by restricting to that submodule the algebra endomorphism of
+$\mathbb{C}[X_0,X_1]$ that substitutes $X_j\mapsto\sum_{i}g_{ij}X_i$, i.e. substitution of the row
+vector times the matrix $g$. The assertion is the identity of complex numbers
+$$\big(g_{10}\tau+g_{11}\big)^{n}\cdot\big(\rho_n(g)P\big)\big(1,\,-(g\cdot\tau)\big)=P\big(1,\,-
+\tau\big),$$
+where both sides are evaluations of the underlying polynomials at the indicated points of
+$\mathbb{C}^2$ (given as `Fin 2`-vectors), $\rho_n(g)P$ is the image of $P$ under the above
+representation, and $g\cdot\tau$ is the Möbius action of $g$ on the upper half-plane.
+
+This is the compatibility between the degree-$n$ substitution action on binary forms and the line
+spanned by $(1,-\tau)$: pairing a $\rho_n$-equivariant vector-valued function with $(1,-\tau)$
+produces a scalar function transforming with weight $-n$, which is the mechanism behind the
+Eichler–Shimura period map. It is used in the proof that the Eichler–Shimura map is injective
+([`HeckeEis.eichlerShimuraMap_injective`](thm.html#HeckeEis.eichlerShimuraMap_injective)) and in the
+boundedness of such evaluations towards the cusp $i\infty$
+([`HeckeEis.IsEichlerIntegral.isBoundedAtImInfty_eval`]
+(thm.html#HeckeEis.IsEichlerIntegral.isBoundedAtImInfty_eval)).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_jFactor_pow_mul_eval_binaryFormRepSL.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_jFactor_pow_mul_eval_binaryFormRepSL
+
+namespace HeckeEis
+p2m_export "HeckeEis" "eval_smul_of_isHomogeneous BinaryForm binarySubst binarySubst_X \
+  binaryFormRepSL binaryFormRepSL_apply_coe jFactor jFactor_ne_zero coe_smul_mul_jFactor"
+namespace PeriodFnAux
+p2m_open "HeckeEis"
+
+open UpperHalfPlane MvPolynomial
+open scoped MatrixGroups
+
+theorem eval_binarySubst {K : Type*} [CommRing K] (M : Matrix (Fin 2) (Fin 2) ℤ) (v : Fin 2 → K)
+    (P : MvPolynomial (Fin 2) K) :
+    MvPolynomial.eval v (binarySubst K M P)
+      = MvPolynomial.eval (fun j => ∑ i : Fin 2, ((M i j : ℤ) : K) * v i) P := by
+  have key : (MvPolynomial.eval v).comp (binarySubst K M : MvPolynomial (Fin 2) K →ₐ[K] MvPolynomial
+    (Fin 2) K).toRingHom
+      = MvPolynomial.eval (fun j => ∑ i : Fin 2, ((M i j : ℤ) : K) * v i) :=
+    MvPolynomial.ringHom_ext (fun a => by simp) (fun j => by simp [binarySubst_X])
+  exact RingHom.congr_fun key P
+
+theorem det_entries (g : SL(2, ℤ)) :
+    ((g : Matrix (Fin 2) (Fin 2) ℤ) 0 0 : ℂ) * ((g : Matrix (Fin 2) (Fin 2) ℤ) 1 1 : ℂ)
+      - ((g : Matrix (Fin 2) (Fin 2) ℤ) 0 1 : ℂ) * ((g : Matrix (Fin 2) (Fin 2) ℤ) 1 0 : ℂ) = 1 :=
+        by
+  have h := Matrix.SpecialLinearGroup.det_coe g
+  rw [Matrix.det_fin_two] at h
+  exact_mod_cast h
+
+theorem jFactor_pow_mul_eval_binaryFormRepSL (n : ℕ) (g : SL(2, ℤ)) (τ : ℍ) (P : ↥(BinaryForm ℂ n))
+    :
+    jFactor g τ ^ n * MvPolynomial.eval ![(1 : ℂ), -(((g • τ : ℍ)) : ℂ)]
+        ((binaryFormRepSL ℂ n g P : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ)
+      = MvPolynomial.eval ![(1 : ℂ), -(τ : ℂ)] (P : MvPolynomial (Fin 2) ℂ) := by
+  rw [binaryFormRepSL_apply_coe, eval_binarySubst]
+  have hj : jFactor g τ ≠ 0 := jFactor_ne_zero g τ
+  have hJ : jFactor g τ = ((g : Matrix (Fin 2) (Fin 2) ℤ) 1 0 : ℂ) * (τ : ℂ) + ((g : Matrix (Fin 2)
+    (Fin 2) ℤ) 1 1 : ℂ) :=
+    rfl
+  have hmul := coe_smul_mul_jFactor g τ
+  have hdet := det_entries g
+  have hrow : ∀ j : Fin 2, jFactor g τ * (∑ i : Fin 2, (((g : Matrix (Fin 2) (Fin 2) ℤ) i j : ℤ) :
+    ℂ)
+        * (![(1 : ℂ), -(((g • τ : ℍ)) : ℂ)]) i) = (![(1 : ℂ), -(τ : ℂ)]) j := by
+    intro j
+    fin_cases j
+    · simp only [Fin.sum_univ_two, Fin.isValue, Fin.zero_eta, Matrix.cons_val_zero,
+        Matrix.cons_val_one,
+        Matrix.cons_val_fin_one, mul_one]
+      linear_combination (-(((g : Matrix (Fin 2) (Fin 2) ℤ) 1 0 : ℤ) : ℂ)) * hmul
+        + (((g : Matrix (Fin 2) (Fin 2) ℤ) 0 0 : ℤ) : ℂ) * hJ + hdet
+    · simp only [Fin.sum_univ_two, Fin.isValue, Fin.mk_one, Matrix.cons_val_zero,
+        Matrix.cons_val_one,
+        Matrix.cons_val_fin_one, mul_one]
+      linear_combination (-(((g : Matrix (Fin 2) (Fin 2) ℤ) 1 1 : ℤ) : ℂ)) * hmul
+        + (((g : Matrix (Fin 2) (Fin 2) ℤ) 0 1 : ℤ) : ℂ) * hJ - (τ : ℂ) * hdet
+  have hpt : (fun j : Fin 2 => ∑ i : Fin 2, (((g : Matrix (Fin 2) (Fin 2) ℤ) i j : ℤ) : ℂ)
+        * (![(1 : ℂ), -(((g • τ : ℍ)) : ℂ)]) i)
+      = (jFactor g τ)⁻¹ • ![(1 : ℂ), -(τ : ℂ)] := by
+    funext j
+    rw [Pi.smul_apply, smul_eq_mul, ← hrow j, ← mul_assoc, inv_mul_cancel₀ hj, one_mul]
+  rw [hpt, eval_smul_of_isHomogeneous ((mem_homogeneousSubmodule n _).mp P.2), ← mul_assoc, ←
+    mul_pow,
+    mul_inv_cancel₀ hj, one_pow, one_mul]
+
+end HeckeEis.PeriodFnAux
+
+open scoped MatrixGroups in
+theorem solution (n : ℕ) (g : SL(2, ℤ)) (τ : UpperHalfPlane)
+    (P : ↥(HeckeEis.BinaryForm ℂ n)) :
+    HeckeEis.jFactor g τ ^ n * MvPolynomial.eval ![(1 : ℂ), -(((g • τ : UpperHalfPlane)) : ℂ)]
+        ((HeckeEis.binaryFormRepSL ℂ n g P : ↥(HeckeEis.BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ)
+      = MvPolynomial.eval ![(1 : ℂ), -(τ : ℂ)] (P : MvPolynomial (Fin 2) ℂ) :=
+  HeckeEis.PeriodFnAux.jFactor_pow_mul_eval_binaryFormRepSL n g τ P
+
+end S_HeckeEis_jFactor_pow_mul_eval_binaryFormRepSL
+end P2MW
+export P2MW.S_HeckeEis_jFactor_pow_mul_eval_binaryFormRepSL (solution)
+
+end privateSection
+
+public section publicSection
+
+open scoped MatrixGroups
+theorem HeckeEis.jFactor_pow_mul_eval_binaryFormRepSL (n : ℕ) (g : SL(2, ℤ)) (τ : UpperHalfPlane)
+    (P : ↥(HeckeEis.BinaryForm ℂ n)) :
+    HeckeEis.jFactor g τ ^ n * MvPolynomial.eval ![(1 : ℂ), -(((g • τ : UpperHalfPlane)) : ℂ)]
+        ((HeckeEis.binaryFormRepSL ℂ n g P : ↥(HeckeEis.BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ)
+      = MvPolynomial.eval ![(1 : ℂ), -(τ : ℂ)] (P : MvPolynomial (Fin 2) ℂ) :=
+  solution n g τ P
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_le_finrank_fixed_S_and_ST_binaryFormRepSL.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_le_finrank_fixed_S_and_ST_binaryFormRepSL.lean
new file mode 100644
index 0000000000..09250729b4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_le_finrank_fixed_S_and_ST_binaryFormRepSL.lean
@@ -0,0 +1,389 @@
+/-
+Based on Prove2Me node HeckeEis.le_finrank_fixed_S_and_ST_binaryFormRepSL
+(7ef3eb5d-8676-5eea-ab2a-8a4605d1a228) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8ac7cf56-5010-5b5b-bb9c-7bf3342fa1e0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Basic.Complex.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+
+import Mathlib.Algebra.MvPolynomial.Monad
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Analysis.CStarAlgebra.Classes
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Lower bounds for S- and ST-fixed binary forms
+
+Theorem statement: `HeckeEis.le_finrank_fixed_S_and_ST_binaryFormRepSL`
+(`7ef3eb5d-8676-5eea-ab2a-8a4605d1a228`), by Claude, 2026-09-05.
+
+Proof: submission `8ac7cf56-5010-5b5b-bb9c-7bf3342fa1e0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $n$ be a natural number, assumed even. Consider the space of binary forms of degree $n$ over
+$\mathbb{C}$, i.e. the submodule $\mathrm{homogeneousSubmodule}$ of homogeneous polynomials of
+degree $n$ in $\mathbb{C}[X_0,X_1]$, equipped with the representation [`HeckeEis.binaryFormRepSL ℂ
+n`](def/HeckeEis_BinaryFormRep.html#L61) of $\mathrm{SL}(2,\mathbb{Z})$ in which a matrix $M$ acts
+by the substitution algebra endomorphism sending $X_j$ to $\sum_{i} M_{ij} X_i$ (the image of the
+integer entries in $\mathbb{C}$), restricted to the degree-$n$ part. Write $\rho$ for this
+representation, and let $S$ and $T$ be the standard generators `ModularGroup.S` and
+`ModularGroup.T`. The assertion is the conjunction of two inequalities between natural numbers:
+first, $n+1-2\lfloor (n+2)/4\rfloor$ is at most the $\mathbb{C}$-dimension of $\ker(\rho(S)-1)$, the
+space of forms fixed by $S$; second, $n+1-2\lfloor (n+2)/3\rfloor$ is at most the
+$\mathbb{C}$-dimension of $\ker(\rho(S\cdot T)-1)$, the space of forms fixed by $ST$. Here division
+and subtraction are those of the natural numbers, so the quotients are floors and the subtractions
+truncated at $0$. Only lower bounds are asserted, although both are in fact equalities.
+
+These are the two elliptic-point contributions appearing in the dimension formula for modular forms,
+expressed as the dimensions of the fixed subspaces of the order-$4$ element $S$ and the order-$6$
+element $ST$ acting on degree-$n$ binary forms. The bounds are used by
+[`HeckeEis.finrank_coeffH1par_le_two_mul_dimFormula`]
+(thm.html#HeckeEis.finrank_coeffH1par_le_two_mul_dimFormula)
+to control the dimension of a parabolic cohomology group by twice the dimension-formula value.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_le_finrank_fixed_S_and_ST_binaryFormRepSL.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 1600000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_le_finrank_fixed_S_and_ST_binaryFormRepSL
+
+
+open scoped MatrixGroups
+open MvPolynomial
+
+namespace UH1
+
+noncomputable def tau (c₁ c₂ : ℂ) : MvPolynomial (Fin 2) ℂ →ₐ[ℂ] MvPolynomial (Fin 2) ℂ :=
+  MvPolynomial.aeval fun j : Fin 2 => if j = 0 then X 0 + C c₁ * X 1 else X 0 + C c₂ * X 1
+
+noncomputable def tauInv (c₁ c₂ : ℂ) : MvPolynomial (Fin 2) ℂ →ₐ[ℂ] MvPolynomial (Fin 2) ℂ :=
+  MvPolynomial.aeval fun j : Fin 2 =>
+    if j = 0 then C ((c₂ - c₁)⁻¹) * (C c₂ * X 0 - C c₁ * X 1) else C ((c₂ - c₁)⁻¹) * (X 1 - X 0)
+
+theorem tau_X0 (c₁ c₂ : ℂ) : tau c₁ c₂ (X 0) = X 0 + C c₁ * X 1 := by
+  simp [tau]
+
+theorem tau_X1 (c₁ c₂ : ℂ) : tau c₁ c₂ (X 1) = X 0 + C c₂ * X 1 := by
+  simp [tau]
+
+theorem tauInv_comp_tau (c₁ c₂ : ℂ) (hc : c₁ ≠ c₂) :
+    (tauInv c₁ c₂).comp (tau c₁ c₂) = AlgHom.id ℂ _ := by
+  have hne : (c₂ - c₁) ≠ 0 := sub_ne_zero.mpr (Ne.symm hc)
+  refine MvPolynomial.algHom_ext fun j => ?_
+  fin_cases j
+  · simp only [AlgHom.comp_apply, AlgHom.id_apply]
+    change tauInv c₁ c₂ (tau c₁ c₂ (X 0)) = X 0
+    rw [tau_X0, map_add, map_mul, MvPolynomial.algHom_C, MvPolynomial.algebraMap_eq]
+    simp only [tauInv, MvPolynomial.aeval_X, Fin.isValue, ↓reduceIte, one_ne_zero]
+    have key : C ((c₂ - c₁)⁻¹) * (C c₂ * X 0 - C c₁ * X 1) + C c₁ * (C ((c₂ - c₁)⁻¹) * (X 1 - X 0))
+        = C ((c₂ - c₁)⁻¹ * (c₂ - c₁)) * (X 0 : MvPolynomial (Fin 2) ℂ) := by
+      simp only [map_mul, map_sub]
+      ring
+    rw [key, inv_mul_cancel₀ hne, C_1, one_mul]
+  · simp only [AlgHom.comp_apply, AlgHom.id_apply]
+    change tauInv c₁ c₂ (tau c₁ c₂ (X 1)) = X 1
+    rw [tau_X1, map_add, map_mul, MvPolynomial.algHom_C, MvPolynomial.algebraMap_eq]
+    simp only [tauInv, MvPolynomial.aeval_X, Fin.isValue, ↓reduceIte, one_ne_zero]
+    have key : C ((c₂ - c₁)⁻¹) * (C c₂ * X 0 - C c₁ * X 1) + C c₂ * (C ((c₂ - c₁)⁻¹) * (X 1 - X 0))
+        = C ((c₂ - c₁)⁻¹ * (c₂ - c₁)) * (X 1 : MvPolynomial (Fin 2) ℂ) := by
+      simp only [map_mul, map_sub]
+      ring
+    rw [key, inv_mul_cancel₀ hne, C_1, one_mul]
+
+theorem tau_injective (c₁ c₂ : ℂ) (hc : c₁ ≠ c₂) : Function.Injective (tau c₁ c₂) := by
+  intro p q h
+  have := congrArg (tauInv c₁ c₂) h
+  rwa [← AlgHom.comp_apply, ← AlgHom.comp_apply, tauInv_comp_tau c₁ c₂ hc, AlgHom.id_apply,
+    AlgHom.id_apply] at this
+
+noncomputable def bvec (c₁ c₂ : ℂ) (n a : ℕ) : MvPolynomial (Fin 2) ℂ :=
+  (X 0 + C c₁ * X 1) ^ a * (X 0 + C c₂ * X 1) ^ (n - a)
+
+theorem bvec_eq_tau (c₁ c₂ : ℂ) (n a : ℕ) :
+    bvec c₁ c₂ n a = tau c₁ c₂ (X 0 ^ a * X 1 ^ (n - a)) := by
+  rw [map_mul, map_pow, map_pow, tau_X0, tau_X1, bvec]
+
+theorem isHomogeneous_lin (c : ℂ) : (X 0 + C c * X 1 : MvPolynomial (Fin 2) ℂ).IsHomogeneous 1 :=
+  (MvPolynomial.isHomogeneous_X ℂ 0).add ((MvPolynomial.isHomogeneous_X ℂ 1).C_mul c)
+
+theorem bvec_mem (c₁ c₂ : ℂ) (n a : ℕ) (ha : a ≤ n) : bvec c₁ c₂ n a ∈ HeckeEis.BinaryForm ℂ n := by
+  rw [MvPolynomial.mem_homogeneousSubmodule, bvec]
+  have h := ((isHomogeneous_lin c₁).pow a).mul ((isHomogeneous_lin c₂).pow (n - a))
+  rwa [one_mul, one_mul, Nat.add_sub_cancel' ha] at h
+
+theorem linearIndependent_monomials {ι : Type*} (n : ℕ) (a : ι → ℕ) (ha : Function.Injective a) :
+    LinearIndependent ℂ (fun t => (X 0 ^ a t * X 1 ^ (n - a t) : MvPolynomial (Fin 2) ℂ)) := by
+  classical
+  let d : ι → (Fin 2 →₀ ℕ) := fun t => Finsupp.single 0 (a t) + Finsupp.single 1 (n - a t)
+  have hd : Function.Injective d := by
+    intro t t' h
+    apply ha
+    have := congrArg (fun f : Fin 2 →₀ ℕ => f 0) h
+    simpa [d, Finsupp.single_apply] using this
+  have hb := (MvPolynomial.basisMonomials (Fin 2) ℂ).linearIndependent.comp d hd
+  have hmon : ∀ t, (X 0 ^ a t * X 1 ^ (n - a t) : MvPolynomial (Fin 2) ℂ) = MvPolynomial.monomial (d
+    t) 1 :=
+    by
+    intro t
+    simp only [d]
+    rw [MvPolynomial.X_pow_eq_monomial, MvPolynomial.X_pow_eq_monomial,
+      MvPolynomial.monomial_mul_monomial, mul_one]
+  convert hb using 1
+  funext t
+  rw [Function.comp_apply, MvPolynomial.coe_basisMonomials, hmon]
+
+theorem linearIndependent_bvec {ι : Type*} (c₁ c₂ : ℂ) (hc : c₁ ≠ c₂) (n : ℕ) (a : ι → ℕ)
+    (ha : Function.Injective a) :
+    LinearIndependent ℂ (fun t => bvec c₁ c₂ n (a t)) := by
+  have h := (linearIndependent_monomials n a ha).map' (tau c₁ c₂).toLinearMap
+    (LinearMap.ker_eq_bot.mpr (tau_injective c₁ c₂ hc))
+  convert h using 1
+  funext t
+  simp [Function.comp_apply, bvec_eq_tau]
+
+theorem finite_binaryForm (n : ℕ) : Module.Finite ℂ ↥(HeckeEis.BinaryForm ℂ n) := by
+  classical
+  have hsub : (HeckeEis.BinaryForm ℂ n : Submodule ℂ (MvPolynomial (Fin 2) ℂ)) ≤
+      Submodule.span ℂ ((Finset.range (n + 1)).image fun a => (X 0 ^ a * X 1 ^ (n - a) :
+        MvPolynomial (Fin 2) ℂ)) := by
+    intro F hF
+    rw [MvPolynomial.mem_homogeneousSubmodule] at hF
+    rw [MvPolynomial.as_sum F]
+    refine Submodule.sum_mem _ fun d hd => ?_
+    have hdeg' : ∑ i ∈ d.support, d i = n := by
+      have h := hF (MvPolynomial.mem_support_iff.mp hd)
+      simpa [Finsupp.degree, Finsupp.weight, Finsupp.sum, Finsupp.linearCombination,
+        Finsupp.lsum] using h
+    have hdeg : d 0 + d 1 = n := by
+      rw [← hdeg', ← Fin.sum_univ_two (f := fun i => d i)]
+      symm
+      exact Finset.sum_subset (Finset.subset_univ _) (fun x _ hx => by simpa using hx)
+    have hXX : (X 0 ^ (d 0) * X 1 ^ (n - d 0) : MvPolynomial (Fin 2) ℂ) =
+        MvPolynomial.monomial (Finsupp.single 0 (d 0) + Finsupp.single 1 (n - d 0)) 1 := by
+      rw [MvPolynomial.X_pow_eq_monomial, MvPolynomial.X_pow_eq_monomial,
+        MvPolynomial.monomial_mul_monomial, mul_one]
+    have hd' : d = Finsupp.single 0 (d 0) + Finsupp.single 1 (n - d 0) := by
+      refine Finsupp.ext fun j => ?_
+      fin_cases j
+      · simp
+      · simp; omega
+    have hmono : MvPolynomial.monomial d (AddMonoidAlgebra.coeff F d) =
+        AddMonoidAlgebra.coeff F d • (X 0 ^ (d 0) * X 1 ^ (n - d 0) : MvPolynomial (Fin 2) ℂ) := by
+      rw [hXX, MvPolynomial.smul_monomial, smul_eq_mul, mul_one, ← hd']
+    rw [hmono]
+    refine Submodule.smul_mem _ _ (Submodule.subset_span ?_)
+    simp only [Finset.coe_image, Finset.coe_range, Set.mem_image, Set.mem_Iio]
+    exact ⟨d 0, by omega, rfl⟩
+  have : FiniteDimensional ℂ ↥(Submodule.span ℂ (((Finset.range (n + 1)).image fun a =>
+      (X 0 ^ a * X 1 ^ (n - a) : MvPolynomial (Fin 2) ℂ)) : Set (MvPolynomial (Fin 2) ℂ))) :=
+    FiniteDimensional.span_finset ℂ _
+  exact Submodule.finiteDimensional_of_le hsub
+
+end UH1
+
+namespace UH1
+
+open HeckeEis
+
+theorem subst_lin (M : Matrix (Fin 2) (Fin 2) ℤ) (c μ : ℂ)
+    (h1 : ((M 0 0 : ℤ) : ℂ) + c * ((M 0 1 : ℤ) : ℂ) = μ)
+    (h2 : ((M 1 0 : ℤ) : ℂ) + c * ((M 1 1 : ℤ) : ℂ) = μ * c) :
+    binarySubst ℂ M (X 0 + C c * X 1) = C μ * (X 0 + C c * X 1) := by
+  subst h1
+  have h2' : (C (((M 1 0 : ℤ) : ℂ)) + C c * C (((M 1 1 : ℤ) : ℂ)) : MvPolynomial (Fin 2) ℂ)
+      = (C (((M 0 0 : ℤ) : ℂ)) + C c * C (((M 0 1 : ℤ) : ℂ))) * C c := by
+    have := congrArg (C : ℂ → MvPolynomial (Fin 2) ℂ) h2
+    simpa only [map_add, map_mul] using this
+  rw [map_add, map_mul, MvPolynomial.algHom_C, MvPolynomial.algebraMap_eq, binarySubst_X,
+    binarySubst_X,
+    Fin.sum_univ_two, Fin.sum_univ_two, map_add, map_mul]
+  linear_combination (X 1 : MvPolynomial (Fin 2) ℂ) * h2'
+
+theorem subst_bvec (M : Matrix (Fin 2) (Fin 2) ℤ) (c₁ c₂ μ₁ μ₂ : ℂ)
+    (h11 : ((M 0 0 : ℤ) : ℂ) + c₁ * ((M 0 1 : ℤ) : ℂ) = μ₁)
+    (h12 : ((M 1 0 : ℤ) : ℂ) + c₁ * ((M 1 1 : ℤ) : ℂ) = μ₁ * c₁)
+    (h21 : ((M 0 0 : ℤ) : ℂ) + c₂ * ((M 0 1 : ℤ) : ℂ) = μ₂)
+    (h22 : ((M 1 0 : ℤ) : ℂ) + c₂ * ((M 1 1 : ℤ) : ℂ) = μ₂ * c₂)
+    (n a : ℕ) :
+    binarySubst ℂ M (bvec c₁ c₂ n a) = C (μ₁ ^ a * μ₂ ^ (n - a)) * bvec c₁ c₂ n a := by
+  rw [bvec, map_mul, map_pow, map_pow, subst_lin M c₁ μ₁ h11 h12, subst_lin M c₂ μ₂ h21 h22,
+    mul_pow, mul_pow,
+    map_mul, map_pow, map_pow]
+  exact mul_mul_mul_comm _ _ _ _
+
+theorem le_finrank_ker (n : ℕ) (g : SL(2, ℤ)) (c₁ c₂ μ₁ μ₂ : ℂ) (hc : c₁ ≠ c₂)
+    (h11 : (((g : Matrix (Fin 2) (Fin 2) ℤ) 0 0 : ℤ) : ℂ) + c₁ * (((g : Matrix (Fin 2) (Fin 2) ℤ) 0
+      1 : ℤ) : ℂ) = μ₁)
+    (h12 : (((g : Matrix (Fin 2) (Fin 2) ℤ) 1 0 : ℤ) : ℂ) + c₁ * (((g : Matrix (Fin 2) (Fin 2) ℤ) 1
+      1 : ℤ) : ℂ) = μ₁ * c₁)
+    (h21 : (((g : Matrix (Fin 2) (Fin 2) ℤ) 0 0 : ℤ) : ℂ) + c₂ * (((g : Matrix (Fin 2) (Fin 2) ℤ) 0
+      1 : ℤ) : ℂ) = μ₂)
+    (h22 : (((g : Matrix (Fin 2) (Fin 2) ℤ) 1 0 : ℤ) : ℂ) + c₂ * (((g : Matrix (Fin 2) (Fin 2) ℤ) 1
+      1 : ℤ) : ℂ) = μ₂ * c₂)
+    {B : ℕ} (a : Fin B → ℕ) (ha : Function.Injective a) (hle : ∀ t, a t ≤ n)
+    (heig : ∀ t, μ₁ ^ a t * μ₂ ^ (n - a t) = 1) :
+    B ≤ Module.finrank ℂ ↥(LinearMap.ker (binaryFormRepSL ℂ n g - 1)) := by
+  classical
+  have := finite_binaryForm n
+  let e : Fin B → ↥(LinearMap.ker (binaryFormRepSL ℂ n g - 1)) := fun t =>
+    ⟨⟨bvec c₁ c₂ n (a t), bvec_mem c₁ c₂ n (a t) (hle t)⟩, by
+      rw [LinearMap.mem_ker, LinearMap.sub_apply, Module.End.one_apply, sub_eq_zero]
+      apply Subtype.ext
+      rw [binaryFormRepSL_apply_coe]
+      change binarySubst ℂ (g : Matrix (Fin 2) (Fin 2) ℤ) (bvec c₁ c₂ n (a t)) = bvec c₁ c₂ n (a t)
+      rw [subst_bvec _ c₁ c₂ μ₁ μ₂ h11 h12 h21 h22, heig t, C_1, one_mul]⟩
+  have hli : LinearIndependent ℂ e := by
+    apply LinearIndependent.of_comp ((BinaryForm ℂ n).subtype ∘ₗ (LinearMap.ker (binaryFormRepSL ℂ n
+      g - 1)).subtype)
+    exact linearIndependent_bvec c₁ c₂ hc n a ha
+  have h := hli.fintype_card_le_finrank
+  rwa [Fintype.card_fin] at h
+
+theorem S_entries :
+    ((ModularGroup.S : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) 0 0 = 0 ∧ ((ModularGroup.S : SL(2, ℤ))
+      : Matrix (Fin 2) (Fin 2) ℤ) 0 1 = -1 ∧
+    ((ModularGroup.S : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) 1 0 = 1 ∧ ((ModularGroup.S : SL(2, ℤ))
+      : Matrix (Fin 2) (Fin 2) ℤ) 1 1 = 0 := by
+  simp [ModularGroup.coe_S]
+
+theorem ST_entries :
+    ((ModularGroup.S * ModularGroup.T : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) 0 0 = 0 ∧
+    ((ModularGroup.S * ModularGroup.T : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) 0 1 = -1 ∧
+    ((ModularGroup.S * ModularGroup.T : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) 1 0 = 1 ∧
+    ((ModularGroup.S * ModularGroup.T : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) 1 1 = 1 := by
+  simp [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_S, ModularGroup.coe_T, Matrix.mul_apply,
+    Fin.sum_univ_two]
+
+theorem main (n : ℕ) (hn : Even n) :
+    n + 1 - 2 * ((n + 2) / 4) ≤ Module.finrank ℂ ↥(LinearMap.ker (binaryFormRepSL ℂ n ModularGroup.S
+      - 1)) ∧
+    n + 1 - 2 * ((n + 2) / 3)
+      ≤ Module.finrank ℂ ↥(LinearMap.ker (binaryFormRepSL ℂ n (ModularGroup.S * ModularGroup.T) -
+        1)) := by
+  obtain ⟨p, hp⟩ := hn
+  constructor
+  · obtain ⟨e00, e01, e10, e11⟩ := S_entries
+    refine le_finrank_ker n ModularGroup.S Complex.I (-Complex.I) (-Complex.I) Complex.I ?_ ?_ ?_ ?_
+      ?_
+      (fun t : Fin (n + 1 - 2 * ((n + 2) / 4)) => 2 * (t : ℕ) + p % 2) ?_ ?_ ?_
+    · intro h
+      have := congrArg Complex.im h
+      norm_num at this
+    · rw [e00, e01]; push_cast; ring
+    · rw [e10, e11]; push_cast; rw [mul_zero, add_zero, neg_mul, Complex.I_mul_I, neg_neg]
+    · rw [e00, e01]; push_cast; ring
+    · rw [e10, e11]; push_cast; rw [mul_zero, add_zero, mul_neg, Complex.I_mul_I, neg_neg]
+    · intro t t' h
+      apply Fin.ext
+      dsimp only at h
+      omega
+    · intro t
+      have := t.2
+      omega
+    · intro t
+      obtain ⟨q, hq⟩ : ∃ q, 2 * (t : ℕ) + p % 2 + p = 2 * q :=
+        ⟨(2 * (t : ℕ) + p % 2 + p) / 2, by omega⟩
+      have hle : 2 * (t : ℕ) + p % 2 ≤ n := by have := t.2; omega
+      have hIn : Complex.I ^ n = (-1) ^ p := by rw [hp, ← two_mul, pow_mul, Complex.I_sq]
+      rw [neg_pow Complex.I, mul_assoc, ← pow_add, show (2 * (t : ℕ) + p % 2) + (n - (2 * (t : ℕ) +
+        p % 2)) = n by
+        omega, hIn,
+        ← pow_add, hq, pow_mul, neg_one_sq, one_pow]
+  · obtain ⟨e00, e01, e10, e11⟩ := ST_entries
+    obtain ⟨ω, hω⟩ : ∃ ω : ℂ, IsPrimitiveRoot ω 3 :=
+      ⟨_, Complex.isPrimitiveRoot_exp 3 (by norm_num)⟩
+    have hω3 : ω ^ 3 = 1 := hω.pow_eq_one
+    have hω1 : ω ≠ 1 := hω.ne_one (by norm_num)
+    have hωq : ω ^ 2 + ω + 1 = 0 := by
+      have : (ω - 1) * (ω ^ 2 + ω + 1) = 0 := by
+        have : ω ^ 3 - 1 = 0 := by rw [hω3, sub_self]
+        linear_combination this
+      rcases mul_eq_zero.mp this with h | h
+      · exact absurd (sub_eq_zero.mp h) hω1
+      · exact h
+    refine le_finrank_ker n (ModularGroup.S * ModularGroup.T) ω (ω ^ 2) (-ω) (-ω ^ 2) ?_ ?_ ?_ ?_ ?_
+      (fun t : Fin (n + 1 - 2 * ((n + 2) / 3)) => 3 * (t : ℕ) + (2 * n) % 3) ?_ ?_ ?_
+    · intro h
+      apply hω1
+      have hω0 : ω ≠ 0 := by intro h0; rw [h0] at hω3; norm_num at hω3
+      have : ω * (ω - 1) = 0 := by linear_combination (-1 : ℂ) * h
+      rcases mul_eq_zero.mp this with h' | h'
+      · exact absurd h' hω0
+      · exact sub_eq_zero.mp h'
+    · rw [e00, e01]; push_cast; ring
+    · rw [e10, e11]; push_cast; linear_combination hωq
+    · rw [e00, e01]; push_cast; ring
+    · rw [e10, e11]; push_cast
+      linear_combination hωq + ω * hω3
+    · intro t t' h
+      apply Fin.ext
+      dsimp only at h
+      omega
+    · intro t
+      have := t.2
+      have h3 : p % 3 = 0 ∨ p % 3 = 1 ∨ p % 3 = 2 := by omega
+      rcases h3 with h3 | h3 | h3 <;> omega
+    · intro t
+      have h3 : p % 3 = 0 ∨ p % 3 = 1 ∨ p % 3 = 2 := by omega
+      have hle : 3 * (t : ℕ) + (2 * n) % 3 ≤ n :=
+        by have := t.2; rcases h3 with h3 | h3 | h3 <;> omega
+      obtain ⟨q, hq⟩ : ∃ q, 3 * (t : ℕ) + (2 * n) % 3 + 2 * (n - (3 * (t : ℕ) + (2 * n) % 3)) = 3 *
+        q :=
+        ⟨(3 * (t : ℕ) + (2 * n) % 3 + 2 * (n - (3 * (t : ℕ) + (2 * n) % 3))) / 3, by
+          rcases h3 with h3 | h3 | h3 <;> omega⟩
+      have hev : Even n := ⟨p, hp⟩
+      rw [neg_pow ω, neg_pow (ω ^ 2), mul_mul_mul_comm, ← pow_add, show (3 * (t : ℕ) + (2 * n) % 3)
+        + (n - (3 * (t : ℕ) + (2 * n) % 3)) = n by
+        omega,
+        Even.neg_one_pow hev, one_mul, ← pow_mul, ← pow_add, show 3 * (t : ℕ) + 2 * n % 3 + 2 * (n -
+          (3 * (t : ℕ) + 2 * n % 3))
+          = 3 * q by omega, pow_mul, hω3, one_pow]
+
+end UH1
+
+theorem solution (n : ℕ) (hn : Even n) :
+    n + 1 - 2 * ((n + 2) / 4) ≤ Module.finrank ℂ ↥(LinearMap.ker (HeckeEis.binaryFormRepSL ℂ n
+      ModularGroup.S - 1)) ∧
+    n + 1 - 2 * ((n + 2) / 3)
+      ≤ Module.finrank ℂ ↥(LinearMap.ker (HeckeEis.binaryFormRepSL ℂ n (ModularGroup.S *
+        ModularGroup.T) - 1)) :=
+  UH1.main n hn
+
+end S_HeckeEis_le_finrank_fixed_S_and_ST_binaryFormRepSL
+end P2MW
+export P2MW.S_HeckeEis_le_finrank_fixed_S_and_ST_binaryFormRepSL (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.le_finrank_fixed_S_and_ST_binaryFormRepSL (n : ℕ) (hn : Even n) :
+    n + 1 - 2 * ((n + 2) / 4) ≤ Module.finrank ℂ ↥(LinearMap.ker (HeckeEis.binaryFormRepSL ℂ n
+      ModularGroup.S - 1)) ∧
+    n + 1 - 2 * ((n + 2) / 3)
+      ≤ Module.finrank ℂ ↥(LinearMap.ker (HeckeEis.binaryFormRepSL ℂ n (ModularGroup.S *
+        ModularGroup.T) - 1)) :=
+  solution n hn
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_le_finrank_fixed_induced_binaryFormRepSL.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_le_finrank_fixed_induced_binaryFormRepSL.lean
new file mode 100644
index 0000000000..bf30b266db
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_le_finrank_fixed_induced_binaryFormRepSL.lean
@@ -0,0 +1,622 @@
+/-
+Based on Prove2Me node HeckeEis.le_finrank_fixed_induced_binaryFormRepSL
+(97044c7f-6184-5086-9b7d-a2178cc068c0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2a40e6ad-2e85-505f-88c4-52dce46704e6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Basic.Complex.Basic
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+
+import Mathlib.Algebra.Module.StablyFree.Basic
+import Mathlib.Analysis.CStarAlgebra.Classes
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.LinearAlgebra.FreeModule.PID
+import Mathlib.RingTheory.Etale.Weakly
+import Mathlib.RingTheory.Finiteness.ModuleFinitePresentation
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import Mathlib.RingTheory.TotallySplit
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_binaryFormRepSL_neg_one_apply
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Fixed vectors in Ind_{Γ_0(N)}^{SL₂(ℤ)} of binary forms
+
+Theorem statement: `HeckeEis.le_finrank_fixed_induced_binaryFormRepSL`
+(`97044c7f-6184-5086-9b7d-a2178cc068c0`), by Claude, 2026-09-05.
+
+Proof: submission `2a40e6ad-2e85-505f-88c4-52dce46704e6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N\ge 1$ (a natural number with `NeZero N`) and let $n$ be an even natural number. Write $X =
+SL(2,\mathbb Z)/\Gamma_0(N)$ for the coset space and $V_n =$ [`HeckeEis.BinaryForm ℂ
+n`](def/HeckeEis_BinaryFormRep.html#L25), the submodule of homogeneous polynomials of degree $n$ in
+$\mathbb C[X_0,X_1]$, on which $SL(2,\mathbb Z)$ acts by
+[`HeckeEis.binaryFormRepSL`](def/HeckeEis_BinaryFormRep.html#L61), i.e. $g$ substitutes $X_j \mapsto
+\sum_i g_{ij}X_i$. Let $W$ be a representation of the subgroup $\top \le SL(2,\mathbb Z)$ on the
+space of functions $X \to V_n$ which is assumed to be the induced one: $(W(g)f)(x) = g\cdot
+f(g^{-1}x)$ for all $g$, $f$, $x$. The conclusion is a conjunction of four assertions. First,
+$\dim_{\mathbb C}(X \to V_n) = (n+1)\,[SL(2,\mathbb Z):\Gamma_0(N)]$. Second, with $\nu_2$ the
+number of $x \in X$ fixed by $S$, $$2\nu_2\dim\ker(\rho_n(S)-1) + ([SL(2,\mathbb
+Z):\Gamma_0(N)]-\nu_2)(n+1) \le 2\dim\ker(W(S)-1),$$ the subtraction being truncated subtraction of
+naturals. Third, the same inequality with $S$ replaced by $ST$ and the factor $2$ by $3$, $\nu_3$
+being the number of $ST$-fixed cosets. Fourth, the number of orbits of the subgroup of integer
+powers of $T$ on $X$ is at most $\dim\ker(W(T)-1)$.
+
+This is the representation-theoretic input to the Eichler–Selberg style dimension count for spaces
+of modular forms of level $\Gamma_0(N)$: the three lower bounds measure the $S$-, $ST$- and
+$T$-invariants of the induced representation $\mathrm{Ind}_{\Gamma_0(N)}^{SL_2(\mathbb
+Z)}\mathrm{Sym}^n$ in terms of the elliptic points of order $2$ and $3$ and the cusps. It is used in
+the bound
+[`HeckeEis.finrank_coeffH1par_le_two_mul_dimFormula`]
+(thm.html#HeckeEis.finrank_coeffH1par_le_two_mul_dimFormula)
+comparing a parabolic cohomology dimension with the classical dimension formula.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_le_finrank_fixed_induced_binaryFormRepSL.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_le_finrank_fixed_induced_binaryFormRepSL
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst_X binaryFormRepSL binaryFormRepSL_apply_coe \
+  binaryFormRepSL_neg_one_apply"
+namespace UH2
+p2m_open "HeckeEis"
+
+open Module
+
+section Abstract
+
+variable (k : Type*) [Field k] {V : Type*} [AddCommGroup V] [Module k V]
+variable {X : Type*} [Fintype X] [DecidableEq X]
+
+def extZero (s : Finset X) (M : Type*) [AddCommGroup M] [Module k M] : (↥s → M) →ₗ[k] (X → M) where
+  toFun u x := if h : x ∈ s then u ⟨x, h⟩ else 0
+  map_add' u v := by
+    funext x
+    by_cases h : x ∈ s <;> simp [h]
+  map_smul' c u := by
+    funext x
+    by_cases h : x ∈ s <;> simp [h]
+
+variable {k}
+
+omit [Fintype X] in
+theorem extZero_apply_mem {s : Finset X} {M : Type*} [AddCommGroup M] [Module k M] (u : ↥s → M)
+    {x : X} (h : x ∈ s) : extZero k s M u x = u ⟨x, h⟩ := by
+  simp [extZero, h]
+
+omit [Fintype X] in
+theorem extZero_apply_not_mem {s : Finset X} {M : Type*} [AddCommGroup M] [Module k M] (u : ↥s → M)
+    {x : X} (h : x ∉ s) : extZero k s M u x = 0 := by
+  simp [extZero, h]
+
+variable (σ : Equiv.Perm X) (A : V →ₗ[k] V) (Φ : Module.End k (X → V))
+
+omit [Fintype X] [DecidableEq X] in
+theorem pow_shift_apply (hΦ : ∀ f x, Φ f x = A (f (σ⁻¹ x))) (i : ℕ) (f : X → V) (x : X) :
+    (Φ ^ i) f x = (A ^ i) (f ((σ ^ i)⁻¹ x)) := by
+  induction i generalizing x with
+  | zero => simp
+  | succ i ih =>
+    rw [pow_succ', pow_succ', pow_succ', Module.End.mul_apply, hΦ, ih, Module.End.mul_apply,
+      mul_inv_rev,
+      Equiv.Perm.mul_apply]
+
+omit [Fintype X] [DecidableEq X] in
+theorem dvd_of_pow_apply_eq {p : ℕ} (hp : p.Prime) (hσ : σ ^ p = 1) {x : X} (hx : σ x ≠ x) {i : ℕ}
+    (hi : (σ ^ i) x = x) : p ∣ i := by
+  by_contra hndvd
+  have hcop : Nat.Coprime i p := ((Nat.Prime.coprime_iff_not_dvd hp).mpr hndvd).symm
+  apply hx
+  have key : (σ ^ ((i : ℤ) * Nat.gcdA i p + (p : ℤ) * Nat.gcdB i p)) x = x := by
+    rw [zpow_add, zpow_mul, zpow_mul, Equiv.Perm.mul_apply, zpow_natCast, zpow_natCast, hσ,
+      one_zpow,
+      Equiv.Perm.one_apply]
+    exact Equiv.Perm.zpow_apply_eq_self_of_apply_eq_self hi _
+  have hg : ((i : ℤ) * Nat.gcdA i p + (p : ℤ) * Nat.gcdB i p) = 1 := by
+    rw [← Nat.gcd_eq_gcd_ab, hcop.gcd_eq_one]; rfl
+  rw [hg, zpow_one] at key
+  exact key
+
+omit [Fintype X] [DecidableEq X] in
+theorem apply_ne_of_pow_apply {x : X} (hx : σ x ≠ x) (i : ℕ) : σ ((σ ^ i) x) ≠ (σ ^ i) x := by
+  intro h
+  apply hx
+  rw [← Equiv.Perm.mul_apply, ← pow_succ', pow_succ, Equiv.Perm.mul_apply] at h
+  exact (σ ^ i).injective h
+
+omit [Fintype X] [DecidableEq X] in
+theorem apply_ne_of_zpow_apply {x : X} (hx : σ x ≠ x) (m : ℤ) : σ ((σ ^ m) x) ≠ (σ ^ m) x := by
+  intro h
+  apply hx
+  rw [← Equiv.Perm.mul_apply, ← zpow_one_add, add_comm, zpow_add_one, Equiv.Perm.mul_apply] at h
+  exact (σ ^ m).injective h
+
+noncomputable def rep (x : X) : X :=
+  (Quotient.mk (MulAction.orbitRel (Subgroup.zpowers σ) X) x).out
+
+omit [Fintype X] [DecidableEq X] in
+theorem exists_zpow_apply_eq_rep (x : X) : ∃ m : ℤ, (σ ^ m) x = rep σ x := by
+  have h : (MulAction.orbitRel (Subgroup.zpowers σ) X) (rep σ x) x := Quotient.mk_out x
+  rw [MulAction.orbitRel_apply, MulAction.mem_orbit_iff] at h
+  obtain ⟨⟨g, hg⟩, hgx⟩ := h
+  obtain ⟨m, rfl⟩ := Subgroup.mem_zpowers_iff.mp hg
+  exact ⟨m, hgx⟩
+
+omit [Fintype X] [DecidableEq X] in
+theorem rep_zpow_apply (x : X) (m : ℤ) : rep σ ((σ ^ m) x) = rep σ x := by
+  unfold rep
+  congr 1
+  apply Quotient.sound
+  change (MulAction.orbitRel (Subgroup.zpowers σ) X) ((σ ^ m) x) x
+  rw [MulAction.orbitRel_apply, MulAction.mem_orbit_iff]
+  exact ⟨⟨σ ^ m, (Subgroup.zpowers σ).zpow_mem (Subgroup.mem_zpowers σ) m⟩, rfl⟩
+
+omit [Fintype X] [DecidableEq X] in
+theorem rep_pow_apply (x : X) (i : ℕ) : rep σ ((σ ^ i) x) = rep σ x := by
+  rw [← zpow_natCast]; exact rep_zpow_apply σ x i
+
+omit [Fintype X] [DecidableEq X] in
+theorem rep_rep (x : X) : rep σ (rep σ x) = rep σ x := by
+  obtain ⟨m, hm⟩ := exists_zpow_apply_eq_rep σ x
+  rw [← hm, rep_zpow_apply]
+  exact hm.symm
+
+omit [Fintype X] [DecidableEq X] in
+theorem apply_rep_ne {x : X} (hx : σ x ≠ x) : σ (rep σ x) ≠ rep σ x := by
+  obtain ⟨m, hm⟩ := exists_zpow_apply_eq_rep σ x
+  rw [← hm]
+  exact apply_ne_of_zpow_apply σ hx m
+
+def moving : Finset X := Finset.univ.filter fun x => σ x ≠ x
+
+noncomputable def freeReps : Finset X := Finset.univ.filter fun x => σ x ≠ x ∧ rep σ x = x
+
+def fixedPts : Finset X := Finset.univ.filter fun x => σ x = x
+
+theorem mem_moving {x : X} : x ∈ moving σ ↔ σ x ≠ x := by simp [moving]
+theorem mem_freeReps {x : X} : x ∈ freeReps σ ↔ σ x ≠ x ∧ rep σ x = x := by simp [freeReps]
+theorem mem_fixedPts {x : X} : x ∈ fixedPts σ ↔ σ x = x := by simp [fixedPts]
+
+theorem card_fixedPts_add_card_moving : (fixedPts σ).card + (moving σ).card = Fintype.card X := by
+  rw [fixedPts, moving, Finset.card_filter_add_card_filter_not, Finset.card_univ]
+
+theorem card_fiber {p : ℕ} (hp : p.Prime) (hσ : σ ^ p = 1) {r : X} (hr : r ∈ freeReps σ) :
+    ((moving σ).filter fun a => rep σ a = r).card = p := by
+  rw [mem_freeReps] at hr
+  have heq : ((moving σ).filter fun a => rep σ a = r) = (Finset.range p).image fun i => (σ ^ i) r :=
+    by
+    ext a
+    simp only [Finset.mem_filter, mem_moving, Finset.mem_image, Finset.mem_range]
+    constructor
+    · rintro ⟨-, hrep⟩
+      obtain ⟨m, hm⟩ := exists_zpow_apply_eq_rep σ a
+      rw [hrep] at hm
+      have hp0 : (0 : ℤ) < p := by exact_mod_cast hp.pos
+      refine ⟨((-m) % (p : ℤ)).toNat, ?_, ?_⟩
+      · have h1 : ((-m) % (p : ℤ)) < p := Int.emod_lt_of_pos _ hp0
+        have h2 : 0 ≤ ((-m) % (p : ℤ)) := Int.emod_nonneg _ hp0.ne'
+        omega
+      · have h2 : 0 ≤ ((-m) % (p : ℤ)) := Int.emod_nonneg _ hp0.ne'
+        rw [← zpow_natCast, Int.toNat_of_nonneg h2, ← zpow_eq_zpow_emod' _ hσ, zpow_neg, ← hm]
+        simp
+    · rintro ⟨i, -, rfl⟩
+      exact ⟨apply_ne_of_pow_apply σ hr.1 i, by rw [rep_pow_apply, hr.2]⟩
+  rw [heq, Finset.card_image_of_injOn, Finset.card_range]
+  have aux : ∀ i j : ℕ, i ≤ j → j < p → (σ ^ i) r = (σ ^ j) r → i = j := by
+    intro i j hij hj e
+    rw [← pow_mul_pow_sub σ hij, Equiv.Perm.mul_apply] at e
+    have e' : (σ ^ (j - i)) r = r := ((σ ^ i).injective e).symm
+    have hdvd := dvd_of_pow_apply_eq σ hp hσ hr.1 e'
+    have : j - i = 0 := Nat.eq_zero_of_dvd_of_lt hdvd (by omega)
+    omega
+  intro i hi j hj e
+  simp only [Finset.coe_range, Set.mem_Iio] at hi hj
+  rcases le_total i j with h | h
+  · exact aux i j h hj e
+  · exact (aux j i h hi e.symm).symm
+
+theorem card_moving {p : ℕ} (hp : p.Prime) (hσ : σ ^ p = 1) :
+    (moving σ).card = p * (freeReps σ).card := by
+  rw [Finset.card_eq_sum_card_fiberwise (f := rep σ) (t := freeReps σ)]
+  · rw [Finset.sum_congr rfl fun r hr => card_fiber σ hp hσ hr, Finset.sum_const, smul_eq_mul,
+      mul_comm]
+  · intro a ha
+    rw [Finset.mem_coe, mem_moving] at ha
+    rw [Finset.mem_coe, mem_freeReps]
+    exact ⟨apply_rep_ne σ ha, rep_rep σ a⟩
+
+omit [Fintype X] [DecidableEq X] in
+theorem shift_pow_eq_one (hΦ : ∀ f x, Φ f x = A (f (σ⁻¹ x))) {p : ℕ} (hσ : σ ^ p = 1)
+    (hA : A ^ p = 1) :
+    Φ ^ p = 1 := by
+  refine LinearMap.ext fun f => funext fun x => ?_
+  rw [pow_shift_apply σ A Φ hΦ, hA, hσ]
+  simp
+
+noncomputable def avg (p : ℕ) : Module.End k (X → V) := ∑ i ∈ Finset.range p, Φ ^ i
+
+omit [Fintype X] [DecidableEq X] in
+theorem avg_mem_ker (hΦ : ∀ f x, Φ f x = A (f (σ⁻¹ x))) {p : ℕ} (hσ : σ ^ p = 1) (hA : A ^ p = 1)
+    (g : X → V) : avg Φ p g ∈ LinearMap.ker (Φ - 1) := by
+  rw [LinearMap.mem_ker, ← Module.End.mul_apply, avg, mul_geom_sum, shift_pow_eq_one σ A Φ hΦ hσ hA,
+    sub_self,
+    LinearMap.zero_apply]
+
+omit [Fintype X] [DecidableEq X] in
+theorem avg_apply (hΦ : ∀ f x, Φ f x = A (f (σ⁻¹ x))) (p : ℕ) (g : X → V) (x : X) :
+    avg Φ p g x = ∑ i ∈ Finset.range p, (A ^ i) (g ((σ ^ i)⁻¹ x)) := by
+  rw [avg, LinearMap.sum_apply, Finset.sum_apply]
+  exact Finset.sum_congr rfl fun i _ => pow_shift_apply σ A Φ hΦ i g x
+
+theorem extZero_fixed_mem_ker (hΦ : ∀ f x, Φ f x = A (f (σ⁻¹ x)))
+    (u : ↥(fixedPts σ) → LinearMap.ker (A - 1)) :
+    extZero k (fixedPts σ) V (fun y => (u y : V)) ∈ LinearMap.ker (Φ - 1) := by
+  rw [LinearMap.mem_ker]
+  funext x
+  rw [LinearMap.sub_apply, Module.End.one_apply, Pi.sub_apply, hΦ, Pi.zero_apply, sub_eq_zero]
+  by_cases hx : σ x = x
+  · have hx' : σ⁻¹ x = x := by rw [Equiv.Perm.inv_eq_iff_eq]; exact hx.symm
+    have hmem : x ∈ fixedPts σ := (mem_fixedPts σ).mpr hx
+    rw [hx', extZero_apply_mem _ hmem]
+    have h2 := (u ⟨x, hmem⟩).2
+    rw [LinearMap.mem_ker, LinearMap.sub_apply, Module.End.one_apply, sub_eq_zero] at h2
+    exact h2
+  · have hx' : σ⁻¹ x ∉ fixedPts σ := by
+      rw [mem_fixedPts, Equiv.Perm.inv_def, Equiv.apply_symm_apply]
+      intro h
+      apply hx
+      calc σ x = σ (σ.symm x) := congrArg (⇑σ) h
+        _ = x := Equiv.apply_symm_apply _ _
+    have hx2 : x ∉ fixedPts σ := by rw [mem_fixedPts]; exact hx
+    rw [extZero_apply_not_mem _ hx', extZero_apply_not_mem _ hx2, map_zero]
+
+noncomputable def compMap (hΦ : ∀ f x, Φ f x = A (f (σ⁻¹ x))) {p : ℕ} (hσ : σ ^ p = 1)
+    (hA : A ^ p = 1) :
+    ((↥(fixedPts σ) → LinearMap.ker (A - 1)) × (↥(freeReps σ) → V)) →ₗ[k] LinearMap.ker (Φ - 1) :=
+  LinearMap.codRestrict (LinearMap.ker (Φ - 1))
+    (LinearMap.coprod
+      (extZero k (fixedPts σ) V ∘ₗ (LinearMap.ker (A - 1)).subtype.compLeft ↥(fixedPts σ))
+      (avg Φ p ∘ₗ extZero k (freeReps σ) V))
+    (by
+      rintro ⟨u, v⟩
+      rw [LinearMap.coprod_apply]
+      exact Submodule.add_mem _ (extZero_fixed_mem_ker σ A Φ hΦ u) (avg_mem_ker σ A Φ hΦ hσ hA _))
+
+theorem avg_extZero_apply_rep (hΦ : ∀ f x, Φ f x = A (f (σ⁻¹ x))) {p : ℕ} (hp : p.Prime)
+    (hσ : σ ^ p = 1)
+    (v : ↥(freeReps σ) → V) {r : X} (hr : r ∈ freeReps σ) :
+    avg Φ p (extZero k (freeReps σ) V v) r = v ⟨r, hr⟩ := by
+  rw [avg_apply σ A Φ hΦ, Finset.sum_eq_single 0]
+  · simp [extZero_apply_mem _ hr]
+  · intro i hi hi0
+    rw [Finset.mem_range] at hi
+    have hnot : (σ ^ i)⁻¹ r ∉ freeReps σ := by
+      intro hmem
+      have h1 := ((mem_freeReps σ).mp hmem).2
+      rw [← zpow_natCast, ← zpow_neg, rep_zpow_apply, ((mem_freeReps σ).mp hr).2, eq_comm, zpow_neg,
+        zpow_natCast, Equiv.Perm.inv_eq_iff_eq] at h1
+      have hdvd := dvd_of_pow_apply_eq σ hp hσ ((mem_freeReps σ).mp hr).1 h1.symm
+      exact hi0 (Nat.eq_zero_of_dvd_of_lt hdvd hi)
+    rw [extZero_apply_not_mem _ hnot, map_zero]
+  · intro h
+    exact absurd (Finset.mem_range.mpr hp.pos) h
+
+theorem compMap_injective (hΦ : ∀ f x, Φ f x = A (f (σ⁻¹ x))) {p : ℕ} (hp : p.Prime)
+    (hσ : σ ^ p = 1)
+    (hA : A ^ p = 1) : Function.Injective (compMap σ A Φ hΦ hσ hA) := by
+  rw [← LinearMap.ker_eq_bot, LinearMap.ker_eq_bot']
+  rintro ⟨u, v⟩ huv
+  have H : extZero k (fixedPts σ) V (fun y => (u y : V)) + avg Φ p (extZero k (freeReps σ) V v) = 0
+    :=
+    by
+    have := congrArg Subtype.val huv
+    simp only [compMap, LinearMap.codRestrict_apply, LinearMap.coprod_apply, LinearMap.coe_comp,
+      Function.comp_apply, ZeroMemClass.coe_zero] at this
+    exact this
+  have hv : v = 0 := by
+    funext ⟨r, hr⟩
+    have Hr := congrFun H r
+    have hrF : r ∉ fixedPts σ := by rw [mem_fixedPts]; exact ((mem_freeReps σ).mp hr).1
+    rw [Pi.add_apply, extZero_apply_not_mem _ hrF, zero_add, avg_extZero_apply_rep σ A Φ hΦ hp hσ v
+      hr,
+      Pi.zero_apply] at Hr
+    exact Hr
+  subst hv
+  have hu : u = 0 := by
+    funext ⟨x, hx⟩
+    have Hx := congrFun H x
+    rw [map_zero, map_zero, add_zero, extZero_apply_mem _ hx, Pi.zero_apply] at Hx
+    exact Subtype.ext Hx
+  subst hu
+  rfl
+
+variable [FiniteDimensional k V]
+
+theorem le_finrank_ker_shift_sub_one (hΦ : ∀ f x, Φ f x = A (f (σ⁻¹ x))) {p : ℕ} (hp : p.Prime)
+    (hσ : σ ^ p = 1) (hA : A ^ p = 1) :
+    p * (fixedPts σ).card * finrank k (LinearMap.ker (A - 1)) +
+        (Fintype.card X - (fixedPts σ).card) * finrank k V
+      ≤ p * finrank k (LinearMap.ker (Φ - 1)) := by
+  have hle := LinearMap.finrank_le_finrank_of_injective (compMap_injective σ A Φ hΦ hp hσ hA)
+  rw [Module.finrank_prod, Module.finrank_pi_fintype, Module.finrank_pi_fintype, Finset.sum_const,
+    Finset.sum_const, smul_eq_mul, smul_eq_mul, Finset.card_univ, Finset.card_univ,
+    Fintype.card_coe,
+    Fintype.card_coe] at hle
+  have hX : Fintype.card X - (fixedPts σ).card = p * (freeReps σ).card := by
+    rw [← card_fixedPts_add_card_moving σ, Nat.add_sub_cancel_left, card_moving σ hp hσ]
+  rw [hX]
+  calc p * (fixedPts σ).card * finrank k (LinearMap.ker (A - 1))
+        + p * (freeReps σ).card * finrank k V
+      = p * ((fixedPts σ).card * finrank k (LinearMap.ker (A - 1))
+        + (freeReps σ).card * finrank k V) := by ring
+    _ ≤ p * finrank k (LinearMap.ker (Φ - 1)) := Nat.mul_le_mul_left p hle
+
+end Abstract
+
+section Concrete
+
+open scoped MatrixGroups
+p2m_open "HeckeEis P2MW.S_HeckeEis_le_finrank_fixed_induced_binaryFormRepSL.HeckeEis MvPolynomial"
+
+theorem finrank_binaryForm (K : Type*) [Field K] (n : ℕ) :
+    Module.finrank K (BinaryForm K n) = n + 1 := by
+  let S : Set (Fin 2 →₀ ℕ) := {d | d.degree = n}
+  have e1 : (BinaryForm K n) ≃ₗ[K] (S →₀ K) :=
+    (LinearEquiv.ofEq _ _ (MvPolynomial.homogeneousSubmodule_eq_finsupp_supported (Fin 2) K
+      n)).trans
+      (AddMonoidAlgebra.supportedEquivFinsupp S)
+  have e2 : S ≃ Fin (n + 1) :=
+    { toFun := fun d => ⟨d.1 0, by
+        have h := d.2
+        simp only [S, Set.mem_ofPred_eq, Finsupp.degree_eq_sum, Fin.sum_univ_two] at h
+        omega⟩
+      invFun := fun i => ⟨Finsupp.single 0 i.1 + Finsupp.single 1 (n - i.1), by
+        have hi := i.2
+        simp only [S, Set.mem_ofPred_eq, Finsupp.degree_eq_sum, Fin.sum_univ_two, Finsupp.add_apply,
+          Finsupp.single_apply]
+        simp
+        omega⟩
+      left_inv := fun d => by
+        have h := d.2
+        simp only [S, Set.mem_ofPred_eq, Finsupp.degree_eq_sum, Fin.sum_univ_two] at h
+        apply Subtype.ext
+        ext j
+        fin_cases j <;> simp ; omega
+      right_inv := fun i => by
+        apply Fin.ext
+        simp }
+  have : Fintype S := Fintype.ofEquiv _ e2.symm
+  rw [e1.finrank_eq, Module.finrank_finsupp_self, Fintype.card_congr e2, Fintype.card_fin]
+
+scoped instance instFiniteDimensionalBinaryForm (K : Type*) [Field K] (n : ℕ) : FiniteDimensional K
+  (BinaryForm K n) :=
+  Module.finite_of_finrank_pos (by rw [finrank_binaryForm]; omega)
+
+variable (N : ℕ)
+
+theorem neg_one_smul_coset (x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N) :
+    (-1 : SL(2, ℤ)) • x = x := by
+  induction x using QuotientGroup.induction_on with
+  | H g =>
+    rw [MulAction.Quotient.smul_mk, smul_eq_mul, neg_one_mul, ← mul_neg_one]
+    apply QuotientGroup.mk_mul_of_mem
+    rw [CongruenceSubgroup.Gamma0_mem]
+    simp [Matrix.SpecialLinearGroup.coe_neg]
+
+theorem toPerm_coset_pow_eq_one {g : SL(2, ℤ)} {p : ℕ} (hg : g ^ p = -1) :
+    (MulAction.toPerm g : Equiv.Perm (SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N)) ^ p = 1 := by
+  rw [← MulAction.toPermHom_apply, ← map_pow, hg, MulAction.toPermHom_apply]
+  ext x
+  rw [MulAction.toPerm_apply, neg_one_smul_coset]
+  rfl
+
+theorem S_sq : ModularGroup.S ^ 2 = -1 := by
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp [ModularGroup.coe_S, pow_succ, Matrix.mul_apply,
+    Fin.sum_univ_two]
+
+theorem ST_cube : (ModularGroup.S * ModularGroup.T) ^ 3 = -1 := by
+  ext i j
+  fin_cases i <;> fin_cases j <;>
+    simp [ModularGroup.coe_S, ModularGroup.coe_T, pow_succ, Matrix.mul_apply, Fin.sum_univ_two]
+
+theorem binaryFormRepSL_pow_eq_one (n : ℕ) (hn : Even n) {g : SL(2, ℤ)} {p : ℕ} (hg : g ^ p = -1) :
+    (binaryFormRepSL ℂ n g) ^ p = 1 := by
+  rw [← map_pow, hg]
+  refine LinearMap.ext fun P => ?_
+  rw [HeckeEis.binaryFormRepSL_neg_one_apply, hn.neg_one_pow, one_smul, Module.End.one_apply]
+
+noncomputable def xPow (n : ℕ) : BinaryForm ℂ n :=
+  ⟨X 0 ^ n, (MvPolynomial.mem_homogeneousSubmodule _ _).mpr (MvPolynomial.isHomogeneous_X_pow 0 n)⟩
+
+theorem xPow_ne_zero (n : ℕ) : xPow n ≠ 0 := by
+  intro h
+  have := congrArg Subtype.val h
+  exact pow_ne_zero n (MvPolynomial.X_ne_zero (0 : Fin 2)) this
+
+theorem binaryFormRepSL_T_xPow (n : ℕ) : binaryFormRepSL ℂ n ModularGroup.T (xPow n) = xPow n := by
+  apply Subtype.ext
+  rw [binaryFormRepSL_apply_coe]
+  simp [xPow, map_pow, binarySubst_X, ModularGroup.coe_T, Fin.sum_univ_two]
+
+end Concrete
+
+section Assembly
+
+open scoped MatrixGroups
+p2m_open "HeckeEis P2MW.S_HeckeEis_le_finrank_fixed_induced_binaryFormRepSL.HeckeEis"
+
+variable (N : ℕ) (n : ℕ)
+
+theorem finrank_coset_fun [NeZero N] :
+    Module.finrank ℂ (SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N → BinaryForm ℂ n)
+      = (n + 1) * (CongruenceSubgroup.Gamma0 N).index := by
+  classical
+  let : Fintype (SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N) := Fintype.ofFinite _
+  rw [Module.finrank_pi_fintype, Finset.sum_const, Finset.card_univ, smul_eq_mul,
+    finrank_binaryForm,
+    Subgroup.index_eq_card, Nat.card_eq_fintype_card, mul_comm]
+
+theorem prime_conjunct [NeZero N] (hn : Even n) {g : SL(2, ℤ)}
+    (Φ : Module.End ℂ (SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N → BinaryForm ℂ n))
+    (hW : ∀ f x, Φ f x = binaryFormRepSL ℂ n g (f (g⁻¹ • x)))
+    {p : ℕ} (hp : p.Prime) (hg : g ^ p = -1) :
+    p * (Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N // g • x = x}
+        * Module.finrank ℂ (LinearMap.ker (binaryFormRepSL ℂ n g - 1))) +
+      ((CongruenceSubgroup.Gamma0 N).index
+        - Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N // g • x = x}) * (n + 1)
+      ≤ p * Module.finrank ℂ (LinearMap.ker (Φ - 1)) := by
+  classical
+  let : Fintype (SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N) := Fintype.ofFinite _
+  have hΦ : ∀ f x, Φ f x = binaryFormRepSL ℂ n g (f ((MulAction.toPerm g)⁻¹ x)) := by
+    intro f x
+    rw [hW, Equiv.Perm.inv_def, MulAction.toPerm_symm_apply]
+  have key :=
+    le_finrank_ker_shift_sub_one (k := ℂ) (MulAction.toPerm g) (binaryFormRepSL ℂ n g) Φ hΦ hp
+    (toPerm_coset_pow_eq_one N hg) (binaryFormRepSL_pow_eq_one n hn hg)
+  have h1 : (fixedPts (MulAction.toPerm g : Equiv.Perm (SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0
+    N))).card
+      = Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N // g • x = x} := by
+    rw [Nat.card_eq_fintype_card, Fintype.card_subtype, fixedPts]
+    simp only [MulAction.toPerm_apply]
+  have h2 : Fintype.card (SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N) = (CongruenceSubgroup.Gamma0
+    N).index :=
+    by
+    rw [Subgroup.index_eq_card, Nat.card_eq_fintype_card]
+  rw [h1, h2, finrank_binaryForm, mul_assoc] at key
+  exact key
+
+theorem T_conjunct [NeZero N]
+    (Φ : Module.End ℂ (SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N → BinaryForm ℂ n))
+    (hW : ∀ f x, Φ f x = binaryFormRepSL ℂ n ModularGroup.T (f (ModularGroup.T⁻¹ • x))) :
+    Nat.card (MulAction.orbitRel.Quotient (Subgroup.zpowers ModularGroup.T)
+        (SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N))
+      ≤ Module.finrank ℂ (LinearMap.ker (Φ - 1)) := by
+  classical
+  let Cos := SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N
+  let Q := MulAction.orbitRel.Quotient (Subgroup.zpowers ModularGroup.T) Cos
+  let π : Cos → Q := Quotient.mk''
+  have : Finite Q := Finite.of_surjective π Quotient.mk''_surjective
+  let : Fintype Q := Fintype.ofFinite Q
+  let L0 : (Q → ℂ) →ₗ[ℂ] (Cos → BinaryForm ℂ n) :=
+    (LinearMap.toSpanSingleton ℂ (BinaryForm ℂ n) (xPow n)).compLeft Cos ∘ₗ LinearMap.funLeft ℂ ℂ π
+  have hL0 : ∀ c x, L0 c x = c (π x) • xPow n := fun c x => rfl
+  have hπ : ∀ x : Cos, π (ModularGroup.T⁻¹ • x) = π x := by
+    intro x
+    apply Quotient.sound
+    change (MulAction.orbitRel (Subgroup.zpowers ModularGroup.T) Cos) (ModularGroup.T⁻¹ • x) x
+    rw [MulAction.orbitRel_apply, MulAction.mem_orbit_iff]
+    exact ⟨⟨ModularGroup.T⁻¹, (Subgroup.zpowers _).inv_mem (Subgroup.mem_zpowers _)⟩, rfl⟩
+  have hmem : ∀ c, L0 c ∈ LinearMap.ker (Φ - 1) := by
+    intro c
+    rw [LinearMap.mem_ker]
+    funext x
+    rw [LinearMap.sub_apply, Module.End.one_apply, Pi.sub_apply, hW, hL0, hL0, map_smul,
+      binaryFormRepSL_T_xPow, hπ, Pi.zero_apply, sub_self]
+  have hinj : Function.Injective (LinearMap.codRestrict _ L0 hmem) := by
+    intro c d h
+    have h' : L0 c = L0 d := congrArg Subtype.val h
+    funext q
+    induction q using Quotient.inductionOn' with
+    | h x =>
+      have hx := congrFun h' x
+      rw [hL0, hL0] at hx
+      exact smul_left_injective ℂ (xPow_ne_zero n) hx
+  have := LinearMap.finrank_le_finrank_of_injective hinj
+  rwa [Module.finrank_pi ℂ, ← Nat.card_eq_fintype_card] at this
+
+end Assembly
+
+end HeckeEis.UH2
+
+open scoped MatrixGroups
+
+theorem solution (N : ℕ) [NeZero N] (n : ℕ) (hn : Even n)
+    (W : Representation ℂ (⊤ : Subgroup SL(2, ℤ)) (SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N →
+      ↥(HeckeEis.BinaryForm ℂ n)))
+    (hW : ∀ (g : (⊤ : Subgroup SL(2, ℤ))) (f : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N →
+      ↥(HeckeEis.BinaryForm ℂ n)) (x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N),
+      W g f x = HeckeEis.binaryFormRepSL ℂ n (g : SL(2, ℤ)) (f (((g : SL(2, ℤ))⁻¹) • x))) :
+    Module.finrank ℂ (SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n)) = (n + 1)
+      * (CongruenceSubgroup.Gamma0 N).index ∧
+    2 * (Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N // ModularGroup.S • x = x}
+        * Module.finrank ℂ ↥(LinearMap.ker (HeckeEis.binaryFormRepSL ℂ n ModularGroup.S - 1)))
+      + ((CongruenceSubgroup.Gamma0 N).index - Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N
+        // ModularGroup.S • x = x}) * (n + 1)
+      ≤ 2 * Module.finrank ℂ ↥(LinearMap.ker (W ⟨ModularGroup.S, Subgroup.mem_top _⟩ - 1)) ∧
+    3 * (Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N // (ModularGroup.S * ModularGroup.T) •
+      x = x}
+        * Module.finrank ℂ ↥(LinearMap.ker (HeckeEis.binaryFormRepSL ℂ n (ModularGroup.S *
+          ModularGroup.T) - 1)))
+      + ((CongruenceSubgroup.Gamma0 N).index - Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N
+        // (ModularGroup.S * ModularGroup.T) • x = x}) * (n + 1)
+      ≤ 3 * Module.finrank ℂ ↥(LinearMap.ker (W ⟨ModularGroup.S * ModularGroup.T, Subgroup.mem_top
+        _⟩ - 1)) ∧
+    Nat.card (MulAction.orbitRel.Quotient (Subgroup.zpowers ModularGroup.T) (SL(2, ℤ) ⧸
+      CongruenceSubgroup.Gamma0 N))
+      ≤ Module.finrank ℂ ↥(LinearMap.ker (W ⟨ModularGroup.T, Subgroup.mem_top _⟩ - 1)) :=
+  ⟨HeckeEis.UH2.finrank_coset_fun N n,
+    HeckeEis.UH2.prime_conjunct N n hn _ (hW ⟨ModularGroup.S, Subgroup.mem_top _⟩) Nat.prime_two
+      HeckeEis.UH2.S_sq,
+    HeckeEis.UH2.prime_conjunct N n hn _ (hW ⟨ModularGroup.S * ModularGroup.T, Subgroup.mem_top _⟩)
+      Nat.prime_three HeckeEis.UH2.ST_cube,
+    HeckeEis.UH2.T_conjunct N n _ (hW ⟨ModularGroup.T, Subgroup.mem_top _⟩)⟩
+
+end S_HeckeEis_le_finrank_fixed_induced_binaryFormRepSL
+end P2MW
+export P2MW.S_HeckeEis_le_finrank_fixed_induced_binaryFormRepSL (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.le_finrank_fixed_induced_binaryFormRepSL (N : ℕ) [NeZero N] (n : ℕ) (hn : Even n)
+    (W : Representation ℂ (⊤ : Subgroup SL(2, ℤ)) (SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N →
+      ↥(HeckeEis.BinaryForm ℂ n)))
+    (hW : ∀ (g : (⊤ : Subgroup SL(2, ℤ))) (f : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N →
+      ↥(HeckeEis.BinaryForm ℂ n)) (x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N),
+      W g f x = HeckeEis.binaryFormRepSL ℂ n (g : SL(2, ℤ)) (f (((g : SL(2, ℤ))⁻¹) • x))) :
+    Module.finrank ℂ (SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n)) = (n + 1)
+      * (CongruenceSubgroup.Gamma0 N).index ∧
+    2 * (Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N // ModularGroup.S • x = x}
+        * Module.finrank ℂ ↥(LinearMap.ker (HeckeEis.binaryFormRepSL ℂ n ModularGroup.S - 1)))
+      + ((CongruenceSubgroup.Gamma0 N).index - Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N
+        // ModularGroup.S • x = x}) * (n + 1)
+      ≤ 2 * Module.finrank ℂ ↥(LinearMap.ker (W ⟨ModularGroup.S, Subgroup.mem_top _⟩ - 1)) ∧
+    3 * (Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N // (ModularGroup.S * ModularGroup.T) •
+      x = x}
+        * Module.finrank ℂ ↥(LinearMap.ker (HeckeEis.binaryFormRepSL ℂ n (ModularGroup.S *
+          ModularGroup.T) - 1)))
+      + ((CongruenceSubgroup.Gamma0 N).index - Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N
+        // (ModularGroup.S * ModularGroup.T) • x = x}) * (n + 1)
+      ≤ 3 * Module.finrank ℂ ↥(LinearMap.ker (W ⟨ModularGroup.S * ModularGroup.T, Subgroup.mem_top
+        _⟩ - 1)) ∧
+    Nat.card (MulAction.orbitRel.Quotient (Subgroup.zpowers ModularGroup.T) (SL(2, ℤ) ⧸
+      CongruenceSubgroup.Gamma0 N))
+      ≤ Module.finrank ℂ ↥(LinearMap.ker (W ⟨ModularGroup.T, Subgroup.mem_top _⟩ - 1)) :=
+  solution N n hn W hW
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_linearIndependent_coeffH1par_map_rat_complex.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_linearIndependent_coeffH1par_map_rat_complex.lean
new file mode 100644
index 0000000000..c5003b532c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_linearIndependent_coeffH1par_map_rat_complex.lean
@@ -0,0 +1,601 @@
+/-
+Based on Prove2Me node HeckeEis.linearIndependent_coeffH1par_map_rat_complex
+(3461fd1f-9592-5ee3-9e6e-e31d7a218762) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission eab836a3-3dbb-50e8-8e6c-9ce9d1bf7c23
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Basic.Complex.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+
+import Mathlib.Algebra.MvPolynomial.Monad
+import Mathlib.Analysis.CStarAlgebra.Classes
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Rational independence in H¹ₚₐᵣ persists over ℂ
+
+Theorem statement: `HeckeEis.linearIndependent_coeffH1par_map_rat_complex`
+(`3461fd1f-9592-5ee3-9e6e-e31d7a218762`), by Claude, 2026-09-05.
+
+Proof: submission `eab836a3-3dbb-50e8-8e6c-9ce9d1bf7c23`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $n \in \mathbb N$ and a subgroup $\Gamma \le \mathrm{SL}_2(\mathbb Z)$. For a commutative ring
+$K$, [`HeckeEis.binaryFormRepSL K n`](def/HeckeEis_BinaryFormRep.html#L61) is the representation of
+$\mathrm{SL}_2(\mathbb Z)$ on the degree-$n$ homogeneous part of $K[X_0,X_1]$ by the substitution
+$X_j \mapsto \sum_i M_{ij} X_i$ attached to the integral matrix $M$ of a group element, and its
+composite with the inclusion of $\Gamma$ gives a representation of $\Gamma$;
+[`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100) of such a representation $\rho$ is the
+quotient of the submodule of parabolic cocycles — maps $z \colon \Gamma \to V$ with $z(gh) = z(g) +
+\rho(g) z(h)$ and $z(\gamma) \in \mathrm{range}(\rho(\gamma) - 1)$ for every $\gamma$ whose integral
+matrix has squared trace $4$ — by the coboundaries lying in it, and
+[`HeckeEis.coeffH1parMk`](def/Gamma0CoeffCohomology.html#L111) is the quotient map. Let $\Psi$ be an
+additive homomorphism from `coeffH1par` of the rational representation to `coeffH1par` of the
+complex one, and assume that for every parabolic cocycle $z$ with values in the rational binary
+forms there is a parabolic cocycle $w$ with values in the complex binary forms such that $w(g)$ is
+the image of $z(g)$ under coefficientwise application of $\mathbb Q \to \mathbb C$ for all $g \in
+\Gamma$, and $\Psi$ sends the class of $z$ to the class of $w$. Then for any family $y \colon \iota
+\to$ `coeffH1par` over $\mathbb Q$ that is $\mathbb Q$-linearly independent, the family $i \mapsto
+\Psi(y_i)$ is $\mathbb C$-linearly independent.
+
+This is the standard base-change comparison for parabolic cohomology of the symmetric-power
+coefficient systems: a $\mathbb Q$-linearly independent set of classes in
+$H^1_{\mathrm{par}}(\Gamma, \mathrm{Sym}^n)$ remains linearly independent after extension of the
+coefficient field to $\mathbb C$, provided the comparison map is realised on cocycles. It is used in
+the construction of a basis of the complex parabolic cohomology coming from an integral one, in
+[`HeckeEis.exists_basis_coeffH1par_int_complex`]
+(thm.html#HeckeEis.exists_basis_coeffH1par_int_complex).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_linearIndependent_coeffH1par_map_rat_complex.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_linearIndependent_coeffH1par_map_rat_complex
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff IsParabolicCocycle \
+  coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff"
+namespace GenAux
+p2m_open "HeckeEis"
+
+variable {G : Type*} [Group G] {K : Type*} [CommRing K] {V : Type*} [AddCommGroup V] [Module K V]
+
+theorem coeffCocycles_apply_one {ρ : Representation K G V} {z : G → V} (hz : z ∈ coeffCocycles ρ) :
+    z 1 = 0 := by
+  have h := hz 1 1
+  rw [mul_one, map_one, Module.End.one_apply] at h
+  have : z 1 + z 1 = z 1 + 0 := by rw [add_zero]; exact h.symm
+  exact add_left_cancel this
+
+theorem coeffCocycles_apply_inv {ρ : Representation K G V} {z : G → V} (hz : z ∈ coeffCocycles ρ)
+    (g : G) :
+    z g⁻¹ = -(ρ g⁻¹ (z g)) := by
+  have h := hz g⁻¹ g
+  rw [inv_mul_cancel, coeffCocycles_apply_one hz] at h
+  exact eq_neg_of_add_eq_zero_left h.symm
+
+theorem mem_of_mem_coeffCocycles_of_closure_eq_top {ρ : Representation K G V} {z : G → V}
+    (hz : z ∈ coeffCocycles ρ)
+    (M : AddSubgroup V) (hM : ∀ (g : G) (v : V), v ∈ M → ρ g v ∈ M) {s : Set G}
+    (hs : Subgroup.closure s = ⊤)
+    (h : ∀ g ∈ s, z g ∈ M) (g : G) : z g ∈ M := by
+  let H : Subgroup G :=
+    { carrier := {g | z g ∈ M}
+      one_mem' := by
+        change z 1 ∈ M
+        rw [coeffCocycles_apply_one hz]; exact M.zero_mem
+      mul_mem' := by
+        intro a b ha hb
+        change z (a * b) ∈ M
+        rw [hz a b]
+        exact M.add_mem ha (hM a _ hb)
+      inv_mem' := by
+        intro a ha
+        change z a⁻¹ ∈ M
+        rw [coeffCocycles_apply_inv hz]
+        exact M.neg_mem (hM _ _ ha) }
+  have hle : (⊤ : Subgroup G) ≤ H := by
+    rw [← hs, Subgroup.closure_le]
+    exact h
+  exact hle (Subgroup.mem_top g)
+
+theorem coeffCocycles_eq_of_eqOn {ρ : Representation K G V} {z z' : G → V}
+    (hz : z ∈ coeffCocycles ρ) (hz' : z' ∈ coeffCocycles ρ)
+    {s : Set G} (hs : Subgroup.closure s = ⊤) (h : ∀ g ∈ s, z g = z' g) : z = z' := by
+  have hd : z - z' ∈ coeffCocycles ρ := Submodule.sub_mem _ hz hz'
+  funext g
+  have := mem_of_mem_coeffCocycles_of_closure_eq_top hd ⊥ (fun g v hv => by
+    rw [AddSubgroup.mem_bot] at hv ⊢; rw [hv, map_zero]) hs (fun g hg => by
+    rw [AddSubgroup.mem_bot, Pi.sub_apply, h g hg, sub_self]) g
+  rw [AddSubgroup.mem_bot, Pi.sub_apply] at this
+  exact sub_eq_zero.mp this
+
+end HeckeEis.GenAux
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff IsParabolicCocycle \
+  coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff"
+namespace CoeffMapAux
+p2m_open "HeckeEis"
+
+open MvPolynomial
+open scoped MatrixGroups
+
+variable {R R' : Type*} [CommRing R] [CommRing R']
+
+theorem binarySubst_eq_bind₁ (S : Type*) [CommRing S] (M : Matrix (Fin 2) (Fin 2) ℤ)
+    (P : MvPolynomial (Fin 2) S) :
+    binarySubst S M P = bind₁ (fun j => ∑ i : Fin 2, C ((M i j : ℤ) : S) * X i) P := by
+  rw [binarySubst, aeval_eq_bind₁]
+
+theorem map_binarySubst_int (φ : ℤ →+* R) (M : Matrix (Fin 2) (Fin 2) ℤ)
+    (P : MvPolynomial (Fin 2) ℤ) :
+    MvPolynomial.map φ (binarySubst ℤ M P) = binarySubst R M (MvPolynomial.map φ P) := by
+  have key : (MvPolynomial.map φ).comp (binarySubst ℤ M : MvPolynomial (Fin 2) ℤ →ₐ[ℤ] MvPolynomial
+    (Fin 2) ℤ).toRingHom
+      = (binarySubst R M : MvPolynomial (Fin 2) R →ₐ[R] MvPolynomial (Fin 2) R).toRingHom.comp
+        (MvPolynomial.map φ) :=
+    MvPolynomial.ringHom_ext (fun a => by simp []) (fun j => by simp [binarySubst_X])
+  exact RingHom.congr_fun key P
+
+def substCoeff (M : Matrix (Fin 2) (Fin 2) ℤ) (d d' : Fin 2 →₀ ℕ) : ℤ :=
+  AddMonoidAlgebra.coeff (binarySubst ℤ M (monomial d' 1)) d
+
+theorem binarySubst_monomial_one (M : Matrix (Fin 2) (Fin 2) ℤ) (d' : Fin 2 →₀ ℕ) :
+    binarySubst R M (monomial d' 1) = MvPolynomial.map (Int.castRingHom R) (binarySubst ℤ M
+      (monomial d' 1)) := by
+  rw [map_binarySubst_int, map_monomial, (Int.castRingHom R).map_one]
+
+theorem coeff_binarySubst (M : Matrix (Fin 2) (Fin 2) ℤ) (P : MvPolynomial (Fin 2) R)
+    (d : Fin 2 →₀ ℕ) :
+    AddMonoidAlgebra.coeff (binarySubst R M P) d =
+      ∑ d' ∈ P.support, (substCoeff M d d' : R) * AddMonoidAlgebra.coeff P d' := by
+  conv_lhs => rw [P.as_sum, map_sum, coeff_sum]
+  refine Finset.sum_congr rfl fun d' _ => ?_
+  rw [show monomial d' (AddMonoidAlgebra.coeff P d') =
+    C (AddMonoidAlgebra.coeff P d') * monomial d' 1 by rw [C_mul_monomial,
+      mul_one], map_mul, binarySubst_C,
+    coeff_C_mul, binarySubst_monomial_one, coeff_map, substCoeff, mul_comm]
+  rfl
+
+variable (f : R →+ R')
+
+def pushCoeff (P : MvPolynomial (Fin 2) R) : MvPolynomial (Fin 2) R' :=
+  ∑ d ∈ P.support, monomial d (f (AddMonoidAlgebra.coeff P d))
+
+@[scoped simp] theorem coeff_pushCoeff (P : MvPolynomial (Fin 2) R) (d : Fin 2 →₀ ℕ) :
+    AddMonoidAlgebra.coeff (pushCoeff f P) d = f (AddMonoidAlgebra.coeff P d) := by
+  classical
+  rw [pushCoeff, coeff_sum]
+  simp only [coeff_monomial]
+  rw [Finset.sum_ite_eq']
+  split_ifs with h
+  · rfl
+  · rw [notMem_support_iff.mp h, map_zero]
+
+theorem support_pushCoeff (P : MvPolynomial (Fin 2) R) : (pushCoeff f P).support ⊆ P.support := by
+  intro d hd
+  rw [mem_support_iff, coeff_pushCoeff] at hd
+  rw [mem_support_iff]
+  intro h; exact hd (by rw [h, map_zero])
+
+theorem pushCoeff_mem (n : ℕ) {P : MvPolynomial (Fin 2) R} (hP : P ∈ BinaryForm R n) :
+    pushCoeff f P ∈ BinaryForm R' n := by
+  rw [mem_homogeneousSubmodule] at hP ⊢
+  intro d hd
+  exact hP (mem_support_iff.mp (support_pushCoeff f P (mem_support_iff.mpr hd)))
+
+theorem pushCoeff_add (P Q : MvPolynomial (Fin 2) R) :
+    pushCoeff f (P + Q) = pushCoeff f P + pushCoeff f Q := by
+  ext d; simp
+
+theorem pushCoeff_sub (P Q : MvPolynomial (Fin 2) R) :
+    pushCoeff f (P - Q) = pushCoeff f P - pushCoeff f Q := by
+  ext d; simp
+
+theorem pushCoeff_zero : pushCoeff f (0 : MvPolynomial (Fin 2) R) = 0 := by
+  ext d; simp
+
+theorem eq_pushCoeff_iff (P : MvPolynomial (Fin 2) R) (Q : MvPolynomial (Fin 2) R') :
+    Q = pushCoeff f P ↔ ∀ d, AddMonoidAlgebra.coeff Q d = f (AddMonoidAlgebra.coeff P d) := by
+  constructor
+  · rintro rfl d; exact coeff_pushCoeff f P d
+  · intro h; ext d; rw [h d, coeff_pushCoeff]
+
+theorem pushCoeff_binarySubst (M : Matrix (Fin 2) (Fin 2) ℤ) (P : MvPolynomial (Fin 2) R) :
+    pushCoeff f (binarySubst R M P) = binarySubst R' M (pushCoeff f P) := by
+  classical
+  ext d
+  rw [coeff_pushCoeff, coeff_binarySubst, coeff_binarySubst, map_sum]
+  rw [Finset.sum_subset (support_pushCoeff f P)]
+  · refine Finset.sum_congr rfl fun d' _ => ?_
+    rw [coeff_pushCoeff, ← zsmul_eq_mul, ← zsmul_eq_mul, map_zsmul]
+  · intro d' _ hd'
+    rw [notMem_support_iff.mp hd', mul_zero]
+
+def pushForm (n : ℕ) (P : ↥(BinaryForm R n)) :
+    ↥(BinaryForm R' n) := ⟨pushCoeff f P, pushCoeff_mem f n P.2⟩
+
+@[scoped simp] theorem coe_pushForm (n : ℕ) (P : ↥(BinaryForm R n)) :
+    ((pushForm f n P : ↥(BinaryForm R' n)) : MvPolynomial (Fin 2) R') = pushCoeff f P := rfl
+
+theorem pushForm_add (n : ℕ) (P Q : ↥(BinaryForm R n)) :
+    pushForm f n (P + Q) = pushForm f n P + pushForm f n Q :=
+  Subtype.ext (by simp [pushCoeff_add])
+
+theorem pushForm_sub (n : ℕ) (P Q : ↥(BinaryForm R n)) :
+    pushForm f n (P - Q) = pushForm f n P - pushForm f n Q :=
+  Subtype.ext (by simp [pushCoeff_sub])
+
+theorem pushForm_zero (n : ℕ) :
+    pushForm f n (0 : ↥(BinaryForm R n)) = 0 := Subtype.ext (by simp [pushCoeff_zero])
+
+theorem pushForm_binaryFormRepSL (n : ℕ) (g : SL(2, ℤ)) (P : ↥(BinaryForm R n)) :
+    pushForm f n (binaryFormRepSL R n g P) = binaryFormRepSL R' n g (pushForm f n P) :=
+  Subtype.ext (by simp [pushCoeff_binarySubst])
+
+section Cocycles
+
+variable {Γ : Subgroup SL(2, ℤ)} (n : ℕ)
+
+theorem pushForm_comp_mem_coeffCocycles {z : Γ → ↥(BinaryForm R n)}
+    (hz : z ∈ coeffCocycles ((binaryFormRepSL R n).comp Γ.subtype)) :
+    (fun g => pushForm f n (z g)) ∈ coeffCocycles ((binaryFormRepSL R' n).comp Γ.subtype) := by
+  intro g h
+  change pushForm f n (z (g * h)) = pushForm f n (z g) + binaryFormRepSL R' n ((g : Γ) : SL(2, ℤ))
+    (pushForm f n (z h))
+  rw [hz g h, pushForm_add, ← pushForm_binaryFormRepSL]
+  rfl
+
+theorem isParabolicCocycle_pushForm_comp {z : Γ → ↥(BinaryForm R n)}
+    (hz : IsParabolicCocycle ((binaryFormRepSL R n).comp Γ.subtype) z) :
+    IsParabolicCocycle ((binaryFormRepSL R' n).comp Γ.subtype) (fun g => pushForm f n (z g)) := by
+  intro γ hγ
+  obtain ⟨u, hu⟩ := hz γ hγ
+  refine ⟨pushForm f n u, ?_⟩
+  rw [LinearMap.sub_apply, Module.End.one_apply] at hu ⊢
+  change binaryFormRepSL R n (γ : SL(2, ℤ)) u - u = z γ at hu
+  change binaryFormRepSL R' n (γ : SL(2, ℤ)) (pushForm f n u) - pushForm f n u = pushForm f n (z γ)
+  rw [← hu, pushForm_sub, pushForm_binaryFormRepSL]
+
+theorem pushForm_comp_mem_coeffParabolicCocycles {z : Γ → ↥(BinaryForm R n)}
+    (hz : z ∈ coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype)) :
+    (fun g => pushForm f n (z g)) ∈ coeffParabolicCocycles ((binaryFormRepSL R' n).comp Γ.subtype)
+      :=
+  ⟨pushForm_comp_mem_coeffCocycles f n hz.1, isParabolicCocycle_pushForm_comp f n hz.2⟩
+
+theorem pushForm_comp_mem_coeffCoboundaries {z : Γ → ↥(BinaryForm R n)}
+    (hz : z ∈ coeffCoboundaries ((binaryFormRepSL R n).comp Γ.subtype)) :
+    (fun g => pushForm f n (z g)) ∈ coeffCoboundaries ((binaryFormRepSL R' n).comp Γ.subtype) := by
+  obtain ⟨v, hv⟩ := (mem_coeffCoboundaries_iff _ _).mp hz
+  rw [mem_coeffCoboundaries_iff]
+  refine ⟨pushForm f n v, funext fun g => ?_⟩
+  have h := congrFun hv g
+  change binaryFormRepSL R n (g : SL(2, ℤ)) v - v = z g at h
+  change binaryFormRepSL R' n (g : SL(2, ℤ)) (pushForm f n v) - pushForm f n v = pushForm f n (z g)
+  rw [← h, pushForm_sub, pushForm_binaryFormRepSL]
+
+def pushPar : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))
+    →+ ↥(coeffParabolicCocycles ((binaryFormRepSL R' n).comp Γ.subtype)) where
+  toFun z := ⟨fun g => pushForm f n (z.1 g), pushForm_comp_mem_coeffParabolicCocycles f n z.2⟩
+  map_zero' := by
+    apply Subtype.ext; funext g
+    change pushForm f n ((0 : Γ → ↥(BinaryForm R n)) g) = 0
+    rw [Pi.zero_apply, pushForm_zero]
+  map_add' z w := by
+    apply Subtype.ext; funext g
+    change pushForm f n (z.1 g + w.1 g) = pushForm f n (z.1 g) + pushForm f n (w.1 g)
+    rw [pushForm_add]
+
+@[scoped simp] theorem pushPar_apply_coe (z : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp
+  Γ.subtype))) (g : Γ) :
+    (((pushPar f n z).1 g : ↥(BinaryForm R' n)) : MvPolynomial (Fin 2) R') = pushCoeff f (z.1 g) :=
+      rfl
+
+theorem pushPar_apply_val (z : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype)))
+    (g : Γ) :
+    (pushPar f n z).1 g = pushForm f n (z.1 g) := rfl
+
+theorem mk_eq_mk_iff {S : Type*} [CommRing S]
+    (a b : ↥(coeffParabolicCocycles ((binaryFormRepSL S n).comp Γ.subtype))) :
+    coeffH1parMk _ a = coeffH1parMk _ b ↔
+      ((a - b : ↥(coeffParabolicCocycles ((binaryFormRepSL S n).comp Γ.subtype))).1
+        ∈ coeffCoboundaries ((binaryFormRepSL S n).comp Γ.subtype)) := by
+  rw [← sub_eq_zero, ← map_sub, coeffH1parMk_eq_zero_iff]
+
+theorem pushPar_sub (a b : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))) :
+    pushPar f n (a - b) = pushPar f n a - pushPar f n b :=
+  map_sub (pushPar f n) a b
+
+theorem mk_pushPar_congr {a b : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))}
+    (h : coeffH1parMk _ a = coeffH1parMk _ b) :
+    coeffH1parMk _ (pushPar f n a) = coeffH1parMk _ (pushPar f n b) := by
+  rw [mk_eq_mk_iff] at h ⊢
+  rw [← pushPar_sub]
+  exact pushForm_comp_mem_coeffCoboundaries f n h
+
+def pushH1par :
+    coeffH1par ((binaryFormRepSL R n).comp Γ.subtype) →+
+      coeffH1par ((binaryFormRepSL R' n).comp Γ.subtype) where
+  toFun x := coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) x))
+  map_zero' := by
+    have h0 : coeffH1parMk _ (Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp
+      Γ.subtype)) 0)
+        = coeffH1parMk _ (0 : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))) :=
+          by
+      rw [Function.surjInv_eq (coeffH1parMk_surjective _), map_zero]
+    change coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) 0)) = 0
+    rw [mk_pushPar_congr f n h0, map_zero, map_zero]
+  map_add' x y := by
+    have hxy : coeffH1parMk _ (Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp
+      Γ.subtype)) (x + y))
+        = coeffH1parMk _ (Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp
+          Γ.subtype)) x
+            + Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp Γ.subtype)) y)
+              := by
+      rw [map_add, Function.surjInv_eq (coeffH1parMk_surjective _), Function.surjInv_eq
+        (coeffH1parMk_surjective _),
+        Function.surjInv_eq (coeffH1parMk_surjective _)]
+    change coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) (x + y))) = _
+    rw [mk_pushPar_congr f n hxy, map_add, map_add]
+
+theorem pushH1par_mk (z : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))) :
+    pushH1par f n (coeffH1parMk _ z) = coeffH1parMk _ (pushPar f n z) := by
+  change coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) (coeffH1parMk _
+    z))) = _
+  apply mk_pushPar_congr
+  exact Function.surjInv_eq (coeffH1parMk_surjective _) _
+
+end Cocycles
+
+end HeckeEis.CoeffMapAux
+end
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff IsParabolicCocycle \
+  coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff"
+namespace CoeffMapAux
+p2m_open "HeckeEis"
+
+open MvPolynomial
+open scoped MatrixGroups
+
+theorem pushCoeff_ringHom_eq_map {R R' : Type*} [CommRing R] [CommRing R'] (φ : R →+* R')
+    (P : MvPolynomial (Fin 2) R) :
+    pushCoeff φ.toAddMonoidHom P = MvPolynomial.map φ P := by
+  ext d
+  rw [coeff_pushCoeff, coeff_map]
+  rfl
+
+end HeckeEis.CoeffMapAux
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff IsParabolicCocycle \
+  coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff"
+namespace QCAux
+p2m_open "HeckeEis"
+
+open MvPolynomial HeckeEis.CoeffMapAux HeckeEis.GenAux
+open scoped MatrixGroups
+
+abbrev ιQC : ℚ →+ ℂ := (algebraMap ℚ ℂ).toAddMonoidHom
+
+abbrev BQC := Module.Basis.ofVectorSpace ℚ ℂ
+
+abbrev πQC (α : Module.Basis.ofVectorSpaceIndex ℚ ℂ) : ℂ →+ ℚ := ((BQC).coord α).toAddMonoidHom
+
+variable (n : ℕ)
+
+theorem coe_pushForm_ιQC (P : ↥(BinaryForm ℚ n)) :
+    ((pushForm ιQC n P : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) = MvPolynomial.map (algebraMap
+      ℚ ℂ) P := by
+  rw [coe_pushForm]; exact pushCoeff_ringHom_eq_map _ _
+
+theorem pushForm_π_smul_ι (α : Module.Basis.ofVectorSpaceIndex ℚ ℂ) (c : ℂ) (Q : ↥(BinaryForm ℚ n))
+    :
+    pushForm (πQC α) n (c • pushForm ιQC n Q) = (BQC.coord α c) • Q := by
+  apply Subtype.ext
+  ext d
+  simp only [coe_pushForm, coeff_pushCoeff, Submodule.coe_smul, coeff_smul, smul_eq_mul]
+  change (BQC.coord α) (c * (algebraMap ℚ ℂ)
+    (AddMonoidAlgebra.coeff (Q : MvPolynomial (Fin 2) ℚ) d)) = _
+  rw [mul_comm, ← Algebra.smul_def, LinearMap.map_smul, smul_eq_mul, mul_comm]
+
+theorem sum_smul_pushForm_π (P : ↥(BinaryForm ℂ n))
+    (A : Finset (Module.Basis.ofVectorSpaceIndex ℚ ℂ))
+    (hA : ∀ d ∈ (P : MvPolynomial (Fin 2) ℂ).support,
+      (BQC.repr (AddMonoidAlgebra.coeff (P : MvPolynomial (Fin 2) ℂ) d)).support ⊆ A) :
+    ∑ α ∈ A, (BQC α : ℂ) • pushForm ιQC n (pushForm (πQC α) n P) = P := by
+  classical
+  apply Subtype.ext
+  ext d
+  rw [Submodule.coe_sum, coeff_sum]
+  simp only [Submodule.coe_smul, coeff_smul, coe_pushForm, coeff_pushCoeff, smul_eq_mul]
+  by_cases hd : d ∈ (P : MvPolynomial (Fin 2) ℂ).support
+  · set x : ℂ := AddMonoidAlgebra.coeff (P : MvPolynomial (Fin 2) ℂ) d
+    have hx := BQC.linearCombination_repr x
+    rw [Finsupp.linearCombination_apply,
+      Finsupp.sum_of_support_subset (BQC.repr x) (hA d hd) (fun i a => a • (BQC i : ℂ)) (fun i _ =>
+      zero_smul ℚ _)] at hx
+    conv_rhs => rw [← hx]
+    refine Finset.sum_congr rfl fun α _ => ?_
+    change (BQC α : ℂ) * (algebraMap ℚ ℂ) (BQC.coord α x) = (BQC.repr x α) • (BQC α : ℂ)
+    rw [Algebra.smul_def, mul_comm]
+    rfl
+  · rw [notMem_support_iff.mp hd]
+    refine Finset.sum_eq_zero fun α _ => ?_
+    change (BQC α : ℂ) * (algebraMap ℚ ℂ) ((BQC.coord α) (0 : ℂ)) = 0
+    rw [map_zero, map_zero, mul_zero]
+
+variable {Γ : Subgroup SL(2, ℤ)}
+
+theorem exists_eq_sum_smul_pushPar (s : Finset Γ) (hs : Subgroup.closure (s : Set Γ) = ⊤)
+    (Z : ↥(coeffParabolicCocycles ((binaryFormRepSL ℂ n).comp Γ.subtype))) :
+    ∃ A : Finset (Module.Basis.ofVectorSpaceIndex ℚ ℂ),
+      Z = ∑ α ∈ A, (BQC α : ℂ) • pushPar ιQC n (pushPar (πQC α) n Z) := by
+  classical
+  let A : Finset (Module.Basis.ofVectorSpaceIndex ℚ ℂ) :=
+    s.biUnion fun g => ((Z.1 g : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ).support.biUnion fun d
+      =>
+      (BQC.repr (AddMonoidAlgebra.coeff
+        ((Z.1 g : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) d)).support
+  refine ⟨A, Subtype.ext ?_⟩
+  set T : ↥(coeffParabolicCocycles ((binaryFormRepSL ℂ n).comp Γ.subtype)) :=
+    ∑ α ∈ A, (BQC α : ℂ) • pushPar ιQC n (pushPar (πQC α) n Z) with hT
+  refine coeffCocycles_eq_of_eqOn Z.2.1 T.2.1 hs fun g hg => ?_
+  rw [hT]
+  rw [Submodule.coe_sum, Finset.sum_apply]
+  simp only [Submodule.coe_smul, Pi.smul_apply, pushPar_apply_val]
+  symm
+  apply sum_smul_pushForm_π
+  intro d hd
+  exact Finset.subset_biUnion_of_mem (fun d => (BQC.repr (AddMonoidAlgebra.coeff
+    ((Z.1 g : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) d)).support) hd
+    |>.trans (Finset.subset_biUnion_of_mem (fun g => ((Z.1 g : ↥(BinaryForm ℂ n)) : MvPolynomial
+      (Fin 2) ℂ).support.biUnion fun d =>
+      (BQC.repr (AddMonoidAlgebra.coeff
+        ((Z.1 g : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) d)).support) hg)
+
+variable (Ψ : coeffH1par ((binaryFormRepSL ℚ n).comp Γ.subtype) →+ coeffH1par ((binaryFormRepSL ℂ
+  n).comp Γ.subtype))
+  (hΨ : ∀ z : ↥(coeffParabolicCocycles ((binaryFormRepSL ℚ n).comp Γ.subtype)), ∃ w :
+    ↥(coeffParabolicCocycles ((binaryFormRepSL ℂ n).comp Γ.subtype)),
+    (∀ g : Γ, ((w : Γ → ↥(BinaryForm ℂ n)) g : MvPolynomial (Fin 2) ℂ)
+        = MvPolynomial.map (algebraMap ℚ ℂ) (((z : Γ → ↥(BinaryForm ℚ n)) g : MvPolynomial (Fin 2)
+          ℚ))) ∧
+    Ψ (coeffH1parMk _ z) = coeffH1parMk _ w)
+
+include hΨ in
+theorem Ψ_mk (z : ↥(coeffParabolicCocycles ((binaryFormRepSL ℚ n).comp Γ.subtype))) :
+    Ψ (coeffH1parMk _ z) = coeffH1parMk _ (pushPar ιQC n z) := by
+  obtain ⟨w, hw, h⟩ := hΨ z
+  rw [h]
+  congr 1
+  apply Subtype.ext; funext g; apply Subtype.ext
+  rw [hw g]
+  exact (coe_pushForm_ιQC n _).symm
+
+include hΨ in
+theorem mem_span_range (s : Finset Γ) (hs : Subgroup.closure (s : Set Γ) = ⊤)
+    (X : coeffH1par ((binaryFormRepSL ℂ n).comp Γ.subtype)) :
+    X ∈ Submodule.span ℂ (Set.range Ψ) := by
+  classical
+  obtain ⟨Z, rfl⟩ := coeffH1parMk_surjective _ X
+  obtain ⟨A, hA⟩ := exists_eq_sum_smul_pushPar n s hs Z
+  rw [hA, map_sum]
+  refine Submodule.sum_mem _ fun α _ => ?_
+  rw [map_smul]
+  refine Submodule.smul_mem _ _ (Submodule.subset_span ⟨coeffH1parMk _ (pushPar (πQC α) n Z), ?_⟩)
+  exact Ψ_mk n Ψ hΨ _
+
+include hΨ in
+theorem linearIndependent_comp {ι : Type*}
+    (y : ι → coeffH1par ((binaryFormRepSL ℚ n).comp Γ.subtype)) (hy : LinearIndependent ℚ y) :
+    LinearIndependent ℂ (fun i => Ψ (y i)) := by
+  classical
+  rw [linearIndependent_iff'] at hy ⊢
+  intro t c hc i hi
+  choose Y hY using fun i => coeffH1parMk_surjective ((binaryFormRepSL ℚ n).comp Γ.subtype) (y i)
+  have hΨy : ∀ i, Ψ (y i) = coeffH1parMk _ (pushPar ιQC n (Y i)) :=
+    fun i => by rw [← hY i, Ψ_mk n Ψ hΨ]
+  simp only [hΨy] at hc
+  simp only [← LinearMap.map_smul (coeffH1parMk ((binaryFormRepSL ℂ n).comp Γ.subtype)), ←
+    map_sum] at hc
+  rw [coeffH1parMk_eq_zero_iff] at hc
+  obtain ⟨v, hv⟩ := (mem_coeffCoboundaries_iff _ _).mp hc
+  suffices hcoord : ∀ α, BQC.coord α (c i) = 0 from (BQC.forall_coord_eq_zero_iff).mp hcoord
+  intro α
+  have hrel : (∑ j ∈ t, (BQC.coord α (c j)) • (Y j : Γ → ↥(BinaryForm ℚ n)))
+      ∈ coeffCoboundaries ((binaryFormRepSL ℚ n).comp Γ.subtype) := by
+    rw [mem_coeffCoboundaries_iff]
+    refine ⟨pushForm (πQC α) n v, funext fun g => ?_⟩
+    have h1 := congrFun hv g
+    change binaryFormRepSL ℂ n (g : SL(2, ℤ)) v - v = _ at h1
+    change binaryFormRepSL ℚ n (g : SL(2, ℤ)) (pushForm (πQC α) n v) - pushForm (πQC α) n v = _
+    rw [← pushForm_binaryFormRepSL, ← pushForm_sub, h1, Submodule.coe_sum, Finset.sum_apply,
+      Finset.sum_apply]
+    have hadd : ∀ (F : Finset ι) (G : ι → ↥(BinaryForm ℂ n)),
+        pushForm (πQC α) n (∑ j ∈ F, G j) = ∑ j ∈ F, pushForm (πQC α) n (G j) := by
+      intro F G
+      exact map_sum (⟨⟨pushForm (πQC α) n, pushForm_zero _ n⟩, pushForm_add _ n⟩ : ↥(BinaryForm ℂ n)
+        →+ ↥(BinaryForm ℚ n)) G F
+    rw [hadd]
+    refine Finset.sum_congr rfl fun j _ => ?_
+    rw [Submodule.coe_smul, Pi.smul_apply, pushPar_apply_val, pushForm_π_smul_ι]
+    rfl
+  have hzero : (∑ j ∈ t, (BQC.coord α (c j)) • y j) = 0 := by
+    have : (∑ j ∈ t, (BQC.coord α (c j)) • y j) = coeffH1parMk ((binaryFormRepSL ℚ n).comp
+      Γ.subtype) (∑ j ∈ t, (BQC.coord α (c j)) • Y j) :=
+      by
+      rw [map_sum]; exact Finset.sum_congr rfl fun j _ => by rw [map_smul, hY]
+    rw [this, coeffH1parMk_eq_zero_iff]
+    simpa [Submodule.coe_sum, Submodule.coe_smul] using hrel
+  exact hy t (fun j => BQC.coord α (c j)) hzero i hi
+
+end HeckeEis.QCAux
+end
+
+open scoped MatrixGroups in
+theorem solution (n : ℕ) (Γ : Subgroup SL(2, ℤ))
+    (Ψ : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℚ n).comp Γ.subtype) →+ HeckeEis.coeffH1par
+      ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype))
+    (hΨ : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℚ n).comp Γ.subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype)),
+        (∀ g : Γ, ((w : Γ → ↥(HeckeEis.BinaryForm ℂ n)) g : MvPolynomial (Fin 2) ℂ)
+            = MvPolynomial.map (algebraMap ℚ ℂ)
+                (((z : Γ → ↥(HeckeEis.BinaryForm ℚ n)) g : MvPolynomial (Fin 2) ℚ))) ∧
+        Ψ (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w)
+    {ι : Type*} (y : ι → HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℚ n).comp Γ.subtype))
+    (hy : LinearIndependent ℚ y) :
+    LinearIndependent ℂ (fun i => Ψ (y i)) :=
+  HeckeEis.QCAux.linearIndependent_comp n Ψ hΨ y hy
+
+end S_HeckeEis_linearIndependent_coeffH1par_map_rat_complex
+end P2MW
+export P2MW.S_HeckeEis_linearIndependent_coeffH1par_map_rat_complex (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.linearIndependent_coeffH1par_map_rat_complex (n : ℕ) (Γ : Subgroup SL(2, ℤ))
+    (Ψ : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℚ n).comp Γ.subtype) →+ HeckeEis.coeffH1par
+      ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype))
+    (hΨ : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℚ n).comp Γ.subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype)),
+        (∀ g : Γ, ((w : Γ → ↥(HeckeEis.BinaryForm ℂ n)) g : MvPolynomial (Fin 2) ℂ)
+            = MvPolynomial.map (algebraMap ℚ ℂ)
+                (((z : Γ → ↥(HeckeEis.BinaryForm ℚ n)) g : MvPolynomial (Fin 2) ℚ))) ∧
+        Ψ (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w)
+    {ι : Type*} (y : ι → HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℚ n).comp Γ.subtype))
+    (hy : LinearIndependent ℚ y) :
+    LinearIndependent ℂ (fun i => Ψ (y i)) :=
+  solution n Γ Ψ hΨ y hy
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_mem_range_binaryFormRepSL_T_zpow_sub_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_mem_range_binaryFormRepSL_T_zpow_sub_one.lean
new file mode 100644
index 0000000000..3af22d66d5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_mem_range_binaryFormRepSL_T_zpow_sub_one.lean
@@ -0,0 +1,194 @@
+/-
+Based on Prove2Me node HeckeEis.mem_range_binaryFormRepSL_T_zpow_sub_one
+(2dbff47a-41b4-5aff-8373-e8ee56831b60) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 048befd3-7b83-5bd2-b092-84834929790f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Forms with no X₁ⁿ term lie in the image of T^h-1
+
+Theorem statement: `HeckeEis.mem_range_binaryFormRepSL_T_zpow_sub_one`
+(`2dbff47a-41b4-5aff-8373-e8ee56831b60`), by Claude, 2026-09-05.
+
+Proof: submission `048befd3-7b83-5bd2-b092-84834929790f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field of characteristic zero, let $n$ be a natural number and let $h$ be a nonzero
+integer. Here [`HeckeEis.BinaryForm K n`](def/HeckeEis_BinaryFormRep.html#L25) is the submodule
+`MvPolynomial.homogeneousSubmodule (Fin 2) K n` of polynomials in two variables $X_0, X_1$ over $K$
+that are homogeneous of degree $n$, and [`HeckeEis.binaryFormRepSL K
+n`](def/HeckeEis_BinaryFormRep.html#L61) is the representation of $SL(2,\mathbb{Z})$ on this
+submodule obtained by restricting the substitution algebra map sending $X_j$ to $\sum_i M_{ij} X_i$,
+where $M$ is the integer matrix of the group element, its entries read in $K$. For $M$ the matrix of
+$T^h$ with $T = \begin{pmatrix} 1 & 1 \\ 0 & 1\end{pmatrix}$ this is $P(X_0,X_1) \mapsto P(X_0, hX_0
++ X_1)$. The assertion is: if $P$ is an element of [`HeckeEis.BinaryForm K
+n`](def/HeckeEis_BinaryFormRep.html#L25) whose coefficient at the exponent vector `Finsupp.single 1
+n`, i.e. the coefficient of the monomial $X_1^n$, vanishes, then $P$ belongs to the range of the
+$K$-linear endomorphism `binaryFormRepSL K n (ModularGroup.T ^ h) - 1` of `BinaryForm K n`. Only
+this inclusion is asserted, not the reverse one.
+
+This is the algebraic ingredient in the parabolicity of Eichler–Shimura cocycles at the cusp
+$\infty$: the hyperplane $\{\,\mathrm{coeff}_{X_1^n} = 0\,\} = X_0 \cdot \operatorname{Sym}^{n-1}$
+of binary forms of degree $n$ is contained in the image of $\rho_n(T^h) - 1$. It is used in the
+treatment of Eichler integrals and of the parabolic condition on coefficient cocycles.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_mem_range_binaryFormRepSL_T_zpow_sub_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_mem_range_binaryFormRepSL_T_zpow_sub_one
+
+open scoped MatrixGroups
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst_X binaryFormRepSL binaryFormRepSL_apply_coe"
+namespace RangeTzpowSol
+p2m_open "HeckeEis"
+
+open MvPolynomial
+open scoped MatrixGroups
+
+variable (K : Type*) [CommRing K] (n : ℕ)
+
+theorem X_pow_mul_X_pow_mem {a b : ℕ} (h : a + b = n) :
+    (X 0 ^ a * X 1 ^ b : MvPolynomial (Fin 2) K) ∈ BinaryForm K n := by
+  rw [mem_homogeneousSubmodule]
+  have := ((isHomogeneous_X K (0 : Fin 2)).pow a).mul ((isHomogeneous_X K (1 : Fin 2)).pow b)
+  convert this using 1
+  omega
+
+noncomputable def mono (b : ℕ) : ↥(BinaryForm K n) :=
+  if hb : b ≤ n then ⟨X 0 ^ (n - b) * X 1 ^ b, X_pow_mul_X_pow_mem K n (by omega)⟩ else 0
+
+theorem coe_mono {b : ℕ} (hb : b ≤ n) :
+    (mono K n b : MvPolynomial (Fin 2) K) = X 0 ^ (n - b) * X 1 ^ b := by
+  rw [mono, dite_eq_left hb]
+
+theorem binaryFormRepSL_T_zpow_mono (h : ℤ) {b : ℕ} (hb : b ≤ n) :
+    binaryFormRepSL K n (ModularGroup.T ^ h) (mono K n b)
+      = ∑ i ∈ Finset.range (b + 1), ((b.choose i : K) * (h : K) ^ (b - i)) • mono K n i := by
+  apply Subtype.ext
+  rw [binaryFormRepSL_apply_coe, coe_mono K n hb, Submodule.coe_sum, map_mul, map_pow, map_pow,
+    binarySubst_X,
+    binarySubst_X, Fin.sum_univ_two, Fin.sum_univ_two]
+  simp only [ModularGroup.coe_T_zpow, Matrix.of_apply, Matrix.cons_val', Matrix.cons_val_zero,
+    Matrix.cons_val_one,
+    Matrix.cons_val_fin_one, Matrix.empty_val', Int.cast_one, Int.cast_zero, map_one, map_zero,
+    one_mul, zero_mul,
+    add_zero]
+  rw [add_comm (C (h : K) * X 0) (X 1), add_pow, Finset.mul_sum]
+  refine Finset.sum_congr rfl fun i hi => ?_
+  rw [Finset.mem_range] at hi
+  rw [Submodule.coe_smul, coe_mono K n (by omega : i ≤ n), smul_eq_C_mul, mul_pow, ← C_pow,
+    show n - i = (n - b) + (b - i) by omega, pow_add, map_mul, map_natCast]
+  ring
+
+variable {K : Type*} [Field K] [CharZero K]
+
+theorem mono_mem_range_T_zpow_sub_one (n : ℕ) {h : ℤ} (hh : h ≠ 0) :
+    ∀ b < n, mono K n b ∈ LinearMap.range (binaryFormRepSL K n (ModularGroup.T ^ h) - 1) := by
+  intro b
+  induction b using Nat.strong_induction_on with
+  | _ b ih =>
+    intro hb
+    have hexp := binaryFormRepSL_T_zpow_mono K n h (b := b + 1) (by omega)
+    rw [Finset.sum_range_succ, Finset.sum_range_succ, Nat.choose_self, Nat.sub_self, pow_zero,
+      Nat.cast_one, one_mul,
+      one_smul, Nat.choose_succ_self_right, Nat.add_sub_cancel_left, pow_one] at hexp
+    have hmem : (binaryFormRepSL K n (ModularGroup.T ^ h) - 1) (mono K n (b + 1))
+        ∈ LinearMap.range (binaryFormRepSL K n (ModularGroup.T ^ h) - 1) := LinearMap.mem_range_self
+          _ _
+    rw [LinearMap.sub_apply, Module.End.one_apply, hexp, add_sub_cancel_right] at hmem
+    have hsum : ∑ i ∈ Finset.range b, (((b + 1).choose i : K) * (h : K) ^ (b + 1 - i)) • mono K n i
+        ∈ LinearMap.range (binaryFormRepSL K n (ModularGroup.T ^ h) - 1) :=
+      Submodule.sum_mem _ fun i hi => by
+        have hib := Finset.mem_range.mp hi
+        exact Submodule.smul_mem _ _ (ih i hib (by omega))
+    have hcb : (((b + 1 : ℕ) : K) * (h : K)) ≠ 0 :=
+      mul_ne_zero (Nat.cast_ne_zero.mpr (Nat.succ_ne_zero b)) (Int.cast_ne_zero.mpr hh)
+    have key := Submodule.sub_mem _ hmem hsum
+    rw [add_sub_cancel_left] at key
+    exact (Submodule.smul_mem_iff _ hcb).mp key
+
+end HeckeEis.RangeTzpowSol
+
+open _root_.HeckeEis _root_.P2MW.S_HeckeEis_mem_range_binaryFormRepSL_T_zpow_sub_one.HeckeEis
+  HeckeEis.RangeTzpowSol MvPolynomial in
+theorem solution {K : Type*} [Field K] [CharZero K] (n : ℕ) {h : ℤ}
+    (hh : h ≠ 0) (P : ↥(HeckeEis.BinaryForm K n))
+    (hP : AddMonoidAlgebra.coeff (P : MvPolynomial (Fin 2) K) (Finsupp.single 1 n) = 0) :
+    P ∈ LinearMap.range (HeckeEis.binaryFormRepSL K n (ModularGroup.T ^ h) - 1) := by
+  classical
+  have hhom : (P : MvPolynomial (Fin 2) K).IsHomogeneous n := (mem_homogeneousSubmodule n _).mp P.2
+  have hdeg : ∀ d ∈ (P : MvPolynomial (Fin 2) K).support, d 0 + d 1 = n ∧ d 1 < n := by
+    intro d hd
+    have hne := mem_support_iff.mp hd
+    have hdn : d.degree = n := by
+      by_contra hc
+      exact hne (hhom.coeff_eq_zero hc)
+    rw [Finsupp.degree_eq_sum, Fin.sum_univ_two] at hdn
+    refine ⟨hdn, lt_of_le_of_ne (by omega) fun h1 => hne ?_⟩
+    have : d = Finsupp.single 1 n := by
+      ext i
+      fin_cases i
+      · simp
+        omega
+      · simpa using h1
+    rw [this]
+    exact hP
+  have hrepr : P = ∑ d ∈ (P : MvPolynomial (Fin 2) K).support,
+      AddMonoidAlgebra.coeff (P : MvPolynomial (Fin 2) K) d • mono K n (d 1) := by
+    apply Subtype.ext
+    rw [Submodule.coe_sum]
+    conv_lhs => rw [(P : MvPolynomial (Fin 2) K).as_sum]
+    refine Finset.sum_congr rfl fun d hd => ?_
+    obtain ⟨hdn, hd1⟩ := hdeg d hd
+    rw [Submodule.coe_smul, coe_mono K n hd1.le, monomial_eq, smul_eq_C_mul,
+      Finsupp.prod_fintype _ _ (fun i => pow_zero _), Fin.prod_univ_two, show n - d 1 = d 0 by
+        omega]
+  rw [hrepr]
+  exact Submodule.sum_mem _ fun d hd => Submodule.smul_mem _ _ (mono_mem_range_T_zpow_sub_one n hh _
+    (hdeg d hd).2)
+
+end
+
+end S_HeckeEis_mem_range_binaryFormRepSL_T_zpow_sub_one
+end P2MW
+export P2MW.S_HeckeEis_mem_range_binaryFormRepSL_T_zpow_sub_one (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.mem_range_binaryFormRepSL_T_zpow_sub_one {K : Type*} [Field K] [CharZero K] (n : ℕ)
+    {h : ℤ}
+    (hh : h ≠ 0) (P : ↥(HeckeEis.BinaryForm K n))
+    (hP : AddMonoidAlgebra.coeff (P : MvPolynomial (Fin 2) K) (Finsupp.single 1 n) = 0) :
+    P ∈ LinearMap.range (HeckeEis.binaryFormRepSL K n (ModularGroup.T ^ h) - 1) :=
+  solution n hh P hP
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_mem_span_range_coeffH1par_map_rat_complex.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_mem_span_range_coeffH1par_map_rat_complex.lean
new file mode 100644
index 0000000000..d6762c477c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_mem_span_range_coeffH1par_map_rat_complex.lean
@@ -0,0 +1,601 @@
+/-
+Based on Prove2Me node HeckeEis.mem_span_range_coeffH1par_map_rat_complex
+(dc7fa376-1f62-5cff-8bf9-4f6c2687e89a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d3a93073-195c-5ccb-98b6-6aab8e9e3f90
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Basic.Complex.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Gamma0CoeffCohomology
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_BinaryFormRep
+
+import Mathlib.Algebra.MvPolynomial.Monad
+import Mathlib.Analysis.CStarAlgebra.Classes
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Rational classes span parabolic cohomology over ℂ
+
+Theorem statement: `HeckeEis.mem_span_range_coeffH1par_map_rat_complex`
+(`dc7fa376-1f62-5cff-8bf9-4f6c2687e89a`), by Claude, 2026-09-05.
+
+Proof: submission `d3a93073-195c-5ccb-98b6-6aab8e9e3f90`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $n \in \mathbb{N}$ and a finitely generated subgroup $\Gamma \le \mathrm{SL}_2(\mathbb{Z})$. For
+a commutative ring $K$, let $\rho_{K}$ denote the representation of $\Gamma$ on the space
+[`HeckeEis.BinaryForm K n`](def/HeckeEis_BinaryFormRep.html#L25) of degree-$n$ homogeneous
+polynomials in two variables over $K$ obtained by restricting to $\Gamma$ the substitution action of
+$\mathrm{SL}_2(\mathbb{Z})$ given by
+[`HeckeEis.binaryFormRepSL`](def/HeckeEis_BinaryFormRep.html#L61). Here
+[`HeckeEis.coeffH1par`](def/Gamma0CoeffCohomology.html#L100) $\rho_K$ is the quotient of the
+$K$-module of parabolic cocycles — functions $z : \Gamma \to$ `BinaryForm K n` with $z(gh) = z(g) +
+\rho_K(g)(z(h))$ and with $z(\gamma) \in \mathrm{range}(\rho_K(\gamma) - 1)$ whenever the trace of
+$\gamma$, viewed as an integer matrix, satisfies $\mathrm{tr}(\gamma)^2 = 4$ — by the submodule of
+those parabolic cocycles that are coboundaries, and `coeffH1parMk` is the quotient map. Assume given
+an additive homomorphism $\Psi$ from `coeffH1par` $\rho_{\mathbb{Q}}$ to `coeffH1par`
+$\rho_{\mathbb{C}}$ with the following compatibility at cochain level: for every rational parabolic
+cocycle $z$ there is a complex parabolic cocycle $w$ such that for all $g \in \Gamma$ the polynomial
+$w(g)$ is the image of $z(g)$ under coefficientwise application of $\mathbb{Q} \to \mathbb{C}$, and
+$\Psi$ sends the class of $z$ to the class of $w$. The conclusion is that every element $X$ of
+`coeffH1par` $\rho_{\mathbb{C}}$ lies in the $\mathbb{C}$-span of the range of $\Psi$.
+
+This is the statement that the parabolic cohomology $H^1_{\mathrm{par}}(\Gamma, \mathrm{Sym}^n)$
+with complex coefficients is spanned over $\mathbb{C}$ by the image of its rational counterpart, in
+the concrete model where the coefficient module consists of binary forms acted on by substitution.
+It is used in the construction of a basis of the complex parabolic cohomology coming from the
+integral, hence rational, classes
+([`HeckeEis.exists_basis_coeffH1par_int_complex`]
+(thm.html#HeckeEis.exists_basis_coeffH1par_int_complex)).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_mem_span_range_coeffH1par_map_rat_complex.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HeckeEis_mem_span_range_coeffH1par_map_rat_complex
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff IsParabolicCocycle \
+  coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff"
+namespace GenAux
+p2m_open "HeckeEis"
+
+variable {G : Type*} [Group G] {K : Type*} [CommRing K] {V : Type*} [AddCommGroup V] [Module K V]
+
+theorem coeffCocycles_apply_one {ρ : Representation K G V} {z : G → V} (hz : z ∈ coeffCocycles ρ) :
+    z 1 = 0 := by
+  have h := hz 1 1
+  rw [mul_one, map_one, Module.End.one_apply] at h
+  have : z 1 + z 1 = z 1 + 0 := by rw [add_zero]; exact h.symm
+  exact add_left_cancel this
+
+theorem coeffCocycles_apply_inv {ρ : Representation K G V} {z : G → V} (hz : z ∈ coeffCocycles ρ)
+    (g : G) :
+    z g⁻¹ = -(ρ g⁻¹ (z g)) := by
+  have h := hz g⁻¹ g
+  rw [inv_mul_cancel, coeffCocycles_apply_one hz] at h
+  exact eq_neg_of_add_eq_zero_left h.symm
+
+theorem mem_of_mem_coeffCocycles_of_closure_eq_top {ρ : Representation K G V} {z : G → V}
+    (hz : z ∈ coeffCocycles ρ)
+    (M : AddSubgroup V) (hM : ∀ (g : G) (v : V), v ∈ M → ρ g v ∈ M) {s : Set G}
+    (hs : Subgroup.closure s = ⊤)
+    (h : ∀ g ∈ s, z g ∈ M) (g : G) : z g ∈ M := by
+  let H : Subgroup G :=
+    { carrier := {g | z g ∈ M}
+      one_mem' := by
+        change z 1 ∈ M
+        rw [coeffCocycles_apply_one hz]; exact M.zero_mem
+      mul_mem' := by
+        intro a b ha hb
+        change z (a * b) ∈ M
+        rw [hz a b]
+        exact M.add_mem ha (hM a _ hb)
+      inv_mem' := by
+        intro a ha
+        change z a⁻¹ ∈ M
+        rw [coeffCocycles_apply_inv hz]
+        exact M.neg_mem (hM _ _ ha) }
+  have hle : (⊤ : Subgroup G) ≤ H := by
+    rw [← hs, Subgroup.closure_le]
+    exact h
+  exact hle (Subgroup.mem_top g)
+
+theorem coeffCocycles_eq_of_eqOn {ρ : Representation K G V} {z z' : G → V}
+    (hz : z ∈ coeffCocycles ρ) (hz' : z' ∈ coeffCocycles ρ)
+    {s : Set G} (hs : Subgroup.closure s = ⊤) (h : ∀ g ∈ s, z g = z' g) : z = z' := by
+  have hd : z - z' ∈ coeffCocycles ρ := Submodule.sub_mem _ hz hz'
+  funext g
+  have := mem_of_mem_coeffCocycles_of_closure_eq_top hd ⊥ (fun g v hv => by
+    rw [AddSubgroup.mem_bot] at hv ⊢; rw [hv, map_zero]) hs (fun g hg => by
+    rw [AddSubgroup.mem_bot, Pi.sub_apply, h g hg, sub_self]) g
+  rw [AddSubgroup.mem_bot, Pi.sub_apply] at this
+  exact sub_eq_zero.mp this
+
+end HeckeEis.GenAux
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff IsParabolicCocycle \
+  coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff"
+namespace CoeffMapAux
+p2m_open "HeckeEis"
+
+open MvPolynomial
+open scoped MatrixGroups
+
+variable {R R' : Type*} [CommRing R] [CommRing R']
+
+theorem binarySubst_eq_bind₁ (S : Type*) [CommRing S] (M : Matrix (Fin 2) (Fin 2) ℤ)
+    (P : MvPolynomial (Fin 2) S) :
+    binarySubst S M P = bind₁ (fun j => ∑ i : Fin 2, C ((M i j : ℤ) : S) * X i) P := by
+  rw [binarySubst, aeval_eq_bind₁]
+
+theorem map_binarySubst_int (φ : ℤ →+* R) (M : Matrix (Fin 2) (Fin 2) ℤ)
+    (P : MvPolynomial (Fin 2) ℤ) :
+    MvPolynomial.map φ (binarySubst ℤ M P) = binarySubst R M (MvPolynomial.map φ P) := by
+  have key : (MvPolynomial.map φ).comp (binarySubst ℤ M : MvPolynomial (Fin 2) ℤ →ₐ[ℤ] MvPolynomial
+    (Fin 2) ℤ).toRingHom
+      = (binarySubst R M : MvPolynomial (Fin 2) R →ₐ[R] MvPolynomial (Fin 2) R).toRingHom.comp
+        (MvPolynomial.map φ) :=
+    MvPolynomial.ringHom_ext (fun a => by simp []) (fun j => by simp [binarySubst_X])
+  exact RingHom.congr_fun key P
+
+def substCoeff (M : Matrix (Fin 2) (Fin 2) ℤ) (d d' : Fin 2 →₀ ℕ) : ℤ :=
+  AddMonoidAlgebra.coeff (binarySubst ℤ M (monomial d' 1)) d
+
+theorem binarySubst_monomial_one (M : Matrix (Fin 2) (Fin 2) ℤ) (d' : Fin 2 →₀ ℕ) :
+    binarySubst R M (monomial d' 1) = MvPolynomial.map (Int.castRingHom R) (binarySubst ℤ M
+      (monomial d' 1)) := by
+  rw [map_binarySubst_int, map_monomial, (Int.castRingHom R).map_one]
+
+theorem coeff_binarySubst (M : Matrix (Fin 2) (Fin 2) ℤ) (P : MvPolynomial (Fin 2) R)
+    (d : Fin 2 →₀ ℕ) :
+    AddMonoidAlgebra.coeff (binarySubst R M P) d =
+      ∑ d' ∈ P.support, (substCoeff M d d' : R) * AddMonoidAlgebra.coeff P d' := by
+  conv_lhs => rw [P.as_sum, map_sum, coeff_sum]
+  refine Finset.sum_congr rfl fun d' _ => ?_
+  rw [show monomial d' (AddMonoidAlgebra.coeff P d') =
+    C (AddMonoidAlgebra.coeff P d') * monomial d' 1 by rw [C_mul_monomial,
+      mul_one], map_mul, binarySubst_C,
+    coeff_C_mul, binarySubst_monomial_one, coeff_map, substCoeff, mul_comm]
+  rfl
+
+variable (f : R →+ R')
+
+def pushCoeff (P : MvPolynomial (Fin 2) R) : MvPolynomial (Fin 2) R' :=
+  ∑ d ∈ P.support, monomial d (f (AddMonoidAlgebra.coeff P d))
+
+@[scoped simp] theorem coeff_pushCoeff (P : MvPolynomial (Fin 2) R) (d : Fin 2 →₀ ℕ) :
+    AddMonoidAlgebra.coeff (pushCoeff f P) d = f (AddMonoidAlgebra.coeff P d) := by
+  classical
+  rw [pushCoeff, coeff_sum]
+  simp only [coeff_monomial]
+  rw [Finset.sum_ite_eq']
+  split_ifs with h
+  · rfl
+  · rw [notMem_support_iff.mp h, map_zero]
+
+theorem support_pushCoeff (P : MvPolynomial (Fin 2) R) : (pushCoeff f P).support ⊆ P.support := by
+  intro d hd
+  rw [mem_support_iff, coeff_pushCoeff] at hd
+  rw [mem_support_iff]
+  intro h; exact hd (by rw [h, map_zero])
+
+theorem pushCoeff_mem (n : ℕ) {P : MvPolynomial (Fin 2) R} (hP : P ∈ BinaryForm R n) :
+    pushCoeff f P ∈ BinaryForm R' n := by
+  rw [mem_homogeneousSubmodule] at hP ⊢
+  intro d hd
+  exact hP (mem_support_iff.mp (support_pushCoeff f P (mem_support_iff.mpr hd)))
+
+theorem pushCoeff_add (P Q : MvPolynomial (Fin 2) R) :
+    pushCoeff f (P + Q) = pushCoeff f P + pushCoeff f Q := by
+  ext d; simp
+
+theorem pushCoeff_sub (P Q : MvPolynomial (Fin 2) R) :
+    pushCoeff f (P - Q) = pushCoeff f P - pushCoeff f Q := by
+  ext d; simp
+
+theorem pushCoeff_zero : pushCoeff f (0 : MvPolynomial (Fin 2) R) = 0 := by
+  ext d; simp
+
+theorem eq_pushCoeff_iff (P : MvPolynomial (Fin 2) R) (Q : MvPolynomial (Fin 2) R') :
+    Q = pushCoeff f P ↔ ∀ d, AddMonoidAlgebra.coeff Q d = f (AddMonoidAlgebra.coeff P d) := by
+  constructor
+  · rintro rfl d; exact coeff_pushCoeff f P d
+  · intro h; ext d; rw [h d, coeff_pushCoeff]
+
+theorem pushCoeff_binarySubst (M : Matrix (Fin 2) (Fin 2) ℤ) (P : MvPolynomial (Fin 2) R) :
+    pushCoeff f (binarySubst R M P) = binarySubst R' M (pushCoeff f P) := by
+  classical
+  ext d
+  rw [coeff_pushCoeff, coeff_binarySubst, coeff_binarySubst, map_sum]
+  rw [Finset.sum_subset (support_pushCoeff f P)]
+  · refine Finset.sum_congr rfl fun d' _ => ?_
+    rw [coeff_pushCoeff, ← zsmul_eq_mul, ← zsmul_eq_mul, map_zsmul]
+  · intro d' _ hd'
+    rw [notMem_support_iff.mp hd', mul_zero]
+
+def pushForm (n : ℕ) (P : ↥(BinaryForm R n)) :
+    ↥(BinaryForm R' n) := ⟨pushCoeff f P, pushCoeff_mem f n P.2⟩
+
+@[scoped simp] theorem coe_pushForm (n : ℕ) (P : ↥(BinaryForm R n)) :
+    ((pushForm f n P : ↥(BinaryForm R' n)) : MvPolynomial (Fin 2) R') = pushCoeff f P := rfl
+
+theorem pushForm_add (n : ℕ) (P Q : ↥(BinaryForm R n)) :
+    pushForm f n (P + Q) = pushForm f n P + pushForm f n Q :=
+  Subtype.ext (by simp [pushCoeff_add])
+
+theorem pushForm_sub (n : ℕ) (P Q : ↥(BinaryForm R n)) :
+    pushForm f n (P - Q) = pushForm f n P - pushForm f n Q :=
+  Subtype.ext (by simp [pushCoeff_sub])
+
+theorem pushForm_zero (n : ℕ) :
+    pushForm f n (0 : ↥(BinaryForm R n)) = 0 := Subtype.ext (by simp [pushCoeff_zero])
+
+theorem pushForm_binaryFormRepSL (n : ℕ) (g : SL(2, ℤ)) (P : ↥(BinaryForm R n)) :
+    pushForm f n (binaryFormRepSL R n g P) = binaryFormRepSL R' n g (pushForm f n P) :=
+  Subtype.ext (by simp [pushCoeff_binarySubst])
+
+section Cocycles
+
+variable {Γ : Subgroup SL(2, ℤ)} (n : ℕ)
+
+theorem pushForm_comp_mem_coeffCocycles {z : Γ → ↥(BinaryForm R n)}
+    (hz : z ∈ coeffCocycles ((binaryFormRepSL R n).comp Γ.subtype)) :
+    (fun g => pushForm f n (z g)) ∈ coeffCocycles ((binaryFormRepSL R' n).comp Γ.subtype) := by
+  intro g h
+  change pushForm f n (z (g * h)) = pushForm f n (z g) + binaryFormRepSL R' n ((g : Γ) : SL(2, ℤ))
+    (pushForm f n (z h))
+  rw [hz g h, pushForm_add, ← pushForm_binaryFormRepSL]
+  rfl
+
+theorem isParabolicCocycle_pushForm_comp {z : Γ → ↥(BinaryForm R n)}
+    (hz : IsParabolicCocycle ((binaryFormRepSL R n).comp Γ.subtype) z) :
+    IsParabolicCocycle ((binaryFormRepSL R' n).comp Γ.subtype) (fun g => pushForm f n (z g)) := by
+  intro γ hγ
+  obtain ⟨u, hu⟩ := hz γ hγ
+  refine ⟨pushForm f n u, ?_⟩
+  rw [LinearMap.sub_apply, Module.End.one_apply] at hu ⊢
+  change binaryFormRepSL R n (γ : SL(2, ℤ)) u - u = z γ at hu
+  change binaryFormRepSL R' n (γ : SL(2, ℤ)) (pushForm f n u) - pushForm f n u = pushForm f n (z γ)
+  rw [← hu, pushForm_sub, pushForm_binaryFormRepSL]
+
+theorem pushForm_comp_mem_coeffParabolicCocycles {z : Γ → ↥(BinaryForm R n)}
+    (hz : z ∈ coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype)) :
+    (fun g => pushForm f n (z g)) ∈ coeffParabolicCocycles ((binaryFormRepSL R' n).comp Γ.subtype)
+      :=
+  ⟨pushForm_comp_mem_coeffCocycles f n hz.1, isParabolicCocycle_pushForm_comp f n hz.2⟩
+
+theorem pushForm_comp_mem_coeffCoboundaries {z : Γ → ↥(BinaryForm R n)}
+    (hz : z ∈ coeffCoboundaries ((binaryFormRepSL R n).comp Γ.subtype)) :
+    (fun g => pushForm f n (z g)) ∈ coeffCoboundaries ((binaryFormRepSL R' n).comp Γ.subtype) := by
+  obtain ⟨v, hv⟩ := (mem_coeffCoboundaries_iff _ _).mp hz
+  rw [mem_coeffCoboundaries_iff]
+  refine ⟨pushForm f n v, funext fun g => ?_⟩
+  have h := congrFun hv g
+  change binaryFormRepSL R n (g : SL(2, ℤ)) v - v = z g at h
+  change binaryFormRepSL R' n (g : SL(2, ℤ)) (pushForm f n v) - pushForm f n v = pushForm f n (z g)
+  rw [← h, pushForm_sub, pushForm_binaryFormRepSL]
+
+def pushPar : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))
+    →+ ↥(coeffParabolicCocycles ((binaryFormRepSL R' n).comp Γ.subtype)) where
+  toFun z := ⟨fun g => pushForm f n (z.1 g), pushForm_comp_mem_coeffParabolicCocycles f n z.2⟩
+  map_zero' := by
+    apply Subtype.ext; funext g
+    change pushForm f n ((0 : Γ → ↥(BinaryForm R n)) g) = 0
+    rw [Pi.zero_apply, pushForm_zero]
+  map_add' z w := by
+    apply Subtype.ext; funext g
+    change pushForm f n (z.1 g + w.1 g) = pushForm f n (z.1 g) + pushForm f n (w.1 g)
+    rw [pushForm_add]
+
+@[scoped simp] theorem pushPar_apply_coe (z : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp
+  Γ.subtype))) (g : Γ) :
+    (((pushPar f n z).1 g : ↥(BinaryForm R' n)) : MvPolynomial (Fin 2) R') = pushCoeff f (z.1 g) :=
+      rfl
+
+theorem pushPar_apply_val (z : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype)))
+    (g : Γ) :
+    (pushPar f n z).1 g = pushForm f n (z.1 g) := rfl
+
+theorem mk_eq_mk_iff {S : Type*} [CommRing S]
+    (a b : ↥(coeffParabolicCocycles ((binaryFormRepSL S n).comp Γ.subtype))) :
+    coeffH1parMk _ a = coeffH1parMk _ b ↔
+      ((a - b : ↥(coeffParabolicCocycles ((binaryFormRepSL S n).comp Γ.subtype))).1
+        ∈ coeffCoboundaries ((binaryFormRepSL S n).comp Γ.subtype)) := by
+  rw [← sub_eq_zero, ← map_sub, coeffH1parMk_eq_zero_iff]
+
+theorem pushPar_sub (a b : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))) :
+    pushPar f n (a - b) = pushPar f n a - pushPar f n b :=
+  map_sub (pushPar f n) a b
+
+theorem mk_pushPar_congr {a b : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))}
+    (h : coeffH1parMk _ a = coeffH1parMk _ b) :
+    coeffH1parMk _ (pushPar f n a) = coeffH1parMk _ (pushPar f n b) := by
+  rw [mk_eq_mk_iff] at h ⊢
+  rw [← pushPar_sub]
+  exact pushForm_comp_mem_coeffCoboundaries f n h
+
+def pushH1par :
+    coeffH1par ((binaryFormRepSL R n).comp Γ.subtype) →+
+      coeffH1par ((binaryFormRepSL R' n).comp Γ.subtype) where
+  toFun x := coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) x))
+  map_zero' := by
+    have h0 : coeffH1parMk _ (Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp
+      Γ.subtype)) 0)
+        = coeffH1parMk _ (0 : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))) :=
+          by
+      rw [Function.surjInv_eq (coeffH1parMk_surjective _), map_zero]
+    change coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) 0)) = 0
+    rw [mk_pushPar_congr f n h0, map_zero, map_zero]
+  map_add' x y := by
+    have hxy : coeffH1parMk _ (Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp
+      Γ.subtype)) (x + y))
+        = coeffH1parMk _ (Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp
+          Γ.subtype)) x
+            + Function.surjInv (coeffH1parMk_surjective ((binaryFormRepSL R n).comp Γ.subtype)) y)
+              := by
+      rw [map_add, Function.surjInv_eq (coeffH1parMk_surjective _), Function.surjInv_eq
+        (coeffH1parMk_surjective _),
+        Function.surjInv_eq (coeffH1parMk_surjective _)]
+    change coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) (x + y))) = _
+    rw [mk_pushPar_congr f n hxy, map_add, map_add]
+
+theorem pushH1par_mk (z : ↥(coeffParabolicCocycles ((binaryFormRepSL R n).comp Γ.subtype))) :
+    pushH1par f n (coeffH1parMk _ z) = coeffH1parMk _ (pushPar f n z) := by
+  change coeffH1parMk _ (pushPar f n (Function.surjInv (coeffH1parMk_surjective _) (coeffH1parMk _
+    z))) = _
+  apply mk_pushPar_congr
+  exact Function.surjInv_eq (coeffH1parMk_surjective _) _
+
+end Cocycles
+
+end HeckeEis.CoeffMapAux
+end
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff IsParabolicCocycle \
+  coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff"
+namespace CoeffMapAux
+p2m_open "HeckeEis"
+
+open MvPolynomial
+open scoped MatrixGroups
+
+theorem pushCoeff_ringHom_eq_map {R R' : Type*} [CommRing R] [CommRing R'] (φ : R →+* R')
+    (P : MvPolynomial (Fin 2) R) :
+    pushCoeff φ.toAddMonoidHom P = MvPolynomial.map φ P := by
+  ext d
+  rw [coeff_pushCoeff, coeff_map]
+  rfl
+
+end HeckeEis.CoeffMapAux
+
+noncomputable section
+
+namespace HeckeEis
+p2m_export "HeckeEis" "BinaryForm binarySubst binarySubst_X binarySubst_C binaryFormRepSL \
+  coeffCocycles coeffCoboundaries mem_coeffCoboundaries_iff IsParabolicCocycle \
+  coeffParabolicCocycles coeffH1par coeffH1parMk coeffH1parMk_surjective coeffH1parMk_eq_zero_iff"
+namespace QCAux
+p2m_open "HeckeEis"
+
+open MvPolynomial HeckeEis.CoeffMapAux HeckeEis.GenAux
+open scoped MatrixGroups
+
+abbrev ιQC : ℚ →+ ℂ := (algebraMap ℚ ℂ).toAddMonoidHom
+
+abbrev BQC := Module.Basis.ofVectorSpace ℚ ℂ
+
+abbrev πQC (α : Module.Basis.ofVectorSpaceIndex ℚ ℂ) : ℂ →+ ℚ := ((BQC).coord α).toAddMonoidHom
+
+variable (n : ℕ)
+
+theorem coe_pushForm_ιQC (P : ↥(BinaryForm ℚ n)) :
+    ((pushForm ιQC n P : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) = MvPolynomial.map (algebraMap
+      ℚ ℂ) P := by
+  rw [coe_pushForm]; exact pushCoeff_ringHom_eq_map _ _
+
+theorem pushForm_π_smul_ι (α : Module.Basis.ofVectorSpaceIndex ℚ ℂ) (c : ℂ) (Q : ↥(BinaryForm ℚ n))
+    :
+    pushForm (πQC α) n (c • pushForm ιQC n Q) = (BQC.coord α c) • Q := by
+  apply Subtype.ext
+  ext d
+  simp only [coe_pushForm, coeff_pushCoeff, Submodule.coe_smul, coeff_smul, smul_eq_mul]
+  change (BQC.coord α) (c * (algebraMap ℚ ℂ)
+    (AddMonoidAlgebra.coeff (Q : MvPolynomial (Fin 2) ℚ) d)) = _
+  rw [mul_comm, ← Algebra.smul_def, LinearMap.map_smul, smul_eq_mul, mul_comm]
+
+theorem sum_smul_pushForm_π (P : ↥(BinaryForm ℂ n))
+    (A : Finset (Module.Basis.ofVectorSpaceIndex ℚ ℂ))
+    (hA : ∀ d ∈ (P : MvPolynomial (Fin 2) ℂ).support,
+      (BQC.repr (AddMonoidAlgebra.coeff (P : MvPolynomial (Fin 2) ℂ) d)).support ⊆ A) :
+    ∑ α ∈ A, (BQC α : ℂ) • pushForm ιQC n (pushForm (πQC α) n P) = P := by
+  classical
+  apply Subtype.ext
+  ext d
+  rw [Submodule.coe_sum, coeff_sum]
+  simp only [Submodule.coe_smul, coeff_smul, coe_pushForm, coeff_pushCoeff, smul_eq_mul]
+  by_cases hd : d ∈ (P : MvPolynomial (Fin 2) ℂ).support
+  · set x : ℂ := AddMonoidAlgebra.coeff (P : MvPolynomial (Fin 2) ℂ) d
+    have hx := BQC.linearCombination_repr x
+    rw [Finsupp.linearCombination_apply,
+      Finsupp.sum_of_support_subset (BQC.repr x) (hA d hd) (fun i a => a • (BQC i : ℂ)) (fun i _ =>
+      zero_smul ℚ _)] at hx
+    conv_rhs => rw [← hx]
+    refine Finset.sum_congr rfl fun α _ => ?_
+    change (BQC α : ℂ) * (algebraMap ℚ ℂ) (BQC.coord α x) = (BQC.repr x α) • (BQC α : ℂ)
+    rw [Algebra.smul_def, mul_comm]
+    rfl
+  · rw [notMem_support_iff.mp hd]
+    refine Finset.sum_eq_zero fun α _ => ?_
+    change (BQC α : ℂ) * (algebraMap ℚ ℂ) ((BQC.coord α) (0 : ℂ)) = 0
+    rw [map_zero, map_zero, mul_zero]
+
+variable {Γ : Subgroup SL(2, ℤ)}
+
+theorem exists_eq_sum_smul_pushPar (s : Finset Γ) (hs : Subgroup.closure (s : Set Γ) = ⊤)
+    (Z : ↥(coeffParabolicCocycles ((binaryFormRepSL ℂ n).comp Γ.subtype))) :
+    ∃ A : Finset (Module.Basis.ofVectorSpaceIndex ℚ ℂ),
+      Z = ∑ α ∈ A, (BQC α : ℂ) • pushPar ιQC n (pushPar (πQC α) n Z) := by
+  classical
+  let A : Finset (Module.Basis.ofVectorSpaceIndex ℚ ℂ) :=
+    s.biUnion fun g => ((Z.1 g : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ).support.biUnion fun d
+      =>
+      (BQC.repr (AddMonoidAlgebra.coeff
+        ((Z.1 g : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) d)).support
+  refine ⟨A, Subtype.ext ?_⟩
+  set T : ↥(coeffParabolicCocycles ((binaryFormRepSL ℂ n).comp Γ.subtype)) :=
+    ∑ α ∈ A, (BQC α : ℂ) • pushPar ιQC n (pushPar (πQC α) n Z) with hT
+  refine coeffCocycles_eq_of_eqOn Z.2.1 T.2.1 hs fun g hg => ?_
+  rw [hT]
+  rw [Submodule.coe_sum, Finset.sum_apply]
+  simp only [Submodule.coe_smul, Pi.smul_apply, pushPar_apply_val]
+  symm
+  apply sum_smul_pushForm_π
+  intro d hd
+  exact Finset.subset_biUnion_of_mem (fun d => (BQC.repr (AddMonoidAlgebra.coeff
+    ((Z.1 g : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) d)).support) hd
+    |>.trans (Finset.subset_biUnion_of_mem (fun g => ((Z.1 g : ↥(BinaryForm ℂ n)) : MvPolynomial
+      (Fin 2) ℂ).support.biUnion fun d =>
+      (BQC.repr (AddMonoidAlgebra.coeff
+        ((Z.1 g : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) d)).support) hg)
+
+variable (Ψ : coeffH1par ((binaryFormRepSL ℚ n).comp Γ.subtype) →+ coeffH1par ((binaryFormRepSL ℂ
+  n).comp Γ.subtype))
+  (hΨ : ∀ z : ↥(coeffParabolicCocycles ((binaryFormRepSL ℚ n).comp Γ.subtype)), ∃ w :
+    ↥(coeffParabolicCocycles ((binaryFormRepSL ℂ n).comp Γ.subtype)),
+    (∀ g : Γ, ((w : Γ → ↥(BinaryForm ℂ n)) g : MvPolynomial (Fin 2) ℂ)
+        = MvPolynomial.map (algebraMap ℚ ℂ) (((z : Γ → ↥(BinaryForm ℚ n)) g : MvPolynomial (Fin 2)
+          ℚ))) ∧
+    Ψ (coeffH1parMk _ z) = coeffH1parMk _ w)
+
+include hΨ in
+theorem Ψ_mk (z : ↥(coeffParabolicCocycles ((binaryFormRepSL ℚ n).comp Γ.subtype))) :
+    Ψ (coeffH1parMk _ z) = coeffH1parMk _ (pushPar ιQC n z) := by
+  obtain ⟨w, hw, h⟩ := hΨ z
+  rw [h]
+  congr 1
+  apply Subtype.ext; funext g; apply Subtype.ext
+  rw [hw g]
+  exact (coe_pushForm_ιQC n _).symm
+
+include hΨ in
+theorem mem_span_range (s : Finset Γ) (hs : Subgroup.closure (s : Set Γ) = ⊤)
+    (X : coeffH1par ((binaryFormRepSL ℂ n).comp Γ.subtype)) :
+    X ∈ Submodule.span ℂ (Set.range Ψ) := by
+  classical
+  obtain ⟨Z, rfl⟩ := coeffH1parMk_surjective _ X
+  obtain ⟨A, hA⟩ := exists_eq_sum_smul_pushPar n s hs Z
+  rw [hA, map_sum]
+  refine Submodule.sum_mem _ fun α _ => ?_
+  rw [map_smul]
+  refine Submodule.smul_mem _ _ (Submodule.subset_span ⟨coeffH1parMk _ (pushPar (πQC α) n Z), ?_⟩)
+  exact Ψ_mk n Ψ hΨ _
+
+include hΨ in
+theorem linearIndependent_comp {ι : Type*}
+    (y : ι → coeffH1par ((binaryFormRepSL ℚ n).comp Γ.subtype)) (hy : LinearIndependent ℚ y) :
+    LinearIndependent ℂ (fun i => Ψ (y i)) := by
+  classical
+  rw [linearIndependent_iff'] at hy ⊢
+  intro t c hc i hi
+  choose Y hY using fun i => coeffH1parMk_surjective ((binaryFormRepSL ℚ n).comp Γ.subtype) (y i)
+  have hΨy : ∀ i, Ψ (y i) = coeffH1parMk _ (pushPar ιQC n (Y i)) :=
+    fun i => by rw [← hY i, Ψ_mk n Ψ hΨ]
+  simp only [hΨy] at hc
+  simp only [← LinearMap.map_smul (coeffH1parMk ((binaryFormRepSL ℂ n).comp Γ.subtype)), ←
+    map_sum] at hc
+  rw [coeffH1parMk_eq_zero_iff] at hc
+  obtain ⟨v, hv⟩ := (mem_coeffCoboundaries_iff _ _).mp hc
+  suffices hcoord : ∀ α, BQC.coord α (c i) = 0 from (BQC.forall_coord_eq_zero_iff).mp hcoord
+  intro α
+  have hrel : (∑ j ∈ t, (BQC.coord α (c j)) • (Y j : Γ → ↥(BinaryForm ℚ n)))
+      ∈ coeffCoboundaries ((binaryFormRepSL ℚ n).comp Γ.subtype) := by
+    rw [mem_coeffCoboundaries_iff]
+    refine ⟨pushForm (πQC α) n v, funext fun g => ?_⟩
+    have h1 := congrFun hv g
+    change binaryFormRepSL ℂ n (g : SL(2, ℤ)) v - v = _ at h1
+    change binaryFormRepSL ℚ n (g : SL(2, ℤ)) (pushForm (πQC α) n v) - pushForm (πQC α) n v = _
+    rw [← pushForm_binaryFormRepSL, ← pushForm_sub, h1, Submodule.coe_sum, Finset.sum_apply,
+      Finset.sum_apply]
+    have hadd : ∀ (F : Finset ι) (G : ι → ↥(BinaryForm ℂ n)),
+        pushForm (πQC α) n (∑ j ∈ F, G j) = ∑ j ∈ F, pushForm (πQC α) n (G j) := by
+      intro F G
+      exact map_sum (⟨⟨pushForm (πQC α) n, pushForm_zero _ n⟩, pushForm_add _ n⟩ : ↥(BinaryForm ℂ n)
+        →+ ↥(BinaryForm ℚ n)) G F
+    rw [hadd]
+    refine Finset.sum_congr rfl fun j _ => ?_
+    rw [Submodule.coe_smul, Pi.smul_apply, pushPar_apply_val, pushForm_π_smul_ι]
+    rfl
+  have hzero : (∑ j ∈ t, (BQC.coord α (c j)) • y j) = 0 := by
+    have : (∑ j ∈ t, (BQC.coord α (c j)) • y j) = coeffH1parMk ((binaryFormRepSL ℚ n).comp
+      Γ.subtype) (∑ j ∈ t, (BQC.coord α (c j)) • Y j) :=
+      by
+      rw [map_sum]; exact Finset.sum_congr rfl fun j _ => by rw [map_smul, hY]
+    rw [this, coeffH1parMk_eq_zero_iff]
+    simpa [Submodule.coe_sum, Submodule.coe_smul] using hrel
+  exact hy t (fun j => BQC.coord α (c j)) hzero i hi
+
+end HeckeEis.QCAux
+end
+
+open scoped MatrixGroups in
+theorem solution (n : ℕ) (Γ : Subgroup SL(2, ℤ)) [Group.FG Γ]
+    (Ψ : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℚ n).comp Γ.subtype) →+ HeckeEis.coeffH1par
+      ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype))
+    (hΨ : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℚ n).comp Γ.subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype)),
+        (∀ g : Γ, ((w : Γ → ↥(HeckeEis.BinaryForm ℂ n)) g : MvPolynomial (Fin 2) ℂ)
+            = MvPolynomial.map (algebraMap ℚ ℂ)
+                (((z : Γ → ↥(HeckeEis.BinaryForm ℚ n)) g : MvPolynomial (Fin 2) ℚ))) ∧
+        Ψ (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w)
+    (X : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype)) :
+    X ∈ Submodule.span ℂ (Set.range Ψ) := by
+  obtain ⟨_, S, _, hS⟩ := Group.fg_iff'.mp (inferInstance : Group.FG Γ)
+  exact HeckeEis.QCAux.mem_span_range n Ψ hΨ S hS X
+
+end S_HeckeEis_mem_span_range_coeffH1par_map_rat_complex
+end P2MW
+export P2MW.S_HeckeEis_mem_span_range_coeffH1par_map_rat_complex (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem HeckeEis.mem_span_range_coeffH1par_map_rat_complex (n : ℕ) (Γ : Subgroup SL(2, ℤ))
+    [Group.FG Γ]
+    (Ψ : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℚ n).comp Γ.subtype) →+ HeckeEis.coeffH1par
+      ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype))
+    (hΨ : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℚ n).comp Γ.subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype)),
+        (∀ g : Γ, ((w : Γ → ↥(HeckeEis.BinaryForm ℂ n)) g : MvPolynomial (Fin 2) ℂ)
+            = MvPolynomial.map (algebraMap ℚ ℂ)
+                (((z : Γ → ↥(HeckeEis.BinaryForm ℚ n)) g : MvPolynomial (Fin 2) ℚ))) ∧
+        Ψ (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w)
+    (X : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp Γ.subtype)) :
+    X ∈ Submodule.span ℂ (Set.range Ψ) :=
+  solution n Γ Ψ hΨ X
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_range_eichlerShimuraMap_inf_range_conj_eq_bot.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_range_eichlerShimuraMap_inf_range_conj_eq_bot.lean
new file mode 100644
index 0000000000..23cb67591d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HeckeEis_range_eichlerShimuraMap_inf_range_conj_eq_bot.lean
@@ -0,0 +1,1547 @@
+/-
+Based on Prove2Me node HeckeEis.range_eichlerShimuraMap_inf_range_conj_eq_bot
+(08ca6524-3cdd-543d-8541-99b27558904b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9e30b8d1-025f-52ca-9dfa-6833527197e9
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HeckeEis_EichlerIntegral
+
+import Mathlib.Algebra.Ring.IsFormallyReal
+import Mathlib.Analysis.Complex.Liouville
+import Mathlib.Data.Int.Star
+import Mathlib.MeasureTheory.Integral.ExpDecay
+import Mathlib.NumberTheory.ModularForms.Bounds
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Complex_integral_modularFundamentalDomain_eq_boundary_of_hasFDerivAt
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_IsEichlerIntegral_slash
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HeckeEis_exists_isEichlerIntegral_isParabolicCocycle
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_gammaFundamentalSet_boundary_sidePairing_of_slash_eq_add
+
+/-!
+# Injectivity half of Eichler–Shimura for Γ₀(N)
+
+Theorem statement: `HeckeEis.range_eichlerShimuraMap_inf_range_conj_eq_bot`
+(`08ca6524-3cdd-543d-8541-99b27558904b`), by Claude, 2026-09-05.
+
+Proof: submission `9e30b8d1-025f-52ca-9dfa-6833527197e9`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N \ge 1$ and $n \ge 0$ be integers, and let $\rho$ denote the representation of $\Gamma_0(N)$
+obtained by restricting to $\Gamma_0(N) \subseteq \mathrm{SL}(2,\mathbb{Z})$ the action of
+$\mathrm{SL}(2,\mathbb{Z})$ on the space of binary forms of degree $n$ over $\mathbb{C}$ (the
+homogeneous polynomials of degree $n$ in two variables) by linear substitution of the variables.
+Write $H = \mathrm{HeckeEis.coeffH1par}\,\rho$ for the quotient of the module of parabolic cocycles
+— functions $z \colon \Gamma_0(N) \to \mathrm{BinaryForm}$ with $z(gh) = z(g) + \rho(g) z(h)$ and
+with $z(\gamma) \in \mathrm{range}(\rho(\gamma) - 1)$ whenever the integral matrix of $\gamma$ has
+trace squared equal to $4$ — by those parabolic cocycles that are coboundaries. Assume given a
+$\mathbb{C}$-linear map $ES$ from the cusp forms of weight $(n : \mathbb{Z}) + 2$ on $\Gamma_0(N)$
+to $H$ whose underlying function is [`HeckeEis.eichlerShimuraMap n
+N`](def/HeckeEis_EichlerIntegral.html#L114), and an additive endomorphism $\Phi$ of $H$ such that
+for every parabolic cocycle $z$ there is a parabolic cocycle $w$ with $w(g)$ equal to the
+coefficientwise complex conjugate of $z(g)$ for all $g \in \Gamma_0(N)$ and with $\Phi$ of the class
+of $z$ equal to the class of $w$. Then for cusp forms $f, g$ of weight $(n : \mathbb{Z}) + 2$ on
+$\Gamma_0(N)$, the equality $ES(f) = \Phi(ES(g))$ forces $f = 0$.
+
+This is the disjointness, or injectivity, half of the Eichler–Shimura relation: the image of the
+Eichler–Shimura map on cusp forms of weight $n+2$ meets its complex conjugate only in zero inside
+parabolic cohomology with $\mathrm{Sym}^n$ coefficients. Combined with the bound on $\dim
+H^1_{\mathrm{par}}$ by twice the dimension of the space of cusp forms, it yields the direct sum
+decomposition recorded in
+[`HeckeEis.isCompl_range_eichlerShimuraMap_range_conj`]
+(thm.html#HeckeEis.isCompl_range_eichlerShimuraMap_range_conj),
+the sole consumer of this statement.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HeckeEis_range_eichlerShimuraMap_inf_range_conj_eq_bot.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+noncomputable section privateSection
+
+open UpperHalfPlane hiding I
+open Complex MvPolynomial
+open scoped MatrixGroups ComplexConjugate ModularForm Manifold Pointwise
+
+namespace HeckeEis
+
+namespace ESDisjoint
+
+abbrev conjP : MvPolynomial (Fin 2) ℂ →+* MvPolynomial (Fin 2) ℂ := MvPolynomial.map (starRingEnd ℂ)
+
+theorem conjP_conjP (Q : MvPolynomial (Fin 2) ℂ) : conjP (conjP Q) = Q := by
+  rw [MvPolynomial.map_map]
+  have : (starRingEnd ℂ).comp (starRingEnd ℂ) = RingHom.id ℂ := by
+    ext z
+    simp
+  rw [this, MvPolynomial.map_id]
+
+theorem coeff_conjP (Q : MvPolynomial (Fin 2) ℂ) (d : Fin 2 →₀ ℕ) :
+    AddMonoidAlgebra.coeff (conjP Q) d = conj (AddMonoidAlgebra.coeff Q d) := coeff_map _ _ _
+
+theorem conjP_binarySubst (M : Matrix (Fin 2) (Fin 2) ℤ) (Q : MvPolynomial (Fin 2) ℂ) :
+    conjP (binarySubst ℂ M Q) = binarySubst ℂ M (conjP Q) := by
+  rw [binarySubst, aeval_eq_bind₁]
+  change (MvPolynomial.map (starRingEnd ℂ)) ((bind₁ _) Q) = (bind₁ _) ((MvPolynomial.map
+    (starRingEnd ℂ)) Q)
+  rw [map_bind₁]
+  have h : (fun j : Fin 2 => (MvPolynomial.map (starRingEnd ℂ)) (∑ i : Fin 2, C (((M i j : ℤ)) : ℂ)
+    * X i))
+      = fun j : Fin 2 => ∑ i : Fin 2, C (((M i j : ℤ)) : ℂ) * X i := by
+    funext j
+    simp [MvPolynomial.map_X]
+  rw [h]
+
+theorem conjP_mem {n : ℕ} {Q : MvPolynomial (Fin 2) ℂ} (hQ : Q ∈ BinaryForm ℂ n) :
+    conjP Q ∈ BinaryForm ℂ n := by
+  rw [mem_homogeneousSubmodule] at hQ ⊢
+  intro d hd
+  rw [coeff_conjP] at hd
+  exact hQ (fun h => hd (by rw [h, map_zero]))
+
+def ev (z : ℂ) (Q : MvPolynomial (Fin 2) ℂ) : ℂ := eval ![(1 : ℂ), -z] Q
+
+theorem ev_add (z : ℂ) (P Q : MvPolynomial (Fin 2) ℂ) :
+    ev z (P + Q) = ev z P + ev z Q := map_add _ _ _
+
+theorem ev_sub (z : ℂ) (P Q : MvPolynomial (Fin 2) ℂ) :
+    ev z (P - Q) = ev z P - ev z Q := map_sub _ _ _
+
+theorem eval_bind₁' (x : Fin 2 → ℂ) (h : Fin 2 → MvPolynomial (Fin 2) ℂ)
+    (Q : MvPolynomial (Fin 2) ℂ) :
+    eval x (bind₁ h Q) = eval (fun i => eval x (h i)) Q := by
+  rw [MvPolynomial.eval, eval₂Hom_bind₁]
+  rfl
+
+theorem jFactor_pow_mul_ev_smul {n : ℕ} (γ : SL(2, ℤ)) (τ : ℍ) {Q : MvPolynomial (Fin 2) ℂ}
+    (hQ : Q ∈ BinaryForm ℂ n) :
+    jFactor γ τ ^ n * ev ((γ • τ : ℍ) : ℂ) (binarySubst ℂ (γ : Matrix (Fin 2) (Fin 2) ℤ) Q) = ev τ Q
+      := by
+  have hj := jFactor_ne_zero γ τ
+  rw [mem_homogeneousSubmodule] at hQ
+  rw [ev, ev, binarySubst, aeval_eq_bind₁]
+  change jFactor γ τ ^ n * eval ![(1 : ℂ), -((γ • τ : ℍ) : ℂ)] ((bind₁ _) Q) = _
+  rw [eval_bind₁']
+  have hsm := coe_smul_mul_jFactor γ τ
+  have hdet : ((γ : Matrix (Fin 2) (Fin 2) ℤ) 0 0 : ℂ) * ((γ : Matrix (Fin 2) (Fin 2) ℤ) 1 1 : ℂ)
+      - ((γ : Matrix (Fin 2) (Fin 2) ℤ) 0 1 : ℂ) * ((γ : Matrix (Fin 2) (Fin 2) ℤ) 1 0 : ℂ) = 1
+        := by
+    have h := congrArg (fun x : ℤ => (x : ℂ)) (Matrix.SpecialLinearGroup.det_coe γ)
+    simp only [Matrix.det_fin_two, Int.cast_sub, Int.cast_mul, Int.cast_one] at h
+    exact h
+  have hpt : (fun i : Fin 2 => eval ![(1 : ℂ), -((γ • τ : ℍ) : ℂ)]
+      (∑ k : Fin 2, C (((γ : Matrix (Fin 2) (Fin 2) ℤ) k i : ℤ) : ℂ) * X k))
+      = (jFactor γ τ)⁻¹ • ![(1 : ℂ), -(τ : ℂ)] := by
+    rw [jFactor] at hsm hj ⊢
+    funext i
+    fin_cases i
+    · simp only [Fin.sum_univ_two, Fin.isValue, map_add, map_mul, eval_C, eval_X,
+        Matrix.cons_val_zero,
+        Matrix.cons_val_one, Fin.zero_eta, Pi.smul_apply, smul_eq_mul, mul_one, mul_neg]
+      field_simp
+      linear_combination -((γ : Matrix (Fin 2) (Fin 2) ℤ) 1 0 : ℂ) * hsm + hdet
+    · simp only [Fin.sum_univ_two, Fin.isValue, map_add, map_mul, eval_C, eval_X,
+        Matrix.cons_val_zero,
+        Matrix.cons_val_one, Fin.mk_one, Pi.smul_apply, smul_eq_mul, mul_one, mul_neg]
+      field_simp
+      linear_combination -((γ : Matrix (Fin 2) (Fin 2) ℤ) 1 1 : ℂ) * hsm - (τ : ℂ) * hdet
+  rw [hpt, eval_smul_of_isHomogeneous hQ, ← mul_assoc, ← mul_pow, mul_inv_cancel₀ hj, one_pow,
+    one_mul]
+
+theorem jFactor_pow_mul_ev_rep {n : ℕ} (γ : SL(2, ℤ)) (τ : ℍ) (Q : ↥(BinaryForm ℂ n)) :
+    jFactor γ τ ^ n * ev ((γ • τ : ℍ) : ℂ) ((binaryFormRepSL ℂ n γ Q : ↥(BinaryForm ℂ n)) :
+      MvPolynomial (Fin 2) ℂ)
+      = ev τ (Q : MvPolynomial (Fin 2) ℂ) := by
+  rw [binaryFormRepSL_apply_coe]
+  exact jFactor_pow_mul_ev_smul γ τ Q.2
+
+theorem jFactor_pow_mul_ev_conjP_rep {n : ℕ} (γ : SL(2, ℤ)) (τ : ℍ) (Q : ↥(BinaryForm ℂ n)) :
+    jFactor γ τ ^ n * ev ((γ • τ : ℍ) : ℂ) (conjP ((binaryFormRepSL ℂ n γ Q : ↥(BinaryForm ℂ n)) :
+      MvPolynomial (Fin 2) ℂ))
+      = ev τ (conjP (Q : MvPolynomial (Fin 2) ℂ)) := by
+  rw [binaryFormRepSL_apply_coe, conjP_binarySubst]
+  exact jFactor_pow_mul_ev_smul γ τ (conjP_mem Q.2)
+
+theorem ev_conjP_linePow (n : ℕ) (z : ℂ) :
+    ev z (conjP ((linePow n z : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ)) = (conj z - z) ^ n
+      := by
+  rw [coe_linePow, ev]
+  simp only [map_pow, map_add, map_mul, MvPolynomial.map_C, MvPolynomial.map_X, eval_C, eval_X,
+    Matrix.cons_val_zero, Matrix.cons_val_one]
+  ring
+
+def expo (n i : ℕ) : Fin 2 →₀ ℕ := Finsupp.single 0 (n - i) + Finsupp.single 1 i
+
+theorem expo_one (n i : ℕ) : expo n i 1 = i := by simp [expo]
+
+theorem expo_injective (n : ℕ) : Function.Injective (expo n) := by
+  intro i j h
+  have := congrArg (fun d => d 1) h
+  simpa [expo_one] using this
+
+theorem add_eq_of_weight {n : ℕ} {d : Fin 2 →₀ ℕ} (hd : Finsupp.weight (1 : Fin 2 → ℕ) d = n) :
+    d 0 + d 1 = n := by
+  rw [Finsupp.weight_apply, Finsupp.sum_fintype _ _ (by simp)] at hd
+  simpa [Fin.sum_univ_two] using hd
+
+theorem eq_expo_of_degree {n : ℕ} {d : Fin 2 →₀ ℕ} (hd : Finsupp.weight (1 : Fin 2 → ℕ) d = n) :
+    d = expo n (d 1) := by
+  have hsum : d 0 + d 1 = n := add_eq_of_weight hd
+  ext i
+  fin_cases i
+  · simp [expo]; omega
+  · simp [expo]
+
+theorem ev_eq_sum {n : ℕ} (z : ℂ) {Q : MvPolynomial (Fin 2) ℂ} (hQ : Q ∈ BinaryForm ℂ n) :
+    ev z Q = ∑ i ∈ Finset.range (n + 1), AddMonoidAlgebra.coeff Q (expo n i) * (-z) ^ i := by
+  rw [mem_homogeneousSubmodule] at hQ
+  rw [ev, eval_eq']
+  have hterm : ∀ d : Fin 2 →₀ ℕ, AddMonoidAlgebra.coeff Q d * ∏ i,
+      (![(1 : ℂ), -z] i) ^ d i = AddMonoidAlgebra.coeff Q d * (-z) ^ (d 1) := by
+    intro d
+    simp [Fin.prod_univ_two]
+  simp_rw [hterm]
+  have hsupp : ∀ d ∈ Q.support, d = expo n (d 1) := by
+    intro d hd
+    exact eq_expo_of_degree (hQ (mem_support_iff.mp hd))
+  have hsub : Q.support ⊆ (Finset.range (n + 1)).image (expo n) := by
+    intro d hd
+    rw [Finset.mem_image]
+    refine ⟨d 1, ?_, (hsupp d hd).symm⟩
+    have hsum : d 0 + d 1 = n := add_eq_of_weight (hQ (mem_support_iff.mp hd))
+    rw [Finset.mem_range]
+    omega
+  calc ∑ d ∈ Q.support, AddMonoidAlgebra.coeff Q d * (-z) ^ (d 1)
+      = ∑ d ∈ (Finset.range (n + 1)).image (expo n),
+          AddMonoidAlgebra.coeff Q d * (-z) ^ (d 1) := by
+        apply Finset.sum_subset hsub
+        intro d _ hd
+        rw [notMem_support_iff.mp hd, zero_mul]
+    _ = ∑ i ∈ Finset.range (n + 1),
+        AddMonoidAlgebra.coeff Q (expo n i) * (-z) ^ ((expo n i) 1) := by
+        rw [Finset.sum_image (fun i _ j _ h => expo_injective n h)]
+    _ = _ := by simp_rw [expo_one]
+
+section Laws
+
+variable {n : ℕ}
+
+theorem coe_rep_inv_rep (σ : SL(2, ℤ)) (X : ↥(BinaryForm ℂ n)) :
+    binaryFormRepSL ℂ n σ (binaryFormRepSL ℂ n σ⁻¹ X) = X := by
+  rw [← Module.End.mul_apply, ← map_mul, mul_inv_cancel, map_one, Module.End.one_apply]
+
+theorem rep_inv_rep (σ : SL(2, ℤ)) (X : ↥(BinaryForm ℂ n)) :
+    binaryFormRepSL ℂ n σ⁻¹ (binaryFormRepSL ℂ n σ X) = X := by
+  rw [← Module.End.mul_apply, ← map_mul, inv_mul_cancel, map_one, Module.End.one_apply]
+
+theorem binarySubst_inv_mul (σ : SL(2, ℤ)) (Q : MvPolynomial (Fin 2) ℂ) :
+    binarySubst ℂ ((σ⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) (binarySubst ℂ (σ : Matrix (Fin 2)
+      (Fin 2) ℤ) Q) = Q := by
+  rw [← AlgHom.comp_apply, ← binarySubst_mul, ← Matrix.SpecialLinearGroup.coe_mul, inv_mul_cancel,
+    Matrix.SpecialLinearGroup.coe_one, binarySubst_one, AlgHom.id_apply]
+
+def Edat (A B : ℍ → ↥(BinaryForm ℂ n)) (c : ↥(BinaryForm ℂ n)) (τ : ℍ) : ℂ :=
+  ev τ (conjP (A τ : MvPolynomial (Fin 2) ℂ)) - ev τ (B τ : MvPolynomial (Fin 2) ℂ) + ev τ (conjP (c
+    : MvPolynomial (Fin 2) ℂ))
+
+def Pdat (φ : ℍ → ℂ) (A B : ℍ → ↥(BinaryForm ℂ n)) (c : ↥(BinaryForm ℂ n)) (τ : ℍ) :
+    ℂ := φ τ * Edat A B c τ
+
+def trV (σ : SL(2, ℤ)) (A : ℍ → ↥(BinaryForm ℂ n)) (τ : ℍ) :
+    ↥(BinaryForm ℂ n) := binaryFormRepSL ℂ n σ⁻¹ (A (σ • τ))
+
+theorem jFactor_pow_mul_Edat_smul (σ : SL(2, ℤ)) (A B : ℍ → ↥(BinaryForm ℂ n))
+    (c : ↥(BinaryForm ℂ n)) (τ : ℍ) :
+    jFactor σ τ ^ n * Edat A B c (σ • τ) = Edat (trV σ A) (trV σ B) (binaryFormRepSL ℂ n σ⁻¹ c) τ
+      := by
+  have hA : A (σ • τ) = binaryFormRepSL ℂ n σ (trV σ A τ) := (coe_rep_inv_rep σ _).symm
+  have hB : B (σ • τ) = binaryFormRepSL ℂ n σ (trV σ B τ) := (coe_rep_inv_rep σ _).symm
+  have hc : c = binaryFormRepSL ℂ n σ (binaryFormRepSL ℂ n σ⁻¹ c) := (coe_rep_inv_rep σ _).symm
+  unfold Edat
+  conv_lhs => rw [hA, hB, hc]
+  rw [mul_add, mul_sub, jFactor_pow_mul_ev_conjP_rep, jFactor_pow_mul_ev_rep,
+    jFactor_pow_mul_ev_conjP_rep]
+
+theorem Pdat_smul (σ : SL(2, ℤ)) (φ : ℍ → ℂ) (A B : ℍ → ↥(BinaryForm ℂ n)) (c : ↥(BinaryForm ℂ n))
+    (τ : ℍ) :
+    Pdat φ A B c (σ • τ) = denom (σ : GL (Fin 2) ℝ) τ ^ 2 *
+      Pdat (φ ∣[((n : ℤ) + 2)] σ) (trV σ A) (trV σ B) (binaryFormRepSL ℂ n σ⁻¹ c) τ := by
+  have hD : denom (σ : GL (Fin 2) ℝ) τ ≠ 0 := UpperHalfPlane.denom_ne_zero _ _
+  have hj : jFactor σ τ = denom (σ : GL (Fin 2) ℝ) τ := jFactor_eq_denom σ τ
+  have hE := jFactor_pow_mul_Edat_smul σ A B c τ
+  rw [hj] at hE
+  unfold Pdat
+  rw [← hE, ModularForm.SL_slash_apply]
+  have : denom (σ : GL (Fin 2) ℝ) τ ^ (-((n : ℤ) + 2)) = (denom (σ : GL (Fin 2) ℝ) τ ^ n)⁻¹ * (denom
+    (σ : GL (Fin 2) ℝ) τ ^ 2)⁻¹ :=
+    by
+    rw [zpow_neg, ← mul_inv]
+    congr 1
+    rw [← zpow_natCast, ← zpow_natCast, ← zpow_add₀ hD]
+    norm_cast
+  rw [this]
+  field_simp
+
+variable {N : ℕ}
+
+theorem Edat_trV_of_cocycle (A B : ℍ → ↥(BinaryForm ℂ n)) (c : ↥(BinaryForm ℂ n))
+    (zA zB : CongruenceSubgroup.Gamma0 N → ↥(BinaryForm ℂ n))
+    (hA : ∀ (γ : CongruenceSubgroup.Gamma0 N) (τ : ℍ), A ((γ : SL(2, ℤ)) • τ) = zA γ +
+      binaryFormRepSL ℂ n γ (A τ))
+    (hB : ∀ (γ : CongruenceSubgroup.Gamma0 N) (τ : ℍ), B ((γ : SL(2, ℤ)) • τ) = zB γ +
+      binaryFormRepSL ℂ n γ (B τ))
+    (hcoc : ∀ γ : CongruenceSubgroup.Gamma0 N, (zA γ : MvPolynomial (Fin 2) ℂ) - conjP (zB γ :
+      MvPolynomial (Fin 2) ℂ)
+      = binarySubst ℂ ((γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) (c : MvPolynomial (Fin 2) ℂ) - c)
+    (γ : CongruenceSubgroup.Gamma0 N) (τ : ℍ) :
+    Edat (trV (γ : SL(2, ℤ)) A) (trV (γ : SL(2, ℤ)) B) (binaryFormRepSL ℂ n (γ : SL(2, ℤ))⁻¹ c) τ =
+      Edat A B c τ := by
+  unfold Edat trV
+  rw [hA, hB, map_add, map_add, rep_inv_rep, rep_inv_rep]
+  simp only [Submodule.coe_add, map_add, ev_add, binaryFormRepSL_apply_coe]
+  have h := hcoc γ
+  have h2 : conjP (zA γ : MvPolynomial (Fin 2) ℂ) - (zB γ : MvPolynomial (Fin 2) ℂ)
+      = binarySubst ℂ ((γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) (conjP (c : MvPolynomial (Fin 2)
+        ℂ)) - conjP c := by
+    have := congrArg conjP h
+    rw [map_sub, map_sub, conjP_conjP, conjP_binarySubst] at this
+    exact this
+  have h3 : conjP (binarySubst ℂ (((γ : SL(2, ℤ))⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) (zA γ :
+    MvPolynomial (Fin 2) ℂ))
+      - binarySubst ℂ (((γ : SL(2, ℤ))⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) (zB γ :
+        MvPolynomial (Fin 2) ℂ)
+      + conjP (binarySubst ℂ (((γ : SL(2, ℤ))⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) (c :
+        MvPolynomial (Fin 2) ℂ))
+      = conjP (c : MvPolynomial (Fin 2) ℂ) := by
+    rw [conjP_binarySubst, conjP_binarySubst, ← map_sub, h2, map_sub, binarySubst_inv_mul]
+    abel
+  have h4 := congrArg (ev (τ : ℂ)) h3
+  rw [ev_add, ev_sub] at h4
+  linear_combination h4
+
+theorem Pdat_smul_of_mem (φ : ℍ → ℂ)
+    (hφ : ∀ γ : CongruenceSubgroup.Gamma0 N, φ ∣[((n : ℤ) + 2)] (γ : SL(2, ℤ)) = φ)
+    (A B : ℍ → ↥(BinaryForm ℂ n)) (c : ↥(BinaryForm ℂ n))
+    (zA zB : CongruenceSubgroup.Gamma0 N → ↥(BinaryForm ℂ n))
+    (hA : ∀ (γ : CongruenceSubgroup.Gamma0 N) (τ : ℍ), A ((γ : SL(2, ℤ)) • τ) = zA γ +
+      binaryFormRepSL ℂ n γ (A τ))
+    (hB : ∀ (γ : CongruenceSubgroup.Gamma0 N) (τ : ℍ), B ((γ : SL(2, ℤ)) • τ) = zB γ +
+      binaryFormRepSL ℂ n γ (B τ))
+    (hcoc : ∀ γ : CongruenceSubgroup.Gamma0 N, (zA γ : MvPolynomial (Fin 2) ℂ) - conjP (zB γ :
+      MvPolynomial (Fin 2) ℂ)
+      = binarySubst ℂ ((γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) (c : MvPolynomial (Fin 2) ℂ) - c)
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 N) (τ : ℍ) :
+    Pdat φ A B c (γ • τ) / denom (γ : GL (Fin 2) ℝ) τ ^ 2 = Pdat φ A B c τ + 0 * (0 : ℂ) := by
+  have hD : denom (γ : GL (Fin 2) ℝ) τ ≠ 0 := UpperHalfPlane.denom_ne_zero _ _
+  rw [Pdat_smul, zero_mul, add_zero, mul_div_cancel_left₀ _ (pow_ne_zero 2 hD)]
+  have h1 := hφ ⟨γ, hγ⟩
+  have h2 := Edat_trV_of_cocycle A B c zA zB hA hB hcoc ⟨γ, hγ⟩ τ
+  simp only at h1 h2
+  unfold Pdat
+  rw [h1, h2]
+
+end Laws
+
+section Unpack
+
+variable (N : ℕ) [NeZero N] (n : ℕ)
+
+abbrev ρN : Representation ℂ (CongruenceSubgroup.Gamma0 N) ↥(BinaryForm ℂ n) :=
+  (binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype
+
+theorem unpack
+    (ES : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2) →ₗ[ℂ] coeffH1par (ρN N n))
+    (hES : ∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2), ES f = eichlerShimuraMap n N
+      f)
+    (Φ : coeffH1par (ρN N n) →+ coeffH1par (ρN N n))
+    (hΦ : ∀ z : ↥(coeffParabolicCocycles (ρN N n)), ∃ w : ↥(coeffParabolicCocycles (ρN N n)),
+        (∀ g : CongruenceSubgroup.Gamma0 N, ((w : CongruenceSubgroup.Gamma0 N → ↥(BinaryForm ℂ n)) g
+          : MvPolynomial (Fin 2) ℂ)
+            = MvPolynomial.map (starRingEnd ℂ)
+                (((z : CongruenceSubgroup.Gamma0 N → ↥(BinaryForm ℂ n)) g : MvPolynomial (Fin 2)
+                  ℂ))) ∧
+        Φ (coeffH1parMk _ z) = coeffH1parMk _ w)
+    (f g : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2)) (hfg : ES f = Φ (ES g)) :
+    ∃ (F G : ℍ → ↥(BinaryForm ℂ n)) (v : ↥(BinaryForm ℂ n)) (zF zG : CongruenceSubgroup.Gamma0 N →
+      ↥(BinaryForm ℂ n)),
+      IsEichlerIntegral n f F ∧ IsEichlerIntegral n g G ∧
+      (∀ (γ : CongruenceSubgroup.Gamma0 N) (τ : ℍ), F ((γ : SL(2, ℤ)) • τ) = zF γ + binaryFormRepSL
+        ℂ n γ (F τ)) ∧
+      (∀ (γ : CongruenceSubgroup.Gamma0 N) (τ : ℍ), G ((γ : SL(2, ℤ)) • τ) = zG γ + binaryFormRepSL
+        ℂ n γ (G τ)) ∧
+      (∀ γ : CongruenceSubgroup.Gamma0 N, (zF γ : MvPolynomial (Fin 2) ℂ) - conjP (zG γ :
+        MvPolynomial (Fin 2) ℂ)
+        = binarySubst ℂ ((γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) (v : MvPolynomial (Fin 2) ℂ) -
+          v) := by
+  obtain ⟨F₁, hF₁, hF₁e, hF₁p⟩ := HeckeEis.exists_isEichlerIntegral_isParabolicCocycle N n f
+  obtain ⟨G₁, hG₁, hG₁e, hG₁p⟩ := HeckeEis.exists_isEichlerIntegral_isParabolicCocycle N n g
+  obtain ⟨F, hF, hFe, hFp, hESf⟩ := eichlerShimuraMap_def n N f hF₁ hF₁e hF₁p
+  obtain ⟨G, hG, hGe, hGp, hESg⟩ := eichlerShimuraMap_def n N g hG₁ hG₁e hG₁p
+  set zGp : ↥(coeffParabolicCocycles (ρN N n)) := ⟨hGe.cocycle, ⟨hGe.cocycle_mem_coeffCocycles,
+    hGp⟩⟩ with hzGp
+  set zFp : ↥(coeffParabolicCocycles (ρN N n)) := ⟨hFe.cocycle, ⟨hFe.cocycle_mem_coeffCocycles,
+    hFp⟩⟩ with hzFp
+  obtain ⟨w, hw, hΦw⟩ := hΦ zGp
+  have hcl : coeffH1parMk _ zFp = coeffH1parMk _ w := by
+    rw [← hΦw, ← hESg, ← hESf, ← hES, ← hES, hfg]
+  have hcob : ((zFp - w : ↥(coeffParabolicCocycles (ρN N n))) : CongruenceSubgroup.Gamma0 N →
+    ↥(BinaryForm ℂ n))
+      ∈ coeffCoboundaries (ρN N n) := by
+    have hq : zFp - w ∈ (coeffCoboundaries (ρN N n)).comap (coeffParabolicCocycles (ρN N n)).subtype
+      :=
+      (Submodule.Quotient.eq _).mp hcl
+    exact Submodule.mem_comap.mp hq
+  obtain ⟨v, hv⟩ := (mem_coeffCoboundaries_iff _ _).mp hcob
+  refine ⟨F, G, v, hFe.cocycle, hGe.cocycle, hF, hG, fun γ τ => hFe.apply_smul γ τ, fun γ τ =>
+    hGe.apply_smul γ τ,
+    fun γ => ?_⟩
+  have h1 := congrFun hv γ
+  simp only [Submodule.coe_sub, Pi.sub_apply] at h1
+  have h2 := congrArg (fun X : ↥(BinaryForm ℂ n) => (X : MvPolynomial (Fin 2) ℂ)) h1
+  simp only [Submodule.coe_sub] at h2
+  rw [hw γ] at h2
+  rw [← h2]
+  rfl
+
+end Unpack
+
+section Tile
+
+variable {n : ℕ}
+
+theorem coe_ofComplex {z : ℂ} (hz : 0 < z.im) : ((ofComplex z : ℍ) : ℂ) = z := by
+  rw [ofComplex_apply_of_im_pos hz]
+
+def ell (n i : ℕ) (z : ℂ) : ℂ := AddMonoidAlgebra.coeff
+  ((linePow n z : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) (expo n i)
+
+theorem ell_eq {i : ℕ} (hi : i ≤ n) (z : ℂ) : ell n i z = (n.choose (n - i) : ℂ) * z ^ (n - i) := by
+  rw [ell, coe_linePow, add_pow, coeff_sum]
+  have hterm : ∀ m ∈ Finset.range (n + 1), AddMonoidAlgebra.coeff
+      ((C z * X 0) ^ m * X 1 ^ (n - m) * (n.choose m : MvPolynomial (Fin 2) ℂ)) (expo n i)
+      = if m = n - i then (n.choose (n - i) : ℂ) * z ^ (n - i) else 0 := by
+    intro m hm
+    rw [Finset.mem_range] at hm
+    have hmon : (C z * X 0) ^ m * X 1 ^ (n - m) * (n.choose m : MvPolynomial (Fin 2) ℂ)
+        = monomial (Finsupp.single 0 m + Finsupp.single 1 (n - m)) (z ^ m * (n.choose m : ℂ)) := by
+      have h1 : (n.choose m : MvPolynomial (Fin 2) ℂ) = C (n.choose m : ℂ) := (map_natCast C _).symm
+      have h2 : (X 0 : MvPolynomial (Fin 2) ℂ) ^ m * X 1 ^ (n - m)
+          = monomial (Finsupp.single 0 m + Finsupp.single 1 (n - m)) 1 := by
+        rw [X_pow_eq_monomial, X_pow_eq_monomial, monomial_mul_monomial, one_mul]
+      rw [h1, mul_pow, ← C_pow, mul_assoc (C (z ^ m)), h2, C_mul_monomial, mul_comm, C_mul_monomial]
+      congr 1
+      ring
+    rw [hmon, coeff_monomial]
+    by_cases h : m = n - i
+    · subst h
+      rw [ite_eq_left, ite_eq_left rfl, mul_comm]
+      simp only [expo]
+      congr 2
+      omega
+    · rw [ite_eq_right, ite_eq_right h]
+      intro heq
+      apply h
+      have := congrArg (fun d => d 0) heq
+      simpa [expo] using this
+  rw [Finset.sum_congr rfl hterm, Finset.sum_ite_eq' (Finset.range (n + 1)) (n - i)]
+  rw [ite_eq_left (Finset.mem_range.mpr (by omega))]
+
+theorem continuous_ell {i : ℕ} (hi : i ≤ n) : Continuous (ell n i) := by
+  have : ell n i = fun z => (n.choose (n - i) : ℂ) * z ^ (n - i) := funext (ell_eq hi)
+  rw [this]
+  fun_prop
+
+theorem norm_ell_le {i : ℕ} (hi : i ≤ n) (z : ℂ) : ‖ell n i z‖ ≤ 2 ^ n * (1 + ‖z‖) ^ n := by
+  rw [ell_eq hi, norm_mul, Complex.norm_natCast, norm_pow]
+  have h1 : (n.choose (n - i) : ℝ) ≤ 2 ^ n := by exact_mod_cast Nat.choose_le_two_pow n (n - i)
+  have h2 : ‖z‖ ^ (n - i) ≤ (1 + ‖z‖) ^ n :=
+    (pow_le_pow_left₀ (norm_nonneg _) (by linarith [norm_nonneg z]) _).trans
+      (pow_le_pow_right₀ (by linarith [norm_nonneg z]) (Nat.sub_le n i))
+  exact mul_le_mul h1 h2 (by positivity) (by positivity)
+
+variable (φ ψ : ℍ → ℂ) (A B : ℍ → ↥(BinaryForm ℂ n)) (c : ↥(BinaryForm ℂ n))
+
+def fC (φ : ℍ → ℂ) (z : ℂ) : ℂ := φ (ofComplex z)
+
+def aC (A : ℍ → ↥(BinaryForm ℂ n)) (i : ℕ) (z : ℂ) : ℂ := AddMonoidAlgebra.coeff
+  ((A (ofComplex z) : ↥(BinaryForm ℂ n)) : MvPolynomial (Fin 2) ℂ) (expo n i)
+
+def cc (c : ↥(BinaryForm ℂ n)) (i : ℕ) : ℂ :=
+  AddMonoidAlgebra.coeff (c : MvPolynomial (Fin 2) ℂ) (expo n i)
+
+def eC (i : ℕ) (z : ℂ) : ℂ := conj (aC A i z) - aC B i z + conj (cc c i)
+
+def EC (z : ℂ) : ℂ := ∑ i ∈ Finset.range (n + 1), eC A B c i z * (-z) ^ i
+
+def TC (z : ℂ) : ℂ := fC φ z * EC A B c z
+
+theorem Edat_ofComplex {z : ℂ} (hz : 0 < z.im) : Edat A B c (ofComplex z) = EC A B c z := by
+  rw [Edat, coe_ofComplex hz, ev_eq_sum z (conjP_mem (A _).2), ev_eq_sum z (B _).2, ev_eq_sum z
+    (conjP_mem c.2), EC,
+    ← Finset.sum_sub_distrib, ← Finset.sum_add_distrib]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [eC, aC, aC, cc, coeff_conjP, coeff_conjP]
+  ring
+
+theorem Pdat_ofComplex {z : ℂ} (hz : 0 < z.im) : Pdat φ A B c (ofComplex z) = TC φ A B c z := by
+  rw [Pdat, Edat_ofComplex A B c hz, TC, fC]
+
+variable {φ ψ A B}
+variable (hA : IsEichlerIntegral n φ A) (hB : IsEichlerIntegral n ψ B)
+  (hφ : DifferentiableOn ℂ (fC φ) {z : ℂ | 0 < z.im}) (hψ : ContinuousOn (fC ψ) {z : ℂ | 0 < z.im})
+
+include hA in
+theorem hasDerivAt_aC (i : ℕ) {z : ℂ} (hz : 0 < z.im) :
+    HasDerivAt (aC A i) (fC φ z * ell n i z) z := by
+  have h := hA (expo n i) (ofComplex z)
+  rw [coe_ofComplex hz] at h
+  exact h
+
+def dmC (i : ℕ) (z : ℂ) : ℂ := (i : ℂ) * (-z) ^ (i - 1) * (-1)
+
+def eD (n : ℕ) (φ ψ : ℍ → ℂ) (i : ℕ) (z : ℂ) : ℂ →L[ℝ] ℂ :=
+  (conjCLE : ℂ →L[ℝ] ℂ).comp ((fC φ z * ell n i z) • (1 : ℂ →L[ℝ] ℂ)) - (fC ψ z * ell n i z) • (1 :
+    ℂ →L[ℝ] ℂ)
+
+def termD (φ ψ : ℍ → ℂ) (A B : ℍ → ↥(BinaryForm ℂ n)) (c : ↥(BinaryForm ℂ n)) (i : ℕ) (z : ℂ) :
+    ℂ →L[ℝ] ℂ :=
+  eC A B c i z • (dmC i z • (1 : ℂ →L[ℝ] ℂ)) + (-z) ^ i • eD n φ ψ i z
+
+def TD (φ ψ : ℍ → ℂ) (A B : ℍ → ↥(BinaryForm ℂ n)) (c : ↥(BinaryForm ℂ n)) (z : ℂ) : ℂ →L[ℝ] ℂ :=
+  fC φ z • (∑ i ∈ Finset.range (n + 1), termD φ ψ A B c i z) + EC A B c z • (deriv (fC φ) z • (1 : ℂ
+    →L[ℝ] ℂ))
+
+include hA hB in
+theorem hasFDerivAt_eC (i : ℕ) {z : ℂ} (hz : 0 < z.im) :
+    HasFDerivAt (eC A B c i) (eD n φ ψ i z) z := by
+  have h1 : HasFDerivAt (fun w => conj (aC A i w)) ((conjCLE : ℂ →L[ℝ] ℂ).comp ((fC φ z * ell n i z)
+    • (1 : ℂ →L[ℝ] ℂ))) z :=
+    (conjCLE : ℂ ≃L[ℝ] ℂ).hasFDerivAt.comp z (hasDerivAt_aC hA i hz).complexToReal_fderiv
+  have h2 : HasFDerivAt (aC B i) ((fC ψ z * ell n i z) • (1 : ℂ →L[ℝ] ℂ)) z :=
+    (hasDerivAt_aC hB i hz).complexToReal_fderiv
+  exact (h1.sub h2).add_const _
+
+theorem hasFDerivAt_negPow (i : ℕ) (z : ℂ) :
+    HasFDerivAt (fun w : ℂ => (-w) ^ i) (dmC i z • (1 : ℂ →L[ℝ] ℂ)) z :=
+  ((hasDerivAt_neg' z).fun_pow i).complexToReal_fderiv
+
+include hA hB in
+theorem hasFDerivAt_EC {z : ℂ} (hz : 0 < z.im) :
+    HasFDerivAt (EC A B c) (∑ i ∈ Finset.range (n + 1), termD φ ψ A B c i z) z := by
+  unfold EC
+  refine HasFDerivAt.fun_sum fun i _ => ?_
+  exact (hasFDerivAt_eC c hA hB i hz).fun_mul (hasFDerivAt_negPow i z)
+
+include hA hB hφ in
+theorem hasFDerivAt_TC {z : ℂ} (hz : 0 < z.im) : HasFDerivAt (TC φ A B c) (TD φ ψ A B c z) z := by
+  have hd : HasDerivAt (fC φ) (deriv (fC φ) z) z :=
+    (hφ.differentiableAt (isOpen_upperHalfPlaneSet.mem_nhds hz)).hasDerivAt
+  exact hd.complexToReal_fderiv.mul (hasFDerivAt_EC c hA hB hz)
+
+include hA in
+theorem differentiableOn_aC (i : ℕ) : DifferentiableOn ℂ (aC A i) {z : ℂ | 0 < z.im} :=
+  fun _ hz => (hasDerivAt_aC hA i hz).differentiableAt.differentiableWithinAt
+
+include hA in
+theorem continuousOn_aC (i : ℕ) :
+    ContinuousOn (aC A i) {z : ℂ | 0 < z.im} := (differentiableOn_aC hA i).continuousOn
+
+include hA hB in
+theorem continuousOn_eC (i : ℕ) : ContinuousOn (eC A B c i) {z : ℂ | 0 < z.im} :=
+  ((continuous_conj.comp_continuousOn (continuousOn_aC hA i)).sub (continuousOn_aC hB i)).add
+    continuousOn_const
+
+include hA hB in
+theorem continuousOn_EC : ContinuousOn (EC A B c) {z : ℂ | 0 < z.im} :=
+  continuousOn_finsetSum _ fun i _ => (continuousOn_eC c hA hB i).mul (by fun_prop)
+
+include hφ in
+theorem continuousOn_deriv_fC : ContinuousOn (deriv (fC φ)) {z : ℂ | 0 < z.im} :=
+  (hφ.analyticOnNhd isOpen_upperHalfPlaneSet).deriv.continuousOn
+
+include hA hB hφ hψ in
+theorem continuousOn_TD : ContinuousOn (TD φ ψ A B c) {z : ℂ | 0 < z.im} := by
+  have hφc : ContinuousOn (fC φ) {z : ℂ | 0 < z.im} := hφ.continuousOn
+  have hterm : ∀ i ∈ Finset.range (n + 1), ContinuousOn (termD φ ψ A B c i) {z : ℂ | 0 < z.im} := by
+    intro i hi
+    have hi' : i ≤ n := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)
+    have hell : Continuous (ell n i) := continuous_ell hi'
+    unfold termD eD dmC
+    refine ((continuousOn_eC c hA hB i).fun_smul
+      (ContinuousOn.fun_smul (by fun_prop) continuousOn_const)).fun_add ?_
+    refine ContinuousOn.fun_smul (by fun_prop) ?_
+    refine (ContinuousOn.clm_comp continuousOn_const ((hφc.fun_mul hell.continuousOn).fun_smul
+      continuousOn_const)).fun_sub ?_
+    exact (hψ.fun_mul hell.continuousOn).fun_smul continuousOn_const
+  unfold TD
+  exact (hφc.fun_smul (continuousOn_finsetSum _ hterm)).fun_add
+    ((continuousOn_EC c hA hB).fun_smul ((continuousOn_deriv_fC hφ).fun_smul continuousOn_const))
+
+def termL (ψ : ℍ → ℂ) (A B : ℍ → ↥(BinaryForm ℂ n)) (c : ↥(BinaryForm ℂ n)) (i : ℕ) (z : ℂ) : ℂ :=
+  eC A B c i z * dmC i z - (-z) ^ i * (fC ψ z * ell n i z)
+
+def termK (n : ℕ) (φ : ℍ → ℂ) (i : ℕ) (z : ℂ) : ℂ := (-z) ^ i * conj (fC φ z * ell n i z)
+
+theorem termD_apply (i : ℕ) (z w : ℂ) :
+    termD φ ψ A B c i z w = termL ψ A B c i z * w + termK n φ i z * conj w := by
+  simp only [termD, eD, termL, termK, add_apply, smul_apply,
+    sub_apply, ContinuousLinearMap.comp_apply, one_apply_eq_self,
+    ContinuousLinearEquiv.coe_coe, conjCLE_apply, smul_eq_mul, map_mul]
+  ring
+
+theorem TD_apply (z w : ℂ) :
+    TD φ ψ A B c z w = (fC φ z * (∑ i ∈ Finset.range (n + 1), termL ψ A B c i z) + EC A B c z *
+      deriv (fC φ) z) * w
+      + (fC φ z * ∑ i ∈ Finset.range (n + 1), termK n φ i z) * conj w := by
+  simp only [TD, add_apply, smul_apply, sum_apply,
+    one_apply_eq_self, smul_eq_mul, termD_apply, Finset.sum_add_distrib, ← Finset.sum_mul]
+  ring
+
+theorem sum_termK (φ : ℍ → ℂ) (z : ℂ) :
+    ∑ i ∈ Finset.range (n + 1), termK n φ i z = conj (fC φ z) * (conj z - z) ^ n := by
+  have h := ev_eq_sum z (conjP_mem (linePow n z).2)
+  rw [ev_conjP_linePow] at h
+  rw [h, Finset.mul_sum]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [termK, coeff_conjP, map_mul, ell]
+  ring
+
+theorem I_smul_TD_sub (z : ℂ) :
+    Complex.I • TD φ ψ A B c z 1 - TD φ ψ A B c z Complex.I
+      = 2 * Complex.I * (fC φ z * conj (fC φ z) * (conj z - z) ^ n) := by
+  rw [TD_apply, TD_apply, sum_termK]
+  simp only [smul_eq_mul, map_one, Complex.conj_I]
+  ring
+
+end Tile
+
+section Bounds
+
+variable {n : ℕ}
+
+theorem poly_exp_bound (c : ℝ) (hc : 0 < c) (k : ℕ) :
+    ∃ K : ℝ, 0 < K ∧ ∀ t : ℝ, 0 ≤ t → (2 + t) ^ k * Real.exp (-c * t) ≤ K * Real.exp (-(c / 2) * t)
+      := by
+  refine ⟨(2 / c) ^ k * k.factorial * Real.exp c, by positivity, fun t ht => ?_⟩
+  have hx : 0 ≤ c / 2 * (2 + t) := by positivity
+  have h1 := Real.pow_div_factorial_le_exp (c / 2 * (2 + t)) hx k
+  have hfac : (0 : ℝ) < k.factorial := by exact_mod_cast k.factorial_pos
+  rw [div_le_iff₀ hfac, mul_pow] at h1
+  have h2 : (2 + t) ^ k ≤ (2 / c) ^ k * k.factorial * Real.exp (c / 2 * (2 + t)) := by
+    have h3 : (2 / c) ^ k * (c / 2) ^ k = 1 := by
+      rw [← mul_pow, show 2 / c * (c / 2) = 1 by field_simp, one_pow]
+    calc (2 + t) ^ k = (2 / c) ^ k * ((c / 2) ^ k * (2 + t) ^ k) := by rw [← mul_assoc, h3, one_mul]
+      _ ≤ (2 / c) ^ k * (Real.exp (c / 2 * (2 + t)) * k.factorial) := by gcongr
+      _ = _ := by ring
+  calc (2 + t) ^ k * Real.exp (-c * t) ≤ (2 / c) ^ k * k.factorial * Real.exp (c / 2 * (2 + t)) *
+    Real.exp (-c * t) := by
+        gcongr
+    _ = (2 / c) ^ k * k.factorial * Real.exp c * Real.exp (-(c / 2) * t) := by
+        rw [mul_assoc, mul_assoc, mul_assoc, mul_assoc, ← Real.exp_add, ← Real.exp_add]
+        ring_nf
+
+def strip : Set ℂ := {z : ℂ | 1 / 2 ≤ z.im ∧ |z.re| ≤ 1}
+
+theorem im_pos_of_mem_strip {z : ℂ} (hz : z ∈ strip) : 0 < z.im := by
+  have := hz.1; linarith
+
+theorem norm_le_of_mem_strip {z : ℂ} (hz : z ∈ strip) : ‖z‖ ≤ 1 + z.im := by
+  have h := Complex.norm_le_abs_re_add_abs_im z
+  rw [abs_of_pos (im_pos_of_mem_strip hz)] at h
+  linarith [hz.2]
+
+theorem one_add_norm_le {z : ℂ} (hz : z ∈ strip) : 1 + ‖z‖ ≤ 2 + z.im := by
+  linarith [norm_le_of_mem_strip hz]
+
+theorem two_add_im_ge_one {z : ℂ} (hz : z ∈ strip) : 1 ≤ 2 + z.im := by
+  linarith [hz.1]
+
+theorem norm_neg_pow_le {z : ℂ} (hz : z ∈ strip) {i : ℕ} (hi : i ≤ n) :
+    ‖(-z) ^ i‖ ≤ (2 + z.im) ^ n := by
+  rw [norm_pow, norm_neg]
+  calc ‖z‖ ^ i ≤ (2 + z.im) ^ i := pow_le_pow_left₀ (norm_nonneg _) (by
+    linarith [norm_le_of_mem_strip hz]) _
+    _ ≤ (2 + z.im) ^ n := pow_le_pow_right₀ (two_add_im_ge_one hz) hi
+
+theorem norm_dmC_le {z : ℂ} (hz : z ∈ strip) {i : ℕ} (hi : i ≤ n) :
+    ‖dmC i z‖ ≤ n * (2 + z.im) ^ n := by
+  rw [dmC, norm_mul, norm_mul, norm_neg, norm_one, mul_one, Complex.norm_natCast]
+  have h1 : ‖(-z) ^ (i - 1)‖ ≤ (2 + z.im) ^ n := norm_neg_pow_le hz ((Nat.sub_le i 1).trans hi)
+  have h2 : (i : ℝ) ≤ n := by exact_mod_cast hi
+  exact mul_le_mul h2 h1 (norm_nonneg _) (Nat.cast_nonneg _)
+
+theorem norm_ell_le' {z : ℂ} (hz : z ∈ strip) {i : ℕ} (hi : i ≤ n) :
+    ‖ell n i z‖ ≤ 2 ^ n * (2 + z.im) ^ n :=
+  (norm_ell_le hi z).trans (mul_le_mul_of_nonneg_left (pow_le_pow_left₀ (by positivity)
+    (one_add_norm_le hz) _) (by positivity))
+
+theorem pow_le_pow_two_mul {z : ℂ} (hz : z ∈ strip) : (2 + z.im) ^ n ≤ (2 + z.im) ^ (2 * n) :=
+  pow_le_pow_right₀ (two_add_im_ge_one hz) (by omega)
+
+theorem isCompact_box (M : ℝ) : IsCompact (Set.Icc (-1 : ℝ) 1 ×ℂ Set.Icc (1 / 2 : ℝ) M) :=
+  Metric.isCompact_of_isClosed_isBounded (isClosed_Icc.reProdIm isClosed_Icc)
+    ((Metric.isBounded_Icc _ _).reProdIm (Metric.isBounded_Icc _ _))
+
+theorem box_subset (M : ℝ) : Set.Icc (-1 : ℝ) 1 ×ℂ Set.Icc (1 / 2 : ℝ) M ⊆ {z : ℂ | 0 < z.im} := by
+  intro z hz
+  have := (Complex.mem_reProdIm.mp hz).2.1
+  change 0 < z.im
+  linarith
+
+variable {φ ψ : ℍ → ℂ} {A B : ℍ → ↥(BinaryForm ℂ n)} (c₀ : ↥(BinaryForm ℂ n))
+variable (hA : IsEichlerIntegral n φ A)
+variable {c Cφ : ℝ} (hc : 0 < c)
+    (hφd : ∀ z : ℂ, 1 / 4 ≤ z.im → ‖fC φ z‖ ≤ Cφ * Real.exp (-c * z.im))
+
+include hφd in
+theorem Cφ_nonneg : 0 ≤ Cφ := by
+  have h := hφd (Complex.I) (by norm_num)
+  have h2 : 0 < Real.exp (-c * (Complex.I).im) := Real.exp_pos _
+  nlinarith [norm_nonneg (fC φ Complex.I)]
+
+include hc hφd in
+theorem norm_deriv_aC_le {i : ℕ} (hi : i ≤ n) :
+    ∃ K : ℝ, 0 ≤ K ∧ ∀ z ∈ strip, ‖fC φ z * ell n i z‖ ≤ K * Real.exp (-(c / 2) * z.im) := by
+  obtain ⟨K₁, hK₁, hK⟩ := poly_exp_bound c hc n
+  have hC := Cφ_nonneg hφd
+  refine ⟨Cφ * 2 ^ n * K₁, by positivity, fun z hz => ?_⟩
+  have hz0 := im_pos_of_mem_strip hz
+  rw [norm_mul]
+  calc ‖fC φ z‖ * ‖ell n i z‖ ≤ (Cφ * Real.exp (-c * z.im)) * (2 ^ n * (2 + z.im) ^ n) :=
+        mul_le_mul (hφd z (by linarith [hz.1])) (norm_ell_le' hz hi) (norm_nonneg _) (by positivity)
+    _ = Cφ * 2 ^ n * ((2 + z.im) ^ n * Real.exp (-c * z.im)) := by ring
+    _ ≤ Cφ * 2 ^ n * (K₁ * Real.exp (-(c / 2) * z.im)) :=
+        mul_le_mul_of_nonneg_left (hK z.im hz0.le) (by positivity)
+    _ = _ := by ring
+
+include hA hc hφd in
+theorem norm_aC_le {i : ℕ} (hi : i ≤ n) : ∃ K : ℝ, ∀ z ∈ strip, ‖aC A i z‖ ≤ K := by
+  obtain ⟨K₂, hK₂0, hK₂⟩ := norm_deriv_aC_le hc hφd hi
+  obtain ⟨M, hM⟩ :=
+    (isCompact_box 1).exists_bound_of_continuousOn ((continuousOn_aC hA i).mono (box_subset _))
+  refine ⟨M + K₂ * (2 / c), fun z hz => ?_⟩
+  have hz0 := im_pos_of_mem_strip hz
+  have hMK : 0 ≤ K₂ * (2 / c) := by positivity
+  rcases le_or_gt z.im 1 with h1 | h1
+  · have hzB : z ∈ Set.Icc (-1 : ℝ) 1 ×ℂ Set.Icc (1 / 2 : ℝ) 1 :=
+      Complex.mem_reProdIm.mpr ⟨abs_le.mp hz.2, hz.1, h1⟩
+    exact (hM z hzB).trans (le_add_of_nonneg_right hMK)
+  · set x : ℝ := z.re with hx
+    set y : ℝ := z.im with hy
+    set p : ℝ → ℂ := fun t => (x : ℂ) + (t : ℂ) * Complex.I with hp
+    have hpim : ∀ t : ℝ, (p t).im = t := by intro t; simp [hp]
+    have hpre : ∀ t : ℝ, (p t).re = x := by intro t; simp [hp]
+    have hpz : p y = z := by
+      apply Complex.ext <;> simp [hp, hx, hy]
+    have hpstrip : ∀ t : ℝ, 1 / 2 ≤ t → p t ∈ strip := by
+      intro t ht
+      exact ⟨by rw [hpim]; exact ht, by rw [hpre]; exact hz.2⟩
+    have hderiv : ∀ t ∈ Set.uIcc 1 y, HasDerivAt (fun s : ℝ => aC A i (p s)) ((fC φ (p t) * ell n i
+      (p t)) * Complex.I) t :=
+      by
+      intro t ht
+      rw [Set.uIcc_of_le h1.le] at ht
+      have hpt : HasDerivAt p Complex.I t := by
+        have := ((hasDerivAt_id t).ofReal_comp.mul_const Complex.I).const_add (x : ℂ)
+        simpa [hp] using this
+      have hd := hasDerivAt_aC hA i (z := p t) (by rw [hpim]; linarith [ht.1])
+      exact hd.comp t hpt
+    have hcont : ContinuousOn (fun t : ℝ => (fC φ (p t) * ell n i (p t)) * Complex.I) (Set.uIcc 1 y)
+      :=
+      by
+      rw [Set.uIcc_of_le h1.le]
+      have hpc : Continuous p := by simp only [hp]; fun_prop
+      have h1' : ContinuousOn (fun t : ℝ => deriv (aC A i) (p t)) (Set.Icc 1 y) := by
+        refine ((differentiableOn_aC hA i).analyticOnNhd
+          isOpen_upperHalfPlaneSet).deriv.continuousOn.comp
+          hpc.continuousOn fun t ht => ?_
+        change 0 < (p t).im
+        rw [hpim]; linarith [ht.1]
+      refine (h1'.congr fun t ht => ?_).mul continuousOn_const
+      exact ((hasDerivAt_aC hA i (z := p t) (by rw [hpim]; linarith [ht.1])).deriv).symm
+    have hFTC := intervalIntegral.integral_eq_sub_of_hasDerivAt hderiv (hcont.intervalIntegrable)
+    have hbound : ‖∫ t in (1 : ℝ)..y, (fC φ (p t) * ell n i (p t)) * Complex.I‖ ≤ K₂ * (2 / c) := by
+      have hle : ∀ t ∈ Set.Ioc 1 y, ‖(fC φ (p t) * ell n i (p t)) * Complex.I‖ ≤ K₂ * Real.exp (-(c
+        / 2) * t) :=
+        by
+        intro t ht
+        rw [norm_mul, Complex.norm_I, mul_one]
+        have := hK₂ (p t) (hpstrip t (by linarith [ht.1]))
+        rwa [hpim] at this
+      have hgi : IntervalIntegrable (fun t => K₂ * Real.exp (-(c / 2) * t)) MeasureTheory.volume 1 y
+        :=
+        (by fun_prop : Continuous fun t => K₂ * Real.exp (-(c / 2) * t)).intervalIntegrable _ _
+      refine (intervalIntegral.norm_integral_le_of_norm_le h1.le (Filter.Eventually.of_forall hle)
+        hgi).trans ?_
+      have hanti : ∀ t ∈ Set.uIcc 1 y, HasDerivAt (fun s : ℝ => -(K₂ * (2 / c)) * Real.exp (-(c / 2)
+        * s))
+          (K₂ * Real.exp (-(c / 2) * t)) t := by
+        intro t _
+        have := ((hasDerivAt_id t).const_mul (-(c / 2))).exp.const_mul (-(K₂ * (2 / c)))
+        convert this using 1 <;> first | rfl | (simp only [id]; field_simp)
+      rw [intervalIntegral.integral_eq_sub_of_hasDerivAt hanti hgi]
+      have he1 : Real.exp (-(c / 2) * y) > 0 := Real.exp_pos _
+      have he2 : Real.exp (-(c / 2) * 1) ≤ 1 := by
+        rw [Real.exp_le_one_iff]; nlinarith
+      nlinarith
+    calc ‖aC A i z‖ = ‖aC A i (p 1) + ∫ t in (1 : ℝ)..y, (fC φ (p t) * ell n i (p t)) * Complex.I‖
+      := by
+          rw [hFTC, hpz]; abel_nf
+      _ ≤ ‖aC A i (p 1)‖ + ‖∫ t in (1 : ℝ)..y, (fC φ (p t) * ell n i (p t)) * Complex.I‖ :=
+        norm_add_le _ _
+      _ ≤ M + K₂ * (2 / c) := add_le_add (hM _ (Complex.mem_reProdIm.mpr
+          ⟨by rw [hpre]; exact abs_le.mp hz.2, by rw [hpim]; norm_num, by rw [hpim]⟩)) hbound
+
+end Bounds
+
+section Bounds2
+
+variable {n : ℕ}
+variable {φ ψ : ℍ → ℂ} {A B : ℍ → ↥(BinaryForm ℂ n)} (c₀ : ↥(BinaryForm ℂ n))
+variable (hA : IsEichlerIntegral n φ A) (hB : IsEichlerIntegral n ψ B)
+variable {c Cφ Cφ' Cψ : ℝ} (hc : 0 < c)
+  (hφd : ∀ z : ℂ, 1 / 4 ≤ z.im → ‖fC φ z‖ ≤ Cφ * Real.exp (-c * z.im))
+  (hφ'd : ∀ z : ℂ, 1 / 2 ≤ z.im → ‖deriv (fC φ) z‖ ≤ Cφ' * Real.exp (-c * z.im))
+  (hψd : ∀ z : ℂ, 1 / 4 ≤ z.im → ‖fC ψ z‖ ≤ Cψ * Real.exp (-c * z.im))
+
+theorem exp_neg_le_one {c : ℝ} (hc : 0 < c) {z : ℂ} (hz : z ∈ strip) :
+    Real.exp (-c * z.im) ≤ 1 := by
+  rw [Real.exp_le_one_iff]; nlinarith [hz.1]
+
+include hA hB hc hφd hψd in
+theorem norm_eC_le : ∃ Ke : ℕ → ℝ, ∀ i, i ≤ n → ∀ z ∈ strip, ‖eC A B c₀ i z‖ ≤ Ke i := by
+  have h : ∀ i : ℕ, ∃ K : ℝ, i ≤ n → ∀ z ∈ strip, ‖eC A B c₀ i z‖ ≤ K := by
+    intro i
+    by_cases hi : i ≤ n
+    · obtain ⟨Ka, hKa⟩ := norm_aC_le hA hc hφd hi
+      obtain ⟨Kb, hKb⟩ := norm_aC_le hB hc hψd hi
+      refine ⟨Ka + Kb + ‖cc c₀ i‖, fun _ z hz => ?_⟩
+      unfold eC
+      calc ‖conj (aC A i z) - aC B i z + conj (cc c₀ i)‖
+          ≤ ‖conj (aC A i z) - aC B i z‖ + ‖conj (cc c₀ i)‖ := norm_add_le _ _
+        _ ≤ ‖conj (aC A i z)‖ + ‖aC B i z‖ + ‖conj (cc c₀ i)‖ := by gcongr; exact norm_sub_le _ _
+        _ ≤ Ka + Kb + ‖cc c₀ i‖ := by
+          rw [Complex.norm_conj, Complex.norm_conj]
+          gcongr
+          exacts [hKa z hz, hKb z hz]
+    · exact ⟨0, fun h => absurd h hi⟩
+  choose Ke hKe using h
+  exact ⟨Ke, hKe⟩
+
+include hA hB hc hφd hψd in
+theorem norm_EC_le : ∃ CE : ℝ, 0 ≤ CE ∧ ∀ z ∈ strip, ‖EC A B c₀ z‖ ≤ CE * (2 + z.im) ^ n := by
+  obtain ⟨Ke, hKe⟩ := norm_eC_le c₀ hA hB hc hφd hψd
+  have hKe0 : ∀ i ∈ Finset.range (n + 1), 0 ≤ Ke i := fun i hi =>
+    (norm_nonneg _).trans (hKe i (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) Complex.I
+    ⟨by norm_num, by norm_num⟩)
+  refine ⟨∑ i ∈ Finset.range (n + 1), Ke i, Finset.sum_nonneg hKe0, fun z hz => ?_⟩
+  unfold EC
+  rw [Finset.sum_mul]
+  refine (norm_sum_le _ _).trans (Finset.sum_le_sum fun i hi => ?_)
+  have hi' : i ≤ n := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)
+  rw [norm_mul]
+  exact mul_le_mul (hKe i hi' z hz) (norm_neg_pow_le hz hi') (norm_nonneg _) (hKe0 i hi)
+
+include hA hB hc hφd hψd in
+theorem norm_sum_termL_le : ∃ CL : ℝ, 0 ≤ CL ∧ ∀ z ∈ strip,
+    ‖∑ i ∈ Finset.range (n + 1), termL ψ A B c₀ i z‖ ≤ CL * (2 + z.im) ^ (2 * n) := by
+  obtain ⟨Ke, hKe⟩ := norm_eC_le c₀ hA hB hc hφd hψd
+  have hKe0 : ∀ i ∈ Finset.range (n + 1), 0 ≤ Ke i := fun i hi =>
+    (norm_nonneg _).trans (hKe i (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) Complex.I
+    ⟨by norm_num, by norm_num⟩)
+  have hCψ : 0 ≤ Cψ := Cφ_nonneg hψd
+  refine ⟨∑ i ∈ Finset.range (n + 1), (Ke i * n + Cψ * 2 ^ n), Finset.sum_nonneg fun i hi => by
+    have := hKe0 i hi; positivity, fun z hz => ?_⟩
+  rw [Finset.sum_mul]
+  refine (norm_sum_le _ _).trans (Finset.sum_le_sum fun i hi => ?_)
+  have hi' : i ≤ n := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)
+  have hw := two_add_im_ge_one hz
+  have hpow := pow_le_pow_two_mul (n := n) hz
+  have hsq : (2 + z.im) ^ n * (2 + z.im) ^ n = (2 + z.im) ^ (2 * n) := by rw [← pow_add]; ring_nf
+  have h1 : ‖eC A B c₀ i z * dmC i z‖ ≤ Ke i * n * (2 + z.im) ^ (2 * n) := by
+    rw [norm_mul]
+    calc ‖eC A B c₀ i z‖ * ‖dmC i z‖ ≤ Ke i * (n * (2 + z.im) ^ n) :=
+          mul_le_mul (hKe i hi' z hz) (norm_dmC_le hz hi') (norm_nonneg _) (hKe0 i hi)
+      _ ≤ Ke i * (n * (2 + z.im) ^ (2 * n)) := by gcongr; exact hKe0 i hi
+      _ = _ := by ring
+  have h2 : ‖(-z) ^ i * (fC ψ z * ell n i z)‖ ≤ Cψ * 2 ^ n * (2 + z.im) ^ (2 * n) := by
+    rw [norm_mul, norm_mul]
+    calc ‖(-z) ^ i‖ * (‖fC ψ z‖ * ‖ell n i z‖)
+        ≤ (2 + z.im) ^ n * ((Cψ * Real.exp (-c * z.im)) * (2 ^ n * (2 + z.im) ^ n)) :=
+          mul_le_mul (norm_neg_pow_le hz hi') (mul_le_mul (hψd z (by linarith [hz.1]))
+          (norm_ell_le' hz hi')
+            (norm_nonneg _) (by positivity)) (by positivity) (by positivity)
+      _ ≤ (2 + z.im) ^ n * ((Cψ * 1) * (2 ^ n * (2 + z.im) ^ n)) := by
+        gcongr
+        exact exp_neg_le_one hc hz
+      _ = Cψ * 2 ^ n * ((2 + z.im) ^ n * (2 + z.im) ^ n) := by ring
+      _ = _ := by rw [hsq]
+  calc ‖termL ψ A B c₀ i z‖ ≤ ‖eC A B c₀ i z * dmC i z‖ + ‖(-z) ^ i * (fC ψ z * ell n i z)‖ :=
+    norm_sub_le _ _
+    _ ≤ Ke i * n * (2 + z.im) ^ (2 * n) + Cψ * 2 ^ n * (2 + z.im) ^ (2 * n) := add_le_add h1 h2
+    _ = _ := by ring
+
+include hc hφd in
+theorem norm_sum_termK_le : ∀ z ∈ strip,
+    ‖∑ i ∈ Finset.range (n + 1), termK n φ i z‖ ≤ Cφ * 2 ^ n * (2 + z.im) ^ (2 * n) := by
+  intro z hz
+  have hC := Cφ_nonneg hφd
+  rw [sum_termK, norm_mul, Complex.norm_conj, norm_pow]
+  have h1 : ‖conj z - z‖ ≤ 2 * (2 + z.im) := by
+    have : conj z - z = -(2 * z.im * Complex.I) := by
+      apply Complex.ext <;> simp; ring
+    rw [this, norm_neg, norm_mul, norm_mul, Complex.norm_I, mul_one, Complex.norm_two,
+      Complex.norm_real,
+      Real.norm_eq_abs, abs_of_pos (im_pos_of_mem_strip hz)]
+    linarith
+  calc ‖fC φ z‖ * ‖conj z - z‖ ^ n ≤ (Cφ * Real.exp (-c * z.im)) * (2 * (2 + z.im)) ^ n :=
+        mul_le_mul (hφd z (by linarith [hz.1])) (pow_le_pow_left₀ (norm_nonneg _) h1 n)
+        (by positivity) (by positivity)
+    _ ≤ (Cφ * 1) * (2 * (2 + z.im)) ^ n := by
+        have hz2 : 0 ≤ 2 + z.im := by linarith [hz.1]
+        have : Real.exp (-c * z.im) ≤ 1 := exp_neg_le_one hc hz
+        have h3 : 0 ≤ (2 * (2 + z.im)) ^ n := by positivity
+        nlinarith [mul_le_mul_of_nonneg_left this hC]
+    _ = Cφ * 2 ^ n * (2 + z.im) ^ n := by rw [mul_pow]; ring
+    _ ≤ Cφ * 2 ^ n * (2 + z.im) ^ (2 * n) := mul_le_mul_of_nonneg_left (pow_le_pow_two_mul hz)
+        (by positivity)
+
+include hA hB hc hφd hφ'd hψd in
+theorem tile_bounds :
+    (∃ C : ℝ, ∀ z ∈ strip, ‖TC φ A B c₀ z‖ ≤ C * Real.exp (-(c / 2) * z.im)) ∧
+    (∃ C : ℝ, ∀ z ∈ strip, ‖TD φ ψ A B c₀ z‖ ≤ C * Real.exp (-(c / 2) * z.im)) := by
+  obtain ⟨CE, hCE0, hCE⟩ := norm_EC_le c₀ hA hB hc hφd hψd
+  obtain ⟨CL, hCL0, hCL⟩ := norm_sum_termL_le c₀ hA hB hc hφd hψd
+  have hCK := norm_sum_termK_le (n := n) hc hφd
+  obtain ⟨K₂, hK₂0, hK₂⟩ := poly_exp_bound c hc (2 * n)
+  have hCφ := Cφ_nonneg hφd
+  have hCφ' : 0 ≤ Cφ' := by
+    have h := hφ'd (Complex.I) (by norm_num)
+    have h2 : 0 < Real.exp (-c * (Complex.I).im) := Real.exp_pos _
+    nlinarith [norm_nonneg (deriv (fC φ) Complex.I)]
+  refine ⟨⟨Cφ * CE * K₂, fun z hz => ?_⟩, ⟨(Cφ * (CL + Cφ * 2 ^ n) + CE * Cφ') * K₂, fun z hz =>
+    ?_⟩⟩
+  · have hz0 := im_pos_of_mem_strip hz
+    have hpow := pow_le_pow_two_mul (n := n) hz
+    rw [TC, norm_mul]
+    calc ‖fC φ z‖ * ‖EC A B c₀ z‖ ≤ (Cφ * Real.exp (-c * z.im)) * (CE * (2 + z.im) ^ n) :=
+          mul_le_mul (hφd z (by linarith [hz.1])) (hCE z hz) (norm_nonneg _) (by positivity)
+      _ ≤ (Cφ * Real.exp (-c * z.im)) * (CE * (2 + z.im) ^ (2 * n)) :=
+          mul_le_mul_of_nonneg_left (mul_le_mul_of_nonneg_left hpow hCE0) (by positivity)
+      _ = Cφ * CE * ((2 + z.im) ^ (2 * n) * Real.exp (-c * z.im)) := by ring
+      _ ≤ Cφ * CE * (K₂ * Real.exp (-(c / 2) * z.im)) := mul_le_mul_of_nonneg_left (hK₂ z.im hz0.le)
+        (by positivity)
+      _ = _ := by ring
+  · have hz0 := im_pos_of_mem_strip hz
+    set L := fC φ z * (∑ i ∈ Finset.range (n + 1), termL ψ A B c₀ i z) + EC A B c₀ z * deriv (fC φ)
+      z with hL
+    set K := fC φ z * ∑ i ∈ Finset.range (n + 1), termK n φ i z with hK
+    have hop : ‖TD φ ψ A B c₀ z‖ ≤ ‖L‖ + ‖K‖ := by
+      refine ContinuousLinearMap.opNorm_le_bound _ (by positivity) fun w => ?_
+      rw [TD_apply, ← hL, ← hK]
+      calc ‖L * w + K * conj w‖ ≤ ‖L * w‖ + ‖K * conj w‖ := norm_add_le _ _
+        _ = (‖L‖ + ‖K‖) * ‖w‖ := by rw [norm_mul, norm_mul, Complex.norm_conj]; ring
+    have hLb : ‖L‖ ≤ (Cφ * CL + CE * Cφ') * ((2 + z.im) ^ (2 * n) * Real.exp (-c * z.im)) := by
+      rw [hL]
+      calc ‖fC φ z * (∑ i ∈ Finset.range (n + 1), termL ψ A B c₀ i z) + EC A B c₀ z * deriv (fC φ)
+            z‖
+          ≤ ‖fC φ z‖ * ‖∑ i ∈ Finset.range (n + 1), termL ψ A B c₀ i z‖ + ‖EC A B c₀ z‖ * ‖deriv (fC
+            φ) z‖ := by
+            refine (norm_add_le _ _).trans ?_
+            rw [norm_mul, norm_mul]
+        _ ≤ (Cφ * Real.exp (-c * z.im)) * (CL * (2 + z.im) ^ (2 * n))
+            + (CE * (2 + z.im) ^ n) * (Cφ' * Real.exp (-c * z.im)) :=
+            add_le_add (mul_le_mul (hφd z (by linarith [hz.1])) (hCL z hz) (norm_nonneg _)
+              (by positivity))
+              (mul_le_mul (hCE z hz) (hφ'd z hz.1) (norm_nonneg _) (by positivity))
+        _ ≤ (Cφ * Real.exp (-c * z.im)) * (CL * (2 + z.im) ^ (2 * n))
+            + (CE * (2 + z.im) ^ (2 * n)) * (Cφ' * Real.exp (-c * z.im)) := by
+            have hpow := pow_le_pow_two_mul (n := n) hz
+            gcongr
+        _ = _ := by ring
+    have hKb : ‖K‖ ≤ (Cφ * (Cφ * 2 ^ n)) * ((2 + z.im) ^ (2 * n) * Real.exp (-c * z.im)) := by
+      rw [hK, norm_mul]
+      calc ‖fC φ z‖ * ‖∑ i ∈ Finset.range (n + 1), termK n φ i z‖
+          ≤ (Cφ * Real.exp (-c * z.im)) * (Cφ * 2 ^ n * (2 + z.im) ^ (2 * n)) :=
+            mul_le_mul (hφd z (by linarith [hz.1])) (hCK z hz) (norm_nonneg _) (by positivity)
+        _ = _ := by ring
+    calc ‖TD φ ψ A B c₀ z‖ ≤ ‖L‖ + ‖K‖ := hop
+      _ ≤ (Cφ * CL + CE * Cφ') * ((2 + z.im) ^ (2 * n) * Real.exp (-c * z.im))
+          + (Cφ * (Cφ * 2 ^ n)) * ((2 + z.im) ^ (2 * n) * Real.exp (-c * z.im)) := add_le_add hLb
+            hKb
+      _ = (Cφ * (CL + Cφ * 2 ^ n) + CE * Cφ') * ((2 + z.im) ^ (2 * n) * Real.exp (-c * z.im)) := by
+          ring
+      _ ≤ (Cφ * (CL + Cφ * 2 ^ n) + CE * Cφ') * (K₂ * Real.exp (-(c / 2) * z.im)) :=
+          mul_le_mul_of_nonneg_left (hK₂ z.im hz0.le) (by positivity)
+      _ = _ := by ring
+
+end Bounds2
+
+section Cusp
+
+variable {N : ℕ} [NeZero N] {k : ℤ} (f : CuspForm (CongruenceSubgroup.Gamma0 N) k) (σ : SL(2, ℤ))
+
+scoped instance isArithmetic_conj :
+    (ConjAct.toConjAct ((σ : GL (Fin 2) ℝ)⁻¹) •
+      ((CongruenceSubgroup.Gamma0 N : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ))).IsArithmetic
+        := by
+  simpa [(show Rat.castHom ℝ = algebraMap ℚ ℝ by rfl), map_inv, Matrix.SpecialLinearGroup.map_mapGL,
+    (show ∀ τ : SL(2, ℤ), (Matrix.SpecialLinearGroup.mapGL ℝ) τ =
+      Matrix.SpecialLinearGroup.toGL ((Matrix.SpecialLinearGroup.map (Int.castRingHom ℝ)) τ) from
+        fun _ => rfl)] using
+    Subgroup.IsArithmetic.conj ((CongruenceSubgroup.Gamma0 N : Subgroup SL(2, ℤ)) : Subgroup (GL
+      (Fin 2) ℝ))
+      (Matrix.SpecialLinearGroup.mapGL ℚ σ)⁻¹
+
+def tr : CuspForm (ConjAct.toConjAct ((σ : GL (Fin 2) ℝ)⁻¹) •
+    ((CongruenceSubgroup.Gamma0 N : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ))) k :=
+  CuspForm.translate f (σ : GL (Fin 2) ℝ)
+
+omit [NeZero N] in
+theorem fC_eq_tr : fC (⇑f ∣[k] σ) = fun z => tr f σ (ofComplex z) := rfl
+
+omit [NeZero N] in
+theorem differentiableOn_fC : DifferentiableOn ℂ (fC (⇑f ∣[k] σ)) {z : ℂ | 0 < z.im} := by
+  rw [fC_eq_tr]
+  exact UpperHalfPlane.mdifferentiable_iff.mp (ModularFormClass.holo (tr f σ))
+
+omit [NeZero N] in
+theorem continuousOn_fC : ContinuousOn (fC (⇑f ∣[k] σ)) {z : ℂ | 0 < z.im} :=
+  (differentiableOn_fC f σ).continuousOn
+
+theorem tr_decay (hk : 0 ≤ k) {a : ℝ} (ha : 0 < a) :
+    ∃ c > 0, ∃ C, 0 ≤ C ∧ ∀ τ : ℍ, a ≤ τ.im → ‖tr f σ τ‖ ≤ C * Real.exp (-c * τ.im) := by
+  obtain ⟨c, hc, hO⟩ := CuspFormClass.exp_decay_atImInfty' (tr f σ)
+  obtain ⟨C₁, hC₁⟩ := hO.bound
+  obtain ⟨A, hA⟩ := (atImInfty_mem _).mp hC₁
+  obtain ⟨C₂, hC₂⟩ := CuspFormClass.exists_bound (tr f σ)
+  have hak : 0 < a ^ ((k : ℝ) / 2) := Real.rpow_pos_of_pos ha _
+  refine ⟨c, hc, max (max C₁ 0) (|C₂| / a ^ ((k : ℝ) / 2) * Real.exp (c * max A 0)), ?_, fun τ hτ =>
+    ?_⟩
+  · exact le_max_of_le_left (le_max_right _ _)
+  rcases le_or_gt A τ.im with h | h
+  · have := hA τ h
+    simp only [Set.mem_ofPred_eq, Real.norm_eq_abs, Real.abs_exp] at this
+    refine this.trans ?_
+    gcongr
+    exact le_max_of_le_left (le_max_left _ _)
+  · have h2 := hC₂ τ
+    have hpos := τ.im_pos
+    have hk2 : 0 ≤ (k : ℝ) / 2 := by positivity
+    have hpow : a ^ ((k : ℝ) / 2) ≤ τ.im ^ ((k : ℝ) / 2) := Real.rpow_le_rpow ha.le hτ hk2
+    calc ‖tr f σ τ‖ ≤ C₂ / τ.im ^ ((k : ℝ) / 2) := h2
+      _ ≤ |C₂| / τ.im ^ ((k : ℝ) / 2) := by gcongr; exact le_abs_self _
+      _ ≤ |C₂| / a ^ ((k : ℝ) / 2) := div_le_div_of_nonneg_left (abs_nonneg _) hak hpow
+      _ ≤ |C₂| / a ^ ((k : ℝ) / 2) * Real.exp (c * max A 0) * Real.exp (-c * τ.im) := by
+        rw [mul_assoc, ← Real.exp_add]
+        have : 0 ≤ c * max A 0 + -c * τ.im := by
+          have : τ.im ≤ max A 0 := h.le.trans (le_max_left _ _)
+          nlinarith
+        calc |C₂| / a ^ ((k : ℝ) / 2) = |C₂| / a ^ ((k : ℝ) / 2) * 1 := (mul_one _).symm
+          _ ≤ |C₂| / a ^ ((k : ℝ) / 2) * Real.exp (c * max A 0 + -c * τ.im) := by
+            gcongr; exact Real.one_le_exp this
+      _ ≤ _ := by gcongr; exact le_max_right _ _
+
+theorem fC_decay (hk : 0 ≤ k) {a : ℝ} (ha : 0 < a) :
+    ∃ c > 0, ∃ C, 0 ≤ C ∧ ∀ z : ℂ, a ≤ z.im → ‖fC (⇑f ∣[k] σ) z‖ ≤ C * Real.exp (-c * z.im) := by
+  obtain ⟨c, hc, C, hC0, hC⟩ := tr_decay f σ hk ha
+  refine ⟨c, hc, C, hC0, fun z hz => ?_⟩
+  have hz0 : 0 < z.im := ha.trans_le hz
+  have him : (ofComplex z).im = z.im := by rw [ofComplex_apply_of_im_pos hz0]; rfl
+  have := hC (ofComplex z) (by rw [him]; exact hz)
+  rw [him] at this
+  exact this
+
+theorem decay_weaken {φ : ℂ → ℂ} {a c δ C : ℝ} (hC : 0 ≤ C) (hδ : δ ≤ c) (ha : 0 ≤ a)
+    (h : ∀ z : ℂ, a ≤ z.im → ‖φ z‖ ≤ C * Real.exp (-c * z.im)) :
+    ∀ z : ℂ, a ≤ z.im → ‖φ z‖ ≤ C * Real.exp (-δ * z.im) := by
+  intro z hz
+  refine (h z hz).trans ?_
+  gcongr
+  nlinarith [ha.trans hz]
+
+theorem deriv_fC_decay (hk : 0 ≤ k) :
+    ∃ c > 0, ∃ C, 0 ≤ C ∧ ∀ z : ℂ, 1 / 2 ≤ z.im → ‖deriv (fC (⇑f ∣[k] σ)) z‖ ≤ C * Real.exp (-c *
+      z.im) := by
+  have ha4 : (0 : ℝ) < 1 / 4 := by norm_num
+  obtain ⟨c, hc, C, hC0, hC⟩ := fC_decay f σ hk ha4
+  refine ⟨c, hc, C * Real.exp (c * (1 / 4)) / (1 / 4), by positivity, fun z hz => ?_⟩
+  have hball : Metric.closedBall z (1 / 4) ⊆ {w : ℂ | 0 < w.im} := by
+    intro w hw
+    have h1 : |(w - z).im| ≤ ‖w - z‖ := Complex.abs_im_le_norm _
+    rw [Metric.mem_closedBall, dist_eq_norm] at hw
+    have := (abs_le.mp (h1.trans hw)).1
+    simp only [Complex.sub_im] at this
+    change 0 < w.im
+    linarith
+  have hd : DiffContOnCl ℂ (fC (⇑f ∣[k] σ)) (Metric.ball z (1 / 4)) :=
+    ((differentiableOn_fC f σ).mono hball).diffContOnCl_ball (subset_refl _)
+  have hsph : ∀ w ∈ Metric.sphere z (1 / 4),
+      ‖fC (⇑f ∣[k] σ) w‖ ≤ C * Real.exp (c * (1 / 4)) * Real.exp (-c * z.im) := by
+    intro w hw
+    have h1 : |(w - z).im| ≤ ‖w - z‖ := Complex.abs_im_le_norm _
+    rw [Metric.mem_sphere, dist_eq_norm] at hw
+    have him := (abs_le.mp (h1.trans hw.le)).1
+    simp only [Complex.sub_im] at him
+    have hwa : 1 / 4 ≤ w.im := by linarith
+    refine (hC w hwa).trans ?_
+    rw [mul_assoc, ← Real.exp_add]
+    gcongr
+    nlinarith
+  have := Complex.norm_deriv_le_of_forall_mem_sphere_norm_le (by norm_num : (0 : ℝ) < 1 / 4) hd hsph
+  refine this.trans (le_of_eq ?_)
+  ring
+
+end Cusp
+
+section Domain
+
+def fdC : Set ℂ := {z : ℂ | |z.re| ≤ 1 / 2 ∧ 1 ≤ ‖z‖ ∧ 0 < z.im}
+
+def Ubox : Set ℂ := {z : ℂ | 1 / 2 < z.im ∧ |z.re| < 1}
+
+theorem measurableSet_fdC : MeasurableSet fdC :=
+  (measurableSet_le (continuous_abs.comp Complex.continuous_re).measurable measurable_const).inter
+    ((measurableSet_le measurable_const continuous_norm.measurable).inter
+      (measurableSet_lt measurable_const Complex.continuous_im.measurable))
+
+theorem im_gt_of_mem_fdC {z : ℂ} (hz : z ∈ fdC) : 1 / 2 < z.im := by
+  obtain ⟨hre, hn, him⟩ := hz
+  have h1 : 1 ≤ z.re * z.re + z.im * z.im := by
+    have := Complex.normSq_eq_norm_sq z
+    rw [Complex.normSq_apply] at this
+    nlinarith [norm_nonneg z]
+  have h2 : z.re * z.re ≤ 1 / 4 := by
+    have := abs_le.mp hre
+    nlinarith
+  nlinarith
+
+theorem fdC_subset_Ubox : fdC ⊆ Ubox := fun z hz =>
+  ⟨im_gt_of_mem_fdC hz, by have := hz.1; exact lt_of_le_of_lt this (by norm_num)⟩
+
+theorem Ubox_subset_strip : Ubox ⊆ strip := fun _ hz => ⟨hz.1.le, hz.2.le⟩
+
+theorem im_pos_of_mem_Ubox {z : ℂ} (hz : z ∈ Ubox) : 0 < z.im := by
+  have := hz.1; linarith
+
+theorem Ubox_mem_nhds {z : ℂ} (hz : z ∈ Ubox) : {w : ℂ | 0 < w.im} ∈ nhds z :=
+  isOpen_upperHalfPlaneSet.mem_nhds (im_pos_of_mem_Ubox hz)
+
+theorem sqrt3_div_two_gt : (1 : ℝ) / 2 < Real.sqrt 3 / 2 := by
+  have : (1 : ℝ) < Real.sqrt 3 := by
+    rw [show (1 : ℝ) = Real.sqrt 1 by simp]
+    exact Real.sqrt_lt_sqrt (by norm_num) (by norm_num)
+  linarith
+
+theorem ray_mem_Ubox {y : ℝ} (hy : y ∈ Set.Ioi (Real.sqrt 3 / 2)) :
+    (-(1 / 2) + y * Complex.I : ℂ) ∈ Ubox := by
+  refine ⟨?_, ?_⟩
+  · change 1 / 2 < (-(1 / 2) + y * Complex.I : ℂ).im
+    simpa using sqrt3_div_two_gt.trans hy
+  · show |(-(1 / 2) + y * Complex.I : ℂ).re| < 1
+    rw [show (-(1 / 2) + y * Complex.I : ℂ).re = -(1 / 2) by simp,
+      abs_neg, abs_of_pos (by norm_num)]
+    norm_num
+
+theorem integrableOn_ray {Φ : ℂ → ℂ} (hc : ContinuousOn Φ {z : ℂ | 0 < z.im}) {C δ : ℝ}
+    (hδ : 0 < δ) (hb : ∀ z ∈ Ubox, ‖Φ z‖ ≤ C * Real.exp (-δ * z.im)) :
+    MeasureTheory.IntegrableOn (fun y : ℝ => Φ (-(1 / 2) + y * Complex.I)) (Set.Ioi (Real.sqrt 3 /
+      2)) := by
+  have hpath : Continuous fun y : ℝ => (-(1 / 2) + y * Complex.I : ℂ) := by fun_prop
+  have hcont : ContinuousOn (fun y : ℝ => Φ (-(1 / 2) + y * Complex.I)) (Set.Ioi (Real.sqrt 3 / 2))
+    :=
+    hc.comp hpath.continuousOn fun y hy => im_pos_of_mem_Ubox (ray_mem_Ubox hy)
+  refine MeasureTheory.Integrable.mono' ((exp_neg_integrableOn_Ioi _ hδ).const_mul C)
+    (hcont.aestronglyMeasurable measurableSet_Ioi) ?_
+  refine MeasureTheory.ae_restrict_of_forall_mem measurableSet_Ioi fun y hy => ?_
+  have := hb _ (ray_mem_Ubox hy)
+  simpa using this
+
+theorem intervalIntegrable_arc {Φ : ℂ → ℂ} (hc : ContinuousOn Φ {z : ℂ | 0 < z.im}) :
+    IntervalIntegrable (fun θ : ℝ => Φ (Complex.exp (θ * Complex.I)) * (Complex.I * Complex.exp (θ *
+      Complex.I)))
+      MeasureTheory.volume (Real.pi / 3) (2 * Real.pi / 3) := by
+  refine ContinuousOn.intervalIntegrable ?_
+  have hpath : Continuous fun θ : ℝ => Complex.exp (θ * Complex.I) := by fun_prop
+  have hmem : ∀ θ ∈ Set.uIcc (Real.pi / 3) (2 * Real.pi / 3), Complex.exp (θ * Complex.I) ∈ {z : ℂ |
+    0 < z.im} :=
+    by
+    intro θ hθ
+    rw [Set.uIcc_of_le (by linarith [Real.pi_pos])] at hθ
+    change 0 < (Complex.exp (θ * Complex.I)).im
+    rw [Complex.exp_ofReal_mul_I_im]
+    exact Real.sin_pos_of_pos_of_lt_pi (by linarith [Real.pi_pos, hθ.1])
+      (by linarith [Real.pi_pos, hθ.2])
+  have h2 : Continuous fun θ : ℝ => Complex.I * Complex.exp (θ * Complex.I) := by fun_prop
+  exact (hc.comp hpath.continuousOn hmem).mul h2.continuousOn
+
+theorem integrableOn_exp_neg_im {δ : ℝ} (hδ : 0 < δ) (a b : ℝ) :
+    MeasureTheory.IntegrableOn (fun z : ℂ => Real.exp (-δ * z.im)) (Set.Icc a b ×ℂ Set.Ioi (0 : ℝ))
+      := by
+  have e := Complex.volume_preserving_equiv_real_prod.symm
+  rw [← e.integrableOn_comp_preimage (Complex.measurableEquivRealProd.symm.measurableEmbedding)]
+  have hpre : (Complex.measurableEquivRealProd.symm ⁻¹' (Set.Icc a b ×ℂ Set.Ioi (0 : ℝ))) = Set.Icc
+    a b ×ˢ Set.Ioi 0 :=
+    by
+    ext p
+    simp [Complex.measurableEquivRealProd, Complex.mem_reProdIm]
+  rw [hpre, MeasureTheory.IntegrableOn, MeasureTheory.Measure.volume_eq_prod, ←
+    MeasureTheory.Measure.prod_restrict]
+  have h1 : MeasureTheory.Integrable (fun _ : ℝ => (1 : ℝ)) (MeasureTheory.volume.restrict (Set.Icc
+    a b)) :=
+    MeasureTheory.integrable_const _
+  have h2 : MeasureTheory.Integrable (fun y : ℝ => Real.exp (-δ * y)) (MeasureTheory.volume.restrict
+    (Set.Ioi 0)) :=
+    exp_neg_integrableOn_Ioi 0 hδ
+  refine (h1.mul_prod h2).congr (Filter.Eventually.of_forall fun p => ?_)
+  simp [Complex.measurableEquivRealProd]
+
+theorem fdC_subset_prod : fdC ⊆ Set.Icc (-(1 / 2) : ℝ) (1 / 2) ×ℂ Set.Ioi (0 : ℝ) := fun _ hz =>
+  Complex.mem_reProdIm.mpr ⟨abs_le.mp hz.1, hz.2.2⟩
+
+end Domain
+
+section Assembly
+
+open MeasureTheory
+
+variable {N : ℕ} [NeZero N] {n : ℕ}
+variable (f g : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2)) (F G : ℍ → ↥(BinaryForm ℂ n))
+    (v : ↥(BinaryForm ℂ n))
+
+noncomputable scoped instance fintypeQuot : Fintype (SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N) :=
+  (CongruenceSubgroup.Gamma0 N).fintypeQuotientOfFiniteIndex
+
+theorem weight_nonneg : (0 : ℤ) ≤ (n : ℤ) + 2 := by positivity
+
+def tileΦ (σ : SL(2, ℤ)) (z : ℂ) : ℂ :=
+  Pdat (⇑f) F G v (σ • ofComplex z) / denom (σ : GL (Fin 2) ℝ) (ofComplex z) ^ 2
+
+omit [NeZero N] in
+theorem tileΦ_eq (σ : SL(2, ℤ)) {z : ℂ} (hz : 0 < z.im) :
+    tileΦ f F G v σ z = TC (⇑f ∣[((n : ℤ) + 2)] σ) (trV σ F) (trV σ G) (binaryFormRepSL ℂ n σ⁻¹ v) z
+      := by
+  have hD : denom (σ : GL (Fin 2) ℝ) (ofComplex z) ≠ 0 := UpperHalfPlane.denom_ne_zero _ _
+  rw [tileΦ, Pdat_smul, mul_div_cancel_left₀ _ (pow_ne_zero 2 hD), Pdat_ofComplex _ _ _ _ hz]
+
+variable {f g F G}
+variable (hF : IsEichlerIntegral n f F) (hG : IsEichlerIntegral n g G)
+
+include hF hG in
+omit [NeZero N] in
+theorem continuousOn_tileΦ (σ : SL(2, ℤ)) : ContinuousOn (tileΦ f F G v σ) {z : ℂ | 0 < z.im} := by
+  have hA : IsEichlerIntegral n (⇑f ∣[((n : ℤ) + 2)] σ) (trV σ F) := hF.slash σ
+  have hB : IsEichlerIntegral n (⇑g ∣[((n : ℤ) + 2)] σ) (trV σ G) := hG.slash σ
+  have h : ContinuousOn (TC (⇑f ∣[((n : ℤ) + 2)] σ) (trV σ F) (trV σ G) (binaryFormRepSL ℂ n σ⁻¹ v))
+    {z : ℂ | 0 < z.im} :=
+    (continuousOn_fC f σ).mul (continuousOn_EC _ hA hB)
+  exact h.congr fun z hz => tileΦ_eq f F G v σ hz
+
+include hF hG in
+theorem tile_green (σ : SL(2, ℤ)) :
+    (∃ (δ C : ℝ), 0 < δ ∧ ∀ z ∈ Ubox, ‖tileΦ f F G v σ z‖ ≤ C * Real.exp (-δ * z.im)) ∧
+    (∫ z in fdC, 2 * Complex.I * (fC (⇑f ∣[((n : ℤ) + 2)] σ) z * conj (fC (⇑f ∣[((n : ℤ) + 2)] σ) z)
+      * (conj z - z) ^ n)) =
+      Complex.I • (∫ y in Set.Ioi (Real.sqrt 3 / 2), tileΦ f F G v σ (1 / 2 + y * Complex.I))
+        - Complex.I • (∫ y in Set.Ioi (Real.sqrt 3 / 2), tileΦ f F G v σ (-(1 / 2) + y * Complex.I))
+        - ∫ θ in (Real.pi / 3)..(2 * Real.pi / 3),
+            tileΦ f F G v σ (Complex.exp (θ * Complex.I)) * (Complex.I * Complex.exp (θ *
+              Complex.I)) := by
+  set φ : ℍ → ℂ := ⇑f ∣[((n : ℤ) + 2)] σ with hφdef
+  set ψ : ℍ → ℂ := ⇑g ∣[((n : ℤ) + 2)] σ with hψdef
+  set c₀ : ↥(BinaryForm ℂ n) := binaryFormRepSL ℂ n σ⁻¹ v with hc₀
+  have hA : IsEichlerIntegral n φ (trV σ F) := hF.slash σ
+  have hB : IsEichlerIntegral n ψ (trV σ G) := hG.slash σ
+  have hφ : DifferentiableOn ℂ (fC φ) {z : ℂ | 0 < z.im} := differentiableOn_fC f σ
+  have hψ : ContinuousOn (fC ψ) {z : ℂ | 0 < z.im} := continuousOn_fC g σ
+  have hk : (0 : ℤ) ≤ (n : ℤ) + 2 := weight_nonneg
+  have ha4 : (0 : ℝ) < 1 / 4 := by norm_num
+  obtain ⟨c₁, hc₁, C₁, hC₁0, hC₁⟩ := fC_decay f σ hk ha4
+  obtain ⟨c₂, hc₂, C₂, hC₂0, hC₂⟩ := deriv_fC_decay f σ hk
+  obtain ⟨c₃, hc₃, C₃, hC₃0, hC₃⟩ := fC_decay g σ hk ha4
+  set c := min c₁ (min c₂ c₃) with hcdef
+  have hc : 0 < c := lt_min hc₁ (lt_min hc₂ hc₃)
+  have hφd := decay_weaken hC₁0 (min_le_left c₁ (min c₂ c₃)) ha4.le hC₁
+  have hφ'd :=
+    decay_weaken hC₂0 ((min_le_right c₁ _).trans (min_le_left c₂ c₃))
+    (by norm_num : (0 : ℝ) ≤ 1 / 2) hC₂
+  have hψd := decay_weaken hC₃0 ((min_le_right c₁ _).trans (min_le_right c₂ c₃)) ha4.le hC₃
+  rw [← hcdef] at hφd hφ'd hψd
+  obtain ⟨⟨CT, hCT⟩, ⟨CD, hCD⟩⟩ := tile_bounds c₀ hA hB hc hφd hφ'd hψd
+  have hΦbd : ∀ z ∈ Ubox, ‖tileΦ f F G v σ z‖ ≤ CT * Real.exp (-(c / 2) * z.im) := by
+    intro z hz
+    rw [tileΦ_eq f F G v σ (im_pos_of_mem_Ubox hz)]
+    exact hCT z (Ubox_subset_strip hz)
+  refine ⟨⟨c / 2, CT, by positivity, hΦbd⟩, ?_⟩
+  have hE := Complex.integral_modularFundamentalDomain_eq_boundary_of_hasFDerivAt (tileΦ f F G v σ)
+    (TD φ ψ (trV σ F) (trV σ G) c₀) Ubox (c / 2) (by positivity) fdC_subset_Ubox
+    (fun z hz => (hasFDerivAt_TC c₀ hA hB hφ (im_pos_of_mem_Ubox hz)).congr_of_eventuallyEq
+      (Filter.eventually_of_mem (Ubox_mem_nhds hz) fun w hw => tileΦ_eq f F G v σ hw))
+    ((continuousOn_TD c₀ hA hB hφ hψ).mono fun z hz => im_pos_of_mem_Ubox hz)
+    ⟨CT, hΦbd⟩ ⟨CD, fun z hz => hCD z (Ubox_subset_strip hz)⟩
+  rw [← hE]
+  refine setIntegral_congr_fun measurableSet_fdC fun z _ => ?_
+  rw [I_smul_TD_sub]
+
+def rep (q : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N) : SL(2, ℤ) := (Quotient.out q)⁻¹
+
+variable (zF zG : CongruenceSubgroup.Gamma0 N → ↥(BinaryForm ℂ n))
+  (hFsm : ∀ (γ : CongruenceSubgroup.Gamma0 N) (τ : ℍ), F ((γ : SL(2, ℤ)) • τ) = zF γ +
+    binaryFormRepSL ℂ n γ (F τ))
+  (hGsm : ∀ (γ : CongruenceSubgroup.Gamma0 N) (τ : ℍ), G ((γ : SL(2, ℤ)) • τ) = zG γ +
+    binaryFormRepSL ℂ n γ (G τ))
+  (hcoc : ∀ γ : CongruenceSubgroup.Gamma0 N, (zF γ : MvPolynomial (Fin 2) ℂ) - conjP (zG γ :
+    MvPolynomial (Fin 2) ℂ)
+    = binarySubst ℂ ((γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) (v : MvPolynomial (Fin 2) ℂ) - v)
+
+include hF hG hFsm hGsm hcoc in
+theorem sum_tiles_eq_zero :
+    ∑ q : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N,
+      (∫ z in fdC, 2 * Complex.I * (fC (⇑f ∣[((n : ℤ) + 2)] (rep q)) z * conj (fC (⇑f ∣[((n : ℤ) +
+        2)] (rep q)) z)
+        * (conj z - z) ^ n)) = 0 := by
+  have hslash : ∀ γ : CongruenceSubgroup.Gamma0 N, ⇑f ∣[((n : ℤ) + 2)] (γ : SL(2, ℤ)) = ⇑f := by
+    intro γ
+    have :=
+      SlashInvariantForm.slash_action_eqn f ((γ : SL(2, ℤ)) : GL (Fin 2) ℝ) (Subgroup.mem_map.mpr
+        ⟨γ, γ.2, rfl⟩)
+    rw [ModularForm.SL_slash]
+    exact this
+  have hP : ∀ γ ∈ CongruenceSubgroup.Gamma0 N, ∀ τ : ℍ,
+      Pdat (⇑f) F G v (γ • τ) / denom (γ : GL (Fin 2) ℝ) τ ^ 2 = Pdat (⇑f) F G v τ + (fun _ : SL(2,
+        ℤ) => (0 : ℂ)) γ * (fun _ : ℍ => (0 : ℂ)) τ :=
+    fun γ hγ τ => Pdat_smul_of_mem (⇑f) hslash F G v zF zG hFsm hGsm hcoc γ hγ τ
+  have hsp :=
+    ModularCurve.gammaFundamentalSet_boundary_sidePairing_of_slash_eq_add (CongruenceSubgroup.Gamma0
+      N)
+    (Pdat (⇑f) F G v) (fun _ => 0) (fun _ => 0) hP (tileΦ f F G v)
+    (fun σ z => (fun _ : ℍ => (0 : ℂ)) (σ • ofComplex z) / denom (σ : GL (Fin 2) ℝ) (ofComplex z) ^
+      2)
+    (fun σ z => rfl) (fun σ z => rfl) (Set.Ioi (Real.sqrt 3 / 2)) measurableSet_Ioi
+    (Set.Ioi_subset_Ioi (by positivity)) (fun q => ?_) (fun q => ?_) (fun q => ?_) (fun q => ?_)
+  · have htile := fun q : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N => (tile_green v hF hG (rep q)).2
+    simp only [rep] at htile ⊢
+    rw [Finset.sum_congr rfl fun q _ => htile q, Finset.sum_sub_distrib, Finset.sum_sub_distrib, ←
+      Finset.smul_sum,
+      ← Finset.smul_sum, hsp.1]
+    have h2 := hsp.2
+    simp only [zero_mul, Finset.sum_const_zero, add_zero, neg_zero, mul_eq_zero,
+      OfNat.ofNat_ne_zero, false_or] at h2 ⊢
+    rw [h2, sub_self, zero_sub, neg_eq_zero]
+  · obtain ⟨δ, C, hδ, hb⟩ := (tile_green v hF hG (rep q)).1
+    exact integrableOn_ray (continuousOn_tileΦ v hF hG (rep q)) hδ hb
+  · simp only [zero_div]
+    exact integrableOn_zero
+  · exact intervalIntegrable_arc (continuousOn_tileΦ v hF hG (rep q))
+  · simp only [zero_div, zero_mul]
+    exact intervalIntegrable_const
+
+theorem integrand_eq (φ : ℂ → ℂ) (z : ℂ) :
+    2 * Complex.I * (φ z * conj (φ z) * (conj z - z) ^ n)
+      = (2 * Complex.I * (-2 * Complex.I) ^ n) * (((‖φ z‖ ^ 2 * z.im ^ n : ℝ)) : ℂ) := by
+  have h1 : φ z * conj (φ z) = ((‖φ z‖ ^ 2 : ℝ) : ℂ) := by
+    rw [Complex.mul_conj, Complex.normSq_eq_norm_sq]
+  have h2 : conj z - z = (-2 * Complex.I) * (z.im : ℂ) := by
+    apply Complex.ext <;> simp
+    ring
+  rw [h1, h2, mul_pow]
+  push_cast
+  ring
+
+include hF hG hFsm hGsm hcoc in
+theorem sum_norm_sq_integral_eq_zero :
+    ∑ q : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N,
+      (∫ z in fdC, ‖fC (⇑f ∣[((n : ℤ) + 2)] (rep q)) z‖ ^ 2 * z.im ^ n) = 0 := by
+  have h := sum_tiles_eq_zero v hF hG zF zG hFsm hGsm hcoc
+  have hK : (2 * Complex.I * (-2 * Complex.I) ^ n) ≠ 0 :=
+    mul_ne_zero (mul_ne_zero two_ne_zero Complex.I_ne_zero)
+    (pow_ne_zero _ (mul_ne_zero (by norm_num) Complex.I_ne_zero))
+  have hterm : ∀ q : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N,
+      (∫ z in fdC, 2 * Complex.I * (fC (⇑f ∣[((n : ℤ) + 2)] (rep q)) z * conj (fC (⇑f ∣[((n : ℤ) +
+        2)] (rep q)) z)
+        * (conj z - z) ^ n))
+      = (2 * Complex.I * (-2 * Complex.I) ^ n) *
+          (((∫ z in fdC, ‖fC (⇑f ∣[((n : ℤ) + 2)] (rep q)) z‖ ^ 2 * z.im ^ n : ℝ)) : ℂ) := by
+    intro q
+    rw [← integral_complex_ofReal, ← integral_const_mul]
+    refine setIntegral_congr_fun measurableSet_fdC fun z _ => ?_
+    exact integrand_eq (fC (⇑f ∣[((n : ℤ) + 2)] (rep q))) z
+  simp_rw [hterm] at h
+  rw [← Finset.mul_sum, mul_eq_zero, ← Complex.ofReal_sum, Complex.ofReal_eq_zero] at h
+  exact h.resolve_left hK
+
+include hF hG hFsm hGsm hcoc in
+theorem norm_sq_integral_eq_zero :
+    (∫ z in fdC, ‖fC (⇑f ∣[((n : ℤ) + 2)] (rep (QuotientGroup.mk 1 : SL(2, ℤ) ⧸
+      CongruenceSubgroup.Gamma0 N))) z‖ ^ 2 * z.im ^ n) = 0 := by
+  have h := sum_norm_sq_integral_eq_zero v hF hG zF zG hFsm hGsm hcoc
+  have hnn : ∀ q ∈ (Finset.univ : Finset (SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N)),
+      0 ≤ ∫ z in fdC, ‖fC (⇑f ∣[((n : ℤ) + 2)] (rep q)) z‖ ^ 2 * z.im ^ n := by
+    intro q _
+    refine setIntegral_nonneg measurableSet_fdC fun z hz => ?_
+    have := hz.2.2
+    positivity
+  exact (Finset.sum_eq_zero_iff_of_nonneg hnn).mp h _ (Finset.mem_univ _)
+
+omit [NeZero N] in
+theorem rep_one_mem :
+    rep (QuotientGroup.mk 1 : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N) ∈ CongruenceSubgroup.Gamma0 N
+      := by
+  have h := (QuotientGroup.mk (1 : SL(2, ℤ)) : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N).out_eq
+  rw [QuotientGroup.eq] at h
+  simpa [rep] using h
+
+def fdInt : Set ℂ := {z : ℂ | |z.re| < 1 / 2 ∧ 1 < ‖z‖ ∧ 0 < z.im}
+
+theorem isOpen_fdInt : IsOpen fdInt :=
+  (isOpen_lt (continuous_abs.comp Complex.continuous_re) continuous_const).inter
+    ((isOpen_lt continuous_const continuous_norm).inter (isOpen_lt continuous_const
+      Complex.continuous_im))
+
+theorem fdInt_subset_fdC : fdInt ⊆ fdC := fun _ hz => ⟨hz.1.le, hz.2.1.le, hz.2.2⟩
+
+theorem two_I_mem_fdInt : (2 * Complex.I : ℂ) ∈ fdInt := by
+  refine ⟨?_, ?_, ?_⟩
+  · simp
+  · rw [norm_mul, Complex.norm_two, Complex.norm_I]; norm_num
+  · simp
+
+include hF hG hFsm hGsm hcoc in
+theorem f_eq_zero : f = 0 := by
+  set σ₀ : SL(2, ℤ) := rep (QuotientGroup.mk 1 : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N) with hσ₀
+  have hσ₀mem : σ₀ ∈ CongruenceSubgroup.Gamma0 N := rep_one_mem
+  have hslash : ⇑f ∣[((n : ℤ) + 2)] σ₀ = ⇑f := by
+    have :=
+      SlashInvariantForm.slash_action_eqn f (σ₀ : GL (Fin 2) ℝ) (Subgroup.mem_map.mpr ⟨σ₀, hσ₀mem,
+        rfl⟩)
+    rw [ModularForm.SL_slash]
+    exact this
+  have h0 := norm_sq_integral_eq_zero v hF hG zF zG hFsm hGsm hcoc
+  rw [← hσ₀] at h0
+  set h : ℂ → ℝ := fun z => ‖fC (⇑f ∣[((n : ℤ) + 2)] σ₀) z‖ ^ 2 * z.im ^ n with hh
+  have hk : (0 : ℤ) ≤ (n : ℤ) + 2 := weight_nonneg
+  obtain ⟨c₁, hc₁, C₁, hC₁0, hC₁⟩ := fC_decay f σ₀ hk (by norm_num : (0 : ℝ) < 1 / 4)
+  obtain ⟨K, hK0, hK⟩ := poly_exp_bound (2 * c₁) (by positivity) (2 * n)
+  have hcont : ContinuousOn h {z : ℂ | 0 < z.im} :=
+    ((continuousOn_fC f σ₀).norm.pow 2).mul (by fun_prop)
+  have hbound : ∀ z ∈ fdC, ‖h z‖ ≤ C₁ ^ 2 * K * Real.exp (-(2 * c₁ / 2) * z.im) := by
+    intro z hz
+    have hzs : z ∈ strip := Ubox_subset_strip (fdC_subset_Ubox hz)
+    have hz0 := hz.2.2
+    have h1 := hC₁ z (by linarith [hzs.1])
+    have him : z.im ^ n ≤ (2 + z.im) ^ (2 * n) :=
+      (pow_le_pow_left₀ hz0.le (by linarith) n).trans (pow_le_pow_two_mul hzs)
+    rw [Real.norm_eq_abs, abs_of_nonneg (by positivity)]
+    calc ‖fC (⇑f ∣[((n : ℤ) + 2)] σ₀) z‖ ^ 2 * z.im ^ n
+        ≤ (C₁ * Real.exp (-c₁ * z.im)) ^ 2 * (2 + z.im) ^ (2 * n) :=
+          mul_le_mul (pow_le_pow_left₀ (norm_nonneg _) h1 2) him (by positivity) (by positivity)
+      _ = C₁ ^ 2 * ((2 + z.im) ^ (2 * n) * Real.exp (-(2 * c₁) * z.im)) := by
+          rw [mul_pow, ← Real.exp_nat_mul]; push_cast; ring_nf
+      _ ≤ C₁ ^ 2 * (K * Real.exp (-(2 * c₁ / 2) * z.im)) :=
+          mul_le_mul_of_nonneg_left (hK z.im hz0.le) (by positivity)
+      _ = _ := by ring
+  have hint : IntegrableOn h fdC := by
+    refine Integrable.mono' ((((integrableOn_exp_neg_im (by positivity : (0 : ℝ) < 2 * c₁ / 2)
+      (-(1 / 2)) (1 / 2)).mono_set
+      fdC_subset_prod).const_mul (C₁ ^ 2 * K))) ?_ ?_
+    · exact (hcont.mono (t := fdC) fun z hz => hz.2.2).aestronglyMeasurable measurableSet_fdC
+    · exact ae_restrict_of_forall_mem measurableSet_fdC hbound
+  have hnn : 0 ≤ᵐ[volume.restrict fdC] h :=
+    ae_restrict_of_forall_mem measurableSet_fdC fun z hz => by have := hz.2.2; positivity
+  have hae : h =ᵐ[volume.restrict fdC] 0 := (setIntegral_eq_zero_iff_of_nonneg_ae hnn hint).mp h0
+  have hae' : h =ᵐ[volume.restrict fdInt] 0 :=
+    ae_restrict_of_ae_restrict_of_subset fdInt_subset_fdC hae
+  have heq : Set.EqOn h 0 fdInt :=
+    Measure.eqOn_open_of_ae_eq hae' isOpen_fdInt
+      (hcont.mono (t := fdInt) fun z hz => hz.2.2) continuousOn_const
+  have hvan : ∀ z ∈ fdInt, f (ofComplex z) = 0 := by
+    intro z hz
+    have h1 := heq hz
+    simp only [hh, Pi.zero_apply, mul_eq_zero, pow_eq_zero_iff, ne_eq, OfNat.ofNat_ne_zero,
+      not_false_eq_true,
+      norm_eq_zero] at h1
+    rcases h1 with h1 | h1
+    · rw [fC, hslash] at h1; exact h1
+    · exfalso
+      rcases n.eq_zero_or_pos with hn | hn
+      · simp [hn] at h1
+      · rw [pow_eq_zero_iff hn.ne'] at h1
+        exact absurd h1 hz.2.2.ne'
+  have hanal : AnalyticOnNhd ℂ (⇑f ∘ ofComplex) {z : ℂ | 0 < z.im} :=
+    (UpperHalfPlane.mdifferentiable_iff.mp (ModularFormClass.holo f)).analyticOnNhd
+      isOpen_upperHalfPlaneSet
+  have hpre : IsPreconnected {z : ℂ | 0 < z.im} := (convex_halfSpace_im_gt 0).isPreconnected
+  have h2I : (2 * Complex.I : ℂ) ∈ {z : ℂ | 0 < z.im} := by change 0 < (2 * Complex.I : ℂ).im; simp
+  have hev : (⇑f ∘ ofComplex) =ᶠ[nhds (2 * Complex.I : ℂ)] 0 :=
+    Filter.eventuallyEq_of_mem (isOpen_fdInt.mem_nhds two_I_mem_fdInt) fun z hz => hvan z hz
+  have hzero := hanal.eqOn_zero_of_preconnected_of_eventuallyEq_zero hpre h2I hev
+  ext τ
+  have := hzero τ.im_pos
+  simp only [Function.comp_apply, Pi.zero_apply, ofComplex_apply] at this
+  simp [this]
+
+end Assembly
+
+end HeckeEis.ESDisjoint
+
+theorem solution (N : ℕ) [NeZero N] (n : ℕ)
+    (ES : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2) →ₗ[ℂ] HeckeEis.coeffH1par
+      ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype))
+    (hES : ∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2), ES f =
+      HeckeEis.eichlerShimuraMap n N f)
+    (Φ : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+      N).subtype) →+ HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype))
+    (hΦ : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+        (CongruenceSubgroup.Gamma0 N).subtype)),
+        (∀ g : CongruenceSubgroup.Gamma0 N, ((w : CongruenceSubgroup.Gamma0 N →
+          ↥(HeckeEis.BinaryForm ℂ n)) g : MvPolynomial (Fin 2) ℂ)
+            = MvPolynomial.map (starRingEnd ℂ)
+                (((z : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n)) g : MvPolynomial
+                  (Fin 2) ℂ))) ∧
+        Φ (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w)
+    (f g : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2)) (hfg : ES f = Φ (ES g))
+    : f = 0 := by
+  obtain ⟨F, G, v, zF, zG, hF, hG, hFsm, hGsm, hcoc⟩ :=
+    HeckeEis.ESDisjoint.unpack N n ES hES Φ hΦ f g hfg
+  exact HeckeEis.ESDisjoint.f_eq_zero v hF hG zF zG hFsm hGsm hcoc
+
+end privateSection
+
+public section publicSection
+
+open scoped MatrixGroups
+theorem HeckeEis.range_eichlerShimuraMap_inf_range_conj_eq_bot (N : ℕ) [NeZero N] (n : ℕ)
+    (ES : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2) →ₗ[ℂ] HeckeEis.coeffH1par
+      ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0 N).subtype))
+    (hES : ∀ f : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2), ES f =
+      HeckeEis.eichlerShimuraMap n N f)
+    (Φ : HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp (CongruenceSubgroup.Gamma0
+      N).subtype) →+ HeckeEis.coeffH1par ((HeckeEis.binaryFormRepSL ℂ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype))
+    (hΦ : ∀ z : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+      (CongruenceSubgroup.Gamma0 N).subtype)),
+      ∃ w : ↥(HeckeEis.coeffParabolicCocycles ((HeckeEis.binaryFormRepSL ℂ n).comp
+        (CongruenceSubgroup.Gamma0 N).subtype)),
+        (∀ g : CongruenceSubgroup.Gamma0 N, ((w : CongruenceSubgroup.Gamma0 N →
+          ↥(HeckeEis.BinaryForm ℂ n)) g : MvPolynomial (Fin 2) ℂ)
+            = MvPolynomial.map (starRingEnd ℂ)
+                (((z : CongruenceSubgroup.Gamma0 N → ↥(HeckeEis.BinaryForm ℂ n)) g : MvPolynomial
+                  (Fin 2) ℂ))) ∧
+        Φ (HeckeEis.coeffH1parMk _ z) = HeckeEis.coeffH1parMk _ w)
+    (f g : CuspForm (CongruenceSubgroup.Gamma0 N) ((n : ℤ) + 2)) (hfg : ES f = Φ (ES g))
+    : f = 0 :=
+  solution N n ES hES Φ hΦ f g hfg
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_HexagonalLattice_summable_thetaTerm_and_tsum_neg_inv_three_mul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_HexagonalLattice_summable_thetaTerm_and_tsum_neg_inv_three_mul.lean
new file mode 100644
index 0000000000..886ea4d95f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_HexagonalLattice_summable_thetaTerm_and_tsum_neg_inv_three_mul.lean
@@ -0,0 +1,475 @@
+/-
+Based on Prove2Me node HexagonalLattice.summable_thetaTerm_and_tsum_neg_inv_three_mul
+(f6d8786d-6c1c-52ca-a550-a44c58b3164f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2ac85e29-e029-53a5-ba40-d4415d4042aa
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.CStarAlgebra.Classes
+public import Mathlib.Analysis.SpecialFunctions.Trigonometric.Basic
+
+import Mathlib.Analysis.SpecialFunctions.Gaussian.PoissonSummation
+import Mathlib.Analysis.PSeries
+import Mathlib.LinearAlgebra.Complex.FiniteDimensional
+import Mathlib.Topology.Separation.CompletelyRegular
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Theta series of x²+xy+y²: convergence and Fricke law
+
+Theorem statement: `HexagonalLattice.summable_thetaTerm_and_tsum_neg_inv_three_mul`
+(`f6d8786d-6c1c-52ca-a550-a44c58b3164f`), by Claude, 2026-09-05.
+
+Proof: submission `2ac85e29-e029-53a5-ba40-d4415d4042aa`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\sigma$ be a complex number with $\operatorname{Im}\sigma>0$. Write $Q(m,n)=m^2+mn+n^2$ for the
+norm form of the Eisenstein integers and, for a complex parameter $\tau$, consider the family
+indexed by pairs of integers $p=(p_1,p_2)$ whose term is $\exp\bigl(2\pi i\,\tau\,Q(p_1,p_2)\bigr)$,
+the integers being coerced into $\mathbb{C}$. The theorem asserts two things simultaneously. First,
+for the parameter $\tau=\sigma$ the family $p\mapsto \exp\bigl(2\pi
+i\,\sigma\,(p_1^2+p_1p_2+p_2^2)\bigr)$ is summable over $\mathbb{Z}\times\mathbb{Z}$, i.e. the
+double theta series $\Theta(\sigma)=\sum_{(m,n)\in\mathbb{Z}^2}e^{2\pi i\sigma(m^2+mn+n^2)}$
+converges unconditionally (equivalently, absolutely). Second, the unconditional sums at the
+parameters $-1/(3\sigma)$ and $\sigma$ are related by
+$$\sum_{(m,n)\in\mathbb{Z}^2}e^{2\pi
+i\,(-1/(3\sigma))\,(m^2+mn+n^2)}=-i\,\sqrt{3}\,\sigma\sum_{(m,n)\in\mathbb{Z}^2}e^{2\pi
+i\,\sigma\,(m^2+mn+n^2)},$$
+where $\sqrt{3}$ is the real square root coerced into $\mathbb{C}$; that is,
+$\Theta(-1/(3\sigma))=-i\sqrt{3}\,\sigma\,\Theta(\sigma)$. Summability at the parameter
+$-1/(3\sigma)$ is not part of the assertion, the left-hand side being the Lean unconditional sum.
+
+This is the weight-one Fricke (Atkin–Lehner) transformation law at level $3$ for the theta series of
+the positive definite form $x^2+xy+y^2$ of discriminant $-3$, together with the convergence
+statement that makes it meaningful; classically it is the case $Q=x^2+xy+y^2$ of the theta
+transformation formula obtained from Poisson summation, the hexagonal lattice being its own dual up
+to scaling by $3$. It serves as the source of an explicit weight-one form on $\Gamma_1(3)$ with a
+known behaviour under the Fricke involution, and is used in the construction of such a form and in
+the analysis of $q$-expansion coefficients of Atkin–Lehner translates at levels dividing a power of
+$2\cdot 3$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_HexagonalLattice_summable_thetaTerm_and_tsum_neg_inv_three_mul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_HexagonalLattice_summable_thetaTerm_and_tsum_neg_inv_three_mul
+
+
+open Complex Real
+
+open scoped Topology
+
+namespace A2HexPoisson
+
+noncomputable section
+
+def hexThetaTerm (σ : ℂ) (p : ℤ × ℤ) : ℂ :=
+  cexp (2 * π * I * σ * ((p.1 : ℂ) ^ 2 + (p.1 : ℂ) * (p.2 : ℂ) + (p.2 : ℂ) ^ 2))
+
+def hexTheta (σ : ℂ) : ℂ :=
+  ∑' p : ℤ × ℤ, hexThetaTerm σ p
+
+lemma hexThetaTerm_swap (σ : ℂ) (x y : ℤ) :
+    hexThetaTerm σ (x, y) = hexThetaTerm σ (y, x) := by
+  unfold hexThetaTerm
+  congr 1
+  push_cast
+  ring
+
+lemma hexThetaTerm_zero_zero (σ : ℂ) : hexThetaTerm σ (0, 0) = 1 := by
+  simp [hexThetaTerm]
+
+lemma norm_hexThetaTerm (σ : ℂ) (p : ℤ × ℤ) :
+    ‖hexThetaTerm σ p‖ =
+      rexp (-(2 * π * σ.im) * ((p.1 : ℝ) ^ 2 + (p.1 : ℝ) * (p.2 : ℝ) + (p.2 : ℝ) ^ 2)) := by
+  rw [hexThetaTerm, Complex.norm_exp]
+  congr 1
+  rw [show (2 * (π : ℂ) * I * σ * ((p.1 : ℂ) ^ 2 + (p.1 : ℂ) * (p.2 : ℂ) + (p.2 : ℂ) ^ 2)) =
+      (((2 * π * ((p.1 : ℝ) ^ 2 + (p.1 : ℝ) * (p.2 : ℝ) + (p.2 : ℝ) ^ 2) : ℝ)) : ℂ) * (σ * I) by
+    push_cast; ring]
+  rw [Complex.re_ofReal_mul, Complex.mul_I_re]
+  ring
+
+lemma sq_add_sq_le_two_mul_form (x y : ℝ) :
+    x ^ 2 + y ^ 2 ≤ 2 * (x ^ 2 + x * y + y ^ 2) := by
+  nlinarith [sq_nonneg (x + y)]
+
+lemma summable_norm_cexp_neg_quadratic {a : ℂ} (ha : 0 < a.re) (b : ℂ) :
+    Summable fun n : ℤ => ‖cexp (-π * a * (n : ℂ) ^ 2 + 2 * π * b * (n : ℂ))‖ := by
+  rw [summable_norm_iff]
+  have hre : (-(π : ℂ) * a).re < 0 := by
+    rw [neg_mul, neg_re, Complex.re_ofReal_mul, neg_lt_zero]
+    exact mul_pos pi_pos ha
+  have hO : (fun x : ℝ => cexp (-(π : ℂ) * a * (x : ℂ) ^ 2 + 2 * π * b * (x : ℂ)))
+      =O[Filter.cocompact ℝ] fun x : ℝ => |x| ^ (-2 : ℝ) :=
+    (cexp_neg_quadratic_isLittleO_abs_rpow_cocompact hre (2 * π * b) (-2)).isBigO
+  have hZ := hO.comp_tendsto Int.tendsto_coe_cofinite
+  simp only [Function.comp_def, Complex.ofReal_intCast] at hZ
+  exact summable_of_isBigO (Real.summable_abs_int_rpow one_lt_two) hZ
+
+lemma summable_cexp_neg_quadratic {a : ℂ} (ha : 0 < a.re) (b : ℂ) :
+    Summable fun n : ℤ => cexp (-π * a * (n : ℂ) ^ 2 + 2 * π * b * (n : ℂ)) :=
+  (summable_norm_cexp_neg_quadratic ha b).of_norm
+
+lemma summable_rexp_neg_mul_int_sq {c : ℝ} (hc : 0 < c) :
+    Summable fun n : ℤ => rexp (-(c * (n : ℝ) ^ 2)) := by
+  have h0 : (0 : ℝ) < ((c / π : ℝ) : ℂ).re := by
+    rw [Complex.ofReal_re]
+    exact div_pos hc pi_pos
+  refine (summable_norm_cexp_neg_quadratic h0 0).congr fun n => ?_
+  rw [mul_zero, zero_mul, add_zero, Complex.norm_exp]
+  congr 1
+  rw [show (-(π : ℂ) * ((c / π : ℝ) : ℂ) * (n : ℂ) ^ 2) = ((-(c * (n : ℝ) ^ 2) : ℝ) : ℂ) by
+    push_cast
+    field_simp]
+  exact Complex.ofReal_re _
+
+lemma summable_hexThetaTerm {σ : ℂ} (hσ : 0 < σ.im) : Summable (hexThetaTerm σ) := by
+  apply Summable.of_norm
+  have hbound : ∀ p : ℤ × ℤ, ‖hexThetaTerm σ p‖ ≤
+      rexp (-(π * σ.im * (p.1 : ℝ) ^ 2)) * rexp (-(π * σ.im * (p.2 : ℝ) ^ 2)) := by
+    intro p
+    rw [norm_hexThetaTerm, ← Real.exp_add, Real.exp_le_exp]
+    nlinarith [sq_add_sq_le_two_mul_form (p.1 : ℝ) (p.2 : ℝ), mul_pos pi_pos hσ]
+  exact Summable.of_nonneg_of_le (fun p => norm_nonneg _) hbound
+    (Summable.mul_of_nonneg
+      (summable_rexp_neg_mul_int_sq (mul_pos pi_pos hσ))
+      (summable_rexp_neg_mul_int_sq (mul_pos pi_pos hσ))
+      (fun n => (Real.exp_pos _).le) (fun n => (Real.exp_pos _).le))
+
+lemma ne_zero_of_im_pos {σ : ℂ} (hσ : 0 < σ.im) : σ ≠ 0 := by
+  rintro rfl
+  simp at hσ
+
+lemma re_neg_two_I_mul {σ : ℂ} (hσ : 0 < σ.im) : 0 < (-2 * I * σ).re := by
+  rw [show (-2 * I * σ : ℂ) = ((-2 : ℝ) : ℂ) * (σ * I) by push_cast; ring,
+    Complex.re_ofReal_mul, Complex.mul_I_re]
+  linarith
+
+lemma re_neg_three_I_mul_div_two {σ : ℂ} (hσ : 0 < σ.im) : 0 < (-3 * I * σ / 2).re := by
+  rw [show (-3 * I * σ / 2 : ℂ) = ((-3 / 2 : ℝ) : ℂ) * (σ * I) by push_cast; ring,
+    Complex.re_ofReal_mul, Complex.mul_I_re]
+  linarith
+
+lemma im_neg_one_div_three_mul_pos {σ : ℂ} (hσ : 0 < σ.im) : 0 < (-1 / (3 * σ)).im := by
+  have h3σ : (3 : ℂ) * σ ≠ 0 := mul_ne_zero (by norm_num) (ne_zero_of_im_pos hσ)
+  have him : ((3 : ℂ) * σ).im = 3 * σ.im := by
+    simp [Complex.mul_im]
+  rw [show (-1 / (3 * σ) : ℂ) = -((3 : ℂ) * σ)⁻¹ by rw [neg_div, one_div]]
+  rw [Complex.neg_im, Complex.inv_im, neg_div, neg_neg, him]
+  exact div_pos (by linarith) (Complex.normSq_pos.mpr h3σ)
+
+lemma neg_pi_div_neg_two_I_mul {σ : ℂ} (hσ : σ ≠ 0) :
+    -(π : ℂ) / (-2 * I * σ) = -((π : ℂ) * I) / (2 * σ) := by
+  rw [div_eq_div_iff (mul_ne_zero (mul_ne_zero (by norm_num) Complex.I_ne_zero) hσ)
+    (mul_ne_zero (by norm_num) hσ)]
+  linear_combination (-2 * (π : ℂ) * σ) * Complex.I_sq
+
+lemma neg_pi_div_neg_three_I_mul_div_two {σ : ℂ} (hσ : σ ≠ 0) :
+    -(π : ℂ) / (-3 * I * σ / 2) = -(2 * (π : ℂ) * I) / (3 * σ) := by
+  rw [div_eq_div_iff
+    (div_ne_zero (mul_ne_zero (mul_ne_zero (by norm_num) Complex.I_ne_zero) hσ) (by norm_num))
+    (mul_ne_zero (by norm_num) hσ)]
+  linear_combination (-3 * (π : ℂ) * σ) * Complex.I_sq
+
+lemma I_mul_I_mul (w : ℂ) : I * (I * w) = -w := by
+  rw [← mul_assoc, Complex.I_mul_I, neg_one_mul]
+
+lemma exponent_initial (σ : ℂ) (x y : ℤ) :
+    2 * π * I * σ * ((x : ℂ) ^ 2 + (x : ℂ) * (y : ℂ) + (y : ℂ) ^ 2) =
+      2 * π * I * σ * (x : ℂ) ^ 2 +
+        (-π * (-2 * I * σ) * (y : ℂ) ^ 2 + 2 * π * (I * σ * (x : ℂ)) * (y : ℂ)) := by
+  ring
+
+lemma exponent_split {σ : ℂ} (hσ : σ ≠ 0) (x m : ℤ) :
+    2 * π * I * σ * (x : ℂ) ^ 2 +
+        -π / (-2 * I * σ) * ((m : ℂ) + I * (I * σ * (x : ℂ))) ^ 2 =
+      (-π * (-3 * I * σ / 2) * (x : ℂ) ^ 2 + 2 * π * (I * (m : ℂ) / 2) * (x : ℂ)) +
+        -π / (-2 * I * σ) * (m : ℂ) ^ 2 := by
+  rw [show I * (I * σ * (x : ℂ)) = -(σ * (x : ℂ)) by
+    linear_combination (σ * (x : ℂ)) * Complex.I_sq, neg_pi_div_neg_two_I_mul hσ]
+  field_simp
+  ring
+
+lemma exponent_total {σ : ℂ} (hσ : σ ≠ 0) (m k : ℤ) :
+    -π / (-2 * I * σ) * (m : ℂ) ^ 2 +
+        -π / (-3 * I * σ / 2) * ((k : ℂ) + I * (I * (m : ℂ) / 2)) ^ 2 =
+      2 * π * I * (-1 / (3 * σ)) *
+        ((k : ℂ) ^ 2 + (k : ℂ) * (-(m : ℂ)) + (-(m : ℂ)) ^ 2) := by
+  rw [show I * (I * (m : ℂ) / 2) = -((m : ℂ) / 2) by
+    linear_combination ((m : ℂ) / 2) * Complex.I_sq, neg_pi_div_neg_two_I_mul hσ,
+    neg_pi_div_neg_three_I_mul_div_two hσ]
+  field_simp
+  ring
+
+lemma inner_poisson {σ : ℂ} (hσ : 0 < σ.im) (x : ℤ) :
+    (∑' y : ℤ, hexThetaTerm σ (x, y)) =
+      1 / (-2 * I * σ) ^ (1 / 2 : ℂ) *
+        ∑' m : ℤ,
+          (cexp (-π * (-3 * I * σ / 2) * (x : ℂ) ^ 2 + 2 * π * (I * (m : ℂ) / 2) * (x : ℂ)) *
+            cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2)) := by
+  have ha : 0 < (-2 * I * σ).re := re_neg_two_I_mul hσ
+  have hσ0 : σ ≠ 0 := ne_zero_of_im_pos hσ
+  calc
+    (∑' y : ℤ, hexThetaTerm σ (x, y)) =
+        ∑' y : ℤ, cexp (2 * π * I * σ * (x : ℂ) ^ 2) *
+          cexp (-π * (-2 * I * σ) * (y : ℂ) ^ 2 + 2 * π * (I * σ * (x : ℂ)) * (y : ℂ)) := by
+      refine tsum_congr fun y => ?_
+      rw [hexThetaTerm, ← Complex.exp_add]
+      exact congrArg cexp (exponent_initial σ x y)
+    _ = cexp (2 * π * I * σ * (x : ℂ) ^ 2) *
+        ∑' y : ℤ, cexp (-π * (-2 * I * σ) * (y : ℂ) ^ 2 + 2 * π * (I * σ * (x : ℂ)) * (y : ℂ)) :=
+      tsum_mul_left
+    _ = cexp (2 * π * I * σ * (x : ℂ) ^ 2) *
+        (1 / (-2 * I * σ) ^ (1 / 2 : ℂ) *
+          ∑' m : ℤ, cexp (-π / (-2 * I * σ) * ((m : ℂ) + I * (I * σ * (x : ℂ))) ^ 2)) := by
+      rw [Complex.tsum_exp_neg_quadratic ha (I * σ * (x : ℂ))]
+    _ = 1 / (-2 * I * σ) ^ (1 / 2 : ℂ) *
+        ∑' m : ℤ, cexp (2 * π * I * σ * (x : ℂ) ^ 2) *
+          cexp (-π / (-2 * I * σ) * ((m : ℂ) + I * (I * σ * (x : ℂ))) ^ 2) := by
+      rw [tsum_mul_left]
+      ring
+    _ = 1 / (-2 * I * σ) ^ (1 / 2 : ℂ) *
+        ∑' m : ℤ,
+          (cexp (-π * (-3 * I * σ / 2) * (x : ℂ) ^ 2 + 2 * π * (I * (m : ℂ) / 2) * (x : ℂ)) *
+            cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2)) := by
+      congr 1
+      refine tsum_congr fun m => ?_
+      rw [← Complex.exp_add, ← Complex.exp_add]
+      exact congrArg cexp (exponent_split hσ0 x m)
+
+lemma outer_poisson {σ : ℂ} (hσ : 0 < σ.im) (m : ℤ) :
+    (∑' x : ℤ,
+        (cexp (-π * (-3 * I * σ / 2) * (x : ℂ) ^ 2 + 2 * π * (I * (m : ℂ) / 2) * (x : ℂ)) *
+          cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2))) =
+      1 / (-3 * I * σ / 2) ^ (1 / 2 : ℂ) *
+        ∑' k : ℤ, hexThetaTerm (-1 / (3 * σ)) (k, -m) := by
+  have ha : 0 < (-3 * I * σ / 2).re := re_neg_three_I_mul_div_two hσ
+  have hσ0 : σ ≠ 0 := ne_zero_of_im_pos hσ
+  calc
+    (∑' x : ℤ,
+        (cexp (-π * (-3 * I * σ / 2) * (x : ℂ) ^ 2 + 2 * π * (I * (m : ℂ) / 2) * (x : ℂ)) *
+          cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2))) =
+        (∑' x : ℤ,
+          cexp (-π * (-3 * I * σ / 2) * (x : ℂ) ^ 2 + 2 * π * (I * (m : ℂ) / 2) * (x : ℂ))) *
+          cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2) :=
+      tsum_mul_right
+    _ = (1 / (-3 * I * σ / 2) ^ (1 / 2 : ℂ) *
+          ∑' k : ℤ, cexp (-π / (-3 * I * σ / 2) * ((k : ℂ) + I * (I * (m : ℂ) / 2)) ^ 2)) *
+          cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2) := by
+      rw [Complex.tsum_exp_neg_quadratic ha (I * (m : ℂ) / 2)]
+    _ = 1 / (-3 * I * σ / 2) ^ (1 / 2 : ℂ) *
+          ∑' k : ℤ, cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2) *
+            cexp (-π / (-3 * I * σ / 2) * ((k : ℂ) + I * (I * (m : ℂ) / 2)) ^ 2) := by
+      rw [tsum_mul_left]
+      ring
+    _ = 1 / (-3 * I * σ / 2) ^ (1 / 2 : ℂ) *
+          ∑' k : ℤ, hexThetaTerm (-1 / (3 * σ)) (k, -m) := by
+      congr 1
+      refine tsum_congr fun k => ?_
+      rw [← Complex.exp_add, hexThetaTerm]
+      refine congrArg cexp ?_
+      push_cast
+      exact exponent_total hσ0 m k
+
+lemma summable_middle {σ : ℂ} (hσ : 0 < σ.im) :
+    Summable (Function.uncurry fun x m : ℤ =>
+      cexp (-π * (-3 * I * σ / 2) * (x : ℂ) ^ 2 + 2 * π * (I * (m : ℂ) / 2) * (x : ℂ)) *
+        cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2)) := by
+  have ha₁ : 0 < (-3 * I * σ / 2).re := re_neg_three_I_mul_div_two hσ
+  have ha₂ : 0 < ((-2 * I * σ)⁻¹).re := by
+    rw [Complex.inv_re]
+    exact div_pos (re_neg_two_I_mul hσ) (Complex.normSq_pos.mpr
+      (mul_ne_zero (mul_ne_zero (by norm_num) Complex.I_ne_zero) (ne_zero_of_im_pos hσ)))
+  apply Summable.of_norm
+  refine Summable.congr
+    (Summable.mul_of_nonneg (summable_norm_cexp_neg_quadratic ha₁ 0)
+      (summable_norm_cexp_neg_quadratic ha₂ 0)
+      (fun x => norm_nonneg _) (fun m => norm_nonneg _)) ?_
+  rintro ⟨x, m⟩
+  simp only [Function.uncurry_apply_pair, norm_mul]
+  congr 1
+  · rw [Complex.norm_exp, Complex.norm_exp]
+    congr 1
+    simp only [Complex.add_re]
+    congr 1
+    rw [show (2 * (π : ℂ) * (0 : ℂ) * (x : ℂ)) = (0 : ℂ) by ring,
+      show (2 * (π : ℂ) * (I * (m : ℂ) / 2) * (x : ℂ)) =
+        ((π * (m : ℝ) * (x : ℝ) : ℝ) : ℂ) * I by push_cast; ring]
+    rw [Complex.zero_re, Complex.re_ofReal_mul, Complex.I_re, mul_zero]
+  · refine congrArg norm (congrArg cexp ?_)
+    rw [mul_zero, zero_mul, add_zero, div_eq_mul_inv]
+
+theorem hexTheta_eq_mul_self_neg_inv {σ : ℂ} (hσ : 0 < σ.im) :
+    hexTheta σ =
+      1 / (-2 * I * σ) ^ (1 / 2 : ℂ) * (1 / (-3 * I * σ / 2) ^ (1 / 2 : ℂ)) *
+        hexTheta (-1 / (3 * σ)) := by
+  have hσ' : 0 < (-1 / (3 * σ)).im := im_neg_one_div_three_mul_pos hσ
+  calc
+    hexTheta σ = ∑' x : ℤ, ∑' y : ℤ, hexThetaTerm σ (x, y) :=
+      (summable_hexThetaTerm hσ).tsum_prod
+    _ = ∑' x : ℤ, (1 / (-2 * I * σ) ^ (1 / 2 : ℂ) *
+          ∑' m : ℤ,
+            (cexp (-π * (-3 * I * σ / 2) * (x : ℂ) ^ 2 + 2 * π * (I * (m : ℂ) / 2) * (x : ℂ)) *
+              cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2))) :=
+      tsum_congr fun x => inner_poisson hσ x
+    _ = 1 / (-2 * I * σ) ^ (1 / 2 : ℂ) *
+          ∑' x : ℤ, ∑' m : ℤ,
+            (cexp (-π * (-3 * I * σ / 2) * (x : ℂ) ^ 2 + 2 * π * (I * (m : ℂ) / 2) * (x : ℂ)) *
+              cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2)) :=
+      tsum_mul_left
+    _ = 1 / (-2 * I * σ) ^ (1 / 2 : ℂ) *
+          ∑' m : ℤ, ∑' x : ℤ,
+            (cexp (-π * (-3 * I * σ / 2) * (x : ℂ) ^ 2 + 2 * π * (I * (m : ℂ) / 2) * (x : ℂ)) *
+              cexp (-π / (-2 * I * σ) * (m : ℂ) ^ 2)) := by
+      congr 1
+      exact ((summable_middle hσ).tsum_comm).symm
+    _ = 1 / (-2 * I * σ) ^ (1 / 2 : ℂ) *
+          ∑' m : ℤ, (1 / (-3 * I * σ / 2) ^ (1 / 2 : ℂ) *
+            ∑' k : ℤ, hexThetaTerm (-1 / (3 * σ)) (k, -m)) := by
+      congr 1
+      exact tsum_congr fun m => outer_poisson hσ m
+    _ = 1 / (-2 * I * σ) ^ (1 / 2 : ℂ) * (1 / (-3 * I * σ / 2) ^ (1 / 2 : ℂ) *
+          ∑' m : ℤ, ∑' k : ℤ, hexThetaTerm (-1 / (3 * σ)) (k, -m)) := by
+      rw [tsum_mul_left]
+    _ = 1 / (-2 * I * σ) ^ (1 / 2 : ℂ) * (1 / (-3 * I * σ / 2) ^ (1 / 2 : ℂ)) *
+          hexTheta (-1 / (3 * σ)) := by
+      have hS : (∑' m : ℤ, ∑' k : ℤ, hexThetaTerm (-1 / (3 * σ)) (k, -m)) =
+          hexTheta (-1 / (3 * σ)) :=
+        calc
+          (∑' m : ℤ, ∑' k : ℤ, hexThetaTerm (-1 / (3 * σ)) (k, -m)) =
+              ∑' m : ℤ, ∑' k : ℤ, hexThetaTerm (-1 / (3 * σ)) (-m, k) :=
+            tsum_congr fun m => tsum_congr fun k => hexThetaTerm_swap _ k (-m)
+          _ = ∑' m : ℤ, ∑' k : ℤ, hexThetaTerm (-1 / (3 * σ)) (m, k) :=
+            tsum_comp_neg fun m => ∑' k : ℤ, hexThetaTerm (-1 / (3 * σ)) (m, k)
+          _ = hexTheta (-1 / (3 * σ)) := ((summable_hexThetaTerm hσ').tsum_prod).symm
+      rw [hS]
+      ring
+
+lemma re_cpow_half_pos {z : ℂ} (hz : 0 < z.re) : 0 < (z ^ (1 / 2 : ℂ)).re := by
+  have hz0 : z ≠ 0 := fun h => by simp [h] at hz
+  have harg : |Complex.arg z| < π / 2 := Complex.abs_arg_lt_pi_div_two_iff.mpr (Or.inl hz)
+  rw [abs_lt] at harg
+  rw [show (1 / 2 : ℂ) = ((1 / 2 : ℝ) : ℂ) by norm_num, Complex.cpow_ofReal_re]
+  exact mul_pos (Real.rpow_pos_of_pos (norm_pos_iff.mpr hz0) _)
+    (Real.cos_pos_of_mem_Ioo ⟨by linarith [harg.1, pi_pos], by linarith [harg.2, pi_pos]⟩)
+
+lemma re_cpow_half_mul_cpow_half_pos {a b : ℂ} (ha : 0 < a.re) (hb : 0 < b.re) :
+    0 < (a ^ (1 / 2 : ℂ) * b ^ (1 / 2 : ℂ)).re := by
+  have ha0 : a ≠ 0 := fun h => by simp [h] at ha
+  have hb0 : b ≠ 0 := fun h => by simp [h] at hb
+  have harga : |Complex.arg a| < π / 2 := Complex.abs_arg_lt_pi_div_two_iff.mpr (Or.inl ha)
+  have hargb : |Complex.arg b| < π / 2 := Complex.abs_arg_lt_pi_div_two_iff.mpr (Or.inl hb)
+  rw [abs_lt] at harga hargb
+  have hcos : 0 < Real.cos (Complex.arg a * (1 / 2) + Complex.arg b * (1 / 2)) :=
+    Real.cos_pos_of_mem_Ioo
+      ⟨by linarith [harga.1, hargb.1], by linarith [harga.2, hargb.2]⟩
+  rw [Real.cos_add] at hcos
+  have hra : 0 < ‖a‖ ^ (1 / 2 : ℝ) := Real.rpow_pos_of_pos (norm_pos_iff.mpr ha0) _
+  have hrb : 0 < ‖b‖ ^ (1 / 2 : ℝ) := Real.rpow_pos_of_pos (norm_pos_iff.mpr hb0) _
+  rw [show (1 / 2 : ℂ) = ((1 / 2 : ℝ) : ℂ) by norm_num, Complex.mul_re,
+    Complex.cpow_ofReal_re, Complex.cpow_ofReal_re, Complex.cpow_ofReal_im,
+    Complex.cpow_ofReal_im]
+  nlinarith [mul_pos hra hrb, hcos]
+
+lemma eq_of_sq_eq_sq_of_re_pos {a b : ℂ} (h : a ^ 2 = b ^ 2) (ha : 0 < a.re)
+    (hb : 0 < b.re) : a = b := by
+  rcases sq_eq_sq_iff_eq_or_eq_neg.mp h with h' | h'
+  · exact h'
+  · exfalso
+    rw [h', Complex.neg_re] at ha
+    linarith
+
+lemma sq_cpow_half {z : ℂ} (hz : z ≠ 0) : (z ^ (1 / 2 : ℂ)) ^ 2 = z := by
+  rw [sq, ← Complex.cpow_add _ _ hz]
+  norm_num
+
+lemma cpow_half_mul_cpow_half {σ : ℂ} (hσ : 0 < σ.im) :
+    (-2 * I * σ) ^ (1 / 2 : ℂ) * (-3 * I * σ / 2) ^ (1 / 2 : ℂ) =
+      -I * (Real.sqrt 3 : ℂ) * σ := by
+  have hσ0 : σ ≠ 0 := ne_zero_of_im_pos hσ
+  have ha : (-2 : ℂ) * I * σ ≠ 0 :=
+    mul_ne_zero (mul_ne_zero (by norm_num) Complex.I_ne_zero) hσ0
+  have hb : (-3 : ℂ) * I * σ / 2 ≠ 0 :=
+    div_ne_zero (mul_ne_zero (mul_ne_zero (by norm_num) Complex.I_ne_zero) hσ0) (by norm_num)
+  have hs3 : ((Real.sqrt 3 : ℝ) : ℂ) ^ 2 = 3 := by
+    rw [← Complex.ofReal_pow, Real.sq_sqrt (by norm_num : (0 : ℝ) ≤ 3)]
+    norm_num
+  refine eq_of_sq_eq_sq_of_re_pos ?_
+    (re_cpow_half_mul_cpow_half_pos (re_neg_two_I_mul hσ) (re_neg_three_I_mul_div_two hσ)) ?_
+  · rw [mul_pow, sq_cpow_half ha, sq_cpow_half hb,
+      show (-I * ((Real.sqrt 3 : ℝ) : ℂ) * σ) ^ 2 =
+        ((Real.sqrt 3 : ℝ) : ℂ) ^ 2 * (I ^ 2 * σ ^ 2) by ring,
+      hs3]
+    ring
+  · rw [show (-I * ((Real.sqrt 3 : ℝ) : ℂ) * σ) = ((Real.sqrt 3 : ℝ) : ℂ) * (σ * -I) by ring,
+      Complex.re_ofReal_mul, mul_neg, Complex.neg_re, Complex.mul_I_re, neg_neg]
+    exact mul_pos (Real.sqrt_pos.mpr (by norm_num)) hσ
+
+lemma cpow_half_ne_zero {z : ℂ} (hz : z ≠ 0) : z ^ (1 / 2 : ℂ) ≠ 0 := fun h =>
+  hz ((Complex.cpow_eq_zero_iff _ _).mp h).1
+
+theorem hexTheta_fricke {σ : ℂ} (hσ : 0 < σ.im) :
+    hexTheta (-1 / (3 * σ)) = -I * (Real.sqrt 3 : ℂ) * σ * hexTheta σ := by
+  have hσ0 : σ ≠ 0 := ne_zero_of_im_pos hσ
+  have ha : (-2 : ℂ) * I * σ ≠ 0 :=
+    mul_ne_zero (mul_ne_zero (by norm_num) Complex.I_ne_zero) hσ0
+  have hb : (-3 : ℂ) * I * σ / 2 ≠ 0 :=
+    div_ne_zero (mul_ne_zero (mul_ne_zero (by norm_num) Complex.I_ne_zero) hσ0) (by norm_num)
+  have hu : (-2 * I * σ) ^ (1 / 2 : ℂ) ≠ 0 := cpow_half_ne_zero ha
+  have hv : (-3 * I * σ / 2) ^ (1 / 2 : ℂ) ≠ 0 := cpow_half_ne_zero hb
+  have hone : (-2 * I * σ) ^ (1 / 2 : ℂ) * (-3 * I * σ / 2) ^ (1 / 2 : ℂ) *
+      (1 / (-2 * I * σ) ^ (1 / 2 : ℂ) * (1 / (-3 * I * σ / 2) ^ (1 / 2 : ℂ))) = 1 := by
+    field_simp
+  rw [hexTheta_eq_mul_self_neg_inv hσ, ← cpow_half_mul_cpow_half hσ, ← mul_assoc, hone,
+    one_mul]
+
+end
+
+end A2HexPoisson
+
+theorem solution (σ : ℂ) (hσ : 0 < σ.im) :
+    Summable (fun p : ℤ × ℤ =>
+      Complex.exp (2 * (Real.pi : ℂ) * Complex.I * σ *
+        ((p.1 : ℂ) ^ 2 + (p.1 : ℂ) * (p.2 : ℂ) + (p.2 : ℂ) ^ 2))) ∧
+    (∑' p : ℤ × ℤ, Complex.exp (2 * (Real.pi : ℂ) * Complex.I * (-1 / (3 * σ)) *
+        ((p.1 : ℂ) ^ 2 + (p.1 : ℂ) * (p.2 : ℂ) + (p.2 : ℂ) ^ 2))) =
+      -Complex.I * (Real.sqrt 3 : ℂ) * σ *
+        ∑' p : ℤ × ℤ, Complex.exp (2 * (Real.pi : ℂ) * Complex.I * σ *
+          ((p.1 : ℂ) ^ 2 + (p.1 : ℂ) * (p.2 : ℂ) + (p.2 : ℂ) ^ 2)) :=
+  ⟨A2HexPoisson.summable_hexThetaTerm hσ, A2HexPoisson.hexTheta_fricke hσ⟩
+
+end S_HexagonalLattice_summable_thetaTerm_and_tsum_neg_inv_three_mul
+end P2MW
+export P2MW.S_HexagonalLattice_summable_thetaTerm_and_tsum_neg_inv_three_mul (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem HexagonalLattice.summable_thetaTerm_and_tsum_neg_inv_three_mul (σ : ℂ) (hσ : 0 < σ.im) :
+    Summable (fun p : ℤ × ℤ =>
+      Complex.exp (2 * (Real.pi : ℂ) * Complex.I * σ *
+        ((p.1 : ℂ) ^ 2 + (p.1 : ℂ) * (p.2 : ℂ) + (p.2 : ℂ) ^ 2))) ∧
+    (∑' p : ℤ × ℤ, Complex.exp (2 * (Real.pi : ℂ) * Complex.I * (-1 / (3 * σ)) *
+        ((p.1 : ℂ) ^ 2 + (p.1 : ℂ) * (p.2 : ℂ) + (p.2 : ℂ) ^ 2))) =
+      -Complex.I * (Real.sqrt 3 : ℂ) * σ *
+        ∑' p : ℤ × ℤ, Complex.exp (2 * (Real.pi : ℂ) * Complex.I * σ *
+          ((p.1 : ℂ) ^ 2 + (p.1 : ℂ) * (p.2 : ℂ) + (p.2 : ℂ) ^ 2)) :=
+  solution σ hσ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Ideal_IsMaximal_exists_adicCompletion_localization_ringEquiv.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Ideal_IsMaximal_exists_adicCompletion_localization_ringEquiv.lean
new file mode 100644
index 0000000000..0817ecd057
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Ideal_IsMaximal_exists_adicCompletion_localization_ringEquiv.lean
@@ -0,0 +1,213 @@
+/-
+Based on Prove2Me node Ideal.IsMaximal.exists_adicCompletion_localization_ringEquiv
+(d1ec29e0-26c9-5e94-b475-5ce731ee73ca) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 40dde146-8c85-599b-a2c8-e0b34c55616d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.AdicCompletion.Algebra
+public import Mathlib.RingTheory.Localization.AtPrime.Basic
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Completion at a maximal ideal agrees with completion of the localisation
+
+Theorem statement: `Ideal.IsMaximal.exists_adicCompletion_localization_ringEquiv`
+(`d1ec29e0-26c9-5e94-b475-5ce731ee73ca`), by Claude, 2026-09-05.
+
+Proof: submission `40dde146-8c85-599b-a2c8-e0b34c55616d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $C$ be a commutative ring and let $\mathfrak m \subseteq C$ be a maximal ideal. Write
+$C_{\mathfrak m} =$ `Localization.AtPrime 𝔪` for the localisation of $C$ at the prime complement of
+$\mathfrak m$, a local ring with maximal ideal $\mathfrak m C_{\mathfrak m}$ in the sense of
+`IsLocalRing.maximalIdeal`. The assertion is that there exists a ring isomorphism
+$$e : \widehat{(C_{\mathfrak m})} \;\xrightarrow{\ \sim\ }\; \widehat{C},$$
+where the source is the adic completion of $C_{\mathfrak m}$ with respect to its maximal ideal and
+the target is the $\mathfrak m$-adic completion of $C$ (both in Mathlib's `AdicCompletion` sense,
+the inverse limit of the quotients by the powers of the ideal), such that $e$ is compatible with the
+canonical maps out of $C$: for every $c \in C$, applying $e$ to the image in $\widehat{(C_{\mathfrak
+m})}$ of the element $c/1 \in C_{\mathfrak m}$ under the structure map $C_{\mathfrak m} \to
+\widehat{(C_{\mathfrak m})}$ gives the image of $c$ under the structure map $C \to \widehat{C}$. No
+finiteness or Noetherian hypothesis on $C$ is assumed, and the compatibility is asserted only on
+elements coming from $C$; no naturality in $C$ is claimed.
+
+This is the standard comparison between the $\mathfrak m$-adic completion of a ring and the
+completion of its localisation at a maximal ideal, which fails for non-maximal primes. It is used in
+the study of completions of local rings on modular curves, being cited by the two results
+identifying the adic completion of a stalk with an adic completion along the comap of a point.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Ideal_IsMaximal_exists_adicCompletion_localization_ringEquiv.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_Ideal_IsMaximal_exists_adicCompletion_localization_ringEquiv
+
+universe u
+
+namespace AdicIso
+
+open Ideal Ideal.Quotient AdicCompletion
+
+variable {R S : Type*} [CommRing R] [CommRing S] (I : Ideal R) (J : Ideal S)
+
+theorem factorPow_evalₐ {m n : ℕ} (hle : m ≤ n) (x : AdicCompletion I R) :
+    Ideal.Quotient.factorPow I hle (AdicCompletion.evalₐ I n x) = AdicCompletion.evalₐ I m x := by
+  obtain ⟨a, rfl⟩ := AdicCompletion.mk_surjective I R x
+  rw [AdicCompletion.evalₐ_mk, AdicCompletion.evalₐ_mk, Ideal.Quotient.factor_mk]
+  exact AdicCompletion.Ideal.mk_eq_mk I hle a
+
+theorem exists_ringEquiv (e : ∀ n : ℕ, R ⧸ I ^ n ≃+* S ⧸ J ^ n)
+    (he : ∀ {m n : ℕ} (hle : m ≤ n) (x : R ⧸ I ^ n),
+      e m (Ideal.Quotient.factorPow I hle x) = Ideal.Quotient.factorPow J hle (e n x)) :
+    ∃ E : AdicCompletion I R ≃+* AdicCompletion J S,
+      ∀ (n : ℕ) (x : AdicCompletion I R)
+        , AdicCompletion.evalₐ J n (E x) = e n (AdicCompletion.evalₐ I n x) := by
+  have he' : ∀ {m n : ℕ} (hle : m ≤ n) (y : S ⧸ J ^ n),
+      (e m).symm (Ideal.Quotient.factorPow J hle y) = Ideal.Quotient.factorPow I hle ((e n).symm y)
+        := by
+    intro m n hle y
+    apply (e m).injective
+    rw [RingEquiv.apply_symm_apply, he, RingEquiv.apply_symm_apply]
+  let F : AdicCompletion I R →+* AdicCompletion J S :=
+    AdicCompletion.liftRingHom J (fun n => (e n).toRingHom.comp (AdicCompletion.evalₐ I
+      n).toRingHom) (by
+      intro m n hle
+      ext x
+      change Ideal.Quotient.factorPow J hle (e n (AdicCompletion.evalₐ I n x)) = e m
+        (AdicCompletion.evalₐ I m x)
+      rw [← he, factorPow_evalₐ])
+  let G : AdicCompletion J S →+* AdicCompletion I R :=
+    AdicCompletion.liftRingHom I (fun n => (e n).symm.toRingHom.comp (AdicCompletion.evalₐ J
+      n).toRingHom) (by
+      intro m n hle
+      ext y
+      change Ideal.Quotient.factorPow I hle ((e n).symm (AdicCompletion.evalₐ J n y)) =
+        (e m).symm (AdicCompletion.evalₐ J m y)
+      rw [← he', factorPow_evalₐ])
+  have hF : ∀ n x, AdicCompletion.evalₐ J n (F x) = e n (AdicCompletion.evalₐ I n x) :=
+    fun n x => AdicCompletion.evalₐ_liftRingHom J _ _ n x
+  have hG : ∀ n y, AdicCompletion.evalₐ I n (G y) = (e n).symm (AdicCompletion.evalₐ J n y) :=
+    fun n y => AdicCompletion.evalₐ_liftRingHom I _ _ n y
+  refine ⟨RingEquiv.ofRingHom F G (RingHom.ext fun y => ?_) (RingHom.ext fun x => ?_), hF⟩
+  · apply AdicCompletion.ext_evalₐ
+    intro n
+    rw [RingHom.comp_apply, hF, hG, RingEquiv.apply_symm_apply, RingHom.id_apply]
+  · apply AdicCompletion.ext_evalₐ
+    intro n
+    rw [RingHom.comp_apply, hG, hF, RingEquiv.symm_apply_apply, RingHom.id_apply]
+
+theorem apply_of_eq_of (e : ∀ n : ℕ, R ⧸ I ^ n ≃+* S ⧸ J ^ n)
+    (E : AdicCompletion I R ≃+* AdicCompletion J S)
+    (hE : ∀ (n : ℕ) (x : AdicCompletion I R), AdicCompletion.evalₐ J n (E x) = e n
+      (AdicCompletion.evalₐ I n x))
+    (θ : R → S)
+    (hθ : ∀ (n : ℕ) (r : R), e n (Ideal.Quotient.mk (I ^ n) r) = Ideal.Quotient.mk (J ^ n) (θ r))
+    (r : R) :
+    E (AdicCompletion.of I R r) = AdicCompletion.of J S (θ r) := by
+  apply AdicCompletion.ext_evalₐ
+  intro n
+  rw [hE, AdicCompletion.evalₐ_of, hθ, AdicCompletion.evalₐ_of]
+
+end AdicIso
+
+open AdicIso in
+theorem solution
+    {C : Type u} [CommRing C] (𝔪 : Ideal C) [𝔪.IsMaximal] :
+    ∃ e : AdicCompletion (IsLocalRing.maximalIdeal (Localization.AtPrime 𝔪)) (Localization.AtPrime
+      𝔪) ≃+*
+        AdicCompletion 𝔪 C,
+      ∀ c : C, e (algebraMap (Localization.AtPrime 𝔪) _ (algebraMap C (Localization.AtPrime 𝔪) c)) =
+        algebraMap C (AdicCompletion 𝔪 C) c := by
+  classical
+  have hmap : ∀ n : ℕ, (𝔪 ^ n).map (algebraMap C (Localization.AtPrime 𝔪)) =
+      (IsLocalRing.maximalIdeal (Localization.AtPrime 𝔪)) ^ n := by
+    intro n
+    rw [Ideal.map_pow, Localization.AtPrime.map_eq_maximalIdeal]
+  have hunit : ∀ (n : ℕ) (s : C), s ∉ 𝔪 → IsUnit (Ideal.Quotient.mk (𝔪 ^ n) s) := by
+    intro n s hs
+    obtain ⟨y, i, hi, hyi⟩ := (‹𝔪.IsMaximal›).exists_inv hs
+    have hnil : IsNilpotent (Ideal.Quotient.mk (𝔪 ^ n) i) :=
+      ⟨n, by rw [← map_pow, Ideal.Quotient.eq_zero_iff_mem]; exact Ideal.pow_mem_pow hi n⟩
+    have h1 : Ideal.Quotient.mk (𝔪 ^ n) y * Ideal.Quotient.mk (𝔪 ^ n) s = 1 - Ideal.Quotient.mk (𝔪 ^
+      n) i :=
+      by
+      rw [← map_mul, eq_sub_of_add_eq hyi, map_sub, map_one]
+    exact isUnit_of_mul_isUnit_right (h1 ▸ hnil.isUnit_one_sub)
+  have hU : ∀ n : ℕ, Algebra.algebraMapSubmonoid (C ⧸ 𝔪 ^ n) 𝔪.primeCompl ≤ IsUnit.submonoid (C ⧸ 𝔪
+    ^ n) :=
+    by
+    intro n x hx
+    rw [Algebra.algebraMapSubmonoid, Submonoid.mem_map] at hx
+    obtain ⟨s, hs, rfl⟩ := hx
+    exact hunit n s hs
+  let d : ∀ n : ℕ, C ⧸ 𝔪 ^ n ≃+* Localization.AtPrime 𝔪 ⧸ (IsLocalRing.maximalIdeal
+    (Localization.AtPrime 𝔪)) ^ n :=
+    fun n =>
+      (IsLocalization.atUnits (C ⧸ 𝔪 ^ n) (Algebra.algebraMapSubmonoid (C ⧸ 𝔪 ^ n) 𝔪.primeCompl)
+          (S := Localization.AtPrime 𝔪 ⧸ (𝔪 ^ n).map (algebraMap C (Localization.AtPrime 𝔪))) (hU
+            n)).toRingEquiv.trans
+        (Ideal.quotEquivOfEq (hmap n))
+  have hd_mk : ∀ (n : ℕ) (c : C), d n (Ideal.Quotient.mk (𝔪 ^ n) c) =
+      Ideal.Quotient.mk _ (algebraMap C (Localization.AtPrime 𝔪) c) := by
+    intro n c
+    have h :=
+      (IsLocalization.atUnits (C ⧸ 𝔪 ^ n) (Algebra.algebraMapSubmonoid (C ⧸ 𝔪 ^ n) 𝔪.primeCompl)
+      (S := Localization.AtPrime 𝔪 ⧸ (𝔪 ^ n).map (algebraMap C (Localization.AtPrime 𝔪))) (hU
+        n)).commutes
+      (Ideal.Quotient.mk (𝔪 ^ n) c)
+    rw [Algebra.algebraMap_self, RingHom.id_apply,
+      Ideal.Quotient.algebraMap_quotient_map_quotient] at h
+    change Ideal.quotEquivOfEq (hmap n)
+      (IsLocalization.atUnits (C ⧸ 𝔪 ^ n) (Algebra.algebraMapSubmonoid (C ⧸ 𝔪 ^ n) 𝔪.primeCompl)
+        (S := Localization.AtPrime 𝔪 ⧸ (𝔪 ^ n).map (algebraMap C (Localization.AtPrime 𝔪))) (hU n)
+        (Ideal.Quotient.mk (𝔪 ^ n) c)) = _
+    rw [h, Ideal.quotEquivOfEq_mk]
+  have hd : ∀ {m n : ℕ} (hle : m ≤ n) (x : C ⧸ 𝔪 ^ n),
+      d m (Ideal.Quotient.factorPow 𝔪 hle x) = Ideal.Quotient.factorPow _ hle (d n x) := by
+    intro m n hle x
+    obtain ⟨c, rfl⟩ := Ideal.Quotient.mk_surjective x
+    rw [Ideal.Quotient.factor_mk, hd_mk, hd_mk, Ideal.Quotient.factor_mk]
+  obtain ⟨E, hE⟩ := exists_ringEquiv 𝔪 (IsLocalRing.maximalIdeal (Localization.AtPrime 𝔪)) d hd
+  refine ⟨E.symm, fun c => ?_⟩
+  apply E.injective
+  rw [RingEquiv.apply_symm_apply, AdicCompletion.algebraMap_apply, AdicCompletion.algebraMap_apply,
+    Algebra.algebraMap_self, Algebra.algebraMap_self, RingHom.id_apply, RingHom.id_apply]
+  exact (apply_of_eq_of _ _ d E hE (algebraMap C (Localization.AtPrime 𝔪)) hd_mk c).symm
+
+end S_Ideal_IsMaximal_exists_adicCompletion_localization_ringEquiv
+end P2MW
+export P2MW.S_Ideal_IsMaximal_exists_adicCompletion_localization_ringEquiv (solution)
+
+end privateSection
+
+public section publicSection
+
+
+universe u
+
+theorem Ideal.IsMaximal.exists_adicCompletion_localization_ringEquiv
+    {C : Type u} [CommRing C] (𝔪 : Ideal C) [𝔪.IsMaximal] :
+    ∃ e : AdicCompletion (IsLocalRing.maximalIdeal (Localization.AtPrime 𝔪)) (Localization.AtPrime
+      𝔪) ≃+*
+        AdicCompletion 𝔪 C,
+      ∀ c : C, e (algebraMap (Localization.AtPrime 𝔪) _ (algebraMap C (Localization.AtPrime 𝔪) c)) =
+        algebraMap C (AdicCompletion 𝔪 C) c :=
+  solution 𝔪
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Int_exists_squarefree_sq_add_mul_add_mul_sq_of_sq_lt_four_mul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Int_exists_squarefree_sq_add_mul_add_mul_sq_of_sq_lt_four_mul.lean
new file mode 100644
index 0000000000..c1ca31273b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Int_exists_squarefree_sq_add_mul_add_mul_sq_of_sq_lt_four_mul.lean
@@ -0,0 +1,91 @@
+/-
+Based on Prove2Me node Int.exists_squarefree_sq_add_mul_add_mul_sq_of_sq_lt_four_mul
+(922e7ee1-f2b2-5600-8071-07c6c6138d01) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 32d83ac3-fc39-565e-a279-5b13174f0f79
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Squarefree.Basic
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Nat_exists_squarefree_sq_add
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Positive-definite binary form represents a squarefree integer ≥ 2
+
+Theorem statement: `Int.exists_squarefree_sq_add_mul_add_mul_sq_of_sq_lt_four_mul`
+(`922e7ee1-f2b2-5600-8071-07c6c6138d01`), by Claude, 2026-09-05.
+
+Proof: submission `32d83ac3-fc39-565e-a279-5b13174f0f79`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $t$ and $n$ be integers satisfying $t^2 < 4n$, so that the binary quadratic form $Q(a,b) = a^2 +
+t\,ab + n\,b^2$ has negative discriminant $t^2 - 4n$ and is positive definite. The assertion is that
+there exist integers $a$ and $b$ with $b \neq 0$ such that the natural number $(a^2 + t\,ab +
+n\,b^2)\,$`.toNat`, that is the truncation to $\mathbb{N}$ of the integer value $Q(a,b)$, is
+squarefree as a natural number and is at least $2$. Since the value produced is in fact positive,
+the passage through `Int.toNat` loses nothing: the conclusion says that $Q$ takes, at some point off
+the line $b = 0$, a squarefree value $\ge 2$. Squarefreeness is the Mathlib predicate on the monoid
+$\mathbb{N}$: every element whose square divides the value is a unit.
+
+For an imaginary quadratic order $\mathbb{Z}[\varphi]$ with $\varphi^2 = t\varphi - n$, the form $Q$
+is the norm form, and $Q(a,b)$ is the degree of $a + b\varphi$ viewed as an endomorphism of an
+elliptic curve with complex multiplication by that order. The statement is used in the treatment of
+[`WeierstrassCurve.Affine.IsogenyEndDatum`](def/Isogeny_ConditionalCurrency.html#L149) to produce an
+endomorphism of squarefree degree $N \ge 2$ that is not multiplication by an integer, in the lemmas
+`exists_forall_pointEnd_eq_zsmul_of_not_isIntegral_j` and
+`exists_forall_pointEnd_eq_zsmul_of_transcendental_j`.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Int_exists_squarefree_sq_add_mul_add_mul_sq_of_sq_lt_four_mul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_Int_exists_squarefree_sq_add_mul_add_mul_sq_of_sq_lt_four_mul
+
+theorem solution (t n : ℤ) (h : t ^ 2 < 4 * n) :
+    ∃ a b : ℤ, b ≠ 0 ∧ Squarefree (a ^ 2 + t * a * b + n * b ^ 2).toNat ∧
+      2 ≤ (a ^ 2 + t * a * b + n * b ^ 2).toNat := by
+  set D : ℕ := (4 * n - t ^ 2).toNat with hD_def
+  have hD1 : 1 ≤ D := by
+    have : (1 : ℤ) ≤ 4 * n - t ^ 2 := by omega
+    omega
+  have hDcast : ((D : ℤ)) = 4 * n - t ^ 2 := by
+    rw [hD_def]; exact Int.toNat_of_nonneg (by omega)
+  obtain ⟨c, hc1, hsf⟩ := Nat.exists_squarefree_sq_add D hD1
+  have hid : ((c : ℤ) - t) ^ 2 + t * ((c : ℤ) - t) * 2 + n * 2 ^ 2 = ((c ^ 2 + D : ℕ) : ℤ) := by
+    push_cast [hDcast]; ring
+  refine ⟨(c : ℤ) - t, 2, two_ne_zero, ?_, ?_⟩
+  · rw [hid, Int.toNat_natCast]; exact hsf
+  · rw [hid, Int.toNat_natCast]; nlinarith [sq_nonneg c]
+
+end S_Int_exists_squarefree_sq_add_mul_add_mul_sq_of_sq_lt_four_mul
+end P2MW
+export P2MW.S_Int_exists_squarefree_sq_add_mul_add_mul_sq_of_sq_lt_four_mul (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem Int.exists_squarefree_sq_add_mul_add_mul_sq_of_sq_lt_four_mul (t n : ℤ) (h : t ^ 2 < 4 * n)
+    :
+    ∃ a b : ℤ, b ≠ 0 ∧ Squarefree (a ^ 2 + t * a * b + n * b ^ 2).toNat ∧
+      2 ≤ (a ^ 2 + t * a * b + n * b ^ 2).toNat :=
+  solution t n h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_IntermediateField_finrank_fieldRange_le_of_adjoin_pair_eq_top.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_IntermediateField_finrank_fieldRange_le_of_adjoin_pair_eq_top.lean
new file mode 100644
index 0000000000..1ba8274330
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_IntermediateField_finrank_fieldRange_le_of_adjoin_pair_eq_top.lean
@@ -0,0 +1,223 @@
+/-
+Based on Prove2Me node IntermediateField.finrank_fieldRange_le_of_adjoin_pair_eq_top
+(8fe683a8-57ff-553a-b3e0-3ca138c9888b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission be51a8b7-5f2b-5558-a728-f203cc9a0fb8
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Defs
+public import Mathlib.LinearAlgebra.FiniteDimensional.Defs
+
+import Mathlib.FieldTheory.Galois.Basic
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+import Mathlib.FieldTheory.IntermediateField.Algebraic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree bound for a K-endomorphism of a quadratic extension
+
+Theorem statement: `IntermediateField.finrank_fieldRange_le_of_adjoin_pair_eq_top`
+(`8fe683a8-57ff-553a-b3e0-3ca138c9888b`), by Claude, 2026-09-05.
+
+Proof: submission `be51a8b7-5f2b-5558-a728-f203cc9a0fb8`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $L$ be fields with $L$ a $K$-algebra, and let $X, Y \in L$ be elements generating $L$
+over $K$, in the sense that the intermediate field $K(X,Y)$ of $L/K$ is all of $L$. Let $A, B$ be
+elements of the intermediate field $K(X)$ such that $Y^2 + AY + B = 0$. Let $\mu, \iota$ be
+$K$-algebra endomorphisms of $L$ such that $\iota X = X$, such that $\iota Y$ satisfies the same
+quadratic relation $(\iota Y)^2 + A\,\iota Y + B = 0$, and such that $\iota(\mu Y) \neq \mu Y$. Let
+$\Phi, \Psi \in K[t]$ and let $d$ be a positive natural number such that $\Phi(X) = \mu(X)\,\Psi(X)$
+(evaluation of polynomials at $X$ via the $K$-algebra structure), and such that for every
+intermediate field $M$ of $L/K$ and every $c \in M$ the polynomial $\Phi - c\,\Psi$, taken over $M$,
+has degree exactly $d$. The conclusion is that $L$ is finite-dimensional as a module over the
+intermediate field $\mu(L)$, the range of $\mu$, and that $[L : \mu(L)] \leq d$.
+
+This is an abstract form of the degree bound for the pullback of functions along an isogeny: a
+$K$-endomorphism $\mu$ of a quadratic extension $L = K(X,Y)$ of a rational function field has index
+at most $d$ in $L$, where $d$ controls the degree of $\Phi - c\Psi$ and $\iota$ plays the role of
+the hyperelliptic involution witnessing that $\mu Y \notin K(X)$. It is applied, via
+[`WeierstrassCurve.Affine.finrank_fieldRange_mulPull_le`]
+(thm.html#WeierstrassCurve.Affine.finrank_fieldRange_mulPull_le),
+to multiplication by $n$ on the function field of an elliptic curve with $\Phi, \Psi$ built from
+division polynomials and $d = n^2$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_IntermediateField_finrank_fieldRange_le_of_adjoin_pair_eq_top.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_IntermediateField_finrank_fieldRange_le_of_adjoin_pair_eq_top
+
+open Polynomial IntermediateField
+
+namespace WeilPairingDEGN
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+
+lemma algHom_ext_of_adjoin_eq_top {L' : Type*} [Field L'] [Algebra K L'] {S : Set L}
+    (hS : adjoin K S = ⊤) {f g : L →ₐ[K] L'} (h : ∀ s ∈ S, f s = g s) : f = g := by
+  have hle : adjoin K S ≤ (⊤ : IntermediateField K L) := le_top
+  have key : (adjoin K S).toSubfield ≤ (f : L →+* L').eqLocusField (g : L →+* L') := by
+    change Subfield.closure (Set.range (algebraMap K L) ∪ S) ≤ _
+    rw [Subfield.closure_le]
+    rintro x (⟨k, rfl⟩ | hx)
+    · simp
+    · exact h x hx
+  ext z
+  have hz : z ∈ (adjoin K S).toSubfield := by rw [hS]; trivial
+  exact key hz
+
+lemma eq_top_of_forall_mem {B : Type*} [Field B] [Algebra K B] [Algebra B L] [IsScalarTower K B L]
+    {S : Set L} (hS : adjoin K S = ⊤) (N : IntermediateField B L) (h : ∀ s ∈ S, s ∈ N) : N = ⊤ := by
+  apply IntermediateField.restrictScalars_injective K
+  rw [IntermediateField.restrictScalars_top, eq_top_iff, ← hS, adjoin_le_iff]
+  exact h
+
+theorem finrank_fieldRange_le (X Y : L) (hgen : adjoin K {X, Y} = ⊤) (A B : L)
+    (hA : A ∈ K⟮X⟯) (hB : B ∈ K⟮X⟯) (hY : Y ^ 2 + A * Y + B = 0) (μ ι : L →ₐ[K] L)
+    (hιX : ι X = X) (hιY : ι Y ^ 2 + A * ι Y + B = 0) (hιμ : ι (μ Y) ≠ μ Y) (Φ Ψ : K[X])
+    {d : ℕ} (hd : 0 < d) (hroot : aeval X Φ = μ X * aeval X Ψ)
+    (hdeg : ∀ (M : IntermediateField K L) (c : M),
+      (Φ.map (algebraMap K M) - C c * Ψ.map (algebraMap K M)).natDegree = d) :
+    FiniteDimensional μ.fieldRange L ∧ Module.finrank μ.fieldRange L ≤ d := by
+  set M : IntermediateField K L := μ.fieldRange with hM
+  have hxM : μ X ∈ M := ⟨X, rfl⟩
+  have hyM : μ Y ∈ M := ⟨Y, rfl⟩
+  set P : M[X] := Φ.map (algebraMap K M) - C (⟨μ X, hxM⟩ : M) * Ψ.map (algebraMap K M) with hP
+  have hPdeg : P.natDegree = d := hdeg M _
+  have hP0 : P ≠ 0 := fun h => by rw [h, natDegree_zero] at hPdeg; omega
+  have hPX : aeval X P = 0 := by
+    rw [hP, map_sub, map_mul, aeval_map_algebraMap, aeval_map_algebraMap, aeval_C, hroot]
+    change μ X * aeval X Ψ - (algebraMap M L ⟨μ X, hxM⟩) * aeval X Ψ = 0
+    rw [sub_eq_zero]; rfl
+  have hXalg : IsAlgebraic M X := ⟨P, hP0, hPX⟩
+  have hXint : IsIntegral M X := hXalg.isIntegral
+  have hN'fd : FiniteDimensional M M⟮X⟯ := adjoin.finiteDimensional hXint
+  have hN'deg : Module.finrank M M⟮X⟯ ≤ d := by
+    rw [adjoin.finrank hXint, ← hPdeg]
+    exact natDegree_le_natDegree (minpoly.degree_le_of_ne_zero M X hP0 hPX)
+  have hKX : K⟮X⟯ ≤ (M⟮X⟯).restrictScalars K := by
+    rw [adjoin_simple_le_iff]
+    exact mem_adjoin_simple_self M X
+  have hAN : A ∈ M⟮X⟯ := hKX hA
+  have hBN : B ∈ M⟮X⟯ := hKX hB
+  have hMN : ∀ z : L, z ∈ M → z ∈ M⟮X⟯ := fun z hz => (M⟮X⟯).algebraMap_mem ⟨z, hz⟩
+  have hpair : ∀ {P : L → Prop}, P X → P Y → ∀ s ∈ ({X, Y} : Set L), P s := by
+    intro P hX hY s hs
+    rcases hs with h | h
+    · rw [h]; exact hX
+    · rw [Set.mem_singleton_iff] at h; rw [h]; exact hY
+  have hXY : ∀ N : IntermediateField K L, X ∈ N → Y ∈ N → N = ⊤ := fun N hX hY =>
+    eq_top_of_forall_mem hgen N (hpair hX hY)
+  set N : IntermediateField K L := (M⟮X⟯).restrictScalars K with hN
+  have hmemN : ∀ z, z ∈ N ↔ z ∈ M⟮X⟯ := fun z => IntermediateField.mem_restrictScalars K
+  have hXN : X ∈ N := (hmemN X).mpr (mem_adjoin_simple_self M X)
+  have hYN : Y ∈ N := by
+    by_contra hYN
+    set a : N := ⟨A, (hmemN A).mpr hAN⟩ with ha
+    set b : N := ⟨B, (hmemN B).mpr hBN⟩ with hb
+    set q : N[X] := Polynomial.X ^ 2 + (C a * Polynomial.X + C b) with hq
+    have hlow : (C a * Polynomial.X + C b).degree < 2 := by
+      refine lt_of_le_of_lt (degree_add_le _ _) (max_lt ?_ ?_)
+      · exact lt_of_le_of_lt (degree_C_mul_X_le a) (by exact_mod_cast Nat.lt_succ_self 1)
+      · exact lt_of_le_of_lt degree_C_le (by exact_mod_cast Nat.zero_lt_two)
+    have hqm : q.Monic := monic_X_pow_add hlow
+    have hqdeg : q.natDegree = 2 := by
+      rw [hq, natDegree_add_eq_left_of_degree_lt, natDegree_X_pow]
+      rwa [degree_X_pow]
+    have hq0 : q ≠ 0 := hqm.ne_zero
+    have haeval : ∀ z : L, aeval z q = z ^ 2 + A * z + B := by
+      intro z
+      rw [hq]
+      simp only [map_add, map_mul, map_pow, aeval_X, aeval_C]
+      rw [add_assoc]
+      rfl
+    have hqY : aeval Y q = 0 := by rw [haeval, hY]
+    have hYint : IsIntegral N Y := ⟨q, hqm, by rwa [← aeval_def]⟩
+    have hmin2 : 2 ≤ (minpoly N Y).natDegree := by
+      rw [minpoly.two_le_natDegree_iff hYint]
+      rintro ⟨z, hz⟩
+      exact hYN (hz ▸ z.2)
+    have hmin : minpoly N Y = q := by
+      symm
+      apply Polynomial.eq_of_monic_of_dvd_of_natDegree_le (minpoly.monic hYint) hqm
+        (minpoly.dvd N Y hqY)
+      rw [hqdeg]; exact hmin2
+    have hιroot : ι Y ∈ (minpoly N Y).aroots L := by
+      rw [mem_aroots', hmin]
+      exact ⟨Polynomial.map_ne_zero hq0, by rw [haeval, hιY]⟩
+    have hXNY : X ∈ N⟮Y⟯ := (N⟮Y⟯).algebraMap_mem ⟨X, hXN⟩
+    have hYNY : Y ∈ N⟮Y⟯ := mem_adjoin_simple_self N Y
+    have htop : N⟮Y⟯ = ⊤ := eq_top_of_forall_mem hgen _ (hpair hXNY hYNY)
+    let e : L ≃ₐ[N] N⟮Y⟯ :=
+      ((IntermediateField.equivOfEq htop).trans IntermediateField.topEquiv).symm
+    let θ₀ : N⟮Y⟯ →ₐ[N] L := (algHomAdjoinIntegralEquiv N hYint).symm ⟨ι Y, hιroot⟩
+    let θ : L →ₐ[N] L := θ₀.comp e
+    have heY : e Y = AdjoinSimple.gen N Y := by
+      apply Subtype.ext; rfl
+    have hθY : θ Y = ι Y := by
+      change θ₀ (e Y) = ι Y
+      rw [heY]
+      exact algHomAdjoinIntegralEquiv_symm_apply_gen N hYint ⟨ι Y, hιroot⟩
+    have hθfix : ∀ z : L, z ∈ N → θ z = z := fun z hz => θ.commutes ⟨z, hz⟩
+    have hθX : θ.restrictScalars K X = ι X := by
+      rw [AlgHom.restrictScalars_apply, hθfix _ hXN, hιX]
+    have hθY' : θ.restrictScalars K Y = ι Y := by
+      rw [AlgHom.restrictScalars_apply, hθY]
+    have hθι : θ.restrictScalars K = ι :=
+      algHom_ext_of_adjoin_eq_top hgen (hpair (P := fun s => θ.restrictScalars K s = ι s) hθX hθY')
+    apply hιμ
+    rw [← hθι, AlgHom.restrictScalars_apply]
+    exact hθfix _ ((hmemN _).mpr (hMN _ hyM))
+  have htop' : M⟮X⟯ = ⊤ :=
+    eq_top_of_forall_mem hgen (M⟮X⟯) (hpair (mem_adjoin_simple_self M X) ((hmemN Y).mp hYN))
+  let e' : M⟮X⟯ ≃ₐ[M] L := (IntermediateField.equivOfEq htop').trans IntermediateField.topEquiv
+  refine ⟨LinearEquiv.finiteDimensional e'.toLinearEquiv, ?_⟩
+  rw [← LinearEquiv.finrank_eq e'.toLinearEquiv]
+  exact hN'deg
+
+end WeilPairingDEGN
+
+theorem solution {K L : Type*} [Field K] [Field L] [Algebra K L] (X Y : L) (hgen :
+  IntermediateField.adjoin K {X, Y} = ⊤) (A B : L) (hA : A ∈ IntermediateField.adjoin K {X}) (hB : B
+  ∈ IntermediateField.adjoin K {X}) (hY : Y ^ 2 + A * Y + B = 0) (μ ι : L →ₐ[K] L) (hιX : ι X = X)
+  (hιY : ι Y ^ 2 + A * ι Y + B = 0) (hιμ : ι (μ Y) ≠ μ Y) (Φ Ψ : Polynomial K) {d : ℕ} (hd : 0 < d)
+  (hroot : Polynomial.aeval X Φ = μ X * Polynomial.aeval X Ψ) (hdeg : ∀ (M : IntermediateField K L)
+  (c : M), (Φ.map (algebraMap K M) - Polynomial.C c * Ψ.map (algebraMap K M)).natDegree = d) :
+    FiniteDimensional μ.fieldRange L ∧ Module.finrank μ.fieldRange L ≤ d :=
+  WeilPairingDEGN.finrank_fieldRange_le X Y hgen A B hA hB hY μ ι hιX hιY hιμ Φ Ψ hd hroot hdeg
+
+end S_IntermediateField_finrank_fieldRange_le_of_adjoin_pair_eq_top
+end P2MW
+export P2MW.S_IntermediateField_finrank_fieldRange_le_of_adjoin_pair_eq_top (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem IntermediateField.finrank_fieldRange_le_of_adjoin_pair_eq_top {K L : Type*} [Field K] [Field
+  L] [Algebra K L] (X Y : L) (hgen : IntermediateField.adjoin K {X, Y} = ⊤) (A B : L) (hA : A ∈
+  IntermediateField.adjoin K {X}) (hB : B ∈ IntermediateField.adjoin K {X}) (hY : Y ^ 2 + A * Y + B
+  = 0) (μ ι : L →ₐ[K] L) (hιX : ι X = X) (hιY : ι Y ^ 2 + A * ι Y + B = 0) (hιμ : ι (μ Y) ≠ μ Y) (Φ
+  Ψ : Polynomial K) {d : ℕ} (hd : 0 < d) (hroot : Polynomial.aeval X Φ = μ X * Polynomial.aeval X Ψ)
+  (hdeg : ∀ (M : IntermediateField K L) (c : M), (Φ.map (algebraMap K M) - Polynomial.C c * Ψ.map
+  (algebraMap K M)).natDegree = d) :
+    FiniteDimensional μ.fieldRange L ∧ Module.finrank μ.fieldRange L ≤ d :=
+  solution X Y hgen A B hA hB hY μ ι hιX hιY hιμ Φ Ψ hd hroot hdeg
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_IsAddCyclic_of_squarefree_natCard.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_IsAddCyclic_of_squarefree_natCard.lean
new file mode 100644
index 0000000000..179415e6eb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_IsAddCyclic_of_squarefree_natCard.lean
@@ -0,0 +1,80 @@
+/-
+Based on Prove2Me node IsAddCyclic.of_squarefree_natCard
+(14855747-d0f6-58c2-8d76-6caa8c9e1383) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission fa1809a7-8c5a-585b-a63d-4367dd32ade8
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Squarefree.Basic
+public import Mathlib.SetTheory.Cardinal.Finite
+
+import Mathlib.GroupTheory.SpecificGroups.ZGroup
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Abelian groups of squarefree order are cyclic
+
+Theorem statement: `IsAddCyclic.of_squarefree_natCard` (`14855747-d0f6-58c2-8d76-6caa8c9e1383`), by
+Claude, 2026-09-05.
+
+Proof: submission `fa1809a7-8c5a-585b-a63d-4367dd32ade8`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $A$ be an additive abelian group (no finiteness is assumed as a separate hypothesis) and suppose
+the natural number $\mathrm{Nat.card}\,A$ is squarefree, i.e. every element of $\mathbb{N}$ whose
+square divides it is a unit. Since a squarefree natural number is nonzero, this hypothesis already
+forces $A$ to be finite, with $\mathrm{Nat.card}\,A$ its order. The conclusion is `IsAddCyclic A`:
+the group $A$ is cyclic, that is, there is an element $g \in A$ such that every element of $A$ is an
+integer multiple of $g$. Note that the hypothesis is on the cardinality in the `Nat.card` sense, so
+for an infinite $A$ the value would be $0$, which is not squarefree; thus the statement is exactly
+the assertion that a finite abelian group whose order is squarefree is cyclic, phrased additively.
+
+This is the classical fact that a finite abelian group of squarefree order is cyclic. In this
+development it supplies the cyclicity of subgroups of torsion groups of elliptic curves of
+squarefree order, and is used by
+[`WeierstrassCurve.Affine.IsogenyEndDatum.aeval_j_diag_eq_zero_of_finrankAlong_eq`]
+(thm.html#WeierstrassCurve.Affine.IsogenyEndDatum.aeval_j_diag_eq_zero_of_finrankAlong_eq).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_IsAddCyclic_of_squarefree_natCard.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_IsAddCyclic_of_squarefree_natCard
+
+theorem solution
+    {A : Type*} [AddCommGroup A] (hA : Squarefree (Nat.card A)) : IsAddCyclic A := by
+  have : Finite A := Nat.finite_of_card_ne_zero hA.ne_zero
+  rw [← isCyclic_multiplicative_iff]
+  have hM : Squarefree (Nat.card (Multiplicative A)) := by
+    rwa [Nat.card_congr Multiplicative.toAdd]
+  have : IsZGroup (Multiplicative A) := IsZGroup.of_squarefree hM
+  exact IsCyclic.of_exponent_eq_card (IsZGroup.exponent_eq_card (Multiplicative A))
+
+end S_IsAddCyclic_of_squarefree_natCard
+end P2MW
+export P2MW.S_IsAddCyclic_of_squarefree_natCard (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem IsAddCyclic.of_squarefree_natCard
+    {A : Type*} [AddCommGroup A] (hA : Squarefree (Nat.card A))
+    : IsAddCyclic A :=
+  solution hA
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_IsDedekindDomain_HeightOneSpectrum_exists_eq_span_singleton_of_map_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_IsDedekindDomain_HeightOneSpectrum_exists_eq_span_singleton_of_map_eq.lean
new file mode 100644
index 0000000000..32240bb70b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_IsDedekindDomain_HeightOneSpectrum_exists_eq_span_singleton_of_map_eq.lean
@@ -0,0 +1,219 @@
+/-
+Based on Prove2Me node IsDedekindDomain.HeightOneSpectrum.exists_eq_span_singleton_of_map_eq
+(631971c2-561a-5f1e-82c1-655bbd4b5ea3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c729dafe-4f6d-5f0f-be82-0c7548e0779b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.DedekindDomain.AdicValuation
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Principality of a height-one prime from a pulled-back simple zero
+
+Theorem statement: `IsDedekindDomain.HeightOneSpectrum.exists_eq_span_singleton_of_map_eq`
+(`631971c2-561a-5f1e-82c1-655bbd4b5ea3`), by Claude, 2026-09-05.
+
+Proof: submission `c729dafe-4f6d-5f0f-be82-0c7548e0779b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a Dedekind domain with fraction field $K$, let $\mu \colon K \to K$ be a ring
+homomorphism, and let $N$ be a map from the height-one spectrum of $R$ to $\mathrm{Option}$ of that
+spectrum, i.e. a partial self-map $v \mapsto N(v)$ of the set of height-one primes. Assume: (i) $N$
+hits every prime, that is, for every $w$ there is a $v$ with $N(v) = w$; (ii) $\mu$ transports
+valuations along $N$, in the sense that whenever $N(v) = w$, every $h \in K$ and every natural
+number $k$ satisfy the implication $w(h) \le \exp(-k) \Rightarrow v(\mu h) \le \exp(-k)$, where
+$w(\cdot)$, $v(\cdot)$ are the $\mathbb{Z}^{m0}$-valued valuations of $K$ attached to the primes and
+$\exp$ is the embedding of $\mathbb{Z}$ into $\mathbb{Z}^{m0}$. Let $g \in K$ and let $t_0$ be a
+height-one prime of $R$ such that $v(g) = \exp(-1)$ for every $v$ with $N(v) = t_0$, and $v(g) = 1$
+for every $v$ with $N(v) = w$ for some $w \neq t_0$; assume further that $g$ lies in the image of
+$\mu$. Then $t_0$ is principal: there exists $r \in R$ with $t_0 = (r)$. (Only principality is
+asserted, not that a generator can be taken to be a preimage of $g$.)
+
+This is the valuation-theoretic core of the non-degeneracy argument for the Weil pairing, in which a
+function whose divisor would be $(T) - (O)$ is excluded because that divisor is not principal; it is
+stated here abstractly for an arbitrary Dedekind domain, a partial self-map of its height-one
+spectrum, and a ring endomorphism of the fraction field compatible with valuations along that map.
+It is used by
+[`WeierstrassCurve.Affine.eq_zero_of_forall_transEquiv_eq`]
+(thm.html#WeierstrassCurve.Affine.eq_zero_of_forall_transEquiv_eq).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_IsDedekindDomain_HeightOneSpectrum_exists_eq_span_singleton_of_map_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_IsDedekindDomain_HeightOneSpectrum_exists_eq_span_singleton_of_map_eq
+
+open IsDedekindDomain IsDedekindDomain.HeightOneSpectrum WithZero
+
+namespace WeilPairingND
+
+variable {R : Type*} [CommRing R] [IsDedekindDomain R] {K : Type*} [Field K] [Algebra R K]
+  [IsFractionRing R K]
+
+lemma le_exp_neg_one_of_lt_one {x : ℤᵐ⁰} (hx : x < 1) : x ≤ exp (-1) := by
+  by_cases h0 : x = 0
+  · rw [h0]; exact zero_le
+  · rw [← exp_log h0] at hx ⊢
+    rw [← exp_zero, exp_lt_exp] at hx
+    rw [exp_le_exp]
+    omega
+
+omit [IsDedekindDomain R] in
+lemma isUnit_of_forall_not_mem [IsDomain R] {r : R} (hr : ∀ w : HeightOneSpectrum R, r ∉ w.asIdeal)
+    (w₀ : HeightOneSpectrum R) : IsUnit r := by
+  by_contra hu
+  obtain ⟨𝔪, h𝔪, hle⟩ := Ideal.exists_le_maximal (Ideal.span {r}) (Ideal.span_singleton_ne_top hu)
+  have hr0 : r ≠ 0 := by
+    rintro rfl
+    exact hr w₀ (Submodule.zero_mem _)
+  have h𝔪0 : 𝔪 ≠ ⊥ := fun h => by
+    rw [h, le_bot_iff, Ideal.span_singleton_eq_bot] at hle
+    exact hr0 hle
+  exact hr ⟨𝔪, h𝔪.isPrime, h𝔪0⟩ (hle (Ideal.mem_span_singleton_self r))
+
+theorem exists_eq_span_of_eq_pullback (μ : K →+* K)
+    (N : HeightOneSpectrum R → Option (HeightOneSpectrum R)) (hN : ∀ w, ∃ v, N v = some w)
+    (hμ : ∀ v w, N v = some w → ∀ (h : K) (k : ℕ),
+      w.valuation K h ≤ exp (-(k : ℤ)) → v.valuation K (μ h) ≤ exp (-(k : ℤ)))
+    (g : K) (t₀ : HeightOneSpectrum R) (hg₀ : ∀ v, N v = some t₀ → v.valuation K g = exp (-1))
+    (hg₁ : ∀ v w, N v = some w → w ≠ t₀ → v.valuation K g = 1) (hgμ : ∃ h, μ h = g) :
+    ∃ r : R, t₀.asIdeal = Ideal.span {r} := by
+  obtain ⟨h, rfl⟩ := hgμ
+  obtain ⟨v₀, hv₀⟩ := hN t₀
+  have hg_le : ∀ v w, N v = some w → v.valuation K (μ h) ≤ 1 := by
+    intro v w hvw
+    by_cases hw : w = t₀
+    · subst hw; rw [hg₀ v hvw, ← exp_zero, exp_le_exp]; norm_num
+    · rw [hg₁ v w hvw hw]
+  have hμ0 : ∀ v w, N v = some w → ∀ x : K, w.valuation K x ≤ 1 → v.valuation K (μ x) ≤ 1 := by
+    intro v w hvw x hx
+    have := hμ v w hvw x 0 (by rwa [Nat.cast_zero, neg_zero, exp_zero])
+    rwa [Nat.cast_zero, neg_zero, exp_zero] at this
+  have hh0 : h ≠ 0 := by
+    rintro rfl
+    have := hg₀ v₀ hv₀
+    rw [map_zero, Valuation.map_zero] at this
+    exact WithZero.zero_ne_coe this
+  have hμh0 : μ h ≠ 0 := (map_ne_zero μ).mpr hh0
+  have h1 : ∀ w : HeightOneSpectrum R, w.valuation K h ≤ 1 := by
+    intro w
+    by_contra hlt
+    rw [not_le] at hlt
+    obtain ⟨v, hv⟩ := hN w
+    have hinv : w.valuation K h⁻¹ ≤ exp (-((1 : ℕ) : ℤ)) := by
+      rw [Nat.cast_one, map_inv₀]
+      exact le_exp_neg_one_of_lt_one ((inv_lt_one₀ (lt_trans zero_lt_one hlt)).mpr hlt)
+    have := hμ v w hv h⁻¹ 1 hinv
+    rw [map_inv₀, map_inv₀, Nat.cast_one] at this
+    have hlt' : (v.valuation K (μ h))⁻¹ < 1 := lt_of_le_of_lt this (by
+      rw [← exp_zero, exp_lt_exp]; norm_num)
+    have hpos : 0 < v.valuation K (μ h) := zero_lt_iff.mpr ((Valuation.ne_zero_iff _).mpr hμh0)
+    exact absurd ((inv_lt_one₀ hpos).mp hlt') (not_lt.mpr (hg_le v w hv))
+  obtain ⟨r, hr⟩ := mem_integers_of_valuation_le_one K h h1
+  subst hr
+  have hr0 : r ≠ 0 := fun h0 => hh0 (by rw [h0, map_zero])
+  have h3 : ∀ w : HeightOneSpectrum R, w ≠ t₀ → r ∉ w.asIdeal := by
+    intro w hw hmem
+    obtain ⟨v, hv⟩ := hN w
+    have hlt : w.valuation K (algebraMap R K r) ≤ exp (-((1 : ℕ) : ℤ)) := by
+      rw [Nat.cast_one]
+      exact le_exp_neg_one_of_lt_one ((valuation_lt_one_iff_mem w r).mpr hmem)
+    have := hμ v w hv _ 1 hlt
+    rw [hg₁ v w hv hw, Nat.cast_one, ← exp_zero, exp_le_exp] at this
+    norm_num at this
+  have h4a : r ∈ t₀.asIdeal := by
+    by_contra hnot
+    have hunit : IsUnit r := isUnit_of_forall_not_mem
+      (fun w => by by_cases hw : w = t₀ <;> [exact hw ▸ hnot; exact h3 w hw]) t₀
+    obtain ⟨u, hu⟩ := hunit
+    have hprod : v₀.valuation K (μ (algebraMap R K r)) *
+        v₀.valuation K (μ (algebraMap R K ((u⁻¹ : Rˣ) : R))) = 1 := by
+      rw [← map_mul, ← map_mul, ← map_mul, ← hu, Units.mul_inv, map_one, map_one, map_one]
+    have hle : v₀.valuation K (μ (algebraMap R K ((u⁻¹ : Rˣ) : R))) ≤ 1 :=
+      hμ0 v₀ t₀ hv₀ _ (valuation_le_one t₀ _)
+    have key : v₀.valuation K (μ (algebraMap R K r)) *
+        v₀.valuation K (μ (algebraMap R K ((u⁻¹ : Rˣ) : R))) ≤ exp (-1) * 1 := by
+      rw [hg₀ v₀ hv₀]
+      gcongr
+    rw [hprod, mul_one, ← exp_zero, exp_le_exp] at key
+    norm_num at key
+  have h4b : r ∉ t₀.asIdeal ^ 2 := by
+    intro hmem
+    have hle : t₀.valuation K (algebraMap R K r) ≤ exp (-((2 : ℕ) : ℤ)) := by
+      rw [valuation_of_algebraMap]
+      exact (intValuation_le_pow_iff_mem t₀ r 2).mpr hmem
+    have := hμ v₀ t₀ hv₀ _ 2 hle
+    rw [hg₀ v₀ hv₀, exp_le_exp] at this
+    norm_num at this
+  refine ⟨r, ?_⟩
+  have hdvd : t₀.asIdeal ∣ Ideal.span {r} :=
+    (Ideal.dvd_span_singleton).mpr h4a
+  obtain ⟨J, hJ⟩ := hdvd
+  suffices hJtop : J = ⊤ by rw [hJ, hJtop, Ideal.mul_top]
+  by_contra hJtop
+  obtain ⟨𝔪, h𝔪, hJle⟩ := Ideal.exists_le_maximal J hJtop
+  have hJ0 : J ≠ ⊥ := by
+    intro hJ0
+    rw [hJ0, Ideal.mul_bot, Ideal.span_singleton_eq_bot] at hJ
+    exact hr0 hJ
+  have h𝔪0 : 𝔪 ≠ ⊥ := fun h => hJ0 (le_bot_iff.mp (h ▸ hJle))
+  set w : HeightOneSpectrum R := ⟨𝔪, h𝔪.isPrime, h𝔪0⟩
+  have hrw : r ∈ t₀.asIdeal * w.asIdeal := by
+    have : t₀.asIdeal * w.asIdeal ∣ Ideal.span {r} := by
+      rw [hJ]; exact mul_dvd_mul_left _ ((Ideal.dvd_iff_le).mpr hJle)
+    exact (Ideal.dvd_span_singleton).mp this
+  by_cases hw : w = t₀
+  · apply h4b
+    rw [sq, ← hw]
+    nth_rewrite 1 [hw]
+    exact hrw
+  · exact h3 w hw (Ideal.mul_le_right hrw)
+
+end WeilPairingND
+
+theorem solution {R : Type*} [CommRing R] [IsDedekindDomain R] {K : Type*} [Field K] [Algebra R K]
+  [IsFractionRing R K] (μ : K →+* K) (N : IsDedekindDomain.HeightOneSpectrum R → Option
+  (IsDedekindDomain.HeightOneSpectrum R)) (hN : ∀ w, ∃ v, N v = some w) (hμ : ∀ v w, N v = some w →
+  ∀ (h : K) (k : ℕ), w.valuation K h ≤ WithZero.exp (-(k : ℤ)) → v.valuation K (μ h) ≤ WithZero.exp
+  (-(k : ℤ))) (g : K) (t₀ : IsDedekindDomain.HeightOneSpectrum R) (hg₀ : ∀ v, N v = some t₀ →
+  v.valuation K g = WithZero.exp (-1)) (hg₁ : ∀ v w, N v = some w → w ≠ t₀ → v.valuation K g = 1)
+  (hgμ : ∃ h, μ h = g) :
+    ∃ r : R, t₀.asIdeal = Ideal.span {r} :=
+  WeilPairingND.exists_eq_span_of_eq_pullback μ N hN hμ g t₀ hg₀ hg₁ hgμ
+
+end S_IsDedekindDomain_HeightOneSpectrum_exists_eq_span_singleton_of_map_eq
+end P2MW
+export P2MW.S_IsDedekindDomain_HeightOneSpectrum_exists_eq_span_singleton_of_map_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem IsDedekindDomain.HeightOneSpectrum.exists_eq_span_singleton_of_map_eq {R : Type*} [CommRing
+  R] [IsDedekindDomain R] {K : Type*} [Field K] [Algebra R K] [IsFractionRing R K] (μ : K →+* K) (N
+  : IsDedekindDomain.HeightOneSpectrum R → Option (IsDedekindDomain.HeightOneSpectrum R)) (hN : ∀ w,
+  ∃ v, N v = some w) (hμ : ∀ v w, N v = some w → ∀ (h : K) (k : ℕ), w.valuation K h ≤ WithZero.exp
+  (-(k : ℤ)) → v.valuation K (μ h) ≤ WithZero.exp (-(k : ℤ))) (g : K) (t₀ :
+  IsDedekindDomain.HeightOneSpectrum R) (hg₀ : ∀ v, N v = some t₀ → v.valuation K g = WithZero.exp
+  (-1)) (hg₁ : ∀ v w, N v = some w → w ≠ t₀ → v.valuation K g = 1) (hgμ : ∃ h, μ h = g) :
+    ∃ r : R, t₀.asIdeal = Ideal.span {r} :=
+  solution μ N hN hμ g t₀ hg₀ hg₁ hgμ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_IsDedekindDomain_HeightOneSpectrum_valuation_eq_exp_neg_count.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_IsDedekindDomain_HeightOneSpectrum_valuation_eq_exp_neg_count.lean
new file mode 100644
index 0000000000..f518ac2b6f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_IsDedekindDomain_HeightOneSpectrum_valuation_eq_exp_neg_count.lean
@@ -0,0 +1,112 @@
+/-
+Based on Prove2Me node IsDedekindDomain.HeightOneSpectrum.valuation_eq_exp_neg_count
+(bd555933-1cd7-5e0f-bba0-cf3d5fefac90) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5579bf6c-bb3f-58ad-83a1-88349d199c9d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.DedekindDomain.AdicValuation
+public import Mathlib.RingTheory.DedekindDomain.Factorization
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# v-adic valuation as exp of minus the multiplicity of v
+
+Theorem statement: `IsDedekindDomain.HeightOneSpectrum.valuation_eq_exp_neg_count`
+(`bd555933-1cd7-5e0f-bba0-cf3d5fefac90`), by Claude, 2026-09-05.
+
+Proof: submission `5579bf6c-bb3f-58ad-83a1-88349d199c9d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring which is a Dedekind domain, let $K$ be a field equipped with an
+$R$-algebra structure making it a fraction field of $R$, let $v$ be a point of the height-one
+spectrum of $R$ (a nonzero prime ideal of height one), and let $x \in K$ with $x \neq 0$. The
+assertion is that the multiplicative $v$-adic valuation $v(x)$ of $x$ on $K$, in the sense of
+Mathlib's `IsDedekindDomain.HeightOneSpectrum.valuation`, taking values in $\mathbb{Z}$ with a zero
+adjoined, equals $\exp(-n)$, where $n =$ `FractionalIdeal.count K v (FractionalIdeal.spanSingleton
+R⁰ x)` is the exponent of $v$ in the factorisation into powers of height-one primes of the principal
+fractional ideal $xR \subseteq K$ generated by $x$ (here $R⁰$ denotes the monoid of
+non-zero-divisors of $R$, with respect to which the fractional ideals are formed), and $\exp$ is the
+embedding of the additive group $\mathbb{Z}$ into the multiplicative monoid $\mathbb{Z}$-with-zero.
+Thus the two Mathlib descriptions of the order of $x$ at $v$ — through the valuation and through the
+ideal factorisation — agree, with the normalisation in which a uniformiser has valuation $\exp(-1)$.
+
+This is the classical identification of the exponential valuation $v_{\mathfrak p}$ on the fraction
+field of a Dedekind domain with the multiplicity of $\mathfrak p$ in the principal ideal $(x)$, i.e.
+$(x) = \prod_{\mathfrak p} \mathfrak p^{v_{\mathfrak p}(x)}$. It serves as the bridge allowing
+orders of zeros and poles to be computed from ideal factorisations; it is used in the treatment of
+valuations of functions on Weierstrass curves and in an estimate for automorphic forms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_IsDedekindDomain_HeightOneSpectrum_valuation_eq_exp_neg_count.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_IsDedekindDomain_HeightOneSpectrum_valuation_eq_exp_neg_count
+
+open scoped nonZeroDivisors
+
+theorem solution {R : Type*} [CommRing R] [IsDedekindDomain R] (K : Type*) [Field K] [Algebra R K]
+    [IsFractionRing R K] (v : IsDedekindDomain.HeightOneSpectrum R) {x : K} (hx : x ≠ 0) :
+    v.valuation K x = WithZero.exp (-FractionalIdeal.count K v (FractionalIdeal.spanSingleton R⁰ x))
+      := by
+  classical
+  obtain ⟨r, s, rfl⟩ := IsLocalization.exists_mk'_eq R⁰ x
+  have hr : r ≠ 0 := by
+    rintro rfl
+    exact hx (by simp)
+  have hs : (s : R) ≠ 0 := nonZeroDivisors.coe_ne_zero s
+  rw [IsDedekindDomain.HeightOneSpectrum.valuation_of_mk',
+    IsDedekindDomain.HeightOneSpectrum.intValuation_if_neg _ hr,
+    IsDedekindDomain.HeightOneSpectrum.intValuation_if_neg _ hs]
+  have hx' : FractionalIdeal.spanSingleton R⁰ (IsLocalization.mk' K r s) =
+      ((Ideal.span {r} : Ideal R) : FractionalIdeal R⁰ K) *
+        ((Ideal.span {(s : R)} : Ideal R) : FractionalIdeal R⁰ K)⁻¹ := by
+    rw [FractionalIdeal.coeIdeal_span_singleton, FractionalIdeal.coeIdeal_span_singleton,
+      FractionalIdeal.spanSingleton_inv, FractionalIdeal.spanSingleton_mul_spanSingleton,
+      IsFractionRing.mk'_eq_div, div_eq_mul_inv]
+  have hr' : ((Ideal.span {r} : Ideal R) : FractionalIdeal R⁰ K) ≠ 0 := by
+    rwa [Ne, FractionalIdeal.coeIdeal_eq_zero, Ideal.span_singleton_eq_bot]
+  have hs' : ((Ideal.span {(s : R)} : Ideal R) : FractionalIdeal R⁰ K) ≠ 0 := by
+    rwa [Ne, FractionalIdeal.coeIdeal_eq_zero, Ideal.span_singleton_eq_bot]
+  rw [hx', FractionalIdeal.count_mul K v hr' (inv_ne_zero hs'), FractionalIdeal.count_inv,
+    FractionalIdeal.count_coe K v (by rwa [Ne, Ideal.span_singleton_eq_bot] : Ideal.span {r} ≠ ⊥),
+    FractionalIdeal.count_coe K v
+      (by rwa [Ne, Ideal.span_singleton_eq_bot] : Ideal.span {(s : R)} ≠ ⊥),
+    ← WithZero.exp_sub]
+  congr 1
+  ring
+
+end S_IsDedekindDomain_HeightOneSpectrum_valuation_eq_exp_neg_count
+end P2MW
+export P2MW.S_IsDedekindDomain_HeightOneSpectrum_valuation_eq_exp_neg_count (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped nonZeroDivisors
+
+theorem IsDedekindDomain.HeightOneSpectrum.valuation_eq_exp_neg_count {R : Type*} [CommRing R]
+    [IsDedekindDomain R] (K : Type*) [Field K] [Algebra R K] [IsFractionRing R K]
+    (v : IsDedekindDomain.HeightOneSpectrum R) {x : K} (hx : x ≠ 0) :
+    v.valuation K x = WithZero.exp (-FractionalIdeal.count K v (FractionalIdeal.spanSingleton R⁰ x))
+      :=
+  solution K v hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_IsDiscreteValuationRing_adicCompletion_isDomain_isDiscreteValuationRing_isAdicComplete.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_IsDiscreteValuationRing_adicCompletion_isDomain_isDiscreteValuationRing_isAdicComplete.lean
new file mode 100644
index 0000000000..2096b08053
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_IsDiscreteValuationRing_adicCompletion_isDomain_isDiscreteValuationRing_isAdicComplete.lean
@@ -0,0 +1,285 @@
+/-
+Based on Prove2Me node
+IsDiscreteValuationRing.adicCompletion_isDomain_isDiscreteValuationRing_isAdicComplete
+(a0e3aec5-3479-5c44-9927-bcd6e6f2d355) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c8a40646-de82-5693-82eb-fc9693205e2f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.RegularLocalRing.Defs
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AdicCompletionLocalRing
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Adic completion of a DVR is a complete DVR
+
+Theorem statement:
+`IsDiscreteValuationRing.adicCompletion_isDomain_isDiscreteValuationRing_isAdicComplete`
+(`a0e3aec5-3479-5c44-9927-bcd6e6f2d355`), by Claude, 2026-09-05.
+
+Proof: submission `c8a40646-de82-5693-82eb-fc9693205e2f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $C$ be a commutative ring which is a domain and a discrete valuation ring, and let $\varpi \in
+C$ be an irreducible element. Write $\hat C =$ `AdicCompletion (IsLocalRing.maximalIdeal C) C` for
+the adic completion of $C$ at its maximal ideal, and let $\iota =$ `algebraMap C` $\hat C$ denote
+the canonical map. The theorem asserts the existence of three pieces of data, namely proofs that
+$\hat C$ is a domain, that $\hat C$ is a discrete valuation ring, and that $\hat C$ is adically
+complete with respect to its own maximal ideal `IsLocalRing.maximalIdeal` $\hat C$ (so the statement
+packages these as an existential rather than registering them as instances), together with the
+conjunction of three further assertions: first, $\iota(\varpi)$ is irreducible in $\hat C$; second,
+for every $n \in \mathbb{N}$ and every $c \in C$, if $\iota(c)$ lies in the ideal of $\hat C$
+generated by $\iota(\varpi)^n$ then already $c$ lies in the ideal of $C$ generated by $\varpi^n$;
+third, for every $n \in \mathbb{N}$ and every $w \in \hat C$ there is $c \in C$ with $w - \iota(c)$
+in the ideal generated by $\iota(\varpi)^n$.
+
+This is the standard fact that the completion of a discrete valuation ring at its maximal ideal is
+again a discrete valuation ring, complete for its adic topology, with the structure map an isometry
+(second clause) with dense image (third clause) and the uniformiser remaining a uniformiser. It is
+the tool that allows results formulated for an abstract complete discrete valuation ring to be
+applied to the completion of a given one, and is invoked throughout the local study of the node
+rings and stalks occurring later.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_IsDiscreteValuationRing_adicCompletion_isDomain_isDiscreteValuationRing_isAdicComplete.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_3bbd935a
+
+universe u
+
+open IsLocalRing
+
+namespace ADICDVRe133
+
+variable {C : Type u} [CommRing C] [IsDomain C] [IsDiscreteValuationRing C]
+
+theorem maximalIdeal_eq_span (ϖ : C) (hϖ : Irreducible ϖ) :
+    maximalIdeal (AdicCompletion (maximalIdeal C) C) =
+      Ideal.span {algebraMap C (AdicCompletion (maximalIdeal C) C) ϖ} := by
+  rw [AdicCompletion.maximalIdeal_eq_map, hϖ.maximalIdeal_eq, Ideal.map_span, Set.image_singleton]
+
+theorem maximalIdeal_pow_eq_span (ϖ : C) (hϖ : Irreducible ϖ) (n : ℕ) :
+    maximalIdeal (AdicCompletion (maximalIdeal C) C) ^ n =
+      Ideal.span {algebraMap C (AdicCompletion (maximalIdeal C) C) ϖ ^ n} := by
+  rw [maximalIdeal_eq_span ϖ hϖ, Ideal.span_singleton_pow]
+
+theorem eq_zero_of_forall_mem_pow (x : AdicCompletion (maximalIdeal C) C)
+    (h : ∀ n, x ∈ maximalIdeal (AdicCompletion (maximalIdeal C) C) ^ n) : x = 0 := by
+  refine AdicCompletion.ext_evalₐ (fun n => ?_)
+  have hn := h n
+  rw [AdicCompletion.maximalIdeal_pow_eq_ker_evalₐ, RingHom.mem_ker] at hn
+  rw [hn, map_zero]
+
+theorem algebraMap_pow_ne_zero (ϖ : C) (hϖ : Irreducible ϖ) (m : ℕ) :
+    algebraMap C (AdicCompletion (maximalIdeal C) C) ϖ ^ m ≠ 0 := by
+  intro h
+  have h1 : AdicCompletion.evalₐ (maximalIdeal C) (m + 1)
+      (algebraMap C (AdicCompletion (maximalIdeal C) C) (ϖ ^ m)) = 0 := by
+    rw [map_pow, h, map_zero]
+  rw [AdicCompletion.evalₐ_algebraMap, Ideal.Quotient.eq_zero_iff_mem, hϖ.maximalIdeal_eq,
+    Ideal.span_singleton_pow, Ideal.mem_span_singleton] at h1
+  obtain ⟨c, hc⟩ := h1
+  have hϖ0 : ϖ ≠ 0 := hϖ.ne_zero
+  have h2 : ϖ ^ m * 1 = ϖ ^ m * (ϖ * c) := by rw [mul_one, ← mul_assoc, ← pow_succ]; exact hc
+  have h3 : (1 : C) = ϖ * c := mul_left_cancel₀ (pow_ne_zero m hϖ0) h2
+  exact hϖ.not_isUnit (isUnit_iff_exists_inv.mpr ⟨c, h3.symm⟩)
+
+theorem exists_eq_unit_mul_pow (ϖ : C) (hϖ : Irreducible ϖ) (x : AdicCompletion (maximalIdeal C) C)
+    (hx : x ≠ 0) :
+    ∃ (n : ℕ) (v : (AdicCompletion (maximalIdeal C) C)ˣ),
+      x = (v : AdicCompletion (maximalIdeal C) C) * algebraMap C (AdicCompletion (maximalIdeal C) C)
+        ϖ ^ n := by
+  classical
+  have hex : ∃ n, x ∉ maximalIdeal (AdicCompletion (maximalIdeal C) C) ^ n := by
+    by_contra hall
+    push Not at hall
+    exact hx (eq_zero_of_forall_mem_pow x hall)
+  let N := Nat.find hex
+  have hN : x ∉ maximalIdeal (AdicCompletion (maximalIdeal C) C) ^ N := Nat.find_spec hex
+  have hN0 : N ≠ 0 := by
+    intro h0
+    apply hN
+    rw [h0, pow_zero, Ideal.one_eq_top]
+    exact Submodule.mem_top
+  obtain ⟨n, hn⟩ := Nat.exists_eq_succ_of_ne_zero hN0
+  have hxn : x ∈ maximalIdeal (AdicCompletion (maximalIdeal C) C) ^ n := by
+    have hlt : n < N := by rw [hn]; exact Nat.lt_succ_self n
+    have := Nat.find_min hex hlt
+    simpa using this
+  rw [maximalIdeal_pow_eq_span ϖ hϖ n, Ideal.mem_span_singleton] at hxn
+  obtain ⟨x', hx'⟩ := hxn
+  have hx'u : IsUnit x' := by
+    by_contra hnu
+    apply hN
+    rw [hn, maximalIdeal_pow_eq_span ϖ hϖ, Ideal.mem_span_singleton, hx']
+    have hmem : x' ∈ maximalIdeal (AdicCompletion (maximalIdeal C) C) :=
+      (mem_maximalIdeal x').mpr hnu
+    rw [maximalIdeal_eq_span ϖ hϖ, Ideal.mem_span_singleton] at hmem
+    obtain ⟨x'', rfl⟩ := hmem
+    exact ⟨x'', by rw [Nat.succ_eq_add_one, pow_succ]; ring⟩
+  refine ⟨n, hx'u.unit, ?_⟩
+  rw [hx', IsUnit.unit_spec, mul_comm]
+
+theorem isDomain (ϖ : C) (hϖ : Irreducible ϖ) : IsDomain (AdicCompletion (maximalIdeal C) C) := by
+  have : NoZeroDivisors (AdicCompletion (maximalIdeal C) C) := by
+    refine ⟨fun {a b} hab => ?_⟩
+    by_contra hne
+    push Not at hne
+    obtain ⟨m, v, hv⟩ := exists_eq_unit_mul_pow ϖ hϖ a hne.1
+    obtain ⟨n, w, hw⟩ := exists_eq_unit_mul_pow ϖ hϖ b hne.2
+    have h : (v : AdicCompletion (maximalIdeal C) C) * w * algebraMap C _ ϖ ^ (m + n) = 0 := by
+      rw [← hab, hv, hw]; ring
+    have h' : algebraMap C (AdicCompletion (maximalIdeal C) C) ϖ ^ (m + n) = 0 := by
+      have hu : IsUnit ((v : AdicCompletion (maximalIdeal C) C) * w) :=
+        (Units.isUnit v).mul (Units.isUnit w)
+      exact (hu.mul_right_eq_zero).mp h
+    exact algebraMap_pow_ne_zero ϖ hϖ (m + n) h'
+  exact NoZeroDivisors.to_isDomain _
+
+theorem irreducible_algebraMap (ϖ : C) (hϖ : Irreducible ϖ) :
+    Irreducible (algebraMap C (AdicCompletion (maximalIdeal C) C) ϖ) := by
+  have := isDomain ϖ hϖ
+  have hπ0 : algebraMap C (AdicCompletion (maximalIdeal C) C) ϖ ≠ 0 := by
+    have := algebraMap_pow_ne_zero ϖ hϖ 1
+    rwa [pow_one] at this
+  have hπnu : ¬ IsUnit (algebraMap C (AdicCompletion (maximalIdeal C) C) ϖ) := by
+    intro hu
+    have hmem : algebraMap C (AdicCompletion (maximalIdeal C) C) ϖ ∈ maximalIdeal _ := by
+      rw [maximalIdeal_eq_span ϖ hϖ]; exact Ideal.mem_span_singleton_self _
+    exact (mem_maximalIdeal _).mp hmem hu
+  refine ⟨hπnu, fun a b hab => ?_⟩
+  by_cases ha0 : a = 0
+  · exact absurd (by rw [hab, ha0, zero_mul]) hπ0
+  by_cases hb0 : b = 0
+  · exact absurd (by rw [hab, hb0, mul_zero]) hπ0
+  obtain ⟨m, v, hv⟩ := exists_eq_unit_mul_pow ϖ hϖ a ha0
+  obtain ⟨n, w, hw⟩ := exists_eq_unit_mul_pow ϖ hϖ b hb0
+  rcases Nat.eq_zero_or_pos m with hm | hm
+  · left
+    rw [hv, hm, pow_zero, mul_one]
+    exact Units.isUnit v
+  rcases Nat.eq_zero_or_pos n with hn | hn
+  · right
+    rw [hw, hn, pow_zero, mul_one]
+    exact Units.isUnit w
+  exfalso
+  obtain ⟨k, hk⟩ : ∃ k, m + n = k + 2 := ⟨m + n - 2, by omega⟩
+  have h1 : algebraMap C (AdicCompletion (maximalIdeal C) C) ϖ =
+      (v : AdicCompletion (maximalIdeal C) C) * w * algebraMap C _ ϖ ^ (k + 2) := by
+    calc algebraMap C (AdicCompletion (maximalIdeal C) C) ϖ = a * b := hab
+      _ = ((v : AdicCompletion (maximalIdeal C) C) * algebraMap C _ ϖ ^ m) *
+            ((w : AdicCompletion (maximalIdeal C) C) * algebraMap C _ ϖ ^ n) := by rw [hv, hw]
+      _ = (v : AdicCompletion (maximalIdeal C) C) * w * algebraMap C _ ϖ ^ (m + n) := by ring
+      _ = (v : AdicCompletion (maximalIdeal C) C) * w * algebraMap C _ ϖ ^ (k + 2) := by rw [hk]
+  have h2 : algebraMap C (AdicCompletion (maximalIdeal C) C) ϖ * 1 =
+      algebraMap C (AdicCompletion (maximalIdeal C) C) ϖ *
+        ((v : AdicCompletion (maximalIdeal C) C) * w * algebraMap C _ ϖ ^ (k + 1)) := by
+    rw [mul_one]
+    conv_lhs => rw [h1]
+    ring
+  have h3 : (1 : AdicCompletion (maximalIdeal C) C) =
+      (v : AdicCompletion (maximalIdeal C) C) * w * algebraMap C _ ϖ ^ (k + 1) :=
+    mul_left_cancel₀ hπ0 h2
+  have hu : IsUnit (algebraMap C (AdicCompletion (maximalIdeal C) C) ϖ ^ (k + 1)) :=
+    isUnit_iff_exists_inv.mpr ⟨(v : AdicCompletion (maximalIdeal C) C) * w, by
+      rw [mul_comm]; exact h3.symm⟩
+  exact hπnu ((isUnit_pow_iff (Nat.succ_ne_zero k)).mp hu)
+
+theorem isDiscreteValuationRing (ϖ : C) (hϖ : Irreducible ϖ) :
+    @IsDiscreteValuationRing (AdicCompletion (maximalIdeal C) C) _ (isDomain ϖ hϖ) := by
+  have := isDomain ϖ hϖ
+  exact IsDiscreteValuationRing.ofHasUnitMulPowIrreducibleFactorization
+    ⟨algebraMap C _ ϖ, irreducible_algebraMap ϖ hϖ, fun {x} hx => by
+      obtain ⟨n, v, hv⟩ := exists_eq_unit_mul_pow ϖ hϖ x hx
+      exact ⟨n, v, by rw [hv, mul_comm]⟩⟩
+
+theorem isAdicComplete_maximalIdeal :
+    IsAdicComplete (maximalIdeal (AdicCompletion (maximalIdeal C) C)) (AdicCompletion (maximalIdeal
+      C) C) := by
+  rw [AdicCompletion.maximalIdeal_eq_map]
+  exact (IsAdicComplete.map_algebraMap_iff (maximalIdeal C) (AdicCompletion (maximalIdeal C) C)).mpr
+    (AdicCompletion.isAdicComplete AdicCompletion.maximalIdeal_fg)
+
+end ADICDVRe133
+
+open ADICDVRe133 in
+theorem solution
+    (C : Type u) [CommRing C] [IsDomain C] [IsDiscreteValuationRing C] (ϖ : C) (hϖ : Irreducible ϖ)
+    :
+    ∃ (_ : IsDomain (AdicCompletion (IsLocalRing.maximalIdeal C) C))
+      (_ : IsDiscreteValuationRing (AdicCompletion (IsLocalRing.maximalIdeal C) C))
+      (_ : IsAdicComplete (IsLocalRing.maximalIdeal (AdicCompletion (IsLocalRing.maximalIdeal C) C))
+        (AdicCompletion (IsLocalRing.maximalIdeal C) C)),
+      Irreducible (algebraMap C (AdicCompletion (IsLocalRing.maximalIdeal C) C) ϖ) ∧
+      (∀ (n : ℕ) (c : C), algebraMap C (AdicCompletion (IsLocalRing.maximalIdeal C) C) c ∈
+          Ideal.span {algebraMap C (AdicCompletion (IsLocalRing.maximalIdeal C) C) ϖ ^ n} → c ∈
+            Ideal.span {ϖ ^ n}) ∧
+      (∀ (n : ℕ) (w : AdicCompletion (IsLocalRing.maximalIdeal C) C), ∃ c : C,
+          w - algebraMap C (AdicCompletion (IsLocalRing.maximalIdeal C) C) c ∈
+            Ideal.span {algebraMap C (AdicCompletion (IsLocalRing.maximalIdeal C) C) ϖ ^ n}) := by
+  have := isDomain ϖ hϖ
+  have := isDiscreteValuationRing ϖ hϖ
+  refine ⟨inferInstance, inferInstance, isAdicComplete_maximalIdeal, irreducible_algebraMap ϖ hϖ,
+    fun n c hc => ?_,
+    fun n w => ?_⟩
+  · rw [← maximalIdeal_pow_eq_span ϖ hϖ n, AdicCompletion.maximalIdeal_pow_eq_ker_evalₐ,
+      RingHom.mem_ker,
+      AdicCompletion.evalₐ_algebraMap, Ideal.Quotient.eq_zero_iff_mem, hϖ.maximalIdeal_eq,
+      Ideal.span_singleton_pow] at hc
+    exact hc
+  · obtain ⟨a, y, hy, hw⟩ :=
+      AdicCompletion.exists_eq_algebraMap_add (maximalIdeal C) AdicCompletion.maximalIdeal_fg n w
+    refine ⟨a, ?_⟩
+    rw [hw, add_sub_cancel_left, ← maximalIdeal_pow_eq_span ϖ hϖ n,
+      AdicCompletion.maximalIdeal_pow_eq_ker_evalₐ,
+      AdicCompletion.ker_evalₐ_eq_map_pow _ AdicCompletion.maximalIdeal_fg]
+    exact hy
+
+end S_OVERLONG_3bbd935a
+end P2MW
+export P2MW.S_OVERLONG_3bbd935a
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+universe u
+
+open IsLocalRing
+
+theorem IsDiscreteValuationRing.adicCompletion_isDomain_isDiscreteValuationRing_isAdicComplete
+    (C : Type u) [CommRing C] [IsDomain C] [IsDiscreteValuationRing C] (ϖ : C) (hϖ : Irreducible ϖ)
+    :
+    ∃ (_ : IsDomain (AdicCompletion (IsLocalRing.maximalIdeal C) C))
+      (_ : IsDiscreteValuationRing (AdicCompletion (IsLocalRing.maximalIdeal C) C))
+      (_ : IsAdicComplete (IsLocalRing.maximalIdeal (AdicCompletion (IsLocalRing.maximalIdeal C) C))
+        (AdicCompletion (IsLocalRing.maximalIdeal C) C)),
+      Irreducible (algebraMap C (AdicCompletion (IsLocalRing.maximalIdeal C) C) ϖ) ∧
+      (∀ (n : ℕ) (c : C), algebraMap C (AdicCompletion (IsLocalRing.maximalIdeal C) C) c ∈
+          Ideal.span {algebraMap C (AdicCompletion (IsLocalRing.maximalIdeal C) C) ϖ ^ n} → c ∈
+            Ideal.span {ϖ ^ n}) ∧
+      (∀ (n : ℕ) (w : AdicCompletion (IsLocalRing.maximalIdeal C) C), ∃ c : C,
+          w - algebraMap C (AdicCompletion (IsLocalRing.maximalIdeal C) C) c ∈
+            Ideal.span {algebraMap C (AdicCompletion (IsLocalRing.maximalIdeal C) C) ϖ ^ n}) :=
+  solution C ϖ hϖ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_IsIntegral_mem_span_of_adjoin_simple_constants.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_IsIntegral_mem_span_of_adjoin_simple_constants.lean
new file mode 100644
index 0000000000..9c75a0c9d9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_IsIntegral_mem_span_of_adjoin_simple_constants.lean
@@ -0,0 +1,496 @@
+/-
+Based on Prove2Me node IsIntegral.mem_span_of_adjoin_simple_constants
+(334cf788-7019-5491-894a-0eed8ed1f5c0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8f2cfe2c-1483-570c-afcf-afd985706bbd
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+public import Mathlib.RingTheory.IntegralClosure.IsIntegral.Basic
+public import Mathlib.Analysis.Complex.Polynomial.Basic
+
+import Mathlib.FieldTheory.AlgebraicClosure
+import Mathlib.FieldTheory.Perfect
+import Mathlib.LinearAlgebra.Lagrange
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Adjoining an algebraic constant does not enlarge the span
+
+Theorem statement: `IsIntegral.mem_span_of_adjoin_simple_constants`
+(`334cf788-7019-5491-894a-0eed8ed1f5c0`), by Claude, 2026-09-05.
+
+Proof: submission `8f2cfe2c-1483-570c-afcf-afd985706bbd`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field equipped with a $\mathbb{C}$-algebra structure, let $F$ be an intermediate field
+of $\mathbb{C}/\mathbb{Q}$, and let $B \subseteq S$ be subsets of $K$. Let $c \in \mathbb{C}$ be
+algebraic over $F$, and write $F(c)$ for the intermediate field of $\mathbb{C}/F$ generated by $c$,
+viewed as a subset of $\mathbb{C}$. Let $y \in K$ satisfy two hypotheses: first, $y$ belongs to the
+subfield of $K$ generated by the image of $F(c)$ under the structure map $\mathbb{C} \to K$ together
+with $S$; second, $y$ is integral over the subring of $K$ generated by the image of $F(c)$ under the
+structure map together with $B$. The conclusion is that $y$ lies in the $\mathbb{C}$-submodule of
+$K$ spanned by the set of those $z \in K$ which simultaneously belong to the subfield of $K$
+generated by the image of $F$ together with $S$ and are integral over the subring of $K$ generated
+by the image of $F$ together with $B$.
+
+This is the algebraic-constant step in the descent of the field of constants: enlarging the
+coefficient field $F$ inside $\mathbb{C}$ by a single algebraic number leaves unchanged the
+$\mathbb{C}$-span of the elements of $K$ that are $F$-rational in the above sense and integral over
+$F[B]$. It is used in the $q$-expansion argument, where it is cited by
+[`WLight.frickeFunction_intBaseChange`](thm.html#WLight.frickeFunction_intBaseChange).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_IsIntegral_mem_span_of_adjoin_simple_constants.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_IsIntegral_mem_span_of_adjoin_simple_constants
+
+noncomputable section
+
+open Polynomial
+open scoped IntermediateField
+
+namespace WLightR7b
+
+variable {K : Type*} [Field K] [Algebra ℂ K]
+
+omit [Algebra ℂ K] in
+theorem isIntegral_subring_iff (T : Subring K) (y : K) :
+    IsIntegral ↥T y ↔ ∃ p : K[X], p.Monic ∧ (∀ n, p.coeff n ∈ T) ∧ p.eval y = 0 := by
+  constructor
+  · rintro ⟨p, hm, hp⟩
+    refine ⟨p.map (algebraMap ↥T K), hm.map _, fun n ↦ ?_, ?_⟩
+    · rw [Polynomial.coeff_map]; exact (p.coeff n).2
+    · rwa [Polynomial.eval_map]
+  · rintro ⟨p, hm, hc, hp⟩
+    have hl : p ∈ Polynomial.lifts (algebraMap ↥T K) := by
+      rw [Polynomial.lifts_iff_coeff_lifts]
+      intro n; exact ⟨⟨p.coeff n, hc n⟩, rfl⟩
+    obtain ⟨q, hq, -, hqm⟩ := Polynomial.lifts_and_degree_eq_and_monic hl hm
+    refine ⟨q, hqm, ?_⟩
+    rw [← Polynomial.eval_map, hq, hp]
+
+omit [Algebra ℂ K] in
+theorem isIntegral_subalgebra_iff {R₀ : Type*} [CommRing R₀] [Algebra R₀ K]
+    (T : Subalgebra R₀ K) (y : K) :
+    IsIntegral ↥T y ↔ ∃ p : K[X], p.Monic ∧ (∀ n, p.coeff n ∈ T) ∧ p.eval y = 0 := by
+  constructor
+  · rintro ⟨p, hm, hp⟩
+    refine ⟨p.map (algebraMap ↥T K), hm.map _, fun n ↦ ?_, ?_⟩
+    · rw [Polynomial.coeff_map]; exact (p.coeff n).2
+    · rwa [Polynomial.eval_map]
+  · rintro ⟨p, hm, hc, hp⟩
+    have hl : p ∈ Polynomial.lifts (algebraMap ↥T K) := by
+      rw [Polynomial.lifts_iff_coeff_lifts]
+      intro n; exact ⟨⟨p.coeff n, hc n⟩, rfl⟩
+    obtain ⟨q, hq, -, hqm⟩ := Polynomial.lifts_and_degree_eq_and_monic hl hm
+    refine ⟨q, hqm, ?_⟩
+    rw [← Polynomial.eval_map, hq, hp]
+
+omit [Algebra ℂ K] in
+theorem isIntegral_adjoin_iff_closure {R₀ : Type*} [CommRing R₀] [Algebra R₀ K] (B : Set K) (y : K)
+    :
+    IsIntegral ↥(Algebra.adjoin R₀ B) y ↔
+      IsIntegral ↥(Subring.closure (Set.range (algebraMap R₀ K) ∪ B)) y := by
+  rw [isIntegral_subalgebra_iff, isIntegral_subring_iff]
+  simp only [Algebra.mem_adjoin_iff]
+
+omit [Algebra ℂ K] in
+theorem isIntegral_of_isIntegral_adjoin_singleton {A : Type*} [CommRing A] [Algebra A K] {r z : K}
+    (hr : IsIntegral A r) (hz : IsIntegral ↥(Algebra.adjoin A {r}) z) : IsIntegral A z := by
+  have : Algebra.IsIntegral A ↥(Algebra.adjoin A {r}) :=
+    Algebra.IsIntegral.adjoin fun _ h ↦ by rw [Set.mem_singleton_iff] at h; rw [h]; exact hr
+  exact isIntegral_trans z hz
+
+theorem range_algebraMap_subfield (F : IntermediateField ℚ ℂ) :
+    Set.range (algebraMap ↥F K) = ⇑(algebraMap ℂ K) '' (F : Set ℂ) := by
+  ext x
+  constructor
+  · rintro ⟨c, rfl⟩; exact ⟨c, c.2, rfl⟩
+  · rintro ⟨c, hc, rfl⟩; exact ⟨⟨c, hc⟩, rfl⟩
+
+theorem algebraMap_subfield_apply' (F : IntermediateField ℚ ℂ) (E₀ : IntermediateField ↥F ℂ)
+    (c : ↥E₀) : algebraMap ↥E₀ K c = algebraMap ℂ K (c : ℂ) := rfl
+
+theorem range_algebraMap_subfield' (F : IntermediateField ℚ ℂ) (E₀ : IntermediateField ↥F ℂ) :
+    Set.range (algebraMap ↥E₀ K) = ⇑(algebraMap ℂ K) '' (E₀ : Set ℂ) := by
+  ext x
+  constructor
+  · rintro ⟨c, rfl⟩; exact ⟨c, c.2, rfl⟩
+  · rintro ⟨c, hc, rfl⟩; exact ⟨⟨c, hc⟩, rfl⟩
+
+theorem charZero_KFld (F : IntermediateField ℚ ℂ) (L₀ : IntermediateField ↥F K) : CharZero ↥L₀ :=
+  haveI : CharZero ↥F := charZero_of_injective_algebraMap (algebraMap ℚ ↥F).injective
+  charZero_of_injective_algebraMap (algebraMap ↥F ↥L₀).injective
+
+variable (F : IntermediateField ℚ ℂ) (B S : Set K)
+
+abbrev KFld : IntermediateField ↥F K := IntermediateField.adjoin ↥F S
+
+abbrev TRng : Subalgebra ↥F K := Algebra.adjoin ↥F B
+
+def RSet : Set K := {y | y ∈ KFld F S ∧ IsIntegral ↥(TRng F B) y}
+
+variable {B S}
+
+theorem isIntegral_TRng_algebraMap {a : ℂ} (ha : IsIntegral ↥F a) :
+    IsIntegral ↥(TRng F B) (algebraMap ℂ K a) :=
+  (ha.algebraMap (B := K)).tower_top
+
+theorem isIntegral_KFld_algebraMap {a : ℂ} (ha : IsIntegral ↥F a) :
+    IsIntegral ↥(KFld F S) (algebraMap ℂ K a) :=
+  (ha.algebraMap (B := K)).tower_top
+
+theorem minpoly_KFld_dvd (c : ℂ) :
+    minpoly ↥(KFld F S) (algebraMap ℂ K c) ∣ (minpoly ↥F c).map (algebraMap ↥F ↥(KFld F S)) := by
+  apply minpoly.dvd
+  rw [Polynomial.aeval_map_algebraMap, Polynomial.aeval_algebraMap_apply, minpoly.aeval, map_zero]
+
+theorem root_minpoly_KFld_eq_algebraMap {c : ℂ} (hc : IsIntegral ↥F c) {r : K}
+    (hr : r ∈ (minpoly ↥(KFld F S) (algebraMap ℂ K c)).aroots K) :
+    ∃ a : ℂ, IsIntegral ↥F a ∧ algebraMap ℂ K a = r := by
+  set ι := algebraMap ℂ K
+  set q : ℂ[X] := (minpoly ↥F c).map (algebraMap ↥F ℂ) with hq
+  have hqm : q.Monic := (minpoly.monic hc).map _
+  have hq0 : q.map ι ≠ 0 := (hqm.map ι).ne_zero
+  have hdvd : (minpoly ↥(KFld F S) (ι c)).map (algebraMap ↥(KFld F S) K) ∣ q.map ι := by
+    have := Polynomial.map_dvd (algebraMap ↥(KFld F S) K) (minpoly_KFld_dvd F (S := S) c)
+    rw [Polynomial.map_map, ← IsScalarTower.algebraMap_eq] at this
+    rwa [hq, Polynomial.map_map, ← IsScalarTower.algebraMap_eq ↥F ℂ K]
+  have hroots : (q.map ι).roots = q.roots.map ι :=
+    (IsAlgClosed.splits q).roots_map_of_injective (algebraMap ℂ K).injective
+  have hr' : r ∈ (q.map ι).roots := Multiset.mem_of_le (Polynomial.roots.le_of_dvd hq0 hdvd) hr
+  rw [hroots, Multiset.mem_map] at hr'
+  obtain ⟨a, ha, rfl⟩ := hr'
+  refine ⟨a, ?_, rfl⟩
+  rw [Polynomial.mem_roots hqm.ne_zero, Polynomial.IsRoot.def, hq, Polynomial.eval_map,
+    ← Polynomial.aeval_def] at ha
+  exact ⟨minpoly ↥F c, minpoly.monic hc, by rwa [← Polynomial.aeval_def]⟩
+
+attribute [local instance] Classical.propDecidable in
+theorem card_rootFinset_minpoly_KFld {c : ℂ} (hc : IsIntegral ↥F c) :
+    ((minpoly ↥(KFld F S) (algebraMap ℂ K c)).aroots K).toFinset.card =
+      (minpoly ↥(KFld F S) (algebraMap ℂ K c)).natDegree := by
+  set ι := algebraMap ℂ K
+  set L₀ := KFld F S
+  have : CharZero ↥L₀ := charZero_KFld F L₀
+  have hint : IsIntegral ↥L₀ (ι c) := isIntegral_KFld_algebraMap F hc
+  set m₁ := minpoly ↥L₀ (ι c)
+  have hsep : (m₁.map (algebraMap ↥L₀ K)).Separable :=
+    (PerfectField.separable_of_irreducible (minpoly.irreducible hint)).map
+  rw [Polynomial.aroots_def, Multiset.toFinset_card_of_nodup (Polynomial.nodup_roots hsep)]
+  set q : ℂ[X] := (minpoly ↥F c).map (algebraMap ↥F ℂ) with hq
+  have hqm : q.Monic := (minpoly.monic hc).map _
+  have hdvd : m₁.map (algebraMap ↥L₀ K) ∣ q.map ι := by
+    have := Polynomial.map_dvd (algebraMap ↥L₀ K) (minpoly_KFld_dvd F (S := S) c)
+    rw [Polynomial.map_map, ← IsScalarTower.algebraMap_eq] at this
+    rwa [hq, Polynomial.map_map, ← IsScalarTower.algebraMap_eq ↥F ℂ K]
+  have hspl : (m₁.map (algebraMap ↥L₀ K)).Splits :=
+    ((IsAlgClosed.splits q).map ι).of_dvd (hqm.map ι).ne_zero hdvd
+  rw [← hspl.natDegree_eq_card_roots, Polynomial.natDegree_map]
+
+theorem algebraMap_adjoinF_mem {c : ℂ} {z : ℂ} (hz : z ∈ IntermediateField.adjoin ↥F {c}) :
+    algebraMap ℂ K z ∈
+      IntermediateField.adjoin ↥(KFld F S) {algebraMap ℂ K c} := by
+  set f := IsScalarTower.toAlgHom ↥F ℂ K
+  have h1 : algebraMap ℂ K z ∈ (IntermediateField.adjoin ↥F {c}).map f := by
+    rw [← SetLike.mem_coe, IntermediateField.coe_map]
+    exact ⟨z, hz, rfl⟩
+  rw [IntermediateField.adjoin_map, Set.image_singleton] at h1
+  have h2 : IntermediateField.adjoin ↥F {f c} ≤
+      (IntermediateField.adjoin ↥(KFld F S) {algebraMap ℂ K c}).restrictScalars ↥F :=
+    IntermediateField.adjoin_le_iff.mpr (Set.singleton_subset_iff.mpr
+      (IntermediateField.mem_adjoin_simple_self ↥(KFld F S) _))
+  exact h2 h1
+
+theorem closure_adjoin_le {c : ℂ} :
+    Subfield.closure
+        (⇑(algebraMap ℂ K) '' (IntermediateField.adjoin ↥F {c} : Set ℂ) ∪ S) ≤
+      (IntermediateField.adjoin ↥(KFld F S) {algebraMap ℂ K c}).toSubfield := by
+  refine Subfield.closure_le.mpr ?_
+  rintro y (⟨z, hz, rfl⟩ | hy)
+  · exact algebraMap_adjoinF_mem F hz
+  · exact (IntermediateField.adjoin ↥(KFld F S) {algebraMap ℂ K c}).algebraMap_mem
+      ⟨y, IntermediateField.subset_adjoin ↥F S hy⟩
+
+variable (B) in
+theorem exists_lift_of_mem_adjoin (hBS : B ⊆ S) {c : ℂ} (hc : IsIntegral ↥F c) {y : K}
+    (hy : y ∈ Algebra.adjoin ↥(IntermediateField.adjoin ↥F {c}) B) :
+    ∃ y' : ↥(IntermediateField.adjoin ↥(KFld F S) {algebraMap ℂ K c}),
+      (y' : K) = y ∧
+      ∀ φ : ↥(IntermediateField.adjoin ↥(KFld F S) {algebraMap ℂ K c}) →ₐ[↥(KFld F S)] K,
+        φ y' ∈ Algebra.adjoin ↥(TRng F B) {φ (IntermediateField.AdjoinSimple.gen ↥(KFld F S)
+          (algebraMap ℂ K c))} := by
+  set ι := algebraMap ℂ K
+  set L₀ := KFld F S
+  set E := IntermediateField.adjoin ↥L₀ {ι c}
+  set g := IntermediateField.AdjoinSimple.gen ↥L₀ (ι c)
+  induction hy using Algebra.adjoin_induction with
+  | mem x hx =>
+    refine ⟨algebraMap ↥L₀ ↥E ⟨x, IntermediateField.subset_adjoin ↥F S (hBS hx)⟩, rfl, fun φ ↦ ?_⟩
+    rw [AlgHom.commutes]
+    exact Subalgebra.algebraMap_mem (Algebra.adjoin ↥(TRng F B) {φ g})
+      (⟨x, Algebra.subset_adjoin hx⟩ : ↥(TRng F B))
+  | algebraMap z =>
+    have hz : (z : ℂ) ∈ IntermediateField.adjoin ↥F {c} := z.2
+    rw [← IntermediateField.mem_toSubalgebra,
+      IntermediateField.adjoin_simple_toSubalgebra_of_isAlgebraic hc.isAlgebraic,
+      Algebra.adjoin_singleton_eq_range_aeval] at hz
+    obtain ⟨u, hu⟩ := hz
+    refine ⟨Polynomial.aeval g (u.map (algebraMap ↥F ↥L₀)), ?_, fun φ ↦ ?_⟩
+    · rw [algebraMap_subfield_apply', ← IntermediateField.aeval_coe,
+        Polynomial.aeval_map_algebraMap, IntermediateField.AdjoinSimple.coe_gen,
+        Polynomial.aeval_algebraMap_apply]
+      exact congrArg ι hu
+    · rw [← Polynomial.aeval_algHom_apply, Polynomial.aeval_map_algebraMap,
+        ← Polynomial.aeval_map_algebraMap ↥(TRng F B)]
+      exact Polynomial.aeval_mem_adjoin_singleton _ _
+  | add x y _ _ ihx ihy =>
+    obtain ⟨x', hx', hx⟩ := ihx
+    obtain ⟨y', hy', hy⟩ := ihy
+    exact ⟨x' + y', by rw [IntermediateField.coe_add, hx', hy'], fun φ ↦ by
+      rw [map_add]; exact Subalgebra.add_mem _ (hx φ) (hy φ)⟩
+  | mul x y _ _ ihx ihy =>
+    obtain ⟨x', hx', hx⟩ := ihx
+    obtain ⟨y', hy', hy⟩ := ihy
+    exact ⟨x' * y', by rw [IntermediateField.coe_mul, hx', hy'], fun φ ↦ by
+      rw [map_mul]; exact Subalgebra.mul_mem _ (hx φ) (hy φ)⟩
+
+attribute [local instance] Classical.propDecidable in
+theorem isIntegral_coeff_lagrangeBasis {s : Finset K}
+    (hs : ∀ r ∈ s, ∃ a : ℂ, IsIntegral ↥F a ∧ algebraMap ℂ K a = r)
+    {r : K} (hr : r ∈ s) (k : ℕ) :
+    IsIntegral ↥(TRng F B) ((Lagrange.basis s id r).coeff k) := by
+  set ι := algebraMap ℂ K
+  set Sf : Subfield K := (algebraicClosure ↥F ℂ).toSubfield.map ι
+  have hmemS : ∀ r ∈ s, r ∈ Sf := by
+    intro r hr
+    obtain ⟨a, ha, rfl⟩ := hs r hr
+    exact ⟨a, mem_algebraicClosure_iff.mpr ha.isAlgebraic, rfl⟩
+  have hlift : Lagrange.basis s id r ∈ Polynomial.liftsRing Sf.subtype := by
+    unfold Lagrange.basis
+    refine Subring.prod_mem _ fun j hj ↦ ?_
+    unfold Lagrange.basisDivisor
+    have hrS : (id r : K) ∈ Set.range Sf.subtype := ⟨⟨r, hmemS r hr⟩, rfl⟩
+    have hjS : (id j : K) ∈ Set.range Sf.subtype :=
+      ⟨⟨j, hmemS j (Finset.mem_of_mem_erase hj)⟩, rfl⟩
+    refine Subring.mul_mem _ ?_ (Subring.sub_mem _ ?_ ?_)
+    · rw [← Polynomial.lifts_iff_liftsRing]
+      apply Polynomial.C'_mem_lifts
+      obtain ⟨a, ha⟩ := hrS; obtain ⟨b, hb⟩ := hjS
+      exact ⟨(a - b)⁻¹, by rw [map_inv₀, map_sub, ha, hb]⟩
+    · rw [← Polynomial.lifts_iff_liftsRing]; exact Polynomial.X_mem_lifts _
+    · rw [← Polynomial.lifts_iff_liftsRing]; exact Polynomial.C'_mem_lifts hjS
+  rw [← Polynomial.lifts_iff_liftsRing, Polynomial.lifts_iff_coeff_lifts] at hlift
+  obtain ⟨⟨w, hw⟩, hw'⟩ := hlift k
+  obtain ⟨a, ha, rfl⟩ := hw
+  change ι a = _ at hw'
+  rw [← hw']
+  exact isIntegral_TRng_algebraMap F
+    (isAlgebraic_iff_isIntegral.mp (mem_algebraicClosure_iff.mp ha))
+
+variable (B S) in
+theorem mem_span_RSet_of_adjoin_simple (hBS : B ⊆ S) {c : ℂ} (hc : IsIntegral ↥F c) {x : K}
+    (hxK : x ∈ Subfield.closure
+      (⇑(algebraMap ℂ K) '' (IntermediateField.adjoin ↥F {c} : Set ℂ) ∪ S))
+    (hxint : IsIntegral ↥(Algebra.adjoin ↥(IntermediateField.adjoin ↥F {c}) B) x) :
+    x ∈ Submodule.span ℂ (RSet F B S) := by
+  classical
+  set ι := algebraMap ℂ K
+  set L₀ := KFld F S
+  have : CharZero ↥L₀ := charZero_KFld F L₀
+  have hint : IsIntegral ↥L₀ (ι c) := isIntegral_KFld_algebraMap F hc
+  set E := IntermediateField.adjoin ↥L₀ {ι c}
+  set g := IntermediateField.AdjoinSimple.gen ↥L₀ (ι c)
+  set pb := IntermediateField.adjoin.powerBasis hint
+  have hpbg : pb.gen = g := IntermediateField.adjoin.powerBasis_gen hint
+  have hpbd : pb.dim = (minpoly ↥L₀ (ι c)).natDegree :=
+    IntermediateField.adjoin.powerBasis_dim hint
+  set x' : ↥E := ⟨x, closure_adjoin_le F hxK⟩
+  set y : Fin pb.dim → ↥L₀ := fun i ↦ pb.basis.repr x' i
+  have hx' : x' = ∑ i, y i • g ^ (i : ℕ) := by
+    conv_lhs => rw [← pb.basis.sum_repr x']
+    refine Finset.sum_congr rfl fun i _ ↦ ?_
+    rw [pb.coe_basis, hpbg]
+  obtain ⟨P, hPm, hPc, hPx⟩ := (isIntegral_subalgebra_iff _ x).mp hxint
+  set d := P.natDegree
+  choose pc hpc hpcφ using fun n ↦ exists_lift_of_mem_adjoin F B hBS hc (hPc n)
+  have hw : x' ^ d + ∑ n ∈ Finset.range d, pc n * x' ^ n = 0 := by
+    apply Subtype.ext
+    rw [IntermediateField.coe_add, IntermediateField.coe_pow, AddSubmonoidClass.coe_finsetSum,
+      ZeroMemClass.coe_zero]
+    have := hPx
+    rw [hPm.as_sum, Polynomial.eval_add, Polynomial.eval_pow, Polynomial.eval_X,
+      Polynomial.eval_finsetSum] at this
+    simp only [Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_pow, Polynomial.eval_X]
+      at this
+    rw [← this]
+    congr 1
+    refine Finset.sum_congr rfl fun n _ ↦ ?_
+    rw [IntermediateField.coe_mul, IntermediateField.coe_pow, hpc]
+  set roots := (minpoly ↥L₀ (ι c)).aroots K
+  set s := roots.toFinset
+  have hsconst : ∀ r ∈ s, ∃ a : ℂ, IsIntegral ↥F a ∧ ι a = r := fun r hr ↦
+    root_minpoly_KFld_eq_algebraMap F hc (Multiset.mem_toFinset.mp hr)
+  let φ : ∀ r, r ∈ roots → (↥E →ₐ[↥L₀] K) := fun r hr ↦
+    (IntermediateField.algHomAdjoinIntegralEquiv ↥L₀ hint).symm ⟨r, hr⟩
+  have hφg : ∀ r hr, φ r hr g = r := fun r hr ↦
+    IntermediateField.algHomAdjoinIntegralEquiv_symm_apply_gen ↥L₀ hint ⟨r, hr⟩
+  let zf : K → K := fun r ↦ if hr : r ∈ roots then φ r hr x' else 0
+  have hZ1 : ∀ r hr, IsIntegral ↥(TRng F B) (φ r hr x') := by
+    intro r hr
+    set T := Algebra.adjoin ↥(TRng F B) {r}
+    have hrint : IsIntegral ↥(TRng F B) r := by
+      obtain ⟨a, ha, rfl⟩ := root_minpoly_KFld_eq_algebraMap F hc hr
+      exact isIntegral_TRng_algebraMap F ha
+    have hpcT : ∀ n, φ r hr (pc n) ∈ T := by
+      intro n
+      have := hpcφ n (φ r hr)
+      rwa [hφg] at this
+    have hT : IsIntegral ↥T (φ r hr x') := by
+      rw [isIntegral_subalgebra_iff]
+      refine ⟨X ^ d + ∑ n ∈ Finset.range d, C (φ r hr (pc n)) * X ^ n, ?_, ?_, ?_⟩
+      · apply Polynomial.monic_X_pow_add
+        refine (Polynomial.degree_sum_le _ _).trans_lt ?_
+        refine (Finset.sup_lt_iff (WithBot.bot_lt_coe d)).mpr fun k hk ↦ ?_
+        exact (Polynomial.degree_C_mul_X_pow_le _ _).trans_lt
+          (WithBot.coe_lt_coe.mpr (Finset.mem_range.mp hk))
+      · intro k
+        rw [Polynomial.coeff_add, Polynomial.coeff_X_pow, Polynomial.finsetSum_coeff]
+        refine Subalgebra.add_mem _ ?_ (Subalgebra.sum_mem _ fun n _ ↦ ?_)
+        · split_ifs
+          · exact Subalgebra.one_mem _
+          · exact Subalgebra.zero_mem _
+        · rw [Polynomial.coeff_C_mul_X_pow]
+          split_ifs
+          · exact hpcT n
+          · exact Subalgebra.zero_mem _
+      · rw [Polynomial.eval_add, Polynomial.eval_pow, Polynomial.eval_X, Polynomial.eval_finsetSum]
+        simp only [Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_pow, Polynomial.eval_X]
+        rw [← map_pow]
+        simp_rw [← map_pow, ← map_mul]
+        rw [← map_sum, ← map_add, hw, map_zero]
+    exact isIntegral_of_isIntegral_adjoin_singleton hrint hT
+  have hZ2 : ∀ r hr, φ r hr x' = ∑ i, (y i : K) * r ^ (i : ℕ) := by
+    intro r hr
+    rw [hx', map_sum]
+    refine Finset.sum_congr rfl fun i _ ↦ ?_
+    rw [Algebra.smul_def, map_mul, map_pow, hφg, AlgHom.commutes]
+    rfl
+  set Y : K[X] := ∑ i : Fin pb.dim, C (y i : K) * X ^ (i : ℕ)
+  have hcard : s.card = pb.dim := by
+    rw [hpbd]; exact card_rootFinset_minpoly_KFld F hc
+  have hYdeg : Y.degree < s.card := by
+    rw [hcard]; exact Polynomial.degree_sum_fin_lt _
+  have hYeval : ∀ r ∈ s, Y.eval (id r) = zf r := by
+    intro r hr
+    have hr' : r ∈ roots := Multiset.mem_toFinset.mp hr
+    simp only [zf, dite_eq_left hr', id, hZ2 r hr', Y, Polynomial.eval_finsetSum,
+      Polynomial.eval_mul,
+      Polynomial.eval_C, Polynomial.eval_pow, Polynomial.eval_X]
+  have hY : Y = Lagrange.interpolate s id zf :=
+    Lagrange.eq_interpolate_of_eval_eq zf (Set.injOn_id _) hYdeg hYeval
+  have hYcoeff : ∀ i : Fin pb.dim, Y.coeff i = (y i : K) := by
+    intro i
+    simp only [Y, Polynomial.finsetSum_coeff, Polynomial.coeff_C_mul_X_pow]
+    rw [Finset.sum_eq_single i]
+    · simp
+    · intro j _ hji
+      rw [ite_eq_right (fun h ↦ hji (Fin.ext h.symm))]
+    · intro h; exact absurd (Finset.mem_univ i) h
+  have hZ4 : ∀ i : Fin pb.dim, IsIntegral ↥(TRng F B) (y i : K) := by
+    intro i
+    rw [← hYcoeff, hY, Lagrange.interpolate_apply, Polynomial.finsetSum_coeff]
+    refine IsIntegral.sum _ fun r hr ↦ ?_
+    rw [Polynomial.coeff_C_mul]
+    refine IsIntegral.mul ?_ (isIntegral_coeff_lagrangeBasis F hsconst hr _)
+    have hr' : r ∈ roots := Multiset.mem_toFinset.mp hr
+    simp only [zf, dite_eq_left hr']
+    exact hZ1 r hr'
+  have hZ5 : ∀ i : Fin pb.dim, (y i : K) ∈ RSet F B S := fun i ↦ ⟨(y i).2, hZ4 i⟩
+  have hxsum : x = ∑ i : Fin pb.dim, (y i : K) * ι c ^ (i : ℕ) := by
+    have := congrArg (fun e : ↥E ↦ (e : K)) hx'
+    rw [IntermediateField.coe_sum] at this
+    rw [show x = (x' : K) from rfl, this]
+    refine Finset.sum_congr rfl fun i _ ↦ ?_
+    rw [IntermediateField.coe_smul, IntermediateField.coe_pow,
+      IntermediateField.AdjoinSimple.coe_gen, IntermediateField.smul_def, smul_eq_mul]
+  rw [hxsum]
+  refine Submodule.sum_mem _ fun i _ ↦ ?_
+  have : (y i : K) * ι c ^ (i : ℕ) = (c ^ (i : ℕ)) • (y i : K) := by
+    rw [Algebra.smul_def, map_pow, mul_comm]
+  rw [this]
+  exact Submodule.smul_mem _ _ (Submodule.subset_span (hZ5 i))
+
+theorem mem_KFld_iff_closure (z : K) :
+    z ∈ KFld F S ↔ z ∈ Subfield.closure (⇑(algebraMap ℂ K) '' (F : Set ℂ) ∪ S) := by
+  rw [← IntermediateField.mem_toSubfield, IntermediateField.adjoin_toSubfield,
+    range_algebraMap_subfield]
+
+theorem isIntegral_TRng_iff_closure (z : K) :
+    IsIntegral ↥(TRng F B) z ↔
+      IsIntegral ↥(Subring.closure (⇑(algebraMap ℂ K) '' (F : Set ℂ) ∪ B)) z := by
+  rw [isIntegral_adjoin_iff_closure, range_algebraMap_subfield]
+
+theorem isIntegral_adjoin_iff_closure' (E₀ : IntermediateField ↥F ℂ) (z : K) :
+    IsIntegral ↥(Algebra.adjoin ↥E₀ B) z ↔
+      IsIntegral ↥(Subring.closure (⇑(algebraMap ℂ K) '' (E₀ : Set ℂ) ∪ B)) z := by
+  rw [isIntegral_adjoin_iff_closure, range_algebraMap_subfield']
+
+end WLightR7b
+
+theorem solution {K : Type*} [Field K] [Algebra ℂ K]
+    (F : IntermediateField ℚ ℂ) (B S : Set K) (hBS : B ⊆ S) (c : ℂ) (hc : IsAlgebraic ↥F c)
+    (y : K)
+    (hyS : y ∈ Subfield.closure
+      (⇑(algebraMap ℂ K) '' (IntermediateField.adjoin ↥F {c} : Set ℂ) ∪ S))
+    (hyB : IsIntegral ↥(Subring.closure
+      (⇑(algebraMap ℂ K) '' (IntermediateField.adjoin ↥F {c} : Set ℂ) ∪ B)) y) :
+    y ∈ Submodule.span ℂ {z : K | z ∈ Subfield.closure (⇑(algebraMap ℂ K) '' (F : Set ℂ) ∪ S) ∧
+      IsIntegral ↥(Subring.closure (⇑(algebraMap ℂ K) '' (F : Set ℂ) ∪ B)) z} := by
+  have hyB' : IsIntegral ↥(Algebra.adjoin ↥(IntermediateField.adjoin ↥F {c}) B) y := by
+    rw [WLightR7b.isIntegral_adjoin_iff_closure' F]
+    exact hyB
+  have h := WLightR7b.mem_span_RSet_of_adjoin_simple F B S hBS hc.isIntegral hyS hyB'
+  refine Submodule.span_mono (fun z hz => ?_) h
+  exact ⟨(WLightR7b.mem_KFld_iff_closure F z).mp hz.1,
+    (WLightR7b.isIntegral_TRng_iff_closure F z).mp hz.2⟩
+
+end
+
+end S_IsIntegral_mem_span_of_adjoin_simple_constants
+end P2MW
+export P2MW.S_IsIntegral_mem_span_of_adjoin_simple_constants (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem IsIntegral.mem_span_of_adjoin_simple_constants {K : Type*} [Field K] [Algebra ℂ K]
+    (F : IntermediateField ℚ ℂ) (B S : Set K) (hBS : B ⊆ S) (c : ℂ) (hc : IsAlgebraic ↥F c)
+    (y : K)
+    (hyS : y ∈ Subfield.closure
+      (⇑(algebraMap ℂ K) '' (IntermediateField.adjoin ↥F {c} : Set ℂ) ∪ S))
+    (hyB : IsIntegral ↥(Subring.closure
+      (⇑(algebraMap ℂ K) '' (IntermediateField.adjoin ↥F {c} : Set ℂ) ∪ B)) y) :
+    y ∈ Submodule.span ℂ {z : K | z ∈ Subfield.closure (⇑(algebraMap ℂ K) '' (F : Set ℂ) ∪ S) ∧
+      IsIntegral ↥(Subring.closure (⇑(algebraMap ℂ K) '' (F : Set ℂ) ∪ B)) z} :=
+  solution F B S hBS c hc y hyS hyB
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_IsIntegral_mem_span_of_adjoin_simple_constants_transcendental.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_IsIntegral_mem_span_of_adjoin_simple_constants_transcendental.lean
new file mode 100644
index 0000000000..5286596137
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_IsIntegral_mem_span_of_adjoin_simple_constants_transcendental.lean
@@ -0,0 +1,657 @@
+/-
+Based on Prove2Me node IsIntegral.mem_span_of_adjoin_simple_constants_transcendental
+(e0c318e5-4141-5cba-8a82-1849acf24693) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b714685b-9ff4-5987-bf8c-c42173bc2b1e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+public import Mathlib.RingTheory.IntegralClosure.IsIntegral.Basic
+public import Mathlib.Analysis.Complex.Polynomial.Basic
+
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Algebra
+import Mathlib.RingTheory.DedekindDomain.IntegralClosure
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import Mathlib.RingTheory.Polynomial.IsIntegral
+import Mathlib.RingTheory.Polynomial.GaussLemma
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Descent of integrality along a transcendental constant
+
+Theorem statement: `IsIntegral.mem_span_of_adjoin_simple_constants_transcendental`
+(`e0c318e5-4141-5cba-8a82-1849acf24693`), by Claude, 2026-09-05.
+
+Proof: submission `b714685b-9ff4-5987-bf8c-c42173bc2b1e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field equipped with a $\mathbb{C}$-algebra structure, let $F$ be an intermediate field
+of $\mathbb{Q} \subset \mathbb{C}$, and let $t \in K$ be transcendental over $\mathbb{C}$. Let $S
+\subseteq K$ be a finite set with $t \in S$ such that every $s \in S$ is integral over the subring
+of $K$ generated by the image of $F$ under the structure map $\mathbb{C} \to K$ together with $t$
+(that is, over the image of $F[t]$). Let $c \in \mathbb{C}$ be transcendental over $F$, and assume
+moreover that its image in $K$ is transcendental over the subfield of $K$ generated by the image of
+$F$ together with $S$. Let $y \in K$ be an element which lies in the subfield of $K$ generated by
+the image of the intermediate field $F(c)$ of $F \subset \mathbb{C}$ together with $S$, and which is
+integral over the subring of $K$ generated by the image of $F(c)$ together with $t$. Then $y$ lies
+in the $\mathbb{C}$-submodule of $K$ spanned by those $z \in K$ that simultaneously lie in the
+subfield generated by the image of $F$ together with $S$ and are integral over the subring generated
+by the image of $F$ together with $t$.
+
+This is the transcendental step of a descent of the coefficient field: it removes one constant $c$,
+transcendental over $F$, from the field of definition of an integral element, at the cost of passing
+from a single element to a $\mathbb{C}$-linear combination. It is used, alternately with its
+counterpart for algebraic constants, in the proof of
+[`WLight.frickeFunction_intBaseChange`](thm.html#WLight.frickeFunction_intBaseChange).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_IsIntegral_mem_span_of_adjoin_simple_constants_transcendental.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 3200000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_IsIntegral_mem_span_of_adjoin_simple_constants_transcendental
+
+noncomputable section
+
+open Polynomial
+open scoped IntermediateField IntermediateField.algebraAdjoinAdjoin
+
+namespace WLightR8a
+
+variable {K : Type*} [Field K] [Algebra ℂ K]
+
+omit [Algebra ℂ K] in
+theorem isIntegral_subring_iff (T : Subring K) (y : K) :
+    IsIntegral ↥T y ↔ ∃ p : K[X], p.Monic ∧ (∀ n, p.coeff n ∈ T) ∧ p.eval y = 0 := by
+  constructor
+  · rintro ⟨p, hm, hp⟩
+    refine ⟨p.map (algebraMap ↥T K), hm.map _, fun n ↦ ?_, ?_⟩
+    · rw [Polynomial.coeff_map]; exact (p.coeff n).2
+    · rwa [Polynomial.eval_map]
+  · rintro ⟨p, hm, hc, hp⟩
+    have hl : p ∈ Polynomial.lifts (algebraMap ↥T K) := by
+      rw [Polynomial.lifts_iff_coeff_lifts]
+      intro n; exact ⟨⟨p.coeff n, hc n⟩, rfl⟩
+    obtain ⟨q, hq, -, hqm⟩ := Polynomial.lifts_and_degree_eq_and_monic hl hm
+    refine ⟨q, hqm, ?_⟩
+    rw [← Polynomial.eval_map, hq, hp]
+
+omit [Algebra ℂ K] in
+theorem isIntegral_subalgebra_iff {R₀ : Type*} [CommRing R₀] [Algebra R₀ K]
+    (T : Subalgebra R₀ K) (y : K) :
+    IsIntegral ↥T y ↔ ∃ p : K[X], p.Monic ∧ (∀ n, p.coeff n ∈ T) ∧ p.eval y = 0 := by
+  constructor
+  · rintro ⟨p, hm, hp⟩
+    refine ⟨p.map (algebraMap ↥T K), hm.map _, fun n ↦ ?_, ?_⟩
+    · rw [Polynomial.coeff_map]; exact (p.coeff n).2
+    · rwa [Polynomial.eval_map]
+  · rintro ⟨p, hm, hc, hp⟩
+    have hl : p ∈ Polynomial.lifts (algebraMap ↥T K) := by
+      rw [Polynomial.lifts_iff_coeff_lifts]
+      intro n; exact ⟨⟨p.coeff n, hc n⟩, rfl⟩
+    obtain ⟨q, hq, -, hqm⟩ := Polynomial.lifts_and_degree_eq_and_monic hl hm
+    refine ⟨q, hqm, ?_⟩
+    rw [← Polynomial.eval_map, hq, hp]
+
+omit [Algebra ℂ K] in
+theorem isIntegral_adjoin_iff_closure {R₀ : Type*} [CommRing R₀] [Algebra R₀ K] (B : Set K) (y : K)
+    :
+    IsIntegral ↥(Algebra.adjoin R₀ B) y ↔
+      IsIntegral ↥(Subring.closure (Set.range (algebraMap R₀ K) ∪ B)) y := by
+  rw [isIntegral_subalgebra_iff, isIntegral_subring_iff]
+  simp only [Algebra.mem_adjoin_iff]
+
+omit [Algebra ℂ K] in
+theorem isIntegral_of_isIntegral_adjoin_singleton {A : Type*} [CommRing A] [Algebra A K] {r z : K}
+    (hr : IsIntegral A r) (hz : IsIntegral ↥(Algebra.adjoin A {r}) z) : IsIntegral A z := by
+  have : Algebra.IsIntegral A ↥(Algebra.adjoin A {r}) :=
+    Algebra.IsIntegral.adjoin fun _ h ↦ by rw [Set.mem_singleton_iff] at h; rw [h]; exact hr
+  exact isIntegral_trans z hz
+
+theorem algebraMap_subfield_apply (F : IntermediateField ℚ ℂ) (c : ↥F) :
+    algebraMap ↥F K c = algebraMap ℂ K (c : ℂ) := rfl
+
+theorem range_algebraMap_subfield (F : IntermediateField ℚ ℂ) :
+    Set.range (algebraMap ↥F K) = ⇑(algebraMap ℂ K) '' (F : Set ℂ) := by
+  ext x
+  constructor
+  · rintro ⟨c, rfl⟩; exact ⟨c, c.2, rfl⟩
+  · rintro ⟨c, hc, rfl⟩; exact ⟨⟨c, hc⟩, rfl⟩
+
+theorem algebraMap_subfield_apply' (F : IntermediateField ℚ ℂ) (E₀ : IntermediateField ↥F ℂ)
+    (c : ↥E₀) : algebraMap ↥E₀ K c = algebraMap ℂ K (c : ℂ) := rfl
+
+theorem range_algebraMap_subfield' (F : IntermediateField ℚ ℂ) (E₀ : IntermediateField ↥F ℂ) :
+    Set.range (algebraMap ↥E₀ K) = ⇑(algebraMap ℂ K) '' (E₀ : Set ℂ) := by
+  ext x
+  constructor
+  · rintro ⟨c, rfl⟩; exact ⟨c, c.2, rfl⟩
+  · rintro ⟨c, hc, rfl⟩; exact ⟨⟨c, hc⟩, rfl⟩
+
+theorem charZero_K : CharZero K := charZero_of_injective_algebraMap (algebraMap ℂ K).injective
+
+theorem charZero_KFld (F : IntermediateField ℚ ℂ) (L₀ : IntermediateField ↥F K) : CharZero ↥L₀ :=
+  haveI : CharZero ↥F := charZero_of_injective_algebraMap (algebraMap ℚ ↥F).injective
+  charZero_of_injective_algebraMap (algebraMap ↥F ↥L₀).injective
+
+variable (F : IntermediateField ℚ ℂ) (t : K) (S : Set K)
+
+abbrev KFld : IntermediateField ↥F K := IntermediateField.adjoin ↥F S
+
+abbrev TRng : Subalgebra ↥F K := Algebra.adjoin ↥F {t}
+
+def RSet : Set K := {y | y ∈ KFld F S ∧ IsIntegral ↥(TRng F t) y}
+
+abbrev RFld : IntermediateField ↥F K := (↥F)⟮t⟯
+
+abbrev KFldT : IntermediateField ↥(RFld F t) K := IntermediateField.adjoin ↥(RFld F t) S
+
+noncomputable scoped instance algebraTRng_KFldT : Algebra ↥(TRng F t) ↥(KFldT F t S) :=
+  ((algebraMap ↥(RFld F t) ↥(KFldT F t S)).comp (algebraMap ↥(TRng F t) ↥(RFld F t))).toAlgebra
+
+noncomputable scoped instance smulTRng_KFldT : SMul ↥(TRng F t) ↥(KFldT F t S) := Algebra.toSMul
+
+noncomputable scoped instance moduleTRng_KFldT : Module ↥(TRng F t) ↥(KFldT F t S) :=
+  Algebra.toModule
+
+scoped instance : IsScalarTower ↥(TRng F t) ↥(RFld F t) ↥(KFldT F t S) :=
+  IsScalarTower.of_algebraMap_eq fun _ ↦ rfl
+
+scoped instance : IsScalarTower ↥(TRng F t) ↥(KFldT F t S) K :=
+  IsScalarTower.of_algebraMap_eq fun _ ↦ rfl
+
+set_option synthInstance.maxHeartbeats 1600000 in
+scoped instance : FaithfulSMul ↥(TRng F t) ↥(KFldT F t S) := by
+  rw [faithfulSMul_iff_algebraMap_injective]
+  exact (FaithfulSMul.algebraMap_injective ↥(RFld F t) ↥(KFldT F t S)).comp
+    (FaithfulSMul.algebraMap_injective ↥(TRng F t) ↥(RFld F t))
+
+abbrev RFa : Subalgebra ↥(TRng F t) ↥(KFldT F t S) := integralClosure ↥(TRng F t) ↥(KFldT F t S)
+
+set_option synthInstance.maxHeartbeats 800000 in
+scoped instance commRing_RFa : CommRing ↥(RFa F t S) := inferInstance
+
+theorem KFldT_restrictScalars (htS : t ∈ S) :
+    (KFldT F t S).restrictScalars ↥F = KFld F S := by
+  rw [show KFldT F t S = IntermediateField.adjoin ↥(RFld F t) S from rfl,
+    IntermediateField.adjoin_adjoin_left]
+  congr 1
+  simp [Set.insert_eq_self.mpr htS]
+
+theorem mem_KFldT_iff (htS : t ∈ S) (z : K) : z ∈ KFldT F t S ↔ z ∈ KFld F S := by
+  rw [← KFldT_restrictScalars F t S htS, IntermediateField.mem_restrictScalars]
+
+section instances
+
+scoped instance : IsDomain ↥(TRng F t) := Subalgebra.isDomain _
+
+def TRngEquiv (ht : Transcendental ℂ t) : (↥F)[X] ≃ₐ[↥F] ↥(TRng F t) :=
+  Polynomial.algEquivOfTranscendental ↥F t
+    (ht.restrictScalars (FaithfulSMul.algebraMap_injective ↥F ℂ))
+
+theorem isPrincipalIdealRing_TRng (ht : Transcendental ℂ t) :
+    IsPrincipalIdealRing ↥(TRng F t) :=
+  IsPrincipalIdealRing.of_surjective (TRngEquiv F t ht).toRingEquiv.toRingHom
+    (TRngEquiv F t ht).surjective
+
+theorem finiteDimensional_KFldT (hSfin : S.Finite)
+    (hSint : ∀ s ∈ S, IsIntegral ↥(TRng F t) s) :
+    FiniteDimensional ↥(RFld F t) ↥(KFldT F t S) := by
+  have : Finite ↥S := hSfin.to_subtype
+  refine IntermediateField.finiteDimensional_adjoin (fun s hs => ?_)
+  exact (hSint s hs).tower_top
+
+scoped instance charZero_KFldT : CharZero ↥(KFldT F t S) :=
+  haveI : CharZero ↥(RFld F t) := charZero_KFld F (RFld F t)
+  charZero_of_injective_algebraMap (algebraMap ↥(RFld F t) ↥(KFldT F t S)).injective
+
+set_option synthInstance.maxHeartbeats 1600000 in
+theorem isDedekindDomain_RFa (ht : Transcendental ℂ t) (hSfin : S.Finite)
+    (hSint : ∀ s ∈ S, IsIntegral ↥(TRng F t) s) : IsDedekindDomain ↥(RFa F t S) := by
+  have := isPrincipalIdealRing_TRng F t ht
+  have := finiteDimensional_KFldT F t S hSfin hSint
+  exact integralClosure.isDedekindDomain ↥(TRng F t) ↥(RFld F t) ↥(KFldT F t S)
+
+set_option synthInstance.maxHeartbeats 1600000 in
+theorem isFractionRing_RFa (ht : Transcendental ℂ t) (hSfin : S.Finite)
+    (hSint : ∀ s ∈ S, IsIntegral ↥(TRng F t) s) :
+    IsFractionRing ↥(RFa F t S) ↥(KFldT F t S) := by
+  have hPID := isPrincipalIdealRing_TRng F t ht
+  have : IsDedekindDomain ↥(TRng F t) := @IsPrincipalIdealRing.isDedekindDomain _ _ _ hPID
+  have := finiteDimensional_KFldT F t S hSfin hSint
+  exact integralClosure.isFractionRing_of_finite_extension ↥(RFld F t) ↥(KFldT F t S)
+
+end instances
+
+set_option synthInstance.maxHeartbeats 3200000 in
+theorem isIntegrallyClosed_RFa_polynomial (ht : Transcendental ℂ t) (hSfin : S.Finite)
+    (hSint : ∀ s ∈ S, IsIntegral ↥(TRng F t) s) :
+    IsIntegrallyClosed (Polynomial ↥(RFa F t S)) := by
+  have : IsDedekindDomain ↥(RFa F t S) := isDedekindDomain_RFa F t S ht hSfin hSint
+  infer_instance
+
+theorem algebraMap_adjoinF_mem {c : ℂ} {z : ℂ} (hz : z ∈ IntermediateField.adjoin ↥F {c}) :
+    algebraMap ℂ K z ∈
+      IntermediateField.adjoin ↥(KFld F S) {algebraMap ℂ K c} := by
+  set f := IsScalarTower.toAlgHom ↥F ℂ K
+  have h1 : algebraMap ℂ K z ∈ (IntermediateField.adjoin ↥F {c}).map f := by
+    rw [← SetLike.mem_coe, IntermediateField.coe_map]
+    exact ⟨z, hz, rfl⟩
+  rw [IntermediateField.adjoin_map, Set.image_singleton] at h1
+  have h2 : IntermediateField.adjoin ↥F {f c} ≤
+      (IntermediateField.adjoin ↥(KFld F S) {algebraMap ℂ K c}).restrictScalars ↥F :=
+    IntermediateField.adjoin_le_iff.mpr (Set.singleton_subset_iff.mpr
+      (IntermediateField.mem_adjoin_simple_self ↥(KFld F S) _))
+  exact h2 h1
+
+theorem closure_adjoin_le {c : ℂ} :
+    Subfield.closure
+        (⇑(algebraMap ℂ K) '' (IntermediateField.adjoin ↥F {c} : Set ℂ) ∪ S) ≤
+      (IntermediateField.adjoin ↥(KFld F S) {algebraMap ℂ K c}).toSubfield := by
+  refine Subfield.closure_le.mpr ?_
+  rintro y (⟨z, hz, rfl⟩ | hy)
+  · exact algebraMap_adjoinF_mem F S hz
+  · exact (IntermediateField.adjoin ↥(KFld F S) {algebraMap ℂ K c}).algebraMap_mem
+      ⟨y, IntermediateField.subset_adjoin ↥F S hy⟩
+
+theorem t_mem_RSet (htS : t ∈ S) : t ∈ RSet F t S :=
+  ⟨IntermediateField.subset_adjoin ↥F S htS, isIntegral_algebraMap
+    (x := (⟨t, Algebra.self_mem_adjoin_singleton ↥F t⟩ : ↥(TRng F t)))⟩
+
+theorem algebraMap_mem_RSet (z : ↥F) : algebraMap ↥F K z ∈ RSet F t S :=
+  ⟨(KFld F S).algebraMap_mem z, isIntegral_algebraMap (x := algebraMap ↥F ↥(TRng F t) z)⟩
+
+variable (c : ℂ)
+
+set_option synthInstance.maxHeartbeats 1600000 in
+def rfPolyEval : (↥(RFa F t S))[X] →+* K :=
+  Polynomial.eval₂RingHom ((algebraMap ↥(KFldT F t S) K).comp (RFa F t S).val.toRingHom)
+    (algebraMap ℂ K c)
+
+variable {c}
+
+set_option synthInstance.maxHeartbeats 1600000 in
+theorem rfPolyEval_injective
+    (htc : Transcendental ↥(KFldT F t S) (algebraMap ℂ K c)) :
+    Function.Injective (rfPolyEval F t S c) := by
+  have h1 : Function.Injective
+      (Polynomial.aeval (R := ↥(KFldT F t S)) (algebraMap ℂ K c)) :=
+    transcendental_iff_injective.mp htc
+  have h2 : Function.Injective (Polynomial.map (RFa F t S).val.toRingHom) :=
+    Polynomial.map_injective _ Subtype.val_injective
+  have hcomp : ⇑(rfPolyEval F t S c) =
+      ⇑(Polynomial.aeval (R := ↥(KFldT F t S)) (algebraMap ℂ K c)) ∘
+        Polynomial.map (RFa F t S).val.toRingHom := by
+    funext q
+    simp only [rfPolyEval, Polynomial.coe_eval₂RingHom, Function.comp_apply,
+      Polynomial.aeval_def, Polynomial.eval₂_map]
+  rw [hcomp]; exact h1.comp h2
+
+set_option synthInstance.maxHeartbeats 1600000 in
+theorem isIntegral_KFldT_of (htS : t ∈ S) {y : K} (hyK : y ∈ KFld F S)
+    (hyI : IsIntegral ↥(TRng F t) y) :
+    IsIntegral ↥(TRng F t) (⟨y, (mem_KFldT_iff F t S htS y).mpr hyK⟩ : ↥(KFldT F t S)) := by
+  obtain ⟨P, hPm, hPe⟩ := hyI
+  refine ⟨P, hPm, ?_⟩
+  apply Subtype.ext
+  rw [ZeroMemClass.coe_zero, ← hPe, Polynomial.eval₂_def, Polynomial.eval₂_def,
+    Polynomial.sum_def, Polynomial.sum_def, AddSubmonoidClass.coe_finsetSum]
+  refine Finset.sum_congr rfl fun n _ => ?_
+  simp only [SubmonoidClass.coe_pow, MulMemClass.coe_mul]
+  rfl
+
+theorem mem_range_rfPolyEval_of_mem_RSet (htS : t ∈ S) {y : K} (hy : y ∈ RSet F t S) :
+    y ∈ Set.range ⇑(rfPolyEval F t S c) := by
+  obtain ⟨hyK, hyI⟩ := hy
+  exact ⟨Polynomial.C ⟨_, isIntegral_KFldT_of F t S htS hyK hyI⟩, by simp [rfPolyEval]⟩
+
+set_option synthInstance.maxHeartbeats 1600000 in
+theorem evalF_mem_range_rfPolyEval (htS : t ∈ S) (q : (↥F)[X]) :
+    Polynomial.aeval (algebraMap ℂ K c) q ∈ Set.range ⇑(rfPolyEval F t S c) := by
+  induction q using Polynomial.induction_on' with
+  | add p q hp hq =>
+    obtain ⟨p₁, h₁⟩ := hp; obtain ⟨p₂, h₂⟩ := hq
+    exact ⟨p₁ + p₂, by rw [map_add, map_add, h₁, h₂]⟩
+  | monomial n z =>
+    have hz := algebraMap_mem_RSet F t S z
+    obtain ⟨w, hw⟩ := mem_range_rfPolyEval_of_mem_RSet F t S htS (c := c) hz
+    refine ⟨w * Polynomial.X ^ n, ?_⟩
+    rw [Polynomial.aeval_monomial, map_mul, map_pow, hw]
+    simp only [rfPolyEval, Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X,
+      algebraMap_subfield_apply]
+
+set_option synthInstance.maxHeartbeats 1600000 in
+theorem evalF_ne_zero (hc : Transcendental ↥F c) {q : (↥F)[X]} (hq : q ≠ 0) :
+    Polynomial.aeval (algebraMap ℂ K c) q ≠ 0 := by
+  intro h0
+  rw [Polynomial.aeval_algebraMap_apply] at h0
+  have h1 : Polynomial.aeval c q = 0 :=
+    (map_eq_zero_iff _ (algebraMap ℂ K).injective).mp h0
+  exact hq ((transcendental_iff.mp hc) q h1)
+
+set_option synthInstance.maxHeartbeats 1600000 in
+theorem range_rfPolyEval_subset_span (htS : t ∈ S) :
+    Set.range ⇑(rfPolyEval F t S c) ⊆
+      (Submodule.span ℂ (RSet F t S) : Set K) := by
+  rintro _ ⟨p, rfl⟩
+  induction p using Polynomial.induction_on' with
+  | add p q hp hq => rw [map_add]; exact add_mem hp hq
+  | monomial n z =>
+    have hshape : rfPolyEval F t S c (Polynomial.monomial n z) =
+        (c ^ n) • ((z : ↥(KFldT F t S)) : K) := by
+      rw [Algebra.smul_def, map_pow, rfPolyEval]
+      simp only [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_monomial]
+      exact mul_comm _ _
+    rw [hshape]
+    refine Submodule.smul_mem _ _ (Submodule.subset_span ⟨?_, ?_⟩)
+    · exact (mem_KFldT_iff F t S htS _).mp (z : ↥(KFldT F t S)).2
+    · have hzK : ((z : ↥(KFldT F t S)) : K) =
+          algebraMap ↥(KFldT F t S) K (z : ↥(KFldT F t S)) := rfl
+      rw [hzK]
+      exact (z.2 : IsIntegral ↥(TRng F t) (z : ↥(KFldT F t S))).algebraMap
+
+set_option synthInstance.maxHeartbeats 1600000 in
+theorem exists_clear_denominator (htS : t ∈ S) {a : K}
+    (ha : a ∈ Algebra.adjoin ↥(IntermediateField.adjoin ↥F {c}) ({t} : Set K)) :
+    ∃ q : (↥F)[X], q ≠ 0 ∧
+      Polynomial.aeval (algebraMap ℂ K c) q * a ∈ Set.range ⇑(rfPolyEval F t S c) := by
+  induction ha using Algebra.adjoin_induction with
+  | mem w hw =>
+    refine ⟨1, one_ne_zero, ?_⟩
+    rw [map_one, one_mul, Set.mem_singleton_iff.mp hw]
+    exact mem_range_rfPolyEval_of_mem_RSet F t S htS (t_mem_RSet F t S htS)
+  | algebraMap z =>
+    obtain ⟨r, s, hz⟩ := (IntermediateField.mem_adjoin_simple_iff ↥F ((z : ℂ))).mp z.2
+    by_cases hs : Polynomial.aeval c s = 0
+    · refine ⟨1, one_ne_zero, ?_⟩
+      have hz0 : (z : ℂ) = 0 := by rw [hz, hs, div_zero]
+      have hmap0 : algebraMap ↥(IntermediateField.adjoin ↥F {c}) K z = 0 := by
+        rw [algebraMap_subfield_apply', hz0, map_zero]
+      rw [map_one, one_mul, hmap0]
+      exact ⟨0, map_zero _⟩
+    · refine ⟨s, fun h0 => hs (by rw [h0, map_zero]), ?_⟩
+      have hid : Polynomial.aeval (algebraMap ℂ K c) s *
+          algebraMap ↥(IntermediateField.adjoin ↥F {c}) K z =
+          Polynomial.aeval (algebraMap ℂ K c) r := by
+        rw [Polynomial.aeval_algebraMap_apply, Polynomial.aeval_algebraMap_apply,
+          algebraMap_subfield_apply', ← map_mul]
+        congr 1; rw [hz]; field_simp
+      rw [hid]; exact evalF_mem_range_rfPolyEval F t S htS r
+  | add u v _ _ ihu ihv =>
+    obtain ⟨q₁, h₁0, A₁, hA₁⟩ := ihu; obtain ⟨q₂, h₂0, A₂, hA₂⟩ := ihv
+    obtain ⟨B₁, hB₁⟩ := evalF_mem_range_rfPolyEval F t S htS (c := c) q₁
+    obtain ⟨B₂, hB₂⟩ := evalF_mem_range_rfPolyEval F t S htS (c := c) q₂
+    refine ⟨q₁ * q₂, mul_ne_zero h₁0 h₂0, B₂ * A₁ + B₁ * A₂, ?_⟩
+    rw [map_add, map_mul, map_mul, hB₁, hB₂, hA₁, hA₂, map_mul]; ring
+  | mul u v _ _ ihu ihv =>
+    obtain ⟨q₁, h₁0, A₁, hA₁⟩ := ihu; obtain ⟨q₂, h₂0, A₂, hA₂⟩ := ihv
+    refine ⟨q₁ * q₂, mul_ne_zero h₁0 h₂0, A₁ * A₂, ?_⟩
+    rw [map_mul, map_mul, hA₁, hA₂]; ring
+
+variable {F t}
+
+set_option synthInstance.maxHeartbeats 4000000 in
+set_option maxSynthPendingDepth 3 in
+theorem mem_span_RSet_of_adjoin_simple_transcendental
+    (ht : Transcendental ℂ t) (htS : t ∈ S) (hSfin : S.Finite)
+    (hSint : ∀ s ∈ S, IsIntegral ↥(TRng F t) s)
+    {c : ℂ} (hc : Transcendental ↥F c)
+    (htc : Transcendental ↥(KFldT F t S) (algebraMap ℂ K c))
+    {x : K}
+    (hxK : x ∈ Subfield.closure
+      (⇑(algebraMap ℂ K) '' (IntermediateField.adjoin ↥F {c} : Set ℂ) ∪ S))
+    (hxint : IsIntegral ↥(Algebra.adjoin ↥(IntermediateField.adjoin ↥F {c}) ({t} : Set K)) x) :
+    x ∈ Submodule.span ℂ (RSet F t S) := by
+  classical
+  set c' : K := algebraMap ℂ K c with hc'
+  set ψ : FractionRing ((↥(RFa F t S))[X]) →+* K :=
+    IsFractionRing.lift (rfPolyEval_injective F t S htc) with hψ
+  have hψalg : ∀ a : (↥(RFa F t S))[X], ψ (algebraMap _ _ a) = rfPolyEval F t S c a :=
+    fun a => IsFractionRing.lift_algebraMap _ _
+  have hψinj : Function.Injective ψ := ψ.injective
+  have hDD : IsDedekindDomain ↥(RFa F t S) := isDedekindDomain_RFa F t S ht hSfin hSint
+  have hFR : IsFractionRing ↥(RFa F t S) ↥(KFldT F t S) :=
+    isFractionRing_RFa F t S ht hSfin hSint
+  have hrange : ∀ z ∈ IntermediateField.adjoin ↥(KFldT F t S) {c'}, z ∈ ψ.fieldRange := by
+    intro z hz
+    rw [← IntermediateField.mem_toSubfield, IntermediateField.adjoin_toSubfield] at hz
+    refine Subfield.closure_le (t := ψ.fieldRange) |>.mpr ?_ hz
+    rintro w (⟨w', rfl⟩ | rfl)
+    · obtain ⟨r, s, hs, hrs⟩ := IsFractionRing.div_surjective (A := ↥(RFa F t S)) w'
+      rw [← hrs]
+      have h1 : algebraMap ↥(KFldT F t S) K (algebraMap ↥(RFa F t S) ↥(KFldT F t S) r) =
+          ψ (algebraMap _ _ (Polynomial.C r)) := by rw [hψalg]; simp [rfPolyEval]
+      have h2 : algebraMap ↥(KFldT F t S) K (algebraMap ↥(RFa F t S) ↥(KFldT F t S) s) =
+          ψ (algebraMap _ _ (Polynomial.C s)) := by rw [hψalg]; simp [rfPolyEval]
+      rw [map_div₀, h1, h2]
+      exact div_mem (RingHom.mem_fieldRange_self ψ _) (RingHom.mem_fieldRange_self ψ _)
+    · exact ⟨algebraMap _ _ Polynomial.X, by rw [hψalg, hc']; simp [rfPolyEval]⟩
+  have hxψ : x ∈ ψ.fieldRange := by
+    refine hrange x ?_
+    have h1 := closure_adjoin_le F S hxK
+    have heq : (IntermediateField.adjoin ↥(KFld F S) {c'}).toSubfield =
+        (IntermediateField.adjoin ↥(KFldT F t S) {c'}).toSubfield := by
+      rw [IntermediateField.adjoin_toSubfield, IntermediateField.adjoin_toSubfield]
+      have hrng : Set.range ⇑(algebraMap ↥(KFld F S) K) =
+          Set.range ⇑(algebraMap ↥(KFldT F t S) K) := by
+        ext z
+        exact ⟨fun ⟨w, hw⟩ => ⟨⟨w, (mem_KFldT_iff F t S htS w).mpr w.2⟩, hw⟩,
+          fun ⟨w, hw⟩ => ⟨⟨w, (mem_KFldT_iff F t S htS w).mp w.2⟩, hw⟩⟩
+      rw [hrng]
+    rw [← IntermediateField.mem_toSubfield, ← heq]; exact h1
+  obtain ⟨P, hPmonic, hPc, hPx⟩ := (isIntegral_subalgebra_iff _ x).mp hxint
+  set n := P.natDegree with hn
+  have hrel : x ^ n + ∑ k ∈ Finset.range n, (P.coeff k) * x ^ k = 0 := by
+    have h1 := hPx
+    rw [hPmonic.as_sum, Polynomial.eval_add, Polynomial.eval_pow, Polynomial.eval_X,
+      Polynomial.eval_finsetSum] at h1
+    simp only [Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_pow, Polynomial.eval_X]
+      at h1
+    linear_combination h1
+  have hn0 : 0 < n := by
+    rcases Nat.eq_zero_or_pos n with h0 | h0
+    · rw [h0] at hrel; simp at hrel
+    · exact h0
+  choose qd hqd0 hqdW using fun (k : ℕ) (hk : k ∈ Finset.range n) =>
+    exists_clear_denominator F t S htS (c := c) (hPc k)
+  set Q : ℕ → (↥F)[X] := fun k => if h : k ∈ Finset.range n then qd k h else 1 with hQ
+  have hQ0 : ∀ k, Q k ≠ 0 := by
+    intro k; by_cases h : k ∈ Finset.range n
+    · simp only [hQ, dite_eq_left h]; exact hqd0 k h
+    · simp only [hQ, dite_eq_right h]; exact one_ne_zero
+  set D : (↥F)[X] := ∏ k ∈ Finset.range n, Q k with hD
+  have hD0 : D ≠ 0 := Finset.prod_ne_zero_iff.mpr fun k _ => hQ0 k
+  set Dv : K := Polynomial.aeval c' D with hDv
+  have hDv0 : Dv ≠ 0 := evalF_ne_zero F hc hD0
+  have hDvrange : Dv ∈ Set.range ⇑(rfPolyEval F t S c) := evalF_mem_range_rfPolyEval F t S htS D
+  have hbW : ∀ k ∈ Finset.range n, Dv ^ (n - k) * (P.coeff k) ∈
+      Set.range ⇑(rfPolyEval F t S c) := by
+    intro k hk
+    have hQk : Q k = qd k hk := by simp only [hQ, dite_eq_left hk]
+    obtain ⟨A₁, hA₁⟩ := hqdW k hk
+    obtain ⟨B₁, hB₁⟩ := evalF_mem_range_rfPolyEval F t S htS (c := c)
+      ((∏ j ∈ (Finset.range n).erase k, Q j) * D ^ (n - k - 1))
+    refine ⟨B₁ * A₁, ?_⟩
+    rw [map_mul, hB₁, hA₁, map_mul, map_pow, ← hDv]
+    have hDvsplit : Dv ^ (n - k) = Polynomial.aeval c' (qd k hk) *
+        Polynomial.aeval c' (∏ j ∈ (Finset.range n).erase k, Q j) * Dv ^ (n - k - 1) := by
+      have h1 : Polynomial.aeval c' (qd k hk) *
+          Polynomial.aeval c' (∏ j ∈ (Finset.range n).erase k, Q j) = Dv := by
+        rw [← hQk, ← map_mul, Finset.mul_prod_erase _ _ hk, hDv, hD]
+      rw [h1, ← pow_succ']
+      congr 1
+      have hkn := Finset.mem_range.mp hk; omega
+    rw [hDvsplit]; ring
+  set y : K := Dv * x with hy
+  have hDψ : Dv ∈ ψ.fieldRange := by
+    obtain ⟨a, ha⟩ := hDvrange
+    exact ⟨algebraMap _ _ a, by rw [hψalg]; exact ha⟩
+  have hyψ : y ∈ ψ.fieldRange := mul_mem hDψ hxψ
+  have hyrel : y ^ n + ∑ k ∈ Finset.range n, (Dv ^ (n - k) * (P.coeff k)) * y ^ k = 0 := by
+    have h1 : ∀ k ∈ Finset.range n, (Dv ^ (n - k) * (P.coeff k)) * y ^ k =
+        Dv ^ n * ((P.coeff k) * x ^ k) := by
+      intro k hk
+      have hkn : k ≤ n := (Finset.mem_range.mp hk).le
+      rw [hy, mul_pow, show Dv ^ n = Dv ^ (n - k) * Dv ^ k from by
+        rw [← pow_add, Nat.sub_add_cancel hkn]]
+      ring
+    rw [Finset.sum_congr rfl h1, ← Finset.mul_sum, hy, mul_pow, ← mul_add, hrel, mul_zero]
+  choose B hB using fun k (hk : k ∈ Finset.range n) => hbW k hk
+  set BB : ℕ → (↥(RFa F t S))[X] := fun k => if h : k ∈ Finset.range n then B k h else 0 with hBB
+  obtain ⟨m, hm⟩ := RingHom.mem_fieldRange.mp hyψ
+  have hmrel : m ^ n + ∑ k ∈ Finset.range n, algebraMap _ _ (BB k) * m ^ k = 0 := by
+    apply hψinj
+    rw [map_add, map_pow, map_sum, map_zero, hm]
+    rw [show (∑ k ∈ Finset.range n, ψ (algebraMap _ _ (BB k) * m ^ k)) =
+        ∑ k ∈ Finset.range n, (Dv ^ (n - k) * (P.coeff k)) * y ^ k from
+      Finset.sum_congr rfl fun k hk => by
+        rw [map_mul, map_pow, hm, hψalg]; simp only [hBB, dite_eq_left hk]; rw [hB k hk]]
+    exact hyrel
+  have hmint : IsIntegral ((↥(RFa F t S))[X]) m := by
+    refine ⟨Polynomial.X ^ n + ∑ k ∈ Finset.range n, Polynomial.C (BB k) * Polynomial.X ^ k,
+      ?_, ?_⟩
+    · exact Polynomial.monic_X_pow_add ((Polynomial.degree_sum_le _ _).trans_lt
+        ((Finset.sup_lt_iff (WithBot.bot_lt_coe n)).mpr fun k hk =>
+          (Polynomial.degree_C_mul_X_pow_le _ _).trans_lt
+            (WithBot.coe_lt_coe.mpr (Finset.mem_range.mp hk))))
+    · rw [Polynomial.eval₂_add, Polynomial.eval₂_pow, Polynomial.eval₂_X,
+        Polynomial.eval₂_finsetSum]
+      rw [show (∑ k ∈ Finset.range n, Polynomial.eval₂ (algebraMap _ _) m
+          (Polynomial.C (BB k) * Polynomial.X ^ k)) =
+          ∑ k ∈ Finset.range n, algebraMap _ _ (BB k) * m ^ k from
+        Finset.sum_congr rfl fun k _ => by
+          rw [Polynomial.eval₂_mul, Polynomial.eval₂_C, Polynomial.eval₂_pow,
+            Polynomial.eval₂_X]]
+      exact hmrel
+  have hDomRFa : IsDomain ↥(RFa F t S) := Subalgebra.isDomain _
+  have hICR : IsIntegrallyClosed ↥(RFa F t S) := inferInstance
+  have hICX : IsIntegrallyClosed ((↥(RFa F t S))[X]) :=
+    isIntegrallyClosed_RFa_polynomial F t S ht hSfin hSint
+  obtain ⟨a, ha⟩ := IsIntegrallyClosed.isIntegral_iff.mp hmint
+  have hyrange : y ∈ Set.range ⇑(rfPolyEval F t S c) :=
+    ⟨a, by rw [← hψalg, ha, hm]⟩
+  have hyspan := range_rfPolyEval_subset_span F t S htS hyrange
+  have hsmul : (Polynomial.aeval c D : ℂ) • x = y := by
+    rw [Algebra.smul_def, hy, hDv, Polynomial.aeval_algebraMap_apply]
+  have hs0 : (Polynomial.aeval c D : ℂ) ≠ 0 := by
+    intro h0; exact hD0 ((transcendental_iff.mp hc) D h0)
+  have hsx : (Polynomial.aeval c D : ℂ) • x ∈ Submodule.span ℂ (RSet F t S) := by
+    rw [hsmul]; exact hyspan
+  have h2 := Submodule.smul_mem (Submodule.span ℂ (RSet F t S))
+    ((Polynomial.aeval c D : ℂ))⁻¹ hsx
+  rwa [← smul_assoc, smul_eq_mul, inv_mul_cancel₀ hs0, one_smul] at h2
+
+variable (F) in
+theorem mem_KFld_iff_closure (z : K) :
+    z ∈ KFld F S ↔ z ∈ Subfield.closure (⇑(algebraMap ℂ K) '' (F : Set ℂ) ∪ S) := by
+  rw [← IntermediateField.mem_toSubfield, IntermediateField.adjoin_toSubfield,
+    range_algebraMap_subfield]
+
+variable (F t) in
+theorem isIntegral_TRng_iff_closure (z : K) :
+    IsIntegral ↥(TRng F t) z ↔
+      IsIntegral ↥(Subring.closure (⇑(algebraMap ℂ K) '' (F : Set ℂ) ∪ {t})) z := by
+  rw [isIntegral_adjoin_iff_closure, range_algebraMap_subfield]
+
+variable (F) in
+theorem isIntegral_adjoin_iff_closure' (E₀ : IntermediateField ↥F ℂ) (z : K) :
+    IsIntegral ↥(Algebra.adjoin ↥E₀ ({t} : Set K)) z ↔
+      IsIntegral ↥(Subring.closure (⇑(algebraMap ℂ K) '' (E₀ : Set ℂ) ∪ {t})) z := by
+  rw [isIntegral_adjoin_iff_closure, range_algebraMap_subfield']
+
+variable (F t) in
+theorem KFldT_toSubfield_eq (htS : t ∈ S) :
+    (KFldT F t S).toSubfield = Subfield.closure (⇑(algebraMap ℂ K) '' (F : Set ℂ) ∪ S) := by
+  have h1 : (KFldT F t S).toSubfield = ((KFldT F t S).restrictScalars ↥F).toSubfield := rfl
+  rw [h1, KFldT_restrictScalars F t S htS, IntermediateField.adjoin_toSubfield,
+    range_algebraMap_subfield]
+
+variable (F t) in
+theorem transcendental_KFldT_of_closure (htS : t ∈ S)
+    (htc : Transcendental ↥(Subfield.closure (⇑(algebraMap ℂ K) '' (F : Set ℂ) ∪ S))
+      (algebraMap ℂ K c)) :
+    Transcendental ↥(KFldT F t S) (algebraMap ℂ K c) := by
+  rw [Transcendental] at htc ⊢
+  intro ⟨P, hP0, hPe⟩
+  set e := (RingEquiv.subfieldCongr (KFldT_toSubfield_eq F t S htS)).toRingHom
+  refine htc ⟨P.map e, fun h => hP0 (Polynomial.map_eq_zero_iff (RingEquiv.injective _) |>.mp h),
+    ?_⟩
+  have hcomp : (algebraMap ↥(Subfield.closure (⇑(algebraMap ℂ K) '' (F : Set ℂ) ∪ S)) K).comp e =
+      algebraMap ↥(KFldT F t S) K := by
+    ext z; rfl
+  rw [Polynomial.aeval_def, Polynomial.eval₂_map, hcomp]
+  exact hPe
+
+end WLightR8a
+
+theorem solution {K : Type*} [Field K] [Algebra ℂ K]
+    (F : IntermediateField ℚ ℂ) (t : K) (ht : Transcendental ℂ t)
+    (S : Set K) (htS : t ∈ S) (hSfin : S.Finite)
+    (hSint : ∀ s ∈ S, IsIntegral
+      ↥(Subring.closure (⇑(algebraMap ℂ K) '' (F : Set ℂ) ∪ {t})) s)
+    (c : ℂ) (hc : Transcendental ↥F c)
+    (htc : Transcendental ↥(Subfield.closure (⇑(algebraMap ℂ K) '' (F : Set ℂ) ∪ S))
+      (algebraMap ℂ K c))
+    (y : K)
+    (hyS : y ∈ Subfield.closure
+      (⇑(algebraMap ℂ K) '' (IntermediateField.adjoin ↥F {c} : Set ℂ) ∪ S))
+    (hyB : IsIntegral ↥(Subring.closure
+      (⇑(algebraMap ℂ K) '' (IntermediateField.adjoin ↥F {c} : Set ℂ) ∪ {t})) y) :
+    y ∈ Submodule.span ℂ {z : K | z ∈ Subfield.closure (⇑(algebraMap ℂ K) '' (F : Set ℂ) ∪ S) ∧
+      IsIntegral ↥(Subring.closure (⇑(algebraMap ℂ K) '' (F : Set ℂ) ∪ {t})) z} := by
+  have hSint' : ∀ s ∈ S, IsIntegral ↥(WLightR8a.TRng F t) s := fun s hs =>
+    (WLightR8a.isIntegral_TRng_iff_closure F t s).mpr (hSint s hs)
+  have hyB' : IsIntegral
+      ↥(Algebra.adjoin ↥(IntermediateField.adjoin ↥F {c}) ({t} : Set K)) y :=
+    (WLightR8a.isIntegral_adjoin_iff_closure' F _ y).mpr hyB
+  have htc' := WLightR8a.transcendental_KFldT_of_closure F t S htS htc
+  have h := WLightR8a.mem_span_RSet_of_adjoin_simple_transcendental
+    S ht htS hSfin hSint' hc htc' hyS hyB'
+  refine Submodule.span_mono (fun z hz => ?_) h
+  exact ⟨(WLightR8a.mem_KFld_iff_closure F S z).mp hz.1,
+    (WLightR8a.isIntegral_TRng_iff_closure F t z).mp hz.2⟩
+
+end
+end S_IsIntegral_mem_span_of_adjoin_simple_constants_transcendental
+end P2MW
+export P2MW.S_IsIntegral_mem_span_of_adjoin_simple_constants_transcendental (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem IsIntegral.mem_span_of_adjoin_simple_constants_transcendental {K : Type*}
+    [Field K] [Algebra ℂ K]
+    (F : IntermediateField ℚ ℂ) (t : K) (ht : Transcendental ℂ t)
+    (S : Set K) (htS : t ∈ S) (hSfin : S.Finite)
+    (hSint : ∀ s ∈ S, IsIntegral
+      ↥(Subring.closure (⇑(algebraMap ℂ K) '' (F : Set ℂ) ∪ {t})) s)
+    (c : ℂ) (hc : Transcendental ↥F c)
+    (htc : Transcendental ↥(Subfield.closure (⇑(algebraMap ℂ K) '' (F : Set ℂ) ∪ S))
+      (algebraMap ℂ K c))
+    (y : K)
+    (hyS : y ∈ Subfield.closure
+      (⇑(algebraMap ℂ K) '' (IntermediateField.adjoin ↥F {c} : Set ℂ) ∪ S))
+    (hyB : IsIntegral ↥(Subring.closure
+      (⇑(algebraMap ℂ K) '' (IntermediateField.adjoin ↥F {c} : Set ℂ) ∪ {t})) y) :
+    y ∈ Submodule.span ℂ {z : K | z ∈ Subfield.closure (⇑(algebraMap ℂ K) '' (F : Set ℂ) ∪ S) ∧
+      IsIntegral ↥(Subring.closure (⇑(algebraMap ℂ K) '' (F : Set ℂ) ∪ {t})) z} :=
+  solution F t ht S htS hSfin hSint c hc htc y hyS hyB
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_KaehlerDifferential_D_ne_zero_of_transcendental.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_KaehlerDifferential_D_ne_zero_of_transcendental.lean
new file mode 100644
index 0000000000..7e638f4640
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_KaehlerDifferential_D_ne_zero_of_transcendental.lean
@@ -0,0 +1,145 @@
+/-
+Based on Prove2Me node KaehlerDifferential.D_ne_zero_of_transcendental
+(0df85775-aaa5-5911-8954-96e03b12839a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 95ed7aea-228a-552c-bed7-c51720bd6f7e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.Kaehler.Basic
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+public import Mathlib.FieldTheory.Separable
+public import Mathlib.RingTheory.Algebraic.Defs
+
+import Mathlib.RingTheory.Etale.Kaehler
+import Mathlib.RingTheory.Etale.Field
+import Mathlib.RingTheory.Kaehler.Polynomial
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import Mathlib.LinearAlgebra.TensorProduct.Basis
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Nonvanishing of dx for a separating transcendental element
+
+Theorem statement: `KaehlerDifferential.D_ne_zero_of_transcendental`
+(`0df85775-aaa5-5911-8954-96e03b12839a`), by Claude, 2026-09-05.
+
+Proof: submission `95ed7aea-228a-552c-bed7-c51720bd6f7e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, $F$ a field, and let $F$ be a $K$-algebra. Let $x \in F$ be transcendental over
+$K$, i.e. `Transcendental K x`: $x$ is not a root of any nonzero polynomial over $K$. Assume further
+that $F$ is a separable algebra over the intermediate field $K(x) =$ `IntermediateField.adjoin K
+{x}` generated by $x$, that is, every element of $F$ is algebraic with separable minimal polynomial
+over $K(x)$. The conclusion is that the universal derivation applied to $x$, namely
+`KaehlerDifferential.D K F x` $= dx$, is nonzero in the module of Kähler differentials
+$\Omega_{F/K}$ of $F$ over $K$. This is the nonvanishing half only: the statement asserts $dx \neq
+0$, not that $dx$ is an $F$-basis of $\Omega_{F/K}$, although the proof establishes the stronger
+fact along the way.
+
+This is the classical nonvanishing of the differential of a separating element of a function field,
+underlying the fact that $\Omega_{F/K}$ is one-dimensional over $F$ with basis $dx$. It is used
+throughout the treatment of differentials on curves, for instance in defining and computing the
+order of a differential at a place and in the study of torsion in the degree-zero part of the Picard
+group.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_KaehlerDifferential_D_ne_zero_of_transcendental.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_KaehlerDifferential_D_ne_zero_of_transcendental
+
+noncomputable section
+p2m_open "Polynomial KaehlerDifferential \
+  P2MW.S_KaehlerDifferential_D_ne_zero_of_transcendental.KaehlerDifferential"
+
+namespace KaehlerDifferential
+p2m_export "KaehlerDifferential" "tensorKaehlerEquivOfFormallyEtale polynomialEquiv \
+  tensorKaehlerEquivOfFormallyEtale_apply mapBaseChange_tmul D map_D map"
+namespace FF2
+p2m_open "KaehlerDifferential"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] {x : F} (hx : Transcendental K x)
+  [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F]
+
+include hx in
+private theorem exists_basis : ∃ b : Module.Basis Unit F Ω[F⁄K], b () = D K F x := by
+  let e : RatFunc K ≃ₐ[K] IntermediateField.adjoin K ({x} : Set F) :=
+    RatFunc.algEquivOfTranscendental x hx
+  let algKx : Algebra K[X] (IntermediateField.adjoin K ({x} : Set F)) :=
+    (e.toAlgHom.toRingHom.comp (algebraMap K[X] (RatFunc K))).toAlgebra
+  let algF : Algebra K[X] F :=
+    ((algebraMap (IntermediateField.adjoin K ({x} : Set F)) F).comp (algebraMap K[X]
+      (IntermediateField.adjoin K ({x} : Set F)))).toAlgebra
+  have : IsScalarTower K[X] (IntermediateField.adjoin K ({x} : Set F)) F :=
+    IsScalarTower.of_algebraMap_eq (fun _ => rfl)
+  have : IsScalarTower K K[X] (IntermediateField.adjoin K ({x} : Set F)) :=
+    IsScalarTower.of_algebraMap_eq (fun c => by
+    change _ = (e.toAlgHom.toRingHom.comp (algebraMap K[X] (RatFunc K))) (C c)
+    simp only [RingHom.comp_apply, AlgHom.toRingHom_eq_coe, RingHom.coe_coe, AlgEquiv.coe_toAlgHom]
+    rw [← Polynomial.algebraMap_eq, ← IsScalarTower.algebraMap_apply K K[X] (RatFunc K),
+      AlgEquiv.commutes])
+  have : IsScalarTower K K[X] F := IsScalarTower.of_algebraMap_eq (fun c => by
+    rw [IsScalarTower.algebraMap_apply K (IntermediateField.adjoin K ({x} : Set F)) F,
+      IsScalarTower.algebraMap_apply K[X] (IntermediateField.adjoin K ({x} : Set F)) F,
+      ← IsScalarTower.algebraMap_apply K K[X] (IntermediateField.adjoin K ({x} : Set F))])
+  have : Algebra.FormallyEtale K[X] (RatFunc K) :=
+    Algebra.FormallyEtale.of_isLocalization (nonZeroDivisors K[X])
+  have : Algebra.FormallyEtale K[X] (IntermediateField.adjoin K ({x} : Set F)) :=
+    Algebra.FormallyEtale.of_equiv (R := K[X]) (A := RatFunc K) { e with commutes' := fun _ => rfl }
+  have : Algebra.FormallyEtale (IntermediateField.adjoin K ({x} : Set F)) F :=
+    Algebra.FormallyEtale.of_isSeparable (IntermediateField.adjoin K ({x} : Set F)) F
+  have : Algebra.FormallyEtale K[X] F :=
+    Algebra.FormallyEtale.comp K[X] (IntermediateField.adjoin K ({x} : Set F)) F
+  let b₀ : Module.Basis Unit K[X] Ω[K[X]⁄K] :=
+    (Module.Basis.singleton Unit K[X]).map (polynomialEquiv K).symm
+  have hb₀ : b₀ () = D K K[X] X := by simp [b₀]
+  let ψ := tensorKaehlerEquivOfFormallyEtale K K[X] F
+  refine ⟨(b₀.baseChange F).map ψ, ?_⟩
+  have hX : algebraMap K[X] F X = x := by
+    change algebraMap (IntermediateField.adjoin K ({x} : Set F)) F (e (algebraMap K[X] (RatFunc K)
+      X)) = x
+    rw [RatFunc.algebraMap_X]
+    exact RatFunc.algEquivOfTranscendental_X x hx
+  simp only [Module.Basis.map_apply, Module.Basis.baseChange_apply, hb₀, ψ,
+    tensorKaehlerEquivOfFormallyEtale_apply, mapBaseChange_tmul, one_smul, map_D, hX]
+
+end KaehlerDifferential.FF2
+
+theorem solution (K : Type*) [Field K] {F : Type*} [Field F] [Algebra K F] (x : F)
+    (hx : Transcendental K x)
+    [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F] :
+    KaehlerDifferential.D K F x ≠ 0 := by
+  obtain ⟨b, hb⟩ := KaehlerDifferential.FF2.exists_basis hx
+  simpa [hb] using b.ne_zero ()
+
+end
+
+end S_KaehlerDifferential_D_ne_zero_of_transcendental
+end P2MW
+export P2MW.S_KaehlerDifferential_D_ne_zero_of_transcendental (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem KaehlerDifferential.D_ne_zero_of_transcendental (K : Type*) [Field K] {F : Type*} [Field F]
+    [Algebra K F] (x : F) (hx : Transcendental K x)
+    [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F] :
+    KaehlerDifferential.D K F x ≠ 0 :=
+  solution K x hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_KaehlerDifferential_span_D_eq_top_of_transcendental.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_KaehlerDifferential_span_D_eq_top_of_transcendental.lean
new file mode 100644
index 0000000000..ca9eef0656
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_KaehlerDifferential_span_D_eq_top_of_transcendental.lean
@@ -0,0 +1,145 @@
+/-
+Based on Prove2Me node KaehlerDifferential.span_D_eq_top_of_transcendental
+(cff114e0-913d-5ab8-a133-347de5198cee) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 76fe99e6-1761-5fa8-80c6-b680ac94900b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.Kaehler.Basic
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+public import Mathlib.FieldTheory.Separable
+public import Mathlib.RingTheory.Algebraic.Defs
+
+import Mathlib.RingTheory.Etale.Kaehler
+import Mathlib.RingTheory.Etale.Field
+import Mathlib.RingTheory.Kaehler.Polynomial
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import Mathlib.LinearAlgebra.TensorProduct.Basis
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Ω_{F/K} is spanned by dx for separating x
+
+Theorem statement: `KaehlerDifferential.span_D_eq_top_of_transcendental`
+(`cff114e0-913d-5ab8-a133-347de5198cee`), by Claude, 2026-09-05.
+
+Proof: submission `76fe99e6-1761-5fa8-80c6-b680ac94900b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, $F$ a field equipped with a $K$-algebra structure, and $x \in F$ an element
+transcendental over $K$, i.e. the evaluation map $K[X] \to F$ at $x$ is injective. Assume further
+that $F$ is separable as an algebra over the intermediate field $K(x) =$ `IntermediateField.adjoin K
+{x}` generated by $x$. Then the $F$-submodule of the module of Kähler differentials $\Omega_{F/K}$
+spanned by the single element $D_{K,F}(x) = dx$ is all of $\Omega_{F/K}$; equivalently, every
+differential of $F$ over $K$ is of the form $g\,dx$ with $g \in F$. The assertion is only the
+spanning statement: nothing is claimed here about $dx$ being nonzero, so linear independence, and
+hence one-dimensionality of $\Omega_{F/K}$, is not part of the conclusion.
+
+This is the classical description of the differentials of a separably generated function field of
+one variable: $\Omega_{F/K}$ is generated by the differential of a separating element. Together with
+the companion statement that $dx \neq 0$ for such an $x$, it underlies the treatment of
+differentials at a place of an algebraic curve, where it is used to define and compute differential
+coefficients.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_KaehlerDifferential_span_D_eq_top_of_transcendental.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_KaehlerDifferential_span_D_eq_top_of_transcendental
+
+noncomputable section
+p2m_open "Polynomial KaehlerDifferential \
+  P2MW.S_KaehlerDifferential_span_D_eq_top_of_transcendental.KaehlerDifferential"
+
+namespace KaehlerDifferential
+p2m_export "KaehlerDifferential" "tensorKaehlerEquivOfFormallyEtale polynomialEquiv \
+  tensorKaehlerEquivOfFormallyEtale_apply mapBaseChange_tmul D map_D map"
+namespace FF2
+p2m_open "KaehlerDifferential"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] {x : F} (hx : Transcendental K x)
+  [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F]
+
+include hx in
+private theorem exists_basis : ∃ b : Module.Basis Unit F Ω[F⁄K], b () = D K F x := by
+  let e : RatFunc K ≃ₐ[K] IntermediateField.adjoin K ({x} : Set F) :=
+    RatFunc.algEquivOfTranscendental x hx
+  let algKx : Algebra K[X] (IntermediateField.adjoin K ({x} : Set F)) :=
+    (e.toAlgHom.toRingHom.comp (algebraMap K[X] (RatFunc K))).toAlgebra
+  let algF : Algebra K[X] F :=
+    ((algebraMap (IntermediateField.adjoin K ({x} : Set F)) F).comp (algebraMap K[X]
+      (IntermediateField.adjoin K ({x} : Set F)))).toAlgebra
+  have : IsScalarTower K[X] (IntermediateField.adjoin K ({x} : Set F)) F :=
+    IsScalarTower.of_algebraMap_eq (fun _ => rfl)
+  have : IsScalarTower K K[X] (IntermediateField.adjoin K ({x} : Set F)) :=
+    IsScalarTower.of_algebraMap_eq (fun c => by
+    change _ = (e.toAlgHom.toRingHom.comp (algebraMap K[X] (RatFunc K))) (C c)
+    simp only [RingHom.comp_apply, AlgHom.toRingHom_eq_coe, RingHom.coe_coe, AlgEquiv.coe_toAlgHom]
+    rw [← Polynomial.algebraMap_eq, ← IsScalarTower.algebraMap_apply K K[X] (RatFunc K),
+      AlgEquiv.commutes])
+  have : IsScalarTower K K[X] F := IsScalarTower.of_algebraMap_eq (fun c => by
+    rw [IsScalarTower.algebraMap_apply K (IntermediateField.adjoin K ({x} : Set F)) F,
+      IsScalarTower.algebraMap_apply K[X] (IntermediateField.adjoin K ({x} : Set F)) F,
+      ← IsScalarTower.algebraMap_apply K K[X] (IntermediateField.adjoin K ({x} : Set F))])
+  have : Algebra.FormallyEtale K[X] (RatFunc K) :=
+    Algebra.FormallyEtale.of_isLocalization (nonZeroDivisors K[X])
+  have : Algebra.FormallyEtale K[X] (IntermediateField.adjoin K ({x} : Set F)) :=
+    Algebra.FormallyEtale.of_equiv (R := K[X]) (A := RatFunc K) { e with commutes' := fun _ => rfl }
+  have : Algebra.FormallyEtale (IntermediateField.adjoin K ({x} : Set F)) F :=
+    Algebra.FormallyEtale.of_isSeparable (IntermediateField.adjoin K ({x} : Set F)) F
+  have : Algebra.FormallyEtale K[X] F :=
+    Algebra.FormallyEtale.comp K[X] (IntermediateField.adjoin K ({x} : Set F)) F
+  let b₀ : Module.Basis Unit K[X] Ω[K[X]⁄K] :=
+    (Module.Basis.singleton Unit K[X]).map (polynomialEquiv K).symm
+  have hb₀ : b₀ () = D K K[X] X := by simp [b₀]
+  let ψ := tensorKaehlerEquivOfFormallyEtale K K[X] F
+  refine ⟨(b₀.baseChange F).map ψ, ?_⟩
+  have hX : algebraMap K[X] F X = x := by
+    change algebraMap (IntermediateField.adjoin K ({x} : Set F)) F (e (algebraMap K[X] (RatFunc K)
+      X)) = x
+    rw [RatFunc.algebraMap_X]
+    exact RatFunc.algEquivOfTranscendental_X x hx
+  simp only [Module.Basis.map_apply, Module.Basis.baseChange_apply, hb₀, ψ,
+    tensorKaehlerEquivOfFormallyEtale_apply, mapBaseChange_tmul, one_smul, map_D, hX]
+
+end KaehlerDifferential.FF2
+
+theorem solution (K : Type*) [Field K] {F : Type*} [Field F] [Algebra K F] (x : F)
+    (hx : Transcendental K x)
+    [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F] :
+    Submodule.span F ({KaehlerDifferential.D K F x} : Set (KaehlerDifferential K F)) = ⊤ := by
+  obtain ⟨b, hb⟩ := KaehlerDifferential.FF2.exists_basis hx
+  have h := b.span_eq
+  rwa [show Set.range b = {KaehlerDifferential.D K F x} by ext ω; simp [Set.range_unique, hb]] at h
+
+end
+
+end S_KaehlerDifferential_span_D_eq_top_of_transcendental
+end P2MW
+export P2MW.S_KaehlerDifferential_span_D_eq_top_of_transcendental (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem KaehlerDifferential.span_D_eq_top_of_transcendental (K : Type*) [Field K] {F : Type*}
+    [Field F] [Algebra K F] (x : F) (hx : Transcendental K x)
+    [Algebra.IsSeparable (IntermediateField.adjoin K ({x} : Set F)) F] :
+    Submodule.span F ({KaehlerDifferential.D K F x} : Set (KaehlerDifferential K F)) = ⊤ :=
+  solution K x hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_LaurentSeries_exists_algHom_comp_map_eq_single.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_LaurentSeries_exists_algHom_comp_map_eq_single.lean
new file mode 100644
index 0000000000..a13d1fc837
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_LaurentSeries_exists_algHom_comp_map_eq_single.lean
@@ -0,0 +1,358 @@
+/-
+Based on Prove2Me node LaurentSeries.exists_algHom_comp_map_eq_single
+(70dd59d7-5fd8-5e59-812a-b1c053ef17ff) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8188f922-4c6d-5dea-a9e3-532b28b07740
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.LaurentSeries
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+
+import Mathlib.RingTheory.PowerSeries.Substitution
+import Mathlib.RingTheory.PowerSeries.Inverse
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.AdicCompletion.Completeness
+import Mathlib.Algebra.Polynomial.Derivative
+import Mathlib.Algebra.Polynomial.Monic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order-preserving renormalisation of an embedding into K((X))
+
+Theorem statement: `LaurentSeries.exists_algHom_comp_map_eq_single`
+(`70dd59d7-5fd8-5e59-812a-b1c053ef17ff`), by Claude, 2026-09-05.
+
+Proof: submission `8188f922-4c6d-5dea-a9e3-532b28b07740`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field that is algebraically closed and of characteristic zero, let $F$ be a field
+equipped with a $K$-algebra structure, and let $\varphi : F \to K((X))$ be a $K$-algebra
+homomorphism into the field of formal Laurent series over $K$ (Hahn series over $K$ with value group
+$\mathbb{Z}$). Let $f \in F$ be such that the order of $\varphi f$ is strictly positive; here
+`order` is the Hahn-series order, namely the least element of the support for a nonzero series and
+$0$ for the zero series, so the hypothesis in particular forces $\varphi f \neq 0$. The assertion is
+that there exists a further $K$-algebra homomorphism $\varphi' : F \to K((X))$ with two properties:
+for every $x \in F$ the order of $\varphi' x$ equals the order of $\varphi x$, and $\varphi' f$ is
+exactly the monomial `single (φ f).order 1`, that is, the Laurent series whose only nonzero
+coefficient is $1$, in degree equal to the order of $\varphi f$.
+
+This is the Newton–Puiseux normalisation of a Laurent series of positive order over an algebraically
+closed field of characteristic zero, packaged as the statement that an embedding of a field into
+$K((X))$ may be replaced by an order-equivalent one sending a prescribed element of positive order
+to an exact power of the variable. It is used in the count
+[`ModularCurve.natCard_normalized_algHom_jBar_eq_toNat_ord`]
+(thm.html#ModularCurve.natCard_normalized_algHom_jBar_eq_toNat_ord),
+where an embedding of a function field may be assumed to send the chosen parameter to a power of the
+uniformiser while all orders, and hence the place determined by the embedding, are unchanged.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_LaurentSeries_exists_algHom_comp_map_eq_single.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_LaurentSeries_exists_algHom_comp_map_eq_single
+
+noncomputable section
+
+open HahnSeries Polynomial
+
+namespace B2Tors
+
+open Polynomial
+
+theorem henselianLocalRing_of_henselianRing_maximalIdeal
+    {R : Type*} [CommRing R] [IsLocalRing R]
+    [HenselianRing R (IsLocalRing.maximalIdeal R)] : HenselianLocalRing R where
+  is_henselian f hf a₀ h₁ h₂ := HenselianRing.is_henselian f hf a₀ h₁ (h₂.map _)
+
+scoped instance instHenselianLocalRingPowerSeries {K : Type*} [Field K] :
+    HenselianLocalRing (PowerSeries K) := by
+  have : HenselianRing (PowerSeries K) (IsLocalRing.maximalIdeal (PowerSeries K)) := by
+    rw [PowerSeries.maximalIdeal_eq_span_X]
+    exact IsAdicComplete.henselianRing _ _
+  exact henselianLocalRing_of_henselianRing_maximalIdeal
+
+theorem surjective_constantCoeff {K : Type*} [Field K] :
+    Function.Surjective (PowerSeries.constantCoeff (R := K)) :=
+  fun a => ⟨PowerSeries.C a, PowerSeries.constantCoeff_C a⟩
+
+theorem exists_isRoot_and_constantCoeff_eq {K : Type*} [Field K]
+    {f : Polynomial (PowerSeries K)} (hf : f.Monic)
+    {a₀ : K} (hroot : (f.map PowerSeries.constantCoeff).IsRoot a₀)
+    (hderiv : (f.map PowerSeries.constantCoeff).derivative.eval a₀ ≠ 0) :
+    ∃ a : PowerSeries K, f.IsRoot a ∧ PowerSeries.constantCoeff a = a₀ := by
+  have tfae := HenselianLocalRing.TFAE (PowerSeries K)
+  have h3 := tfae.out 1 3
+  have H := h3.mp inferInstance PowerSeries.constantCoeff surjective_constantCoeff f hf a₀
+  rw [Polynomial.IsRoot, Polynomial.eval_map] at hroot
+  rw [Polynomial.derivative_map, Polynomial.eval_map] at hderiv
+  exact H hroot hderiv
+
+end B2Tors
+
+namespace B2P1
+
+section Reparam
+
+variable {K : Type*} [Field K]
+
+variable (σ : PowerSeries K) (h0 : PowerSeries.constantCoeff σ = 0)
+  (h1 : IsUnit (PowerSeries.coeff 1 σ))
+
+abbrev rho : PowerSeries K := σ.substInvOfIsUnit h1
+
+theorem hasSubst_rho : PowerSeries.HasSubst (rho σ h1) :=
+  PowerSeries.HasSubst.substInvOfIsUnit σ h1
+
+include h0 in
+theorem subst_sigma_subst_rho (p : PowerSeries K) :
+    PowerSeries.subst σ (PowerSeries.subst (rho σ h1) p) = p := by
+  rw [PowerSeries.subst_comp_subst_apply (hasSubst_rho σ h1)
+      (PowerSeries.HasSubst.of_constantCoeff_zero' h0),
+    PowerSeries.subst_substInvOfIsUnit_left σ h0 h1, PowerSeries.X_subst]
+
+include h0 in
+theorem subst_rho_injective : Function.Injective fun p : PowerSeries K => p.subst (rho σ h1) :=
+  Function.LeftInverse.injective (g := fun q : PowerSeries K => q.subst σ)
+    (subst_sigma_subst_rho σ h0 h1)
+
+include h0 in
+theorem order_subst_rho (p : PowerSeries K) :
+    PowerSeries.order (PowerSeries.subst (rho σ h1) p) = PowerSeries.order p := by
+  refine le_antisymm ?_ (PowerSeries.le_order_subst_left'
+    (PowerSeries.constantCoeff_substInvOfIsUnit σ h1))
+  have h := PowerSeries.le_order_subst_left' (φ := PowerSeries.subst (rho σ h1) p) h0
+  rwa [subst_sigma_subst_rho σ h0 h1] at h
+
+include h0 in
+theorem constantCoeff_subst_rho_ne_zero {p : PowerSeries K} (hp : PowerSeries.constantCoeff p ≠ 0) :
+    PowerSeries.constantCoeff (PowerSeries.subst (rho σ h1) p) ≠ 0 := by
+  have hord : PowerSeries.order (PowerSeries.subst (rho σ h1) p) = (0 : ℕ) := by
+    rw [order_subst_rho σ h0 h1]
+    exact PowerSeries.order_eq_nat.mpr ⟨by simpa using hp, fun i hi => (Nat.not_lt_zero i hi).elim⟩
+  have h := (PowerSeries.order_eq_nat.mp hord).1
+  simpa using h
+
+def reparamInt : PowerSeries K →+* LaurentSeries K :=
+  (algebraMap (PowerSeries K) (LaurentSeries K)).comp
+    (PowerSeries.substAlgHom (hasSubst_rho σ h1)).toRingHom
+
+theorem reparamInt_apply (p : PowerSeries K) :
+    reparamInt σ h1 p = ((p.subst (rho σ h1) : PowerSeries K) : LaurentSeries K) := by
+  change algebraMap (PowerSeries K) (LaurentSeries K)
+      (PowerSeries.substAlgHom (hasSubst_rho σ h1) p) = _
+  rw [PowerSeries.coe_substAlgHom]
+  rfl
+
+include h0 in
+theorem reparamInt_injective : Function.Injective (reparamInt σ h1) := by
+  intro p q h
+  rw [reparamInt_apply, reparamInt_apply] at h
+  exact subst_rho_injective σ h0 h1 (HahnSeries.ofPowerSeries_injective h)
+
+def reparam : LaurentSeries K →+* LaurentSeries K :=
+  IsFractionRing.lift (reparamInt_injective σ h0 h1)
+
+theorem reparam_coe (p : PowerSeries K) :
+    reparam σ h0 h1 (p : LaurentSeries K) =
+      ((p.subst (rho σ h1) : PowerSeries K) : LaurentSeries K) := by
+  change IsFractionRing.lift (reparamInt_injective σ h0 h1)
+      (algebraMap (PowerSeries K) (LaurentSeries K) p) = _
+  rw [IsFractionRing.lift_algebraMap, reparamInt_apply]
+
+theorem reparam_C (a : K) : reparam σ h0 h1 (HahnSeries.C a) = HahnSeries.C a := by
+  rw [← PowerSeries.coe_C, reparam_coe, PowerSeries.subst_C]
+  rfl
+
+theorem reparam_coe_sigma : reparam σ h0 h1 (σ : LaurentSeries K) = single 1 1 := by
+  rw [reparam_coe, PowerSeries.subst_substInvOfIsUnit_right σ h0 h1, PowerSeries.coe_X]
+
+theorem reparam_single_one : reparam σ h0 h1 (single 1 1) = (rho σ h1 : LaurentSeries K) := by
+  rw [← PowerSeries.coe_X, reparam_coe, PowerSeries.subst_X (hasSubst_rho σ h1)]
+
+theorem order_coe_eq_zero {q : PowerSeries K} (hq : PowerSeries.constantCoeff q ≠ 0) :
+    (q : LaurentSeries K).order = 0 := by
+  have hq0 : (q : LaurentSeries K) ≠ 0 := by
+    intro h
+    apply hq
+    have : q = 0 := HahnSeries.ofPowerSeries_injective (h.trans (map_zero _).symm)
+    simp [this]
+  apply le_antisymm
+  · apply order_le_of_coeff_ne_zero
+    rw [show (0 : ℤ) = ((0 : ℕ) : ℤ) from rfl, LaurentSeries.coeff_coe_powerSeries]
+    simpa using hq
+  · by_contra hlt
+    rw [not_le] at hlt
+    have h := mt coeff_order_eq_zero.mp hq0
+    rw [PowerSeries.coeff_coe, ite_eq_left hlt] at h
+    exact h rfl
+
+theorem order_inv' {x : LaurentSeries K} (hx : x ≠ 0) : x⁻¹.order = -x.order := by
+  have h := order_mul (inv_ne_zero hx) hx
+  rw [inv_mul_cancel₀ hx, order_one] at h
+  omega
+
+theorem order_zpow' {x : LaurentSeries K} (hx : x ≠ 0) (m : ℤ) : (x ^ m).order = m * x.order := by
+  cases m with
+  | ofNat n => simp [order_pow]
+  | negSucc n =>
+    rw [zpow_negSucc, order_inv' (pow_ne_zero _ hx), order_pow, nsmul_eq_mul, Int.negSucc_eq]
+    push_cast
+    ring
+
+theorem order_coe_rho : ((rho σ h1 : PowerSeries K) : LaurentSeries K).order = 1 := by
+  set ρ₁ : PowerSeries K := PowerSeries.mk fun n => PowerSeries.coeff (n + 1) (rho σ h1) with hρ₁
+  have hdec : rho σ h1 = PowerSeries.X * ρ₁ := by
+    have h := PowerSeries.eq_X_mul_shift_add_const (rho σ h1)
+    rw [PowerSeries.constantCoeff_substInvOfIsUnit, map_zero, add_zero] at h
+    exact h
+  have hρ₁0 : PowerSeries.constantCoeff ρ₁ ≠ 0 := by
+    rw [← PowerSeries.coeff_zero_eq_constantCoeff_apply, hρ₁, PowerSeries.coeff_mk, zero_add,
+      PowerSeries.coeff_one_substInvOfIsUnit]
+    exact Units.ne_zero _
+  have hρ₁0' : (ρ₁ : LaurentSeries K) ≠ 0 := by
+    intro h
+    apply hρ₁0
+    have : ρ₁ = 0 := HahnSeries.ofPowerSeries_injective (h.trans (map_zero _).symm)
+    simp [this]
+  rw [hdec, PowerSeries.coe_mul, PowerSeries.coe_X,
+    order_mul (single_ne_zero one_ne_zero) hρ₁0', order_single one_ne_zero,
+    order_coe_eq_zero hρ₁0, add_zero]
+
+theorem order_reparam (y : LaurentSeries K) : (reparam σ h0 h1 y).order = y.order := by
+  rcases eq_or_ne y 0 with rfl | hy
+  · simp
+  set p := y.powerSeriesPart with hp
+  have hp0 : PowerSeries.constantCoeff p ≠ 0 := by
+    rw [← PowerSeries.coeff_zero_eq_constantCoeff_apply, hp, LaurentSeries.powerSeriesPart_coeff,
+      Nat.cast_zero, add_zero]
+    exact mt coeff_order_eq_zero.mp hy
+  have hy' : y = single (1 : ℤ) (1 : K) ^ y.order * (p : LaurentSeries K) := by
+    rw [← RatFunc.single_zpow, hp]
+    exact (LaurentSeries.single_order_mul_powerSeriesPart y).symm
+  have hρ0 : ((rho σ h1 : PowerSeries K) : LaurentSeries K) ≠ 0 := by
+    intro h
+    have := order_coe_rho σ h1
+    rw [h, order_zero] at this
+    exact zero_ne_one this
+  have hq0 : ((p.subst (rho σ h1) : PowerSeries K) : LaurentSeries K) ≠ 0 := by
+    intro h
+    apply constantCoeff_subst_rho_ne_zero σ h0 h1 hp0
+    have : p.subst (rho σ h1) = 0 := HahnSeries.ofPowerSeries_injective (h.trans (map_zero _).symm)
+    simp [this]
+  conv_lhs => rw [hy']
+  rw [map_mul, map_zpow₀, reparam_single_one, reparam_coe,
+    order_mul (zpow_ne_zero _ hρ0) hq0, order_zpow' hρ0, order_coe_rho,
+    order_coe_eq_zero (constantCoeff_subst_rho_ne_zero σ h0 h1 hp0)]
+  ring
+
+end Reparam
+
+private theorem _root_.LaurentSeries.exists_algHom_order_eq_map_eq_single' {K : Type*} [Field K]
+    [IsAlgClosed K] [CharZero K]
+    (y : LaurentSeries K) (hy : 0 < y.order) :
+    ∃ ρ : LaurentSeries K →ₐ[K] LaurentSeries K,
+      (∀ z : LaurentSeries K, (ρ z).order = z.order) ∧ ρ y = single y.order 1 := by
+  set n : ℕ := y.order.toNat with hn
+  have hn0 : 0 < n := by omega
+  have hyord : y.order = (n : ℤ) := by omega
+  have hy0 : y ≠ 0 := by
+    intro h
+    rw [h, order_zero] at hyord
+    have : (n : ℤ) = 0 := hyord.symm
+    omega
+  set a := y.powerSeriesPart with ha
+  have hya : single (n : ℤ) (1 : K) * (a : LaurentSeries K) = y := by
+    rw [← hyord, ha, LaurentSeries.single_order_mul_powerSeriesPart]
+  set a₀ := PowerSeries.constantCoeff a with ha₀
+  have ha₀0 : a₀ ≠ 0 := by
+    rw [ha₀, ← PowerSeries.coeff_zero_eq_constantCoeff_apply, ha,
+      LaurentSeries.powerSeriesPart_coeff,
+      Nat.cast_zero, add_zero]
+    exact mt coeff_order_eq_zero.mp hy0
+  obtain ⟨b₀, hb₀⟩ := IsAlgClosed.exists_pow_nat_eq a₀ hn0
+  have hb₀0 : b₀ ≠ 0 := by
+    rintro rfl
+    rw [zero_pow hn0.ne'] at hb₀
+    exact ha₀0 hb₀.symm
+  set P : Polynomial (PowerSeries K) := X ^ n - Polynomial.C a with hP
+  have hPmonic : P.Monic := monic_X_pow_sub_C a hn0.ne'
+  have hPmap : P.map PowerSeries.constantCoeff = X ^ n - Polynomial.C a₀ := by
+    rw [hP, Polynomial.map_sub, Polynomial.map_pow, Polynomial.map_X, Polynomial.map_C]
+  have hroot : (P.map PowerSeries.constantCoeff).IsRoot b₀ := by
+    rw [hPmap, IsRoot.def, eval_sub, eval_pow, eval_X, eval_C, hb₀, sub_self]
+  have hderiv : (P.map PowerSeries.constantCoeff).derivative.eval b₀ ≠ 0 := by
+    rw [hPmap, derivative_sub, derivative_X_pow, derivative_C, sub_zero, eval_mul, eval_C, eval_pow,
+      eval_X]
+    exact mul_ne_zero (Nat.cast_ne_zero.mpr hn0.ne') (pow_ne_zero _ hb₀0)
+  obtain ⟨b, hbroot, hb0⟩ := B2Tors.exists_isRoot_and_constantCoeff_eq hPmonic hroot hderiv
+  have hbn : b ^ n = a := by
+    have h := hbroot
+    rw [IsRoot.def, hP, eval_sub, eval_pow, eval_X, eval_C, sub_eq_zero] at h
+    exact h
+  set σ : PowerSeries K := PowerSeries.X * b with hσ
+  have hσ0 : PowerSeries.constantCoeff σ = 0 := by simp [hσ]
+  have hσ1 : IsUnit (PowerSeries.coeff 1 σ) := by
+    rw [hσ, show (1 : ℕ) = 0 + 1 from rfl, PowerSeries.coeff_succ_X_mul,
+      PowerSeries.coeff_zero_eq_constantCoeff_apply, hb0]
+    exact isUnit_iff_ne_zero.mpr hb₀0
+  have hyσ : y = ((σ ^ n : PowerSeries K) : LaurentSeries K) := by
+    rw [← hya, hσ, mul_pow, hbn, PowerSeries.coe_mul, PowerSeries.coe_pow, PowerSeries.coe_X,
+      single_pow]
+    simp
+  refine ⟨{ (reparam σ hσ0 hσ1) with commutes' := fun k => ?_ }, fun z => ?_, ?_⟩
+  · change reparam σ hσ0 hσ1 (algebraMap K (LaurentSeries K) k) = algebraMap K (LaurentSeries K) k
+    rw [LaurentSeries.algebraMap_apply, reparam_C]
+  · change (reparam σ hσ0 hσ1 z).order = z.order
+    exact order_reparam σ hσ0 hσ1 z
+  · change reparam σ hσ0 hσ1 y = single y.order 1
+    rw [hyord, hyσ, PowerSeries.coe_pow, map_pow, reparam_coe_sigma, single_pow]
+    simp
+
+
+private theorem _root_.LaurentSeries.exists_algHom_comp_map_eq_single' {K F : Type*} [Field K]
+    [IsAlgClosed K] [CharZero K]
+    [Field F] [Algebra K F] (φ : F →ₐ[K] LaurentSeries K) (f : F) (hf : 0 < (φ f).order) :
+    ∃ φ' : F →ₐ[K] LaurentSeries K,
+      (∀ x : F, (φ' x).order = (φ x).order) ∧ φ' f = single (φ f).order 1 := by
+  obtain ⟨ρ, hρ, hρy⟩ := LaurentSeries.exists_algHom_order_eq_map_eq_single' (φ f) hf
+  exact ⟨ρ.comp φ, fun x => hρ (φ x), hρy⟩
+
+end B2P1
+end
+
+open HahnSeries in
+theorem solution {K F : Type*} [Field K] [IsAlgClosed K] [CharZero K]
+    [Field F] [Algebra K F] (φ : F →ₐ[K] LaurentSeries K) (f : F) (hf : 0 < (φ f).order) :
+    ∃ φ' : F →ₐ[K] LaurentSeries K,
+      (∀ x : F, (φ' x).order = (φ x).order) ∧ φ' f = single (φ f).order 1 :=
+  LaurentSeries.exists_algHom_comp_map_eq_single' φ f hf
+
+end S_LaurentSeries_exists_algHom_comp_map_eq_single
+end P2MW
+export P2MW.S_LaurentSeries_exists_algHom_comp_map_eq_single (solution)
+
+end privateSection
+
+public section publicSection
+
+open HahnSeries
+theorem LaurentSeries.exists_algHom_comp_map_eq_single {K F : Type*} [Field K] [IsAlgClosed K]
+    [CharZero K]
+    [Field F] [Algebra K F] (φ : F →ₐ[K] LaurentSeries K) (f : F) (hf : 0 < (φ f).order) :
+    ∃ φ' : F →ₐ[K] LaurentSeries K,
+      (∀ x : F, (φ' x).order = (φ x).order) ∧ φ' f = single (φ f).order 1 :=
+  solution φ f hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_LinearMap_charpoly_eq_iff_of_finrank_eq_two.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_LinearMap_charpoly_eq_iff_of_finrank_eq_two.lean
new file mode 100644
index 0000000000..2cf079bb91
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_LinearMap_charpoly_eq_iff_of_finrank_eq_two.lean
@@ -0,0 +1,95 @@
+/-
+Based on Prove2Me node LinearMap.charpoly_eq_iff_of_finrank_eq_two
+(e04ad550-8399-5638-ab27-356c7b9b79da) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5f78c23a-064a-5d75-9f75-3be1d1b3f971
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.LinearAlgebra.Charpoly.Basic
+public import Mathlib.LinearAlgebra.Trace
+public import Mathlib.LinearAlgebra.Determinant
+
+import Mathlib.LinearAlgebra.Charpoly.ToMatrix
+import Mathlib.LinearAlgebra.Matrix.Charpoly.Coeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_LinearMap_charpoly_of_finrank_eq_two
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Characteristic polynomial of a rank-two endomorphism: coefficient criterion
+
+Theorem statement: `LinearMap.charpoly_eq_iff_of_finrank_eq_two`
+(`e04ad550-8399-5638-ab27-356c7b9b79da`), by Claude, 2026-09-05.
+
+Proof: submission `5f78c23a-064a-5d75-9f75-3be1d1b3f971`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a nontrivial commutative ring and $M$ an $R$-module that is free and finite over $R$,
+with $\operatorname{finrank}_R M = 2$. Let $f \colon M \to M$ be an $R$-linear endomorphism and let
+$a, b \in R$. The assertion is an equivalence: the characteristic polynomial `f.charpoly` equals
+$X^2 - C(a)\,X + C(b)$ in $R[X]$ (the constants $a$ and $b$ being embedded via the
+constant-polynomial map) if and only if both $\operatorname{tr}_{R,M}(f) = a$ and $\det(f) = b$,
+where the trace and determinant are the Mathlib trace and determinant of a linear endomorphism of a
+finite free module. Thus, in rank two, prescribing the characteristic polynomial in the normalised
+shape $X^2 - aX + b$ is the same as prescribing the trace and the determinant of $f$.
+
+This is the rank-two Cayley–Hamilton normalisation in the form of a two-way criterion: it converts a
+condition on the characteristic polynomial of a two-dimensional representation into the pair of
+conditions on trace and determinant, and back. It is used in the identification of Frobenius
+characteristic polynomials on the Tate module of a Weierstrass curve, in the trace–determinant
+characterisation of when a residual Galois representation is attached to a form, and in the
+level-lowering step for newforms with a unipotent residual local behaviour.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_LinearMap_charpoly_eq_iff_of_finrank_eq_two.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_LinearMap_charpoly_eq_iff_of_finrank_eq_two
+
+open Polynomial
+
+theorem solution {R : Type*} {M : Type*} [CommRing R] [Nontrivial R] [AddCommGroup M] [Module R M]
+    [Module.Free R M] [Module.Finite R M] (h : Module.finrank R M = 2) (f : M →ₗ[R] M) (a b : R) :
+    f.charpoly = X ^ 2 - C a * X + C b ↔ LinearMap.trace R M f = a ∧ LinearMap.det f = b := by
+  rw [LinearMap.charpoly_of_finrank_eq_two h f]
+  constructor
+  · intro he
+    have h0 := congr_arg (fun q : R[X] ↦ q.coeff 0) he
+    have h1 := congr_arg (fun q : R[X] ↦ q.coeff 1) he
+    simp only [coeff_add, coeff_sub, coeff_X_pow, coeff_C_mul, coeff_X, coeff_C] at h0 h1
+    norm_num at h0 h1
+    exact ⟨h1, h0⟩
+  · rintro ⟨ht, hd⟩
+    rw [ht, hd]
+
+end S_LinearMap_charpoly_eq_iff_of_finrank_eq_two
+end P2MW
+export P2MW.S_LinearMap_charpoly_eq_iff_of_finrank_eq_two (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Polynomial
+
+theorem LinearMap.charpoly_eq_iff_of_finrank_eq_two {R : Type*} {M : Type*} [CommRing R]
+    [Nontrivial R] [AddCommGroup M] [Module R M] [Module.Free R M] [Module.Finite R M]
+    (h : Module.finrank R M = 2) (f : M →ₗ[R] M) (a b : R) :
+    f.charpoly = X ^ 2 - C a * X + C b ↔ LinearMap.trace R M f = a ∧ LinearMap.det f = b :=
+  solution h f a b
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_LinearMap_charpoly_of_finrank_eq_two.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_LinearMap_charpoly_of_finrank_eq_two.lean
new file mode 100644
index 0000000000..1b38391de4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_LinearMap_charpoly_of_finrank_eq_two.lean
@@ -0,0 +1,87 @@
+/-
+Based on Prove2Me node LinearMap.charpoly_of_finrank_eq_two
+(6eb39757-9e30-581c-8cd4-f83b507a59f8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2ac51848-0731-5d11-8691-246245a26146
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.LinearAlgebra.Charpoly.Basic
+public import Mathlib.LinearAlgebra.Trace
+public import Mathlib.LinearAlgebra.Determinant
+
+import Mathlib.LinearAlgebra.Charpoly.ToMatrix
+import Mathlib.LinearAlgebra.Matrix.Charpoly.Coeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Characteristic polynomial of a rank-two endomorphism
+
+Theorem statement: `LinearMap.charpoly_of_finrank_eq_two` (`6eb39757-9e30-581c-8cd4-f83b507a59f8`),
+by Claude, 2026-09-05.
+
+Proof: submission `2ac51848-0731-5d11-8691-246245a26146`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a nontrivial commutative ring and $M$ an $R$-module that is free and finite over $R$, and
+suppose its rank satisfies $\mathrm{finrank}_R M = 2$. Then for every $R$-linear endomorphism $f
+\colon M \to M$, the characteristic polynomial of $f$ (the `LinearMap.charpoly` of Mathlib, defined
+via the matrix of $f$ in a chosen basis) is given by $$f.\mathrm{charpoly} = X^2 -
+C(\mathrm{tr}_R(f))\,X + C(\det f),$$ an identity in the polynomial ring $R[X]$, where
+$\mathrm{tr}_R(f)$ denotes `LinearMap.trace R M f`, $\det f$ denotes `LinearMap.det f`, and $C$ is
+the inclusion of $R$ as constant polynomials. The hypothesis of nontriviality of $R$ enters through
+the availability of a basis indexed by `Fin 2` for a module of finrank $2$.
+
+This is the standard rank-two case of the formula expressing the characteristic polynomial through
+the coefficients trace and determinant. It serves as the dictionary between the two usual
+formulations of the data attached to a two-dimensional Galois representation — 'characteristic
+polynomial of Frobenius' versus 'trace and determinant of Frobenius' — and is used in that role in
+the statements about Galois representations attached to newforms and to Tate modules of elliptic
+curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_LinearMap_charpoly_of_finrank_eq_two.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_LinearMap_charpoly_of_finrank_eq_two
+
+open Polynomial
+
+theorem solution {R : Type*} {M : Type*} [CommRing R] [Nontrivial R] [AddCommGroup M] [Module R M]
+    [Module.Free R M] [Module.Finite R M] (h : Module.finrank R M = 2) (f : M →ₗ[R] M) :
+    f.charpoly = X ^ 2 - C (LinearMap.trace R M f) * X + C (LinearMap.det f) := by
+  let b := Module.finBasisOfFinrankEq R M h
+  rw [← f.charpoly_toMatrix b, Matrix.charpoly_fin_two, ← LinearMap.trace_eq_matrix_trace R b f,
+    LinearMap.det_toMatrix b f]
+
+end S_LinearMap_charpoly_of_finrank_eq_two
+end P2MW
+export P2MW.S_LinearMap_charpoly_of_finrank_eq_two (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Polynomial
+
+theorem LinearMap.charpoly_of_finrank_eq_two {R : Type*} {M : Type*} [CommRing R] [Nontrivial R]
+    [AddCommGroup M] [Module R M] [Module.Free R M] [Module.Finite R M] (h : Module.finrank R M = 2)
+    (f : M →ₗ[R] M) :
+    f.charpoly = X ^ 2 - C (LinearMap.trace R M f) * X + C (LinearMap.det f) :=
+  solution h f
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_LinearMap_trace_eq_of_sq_sub_smul_add_eq_zero_of_det_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_LinearMap_trace_eq_of_sq_sub_smul_add_eq_zero_of_det_eq.lean
new file mode 100644
index 0000000000..b3b946f3a0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_LinearMap_trace_eq_of_sq_sub_smul_add_eq_zero_of_det_eq.lean
@@ -0,0 +1,112 @@
+/-
+Based on Prove2Me node LinearMap.trace_eq_of_sq_sub_smul_add_eq_zero_of_det_eq
+(30b6f732-8aca-5287-9250-d1b13f6da6ea) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1202994b-8873-5a42-96ef-62c5c2477b9f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.LinearAlgebra.Charpoly.Basic
+public import Mathlib.LinearAlgebra.Trace
+public import Mathlib.LinearAlgebra.Determinant
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_LinearMap_charpoly_of_finrank_eq_two
+import Mathlib.Tactic.Module
+import Mathlib.Tactic.LinearCombination
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Trace from a quadratic relation and the determinant in rank two
+
+Theorem statement: `LinearMap.trace_eq_of_sq_sub_smul_add_eq_zero_of_det_eq`
+(`30b6f732-8aca-5287-9250-d1b13f6da6ea`), by Claude, 2026-09-05.
+
+Proof: submission `1202994b-8873-5a42-96ef-62c5c2477b9f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring that is a domain and let $M$ be an $R$-module that is free and
+finitely generated, with $\operatorname{finrank}_R M = 2$. Let $f$ be an $R$-linear endomorphism of
+$M$ and let $a, d \in R$ satisfy the relation $f \circ f - a \cdot f + d \cdot \mathrm{id}_M = 0$ in
+$\operatorname{End}_R(M)$ (multiplication being composition, and $a\cdot f$, $d\cdot\mathrm{id}_M$
+being scalar multiples). Assume moreover that $\det f = d$ and that $d \neq 0$. Then
+$\operatorname{tr}_R f = a$. Thus, for a rank-two endomorphism over a domain, a monic quadratic
+relation whose constant coefficient is the determinant and is nonzero forces its linear coefficient
+to be the trace; the hypothesis $d \neq 0$ cannot be dropped, since $f = 0$, $d = 0$ satisfies the
+relation for every $a$.
+
+This is the uniqueness half of the rank-two Cayley–Hamilton relation: it identifies the coefficient
+$a$ in a quadratic relation satisfied by $f$ with the trace of $f$. It is used to pass from the
+Hasse relation $\mathrm{Frob}_\ell^2 - a_\ell\,\mathrm{Frob}_\ell + \ell = 0$ on a Tate module,
+together with the determinant computation, to the characteristic polynomial and trace of Frobenius,
+in
+[`WeierstrassCurve.tateModuleRep_charpoly_frobenius`]
+(thm.html#WeierstrassCurve.tateModuleRep_charpoly_frobenius)
+and
+[`WeierstrassCurve.trace_frobenius_tateModule_eq_card_add_one_sub`]
+(thm.html#WeierstrassCurve.trace_frobenius_tateModule_eq_card_add_one_sub).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_LinearMap_trace_eq_of_sq_sub_smul_add_eq_zero_of_det_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_LinearMap_trace_eq_of_sq_sub_smul_add_eq_zero_of_det_eq
+
+open Polynomial
+
+theorem solution {R : Type*} {M : Type*} [CommRing R] [IsDomain R] [AddCommGroup M]
+    [Module R M] [Module.Free R M] [Module.Finite R M] (h : Module.finrank R M = 2)
+    (f : M →ₗ[R] M) (a d : R) (hf : f * f - a • f + d • (1 : M →ₗ[R] M) = 0)
+    (hdet : LinearMap.det f = d) (hd : d ≠ 0) :
+    LinearMap.trace R M f = a := by
+  have hM : Nontrivial M := by
+    have h2 : 0 < Module.finrank R M := by rw [h]; decide
+    exact (Module.finrank_pos_iff_of_free R M).mp h2
+  have hCH : f * f - (LinearMap.trace R M f) • f + d • (1 : M →ₗ[R] M) = 0 := by
+    have h1 := LinearMap.aeval_self_charpoly f
+    rw [LinearMap.charpoly_of_finrank_eq_two h f, hdet] at h1
+    simpa [pow_two, map_sub, map_add, map_mul, map_pow, aeval_X, aeval_C,
+      Module.algebraMap_end_eq_smul_id, smul_mul_assoc, ← Module.End.one_eq_id] using h1
+  have hf0 : f ≠ 0 := by
+    intro hf'
+    obtain ⟨v, hv⟩ := exists_ne (0 : M)
+    have hdv : d • v = 0 := by simpa [hf'] using LinearMap.congr_fun hf v
+    rcases smul_eq_zero.mp hdv with h' | h'
+    · exact hd h'
+    · exact hv h'
+  have hsub : (a - LinearMap.trace R M f) • f = 0 := by
+    linear_combination (norm := module) hCH - hf
+  rcases smul_eq_zero.mp hsub with h' | h'
+  · exact (sub_eq_zero.mp h').symm
+  · exact absurd h' hf0
+
+end S_LinearMap_trace_eq_of_sq_sub_smul_add_eq_zero_of_det_eq
+end P2MW
+export P2MW.S_LinearMap_trace_eq_of_sq_sub_smul_add_eq_zero_of_det_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem LinearMap.trace_eq_of_sq_sub_smul_add_eq_zero_of_det_eq
+    {R : Type*} {M : Type*} [CommRing R] [IsDomain R] [AddCommGroup M] [Module R M]
+    [Module.Free R M] [Module.Finite R M] (h : Module.finrank R M = 2)
+    (f : M →ₗ[R] M) (a d : R) (hf : f * f - a • f + d • (1 : M →ₗ[R] M) = 0)
+    (hdet : LinearMap.det f = d) (hd : d ≠ 0) :
+    LinearMap.trace R M f = a :=
+  solution h f a d hf hdet hd
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Matrix_SpecialLinearGroup_exists_addMonoidHom_conj_T_pow_minimalPeriod_eq_of_finsum_eq_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Matrix_SpecialLinearGroup_exists_addMonoidHom_conj_T_pow_minimalPeriod_eq_of_finsum_eq_zero.lean
new file mode 100644
index 0000000000..56de6e6d89
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Matrix_SpecialLinearGroup_exists_addMonoidHom_conj_T_pow_minimalPeriod_eq_of_finsum_eq_zero.lean
@@ -0,0 +1,290 @@
+/-
+Based on Prove2Me node
+Matrix.SpecialLinearGroup.exists_addMonoidHom_conj_T_pow_minimalPeriod_eq_of_finsum_eq_zero
+(8d457ddf-ccfe-5087-b1aa-22e610006cd1) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 948c23f4-0dbc-5cfd-9141-e1fcc3606f99
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.LinearAlgebra.Matrix.SpecialLinearGroup
+
+import Mathlib.Analysis.Normed.Ring.Lemmas
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularGroup_exists_mulEquiv_freeProduct_quotient_center
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Monoid_CoprodI_exists_addMonoidHom_conj_pow_minimalPeriod_eq_of_finsum_eq_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Sum-zero functions on cusps realised by homomorphisms of Γ
+
+Theorem statement:
+`Matrix.SpecialLinearGroup.exists_addMonoidHom_conj_T_pow_minimalPeriod_eq_of_finsum_eq_zero`
+(`8d457ddf-ccfe-5087-b1aa-22e610006cd1`), by Claude, 2026-09-05.
+
+Proof: submission `948c23f4-0dbc-5cfd-9141-e1fcc3606f99`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of finite index in $\mathrm{SL}_2(\mathbb Z)$ containing $-1$, and let
+$R$ be an additive commutative group. Write $T = \mathrm{ModularGroup.T}$ and let $\langle T\rangle$
+be the subgroup of integer powers of $T$, acting by left translation on the coset space
+$\mathrm{SL}_2(\mathbb Z)/\Gamma$; the quotient of this coset space by the orbit relation of
+$\langle T\rangle$ is the index set of the statement. Suppose given $a$ from that orbit set to $R$
+whose (finitely supported) sum $\sum^{\mathrm f}_c a(c)$ vanishes. The assertion is that there
+exists an additive group homomorphism $\varphi$ from $\Gamma$, viewed additively, to $R$ with the
+following property: for every $g \in \mathrm{SL}_2(\mathbb Z)$ and every proof that the element
+$g^{-1} T^{w} g$ lies in $\Gamma$, where $w$ is the minimal period of the map $x \mapsto T \cdot x$
+at the coset $g\Gamma$, the value of $\varphi$ at that element of $\Gamma$ equals $a$ evaluated at
+the $\langle T\rangle$-orbit of $g\Gamma$.
+
+In classical language the $\langle T\rangle$-orbits on $\mathrm{SL}_2(\mathbb Z)/\Gamma$ are the
+cusps of $\Gamma$, $w$ is the width of the cusp through $g\Gamma$ and $g^{-1}T^{w}g$ the
+corresponding parabolic generator; the statement says that evaluation $\mathrm{Hom}(\Gamma,R) \to
+R^{\{\text{cusps}\}}$ at the parabolic generators hits every vector of sum zero, so these generators
+satisfy no relation in $\Gamma^{\mathrm{ab}}$ beyond the boundary relation. It is obtained by
+transport along $\mathrm{SL}_2(\mathbb Z) \to \mathrm{PSL}_2(\mathbb Z) \cong C_2 * C_3$ from the
+corresponding statement for a free product, using
+[`ModularGroup.exists_mulEquiv_freeProduct_quotient_center`]
+(thm.html#ModularGroup.exists_mulEquiv_freeProduct_quotient_center)
+and
+[`Monoid.CoprodI.exists_addMonoidHom_conj_pow_minimalPeriod_eq_of_finsum_eq_zero`]
+(thm.html#Monoid.CoprodI.exists_addMonoidHom_conj_pow_minimalPeriod_eq_of_finsum_eq_zero),
+and is used in the lower bound for the rank of the parabolic homomorphisms in
+[`ModularCurve.Period.finrank_parabolicHoms_add_natCard_le_finrank_addMonoidHom_add_one`]
+(thm.html#ModularCurve.Period.finrank_parabolicHoms_add_natCard_le_finrank_addMonoidHom_add_one).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Matrix_SpecialLinearGroup_exists_addMonoidHom_conj_T_pow_minimalPeriod_eq_of_finsum_eq_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_0e0b1d23
+
+
+open Matrix MatrixGroups Subgroup MulAction
+
+noncomputable section
+
+namespace BassSerreCuspSL2
+
+abbrev G23 (i : Fin 2) : Type := Multiplicative (ZMod (i.val + 2))
+abbrev Gp : Type := Monoid.CoprodI G23
+abbrev PSL : Type := SL(2, ℤ) ⧸ Subgroup.center SL(2, ℤ)
+
+def τ : Gp := Monoid.CoprodI.of (M := G23) (i := 0) (Multiplicative.ofAdd 1) *
+  Monoid.CoprodI.of (M := G23) (i := 1) (Multiplicative.ofAdd 1)
+
+def e : Gp ≃* PSL := ModularGroup.exists_mulEquiv_freeProduct_quotient_center.choose
+
+theorem mem_center_iff_eq (A : SL(2, ℤ)) : A ∈ Subgroup.center SL(2, ℤ) ↔ A = 1 ∨ A = -1 := by
+  rw [Matrix.SpecialLinearGroup.mem_center_iff]
+  constructor
+  · rintro ⟨r, hr, hA⟩
+    have hr' : r * r = 1 := by rw [← pow_two]; simpa using hr
+    rcases mul_self_eq_one_iff.mp hr' with rfl | rfl
+    · left
+      apply Subtype.ext
+      rw [← hA, map_one]
+      rfl
+    · right
+      apply Subtype.ext
+      rw [← hA, map_neg, map_one]
+      rfl
+  · rintro (rfl | rfl)
+    · exact ⟨1, by simp, by simp⟩
+    · exact ⟨-1, by simp, by simp⟩
+
+theorem e_of_zero :
+    e (Monoid.CoprodI.of (i := 0) (Multiplicative.ofAdd 1)) = QuotientGroup.mk ModularGroup.S :=
+  ModularGroup.exists_mulEquiv_freeProduct_quotient_center.choose_spec.1
+
+theorem e_of_one : e (Monoid.CoprodI.of (i := 1) (Multiplicative.ofAdd 1))
+    = QuotientGroup.mk (ModularGroup.S * ModularGroup.T) :=
+  ModularGroup.exists_mulEquiv_freeProduct_quotient_center.choose_spec.2
+
+theorem e_τ : e τ = QuotientGroup.mk ModularGroup.T := by
+  have hSS : ModularGroup.S * ModularGroup.S = -1 := by decide
+  have h1 : (QuotientGroup.mk (-1 : SL(2, ℤ)) : PSL) = 1 :=
+    (QuotientGroup.eq_one_iff (-1 : SL(2, ℤ))).mpr ((mem_center_iff_eq _).mpr (Or.inr rfl))
+  rw [τ, map_mul, e_of_zero, e_of_one, ← QuotientGroup.mk_mul, ← mul_assoc, hSS,
+    QuotientGroup.mk_mul,
+    h1, one_mul]
+
+def π : SL(2, ℤ) →* Gp := e.symm.toMonoidHom.comp (QuotientGroup.mk' (Subgroup.center SL(2, ℤ)))
+
+theorem π_apply (g : SL(2, ℤ)) : π g = e.symm (QuotientGroup.mk g) := rfl
+
+theorem π_T : π ModularGroup.T = τ := by
+  rw [π_apply, ← e_τ, MulEquiv.symm_apply_apply]
+
+theorem π_surjective : Function.Surjective π :=
+  e.symm.surjective.comp (QuotientGroup.mk'_surjective _)
+
+theorem π_ker_le (Γ : Subgroup SL(2, ℤ)) (hneg : (-1 : SL(2, ℤ)) ∈ Γ) : π.ker ≤ Γ := by
+  intro z hz
+  rw [MonoidHom.mem_ker, π_apply, MulEquiv.map_eq_one_iff, QuotientGroup.eq_one_iff] at hz
+  rcases (mem_center_iff_eq z).mp hz with rfl | rfl
+  · exact one_mem Γ
+  · exact hneg
+
+section Main
+
+variable (Γ : Subgroup SL(2, ℤ))
+
+abbrev Hm : Subgroup Gp := Γ.map π
+
+theorem comap_Hm (hneg : (-1 : SL(2, ℤ)) ∈ Γ) :
+    (Hm Γ).comap π = Γ := Subgroup.comap_map_eq_self (π_ker_le Γ hneg)
+
+theorem mem_Γ_iff (hneg : (-1 : SL(2, ℤ)) ∈ Γ) (g : SL(2, ℤ)) : g ∈ Γ ↔ π g ∈ Hm Γ := by
+  conv_lhs => rw [← comap_Hm Γ hneg]
+  rfl
+
+theorem index_Hm (hneg : (-1 : SL(2, ℤ)) ∈ Γ) :
+    (Hm Γ).index = Γ.index := Subgroup.index_map_eq _ π_surjective (π_ker_le Γ hneg)
+
+def θ : SL(2, ℤ) ⧸ Γ → Gp ⧸ Hm Γ :=
+  Quotient.map' π fun a b h => by
+    rw [QuotientGroup.leftRel_apply] at h ⊢
+    rw [← map_inv, ← map_mul]
+    exact Subgroup.mem_map_of_mem π h
+
+@[scoped simp] theorem θ_mk (g : SL(2, ℤ)) :
+    θ Γ (g : SL(2, ℤ) ⧸ Γ) = ((π g : Gp) : Gp ⧸ Hm Γ) := rfl
+
+theorem θ_injective (hneg : (-1 : SL(2, ℤ)) ∈ Γ) : Function.Injective (θ Γ) := by
+  intro x y h
+  induction x using QuotientGroup.induction_on with | H a =>
+  induction y using QuotientGroup.induction_on with | H b =>
+  rw [θ_mk, θ_mk, QuotientGroup.eq, ← map_inv, ← map_mul, ← mem_Γ_iff Γ hneg] at h
+  exact QuotientGroup.eq.mpr h
+
+theorem θ_smul (g : SL(2, ℤ)) (x : SL(2, ℤ) ⧸ Γ) : θ Γ (g • x) = π g • θ Γ x := by
+  induction x using QuotientGroup.induction_on with | H a =>
+  change θ Γ ((g * a : SL(2, ℤ)) : SL(2, ℤ) ⧸ Γ) = ((π g * π a : Gp) : Gp ⧸ Hm Γ)
+  rw [θ_mk, map_mul]
+
+theorem θ_T_zpow_smul (n : ℤ) (x : SL(2, ℤ) ⧸ Γ) :
+    θ Γ (ModularGroup.T ^ n • x) = τ ^ n • θ Γ x := by
+  rw [θ_smul, map_zpow, π_T]
+
+theorem minimalPeriod_eq (hneg : (-1 : SL(2, ℤ)) ∈ Γ) (x : SL(2, ℤ) ⧸ Γ) :
+    Function.minimalPeriod (fun y => ModularGroup.T • y) x
+      = Function.minimalPeriod (fun y => τ • y) (θ Γ x) := by
+  apply Nat.dvd_antisymm
+  · rw [← MulAction.pow_smul_eq_iff_minimalPeriod_dvd]
+    apply θ_injective Γ hneg
+    rw [← zpow_natCast, θ_T_zpow_smul Γ, zpow_natCast]
+    exact (MulAction.pow_smul_eq_iff_minimalPeriod_dvd).mpr dvd_rfl
+  · rw [← MulAction.pow_smul_eq_iff_minimalPeriod_dvd, ← zpow_natCast, ← θ_T_zpow_smul Γ,
+      zpow_natCast]
+    congr 1
+    exact (MulAction.pow_smul_eq_iff_minimalPeriod_dvd).mpr dvd_rfl
+
+theorem mem_orbit_iff_θ (hneg : (-1 : SL(2, ℤ)) ∈ Γ) (x y : SL(2, ℤ) ⧸ Γ) :
+    x ∈ orbit (zpowers ModularGroup.T) y ↔ θ Γ x ∈ orbit (zpowers τ) (θ Γ y) := by
+  constructor
+  · rintro ⟨⟨_, n, rfl⟩, rfl⟩
+    exact ⟨⟨τ ^ n, n, rfl⟩, (θ_T_zpow_smul Γ n y).symm⟩
+  · rintro ⟨⟨_, n, rfl⟩, h⟩
+    refine ⟨⟨ModularGroup.T ^ n, n, rfl⟩, θ_injective Γ hneg ?_⟩
+    rw [← h]
+    exact θ_T_zpow_smul Γ n y
+
+def Θ (hneg : (-1 : SL(2, ℤ)) ∈ Γ) : orbitRel.Quotient (zpowers ModularGroup.T) (SL(2, ℤ) ⧸ Γ)
+    ≃ orbitRel.Quotient (zpowers τ) (Gp ⧸ Hm Γ) :=
+  Quotient.congr (Equiv.ofBijective (θ Γ)
+      ⟨θ_injective Γ hneg, fun y => by
+        induction y using QuotientGroup.induction_on with | H k =>
+        obtain ⟨g, rfl⟩ := π_surjective k
+        exact ⟨(g : SL(2, ℤ) ⧸ Γ), rfl⟩⟩)
+    (fun x y => mem_orbit_iff_θ Γ hneg x y)
+
+theorem Θ_mk (hneg : (-1 : SL(2, ℤ)) ∈ Γ) (x : SL(2, ℤ) ⧸ Γ) :
+    Θ Γ hneg (Quotient.mk (orbitRel (zpowers ModularGroup.T) _) x)
+      = Quotient.mk (orbitRel (zpowers τ) _) (θ Γ x) := rfl
+
+end Main
+
+end BassSerreCuspSL2
+
+open BassSerreCuspSL2 in
+theorem solution (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hneg : (-1 : Matrix.SpecialLinearGroup (Fin 2) ℤ) ∈ Γ) (R : Type) [AddCommGroup R]
+    (a : MulAction.orbitRel.Quotient (Subgroup.zpowers ModularGroup.T)
+          (Matrix.SpecialLinearGroup (Fin 2) ℤ ⧸ Γ) → R)
+    (ha : ∑ᶠ c, a c = 0) :
+    ∃ φ : Additive Γ →+ R,
+      ∀ (g : Matrix.SpecialLinearGroup (Fin 2) ℤ)
+        (hg : g⁻¹ * ModularGroup.T ^ Function.minimalPeriod (fun x => ModularGroup.T • x)
+                (g : Matrix.SpecialLinearGroup (Fin 2) ℤ ⧸ Γ) * g ∈ Γ),
+        φ (Additive.ofMul ⟨_, hg⟩)
+          = a (Quotient.mk (MulAction.orbitRel (Subgroup.zpowers ModularGroup.T) _)
+              (g : Matrix.SpecialLinearGroup (Fin 2) ℤ ⧸ Γ)) := by
+  have : (Hm Γ).FiniteIndex := ⟨by rw [index_Hm Γ hneg]; exact Subgroup.FiniteIndex.index_ne_zero⟩
+  set a' : MulAction.orbitRel.Quotient (Subgroup.zpowers τ) (Gp ⧸ Hm Γ) → R :=
+    fun c => a ((Θ Γ hneg).symm c) with ha'def
+  have ha' : ∑ᶠ c, a' c = 0 := by
+    rw [← ha]
+    exact finsum_eq_of_bijective (Θ Γ hneg).symm (Θ Γ hneg).symm.bijective fun c => rfl
+  obtain ⟨φH, hφH⟩ :=
+    Monoid.CoprodI.exists_addMonoidHom_conj_pow_minimalPeriod_eq_of_finsum_eq_zero τ rfl (Hm Γ) R a'
+      ha'
+  refine ⟨φH.comp (MonoidHom.toAdditive (π.subgroupMap Γ)), fun g hg => ?_⟩
+  have hk : (π g)⁻¹ * τ ^ Function.minimalPeriod (fun x => τ • x) ((π g : Gp) : Gp ⧸ Hm Γ) * π g
+      ∈ Hm Γ := by
+    rw [← θ_mk Γ, ← minimalPeriod_eq Γ hneg, ← π_T, ← map_pow, ← map_inv, ← map_mul,
+      ← map_mul, ← mem_Γ_iff Γ hneg]
+    exact hg
+  have key := hφH (π g) hk
+  rw [AddMonoidHom.comp_apply]
+  have hmap : (MonoidHom.toAdditive (π.subgroupMap Γ)) (Additive.ofMul ⟨_, hg⟩)
+      = Additive.ofMul ⟨_, hk⟩ := by
+    change Additive.ofMul (π.subgroupMap Γ ⟨_, hg⟩) = _
+    congr 1
+    apply Subtype.ext
+    change π (g⁻¹ * ModularGroup.T ^ _ * g) = _
+    rw [map_mul, map_mul, map_inv, map_pow, π_T, minimalPeriod_eq Γ hneg, θ_mk]
+  rw [hmap, key, ha'def]
+  change a ((Θ Γ hneg).symm (Θ Γ hneg (Quotient.mk _ (g : SL(2, ℤ) ⧸ Γ)))) = _
+  rw [Equiv.symm_apply_apply]
+
+end
+end S_OVERLONG_0e0b1d23
+end P2MW
+export
+  P2MW.S_OVERLONG_0e0b1d23
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem Matrix.SpecialLinearGroup.exists_addMonoidHom_conj_T_pow_minimalPeriod_eq_of_finsum_eq_zero
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hneg : (-1 : Matrix.SpecialLinearGroup (Fin 2) ℤ) ∈ Γ) (R : Type) [AddCommGroup R]
+    (a : MulAction.orbitRel.Quotient (Subgroup.zpowers ModularGroup.T)
+          (Matrix.SpecialLinearGroup (Fin 2) ℤ ⧸ Γ) → R)
+    (ha : ∑ᶠ c, a c = 0) :
+    ∃ φ : Additive Γ →+ R,
+      ∀ (g : Matrix.SpecialLinearGroup (Fin 2) ℤ)
+        (hg : g⁻¹ * ModularGroup.T ^ Function.minimalPeriod (fun x => ModularGroup.T • x)
+                (g : Matrix.SpecialLinearGroup (Fin 2) ℤ ⧸ Γ) * g ∈ Γ),
+        φ (Additive.ofMul ⟨_, hg⟩)
+          = a (Quotient.mk (MulAction.orbitRel (Subgroup.zpowers ModularGroup.T) _)
+              (g : Matrix.SpecialLinearGroup (Fin 2) ℤ ⧸ Γ)) :=
+  solution Γ hneg R a ha
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Matrix_SpecialLinearGroup_exists_eq_mul_diagonal_mul_of_gcd_eq_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Matrix_SpecialLinearGroup_exists_eq_mul_diagonal_mul_of_gcd_eq_one.lean
new file mode 100644
index 0000000000..9b48da5ef9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Matrix_SpecialLinearGroup_exists_eq_mul_diagonal_mul_of_gcd_eq_one.lean
@@ -0,0 +1,161 @@
+/-
+Based on Prove2Me node Matrix.SpecialLinearGroup.exists_eq_mul_diagonal_mul_of_gcd_eq_one
+(c8bce8b0-edd5-5602-b497-0ee5560f503b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6746b6bf-ecd5-5ff9-bc35-1d12e96aca37
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.LinearAlgebra.Matrix.SpecialLinearGroup
+
+import Mathlib.Algebra.BigOperators.Associated
+import Mathlib.Tactic.LinearCombination
+import Mathlib.Tactic.LinearCombination.Lemmas
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Primitive upper-triangular matrices of determinant N in one double coset
+
+Theorem statement: `Matrix.SpecialLinearGroup.exists_eq_mul_diagonal_mul_of_gcd_eq_one`
+(`c8bce8b0-edd5-5602-b497-0ee5560f503b`), by Claude, 2026-09-05.
+
+Proof: submission `6746b6bf-ecd5-5ff9-bc35-1d12e96aca37`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N,a,b,d$ be natural numbers such that $N \neq 0$, $a d = N$, and $\gcd(a,\gcd(b,d)) = 1$. Then
+there exist $\gamma_1,\gamma_2 \in \mathrm{SL}_2(\mathbb{Z})$, i.e. elements of
+`Matrix.SpecialLinearGroup (Fin 2) ℤ`, such that, after casting $a,b,d,N$ into $\mathbb{Z}$ and
+coercing $\gamma_1,\gamma_2$ to their underlying $2 \times 2$ integer matrices, the equality of
+matrices in `Matrix (Fin 2) (Fin 2) ℤ`
+$$\begin{pmatrix} a & b \\ 0 & d\end{pmatrix} \;=\; \gamma_1 \begin{pmatrix} N & 0 \\ 0 &
+1\end{pmatrix} \gamma_2$$
+holds. Thus a primitive upper-triangular integer matrix with non-negative entries and determinant $N
+> 0$ lies in the double coset $\mathrm{SL}_2(\mathbb{Z}) \, \mathrm{diag}(N,1) \,
+\mathrm{SL}_2(\mathbb{Z})$. Note that the usual normalisation $0 \le b < d$ of coset representatives
+is not assumed, only the coprimality condition; the entries are natural numbers rather than
+arbitrary integers; and the orientation of the factorisation is with $\mathrm{diag}(N,1)$ (not
+$\mathrm{diag}(1,N)$) in the middle.
+
+This is the $\mathrm{SL}_2$ refinement of the elementary-divisor (Smith) normal form in rank two:
+the elementary divisors of a primitive integer matrix of determinant $N$ are $1$ and $N$, and the
+reduction can be carried out on both sides inside $\mathrm{SL}_2(\mathbb{Z})$ rather than
+$\mathrm{GL}_2(\mathbb{Z})$. It is used in the study of the modular equation, where a level-one
+modular function is evaluated along the cosets $\mathrm{SL}_2(\mathbb{Z})\binom{a\;b}{0\;d}$ with
+$ad = N$; it is cited by
+[`ModularCurve.ModularPolynomialData.eval_E4_cube_div_discriminant_coset_eq_zero`]
+(thm.html#ModularCurve.ModularPolynomialData.eval_E4_cube_div_discriminant_coset_eq_zero).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Matrix_SpecialLinearGroup_exists_eq_mul_diagonal_mul_of_gcd_eq_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_Matrix_SpecialLinearGroup_exists_eq_mul_diagonal_mul_of_gcd_eq_one
+
+namespace Matrix
+p2m_export "Matrix" "ext diag SpecialLinearGroup det_fin_two_of of mul_fin_two"
+namespace SpecialLinearGroup
+p2m_export "Matrix.SpecialLinearGroup" "ext"
+namespace PrimitiveSmith
+p2m_open "Matrix.SpecialLinearGroup Matrix"
+
+theorem exists_coprime_mul_add {a b d : ℕ} (hd : d ≠ 0) (hgcd : Nat.gcd a (Nat.gcd b d) = 1) :
+    ∃ p : ℕ, Nat.Coprime (a * p + b) d := by
+  classical
+  refine ⟨∏ q ∈ d.primeFactors.filter (fun q => ¬ q ∣ b), q, ?_⟩
+  set P := ∏ q ∈ d.primeFactors.filter (fun q => ¬ q ∣ b), q with hP
+  apply Nat.Coprime.symm
+  apply Nat.coprime_of_dvd
+  intro q hq hqd hqab
+  have hqP : q ∣ P ↔ ¬ q ∣ b := by
+    rw [hP]
+    first
+      | rw [Prime.dvd_finsetProd_iff (Nat.prime_iff.mp hq)]
+    constructor
+    · rintro ⟨q', hq', hqq'⟩
+      rw [Finset.mem_filter, Nat.mem_primeFactors] at hq'
+      obtain ⟨⟨hq'p, -, -⟩, hq'b⟩ := hq'
+      rwa [(Nat.prime_dvd_prime_iff_eq hq hq'p).mp hqq']
+    · intro hqb
+      exact ⟨q, Finset.mem_filter.mpr ⟨Nat.mem_primeFactors.mpr ⟨hq, hqd, hd⟩, hqb⟩, dvd_rfl⟩
+  by_cases hqb : q ∣ b
+  · have hqa : ¬ q ∣ a := by
+      intro hqa
+      have : q ∣ Nat.gcd a (Nat.gcd b d) := Nat.dvd_gcd hqa (Nat.dvd_gcd hqb hqd)
+      rw [hgcd] at this
+      exact hq.one_lt.ne' (Nat.dvd_one.mp this)
+    have hqaP : q ∣ a * P := (Nat.dvd_add_right hqb).mp (by rwa [add_comm] at hqab)
+    rcases (Nat.Prime.dvd_mul hq).mp hqaP with h | h
+    · exact hqa h
+    · exact (hqP.mp h) hqb
+  · have hqP' : q ∣ a * P := Dvd.dvd.mul_left (hqP.mpr hqb) a
+    exact hqb ((Nat.dvd_add_right hqP').mp hqab)
+
+theorem main {N a b d : ℕ} (hN : N ≠ 0) (had : a * d = N) (hgcd : Nat.gcd a (Nat.gcd b d) = 1) :
+    ∃ γ₁ γ₂ : Matrix.SpecialLinearGroup (Fin 2) ℤ,
+      !![(a : ℤ), b; 0, d] = (γ₁ : Matrix (Fin 2) (Fin 2) ℤ) * !![(N : ℤ), 0; 0, 1]
+        * (γ₂ : Matrix (Fin 2) (Fin 2) ℤ) := by
+  have hd : d ≠ 0 := fun h0 => hN (by rw [← had, h0, mul_zero])
+  obtain ⟨p, hp⟩ := exists_coprime_mul_add hd hgcd
+  set u : ℤ := (a : ℤ) * p + b with hu
+  have hcop : IsCoprime u (d : ℤ) := by
+    rw [hu]
+    have : ((a * p + b : ℕ) : ℤ) = (a : ℤ) * p + b := by push_cast; ring
+    rw [← this, Int.isCoprime_iff_gcd_eq_one, Int.gcd_natCast_natCast]
+    exact hp
+  obtain ⟨s, t, hst⟩ := hcop
+  have hN' : (N : ℤ) = a * d := by exact_mod_cast had.symm
+  refine ⟨⟨!![-t, -u; s, -(d : ℤ)], ?_⟩, ⟨!![-1, (p : ℤ); -s * a, (p : ℤ) * s * a - 1], ?_⟩, ?_⟩
+  · rw [Matrix.det_fin_two_of]
+    linear_combination hst
+  · rw [Matrix.det_fin_two_of]
+    ring
+  · rw [Matrix.mul_fin_two, Matrix.mul_fin_two, hN']
+    ext i j
+    fin_cases i <;> fin_cases j
+    · simp
+      linear_combination (-(a : ℤ)) * hst + ((a : ℤ) * s) * hu
+    · simp
+      linear_combination ((a : ℤ) * p) * hst - ((a : ℤ) * p * s) * hu
+    · simp
+      ring
+    · simp
+      ring
+
+end Matrix.SpecialLinearGroup.PrimitiveSmith
+
+theorem solution
+    {N a b d : ℕ} (hN : N ≠ 0) (had : a * d = N) (hgcd : Nat.gcd a (Nat.gcd b d) = 1) :
+    ∃ γ₁ γ₂ : Matrix.SpecialLinearGroup (Fin 2) ℤ,
+      !![(a : ℤ), b; 0, d] = (γ₁ : Matrix (Fin 2) (Fin 2) ℤ) * !![(N : ℤ), 0; 0, 1] * (γ₂ : Matrix
+        (Fin 2) (Fin 2) ℤ) :=
+  Matrix.SpecialLinearGroup.PrimitiveSmith.main hN had hgcd
+
+end S_Matrix_SpecialLinearGroup_exists_eq_mul_diagonal_mul_of_gcd_eq_one
+end P2MW
+export P2MW.S_Matrix_SpecialLinearGroup_exists_eq_mul_diagonal_mul_of_gcd_eq_one (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem Matrix.SpecialLinearGroup.exists_eq_mul_diagonal_mul_of_gcd_eq_one
+    {N a b d : ℕ} (hN : N ≠ 0) (had : a * d = N) (hgcd : Nat.gcd a (Nat.gcd b d) = 1) :
+    ∃ γ₁ γ₂ : Matrix.SpecialLinearGroup (Fin 2) ℤ,
+      !![(a : ℤ), b; 0, d] = (γ₁ : Matrix (Fin 2) (Fin 2) ℤ) * !![(N : ℤ), 0; 0, 1] * (γ₂ : Matrix
+        (Fin 2) (Fin 2) ℤ) :=
+  solution hN had hgcd
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Matrix_SpecialLinearGroup_exists_generators_free_mod_neg_one_of_forall_trace_ne.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Matrix_SpecialLinearGroup_exists_generators_free_mod_neg_one_of_forall_trace_ne.lean
new file mode 100644
index 0000000000..1b6dd59c47
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Matrix_SpecialLinearGroup_exists_generators_free_mod_neg_one_of_forall_trace_ne.lean
@@ -0,0 +1,192 @@
+/-
+Based on Prove2Me node
+Matrix.SpecialLinearGroup.exists_generators_free_mod_neg_one_of_forall_trace_ne
+(3bd3e142-725c-544e-b864-4fd8b4d3ed7e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9ce5f5c0-0c4d-5814-b662-464da7d3f2e5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.LinearAlgebra.Matrix.SpecialLinearGroup
+public import Mathlib.LinearAlgebra.Matrix.Trace
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Matrix_SpecialLinearGroup_nonempty_freeGroupBasis_map_quotient_center_of_forall_trace_ne
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Free basis modulo ± 1 for torsion-free ΓleSL₂(ℤ)
+
+Theorem statement: `Matrix.SpecialLinearGroup.exists_generators_free_mod_neg_one_of_forall_trace_ne`
+(`3bd3e142-725c-544e-b864-4fd8b4d3ed7e`), by Claude, 2026-09-05.
+
+Proof: submission `9ce5f5c0-0c4d-5814-b662-464da7d3f2e5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of $\mathrm{SL}_2(\mathbb Z)$ (the special linear group of $2\times 2$
+integer matrices) of finite index, assume $-1\in\Gamma$, and assume that no $\gamma\in\Gamma$ has
+trace $0$, $1$ or $-1$ as an integer matrix. Put $n = 1 + [\mathrm{SL}_2(\mathbb Z):\Gamma]/6$,
+where the quotient is natural-number division of the index. The assertion is the existence of a
+family $g : \mathrm{Fin}\, n \to \Gamma$ with two properties. First, the subgroup of $\Gamma$
+generated by the set $\{g_0,\dots,g_{n-1}\}\cup\{-1\}$ (the element $-1$ taken with its membership
+in $\Gamma$) is the whole of $\Gamma$. Second, the family has the universal property of a free
+generating family with respect to groups in the lowest universe: for every group $L$ in `Type` and
+every family $v : \mathrm{Fin}\, n \to L$ there is a group homomorphism $f : \Gamma \to L$ with
+$f(g_i) = v_i$ for all $i$. No uniqueness of $f$ is claimed, so the conclusion says that $\Gamma$ is
+generated by $n$ elements together with $-1$ and that arbitrary values may be prescribed on those
+$n$ elements.
+
+The trace hypothesis rules out elements of finite order other than $\pm 1$, so $\Gamma$ has
+torsion-free image $\bar\Gamma$ in $\mathrm{PSL}_2(\mathbb Z)$; the classical statement is that such
+a $\bar\Gamma$ is free of rank $1 + [\mathrm{SL}_2(\mathbb Z):\Gamma]/6$, and the present form
+transports this to $\Gamma$ itself modulo $\pm 1$ in the shape of a generating family on which
+homomorphisms may be prescribed freely. It is used in the construction of bases for spaces of
+homomorphisms out of $\Gamma$, via
+[`ModularCurve.Period.exists_basis_parabolicHoms_castAddHom_comp`]
+(thm.html#ModularCurve.Period.exists_basis_parabolicHoms_castAddHom_comp).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Matrix_SpecialLinearGroup_exists_generators_free_mod_neg_one_of_forall_trace_ne.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_Matrix_SpecialLinearGroup_exists_generators_free_mod_neg_one_of_forall_trace_ne
+
+open Matrix MatrixGroups Subgroup
+
+namespace ModularCurve
+namespace FreeModNegOne
+
+section Basis
+
+variable {ι K L : Type*} [Group K] [Group L]
+
+theorem lift_apply_basis (b : FreeGroupBasis ι K) (f : ι → L) (i : ι) :
+    b.lift f (b i) = f i := by
+  change FreeGroup.lift f (b.repr (b i)) = f i
+  rw [FreeGroupBasis.repr_apply_coe, FreeGroup.lift_apply_of]
+
+theorem closure_range_basis (b : FreeGroupBasis ι K) :
+    Subgroup.closure (Set.range (b : ι → K)) = ⊤ := by
+  have hrange : Set.range (b : ι → K) =
+      ⇑b.repr.symm.toMonoidHom '' Set.range (FreeGroup.of : ι → FreeGroup ι) := by
+    rw [MulEquiv.coe_toMonoidHom, ← Set.range_comp]
+    rfl
+  rw [hrange, ← MonoidHom.map_closure, FreeGroup.closure_range_of, ← MonoidHom.range_eq_map]
+  exact MonoidHom.range_eq_top.mpr b.repr.symm.surjective
+
+end Basis
+
+variable (Γ : Subgroup SL(2, ℤ))
+
+theorem mem_center_iff_eq (A : SL(2, ℤ)) : A ∈ Subgroup.center SL(2, ℤ) ↔ A = 1 ∨ A = -1 := by
+  rw [Matrix.SpecialLinearGroup.mem_center_iff]
+  constructor
+  · rintro ⟨r, hr, hA⟩
+    have hr' : r * r = 1 := by rw [← pow_two]; simpa using hr
+    rcases mul_self_eq_one_iff.mp hr' with rfl | rfl
+    · left
+      apply Subtype.ext
+      rw [← hA, map_one]
+      rfl
+    · right
+      apply Subtype.ext
+      rw [← hA, map_neg, map_one]
+      rfl
+  · rintro (rfl | rfl)
+    · exact ⟨1, by simp, by simp⟩
+    · exact ⟨-1, by simp, by simp⟩
+
+abbrev toBar : Γ →* Γ.map (QuotientGroup.mk' (Subgroup.center SL(2, ℤ))) :=
+  (QuotientGroup.mk' (Subgroup.center SL(2, ℤ))).subgroupMap Γ
+
+theorem eq_one_or_eq_neg_of_toBar_eq_one (hneg : (-1 : SL(2, ℤ)) ∈ Γ) {x : Γ}
+    (h : toBar Γ x = 1) : x = 1 ∨ x = ⟨-1, hneg⟩ := by
+  have h' : (QuotientGroup.mk' (Subgroup.center SL(2, ℤ))) (x : SL(2, ℤ)) = 1 := by
+    have := congrArg Subtype.val h
+    simpa using this
+  rw [← MonoidHom.mem_ker, QuotientGroup.ker_mk', mem_center_iff_eq] at h'
+  rcases h' with h1 | h1
+  · left; exact Subtype.ext h1
+  · right; exact Subtype.ext h1
+
+theorem exists_gens [Γ.FiniteIndex] (hneg : (-1 : SL(2, ℤ)) ∈ Γ)
+    (hΓ : ∀ γ ∈ Γ, (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 0 ∧
+      (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 1 ∧ (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ -1) :
+    ∃ gens : Fin (1 + Γ.index / 6) → Γ,
+      Subgroup.closure (Set.range gens ∪ {⟨-1, hneg⟩}) = ⊤ ∧
+      ∀ (L : Type) [Group L] (v : Fin (1 + Γ.index / 6) → L),
+        ∃ f : Γ →* L, ∀ i, f (gens i) = v i := by
+  classical
+  obtain ⟨b⟩ :=
+    Matrix.SpecialLinearGroup.nonempty_freeGroupBasis_map_quotient_center_of_forall_trace_ne Γ hneg
+      hΓ
+  have hsurj := (QuotientGroup.mk' (Subgroup.center SL(2, ℤ))).subgroupMap_surjective Γ
+  choose gens hgens using fun i => hsurj (b i)
+  refine ⟨gens, ?_, ?_⟩
+  · set C : Subgroup Γ := Subgroup.closure (Set.range gens ∪ {⟨-1, hneg⟩}) with hC
+    have hnegC : (⟨-1, hneg⟩ : Γ) ∈ C := Subgroup.subset_closure (Set.mem_union_right _ rfl)
+    have hgensC : ∀ i, gens i ∈ C := fun i =>
+      Subgroup.subset_closure (Set.mem_union_left _ (Set.mem_range_self i))
+    have hker : (toBar Γ).ker ≤ C := by
+      intro x hx
+      rcases eq_one_or_eq_neg_of_toBar_eq_one Γ hneg (MonoidHom.mem_ker.mp hx) with rfl | rfl
+      · exact one_mem C
+      · exact hnegC
+    have himage : Subgroup.map (toBar Γ) C = ⊤ := by
+      rw [eq_top_iff, ← closure_range_basis b, Subgroup.closure_le]
+      rintro _ ⟨i, rfl⟩
+      exact ⟨gens i, hgensC i, hgens i⟩
+    have hsup : C ⊔ (toBar Γ).ker = ⊤ := by
+      rw [← Subgroup.comap_map_eq, himage, Subgroup.comap_top]
+    exact (sup_of_le_left hker).symm.trans hsup
+  · intro L _ v
+    refine ⟨(b.lift v).comp (toBar Γ), fun i => ?_⟩
+    rw [MonoidHom.comp_apply, hgens i]
+    exact lift_apply_basis b v i
+
+end ModularCurve.FreeModNegOne
+
+theorem solution (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hneg : (-1 : Matrix.SpecialLinearGroup (Fin 2) ℤ) ∈ Γ)
+    (hΓ : ∀ γ ∈ Γ, (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 0 ∧
+      (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 1 ∧ (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ -1) :
+    ∃ gens : Fin (1 + Γ.index / 6) → Γ,
+      Subgroup.closure (Set.range gens ∪ {⟨-1, hneg⟩}) = ⊤ ∧
+      ∀ (L : Type) [Group L] (v : Fin (1 + Γ.index / 6) → L),
+        ∃ f : Γ →* L, ∀ i, f (gens i) = v i :=
+  ModularCurve.FreeModNegOne.exists_gens Γ hneg hΓ
+
+end S_Matrix_SpecialLinearGroup_exists_generators_free_mod_neg_one_of_forall_trace_ne
+end P2MW
+export P2MW.S_Matrix_SpecialLinearGroup_exists_generators_free_mod_neg_one_of_forall_trace_ne
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem Matrix.SpecialLinearGroup.exists_generators_free_mod_neg_one_of_forall_trace_ne
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hneg : (-1 : Matrix.SpecialLinearGroup (Fin 2) ℤ) ∈ Γ)
+    (hΓ : ∀ γ ∈ Γ, (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 0 ∧
+      (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 1 ∧ (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ -1) :
+    ∃ gens : Fin (1 + Γ.index / 6) → Γ,
+      Subgroup.closure (Set.range gens ∪ {⟨-1, hneg⟩}) = ⊤ ∧
+      ∀ (L : Type) [Group L] (v : Fin (1 + Γ.index / 6) → L),
+        ∃ f : Γ →* L, ∀ i, f (gens i) = v i :=
+  solution Γ hneg hΓ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Matrix_SpecialLinearGroup_finrank_addMonoidHom_eq_of_forall_trace_ne.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Matrix_SpecialLinearGroup_finrank_addMonoidHom_eq_of_forall_trace_ne.lean
new file mode 100644
index 0000000000..b99143d1f7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Matrix_SpecialLinearGroup_finrank_addMonoidHom_eq_of_forall_trace_ne.lean
@@ -0,0 +1,234 @@
+/-
+Based on Prove2Me node Matrix.SpecialLinearGroup.finrank_addMonoidHom_eq_of_forall_trace_ne
+(245dc773-3bfc-5c53-b085-126353660e5b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f5b006b3-72f2-5303-a1b8-e84b0665765f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.LinearAlgebra.Dimension.Finrank
+public import Mathlib.LinearAlgebra.Matrix.SpecialLinearGroup
+public import Mathlib.LinearAlgebra.Matrix.Trace
+
+import Mathlib.LinearAlgebra.Dimension.Constructions
+import Mathlib.LinearAlgebra.FreeModule.StrongRankCondition
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Matrix_SpecialLinearGroup_nonempty_freeGroupBasis_map_quotient_center_of_forall_trace_ne
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Dimension of Hom(Γ,K) for elliptic-free ΓleSL₂(ℤ)
+
+Theorem statement: `Matrix.SpecialLinearGroup.finrank_addMonoidHom_eq_of_forall_trace_ne`
+(`245dc773-3bfc-5c53-b085-126353660e5b`), by Claude, 2026-09-05.
+
+Proof: submission `f5b006b3-72f2-5303-a1b8-e84b0665765f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of $\mathrm{SL}_2(\mathbb Z)$ (the group of $2\times 2$ integer matrices
+of determinant $1$) of finite index, and assume that $-1\in\Gamma$ and that every $\gamma\in\Gamma$
+has $\operatorname{tr}(\gamma)\neq 0$, $\operatorname{tr}(\gamma)\neq 1$ and
+$\operatorname{tr}(\gamma)\neq -1$, the trace being taken of the underlying integer matrix. Let $K$
+be a field of characteristic zero. Then the $K$-vector space $\mathrm{Hom}(\Gamma,K)$ of additive
+characters of $\Gamma$ — formally, the additive monoid homomorphisms from $\Gamma$, viewed
+additively via `Additive`, to $K$, with its $K$-module structure by scaling in the target — has
+finite dimension, and $$\dim_K\mathrm{Hom}(\Gamma,K) = 1 + [\mathrm{SL}_2(\mathbb Z):\Gamma]/6,$$
+where the quotient is division of natural numbers (truncated); the index is `Subgroup.index`. The
+assertion is about `Module.finrank`, so it simultaneously records that the dimension is finite and
+equal to the stated value.
+
+The hypothesis on traces excludes elements of finite order other than $\pm 1$, so the image
+$\bar\Gamma$ of $\Gamma$ in $\mathrm{PSL}_2(\mathbb Z)$ is free of rank $1 + [\mathrm{SL}_2(\mathbb
+Z):\Gamma]/6$; this statement converts that freeness into the dimension of the space of $K$-valued
+characters, i.e. of $H^1(\Gamma,K)$ with trivial action. It feeds the count of parabolic
+homomorphisms on $\Gamma$ used in the numerics of modular curves, being cited by
+[`ModularCurve.six_mul_level_mul_finrank_parabolicHoms_Gamma_add_eq`]
+(thm.html#ModularCurve.six_mul_level_mul_finrank_parabolicHoms_Gamma_add_eq).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Matrix_SpecialLinearGroup_finrank_addMonoidHom_eq_of_forall_trace_ne.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_Matrix_SpecialLinearGroup_finrank_addMonoidHom_eq_of_forall_trace_ne
+
+open Matrix MatrixGroups Subgroup
+
+namespace ModularCurve
+namespace FreeModNegOne
+
+section Basis
+
+variable {ι K L : Type*} [Group K] [Group L]
+
+theorem lift_apply_basis (b : FreeGroupBasis ι K) (f : ι → L) (i : ι) :
+    b.lift f (b i) = f i := by
+  change FreeGroup.lift f (b.repr (b i)) = f i
+  rw [FreeGroupBasis.repr_apply_coe, FreeGroup.lift_apply_of]
+
+theorem closure_range_basis (b : FreeGroupBasis ι K) :
+    Subgroup.closure (Set.range (b : ι → K)) = ⊤ := by
+  have hrange : Set.range (b : ι → K) =
+      ⇑b.repr.symm.toMonoidHom '' Set.range (FreeGroup.of : ι → FreeGroup ι) := by
+    rw [MulEquiv.coe_toMonoidHom, ← Set.range_comp]
+    rfl
+  rw [hrange, ← MonoidHom.map_closure, FreeGroup.closure_range_of, ← MonoidHom.range_eq_map]
+  exact MonoidHom.range_eq_top.mpr b.repr.symm.surjective
+
+end Basis
+
+variable (Γ : Subgroup SL(2, ℤ))
+
+theorem mem_center_iff_eq (A : SL(2, ℤ)) : A ∈ Subgroup.center SL(2, ℤ) ↔ A = 1 ∨ A = -1 := by
+  rw [Matrix.SpecialLinearGroup.mem_center_iff]
+  constructor
+  · rintro ⟨r, hr, hA⟩
+    have hr' : r * r = 1 := by rw [← pow_two]; simpa using hr
+    rcases mul_self_eq_one_iff.mp hr' with rfl | rfl
+    · left
+      apply Subtype.ext
+      rw [← hA, map_one]
+      rfl
+    · right
+      apply Subtype.ext
+      rw [← hA, map_neg, map_one]
+      rfl
+  · rintro (rfl | rfl)
+    · exact ⟨1, by simp, by simp⟩
+    · exact ⟨-1, by simp, by simp⟩
+
+abbrev toBar : Γ →* Γ.map (QuotientGroup.mk' (Subgroup.center SL(2, ℤ))) :=
+  (QuotientGroup.mk' (Subgroup.center SL(2, ℤ))).subgroupMap Γ
+
+theorem eq_one_or_eq_neg_of_toBar_eq_one (hneg : (-1 : SL(2, ℤ)) ∈ Γ) {x : Γ}
+    (h : toBar Γ x = 1) : x = 1 ∨ x = ⟨-1, hneg⟩ := by
+  have h' : (QuotientGroup.mk' (Subgroup.center SL(2, ℤ))) (x : SL(2, ℤ)) = 1 := by
+    have := congrArg Subtype.val h
+    simpa using this
+  rw [← MonoidHom.mem_ker, QuotientGroup.ker_mk', mem_center_iff_eq] at h'
+  rcases h' with h1 | h1
+  · left; exact Subtype.ext h1
+  · right; exact Subtype.ext h1
+
+theorem exists_gens [Γ.FiniteIndex] (hneg : (-1 : SL(2, ℤ)) ∈ Γ)
+    (hΓ : ∀ γ ∈ Γ, (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 0 ∧
+      (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 1 ∧ (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ -1) :
+    ∃ gens : Fin (1 + Γ.index / 6) → Γ,
+      Subgroup.closure (Set.range gens ∪ {⟨-1, hneg⟩}) = ⊤ ∧
+      ∀ (L : Type) [Group L] (v : Fin (1 + Γ.index / 6) → L),
+        ∃ f : Γ →* L, ∀ i, f (gens i) = v i := by
+  classical
+  obtain ⟨b⟩ :=
+    Matrix.SpecialLinearGroup.nonempty_freeGroupBasis_map_quotient_center_of_forall_trace_ne Γ hneg
+      hΓ
+  have hsurj := (QuotientGroup.mk' (Subgroup.center SL(2, ℤ))).subgroupMap_surjective Γ
+  choose gens hgens using fun i => hsurj (b i)
+  refine ⟨gens, ?_, ?_⟩
+  · set C : Subgroup Γ := Subgroup.closure (Set.range gens ∪ {⟨-1, hneg⟩}) with hC
+    have hnegC : (⟨-1, hneg⟩ : Γ) ∈ C := Subgroup.subset_closure (Set.mem_union_right _ rfl)
+    have hgensC : ∀ i, gens i ∈ C := fun i =>
+      Subgroup.subset_closure (Set.mem_union_left _ (Set.mem_range_self i))
+    have hker : (toBar Γ).ker ≤ C := by
+      intro x hx
+      rcases eq_one_or_eq_neg_of_toBar_eq_one Γ hneg (MonoidHom.mem_ker.mp hx) with rfl | rfl
+      · exact one_mem C
+      · exact hnegC
+    have himage : Subgroup.map (toBar Γ) C = ⊤ := by
+      rw [eq_top_iff, ← closure_range_basis b, Subgroup.closure_le]
+      rintro _ ⟨i, rfl⟩
+      exact ⟨gens i, hgensC i, hgens i⟩
+    have hsup : C ⊔ (toBar Γ).ker = ⊤ := by
+      rw [← Subgroup.comap_map_eq, himage, Subgroup.comap_top]
+    exact (sup_of_le_left hker).symm.trans hsup
+  · intro L _ v
+    refine ⟨(b.lift v).comp (toBar Γ), fun i => ?_⟩
+    rw [MonoidHom.comp_apply, hgens i]
+    exact lift_apply_basis b v i
+
+theorem finrank_addMonoidHom [Γ.FiniteIndex] (hneg : (-1 : SL(2, ℤ)) ∈ Γ)
+    (hΓ : ∀ γ ∈ Γ, (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 0 ∧
+      (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 1 ∧ (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ -1)
+    (K : Type) [Field K] [CharZero K] :
+    Module.finrank K (Additive Γ →+ K) = 1 + Γ.index / 6 := by
+  obtain ⟨gens, hcl, hext⟩ := exists_gens Γ hneg hΓ
+  let ev : (Additive Γ →+ K) →ₗ[K] (Fin (1 + Γ.index / 6) → K) :=
+    { toFun := fun φ i => φ (Additive.ofMul (gens i))
+      map_add' := fun _ _ => rfl
+      map_smul' := fun _ _ => rfl }
+  have hneg0 : ∀ φ : Additive Γ →+ K, φ (Additive.ofMul (⟨-1, hneg⟩ : Γ)) = 0 := by
+    intro φ
+    have h2 : (⟨-1, hneg⟩ : Γ) * ⟨-1, hneg⟩ = 1 := by
+      apply Subtype.ext
+      change (-1 : SL(2, ℤ)) * -1 = 1
+      rw [neg_mul_neg, one_mul]
+    have : φ (Additive.ofMul (⟨-1, hneg⟩ : Γ)) + φ (Additive.ofMul (⟨-1, hneg⟩ : Γ)) = 0 := by
+      rw [← map_add, ← ofMul_mul, h2, ofMul_one, map_zero]
+    have h3 : (2 : K) * φ (Additive.ofMul (⟨-1, hneg⟩ : Γ)) = 0 := by rw [two_mul]; exact this
+    exact (mul_eq_zero.mp h3).resolve_left two_ne_zero
+  have hinj : Function.Injective ev := by
+    intro φ ψ h
+    have key : ∀ γ : Γ, φ (Additive.ofMul γ) = ψ (Additive.ofMul γ) := by
+      intro γ
+      have hγ : γ ∈ Subgroup.closure (Set.range gens ∪ {⟨-1, hneg⟩}) := by
+        rw [hcl]; exact Subgroup.mem_top γ
+      induction hγ using Subgroup.closure_induction with
+      | mem x hx =>
+        rcases hx with ⟨i, rfl⟩ | hx
+        · exact congrFun h i
+        · rw [Set.mem_singleton_iff] at hx
+          subst hx
+          rw [hneg0, hneg0]
+      | one => rw [ofMul_one, map_zero, map_zero]
+      | mul x y _ _ hx hy => rw [ofMul_mul, map_add, map_add, hx, hy]
+      | inv x _ hx => rw [ofMul_inv, map_neg, map_neg, hx]
+    exact AddMonoidHom.ext fun a => key (Additive.toMul a)
+  have hsurj : Function.Surjective ev := by
+    intro v
+    obtain ⟨f, hf⟩ := hext (Multiplicative K) (fun i => Multiplicative.ofAdd (v i))
+    refine ⟨(MonoidHom.toAdditive f), funext fun i => ?_⟩
+    change Multiplicative.toAdd (f (gens i)) = v i
+    rw [hf i]
+    rfl
+  rw [(LinearEquiv.ofBijective ev ⟨hinj, hsurj⟩).finrank_eq, Module.finrank_fin_fun]
+
+end ModularCurve.FreeModNegOne
+
+theorem solution (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hneg : (-1 : Matrix.SpecialLinearGroup (Fin 2) ℤ) ∈ Γ)
+    (hΓ : ∀ γ ∈ Γ, (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 0 ∧
+      (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 1 ∧ (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ -1)
+    (K : Type) [Field K] [CharZero K] :
+    Module.finrank K (Additive Γ →+ K) = 1 + Γ.index / 6 :=
+  ModularCurve.FreeModNegOne.finrank_addMonoidHom Γ hneg hΓ K
+
+end S_Matrix_SpecialLinearGroup_finrank_addMonoidHom_eq_of_forall_trace_ne
+end P2MW
+export P2MW.S_Matrix_SpecialLinearGroup_finrank_addMonoidHom_eq_of_forall_trace_ne (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem Matrix.SpecialLinearGroup.finrank_addMonoidHom_eq_of_forall_trace_ne
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hneg : (-1 : Matrix.SpecialLinearGroup (Fin 2) ℤ) ∈ Γ)
+    (hΓ : ∀ γ ∈ Γ, (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 0 ∧
+      (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 1 ∧ (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ -1)
+    (K : Type) [Field K] [CharZero K] :
+    Module.finrank K (Additive Γ →+ K) = 1 + Γ.index / 6 :=
+  solution Γ hneg hΓ K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Matrix_SpecialLinearGroup_nonempty_freeGroupBasis_map_quotient_center_of_forall_trace_ne.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Matrix_SpecialLinearGroup_nonempty_freeGroupBasis_map_quotient_center_of_forall_trace_ne.lean
new file mode 100644
index 0000000000..1f0cf9f226
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Matrix_SpecialLinearGroup_nonempty_freeGroupBasis_map_quotient_center_of_forall_trace_ne.lean
@@ -0,0 +1,270 @@
+/-
+Based on Prove2Me node
+Matrix.SpecialLinearGroup.nonempty_freeGroupBasis_map_quotient_center_of_forall_trace_ne
+(8a515b68-0526-52cb-8cbc-52fbd29a8276) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 82502845-9dc2-5a07-8245-7f4f24c10cc3
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.GroupTheory.FreeGroup.IsFreeGroup
+public import Mathlib.LinearAlgebra.Matrix.SpecialLinearGroup
+public import Mathlib.LinearAlgebra.Matrix.Trace
+
+import Mathlib.Analysis.Normed.Ring.Lemmas
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularGroup_exists_mulEquiv_freeProduct_quotient_center
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Monoid_CoprodI_nonempty_freeGroupBasis_fin_kuroshRank
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Subgroup_card_orbitRelQuotient_mul_card_eq_index
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Free image in PSL₂(ℤ) of a torsion-free congruence-type subgroup
+
+Theorem statement:
+`Matrix.SpecialLinearGroup.nonempty_freeGroupBasis_map_quotient_center_of_forall_trace_ne`
+(`8a515b68-0526-52cb-8cbc-52fbd29a8276`), by Claude, 2026-09-05.
+
+Proof: submission `82502845-9dc2-5a07-8245-7f4f24c10cc3`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of $\mathrm{SL}_2(\mathbb{Z})$ (matrices over $\mathbb{Z}$ indexed by
+`Fin 2`) which is of finite index, i.e. carries the `FiniteIndex` instance, and assume: (i) $-1 \in
+\Gamma$; (ii) for every $\gamma \in \Gamma$ the trace of the underlying integral $2 \times 2$ matrix
+is different from $0$, from $1$ and from $-1$. The conclusion is that the type `FreeGroupBasis (Fin
+(1 + Γ.index / 6))` of the image of $\Gamma$ under the canonical projection
+$\mathrm{SL}_2(\mathbb{Z}) \to \mathrm{SL}_2(\mathbb{Z})/Z$, $Z$ the centre, is nonempty; that is,
+the image $\bar\Gamma$ of $\Gamma$ in $\mathrm{PSL}_2(\mathbb{Z})$ admits a basis as a free group
+indexed by the finite type with $1 + [\mathrm{SL}_2(\mathbb{Z}):\Gamma]/6$ elements, where the
+quotient is natural-number division. So $\bar\Gamma$ is free of rank $1 +
+[\mathrm{SL}_2(\mathbb{Z}):\Gamma]/6$, the index being that of $\Gamma$ in the full group; no
+divisibility assertion about the index is made, the division being truncated.
+
+This is the classical statement that a finite-index subgroup of $\mathrm{SL}_2(\mathbb{Z})$
+containing $-1$ and having no elliptic elements has free image in $\mathrm{PSL}_2(\mathbb{Z})$, of
+rank $1 + [\mathrm{SL}_2(\mathbb{Z}):\Gamma]/6$; it is obtained by transporting the Kurosh rank
+formula
+[`Monoid.CoprodI.nonempty_freeGroupBasis_fin_kuroshRank`]
+(thm.html#Monoid.CoprodI.nonempty_freeGroupBasis_fin_kuroshRank)
+along the isomorphism $\mathrm{PSL}_2(\mathbb{Z}) \cong C_2 * C_3$ of
+[`ModularGroup.exists_mulEquiv_freeProduct_quotient_center`]
+(thm.html#ModularGroup.exists_mulEquiv_freeProduct_quotient_center),
+together with the index computation
+[`Subgroup.card_orbitRelQuotient_mul_card_eq_index`]
+(thm.html#Subgroup.card_orbitRelQuotient_mul_card_eq_index).
+It feeds the construction of explicit free generators for such subgroups and, through that, the
+vanishing of $H^2$ and the degree-one surjectivity statements used in the cohomological part of the
+argument.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Matrix_SpecialLinearGroup_nonempty_freeGroupBasis_map_quotient_center_of_forall_trace_ne.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_9c064c5e
+
+open Matrix MatrixGroups ModularGroup Subgroup
+open scoped Pointwise
+
+namespace ModularCurve
+namespace FreeTransport
+
+theorem kurosh_two_three {m : ℕ} (hm : 6 ∣ m) : 1 + m - m / 2 - m / 3 = 1 + m / 6 := by
+  obtain ⟨k, rfl⟩ := hm
+  omega
+
+abbrev G23 (i : Fin 2) : Type := Multiplicative (ZMod (i.val + 2))
+
+scoped instance factOneLt (i : Fin 2) : Fact (1 < i.val + 2) := ⟨by omega⟩
+
+theorem natCard_G23 (i : Fin 2) : Nat.card (G23 i) = i.val + 2 := by
+  rw [Nat.card_eq_fintype_card, Fintype.card_multiplicative, ZMod.card]
+
+abbrev PSL : Type := SL(2, ℤ) ⧸ Subgroup.center SL(2, ℤ)
+
+noncomputable def e : Monoid.CoprodI G23 ≃* PSL :=
+  ModularGroup.exists_mulEquiv_freeProduct_quotient_center.choose
+
+theorem e_of_zero : e (Monoid.CoprodI.of (i := 0) (Multiplicative.ofAdd 1)) = QuotientGroup.mk S :=
+  ModularGroup.exists_mulEquiv_freeProduct_quotient_center.choose_spec.1
+
+theorem e_of_one :
+    e (Monoid.CoprodI.of (i := 1) (Multiplicative.ofAdd 1)) = QuotientGroup.mk (S * T) :=
+  ModularGroup.exists_mulEquiv_freeProduct_quotient_center.choose_spec.2
+
+theorem exists_trace_of_ne_one {i : Fin 2} (x : G23 i) (hx : x ≠ 1) :
+    ∃ w : SL(2, ℤ), e (Monoid.CoprodI.of x) = QuotientGroup.mk w ∧
+      ((w : Matrix (Fin 2) (Fin 2) ℤ).trace = 0 ∨ (w : Matrix (Fin 2) (Fin 2) ℤ).trace = 1 ∨
+        (w : Matrix (Fin 2) (Fin 2) ℤ).trace = -1) := by
+  fin_cases i
+  · have hh : x = Multiplicative.ofAdd 1 := by
+      revert hx; revert x; decide
+    subst hh
+    exact ⟨S, e_of_zero, Or.inl (by decide)⟩
+  · have hh : x = Multiplicative.ofAdd 1 ∨
+        x = Multiplicative.ofAdd 1 * Multiplicative.ofAdd 1 := by
+      revert hx; revert x; decide
+    rcases hh with rfl | rfl
+    · exact ⟨S * T, e_of_one, Or.inr (Or.inl (by decide))⟩
+    · refine ⟨S * T * (S * T), ?_, Or.inr (Or.inr (by decide))⟩
+      have h1 : e (Monoid.CoprodI.of (i := 1) (Multiplicative.ofAdd 1)) = QuotientGroup.mk (S * T)
+        :=
+        e_of_one
+      rw [map_mul, map_mul, QuotientGroup.mk_mul]
+      exact congrArg₂ (· * ·) h1 h1
+
+theorem mem_center_iff_eq (A : SL(2, ℤ)) : A ∈ Subgroup.center SL(2, ℤ) ↔ A = 1 ∨ A = -1 := by
+  rw [Matrix.SpecialLinearGroup.mem_center_iff]
+  constructor
+  · rintro ⟨r, hr, hA⟩
+    have hr' : r * r = 1 := by rw [← pow_two]; simpa using hr
+    rcases mul_self_eq_one_iff.mp hr' with rfl | rfl
+    · left
+      apply Subtype.ext
+      rw [← hA, map_one]
+      rfl
+    · right
+      apply Subtype.ext
+      rw [← hA, map_neg, map_one]
+      rfl
+  · rintro (rfl | rfl)
+    · exact ⟨1, by simp, by simp⟩
+    · exact ⟨-1, by simp, by simp⟩
+
+theorem trace_coe_conj (δ w : SL(2, ℤ)) :
+    ((δ⁻¹ * w * δ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace = (w : Matrix (Fin 2) (Fin 2)
+      ℤ).trace := by
+  rw [Matrix.SpecialLinearGroup.coe_mul, Matrix.SpecialLinearGroup.coe_mul,
+    Matrix.trace_mul_comm, ← Matrix.mul_assoc, ← Matrix.SpecialLinearGroup.coe_mul,
+    mul_inv_cancel, Matrix.SpecialLinearGroup.coe_one, Matrix.one_mul]
+
+section Main
+
+variable (Γ : Subgroup SL(2, ℤ))
+
+abbrev bar : Subgroup PSL := Γ.map (QuotientGroup.mk' (Subgroup.center SL(2, ℤ)))
+
+noncomputable abbrev pulledBack : Subgroup (Monoid.CoprodI G23) := (bar Γ).comap e.toMonoidHom
+
+theorem map_pulledBack : (pulledBack Γ).map e.toMonoidHom = bar Γ :=
+  Subgroup.map_comap_eq_self_of_surjective e.surjective _
+
+theorem index_bar (hneg : (-1 : SL(2, ℤ)) ∈ Γ) : (bar Γ).index = Γ.index := by
+  apply Subgroup.index_map_eq _ (QuotientGroup.mk'_surjective _)
+  rw [QuotientGroup.ker_mk']
+  intro z hz
+  rcases (mem_center_iff_eq z).mp hz with rfl | rfl
+  · exact one_mem Γ
+  · exact hneg
+
+theorem index_pulledBack (hneg : (-1 : SL(2, ℤ)) ∈ Γ) : (pulledBack Γ).index = Γ.index := by
+  rw [Subgroup.index_comap_of_surjective _ e.surjective, index_bar Γ hneg]
+
+variable (hΓ : ∀ γ ∈ Γ, (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 0 ∧
+    (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 1 ∧ (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ -1)
+include hΓ
+
+theorem conjTrivial (i : Fin 2) (g : Monoid.CoprodI G23) (x : G23 i)
+    (hconj : g⁻¹ * Monoid.CoprodI.of x * g ∈ pulledBack Γ) : x = 1 := by
+  by_contra hx
+  obtain ⟨w, hw, htr⟩ := exists_trace_of_ne_one x hx
+  obtain ⟨δ, hδ⟩ := QuotientGroup.mk_surjective (e g)
+  rw [Subgroup.mem_comap, MulEquiv.coe_toMonoidHom, map_mul, map_mul, map_inv, hw, ← hδ] at hconj
+  obtain ⟨γ, hγ, hγeq⟩ := Subgroup.mem_map.mp hconj
+  have hγeq' : (QuotientGroup.mk γ : PSL) = QuotientGroup.mk (δ⁻¹ * w * δ) := by
+    rw [QuotientGroup.mk'_apply] at hγeq
+    rw [hγeq, QuotientGroup.mk_mul, QuotientGroup.mk_mul, QuotientGroup.mk_inv]
+  rw [QuotientGroup.eq] at hγeq'
+  have key : ((γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace = (w : Matrix (Fin 2) (Fin 2)
+    ℤ).trace ∨
+      ((γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace = -(w : Matrix (Fin 2) (Fin 2) ℤ).trace :=
+        by
+    rcases (mem_center_iff_eq _).mp hγeq' with h1 | h1
+    · left
+      have : δ⁻¹ * w * δ = γ := by
+        rw [inv_mul_eq_iff_eq_mul, mul_one] at h1; exact h1
+      rw [← trace_coe_conj δ w, this]
+    · right
+      have : δ⁻¹ * w * δ = -γ := by
+        rw [inv_mul_eq_iff_eq_mul, mul_neg_one] at h1; exact h1
+      rw [← trace_coe_conj δ w, this, Matrix.SpecialLinearGroup.coe_neg, Matrix.trace_neg, neg_neg]
+  obtain ⟨h0, h1, hm1⟩ := hΓ γ hγ
+  rcases key with hk | hk <;> rcases htr with ht | ht | ht <;> rw [ht] at hk
+  · exact h0 hk
+  · exact h1 hk
+  · exact hm1 hk
+  · exact h0 (by rw [hk]; norm_num)
+  · exact hm1 (by rw [hk])
+  · exact h1 (by rw [hk]; norm_num)
+
+theorem nonempty_freeGroupBasis [Γ.FiniteIndex] (hneg : (-1 : SL(2, ℤ)) ∈ Γ) :
+    Nonempty (FreeGroupBasis (Fin (1 + Γ.index / 6)) (bar Γ)) := by
+  have : (pulledBack Γ).FiniteIndex := ⟨by
+    rw [index_pulledBack Γ hneg]; exact Subgroup.FiniteIndex.index_ne_zero⟩
+  have hCT := conjTrivial Γ hΓ
+  obtain ⟨b⟩ := Monoid.CoprodI.nonempty_freeGroupBasis_fin_kuroshRank (pulledBack Γ) hCT
+  have hdvd : ∀ i : Fin 2, (i.val + 2) ∣ Γ.index := by
+    intro i
+    have hc := Subgroup.card_orbitRelQuotient_mul_card_eq_index (pulledBack Γ)
+      (Monoid.CoprodI.of (M := G23) (i := i)).range (by
+        rintro g x ⟨a, rfl⟩ h
+        rw [hCT i g a h, map_one])
+    rw [index_pulledBack Γ hneg] at hc
+    have hK : Nat.card ((Monoid.CoprodI.of (M := G23) (i := i)).range) = i.val + 2 :=
+      (Nat.card_congr (MonoidHom.ofInjective (Monoid.CoprodI.of_injective i)).toEquiv).symm.trans
+        (natCard_G23 i)
+    rw [hK] at hc
+    exact Dvd.intro_left _ hc
+  have h6 : 6 ∣ Γ.index :=
+    (by decide : Nat.Coprime 2 3).mul_dvd_of_dvd_of_dvd (hdvd 0) (hdvd 1)
+  have hrank : 1 + (pulledBack Γ).index - (pulledBack Γ).index / Nat.card (G23 0)
+      - (pulledBack Γ).index / Nat.card (G23 1) = 1 + Γ.index / 6 := by
+    rw [index_pulledBack Γ hneg, natCard_G23, natCard_G23]
+    exact kurosh_two_three h6
+  rw [hrank] at b
+  exact ⟨(b.map (e.subgroupMap (pulledBack Γ))).map (MulEquiv.subgroupCongr (map_pulledBack Γ))⟩
+
+end Main
+
+end ModularCurve.FreeTransport
+
+theorem solution (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hneg : (-1 : Matrix.SpecialLinearGroup (Fin 2) ℤ) ∈ Γ)
+    (hΓ : ∀ γ ∈ Γ, (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 0 ∧
+      (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 1 ∧ (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ -1) :
+    Nonempty (FreeGroupBasis (Fin (1 + Γ.index / 6))
+      (Γ.map (QuotientGroup.mk' (Subgroup.center (Matrix.SpecialLinearGroup (Fin 2) ℤ))))) :=
+  ModularCurve.FreeTransport.nonempty_freeGroupBasis Γ hΓ hneg
+
+end S_OVERLONG_9c064c5e
+end P2MW
+export
+  P2MW.S_OVERLONG_9c064c5e
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem Matrix.SpecialLinearGroup.nonempty_freeGroupBasis_map_quotient_center_of_forall_trace_ne
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hneg : (-1 : Matrix.SpecialLinearGroup (Fin 2) ℤ) ∈ Γ)
+    (hΓ : ∀ γ ∈ Γ, (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 0 ∧
+      (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 1 ∧ (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ -1) :
+    Nonempty (FreeGroupBasis (Fin (1 + Γ.index / 6))
+      (Γ.map (QuotientGroup.mk' (Subgroup.center (Matrix.SpecialLinearGroup (Fin 2) ℤ))))) :=
+  solution Γ hneg hΓ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_exists_torsionBy_reduction_addEquiv.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_exists_torsionBy_reduction_addEquiv.lean
new file mode 100644
index 0000000000..6af2bf8d23
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_exists_torsionBy_reduction_addEquiv.lean
@@ -0,0 +1,158 @@
+/-
+Based on Prove2Me node ModularCurve.B3.exists_torsionBy_reduction_addEquiv
+(44aabecf-b500-5bf4-98da-9a12f52e3217) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 45f040e2-7cb2-5205-af9d-61e92078d3e5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_SpecialisationVocab
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_TatePoint
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_HahnSpecialise
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_HahnSpecialise_specialise_bijOn_torsion
+import Mathlib.Algebra.Module.Torsion.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Reduction is an isomorphism on p-torsion
+
+Theorem statement: `ModularCurve.B3.exists_torsionBy_reduction_addEquiv`
+(`44aabecf-b500-5bf4-98da-9a12f52e3217`), by Claude, 2026-09-05.
+
+Proof: submission `45f040e2-7cb2-5205-af9d-61e92078d3e5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $W$ be a Weierstrass curve over the field $H$ of the Tate-point construction, assumed elliptic,
+and let `specialFibre W` be the Weierstrass curve over $\overline{\mathbb{Q}} =$ `AlgebraicClosure
+ℚ` whose coefficients are the coefficients at $0$ of $a_1,a_2,a_3,a_4,a_6$ of $W$, also assumed
+elliptic. Assume `IntegralCoeffs W`, i.e. each of $a_1,a_2,a_3,a_4,a_6$ has $\mathrm{orderTop} \ge
+0$, and assume $\mathrm{orderTop}(\Delta_W) = 0$. Let $p$ be a prime. Then there is an isomorphism
+of additive groups $e$ from the $\mathbb{Z}$-torsion submodule $\{P : p \cdot P = 0\}$ of the affine
+point group of $W$ onto the corresponding $p$-torsion submodule of the affine point group of
+`specialFibre W`, which is given on coordinates by taking coefficients at $0$: for every $p$-torsion
+point $P$ and all $x, y \in H$ with $(x,y)$ nonsingular on the affine model of $W$, if $P$ is the
+affine point $(x,y)$, then $(x.\mathrm{coeff}\ 0, y.\mathrm{coeff}\ 0)$ is nonsingular on the affine
+model of `specialFibre W` and $e(P)$ is the affine point with these coordinates. Only the existence
+of such an $e$ is asserted, not uniqueness.
+
+This is the good-reduction statement that reduction modulo the maximal ideal is injective, indeed
+bijective, on $p$-torsion for a model with integral coefficients and unit discriminant, together
+with the description of the reduction map on affine coordinates as passage to constant terms. It
+serves the construction of Tate points on modular curves, where the $p$-torsion of a curve over the
+Hahn-series field has to be identified with the $p$-torsion of its special fibre compatibly with
+coordinates.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_B3_exists_torsionBy_reduction_addEquiv.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_B3_exists_torsionBy_reduction_addEquiv
+
+noncomputable section
+
+open ModularCurve ModularCurve.B3 ModularCurve.HahnSpecialise
+open ModularCurve.TatePoint (Qbar H CycSubH)
+open IsLocalRing WeierstrassCurve
+open scoped Classical
+
+namespace Sol3a
+
+variable (W : WeierstrassCurve H) (hW : IntegralCoeffs W) (hΔ' : (specialFibre W).Δ ≠ 0)
+
+theorem nsmul_of_mem {M : Type*} [AddCommGroup M] {N : ℕ} {x : M}
+    (hx : x ∈ Submodule.torsionBy ℤ M (N : ℤ)) : N • x = 0 := by
+  rw [Submodule.mem_torsionBy_iff] at hx; rwa [natCast_zsmul] at hx
+
+theorem mem_of_nsmul {M : Type*} [AddCommGroup M] {N : ℕ} {x : M}
+    (hx : N • x = 0) : x ∈ Submodule.torsionBy ℤ M (N : ℤ) := by
+  rw [Submodule.mem_torsionBy_iff, natCast_zsmul]; exact hx
+
+def torsHom (N : ℕ) :
+    Submodule.torsionBy ℤ W.toAffine.Point (N : ℤ) →+
+      Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (N : ℤ) where
+  toFun P := ⟨specialise W hW hΔ' P, by
+    have hP := P.2
+    rw [Submodule.mem_torsionBy_iff] at hP ⊢
+    rw [← map_zsmul, hP, map_zero]⟩
+  map_zero' := Subtype.ext (map_zero _)
+  map_add' P Q := Subtype.ext (map_add _ _ _)
+
+theorem torsHom_bijective (N : ℕ) [NeZero N] : Function.Bijective (torsHom W hW hΔ' N) := by
+  have hb := ModularCurve.HahnSpecialise.specialise_bijOn_torsion W hW hΔ' N
+  refine ⟨fun P Q h => Subtype.ext (hb.2.1 (nsmul_of_mem P.2) (nsmul_of_mem Q.2)
+    (congrArg Subtype.val h)), fun Q => ?_⟩
+  obtain ⟨P, hP, hPQ⟩ := hb.2.2 (nsmul_of_mem Q.2)
+  exact ⟨⟨P, mem_of_nsmul hP⟩, Subtype.ext hPQ⟩
+
+end Sol3a
+
+theorem solution (W : WeierstrassCurve H)
+    [W.IsElliptic] (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0)
+    [(specialFibre W).IsElliptic] (p : ℕ) [Fact p.Prime] :
+    ∃ e : Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ) ≃+
+        Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ),
+      ∀ (P : Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ)) (x y : H)
+        (h : W.toAffine.Nonsingular x y),
+        (P : W.toAffine.Point) = WeierstrassCurve.Affine.Point.some x y h →
+          ∃ h₀ : (specialFibre W).toAffine.Nonsingular (x.coeff 0) (y.coeff 0),
+            ((e P : Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ)) :
+                (specialFibre W).toAffine.Point) =
+              WeierstrassCurve.Affine.Point.some (x.coeff 0) (y.coeff 0) h₀ := by
+  have hΔ' : (specialFibre W).Δ ≠ 0 := (specialFibre_Δ_ne_zero_iff W hW).mpr hΔ
+  have : NeZero p := ⟨(Fact.out : p.Prime).ne_zero⟩
+  refine ⟨AddEquiv.ofBijective (Sol3a.torsHom W hW hΔ' p) (Sol3a.torsHom_bijective W hW hΔ' p), ?_⟩
+  intro P x y h hP
+  have hPt : p • (P : W.toAffine.Point) = 0 := Sol3a.nsmul_of_mem P.2
+  have h' : ((liftModel W hW).map valuationSubringH.subtype).toAffine.Nonsingular x y := by
+    rw [liftModel_map_subtype]; exact h
+  have hx : x ∈ valuationSubringH := by
+    refine X_mem_of_nsmul_eq_zero' (liftModel W hW) (natCast_residueField_ne_zero (NeZero.ne p)) h'
+      ?_
+    have : (P : W.toAffine.Point) = (Affine.Point.some x y h' :
+        ((liftModel W hW).map valuationSubringH.subtype).toAffine.Point) := hP
+    rw [← this]; exact hPt
+  refine ⟨nonsingular_specialFibre_coeff_zero W hW hΔ' h hx, ?_⟩
+  change specialise W hW hΔ' (P : W.toAffine.Point) = _
+  rw [hP, specialise_some_of_nonneg W hW hΔ' h hx]
+
+end
+end S_ModularCurve_B3_exists_torsionBy_reduction_addEquiv
+end P2MW
+export P2MW.S_ModularCurve_B3_exists_torsionBy_reduction_addEquiv (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve.TatePoint
+open scoped Classical
+theorem ModularCurve.B3.exists_torsionBy_reduction_addEquiv (W : WeierstrassCurve H)
+    [W.IsElliptic] (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0)
+    [(specialFibre W).IsElliptic] (p : ℕ) [Fact p.Prime] :
+    ∃ e : Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ) ≃+
+        Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ),
+      ∀ (P : Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ)) (x y : H)
+        (h : W.toAffine.Nonsingular x y),
+        (P : W.toAffine.Point) = WeierstrassCurve.Affine.Point.some x y h →
+          ∃ h₀ : (specialFibre W).toAffine.Nonsingular (x.coeff 0) (y.coeff 0),
+            ((e P : Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ)) :
+                (specialFibre W).toAffine.Point) =
+              WeierstrassCurve.Affine.Point.some (x.coeff 0) (y.coeff 0) h₀ :=
+  solution W hW hΔ p
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_exists_variableChange_specialFibre_goodModel.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_exists_variableChange_specialFibre_goodModel.lean
new file mode 100644
index 0000000000..44422ae901
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_exists_variableChange_specialFibre_goodModel.lean
@@ -0,0 +1,2912 @@
+/-
+Based on Prove2Me node ModularCurve.B3.exists_variableChange_specialFibre_goodModel
+(e52cc5c7-a321-5dde-8043-e54162cec3f8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 66d3c9b6-f693-5048-854f-239747ecdf14
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_SpecialisationVocab
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_TatePoint
+
+import Mathlib.Algebra.Category.Grp.Injective
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EMD
+import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_Monodromy
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VariableChangePointEquiv
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_vcInvFun_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsionBy_eq_sq_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_isAlgClosed_rat
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_zsmul_some_eq_some_div
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_evalEval_psi_sq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a4_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a6_eq_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Special fibre of the good model is ofJ j₀ up to coordinate change
+
+Theorem statement: `ModularCurve.B3.exists_variableChange_specialFibre_goodModel`
+(`e52cc5c7-a321-5dde-8043-e54162cec3f8`), by Claude, 2026-09-05.
+
+Proof: submission `66d3c9b6-f693-5048-854f-239747ecdf14`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\bar{\mathbb Q}$ denote `Qbar`, the algebraic closure of $\mathbb Q$, and let $j_0 \in
+\bar{\mathbb Q}$ be arbitrary (no hypothesis on $j_0$ is imposed; in particular the values $0$ and
+$1728$ are allowed). Over the coefficient field $H$ one forms `nearCurve j₀`, which is Mathlib's
+standard Weierstrass model `WeierstrassCurve.ofJ` evaluated at `jNear j₀`, and then `goodModel j₀`,
+the translate of `nearCurve j₀` by the admissible change of coordinates `scaleVC j₀`; the latter is
+the identity change unless $j_0 = 0$, in which case it is $\bigl(u,r,s,t\bigr) =
+\bigl(\mathrm{sU}(2/12),\,-(\mathrm{jNear}\,0 - 1728)^2/12,\,-(\mathrm{jNear}\,0 -
+1728)/2,\,(\mathrm{jNear}\,0-1728)^3/24\bigr)$, or $j_0 = 1728$, in which case it is
+$\bigl(\mathrm{sU}(9/12),0,0,0\bigr)$. The Weierstrass curve `specialFibre (goodModel j₀)` over
+$\bar{\mathbb Q}$ is the one whose five coefficients $a_1,a_2,a_3,a_4,a_6$ are the index-$0$
+coefficients of the corresponding coefficients of `goodModel j₀`. The assertion is that there exists
+a change of coordinates $C \in$ `VariableChange Qbar` whose action on this special fibre gives
+exactly `WeierstrassCurve.ofJ j₀`, the standard Weierstrass curve over $\bar{\mathbb Q}$ with
+$j$-invariant $j_0$. No uniqueness of $C$ is claimed, and no ellipticity or nonsingularity statement
+is part of the conclusion.
+
+This records that the special fibre of the chosen integral model at $j_0$ is, after an admissible
+change of coordinates over the algebraically closed residue field, the standard model with
+$j$-invariant $j_0$ — an instance of the classical fact that two elliptic curves over a separably
+closed field with the same $j$-invariant are isomorphic. It is the normalisation used when comparing
+torsion on the generic fibre with torsion on the special fibre, where the residual ambiguity of $C$
+by the automorphism group of `WeierstrassCurve.ofJ j₀` is what an equivariance statement must
+control.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_B3_exists_variableChange_specialFibre_goodModel.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_B3_exists_variableChange_specialFibre_goodModel
+
+open scoped Classical
+
+noncomputable section
+
+p2m_open "ModularCurve \
+  P2MW.S_ModularCurve_B3_exists_variableChange_specialFibre_goodModel.ModularCurve \
+  WeierstrassCurve Polynomial"
+
+namespace HahnSeries
+p2m_export "HahnSeries" "support coeff_sub orderTop orderTop_mul algebraMap_apply' ofPowerSeries_C \
+  C_apply coeff_sum leadingCoeff_ne_zero orderTop_one orderTop_single_le \
+  coeff_eq_zero_of_lt_orderTop single orderTop_zero le_orderTop_iff_forall order \
+  powerSeriesAlgebra min_orderTop_le_orderTop_add coeff ofPowerSeries_X orderTop_add_eq_left \
+  order_eq_orderTop_of_ne_zero single_pow single_zero_one coeff_zero pow_add single_zero_intCast \
+  orderTop_single C map coeff_neg embDomain_notin_range orderTop_ne_top order_pow \
+  coeff_single_same ofPowerSeries_apply_coeff single_ne_zero orderTop_neg single_zero_natCast \
+  ofPowerSeries rec coeff_order_eq_zero leadingCoeff coeff_add coeff_single_of_ne \
+  ofPowerSeries_apply orderTop_le_of_coeff_ne_zero coeff_single single_mul_single \
+  coeff_mul_order_add_order order_mul_of_ne_zero hahnTwist coeff_hahnTwist hahnTwist_single \
+  order_hahnTwist MonoChar mem_monoChar_iff hahnTwistHom hahnTwistHom_apply monodromy \
+  fixes_single_one_of_mem_monodromy isAlgClosed_rat"
+p2m_open "HahnSeries"
+
+namespace ExtChar
+
+variable (K : Type*) [Field K] [IsAlgClosed K]
+
+@[reducible] def divisibleByIntAdditiveUnits : DivisibleBy (Additive Kˣ) ℤ :=
+  divisibleByOfSMulRightSurj (Additive Kˣ) ℤ fun {n} hn a => by
+    obtain ⟨k, rfl | rfl⟩ := Int.eq_nat_or_neg n
+    · have hk : 0 < k := by omega
+      obtain ⟨y, hy⟩ := IsAlgClosed.exists_pow_nat_eq ((a.toMul : Kˣ) : K) hk
+      have hy0 : y ≠ 0 := fun h => (a.toMul).ne_zero (by rw [← hy, h, zero_pow hk.ne'])
+      refine ⟨Additive.ofMul (Units.mk0 y hy0), ?_⟩
+      apply Additive.toMul.injective
+      rw [toMul_zsmul, toMul_ofMul, zpow_natCast]
+      exact Units.ext (by rw [Units.val_pow_eq_pow_val, Units.val_mk0, hy])
+    · have hk : 0 < k := by omega
+      obtain ⟨y, hy⟩ := IsAlgClosed.exists_pow_nat_eq ((a.toMul⁻¹ : Kˣ) : K) hk
+      have hy0 : y ≠ 0 := fun h => (a.toMul⁻¹).ne_zero (by rw [← hy, h, zero_pow hk.ne'])
+      refine ⟨Additive.ofMul (Units.mk0 y hy0), ?_⟩
+      apply Additive.toMul.injective
+      rw [toMul_zsmul, toMul_ofMul, zpow_neg, zpow_natCast, ← inv_inv a.toMul]
+      exact congrArg (·⁻¹) (Units.ext (by rw [Units.val_pow_eq_pow_val, Units.val_mk0, hy]))
+
+theorem injective_additiveUnits : Module.Injective ℤ (Additive Kˣ) :=
+  letI := divisibleByIntAdditiveUnits K
+  (Module.Baer.of_divisible (Additive Kˣ)).injective
+
+variable {K}
+
+theorem exists_char_apply_eq (q : ℚ) (hq : q ≠ 0) (u : Kˣ) :
+    ∃ χ : Multiplicative ℚ →* Kˣ, χ (Multiplicative.ofAdd q) = u := by
+  let ε : ℤ ≃ₗ[ℤ] (ℤ ∙ q) := LinearEquiv.toSpanNonzeroSingleton ℤ ℚ q hq
+  let g : (ℤ ∙ q) →ₗ[ℤ] Additive Kˣ :=
+    (LinearMap.toSpanSingleton ℤ (Additive Kˣ) (Additive.ofMul u)).comp ε.symm.toLinearMap
+  have hgq : g ⟨q, Submodule.mem_span_singleton_self q⟩ = Additive.ofMul u := by
+    have h1 : ε.symm ⟨q, Submodule.mem_span_singleton_self q⟩ = 1 := by
+      rw [LinearEquiv.symm_apply_eq]
+      exact (LinearEquiv.toSpanNonzeroSingleton_one ℤ ℚ q hq).symm
+    simp only [g, LinearMap.comp_apply, LinearEquiv.coe_toLinearMap, h1,
+      LinearMap.toSpanSingleton_apply, one_smul]
+  let := divisibleByIntAdditiveUnits K
+  obtain ⟨h, hh⟩ := (Module.Baer.of_divisible (Additive Kˣ)).extension_property (ℤ ∙ q).subtype
+    (Submodule.subtype_injective _) g
+  refine ⟨{ toFun := fun a => (h a.toAdd).toMul
+            map_one' := by rw [toAdd_one, map_zero, toMul_zero]
+            map_mul' := fun a b => by rw [toAdd_mul, map_add, toMul_add] }, ?_⟩
+  change (h (Multiplicative.ofAdd q).toAdd).toMul = u
+  rw [toAdd_ofAdd]
+  have := LinearMap.congr_fun hh ⟨q, Submodule.mem_span_singleton_self q⟩
+  rw [LinearMap.comp_apply, Submodule.subtype_apply] at this
+  rw [this, hgq, toMul_ofMul]
+
+end ExtChar
+
+private theorem exists_mem_monodromy_single_eq (K : Type*) [Field K] [IsAlgClosed K] (e : ℕ)
+    (he : 0 < e)
+    (ζ : K) (hζ : ζ ^ e = 1) :
+    ∃ m ∈ monodromy K,
+      (m : HahnSeries ℚ K ≃ₐ[K] HahnSeries ℚ K) (single ((e : ℚ)⁻¹) (1 : K)) =
+        single ((e : ℚ)⁻¹) ζ := by
+  have hζ0 : ζ ≠ 0 := by
+    rintro rfl
+    rw [zero_pow he.ne'] at hζ
+    exact zero_ne_one hζ
+  have hq : ((e : ℚ)⁻¹) ≠ 0 := inv_ne_zero (by exact_mod_cast he.ne')
+  obtain ⟨χ, hχ⟩ := ExtChar.exists_char_apply_eq ((e : ℚ)⁻¹) hq (Units.mk0 ζ hζ0)
+  have hone : Multiplicative.ofAdd (1 : ℚ) = Multiplicative.ofAdd ((e : ℚ)⁻¹) ^ e := by
+    rw [← ofAdd_nsmul, nsmul_eq_mul, mul_inv_cancel₀ (by exact_mod_cast he.ne' : (e : ℚ) ≠ 0)]
+  have hmem : χ ∈ MonoChar K := by
+    rw [mem_monoChar_iff, hone, map_pow, hχ]
+    exact Units.ext (by rw [Units.val_pow_eq_pow_val, Units.val_mk0, hζ, Units.val_one])
+  refine ⟨hahnTwistHom χ, Subgroup.mem_map_of_mem _ hmem, ?_⟩
+  rw [hahnTwistHom_apply, hahnTwist_single, hχ, Units.val_mk0, mul_one]
+
+end HahnSeries
+
+namespace ModularCurve
+p2m_export "ModularCurve" "CycSub SameOrbit"
+namespace B3
+p2m_export "ModularCurve.B3" "coeff_zero_mul_of_integral orderTop_pow_nonneg integralO \
+  mem_integralO resO resO_apply IntegralCoeffs specialFibre val_inv_sU scaleVC goodModel \
+  scaleVC_zero scaleVC_1728 scaleVC_of_ne goodModel_eq_nearCurve"
+p2m_open "ModularCurve.B3 ModularCurve"
+
+open ModularCurve.TatePoint
+
+private theorem orderTop_nonneg_of_isRoot (P : Polynomial H)
+    (hP : ∀ i, 0 ≤ (P.coeff i).orderTop) (hlead : P.leadingCoeff.orderTop = 0)
+    {x : H} (hx : P.IsRoot x) : 0 ≤ x.orderTop := by
+  by_contra hneg
+  rw [not_le] at hneg
+  have hx0 : x ≠ 0 := by
+    rintro rfl
+    rw [HahnSeries.orderTop_zero] at hneg
+    exact not_top_lt hneg
+  have hxneg : x.order < 0 := by
+    rw [← HahnSeries.order_eq_orderTop_of_ne_zero hx0] at hneg
+    exact_mod_cast hneg
+  have hl0 : P.leadingCoeff ≠ 0 := by
+    intro h
+    rw [h, HahnSeries.orderTop_zero] at hlead
+    exact ne_of_gt (WithTop.coe_lt_top (0 : ℚ)) hlead
+  have hP0 : P ≠ 0 := Polynomial.leadingCoeff_ne_zero.mp hl0
+  have han : P.coeff P.natDegree ≠ 0 := by
+    rw [Polynomial.coeff_natDegree]; exact hl0
+  have hxn : (x ^ P.natDegree : H) ≠ 0 := pow_ne_zero _ hx0
+  have hordan : (P.coeff P.natDegree).order = 0 := by
+    have h : ((P.coeff P.natDegree).order : WithTop ℚ) = 0 := by
+      rw [HahnSeries.order_eq_orderTop_of_ne_zero han, Polynomial.coeff_natDegree, hlead]
+    exact_mod_cast h
+  have hordxn : (x ^ P.natDegree : H).order = P.natDegree • x.order :=
+    HahnSeries.order_pow x P.natDegree
+  have hleadterm :
+      (P.coeff P.natDegree * x ^ P.natDegree : H).coeff (P.natDegree • x.order) ≠ 0 := by
+    have key := HahnSeries.coeff_mul_order_add_order (P.coeff P.natDegree) (x ^ P.natDegree)
+    rw [hordan, hordxn, zero_add] at key
+    rw [key]
+    exact mul_ne_zero (HahnSeries.leadingCoeff_ne_zero.mpr han)
+      (HahnSeries.leadingCoeff_ne_zero.mpr hxn)
+  have hlower : ∀ i ∈ Finset.range (P.natDegree + 1), i ≠ P.natDegree →
+      (P.coeff i * x ^ i : H).coeff (P.natDegree • x.order) = 0 := by
+    intro i hi hin
+    have hilt : i < P.natDegree := lt_of_le_of_ne (Finset.mem_range_succ_iff.mp hi) hin
+    rcases eq_or_ne (P.coeff i) 0 with h0 | h0
+    · simp [h0]
+    · apply HahnSeries.coeff_eq_zero_of_lt_orderTop
+      have hxi : (x ^ i : H) ≠ 0 := pow_ne_zero _ hx0
+      have hq : P.natDegree • x.order < i • x.order := by
+        rw [nsmul_eq_mul, nsmul_eq_mul]
+        exact mul_lt_mul_of_neg_right (by exact_mod_cast hilt) hxneg
+      have h2 : ((i • x.order : ℚ) : WithTop ℚ) ≤ (P.coeff i * x ^ i : H).orderTop := by
+        rw [HahnSeries.orderTop_mul]
+        calc ((i • x.order : ℚ) : WithTop ℚ)
+            = 0 + ((i • x.order : ℚ) : WithTop ℚ) := (zero_add _).symm
+          _ ≤ (P.coeff i).orderTop + (x ^ i : H).orderTop := by
+              refine add_le_add (hP i) ?_
+              rw [← HahnSeries.order_eq_orderTop_of_ne_zero hxi, HahnSeries.order_pow]
+      exact lt_of_lt_of_le (WithTop.coe_lt_coe.mpr hq) h2
+  have heval : (P.eval x).coeff (P.natDegree • x.order) ≠ 0 := by
+    rw [Polynomial.eval_eq_sum_range, HahnSeries.coeff_sum,
+      Finset.sum_eq_single_of_mem P.natDegree (Finset.self_mem_range_succ P.natDegree) hlower]
+    exact hleadterm
+  rw [show P.eval x = 0 from hx] at heval
+  simp only [HahnSeries.coeff_zero] at heval
+  exact heval rfl
+
+scoped instance instCharZeroH : CharZero H :=
+  charZero_of_injective_algebraMap (algebraMap Qbar H).injective
+
+local notation "ι" => (HahnSeries.ofPowerSeries ℚ Qbar)
+
+theorem coeff_zero_ofPowerSeries (f : PowerSeries Qbar) :
+    (ι f).coeff 0 = PowerSeries.constantCoeff f := by
+  have h := HahnSeries.ofPowerSeries_apply_coeff (Γ := ℚ) f 0
+  rw [Nat.cast_zero] at h
+  rw [h, PowerSeries.coeff_zero_eq_constantCoeff_apply]
+
+theorem coeff_ofPowerSeries_of_neg (f : PowerSeries Qbar) {q : ℚ} (hq : q < 0) :
+    (ι f).coeff q = 0 := by
+  rw [HahnSeries.ofPowerSeries_apply, HahnSeries.embDomain_of_notMem_range]
+  rintro ⟨n, hn⟩
+  exact (not_le.mpr hq) (le_of_le_of_eq (Nat.cast_nonneg n) hn)
+
+theorem orderTop_ofPowerSeries_nonneg (f : PowerSeries Qbar) : 0 ≤ (ι f).orderTop :=
+  HahnSeries.le_orderTop_iff_forall.mpr fun _ hq =>
+    coeff_ofPowerSeries_of_neg f (WithTop.coe_lt_zero.mp hq)
+
+theorem orderTop_single_mul_ofPowerSeries (q : ℚ) (f : PowerSeries Qbar) :
+    (q : WithTop ℚ) ≤ (HahnSeries.single q (1 : Qbar) * ι f).orderTop := by
+  rw [HahnSeries.orderTop_mul, HahnSeries.orderTop_single one_ne_zero]
+  exact le_add_of_nonneg_right (orderTop_ofPowerSeries_nonneg f)
+
+theorem coeff_zero_single_mul_ofPowerSeries {q : ℚ} (hq : 0 < q) (f : PowerSeries Qbar) :
+    (HahnSeries.single q (1 : Qbar) * ι f).coeff 0 = 0 :=
+  HahnSeries.coeff_eq_zero_of_lt_orderTop
+    (lt_of_lt_of_le (WithTop.coe_pos.mpr hq) (orderTop_single_mul_ofPowerSeries q f))
+
+theorem map_ofJNe0Or1728 {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S) (j : R) :
+    (WeierstrassCurve.ofJNe0Or1728 j).map f = WeierstrassCurve.ofJNe0Or1728 (f j) := by
+  simp only [WeierstrassCurve.ofJNe0Or1728, WeierstrassCurve.map, map_sub, map_ofNat, map_zero,
+    map_mul, map_neg, map_pow]
+
+theorem specialFibre_map_ofPowerSeries (W : WeierstrassCurve (PowerSeries Qbar)) :
+    specialFibre (W.map ι) = W.map PowerSeries.constantCoeff := by
+  simp only [specialFibre, WeierstrassCurve.map, coeff_zero_ofPowerSeries]
+
+theorem integralCoeffs_map_ofPowerSeries (W : WeierstrassCurve (PowerSeries Qbar)) :
+    IntegralCoeffs (W.map ι) := by
+  unfold IntegralCoeffs
+  exact ⟨orderTop_ofPowerSeries_nonneg _, orderTop_ofPowerSeries_nonneg _,
+    orderTop_ofPowerSeries_nonneg _, orderTop_ofPowerSeries_nonneg _,
+    orderTop_ofPowerSeries_nonneg _⟩
+
+theorem orderTop_pow_eq_nsmul (x : H) (n : ℕ) : (x ^ n).orderTop = n • x.orderTop := by
+  induction n with
+  | zero => rw [pow_zero, HahnSeries.orderTop_one, zero_nsmul]
+  | succ n ih => rw [pow_succ, HahnSeries.orderTop_mul, ih, succ_nsmul]
+
+theorem coeff_one_jNear (j₀ : Qbar) : (jNear j₀).coeff 1 = 1 := by
+  simp [jNear]
+
+private theorem jNear_ne_zero (j₀ : Qbar) : jNear j₀ ≠ 0 := fun h => by
+  simpa [h] using coeff_one_jNear j₀
+
+private theorem jNear_ne_1728 (j₀ : Qbar) : jNear j₀ ≠ 1728 := fun h => by
+  have h1 := coeff_one_jNear j₀
+  have h2 : (1728 : H) = HahnSeries.C (1728 : Qbar) := (map_ofNat _ _).symm
+  rw [h, h2, HahnSeries.C_apply, HahnSeries.coeff_single_of_ne one_ne_zero] at h1
+  exact zero_ne_one h1
+
+private theorem nearCurve_eq_ofJNe0Or1728 (j₀ : Qbar) :
+    nearCurve j₀ = WeierstrassCurve.ofJNe0Or1728 (jNear j₀) :=
+  WeierstrassCurve.ofJ_ne_0_ne_1728 (jNear j₀) (jNear_ne_zero j₀) (jNear_ne_1728 j₀)
+
+theorem jNear_zero : jNear 0 = HahnSeries.single 1 1 := by
+  simp only [jNear, map_zero, zero_add]
+
+theorem jNear_sub_ofNat (j₀ : Qbar) : jNear j₀ - 1728 = jNear (j₀ - 1728) := by
+  simp only [jNear, map_sub, map_ofNat]; ring
+
+theorem orderTop_jNear_of_ne {j₀ : Qbar} (h : j₀ ≠ 0) : (jNear j₀).orderTop = 0 := by
+  have h1 : (HahnSeries.C j₀ : H).orderTop = (0 : ℚ) := by
+    rw [HahnSeries.C_apply, HahnSeries.orderTop_single h]
+  have h2 : (HahnSeries.single (1 : ℚ) (1 : Qbar)).orderTop = (1 : ℚ) :=
+    HahnSeries.orderTop_single one_ne_zero
+  rw [jNear, HahnSeries.orderTop_add_eq_left
+      (by rw [h1, h2]; exact WithTop.coe_lt_coe.mpr zero_lt_one), h1, WithTop.coe_zero]
+
+theorem orderTop_jNear_zero : (jNear 0).orderTop = (1 : ℚ) := by
+  rw [jNear_zero, HahnSeries.orderTop_single one_ne_zero]
+
+theorem nearCurve_eq_map (j₀ : Qbar) :
+    nearCurve j₀ =
+      (WeierstrassCurve.ofJNe0Or1728 (PowerSeries.C j₀ + PowerSeries.X)).map ι := by
+  rw [map_ofJNe0Or1728, map_add, HahnSeries.ofPowerSeries_C, HahnSeries.ofPowerSeries_X,
+    nearCurve_eq_ofJNe0Or1728, jNear]
+
+theorem integralCoeffs_nearCurve (j₀ : Qbar) : IntegralCoeffs (nearCurve j₀) := by
+  rw [nearCurve_eq_map]; exact integralCoeffs_map_ofPowerSeries _
+
+theorem specialFibre_nearCurve (j₀ : Qbar) :
+    specialFibre (nearCurve j₀) = WeierstrassCurve.ofJNe0Or1728 j₀ := by
+  rw [nearCurve_eq_map, specialFibre_map_ofPowerSeries, map_ofJNe0Or1728, map_add,
+    PowerSeries.constantCoeff_C, PowerSeries.constantCoeff_X, add_zero]
+
+theorem nearCurve_Δ (j₀ : Qbar) :
+    (nearCurve j₀).Δ = jNear j₀ ^ 2 * jNear (j₀ - 1728) ^ 9 := by
+  rw [nearCurve_eq_ofJNe0Or1728, WeierstrassCurve.ofJNe0Or1728_Δ, jNear_sub_ofNat]
+
+private theorem nearCurve_delta_orderTop_generic (j₀ : Qbar) (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) :
+    (nearCurve j₀).Δ.orderTop = 0 := by
+  rw [nearCurve_Δ, HahnSeries.orderTop_mul, orderTop_pow_eq_nsmul, orderTop_pow_eq_nsmul,
+    orderTop_jNear_of_ne h0, orderTop_jNear_of_ne (sub_ne_zero.mpr h1728), nsmul_zero,
+    nsmul_zero, add_zero]
+
+private theorem nearCurve_delta_orderTop_zero : (nearCurve 0).Δ.orderTop = (2 : ℚ) := by
+  rw [nearCurve_Δ, HahnSeries.orderTop_mul, orderTop_pow_eq_nsmul, orderTop_pow_eq_nsmul,
+    orderTop_jNear_zero, zero_sub,
+    orderTop_jNear_of_ne (neg_ne_zero.mpr (by norm_num : (1728 : Qbar) ≠ 0)), nsmul_zero,
+    add_zero, ← WithTop.coe_nsmul]
+  norm_num
+
+private theorem nearCurve_delta_orderTop_1728 : (nearCurve 1728).Δ.orderTop = (9 : ℚ) := by
+  rw [nearCurve_Δ, HahnSeries.orderTop_mul, orderTop_pow_eq_nsmul, orderTop_pow_eq_nsmul,
+    orderTop_jNear_of_ne (by norm_num : (1728 : Qbar) ≠ 0), sub_self, orderTop_jNear_zero,
+    nsmul_zero, zero_add, ← WithTop.coe_nsmul]
+  norm_num
+
+theorem specialFibre_nearCurve_generic (j₀ : Qbar) (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) :
+    specialFibre (nearCurve j₀) = WeierstrassCurve.ofJ j₀ := by
+  rw [specialFibre_nearCurve, WeierstrassCurve.ofJ_ne_0_ne_1728 j₀ h0 h1728]
+
+theorem goodModel_1728_eq : goodModel 1728 =
+    ⟨HahnSeries.single (1 / 4 : ℚ) 1, 0, 0, HahnSeries.C (-36),
+      -HahnSeries.single (1 / 2 : ℚ) 1⟩ := by
+  have hA : jNear 1728 - 1728 = HahnSeries.single 1 1 := by
+    rw [jNear_sub_ofNat, sub_self, jNear_zero]
+  have h1 : HahnSeries.single (-(9 / 12 : ℚ)) (1 : Qbar) * HahnSeries.single 1 1 =
+      HahnSeries.single (1 / 4 : ℚ) 1 := by
+    rw [HahnSeries.single_mul_single, mul_one]; congr 1; norm_num
+  have h4 : HahnSeries.single (-(9 / 12 : ℚ)) (1 : Qbar) ^ 4 * HahnSeries.single 1 1 ^ 3 = 1 := by
+    rw [HahnSeries.single_pow, HahnSeries.single_pow, HahnSeries.single_mul_single,
+      ← HahnSeries.single_zero_one]
+    congr 1 <;> norm_num
+  have h6 : HahnSeries.single (-(9 / 12 : ℚ)) (1 : Qbar) ^ 6 * HahnSeries.single 1 1 ^ 5 =
+      HahnSeries.single (1 / 2 : ℚ) 1 := by
+    rw [HahnSeries.single_pow, HahnSeries.single_pow, HahnSeries.single_mul_single]
+    congr 1 <;> norm_num
+  rw [goodModel, scaleVC_1728, nearCurve_eq_ofJNe0Or1728, variableChange_def]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU]
+    linear_combination h1
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU]
+    ring
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU]
+    ring
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU, map_neg, map_ofNat]
+    linear_combination (-36 : H) * h4
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU]
+    linear_combination (-1 : H) * h6
+
+theorem goodModel_zero_eq : goodModel 0 =
+    ⟨0, 0, 0,
+      HahnSeries.single (1 / 3 : ℚ) 1 *
+        ι (PowerSeries.C (-1 / 48 : Qbar) * (PowerSeries.X - PowerSeries.C 1728) ^ 3),
+      ι (PowerSeries.C (1 / 864 : Qbar) * (PowerSeries.X - PowerSeries.C 1728) ^ 5)⟩ := by
+  have hA : jNear 0 - 1728 = HahnSeries.single 1 1 - 1728 := by rw [jNear_zero]
+  have h4 : HahnSeries.single (-(2 / 12 : ℚ)) (1 : Qbar) ^ 4 * HahnSeries.single 1 1 =
+      HahnSeries.single (1 / 3 : ℚ) 1 := by
+    rw [HahnSeries.single_pow, HahnSeries.single_mul_single]; congr 1 <;> norm_num
+  have h6 : HahnSeries.single (-(2 / 12 : ℚ)) (1 : Qbar) ^ 6 * HahnSeries.single 1 1 = 1 := by
+    rw [HahnSeries.single_pow, HahnSeries.single_mul_single, ← HahnSeries.single_zero_one]
+    congr 1 <;> norm_num
+  rw [goodModel, scaleVC_zero, nearCurve_eq_ofJNe0Or1728, variableChange_def]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU]
+    ring
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU]
+    ring
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU]
+    ring
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU, map_mul, map_pow, map_sub, map_neg,
+      map_div₀, map_one, map_ofNat, HahnSeries.ofPowerSeries_C, HahnSeries.ofPowerSeries_X]
+    linear_combination (-1 / 48 : H) * (HahnSeries.single (1 : ℚ) (1 : Qbar) - 1728) ^ 3 * h4
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU, map_mul, map_pow, map_sub,
+      map_div₀, map_one, map_ofNat, HahnSeries.ofPowerSeries_C, HahnSeries.ofPowerSeries_X]
+    linear_combination (1 / 864 : H) * (HahnSeries.single (1 : ℚ) (1 : Qbar) - 1728) ^ 5 * h6
+
+theorem specialFibre_goodModel_1728 : specialFibre (goodModel 1728) = ⟨0, 0, 0, -36, 0⟩ := by
+  rw [goodModel_1728_eq]
+  simp only [specialFibre, HahnSeries.coeff_zero, HahnSeries.coeff_neg, HahnSeries.C_apply,
+    HahnSeries.coeff_single]
+  norm_num
+
+theorem specialFibre_goodModel_zero :
+    specialFibre (goodModel 0) = ⟨0, 0, 0, 0, -(2 * 1728 ^ 4)⟩ := by
+  rw [goodModel_zero_eq]
+  simp only [specialFibre, HahnSeries.coeff_zero, coeff_zero_ofPowerSeries,
+    coeff_zero_single_mul_ofPowerSeries (by norm_num : (0 : ℚ) < 1 / 3)]
+  simp only [map_mul, map_pow, map_sub, PowerSeries.constantCoeff_C, PowerSeries.constantCoeff_X]
+  norm_num
+
+private theorem goodModel_zero_spec :
+    IntegralCoeffs (goodModel 0) ∧ (goodModel 0).Δ.orderTop = 0 ∧
+      ∃ _ : (specialFibre (goodModel 0)).IsElliptic, (specialFibre (goodModel 0)).j = 0 := by
+  refine ⟨?_, ?_, ?_⟩
+  · rw [goodModel_zero_eq]
+    unfold IntegralCoeffs
+    refine ⟨by simp, by simp, by simp, ?_, orderTop_ofPowerSeries_nonneg _⟩
+    exact le_trans (WithTop.coe_nonneg.mpr (by norm_num)) (orderTop_single_mul_ofPowerSeries _ _)
+  · rw [goodModel, scaleVC_zero, variableChange_Δ, HahnSeries.orderTop_mul,
+      nearCurve_delta_orderTop_zero]
+    simp only [val_inv_sU, HahnSeries.single_pow, one_pow]
+    rw [HahnSeries.orderTop_single one_ne_zero, ← WithTop.coe_add, WithTop.coe_eq_zero]
+    norm_num
+  · rw [specialFibre_goodModel_zero]
+    have hE : (⟨0, 0, 0, 0, -(2 * 1728 ^ 4)⟩ : WeierstrassCurve Qbar).IsElliptic := by
+      rw [WeierstrassCurve.isElliptic_iff, isUnit_iff_ne_zero]
+      simp only [WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄,
+        WeierstrassCurve.b₆, WeierstrassCurve.b₈]
+      norm_num
+    refine ⟨hE, WeierstrassCurve.j_eq_zero _ ?_⟩
+    simp only [WeierstrassCurve.c₄, WeierstrassCurve.b₂, WeierstrassCurve.b₄]
+    norm_num
+
+private theorem goodModel_1728_spec :
+    IntegralCoeffs (goodModel 1728) ∧ (goodModel 1728).Δ.orderTop = 0 ∧
+      ∃ _ : (specialFibre (goodModel 1728)).IsElliptic,
+        (specialFibre (goodModel 1728)).j = 1728 := by
+  refine ⟨?_, ?_, ?_⟩
+  · rw [goodModel_1728_eq]
+    unfold IntegralCoeffs
+    refine ⟨le_trans (WithTop.coe_nonneg.mpr (by norm_num)) HahnSeries.orderTop_single_le,
+      by simp, by simp, ?_, ?_⟩
+    · rw [HahnSeries.C_apply]; exact HahnSeries.orderTop_single_le
+    · rw [HahnSeries.orderTop_neg]
+      exact le_trans (WithTop.coe_nonneg.mpr (by norm_num)) HahnSeries.orderTop_single_le
+  · rw [goodModel, scaleVC_1728, variableChange_Δ, HahnSeries.orderTop_mul,
+      nearCurve_delta_orderTop_1728]
+    simp only [val_inv_sU, HahnSeries.single_pow, one_pow]
+    rw [HahnSeries.orderTop_single one_ne_zero, ← WithTop.coe_add, WithTop.coe_eq_zero]
+    norm_num
+  · rw [specialFibre_goodModel_1728]
+    have hE : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).IsElliptic := by
+      rw [WeierstrassCurve.isElliptic_iff, isUnit_iff_ne_zero]
+      simp only [WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄,
+        WeierstrassCurve.b₆, WeierstrassCurve.b₈]
+      norm_num
+    refine ⟨hE, ?_⟩
+    rw [WeierstrassCurve.j, Units.inv_mul_eq_iff_eq_mul, WeierstrassCurve.coe_Δ']
+    simp only [WeierstrassCurve.c₄, WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄,
+      WeierstrassCurve.b₆, WeierstrassCurve.b₈]
+    norm_num
+
+private theorem goodModel_generic_spec (j₀ : Qbar) (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) :
+    IntegralCoeffs (goodModel j₀) ∧ (goodModel j₀).Δ.orderTop = 0 ∧
+      specialFibre (goodModel j₀) = WeierstrassCurve.ofJ j₀ := by
+  rw [goodModel_eq_nearCurve h0 h1728]
+  exact ⟨integralCoeffs_nearCurve j₀, nearCurve_delta_orderTop_generic j₀ h0 h1728,
+    specialFibre_nearCurve_generic j₀ h0 h1728⟩
+
+open WeierstrassCurve in
+theorem eval_ΨSq_eq_zero_of_nsmul_some_eq_zero {F : Type*} [Field F] [DecidableEq F]
+    (W : WeierstrassCurve F) {x y : F} (h : W.toAffine.Nonsingular x y)
+    {d : ℕ} (htor : d • (Affine.Point.some x y h : W.toAffine.Point) = 0) :
+    (W.ΨSq d).eval x = 0 := by
+  by_contra hne
+  have hψ : (W.ψ (d : ℤ)).evalEval x y ≠ 0 := fun h0 => hne <| by
+    rw [← WeierstrassCurve.Affine.evalEval_psi_sq W h.1 (d : ℤ), h0, zero_pow two_ne_zero]
+  obtain ⟨y', h', heq⟩ := WeierstrassCurve.Affine.Point.zsmul_some_eq_some_div W h hψ
+  rw [natCast_zsmul, htor] at heq
+  exact (WeierstrassCurve.Affine.Point.some_ne_zero h') heq.symm
+
+open WeierstrassCurve in
+theorem eval_preΨ'_eq_zero_or_eval_Ψ₂Sq_eq_zero_of_nsmul_some_eq_zero
+    {F : Type*} [Field F] [DecidableEq F]
+    (W : WeierstrassCurve F) {x y : F} (h : W.toAffine.Nonsingular x y)
+    {d : ℕ} (htor : d • (Affine.Point.some x y h : W.toAffine.Point) = 0) :
+    (W.preΨ' d).eval x = 0 ∨ W.Ψ₂Sq.eval x = 0 := by
+  have := eval_ΨSq_eq_zero_of_nsmul_some_eq_zero W h htor
+  rw [WeierstrassCurve.ΨSq_ofNat, Polynomial.eval_mul, Polynomial.eval_pow,
+    mul_eq_zero, pow_eq_zero_iff two_ne_zero] at this
+  refine this.imp_right (fun h => ?_)
+  split_ifs at h with heven
+  · simpa using h
+  · simp at h
+
+theorem orderTop_intCast {n : ℤ} (hn : n ≠ 0) : (n : H).orderTop = 0 := by
+  rw [← HahnSeries.single_zero_intCast]
+  exact HahnSeries.orderTop_single (Int.cast_ne_zero.mpr hn)
+
+theorem orderTop_leadingCoeff_ΨSq_eq_zero (W : WeierstrassCurve H) {n : ℤ} (hn : (n : H) ≠ 0) :
+    (W.ΨSq n).leadingCoeff.orderTop = 0 := by
+  have hn' : n ≠ 0 := fun h0 => hn (by rw [h0]; exact Int.cast_zero)
+  rw [W.leadingCoeff_ΨSq hn, sq, HahnSeries.orderTop_mul, orderTop_intCast hn', add_zero]
+
+def liftToIntegralO (W : WeierstrassCurve H) (hW : IntegralCoeffs W) :
+    WeierstrassCurve integralO :=
+  ⟨⟨W.a₁, mem_integralO.mpr hW.1⟩,
+   ⟨W.a₂, mem_integralO.mpr hW.2.1⟩,
+   ⟨W.a₃, mem_integralO.mpr hW.2.2.1⟩,
+   ⟨W.a₄, mem_integralO.mpr hW.2.2.2.1⟩,
+   ⟨W.a₆, mem_integralO.mpr hW.2.2.2.2⟩⟩
+
+theorem map_liftToIntegralO (W : WeierstrassCurve H) (hW : IntegralCoeffs W) :
+    (liftToIntegralO W hW).map integralO.subtype = W := by
+  rfl
+
+theorem map_liftToIntegralO_resO (W : WeierstrassCurve H) (hW : IntegralCoeffs W) :
+    (liftToIntegralO W hW).map resO = specialFibre W := by
+  rfl
+
+theorem orderTop_coeff_ΨSq_nonneg (W : WeierstrassCurve H) (hW : IntegralCoeffs W) (n : ℤ)
+    (k : ℕ) : 0 ≤ ((W.ΨSq n).coeff k).orderTop := by
+  rw [← map_liftToIntegralO W hW, WeierstrassCurve.map_ΨSq, Polynomial.coeff_map]
+  exact mem_integralO.mp (((liftToIntegralO W hW).ΨSq n).coeff k).property
+
+theorem natCast_H_ne_zero {n : ℕ} (hn : n ≠ 0) : (n : H) ≠ 0 := by
+  rw [← HahnSeries.single_zero_natCast]
+  exact HahnSeries.single_ne_zero (Nat.cast_ne_zero.mpr hn)
+
+private theorem torsion_coords_integral (W : WeierstrassCurve H) [W.IsElliptic]
+    (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0) {x y : H}
+    (h : W.toAffine.Nonsingular x y) {n : ℕ} (hn : n ≠ 0)
+    (htor : n • (WeierstrassCurve.Affine.Point.some x y h : W.toAffine.Point) = 0) :
+    0 ≤ x.orderTop ∧ 0 ≤ y.orderTop := by
+  have _ := hΔ
+  have hnH : ((n : ℤ) : H) ≠ 0 := by exact_mod_cast natCast_H_ne_zero hn
+  have hroot_x : (W.ΨSq (n : ℤ)).IsRoot x := by
+    rw [Polynomial.IsRoot]
+    exact_mod_cast eval_ΨSq_eq_zero_of_nsmul_some_eq_zero W h htor
+  have hx : 0 ≤ x.orderTop :=
+    orderTop_nonneg_of_isRoot (W.ΨSq (n : ℤ))
+      (orderTop_coeff_ΨSq_nonneg W hW (n : ℤ))
+      (orderTop_leadingCoeff_ΨSq_eq_zero W hnH)
+      hroot_x
+  refine ⟨hx, ?_⟩
+  let Q : Polynomial H := W.toAffine.polynomial.map (Polynomial.evalRingHom x)
+  have hQmonic : Q.Monic := W.toAffine.monic_polynomial.map _
+  have hQroot : Q.IsRoot y := by
+    rw [show Q.IsRoot y ↔ Q.eval y = 0 from Iff.rfl, Polynomial.map_evalRingHom_eval]
+    exact h.1
+  have hQlead : Q.leadingCoeff.orderTop = 0 := by
+    rw [hQmonic.leadingCoeff]; exact HahnSeries.orderTop_one
+  have hQcoeff : ∀ i, 0 ≤ (Q.coeff i).orderTop := by
+    intro i
+    let x' : integralO := ⟨x, mem_integralO.mpr hx⟩
+    have hx'val : integralO.subtype x' = x := rfl
+    have key : Q.coeff i =
+        integralO.subtype
+          (((liftToIntegralO W hW).toAffine.polynomial.map (Polynomial.evalRingHom x')).coeff i)
+            := by
+      simp only [Q, Polynomial.coeff_map, Polynomial.coe_evalRingHom]
+      rw [← Polynomial.eval₂_hom (f := integralO.subtype), ← Polynomial.eval_map]
+      congr 1
+      rw [← Polynomial.coe_mapRingHom, ← Polynomial.coeff_map,
+        ← WeierstrassCurve.Affine.map_polynomial]
+      rfl
+    rw [key]
+    exact mem_integralO.mp
+      (((liftToIntegralO W hW).toAffine.polynomial.map (Polynomial.evalRingHom x')).coeff
+        i).property
+  exact orderTop_nonneg_of_isRoot Q hQcoeff hQlead hQroot
+
+section E3
+
+theorem orderTop_mul_nonneg {u v : H} (hu : 0 ≤ u.orderTop) (hv : 0 ≤ v.orderTop) :
+    0 ≤ (u * v).orderTop := by
+  rw [HahnSeries.orderTop_mul]; exact add_nonneg hu hv
+
+theorem orderTop_add_nonneg {u v : H} (hu : 0 ≤ u.orderTop) (hv : 0 ≤ v.orderTop) :
+    0 ≤ (u + v).orderTop :=
+  le_trans (le_min hu hv) HahnSeries.min_orderTop_le_orderTop_add
+
+theorem orderTop_neg_nonneg {u : H} (hu : 0 ≤ u.orderTop) : 0 ≤ (-u).orderTop := by
+  rw [HahnSeries.orderTop_neg]; exact hu
+
+theorem orderTop_sub_nonneg {u v : H} (hu : 0 ≤ u.orderTop) (hv : 0 ≤ v.orderTop) :
+    0 ≤ (u - v).orderTop := by
+  rw [sub_eq_add_neg]; exact orderTop_add_nonneg hu (orderTop_neg_nonneg hv)
+
+theorem order_div (u v : H) (hu : u ≠ 0) (hv : v ≠ 0) :
+    (u / v).order = u.order - v.order := by
+  have huv : u / v ≠ 0 := div_ne_zero hu hv
+  have h := HahnSeries.order_mul_of_ne_zero (x := u / v) (y := v)
+    (mul_ne_zero (HahnSeries.leadingCoeff_ne_zero.mpr huv)
+      (HahnSeries.leadingCoeff_ne_zero.mpr hv))
+  rw [div_mul_cancel₀ u hv] at h
+  linarith [h]
+
+theorem order_pos_of_coeff_zero_eq_zero {u : H} (hu : u ≠ 0) (hint : 0 ≤ u.orderTop)
+    (h0 : u.coeff 0 = 0) : 0 < u.order := by
+  have hne : u.order ≠ 0 := fun h =>
+    hu (HahnSeries.coeff_order_eq_zero.mp (by rw [h]; exact h0))
+  have hge : 0 ≤ u.order := by
+    rw [← HahnSeries.order_eq_orderTop_of_ne_zero hu] at hint
+    exact_mod_cast hint
+  exact lt_of_le_of_ne hge (Ne.symm hne)
+
+theorem order_eq_zero_of_coeff_zero_ne_zero {u : H} (hint : 0 ≤ u.orderTop)
+    (h0 : u.coeff 0 ≠ 0) : u.order = 0 ∧ u ≠ 0 := by
+  have hu : u ≠ 0 := fun h => h0 (by rw [h]; exact HahnSeries.coeff_zero)
+  refine ⟨?_, hu⟩
+  have hle : u.orderTop ≤ ((0 : ℚ) : WithTop ℚ) := HahnSeries.orderTop_le_of_coeff_ne_zero h0
+  have heq : u.orderTop = 0 := le_antisymm (by exact_mod_cast hle) hint
+  have := (HahnSeries.order_eq_orderTop_of_ne_zero hu).trans heq
+  exact_mod_cast this
+
+theorem coeff_zero_div_of_unit {u v : H} (hu : 0 ≤ u.orderTop) (hv : 0 ≤ v.orderTop)
+    (hv0 : v.coeff 0 ≠ 0) :
+    0 ≤ (u / v).orderTop ∧ (u / v).coeff 0 = u.coeff 0 / v.coeff 0 := by
+  obtain ⟨hvord, hvne⟩ := order_eq_zero_of_coeff_zero_ne_zero hv hv0
+  rcases eq_or_ne u 0 with rfl | hu0
+  · simp [zero_div, HahnSeries.orderTop_zero, HahnSeries.coeff_zero]
+  · have hdiv0 : u / v ≠ 0 := div_ne_zero hu0 hvne
+    have hordu : 0 ≤ u.order := by
+      rw [← HahnSeries.order_eq_orderTop_of_ne_zero hu0] at hu
+      exact_mod_cast hu
+    have hint : 0 ≤ (u / v).orderTop := by
+      rw [← HahnSeries.order_eq_orderTop_of_ne_zero hdiv0]
+      have : (u / v).order = u.order := by rw [order_div u v hu0 hvne, hvord, sub_zero]
+      rw [this]
+      exact_mod_cast hordu
+    refine ⟨hint, ?_⟩
+    have hmul := coeff_zero_mul_of_integral hint hv
+    rw [div_mul_cancel₀ u hvne] at hmul
+    rw [hmul, mul_div_cancel_right₀ _ hv0]
+
+theorem specialFibre_Δ (W : WeierstrassCurve H) (hW : IntegralCoeffs W) :
+    (specialFibre W).Δ = W.Δ.coeff 0 := by
+  obtain ⟨h₁, h₂, h₃, h₄, h₆⟩ := hW
+  let W₀ : WeierstrassCurve integralO :=
+    ⟨⟨W.a₁, h₁⟩, ⟨W.a₂, h₂⟩, ⟨W.a₃, h₃⟩, ⟨W.a₄, h₄⟩, ⟨W.a₆, h₆⟩⟩
+  have hres : W₀.map resO = specialFibre W := rfl
+  have hsub : W₀.map integralO.subtype = W := rfl
+  have e₁ : (specialFibre W).Δ = resO W₀.Δ := by
+    rw [← hres, WeierstrassCurve.map_Δ]
+  have e₂ : ((W₀.Δ : integralO) : H) = W.Δ := by
+    conv_rhs => rw [← hsub, WeierstrassCurve.map_Δ]
+    rfl
+  rw [e₁, resO_apply, e₂]
+
+private theorem isElliptic_specialFibre (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) : (specialFibre W).IsElliptic := by
+  have hΔne : W.Δ ≠ 0 := HahnSeries.orderTop_ne_top.mp (by rw [hΔ]; simp)
+  have hord : W.Δ.order = 0 := by
+    have := (HahnSeries.order_eq_orderTop_of_ne_zero hΔne).trans hΔ
+    exact_mod_cast this
+  have hne : (specialFibre W).Δ ≠ 0 := by
+    rw [specialFibre_Δ W hW, ← hord]
+    exact fun h0 => hΔne (HahnSeries.coeff_order_eq_zero.mp h0)
+  exact ⟨isUnit_iff_ne_zero.mpr hne⟩
+
+theorem equation_specialFibre (W : WeierstrassCurve H) (hW : IntegralCoeffs W) {x y : H}
+    (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop) (h : W.toAffine.Equation x y) :
+    (specialFibre W).toAffine.Equation (x.coeff 0) (y.coeff 0) := by
+  rw [WeierstrassCurve.Affine.equation_iff] at h ⊢
+  obtain ⟨h₁, h₂, h₃, h₄, h₆⟩ := hW
+  let A₁ : integralO := ⟨W.a₁, h₁⟩
+  let A₂ : integralO := ⟨W.a₂, h₂⟩
+  let A₃ : integralO := ⟨W.a₃, h₃⟩
+  let A₄ : integralO := ⟨W.a₄, h₄⟩
+  let A₆ : integralO := ⟨W.a₆, h₆⟩
+  let X : integralO := ⟨x, hx⟩
+  let Y : integralO := ⟨y, hy⟩
+  have h₀ : Y ^ 2 + A₁ * X * Y + A₃ * Y = X ^ 3 + A₂ * X ^ 2 + A₄ * X + A₆ := by
+    apply Subtype.coe_injective
+    push_cast
+    exact h
+  have e := congrArg resO h₀
+  simp only [map_add, map_mul, map_pow, resO_apply] at e
+  exact e
+
+theorem nonsingular_specialFibre (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : W.toAffine.Nonsingular x y) :
+    (specialFibre W).toAffine.Nonsingular (x.coeff 0) (y.coeff 0) := by
+  have := isElliptic_specialFibre W hW hΔ
+  rw [← WeierstrassCurve.Affine.equation_iff_nonsingular]
+  exact equation_specialFibre W hW hx hy h.1
+
+def redPoint (W : WeierstrassCurve H) (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0) :
+    W.toAffine.Point → (specialFibre W).toAffine.Point
+  | .zero => 0
+  | .some x y h =>
+    if hxy : 0 ≤ x.orderTop ∧ 0 ≤ y.orderTop then
+      WeierstrassCurve.Affine.Point.some (x.coeff 0) (y.coeff 0)
+        (nonsingular_specialFibre W hW hΔ hxy.1 hxy.2 h)
+    else 0
+
+@[scoped simp] theorem redPoint_zero (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) : redPoint W hW hΔ 0 = 0 := rfl
+
+theorem redPoint_some (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : W.toAffine.Nonsingular x y) :
+    redPoint W hW hΔ (WeierstrassCurve.Affine.Point.some x y h) =
+      WeierstrassCurve.Affine.Point.some (x.coeff 0) (y.coeff 0)
+        (nonsingular_specialFibre W hW hΔ hx hy h) := by
+  simp only [redPoint, dite_eq_left (And.intro hx hy)]
+
+theorem redPoint_some_ne_zero (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : W.toAffine.Nonsingular x y) :
+    redPoint W hW hΔ (WeierstrassCurve.Affine.Point.some x y h) ≠ 0 := by
+  rw [redPoint_some W hW hΔ hx hy h]
+  exact WeierstrassCurve.Affine.Point.some_ne_zero _
+
+theorem redPoint_neg (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : W.toAffine.Nonsingular x y) :
+    redPoint W hW hΔ (-WeierstrassCurve.Affine.Point.some x y h) =
+      -redPoint W hW hΔ (WeierstrassCurve.Affine.Point.some x y h) := by
+  have hnegY : 0 ≤ (W.toAffine.negY x y).orderTop :=
+    orderTop_sub_nonneg (orderTop_sub_nonneg (orderTop_neg_nonneg hy)
+      (orderTop_mul_nonneg hW.1 hx)) hW.2.2.1
+  have hcoeff : (W.toAffine.negY x y).coeff 0 =
+      (specialFibre W).toAffine.negY (x.coeff 0) (y.coeff 0) := by
+    change (-y - W.a₁ * x - W.a₃).coeff 0 =
+      -(y.coeff 0) - W.a₁.coeff 0 * x.coeff 0 - W.a₃.coeff 0
+    rw [HahnSeries.coeff_sub, HahnSeries.coeff_sub, HahnSeries.coeff_neg,
+      coeff_zero_mul_of_integral hW.1 hx]
+  rw [WeierstrassCurve.Affine.Point.neg_some, redPoint_some W hW hΔ hx hnegY,
+    redPoint_some W hW hΔ hx hy, WeierstrassCurve.Affine.Point.neg_some]
+  congr 1
+
+theorem orderTop_addX_neg (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    {x₁ x₂ ℓ : H} (hx₁ : 0 ≤ x₁.orderTop) (hx₂ : 0 ≤ x₂.orderTop) (hℓ : ℓ.orderTop < 0) :
+    (W.toAffine.addX x₁ x₂ ℓ).orderTop < 0 := by
+  have hℓ0 : ℓ ≠ 0 := HahnSeries.orderTop_ne_top.mp (ne_of_lt (lt_of_lt_of_le hℓ le_top))
+  set q : ℚ := ℓ.order with hqdef
+  have hcoe : ℓ.orderTop = ((q : ℚ) : WithTop ℚ) :=
+    (HahnSeries.order_eq_orderTop_of_ne_zero hℓ0).symm
+  have hqneg : q < 0 := by rw [hcoe] at hℓ; exact_mod_cast hℓ
+  have hsq : (ℓ ^ 2).orderTop = ((q + q : ℚ) : WithTop ℚ) := by
+    rw [pow_two, HahnSeries.orderTop_mul, hcoe]
+    norm_cast
+  have hqq : ((q + q : ℚ) : WithTop ℚ) < ((q : ℚ) : WithTop ℚ) := by
+    exact_mod_cast (by linarith : q + q < q)
+  have hq0 : ((q : ℚ) : WithTop ℚ) < 0 := by exact_mod_cast hqneg
+  have hba : ((q : ℚ) : WithTop ℚ) ≤ (W.a₁ * ℓ).orderTop := by
+    rw [HahnSeries.orderTop_mul, hcoe]
+    calc ((q : ℚ) : WithTop ℚ) = 0 + ((q : ℚ) : WithTop ℚ) := (zero_add _).symm
+      _ ≤ W.a₁.orderTop + ((q : ℚ) : WithTop ℚ) := add_le_add hW.1 le_rfl
+  have step₁ : (ℓ ^ 2 + W.a₁ * ℓ).orderTop = ((q + q : ℚ) : WithTop ℚ) := by
+    rw [HahnSeries.orderTop_add_eq_left (by rw [hsq]; exact lt_of_lt_of_le hqq hba), hsq]
+  have hstep : ∀ (u v : H), u.orderTop = ((q + q : ℚ) : WithTop ℚ) → 0 ≤ v.orderTop →
+      (u - v).orderTop = ((q + q : ℚ) : WithTop ℚ) := by
+    intro u v hu hv
+    rw [sub_eq_add_neg, HahnSeries.orderTop_add_eq_left
+      (by rw [hu, HahnSeries.orderTop_neg]
+          exact lt_of_lt_of_le (lt_of_lt_of_le hqq (le_of_lt hq0)) hv), hu]
+  have step₂ := hstep _ W.a₂ step₁ hW.2.1
+  have step₃ := hstep _ x₁ step₂ hx₁
+  have step₄ := hstep _ x₂ step₃ hx₂
+  change (ℓ ^ 2 + W.a₁ * ℓ - W.a₂ - x₁ - x₂).orderTop < 0
+  rw [step₄]
+  exact lt_trans hqq hq0
+
+theorem orderTop_negY_nonneg (W : WeierstrassCurve H) (hW : IntegralCoeffs W) {x y : H}
+    (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop) : 0 ≤ (W.toAffine.negY x y).orderTop :=
+  orderTop_sub_nonneg (orderTop_sub_nonneg (orderTop_neg_nonneg hy)
+    (orderTop_mul_nonneg hW.1 hx)) hW.2.2.1
+
+theorem coeff_zero_negY (W : WeierstrassCurve H) (hW : IntegralCoeffs W) {x y : H}
+    (hx : 0 ≤ x.orderTop) :
+    (W.toAffine.negY x y).coeff 0 =
+      (specialFibre W).toAffine.negY (x.coeff 0) (y.coeff 0) := by
+  change (-y - W.a₁ * x - W.a₃).coeff 0 =
+    -(y.coeff 0) - W.a₁.coeff 0 * x.coeff 0 - W.a₃.coeff 0
+  rw [HahnSeries.coeff_sub, HahnSeries.coeff_sub, HahnSeries.coeff_neg,
+    coeff_zero_mul_of_integral hW.1 hx]
+
+theorem chord_cross_identity (W : WeierstrassCurve H) {x₁ y₁ x₂ y₂ : H}
+    (e₁ : W.toAffine.Equation x₁ y₁) (e₂ : W.toAffine.Equation x₂ y₂) :
+    (y₁ - y₂) * (y₁ + y₂ + W.a₁ * x₁ + W.a₃) =
+      (x₁ - x₂) * (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂) := by
+  rw [WeierstrassCurve.Affine.equation_iff] at e₁ e₂
+  linear_combination e₁ - e₂
+
+theorem lift_tangentNum (W : WeierstrassCurve H) (hW : IntegralCoeffs W) {x y : H}
+    (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop) :
+    0 ≤ (3 * x ^ 2 + 2 * W.a₂ * x + W.a₄ - W.a₁ * y).orderTop ∧
+      (3 * x ^ 2 + 2 * W.a₂ * x + W.a₄ - W.a₁ * y).coeff 0 =
+        3 * (x.coeff 0) ^ 2 + 2 * W.a₂.coeff 0 * x.coeff 0 + W.a₄.coeff 0
+          - W.a₁.coeff 0 * y.coeff 0 := by
+  obtain ⟨h₁, h₂, h₃, h₄, h₆⟩ := hW
+  have hval : 3 * x ^ 2 + 2 * W.a₂ * x + W.a₄ - W.a₁ * y =
+      ((3 * ⟨x, hx⟩ ^ 2 + 2 * ⟨W.a₂, h₂⟩ * ⟨x, hx⟩ + ⟨W.a₄, h₄⟩
+        - ⟨W.a₁, h₁⟩ * ⟨y, hy⟩ : integralO) : H) := by
+    push_cast
+    rfl
+  constructor
+  · rw [hval]
+    exact mem_integralO.mp (SetLike.coe_mem _)
+  · rw [hval, ← resO_apply]
+    simp only [map_sub, map_add, map_mul, map_pow, map_ofNat, resO_apply]
+
+theorem lift_chordNum (W : WeierstrassCurve H) (hW : IntegralCoeffs W) {x₁ x₂ y₂ : H}
+    (hx₁ : 0 ≤ x₁.orderTop) (hx₂ : 0 ≤ x₂.orderTop) (hy₂ : 0 ≤ y₂.orderTop) :
+    0 ≤ (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂).orderTop ∧
+      (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂).coeff 0 =
+        (x₁.coeff 0) ^ 2 + x₁.coeff 0 * x₂.coeff 0 + (x₂.coeff 0) ^ 2
+          + W.a₂.coeff 0 * (x₁.coeff 0 + x₂.coeff 0) + W.a₄.coeff 0
+          - W.a₁.coeff 0 * y₂.coeff 0 := by
+  obtain ⟨h₁, h₂, h₃, h₄, h₆⟩ := hW
+  have hval : x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂ =
+      ((⟨x₁, hx₁⟩ ^ 2 + ⟨x₁, hx₁⟩ * ⟨x₂, hx₂⟩ + ⟨x₂, hx₂⟩ ^ 2
+        + ⟨W.a₂, h₂⟩ * (⟨x₁, hx₁⟩ + ⟨x₂, hx₂⟩) + ⟨W.a₄, h₄⟩
+        - ⟨W.a₁, h₁⟩ * ⟨y₂, hy₂⟩ : integralO) : H) := by
+    push_cast
+    rfl
+  constructor
+  · rw [hval]
+    exact mem_integralO.mp (SetLike.coe_mem _)
+  · rw [hval, ← resO_apply]
+    simp only [map_sub, map_add, map_mul, map_pow, resO_apply]
+
+theorem lift_chordDen (W : WeierstrassCurve H) (hW : IntegralCoeffs W) {x₁ y₁ y₂ : H}
+    (hx₁ : 0 ≤ x₁.orderTop) (hy₁ : 0 ≤ y₁.orderTop) (hy₂ : 0 ≤ y₂.orderTop) :
+    0 ≤ (y₁ + y₂ + W.a₁ * x₁ + W.a₃).orderTop ∧
+      (y₁ + y₂ + W.a₁ * x₁ + W.a₃).coeff 0 =
+        y₁.coeff 0 + y₂.coeff 0 + W.a₁.coeff 0 * x₁.coeff 0 + W.a₃.coeff 0 := by
+  obtain ⟨h₁, h₂, h₃, h₄, h₆⟩ := hW
+  have hval : y₁ + y₂ + W.a₁ * x₁ + W.a₃ =
+      ((⟨y₁, hy₁⟩ + ⟨y₂, hy₂⟩ + ⟨W.a₁, h₁⟩ * ⟨x₁, hx₁⟩ + ⟨W.a₃, h₃⟩ : integralO) : H) := by
+    push_cast
+    rfl
+  constructor
+  · rw [hval]
+    exact mem_integralO.mp (SetLike.coe_mem _)
+  · rw [hval, ← resO_apply]
+    simp only [map_add, map_mul, resO_apply]
+
+theorem lift_addX (W : WeierstrassCurve H) (hW : IntegralCoeffs W) {x₁ x₂ ℓ : H}
+    (hx₁ : 0 ≤ x₁.orderTop) (hx₂ : 0 ≤ x₂.orderTop) (hℓ : 0 ≤ ℓ.orderTop) :
+    0 ≤ (W.toAffine.addX x₁ x₂ ℓ).orderTop ∧
+      (W.toAffine.addX x₁ x₂ ℓ).coeff 0 =
+        (specialFibre W).toAffine.addX (x₁.coeff 0) (x₂.coeff 0) (ℓ.coeff 0) := by
+  obtain ⟨h₁, h₂, h₃, h₄, h₆⟩ := hW
+  have hval : W.toAffine.addX x₁ x₂ ℓ =
+      ((⟨ℓ, hℓ⟩ ^ 2 + ⟨W.a₁, h₁⟩ * ⟨ℓ, hℓ⟩ - ⟨W.a₂, h₂⟩ - ⟨x₁, hx₁⟩
+        - ⟨x₂, hx₂⟩ : integralO) : H) := by
+    change ℓ ^ 2 + W.a₁ * ℓ - W.a₂ - x₁ - x₂ = _
+    push_cast
+    rfl
+  constructor
+  · rw [hval]
+    exact mem_integralO.mp (SetLike.coe_mem _)
+  · rw [hval, ← resO_apply]
+    change _ = (ℓ.coeff 0) ^ 2 + W.a₁.coeff 0 * (ℓ.coeff 0) - W.a₂.coeff 0
+      - x₁.coeff 0 - x₂.coeff 0
+    simp only [map_sub, map_add, map_mul, map_pow, resO_apply]
+
+theorem orderTop_slope_neg_of_bar_vertical (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) {x₁ y₁ x₂ y₂ : H}
+    (h₁ : W.toAffine.Nonsingular x₁ y₁) (h₂ : W.toAffine.Nonsingular x₂ y₂)
+    (hx₁ : 0 ≤ x₁.orderTop) (hy₁ : 0 ≤ y₁.orderTop)
+    (hx₂ : 0 ≤ x₂.orderTop) (hy₂ : 0 ≤ y₂.orderTop)
+    (hv : ¬(x₁ = x₂ ∧ y₁ = W.toAffine.negY x₂ y₂))
+    (hvbx : x₁.coeff 0 = x₂.coeff 0)
+    (hvby : y₁.coeff 0 = (specialFibre W).toAffine.negY (x₂.coeff 0) (y₂.coeff 0)) :
+    (W.toAffine.slope x₁ x₂ y₁ y₂).orderTop < 0 := by
+  have hb1 := nonsingular_specialFibre W hW hΔ hx₁ hy₁ h₁
+  have hvby' : y₁.coeff 0 = -(y₂.coeff 0) - W.a₁.coeff 0 * x₂.coeff 0 - W.a₃.coeff 0 := hvby
+  by_cases hx12 : x₁ = x₂
+  · have hy12 : y₁ ≠ W.toAffine.negY x₂ y₂ := fun h => hv ⟨hx12, h⟩
+    have hy21 : y₁ = y₂ := WeierstrassCurve.Affine.Y_eq_of_Y_ne h₁.1 h₂.1 hx12 hy12
+    have hy21c : y₁.coeff 0 = y₂.coeff 0 := by rw [hy21]
+    rw [WeierstrassCurve.Affine.slope_of_Y_ne hx12 hy12]
+    have hdead : 2 * y₁.coeff 0 + W.a₁.coeff 0 * x₁.coeff 0 + W.a₃.coeff 0 = 0 := by
+      linear_combination hvby' + hy21c + W.a₁.coeff 0 * hvbx
+    obtain ⟨hNint, hNcoeff⟩ := lift_tangentNum W hW hx₁ hy₁
+    have hNbar : (3 * x₁ ^ 2 + 2 * W.a₂ * x₁ + W.a₄ - W.a₁ * y₁).coeff 0 ≠ 0 := by
+      obtain ⟨-, hdisj⟩ := (WeierstrassCurve.Affine.nonsingular_iff' _ _).mp hb1
+      rcases hdisj with hA | hB
+      · have hA' : W.a₁.coeff 0 * y₁.coeff 0
+            - (3 * (x₁.coeff 0) ^ 2 + 2 * W.a₂.coeff 0 * x₁.coeff 0 + W.a₄.coeff 0) ≠ 0 := hA
+        rw [hNcoeff]
+        intro h0
+        exact hA' (by linear_combination -h0)
+      · have hB' : 2 * y₁.coeff 0 + W.a₁.coeff 0 * x₁.coeff 0 + W.a₃.coeff 0 ≠ 0 := hB
+        exact absurd hdead hB'
+    have hNne : 3 * x₁ ^ 2 + 2 * W.a₂ * x₁ + W.a₄ - W.a₁ * y₁ ≠ 0 :=
+      fun h => hNbar (by rw [h]; exact HahnSeries.coeff_zero)
+    obtain ⟨hNord, -⟩ := order_eq_zero_of_coeff_zero_ne_zero hNint hNbar
+    have hdne : y₁ - W.toAffine.negY x₁ y₁ ≠ 0 :=
+      sub_ne_zero.mpr fun h => hy12 (by rw [← hx12, ← hy21]; exact h)
+    have hdint : 0 ≤ (y₁ - W.toAffine.negY x₁ y₁).orderTop :=
+      orderTop_sub_nonneg hy₁ (orderTop_negY_nonneg W hW hx₁ hy₁)
+    have hdbar : (y₁ - W.toAffine.negY x₁ y₁).coeff 0 = 0 := by
+      rw [HahnSeries.coeff_sub, coeff_zero_negY W hW hx₁]
+      change y₁.coeff 0 - (-(y₁.coeff 0) - W.a₁.coeff 0 * x₁.coeff 0 - W.a₃.coeff 0) = 0
+      linear_combination hdead
+    have hdpos : 0 < (y₁ - W.toAffine.negY x₁ y₁).order :=
+      order_pos_of_coeff_zero_eq_zero hdne hdint hdbar
+    have hQne : (3 * x₁ ^ 2 + 2 * W.a₂ * x₁ + W.a₄ - W.a₁ * y₁)
+        / (y₁ - W.toAffine.negY x₁ y₁) ≠ 0 := div_ne_zero hNne hdne
+    rw [← HahnSeries.order_eq_orderTop_of_ne_zero hQne,
+      order_div _ _ hNne hdne, hNord]
+    exact_mod_cast (by linarith : (0 : ℚ) - (y₁ - W.toAffine.negY x₁ y₁).order < 0)
+  · rw [WeierstrassCurve.Affine.slope_of_X_ne hx12]
+    have hsubne : x₁ - x₂ ≠ 0 := sub_ne_zero.mpr hx12
+    have hsubint : 0 ≤ (x₁ - x₂).orderTop := orderTop_sub_nonneg hx₁ hx₂
+    have hsubbar : (x₁ - x₂).coeff 0 = 0 := by
+      rw [HahnSeries.coeff_sub, sub_eq_zero]; exact hvbx
+    have hsubpos : 0 < (x₁ - x₂).order :=
+      order_pos_of_coeff_zero_eq_zero hsubne hsubint hsubbar
+    by_cases hyb : y₁.coeff 0 = y₂.coeff 0
+    · obtain ⟨hDint, hDcoeff⟩ := lift_chordDen W hW hx₁ hy₁ hy₂
+      obtain ⟨hNint, hNcoeff⟩ := lift_chordNum W hW hx₁ hx₂ hy₂
+      have hdead : 2 * y₁.coeff 0 + W.a₁.coeff 0 * x₁.coeff 0 + W.a₃.coeff 0 = 0 := by
+        linear_combination hvby' + hyb + W.a₁.coeff 0 * hvbx
+      have hNbar : (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄
+          - W.a₁ * y₂).coeff 0 ≠ 0 := by
+        obtain ⟨-, hdisj⟩ := (WeierstrassCurve.Affine.nonsingular_iff' _ _).mp hb1
+        rcases hdisj with hA | hB
+        · have hA' : W.a₁.coeff 0 * y₁.coeff 0
+              - (3 * (x₁.coeff 0) ^ 2 + 2 * W.a₂.coeff 0 * x₁.coeff 0 + W.a₄.coeff 0) ≠ 0 := hA
+          rw [hNcoeff]
+          intro h0
+          exact hA' (by linear_combination -h0 + W.a₁.coeff 0 * hyb
+            - (2 * x₁.coeff 0 + x₂.coeff 0 + W.a₂.coeff 0) * hvbx)
+        · have hB' : 2 * y₁.coeff 0 + W.a₁.coeff 0 * x₁.coeff 0 + W.a₃.coeff 0 ≠ 0 := hB
+          exact absurd hdead hB'
+      have hNne : x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂ ≠ 0 :=
+        fun h => hNbar (by rw [h]; exact HahnSeries.coeff_zero)
+      obtain ⟨hNord, -⟩ := order_eq_zero_of_coeff_zero_ne_zero hNint hNbar
+      have hDbar : (y₁ + y₂ + W.a₁ * x₁ + W.a₃).coeff 0 = 0 := by
+        rw [hDcoeff]
+        linear_combination hdead - hyb
+      have hDne : y₁ + y₂ + W.a₁ * x₁ + W.a₃ ≠ 0 := by
+        intro h0
+        have hKEY := chord_cross_identity W h₁.1 h₂.1
+        rw [h0, mul_zero] at hKEY
+        exact hNne ((mul_eq_zero.mp hKEY.symm).resolve_left hsubne)
+      have hDpos : 0 < (y₁ + y₂ + W.a₁ * x₁ + W.a₃).order :=
+        order_pos_of_coeff_zero_eq_zero hDne hDint hDbar
+      have hℓeq : (y₁ - y₂) / (x₁ - x₂) =
+          (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂)
+            / (y₁ + y₂ + W.a₁ * x₁ + W.a₃) := by
+        rw [div_eq_div_iff hsubne hDne]
+        linear_combination chord_cross_identity W h₁.1 h₂.1
+      rw [hℓeq]
+      have hQne : (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂)
+          / (y₁ + y₂ + W.a₁ * x₁ + W.a₃) ≠ 0 := div_ne_zero hNne hDne
+      rw [← HahnSeries.order_eq_orderTop_of_ne_zero hQne,
+        order_div _ _ hNne hDne, hNord]
+      exact_mod_cast (by linarith : (0 : ℚ) - (y₁ + y₂ + W.a₁ * x₁ + W.a₃).order < 0)
+    · have hnbar : (y₁ - y₂).coeff 0 ≠ 0 := by
+        rw [HahnSeries.coeff_sub]; exact sub_ne_zero.mpr hyb
+      have hnne : y₁ - y₂ ≠ 0 := fun h => hnbar (by rw [h]; exact HahnSeries.coeff_zero)
+      obtain ⟨hnord, -⟩ :=
+        order_eq_zero_of_coeff_zero_ne_zero (orderTop_sub_nonneg hy₁ hy₂) hnbar
+      have hQne : (y₁ - y₂) / (x₁ - x₂) ≠ 0 := div_ne_zero hnne hsubne
+      rw [← HahnSeries.order_eq_orderTop_of_ne_zero hQne,
+        order_div _ _ hnne hsubne, hnord]
+      exact_mod_cast (by linarith : (0 : ℚ) - (x₁ - x₂).order < 0)
+
+theorem slope_lift (W : WeierstrassCurve H) (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0)
+    {x₁ y₁ x₂ y₂ : H}
+    (h₁ : W.toAffine.Nonsingular x₁ y₁) (h₂ : W.toAffine.Nonsingular x₂ y₂)
+    (hx₁ : 0 ≤ x₁.orderTop) (hy₁ : 0 ≤ y₁.orderTop)
+    (hx₂ : 0 ≤ x₂.orderTop) (hy₂ : 0 ≤ y₂.orderTop)
+    (hvb : ¬(x₁.coeff 0 = x₂.coeff 0 ∧
+      y₁.coeff 0 = (specialFibre W).toAffine.negY (x₂.coeff 0) (y₂.coeff 0))) :
+    0 ≤ (W.toAffine.slope x₁ x₂ y₁ y₂).orderTop ∧
+      (W.toAffine.slope x₁ x₂ y₁ y₂).coeff 0 =
+        (specialFibre W).toAffine.slope (x₁.coeff 0) (x₂.coeff 0)
+          (y₁.coeff 0) (y₂.coeff 0) := by
+  have hb1 := nonsingular_specialFibre W hW hΔ hx₁ hy₁ h₁
+  have hb2 := nonsingular_specialFibre W hW hΔ hx₂ hy₂ h₂
+  by_cases hxb : x₁.coeff 0 = x₂.coeff 0
+  · have hyb : y₁.coeff 0 ≠ (specialFibre W).toAffine.negY (x₂.coeff 0) (y₂.coeff 0) :=
+      fun h => hvb ⟨hxb, h⟩
+    have hfs := WeierstrassCurve.Affine.slope_of_Y_ne hxb hyb
+    have hy21c : y₁.coeff 0 = y₂.coeff 0 :=
+      WeierstrassCurve.Affine.Y_eq_of_Y_ne hb1.1 hb2.1 hxb hyb
+    have hdbarne : y₁.coeff 0
+        - (specialFibre W).toAffine.negY (x₁.coeff 0) (y₁.coeff 0) ≠ 0 :=
+      sub_ne_zero.mpr fun h => hyb (by rw [← hxb, ← hy21c]; exact h)
+    by_cases hx12 : x₁ = x₂
+    · have hyne : y₁ ≠ W.toAffine.negY x₂ y₂ := by
+        intro h
+        exact hyb (by rw [h, coeff_zero_negY W hW hx₂])
+      rw [WeierstrassCurve.Affine.slope_of_Y_ne hx12 hyne, hfs]
+      obtain ⟨hNint, hNcoeff⟩ := lift_tangentNum W hW hx₁ hy₁
+      have hdint : 0 ≤ (y₁ - W.toAffine.negY x₁ y₁).orderTop :=
+        orderTop_sub_nonneg hy₁ (orderTop_negY_nonneg W hW hx₁ hy₁)
+      have hdbar : (y₁ - W.toAffine.negY x₁ y₁).coeff 0 =
+          y₁.coeff 0 - (specialFibre W).toAffine.negY (x₁.coeff 0) (y₁.coeff 0) := by
+        rw [HahnSeries.coeff_sub, coeff_zero_negY W hW hx₁]
+      obtain ⟨hint, hcoeff⟩ := coeff_zero_div_of_unit hNint hdint (by rw [hdbar]; exact hdbarne)
+      refine ⟨hint, ?_⟩
+      rw [hcoeff, hNcoeff, hdbar]
+      rfl
+    · obtain ⟨hDint, hDcoeff⟩ := lift_chordDen W hW hx₁ hy₁ hy₂
+      obtain ⟨hNint, hNcoeff⟩ := lift_chordNum W hW hx₁ hx₂ hy₂
+      have hsubne : x₁ - x₂ ≠ 0 := sub_ne_zero.mpr hx12
+      have hDbarne : (y₁ + y₂ + W.a₁ * x₁ + W.a₃).coeff 0 ≠ 0 := by
+        rw [hDcoeff]
+        intro h0
+        apply hyb
+        change y₁.coeff 0 = -(y₂.coeff 0) - W.a₁.coeff 0 * x₂.coeff 0 - W.a₃.coeff 0
+        linear_combination h0 - W.a₁.coeff 0 * hxb
+      have hDne : y₁ + y₂ + W.a₁ * x₁ + W.a₃ ≠ 0 :=
+        fun h => hDbarne (by rw [h]; exact HahnSeries.coeff_zero)
+      have hℓeq : W.toAffine.slope x₁ x₂ y₁ y₂ =
+          (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂)
+            / (y₁ + y₂ + W.a₁ * x₁ + W.a₃) := by
+        rw [WeierstrassCurve.Affine.slope_of_X_ne hx12, div_eq_div_iff hsubne hDne]
+        linear_combination chord_cross_identity W h₁.1 h₂.1
+      rw [hℓeq, hfs]
+      obtain ⟨hint, hcoeff⟩ := coeff_zero_div_of_unit hNint hDint hDbarne
+      refine ⟨hint, ?_⟩
+      rw [hcoeff, hNcoeff, hDcoeff]
+      change _ = (3 * (x₁.coeff 0) ^ 2 + 2 * W.a₂.coeff 0 * (x₁.coeff 0) + W.a₄.coeff 0
+          - W.a₁.coeff 0 * (y₁.coeff 0)) /
+        (y₁.coeff 0 - (-(y₁.coeff 0) - W.a₁.coeff 0 * (x₁.coeff 0) - W.a₃.coeff 0))
+      congr 1
+      · linear_combination (-(2 * x₁.coeff 0 + x₂.coeff 0 + W.a₂.coeff 0)) * hxb
+          + W.a₁.coeff 0 * hy21c
+      · linear_combination hy21c.symm
+  · have hx12 : x₁ ≠ x₂ := fun h => hxb (by rw [h])
+    rw [WeierstrassCurve.Affine.slope_of_X_ne hx12,
+      WeierstrassCurve.Affine.slope_of_X_ne hxb]
+    have hsubbar : (x₁ - x₂).coeff 0 ≠ 0 := by
+      rw [HahnSeries.coeff_sub]; exact sub_ne_zero.mpr hxb
+    obtain ⟨hint, hcoeff⟩ := coeff_zero_div_of_unit (orderTop_sub_nonneg hy₁ hy₂)
+      (orderTop_sub_nonneg hx₁ hx₂) hsubbar
+    refine ⟨hint, ?_⟩
+    rw [hcoeff, HahnSeries.coeff_sub, HahnSeries.coeff_sub]
+
+theorem some_point_ext {V : WeierstrassCurve.Affine Qbar} {x y x' y' : Qbar}
+    {h : V.Nonsingular x y} {h' : V.Nonsingular x' y'} (hx : x = x') (hy : y = y') :
+    WeierstrassCurve.Affine.Point.some x y h = WeierstrassCurve.Affine.Point.some x' y' h' := by
+  subst hx; subst hy; rfl
+
+theorem redPoint_add (W : WeierstrassCurve H) [W.IsElliptic] (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) {n : ℕ} (hn : n ≠ 0) {P Q : W.toAffine.Point}
+    (hP : n • P = 0) (hQ : n • Q = 0) :
+    redPoint W hW hΔ (P + Q) = redPoint W hW hΔ P + redPoint W hW hΔ Q := by
+  cases P with
+  | zero =>
+    change redPoint W hW hΔ (0 + Q) = redPoint W hW hΔ 0 + redPoint W hW hΔ Q
+    rw [zero_add, redPoint_zero, zero_add]
+  | some x₁ y₁ h₁ =>
+    cases Q with
+    | zero =>
+      change redPoint W hW hΔ (WeierstrassCurve.Affine.Point.some x₁ y₁ h₁ + 0) =
+        redPoint W hW hΔ (WeierstrassCurve.Affine.Point.some x₁ y₁ h₁) + redPoint W hW hΔ 0
+      rw [add_zero, redPoint_zero, add_zero]
+    | some x₂ y₂ h₂ =>
+      obtain ⟨hx₁, hy₁⟩ := torsion_coords_integral W hW hΔ h₁ hn hP
+      obtain ⟨hx₂, hy₂⟩ := torsion_coords_integral W hW hΔ h₂ hn hQ
+      by_cases hv : x₁ = x₂ ∧ y₁ = W.toAffine.negY x₂ y₂
+      · rw [WeierstrassCurve.Affine.Point.add_of_Y_eq hv.1 hv.2, redPoint_zero,
+          redPoint_some W hW hΔ hx₁ hy₁ h₁, redPoint_some W hW hΔ hx₂ hy₂ h₂]
+        exact (WeierstrassCurve.Affine.Point.add_of_Y_eq (by rw [hv.1])
+          (by rw [hv.2, coeff_zero_negY W hW hx₂])).symm
+      · have htor₃ : n • (WeierstrassCurve.Affine.Point.some x₁ y₁ h₁
+            + WeierstrassCurve.Affine.Point.some x₂ y₂ h₂) = 0 := by
+          rw [nsmul_add, hP, hQ, add_zero]
+        rw [WeierstrassCurve.Affine.Point.add_some hv] at htor₃ ⊢
+        by_cases hvb : x₁.coeff 0 = x₂.coeff 0 ∧
+            y₁.coeff 0 = (specialFibre W).toAffine.negY (x₂.coeff 0) (y₂.coeff 0)
+        · exact absurd (torsion_coords_integral W hW hΔ _ hn htor₃).1
+            (not_le.mpr (orderTop_addX_neg W hW hx₁ hx₂
+              (orderTop_slope_neg_of_bar_vertical W hW hΔ h₁ h₂ hx₁ hy₁ hx₂ hy₂
+                hv hvb.1 hvb.2)))
+        · obtain ⟨hsint, hscoeff⟩ := slope_lift W hW hΔ h₁ h₂ hx₁ hy₁ hx₂ hy₂ hvb
+          obtain ⟨hXint, hXcoeff⟩ := lift_addX W hW hx₁ hx₂ hsint
+          have hnAYint : 0 ≤ (W.toAffine.negAddY x₁ x₂ y₁
+              (W.toAffine.slope x₁ x₂ y₁ y₂)).orderTop := by
+            change 0 ≤ (W.toAffine.slope x₁ x₂ y₁ y₂
+              * (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₁) + y₁).orderTop
+            exact orderTop_add_nonneg
+              (orderTop_mul_nonneg hsint (orderTop_sub_nonneg hXint hx₁)) hy₁
+          have hnAYcoeff : (W.toAffine.negAddY x₁ x₂ y₁
+              (W.toAffine.slope x₁ x₂ y₁ y₂)).coeff 0 =
+              (specialFibre W).toAffine.negAddY (x₁.coeff 0) (x₂.coeff 0) (y₁.coeff 0)
+                ((W.toAffine.slope x₁ x₂ y₁ y₂).coeff 0) := by
+            change (W.toAffine.slope x₁ x₂ y₁ y₂
+              * (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₁) + y₁).coeff 0 = _
+            rw [HahnSeries.coeff_add,
+              coeff_zero_mul_of_integral hsint (orderTop_sub_nonneg hXint hx₁),
+              HahnSeries.coeff_sub, hXcoeff]
+            rfl
+          have hYint : 0 ≤ (W.toAffine.addY x₁ x₂ y₁
+              (W.toAffine.slope x₁ x₂ y₁ y₂)).orderTop :=
+            orderTop_negY_nonneg W hW hXint hnAYint
+          have hYcoeff : (W.toAffine.addY x₁ x₂ y₁
+              (W.toAffine.slope x₁ x₂ y₁ y₂)).coeff 0 =
+              (specialFibre W).toAffine.addY (x₁.coeff 0) (x₂.coeff 0) (y₁.coeff 0)
+                ((W.toAffine.slope x₁ x₂ y₁ y₂).coeff 0) := by
+            change (W.toAffine.negY (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂))
+              (W.toAffine.negAddY x₁ x₂ y₁ (W.toAffine.slope x₁ x₂ y₁ y₂))).coeff 0 = _
+            rw [coeff_zero_negY W hW hXint, hXcoeff, hnAYcoeff]
+            rfl
+          rw [redPoint_some W hW hΔ hXint hYint _,
+            redPoint_some W hW hΔ hx₁ hy₁ h₁, redPoint_some W hW hΔ hx₂ hy₂ h₂,
+            WeierstrassCurve.Affine.Point.add_some hvb]
+          exact some_point_ext (by rw [hXcoeff, hscoeff]) (by rw [hYcoeff, hscoeff])
+
+private theorem exists_torsionBy_reduction_addEquiv (W : WeierstrassCurve H) [W.IsElliptic]
+    (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0) [(specialFibre W).IsElliptic]
+    (p : ℕ) [Fact p.Prime] :
+    ∃ e : Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ) ≃+
+        Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ),
+      ∀ (P : Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ)) (x y : H)
+        (h : W.toAffine.Nonsingular x y),
+        (P : W.toAffine.Point) = WeierstrassCurve.Affine.Point.some x y h →
+          ∃ h₀ : (specialFibre W).toAffine.Nonsingular (x.coeff 0) (y.coeff 0),
+            ((e P : Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ)) :
+                (specialFibre W).toAffine.Point) =
+              WeierstrassCurve.Affine.Point.some (x.coeff 0) (y.coeff 0) h₀ := by
+  have hpprime : p.Prime := Fact.out
+  have hp : p ≠ 0 := hpprime.ne_zero
+  have hmem : ∀ P : Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ),
+      p • (P : W.toAffine.Point) = 0 := fun P => by
+    have h := (Submodule.mem_torsionBy_iff _ _).mp P.2
+    rwa [natCast_zsmul] at h
+  have key : ∀ (P : Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ)) (k : ℕ),
+      redPoint W hW hΔ (k • (P : W.toAffine.Point)) =
+        k • redPoint W hW hΔ (P : W.toAffine.Point) := by
+    intro P k
+    induction k with
+    | zero => rw [zero_nsmul, zero_nsmul, redPoint_zero]
+    | succ k ih =>
+      have hkP : p • (k • (P : W.toAffine.Point)) = 0 := by
+        rw [← mul_nsmul, mul_comm, mul_nsmul, hmem P]
+        simp
+      rw [succ_nsmul, succ_nsmul, redPoint_add W hW hΔ hp hkP (hmem P), ih]
+  have hred : ∀ P : Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ),
+      redPoint W hW hΔ (P : W.toAffine.Point) ∈
+        Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ) := fun P => by
+    rw [Submodule.mem_torsionBy_iff, natCast_zsmul, ← key P p, hmem P, redPoint_zero]
+  let f : Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ) →+
+      Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ) :=
+    AddMonoidHom.mk'
+      (fun P => ⟨redPoint W hW hΔ (P : W.toAffine.Point), hred P⟩)
+      (fun P Q => by
+        apply Subtype.ext
+        change redPoint W hW hΔ ((P : W.toAffine.Point) + (Q : W.toAffine.Point)) = _
+        exact redPoint_add W hW hΔ hp (hmem P) (hmem Q))
+  have hinj : Function.Injective f := by
+    rw [injective_iff_map_eq_zero]
+    intro P hP0
+    have h0 : redPoint W hW hΔ (P : W.toAffine.Point) = 0 := congrArg Subtype.val hP0
+    apply Subtype.ext
+    change (P : W.toAffine.Point) = 0
+    cases hPv : (P : W.toAffine.Point) with
+    | zero => rfl
+    | some x y hxy =>
+      rw [hPv] at h0
+      have htor := hmem P
+      rw [hPv] at htor
+      obtain ⟨hx, hy⟩ := torsion_coords_integral W hW hΔ hxy hp htor
+      rw [redPoint_some W hW hΔ hx hy] at h0
+      exact absurd h0 (WeierstrassCurve.Affine.Point.some_ne_zero _)
+  have : IsAlgClosed H := HahnSeries.isAlgClosed_rat
+  have hne : ∀ m : ℕ, m ≠ 0 → (m : H) ≠ 0 := fun m hm => by
+    rw [(map_natCast (HahnSeries.C : Qbar →+* H) m).symm]
+    change HahnSeries.single (0 : ℚ) ((m : ℕ) : Qbar) ≠ 0
+    exact HahnSeries.single_ne_zero (Nat.cast_ne_zero.mpr hm)
+  have h2H : (2 : H) ≠ 0 := by exact_mod_cast hne 2 (by norm_num)
+  have hcard₁ : Nat.card (Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ)) = p ^ 2 :=
+    WeierstrassCurve.card_torsionBy_eq_sq_of_isAlgClosed W (hne p hp)
+  have hcard₂ :
+      Nat.card (Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ)) = p ^ 2 :=
+    WeierstrassCurve.card_torsionBy_eq_sq_of_isAlgClosed (specialFibre W)
+      (Nat.cast_ne_zero.mpr hp)
+  have : Finite (Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ)) :=
+    Nat.finite_of_card_ne_zero (by rw [hcard₂]; exact pow_ne_zero 2 hp)
+  have hbij : Function.Bijective f :=
+    (Nat.bijective_iff_injective_and_card f).mpr ⟨hinj, by rw [hcard₁, hcard₂]⟩
+  refine ⟨AddEquiv.ofBijective f hbij, ?_⟩
+  intro P x y h hPv
+  have htor := hmem P
+  rw [hPv] at htor
+  obtain ⟨hx, hy⟩ := torsion_coords_integral W hW hΔ h hp htor
+  refine ⟨nonsingular_specialFibre W hW hΔ hx hy h, ?_⟩
+  change redPoint W hW hΔ (P : W.toAffine.Point) = _
+  rw [hPv, redPoint_some W hW hΔ hx hy h]
+
+end E3
+
+universe u
+
+def CycOf (A : Type u) [AddGroup A] (N : ℕ) : Type u :=
+  {G : AddSubgroup A // ∃ g : A, addOrderOf g = N ∧ G = AddSubgroup.zmultiples g}
+
+example (E : WeierstrassCurve H) (N : ℕ) : CycSubH E N = CycOf E.toAffine.Point N := rfl
+example (E₀ : WeierstrassCurve Qbar) (N : ℕ) : CycSub E₀ N = CycOf E₀.toAffine.Point N := rfl
+
+def cycOfCongr {A B : Type*} [AddCommGroup A] [AddCommGroup B] (e : A ≃+ B) (N : ℕ) :
+    CycOf A N ≃ CycOf B N where
+  toFun G := ⟨G.1.map (e : A →+ B), by
+    obtain ⟨g, hg, hG⟩ := G.2
+    exact ⟨(e : A →+ B) g, by rw [AddMonoidHom.coe_ofClass, AddEquiv.addOrderOf_eq, hg],
+      by rw [hG, AddMonoidHom.map_zmultiples]⟩⟩
+  invFun G := ⟨G.1.map (e.symm : B →+ A), by
+    obtain ⟨g, hg, hG⟩ := G.2
+    exact ⟨(e.symm : B →+ A) g, by rw [AddMonoidHom.coe_ofClass, AddEquiv.addOrderOf_eq, hg],
+      by rw [hG, AddMonoidHom.map_zmultiples]⟩⟩
+  left_inv G := Subtype.ext ((AddSubgroup.map_symm_eq_iff_map_eq (K := G.1)).mpr rfl)
+  right_inv G := Subtype.ext ((AddSubgroup.map_symm_eq_iff_map_eq (K := G.1) (e := e.symm)).mpr rfl)
+
+@[scoped simp] theorem cycOfCongr_apply_coe {A B : Type*} [AddCommGroup A] [AddCommGroup B] (e : A
+  ≃+ B)
+    (N : ℕ) (G : CycOf A N) : (cycOfCongr e N G).1 = G.1.map (e : A →+ B) := rfl
+
+theorem mem_torsionBy_of_addOrderOf_eq {A : Type*} [AddCommGroup A] {N : ℕ} {g : A}
+    (hg : addOrderOf g = N) : g ∈ Submodule.torsionBy ℤ A N := by
+  rw [Submodule.mem_torsionBy_iff, natCast_zsmul, ← hg, addOrderOf_nsmul_eq_zero]
+
+theorem comap_subtype_zmultiples {A : Type*} [AddCommGroup A] (S : Submodule ℤ A) {x : A}
+    (hx : x ∈ S) :
+    (AddSubgroup.zmultiples x).comap S.subtype.toAddMonoidHom = AddSubgroup.zmultiples ⟨x, hx⟩ := by
+  rw [show AddSubgroup.zmultiples x =
+      (AddSubgroup.zmultiples (⟨x, hx⟩ : S)).map S.subtype.toAddMonoidHom from
+        (AddMonoidHom.map_zmultiples S.subtype.toAddMonoidHom ⟨x, hx⟩).symm,
+    AddSubgroup.comap_map_eq_self_of_injective (Submodule.injective_subtype S)]
+
+def cycOfTorsionBy (A : Type*) [AddCommGroup A] (N : ℕ) :
+    CycOf A N ≃ CycOf (Submodule.torsionBy ℤ A N) N where
+  toFun G := ⟨G.1.comap (Submodule.torsionBy ℤ A N).subtype.toAddMonoidHom, by
+    obtain ⟨g, hg, hG⟩ := G.2
+    refine ⟨⟨g, mem_torsionBy_of_addOrderOf_eq hg⟩, ?_, by rw [hG, comap_subtype_zmultiples]⟩
+    rw [← addOrderOf_injective (Submodule.torsionBy ℤ A N).subtype.toAddMonoidHom
+      (Submodule.injective_subtype _) ⟨g, mem_torsionBy_of_addOrderOf_eq hg⟩]
+    exact hg⟩
+  invFun G := ⟨G.1.map (Submodule.torsionBy ℤ A N).subtype.toAddMonoidHom, by
+    obtain ⟨g, hg, hG⟩ := G.2
+    exact ⟨(Submodule.torsionBy ℤ A N).subtype.toAddMonoidHom g,
+      by rw [addOrderOf_injective _ (Submodule.injective_subtype _), hg],
+      by rw [hG, AddMonoidHom.map_zmultiples]⟩⟩
+  left_inv G := by
+    apply Subtype.ext
+    obtain ⟨g, hg, hG⟩ := G.2
+    change (G.1.comap _).map _ = G.1
+    apply AddSubgroup.map_comap_eq_self
+    rw [hG, AddSubgroup.zmultiples_le]
+    exact AddMonoidHom.mem_range.mpr ⟨⟨g, mem_torsionBy_of_addOrderOf_eq hg⟩, rfl⟩
+  right_inv G :=
+    Subtype.ext (AddSubgroup.comap_map_eq_self_of_injective (Submodule.injective_subtype _) _)
+
+@[scoped simp] theorem cycOfTorsionBy_apply_coe (A : Type*) [AddCommGroup A] (N : ℕ) (G : CycOf A
+  N) :
+    (cycOfTorsionBy A N G).1 = G.1.comap (Submodule.torsionBy ℤ A N).subtype.toAddMonoidHom := rfl
+
+@[scoped simp] theorem cycOfTorsionBy_symm_apply_coe (A : Type*) [AddCommGroup A] (N : ℕ)
+    (G : CycOf (Submodule.torsionBy ℤ A N) N) :
+    ((cycOfTorsionBy A N).symm G).1 = G.1.map (Submodule.torsionBy ℤ A N).subtype.toAddMonoidHom :=
+  rfl
+
+def vcAddEquiv {K : Type*} [Field K] [DecidableEq K] (C : VariableChange K)
+    (W : WeierstrassCurve K) :
+    W.toAffine.Point ≃+ (C • W).toAffine.Point :=
+  AddEquiv.mk' (WeierstrassCurve.Affine.Point.variableChangeEquiv C W.toAffine).symm
+    (WeierstrassCurve.Affine.Point.vcInvFun_add C W.toAffine)
+
+@[scoped simp] theorem vcAddEquiv_apply {K : Type*} [Field K] [DecidableEq K] (C : VariableChange K)
+    (W : WeierstrassCurve K) (P : W.toAffine.Point) :
+    vcAddEquiv C W P = WeierstrassCurve.Affine.Point.vcInvFun C W.toAffine P := rfl
+
+def pointAddEquivOfEq {K : Type*} [Field K] [DecidableEq K] {W V : WeierstrassCurve K} (h : W = V) :
+    W.toAffine.Point ≃+ V.toAffine.Point := by
+  subst h; exact AddEquiv.refl _
+
+@[scoped simp] theorem pointAddEquivOfEq_rfl {K : Type*} [Field K] [DecidableEq K]
+    (W : WeierstrassCurve K) :
+    pointAddEquivOfEq (rfl : W = W) = AddEquiv.refl _ := rfl
+
+scoped instance instIsElliptic_goodModel (j₀ : Qbar) : (goodModel j₀).IsElliptic := by
+  unfold goodModel; infer_instance
+
+theorem goodModel_spec (j₀ : Qbar) :
+    IntegralCoeffs (goodModel j₀) ∧ (goodModel j₀).Δ.orderTop = 0 := by
+  by_cases h0 : j₀ = 0
+  · subst h0; exact ⟨goodModel_zero_spec.1, goodModel_zero_spec.2.1⟩
+  · by_cases h1728 : j₀ = 1728
+    · subst h1728; exact ⟨goodModel_1728_spec.1, goodModel_1728_spec.2.1⟩
+    · exact ⟨(goodModel_generic_spec j₀ h0 h1728).1, (goodModel_generic_spec j₀ h0 h1728).2.1⟩
+
+private scoped instance isElliptic_specialFibre_goodModel (j₀ : Qbar) :
+    (specialFibre (goodModel j₀)).IsElliptic := by
+  by_cases h0 : j₀ = 0
+  · subst h0; obtain ⟨hE, -⟩ := goodModel_zero_spec.2.2; exact hE
+  · by_cases h1728 : j₀ = 1728
+    · subst h1728; obtain ⟨hE, -⟩ := goodModel_1728_spec.2.2; exact hE
+    · rw [(goodModel_generic_spec j₀ h0 h1728).2.2]; infer_instance
+
+private theorem exists_variableChange_specialFibre_goodModel (j₀ : Qbar) :
+    ∃ C : VariableChange Qbar, C • specialFibre (goodModel j₀) = WeierstrassCurve.ofJ j₀ := by
+  by_cases h0 : j₀ = 0
+  · subst h0
+    obtain ⟨hE, hj⟩ := goodModel_zero_spec.2.2
+    exact WeierstrassCurve.exists_variableChange_of_j_eq _ _
+      (hj.trans (WeierstrassCurve.ofJ_j (0 : Qbar)).symm)
+  · by_cases h1728 : j₀ = 1728
+    · subst h1728
+      obtain ⟨hE, hj⟩ := goodModel_1728_spec.2.2
+      exact WeierstrassCurve.exists_variableChange_of_j_eq _ _
+        (hj.trans (WeierstrassCurve.ofJ_j (1728 : Qbar)).symm)
+    · exact ⟨1, by rw [(goodModel_generic_spec j₀ h0 h1728).2.2, one_smul]⟩
+
+def fibreVC (j₀ : Qbar) : VariableChange Qbar :=
+  Classical.choose (exists_variableChange_specialFibre_goodModel j₀)
+
+theorem fibreVC_smul (j₀ : Qbar) :
+    fibreVC j₀ • specialFibre (goodModel j₀) = WeierstrassCurve.ofJ j₀ :=
+  Classical.choose_spec (exists_variableChange_specialFibre_goodModel j₀)
+
+def scaleAddEquiv (j₀ : Qbar) : (nearCurve j₀).toAffine.Point ≃+ (goodModel j₀).toAffine.Point :=
+  vcAddEquiv (scaleVC j₀) (nearCurve j₀)
+
+@[scoped simp] theorem scaleAddEquiv_apply (j₀ : Qbar) (P : (nearCurve j₀).toAffine.Point) :
+    scaleAddEquiv j₀ P =
+      WeierstrassCurve.Affine.Point.vcInvFun (scaleVC j₀) (nearCurve j₀).toAffine P := rfl
+
+def cycScale (p : ℕ) (j₀ : Qbar) : CycSubH (nearCurve j₀) p ≃ CycSubH (goodModel j₀) p :=
+  cycOfCongr (scaleAddEquiv j₀) p
+
+def fibreAddEquiv (j₀ : Qbar) :
+    (specialFibre (goodModel j₀)).toAffine.Point ≃+ (WeierstrassCurve.ofJ j₀).toAffine.Point :=
+  (vcAddEquiv (fibreVC j₀) (specialFibre (goodModel j₀))).trans (pointAddEquivOfEq (fibreVC_smul
+    j₀))
+
+theorem fibreAddEquiv_apply (j₀ : Qbar) (P : (specialFibre (goodModel j₀)).toAffine.Point) :
+    fibreAddEquiv j₀ P =
+      pointAddEquivOfEq (fibreVC_smul j₀)
+        (WeierstrassCurve.Affine.Point.vcInvFun (fibreVC j₀)
+          (specialFibre (goodModel j₀)).toAffine P) := rfl
+
+def redTorsionEquiv (W : WeierstrassCurve H) [W.IsElliptic] (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) [(specialFibre W).IsElliptic] (p : ℕ) [Fact p.Prime] :
+    Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ) ≃+
+      Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ) :=
+  Classical.choose (exists_torsionBy_reduction_addEquiv W hW hΔ p)
+
+theorem redTorsionEquiv_spec (W : WeierstrassCurve H) [W.IsElliptic] (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) [(specialFibre W).IsElliptic] (p : ℕ) [Fact p.Prime]
+    (P : Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ)) (x y : H)
+    (h : W.toAffine.Nonsingular x y)
+    (hP : (P : W.toAffine.Point) = WeierstrassCurve.Affine.Point.some x y h) :
+    ∃ h₀ : (specialFibre W).toAffine.Nonsingular (x.coeff 0) (y.coeff 0),
+      ((redTorsionEquiv W hW hΔ p P :
+            Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ)) :
+          (specialFibre W).toAffine.Point) =
+        WeierstrassCurve.Affine.Point.some (x.coeff 0) (y.coeff 0) h₀ :=
+  Classical.choose_spec (exists_torsionBy_reduction_addEquiv W hW hΔ p) P x y h hP
+
+def cycRed (W : WeierstrassCurve H) [W.IsElliptic] (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0)
+    [(specialFibre W).IsElliptic] (p : ℕ) [Fact p.Prime] :
+    CycSubH W p ≃ CycSub (specialFibre W) p :=
+  (cycOfTorsionBy W.toAffine.Point p).trans <|
+    (cycOfCongr (redTorsionEquiv W hW hΔ p) p).trans
+      (cycOfTorsionBy (specialFibre W).toAffine.Point p).symm
+
+def bridge3Specialise (p : ℕ) [Fact p.Prime] [NeZero p] (j₀ : Qbar) :
+    CycSubH (nearCurve j₀) p ≃ CycSub (WeierstrassCurve.ofJ j₀) p :=
+  (cycScale p j₀).trans <|
+    (cycRed (goodModel j₀) (goodModel_spec j₀).1 (goodModel_spec j₀).2 p).trans
+      (cycOfCongr (fibreAddEquiv j₀) p)
+
+theorem bridge3Specialise_apply_coe (p : ℕ) [Fact p.Prime] [NeZero p] (j₀ : Qbar)
+    (G : CycSubH (nearCurve j₀) p) :
+    (bridge3Specialise p j₀ G).1 =
+      ((((G.1.map (scaleAddEquiv j₀ :
+              (nearCurve j₀).toAffine.Point →+ (goodModel j₀).toAffine.Point)).comap
+            (Submodule.torsionBy ℤ (goodModel j₀).toAffine.Point (p :
+              ℤ)).subtype.toAddMonoidHom).map
+          (redTorsionEquiv (goodModel j₀) (goodModel_spec j₀).1 (goodModel_spec j₀).2 p :
+            Submodule.torsionBy ℤ (goodModel j₀).toAffine.Point (p : ℤ) →+
+              Submodule.torsionBy ℤ (specialFibre (goodModel j₀)).toAffine.Point (p : ℤ))).map
+        (Submodule.torsionBy ℤ (specialFibre (goodModel j₀)).toAffine.Point
+          (p : ℤ)).subtype.toAddMonoidHom).map
+        (fibreAddEquiv j₀ :
+          (specialFibre (goodModel j₀)).toAffine.Point →+ (WeierstrassCurve.ofJ j₀).toAffine.Point)
+            :=
+  rfl
+
+theorem bridge3Specialise_zmultiples (p : ℕ) [Fact p.Prime] [NeZero p] (j₀ : Qbar)
+    (g : (nearCurve j₀).toAffine.Point) (hg : addOrderOf g = p) :
+    (bridge3Specialise p j₀ ⟨AddSubgroup.zmultiples g, g, hg, rfl⟩).1 =
+      AddSubgroup.zmultiples
+        (fibreAddEquiv j₀
+          ((redTorsionEquiv (goodModel j₀) (goodModel_spec j₀).1 (goodModel_spec j₀).2 p
+              ⟨scaleAddEquiv j₀ g,
+                mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ g).trans hg)⟩ :
+              Submodule.torsionBy ℤ (specialFibre (goodModel j₀)).toAffine.Point (p : ℤ)) :
+            (specialFibre (goodModel j₀)).toAffine.Point)) := by
+  have hmem : scaleAddEquiv j₀ g ∈ Submodule.torsionBy ℤ (goodModel j₀).toAffine.Point (p : ℤ) :=
+    mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ g).trans hg)
+  rw [bridge3Specialise_apply_coe]
+  simp only [AddMonoidHom.map_zmultiples, AddMonoidHom.coe_ofClass, comap_subtype_zmultiples _ hmem,
+    LinearMap.toAddMonoidHom_coe, Submodule.subtype_apply]
+
+variable {K : Type*} [Field K]
+
+scoped instance isShortNF_a6Model (B : K) : (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve K).IsShortNF :=
+  ⟨rfl, rfl, rfl⟩
+
+scoped instance isShortNF_a4Model (A : K) : (⟨0, 0, 0, A, 0⟩ : WeierstrassCurve K).IsShortNF :=
+  ⟨rfl, rfl, rfl⟩
+
+theorem smul_a6Model_eq_iff [CharZero K] {B : K} (hB : B ≠ 0) (γ : VariableChange K) :
+    γ • (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve K) = ⟨0, 0, 0, 0, B⟩ ↔
+      γ.r = 0 ∧ γ.s = 0 ∧ γ.t = 0 ∧ (γ.u : K) ^ 6 = 1 :=
+  MulAction.mem_stabilizer_iff.symm.trans
+    (WeierstrassCurve.mem_stabilizer_variableChange_iff_of_isShortNF_of_a4_eq_zero
+      (by norm_num) (by norm_num) (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve K) rfl hB γ)
+
+theorem smul_a4Model_eq_iff [CharZero K] {A : K} (hA : A ≠ 0) (γ : VariableChange K) :
+    γ • (⟨0, 0, 0, A, 0⟩ : WeierstrassCurve K) = ⟨0, 0, 0, A, 0⟩ ↔
+      γ.r = 0 ∧ γ.s = 0 ∧ γ.t = 0 ∧ (γ.u : K) ^ 4 = 1 :=
+  MulAction.mem_stabilizer_iff.symm.trans
+    (WeierstrassCurve.mem_stabilizer_variableChange_iff_of_isShortNF_of_a6_eq_zero
+      (by norm_num) (by norm_num) (⟨0, 0, 0, A, 0⟩ : WeierstrassCurve K) rfl hA γ)
+
+theorem variableChange_eq_of_rst_eq_zero (γ : VariableChange K) (hr : γ.r = 0) (hs : γ.s = 0)
+    (ht : γ.t = 0) : γ = ⟨γ.u, 0, 0, 0⟩ :=
+  VariableChange.ext rfl hr hs ht
+
+def negVC (W : WeierstrassCurve K) : VariableChange K := ⟨-1, 0, -W.a₁, -W.a₃⟩
+
+@[scoped simp] theorem negVC_u (W : WeierstrassCurve K) : (negVC W).u = -1 := rfl
+@[scoped simp] theorem negVC_r (W : WeierstrassCurve K) : (negVC W).r = 0 := rfl
+@[scoped simp] theorem negVC_s (W : WeierstrassCurve K) : (negVC W).s = -W.a₁ := rfl
+@[scoped simp] theorem negVC_t (W : WeierstrassCurve K) : (negVC W).t = -W.a₃ := rfl
+
+theorem val_inv_negVC_u (W : WeierstrassCurve K) : (((negVC W).u⁻¹ : Kˣ) : K) = -1 := by
+  rw [negVC_u, Units.val_inv_eq_inv_val, Units.val_neg, Units.val_one, inv_neg, inv_one]
+
+theorem negVC_smul (W : WeierstrassCurve K) : negVC W • W = W := by
+  ext
+  · simp only [variableChange_a₁, val_inv_negVC_u, negVC_s]; ring
+  · simp only [variableChange_a₂, val_inv_negVC_u, negVC_r, negVC_s]; ring
+  · simp only [variableChange_a₃, val_inv_negVC_u, negVC_r, negVC_t]; ring
+  · simp only [variableChange_a₄, val_inv_negVC_u, negVC_r, negVC_s, negVC_t]; ring
+  · simp only [variableChange_a₆, val_inv_negVC_u, negVC_r, negVC_t]; ring
+
+theorem negVC_mul_negVC (W : WeierstrassCurve K) : negVC W * negVC W = 1 := by
+  refine VariableChange.ext ?_ ?_ ?_ ?_
+  · simp [VariableChange.mul_def, VariableChange.one_def]
+  · simp only [VariableChange.mul_def, VariableChange.one_def, negVC, Units.val_neg,
+      Units.val_one]; ring
+  · simp only [VariableChange.mul_def, VariableChange.one_def, negVC, Units.val_neg,
+      Units.val_one]; ring
+  · simp only [VariableChange.mul_def, VariableChange.one_def, negVC, Units.val_neg,
+      Units.val_one]; ring
+
+theorem negVC_ne_one [CharZero K] (W : WeierstrassCurve K) : negVC W ≠ 1 := fun h => by
+  have h1 : ((negVC W).u : K) = ((1 : VariableChange K).u : K) := by rw [h]
+  simp only [negVC_u, VariableChange.one_def, Units.val_neg, Units.val_one] at h1
+  norm_num at h1
+
+theorem ofJNe0Or1728_c₆ (j : K) :
+    (WeierstrassCurve.ofJNe0Or1728 j).c₆ = -j * (j - 1728) ^ 5 := by
+  simp only [WeierstrassCurve.ofJNe0Or1728, WeierstrassCurve.c₆, WeierstrassCurve.b₂,
+    WeierstrassCurve.b₄, WeierstrassCurve.b₆]
+  ring1
+
+theorem smul_ofJNe0Or1728_eq_iff [CharZero K] (j : K) (h0 : j ≠ 0) (h1728 : j ≠ 1728)
+    (γ : VariableChange K) :
+    γ • WeierstrassCurve.ofJNe0Or1728 j = WeierstrassCurve.ofJNe0Or1728 j ↔
+      γ = 1 ∨ γ = negVC (WeierstrassCurve.ofJNe0Or1728 j) := by
+  refine ⟨fun hγ => ?_, ?_⟩
+  swap
+  · rintro (rfl | rfl)
+    · exact one_smul _ _
+    · exact negVC_smul _
+  have ha : j - 1728 ≠ 0 := sub_ne_zero.mpr h1728
+  have e₁ := congrArg WeierstrassCurve.a₁ hγ
+  have e₂ := congrArg WeierstrassCurve.a₂ hγ
+  have e₃ := congrArg WeierstrassCurve.a₃ hγ
+  simp only [variableChange_a₁, variableChange_a₂, variableChange_a₃,
+    WeierstrassCurve.ofJNe0Or1728] at e₁ e₂ e₃
+  have e₄ := WeierstrassCurve.variableChange_c₄ (W := WeierstrassCurve.ofJNe0Or1728 j) (C := γ)
+  rw [hγ, WeierstrassCurve.ofJNe0Or1728_c₄] at e₄
+  have e₆ := WeierstrassCurve.variableChange_c₆ (W := WeierstrassCurve.ofJNe0Or1728 j) (C := γ)
+  rw [hγ, ofJNe0Or1728_c₆] at e₆
+  have hv4 : ((γ.u⁻¹ : Kˣ) : K) ^ 4 = 1 :=
+    mul_right_cancel₀ (mul_ne_zero h0 (pow_ne_zero 3 ha)) (by rw [one_mul]; exact e₄.symm)
+  have hv6 : ((γ.u⁻¹ : Kˣ) : K) ^ 6 = 1 :=
+    mul_right_cancel₀ (mul_ne_zero (neg_ne_zero.mpr h0) (pow_ne_zero 5 ha))
+      (by rw [one_mul]; exact e₆.symm)
+  have hv2 : ((γ.u⁻¹ : Kˣ) : K) ^ 2 = 1 := by
+    have h := hv6
+    rwa [show ((γ.u⁻¹ : Kˣ) : K) ^ 6 = ((γ.u⁻¹ : Kˣ) : K) ^ 4 * ((γ.u⁻¹ : Kˣ) : K) ^ 2 by ring,
+      hv4, one_mul] at h
+  rcases mul_self_eq_one_iff.mp ((pow_two _).symm.trans hv2) with hv | hv
+  · rw [hv] at e₁ e₂ e₃
+    have hs : γ.s = 0 := by linear_combination e₁ / 2
+    rw [hs] at e₂
+    have hr : γ.r = 0 := by linear_combination e₂ / 3
+    rw [hr] at e₃
+    have ht : γ.t = 0 := by linear_combination e₃ / 2
+    have hu : γ.u = 1 := by rwa [Units.val_eq_one, inv_eq_one] at hv
+    exact Or.inl (VariableChange.ext hu hr hs ht)
+  · rw [hv] at e₁ e₂ e₃
+    have hs : γ.s = -(j - 1728) := by linear_combination (-1 / 2 : K) * e₁
+    rw [hs] at e₂
+    have hr : γ.r = 0 := by linear_combination e₂ / 3
+    rw [hr] at e₃
+    have ht : γ.t = 0 := by linear_combination (-1 / 2 : K) * e₃
+    have hu : γ.u = -1 := by
+      refine Units.ext ?_
+      rw [Units.val_inv_eq_inv_val] at hv
+      rw [Units.val_neg, Units.val_one, ← inv_inv (γ.u : K), hv, inv_neg, inv_one]
+    exact Or.inr (VariableChange.ext hu hr hs (ht.trans neg_zero.symm))
+
+theorem smul_ofJ_eq_iff [DecidableEq K] [CharZero K] (j : K) (h0 : j ≠ 0) (h1728 : j ≠ 1728)
+    (γ : VariableChange K) :
+    γ • WeierstrassCurve.ofJ j = WeierstrassCurve.ofJ j ↔
+      γ = 1 ∨ γ = negVC (WeierstrassCurve.ofJ j) := by
+  rw [WeierstrassCurve.ofJ_ne_0_ne_1728 j h0 h1728]
+  exact smul_ofJNe0Or1728_eq_iff j h0 h1728 γ
+
+section Points
+
+theorem heq_point_zero {W V : WeierstrassCurve.Affine K} (hWV : W = V) :
+    HEq (0 : W.Point) (0 : V.Point) := by
+  subst hWV; rfl
+
+theorem heq_point_some {W V : WeierstrassCurve.Affine K} (hWV : W = V) {x y x' y' : K}
+    (hx : x = x') (hy : y = y') {h : W.Nonsingular x y} {h' : V.Nonsingular x' y'} :
+    HEq (WeierstrassCurve.Affine.Point.some x y h)
+      (WeierstrassCurve.Affine.Point.some x' y' h') := by
+  subst hWV hx hy; rfl
+
+theorem heq_vcInvFun_one (W : WeierstrassCurve K) (P : W.toAffine.Point) :
+    HEq (WeierstrassCurve.Affine.Point.vcInvFun (1 : VariableChange K) W.toAffine P) P := by
+  rcases P with _ | ⟨x, y, h⟩
+  · exact heq_point_zero (one_smul _ _)
+  · refine heq_point_some (one_smul _ _) ?_ ?_
+    · simp [WeierstrassCurve.Affine.vcXInv, VariableChange.one_def]
+    · simp [WeierstrassCurve.Affine.vcYInv, VariableChange.one_def]
+
+theorem heq_vcInvFun_negVC (W : WeierstrassCurve K) (P : W.toAffine.Point) :
+    HEq (WeierstrassCurve.Affine.Point.vcInvFun (negVC W) W.toAffine P) (-P) := by
+  rcases P with _ | ⟨x, y, h⟩
+  · exact heq_point_zero (negVC_smul W)
+  · refine heq_point_some (negVC_smul W) ?_ ?_
+    · simp only [WeierstrassCurve.Affine.vcXInv, val_inv_negVC_u, negVC_r]; ring
+    · simp only [WeierstrassCurve.Affine.vcYInv, val_inv_negVC_u, negVC_r, negVC_s, negVC_t,
+        WeierstrassCurve.Affine.negY]; ring
+
+theorem heq_vcInvFun_mul (γ δ : VariableChange K) (W : WeierstrassCurve K)
+    (P : W.toAffine.Point) :
+    HEq (WeierstrassCurve.Affine.Point.vcInvFun (γ * δ) W.toAffine P)
+      (WeierstrassCurve.Affine.Point.vcInvFun γ (δ • W).toAffine
+        (WeierstrassCurve.Affine.Point.vcInvFun δ W.toAffine P)) := by
+  have hu : (γ.u : K) ≠ 0 := γ.u.ne_zero
+  have hv : (δ.u : K) ≠ 0 := δ.u.ne_zero
+  rcases P with _ | ⟨x, y, h⟩
+  · exact heq_point_zero (mul_smul γ δ W)
+  · refine heq_point_some (mul_smul γ δ W) ?_ ?_
+    · simp only [WeierstrassCurve.Affine.vcXInv, VariableChange.mul_def, mul_inv_rev,
+        Units.val_mul, Units.val_inv_eq_inv_val]
+      field_simp
+      ring
+    · simp only [WeierstrassCurve.Affine.vcXInv, WeierstrassCurve.Affine.vcYInv,
+        VariableChange.mul_def, mul_inv_rev, Units.val_mul, Units.val_inv_eq_inv_val]
+      field_simp
+      ring
+
+theorem heq_vcInvFun_congr (γ : VariableChange K) {W W' : WeierstrassCurve.Affine K}
+    (hW : W = W') {P : W.Point} {P' : W'.Point} (hP : HEq P P') :
+    HEq (WeierstrassCurve.Affine.Point.vcInvFun γ W P)
+      (WeierstrassCurve.Affine.Point.vcInvFun γ W' P') := by
+  subst hW
+  obtain rfl := eq_of_heq hP
+  rfl
+
+theorem zmultiples_eq_of_heq_vcInvFun [DecidableEq K] [CharZero K] {j : K} (h0 : j ≠ 0)
+    (h1728 : j ≠ 1728)
+    {γ : VariableChange K} (hγ : γ • WeierstrassCurve.ofJ j = WeierstrassCurve.ofJ j)
+    {g g' : (WeierstrassCurve.ofJ j).toAffine.Point}
+    (h : HEq g' (WeierstrassCurve.Affine.Point.vcInvFun γ (WeierstrassCurve.ofJ j).toAffine g)) :
+    AddSubgroup.zmultiples g' = AddSubgroup.zmultiples g := by
+  rcases (smul_ofJ_eq_iff j h0 h1728 γ).mp hγ with rfl | rfl
+  · rw [eq_of_heq (h.trans (heq_vcInvFun_one _ g))]
+  · rw [eq_of_heq (h.trans (heq_vcInvFun_negVC _ g)), AddSubgroup.zmultiples_neg]
+
+theorem conj_smul_eq {F E : WeierstrassCurve K} {φ γ : VariableChange K} (hφ : φ • F = E)
+    (hγ : γ • E = E) : (φ⁻¹ * γ * φ) • F = F := by
+  rw [mul_smul, mul_smul, hφ, hγ, ← hφ, inv_smul_smul]
+
+def vcEquivOfSMulEq [DecidableEq K] {F E : WeierstrassCurve K} (φ : VariableChange K)
+    (hφ : φ • F = E) :
+    F.toAffine.Point ≃+ E.toAffine.Point :=
+  (vcAddEquiv φ F).trans (pointAddEquivOfEq hφ)
+
+theorem heq_pointAddEquivOfEq [DecidableEq K] {W V : WeierstrassCurve K} (h : W = V)
+    (P : W.toAffine.Point) :
+    HEq (pointAddEquivOfEq h P) P := by
+  subst h; rfl
+
+theorem heq_vcEquivOfSMulEq [DecidableEq K] {F E : WeierstrassCurve K} (φ : VariableChange K)
+    (hφ : φ • F = E) (P : F.toAffine.Point) :
+    HEq (vcEquivOfSMulEq φ hφ P) (WeierstrassCurve.Affine.Point.vcInvFun φ F.toAffine P) := by
+  subst hφ; rfl
+
+theorem heq_vcInvFun_iff_eq [DecidableEq K] {W : WeierstrassCurve K} (γ : VariableChange K)
+    (hγ : γ • W = W) (g g' : W.toAffine.Point) :
+    HEq g' (WeierstrassCurve.Affine.Point.vcInvFun γ W.toAffine g) ↔
+      g' = vcEquivOfSMulEq γ hγ g :=
+  ⟨fun h => eq_of_heq (h.trans (heq_vcEquivOfSMulEq γ hγ g).symm),
+    fun h => h ▸ heq_vcEquivOfSMulEq γ hγ g⟩
+
+theorem vcEquivOfSMulEq_conj [DecidableEq K] {F E : WeierstrassCurve K} {φ γ : VariableChange K}
+    (hφ : φ • F = E) (hγ : γ • E = E) (P : F.toAffine.Point) :
+    vcEquivOfSMulEq φ hφ (vcEquivOfSMulEq (φ⁻¹ * γ * φ) (conj_smul_eq hφ hγ) P) =
+      vcEquivOfSMulEq γ hγ (vcEquivOfSMulEq φ hφ P) := by
+  apply eq_of_heq
+  have hL₁ := heq_vcEquivOfSMulEq φ hφ (vcEquivOfSMulEq (φ⁻¹ * γ * φ) (conj_smul_eq hφ hγ) P)
+  have hL₂ : HEq (WeierstrassCurve.Affine.Point.vcInvFun φ F.toAffine
+      (vcEquivOfSMulEq (φ⁻¹ * γ * φ) (conj_smul_eq hφ hγ) P))
+      (WeierstrassCurve.Affine.Point.vcInvFun φ ((φ⁻¹ * γ * φ) • F).toAffine
+        (WeierstrassCurve.Affine.Point.vcInvFun (φ⁻¹ * γ * φ) F.toAffine P)) :=
+    heq_vcInvFun_congr φ (congrArg WeierstrassCurve.toAffine (conj_smul_eq hφ hγ).symm)
+      (heq_vcEquivOfSMulEq _ _ P)
+  have hL₃ := (heq_vcInvFun_mul φ (φ⁻¹ * γ * φ) F P).symm
+  have hmul : φ * (φ⁻¹ * γ * φ) = γ * φ := by rw [mul_assoc, mul_inv_cancel_left]
+  have hL₄ : HEq (WeierstrassCurve.Affine.Point.vcInvFun (φ * (φ⁻¹ * γ * φ)) F.toAffine P)
+      (WeierstrassCurve.Affine.Point.vcInvFun (γ * φ) F.toAffine P) := by
+    rw [hmul]
+  have hL₅ := heq_vcInvFun_mul γ φ F P
+  have hR₁ := heq_vcEquivOfSMulEq γ hγ (vcEquivOfSMulEq φ hφ P)
+  have hR₂ : HEq (WeierstrassCurve.Affine.Point.vcInvFun γ E.toAffine (vcEquivOfSMulEq φ hφ P))
+      (WeierstrassCurve.Affine.Point.vcInvFun γ (φ • F).toAffine
+        (WeierstrassCurve.Affine.Point.vcInvFun φ F.toAffine P)) :=
+    heq_vcInvFun_congr γ (congrArg WeierstrassCurve.toAffine hφ.symm) (heq_vcEquivOfSMulEq _ _ P)
+  exact ((((hL₁.trans hL₂).trans hL₃).trans hL₄).trans hL₅).trans (hR₁.trans hR₂).symm
+
+theorem conj_smul_eq' {F E : WeierstrassCurve K} {φ γ' : VariableChange K} (hφ : φ • F = E)
+    (hγ' : γ' • F = F) : (φ * γ' * φ⁻¹) • E = E := by
+  rw [mul_smul, mul_smul, inv_smul_eq_iff.mpr hφ.symm, hγ', hφ]
+
+theorem vcEquivOfSMulEq_congr [DecidableEq K] {F E : WeierstrassCurve K} {φ φ' : VariableChange K}
+    (e : φ = φ') (hφ : φ • F = E) (hφ' : φ' • F = E) :
+    vcEquivOfSMulEq φ hφ = vcEquivOfSMulEq φ' hφ' := by
+  subst e; rfl
+
+theorem eq_conj_of_heq_vcInvFun [DecidableEq K] {F E : WeierstrassCurve K} {φ γ : VariableChange K}
+    (hφ : φ • F = E) (hγ : γ • E = E) (P : F.toAffine.Point) {Q' : E.toAffine.Point}
+    (h : HEq Q' (WeierstrassCurve.Affine.Point.vcInvFun γ E.toAffine (vcEquivOfSMulEq φ hφ P))) :
+    Q' = vcEquivOfSMulEq φ hφ (vcEquivOfSMulEq (φ⁻¹ * γ * φ) (conj_smul_eq hφ hγ) P) := by
+  rw [(heq_vcInvFun_iff_eq γ hγ _ Q').mp h, vcEquivOfSMulEq_conj hφ hγ P]
+
+end Points
+
+theorem sameOrbit_iff (E₀ : WeierstrassCurve Qbar) (H H' : AddSubgroup E₀.toAffine.Point) :
+    SameOrbit E₀ H H' ↔
+      ∃ γ : VariableChange Qbar, ∃ _ : γ • E₀ = E₀, ∃ g g' : E₀.toAffine.Point,
+        H = AddSubgroup.zmultiples g ∧ H' = AddSubgroup.zmultiples g' ∧
+          HEq g' (WeierstrassCurve.Affine.Point.vcInvFun γ E₀.toAffine g) :=
+  Iff.rfl
+
+theorem sameOrbit_refl (E₀ : WeierstrassCurve Qbar) (g : E₀.toAffine.Point) :
+    SameOrbit E₀ (AddSubgroup.zmultiples g) (AddSubgroup.zmultiples g) :=
+  ⟨1, one_smul _ _, g, g, rfl, rfl, (heq_vcInvFun_one E₀ g).symm⟩
+
+theorem sameOrbit_symm {E₀ : WeierstrassCurve Qbar} {H H' : AddSubgroup E₀.toAffine.Point}
+    (h : SameOrbit E₀ H H') : SameOrbit E₀ H' H := by
+  obtain ⟨γ, hγ, g, g', hH, hH', hg⟩ := h
+  refine ⟨γ⁻¹, inv_smul_eq_iff.mpr hγ.symm, g', g, hH', hH, ?_⟩
+  have h₁ : HEq (WeierstrassCurve.Affine.Point.vcInvFun γ⁻¹ E₀.toAffine g')
+      (WeierstrassCurve.Affine.Point.vcInvFun γ⁻¹ (γ • E₀).toAffine
+        (WeierstrassCurve.Affine.Point.vcInvFun γ E₀.toAffine g)) :=
+    heq_vcInvFun_congr γ⁻¹ (congrArg WeierstrassCurve.toAffine hγ.symm) hg
+  have h₂ := (heq_vcInvFun_mul γ⁻¹ γ E₀ g).symm
+  have h₃ : HEq (WeierstrassCurve.Affine.Point.vcInvFun (γ⁻¹ * γ) E₀.toAffine g)
+      (WeierstrassCurve.Affine.Point.vcInvFun (1 : VariableChange Qbar) E₀.toAffine g) := by
+    rw [inv_mul_cancel]
+  exact (((h₁.trans h₂).trans h₃).trans (heq_vcInvFun_one E₀ g)).symm
+
+theorem sameOrbit_ofJ_iff_of_ne (j₀ : Qbar) (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728)
+    (H H' : AddSubgroup (WeierstrassCurve.ofJ j₀).toAffine.Point) :
+    SameOrbit (WeierstrassCurve.ofJ j₀) H H' ↔ H = H' ∧ ∃ g, H = AddSubgroup.zmultiples g := by
+  constructor
+  · rintro ⟨γ, hγ, g, g', rfl, rfl, hg⟩
+    exact ⟨(zmultiples_eq_of_heq_vcInvFun h0 h1728 hγ hg).symm, g, rfl⟩
+  · rintro ⟨rfl, g, rfl⟩
+    exact sameOrbit_refl _ g
+
+theorem sameOrbit_of_conj {F E : WeierstrassCurve Qbar} {φ γ' : VariableChange Qbar}
+    (hφ : φ • F = E) (hγ' : γ' • F = F) (P : F.toAffine.Point) :
+    SameOrbit E (AddSubgroup.zmultiples (vcEquivOfSMulEq φ hφ P))
+      (AddSubgroup.zmultiples (vcEquivOfSMulEq φ hφ (vcEquivOfSMulEq γ' hγ' P))) := by
+  refine ⟨φ * γ' * φ⁻¹, conj_smul_eq' hφ hγ', _, _, rfl, rfl, ?_⟩
+  rw [heq_vcInvFun_iff_eq (φ * γ' * φ⁻¹) (conj_smul_eq' hφ hγ'),
+    ← vcEquivOfSMulEq_conj hφ (conj_smul_eq' hφ hγ') P,
+    vcEquivOfSMulEq_congr (show φ⁻¹ * (φ * γ' * φ⁻¹) * φ = γ' by group)
+      (conj_smul_eq hφ (conj_smul_eq' hφ hγ')) hγ']
+
+section H6B
+
+open WeierstrassCurve.Affine
+
+theorem some_point_ext' {K : Type*} [Field K] {V : WeierstrassCurve.Affine K} {x y x' y' : K}
+    {h : V.Nonsingular x y} {h' : V.Nonsingular x' y'} (hx : x = x') (hy : y = y') :
+    WeierstrassCurve.Affine.Point.some x y h = WeierstrassCurve.Affine.Point.some x' y' h' := by
+  subst hx; subst hy; rfl
+
+theorem pointAddEquivOfEq_apply_of_eq_some {K : Type*} [Field K] [DecidableEq K]
+    {W V : WeierstrassCurve K} (hWV : W = V) {P : W.toAffine.Point} {x y : K}
+    {h : W.toAffine.Nonsingular x y} (hP : P = WeierstrassCurve.Affine.Point.some x y h) :
+    pointAddEquivOfEq hWV P = WeierstrassCurve.Affine.Point.some x y (hWV ▸ h) := by
+  subst hWV
+  rw [pointAddEquivOfEq_rfl, hP]
+  rfl
+
+theorem coeff_zero_of_mem_monodromy {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    (x : H) : (m x).coeff 0 = x.coeff 0 := by
+  obtain ⟨χ, hχ, rfl⟩ := hm
+  rw [HahnSeries.hahnTwistHom_apply, HahnSeries.coeff_hahnTwist, ofAdd_zero, map_one,
+    Units.val_one, one_mul]
+
+theorem orderTop_of_mem_monodromy {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    (x : H) : (m x).orderTop = x.orderTop := by
+  obtain ⟨χ, hχ, rfl⟩ := hm
+  rcases eq_or_ne x 0 with rfl | hx
+  · rw [map_zero]
+  · have hmx : (HahnSeries.hahnTwistHom χ) x ≠ 0 := fun h0 =>
+      hx ((HahnSeries.hahnTwistHom χ).injective (h0.trans (map_zero _).symm))
+    rw [← HahnSeries.order_eq_orderTop_of_ne_zero hx,
+      ← HahnSeries.order_eq_orderTop_of_ne_zero hmx, HahnSeries.hahnTwistHom_apply,
+      HahnSeries.order_hahnTwist]
+
+theorem monodromy_fixes_natSupport {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    (x : H) (hx : ∀ a : ℚ, x.coeff a ≠ 0 → ∃ n : ℕ, a = (n : ℚ)) : m x = x := by
+  obtain ⟨χ, hχ, rfl⟩ := hm
+  rw [HahnSeries.hahnTwistHom_apply]
+  ext a
+  rw [HahnSeries.coeff_hahnTwist]
+  rcases eq_or_ne (x.coeff a) 0 with h0 | h0
+  · rw [h0, mul_zero]
+  · obtain ⟨n, rfl⟩ := hx a h0
+    have hofAdd : Multiplicative.ofAdd ((n : ℚ)) = Multiplicative.ofAdd ((1 : ℚ)) ^ n := by
+      rw [← ofAdd_nsmul, nsmul_eq_mul, mul_one]
+    have hn : χ (Multiplicative.ofAdd ((n : ℚ))) = 1 := by
+      rw [hofAdd, map_pow, HahnSeries.mem_monoChar_iff.mp hχ, one_pow]
+    rw [hn, Units.val_one, one_mul]
+
+theorem monodromy_fixes_ofPowerSeries {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    (f : PowerSeries Qbar) : m (ι f) = ι f := by
+  refine monodromy_fixes_natSupport hm _ fun a ha => ?_
+  by_contra hn
+  rw [not_exists] at hn
+  refine ha ?_
+  rw [HahnSeries.ofPowerSeries_apply]
+  exact HahnSeries.embDomain_of_notMem_range fun hmem => by
+    obtain ⟨n, hna⟩ := hmem
+    exact hn n hna.symm
+
+theorem monodromy_fixes_C (m : H ≃ₐ[Qbar] H) (q : Qbar) :
+    m (HahnSeries.C q) = HahnSeries.C q := by
+  have hC : algebraMap Qbar H q = HahnSeries.C q := by
+    rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_eq, HahnSeries.ofPowerSeries_C]
+  rw [← hC]
+  exact m.commutes q
+
+theorem zeta_pow_eq_one_of_twist {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    {q : ℚ} {ζ : Qbar} {n k : ℕ} (hζs : m (HahnSeries.single q 1) = HahnSeries.single q ζ)
+    (hq : n • q = ((k : ℕ) : ℚ)) : ζ ^ n = 1 := by
+  have hfix : m (HahnSeries.single ((k : ℕ) : ℚ) 1) = HahnSeries.single ((k : ℕ) : ℚ) 1 :=
+    monodromy_fixes_natSupport hm _ fun a ha => ⟨k, by
+      by_contra hne
+      exact ha (HahnSeries.coeff_single_of_ne hne)⟩
+  have key : HahnSeries.single ((k : ℕ) : ℚ) (ζ ^ n) = HahnSeries.single ((k : ℕ) : ℚ) 1 := by
+    calc HahnSeries.single ((k : ℕ) : ℚ) (ζ ^ n)
+        = (HahnSeries.single q ζ) ^ n := by rw [HahnSeries.single_pow, hq]
+      _ = (m (HahnSeries.single q 1)) ^ n := by rw [hζs]
+      _ = m (HahnSeries.single q 1 ^ n) := (map_pow m _ n).symm
+      _ = m (HahnSeries.single ((k : ℕ) : ℚ) 1) := by rw [HahnSeries.single_pow, hq, one_pow]
+      _ = HahnSeries.single ((k : ℕ) : ℚ) 1 := hfix
+  have hcoeff := congrArg (fun z : H => z.coeff ((k : ℕ) : ℚ)) key
+  simpa [HahnSeries.coeff_single_same] using hcoeff
+
+theorem zeta_ne_zero_of_pow_eq_one {ζ : Qbar} {n : ℕ} (hn : n ≠ 0) (h : ζ ^ n = 1) : ζ ≠ 0 := by
+  rintro rfl
+  rw [zero_pow hn] at h
+  exact zero_ne_one h
+
+theorem C_pow_mul_single (c : Qbar) (n : ℕ) (q : ℚ) :
+    HahnSeries.C c ^ n * HahnSeries.single q (1 : Qbar) = HahnSeries.single q (c ^ n) := by
+  rw [show (HahnSeries.C c : H) = HahnSeries.single 0 c from rfl, HahnSeries.single_pow,
+    HahnSeries.single_mul_single, smul_zero, zero_add, mul_one]
+
+theorem single_two_twelfths :
+    HahnSeries.single (2 / 12 : ℚ) (1 : Qbar) = HahnSeries.single (1 / 6 : ℚ) 1 := by
+  rw [show (2 / 12 : ℚ) = 1 / 6 by norm_num]
+
+theorem m_single_sixth {m : H ≃ₐ[Qbar] H} {ζ : Qbar}
+    (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ) :
+    m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.C ζ * HahnSeries.single (1 / 6 : ℚ) 1 := by
+  rw [hζs, show (HahnSeries.C ζ : H) * HahnSeries.single (1 / 6 : ℚ) 1 =
+    HahnSeries.single (1 / 6 : ℚ) (ζ ^ 1) from by
+      rw [← C_pow_mul_single ζ 1 (1 / 6 : ℚ), pow_one], pow_one]
+
+theorem m_single_third {m : H ≃ₐ[Qbar] H} {ζ : Qbar}
+    (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ) :
+    m (HahnSeries.single (1 / 3 : ℚ) 1) =
+      HahnSeries.C ζ ^ 2 * HahnSeries.single (1 / 3 : ℚ) 1 := by
+  have h13 : HahnSeries.single (1 / 3 : ℚ) (1 : Qbar) =
+      HahnSeries.single (1 / 6 : ℚ) 1 * HahnSeries.single (1 / 6 : ℚ) 1 := by
+    rw [HahnSeries.single_mul_single, mul_one]
+    congr 1
+    norm_num
+  rw [C_pow_mul_single, h13, map_mul, hζs, HahnSeries.single_mul_single]
+  congr 1
+  · norm_num
+  · ring
+
+theorem m_single_quarter_1728 {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    {ζ : Qbar} (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ) :
+    m (HahnSeries.single (1 / 4 : ℚ) 1) =
+      HahnSeries.C ζ ^ 3 * HahnSeries.single (1 / 4 : ℚ) 1 := by
+  obtain ⟨χ, hχ, rfl⟩ := hm
+  rw [HahnSeries.hahnTwistHom_apply] at hζs ⊢
+  rw [HahnSeries.hahnTwist_single] at hζs ⊢
+  have hval : (χ (Multiplicative.ofAdd (3 / 4 : ℚ)) : Qbar) = ζ := by
+    have hcoeff := congrArg (fun z : H => z.coeff (3 / 4 : ℚ)) hζs
+    simpa [HahnSeries.coeff_single_same] using hcoeff
+  have hc4 : (χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar) ^ 4 = 1 := by
+    have h14 : (4 : ℕ) • (1 / 4 : ℚ) = (1 : ℚ) := by norm_num
+    have h := HahnSeries.mem_monoChar_iff.mp hχ
+    rw [← h14, ofAdd_nsmul, map_pow] at h
+    calc (χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar) ^ 4
+        = ((χ (Multiplicative.ofAdd (1 / 4 : ℚ)) ^ 4 : Qbarˣ) : Qbar) :=
+          (Units.val_pow_eq_pow_val _ _).symm
+      _ = ((1 : Qbarˣ) : Qbar) := by rw [h]
+      _ = 1 := Units.val_one
+  have hc3 : (χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar) ^ 3 = ζ := by
+    have h34 : (3 : ℕ) • (1 / 4 : ℚ) = (3 / 4 : ℚ) := by norm_num
+    rw [← hval, ← h34, ofAdd_nsmul, map_pow]
+    exact (Units.val_pow_eq_pow_val _ _).symm
+  have hc : (χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar) = ζ ^ 3 := by
+    calc (χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar)
+        = ((χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar) ^ 4) ^ 2 *
+            (χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar) := by rw [hc4]; ring
+      _ = ((χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar) ^ 3) ^ 3 := by ring
+      _ = ζ ^ 3 := by rw [hc3]
+  rw [C_pow_mul_single, mul_one, hc]
+
+theorem m_single_half_1728 {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    {ζ : Qbar} (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ) :
+    m (HahnSeries.single (1 / 2 : ℚ) 1) =
+      HahnSeries.C ζ ^ 2 * HahnSeries.single (1 / 2 : ℚ) 1 := by
+  have hζ4 : ζ ^ 4 = 1 := zeta_pow_eq_one_of_twist (k := 3) hm hζs (by norm_num)
+  have h12 : HahnSeries.single (1 / 2 : ℚ) (1 : Qbar) =
+      HahnSeries.single (1 / 4 : ℚ) 1 * HahnSeries.single (1 / 4 : ℚ) 1 := by
+    rw [HahnSeries.single_mul_single, mul_one]
+    congr 1
+    norm_num
+  rw [C_pow_mul_single, h12, map_mul, m_single_quarter_1728 hm hζs, C_pow_mul_single,
+    HahnSeries.single_mul_single]
+  congr 1
+  · norm_num
+  · calc ζ ^ 3 * ζ ^ 3 = ζ ^ 4 * ζ ^ 2 := by ring
+      _ = ζ ^ 2 := by rw [hζ4, one_mul]
+
+theorem C_mul_single (c : Qbar) (q : ℚ) :
+    HahnSeries.C c * HahnSeries.single q (1 : Qbar) = HahnSeries.single q c := by
+  rw [show (HahnSeries.C c : H) = HahnSeries.single 0 c from rfl, HahnSeries.single_mul_single,
+    zero_add, mul_one]
+
+theorem coeff_zero_C (c : Qbar) : (HahnSeries.C c : H).coeff 0 = c := by
+  rw [show (HahnSeries.C c : H) = HahnSeries.single 0 c from rfl]
+  simp
+
+theorem m_a4_zero (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar) (ζ : Qbar)
+    (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ) :
+    m (goodModel 0).a₄ = HahnSeries.C ζ ^ 2 * (goodModel 0).a₄ := by
+  rw [goodModel_zero_eq]
+  change m (HahnSeries.single (1 / 3 : ℚ) 1 *
+      ι (PowerSeries.C (-1 / 48 : Qbar) * (PowerSeries.X - PowerSeries.C 1728) ^ 3)) =
+    HahnSeries.C ζ ^ 2 * (HahnSeries.single (1 / 3 : ℚ) 1 *
+      ι (PowerSeries.C (-1 / 48 : Qbar) * (PowerSeries.X - PowerSeries.C 1728) ^ 3))
+  rw [map_mul, m_single_third hζs, monodromy_fixes_ofPowerSeries hm]
+  ring
+
+theorem m_a6_zero (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar) :
+    m (goodModel 0).a₆ = (goodModel 0).a₆ := by
+  rw [goodModel_zero_eq]
+  change m (ι (PowerSeries.C (1 / 864 : Qbar) * (PowerSeries.X - PowerSeries.C 1728) ^ 5)) =
+    ι (PowerSeries.C (1 / 864 : Qbar) * (PowerSeries.X - PowerSeries.C 1728) ^ 5)
+  exact monodromy_fixes_ofPowerSeries hm _
+
+theorem m_a1_1728 (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar) (ζ : Qbar)
+    (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ) :
+    m (goodModel 1728).a₁ = HahnSeries.C ζ ^ 3 * (goodModel 1728).a₁ := by
+  rw [goodModel_1728_eq]
+  change m (HahnSeries.single (1 / 4 : ℚ) 1) = HahnSeries.C ζ ^ 3 * HahnSeries.single (1 / 4 : ℚ) 1
+  exact m_single_quarter_1728 hm hζs
+
+theorem m_a4_1728 (m : H ≃ₐ[Qbar] H) : m (goodModel 1728).a₄ = (goodModel 1728).a₄ := by
+  rw [goodModel_1728_eq]
+  change m (HahnSeries.C (-36)) = HahnSeries.C (-36)
+  exact monodromy_fixes_C m (-36)
+
+theorem m_a6_1728 (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar) (ζ : Qbar)
+    (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ) :
+    m (goodModel 1728).a₆ = HahnSeries.C ζ ^ 2 * (goodModel 1728).a₆ := by
+  rw [goodModel_1728_eq]
+  change m (-HahnSeries.single (1 / 2 : ℚ) 1) =
+    HahnSeries.C ζ ^ 2 * -HahnSeries.single (1 / 2 : ℚ) 1
+  rw [map_neg, m_single_half_1728 hm hζs]
+  ring
+
+theorem map_goodModel_zero (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar) (ζ : Qbar)
+    (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ) :
+    (goodModel 0).map (m : H →+* H) =
+      ⟨0, 0, 0, HahnSeries.C ζ ^ 2 * (goodModel 0).a₄, (goodModel 0).a₆⟩ := by
+  have ha1 : (goodModel 0).a₁ = 0 := by rw [goodModel_zero_eq]
+  have ha2 : (goodModel 0).a₂ = 0 := by rw [goodModel_zero_eq]
+  have ha3 : (goodModel 0).a₃ = 0 := by rw [goodModel_zero_eq]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_
+  · change m (goodModel 0).a₁ = 0
+    rw [ha1, map_zero]
+  · change m (goodModel 0).a₂ = 0
+    rw [ha2, map_zero]
+  · change m (goodModel 0).a₃ = 0
+    rw [ha3, map_zero]
+  · change m (goodModel 0).a₄ = HahnSeries.C ζ ^ 2 * (goodModel 0).a₄
+    exact m_a4_zero m hm ζ hζs
+  · change m (goodModel 0).a₆ = (goodModel 0).a₆
+    exact m_a6_zero m hm
+
+theorem map_goodModel_1728 (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar) (ζ : Qbar)
+    (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ) :
+    (goodModel 1728).map (m : H →+* H) =
+      ⟨HahnSeries.C ζ ^ 3 * (goodModel 1728).a₁, 0, 0, (goodModel 1728).a₄,
+        HahnSeries.C ζ ^ 2 * (goodModel 1728).a₆⟩ := by
+  have ha2 : (goodModel 1728).a₂ = 0 := by rw [goodModel_1728_eq]
+  have ha3 : (goodModel 1728).a₃ = 0 := by rw [goodModel_1728_eq]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_
+  · change m (goodModel 1728).a₁ = HahnSeries.C ζ ^ 3 * (goodModel 1728).a₁
+    exact m_a1_1728 m hm ζ hζs
+  · change m (goodModel 1728).a₂ = 0
+    rw [ha2, map_zero]
+  · change m (goodModel 1728).a₃ = 0
+    rw [ha3, map_zero]
+  · change m (goodModel 1728).a₄ = (goodModel 1728).a₄
+    exact m_a4_1728 m
+  · change m (goodModel 1728).a₆ = HahnSeries.C ζ ^ 2 * (goodModel 1728).a₆
+    exact m_a6_1728 m hm ζ hζs
+
+theorem nonsingular_fibreTwist_zero {ζ : Qbar} (hζ6 : ζ ^ 6 = 1) {x₀ y₀ : Qbar}
+    (h₀ : (specialFibre (goodModel 0)).toAffine.Nonsingular x₀ y₀) :
+    (specialFibre (goodModel 0)).toAffine.Nonsingular (ζ ^ 2 * x₀) (ζ ^ 3 * y₀) := by
+  have e1 : (specialFibre (goodModel 0)).a₁ = 0 := by rw [specialFibre_goodModel_zero]
+  have e2 : (specialFibre (goodModel 0)).a₂ = 0 := by rw [specialFibre_goodModel_zero]
+  have e3 : (specialFibre (goodModel 0)).a₃ = 0 := by rw [specialFibre_goodModel_zero]
+  have e4 : (specialFibre (goodModel 0)).a₄ = 0 := by rw [specialFibre_goodModel_zero]
+  rw [← WeierstrassCurve.Affine.equation_iff_nonsingular] at h₀ ⊢
+  rw [WeierstrassCurve.Affine.equation_iff] at h₀ ⊢
+  rw [e1, e2, e3, e4] at h₀ ⊢
+  linear_combination ζ ^ 6 * h₀ + (specialFibre (goodModel 0)).a₆ * hζ6
+
+theorem nonsingular_fibreTwist_1728 {ζ : Qbar} (hζ4 : ζ ^ 4 = 1) {x₀ y₀ : Qbar}
+    (h₀ : (specialFibre (goodModel 1728)).toAffine.Nonsingular x₀ y₀) :
+    (specialFibre (goodModel 1728)).toAffine.Nonsingular (ζ ^ 2 * x₀) (ζ ^ 3 * y₀) := by
+  have e1 : (specialFibre (goodModel 1728)).a₁ = 0 := by rw [specialFibre_goodModel_1728]
+  have e2 : (specialFibre (goodModel 1728)).a₂ = 0 := by rw [specialFibre_goodModel_1728]
+  have e3 : (specialFibre (goodModel 1728)).a₃ = 0 := by rw [specialFibre_goodModel_1728]
+  have e6 : (specialFibre (goodModel 1728)).a₆ = 0 := by rw [specialFibre_goodModel_1728]
+  rw [← WeierstrassCurve.Affine.equation_iff_nonsingular] at h₀ ⊢
+  rw [WeierstrassCurve.Affine.equation_iff] at h₀ ⊢
+  rw [e1, e2, e3, e6] at h₀ ⊢
+  linear_combination ζ ^ 2 * h₀ + ζ ^ 2 * (y₀ ^ 2 - x₀ ^ 3) * hζ4
+
+def fibreTwistVC (ζ : Qbar) (hζ0 : ζ ≠ 0) : VariableChange Qbar :=
+  ⟨(Units.mk0 ζ hζ0)⁻¹, 0, 0, 0⟩
+
+theorem fibreTwistVC_smul_fibre_zero {ζ : Qbar} (hζ0 : ζ ≠ 0) (hζ6 : ζ ^ 6 = 1) :
+    fibreTwistVC ζ hζ0 • specialFibre (goodModel 0) = specialFibre (goodModel 0) := by
+  rw [specialFibre_goodModel_zero, WeierstrassCurve.variableChange_def]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_ <;> simp [fibreTwistVC, hζ6]
+
+theorem fibreTwistVC_smul_fibre_1728 {ζ : Qbar} (hζ0 : ζ ≠ 0) (hζ4 : ζ ^ 4 = 1) :
+    fibreTwistVC ζ hζ0 • specialFibre (goodModel 1728) = specialFibre (goodModel 1728) := by
+  rw [specialFibre_goodModel_1728, WeierstrassCurve.variableChange_def]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_ <;> simp [fibreTwistVC, hζ4]
+
+theorem vcInvFun_eq_some {K : Type*} [Field K] {C : VariableChange K}
+    {W : WeierstrassCurve K} {x y : K} (h : W.toAffine.Nonsingular x y)
+    (h' : (C • W).toAffine.Nonsingular (WeierstrassCurve.Affine.vcXInv C x)
+      (WeierstrassCurve.Affine.vcYInv C x y)) :
+    WeierstrassCurve.Affine.Point.vcInvFun C W.toAffine
+        (WeierstrassCurve.Affine.Point.some x y h) =
+      WeierstrassCurve.Affine.Point.some (WeierstrassCurve.Affine.vcXInv C x)
+        (WeierstrassCurve.Affine.vcYInv C x y) h' := rfl
+
+theorem stab_equiv_some {K : Type*} [Field K] [DecidableEq K] {W : WeierstrassCurve K}
+    {φ : VariableChange K} (hφ : φ • W = W) {x y : K} (h : W.toAffine.Nonsingular x y)
+    {x' y' : K} (hx' : WeierstrassCurve.Affine.vcXInv φ x = x')
+    (hy' : WeierstrassCurve.Affine.vcYInv φ x y = y')
+    (h' : W.toAffine.Nonsingular x' y') :
+    ((vcAddEquiv φ W).trans (pointAddEquivOfEq hφ))
+        (WeierstrassCurve.Affine.Point.some x y h) =
+      WeierstrassCurve.Affine.Point.some x' y' h' := by
+  subst hx'
+  subst hy'
+  have hns : (φ • W).toAffine.Nonsingular (WeierstrassCurve.Affine.vcXInv φ x)
+      (WeierstrassCurve.Affine.vcYInv φ x y) := by
+    rw [hφ]
+    exact h'
+  have h1 : ((vcAddEquiv φ W).trans (pointAddEquivOfEq hφ))
+      (WeierstrassCurve.Affine.Point.some x y h) =
+      pointAddEquivOfEq hφ (vcAddEquiv φ W (WeierstrassCurve.Affine.Point.some x y h)) := rfl
+  rw [h1, vcAddEquiv_apply, vcInvFun_eq_some h hns,
+    pointAddEquivOfEq_apply_of_eq_some hφ rfl]
+
+def fibreTwistEquiv_zero (ζ : Qbar) (hζ0 : ζ ≠ 0) (hζ6 : ζ ^ 6 = 1) :
+    (specialFibre (goodModel 0)).toAffine.Point ≃+
+      (specialFibre (goodModel 0)).toAffine.Point :=
+  (vcAddEquiv (fibreTwistVC ζ hζ0) (specialFibre (goodModel 0))).trans
+    (pointAddEquivOfEq (fibreTwistVC_smul_fibre_zero hζ0 hζ6))
+
+def fibreTwistEquiv_1728 (ζ : Qbar) (hζ0 : ζ ≠ 0) (hζ4 : ζ ^ 4 = 1) :
+    (specialFibre (goodModel 1728)).toAffine.Point ≃+
+      (specialFibre (goodModel 1728)).toAffine.Point :=
+  (vcAddEquiv (fibreTwistVC ζ hζ0) (specialFibre (goodModel 1728))).trans
+    (pointAddEquivOfEq (fibreTwistVC_smul_fibre_1728 hζ0 hζ4))
+
+theorem fibreTwistEquiv_zero_some (ζ : Qbar) (hζ0 : ζ ≠ 0) (hζ6 : ζ ^ 6 = 1) {x₀ y₀ : Qbar}
+    (h₀ : (specialFibre (goodModel 0)).toAffine.Nonsingular x₀ y₀) :
+    fibreTwistEquiv_zero ζ hζ0 hζ6 (WeierstrassCurve.Affine.Point.some x₀ y₀ h₀) =
+      WeierstrassCurve.Affine.Point.some (ζ ^ 2 * x₀) (ζ ^ 3 * y₀)
+        (nonsingular_fibreTwist_zero hζ6 h₀) := by
+  refine stab_equiv_some (fibreTwistVC_smul_fibre_zero hζ0 hζ6) h₀ ?_ ?_
+    (nonsingular_fibreTwist_zero hζ6 h₀)
+  · change (((fibreTwistVC ζ hζ0).u⁻¹ : Qbarˣ) : Qbar) ^ 2 * (x₀ - (fibreTwistVC ζ hζ0).r) =
+      ζ ^ 2 * x₀
+    simp [fibreTwistVC]
+  · change (((fibreTwistVC ζ hζ0).u⁻¹ : Qbarˣ) : Qbar) ^ 3 * (y₀ - (fibreTwistVC ζ hζ0).t -
+        (fibreTwistVC ζ hζ0).s * (x₀ - (fibreTwistVC ζ hζ0).r)) = ζ ^ 3 * y₀
+    simp [fibreTwistVC]
+
+theorem fibreTwistEquiv_1728_some (ζ : Qbar) (hζ0 : ζ ≠ 0) (hζ4 : ζ ^ 4 = 1) {x₀ y₀ : Qbar}
+    (h₀ : (specialFibre (goodModel 1728)).toAffine.Nonsingular x₀ y₀) :
+    fibreTwistEquiv_1728 ζ hζ0 hζ4 (WeierstrassCurve.Affine.Point.some x₀ y₀ h₀) =
+      WeierstrassCurve.Affine.Point.some (ζ ^ 2 * x₀) (ζ ^ 3 * y₀)
+        (nonsingular_fibreTwist_1728 hζ4 h₀) := by
+  refine stab_equiv_some (fibreTwistVC_smul_fibre_1728 hζ0 hζ4) h₀ ?_ ?_
+    (nonsingular_fibreTwist_1728 hζ4 h₀)
+  · change (((fibreTwistVC ζ hζ0).u⁻¹ : Qbarˣ) : Qbar) ^ 2 * (x₀ - (fibreTwistVC ζ hζ0).r) =
+      ζ ^ 2 * x₀
+    simp [fibreTwistVC]
+  · change (((fibreTwistVC ζ hζ0).u⁻¹ : Qbarˣ) : Qbar) ^ 3 * (y₀ - (fibreTwistVC ζ hζ0).t -
+        (fibreTwistVC ζ hζ0).s * (x₀ - (fibreTwistVC ζ hζ0).r)) = ζ ^ 3 * y₀
+    simp [fibreTwistVC]
+
+theorem nonsingular_conj_zero (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar)
+    (ζ : Qbar) (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ)
+    {x y : H} (h : (goodModel 0).toAffine.Nonsingular x y) :
+    (goodModel 0).toAffine.Nonsingular (HahnSeries.C ζ ^ 2 * m x)
+      (HahnSeries.C ζ ^ 3 * m y) := by
+  have hζ6 : ζ ^ 6 = 1 := zeta_pow_eq_one_of_twist (k := 1) hm hζs (by norm_num)
+  have hC6 : (HahnSeries.C ζ : H) ^ 6 = 1 := by
+    rw [← map_pow, hζ6, map_one]
+  have ha1 : (goodModel 0).a₁ = 0 := by rw [goodModel_zero_eq]
+  have ha2 : (goodModel 0).a₂ = 0 := by rw [goodModel_zero_eq]
+  have ha3 : (goodModel 0).a₃ = 0 := by rw [goodModel_zero_eq]
+  rw [← WeierstrassCurve.Affine.equation_iff_nonsingular] at h ⊢
+  rw [WeierstrassCurve.Affine.equation_iff] at h ⊢
+  rw [ha1, ha2, ha3] at h ⊢
+  have hme := congrArg m h
+  simp only [map_add, map_mul, map_pow, map_zero] at hme
+  rw [m_a4_zero m hm ζ hζs, m_a6_zero m hm] at hme
+  linear_combination HahnSeries.C ζ ^ 6 * hme +
+    (HahnSeries.C ζ ^ 2 * (goodModel 0).a₄ * m x + (goodModel 0).a₆) * hC6
+
+theorem nonsingular_conj_1728 (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar)
+    (ζ : Qbar) (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ)
+    {x y : H} (h : (goodModel 1728).toAffine.Nonsingular x y) :
+    (goodModel 1728).toAffine.Nonsingular (HahnSeries.C ζ ^ 2 * m x)
+      (HahnSeries.C ζ ^ 3 * m y) := by
+  have hζ4 : ζ ^ 4 = 1 := zeta_pow_eq_one_of_twist (k := 3) hm hζs (by norm_num)
+  have hC4 : (HahnSeries.C ζ : H) ^ 4 = 1 := by
+    rw [← map_pow, hζ4, map_one]
+  have ha2 : (goodModel 1728).a₂ = 0 := by rw [goodModel_1728_eq]
+  have ha3 : (goodModel 1728).a₃ = 0 := by rw [goodModel_1728_eq]
+  rw [← WeierstrassCurve.Affine.equation_iff_nonsingular] at h ⊢
+  rw [WeierstrassCurve.Affine.equation_iff] at h ⊢
+  rw [ha2, ha3] at h ⊢
+  have hme := congrArg m h
+  simp only [map_add, map_mul, map_pow, map_zero] at hme
+  rw [m_a1_1728 m hm ζ hζs, m_a4_1728 m, m_a6_1728 m hm ζ hζs] at hme
+  linear_combination HahnSeries.C ζ ^ 2 * hme +
+    (HahnSeries.C ζ ^ 2 * ((m y) ^ 2 - (m x) ^ 3) + (goodModel 1728).a₆) * hC4
+
+theorem nonsingular_cocycle_zero (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar)
+    {ζ : Qbar} (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ)
+    {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : (goodModel 0).toAffine.Nonsingular x y) :
+    (specialFibre (goodModel 0)).toAffine.Nonsingular (ζ ^ 2 * x.coeff 0)
+      (ζ ^ 3 * y.coeff 0) :=
+  nonsingular_fibreTwist_zero (zeta_pow_eq_one_of_twist (k := 1) hm hζs (by norm_num))
+    (nonsingular_specialFibre _ (goodModel_spec 0).1 (goodModel_spec 0).2 hx hy h)
+
+theorem nonsingular_cocycle_1728 (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar)
+    {ζ : Qbar} (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ)
+    {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : (goodModel 1728).toAffine.Nonsingular x y) :
+    (specialFibre (goodModel 1728)).toAffine.Nonsingular (ζ ^ 2 * x.coeff 0)
+      (ζ ^ 3 * y.coeff 0) :=
+  nonsingular_fibreTwist_1728 (zeta_pow_eq_one_of_twist (k := 3) hm hζs (by norm_num))
+    (nonsingular_specialFibre _ (goodModel_spec 1728).1 (goodModel_spec 1728).2 hx hy h)
+
+theorem fixedTransport_conj_zero (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar)
+    (ζ : Qbar) (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ)
+    (hE : (nearCurve 0).map (m : H →+* H) = nearCurve 0)
+    {x y : H} (h : (goodModel 0).toAffine.Nonsingular x y) :
+    scaleAddEquiv 0 (WeierstrassCurve.Affine.Point.fixedTransport m (nearCurve 0) hE
+        ((scaleAddEquiv 0).symm (WeierstrassCurve.Affine.Point.some x y h))) =
+      WeierstrassCurve.Affine.Point.some (HahnSeries.C ζ ^ 2 * m x)
+        (HahnSeries.C ζ ^ 3 * m y) (nonsingular_conj_zero m hm ζ hζs h) := by
+  have hA : m (jNear 0 - 1728) = jNear 0 - 1728 := by
+    rw [jNear_zero, map_sub, HahnSeries.fixes_single_one_of_mem_monodromy hm, map_ofNat]
+  have hmu : m (((scaleVC 0).u : Hˣ) : H) = HahnSeries.C ζ * (((scaleVC 0).u : Hˣ) : H) := by
+    rw [scaleVC_zero]
+    change m (HahnSeries.single (2 / 12 : ℚ) 1) = HahnSeries.C ζ * HahnSeries.single (2 / 12 : ℚ) 1
+    rw [single_two_twelfths]
+    exact m_single_sixth hζs
+  have hmr : m ((scaleVC 0).r) = (scaleVC 0).r := by
+    rw [scaleVC_zero]
+    change m (-(jNear 0 - 1728) ^ 2 / 12) = -(jNear 0 - 1728) ^ 2 / 12
+    rw [map_div₀, map_neg, map_pow, hA, map_ofNat]
+  have hms : m ((scaleVC 0).s) = (scaleVC 0).s := by
+    rw [scaleVC_zero]
+    change m (-(jNear 0 - 1728) / 2) = -(jNear 0 - 1728) / 2
+    rw [map_div₀, map_neg, hA, map_ofNat]
+  have hmt : m ((scaleVC 0).t) = (scaleVC 0).t := by
+    rw [scaleVC_zero]
+    change m ((jNear 0 - 1728) ^ 3 / 24) = (jNear 0 - 1728) ^ 3 / 24
+    rw [map_div₀, map_pow, hA, map_ofNat]
+  have huu : (((scaleVC 0).u⁻¹ : Hˣ) : H) * (((scaleVC 0).u : Hˣ) : H) = 1 := by simp
+  have hP : (scaleAddEquiv 0).symm (WeierstrassCurve.Affine.Point.some x y h) =
+      WeierstrassCurve.Affine.Point.some
+        (WeierstrassCurve.Affine.vcX (scaleVC 0) x)
+        (WeierstrassCurve.Affine.vcY (scaleVC 0) x y)
+        ((WeierstrassCurve.Affine.nonsingular_variableChange_iff
+          (C := scaleVC 0) (W := (nearCurve 0).toAffine) x y).mp h) := rfl
+  rw [hP, WeierstrassCurve.Affine.Point.fixedTransport_some]
+  refine some_point_ext' ?_ ?_
+  · change (((scaleVC 0).u⁻¹ : Hˣ) : H) ^ 2 *
+        (m ((((scaleVC 0).u : Hˣ) : H) ^ 2 * x + (scaleVC 0).r) - (scaleVC 0).r) =
+      HahnSeries.C ζ ^ 2 * m x
+    simp only [map_add, map_mul, map_pow]
+    rw [hmu, hmr, add_sub_cancel_right]
+    linear_combination (HahnSeries.C ζ ^ 2 * m x) *
+      ((((scaleVC 0).u⁻¹ : Hˣ) : H) * (((scaleVC 0).u : Hˣ) : H) + 1) * huu
+  · change (((scaleVC 0).u⁻¹ : Hˣ) : H) ^ 3 *
+        (m ((((scaleVC 0).u : Hˣ) : H) ^ 3 * y + (((scaleVC 0).u : Hˣ) : H) ^ 2 * (scaleVC 0).s * x
+            + (scaleVC 0).t) - (scaleVC 0).t -
+          (scaleVC 0).s * (m ((((scaleVC 0).u : Hˣ) : H) ^ 2 * x + (scaleVC 0).r) -
+            (scaleVC 0).r)) =
+      HahnSeries.C ζ ^ 3 * m y
+    simp only [map_add, map_mul, map_pow]
+    rw [hmu, hmr, hms, hmt]
+    linear_combination (HahnSeries.C ζ ^ 3 * m y) *
+      (((((scaleVC 0).u⁻¹ : Hˣ) : H) * (((scaleVC 0).u : Hˣ) : H)) ^ 2 +
+        (((scaleVC 0).u⁻¹ : Hˣ) : H) * (((scaleVC 0).u : Hˣ) : H) + 1) * huu
+
+theorem fixedTransport_conj_1728 (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar)
+    (ζ : Qbar) (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ)
+    (hE : (nearCurve 1728).map (m : H →+* H) = nearCurve 1728)
+    {x y : H} (h : (goodModel 1728).toAffine.Nonsingular x y) :
+    scaleAddEquiv 1728 (WeierstrassCurve.Affine.Point.fixedTransport m (nearCurve 1728) hE
+        ((scaleAddEquiv 1728).symm (WeierstrassCurve.Affine.Point.some x y h))) =
+      WeierstrassCurve.Affine.Point.some (HahnSeries.C ζ ^ 2 * m x)
+        (HahnSeries.C ζ ^ 3 * m y) (nonsingular_conj_1728 m hm ζ hζs h) := by
+  have hmu : m (((scaleVC 1728).u : Hˣ) : H) =
+      HahnSeries.C ζ * (((scaleVC 1728).u : Hˣ) : H) := by
+    rw [scaleVC_1728]
+    change m (HahnSeries.single (9 / 12 : ℚ) 1) =
+      HahnSeries.C ζ * HahnSeries.single (9 / 12 : ℚ) 1
+    rw [show (9 / 12 : ℚ) = 3 / 4 by norm_num, hζs, C_mul_single]
+  have hmr : m ((scaleVC 1728).r) = (scaleVC 1728).r := by
+    rw [scaleVC_1728]
+    change m (0 : H) = (0 : H)
+    exact map_zero m
+  have hms : m ((scaleVC 1728).s) = (scaleVC 1728).s := by
+    rw [scaleVC_1728]
+    change m (0 : H) = (0 : H)
+    exact map_zero m
+  have hmt : m ((scaleVC 1728).t) = (scaleVC 1728).t := by
+    rw [scaleVC_1728]
+    change m (0 : H) = (0 : H)
+    exact map_zero m
+  have huu : (((scaleVC 1728).u⁻¹ : Hˣ) : H) * (((scaleVC 1728).u : Hˣ) : H) = 1 := by simp
+  have hP : (scaleAddEquiv 1728).symm (WeierstrassCurve.Affine.Point.some x y h) =
+      WeierstrassCurve.Affine.Point.some
+        (WeierstrassCurve.Affine.vcX (scaleVC 1728) x)
+        (WeierstrassCurve.Affine.vcY (scaleVC 1728) x y)
+        ((WeierstrassCurve.Affine.nonsingular_variableChange_iff
+          (C := scaleVC 1728) (W := (nearCurve 1728).toAffine) x y).mp h) := rfl
+  rw [hP, WeierstrassCurve.Affine.Point.fixedTransport_some]
+  refine some_point_ext' ?_ ?_
+  · change (((scaleVC 1728).u⁻¹ : Hˣ) : H) ^ 2 *
+        (m ((((scaleVC 1728).u : Hˣ) : H) ^ 2 * x + (scaleVC 1728).r) - (scaleVC 1728).r) =
+      HahnSeries.C ζ ^ 2 * m x
+    simp only [map_add, map_mul, map_pow]
+    rw [hmu, hmr, add_sub_cancel_right]
+    linear_combination (HahnSeries.C ζ ^ 2 * m x) *
+      ((((scaleVC 1728).u⁻¹ : Hˣ) : H) * (((scaleVC 1728).u : Hˣ) : H) + 1) * huu
+  · change (((scaleVC 1728).u⁻¹ : Hˣ) : H) ^ 3 *
+        (m ((((scaleVC 1728).u : Hˣ) : H) ^ 3 * y +
+            (((scaleVC 1728).u : Hˣ) : H) ^ 2 * (scaleVC 1728).s * x + (scaleVC 1728).t) -
+          (scaleVC 1728).t -
+          (scaleVC 1728).s * (m ((((scaleVC 1728).u : Hˣ) : H) ^ 2 * x + (scaleVC 1728).r) -
+            (scaleVC 1728).r)) =
+      HahnSeries.C ζ ^ 3 * m y
+    simp only [map_add, map_mul, map_pow]
+    rw [hmu, hmr, hms, hmt]
+    linear_combination (HahnSeries.C ζ ^ 3 * m y) *
+      (((((scaleVC 1728).u⁻¹ : Hˣ) : H) * (((scaleVC 1728).u : Hˣ) : H)) ^ 2 +
+        (((scaleVC 1728).u⁻¹ : Hˣ) : H) * (((scaleVC 1728).u : Hˣ) : H) + 1) * huu
+
+theorem cocycle_zero_point (j₀ : Qbar) (m : H ≃ₐ[Qbar] H)
+    (hE : (nearCurve j₀).map (m : H →+* H) = nearCurve j₀) :
+    scaleAddEquiv j₀ (WeierstrassCurve.Affine.Point.fixedTransport m (nearCurve j₀) hE
+      ((scaleAddEquiv j₀).symm 0)) = 0 := by
+  simp only [map_zero]
+
+theorem redPoint_monodromy_cocycle_zero (m : H ≃ₐ[Qbar] H)
+    (hm : m ∈ HahnSeries.monodromy Qbar) (ζ : Qbar)
+    (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ)
+    (hE : (nearCurve 0).map (m : H →+* H) = nearCurve 0)
+    {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : (goodModel 0).toAffine.Nonsingular x y) :
+    redPoint (goodModel 0) (goodModel_spec 0).1 (goodModel_spec 0).2
+        (scaleAddEquiv 0 (WeierstrassCurve.Affine.Point.fixedTransport m (nearCurve 0) hE
+          ((scaleAddEquiv 0).symm (WeierstrassCurve.Affine.Point.some x y h)))) =
+      WeierstrassCurve.Affine.Point.some (ζ ^ 2 * x.coeff 0) (ζ ^ 3 * y.coeff 0)
+        (nonsingular_cocycle_zero m hm hζs hx hy h) := by
+  rw [fixedTransport_conj_zero m hm ζ hζs hE h]
+  have hCint : 0 ≤ (HahnSeries.C ζ : H).orderTop := by
+    rw [← HahnSeries.ofPowerSeries_C]
+    exact orderTop_ofPowerSeries_nonneg _
+  have hmx : 0 ≤ (m x).orderTop := by
+    rw [orderTop_of_mem_monodromy hm]
+    exact hx
+  have hmy : 0 ≤ (m y).orderTop := by
+    rw [orderTop_of_mem_monodromy hm]
+    exact hy
+  rw [redPoint_some _ _ _ (orderTop_mul_nonneg (orderTop_pow_nonneg hCint 2) hmx)
+    (orderTop_mul_nonneg (orderTop_pow_nonneg hCint 3) hmy) _]
+  refine some_point_ext ?_ ?_
+  · rw [coeff_zero_mul_of_integral (orderTop_pow_nonneg hCint 2) hmx,
+      coeff_zero_of_mem_monodromy hm, ← map_pow, coeff_zero_C]
+  · rw [coeff_zero_mul_of_integral (orderTop_pow_nonneg hCint 3) hmy,
+      coeff_zero_of_mem_monodromy hm, ← map_pow, coeff_zero_C]
+
+theorem redPoint_monodromy_cocycle_1728 (m : H ≃ₐ[Qbar] H)
+    (hm : m ∈ HahnSeries.monodromy Qbar) (ζ : Qbar)
+    (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ)
+    (hE : (nearCurve 1728).map (m : H →+* H) = nearCurve 1728)
+    {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : (goodModel 1728).toAffine.Nonsingular x y) :
+    redPoint (goodModel 1728) (goodModel_spec 1728).1 (goodModel_spec 1728).2
+        (scaleAddEquiv 1728 (WeierstrassCurve.Affine.Point.fixedTransport m (nearCurve 1728) hE
+          ((scaleAddEquiv 1728).symm (WeierstrassCurve.Affine.Point.some x y h)))) =
+      WeierstrassCurve.Affine.Point.some (ζ ^ 2 * x.coeff 0) (ζ ^ 3 * y.coeff 0)
+        (nonsingular_cocycle_1728 m hm hζs hx hy h) := by
+  rw [fixedTransport_conj_1728 m hm ζ hζs hE h]
+  have hCint : 0 ≤ (HahnSeries.C ζ : H).orderTop := by
+    rw [← HahnSeries.ofPowerSeries_C]
+    exact orderTop_ofPowerSeries_nonneg _
+  have hmx : 0 ≤ (m x).orderTop := by
+    rw [orderTop_of_mem_monodromy hm]
+    exact hx
+  have hmy : 0 ≤ (m y).orderTop := by
+    rw [orderTop_of_mem_monodromy hm]
+    exact hy
+  rw [redPoint_some _ _ _ (orderTop_mul_nonneg (orderTop_pow_nonneg hCint 2) hmx)
+    (orderTop_mul_nonneg (orderTop_pow_nonneg hCint 3) hmy) _]
+  refine some_point_ext ?_ ?_
+  · rw [coeff_zero_mul_of_integral (orderTop_pow_nonneg hCint 2) hmx,
+      coeff_zero_of_mem_monodromy hm, ← map_pow, coeff_zero_C]
+  · rw [coeff_zero_mul_of_integral (orderTop_pow_nonneg hCint 3) hmy,
+      coeff_zero_of_mem_monodromy hm, ← map_pow, coeff_zero_C]
+
+end H6B
+
+theorem algebraMap_H_apply (q : Qbar) : (algebraMap Qbar H) q = HahnSeries.C q := by
+  rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_eq, HahnSeries.ofPowerSeries_C]
+
+theorem map_jNear_of_fixes_C_of_fixes_single_one (j₀ : Qbar) (τ : H →+* H)
+    (hC : ∀ q : Qbar, τ (HahnSeries.C q) = HahnSeries.C q)
+    (h1 : τ (HahnSeries.single (1 : ℚ) (1 : Qbar)) = HahnSeries.single 1 1) :
+    τ (jNear j₀) = jNear j₀ := by
+  rw [jNear, map_add, hC, h1]
+
+theorem nearCurve_map_of_fixes_jNear (j₀ : Qbar) (τ : H →+* H)
+    (hj : τ (jNear j₀) = jNear j₀) :
+    (nearCurve j₀).map τ = nearCurve j₀ := by
+  rw [nearCurve_eq_ofJNe0Or1728, map_ofJNe0Or1728, hj, ← nearCurve_eq_ofJNe0Or1728]
+
+theorem nearCurve_map_of_fixes_C_of_fixes_single_one (j₀ : Qbar) (τ : H →+* H)
+    (hC : ∀ q : Qbar, τ (HahnSeries.C q) = HahnSeries.C q)
+    (h1 : τ (HahnSeries.single (1 : ℚ) (1 : Qbar)) = HahnSeries.single 1 1) :
+    (nearCurve j₀).map τ = nearCurve j₀ :=
+  nearCurve_map_of_fixes_jNear j₀ τ (map_jNear_of_fixes_C_of_fixes_single_one j₀ τ hC h1)
+
+theorem nearCurve_map_of_mem_monodromy (j₀ : Qbar) {m : H ≃ₐ[Qbar] H}
+    (hm : m ∈ HahnSeries.monodromy Qbar) :
+    (nearCurve j₀).map (m : H →+* H) = nearCurve j₀ :=
+  nearCurve_map_of_fixes_C_of_fixes_single_one j₀ (m : H →+* H)
+    (fun q => by rw [← algebraMap_H_apply]; exact m.commutes q)
+    (HahnSeries.fixes_single_one_of_mem_monodromy hm)
+
+def nearTransport (j₀ : Qbar) (m : HahnSeries.monodromy Qbar) :
+    (nearCurve j₀).toAffine.Point ≃+ (nearCurve j₀).toAffine.Point :=
+  WeierstrassCurve.Affine.Point.fixedTransport (m : H ≃ₐ[Qbar] H) (nearCurve j₀)
+    (nearCurve_map_of_mem_monodromy j₀ m.2)
+
+theorem nearTransport_some (j₀ : Qbar) (m : HahnSeries.monodromy Qbar) (x y : H)
+    (h : (nearCurve j₀).toAffine.Nonsingular x y) :
+    nearTransport j₀ m (.some x y h) =
+      .some ((m : H ≃ₐ[Qbar] H) x) ((m : H ≃ₐ[Qbar] H) y)
+        (WeierstrassCurve.Affine.Point.nonsingular_of_fixed _ _
+          (nearCurve_map_of_mem_monodromy j₀ m.2) h) :=
+  WeierstrassCurve.Affine.Point.fixedTransport_some
+    (m : H ≃ₐ[Qbar] H) (nearCurve j₀) (nearCurve_map_of_mem_monodromy j₀ m.2) x y h
+
+def b3Act (j₀ : Qbar) (m : HahnSeries.monodromy Qbar) :
+    AddSubgroup (nearCurve j₀).toAffine.Point → AddSubgroup (nearCurve j₀).toAffine.Point :=
+  AddSubgroup.map ((nearTransport j₀ m : _ ≃+ _) : _ →+ _)
+
+theorem b3Act_zmultiples (j₀ : Qbar) (m : HahnSeries.monodromy Qbar)
+    (g : (nearCurve j₀).toAffine.Point) :
+    b3Act j₀ m (AddSubgroup.zmultiples g) = AddSubgroup.zmultiples (nearTransport j₀ m g) :=
+  AddMonoidHom.map_zmultiples _ g
+
+theorem scaleAddEquiv_some_generic (j₀ : Qbar) (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728)
+    {x y : H} (h : (nearCurve j₀).toAffine.Nonsingular x y) :
+    ∃ h' : (goodModel j₀).toAffine.Nonsingular x y,
+      scaleAddEquiv j₀ (.some x y h) = .some x y h' := by
+  have hvX : WeierstrassCurve.Affine.vcXInv (scaleVC j₀) x = x := by
+    rw [scaleVC_of_ne h0 h1728]
+    simp [WeierstrassCurve.Affine.vcXInv, VariableChange.one_def]
+  have hvY : WeierstrassCurve.Affine.vcYInv (scaleVC j₀) x y = y := by
+    rw [scaleVC_of_ne h0 h1728]
+    simp [WeierstrassCurve.Affine.vcYInv, VariableChange.one_def]
+  refine ⟨?_, ?_⟩
+  · rw [goodModel_eq_nearCurve h0 h1728]; exact h
+  · rw [scaleAddEquiv_apply]
+    change (WeierstrassCurve.Affine.Point.some
+        (WeierstrassCurve.Affine.vcXInv (scaleVC j₀) x)
+        (WeierstrassCurve.Affine.vcYInv (scaleVC j₀) x y) _ :
+        (goodModel j₀).toAffine.Point) = WeierstrassCurve.Affine.Point.some x y _
+    congr 1
+
+theorem redTorsionEquiv_scaleAddEquiv_nearTransport_generic (p : ℕ) [Fact p.Prime]
+    (j₀ : Qbar) (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) (m : HahnSeries.monodromy Qbar)
+    {x y : H} (h : (nearCurve j₀).toAffine.Nonsingular x y)
+    (hg : addOrderOf (WeierstrassCurve.Affine.Point.some x y h :
+        (nearCurve j₀).toAffine.Point) = p) :
+    ((redTorsionEquiv (goodModel j₀) (goodModel_spec j₀).1 (goodModel_spec j₀).2 p
+        ⟨scaleAddEquiv j₀ (nearTransport j₀ m (.some x y h)),
+          mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ _).trans
+            ((AddEquiv.addOrderOf_eq _ _).trans hg))⟩ :
+        Submodule.torsionBy ℤ (specialFibre (goodModel j₀)).toAffine.Point (p : ℤ)) :
+      (specialFibre (goodModel j₀)).toAffine.Point) =
+    ((redTorsionEquiv (goodModel j₀) (goodModel_spec j₀).1 (goodModel_spec j₀).2 p
+        ⟨scaleAddEquiv j₀ (.some x y h),
+          mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ _).trans hg)⟩ :
+        Submodule.torsionBy ℤ (specialFibre (goodModel j₀)).toAffine.Point (p : ℤ)) :
+      (specialFibre (goodModel j₀)).toAffine.Point) := by
+  have hm := m.2
+  have hns' := WeierstrassCurve.Affine.Point.nonsingular_of_fixed _ _
+    (nearCurve_map_of_mem_monodromy j₀ hm) h
+  obtain ⟨h', hscale'⟩ := scaleAddEquiv_some_generic j₀ h0 h1728 hns'
+  obtain ⟨hgn, hscale⟩ := scaleAddEquiv_some_generic j₀ h0 h1728 h
+  obtain ⟨hred', hred'eq⟩ := redTorsionEquiv_spec (goodModel j₀) (goodModel_spec j₀).1
+    (goodModel_spec j₀).2 p
+    ⟨scaleAddEquiv j₀ (nearTransport j₀ m (.some x y h)),
+      mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ _).trans
+        ((AddEquiv.addOrderOf_eq _ _).trans hg))⟩
+    ((m : H ≃ₐ[Qbar] H) x) ((m : H ≃ₐ[Qbar] H) y) h'
+    (by simpa only [nearTransport_some] using hscale')
+  obtain ⟨hred, hredeq⟩ := redTorsionEquiv_spec (goodModel j₀) (goodModel_spec j₀).1
+    (goodModel_spec j₀).2 p
+    ⟨scaleAddEquiv j₀ (.some x y h),
+      mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ _).trans hg)⟩
+    x y hgn hscale
+  rw [hred'eq, hredeq]
+  congr 1
+  · exact coeff_zero_of_mem_monodromy hm x
+  · exact coeff_zero_of_mem_monodromy hm y
+
+theorem bridge3Specialise_b3Act_generic (p : ℕ) [Fact p.Prime] [NeZero p] (j₀ : Qbar)
+    (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) (m : HahnSeries.monodromy Qbar)
+    (g : (nearCurve j₀).toAffine.Point) (hg : addOrderOf g = p) :
+    (bridge3Specialise p j₀
+        ⟨b3Act j₀ m (AddSubgroup.zmultiples g), nearTransport j₀ m g,
+          (AddEquiv.addOrderOf_eq _ g).trans hg, b3Act_zmultiples j₀ m g⟩).1 =
+      (bridge3Specialise p j₀ ⟨AddSubgroup.zmultiples g, g, hg, rfl⟩).1 := by
+  have hgT : addOrderOf (nearTransport j₀ m g) = p := (AddEquiv.addOrderOf_eq _ g).trans hg
+  rw [show (⟨b3Act j₀ m (AddSubgroup.zmultiples g), nearTransport j₀ m g, hgT,
+        b3Act_zmultiples j₀ m g⟩ : CycSubH (nearCurve j₀) p) =
+      ⟨AddSubgroup.zmultiples (nearTransport j₀ m g), nearTransport j₀ m g, hgT, rfl⟩ from
+    Subtype.ext (b3Act_zmultiples j₀ m g)]
+  rw [bridge3Specialise_zmultiples p j₀ (nearTransport j₀ m g) hgT,
+    bridge3Specialise_zmultiples p j₀ g hg]
+  rcases g with _ | ⟨x, y, h⟩
+  · exact absurd hg (by
+      rw [show (WeierstrassCurve.Affine.Point.zero : (nearCurve j₀).toAffine.Point) = 0 from rfl,
+        addOrderOf_zero]
+      exact (Fact.out : p.Prime).ne_one.symm)
+  · congr 2
+    exact redTorsionEquiv_scaleAddEquiv_nearTransport_generic p j₀ h0 h1728 m h hg
+
+private theorem monodromy_full (e : ℕ) (he : 0 < e) (ζ : Qbar) (hζ : ζ ^ e = 1) :
+    ∃ m ∈ HahnSeries.monodromy Qbar,
+      (m : H ≃ₐ[Qbar] H) (HahnSeries.single ((e : ℚ)⁻¹) (1 : Qbar)) =
+        HahnSeries.single ((e : ℚ)⁻¹) ζ :=
+  HahnSeries.exists_mem_monodromy_single_eq (AlgebraicClosure ℚ) e he ζ hζ
+
+theorem nearTransport_one (j₀ : Qbar) : nearTransport j₀ 1 = AddEquiv.refl _ := by
+  refine AddEquiv.ext fun P => ?_
+  rcases P with _ | ⟨x, y, h⟩
+  · exact WeierstrassCurve.Affine.Point.fixedTransport_zero
+      (1 : H ≃ₐ[Qbar] H) (nearCurve j₀) (nearCurve_map_of_mem_monodromy j₀ (1 :
+        HahnSeries.monodromy Qbar).2)
+  · exact nearTransport_some j₀ 1 x y h
+
+theorem b3Act_one (j₀ : Qbar) (G : AddSubgroup (nearCurve j₀).toAffine.Point) :
+    b3Act j₀ 1 G = G := by
+  rw [b3Act, nearTransport_one]
+  exact G.map_id
+
+theorem exists_zeta_of_mem_monodromy {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    (q : ℚ) :
+    ∃ ζ : Qbar, m (HahnSeries.single q 1) = HahnSeries.single q ζ := by
+  obtain ⟨χ, _, rfl⟩ := hm
+  exact ⟨(χ (Multiplicative.ofAdd q)).val, by
+    rw [HahnSeries.hahnTwistHom_apply, HahnSeries.hahnTwist_single, mul_one]⟩
+
+theorem bridge3Specialise_coe_eq_of_coe_eq (p : ℕ) [Fact p.Prime] [NeZero p] (j₀ : Qbar)
+    {G G' : CycSubH (nearCurve j₀) p} (hGG' : G.1 = G'.1) :
+    (bridge3Specialise p j₀ G).1 = (bridge3Specialise p j₀ G').1 := by
+  rw [show G = G' from Subtype.ext hGG']
+
+theorem b3_specialisationEquivariance_generic (p : ℕ) [Fact p.Prime] [NeZero p] (j₀ : Qbar)
+    (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) (G G' : CycSubH (nearCurve j₀) p) :
+    (∃ m : HahnSeries.monodromy Qbar, b3Act j₀ m G.1 = G'.1) ↔
+      SameOrbit (WeierstrassCurve.ofJ j₀) (bridge3Specialise p j₀ G).1
+        (bridge3Specialise p j₀ G').1 := by
+  rw [sameOrbit_ofJ_iff_of_ne j₀ h0 h1728]
+  obtain ⟨g, hg, hG1⟩ := G.2
+  have hGeq : G = ⟨AddSubgroup.zmultiples g, g, hg, rfl⟩ := Subtype.ext hG1
+  constructor
+  · rintro ⟨m, hb3⟩
+    refine ⟨?_, (bridge3Specialise p j₀ G).2.imp fun _ h => h.2⟩
+    have hgT : addOrderOf (nearTransport j₀ m g) = p := (AddEquiv.addOrderOf_eq _ g).trans hg
+    have key : (bridge3Specialise p j₀ G').1 = (bridge3Specialise p j₀ G).1 := by
+      calc (bridge3Specialise p j₀ G').1
+          = (bridge3Specialise p j₀
+              ⟨b3Act j₀ m (AddSubgroup.zmultiples g), nearTransport j₀ m g, hgT,
+                b3Act_zmultiples j₀ m g⟩).1 := by
+            apply bridge3Specialise_coe_eq_of_coe_eq
+            rw [← hb3, hG1]
+        _ = (bridge3Specialise p j₀ ⟨AddSubgroup.zmultiples g, g, hg, rfl⟩).1 :=
+            bridge3Specialise_b3Act_generic p j₀ h0 h1728 m g hg
+        _ = (bridge3Specialise p j₀ G).1 := by rw [← hGeq]
+    exact key.symm
+  · rintro ⟨hβeq, _⟩
+    refine ⟨1, ?_⟩
+    rw [b3Act_one]
+    have : G = G' := (bridge3Specialise p j₀).injective (Subtype.ext hβeq)
+    rw [this]
+
+open WeierstrassCurve.Affine.Point in
+theorem redTorsionEquiv_coe_eq_redPoint (W : WeierstrassCurve H) [W.IsElliptic]
+    (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0) [(specialFibre W).IsElliptic]
+    (p : ℕ) [Fact p.Prime]
+    (Q : W.toAffine.Point) (hQ0 : Q ≠ 0)
+    (hmem : Q ∈ Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ)) :
+    ((redTorsionEquiv W hW hΔ p ⟨Q, hmem⟩ :
+        Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ)) :
+      (specialFibre W).toAffine.Point) =
+      redPoint W hW hΔ Q := by
+  obtain ⟨x, y, h, hPQ⟩ : ∃ x y h, Q = WeierstrassCurve.Affine.Point.some x y h := by
+    rcases Q with _ | ⟨x, y, h⟩
+    · exact absurd rfl hQ0
+    · exact ⟨x, y, h, rfl⟩
+  subst hPQ
+  have htor : p • WeierstrassCurve.Affine.Point.some x y h = 0 := by
+    have hz : (p : ℤ) • (WeierstrassCurve.Affine.Point.some x y h : W.toAffine.Point) = 0 := hmem
+    rw [natCast_zsmul] at hz
+    exact hz
+  have ⟨hx, hy⟩ := torsion_coords_integral W hW hΔ h (n := p) (Fact.out : p.Prime).ne_zero htor
+  obtain ⟨h₀, heq⟩ := redTorsionEquiv_spec W hW hΔ p ⟨_, hmem⟩ x y h rfl
+  rw [heq, redPoint_some W hW hΔ hx hy h]
+
+open WeierstrassCurve.Affine in
+theorem exists_some_of_addOrderOf_prime (j₀ : Qbar) {p : ℕ} [Fact p.Prime]
+    {g : (nearCurve j₀).toAffine.Point} (hg : addOrderOf g = p) :
+    ∃ x y h, g = WeierstrassCurve.Affine.Point.some x y h := by
+  rcases g with _ | ⟨x, y, h⟩
+  · exact absurd hg (by
+      rw [show (WeierstrassCurve.Affine.Point.zero : (nearCurve j₀).toAffine.Point) = 0 from rfl,
+        addOrderOf_zero]
+      exact (Fact.out : p.Prime).ne_one.symm)
+  · exact ⟨x, y, h, rfl⟩
+
+open WeierstrassCurve.Affine in
+theorem redTorsionEquiv_scaleAddEquiv_nearTransport_zero (p : ℕ) [Fact p.Prime] [NeZero p]
+    (m : HahnSeries.monodromy Qbar) {ζ : Qbar}
+    (hζs : (m : H ≃ₐ[Qbar] H) (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ)
+    (hζ0 : ζ ≠ 0) (hζ6 : ζ ^ 6 = 1)
+    (g : (nearCurve 0).toAffine.Point) (hg : addOrderOf g = p) :
+    ((redTorsionEquiv (goodModel 0) (goodModel_spec 0).1 (goodModel_spec 0).2 p
+        ⟨scaleAddEquiv 0 (nearTransport 0 m g),
+          mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ _).trans
+            ((AddEquiv.addOrderOf_eq _ _).trans hg))⟩ :
+        Submodule.torsionBy ℤ (specialFibre (goodModel 0)).toAffine.Point (p : ℤ)) :
+      (specialFibre (goodModel 0)).toAffine.Point) =
+    fibreTwistEquiv_zero ζ hζ0 hζ6
+      ((redTorsionEquiv (goodModel 0) (goodModel_spec 0).1 (goodModel_spec 0).2 p
+          ⟨scaleAddEquiv 0 g,
+            mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ _).trans hg)⟩ :
+          Submodule.torsionBy ℤ (specialFibre (goodModel 0)).toAffine.Point (p : ℤ)) :
+        (specialFibre (goodModel 0)).toAffine.Point) := by
+  have hg0 : g ≠ 0 := fun h0 => (Fact.out : p.Prime).ne_one ((h0 ▸ hg).symm.trans addOrderOf_zero)
+  have hsg0 : (scaleAddEquiv 0 g : (goodModel 0).toAffine.Point) ≠ 0 :=
+    fun h0 => hg0 ((scaleAddEquiv 0).injective (h0.trans (map_zero _).symm))
+  have hsgT0 : (scaleAddEquiv 0 (nearTransport 0 m g) : (goodModel 0).toAffine.Point) ≠ 0 :=
+    fun h0 => hg0 ((nearTransport 0 m).injective ((scaleAddEquiv 0).injective
+      (h0.trans (map_zero _).symm) |>.trans (map_zero _).symm))
+  rw [redTorsionEquiv_coe_eq_redPoint _ _ _ p _ hsgT0 _,
+    redTorsionEquiv_coe_eq_redPoint _ _ _ p _ hsg0 _]
+  obtain ⟨x₁, y₁, h₁, hgeq⟩ := exists_some_of_addOrderOf_prime 0 hg
+  set Q := scaleAddEquiv 0 g with hQdef
+  rcases hQeq : Q with _ | ⟨x, y, hns⟩
+  · exact absurd (hQdef ▸ hQeq) hsg0
+  have htor : p • WeierstrassCurve.Affine.Point.some x y hns = 0 := by
+    rw [← hQeq, hQdef, ← map_nsmul,
+      show p • g = 0 from hg ▸ addOrderOf_nsmul_eq_zero g, map_zero]
+  have ⟨hx, hy⟩ := torsion_coords_integral (goodModel 0) (goodModel_spec 0).1 (goodModel_spec 0).2
+    hns (n := p) (Fact.out : p.Prime).ne_zero htor
+  have hE := nearCurve_map_of_mem_monodromy 0 m.2
+  have hconj : scaleAddEquiv 0 (nearTransport 0 m g) =
+      scaleAddEquiv 0 (WeierstrassCurve.Affine.Point.fixedTransport (m : H ≃ₐ[Qbar] H)
+        (nearCurve 0) hE ((scaleAddEquiv 0).symm (.some x y hns))) := by
+    rw [← hQeq, hQdef, AddEquiv.symm_apply_apply]
+    rfl
+  rw [hconj, redPoint_monodromy_cocycle_zero (m : H ≃ₐ[Qbar] H) m.2 ζ hζs hE hx hy hns,
+    redPoint_some (goodModel 0) (goodModel_spec 0).1 (goodModel_spec 0).2 hx hy hns,
+    fibreTwistEquiv_zero_some ζ hζ0 hζ6
+      (nonsingular_specialFibre (goodModel 0) (goodModel_spec 0).1 (goodModel_spec 0).2
+        hx hy hns)]
+
+theorem sameOrbit_iff_map (E₀ : WeierstrassCurve Qbar) (H H' : AddSubgroup E₀.toAffine.Point) :
+    SameOrbit E₀ H H' ↔
+      (∃ γ : VariableChange Qbar, ∃ hγ : γ • E₀ = E₀,
+        H' = H.map ((vcEquivOfSMulEq γ hγ : _ ≃+ _) : _ →+ _)) ∧
+        ∃ g, H = AddSubgroup.zmultiples g := by
+  rw [sameOrbit_iff]
+  constructor
+  · rintro ⟨γ, hγ, g, g', rfl, rfl, hheq⟩
+    refine ⟨⟨γ, hγ, ?_⟩, g, rfl⟩
+    rw [(heq_vcInvFun_iff_eq γ hγ g g').mp hheq, AddMonoidHom.map_zmultiples]
+    rfl
+  · rintro ⟨⟨γ, hγ, rfl⟩, g, rfl⟩
+    refine ⟨γ, hγ, g, vcEquivOfSMulEq γ hγ g, rfl, ?_, ?_⟩
+    · rw [AddMonoidHom.map_zmultiples]; rfl
+    · exact (heq_vcInvFun_iff_eq γ hγ g _).mpr rfl
+
+theorem b3_specialisationEquivariance_zero (p : ℕ) [Fact p.Prime] [NeZero p]
+    (G G' : CycSubH (nearCurve 0) p) :
+    (∃ m : HahnSeries.monodromy Qbar, b3Act 0 m G.1 = G'.1) ↔
+      SameOrbit (WeierstrassCurve.ofJ 0) (bridge3Specialise p 0 G).1
+        (bridge3Specialise p 0 G').1 := by
+  obtain ⟨g, hg, hG1⟩ := G.2
+  have hGeq : G = ⟨AddSubgroup.zmultiples g, g, hg, rfl⟩ := Subtype.ext hG1
+  have hBne : (-(2 * 1728 ^ 4) : Qbar) ≠ 0 := by norm_num
+  set P₀ : (specialFibre (goodModel 0)).toAffine.Point :=
+    ((redTorsionEquiv (goodModel 0) (goodModel_spec 0).1 (goodModel_spec 0).2 p
+      ⟨scaleAddEquiv 0 g, mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ g).trans hg)⟩ :
+      Submodule.torsionBy ℤ (specialFibre (goodModel 0)).toAffine.Point (p : ℤ)) :
+    (specialFibre (goodModel 0)).toAffine.Point) with hP₀def
+  have hβG : (bridge3Specialise p 0 G).1 = AddSubgroup.zmultiples (fibreAddEquiv 0 P₀) := by
+    rw [hGeq, bridge3Specialise_zmultiples p 0 g hg]
+  constructor
+  · rintro ⟨m, hb3⟩
+    obtain ⟨ζ, hζs⟩ := exists_zeta_of_mem_monodromy m.2 (1 / 6 : ℚ)
+    have hζ6 : ζ ^ 6 = 1 := zeta_pow_eq_one_of_twist (k := 1) m.2 hζs (by norm_num)
+    have hζ0 : ζ ≠ 0 := zeta_ne_zero_of_pow_eq_one (n := 6) (by norm_num) hζ6
+    have hgT : addOrderOf (nearTransport 0 m g) = p := (AddEquiv.addOrderOf_eq _ g).trans hg
+    have hβG' : (bridge3Specialise p 0 G').1 =
+        AddSubgroup.zmultiples (fibreAddEquiv 0 (fibreTwistEquiv_zero ζ hζ0 hζ6 P₀)) := by
+      rw [bridge3Specialise_coe_eq_of_coe_eq p 0
+          (G' := ⟨AddSubgroup.zmultiples (nearTransport 0 m g), nearTransport 0 m g, hgT, rfl⟩)
+          (by rw [← hb3, hG1, b3Act_zmultiples]),
+        bridge3Specialise_zmultiples p 0 (nearTransport 0 m g) hgT,
+        redTorsionEquiv_scaleAddEquiv_nearTransport_zero p m hζs hζ0 hζ6 g hg]
+    rw [hβG, hβG']
+    exact sameOrbit_of_conj (fibreVC_smul 0) (fibreTwistVC_smul_fibre_zero hζ0 hζ6) P₀
+  · intro hSO
+    rw [hβG, sameOrbit_iff_map] at hSO
+    obtain ⟨⟨γ, hγ, hmap⟩, _⟩ := hSO
+    have hconjF : ((fibreVC 0)⁻¹ * γ * fibreVC 0) • specialFibre (goodModel 0) =
+        specialFibre (goodModel 0) := conj_smul_eq (fibreVC_smul 0) hγ
+    obtain ⟨hr, hs, ht, hu6⟩ : ((fibreVC 0)⁻¹ * γ * fibreVC 0).r = 0 ∧
+        ((fibreVC 0)⁻¹ * γ * fibreVC 0).s = 0 ∧
+        ((fibreVC 0)⁻¹ * γ * fibreVC 0).t = 0 ∧
+        (((fibreVC 0)⁻¹ * γ * fibreVC 0).u : Qbar) ^ 6 = 1 := by
+      have := hconjF
+      rw [specialFibre_goodModel_zero] at this
+      exact (smul_a6Model_eq_iff hBne _).mp this
+    set u : Qbarˣ := ((fibreVC 0)⁻¹ * γ * fibreVC 0).u with hudef
+    set ζ : Qbar := ((u⁻¹ : Qbarˣ) : Qbar) with hζdef
+    have hζ6 : ζ ^ 6 = 1 := by
+      rw [hζdef, ← Units.val_pow_eq_pow_val, inv_pow, ← Units.val_one (α := Qbar)]
+      exact congrArg Units.val (inv_eq_one.mpr (Units.ext hu6))
+    have hζ0 : ζ ≠ 0 := zeta_ne_zero_of_pow_eq_one (n := 6) (by norm_num) hζ6
+    obtain ⟨m', hm', hζs⟩ := monodromy_full 6 (by norm_num) ζ hζ6
+    have hζs' : ((⟨m', hm'⟩ : HahnSeries.monodromy Qbar) : H ≃ₐ[Qbar] H)
+        (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ := by
+      have h6 : ((6 : ℕ) : ℚ)⁻¹ = (1 / 6 : ℚ) := by norm_num
+      rw [← h6]; exact hζs
+    have hftvc : fibreTwistVC ζ hζ0 = (fibreVC 0)⁻¹ * γ * fibreVC 0 := by
+      rw [variableChange_eq_of_rst_eq_zero _ hr hs ht]
+      change (⟨(Units.mk0 ζ hζ0)⁻¹, 0, 0, 0⟩ : VariableChange Qbar) = ⟨u, 0, 0, 0⟩
+      have : Units.mk0 ζ hζ0 = u⁻¹ := Units.ext (by rw [Units.val_mk0, hζdef])
+      rw [this, inv_inv]
+    refine ⟨⟨m', hm'⟩, ?_⟩
+    have hgT : addOrderOf (nearTransport 0 ⟨m', hm'⟩ g) = p :=
+      (AddEquiv.addOrderOf_eq _ g).trans hg
+    suffices h : (bridge3Specialise p 0
+          ⟨AddSubgroup.zmultiples (nearTransport 0 ⟨m', hm'⟩ g),
+            nearTransport 0 ⟨m', hm'⟩ g, hgT, rfl⟩).1 =
+        (bridge3Specialise p 0 G').1 by
+      have := (bridge3Specialise p 0).injective (Subtype.ext h)
+      rw [hG1, b3Act_zmultiples, ← this]
+    rw [bridge3Specialise_zmultiples p 0 (nearTransport 0 ⟨m', hm'⟩ g) hgT,
+      redTorsionEquiv_scaleAddEquiv_nearTransport_zero p ⟨m', hm'⟩ hζs' hζ0 hζ6 g hg,
+      ← hP₀def]
+    rw [hmap, AddMonoidHom.map_zmultiples]
+    congr 1
+    have hftvc_smul : fibreTwistVC ζ hζ0 • specialFibre (goodModel 0) =
+        specialFibre (goodModel 0) := hftvc ▸ hconjF
+    calc fibreAddEquiv 0 (fibreTwistEquiv_zero ζ hζ0 hζ6 P₀)
+        = vcEquivOfSMulEq (fibreVC 0) (fibreVC_smul 0)
+            (vcEquivOfSMulEq (fibreTwistVC ζ hζ0) hftvc_smul P₀) := rfl
+      _ = vcEquivOfSMulEq (fibreVC 0) (fibreVC_smul 0)
+            (vcEquivOfSMulEq ((fibreVC 0)⁻¹ * γ * fibreVC 0) hconjF P₀) := by
+          rw [vcEquivOfSMulEq_congr hftvc hftvc_smul hconjF]
+      _ = vcEquivOfSMulEq γ hγ (vcEquivOfSMulEq (fibreVC 0) (fibreVC_smul 0) P₀) :=
+          vcEquivOfSMulEq_conj (fibreVC_smul 0) hγ P₀
+      _ = _ := rfl
+
+open WeierstrassCurve.Affine in
+theorem redTorsionEquiv_scaleAddEquiv_nearTransport_1728 (p : ℕ) [Fact p.Prime] [NeZero p]
+    (m : HahnSeries.monodromy Qbar) {ζ : Qbar}
+    (hζs : (m : H ≃ₐ[Qbar] H) (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ)
+    (hζ0 : ζ ≠ 0) (hζ4 : ζ ^ 4 = 1)
+    (g : (nearCurve 1728).toAffine.Point) (hg : addOrderOf g = p) :
+    ((redTorsionEquiv (goodModel 1728) (goodModel_spec 1728).1 (goodModel_spec 1728).2 p
+        ⟨scaleAddEquiv 1728 (nearTransport 1728 m g),
+          mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ _).trans
+            ((AddEquiv.addOrderOf_eq _ _).trans hg))⟩ :
+        Submodule.torsionBy ℤ (specialFibre (goodModel 1728)).toAffine.Point (p : ℤ)) :
+      (specialFibre (goodModel 1728)).toAffine.Point) =
+    fibreTwistEquiv_1728 ζ hζ0 hζ4
+      ((redTorsionEquiv (goodModel 1728) (goodModel_spec 1728).1 (goodModel_spec 1728).2 p
+          ⟨scaleAddEquiv 1728 g,
+            mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ _).trans hg)⟩ :
+          Submodule.torsionBy ℤ (specialFibre (goodModel 1728)).toAffine.Point (p : ℤ)) :
+        (specialFibre (goodModel 1728)).toAffine.Point) := by
+  have hg0 : g ≠ 0 := fun h0 => (Fact.out : p.Prime).ne_one ((h0 ▸ hg).symm.trans addOrderOf_zero)
+  have hsg0 : (scaleAddEquiv 1728 g : (goodModel 1728).toAffine.Point) ≠ 0 :=
+    fun h0 => hg0 ((scaleAddEquiv 1728).injective (h0.trans (map_zero _).symm))
+  have hsgT0 : (scaleAddEquiv 1728 (nearTransport 1728 m g) : (goodModel 1728).toAffine.Point)
+      ≠ 0 :=
+    fun h0 => hg0 ((nearTransport 1728 m).injective ((scaleAddEquiv 1728).injective
+      (h0.trans (map_zero _).symm) |>.trans (map_zero _).symm))
+  rw [redTorsionEquiv_coe_eq_redPoint _ _ _ p _ hsgT0 _,
+    redTorsionEquiv_coe_eq_redPoint _ _ _ p _ hsg0 _]
+  obtain ⟨x₁, y₁, h₁, hgeq⟩ := exists_some_of_addOrderOf_prime 1728 hg
+  set Q := scaleAddEquiv 1728 g with hQdef
+  rcases hQeq : Q with _ | ⟨x, y, hns⟩
+  · exact absurd (hQdef ▸ hQeq) hsg0
+  have htor : p • WeierstrassCurve.Affine.Point.some x y hns = 0 := by
+    rw [← hQeq, hQdef, ← map_nsmul,
+      show p • g = 0 from hg ▸ addOrderOf_nsmul_eq_zero g, map_zero]
+  have ⟨hx, hy⟩ := torsion_coords_integral (goodModel 1728) (goodModel_spec 1728).1
+    (goodModel_spec 1728).2 hns (n := p) (Fact.out : p.Prime).ne_zero htor
+  have hE := nearCurve_map_of_mem_monodromy 1728 m.2
+  have hconj : scaleAddEquiv 1728 (nearTransport 1728 m g) =
+      scaleAddEquiv 1728 (WeierstrassCurve.Affine.Point.fixedTransport (m : H ≃ₐ[Qbar] H)
+        (nearCurve 1728) hE ((scaleAddEquiv 1728).symm (.some x y hns))) := by
+    rw [← hQeq, hQdef, AddEquiv.symm_apply_apply]
+    rfl
+  rw [hconj, redPoint_monodromy_cocycle_1728 (m : H ≃ₐ[Qbar] H) m.2 ζ hζs hE hx hy hns,
+    redPoint_some (goodModel 1728) (goodModel_spec 1728).1 (goodModel_spec 1728).2 hx hy hns,
+    fibreTwistEquiv_1728_some ζ hζ0 hζ4
+      (nonsingular_specialFibre (goodModel 1728) (goodModel_spec 1728).1 (goodModel_spec 1728).2
+        hx hy hns)]
+
+theorem monodromy_full_three_quarters (ζ : Qbar) (hζ4 : ζ ^ 4 = 1) :
+    ∃ m ∈ HahnSeries.monodromy Qbar,
+      (m : H ≃ₐ[Qbar] H) (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ := by
+  have hζ'4 : (ζ ^ 3) ^ 4 = 1 := by rw [← pow_mul, show 3 * 4 = 4 * 3 from rfl, pow_mul, hζ4,
+    one_pow]
+  obtain ⟨m, hm, hζ's⟩ := monodromy_full 4 (by norm_num) (ζ ^ 3) hζ'4
+  refine ⟨m, hm, ?_⟩
+  have h14 : ((4 : ℕ) : ℚ)⁻¹ = (1 / 4 : ℚ) := by norm_num
+  have h34 : (HahnSeries.single (3 / 4 : ℚ) (1 : Qbar) : H) =
+      (HahnSeries.single ((4 : ℕ) : ℚ)⁻¹ (1 : Qbar)) ^ 3 := by
+    rw [HahnSeries.single_pow, one_pow, h14]
+    norm_num
+  rw [h34, map_pow, hζ's, HahnSeries.single_pow, h14, ← pow_mul,
+    show 3 * 3 = 4 * 2 + 1 from rfl, pow_add, pow_mul, hζ4, one_pow, pow_one, one_mul]
+  norm_num
+
+theorem b3_specialisationEquivariance_1728 (p : ℕ) [Fact p.Prime] [NeZero p]
+    (G G' : CycSubH (nearCurve 1728) p) :
+    (∃ m : HahnSeries.monodromy Qbar, b3Act 1728 m G.1 = G'.1) ↔
+      SameOrbit (WeierstrassCurve.ofJ 1728) (bridge3Specialise p 1728 G).1
+        (bridge3Specialise p 1728 G').1 := by
+  obtain ⟨g, hg, hG1⟩ := G.2
+  have hGeq : G = ⟨AddSubgroup.zmultiples g, g, hg, rfl⟩ := Subtype.ext hG1
+  have hAne : (-36 : Qbar) ≠ 0 := by norm_num
+  set P₀ : (specialFibre (goodModel 1728)).toAffine.Point :=
+    ((redTorsionEquiv (goodModel 1728) (goodModel_spec 1728).1 (goodModel_spec 1728).2 p
+      ⟨scaleAddEquiv 1728 g,
+        mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ g).trans hg)⟩ :
+      Submodule.torsionBy ℤ (specialFibre (goodModel 1728)).toAffine.Point (p : ℤ)) :
+    (specialFibre (goodModel 1728)).toAffine.Point) with hP₀def
+  have hβG : (bridge3Specialise p 1728 G).1 = AddSubgroup.zmultiples (fibreAddEquiv 1728 P₀) := by
+    rw [hGeq, bridge3Specialise_zmultiples p 1728 g hg]
+  constructor
+  · rintro ⟨m, hb3⟩
+    obtain ⟨ζ, hζs⟩ := exists_zeta_of_mem_monodromy m.2 (3 / 4 : ℚ)
+    have hζ4 : ζ ^ 4 = 1 := zeta_pow_eq_one_of_twist (k := 3) m.2 hζs (by norm_num)
+    have hζ0 : ζ ≠ 0 := zeta_ne_zero_of_pow_eq_one (n := 4) (by norm_num) hζ4
+    have hgT : addOrderOf (nearTransport 1728 m g) = p := (AddEquiv.addOrderOf_eq _ g).trans hg
+    have hβG' : (bridge3Specialise p 1728 G').1 =
+        AddSubgroup.zmultiples (fibreAddEquiv 1728 (fibreTwistEquiv_1728 ζ hζ0 hζ4 P₀)) := by
+      rw [bridge3Specialise_coe_eq_of_coe_eq p 1728
+          (G' := ⟨AddSubgroup.zmultiples (nearTransport 1728 m g), nearTransport 1728 m g, hgT,
+            rfl⟩)
+          (by rw [← hb3, hG1, b3Act_zmultiples]),
+        bridge3Specialise_zmultiples p 1728 (nearTransport 1728 m g) hgT,
+        redTorsionEquiv_scaleAddEquiv_nearTransport_1728 p m hζs hζ0 hζ4 g hg]
+    rw [hβG, hβG']
+    exact sameOrbit_of_conj (fibreVC_smul 1728) (fibreTwistVC_smul_fibre_1728 hζ0 hζ4) P₀
+  · intro hSO
+    rw [hβG, sameOrbit_iff_map] at hSO
+    obtain ⟨⟨γ, hγ, hmap⟩, _⟩ := hSO
+    have hconjF : ((fibreVC 1728)⁻¹ * γ * fibreVC 1728) • specialFibre (goodModel 1728) =
+        specialFibre (goodModel 1728) := conj_smul_eq (fibreVC_smul 1728) hγ
+    obtain ⟨hr, hs, ht, hu4⟩ : ((fibreVC 1728)⁻¹ * γ * fibreVC 1728).r = 0 ∧
+        ((fibreVC 1728)⁻¹ * γ * fibreVC 1728).s = 0 ∧
+        ((fibreVC 1728)⁻¹ * γ * fibreVC 1728).t = 0 ∧
+        (((fibreVC 1728)⁻¹ * γ * fibreVC 1728).u : Qbar) ^ 4 = 1 := by
+      have := hconjF
+      rw [specialFibre_goodModel_1728] at this
+      exact (smul_a4Model_eq_iff hAne _).mp this
+    set u : Qbarˣ := ((fibreVC 1728)⁻¹ * γ * fibreVC 1728).u with hudef
+    set ζ : Qbar := ((u⁻¹ : Qbarˣ) : Qbar) with hζdef
+    have hζ4 : ζ ^ 4 = 1 := by
+      rw [hζdef, ← Units.val_pow_eq_pow_val, inv_pow, ← Units.val_one (α := Qbar)]
+      exact congrArg Units.val (inv_eq_one.mpr (Units.ext hu4))
+    have hζ0 : ζ ≠ 0 := zeta_ne_zero_of_pow_eq_one (n := 4) (by norm_num) hζ4
+    obtain ⟨m', hm', hζs⟩ := monodromy_full_three_quarters ζ hζ4
+    have hftvc : fibreTwistVC ζ hζ0 = (fibreVC 1728)⁻¹ * γ * fibreVC 1728 := by
+      rw [variableChange_eq_of_rst_eq_zero _ hr hs ht]
+      change (⟨(Units.mk0 ζ hζ0)⁻¹, 0, 0, 0⟩ : VariableChange Qbar) = ⟨u, 0, 0, 0⟩
+      have : Units.mk0 ζ hζ0 = u⁻¹ := Units.ext (by rw [Units.val_mk0, hζdef])
+      rw [this, inv_inv]
+    refine ⟨⟨m', hm'⟩, ?_⟩
+    have hgT : addOrderOf (nearTransport 1728 ⟨m', hm'⟩ g) = p :=
+      (AddEquiv.addOrderOf_eq _ g).trans hg
+    suffices h : (bridge3Specialise p 1728
+          ⟨AddSubgroup.zmultiples (nearTransport 1728 ⟨m', hm'⟩ g),
+            nearTransport 1728 ⟨m', hm'⟩ g, hgT, rfl⟩).1 =
+        (bridge3Specialise p 1728 G').1 by
+      have := (bridge3Specialise p 1728).injective (Subtype.ext h)
+      rw [hG1, b3Act_zmultiples, ← this]
+    rw [bridge3Specialise_zmultiples p 1728 (nearTransport 1728 ⟨m', hm'⟩ g) hgT,
+      redTorsionEquiv_scaleAddEquiv_nearTransport_1728 p ⟨m', hm'⟩ hζs hζ0 hζ4 g hg,
+      ← hP₀def]
+    rw [hmap, AddMonoidHom.map_zmultiples]
+    congr 1
+    have hftvc_smul : fibreTwistVC ζ hζ0 • specialFibre (goodModel 1728) =
+        specialFibre (goodModel 1728) := hftvc ▸ hconjF
+    calc fibreAddEquiv 1728 (fibreTwistEquiv_1728 ζ hζ0 hζ4 P₀)
+        = vcEquivOfSMulEq (fibreVC 1728) (fibreVC_smul 1728)
+            (vcEquivOfSMulEq (fibreTwistVC ζ hζ0) hftvc_smul P₀) := rfl
+      _ = vcEquivOfSMulEq (fibreVC 1728) (fibreVC_smul 1728)
+            (vcEquivOfSMulEq ((fibreVC 1728)⁻¹ * γ * fibreVC 1728) hconjF P₀) := by
+          rw [vcEquivOfSMulEq_congr hftvc hftvc_smul hconjF]
+      _ = vcEquivOfSMulEq γ hγ (vcEquivOfSMulEq (fibreVC 1728) (fibreVC_smul 1728) P₀) :=
+          vcEquivOfSMulEq_conj (fibreVC_smul 1728) hγ P₀
+      _ = _ := rfl
+
+theorem b3_specialisationEquivariance (p : ℕ) [Fact p.Prime] [NeZero p] (j₀ : Qbar) :
+    ∃ β : CycSubH (nearCurve j₀) p ≃ CycSub (WeierstrassCurve.ofJ j₀) p,
+      ∀ G G' : CycSubH (nearCurve j₀) p,
+        (∃ m : HahnSeries.monodromy Qbar, b3Act j₀ m G.1 = G'.1) ↔
+          SameOrbit (WeierstrassCurve.ofJ j₀) (β G).1 (β G').1 := by
+  refine ⟨bridge3Specialise p j₀, fun G G' => ?_⟩
+  by_cases hz : j₀ = 0
+  · subst hz; exact b3_specialisationEquivariance_zero p G G'
+  by_cases h17 : j₀ = 1728
+  · subst h17; exact b3_specialisationEquivariance_1728 p G G'
+  exact b3_specialisationEquivariance_generic p j₀ hz h17 G G'
+
+end ModularCurve.B3
+end
+
+namespace ModularCurve
+p2m_export "ModularCurve" "CycSub SameOrbit"
+namespace B3
+p2m_export "ModularCurve.B3" "coeff_zero_mul_of_integral orderTop_pow_nonneg integralO \
+  mem_integralO resO resO_apply IntegralCoeffs specialFibre val_inv_sU scaleVC goodModel \
+  scaleVC_zero scaleVC_1728 scaleVC_of_ne goodModel_eq_nearCurve"
+p2m_open "ModularCurve.B3 ModularCurve"
+
+open ModularCurve.TatePoint
+
+private theorem orderTop_coeff_PsiSq_nonneg (W : WeierstrassCurve H) (hW : IntegralCoeffs W) (n : ℤ)
+    (k : ℕ) : 0 ≤ ((W.ΨSq n).coeff k).orderTop :=
+  orderTop_coeff_ΨSq_nonneg W hW n k
+
+private theorem orderTop_leadingCoeff_PsiSq_eq_zero (W : WeierstrassCurve H) (n : ℤ)
+    (hn : (n : H) ≠ 0) : (W.ΨSq n).leadingCoeff.orderTop = 0 :=
+  @orderTop_leadingCoeff_ΨSq_eq_zero W n hn
+
+private theorem specialFibre_Delta (W : WeierstrassCurve H) (hW : IntegralCoeffs W) :
+    (specialFibre W).Δ = W.Δ.coeff 0 :=
+  specialFibre_Δ W hW
+
+end ModularCurve.B3
+
+open WeierstrassCurve
+open ModularCurve.TatePoint
+open _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_B3_exists_variableChange_specialFibre_goodModel.ModularCurve
+  _root_.ModularCurve.B3
+  _root_.P2MW.S_ModularCurve_B3_exists_variableChange_specialFibre_goodModel.ModularCurve.B3 in
+theorem solution (j₀ : Qbar) :
+    ∃ C : VariableChange Qbar,
+      C • specialFibre (goodModel j₀) = WeierstrassCurve.ofJ j₀ :=
+  ModularCurve.B3.exists_variableChange_specialFibre_goodModel j₀
+
+end S_ModularCurve_B3_exists_variableChange_specialFibre_goodModel
+end P2MW
+export P2MW.S_ModularCurve_B3_exists_variableChange_specialFibre_goodModel (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve
+open ModularCurve.TatePoint
+theorem ModularCurve.B3.exists_variableChange_specialFibre_goodModel (j₀ : Qbar) :
+    ∃ C : VariableChange Qbar,
+      C • specialFibre (goodModel j₀) = WeierstrassCurve.ofJ j₀ :=
+  solution j₀
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_goodModel_1728_spec.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_goodModel_1728_spec.lean
new file mode 100644
index 0000000000..349aac334e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_goodModel_1728_spec.lean
@@ -0,0 +1,478 @@
+/-
+Based on Prove2Me node ModularCurve.B3.goodModel_1728_spec
+(52339f10-05e7-51eb-933b-d3d9c5e64858) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 59dfbd61-fa48-5bb2-a664-59fc189ad185
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_SpecialisationVocab
+
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integral model at j₀=1728 with unit discriminant
+
+Theorem statement: `ModularCurve.B3.goodModel_1728_spec` (`52339f10-05e7-51eb-933b-d3d9c5e64858`),
+by Claude, 2026-09-05.
+
+Proof: submission `59dfbd61-fa48-5bb2-a664-59fc189ad185`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+The assertion is a closed statement about one explicitly given Weierstrass curve over the series
+field $H$, namely `goodModel 1728`, which is by definition the curve `WeierstrassCurve.ofJ (jNear
+1728)` transformed by the variable change `scaleVC 1728`; since $1728 \ne 0$, that variable change
+is the one with $u =$ `sU (9/12)`, i.e. the scaling factor of exponent $3/4$, and with $r = s = t =
+0$, so it is a pure rescaling with no translation. Three things are asserted. First,
+`IntegralCoeffs` holds for this curve: each of $a_1, a_2, a_3, a_4, a_6$ has $\mathrm{orderTop} \ge
+0$, i.e. all five coefficients lie in the valuation ring. Second, its discriminant satisfies
+$\mathrm{orderTop}\,\Delta = 0$, so $\Delta$ is a unit. Third, the special fibre — the Weierstrass
+curve over $\overline{\mathbb{Q}} =$ `AlgebraicClosure ℚ` whose coefficients are the degree-zero
+coefficients `coeff 0` of $a_1,\dots,a_6$ — admits a witness of `IsElliptic`, and with respect to it
+its $j$-invariant equals $1728$.
+
+This is the good-reduction statement at the special $j$-value $1728$: after a ramified rescaling of
+exponent $3/4$, the curve with $j$-invariant near $1728$ acquires integral coefficients, unit
+discriminant and an elliptic special fibre of $j$-invariant $1728$. It is the counterpart, at $j_0 =
+1728$, of the corresponding statement at $j_0 = 0$, and serves the specialisation vocabulary in
+which reduction of curves and of their torsion over the series field is set up.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_B3_goodModel_1728_spec.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_B3_goodModel_1728_spec
+
+
+open scoped Classical
+open ModularCurve.TatePoint ModularCurve.B3 WeierstrassCurve
+
+noncomputable section
+
+namespace S12B3
+
+abbrev sMon : H := HahnSeries.single (1 : ℚ) (1 : Qbar)
+
+scoped instance charZero_H : CharZero H :=
+  (RingHom.charZero_iff (HahnSeries.C_injective (Γ := ℚ) (R := Qbar))).mp inferInstance
+
+theorem C_ofNat (n : ℕ) [n.AtLeastTwo] :
+    (HahnSeries.C (OfNat.ofNat n : Qbar) : H) = (OfNat.ofNat n : H) := map_ofNat _ n
+
+theorem coeff_zero_C (c : Qbar) : (HahnSeries.C c : H).coeff 0 = c := by
+  rw [HahnSeries.C_apply, HahnSeries.coeff_single_same]
+
+theorem coeff_zero_ofNat (n : ℕ) [n.AtLeastTwo] :
+    (OfNat.ofNat n : H).coeff 0 = (OfNat.ofNat n : Qbar) := by
+  rw [← C_ofNat, coeff_zero_C]
+
+theorem coeff_zero_sMon : sMon.coeff 0 = 0 :=
+  HahnSeries.coeff_single_of_ne (by norm_num)
+
+theorem coeff_one_jNear (j₀ : Qbar) : (jNear j₀).coeff 1 = 1 := by
+  simp only [jNear, HahnSeries.C_apply, HahnSeries.coeff_add, HahnSeries.coeff_single_same,
+    HahnSeries.coeff_single_of_ne (one_ne_zero : (1 : ℚ) ≠ 0), zero_add]
+
+theorem jNear_ne_C (j₀ c : Qbar) : jNear j₀ ≠ HahnSeries.C c := by
+  intro h
+  have h1 := congrArg (fun x : H => x.coeff (1 : ℚ)) h
+  simp only [coeff_one_jNear, HahnSeries.C_apply,
+    HahnSeries.coeff_single_of_ne (one_ne_zero : (1 : ℚ) ≠ 0)] at h1
+  exact one_ne_zero h1
+
+theorem jNear_ne_zero (j₀ : Qbar) : jNear j₀ ≠ 0 := by
+  simpa using jNear_ne_C j₀ 0
+
+theorem jNear_ne_1728 (j₀ : Qbar) : jNear j₀ ≠ 1728 := by
+  rw [← C_ofNat]; exact jNear_ne_C j₀ _
+
+theorem nearCurve_eq (j₀ : Qbar) : nearCurve j₀ = ofJNe0Or1728 (jNear j₀) := by
+  unfold nearCurve
+  exact ofJ_ne_0_ne_1728 _ (jNear_ne_zero j₀) (jNear_ne_1728 j₀)
+
+theorem jNear_sub (j₀ : Qbar) : jNear j₀ - 1728 = HahnSeries.C (j₀ - 1728) + sMon := by
+  rw [jNear, map_sub, C_ofNat]; ring
+
+theorem single_mem {q : ℚ} (hq : 0 ≤ q) (c : Qbar) : (HahnSeries.single q c : H) ∈ integralO := by
+  rw [mem_integralO]
+  by_cases hc : c = 0
+  · simp [hc]
+  · rw [HahnSeries.orderTop_single hc]; exact_mod_cast hq
+
+theorem C_mem (c : Qbar) : (HahnSeries.C c : H) ∈ integralO := by
+  rw [HahnSeries.C_apply]; exact single_mem le_rfl c
+
+theorem sMon_mem : sMon ∈ integralO := single_mem zero_le_one 1
+
+theorem ofNat_mem (n : ℕ) [n.AtLeastTwo] : (OfNat.ofNat n : H) ∈ integralO := by
+  rw [← C_ofNat]; exact C_mem _
+
+theorem inv_ofNat_mem (n : ℕ) [n.AtLeastTwo] : ((OfNat.ofNat n : H)⁻¹) ∈ integralO := by
+  rw [← C_ofNat, ← map_inv₀]; exact C_mem _
+
+theorem w_mem (j₀ : Qbar) : jNear j₀ - 1728 ∈ integralO := by
+  rw [jNear_sub]; exact Subring.add_mem _ (C_mem _) sMon_mem
+
+theorem coeff_zero_w (j₀ : Qbar) : (jNear j₀ - 1728).coeff 0 = j₀ - 1728 := by
+  rw [jNear_sub, HahnSeries.coeff_add, coeff_zero_C, coeff_zero_sMon, add_zero]
+
+theorem orderTop_nonneg_of_mem {x : H} (hx : x ∈ integralO) : 0 ≤ x.orderTop := mem_integralO.mp hx
+
+theorem coeff_zero_mul_mem {x y : H} (hx : x ∈ integralO) (hy : y ∈ integralO) :
+    (x * y).coeff 0 = x.coeff 0 * y.coeff 0 :=
+  coeff_zero_mul_of_integral (mem_integralO.mp hx) (mem_integralO.mp hy)
+
+theorem coeff_zero_pow_mem {x : H} (hx : x ∈ integralO) (k : ℕ) :
+    (x ^ k).coeff 0 = x.coeff 0 ^ k :=
+  coeff_zero_pow_of_integral (mem_integralO.mp hx) k
+
+theorem delta_j1728 : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).Δ = 2985984 := by
+  simp only [WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄, WeierstrassCurve.b₆,
+    WeierstrassCurve.b₈]
+  norm_num
+
+theorem c4_j1728 : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).c₄ = 1728 := by
+  simp only [WeierstrassCurve.c₄, WeierstrassCurve.b₂, WeierstrassCurve.b₄]
+  norm_num
+
+theorem delta_j0 (a : Qbar) : (⟨0, 0, 0, 0, a⟩ : WeierstrassCurve Qbar).Δ = -432 * a ^ 2 := by
+  simp only [WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄, WeierstrassCurve.b₆,
+    WeierstrassCurve.b₈]
+  ring
+
+theorem c4_j0 (a : Qbar) : (⟨0, 0, 0, 0, a⟩ : WeierstrassCurve Qbar).c₄ = 0 := by
+  simp only [WeierstrassCurve.c₄, WeierstrassCurve.b₂, WeierstrassCurve.b₄]
+  ring
+
+theorem j_eq (E : WeierstrassCurve Qbar) [E.IsElliptic] : E.j = E.c₄ ^ 3 * E.Δ⁻¹ := by
+  rw [WeierstrassCurve.j, Units.val_inv_eq_inv_val, WeierstrassCurve.coe_Δ', mul_comm]
+
+section Generic
+
+variable {j₀ : Qbar} (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728)
+include h0 h1728
+
+theorem goodModel_generic : goodModel j₀ = ofJNe0Or1728 (jNear j₀) := by
+  rw [goodModel_eq_nearCurve h0 h1728, nearCurve_eq]
+
+theorem specialFibre_generic : specialFibre (goodModel j₀) = ofJNe0Or1728 j₀ := by
+  rw [goodModel_generic h0 h1728]
+  have hw := w_mem j₀
+  have hc := coeff_zero_w j₀
+  ext
+  · change (jNear j₀ - 1728).coeff 0 = j₀ - 1728
+    exact hc
+  · change (0 : H).coeff 0 = 0
+    simp
+  · change (0 : H).coeff 0 = 0
+    simp
+  · change (-36 * (jNear j₀ - 1728) ^ 3).coeff 0 = -36 * (j₀ - 1728) ^ 3
+    rw [neg_mul, HahnSeries.coeff_neg, coeff_zero_mul_mem (ofNat_mem 36) (Subring.pow_mem _ hw 3),
+      coeff_zero_pow_mem hw, hc, coeff_zero_ofNat, neg_mul]
+  · change (-(jNear j₀ - 1728) ^ 5).coeff 0 = -(j₀ - 1728) ^ 5
+    rw [HahnSeries.coeff_neg, coeff_zero_pow_mem hw, hc]
+
+theorem integralCoeffs_generic : IntegralCoeffs (goodModel j₀) := by
+  rw [goodModel_generic h0 h1728]
+  have hw := w_mem j₀
+  refine ⟨orderTop_nonneg_of_mem hw, by simp [ofJNe0Or1728], by simp [ofJNe0Or1728],
+    orderTop_nonneg_of_mem ?_, orderTop_nonneg_of_mem ?_⟩
+  · change -36 * (jNear j₀ - 1728) ^ 3 ∈ integralO
+    exact Subring.mul_mem _ (Subring.neg_mem _ (ofNat_mem 36)) (Subring.pow_mem _ hw 3)
+  · change -(jNear j₀ - 1728) ^ 5 ∈ integralO
+    exact Subring.neg_mem _ (Subring.pow_mem _ hw 5)
+
+theorem isGood_generic : IntegralCoeffs (goodModel j₀) ∧
+    ∃ h : (specialFibre (goodModel j₀)).IsElliptic,
+      @WeierstrassCurve.j Qbar _ (specialFibre (goodModel j₀)) h = j₀ := by
+  refine ⟨integralCoeffs_generic h0 h1728, ?_⟩
+  rw [specialFibre_generic h0 h1728]
+  have : Fact (IsUnit j₀) := ⟨isUnit_iff_ne_zero.mpr h0⟩
+  have : Fact (IsUnit (j₀ - 1728)) := ⟨isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr h1728)⟩
+  exact ⟨inferInstance, ofJNe0Or1728_j j₀⟩
+
+end Generic
+
+section J1728
+
+theorem jNear_1728_sub : jNear 1728 - 1728 = sMon := by
+  rw [jNear_sub, sub_self, map_zero, zero_add]
+
+theorem goodModel_1728_a₁ : (goodModel 1728).a₁ = HahnSeries.single (1 / 4 : ℚ) (1 : Qbar) := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₁]
+  simp only [ofJNe0Or1728, jNear_1728_sub, val_inv_sU, mul_zero, add_zero]
+  rw [HahnSeries.single_mul_single]; norm_num
+
+theorem goodModel_1728_a₂ : (goodModel 1728).a₂ = 0 := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₂]
+  simp [ofJNe0Or1728]
+
+theorem goodModel_1728_a₃ : (goodModel 1728).a₃ = 0 := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₃]
+  simp [ofJNe0Or1728]
+
+theorem goodModel_1728_a₄ : (goodModel 1728).a₄ = -36 := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₄]
+  simp only [ofJNe0Or1728, jNear_1728_sub, val_inv_sU, mul_zero, zero_mul, sub_zero, add_zero,
+    zero_pow (by norm_num : (2:ℕ) ≠ 0)]
+  rw [HahnSeries.single_pow, show (-36 : H) * sMon ^ 3 = sMon ^ 3 * (-36) from mul_comm _ _,
+    ← mul_assoc, HahnSeries.single_pow, HahnSeries.single_mul_single]
+  norm_num
+
+theorem goodModel_1728_a₆ : (goodModel 1728).a₆ = -HahnSeries.single (1 / 2 : ℚ) (1 : Qbar) := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₆]
+  simp only [ofJNe0Or1728, jNear_1728_sub, val_inv_sU, mul_zero, zero_mul, sub_zero, add_zero,
+    zero_pow (by norm_num : (2:ℕ) ≠ 0), zero_pow (by norm_num : (3:ℕ) ≠ 0)]
+  rw [mul_neg, HahnSeries.single_pow, HahnSeries.single_pow, HahnSeries.single_mul_single]
+  norm_num
+
+theorem specialFibre_1728 : specialFibre (goodModel 1728) = ⟨0, 0, 0, -36, 0⟩ := by
+  ext
+  · change (goodModel 1728).a₁.coeff 0 = 0
+    rw [goodModel_1728_a₁]; exact HahnSeries.coeff_single_of_ne (by norm_num)
+  · change (goodModel 1728).a₂.coeff 0 = 0
+    rw [goodModel_1728_a₂]; simp
+  · change (goodModel 1728).a₃.coeff 0 = 0
+    rw [goodModel_1728_a₃]; simp
+  · change (goodModel 1728).a₄.coeff 0 = -36
+    rw [goodModel_1728_a₄, show (-36 : H) = -(36 : H) from rfl, HahnSeries.coeff_neg,
+      coeff_zero_ofNat]
+  · change (goodModel 1728).a₆.coeff 0 = 0
+    rw [goodModel_1728_a₆, HahnSeries.coeff_neg, HahnSeries.coeff_single_of_ne (by
+      norm_num), neg_zero]
+
+theorem integralCoeffs_1728 : IntegralCoeffs (goodModel 1728) := by
+  refine ⟨?_, ?_, ?_, ?_, ?_⟩
+  · rw [goodModel_1728_a₁]; exact orderTop_nonneg_of_mem (single_mem (by norm_num) _)
+  · rw [goodModel_1728_a₂]; simp
+  · rw [goodModel_1728_a₃]; simp
+  · rw [goodModel_1728_a₄]; exact orderTop_nonneg_of_mem (Subring.neg_mem _ (ofNat_mem 36))
+  · rw [goodModel_1728_a₆]
+    exact orderTop_nonneg_of_mem (Subring.neg_mem _ (single_mem (by norm_num) _))
+
+theorem isGood_1728 : IntegralCoeffs (goodModel 1728) ∧
+    ∃ h : (specialFibre (goodModel 1728)).IsElliptic,
+      @WeierstrassCurve.j Qbar _ (specialFibre (goodModel 1728)) h = 1728 := by
+  refine ⟨integralCoeffs_1728, ?_⟩
+  rw [specialFibre_1728]
+  have hΔ : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).Δ ≠ 0 := by
+    rw [delta_j1728]; norm_num
+  have : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+  refine ⟨inferInstance, ?_⟩
+  rw [j_eq, c4_j1728, delta_j1728]
+  norm_num
+
+end J1728
+
+section J0
+
+abbrev mEl : H := jNear 0 - 1728
+
+theorem jNear_zero : jNear 0 = sMon := by rw [jNear, map_zero, zero_add]
+
+theorem mEl_add : mEl + 1728 = sMon := by rw [mEl, jNear_zero]; ring
+
+theorem mEl_mem : mEl ∈ integralO := w_mem 0
+
+theorem coeff_zero_mEl : mEl.coeff 0 = -1728 := by rw [mEl, coeff_zero_w, zero_sub]
+
+theorem uInv_pow_mul_sMon_four :
+    (HahnSeries.single (-(2 / 12) : ℚ) (1 : Qbar) : H) ^ 4 * sMon = HahnSeries.single (1 / 3 : ℚ) 1
+      := by
+  rw [HahnSeries.single_pow, HahnSeries.single_mul_single]; norm_num
+
+theorem uInv_pow_mul_sMon_six :
+    (HahnSeries.single (-(2 / 12) : ℚ) (1 : Qbar) : H) ^ 6 * sMon = 1 := by
+  rw [HahnSeries.single_pow, HahnSeries.single_mul_single]; norm_num
+
+theorem goodModel_0_a₁ : (goodModel 0).a₁ = 0 := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₁]
+  simp only [ofJNe0Or1728]
+  ring
+
+theorem goodModel_0_a₂ : (goodModel 0).a₂ = 0 := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₂]
+  simp only [ofJNe0Or1728]
+  ring
+
+theorem goodModel_0_a₃ : (goodModel 0).a₃ = 0 := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₃]
+  simp only [ofJNe0Or1728]
+  ring
+
+theorem goodModel_0_a₄ :
+    (goodModel 0).a₄ = HahnSeries.single (1 / 3 : ℚ) (1 : Qbar) * (-mEl ^ 3 / 48) := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₄]
+  simp only [ofJNe0Or1728, val_inv_sU]
+  have key : (-36 * (jNear 0 - 1728) ^ 3 - -(jNear 0 - 1728) / 2 * 0 +
+      2 * (-(jNear 0 - 1728) ^ 2 / 12) * 0 -
+      ((jNear 0 - 1728) ^ 3 / 24 + -(jNear 0 - 1728) ^ 2 / 12 * (-(jNear 0 - 1728) / 2)) *
+        (jNear 0 - 1728) +
+      3 * (-(jNear 0 - 1728) ^ 2 / 12) ^ 2 - 2 * (-(jNear 0 - 1728) / 2) * ((jNear 0 - 1728) ^ 3 /
+        24))
+      = sMon * (-mEl ^ 3 / 48) := by
+    rw [← mEl_add]; simp only [mEl]; ring
+  rw [key, ← mul_assoc, uInv_pow_mul_sMon_four]
+
+theorem goodModel_0_a₆ : (goodModel 0).a₆ = mEl ^ 5 / 864 := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₆]
+  simp only [ofJNe0Or1728, val_inv_sU]
+  have key : (-(jNear 0 - 1728) ^ 5 + -(jNear 0 - 1728) ^ 2 / 12 * (-36 * (jNear 0 - 1728) ^ 3) +
+      (-(jNear 0 - 1728) ^ 2 / 12) ^ 2 * 0 + (-(jNear 0 - 1728) ^ 2 / 12) ^ 3 -
+      (jNear 0 - 1728) ^ 3 / 24 * 0 - ((jNear 0 - 1728) ^ 3 / 24) ^ 2 -
+      -(jNear 0 - 1728) ^ 2 / 12 * ((jNear 0 - 1728) ^ 3 / 24) * (jNear 0 - 1728))
+      = sMon * (mEl ^ 5 / 864) := by
+    rw [← mEl_add]; simp only [mEl]; ring
+  rw [key, ← mul_assoc, uInv_pow_mul_sMon_six, one_mul]
+
+theorem a₄_0_mem : HahnSeries.single (1 / 3 : ℚ) (1 : Qbar) * (-mEl ^ 3 / 48) ∈ integralO := by
+  refine Subring.mul_mem _ (single_mem (by norm_num) _) ?_
+  rw [div_eq_mul_inv]
+  exact Subring.mul_mem _ (Subring.neg_mem _ (Subring.pow_mem _ mEl_mem 3)) (inv_ofNat_mem 48)
+
+theorem a₆_0_mem : mEl ^ 5 / 864 ∈ integralO := by
+  rw [div_eq_mul_inv]
+  exact Subring.mul_mem _ (Subring.pow_mem _ mEl_mem 5) (inv_ofNat_mem 864)
+
+theorem coeff_zero_a₆_0 : (mEl ^ 5 / 864).coeff 0 = (-1728) ^ 5 / 864 := by
+  rw [div_eq_mul_inv, coeff_zero_mul_mem (Subring.pow_mem _ mEl_mem 5) (inv_ofNat_mem 864),
+    coeff_zero_pow_mem mEl_mem, coeff_zero_mEl, ← C_ofNat, ← map_inv₀, coeff_zero_C, div_eq_mul_inv]
+
+theorem specialFibre_0 : specialFibre (goodModel 0) = ⟨0, 0, 0, 0, (-1728) ^ 5 / 864⟩ := by
+  ext
+  · change (goodModel 0).a₁.coeff 0 = 0
+    rw [goodModel_0_a₁]; simp
+  · change (goodModel 0).a₂.coeff 0 = 0
+    rw [goodModel_0_a₂]; simp
+  · change (goodModel 0).a₃.coeff 0 = 0
+    rw [goodModel_0_a₃]; simp
+  · change (goodModel 0).a₄.coeff 0 = 0
+    rw [goodModel_0_a₄, coeff_zero_mul_mem (single_mem (by norm_num) _)
+      (by simpa [div_eq_mul_inv] using
+        (Subring.mul_mem _ (Subring.neg_mem _ (Subring.pow_mem _ mEl_mem 3)) (inv_ofNat_mem 48))),
+      HahnSeries.coeff_single_of_ne (by norm_num), zero_mul]
+  · change (goodModel 0).a₆.coeff 0 = (-1728) ^ 5 / 864
+    rw [goodModel_0_a₆, coeff_zero_a₆_0]
+
+theorem integralCoeffs_0 : IntegralCoeffs (goodModel 0) := by
+  refine ⟨?_, ?_, ?_, ?_, ?_⟩
+  · rw [goodModel_0_a₁]; simp
+  · rw [goodModel_0_a₂]; simp
+  · rw [goodModel_0_a₃]; simp
+  · rw [goodModel_0_a₄]; exact orderTop_nonneg_of_mem a₄_0_mem
+  · rw [goodModel_0_a₆]; exact orderTop_nonneg_of_mem a₆_0_mem
+
+theorem isGood_0 : IntegralCoeffs (goodModel 0) ∧
+    ∃ h : (specialFibre (goodModel 0)).IsElliptic,
+      @WeierstrassCurve.j Qbar _ (specialFibre (goodModel 0)) h = 0 := by
+  refine ⟨integralCoeffs_0, ?_⟩
+  rw [specialFibre_0]
+  have ha : ((-1728 : Qbar) ^ 5 / 864) ≠ 0 := by norm_num
+  have hΔ : (⟨0, 0, 0, 0, (-1728 : Qbar) ^ 5 / 864⟩ : WeierstrassCurve Qbar).Δ ≠ 0 := by
+    rw [delta_j0]; exact mul_ne_zero (by norm_num) (pow_ne_zero _ ha)
+  have : (⟨0, 0, 0, 0, (-1728 : Qbar) ^ 5 / 864⟩ : WeierstrassCurve Qbar).IsElliptic :=
+    ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+  refine ⟨inferInstance, ?_⟩
+  rw [j_eq, c4_j0]
+  ring
+
+end J0
+
+end S12B3
+
+namespace S12B3
+
+theorem orderTop_C_add_sMon {a : Qbar} (ha : a ≠ 0) : (HahnSeries.C a + sMon : H).orderTop = 0 := by
+  have hC : (HahnSeries.C a : H).orderTop = 0 := by
+    rw [HahnSeries.C_apply, HahnSeries.orderTop_single ha]; rfl
+  have hs : (sMon : H).orderTop = 1 := by
+    rw [HahnSeries.orderTop_single one_ne_zero]; rfl
+  rw [HahnSeries.orderTop_add_eq_left (by rw [hC, hs]; exact zero_lt_one), hC]
+
+theorem orderTop_jNear {j₀ : Qbar} (h0 : j₀ ≠ 0) : (jNear j₀).orderTop = 0 := by
+  rw [jNear]; exact orderTop_C_add_sMon h0
+
+theorem orderTop_w' {j₀ : Qbar} (h : j₀ ≠ 1728) : (jNear j₀ - 1728).orderTop = 0 := by
+  rw [jNear_sub]; exact orderTop_C_add_sMon (sub_ne_zero.mpr h)
+
+theorem orderTop_pow_of_eq_zero {x : H} (hx : x.orderTop = 0) (n : ℕ) : (x ^ n).orderTop = 0 := by
+  induction n with
+  | zero => rw [pow_zero, HahnSeries.orderTop_one]
+  | succ n ih => rw [pow_succ, HahnSeries.orderTop_mul, ih, hx, add_zero]
+
+theorem delta_nearCurve (j₀ : Qbar) :
+    (nearCurve j₀).Δ = (jNear j₀) ^ 2 * (jNear j₀ - 1728) ^ 9 := by
+  rw [nearCurve_eq, WeierstrassCurve.ofJNe0Or1728_Δ]
+
+theorem orderTop_delta_nearCurve_generic {j₀ : Qbar} (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) :
+    (nearCurve j₀).Δ.orderTop = 0 := by
+  rw [delta_nearCurve, HahnSeries.orderTop_mul, orderTop_pow_of_eq_zero (orderTop_jNear h0),
+    orderTop_pow_of_eq_zero (orderTop_w' h1728), add_zero]
+
+theorem delta_goodModel_zero : (goodModel 0).Δ = mEl ^ 9 := by
+  rw [goodModel, WeierstrassCurve.variableChange_Δ, scaleVC_zero, delta_nearCurve, jNear_zero]
+  simp only [val_inv_sU]
+  rw [show (HahnSeries.single (-(2 / 12) : ℚ) (1 : Qbar) : H) ^ 12 * (sMon ^ 2 * (sMon - 1728) ^ 9)
+      = (HahnSeries.single (-(2 / 12) : ℚ) (1 : Qbar) ^ 12 * sMon ^ 2) * (sMon - 1728) ^ 9 by ring,
+    HahnSeries.single_pow, HahnSeries.single_pow, HahnSeries.single_mul_single]
+  norm_num
+  rw [mEl, jNear_zero]
+
+theorem orderTop_delta_goodModel_zero : (goodModel 0).Δ.orderTop = 0 := by
+  rw [delta_goodModel_zero]
+  exact orderTop_pow_of_eq_zero (by rw [mEl]; exact orderTop_w' (by norm_num)) 9
+
+theorem delta_goodModel_1728 : (goodModel 1728).Δ = (jNear 1728) ^ 2 := by
+  rw [goodModel, WeierstrassCurve.variableChange_Δ, scaleVC_1728, delta_nearCurve, jNear_1728_sub]
+  simp only [val_inv_sU]
+  rw [show (HahnSeries.single (-(9 / 12) : ℚ) (1 : Qbar) : H) ^ 12 * (jNear 1728 ^ 2 * sMon ^ 9)
+      = (HahnSeries.single (-(9 / 12) : ℚ) (1 : Qbar) ^ 12 * sMon ^ 9) * jNear 1728 ^ 2 by ring,
+    HahnSeries.single_pow, HahnSeries.single_pow, HahnSeries.single_mul_single]
+  norm_num
+
+theorem orderTop_delta_goodModel_1728 : (goodModel 1728).Δ.orderTop = 0 := by
+  rw [delta_goodModel_1728]
+  exact orderTop_pow_of_eq_zero (orderTop_jNear (by norm_num)) 2
+
+end S12B3
+end
+
+open ModularCurve.B3 ModularCurve.TatePoint WeierstrassCurve
+
+theorem solution :
+    IntegralCoeffs (goodModel 1728) ∧ (goodModel 1728).Δ.orderTop = 0 ∧
+      ∃ _ : (specialFibre (goodModel 1728)).IsElliptic,
+        (specialFibre (goodModel 1728)).j = 1728 := by
+  obtain ⟨hint, h, hj⟩ := S12B3.isGood_1728
+  exact ⟨hint, S12B3.orderTop_delta_goodModel_1728, h, hj⟩
+
+end S_ModularCurve_B3_goodModel_1728_spec
+end P2MW
+export P2MW.S_ModularCurve_B3_goodModel_1728_spec (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.B3.goodModel_1728_spec :
+    IntegralCoeffs (goodModel 1728) ∧ (goodModel 1728).Δ.orderTop = 0 ∧
+      ∃ _ : (specialFibre (goodModel 1728)).IsElliptic,
+        (specialFibre (goodModel 1728)).j = 1728 :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_goodModel_generic_spec.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_goodModel_generic_spec.lean
new file mode 100644
index 0000000000..217bc38f02
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_goodModel_generic_spec.lean
@@ -0,0 +1,481 @@
+/-
+Based on Prove2Me node ModularCurve.B3.goodModel_generic_spec
+(cc7fce4b-bc31-5e57-8a2a-f29403028116) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission acd9ec24-7dfa-5c73-8ae8-6bc3fb7e892a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_SpecialisationVocab
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_TatePoint
+
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Good model at generic j₀: integrality, unit Δ, special fibre
+
+Theorem statement: `ModularCurve.B3.goodModel_generic_spec`
+(`cc7fce4b-bc31-5e57-8a2a-f29403028116`), by Claude, 2026-09-05.
+
+Proof: submission `acd9ec24-7dfa-5c73-8ae8-6bc3fb7e892a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $j_0$ be an element of `Qbar`, the algebraic closure of $\mathbb{Q}$, and assume $j_0 \neq 0$
+and $j_0 \neq 1728$. Consider the Weierstrass curve `goodModel j₀` over the coefficient field `H`,
+defined as the variable change `scaleVC j₀` applied to `nearCurve j₀`$=$`WeierstrassCurve.ofJ (jNear
+j₀)`, the standard model over `H` of $j$-invariant `jNear j₀`; under the two hypotheses `scaleVC j₀`
+is by definition the trivial variable change $1$, so `goodModel j₀` is `WeierstrassCurve.ofJ (jNear
+j₀)` itself. The conclusion is a conjunction of three assertions. First, `IntegralCoeffs (goodModel
+j₀)`: each of the five coefficients $a_1, a_2, a_3, a_4, a_6$ has `orderTop` at least $0$. Second,
+the discriminant $\Delta$ of `goodModel j₀` has `orderTop` exactly $0$, i.e. it is of order zero
+rather than positive order. Third, `specialFibre (goodModel j₀)`, the Weierstrass curve over `Qbar`
+whose coefficients are the degree-$0$ coefficients of $a_1, a_2, a_3, a_4, a_6$, is equal on the
+nose to `WeierstrassCurve.ofJ j₀`.
+
+This is the generic case of a three-case construction of an integral model with good reduction at a
+chosen point of the $j$-line: away from $j_0 = 0$ and $j_0 = 1728$ no rescaling is needed, and the
+special fibre is literally the standard curve of $j$-invariant $j_0$. The uniform shape of the three
+conclusions — integral coefficients, discriminant of order zero, identified special fibre — is what
+allows the reduction map on torsion to be applied without distinguishing the cases.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_B3_goodModel_generic_spec.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_B3_goodModel_generic_spec
+
+
+open scoped Classical
+open ModularCurve.TatePoint ModularCurve.B3 WeierstrassCurve
+
+noncomputable section
+
+namespace S12B3
+
+abbrev sMon : H := HahnSeries.single (1 : ℚ) (1 : Qbar)
+
+scoped instance charZero_H : CharZero H :=
+  (RingHom.charZero_iff (HahnSeries.C_injective (Γ := ℚ) (R := Qbar))).mp inferInstance
+
+theorem C_ofNat (n : ℕ) [n.AtLeastTwo] :
+    (HahnSeries.C (OfNat.ofNat n : Qbar) : H) = (OfNat.ofNat n : H) := map_ofNat _ n
+
+theorem coeff_zero_C (c : Qbar) : (HahnSeries.C c : H).coeff 0 = c := by
+  rw [HahnSeries.C_apply, HahnSeries.coeff_single_same]
+
+theorem coeff_zero_ofNat (n : ℕ) [n.AtLeastTwo] :
+    (OfNat.ofNat n : H).coeff 0 = (OfNat.ofNat n : Qbar) := by
+  rw [← C_ofNat, coeff_zero_C]
+
+theorem coeff_zero_sMon : sMon.coeff 0 = 0 :=
+  HahnSeries.coeff_single_of_ne (by norm_num)
+
+theorem coeff_one_jNear (j₀ : Qbar) : (jNear j₀).coeff 1 = 1 := by
+  simp only [jNear, HahnSeries.C_apply, HahnSeries.coeff_add, HahnSeries.coeff_single_same,
+    HahnSeries.coeff_single_of_ne (one_ne_zero : (1 : ℚ) ≠ 0), zero_add]
+
+theorem jNear_ne_C (j₀ c : Qbar) : jNear j₀ ≠ HahnSeries.C c := by
+  intro h
+  have h1 := congrArg (fun x : H => x.coeff (1 : ℚ)) h
+  simp only [coeff_one_jNear, HahnSeries.C_apply,
+    HahnSeries.coeff_single_of_ne (one_ne_zero : (1 : ℚ) ≠ 0)] at h1
+  exact one_ne_zero h1
+
+theorem jNear_ne_zero (j₀ : Qbar) : jNear j₀ ≠ 0 := by
+  simpa using jNear_ne_C j₀ 0
+
+theorem jNear_ne_1728 (j₀ : Qbar) : jNear j₀ ≠ 1728 := by
+  rw [← C_ofNat]; exact jNear_ne_C j₀ _
+
+theorem nearCurve_eq (j₀ : Qbar) : nearCurve j₀ = ofJNe0Or1728 (jNear j₀) := by
+  unfold nearCurve
+  exact ofJ_ne_0_ne_1728 _ (jNear_ne_zero j₀) (jNear_ne_1728 j₀)
+
+theorem jNear_sub (j₀ : Qbar) : jNear j₀ - 1728 = HahnSeries.C (j₀ - 1728) + sMon := by
+  rw [jNear, map_sub, C_ofNat]; ring
+
+theorem single_mem {q : ℚ} (hq : 0 ≤ q) (c : Qbar) : (HahnSeries.single q c : H) ∈ integralO := by
+  rw [mem_integralO]
+  by_cases hc : c = 0
+  · simp [hc]
+  · rw [HahnSeries.orderTop_single hc]; exact_mod_cast hq
+
+theorem C_mem (c : Qbar) : (HahnSeries.C c : H) ∈ integralO := by
+  rw [HahnSeries.C_apply]; exact single_mem le_rfl c
+
+theorem sMon_mem : sMon ∈ integralO := single_mem zero_le_one 1
+
+theorem ofNat_mem (n : ℕ) [n.AtLeastTwo] : (OfNat.ofNat n : H) ∈ integralO := by
+  rw [← C_ofNat]; exact C_mem _
+
+theorem inv_ofNat_mem (n : ℕ) [n.AtLeastTwo] : ((OfNat.ofNat n : H)⁻¹) ∈ integralO := by
+  rw [← C_ofNat, ← map_inv₀]; exact C_mem _
+
+theorem w_mem (j₀ : Qbar) : jNear j₀ - 1728 ∈ integralO := by
+  rw [jNear_sub]; exact Subring.add_mem _ (C_mem _) sMon_mem
+
+theorem coeff_zero_w (j₀ : Qbar) : (jNear j₀ - 1728).coeff 0 = j₀ - 1728 := by
+  rw [jNear_sub, HahnSeries.coeff_add, coeff_zero_C, coeff_zero_sMon, add_zero]
+
+theorem orderTop_nonneg_of_mem {x : H} (hx : x ∈ integralO) : 0 ≤ x.orderTop := mem_integralO.mp hx
+
+theorem coeff_zero_mul_mem {x y : H} (hx : x ∈ integralO) (hy : y ∈ integralO) :
+    (x * y).coeff 0 = x.coeff 0 * y.coeff 0 :=
+  coeff_zero_mul_of_integral (mem_integralO.mp hx) (mem_integralO.mp hy)
+
+theorem coeff_zero_pow_mem {x : H} (hx : x ∈ integralO) (k : ℕ) :
+    (x ^ k).coeff 0 = x.coeff 0 ^ k :=
+  coeff_zero_pow_of_integral (mem_integralO.mp hx) k
+
+theorem delta_j1728 : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).Δ = 2985984 := by
+  simp only [WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄, WeierstrassCurve.b₆,
+    WeierstrassCurve.b₈]
+  norm_num
+
+theorem c4_j1728 : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).c₄ = 1728 := by
+  simp only [WeierstrassCurve.c₄, WeierstrassCurve.b₂, WeierstrassCurve.b₄]
+  norm_num
+
+theorem delta_j0 (a : Qbar) : (⟨0, 0, 0, 0, a⟩ : WeierstrassCurve Qbar).Δ = -432 * a ^ 2 := by
+  simp only [WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄, WeierstrassCurve.b₆,
+    WeierstrassCurve.b₈]
+  ring
+
+theorem c4_j0 (a : Qbar) : (⟨0, 0, 0, 0, a⟩ : WeierstrassCurve Qbar).c₄ = 0 := by
+  simp only [WeierstrassCurve.c₄, WeierstrassCurve.b₂, WeierstrassCurve.b₄]
+  ring
+
+theorem j_eq (E : WeierstrassCurve Qbar) [E.IsElliptic] : E.j = E.c₄ ^ 3 * E.Δ⁻¹ := by
+  rw [WeierstrassCurve.j, Units.val_inv_eq_inv_val, WeierstrassCurve.coe_Δ', mul_comm]
+
+section Generic
+
+variable {j₀ : Qbar} (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728)
+include h0 h1728
+
+theorem goodModel_generic : goodModel j₀ = ofJNe0Or1728 (jNear j₀) := by
+  rw [goodModel_eq_nearCurve h0 h1728, nearCurve_eq]
+
+theorem specialFibre_generic : specialFibre (goodModel j₀) = ofJNe0Or1728 j₀ := by
+  rw [goodModel_generic h0 h1728]
+  have hw := w_mem j₀
+  have hc := coeff_zero_w j₀
+  ext
+  · change (jNear j₀ - 1728).coeff 0 = j₀ - 1728
+    exact hc
+  · change (0 : H).coeff 0 = 0
+    simp
+  · change (0 : H).coeff 0 = 0
+    simp
+  · change (-36 * (jNear j₀ - 1728) ^ 3).coeff 0 = -36 * (j₀ - 1728) ^ 3
+    rw [neg_mul, HahnSeries.coeff_neg, coeff_zero_mul_mem (ofNat_mem 36) (Subring.pow_mem _ hw 3),
+      coeff_zero_pow_mem hw, hc, coeff_zero_ofNat, neg_mul]
+  · change (-(jNear j₀ - 1728) ^ 5).coeff 0 = -(j₀ - 1728) ^ 5
+    rw [HahnSeries.coeff_neg, coeff_zero_pow_mem hw, hc]
+
+theorem integralCoeffs_generic : IntegralCoeffs (goodModel j₀) := by
+  rw [goodModel_generic h0 h1728]
+  have hw := w_mem j₀
+  refine ⟨orderTop_nonneg_of_mem hw, by simp [ofJNe0Or1728], by simp [ofJNe0Or1728],
+    orderTop_nonneg_of_mem ?_, orderTop_nonneg_of_mem ?_⟩
+  · change -36 * (jNear j₀ - 1728) ^ 3 ∈ integralO
+    exact Subring.mul_mem _ (Subring.neg_mem _ (ofNat_mem 36)) (Subring.pow_mem _ hw 3)
+  · change -(jNear j₀ - 1728) ^ 5 ∈ integralO
+    exact Subring.neg_mem _ (Subring.pow_mem _ hw 5)
+
+theorem isGood_generic : IntegralCoeffs (goodModel j₀) ∧
+    ∃ h : (specialFibre (goodModel j₀)).IsElliptic,
+      @WeierstrassCurve.j Qbar _ (specialFibre (goodModel j₀)) h = j₀ := by
+  refine ⟨integralCoeffs_generic h0 h1728, ?_⟩
+  rw [specialFibre_generic h0 h1728]
+  have : Fact (IsUnit j₀) := ⟨isUnit_iff_ne_zero.mpr h0⟩
+  have : Fact (IsUnit (j₀ - 1728)) := ⟨isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr h1728)⟩
+  exact ⟨inferInstance, ofJNe0Or1728_j j₀⟩
+
+end Generic
+
+section J1728
+
+theorem jNear_1728_sub : jNear 1728 - 1728 = sMon := by
+  rw [jNear_sub, sub_self, map_zero, zero_add]
+
+theorem goodModel_1728_a₁ : (goodModel 1728).a₁ = HahnSeries.single (1 / 4 : ℚ) (1 : Qbar) := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₁]
+  simp only [ofJNe0Or1728, jNear_1728_sub, val_inv_sU, mul_zero, add_zero]
+  rw [HahnSeries.single_mul_single]; norm_num
+
+theorem goodModel_1728_a₂ : (goodModel 1728).a₂ = 0 := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₂]
+  simp [ofJNe0Or1728]
+
+theorem goodModel_1728_a₃ : (goodModel 1728).a₃ = 0 := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₃]
+  simp [ofJNe0Or1728]
+
+theorem goodModel_1728_a₄ : (goodModel 1728).a₄ = -36 := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₄]
+  simp only [ofJNe0Or1728, jNear_1728_sub, val_inv_sU, mul_zero, zero_mul, sub_zero, add_zero,
+    zero_pow (by norm_num : (2:ℕ) ≠ 0)]
+  rw [HahnSeries.single_pow, show (-36 : H) * sMon ^ 3 = sMon ^ 3 * (-36) from mul_comm _ _,
+    ← mul_assoc, HahnSeries.single_pow, HahnSeries.single_mul_single]
+  norm_num
+
+theorem goodModel_1728_a₆ : (goodModel 1728).a₆ = -HahnSeries.single (1 / 2 : ℚ) (1 : Qbar) := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₆]
+  simp only [ofJNe0Or1728, jNear_1728_sub, val_inv_sU, mul_zero, zero_mul, sub_zero, add_zero,
+    zero_pow (by norm_num : (2:ℕ) ≠ 0), zero_pow (by norm_num : (3:ℕ) ≠ 0)]
+  rw [mul_neg, HahnSeries.single_pow, HahnSeries.single_pow, HahnSeries.single_mul_single]
+  norm_num
+
+theorem specialFibre_1728 : specialFibre (goodModel 1728) = ⟨0, 0, 0, -36, 0⟩ := by
+  ext
+  · change (goodModel 1728).a₁.coeff 0 = 0
+    rw [goodModel_1728_a₁]; exact HahnSeries.coeff_single_of_ne (by norm_num)
+  · change (goodModel 1728).a₂.coeff 0 = 0
+    rw [goodModel_1728_a₂]; simp
+  · change (goodModel 1728).a₃.coeff 0 = 0
+    rw [goodModel_1728_a₃]; simp
+  · change (goodModel 1728).a₄.coeff 0 = -36
+    rw [goodModel_1728_a₄, show (-36 : H) = -(36 : H) from rfl, HahnSeries.coeff_neg,
+      coeff_zero_ofNat]
+  · change (goodModel 1728).a₆.coeff 0 = 0
+    rw [goodModel_1728_a₆, HahnSeries.coeff_neg, HahnSeries.coeff_single_of_ne (by
+      norm_num), neg_zero]
+
+theorem integralCoeffs_1728 : IntegralCoeffs (goodModel 1728) := by
+  refine ⟨?_, ?_, ?_, ?_, ?_⟩
+  · rw [goodModel_1728_a₁]; exact orderTop_nonneg_of_mem (single_mem (by norm_num) _)
+  · rw [goodModel_1728_a₂]; simp
+  · rw [goodModel_1728_a₃]; simp
+  · rw [goodModel_1728_a₄]; exact orderTop_nonneg_of_mem (Subring.neg_mem _ (ofNat_mem 36))
+  · rw [goodModel_1728_a₆]
+    exact orderTop_nonneg_of_mem (Subring.neg_mem _ (single_mem (by norm_num) _))
+
+theorem isGood_1728 : IntegralCoeffs (goodModel 1728) ∧
+    ∃ h : (specialFibre (goodModel 1728)).IsElliptic,
+      @WeierstrassCurve.j Qbar _ (specialFibre (goodModel 1728)) h = 1728 := by
+  refine ⟨integralCoeffs_1728, ?_⟩
+  rw [specialFibre_1728]
+  have hΔ : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).Δ ≠ 0 := by
+    rw [delta_j1728]; norm_num
+  have : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+  refine ⟨inferInstance, ?_⟩
+  rw [j_eq, c4_j1728, delta_j1728]
+  norm_num
+
+end J1728
+
+section J0
+
+abbrev mEl : H := jNear 0 - 1728
+
+theorem jNear_zero : jNear 0 = sMon := by rw [jNear, map_zero, zero_add]
+
+theorem mEl_add : mEl + 1728 = sMon := by rw [mEl, jNear_zero]; ring
+
+theorem mEl_mem : mEl ∈ integralO := w_mem 0
+
+theorem coeff_zero_mEl : mEl.coeff 0 = -1728 := by rw [mEl, coeff_zero_w, zero_sub]
+
+theorem uInv_pow_mul_sMon_four :
+    (HahnSeries.single (-(2 / 12) : ℚ) (1 : Qbar) : H) ^ 4 * sMon = HahnSeries.single (1 / 3 : ℚ) 1
+      := by
+  rw [HahnSeries.single_pow, HahnSeries.single_mul_single]; norm_num
+
+theorem uInv_pow_mul_sMon_six :
+    (HahnSeries.single (-(2 / 12) : ℚ) (1 : Qbar) : H) ^ 6 * sMon = 1 := by
+  rw [HahnSeries.single_pow, HahnSeries.single_mul_single]; norm_num
+
+theorem goodModel_0_a₁ : (goodModel 0).a₁ = 0 := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₁]
+  simp only [ofJNe0Or1728]
+  ring
+
+theorem goodModel_0_a₂ : (goodModel 0).a₂ = 0 := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₂]
+  simp only [ofJNe0Or1728]
+  ring
+
+theorem goodModel_0_a₃ : (goodModel 0).a₃ = 0 := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₃]
+  simp only [ofJNe0Or1728]
+  ring
+
+theorem goodModel_0_a₄ :
+    (goodModel 0).a₄ = HahnSeries.single (1 / 3 : ℚ) (1 : Qbar) * (-mEl ^ 3 / 48) := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₄]
+  simp only [ofJNe0Or1728, val_inv_sU]
+  have key : (-36 * (jNear 0 - 1728) ^ 3 - -(jNear 0 - 1728) / 2 * 0 +
+      2 * (-(jNear 0 - 1728) ^ 2 / 12) * 0 -
+      ((jNear 0 - 1728) ^ 3 / 24 + -(jNear 0 - 1728) ^ 2 / 12 * (-(jNear 0 - 1728) / 2)) *
+        (jNear 0 - 1728) +
+      3 * (-(jNear 0 - 1728) ^ 2 / 12) ^ 2 - 2 * (-(jNear 0 - 1728) / 2) * ((jNear 0 - 1728) ^ 3 /
+        24))
+      = sMon * (-mEl ^ 3 / 48) := by
+    rw [← mEl_add]; simp only [mEl]; ring
+  rw [key, ← mul_assoc, uInv_pow_mul_sMon_four]
+
+theorem goodModel_0_a₆ : (goodModel 0).a₆ = mEl ^ 5 / 864 := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₆]
+  simp only [ofJNe0Or1728, val_inv_sU]
+  have key : (-(jNear 0 - 1728) ^ 5 + -(jNear 0 - 1728) ^ 2 / 12 * (-36 * (jNear 0 - 1728) ^ 3) +
+      (-(jNear 0 - 1728) ^ 2 / 12) ^ 2 * 0 + (-(jNear 0 - 1728) ^ 2 / 12) ^ 3 -
+      (jNear 0 - 1728) ^ 3 / 24 * 0 - ((jNear 0 - 1728) ^ 3 / 24) ^ 2 -
+      -(jNear 0 - 1728) ^ 2 / 12 * ((jNear 0 - 1728) ^ 3 / 24) * (jNear 0 - 1728))
+      = sMon * (mEl ^ 5 / 864) := by
+    rw [← mEl_add]; simp only [mEl]; ring
+  rw [key, ← mul_assoc, uInv_pow_mul_sMon_six, one_mul]
+
+theorem a₄_0_mem : HahnSeries.single (1 / 3 : ℚ) (1 : Qbar) * (-mEl ^ 3 / 48) ∈ integralO := by
+  refine Subring.mul_mem _ (single_mem (by norm_num) _) ?_
+  rw [div_eq_mul_inv]
+  exact Subring.mul_mem _ (Subring.neg_mem _ (Subring.pow_mem _ mEl_mem 3)) (inv_ofNat_mem 48)
+
+theorem a₆_0_mem : mEl ^ 5 / 864 ∈ integralO := by
+  rw [div_eq_mul_inv]
+  exact Subring.mul_mem _ (Subring.pow_mem _ mEl_mem 5) (inv_ofNat_mem 864)
+
+theorem coeff_zero_a₆_0 : (mEl ^ 5 / 864).coeff 0 = (-1728) ^ 5 / 864 := by
+  rw [div_eq_mul_inv, coeff_zero_mul_mem (Subring.pow_mem _ mEl_mem 5) (inv_ofNat_mem 864),
+    coeff_zero_pow_mem mEl_mem, coeff_zero_mEl, ← C_ofNat, ← map_inv₀, coeff_zero_C, div_eq_mul_inv]
+
+theorem specialFibre_0 : specialFibre (goodModel 0) = ⟨0, 0, 0, 0, (-1728) ^ 5 / 864⟩ := by
+  ext
+  · change (goodModel 0).a₁.coeff 0 = 0
+    rw [goodModel_0_a₁]; simp
+  · change (goodModel 0).a₂.coeff 0 = 0
+    rw [goodModel_0_a₂]; simp
+  · change (goodModel 0).a₃.coeff 0 = 0
+    rw [goodModel_0_a₃]; simp
+  · change (goodModel 0).a₄.coeff 0 = 0
+    rw [goodModel_0_a₄, coeff_zero_mul_mem (single_mem (by norm_num) _)
+      (by simpa [div_eq_mul_inv] using
+        (Subring.mul_mem _ (Subring.neg_mem _ (Subring.pow_mem _ mEl_mem 3)) (inv_ofNat_mem 48))),
+      HahnSeries.coeff_single_of_ne (by norm_num), zero_mul]
+  · change (goodModel 0).a₆.coeff 0 = (-1728) ^ 5 / 864
+    rw [goodModel_0_a₆, coeff_zero_a₆_0]
+
+theorem integralCoeffs_0 : IntegralCoeffs (goodModel 0) := by
+  refine ⟨?_, ?_, ?_, ?_, ?_⟩
+  · rw [goodModel_0_a₁]; simp
+  · rw [goodModel_0_a₂]; simp
+  · rw [goodModel_0_a₃]; simp
+  · rw [goodModel_0_a₄]; exact orderTop_nonneg_of_mem a₄_0_mem
+  · rw [goodModel_0_a₆]; exact orderTop_nonneg_of_mem a₆_0_mem
+
+theorem isGood_0 : IntegralCoeffs (goodModel 0) ∧
+    ∃ h : (specialFibre (goodModel 0)).IsElliptic,
+      @WeierstrassCurve.j Qbar _ (specialFibre (goodModel 0)) h = 0 := by
+  refine ⟨integralCoeffs_0, ?_⟩
+  rw [specialFibre_0]
+  have ha : ((-1728 : Qbar) ^ 5 / 864) ≠ 0 := by norm_num
+  have hΔ : (⟨0, 0, 0, 0, (-1728 : Qbar) ^ 5 / 864⟩ : WeierstrassCurve Qbar).Δ ≠ 0 := by
+    rw [delta_j0]; exact mul_ne_zero (by norm_num) (pow_ne_zero _ ha)
+  have : (⟨0, 0, 0, 0, (-1728 : Qbar) ^ 5 / 864⟩ : WeierstrassCurve Qbar).IsElliptic :=
+    ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+  refine ⟨inferInstance, ?_⟩
+  rw [j_eq, c4_j0]
+  ring
+
+end J0
+
+end S12B3
+
+namespace S12B3
+
+theorem orderTop_C_add_sMon {a : Qbar} (ha : a ≠ 0) : (HahnSeries.C a + sMon : H).orderTop = 0 := by
+  have hC : (HahnSeries.C a : H).orderTop = 0 := by
+    rw [HahnSeries.C_apply, HahnSeries.orderTop_single ha]; rfl
+  have hs : (sMon : H).orderTop = 1 := by
+    rw [HahnSeries.orderTop_single one_ne_zero]; rfl
+  rw [HahnSeries.orderTop_add_eq_left (by rw [hC, hs]; exact zero_lt_one), hC]
+
+theorem orderTop_jNear {j₀ : Qbar} (h0 : j₀ ≠ 0) : (jNear j₀).orderTop = 0 := by
+  rw [jNear]; exact orderTop_C_add_sMon h0
+
+theorem orderTop_w' {j₀ : Qbar} (h : j₀ ≠ 1728) : (jNear j₀ - 1728).orderTop = 0 := by
+  rw [jNear_sub]; exact orderTop_C_add_sMon (sub_ne_zero.mpr h)
+
+theorem orderTop_pow_of_eq_zero {x : H} (hx : x.orderTop = 0) (n : ℕ) : (x ^ n).orderTop = 0 := by
+  induction n with
+  | zero => rw [pow_zero, HahnSeries.orderTop_one]
+  | succ n ih => rw [pow_succ, HahnSeries.orderTop_mul, ih, hx, add_zero]
+
+theorem delta_nearCurve (j₀ : Qbar) :
+    (nearCurve j₀).Δ = (jNear j₀) ^ 2 * (jNear j₀ - 1728) ^ 9 := by
+  rw [nearCurve_eq, WeierstrassCurve.ofJNe0Or1728_Δ]
+
+theorem orderTop_delta_nearCurve_generic {j₀ : Qbar} (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) :
+    (nearCurve j₀).Δ.orderTop = 0 := by
+  rw [delta_nearCurve, HahnSeries.orderTop_mul, orderTop_pow_of_eq_zero (orderTop_jNear h0),
+    orderTop_pow_of_eq_zero (orderTop_w' h1728), add_zero]
+
+theorem delta_goodModel_zero : (goodModel 0).Δ = mEl ^ 9 := by
+  rw [goodModel, WeierstrassCurve.variableChange_Δ, scaleVC_zero, delta_nearCurve, jNear_zero]
+  simp only [val_inv_sU]
+  rw [show (HahnSeries.single (-(2 / 12) : ℚ) (1 : Qbar) : H) ^ 12 * (sMon ^ 2 * (sMon - 1728) ^ 9)
+      = (HahnSeries.single (-(2 / 12) : ℚ) (1 : Qbar) ^ 12 * sMon ^ 2) * (sMon - 1728) ^ 9 by ring,
+    HahnSeries.single_pow, HahnSeries.single_pow, HahnSeries.single_mul_single]
+  norm_num
+  rw [mEl, jNear_zero]
+
+theorem orderTop_delta_goodModel_zero : (goodModel 0).Δ.orderTop = 0 := by
+  rw [delta_goodModel_zero]
+  exact orderTop_pow_of_eq_zero (by rw [mEl]; exact orderTop_w' (by norm_num)) 9
+
+theorem delta_goodModel_1728 : (goodModel 1728).Δ = (jNear 1728) ^ 2 := by
+  rw [goodModel, WeierstrassCurve.variableChange_Δ, scaleVC_1728, delta_nearCurve, jNear_1728_sub]
+  simp only [val_inv_sU]
+  rw [show (HahnSeries.single (-(9 / 12) : ℚ) (1 : Qbar) : H) ^ 12 * (jNear 1728 ^ 2 * sMon ^ 9)
+      = (HahnSeries.single (-(9 / 12) : ℚ) (1 : Qbar) ^ 12 * sMon ^ 9) * jNear 1728 ^ 2 by ring,
+    HahnSeries.single_pow, HahnSeries.single_pow, HahnSeries.single_mul_single]
+  norm_num
+
+theorem orderTop_delta_goodModel_1728 : (goodModel 1728).Δ.orderTop = 0 := by
+  rw [delta_goodModel_1728]
+  exact orderTop_pow_of_eq_zero (orderTop_jNear (by norm_num)) 2
+
+end S12B3
+end
+
+open ModularCurve.B3 ModularCurve.TatePoint WeierstrassCurve
+
+theorem solution (j₀ : Qbar) (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) :
+    IntegralCoeffs (goodModel j₀) ∧ (goodModel j₀).Δ.orderTop = 0 ∧
+      specialFibre (goodModel j₀) = WeierstrassCurve.ofJ j₀ := by
+  refine ⟨S12B3.integralCoeffs_generic h0 h1728, ?_, ?_⟩
+  · rw [goodModel_eq_nearCurve h0 h1728]; exact S12B3.orderTop_delta_nearCurve_generic h0 h1728
+  · rw [S12B3.specialFibre_generic h0
+      h1728]; exact (WeierstrassCurve.ofJ_ne_0_ne_1728 j₀ h0 h1728).symm
+
+end S_ModularCurve_B3_goodModel_generic_spec
+end P2MW
+export P2MW.S_ModularCurve_B3_goodModel_generic_spec (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve.TatePoint
+theorem ModularCurve.B3.goodModel_generic_spec (j₀ : Qbar) (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) :
+    IntegralCoeffs (goodModel j₀) ∧ (goodModel j₀).Δ.orderTop = 0 ∧
+      specialFibre (goodModel j₀) = WeierstrassCurve.ofJ j₀ :=
+  solution j₀ h0 h1728
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_goodModel_zero_spec.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_goodModel_zero_spec.lean
new file mode 100644
index 0000000000..74a33220e3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_goodModel_zero_spec.lean
@@ -0,0 +1,477 @@
+/-
+Based on Prove2Me node ModularCurve.B3.goodModel_zero_spec
+(9d60ebf5-a066-5670-9a53-57b66a6dd389) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5c4ac12c-2b89-524d-91ab-e523b7ea06f2
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_SpecialisationVocab
+
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integral model at j₀=0: unit discriminant, elliptic special fibre
+
+Theorem statement: `ModularCurve.B3.goodModel_zero_spec` (`9d60ebf5-a066-5670-9a53-57b66a6dd389`),
+by Claude, 2026-09-05.
+
+Proof: submission `5c4ac12c-2b89-524d-91ab-e523b7ea06f2`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+A closed assertion, with no hypotheses, about the single Weierstrass curve `goodModel 0` over the
+coefficient field $H$ of the project (whose elements carry an `orderTop` and coefficients, the
+coefficient in degree $0$ lying in $\overline{\mathbb{Q}} =$ `AlgebraicClosure ℚ`). By definition
+`goodModel 0` is the result of acting on `nearCurve 0` $=$ `WeierstrassCurve.ofJ (jNear 0)`,
+Mathlib's explicit model with $j$-invariant `jNear 0`, by the admissible variable change `scaleVC 0`
+with parameters $u =$ `sU (2/12)`, $r = -(\mathtt{jNear }0 - 1728)^2/12$, $s = -(\mathtt{jNear
+}0-1728)/2$ and $t = (\mathtt{jNear }0-1728)^3/24$. Three things are asserted about this curve.
+First, `IntegralCoeffs` holds: each of $a_1, a_2, a_3, a_4, a_6$ has `orderTop` at least $0$.
+Second, its discriminant $\Delta$ has `orderTop` exactly $0$. Third, the curve `specialFibre
+(goodModel 0)` over $\overline{\mathbb{Q}}$ obtained by taking the degree-$0$ coefficient of each of
+the five $a_i$ is elliptic, i.e. satisfies `IsElliptic`, and its $j$-invariant (formed with respect
+to that ellipticity) equals $0$.
+
+This is the concrete form, at the elliptic point $j = 0$, of the statement that a curve whose
+$j$-invariant is integral acquires good reduction after a tame base change: the rescaled model has
+integral coefficients and unit discriminant, so its special fibre is an elliptic curve, here of
+$j$-invariant $0$. The three conclusions are what is needed downstream to reduce torsion points to
+the special fibre.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_B3_goodModel_zero_spec.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_B3_goodModel_zero_spec
+
+
+open scoped Classical
+open ModularCurve.TatePoint ModularCurve.B3 WeierstrassCurve
+
+noncomputable section
+
+namespace S12B3
+
+abbrev sMon : H := HahnSeries.single (1 : ℚ) (1 : Qbar)
+
+scoped instance charZero_H : CharZero H :=
+  (RingHom.charZero_iff (HahnSeries.C_injective (Γ := ℚ) (R := Qbar))).mp inferInstance
+
+theorem C_ofNat (n : ℕ) [n.AtLeastTwo] :
+    (HahnSeries.C (OfNat.ofNat n : Qbar) : H) = (OfNat.ofNat n : H) := map_ofNat _ n
+
+theorem coeff_zero_C (c : Qbar) : (HahnSeries.C c : H).coeff 0 = c := by
+  rw [HahnSeries.C_apply, HahnSeries.coeff_single_same]
+
+theorem coeff_zero_ofNat (n : ℕ) [n.AtLeastTwo] :
+    (OfNat.ofNat n : H).coeff 0 = (OfNat.ofNat n : Qbar) := by
+  rw [← C_ofNat, coeff_zero_C]
+
+theorem coeff_zero_sMon : sMon.coeff 0 = 0 :=
+  HahnSeries.coeff_single_of_ne (by norm_num)
+
+theorem coeff_one_jNear (j₀ : Qbar) : (jNear j₀).coeff 1 = 1 := by
+  simp only [jNear, HahnSeries.C_apply, HahnSeries.coeff_add, HahnSeries.coeff_single_same,
+    HahnSeries.coeff_single_of_ne (one_ne_zero : (1 : ℚ) ≠ 0), zero_add]
+
+theorem jNear_ne_C (j₀ c : Qbar) : jNear j₀ ≠ HahnSeries.C c := by
+  intro h
+  have h1 := congrArg (fun x : H => x.coeff (1 : ℚ)) h
+  simp only [coeff_one_jNear, HahnSeries.C_apply,
+    HahnSeries.coeff_single_of_ne (one_ne_zero : (1 : ℚ) ≠ 0)] at h1
+  exact one_ne_zero h1
+
+theorem jNear_ne_zero (j₀ : Qbar) : jNear j₀ ≠ 0 := by
+  simpa using jNear_ne_C j₀ 0
+
+theorem jNear_ne_1728 (j₀ : Qbar) : jNear j₀ ≠ 1728 := by
+  rw [← C_ofNat]; exact jNear_ne_C j₀ _
+
+theorem nearCurve_eq (j₀ : Qbar) : nearCurve j₀ = ofJNe0Or1728 (jNear j₀) := by
+  unfold nearCurve
+  exact ofJ_ne_0_ne_1728 _ (jNear_ne_zero j₀) (jNear_ne_1728 j₀)
+
+theorem jNear_sub (j₀ : Qbar) : jNear j₀ - 1728 = HahnSeries.C (j₀ - 1728) + sMon := by
+  rw [jNear, map_sub, C_ofNat]; ring
+
+theorem single_mem {q : ℚ} (hq : 0 ≤ q) (c : Qbar) : (HahnSeries.single q c : H) ∈ integralO := by
+  rw [mem_integralO]
+  by_cases hc : c = 0
+  · simp [hc]
+  · rw [HahnSeries.orderTop_single hc]; exact_mod_cast hq
+
+theorem C_mem (c : Qbar) : (HahnSeries.C c : H) ∈ integralO := by
+  rw [HahnSeries.C_apply]; exact single_mem le_rfl c
+
+theorem sMon_mem : sMon ∈ integralO := single_mem zero_le_one 1
+
+theorem ofNat_mem (n : ℕ) [n.AtLeastTwo] : (OfNat.ofNat n : H) ∈ integralO := by
+  rw [← C_ofNat]; exact C_mem _
+
+theorem inv_ofNat_mem (n : ℕ) [n.AtLeastTwo] : ((OfNat.ofNat n : H)⁻¹) ∈ integralO := by
+  rw [← C_ofNat, ← map_inv₀]; exact C_mem _
+
+theorem w_mem (j₀ : Qbar) : jNear j₀ - 1728 ∈ integralO := by
+  rw [jNear_sub]; exact Subring.add_mem _ (C_mem _) sMon_mem
+
+theorem coeff_zero_w (j₀ : Qbar) : (jNear j₀ - 1728).coeff 0 = j₀ - 1728 := by
+  rw [jNear_sub, HahnSeries.coeff_add, coeff_zero_C, coeff_zero_sMon, add_zero]
+
+theorem orderTop_nonneg_of_mem {x : H} (hx : x ∈ integralO) : 0 ≤ x.orderTop := mem_integralO.mp hx
+
+theorem coeff_zero_mul_mem {x y : H} (hx : x ∈ integralO) (hy : y ∈ integralO) :
+    (x * y).coeff 0 = x.coeff 0 * y.coeff 0 :=
+  coeff_zero_mul_of_integral (mem_integralO.mp hx) (mem_integralO.mp hy)
+
+theorem coeff_zero_pow_mem {x : H} (hx : x ∈ integralO) (k : ℕ) :
+    (x ^ k).coeff 0 = x.coeff 0 ^ k :=
+  coeff_zero_pow_of_integral (mem_integralO.mp hx) k
+
+theorem delta_j1728 : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).Δ = 2985984 := by
+  simp only [WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄, WeierstrassCurve.b₆,
+    WeierstrassCurve.b₈]
+  norm_num
+
+theorem c4_j1728 : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).c₄ = 1728 := by
+  simp only [WeierstrassCurve.c₄, WeierstrassCurve.b₂, WeierstrassCurve.b₄]
+  norm_num
+
+theorem delta_j0 (a : Qbar) : (⟨0, 0, 0, 0, a⟩ : WeierstrassCurve Qbar).Δ = -432 * a ^ 2 := by
+  simp only [WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄, WeierstrassCurve.b₆,
+    WeierstrassCurve.b₈]
+  ring
+
+theorem c4_j0 (a : Qbar) : (⟨0, 0, 0, 0, a⟩ : WeierstrassCurve Qbar).c₄ = 0 := by
+  simp only [WeierstrassCurve.c₄, WeierstrassCurve.b₂, WeierstrassCurve.b₄]
+  ring
+
+theorem j_eq (E : WeierstrassCurve Qbar) [E.IsElliptic] : E.j = E.c₄ ^ 3 * E.Δ⁻¹ := by
+  rw [WeierstrassCurve.j, Units.val_inv_eq_inv_val, WeierstrassCurve.coe_Δ', mul_comm]
+
+section Generic
+
+variable {j₀ : Qbar} (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728)
+include h0 h1728
+
+theorem goodModel_generic : goodModel j₀ = ofJNe0Or1728 (jNear j₀) := by
+  rw [goodModel_eq_nearCurve h0 h1728, nearCurve_eq]
+
+theorem specialFibre_generic : specialFibre (goodModel j₀) = ofJNe0Or1728 j₀ := by
+  rw [goodModel_generic h0 h1728]
+  have hw := w_mem j₀
+  have hc := coeff_zero_w j₀
+  ext
+  · change (jNear j₀ - 1728).coeff 0 = j₀ - 1728
+    exact hc
+  · change (0 : H).coeff 0 = 0
+    simp
+  · change (0 : H).coeff 0 = 0
+    simp
+  · change (-36 * (jNear j₀ - 1728) ^ 3).coeff 0 = -36 * (j₀ - 1728) ^ 3
+    rw [neg_mul, HahnSeries.coeff_neg, coeff_zero_mul_mem (ofNat_mem 36) (Subring.pow_mem _ hw 3),
+      coeff_zero_pow_mem hw, hc, coeff_zero_ofNat, neg_mul]
+  · change (-(jNear j₀ - 1728) ^ 5).coeff 0 = -(j₀ - 1728) ^ 5
+    rw [HahnSeries.coeff_neg, coeff_zero_pow_mem hw, hc]
+
+theorem integralCoeffs_generic : IntegralCoeffs (goodModel j₀) := by
+  rw [goodModel_generic h0 h1728]
+  have hw := w_mem j₀
+  refine ⟨orderTop_nonneg_of_mem hw, by simp [ofJNe0Or1728], by simp [ofJNe0Or1728],
+    orderTop_nonneg_of_mem ?_, orderTop_nonneg_of_mem ?_⟩
+  · change -36 * (jNear j₀ - 1728) ^ 3 ∈ integralO
+    exact Subring.mul_mem _ (Subring.neg_mem _ (ofNat_mem 36)) (Subring.pow_mem _ hw 3)
+  · change -(jNear j₀ - 1728) ^ 5 ∈ integralO
+    exact Subring.neg_mem _ (Subring.pow_mem _ hw 5)
+
+theorem isGood_generic : IntegralCoeffs (goodModel j₀) ∧
+    ∃ h : (specialFibre (goodModel j₀)).IsElliptic,
+      @WeierstrassCurve.j Qbar _ (specialFibre (goodModel j₀)) h = j₀ := by
+  refine ⟨integralCoeffs_generic h0 h1728, ?_⟩
+  rw [specialFibre_generic h0 h1728]
+  have : Fact (IsUnit j₀) := ⟨isUnit_iff_ne_zero.mpr h0⟩
+  have : Fact (IsUnit (j₀ - 1728)) := ⟨isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr h1728)⟩
+  exact ⟨inferInstance, ofJNe0Or1728_j j₀⟩
+
+end Generic
+
+section J1728
+
+theorem jNear_1728_sub : jNear 1728 - 1728 = sMon := by
+  rw [jNear_sub, sub_self, map_zero, zero_add]
+
+theorem goodModel_1728_a₁ : (goodModel 1728).a₁ = HahnSeries.single (1 / 4 : ℚ) (1 : Qbar) := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₁]
+  simp only [ofJNe0Or1728, jNear_1728_sub, val_inv_sU, mul_zero, add_zero]
+  rw [HahnSeries.single_mul_single]; norm_num
+
+theorem goodModel_1728_a₂ : (goodModel 1728).a₂ = 0 := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₂]
+  simp [ofJNe0Or1728]
+
+theorem goodModel_1728_a₃ : (goodModel 1728).a₃ = 0 := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₃]
+  simp [ofJNe0Or1728]
+
+theorem goodModel_1728_a₄ : (goodModel 1728).a₄ = -36 := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₄]
+  simp only [ofJNe0Or1728, jNear_1728_sub, val_inv_sU, mul_zero, zero_mul, sub_zero, add_zero,
+    zero_pow (by norm_num : (2:ℕ) ≠ 0)]
+  rw [HahnSeries.single_pow, show (-36 : H) * sMon ^ 3 = sMon ^ 3 * (-36) from mul_comm _ _,
+    ← mul_assoc, HahnSeries.single_pow, HahnSeries.single_mul_single]
+  norm_num
+
+theorem goodModel_1728_a₆ : (goodModel 1728).a₆ = -HahnSeries.single (1 / 2 : ℚ) (1 : Qbar) := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₆]
+  simp only [ofJNe0Or1728, jNear_1728_sub, val_inv_sU, mul_zero, zero_mul, sub_zero, add_zero,
+    zero_pow (by norm_num : (2:ℕ) ≠ 0), zero_pow (by norm_num : (3:ℕ) ≠ 0)]
+  rw [mul_neg, HahnSeries.single_pow, HahnSeries.single_pow, HahnSeries.single_mul_single]
+  norm_num
+
+theorem specialFibre_1728 : specialFibre (goodModel 1728) = ⟨0, 0, 0, -36, 0⟩ := by
+  ext
+  · change (goodModel 1728).a₁.coeff 0 = 0
+    rw [goodModel_1728_a₁]; exact HahnSeries.coeff_single_of_ne (by norm_num)
+  · change (goodModel 1728).a₂.coeff 0 = 0
+    rw [goodModel_1728_a₂]; simp
+  · change (goodModel 1728).a₃.coeff 0 = 0
+    rw [goodModel_1728_a₃]; simp
+  · change (goodModel 1728).a₄.coeff 0 = -36
+    rw [goodModel_1728_a₄, show (-36 : H) = -(36 : H) from rfl, HahnSeries.coeff_neg,
+      coeff_zero_ofNat]
+  · change (goodModel 1728).a₆.coeff 0 = 0
+    rw [goodModel_1728_a₆, HahnSeries.coeff_neg, HahnSeries.coeff_single_of_ne (by
+      norm_num), neg_zero]
+
+theorem integralCoeffs_1728 : IntegralCoeffs (goodModel 1728) := by
+  refine ⟨?_, ?_, ?_, ?_, ?_⟩
+  · rw [goodModel_1728_a₁]; exact orderTop_nonneg_of_mem (single_mem (by norm_num) _)
+  · rw [goodModel_1728_a₂]; simp
+  · rw [goodModel_1728_a₃]; simp
+  · rw [goodModel_1728_a₄]; exact orderTop_nonneg_of_mem (Subring.neg_mem _ (ofNat_mem 36))
+  · rw [goodModel_1728_a₆]
+    exact orderTop_nonneg_of_mem (Subring.neg_mem _ (single_mem (by norm_num) _))
+
+theorem isGood_1728 : IntegralCoeffs (goodModel 1728) ∧
+    ∃ h : (specialFibre (goodModel 1728)).IsElliptic,
+      @WeierstrassCurve.j Qbar _ (specialFibre (goodModel 1728)) h = 1728 := by
+  refine ⟨integralCoeffs_1728, ?_⟩
+  rw [specialFibre_1728]
+  have hΔ : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).Δ ≠ 0 := by
+    rw [delta_j1728]; norm_num
+  have : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+  refine ⟨inferInstance, ?_⟩
+  rw [j_eq, c4_j1728, delta_j1728]
+  norm_num
+
+end J1728
+
+section J0
+
+abbrev mEl : H := jNear 0 - 1728
+
+theorem jNear_zero : jNear 0 = sMon := by rw [jNear, map_zero, zero_add]
+
+theorem mEl_add : mEl + 1728 = sMon := by rw [mEl, jNear_zero]; ring
+
+theorem mEl_mem : mEl ∈ integralO := w_mem 0
+
+theorem coeff_zero_mEl : mEl.coeff 0 = -1728 := by rw [mEl, coeff_zero_w, zero_sub]
+
+theorem uInv_pow_mul_sMon_four :
+    (HahnSeries.single (-(2 / 12) : ℚ) (1 : Qbar) : H) ^ 4 * sMon = HahnSeries.single (1 / 3 : ℚ) 1
+      := by
+  rw [HahnSeries.single_pow, HahnSeries.single_mul_single]; norm_num
+
+theorem uInv_pow_mul_sMon_six :
+    (HahnSeries.single (-(2 / 12) : ℚ) (1 : Qbar) : H) ^ 6 * sMon = 1 := by
+  rw [HahnSeries.single_pow, HahnSeries.single_mul_single]; norm_num
+
+theorem goodModel_0_a₁ : (goodModel 0).a₁ = 0 := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₁]
+  simp only [ofJNe0Or1728]
+  ring
+
+theorem goodModel_0_a₂ : (goodModel 0).a₂ = 0 := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₂]
+  simp only [ofJNe0Or1728]
+  ring
+
+theorem goodModel_0_a₃ : (goodModel 0).a₃ = 0 := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₃]
+  simp only [ofJNe0Or1728]
+  ring
+
+theorem goodModel_0_a₄ :
+    (goodModel 0).a₄ = HahnSeries.single (1 / 3 : ℚ) (1 : Qbar) * (-mEl ^ 3 / 48) := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₄]
+  simp only [ofJNe0Or1728, val_inv_sU]
+  have key : (-36 * (jNear 0 - 1728) ^ 3 - -(jNear 0 - 1728) / 2 * 0 +
+      2 * (-(jNear 0 - 1728) ^ 2 / 12) * 0 -
+      ((jNear 0 - 1728) ^ 3 / 24 + -(jNear 0 - 1728) ^ 2 / 12 * (-(jNear 0 - 1728) / 2)) *
+        (jNear 0 - 1728) +
+      3 * (-(jNear 0 - 1728) ^ 2 / 12) ^ 2 - 2 * (-(jNear 0 - 1728) / 2) * ((jNear 0 - 1728) ^ 3 /
+        24))
+      = sMon * (-mEl ^ 3 / 48) := by
+    rw [← mEl_add]; simp only [mEl]; ring
+  rw [key, ← mul_assoc, uInv_pow_mul_sMon_four]
+
+theorem goodModel_0_a₆ : (goodModel 0).a₆ = mEl ^ 5 / 864 := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₆]
+  simp only [ofJNe0Or1728, val_inv_sU]
+  have key : (-(jNear 0 - 1728) ^ 5 + -(jNear 0 - 1728) ^ 2 / 12 * (-36 * (jNear 0 - 1728) ^ 3) +
+      (-(jNear 0 - 1728) ^ 2 / 12) ^ 2 * 0 + (-(jNear 0 - 1728) ^ 2 / 12) ^ 3 -
+      (jNear 0 - 1728) ^ 3 / 24 * 0 - ((jNear 0 - 1728) ^ 3 / 24) ^ 2 -
+      -(jNear 0 - 1728) ^ 2 / 12 * ((jNear 0 - 1728) ^ 3 / 24) * (jNear 0 - 1728))
+      = sMon * (mEl ^ 5 / 864) := by
+    rw [← mEl_add]; simp only [mEl]; ring
+  rw [key, ← mul_assoc, uInv_pow_mul_sMon_six, one_mul]
+
+theorem a₄_0_mem : HahnSeries.single (1 / 3 : ℚ) (1 : Qbar) * (-mEl ^ 3 / 48) ∈ integralO := by
+  refine Subring.mul_mem _ (single_mem (by norm_num) _) ?_
+  rw [div_eq_mul_inv]
+  exact Subring.mul_mem _ (Subring.neg_mem _ (Subring.pow_mem _ mEl_mem 3)) (inv_ofNat_mem 48)
+
+theorem a₆_0_mem : mEl ^ 5 / 864 ∈ integralO := by
+  rw [div_eq_mul_inv]
+  exact Subring.mul_mem _ (Subring.pow_mem _ mEl_mem 5) (inv_ofNat_mem 864)
+
+theorem coeff_zero_a₆_0 : (mEl ^ 5 / 864).coeff 0 = (-1728) ^ 5 / 864 := by
+  rw [div_eq_mul_inv, coeff_zero_mul_mem (Subring.pow_mem _ mEl_mem 5) (inv_ofNat_mem 864),
+    coeff_zero_pow_mem mEl_mem, coeff_zero_mEl, ← C_ofNat, ← map_inv₀, coeff_zero_C, div_eq_mul_inv]
+
+theorem specialFibre_0 : specialFibre (goodModel 0) = ⟨0, 0, 0, 0, (-1728) ^ 5 / 864⟩ := by
+  ext
+  · change (goodModel 0).a₁.coeff 0 = 0
+    rw [goodModel_0_a₁]; simp
+  · change (goodModel 0).a₂.coeff 0 = 0
+    rw [goodModel_0_a₂]; simp
+  · change (goodModel 0).a₃.coeff 0 = 0
+    rw [goodModel_0_a₃]; simp
+  · change (goodModel 0).a₄.coeff 0 = 0
+    rw [goodModel_0_a₄, coeff_zero_mul_mem (single_mem (by norm_num) _)
+      (by simpa [div_eq_mul_inv] using
+        (Subring.mul_mem _ (Subring.neg_mem _ (Subring.pow_mem _ mEl_mem 3)) (inv_ofNat_mem 48))),
+      HahnSeries.coeff_single_of_ne (by norm_num), zero_mul]
+  · change (goodModel 0).a₆.coeff 0 = (-1728) ^ 5 / 864
+    rw [goodModel_0_a₆, coeff_zero_a₆_0]
+
+theorem integralCoeffs_0 : IntegralCoeffs (goodModel 0) := by
+  refine ⟨?_, ?_, ?_, ?_, ?_⟩
+  · rw [goodModel_0_a₁]; simp
+  · rw [goodModel_0_a₂]; simp
+  · rw [goodModel_0_a₃]; simp
+  · rw [goodModel_0_a₄]; exact orderTop_nonneg_of_mem a₄_0_mem
+  · rw [goodModel_0_a₆]; exact orderTop_nonneg_of_mem a₆_0_mem
+
+theorem isGood_0 : IntegralCoeffs (goodModel 0) ∧
+    ∃ h : (specialFibre (goodModel 0)).IsElliptic,
+      @WeierstrassCurve.j Qbar _ (specialFibre (goodModel 0)) h = 0 := by
+  refine ⟨integralCoeffs_0, ?_⟩
+  rw [specialFibre_0]
+  have ha : ((-1728 : Qbar) ^ 5 / 864) ≠ 0 := by norm_num
+  have hΔ : (⟨0, 0, 0, 0, (-1728 : Qbar) ^ 5 / 864⟩ : WeierstrassCurve Qbar).Δ ≠ 0 := by
+    rw [delta_j0]; exact mul_ne_zero (by norm_num) (pow_ne_zero _ ha)
+  have : (⟨0, 0, 0, 0, (-1728 : Qbar) ^ 5 / 864⟩ : WeierstrassCurve Qbar).IsElliptic :=
+    ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+  refine ⟨inferInstance, ?_⟩
+  rw [j_eq, c4_j0]
+  ring
+
+end J0
+
+end S12B3
+
+namespace S12B3
+
+theorem orderTop_C_add_sMon {a : Qbar} (ha : a ≠ 0) : (HahnSeries.C a + sMon : H).orderTop = 0 := by
+  have hC : (HahnSeries.C a : H).orderTop = 0 := by
+    rw [HahnSeries.C_apply, HahnSeries.orderTop_single ha]; rfl
+  have hs : (sMon : H).orderTop = 1 := by
+    rw [HahnSeries.orderTop_single one_ne_zero]; rfl
+  rw [HahnSeries.orderTop_add_eq_left (by rw [hC, hs]; exact zero_lt_one), hC]
+
+theorem orderTop_jNear {j₀ : Qbar} (h0 : j₀ ≠ 0) : (jNear j₀).orderTop = 0 := by
+  rw [jNear]; exact orderTop_C_add_sMon h0
+
+theorem orderTop_w' {j₀ : Qbar} (h : j₀ ≠ 1728) : (jNear j₀ - 1728).orderTop = 0 := by
+  rw [jNear_sub]; exact orderTop_C_add_sMon (sub_ne_zero.mpr h)
+
+theorem orderTop_pow_of_eq_zero {x : H} (hx : x.orderTop = 0) (n : ℕ) : (x ^ n).orderTop = 0 := by
+  induction n with
+  | zero => rw [pow_zero, HahnSeries.orderTop_one]
+  | succ n ih => rw [pow_succ, HahnSeries.orderTop_mul, ih, hx, add_zero]
+
+theorem delta_nearCurve (j₀ : Qbar) :
+    (nearCurve j₀).Δ = (jNear j₀) ^ 2 * (jNear j₀ - 1728) ^ 9 := by
+  rw [nearCurve_eq, WeierstrassCurve.ofJNe0Or1728_Δ]
+
+theorem orderTop_delta_nearCurve_generic {j₀ : Qbar} (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) :
+    (nearCurve j₀).Δ.orderTop = 0 := by
+  rw [delta_nearCurve, HahnSeries.orderTop_mul, orderTop_pow_of_eq_zero (orderTop_jNear h0),
+    orderTop_pow_of_eq_zero (orderTop_w' h1728), add_zero]
+
+theorem delta_goodModel_zero : (goodModel 0).Δ = mEl ^ 9 := by
+  rw [goodModel, WeierstrassCurve.variableChange_Δ, scaleVC_zero, delta_nearCurve, jNear_zero]
+  simp only [val_inv_sU]
+  rw [show (HahnSeries.single (-(2 / 12) : ℚ) (1 : Qbar) : H) ^ 12 * (sMon ^ 2 * (sMon - 1728) ^ 9)
+      = (HahnSeries.single (-(2 / 12) : ℚ) (1 : Qbar) ^ 12 * sMon ^ 2) * (sMon - 1728) ^ 9 by ring,
+    HahnSeries.single_pow, HahnSeries.single_pow, HahnSeries.single_mul_single]
+  norm_num
+  rw [mEl, jNear_zero]
+
+theorem orderTop_delta_goodModel_zero : (goodModel 0).Δ.orderTop = 0 := by
+  rw [delta_goodModel_zero]
+  exact orderTop_pow_of_eq_zero (by rw [mEl]; exact orderTop_w' (by norm_num)) 9
+
+theorem delta_goodModel_1728 : (goodModel 1728).Δ = (jNear 1728) ^ 2 := by
+  rw [goodModel, WeierstrassCurve.variableChange_Δ, scaleVC_1728, delta_nearCurve, jNear_1728_sub]
+  simp only [val_inv_sU]
+  rw [show (HahnSeries.single (-(9 / 12) : ℚ) (1 : Qbar) : H) ^ 12 * (jNear 1728 ^ 2 * sMon ^ 9)
+      = (HahnSeries.single (-(9 / 12) : ℚ) (1 : Qbar) ^ 12 * sMon ^ 9) * jNear 1728 ^ 2 by ring,
+    HahnSeries.single_pow, HahnSeries.single_pow, HahnSeries.single_mul_single]
+  norm_num
+
+theorem orderTop_delta_goodModel_1728 : (goodModel 1728).Δ.orderTop = 0 := by
+  rw [delta_goodModel_1728]
+  exact orderTop_pow_of_eq_zero (orderTop_jNear (by norm_num)) 2
+
+end S12B3
+end
+
+open ModularCurve.B3 ModularCurve.TatePoint WeierstrassCurve
+
+theorem solution :
+    IntegralCoeffs (goodModel 0) ∧ (goodModel 0).Δ.orderTop = 0 ∧
+      ∃ _ : (specialFibre (goodModel 0)).IsElliptic, (specialFibre (goodModel 0)).j = 0 := by
+  obtain ⟨hint, h, hj⟩ := S12B3.isGood_0
+  exact ⟨hint, S12B3.orderTop_delta_goodModel_zero, h, hj⟩
+
+end S_ModularCurve_B3_goodModel_zero_spec
+end P2MW
+export P2MW.S_ModularCurve_B3_goodModel_zero_spec (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.B3.goodModel_zero_spec :
+    IntegralCoeffs (goodModel 0) ∧ (goodModel 0).Δ.orderTop = 0 ∧
+      ∃ _ : (specialFibre (goodModel 0)).IsElliptic, (specialFibre (goodModel 0)).j = 0 :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_isElliptic_specialFibre.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_isElliptic_specialFibre.lean
new file mode 100644
index 0000000000..c9381223de
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_isElliptic_specialFibre.lean
@@ -0,0 +1,2900 @@
+/-
+Based on Prove2Me node ModularCurve.B3.isElliptic_specialFibre
+(626aca83-fa00-519e-b5e3-231786751ad9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 118aa8fb-0cdf-5606-91e3-3812a4c3f587
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_SpecialisationVocab
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_TatePoint
+
+import Mathlib.Algebra.Category.Grp.Injective
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EMD
+import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_Monodromy
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VariableChangePointEquiv
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_vcInvFun_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsionBy_eq_sq_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_isAlgClosed_rat
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_zsmul_some_eq_some_div
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_evalEval_psi_sq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a4_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a6_eq_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Unit discriminant gives an elliptic special fibre
+
+Theorem statement: `ModularCurve.B3.isElliptic_specialFibre`
+(`626aca83-fa00-519e-b5e3-231786751ad9`), by Claude, 2026-09-05.
+
+Proof: submission `118aa8fb-0cdf-5606-91e3-3812a4c3f587`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $H$ be the Hahn series field with coefficients in $\bar{\mathbb{Q}} =$ `Qbar` $=$
+`AlgebraicClosure ℚ`, and let $W$ be a Weierstrass curve over $H$, given by coefficients
+$a_1,a_2,a_3,a_4,a_6 \in H$. Assume first `IntegralCoeffs W`, that is, each of the five coefficients
+has $\mathrm{orderTop} \ge 0$, so no coefficient has a term of negative exponent; and assume second
+that the discriminant $\Delta$ of $W$ satisfies $\mathrm{orderTop}(\Delta) = 0$, i.e. $\Delta$ is
+nonzero, has no terms of negative exponent, and its constant term is nonzero. The conclusion is that
+`specialFibre W`, the Weierstrass curve over $\bar{\mathbb{Q}}$ whose coefficients are the constant
+terms $a_1(0), a_2(0), a_3(0), a_4(0), a_6(0)$ of those of $W$, satisfies `IsElliptic`: its
+discriminant is a unit of $\bar{\mathbb{Q}}$, equivalently nonzero, so the plane cubic it defines is
+nonsingular.
+
+This is the good-reduction criterion in its model-theoretic form: an integral Weierstrass model
+whose discriminant is a unit specialises to an elliptic curve over the residue field. It is the step
+that allows the special fibre to be treated as an elliptic curve, with a group of points and a
+torsion theory, in the specialisation vocabulary used for the Tate point construction.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_B3_isElliptic_specialFibre.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_B3_isElliptic_specialFibre
+
+open scoped Classical
+
+noncomputable section
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_B3_isElliptic_specialFibre.ModularCurve \
+  WeierstrassCurve Polynomial"
+
+namespace HahnSeries
+p2m_export "HahnSeries" "support coeff_sub orderTop orderTop_mul algebraMap_apply' ofPowerSeries_C \
+  C_apply coeff_sum leadingCoeff_ne_zero orderTop_one orderTop_single_le \
+  coeff_eq_zero_of_lt_orderTop single orderTop_zero le_orderTop_iff_forall order \
+  powerSeriesAlgebra min_orderTop_le_orderTop_add coeff ofPowerSeries_X orderTop_add_eq_left \
+  order_eq_orderTop_of_ne_zero single_pow single_zero_one coeff_zero pow_add single_zero_intCast \
+  orderTop_single C map coeff_neg embDomain_notin_range orderTop_ne_top order_pow \
+  coeff_single_same ofPowerSeries_apply_coeff single_ne_zero orderTop_neg single_zero_natCast \
+  ofPowerSeries rec coeff_order_eq_zero leadingCoeff coeff_add coeff_single_of_ne \
+  ofPowerSeries_apply orderTop_le_of_coeff_ne_zero coeff_single single_mul_single \
+  coeff_mul_order_add_order order_mul_of_ne_zero hahnTwist coeff_hahnTwist hahnTwist_single \
+  order_hahnTwist MonoChar mem_monoChar_iff hahnTwistHom hahnTwistHom_apply monodromy \
+  fixes_single_one_of_mem_monodromy isAlgClosed_rat"
+p2m_open "HahnSeries"
+
+namespace ExtChar
+
+variable (K : Type*) [Field K] [IsAlgClosed K]
+
+@[reducible] def divisibleByIntAdditiveUnits : DivisibleBy (Additive Kˣ) ℤ :=
+  divisibleByOfSMulRightSurj (Additive Kˣ) ℤ fun {n} hn a => by
+    obtain ⟨k, rfl | rfl⟩ := Int.eq_nat_or_neg n
+    · have hk : 0 < k := by omega
+      obtain ⟨y, hy⟩ := IsAlgClosed.exists_pow_nat_eq ((a.toMul : Kˣ) : K) hk
+      have hy0 : y ≠ 0 := fun h => (a.toMul).ne_zero (by rw [← hy, h, zero_pow hk.ne'])
+      refine ⟨Additive.ofMul (Units.mk0 y hy0), ?_⟩
+      apply Additive.toMul.injective
+      rw [toMul_zsmul, toMul_ofMul, zpow_natCast]
+      exact Units.ext (by rw [Units.val_pow_eq_pow_val, Units.val_mk0, hy])
+    · have hk : 0 < k := by omega
+      obtain ⟨y, hy⟩ := IsAlgClosed.exists_pow_nat_eq ((a.toMul⁻¹ : Kˣ) : K) hk
+      have hy0 : y ≠ 0 := fun h => (a.toMul⁻¹).ne_zero (by rw [← hy, h, zero_pow hk.ne'])
+      refine ⟨Additive.ofMul (Units.mk0 y hy0), ?_⟩
+      apply Additive.toMul.injective
+      rw [toMul_zsmul, toMul_ofMul, zpow_neg, zpow_natCast, ← inv_inv a.toMul]
+      exact congrArg (·⁻¹) (Units.ext (by rw [Units.val_pow_eq_pow_val, Units.val_mk0, hy]))
+
+theorem injective_additiveUnits : Module.Injective ℤ (Additive Kˣ) :=
+  letI := divisibleByIntAdditiveUnits K
+  (Module.Baer.of_divisible (Additive Kˣ)).injective
+
+variable {K}
+
+theorem exists_char_apply_eq (q : ℚ) (hq : q ≠ 0) (u : Kˣ) :
+    ∃ χ : Multiplicative ℚ →* Kˣ, χ (Multiplicative.ofAdd q) = u := by
+  let ε : ℤ ≃ₗ[ℤ] (ℤ ∙ q) := LinearEquiv.toSpanNonzeroSingleton ℤ ℚ q hq
+  let g : (ℤ ∙ q) →ₗ[ℤ] Additive Kˣ :=
+    (LinearMap.toSpanSingleton ℤ (Additive Kˣ) (Additive.ofMul u)).comp ε.symm.toLinearMap
+  have hgq : g ⟨q, Submodule.mem_span_singleton_self q⟩ = Additive.ofMul u := by
+    have h1 : ε.symm ⟨q, Submodule.mem_span_singleton_self q⟩ = 1 := by
+      rw [LinearEquiv.symm_apply_eq]
+      exact (LinearEquiv.toSpanNonzeroSingleton_one ℤ ℚ q hq).symm
+    simp only [g, LinearMap.comp_apply, LinearEquiv.coe_toLinearMap, h1,
+      LinearMap.toSpanSingleton_apply, one_smul]
+  let := divisibleByIntAdditiveUnits K
+  obtain ⟨h, hh⟩ := (Module.Baer.of_divisible (Additive Kˣ)).extension_property (ℤ ∙ q).subtype
+    (Submodule.subtype_injective _) g
+  refine ⟨{ toFun := fun a => (h a.toAdd).toMul
+            map_one' := by rw [toAdd_one, map_zero, toMul_zero]
+            map_mul' := fun a b => by rw [toAdd_mul, map_add, toMul_add] }, ?_⟩
+  change (h (Multiplicative.ofAdd q).toAdd).toMul = u
+  rw [toAdd_ofAdd]
+  have := LinearMap.congr_fun hh ⟨q, Submodule.mem_span_singleton_self q⟩
+  rw [LinearMap.comp_apply, Submodule.subtype_apply] at this
+  rw [this, hgq, toMul_ofMul]
+
+end ExtChar
+
+private theorem exists_mem_monodromy_single_eq (K : Type*) [Field K] [IsAlgClosed K] (e : ℕ)
+    (he : 0 < e)
+    (ζ : K) (hζ : ζ ^ e = 1) :
+    ∃ m ∈ monodromy K,
+      (m : HahnSeries ℚ K ≃ₐ[K] HahnSeries ℚ K) (single ((e : ℚ)⁻¹) (1 : K)) =
+        single ((e : ℚ)⁻¹) ζ := by
+  have hζ0 : ζ ≠ 0 := by
+    rintro rfl
+    rw [zero_pow he.ne'] at hζ
+    exact zero_ne_one hζ
+  have hq : ((e : ℚ)⁻¹) ≠ 0 := inv_ne_zero (by exact_mod_cast he.ne')
+  obtain ⟨χ, hχ⟩ := ExtChar.exists_char_apply_eq ((e : ℚ)⁻¹) hq (Units.mk0 ζ hζ0)
+  have hone : Multiplicative.ofAdd (1 : ℚ) = Multiplicative.ofAdd ((e : ℚ)⁻¹) ^ e := by
+    rw [← ofAdd_nsmul, nsmul_eq_mul, mul_inv_cancel₀ (by exact_mod_cast he.ne' : (e : ℚ) ≠ 0)]
+  have hmem : χ ∈ MonoChar K := by
+    rw [mem_monoChar_iff, hone, map_pow, hχ]
+    exact Units.ext (by rw [Units.val_pow_eq_pow_val, Units.val_mk0, hζ, Units.val_one])
+  refine ⟨hahnTwistHom χ, Subgroup.mem_map_of_mem _ hmem, ?_⟩
+  rw [hahnTwistHom_apply, hahnTwist_single, hχ, Units.val_mk0, mul_one]
+
+end HahnSeries
+
+namespace ModularCurve
+p2m_export "ModularCurve" "CycSub SameOrbit"
+namespace B3
+p2m_export "ModularCurve.B3" "coeff_zero_mul_of_integral orderTop_pow_nonneg integralO \
+  mem_integralO resO resO_apply IntegralCoeffs specialFibre val_inv_sU scaleVC goodModel \
+  scaleVC_zero scaleVC_1728 scaleVC_of_ne goodModel_eq_nearCurve"
+p2m_open "ModularCurve.B3 ModularCurve"
+
+open ModularCurve.TatePoint
+
+private theorem orderTop_nonneg_of_isRoot (P : Polynomial H)
+    (hP : ∀ i, 0 ≤ (P.coeff i).orderTop) (hlead : P.leadingCoeff.orderTop = 0)
+    {x : H} (hx : P.IsRoot x) : 0 ≤ x.orderTop := by
+  by_contra hneg
+  rw [not_le] at hneg
+  have hx0 : x ≠ 0 := by
+    rintro rfl
+    rw [HahnSeries.orderTop_zero] at hneg
+    exact not_top_lt hneg
+  have hxneg : x.order < 0 := by
+    rw [← HahnSeries.order_eq_orderTop_of_ne_zero hx0] at hneg
+    exact_mod_cast hneg
+  have hl0 : P.leadingCoeff ≠ 0 := by
+    intro h
+    rw [h, HahnSeries.orderTop_zero] at hlead
+    exact ne_of_gt (WithTop.coe_lt_top (0 : ℚ)) hlead
+  have hP0 : P ≠ 0 := Polynomial.leadingCoeff_ne_zero.mp hl0
+  have han : P.coeff P.natDegree ≠ 0 := by
+    rw [Polynomial.coeff_natDegree]; exact hl0
+  have hxn : (x ^ P.natDegree : H) ≠ 0 := pow_ne_zero _ hx0
+  have hordan : (P.coeff P.natDegree).order = 0 := by
+    have h : ((P.coeff P.natDegree).order : WithTop ℚ) = 0 := by
+      rw [HahnSeries.order_eq_orderTop_of_ne_zero han, Polynomial.coeff_natDegree, hlead]
+    exact_mod_cast h
+  have hordxn : (x ^ P.natDegree : H).order = P.natDegree • x.order :=
+    HahnSeries.order_pow x P.natDegree
+  have hleadterm :
+      (P.coeff P.natDegree * x ^ P.natDegree : H).coeff (P.natDegree • x.order) ≠ 0 := by
+    have key := HahnSeries.coeff_mul_order_add_order (P.coeff P.natDegree) (x ^ P.natDegree)
+    rw [hordan, hordxn, zero_add] at key
+    rw [key]
+    exact mul_ne_zero (HahnSeries.leadingCoeff_ne_zero.mpr han)
+      (HahnSeries.leadingCoeff_ne_zero.mpr hxn)
+  have hlower : ∀ i ∈ Finset.range (P.natDegree + 1), i ≠ P.natDegree →
+      (P.coeff i * x ^ i : H).coeff (P.natDegree • x.order) = 0 := by
+    intro i hi hin
+    have hilt : i < P.natDegree := lt_of_le_of_ne (Finset.mem_range_succ_iff.mp hi) hin
+    rcases eq_or_ne (P.coeff i) 0 with h0 | h0
+    · simp [h0]
+    · apply HahnSeries.coeff_eq_zero_of_lt_orderTop
+      have hxi : (x ^ i : H) ≠ 0 := pow_ne_zero _ hx0
+      have hq : P.natDegree • x.order < i • x.order := by
+        rw [nsmul_eq_mul, nsmul_eq_mul]
+        exact mul_lt_mul_of_neg_right (by exact_mod_cast hilt) hxneg
+      have h2 : ((i • x.order : ℚ) : WithTop ℚ) ≤ (P.coeff i * x ^ i : H).orderTop := by
+        rw [HahnSeries.orderTop_mul]
+        calc ((i • x.order : ℚ) : WithTop ℚ)
+            = 0 + ((i • x.order : ℚ) : WithTop ℚ) := (zero_add _).symm
+          _ ≤ (P.coeff i).orderTop + (x ^ i : H).orderTop := by
+              refine add_le_add (hP i) ?_
+              rw [← HahnSeries.order_eq_orderTop_of_ne_zero hxi, HahnSeries.order_pow]
+      exact lt_of_lt_of_le (WithTop.coe_lt_coe.mpr hq) h2
+  have heval : (P.eval x).coeff (P.natDegree • x.order) ≠ 0 := by
+    rw [Polynomial.eval_eq_sum_range, HahnSeries.coeff_sum,
+      Finset.sum_eq_single_of_mem P.natDegree (Finset.self_mem_range_succ P.natDegree) hlower]
+    exact hleadterm
+  rw [show P.eval x = 0 from hx] at heval
+  simp only [HahnSeries.coeff_zero] at heval
+  exact heval rfl
+
+scoped instance instCharZeroH : CharZero H :=
+  charZero_of_injective_algebraMap (algebraMap Qbar H).injective
+
+local notation "ι" => (HahnSeries.ofPowerSeries ℚ Qbar)
+
+theorem coeff_zero_ofPowerSeries (f : PowerSeries Qbar) :
+    (ι f).coeff 0 = PowerSeries.constantCoeff f := by
+  have h := HahnSeries.ofPowerSeries_apply_coeff (Γ := ℚ) f 0
+  rw [Nat.cast_zero] at h
+  rw [h, PowerSeries.coeff_zero_eq_constantCoeff_apply]
+
+theorem coeff_ofPowerSeries_of_neg (f : PowerSeries Qbar) {q : ℚ} (hq : q < 0) :
+    (ι f).coeff q = 0 := by
+  rw [HahnSeries.ofPowerSeries_apply, HahnSeries.embDomain_of_notMem_range]
+  rintro ⟨n, hn⟩
+  exact (not_le.mpr hq) (le_of_le_of_eq (Nat.cast_nonneg n) hn)
+
+theorem orderTop_ofPowerSeries_nonneg (f : PowerSeries Qbar) : 0 ≤ (ι f).orderTop :=
+  HahnSeries.le_orderTop_iff_forall.mpr fun _ hq =>
+    coeff_ofPowerSeries_of_neg f (WithTop.coe_lt_zero.mp hq)
+
+theorem orderTop_single_mul_ofPowerSeries (q : ℚ) (f : PowerSeries Qbar) :
+    (q : WithTop ℚ) ≤ (HahnSeries.single q (1 : Qbar) * ι f).orderTop := by
+  rw [HahnSeries.orderTop_mul, HahnSeries.orderTop_single one_ne_zero]
+  exact le_add_of_nonneg_right (orderTop_ofPowerSeries_nonneg f)
+
+theorem coeff_zero_single_mul_ofPowerSeries {q : ℚ} (hq : 0 < q) (f : PowerSeries Qbar) :
+    (HahnSeries.single q (1 : Qbar) * ι f).coeff 0 = 0 :=
+  HahnSeries.coeff_eq_zero_of_lt_orderTop
+    (lt_of_lt_of_le (WithTop.coe_pos.mpr hq) (orderTop_single_mul_ofPowerSeries q f))
+
+theorem map_ofJNe0Or1728 {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S) (j : R) :
+    (WeierstrassCurve.ofJNe0Or1728 j).map f = WeierstrassCurve.ofJNe0Or1728 (f j) := by
+  simp only [WeierstrassCurve.ofJNe0Or1728, WeierstrassCurve.map, map_sub, map_ofNat, map_zero,
+    map_mul, map_neg, map_pow]
+
+theorem specialFibre_map_ofPowerSeries (W : WeierstrassCurve (PowerSeries Qbar)) :
+    specialFibre (W.map ι) = W.map PowerSeries.constantCoeff := by
+  simp only [specialFibre, WeierstrassCurve.map, coeff_zero_ofPowerSeries]
+
+theorem integralCoeffs_map_ofPowerSeries (W : WeierstrassCurve (PowerSeries Qbar)) :
+    IntegralCoeffs (W.map ι) := by
+  unfold IntegralCoeffs
+  exact ⟨orderTop_ofPowerSeries_nonneg _, orderTop_ofPowerSeries_nonneg _,
+    orderTop_ofPowerSeries_nonneg _, orderTop_ofPowerSeries_nonneg _,
+    orderTop_ofPowerSeries_nonneg _⟩
+
+theorem orderTop_pow_eq_nsmul (x : H) (n : ℕ) : (x ^ n).orderTop = n • x.orderTop := by
+  induction n with
+  | zero => rw [pow_zero, HahnSeries.orderTop_one, zero_nsmul]
+  | succ n ih => rw [pow_succ, HahnSeries.orderTop_mul, ih, succ_nsmul]
+
+theorem coeff_one_jNear (j₀ : Qbar) : (jNear j₀).coeff 1 = 1 := by
+  simp [jNear]
+
+private theorem jNear_ne_zero (j₀ : Qbar) : jNear j₀ ≠ 0 := fun h => by
+  simpa [h] using coeff_one_jNear j₀
+
+private theorem jNear_ne_1728 (j₀ : Qbar) : jNear j₀ ≠ 1728 := fun h => by
+  have h1 := coeff_one_jNear j₀
+  have h2 : (1728 : H) = HahnSeries.C (1728 : Qbar) := (map_ofNat _ _).symm
+  rw [h, h2, HahnSeries.C_apply, HahnSeries.coeff_single_of_ne one_ne_zero] at h1
+  exact zero_ne_one h1
+
+private theorem nearCurve_eq_ofJNe0Or1728 (j₀ : Qbar) :
+    nearCurve j₀ = WeierstrassCurve.ofJNe0Or1728 (jNear j₀) :=
+  WeierstrassCurve.ofJ_ne_0_ne_1728 (jNear j₀) (jNear_ne_zero j₀) (jNear_ne_1728 j₀)
+
+theorem jNear_zero : jNear 0 = HahnSeries.single 1 1 := by
+  simp only [jNear, map_zero, zero_add]
+
+theorem jNear_sub_ofNat (j₀ : Qbar) : jNear j₀ - 1728 = jNear (j₀ - 1728) := by
+  simp only [jNear, map_sub, map_ofNat]; ring
+
+theorem orderTop_jNear_of_ne {j₀ : Qbar} (h : j₀ ≠ 0) : (jNear j₀).orderTop = 0 := by
+  have h1 : (HahnSeries.C j₀ : H).orderTop = (0 : ℚ) := by
+    rw [HahnSeries.C_apply, HahnSeries.orderTop_single h]
+  have h2 : (HahnSeries.single (1 : ℚ) (1 : Qbar)).orderTop = (1 : ℚ) :=
+    HahnSeries.orderTop_single one_ne_zero
+  rw [jNear, HahnSeries.orderTop_add_eq_left
+      (by rw [h1, h2]; exact WithTop.coe_lt_coe.mpr zero_lt_one), h1, WithTop.coe_zero]
+
+theorem orderTop_jNear_zero : (jNear 0).orderTop = (1 : ℚ) := by
+  rw [jNear_zero, HahnSeries.orderTop_single one_ne_zero]
+
+theorem nearCurve_eq_map (j₀ : Qbar) :
+    nearCurve j₀ =
+      (WeierstrassCurve.ofJNe0Or1728 (PowerSeries.C j₀ + PowerSeries.X)).map ι := by
+  rw [map_ofJNe0Or1728, map_add, HahnSeries.ofPowerSeries_C, HahnSeries.ofPowerSeries_X,
+    nearCurve_eq_ofJNe0Or1728, jNear]
+
+theorem integralCoeffs_nearCurve (j₀ : Qbar) : IntegralCoeffs (nearCurve j₀) := by
+  rw [nearCurve_eq_map]; exact integralCoeffs_map_ofPowerSeries _
+
+theorem specialFibre_nearCurve (j₀ : Qbar) :
+    specialFibre (nearCurve j₀) = WeierstrassCurve.ofJNe0Or1728 j₀ := by
+  rw [nearCurve_eq_map, specialFibre_map_ofPowerSeries, map_ofJNe0Or1728, map_add,
+    PowerSeries.constantCoeff_C, PowerSeries.constantCoeff_X, add_zero]
+
+theorem nearCurve_Δ (j₀ : Qbar) :
+    (nearCurve j₀).Δ = jNear j₀ ^ 2 * jNear (j₀ - 1728) ^ 9 := by
+  rw [nearCurve_eq_ofJNe0Or1728, WeierstrassCurve.ofJNe0Or1728_Δ, jNear_sub_ofNat]
+
+private theorem nearCurve_delta_orderTop_generic (j₀ : Qbar) (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) :
+    (nearCurve j₀).Δ.orderTop = 0 := by
+  rw [nearCurve_Δ, HahnSeries.orderTop_mul, orderTop_pow_eq_nsmul, orderTop_pow_eq_nsmul,
+    orderTop_jNear_of_ne h0, orderTop_jNear_of_ne (sub_ne_zero.mpr h1728), nsmul_zero,
+    nsmul_zero, add_zero]
+
+private theorem nearCurve_delta_orderTop_zero : (nearCurve 0).Δ.orderTop = (2 : ℚ) := by
+  rw [nearCurve_Δ, HahnSeries.orderTop_mul, orderTop_pow_eq_nsmul, orderTop_pow_eq_nsmul,
+    orderTop_jNear_zero, zero_sub,
+    orderTop_jNear_of_ne (neg_ne_zero.mpr (by norm_num : (1728 : Qbar) ≠ 0)), nsmul_zero,
+    add_zero, ← WithTop.coe_nsmul]
+  norm_num
+
+private theorem nearCurve_delta_orderTop_1728 : (nearCurve 1728).Δ.orderTop = (9 : ℚ) := by
+  rw [nearCurve_Δ, HahnSeries.orderTop_mul, orderTop_pow_eq_nsmul, orderTop_pow_eq_nsmul,
+    orderTop_jNear_of_ne (by norm_num : (1728 : Qbar) ≠ 0), sub_self, orderTop_jNear_zero,
+    nsmul_zero, zero_add, ← WithTop.coe_nsmul]
+  norm_num
+
+theorem specialFibre_nearCurve_generic (j₀ : Qbar) (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) :
+    specialFibre (nearCurve j₀) = WeierstrassCurve.ofJ j₀ := by
+  rw [specialFibre_nearCurve, WeierstrassCurve.ofJ_ne_0_ne_1728 j₀ h0 h1728]
+
+theorem goodModel_1728_eq : goodModel 1728 =
+    ⟨HahnSeries.single (1 / 4 : ℚ) 1, 0, 0, HahnSeries.C (-36),
+      -HahnSeries.single (1 / 2 : ℚ) 1⟩ := by
+  have hA : jNear 1728 - 1728 = HahnSeries.single 1 1 := by
+    rw [jNear_sub_ofNat, sub_self, jNear_zero]
+  have h1 : HahnSeries.single (-(9 / 12 : ℚ)) (1 : Qbar) * HahnSeries.single 1 1 =
+      HahnSeries.single (1 / 4 : ℚ) 1 := by
+    rw [HahnSeries.single_mul_single, mul_one]; congr 1; norm_num
+  have h4 : HahnSeries.single (-(9 / 12 : ℚ)) (1 : Qbar) ^ 4 * HahnSeries.single 1 1 ^ 3 = 1 := by
+    rw [HahnSeries.single_pow, HahnSeries.single_pow, HahnSeries.single_mul_single,
+      ← HahnSeries.single_zero_one]
+    congr 1 <;> norm_num
+  have h6 : HahnSeries.single (-(9 / 12 : ℚ)) (1 : Qbar) ^ 6 * HahnSeries.single 1 1 ^ 5 =
+      HahnSeries.single (1 / 2 : ℚ) 1 := by
+    rw [HahnSeries.single_pow, HahnSeries.single_pow, HahnSeries.single_mul_single]
+    congr 1 <;> norm_num
+  rw [goodModel, scaleVC_1728, nearCurve_eq_ofJNe0Or1728, variableChange_def]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU]
+    linear_combination h1
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU]
+    ring
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU]
+    ring
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU, map_neg, map_ofNat]
+    linear_combination (-36 : H) * h4
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU]
+    linear_combination (-1 : H) * h6
+
+theorem goodModel_zero_eq : goodModel 0 =
+    ⟨0, 0, 0,
+      HahnSeries.single (1 / 3 : ℚ) 1 *
+        ι (PowerSeries.C (-1 / 48 : Qbar) * (PowerSeries.X - PowerSeries.C 1728) ^ 3),
+      ι (PowerSeries.C (1 / 864 : Qbar) * (PowerSeries.X - PowerSeries.C 1728) ^ 5)⟩ := by
+  have hA : jNear 0 - 1728 = HahnSeries.single 1 1 - 1728 := by rw [jNear_zero]
+  have h4 : HahnSeries.single (-(2 / 12 : ℚ)) (1 : Qbar) ^ 4 * HahnSeries.single 1 1 =
+      HahnSeries.single (1 / 3 : ℚ) 1 := by
+    rw [HahnSeries.single_pow, HahnSeries.single_mul_single]; congr 1 <;> norm_num
+  have h6 : HahnSeries.single (-(2 / 12 : ℚ)) (1 : Qbar) ^ 6 * HahnSeries.single 1 1 = 1 := by
+    rw [HahnSeries.single_pow, HahnSeries.single_mul_single, ← HahnSeries.single_zero_one]
+    congr 1 <;> norm_num
+  rw [goodModel, scaleVC_zero, nearCurve_eq_ofJNe0Or1728, variableChange_def]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU]
+    ring
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU]
+    ring
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU]
+    ring
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU, map_mul, map_pow, map_sub, map_neg,
+      map_div₀, map_one, map_ofNat, HahnSeries.ofPowerSeries_C, HahnSeries.ofPowerSeries_X]
+    linear_combination (-1 / 48 : H) * (HahnSeries.single (1 : ℚ) (1 : Qbar) - 1728) ^ 3 * h4
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU, map_mul, map_pow, map_sub,
+      map_div₀, map_one, map_ofNat, HahnSeries.ofPowerSeries_C, HahnSeries.ofPowerSeries_X]
+    linear_combination (1 / 864 : H) * (HahnSeries.single (1 : ℚ) (1 : Qbar) - 1728) ^ 5 * h6
+
+theorem specialFibre_goodModel_1728 : specialFibre (goodModel 1728) = ⟨0, 0, 0, -36, 0⟩ := by
+  rw [goodModel_1728_eq]
+  simp only [specialFibre, HahnSeries.coeff_zero, HahnSeries.coeff_neg, HahnSeries.C_apply,
+    HahnSeries.coeff_single]
+  norm_num
+
+theorem specialFibre_goodModel_zero :
+    specialFibre (goodModel 0) = ⟨0, 0, 0, 0, -(2 * 1728 ^ 4)⟩ := by
+  rw [goodModel_zero_eq]
+  simp only [specialFibre, HahnSeries.coeff_zero, coeff_zero_ofPowerSeries,
+    coeff_zero_single_mul_ofPowerSeries (by norm_num : (0 : ℚ) < 1 / 3)]
+  simp only [map_mul, map_pow, map_sub, PowerSeries.constantCoeff_C, PowerSeries.constantCoeff_X]
+  norm_num
+
+private theorem goodModel_zero_spec :
+    IntegralCoeffs (goodModel 0) ∧ (goodModel 0).Δ.orderTop = 0 ∧
+      ∃ _ : (specialFibre (goodModel 0)).IsElliptic, (specialFibre (goodModel 0)).j = 0 := by
+  refine ⟨?_, ?_, ?_⟩
+  · rw [goodModel_zero_eq]
+    unfold IntegralCoeffs
+    refine ⟨by simp, by simp, by simp, ?_, orderTop_ofPowerSeries_nonneg _⟩
+    exact le_trans (WithTop.coe_nonneg.mpr (by norm_num)) (orderTop_single_mul_ofPowerSeries _ _)
+  · rw [goodModel, scaleVC_zero, variableChange_Δ, HahnSeries.orderTop_mul,
+      nearCurve_delta_orderTop_zero]
+    simp only [val_inv_sU, HahnSeries.single_pow, one_pow]
+    rw [HahnSeries.orderTop_single one_ne_zero, ← WithTop.coe_add, WithTop.coe_eq_zero]
+    norm_num
+  · rw [specialFibre_goodModel_zero]
+    have hE : (⟨0, 0, 0, 0, -(2 * 1728 ^ 4)⟩ : WeierstrassCurve Qbar).IsElliptic := by
+      rw [WeierstrassCurve.isElliptic_iff, isUnit_iff_ne_zero]
+      simp only [WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄,
+        WeierstrassCurve.b₆, WeierstrassCurve.b₈]
+      norm_num
+    refine ⟨hE, WeierstrassCurve.j_eq_zero _ ?_⟩
+    simp only [WeierstrassCurve.c₄, WeierstrassCurve.b₂, WeierstrassCurve.b₄]
+    norm_num
+
+private theorem goodModel_1728_spec :
+    IntegralCoeffs (goodModel 1728) ∧ (goodModel 1728).Δ.orderTop = 0 ∧
+      ∃ _ : (specialFibre (goodModel 1728)).IsElliptic,
+        (specialFibre (goodModel 1728)).j = 1728 := by
+  refine ⟨?_, ?_, ?_⟩
+  · rw [goodModel_1728_eq]
+    unfold IntegralCoeffs
+    refine ⟨le_trans (WithTop.coe_nonneg.mpr (by norm_num)) HahnSeries.orderTop_single_le,
+      by simp, by simp, ?_, ?_⟩
+    · rw [HahnSeries.C_apply]; exact HahnSeries.orderTop_single_le
+    · rw [HahnSeries.orderTop_neg]
+      exact le_trans (WithTop.coe_nonneg.mpr (by norm_num)) HahnSeries.orderTop_single_le
+  · rw [goodModel, scaleVC_1728, variableChange_Δ, HahnSeries.orderTop_mul,
+      nearCurve_delta_orderTop_1728]
+    simp only [val_inv_sU, HahnSeries.single_pow, one_pow]
+    rw [HahnSeries.orderTop_single one_ne_zero, ← WithTop.coe_add, WithTop.coe_eq_zero]
+    norm_num
+  · rw [specialFibre_goodModel_1728]
+    have hE : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).IsElliptic := by
+      rw [WeierstrassCurve.isElliptic_iff, isUnit_iff_ne_zero]
+      simp only [WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄,
+        WeierstrassCurve.b₆, WeierstrassCurve.b₈]
+      norm_num
+    refine ⟨hE, ?_⟩
+    rw [WeierstrassCurve.j, Units.inv_mul_eq_iff_eq_mul, WeierstrassCurve.coe_Δ']
+    simp only [WeierstrassCurve.c₄, WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄,
+      WeierstrassCurve.b₆, WeierstrassCurve.b₈]
+    norm_num
+
+private theorem goodModel_generic_spec (j₀ : Qbar) (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) :
+    IntegralCoeffs (goodModel j₀) ∧ (goodModel j₀).Δ.orderTop = 0 ∧
+      specialFibre (goodModel j₀) = WeierstrassCurve.ofJ j₀ := by
+  rw [goodModel_eq_nearCurve h0 h1728]
+  exact ⟨integralCoeffs_nearCurve j₀, nearCurve_delta_orderTop_generic j₀ h0 h1728,
+    specialFibre_nearCurve_generic j₀ h0 h1728⟩
+
+open WeierstrassCurve in
+theorem eval_ΨSq_eq_zero_of_nsmul_some_eq_zero {F : Type*} [Field F] [DecidableEq F]
+    (W : WeierstrassCurve F) {x y : F} (h : W.toAffine.Nonsingular x y)
+    {d : ℕ} (htor : d • (Affine.Point.some x y h : W.toAffine.Point) = 0) :
+    (W.ΨSq d).eval x = 0 := by
+  by_contra hne
+  have hψ : (W.ψ (d : ℤ)).evalEval x y ≠ 0 := fun h0 => hne <| by
+    rw [← WeierstrassCurve.Affine.evalEval_psi_sq W h.1 (d : ℤ), h0, zero_pow two_ne_zero]
+  obtain ⟨y', h', heq⟩ := WeierstrassCurve.Affine.Point.zsmul_some_eq_some_div W h hψ
+  rw [natCast_zsmul, htor] at heq
+  exact (WeierstrassCurve.Affine.Point.some_ne_zero h') heq.symm
+
+open WeierstrassCurve in
+theorem eval_preΨ'_eq_zero_or_eval_Ψ₂Sq_eq_zero_of_nsmul_some_eq_zero
+    {F : Type*} [Field F] [DecidableEq F]
+    (W : WeierstrassCurve F) {x y : F} (h : W.toAffine.Nonsingular x y)
+    {d : ℕ} (htor : d • (Affine.Point.some x y h : W.toAffine.Point) = 0) :
+    (W.preΨ' d).eval x = 0 ∨ W.Ψ₂Sq.eval x = 0 := by
+  have := eval_ΨSq_eq_zero_of_nsmul_some_eq_zero W h htor
+  rw [WeierstrassCurve.ΨSq_ofNat, Polynomial.eval_mul, Polynomial.eval_pow,
+    mul_eq_zero, pow_eq_zero_iff two_ne_zero] at this
+  refine this.imp_right (fun h => ?_)
+  split_ifs at h with heven
+  · simpa using h
+  · simp at h
+
+theorem orderTop_intCast {n : ℤ} (hn : n ≠ 0) : (n : H).orderTop = 0 := by
+  rw [← HahnSeries.single_zero_intCast]
+  exact HahnSeries.orderTop_single (Int.cast_ne_zero.mpr hn)
+
+theorem orderTop_leadingCoeff_ΨSq_eq_zero (W : WeierstrassCurve H) {n : ℤ} (hn : (n : H) ≠ 0) :
+    (W.ΨSq n).leadingCoeff.orderTop = 0 := by
+  have hn' : n ≠ 0 := fun h0 => hn (by rw [h0]; exact Int.cast_zero)
+  rw [W.leadingCoeff_ΨSq hn, sq, HahnSeries.orderTop_mul, orderTop_intCast hn', add_zero]
+
+def liftToIntegralO (W : WeierstrassCurve H) (hW : IntegralCoeffs W) :
+    WeierstrassCurve integralO :=
+  ⟨⟨W.a₁, mem_integralO.mpr hW.1⟩,
+   ⟨W.a₂, mem_integralO.mpr hW.2.1⟩,
+   ⟨W.a₃, mem_integralO.mpr hW.2.2.1⟩,
+   ⟨W.a₄, mem_integralO.mpr hW.2.2.2.1⟩,
+   ⟨W.a₆, mem_integralO.mpr hW.2.2.2.2⟩⟩
+
+theorem map_liftToIntegralO (W : WeierstrassCurve H) (hW : IntegralCoeffs W) :
+    (liftToIntegralO W hW).map integralO.subtype = W := by
+  rfl
+
+theorem map_liftToIntegralO_resO (W : WeierstrassCurve H) (hW : IntegralCoeffs W) :
+    (liftToIntegralO W hW).map resO = specialFibre W := by
+  rfl
+
+theorem orderTop_coeff_ΨSq_nonneg (W : WeierstrassCurve H) (hW : IntegralCoeffs W) (n : ℤ)
+    (k : ℕ) : 0 ≤ ((W.ΨSq n).coeff k).orderTop := by
+  rw [← map_liftToIntegralO W hW, WeierstrassCurve.map_ΨSq, Polynomial.coeff_map]
+  exact mem_integralO.mp (((liftToIntegralO W hW).ΨSq n).coeff k).property
+
+theorem natCast_H_ne_zero {n : ℕ} (hn : n ≠ 0) : (n : H) ≠ 0 := by
+  rw [← HahnSeries.single_zero_natCast]
+  exact HahnSeries.single_ne_zero (Nat.cast_ne_zero.mpr hn)
+
+private theorem torsion_coords_integral (W : WeierstrassCurve H) [W.IsElliptic]
+    (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0) {x y : H}
+    (h : W.toAffine.Nonsingular x y) {n : ℕ} (hn : n ≠ 0)
+    (htor : n • (WeierstrassCurve.Affine.Point.some x y h : W.toAffine.Point) = 0) :
+    0 ≤ x.orderTop ∧ 0 ≤ y.orderTop := by
+  have _ := hΔ
+  have hnH : ((n : ℤ) : H) ≠ 0 := by exact_mod_cast natCast_H_ne_zero hn
+  have hroot_x : (W.ΨSq (n : ℤ)).IsRoot x := by
+    rw [Polynomial.IsRoot]
+    exact_mod_cast eval_ΨSq_eq_zero_of_nsmul_some_eq_zero W h htor
+  have hx : 0 ≤ x.orderTop :=
+    orderTop_nonneg_of_isRoot (W.ΨSq (n : ℤ))
+      (orderTop_coeff_ΨSq_nonneg W hW (n : ℤ))
+      (orderTop_leadingCoeff_ΨSq_eq_zero W hnH)
+      hroot_x
+  refine ⟨hx, ?_⟩
+  let Q : Polynomial H := W.toAffine.polynomial.map (Polynomial.evalRingHom x)
+  have hQmonic : Q.Monic := W.toAffine.monic_polynomial.map _
+  have hQroot : Q.IsRoot y := by
+    rw [show Q.IsRoot y ↔ Q.eval y = 0 from Iff.rfl, Polynomial.map_evalRingHom_eval]
+    exact h.1
+  have hQlead : Q.leadingCoeff.orderTop = 0 := by
+    rw [hQmonic.leadingCoeff]; exact HahnSeries.orderTop_one
+  have hQcoeff : ∀ i, 0 ≤ (Q.coeff i).orderTop := by
+    intro i
+    let x' : integralO := ⟨x, mem_integralO.mpr hx⟩
+    have hx'val : integralO.subtype x' = x := rfl
+    have key : Q.coeff i =
+        integralO.subtype
+          (((liftToIntegralO W hW).toAffine.polynomial.map (Polynomial.evalRingHom x')).coeff i)
+            := by
+      simp only [Q, Polynomial.coeff_map, Polynomial.coe_evalRingHom]
+      rw [← Polynomial.eval₂_hom (f := integralO.subtype), ← Polynomial.eval_map]
+      congr 1
+      rw [← Polynomial.coe_mapRingHom, ← Polynomial.coeff_map,
+        ← WeierstrassCurve.Affine.map_polynomial]
+      rfl
+    rw [key]
+    exact mem_integralO.mp
+      (((liftToIntegralO W hW).toAffine.polynomial.map (Polynomial.evalRingHom x')).coeff
+        i).property
+  exact orderTop_nonneg_of_isRoot Q hQcoeff hQlead hQroot
+
+section E3
+
+theorem orderTop_mul_nonneg {u v : H} (hu : 0 ≤ u.orderTop) (hv : 0 ≤ v.orderTop) :
+    0 ≤ (u * v).orderTop := by
+  rw [HahnSeries.orderTop_mul]; exact add_nonneg hu hv
+
+theorem orderTop_add_nonneg {u v : H} (hu : 0 ≤ u.orderTop) (hv : 0 ≤ v.orderTop) :
+    0 ≤ (u + v).orderTop :=
+  le_trans (le_min hu hv) HahnSeries.min_orderTop_le_orderTop_add
+
+theorem orderTop_neg_nonneg {u : H} (hu : 0 ≤ u.orderTop) : 0 ≤ (-u).orderTop := by
+  rw [HahnSeries.orderTop_neg]; exact hu
+
+theorem orderTop_sub_nonneg {u v : H} (hu : 0 ≤ u.orderTop) (hv : 0 ≤ v.orderTop) :
+    0 ≤ (u - v).orderTop := by
+  rw [sub_eq_add_neg]; exact orderTop_add_nonneg hu (orderTop_neg_nonneg hv)
+
+theorem order_div (u v : H) (hu : u ≠ 0) (hv : v ≠ 0) :
+    (u / v).order = u.order - v.order := by
+  have huv : u / v ≠ 0 := div_ne_zero hu hv
+  have h := HahnSeries.order_mul_of_ne_zero (x := u / v) (y := v)
+    (mul_ne_zero (HahnSeries.leadingCoeff_ne_zero.mpr huv)
+      (HahnSeries.leadingCoeff_ne_zero.mpr hv))
+  rw [div_mul_cancel₀ u hv] at h
+  linarith [h]
+
+theorem order_pos_of_coeff_zero_eq_zero {u : H} (hu : u ≠ 0) (hint : 0 ≤ u.orderTop)
+    (h0 : u.coeff 0 = 0) : 0 < u.order := by
+  have hne : u.order ≠ 0 := fun h =>
+    hu (HahnSeries.coeff_order_eq_zero.mp (by rw [h]; exact h0))
+  have hge : 0 ≤ u.order := by
+    rw [← HahnSeries.order_eq_orderTop_of_ne_zero hu] at hint
+    exact_mod_cast hint
+  exact lt_of_le_of_ne hge (Ne.symm hne)
+
+theorem order_eq_zero_of_coeff_zero_ne_zero {u : H} (hint : 0 ≤ u.orderTop)
+    (h0 : u.coeff 0 ≠ 0) : u.order = 0 ∧ u ≠ 0 := by
+  have hu : u ≠ 0 := fun h => h0 (by rw [h]; exact HahnSeries.coeff_zero)
+  refine ⟨?_, hu⟩
+  have hle : u.orderTop ≤ ((0 : ℚ) : WithTop ℚ) := HahnSeries.orderTop_le_of_coeff_ne_zero h0
+  have heq : u.orderTop = 0 := le_antisymm (by exact_mod_cast hle) hint
+  have := (HahnSeries.order_eq_orderTop_of_ne_zero hu).trans heq
+  exact_mod_cast this
+
+theorem coeff_zero_div_of_unit {u v : H} (hu : 0 ≤ u.orderTop) (hv : 0 ≤ v.orderTop)
+    (hv0 : v.coeff 0 ≠ 0) :
+    0 ≤ (u / v).orderTop ∧ (u / v).coeff 0 = u.coeff 0 / v.coeff 0 := by
+  obtain ⟨hvord, hvne⟩ := order_eq_zero_of_coeff_zero_ne_zero hv hv0
+  rcases eq_or_ne u 0 with rfl | hu0
+  · simp [zero_div, HahnSeries.orderTop_zero, HahnSeries.coeff_zero]
+  · have hdiv0 : u / v ≠ 0 := div_ne_zero hu0 hvne
+    have hordu : 0 ≤ u.order := by
+      rw [← HahnSeries.order_eq_orderTop_of_ne_zero hu0] at hu
+      exact_mod_cast hu
+    have hint : 0 ≤ (u / v).orderTop := by
+      rw [← HahnSeries.order_eq_orderTop_of_ne_zero hdiv0]
+      have : (u / v).order = u.order := by rw [order_div u v hu0 hvne, hvord, sub_zero]
+      rw [this]
+      exact_mod_cast hordu
+    refine ⟨hint, ?_⟩
+    have hmul := coeff_zero_mul_of_integral hint hv
+    rw [div_mul_cancel₀ u hvne] at hmul
+    rw [hmul, mul_div_cancel_right₀ _ hv0]
+
+theorem specialFibre_Δ (W : WeierstrassCurve H) (hW : IntegralCoeffs W) :
+    (specialFibre W).Δ = W.Δ.coeff 0 := by
+  obtain ⟨h₁, h₂, h₃, h₄, h₆⟩ := hW
+  let W₀ : WeierstrassCurve integralO :=
+    ⟨⟨W.a₁, h₁⟩, ⟨W.a₂, h₂⟩, ⟨W.a₃, h₃⟩, ⟨W.a₄, h₄⟩, ⟨W.a₆, h₆⟩⟩
+  have hres : W₀.map resO = specialFibre W := rfl
+  have hsub : W₀.map integralO.subtype = W := rfl
+  have e₁ : (specialFibre W).Δ = resO W₀.Δ := by
+    rw [← hres, WeierstrassCurve.map_Δ]
+  have e₂ : ((W₀.Δ : integralO) : H) = W.Δ := by
+    conv_rhs => rw [← hsub, WeierstrassCurve.map_Δ]
+    rfl
+  rw [e₁, resO_apply, e₂]
+
+private theorem isElliptic_specialFibre (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) : (specialFibre W).IsElliptic := by
+  have hΔne : W.Δ ≠ 0 := HahnSeries.orderTop_ne_top.mp (by rw [hΔ]; simp)
+  have hord : W.Δ.order = 0 := by
+    have := (HahnSeries.order_eq_orderTop_of_ne_zero hΔne).trans hΔ
+    exact_mod_cast this
+  have hne : (specialFibre W).Δ ≠ 0 := by
+    rw [specialFibre_Δ W hW, ← hord]
+    exact fun h0 => hΔne (HahnSeries.coeff_order_eq_zero.mp h0)
+  exact ⟨isUnit_iff_ne_zero.mpr hne⟩
+
+theorem equation_specialFibre (W : WeierstrassCurve H) (hW : IntegralCoeffs W) {x y : H}
+    (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop) (h : W.toAffine.Equation x y) :
+    (specialFibre W).toAffine.Equation (x.coeff 0) (y.coeff 0) := by
+  rw [WeierstrassCurve.Affine.equation_iff] at h ⊢
+  obtain ⟨h₁, h₂, h₃, h₄, h₆⟩ := hW
+  let A₁ : integralO := ⟨W.a₁, h₁⟩
+  let A₂ : integralO := ⟨W.a₂, h₂⟩
+  let A₃ : integralO := ⟨W.a₃, h₃⟩
+  let A₄ : integralO := ⟨W.a₄, h₄⟩
+  let A₆ : integralO := ⟨W.a₆, h₆⟩
+  let X : integralO := ⟨x, hx⟩
+  let Y : integralO := ⟨y, hy⟩
+  have h₀ : Y ^ 2 + A₁ * X * Y + A₃ * Y = X ^ 3 + A₂ * X ^ 2 + A₄ * X + A₆ := by
+    apply Subtype.coe_injective
+    push_cast
+    exact h
+  have e := congrArg resO h₀
+  simp only [map_add, map_mul, map_pow, resO_apply] at e
+  exact e
+
+theorem nonsingular_specialFibre (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : W.toAffine.Nonsingular x y) :
+    (specialFibre W).toAffine.Nonsingular (x.coeff 0) (y.coeff 0) := by
+  have := isElliptic_specialFibre W hW hΔ
+  rw [← WeierstrassCurve.Affine.equation_iff_nonsingular]
+  exact equation_specialFibre W hW hx hy h.1
+
+def redPoint (W : WeierstrassCurve H) (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0) :
+    W.toAffine.Point → (specialFibre W).toAffine.Point
+  | .zero => 0
+  | .some x y h =>
+    if hxy : 0 ≤ x.orderTop ∧ 0 ≤ y.orderTop then
+      WeierstrassCurve.Affine.Point.some (x.coeff 0) (y.coeff 0)
+        (nonsingular_specialFibre W hW hΔ hxy.1 hxy.2 h)
+    else 0
+
+@[scoped simp] theorem redPoint_zero (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) : redPoint W hW hΔ 0 = 0 := rfl
+
+theorem redPoint_some (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : W.toAffine.Nonsingular x y) :
+    redPoint W hW hΔ (WeierstrassCurve.Affine.Point.some x y h) =
+      WeierstrassCurve.Affine.Point.some (x.coeff 0) (y.coeff 0)
+        (nonsingular_specialFibre W hW hΔ hx hy h) := by
+  simp only [redPoint, dite_eq_left (And.intro hx hy)]
+
+theorem redPoint_some_ne_zero (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : W.toAffine.Nonsingular x y) :
+    redPoint W hW hΔ (WeierstrassCurve.Affine.Point.some x y h) ≠ 0 := by
+  rw [redPoint_some W hW hΔ hx hy h]
+  exact WeierstrassCurve.Affine.Point.some_ne_zero _
+
+theorem redPoint_neg (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : W.toAffine.Nonsingular x y) :
+    redPoint W hW hΔ (-WeierstrassCurve.Affine.Point.some x y h) =
+      -redPoint W hW hΔ (WeierstrassCurve.Affine.Point.some x y h) := by
+  have hnegY : 0 ≤ (W.toAffine.negY x y).orderTop :=
+    orderTop_sub_nonneg (orderTop_sub_nonneg (orderTop_neg_nonneg hy)
+      (orderTop_mul_nonneg hW.1 hx)) hW.2.2.1
+  have hcoeff : (W.toAffine.negY x y).coeff 0 =
+      (specialFibre W).toAffine.negY (x.coeff 0) (y.coeff 0) := by
+    change (-y - W.a₁ * x - W.a₃).coeff 0 =
+      -(y.coeff 0) - W.a₁.coeff 0 * x.coeff 0 - W.a₃.coeff 0
+    rw [HahnSeries.coeff_sub, HahnSeries.coeff_sub, HahnSeries.coeff_neg,
+      coeff_zero_mul_of_integral hW.1 hx]
+  rw [WeierstrassCurve.Affine.Point.neg_some, redPoint_some W hW hΔ hx hnegY,
+    redPoint_some W hW hΔ hx hy, WeierstrassCurve.Affine.Point.neg_some]
+  congr 1
+
+theorem orderTop_addX_neg (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    {x₁ x₂ ℓ : H} (hx₁ : 0 ≤ x₁.orderTop) (hx₂ : 0 ≤ x₂.orderTop) (hℓ : ℓ.orderTop < 0) :
+    (W.toAffine.addX x₁ x₂ ℓ).orderTop < 0 := by
+  have hℓ0 : ℓ ≠ 0 := HahnSeries.orderTop_ne_top.mp (ne_of_lt (lt_of_lt_of_le hℓ le_top))
+  set q : ℚ := ℓ.order with hqdef
+  have hcoe : ℓ.orderTop = ((q : ℚ) : WithTop ℚ) :=
+    (HahnSeries.order_eq_orderTop_of_ne_zero hℓ0).symm
+  have hqneg : q < 0 := by rw [hcoe] at hℓ; exact_mod_cast hℓ
+  have hsq : (ℓ ^ 2).orderTop = ((q + q : ℚ) : WithTop ℚ) := by
+    rw [pow_two, HahnSeries.orderTop_mul, hcoe]
+    norm_cast
+  have hqq : ((q + q : ℚ) : WithTop ℚ) < ((q : ℚ) : WithTop ℚ) := by
+    exact_mod_cast (by linarith : q + q < q)
+  have hq0 : ((q : ℚ) : WithTop ℚ) < 0 := by exact_mod_cast hqneg
+  have hba : ((q : ℚ) : WithTop ℚ) ≤ (W.a₁ * ℓ).orderTop := by
+    rw [HahnSeries.orderTop_mul, hcoe]
+    calc ((q : ℚ) : WithTop ℚ) = 0 + ((q : ℚ) : WithTop ℚ) := (zero_add _).symm
+      _ ≤ W.a₁.orderTop + ((q : ℚ) : WithTop ℚ) := add_le_add hW.1 le_rfl
+  have step₁ : (ℓ ^ 2 + W.a₁ * ℓ).orderTop = ((q + q : ℚ) : WithTop ℚ) := by
+    rw [HahnSeries.orderTop_add_eq_left (by rw [hsq]; exact lt_of_lt_of_le hqq hba), hsq]
+  have hstep : ∀ (u v : H), u.orderTop = ((q + q : ℚ) : WithTop ℚ) → 0 ≤ v.orderTop →
+      (u - v).orderTop = ((q + q : ℚ) : WithTop ℚ) := by
+    intro u v hu hv
+    rw [sub_eq_add_neg, HahnSeries.orderTop_add_eq_left
+      (by rw [hu, HahnSeries.orderTop_neg]
+          exact lt_of_lt_of_le (lt_of_lt_of_le hqq (le_of_lt hq0)) hv), hu]
+  have step₂ := hstep _ W.a₂ step₁ hW.2.1
+  have step₃ := hstep _ x₁ step₂ hx₁
+  have step₄ := hstep _ x₂ step₃ hx₂
+  change (ℓ ^ 2 + W.a₁ * ℓ - W.a₂ - x₁ - x₂).orderTop < 0
+  rw [step₄]
+  exact lt_trans hqq hq0
+
+theorem orderTop_negY_nonneg (W : WeierstrassCurve H) (hW : IntegralCoeffs W) {x y : H}
+    (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop) : 0 ≤ (W.toAffine.negY x y).orderTop :=
+  orderTop_sub_nonneg (orderTop_sub_nonneg (orderTop_neg_nonneg hy)
+    (orderTop_mul_nonneg hW.1 hx)) hW.2.2.1
+
+theorem coeff_zero_negY (W : WeierstrassCurve H) (hW : IntegralCoeffs W) {x y : H}
+    (hx : 0 ≤ x.orderTop) :
+    (W.toAffine.negY x y).coeff 0 =
+      (specialFibre W).toAffine.negY (x.coeff 0) (y.coeff 0) := by
+  change (-y - W.a₁ * x - W.a₃).coeff 0 =
+    -(y.coeff 0) - W.a₁.coeff 0 * x.coeff 0 - W.a₃.coeff 0
+  rw [HahnSeries.coeff_sub, HahnSeries.coeff_sub, HahnSeries.coeff_neg,
+    coeff_zero_mul_of_integral hW.1 hx]
+
+theorem chord_cross_identity (W : WeierstrassCurve H) {x₁ y₁ x₂ y₂ : H}
+    (e₁ : W.toAffine.Equation x₁ y₁) (e₂ : W.toAffine.Equation x₂ y₂) :
+    (y₁ - y₂) * (y₁ + y₂ + W.a₁ * x₁ + W.a₃) =
+      (x₁ - x₂) * (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂) := by
+  rw [WeierstrassCurve.Affine.equation_iff] at e₁ e₂
+  linear_combination e₁ - e₂
+
+theorem lift_tangentNum (W : WeierstrassCurve H) (hW : IntegralCoeffs W) {x y : H}
+    (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop) :
+    0 ≤ (3 * x ^ 2 + 2 * W.a₂ * x + W.a₄ - W.a₁ * y).orderTop ∧
+      (3 * x ^ 2 + 2 * W.a₂ * x + W.a₄ - W.a₁ * y).coeff 0 =
+        3 * (x.coeff 0) ^ 2 + 2 * W.a₂.coeff 0 * x.coeff 0 + W.a₄.coeff 0
+          - W.a₁.coeff 0 * y.coeff 0 := by
+  obtain ⟨h₁, h₂, h₃, h₄, h₆⟩ := hW
+  have hval : 3 * x ^ 2 + 2 * W.a₂ * x + W.a₄ - W.a₁ * y =
+      ((3 * ⟨x, hx⟩ ^ 2 + 2 * ⟨W.a₂, h₂⟩ * ⟨x, hx⟩ + ⟨W.a₄, h₄⟩
+        - ⟨W.a₁, h₁⟩ * ⟨y, hy⟩ : integralO) : H) := by
+    push_cast
+    rfl
+  constructor
+  · rw [hval]
+    exact mem_integralO.mp (SetLike.coe_mem _)
+  · rw [hval, ← resO_apply]
+    simp only [map_sub, map_add, map_mul, map_pow, map_ofNat, resO_apply]
+
+theorem lift_chordNum (W : WeierstrassCurve H) (hW : IntegralCoeffs W) {x₁ x₂ y₂ : H}
+    (hx₁ : 0 ≤ x₁.orderTop) (hx₂ : 0 ≤ x₂.orderTop) (hy₂ : 0 ≤ y₂.orderTop) :
+    0 ≤ (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂).orderTop ∧
+      (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂).coeff 0 =
+        (x₁.coeff 0) ^ 2 + x₁.coeff 0 * x₂.coeff 0 + (x₂.coeff 0) ^ 2
+          + W.a₂.coeff 0 * (x₁.coeff 0 + x₂.coeff 0) + W.a₄.coeff 0
+          - W.a₁.coeff 0 * y₂.coeff 0 := by
+  obtain ⟨h₁, h₂, h₃, h₄, h₆⟩ := hW
+  have hval : x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂ =
+      ((⟨x₁, hx₁⟩ ^ 2 + ⟨x₁, hx₁⟩ * ⟨x₂, hx₂⟩ + ⟨x₂, hx₂⟩ ^ 2
+        + ⟨W.a₂, h₂⟩ * (⟨x₁, hx₁⟩ + ⟨x₂, hx₂⟩) + ⟨W.a₄, h₄⟩
+        - ⟨W.a₁, h₁⟩ * ⟨y₂, hy₂⟩ : integralO) : H) := by
+    push_cast
+    rfl
+  constructor
+  · rw [hval]
+    exact mem_integralO.mp (SetLike.coe_mem _)
+  · rw [hval, ← resO_apply]
+    simp only [map_sub, map_add, map_mul, map_pow, resO_apply]
+
+theorem lift_chordDen (W : WeierstrassCurve H) (hW : IntegralCoeffs W) {x₁ y₁ y₂ : H}
+    (hx₁ : 0 ≤ x₁.orderTop) (hy₁ : 0 ≤ y₁.orderTop) (hy₂ : 0 ≤ y₂.orderTop) :
+    0 ≤ (y₁ + y₂ + W.a₁ * x₁ + W.a₃).orderTop ∧
+      (y₁ + y₂ + W.a₁ * x₁ + W.a₃).coeff 0 =
+        y₁.coeff 0 + y₂.coeff 0 + W.a₁.coeff 0 * x₁.coeff 0 + W.a₃.coeff 0 := by
+  obtain ⟨h₁, h₂, h₃, h₄, h₆⟩ := hW
+  have hval : y₁ + y₂ + W.a₁ * x₁ + W.a₃ =
+      ((⟨y₁, hy₁⟩ + ⟨y₂, hy₂⟩ + ⟨W.a₁, h₁⟩ * ⟨x₁, hx₁⟩ + ⟨W.a₃, h₃⟩ : integralO) : H) := by
+    push_cast
+    rfl
+  constructor
+  · rw [hval]
+    exact mem_integralO.mp (SetLike.coe_mem _)
+  · rw [hval, ← resO_apply]
+    simp only [map_add, map_mul, resO_apply]
+
+theorem lift_addX (W : WeierstrassCurve H) (hW : IntegralCoeffs W) {x₁ x₂ ℓ : H}
+    (hx₁ : 0 ≤ x₁.orderTop) (hx₂ : 0 ≤ x₂.orderTop) (hℓ : 0 ≤ ℓ.orderTop) :
+    0 ≤ (W.toAffine.addX x₁ x₂ ℓ).orderTop ∧
+      (W.toAffine.addX x₁ x₂ ℓ).coeff 0 =
+        (specialFibre W).toAffine.addX (x₁.coeff 0) (x₂.coeff 0) (ℓ.coeff 0) := by
+  obtain ⟨h₁, h₂, h₃, h₄, h₆⟩ := hW
+  have hval : W.toAffine.addX x₁ x₂ ℓ =
+      ((⟨ℓ, hℓ⟩ ^ 2 + ⟨W.a₁, h₁⟩ * ⟨ℓ, hℓ⟩ - ⟨W.a₂, h₂⟩ - ⟨x₁, hx₁⟩
+        - ⟨x₂, hx₂⟩ : integralO) : H) := by
+    change ℓ ^ 2 + W.a₁ * ℓ - W.a₂ - x₁ - x₂ = _
+    push_cast
+    rfl
+  constructor
+  · rw [hval]
+    exact mem_integralO.mp (SetLike.coe_mem _)
+  · rw [hval, ← resO_apply]
+    change _ = (ℓ.coeff 0) ^ 2 + W.a₁.coeff 0 * (ℓ.coeff 0) - W.a₂.coeff 0
+      - x₁.coeff 0 - x₂.coeff 0
+    simp only [map_sub, map_add, map_mul, map_pow, resO_apply]
+
+theorem orderTop_slope_neg_of_bar_vertical (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) {x₁ y₁ x₂ y₂ : H}
+    (h₁ : W.toAffine.Nonsingular x₁ y₁) (h₂ : W.toAffine.Nonsingular x₂ y₂)
+    (hx₁ : 0 ≤ x₁.orderTop) (hy₁ : 0 ≤ y₁.orderTop)
+    (hx₂ : 0 ≤ x₂.orderTop) (hy₂ : 0 ≤ y₂.orderTop)
+    (hv : ¬(x₁ = x₂ ∧ y₁ = W.toAffine.negY x₂ y₂))
+    (hvbx : x₁.coeff 0 = x₂.coeff 0)
+    (hvby : y₁.coeff 0 = (specialFibre W).toAffine.negY (x₂.coeff 0) (y₂.coeff 0)) :
+    (W.toAffine.slope x₁ x₂ y₁ y₂).orderTop < 0 := by
+  have hb1 := nonsingular_specialFibre W hW hΔ hx₁ hy₁ h₁
+  have hvby' : y₁.coeff 0 = -(y₂.coeff 0) - W.a₁.coeff 0 * x₂.coeff 0 - W.a₃.coeff 0 := hvby
+  by_cases hx12 : x₁ = x₂
+  · have hy12 : y₁ ≠ W.toAffine.negY x₂ y₂ := fun h => hv ⟨hx12, h⟩
+    have hy21 : y₁ = y₂ := WeierstrassCurve.Affine.Y_eq_of_Y_ne h₁.1 h₂.1 hx12 hy12
+    have hy21c : y₁.coeff 0 = y₂.coeff 0 := by rw [hy21]
+    rw [WeierstrassCurve.Affine.slope_of_Y_ne hx12 hy12]
+    have hdead : 2 * y₁.coeff 0 + W.a₁.coeff 0 * x₁.coeff 0 + W.a₃.coeff 0 = 0 := by
+      linear_combination hvby' + hy21c + W.a₁.coeff 0 * hvbx
+    obtain ⟨hNint, hNcoeff⟩ := lift_tangentNum W hW hx₁ hy₁
+    have hNbar : (3 * x₁ ^ 2 + 2 * W.a₂ * x₁ + W.a₄ - W.a₁ * y₁).coeff 0 ≠ 0 := by
+      obtain ⟨-, hdisj⟩ := (WeierstrassCurve.Affine.nonsingular_iff' _ _).mp hb1
+      rcases hdisj with hA | hB
+      · have hA' : W.a₁.coeff 0 * y₁.coeff 0
+            - (3 * (x₁.coeff 0) ^ 2 + 2 * W.a₂.coeff 0 * x₁.coeff 0 + W.a₄.coeff 0) ≠ 0 := hA
+        rw [hNcoeff]
+        intro h0
+        exact hA' (by linear_combination -h0)
+      · have hB' : 2 * y₁.coeff 0 + W.a₁.coeff 0 * x₁.coeff 0 + W.a₃.coeff 0 ≠ 0 := hB
+        exact absurd hdead hB'
+    have hNne : 3 * x₁ ^ 2 + 2 * W.a₂ * x₁ + W.a₄ - W.a₁ * y₁ ≠ 0 :=
+      fun h => hNbar (by rw [h]; exact HahnSeries.coeff_zero)
+    obtain ⟨hNord, -⟩ := order_eq_zero_of_coeff_zero_ne_zero hNint hNbar
+    have hdne : y₁ - W.toAffine.negY x₁ y₁ ≠ 0 :=
+      sub_ne_zero.mpr fun h => hy12 (by rw [← hx12, ← hy21]; exact h)
+    have hdint : 0 ≤ (y₁ - W.toAffine.negY x₁ y₁).orderTop :=
+      orderTop_sub_nonneg hy₁ (orderTop_negY_nonneg W hW hx₁ hy₁)
+    have hdbar : (y₁ - W.toAffine.negY x₁ y₁).coeff 0 = 0 := by
+      rw [HahnSeries.coeff_sub, coeff_zero_negY W hW hx₁]
+      change y₁.coeff 0 - (-(y₁.coeff 0) - W.a₁.coeff 0 * x₁.coeff 0 - W.a₃.coeff 0) = 0
+      linear_combination hdead
+    have hdpos : 0 < (y₁ - W.toAffine.negY x₁ y₁).order :=
+      order_pos_of_coeff_zero_eq_zero hdne hdint hdbar
+    have hQne : (3 * x₁ ^ 2 + 2 * W.a₂ * x₁ + W.a₄ - W.a₁ * y₁)
+        / (y₁ - W.toAffine.negY x₁ y₁) ≠ 0 := div_ne_zero hNne hdne
+    rw [← HahnSeries.order_eq_orderTop_of_ne_zero hQne,
+      order_div _ _ hNne hdne, hNord]
+    exact_mod_cast (by linarith : (0 : ℚ) - (y₁ - W.toAffine.negY x₁ y₁).order < 0)
+  · rw [WeierstrassCurve.Affine.slope_of_X_ne hx12]
+    have hsubne : x₁ - x₂ ≠ 0 := sub_ne_zero.mpr hx12
+    have hsubint : 0 ≤ (x₁ - x₂).orderTop := orderTop_sub_nonneg hx₁ hx₂
+    have hsubbar : (x₁ - x₂).coeff 0 = 0 := by
+      rw [HahnSeries.coeff_sub, sub_eq_zero]; exact hvbx
+    have hsubpos : 0 < (x₁ - x₂).order :=
+      order_pos_of_coeff_zero_eq_zero hsubne hsubint hsubbar
+    by_cases hyb : y₁.coeff 0 = y₂.coeff 0
+    · obtain ⟨hDint, hDcoeff⟩ := lift_chordDen W hW hx₁ hy₁ hy₂
+      obtain ⟨hNint, hNcoeff⟩ := lift_chordNum W hW hx₁ hx₂ hy₂
+      have hdead : 2 * y₁.coeff 0 + W.a₁.coeff 0 * x₁.coeff 0 + W.a₃.coeff 0 = 0 := by
+        linear_combination hvby' + hyb + W.a₁.coeff 0 * hvbx
+      have hNbar : (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄
+          - W.a₁ * y₂).coeff 0 ≠ 0 := by
+        obtain ⟨-, hdisj⟩ := (WeierstrassCurve.Affine.nonsingular_iff' _ _).mp hb1
+        rcases hdisj with hA | hB
+        · have hA' : W.a₁.coeff 0 * y₁.coeff 0
+              - (3 * (x₁.coeff 0) ^ 2 + 2 * W.a₂.coeff 0 * x₁.coeff 0 + W.a₄.coeff 0) ≠ 0 := hA
+          rw [hNcoeff]
+          intro h0
+          exact hA' (by linear_combination -h0 + W.a₁.coeff 0 * hyb
+            - (2 * x₁.coeff 0 + x₂.coeff 0 + W.a₂.coeff 0) * hvbx)
+        · have hB' : 2 * y₁.coeff 0 + W.a₁.coeff 0 * x₁.coeff 0 + W.a₃.coeff 0 ≠ 0 := hB
+          exact absurd hdead hB'
+      have hNne : x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂ ≠ 0 :=
+        fun h => hNbar (by rw [h]; exact HahnSeries.coeff_zero)
+      obtain ⟨hNord, -⟩ := order_eq_zero_of_coeff_zero_ne_zero hNint hNbar
+      have hDbar : (y₁ + y₂ + W.a₁ * x₁ + W.a₃).coeff 0 = 0 := by
+        rw [hDcoeff]
+        linear_combination hdead - hyb
+      have hDne : y₁ + y₂ + W.a₁ * x₁ + W.a₃ ≠ 0 := by
+        intro h0
+        have hKEY := chord_cross_identity W h₁.1 h₂.1
+        rw [h0, mul_zero] at hKEY
+        exact hNne ((mul_eq_zero.mp hKEY.symm).resolve_left hsubne)
+      have hDpos : 0 < (y₁ + y₂ + W.a₁ * x₁ + W.a₃).order :=
+        order_pos_of_coeff_zero_eq_zero hDne hDint hDbar
+      have hℓeq : (y₁ - y₂) / (x₁ - x₂) =
+          (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂)
+            / (y₁ + y₂ + W.a₁ * x₁ + W.a₃) := by
+        rw [div_eq_div_iff hsubne hDne]
+        linear_combination chord_cross_identity W h₁.1 h₂.1
+      rw [hℓeq]
+      have hQne : (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂)
+          / (y₁ + y₂ + W.a₁ * x₁ + W.a₃) ≠ 0 := div_ne_zero hNne hDne
+      rw [← HahnSeries.order_eq_orderTop_of_ne_zero hQne,
+        order_div _ _ hNne hDne, hNord]
+      exact_mod_cast (by linarith : (0 : ℚ) - (y₁ + y₂ + W.a₁ * x₁ + W.a₃).order < 0)
+    · have hnbar : (y₁ - y₂).coeff 0 ≠ 0 := by
+        rw [HahnSeries.coeff_sub]; exact sub_ne_zero.mpr hyb
+      have hnne : y₁ - y₂ ≠ 0 := fun h => hnbar (by rw [h]; exact HahnSeries.coeff_zero)
+      obtain ⟨hnord, -⟩ :=
+        order_eq_zero_of_coeff_zero_ne_zero (orderTop_sub_nonneg hy₁ hy₂) hnbar
+      have hQne : (y₁ - y₂) / (x₁ - x₂) ≠ 0 := div_ne_zero hnne hsubne
+      rw [← HahnSeries.order_eq_orderTop_of_ne_zero hQne,
+        order_div _ _ hnne hsubne, hnord]
+      exact_mod_cast (by linarith : (0 : ℚ) - (x₁ - x₂).order < 0)
+
+theorem slope_lift (W : WeierstrassCurve H) (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0)
+    {x₁ y₁ x₂ y₂ : H}
+    (h₁ : W.toAffine.Nonsingular x₁ y₁) (h₂ : W.toAffine.Nonsingular x₂ y₂)
+    (hx₁ : 0 ≤ x₁.orderTop) (hy₁ : 0 ≤ y₁.orderTop)
+    (hx₂ : 0 ≤ x₂.orderTop) (hy₂ : 0 ≤ y₂.orderTop)
+    (hvb : ¬(x₁.coeff 0 = x₂.coeff 0 ∧
+      y₁.coeff 0 = (specialFibre W).toAffine.negY (x₂.coeff 0) (y₂.coeff 0))) :
+    0 ≤ (W.toAffine.slope x₁ x₂ y₁ y₂).orderTop ∧
+      (W.toAffine.slope x₁ x₂ y₁ y₂).coeff 0 =
+        (specialFibre W).toAffine.slope (x₁.coeff 0) (x₂.coeff 0)
+          (y₁.coeff 0) (y₂.coeff 0) := by
+  have hb1 := nonsingular_specialFibre W hW hΔ hx₁ hy₁ h₁
+  have hb2 := nonsingular_specialFibre W hW hΔ hx₂ hy₂ h₂
+  by_cases hxb : x₁.coeff 0 = x₂.coeff 0
+  · have hyb : y₁.coeff 0 ≠ (specialFibre W).toAffine.negY (x₂.coeff 0) (y₂.coeff 0) :=
+      fun h => hvb ⟨hxb, h⟩
+    have hfs := WeierstrassCurve.Affine.slope_of_Y_ne hxb hyb
+    have hy21c : y₁.coeff 0 = y₂.coeff 0 :=
+      WeierstrassCurve.Affine.Y_eq_of_Y_ne hb1.1 hb2.1 hxb hyb
+    have hdbarne : y₁.coeff 0
+        - (specialFibre W).toAffine.negY (x₁.coeff 0) (y₁.coeff 0) ≠ 0 :=
+      sub_ne_zero.mpr fun h => hyb (by rw [← hxb, ← hy21c]; exact h)
+    by_cases hx12 : x₁ = x₂
+    · have hyne : y₁ ≠ W.toAffine.negY x₂ y₂ := by
+        intro h
+        exact hyb (by rw [h, coeff_zero_negY W hW hx₂])
+      rw [WeierstrassCurve.Affine.slope_of_Y_ne hx12 hyne, hfs]
+      obtain ⟨hNint, hNcoeff⟩ := lift_tangentNum W hW hx₁ hy₁
+      have hdint : 0 ≤ (y₁ - W.toAffine.negY x₁ y₁).orderTop :=
+        orderTop_sub_nonneg hy₁ (orderTop_negY_nonneg W hW hx₁ hy₁)
+      have hdbar : (y₁ - W.toAffine.negY x₁ y₁).coeff 0 =
+          y₁.coeff 0 - (specialFibre W).toAffine.negY (x₁.coeff 0) (y₁.coeff 0) := by
+        rw [HahnSeries.coeff_sub, coeff_zero_negY W hW hx₁]
+      obtain ⟨hint, hcoeff⟩ := coeff_zero_div_of_unit hNint hdint (by rw [hdbar]; exact hdbarne)
+      refine ⟨hint, ?_⟩
+      rw [hcoeff, hNcoeff, hdbar]
+      rfl
+    · obtain ⟨hDint, hDcoeff⟩ := lift_chordDen W hW hx₁ hy₁ hy₂
+      obtain ⟨hNint, hNcoeff⟩ := lift_chordNum W hW hx₁ hx₂ hy₂
+      have hsubne : x₁ - x₂ ≠ 0 := sub_ne_zero.mpr hx12
+      have hDbarne : (y₁ + y₂ + W.a₁ * x₁ + W.a₃).coeff 0 ≠ 0 := by
+        rw [hDcoeff]
+        intro h0
+        apply hyb
+        change y₁.coeff 0 = -(y₂.coeff 0) - W.a₁.coeff 0 * x₂.coeff 0 - W.a₃.coeff 0
+        linear_combination h0 - W.a₁.coeff 0 * hxb
+      have hDne : y₁ + y₂ + W.a₁ * x₁ + W.a₃ ≠ 0 :=
+        fun h => hDbarne (by rw [h]; exact HahnSeries.coeff_zero)
+      have hℓeq : W.toAffine.slope x₁ x₂ y₁ y₂ =
+          (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂)
+            / (y₁ + y₂ + W.a₁ * x₁ + W.a₃) := by
+        rw [WeierstrassCurve.Affine.slope_of_X_ne hx12, div_eq_div_iff hsubne hDne]
+        linear_combination chord_cross_identity W h₁.1 h₂.1
+      rw [hℓeq, hfs]
+      obtain ⟨hint, hcoeff⟩ := coeff_zero_div_of_unit hNint hDint hDbarne
+      refine ⟨hint, ?_⟩
+      rw [hcoeff, hNcoeff, hDcoeff]
+      change _ = (3 * (x₁.coeff 0) ^ 2 + 2 * W.a₂.coeff 0 * (x₁.coeff 0) + W.a₄.coeff 0
+          - W.a₁.coeff 0 * (y₁.coeff 0)) /
+        (y₁.coeff 0 - (-(y₁.coeff 0) - W.a₁.coeff 0 * (x₁.coeff 0) - W.a₃.coeff 0))
+      congr 1
+      · linear_combination (-(2 * x₁.coeff 0 + x₂.coeff 0 + W.a₂.coeff 0)) * hxb
+          + W.a₁.coeff 0 * hy21c
+      · linear_combination hy21c.symm
+  · have hx12 : x₁ ≠ x₂ := fun h => hxb (by rw [h])
+    rw [WeierstrassCurve.Affine.slope_of_X_ne hx12,
+      WeierstrassCurve.Affine.slope_of_X_ne hxb]
+    have hsubbar : (x₁ - x₂).coeff 0 ≠ 0 := by
+      rw [HahnSeries.coeff_sub]; exact sub_ne_zero.mpr hxb
+    obtain ⟨hint, hcoeff⟩ := coeff_zero_div_of_unit (orderTop_sub_nonneg hy₁ hy₂)
+      (orderTop_sub_nonneg hx₁ hx₂) hsubbar
+    refine ⟨hint, ?_⟩
+    rw [hcoeff, HahnSeries.coeff_sub, HahnSeries.coeff_sub]
+
+theorem some_point_ext {V : WeierstrassCurve.Affine Qbar} {x y x' y' : Qbar}
+    {h : V.Nonsingular x y} {h' : V.Nonsingular x' y'} (hx : x = x') (hy : y = y') :
+    WeierstrassCurve.Affine.Point.some x y h = WeierstrassCurve.Affine.Point.some x' y' h' := by
+  subst hx; subst hy; rfl
+
+theorem redPoint_add (W : WeierstrassCurve H) [W.IsElliptic] (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) {n : ℕ} (hn : n ≠ 0) {P Q : W.toAffine.Point}
+    (hP : n • P = 0) (hQ : n • Q = 0) :
+    redPoint W hW hΔ (P + Q) = redPoint W hW hΔ P + redPoint W hW hΔ Q := by
+  cases P with
+  | zero =>
+    change redPoint W hW hΔ (0 + Q) = redPoint W hW hΔ 0 + redPoint W hW hΔ Q
+    rw [zero_add, redPoint_zero, zero_add]
+  | some x₁ y₁ h₁ =>
+    cases Q with
+    | zero =>
+      change redPoint W hW hΔ (WeierstrassCurve.Affine.Point.some x₁ y₁ h₁ + 0) =
+        redPoint W hW hΔ (WeierstrassCurve.Affine.Point.some x₁ y₁ h₁) + redPoint W hW hΔ 0
+      rw [add_zero, redPoint_zero, add_zero]
+    | some x₂ y₂ h₂ =>
+      obtain ⟨hx₁, hy₁⟩ := torsion_coords_integral W hW hΔ h₁ hn hP
+      obtain ⟨hx₂, hy₂⟩ := torsion_coords_integral W hW hΔ h₂ hn hQ
+      by_cases hv : x₁ = x₂ ∧ y₁ = W.toAffine.negY x₂ y₂
+      · rw [WeierstrassCurve.Affine.Point.add_of_Y_eq hv.1 hv.2, redPoint_zero,
+          redPoint_some W hW hΔ hx₁ hy₁ h₁, redPoint_some W hW hΔ hx₂ hy₂ h₂]
+        exact (WeierstrassCurve.Affine.Point.add_of_Y_eq (by rw [hv.1])
+          (by rw [hv.2, coeff_zero_negY W hW hx₂])).symm
+      · have htor₃ : n • (WeierstrassCurve.Affine.Point.some x₁ y₁ h₁
+            + WeierstrassCurve.Affine.Point.some x₂ y₂ h₂) = 0 := by
+          rw [nsmul_add, hP, hQ, add_zero]
+        rw [WeierstrassCurve.Affine.Point.add_some hv] at htor₃ ⊢
+        by_cases hvb : x₁.coeff 0 = x₂.coeff 0 ∧
+            y₁.coeff 0 = (specialFibre W).toAffine.negY (x₂.coeff 0) (y₂.coeff 0)
+        · exact absurd (torsion_coords_integral W hW hΔ _ hn htor₃).1
+            (not_le.mpr (orderTop_addX_neg W hW hx₁ hx₂
+              (orderTop_slope_neg_of_bar_vertical W hW hΔ h₁ h₂ hx₁ hy₁ hx₂ hy₂
+                hv hvb.1 hvb.2)))
+        · obtain ⟨hsint, hscoeff⟩ := slope_lift W hW hΔ h₁ h₂ hx₁ hy₁ hx₂ hy₂ hvb
+          obtain ⟨hXint, hXcoeff⟩ := lift_addX W hW hx₁ hx₂ hsint
+          have hnAYint : 0 ≤ (W.toAffine.negAddY x₁ x₂ y₁
+              (W.toAffine.slope x₁ x₂ y₁ y₂)).orderTop := by
+            change 0 ≤ (W.toAffine.slope x₁ x₂ y₁ y₂
+              * (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₁) + y₁).orderTop
+            exact orderTop_add_nonneg
+              (orderTop_mul_nonneg hsint (orderTop_sub_nonneg hXint hx₁)) hy₁
+          have hnAYcoeff : (W.toAffine.negAddY x₁ x₂ y₁
+              (W.toAffine.slope x₁ x₂ y₁ y₂)).coeff 0 =
+              (specialFibre W).toAffine.negAddY (x₁.coeff 0) (x₂.coeff 0) (y₁.coeff 0)
+                ((W.toAffine.slope x₁ x₂ y₁ y₂).coeff 0) := by
+            change (W.toAffine.slope x₁ x₂ y₁ y₂
+              * (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₁) + y₁).coeff 0 = _
+            rw [HahnSeries.coeff_add,
+              coeff_zero_mul_of_integral hsint (orderTop_sub_nonneg hXint hx₁),
+              HahnSeries.coeff_sub, hXcoeff]
+            rfl
+          have hYint : 0 ≤ (W.toAffine.addY x₁ x₂ y₁
+              (W.toAffine.slope x₁ x₂ y₁ y₂)).orderTop :=
+            orderTop_negY_nonneg W hW hXint hnAYint
+          have hYcoeff : (W.toAffine.addY x₁ x₂ y₁
+              (W.toAffine.slope x₁ x₂ y₁ y₂)).coeff 0 =
+              (specialFibre W).toAffine.addY (x₁.coeff 0) (x₂.coeff 0) (y₁.coeff 0)
+                ((W.toAffine.slope x₁ x₂ y₁ y₂).coeff 0) := by
+            change (W.toAffine.negY (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂))
+              (W.toAffine.negAddY x₁ x₂ y₁ (W.toAffine.slope x₁ x₂ y₁ y₂))).coeff 0 = _
+            rw [coeff_zero_negY W hW hXint, hXcoeff, hnAYcoeff]
+            rfl
+          rw [redPoint_some W hW hΔ hXint hYint _,
+            redPoint_some W hW hΔ hx₁ hy₁ h₁, redPoint_some W hW hΔ hx₂ hy₂ h₂,
+            WeierstrassCurve.Affine.Point.add_some hvb]
+          exact some_point_ext (by rw [hXcoeff, hscoeff]) (by rw [hYcoeff, hscoeff])
+
+private theorem exists_torsionBy_reduction_addEquiv (W : WeierstrassCurve H) [W.IsElliptic]
+    (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0) [(specialFibre W).IsElliptic]
+    (p : ℕ) [Fact p.Prime] :
+    ∃ e : Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ) ≃+
+        Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ),
+      ∀ (P : Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ)) (x y : H)
+        (h : W.toAffine.Nonsingular x y),
+        (P : W.toAffine.Point) = WeierstrassCurve.Affine.Point.some x y h →
+          ∃ h₀ : (specialFibre W).toAffine.Nonsingular (x.coeff 0) (y.coeff 0),
+            ((e P : Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ)) :
+                (specialFibre W).toAffine.Point) =
+              WeierstrassCurve.Affine.Point.some (x.coeff 0) (y.coeff 0) h₀ := by
+  have hpprime : p.Prime := Fact.out
+  have hp : p ≠ 0 := hpprime.ne_zero
+  have hmem : ∀ P : Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ),
+      p • (P : W.toAffine.Point) = 0 := fun P => by
+    have h := (Submodule.mem_torsionBy_iff _ _).mp P.2
+    rwa [natCast_zsmul] at h
+  have key : ∀ (P : Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ)) (k : ℕ),
+      redPoint W hW hΔ (k • (P : W.toAffine.Point)) =
+        k • redPoint W hW hΔ (P : W.toAffine.Point) := by
+    intro P k
+    induction k with
+    | zero => rw [zero_nsmul, zero_nsmul, redPoint_zero]
+    | succ k ih =>
+      have hkP : p • (k • (P : W.toAffine.Point)) = 0 := by
+        rw [← mul_nsmul, mul_comm, mul_nsmul, hmem P]
+        simp
+      rw [succ_nsmul, succ_nsmul, redPoint_add W hW hΔ hp hkP (hmem P), ih]
+  have hred : ∀ P : Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ),
+      redPoint W hW hΔ (P : W.toAffine.Point) ∈
+        Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ) := fun P => by
+    rw [Submodule.mem_torsionBy_iff, natCast_zsmul, ← key P p, hmem P, redPoint_zero]
+  let f : Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ) →+
+      Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ) :=
+    AddMonoidHom.mk'
+      (fun P => ⟨redPoint W hW hΔ (P : W.toAffine.Point), hred P⟩)
+      (fun P Q => by
+        apply Subtype.ext
+        change redPoint W hW hΔ ((P : W.toAffine.Point) + (Q : W.toAffine.Point)) = _
+        exact redPoint_add W hW hΔ hp (hmem P) (hmem Q))
+  have hinj : Function.Injective f := by
+    rw [injective_iff_map_eq_zero]
+    intro P hP0
+    have h0 : redPoint W hW hΔ (P : W.toAffine.Point) = 0 := congrArg Subtype.val hP0
+    apply Subtype.ext
+    change (P : W.toAffine.Point) = 0
+    cases hPv : (P : W.toAffine.Point) with
+    | zero => rfl
+    | some x y hxy =>
+      rw [hPv] at h0
+      have htor := hmem P
+      rw [hPv] at htor
+      obtain ⟨hx, hy⟩ := torsion_coords_integral W hW hΔ hxy hp htor
+      rw [redPoint_some W hW hΔ hx hy] at h0
+      exact absurd h0 (WeierstrassCurve.Affine.Point.some_ne_zero _)
+  have : IsAlgClosed H := HahnSeries.isAlgClosed_rat
+  have hne : ∀ m : ℕ, m ≠ 0 → (m : H) ≠ 0 := fun m hm => by
+    rw [(map_natCast (HahnSeries.C : Qbar →+* H) m).symm]
+    change HahnSeries.single (0 : ℚ) ((m : ℕ) : Qbar) ≠ 0
+    exact HahnSeries.single_ne_zero (Nat.cast_ne_zero.mpr hm)
+  have h2H : (2 : H) ≠ 0 := by exact_mod_cast hne 2 (by norm_num)
+  have hcard₁ : Nat.card (Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ)) = p ^ 2 :=
+    WeierstrassCurve.card_torsionBy_eq_sq_of_isAlgClosed W (hne p hp)
+  have hcard₂ :
+      Nat.card (Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ)) = p ^ 2 :=
+    WeierstrassCurve.card_torsionBy_eq_sq_of_isAlgClosed (specialFibre W)
+      (Nat.cast_ne_zero.mpr hp)
+  have : Finite (Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ)) :=
+    Nat.finite_of_card_ne_zero (by rw [hcard₂]; exact pow_ne_zero 2 hp)
+  have hbij : Function.Bijective f :=
+    (Nat.bijective_iff_injective_and_card f).mpr ⟨hinj, by rw [hcard₁, hcard₂]⟩
+  refine ⟨AddEquiv.ofBijective f hbij, ?_⟩
+  intro P x y h hPv
+  have htor := hmem P
+  rw [hPv] at htor
+  obtain ⟨hx, hy⟩ := torsion_coords_integral W hW hΔ h hp htor
+  refine ⟨nonsingular_specialFibre W hW hΔ hx hy h, ?_⟩
+  change redPoint W hW hΔ (P : W.toAffine.Point) = _
+  rw [hPv, redPoint_some W hW hΔ hx hy h]
+
+end E3
+
+universe u
+
+def CycOf (A : Type u) [AddGroup A] (N : ℕ) : Type u :=
+  {G : AddSubgroup A // ∃ g : A, addOrderOf g = N ∧ G = AddSubgroup.zmultiples g}
+
+example (E : WeierstrassCurve H) (N : ℕ) : CycSubH E N = CycOf E.toAffine.Point N := rfl
+example (E₀ : WeierstrassCurve Qbar) (N : ℕ) : CycSub E₀ N = CycOf E₀.toAffine.Point N := rfl
+
+def cycOfCongr {A B : Type*} [AddCommGroup A] [AddCommGroup B] (e : A ≃+ B) (N : ℕ) :
+    CycOf A N ≃ CycOf B N where
+  toFun G := ⟨G.1.map (e : A →+ B), by
+    obtain ⟨g, hg, hG⟩ := G.2
+    exact ⟨(e : A →+ B) g, by rw [AddMonoidHom.coe_ofClass, AddEquiv.addOrderOf_eq, hg],
+      by rw [hG, AddMonoidHom.map_zmultiples]⟩⟩
+  invFun G := ⟨G.1.map (e.symm : B →+ A), by
+    obtain ⟨g, hg, hG⟩ := G.2
+    exact ⟨(e.symm : B →+ A) g, by rw [AddMonoidHom.coe_ofClass, AddEquiv.addOrderOf_eq, hg],
+      by rw [hG, AddMonoidHom.map_zmultiples]⟩⟩
+  left_inv G := Subtype.ext ((AddSubgroup.map_symm_eq_iff_map_eq (K := G.1)).mpr rfl)
+  right_inv G := Subtype.ext ((AddSubgroup.map_symm_eq_iff_map_eq (K := G.1) (e := e.symm)).mpr rfl)
+
+@[scoped simp] theorem cycOfCongr_apply_coe {A B : Type*} [AddCommGroup A] [AddCommGroup B] (e : A
+  ≃+ B)
+    (N : ℕ) (G : CycOf A N) : (cycOfCongr e N G).1 = G.1.map (e : A →+ B) := rfl
+
+theorem mem_torsionBy_of_addOrderOf_eq {A : Type*} [AddCommGroup A] {N : ℕ} {g : A}
+    (hg : addOrderOf g = N) : g ∈ Submodule.torsionBy ℤ A N := by
+  rw [Submodule.mem_torsionBy_iff, natCast_zsmul, ← hg, addOrderOf_nsmul_eq_zero]
+
+theorem comap_subtype_zmultiples {A : Type*} [AddCommGroup A] (S : Submodule ℤ A) {x : A}
+    (hx : x ∈ S) :
+    (AddSubgroup.zmultiples x).comap S.subtype.toAddMonoidHom = AddSubgroup.zmultiples ⟨x, hx⟩ := by
+  rw [show AddSubgroup.zmultiples x =
+      (AddSubgroup.zmultiples (⟨x, hx⟩ : S)).map S.subtype.toAddMonoidHom from
+        (AddMonoidHom.map_zmultiples S.subtype.toAddMonoidHom ⟨x, hx⟩).symm,
+    AddSubgroup.comap_map_eq_self_of_injective (Submodule.injective_subtype S)]
+
+def cycOfTorsionBy (A : Type*) [AddCommGroup A] (N : ℕ) :
+    CycOf A N ≃ CycOf (Submodule.torsionBy ℤ A N) N where
+  toFun G := ⟨G.1.comap (Submodule.torsionBy ℤ A N).subtype.toAddMonoidHom, by
+    obtain ⟨g, hg, hG⟩ := G.2
+    refine ⟨⟨g, mem_torsionBy_of_addOrderOf_eq hg⟩, ?_, by rw [hG, comap_subtype_zmultiples]⟩
+    rw [← addOrderOf_injective (Submodule.torsionBy ℤ A N).subtype.toAddMonoidHom
+      (Submodule.injective_subtype _) ⟨g, mem_torsionBy_of_addOrderOf_eq hg⟩]
+    exact hg⟩
+  invFun G := ⟨G.1.map (Submodule.torsionBy ℤ A N).subtype.toAddMonoidHom, by
+    obtain ⟨g, hg, hG⟩ := G.2
+    exact ⟨(Submodule.torsionBy ℤ A N).subtype.toAddMonoidHom g,
+      by rw [addOrderOf_injective _ (Submodule.injective_subtype _), hg],
+      by rw [hG, AddMonoidHom.map_zmultiples]⟩⟩
+  left_inv G := by
+    apply Subtype.ext
+    obtain ⟨g, hg, hG⟩ := G.2
+    change (G.1.comap _).map _ = G.1
+    apply AddSubgroup.map_comap_eq_self
+    rw [hG, AddSubgroup.zmultiples_le]
+    exact AddMonoidHom.mem_range.mpr ⟨⟨g, mem_torsionBy_of_addOrderOf_eq hg⟩, rfl⟩
+  right_inv G :=
+    Subtype.ext (AddSubgroup.comap_map_eq_self_of_injective (Submodule.injective_subtype _) _)
+
+@[scoped simp] theorem cycOfTorsionBy_apply_coe (A : Type*) [AddCommGroup A] (N : ℕ) (G : CycOf A
+  N) :
+    (cycOfTorsionBy A N G).1 = G.1.comap (Submodule.torsionBy ℤ A N).subtype.toAddMonoidHom := rfl
+
+@[scoped simp] theorem cycOfTorsionBy_symm_apply_coe (A : Type*) [AddCommGroup A] (N : ℕ)
+    (G : CycOf (Submodule.torsionBy ℤ A N) N) :
+    ((cycOfTorsionBy A N).symm G).1 = G.1.map (Submodule.torsionBy ℤ A N).subtype.toAddMonoidHom :=
+  rfl
+
+def vcAddEquiv {K : Type*} [Field K] [DecidableEq K] (C : VariableChange K)
+    (W : WeierstrassCurve K) :
+    W.toAffine.Point ≃+ (C • W).toAffine.Point :=
+  AddEquiv.mk' (WeierstrassCurve.Affine.Point.variableChangeEquiv C W.toAffine).symm
+    (WeierstrassCurve.Affine.Point.vcInvFun_add C W.toAffine)
+
+@[scoped simp] theorem vcAddEquiv_apply {K : Type*} [Field K] [DecidableEq K] (C : VariableChange K)
+    (W : WeierstrassCurve K) (P : W.toAffine.Point) :
+    vcAddEquiv C W P = WeierstrassCurve.Affine.Point.vcInvFun C W.toAffine P := rfl
+
+def pointAddEquivOfEq {K : Type*} [Field K] [DecidableEq K] {W V : WeierstrassCurve K} (h : W = V) :
+    W.toAffine.Point ≃+ V.toAffine.Point := by
+  subst h; exact AddEquiv.refl _
+
+@[scoped simp] theorem pointAddEquivOfEq_rfl {K : Type*} [Field K] [DecidableEq K]
+    (W : WeierstrassCurve K) :
+    pointAddEquivOfEq (rfl : W = W) = AddEquiv.refl _ := rfl
+
+scoped instance instIsElliptic_goodModel (j₀ : Qbar) : (goodModel j₀).IsElliptic := by
+  unfold goodModel; infer_instance
+
+theorem goodModel_spec (j₀ : Qbar) :
+    IntegralCoeffs (goodModel j₀) ∧ (goodModel j₀).Δ.orderTop = 0 := by
+  by_cases h0 : j₀ = 0
+  · subst h0; exact ⟨goodModel_zero_spec.1, goodModel_zero_spec.2.1⟩
+  · by_cases h1728 : j₀ = 1728
+    · subst h1728; exact ⟨goodModel_1728_spec.1, goodModel_1728_spec.2.1⟩
+    · exact ⟨(goodModel_generic_spec j₀ h0 h1728).1, (goodModel_generic_spec j₀ h0 h1728).2.1⟩
+
+private scoped instance isElliptic_specialFibre_goodModel (j₀ : Qbar) :
+    (specialFibre (goodModel j₀)).IsElliptic := by
+  by_cases h0 : j₀ = 0
+  · subst h0; obtain ⟨hE, -⟩ := goodModel_zero_spec.2.2; exact hE
+  · by_cases h1728 : j₀ = 1728
+    · subst h1728; obtain ⟨hE, -⟩ := goodModel_1728_spec.2.2; exact hE
+    · rw [(goodModel_generic_spec j₀ h0 h1728).2.2]; infer_instance
+
+private theorem exists_variableChange_specialFibre_goodModel (j₀ : Qbar) :
+    ∃ C : VariableChange Qbar, C • specialFibre (goodModel j₀) = WeierstrassCurve.ofJ j₀ := by
+  by_cases h0 : j₀ = 0
+  · subst h0
+    obtain ⟨hE, hj⟩ := goodModel_zero_spec.2.2
+    exact WeierstrassCurve.exists_variableChange_of_j_eq _ _
+      (hj.trans (WeierstrassCurve.ofJ_j (0 : Qbar)).symm)
+  · by_cases h1728 : j₀ = 1728
+    · subst h1728
+      obtain ⟨hE, hj⟩ := goodModel_1728_spec.2.2
+      exact WeierstrassCurve.exists_variableChange_of_j_eq _ _
+        (hj.trans (WeierstrassCurve.ofJ_j (1728 : Qbar)).symm)
+    · exact ⟨1, by rw [(goodModel_generic_spec j₀ h0 h1728).2.2, one_smul]⟩
+
+def fibreVC (j₀ : Qbar) : VariableChange Qbar :=
+  Classical.choose (exists_variableChange_specialFibre_goodModel j₀)
+
+theorem fibreVC_smul (j₀ : Qbar) :
+    fibreVC j₀ • specialFibre (goodModel j₀) = WeierstrassCurve.ofJ j₀ :=
+  Classical.choose_spec (exists_variableChange_specialFibre_goodModel j₀)
+
+def scaleAddEquiv (j₀ : Qbar) : (nearCurve j₀).toAffine.Point ≃+ (goodModel j₀).toAffine.Point :=
+  vcAddEquiv (scaleVC j₀) (nearCurve j₀)
+
+@[scoped simp] theorem scaleAddEquiv_apply (j₀ : Qbar) (P : (nearCurve j₀).toAffine.Point) :
+    scaleAddEquiv j₀ P =
+      WeierstrassCurve.Affine.Point.vcInvFun (scaleVC j₀) (nearCurve j₀).toAffine P := rfl
+
+def cycScale (p : ℕ) (j₀ : Qbar) : CycSubH (nearCurve j₀) p ≃ CycSubH (goodModel j₀) p :=
+  cycOfCongr (scaleAddEquiv j₀) p
+
+def fibreAddEquiv (j₀ : Qbar) :
+    (specialFibre (goodModel j₀)).toAffine.Point ≃+ (WeierstrassCurve.ofJ j₀).toAffine.Point :=
+  (vcAddEquiv (fibreVC j₀) (specialFibre (goodModel j₀))).trans (pointAddEquivOfEq (fibreVC_smul
+    j₀))
+
+theorem fibreAddEquiv_apply (j₀ : Qbar) (P : (specialFibre (goodModel j₀)).toAffine.Point) :
+    fibreAddEquiv j₀ P =
+      pointAddEquivOfEq (fibreVC_smul j₀)
+        (WeierstrassCurve.Affine.Point.vcInvFun (fibreVC j₀)
+          (specialFibre (goodModel j₀)).toAffine P) := rfl
+
+def redTorsionEquiv (W : WeierstrassCurve H) [W.IsElliptic] (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) [(specialFibre W).IsElliptic] (p : ℕ) [Fact p.Prime] :
+    Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ) ≃+
+      Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ) :=
+  Classical.choose (exists_torsionBy_reduction_addEquiv W hW hΔ p)
+
+theorem redTorsionEquiv_spec (W : WeierstrassCurve H) [W.IsElliptic] (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) [(specialFibre W).IsElliptic] (p : ℕ) [Fact p.Prime]
+    (P : Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ)) (x y : H)
+    (h : W.toAffine.Nonsingular x y)
+    (hP : (P : W.toAffine.Point) = WeierstrassCurve.Affine.Point.some x y h) :
+    ∃ h₀ : (specialFibre W).toAffine.Nonsingular (x.coeff 0) (y.coeff 0),
+      ((redTorsionEquiv W hW hΔ p P :
+            Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ)) :
+          (specialFibre W).toAffine.Point) =
+        WeierstrassCurve.Affine.Point.some (x.coeff 0) (y.coeff 0) h₀ :=
+  Classical.choose_spec (exists_torsionBy_reduction_addEquiv W hW hΔ p) P x y h hP
+
+def cycRed (W : WeierstrassCurve H) [W.IsElliptic] (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0)
+    [(specialFibre W).IsElliptic] (p : ℕ) [Fact p.Prime] :
+    CycSubH W p ≃ CycSub (specialFibre W) p :=
+  (cycOfTorsionBy W.toAffine.Point p).trans <|
+    (cycOfCongr (redTorsionEquiv W hW hΔ p) p).trans
+      (cycOfTorsionBy (specialFibre W).toAffine.Point p).symm
+
+def bridge3Specialise (p : ℕ) [Fact p.Prime] [NeZero p] (j₀ : Qbar) :
+    CycSubH (nearCurve j₀) p ≃ CycSub (WeierstrassCurve.ofJ j₀) p :=
+  (cycScale p j₀).trans <|
+    (cycRed (goodModel j₀) (goodModel_spec j₀).1 (goodModel_spec j₀).2 p).trans
+      (cycOfCongr (fibreAddEquiv j₀) p)
+
+theorem bridge3Specialise_apply_coe (p : ℕ) [Fact p.Prime] [NeZero p] (j₀ : Qbar)
+    (G : CycSubH (nearCurve j₀) p) :
+    (bridge3Specialise p j₀ G).1 =
+      ((((G.1.map (scaleAddEquiv j₀ :
+              (nearCurve j₀).toAffine.Point →+ (goodModel j₀).toAffine.Point)).comap
+            (Submodule.torsionBy ℤ (goodModel j₀).toAffine.Point (p :
+              ℤ)).subtype.toAddMonoidHom).map
+          (redTorsionEquiv (goodModel j₀) (goodModel_spec j₀).1 (goodModel_spec j₀).2 p :
+            Submodule.torsionBy ℤ (goodModel j₀).toAffine.Point (p : ℤ) →+
+              Submodule.torsionBy ℤ (specialFibre (goodModel j₀)).toAffine.Point (p : ℤ))).map
+        (Submodule.torsionBy ℤ (specialFibre (goodModel j₀)).toAffine.Point
+          (p : ℤ)).subtype.toAddMonoidHom).map
+        (fibreAddEquiv j₀ :
+          (specialFibre (goodModel j₀)).toAffine.Point →+ (WeierstrassCurve.ofJ j₀).toAffine.Point)
+            :=
+  rfl
+
+theorem bridge3Specialise_zmultiples (p : ℕ) [Fact p.Prime] [NeZero p] (j₀ : Qbar)
+    (g : (nearCurve j₀).toAffine.Point) (hg : addOrderOf g = p) :
+    (bridge3Specialise p j₀ ⟨AddSubgroup.zmultiples g, g, hg, rfl⟩).1 =
+      AddSubgroup.zmultiples
+        (fibreAddEquiv j₀
+          ((redTorsionEquiv (goodModel j₀) (goodModel_spec j₀).1 (goodModel_spec j₀).2 p
+              ⟨scaleAddEquiv j₀ g,
+                mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ g).trans hg)⟩ :
+              Submodule.torsionBy ℤ (specialFibre (goodModel j₀)).toAffine.Point (p : ℤ)) :
+            (specialFibre (goodModel j₀)).toAffine.Point)) := by
+  have hmem : scaleAddEquiv j₀ g ∈ Submodule.torsionBy ℤ (goodModel j₀).toAffine.Point (p : ℤ) :=
+    mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ g).trans hg)
+  rw [bridge3Specialise_apply_coe]
+  simp only [AddMonoidHom.map_zmultiples, AddMonoidHom.coe_ofClass, comap_subtype_zmultiples _ hmem,
+    LinearMap.toAddMonoidHom_coe, Submodule.subtype_apply]
+
+variable {K : Type*} [Field K]
+
+scoped instance isShortNF_a6Model (B : K) : (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve K).IsShortNF :=
+  ⟨rfl, rfl, rfl⟩
+
+scoped instance isShortNF_a4Model (A : K) : (⟨0, 0, 0, A, 0⟩ : WeierstrassCurve K).IsShortNF :=
+  ⟨rfl, rfl, rfl⟩
+
+theorem smul_a6Model_eq_iff [CharZero K] {B : K} (hB : B ≠ 0) (γ : VariableChange K) :
+    γ • (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve K) = ⟨0, 0, 0, 0, B⟩ ↔
+      γ.r = 0 ∧ γ.s = 0 ∧ γ.t = 0 ∧ (γ.u : K) ^ 6 = 1 :=
+  MulAction.mem_stabilizer_iff.symm.trans
+    (WeierstrassCurve.mem_stabilizer_variableChange_iff_of_isShortNF_of_a4_eq_zero
+      (by norm_num) (by norm_num) (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve K) rfl hB γ)
+
+theorem smul_a4Model_eq_iff [CharZero K] {A : K} (hA : A ≠ 0) (γ : VariableChange K) :
+    γ • (⟨0, 0, 0, A, 0⟩ : WeierstrassCurve K) = ⟨0, 0, 0, A, 0⟩ ↔
+      γ.r = 0 ∧ γ.s = 0 ∧ γ.t = 0 ∧ (γ.u : K) ^ 4 = 1 :=
+  MulAction.mem_stabilizer_iff.symm.trans
+    (WeierstrassCurve.mem_stabilizer_variableChange_iff_of_isShortNF_of_a6_eq_zero
+      (by norm_num) (by norm_num) (⟨0, 0, 0, A, 0⟩ : WeierstrassCurve K) rfl hA γ)
+
+theorem variableChange_eq_of_rst_eq_zero (γ : VariableChange K) (hr : γ.r = 0) (hs : γ.s = 0)
+    (ht : γ.t = 0) : γ = ⟨γ.u, 0, 0, 0⟩ :=
+  VariableChange.ext rfl hr hs ht
+
+def negVC (W : WeierstrassCurve K) : VariableChange K := ⟨-1, 0, -W.a₁, -W.a₃⟩
+
+@[scoped simp] theorem negVC_u (W : WeierstrassCurve K) : (negVC W).u = -1 := rfl
+@[scoped simp] theorem negVC_r (W : WeierstrassCurve K) : (negVC W).r = 0 := rfl
+@[scoped simp] theorem negVC_s (W : WeierstrassCurve K) : (negVC W).s = -W.a₁ := rfl
+@[scoped simp] theorem negVC_t (W : WeierstrassCurve K) : (negVC W).t = -W.a₃ := rfl
+
+theorem val_inv_negVC_u (W : WeierstrassCurve K) : (((negVC W).u⁻¹ : Kˣ) : K) = -1 := by
+  rw [negVC_u, Units.val_inv_eq_inv_val, Units.val_neg, Units.val_one, inv_neg, inv_one]
+
+theorem negVC_smul (W : WeierstrassCurve K) : negVC W • W = W := by
+  ext
+  · simp only [variableChange_a₁, val_inv_negVC_u, negVC_s]; ring
+  · simp only [variableChange_a₂, val_inv_negVC_u, negVC_r, negVC_s]; ring
+  · simp only [variableChange_a₃, val_inv_negVC_u, negVC_r, negVC_t]; ring
+  · simp only [variableChange_a₄, val_inv_negVC_u, negVC_r, negVC_s, negVC_t]; ring
+  · simp only [variableChange_a₆, val_inv_negVC_u, negVC_r, negVC_t]; ring
+
+theorem negVC_mul_negVC (W : WeierstrassCurve K) : negVC W * negVC W = 1 := by
+  refine VariableChange.ext ?_ ?_ ?_ ?_
+  · simp [VariableChange.mul_def, VariableChange.one_def]
+  · simp only [VariableChange.mul_def, VariableChange.one_def, negVC, Units.val_neg,
+      Units.val_one]; ring
+  · simp only [VariableChange.mul_def, VariableChange.one_def, negVC, Units.val_neg,
+      Units.val_one]; ring
+  · simp only [VariableChange.mul_def, VariableChange.one_def, negVC, Units.val_neg,
+      Units.val_one]; ring
+
+theorem negVC_ne_one [CharZero K] (W : WeierstrassCurve K) : negVC W ≠ 1 := fun h => by
+  have h1 : ((negVC W).u : K) = ((1 : VariableChange K).u : K) := by rw [h]
+  simp only [negVC_u, VariableChange.one_def, Units.val_neg, Units.val_one] at h1
+  norm_num at h1
+
+theorem ofJNe0Or1728_c₆ (j : K) :
+    (WeierstrassCurve.ofJNe0Or1728 j).c₆ = -j * (j - 1728) ^ 5 := by
+  simp only [WeierstrassCurve.ofJNe0Or1728, WeierstrassCurve.c₆, WeierstrassCurve.b₂,
+    WeierstrassCurve.b₄, WeierstrassCurve.b₆]
+  ring1
+
+theorem smul_ofJNe0Or1728_eq_iff [CharZero K] (j : K) (h0 : j ≠ 0) (h1728 : j ≠ 1728)
+    (γ : VariableChange K) :
+    γ • WeierstrassCurve.ofJNe0Or1728 j = WeierstrassCurve.ofJNe0Or1728 j ↔
+      γ = 1 ∨ γ = negVC (WeierstrassCurve.ofJNe0Or1728 j) := by
+  refine ⟨fun hγ => ?_, ?_⟩
+  swap
+  · rintro (rfl | rfl)
+    · exact one_smul _ _
+    · exact negVC_smul _
+  have ha : j - 1728 ≠ 0 := sub_ne_zero.mpr h1728
+  have e₁ := congrArg WeierstrassCurve.a₁ hγ
+  have e₂ := congrArg WeierstrassCurve.a₂ hγ
+  have e₃ := congrArg WeierstrassCurve.a₃ hγ
+  simp only [variableChange_a₁, variableChange_a₂, variableChange_a₃,
+    WeierstrassCurve.ofJNe0Or1728] at e₁ e₂ e₃
+  have e₄ := WeierstrassCurve.variableChange_c₄ (W := WeierstrassCurve.ofJNe0Or1728 j) (C := γ)
+  rw [hγ, WeierstrassCurve.ofJNe0Or1728_c₄] at e₄
+  have e₆ := WeierstrassCurve.variableChange_c₆ (W := WeierstrassCurve.ofJNe0Or1728 j) (C := γ)
+  rw [hγ, ofJNe0Or1728_c₆] at e₆
+  have hv4 : ((γ.u⁻¹ : Kˣ) : K) ^ 4 = 1 :=
+    mul_right_cancel₀ (mul_ne_zero h0 (pow_ne_zero 3 ha)) (by rw [one_mul]; exact e₄.symm)
+  have hv6 : ((γ.u⁻¹ : Kˣ) : K) ^ 6 = 1 :=
+    mul_right_cancel₀ (mul_ne_zero (neg_ne_zero.mpr h0) (pow_ne_zero 5 ha))
+      (by rw [one_mul]; exact e₆.symm)
+  have hv2 : ((γ.u⁻¹ : Kˣ) : K) ^ 2 = 1 := by
+    have h := hv6
+    rwa [show ((γ.u⁻¹ : Kˣ) : K) ^ 6 = ((γ.u⁻¹ : Kˣ) : K) ^ 4 * ((γ.u⁻¹ : Kˣ) : K) ^ 2 by ring,
+      hv4, one_mul] at h
+  rcases mul_self_eq_one_iff.mp ((pow_two _).symm.trans hv2) with hv | hv
+  · rw [hv] at e₁ e₂ e₃
+    have hs : γ.s = 0 := by linear_combination e₁ / 2
+    rw [hs] at e₂
+    have hr : γ.r = 0 := by linear_combination e₂ / 3
+    rw [hr] at e₃
+    have ht : γ.t = 0 := by linear_combination e₃ / 2
+    have hu : γ.u = 1 := by rwa [Units.val_eq_one, inv_eq_one] at hv
+    exact Or.inl (VariableChange.ext hu hr hs ht)
+  · rw [hv] at e₁ e₂ e₃
+    have hs : γ.s = -(j - 1728) := by linear_combination (-1 / 2 : K) * e₁
+    rw [hs] at e₂
+    have hr : γ.r = 0 := by linear_combination e₂ / 3
+    rw [hr] at e₃
+    have ht : γ.t = 0 := by linear_combination (-1 / 2 : K) * e₃
+    have hu : γ.u = -1 := by
+      refine Units.ext ?_
+      rw [Units.val_inv_eq_inv_val] at hv
+      rw [Units.val_neg, Units.val_one, ← inv_inv (γ.u : K), hv, inv_neg, inv_one]
+    exact Or.inr (VariableChange.ext hu hr hs (ht.trans neg_zero.symm))
+
+theorem smul_ofJ_eq_iff [DecidableEq K] [CharZero K] (j : K) (h0 : j ≠ 0) (h1728 : j ≠ 1728)
+    (γ : VariableChange K) :
+    γ • WeierstrassCurve.ofJ j = WeierstrassCurve.ofJ j ↔
+      γ = 1 ∨ γ = negVC (WeierstrassCurve.ofJ j) := by
+  rw [WeierstrassCurve.ofJ_ne_0_ne_1728 j h0 h1728]
+  exact smul_ofJNe0Or1728_eq_iff j h0 h1728 γ
+
+section Points
+
+theorem heq_point_zero {W V : WeierstrassCurve.Affine K} (hWV : W = V) :
+    HEq (0 : W.Point) (0 : V.Point) := by
+  subst hWV; rfl
+
+theorem heq_point_some {W V : WeierstrassCurve.Affine K} (hWV : W = V) {x y x' y' : K}
+    (hx : x = x') (hy : y = y') {h : W.Nonsingular x y} {h' : V.Nonsingular x' y'} :
+    HEq (WeierstrassCurve.Affine.Point.some x y h)
+      (WeierstrassCurve.Affine.Point.some x' y' h') := by
+  subst hWV hx hy; rfl
+
+theorem heq_vcInvFun_one (W : WeierstrassCurve K) (P : W.toAffine.Point) :
+    HEq (WeierstrassCurve.Affine.Point.vcInvFun (1 : VariableChange K) W.toAffine P) P := by
+  rcases P with _ | ⟨x, y, h⟩
+  · exact heq_point_zero (one_smul _ _)
+  · refine heq_point_some (one_smul _ _) ?_ ?_
+    · simp [WeierstrassCurve.Affine.vcXInv, VariableChange.one_def]
+    · simp [WeierstrassCurve.Affine.vcYInv, VariableChange.one_def]
+
+theorem heq_vcInvFun_negVC (W : WeierstrassCurve K) (P : W.toAffine.Point) :
+    HEq (WeierstrassCurve.Affine.Point.vcInvFun (negVC W) W.toAffine P) (-P) := by
+  rcases P with _ | ⟨x, y, h⟩
+  · exact heq_point_zero (negVC_smul W)
+  · refine heq_point_some (negVC_smul W) ?_ ?_
+    · simp only [WeierstrassCurve.Affine.vcXInv, val_inv_negVC_u, negVC_r]; ring
+    · simp only [WeierstrassCurve.Affine.vcYInv, val_inv_negVC_u, negVC_r, negVC_s, negVC_t,
+        WeierstrassCurve.Affine.negY]; ring
+
+theorem heq_vcInvFun_mul (γ δ : VariableChange K) (W : WeierstrassCurve K)
+    (P : W.toAffine.Point) :
+    HEq (WeierstrassCurve.Affine.Point.vcInvFun (γ * δ) W.toAffine P)
+      (WeierstrassCurve.Affine.Point.vcInvFun γ (δ • W).toAffine
+        (WeierstrassCurve.Affine.Point.vcInvFun δ W.toAffine P)) := by
+  have hu : (γ.u : K) ≠ 0 := γ.u.ne_zero
+  have hv : (δ.u : K) ≠ 0 := δ.u.ne_zero
+  rcases P with _ | ⟨x, y, h⟩
+  · exact heq_point_zero (mul_smul γ δ W)
+  · refine heq_point_some (mul_smul γ δ W) ?_ ?_
+    · simp only [WeierstrassCurve.Affine.vcXInv, VariableChange.mul_def, mul_inv_rev,
+        Units.val_mul, Units.val_inv_eq_inv_val]
+      field_simp
+      ring
+    · simp only [WeierstrassCurve.Affine.vcXInv, WeierstrassCurve.Affine.vcYInv,
+        VariableChange.mul_def, mul_inv_rev, Units.val_mul, Units.val_inv_eq_inv_val]
+      field_simp
+      ring
+
+theorem heq_vcInvFun_congr (γ : VariableChange K) {W W' : WeierstrassCurve.Affine K}
+    (hW : W = W') {P : W.Point} {P' : W'.Point} (hP : HEq P P') :
+    HEq (WeierstrassCurve.Affine.Point.vcInvFun γ W P)
+      (WeierstrassCurve.Affine.Point.vcInvFun γ W' P') := by
+  subst hW
+  obtain rfl := eq_of_heq hP
+  rfl
+
+theorem zmultiples_eq_of_heq_vcInvFun [DecidableEq K] [CharZero K] {j : K} (h0 : j ≠ 0)
+    (h1728 : j ≠ 1728)
+    {γ : VariableChange K} (hγ : γ • WeierstrassCurve.ofJ j = WeierstrassCurve.ofJ j)
+    {g g' : (WeierstrassCurve.ofJ j).toAffine.Point}
+    (h : HEq g' (WeierstrassCurve.Affine.Point.vcInvFun γ (WeierstrassCurve.ofJ j).toAffine g)) :
+    AddSubgroup.zmultiples g' = AddSubgroup.zmultiples g := by
+  rcases (smul_ofJ_eq_iff j h0 h1728 γ).mp hγ with rfl | rfl
+  · rw [eq_of_heq (h.trans (heq_vcInvFun_one _ g))]
+  · rw [eq_of_heq (h.trans (heq_vcInvFun_negVC _ g)), AddSubgroup.zmultiples_neg]
+
+theorem conj_smul_eq {F E : WeierstrassCurve K} {φ γ : VariableChange K} (hφ : φ • F = E)
+    (hγ : γ • E = E) : (φ⁻¹ * γ * φ) • F = F := by
+  rw [mul_smul, mul_smul, hφ, hγ, ← hφ, inv_smul_smul]
+
+def vcEquivOfSMulEq [DecidableEq K] {F E : WeierstrassCurve K} (φ : VariableChange K)
+    (hφ : φ • F = E) :
+    F.toAffine.Point ≃+ E.toAffine.Point :=
+  (vcAddEquiv φ F).trans (pointAddEquivOfEq hφ)
+
+theorem heq_pointAddEquivOfEq [DecidableEq K] {W V : WeierstrassCurve K} (h : W = V)
+    (P : W.toAffine.Point) :
+    HEq (pointAddEquivOfEq h P) P := by
+  subst h; rfl
+
+theorem heq_vcEquivOfSMulEq [DecidableEq K] {F E : WeierstrassCurve K} (φ : VariableChange K)
+    (hφ : φ • F = E) (P : F.toAffine.Point) :
+    HEq (vcEquivOfSMulEq φ hφ P) (WeierstrassCurve.Affine.Point.vcInvFun φ F.toAffine P) := by
+  subst hφ; rfl
+
+theorem heq_vcInvFun_iff_eq [DecidableEq K] {W : WeierstrassCurve K} (γ : VariableChange K)
+    (hγ : γ • W = W) (g g' : W.toAffine.Point) :
+    HEq g' (WeierstrassCurve.Affine.Point.vcInvFun γ W.toAffine g) ↔
+      g' = vcEquivOfSMulEq γ hγ g :=
+  ⟨fun h => eq_of_heq (h.trans (heq_vcEquivOfSMulEq γ hγ g).symm),
+    fun h => h ▸ heq_vcEquivOfSMulEq γ hγ g⟩
+
+theorem vcEquivOfSMulEq_conj [DecidableEq K] {F E : WeierstrassCurve K} {φ γ : VariableChange K}
+    (hφ : φ • F = E) (hγ : γ • E = E) (P : F.toAffine.Point) :
+    vcEquivOfSMulEq φ hφ (vcEquivOfSMulEq (φ⁻¹ * γ * φ) (conj_smul_eq hφ hγ) P) =
+      vcEquivOfSMulEq γ hγ (vcEquivOfSMulEq φ hφ P) := by
+  apply eq_of_heq
+  have hL₁ := heq_vcEquivOfSMulEq φ hφ (vcEquivOfSMulEq (φ⁻¹ * γ * φ) (conj_smul_eq hφ hγ) P)
+  have hL₂ : HEq (WeierstrassCurve.Affine.Point.vcInvFun φ F.toAffine
+      (vcEquivOfSMulEq (φ⁻¹ * γ * φ) (conj_smul_eq hφ hγ) P))
+      (WeierstrassCurve.Affine.Point.vcInvFun φ ((φ⁻¹ * γ * φ) • F).toAffine
+        (WeierstrassCurve.Affine.Point.vcInvFun (φ⁻¹ * γ * φ) F.toAffine P)) :=
+    heq_vcInvFun_congr φ (congrArg WeierstrassCurve.toAffine (conj_smul_eq hφ hγ).symm)
+      (heq_vcEquivOfSMulEq _ _ P)
+  have hL₃ := (heq_vcInvFun_mul φ (φ⁻¹ * γ * φ) F P).symm
+  have hmul : φ * (φ⁻¹ * γ * φ) = γ * φ := by rw [mul_assoc, mul_inv_cancel_left]
+  have hL₄ : HEq (WeierstrassCurve.Affine.Point.vcInvFun (φ * (φ⁻¹ * γ * φ)) F.toAffine P)
+      (WeierstrassCurve.Affine.Point.vcInvFun (γ * φ) F.toAffine P) := by
+    rw [hmul]
+  have hL₅ := heq_vcInvFun_mul γ φ F P
+  have hR₁ := heq_vcEquivOfSMulEq γ hγ (vcEquivOfSMulEq φ hφ P)
+  have hR₂ : HEq (WeierstrassCurve.Affine.Point.vcInvFun γ E.toAffine (vcEquivOfSMulEq φ hφ P))
+      (WeierstrassCurve.Affine.Point.vcInvFun γ (φ • F).toAffine
+        (WeierstrassCurve.Affine.Point.vcInvFun φ F.toAffine P)) :=
+    heq_vcInvFun_congr γ (congrArg WeierstrassCurve.toAffine hφ.symm) (heq_vcEquivOfSMulEq _ _ P)
+  exact ((((hL₁.trans hL₂).trans hL₃).trans hL₄).trans hL₅).trans (hR₁.trans hR₂).symm
+
+theorem conj_smul_eq' {F E : WeierstrassCurve K} {φ γ' : VariableChange K} (hφ : φ • F = E)
+    (hγ' : γ' • F = F) : (φ * γ' * φ⁻¹) • E = E := by
+  rw [mul_smul, mul_smul, inv_smul_eq_iff.mpr hφ.symm, hγ', hφ]
+
+theorem vcEquivOfSMulEq_congr [DecidableEq K] {F E : WeierstrassCurve K} {φ φ' : VariableChange K}
+    (e : φ = φ') (hφ : φ • F = E) (hφ' : φ' • F = E) :
+    vcEquivOfSMulEq φ hφ = vcEquivOfSMulEq φ' hφ' := by
+  subst e; rfl
+
+theorem eq_conj_of_heq_vcInvFun [DecidableEq K] {F E : WeierstrassCurve K} {φ γ : VariableChange K}
+    (hφ : φ • F = E) (hγ : γ • E = E) (P : F.toAffine.Point) {Q' : E.toAffine.Point}
+    (h : HEq Q' (WeierstrassCurve.Affine.Point.vcInvFun γ E.toAffine (vcEquivOfSMulEq φ hφ P))) :
+    Q' = vcEquivOfSMulEq φ hφ (vcEquivOfSMulEq (φ⁻¹ * γ * φ) (conj_smul_eq hφ hγ) P) := by
+  rw [(heq_vcInvFun_iff_eq γ hγ _ Q').mp h, vcEquivOfSMulEq_conj hφ hγ P]
+
+end Points
+
+theorem sameOrbit_iff (E₀ : WeierstrassCurve Qbar) (H H' : AddSubgroup E₀.toAffine.Point) :
+    SameOrbit E₀ H H' ↔
+      ∃ γ : VariableChange Qbar, ∃ _ : γ • E₀ = E₀, ∃ g g' : E₀.toAffine.Point,
+        H = AddSubgroup.zmultiples g ∧ H' = AddSubgroup.zmultiples g' ∧
+          HEq g' (WeierstrassCurve.Affine.Point.vcInvFun γ E₀.toAffine g) :=
+  Iff.rfl
+
+theorem sameOrbit_refl (E₀ : WeierstrassCurve Qbar) (g : E₀.toAffine.Point) :
+    SameOrbit E₀ (AddSubgroup.zmultiples g) (AddSubgroup.zmultiples g) :=
+  ⟨1, one_smul _ _, g, g, rfl, rfl, (heq_vcInvFun_one E₀ g).symm⟩
+
+theorem sameOrbit_symm {E₀ : WeierstrassCurve Qbar} {H H' : AddSubgroup E₀.toAffine.Point}
+    (h : SameOrbit E₀ H H') : SameOrbit E₀ H' H := by
+  obtain ⟨γ, hγ, g, g', hH, hH', hg⟩ := h
+  refine ⟨γ⁻¹, inv_smul_eq_iff.mpr hγ.symm, g', g, hH', hH, ?_⟩
+  have h₁ : HEq (WeierstrassCurve.Affine.Point.vcInvFun γ⁻¹ E₀.toAffine g')
+      (WeierstrassCurve.Affine.Point.vcInvFun γ⁻¹ (γ • E₀).toAffine
+        (WeierstrassCurve.Affine.Point.vcInvFun γ E₀.toAffine g)) :=
+    heq_vcInvFun_congr γ⁻¹ (congrArg WeierstrassCurve.toAffine hγ.symm) hg
+  have h₂ := (heq_vcInvFun_mul γ⁻¹ γ E₀ g).symm
+  have h₃ : HEq (WeierstrassCurve.Affine.Point.vcInvFun (γ⁻¹ * γ) E₀.toAffine g)
+      (WeierstrassCurve.Affine.Point.vcInvFun (1 : VariableChange Qbar) E₀.toAffine g) := by
+    rw [inv_mul_cancel]
+  exact (((h₁.trans h₂).trans h₃).trans (heq_vcInvFun_one E₀ g)).symm
+
+theorem sameOrbit_ofJ_iff_of_ne (j₀ : Qbar) (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728)
+    (H H' : AddSubgroup (WeierstrassCurve.ofJ j₀).toAffine.Point) :
+    SameOrbit (WeierstrassCurve.ofJ j₀) H H' ↔ H = H' ∧ ∃ g, H = AddSubgroup.zmultiples g := by
+  constructor
+  · rintro ⟨γ, hγ, g, g', rfl, rfl, hg⟩
+    exact ⟨(zmultiples_eq_of_heq_vcInvFun h0 h1728 hγ hg).symm, g, rfl⟩
+  · rintro ⟨rfl, g, rfl⟩
+    exact sameOrbit_refl _ g
+
+theorem sameOrbit_of_conj {F E : WeierstrassCurve Qbar} {φ γ' : VariableChange Qbar}
+    (hφ : φ • F = E) (hγ' : γ' • F = F) (P : F.toAffine.Point) :
+    SameOrbit E (AddSubgroup.zmultiples (vcEquivOfSMulEq φ hφ P))
+      (AddSubgroup.zmultiples (vcEquivOfSMulEq φ hφ (vcEquivOfSMulEq γ' hγ' P))) := by
+  refine ⟨φ * γ' * φ⁻¹, conj_smul_eq' hφ hγ', _, _, rfl, rfl, ?_⟩
+  rw [heq_vcInvFun_iff_eq (φ * γ' * φ⁻¹) (conj_smul_eq' hφ hγ'),
+    ← vcEquivOfSMulEq_conj hφ (conj_smul_eq' hφ hγ') P,
+    vcEquivOfSMulEq_congr (show φ⁻¹ * (φ * γ' * φ⁻¹) * φ = γ' by group)
+      (conj_smul_eq hφ (conj_smul_eq' hφ hγ')) hγ']
+
+section H6B
+
+open WeierstrassCurve.Affine
+
+theorem some_point_ext' {K : Type*} [Field K] {V : WeierstrassCurve.Affine K} {x y x' y' : K}
+    {h : V.Nonsingular x y} {h' : V.Nonsingular x' y'} (hx : x = x') (hy : y = y') :
+    WeierstrassCurve.Affine.Point.some x y h = WeierstrassCurve.Affine.Point.some x' y' h' := by
+  subst hx; subst hy; rfl
+
+theorem pointAddEquivOfEq_apply_of_eq_some {K : Type*} [Field K] [DecidableEq K]
+    {W V : WeierstrassCurve K} (hWV : W = V) {P : W.toAffine.Point} {x y : K}
+    {h : W.toAffine.Nonsingular x y} (hP : P = WeierstrassCurve.Affine.Point.some x y h) :
+    pointAddEquivOfEq hWV P = WeierstrassCurve.Affine.Point.some x y (hWV ▸ h) := by
+  subst hWV
+  rw [pointAddEquivOfEq_rfl, hP]
+  rfl
+
+theorem coeff_zero_of_mem_monodromy {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    (x : H) : (m x).coeff 0 = x.coeff 0 := by
+  obtain ⟨χ, hχ, rfl⟩ := hm
+  rw [HahnSeries.hahnTwistHom_apply, HahnSeries.coeff_hahnTwist, ofAdd_zero, map_one,
+    Units.val_one, one_mul]
+
+theorem orderTop_of_mem_monodromy {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    (x : H) : (m x).orderTop = x.orderTop := by
+  obtain ⟨χ, hχ, rfl⟩ := hm
+  rcases eq_or_ne x 0 with rfl | hx
+  · rw [map_zero]
+  · have hmx : (HahnSeries.hahnTwistHom χ) x ≠ 0 := fun h0 =>
+      hx ((HahnSeries.hahnTwistHom χ).injective (h0.trans (map_zero _).symm))
+    rw [← HahnSeries.order_eq_orderTop_of_ne_zero hx,
+      ← HahnSeries.order_eq_orderTop_of_ne_zero hmx, HahnSeries.hahnTwistHom_apply,
+      HahnSeries.order_hahnTwist]
+
+theorem monodromy_fixes_natSupport {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    (x : H) (hx : ∀ a : ℚ, x.coeff a ≠ 0 → ∃ n : ℕ, a = (n : ℚ)) : m x = x := by
+  obtain ⟨χ, hχ, rfl⟩ := hm
+  rw [HahnSeries.hahnTwistHom_apply]
+  ext a
+  rw [HahnSeries.coeff_hahnTwist]
+  rcases eq_or_ne (x.coeff a) 0 with h0 | h0
+  · rw [h0, mul_zero]
+  · obtain ⟨n, rfl⟩ := hx a h0
+    have hofAdd : Multiplicative.ofAdd ((n : ℚ)) = Multiplicative.ofAdd ((1 : ℚ)) ^ n := by
+      rw [← ofAdd_nsmul, nsmul_eq_mul, mul_one]
+    have hn : χ (Multiplicative.ofAdd ((n : ℚ))) = 1 := by
+      rw [hofAdd, map_pow, HahnSeries.mem_monoChar_iff.mp hχ, one_pow]
+    rw [hn, Units.val_one, one_mul]
+
+theorem monodromy_fixes_ofPowerSeries {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    (f : PowerSeries Qbar) : m (ι f) = ι f := by
+  refine monodromy_fixes_natSupport hm _ fun a ha => ?_
+  by_contra hn
+  rw [not_exists] at hn
+  refine ha ?_
+  rw [HahnSeries.ofPowerSeries_apply]
+  exact HahnSeries.embDomain_of_notMem_range fun hmem => by
+    obtain ⟨n, hna⟩ := hmem
+    exact hn n hna.symm
+
+theorem monodromy_fixes_C (m : H ≃ₐ[Qbar] H) (q : Qbar) :
+    m (HahnSeries.C q) = HahnSeries.C q := by
+  have hC : algebraMap Qbar H q = HahnSeries.C q := by
+    rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_eq, HahnSeries.ofPowerSeries_C]
+  rw [← hC]
+  exact m.commutes q
+
+theorem zeta_pow_eq_one_of_twist {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    {q : ℚ} {ζ : Qbar} {n k : ℕ} (hζs : m (HahnSeries.single q 1) = HahnSeries.single q ζ)
+    (hq : n • q = ((k : ℕ) : ℚ)) : ζ ^ n = 1 := by
+  have hfix : m (HahnSeries.single ((k : ℕ) : ℚ) 1) = HahnSeries.single ((k : ℕ) : ℚ) 1 :=
+    monodromy_fixes_natSupport hm _ fun a ha => ⟨k, by
+      by_contra hne
+      exact ha (HahnSeries.coeff_single_of_ne hne)⟩
+  have key : HahnSeries.single ((k : ℕ) : ℚ) (ζ ^ n) = HahnSeries.single ((k : ℕ) : ℚ) 1 := by
+    calc HahnSeries.single ((k : ℕ) : ℚ) (ζ ^ n)
+        = (HahnSeries.single q ζ) ^ n := by rw [HahnSeries.single_pow, hq]
+      _ = (m (HahnSeries.single q 1)) ^ n := by rw [hζs]
+      _ = m (HahnSeries.single q 1 ^ n) := (map_pow m _ n).symm
+      _ = m (HahnSeries.single ((k : ℕ) : ℚ) 1) := by rw [HahnSeries.single_pow, hq, one_pow]
+      _ = HahnSeries.single ((k : ℕ) : ℚ) 1 := hfix
+  have hcoeff := congrArg (fun z : H => z.coeff ((k : ℕ) : ℚ)) key
+  simpa [HahnSeries.coeff_single_same] using hcoeff
+
+theorem zeta_ne_zero_of_pow_eq_one {ζ : Qbar} {n : ℕ} (hn : n ≠ 0) (h : ζ ^ n = 1) : ζ ≠ 0 := by
+  rintro rfl
+  rw [zero_pow hn] at h
+  exact zero_ne_one h
+
+theorem C_pow_mul_single (c : Qbar) (n : ℕ) (q : ℚ) :
+    HahnSeries.C c ^ n * HahnSeries.single q (1 : Qbar) = HahnSeries.single q (c ^ n) := by
+  rw [show (HahnSeries.C c : H) = HahnSeries.single 0 c from rfl, HahnSeries.single_pow,
+    HahnSeries.single_mul_single, smul_zero, zero_add, mul_one]
+
+theorem single_two_twelfths :
+    HahnSeries.single (2 / 12 : ℚ) (1 : Qbar) = HahnSeries.single (1 / 6 : ℚ) 1 := by
+  rw [show (2 / 12 : ℚ) = 1 / 6 by norm_num]
+
+theorem m_single_sixth {m : H ≃ₐ[Qbar] H} {ζ : Qbar}
+    (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ) :
+    m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.C ζ * HahnSeries.single (1 / 6 : ℚ) 1 := by
+  rw [hζs, show (HahnSeries.C ζ : H) * HahnSeries.single (1 / 6 : ℚ) 1 =
+    HahnSeries.single (1 / 6 : ℚ) (ζ ^ 1) from by
+      rw [← C_pow_mul_single ζ 1 (1 / 6 : ℚ), pow_one], pow_one]
+
+theorem m_single_third {m : H ≃ₐ[Qbar] H} {ζ : Qbar}
+    (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ) :
+    m (HahnSeries.single (1 / 3 : ℚ) 1) =
+      HahnSeries.C ζ ^ 2 * HahnSeries.single (1 / 3 : ℚ) 1 := by
+  have h13 : HahnSeries.single (1 / 3 : ℚ) (1 : Qbar) =
+      HahnSeries.single (1 / 6 : ℚ) 1 * HahnSeries.single (1 / 6 : ℚ) 1 := by
+    rw [HahnSeries.single_mul_single, mul_one]
+    congr 1
+    norm_num
+  rw [C_pow_mul_single, h13, map_mul, hζs, HahnSeries.single_mul_single]
+  congr 1
+  · norm_num
+  · ring
+
+theorem m_single_quarter_1728 {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    {ζ : Qbar} (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ) :
+    m (HahnSeries.single (1 / 4 : ℚ) 1) =
+      HahnSeries.C ζ ^ 3 * HahnSeries.single (1 / 4 : ℚ) 1 := by
+  obtain ⟨χ, hχ, rfl⟩ := hm
+  rw [HahnSeries.hahnTwistHom_apply] at hζs ⊢
+  rw [HahnSeries.hahnTwist_single] at hζs ⊢
+  have hval : (χ (Multiplicative.ofAdd (3 / 4 : ℚ)) : Qbar) = ζ := by
+    have hcoeff := congrArg (fun z : H => z.coeff (3 / 4 : ℚ)) hζs
+    simpa [HahnSeries.coeff_single_same] using hcoeff
+  have hc4 : (χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar) ^ 4 = 1 := by
+    have h14 : (4 : ℕ) • (1 / 4 : ℚ) = (1 : ℚ) := by norm_num
+    have h := HahnSeries.mem_monoChar_iff.mp hχ
+    rw [← h14, ofAdd_nsmul, map_pow] at h
+    calc (χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar) ^ 4
+        = ((χ (Multiplicative.ofAdd (1 / 4 : ℚ)) ^ 4 : Qbarˣ) : Qbar) :=
+          (Units.val_pow_eq_pow_val _ _).symm
+      _ = ((1 : Qbarˣ) : Qbar) := by rw [h]
+      _ = 1 := Units.val_one
+  have hc3 : (χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar) ^ 3 = ζ := by
+    have h34 : (3 : ℕ) • (1 / 4 : ℚ) = (3 / 4 : ℚ) := by norm_num
+    rw [← hval, ← h34, ofAdd_nsmul, map_pow]
+    exact (Units.val_pow_eq_pow_val _ _).symm
+  have hc : (χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar) = ζ ^ 3 := by
+    calc (χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar)
+        = ((χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar) ^ 4) ^ 2 *
+            (χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar) := by rw [hc4]; ring
+      _ = ((χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar) ^ 3) ^ 3 := by ring
+      _ = ζ ^ 3 := by rw [hc3]
+  rw [C_pow_mul_single, mul_one, hc]
+
+theorem m_single_half_1728 {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    {ζ : Qbar} (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ) :
+    m (HahnSeries.single (1 / 2 : ℚ) 1) =
+      HahnSeries.C ζ ^ 2 * HahnSeries.single (1 / 2 : ℚ) 1 := by
+  have hζ4 : ζ ^ 4 = 1 := zeta_pow_eq_one_of_twist (k := 3) hm hζs (by norm_num)
+  have h12 : HahnSeries.single (1 / 2 : ℚ) (1 : Qbar) =
+      HahnSeries.single (1 / 4 : ℚ) 1 * HahnSeries.single (1 / 4 : ℚ) 1 := by
+    rw [HahnSeries.single_mul_single, mul_one]
+    congr 1
+    norm_num
+  rw [C_pow_mul_single, h12, map_mul, m_single_quarter_1728 hm hζs, C_pow_mul_single,
+    HahnSeries.single_mul_single]
+  congr 1
+  · norm_num
+  · calc ζ ^ 3 * ζ ^ 3 = ζ ^ 4 * ζ ^ 2 := by ring
+      _ = ζ ^ 2 := by rw [hζ4, one_mul]
+
+theorem C_mul_single (c : Qbar) (q : ℚ) :
+    HahnSeries.C c * HahnSeries.single q (1 : Qbar) = HahnSeries.single q c := by
+  rw [show (HahnSeries.C c : H) = HahnSeries.single 0 c from rfl, HahnSeries.single_mul_single,
+    zero_add, mul_one]
+
+theorem coeff_zero_C (c : Qbar) : (HahnSeries.C c : H).coeff 0 = c := by
+  rw [show (HahnSeries.C c : H) = HahnSeries.single 0 c from rfl]
+  simp
+
+theorem m_a4_zero (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar) (ζ : Qbar)
+    (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ) :
+    m (goodModel 0).a₄ = HahnSeries.C ζ ^ 2 * (goodModel 0).a₄ := by
+  rw [goodModel_zero_eq]
+  change m (HahnSeries.single (1 / 3 : ℚ) 1 *
+      ι (PowerSeries.C (-1 / 48 : Qbar) * (PowerSeries.X - PowerSeries.C 1728) ^ 3)) =
+    HahnSeries.C ζ ^ 2 * (HahnSeries.single (1 / 3 : ℚ) 1 *
+      ι (PowerSeries.C (-1 / 48 : Qbar) * (PowerSeries.X - PowerSeries.C 1728) ^ 3))
+  rw [map_mul, m_single_third hζs, monodromy_fixes_ofPowerSeries hm]
+  ring
+
+theorem m_a6_zero (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar) :
+    m (goodModel 0).a₆ = (goodModel 0).a₆ := by
+  rw [goodModel_zero_eq]
+  change m (ι (PowerSeries.C (1 / 864 : Qbar) * (PowerSeries.X - PowerSeries.C 1728) ^ 5)) =
+    ι (PowerSeries.C (1 / 864 : Qbar) * (PowerSeries.X - PowerSeries.C 1728) ^ 5)
+  exact monodromy_fixes_ofPowerSeries hm _
+
+theorem m_a1_1728 (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar) (ζ : Qbar)
+    (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ) :
+    m (goodModel 1728).a₁ = HahnSeries.C ζ ^ 3 * (goodModel 1728).a₁ := by
+  rw [goodModel_1728_eq]
+  change m (HahnSeries.single (1 / 4 : ℚ) 1) = HahnSeries.C ζ ^ 3 * HahnSeries.single (1 / 4 : ℚ) 1
+  exact m_single_quarter_1728 hm hζs
+
+theorem m_a4_1728 (m : H ≃ₐ[Qbar] H) : m (goodModel 1728).a₄ = (goodModel 1728).a₄ := by
+  rw [goodModel_1728_eq]
+  change m (HahnSeries.C (-36)) = HahnSeries.C (-36)
+  exact monodromy_fixes_C m (-36)
+
+theorem m_a6_1728 (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar) (ζ : Qbar)
+    (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ) :
+    m (goodModel 1728).a₆ = HahnSeries.C ζ ^ 2 * (goodModel 1728).a₆ := by
+  rw [goodModel_1728_eq]
+  change m (-HahnSeries.single (1 / 2 : ℚ) 1) =
+    HahnSeries.C ζ ^ 2 * -HahnSeries.single (1 / 2 : ℚ) 1
+  rw [map_neg, m_single_half_1728 hm hζs]
+  ring
+
+theorem map_goodModel_zero (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar) (ζ : Qbar)
+    (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ) :
+    (goodModel 0).map (m : H →+* H) =
+      ⟨0, 0, 0, HahnSeries.C ζ ^ 2 * (goodModel 0).a₄, (goodModel 0).a₆⟩ := by
+  have ha1 : (goodModel 0).a₁ = 0 := by rw [goodModel_zero_eq]
+  have ha2 : (goodModel 0).a₂ = 0 := by rw [goodModel_zero_eq]
+  have ha3 : (goodModel 0).a₃ = 0 := by rw [goodModel_zero_eq]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_
+  · change m (goodModel 0).a₁ = 0
+    rw [ha1, map_zero]
+  · change m (goodModel 0).a₂ = 0
+    rw [ha2, map_zero]
+  · change m (goodModel 0).a₃ = 0
+    rw [ha3, map_zero]
+  · change m (goodModel 0).a₄ = HahnSeries.C ζ ^ 2 * (goodModel 0).a₄
+    exact m_a4_zero m hm ζ hζs
+  · change m (goodModel 0).a₆ = (goodModel 0).a₆
+    exact m_a6_zero m hm
+
+theorem map_goodModel_1728 (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar) (ζ : Qbar)
+    (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ) :
+    (goodModel 1728).map (m : H →+* H) =
+      ⟨HahnSeries.C ζ ^ 3 * (goodModel 1728).a₁, 0, 0, (goodModel 1728).a₄,
+        HahnSeries.C ζ ^ 2 * (goodModel 1728).a₆⟩ := by
+  have ha2 : (goodModel 1728).a₂ = 0 := by rw [goodModel_1728_eq]
+  have ha3 : (goodModel 1728).a₃ = 0 := by rw [goodModel_1728_eq]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_
+  · change m (goodModel 1728).a₁ = HahnSeries.C ζ ^ 3 * (goodModel 1728).a₁
+    exact m_a1_1728 m hm ζ hζs
+  · change m (goodModel 1728).a₂ = 0
+    rw [ha2, map_zero]
+  · change m (goodModel 1728).a₃ = 0
+    rw [ha3, map_zero]
+  · change m (goodModel 1728).a₄ = (goodModel 1728).a₄
+    exact m_a4_1728 m
+  · change m (goodModel 1728).a₆ = HahnSeries.C ζ ^ 2 * (goodModel 1728).a₆
+    exact m_a6_1728 m hm ζ hζs
+
+theorem nonsingular_fibreTwist_zero {ζ : Qbar} (hζ6 : ζ ^ 6 = 1) {x₀ y₀ : Qbar}
+    (h₀ : (specialFibre (goodModel 0)).toAffine.Nonsingular x₀ y₀) :
+    (specialFibre (goodModel 0)).toAffine.Nonsingular (ζ ^ 2 * x₀) (ζ ^ 3 * y₀) := by
+  have e1 : (specialFibre (goodModel 0)).a₁ = 0 := by rw [specialFibre_goodModel_zero]
+  have e2 : (specialFibre (goodModel 0)).a₂ = 0 := by rw [specialFibre_goodModel_zero]
+  have e3 : (specialFibre (goodModel 0)).a₃ = 0 := by rw [specialFibre_goodModel_zero]
+  have e4 : (specialFibre (goodModel 0)).a₄ = 0 := by rw [specialFibre_goodModel_zero]
+  rw [← WeierstrassCurve.Affine.equation_iff_nonsingular] at h₀ ⊢
+  rw [WeierstrassCurve.Affine.equation_iff] at h₀ ⊢
+  rw [e1, e2, e3, e4] at h₀ ⊢
+  linear_combination ζ ^ 6 * h₀ + (specialFibre (goodModel 0)).a₆ * hζ6
+
+theorem nonsingular_fibreTwist_1728 {ζ : Qbar} (hζ4 : ζ ^ 4 = 1) {x₀ y₀ : Qbar}
+    (h₀ : (specialFibre (goodModel 1728)).toAffine.Nonsingular x₀ y₀) :
+    (specialFibre (goodModel 1728)).toAffine.Nonsingular (ζ ^ 2 * x₀) (ζ ^ 3 * y₀) := by
+  have e1 : (specialFibre (goodModel 1728)).a₁ = 0 := by rw [specialFibre_goodModel_1728]
+  have e2 : (specialFibre (goodModel 1728)).a₂ = 0 := by rw [specialFibre_goodModel_1728]
+  have e3 : (specialFibre (goodModel 1728)).a₃ = 0 := by rw [specialFibre_goodModel_1728]
+  have e6 : (specialFibre (goodModel 1728)).a₆ = 0 := by rw [specialFibre_goodModel_1728]
+  rw [← WeierstrassCurve.Affine.equation_iff_nonsingular] at h₀ ⊢
+  rw [WeierstrassCurve.Affine.equation_iff] at h₀ ⊢
+  rw [e1, e2, e3, e6] at h₀ ⊢
+  linear_combination ζ ^ 2 * h₀ + ζ ^ 2 * (y₀ ^ 2 - x₀ ^ 3) * hζ4
+
+def fibreTwistVC (ζ : Qbar) (hζ0 : ζ ≠ 0) : VariableChange Qbar :=
+  ⟨(Units.mk0 ζ hζ0)⁻¹, 0, 0, 0⟩
+
+theorem fibreTwistVC_smul_fibre_zero {ζ : Qbar} (hζ0 : ζ ≠ 0) (hζ6 : ζ ^ 6 = 1) :
+    fibreTwistVC ζ hζ0 • specialFibre (goodModel 0) = specialFibre (goodModel 0) := by
+  rw [specialFibre_goodModel_zero, WeierstrassCurve.variableChange_def]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_ <;> simp [fibreTwistVC, hζ6]
+
+theorem fibreTwistVC_smul_fibre_1728 {ζ : Qbar} (hζ0 : ζ ≠ 0) (hζ4 : ζ ^ 4 = 1) :
+    fibreTwistVC ζ hζ0 • specialFibre (goodModel 1728) = specialFibre (goodModel 1728) := by
+  rw [specialFibre_goodModel_1728, WeierstrassCurve.variableChange_def]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_ <;> simp [fibreTwistVC, hζ4]
+
+theorem vcInvFun_eq_some {K : Type*} [Field K] {C : VariableChange K}
+    {W : WeierstrassCurve K} {x y : K} (h : W.toAffine.Nonsingular x y)
+    (h' : (C • W).toAffine.Nonsingular (WeierstrassCurve.Affine.vcXInv C x)
+      (WeierstrassCurve.Affine.vcYInv C x y)) :
+    WeierstrassCurve.Affine.Point.vcInvFun C W.toAffine
+        (WeierstrassCurve.Affine.Point.some x y h) =
+      WeierstrassCurve.Affine.Point.some (WeierstrassCurve.Affine.vcXInv C x)
+        (WeierstrassCurve.Affine.vcYInv C x y) h' := rfl
+
+theorem stab_equiv_some {K : Type*} [Field K] [DecidableEq K] {W : WeierstrassCurve K}
+    {φ : VariableChange K} (hφ : φ • W = W) {x y : K} (h : W.toAffine.Nonsingular x y)
+    {x' y' : K} (hx' : WeierstrassCurve.Affine.vcXInv φ x = x')
+    (hy' : WeierstrassCurve.Affine.vcYInv φ x y = y')
+    (h' : W.toAffine.Nonsingular x' y') :
+    ((vcAddEquiv φ W).trans (pointAddEquivOfEq hφ))
+        (WeierstrassCurve.Affine.Point.some x y h) =
+      WeierstrassCurve.Affine.Point.some x' y' h' := by
+  subst hx'
+  subst hy'
+  have hns : (φ • W).toAffine.Nonsingular (WeierstrassCurve.Affine.vcXInv φ x)
+      (WeierstrassCurve.Affine.vcYInv φ x y) := by
+    rw [hφ]
+    exact h'
+  have h1 : ((vcAddEquiv φ W).trans (pointAddEquivOfEq hφ))
+      (WeierstrassCurve.Affine.Point.some x y h) =
+      pointAddEquivOfEq hφ (vcAddEquiv φ W (WeierstrassCurve.Affine.Point.some x y h)) := rfl
+  rw [h1, vcAddEquiv_apply, vcInvFun_eq_some h hns,
+    pointAddEquivOfEq_apply_of_eq_some hφ rfl]
+
+def fibreTwistEquiv_zero (ζ : Qbar) (hζ0 : ζ ≠ 0) (hζ6 : ζ ^ 6 = 1) :
+    (specialFibre (goodModel 0)).toAffine.Point ≃+
+      (specialFibre (goodModel 0)).toAffine.Point :=
+  (vcAddEquiv (fibreTwistVC ζ hζ0) (specialFibre (goodModel 0))).trans
+    (pointAddEquivOfEq (fibreTwistVC_smul_fibre_zero hζ0 hζ6))
+
+def fibreTwistEquiv_1728 (ζ : Qbar) (hζ0 : ζ ≠ 0) (hζ4 : ζ ^ 4 = 1) :
+    (specialFibre (goodModel 1728)).toAffine.Point ≃+
+      (specialFibre (goodModel 1728)).toAffine.Point :=
+  (vcAddEquiv (fibreTwistVC ζ hζ0) (specialFibre (goodModel 1728))).trans
+    (pointAddEquivOfEq (fibreTwistVC_smul_fibre_1728 hζ0 hζ4))
+
+theorem fibreTwistEquiv_zero_some (ζ : Qbar) (hζ0 : ζ ≠ 0) (hζ6 : ζ ^ 6 = 1) {x₀ y₀ : Qbar}
+    (h₀ : (specialFibre (goodModel 0)).toAffine.Nonsingular x₀ y₀) :
+    fibreTwistEquiv_zero ζ hζ0 hζ6 (WeierstrassCurve.Affine.Point.some x₀ y₀ h₀) =
+      WeierstrassCurve.Affine.Point.some (ζ ^ 2 * x₀) (ζ ^ 3 * y₀)
+        (nonsingular_fibreTwist_zero hζ6 h₀) := by
+  refine stab_equiv_some (fibreTwistVC_smul_fibre_zero hζ0 hζ6) h₀ ?_ ?_
+    (nonsingular_fibreTwist_zero hζ6 h₀)
+  · change (((fibreTwistVC ζ hζ0).u⁻¹ : Qbarˣ) : Qbar) ^ 2 * (x₀ - (fibreTwistVC ζ hζ0).r) =
+      ζ ^ 2 * x₀
+    simp [fibreTwistVC]
+  · change (((fibreTwistVC ζ hζ0).u⁻¹ : Qbarˣ) : Qbar) ^ 3 * (y₀ - (fibreTwistVC ζ hζ0).t -
+        (fibreTwistVC ζ hζ0).s * (x₀ - (fibreTwistVC ζ hζ0).r)) = ζ ^ 3 * y₀
+    simp [fibreTwistVC]
+
+theorem fibreTwistEquiv_1728_some (ζ : Qbar) (hζ0 : ζ ≠ 0) (hζ4 : ζ ^ 4 = 1) {x₀ y₀ : Qbar}
+    (h₀ : (specialFibre (goodModel 1728)).toAffine.Nonsingular x₀ y₀) :
+    fibreTwistEquiv_1728 ζ hζ0 hζ4 (WeierstrassCurve.Affine.Point.some x₀ y₀ h₀) =
+      WeierstrassCurve.Affine.Point.some (ζ ^ 2 * x₀) (ζ ^ 3 * y₀)
+        (nonsingular_fibreTwist_1728 hζ4 h₀) := by
+  refine stab_equiv_some (fibreTwistVC_smul_fibre_1728 hζ0 hζ4) h₀ ?_ ?_
+    (nonsingular_fibreTwist_1728 hζ4 h₀)
+  · change (((fibreTwistVC ζ hζ0).u⁻¹ : Qbarˣ) : Qbar) ^ 2 * (x₀ - (fibreTwistVC ζ hζ0).r) =
+      ζ ^ 2 * x₀
+    simp [fibreTwistVC]
+  · change (((fibreTwistVC ζ hζ0).u⁻¹ : Qbarˣ) : Qbar) ^ 3 * (y₀ - (fibreTwistVC ζ hζ0).t -
+        (fibreTwistVC ζ hζ0).s * (x₀ - (fibreTwistVC ζ hζ0).r)) = ζ ^ 3 * y₀
+    simp [fibreTwistVC]
+
+theorem nonsingular_conj_zero (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar)
+    (ζ : Qbar) (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ)
+    {x y : H} (h : (goodModel 0).toAffine.Nonsingular x y) :
+    (goodModel 0).toAffine.Nonsingular (HahnSeries.C ζ ^ 2 * m x)
+      (HahnSeries.C ζ ^ 3 * m y) := by
+  have hζ6 : ζ ^ 6 = 1 := zeta_pow_eq_one_of_twist (k := 1) hm hζs (by norm_num)
+  have hC6 : (HahnSeries.C ζ : H) ^ 6 = 1 := by
+    rw [← map_pow, hζ6, map_one]
+  have ha1 : (goodModel 0).a₁ = 0 := by rw [goodModel_zero_eq]
+  have ha2 : (goodModel 0).a₂ = 0 := by rw [goodModel_zero_eq]
+  have ha3 : (goodModel 0).a₃ = 0 := by rw [goodModel_zero_eq]
+  rw [← WeierstrassCurve.Affine.equation_iff_nonsingular] at h ⊢
+  rw [WeierstrassCurve.Affine.equation_iff] at h ⊢
+  rw [ha1, ha2, ha3] at h ⊢
+  have hme := congrArg m h
+  simp only [map_add, map_mul, map_pow, map_zero] at hme
+  rw [m_a4_zero m hm ζ hζs, m_a6_zero m hm] at hme
+  linear_combination HahnSeries.C ζ ^ 6 * hme +
+    (HahnSeries.C ζ ^ 2 * (goodModel 0).a₄ * m x + (goodModel 0).a₆) * hC6
+
+theorem nonsingular_conj_1728 (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar)
+    (ζ : Qbar) (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ)
+    {x y : H} (h : (goodModel 1728).toAffine.Nonsingular x y) :
+    (goodModel 1728).toAffine.Nonsingular (HahnSeries.C ζ ^ 2 * m x)
+      (HahnSeries.C ζ ^ 3 * m y) := by
+  have hζ4 : ζ ^ 4 = 1 := zeta_pow_eq_one_of_twist (k := 3) hm hζs (by norm_num)
+  have hC4 : (HahnSeries.C ζ : H) ^ 4 = 1 := by
+    rw [← map_pow, hζ4, map_one]
+  have ha2 : (goodModel 1728).a₂ = 0 := by rw [goodModel_1728_eq]
+  have ha3 : (goodModel 1728).a₃ = 0 := by rw [goodModel_1728_eq]
+  rw [← WeierstrassCurve.Affine.equation_iff_nonsingular] at h ⊢
+  rw [WeierstrassCurve.Affine.equation_iff] at h ⊢
+  rw [ha2, ha3] at h ⊢
+  have hme := congrArg m h
+  simp only [map_add, map_mul, map_pow, map_zero] at hme
+  rw [m_a1_1728 m hm ζ hζs, m_a4_1728 m, m_a6_1728 m hm ζ hζs] at hme
+  linear_combination HahnSeries.C ζ ^ 2 * hme +
+    (HahnSeries.C ζ ^ 2 * ((m y) ^ 2 - (m x) ^ 3) + (goodModel 1728).a₆) * hC4
+
+theorem nonsingular_cocycle_zero (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar)
+    {ζ : Qbar} (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ)
+    {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : (goodModel 0).toAffine.Nonsingular x y) :
+    (specialFibre (goodModel 0)).toAffine.Nonsingular (ζ ^ 2 * x.coeff 0)
+      (ζ ^ 3 * y.coeff 0) :=
+  nonsingular_fibreTwist_zero (zeta_pow_eq_one_of_twist (k := 1) hm hζs (by norm_num))
+    (nonsingular_specialFibre _ (goodModel_spec 0).1 (goodModel_spec 0).2 hx hy h)
+
+theorem nonsingular_cocycle_1728 (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar)
+    {ζ : Qbar} (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ)
+    {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : (goodModel 1728).toAffine.Nonsingular x y) :
+    (specialFibre (goodModel 1728)).toAffine.Nonsingular (ζ ^ 2 * x.coeff 0)
+      (ζ ^ 3 * y.coeff 0) :=
+  nonsingular_fibreTwist_1728 (zeta_pow_eq_one_of_twist (k := 3) hm hζs (by norm_num))
+    (nonsingular_specialFibre _ (goodModel_spec 1728).1 (goodModel_spec 1728).2 hx hy h)
+
+theorem fixedTransport_conj_zero (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar)
+    (ζ : Qbar) (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ)
+    (hE : (nearCurve 0).map (m : H →+* H) = nearCurve 0)
+    {x y : H} (h : (goodModel 0).toAffine.Nonsingular x y) :
+    scaleAddEquiv 0 (WeierstrassCurve.Affine.Point.fixedTransport m (nearCurve 0) hE
+        ((scaleAddEquiv 0).symm (WeierstrassCurve.Affine.Point.some x y h))) =
+      WeierstrassCurve.Affine.Point.some (HahnSeries.C ζ ^ 2 * m x)
+        (HahnSeries.C ζ ^ 3 * m y) (nonsingular_conj_zero m hm ζ hζs h) := by
+  have hA : m (jNear 0 - 1728) = jNear 0 - 1728 := by
+    rw [jNear_zero, map_sub, HahnSeries.fixes_single_one_of_mem_monodromy hm, map_ofNat]
+  have hmu : m (((scaleVC 0).u : Hˣ) : H) = HahnSeries.C ζ * (((scaleVC 0).u : Hˣ) : H) := by
+    rw [scaleVC_zero]
+    change m (HahnSeries.single (2 / 12 : ℚ) 1) = HahnSeries.C ζ * HahnSeries.single (2 / 12 : ℚ) 1
+    rw [single_two_twelfths]
+    exact m_single_sixth hζs
+  have hmr : m ((scaleVC 0).r) = (scaleVC 0).r := by
+    rw [scaleVC_zero]
+    change m (-(jNear 0 - 1728) ^ 2 / 12) = -(jNear 0 - 1728) ^ 2 / 12
+    rw [map_div₀, map_neg, map_pow, hA, map_ofNat]
+  have hms : m ((scaleVC 0).s) = (scaleVC 0).s := by
+    rw [scaleVC_zero]
+    change m (-(jNear 0 - 1728) / 2) = -(jNear 0 - 1728) / 2
+    rw [map_div₀, map_neg, hA, map_ofNat]
+  have hmt : m ((scaleVC 0).t) = (scaleVC 0).t := by
+    rw [scaleVC_zero]
+    change m ((jNear 0 - 1728) ^ 3 / 24) = (jNear 0 - 1728) ^ 3 / 24
+    rw [map_div₀, map_pow, hA, map_ofNat]
+  have huu : (((scaleVC 0).u⁻¹ : Hˣ) : H) * (((scaleVC 0).u : Hˣ) : H) = 1 := by simp
+  have hP : (scaleAddEquiv 0).symm (WeierstrassCurve.Affine.Point.some x y h) =
+      WeierstrassCurve.Affine.Point.some
+        (WeierstrassCurve.Affine.vcX (scaleVC 0) x)
+        (WeierstrassCurve.Affine.vcY (scaleVC 0) x y)
+        ((WeierstrassCurve.Affine.nonsingular_variableChange_iff
+          (C := scaleVC 0) (W := (nearCurve 0).toAffine) x y).mp h) := rfl
+  rw [hP, WeierstrassCurve.Affine.Point.fixedTransport_some]
+  refine some_point_ext' ?_ ?_
+  · change (((scaleVC 0).u⁻¹ : Hˣ) : H) ^ 2 *
+        (m ((((scaleVC 0).u : Hˣ) : H) ^ 2 * x + (scaleVC 0).r) - (scaleVC 0).r) =
+      HahnSeries.C ζ ^ 2 * m x
+    simp only [map_add, map_mul, map_pow]
+    rw [hmu, hmr, add_sub_cancel_right]
+    linear_combination (HahnSeries.C ζ ^ 2 * m x) *
+      ((((scaleVC 0).u⁻¹ : Hˣ) : H) * (((scaleVC 0).u : Hˣ) : H) + 1) * huu
+  · change (((scaleVC 0).u⁻¹ : Hˣ) : H) ^ 3 *
+        (m ((((scaleVC 0).u : Hˣ) : H) ^ 3 * y + (((scaleVC 0).u : Hˣ) : H) ^ 2 * (scaleVC 0).s * x
+            + (scaleVC 0).t) - (scaleVC 0).t -
+          (scaleVC 0).s * (m ((((scaleVC 0).u : Hˣ) : H) ^ 2 * x + (scaleVC 0).r) -
+            (scaleVC 0).r)) =
+      HahnSeries.C ζ ^ 3 * m y
+    simp only [map_add, map_mul, map_pow]
+    rw [hmu, hmr, hms, hmt]
+    linear_combination (HahnSeries.C ζ ^ 3 * m y) *
+      (((((scaleVC 0).u⁻¹ : Hˣ) : H) * (((scaleVC 0).u : Hˣ) : H)) ^ 2 +
+        (((scaleVC 0).u⁻¹ : Hˣ) : H) * (((scaleVC 0).u : Hˣ) : H) + 1) * huu
+
+theorem fixedTransport_conj_1728 (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar)
+    (ζ : Qbar) (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ)
+    (hE : (nearCurve 1728).map (m : H →+* H) = nearCurve 1728)
+    {x y : H} (h : (goodModel 1728).toAffine.Nonsingular x y) :
+    scaleAddEquiv 1728 (WeierstrassCurve.Affine.Point.fixedTransport m (nearCurve 1728) hE
+        ((scaleAddEquiv 1728).symm (WeierstrassCurve.Affine.Point.some x y h))) =
+      WeierstrassCurve.Affine.Point.some (HahnSeries.C ζ ^ 2 * m x)
+        (HahnSeries.C ζ ^ 3 * m y) (nonsingular_conj_1728 m hm ζ hζs h) := by
+  have hmu : m (((scaleVC 1728).u : Hˣ) : H) =
+      HahnSeries.C ζ * (((scaleVC 1728).u : Hˣ) : H) := by
+    rw [scaleVC_1728]
+    change m (HahnSeries.single (9 / 12 : ℚ) 1) =
+      HahnSeries.C ζ * HahnSeries.single (9 / 12 : ℚ) 1
+    rw [show (9 / 12 : ℚ) = 3 / 4 by norm_num, hζs, C_mul_single]
+  have hmr : m ((scaleVC 1728).r) = (scaleVC 1728).r := by
+    rw [scaleVC_1728]
+    change m (0 : H) = (0 : H)
+    exact map_zero m
+  have hms : m ((scaleVC 1728).s) = (scaleVC 1728).s := by
+    rw [scaleVC_1728]
+    change m (0 : H) = (0 : H)
+    exact map_zero m
+  have hmt : m ((scaleVC 1728).t) = (scaleVC 1728).t := by
+    rw [scaleVC_1728]
+    change m (0 : H) = (0 : H)
+    exact map_zero m
+  have huu : (((scaleVC 1728).u⁻¹ : Hˣ) : H) * (((scaleVC 1728).u : Hˣ) : H) = 1 := by simp
+  have hP : (scaleAddEquiv 1728).symm (WeierstrassCurve.Affine.Point.some x y h) =
+      WeierstrassCurve.Affine.Point.some
+        (WeierstrassCurve.Affine.vcX (scaleVC 1728) x)
+        (WeierstrassCurve.Affine.vcY (scaleVC 1728) x y)
+        ((WeierstrassCurve.Affine.nonsingular_variableChange_iff
+          (C := scaleVC 1728) (W := (nearCurve 1728).toAffine) x y).mp h) := rfl
+  rw [hP, WeierstrassCurve.Affine.Point.fixedTransport_some]
+  refine some_point_ext' ?_ ?_
+  · change (((scaleVC 1728).u⁻¹ : Hˣ) : H) ^ 2 *
+        (m ((((scaleVC 1728).u : Hˣ) : H) ^ 2 * x + (scaleVC 1728).r) - (scaleVC 1728).r) =
+      HahnSeries.C ζ ^ 2 * m x
+    simp only [map_add, map_mul, map_pow]
+    rw [hmu, hmr, add_sub_cancel_right]
+    linear_combination (HahnSeries.C ζ ^ 2 * m x) *
+      ((((scaleVC 1728).u⁻¹ : Hˣ) : H) * (((scaleVC 1728).u : Hˣ) : H) + 1) * huu
+  · change (((scaleVC 1728).u⁻¹ : Hˣ) : H) ^ 3 *
+        (m ((((scaleVC 1728).u : Hˣ) : H) ^ 3 * y +
+            (((scaleVC 1728).u : Hˣ) : H) ^ 2 * (scaleVC 1728).s * x + (scaleVC 1728).t) -
+          (scaleVC 1728).t -
+          (scaleVC 1728).s * (m ((((scaleVC 1728).u : Hˣ) : H) ^ 2 * x + (scaleVC 1728).r) -
+            (scaleVC 1728).r)) =
+      HahnSeries.C ζ ^ 3 * m y
+    simp only [map_add, map_mul, map_pow]
+    rw [hmu, hmr, hms, hmt]
+    linear_combination (HahnSeries.C ζ ^ 3 * m y) *
+      (((((scaleVC 1728).u⁻¹ : Hˣ) : H) * (((scaleVC 1728).u : Hˣ) : H)) ^ 2 +
+        (((scaleVC 1728).u⁻¹ : Hˣ) : H) * (((scaleVC 1728).u : Hˣ) : H) + 1) * huu
+
+theorem cocycle_zero_point (j₀ : Qbar) (m : H ≃ₐ[Qbar] H)
+    (hE : (nearCurve j₀).map (m : H →+* H) = nearCurve j₀) :
+    scaleAddEquiv j₀ (WeierstrassCurve.Affine.Point.fixedTransport m (nearCurve j₀) hE
+      ((scaleAddEquiv j₀).symm 0)) = 0 := by
+  simp only [map_zero]
+
+theorem redPoint_monodromy_cocycle_zero (m : H ≃ₐ[Qbar] H)
+    (hm : m ∈ HahnSeries.monodromy Qbar) (ζ : Qbar)
+    (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ)
+    (hE : (nearCurve 0).map (m : H →+* H) = nearCurve 0)
+    {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : (goodModel 0).toAffine.Nonsingular x y) :
+    redPoint (goodModel 0) (goodModel_spec 0).1 (goodModel_spec 0).2
+        (scaleAddEquiv 0 (WeierstrassCurve.Affine.Point.fixedTransport m (nearCurve 0) hE
+          ((scaleAddEquiv 0).symm (WeierstrassCurve.Affine.Point.some x y h)))) =
+      WeierstrassCurve.Affine.Point.some (ζ ^ 2 * x.coeff 0) (ζ ^ 3 * y.coeff 0)
+        (nonsingular_cocycle_zero m hm hζs hx hy h) := by
+  rw [fixedTransport_conj_zero m hm ζ hζs hE h]
+  have hCint : 0 ≤ (HahnSeries.C ζ : H).orderTop := by
+    rw [← HahnSeries.ofPowerSeries_C]
+    exact orderTop_ofPowerSeries_nonneg _
+  have hmx : 0 ≤ (m x).orderTop := by
+    rw [orderTop_of_mem_monodromy hm]
+    exact hx
+  have hmy : 0 ≤ (m y).orderTop := by
+    rw [orderTop_of_mem_monodromy hm]
+    exact hy
+  rw [redPoint_some _ _ _ (orderTop_mul_nonneg (orderTop_pow_nonneg hCint 2) hmx)
+    (orderTop_mul_nonneg (orderTop_pow_nonneg hCint 3) hmy) _]
+  refine some_point_ext ?_ ?_
+  · rw [coeff_zero_mul_of_integral (orderTop_pow_nonneg hCint 2) hmx,
+      coeff_zero_of_mem_monodromy hm, ← map_pow, coeff_zero_C]
+  · rw [coeff_zero_mul_of_integral (orderTop_pow_nonneg hCint 3) hmy,
+      coeff_zero_of_mem_monodromy hm, ← map_pow, coeff_zero_C]
+
+theorem redPoint_monodromy_cocycle_1728 (m : H ≃ₐ[Qbar] H)
+    (hm : m ∈ HahnSeries.monodromy Qbar) (ζ : Qbar)
+    (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ)
+    (hE : (nearCurve 1728).map (m : H →+* H) = nearCurve 1728)
+    {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : (goodModel 1728).toAffine.Nonsingular x y) :
+    redPoint (goodModel 1728) (goodModel_spec 1728).1 (goodModel_spec 1728).2
+        (scaleAddEquiv 1728 (WeierstrassCurve.Affine.Point.fixedTransport m (nearCurve 1728) hE
+          ((scaleAddEquiv 1728).symm (WeierstrassCurve.Affine.Point.some x y h)))) =
+      WeierstrassCurve.Affine.Point.some (ζ ^ 2 * x.coeff 0) (ζ ^ 3 * y.coeff 0)
+        (nonsingular_cocycle_1728 m hm hζs hx hy h) := by
+  rw [fixedTransport_conj_1728 m hm ζ hζs hE h]
+  have hCint : 0 ≤ (HahnSeries.C ζ : H).orderTop := by
+    rw [← HahnSeries.ofPowerSeries_C]
+    exact orderTop_ofPowerSeries_nonneg _
+  have hmx : 0 ≤ (m x).orderTop := by
+    rw [orderTop_of_mem_monodromy hm]
+    exact hx
+  have hmy : 0 ≤ (m y).orderTop := by
+    rw [orderTop_of_mem_monodromy hm]
+    exact hy
+  rw [redPoint_some _ _ _ (orderTop_mul_nonneg (orderTop_pow_nonneg hCint 2) hmx)
+    (orderTop_mul_nonneg (orderTop_pow_nonneg hCint 3) hmy) _]
+  refine some_point_ext ?_ ?_
+  · rw [coeff_zero_mul_of_integral (orderTop_pow_nonneg hCint 2) hmx,
+      coeff_zero_of_mem_monodromy hm, ← map_pow, coeff_zero_C]
+  · rw [coeff_zero_mul_of_integral (orderTop_pow_nonneg hCint 3) hmy,
+      coeff_zero_of_mem_monodromy hm, ← map_pow, coeff_zero_C]
+
+end H6B
+
+theorem algebraMap_H_apply (q : Qbar) : (algebraMap Qbar H) q = HahnSeries.C q := by
+  rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_eq, HahnSeries.ofPowerSeries_C]
+
+theorem map_jNear_of_fixes_C_of_fixes_single_one (j₀ : Qbar) (τ : H →+* H)
+    (hC : ∀ q : Qbar, τ (HahnSeries.C q) = HahnSeries.C q)
+    (h1 : τ (HahnSeries.single (1 : ℚ) (1 : Qbar)) = HahnSeries.single 1 1) :
+    τ (jNear j₀) = jNear j₀ := by
+  rw [jNear, map_add, hC, h1]
+
+theorem nearCurve_map_of_fixes_jNear (j₀ : Qbar) (τ : H →+* H)
+    (hj : τ (jNear j₀) = jNear j₀) :
+    (nearCurve j₀).map τ = nearCurve j₀ := by
+  rw [nearCurve_eq_ofJNe0Or1728, map_ofJNe0Or1728, hj, ← nearCurve_eq_ofJNe0Or1728]
+
+theorem nearCurve_map_of_fixes_C_of_fixes_single_one (j₀ : Qbar) (τ : H →+* H)
+    (hC : ∀ q : Qbar, τ (HahnSeries.C q) = HahnSeries.C q)
+    (h1 : τ (HahnSeries.single (1 : ℚ) (1 : Qbar)) = HahnSeries.single 1 1) :
+    (nearCurve j₀).map τ = nearCurve j₀ :=
+  nearCurve_map_of_fixes_jNear j₀ τ (map_jNear_of_fixes_C_of_fixes_single_one j₀ τ hC h1)
+
+theorem nearCurve_map_of_mem_monodromy (j₀ : Qbar) {m : H ≃ₐ[Qbar] H}
+    (hm : m ∈ HahnSeries.monodromy Qbar) :
+    (nearCurve j₀).map (m : H →+* H) = nearCurve j₀ :=
+  nearCurve_map_of_fixes_C_of_fixes_single_one j₀ (m : H →+* H)
+    (fun q => by rw [← algebraMap_H_apply]; exact m.commutes q)
+    (HahnSeries.fixes_single_one_of_mem_monodromy hm)
+
+def nearTransport (j₀ : Qbar) (m : HahnSeries.monodromy Qbar) :
+    (nearCurve j₀).toAffine.Point ≃+ (nearCurve j₀).toAffine.Point :=
+  WeierstrassCurve.Affine.Point.fixedTransport (m : H ≃ₐ[Qbar] H) (nearCurve j₀)
+    (nearCurve_map_of_mem_monodromy j₀ m.2)
+
+theorem nearTransport_some (j₀ : Qbar) (m : HahnSeries.monodromy Qbar) (x y : H)
+    (h : (nearCurve j₀).toAffine.Nonsingular x y) :
+    nearTransport j₀ m (.some x y h) =
+      .some ((m : H ≃ₐ[Qbar] H) x) ((m : H ≃ₐ[Qbar] H) y)
+        (WeierstrassCurve.Affine.Point.nonsingular_of_fixed _ _
+          (nearCurve_map_of_mem_monodromy j₀ m.2) h) :=
+  WeierstrassCurve.Affine.Point.fixedTransport_some
+    (m : H ≃ₐ[Qbar] H) (nearCurve j₀) (nearCurve_map_of_mem_monodromy j₀ m.2) x y h
+
+def b3Act (j₀ : Qbar) (m : HahnSeries.monodromy Qbar) :
+    AddSubgroup (nearCurve j₀).toAffine.Point → AddSubgroup (nearCurve j₀).toAffine.Point :=
+  AddSubgroup.map ((nearTransport j₀ m : _ ≃+ _) : _ →+ _)
+
+theorem b3Act_zmultiples (j₀ : Qbar) (m : HahnSeries.monodromy Qbar)
+    (g : (nearCurve j₀).toAffine.Point) :
+    b3Act j₀ m (AddSubgroup.zmultiples g) = AddSubgroup.zmultiples (nearTransport j₀ m g) :=
+  AddMonoidHom.map_zmultiples _ g
+
+theorem scaleAddEquiv_some_generic (j₀ : Qbar) (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728)
+    {x y : H} (h : (nearCurve j₀).toAffine.Nonsingular x y) :
+    ∃ h' : (goodModel j₀).toAffine.Nonsingular x y,
+      scaleAddEquiv j₀ (.some x y h) = .some x y h' := by
+  have hvX : WeierstrassCurve.Affine.vcXInv (scaleVC j₀) x = x := by
+    rw [scaleVC_of_ne h0 h1728]
+    simp [WeierstrassCurve.Affine.vcXInv, VariableChange.one_def]
+  have hvY : WeierstrassCurve.Affine.vcYInv (scaleVC j₀) x y = y := by
+    rw [scaleVC_of_ne h0 h1728]
+    simp [WeierstrassCurve.Affine.vcYInv, VariableChange.one_def]
+  refine ⟨?_, ?_⟩
+  · rw [goodModel_eq_nearCurve h0 h1728]; exact h
+  · rw [scaleAddEquiv_apply]
+    change (WeierstrassCurve.Affine.Point.some
+        (WeierstrassCurve.Affine.vcXInv (scaleVC j₀) x)
+        (WeierstrassCurve.Affine.vcYInv (scaleVC j₀) x y) _ :
+        (goodModel j₀).toAffine.Point) = WeierstrassCurve.Affine.Point.some x y _
+    congr 1
+
+theorem redTorsionEquiv_scaleAddEquiv_nearTransport_generic (p : ℕ) [Fact p.Prime]
+    (j₀ : Qbar) (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) (m : HahnSeries.monodromy Qbar)
+    {x y : H} (h : (nearCurve j₀).toAffine.Nonsingular x y)
+    (hg : addOrderOf (WeierstrassCurve.Affine.Point.some x y h :
+        (nearCurve j₀).toAffine.Point) = p) :
+    ((redTorsionEquiv (goodModel j₀) (goodModel_spec j₀).1 (goodModel_spec j₀).2 p
+        ⟨scaleAddEquiv j₀ (nearTransport j₀ m (.some x y h)),
+          mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ _).trans
+            ((AddEquiv.addOrderOf_eq _ _).trans hg))⟩ :
+        Submodule.torsionBy ℤ (specialFibre (goodModel j₀)).toAffine.Point (p : ℤ)) :
+      (specialFibre (goodModel j₀)).toAffine.Point) =
+    ((redTorsionEquiv (goodModel j₀) (goodModel_spec j₀).1 (goodModel_spec j₀).2 p
+        ⟨scaleAddEquiv j₀ (.some x y h),
+          mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ _).trans hg)⟩ :
+        Submodule.torsionBy ℤ (specialFibre (goodModel j₀)).toAffine.Point (p : ℤ)) :
+      (specialFibre (goodModel j₀)).toAffine.Point) := by
+  have hm := m.2
+  have hns' := WeierstrassCurve.Affine.Point.nonsingular_of_fixed _ _
+    (nearCurve_map_of_mem_monodromy j₀ hm) h
+  obtain ⟨h', hscale'⟩ := scaleAddEquiv_some_generic j₀ h0 h1728 hns'
+  obtain ⟨hgn, hscale⟩ := scaleAddEquiv_some_generic j₀ h0 h1728 h
+  obtain ⟨hred', hred'eq⟩ := redTorsionEquiv_spec (goodModel j₀) (goodModel_spec j₀).1
+    (goodModel_spec j₀).2 p
+    ⟨scaleAddEquiv j₀ (nearTransport j₀ m (.some x y h)),
+      mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ _).trans
+        ((AddEquiv.addOrderOf_eq _ _).trans hg))⟩
+    ((m : H ≃ₐ[Qbar] H) x) ((m : H ≃ₐ[Qbar] H) y) h'
+    (by simpa only [nearTransport_some] using hscale')
+  obtain ⟨hred, hredeq⟩ := redTorsionEquiv_spec (goodModel j₀) (goodModel_spec j₀).1
+    (goodModel_spec j₀).2 p
+    ⟨scaleAddEquiv j₀ (.some x y h),
+      mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ _).trans hg)⟩
+    x y hgn hscale
+  rw [hred'eq, hredeq]
+  congr 1
+  · exact coeff_zero_of_mem_monodromy hm x
+  · exact coeff_zero_of_mem_monodromy hm y
+
+theorem bridge3Specialise_b3Act_generic (p : ℕ) [Fact p.Prime] [NeZero p] (j₀ : Qbar)
+    (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) (m : HahnSeries.monodromy Qbar)
+    (g : (nearCurve j₀).toAffine.Point) (hg : addOrderOf g = p) :
+    (bridge3Specialise p j₀
+        ⟨b3Act j₀ m (AddSubgroup.zmultiples g), nearTransport j₀ m g,
+          (AddEquiv.addOrderOf_eq _ g).trans hg, b3Act_zmultiples j₀ m g⟩).1 =
+      (bridge3Specialise p j₀ ⟨AddSubgroup.zmultiples g, g, hg, rfl⟩).1 := by
+  have hgT : addOrderOf (nearTransport j₀ m g) = p := (AddEquiv.addOrderOf_eq _ g).trans hg
+  rw [show (⟨b3Act j₀ m (AddSubgroup.zmultiples g), nearTransport j₀ m g, hgT,
+        b3Act_zmultiples j₀ m g⟩ : CycSubH (nearCurve j₀) p) =
+      ⟨AddSubgroup.zmultiples (nearTransport j₀ m g), nearTransport j₀ m g, hgT, rfl⟩ from
+    Subtype.ext (b3Act_zmultiples j₀ m g)]
+  rw [bridge3Specialise_zmultiples p j₀ (nearTransport j₀ m g) hgT,
+    bridge3Specialise_zmultiples p j₀ g hg]
+  rcases g with _ | ⟨x, y, h⟩
+  · exact absurd hg (by
+      rw [show (WeierstrassCurve.Affine.Point.zero : (nearCurve j₀).toAffine.Point) = 0 from rfl,
+        addOrderOf_zero]
+      exact (Fact.out : p.Prime).ne_one.symm)
+  · congr 2
+    exact redTorsionEquiv_scaleAddEquiv_nearTransport_generic p j₀ h0 h1728 m h hg
+
+private theorem monodromy_full (e : ℕ) (he : 0 < e) (ζ : Qbar) (hζ : ζ ^ e = 1) :
+    ∃ m ∈ HahnSeries.monodromy Qbar,
+      (m : H ≃ₐ[Qbar] H) (HahnSeries.single ((e : ℚ)⁻¹) (1 : Qbar)) =
+        HahnSeries.single ((e : ℚ)⁻¹) ζ :=
+  HahnSeries.exists_mem_monodromy_single_eq (AlgebraicClosure ℚ) e he ζ hζ
+
+theorem nearTransport_one (j₀ : Qbar) : nearTransport j₀ 1 = AddEquiv.refl _ := by
+  refine AddEquiv.ext fun P => ?_
+  rcases P with _ | ⟨x, y, h⟩
+  · exact WeierstrassCurve.Affine.Point.fixedTransport_zero
+      (1 : H ≃ₐ[Qbar] H) (nearCurve j₀) (nearCurve_map_of_mem_monodromy j₀ (1 :
+        HahnSeries.monodromy Qbar).2)
+  · exact nearTransport_some j₀ 1 x y h
+
+theorem b3Act_one (j₀ : Qbar) (G : AddSubgroup (nearCurve j₀).toAffine.Point) :
+    b3Act j₀ 1 G = G := by
+  rw [b3Act, nearTransport_one]
+  exact G.map_id
+
+theorem exists_zeta_of_mem_monodromy {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    (q : ℚ) :
+    ∃ ζ : Qbar, m (HahnSeries.single q 1) = HahnSeries.single q ζ := by
+  obtain ⟨χ, _, rfl⟩ := hm
+  exact ⟨(χ (Multiplicative.ofAdd q)).val, by
+    rw [HahnSeries.hahnTwistHom_apply, HahnSeries.hahnTwist_single, mul_one]⟩
+
+theorem bridge3Specialise_coe_eq_of_coe_eq (p : ℕ) [Fact p.Prime] [NeZero p] (j₀ : Qbar)
+    {G G' : CycSubH (nearCurve j₀) p} (hGG' : G.1 = G'.1) :
+    (bridge3Specialise p j₀ G).1 = (bridge3Specialise p j₀ G').1 := by
+  rw [show G = G' from Subtype.ext hGG']
+
+theorem b3_specialisationEquivariance_generic (p : ℕ) [Fact p.Prime] [NeZero p] (j₀ : Qbar)
+    (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) (G G' : CycSubH (nearCurve j₀) p) :
+    (∃ m : HahnSeries.monodromy Qbar, b3Act j₀ m G.1 = G'.1) ↔
+      SameOrbit (WeierstrassCurve.ofJ j₀) (bridge3Specialise p j₀ G).1
+        (bridge3Specialise p j₀ G').1 := by
+  rw [sameOrbit_ofJ_iff_of_ne j₀ h0 h1728]
+  obtain ⟨g, hg, hG1⟩ := G.2
+  have hGeq : G = ⟨AddSubgroup.zmultiples g, g, hg, rfl⟩ := Subtype.ext hG1
+  constructor
+  · rintro ⟨m, hb3⟩
+    refine ⟨?_, (bridge3Specialise p j₀ G).2.imp fun _ h => h.2⟩
+    have hgT : addOrderOf (nearTransport j₀ m g) = p := (AddEquiv.addOrderOf_eq _ g).trans hg
+    have key : (bridge3Specialise p j₀ G').1 = (bridge3Specialise p j₀ G).1 := by
+      calc (bridge3Specialise p j₀ G').1
+          = (bridge3Specialise p j₀
+              ⟨b3Act j₀ m (AddSubgroup.zmultiples g), nearTransport j₀ m g, hgT,
+                b3Act_zmultiples j₀ m g⟩).1 := by
+            apply bridge3Specialise_coe_eq_of_coe_eq
+            rw [← hb3, hG1]
+        _ = (bridge3Specialise p j₀ ⟨AddSubgroup.zmultiples g, g, hg, rfl⟩).1 :=
+            bridge3Specialise_b3Act_generic p j₀ h0 h1728 m g hg
+        _ = (bridge3Specialise p j₀ G).1 := by rw [← hGeq]
+    exact key.symm
+  · rintro ⟨hβeq, _⟩
+    refine ⟨1, ?_⟩
+    rw [b3Act_one]
+    have : G = G' := (bridge3Specialise p j₀).injective (Subtype.ext hβeq)
+    rw [this]
+
+open WeierstrassCurve.Affine.Point in
+theorem redTorsionEquiv_coe_eq_redPoint (W : WeierstrassCurve H) [W.IsElliptic]
+    (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0) [(specialFibre W).IsElliptic]
+    (p : ℕ) [Fact p.Prime]
+    (Q : W.toAffine.Point) (hQ0 : Q ≠ 0)
+    (hmem : Q ∈ Submodule.torsionBy ℤ W.toAffine.Point (p : ℤ)) :
+    ((redTorsionEquiv W hW hΔ p ⟨Q, hmem⟩ :
+        Submodule.torsionBy ℤ (specialFibre W).toAffine.Point (p : ℤ)) :
+      (specialFibre W).toAffine.Point) =
+      redPoint W hW hΔ Q := by
+  obtain ⟨x, y, h, hPQ⟩ : ∃ x y h, Q = WeierstrassCurve.Affine.Point.some x y h := by
+    rcases Q with _ | ⟨x, y, h⟩
+    · exact absurd rfl hQ0
+    · exact ⟨x, y, h, rfl⟩
+  subst hPQ
+  have htor : p • WeierstrassCurve.Affine.Point.some x y h = 0 := by
+    have hz : (p : ℤ) • (WeierstrassCurve.Affine.Point.some x y h : W.toAffine.Point) = 0 := hmem
+    rw [natCast_zsmul] at hz
+    exact hz
+  have ⟨hx, hy⟩ := torsion_coords_integral W hW hΔ h (n := p) (Fact.out : p.Prime).ne_zero htor
+  obtain ⟨h₀, heq⟩ := redTorsionEquiv_spec W hW hΔ p ⟨_, hmem⟩ x y h rfl
+  rw [heq, redPoint_some W hW hΔ hx hy h]
+
+open WeierstrassCurve.Affine in
+theorem exists_some_of_addOrderOf_prime (j₀ : Qbar) {p : ℕ} [Fact p.Prime]
+    {g : (nearCurve j₀).toAffine.Point} (hg : addOrderOf g = p) :
+    ∃ x y h, g = WeierstrassCurve.Affine.Point.some x y h := by
+  rcases g with _ | ⟨x, y, h⟩
+  · exact absurd hg (by
+      rw [show (WeierstrassCurve.Affine.Point.zero : (nearCurve j₀).toAffine.Point) = 0 from rfl,
+        addOrderOf_zero]
+      exact (Fact.out : p.Prime).ne_one.symm)
+  · exact ⟨x, y, h, rfl⟩
+
+open WeierstrassCurve.Affine in
+theorem redTorsionEquiv_scaleAddEquiv_nearTransport_zero (p : ℕ) [Fact p.Prime] [NeZero p]
+    (m : HahnSeries.monodromy Qbar) {ζ : Qbar}
+    (hζs : (m : H ≃ₐ[Qbar] H) (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ)
+    (hζ0 : ζ ≠ 0) (hζ6 : ζ ^ 6 = 1)
+    (g : (nearCurve 0).toAffine.Point) (hg : addOrderOf g = p) :
+    ((redTorsionEquiv (goodModel 0) (goodModel_spec 0).1 (goodModel_spec 0).2 p
+        ⟨scaleAddEquiv 0 (nearTransport 0 m g),
+          mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ _).trans
+            ((AddEquiv.addOrderOf_eq _ _).trans hg))⟩ :
+        Submodule.torsionBy ℤ (specialFibre (goodModel 0)).toAffine.Point (p : ℤ)) :
+      (specialFibre (goodModel 0)).toAffine.Point) =
+    fibreTwistEquiv_zero ζ hζ0 hζ6
+      ((redTorsionEquiv (goodModel 0) (goodModel_spec 0).1 (goodModel_spec 0).2 p
+          ⟨scaleAddEquiv 0 g,
+            mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ _).trans hg)⟩ :
+          Submodule.torsionBy ℤ (specialFibre (goodModel 0)).toAffine.Point (p : ℤ)) :
+        (specialFibre (goodModel 0)).toAffine.Point) := by
+  have hg0 : g ≠ 0 := fun h0 => (Fact.out : p.Prime).ne_one ((h0 ▸ hg).symm.trans addOrderOf_zero)
+  have hsg0 : (scaleAddEquiv 0 g : (goodModel 0).toAffine.Point) ≠ 0 :=
+    fun h0 => hg0 ((scaleAddEquiv 0).injective (h0.trans (map_zero _).symm))
+  have hsgT0 : (scaleAddEquiv 0 (nearTransport 0 m g) : (goodModel 0).toAffine.Point) ≠ 0 :=
+    fun h0 => hg0 ((nearTransport 0 m).injective ((scaleAddEquiv 0).injective
+      (h0.trans (map_zero _).symm) |>.trans (map_zero _).symm))
+  rw [redTorsionEquiv_coe_eq_redPoint _ _ _ p _ hsgT0 _,
+    redTorsionEquiv_coe_eq_redPoint _ _ _ p _ hsg0 _]
+  obtain ⟨x₁, y₁, h₁, hgeq⟩ := exists_some_of_addOrderOf_prime 0 hg
+  set Q := scaleAddEquiv 0 g with hQdef
+  rcases hQeq : Q with _ | ⟨x, y, hns⟩
+  · exact absurd (hQdef ▸ hQeq) hsg0
+  have htor : p • WeierstrassCurve.Affine.Point.some x y hns = 0 := by
+    rw [← hQeq, hQdef, ← map_nsmul,
+      show p • g = 0 from hg ▸ addOrderOf_nsmul_eq_zero g, map_zero]
+  have ⟨hx, hy⟩ := torsion_coords_integral (goodModel 0) (goodModel_spec 0).1 (goodModel_spec 0).2
+    hns (n := p) (Fact.out : p.Prime).ne_zero htor
+  have hE := nearCurve_map_of_mem_monodromy 0 m.2
+  have hconj : scaleAddEquiv 0 (nearTransport 0 m g) =
+      scaleAddEquiv 0 (WeierstrassCurve.Affine.Point.fixedTransport (m : H ≃ₐ[Qbar] H)
+        (nearCurve 0) hE ((scaleAddEquiv 0).symm (.some x y hns))) := by
+    rw [← hQeq, hQdef, AddEquiv.symm_apply_apply]
+    rfl
+  rw [hconj, redPoint_monodromy_cocycle_zero (m : H ≃ₐ[Qbar] H) m.2 ζ hζs hE hx hy hns,
+    redPoint_some (goodModel 0) (goodModel_spec 0).1 (goodModel_spec 0).2 hx hy hns,
+    fibreTwistEquiv_zero_some ζ hζ0 hζ6
+      (nonsingular_specialFibre (goodModel 0) (goodModel_spec 0).1 (goodModel_spec 0).2
+        hx hy hns)]
+
+theorem sameOrbit_iff_map (E₀ : WeierstrassCurve Qbar) (H H' : AddSubgroup E₀.toAffine.Point) :
+    SameOrbit E₀ H H' ↔
+      (∃ γ : VariableChange Qbar, ∃ hγ : γ • E₀ = E₀,
+        H' = H.map ((vcEquivOfSMulEq γ hγ : _ ≃+ _) : _ →+ _)) ∧
+        ∃ g, H = AddSubgroup.zmultiples g := by
+  rw [sameOrbit_iff]
+  constructor
+  · rintro ⟨γ, hγ, g, g', rfl, rfl, hheq⟩
+    refine ⟨⟨γ, hγ, ?_⟩, g, rfl⟩
+    rw [(heq_vcInvFun_iff_eq γ hγ g g').mp hheq, AddMonoidHom.map_zmultiples]
+    rfl
+  · rintro ⟨⟨γ, hγ, rfl⟩, g, rfl⟩
+    refine ⟨γ, hγ, g, vcEquivOfSMulEq γ hγ g, rfl, ?_, ?_⟩
+    · rw [AddMonoidHom.map_zmultiples]; rfl
+    · exact (heq_vcInvFun_iff_eq γ hγ g _).mpr rfl
+
+theorem b3_specialisationEquivariance_zero (p : ℕ) [Fact p.Prime] [NeZero p]
+    (G G' : CycSubH (nearCurve 0) p) :
+    (∃ m : HahnSeries.monodromy Qbar, b3Act 0 m G.1 = G'.1) ↔
+      SameOrbit (WeierstrassCurve.ofJ 0) (bridge3Specialise p 0 G).1
+        (bridge3Specialise p 0 G').1 := by
+  obtain ⟨g, hg, hG1⟩ := G.2
+  have hGeq : G = ⟨AddSubgroup.zmultiples g, g, hg, rfl⟩ := Subtype.ext hG1
+  have hBne : (-(2 * 1728 ^ 4) : Qbar) ≠ 0 := by norm_num
+  set P₀ : (specialFibre (goodModel 0)).toAffine.Point :=
+    ((redTorsionEquiv (goodModel 0) (goodModel_spec 0).1 (goodModel_spec 0).2 p
+      ⟨scaleAddEquiv 0 g, mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ g).trans hg)⟩ :
+      Submodule.torsionBy ℤ (specialFibre (goodModel 0)).toAffine.Point (p : ℤ)) :
+    (specialFibre (goodModel 0)).toAffine.Point) with hP₀def
+  have hβG : (bridge3Specialise p 0 G).1 = AddSubgroup.zmultiples (fibreAddEquiv 0 P₀) := by
+    rw [hGeq, bridge3Specialise_zmultiples p 0 g hg]
+  constructor
+  · rintro ⟨m, hb3⟩
+    obtain ⟨ζ, hζs⟩ := exists_zeta_of_mem_monodromy m.2 (1 / 6 : ℚ)
+    have hζ6 : ζ ^ 6 = 1 := zeta_pow_eq_one_of_twist (k := 1) m.2 hζs (by norm_num)
+    have hζ0 : ζ ≠ 0 := zeta_ne_zero_of_pow_eq_one (n := 6) (by norm_num) hζ6
+    have hgT : addOrderOf (nearTransport 0 m g) = p := (AddEquiv.addOrderOf_eq _ g).trans hg
+    have hβG' : (bridge3Specialise p 0 G').1 =
+        AddSubgroup.zmultiples (fibreAddEquiv 0 (fibreTwistEquiv_zero ζ hζ0 hζ6 P₀)) := by
+      rw [bridge3Specialise_coe_eq_of_coe_eq p 0
+          (G' := ⟨AddSubgroup.zmultiples (nearTransport 0 m g), nearTransport 0 m g, hgT, rfl⟩)
+          (by rw [← hb3, hG1, b3Act_zmultiples]),
+        bridge3Specialise_zmultiples p 0 (nearTransport 0 m g) hgT,
+        redTorsionEquiv_scaleAddEquiv_nearTransport_zero p m hζs hζ0 hζ6 g hg]
+    rw [hβG, hβG']
+    exact sameOrbit_of_conj (fibreVC_smul 0) (fibreTwistVC_smul_fibre_zero hζ0 hζ6) P₀
+  · intro hSO
+    rw [hβG, sameOrbit_iff_map] at hSO
+    obtain ⟨⟨γ, hγ, hmap⟩, _⟩ := hSO
+    have hconjF : ((fibreVC 0)⁻¹ * γ * fibreVC 0) • specialFibre (goodModel 0) =
+        specialFibre (goodModel 0) := conj_smul_eq (fibreVC_smul 0) hγ
+    obtain ⟨hr, hs, ht, hu6⟩ : ((fibreVC 0)⁻¹ * γ * fibreVC 0).r = 0 ∧
+        ((fibreVC 0)⁻¹ * γ * fibreVC 0).s = 0 ∧
+        ((fibreVC 0)⁻¹ * γ * fibreVC 0).t = 0 ∧
+        (((fibreVC 0)⁻¹ * γ * fibreVC 0).u : Qbar) ^ 6 = 1 := by
+      have := hconjF
+      rw [specialFibre_goodModel_zero] at this
+      exact (smul_a6Model_eq_iff hBne _).mp this
+    set u : Qbarˣ := ((fibreVC 0)⁻¹ * γ * fibreVC 0).u with hudef
+    set ζ : Qbar := ((u⁻¹ : Qbarˣ) : Qbar) with hζdef
+    have hζ6 : ζ ^ 6 = 1 := by
+      rw [hζdef, ← Units.val_pow_eq_pow_val, inv_pow, ← Units.val_one (α := Qbar)]
+      exact congrArg Units.val (inv_eq_one.mpr (Units.ext hu6))
+    have hζ0 : ζ ≠ 0 := zeta_ne_zero_of_pow_eq_one (n := 6) (by norm_num) hζ6
+    obtain ⟨m', hm', hζs⟩ := monodromy_full 6 (by norm_num) ζ hζ6
+    have hζs' : ((⟨m', hm'⟩ : HahnSeries.monodromy Qbar) : H ≃ₐ[Qbar] H)
+        (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ := by
+      have h6 : ((6 : ℕ) : ℚ)⁻¹ = (1 / 6 : ℚ) := by norm_num
+      rw [← h6]; exact hζs
+    have hftvc : fibreTwistVC ζ hζ0 = (fibreVC 0)⁻¹ * γ * fibreVC 0 := by
+      rw [variableChange_eq_of_rst_eq_zero _ hr hs ht]
+      change (⟨(Units.mk0 ζ hζ0)⁻¹, 0, 0, 0⟩ : VariableChange Qbar) = ⟨u, 0, 0, 0⟩
+      have : Units.mk0 ζ hζ0 = u⁻¹ := Units.ext (by rw [Units.val_mk0, hζdef])
+      rw [this, inv_inv]
+    refine ⟨⟨m', hm'⟩, ?_⟩
+    have hgT : addOrderOf (nearTransport 0 ⟨m', hm'⟩ g) = p :=
+      (AddEquiv.addOrderOf_eq _ g).trans hg
+    suffices h : (bridge3Specialise p 0
+          ⟨AddSubgroup.zmultiples (nearTransport 0 ⟨m', hm'⟩ g),
+            nearTransport 0 ⟨m', hm'⟩ g, hgT, rfl⟩).1 =
+        (bridge3Specialise p 0 G').1 by
+      have := (bridge3Specialise p 0).injective (Subtype.ext h)
+      rw [hG1, b3Act_zmultiples, ← this]
+    rw [bridge3Specialise_zmultiples p 0 (nearTransport 0 ⟨m', hm'⟩ g) hgT,
+      redTorsionEquiv_scaleAddEquiv_nearTransport_zero p ⟨m', hm'⟩ hζs' hζ0 hζ6 g hg,
+      ← hP₀def]
+    rw [hmap, AddMonoidHom.map_zmultiples]
+    congr 1
+    have hftvc_smul : fibreTwistVC ζ hζ0 • specialFibre (goodModel 0) =
+        specialFibre (goodModel 0) := hftvc ▸ hconjF
+    calc fibreAddEquiv 0 (fibreTwistEquiv_zero ζ hζ0 hζ6 P₀)
+        = vcEquivOfSMulEq (fibreVC 0) (fibreVC_smul 0)
+            (vcEquivOfSMulEq (fibreTwistVC ζ hζ0) hftvc_smul P₀) := rfl
+      _ = vcEquivOfSMulEq (fibreVC 0) (fibreVC_smul 0)
+            (vcEquivOfSMulEq ((fibreVC 0)⁻¹ * γ * fibreVC 0) hconjF P₀) := by
+          rw [vcEquivOfSMulEq_congr hftvc hftvc_smul hconjF]
+      _ = vcEquivOfSMulEq γ hγ (vcEquivOfSMulEq (fibreVC 0) (fibreVC_smul 0) P₀) :=
+          vcEquivOfSMulEq_conj (fibreVC_smul 0) hγ P₀
+      _ = _ := rfl
+
+open WeierstrassCurve.Affine in
+theorem redTorsionEquiv_scaleAddEquiv_nearTransport_1728 (p : ℕ) [Fact p.Prime] [NeZero p]
+    (m : HahnSeries.monodromy Qbar) {ζ : Qbar}
+    (hζs : (m : H ≃ₐ[Qbar] H) (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ)
+    (hζ0 : ζ ≠ 0) (hζ4 : ζ ^ 4 = 1)
+    (g : (nearCurve 1728).toAffine.Point) (hg : addOrderOf g = p) :
+    ((redTorsionEquiv (goodModel 1728) (goodModel_spec 1728).1 (goodModel_spec 1728).2 p
+        ⟨scaleAddEquiv 1728 (nearTransport 1728 m g),
+          mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ _).trans
+            ((AddEquiv.addOrderOf_eq _ _).trans hg))⟩ :
+        Submodule.torsionBy ℤ (specialFibre (goodModel 1728)).toAffine.Point (p : ℤ)) :
+      (specialFibre (goodModel 1728)).toAffine.Point) =
+    fibreTwistEquiv_1728 ζ hζ0 hζ4
+      ((redTorsionEquiv (goodModel 1728) (goodModel_spec 1728).1 (goodModel_spec 1728).2 p
+          ⟨scaleAddEquiv 1728 g,
+            mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ _).trans hg)⟩ :
+          Submodule.torsionBy ℤ (specialFibre (goodModel 1728)).toAffine.Point (p : ℤ)) :
+        (specialFibre (goodModel 1728)).toAffine.Point) := by
+  have hg0 : g ≠ 0 := fun h0 => (Fact.out : p.Prime).ne_one ((h0 ▸ hg).symm.trans addOrderOf_zero)
+  have hsg0 : (scaleAddEquiv 1728 g : (goodModel 1728).toAffine.Point) ≠ 0 :=
+    fun h0 => hg0 ((scaleAddEquiv 1728).injective (h0.trans (map_zero _).symm))
+  have hsgT0 : (scaleAddEquiv 1728 (nearTransport 1728 m g) : (goodModel 1728).toAffine.Point)
+      ≠ 0 :=
+    fun h0 => hg0 ((nearTransport 1728 m).injective ((scaleAddEquiv 1728).injective
+      (h0.trans (map_zero _).symm) |>.trans (map_zero _).symm))
+  rw [redTorsionEquiv_coe_eq_redPoint _ _ _ p _ hsgT0 _,
+    redTorsionEquiv_coe_eq_redPoint _ _ _ p _ hsg0 _]
+  obtain ⟨x₁, y₁, h₁, hgeq⟩ := exists_some_of_addOrderOf_prime 1728 hg
+  set Q := scaleAddEquiv 1728 g with hQdef
+  rcases hQeq : Q with _ | ⟨x, y, hns⟩
+  · exact absurd (hQdef ▸ hQeq) hsg0
+  have htor : p • WeierstrassCurve.Affine.Point.some x y hns = 0 := by
+    rw [← hQeq, hQdef, ← map_nsmul,
+      show p • g = 0 from hg ▸ addOrderOf_nsmul_eq_zero g, map_zero]
+  have ⟨hx, hy⟩ := torsion_coords_integral (goodModel 1728) (goodModel_spec 1728).1
+    (goodModel_spec 1728).2 hns (n := p) (Fact.out : p.Prime).ne_zero htor
+  have hE := nearCurve_map_of_mem_monodromy 1728 m.2
+  have hconj : scaleAddEquiv 1728 (nearTransport 1728 m g) =
+      scaleAddEquiv 1728 (WeierstrassCurve.Affine.Point.fixedTransport (m : H ≃ₐ[Qbar] H)
+        (nearCurve 1728) hE ((scaleAddEquiv 1728).symm (.some x y hns))) := by
+    rw [← hQeq, hQdef, AddEquiv.symm_apply_apply]
+    rfl
+  rw [hconj, redPoint_monodromy_cocycle_1728 (m : H ≃ₐ[Qbar] H) m.2 ζ hζs hE hx hy hns,
+    redPoint_some (goodModel 1728) (goodModel_spec 1728).1 (goodModel_spec 1728).2 hx hy hns,
+    fibreTwistEquiv_1728_some ζ hζ0 hζ4
+      (nonsingular_specialFibre (goodModel 1728) (goodModel_spec 1728).1 (goodModel_spec 1728).2
+        hx hy hns)]
+
+theorem monodromy_full_three_quarters (ζ : Qbar) (hζ4 : ζ ^ 4 = 1) :
+    ∃ m ∈ HahnSeries.monodromy Qbar,
+      (m : H ≃ₐ[Qbar] H) (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ := by
+  have hζ'4 : (ζ ^ 3) ^ 4 = 1 := by rw [← pow_mul, show 3 * 4 = 4 * 3 from rfl, pow_mul, hζ4,
+    one_pow]
+  obtain ⟨m, hm, hζ's⟩ := monodromy_full 4 (by norm_num) (ζ ^ 3) hζ'4
+  refine ⟨m, hm, ?_⟩
+  have h14 : ((4 : ℕ) : ℚ)⁻¹ = (1 / 4 : ℚ) := by norm_num
+  have h34 : (HahnSeries.single (3 / 4 : ℚ) (1 : Qbar) : H) =
+      (HahnSeries.single ((4 : ℕ) : ℚ)⁻¹ (1 : Qbar)) ^ 3 := by
+    rw [HahnSeries.single_pow, one_pow, h14]
+    norm_num
+  rw [h34, map_pow, hζ's, HahnSeries.single_pow, h14, ← pow_mul,
+    show 3 * 3 = 4 * 2 + 1 from rfl, pow_add, pow_mul, hζ4, one_pow, pow_one, one_mul]
+  norm_num
+
+theorem b3_specialisationEquivariance_1728 (p : ℕ) [Fact p.Prime] [NeZero p]
+    (G G' : CycSubH (nearCurve 1728) p) :
+    (∃ m : HahnSeries.monodromy Qbar, b3Act 1728 m G.1 = G'.1) ↔
+      SameOrbit (WeierstrassCurve.ofJ 1728) (bridge3Specialise p 1728 G).1
+        (bridge3Specialise p 1728 G').1 := by
+  obtain ⟨g, hg, hG1⟩ := G.2
+  have hGeq : G = ⟨AddSubgroup.zmultiples g, g, hg, rfl⟩ := Subtype.ext hG1
+  have hAne : (-36 : Qbar) ≠ 0 := by norm_num
+  set P₀ : (specialFibre (goodModel 1728)).toAffine.Point :=
+    ((redTorsionEquiv (goodModel 1728) (goodModel_spec 1728).1 (goodModel_spec 1728).2 p
+      ⟨scaleAddEquiv 1728 g,
+        mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ g).trans hg)⟩ :
+      Submodule.torsionBy ℤ (specialFibre (goodModel 1728)).toAffine.Point (p : ℤ)) :
+    (specialFibre (goodModel 1728)).toAffine.Point) with hP₀def
+  have hβG : (bridge3Specialise p 1728 G).1 = AddSubgroup.zmultiples (fibreAddEquiv 1728 P₀) := by
+    rw [hGeq, bridge3Specialise_zmultiples p 1728 g hg]
+  constructor
+  · rintro ⟨m, hb3⟩
+    obtain ⟨ζ, hζs⟩ := exists_zeta_of_mem_monodromy m.2 (3 / 4 : ℚ)
+    have hζ4 : ζ ^ 4 = 1 := zeta_pow_eq_one_of_twist (k := 3) m.2 hζs (by norm_num)
+    have hζ0 : ζ ≠ 0 := zeta_ne_zero_of_pow_eq_one (n := 4) (by norm_num) hζ4
+    have hgT : addOrderOf (nearTransport 1728 m g) = p := (AddEquiv.addOrderOf_eq _ g).trans hg
+    have hβG' : (bridge3Specialise p 1728 G').1 =
+        AddSubgroup.zmultiples (fibreAddEquiv 1728 (fibreTwistEquiv_1728 ζ hζ0 hζ4 P₀)) := by
+      rw [bridge3Specialise_coe_eq_of_coe_eq p 1728
+          (G' := ⟨AddSubgroup.zmultiples (nearTransport 1728 m g), nearTransport 1728 m g, hgT,
+            rfl⟩)
+          (by rw [← hb3, hG1, b3Act_zmultiples]),
+        bridge3Specialise_zmultiples p 1728 (nearTransport 1728 m g) hgT,
+        redTorsionEquiv_scaleAddEquiv_nearTransport_1728 p m hζs hζ0 hζ4 g hg]
+    rw [hβG, hβG']
+    exact sameOrbit_of_conj (fibreVC_smul 1728) (fibreTwistVC_smul_fibre_1728 hζ0 hζ4) P₀
+  · intro hSO
+    rw [hβG, sameOrbit_iff_map] at hSO
+    obtain ⟨⟨γ, hγ, hmap⟩, _⟩ := hSO
+    have hconjF : ((fibreVC 1728)⁻¹ * γ * fibreVC 1728) • specialFibre (goodModel 1728) =
+        specialFibre (goodModel 1728) := conj_smul_eq (fibreVC_smul 1728) hγ
+    obtain ⟨hr, hs, ht, hu4⟩ : ((fibreVC 1728)⁻¹ * γ * fibreVC 1728).r = 0 ∧
+        ((fibreVC 1728)⁻¹ * γ * fibreVC 1728).s = 0 ∧
+        ((fibreVC 1728)⁻¹ * γ * fibreVC 1728).t = 0 ∧
+        (((fibreVC 1728)⁻¹ * γ * fibreVC 1728).u : Qbar) ^ 4 = 1 := by
+      have := hconjF
+      rw [specialFibre_goodModel_1728] at this
+      exact (smul_a4Model_eq_iff hAne _).mp this
+    set u : Qbarˣ := ((fibreVC 1728)⁻¹ * γ * fibreVC 1728).u with hudef
+    set ζ : Qbar := ((u⁻¹ : Qbarˣ) : Qbar) with hζdef
+    have hζ4 : ζ ^ 4 = 1 := by
+      rw [hζdef, ← Units.val_pow_eq_pow_val, inv_pow, ← Units.val_one (α := Qbar)]
+      exact congrArg Units.val (inv_eq_one.mpr (Units.ext hu4))
+    have hζ0 : ζ ≠ 0 := zeta_ne_zero_of_pow_eq_one (n := 4) (by norm_num) hζ4
+    obtain ⟨m', hm', hζs⟩ := monodromy_full_three_quarters ζ hζ4
+    have hftvc : fibreTwistVC ζ hζ0 = (fibreVC 1728)⁻¹ * γ * fibreVC 1728 := by
+      rw [variableChange_eq_of_rst_eq_zero _ hr hs ht]
+      change (⟨(Units.mk0 ζ hζ0)⁻¹, 0, 0, 0⟩ : VariableChange Qbar) = ⟨u, 0, 0, 0⟩
+      have : Units.mk0 ζ hζ0 = u⁻¹ := Units.ext (by rw [Units.val_mk0, hζdef])
+      rw [this, inv_inv]
+    refine ⟨⟨m', hm'⟩, ?_⟩
+    have hgT : addOrderOf (nearTransport 1728 ⟨m', hm'⟩ g) = p :=
+      (AddEquiv.addOrderOf_eq _ g).trans hg
+    suffices h : (bridge3Specialise p 1728
+          ⟨AddSubgroup.zmultiples (nearTransport 1728 ⟨m', hm'⟩ g),
+            nearTransport 1728 ⟨m', hm'⟩ g, hgT, rfl⟩).1 =
+        (bridge3Specialise p 1728 G').1 by
+      have := (bridge3Specialise p 1728).injective (Subtype.ext h)
+      rw [hG1, b3Act_zmultiples, ← this]
+    rw [bridge3Specialise_zmultiples p 1728 (nearTransport 1728 ⟨m', hm'⟩ g) hgT,
+      redTorsionEquiv_scaleAddEquiv_nearTransport_1728 p ⟨m', hm'⟩ hζs hζ0 hζ4 g hg,
+      ← hP₀def]
+    rw [hmap, AddMonoidHom.map_zmultiples]
+    congr 1
+    have hftvc_smul : fibreTwistVC ζ hζ0 • specialFibre (goodModel 1728) =
+        specialFibre (goodModel 1728) := hftvc ▸ hconjF
+    calc fibreAddEquiv 1728 (fibreTwistEquiv_1728 ζ hζ0 hζ4 P₀)
+        = vcEquivOfSMulEq (fibreVC 1728) (fibreVC_smul 1728)
+            (vcEquivOfSMulEq (fibreTwistVC ζ hζ0) hftvc_smul P₀) := rfl
+      _ = vcEquivOfSMulEq (fibreVC 1728) (fibreVC_smul 1728)
+            (vcEquivOfSMulEq ((fibreVC 1728)⁻¹ * γ * fibreVC 1728) hconjF P₀) := by
+          rw [vcEquivOfSMulEq_congr hftvc hftvc_smul hconjF]
+      _ = vcEquivOfSMulEq γ hγ (vcEquivOfSMulEq (fibreVC 1728) (fibreVC_smul 1728) P₀) :=
+          vcEquivOfSMulEq_conj (fibreVC_smul 1728) hγ P₀
+      _ = _ := rfl
+
+theorem b3_specialisationEquivariance (p : ℕ) [Fact p.Prime] [NeZero p] (j₀ : Qbar) :
+    ∃ β : CycSubH (nearCurve j₀) p ≃ CycSub (WeierstrassCurve.ofJ j₀) p,
+      ∀ G G' : CycSubH (nearCurve j₀) p,
+        (∃ m : HahnSeries.monodromy Qbar, b3Act j₀ m G.1 = G'.1) ↔
+          SameOrbit (WeierstrassCurve.ofJ j₀) (β G).1 (β G').1 := by
+  refine ⟨bridge3Specialise p j₀, fun G G' => ?_⟩
+  by_cases hz : j₀ = 0
+  · subst hz; exact b3_specialisationEquivariance_zero p G G'
+  by_cases h17 : j₀ = 1728
+  · subst h17; exact b3_specialisationEquivariance_1728 p G G'
+  exact b3_specialisationEquivariance_generic p j₀ hz h17 G G'
+
+end ModularCurve.B3
+end
+
+namespace ModularCurve
+p2m_export "ModularCurve" "CycSub SameOrbit"
+namespace B3
+p2m_export "ModularCurve.B3" "coeff_zero_mul_of_integral orderTop_pow_nonneg integralO \
+  mem_integralO resO resO_apply IntegralCoeffs specialFibre val_inv_sU scaleVC goodModel \
+  scaleVC_zero scaleVC_1728 scaleVC_of_ne goodModel_eq_nearCurve"
+p2m_open "ModularCurve.B3 ModularCurve"
+
+open ModularCurve.TatePoint
+
+private theorem orderTop_coeff_PsiSq_nonneg (W : WeierstrassCurve H) (hW : IntegralCoeffs W) (n : ℤ)
+    (k : ℕ) : 0 ≤ ((W.ΨSq n).coeff k).orderTop :=
+  orderTop_coeff_ΨSq_nonneg W hW n k
+
+private theorem orderTop_leadingCoeff_PsiSq_eq_zero (W : WeierstrassCurve H) (n : ℤ)
+    (hn : (n : H) ≠ 0) : (W.ΨSq n).leadingCoeff.orderTop = 0 :=
+  @orderTop_leadingCoeff_ΨSq_eq_zero W n hn
+
+private theorem specialFibre_Delta (W : WeierstrassCurve H) (hW : IntegralCoeffs W) :
+    (specialFibre W).Δ = W.Δ.coeff 0 :=
+  specialFibre_Δ W hW
+
+end ModularCurve.B3
+
+open ModularCurve.TatePoint
+open scoped Classical
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_B3_isElliptic_specialFibre.ModularCurve
+  _root_.ModularCurve.B3 _root_.P2MW.S_ModularCurve_B3_isElliptic_specialFibre.ModularCurve.B3 in
+theorem solution (W : WeierstrassCurve H)
+    (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0) : (specialFibre W).IsElliptic :=
+  ModularCurve.B3.isElliptic_specialFibre W hW hΔ
+
+end S_ModularCurve_B3_isElliptic_specialFibre
+end P2MW
+export P2MW.S_ModularCurve_B3_isElliptic_specialFibre (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve.TatePoint
+open scoped Classical
+theorem ModularCurve.B3.isElliptic_specialFibre (W : WeierstrassCurve H)
+    (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0)
+    : (specialFibre W).IsElliptic :=
+  solution W hW hΔ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_isElliptic_specialFibre_goodModel.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_isElliptic_specialFibre_goodModel.lean
new file mode 100644
index 0000000000..29060ec5bb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_isElliptic_specialFibre_goodModel.lean
@@ -0,0 +1,481 @@
+/-
+Based on Prove2Me node ModularCurve.B3.isElliptic_specialFibre_goodModel
+(5bbe4276-f96f-548b-ac18-5f4b97033ed6) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a96035e8-f888-57de-b30a-2dde1d5b46cd
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_SpecialisationVocab
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_TatePoint
+
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Ellipticity of the special fibre of the good model
+
+Theorem statement: `ModularCurve.B3.isElliptic_specialFibre_goodModel`
+(`5bbe4276-f96f-548b-ac18-5f4b97033ed6`), by Claude, 2026-09-05.
+
+Proof: submission `a96035e8-f888-57de-b30a-2dde1d5b46cd`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $j_0$ be an element of `Qbar`, the algebraic closure of $\mathbb{Q}$. Over the field `H` one
+forms `nearCurve j₀`, the Weierstrass curve `WeierstrassCurve.ofJ (jNear j₀)` attached by the
+standard formulae to the element `jNear j₀` of `H`, and then `goodModel j₀`, the result of acting on
+`nearCurve j₀` by the variable change `scaleVC j₀`; the latter is $\langle
+sU(2/12),\,-(\mathrm{jNear}\,0-1728)^2/12,\,-(\mathrm{jNear}\,0-1728)/2,\,(\mathrm{jNear}
+\,0-1728)^3/24\rangle$
+when $j_0=0$, it is $\langle sU(9/12),0,0,0\rangle$ when $j_0=1728$, and it is the identity variable
+change otherwise. Its special fibre `specialFibre (goodModel j₀)` is the Weierstrass curve over
+`Qbar` whose five coefficients $a_1,a_2,a_3,a_4,a_6$ are the coefficients at index $0$ of the
+corresponding coefficients of `goodModel j₀`. The assertion is that this Weierstrass curve over
+`Qbar` satisfies `IsElliptic`, i.e. its discriminant $\Delta$ is a unit, equivalently nonzero since
+`Qbar` is a field. No hypothesis is imposed on $j_0$: the conclusion holds for every value,
+including $0$ and $1728$.
+
+This is the good-reduction statement for the chosen integral model at a given $j$-value: the closed
+fibre of `goodModel j₀` is again an elliptic curve, so that its nonsingular points form the full
+group of points and reduction of torsion can be studied on it. It is used where the reduction map on
+torsion of the model is set up.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_B3_isElliptic_specialFibre_goodModel.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_B3_isElliptic_specialFibre_goodModel
+
+
+open scoped Classical
+open ModularCurve.TatePoint ModularCurve.B3 WeierstrassCurve
+
+noncomputable section
+
+namespace S12B3
+
+abbrev sMon : H := HahnSeries.single (1 : ℚ) (1 : Qbar)
+
+scoped instance charZero_H : CharZero H :=
+  (RingHom.charZero_iff (HahnSeries.C_injective (Γ := ℚ) (R := Qbar))).mp inferInstance
+
+theorem C_ofNat (n : ℕ) [n.AtLeastTwo] :
+    (HahnSeries.C (OfNat.ofNat n : Qbar) : H) = (OfNat.ofNat n : H) := map_ofNat _ n
+
+theorem coeff_zero_C (c : Qbar) : (HahnSeries.C c : H).coeff 0 = c := by
+  rw [HahnSeries.C_apply, HahnSeries.coeff_single_same]
+
+theorem coeff_zero_ofNat (n : ℕ) [n.AtLeastTwo] :
+    (OfNat.ofNat n : H).coeff 0 = (OfNat.ofNat n : Qbar) := by
+  rw [← C_ofNat, coeff_zero_C]
+
+theorem coeff_zero_sMon : sMon.coeff 0 = 0 :=
+  HahnSeries.coeff_single_of_ne (by norm_num)
+
+theorem coeff_one_jNear (j₀ : Qbar) : (jNear j₀).coeff 1 = 1 := by
+  simp only [jNear, HahnSeries.C_apply, HahnSeries.coeff_add, HahnSeries.coeff_single_same,
+    HahnSeries.coeff_single_of_ne (one_ne_zero : (1 : ℚ) ≠ 0), zero_add]
+
+theorem jNear_ne_C (j₀ c : Qbar) : jNear j₀ ≠ HahnSeries.C c := by
+  intro h
+  have h1 := congrArg (fun x : H => x.coeff (1 : ℚ)) h
+  simp only [coeff_one_jNear, HahnSeries.C_apply,
+    HahnSeries.coeff_single_of_ne (one_ne_zero : (1 : ℚ) ≠ 0)] at h1
+  exact one_ne_zero h1
+
+theorem jNear_ne_zero (j₀ : Qbar) : jNear j₀ ≠ 0 := by
+  simpa using jNear_ne_C j₀ 0
+
+theorem jNear_ne_1728 (j₀ : Qbar) : jNear j₀ ≠ 1728 := by
+  rw [← C_ofNat]; exact jNear_ne_C j₀ _
+
+theorem nearCurve_eq (j₀ : Qbar) : nearCurve j₀ = ofJNe0Or1728 (jNear j₀) := by
+  unfold nearCurve
+  exact ofJ_ne_0_ne_1728 _ (jNear_ne_zero j₀) (jNear_ne_1728 j₀)
+
+theorem jNear_sub (j₀ : Qbar) : jNear j₀ - 1728 = HahnSeries.C (j₀ - 1728) + sMon := by
+  rw [jNear, map_sub, C_ofNat]; ring
+
+theorem single_mem {q : ℚ} (hq : 0 ≤ q) (c : Qbar) : (HahnSeries.single q c : H) ∈ integralO := by
+  rw [mem_integralO]
+  by_cases hc : c = 0
+  · simp [hc]
+  · rw [HahnSeries.orderTop_single hc]; exact_mod_cast hq
+
+theorem C_mem (c : Qbar) : (HahnSeries.C c : H) ∈ integralO := by
+  rw [HahnSeries.C_apply]; exact single_mem le_rfl c
+
+theorem sMon_mem : sMon ∈ integralO := single_mem zero_le_one 1
+
+theorem ofNat_mem (n : ℕ) [n.AtLeastTwo] : (OfNat.ofNat n : H) ∈ integralO := by
+  rw [← C_ofNat]; exact C_mem _
+
+theorem inv_ofNat_mem (n : ℕ) [n.AtLeastTwo] : ((OfNat.ofNat n : H)⁻¹) ∈ integralO := by
+  rw [← C_ofNat, ← map_inv₀]; exact C_mem _
+
+theorem w_mem (j₀ : Qbar) : jNear j₀ - 1728 ∈ integralO := by
+  rw [jNear_sub]; exact Subring.add_mem _ (C_mem _) sMon_mem
+
+theorem coeff_zero_w (j₀ : Qbar) : (jNear j₀ - 1728).coeff 0 = j₀ - 1728 := by
+  rw [jNear_sub, HahnSeries.coeff_add, coeff_zero_C, coeff_zero_sMon, add_zero]
+
+theorem orderTop_nonneg_of_mem {x : H} (hx : x ∈ integralO) : 0 ≤ x.orderTop := mem_integralO.mp hx
+
+theorem coeff_zero_mul_mem {x y : H} (hx : x ∈ integralO) (hy : y ∈ integralO) :
+    (x * y).coeff 0 = x.coeff 0 * y.coeff 0 :=
+  coeff_zero_mul_of_integral (mem_integralO.mp hx) (mem_integralO.mp hy)
+
+theorem coeff_zero_pow_mem {x : H} (hx : x ∈ integralO) (k : ℕ) :
+    (x ^ k).coeff 0 = x.coeff 0 ^ k :=
+  coeff_zero_pow_of_integral (mem_integralO.mp hx) k
+
+theorem delta_j1728 : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).Δ = 2985984 := by
+  simp only [WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄, WeierstrassCurve.b₆,
+    WeierstrassCurve.b₈]
+  norm_num
+
+theorem c4_j1728 : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).c₄ = 1728 := by
+  simp only [WeierstrassCurve.c₄, WeierstrassCurve.b₂, WeierstrassCurve.b₄]
+  norm_num
+
+theorem delta_j0 (a : Qbar) : (⟨0, 0, 0, 0, a⟩ : WeierstrassCurve Qbar).Δ = -432 * a ^ 2 := by
+  simp only [WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄, WeierstrassCurve.b₆,
+    WeierstrassCurve.b₈]
+  ring
+
+theorem c4_j0 (a : Qbar) : (⟨0, 0, 0, 0, a⟩ : WeierstrassCurve Qbar).c₄ = 0 := by
+  simp only [WeierstrassCurve.c₄, WeierstrassCurve.b₂, WeierstrassCurve.b₄]
+  ring
+
+theorem j_eq (E : WeierstrassCurve Qbar) [E.IsElliptic] : E.j = E.c₄ ^ 3 * E.Δ⁻¹ := by
+  rw [WeierstrassCurve.j, Units.val_inv_eq_inv_val, WeierstrassCurve.coe_Δ', mul_comm]
+
+section Generic
+
+variable {j₀ : Qbar} (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728)
+include h0 h1728
+
+theorem goodModel_generic : goodModel j₀ = ofJNe0Or1728 (jNear j₀) := by
+  rw [goodModel_eq_nearCurve h0 h1728, nearCurve_eq]
+
+theorem specialFibre_generic : specialFibre (goodModel j₀) = ofJNe0Or1728 j₀ := by
+  rw [goodModel_generic h0 h1728]
+  have hw := w_mem j₀
+  have hc := coeff_zero_w j₀
+  ext
+  · change (jNear j₀ - 1728).coeff 0 = j₀ - 1728
+    exact hc
+  · change (0 : H).coeff 0 = 0
+    simp
+  · change (0 : H).coeff 0 = 0
+    simp
+  · change (-36 * (jNear j₀ - 1728) ^ 3).coeff 0 = -36 * (j₀ - 1728) ^ 3
+    rw [neg_mul, HahnSeries.coeff_neg, coeff_zero_mul_mem (ofNat_mem 36) (Subring.pow_mem _ hw 3),
+      coeff_zero_pow_mem hw, hc, coeff_zero_ofNat, neg_mul]
+  · change (-(jNear j₀ - 1728) ^ 5).coeff 0 = -(j₀ - 1728) ^ 5
+    rw [HahnSeries.coeff_neg, coeff_zero_pow_mem hw, hc]
+
+theorem integralCoeffs_generic : IntegralCoeffs (goodModel j₀) := by
+  rw [goodModel_generic h0 h1728]
+  have hw := w_mem j₀
+  refine ⟨orderTop_nonneg_of_mem hw, by simp [ofJNe0Or1728], by simp [ofJNe0Or1728],
+    orderTop_nonneg_of_mem ?_, orderTop_nonneg_of_mem ?_⟩
+  · change -36 * (jNear j₀ - 1728) ^ 3 ∈ integralO
+    exact Subring.mul_mem _ (Subring.neg_mem _ (ofNat_mem 36)) (Subring.pow_mem _ hw 3)
+  · change -(jNear j₀ - 1728) ^ 5 ∈ integralO
+    exact Subring.neg_mem _ (Subring.pow_mem _ hw 5)
+
+theorem isGood_generic : IntegralCoeffs (goodModel j₀) ∧
+    ∃ h : (specialFibre (goodModel j₀)).IsElliptic,
+      @WeierstrassCurve.j Qbar _ (specialFibre (goodModel j₀)) h = j₀ := by
+  refine ⟨integralCoeffs_generic h0 h1728, ?_⟩
+  rw [specialFibre_generic h0 h1728]
+  have : Fact (IsUnit j₀) := ⟨isUnit_iff_ne_zero.mpr h0⟩
+  have : Fact (IsUnit (j₀ - 1728)) := ⟨isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr h1728)⟩
+  exact ⟨inferInstance, ofJNe0Or1728_j j₀⟩
+
+end Generic
+
+section J1728
+
+theorem jNear_1728_sub : jNear 1728 - 1728 = sMon := by
+  rw [jNear_sub, sub_self, map_zero, zero_add]
+
+theorem goodModel_1728_a₁ : (goodModel 1728).a₁ = HahnSeries.single (1 / 4 : ℚ) (1 : Qbar) := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₁]
+  simp only [ofJNe0Or1728, jNear_1728_sub, val_inv_sU, mul_zero, add_zero]
+  rw [HahnSeries.single_mul_single]; norm_num
+
+theorem goodModel_1728_a₂ : (goodModel 1728).a₂ = 0 := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₂]
+  simp [ofJNe0Or1728]
+
+theorem goodModel_1728_a₃ : (goodModel 1728).a₃ = 0 := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₃]
+  simp [ofJNe0Or1728]
+
+theorem goodModel_1728_a₄ : (goodModel 1728).a₄ = -36 := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₄]
+  simp only [ofJNe0Or1728, jNear_1728_sub, val_inv_sU, mul_zero, zero_mul, sub_zero, add_zero,
+    zero_pow (by norm_num : (2:ℕ) ≠ 0)]
+  rw [HahnSeries.single_pow, show (-36 : H) * sMon ^ 3 = sMon ^ 3 * (-36) from mul_comm _ _,
+    ← mul_assoc, HahnSeries.single_pow, HahnSeries.single_mul_single]
+  norm_num
+
+theorem goodModel_1728_a₆ : (goodModel 1728).a₆ = -HahnSeries.single (1 / 2 : ℚ) (1 : Qbar) := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₆]
+  simp only [ofJNe0Or1728, jNear_1728_sub, val_inv_sU, mul_zero, zero_mul, sub_zero, add_zero,
+    zero_pow (by norm_num : (2:ℕ) ≠ 0), zero_pow (by norm_num : (3:ℕ) ≠ 0)]
+  rw [mul_neg, HahnSeries.single_pow, HahnSeries.single_pow, HahnSeries.single_mul_single]
+  norm_num
+
+theorem specialFibre_1728 : specialFibre (goodModel 1728) = ⟨0, 0, 0, -36, 0⟩ := by
+  ext
+  · change (goodModel 1728).a₁.coeff 0 = 0
+    rw [goodModel_1728_a₁]; exact HahnSeries.coeff_single_of_ne (by norm_num)
+  · change (goodModel 1728).a₂.coeff 0 = 0
+    rw [goodModel_1728_a₂]; simp
+  · change (goodModel 1728).a₃.coeff 0 = 0
+    rw [goodModel_1728_a₃]; simp
+  · change (goodModel 1728).a₄.coeff 0 = -36
+    rw [goodModel_1728_a₄, show (-36 : H) = -(36 : H) from rfl, HahnSeries.coeff_neg,
+      coeff_zero_ofNat]
+  · change (goodModel 1728).a₆.coeff 0 = 0
+    rw [goodModel_1728_a₆, HahnSeries.coeff_neg, HahnSeries.coeff_single_of_ne (by
+      norm_num), neg_zero]
+
+theorem integralCoeffs_1728 : IntegralCoeffs (goodModel 1728) := by
+  refine ⟨?_, ?_, ?_, ?_, ?_⟩
+  · rw [goodModel_1728_a₁]; exact orderTop_nonneg_of_mem (single_mem (by norm_num) _)
+  · rw [goodModel_1728_a₂]; simp
+  · rw [goodModel_1728_a₃]; simp
+  · rw [goodModel_1728_a₄]; exact orderTop_nonneg_of_mem (Subring.neg_mem _ (ofNat_mem 36))
+  · rw [goodModel_1728_a₆]
+    exact orderTop_nonneg_of_mem (Subring.neg_mem _ (single_mem (by norm_num) _))
+
+theorem isGood_1728 : IntegralCoeffs (goodModel 1728) ∧
+    ∃ h : (specialFibre (goodModel 1728)).IsElliptic,
+      @WeierstrassCurve.j Qbar _ (specialFibre (goodModel 1728)) h = 1728 := by
+  refine ⟨integralCoeffs_1728, ?_⟩
+  rw [specialFibre_1728]
+  have hΔ : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).Δ ≠ 0 := by
+    rw [delta_j1728]; norm_num
+  have : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+  refine ⟨inferInstance, ?_⟩
+  rw [j_eq, c4_j1728, delta_j1728]
+  norm_num
+
+end J1728
+
+section J0
+
+abbrev mEl : H := jNear 0 - 1728
+
+theorem jNear_zero : jNear 0 = sMon := by rw [jNear, map_zero, zero_add]
+
+theorem mEl_add : mEl + 1728 = sMon := by rw [mEl, jNear_zero]; ring
+
+theorem mEl_mem : mEl ∈ integralO := w_mem 0
+
+theorem coeff_zero_mEl : mEl.coeff 0 = -1728 := by rw [mEl, coeff_zero_w, zero_sub]
+
+theorem uInv_pow_mul_sMon_four :
+    (HahnSeries.single (-(2 / 12) : ℚ) (1 : Qbar) : H) ^ 4 * sMon = HahnSeries.single (1 / 3 : ℚ) 1
+      := by
+  rw [HahnSeries.single_pow, HahnSeries.single_mul_single]; norm_num
+
+theorem uInv_pow_mul_sMon_six :
+    (HahnSeries.single (-(2 / 12) : ℚ) (1 : Qbar) : H) ^ 6 * sMon = 1 := by
+  rw [HahnSeries.single_pow, HahnSeries.single_mul_single]; norm_num
+
+theorem goodModel_0_a₁ : (goodModel 0).a₁ = 0 := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₁]
+  simp only [ofJNe0Or1728]
+  ring
+
+theorem goodModel_0_a₂ : (goodModel 0).a₂ = 0 := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₂]
+  simp only [ofJNe0Or1728]
+  ring
+
+theorem goodModel_0_a₃ : (goodModel 0).a₃ = 0 := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₃]
+  simp only [ofJNe0Or1728]
+  ring
+
+theorem goodModel_0_a₄ :
+    (goodModel 0).a₄ = HahnSeries.single (1 / 3 : ℚ) (1 : Qbar) * (-mEl ^ 3 / 48) := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₄]
+  simp only [ofJNe0Or1728, val_inv_sU]
+  have key : (-36 * (jNear 0 - 1728) ^ 3 - -(jNear 0 - 1728) / 2 * 0 +
+      2 * (-(jNear 0 - 1728) ^ 2 / 12) * 0 -
+      ((jNear 0 - 1728) ^ 3 / 24 + -(jNear 0 - 1728) ^ 2 / 12 * (-(jNear 0 - 1728) / 2)) *
+        (jNear 0 - 1728) +
+      3 * (-(jNear 0 - 1728) ^ 2 / 12) ^ 2 - 2 * (-(jNear 0 - 1728) / 2) * ((jNear 0 - 1728) ^ 3 /
+        24))
+      = sMon * (-mEl ^ 3 / 48) := by
+    rw [← mEl_add]; simp only [mEl]; ring
+  rw [key, ← mul_assoc, uInv_pow_mul_sMon_four]
+
+theorem goodModel_0_a₆ : (goodModel 0).a₆ = mEl ^ 5 / 864 := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₆]
+  simp only [ofJNe0Or1728, val_inv_sU]
+  have key : (-(jNear 0 - 1728) ^ 5 + -(jNear 0 - 1728) ^ 2 / 12 * (-36 * (jNear 0 - 1728) ^ 3) +
+      (-(jNear 0 - 1728) ^ 2 / 12) ^ 2 * 0 + (-(jNear 0 - 1728) ^ 2 / 12) ^ 3 -
+      (jNear 0 - 1728) ^ 3 / 24 * 0 - ((jNear 0 - 1728) ^ 3 / 24) ^ 2 -
+      -(jNear 0 - 1728) ^ 2 / 12 * ((jNear 0 - 1728) ^ 3 / 24) * (jNear 0 - 1728))
+      = sMon * (mEl ^ 5 / 864) := by
+    rw [← mEl_add]; simp only [mEl]; ring
+  rw [key, ← mul_assoc, uInv_pow_mul_sMon_six, one_mul]
+
+theorem a₄_0_mem : HahnSeries.single (1 / 3 : ℚ) (1 : Qbar) * (-mEl ^ 3 / 48) ∈ integralO := by
+  refine Subring.mul_mem _ (single_mem (by norm_num) _) ?_
+  rw [div_eq_mul_inv]
+  exact Subring.mul_mem _ (Subring.neg_mem _ (Subring.pow_mem _ mEl_mem 3)) (inv_ofNat_mem 48)
+
+theorem a₆_0_mem : mEl ^ 5 / 864 ∈ integralO := by
+  rw [div_eq_mul_inv]
+  exact Subring.mul_mem _ (Subring.pow_mem _ mEl_mem 5) (inv_ofNat_mem 864)
+
+theorem coeff_zero_a₆_0 : (mEl ^ 5 / 864).coeff 0 = (-1728) ^ 5 / 864 := by
+  rw [div_eq_mul_inv, coeff_zero_mul_mem (Subring.pow_mem _ mEl_mem 5) (inv_ofNat_mem 864),
+    coeff_zero_pow_mem mEl_mem, coeff_zero_mEl, ← C_ofNat, ← map_inv₀, coeff_zero_C, div_eq_mul_inv]
+
+theorem specialFibre_0 : specialFibre (goodModel 0) = ⟨0, 0, 0, 0, (-1728) ^ 5 / 864⟩ := by
+  ext
+  · change (goodModel 0).a₁.coeff 0 = 0
+    rw [goodModel_0_a₁]; simp
+  · change (goodModel 0).a₂.coeff 0 = 0
+    rw [goodModel_0_a₂]; simp
+  · change (goodModel 0).a₃.coeff 0 = 0
+    rw [goodModel_0_a₃]; simp
+  · change (goodModel 0).a₄.coeff 0 = 0
+    rw [goodModel_0_a₄, coeff_zero_mul_mem (single_mem (by norm_num) _)
+      (by simpa [div_eq_mul_inv] using
+        (Subring.mul_mem _ (Subring.neg_mem _ (Subring.pow_mem _ mEl_mem 3)) (inv_ofNat_mem 48))),
+      HahnSeries.coeff_single_of_ne (by norm_num), zero_mul]
+  · change (goodModel 0).a₆.coeff 0 = (-1728) ^ 5 / 864
+    rw [goodModel_0_a₆, coeff_zero_a₆_0]
+
+theorem integralCoeffs_0 : IntegralCoeffs (goodModel 0) := by
+  refine ⟨?_, ?_, ?_, ?_, ?_⟩
+  · rw [goodModel_0_a₁]; simp
+  · rw [goodModel_0_a₂]; simp
+  · rw [goodModel_0_a₃]; simp
+  · rw [goodModel_0_a₄]; exact orderTop_nonneg_of_mem a₄_0_mem
+  · rw [goodModel_0_a₆]; exact orderTop_nonneg_of_mem a₆_0_mem
+
+theorem isGood_0 : IntegralCoeffs (goodModel 0) ∧
+    ∃ h : (specialFibre (goodModel 0)).IsElliptic,
+      @WeierstrassCurve.j Qbar _ (specialFibre (goodModel 0)) h = 0 := by
+  refine ⟨integralCoeffs_0, ?_⟩
+  rw [specialFibre_0]
+  have ha : ((-1728 : Qbar) ^ 5 / 864) ≠ 0 := by norm_num
+  have hΔ : (⟨0, 0, 0, 0, (-1728 : Qbar) ^ 5 / 864⟩ : WeierstrassCurve Qbar).Δ ≠ 0 := by
+    rw [delta_j0]; exact mul_ne_zero (by norm_num) (pow_ne_zero _ ha)
+  have : (⟨0, 0, 0, 0, (-1728 : Qbar) ^ 5 / 864⟩ : WeierstrassCurve Qbar).IsElliptic :=
+    ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+  refine ⟨inferInstance, ?_⟩
+  rw [j_eq, c4_j0]
+  ring
+
+end J0
+
+end S12B3
+
+namespace S12B3
+
+theorem orderTop_C_add_sMon {a : Qbar} (ha : a ≠ 0) : (HahnSeries.C a + sMon : H).orderTop = 0 := by
+  have hC : (HahnSeries.C a : H).orderTop = 0 := by
+    rw [HahnSeries.C_apply, HahnSeries.orderTop_single ha]; rfl
+  have hs : (sMon : H).orderTop = 1 := by
+    rw [HahnSeries.orderTop_single one_ne_zero]; rfl
+  rw [HahnSeries.orderTop_add_eq_left (by rw [hC, hs]; exact zero_lt_one), hC]
+
+theorem orderTop_jNear {j₀ : Qbar} (h0 : j₀ ≠ 0) : (jNear j₀).orderTop = 0 := by
+  rw [jNear]; exact orderTop_C_add_sMon h0
+
+theorem orderTop_w' {j₀ : Qbar} (h : j₀ ≠ 1728) : (jNear j₀ - 1728).orderTop = 0 := by
+  rw [jNear_sub]; exact orderTop_C_add_sMon (sub_ne_zero.mpr h)
+
+theorem orderTop_pow_of_eq_zero {x : H} (hx : x.orderTop = 0) (n : ℕ) : (x ^ n).orderTop = 0 := by
+  induction n with
+  | zero => rw [pow_zero, HahnSeries.orderTop_one]
+  | succ n ih => rw [pow_succ, HahnSeries.orderTop_mul, ih, hx, add_zero]
+
+theorem delta_nearCurve (j₀ : Qbar) :
+    (nearCurve j₀).Δ = (jNear j₀) ^ 2 * (jNear j₀ - 1728) ^ 9 := by
+  rw [nearCurve_eq, WeierstrassCurve.ofJNe0Or1728_Δ]
+
+theorem orderTop_delta_nearCurve_generic {j₀ : Qbar} (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) :
+    (nearCurve j₀).Δ.orderTop = 0 := by
+  rw [delta_nearCurve, HahnSeries.orderTop_mul, orderTop_pow_of_eq_zero (orderTop_jNear h0),
+    orderTop_pow_of_eq_zero (orderTop_w' h1728), add_zero]
+
+theorem delta_goodModel_zero : (goodModel 0).Δ = mEl ^ 9 := by
+  rw [goodModel, WeierstrassCurve.variableChange_Δ, scaleVC_zero, delta_nearCurve, jNear_zero]
+  simp only [val_inv_sU]
+  rw [show (HahnSeries.single (-(2 / 12) : ℚ) (1 : Qbar) : H) ^ 12 * (sMon ^ 2 * (sMon - 1728) ^ 9)
+      = (HahnSeries.single (-(2 / 12) : ℚ) (1 : Qbar) ^ 12 * sMon ^ 2) * (sMon - 1728) ^ 9 by ring,
+    HahnSeries.single_pow, HahnSeries.single_pow, HahnSeries.single_mul_single]
+  norm_num
+  rw [mEl, jNear_zero]
+
+theorem orderTop_delta_goodModel_zero : (goodModel 0).Δ.orderTop = 0 := by
+  rw [delta_goodModel_zero]
+  exact orderTop_pow_of_eq_zero (by rw [mEl]; exact orderTop_w' (by norm_num)) 9
+
+theorem delta_goodModel_1728 : (goodModel 1728).Δ = (jNear 1728) ^ 2 := by
+  rw [goodModel, WeierstrassCurve.variableChange_Δ, scaleVC_1728, delta_nearCurve, jNear_1728_sub]
+  simp only [val_inv_sU]
+  rw [show (HahnSeries.single (-(9 / 12) : ℚ) (1 : Qbar) : H) ^ 12 * (jNear 1728 ^ 2 * sMon ^ 9)
+      = (HahnSeries.single (-(9 / 12) : ℚ) (1 : Qbar) ^ 12 * sMon ^ 9) * jNear 1728 ^ 2 by ring,
+    HahnSeries.single_pow, HahnSeries.single_pow, HahnSeries.single_mul_single]
+  norm_num
+
+theorem orderTop_delta_goodModel_1728 : (goodModel 1728).Δ.orderTop = 0 := by
+  rw [delta_goodModel_1728]
+  exact orderTop_pow_of_eq_zero (orderTop_jNear (by norm_num)) 2
+
+end S12B3
+end
+
+open ModularCurve.B3 ModularCurve.TatePoint WeierstrassCurve
+
+theorem solution (j₀ : Qbar) :
+    (specialFibre (goodModel j₀)).IsElliptic := by
+  rcases eq_or_ne j₀ 0 with rfl | h0
+  · exact S12B3.isGood_0.2.1
+  rcases eq_or_ne j₀ 1728 with rfl | h1728
+  · exact S12B3.isGood_1728.2.1
+  exact (S12B3.isGood_generic h0 h1728).2.1
+
+end S_ModularCurve_B3_isElliptic_specialFibre_goodModel
+end P2MW
+export P2MW.S_ModularCurve_B3_isElliptic_specialFibre_goodModel (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve.TatePoint
+theorem ModularCurve.B3.isElliptic_specialFibre_goodModel (j₀ : Qbar) :
+    (specialFibre (goodModel j₀)).IsElliptic :=
+  solution j₀
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_nearCurve_eq_ofJNe0Or1728.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_nearCurve_eq_ofJNe0Or1728.lean
new file mode 100644
index 0000000000..4842f4209b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_nearCurve_eq_ofJNe0Or1728.lean
@@ -0,0 +1,480 @@
+/-
+Based on Prove2Me node ModularCurve.B3.nearCurve_eq_ofJNe0Or1728
+(7de599c8-4815-5760-8ccf-ef715d7fdc66) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9d6861d9-9f71-5eae-b2d0-e89b2e347e5a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_SpecialisationVocab
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_TatePoint
+
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The near-curve is the explicit model at j₀+s
+
+Theorem statement: `ModularCurve.B3.nearCurve_eq_ofJNe0Or1728`
+(`7de599c8-4815-5760-8ccf-ef715d7fdc66`), by Claude, 2026-09-05.
+
+Proof: submission `9d6861d9-9f71-5eae-b2d0-e89b2e347e5a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\overline{\mathbb{Q}}$ denote the algebraic closure of $\mathbb{Q}$ (the abbreviation `Qbar`),
+and let $H$ be the field of Hahn series with rational exponents and coefficients in
+$\overline{\mathbb{Q}}$, whose uniformiser $s$ is the series `HahnSeries.single (1 : ℚ) (1 : Qbar)`
+supported in exponent $1$ with coefficient $1$. For an element $j_0$ of $\overline{\mathbb{Q}}$, the
+project writes `jNear j₀` for the Hahn series $j_0 + s$, that is the constant series `HahnSeries.C
+j₀` plus the uniformiser, and `nearCurve j₀` for `WeierstrassCurve.ofJ (jNear j₀)`, Mathlib's
+Weierstrass curve over $H$ with prescribed $j$-invariant $j_0 + s$, which is defined by a case
+distinction according as the prescribed invariant is $0$, is $1728$, or is neither. The theorem
+asserts, for every $j_0$, the equality of Weierstrass curves over $H$
+$$\mathrm{nearCurve}(j_0) = \mathrm{ofJNe0Or1728}(j_0+s),$$
+where the right-hand side is Mathlib's explicit five-tuple of coefficients $a_1 = j-1728$, $a_2 =
+a_3 = 0$, $a_4 = -36(j-1728)^3$, $a_6 = -(j-1728)^5$ evaluated at $j = j_0 + s$. In other words, the
+case distinction in `WeierstrassCurve.ofJ` always resolves to the generic branch at the argument
+$j_0+s$, no hypothesis on $j_0$ being required.
+
+This is the statement that the one-parameter deformation $j_0+s$ of a $j$-value never meets the two
+exceptional points $j=0$, $j=1728$ of the $j$-line, so that the curve attached to it is given by the
+explicit global Weierstrass equation of the universal curve over $\mathbb{A}^1_j \setminus
+\{0,1728\}$. It is what makes the coefficients of the near-curve, and hence their orders of
+vanishing in $s$, available as explicit polynomials in $j_0+s$ in the subsequent study of reduction
+and of torsion points over $H$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_B3_nearCurve_eq_ofJNe0Or1728.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_B3_nearCurve_eq_ofJNe0Or1728
+
+
+open scoped Classical
+open ModularCurve.TatePoint ModularCurve.B3 WeierstrassCurve
+
+noncomputable section
+
+namespace S12B3
+
+abbrev sMon : H := HahnSeries.single (1 : ℚ) (1 : Qbar)
+
+scoped instance charZero_H : CharZero H :=
+  (RingHom.charZero_iff (HahnSeries.C_injective (Γ := ℚ) (R := Qbar))).mp inferInstance
+
+theorem C_ofNat (n : ℕ) [n.AtLeastTwo] :
+    (HahnSeries.C (OfNat.ofNat n : Qbar) : H) = (OfNat.ofNat n : H) := map_ofNat _ n
+
+theorem coeff_zero_C (c : Qbar) : (HahnSeries.C c : H).coeff 0 = c := by
+  rw [HahnSeries.C_apply, HahnSeries.coeff_single_same]
+
+theorem coeff_zero_ofNat (n : ℕ) [n.AtLeastTwo] :
+    (OfNat.ofNat n : H).coeff 0 = (OfNat.ofNat n : Qbar) := by
+  rw [← C_ofNat, coeff_zero_C]
+
+theorem coeff_zero_sMon : sMon.coeff 0 = 0 :=
+  HahnSeries.coeff_single_of_ne (by norm_num)
+
+theorem coeff_one_jNear (j₀ : Qbar) : (jNear j₀).coeff 1 = 1 := by
+  simp only [jNear, HahnSeries.C_apply, HahnSeries.coeff_add, HahnSeries.coeff_single_same,
+    HahnSeries.coeff_single_of_ne (one_ne_zero : (1 : ℚ) ≠ 0), zero_add]
+
+theorem jNear_ne_C (j₀ c : Qbar) : jNear j₀ ≠ HahnSeries.C c := by
+  intro h
+  have h1 := congrArg (fun x : H => x.coeff (1 : ℚ)) h
+  simp only [coeff_one_jNear, HahnSeries.C_apply,
+    HahnSeries.coeff_single_of_ne (one_ne_zero : (1 : ℚ) ≠ 0)] at h1
+  exact one_ne_zero h1
+
+theorem jNear_ne_zero (j₀ : Qbar) : jNear j₀ ≠ 0 := by
+  simpa using jNear_ne_C j₀ 0
+
+theorem jNear_ne_1728 (j₀ : Qbar) : jNear j₀ ≠ 1728 := by
+  rw [← C_ofNat]; exact jNear_ne_C j₀ _
+
+theorem nearCurve_eq (j₀ : Qbar) : nearCurve j₀ = ofJNe0Or1728 (jNear j₀) := by
+  unfold nearCurve
+  exact ofJ_ne_0_ne_1728 _ (jNear_ne_zero j₀) (jNear_ne_1728 j₀)
+
+theorem jNear_sub (j₀ : Qbar) : jNear j₀ - 1728 = HahnSeries.C (j₀ - 1728) + sMon := by
+  rw [jNear, map_sub, C_ofNat]; ring
+
+theorem single_mem {q : ℚ} (hq : 0 ≤ q) (c : Qbar) : (HahnSeries.single q c : H) ∈ integralO := by
+  rw [mem_integralO]
+  by_cases hc : c = 0
+  · simp [hc]
+  · rw [HahnSeries.orderTop_single hc]; exact_mod_cast hq
+
+theorem C_mem (c : Qbar) : (HahnSeries.C c : H) ∈ integralO := by
+  rw [HahnSeries.C_apply]; exact single_mem le_rfl c
+
+theorem sMon_mem : sMon ∈ integralO := single_mem zero_le_one 1
+
+theorem ofNat_mem (n : ℕ) [n.AtLeastTwo] : (OfNat.ofNat n : H) ∈ integralO := by
+  rw [← C_ofNat]; exact C_mem _
+
+theorem inv_ofNat_mem (n : ℕ) [n.AtLeastTwo] : ((OfNat.ofNat n : H)⁻¹) ∈ integralO := by
+  rw [← C_ofNat, ← map_inv₀]; exact C_mem _
+
+theorem w_mem (j₀ : Qbar) : jNear j₀ - 1728 ∈ integralO := by
+  rw [jNear_sub]; exact Subring.add_mem _ (C_mem _) sMon_mem
+
+theorem coeff_zero_w (j₀ : Qbar) : (jNear j₀ - 1728).coeff 0 = j₀ - 1728 := by
+  rw [jNear_sub, HahnSeries.coeff_add, coeff_zero_C, coeff_zero_sMon, add_zero]
+
+theorem orderTop_nonneg_of_mem {x : H} (hx : x ∈ integralO) : 0 ≤ x.orderTop := mem_integralO.mp hx
+
+theorem coeff_zero_mul_mem {x y : H} (hx : x ∈ integralO) (hy : y ∈ integralO) :
+    (x * y).coeff 0 = x.coeff 0 * y.coeff 0 :=
+  coeff_zero_mul_of_integral (mem_integralO.mp hx) (mem_integralO.mp hy)
+
+theorem coeff_zero_pow_mem {x : H} (hx : x ∈ integralO) (k : ℕ) :
+    (x ^ k).coeff 0 = x.coeff 0 ^ k :=
+  coeff_zero_pow_of_integral (mem_integralO.mp hx) k
+
+theorem delta_j1728 : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).Δ = 2985984 := by
+  simp only [WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄, WeierstrassCurve.b₆,
+    WeierstrassCurve.b₈]
+  norm_num
+
+theorem c4_j1728 : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).c₄ = 1728 := by
+  simp only [WeierstrassCurve.c₄, WeierstrassCurve.b₂, WeierstrassCurve.b₄]
+  norm_num
+
+theorem delta_j0 (a : Qbar) : (⟨0, 0, 0, 0, a⟩ : WeierstrassCurve Qbar).Δ = -432 * a ^ 2 := by
+  simp only [WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄, WeierstrassCurve.b₆,
+    WeierstrassCurve.b₈]
+  ring
+
+theorem c4_j0 (a : Qbar) : (⟨0, 0, 0, 0, a⟩ : WeierstrassCurve Qbar).c₄ = 0 := by
+  simp only [WeierstrassCurve.c₄, WeierstrassCurve.b₂, WeierstrassCurve.b₄]
+  ring
+
+theorem j_eq (E : WeierstrassCurve Qbar) [E.IsElliptic] : E.j = E.c₄ ^ 3 * E.Δ⁻¹ := by
+  rw [WeierstrassCurve.j, Units.val_inv_eq_inv_val, WeierstrassCurve.coe_Δ', mul_comm]
+
+section Generic
+
+variable {j₀ : Qbar} (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728)
+include h0 h1728
+
+theorem goodModel_generic : goodModel j₀ = ofJNe0Or1728 (jNear j₀) := by
+  rw [goodModel_eq_nearCurve h0 h1728, nearCurve_eq]
+
+theorem specialFibre_generic : specialFibre (goodModel j₀) = ofJNe0Or1728 j₀ := by
+  rw [goodModel_generic h0 h1728]
+  have hw := w_mem j₀
+  have hc := coeff_zero_w j₀
+  ext
+  · change (jNear j₀ - 1728).coeff 0 = j₀ - 1728
+    exact hc
+  · change (0 : H).coeff 0 = 0
+    simp
+  · change (0 : H).coeff 0 = 0
+    simp
+  · change (-36 * (jNear j₀ - 1728) ^ 3).coeff 0 = -36 * (j₀ - 1728) ^ 3
+    rw [neg_mul, HahnSeries.coeff_neg, coeff_zero_mul_mem (ofNat_mem 36) (Subring.pow_mem _ hw 3),
+      coeff_zero_pow_mem hw, hc, coeff_zero_ofNat, neg_mul]
+  · change (-(jNear j₀ - 1728) ^ 5).coeff 0 = -(j₀ - 1728) ^ 5
+    rw [HahnSeries.coeff_neg, coeff_zero_pow_mem hw, hc]
+
+theorem integralCoeffs_generic : IntegralCoeffs (goodModel j₀) := by
+  rw [goodModel_generic h0 h1728]
+  have hw := w_mem j₀
+  refine ⟨orderTop_nonneg_of_mem hw, by simp [ofJNe0Or1728], by simp [ofJNe0Or1728],
+    orderTop_nonneg_of_mem ?_, orderTop_nonneg_of_mem ?_⟩
+  · change -36 * (jNear j₀ - 1728) ^ 3 ∈ integralO
+    exact Subring.mul_mem _ (Subring.neg_mem _ (ofNat_mem 36)) (Subring.pow_mem _ hw 3)
+  · change -(jNear j₀ - 1728) ^ 5 ∈ integralO
+    exact Subring.neg_mem _ (Subring.pow_mem _ hw 5)
+
+theorem isGood_generic : IntegralCoeffs (goodModel j₀) ∧
+    ∃ h : (specialFibre (goodModel j₀)).IsElliptic,
+      @WeierstrassCurve.j Qbar _ (specialFibre (goodModel j₀)) h = j₀ := by
+  refine ⟨integralCoeffs_generic h0 h1728, ?_⟩
+  rw [specialFibre_generic h0 h1728]
+  have : Fact (IsUnit j₀) := ⟨isUnit_iff_ne_zero.mpr h0⟩
+  have : Fact (IsUnit (j₀ - 1728)) := ⟨isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr h1728)⟩
+  exact ⟨inferInstance, ofJNe0Or1728_j j₀⟩
+
+end Generic
+
+section J1728
+
+theorem jNear_1728_sub : jNear 1728 - 1728 = sMon := by
+  rw [jNear_sub, sub_self, map_zero, zero_add]
+
+theorem goodModel_1728_a₁ : (goodModel 1728).a₁ = HahnSeries.single (1 / 4 : ℚ) (1 : Qbar) := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₁]
+  simp only [ofJNe0Or1728, jNear_1728_sub, val_inv_sU, mul_zero, add_zero]
+  rw [HahnSeries.single_mul_single]; norm_num
+
+theorem goodModel_1728_a₂ : (goodModel 1728).a₂ = 0 := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₂]
+  simp [ofJNe0Or1728]
+
+theorem goodModel_1728_a₃ : (goodModel 1728).a₃ = 0 := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₃]
+  simp [ofJNe0Or1728]
+
+theorem goodModel_1728_a₄ : (goodModel 1728).a₄ = -36 := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₄]
+  simp only [ofJNe0Or1728, jNear_1728_sub, val_inv_sU, mul_zero, zero_mul, sub_zero, add_zero,
+    zero_pow (by norm_num : (2:ℕ) ≠ 0)]
+  rw [HahnSeries.single_pow, show (-36 : H) * sMon ^ 3 = sMon ^ 3 * (-36) from mul_comm _ _,
+    ← mul_assoc, HahnSeries.single_pow, HahnSeries.single_mul_single]
+  norm_num
+
+theorem goodModel_1728_a₆ : (goodModel 1728).a₆ = -HahnSeries.single (1 / 2 : ℚ) (1 : Qbar) := by
+  rw [goodModel, scaleVC_1728, nearCurve_eq, variableChange_a₆]
+  simp only [ofJNe0Or1728, jNear_1728_sub, val_inv_sU, mul_zero, zero_mul, sub_zero, add_zero,
+    zero_pow (by norm_num : (2:ℕ) ≠ 0), zero_pow (by norm_num : (3:ℕ) ≠ 0)]
+  rw [mul_neg, HahnSeries.single_pow, HahnSeries.single_pow, HahnSeries.single_mul_single]
+  norm_num
+
+theorem specialFibre_1728 : specialFibre (goodModel 1728) = ⟨0, 0, 0, -36, 0⟩ := by
+  ext
+  · change (goodModel 1728).a₁.coeff 0 = 0
+    rw [goodModel_1728_a₁]; exact HahnSeries.coeff_single_of_ne (by norm_num)
+  · change (goodModel 1728).a₂.coeff 0 = 0
+    rw [goodModel_1728_a₂]; simp
+  · change (goodModel 1728).a₃.coeff 0 = 0
+    rw [goodModel_1728_a₃]; simp
+  · change (goodModel 1728).a₄.coeff 0 = -36
+    rw [goodModel_1728_a₄, show (-36 : H) = -(36 : H) from rfl, HahnSeries.coeff_neg,
+      coeff_zero_ofNat]
+  · change (goodModel 1728).a₆.coeff 0 = 0
+    rw [goodModel_1728_a₆, HahnSeries.coeff_neg, HahnSeries.coeff_single_of_ne (by
+      norm_num), neg_zero]
+
+theorem integralCoeffs_1728 : IntegralCoeffs (goodModel 1728) := by
+  refine ⟨?_, ?_, ?_, ?_, ?_⟩
+  · rw [goodModel_1728_a₁]; exact orderTop_nonneg_of_mem (single_mem (by norm_num) _)
+  · rw [goodModel_1728_a₂]; simp
+  · rw [goodModel_1728_a₃]; simp
+  · rw [goodModel_1728_a₄]; exact orderTop_nonneg_of_mem (Subring.neg_mem _ (ofNat_mem 36))
+  · rw [goodModel_1728_a₆]
+    exact orderTop_nonneg_of_mem (Subring.neg_mem _ (single_mem (by norm_num) _))
+
+theorem isGood_1728 : IntegralCoeffs (goodModel 1728) ∧
+    ∃ h : (specialFibre (goodModel 1728)).IsElliptic,
+      @WeierstrassCurve.j Qbar _ (specialFibre (goodModel 1728)) h = 1728 := by
+  refine ⟨integralCoeffs_1728, ?_⟩
+  rw [specialFibre_1728]
+  have hΔ : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).Δ ≠ 0 := by
+    rw [delta_j1728]; norm_num
+  have : (⟨0, 0, 0, -36, 0⟩ : WeierstrassCurve Qbar).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+  refine ⟨inferInstance, ?_⟩
+  rw [j_eq, c4_j1728, delta_j1728]
+  norm_num
+
+end J1728
+
+section J0
+
+abbrev mEl : H := jNear 0 - 1728
+
+theorem jNear_zero : jNear 0 = sMon := by rw [jNear, map_zero, zero_add]
+
+theorem mEl_add : mEl + 1728 = sMon := by rw [mEl, jNear_zero]; ring
+
+theorem mEl_mem : mEl ∈ integralO := w_mem 0
+
+theorem coeff_zero_mEl : mEl.coeff 0 = -1728 := by rw [mEl, coeff_zero_w, zero_sub]
+
+theorem uInv_pow_mul_sMon_four :
+    (HahnSeries.single (-(2 / 12) : ℚ) (1 : Qbar) : H) ^ 4 * sMon = HahnSeries.single (1 / 3 : ℚ) 1
+      := by
+  rw [HahnSeries.single_pow, HahnSeries.single_mul_single]; norm_num
+
+theorem uInv_pow_mul_sMon_six :
+    (HahnSeries.single (-(2 / 12) : ℚ) (1 : Qbar) : H) ^ 6 * sMon = 1 := by
+  rw [HahnSeries.single_pow, HahnSeries.single_mul_single]; norm_num
+
+theorem goodModel_0_a₁ : (goodModel 0).a₁ = 0 := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₁]
+  simp only [ofJNe0Or1728]
+  ring
+
+theorem goodModel_0_a₂ : (goodModel 0).a₂ = 0 := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₂]
+  simp only [ofJNe0Or1728]
+  ring
+
+theorem goodModel_0_a₃ : (goodModel 0).a₃ = 0 := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₃]
+  simp only [ofJNe0Or1728]
+  ring
+
+theorem goodModel_0_a₄ :
+    (goodModel 0).a₄ = HahnSeries.single (1 / 3 : ℚ) (1 : Qbar) * (-mEl ^ 3 / 48) := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₄]
+  simp only [ofJNe0Or1728, val_inv_sU]
+  have key : (-36 * (jNear 0 - 1728) ^ 3 - -(jNear 0 - 1728) / 2 * 0 +
+      2 * (-(jNear 0 - 1728) ^ 2 / 12) * 0 -
+      ((jNear 0 - 1728) ^ 3 / 24 + -(jNear 0 - 1728) ^ 2 / 12 * (-(jNear 0 - 1728) / 2)) *
+        (jNear 0 - 1728) +
+      3 * (-(jNear 0 - 1728) ^ 2 / 12) ^ 2 - 2 * (-(jNear 0 - 1728) / 2) * ((jNear 0 - 1728) ^ 3 /
+        24))
+      = sMon * (-mEl ^ 3 / 48) := by
+    rw [← mEl_add]; simp only [mEl]; ring
+  rw [key, ← mul_assoc, uInv_pow_mul_sMon_four]
+
+theorem goodModel_0_a₆ : (goodModel 0).a₆ = mEl ^ 5 / 864 := by
+  rw [goodModel, scaleVC_zero, nearCurve_eq, variableChange_a₆]
+  simp only [ofJNe0Or1728, val_inv_sU]
+  have key : (-(jNear 0 - 1728) ^ 5 + -(jNear 0 - 1728) ^ 2 / 12 * (-36 * (jNear 0 - 1728) ^ 3) +
+      (-(jNear 0 - 1728) ^ 2 / 12) ^ 2 * 0 + (-(jNear 0 - 1728) ^ 2 / 12) ^ 3 -
+      (jNear 0 - 1728) ^ 3 / 24 * 0 - ((jNear 0 - 1728) ^ 3 / 24) ^ 2 -
+      -(jNear 0 - 1728) ^ 2 / 12 * ((jNear 0 - 1728) ^ 3 / 24) * (jNear 0 - 1728))
+      = sMon * (mEl ^ 5 / 864) := by
+    rw [← mEl_add]; simp only [mEl]; ring
+  rw [key, ← mul_assoc, uInv_pow_mul_sMon_six, one_mul]
+
+theorem a₄_0_mem : HahnSeries.single (1 / 3 : ℚ) (1 : Qbar) * (-mEl ^ 3 / 48) ∈ integralO := by
+  refine Subring.mul_mem _ (single_mem (by norm_num) _) ?_
+  rw [div_eq_mul_inv]
+  exact Subring.mul_mem _ (Subring.neg_mem _ (Subring.pow_mem _ mEl_mem 3)) (inv_ofNat_mem 48)
+
+theorem a₆_0_mem : mEl ^ 5 / 864 ∈ integralO := by
+  rw [div_eq_mul_inv]
+  exact Subring.mul_mem _ (Subring.pow_mem _ mEl_mem 5) (inv_ofNat_mem 864)
+
+theorem coeff_zero_a₆_0 : (mEl ^ 5 / 864).coeff 0 = (-1728) ^ 5 / 864 := by
+  rw [div_eq_mul_inv, coeff_zero_mul_mem (Subring.pow_mem _ mEl_mem 5) (inv_ofNat_mem 864),
+    coeff_zero_pow_mem mEl_mem, coeff_zero_mEl, ← C_ofNat, ← map_inv₀, coeff_zero_C, div_eq_mul_inv]
+
+theorem specialFibre_0 : specialFibre (goodModel 0) = ⟨0, 0, 0, 0, (-1728) ^ 5 / 864⟩ := by
+  ext
+  · change (goodModel 0).a₁.coeff 0 = 0
+    rw [goodModel_0_a₁]; simp
+  · change (goodModel 0).a₂.coeff 0 = 0
+    rw [goodModel_0_a₂]; simp
+  · change (goodModel 0).a₃.coeff 0 = 0
+    rw [goodModel_0_a₃]; simp
+  · change (goodModel 0).a₄.coeff 0 = 0
+    rw [goodModel_0_a₄, coeff_zero_mul_mem (single_mem (by norm_num) _)
+      (by simpa [div_eq_mul_inv] using
+        (Subring.mul_mem _ (Subring.neg_mem _ (Subring.pow_mem _ mEl_mem 3)) (inv_ofNat_mem 48))),
+      HahnSeries.coeff_single_of_ne (by norm_num), zero_mul]
+  · change (goodModel 0).a₆.coeff 0 = (-1728) ^ 5 / 864
+    rw [goodModel_0_a₆, coeff_zero_a₆_0]
+
+theorem integralCoeffs_0 : IntegralCoeffs (goodModel 0) := by
+  refine ⟨?_, ?_, ?_, ?_, ?_⟩
+  · rw [goodModel_0_a₁]; simp
+  · rw [goodModel_0_a₂]; simp
+  · rw [goodModel_0_a₃]; simp
+  · rw [goodModel_0_a₄]; exact orderTop_nonneg_of_mem a₄_0_mem
+  · rw [goodModel_0_a₆]; exact orderTop_nonneg_of_mem a₆_0_mem
+
+theorem isGood_0 : IntegralCoeffs (goodModel 0) ∧
+    ∃ h : (specialFibre (goodModel 0)).IsElliptic,
+      @WeierstrassCurve.j Qbar _ (specialFibre (goodModel 0)) h = 0 := by
+  refine ⟨integralCoeffs_0, ?_⟩
+  rw [specialFibre_0]
+  have ha : ((-1728 : Qbar) ^ 5 / 864) ≠ 0 := by norm_num
+  have hΔ : (⟨0, 0, 0, 0, (-1728 : Qbar) ^ 5 / 864⟩ : WeierstrassCurve Qbar).Δ ≠ 0 := by
+    rw [delta_j0]; exact mul_ne_zero (by norm_num) (pow_ne_zero _ ha)
+  have : (⟨0, 0, 0, 0, (-1728 : Qbar) ^ 5 / 864⟩ : WeierstrassCurve Qbar).IsElliptic :=
+    ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+  refine ⟨inferInstance, ?_⟩
+  rw [j_eq, c4_j0]
+  ring
+
+end J0
+
+end S12B3
+
+namespace S12B3
+
+theorem orderTop_C_add_sMon {a : Qbar} (ha : a ≠ 0) : (HahnSeries.C a + sMon : H).orderTop = 0 := by
+  have hC : (HahnSeries.C a : H).orderTop = 0 := by
+    rw [HahnSeries.C_apply, HahnSeries.orderTop_single ha]; rfl
+  have hs : (sMon : H).orderTop = 1 := by
+    rw [HahnSeries.orderTop_single one_ne_zero]; rfl
+  rw [HahnSeries.orderTop_add_eq_left (by rw [hC, hs]; exact zero_lt_one), hC]
+
+theorem orderTop_jNear {j₀ : Qbar} (h0 : j₀ ≠ 0) : (jNear j₀).orderTop = 0 := by
+  rw [jNear]; exact orderTop_C_add_sMon h0
+
+theorem orderTop_w' {j₀ : Qbar} (h : j₀ ≠ 1728) : (jNear j₀ - 1728).orderTop = 0 := by
+  rw [jNear_sub]; exact orderTop_C_add_sMon (sub_ne_zero.mpr h)
+
+theorem orderTop_pow_of_eq_zero {x : H} (hx : x.orderTop = 0) (n : ℕ) : (x ^ n).orderTop = 0 := by
+  induction n with
+  | zero => rw [pow_zero, HahnSeries.orderTop_one]
+  | succ n ih => rw [pow_succ, HahnSeries.orderTop_mul, ih, hx, add_zero]
+
+theorem delta_nearCurve (j₀ : Qbar) :
+    (nearCurve j₀).Δ = (jNear j₀) ^ 2 * (jNear j₀ - 1728) ^ 9 := by
+  rw [nearCurve_eq, WeierstrassCurve.ofJNe0Or1728_Δ]
+
+theorem orderTop_delta_nearCurve_generic {j₀ : Qbar} (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) :
+    (nearCurve j₀).Δ.orderTop = 0 := by
+  rw [delta_nearCurve, HahnSeries.orderTop_mul, orderTop_pow_of_eq_zero (orderTop_jNear h0),
+    orderTop_pow_of_eq_zero (orderTop_w' h1728), add_zero]
+
+theorem delta_goodModel_zero : (goodModel 0).Δ = mEl ^ 9 := by
+  rw [goodModel, WeierstrassCurve.variableChange_Δ, scaleVC_zero, delta_nearCurve, jNear_zero]
+  simp only [val_inv_sU]
+  rw [show (HahnSeries.single (-(2 / 12) : ℚ) (1 : Qbar) : H) ^ 12 * (sMon ^ 2 * (sMon - 1728) ^ 9)
+      = (HahnSeries.single (-(2 / 12) : ℚ) (1 : Qbar) ^ 12 * sMon ^ 2) * (sMon - 1728) ^ 9 by ring,
+    HahnSeries.single_pow, HahnSeries.single_pow, HahnSeries.single_mul_single]
+  norm_num
+  rw [mEl, jNear_zero]
+
+theorem orderTop_delta_goodModel_zero : (goodModel 0).Δ.orderTop = 0 := by
+  rw [delta_goodModel_zero]
+  exact orderTop_pow_of_eq_zero (by rw [mEl]; exact orderTop_w' (by norm_num)) 9
+
+theorem delta_goodModel_1728 : (goodModel 1728).Δ = (jNear 1728) ^ 2 := by
+  rw [goodModel, WeierstrassCurve.variableChange_Δ, scaleVC_1728, delta_nearCurve, jNear_1728_sub]
+  simp only [val_inv_sU]
+  rw [show (HahnSeries.single (-(9 / 12) : ℚ) (1 : Qbar) : H) ^ 12 * (jNear 1728 ^ 2 * sMon ^ 9)
+      = (HahnSeries.single (-(9 / 12) : ℚ) (1 : Qbar) ^ 12 * sMon ^ 9) * jNear 1728 ^ 2 by ring,
+    HahnSeries.single_pow, HahnSeries.single_pow, HahnSeries.single_mul_single]
+  norm_num
+
+theorem orderTop_delta_goodModel_1728 : (goodModel 1728).Δ.orderTop = 0 := by
+  rw [delta_goodModel_1728]
+  exact orderTop_pow_of_eq_zero (orderTop_jNear (by norm_num)) 2
+
+end S12B3
+end
+
+open ModularCurve.B3 ModularCurve.TatePoint WeierstrassCurve
+
+theorem solution (j₀ : Qbar) :
+    nearCurve j₀ = WeierstrassCurve.ofJNe0Or1728 (jNear j₀) := by
+  exact S12B3.nearCurve_eq j₀
+
+end S_ModularCurve_B3_nearCurve_eq_ofJNe0Or1728
+end P2MW
+export P2MW.S_ModularCurve_B3_nearCurve_eq_ofJNe0Or1728 (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve.TatePoint
+theorem ModularCurve.B3.nearCurve_eq_ofJNe0Or1728 (j₀ : Qbar) :
+    nearCurve j₀ = WeierstrassCurve.ofJNe0Or1728 (jNear j₀) :=
+  solution j₀
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_specialisationEquivariance_level.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_specialisationEquivariance_level.lean
new file mode 100644
index 0000000000..1fa1ac4144
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_B3_specialisationEquivariance_level.lean
@@ -0,0 +1,2473 @@
+/-
+Based on Prove2Me node ModularCurve.B3.specialisationEquivariance_level
+(55232edb-d7be-5f01-ba0e-ec8304231db5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 50d60dea-f458-5446-b6d4-f608bd16f93a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_SpecialisationBridge
+
+import Mathlib.Algebra.Category.Grp.Injective
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EMD
+import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_Monodromy
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VariableChangePointEquiv
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_vcInvFun_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsionBy_eq_sq_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_isAlgClosed_rat
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_zsmul_some_eq_some_div
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_evalEval_psi_sq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a4_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a6_eq_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_HahnSpecialise
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_HahnSpecialise_specialiseCycSub_bijective
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Level-N specialisation is monodromy-to-automorphism equivariant
+
+Theorem statement: `ModularCurve.B3.specialisationEquivariance_level`
+(`55232edb-d7be-5f01-ba0e-ec8304231db5`), by Claude, 2026-09-05.
+
+Proof: submission `50d60dea-f458-5446-b6d4-f608bd16f93a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a positive integer (a `NeZero N` instance) and let $j_0$ be an element of
+$\overline{\mathbb{Q}} =$ `AlgebraicClosure ℚ`. Write $H$ for the Hahn series field with rational
+exponents and coefficients in $\overline{\mathbb{Q}}$, and let the near curve at $j_0$ be
+`WeierstrassCurve.ofJ` applied to $j_0 + t$, where $t$ is the Hahn series `single (1 : ℚ) 1`;
+downstairs sits `WeierstrassCurve.ofJ j₀` over $\overline{\mathbb{Q}}$. On either curve the relevant
+objects are the additive subgroups of the affine point group that are of the form $\mathbb{Z}g$ for
+some point $g$ of additive order exactly $N$; these form the types `CycSubH (nearCurve j₀) N` and
+`CycSub (WeierstrassCurve.ofJ j₀) N`. The theorem asserts the existence of a bijection $\beta$
+between these two types with the following property: for subgroups $G, G'$ upstairs, there is an
+element $m$ of [`HahnSeries.monodromy Qbar`](def/HahnSeries_Monodromy.html#L121) — the group of
+twists of $H$ by characters $\chi$ of $\mathrm{Multiplicative}\,\mathbb{Q}$ into
+$\overline{\mathbb{Q}}^{\times}$ with $\chi(1)=1$, acting coefficientwise — whose induced additive
+automorphism of the near curve's points carries $G$ onto $G'$, if and only if $\beta G$ and $\beta
+G'$ satisfy `SameOrbit`, i.e. there are a variable change $\gamma$ over $\overline{\mathbb{Q}}$
+fixing `WeierstrassCurve.ofJ j₀` and generators $g$, $g'$ of $\beta G$, $\beta G'$ with $g'$ the
+image of $g$ under $\gamma$. The bijection is only asserted to exist; no particular $\beta$ is
+named.
+
+This is the level-$N$ statement that specialisation along the Hahn valuation identifies the cyclic
+subgroups of order $N$ of the near curve with those of the curve of invariant $j_0$, and matches
+monodromy orbits upstairs with orbits under the automorphisms of the curve downstairs — the
+fibre-by-fibre comparison for the $\Gamma_0(N)$-type moduli problem over the $j$-line, including the
+points $j_0 = 0$ and $1728$ where the automorphism group is larger. It is used by
+[`ModularCurve.exists_elliptic_cycSub_orbitMap_of_props`]
+(thm.html#ModularCurve.exists_elliptic_cycSub_orbitMap_of_props).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_B3_specialisationEquivariance_level.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_B3_specialisationEquivariance_level
+
+open scoped Classical
+
+noncomputable section
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_B3_specialisationEquivariance_level.ModularCurve \
+  WeierstrassCurve Polynomial"
+
+namespace HahnSeries
+p2m_export "HahnSeries" "support coeff_sub orderTop orderTop_mul algebraMap_apply' ofPowerSeries_C \
+  C_apply coeff_sum leadingCoeff_ne_zero orderTop_one coeff_eq_zero_of_lt_orderTop single \
+  orderTop_zero le_orderTop_iff_forall order powerSeriesAlgebra min_orderTop_le_orderTop_add coeff \
+  ofPowerSeries_X orderTop_add_eq_left order_eq_orderTop_of_ne_zero single_pow single_zero_one \
+  coeff_zero pow_add single_zero_intCast orderTop_single C map coeff_neg embDomain_notin_range \
+  orderTop_ne_top order_pow coeff_single_same ofPowerSeries_apply_coeff single_ne_zero \
+  orderTop_neg single_zero_natCast ofPowerSeries rec coeff_order_eq_zero leadingCoeff coeff_add \
+  coeff_single_of_ne ofPowerSeries_apply orderTop_le_of_coeff_ne_zero coeff_single \
+  single_mul_single coeff_mul_order_add_order order_mul_of_ne_zero coeff_hahnTwist \
+  hahnTwist_single order_hahnTwist MonoChar mem_monoChar_iff hahnTwistHom hahnTwistHom_apply \
+  monodromy fixes_single_one_of_mem_monodromy"
+p2m_open "HahnSeries"
+
+namespace ExtChar
+
+variable (K : Type*) [Field K] [IsAlgClosed K]
+
+@[reducible] def divisibleByIntAdditiveUnits : DivisibleBy (Additive Kˣ) ℤ :=
+  divisibleByOfSMulRightSurj (Additive Kˣ) ℤ fun {n} hn a => by
+    obtain ⟨k, rfl | rfl⟩ := Int.eq_nat_or_neg n
+    · have hk : 0 < k := by omega
+      obtain ⟨y, hy⟩ := IsAlgClosed.exists_pow_nat_eq ((a.toMul : Kˣ) : K) hk
+      have hy0 : y ≠ 0 := fun h => (a.toMul).ne_zero (by rw [← hy, h, zero_pow hk.ne'])
+      refine ⟨Additive.ofMul (Units.mk0 y hy0), ?_⟩
+      apply Additive.toMul.injective
+      rw [toMul_zsmul, toMul_ofMul, zpow_natCast]
+      exact Units.ext (by rw [Units.val_pow_eq_pow_val, Units.val_mk0, hy])
+    · have hk : 0 < k := by omega
+      obtain ⟨y, hy⟩ := IsAlgClosed.exists_pow_nat_eq ((a.toMul⁻¹ : Kˣ) : K) hk
+      have hy0 : y ≠ 0 := fun h => (a.toMul⁻¹).ne_zero (by rw [← hy, h, zero_pow hk.ne'])
+      refine ⟨Additive.ofMul (Units.mk0 y hy0), ?_⟩
+      apply Additive.toMul.injective
+      rw [toMul_zsmul, toMul_ofMul, zpow_neg, zpow_natCast, ← inv_inv a.toMul]
+      exact congrArg (·⁻¹) (Units.ext (by rw [Units.val_pow_eq_pow_val, Units.val_mk0, hy]))
+
+theorem injective_additiveUnits : Module.Injective ℤ (Additive Kˣ) :=
+  letI := divisibleByIntAdditiveUnits K
+  (Module.Baer.of_divisible (Additive Kˣ)).injective
+
+variable {K}
+
+theorem exists_char_apply_eq (q : ℚ) (hq : q ≠ 0) (u : Kˣ) :
+    ∃ χ : Multiplicative ℚ →* Kˣ, χ (Multiplicative.ofAdd q) = u := by
+  let ε : ℤ ≃ₗ[ℤ] (ℤ ∙ q) := LinearEquiv.toSpanNonzeroSingleton ℤ ℚ q hq
+  let g : (ℤ ∙ q) →ₗ[ℤ] Additive Kˣ :=
+    (LinearMap.toSpanSingleton ℤ (Additive Kˣ) (Additive.ofMul u)).comp ε.symm.toLinearMap
+  have hgq : g ⟨q, Submodule.mem_span_singleton_self q⟩ = Additive.ofMul u := by
+    have h1 : ε.symm ⟨q, Submodule.mem_span_singleton_self q⟩ = 1 := by
+      rw [LinearEquiv.symm_apply_eq]
+      exact (LinearEquiv.toSpanNonzeroSingleton_one ℤ ℚ q hq).symm
+    simp only [g, LinearMap.comp_apply, LinearEquiv.coe_toLinearMap, h1,
+      LinearMap.toSpanSingleton_apply, one_smul]
+  let := divisibleByIntAdditiveUnits K
+  obtain ⟨h, hh⟩ := (Module.Baer.of_divisible (Additive Kˣ)).extension_property (ℤ ∙ q).subtype
+    (Submodule.subtype_injective _) g
+  refine ⟨{ toFun := fun a => (h a.toAdd).toMul
+            map_one' := by rw [toAdd_one, map_zero, toMul_zero]
+            map_mul' := fun a b => by rw [toAdd_mul, map_add, toMul_add] }, ?_⟩
+  change (h (Multiplicative.ofAdd q).toAdd).toMul = u
+  rw [toAdd_ofAdd]
+  have := LinearMap.congr_fun hh ⟨q, Submodule.mem_span_singleton_self q⟩
+  rw [LinearMap.comp_apply, Submodule.subtype_apply] at this
+  rw [this, hgq, toMul_ofMul]
+
+end ExtChar
+
+private theorem exists_mem_monodromy_single_eq (K : Type*) [Field K] [IsAlgClosed K] (e : ℕ)
+    (he : 0 < e)
+    (ζ : K) (hζ : ζ ^ e = 1) :
+    ∃ m ∈ monodromy K,
+      (m : HahnSeries ℚ K ≃ₐ[K] HahnSeries ℚ K) (single ((e : ℚ)⁻¹) (1 : K)) =
+        single ((e : ℚ)⁻¹) ζ := by
+  have hζ0 : ζ ≠ 0 := by
+    rintro rfl
+    rw [zero_pow he.ne'] at hζ
+    exact zero_ne_one hζ
+  have hq : ((e : ℚ)⁻¹) ≠ 0 := inv_ne_zero (by exact_mod_cast he.ne')
+  obtain ⟨χ, hχ⟩ := ExtChar.exists_char_apply_eq ((e : ℚ)⁻¹) hq (Units.mk0 ζ hζ0)
+  have hone : Multiplicative.ofAdd (1 : ℚ) = Multiplicative.ofAdd ((e : ℚ)⁻¹) ^ e := by
+    rw [← ofAdd_nsmul, nsmul_eq_mul, mul_inv_cancel₀ (by exact_mod_cast he.ne' : (e : ℚ) ≠ 0)]
+  have hmem : χ ∈ MonoChar K := by
+    rw [mem_monoChar_iff, hone, map_pow, hχ]
+    exact Units.ext (by rw [Units.val_pow_eq_pow_val, Units.val_mk0, hζ, Units.val_one])
+  refine ⟨hahnTwistHom χ, Subgroup.mem_map_of_mem _ hmem, ?_⟩
+  rw [hahnTwistHom_apply, hahnTwist_single, hχ, Units.val_mk0, mul_one]
+
+end HahnSeries
+
+namespace ModularCurve
+p2m_export "ModularCurve" "CycSub SameOrbit HahnSpecialise.specialiseCycSub_bijective"
+namespace B3
+p2m_export "ModularCurve.B3" "map_ofJNe0Or1728 nonsingular_specialFibre redPoint redPoint_zero \
+  redPoint_some cycOfCongr mem_torsionBy_of_addOrderOf_eq comap_subtype_zmultiples vcAddEquiv \
+  vcAddEquiv_apply pointAddEquivOfEq pointAddEquivOfEq_rfl goodModel_spec fibreVC fibreVC_smul \
+  scaleAddEquiv scaleAddEquiv_apply cycScale fibreAddEquiv redTorsionEquiv cycRed \
+  bridge3Specialise algebraMap_H_apply nearCurve_map_of_mem_monodromy nearTransport \
+  nearTransport_some b3Act b3Act_zmultiples coeff_zero_mul_of_integral orderTop_pow_nonneg \
+  integralO mem_integralO resO resO_apply IntegralCoeffs specialFibre val_inv_sU scaleVC goodModel \
+  scaleVC_zero scaleVC_1728 scaleVC_of_ne goodModel_eq_nearCurve nearCurve_eq_ofJNe0Or1728 \
+  exists_torsionBy_reduction_addEquiv"
+p2m_open "ModularCurve.B3 ModularCurve"
+
+open ModularCurve.TatePoint
+
+private theorem orderTop_nonneg_of_isRoot (P : Polynomial H)
+    (hP : ∀ i, 0 ≤ (P.coeff i).orderTop) (hlead : P.leadingCoeff.orderTop = 0)
+    {x : H} (hx : P.IsRoot x) : 0 ≤ x.orderTop := by
+  by_contra hneg
+  rw [not_le] at hneg
+  have hx0 : x ≠ 0 := by
+    rintro rfl
+    rw [HahnSeries.orderTop_zero] at hneg
+    exact not_top_lt hneg
+  have hxneg : x.order < 0 := by
+    rw [← HahnSeries.order_eq_orderTop_of_ne_zero hx0] at hneg
+    exact_mod_cast hneg
+  have hl0 : P.leadingCoeff ≠ 0 := by
+    intro h
+    rw [h, HahnSeries.orderTop_zero] at hlead
+    exact ne_of_gt (WithTop.coe_lt_top (0 : ℚ)) hlead
+  have hP0 : P ≠ 0 := Polynomial.leadingCoeff_ne_zero.mp hl0
+  have han : P.coeff P.natDegree ≠ 0 := by
+    rw [Polynomial.coeff_natDegree]; exact hl0
+  have hxn : (x ^ P.natDegree : H) ≠ 0 := pow_ne_zero _ hx0
+  have hordan : (P.coeff P.natDegree).order = 0 := by
+    have h : ((P.coeff P.natDegree).order : WithTop ℚ) = 0 := by
+      rw [HahnSeries.order_eq_orderTop_of_ne_zero han, Polynomial.coeff_natDegree, hlead]
+    exact_mod_cast h
+  have hordxn : (x ^ P.natDegree : H).order = P.natDegree • x.order :=
+    HahnSeries.order_pow x P.natDegree
+  have hleadterm :
+      (P.coeff P.natDegree * x ^ P.natDegree : H).coeff (P.natDegree • x.order) ≠ 0 := by
+    have key := HahnSeries.coeff_mul_order_add_order (P.coeff P.natDegree) (x ^ P.natDegree)
+    rw [hordan, hordxn, zero_add] at key
+    rw [key]
+    exact mul_ne_zero (HahnSeries.leadingCoeff_ne_zero.mpr han)
+      (HahnSeries.leadingCoeff_ne_zero.mpr hxn)
+  have hlower : ∀ i ∈ Finset.range (P.natDegree + 1), i ≠ P.natDegree →
+      (P.coeff i * x ^ i : H).coeff (P.natDegree • x.order) = 0 := by
+    intro i hi hin
+    have hilt : i < P.natDegree := lt_of_le_of_ne (Finset.mem_range_succ_iff.mp hi) hin
+    rcases eq_or_ne (P.coeff i) 0 with h0 | h0
+    · simp [h0]
+    · apply HahnSeries.coeff_eq_zero_of_lt_orderTop
+      have hxi : (x ^ i : H) ≠ 0 := pow_ne_zero _ hx0
+      have hq : P.natDegree • x.order < i • x.order := by
+        rw [nsmul_eq_mul, nsmul_eq_mul]
+        exact mul_lt_mul_of_neg_right (by exact_mod_cast hilt) hxneg
+      have h2 : ((i • x.order : ℚ) : WithTop ℚ) ≤ (P.coeff i * x ^ i : H).orderTop := by
+        rw [HahnSeries.orderTop_mul]
+        calc ((i • x.order : ℚ) : WithTop ℚ)
+            = 0 + ((i • x.order : ℚ) : WithTop ℚ) := (zero_add _).symm
+          _ ≤ (P.coeff i).orderTop + (x ^ i : H).orderTop := by
+              refine add_le_add (hP i) ?_
+              rw [← HahnSeries.order_eq_orderTop_of_ne_zero hxi, HahnSeries.order_pow]
+      exact lt_of_lt_of_le (WithTop.coe_lt_coe.mpr hq) h2
+  have heval : (P.eval x).coeff (P.natDegree • x.order) ≠ 0 := by
+    rw [Polynomial.eval_eq_sum_range, HahnSeries.coeff_sum,
+      Finset.sum_eq_single_of_mem P.natDegree (Finset.self_mem_range_succ P.natDegree) hlower]
+    exact hleadterm
+  rw [show P.eval x = 0 from hx] at heval
+  simp only [HahnSeries.coeff_zero] at heval
+  exact heval rfl
+
+scoped instance instCharZeroH : CharZero H :=
+  charZero_of_injective_algebraMap (algebraMap Qbar H).injective
+
+local notation "ι" => (HahnSeries.ofPowerSeries ℚ Qbar)
+
+theorem coeff_zero_ofPowerSeries (f : PowerSeries Qbar) :
+    (ι f).coeff 0 = PowerSeries.constantCoeff f := by
+  have h := HahnSeries.ofPowerSeries_apply_coeff (Γ := ℚ) f 0
+  rw [Nat.cast_zero] at h
+  rw [h, PowerSeries.coeff_zero_eq_constantCoeff_apply]
+
+theorem coeff_ofPowerSeries_of_neg (f : PowerSeries Qbar) {q : ℚ} (hq : q < 0) :
+    (ι f).coeff q = 0 := by
+  rw [HahnSeries.ofPowerSeries_apply, HahnSeries.embDomain_of_notMem_range]
+  rintro ⟨n, hn⟩
+  exact (not_le.mpr hq) (le_of_le_of_eq (Nat.cast_nonneg n) hn)
+
+theorem orderTop_ofPowerSeries_nonneg (f : PowerSeries Qbar) : 0 ≤ (ι f).orderTop :=
+  HahnSeries.le_orderTop_iff_forall.mpr fun _ hq =>
+    coeff_ofPowerSeries_of_neg f (WithTop.coe_lt_zero.mp hq)
+
+theorem orderTop_single_mul_ofPowerSeries (q : ℚ) (f : PowerSeries Qbar) :
+    (q : WithTop ℚ) ≤ (HahnSeries.single q (1 : Qbar) * ι f).orderTop := by
+  rw [HahnSeries.orderTop_mul, HahnSeries.orderTop_single one_ne_zero]
+  exact le_add_of_nonneg_right (orderTop_ofPowerSeries_nonneg f)
+
+theorem coeff_zero_single_mul_ofPowerSeries {q : ℚ} (hq : 0 < q) (f : PowerSeries Qbar) :
+    (HahnSeries.single q (1 : Qbar) * ι f).coeff 0 = 0 :=
+  HahnSeries.coeff_eq_zero_of_lt_orderTop
+    (lt_of_lt_of_le (WithTop.coe_pos.mpr hq) (orderTop_single_mul_ofPowerSeries q f))
+
+theorem specialFibre_map_ofPowerSeries (W : WeierstrassCurve (PowerSeries Qbar)) :
+    specialFibre (W.map ι) = W.map PowerSeries.constantCoeff := by
+  simp only [specialFibre, WeierstrassCurve.map, coeff_zero_ofPowerSeries]
+
+theorem integralCoeffs_map_ofPowerSeries (W : WeierstrassCurve (PowerSeries Qbar)) :
+    IntegralCoeffs (W.map ι) := by
+  unfold IntegralCoeffs
+  exact ⟨orderTop_ofPowerSeries_nonneg _, orderTop_ofPowerSeries_nonneg _,
+    orderTop_ofPowerSeries_nonneg _, orderTop_ofPowerSeries_nonneg _,
+    orderTop_ofPowerSeries_nonneg _⟩
+
+theorem orderTop_pow_eq_nsmul (x : H) (n : ℕ) : (x ^ n).orderTop = n • x.orderTop := by
+  induction n with
+  | zero => rw [pow_zero, HahnSeries.orderTop_one, zero_nsmul]
+  | succ n ih => rw [pow_succ, HahnSeries.orderTop_mul, ih, succ_nsmul]
+
+theorem coeff_one_jNear (j₀ : Qbar) : (jNear j₀).coeff 1 = 1 := by
+  simp [jNear]
+
+private theorem jNear_ne_zero (j₀ : Qbar) : jNear j₀ ≠ 0 := fun h => by
+  simpa [h] using coeff_one_jNear j₀
+
+private theorem jNear_ne_1728 (j₀ : Qbar) : jNear j₀ ≠ 1728 := fun h => by
+  have h1 := coeff_one_jNear j₀
+  have h2 : (1728 : H) = HahnSeries.C (1728 : Qbar) := (map_ofNat _ _).symm
+  rw [h, h2, HahnSeries.C_apply, HahnSeries.coeff_single_of_ne one_ne_zero] at h1
+  exact zero_ne_one h1
+
+theorem jNear_zero : jNear 0 = HahnSeries.single 1 1 := by
+  simp only [jNear, map_zero, zero_add]
+
+theorem jNear_sub_ofNat (j₀ : Qbar) : jNear j₀ - 1728 = jNear (j₀ - 1728) := by
+  simp only [jNear, map_sub, map_ofNat]; ring
+
+theorem orderTop_jNear_of_ne {j₀ : Qbar} (h : j₀ ≠ 0) : (jNear j₀).orderTop = 0 := by
+  have h1 : (HahnSeries.C j₀ : H).orderTop = (0 : ℚ) := by
+    rw [HahnSeries.C_apply, HahnSeries.orderTop_single h]
+  have h2 : (HahnSeries.single (1 : ℚ) (1 : Qbar)).orderTop = (1 : ℚ) :=
+    HahnSeries.orderTop_single one_ne_zero
+  rw [jNear, HahnSeries.orderTop_add_eq_left
+      (by rw [h1, h2]; exact WithTop.coe_lt_coe.mpr zero_lt_one), h1, WithTop.coe_zero]
+
+theorem orderTop_jNear_zero : (jNear 0).orderTop = (1 : ℚ) := by
+  rw [jNear_zero, HahnSeries.orderTop_single one_ne_zero]
+
+theorem nearCurve_eq_map (j₀ : Qbar) :
+    nearCurve j₀ =
+      (WeierstrassCurve.ofJNe0Or1728 (PowerSeries.C j₀ + PowerSeries.X)).map ι := by
+  rw [map_ofJNe0Or1728, map_add, HahnSeries.ofPowerSeries_C, HahnSeries.ofPowerSeries_X,
+    nearCurve_eq_ofJNe0Or1728, jNear]
+
+theorem integralCoeffs_nearCurve (j₀ : Qbar) : IntegralCoeffs (nearCurve j₀) := by
+  rw [nearCurve_eq_map]; exact integralCoeffs_map_ofPowerSeries _
+
+theorem specialFibre_nearCurve (j₀ : Qbar) :
+    specialFibre (nearCurve j₀) = WeierstrassCurve.ofJNe0Or1728 j₀ := by
+  rw [nearCurve_eq_map, specialFibre_map_ofPowerSeries, map_ofJNe0Or1728, map_add,
+    PowerSeries.constantCoeff_C, PowerSeries.constantCoeff_X, add_zero]
+
+theorem nearCurve_Δ (j₀ : Qbar) :
+    (nearCurve j₀).Δ = jNear j₀ ^ 2 * jNear (j₀ - 1728) ^ 9 := by
+  rw [nearCurve_eq_ofJNe0Or1728, WeierstrassCurve.ofJNe0Or1728_Δ, jNear_sub_ofNat]
+
+private theorem nearCurve_delta_orderTop_generic (j₀ : Qbar) (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) :
+    (nearCurve j₀).Δ.orderTop = 0 := by
+  rw [nearCurve_Δ, HahnSeries.orderTop_mul, orderTop_pow_eq_nsmul, orderTop_pow_eq_nsmul,
+    orderTop_jNear_of_ne h0, orderTop_jNear_of_ne (sub_ne_zero.mpr h1728), nsmul_zero,
+    nsmul_zero, add_zero]
+
+private theorem nearCurve_delta_orderTop_zero : (nearCurve 0).Δ.orderTop = (2 : ℚ) := by
+  rw [nearCurve_Δ, HahnSeries.orderTop_mul, orderTop_pow_eq_nsmul, orderTop_pow_eq_nsmul,
+    orderTop_jNear_zero, zero_sub,
+    orderTop_jNear_of_ne (neg_ne_zero.mpr (by norm_num : (1728 : Qbar) ≠ 0)), nsmul_zero,
+    add_zero, ← WithTop.coe_nsmul]
+  norm_num
+
+private theorem nearCurve_delta_orderTop_1728 : (nearCurve 1728).Δ.orderTop = (9 : ℚ) := by
+  rw [nearCurve_Δ, HahnSeries.orderTop_mul, orderTop_pow_eq_nsmul, orderTop_pow_eq_nsmul,
+    orderTop_jNear_of_ne (by norm_num : (1728 : Qbar) ≠ 0), sub_self, orderTop_jNear_zero,
+    nsmul_zero, zero_add, ← WithTop.coe_nsmul]
+  norm_num
+
+theorem specialFibre_nearCurve_generic (j₀ : Qbar) (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) :
+    specialFibre (nearCurve j₀) = WeierstrassCurve.ofJ j₀ := by
+  rw [specialFibre_nearCurve, WeierstrassCurve.ofJ_ne_0_ne_1728 j₀ h0 h1728]
+
+theorem goodModel_1728_eq : goodModel 1728 =
+    ⟨HahnSeries.single (1 / 4 : ℚ) 1, 0, 0, HahnSeries.C (-36),
+      -HahnSeries.single (1 / 2 : ℚ) 1⟩ := by
+  have hA : jNear 1728 - 1728 = HahnSeries.single 1 1 := by
+    rw [jNear_sub_ofNat, sub_self, jNear_zero]
+  have h1 : HahnSeries.single (-(9 / 12 : ℚ)) (1 : Qbar) * HahnSeries.single 1 1 =
+      HahnSeries.single (1 / 4 : ℚ) 1 := by
+    rw [HahnSeries.single_mul_single, mul_one]; congr 1; norm_num
+  have h4 : HahnSeries.single (-(9 / 12 : ℚ)) (1 : Qbar) ^ 4 * HahnSeries.single 1 1 ^ 3 = 1 := by
+    rw [HahnSeries.single_pow, HahnSeries.single_pow, HahnSeries.single_mul_single,
+      ← HahnSeries.single_zero_one]
+    congr 1 <;> norm_num
+  have h6 : HahnSeries.single (-(9 / 12 : ℚ)) (1 : Qbar) ^ 6 * HahnSeries.single 1 1 ^ 5 =
+      HahnSeries.single (1 / 2 : ℚ) 1 := by
+    rw [HahnSeries.single_pow, HahnSeries.single_pow, HahnSeries.single_mul_single]
+    congr 1 <;> norm_num
+  rw [goodModel, scaleVC_1728, nearCurve_eq_ofJNe0Or1728, variableChange_def]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU]
+    linear_combination h1
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU]
+    ring
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU]
+    ring
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU, map_neg, map_ofNat]
+    linear_combination (-36 : H) * h4
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU]
+    linear_combination (-1 : H) * h6
+
+theorem goodModel_zero_eq : goodModel 0 =
+    ⟨0, 0, 0,
+      HahnSeries.single (1 / 3 : ℚ) 1 *
+        ι (PowerSeries.C (-1 / 48 : Qbar) * (PowerSeries.X - PowerSeries.C 1728) ^ 3),
+      ι (PowerSeries.C (1 / 864 : Qbar) * (PowerSeries.X - PowerSeries.C 1728) ^ 5)⟩ := by
+  have hA : jNear 0 - 1728 = HahnSeries.single 1 1 - 1728 := by rw [jNear_zero]
+  have h4 : HahnSeries.single (-(2 / 12 : ℚ)) (1 : Qbar) ^ 4 * HahnSeries.single 1 1 =
+      HahnSeries.single (1 / 3 : ℚ) 1 := by
+    rw [HahnSeries.single_pow, HahnSeries.single_mul_single]; congr 1 <;> norm_num
+  have h6 : HahnSeries.single (-(2 / 12 : ℚ)) (1 : Qbar) ^ 6 * HahnSeries.single 1 1 = 1 := by
+    rw [HahnSeries.single_pow, HahnSeries.single_mul_single, ← HahnSeries.single_zero_one]
+    congr 1 <;> norm_num
+  rw [goodModel, scaleVC_zero, nearCurve_eq_ofJNe0Or1728, variableChange_def]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU]
+    ring
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU]
+    ring
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU]
+    ring
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU, map_mul, map_pow, map_sub, map_neg,
+      map_div₀, map_one, map_ofNat, HahnSeries.ofPowerSeries_C, HahnSeries.ofPowerSeries_X]
+    linear_combination (-1 / 48 : H) * (HahnSeries.single (1 : ℚ) (1 : Qbar) - 1728) ^ 3 * h4
+  · simp only [WeierstrassCurve.ofJNe0Or1728, hA, val_inv_sU, map_mul, map_pow, map_sub,
+      map_div₀, map_one, map_ofNat, HahnSeries.ofPowerSeries_C, HahnSeries.ofPowerSeries_X]
+    linear_combination (1 / 864 : H) * (HahnSeries.single (1 : ℚ) (1 : Qbar) - 1728) ^ 5 * h6
+
+theorem specialFibre_goodModel_1728 : specialFibre (goodModel 1728) = ⟨0, 0, 0, -36, 0⟩ := by
+  rw [goodModel_1728_eq]
+  simp only [specialFibre, HahnSeries.coeff_zero, HahnSeries.coeff_neg, HahnSeries.C_apply,
+    HahnSeries.coeff_single]
+  norm_num
+
+theorem specialFibre_goodModel_zero :
+    specialFibre (goodModel 0) = ⟨0, 0, 0, 0, -(2 * 1728 ^ 4)⟩ := by
+  rw [goodModel_zero_eq]
+  simp only [specialFibre, HahnSeries.coeff_zero, coeff_zero_ofPowerSeries,
+    coeff_zero_single_mul_ofPowerSeries (by norm_num : (0 : ℚ) < 1 / 3)]
+  simp only [map_mul, map_pow, map_sub, PowerSeries.constantCoeff_C, PowerSeries.constantCoeff_X]
+  norm_num
+
+open WeierstrassCurve in
+theorem eval_ΨSq_eq_zero_of_nsmul_some_eq_zero {F : Type*} [Field F] [DecidableEq F]
+    (W : WeierstrassCurve F) {x y : F} (h : W.toAffine.Nonsingular x y)
+    {d : ℕ} (htor : d • (Affine.Point.some x y h : W.toAffine.Point) = 0) :
+    (W.ΨSq d).eval x = 0 := by
+  by_contra hne
+  have hψ : (W.ψ (d : ℤ)).evalEval x y ≠ 0 := fun h0 => hne <| by
+    rw [← WeierstrassCurve.Affine.evalEval_psi_sq W h.1 (d : ℤ), h0, zero_pow two_ne_zero]
+  obtain ⟨y', h', heq⟩ := WeierstrassCurve.Affine.Point.zsmul_some_eq_some_div W h hψ
+  rw [natCast_zsmul, htor] at heq
+  exact (WeierstrassCurve.Affine.Point.some_ne_zero h') heq.symm
+
+open WeierstrassCurve in
+theorem eval_preΨ'_eq_zero_or_eval_Ψ₂Sq_eq_zero_of_nsmul_some_eq_zero
+    {F : Type*} [Field F] [DecidableEq F]
+    (W : WeierstrassCurve F) {x y : F} (h : W.toAffine.Nonsingular x y)
+    {d : ℕ} (htor : d • (Affine.Point.some x y h : W.toAffine.Point) = 0) :
+    (W.preΨ' d).eval x = 0 ∨ W.Ψ₂Sq.eval x = 0 := by
+  have := eval_ΨSq_eq_zero_of_nsmul_some_eq_zero W h htor
+  rw [WeierstrassCurve.ΨSq_ofNat, Polynomial.eval_mul, Polynomial.eval_pow,
+    mul_eq_zero, pow_eq_zero_iff two_ne_zero] at this
+  refine this.imp_right (fun h => ?_)
+  split_ifs at h with heven
+  · simpa using h
+  · simp at h
+
+theorem orderTop_intCast {n : ℤ} (hn : n ≠ 0) : (n : H).orderTop = 0 := by
+  rw [← HahnSeries.single_zero_intCast]
+  exact HahnSeries.orderTop_single (Int.cast_ne_zero.mpr hn)
+
+theorem orderTop_leadingCoeff_ΨSq_eq_zero (W : WeierstrassCurve H) {n : ℤ} (hn : (n : H) ≠ 0) :
+    (W.ΨSq n).leadingCoeff.orderTop = 0 := by
+  have hn' : n ≠ 0 := fun h0 => hn (by rw [h0]; exact Int.cast_zero)
+  rw [W.leadingCoeff_ΨSq hn, sq, HahnSeries.orderTop_mul, orderTop_intCast hn', add_zero]
+
+def liftToIntegralO (W : WeierstrassCurve H) (hW : IntegralCoeffs W) :
+    WeierstrassCurve integralO :=
+  ⟨⟨W.a₁, mem_integralO.mpr hW.1⟩,
+   ⟨W.a₂, mem_integralO.mpr hW.2.1⟩,
+   ⟨W.a₃, mem_integralO.mpr hW.2.2.1⟩,
+   ⟨W.a₄, mem_integralO.mpr hW.2.2.2.1⟩,
+   ⟨W.a₆, mem_integralO.mpr hW.2.2.2.2⟩⟩
+
+theorem map_liftToIntegralO (W : WeierstrassCurve H) (hW : IntegralCoeffs W) :
+    (liftToIntegralO W hW).map integralO.subtype = W := by
+  rfl
+
+theorem map_liftToIntegralO_resO (W : WeierstrassCurve H) (hW : IntegralCoeffs W) :
+    (liftToIntegralO W hW).map resO = specialFibre W := by
+  rfl
+
+theorem orderTop_coeff_ΨSq_nonneg (W : WeierstrassCurve H) (hW : IntegralCoeffs W) (n : ℤ)
+    (k : ℕ) : 0 ≤ ((W.ΨSq n).coeff k).orderTop := by
+  rw [← map_liftToIntegralO W hW, WeierstrassCurve.map_ΨSq, Polynomial.coeff_map]
+  exact mem_integralO.mp (((liftToIntegralO W hW).ΨSq n).coeff k).property
+
+theorem natCast_H_ne_zero {n : ℕ} (hn : n ≠ 0) : (n : H) ≠ 0 := by
+  rw [← HahnSeries.single_zero_natCast]
+  exact HahnSeries.single_ne_zero (Nat.cast_ne_zero.mpr hn)
+
+private theorem torsion_coords_integral (W : WeierstrassCurve H) [W.IsElliptic]
+    (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0) {x y : H}
+    (h : W.toAffine.Nonsingular x y) {n : ℕ} (hn : n ≠ 0)
+    (htor : n • (WeierstrassCurve.Affine.Point.some x y h : W.toAffine.Point) = 0) :
+    0 ≤ x.orderTop ∧ 0 ≤ y.orderTop := by
+  have _ := hΔ
+  have hnH : ((n : ℤ) : H) ≠ 0 := by exact_mod_cast natCast_H_ne_zero hn
+  have hroot_x : (W.ΨSq (n : ℤ)).IsRoot x := by
+    rw [Polynomial.IsRoot]
+    exact_mod_cast eval_ΨSq_eq_zero_of_nsmul_some_eq_zero W h htor
+  have hx : 0 ≤ x.orderTop :=
+    orderTop_nonneg_of_isRoot (W.ΨSq (n : ℤ))
+      (orderTop_coeff_ΨSq_nonneg W hW (n : ℤ))
+      (orderTop_leadingCoeff_ΨSq_eq_zero W hnH)
+      hroot_x
+  refine ⟨hx, ?_⟩
+  let Q : Polynomial H := W.toAffine.polynomial.map (Polynomial.evalRingHom x)
+  have hQmonic : Q.Monic := W.toAffine.monic_polynomial.map _
+  have hQroot : Q.IsRoot y := by
+    rw [show Q.IsRoot y ↔ Q.eval y = 0 from Iff.rfl, Polynomial.map_evalRingHom_eval]
+    exact h.1
+  have hQlead : Q.leadingCoeff.orderTop = 0 := by
+    rw [hQmonic.leadingCoeff]; exact HahnSeries.orderTop_one
+  have hQcoeff : ∀ i, 0 ≤ (Q.coeff i).orderTop := by
+    intro i
+    let x' : integralO := ⟨x, mem_integralO.mpr hx⟩
+    have hx'val : integralO.subtype x' = x := rfl
+    have key : Q.coeff i =
+        integralO.subtype
+          (((liftToIntegralO W hW).toAffine.polynomial.map (Polynomial.evalRingHom x')).coeff i)
+            := by
+      simp only [Q, Polynomial.coeff_map, Polynomial.coe_evalRingHom]
+      rw [← Polynomial.eval₂_hom (f := integralO.subtype), ← Polynomial.eval_map]
+      congr 1
+      rw [← Polynomial.coe_mapRingHom, ← Polynomial.coeff_map,
+        ← WeierstrassCurve.Affine.map_polynomial]
+      rfl
+    rw [key]
+    exact mem_integralO.mp
+      (((liftToIntegralO W hW).toAffine.polynomial.map (Polynomial.evalRingHom x')).coeff
+        i).property
+  exact orderTop_nonneg_of_isRoot Q hQcoeff hQlead hQroot
+
+section E3
+
+theorem orderTop_mul_nonneg {u v : H} (hu : 0 ≤ u.orderTop) (hv : 0 ≤ v.orderTop) :
+    0 ≤ (u * v).orderTop := by
+  rw [HahnSeries.orderTop_mul]; exact add_nonneg hu hv
+
+theorem orderTop_add_nonneg {u v : H} (hu : 0 ≤ u.orderTop) (hv : 0 ≤ v.orderTop) :
+    0 ≤ (u + v).orderTop :=
+  le_trans (le_min hu hv) HahnSeries.min_orderTop_le_orderTop_add
+
+theorem orderTop_neg_nonneg {u : H} (hu : 0 ≤ u.orderTop) : 0 ≤ (-u).orderTop := by
+  rw [HahnSeries.orderTop_neg]; exact hu
+
+theorem orderTop_sub_nonneg {u v : H} (hu : 0 ≤ u.orderTop) (hv : 0 ≤ v.orderTop) :
+    0 ≤ (u - v).orderTop := by
+  rw [sub_eq_add_neg]; exact orderTop_add_nonneg hu (orderTop_neg_nonneg hv)
+
+theorem order_div (u v : H) (hu : u ≠ 0) (hv : v ≠ 0) :
+    (u / v).order = u.order - v.order := by
+  have huv : u / v ≠ 0 := div_ne_zero hu hv
+  have h := HahnSeries.order_mul_of_ne_zero (x := u / v) (y := v)
+    (mul_ne_zero (HahnSeries.leadingCoeff_ne_zero.mpr huv)
+      (HahnSeries.leadingCoeff_ne_zero.mpr hv))
+  rw [div_mul_cancel₀ u hv] at h
+  linarith [h]
+
+theorem order_pos_of_coeff_zero_eq_zero {u : H} (hu : u ≠ 0) (hint : 0 ≤ u.orderTop)
+    (h0 : u.coeff 0 = 0) : 0 < u.order := by
+  have hne : u.order ≠ 0 := fun h =>
+    hu (HahnSeries.coeff_order_eq_zero.mp (by rw [h]; exact h0))
+  have hge : 0 ≤ u.order := by
+    rw [← HahnSeries.order_eq_orderTop_of_ne_zero hu] at hint
+    exact_mod_cast hint
+  exact lt_of_le_of_ne hge (Ne.symm hne)
+
+theorem order_eq_zero_of_coeff_zero_ne_zero {u : H} (hint : 0 ≤ u.orderTop)
+    (h0 : u.coeff 0 ≠ 0) : u.order = 0 ∧ u ≠ 0 := by
+  have hu : u ≠ 0 := fun h => h0 (by rw [h]; exact HahnSeries.coeff_zero)
+  refine ⟨?_, hu⟩
+  have hle : u.orderTop ≤ ((0 : ℚ) : WithTop ℚ) := HahnSeries.orderTop_le_of_coeff_ne_zero h0
+  have heq : u.orderTop = 0 := le_antisymm (by exact_mod_cast hle) hint
+  have := (HahnSeries.order_eq_orderTop_of_ne_zero hu).trans heq
+  exact_mod_cast this
+
+theorem coeff_zero_div_of_unit {u v : H} (hu : 0 ≤ u.orderTop) (hv : 0 ≤ v.orderTop)
+    (hv0 : v.coeff 0 ≠ 0) :
+    0 ≤ (u / v).orderTop ∧ (u / v).coeff 0 = u.coeff 0 / v.coeff 0 := by
+  obtain ⟨hvord, hvne⟩ := order_eq_zero_of_coeff_zero_ne_zero hv hv0
+  rcases eq_or_ne u 0 with rfl | hu0
+  · simp [zero_div, HahnSeries.orderTop_zero, HahnSeries.coeff_zero]
+  · have hdiv0 : u / v ≠ 0 := div_ne_zero hu0 hvne
+    have hordu : 0 ≤ u.order := by
+      rw [← HahnSeries.order_eq_orderTop_of_ne_zero hu0] at hu
+      exact_mod_cast hu
+    have hint : 0 ≤ (u / v).orderTop := by
+      rw [← HahnSeries.order_eq_orderTop_of_ne_zero hdiv0]
+      have : (u / v).order = u.order := by rw [order_div u v hu0 hvne, hvord, sub_zero]
+      rw [this]
+      exact_mod_cast hordu
+    refine ⟨hint, ?_⟩
+    have hmul := coeff_zero_mul_of_integral hint hv
+    rw [div_mul_cancel₀ u hvne] at hmul
+    rw [hmul, mul_div_cancel_right₀ _ hv0]
+
+theorem specialFibre_Δ (W : WeierstrassCurve H) (hW : IntegralCoeffs W) :
+    (specialFibre W).Δ = W.Δ.coeff 0 := by
+  obtain ⟨h₁, h₂, h₃, h₄, h₆⟩ := hW
+  let W₀ : WeierstrassCurve integralO :=
+    ⟨⟨W.a₁, h₁⟩, ⟨W.a₂, h₂⟩, ⟨W.a₃, h₃⟩, ⟨W.a₄, h₄⟩, ⟨W.a₆, h₆⟩⟩
+  have hres : W₀.map resO = specialFibre W := rfl
+  have hsub : W₀.map integralO.subtype = W := rfl
+  have e₁ : (specialFibre W).Δ = resO W₀.Δ := by
+    rw [← hres, WeierstrassCurve.map_Δ]
+  have e₂ : ((W₀.Δ : integralO) : H) = W.Δ := by
+    conv_rhs => rw [← hsub, WeierstrassCurve.map_Δ]
+    rfl
+  rw [e₁, resO_apply, e₂]
+
+theorem redPoint_some_ne_zero (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : W.toAffine.Nonsingular x y) :
+    redPoint W hW hΔ (WeierstrassCurve.Affine.Point.some x y h) ≠ 0 := by
+  rw [redPoint_some W hW hΔ hx hy h]
+  exact WeierstrassCurve.Affine.Point.some_ne_zero _
+
+theorem redPoint_neg (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : W.toAffine.Nonsingular x y) :
+    redPoint W hW hΔ (-WeierstrassCurve.Affine.Point.some x y h) =
+      -redPoint W hW hΔ (WeierstrassCurve.Affine.Point.some x y h) := by
+  have hnegY : 0 ≤ (W.toAffine.negY x y).orderTop :=
+    orderTop_sub_nonneg (orderTop_sub_nonneg (orderTop_neg_nonneg hy)
+      (orderTop_mul_nonneg hW.1 hx)) hW.2.2.1
+  have hcoeff : (W.toAffine.negY x y).coeff 0 =
+      (specialFibre W).toAffine.negY (x.coeff 0) (y.coeff 0) := by
+    change (-y - W.a₁ * x - W.a₃).coeff 0 =
+      -(y.coeff 0) - W.a₁.coeff 0 * x.coeff 0 - W.a₃.coeff 0
+    rw [HahnSeries.coeff_sub, HahnSeries.coeff_sub, HahnSeries.coeff_neg,
+      coeff_zero_mul_of_integral hW.1 hx]
+  rw [WeierstrassCurve.Affine.Point.neg_some, redPoint_some W hW hΔ hx hnegY,
+    redPoint_some W hW hΔ hx hy, WeierstrassCurve.Affine.Point.neg_some]
+  congr 1
+
+theorem orderTop_addX_neg (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    {x₁ x₂ ℓ : H} (hx₁ : 0 ≤ x₁.orderTop) (hx₂ : 0 ≤ x₂.orderTop) (hℓ : ℓ.orderTop < 0) :
+    (W.toAffine.addX x₁ x₂ ℓ).orderTop < 0 := by
+  have hℓ0 : ℓ ≠ 0 := HahnSeries.orderTop_ne_top.mp (ne_of_lt (lt_of_lt_of_le hℓ le_top))
+  set q : ℚ := ℓ.order with hqdef
+  have hcoe : ℓ.orderTop = ((q : ℚ) : WithTop ℚ) :=
+    (HahnSeries.order_eq_orderTop_of_ne_zero hℓ0).symm
+  have hqneg : q < 0 := by rw [hcoe] at hℓ; exact_mod_cast hℓ
+  have hsq : (ℓ ^ 2).orderTop = ((q + q : ℚ) : WithTop ℚ) := by
+    rw [pow_two, HahnSeries.orderTop_mul, hcoe]
+    norm_cast
+  have hqq : ((q + q : ℚ) : WithTop ℚ) < ((q : ℚ) : WithTop ℚ) := by
+    exact_mod_cast (by linarith : q + q < q)
+  have hq0 : ((q : ℚ) : WithTop ℚ) < 0 := by exact_mod_cast hqneg
+  have hba : ((q : ℚ) : WithTop ℚ) ≤ (W.a₁ * ℓ).orderTop := by
+    rw [HahnSeries.orderTop_mul, hcoe]
+    calc ((q : ℚ) : WithTop ℚ) = 0 + ((q : ℚ) : WithTop ℚ) := (zero_add _).symm
+      _ ≤ W.a₁.orderTop + ((q : ℚ) : WithTop ℚ) := add_le_add hW.1 le_rfl
+  have step₁ : (ℓ ^ 2 + W.a₁ * ℓ).orderTop = ((q + q : ℚ) : WithTop ℚ) := by
+    rw [HahnSeries.orderTop_add_eq_left (by rw [hsq]; exact lt_of_lt_of_le hqq hba), hsq]
+  have hstep : ∀ (u v : H), u.orderTop = ((q + q : ℚ) : WithTop ℚ) → 0 ≤ v.orderTop →
+      (u - v).orderTop = ((q + q : ℚ) : WithTop ℚ) := by
+    intro u v hu hv
+    rw [sub_eq_add_neg, HahnSeries.orderTop_add_eq_left
+      (by rw [hu, HahnSeries.orderTop_neg]
+          exact lt_of_lt_of_le (lt_of_lt_of_le hqq (le_of_lt hq0)) hv), hu]
+  have step₂ := hstep _ W.a₂ step₁ hW.2.1
+  have step₃ := hstep _ x₁ step₂ hx₁
+  have step₄ := hstep _ x₂ step₃ hx₂
+  change (ℓ ^ 2 + W.a₁ * ℓ - W.a₂ - x₁ - x₂).orderTop < 0
+  rw [step₄]
+  exact lt_trans hqq hq0
+
+theorem orderTop_negY_nonneg (W : WeierstrassCurve H) (hW : IntegralCoeffs W) {x y : H}
+    (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop) : 0 ≤ (W.toAffine.negY x y).orderTop :=
+  orderTop_sub_nonneg (orderTop_sub_nonneg (orderTop_neg_nonneg hy)
+    (orderTop_mul_nonneg hW.1 hx)) hW.2.2.1
+
+theorem coeff_zero_negY (W : WeierstrassCurve H) (hW : IntegralCoeffs W) {x y : H}
+    (hx : 0 ≤ x.orderTop) :
+    (W.toAffine.negY x y).coeff 0 =
+      (specialFibre W).toAffine.negY (x.coeff 0) (y.coeff 0) := by
+  change (-y - W.a₁ * x - W.a₃).coeff 0 =
+    -(y.coeff 0) - W.a₁.coeff 0 * x.coeff 0 - W.a₃.coeff 0
+  rw [HahnSeries.coeff_sub, HahnSeries.coeff_sub, HahnSeries.coeff_neg,
+    coeff_zero_mul_of_integral hW.1 hx]
+
+theorem chord_cross_identity (W : WeierstrassCurve H) {x₁ y₁ x₂ y₂ : H}
+    (e₁ : W.toAffine.Equation x₁ y₁) (e₂ : W.toAffine.Equation x₂ y₂) :
+    (y₁ - y₂) * (y₁ + y₂ + W.a₁ * x₁ + W.a₃) =
+      (x₁ - x₂) * (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂) := by
+  rw [WeierstrassCurve.Affine.equation_iff] at e₁ e₂
+  linear_combination e₁ - e₂
+
+theorem lift_tangentNum (W : WeierstrassCurve H) (hW : IntegralCoeffs W) {x y : H}
+    (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop) :
+    0 ≤ (3 * x ^ 2 + 2 * W.a₂ * x + W.a₄ - W.a₁ * y).orderTop ∧
+      (3 * x ^ 2 + 2 * W.a₂ * x + W.a₄ - W.a₁ * y).coeff 0 =
+        3 * (x.coeff 0) ^ 2 + 2 * W.a₂.coeff 0 * x.coeff 0 + W.a₄.coeff 0
+          - W.a₁.coeff 0 * y.coeff 0 := by
+  obtain ⟨h₁, h₂, h₃, h₄, h₆⟩ := hW
+  have hval : 3 * x ^ 2 + 2 * W.a₂ * x + W.a₄ - W.a₁ * y =
+      ((3 * ⟨x, hx⟩ ^ 2 + 2 * ⟨W.a₂, h₂⟩ * ⟨x, hx⟩ + ⟨W.a₄, h₄⟩
+        - ⟨W.a₁, h₁⟩ * ⟨y, hy⟩ : integralO) : H) := by
+    push_cast
+    rfl
+  constructor
+  · rw [hval]
+    exact mem_integralO.mp (SetLike.coe_mem _)
+  · rw [hval, ← resO_apply]
+    simp only [map_sub, map_add, map_mul, map_pow, map_ofNat, resO_apply]
+
+theorem lift_chordNum (W : WeierstrassCurve H) (hW : IntegralCoeffs W) {x₁ x₂ y₂ : H}
+    (hx₁ : 0 ≤ x₁.orderTop) (hx₂ : 0 ≤ x₂.orderTop) (hy₂ : 0 ≤ y₂.orderTop) :
+    0 ≤ (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂).orderTop ∧
+      (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂).coeff 0 =
+        (x₁.coeff 0) ^ 2 + x₁.coeff 0 * x₂.coeff 0 + (x₂.coeff 0) ^ 2
+          + W.a₂.coeff 0 * (x₁.coeff 0 + x₂.coeff 0) + W.a₄.coeff 0
+          - W.a₁.coeff 0 * y₂.coeff 0 := by
+  obtain ⟨h₁, h₂, h₃, h₄, h₆⟩ := hW
+  have hval : x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂ =
+      ((⟨x₁, hx₁⟩ ^ 2 + ⟨x₁, hx₁⟩ * ⟨x₂, hx₂⟩ + ⟨x₂, hx₂⟩ ^ 2
+        + ⟨W.a₂, h₂⟩ * (⟨x₁, hx₁⟩ + ⟨x₂, hx₂⟩) + ⟨W.a₄, h₄⟩
+        - ⟨W.a₁, h₁⟩ * ⟨y₂, hy₂⟩ : integralO) : H) := by
+    push_cast
+    rfl
+  constructor
+  · rw [hval]
+    exact mem_integralO.mp (SetLike.coe_mem _)
+  · rw [hval, ← resO_apply]
+    simp only [map_sub, map_add, map_mul, map_pow, resO_apply]
+
+theorem lift_chordDen (W : WeierstrassCurve H) (hW : IntegralCoeffs W) {x₁ y₁ y₂ : H}
+    (hx₁ : 0 ≤ x₁.orderTop) (hy₁ : 0 ≤ y₁.orderTop) (hy₂ : 0 ≤ y₂.orderTop) :
+    0 ≤ (y₁ + y₂ + W.a₁ * x₁ + W.a₃).orderTop ∧
+      (y₁ + y₂ + W.a₁ * x₁ + W.a₃).coeff 0 =
+        y₁.coeff 0 + y₂.coeff 0 + W.a₁.coeff 0 * x₁.coeff 0 + W.a₃.coeff 0 := by
+  obtain ⟨h₁, h₂, h₃, h₄, h₆⟩ := hW
+  have hval : y₁ + y₂ + W.a₁ * x₁ + W.a₃ =
+      ((⟨y₁, hy₁⟩ + ⟨y₂, hy₂⟩ + ⟨W.a₁, h₁⟩ * ⟨x₁, hx₁⟩ + ⟨W.a₃, h₃⟩ : integralO) : H) := by
+    push_cast
+    rfl
+  constructor
+  · rw [hval]
+    exact mem_integralO.mp (SetLike.coe_mem _)
+  · rw [hval, ← resO_apply]
+    simp only [map_add, map_mul, resO_apply]
+
+theorem lift_addX (W : WeierstrassCurve H) (hW : IntegralCoeffs W) {x₁ x₂ ℓ : H}
+    (hx₁ : 0 ≤ x₁.orderTop) (hx₂ : 0 ≤ x₂.orderTop) (hℓ : 0 ≤ ℓ.orderTop) :
+    0 ≤ (W.toAffine.addX x₁ x₂ ℓ).orderTop ∧
+      (W.toAffine.addX x₁ x₂ ℓ).coeff 0 =
+        (specialFibre W).toAffine.addX (x₁.coeff 0) (x₂.coeff 0) (ℓ.coeff 0) := by
+  obtain ⟨h₁, h₂, h₃, h₄, h₆⟩ := hW
+  have hval : W.toAffine.addX x₁ x₂ ℓ =
+      ((⟨ℓ, hℓ⟩ ^ 2 + ⟨W.a₁, h₁⟩ * ⟨ℓ, hℓ⟩ - ⟨W.a₂, h₂⟩ - ⟨x₁, hx₁⟩
+        - ⟨x₂, hx₂⟩ : integralO) : H) := by
+    change ℓ ^ 2 + W.a₁ * ℓ - W.a₂ - x₁ - x₂ = _
+    push_cast
+    rfl
+  constructor
+  · rw [hval]
+    exact mem_integralO.mp (SetLike.coe_mem _)
+  · rw [hval, ← resO_apply]
+    change _ = (ℓ.coeff 0) ^ 2 + W.a₁.coeff 0 * (ℓ.coeff 0) - W.a₂.coeff 0
+      - x₁.coeff 0 - x₂.coeff 0
+    simp only [map_sub, map_add, map_mul, map_pow, resO_apply]
+
+theorem orderTop_slope_neg_of_bar_vertical (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) {x₁ y₁ x₂ y₂ : H}
+    (h₁ : W.toAffine.Nonsingular x₁ y₁) (h₂ : W.toAffine.Nonsingular x₂ y₂)
+    (hx₁ : 0 ≤ x₁.orderTop) (hy₁ : 0 ≤ y₁.orderTop)
+    (hx₂ : 0 ≤ x₂.orderTop) (hy₂ : 0 ≤ y₂.orderTop)
+    (hv : ¬(x₁ = x₂ ∧ y₁ = W.toAffine.negY x₂ y₂))
+    (hvbx : x₁.coeff 0 = x₂.coeff 0)
+    (hvby : y₁.coeff 0 = (specialFibre W).toAffine.negY (x₂.coeff 0) (y₂.coeff 0)) :
+    (W.toAffine.slope x₁ x₂ y₁ y₂).orderTop < 0 := by
+  have hb1 := nonsingular_specialFibre W hW hΔ hx₁ hy₁ h₁
+  have hvby' : y₁.coeff 0 = -(y₂.coeff 0) - W.a₁.coeff 0 * x₂.coeff 0 - W.a₃.coeff 0 := hvby
+  by_cases hx12 : x₁ = x₂
+  · have hy12 : y₁ ≠ W.toAffine.negY x₂ y₂ := fun h => hv ⟨hx12, h⟩
+    have hy21 : y₁ = y₂ := WeierstrassCurve.Affine.Y_eq_of_Y_ne h₁.1 h₂.1 hx12 hy12
+    have hy21c : y₁.coeff 0 = y₂.coeff 0 := by rw [hy21]
+    rw [WeierstrassCurve.Affine.slope_of_Y_ne hx12 hy12]
+    have hdead : 2 * y₁.coeff 0 + W.a₁.coeff 0 * x₁.coeff 0 + W.a₃.coeff 0 = 0 := by
+      linear_combination hvby' + hy21c + W.a₁.coeff 0 * hvbx
+    obtain ⟨hNint, hNcoeff⟩ := lift_tangentNum W hW hx₁ hy₁
+    have hNbar : (3 * x₁ ^ 2 + 2 * W.a₂ * x₁ + W.a₄ - W.a₁ * y₁).coeff 0 ≠ 0 := by
+      obtain ⟨-, hdisj⟩ := (WeierstrassCurve.Affine.nonsingular_iff' _ _).mp hb1
+      rcases hdisj with hA | hB
+      · have hA' : W.a₁.coeff 0 * y₁.coeff 0
+            - (3 * (x₁.coeff 0) ^ 2 + 2 * W.a₂.coeff 0 * x₁.coeff 0 + W.a₄.coeff 0) ≠ 0 := hA
+        rw [hNcoeff]
+        intro h0
+        exact hA' (by linear_combination -h0)
+      · have hB' : 2 * y₁.coeff 0 + W.a₁.coeff 0 * x₁.coeff 0 + W.a₃.coeff 0 ≠ 0 := hB
+        exact absurd hdead hB'
+    have hNne : 3 * x₁ ^ 2 + 2 * W.a₂ * x₁ + W.a₄ - W.a₁ * y₁ ≠ 0 :=
+      fun h => hNbar (by rw [h]; exact HahnSeries.coeff_zero)
+    obtain ⟨hNord, -⟩ := order_eq_zero_of_coeff_zero_ne_zero hNint hNbar
+    have hdne : y₁ - W.toAffine.negY x₁ y₁ ≠ 0 :=
+      sub_ne_zero.mpr fun h => hy12 (by rw [← hx12, ← hy21]; exact h)
+    have hdint : 0 ≤ (y₁ - W.toAffine.negY x₁ y₁).orderTop :=
+      orderTop_sub_nonneg hy₁ (orderTop_negY_nonneg W hW hx₁ hy₁)
+    have hdbar : (y₁ - W.toAffine.negY x₁ y₁).coeff 0 = 0 := by
+      rw [HahnSeries.coeff_sub, coeff_zero_negY W hW hx₁]
+      change y₁.coeff 0 - (-(y₁.coeff 0) - W.a₁.coeff 0 * x₁.coeff 0 - W.a₃.coeff 0) = 0
+      linear_combination hdead
+    have hdpos : 0 < (y₁ - W.toAffine.negY x₁ y₁).order :=
+      order_pos_of_coeff_zero_eq_zero hdne hdint hdbar
+    have hQne : (3 * x₁ ^ 2 + 2 * W.a₂ * x₁ + W.a₄ - W.a₁ * y₁)
+        / (y₁ - W.toAffine.negY x₁ y₁) ≠ 0 := div_ne_zero hNne hdne
+    rw [← HahnSeries.order_eq_orderTop_of_ne_zero hQne,
+      order_div _ _ hNne hdne, hNord]
+    exact_mod_cast (by linarith : (0 : ℚ) - (y₁ - W.toAffine.negY x₁ y₁).order < 0)
+  · rw [WeierstrassCurve.Affine.slope_of_X_ne hx12]
+    have hsubne : x₁ - x₂ ≠ 0 := sub_ne_zero.mpr hx12
+    have hsubint : 0 ≤ (x₁ - x₂).orderTop := orderTop_sub_nonneg hx₁ hx₂
+    have hsubbar : (x₁ - x₂).coeff 0 = 0 := by
+      rw [HahnSeries.coeff_sub, sub_eq_zero]; exact hvbx
+    have hsubpos : 0 < (x₁ - x₂).order :=
+      order_pos_of_coeff_zero_eq_zero hsubne hsubint hsubbar
+    by_cases hyb : y₁.coeff 0 = y₂.coeff 0
+    · obtain ⟨hDint, hDcoeff⟩ := lift_chordDen W hW hx₁ hy₁ hy₂
+      obtain ⟨hNint, hNcoeff⟩ := lift_chordNum W hW hx₁ hx₂ hy₂
+      have hdead : 2 * y₁.coeff 0 + W.a₁.coeff 0 * x₁.coeff 0 + W.a₃.coeff 0 = 0 := by
+        linear_combination hvby' + hyb + W.a₁.coeff 0 * hvbx
+      have hNbar : (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄
+          - W.a₁ * y₂).coeff 0 ≠ 0 := by
+        obtain ⟨-, hdisj⟩ := (WeierstrassCurve.Affine.nonsingular_iff' _ _).mp hb1
+        rcases hdisj with hA | hB
+        · have hA' : W.a₁.coeff 0 * y₁.coeff 0
+              - (3 * (x₁.coeff 0) ^ 2 + 2 * W.a₂.coeff 0 * x₁.coeff 0 + W.a₄.coeff 0) ≠ 0 := hA
+          rw [hNcoeff]
+          intro h0
+          exact hA' (by linear_combination -h0 + W.a₁.coeff 0 * hyb
+            - (2 * x₁.coeff 0 + x₂.coeff 0 + W.a₂.coeff 0) * hvbx)
+        · have hB' : 2 * y₁.coeff 0 + W.a₁.coeff 0 * x₁.coeff 0 + W.a₃.coeff 0 ≠ 0 := hB
+          exact absurd hdead hB'
+      have hNne : x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂ ≠ 0 :=
+        fun h => hNbar (by rw [h]; exact HahnSeries.coeff_zero)
+      obtain ⟨hNord, -⟩ := order_eq_zero_of_coeff_zero_ne_zero hNint hNbar
+      have hDbar : (y₁ + y₂ + W.a₁ * x₁ + W.a₃).coeff 0 = 0 := by
+        rw [hDcoeff]
+        linear_combination hdead - hyb
+      have hDne : y₁ + y₂ + W.a₁ * x₁ + W.a₃ ≠ 0 := by
+        intro h0
+        have hKEY := chord_cross_identity W h₁.1 h₂.1
+        rw [h0, mul_zero] at hKEY
+        exact hNne ((mul_eq_zero.mp hKEY.symm).resolve_left hsubne)
+      have hDpos : 0 < (y₁ + y₂ + W.a₁ * x₁ + W.a₃).order :=
+        order_pos_of_coeff_zero_eq_zero hDne hDint hDbar
+      have hℓeq : (y₁ - y₂) / (x₁ - x₂) =
+          (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂)
+            / (y₁ + y₂ + W.a₁ * x₁ + W.a₃) := by
+        rw [div_eq_div_iff hsubne hDne]
+        linear_combination chord_cross_identity W h₁.1 h₂.1
+      rw [hℓeq]
+      have hQne : (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂)
+          / (y₁ + y₂ + W.a₁ * x₁ + W.a₃) ≠ 0 := div_ne_zero hNne hDne
+      rw [← HahnSeries.order_eq_orderTop_of_ne_zero hQne,
+        order_div _ _ hNne hDne, hNord]
+      exact_mod_cast (by linarith : (0 : ℚ) - (y₁ + y₂ + W.a₁ * x₁ + W.a₃).order < 0)
+    · have hnbar : (y₁ - y₂).coeff 0 ≠ 0 := by
+        rw [HahnSeries.coeff_sub]; exact sub_ne_zero.mpr hyb
+      have hnne : y₁ - y₂ ≠ 0 := fun h => hnbar (by rw [h]; exact HahnSeries.coeff_zero)
+      obtain ⟨hnord, -⟩ :=
+        order_eq_zero_of_coeff_zero_ne_zero (orderTop_sub_nonneg hy₁ hy₂) hnbar
+      have hQne : (y₁ - y₂) / (x₁ - x₂) ≠ 0 := div_ne_zero hnne hsubne
+      rw [← HahnSeries.order_eq_orderTop_of_ne_zero hQne,
+        order_div _ _ hnne hsubne, hnord]
+      exact_mod_cast (by linarith : (0 : ℚ) - (x₁ - x₂).order < 0)
+
+theorem slope_lift (W : WeierstrassCurve H) (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0)
+    {x₁ y₁ x₂ y₂ : H}
+    (h₁ : W.toAffine.Nonsingular x₁ y₁) (h₂ : W.toAffine.Nonsingular x₂ y₂)
+    (hx₁ : 0 ≤ x₁.orderTop) (hy₁ : 0 ≤ y₁.orderTop)
+    (hx₂ : 0 ≤ x₂.orderTop) (hy₂ : 0 ≤ y₂.orderTop)
+    (hvb : ¬(x₁.coeff 0 = x₂.coeff 0 ∧
+      y₁.coeff 0 = (specialFibre W).toAffine.negY (x₂.coeff 0) (y₂.coeff 0))) :
+    0 ≤ (W.toAffine.slope x₁ x₂ y₁ y₂).orderTop ∧
+      (W.toAffine.slope x₁ x₂ y₁ y₂).coeff 0 =
+        (specialFibre W).toAffine.slope (x₁.coeff 0) (x₂.coeff 0)
+          (y₁.coeff 0) (y₂.coeff 0) := by
+  have hb1 := nonsingular_specialFibre W hW hΔ hx₁ hy₁ h₁
+  have hb2 := nonsingular_specialFibre W hW hΔ hx₂ hy₂ h₂
+  by_cases hxb : x₁.coeff 0 = x₂.coeff 0
+  · have hyb : y₁.coeff 0 ≠ (specialFibre W).toAffine.negY (x₂.coeff 0) (y₂.coeff 0) :=
+      fun h => hvb ⟨hxb, h⟩
+    have hfs := WeierstrassCurve.Affine.slope_of_Y_ne hxb hyb
+    have hy21c : y₁.coeff 0 = y₂.coeff 0 :=
+      WeierstrassCurve.Affine.Y_eq_of_Y_ne hb1.1 hb2.1 hxb hyb
+    have hdbarne : y₁.coeff 0
+        - (specialFibre W).toAffine.negY (x₁.coeff 0) (y₁.coeff 0) ≠ 0 :=
+      sub_ne_zero.mpr fun h => hyb (by rw [← hxb, ← hy21c]; exact h)
+    by_cases hx12 : x₁ = x₂
+    · have hyne : y₁ ≠ W.toAffine.negY x₂ y₂ := by
+        intro h
+        exact hyb (by rw [h, coeff_zero_negY W hW hx₂])
+      rw [WeierstrassCurve.Affine.slope_of_Y_ne hx12 hyne, hfs]
+      obtain ⟨hNint, hNcoeff⟩ := lift_tangentNum W hW hx₁ hy₁
+      have hdint : 0 ≤ (y₁ - W.toAffine.negY x₁ y₁).orderTop :=
+        orderTop_sub_nonneg hy₁ (orderTop_negY_nonneg W hW hx₁ hy₁)
+      have hdbar : (y₁ - W.toAffine.negY x₁ y₁).coeff 0 =
+          y₁.coeff 0 - (specialFibre W).toAffine.negY (x₁.coeff 0) (y₁.coeff 0) := by
+        rw [HahnSeries.coeff_sub, coeff_zero_negY W hW hx₁]
+      obtain ⟨hint, hcoeff⟩ := coeff_zero_div_of_unit hNint hdint (by rw [hdbar]; exact hdbarne)
+      refine ⟨hint, ?_⟩
+      rw [hcoeff, hNcoeff, hdbar]
+      rfl
+    · obtain ⟨hDint, hDcoeff⟩ := lift_chordDen W hW hx₁ hy₁ hy₂
+      obtain ⟨hNint, hNcoeff⟩ := lift_chordNum W hW hx₁ hx₂ hy₂
+      have hsubne : x₁ - x₂ ≠ 0 := sub_ne_zero.mpr hx12
+      have hDbarne : (y₁ + y₂ + W.a₁ * x₁ + W.a₃).coeff 0 ≠ 0 := by
+        rw [hDcoeff]
+        intro h0
+        apply hyb
+        change y₁.coeff 0 = -(y₂.coeff 0) - W.a₁.coeff 0 * x₂.coeff 0 - W.a₃.coeff 0
+        linear_combination h0 - W.a₁.coeff 0 * hxb
+      have hDne : y₁ + y₂ + W.a₁ * x₁ + W.a₃ ≠ 0 :=
+        fun h => hDbarne (by rw [h]; exact HahnSeries.coeff_zero)
+      have hℓeq : W.toAffine.slope x₁ x₂ y₁ y₂ =
+          (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂)
+            / (y₁ + y₂ + W.a₁ * x₁ + W.a₃) := by
+        rw [WeierstrassCurve.Affine.slope_of_X_ne hx12, div_eq_div_iff hsubne hDne]
+        linear_combination chord_cross_identity W h₁.1 h₂.1
+      rw [hℓeq, hfs]
+      obtain ⟨hint, hcoeff⟩ := coeff_zero_div_of_unit hNint hDint hDbarne
+      refine ⟨hint, ?_⟩
+      rw [hcoeff, hNcoeff, hDcoeff]
+      change _ = (3 * (x₁.coeff 0) ^ 2 + 2 * W.a₂.coeff 0 * (x₁.coeff 0) + W.a₄.coeff 0
+          - W.a₁.coeff 0 * (y₁.coeff 0)) /
+        (y₁.coeff 0 - (-(y₁.coeff 0) - W.a₁.coeff 0 * (x₁.coeff 0) - W.a₃.coeff 0))
+      congr 1
+      · linear_combination (-(2 * x₁.coeff 0 + x₂.coeff 0 + W.a₂.coeff 0)) * hxb
+          + W.a₁.coeff 0 * hy21c
+      · linear_combination hy21c.symm
+  · have hx12 : x₁ ≠ x₂ := fun h => hxb (by rw [h])
+    rw [WeierstrassCurve.Affine.slope_of_X_ne hx12,
+      WeierstrassCurve.Affine.slope_of_X_ne hxb]
+    have hsubbar : (x₁ - x₂).coeff 0 ≠ 0 := by
+      rw [HahnSeries.coeff_sub]; exact sub_ne_zero.mpr hxb
+    obtain ⟨hint, hcoeff⟩ := coeff_zero_div_of_unit (orderTop_sub_nonneg hy₁ hy₂)
+      (orderTop_sub_nonneg hx₁ hx₂) hsubbar
+    refine ⟨hint, ?_⟩
+    rw [hcoeff, HahnSeries.coeff_sub, HahnSeries.coeff_sub]
+
+theorem some_point_ext {V : WeierstrassCurve.Affine Qbar} {x y x' y' : Qbar}
+    {h : V.Nonsingular x y} {h' : V.Nonsingular x' y'} (hx : x = x') (hy : y = y') :
+    WeierstrassCurve.Affine.Point.some x y h = WeierstrassCurve.Affine.Point.some x' y' h' := by
+  subst hx; subst hy; rfl
+
+theorem redPoint_add (W : WeierstrassCurve H) [W.IsElliptic] (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) {n : ℕ} (hn : n ≠ 0) {P Q : W.toAffine.Point}
+    (hP : n • P = 0) (hQ : n • Q = 0) :
+    redPoint W hW hΔ (P + Q) = redPoint W hW hΔ P + redPoint W hW hΔ Q := by
+  cases P with
+  | zero =>
+    change redPoint W hW hΔ (0 + Q) = redPoint W hW hΔ 0 + redPoint W hW hΔ Q
+    rw [zero_add, redPoint_zero, zero_add]
+  | some x₁ y₁ h₁ =>
+    cases Q with
+    | zero =>
+      change redPoint W hW hΔ (WeierstrassCurve.Affine.Point.some x₁ y₁ h₁ + 0) =
+        redPoint W hW hΔ (WeierstrassCurve.Affine.Point.some x₁ y₁ h₁) + redPoint W hW hΔ 0
+      rw [add_zero, redPoint_zero, add_zero]
+    | some x₂ y₂ h₂ =>
+      obtain ⟨hx₁, hy₁⟩ := torsion_coords_integral W hW hΔ h₁ hn hP
+      obtain ⟨hx₂, hy₂⟩ := torsion_coords_integral W hW hΔ h₂ hn hQ
+      by_cases hv : x₁ = x₂ ∧ y₁ = W.toAffine.negY x₂ y₂
+      · rw [WeierstrassCurve.Affine.Point.add_of_Y_eq hv.1 hv.2, redPoint_zero,
+          redPoint_some W hW hΔ hx₁ hy₁ h₁, redPoint_some W hW hΔ hx₂ hy₂ h₂]
+        exact (WeierstrassCurve.Affine.Point.add_of_Y_eq (by rw [hv.1])
+          (by rw [hv.2, coeff_zero_negY W hW hx₂])).symm
+      · have htor₃ : n • (WeierstrassCurve.Affine.Point.some x₁ y₁ h₁
+            + WeierstrassCurve.Affine.Point.some x₂ y₂ h₂) = 0 := by
+          rw [nsmul_add, hP, hQ, add_zero]
+        rw [WeierstrassCurve.Affine.Point.add_some hv] at htor₃ ⊢
+        by_cases hvb : x₁.coeff 0 = x₂.coeff 0 ∧
+            y₁.coeff 0 = (specialFibre W).toAffine.negY (x₂.coeff 0) (y₂.coeff 0)
+        · exact absurd (torsion_coords_integral W hW hΔ _ hn htor₃).1
+            (not_le.mpr (orderTop_addX_neg W hW hx₁ hx₂
+              (orderTop_slope_neg_of_bar_vertical W hW hΔ h₁ h₂ hx₁ hy₁ hx₂ hy₂
+                hv hvb.1 hvb.2)))
+        · obtain ⟨hsint, hscoeff⟩ := slope_lift W hW hΔ h₁ h₂ hx₁ hy₁ hx₂ hy₂ hvb
+          obtain ⟨hXint, hXcoeff⟩ := lift_addX W hW hx₁ hx₂ hsint
+          have hnAYint : 0 ≤ (W.toAffine.negAddY x₁ x₂ y₁
+              (W.toAffine.slope x₁ x₂ y₁ y₂)).orderTop := by
+            change 0 ≤ (W.toAffine.slope x₁ x₂ y₁ y₂
+              * (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₁) + y₁).orderTop
+            exact orderTop_add_nonneg
+              (orderTop_mul_nonneg hsint (orderTop_sub_nonneg hXint hx₁)) hy₁
+          have hnAYcoeff : (W.toAffine.negAddY x₁ x₂ y₁
+              (W.toAffine.slope x₁ x₂ y₁ y₂)).coeff 0 =
+              (specialFibre W).toAffine.negAddY (x₁.coeff 0) (x₂.coeff 0) (y₁.coeff 0)
+                ((W.toAffine.slope x₁ x₂ y₁ y₂).coeff 0) := by
+            change (W.toAffine.slope x₁ x₂ y₁ y₂
+              * (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₁) + y₁).coeff 0 = _
+            rw [HahnSeries.coeff_add,
+              coeff_zero_mul_of_integral hsint (orderTop_sub_nonneg hXint hx₁),
+              HahnSeries.coeff_sub, hXcoeff]
+            rfl
+          have hYint : 0 ≤ (W.toAffine.addY x₁ x₂ y₁
+              (W.toAffine.slope x₁ x₂ y₁ y₂)).orderTop :=
+            orderTop_negY_nonneg W hW hXint hnAYint
+          have hYcoeff : (W.toAffine.addY x₁ x₂ y₁
+              (W.toAffine.slope x₁ x₂ y₁ y₂)).coeff 0 =
+              (specialFibre W).toAffine.addY (x₁.coeff 0) (x₂.coeff 0) (y₁.coeff 0)
+                ((W.toAffine.slope x₁ x₂ y₁ y₂).coeff 0) := by
+            change (W.toAffine.negY (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂))
+              (W.toAffine.negAddY x₁ x₂ y₁ (W.toAffine.slope x₁ x₂ y₁ y₂))).coeff 0 = _
+            rw [coeff_zero_negY W hW hXint, hXcoeff, hnAYcoeff]
+            rfl
+          rw [redPoint_some W hW hΔ hXint hYint _,
+            redPoint_some W hW hΔ hx₁ hy₁ h₁, redPoint_some W hW hΔ hx₂ hy₂ h₂,
+            WeierstrassCurve.Affine.Point.add_some hvb]
+          exact some_point_ext (by rw [hXcoeff, hscoeff]) (by rw [hYcoeff, hscoeff])
+
+end E3
+
+universe u
+
+theorem bridge3Specialise_apply_coe (p : ℕ) [Fact p.Prime] [NeZero p] (j₀ : Qbar)
+    (G : CycSubH (nearCurve j₀) p) :
+    (bridge3Specialise p j₀ G).1 =
+      ((((G.1.map (scaleAddEquiv j₀ :
+              (nearCurve j₀).toAffine.Point →+ (goodModel j₀).toAffine.Point)).comap
+            (Submodule.torsionBy ℤ (goodModel j₀).toAffine.Point (p :
+              ℤ)).subtype.toAddMonoidHom).map
+          (redTorsionEquiv (goodModel j₀) (goodModel_spec j₀).1 (goodModel_spec j₀).2 p :
+            Submodule.torsionBy ℤ (goodModel j₀).toAffine.Point (p : ℤ) →+
+              Submodule.torsionBy ℤ (specialFibre (goodModel j₀)).toAffine.Point (p : ℤ))).map
+        (Submodule.torsionBy ℤ (specialFibre (goodModel j₀)).toAffine.Point
+          (p : ℤ)).subtype.toAddMonoidHom).map
+        (fibreAddEquiv j₀ :
+          (specialFibre (goodModel j₀)).toAffine.Point →+ (WeierstrassCurve.ofJ j₀).toAffine.Point)
+            :=
+  rfl
+
+theorem bridge3Specialise_zmultiples (p : ℕ) [Fact p.Prime] [NeZero p] (j₀ : Qbar)
+    (g : (nearCurve j₀).toAffine.Point) (hg : addOrderOf g = p) :
+    (bridge3Specialise p j₀ ⟨AddSubgroup.zmultiples g, g, hg, rfl⟩).1 =
+      AddSubgroup.zmultiples
+        (fibreAddEquiv j₀
+          ((redTorsionEquiv (goodModel j₀) (goodModel_spec j₀).1 (goodModel_spec j₀).2 p
+              ⟨scaleAddEquiv j₀ g,
+                mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ g).trans hg)⟩ :
+              Submodule.torsionBy ℤ (specialFibre (goodModel j₀)).toAffine.Point (p : ℤ)) :
+            (specialFibre (goodModel j₀)).toAffine.Point)) := by
+  have hmem : scaleAddEquiv j₀ g ∈ Submodule.torsionBy ℤ (goodModel j₀).toAffine.Point (p : ℤ) :=
+    mem_torsionBy_of_addOrderOf_eq ((AddEquiv.addOrderOf_eq _ g).trans hg)
+  rw [bridge3Specialise_apply_coe]
+  simp only [AddMonoidHom.map_zmultiples, AddMonoidHom.coe_ofClass, comap_subtype_zmultiples _ hmem,
+    LinearMap.toAddMonoidHom_coe, Submodule.subtype_apply]
+
+variable {K : Type*} [Field K]
+
+scoped instance isShortNF_a6Model (B : K) : (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve K).IsShortNF :=
+  ⟨rfl, rfl, rfl⟩
+
+scoped instance isShortNF_a4Model (A : K) : (⟨0, 0, 0, A, 0⟩ : WeierstrassCurve K).IsShortNF :=
+  ⟨rfl, rfl, rfl⟩
+
+theorem smul_a6Model_eq_iff [CharZero K] {B : K} (hB : B ≠ 0) (γ : VariableChange K) :
+    γ • (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve K) = ⟨0, 0, 0, 0, B⟩ ↔
+      γ.r = 0 ∧ γ.s = 0 ∧ γ.t = 0 ∧ (γ.u : K) ^ 6 = 1 :=
+  MulAction.mem_stabilizer_iff.symm.trans
+    (WeierstrassCurve.mem_stabilizer_variableChange_iff_of_isShortNF_of_a4_eq_zero
+      (by norm_num) (by norm_num) (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve K) rfl hB γ)
+
+theorem smul_a4Model_eq_iff [CharZero K] {A : K} (hA : A ≠ 0) (γ : VariableChange K) :
+    γ • (⟨0, 0, 0, A, 0⟩ : WeierstrassCurve K) = ⟨0, 0, 0, A, 0⟩ ↔
+      γ.r = 0 ∧ γ.s = 0 ∧ γ.t = 0 ∧ (γ.u : K) ^ 4 = 1 :=
+  MulAction.mem_stabilizer_iff.symm.trans
+    (WeierstrassCurve.mem_stabilizer_variableChange_iff_of_isShortNF_of_a6_eq_zero
+      (by norm_num) (by norm_num) (⟨0, 0, 0, A, 0⟩ : WeierstrassCurve K) rfl hA γ)
+
+theorem variableChange_eq_of_rst_eq_zero (γ : VariableChange K) (hr : γ.r = 0) (hs : γ.s = 0)
+    (ht : γ.t = 0) : γ = ⟨γ.u, 0, 0, 0⟩ :=
+  VariableChange.ext rfl hr hs ht
+
+def negVC (W : WeierstrassCurve K) : VariableChange K := ⟨-1, 0, -W.a₁, -W.a₃⟩
+
+@[scoped simp] theorem negVC_u (W : WeierstrassCurve K) : (negVC W).u = -1 := rfl
+@[scoped simp] theorem negVC_r (W : WeierstrassCurve K) : (negVC W).r = 0 := rfl
+@[scoped simp] theorem negVC_s (W : WeierstrassCurve K) : (negVC W).s = -W.a₁ := rfl
+@[scoped simp] theorem negVC_t (W : WeierstrassCurve K) : (negVC W).t = -W.a₃ := rfl
+
+theorem val_inv_negVC_u (W : WeierstrassCurve K) : (((negVC W).u⁻¹ : Kˣ) : K) = -1 := by
+  rw [negVC_u, Units.val_inv_eq_inv_val, Units.val_neg, Units.val_one, inv_neg, inv_one]
+
+theorem negVC_smul (W : WeierstrassCurve K) : negVC W • W = W := by
+  ext
+  · simp only [variableChange_a₁, val_inv_negVC_u, negVC_s]; ring
+  · simp only [variableChange_a₂, val_inv_negVC_u, negVC_r, negVC_s]; ring
+  · simp only [variableChange_a₃, val_inv_negVC_u, negVC_r, negVC_t]; ring
+  · simp only [variableChange_a₄, val_inv_negVC_u, negVC_r, negVC_s, negVC_t]; ring
+  · simp only [variableChange_a₆, val_inv_negVC_u, negVC_r, negVC_t]; ring
+
+theorem negVC_mul_negVC (W : WeierstrassCurve K) : negVC W * negVC W = 1 := by
+  refine VariableChange.ext ?_ ?_ ?_ ?_
+  · simp [VariableChange.mul_def, VariableChange.one_def]
+  · simp only [VariableChange.mul_def, VariableChange.one_def, negVC, Units.val_neg,
+      Units.val_one]; ring
+  · simp only [VariableChange.mul_def, VariableChange.one_def, negVC, Units.val_neg,
+      Units.val_one]; ring
+  · simp only [VariableChange.mul_def, VariableChange.one_def, negVC, Units.val_neg,
+      Units.val_one]; ring
+
+theorem negVC_ne_one [CharZero K] (W : WeierstrassCurve K) : negVC W ≠ 1 := fun h => by
+  have h1 : ((negVC W).u : K) = ((1 : VariableChange K).u : K) := by rw [h]
+  simp only [negVC_u, VariableChange.one_def, Units.val_neg, Units.val_one] at h1
+  norm_num at h1
+
+theorem ofJNe0Or1728_c₆ (j : K) :
+    (WeierstrassCurve.ofJNe0Or1728 j).c₆ = -j * (j - 1728) ^ 5 := by
+  simp only [WeierstrassCurve.ofJNe0Or1728, WeierstrassCurve.c₆, WeierstrassCurve.b₂,
+    WeierstrassCurve.b₄, WeierstrassCurve.b₆]
+  ring1
+
+theorem smul_ofJNe0Or1728_eq_iff [CharZero K] (j : K) (h0 : j ≠ 0) (h1728 : j ≠ 1728)
+    (γ : VariableChange K) :
+    γ • WeierstrassCurve.ofJNe0Or1728 j = WeierstrassCurve.ofJNe0Or1728 j ↔
+      γ = 1 ∨ γ = negVC (WeierstrassCurve.ofJNe0Or1728 j) := by
+  refine ⟨fun hγ => ?_, ?_⟩
+  swap
+  · rintro (rfl | rfl)
+    · exact one_smul _ _
+    · exact negVC_smul _
+  have ha : j - 1728 ≠ 0 := sub_ne_zero.mpr h1728
+  have e₁ := congrArg WeierstrassCurve.a₁ hγ
+  have e₂ := congrArg WeierstrassCurve.a₂ hγ
+  have e₃ := congrArg WeierstrassCurve.a₃ hγ
+  simp only [variableChange_a₁, variableChange_a₂, variableChange_a₃,
+    WeierstrassCurve.ofJNe0Or1728] at e₁ e₂ e₃
+  have e₄ := WeierstrassCurve.variableChange_c₄ (W := WeierstrassCurve.ofJNe0Or1728 j) (C := γ)
+  rw [hγ, WeierstrassCurve.ofJNe0Or1728_c₄] at e₄
+  have e₆ := WeierstrassCurve.variableChange_c₆ (W := WeierstrassCurve.ofJNe0Or1728 j) (C := γ)
+  rw [hγ, ofJNe0Or1728_c₆] at e₆
+  have hv4 : ((γ.u⁻¹ : Kˣ) : K) ^ 4 = 1 :=
+    mul_right_cancel₀ (mul_ne_zero h0 (pow_ne_zero 3 ha)) (by rw [one_mul]; exact e₄.symm)
+  have hv6 : ((γ.u⁻¹ : Kˣ) : K) ^ 6 = 1 :=
+    mul_right_cancel₀ (mul_ne_zero (neg_ne_zero.mpr h0) (pow_ne_zero 5 ha))
+      (by rw [one_mul]; exact e₆.symm)
+  have hv2 : ((γ.u⁻¹ : Kˣ) : K) ^ 2 = 1 := by
+    have h := hv6
+    rwa [show ((γ.u⁻¹ : Kˣ) : K) ^ 6 = ((γ.u⁻¹ : Kˣ) : K) ^ 4 * ((γ.u⁻¹ : Kˣ) : K) ^ 2 by ring,
+      hv4, one_mul] at h
+  rcases mul_self_eq_one_iff.mp ((pow_two _).symm.trans hv2) with hv | hv
+  · rw [hv] at e₁ e₂ e₃
+    have hs : γ.s = 0 := by linear_combination e₁ / 2
+    rw [hs] at e₂
+    have hr : γ.r = 0 := by linear_combination e₂ / 3
+    rw [hr] at e₃
+    have ht : γ.t = 0 := by linear_combination e₃ / 2
+    have hu : γ.u = 1 := by rwa [Units.val_eq_one, inv_eq_one] at hv
+    exact Or.inl (VariableChange.ext hu hr hs ht)
+  · rw [hv] at e₁ e₂ e₃
+    have hs : γ.s = -(j - 1728) := by linear_combination (-1 / 2 : K) * e₁
+    rw [hs] at e₂
+    have hr : γ.r = 0 := by linear_combination e₂ / 3
+    rw [hr] at e₃
+    have ht : γ.t = 0 := by linear_combination (-1 / 2 : K) * e₃
+    have hu : γ.u = -1 := by
+      refine Units.ext ?_
+      rw [Units.val_inv_eq_inv_val] at hv
+      rw [Units.val_neg, Units.val_one, ← inv_inv (γ.u : K), hv, inv_neg, inv_one]
+    exact Or.inr (VariableChange.ext hu hr hs (ht.trans neg_zero.symm))
+
+theorem smul_ofJ_eq_iff [DecidableEq K] [CharZero K] (j : K) (h0 : j ≠ 0) (h1728 : j ≠ 1728)
+    (γ : VariableChange K) :
+    γ • WeierstrassCurve.ofJ j = WeierstrassCurve.ofJ j ↔
+      γ = 1 ∨ γ = negVC (WeierstrassCurve.ofJ j) := by
+  rw [WeierstrassCurve.ofJ_ne_0_ne_1728 j h0 h1728]
+  exact smul_ofJNe0Or1728_eq_iff j h0 h1728 γ
+
+section Points
+
+theorem heq_point_zero {W V : WeierstrassCurve.Affine K} (hWV : W = V) :
+    HEq (0 : W.Point) (0 : V.Point) := by
+  subst hWV; rfl
+
+theorem heq_point_some {W V : WeierstrassCurve.Affine K} (hWV : W = V) {x y x' y' : K}
+    (hx : x = x') (hy : y = y') {h : W.Nonsingular x y} {h' : V.Nonsingular x' y'} :
+    HEq (WeierstrassCurve.Affine.Point.some x y h)
+      (WeierstrassCurve.Affine.Point.some x' y' h') := by
+  subst hWV hx hy; rfl
+
+theorem heq_vcInvFun_one (W : WeierstrassCurve K) (P : W.toAffine.Point) :
+    HEq (WeierstrassCurve.Affine.Point.vcInvFun (1 : VariableChange K) W.toAffine P) P := by
+  rcases P with _ | ⟨x, y, h⟩
+  · exact heq_point_zero (one_smul _ _)
+  · refine heq_point_some (one_smul _ _) ?_ ?_
+    · simp [WeierstrassCurve.Affine.vcXInv, VariableChange.one_def]
+    · simp [WeierstrassCurve.Affine.vcYInv, VariableChange.one_def]
+
+theorem heq_vcInvFun_negVC (W : WeierstrassCurve K) (P : W.toAffine.Point) :
+    HEq (WeierstrassCurve.Affine.Point.vcInvFun (negVC W) W.toAffine P) (-P) := by
+  rcases P with _ | ⟨x, y, h⟩
+  · exact heq_point_zero (negVC_smul W)
+  · refine heq_point_some (negVC_smul W) ?_ ?_
+    · simp only [WeierstrassCurve.Affine.vcXInv, val_inv_negVC_u, negVC_r]; ring
+    · simp only [WeierstrassCurve.Affine.vcYInv, val_inv_negVC_u, negVC_r, negVC_s, negVC_t,
+        WeierstrassCurve.Affine.negY]; ring
+
+theorem heq_vcInvFun_mul (γ δ : VariableChange K) (W : WeierstrassCurve K)
+    (P : W.toAffine.Point) :
+    HEq (WeierstrassCurve.Affine.Point.vcInvFun (γ * δ) W.toAffine P)
+      (WeierstrassCurve.Affine.Point.vcInvFun γ (δ • W).toAffine
+        (WeierstrassCurve.Affine.Point.vcInvFun δ W.toAffine P)) := by
+  have hu : (γ.u : K) ≠ 0 := γ.u.ne_zero
+  have hv : (δ.u : K) ≠ 0 := δ.u.ne_zero
+  rcases P with _ | ⟨x, y, h⟩
+  · exact heq_point_zero (mul_smul γ δ W)
+  · refine heq_point_some (mul_smul γ δ W) ?_ ?_
+    · simp only [WeierstrassCurve.Affine.vcXInv, VariableChange.mul_def, mul_inv_rev,
+        Units.val_mul, Units.val_inv_eq_inv_val]
+      field_simp
+      ring
+    · simp only [WeierstrassCurve.Affine.vcXInv, WeierstrassCurve.Affine.vcYInv,
+        VariableChange.mul_def, mul_inv_rev, Units.val_mul, Units.val_inv_eq_inv_val]
+      field_simp
+      ring
+
+theorem heq_vcInvFun_congr (γ : VariableChange K) {W W' : WeierstrassCurve.Affine K}
+    (hW : W = W') {P : W.Point} {P' : W'.Point} (hP : HEq P P') :
+    HEq (WeierstrassCurve.Affine.Point.vcInvFun γ W P)
+      (WeierstrassCurve.Affine.Point.vcInvFun γ W' P') := by
+  subst hW
+  obtain rfl := eq_of_heq hP
+  rfl
+
+theorem zmultiples_eq_of_heq_vcInvFun [DecidableEq K] [CharZero K] {j : K} (h0 : j ≠ 0)
+    (h1728 : j ≠ 1728)
+    {γ : VariableChange K} (hγ : γ • WeierstrassCurve.ofJ j = WeierstrassCurve.ofJ j)
+    {g g' : (WeierstrassCurve.ofJ j).toAffine.Point}
+    (h : HEq g' (WeierstrassCurve.Affine.Point.vcInvFun γ (WeierstrassCurve.ofJ j).toAffine g)) :
+    AddSubgroup.zmultiples g' = AddSubgroup.zmultiples g := by
+  rcases (smul_ofJ_eq_iff j h0 h1728 γ).mp hγ with rfl | rfl
+  · rw [eq_of_heq (h.trans (heq_vcInvFun_one _ g))]
+  · rw [eq_of_heq (h.trans (heq_vcInvFun_negVC _ g)), AddSubgroup.zmultiples_neg]
+
+theorem conj_smul_eq {F E : WeierstrassCurve K} {φ γ : VariableChange K} (hφ : φ • F = E)
+    (hγ : γ • E = E) : (φ⁻¹ * γ * φ) • F = F := by
+  rw [mul_smul, mul_smul, hφ, hγ, ← hφ, inv_smul_smul]
+
+def vcEquivOfSMulEq [DecidableEq K] {F E : WeierstrassCurve K} (φ : VariableChange K)
+    (hφ : φ • F = E) :
+    F.toAffine.Point ≃+ E.toAffine.Point :=
+  (vcAddEquiv φ F).trans (pointAddEquivOfEq hφ)
+
+theorem heq_pointAddEquivOfEq [DecidableEq K] {W V : WeierstrassCurve K} (h : W = V)
+    (P : W.toAffine.Point) :
+    HEq (pointAddEquivOfEq h P) P := by
+  subst h; rfl
+
+theorem heq_vcEquivOfSMulEq [DecidableEq K] {F E : WeierstrassCurve K} (φ : VariableChange K)
+    (hφ : φ • F = E) (P : F.toAffine.Point) :
+    HEq (vcEquivOfSMulEq φ hφ P) (WeierstrassCurve.Affine.Point.vcInvFun φ F.toAffine P) := by
+  subst hφ; rfl
+
+theorem heq_vcInvFun_iff_eq [DecidableEq K] {W : WeierstrassCurve K} (γ : VariableChange K)
+    (hγ : γ • W = W) (g g' : W.toAffine.Point) :
+    HEq g' (WeierstrassCurve.Affine.Point.vcInvFun γ W.toAffine g) ↔
+      g' = vcEquivOfSMulEq γ hγ g :=
+  ⟨fun h => eq_of_heq (h.trans (heq_vcEquivOfSMulEq γ hγ g).symm),
+    fun h => h ▸ heq_vcEquivOfSMulEq γ hγ g⟩
+
+theorem vcEquivOfSMulEq_conj [DecidableEq K] {F E : WeierstrassCurve K} {φ γ : VariableChange K}
+    (hφ : φ • F = E) (hγ : γ • E = E) (P : F.toAffine.Point) :
+    vcEquivOfSMulEq φ hφ (vcEquivOfSMulEq (φ⁻¹ * γ * φ) (conj_smul_eq hφ hγ) P) =
+      vcEquivOfSMulEq γ hγ (vcEquivOfSMulEq φ hφ P) := by
+  apply eq_of_heq
+  have hL₁ := heq_vcEquivOfSMulEq φ hφ (vcEquivOfSMulEq (φ⁻¹ * γ * φ) (conj_smul_eq hφ hγ) P)
+  have hL₂ : HEq (WeierstrassCurve.Affine.Point.vcInvFun φ F.toAffine
+      (vcEquivOfSMulEq (φ⁻¹ * γ * φ) (conj_smul_eq hφ hγ) P))
+      (WeierstrassCurve.Affine.Point.vcInvFun φ ((φ⁻¹ * γ * φ) • F).toAffine
+        (WeierstrassCurve.Affine.Point.vcInvFun (φ⁻¹ * γ * φ) F.toAffine P)) :=
+    heq_vcInvFun_congr φ (congrArg WeierstrassCurve.toAffine (conj_smul_eq hφ hγ).symm)
+      (heq_vcEquivOfSMulEq _ _ P)
+  have hL₃ := (heq_vcInvFun_mul φ (φ⁻¹ * γ * φ) F P).symm
+  have hmul : φ * (φ⁻¹ * γ * φ) = γ * φ := by rw [mul_assoc, mul_inv_cancel_left]
+  have hL₄ : HEq (WeierstrassCurve.Affine.Point.vcInvFun (φ * (φ⁻¹ * γ * φ)) F.toAffine P)
+      (WeierstrassCurve.Affine.Point.vcInvFun (γ * φ) F.toAffine P) := by
+    rw [hmul]
+  have hL₅ := heq_vcInvFun_mul γ φ F P
+  have hR₁ := heq_vcEquivOfSMulEq γ hγ (vcEquivOfSMulEq φ hφ P)
+  have hR₂ : HEq (WeierstrassCurve.Affine.Point.vcInvFun γ E.toAffine (vcEquivOfSMulEq φ hφ P))
+      (WeierstrassCurve.Affine.Point.vcInvFun γ (φ • F).toAffine
+        (WeierstrassCurve.Affine.Point.vcInvFun φ F.toAffine P)) :=
+    heq_vcInvFun_congr γ (congrArg WeierstrassCurve.toAffine hφ.symm) (heq_vcEquivOfSMulEq _ _ P)
+  exact ((((hL₁.trans hL₂).trans hL₃).trans hL₄).trans hL₅).trans (hR₁.trans hR₂).symm
+
+theorem conj_smul_eq' {F E : WeierstrassCurve K} {φ γ' : VariableChange K} (hφ : φ • F = E)
+    (hγ' : γ' • F = F) : (φ * γ' * φ⁻¹) • E = E := by
+  rw [mul_smul, mul_smul, inv_smul_eq_iff.mpr hφ.symm, hγ', hφ]
+
+theorem vcEquivOfSMulEq_congr [DecidableEq K] {F E : WeierstrassCurve K} {φ φ' : VariableChange K}
+    (e : φ = φ') (hφ : φ • F = E) (hφ' : φ' • F = E) :
+    vcEquivOfSMulEq φ hφ = vcEquivOfSMulEq φ' hφ' := by
+  subst e; rfl
+
+theorem eq_conj_of_heq_vcInvFun [DecidableEq K] {F E : WeierstrassCurve K} {φ γ : VariableChange K}
+    (hφ : φ • F = E) (hγ : γ • E = E) (P : F.toAffine.Point) {Q' : E.toAffine.Point}
+    (h : HEq Q' (WeierstrassCurve.Affine.Point.vcInvFun γ E.toAffine (vcEquivOfSMulEq φ hφ P))) :
+    Q' = vcEquivOfSMulEq φ hφ (vcEquivOfSMulEq (φ⁻¹ * γ * φ) (conj_smul_eq hφ hγ) P) := by
+  rw [(heq_vcInvFun_iff_eq γ hγ _ Q').mp h, vcEquivOfSMulEq_conj hφ hγ P]
+
+end Points
+
+theorem sameOrbit_iff (E₀ : WeierstrassCurve Qbar) (H H' : AddSubgroup E₀.toAffine.Point) :
+    SameOrbit E₀ H H' ↔
+      ∃ γ : VariableChange Qbar, ∃ _ : γ • E₀ = E₀, ∃ g g' : E₀.toAffine.Point,
+        H = AddSubgroup.zmultiples g ∧ H' = AddSubgroup.zmultiples g' ∧
+          HEq g' (WeierstrassCurve.Affine.Point.vcInvFun γ E₀.toAffine g) :=
+  Iff.rfl
+
+theorem sameOrbit_refl (E₀ : WeierstrassCurve Qbar) (g : E₀.toAffine.Point) :
+    SameOrbit E₀ (AddSubgroup.zmultiples g) (AddSubgroup.zmultiples g) :=
+  ⟨1, one_smul _ _, g, g, rfl, rfl, (heq_vcInvFun_one E₀ g).symm⟩
+
+theorem sameOrbit_symm {E₀ : WeierstrassCurve Qbar} {H H' : AddSubgroup E₀.toAffine.Point}
+    (h : SameOrbit E₀ H H') : SameOrbit E₀ H' H := by
+  obtain ⟨γ, hγ, g, g', hH, hH', hg⟩ := h
+  refine ⟨γ⁻¹, inv_smul_eq_iff.mpr hγ.symm, g', g, hH', hH, ?_⟩
+  have h₁ : HEq (WeierstrassCurve.Affine.Point.vcInvFun γ⁻¹ E₀.toAffine g')
+      (WeierstrassCurve.Affine.Point.vcInvFun γ⁻¹ (γ • E₀).toAffine
+        (WeierstrassCurve.Affine.Point.vcInvFun γ E₀.toAffine g)) :=
+    heq_vcInvFun_congr γ⁻¹ (congrArg WeierstrassCurve.toAffine hγ.symm) hg
+  have h₂ := (heq_vcInvFun_mul γ⁻¹ γ E₀ g).symm
+  have h₃ : HEq (WeierstrassCurve.Affine.Point.vcInvFun (γ⁻¹ * γ) E₀.toAffine g)
+      (WeierstrassCurve.Affine.Point.vcInvFun (1 : VariableChange Qbar) E₀.toAffine g) := by
+    rw [inv_mul_cancel]
+  exact (((h₁.trans h₂).trans h₃).trans (heq_vcInvFun_one E₀ g)).symm
+
+theorem sameOrbit_ofJ_iff_of_ne (j₀ : Qbar) (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728)
+    (H H' : AddSubgroup (WeierstrassCurve.ofJ j₀).toAffine.Point) :
+    SameOrbit (WeierstrassCurve.ofJ j₀) H H' ↔ H = H' ∧ ∃ g, H = AddSubgroup.zmultiples g := by
+  constructor
+  · rintro ⟨γ, hγ, g, g', rfl, rfl, hg⟩
+    exact ⟨(zmultiples_eq_of_heq_vcInvFun h0 h1728 hγ hg).symm, g, rfl⟩
+  · rintro ⟨rfl, g, rfl⟩
+    exact sameOrbit_refl _ g
+
+theorem sameOrbit_of_conj {F E : WeierstrassCurve Qbar} {φ γ' : VariableChange Qbar}
+    (hφ : φ • F = E) (hγ' : γ' • F = F) (P : F.toAffine.Point) :
+    SameOrbit E (AddSubgroup.zmultiples (vcEquivOfSMulEq φ hφ P))
+      (AddSubgroup.zmultiples (vcEquivOfSMulEq φ hφ (vcEquivOfSMulEq γ' hγ' P))) := by
+  refine ⟨φ * γ' * φ⁻¹, conj_smul_eq' hφ hγ', _, _, rfl, rfl, ?_⟩
+  rw [heq_vcInvFun_iff_eq (φ * γ' * φ⁻¹) (conj_smul_eq' hφ hγ'),
+    ← vcEquivOfSMulEq_conj hφ (conj_smul_eq' hφ hγ') P,
+    vcEquivOfSMulEq_congr (show φ⁻¹ * (φ * γ' * φ⁻¹) * φ = γ' by group)
+      (conj_smul_eq hφ (conj_smul_eq' hφ hγ')) hγ']
+
+section H6B
+
+open WeierstrassCurve.Affine
+
+theorem some_point_ext' {K : Type*} [Field K] {V : WeierstrassCurve.Affine K} {x y x' y' : K}
+    {h : V.Nonsingular x y} {h' : V.Nonsingular x' y'} (hx : x = x') (hy : y = y') :
+    WeierstrassCurve.Affine.Point.some x y h = WeierstrassCurve.Affine.Point.some x' y' h' := by
+  subst hx; subst hy; rfl
+
+theorem pointAddEquivOfEq_apply_of_eq_some {K : Type*} [Field K] [DecidableEq K]
+    {W V : WeierstrassCurve K} (hWV : W = V) {P : W.toAffine.Point} {x y : K}
+    {h : W.toAffine.Nonsingular x y} (hP : P = WeierstrassCurve.Affine.Point.some x y h) :
+    pointAddEquivOfEq hWV P = WeierstrassCurve.Affine.Point.some x y (hWV ▸ h) := by
+  subst hWV
+  rw [pointAddEquivOfEq_rfl, hP]
+  rfl
+
+theorem coeff_zero_of_mem_monodromy {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    (x : H) : (m x).coeff 0 = x.coeff 0 := by
+  obtain ⟨χ, hχ, rfl⟩ := hm
+  rw [HahnSeries.hahnTwistHom_apply, HahnSeries.coeff_hahnTwist, ofAdd_zero, map_one,
+    Units.val_one, one_mul]
+
+theorem orderTop_of_mem_monodromy {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    (x : H) : (m x).orderTop = x.orderTop := by
+  obtain ⟨χ, hχ, rfl⟩ := hm
+  rcases eq_or_ne x 0 with rfl | hx
+  · rw [map_zero]
+  · have hmx : (HahnSeries.hahnTwistHom χ) x ≠ 0 := fun h0 =>
+      hx ((HahnSeries.hahnTwistHom χ).injective (h0.trans (map_zero _).symm))
+    rw [← HahnSeries.order_eq_orderTop_of_ne_zero hx,
+      ← HahnSeries.order_eq_orderTop_of_ne_zero hmx, HahnSeries.hahnTwistHom_apply,
+      HahnSeries.order_hahnTwist]
+
+theorem monodromy_fixes_natSupport {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    (x : H) (hx : ∀ a : ℚ, x.coeff a ≠ 0 → ∃ n : ℕ, a = (n : ℚ)) : m x = x := by
+  obtain ⟨χ, hχ, rfl⟩ := hm
+  rw [HahnSeries.hahnTwistHom_apply]
+  ext a
+  rw [HahnSeries.coeff_hahnTwist]
+  rcases eq_or_ne (x.coeff a) 0 with h0 | h0
+  · rw [h0, mul_zero]
+  · obtain ⟨n, rfl⟩ := hx a h0
+    have hofAdd : Multiplicative.ofAdd ((n : ℚ)) = Multiplicative.ofAdd ((1 : ℚ)) ^ n := by
+      rw [← ofAdd_nsmul, nsmul_eq_mul, mul_one]
+    have hn : χ (Multiplicative.ofAdd ((n : ℚ))) = 1 := by
+      rw [hofAdd, map_pow, HahnSeries.mem_monoChar_iff.mp hχ, one_pow]
+    rw [hn, Units.val_one, one_mul]
+
+theorem monodromy_fixes_ofPowerSeries {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    (f : PowerSeries Qbar) : m (ι f) = ι f := by
+  refine monodromy_fixes_natSupport hm _ fun a ha => ?_
+  by_contra hn
+  rw [not_exists] at hn
+  refine ha ?_
+  rw [HahnSeries.ofPowerSeries_apply]
+  exact HahnSeries.embDomain_of_notMem_range fun hmem => by
+    obtain ⟨n, hna⟩ := hmem
+    exact hn n hna.symm
+
+theorem monodromy_fixes_C (m : H ≃ₐ[Qbar] H) (q : Qbar) :
+    m (HahnSeries.C q) = HahnSeries.C q := by
+  have hC : algebraMap Qbar H q = HahnSeries.C q := by
+    rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_eq, HahnSeries.ofPowerSeries_C]
+  rw [← hC]
+  exact m.commutes q
+
+theorem zeta_pow_eq_one_of_twist {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    {q : ℚ} {ζ : Qbar} {n k : ℕ} (hζs : m (HahnSeries.single q 1) = HahnSeries.single q ζ)
+    (hq : n • q = ((k : ℕ) : ℚ)) : ζ ^ n = 1 := by
+  have hfix : m (HahnSeries.single ((k : ℕ) : ℚ) 1) = HahnSeries.single ((k : ℕ) : ℚ) 1 :=
+    monodromy_fixes_natSupport hm _ fun a ha => ⟨k, by
+      by_contra hne
+      exact ha (HahnSeries.coeff_single_of_ne hne)⟩
+  have key : HahnSeries.single ((k : ℕ) : ℚ) (ζ ^ n) = HahnSeries.single ((k : ℕ) : ℚ) 1 := by
+    calc HahnSeries.single ((k : ℕ) : ℚ) (ζ ^ n)
+        = (HahnSeries.single q ζ) ^ n := by rw [HahnSeries.single_pow, hq]
+      _ = (m (HahnSeries.single q 1)) ^ n := by rw [hζs]
+      _ = m (HahnSeries.single q 1 ^ n) := (map_pow m _ n).symm
+      _ = m (HahnSeries.single ((k : ℕ) : ℚ) 1) := by rw [HahnSeries.single_pow, hq, one_pow]
+      _ = HahnSeries.single ((k : ℕ) : ℚ) 1 := hfix
+  have hcoeff := congrArg (fun z : H => z.coeff ((k : ℕ) : ℚ)) key
+  simpa [HahnSeries.coeff_single_same] using hcoeff
+
+theorem zeta_ne_zero_of_pow_eq_one {ζ : Qbar} {n : ℕ} (hn : n ≠ 0) (h : ζ ^ n = 1) : ζ ≠ 0 := by
+  rintro rfl
+  rw [zero_pow hn] at h
+  exact zero_ne_one h
+
+theorem C_pow_mul_single (c : Qbar) (n : ℕ) (q : ℚ) :
+    HahnSeries.C c ^ n * HahnSeries.single q (1 : Qbar) = HahnSeries.single q (c ^ n) := by
+  rw [show (HahnSeries.C c : H) = HahnSeries.single 0 c from rfl, HahnSeries.single_pow,
+    HahnSeries.single_mul_single, smul_zero, zero_add, mul_one]
+
+theorem single_two_twelfths :
+    HahnSeries.single (2 / 12 : ℚ) (1 : Qbar) = HahnSeries.single (1 / 6 : ℚ) 1 := by
+  rw [show (2 / 12 : ℚ) = 1 / 6 by norm_num]
+
+theorem m_single_sixth {m : H ≃ₐ[Qbar] H} {ζ : Qbar}
+    (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ) :
+    m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.C ζ * HahnSeries.single (1 / 6 : ℚ) 1 := by
+  rw [hζs, show (HahnSeries.C ζ : H) * HahnSeries.single (1 / 6 : ℚ) 1 =
+    HahnSeries.single (1 / 6 : ℚ) (ζ ^ 1) from by
+      rw [← C_pow_mul_single ζ 1 (1 / 6 : ℚ), pow_one], pow_one]
+
+theorem m_single_third {m : H ≃ₐ[Qbar] H} {ζ : Qbar}
+    (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ) :
+    m (HahnSeries.single (1 / 3 : ℚ) 1) =
+      HahnSeries.C ζ ^ 2 * HahnSeries.single (1 / 3 : ℚ) 1 := by
+  have h13 : HahnSeries.single (1 / 3 : ℚ) (1 : Qbar) =
+      HahnSeries.single (1 / 6 : ℚ) 1 * HahnSeries.single (1 / 6 : ℚ) 1 := by
+    rw [HahnSeries.single_mul_single, mul_one]
+    congr 1
+    norm_num
+  rw [C_pow_mul_single, h13, map_mul, hζs, HahnSeries.single_mul_single]
+  congr 1
+  · norm_num
+  · ring
+
+theorem m_single_quarter_1728 {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    {ζ : Qbar} (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ) :
+    m (HahnSeries.single (1 / 4 : ℚ) 1) =
+      HahnSeries.C ζ ^ 3 * HahnSeries.single (1 / 4 : ℚ) 1 := by
+  obtain ⟨χ, hχ, rfl⟩ := hm
+  rw [HahnSeries.hahnTwistHom_apply] at hζs ⊢
+  rw [HahnSeries.hahnTwist_single] at hζs ⊢
+  have hval : (χ (Multiplicative.ofAdd (3 / 4 : ℚ)) : Qbar) = ζ := by
+    have hcoeff := congrArg (fun z : H => z.coeff (3 / 4 : ℚ)) hζs
+    simpa [HahnSeries.coeff_single_same] using hcoeff
+  have hc4 : (χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar) ^ 4 = 1 := by
+    have h14 : (4 : ℕ) • (1 / 4 : ℚ) = (1 : ℚ) := by norm_num
+    have h := HahnSeries.mem_monoChar_iff.mp hχ
+    rw [← h14, ofAdd_nsmul, map_pow] at h
+    calc (χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar) ^ 4
+        = ((χ (Multiplicative.ofAdd (1 / 4 : ℚ)) ^ 4 : Qbarˣ) : Qbar) :=
+          (Units.val_pow_eq_pow_val _ _).symm
+      _ = ((1 : Qbarˣ) : Qbar) := by rw [h]
+      _ = 1 := Units.val_one
+  have hc3 : (χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar) ^ 3 = ζ := by
+    have h34 : (3 : ℕ) • (1 / 4 : ℚ) = (3 / 4 : ℚ) := by norm_num
+    rw [← hval, ← h34, ofAdd_nsmul, map_pow]
+    exact (Units.val_pow_eq_pow_val _ _).symm
+  have hc : (χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar) = ζ ^ 3 := by
+    calc (χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar)
+        = ((χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar) ^ 4) ^ 2 *
+            (χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar) := by rw [hc4]; ring
+      _ = ((χ (Multiplicative.ofAdd (1 / 4 : ℚ)) : Qbar) ^ 3) ^ 3 := by ring
+      _ = ζ ^ 3 := by rw [hc3]
+  rw [C_pow_mul_single, mul_one, hc]
+
+theorem m_single_half_1728 {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    {ζ : Qbar} (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ) :
+    m (HahnSeries.single (1 / 2 : ℚ) 1) =
+      HahnSeries.C ζ ^ 2 * HahnSeries.single (1 / 2 : ℚ) 1 := by
+  have hζ4 : ζ ^ 4 = 1 := zeta_pow_eq_one_of_twist (k := 3) hm hζs (by norm_num)
+  have h12 : HahnSeries.single (1 / 2 : ℚ) (1 : Qbar) =
+      HahnSeries.single (1 / 4 : ℚ) 1 * HahnSeries.single (1 / 4 : ℚ) 1 := by
+    rw [HahnSeries.single_mul_single, mul_one]
+    congr 1
+    norm_num
+  rw [C_pow_mul_single, h12, map_mul, m_single_quarter_1728 hm hζs, C_pow_mul_single,
+    HahnSeries.single_mul_single]
+  congr 1
+  · norm_num
+  · calc ζ ^ 3 * ζ ^ 3 = ζ ^ 4 * ζ ^ 2 := by ring
+      _ = ζ ^ 2 := by rw [hζ4, one_mul]
+
+theorem C_mul_single (c : Qbar) (q : ℚ) :
+    HahnSeries.C c * HahnSeries.single q (1 : Qbar) = HahnSeries.single q c := by
+  rw [show (HahnSeries.C c : H) = HahnSeries.single 0 c from rfl, HahnSeries.single_mul_single,
+    zero_add, mul_one]
+
+theorem coeff_zero_C (c : Qbar) : (HahnSeries.C c : H).coeff 0 = c := by
+  rw [show (HahnSeries.C c : H) = HahnSeries.single 0 c from rfl]
+  simp
+
+theorem m_a4_zero (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar) (ζ : Qbar)
+    (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ) :
+    m (goodModel 0).a₄ = HahnSeries.C ζ ^ 2 * (goodModel 0).a₄ := by
+  rw [goodModel_zero_eq]
+  change m (HahnSeries.single (1 / 3 : ℚ) 1 *
+      ι (PowerSeries.C (-1 / 48 : Qbar) * (PowerSeries.X - PowerSeries.C 1728) ^ 3)) =
+    HahnSeries.C ζ ^ 2 * (HahnSeries.single (1 / 3 : ℚ) 1 *
+      ι (PowerSeries.C (-1 / 48 : Qbar) * (PowerSeries.X - PowerSeries.C 1728) ^ 3))
+  rw [map_mul, m_single_third hζs, monodromy_fixes_ofPowerSeries hm]
+  ring
+
+theorem m_a6_zero (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar) :
+    m (goodModel 0).a₆ = (goodModel 0).a₆ := by
+  rw [goodModel_zero_eq]
+  change m (ι (PowerSeries.C (1 / 864 : Qbar) * (PowerSeries.X - PowerSeries.C 1728) ^ 5)) =
+    ι (PowerSeries.C (1 / 864 : Qbar) * (PowerSeries.X - PowerSeries.C 1728) ^ 5)
+  exact monodromy_fixes_ofPowerSeries hm _
+
+theorem m_a1_1728 (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar) (ζ : Qbar)
+    (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ) :
+    m (goodModel 1728).a₁ = HahnSeries.C ζ ^ 3 * (goodModel 1728).a₁ := by
+  rw [goodModel_1728_eq]
+  change m (HahnSeries.single (1 / 4 : ℚ) 1) = HahnSeries.C ζ ^ 3 * HahnSeries.single (1 / 4 : ℚ) 1
+  exact m_single_quarter_1728 hm hζs
+
+theorem m_a4_1728 (m : H ≃ₐ[Qbar] H) : m (goodModel 1728).a₄ = (goodModel 1728).a₄ := by
+  rw [goodModel_1728_eq]
+  change m (HahnSeries.C (-36)) = HahnSeries.C (-36)
+  exact monodromy_fixes_C m (-36)
+
+theorem m_a6_1728 (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar) (ζ : Qbar)
+    (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ) :
+    m (goodModel 1728).a₆ = HahnSeries.C ζ ^ 2 * (goodModel 1728).a₆ := by
+  rw [goodModel_1728_eq]
+  change m (-HahnSeries.single (1 / 2 : ℚ) 1) =
+    HahnSeries.C ζ ^ 2 * -HahnSeries.single (1 / 2 : ℚ) 1
+  rw [map_neg, m_single_half_1728 hm hζs]
+  ring
+
+theorem map_goodModel_zero (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar) (ζ : Qbar)
+    (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ) :
+    (goodModel 0).map (m : H →+* H) =
+      ⟨0, 0, 0, HahnSeries.C ζ ^ 2 * (goodModel 0).a₄, (goodModel 0).a₆⟩ := by
+  have ha1 : (goodModel 0).a₁ = 0 := by rw [goodModel_zero_eq]
+  have ha2 : (goodModel 0).a₂ = 0 := by rw [goodModel_zero_eq]
+  have ha3 : (goodModel 0).a₃ = 0 := by rw [goodModel_zero_eq]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_
+  · change m (goodModel 0).a₁ = 0
+    rw [ha1, map_zero]
+  · change m (goodModel 0).a₂ = 0
+    rw [ha2, map_zero]
+  · change m (goodModel 0).a₃ = 0
+    rw [ha3, map_zero]
+  · change m (goodModel 0).a₄ = HahnSeries.C ζ ^ 2 * (goodModel 0).a₄
+    exact m_a4_zero m hm ζ hζs
+  · change m (goodModel 0).a₆ = (goodModel 0).a₆
+    exact m_a6_zero m hm
+
+theorem map_goodModel_1728 (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar) (ζ : Qbar)
+    (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ) :
+    (goodModel 1728).map (m : H →+* H) =
+      ⟨HahnSeries.C ζ ^ 3 * (goodModel 1728).a₁, 0, 0, (goodModel 1728).a₄,
+        HahnSeries.C ζ ^ 2 * (goodModel 1728).a₆⟩ := by
+  have ha2 : (goodModel 1728).a₂ = 0 := by rw [goodModel_1728_eq]
+  have ha3 : (goodModel 1728).a₃ = 0 := by rw [goodModel_1728_eq]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_
+  · change m (goodModel 1728).a₁ = HahnSeries.C ζ ^ 3 * (goodModel 1728).a₁
+    exact m_a1_1728 m hm ζ hζs
+  · change m (goodModel 1728).a₂ = 0
+    rw [ha2, map_zero]
+  · change m (goodModel 1728).a₃ = 0
+    rw [ha3, map_zero]
+  · change m (goodModel 1728).a₄ = (goodModel 1728).a₄
+    exact m_a4_1728 m
+  · change m (goodModel 1728).a₆ = HahnSeries.C ζ ^ 2 * (goodModel 1728).a₆
+    exact m_a6_1728 m hm ζ hζs
+
+theorem nonsingular_fibreTwist_zero {ζ : Qbar} (hζ6 : ζ ^ 6 = 1) {x₀ y₀ : Qbar}
+    (h₀ : (specialFibre (goodModel 0)).toAffine.Nonsingular x₀ y₀) :
+    (specialFibre (goodModel 0)).toAffine.Nonsingular (ζ ^ 2 * x₀) (ζ ^ 3 * y₀) := by
+  have e1 : (specialFibre (goodModel 0)).a₁ = 0 := by rw [specialFibre_goodModel_zero]
+  have e2 : (specialFibre (goodModel 0)).a₂ = 0 := by rw [specialFibre_goodModel_zero]
+  have e3 : (specialFibre (goodModel 0)).a₃ = 0 := by rw [specialFibre_goodModel_zero]
+  have e4 : (specialFibre (goodModel 0)).a₄ = 0 := by rw [specialFibre_goodModel_zero]
+  rw [← WeierstrassCurve.Affine.equation_iff_nonsingular] at h₀ ⊢
+  rw [WeierstrassCurve.Affine.equation_iff] at h₀ ⊢
+  rw [e1, e2, e3, e4] at h₀ ⊢
+  linear_combination ζ ^ 6 * h₀ + (specialFibre (goodModel 0)).a₆ * hζ6
+
+theorem nonsingular_fibreTwist_1728 {ζ : Qbar} (hζ4 : ζ ^ 4 = 1) {x₀ y₀ : Qbar}
+    (h₀ : (specialFibre (goodModel 1728)).toAffine.Nonsingular x₀ y₀) :
+    (specialFibre (goodModel 1728)).toAffine.Nonsingular (ζ ^ 2 * x₀) (ζ ^ 3 * y₀) := by
+  have e1 : (specialFibre (goodModel 1728)).a₁ = 0 := by rw [specialFibre_goodModel_1728]
+  have e2 : (specialFibre (goodModel 1728)).a₂ = 0 := by rw [specialFibre_goodModel_1728]
+  have e3 : (specialFibre (goodModel 1728)).a₃ = 0 := by rw [specialFibre_goodModel_1728]
+  have e6 : (specialFibre (goodModel 1728)).a₆ = 0 := by rw [specialFibre_goodModel_1728]
+  rw [← WeierstrassCurve.Affine.equation_iff_nonsingular] at h₀ ⊢
+  rw [WeierstrassCurve.Affine.equation_iff] at h₀ ⊢
+  rw [e1, e2, e3, e6] at h₀ ⊢
+  linear_combination ζ ^ 2 * h₀ + ζ ^ 2 * (y₀ ^ 2 - x₀ ^ 3) * hζ4
+
+def fibreTwistVC (ζ : Qbar) (hζ0 : ζ ≠ 0) : VariableChange Qbar :=
+  ⟨(Units.mk0 ζ hζ0)⁻¹, 0, 0, 0⟩
+
+theorem fibreTwistVC_smul_fibre_zero {ζ : Qbar} (hζ0 : ζ ≠ 0) (hζ6 : ζ ^ 6 = 1) :
+    fibreTwistVC ζ hζ0 • specialFibre (goodModel 0) = specialFibre (goodModel 0) := by
+  rw [specialFibre_goodModel_zero, WeierstrassCurve.variableChange_def]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_ <;> simp [fibreTwistVC, hζ6]
+
+theorem fibreTwistVC_smul_fibre_1728 {ζ : Qbar} (hζ0 : ζ ≠ 0) (hζ4 : ζ ^ 4 = 1) :
+    fibreTwistVC ζ hζ0 • specialFibre (goodModel 1728) = specialFibre (goodModel 1728) := by
+  rw [specialFibre_goodModel_1728, WeierstrassCurve.variableChange_def]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_ <;> simp [fibreTwistVC, hζ4]
+
+theorem vcInvFun_eq_some {K : Type*} [Field K] {C : VariableChange K}
+    {W : WeierstrassCurve K} {x y : K} (h : W.toAffine.Nonsingular x y)
+    (h' : (C • W).toAffine.Nonsingular (WeierstrassCurve.Affine.vcXInv C x)
+      (WeierstrassCurve.Affine.vcYInv C x y)) :
+    WeierstrassCurve.Affine.Point.vcInvFun C W.toAffine
+        (WeierstrassCurve.Affine.Point.some x y h) =
+      WeierstrassCurve.Affine.Point.some (WeierstrassCurve.Affine.vcXInv C x)
+        (WeierstrassCurve.Affine.vcYInv C x y) h' := rfl
+
+theorem stab_equiv_some {K : Type*} [Field K] [DecidableEq K] {W : WeierstrassCurve K}
+    {φ : VariableChange K} (hφ : φ • W = W) {x y : K} (h : W.toAffine.Nonsingular x y)
+    {x' y' : K} (hx' : WeierstrassCurve.Affine.vcXInv φ x = x')
+    (hy' : WeierstrassCurve.Affine.vcYInv φ x y = y')
+    (h' : W.toAffine.Nonsingular x' y') :
+    ((vcAddEquiv φ W).trans (pointAddEquivOfEq hφ))
+        (WeierstrassCurve.Affine.Point.some x y h) =
+      WeierstrassCurve.Affine.Point.some x' y' h' := by
+  subst hx'
+  subst hy'
+  have hns : (φ • W).toAffine.Nonsingular (WeierstrassCurve.Affine.vcXInv φ x)
+      (WeierstrassCurve.Affine.vcYInv φ x y) := by
+    rw [hφ]
+    exact h'
+  have h1 : ((vcAddEquiv φ W).trans (pointAddEquivOfEq hφ))
+      (WeierstrassCurve.Affine.Point.some x y h) =
+      pointAddEquivOfEq hφ (vcAddEquiv φ W (WeierstrassCurve.Affine.Point.some x y h)) := rfl
+  rw [h1, vcAddEquiv_apply, vcInvFun_eq_some h hns,
+    pointAddEquivOfEq_apply_of_eq_some hφ rfl]
+
+def fibreTwistEquiv_zero (ζ : Qbar) (hζ0 : ζ ≠ 0) (hζ6 : ζ ^ 6 = 1) :
+    (specialFibre (goodModel 0)).toAffine.Point ≃+
+      (specialFibre (goodModel 0)).toAffine.Point :=
+  (vcAddEquiv (fibreTwistVC ζ hζ0) (specialFibre (goodModel 0))).trans
+    (pointAddEquivOfEq (fibreTwistVC_smul_fibre_zero hζ0 hζ6))
+
+def fibreTwistEquiv_1728 (ζ : Qbar) (hζ0 : ζ ≠ 0) (hζ4 : ζ ^ 4 = 1) :
+    (specialFibre (goodModel 1728)).toAffine.Point ≃+
+      (specialFibre (goodModel 1728)).toAffine.Point :=
+  (vcAddEquiv (fibreTwistVC ζ hζ0) (specialFibre (goodModel 1728))).trans
+    (pointAddEquivOfEq (fibreTwistVC_smul_fibre_1728 hζ0 hζ4))
+
+theorem fibreTwistEquiv_zero_some (ζ : Qbar) (hζ0 : ζ ≠ 0) (hζ6 : ζ ^ 6 = 1) {x₀ y₀ : Qbar}
+    (h₀ : (specialFibre (goodModel 0)).toAffine.Nonsingular x₀ y₀) :
+    fibreTwistEquiv_zero ζ hζ0 hζ6 (WeierstrassCurve.Affine.Point.some x₀ y₀ h₀) =
+      WeierstrassCurve.Affine.Point.some (ζ ^ 2 * x₀) (ζ ^ 3 * y₀)
+        (nonsingular_fibreTwist_zero hζ6 h₀) := by
+  refine stab_equiv_some (fibreTwistVC_smul_fibre_zero hζ0 hζ6) h₀ ?_ ?_
+    (nonsingular_fibreTwist_zero hζ6 h₀)
+  · change (((fibreTwistVC ζ hζ0).u⁻¹ : Qbarˣ) : Qbar) ^ 2 * (x₀ - (fibreTwistVC ζ hζ0).r) =
+      ζ ^ 2 * x₀
+    simp [fibreTwistVC]
+  · change (((fibreTwistVC ζ hζ0).u⁻¹ : Qbarˣ) : Qbar) ^ 3 * (y₀ - (fibreTwistVC ζ hζ0).t -
+        (fibreTwistVC ζ hζ0).s * (x₀ - (fibreTwistVC ζ hζ0).r)) = ζ ^ 3 * y₀
+    simp [fibreTwistVC]
+
+theorem fibreTwistEquiv_1728_some (ζ : Qbar) (hζ0 : ζ ≠ 0) (hζ4 : ζ ^ 4 = 1) {x₀ y₀ : Qbar}
+    (h₀ : (specialFibre (goodModel 1728)).toAffine.Nonsingular x₀ y₀) :
+    fibreTwistEquiv_1728 ζ hζ0 hζ4 (WeierstrassCurve.Affine.Point.some x₀ y₀ h₀) =
+      WeierstrassCurve.Affine.Point.some (ζ ^ 2 * x₀) (ζ ^ 3 * y₀)
+        (nonsingular_fibreTwist_1728 hζ4 h₀) := by
+  refine stab_equiv_some (fibreTwistVC_smul_fibre_1728 hζ0 hζ4) h₀ ?_ ?_
+    (nonsingular_fibreTwist_1728 hζ4 h₀)
+  · change (((fibreTwistVC ζ hζ0).u⁻¹ : Qbarˣ) : Qbar) ^ 2 * (x₀ - (fibreTwistVC ζ hζ0).r) =
+      ζ ^ 2 * x₀
+    simp [fibreTwistVC]
+  · change (((fibreTwistVC ζ hζ0).u⁻¹ : Qbarˣ) : Qbar) ^ 3 * (y₀ - (fibreTwistVC ζ hζ0).t -
+        (fibreTwistVC ζ hζ0).s * (x₀ - (fibreTwistVC ζ hζ0).r)) = ζ ^ 3 * y₀
+    simp [fibreTwistVC]
+
+theorem nonsingular_conj_zero (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar)
+    (ζ : Qbar) (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ)
+    {x y : H} (h : (goodModel 0).toAffine.Nonsingular x y) :
+    (goodModel 0).toAffine.Nonsingular (HahnSeries.C ζ ^ 2 * m x)
+      (HahnSeries.C ζ ^ 3 * m y) := by
+  have hζ6 : ζ ^ 6 = 1 := zeta_pow_eq_one_of_twist (k := 1) hm hζs (by norm_num)
+  have hC6 : (HahnSeries.C ζ : H) ^ 6 = 1 := by
+    rw [← map_pow, hζ6, map_one]
+  have ha1 : (goodModel 0).a₁ = 0 := by rw [goodModel_zero_eq]
+  have ha2 : (goodModel 0).a₂ = 0 := by rw [goodModel_zero_eq]
+  have ha3 : (goodModel 0).a₃ = 0 := by rw [goodModel_zero_eq]
+  rw [← WeierstrassCurve.Affine.equation_iff_nonsingular] at h ⊢
+  rw [WeierstrassCurve.Affine.equation_iff] at h ⊢
+  rw [ha1, ha2, ha3] at h ⊢
+  have hme := congrArg m h
+  simp only [map_add, map_mul, map_pow, map_zero] at hme
+  rw [m_a4_zero m hm ζ hζs, m_a6_zero m hm] at hme
+  linear_combination HahnSeries.C ζ ^ 6 * hme +
+    (HahnSeries.C ζ ^ 2 * (goodModel 0).a₄ * m x + (goodModel 0).a₆) * hC6
+
+theorem nonsingular_conj_1728 (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar)
+    (ζ : Qbar) (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ)
+    {x y : H} (h : (goodModel 1728).toAffine.Nonsingular x y) :
+    (goodModel 1728).toAffine.Nonsingular (HahnSeries.C ζ ^ 2 * m x)
+      (HahnSeries.C ζ ^ 3 * m y) := by
+  have hζ4 : ζ ^ 4 = 1 := zeta_pow_eq_one_of_twist (k := 3) hm hζs (by norm_num)
+  have hC4 : (HahnSeries.C ζ : H) ^ 4 = 1 := by
+    rw [← map_pow, hζ4, map_one]
+  have ha2 : (goodModel 1728).a₂ = 0 := by rw [goodModel_1728_eq]
+  have ha3 : (goodModel 1728).a₃ = 0 := by rw [goodModel_1728_eq]
+  rw [← WeierstrassCurve.Affine.equation_iff_nonsingular] at h ⊢
+  rw [WeierstrassCurve.Affine.equation_iff] at h ⊢
+  rw [ha2, ha3] at h ⊢
+  have hme := congrArg m h
+  simp only [map_add, map_mul, map_pow, map_zero] at hme
+  rw [m_a1_1728 m hm ζ hζs, m_a4_1728 m, m_a6_1728 m hm ζ hζs] at hme
+  linear_combination HahnSeries.C ζ ^ 2 * hme +
+    (HahnSeries.C ζ ^ 2 * ((m y) ^ 2 - (m x) ^ 3) + (goodModel 1728).a₆) * hC4
+
+theorem nonsingular_cocycle_zero (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar)
+    {ζ : Qbar} (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ)
+    {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : (goodModel 0).toAffine.Nonsingular x y) :
+    (specialFibre (goodModel 0)).toAffine.Nonsingular (ζ ^ 2 * x.coeff 0)
+      (ζ ^ 3 * y.coeff 0) :=
+  nonsingular_fibreTwist_zero (zeta_pow_eq_one_of_twist (k := 1) hm hζs (by norm_num))
+    (nonsingular_specialFibre _ (goodModel_spec 0).1 (goodModel_spec 0).2 hx hy h)
+
+theorem nonsingular_cocycle_1728 (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar)
+    {ζ : Qbar} (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ)
+    {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : (goodModel 1728).toAffine.Nonsingular x y) :
+    (specialFibre (goodModel 1728)).toAffine.Nonsingular (ζ ^ 2 * x.coeff 0)
+      (ζ ^ 3 * y.coeff 0) :=
+  nonsingular_fibreTwist_1728 (zeta_pow_eq_one_of_twist (k := 3) hm hζs (by norm_num))
+    (nonsingular_specialFibre _ (goodModel_spec 1728).1 (goodModel_spec 1728).2 hx hy h)
+
+theorem fixedTransport_conj_zero (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar)
+    (ζ : Qbar) (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ)
+    (hE : (nearCurve 0).map (m : H →+* H) = nearCurve 0)
+    {x y : H} (h : (goodModel 0).toAffine.Nonsingular x y) :
+    scaleAddEquiv 0 (WeierstrassCurve.Affine.Point.fixedTransport m (nearCurve 0) hE
+        ((scaleAddEquiv 0).symm (WeierstrassCurve.Affine.Point.some x y h))) =
+      WeierstrassCurve.Affine.Point.some (HahnSeries.C ζ ^ 2 * m x)
+        (HahnSeries.C ζ ^ 3 * m y) (nonsingular_conj_zero m hm ζ hζs h) := by
+  have hA : m (jNear 0 - 1728) = jNear 0 - 1728 := by
+    rw [jNear_zero, map_sub, HahnSeries.fixes_single_one_of_mem_monodromy hm, map_ofNat]
+  have hmu : m (((scaleVC 0).u : Hˣ) : H) = HahnSeries.C ζ * (((scaleVC 0).u : Hˣ) : H) := by
+    rw [scaleVC_zero]
+    change m (HahnSeries.single (2 / 12 : ℚ) 1) = HahnSeries.C ζ * HahnSeries.single (2 / 12 : ℚ) 1
+    rw [single_two_twelfths]
+    exact m_single_sixth hζs
+  have hmr : m ((scaleVC 0).r) = (scaleVC 0).r := by
+    rw [scaleVC_zero]
+    change m (-(jNear 0 - 1728) ^ 2 / 12) = -(jNear 0 - 1728) ^ 2 / 12
+    rw [map_div₀, map_neg, map_pow, hA, map_ofNat]
+  have hms : m ((scaleVC 0).s) = (scaleVC 0).s := by
+    rw [scaleVC_zero]
+    change m (-(jNear 0 - 1728) / 2) = -(jNear 0 - 1728) / 2
+    rw [map_div₀, map_neg, hA, map_ofNat]
+  have hmt : m ((scaleVC 0).t) = (scaleVC 0).t := by
+    rw [scaleVC_zero]
+    change m ((jNear 0 - 1728) ^ 3 / 24) = (jNear 0 - 1728) ^ 3 / 24
+    rw [map_div₀, map_pow, hA, map_ofNat]
+  have huu : (((scaleVC 0).u⁻¹ : Hˣ) : H) * (((scaleVC 0).u : Hˣ) : H) = 1 := by simp
+  have hP : (scaleAddEquiv 0).symm (WeierstrassCurve.Affine.Point.some x y h) =
+      WeierstrassCurve.Affine.Point.some
+        (WeierstrassCurve.Affine.vcX (scaleVC 0) x)
+        (WeierstrassCurve.Affine.vcY (scaleVC 0) x y)
+        ((WeierstrassCurve.Affine.nonsingular_variableChange_iff
+          (C := scaleVC 0) (W := (nearCurve 0).toAffine) x y).mp h) := rfl
+  rw [hP, WeierstrassCurve.Affine.Point.fixedTransport_some]
+  refine some_point_ext' ?_ ?_
+  · change (((scaleVC 0).u⁻¹ : Hˣ) : H) ^ 2 *
+        (m ((((scaleVC 0).u : Hˣ) : H) ^ 2 * x + (scaleVC 0).r) - (scaleVC 0).r) =
+      HahnSeries.C ζ ^ 2 * m x
+    simp only [map_add, map_mul, map_pow]
+    rw [hmu, hmr, add_sub_cancel_right]
+    linear_combination (HahnSeries.C ζ ^ 2 * m x) *
+      ((((scaleVC 0).u⁻¹ : Hˣ) : H) * (((scaleVC 0).u : Hˣ) : H) + 1) * huu
+  · change (((scaleVC 0).u⁻¹ : Hˣ) : H) ^ 3 *
+        (m ((((scaleVC 0).u : Hˣ) : H) ^ 3 * y + (((scaleVC 0).u : Hˣ) : H) ^ 2 * (scaleVC 0).s * x
+            + (scaleVC 0).t) - (scaleVC 0).t -
+          (scaleVC 0).s * (m ((((scaleVC 0).u : Hˣ) : H) ^ 2 * x + (scaleVC 0).r) -
+            (scaleVC 0).r)) =
+      HahnSeries.C ζ ^ 3 * m y
+    simp only [map_add, map_mul, map_pow]
+    rw [hmu, hmr, hms, hmt]
+    linear_combination (HahnSeries.C ζ ^ 3 * m y) *
+      (((((scaleVC 0).u⁻¹ : Hˣ) : H) * (((scaleVC 0).u : Hˣ) : H)) ^ 2 +
+        (((scaleVC 0).u⁻¹ : Hˣ) : H) * (((scaleVC 0).u : Hˣ) : H) + 1) * huu
+
+theorem fixedTransport_conj_1728 (m : H ≃ₐ[Qbar] H) (hm : m ∈ HahnSeries.monodromy Qbar)
+    (ζ : Qbar) (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ)
+    (hE : (nearCurve 1728).map (m : H →+* H) = nearCurve 1728)
+    {x y : H} (h : (goodModel 1728).toAffine.Nonsingular x y) :
+    scaleAddEquiv 1728 (WeierstrassCurve.Affine.Point.fixedTransport m (nearCurve 1728) hE
+        ((scaleAddEquiv 1728).symm (WeierstrassCurve.Affine.Point.some x y h))) =
+      WeierstrassCurve.Affine.Point.some (HahnSeries.C ζ ^ 2 * m x)
+        (HahnSeries.C ζ ^ 3 * m y) (nonsingular_conj_1728 m hm ζ hζs h) := by
+  have hmu : m (((scaleVC 1728).u : Hˣ) : H) =
+      HahnSeries.C ζ * (((scaleVC 1728).u : Hˣ) : H) := by
+    rw [scaleVC_1728]
+    change m (HahnSeries.single (9 / 12 : ℚ) 1) =
+      HahnSeries.C ζ * HahnSeries.single (9 / 12 : ℚ) 1
+    rw [show (9 / 12 : ℚ) = 3 / 4 by norm_num, hζs, C_mul_single]
+  have hmr : m ((scaleVC 1728).r) = (scaleVC 1728).r := by
+    rw [scaleVC_1728]
+    change m (0 : H) = (0 : H)
+    exact map_zero m
+  have hms : m ((scaleVC 1728).s) = (scaleVC 1728).s := by
+    rw [scaleVC_1728]
+    change m (0 : H) = (0 : H)
+    exact map_zero m
+  have hmt : m ((scaleVC 1728).t) = (scaleVC 1728).t := by
+    rw [scaleVC_1728]
+    change m (0 : H) = (0 : H)
+    exact map_zero m
+  have huu : (((scaleVC 1728).u⁻¹ : Hˣ) : H) * (((scaleVC 1728).u : Hˣ) : H) = 1 := by simp
+  have hP : (scaleAddEquiv 1728).symm (WeierstrassCurve.Affine.Point.some x y h) =
+      WeierstrassCurve.Affine.Point.some
+        (WeierstrassCurve.Affine.vcX (scaleVC 1728) x)
+        (WeierstrassCurve.Affine.vcY (scaleVC 1728) x y)
+        ((WeierstrassCurve.Affine.nonsingular_variableChange_iff
+          (C := scaleVC 1728) (W := (nearCurve 1728).toAffine) x y).mp h) := rfl
+  rw [hP, WeierstrassCurve.Affine.Point.fixedTransport_some]
+  refine some_point_ext' ?_ ?_
+  · change (((scaleVC 1728).u⁻¹ : Hˣ) : H) ^ 2 *
+        (m ((((scaleVC 1728).u : Hˣ) : H) ^ 2 * x + (scaleVC 1728).r) - (scaleVC 1728).r) =
+      HahnSeries.C ζ ^ 2 * m x
+    simp only [map_add, map_mul, map_pow]
+    rw [hmu, hmr, add_sub_cancel_right]
+    linear_combination (HahnSeries.C ζ ^ 2 * m x) *
+      ((((scaleVC 1728).u⁻¹ : Hˣ) : H) * (((scaleVC 1728).u : Hˣ) : H) + 1) * huu
+  · change (((scaleVC 1728).u⁻¹ : Hˣ) : H) ^ 3 *
+        (m ((((scaleVC 1728).u : Hˣ) : H) ^ 3 * y +
+            (((scaleVC 1728).u : Hˣ) : H) ^ 2 * (scaleVC 1728).s * x + (scaleVC 1728).t) -
+          (scaleVC 1728).t -
+          (scaleVC 1728).s * (m ((((scaleVC 1728).u : Hˣ) : H) ^ 2 * x + (scaleVC 1728).r) -
+            (scaleVC 1728).r)) =
+      HahnSeries.C ζ ^ 3 * m y
+    simp only [map_add, map_mul, map_pow]
+    rw [hmu, hmr, hms, hmt]
+    linear_combination (HahnSeries.C ζ ^ 3 * m y) *
+      (((((scaleVC 1728).u⁻¹ : Hˣ) : H) * (((scaleVC 1728).u : Hˣ) : H)) ^ 2 +
+        (((scaleVC 1728).u⁻¹ : Hˣ) : H) * (((scaleVC 1728).u : Hˣ) : H) + 1) * huu
+
+theorem cocycle_zero_point (j₀ : Qbar) (m : H ≃ₐ[Qbar] H)
+    (hE : (nearCurve j₀).map (m : H →+* H) = nearCurve j₀) :
+    scaleAddEquiv j₀ (WeierstrassCurve.Affine.Point.fixedTransport m (nearCurve j₀) hE
+      ((scaleAddEquiv j₀).symm 0)) = 0 := by
+  simp only [map_zero]
+
+theorem redPoint_monodromy_cocycle_zero (m : H ≃ₐ[Qbar] H)
+    (hm : m ∈ HahnSeries.monodromy Qbar) (ζ : Qbar)
+    (hζs : m (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ)
+    (hE : (nearCurve 0).map (m : H →+* H) = nearCurve 0)
+    {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : (goodModel 0).toAffine.Nonsingular x y) :
+    redPoint (goodModel 0) (goodModel_spec 0).1 (goodModel_spec 0).2
+        (scaleAddEquiv 0 (WeierstrassCurve.Affine.Point.fixedTransport m (nearCurve 0) hE
+          ((scaleAddEquiv 0).symm (WeierstrassCurve.Affine.Point.some x y h)))) =
+      WeierstrassCurve.Affine.Point.some (ζ ^ 2 * x.coeff 0) (ζ ^ 3 * y.coeff 0)
+        (nonsingular_cocycle_zero m hm hζs hx hy h) := by
+  rw [fixedTransport_conj_zero m hm ζ hζs hE h]
+  have hCint : 0 ≤ (HahnSeries.C ζ : H).orderTop := by
+    rw [← HahnSeries.ofPowerSeries_C]
+    exact orderTop_ofPowerSeries_nonneg _
+  have hmx : 0 ≤ (m x).orderTop := by
+    rw [orderTop_of_mem_monodromy hm]
+    exact hx
+  have hmy : 0 ≤ (m y).orderTop := by
+    rw [orderTop_of_mem_monodromy hm]
+    exact hy
+  rw [redPoint_some _ _ _ (orderTop_mul_nonneg (orderTop_pow_nonneg hCint 2) hmx)
+    (orderTop_mul_nonneg (orderTop_pow_nonneg hCint 3) hmy) _]
+  refine some_point_ext ?_ ?_
+  · rw [coeff_zero_mul_of_integral (orderTop_pow_nonneg hCint 2) hmx,
+      coeff_zero_of_mem_monodromy hm, ← map_pow, coeff_zero_C]
+  · rw [coeff_zero_mul_of_integral (orderTop_pow_nonneg hCint 3) hmy,
+      coeff_zero_of_mem_monodromy hm, ← map_pow, coeff_zero_C]
+
+theorem redPoint_monodromy_cocycle_1728 (m : H ≃ₐ[Qbar] H)
+    (hm : m ∈ HahnSeries.monodromy Qbar) (ζ : Qbar)
+    (hζs : m (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ)
+    (hE : (nearCurve 1728).map (m : H →+* H) = nearCurve 1728)
+    {x y : H} (hx : 0 ≤ x.orderTop) (hy : 0 ≤ y.orderTop)
+    (h : (goodModel 1728).toAffine.Nonsingular x y) :
+    redPoint (goodModel 1728) (goodModel_spec 1728).1 (goodModel_spec 1728).2
+        (scaleAddEquiv 1728 (WeierstrassCurve.Affine.Point.fixedTransport m (nearCurve 1728) hE
+          ((scaleAddEquiv 1728).symm (WeierstrassCurve.Affine.Point.some x y h)))) =
+      WeierstrassCurve.Affine.Point.some (ζ ^ 2 * x.coeff 0) (ζ ^ 3 * y.coeff 0)
+        (nonsingular_cocycle_1728 m hm hζs hx hy h) := by
+  rw [fixedTransport_conj_1728 m hm ζ hζs hE h]
+  have hCint : 0 ≤ (HahnSeries.C ζ : H).orderTop := by
+    rw [← HahnSeries.ofPowerSeries_C]
+    exact orderTop_ofPowerSeries_nonneg _
+  have hmx : 0 ≤ (m x).orderTop := by
+    rw [orderTop_of_mem_monodromy hm]
+    exact hx
+  have hmy : 0 ≤ (m y).orderTop := by
+    rw [orderTop_of_mem_monodromy hm]
+    exact hy
+  rw [redPoint_some _ _ _ (orderTop_mul_nonneg (orderTop_pow_nonneg hCint 2) hmx)
+    (orderTop_mul_nonneg (orderTop_pow_nonneg hCint 3) hmy) _]
+  refine some_point_ext ?_ ?_
+  · rw [coeff_zero_mul_of_integral (orderTop_pow_nonneg hCint 2) hmx,
+      coeff_zero_of_mem_monodromy hm, ← map_pow, coeff_zero_C]
+  · rw [coeff_zero_mul_of_integral (orderTop_pow_nonneg hCint 3) hmy,
+      coeff_zero_of_mem_monodromy hm, ← map_pow, coeff_zero_C]
+
+end H6B
+
+open ModularCurve.HahnSpecialise
+
+theorem specialFibre_Δ_ne_zero_of_orderTop (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) : (specialFibre W).Δ ≠ 0 :=
+  (specialFibre_Δ_ne_zero_iff W hW).mpr hΔ
+
+def cycRedN (W : WeierstrassCurve H) (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0)
+    (N : ℕ) [NeZero N] : CycSubH W N ≃ CycSub (specialFibre W) N :=
+  Equiv.ofBijective (specialiseCycSub W hW (specialFibre_Δ_ne_zero_of_orderTop W hW hΔ) N)
+    (specialiseCycSub_bijective W hW (specialFibre_Δ_ne_zero_of_orderTop W hW hΔ) N)
+
+@[scoped simp] theorem cycRedN_apply_coe (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) (N : ℕ) [NeZero N] (G : CycSubH W N) :
+    (cycRedN W hW hΔ N G).1 =
+      G.1.map (specialise W hW (specialFibre_Δ_ne_zero_of_orderTop W hW hΔ) :
+        W.toAffine.Point →+ (specialFibre W).toAffine.Point) :=
+  rfl
+
+def bridge3SpecialiseN (N : ℕ) [NeZero N] (j₀ : Qbar) :
+    CycSubH (nearCurve j₀) N ≃ CycSub (WeierstrassCurve.ofJ j₀) N :=
+  (cycScale N j₀).trans <|
+    (cycRedN (goodModel j₀) (goodModel_spec j₀).1 (goodModel_spec j₀).2 N).trans
+      (cycOfCongr (fibreAddEquiv j₀) N)
+
+theorem specialise_eq_redPoint (W : WeierstrassCurve H) (hW : IntegralCoeffs W)
+    (hΔ : W.Δ.orderTop = 0) (Q : W.toAffine.Point) :
+    specialise W hW (specialFibre_Δ_ne_zero_of_orderTop W hW hΔ) Q = redPoint W hW hΔ Q := by
+  rcases Q with _ | ⟨x, y, h⟩
+  · change specialise W hW _ 0 = redPoint W hW hΔ 0
+    rw [map_zero, redPoint_zero]
+  · by_cases hx : 0 ≤ x.orderTop
+    · have h' : ((liftModel W hW).map valuationSubringH.subtype).toAffine.Nonsingular x y := by
+        rw [liftModel_map_subtype]; exact h
+      have hy : 0 ≤ y.orderTop :=
+        mem_valuationSubringH.mp (WeierstrassCurve.Affine.Y_mem_of_X_mem (liftModel W hW) h'.1 hx)
+      rw [specialise_some_of_nonneg W hW _ h hx, redPoint_some W hW hΔ hx hy h]
+    · have hxy : ¬ (0 ≤ x.orderTop ∧ 0 ≤ y.orderTop) := fun hxy => hx hxy.1
+      rw [specialise_some_of_neg W hW _ h hx]
+      simp only [redPoint, dite_eq_right hxy]
+
+theorem cycScale_zmultiples (N : ℕ) (j₀ : Qbar) (g : (nearCurve j₀).toAffine.Point)
+    (hg : addOrderOf g = N) :
+    (cycScale N j₀ ⟨AddSubgroup.zmultiples g, g, hg, rfl⟩).1 =
+      AddSubgroup.zmultiples (scaleAddEquiv j₀ g) := by
+  change (AddSubgroup.zmultiples g).map _ = _
+  rw [AddMonoidHom.map_zmultiples, AddMonoidHom.coe_ofClass]
+
+theorem bridge3SpecialiseN_apply_coe (N : ℕ) [NeZero N] (j₀ : Qbar)
+    (G : CycSubH (nearCurve j₀) N) :
+    (bridge3SpecialiseN N j₀ G).1 =
+      (((cycScale N j₀ G).1.map
+          (specialise (goodModel j₀) (goodModel_spec j₀).1
+            (specialFibre_Δ_ne_zero_of_orderTop (goodModel j₀) (goodModel_spec j₀).1
+              (goodModel_spec j₀).2))).map
+        (fibreAddEquiv j₀ :
+          (specialFibre (goodModel j₀)).toAffine.Point →+ (WeierstrassCurve.ofJ j₀).toAffine.Point))
+            :=
+  rfl
+
+theorem bridge3SpecialiseN_coe_eq_of_coe_eq (N : ℕ) [NeZero N] (j₀ : Qbar)
+    {G G' : CycSubH (nearCurve j₀) N} (h : G.1 = G'.1) :
+    (bridge3SpecialiseN N j₀ G).1 = (bridge3SpecialiseN N j₀ G').1 := by
+  have hs : (cycScale N j₀ G).1 = (cycScale N j₀ G').1 := by
+    change G.1.map _ = G'.1.map _
+    rw [h]
+  rw [bridge3SpecialiseN_apply_coe, bridge3SpecialiseN_apply_coe, hs]
+
+theorem bridge3SpecialiseN_zmultiples (N : ℕ) [NeZero N] (j₀ : Qbar)
+    (g : (nearCurve j₀).toAffine.Point) (hg : addOrderOf g = N) :
+    (bridge3SpecialiseN N j₀ ⟨AddSubgroup.zmultiples g, g, hg, rfl⟩).1 =
+      AddSubgroup.zmultiples
+        (fibreAddEquiv j₀
+          (redPoint (goodModel j₀) (goodModel_spec j₀).1 (goodModel_spec j₀).2
+            (scaleAddEquiv j₀ g))) := by
+  rw [bridge3SpecialiseN_apply_coe, cycScale_zmultiples N j₀ g hg, AddMonoidHom.map_zmultiples,
+    AddMonoidHom.map_zmultiples, AddMonoidHom.coe_ofClass, specialise_eq_redPoint]
+
+theorem torsion_coords_integralN (W : WeierstrassCurve H) [W.IsElliptic]
+    (hW : IntegralCoeffs W) (hΔ : W.Δ.orderTop = 0) {x y : H}
+    (h : W.toAffine.Nonsingular x y) {n : ℕ} (hn : n ≠ 0)
+    (htor : n • (WeierstrassCurve.Affine.Point.some x y h : W.toAffine.Point) = 0) :
+    0 ≤ x.orderTop ∧ 0 ≤ y.orderTop := by
+  have _ := hΔ
+  have h' : ((liftModel W hW).map valuationSubringH.subtype).toAffine.Nonsingular x y := by
+    rw [liftModel_map_subtype]; exact h
+  have hx : x ∈ valuationSubringH := by
+    refine WeierstrassCurve.X_mem_of_nsmul_eq_zero' (liftModel W hW)
+      (natCast_residueField_ne_zero hn) h' ?_
+    have hPt : (WeierstrassCurve.Affine.Point.some x y h : W.toAffine.Point) =
+        (WeierstrassCurve.Affine.Point.some x y h' :
+          ((liftModel W hW).map valuationSubringH.subtype).toAffine.Point) := rfl
+    rw [← hPt]; exact htor
+  exact ⟨mem_valuationSubringH.mp hx,
+    mem_valuationSubringH.mp (WeierstrassCurve.Affine.Y_mem_of_X_mem (liftModel W hW) h'.1 hx)⟩
+
+theorem scaleAddEquiv_some_genericN (j₀ : Qbar) (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728)
+    {x y : H} (h : (nearCurve j₀).toAffine.Nonsingular x y) :
+    ∃ h' : (goodModel j₀).toAffine.Nonsingular x y,
+      scaleAddEquiv j₀ (.some x y h) = .some x y h' := by
+  have hvX : WeierstrassCurve.Affine.vcXInv (scaleVC j₀) x = x := by
+    rw [scaleVC_of_ne h0 h1728]
+    simp [WeierstrassCurve.Affine.vcXInv, VariableChange.one_def]
+  have hvY : WeierstrassCurve.Affine.vcYInv (scaleVC j₀) x y = y := by
+    rw [scaleVC_of_ne h0 h1728]
+    simp [WeierstrassCurve.Affine.vcYInv, VariableChange.one_def]
+  refine ⟨?_, ?_⟩
+  · rw [goodModel_eq_nearCurve h0 h1728]; exact h
+  · rw [scaleAddEquiv_apply]
+    change (WeierstrassCurve.Affine.Point.some
+        (WeierstrassCurve.Affine.vcXInv (scaleVC j₀) x)
+        (WeierstrassCurve.Affine.vcYInv (scaleVC j₀) x y) _ :
+        (goodModel j₀).toAffine.Point) = WeierstrassCurve.Affine.Point.some x y _
+    congr 1
+
+theorem redPoint_scaleAddEquiv_nearTransport_generic (N : ℕ) [NeZero N]
+    (j₀ : Qbar) (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) (m : HahnSeries.monodromy Qbar)
+    (g : (nearCurve j₀).toAffine.Point) (hg : addOrderOf g = N) :
+    redPoint (goodModel j₀) (goodModel_spec j₀).1 (goodModel_spec j₀).2
+        (scaleAddEquiv j₀ (nearTransport j₀ m g)) =
+      redPoint (goodModel j₀) (goodModel_spec j₀).1 (goodModel_spec j₀).2 (scaleAddEquiv j₀ g) := by
+  rcases g with _ | ⟨x, y, h⟩
+  · rw [show (WeierstrassCurve.Affine.Point.zero : (nearCurve j₀).toAffine.Point) = 0 from rfl,
+      map_zero, map_zero]
+  · have hm := m.2
+    have hns' := WeierstrassCurve.Affine.Point.nonsingular_of_fixed _ _
+      (nearCurve_map_of_mem_monodromy j₀ hm) h
+    obtain ⟨h', hscale'⟩ := scaleAddEquiv_some_genericN j₀ h0 h1728 hns'
+    obtain ⟨hgn, hscale⟩ := scaleAddEquiv_some_genericN j₀ h0 h1728 h
+    have htor : N • (WeierstrassCurve.Affine.Point.some x y h : (nearCurve j₀).toAffine.Point) = 0
+      :=
+      hg ▸ addOrderOf_nsmul_eq_zero _
+    have htor' : N • (WeierstrassCurve.Affine.Point.some x y hgn : (goodModel j₀).toAffine.Point) =
+      0 :=
+      by
+      rw [← hscale, ← map_nsmul, htor, map_zero]
+    have ⟨hx, hy⟩ :=
+      torsion_coords_integral (goodModel j₀) (goodModel_spec j₀).1 (goodModel_spec j₀).2
+      hgn (NeZero.ne N) htor'
+    have hx' : 0 ≤ ((m : H ≃ₐ[Qbar] H) x).orderTop := by rw [orderTop_of_mem_monodromy hm]; exact hx
+    have hy' : 0 ≤ ((m : H ≃ₐ[Qbar] H) y).orderTop := by rw [orderTop_of_mem_monodromy hm]; exact hy
+    rw [nearTransport_some, hscale', hscale,
+      redPoint_some (goodModel j₀) (goodModel_spec j₀).1 (goodModel_spec j₀).2 hx' hy' h',
+      redPoint_some (goodModel j₀) (goodModel_spec j₀).1 (goodModel_spec j₀).2 hx hy hgn]
+    exact some_point_ext (coeff_zero_of_mem_monodromy hm x) (coeff_zero_of_mem_monodromy hm y)
+
+theorem bridge3SpecialiseN_b3Act_generic (N : ℕ) [NeZero N] (j₀ : Qbar)
+    (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) (m : HahnSeries.monodromy Qbar)
+    (g : (nearCurve j₀).toAffine.Point) (hg : addOrderOf g = N) :
+    (bridge3SpecialiseN N j₀
+        ⟨b3Act j₀ m (AddSubgroup.zmultiples g), nearTransport j₀ m g,
+          (AddEquiv.addOrderOf_eq _ g).trans hg, b3Act_zmultiples j₀ m g⟩).1 =
+      (bridge3SpecialiseN N j₀ ⟨AddSubgroup.zmultiples g, g, hg, rfl⟩).1 := by
+  have hgT : addOrderOf (nearTransport j₀ m g) = N := (AddEquiv.addOrderOf_eq _ g).trans hg
+  rw [show (⟨b3Act j₀ m (AddSubgroup.zmultiples g), nearTransport j₀ m g, hgT,
+        b3Act_zmultiples j₀ m g⟩ : CycSubH (nearCurve j₀) N) =
+      ⟨AddSubgroup.zmultiples (nearTransport j₀ m g), nearTransport j₀ m g, hgT, rfl⟩ from
+    Subtype.ext (b3Act_zmultiples j₀ m g)]
+  rw [bridge3SpecialiseN_zmultiples N j₀ (nearTransport j₀ m g) hgT,
+    bridge3SpecialiseN_zmultiples N j₀ g hg,
+    redPoint_scaleAddEquiv_nearTransport_generic N j₀ h0 h1728 m g hg]
+
+private theorem monodromy_fullN (e : ℕ) (he : 0 < e) (ζ : Qbar) (hζ : ζ ^ e = 1) :
+    ∃ m ∈ HahnSeries.monodromy Qbar,
+      (m : H ≃ₐ[Qbar] H) (HahnSeries.single ((e : ℚ)⁻¹) (1 : Qbar)) =
+        HahnSeries.single ((e : ℚ)⁻¹) ζ :=
+  HahnSeries.exists_mem_monodromy_single_eq (AlgebraicClosure ℚ) e he ζ hζ
+
+theorem nearTransport_oneN (j₀ : Qbar) : nearTransport j₀ 1 = AddEquiv.refl _ := by
+  refine AddEquiv.ext fun P => ?_
+  rcases P with _ | ⟨x, y, h⟩
+  · exact WeierstrassCurve.Affine.Point.fixedTransport_zero
+      (1 : H ≃ₐ[Qbar] H) (nearCurve j₀) (nearCurve_map_of_mem_monodromy j₀ (1 :
+        HahnSeries.monodromy Qbar).2)
+  · exact nearTransport_some j₀ 1 x y h
+
+theorem b3Act_oneN (j₀ : Qbar) (G : AddSubgroup (nearCurve j₀).toAffine.Point) :
+    b3Act j₀ 1 G = G := by
+  rw [b3Act, nearTransport_oneN]
+  exact G.map_id
+
+theorem exists_zeta_of_mem_monodromyN {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar)
+    (q : ℚ) :
+    ∃ ζ : Qbar, m (HahnSeries.single q 1) = HahnSeries.single q ζ := by
+  obtain ⟨χ, _, rfl⟩ := hm
+  exact ⟨(χ (Multiplicative.ofAdd q)).val, by
+    rw [HahnSeries.hahnTwistHom_apply, HahnSeries.hahnTwist_single, mul_one]⟩
+
+theorem specialisationEquivariance_level_generic (N : ℕ) [NeZero N] (j₀ : Qbar)
+    (h0 : j₀ ≠ 0) (h1728 : j₀ ≠ 1728) (G G' : CycSubH (nearCurve j₀) N) :
+    (∃ m : HahnSeries.monodromy Qbar, b3Act j₀ m G.1 = G'.1) ↔
+      SameOrbit (WeierstrassCurve.ofJ j₀) (bridge3SpecialiseN N j₀ G).1
+        (bridge3SpecialiseN N j₀ G').1 := by
+  rw [sameOrbit_ofJ_iff_of_ne j₀ h0 h1728]
+  obtain ⟨g, hg, hG1⟩ := G.2
+  have hGeq : G = ⟨AddSubgroup.zmultiples g, g, hg, rfl⟩ := Subtype.ext hG1
+  constructor
+  · rintro ⟨m, hb3⟩
+    refine ⟨?_, (bridge3SpecialiseN N j₀ G).2.imp fun _ h => h.2⟩
+    have hgT : addOrderOf (nearTransport j₀ m g) = N := (AddEquiv.addOrderOf_eq _ g).trans hg
+    have key : (bridge3SpecialiseN N j₀ G').1 = (bridge3SpecialiseN N j₀ G).1 := by
+      calc (bridge3SpecialiseN N j₀ G').1
+          = (bridge3SpecialiseN N j₀
+              ⟨b3Act j₀ m (AddSubgroup.zmultiples g), nearTransport j₀ m g, hgT,
+                b3Act_zmultiples j₀ m g⟩).1 := by
+            apply bridge3SpecialiseN_coe_eq_of_coe_eq
+            rw [← hb3, hG1]
+        _ = (bridge3SpecialiseN N j₀ ⟨AddSubgroup.zmultiples g, g, hg, rfl⟩).1 :=
+            bridge3SpecialiseN_b3Act_generic N j₀ h0 h1728 m g hg
+        _ = (bridge3SpecialiseN N j₀ G).1 := by rw [← hGeq]
+    exact key.symm
+  · rintro ⟨hβeq, _⟩
+    refine ⟨1, ?_⟩
+    rw [b3Act_oneN]
+    have : G = G' := (bridge3SpecialiseN N j₀).injective (Subtype.ext hβeq)
+    rw [this]
+
+open WeierstrassCurve.Affine in
+theorem redPoint_scaleAddEquiv_nearTransport_zero (N : ℕ) [NeZero N]
+    (m : HahnSeries.monodromy Qbar) {ζ : Qbar}
+    (hζs : (m : H ≃ₐ[Qbar] H) (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ)
+    (hζ0 : ζ ≠ 0) (hζ6 : ζ ^ 6 = 1)
+    (g : (nearCurve 0).toAffine.Point) (hg : addOrderOf g = N) :
+    redPoint (goodModel 0) (goodModel_spec 0).1 (goodModel_spec 0).2
+        (scaleAddEquiv 0 (nearTransport 0 m g)) =
+      fibreTwistEquiv_zero ζ hζ0 hζ6
+        (redPoint (goodModel 0) (goodModel_spec 0).1 (goodModel_spec 0).2 (scaleAddEquiv 0 g)) := by
+  by_cases hg0 : g = 0
+  · subst hg0
+    rw [map_zero, map_zero, redPoint_zero, map_zero]
+  have hsg0 : (scaleAddEquiv 0 g : (goodModel 0).toAffine.Point) ≠ 0 :=
+    fun h0 => hg0 ((scaleAddEquiv 0).injective (h0.trans (map_zero _).symm))
+  set Q := scaleAddEquiv 0 g with hQdef
+  rcases hQeq : Q with _ | ⟨x, y, hns⟩
+  · exact absurd (hQdef ▸ hQeq) hsg0
+  have htor : N • WeierstrassCurve.Affine.Point.some x y hns = 0 := by
+    rw [← hQeq, hQdef, ← map_nsmul,
+      show N • g = 0 from hg ▸ addOrderOf_nsmul_eq_zero g, map_zero]
+  have ⟨hx, hy⟩ := torsion_coords_integral (goodModel 0) (goodModel_spec 0).1 (goodModel_spec 0).2
+    hns (NeZero.ne N) htor
+  have hE := nearCurve_map_of_mem_monodromy 0 m.2
+  have hconj : scaleAddEquiv 0 (nearTransport 0 m g) =
+      scaleAddEquiv 0 (WeierstrassCurve.Affine.Point.fixedTransport (m : H ≃ₐ[Qbar] H)
+        (nearCurve 0) hE ((scaleAddEquiv 0).symm (.some x y hns))) := by
+    rw [← hQeq, hQdef, AddEquiv.symm_apply_apply]
+    rfl
+  rw [hconj, redPoint_monodromy_cocycle_zero (m : H ≃ₐ[Qbar] H) m.2 ζ hζs hE hx hy hns,
+    redPoint_some (goodModel 0) (goodModel_spec 0).1 (goodModel_spec 0).2 hx hy hns,
+    fibreTwistEquiv_zero_some ζ hζ0 hζ6
+      (nonsingular_specialFibre (goodModel 0) (goodModel_spec 0).1 (goodModel_spec 0).2
+        hx hy hns)]
+
+open WeierstrassCurve.Affine in
+theorem redPoint_scaleAddEquiv_nearTransport_1728 (N : ℕ) [NeZero N]
+    (m : HahnSeries.monodromy Qbar) {ζ : Qbar}
+    (hζs : (m : H ≃ₐ[Qbar] H) (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ)
+    (hζ0 : ζ ≠ 0) (hζ4 : ζ ^ 4 = 1)
+    (g : (nearCurve 1728).toAffine.Point) (hg : addOrderOf g = N) :
+    redPoint (goodModel 1728) (goodModel_spec 1728).1 (goodModel_spec 1728).2
+        (scaleAddEquiv 1728 (nearTransport 1728 m g)) =
+      fibreTwistEquiv_1728 ζ hζ0 hζ4
+        (redPoint (goodModel 1728) (goodModel_spec 1728).1 (goodModel_spec 1728).2
+          (scaleAddEquiv 1728 g)) := by
+  by_cases hg0 : g = 0
+  · subst hg0
+    rw [map_zero, map_zero, redPoint_zero, map_zero]
+  have hsg0 : (scaleAddEquiv 1728 g : (goodModel 1728).toAffine.Point) ≠ 0 :=
+    fun h0 => hg0 ((scaleAddEquiv 1728).injective (h0.trans (map_zero _).symm))
+  set Q := scaleAddEquiv 1728 g with hQdef
+  rcases hQeq : Q with _ | ⟨x, y, hns⟩
+  · exact absurd (hQdef ▸ hQeq) hsg0
+  have htor : N • WeierstrassCurve.Affine.Point.some x y hns = 0 := by
+    rw [← hQeq, hQdef, ← map_nsmul,
+      show N • g = 0 from hg ▸ addOrderOf_nsmul_eq_zero g, map_zero]
+  have ⟨hx, hy⟩ := torsion_coords_integral (goodModel 1728) (goodModel_spec 1728).1
+    (goodModel_spec 1728).2 hns (NeZero.ne N) htor
+  have hE := nearCurve_map_of_mem_monodromy 1728 m.2
+  have hconj : scaleAddEquiv 1728 (nearTransport 1728 m g) =
+      scaleAddEquiv 1728 (WeierstrassCurve.Affine.Point.fixedTransport (m : H ≃ₐ[Qbar] H)
+        (nearCurve 1728) hE ((scaleAddEquiv 1728).symm (.some x y hns))) := by
+    rw [← hQeq, hQdef, AddEquiv.symm_apply_apply]
+    rfl
+  rw [hconj, redPoint_monodromy_cocycle_1728 (m : H ≃ₐ[Qbar] H) m.2 ζ hζs hE hx hy hns,
+    redPoint_some (goodModel 1728) (goodModel_spec 1728).1 (goodModel_spec 1728).2 hx hy hns,
+    fibreTwistEquiv_1728_some ζ hζ0 hζ4
+      (nonsingular_specialFibre (goodModel 1728) (goodModel_spec 1728).1 (goodModel_spec 1728).2
+        hx hy hns)]
+
+theorem sameOrbit_iff_mapN (E₀ : WeierstrassCurve Qbar) (H H' : AddSubgroup E₀.toAffine.Point) :
+    SameOrbit E₀ H H' ↔
+      (∃ γ : VariableChange Qbar, ∃ hγ : γ • E₀ = E₀,
+        H' = H.map ((vcEquivOfSMulEq γ hγ : _ ≃+ _) : _ →+ _)) ∧
+        ∃ g, H = AddSubgroup.zmultiples g := by
+  rw [sameOrbit_iff]
+  constructor
+  · rintro ⟨γ, hγ, g, g', rfl, rfl, hheq⟩
+    refine ⟨⟨γ, hγ, ?_⟩, g, rfl⟩
+    rw [(heq_vcInvFun_iff_eq γ hγ g g').mp hheq, AddMonoidHom.map_zmultiples]
+    rfl
+  · rintro ⟨⟨γ, hγ, rfl⟩, g, rfl⟩
+    refine ⟨γ, hγ, g, vcEquivOfSMulEq γ hγ g, rfl, ?_, ?_⟩
+    · rw [AddMonoidHom.map_zmultiples]; rfl
+    · exact (heq_vcInvFun_iff_eq γ hγ g _).mpr rfl
+
+theorem specialisationEquivariance_level_zero (N : ℕ) [NeZero N]
+    (G G' : CycSubH (nearCurve 0) N) :
+    (∃ m : HahnSeries.monodromy Qbar, b3Act 0 m G.1 = G'.1) ↔
+      SameOrbit (WeierstrassCurve.ofJ 0) (bridge3SpecialiseN N 0 G).1
+        (bridge3SpecialiseN N 0 G').1 := by
+  obtain ⟨g, hg, hG1⟩ := G.2
+  have hGeq : G = ⟨AddSubgroup.zmultiples g, g, hg, rfl⟩ := Subtype.ext hG1
+  have hBne : (-(2 * 1728 ^ 4) : Qbar) ≠ 0 := by norm_num
+  set P₀ : (specialFibre (goodModel 0)).toAffine.Point :=
+    redPoint (goodModel 0) (goodModel_spec 0).1 (goodModel_spec 0).2 (scaleAddEquiv 0 g) with hP₀def
+  have hβG : (bridge3SpecialiseN N 0 G).1 = AddSubgroup.zmultiples (fibreAddEquiv 0 P₀) := by
+    rw [hGeq, bridge3SpecialiseN_zmultiples N 0 g hg]
+  constructor
+  · rintro ⟨m, hb3⟩
+    obtain ⟨ζ, hζs⟩ := exists_zeta_of_mem_monodromyN m.2 (1 / 6 : ℚ)
+    have hζ6 : ζ ^ 6 = 1 := zeta_pow_eq_one_of_twist (k := 1) m.2 hζs (by norm_num)
+    have hζ0 : ζ ≠ 0 := zeta_ne_zero_of_pow_eq_one (n := 6) (by norm_num) hζ6
+    have hgT : addOrderOf (nearTransport 0 m g) = N := (AddEquiv.addOrderOf_eq _ g).trans hg
+    have hβG' : (bridge3SpecialiseN N 0 G').1 =
+        AddSubgroup.zmultiples (fibreAddEquiv 0 (fibreTwistEquiv_zero ζ hζ0 hζ6 P₀)) := by
+      rw [bridge3SpecialiseN_coe_eq_of_coe_eq N 0
+          (G' := ⟨AddSubgroup.zmultiples (nearTransport 0 m g), nearTransport 0 m g, hgT, rfl⟩)
+          (by rw [← hb3, hG1, b3Act_zmultiples]),
+        bridge3SpecialiseN_zmultiples N 0 (nearTransport 0 m g) hgT,
+        redPoint_scaleAddEquiv_nearTransport_zero N m hζs hζ0 hζ6 g hg]
+    rw [hβG, hβG']
+    exact sameOrbit_of_conj (fibreVC_smul 0) (fibreTwistVC_smul_fibre_zero hζ0 hζ6) P₀
+  · intro hSO
+    rw [hβG, sameOrbit_iff_mapN] at hSO
+    obtain ⟨⟨γ, hγ, hmap⟩, _⟩ := hSO
+    have hconjF : ((fibreVC 0)⁻¹ * γ * fibreVC 0) • specialFibre (goodModel 0) =
+        specialFibre (goodModel 0) := conj_smul_eq (fibreVC_smul 0) hγ
+    obtain ⟨hr, hs, ht, hu6⟩ : ((fibreVC 0)⁻¹ * γ * fibreVC 0).r = 0 ∧
+        ((fibreVC 0)⁻¹ * γ * fibreVC 0).s = 0 ∧
+        ((fibreVC 0)⁻¹ * γ * fibreVC 0).t = 0 ∧
+        (((fibreVC 0)⁻¹ * γ * fibreVC 0).u : Qbar) ^ 6 = 1 := by
+      have := hconjF
+      rw [specialFibre_goodModel_zero] at this
+      exact (smul_a6Model_eq_iff hBne _).mp this
+    set u : Qbarˣ := ((fibreVC 0)⁻¹ * γ * fibreVC 0).u with hudef
+    set ζ : Qbar := ((u⁻¹ : Qbarˣ) : Qbar) with hζdef
+    have hζ6 : ζ ^ 6 = 1 := by
+      rw [hζdef, ← Units.val_pow_eq_pow_val, inv_pow, ← Units.val_one (α := Qbar)]
+      exact congrArg Units.val (inv_eq_one.mpr (Units.ext hu6))
+    have hζ0 : ζ ≠ 0 := zeta_ne_zero_of_pow_eq_one (n := 6) (by norm_num) hζ6
+    obtain ⟨m', hm', hζs⟩ := monodromy_fullN 6 (by norm_num) ζ hζ6
+    have hζs' : ((⟨m', hm'⟩ : HahnSeries.monodromy Qbar) : H ≃ₐ[Qbar] H)
+        (HahnSeries.single (1 / 6 : ℚ) 1) = HahnSeries.single (1 / 6 : ℚ) ζ := by
+      have h6 : ((6 : ℕ) : ℚ)⁻¹ = (1 / 6 : ℚ) := by norm_num
+      rw [← h6]; exact hζs
+    have hftvc : fibreTwistVC ζ hζ0 = (fibreVC 0)⁻¹ * γ * fibreVC 0 := by
+      rw [variableChange_eq_of_rst_eq_zero _ hr hs ht]
+      change (⟨(Units.mk0 ζ hζ0)⁻¹, 0, 0, 0⟩ : VariableChange Qbar) = ⟨u, 0, 0, 0⟩
+      have : Units.mk0 ζ hζ0 = u⁻¹ := Units.ext (by rw [Units.val_mk0, hζdef])
+      rw [this, inv_inv]
+    refine ⟨⟨m', hm'⟩, ?_⟩
+    have hgT : addOrderOf (nearTransport 0 ⟨m', hm'⟩ g) = N :=
+      (AddEquiv.addOrderOf_eq _ g).trans hg
+    suffices h : (bridge3SpecialiseN N 0
+          ⟨AddSubgroup.zmultiples (nearTransport 0 ⟨m', hm'⟩ g),
+            nearTransport 0 ⟨m', hm'⟩ g, hgT, rfl⟩).1 =
+        (bridge3SpecialiseN N 0 G').1 by
+      have := (bridge3SpecialiseN N 0).injective (Subtype.ext h)
+      rw [hG1, b3Act_zmultiples, ← this]
+    rw [bridge3SpecialiseN_zmultiples N 0 (nearTransport 0 ⟨m', hm'⟩ g) hgT,
+      redPoint_scaleAddEquiv_nearTransport_zero N ⟨m', hm'⟩ hζs' hζ0 hζ6 g hg,
+      ← hP₀def]
+    rw [hmap, AddMonoidHom.map_zmultiples]
+    congr 1
+    have hftvc_smul : fibreTwistVC ζ hζ0 • specialFibre (goodModel 0) =
+        specialFibre (goodModel 0) := hftvc ▸ hconjF
+    calc fibreAddEquiv 0 (fibreTwistEquiv_zero ζ hζ0 hζ6 P₀)
+        = vcEquivOfSMulEq (fibreVC 0) (fibreVC_smul 0)
+            (vcEquivOfSMulEq (fibreTwistVC ζ hζ0) hftvc_smul P₀) := rfl
+      _ = vcEquivOfSMulEq (fibreVC 0) (fibreVC_smul 0)
+            (vcEquivOfSMulEq ((fibreVC 0)⁻¹ * γ * fibreVC 0) hconjF P₀) := by
+          rw [vcEquivOfSMulEq_congr hftvc hftvc_smul hconjF]
+      _ = vcEquivOfSMulEq γ hγ (vcEquivOfSMulEq (fibreVC 0) (fibreVC_smul 0) P₀) :=
+          vcEquivOfSMulEq_conj (fibreVC_smul 0) hγ P₀
+      _ = _ := rfl
+
+theorem monodromy_full_three_quartersN (ζ : Qbar) (hζ4 : ζ ^ 4 = 1) :
+    ∃ m ∈ HahnSeries.monodromy Qbar,
+      (m : H ≃ₐ[Qbar] H) (HahnSeries.single (3 / 4 : ℚ) 1) = HahnSeries.single (3 / 4 : ℚ) ζ := by
+  have hζ'4 : (ζ ^ 3) ^ 4 = 1 := by rw [← pow_mul, show 3 * 4 = 4 * 3 from rfl, pow_mul, hζ4,
+    one_pow]
+  obtain ⟨m, hm, hζ's⟩ := monodromy_fullN 4 (by norm_num) (ζ ^ 3) hζ'4
+  refine ⟨m, hm, ?_⟩
+  have h14 : ((4 : ℕ) : ℚ)⁻¹ = (1 / 4 : ℚ) := by norm_num
+  have h34 : (HahnSeries.single (3 / 4 : ℚ) (1 : Qbar) : H) =
+      (HahnSeries.single ((4 : ℕ) : ℚ)⁻¹ (1 : Qbar)) ^ 3 := by
+    rw [HahnSeries.single_pow, one_pow, h14]
+    norm_num
+  rw [h34, map_pow, hζ's, HahnSeries.single_pow, h14, ← pow_mul,
+    show 3 * 3 = 4 * 2 + 1 from rfl, pow_add, pow_mul, hζ4, one_pow, pow_one, one_mul]
+  norm_num
+
+theorem specialisationEquivariance_level_1728 (N : ℕ) [NeZero N]
+    (G G' : CycSubH (nearCurve 1728) N) :
+    (∃ m : HahnSeries.monodromy Qbar, b3Act 1728 m G.1 = G'.1) ↔
+      SameOrbit (WeierstrassCurve.ofJ 1728) (bridge3SpecialiseN N 1728 G).1
+        (bridge3SpecialiseN N 1728 G').1 := by
+  obtain ⟨g, hg, hG1⟩ := G.2
+  have hGeq : G = ⟨AddSubgroup.zmultiples g, g, hg, rfl⟩ := Subtype.ext hG1
+  have hAne : (-36 : Qbar) ≠ 0 := by norm_num
+  set P₀ : (specialFibre (goodModel 1728)).toAffine.Point :=
+    redPoint (goodModel 1728) (goodModel_spec 1728).1 (goodModel_spec 1728).2 (scaleAddEquiv 1728 g)
+    with hP₀def
+  have hβG : (bridge3SpecialiseN N 1728 G).1 = AddSubgroup.zmultiples (fibreAddEquiv 1728 P₀) := by
+    rw [hGeq, bridge3SpecialiseN_zmultiples N 1728 g hg]
+  constructor
+  · rintro ⟨m, hb3⟩
+    obtain ⟨ζ, hζs⟩ := exists_zeta_of_mem_monodromyN m.2 (3 / 4 : ℚ)
+    have hζ4 : ζ ^ 4 = 1 := zeta_pow_eq_one_of_twist (k := 3) m.2 hζs (by norm_num)
+    have hζ0 : ζ ≠ 0 := zeta_ne_zero_of_pow_eq_one (n := 4) (by norm_num) hζ4
+    have hgT : addOrderOf (nearTransport 1728 m g) = N := (AddEquiv.addOrderOf_eq _ g).trans hg
+    have hβG' : (bridge3SpecialiseN N 1728 G').1 =
+        AddSubgroup.zmultiples (fibreAddEquiv 1728 (fibreTwistEquiv_1728 ζ hζ0 hζ4 P₀)) := by
+      rw [bridge3SpecialiseN_coe_eq_of_coe_eq N 1728
+          (G' := ⟨AddSubgroup.zmultiples (nearTransport 1728 m g), nearTransport 1728 m g, hgT,
+            rfl⟩)
+          (by rw [← hb3, hG1, b3Act_zmultiples]),
+        bridge3SpecialiseN_zmultiples N 1728 (nearTransport 1728 m g) hgT,
+        redPoint_scaleAddEquiv_nearTransport_1728 N m hζs hζ0 hζ4 g hg]
+    rw [hβG, hβG']
+    exact sameOrbit_of_conj (fibreVC_smul 1728) (fibreTwistVC_smul_fibre_1728 hζ0 hζ4) P₀
+  · intro hSO
+    rw [hβG, sameOrbit_iff_mapN] at hSO
+    obtain ⟨⟨γ, hγ, hmap⟩, _⟩ := hSO
+    have hconjF : ((fibreVC 1728)⁻¹ * γ * fibreVC 1728) • specialFibre (goodModel 1728) =
+        specialFibre (goodModel 1728) := conj_smul_eq (fibreVC_smul 1728) hγ
+    obtain ⟨hr, hs, ht, hu4⟩ : ((fibreVC 1728)⁻¹ * γ * fibreVC 1728).r = 0 ∧
+        ((fibreVC 1728)⁻¹ * γ * fibreVC 1728).s = 0 ∧
+        ((fibreVC 1728)⁻¹ * γ * fibreVC 1728).t = 0 ∧
+        (((fibreVC 1728)⁻¹ * γ * fibreVC 1728).u : Qbar) ^ 4 = 1 := by
+      have := hconjF
+      rw [specialFibre_goodModel_1728] at this
+      exact (smul_a4Model_eq_iff hAne _).mp this
+    set u : Qbarˣ := ((fibreVC 1728)⁻¹ * γ * fibreVC 1728).u with hudef
+    set ζ : Qbar := ((u⁻¹ : Qbarˣ) : Qbar) with hζdef
+    have hζ4 : ζ ^ 4 = 1 := by
+      rw [hζdef, ← Units.val_pow_eq_pow_val, inv_pow, ← Units.val_one (α := Qbar)]
+      exact congrArg Units.val (inv_eq_one.mpr (Units.ext hu4))
+    have hζ0 : ζ ≠ 0 := zeta_ne_zero_of_pow_eq_one (n := 4) (by norm_num) hζ4
+    obtain ⟨m', hm', hζs⟩ := monodromy_full_three_quartersN ζ hζ4
+    have hftvc : fibreTwistVC ζ hζ0 = (fibreVC 1728)⁻¹ * γ * fibreVC 1728 := by
+      rw [variableChange_eq_of_rst_eq_zero _ hr hs ht]
+      change (⟨(Units.mk0 ζ hζ0)⁻¹, 0, 0, 0⟩ : VariableChange Qbar) = ⟨u, 0, 0, 0⟩
+      have : Units.mk0 ζ hζ0 = u⁻¹ := Units.ext (by rw [Units.val_mk0, hζdef])
+      rw [this, inv_inv]
+    refine ⟨⟨m', hm'⟩, ?_⟩
+    have hgT : addOrderOf (nearTransport 1728 ⟨m', hm'⟩ g) = N :=
+      (AddEquiv.addOrderOf_eq _ g).trans hg
+    suffices h : (bridge3SpecialiseN N 1728
+          ⟨AddSubgroup.zmultiples (nearTransport 1728 ⟨m', hm'⟩ g),
+            nearTransport 1728 ⟨m', hm'⟩ g, hgT, rfl⟩).1 =
+        (bridge3SpecialiseN N 1728 G').1 by
+      have := (bridge3SpecialiseN N 1728).injective (Subtype.ext h)
+      rw [hG1, b3Act_zmultiples, ← this]
+    rw [bridge3SpecialiseN_zmultiples N 1728 (nearTransport 1728 ⟨m', hm'⟩ g) hgT,
+      redPoint_scaleAddEquiv_nearTransport_1728 N ⟨m', hm'⟩ hζs hζ0 hζ4 g hg,
+      ← hP₀def]
+    rw [hmap, AddMonoidHom.map_zmultiples]
+    congr 1
+    have hftvc_smul : fibreTwistVC ζ hζ0 • specialFibre (goodModel 1728) =
+        specialFibre (goodModel 1728) := hftvc ▸ hconjF
+    calc fibreAddEquiv 1728 (fibreTwistEquiv_1728 ζ hζ0 hζ4 P₀)
+        = vcEquivOfSMulEq (fibreVC 1728) (fibreVC_smul 1728)
+            (vcEquivOfSMulEq (fibreTwistVC ζ hζ0) hftvc_smul P₀) := rfl
+      _ = vcEquivOfSMulEq (fibreVC 1728) (fibreVC_smul 1728)
+            (vcEquivOfSMulEq ((fibreVC 1728)⁻¹ * γ * fibreVC 1728) hconjF P₀) := by
+          rw [vcEquivOfSMulEq_congr hftvc hftvc_smul hconjF]
+      _ = vcEquivOfSMulEq γ hγ (vcEquivOfSMulEq (fibreVC 1728) (fibreVC_smul 1728) P₀) :=
+          vcEquivOfSMulEq_conj (fibreVC_smul 1728) hγ P₀
+      _ = _ := rfl
+
+theorem specialisationEquivariance_levelN (N : ℕ) [NeZero N] (j₀ : Qbar) :
+    ∃ β : CycSubH (nearCurve j₀) N ≃ CycSub (WeierstrassCurve.ofJ j₀) N,
+      ∀ G G' : CycSubH (nearCurve j₀) N,
+        (∃ m : HahnSeries.monodromy Qbar, b3Act j₀ m G.1 = G'.1) ↔
+          SameOrbit (WeierstrassCurve.ofJ j₀) (β G).1 (β G').1 := by
+  refine ⟨bridge3SpecialiseN N j₀, fun G G' => ?_⟩
+  by_cases hz : j₀ = 0
+  · subst hz; exact specialisationEquivariance_level_zero N G G'
+  by_cases h17 : j₀ = 1728
+  · subst h17; exact specialisationEquivariance_level_1728 N G G'
+  exact specialisationEquivariance_level_generic N j₀ hz h17 G G'
+
+end ModularCurve.B3
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_B3_specialisationEquivariance_level.ModularCurve
+  ModularCurve.TatePoint _root_.ModularCurve.B3
+  _root_.P2MW.S_ModularCurve_B3_specialisationEquivariance_level.ModularCurve.B3 in
+theorem solution (N : ℕ) [NeZero N] (j₀ : Qbar) :
+    ∃ β : CycSubH (nearCurve j₀) N ≃ CycSub (WeierstrassCurve.ofJ j₀) N,
+      ∀ G G' : CycSubH (nearCurve j₀) N,
+        (∃ m : HahnSeries.monodromy Qbar, b3Act j₀ m G.1 = G'.1) ↔
+          SameOrbit (WeierstrassCurve.ofJ j₀) (β G).1 (β G').1 :=
+  ModularCurve.B3.specialisationEquivariance_levelN N j₀
+
+end S_ModularCurve_B3_specialisationEquivariance_level
+end P2MW
+export P2MW.S_ModularCurve_B3_specialisationEquivariance_level (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.TatePoint ModularCurve.B3
+theorem ModularCurve.B3.specialisationEquivariance_level (N : ℕ) [NeZero N] (j₀ : Qbar) :
+    ∃ β : CycSubH (nearCurve j₀) N ≃ CycSub (WeierstrassCurve.ofJ j₀) N,
+      ∀ G G' : CycSubH (nearCurve j₀) N,
+        (∃ m : HahnSeries.monodromy Qbar, b3Act j₀ m G.1 = G'.1) ↔
+          SameOrbit (WeierstrassCurve.ofJ j₀) (β G).1 (β G').1 :=
+  solution N j₀
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ComplexPlaceDictionaryOf_exists_pt_eq_of_mem.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ComplexPlaceDictionaryOf_exists_pt_eq_of_mem.lean
new file mode 100644
index 0000000000..a74cbc0462
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ComplexPlaceDictionaryOf_exists_pt_eq_of_mem.lean
@@ -0,0 +1,461 @@
+/-
+Based on Prove2Me node ModularCurve.ComplexPlaceDictionaryOf.exists_pt_eq_of_mem
+(febd49ec-8cd8-5f08-878f-9a85778d4061) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission fc8f4a46-8069-576a-99b9-f70e3f074037
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ComplexPlaceDictionaryOf
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isIntegral_adjoin_intermediateField_mk
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder_of_finiteIndex
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_realizeOf_eq_div
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Every place where j is regular is a point place
+
+Theorem statement: `ModularCurve.ComplexPlaceDictionaryOf.exists_pt_eq_of_mem`
+(`febd49ec-8cd8-5f08-878f-9a85778d4061`), by Claude, 2026-09-05.
+
+Proof: submission `fc8f4a46-8069-576a-99b9-f70e3f074037`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a finite-index subgroup of $\mathrm{SL}_2(\mathbb{Z})$ containing
+$T=\begin{pmatrix}1&1\\0&1\end{pmatrix}$, and let $F_0$ be an intermediate field of
+$\mathbb{Q}\subseteq\mathbb{Q}((q))$ that equals [`ModularCurve.qExpFunctionFieldC ℚ
+Γ`](def/ModularCurve_X1.html#L101), the subfield of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by
+the quotients of $q$-expansions of pairs of modular forms of equal weight for $\Gamma$ having
+integral $q$-expansions (with nonzero denominator). Write $\mathbb{C}F_0$ for
+[`ModularCurve.laurentBaseChange ℂ F₀`](def/ModularCurve_LaurentCoeff.html#L103), the subfield of
+$\mathbb{C}((q))$ generated over $\mathbb{C}$ by the image of $F_0$ under coefficientwise extension
+of scalars. Let $D$ be a complex place dictionary for $(\Gamma,F_0)$, i.e. a map $\mathrm{pt}$ from
+the upper half-plane to the places of $\mathbb{C}F_0$ over $\mathbb{C}$ (valuation subrings
+containing $\mathbb{C}$, proper, and principal ideal rings) together with positive integers
+$e_\tau$, such that $\mathrm{pt}$ is $\Gamma$-invariant, $x$ lies in the valuation subring of
+$\mathrm{pt}(\tau)$ exactly when $z\mapsto\|\mathrm{realizeOf}\,\Gamma\,x\,z\|$ is bounded near
+$\tau$ on the punctured neighbourhood filter, and for $x\neq 0$ the meromorphic order of the
+realisation at $\tau$ is $e_\tau\cdot\mathrm{ord}_{\mathrm{pt}(\tau)}(x)$. Let $P$ be a place of
+$\mathbb{C}F_0$ over $\mathbb{C}$ and let $x\in\mathbb{C}F_0$ have underlying Laurent series
+$q^{-1}\cdot(E_4^3/\Delta$-numerator series$)$, i.e. [`ModularCurve.jqModC
+ℂ`](def/ModularCurve_JqCoeff.html#L15). If $x$ lies in the valuation subring of $P$, then
+$P=\mathrm{pt}(\tau)$ for some $\tau$ in the upper half-plane.
+
+This is the completeness half of the identification of $\Gamma\backslash\mathfrak{H}$ with the
+places of the function field of $X(\Gamma)$ at which $j$ is regular: a place not lying above
+$j=\infty$, i.e. not a cusp, is the place attached to a point of the upper half-plane. It is used in
+the comparison of ramification indices with stabiliser orders, in the computation of Hecke
+correspondences on divisors supported at point places, and in the Abel–Jacobi criterion for
+principality of such divisors.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ComplexPlaceDictionaryOf_exists_pt_eq_of_mem.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ComplexPlaceDictionaryOf_exists_pt_eq_of_mem
+
+noncomputable section
+
+open UpperHalfPlane Filter Polynomial
+open scoped MatrixGroups Topology Manifold IntermediateField.algebraAdjoinAdjoin nonZeroDivisors
+
+namespace ModularCurve
+p2m_export "ModularCurve" "realizeOf ComplexPlaceDictionaryOf laurentBaseChange \
+  ComplexPlaceDictionary qExpFunctionFieldC jqModC \
+  transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqMod\
+  C exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC \
+  realizeOf_eq_div jqModC_eq_qExpansion_E4_cube_div_discriminant \
+  isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder_of_finiteIndex"
+namespace Ws49
+namespace CCPL
+p2m_open "ModularCurve"
+
+variable (Γ : Subgroup SL(2, ℤ))
+
+abbrev CF : Type := ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ Γ))
+
+variable (x : CF Γ)
+
+theorem transcendental_jX [Γ.FiniteIndex] [hT : Fact (ModularGroup.T ∈ Γ)]
+    [hx : Fact ((x : LaurentSeries ℂ) = jqModC ℂ)] :
+    Transcendental ℂ x :=
+  (transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC
+    ℂ Γ hT.out x hx.out).1
+
+abbrev A : Subalgebra ℂ (CF Γ) := Algebra.adjoin ℂ {x}
+
+abbrev Kj : IntermediateField ℂ (CF Γ) := IntermediateField.adjoin ℂ {x}
+
+def polyEquiv [Γ.FiniteIndex] [hT : Fact (ModularGroup.T ∈ Γ)]
+    [hx : Fact ((x : LaurentSeries ℂ) = jqModC ℂ)] :
+    ℂ[X] ≃ₐ[ℂ] A Γ x :=
+  Polynomial.algEquivOfTranscendental ℂ x (transcendental_jX Γ x)
+
+scoped instance instIsPrincipalIdealRingA [Γ.FiniteIndex] [hT : Fact (ModularGroup.T ∈ Γ)] [hx :
+  Fact ((x : LaurentSeries ℂ) = jqModC ℂ)] : IsPrincipalIdealRing (A Γ x) :=
+  IsPrincipalIdealRing.of_surjective (polyEquiv Γ x).toRingEquiv.toRingHom
+    (polyEquiv Γ x).toRingEquiv.surjective
+
+scoped instance instIsDedekindDomainA [Γ.FiniteIndex] [hT : Fact (ModularGroup.T ∈ Γ)] [hx : Fact
+  ((x : LaurentSeries ℂ) = jqModC ℂ)] : IsDedekindDomain (A Γ x) := inferInstance
+
+scoped instance instAlgebraAKj : Algebra (A Γ x) (Kj Γ x) := inferInstance
+scoped instance instSMulAKj : SMul (A Γ x) (Kj Γ x) := Algebra.toSMul
+scoped instance instIsScalarTowerAKjCF : IsScalarTower (A Γ x) (Kj Γ x) (CF Γ) :=
+  Subalgebra.inclusion.isScalarTower_right
+    (IntermediateField.algebra_adjoin_le_adjoin ℂ ({x} : Set (CF Γ))) _
+
+scoped instance instFiniteDimensionalKjCF [Γ.FiniteIndex] [hT : Fact (ModularGroup.T ∈ Γ)] [hx :
+  Fact ((x : LaurentSeries ℂ) = jqModC ℂ)] : FiniteDimensional (Kj Γ x) (CF Γ) :=
+  (transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC
+    ℂ Γ hT.out x hx.out).2
+
+def B : Subalgebra (A Γ x) (CF Γ) := integralClosure (A Γ x) (CF Γ)
+
+theorem mem_B_iff {y : CF Γ} : y ∈ B Γ x ↔ IsIntegral (A Γ x) y := Iff.rfl
+
+scoped instance instCommRingB : CommRing (B Γ x) := (B Γ x).toCommRing
+scoped instance instIsDomainB : IsDomain (B Γ x) := Subalgebra.isDomain (B Γ x)
+scoped instance instAlgebraAB : Algebra (A Γ x) (B Γ x) := (B Γ x).algebra
+scoped instance instSMulAB : SMul (A Γ x) (B Γ x) := Algebra.toSMul
+scoped instance instAlgebraBCF : Algebra (B Γ x) (CF Γ) := (B Γ x).toAlgebra
+scoped instance instSMulBCF : SMul (B Γ x) (CF Γ) := Algebra.toSMul
+scoped instance instIsScalarTowerABCF : IsScalarTower (A Γ x) (B Γ x) (CF Γ) :=
+  IsScalarTower.subalgebra' (A Γ x) (CF Γ) (CF Γ) (B Γ x)
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+scoped instance instIsDedekindDomainB [Γ.FiniteIndex] [hT : Fact (ModularGroup.T ∈ Γ)]
+    [hx : Fact ((x : LaurentSeries ℂ) = jqModC ℂ)] : IsDedekindDomain (B Γ x) :=
+  integralClosure.isDedekindDomain (A Γ x) (Kj Γ x) (CF Γ)
+
+scoped instance instIsFractionRingB [Γ.FiniteIndex] [hT : Fact (ModularGroup.T ∈ Γ)] [hx : Fact ((x
+  : LaurentSeries ℂ) = jqModC ℂ)] : IsFractionRing (B Γ x) (CF Γ) := by
+  unfold B; exact integralClosure.isFractionRing_of_finite_extension (Kj Γ x) (CF Γ)
+
+theorem algebraMap_B_apply (b : B Γ x) : algebraMap (B Γ x) (CF Γ) b = (b : CF Γ) := rfl
+
+def valSubalgebra (Q : AlgebraicCurve.Place ℂ (CF Γ)) : Subalgebra ℂ (CF Γ) where
+  carrier := Q.toValuationSubring
+  mul_mem' ha hb := Q.toValuationSubring.mul_mem _ _ ha hb
+  one_mem' := Q.toValuationSubring.one_mem
+  add_mem' ha hb := Q.toValuationSubring.add_mem _ _ ha hb
+  zero_mem' := Q.toValuationSubring.zero_mem
+  algebraMap_mem' c := Q.algebraMap_mem' c
+
+theorem mem_valSubalgebra {Q : AlgebraicCurve.Place ℂ (CF Γ)} {y : CF Γ} :
+    y ∈ valSubalgebra Γ Q ↔ y ∈ Q.toValuationSubring := Iff.rfl
+
+theorem A_le {Q : AlgebraicCurve.Place ℂ (CF Γ)} (hQ : x ∈ Q.toValuationSubring) (a : A Γ x) :
+    (a : CF Γ) ∈ Q.toValuationSubring := by
+  have hle : A Γ x ≤ valSubalgebra Γ Q :=
+    Algebra.adjoin_le (Set.singleton_subset_iff.mpr ((mem_valSubalgebra Γ).mpr hQ))
+  exact (mem_valSubalgebra Γ).mp (hle a.2)
+
+theorem forall_algebraMap_B_mem {Q : AlgebraicCurve.Place ℂ (CF Γ)}
+    (hQ : x ∈ Q.toValuationSubring) :
+    ∀ b : B Γ x, algebraMap (B Γ x) (CF Γ) b ∈ Q.toValuationSubring := by
+  intro b
+  obtain ⟨p, hp, hpb⟩ := (mem_B_iff Γ x).mp b.2
+  rw [algebraMap_B_apply]
+  refine Q.mem_of_eval_monic_eq_zero (P := p.map (algebraMap (A Γ x) (CF Γ))) (hp.map _)
+    (fun i => ?_) ?_
+  · rw [Polynomial.coeff_map]
+    exact A_le Γ x hQ (p.coeff i)
+  · rw [Polynomial.eval_map]
+    exact hpb
+
+section ModularForms
+
+theorem le_SL : ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) ≤ 𝒮ℒ :=
+  Subgroup.map_le_range _ _
+
+def restrict {F : Type*} [FunLike F ℍ ℂ] {Γ Γ' : Subgroup (GL (Fin 2) ℝ)} (hle : Γ' ≤ Γ)
+    {k : ℤ} (f : F) [ModularFormClass F Γ k] : ModularForm Γ' k where
+  toFun := f
+  slash_action_eq' γ hγ := SlashInvariantFormClass.slash_action_eq f γ (hle hγ)
+  holo' := ModularFormClass.holo f
+  bdd_at_cusps' hc := ModularFormClass.bdd_at_cusps f (hc.mono hle)
+
+@[scoped simp]
+theorem coe_restrict {F : Type*} [FunLike F ℍ ℂ] {Γ Γ' : Subgroup (GL (Fin 2) ℝ)}
+    (hle : Γ' ≤ Γ) {k : ℤ} (f : F) [ModularFormClass F Γ k] :
+    ((restrict hle f : ModularForm Γ' k) : ℍ → ℂ) = f := rfl
+
+def G : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12 :=
+  restrict (le_SL Γ) (ModularForm.mcast (by decide) (ModularForm.E₄.pow 3))
+
+def H : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12 :=
+  restrict (le_SL Γ) CuspForm.discriminant
+
+theorem coe_G : ((G Γ : ModularForm _ 12) : ℍ → ℂ) =
+    ((ModularForm.E₄.pow 3 : ModularForm 𝒮ℒ (3 * 4)) : ℍ → ℂ) := rfl
+
+theorem coe_H : ((H Γ : ModularForm _ 12) : ℍ → ℂ) = ModularForm.discriminant := rfl
+
+theorem H_apply_ne_zero (z : ℍ) : (H Γ : ℍ → ℂ) z ≠ 0 := by
+  rw [coe_H]
+  exact ModularForm.discriminant_ne_zero z
+
+abbrev qL {k : ℤ} (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) : LaurentSeries ℂ :=
+  ((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+
+theorem one_mem_strictPeriods [hT : Fact (ModularGroup.T ∈ Γ)] :
+    (1 : ℝ) ∈ ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  rw [Subgroup.mem_strictPeriods_iff]
+  refine ⟨ModularGroup.T, hT.out, ?_⟩
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp [ModularGroup.T, Matrix.GeneralLinearGroup.upperRightHom]
+
+theorem one_mem_strictPeriods_SL : (1 : ℝ) ∈ (𝒮ℒ : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  simp
+
+private theorem _root_.ModularCurve.Ws49.CCPL.continuous_coe {k : ℤ}
+    (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) :
+    Continuous (f : ℍ → ℂ) :=
+  (ModularFormClass.holo f).continuous
+
+p2m_export "ModularCurve.Ws49.CCPL" "continuous_coe"
+
+theorem qL_ne_zero [hT : Fact (ModularGroup.T ∈ Γ)] {k : ℤ}
+    (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hf : f ≠ 0) :
+    qL Γ f ≠ 0 := by
+  intro h
+  apply hf
+  rw [← ModularForm.qExpansion_eq_zero_iff one_pos (one_mem_strictPeriods Γ)]
+  apply (HahnSeries.ofPowerSeries_injective (Γ := ℤ) (R := ℂ))
+  simpa [qL] using h
+
+theorem H_ne_zero : H Γ ≠ 0 := by
+  intro h
+  have := congrArg (fun f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12 => (f : ℍ → ℂ) I) h
+  exact H_apply_ne_zero Γ I (by simpa using this)
+
+theorem qL_G : qL Γ (G Γ) =
+    ((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) ^ 3 := by
+  have h : qExpansion 1 ((G Γ : ModularForm _ 12) : ℍ → ℂ) =
+      (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) ^ 3 := by
+    rw [coe_G, ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+  rw [qL, h, PowerSeries.coe_pow]
+
+theorem qL_H : qL Γ (H Γ) =
+    ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) :=
+  rfl
+
+theorem jqModC_mul_qL_H [hT : Fact (ModularGroup.T ∈ Γ)] : jqModC ℂ * qL Γ (H Γ) = qL Γ (G Γ) := by
+  rw [jqModC_eq_qExpansion_E4_cube_div_discriminant, qL_G, ← qL_H Γ]
+  exact div_mul_cancel₀ _ (qL_ne_zero Γ (H Γ) (H_ne_zero Γ))
+
+theorem realizeOf_jqModC [hT : Fact (ModularGroup.T ∈ Γ)] (z : ℍ) :
+    realizeOf Γ (jqModC ℂ) z = (G Γ : ℍ → ℂ) z / (H Γ : ℍ → ℂ) z :=
+  ModularCurve.realizeOf_eq_div Γ hT.out (G Γ) (H Γ) (jqModC ℂ) (jqModC_mul_qL_H Γ) z
+    (H_apply_ne_zero Γ z)
+
+theorem isBoundedUnder_realizeOf_jqModC [hT : Fact (ModularGroup.T ∈ Γ)] (τ : ℍ) :
+    IsBoundedUnder (· ≤ ·) (𝓝[≠] τ) (fun z : ℍ => ‖realizeOf Γ (jqModC ℂ) z‖) := by
+  have hcont : Continuous (fun z : ℍ => (G Γ : ℍ → ℂ) z / (H Γ : ℍ → ℂ) z) :=
+    (continuous_coe Γ (G Γ)).div (continuous_coe Γ (H Γ)) (H_apply_ne_zero Γ)
+  have hbd : IsBoundedUnder (· ≤ ·) (𝓝 τ)
+      (fun z : ℍ => ‖(G Γ : ℍ → ℂ) z / (H Γ : ℍ → ℂ) z‖) :=
+    (hcont.continuousAt.norm.tendsto).isBoundedUnder_le
+  have hfun : (fun z : ℍ => ‖realizeOf Γ (jqModC ℂ) z‖) =
+      fun z : ℍ => ‖(G Γ : ℍ → ℂ) z / (H Γ : ℍ → ℂ) z‖ :=
+    funext fun z => by rw [realizeOf_jqModC]
+  rw [hfun]
+  exact hbd.mono nhdsWithin_le_nhds
+
+theorem coe_ne_zero {k : ℤ} (h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hh : h ≠ 0) :
+    (h : ℍ → ℂ) ≠ 0 := fun e => hh ((FunLike.coe_zero_iff h).mp e)
+
+theorem eventually_ne_zero {k : ℤ} (h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hh : h ≠ 0)
+    (τ : ℍ) : ∀ᶠ z in 𝓝[≠] τ, (h : ℍ → ℂ) z ≠ 0 := by
+  have hf : MDiff (h : ℍ → ℂ) := h.holo'
+  have han : AnalyticOnNhd ℂ ((h : ℍ → ℂ) ∘ ofComplex) {z : ℂ | 0 < z.im} :=
+    (UpperHalfPlane.mdifferentiable_iff.mp hf).analyticOnNhd isOpen_upperHalfPlaneSet
+  have hC : ∀ᶠ w in 𝓝[≠] (τ : ℂ), (h : ℍ → ℂ) (ofComplex w) ≠ 0 := by
+    rcases (han (τ : ℂ) τ.im_pos).eventually_eq_zero_or_eventually_ne_zero with hz | hz
+    · exfalso
+      apply coe_ne_zero Γ h hh
+      have hU : IsPreconnected {z : ℂ | 0 < z.im} := (convex_halfSpace_im_gt 0).isPreconnected
+      have key := han.eqOn_zero_of_preconnected_of_eventuallyEq_zero hU τ.im_pos hz
+      funext z
+      have := key z.im_pos
+      simp only [Function.comp_apply, ofComplex_apply] at this
+      exact this
+    · exact hz
+  have htend : Tendsto (fun z : ℍ => (z : ℂ)) (𝓝[≠] τ) (𝓝[≠] (τ : ℂ)) := by
+    refine tendsto_nhdsWithin_iff.mpr ⟨?_, ?_⟩
+    · exact UpperHalfPlane.continuous_coe.continuousAt.tendsto.mono_left nhdsWithin_le_nhds
+    · filter_upwards [self_mem_nhdsWithin] with z hz
+      intro hz'
+      exact hz (UpperHalfPlane.ext (Set.mem_singleton_iff.mp hz'))
+  filter_upwards [htend.eventually hC] with z hz
+  simpa only [ofComplex_apply] using hz
+
+theorem isBoundedUnder_div_of_realizeOf [hT : Fact (ModularGroup.T ∈ Γ)] {k : ℤ}
+    (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (hh : h ≠ 0) (y : LaurentSeries ℂ) (hy : y * qL Γ h = qL Γ g) (τ : ℍ)
+    (hb : IsBoundedUnder (· ≤ ·) (𝓝[≠] τ) (fun z : ℍ => ‖realizeOf Γ y z‖)) :
+    IsBoundedUnder (· ≤ ·) (𝓝[≠] τ) (fun z : ℍ => ‖(g : ℍ → ℂ) z / (h : ℍ → ℂ) z‖) := by
+  obtain ⟨b, hb⟩ := hb
+  refine ⟨b, ?_⟩
+  change ∀ᶠ z in 𝓝[≠] τ, ‖(g : ℍ → ℂ) z / (h : ℍ → ℂ) z‖ ≤ b
+  have hev : ∀ᶠ z in 𝓝[≠] τ, (h : ℍ → ℂ) z ≠ 0 := eventually_ne_zero Γ h hh τ
+  have hb' : ∀ᶠ z in 𝓝[≠] τ, ‖realizeOf Γ y z‖ ≤ b := hb
+  filter_upwards [hev, hb'] with z hz hzb
+  rw [← ModularCurve.realizeOf_eq_div Γ hT.out g h y hy z hz]
+  exact hzb
+
+end ModularForms
+
+theorem jX_mem_pt [hT : Fact (ModularGroup.T ∈ Γ)] [hx : Fact ((x : LaurentSeries ℂ) = jqModC ℂ)]
+    (D : ComplexPlaceDictionaryOf Γ (qExpFunctionFieldC ℚ Γ)) (τ : ℍ) :
+    x ∈ (D.pt τ).toValuationSubring := by
+  rw [D.mem_pt_iff τ x, hx.out]
+  exact isBoundedUnder_realizeOf_jqModC Γ τ
+
+open AlgebraicCurve in
+theorem eq_of_center_eq [Γ.FiniteIndex] [hT : Fact (ModularGroup.T ∈ Γ)]
+    [hx : Fact ((x : LaurentSeries ℂ) = jqModC ℂ)] {Q Q' : Place ℂ (CF Γ)}
+    (hQ : ∀ b : B Γ x, algebraMap (B Γ x) (CF Γ) b ∈ Q.toValuationSubring)
+    (hQ' : ∀ b : B Γ x, algebraMap (B Γ x) (CF Γ) b ∈ Q'.toValuationSubring)
+    (h : Place.center (B Γ x) Q hQ = Place.center (B Γ x) Q' hQ') : Q = Q' := by
+  apply Place.ext
+  rw [Place.toValuationSubring_eq_of_forall_mem Q hQ, Place.toValuationSubring_eq_of_forall_mem Q'
+    hQ']
+  have hc : Place.centerHeightOneSpectrum (B Γ x) Q hQ = Place.centerHeightOneSpectrum (B Γ x) Q'
+    hQ' :=
+    IsDedekindDomain.HeightOneSpectrum.ext h
+  rw [hc]
+
+open AlgebraicCurve in
+theorem mem_of_mul_eq [Γ.FiniteIndex] {Q : Place ℂ (CF Γ)}
+    (hQ : ∀ b : B Γ x, algebraMap (B Γ x) (CF Γ) b ∈ Q.toValuationSubring)
+    {y : CF Γ} {b s : B Γ x} (hs : s ∉ Place.center (B Γ x) Q hQ)
+    (hy : y * algebraMap (B Γ x) (CF Γ) s = algebraMap (B Γ x) (CF Γ) b) :
+    y ∈ Q.toValuationSubring := by
+  set O := Q.toValuationSubring
+  have hsunit : IsUnit (⟨algebraMap (B Γ x) (CF Γ) s, hQ s⟩ : O) :=
+    IsLocalRing.notMem_maximalIdeal.mp (fun hm => hs ((Place.mem_center_iff Q hQ).mpr hm))
+  have hv1 : O.valuation (algebraMap (B Γ x) (CF Γ) s) = 1 :=
+    (O.valuation_eq_one_iff _).mp hsunit
+  have hs0 : algebraMap (B Γ x) (CF Γ) s ≠ 0 := by
+    intro h0
+    rw [h0, map_zero] at hv1
+    exact zero_ne_one hv1
+  have hyeq : y = algebraMap (B Γ x) (CF Γ) b * (algebraMap (B Γ x) (CF Γ) s)⁻¹ := by
+    rw [← hy, mul_inv_cancel_right₀ hs0]
+  rw [← O.valuation_le_one_iff, hyeq, map_mul, map_inv₀, hv1, inv_one, mul_one]
+  exact O.valuation_le_one ⟨_, hQ b⟩
+
+open AlgebraicCurve in
+theorem exists_pt_eq [Γ.FiniteIndex] [hT : Fact (ModularGroup.T ∈ Γ)]
+    [hx : Fact ((x : LaurentSeries ℂ) = jqModC ℂ)]
+    (D : ComplexPlaceDictionaryOf Γ (qExpFunctionFieldC ℚ Γ)) (P : Place ℂ (CF Γ))
+    (hP : x ∈ P.toValuationSubring) : ∃ τ : ℍ, D.pt τ = P := by
+  by_contra hne
+  push Not at hne
+  have hwP := forall_algebraMap_B_mem Γ x hP
+  have h𝔭0 : Place.center (B Γ x) P hwP ≠ ⊥ := Place.center_ne_bot P hwP
+  have h𝔭max : (Place.center (B Γ x) P hwP).IsMaximal :=
+    (Place.centerHeightOneSpectrum (B Γ x) P hwP).isPrime.isMaximal h𝔭0
+  obtain ⟨y, hy𝔭, hyB⟩ :=
+    FractionalIdeal.exists_notMem_one_of_ne_bot (K := CF Γ) h𝔭0 h𝔭max.ne_top
+  have hyτ : ∀ τ : ℍ, y ∈ (D.pt τ).toValuationSubring := by
+    intro τ
+    have hwτ := forall_algebraMap_B_mem Γ x (jX_mem_pt Γ x D τ)
+    have hneq : ¬ Place.center (B Γ x) P hwP ≤ Place.center (B Γ x) (D.pt τ) hwτ := fun hle =>
+      hne τ (eq_of_center_eq Γ x hwτ hwP
+        (h𝔭max.eq_of_le
+          (Place.centerHeightOneSpectrum (B Γ x) (D.pt τ) hwτ).isPrime.ne_top hle).symm)
+    obtain ⟨s, hs𝔭, hsτ⟩ := Set.not_subset.mp hneq
+    have hys : y * algebraMap (B Γ x) (CF Γ) s ∈ (1 : FractionalIdeal (B Γ x)⁰ (CF Γ)) := by
+      have hmem : y * algebraMap (B Γ x) (CF Γ) s ∈
+          ((Place.center (B Γ x) P hwP : FractionalIdeal (B Γ x)⁰ (CF Γ))⁻¹ *
+            (Place.center (B Γ x) P hwP : FractionalIdeal (B Γ x)⁰ (CF Γ))) :=
+        FractionalIdeal.mul_mem_mul hy𝔭 (FractionalIdeal.mem_coeIdeal_of_mem _ hs𝔭)
+      rwa [inv_mul_cancel₀ (FractionalIdeal.coeIdeal_ne_zero.mpr h𝔭0)] at hmem
+    obtain ⟨b, hb⟩ := (FractionalIdeal.mem_one_iff _).mp hys
+    exact mem_of_mul_eq Γ x hwτ hsτ hb.symm
+  have hbdd : ∀ τ : ℍ, IsBoundedUnder (· ≤ ·) (𝓝[≠] τ)
+      (fun z : ℍ => ‖realizeOf Γ (y : LaurentSeries ℂ) z‖) :=
+    fun τ => (D.mem_pt_iff τ y).mp (hyτ τ)
+  obtain ⟨k, g, h, hh, hgh⟩ :=
+    exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC Γ hT.out
+      (y : LaurentSeries ℂ) y.2
+  have hb' : ∀ τ : ℍ, IsBoundedUnder (· ≤ ·) (𝓝[≠] τ)
+      (fun z : ℍ => ‖(g : ℍ → ℂ) z / (h : ℍ → ℂ) z‖) :=
+    fun τ => isBoundedUnder_div_of_realizeOf Γ g h hh (y : LaurentSeries ℂ) hgh τ (hbdd τ)
+  have hint0 :=
+    ModularCurve.isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder_of_finiteIndex Γ
+      hT.out g h hh hb'
+  have hyeq : (y : LaurentSeries ℂ) = qL Γ g / qL Γ h := by
+    rw [eq_div_iff (qL_ne_zero Γ h hh)]
+    exact hgh
+  have hint : IsIntegral (Algebra.adjoin ℂ ({(x : LaurentSeries ℂ)} : Set (LaurentSeries ℂ)))
+      (y : LaurentSeries ℂ) := by
+    rw [hx.out, hyeq]
+    exact hint0
+  have hint' : IsIntegral (A Γ x) y := by
+    have := AlgebraicCurve.isIntegral_adjoin_intermediateField_mk
+      (laurentBaseChange ℂ (qExpFunctionFieldC ℚ Γ)) x.2 y.2 hint
+    simpa using this
+  exact hyB ((FractionalIdeal.mem_one_iff _).mpr ⟨⟨y, (mem_B_iff Γ x).mpr hint'⟩, rfl⟩)
+
+end ModularCurve.Ws49.CCPL
+end
+
+open scoped MatrixGroups in
+theorem solution
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (hF : F₀ = ModularCurve.qExpFunctionFieldC ℚ Γ)
+    (D : ModularCurve.ComplexPlaceDictionaryOf Γ F₀)
+    (P : AlgebraicCurve.Place ℂ (ModularCurve.laurentBaseChange ℂ F₀))
+    (x : ModularCurve.laurentBaseChange ℂ F₀) (hx : (x : LaurentSeries ℂ) = ModularCurve.jqModC ℂ)
+    (hP : x ∈ P.toValuationSubring) :
+    ∃ τ : UpperHalfPlane, D.pt τ = P := by
+  subst hF
+  have : Fact (ModularGroup.T ∈ Γ) := ⟨hT⟩
+  have : Fact ((x : LaurentSeries ℂ) = ModularCurve.jqModC ℂ) := ⟨hx⟩
+  exact ModularCurve.Ws49.CCPL.exists_pt_eq Γ x D P hP
+
+end S_ModularCurve_ComplexPlaceDictionaryOf_exists_pt_eq_of_mem
+end P2MW
+export P2MW.S_ModularCurve_ComplexPlaceDictionaryOf_exists_pt_eq_of_mem (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.ComplexPlaceDictionaryOf.exists_pt_eq_of_mem
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (hF : F₀ = ModularCurve.qExpFunctionFieldC ℚ Γ)
+    (D : ModularCurve.ComplexPlaceDictionaryOf Γ F₀)
+    (P : AlgebraicCurve.Place ℂ (ModularCurve.laurentBaseChange ℂ F₀))
+    (x : ModularCurve.laurentBaseChange ℂ F₀) (hx : (x : LaurentSeries ℂ) = ModularCurve.jqModC ℂ)
+    (hP : x ∈ P.toValuationSubring) :
+    ∃ τ : UpperHalfPlane, D.pt τ = P :=
+  solution Γ hT F₀ hF D P x hx hP
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ComplexPlaceDictionaryOf_ramification_eq_one_gamma1.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ComplexPlaceDictionaryOf_ramification_eq_one_gamma1.lean
new file mode 100644
index 0000000000..687db3930c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ComplexPlaceDictionaryOf_ramification_eq_one_gamma1.lean
@@ -0,0 +1,538 @@
+/-
+Based on Prove2Me node ModularCurve.ComplexPlaceDictionaryOf.ramification_eq_one_gamma1
+(906fd3d2-fdfb-5dfe-971b-91dfcbd89604) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 457b690c-f9e1-5d18-b6c5-68ece28bea13
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ComplexPlaceDictionaryOf
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_mem_intFormRatiosC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_realizeOf_eq_div
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Ramification index one for Γ₁(M), M ≥ 4
+
+Theorem statement: `ModularCurve.ComplexPlaceDictionaryOf.ramification_eq_one_gamma1`
+(`906fd3d2-fdfb-5dfe-971b-91dfcbd89604`), by Claude, 2026-09-05.
+
+Proof: submission `457b690c-f9e1-5d18-b6c5-68ece28bea13`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $M$ with $M \neq 0$ and $4 \le M$, and let $F_0$ be an intermediate field of
+$\mathbb{Q} \subseteq \mathbb{Q}((q))$ which is assumed equal to [`ModularCurve.qExpFunctionFieldC ℚ
+(CongruenceSubgroup.Gamma1 M)`](def/ModularCurve_X1.html#L101), that is, to the subfield of the
+Laurent series field generated over $\mathbb{Q}$ by all quotients $\mathrm{intSeriesC}\,p_f /
+\mathrm{intSeriesC}\,p_g$ arising from modular forms $f,g$ of a common weight $k$ for $\Gamma_1(M)$
+together with integral $q$-expansions $p_f, p_g \in \mathbb{Z}[[q]]$ of them, the denominator series
+being nonzero. Let $D$ be a complex place dictionary for $(\Gamma_1(M), F_0)$: a datum consisting of
+a map $\mathrm{pt}$ from the upper half-plane $\mathbb{H}$ to the places of the field $\mathbb{C}
+\cdot F_0 \subseteq \mathbb{C}((q))$ obtained by adjoining to $\mathbb{C}$ the coefficientwise image
+of $F_0$ (a place being a proper valuation subring containing the base field whose ring is a
+principal ideal ring), a map $\mathrm{ramification} : \mathbb{H} \to \mathbb{N}$ with strictly
+positive values, invariance $\mathrm{pt}(\gamma \cdot \tau) = \mathrm{pt}(\tau)$ for $\gamma \in
+\Gamma_1(M)$, the requirement that $x$ lie in the valuation subring of $\mathrm{pt}(\tau)$ exactly
+when $z \mapsto \lVert \mathrm{realizeOf}\,x\,z \rVert$ is bounded on a punctured neighbourhood of
+$\tau$, and the requirement that for every nonzero $x$ the meromorphic order at $\tau$ of the
+function $z \mapsto \mathrm{realizeOf}\,x\,z$ equal $\mathrm{ramification}(\tau) \cdot
+\mathrm{ord}_{\mathrm{pt}(\tau)}(x)$; here $\mathrm{realizeOf}\,x\,\tau$ is $g(\tau)/h(\tau)$ for
+some choice of modular forms $g,h$ of equal weight for the group with $h(\tau) \neq 0$ and $x \cdot
+q\text{-exp}(h) = q\text{-exp}(g)$, and $0$ if no such pair exists. Then for every $\tau \in
+\mathbb{H}$ one has $\mathrm{ramification}(\tau) = 1$.
+
+This is the statement that $\Gamma_1(M)$ has no elliptic points for $M \ge 4$, in the form needed
+for the dictionary between points of the upper half-plane and places of the function field of
+$X_1(M)$: the analytic order of vanishing of a realized function at $\tau$ agrees with its valuation
+at the corresponding place, with no multiplier. It is used in the comparison of valuations with
+weights at such places, via
+[`ModularCurve.even_ord_add_weightFloor_of_mem_toValuationSubring_laurentBaseChange_gamma1`]
+(thm.html#ModularCurve.even_ord_add_weightFloor_of_mem_toValuationSubring_laurentBaseChange_gamma1).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ComplexPlaceDictionaryOf_ramification_eq_one_gamma1.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ComplexPlaceDictionaryOf_ramification_eq_one_gamma1
+
+noncomputable section
+
+open UpperHalfPlane ModularForm Complex SlashInvariantForm Filter ModularGroup
+open scoped MatrixGroups Real Topology ModularForm Manifold Modular
+
+namespace ModularCurve
+p2m_export "ModularCurve" "mem_intFormRatiosC qExpFunctionFieldC intFormRatiosC_subset jNum \
+  constantCoeff_jNum ofPowerSeries_coeff_of_neg algebraMap_laurentSeries_eq_single coeffEmb \
+  laurentBaseChange coeffEmb_mem_laurentBaseChange jqModC map_jqModC realizeOf \
+  ComplexPlaceDictionaryOf realizeOf_eq_div jqModC_eq_qExpansion_E4_cube_div_discriminant \
+  meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two \
+  ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1 jqModC_mem_intFormRatiosC"
+namespace RamOne
+p2m_open "ModularCurve"
+
+section JM
+
+def jf : ℍ → ℂ := fun τ => (E₄ : ℍ → ℂ) τ ^ 3 / ModularForm.discriminant τ
+
+lemma E₄_smul (γ : SL(2, ℤ)) (τ : ℍ) : E₄ (γ • τ) = denom γ τ ^ (4 : ℤ) * E₄ τ := by
+  have h := slash_action_eqn'' (Γ := 𝒮ℒ) (k := (4 : ℤ)) E₄ (γ := (γ : GL (Fin 2) ℝ)) ⟨γ, rfl⟩ τ
+  simpa [ModularGroup.sl_moeb] using h
+
+lemma Δ_smul (γ : SL(2, ℤ)) (τ : ℍ) :
+    ModularForm.discriminant (γ • τ) = denom γ τ ^ (12 : ℤ) * ModularForm.discriminant τ := by
+  have h := slash_action_eqn'' (Γ := 𝒮ℒ) (k := (12 : ℤ)) CuspForm.discriminant
+    (γ := (γ : GL (Fin 2) ℝ)) ⟨γ, rfl⟩ τ
+  simpa [ModularGroup.sl_moeb, CuspForm.coe_discriminant] using h
+
+lemma jf_smul (γ : SL(2, ℤ)) (τ : ℍ) : jf (γ • τ) = jf τ := by
+  simp only [jf]
+  rw [E₄_smul, Δ_smul]
+  have hd : denom (γ : GL (Fin 2) ℝ) τ ≠ 0 := denom_ne_zero _ _
+  have hΔ := discriminant_ne_zero τ
+  field_simp
+
+lemma mdifferentiable_jf : MDiff jf :=
+  (E₄.holo'.pow 3).div CuspForm.discriminant.holo' discriminant_ne_zero
+
+lemma mdiff_E₄ : MDiff (E₄ : ℍ → ℂ) := E₄.holo'
+lemma mdiff_E₆ : MDiff (E₆ : ℍ → ℂ) := E₆.holo'
+lemma mdiff_Δ : MDiff (ModularForm.discriminant : ℍ → ℂ) := CuspForm.discriminant.holo'
+
+lemma E₆_smul (γ : SL(2, ℤ)) (τ : ℍ) : E₆ (γ • τ) = denom γ τ ^ (6 : ℤ) * E₆ τ := by
+  have h := slash_action_eqn'' (Γ := 𝒮ℒ) (k := (6 : ℤ)) E₆ (γ := (γ : GL (Fin 2) ℝ)) ⟨γ, rfl⟩ τ
+  simpa [ModularGroup.sl_moeb] using h
+
+lemma S_smul_I : ModularGroup.S • UpperHalfPlane.I = UpperHalfPlane.I :=
+  ModularGroup.stabilizer_I.mpr (by simp)
+
+lemma TinvS_smul_ρ : (ModularGroup.T⁻¹ * ModularGroup.S) • ρ = ρ :=
+  ModularGroup.stabilizer_ρ.mpr (by simp)
+
+lemma E₆_I : E₆ UpperHalfPlane.I = 0 := by
+  have h := E₆_smul ModularGroup.S UpperHalfPlane.I
+  rw [S_smul_I, ModularGroup.denom_S, UpperHalfPlane.coe_I] at h
+  have hI6 : Complex.I ^ (6 : ℤ) = -1 := by
+    rw [show (6 : ℤ) = ((6 : ℕ) : ℤ) from rfl, zpow_natCast]
+    calc Complex.I ^ 6 = (Complex.I ^ 2) ^ 3 := by ring
+      _ = -1 := by rw [Complex.I_sq]; norm_num
+  rw [hI6] at h
+  linear_combination h / 2
+
+lemma denom_TinvS_ρ : denom (↑(ModularGroup.T⁻¹ * ModularGroup.S) : GL (Fin 2) ℝ) ρ = (ρ : ℂ) := by
+  rw [ModularGroup.denom_apply]
+  have h10 : (ModularGroup.T⁻¹ * ModularGroup.S) 1 0 = 1 := by
+    rw [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_T_inv, ModularGroup.coe_S]
+    simp
+  have h11 : (ModularGroup.T⁻¹ * ModularGroup.S) 1 1 = 0 := by
+    rw [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_T_inv, ModularGroup.coe_S]
+    simp
+  rw [h10, h11]
+  simp
+
+lemma ρ_ne_one : (ρ : ℂ) ≠ 1 := by
+  intro h
+  have := congrArg Complex.im h
+  rw [UpperHalfPlane.coe_im] at this
+  simp only [one_im] at this
+  exact ρ.im_pos.ne' this
+
+lemma E₄_ρ : E₄ ρ = 0 := by
+  have h := E₄_smul (ModularGroup.T⁻¹ * ModularGroup.S) ρ
+  rw [TinvS_smul_ρ, denom_TinvS_ρ] at h
+  have hρ4 : (ρ : ℂ) ^ (4 : ℤ) = (ρ : ℂ) := by
+    rw [show (4 : ℤ) = ((4 : ℕ) : ℤ) from rfl, zpow_natCast]
+    linear_combination ((ρ : ℂ) ^ 2 - ρ) * ρ_sq
+  rw [hρ4] at h
+  have : ((ρ : ℂ) - 1) * E₄ ρ = 0 := by linear_combination -h
+  rcases mul_eq_zero.mp this with h1 | h1
+  · exact absurd (sub_eq_zero.mp h1) ρ_ne_one
+  · exact h1
+
+lemma E₄_I_ne_zero : E₄ UpperHalfPlane.I ≠ 0 := by
+  intro h
+  have hΔ := discriminant_ne_zero UpperHalfPlane.I
+  rw [discriminant_eq_E₄_cube_sub_E₆_sq, h, E₆_I] at hΔ
+  norm_num at hΔ
+
+lemma E₆_ρ_ne_zero : E₆ ρ ≠ 0 := by
+  intro h
+  have hΔ := discriminant_ne_zero ρ
+  rw [discriminant_eq_E₄_cube_sub_E₆_sq, h, E₄_ρ] at hΔ
+  norm_num at hΔ
+
+lemma jf_ρ : jf ρ = 0 := by simp [jf, E₄_ρ]
+
+lemma jf_I_ne_zero : jf UpperHalfPlane.I ≠ 0 :=
+  div_ne_zero (pow_ne_zero _ E₄_I_ne_zero) (discriminant_ne_zero _)
+
+lemma E₄_smul_eq_zero_iff (γ : SL(2, ℤ)) (τ : ℍ) : E₄ (γ • τ) = 0 ↔ E₄ τ = 0 := by
+  rw [E₄_smul, mul_eq_zero, or_iff_right]
+  exact zpow_ne_zero _ (denom_ne_zero _ _)
+
+lemma E₆_smul_eq_zero_iff (γ : SL(2, ℤ)) (τ : ℍ) : E₆ (γ • τ) = 0 ↔ E₆ τ = 0 := by
+  rw [E₆_smul, mul_eq_zero, or_iff_right]
+  exact zpow_ne_zero _ (denom_ne_zero _ _)
+
+lemma natCard_stabilizer_I : Nat.card (MulAction.stabilizer SL(2, ℤ) UpperHalfPlane.I) = 4 := by
+  rw [Nat.card_congr (Equiv.subtypeEquivRight
+    (q := fun g => g ∈ ({1, -1, ModularGroup.S, -ModularGroup.S} : Finset SL(2, ℤ)))
+    (fun g => (MulAction.mem_stabilizer_iff).trans ModularGroup.stabilizer_I)),
+    Nat.card_eq_finsetCard]
+  decide
+
+lemma natCard_stabilizer_ρ : Nat.card (MulAction.stabilizer SL(2, ℤ) ρ) = 6 := by
+  rw [Nat.card_congr (Equiv.subtypeEquivRight
+    (q := fun g => g ∈ ({1, -1, ModularGroup.S * ModularGroup.T, -(ModularGroup.S * ModularGroup.T),
+      ModularGroup.T⁻¹ * ModularGroup.S, -(ModularGroup.T⁻¹ * ModularGroup.S)} : Finset SL(2, ℤ)))
+    (fun g => (MulAction.mem_stabilizer_iff).trans ModularGroup.stabilizer_ρ)),
+    Nat.card_eq_finsetCard]
+  decide
+
+lemma natCard_stabilizer_smul (γ : SL(2, ℤ)) (τ : ℍ) :
+    Nat.card (MulAction.stabilizer SL(2, ℤ) (γ • τ)) =
+      Nat.card (MulAction.stabilizer SL(2, ℤ) τ) :=
+  (Nat.card_congr (MulAction.stabilizerEquivStabilizer (rfl : γ • τ = γ • τ)).toEquiv).symm
+
+lemma orbit_trichotomy (τ : ℍ) :
+    (∃ γ : SL(2, ℤ), τ = γ • UpperHalfPlane.I) ∨ (∃ γ : SL(2, ℤ), τ = γ • ρ) ∨
+      (∀ g : SL(2, ℤ), g • τ = τ → g = 1 ∨ g = -1) := by
+  obtain ⟨g₀, hg₀⟩ := ModularGroup.exists_smul_mem_fd τ
+  by_cases hI : g₀ • τ = UpperHalfPlane.I
+  · exact Or.inl ⟨g₀⁻¹, by rw [← hI, inv_smul_smul]⟩
+  by_cases hρ : g₀ • τ = ρ
+  · exact Or.inr (Or.inl ⟨g₀⁻¹, by rw [← hρ, inv_smul_smul]⟩)
+  by_cases hρ' : g₀ • τ = (1 : ℝ) +ᵥ ρ
+  · refine Or.inr (Or.inl ⟨g₀⁻¹ * ModularGroup.T, ?_⟩)
+    rw [mul_smul, UpperHalfPlane.modular_T_smul, ← hρ', inv_smul_smul]
+  refine Or.inr (Or.inr fun g hg => ?_)
+  have h : (g₀ * g * g₀⁻¹) • (g₀ • τ) = g₀ • τ := by
+    rw [mul_smul, mul_smul, inv_smul_smul, hg]
+  rcases ModularGroup.stabilizer_of_ne hg₀ h hI hρ hρ' with h1 | h1
+  · left
+    have := congrArg (fun x => g₀⁻¹ * x * g₀) h1
+    simpa [mul_assoc] using this
+  · right
+    have := congrArg (fun x => g₀⁻¹ * x * g₀) h1
+    simpa [mul_assoc] using this
+
+lemma natCard_stabilizer_eq_two {τ : ℍ} (h : ∀ g : SL(2, ℤ), g • τ = τ → g = 1 ∨ g = -1) :
+    Nat.card (MulAction.stabilizer SL(2, ℤ) τ) = 2 := by
+  have hiff : ∀ g : SL(2, ℤ), g ∈ MulAction.stabilizer SL(2, ℤ) τ ↔
+      g ∈ ({1, -1} : Finset SL(2, ℤ)) := by
+    intro g
+    rw [MulAction.mem_stabilizer_iff, Finset.mem_insert, Finset.mem_singleton]
+    refine ⟨h g, ?_⟩
+    rintro (rfl | rfl)
+    · exact one_smul _ _
+    · rw [ModularGroup.SL_neg_smul, one_smul]
+  rw [Nat.card_congr (Equiv.subtypeEquivRight
+    (q := fun g => g ∈ ({1, -1} : Finset SL(2, ℤ))) hiff), Nat.card_eq_finsetCard]
+  decide
+
+lemma E₆_ne_zero_of_E₄_eq_zero {τ : ℍ} (h4 : E₄ τ = 0) : E₆ τ ≠ 0 := by
+  intro h6
+  have hΔ := discriminant_ne_zero τ
+  rw [discriminant_eq_E₄_cube_sub_E₆_sq, h4, h6] at hΔ
+  norm_num at hΔ
+
+lemma jf_eq_of_E₆_eq_zero {τ : ℍ} (h6 : E₆ τ = 0) : jf τ = 1728 := by
+  have hΔ := discriminant_ne_zero τ
+  have hΔ' := discriminant_eq_E₄_cube_sub_E₆_sq τ
+  rw [h6] at hΔ'
+  have h4 : E₄ τ ^ 3 ≠ 0 := by
+    intro h
+    rw [h] at hΔ'
+    norm_num at hΔ'
+    exact hΔ hΔ'
+  simp only [jf]
+  rw [div_eq_iff hΔ, hΔ']
+  ring
+
+end JM
+
+section JREG
+
+variable (Γ : Subgroup SL(2, ℤ))
+
+theorem le_SL : ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) ≤ 𝒮ℒ :=
+  Subgroup.map_le_range _ _
+
+def restrict {F : Type*} [FunLike F ℍ ℂ] {Γ Γ' : Subgroup (GL (Fin 2) ℝ)} (hle : Γ' ≤ Γ)
+    {k : ℤ} (f : F) [ModularFormClass F Γ k] : ModularForm Γ' k where
+  toFun := f
+  slash_action_eq' γ hγ := SlashInvariantFormClass.slash_action_eq f γ (hle hγ)
+  holo' := ModularFormClass.holo f
+  bdd_at_cusps' hc := ModularFormClass.bdd_at_cusps f (hc.mono hle)
+
+@[scoped simp]
+theorem coe_restrict {F : Type*} [FunLike F ℍ ℂ] {Γ Γ' : Subgroup (GL (Fin 2) ℝ)}
+    (hle : Γ' ≤ Γ) {k : ℤ} (f : F) [ModularFormClass F Γ k] :
+    ((restrict hle f : ModularForm Γ' k) : ℍ → ℂ) = f := rfl
+
+def G : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12 :=
+  restrict (le_SL Γ) (ModularForm.mcast (by decide) (ModularForm.E₄.pow 3))
+
+def H : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12 :=
+  restrict (le_SL Γ) CuspForm.discriminant
+
+theorem coe_G : ((G Γ : ModularForm _ 12) : ℍ → ℂ) =
+    ((ModularForm.E₄.pow 3 : ModularForm 𝒮ℒ (3 * 4)) : ℍ → ℂ) := rfl
+
+theorem G_apply (z : ℍ) : (G Γ : ℍ → ℂ) z = (E₄ : ℍ → ℂ) z ^ 3 := by
+  rw [coe_G, ModularForm.coe_pow, Pi.pow_apply]
+
+theorem coe_H : ((H Γ : ModularForm _ 12) : ℍ → ℂ) = ModularForm.discriminant := rfl
+
+theorem H_apply_ne_zero (z : ℍ) : (H Γ : ℍ → ℂ) z ≠ 0 := by
+  rw [coe_H]
+  exact ModularForm.discriminant_ne_zero z
+
+abbrev qL {k : ℤ} (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) : LaurentSeries ℂ :=
+  ((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+
+theorem one_mem_strictPeriods [hT : Fact (ModularGroup.T ∈ Γ)] :
+    (1 : ℝ) ∈ ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  rw [Subgroup.mem_strictPeriods_iff]
+  refine ⟨ModularGroup.T, hT.out, ?_⟩
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp [ModularGroup.T, Matrix.GeneralLinearGroup.upperRightHom]
+
+theorem one_mem_strictPeriods_SL : (1 : ℝ) ∈ (𝒮ℒ : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  simp
+
+theorem qL_ne_zero [hT : Fact (ModularGroup.T ∈ Γ)] {k : ℤ}
+    (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hf : f ≠ 0) : qL Γ f ≠ 0 := by
+  intro h
+  apply hf
+  rw [← ModularForm.qExpansion_eq_zero_iff one_pos (one_mem_strictPeriods Γ)]
+  apply (HahnSeries.ofPowerSeries_injective (Γ := ℤ) (R := ℂ))
+  simpa [qL] using h
+
+theorem H_ne_zero : H Γ ≠ 0 := by
+  intro h
+  have := congrArg (fun f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12 => (f : ℍ → ℂ) I) h
+  exact H_apply_ne_zero Γ I (by simpa using this)
+
+theorem qL_G : qL Γ (G Γ) =
+    ((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) ^ 3 := by
+  have h : qExpansion 1 ((G Γ : ModularForm _ 12) : ℍ → ℂ) =
+      (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) ^ 3 := by
+    rw [coe_G, ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+  rw [qL, h, PowerSeries.coe_pow]
+
+theorem qL_H : qL Γ (H Γ) =
+    ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) :=
+  rfl
+
+theorem jqModC_mul_qL_H [hT : Fact (ModularGroup.T ∈ Γ)] :
+    jqModC ℂ * qL Γ (H Γ) = qL Γ (G Γ) := by
+  rw [jqModC_eq_qExpansion_E4_cube_div_discriminant, qL_G, ← qL_H Γ]
+  exact div_mul_cancel₀ _ (qL_ne_zero Γ (H Γ) (H_ne_zero Γ))
+
+theorem qL_G_sub_smul_H [hT : Fact (ModularGroup.T ∈ Γ)] (c : ℂ) :
+    qL Γ (G Γ - c • H Γ) = qL Γ (G Γ) - HahnSeries.C c * qL Γ (H Γ) := by
+  simp only [qL]
+  rw [FunLike.coe_sub, ModularForm.qExpansion_sub one_pos (one_mem_strictPeriods Γ) (G Γ) (c • H Γ),
+    PowerSeries.coe_sub, FunLike.coe_smul,
+    ModularForm.qExpansion_smul one_pos (one_mem_strictPeriods Γ) c (H Γ), PowerSeries.coe_smul,
+    HahnSeries.C_mul_eq_smul]
+
+theorem jqModC_sub_mul_qL_H [hT : Fact (ModularGroup.T ∈ Γ)] (c : ℂ) :
+    (jqModC ℂ - HahnSeries.C c) * qL Γ (H Γ) = qL Γ (G Γ - c • H Γ) := by
+  rw [sub_mul, jqModC_mul_qL_H, qL_G_sub_smul_H]
+
+theorem realizeOf_jqModC_sub [hT : Fact (ModularGroup.T ∈ Γ)] (c : ℂ) (z : ℍ) :
+    realizeOf Γ (jqModC ℂ - HahnSeries.C c) z = (E₄ : ℍ → ℂ) z ^ 3 / ModularForm.discriminant z - c
+      := by
+  rw [ModularCurve.realizeOf_eq_div Γ hT.out (G Γ - c • H Γ) (H Γ) _ (jqModC_sub_mul_qL_H Γ c) z
+    (H_apply_ne_zero Γ z)]
+  have hH : (H Γ : ℍ → ℂ) z ≠ 0 := H_apply_ne_zero Γ z
+  rw [show ((G Γ - c • H Γ : ModularForm _ 12) : ℍ → ℂ) z = (G Γ : ℍ → ℂ) z - c * (H Γ : ℍ → ℂ) z by
+    rw [FunLike.coe_sub, Pi.sub_apply, FunLike.coe_smul, Pi.smul_apply, smul_eq_mul],
+    sub_div, mul_div_cancel_right₀ _ hH, G_apply, coe_H]
+
+end JREG
+
+section Main
+
+variable (M : ℕ) [NeZero M]
+
+theorem order_jqModC' (κ : Type) [Field κ] : (jqModC κ).order = -1 := by
+  have hu : (HahnSeries.ofPowerSeries ℤ κ (jNum.map (Int.castRingHom κ))) ≠ 0 := by
+    intro h
+    have := congrArg (fun x : LaurentSeries κ => x.coeff 0) h
+    simp only [HahnSeries.coeff_zero] at this
+    rw [show (0:ℤ) = ((0:ℕ):ℤ) from rfl, HahnSeries.ofPowerSeries_apply_coeff,
+      PowerSeries.coeff_map,
+      PowerSeries.coeff_zero_eq_constantCoeff, constantCoeff_jNum] at this
+    simp at this
+  have hu0 : (HahnSeries.ofPowerSeries ℤ κ (jNum.map (Int.castRingHom κ))).order = 0 := by
+    apply le_antisymm
+    · apply HahnSeries.order_le_of_coeff_ne_zero
+      rw [show (0:ℤ) = ((0:ℕ):ℤ) from rfl, HahnSeries.ofPowerSeries_apply_coeff,
+        PowerSeries.coeff_map,
+        PowerSeries.coeff_zero_eq_constantCoeff, constantCoeff_jNum]
+      simp
+    · rw [HahnSeries.le_order_iff_forall hu]
+      intro k hk
+      exact ModularCurve.ofPowerSeries_coeff_of_neg _ hk
+  rw [jqModC, HahnSeries.order_mul (by simp) hu, hu0, HahnSeries.order_single one_ne_zero, add_zero]
+
+omit [NeZero M] in
+theorem T_mem_Gamma1 : ModularGroup.T ∈ CongruenceSubgroup.Gamma1 M := by
+  rw [CongruenceSubgroup.Gamma1_mem]
+  simp [ModularGroup.coe_T]
+
+omit [NeZero M] in
+theorem exists_coe_eq_jqModC :
+    ∃ y : laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)),
+      (y : LaurentSeries ℂ) = jqModC ℂ := by
+  obtain ⟨k, A, B, pA, pB, hA, hB, hB0, hjq⟩ :=
+    ModularCurve.jqModC_mem_intFormRatiosC ℚ (CongruenceSubgroup.Gamma1 M)
+  have hmem : jqModC ℚ ∈ qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M) := by
+    rw [hjq]
+    exact intFormRatiosC_subset ℚ _ (mem_intFormRatiosC A B hA hB hB0)
+  refine ⟨⟨coeffEmb ℂ (jqModC ℚ), coeffEmb_mem_laurentBaseChange ℂ hmem⟩, ?_⟩
+  change coeffEmb ℂ (jqModC ℚ) = jqModC ℂ
+  rw [coeffEmb]
+  exact map_jqModC (algebraMap ℚ ℂ)
+
+end Main
+
+end ModularCurve.RamOne
+end
+
+open UpperHalfPlane ModularForm ModularGroup _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_ComplexPlaceDictionaryOf_ramification_eq_one_gamma1.ModularCurve
+  ModularCurve.RamOne in
+open scoped MatrixGroups Modular in
+theorem solution
+    (M : ℕ) [NeZero M] (hM : 4 ≤ M)
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ))
+    (hF : F₀ = ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))
+    (D : ModularCurve.ComplexPlaceDictionaryOf (CongruenceSubgroup.Gamma1 M) F₀)
+    (τ : UpperHalfPlane) :
+    D.ramification τ = 1 := by
+  classical
+  subst hF
+  have : Fact (ModularGroup.T ∈ CongruenceSubgroup.Gamma1 M) := ⟨T_mem_Gamma1 M⟩
+  obtain ⟨y, hy⟩ := exists_coe_eq_jqModC M
+  set c : ℂ := (ModularForm.E₄ : ℍ → ℂ) τ ^ 3 / ModularForm.discriminant τ with hc
+  set x := y - algebraMap ℂ _ c with hxdef
+  have hxcoe : (x : LaurentSeries ℂ) = jqModC ℂ - HahnSeries.C c := by
+    rw [hxdef, AddSubgroupClass.coe_sub, hy,
+      show ((algebraMap ℂ ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1
+      M))) c :
+          ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))) :
+      LaurentSeries ℂ) =
+        algebraMap ℂ (LaurentSeries ℂ) c from rfl,
+      algebraMap_laurentSeries_eq_single, HahnSeries.C_apply]
+  have hx0 : x ≠ 0 := by
+    intro h0
+    have h1 : (jqModC ℂ - HahnSeries.C c).coeff (-1) = 0 := by
+      rw [← hxcoe, h0, ZeroMemClass.coe_zero, HahnSeries.coeff_zero]
+    rw [HahnSeries.coeff_sub, HahnSeries.C_apply, HahnSeries.coeff_single_of_ne (by
+      norm_num : (-1 : ℤ) ≠ 0),
+      sub_zero] at h1
+    have hord := order_jqModC' ℂ
+    have hne : jqModC ℂ ≠ 0 := by
+      intro h; rw [h, HahnSeries.order_zero] at hord; norm_num at hord
+    have := mt HahnSeries.coeff_order_eq_zero.mp hne
+    rw [hord] at this
+    exact this h1
+  have hkey : ((D.ramification τ : ℤ) * (D.pt τ).ord x : ℤ) =
+      ((Nat.card (MulAction.stabilizer SL(2, ℤ) τ) / 2 : ℕ) : ℤ) := by
+    have h := D.meromorphicOrderAt_realizeOf τ x hx0
+    have hfun : (fun z : ℂ => realizeOf (CongruenceSubgroup.Gamma1 M) (x : LaurentSeries ℂ)
+      (ofComplex z)) =
+        (fun z : ℂ => (ModularForm.E₄ : ℍ → ℂ) (ofComplex z) ^ 3 / ModularForm.discriminant
+          (ofComplex z)
+          - (ModularForm.E₄ : ℍ → ℂ) τ ^ 3 / ModularForm.discriminant τ) := by
+      funext z
+      rw [hxcoe, realizeOf_jqModC_sub]
+    rw [hfun,
+      ModularCurve.meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two
+      τ] at h
+    exact_mod_cast h.symm
+  have he : 0 < D.ramification τ := D.ramification_pos τ
+  rcases orbit_trichotomy τ with ⟨γ, rfl⟩ | ⟨γ, rfl⟩ | hgen
+  · rw [natCard_stabilizer_smul, natCard_stabilizer_I] at hkey
+    have hcval : c = 1728 := by
+      rw [hc]
+      have := jf_eq_of_E₆_eq_zero ((E₆_smul_eq_zero_iff γ _).mpr E₆_I)
+      exact this
+    have hx' : x = y - 1728 := by
+      rw [hxdef, hcval, map_ofNat]
+    rw [hx'] at hkey
+    have hpos : 0 < (D.pt (γ • UpperHalfPlane.I)).ord (y - 1728) :=
+      (mul_pos_iff_of_pos_left (show (0 : ℤ) < D.ramification (γ • UpperHalfPlane.I) by
+        exact_mod_cast he)).mp
+        (by rw [hkey]; norm_num)
+    have h2 :=
+      (ModularCurve.ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1 ℂ M hM y
+        hy).2
+      _ hpos
+    rw [h2] at hkey
+    norm_num at hkey
+    exact_mod_cast hkey
+  · rw [natCard_stabilizer_smul, natCard_stabilizer_ρ] at hkey
+    have hcval : c = 0 := by
+      have h4 := (E₄_smul_eq_zero_iff γ _).mpr E₄_ρ
+      rw [hc, h4, zero_pow three_ne_zero, zero_div]
+    have hx' : x = y := by rw [hxdef, hcval, map_zero, sub_zero]
+    rw [hx'] at hkey
+    have hpos : 0 < (D.pt (γ • ρ)).ord y :=
+      (mul_pos_iff_of_pos_left (show (0 : ℤ) < D.ramification (γ • ρ) by exact_mod_cast he)).mp
+        (by rw [hkey]; norm_num)
+    have h3 :=
+      (ModularCurve.ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1 ℂ M hM y
+        hy).1
+      _ hpos
+    rw [h3] at hkey
+    norm_num at hkey
+    exact_mod_cast hkey
+  · rw [natCard_stabilizer_eq_two hgen] at hkey
+    norm_num at hkey
+    have h1 : (D.ramification τ : ℤ) = 1 := Int.eq_one_of_mul_eq_one_right (by positivity) hkey
+    exact_mod_cast h1
+
+end S_ModularCurve_ComplexPlaceDictionaryOf_ramification_eq_one_gamma1
+end P2MW
+export P2MW.S_ModularCurve_ComplexPlaceDictionaryOf_ramification_eq_one_gamma1 (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem ModularCurve.ComplexPlaceDictionaryOf.ramification_eq_one_gamma1
+    (M : ℕ) [NeZero M] (hM : 4 ≤ M)
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ))
+    (hF : F₀ = ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))
+    (D : ModularCurve.ComplexPlaceDictionaryOf (CongruenceSubgroup.Gamma1 M) F₀)
+    (τ : UpperHalfPlane) :
+    D.ramification τ = 1 :=
+  solution M hM F₀ hF D τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_CuspSpace_card_cuspSpace_eq_cuspCount.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_CuspSpace_card_cuspSpace_eq_cuspCount.lean
new file mode 100644
index 0000000000..77131d6b7e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_CuspSpace_card_cuspSpace_eq_cuspCount.lean
@@ -0,0 +1,119 @@
+/-
+Based on Prove2Me node ModularCurve.CuspSpace.card_cuspSpace_eq_cuspCount
+(64ad9f87-b150-5ecf-b3a9-63fad04f9afe) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b17bf4a0-4372-5461-84de-9c063fcbef3b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CuspSpace
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_CuspSpace_classification
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Number of cusps of Γ₀(N) equals sum_{d∣ N}φ(gcd(d,N/d))
+
+Theorem statement: `ModularCurve.CuspSpace.card_cuspSpace_eq_cuspCount`
+(`64ad9f87-b150-5ecf-b3a9-63fad04f9afe`), by Claude, 2026-09-05.
+
+Proof: submission `b17bf4a0-4372-5461-84de-9c063fcbef3b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number with $N \neq 0$. Consider the subgroup $\Gamma_0(N)$ of
+$\mathrm{SL}_2(\mathbb{Z})$, pushed forward along the map to $\mathrm{GL}_2(\mathbb{Q})$, so that
+`Gamma0Q N` is its image as a subgroup of $\mathrm{GL}_2(\mathbb{Q})$; this group acts on the
+one-point compactification `OnePoint ℚ` of $\mathbb{Q}$, i.e. on $\mathbb{P}^1(\mathbb{Q})$
+presented as $\mathbb{Q} \cup \{\infty\}$. The type [`ModularCurve.CuspSpace
+N`](def/ModularCurve_CuspSpace.html#L103) is the quotient of $\mathbb{P}^1(\mathbb{Q})$ by the orbit
+relation for this action, that is the set of cusps $\Gamma_0(N) \backslash
+\mathbb{P}^1(\mathbb{Q})$. The assertion is that the cardinality of this quotient, taken as a
+natural number via `Nat.card`, equals $$\mathrm{cuspCount}(N) = \sum_{d \mid N} \varphi\bigl(\gcd(d,
+N/d)\bigr),$$ the sum being over the positive divisors $d$ of $N$ and $\varphi$ the Euler totient
+function; in particular the quotient is finite, since `Nat.card` of an infinite type would be $0$
+while the right-hand side is positive.
+
+This is the classical count of the cusps of the modular curve $X_0(N)$, $\nu_\infty(N) = \sum_{d
+\mid N} \varphi(\gcd(d, N/d))$. It feeds the numerical input for the genus computations and related
+estimates for $X_0(N)$, being used for the count of orbits of the unipotent subgroup generated by
+$T$ and for the bound on the rank of the space of parabolic homomorphisms in terms of the genus
+formula.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_CuspSpace_card_cuspSpace_eq_cuspCount.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_CuspSpace_card_cuspSpace_eq_cuspCount
+
+open Matrix Matrix.SpecialLinearGroup OnePoint CongruenceSubgroup
+open scoped MatrixGroups
+p2m_open "ModularCurve P2MW.S_ModularCurve_CuspSpace_card_cuspSpace_eq_cuspCount.ModularCurve \
+  ModularCurve.CuspSpace \
+  P2MW.S_ModularCurve_CuspSpace_card_cuspSpace_eq_cuspCount.ModularCurve.CuspSpace"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "CuspSpace cuspCount CuspSpace.classification"
+namespace CuspSpace
+p2m_export "ModularCurve.CuspSpace" "Classification classification"
+p2m_open "ModularCurve.CuspSpace ModularCurve"
+
+open Finset
+
+variable {N : ℕ}
+
+theorem card_sigma_units :
+    Nat.card ((d : N.divisors) × (ZMod (Nat.gcd d (N / (d : ℕ))))ˣ) = cuspCount N := by
+  have hgcd : ∀ d : N.divisors, NeZero (Nat.gcd (d : ℕ) (N / (d : ℕ))) := by
+    rintro ⟨d, hd⟩
+    rw [Nat.mem_divisors] at hd
+    exact ⟨(Nat.gcd_pos_of_pos_left _ (Nat.pos_of_ne_zero
+      (fun h => hd.2 (Nat.eq_zero_of_zero_dvd (h ▸ hd.1))))).ne'⟩
+  rw [Nat.card_sigma]
+  simp only [cuspCount]
+  rw [← Finset.sum_attach N.divisors fun d => Nat.totient (Nat.gcd d (N / d)),
+    ← Finset.univ_eq_attach]
+  refine Finset.sum_congr rfl fun d _ => ?_
+  have := hgcd d
+  rw [Nat.card_eq_fintype_card, ZMod.card_units_eq_totient]
+
+theorem card_eq_cuspCount_of_classification (hcl : Classification N) :
+    Nat.card (CuspSpace N) = cuspCount N := by
+  obtain ⟨e⟩ := hcl
+  rw [Nat.card_congr e, card_sigma_units]
+
+end ModularCurve.CuspSpace
+
+theorem solution {N : ℕ} (hN : N ≠ 0) :
+    Nat.card (ModularCurve.CuspSpace N) = ModularCurve.cuspCount N :=
+  ModularCurve.CuspSpace.card_eq_cuspCount_of_classification (ModularCurve.CuspSpace.classification
+    hN)
+
+end S_ModularCurve_CuspSpace_card_cuspSpace_eq_cuspCount
+end P2MW
+export P2MW.S_ModularCurve_CuspSpace_card_cuspSpace_eq_cuspCount (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open OnePoint
+theorem ModularCurve.CuspSpace.card_cuspSpace_eq_cuspCount {N : ℕ} (hN : N ≠ 0) :
+    Nat.card (ModularCurve.CuspSpace N) = ModularCurve.cuspCount N :=
+  solution hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_CuspSpace_classification.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_CuspSpace_classification.lean
new file mode 100644
index 0000000000..f1b74fccc9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_CuspSpace_classification.lean
@@ -0,0 +1,238 @@
+/-
+Based on Prove2Me node ModularCurve.CuspSpace.classification
+(21f1ac5a-0bf2-5001-b80d-4ad0892d4673) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 79a773fd-9238-5daa-8ef6-32fec4b53a91
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CuspSpace
+
+import Mathlib.Data.ZMod.Units
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_CuspSpace_exists_normalForm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_CuspSpace_normalFormCriterion
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Classification of the cusps of Γ₀(N)
+
+Theorem statement: `ModularCurve.CuspSpace.classification` (`21f1ac5a-0bf2-5001-b80d-4ad0892d4673`),
+by Claude, 2026-09-05.
+
+Proof: submission `79a773fd-9238-5daa-8ef6-32fec4b53a91`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+For a natural number $N$ with $N \neq 0$, the predicate [`ModularCurve.CuspSpace.Classification
+N`](def/ModularCurve_CuspSpace.html#L258) holds, that is: there exists a bijection between the cusp
+space of level $N$ and the dependent sum, over the divisors $d$ of $N$, of the unit groups
+$(\mathbb{Z}/\gcd(d, N/d))^{\times}$. Here the cusp space [`ModularCurve.CuspSpace
+N`](def/ModularCurve_CuspSpace.html#L103) is the quotient of $\mathbb{P}^1(\mathbb{Q})$, realised as
+the one-point extension `OnePoint ℚ` of $\mathbb{Q}$, by the orbit equivalence relation for the
+action of the subgroup `Gamma0Q N` of $\mathrm{GL}_2(\mathbb{Q})$, namely the image of the
+congruence subgroup $\Gamma_0(N) \le \mathrm{SL}_2(\mathbb{Z})$ under the map `mapGL ℚ` into
+$\mathrm{GL}_2(\mathbb{Q})$; the indexing type on the right is `N.divisors`, the divisors of $N$,
+and for each such $d$ the fibre is the group of units of $\mathbb{Z}/\gcd(d, N/d)\mathbb{Z}$. The
+conclusion is the nonemptiness of the type of such equivalences, so it asserts the existence of a
+bijection rather than exhibiting a designated one; in particular no compatibility of the bijection
+with the denominator $d$ or the numerator residue is part of the assertion.
+
+This is the classical count and classification of the cusps of $\Gamma_0(N)$, by a denominator
+divisor $d \mid N$ together with a numerator class in $(\mathbb{Z}/\gcd(d,N/d))^{\times}$
+(Diamond–Shurman, Prop. 3.8.3). It is obtained from the normal-form results for points of
+$\mathbb{P}^1(\mathbb{Q})$ modulo $\Gamma_0(N)$ and is used to compute the cardinality of the cusp
+space, in
+[`ModularCurve.CuspSpace.card_cuspSpace_eq_cuspCount`]
+(thm.html#ModularCurve.CuspSpace.card_cuspSpace_eq_cuspCount).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_CuspSpace_classification.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_CuspSpace_classification
+
+open Matrix Matrix.SpecialLinearGroup OnePoint CongruenceSubgroup
+open scoped MatrixGroups
+p2m_open "ModularCurve P2MW.S_ModularCurve_CuspSpace_classification.ModularCurve \
+  ModularCurve.CuspSpace P2MW.S_ModularCurve_CuspSpace_classification.ModularCurve.CuspSpace"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "ratPoint CuspSpace CuspSpace.Classification CuspSpace.exists_normalForm \
+  CuspSpace.normalFormCriterion"
+namespace CuspSpace
+p2m_export "ModularCurve.CuspSpace" "mk cuspDenom cuspDenom_mk_ratPoint cuspDenom_dvd \
+  NormalFormCriterion Classification exists_normalForm normalFormCriterion"
+p2m_open "ModularCurve.CuspSpace ModularCurve"
+
+variable {N : ℕ}
+
+lemma exists_dvd_sub_and_isCoprime {M : ℤ} (hM : M ≠ 0) {s₀ : ℤ} (hs₀ : IsCoprime s₀ M)
+    {e : ℕ} (he : e ≠ 0) : ∃ s : ℤ, M ∣ s - s₀ ∧ IsCoprime s (e : ℤ) := by
+  set m : ℕ := M.natAbs with hm
+  have hm0 : m ≠ 0 := Int.natAbs_ne_zero.mpr hM
+  have : NeZero (m * e) := ⟨by positivity⟩
+  have hcop : IsCoprime s₀ ((m : ℕ) : ℤ) := by
+    rwa [Int.isCoprime_iff_gcd_eq_one, hm, Int.gcd, Int.natAbs_natCast, ← Int.gcd,
+      ← Int.isCoprime_iff_gcd_eq_one]
+  have hunit : IsUnit ((s₀ : ZMod m)) :=
+    .of_mul_eq_one _ (ZMod.coe_int_mul_inv_eq_one hcop)
+  obtain ⟨S, hS⟩ := ZMod.unitsMap_surjective (n := m) (Nat.dvd_mul_right m e) hunit.unit
+  refine ⟨((S : ZMod (m * e)).val : ℤ), ?_, ?_⟩
+  · have h1 : (((S : ZMod (m * e)).val : ℤ) : ZMod m) = ((s₀ : ZMod m)) := by
+      have h2 : ZMod.castHom (Nat.dvd_mul_right m e) (ZMod m) (S : ZMod (m * e))
+          = (s₀ : ZMod m) := by
+        have := congrArg Units.val hS
+        rwa [ZMod.unitsMap_def, Units.coe_map, IsUnit.unit_spec] at this
+      rw [Int.cast_natCast, ZMod.natCast_val, ← ZMod.castHom_apply (h := Nat.dvd_mul_right m e)]
+      exact h2
+    rw [ZMod.intCast_eq_intCast_iff_dvd_sub] at h1
+    have h4 : (m : ℤ) ∣ ((S : ZMod (m * e)).val : ℤ) - s₀ := by
+      simpa [neg_sub] using dvd_neg.mpr h1
+    exact Int.natAbs_dvd.mp h4
+  · have h3 : Nat.Coprime (S : ZMod (m * e)).val (m * e) := ZMod.val_coe_unit_coprime S
+    exact (Nat.isCoprime_iff_coprime.mpr h3).of_isCoprime_of_dvd_right
+      (by exact_mod_cast dvd_mul_left e m)
+
+noncomputable def normalNumerator (hN : N ≠ 0) (x : CuspSpace N) : ℤ :=
+  (ModularCurve.CuspSpace.exists_normalForm hN x).choose
+
+lemma isCoprime_normalNumerator (hN : N ≠ 0) (x : CuspSpace N) :
+    IsCoprime (normalNumerator hN x) (cuspDenom N x : ℤ) :=
+  (ModularCurve.CuspSpace.exists_normalForm hN x).choose_spec.1
+
+lemma mk_ratPoint_normalNumerator (hN : N ≠ 0) (x : CuspSpace N) :
+    x = mk N (ratPoint (normalNumerator hN x) (cuspDenom N x)) :=
+  (ModularCurve.CuspSpace.exists_normalForm hN x).choose_spec.2
+
+lemma isUnit_intCast_of_isCoprime {d : ℕ} {a : ℤ} (ha : IsCoprime a (d : ℤ)) :
+    IsUnit ((a : ZMod (Nat.gcd d (N / d)))) := by
+  have hga : IsCoprime a ((Nat.gcd d (N / d) : ℕ) : ℤ) :=
+    ha.of_isCoprime_of_dvd_right (Int.natCast_dvd_natCast.mpr (Nat.gcd_dvd_left d (N / d)))
+  exact .of_mul_eq_one _ (ZMod.coe_int_mul_inv_eq_one hga)
+
+lemma exists_intCast_eq_unit {d : ℕ} (hd0 : d ≠ 0)
+    (u : (ZMod (Nat.gcd d (N / d)))ˣ) :
+    ∃ s : ℤ, IsCoprime s (d : ℤ) ∧
+      ((s : ZMod (Nat.gcd d (N / d)))) = (u : ZMod (Nat.gcd d (N / d))) := by
+  have hg0 : Nat.gcd d (N / d) ≠ 0 := (Nat.gcd_pos_of_pos_left _ (Nat.pos_of_ne_zero hd0)).ne'
+  have : NeZero (Nat.gcd d (N / d)) := ⟨hg0⟩
+  have hval : Nat.Coprime ((u : ZMod (Nat.gcd d (N / d)))).val (Nat.gcd d (N / d)) :=
+    ZMod.val_coe_unit_coprime u
+  have hvalZ : IsCoprime (((u : ZMod (Nat.gcd d (N / d)))).val : ℤ)
+      ((Nat.gcd d (N / d) : ℕ) : ℤ) :=
+    Nat.isCoprime_iff_coprime.mpr hval
+  obtain ⟨s, hs_mod, hs_cop⟩ :=
+    exists_dvd_sub_and_isCoprime (M := ((Nat.gcd d (N / d) : ℕ) : ℤ))
+      (by exact_mod_cast hg0) hvalZ hd0
+  refine ⟨s, hs_cop, ?_⟩
+  have h1 : ((((u : ZMod (Nat.gcd d (N / d)))).val : ℤ) : ZMod (Nat.gcd d (N / d)))
+      = (s : ZMod (Nat.gcd d (N / d))) :=
+    (ZMod.intCast_eq_intCast_iff_dvd_sub _ _ _).mpr hs_mod
+  rw [← h1]
+  push_cast
+  simp [ZMod.natCast_val, ZMod.cast_id]
+
+noncomputable def fiberToUnits (hN : N ≠ 0) {d : ℕ}
+    (x : {x : CuspSpace N // cuspDenom N x = d}) : (ZMod (Nat.gcd d (N / d)))ˣ :=
+  (isUnit_intCast_of_isCoprime (x.2 ▸ isCoprime_normalNumerator hN x.1)).unit
+
+@[scoped simp] lemma val_fiberToUnits (hN : N ≠ 0) {d : ℕ}
+    (x : {x : CuspSpace N // cuspDenom N x = d}) :
+    (fiberToUnits hN x : ZMod (Nat.gcd d (N / d)))
+      = ((normalNumerator hN x.1 : ℤ) : ZMod (Nat.gcd d (N / d))) :=
+  IsUnit.unit_spec _
+
+lemma eq_mk_ratPoint_normalNumerator (hN : N ≠ 0) {d : ℕ}
+    (x : {x : CuspSpace N // cuspDenom N x = d}) :
+    x.1 = mk N (ratPoint (normalNumerator hN x.1) d) := by
+  conv_lhs => rw [mk_ratPoint_normalNumerator hN x.1]
+  rw [x.2]
+
+lemma fiberToUnits_injective (hN : N ≠ 0) (hcrit : NormalFormCriterion N) {d : ℕ}
+    (hd : d ∣ N) : Function.Injective (fiberToUnits (N := N) hN (d := d)) := by
+  intro x y hxy
+  have hx := x.2 ▸ isCoprime_normalNumerator hN x.1
+  have hy := y.2 ▸ isCoprime_normalNumerator hN y.1
+  have hval : ((normalNumerator hN x.1 : ℤ) : ZMod (Nat.gcd d (N / d)))
+      = ((normalNumerator hN y.1 : ℤ) : ZMod (Nat.gcd d (N / d))) := by
+    rw [← val_fiberToUnits hN x, ← val_fiberToUnits hN y, hxy]
+  refine Subtype.ext ?_
+  rw [eq_mk_ratPoint_normalNumerator hN x, eq_mk_ratPoint_normalNumerator hN y]
+  exact (hcrit _ _ d hd hx hy).mpr hval
+
+lemma fiberToUnits_surjective (hN : N ≠ 0) (hcrit : NormalFormCriterion N) {d : ℕ}
+    (hd : d ∣ N) : Function.Surjective (fiberToUnits (N := N) hN (d := d)) := by
+  have hd0 : d ≠ 0 := by rintro rfl; exact hN (Nat.eq_zero_of_zero_dvd hd)
+  intro u
+  obtain ⟨s, hs_cop, hs_val⟩ := exists_intCast_eq_unit hd0 u
+  have hyd : cuspDenom N (mk N (ratPoint s d)) = d := by
+    rw [cuspDenom_mk_ratPoint hs_cop, Int.gcd_natCast_natCast, Nat.gcd_eq_left hd]
+  refine ⟨⟨mk N (ratPoint s d), hyd⟩, ?_⟩
+  refine Units.ext ?_
+  rw [val_fiberToUnits]
+  have ha : IsCoprime (normalNumerator hN (mk N (ratPoint s d))) ((d : ℕ) : ℤ) := by
+    have h := isCoprime_normalNumerator hN (mk N (ratPoint s d))
+    rwa [hyd] at h
+  have hya : mk N (ratPoint (normalNumerator hN (mk N (ratPoint s d))) d)
+      = mk N (ratPoint s d) :=
+    (eq_mk_ratPoint_normalNumerator hN (⟨mk N (ratPoint s d), hyd⟩ :
+      {x : CuspSpace N // cuspDenom N x = d})).symm
+  rw [(hcrit _ _ d hd ha hs_cop).mp hya, hs_val]
+
+noncomputable def fiberEquivUnits (hN : N ≠ 0) (hcrit : NormalFormCriterion N) {d : ℕ}
+    (hd : d ∣ N) : {x : CuspSpace N // cuspDenom N x = d} ≃ (ZMod (Nat.gcd d (N / d)))ˣ :=
+  Equiv.ofBijective _
+    ⟨fiberToUnits_injective hN hcrit hd, fiberToUnits_surjective hN hcrit hd⟩
+
+variable (N) in
+noncomputable def cuspDenomDvd (hN : N ≠ 0) (x : CuspSpace N) : N.divisors :=
+  ⟨cuspDenom N x, Nat.mem_divisors.mpr ⟨cuspDenom_dvd x, hN⟩⟩
+
+@[scoped simp] lemma cuspDenomDvd_coe (hN : N ≠ 0) (x : CuspSpace N) :
+    (cuspDenomDvd N hN x : ℕ) = cuspDenom N x := rfl
+
+theorem classification_of_normalFormCriterion (hN : N ≠ 0)
+    (hcrit : NormalFormCriterion N) : Classification N := by
+  refine ⟨(Equiv.sigmaFiberEquiv (cuspDenomDvd N hN)).symm.trans
+    (Equiv.sigmaCongrRight fun d => ?_)⟩
+  refine (Equiv.subtypeEquivRight fun x => ?_).trans
+    (fiberEquivUnits hN hcrit (Nat.mem_divisors.mp d.2).1)
+  rw [Subtype.ext_iff, cuspDenomDvd_coe]
+
+end ModularCurve.CuspSpace
+end
+
+theorem solution {N : ℕ} (hN : N ≠ 0) :
+    ModularCurve.CuspSpace.Classification N :=
+  ModularCurve.CuspSpace.classification_of_normalFormCriterion hN
+    (ModularCurve.CuspSpace.normalFormCriterion hN)
+
+end S_ModularCurve_CuspSpace_classification
+end P2MW
+export P2MW.S_ModularCurve_CuspSpace_classification (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open OnePoint
+theorem ModularCurve.CuspSpace.classification {N : ℕ} (hN : N ≠ 0) :
+    ModularCurve.CuspSpace.Classification N :=
+  solution hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_CuspSpace_exists_normalForm.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_CuspSpace_exists_normalForm.lean
new file mode 100644
index 0000000000..961d3e2200
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_CuspSpace_exists_normalForm.lean
@@ -0,0 +1,180 @@
+/-
+Based on Prove2Me node ModularCurve.CuspSpace.exists_normalForm
+(cb606138-7b7a-5f4f-b98f-8a06b99ca877) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ff0928f6-217a-5f25-b790-9935e84068a2
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CuspSpace
+
+import Mathlib.Data.ZMod.Units
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Normal form for a cusp of Γ₀(N)
+
+Theorem statement: `ModularCurve.CuspSpace.exists_normalForm`
+(`cb606138-7b7a-5f4f-b98f-8a06b99ca877`), by Claude, 2026-09-05.
+
+Proof: submission `ff0928f6-217a-5f25-b790-9935e84068a2`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a non-zero natural number and let $x$ be a point of [`ModularCurve.CuspSpace
+N`](def/ModularCurve_CuspSpace.html#L103), that is, an element of the orbit space of
+$\mathbb{P}^1(\mathbb{Q})$ (realised as `OnePoint ℚ`) under `Gamma0Q N`, the image of $\Gamma_0(N)$
+in $\mathrm{GL}_2(\mathbb{Q})$ under `mapGL ℚ`. Write $d =$ `cuspDenom N x` for the natural number
+attached to the orbit of $x$ by the orbit-invariant function sending $\infty$ to $N$ and a rational
+$q$ to $\gcd(\mathrm{den}\, q, N)$. The assertion is that there exists an integer $a$ such that $a$
+and $d$ are coprime in $\mathbb{Z}$ in the Bézout sense (some $\mathbb{Z}$-combination of $a$ and
+$d$ equals $1$) and such that $x$ is the orbit [`ModularCurve.CuspSpace.mk
+N`](def/ModularCurve_CuspSpace.html#L107) of the point [`ModularCurve.ratPoint a
+d`](def/ModularCurve_CuspSpace.html#L11), which is $\infty$ if $d = 0$ and the image of $a/d \in
+\mathbb{Q}$ in $\mathbb{P}^1(\mathbb{Q})$ otherwise. Thus every cusp of $\Gamma_0(N)$ is represented
+by $a/d$ with $d$ its denominator invariant and $a$ coprime to $d$.
+
+This is the existence (surjectivity) half of the classical normal-form description of the cusps of
+$\Gamma_0(N)$, in which a cusp is presented as $a/d$ with $d \mid N$ the denominator invariant and
+$\gcd(a,d) = 1$. It is used in the classification of `CuspSpace N` and in the verification that a
+Hecke operator acts as expected on parabolic homomorphisms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_CuspSpace_exists_normalForm.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_CuspSpace_exists_normalForm
+
+open Matrix Matrix.SpecialLinearGroup OnePoint CongruenceSubgroup
+open scoped MatrixGroups
+p2m_open "ModularCurve P2MW.S_ModularCurve_CuspSpace_exists_normalForm.ModularCurve \
+  ModularCurve.CuspSpace P2MW.S_ModularCurve_CuspSpace_exists_normalForm.ModularCurve.CuspSpace"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "ratPoint exists_ratPoint_eq mapGL_smul_ratPoint isCoprime_smul_pair \
+  CuspSpace CuspSpace.mk CuspSpace.cuspDenom"
+namespace CuspSpace
+p2m_export "ModularCurve.CuspSpace" "mk mk_surjective mk_smul cuspDenom cuspDenom_mk_ratPoint"
+p2m_open "ModularCurve.CuspSpace ModularCurve"
+
+variable {N : ℕ}
+
+lemma exists_dvd_sub_and_isCoprime {M : ℤ} (hM : M ≠ 0) {s₀ : ℤ} (hs₀ : IsCoprime s₀ M)
+    {e : ℕ} (he : e ≠ 0) : ∃ s : ℤ, M ∣ s - s₀ ∧ IsCoprime s (e : ℤ) := by
+  set m : ℕ := M.natAbs with hm
+  have hm0 : m ≠ 0 := Int.natAbs_ne_zero.mpr hM
+  have : NeZero (m * e) := ⟨by positivity⟩
+  have hcop : IsCoprime s₀ ((m : ℕ) : ℤ) := by
+    rwa [Int.isCoprime_iff_gcd_eq_one, hm, Int.gcd, Int.natAbs_natCast, ← Int.gcd,
+      ← Int.isCoprime_iff_gcd_eq_one]
+  have hunit : IsUnit ((s₀ : ZMod m)) :=
+    .of_mul_eq_one _ (ZMod.coe_int_mul_inv_eq_one hcop)
+  obtain ⟨S, hS⟩ := ZMod.unitsMap_surjective (n := m) (Nat.dvd_mul_right m e) hunit.unit
+  refine ⟨((S : ZMod (m * e)).val : ℤ), ?_, ?_⟩
+  · have h1 : (((S : ZMod (m * e)).val : ℤ) : ZMod m) = ((s₀ : ZMod m)) := by
+      have h2 : ZMod.castHom (Nat.dvd_mul_right m e) (ZMod m) (S : ZMod (m * e))
+          = (s₀ : ZMod m) := by
+        have := congrArg Units.val hS
+        rwa [ZMod.unitsMap_def, Units.coe_map, IsUnit.unit_spec] at this
+      rw [Int.cast_natCast, ZMod.natCast_val, ← ZMod.castHom_apply (h := Nat.dvd_mul_right m e)]
+      exact h2
+    rw [ZMod.intCast_eq_intCast_iff_dvd_sub] at h1
+    have h4 : (m : ℤ) ∣ ((S : ZMod (m * e)).val : ℤ) - s₀ := by
+      simpa [neg_sub] using dvd_neg.mpr h1
+    exact Int.natAbs_dvd.mp h4
+  · have h3 : Nat.Coprime (S : ZMod (m * e)).val (m * e) := ZMod.val_coe_unit_coprime S
+    exact (Nat.isCoprime_iff_coprime.mpr h3).of_isCoprime_of_dvd_right
+      (by exact_mod_cast dvd_mul_left e m)
+
+lemma exists_row_smul_eq_gcd (hN : N ≠ 0) {a c : ℤ} (hac : IsCoprime a c) :
+    ∃ r s : ℤ, (N : ℤ) ∣ r ∧ IsCoprime r s ∧ r * a + s * c = Int.gcd c N := by
+  rcases eq_or_ne a 0 with rfl | ha
+  · have hc : IsUnit c := isCoprime_zero_left.mp hac
+    refine ⟨0, c, dvd_zero _, isCoprime_zero_left.mpr hc, ?_⟩
+    rcases Int.isUnit_iff.mp hc with rfl | rfl <;> simp
+  set d : ℕ := Int.gcd c N with hd
+  have hd0 : d ≠ 0 := by
+    have : (N : ℤ) ≠ 0 := by exact_mod_cast hN
+    exact (Int.gcd_pos_iff.mpr (Or.inr this)).ne'
+  obtain ⟨c₁, hc₁⟩ : ((d : ℤ)) ∣ c := Int.gcd_dvd_left ..
+  obtain ⟨n₁, hn₁⟩ : ((d : ℤ)) ∣ (N : ℤ) := Int.gcd_dvd_right ..
+  have hn₁0 : n₁ ≠ 0 := by
+    rintro rfl
+    rw [mul_zero] at hn₁
+    exact hN (by exact_mod_cast hn₁)
+  have hcop1 : IsCoprime c₁ n₁ := by
+    rw [Int.isCoprime_iff_gcd_eq_one]
+    have h5 : Int.gcd ((d : ℤ) * c₁) ((d : ℤ) * n₁) = d * Int.gcd c₁ n₁ := by
+      rw [Int.gcd_mul_left, Int.natAbs_natCast]
+    rw [← hc₁, ← hn₁, ← hd] at h5
+    exact Nat.eq_of_mul_eq_mul_left (Nat.pos_of_ne_zero hd0) (by rw [mul_one, ← h5])
+  have hcop2 : IsCoprime c₁ a :=
+    hac.symm.of_isCoprime_of_dvd_left ⟨(d : ℤ), by rw [hc₁]; ring⟩
+  obtain ⟨u, v, huv⟩ := hcop1.mul_right hcop2
+  have hMne : n₁ * a ≠ 0 := mul_ne_zero hn₁0 ha
+  have huM : IsCoprime u (n₁ * a) := ⟨c₁, v, by linear_combination huv⟩
+  obtain ⟨s, hsmod, hsd⟩ := exists_dvd_sub_and_isCoprime hMne huM hd0
+  obtain ⟨t, ht⟩ : (n₁ * a) ∣ s * c₁ - 1 := by
+    have h6 : s * c₁ - 1 = (s - u) * c₁ - v * (n₁ * a) := by linear_combination huv
+    rw [h6]
+    exact dvd_sub (hsmod.mul_right c₁) (dvd_mul_left _ _)
+  have hsum : -((N : ℤ) * t) * a + s * c = (d : ℤ) := by
+    have h7 : s * c - (d : ℤ) = (N : ℤ) * a * t := by
+      calc s * c - (d : ℤ) = (d : ℤ) * (s * c₁ - 1) := by rw [hc₁]; ring
+        _ = (d : ℤ) * (n₁ * a * t) := by rw [ht]
+        _ = (N : ℤ) * a * t := by rw [hn₁]; ring
+    linear_combination h7
+  refine ⟨-((N : ℤ) * t), s, ⟨-t, by ring⟩, ?_, hsum⟩
+  obtain ⟨p, q, hpq⟩ := hsd
+  exact ⟨q * a, p + q * c, by linear_combination hpq + q * hsum⟩
+
+end ModularCurve.CuspSpace
+
+theorem solution {N : ℕ} (hN : N ≠ 0) (x : ModularCurve.CuspSpace N) :
+    ∃ a : ℤ, IsCoprime a (ModularCurve.CuspSpace.cuspDenom N x : ℤ) ∧
+      x = ModularCurve.CuspSpace.mk N (ModularCurve.ratPoint a (ModularCurve.CuspSpace.cuspDenom N
+        x)) := by
+  obtain ⟨y, rfl⟩ := mk_surjective N x
+  obtain ⟨a, c, hac, rfl⟩ := exists_ratPoint_eq y
+  obtain ⟨r, s, hNr, hrs, hsum⟩ := exists_row_smul_eq_gcd hN hac
+  obtain ⟨γ, hγ10, hγ11⟩ := hrs.exists_SL2_row 1
+  have hγmem : γ ∈ Gamma0 N := Gamma0_mem_iff_dvd.mpr (by rw [hγ10]; exact hNr)
+  have hkey : mapGL ℚ γ • ratPoint a c
+      = ratPoint (γ 0 0 * a + γ 0 1 * c) (Int.gcd c N) := by
+    rw [mapGL_smul_ratPoint γ hac.ne_zero_or_ne_zero, hγ10, hγ11, hsum]
+  refine ⟨γ 0 0 * a + γ 0 1 * c, ?_, ?_⟩
+  · rw [cuspDenom_mk_ratPoint hac]
+    have h8 := isCoprime_smul_pair γ hac
+    rwa [hγ10, hγ11, hsum] at h8
+  · rw [cuspDenom_mk_ratPoint hac, ← hkey, mk_smul hγmem]
+
+end S_ModularCurve_CuspSpace_exists_normalForm
+end P2MW
+export P2MW.S_ModularCurve_CuspSpace_exists_normalForm (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open OnePoint
+theorem ModularCurve.CuspSpace.exists_normalForm {N : ℕ} (hN : N ≠ 0) (x : ModularCurve.CuspSpace N)
+    :
+    ∃ a : ℤ, IsCoprime a (ModularCurve.CuspSpace.cuspDenom N x : ℤ) ∧
+      x = ModularCurve.CuspSpace.mk N (ModularCurve.ratPoint a (ModularCurve.CuspSpace.cuspDenom N
+        x)) :=
+  solution hN x
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_CuspSpace_normalFormCriterion.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_CuspSpace_normalFormCriterion.lean
new file mode 100644
index 0000000000..c928a28f46
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_CuspSpace_normalFormCriterion.lean
@@ -0,0 +1,183 @@
+/-
+Based on Prove2Me node ModularCurve.CuspSpace.normalFormCriterion
+(77fd4deb-4fd3-5641-a54e-7708f3776079) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a27f70f4-f5f0-5f55-a4a4-6edfa4032b39
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CuspSpace
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ratPoint_eq_ratPoint_iff_of_isCoprime
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cusp normal form criterion for Γ₀(N)
+
+Theorem statement: `ModularCurve.CuspSpace.normalFormCriterion`
+(`77fd4deb-4fd3-5641-a54e-7708f3776079`), by Claude, 2026-09-05.
+
+Proof: submission `a27f70f4-f5f0-5f55-a4a4-6edfa4032b39`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number with $N \neq 0$. The assertion is the predicate
+[`ModularCurve.CuspSpace.NormalFormCriterion N`](def/ModularCurve_CuspSpace.html#L253), namely: for
+all integers $a, a'$ and every natural number $e$ dividing $N$ such that $a$ and $e$ are coprime in
+$\mathbb{Z}$ and $a'$ and $e$ are coprime in $\mathbb{Z}$, the two points of the quotient
+$\Gamma_0(N)\backslash\mathbb{P}^1(\mathbb{Q})$ determined by $(a : e)$ and $(a' : e)$ agree if and
+only if $a$ and $a'$ have the same image in $\mathbb{Z}/\gcd(e, N/e)$. Here
+$\mathbb{P}^1(\mathbb{Q})$ is realised as `OnePoint ℚ`, the point attached to a pair $(a, c)$ of
+integers is $\infty$ when $c = 0$ and the rational number $a/c$ otherwise, and the quotient is the
+orbit space for the action on `OnePoint ℚ` of the subgroup of $\mathrm{GL}_2(\mathbb{Q})$ obtained
+as the image of $\Gamma_0(N) \subseteq \mathrm{SL}_2(\mathbb{Z})$; $N/e$ is natural-number division,
+and the class map is [`ModularCurve.CuspSpace.mk`](def/ModularCurve_CuspSpace.html#L107). Since $N
+\neq 0$ and $e \mid N$, the denominator $e$ is nonzero, so both points are the rationals $a/e$ and
+$a'/e$.
+
+This is the same-denominator case of the classical classification of the cusps of $\Gamma_0(N)$
+(Diamond–Shurman, Prop. 3.8.3): cusps written in the normal form $(a : e)$ with $e \mid N$ and $a$
+coprime to $e$ coincide exactly when their numerators agree modulo $\gcd(e, N/e)$. It is used in the
+full classification of [`ModularCurve.CuspSpace`](def/ModularCurve_CuspSpace.html#L103) and, through
+that, in the computation showing that a Hecke operator minus a scalar lands in the relevant space of
+parabolic homomorphisms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_CuspSpace_normalFormCriterion.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_CuspSpace_normalFormCriterion
+
+open Matrix Matrix.SpecialLinearGroup OnePoint CongruenceSubgroup
+open scoped MatrixGroups
+p2m_open "ModularCurve P2MW.S_ModularCurve_CuspSpace_normalFormCriterion.ModularCurve \
+  ModularCurve.CuspSpace P2MW.S_ModularCurve_CuspSpace_normalFormCriterion.ModularCurve.CuspSpace"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "ratPoint mapGL_smul_ratPoint isCoprime_smul_pair CuspSpace \
+  CuspSpace.NormalFormCriterion ratPoint_eq_ratPoint_iff_of_isCoprime"
+namespace CuspSpace
+p2m_export "ModularCurve.CuspSpace" "mk mk_eq_mk_iff mk_smul NormalFormCriterion"
+p2m_open "ModularCurve.CuspSpace ModularCurve"
+
+variable {N : ℕ}
+
+lemma dvd_sub_of_smul_eq {e : ℕ} (hN : N ≠ 0) (he : e ∣ N) {A A' ε : ℤ}
+    (hε : ε = 1 ∨ ε = -1) {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 N)
+    (h0 : γ 0 0 * A + γ 0 1 * (e : ℤ) = ε * A')
+    (h1 : γ 1 0 * A + γ 1 1 * (e : ℤ) = ε * (e : ℤ)) :
+    ((Nat.gcd e (N / e) : ℕ) : ℤ) ∣ A' - A := by
+  have he0 : e ≠ 0 := by rintro rfl; exact hN (Nat.eq_zero_of_zero_dvd he)
+  have he0' : (e : ℤ) ≠ 0 := by exact_mod_cast he0
+  have hε2 : ε * ε = 1 := by rcases hε with rfl | rfl <;> norm_num
+  have hN10 : (N : ℤ) ∣ γ 1 0 := Gamma0_mem_iff_dvd.mp hγ
+  obtain ⟨r₁, hr₁⟩ : (e : ℤ) ∣ γ 1 0 := dvd_trans (by exact_mod_cast he) hN10
+  have hem : (e : ℤ) * ((N / e : ℕ) : ℤ) = (N : ℤ) := by exact_mod_cast Nat.mul_div_cancel' he
+  have hr₂ : ((N / e : ℕ) : ℤ) ∣ r₁ := by
+    have h := hN10
+    rw [hr₁, ← hem] at h
+    exact (mul_dvd_mul_iff_left he0').mp h
+  have hs : γ 1 1 = ε - r₁ * A := by
+    have h2 : (e : ℤ) * γ 1 1 = (e : ℤ) * (ε - r₁ * A) := by
+      have h := h1
+      rw [hr₁] at h
+      linear_combination h
+    exact mul_left_cancel₀ he0' h2
+  have hdet : γ 0 0 * γ 1 1 - γ 0 1 * γ 1 0 = 1 := by
+    have h := γ.property
+    rwa [Matrix.det_fin_two] at h
+  obtain ⟨k, hk⟩ : ((Nat.gcd e (N / e) : ℕ) : ℤ) ∣ r₁ :=
+    dvd_trans (by exact_mod_cast Nat.gcd_dvd_right e (N / e)) hr₂
+  obtain ⟨l, hl⟩ : ((Nat.gcd e (N / e) : ℕ) : ℤ) ∣ (e : ℤ) := by
+    exact_mod_cast Nat.gcd_dvd_left e (N / e)
+  refine ⟨ε * A' * A * k + ε * γ 0 1 * l, ?_⟩
+  linear_combination (A * r₁ - ε) * h0 + A * hdet + A * γ 0 1 * hr₁ - A * γ 0 0 * hs
+    - A' * hε2 + ε * A' * A * hk + ε * γ 0 1 * hl
+
+lemma exists_smul_ratPoint_eq {e : ℕ} (he0 : (e : ℤ) ≠ 0) (a a' q r₁ : ℤ)
+    (hq : q * (e : ℤ) = a' - a - r₁ * (a * a')) :
+    ∃ γ : SL(2, ℤ), γ 1 0 = (e : ℤ) * r₁ ∧
+      mapGL ℚ γ • ratPoint a (e : ℤ) = ratPoint a' (e : ℤ) := by
+  obtain ⟨γ, h00, h01, h10, h11⟩ :
+      ∃ γ : SL(2, ℤ), γ 0 0 = 1 + r₁ * a' ∧ γ 0 1 = q ∧ γ 1 0 = (e : ℤ) * r₁ ∧
+        γ 1 1 = 1 - r₁ * a :=
+    ⟨⟨!![1 + r₁ * a', q; (e : ℤ) * r₁, 1 - r₁ * a], by
+      rw [Matrix.det_fin_two_of]
+      linear_combination (-r₁) * hq⟩, rfl, rfl, rfl, rfl⟩
+  refine ⟨γ, h10, ?_⟩
+  rw [mapGL_smul_ratPoint (a := a) (c := (e : ℤ)) γ (Or.inr he0), h00, h01, h10, h11,
+    show (1 + r₁ * a') * a + q * (e : ℤ) = a' by linear_combination hq,
+    show (e : ℤ) * r₁ * a + (1 - r₁ * a) * (e : ℤ) = (e : ℤ) by ring]
+
+end ModularCurve.CuspSpace
+
+end
+
+theorem solution {N : ℕ} (hN : N ≠ 0) :
+    ModularCurve.CuspSpace.NormalFormCriterion N := by
+  intro a a' e he ha ha'
+  have he0 : e ≠ 0 := by rintro rfl; exact hN (Nat.eq_zero_of_zero_dvd he)
+  have he0' : (e : ℤ) ≠ 0 := by exact_mod_cast he0
+  constructor
+  · intro h
+    rw [mk_eq_mk_iff] at h
+    obtain ⟨γ, hγ, hsmul⟩ := h
+    rw [mapGL_smul_ratPoint (a := a') (c := (e : ℤ)) γ (Or.inr he0')] at hsmul
+    rw [ZMod.intCast_eq_intCast_iff_dvd_sub]
+    rcases (ratPoint_eq_ratPoint_iff_of_isCoprime (isCoprime_smul_pair γ ha') ha).mp hsmul with
+      ⟨h0, h1⟩ | ⟨h0, h1⟩
+    · exact dvd_sub_comm.mp (dvd_sub_of_smul_eq (A := a') (A' := a) (ε := 1) hN he
+        (Or.inl rfl) hγ (by linear_combination h0) (by linear_combination h1))
+    · exact dvd_sub_comm.mp (dvd_sub_of_smul_eq (A := a') (A' := a) (ε := -1) hN he
+        (Or.inr rfl) hγ (by linear_combination h0) (by linear_combination h1))
+  · intro h
+    obtain ⟨w, hw⟩ : ((Nat.gcd e (N / e) : ℕ) : ℤ) ∣ a' - a :=
+      (ZMod.intCast_eq_intCast_iff_dvd_sub a a' _).mp h
+    obtain ⟨b, c, hbc⟩ := ha.mul_left ha'
+    have hgab := Nat.gcd_eq_gcd_ab e (N / e)
+    have hem : (e : ℤ) * ((N / e : ℕ) : ℤ) = (N : ℤ) := by exact_mod_cast Nat.mul_div_cancel' he
+    have hq : (((Nat.gcd e (N / e) : ℕ) : ℤ) * w * c + Nat.gcdA e (N / e) * w * b * (a * a'))
+          * (e : ℤ)
+        = a' - a - ((N / e : ℕ) : ℤ) * (Nat.gcdB e (N / e) * w * b) * (a * a') := by
+      linear_combination (((Nat.gcd e (N / e) : ℕ) : ℤ) * w) * hbc
+        - w * b * (a * a') * hgab - hw
+    obtain ⟨γ, hγ10, hγsmul⟩ := exists_smul_ratPoint_eq he0' a a'
+      (((Nat.gcd e (N / e) : ℕ) : ℤ) * w * c + Nat.gcdA e (N / e) * w * b * (a * a'))
+      (((N / e : ℕ) : ℤ) * (Nat.gcdB e (N / e) * w * b)) hq
+    have hγmem : γ ∈ Gamma0 N := by
+      refine Gamma0_mem_iff_dvd.mpr ?_
+      rw [hγ10]
+      exact ⟨Nat.gcdB e (N / e) * w * b, by rw [← hem]; ring⟩
+    calc mk N (ratPoint a (e : ℤ))
+        = mk N (mapGL ℚ γ • ratPoint a (e : ℤ)) := (mk_smul hγmem _).symm
+      _ = mk N (ratPoint a' (e : ℤ)) := by rw [hγsmul]
+
+end S_ModularCurve_CuspSpace_normalFormCriterion
+end P2MW
+export P2MW.S_ModularCurve_CuspSpace_normalFormCriterion (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open OnePoint
+theorem ModularCurve.CuspSpace.normalFormCriterion {N : ℕ} (hN : N ≠ 0) :
+    ModularCurve.CuspSpace.NormalFormCriterion N :=
+  solution hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_E4_cube_div_discriminant_smul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_E4_cube_div_discriminant_smul.lean
new file mode 100644
index 0000000000..738a75bda8
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_E4_cube_div_discriminant_smul.lean
@@ -0,0 +1,105 @@
+/-
+Based on Prove2Me node ModularCurve.E4_cube_div_discriminant_smul
+(c0acef28-60a7-5603-ba6b-5202f4dad3b3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 677c6c79-20ba-5ac7-afee-62a70e6c35ad
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.EisensteinSeries.Basic
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# SL₂(ℤ)-invariance of E₄³/Δ
+
+Theorem statement: `ModularCurve.E4_cube_div_discriminant_smul`
+(`c0acef28-60a7-5603-ba6b-5202f4dad3b3`), by Claude, 2026-09-05.
+
+Proof: submission `677c6c79-20ba-5ac7-afee-62a70e6c35ad`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+For every $\gamma$ in the special linear group $\mathrm{SL}_2(\mathbb{Z})$ (Mathlib's
+`Matrix.SpecialLinearGroup (Fin 2) ℤ`) and every point $\tau$ of the upper half-plane
+$\mathfrak{H}$, the complex number $E_4(\gamma\cdot\tau)^3/\Delta(\gamma\cdot\tau)$ equals
+$E_4(\tau)^3/\Delta(\tau)$. Here $E_4$ is Mathlib's normalised weight-$4$ Eisenstein series
+`ModularForm.E₄` for the full modular group, $\Delta$ is the modular discriminant
+`ModularForm.discriminant`, $\gamma\cdot\tau$ is the usual action of $\mathrm{SL}_2(\mathbb{Z})$ on
+$\mathfrak{H}$ by fractional linear transformations, and the cube and the quotient are taken in
+$\mathbb{C}$. No non-vanishing hypothesis on $\Delta$ enters: with Lean's convention $x/0 = 0$ the
+asserted identity holds as stated, so this is exactly the invariance of the function $\tau \mapsto
+E_4(\tau)^3/\Delta(\tau)$ on $\mathfrak{H}$ under the full modular group, with no claim that the
+common value is finite or that it computes the $j$-invariant up to a constant.
+
+This is the $\mathrm{SL}_2(\mathbb{Z})$-invariance of the level-one modular function $E_4^3/\Delta$,
+i.e. of the modular invariant $j$ up to normalisation. It is used in the treatment of the modular
+curve: stabiliser and ramification computations for complex points, membership statements for
+algebras generated by $j$ and $q$, and the Fricke involution on $\Gamma_0$-invariant expansions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_E4_cube_div_discriminant_smul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_E4_cube_div_discriminant_smul
+
+noncomputable section
+
+open Matrix.SpecialLinearGroup UpperHalfPlane Polynomial
+open scoped MatrixGroups ModularForm OnePoint
+
+namespace ModularCurve
+
+theorem E4_cube_div_discriminant_smul' (γ : SL(2, ℤ)) (τ : ℍ) :
+    ModularForm.E₄ (γ • τ) ^ 3 / ModularForm.discriminant (γ • τ)
+      = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ := by
+  have hγ : (mapGL ℝ γ : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ, rfl⟩
+  have hE : ModularForm.E₄ (γ • τ) = denom (mapGL ℝ γ) τ ^ (4 : ℤ) * ModularForm.E₄ τ :=
+    SlashInvariantForm.slash_action_eqn'' (ModularForm.E₄) hγ τ
+  have hΔ : ModularForm.discriminant (γ • τ)
+      = denom (mapGL ℝ γ) τ ^ (12 : ℤ) * ModularForm.discriminant τ := by
+    have := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hγ τ
+    simp only [CuspForm.coe_discriminant] at this
+    exact this
+  have hd : denom (mapGL ℝ γ : GL (Fin 2) ℝ) τ ≠ 0 := denom_ne_zero _ _
+  rw [hE, hΔ, mul_pow, ← zpow_natCast, ← zpow_mul]
+  norm_num
+  rw [mul_div_mul_left _ _ (pow_ne_zero 12 hd)]
+
+end ModularCurve
+
+end
+
+theorem solution (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) (τ : UpperHalfPlane) :
+    ModularForm.E₄ (γ • τ) ^ 3 / ModularForm.discriminant (γ • τ) = ModularForm.E₄ τ ^ 3 /
+      ModularForm.discriminant τ :=
+  ModularCurve.E4_cube_div_discriminant_smul' γ τ
+
+end S_ModularCurve_E4_cube_div_discriminant_smul
+end P2MW
+export P2MW.S_ModularCurve_E4_cube_div_discriminant_smul (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.E4_cube_div_discriminant_smul (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ)
+    (τ : UpperHalfPlane) :
+    ModularForm.E₄ (γ • τ) ^ 3 / ModularForm.discriminant (γ • τ) = ModularForm.E₄ τ ^ 3 /
+      ModularForm.discriminant τ :=
+  solution γ τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_Gamma0_index.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_Gamma0_index.lean
new file mode 100644
index 0000000000..150a09409b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_Gamma0_index.lean
@@ -0,0 +1,297 @@
+/-
+Based on Prove2Me node ModularCurve.Gamma0_index
+(c91d959d-2902-51d8-9891-dad35f4d75c5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 60e4f211-95fb-5f56-9a18-a4784405373b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import Mathlib.GroupTheory.Index
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_card_projectiveLine_zmod
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Index of Γ₀(N) equals ψ(N)
+
+Theorem statement: `ModularCurve.Gamma0_index` (`c91d959d-2902-51d8-9891-dad35f4d75c5`), by Claude,
+2026-09-05.
+
+Proof: submission `60e4f211-95fb-5f56-9a18-a4784405373b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, assumed nonzero. The Hecke congruence subgroup $\Gamma_0(N)$ of
+$\mathrm{SL}_2(\mathbb{Z})$, consisting of the integral matrices of determinant one whose lower-left
+entry is divisible by $N$, has finite index in $\mathrm{SL}_2(\mathbb{Z})$, and that index (in the
+sense of Mathlib's subgroup index, which is $0$ when the index is infinite) is equal to `dedekindPsi
+N`, defined here as the sum of $N/d$ over the squarefree divisors $d$ of $N$. Thus
+$$[\mathrm{SL}_2(\mathbb{Z}) : \Gamma_0(N)] \;=\; \sum_{\substack{d \mid N \\ d \text{ squarefree}}}
+\frac{N}{d},$$ the right-hand side being the usual Dedekind psi function $\psi(N) = N\prod_{p \mid
+N}(1 + p^{-1})$ in this alternative but equivalent form. The proof cites the count
+[`ModularCurve.card_projectiveLine_zmod`](thm.html#ModularCurve.card_projectiveLine_zmod), which
+states that the projective line over $\mathbb{Z}/N\mathbb{Z}$ has cardinality `dedekindPsi N` for $N
+\neq 0$, reflecting the bijection between the cosets of $\Gamma_0(N)$ and
+$\mathbb{P}^1(\mathbb{Z}/N\mathbb{Z})$.
+
+This is the classical index formula for the Hecke congruence subgroup, equivalently the degree of
+the covering $X_0(N) \to X(1)$ and the degree in each variable of the modular polynomial $\Phi_N$.
+It underlies the numerical bookkeeping for $X_0(N)$ and for spaces of modular forms of level $N$,
+and is used for instance in the sum of cusp widths on $X_0(N)$, in dimension and rank bounds for
+spaces of cusp forms, and in vanishing criteria for forms of small weight relative to $\psi(N)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_Gamma0_index.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_Gamma0_index
+
+open ModularCurve Matrix CongruenceSubgroup Finset
+open scoped MatrixGroups
+
+open scoped MatrixGroups
+
+section ArithmeticLemmas
+
+private lemma natCast_dvd_int {p : ℕ} {z : ℤ} : (p : ℤ) ∣ z ↔ p ∣ z.natAbs :=
+  Int.natCast_dvd
+
+private def primeSel (c d : ℤ) : ℕ :=
+  ∏ p ∈ c.natAbs.primeFactors, if p ∣ d.natAbs then 1 else p
+
+private lemma dvd_primeSel {c d : ℤ} {p : ℕ} (hc : c ≠ 0) (hp : p.Prime)
+    (hpc : (p : ℤ) ∣ c) (hpd : ¬(p : ℤ) ∣ d) : p ∣ primeSel c d := by
+  have hmem : p ∈ c.natAbs.primeFactors :=
+    Nat.mem_primeFactors.mpr ⟨hp, natCast_dvd_int.mp hpc, Int.natAbs_ne_zero.mpr hc⟩
+  have h := Finset.dvd_prod_of_mem (fun q : ℕ => if q ∣ d.natAbs then 1 else q) hmem
+  simp only [ite_eq_right (fun hcontra => hpd (natCast_dvd_int.mpr hcontra))] at h
+  exact h
+
+private lemma not_dvd_primeSel {c d : ℤ} {p : ℕ} (hp : p.Prime) (hpd : (p : ℤ) ∣ d) :
+    ¬p ∣ primeSel c d := by
+  intro hdvd
+  obtain ⟨q, hq, hpq⟩ := (Nat.Prime.prime hp).dvd_finsetProd_iff _ |>.mp hdvd
+  by_cases hqd : q ∣ d.natAbs
+  · rw [ite_eq_left hqd] at hpq
+    exact hp.one_lt.ne' (Nat.dvd_one.mp hpq)
+  · rw [ite_eq_right hqd] at hpq
+    have hq' : q.Prime := (Nat.mem_primeFactors.mp hq).1
+    exact hqd (((Nat.prime_dvd_prime_iff_eq hp hq').mp hpq) ▸ natCast_dvd_int.mp hpd)
+
+private theorem exists_coprime_lift (N : ℕ) [NeZero N] {c₀ d₀ : ℤ}
+    (H : ∀ p : ℕ, p.Prime → (p : ℤ) ∣ c₀ → (p : ℤ) ∣ d₀ → ¬(p : ℤ) ∣ (N : ℤ)) :
+    ∃ γ δ : ℤ, Int.gcd γ δ = 1 ∧
+      (γ : ZMod N) = (c₀ : ZMod N) ∧ (δ : ZMod N) = (d₀ : ZMod N) := by
+  set γ : ℤ := if c₀ = 0 then (N : ℤ) else c₀ with hγ_def
+  have hγ0 : γ ≠ 0 := by
+    rw [hγ_def]; split
+    · exact_mod_cast NeZero.ne N
+    · assumption
+  have hγc : (γ : ZMod N) = (c₀ : ZMod N) := by
+    rw [hγ_def]; split
+    · next h => simp [h]
+    · rfl
+  have Hγ : ∀ p : ℕ, p.Prime → (p : ℤ) ∣ γ → (p : ℤ) ∣ d₀ → ¬(p : ℤ) ∣ (N : ℤ) := by
+    intro p pp hpγ hpd
+    refine H p pp ?_ hpd
+    rw [hγ_def] at hpγ
+    by_cases h : c₀ = 0
+    · simp [h]
+    · rwa [ite_eq_right h] at hpγ
+  refine ⟨γ, d₀ + (primeSel γ d₀ : ℤ) * (N : ℤ), ?_, hγc, ?_⟩
+  · by_contra hne
+    obtain ⟨p, pp, hpdvd⟩ := Nat.exists_prime_and_dvd hne
+    have h1 : (p : ℤ) ∣ γ :=
+      natCast_dvd_int.mpr (hpdvd.trans (Nat.gcd_dvd_left _ _))
+    have h2 : (p : ℤ) ∣ d₀ + (primeSel γ d₀ : ℤ) * (N : ℤ) :=
+      natCast_dvd_int.mpr (hpdvd.trans (Nat.gcd_dvd_right _ _))
+    by_cases hpd : (p : ℤ) ∣ d₀
+    · have h3 : (p : ℤ) ∣ (primeSel γ d₀ : ℤ) * (N : ℤ) := by
+        have := h2.sub hpd; rwa [add_sub_cancel_left] at this
+      have h3' : p ∣ primeSel γ d₀ * N := by
+        have : (p : ℤ) ∣ ((primeSel γ d₀ * N : ℕ) : ℤ) := by push_cast; exact h3
+        exact_mod_cast this
+      rcases (pp.prime.dvd_mul.mp h3') with h4 | h4
+      · exact not_dvd_primeSel pp hpd h4
+      · exact Hγ p pp h1 hpd (by exact_mod_cast h4)
+    · have h3 : (p : ℤ) ∣ (primeSel γ d₀ : ℤ) :=
+        natCast_dvd_int.mpr (dvd_primeSel hγ0 pp h1 hpd)
+      refine hpd ?_
+      have := h2.sub (h3.mul_right (N : ℤ)); rwa [add_sub_cancel_right] at this
+  · push_cast; simp
+
+private theorem exists_sl2_int_lift {N : ℕ} [NeZero N] {a b c d : ZMod N}
+    (h : a * d - b * c = 1) :
+    ∃ α β γ δ : ℤ, α * δ - β * γ = 1 ∧
+      (α : ZMod N) = a ∧ (β : ZMod N) = b ∧ (γ : ZMod N) = c ∧ (δ : ZMod N) = d := by
+  set a₀ : ℤ := ZMod.cast a with ha₀
+  set b₀ : ℤ := ZMod.cast b with hb₀
+  set c₀ : ℤ := ZMod.cast c with hc₀
+  set d₀ : ℤ := ZMod.cast d with hd₀
+  have hcasta : ((a₀ : ℤ) : ZMod N) = a := ZMod.intCast_zmod_cast a
+  have hcastb : ((b₀ : ℤ) : ZMod N) = b := ZMod.intCast_zmod_cast b
+  have hcastc : ((c₀ : ℤ) : ZMod N) = c := ZMod.intCast_zmod_cast c
+  have hcastd : ((d₀ : ℤ) : ZMod N) = d := ZMod.intCast_zmod_cast d
+  have hdvd : (N : ℤ) ∣ a₀ * d₀ - b₀ * c₀ - 1 := by
+    rw [← ZMod.intCast_zmod_eq_zero_iff_dvd]
+    push_cast
+    rw [hcasta, hcastb, hcastc, hcastd]
+    rw [sub_eq_zero]; exact h
+  have H : ∀ p : ℕ, p.Prime → (p : ℤ) ∣ c₀ → (p : ℤ) ∣ d₀ → ¬(p : ℤ) ∣ (N : ℤ) := by
+    intro p pp hpc hpd hpN
+    have hone : (p : ℤ) ∣ 1 := by
+      have h1 : (p : ℤ) ∣ a₀ * d₀ - b₀ * c₀ - 1 := hpN.trans hdvd
+      have h2 : (p : ℤ) ∣ a₀ * d₀ := hpd.mul_left a₀
+      have h3 : (p : ℤ) ∣ b₀ * c₀ := hpc.mul_left b₀
+      have key : (1 : ℤ) = a₀ * d₀ - b₀ * c₀ - (a₀ * d₀ - b₀ * c₀ - 1) := by ring
+      rw [key]; exact (h2.sub h3).sub h1
+    exact pp.one_lt.ne' (Nat.dvd_one.mp (by exact_mod_cast hone))
+  obtain ⟨γ, δ, hγδ, hγ, hδ⟩ := exists_coprime_lift N H
+  rw [hcastc] at hγ; rw [hcastd] at hδ
+  set α₀ : ℤ := Int.gcdB γ δ with hα₀
+  set β₀ : ℤ := -Int.gcdA γ δ with hβ₀
+  have hdet₀ : α₀ * δ - β₀ * γ = 1 := by
+    have hbez := Int.gcd_eq_gcd_ab γ δ
+    rw [hγδ] at hbez; push_cast at hbez
+    rw [hα₀, hβ₀]; linear_combination -hbez
+  have hdet₀' : (α₀ : ZMod N) * d - (β₀ : ZMod N) * c = 1 := by
+    have := congrArg (fun z : ℤ => (z : ZMod N)) hdet₀
+    push_cast at this; rwa [hγ, hδ] at this
+  set lam : ZMod N := b * (α₀ : ZMod N) - a * (β₀ : ZMod N) with hlam
+  set l : ℤ := ZMod.cast lam with hl
+  have hcastl : ((l : ℤ) : ZMod N) = lam := ZMod.intCast_zmod_cast lam
+  refine ⟨α₀ + l * γ, β₀ + l * δ, γ, δ, ?_, ?_, ?_, hγ, hδ⟩
+  · linear_combination hdet₀
+  · push_cast; rw [hcastl, hγ, hlam]
+    linear_combination (-(α₀ : ZMod N)) * h + a * hdet₀'
+  · push_cast; rw [hcastl, hδ, hlam]
+    linear_combination (-(β₀ : ZMod N)) * h + b * hdet₀'
+
+end ArithmeticLemmas
+
+private theorem sl2_surj (N : ℕ) [NeZero N] :
+    Function.Surjective
+      (Matrix.SpecialLinearGroup.map (n := Fin 2) (Int.castRingHom (ZMod N))) := by
+  intro M
+  have hdet : M 0 0 * M 1 1 - M 0 1 * M 1 0 = 1 := by
+    have hM := M.prop; rwa [Matrix.det_fin_two] at hM
+  obtain ⟨α, β, γ, δ, h1, ha, hb, hc, hd⟩ := exists_sl2_int_lift hdet
+  refine ⟨⟨!![α, β; γ, δ], by rw [Matrix.det_fin_two_of]; exact h1⟩, ?_⟩
+  ext i j
+  fin_cases i <;> fin_cases j <;>
+    simpa [Matrix.SpecialLinearGroup.map_apply_coe, RingHom.mapMatrix_apply, Matrix.map_apply]
+      using ‹_›
+
+section QuotientBorel
+variable {R : Type*} [CommRing R]
+
+private theorem isUnimodularRow_firstCol (A : SpecialLinearGroup (Fin 2) R) :
+    IsUnimodularRow (A.1 0 0) (A.1 1 0) := by
+  refine ⟨A.1 1 1, -A.1 0 1, ?_⟩
+  have hdet : A.1 0 0 * A.1 1 1 - A.1 0 1 * A.1 1 0 = 1 := by
+    have h := A.2; rwa [Matrix.det_fin_two] at h
+  linear_combination hdet
+
+private def firstColumnClass (A : SpecialLinearGroup (Fin 2) R) : ProjectiveLine R :=
+  ⟦⟨(A.1 0 0, A.1 1 0), isUnimodularRow_firstCol A⟩⟧
+
+private theorem firstColumnClass_eq_iff (A B : SpecialLinearGroup (Fin 2) R) :
+    firstColumnClass A = firstColumnClass B ↔ A⁻¹ * B ∈ borel R := by
+  constructor
+  · intro hAB
+    obtain ⟨u, h1, h2⟩ := Quotient.exact hAB
+    have h1' : (u : R) * A.1 0 0 = B.1 0 0 := h1
+    have h2' : (u : R) * A.1 1 0 = B.1 1 0 := h2
+    change (A⁻¹ * B).1 1 0 = 0
+    rw [SpecialLinearGroup.coe_mul, SpecialLinearGroup.SL2_inv_expl A,
+      (Matrix.two_mul_expl _ B.1).2.2.1]
+    simp only [Matrix.cons_val_one, Matrix.cons_val_zero]
+    rw [← h1', ← h2']; ring
+  · intro hAB
+    have hB : B = A * (A⁻¹ * B) := (mul_inv_cancel_left A B).symm
+    have hC10 : (A⁻¹ * B).1 1 0 = 0 := hAB
+    have hCdet : (A⁻¹ * B).1 0 0 * (A⁻¹ * B).1 1 1 = 1 := by
+      have h := (A⁻¹ * B).2; rw [Matrix.det_fin_two, hC10] at h; linear_combination h
+    have hB00 : B.1 0 0 = A.1 0 0 * (A⁻¹ * B).1 0 0 + A.1 0 1 * (A⁻¹ * B).1 1 0 := by
+      conv_lhs => rw [hB, SpecialLinearGroup.coe_mul]
+      exact (Matrix.two_mul_expl A.1 (A⁻¹ * B).1).1
+    have hB10 : B.1 1 0 = A.1 1 0 * (A⁻¹ * B).1 0 0 + A.1 1 1 * (A⁻¹ * B).1 1 0 := by
+      conv_lhs => rw [hB, SpecialLinearGroup.coe_mul]
+      exact (Matrix.two_mul_expl A.1 (A⁻¹ * B).1).2.2.1
+    refine Quotient.sound ⟨⟨(A⁻¹ * B).1 0 0, (A⁻¹ * B).1 1 1, hCdet,
+      (mul_comm _ _).trans hCdet⟩, ?_, ?_⟩
+    · change (A⁻¹ * B).1 0 0 * A.1 0 0 = B.1 0 0; rw [hB00, hC10]; ring
+    · change (A⁻¹ * B).1 0 0 * A.1 1 0 = B.1 1 0; rw [hB10, hC10]; ring
+
+private theorem card_quotient_borel (R : Type*) [CommRing R] :
+    Nat.card (SpecialLinearGroup (Fin 2) R ⧸ borel R) = Nat.card (ProjectiveLine R) := by
+  have hwd : ∀ A B : SpecialLinearGroup (Fin 2) R, QuotientGroup.leftRel (borel R) A B →
+      firstColumnClass A = firstColumnClass B := by
+    intro A B hAB
+    rw [QuotientGroup.leftRel_apply] at hAB
+    exact (firstColumnClass_eq_iff A B).mpr hAB
+  refine Nat.card_eq_of_bijective (fun q => Quotient.liftOn' q firstColumnClass hwd) ⟨?_, ?_⟩
+  · intro q q'
+    refine Quotient.inductionOn₂' q q' ?_
+    intro A B hAB
+    have hAB' : firstColumnClass A = firstColumnClass B := hAB
+    exact (QuotientGroup.eq).mpr ((firstColumnClass_eq_iff A B).mp hAB')
+  · intro q
+    obtain ⟨v, rfl⟩ := Quotient.exists_rep q
+    obtain ⟨x, y, hxy⟩ := v.2
+    refine ⟨QuotientGroup.mk ⟨!![v.1.1, -y; v.1.2, x], by
+      rw [Matrix.det_fin_two_of]; linear_combination hxy⟩, ?_⟩
+    change firstColumnClass _ = ⟦v⟧
+    refine Quotient.sound ⟨1, ?_, ?_⟩
+    · change (1 : R) * !![v.1.1, -y; v.1.2, x] 0 0 = v.1.1; simp
+    · change (1 : R) * !![v.1.1, -y; v.1.2, x] 1 0 = v.1.2; simp
+
+end QuotientBorel
+
+private theorem Gamma0_eq_comap_borel (N : ℕ) :
+    Gamma0 N = (borel (ZMod N)).comap
+      (SpecialLinearGroup.map (n := Fin 2) (Int.castRingHom (ZMod N))) := by
+  ext A
+  rw [Gamma0_mem, Subgroup.mem_comap, mem_borel_iff]
+  constructor
+  · intro hA
+    change (Int.castRingHom (ZMod N)).mapMatrix A.1 1 0 = 0; simpa using hA
+  · intro hA
+    have hA' : (Int.castRingHom (ZMod N)).mapMatrix A.1 1 0 = 0 := hA; simpa using hA'
+
+theorem solution (N : ℕ) [NeZero N] : (CongruenceSubgroup.Gamma0 N).index = dedekindPsi N := by
+  have h1 : (Gamma0 N).index = (borel (ZMod N)).index := by
+    rw [Gamma0_eq_comap_borel]
+    exact Subgroup.index_comap_of_surjective _ (sl2_surj N)
+  rw [h1, Subgroup.index_eq_card, card_quotient_borel,
+    ModularCurve.card_projectiveLine_zmod N (NeZero.ne N)]
+
+end S_ModularCurve_Gamma0_index
+end P2MW
+export P2MW.S_ModularCurve_Gamma0_index (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.Gamma0_index (N : ℕ) [NeZero N] :
+    (CongruenceSubgroup.Gamma0 N).index = dedekindPsi N :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_HahnSpecialise_specialiseCycSub_bijective.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_HahnSpecialise_specialiseCycSub_bijective.lean
new file mode 100644
index 0000000000..a3043935ce
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_HahnSpecialise_specialiseCycSub_bijective.lean
@@ -0,0 +1,127 @@
+/-
+Based on Prove2Me node ModularCurve.HahnSpecialise.specialiseCycSub_bijective
+(9307f9d2-7f83-55bd-a537-afd602522dd1) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b8e9b129-d73f-5b34-b4d4-1de090874d1f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_HahnSpecialise
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_HahnSpecialise_specialiseCycSub_injective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_HahnSpecialise_specialise_bijOn_torsion
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Bijectivity of specialisation on cyclic subgroups of order N
+
+Theorem statement: `ModularCurve.HahnSpecialise.specialiseCycSub_bijective`
+(`9307f9d2-7f83-55bd-a537-afd602522dd1`), by Claude, 2026-09-05.
+
+Proof: submission `b8e9b129-d73f-5b34-b4d4-1de090874d1f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let `E` be a Weierstrass curve over the series field `H`, and assume `IntegralCoeffs E`, i.e. each
+of the five coefficients $a_1,a_2,a_3,a_4,a_6$ of `E` has non-negative `orderTop`. Let `specialFibre
+E` be the Weierstrass curve over $\bar{\mathbb Q}$ (the algebraic closure of $\mathbb Q$) whose
+coefficients are the degree-$0$ coefficients $a_i.\mathrm{coeff}\,0$, and assume its discriminant is
+non-zero. Let $N$ be a natural number, non-zero. The statement concerns the specialisation map on
+cyclic subgroups: the source is the set of additive subgroups $G$ of the affine point group $E(\,)$
+of `E` for which there is a point $g$ of additive order exactly $N$ with $G$ the group of integer
+multiples of $g$, the target is the analogous set for `specialFibre E`, and the map sends such a $G$
+to its image under the specialisation homomorphism `specialise E hE hΔ` on points (reduction into
+the special fibre). The conclusion is that this map is bijective: a cyclic subgroup of order $N$
+upstairs has image a cyclic subgroup of order $N$ in the special fibre, and every such subgroup
+downstairs arises from exactly one subgroup upstairs.
+
+This is the level-structure counterpart of good-reduction specialisation: over the series field the
+cyclic subgroups of exact order $N$ of the generic curve correspond bijectively to those of its
+special fibre over $\bar{\mathbb Q}$. It is the curve-side input used by
+[`ModularCurve.B3.specialisationEquivariance_level`]
+(thm.html#ModularCurve.B3.specialisationEquivariance_level),
+where cyclic $N$-isogenies (level structures) must be matched between the generic and the special
+curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_HahnSpecialise_specialiseCycSub_bijective.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_HahnSpecialise_specialiseCycSub_bijective
+
+noncomputable section
+
+open ModularCurve ModularCurve.B3 ModularCurve.HahnSpecialise
+open ModularCurve.TatePoint (Qbar H CycSubH)
+open scoped Classical
+
+namespace CycSubOf
+p2m_export "CycSubOf" "map coe_map"
+p2m_open "CycSubOf"
+
+variable {G G' : Type*} [AddCommGroup G] [AddCommGroup G'] (f : G →+ G') {N : ℕ}
+variable (hf : ∀ ⦃P Q : G⦄, N • P = 0 → N • Q = 0 → f P = f Q → P = Q)
+
+include hf in
+theorem addOrderOf_map_eq_of_injOn {g : G} (hg : N • g = 0) : addOrderOf (f g) = addOrderOf g := by
+  apply Nat.dvd_antisymm (addOrderOf_map_dvd f g)
+  apply addOrderOf_dvd_of_nsmul_eq_zero
+  refine hf ?_ (smul_zero _) ?_
+  · rw [smul_comm, hg, smul_zero]
+  · rw [map_nsmul, addOrderOf_nsmul_eq_zero, map_zero]
+
+include hf in
+theorem map_surjective_of_surjOn
+    (hs : ∀ P' : G', N • P' = 0 → ∃ P : G, N • P = 0 ∧ f P = P') :
+    Function.Surjective (map f hf) := by
+  intro T
+  obtain ⟨g', hg', hT⟩ := T.2
+  obtain ⟨g, hgN, hgg'⟩ := hs g' (by rw [← hg']; exact addOrderOf_nsmul_eq_zero g')
+  have hg : addOrderOf g = N := by rw [← addOrderOf_map_eq_of_injOn f hf hgN, hgg', hg']
+  refine ⟨⟨AddSubgroup.zmultiples g, g, hg, rfl⟩, Subtype.ext ?_⟩
+  rw [coe_map, hT, AddMonoidHom.map_zmultiples, hgg']
+
+end CycSubOf
+
+theorem solution (E : WeierstrassCurve H) (hE : IntegralCoeffs E)
+    (hΔ : (specialFibre E).Δ ≠ 0) (N : ℕ) [NeZero N] :
+    Function.Bijective (specialiseCycSub E hE hΔ N) := by
+  refine ⟨ModularCurve.HahnSpecialise.specialiseCycSub_injective E hE hΔ N, ?_⟩
+  have hb := ModularCurve.HahnSpecialise.specialise_bijOn_torsion E hE hΔ N
+  exact CycSubOf.map_surjective_of_surjOn _ _ (fun Q hQ => by
+    obtain ⟨P, hP, hPQ⟩ := hb.2.2 hQ
+    exact ⟨P, hP, hPQ⟩)
+
+end
+
+end S_ModularCurve_HahnSpecialise_specialiseCycSub_bijective
+end P2MW
+export P2MW.S_ModularCurve_HahnSpecialise_specialiseCycSub_bijective (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.B3 ModularCurve.HahnSpecialise
+open ModularCurve.TatePoint (Qbar H CycSubH)
+open scoped Classical
+theorem ModularCurve.HahnSpecialise.specialiseCycSub_bijective (E : WeierstrassCurve H)
+    (hE : IntegralCoeffs E)
+    (hΔ : (specialFibre E).Δ ≠ 0) (N : ℕ) [NeZero N] :
+    Function.Bijective (specialiseCycSub E hE hΔ N) :=
+  solution E hE hΔ N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_HahnSpecialise_specialiseCycSub_injective.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_HahnSpecialise_specialiseCycSub_injective.lean
new file mode 100644
index 0000000000..ded81804fa
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_HahnSpecialise_specialiseCycSub_injective.lean
@@ -0,0 +1,132 @@
+/-
+Based on Prove2Me node ModularCurve.HahnSpecialise.specialiseCycSub_injective
+(319e24b6-63cc-58e9-887d-b11e3471b436) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 97ee1c07-1f56-536a-818d-4f73d536eb44
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_HahnSpecialise
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Specialisation is injective on cyclic subgroups of order N
+
+Theorem statement: `ModularCurve.HahnSpecialise.specialiseCycSub_injective`
+(`319e24b6-63cc-58e9-887d-b11e3471b436`), by Claude, 2026-09-05.
+
+Proof: submission `97ee1c07-1f56-536a-818d-4f73d536eb44`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let `H` be the Hahn-series field fixed in this development (its elements carry an order function
+`orderTop` and coefficients, so that `coeff 0` is defined) and let $\bar{\mathbb Q}$ denote `Qbar`,
+the algebraic closure of $\mathbb Q$. Let $E$ be a Weierstrass curve over `H` satisfying
+`IntegralCoeffs`, that is, each of $a_1,a_2,a_3,a_4,a_6$ has nonnegative `orderTop`; let
+`specialFibre E` be the Weierstrass curve over $\bar{\mathbb Q}$ whose coefficients are the $0$-th
+coefficients $a_i(0)$, and assume its discriminant $\Delta$ is nonzero. Let $N$ be a natural number
+with `NeZero N`, i.e. $N \neq 0$. The assertion is that the map `specialiseCycSub E hE hΔ N` is
+injective. Its source `CycSubH E N` consists of the subgroups $S$ of the affine point group
+$E(\,$`H`$)$ for which there is a point $g$ of additive order exactly $N$ with $S = \langle
+g\rangle$ (the group of integer multiples of $g$), its target `CycSub (specialFibre E) N` is the
+analogous set of subgroups of $(\mathrm{specialFibre}\,E)(\bar{\mathbb Q})$, and the map sends $S$
+to its image under the specialisation homomorphism `specialise E hE hΔ` $: E(\,$`H`$) \to
+(\mathrm{specialFibre}\,E)(\bar{\mathbb Q})$, this image again being cyclic of order $N$ because
+that homomorphism is injective on pairs of $N$-torsion points.
+
+This is the injectivity half of the comparison of $\Gamma_0(N)$-level structures — cyclic subgroups
+of order $N$ — on a Weierstrass curve with good special fibre and on that special fibre, the
+classical source being the injectivity of reduction on torsion of order prime to the residue
+characteristic. It feeds the bijectivity statement
+[`ModularCurve.HahnSpecialise.specialiseCycSub_bijective`]
+(thm.html#ModularCurve.HahnSpecialise.specialiseCycSub_bijective).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_HahnSpecialise_specialiseCycSub_injective.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_HahnSpecialise_specialiseCycSub_injective
+
+noncomputable section
+
+open ModularCurve ModularCurve.B3 ModularCurve.HahnSpecialise
+open ModularCurve.TatePoint (Qbar H CycSubH)
+open scoped Classical
+
+namespace CycSubOf
+p2m_export "CycSubOf" "map coe_map"
+p2m_open "CycSubOf"
+
+variable {G G' : Type*} [AddCommGroup G] [AddCommGroup G'] (f : G →+ G') {N : ℕ}
+variable (hf : ∀ ⦃P Q : G⦄, N • P = 0 → N • Q = 0 → f P = f Q → P = Q)
+
+include hf in
+theorem mem_zmultiples_of_map_eq {g g' : G} (hg : addOrderOf g = N) (hg' : addOrderOf g' = N)
+    (heq : (AddSubgroup.zmultiples g).map f = (AddSubgroup.zmultiples g').map f) :
+    g ∈ AddSubgroup.zmultiples g' := by
+  have hmem : f g ∈ (AddSubgroup.zmultiples g').map f := by
+    rw [← heq]; exact AddSubgroup.mem_map_of_mem _ (AddSubgroup.mem_zmultiples g)
+  rw [AddMonoidHom.map_zmultiples, AddSubgroup.mem_zmultiples_iff] at hmem
+  obtain ⟨k, hk⟩ := hmem
+  have hgk : g = k • g' := by
+    refine hf ?_ ?_ (by rw [map_zsmul, hk])
+    · rw [← hg]; exact addOrderOf_nsmul_eq_zero g
+    · rw [smul_comm, ← hg', addOrderOf_nsmul_eq_zero, smul_zero]
+  rw [hgk]; exact AddSubgroup.zsmul_mem _ (AddSubgroup.mem_zmultiples g') k
+
+theorem map_injective : Function.Injective (map f hf) := by
+  intro S T hST
+  obtain ⟨g, hg, hS⟩ := S.2
+  obtain ⟨g', hg', hT⟩ := T.2
+  have hST' : (AddSubgroup.zmultiples g).map f = (AddSubgroup.zmultiples g').map f := by
+    have := congrArg Subtype.val hST
+    simpa [coe_map, hS, hT] using this
+  apply Subtype.ext
+  rw [hS, hT]
+  apply le_antisymm
+  · rw [AddSubgroup.zmultiples_le]
+    exact mem_zmultiples_of_map_eq f hf hg hg' hST'
+  · rw [AddSubgroup.zmultiples_le]
+    exact mem_zmultiples_of_map_eq f hf hg' hg hST'.symm
+
+end CycSubOf
+
+theorem solution (E : WeierstrassCurve H) (hE : IntegralCoeffs E)
+    (hΔ : (specialFibre E).Δ ≠ 0) (N : ℕ) [NeZero N] :
+    Function.Injective (specialiseCycSub E hE hΔ N) :=
+  CycSubOf.map_injective _ _
+
+end
+
+end S_ModularCurve_HahnSpecialise_specialiseCycSub_injective
+end P2MW
+export P2MW.S_ModularCurve_HahnSpecialise_specialiseCycSub_injective (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.B3 ModularCurve.HahnSpecialise
+open ModularCurve.TatePoint (Qbar H CycSubH)
+open scoped Classical
+theorem ModularCurve.HahnSpecialise.specialiseCycSub_injective (E : WeierstrassCurve H)
+    (hE : IntegralCoeffs E)
+    (hΔ : (specialFibre E).Δ ≠ 0) (N : ℕ) [NeZero N] :
+    Function.Injective (specialiseCycSub E hE hΔ N) :=
+  solution E hE hΔ N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_HahnSpecialise_specialise_bijOn_torsion.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_HahnSpecialise_specialise_bijOn_torsion.lean
new file mode 100644
index 0000000000..15a1bf5b8a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_HahnSpecialise_specialise_bijOn_torsion.lean
@@ -0,0 +1,188 @@
+/-
+Based on Prove2Me node ModularCurve.HahnSpecialise.specialise_bijOn_torsion
+(efd9b02b-cf7a-51ab-8940-ed4ca3c344a2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 11789ecf-46e7-5a3b-8718-644cd3c68409
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_HahnSpecialise
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsionBy_eq_sq_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_isAlgClosed_rat
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Specialisation is bijective on N-torsion
+
+Theorem statement: `ModularCurve.HahnSpecialise.specialise_bijOn_torsion`
+(`efd9b02b-cf7a-51ab-8940-ed4ca3c344a2`), by Claude, 2026-09-05.
+
+Proof: submission `11789ecf-46e7-5a3b-8718-644cd3c68409`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $H$ be the field of Hahn series with rational exponents over an algebraic closure $\bar{\mathbb
+Q}$ of $\mathbb Q$, and let $E$ be a Weierstrass curve over $H$. Assume `IntegralCoeffs E`, i.e.
+each of the five coefficients $a_1,a_2,a_3,a_4,a_6$ of $E$ has $\mathrm{orderTop}\ge 0$, so that all
+of them lie in the valuation subring `valuationSubringH` of Hahn series with non-negative support.
+Let `specialFibre E` be the Weierstrass curve over $\bar{\mathbb Q}$ whose coefficients are the
+degree-$0$ Hahn coefficients of the $a_i$, and assume its discriminant $\Delta$ is non-zero. Let $N$
+be a natural number, non-zero. Then the additive group homomorphism `specialise E hE hΔ` from the
+affine point group $E(H)$ to that of `specialFibre E` over $\bar{\mathbb Q}$ — obtained by viewing
+$E$ as the base change of the model `liftModel E hE` over `valuationSubringH`, reducing points by
+`reduceHom`, and transporting along the identification of the residue field with $\bar{\mathbb Q}$ —
+maps the set $\{P : N\cdot P = 0\}$ bijectively onto $\{Q : N\cdot Q = 0\}$: it sends the first set
+into the second, is injective on it, and is onto it.
+
+This is the statement that reduction from the Hahn-series field to its residue field $\bar{\mathbb
+Q}$ is an isomorphism on $N$-torsion for a model with non-degenerate special fibre (residue
+characteristic $0$, so no condition on $N$ is needed). It is used to transport $N$-torsion and
+cyclic level structures between a curve over $H$ and its special fibre, being cited by
+[`ModularCurve.HahnSpecialise.specialiseCycSub_bijective`]
+(thm.html#ModularCurve.HahnSpecialise.specialiseCycSub_bijective)
+and
+[`ModularCurve.B3.exists_torsionBy_reduction_addEquiv`]
+(thm.html#ModularCurve.B3.exists_torsionBy_reduction_addEquiv).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_HahnSpecialise_specialise_bijOn_torsion.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_HahnSpecialise_specialise_bijOn_torsion
+
+noncomputable section
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_HahnSpecialise_specialise_bijOn_torsion.ModularCurve \
+  ModularCurve.B3 ModularCurve.HahnSpecialise \
+  P2MW.S_ModularCurve_HahnSpecialise_specialise_bijOn_torsion.ModularCurve.HahnSpecialise"
+open IsLocalRing
+open ModularCurve.TatePoint (Qbar H CycSubH)
+open scoped Classical
+
+namespace ModularCurve
+namespace HahnSpecialise
+p2m_export "ModularCurve.HahnSpecialise" "valuationSubringH liftModel liftModel_map_subtype \
+  map_residue_Δ_ne_zero_of_specialFibre specialise specialise_injOn_nsmul_eq_zero"
+p2m_open "ModularCurve.HahnSpecialise ModularCurve"
+
+open ModularCurve.B3
+
+open WeierstrassCurve
+
+theorem isElliptic_specialFibre (E : WeierstrassCurve H) (hΔ : (specialFibre E).Δ ≠ 0) :
+    (specialFibre E).IsElliptic :=
+  ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+
+theorem isElliptic_of_specialFibre (E : WeierstrassCurve H) (hE : IntegralCoeffs E)
+    (hΔ : (specialFibre E).Δ ≠ 0) : E.IsElliptic := by
+  refine ⟨isUnit_iff_ne_zero.mpr ?_⟩
+  have hres : ((liftModel E hE).map (residue valuationSubringH)).Δ ≠ 0 :=
+    map_residue_Δ_ne_zero_of_specialFibre E hE hΔ
+  have hne : (liftModel E hE).Δ ≠ 0 := by
+    intro h0; apply hres; rw [WeierstrassCurve.map_Δ, h0, map_zero]
+  have h1 : ((liftModel E hE).map valuationSubringH.subtype).Δ =
+      valuationSubringH.subtype (liftModel E hE).Δ := by
+    simp only [WeierstrassCurve.map_Δ]
+  rw [liftModel_map_subtype] at h1
+  rw [h1]
+  exact fun h => hne (Subtype.ext h)
+
+theorem natCast_H_ne_zero {n : ℕ} (hn : n ≠ 0) : (n : H) ≠ 0 := by
+  intro h
+  have := congrArg (fun x : H => x.coeff 0) h
+  simp only [HahnSeries.coeff_zero] at this
+  rw [show ((n : H)).coeff 0 = (n : Qbar) from by
+    rw [← map_natCast (HahnSeries.C (Γ := ℚ) (R := Qbar)) n, HahnSeries.C_apply,
+      HahnSeries.coeff_single_same]] at this
+  exact (Nat.cast_ne_zero.mpr hn) this
+
+def specialiseTorsion (E : WeierstrassCurve H) (hE : IntegralCoeffs E)
+    (hΔ : (specialFibre E).Δ ≠ 0) (N : ℕ) :
+    Submodule.torsionBy ℤ E.toAffine.Point (N : ℤ) →
+      Submodule.torsionBy ℤ (specialFibre E).toAffine.Point (N : ℤ) :=
+  fun P => ⟨specialise E hE hΔ P, by
+    have hP := P.2
+    rw [Submodule.mem_torsionBy_iff] at hP ⊢
+    rw [← map_zsmul, hP, map_zero]⟩
+
+theorem nsmul_eq_zero_of_mem_torsionBy {M : Type*} [AddCommGroup M] {N : ℕ} {x : M}
+    (hx : x ∈ Submodule.torsionBy ℤ M (N : ℤ)) : N • x = 0 := by
+  rw [Submodule.mem_torsionBy_iff] at hx
+  rwa [natCast_zsmul] at hx
+
+theorem mem_torsionBy_of_nsmul_eq_zero {M : Type*} [AddCommGroup M] {N : ℕ} {x : M}
+    (hx : N • x = 0) : x ∈ Submodule.torsionBy ℤ M (N : ℤ) := by
+  rw [Submodule.mem_torsionBy_iff, natCast_zsmul]; exact hx
+
+theorem specialiseTorsion_injective (E : WeierstrassCurve H) (hE : IntegralCoeffs E)
+    (hΔ : (specialFibre E).Δ ≠ 0) {N : ℕ} (hN : N ≠ 0) :
+    Function.Injective (specialiseTorsion E hE hΔ N) := by
+  intro P Q h
+  apply Subtype.ext
+  exact specialise_injOn_nsmul_eq_zero E hE hΔ hN (nsmul_eq_zero_of_mem_torsionBy P.2)
+    (nsmul_eq_zero_of_mem_torsionBy Q.2) (congrArg Subtype.val h)
+
+theorem specialiseTorsion_bijective (E : WeierstrassCurve H) (hE : IntegralCoeffs E)
+    (hΔ : (specialFibre E).Δ ≠ 0) {N : ℕ} (hN : N ≠ 0) :
+    Function.Bijective (specialiseTorsion E hE hΔ N) := by
+  have : IsAlgClosed H := HahnSeries.isAlgClosed_rat
+  have : E.IsElliptic := isElliptic_of_specialFibre E hE hΔ
+  have : (specialFibre E).IsElliptic := isElliptic_specialFibre E hΔ
+  have hcardH : Nat.card (Submodule.torsionBy ℤ E.toAffine.Point (N : ℤ)) = N ^ 2 :=
+    WeierstrassCurve.card_torsionBy_eq_sq_of_isAlgClosed E (natCast_H_ne_zero hN)
+  have hcardQ : Nat.card (Submodule.torsionBy ℤ (specialFibre E).toAffine.Point (N : ℤ)) = N ^ 2 :=
+    WeierstrassCurve.card_torsionBy_eq_sq_of_isAlgClosed (specialFibre E) (Nat.cast_ne_zero.mpr hN)
+  have : Finite (Submodule.torsionBy ℤ (specialFibre E).toAffine.Point (N : ℤ)) :=
+    Nat.finite_of_card_ne_zero (by rw [hcardQ]; exact pow_ne_zero _ hN)
+  exact (specialiseTorsion_injective E hE hΔ hN).bijective_of_nat_card_le
+    (by rw [hcardH, hcardQ])
+
+end ModularCurve.HahnSpecialise
+
+theorem solution (E : WeierstrassCurve H) (hE : IntegralCoeffs E)
+    (hΔ : (specialFibre E).Δ ≠ 0) (N : ℕ) [NeZero N] :
+    Set.BijOn (specialise E hE hΔ) {P | N • P = 0} {Q | N • Q = 0} := by
+  have hN : N ≠ 0 := NeZero.ne N
+  refine ⟨fun P hP => ?_, fun P hP Q hQ h => specialise_injOn_nsmul_eq_zero E hE hΔ hN hP hQ h,
+    fun Q hQ => ?_⟩
+  · change N • specialise E hE hΔ P = 0
+    rw [← map_nsmul, show N • P = 0 from hP, map_zero]
+  · obtain ⟨P, hP⟩ := (ModularCurve.HahnSpecialise.specialiseTorsion_bijective E hE hΔ hN).2
+      ⟨Q, ModularCurve.HahnSpecialise.mem_torsionBy_of_nsmul_eq_zero hQ⟩
+    exact ⟨P, ModularCurve.HahnSpecialise.nsmul_eq_zero_of_mem_torsionBy P.2, congrArg Subtype.val
+      hP⟩
+
+end
+
+end S_ModularCurve_HahnSpecialise_specialise_bijOn_torsion
+end P2MW
+export P2MW.S_ModularCurve_HahnSpecialise_specialise_bijOn_torsion (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.B3 ModularCurve.HahnSpecialise
+open ModularCurve.TatePoint (Qbar H CycSubH)
+open scoped Classical
+theorem ModularCurve.HahnSpecialise.specialise_bijOn_torsion (E : WeierstrassCurve H)
+    (hE : IntegralCoeffs E)
+    (hΔ : (specialFibre E).Δ ≠ 0) (N : ℕ) [NeZero N] :
+    Set.BijOn (specialise E hE hΔ) {P | N • P = 0} {Q | N • Q = 0} :=
+  solution E hE hΔ N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_JOneES_exists_transcendental_finiteDimensional_laurentBaseChange.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_JOneES_exists_transcendental_finiteDimensional_laurentBaseChange.lean
new file mode 100644
index 0000000000..050f43cbdd
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_JOneES_exists_transcendental_finiteDimensional_laurentBaseChange.lean
@@ -0,0 +1,391 @@
+/-
+Based on Prove2Me node ModularCurve.JOneES.exists_transcendental_finiteDimensional_laurentBaseChange
+(2a4e1e30-2f75-59ed-922a-4db222b34095) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b8e3d605-22f9-51a1-a0b2-870f8c8c1969
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Data.Int.Star
+import Mathlib.RingTheory.Valuation.Integral
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_JOneES_exists_transcendental_finiteDimensional_qExpFunctionFieldC
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Base change of the q-expansion function field is a function field
+
+Theorem statement: `ModularCurve.JOneES.exists_transcendental_finiteDimensional_laurentBaseChange`
+(`2a4e1e30-2f75-59ed-922a-4db222b34095`), by Claude, 2026-09-05.
+
+Proof: submission `b8e3d605-22f9-51a1-a0b2-870f8c8c1969`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with an algebra structure over $\mathbb{Q}$, and let $\Gamma$ be a
+subgroup of $\mathrm{SL}_2(\mathbb{Z})$ of finite index containing the translation matrix
+`ModularGroup.T`. Write $F =$ [`ModularCurve.qExpFunctionFieldC ℚ Γ`](def/ModularCurve_X1.html#L101)
+for the intermediate field of the Laurent series field $\mathbb{Q}((q))$ over $\mathbb{Q}$ generated
+by the set `intFormRatiosC`, namely by all quotients $\mathrm{intSeriesC}\,\mathbb{Q}\,p_f /
+\mathrm{intSeriesC}\,\mathbb{Q}\,p_g$ where, for some weight $k \in \mathbb{Z}$, $f$ and $g$ are
+modular forms of weight $k$ for the image of $\Gamma$ in $\mathrm{GL}_2(\mathbb{R})$, $p_f, p_g$ are
+power series with integer coefficients satisfying the predicate `IsIntegralQExp` with respect to $f$
+and to $g$ respectively, and $\mathrm{intSeriesC}\,\mathbb{Q}\,p_g \neq 0$. Let `laurentBaseChange L
+F` be the intermediate field of $L((q))$ generated over $L$ by the image of $F$ under the
+coefficientwise ring homomorphism $\mathbb{Q}((q)) \to L((q))$ induced by $\mathbb{Q} \to L$. The
+assertion is that there exists an element $x$ of `laurentBaseChange L F` which is transcendental
+over $L$ and such that `laurentBaseChange L F` is finite-dimensional as a vector space over the
+intermediate field $L(x)$ generated over $L$ by $x$.
+
+This is the statement that the base change to $L$ of the $q$-expansion presentation of the function
+field of the modular curve attached to $\Gamma$ is an algebraic function field of one variable over
+$L$, obtained from the corresponding statement over $\mathbb{Q}$. It is the hypothesis under which
+the general theory of one-variable function fields (places, divisors, genus, Jacobian) is applied to
+modular curves in the subsequent development, and it is invoked throughout the treatment of $X_1(M)$
+and its Jacobian.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_JOneES_exists_transcendental_finiteDimensional_laurentBaseChange.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_JOneES_exists_transcendental_finiteDimensional_laurentBaseChange
+
+namespace JOneESAlgBC
+
+open HahnSeries Polynomial
+
+section A1
+
+variable {K : Type*} [Field K]
+
+theorem valuation_algebraMap_le_one (d : K) :
+    Valued.v (algebraMap K (LaurentSeries K) d) ≤ (1 : WithZero (Multiplicative ℤ)) := by
+  rw [show algebraMap K (LaurentSeries K) d = ((PowerSeries.C d : PowerSeries K) : LaurentSeries K)
+    by
+    rw [LaurentSeries.algebraMap_apply, HahnSeries.ofPowerSeries_C]]
+  rw [LaurentSeries.valuation_def, ← LaurentSeries.coe_algebraMap]
+  exact IsDedekindDomain.HeightOneSpectrum.valuation_le_one _ _
+
+theorem valuation_le_one_of_isAlgebraic {y : LaurentSeries K} (hy : IsAlgebraic K y) :
+    Valued.v y ≤ (1 : WithZero (Multiplicative ℤ)) := by
+  have hint : IsIntegral K y := hy.isIntegral
+  let v : Valuation (LaurentSeries K) (WithZero (Multiplicative ℤ)) := Valued.v
+  let O : Subring (LaurentSeries K) := v.integer
+  have hInt : v.Integers O := Valuation.integer.integers _
+  have hcoef : ∀ c : K, algebraMap K (LaurentSeries K) c ∈ O := fun c =>
+    (Valuation.mem_integer_iff _ _).2 (valuation_algebraMap_le_one c)
+  have hint' : IsIntegral O y := by
+    obtain ⟨p, hp, hpy⟩ := hint
+    let φ : K →+* O := (algebraMap K (LaurentSeries K)).codRestrict O hcoef
+    refine ⟨p.map φ, hp.map φ, ?_⟩
+    rw [Polynomial.eval₂_map]
+    have hcomp : (algebraMap O (LaurentSeries K)).comp φ = algebraMap K (LaurentSeries K) := by
+      ext c; rfl
+    rw [hcomp]
+    exact hpy
+  exact (Valuation.mem_integer_iff _ _).1 (hInt.mem_of_integral hint')
+
+theorem eq_C_of_isAlgebraic {y : LaurentSeries K} (hy : IsAlgebraic K y) :
+    ∃ c : K, y = HahnSeries.C c := by
+  refine ⟨y.coeff 0, ?_⟩
+  set z : LaurentSeries K := y - HahnSeries.C (y.coeff 0) with hz
+  have hzalg : IsAlgebraic K z := by
+    have h2 : IsAlgebraic K (algebraMap K (LaurentSeries K) (y.coeff 0)) := isAlgebraic_algebraMap _
+    rw [LaurentSeries.algebraMap_apply] at h2
+    exact hy.sub h2
+  have hy1 := valuation_le_one_of_isAlgebraic hy
+  have hy0 : ∀ m < (0 : ℤ), y.coeff m = 0 :=
+    (LaurentSeries.valuation_le_iff_coeff_lt_eq_zero K (D := 0) (f := y)).1 (by simpa using hy1)
+  have hcoef : ∀ n < (1 : ℤ), z.coeff n = 0 := by
+    intro n hn
+    rcases lt_or_eq_of_le (Int.lt_add_one_iff.mp (by simpa using hn) : n ≤ 0) with h | h
+    · simp [hz, HahnSeries.coeff_sub, hy0 n h, HahnSeries.C_apply, HahnSeries.coeff_single_of_ne
+        h.ne]
+    · subst h; simp [hz, HahnSeries.C_apply]
+  have hzval : Valued.v z ≤ WithZero.exp (-(1 : ℤ)) :=
+    (LaurentSeries.valuation_le_iff_coeff_lt_eq_zero K).2 hcoef
+  by_cases hz0 : z = 0
+  · exact (sub_eq_zero.mp hz0)
+  · exfalso
+    have h2 := valuation_le_one_of_isAlgebraic hzalg.inv
+    have hprod : Valued.v z * Valued.v z⁻¹ = (1 : WithZero (Multiplicative ℤ)) := by
+      rw [← map_mul, mul_inv_cancel₀ hz0, map_one]
+    have hlt : Valued.v z < (1 : WithZero (Multiplicative ℤ)) :=
+      lt_of_le_of_lt hzval (by
+        rw [← WithZero.exp_zero, WithZero.exp_lt_exp]; norm_num)
+    have := mul_lt_one_of_lt_of_le hlt h2
+    rw [hprod] at this
+    exact lt_irrefl _ this
+
+theorem transcendental_of_coeff_ne_zero {y : LaurentSeries K} {n : ℤ} (hn : n ≠ 0)
+    (hy : y.coeff n ≠ 0) : Transcendental K y := by
+  intro halg
+  obtain ⟨c, hc⟩ := eq_C_of_isAlgebraic halg
+  apply hy
+  rw [hc, HahnSeries.C_apply, HahnSeries.coeff_single_of_ne hn]
+
+end A1
+
+end JOneESAlgBC
+
+namespace JOneESBC
+
+open ModularCurve HahnSeries Polynomial IntermediateField
+
+variable (L : Type*) [Field L] [Algebra ℚ L] (F₀ : IntermediateField ℚ (LaurentSeries ℚ))
+
+omit [Algebra ℚ L] in
+theorem eq_C_of_forall_coeff_eq_zero {x : LaurentSeries ℚ} (h : ∀ n : ℤ, n ≠ 0 → x.coeff n = 0) :
+    x = HahnSeries.C (x.coeff 0) := by
+  ext n
+  by_cases hn : n = 0
+  · subst hn; rw [HahnSeries.C_apply, HahnSeries.coeff_single_same]
+  · rw [h n hn, HahnSeries.C_apply, HahnSeries.coeff_single_of_ne hn]
+
+theorem charZero_L : CharZero L :=
+  charZero_of_injective_algebraMap (algebraMap ℚ L).injective
+
+theorem transcendental_coeffEmb {x : LaurentSeries ℚ} (hx : Transcendental ℚ x) :
+    Transcendental L (coeffEmb L x) := by
+  have hC : ∀ c : ℚ, algebraMap ℚ (LaurentSeries ℚ) c = HahnSeries.C c :=
+    fun c => RingHom.congr_fun (Subsingleton.elim _ _) c
+  have hne : ∃ n : ℤ, n ≠ 0 ∧ x.coeff n ≠ 0 := by
+    by_contra hall
+    push Not at hall
+    apply hx
+    refine ⟨X - Polynomial.C (x.coeff 0), X_sub_C_ne_zero _, ?_⟩
+    rw [map_sub, aeval_X, aeval_C, hC, ← eq_C_of_forall_coeff_eq_zero (fun n hn => hall n hn),
+      sub_self]
+  obtain ⟨n, hn, hxn⟩ := hne
+  refine JOneESAlgBC.transcendental_of_coeff_ne_zero hn ?_
+  rw [coeffEmb_coeff]
+  exact (map_ne_zero_iff _ (algebraMap ℚ L).injective).mpr hxn
+
+omit [Algebra ℚ L] in
+theorem algebraMap_rat_eq_C : algebraMap ℚ (LaurentSeries ℚ) = HahnSeries.C := Subsingleton.elim _ _
+
+theorem coeffEmb_C (c : ℚ) :
+    coeffEmb L (HahnSeries.C c) = algebraMap L (LaurentSeries L) (algebraMap ℚ L c) := by
+  rw [algebraMap_laurentSeries_eq_single]
+  ext n
+  rw [coeffEmb_coeff, HahnSeries.C_apply]
+  by_cases hn : n = 0
+  · subst hn; simp
+  · rw [HahnSeries.coeff_single_of_ne hn, HahnSeries.coeff_single_of_ne hn, map_zero]
+
+theorem coeffEmb_mem_adjoin_of_mem_adjoin (x : LaurentSeries ℚ) {z : LaurentSeries ℚ}
+    (hz : z ∈ ℚ⟮x⟯) : coeffEmb L z ∈ L⟮coeffEmb L x⟯ := by
+  induction hz using IntermediateField.adjoin_induction with
+  | mem y hy =>
+    rw [Set.mem_singleton_iff] at hy
+    subst hy
+    exact IntermediateField.mem_adjoin_simple_self L _
+  | algebraMap c =>
+    rw [algebraMap_rat_eq_C, coeffEmb_C]
+    exact IntermediateField.algebraMap_mem _ _
+  | add y w _ _ hy hw => rw [map_add]; exact add_mem hy hw
+  | inv y _ hy => rw [map_inv₀]; exact inv_mem hy
+  | mul y w _ _ hy hw => rw [map_mul]; exact mul_mem hy hw
+
+omit [Algebra ℚ L] in
+theorem finiteDimensional_adjoin_of_extendScalars {A : Type*} [Field A] [Algebra L A]
+    (E : IntermediateField L A) (Y : E) (hle : L⟮(Y : A)⟯ ≤ E)
+    (hfin : Module.Finite L⟮(Y : A)⟯ (IntermediateField.extendScalars hle)) :
+    FiniteDimensional L⟮Y⟯ E := by
+  let e₁ : L⟮(Y : A)⟯ ≃+* L⟮Y⟯ :=
+    ((IntermediateField.liftAlgEquiv L⟮Y⟯).trans
+      (IntermediateField.equivOfEq (IntermediateField.lift_adjoin_simple L E Y))).symm.toRingEquiv
+  let e₂ : IntermediateField.extendScalars hle ≃+* E :=
+    { toFun := fun z => ⟨z.1, z.2⟩
+      invFun := fun z => ⟨z.1, z.2⟩
+      left_inv := fun _ => rfl
+      right_inv := fun _ => rfl
+      map_mul' := fun _ _ => rfl
+      map_add' := fun _ _ => rfl }
+  refine Module.Finite.of_equiv_equiv e₁ e₂ ?_
+  ext r
+  rfl
+
+omit [Algebra ℚ L] in
+theorem finite_adjoin_of_le {A : Type*} [Field A] [Algebra L A] (K₁ : IntermediateField L A)
+    (S T : Set A) [FiniteDimensional K₁ (IntermediateField.adjoin K₁ T)]
+    (hle : IntermediateField.adjoin K₁ S ≤ IntermediateField.adjoin K₁ T) :
+    FiniteDimensional K₁ (IntermediateField.adjoin K₁ S) :=
+  Module.Finite.of_injective (IntermediateField.inclusion hle).toLinearMap
+    (IntermediateField.inclusion_injective hle)
+
+omit [Algebra ℚ L] in
+theorem finite_extendScalars_of_adjoin {A : Type*} [Field A] [Algebra L A]
+    (K₁ : IntermediateField L A)
+    (S : Set A) (hle : K₁ ≤ IntermediateField.adjoin L S)
+    [FiniteDimensional K₁ (IntermediateField.adjoin K₁ S)] :
+    Module.Finite K₁ (IntermediateField.extendScalars hle) :=
+  Module.Finite.equiv
+    (IntermediateField.equivOfEq (IntermediateField.extendScalars_adjoin hle)).symm.toLinearEquiv
+
+theorem finite_extendScalars (X₀ : F₀) [FiniteDimensional ℚ⟮X₀⟯ F₀]
+    (hle : L⟮coeffEmb L (X₀ : LaurentSeries ℚ)⟯ ≤
+      IntermediateField.adjoin L (⇑(coeffEmb L) '' (F₀ : Set (LaurentSeries ℚ)))) :
+    Module.Finite L⟮coeffEmb L (X₀ : LaurentSeries ℚ)⟯ (IntermediateField.extendScalars hle) := by
+  classical
+  have := charZero_L L
+  have : Module.Free ℚ⟮X₀⟯ F₀ := Module.Free.of_divisionRing _ _
+  let bF := Module.finBasis ℚ⟮X₀⟯ F₀
+  let T : Set (LaurentSeries L) := Set.range fun j => coeffEmb L ((bF j : F₀) : LaurentSeries ℚ)
+  have : Finite T := Set.finite_range _ |>.to_subtype
+  have hcoeQ : ∀ c : ℚ, ((algebraMap ℚ F₀ c : F₀) : LaurentSeries ℚ) = algebraMap ℚ (LaurentSeries
+    ℚ) c :=
+    fun c => RingHom.congr_fun (Subsingleton.elim
+      ((algebraMap F₀ (LaurentSeries ℚ)).comp (algebraMap ℚ F₀)) (algebraMap ℚ (LaurentSeries ℚ))) c
+  have hval : ∀ z : F₀, z ∈ ℚ⟮X₀⟯ → (z : LaurentSeries ℚ) ∈ ℚ⟮(X₀ : LaurentSeries ℚ)⟯ := by
+    intro z hz
+    induction hz using IntermediateField.adjoin_induction with
+    | mem y hy =>
+      rw [Set.mem_singleton_iff] at hy
+      subst hy
+      exact IntermediateField.mem_adjoin_simple_self ℚ _
+    | algebraMap c =>
+      rw [hcoeQ]
+      exact IntermediateField.algebraMap_mem _ _
+    | add y w _ _ hy hw => rw [AddMemClass.coe_add]; exact add_mem hy hw
+    | inv y _ hy =>
+      rw [show ((y⁻¹ : F₀) : LaurentSeries ℚ) = ((y : F₀) : LaurentSeries ℚ)⁻¹ from rfl]
+      exact inv_mem hy
+    | mul y w _ _ hy hw => rw [MulMemClass.coe_mul]; exact mul_mem hy hw
+  have hmemK₁ : ∀ r : ℚ⟮X₀⟯, coeffEmb L ((r : F₀) : LaurentSeries ℚ) ∈ L⟮coeffEmb L (X₀ :
+    LaurentSeries ℚ)⟯ :=
+    fun r => coeffEmb_mem_adjoin_of_mem_adjoin L _ (hval r r.2)
+  let ψ : ℚ⟮X₀⟯ →+* L⟮coeffEmb L (X₀ : LaurentSeries ℚ)⟯ :=
+    { toFun := fun r => ⟨coeffEmb L ((r : F₀) : LaurentSeries ℚ), hmemK₁ r⟩
+      map_one' := Subtype.ext (by simp)
+      map_mul' := fun a b => Subtype.ext (by simp)
+      map_zero' := Subtype.ext (by simp)
+      map_add' := fun a b => Subtype.ext (by simp) }
+  let Φ : F₀ →+* LaurentSeries L := (coeffEmb L).comp (algebraMap F₀ (LaurentSeries ℚ))
+  have hΦψ : Φ.comp (algebraMap ℚ⟮X₀⟯ F₀) =
+      (algebraMap L⟮coeffEmb L (X₀ : LaurentSeries ℚ)⟯ (LaurentSeries L)).comp ψ :=
+    RingHom.ext fun _ => rfl
+  have hint : ∀ t ∈ T, IsIntegral L⟮coeffEmb L (X₀ : LaurentSeries ℚ)⟯ t := by
+    rintro _ ⟨j, rfl⟩
+    have hb : IsIntegral ℚ⟮X₀⟯ (bF j) := IsIntegral.of_finite _ _
+    obtain ⟨P, hPm, hP⟩ := hb
+    refine ⟨P.map ψ, hPm.map ψ, ?_⟩
+    rw [Polynomial.eval₂_map, ← hΦψ]
+    have := Polynomial.hom_eval₂ P (algebraMap ℚ⟮X₀⟯ F₀) Φ (bF j)
+    rw [hP, map_zero] at this
+    exact this.symm
+  have hfinT : FiniteDimensional L⟮coeffEmb L (X₀ : LaurentSeries ℚ)⟯
+      (IntermediateField.adjoin L⟮coeffEmb L (X₀ : LaurentSeries ℚ)⟯ T) :=
+    IntermediateField.finiteDimensional_adjoin hint
+  have hST : (⇑(coeffEmb L) '' (F₀ : Set (LaurentSeries ℚ))) ⊆
+      (IntermediateField.adjoin L⟮coeffEmb L (X₀ : LaurentSeries ℚ)⟯ T : Set _) := by
+    rintro _ ⟨y, hy, rfl⟩
+    have hrepr := bF.sum_repr ⟨y, hy⟩
+    have hy' : coeffEmb L y = ∑ j, coeffEmb L (((bF.repr ⟨y, hy⟩ j : ℚ⟮X₀⟯) : F₀) : LaurentSeries ℚ)
+      *
+        coeffEmb L ((bF j : F₀) : LaurentSeries ℚ) := by
+      have := congrArg (fun w : F₀ => coeffEmb L (w : LaurentSeries ℚ)) hrepr
+      simp only at this
+      rw [← this, IntermediateField.coe_sum, map_sum]
+      refine Finset.sum_congr rfl fun j _ => ?_
+      rw [Algebra.smul_def, MulMemClass.coe_mul, IntermediateField.algebraMap_apply, map_mul]
+    rw [SetLike.mem_coe, hy']
+    refine sum_mem fun j _ => ?_
+    refine mul_mem ?_ (IntermediateField.subset_adjoin _ T ⟨j, rfl⟩)
+    exact IntermediateField.algebraMap_mem
+      (IntermediateField.adjoin L⟮coeffEmb L (X₀ : LaurentSeries ℚ)⟯ T) (ψ (bF.repr ⟨y, hy⟩ j))
+  have hle' : IntermediateField.adjoin L⟮coeffEmb L (X₀ : LaurentSeries ℚ)⟯
+        (⇑(coeffEmb L) '' (F₀ : Set (LaurentSeries ℚ))) ≤
+      IntermediateField.adjoin L⟮coeffEmb L (X₀ : LaurentSeries ℚ)⟯ T :=
+    IntermediateField.adjoin_le_iff.mpr hST
+  have hfinS : FiniteDimensional L⟮coeffEmb L (X₀ : LaurentSeries ℚ)⟯
+      (IntermediateField.adjoin L⟮coeffEmb L (X₀ : LaurentSeries ℚ)⟯
+        (⇑(coeffEmb L) '' (F₀ : Set (LaurentSeries ℚ)))) :=
+    finite_adjoin_of_le L _ _ T hle'
+  exact finite_extendScalars_of_adjoin L _ _ hle
+
+theorem exists_transcendental_finiteDimensional_laurentBaseChange
+    (h : ∃ x : F₀, Transcendental ℚ x ∧ FiniteDimensional ℚ⟮x⟯ F₀) :
+    ∃ y : laurentBaseChange L F₀, Transcendental L y ∧
+      FiniteDimensional L⟮y⟯ (laurentBaseChange L F₀) := by
+  classical
+  have := charZero_L L
+  obtain ⟨X₀, hX₀, hfin⟩ := h
+  have := hfin
+  have hxE : coeffEmb L (X₀ : LaurentSeries ℚ) ∈ laurentBaseChange L F₀ :=
+    coeffEmb_mem_laurentBaseChange L X₀.2
+  let Y : laurentBaseChange L F₀ := ⟨coeffEmb L (X₀ : LaurentSeries ℚ), hxE⟩
+  have hxtr : Transcendental ℚ (X₀ : LaurentSeries ℚ) := by
+    rintro ⟨r, hr0, hr⟩
+    refine hX₀ ⟨r, hr0, ?_⟩
+    apply Subtype.val_injective
+    have := Polynomial.hom_eval₂ r (algebraMap ℚ F₀) (algebraMap F₀ (LaurentSeries ℚ)) X₀
+    rw [Polynomial.aeval_def, ZeroMemClass.coe_zero, ← IntermediateField.algebraMap_apply, this,
+      Subsingleton.elim ((algebraMap F₀ (LaurentSeries ℚ)).comp (algebraMap ℚ F₀))
+        (algebraMap ℚ (LaurentSeries ℚ)), ← Polynomial.aeval_def]
+    exact hr
+  have hYtr : Transcendental L Y := by
+    rintro ⟨r, hr0, hr⟩
+    refine transcendental_coeffEmb L hxtr ⟨r, hr0, ?_⟩
+    have := Polynomial.hom_eval₂ r (algebraMap L (laurentBaseChange L F₀))
+      (algebraMap (laurentBaseChange L F₀) (LaurentSeries L)) Y
+    rw [← IsScalarTower.algebraMap_eq] at this
+    rw [Polynomial.aeval_def, show coeffEmb L (X₀ : LaurentSeries ℚ) =
+      algebraMap (laurentBaseChange L F₀) (LaurentSeries L) Y from rfl, ← this,
+      ← Polynomial.aeval_def, hr, map_zero]
+  refine ⟨Y, hYtr, ?_⟩
+  have hle : L⟮coeffEmb L (X₀ : LaurentSeries ℚ)⟯ ≤ laurentBaseChange L F₀ :=
+    IntermediateField.adjoin_le_iff.mpr (Set.singleton_subset_iff.mpr hxE)
+  exact finiteDimensional_adjoin_of_extendScalars L (laurentBaseChange L F₀) Y hle
+    (finite_extendScalars L F₀ X₀ hle)
+
+end JOneESBC
+
+theorem solution
+    (L : Type*) [Field L] [Algebra ℚ L]
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hT : ModularGroup.T ∈ Γ) :
+    ∃ x : ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ),
+      Transcendental L x ∧
+      FiniteDimensional
+        (IntermediateField.adjoin L
+          ({x} : Set (ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ))))
+        (ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ)) :=
+  JOneESBC.exists_transcendental_finiteDimensional_laurentBaseChange L _
+    (ModularCurve.JOneES.exists_transcendental_finiteDimensional_qExpFunctionFieldC Γ hT)
+
+end S_ModularCurve_JOneES_exists_transcendental_finiteDimensional_laurentBaseChange
+end P2MW
+export P2MW.S_ModularCurve_JOneES_exists_transcendental_finiteDimensional_laurentBaseChange
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.JOneES.exists_transcendental_finiteDimensional_laurentBaseChange
+    (L : Type*) [Field L] [Algebra ℚ L]
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hT : ModularGroup.T ∈ Γ) :
+    ∃ x : ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ),
+      Transcendental L x ∧
+      FiniteDimensional
+        (IntermediateField.adjoin L
+          ({x} : Set (ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ))))
+        (ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ)) :=
+  solution L Γ hT
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_JOneES_exists_transcendental_finiteDimensional_qExpFunctionFieldC.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_JOneES_exists_transcendental_finiteDimensional_qExpFunctionFieldC.lean
new file mode 100644
index 0000000000..e900c2881c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_JOneES_exists_transcendental_finiteDimensional_qExpFunctionFieldC.lean
@@ -0,0 +1,1109 @@
+/-
+Based on Prove2Me node
+ModularCurve.JOneES.exists_transcendental_finiteDimensional_qExpFunctionFieldC
+(e1e4047a-27d8-5d03-8987-2e97cdbcffa3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6a875af3-0033-56a6-b1b0-6c3d39a4eb81
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Algebra.Polynomial.Homogenize
+import Mathlib.LinearAlgebra.Lagrange
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+import Mathlib.NumberTheory.ModularForms.NormTrace
+import Mathlib.RingTheory.Valuation.Integral
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The q-expansion function field over ℚ is a one-variable function field
+
+Theorem statement: `ModularCurve.JOneES.exists_transcendental_finiteDimensional_qExpFunctionFieldC`
+(`e1e4047a-27d8-5d03-8987-2e97cdbcffa3`), by Claude, 2026-09-05.
+
+Proof: submission `6a875af3-0033-56a6-b1b0-6c3d39a4eb81`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of $\mathrm{SL}_2(\mathbb{Z})$ of finite index containing the translation
+matrix $T = \begin{pmatrix}1&1\\0&1\end{pmatrix}$ (`ModularGroup.T`). Consider the intermediate
+field [`ModularCurve.qExpFunctionFieldC ℚ Γ`](def/ModularCurve_X1.html#L101) of the field of formal
+Laurent series over $\mathbb{Q}$: by definition it is the subfield generated over $\mathbb{Q}$ by
+the set `intFormRatiosC`, consisting of those Laurent series of the form `intSeriesC ℚ pf /
+intSeriesC ℚ pg`, where for some weight $k \in \mathbb{Z}$ there are modular forms $f, g$ of weight
+$k$ for the image of $\Gamma$ in $\mathrm{GL}_2(\mathbb{R})$ and power series $pf, pg$ with integer
+coefficients satisfying the predicates `IsIntegralQExp f pf` and `IsIntegralQExp g pg`, with
+`intSeriesC ℚ pg` nonzero; here `intSeriesC ℚ p` denotes the Laurent series over $\mathbb{Q}$
+attached to an integral power series $p$. The theorem asserts that this field contains an element
+$x$ which is transcendental over $\mathbb{Q}$ and for which the whole field is finite-dimensional as
+a vector space over the intermediate field $\mathbb{Q}(x)$ obtained by adjoining $x$ to $\mathbb{Q}$
+inside it. No particular such $x$, and no bound on the degree, is asserted.
+
+This is the basic finiteness statement making the $q$-expansion presentation of the modular curve
+attached to $\Gamma$ into an algebraic function field of one variable over $\mathbb{Q}$, in the
+classical form obtained from $j$ (or $E_6^2/E_4^3$) together with the finiteness of the index of
+$\Gamma$. It is the hypothesis under which the general theory of one-variable function fields
+(places, divisor classes, genus, torsion in $\mathrm{Pic}^0$) is applied to these fields, and is
+used by the corresponding statement after base change of the coefficient field and in the
+construction of smooth proper models of modular curves with their Galois-compatible structure.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_JOneES_exists_transcendental_finiteDimensional_qExpFunctionFieldC.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_ModularCurve_JOneES_exists_transcendental_finiteDimensional_qExpFunctionFieldC
+
+namespace JOneESAlg
+
+open HahnSeries Polynomial
+
+section A1
+
+variable {K : Type*} [Field K]
+
+theorem valuation_algebraMap_le_one (d : K) :
+    Valued.v (algebraMap K (LaurentSeries K) d) ≤ (1 : WithZero (Multiplicative ℤ)) := by
+  rw [show algebraMap K (LaurentSeries K) d = ((PowerSeries.C d : PowerSeries K) : LaurentSeries K)
+    by
+    rw [LaurentSeries.algebraMap_apply, HahnSeries.ofPowerSeries_C]]
+  rw [LaurentSeries.valuation_def, ← LaurentSeries.coe_algebraMap]
+  exact IsDedekindDomain.HeightOneSpectrum.valuation_le_one _ _
+
+theorem valuation_le_one_of_isAlgebraic {y : LaurentSeries K} (hy : IsAlgebraic K y) :
+    Valued.v y ≤ (1 : WithZero (Multiplicative ℤ)) := by
+  have hint : IsIntegral K y := hy.isIntegral
+  let v : Valuation (LaurentSeries K) (WithZero (Multiplicative ℤ)) := Valued.v
+  let O : Subring (LaurentSeries K) := v.integer
+  have hInt : v.Integers O := Valuation.integer.integers _
+  have hcoef : ∀ c : K, algebraMap K (LaurentSeries K) c ∈ O := fun c =>
+    (Valuation.mem_integer_iff _ _).2 (valuation_algebraMap_le_one c)
+  have hint' : IsIntegral O y := by
+    obtain ⟨p, hp, hpy⟩ := hint
+    let φ : K →+* O := (algebraMap K (LaurentSeries K)).codRestrict O hcoef
+    refine ⟨p.map φ, hp.map φ, ?_⟩
+    rw [Polynomial.eval₂_map]
+    have hcomp : (algebraMap O (LaurentSeries K)).comp φ = algebraMap K (LaurentSeries K) := by
+      ext c; rfl
+    rw [hcomp]
+    exact hpy
+  exact (Valuation.mem_integer_iff _ _).1 (hInt.mem_of_integral hint')
+
+theorem eq_C_of_isAlgebraic {y : LaurentSeries K} (hy : IsAlgebraic K y) :
+    ∃ c : K, y = HahnSeries.C c := by
+  refine ⟨y.coeff 0, ?_⟩
+  set z : LaurentSeries K := y - HahnSeries.C (y.coeff 0) with hz
+  have hzalg : IsAlgebraic K z := by
+    have h2 : IsAlgebraic K (algebraMap K (LaurentSeries K) (y.coeff 0)) := isAlgebraic_algebraMap _
+    rw [LaurentSeries.algebraMap_apply] at h2
+    exact hy.sub h2
+  have hy1 := valuation_le_one_of_isAlgebraic hy
+  have hy0 : ∀ m < (0 : ℤ), y.coeff m = 0 :=
+    (LaurentSeries.valuation_le_iff_coeff_lt_eq_zero K (D := 0) (f := y)).1 (by simpa using hy1)
+  have hcoef : ∀ n < (1 : ℤ), z.coeff n = 0 := by
+    intro n hn
+    rcases lt_or_eq_of_le (Int.lt_add_one_iff.mp (by simpa using hn) : n ≤ 0) with h | h
+    · simp [hz, HahnSeries.coeff_sub, hy0 n h, HahnSeries.C_apply, HahnSeries.coeff_single_of_ne
+        h.ne]
+    · subst h; simp [hz, HahnSeries.C_apply]
+  have hzval : Valued.v z ≤ WithZero.exp (-(1 : ℤ)) :=
+    (LaurentSeries.valuation_le_iff_coeff_lt_eq_zero K).2 hcoef
+  by_cases hz0 : z = 0
+  · exact (sub_eq_zero.mp hz0)
+  · exfalso
+    have h2 := valuation_le_one_of_isAlgebraic hzalg.inv
+    have hprod : Valued.v z * Valued.v z⁻¹ = (1 : WithZero (Multiplicative ℤ)) := by
+      rw [← map_mul, mul_inv_cancel₀ hz0, map_one]
+    have hlt : Valued.v z < (1 : WithZero (Multiplicative ℤ)) :=
+      lt_of_le_of_lt hzval (by
+        rw [← WithZero.exp_zero, WithZero.exp_lt_exp]; norm_num)
+    have := mul_lt_one_of_lt_of_le hlt h2
+    rw [hprod] at this
+    exact lt_irrefl _ this
+
+end A1
+
+section A2
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+
+theorem linearIndependent_map {ι : Type*} {v : ι → LaurentSeries K} (hv : LinearIndependent K v) :
+    LinearIndependent L (fun i => HahnSeries.map (v i) (algebraMap K L)) := by
+  classical
+  rw [linearIndependent_iff']
+  intro s c hsum i hi
+  let W : Submodule K L := Submodule.span K (Set.range fun j : s => c j)
+  have : Module.Finite K W := Module.Finite.span_of_finite K (Set.finite_range _)
+  let b := Module.finBasis K W
+  have hcW : ∀ j : s, c j ∈ W := fun j => Submodule.subset_span ⟨j, rfl⟩
+  let a : s → Fin (Module.finrank K W) → K := fun j l => b.repr ⟨c j, hcW j⟩ l
+  have hca : ∀ j : s, c j = ∑ l, a j l • (b l : L) := by
+    intro j
+    have h1 := b.sum_repr ⟨c j, hcW j⟩
+    have h2 := congrArg (Submodule.subtype W) h1
+    rw [map_sum] at h2
+    simp only [Submodule.subtype_apply, Submodule.coe_smul] at h2
+    exact h2.symm
+  have hcoeff : ∀ n : ℤ, ∑ j ∈ s, c j * algebraMap K L ((v j).coeff n) = 0 := by
+    intro n
+    have := congrArg (fun x : LaurentSeries L => x.coeff n) hsum
+    simpa [HahnSeries.coeff_sum] using this
+  have hbi : LinearIndependent K (fun l' => (b l' : L)) :=
+    b.linearIndependent.map' W.subtype (Submodule.ker_subtype W)
+  have hv' : LinearIndependent K (fun j : s => v j) := hv.comp _ Subtype.val_injective
+  have hrel : ∀ l, ∑ j : s, a j l • v j = 0 := by
+    intro l
+    ext n
+    have h1 : ∑ l', (∑ j : s, a j l' * (v j).coeff n) • (b l' : L) = 0 := by
+      have h0 := hcoeff n
+      rw [← Finset.sum_coe_sort] at h0
+      simp_rw [hca, Finset.sum_mul] at h0
+      rw [Finset.sum_comm] at h0
+      rw [← h0]
+      refine Finset.sum_congr rfl fun l' _ => ?_
+      rw [Finset.sum_smul]
+      refine Finset.sum_congr rfl fun j _ => ?_
+      rw [Algebra.smul_def, Algebra.smul_def, map_mul]; ring
+    have := Fintype.linearIndependent_iff.mp hbi (fun l' => ∑ j : s, a j l' * (v j).coeff n) h1 l
+    rw [HahnSeries.coeff_sum]
+    simpa [HahnSeries.coeff_smul] using this
+  have ha : ∀ (j : s) l, a j l = 0 := fun j l =>
+    Fintype.linearIndependent_iff.mp hv' (fun j => a j l) (hrel l) j
+  rw [show c i = c (⟨i, hi⟩ : s) from rfl, hca]
+  simp [ha]
+
+end A2
+
+section A3
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem finiteDimensional_of_forall_aeval_eq_zero [PerfectField K] (D : ℕ)
+    (h : ∀ y : F, ∃ p : K[X], p ≠ 0 ∧ p.natDegree ≤ D ∧ aeval y p = 0) :
+    FiniteDimensional K F := by
+  have : Algebra.IsAlgebraic K F := ⟨fun y => by
+    obtain ⟨p, hp0, -, hpy⟩ := h y
+    exact ⟨p, hp0, hpy⟩⟩
+  have : Algebra.IsSeparable K F := Algebra.IsAlgebraic.isSeparable_of_perfectField
+  by_contra hinf
+  obtain ⟨L, hLfd, hlt⟩ := IntermediateField.exists_lt_finrank_of_infinite_dimensional hinf D
+  have := hLfd
+  have : Algebra.IsSeparable K L := Algebra.isSeparable_tower_bot_of_isSeparable K L F
+  obtain ⟨α, hα⟩ := Field.exists_primitive_element K L
+  have hdeg : (minpoly K α).natDegree = Module.finrank K L :=
+    (Field.primitive_element_iff_minpoly_natDegree_eq K α).mp hα
+  obtain ⟨p, hp0, hpD, hpy⟩ := h (α : F)
+  have hmin : minpoly K α = minpoly K (α : F) := IntermediateField.minpoly_eq α
+  have hle : (minpoly K (α : F)).natDegree ≤ p.natDegree :=
+    Polynomial.natDegree_le_of_dvd (minpoly.dvd K _ hpy) hp0
+  have : Module.finrank K L ≤ D := by
+    rw [← hdeg, hmin]
+    exact hle.trans hpD
+  exact absurd hlt (not_lt.mpr this)
+
+end A3
+
+end JOneESAlg
+
+namespace JOneESLevelOne
+
+open ModularForm UpperHalfPlane EisensteinSeries
+open scoped MatrixGroups
+
+noncomputable abbrev q4 : PowerSeries ℂ := qExpansion 1 (E₄ : ℍ → ℂ)
+noncomputable abbrev q6 : PowerSeries ℂ := qExpansion 1 (E₆ : ℍ → ℂ)
+
+noncomputable def monomialSpan (m : ℕ) : Submodule ℂ (PowerSeries ℂ) :=
+  Submodule.span ℂ (Set.range fun b : Fin (m + 1) => q4 ^ (3 * (m - b)) * q6 ^ (2 * (b : ℕ)))
+
+theorem monomial_mem (m : ℕ) (b : ℕ) (hb : b ≤ m) :
+    q4 ^ (3 * (m - b)) * q6 ^ (2 * b) ∈ monomialSpan m :=
+  Submodule.subset_span ⟨⟨b, Nat.lt_succ_of_le hb⟩, rfl⟩
+
+theorem q4_coeff_zero : PowerSeries.coeff 0 q4 = 1 :=
+  E_qExpansion_coeff_zero (by norm_num) (by decide)
+
+theorem qExpansion_discriminant :
+    qExpansion 1 (CuspForm.discriminant : ℍ → ℂ) = (1728 : ℂ)⁻¹ • (q4 ^ 3 - q6 ^ 2) := by
+  let A : ModularForm 𝒮ℒ 12 := (E₄.pow 3).mcast (by norm_num)
+  let B : ModularForm 𝒮ℒ 12 := (E₆.pow 2).mcast (by norm_num)
+  have hfun : (CuspForm.discriminant : ℍ → ℂ) = ⇑((1728 : ℂ)⁻¹ • (A - B)) := by
+    funext z
+    rw [CuspForm.coe_discriminant, discriminant_eq_E₄_cube_sub_E₆_sq]
+    rw [smul_apply, sub_apply]
+    simp only [A, B, coe_mcast, coe_pow, Pi.pow_apply, smul_eq_mul]
+    ring
+  rw [hfun, FunLike.coe_smul, ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL,
+    FunLike.coe_sub, ModularForm.qExpansion_sub one_pos one_mem_strictPeriods_SL]
+  simp only [A, B, ModularForm.qExpansion_mcast,
+    ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+
+theorem qExpansion_mem_monomialSpan (m : ℕ)
+    (h : ModularForm 𝒮ℒ (12 * (m : ℤ))) :
+    qExpansion 1 (h : ℍ → ℂ) ∈ monomialSpan m := by
+  have aux : ∀ (m : ℕ) (k : ℤ), k = 12 * (m : ℤ) →
+      ∀ h : ModularForm 𝒮ℒ k, qExpansion 1 (h : ℍ → ℂ) ∈ monomialSpan m := by
+    intro m
+    induction m with
+      | zero =>
+        intro k hk h
+        simp only [Nat.cast_zero, mul_zero] at hk
+        subst hk
+        obtain ⟨c, hc⟩ := ModularFormClass.levelOne_weight_zero_const h
+        have hh : h = c • (1 : ModularForm 𝒮ℒ 0) := by
+          ext z
+          rw [hc, smul_apply]
+          simp
+        rw [hh, FunLike.coe_smul, ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL,
+          ModularForm.qExpansion_one]
+        refine Submodule.smul_mem _ _ ?_
+        have := monomial_mem 0 0 le_rfl
+        simpa using this
+      | succ m ih =>
+        intro k hk h
+        set a₀ : ℂ := PowerSeries.coeff 0 (qExpansion 1 (h : ℍ → ℂ)) with ha₀
+        let P : ModularForm 𝒮ℒ k := (E₄.pow (3 * (m + 1))).mcast (by rw [hk]; push_cast; ring)
+        have hP : qExpansion 1 (P : ℍ → ℂ) = q4 ^ (3 * (m + 1)) := by
+          simp only [P, ModularForm.qExpansion_mcast,
+            ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+        let g : ModularForm 𝒮ℒ k := h - a₀ • P
+        have hg : qExpansion 1 (g : ℍ → ℂ) = qExpansion 1 (h : ℍ → ℂ) - a₀ • q4 ^ (3 * (m + 1)) :=
+          by
+          simp only [g]
+          rw [FunLike.coe_sub, ModularForm.qExpansion_sub one_pos one_mem_strictPeriods_SL,
+            FunLike.coe_smul,
+            ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL, hP]
+        have hg0 : PowerSeries.coeff 0 (qExpansion 1 (g : ℍ → ℂ)) = 0 := by
+          have h4 : PowerSeries.coeff 0 (q4 ^ (3 * (m + 1))) = 1 := by
+            rw [PowerSeries.coeff_zero_eq_constantCoeff_apply, map_pow,
+              ← PowerSeries.coeff_zero_eq_constantCoeff_apply, q4_coeff_zero, one_pow]
+          rw [hg, map_sub, map_smul, h4, smul_eq_mul, mul_one, ha₀, sub_self]
+        have hΔ := ModularForm.qExpansion_eq_qExpansion_discriminant_mul g hg0
+        rw [← CuspForm.coe_discriminant] at hΔ
+        have hk' : k - 12 = 12 * (m : ℤ) := by rw [hk]; push_cast; ring
+        have hIH := ih (k - 12) hk' (CuspForm.discriminantEquiv (g.toCuspForm hg0))
+        have hh : qExpansion 1 (h : ℍ → ℂ) =
+            a₀ • q4 ^ (3 * (m + 1)) + (1728 : ℂ)⁻¹ • (q4 ^ 3 - q6 ^ 2) *
+              qExpansion 1 (CuspForm.discriminantEquiv (g.toCuspForm hg0) : ℍ → ℂ) := by
+          rw [← qExpansion_discriminant, ← hΔ, hg]; abel
+        rw [hh]
+        refine Submodule.add_mem _ (Submodule.smul_mem _ _ ?_) ?_
+        · have := monomial_mem (m + 1) 0 (Nat.zero_le _)
+          simpa using this
+        · rw [smul_mul_assoc]
+          refine Submodule.smul_mem _ _ ?_
+          refine Submodule.span_induction (p := fun x _ => (q4 ^ 3 - q6 ^ 2) * x ∈ monomialSpan (m +
+            1))
+            ?_ ?_ ?_ ?_ hIH
+          · rintro _ ⟨b, rfl⟩
+            have hb : (b : ℕ) ≤ m := Nat.lt_succ_iff.mp b.2
+            rw [sub_mul]
+            refine Submodule.sub_mem _ ?_ ?_
+            · have := monomial_mem (m + 1) b (hb.trans (Nat.le_succ m))
+              rw [show 3 * (m + 1 - (b : ℕ)) = 3 + 3 * (m - b) by omega, pow_add, mul_assoc] at this
+              exact this
+            · have := monomial_mem (m + 1) (b + 1) (Nat.succ_le_succ hb)
+              rw [show 3 * (m + 1 - ((b : ℕ) + 1)) = 3 * (m - b) by omega,
+                show 2 * ((b : ℕ) + 1) = 2 * b + 2 by ring, pow_add] at this
+              rw [show q6 ^ 2 * (q4 ^ (3 * (m - ↑b)) * q6 ^ (2 * ↑b)) =
+                q4 ^ (3 * (m - ↑b)) * (q6 ^ (2 * ↑b) * q6 ^ 2) by ring]
+              exact this
+          · simp
+          · intro x y _ _ hx hy
+            rw [mul_add]
+            exact Submodule.add_mem _ hx hy
+          · intro c x _ hx
+            rw [mul_smul_comm]
+            exact Submodule.smul_mem _ _ hx
+  exact aux m _ rfl h
+
+end JOneESLevelOne
+
+namespace JOneESNorm
+
+open ModularForm UpperHalfPlane SlashInvariantForm Polynomial
+open scoped MatrixGroups ModularForm
+
+variable {Γ : Subgroup SL(2, ℤ)} [Γ.FiniteIndex] {k : ℤ}
+
+abbrev Cos (Γ : Subgroup SL(2, ℤ)) : Type := ↥𝒮ℒ ⧸ (Γ : Subgroup (GL (Fin 2) ℝ)).subgroupOf 𝒮ℒ
+
+noncomputable scoped instance : Fintype (Cos Γ) := Fintype.ofFinite _
+
+omit [Γ.FiniteIndex] in
+set_option backward.isDefEq.respectTransparency.types false in
+theorem one_mem_strictPeriods (hT : ModularGroup.T ∈ Γ) :
+    (1 : ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  rw [Subgroup.mem_strictPeriods_iff]
+  refine ⟨ModularGroup.T, hT, ?_⟩
+  ext i j
+  fin_cases i <;> fin_cases j <;>
+  simp [ModularGroup.T, Matrix.GeneralLinearGroup.upperRightHom]
+
+section Linear
+
+variable (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+
+omit [Γ.FiniteIndex] in
+theorem quotientFunc_smul_sub (c : ℂ) (q : (Cos Γ)) :
+    quotientFunc (c • g - f) q = c • quotientFunc g q - quotientFunc f q := by
+  induction q using Quotient.inductionOn with
+  | h r =>
+    simp only [quotientFunc_mk]
+    obtain ⟨γ, hγ⟩ := r.2
+    have hr : (r.val)⁻¹ = ((γ⁻¹ : SL(2, ℤ)) : GL (Fin 2) ℝ) := by rw [← hγ, ← map_inv]; rfl
+    rw [hr, ← ModularForm.SL_slash, ← ModularForm.SL_slash, ← ModularForm.SL_slash,
+      FunLike.coe_sub, FunLike.coe_smul, sub_eq_add_neg, SlashAction.add_slash,
+      SlashAction.neg_slash, ModularForm.SL_smul_slash, sub_eq_add_neg]
+
+theorem norm_smul_sub_apply (c : ℂ) (τ : ℍ) :
+    (ModularForm.norm 𝒮ℒ (c • g - f)) τ = ∏ q : (Cos Γ), (c * quotientFunc g q τ - quotientFunc f q
+      τ) := by
+  have h := ModularForm.coe_norm 𝒮ℒ (c • g - f)
+  rw [h]
+  rw [Finset.prod_apply]
+  refine Fintype.prod_congr _ _ (fun q => ?_)
+  rw [quotientFunc_smul_sub]
+  simp
+
+noncomputable def charPolyAt (τ : ℍ) : ℂ[X] :=
+  ∏ q : (Cos Γ), (C (quotientFunc g q τ) * X - C (quotientFunc f q τ))
+
+theorem eval_charPolyAt (c : ℂ) (τ : ℍ) :
+    (charPolyAt f g τ).eval c = (ModularForm.norm 𝒮ℒ (c • g - f)) τ := by
+  rw [norm_smul_sub_apply, charPolyAt, eval_prod]
+  refine Finset.prod_congr rfl fun q _ => ?_
+  simp only [eval_sub, eval_mul, eval_C, eval_X]
+  ring
+
+theorem natDegree_linear_le (a b : ℂ) : (C a * X - C b).natDegree ≤ 1 := by
+  refine (natDegree_sub_le _ _).trans ?_
+  refine max_le ?_ (by simp)
+  exact (natDegree_C_mul_le _ _).trans (by simp)
+
+theorem card_cos : (Finset.univ : Finset (Cos Γ)).card = Nat.card (Cos Γ) := by
+  rw [Nat.card_eq_fintype_card, Finset.card_univ]
+
+theorem natDegree_charPolyAt_le (τ : ℍ) : (charPolyAt f g τ).natDegree ≤ Nat.card (Cos Γ) := by
+  rw [charPolyAt]
+  refine (natDegree_prod_le _ _).trans ?_
+  refine (Finset.sum_le_sum fun q _ => natDegree_linear_le
+    (quotientFunc g q τ) (quotientFunc f q τ)).trans ?_
+  rw [Finset.sum_const, smul_eq_mul, mul_one, card_cos]
+
+theorem coeff_charPolyAt_card (τ : ℍ) :
+    (charPolyAt f g τ).coeff (Nat.card (Cos Γ)) = (ModularForm.norm 𝒮ℒ g) τ := by
+  have hc : (Finset.univ : Finset (Cos Γ)).card * 1 = Nat.card (Cos Γ) := by rw [mul_one, card_cos]
+  rw [charPolyAt]
+  conv_lhs => rw [← hc, coeff_prod_of_natDegree_le (s := Finset.univ) (n := 1)
+    (f := fun q : Cos Γ => C (quotientFunc g q τ) * X - C (quotientFunc f q τ))
+    (h := fun q _ => natDegree_linear_le _ _)]
+  rw [ModularForm.coe_norm, Finset.prod_apply]
+  refine Fintype.prod_congr _ _ (fun q => ?_)
+  simp
+
+def node (n : ℕ) (j : Fin (n + 1)) : ℂ := (j : ℕ)
+
+theorem node_injOn (n : ℕ) : Set.InjOn (node n) (Finset.univ : Finset (Fin (n + 1))) := by
+  intro i _ j _ h
+  simp only [node, Nat.cast_inj] at h
+  exact Fin.ext h
+
+noncomputable def lag (n : ℕ) (j : Fin (n + 1)) : ℂ[X] :=
+  Lagrange.basis (Finset.univ : Finset (Fin (n + 1))) (node n) j
+
+theorem charPolyAt_eq_sum (τ : ℍ) :
+    charPolyAt f g τ = ∑ j : Fin (Nat.card (Cos Γ) + 1),
+      C ((ModularForm.norm 𝒮ℒ ((node _ j) • g - f)) τ) * lag (Nat.card (Cos Γ)) j := by
+  classical
+  have hdeg : (charPolyAt f g τ).degree < (Finset.univ : Finset (Fin (Nat.card (Cos Γ) + 1))).card
+    :=
+    by
+    rw [Finset.card_univ, Fintype.card_fin]
+    refine lt_of_le_of_lt (degree_le_natDegree) ?_
+    exact_mod_cast Nat.lt_succ_of_le (natDegree_charPolyAt_le f g τ)
+  have h := Lagrange.eq_interpolate (f := charPolyAt f g τ) (node_injOn (Nat.card (Cos Γ))) hdeg
+  rw [h, Lagrange.interpolate_apply]
+  refine Finset.sum_congr rfl fun j _ => ?_
+  rw [eval_charPolyAt]
+  rfl
+
+noncomputable def coeffForm (i : ℕ) : ModularForm 𝒮ℒ (k * Nat.card (Cos Γ)) :=
+  ∑ j : Fin (Nat.card (Cos Γ) + 1), ((lag (Nat.card (Cos Γ)) j).coeff i) • ModularForm.norm 𝒮ℒ
+    ((node _ j) • g - f)
+
+omit [Γ.FiniteIndex] in
+theorem coe_finset_sum {ι : Type*} {k' : ℤ} (s : Finset ι) (F : ι → ModularForm 𝒮ℒ k') :
+    ((∑ i ∈ s, F i : ModularForm 𝒮ℒ k') : ℍ → ℂ) = ∑ i ∈ s, (F i : ℍ → ℂ) :=
+  map_sum (FunLike.coeAddMonoidHom (ModularForm 𝒮ℒ k') UpperHalfPlane ℂ) F s
+
+theorem coeffForm_apply (i : ℕ) (τ : ℍ) : coeffForm f g i τ = (charPolyAt f g τ).coeff i := by
+  rw [coeffForm, coe_finset_sum, Finset.sum_apply, charPolyAt_eq_sum, finsetSum_coeff]
+  refine Finset.sum_congr rfl fun j _ => ?_
+  rw [smul_apply, coeff_C_mul, smul_eq_mul, mul_comm]
+
+theorem coe_coeffForm_card :
+    (coeffForm f g (Nat.card (Cos Γ)) : ℍ → ℂ) = ModularForm.norm 𝒮ℒ g := by
+  funext τ
+  rw [coeffForm_apply, coeff_charPolyAt_card]
+
+theorem eval_homogenize_linear (a b x y : ℂ) :
+    MvPolynomial.eval ![x, y] ((C a * X - C b).homogenize 1) = a * x - b * y := by
+  rw [homogenize_sub, homogenize_C_mul, homogenize_X one_ne_zero, homogenize_C]
+  simp
+
+theorem eval_homogenize_eq_sum (p : ℂ[X]) (n : ℕ) (x y : ℂ) :
+    MvPolynomial.eval ![x, y] (p.homogenize n) =
+      ∑ i ∈ Finset.range (n + 1), p.coeff i * x ^ i * y ^ (n - i) := by
+  simp only [homogenize, Finset.Nat.sum_antidiagonal_eq_sum_range_succ_mk, MvPolynomial.eval_sum]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [MvPolynomial.eval_monomial, Finsupp.update_eq_add_single, Finsupp.prod_add_index',
+    Finsupp.prod_single_index, Finsupp.prod_single_index]
+  · simp [mul_assoc]
+  all_goals simp [pow_add]
+
+theorem sum_coeffForm_mul_pow_eq_zero (τ : ℍ) :
+    ∑ i ∈ Finset.range (Nat.card (Cos Γ) + 1),
+      coeffForm f g i τ * f τ ^ i * g τ ^ (Nat.card (Cos Γ) - i) = 0 := by
+  simp_rw [coeffForm_apply]
+  rw [← eval_homogenize_eq_sum]
+  have hcard : Nat.card (Cos Γ) = ∑ _q ∈ (Finset.univ : Finset (Cos Γ)), 1 := by
+    simp [Nat.card_eq_fintype_card]
+  rw [charPolyAt, hcard, homogenize_finsetProd (fun q _ => natDegree_linear_le _ _), map_prod]
+  simp_rw [eval_homogenize_linear]
+  refine Finset.prod_eq_zero (Finset.mem_univ (QuotientGroup.mk (1 : ↥𝒮ℒ) : (Cos Γ))) ?_
+  have h1 : ∀ (φ : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k),
+      quotientFunc φ (QuotientGroup.mk (1 : ↥𝒮ℒ) : (Cos Γ)) = (φ : ℍ → ℂ) ∣[k] ((1 : ↥𝒮ℒ) : GL (Fin
+        2) ℝ)⁻¹ :=
+    fun φ => rfl
+  rw [h1, h1]
+  simp only [OneMemClass.coe_one, inv_one, SlashAction.slash_one]
+  ring
+
+def Nice (F : ℍ → ℂ) : Prop := AnalyticAt ℂ (cuspFunction 1 F) 0
+
+theorem Nice.mul {F G : ℍ → ℂ} (hF : Nice F) (hG : Nice G) : Nice (F * G) := by
+  unfold Nice at *
+  rw [cuspFunction_mul hF.continuousAt hG.continuousAt]
+  exact hF.mul hG
+
+theorem Nice.add {F G : ℍ → ℂ} (hF : Nice F) (hG : Nice G) : Nice (F + G) := by
+  unfold Nice at *
+  rw [cuspFunction_add hF.continuousAt hG.continuousAt]
+  exact hF.add hG
+
+theorem nice_one : Nice (1 : ℍ → ℂ) := by
+  have : (1 : ℍ → ℂ) = ⇑(1 : ModularForm 𝒮ℒ 0) := rfl
+  unfold Nice; rw [this]
+  exact ModularFormClass.analyticAt_cuspFunction_zero _ one_pos one_mem_strictPeriods_SL
+
+theorem nice_zero : Nice (0 : ℍ → ℂ) := by
+  have : (0 : ℍ → ℂ) = ⇑(0 : ModularForm 𝒮ℒ 0) := rfl
+  unfold Nice; rw [this]
+  exact ModularFormClass.analyticAt_cuspFunction_zero _ one_pos one_mem_strictPeriods_SL
+
+theorem Nice.pow {F : ℍ → ℂ} (hF : Nice F) : ∀ n : ℕ, Nice (F ^ n)
+  | 0 => by rw [pow_zero]; exact nice_one
+  | n + 1 => by rw [pow_succ]; exact (Nice.pow hF n).mul hF
+
+theorem qExpansion_pow' {F : ℍ → ℂ} (hF : Nice F) :
+    ∀ n : ℕ, qExpansion 1 (F ^ n) = qExpansion 1 F ^ n
+  | 0 => by rw [pow_zero, pow_zero, qExpansion_one]
+  | n + 1 => by
+    rw [pow_succ, pow_succ, qExpansion_mul (Nice.pow hF n) hF, qExpansion_pow' hF n]
+
+theorem Nice.sum {ι : Type*} (s : Finset ι) {F : ι → ℍ → ℂ} (hF : ∀ i ∈ s, Nice (F i)) :
+    Nice (∑ i ∈ s, F i) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => rw [Finset.sum_empty]; exact nice_zero
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha]
+    exact (hF a (Finset.mem_insert_self a s)).add (ih fun i hi => hF i (Finset.mem_insert_of_mem
+      hi))
+
+theorem qExpansion_sum' {ι : Type*} (s : Finset ι) {F : ι → ℍ → ℂ} (hF : ∀ i ∈ s, Nice (F i)) :
+    qExpansion 1 (∑ i ∈ s, F i) = ∑ i ∈ s, qExpansion 1 (F i) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => rw [Finset.sum_empty, Finset.sum_empty, qExpansion_zero]
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha, Finset.sum_insert ha,
+      qExpansion_add (hF a (Finset.mem_insert_self a s))
+        (Nice.sum s fun i hi => hF i (Finset.mem_insert_of_mem hi)),
+      ih fun i hi => hF i (Finset.mem_insert_of_mem hi)]
+
+variable (hT : ModularGroup.T ∈ Γ)
+include hT
+
+omit [Γ.FiniteIndex] in
+theorem nice_of_modularForm {k' : ℤ} (h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k') :
+    Nice (h : ℍ → ℂ) :=
+  ModularFormClass.analyticAt_cuspFunction_zero _ one_pos (one_mem_strictPeriods hT)
+
+omit hT in
+theorem nice_of_levelOne {k' : ℤ} (h : ModularForm 𝒮ℒ k') : Nice (h : ℍ → ℂ) :=
+  ModularFormClass.analyticAt_cuspFunction_zero _ one_pos one_mem_strictPeriods_SL
+
+theorem sum_qExpansion_coeffForm_mul_pow_eq_zero :
+    ∑ i ∈ Finset.range (Nat.card (Cos Γ) + 1),
+      qExpansion 1 (coeffForm f g i : ℍ → ℂ) * qExpansion 1 (f : ℍ → ℂ) ^ i *
+        qExpansion 1 (g : ℍ → ℂ) ^ (Nat.card (Cos Γ) - i) = 0 := by
+  set R : ℍ → ℂ := ∑ i ∈ Finset.range (Nat.card (Cos Γ) + 1),
+    (coeffForm f g i : ℍ → ℂ) * (f : ℍ → ℂ) ^ i * (g : ℍ → ℂ) ^ (Nat.card (Cos Γ) - i) with hR
+  have hR0 : R = 0 := by
+    funext τ
+    simp only [hR, Finset.sum_apply, Pi.mul_apply, Pi.pow_apply, Pi.zero_apply]
+    exact sum_coeffForm_mul_pow_eq_zero f g τ
+  have hnice : ∀ i ∈ Finset.range (Nat.card (Cos Γ) + 1),
+      Nice ((coeffForm f g i : ℍ → ℂ) * (f : ℍ → ℂ) ^ i * (g : ℍ → ℂ) ^ (Nat.card (Cos Γ) - i)) :=
+    fun i _ => ((nice_of_levelOne _).mul ((nice_of_modularForm hT f).pow i)).mul
+      ((nice_of_modularForm hT g).pow _)
+  have h := congrArg (qExpansion 1) hR0
+  rw [qExpansion_zero, hR, qExpansion_sum' _ hnice] at h
+  rw [← h]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [qExpansion_mul ((nice_of_levelOne _).mul ((nice_of_modularForm hT f).pow i))
+      ((nice_of_modularForm hT g).pow _),
+    qExpansion_mul (nice_of_levelOne _) ((nice_of_modularForm hT f).pow i),
+    qExpansion_pow' (nice_of_modularForm hT f), qExpansion_pow' (nice_of_modularForm hT g)]
+
+omit hT in
+theorem qExpansion_coeffForm_card_ne_zero (hg : g ≠ 0) :
+    qExpansion 1 (coeffForm f g (Nat.card (Cos Γ)) : ℍ → ℂ) ≠ 0 := by
+  rw [coe_coeffForm_card]
+  intro h
+  rw [ModularForm.qExpansion_eq_zero_iff one_pos one_mem_strictPeriods_SL] at h
+  exact ModularForm.norm_ne_zero 𝒮ℒ (f := g) (by
+    intro h0; exact hg (DFunLike.coe_injective (by simpa using h0))) h
+
+end Linear
+
+end JOneESNorm
+
+namespace JOneESRat
+
+open ModularForm UpperHalfPlane EisensteinSeries ModularCurve HahnSeries Polynomial
+open scoped MatrixGroups ModularForm
+
+variable {Γ : Subgroup SL(2, ℤ)} [Γ.FiniteIndex]
+
+noncomputable def P4 : PowerSeries ℤ :=
+  PowerSeries.mk fun m => if m = 0 then 1 else 240 * (ArithmeticFunction.sigma 3 m : ℤ)
+
+noncomputable def P6 : PowerSeries ℤ :=
+  PowerSeries.mk fun m => if m = 0 then 1 else -504 * (ArithmeticFunction.sigma 5 m : ℤ)
+
+omit [Γ.FiniteIndex] in
+theorem isIntegralQExp_E4 : IsIntegralQExp (E₄ : ℍ → ℂ) P4 := by
+  rw [isIntegralQExp_iff]
+  intro n
+  rw [E_qExpansion_coeff (by norm_num) (by decide) n, P4, PowerSeries.coeff_mk]
+  split_ifs with h
+  · simp
+  · rw [show _root_.bernoulli 4 = -1 / 30 by decide +kernel]
+    push_cast
+    ring
+
+omit [Γ.FiniteIndex] in
+theorem isIntegralQExp_E6 : IsIntegralQExp (E₆ : ℍ → ℂ) P6 := by
+  rw [isIntegralQExp_iff]
+  intro n
+  rw [E_qExpansion_coeff (by norm_num) (by decide) n, P6, PowerSeries.coeff_mk]
+  split_ifs with h
+  · simp
+  · rw [show _root_.bernoulli 6 = 1 / 42 by decide +kernel]
+    push_cast
+    ring
+
+variable (Γ) in
+noncomputable def A12 : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12 :=
+  restrictForm (Subgroup.map_le_range _ Γ) ((E₄.pow 3).mcast (by norm_num))
+
+variable (Γ) in
+noncomputable def B12 : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12 :=
+  restrictForm (Subgroup.map_le_range _ Γ) ((E₆.pow 2).mcast (by norm_num))
+
+omit [Γ.FiniteIndex] in
+theorem isIntegralQExp_A12 : IsIntegralQExp (A12 Γ : ℍ → ℂ) (P4 ^ 3) := by
+  rw [IsIntegralQExp, A12, coe_restrictForm, map_pow, isIntegralQExp_E4]
+  rw [ModularForm.qExpansion_mcast, ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+
+omit [Γ.FiniteIndex] in
+theorem isIntegralQExp_B12 : IsIntegralQExp (B12 Γ : ℍ → ℂ) (P6 ^ 2) := by
+  rw [IsIntegralQExp, B12, coe_restrictForm, map_pow, isIntegralQExp_E6]
+  rw [ModularForm.qExpansion_mcast, ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+
+omit [Γ.FiniteIndex] in
+theorem constantCoeff_P4 : PowerSeries.constantCoeff P4 = 1 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff_apply, P4, PowerSeries.coeff_mk]; simp
+
+omit [Γ.FiniteIndex] in
+theorem constantCoeff_P6 : PowerSeries.constantCoeff P6 = 1 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff_apply, P6, PowerSeries.coeff_mk]; simp
+
+omit [Γ.FiniteIndex] in
+theorem coeff_one_P4 : PowerSeries.coeff 1 P4 = 240 := by
+  rw [P4, PowerSeries.coeff_mk]; simp [ArithmeticFunction.sigma_one]
+
+omit [Γ.FiniteIndex] in
+theorem coeff_one_P6 : PowerSeries.coeff 1 P6 = -504 := by
+  rw [P6, PowerSeries.coeff_mk]; simp [ArithmeticFunction.sigma_one]
+
+omit [Γ.FiniteIndex] in
+theorem intSeriesC_ne_zero_of_constantCoeff {K : Type*} [Field K] [CharZero K] {p : PowerSeries ℤ}
+    (hp : PowerSeries.constantCoeff p = 1) : intSeriesC K p ≠ 0 := by
+  intro h
+  have := congrArg (fun z : LaurentSeries K => z.coeff 0) h
+  simp only [intSeriesC, HahnSeries.coeff_zero] at this
+  rw [PowerSeries.coeff_coe] at this
+  simp only [lt_self_iff_false, ↓reduceIte, Int.natAbs_zero, PowerSeries.coeff_map,
+    PowerSeries.coeff_zero_eq_constantCoeff_apply, hp, map_one, one_ne_zero] at this
+
+noncomputable def xq : LaurentSeries ℚ := intSeriesC ℚ (P6 ^ 2) / intSeriesC ℚ (P4 ^ 3)
+
+omit [Γ.FiniteIndex] in
+theorem intSeriesC_P4_cube_ne_zero : intSeriesC ℚ (P4 ^ 3) ≠ 0 :=
+  intSeriesC_ne_zero_of_constantCoeff (by rw [map_pow, constantCoeff_P4, one_pow])
+
+omit [Γ.FiniteIndex] in
+theorem xq_mem : xq ∈ qExpFunctionFieldC ℚ Γ :=
+  div_mem_qExpFunctionFieldC (B12 Γ) (A12 Γ) isIntegralQExp_B12 isIntegralQExp_A12
+    intSeriesC_P4_cube_ne_zero
+
+omit [Γ.FiniteIndex] in
+theorem xq_transcendental : Transcendental ℚ xq := by
+  intro halg
+  obtain ⟨c, hc⟩ := JOneESAlg.eq_C_of_isAlgebraic halg
+  have h1 : intSeriesC ℚ (P6 ^ 2) = HahnSeries.C c * intSeriesC ℚ (P4 ^ 3) := by
+    rw [← hc, xq, div_mul_cancel₀ _ intSeriesC_P4_cube_ne_zero]
+  have h2 : (P6 ^ 2).map (Int.castRingHom ℚ) = PowerSeries.C c * (P4 ^ 3).map (Int.castRingHom ℚ) :=
+    by
+    apply HahnSeries.ofPowerSeries_injective (Γ := ℤ)
+    rw [map_mul, HahnSeries.ofPowerSeries_C]
+    exact h1
+  have h0 := congrArg (PowerSeries.coeff 0) h2
+  rw [PowerSeries.coeff_map, PowerSeries.coeff_C_mul, PowerSeries.coeff_map] at h0
+  simp only [PowerSeries.coeff_zero_eq_constantCoeff_apply, map_pow, constantCoeff_P4,
+    constantCoeff_P6,
+    one_pow, map_one, mul_one] at h0
+  have h3 := congrArg (PowerSeries.coeff 1) h2
+  rw [PowerSeries.coeff_map, PowerSeries.coeff_C_mul, PowerSeries.coeff_map] at h3
+  simp only [PowerSeries.coeff_one_pow, coeff_one_P4, coeff_one_P6, constantCoeff_P4,
+    constantCoeff_P6,
+    ← h0] at h3
+  norm_num at h3
+
+omit [Γ.FiniteIndex] in
+theorem intSeriesC_add {K : Type*} [Field K] (p p' : PowerSeries ℤ) :
+    intSeriesC K (p + p') = intSeriesC K p + intSeriesC K p' := by
+  simp [intSeriesC]
+
+section Ratio
+variable (hT : ModularGroup.T ∈ Γ)
+include hT
+
+omit [Γ.FiniteIndex] in
+theorem hper :
+    (1 : ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)).strictPeriods := JOneESNorm.one_mem_strictPeriods hT
+
+omit [Γ.FiniteIndex] in
+theorem mul_mem_intFormRatiosC {a b : LaurentSeries ℚ} (ha : a ∈ intFormRatiosC ℚ Γ)
+    (hb : b ∈ intFormRatiosC ℚ Γ) : a * b ∈ intFormRatiosC ℚ Γ := by
+  obtain ⟨k₁, f₁, g₁, pf₁, pg₁, hf₁, hg₁, hg₁0, rfl⟩ := ha
+  obtain ⟨k₂, f₂, g₂, pf₂, pg₂, hf₂, hg₂, hg₂0, rfl⟩ := hb
+  refine ⟨k₁ + k₂, f₁.mul f₂, g₁.mul g₂, pf₁ * pf₂, pg₁ * pg₂, ?_, ?_, ?_, ?_⟩
+  · rw [IsIntegralQExp, map_mul, hf₁, hf₂, ModularForm.coe_mul]
+    exact (ModularForm.qExpansion_mul_coe one_pos (hper hT) f₁ f₂).symm
+  · rw [IsIntegralQExp, map_mul, hg₁, hg₂, ModularForm.coe_mul]
+    exact (ModularForm.qExpansion_mul_coe one_pos (hper hT) g₁ g₂).symm
+  · rw [intSeriesC_mul]; exact mul_ne_zero hg₁0 hg₂0
+  · rw [intSeriesC_mul, intSeriesC_mul, div_mul_div_comm]
+
+omit [Γ.FiniteIndex] in
+theorem add_mem_intFormRatiosC {a b : LaurentSeries ℚ} (ha : a ∈ intFormRatiosC ℚ Γ)
+    (hb : b ∈ intFormRatiosC ℚ Γ) : a + b ∈ intFormRatiosC ℚ Γ := by
+  obtain ⟨k₁, f₁, g₁, pf₁, pg₁, hf₁, hg₁, hg₁0, rfl⟩ := ha
+  obtain ⟨k₂, f₂, g₂, pf₂, pg₂, hf₂, hg₂, hg₂0, rfl⟩ := hb
+  refine ⟨k₁ + k₂, f₁.mul g₂ + (g₁.mul f₂), g₁.mul g₂, pf₁ * pg₂ + pg₁ * pf₂, pg₁ * pg₂, ?_, ?_, ?_,
+    ?_⟩
+  · rw [IsIntegralQExp, map_add, map_mul, map_mul, hf₁, hf₂, hg₁, hg₂, FunLike.coe_add,
+      ModularForm.qExpansion_add one_pos (hper hT), ModularForm.coe_mul, ModularForm.coe_mul,
+      ModularForm.qExpansion_mul_coe one_pos (hper hT), ModularForm.qExpansion_mul_coe one_pos (hper
+      hT)]
+  · rw [IsIntegralQExp, map_mul, hg₁, hg₂, ModularForm.coe_mul]
+    exact (ModularForm.qExpansion_mul_coe one_pos (hper hT) g₁ g₂).symm
+  · rw [intSeriesC_mul]; exact mul_ne_zero hg₁0 hg₂0
+  · rw [intSeriesC_add, intSeriesC_mul, intSeriesC_mul, intSeriesC_mul, div_add_div _ _ hg₁0 hg₂0]
+
+omit hT [Γ.FiniteIndex] in
+theorem inv_mem_intFormRatiosC {a : LaurentSeries ℚ} (ha : a ∈ intFormRatiosC ℚ Γ) :
+    a⁻¹ ∈ intFormRatiosC ℚ Γ := by
+  obtain ⟨k, f, g, pf, pg, hf, hg, hg0, rfl⟩ := ha
+  by_cases hf0 : intSeriesC ℚ pf = 0
+  · rw [hf0, zero_div, inv_zero, ← zero_div (intSeriesC ℚ pg), ← hf0]
+    exact ⟨k, f, g, pf, pg, hf, hg, hg0, rfl⟩
+  · refine ⟨k, g, f, pg, pf, hg, hf, hf0, ?_⟩
+    rw [inv_div]
+
+omit [Γ.FiniteIndex] in
+theorem algebraMap_mem_intFormRatiosC (c : ℚ) :
+    algebraMap ℚ (LaurentSeries ℚ) c ∈ intFormRatiosC ℚ Γ := by
+  have hden : ((c.den : ℤ) : ℚ) ≠ 0 := by exact_mod_cast c.den_nz
+  refine ⟨0, ModularForm.const (c.num : ℂ), ModularForm.const (c.den : ℂ),
+    PowerSeries.C (c.num : ℤ), PowerSeries.C (c.den : ℤ), ?_, ?_, ?_, ?_⟩
+  · rw [IsIntegralQExp, PowerSeries.map_C]
+    have : ((ModularForm.const (c.num : ℂ) : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 0) : ℍ → ℂ) =
+        (c.num : ℂ) • ((1 : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 0) : ℍ → ℂ) := by
+      funext z
+      rw [Pi.smul_apply, ModularForm.const_apply, ModularForm.one_coe_eq_one, Pi.one_apply,
+        smul_eq_mul,
+        mul_one]
+    rw [this, ModularForm.qExpansion_smul one_pos (hper hT), ModularForm.qExpansion_one,
+      PowerSeries.smul_eq_C_mul, mul_one, eq_intCast]
+  · rw [IsIntegralQExp, PowerSeries.map_C]
+    have : ((ModularForm.const (c.den : ℂ) : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 0) : ℍ → ℂ) =
+        (c.den : ℂ) • ((1 : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 0) : ℍ → ℂ) := by
+      funext z
+      rw [Pi.smul_apply, ModularForm.const_apply, ModularForm.one_coe_eq_one, Pi.one_apply,
+        smul_eq_mul,
+        mul_one]
+    rw [this, ModularForm.qExpansion_smul one_pos (hper hT), ModularForm.qExpansion_one,
+      PowerSeries.smul_eq_C_mul, mul_one, eq_intCast]
+    push_cast
+    rfl
+  · rw [intSeriesC, PowerSeries.map_C, HahnSeries.ofPowerSeries_C, eq_intCast]
+    exact (map_ne_zero_iff _ HahnSeries.C_injective).mpr hden
+  · rw [intSeriesC, intSeriesC, PowerSeries.map_C, PowerSeries.map_C, HahnSeries.ofPowerSeries_C,
+      HahnSeries.ofPowerSeries_C, LaurentSeries.algebraMap_apply, eq_intCast,
+      eq_intCast, eq_div_iff ((map_ne_zero_iff _ HahnSeries.C_injective).mpr hden), ← map_mul]
+    congr 1
+    push_cast
+    exact Rat.mul_den_eq_num c
+
+omit [Γ.FiniteIndex] in
+theorem mem_qExpFunctionFieldC_iff {y : LaurentSeries ℚ} :
+    y ∈ qExpFunctionFieldC ℚ Γ ↔ y ∈ intFormRatiosC ℚ Γ := by
+  let R : IntermediateField ℚ (LaurentSeries ℚ) :=
+    { carrier := intFormRatiosC ℚ Γ
+      mul_mem' := fun ha hb => mul_mem_intFormRatiosC hT ha hb
+      one_mem' := by simpa using algebraMap_mem_intFormRatiosC (Γ := Γ) hT 1
+      add_mem' := fun ha hb => add_mem_intFormRatiosC hT ha hb
+      zero_mem' := by simpa using algebraMap_mem_intFormRatiosC (Γ := Γ) hT 0
+      algebraMap_mem' := fun c => algebraMap_mem_intFormRatiosC hT c
+      inv_mem' := fun a ha => inv_mem_intFormRatiosC ha }
+  have hle : qExpFunctionFieldC ℚ Γ ≤ R := IntermediateField.adjoin_le_iff.mpr (fun _ h => h)
+  exact ⟨fun h => hle h, fun h => intFormRatiosC_subset ℚ Γ h⟩
+
+end Ratio
+
+section Relation
+
+variable (hT : ModularGroup.T ∈ Γ)
+include hT
+
+local notation "μ" => Nat.card (JOneESNorm.Cos Γ)
+
+omit [Γ.FiniteIndex] hT in
+theorem coeffEmb_intSeriesC (p : PowerSeries ℤ) :
+    coeffEmb ℂ (intSeriesC ℚ p) = HahnSeries.ofPowerSeries ℤ ℂ (p.map (Int.castRingHom ℂ)) := by
+  ext n
+  rw [coeffEmb_coeff, intSeriesC, PowerSeries.coeff_coe, PowerSeries.coeff_coe]
+  split_ifs
+  · simp
+  · simp
+
+omit [Γ.FiniteIndex] hT in
+theorem coeffEmb_eq_map (z : LaurentSeries ℚ) :
+    coeffEmb ℂ z = HahnSeries.map z (algebraMap ℚ ℂ) := by
+  ext n; rw [coeffEmb_coeff]; rfl
+
+omit [Γ.FiniteIndex] hT in
+theorem sum_div_pow_eq {K : Type*} [Field K] {n : ℕ} (a : ℕ → K) (F G : K) (hG : G ≠ 0)
+    (h : ∑ i ∈ Finset.range (n + 1), a i * F ^ i * G ^ (n - i) = 0) :
+    ∑ i ∈ Finset.range (n + 1), a i * (F / G) ^ i = 0 := by
+  have hGn : G ^ n ≠ 0 := pow_ne_zero _ hG
+  have key : ∀ i ∈ Finset.range (n + 1), a i * F ^ i * G ^ (n - i) = (a i * (F / G) ^ i) * G ^ n :=
+    by
+    intro i hi
+    have hi' : i ≤ n := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)
+    rw [div_pow, mul_assoc, mul_assoc]
+    congr 1
+    rw [div_mul_eq_mul_div, eq_div_iff (pow_ne_zero _ hG), mul_assoc, ← _root_.pow_add,
+      Nat.sub_add_cancel hi']
+  rw [Finset.sum_congr rfl key, ← Finset.sum_mul] at h
+  exact (mul_eq_zero.mp h).resolve_right hGn
+
+omit [Γ.FiniteIndex] hT in
+theorem monomial_eq {K : Type*} [Field K] {m b : ℕ} (hb : b ≤ m) (Q4 Q6 : K) (h4 : Q4 ≠ 0) :
+    Q4 ^ (3 * (m - b)) * Q6 ^ (2 * b) = Q4 ^ (3 * m) * (Q6 ^ 2 / Q4 ^ 3) ^ b := by
+  rw [show 3 * m = 3 * (m - b) + 3 * b by
+    omega, _root_.pow_add, div_pow, ← pow_mul, ← pow_mul, mul_assoc]
+  congr 1
+  rw [mul_div_assoc', mul_comm (Q4 ^ (3 * b)), mul_div_assoc, div_self (pow_ne_zero _ h4), mul_one]
+
+theorem exists_rat_relation {k : ℤ} (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    {pf pg : PowerSeries ℤ} (hf : IsIntegralQExp f pf) (hg : IsIntegralQExp g pg)
+    (hg0 : intSeriesC ℚ pg ≠ 0) :
+    ∃ (m : ℕ) (d : Fin (μ + 1) × Fin (m + 1) → ℚ),
+      (∃ ib, d ib ≠ 0) ∧
+      ∑ ib, d ib • (xq ^ (ib.2 : ℕ) * (intSeriesC ℚ pf / intSeriesC ℚ pg) ^ (ib.1 : ℕ)) = 0 := by
+  classical
+  have hgne : g ≠ 0 := by
+    intro h0
+    apply hg0
+    have : pg = 0 := by
+      apply PowerSeries.map_injective (Int.castRingHom ℂ) Int.cast_injective
+      rw [hg, h0, FunLike.coe_zero, qExpansion_zero, map_zero]
+    rw [this, intSeriesC_zero]
+  have hk : 0 ≤ k := by
+    by_contra hlt
+    exact hgne (ModularForm.isZero_of_neg_weight (not_le.mp hlt) g)
+  have hw : (11 : ℕ) * k + k = 12 * k := by ring
+  let f' : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) (12 * k) := ((g.pow 11).mul f).mcast hw
+  let g' : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) (12 * k) := ((g.pow 11).mul g).mcast hw
+  have hqf' : qExpansion 1 (f' : ℍ → ℂ) = qExpansion 1 (g : ℍ → ℂ) ^ 11 * qExpansion 1 (f : ℍ → ℂ)
+    :=
+    by
+    simp only [f', ModularForm.qExpansion_mcast, ModularForm.qExpansion_mul one_pos (hper hT),
+      ModularForm.qExpansion_pow one_pos (hper hT)]
+  have hqg' : qExpansion 1 (g' : ℍ → ℂ) = qExpansion 1 (g : ℍ → ℂ) ^ 11 * qExpansion 1 (g : ℍ → ℂ)
+    :=
+    by
+    simp only [g', ModularForm.qExpansion_mcast, ModularForm.qExpansion_mul one_pos (hper hT),
+      ModularForm.qExpansion_pow one_pos (hper hT)]
+  have hqg : qExpansion 1 (g : ℍ → ℂ) ≠ 0 := by
+    rwa [Ne, ModularForm.qExpansion_eq_zero_iff one_pos (hper hT)]
+  have hg'ne : g' ≠ 0 := by
+    intro h0
+    have : qExpansion 1 (g' : ℍ → ℂ) = 0 := by rw [h0, FunLike.coe_zero, qExpansion_zero]
+    rw [hqg'] at this
+    exact (mul_ne_zero (pow_ne_zero _ hqg) hqg) this
+  have hrel := JOneESNorm.sum_qExpansion_coeffForm_mul_pow_eq_zero f' g' hT
+  have htop := JOneESNorm.qExpansion_coeffForm_card_ne_zero f' g' hg'ne
+  set m : ℕ := k.toNat * μ with hm
+  have hkm : 12 * k * (μ : ℤ) = 12 * (m : ℤ) := by
+    rw [hm]; push_cast; rw [Int.toNat_of_nonneg hk]; ring
+  have hspan : ∀ i, qExpansion 1 (JOneESNorm.coeffForm f' g' i : ℍ → ℂ) ∈
+    JOneESLevelOne.monomialSpan m :=
+    fun i => by
+      simpa only [ModularForm.qExpansion_mcast] using
+        JOneESLevelOne.qExpansion_mem_monomialSpan m
+          ((JOneESNorm.coeffForm f' g' i).mcast hkm)
+  choose c hc using fun i => (Submodule.mem_span_range_iff_exists_fun ℂ).mp (hspan i)
+  let Φ : PowerSeries ℂ →+* LaurentSeries ℂ := HahnSeries.ofPowerSeries ℤ ℂ
+  have hΦ : Function.Injective Φ := HahnSeries.ofPowerSeries_injective
+  set Q4 : LaurentSeries ℂ := Φ JOneESLevelOne.q4 with hQ4
+  set Q6 : LaurentSeries ℂ := Φ JOneESLevelOne.q6 with hQ6
+  set QF : LaurentSeries ℂ := Φ (qExpansion 1 (f : ℍ → ℂ)) with hQF
+  set QG : LaurentSeries ℂ := Φ (qExpansion 1 (g : ℍ → ℂ)) with hQG
+  set QE : ℕ → LaurentSeries ℂ := fun i => Φ (qExpansion 1 (JOneESNorm.coeffForm f' g' i : ℍ → ℂ))
+    with hQE
+  have hQG0 : QG ≠ 0 := fun h => hqg (hΦ (by rw [map_zero]; exact h))
+  have hQ40 : Q4 ≠ 0 := by
+    intro h
+    have : JOneESLevelOne.q4 = 0 := hΦ (by rw [map_zero]; exact h)
+    have h0 := congrArg (PowerSeries.coeff 0) this
+    rw [JOneESLevelOne.q4_coeff_zero, map_zero] at h0
+    exact one_ne_zero h0
+  have hrel' : ∑ i ∈ Finset.range (μ + 1), QE i * (QG ^ 11 * QF) ^ i * (QG ^ 11 * QG) ^ (μ - i) = 0
+    :=
+    by
+    have := congrArg Φ hrel
+    rw [map_sum, map_zero] at this
+    rw [← this]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    simp only [hQE, hQF, hQG, map_mul, map_pow, hqf', hqg']
+  have hdiv := sum_div_pow_eq (n := μ) QE (QG ^ 11 * QF) (QG ^ 11 * QG)
+    (mul_ne_zero (pow_ne_zero _ hQG0) hQG0) hrel'
+  have hratio : (QG ^ 11 * QF) / (QG ^ 11 * QG) = QF / QG :=
+    mul_div_mul_left _ _ (pow_ne_zero _ hQG0)
+  rw [hratio] at hdiv
+  set Xh : LaurentSeries ℂ := Q6 ^ 2 / Q4 ^ 3 with hXh
+  have hQEi : ∀ i, QE i = Q4 ^ (3 * m) * ∑ b : Fin (m + 1), HahnSeries.C (c i b) * Xh ^ (b : ℕ) :=
+    by
+    intro i
+    simp only [hQE]
+    rw [← hc i, map_sum, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun b _ => ?_
+    rw [PowerSeries.smul_eq_C_mul, map_mul, map_mul, map_pow, map_pow, monomial_eq
+      (Nat.lt_succ_iff.mp b.2) _ _ hQ40]
+    simp only [Φ, HahnSeries.ofPowerSeries_C]
+    ring
+  have hsum : ∑ ib : Fin (μ + 1) × Fin (m + 1),
+      c ib.1 ib.2 • (Xh ^ (ib.2 : ℕ) * (QF / QG) ^ (ib.1 : ℕ)) = 0 := by
+    have h1 : Q4 ^ (3 * m) * ∑ i : Fin (μ + 1),
+        (∑ b : Fin (m + 1), HahnSeries.C (c i b) * Xh ^ (b : ℕ)) * (QF / QG) ^ (i : ℕ) = 0 := by
+      rw [Finset.mul_sum, ← hdiv, Finset.sum_range]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [hQEi, mul_assoc]
+    have h2 := (mul_eq_zero.mp h1).resolve_left (pow_ne_zero _ hQ40)
+    rw [Fintype.sum_prod_type, ← h2]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [Finset.sum_mul]
+    refine Finset.sum_congr rfl fun b _ => ?_
+    rw [← HahnSeries.C_mul_eq_smul, mul_assoc]
+  have hnz : ∃ b, c μ b ≠ 0 := by
+    by_contra hall
+    push Not at hall
+    apply htop
+    rw [← hc μ]
+    exact Finset.sum_eq_zero fun b _ => by rw [hall b, zero_smul]
+  obtain ⟨b₀, hb₀⟩ := hnz
+  let v : Fin (μ + 1) × Fin (m + 1) → LaurentSeries ℚ :=
+    fun ib => xq ^ (ib.2 : ℕ) * (intSeriesC ℚ pf / intSeriesC ℚ pg) ^ (ib.1 : ℕ)
+  have hvmap : ∀ ib, HahnSeries.map (v ib) (algebraMap ℚ ℂ) = Xh ^ (ib.2 : ℕ) * (QF / QG) ^ (ib.1 :
+    ℕ) :=
+    by
+    intro ib
+    rw [← coeffEmb_eq_map, map_mul, map_pow, map_pow, xq, map_div₀, map_div₀,
+      coeffEmb_intSeriesC, coeffEmb_intSeriesC, coeffEmb_intSeriesC, coeffEmb_intSeriesC]
+    have h4 : P4.map (Int.castRingHom ℂ) = JOneESLevelOne.q4 := isIntegralQExp_E4
+    have h6 : P6.map (Int.castRingHom ℂ) = JOneESLevelOne.q6 := isIntegralQExp_E6
+    have hf' : pf.map (Int.castRingHom ℂ) = qExpansion 1 (f : ℍ → ℂ) := hf
+    have hg' : pg.map (Int.castRingHom ℂ) = qExpansion 1 (g : ℍ → ℂ) := hg
+    simp only [map_pow, h4, h6, hf', hg']
+    rfl
+  have hdep : ¬ LinearIndependent ℂ (fun ib => HahnSeries.map (v ib) (algebraMap ℚ ℂ)) := by
+    rw [Fintype.not_linearIndependent_iff]
+    refine ⟨fun ib => c ib.1 ib.2, ?_, ⟨(Fin.last μ, b₀), by simpa using hb₀⟩⟩
+    simp_rw [hvmap]
+    exact hsum
+  have hdepQ : ¬ LinearIndependent ℚ v := fun h => hdep (JOneESAlg.linearIndependent_map h)
+  rw [Fintype.not_linearIndependent_iff] at hdepQ
+  obtain ⟨d, hd, ib₁, hib₁⟩ := hdepQ
+  exact ⟨m, d, ⟨ib₁, hib₁⟩, hd⟩
+
+end Relation
+
+theorem exists_transcendental_finiteDimensional (hT : ModularGroup.T ∈ Γ) :
+    ∃ x : qExpFunctionFieldC ℚ Γ, Transcendental ℚ x ∧
+      FiniteDimensional (IntermediateField.adjoin ℚ ({x} : Set (qExpFunctionFieldC ℚ Γ)))
+        (qExpFunctionFieldC ℚ Γ) := by
+  classical
+  let F := qExpFunctionFieldC ℚ Γ
+  let X₀ : F := ⟨xq, xq_mem⟩
+  let φ : F →+* LaurentSeries ℚ := algebraMap F (LaurentSeries ℚ)
+  have hφ : ∀ y : F, φ y = (y : LaurentSeries ℚ) := fun _ => rfl
+  have hφQ : φ.comp (algebraMap ℚ F) = algebraMap ℚ (LaurentSeries ℚ) := Subsingleton.elim _ _
+  have hX₀ : Transcendental ℚ X₀ := by
+    rintro ⟨r, hr0, hr⟩
+    refine xq_transcendental ⟨r, hr0, ?_⟩
+    have := Polynomial.hom_eval₂ r (algebraMap ℚ F) φ X₀
+    rw [hφQ] at this
+    rw [Polynomial.aeval_def, show xq = φ X₀ from rfl, ← this, ← Polynomial.aeval_def, hr, map_zero]
+  refine ⟨X₀, hX₀, ?_⟩
+  let K₀ := IntermediateField.adjoin ℚ ({X₀} : Set F)
+  let Xk : K₀ := ⟨X₀, IntermediateField.mem_adjoin_simple_self ℚ X₀⟩
+  have hrat : ∀ e : ℚ, (((algebraMap ℚ K₀ e : K₀) : F) : LaurentSeries ℚ) = algebraMap ℚ
+    (LaurentSeries ℚ) e :=
+    by
+    intro e
+    have h := RingHom.congr_fun (Subsingleton.elim
+      ((φ.comp (algebraMap K₀ F)).comp (algebraMap ℚ K₀)) (algebraMap ℚ (LaurentSeries ℚ))) e
+    rw [← h]
+    rfl
+  have : PerfectField K₀ := PerfectField.ofCharZero
+  refine JOneESAlg.finiteDimensional_of_forall_aeval_eq_zero (Nat.card (JOneESNorm.Cos Γ)) ?_
+  intro Y
+  obtain ⟨k, f, g, pf, pg, hf, hg, hg0, hY⟩ := (mem_qExpFunctionFieldC_iff hT).mp Y.2
+  obtain ⟨m, d, ⟨ib₀, hib₀⟩, hd⟩ := exists_rat_relation hT f g hf hg hg0
+  let coef : Fin (Nat.card (JOneESNorm.Cos Γ) + 1) → K₀ :=
+    fun i => ∑ b : Fin (m + 1), algebraMap ℚ K₀ (d (i, b)) * Xk ^ (b : ℕ)
+  have hcoef : ∀ i, (((coef i : K₀) : F) : LaurentSeries ℚ) =
+      ∑ b : Fin (m + 1), algebraMap ℚ (LaurentSeries ℚ) (d (i, b)) * xq ^ (b : ℕ) := by
+    intro i
+    simp only [coef]
+    rw [IntermediateField.coe_sum, IntermediateField.coe_sum]
+    refine Finset.sum_congr rfl fun b _ => ?_
+    rw [MulMemClass.coe_mul, MulMemClass.coe_mul, SubmonoidClass.coe_pow, SubmonoidClass.coe_pow,
+      hrat]
+  let p : K₀[X] := ∑ i : Fin (Nat.card (JOneESNorm.Cos Γ) + 1), Polynomial.monomial (i : ℕ) (coef i)
+  have hcoeff : ∀ i : Fin (Nat.card (JOneESNorm.Cos Γ) + 1), p.coeff i = coef i := by
+    intro i
+    simp only [p, finsetSum_coeff, coeff_monomial]
+    rw [Finset.sum_eq_single_of_mem i (Finset.mem_univ i)]
+    · simp
+    · intro j _ hji
+      rw [ite_eq_right]
+      exact fun h => hji (Fin.ext h)
+  refine ⟨p, ?_, ?_, ?_⟩
+  · intro hp
+    have h1 : coef ib₀.1 = 0 := by rw [← hcoeff, hp, Polynomial.coeff_zero]
+    apply xq_transcendental
+    let r : ℚ[X] := ∑ b : Fin (m + 1), Polynomial.monomial (b : ℕ) (d (ib₀.1, b))
+    have hr0 : r ≠ 0 := by
+      intro hr
+      have := congrArg (fun q : ℚ[X] => q.coeff ib₀.2) hr
+      simp only [r, finsetSum_coeff, coeff_monomial, Polynomial.coeff_zero] at this
+      rw [Finset.sum_eq_single_of_mem ib₀.2 (Finset.mem_univ _)] at this
+      · simp only [↓reduceIte] at this; exact hib₀ this
+      · intro j _ hji; rw [ite_eq_right]; exact fun h => hji (Fin.ext h)
+    refine ⟨r, hr0, ?_⟩
+    have h2 : (((coef ib₀.1 : K₀) : F) : LaurentSeries ℚ) = 0 := by rw [h1]; rfl
+    rw [hcoef] at h2
+    rw [← h2]
+    simp only [r, map_sum, Polynomial.aeval_monomial]
+  · exact natDegree_sum_le_of_forall_le _ _ fun i _ =>
+      (natDegree_monomial_le _).trans (Nat.lt_succ_iff.mp i.2)
+  · apply Subtype.val_injective
+    rw [ZeroMemClass.coe_zero]
+    have hd' : ∑ ib : Fin (Nat.card (JOneESNorm.Cos Γ) + 1) × Fin (m + 1),
+        algebraMap ℚ (LaurentSeries ℚ) (d ib) *
+          (xq ^ (ib.2 : ℕ) * (intSeriesC ℚ pf / intSeriesC ℚ pg) ^ (ib.1 : ℕ)) = 0 := by
+      rw [← hd]
+      refine Finset.sum_congr rfl fun ib _ => ?_
+      rw [← HahnSeries.C_mul_eq_smul, HahnSeries.C_eq_algebraMap]
+      congr 1
+      exact RingHom.congr_fun (Subsingleton.elim _ _) _
+    rw [← hd']
+    simp only [p, map_sum, Polynomial.aeval_monomial]
+    rw [IntermediateField.coe_sum, Fintype.sum_prod_type]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [MulMemClass.coe_mul, SubmonoidClass.coe_pow, ← hY, IntermediateField.algebraMap_apply,
+      hcoef,
+      Finset.sum_mul]
+    refine Finset.sum_congr rfl fun b _ => ?_
+    ring
+
+end JOneESRat
+
+open scoped MatrixGroups in
+theorem solution
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hT : ModularGroup.T ∈ Γ) :
+    ∃ x : ModularCurve.qExpFunctionFieldC ℚ Γ, Transcendental ℚ x ∧
+      FiniteDimensional
+        (IntermediateField.adjoin ℚ ({x} : Set (ModularCurve.qExpFunctionFieldC ℚ Γ)))
+        (ModularCurve.qExpFunctionFieldC ℚ Γ) :=
+  JOneESRat.exists_transcendental_finiteDimensional hT
+
+end S_ModularCurve_JOneES_exists_transcendental_finiteDimensional_qExpFunctionFieldC
+end P2MW
+export P2MW.S_ModularCurve_JOneES_exists_transcendental_finiteDimensional_qExpFunctionFieldC
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.JOneES.exists_transcendental_finiteDimensional_qExpFunctionFieldC
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hT : ModularGroup.T ∈ Γ) :
+    ∃ x : ModularCurve.qExpFunctionFieldC ℚ Γ, Transcendental ℚ x ∧
+      FiniteDimensional
+        (IntermediateField.adjoin ℚ ({x} : Set (ModularCurve.qExpFunctionFieldC ℚ Γ)))
+        (ModularCurve.qExpFunctionFieldC ℚ Γ) :=
+  solution Γ hT
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_Descent_fixer_le.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_Descent_fixer_le.lean
new file mode 100644
index 0000000000..e3d45767d3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_Descent_fixer_le.lean
@@ -0,0 +1,436 @@
+/-
+Based on Prove2Me node ModularCurve.LevelN.Descent.fixer_le
+(533e00aa-e878-5a51-adb4-056c05d03b4d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission cb286391-1144-5745-8a41-7baf91995d6d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.Data.Int.Star
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Elements fixing Φ pointwise lie in ±Γ₁(M)
+
+Theorem statement: `ModularCurve.LevelN.Descent.fixer_le` (`533e00aa-e878-5a51-adb4-056c05d03b4d`),
+by Claude, 2026-09-05.
+
+Proof: submission `cb286391-1144-5745-8a41-7baf91995d6d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a positive integer $M$, a field $K$ equipped with a $\mathbb{C}$-algebra structure, an element
+$t\in K$, and a group homomorphism $\sigma\colon \mathrm{SL}_2(\mathbb{Z})\to
+\mathrm{Aut}_{\mathbb{C}}(K)$ whose kernel is the subgroup generated by $\Gamma(M)$ together with
+$-1$; assume $K$ is finite-dimensional and Galois over the subfield $\mathbb{C}\langle t\rangle$
+generated by $t$, of degree equal to the index of $\Gamma(M)\cdot\langle -1\rangle$ in
+$\mathrm{SL}_2(\mathbb{Z})$. Let $\iota\colon \overline{\mathbb{Q}}\to\mathbb{C}$ be a ring
+homomorphism, and let $F$ denote the intermediate field of $\overline{\mathbb{Q}}((q))$ obtained by
+adjoining to $\overline{\mathbb{Q}}$ the coefficientwise images of the field generated over
+$\mathbb{Q}$ inside $\mathbb{Q}((q))$ by the quotients of integral $q$-expansions of pairs of
+modular forms of equal weight on $\Gamma_1(M)$ (denominator nonzero). Let $\Phi\colon F\to K$ be a
+ring homomorphism and $E'\colon K\to\mathbb{C}((q))$ a $\mathbb{C}$-algebra homomorphism with
+$E'(t)$ the series $q^{-1}\cdot(E_4^3\eta^{-24}$-type integral expansion$)$ of $j$ with $q$ replaced
+by $q^M$, and $E'(\Phi u)$ equal to the $q\mapsto q^M$ substitution applied to the $\iota$-image of
+$u$ for every $u\in F$. Assume further that $\Phi$ sends the element $y_0\in F$ whose Laurent series
+is the $j$-expansion over $\overline{\mathbb{Q}}$ to $t$, and that $\sigma(\gamma)$ fixes $\Phi u$
+for all $\gamma\in\Gamma_1(M)$ and all $u$. Then any $\delta\in\mathrm{SL}_2(\mathbb{Z})$ with
+$\sigma(\delta)(\Phi u)=\Phi u$ for all $u$ lies in the subgroup generated by $\Gamma_1(M)$ and
+$-1$.
+
+This is the Galois-correspondence step identifying the pointwise fixer of the image of the function
+field of $X_1(M)$ inside $\mathrm{Gal}(K/\mathbb{C}(t))$ as exactly $\pm\Gamma_1(M)/\pm\Gamma(M)$,
+the inclusion in the nontrivial direction. It is used in the descent computation of ramification
+orders for the $\Gamma_1(M)$ base change over $\overline{\mathbb{Q}}$, via the degree formula
+$[\,\mathbb{C}\cdot F : \mathbb{C}(j(q^M))\,]=[\mathrm{SL}_2(\mathbb{Z}):\pm\Gamma_1(M)]$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_LevelN_Descent_fixer_le.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_LevelN_Descent_fixer_le
+
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_LevelN_Descent_fixer_le.ModularCurve"
+open scoped MatrixGroups IntermediateField
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpFunctionFieldC qExpand qExpand_single coeffMap coeffMap_single \
+  coeffMap_coeffMap coeffMap_congr algebraMap_laurentSeries_eq_single coeffMap_algebraMap coeffEmb \
+  coeffMap_coeffEmb laurentBaseChange coeffEmb_mem_laurentBaseChange mem_laurentBaseChange_iff \
+  coeffMap_mem_laurentBaseChange jqModC map_jqModC \
+  finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index"
+namespace LevelN
+namespace Descent
+p2m_open "ModularCurve.LevelN ModularCurve"
+
+local notation "ℚ̄" => AlgebraicClosure ℚ
+
+def qExpC (M : ℕ) [NeZero M] : LaurentSeries ℂ →ₐ[ℂ] LaurentSeries ℂ :=
+  { qExpand ℂ M with
+    commutes' := fun c => by
+      change qExpand ℂ M (algebraMap ℂ (LaurentSeries ℂ) c) = algebraMap ℂ (LaurentSeries ℂ) c
+      rw [algebraMap_laurentSeries_eq_single, qExpand_single, mul_zero] }
+
+theorem qExpC_apply (M : ℕ) [NeZero M] (f : LaurentSeries ℂ) : qExpC M f = qExpand ℂ M f := rfl
+
+variable (ι : ℚ̄ →+* ℂ) (F₀ : IntermediateField ℚ (LaurentSeries ℚ))
+
+theorem coeffMap_coeffEmb (x : LaurentSeries ℚ) : coeffMap ι (coeffEmb ℚ̄ x) = coeffEmb ℂ x := by
+  change coeffMap _ (coeffMap _ x) = coeffMap _ x
+  rw [coeffMap_coeffMap]
+  exact coeffMap_congr (RingHom.ext_rat _ _) x
+
+theorem coeffMap_algebraMap (c : ℚ̄) :
+    coeffMap ι (algebraMap ℚ̄ (LaurentSeries ℚ̄) c) = algebraMap ℂ (LaurentSeries ℂ) (ι c) := by
+  rw [algebraMap_laurentSeries_eq_single, algebraMap_laurentSeries_eq_single, coeffMap_single]
+
+theorem coeffMap_mem_laurentBaseChange {x : LaurentSeries ℚ̄} (hx : x ∈ laurentBaseChange ℚ̄ F₀) :
+    coeffMap ι x ∈ laurentBaseChange ℂ F₀ := by
+  rw [mem_laurentBaseChange_iff] at hx
+  induction hx using Subfield.closure_induction with
+  | mem y hy =>
+      rcases hy with ⟨a, rfl⟩ | ⟨z, hz, rfl⟩
+      · rw [coeffMap_algebraMap]
+        exact (laurentBaseChange ℂ F₀).algebraMap_mem _
+      · rw [coeffMap_coeffEmb]
+        exact coeffEmb_mem_laurentBaseChange ℂ hz
+  | one => simp
+  | add _ _ _ _ hx hy => simpa using add_mem hx hy
+  | neg _ _ hx => simpa using neg_mem hx
+  | inv _ _ hx => simpa using inv_mem hx
+  | mul _ _ _ _ hx hy => simpa using mul_mem hx hy
+
+section Degree
+
+variable (M : ℕ) [NeZero M]
+variable (K : Type*) [Field K] [Algebra ℂ K]
+
+local notation "FF" => laurentBaseChange ℚ̄ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))
+local notation "FC" => laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))
+
+theorem map_adjoin_range_eq (Φ : ↥FF →+* K) (E' : K →ₐ[ℂ] LaurentSeries ℂ)
+    (hE'Φ : ∀ u : ↥FF, E' (Φ u) = qExpand ℂ M (coeffMap ι (u : LaurentSeries ℚ̄))) :
+    (IntermediateField.adjoin ℂ (Set.range Φ)).map E' = (FC).map (qExpC M) := by
+  apply le_antisymm
+  · rw [IntermediateField.adjoin_map, IntermediateField.adjoin_le_iff]
+    rintro _ ⟨_, ⟨u, rfl⟩, rfl⟩
+    change E' (Φ u) ∈ (FC).map (qExpC M)
+    rw [hE'Φ, ← qExpC_apply]
+    exact ⟨coeffMap ι u, coeffMap_mem_laurentBaseChange ι _ u.2, rfl⟩
+  · unfold laurentBaseChange
+    rw [IntermediateField.adjoin_map, IntermediateField.adjoin_le_iff, IntermediateField.adjoin_map]
+    rintro _ ⟨_, ⟨x, hx, rfl⟩, rfl⟩
+    change qExpC M (coeffEmb ℂ x) ∈ _
+    have hu : coeffEmb ℚ̄ x ∈ FF := coeffEmb_mem_laurentBaseChange ℚ̄ hx
+    have : qExpC M (coeffEmb ℂ x) = E' (Φ ⟨coeffEmb ℚ̄ x, hu⟩) := by
+      rw [hE'Φ, qExpC_apply, coeffMap_coeffEmb]
+    rw [this]
+    exact IntermediateField.subset_adjoin ℂ _ ⟨Φ ⟨coeffEmb ℚ̄ x, hu⟩, ⟨_, rfl⟩, rfl⟩
+
+theorem finrank_adjoin_eq_index (Φ : ↥FF →+* K) (E' : K →ₐ[ℂ] LaurentSeries ℂ)
+    (t : K) (hE'j : E' t = qExpand ℂ M (jqModC ℂ))
+    (hE'Φ : ∀ u : ↥FF, E' (Φ u) = qExpand ℂ M (coeffMap ι (u : LaurentSeries ℚ̄)))
+    (y₀ : ↥FF) (hy₀ : (y₀ : LaurentSeries ℚ̄) = jqModC ℚ̄) (hΦy : Φ y₀ = t) :
+    Module.finrank ↥ℂ⟮(⟨t, hΦy ▸ IntermediateField.subset_adjoin ℂ _ ⟨y₀, rfl⟩⟩ :
+        ↥(IntermediateField.adjoin ℂ (Set.range Φ)))⟯ ↥(IntermediateField.adjoin ℂ (Set.range Φ)) =
+      (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index := by
+  let yC : ↥FC := ⟨coeffMap ι (y₀ : LaurentSeries ℚ̄), coeffMap_mem_laurentBaseChange ι _ y₀.2⟩
+  have hyC : (yC : LaurentSeries ℂ) = jqModC ℂ := by
+    change coeffMap ι (y₀ : LaurentSeries ℚ̄) = jqModC ℂ
+    rw [hy₀]; exact map_jqModC ι
+  have hfull :=
+    ModularCurve.finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index ℂ M yC
+      hyC
+  rw [← hfull]
+  symm
+  set EE : IntermediateField ℂ K := IntermediateField.adjoin ℂ (Set.range Φ) with hEE
+  have htmem : t ∈ EE := hΦy ▸ IntermediateField.subset_adjoin ℂ _ ⟨y₀, rfl⟩
+  set tE : ↥EE := ⟨t, htmem⟩ with htE
+  have heq : (FC).map (qExpC M) = EE.map E' := (map_adjoin_range_eq ι M K Φ E' hE'Φ).symm
+  let j : ↥FC ≃ₐ[ℂ] ↥EE :=
+    ((FC).equivMap (qExpC M)).trans ((IntermediateField.equivOfEq heq).trans (EE.equivMap E').symm)
+  have hj : ∀ z : ↥FC, ((j z : ↥EE) : K) = (j z : K) := fun _ => rfl
+  have hjval : ∀ z : ↥FC, E' ((j z : ↥EE) : K) = qExpC M (z : LaurentSeries ℂ) := by
+    intro z
+    change (((EE.equivMap E') (j z) : ↥(EE.map E')) : LaurentSeries ℂ) = _
+    change (((EE.equivMap E') ((EE.equivMap E').symm
+      (IntermediateField.equivOfEq heq ((FC).equivMap (qExpC M) z))) : ↥(EE.map E')) : LaurentSeries
+        ℂ) = _
+    rw [AlgEquiv.apply_symm_apply]
+    rfl
+  have hjy : j yC = tE := by
+    apply Subtype.ext
+    apply E'.toRingHom.injective
+    change E' ((j yC : ↥EE) : K) = E' t
+    rw [hjval, qExpC_apply, hyC, hE'j]
+  have hmap : (ℂ⟮yC⟯).map j.toAlgHom = ℂ⟮tE⟯ := by
+    rw [IntermediateField.adjoin_map, Set.image_singleton]
+    change ℂ⟮j yC⟯ = ℂ⟮tE⟯
+    rw [hjy]
+  let i : ↥ℂ⟮yC⟯ ≃ₐ[ℂ] ↥ℂ⟮tE⟯ :=
+    ((ℂ⟮yC⟯).equivMap j.toAlgHom).trans (IntermediateField.equivOfEq hmap)
+  have hi : ∀ z : ↥ℂ⟮yC⟯, ((i z : ↥ℂ⟮tE⟯) : ↥EE) = j (z : ↥FC) := fun _ => rfl
+  refine Algebra.finrank_eq_of_equiv_equiv i.toRingEquiv j.toRingEquiv ?_
+  refine RingHom.ext fun z => ?_
+  change ((i z : ↥ℂ⟮tE⟯) : ↥EE) = j (z : ↥FC)
+  exact hi z
+
+end Degree
+
+section Fixer
+
+variable (M : ℕ) [NeZero M]
+variable (K : Type*) [Field K] [Algebra ℂ K]
+
+local notation "FF" => laurentBaseChange ℚ̄ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))
+
+theorem apply_eq_self_of_mem_adjoin (t : K) (ψ : K →ₐ[ℂ] K) (ht : ψ t = t) (z : K) (hz : z ∈ ℂ⟮t⟯) :
+    ψ z = z := by
+  let S : IntermediateField ℂ K :=
+    (AlgHom.equalizer ψ (AlgHom.id ℂ K)).toIntermediateField (fun x hx => by
+    simp only [AlgHom.mem_equalizer, AlgHom.coe_id, id_eq] at hx ⊢
+    rw [map_inv₀, hx])
+  have hle : ℂ⟮t⟯ ≤ S := by
+    rw [IntermediateField.adjoin_le_iff, Set.singleton_subset_iff]
+    change ψ t = AlgHom.id ℂ K t
+    rw [ht]; rfl
+  exact hle hz
+
+theorem apply_eq_self_of_mem_adjoin_range {F : Type*} (Φ : F → K) (ψ : K →ₐ[ℂ] K)
+    (hΦ : ∀ u, ψ (Φ u) = Φ u) (z : K)
+    (hz : z ∈ IntermediateField.adjoin ℂ (Set.range Φ)) : ψ z = z := by
+  let S : IntermediateField ℂ K :=
+    (AlgHom.equalizer ψ (AlgHom.id ℂ K)).toIntermediateField (fun x hx => by
+    simp only [AlgHom.mem_equalizer, AlgHom.coe_id, id_eq] at hx ⊢
+    rw [map_inv₀, hx])
+  have hle : IntermediateField.adjoin ℂ (Set.range Φ) ≤ S := by
+    rw [IntermediateField.adjoin_le_iff]
+    rintro _ ⟨u, rfl⟩
+    change ψ (Φ u) = AlgHom.id ℂ K (Φ u)
+    rw [hΦ]; rfl
+  exact hle hz
+
+theorem fixer_le (t : K)
+    (σ : SL(2, ℤ) →* (K ≃ₐ[ℂ] K))
+    (hker : σ.ker = CongruenceSubgroup.Gamma M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)))
+    (hfin : FiniteDimensional ℂ⟮t⟯ K) (hgal : IsGalois ℂ⟮t⟯ K)
+    (hdeg : Module.finrank ℂ⟮t⟯ K = (CongruenceSubgroup.Gamma M ⊔ Subgroup.zpowers (-1 : SL(2,
+      ℤ))).index)
+    (ι : ℚ̄ →+* ℂ) (Φ : ↥FF →+* K) (E' : K →ₐ[ℂ] LaurentSeries ℂ)
+    (hE'j : E' t = qExpand ℂ M (jqModC ℂ))
+    (hE'Φ : ∀ u : ↥FF, E' (Φ u) = qExpand ℂ M (coeffMap ι (u : LaurentSeries ℚ̄)))
+    (y₀ : ↥FF) (hy₀ : (y₀ : LaurentSeries ℚ̄) = jqModC ℚ̄) (hΦy : Φ y₀ = t)
+    (hΦfix : ∀ γ ∈ CongruenceSubgroup.Gamma1 M, ∀ u, σ γ (Φ u) = Φ u)
+    (δ : SL(2, ℤ)) (hδ : ∀ u, σ δ (Φ u) = Φ u) :
+    δ ∈ CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) := by
+  classical
+  have := hfin
+  have := hgal
+  let S₁ : Subgroup SL(2, ℤ) :=
+    { carrier := {δ | ∀ u, σ δ (Φ u) = Φ u}
+      mul_mem' := fun {a b} ha hb u => by
+        change σ (a * b) (Φ u) = Φ u
+        rw [map_mul, AlgEquiv.mul_apply, hb, ha]
+      one_mem' := fun u => by
+        change σ 1 (Φ u) = Φ u
+        rw [map_one, AlgEquiv.one_apply]
+      inv_mem' := fun {a} ha u => by
+        change σ a⁻¹ (Φ u) = Φ u
+        rw [map_inv, AlgEquiv.aut_inv]
+        conv_lhs => rw [← ha u]
+        exact (σ a).symm_apply_apply _ }
+  have hmemS : ∀ d, d ∈ S₁ ↔ ∀ u, σ d (Φ u) = Φ u := fun _ => Iff.rfl
+  set G₁ : Subgroup SL(2, ℤ) := CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) with
+    hG₁
+  have hneg : σ (-1) = 1 := by
+    have : (-1 : SL(2, ℤ)) ∈ σ.ker :=
+      by rw [hker]; exact Subgroup.mem_sup_right (Subgroup.mem_zpowers _)
+    exact this
+  have hkerS : σ.ker ≤ S₁ := fun d hd u => by
+    have hd' : σ d = 1 := hd
+    rw [hd', AlgEquiv.one_apply]
+  have hG₁S : G₁ ≤ S₁ := by
+    refine sup_le (fun d hd => (hmemS d).mpr (hΦfix d hd)) ?_
+    rw [Subgroup.zpowers_le]
+    intro u
+    show σ (-1) (Φ u) = Φ u
+    rw [hneg, AlgEquiv.one_apply]
+  set EE : IntermediateField ℂ K := IntermediateField.adjoin ℂ (Set.range Φ) with hEE
+  have htmem : t ∈ EE := hΦy ▸ IntermediateField.subset_adjoin ℂ _ ⟨y₀, rfl⟩
+  have hle : ℂ⟮t⟯ ≤ EE := IntermediateField.adjoin_simple_le_iff.mpr htmem
+  let E₂ : IntermediateField ↥ℂ⟮t⟯ K := IntermediateField.extendScalars hle
+  have hfixt : ∀ d : S₁, ∀ z ∈ ℂ⟮t⟯, σ d z = z := fun d z hz =>
+    apply_eq_self_of_mem_adjoin K t (σ d : K →ₐ[ℂ] K) (by rw [← hΦy]; exact d.2 y₀) z hz
+  let θ : S₁ →* (K ≃ₐ[ℂ⟮t⟯] K) :=
+    { toFun := fun d => { (σ d).toRingEquiv with commutes' := fun z => hfixt d z z.2 }
+      map_one' := AlgEquiv.ext fun z => by
+        change σ (1 : S₁) z = z
+        rw [OneMemClass.coe_one, map_one, AlgEquiv.one_apply]
+      map_mul' := fun a b => AlgEquiv.ext fun z => by
+        change σ ((a * b : S₁) : SL(2, ℤ)) z = σ a (σ b z)
+        rw [Subgroup.coe_mul, map_mul, AlgEquiv.mul_apply] }
+  have hθapply : ∀ (d : S₁) (z : K), θ d z = σ d z := fun _ _ => rfl
+  have hθrange : θ.range ≤ E₂.fixingSubgroup := by
+    rintro _ ⟨d, rfl⟩
+    rw [IntermediateField.mem_fixingSubgroup_iff]
+    intro z hz
+    rw [hθapply]
+    exact apply_eq_self_of_mem_adjoin_range K Φ (σ d : K →ₐ[ℂ] K) d.2 z hz
+  have hθker : θ.ker = σ.ker.subgroupOf S₁ := by
+    ext d
+    rw [MonoidHom.mem_ker, Subgroup.mem_subgroupOf, MonoidHom.mem_ker]
+    constructor
+    · intro h
+      apply AlgEquiv.ext
+      intro z
+      have := congrArg (fun f : K ≃ₐ[ℂ⟮t⟯] K => f z) h
+      exact this
+    · intro h
+      apply AlgEquiv.ext
+      intro z
+      change σ d z = z
+      rw [h, AlgEquiv.one_apply]
+  have : Finite (K ≃ₐ[ℂ⟮t⟯] K) := inferInstance
+  have hcard1 : Nat.card θ.range ≤ Nat.card E₂.fixingSubgroup := Subgroup.card_le_of_le hθrange
+  have hcard2 : Nat.card E₂.fixingSubgroup = Module.finrank ↥E₂ K :=
+    IsGalois.card_fixingSubgroup_eq_finrank E₂
+  have hcard3 : σ.ker.relIndex S₁ = Nat.card θ.range := by
+    rw [← Subgroup.index_ker, hθker]; rfl
+  have htower : Module.finrank ↥ℂ⟮t⟯ ↥E₂ * Module.finrank ↥E₂ K = Module.finrank ↥ℂ⟮t⟯ K :=
+    Module.finrank_mul_finrank _ _ _
+  have hE₂ : Module.finrank ↥ℂ⟮t⟯ ↥E₂ = G₁.index := by
+    have h0 := finrank_adjoin_eq_index ι M K Φ E' t hE'j hE'Φ y₀ hy₀ hΦy
+    rw [← h0]
+    set tE : ↥EE := ⟨t, hΦy ▸ IntermediateField.subset_adjoin ℂ _ ⟨y₀, rfl⟩⟩ with htE
+    have hlift : IntermediateField.lift ℂ⟮tE⟯ = ℂ⟮t⟯ := by
+      rw [IntermediateField.lift_adjoin_simple]
+    let e₁ : ↥ℂ⟮tE⟯ ≃ₐ[ℂ] ↥ℂ⟮t⟯ :=
+      (IntermediateField.liftAlgEquiv _).trans (IntermediateField.equivOfEq hlift)
+    let e₂ : ↥EE ≃+* ↥E₂ := RingEquiv.refl _
+    symm
+    refine Algebra.finrank_eq_of_equiv_equiv e₁.toRingEquiv e₂ ?_
+    refine RingHom.ext fun w => Subtype.ext ?_
+    rfl
+  have ha : Module.finrank ↥ℂ⟮t⟯ K = σ.ker.index := by rw [hdeg, hker]
+  have hapos : 0 < Module.finrank ↥ℂ⟮t⟯ K := Module.finrank_pos
+  have hrs : σ.ker.relIndex S₁ * S₁.index = σ.ker.index := Subgroup.relIndex_mul_index hkerS
+  have hr_le : σ.ker.relIndex S₁ ≤ Module.finrank ↥E₂ K := by rw [hcard3, ← hcard2]; exact hcard1
+  have hsb : S₁.index ∣ G₁.index := Subgroup.index_dvd_of_le hG₁S
+  have hb0 : G₁.index ≠ 0 := by
+    intro h0
+    rw [h0] at hE₂
+    rw [hE₂, zero_mul] at htower
+    omega
+  have hs_le : S₁.index ≤ G₁.index := Nat.le_of_dvd (Nat.pos_of_ne_zero hb0) hsb
+  have hbs : G₁.index ≤ S₁.index := by
+    have h1 : σ.ker.relIndex S₁ * S₁.index = Module.finrank ↥ℂ⟮t⟯ ↥E₂ * Module.finrank ↥E₂ K := by
+      rw [hrs, ← ha, htower]
+    rw [hE₂] at h1
+    have hr0 : 0 < σ.ker.relIndex S₁ := by
+      rcases Nat.eq_zero_or_pos (σ.ker.relIndex S₁) with h | h
+      · rw [h, zero_mul] at h1
+        have : 0 < G₁.index * Module.finrank ↥E₂ K := by
+          rw [← hE₂, htower]; exact hapos
+        omega
+      · exact h
+    nlinarith
+  have hseq : S₁.index = G₁.index := le_antisymm hs_le hbs
+  have hrel : G₁.relIndex S₁ * S₁.index = G₁.index := Subgroup.relIndex_mul_index hG₁S
+  rw [hseq] at hrel
+  have hrel1 : G₁.relIndex S₁ = 1 := by
+    have : G₁.relIndex S₁ * G₁.index = 1 * G₁.index := by rw [hrel, one_mul]
+    exact Nat.eq_of_mul_eq_mul_right (Nat.pos_of_ne_zero hb0) this
+  exact (Subgroup.relIndex_eq_one.mp hrel1) ((hmemS δ).mpr hδ)
+
+end Fixer
+
+end ModularCurve.LevelN.Descent
+
+end
+
+theorem solution (M : ℕ) [NeZero M]
+    (K : Type*) [Field K] [Algebra ℂ K] (t : K)
+    (σ : SL(2, ℤ) →* (K ≃ₐ[ℂ] K))
+    (hker : σ.ker = CongruenceSubgroup.Gamma M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)))
+    (hfin : FiniteDimensional ℂ⟮t⟯ K) (hgal : IsGalois ℂ⟮t⟯ K)
+    (hdeg : Module.finrank ℂ⟮t⟯ K = (CongruenceSubgroup.Gamma M ⊔ Subgroup.zpowers (-1 : SL(2,
+      ℤ))).index)
+    (ι : AlgebraicClosure ℚ →+* ℂ)
+    (Φ : ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+        (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))) →+* K)
+    (E' : K →ₐ[ℂ] LaurentSeries ℂ)
+    (hE'j : E' t = ModularCurve.qExpand ℂ M (ModularCurve.jqModC ℂ))
+    (hE'Φ : ∀ u : ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+        (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))),
+        E' (Φ u) = ModularCurve.qExpand ℂ M (ModularCurve.coeffMap ι (u : LaurentSeries
+          (AlgebraicClosure ℚ))))
+    (y₀ : ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+        (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))))
+    (hy₀ : (y₀ : LaurentSeries (AlgebraicClosure ℚ)) = ModularCurve.jqModC (AlgebraicClosure ℚ))
+    (hΦy : Φ y₀ = t)
+    (hΦfix : ∀ γ ∈ CongruenceSubgroup.Gamma1 M, ∀ u, σ γ (Φ u) = Φ u)
+    (δ : SL(2, ℤ)) (hδ : ∀ u, σ δ (Φ u) = Φ u) :
+    δ ∈ CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) :=
+  ModularCurve.LevelN.Descent.fixer_le M K t σ hker hfin hgal hdeg ι Φ E' hE'j hE'Φ y₀ hy₀ hΦy hΦfix
+    δ hδ
+
+end S_ModularCurve_LevelN_Descent_fixer_le
+end P2MW
+export P2MW.S_ModularCurve_LevelN_Descent_fixer_le (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups IntermediateField
+theorem ModularCurve.LevelN.Descent.fixer_le (M : ℕ) [NeZero M]
+    (K : Type*) [Field K] [Algebra ℂ K] (t : K)
+    (σ : SL(2, ℤ) →* (K ≃ₐ[ℂ] K))
+    (hker : σ.ker = CongruenceSubgroup.Gamma M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)))
+    (hfin : FiniteDimensional ℂ⟮t⟯ K) (hgal : IsGalois ℂ⟮t⟯ K)
+    (hdeg : Module.finrank ℂ⟮t⟯ K = (CongruenceSubgroup.Gamma M ⊔ Subgroup.zpowers (-1 : SL(2,
+      ℤ))).index)
+    (ι : AlgebraicClosure ℚ →+* ℂ)
+    (Φ : ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+        (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))) →+* K)
+    (E' : K →ₐ[ℂ] LaurentSeries ℂ)
+    (hE'j : E' t = ModularCurve.qExpand ℂ M (ModularCurve.jqModC ℂ))
+    (hE'Φ : ∀ u : ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+        (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))),
+        E' (Φ u) = ModularCurve.qExpand ℂ M (ModularCurve.coeffMap ι (u : LaurentSeries
+          (AlgebraicClosure ℚ))))
+    (y₀ : ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+        (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))))
+    (hy₀ : (y₀ : LaurentSeries (AlgebraicClosure ℚ)) = ModularCurve.jqModC (AlgebraicClosure ℚ))
+    (hΦy : Φ y₀ = t)
+    (hΦfix : ∀ γ ∈ CongruenceSubgroup.Gamma1 M, ∀ u, σ γ (Φ u) = Φ u)
+    (δ : SL(2, ℤ)) (hδ : ∀ u, σ δ (Φ u) = Φ u) :
+    δ ∈ CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) :=
+  solution M K t σ hker hfin hgal hdeg ι Φ E' hE'j hE'Φ y₀ hy₀ hΦy hΦfix δ hδ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_algHom_laurentBaseChange_apply_eq_qExpand.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_algHom_laurentBaseChange_apply_eq_qExpand.lean
new file mode 100644
index 0000000000..52c5757171
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_algHom_laurentBaseChange_apply_eq_qExpand.lean
@@ -0,0 +1,255 @@
+/-
+Based on Prove2Me node ModularCurve.LevelN.exists_algHom_laurentBaseChange_apply_eq_qExpand
+(7a3c824d-739d-5148-b55c-0a9f9b438a98) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 462e8492-1441-55ad-8813-de7d0ffe5c16
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LevelNFunctionField
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN_qExpansion
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Level-M realisation of the q-expansion function field
+
+Theorem statement: `ModularCurve.LevelN.exists_algHom_laurentBaseChange_apply_eq_qExpand`
+(`7a3c824d-739d-5148-b55c-0a9f9b438a98`), by Claude, 2026-09-05.
+
+Proof: submission `462e8492-1441-55ad-8813-de7d0ffe5c16`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $M \ge 1$ and let $A_M =$ [`ModularCurve.LevelN.ring
+M`](def/ModularCurve_LevelNFunctionField.html#L28) be the $\mathbb{C}$-subalgebra of functions
+$\mathbb{H} \to \mathbb{C}$ generated by $j = E_4^3/\Delta$ together with the Fricke functions $f_v$
+for all nonzero $v \in (\mathbb{Z}/M)^2$. Let $K$ be a field that is simultaneously a
+$\mathbb{C}$-algebra and an $A_M$-algebra, with $\mathbb{C} \to A_M \to K$ a scalar tower and $K$ a
+fraction field of $A_M$. Suppose given a group homomorphism $\sigma : \mathrm{SL}_2(\mathbb{Z}) \to
+\mathrm{Aut}_{\mathbb{C}}(K)$ whose kernel is the subgroup generated by $\Gamma(M)$ together with
+$-1$ (the join of $\Gamma(M)$ and the integer powers of $-1$), and such that the fixed field of the
+image of $\sigma$ is the subfield of $K$ generated over $\mathbb{C}$ by the image of $j$ under $A_M
+\to K$. Suppose further given a $\mathbb{C}$-algebra homomorphism $E : K \to \mathbb{C}((q))$
+(Laurent series over $\mathbb{C}$) sending the image of $j$ to $\mathrm{qExpand}_M$ applied to
+[`ModularCurve.jqModC`](def/ModularCurve_JqCoeff.html#L15), the Laurent series
+$q^{-1}\cdot(\text{the integral power series } E_4^3\eta^{-24}\text{ read in }\mathbb{C})$; here
+$\mathrm{qExpand}_M$ is the ring endomorphism of $\mathbb{C}((q))$ multiplying all exponents by $M$,
+i.e. the substitution $q \mapsto q^M$. Finally let $\Gamma \le \mathrm{SL}_2(\mathbb{Z})$ contain
+$\Gamma(M)$ and the translation matrix $T$. Then there is a $\mathbb{C}$-algebra homomorphism $\Psi$
+from [`ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+Γ)`](def/ModularCurve_LaurentCoeff.html#L103) — the subfield of $\mathbb{C}((q))$ generated over
+$\mathbb{C}$ by the coefficientwise images of the subfield of $\mathbb{Q}((q))$ generated over
+$\mathbb{Q}$ by all quotients $p_f/p_g$ of integral $q$-expansions of two modular forms $f, g$ of
+one and the same weight $k$ for $\Gamma$, with $p_g \neq 0$ — into $K$, such that $E(\Psi(u)) =
+\mathrm{qExpand}_M(u)$ for every element $u$ of that subfield, the latter being read as a Laurent
+series.
+
+This is the classical statement that the $q$-expansion function field of $X(\Gamma)$, for $\Gamma
+\supseteq \Gamma(M)$ containing $T$, is realised inside the field of modular functions of level $M$
+compatibly with $q$-expansions, here in a form universal in the chosen expansion map $E$: any
+$\mathbb{C}$-algebra map $K \to \mathbb{C}((q))$ matching $j$ with its $q^M$-expansion admits a
+compatible $\Psi$. It feeds the comparison of orders of vanishing and the computation of composita
+of the function fields attached to $X_1$-type levels.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_LevelN_exists_algHom_laurentBaseChange_apply_eq_qExpand.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_LevelN_exists_algHom_laurentBaseChange_apply_eq_qExpand
+
+open scoped MatrixGroups IntermediateField
+open Polynomial
+
+noncomputable def N3Prep.qExpandAlgHom (L : Type*) [Field L] (N : ℕ) [NeZero N] :
+    LaurentSeries L →ₐ[L] LaurentSeries L :=
+  AlgHom.mk' (ModularCurve.qExpand L N) (fun c x => by
+    rw [Algebra.smul_def, Algebra.smul_def, map_mul, LaurentSeries.algebraMap_apply,
+      ModularCurve.qExpand_C])
+
+theorem N3Prep.qExpandAlgHom_apply (L : Type*) [Field L] (N : ℕ) [NeZero N] (x : LaurentSeries L) :
+    N3Prep.qExpandAlgHom L N x = ModularCurve.qExpand L N x := rfl
+
+theorem N3Prep.exists_apply_eq_apply_smul
+    {F K L : Type*} [Field F] [Field K] [Algebra F K] [Field L] [Algebra F L]
+    (H : Subgroup (K ≃ₐ[F] K)) [Finite H] (E E' : K →ₐ[F] L)
+    (hagree : ∀ c ∈ IntermediateField.fixedField H, E c = E' c) (x : K) :
+    ∃ h : H, E' x = E ((h : K ≃ₐ[F] K) x) := by
+  classical
+  have : Fintype H := Fintype.ofFinite H
+  set Q : K[X] := ∏ h : H, (X - C ((h : K ≃ₐ[F] K) x)) with hQ
+  have hfix : ∀ i, Q.coeff i ∈ IntermediateField.fixedField H := by
+    intro i
+    rw [IntermediateField.mem_fixedField_iff]
+    intro g hg
+    have hmap : Q.map (g : K →+* K) = Q := by
+      rw [hQ, Polynomial.map_prod]
+      simp only [Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C, RingHom.coe_coe]
+      exact Fintype.prod_bijective (fun h : H => (⟨g, hg⟩ : H) * h) (Group.mulLeft_bijective _)
+        _ _ fun h => rfl
+    have := congrArg (fun P : K[X] => P.coeff i) hmap
+    simpa only [Polynomial.coeff_map, RingHom.coe_coe] using this
+  have hmapEE' : Q.map (E : K →+* L) = Q.map (E' : K →+* L) := by
+    ext i
+    rw [Polynomial.coeff_map, Polynomial.coeff_map, RingHom.coe_coe, RingHom.coe_coe]
+    exact hagree _ (hfix i)
+  have hQx : Q.eval x = 0 := by
+    rw [hQ, eval_prod]
+    exact Finset.prod_eq_zero (Finset.mem_univ (1 : H)) (by simp)
+  have hroot : (Q.map (E : K →+* L)).eval (E' x) = 0 := by
+    have h0 : Polynomial.eval₂ (E' : K →+* L) ((E' : K →+* L) x) Q = 0 := by
+      rw [Polynomial.eval₂_hom, hQx, map_zero]
+    rw [hmapEE', Polynomial.eval_map]
+    simpa only [RingHom.coe_coe] using h0
+  have hfac : Q.map (E : K →+* L) = ∏ h : H, (X - C (E ((h : K ≃ₐ[F] K) x))) := by
+    rw [hQ, Polynomial.map_prod]
+    simp only [Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C, RingHom.coe_coe]
+  rw [hfac, eval_prod, Finset.prod_eq_zero_iff] at hroot
+  obtain ⟨h, -, hh⟩ := hroot
+  refine ⟨h, ?_⟩
+  simpa [sub_eq_zero] using hh
+
+theorem N3Prep.exists_algHom_comp_eq
+    {F K L : Type*} [Field F] [Field K] [Algebra F K] [Field L] [Algebra F L]
+    (H : Subgroup (K ≃ₐ[F] K)) [Finite H] (E E' : K →ₐ[F] L)
+    (hagree : ∀ c ∈ IntermediateField.fixedField H, E c = E' c) :
+    ∃ g : K →ₐ[F] K, ∀ x, E (g x) = E' x := by
+  have hmem : ∀ x, E' x ∈ E.range := by
+    intro x
+    obtain ⟨h, hh⟩ := N3Prep.exists_apply_eq_apply_smul H E E' hagree x
+    exact ⟨_, hh.symm⟩
+  refine ⟨(AlgEquiv.ofInjectiveField E).symm.toAlgHom.comp (E'.codRestrict E.range hmem), fun x =>
+    ?_⟩
+  have h1 := AlgEquiv.ofInjective_apply E (RingHom.injective (E : K →+* L))
+    ((AlgEquiv.ofInjectiveField E).symm (E'.codRestrict E.range hmem x))
+  change E ((AlgEquiv.ofInjectiveField E).symm (E'.codRestrict E.range hmem x)) = E' x
+  rw [← h1]
+  change (((AlgEquiv.ofInjectiveField E) ((AlgEquiv.ofInjectiveField E).symm
+    (E'.codRestrict E.range hmem x))) : L) = E' x
+  rw [AlgEquiv.apply_symm_apply]
+  rfl
+
+theorem solution
+    (M : ℕ) [NeZero M]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring M) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring M) K]
+    [IsFractionRing (ModularCurve.LevelN.ring M) K]
+    (σ : SL(2, ℤ) →* (K ≃ₐ[ℂ] K))
+    (hker : σ.ker = CongruenceSubgroup.Gamma M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)))
+    (hfixed : IntermediateField.fixedField σ.range =
+      IntermediateField.adjoin ℂ
+        ({algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)} : Set K))
+    (E : K →ₐ[ℂ] LaurentSeries ℂ)
+    (hEj : E (algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)) =
+      ModularCurve.qExpand ℂ M (ModularCurve.jqModC ℂ))
+    (Γ : Subgroup SL(2, ℤ)) (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ) :
+    ∃ Ψ : ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ) →ₐ[ℂ] K,
+      ∀ u : ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ),
+        E (Ψ u) = ModularCurve.qExpand ℂ M (u : LaurentSeries ℂ) := by
+  classical
+  set jK := algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M) with hjK
+  have : Algebra.IsAlgebraic ℚ (AlgebraicClosure ℚ) := AlgebraicClosure.isAlgebraic ℚ
+  let ι : AlgebraicClosure ℚ →+* ℂ :=
+    (IsAlgClosed.lift (R := ℚ) (S := AlgebraicClosure ℚ) (M := ℂ)).toRingHom
+  have h9 := ModularCurve.exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN_qExpansion
+    M Γ hΓ hT ι K
+  obtain ⟨Φ, E₉, hE₉j, hE₉Φ, -, -, -⟩ := h9
+  have hcoeff : ∀ x : LaurentSeries ℚ,
+      ModularCurve.coeffMap ι (ModularCurve.coeffEmb (AlgebraicClosure ℚ) x) =
+        ModularCurve.coeffEmb ℂ x := by
+    intro x
+    rw [ModularCurve.coeffEmb, ModularCurve.coeffEmb, ModularCurve.coeffMap_coeffMap]
+    exact ModularCurve.coeffMap_congr (RingHom.ext_rat _ _) x
+  have hrange : ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ) ≤
+      E₉.fieldRange.comap (N3Prep.qExpandAlgHom ℂ M) := by
+    rw [ModularCurve.laurentBaseChange, IntermediateField.adjoin_le_iff]
+    rintro _ ⟨x, hx, rfl⟩
+    change N3Prep.qExpandAlgHom ℂ M (ModularCurve.coeffEmb ℂ x) ∈ E₉.fieldRange
+    rw [AlgHom.mem_fieldRange]
+    refine ⟨Φ ⟨ModularCurve.coeffEmb (AlgebraicClosure ℚ) x,
+      ModularCurve.coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) hx⟩, ?_⟩
+    rw [hE₉Φ, N3Prep.qExpandAlgHom_apply, hcoeff]
+  have hmem : ∀ u : ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ),
+      (N3Prep.qExpandAlgHom ℂ M).comp
+          (ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ)).val u ∈
+        E₉.range := by
+    intro u
+    obtain ⟨y, hy⟩ := AlgHom.mem_fieldRange.mp (hrange u.2)
+    exact ⟨y, hy⟩
+  let Ψ₉ : ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ) →ₐ[ℂ] K :=
+    (AlgEquiv.ofInjectiveField E₉).symm.toAlgHom.comp
+      (((N3Prep.qExpandAlgHom ℂ M).comp
+        (ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ)).val).codRestrict
+          E₉.range hmem)
+  have hΨ₉ : ∀ u, E₉ (Ψ₉ u) = ModularCurve.qExpand ℂ M (u : LaurentSeries ℂ) := by
+    intro u
+    set w : E₉.range := ((N3Prep.qExpandAlgHom ℂ M).comp
+      (ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ)).val).codRestrict
+        E₉.range hmem u with hw
+    have h1 := AlgEquiv.ofInjective_apply E₉ (RingHom.injective (E₉ : K →+* LaurentSeries ℂ))
+      ((AlgEquiv.ofInjectiveField E₉).symm w)
+    change E₉ ((AlgEquiv.ofInjectiveField E₉).symm w) = _
+    rw [← h1]
+    change (((AlgEquiv.ofInjectiveField E₉) ((AlgEquiv.ofInjectiveField E₉).symm w)) : LaurentSeries
+      ℂ) = _
+    rw [AlgEquiv.apply_symm_apply]
+    rfl
+  have : σ.ker.FiniteIndex := by
+    rw [hker]; exact Subgroup.finiteIndex_of_le le_sup_left
+  have : Finite σ.range :=
+    Finite.of_equiv _ (QuotientGroup.quotientKerEquivRange σ).toEquiv
+  have hagree : ∀ c ∈ IntermediateField.fixedField σ.range, E c = E₉ c := by
+    intro c hc
+    rw [hfixed] at hc
+    obtain ⟨p, q, rfl⟩ := (IntermediateField.mem_adjoin_simple_iff ℂ c).mp hc
+    have key : ∀ (φ : K →ₐ[ℂ] LaurentSeries ℂ) (r : ℂ[X]), φ (aeval jK r) = aeval (φ jK) r :=
+      fun φ r => (Polynomial.aeval_algHom_apply φ jK r).symm
+    rw [map_div₀, map_div₀, key E, key E, key E₉, key E₉, hEj, hE₉j]
+  obtain ⟨g, hg⟩ := N3Prep.exists_algHom_comp_eq σ.range E E₉ hagree
+  exact ⟨g.comp Ψ₉, fun u => by rw [AlgHom.comp_apply, hg, hΨ₉]⟩
+
+end S_ModularCurve_LevelN_exists_algHom_laurentBaseChange_apply_eq_qExpand
+end P2MW
+export P2MW.S_ModularCurve_LevelN_exists_algHom_laurentBaseChange_apply_eq_qExpand (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.LevelN.exists_algHom_laurentBaseChange_apply_eq_qExpand
+    (M : ℕ) [NeZero M]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring M) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring M) K]
+    [IsFractionRing (ModularCurve.LevelN.ring M) K]
+    (σ : SL(2, ℤ) →* (K ≃ₐ[ℂ] K))
+    (hker : σ.ker = CongruenceSubgroup.Gamma M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)))
+    (hfixed : IntermediateField.fixedField σ.range =
+      IntermediateField.adjoin ℂ
+        ({algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)} : Set K))
+    (E : K →ₐ[ℂ] LaurentSeries ℂ)
+    (hEj : E (algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)) =
+      ModularCurve.qExpand ℂ M (ModularCurve.jqModC ℂ))
+    (Γ : Subgroup SL(2, ℤ)) (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ) :
+    ∃ Ψ : ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ) →ₐ[ℂ] K,
+      ∀ u : ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ),
+        E (Ψ u) = ModularCurve.qExpand ℂ M (u : LaurentSeries ℂ) :=
+  solution M K σ hker hfixed E hEj Γ hΓ hT
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_algHom_laurentSeries_qExpansion.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_algHom_laurentSeries_qExpansion.lean
new file mode 100644
index 0000000000..aab05cad42
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_algHom_laurentSeries_qExpansion.lean
@@ -0,0 +1,688 @@
+/-
+Based on Prove2Me node ModularCurve.LevelN.exists_algHom_laurentSeries_qExpansion
+(ac5fac4d-f997-5082-ba9d-0f6d33d85739) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f0e89fbd-8b14-51e3-b97e-6ca5595e89b9
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LevelNFunctionField
+
+import Mathlib.Data.Int.Star
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_modularity_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_orbit_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelN_structure_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A q_N-expansion algebra map on the level-N function field
+
+Theorem statement: `ModularCurve.LevelN.exists_algHom_laurentSeries_qExpansion`
+(`ac5fac4d-f997-5082-ba9d-0f6d33d85739`), by Claude, 2026-09-05.
+
+Proof: submission `f0e89fbd-8b14-51e3-b97e-6ca5595e89b9`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N\ge 1$ (an `NeZero` instance) and write $A_N :=$ [`ModularCurve.LevelN.ring
+N`](def/ModularCurve_LevelNFunctionField.html#L28) for the $\mathbb{C}$-subalgebra of functions
+$\mathbb{H}\to\mathbb{C}$ generated by the modular invariant $j(\tau)=E_4(\tau)^3/\Delta(\tau)$
+together with the functions `fricke N v` for all nonzero $v\in(\mathbb{Z}/N)^2$ (the level-$N$
+Fricke functions). Let $K$ be a field which is simultaneously a $\mathbb{C}$-algebra and an
+$A_N$-algebra, compatibly (a scalar tower $\mathbb{C}\to A_N\to K$), and which is a fraction field
+of $A_N$. The assertion is that there exists a morphism of $\mathbb{C}$-algebras $E\colon
+K\to\mathbb{C}((q))$ into the Laurent series field with two properties. First, $E$ sends the image
+in $K$ of the distinguished generator `jGen N` (namely $j=E_4^3/\Delta$, viewed as an element of
+$A_N$) to `qExpand ℂ N` applied to `jqModC ℂ`, that is, to the Laurent series
+$q^{-1}\cdot(\mathrm{eisenstein4}^3\cdot\mathrm{dedekindEtaUnitInv})$ with integer coefficients read
+in $\mathbb{C}$ and with every exponent multiplied by $N$ (so $q$ replaced by $q_N^N$). Second, for
+every $F\colon\mathbb{H}\to\mathbb{C}$ lying in $A_N$ and every $m\in\mathbb{N}$ such that
+$F\cdot\Delta^m$ is bounded as $\operatorname{Im}\tau\to\infty$, the identity
+$E(F)\cdot\big(\text{$q_N$-expansion of }\Delta\big)^m=\big(\text{$q_N$-expansion of }
+F\cdot\Delta^m\big)$ holds in $\mathbb{C}((q_N))$, the power-series expansions
+`UpperHalfPlane.qExpansion N` being embedded into Laurent series via `HahnSeries.ofPowerSeries`.
+
+This is the $q$-expansion principle at the cusp $i\infty$ for the field of modular functions of
+level $N$: the $q_N$-expansion map $F\mapsto(\text{expansion of }F\Delta^m)/(\text{expansion of
+}\Delta)^m$ on $A_N$ extends to a $\mathbb{C}$-algebra map from the fraction field into
+$\mathbb{C}((q_N))$, normalised by the expansion of $j$. It is used downstream to compute valuations
+of $j$ at the place given by the cusp and to produce the Laurent-series base-change homomorphisms
+attached to the level-$N$ function field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_LevelN_exists_algHom_laurentSeries_qExpansion.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 1600000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_LevelN_exists_algHom_laurentSeries_qExpansion
+
+
+open UpperHalfPlane Filter Topology Function
+open scoped MatrixGroups Manifold Real
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "LevelN.ring LevelN.jGen jqModC qExpand qExpand_coeff_mul \
+  qExpand_coeff_of_not_dvd ofPowerSeries_coeff_of_neg jGen \
+  jqModC_eq_qExpansion_E4_cube_div_discriminant"
+namespace LevelN
+p2m_export "ModularCurve.LevelN" "wp fricke jAnalytic generators ring jAnalytic_mem jGen"
+namespace QExpEmbedding
+p2m_open "ModularCurve.LevelN ModularCurve"
+
+section Toolkit
+
+variable {h : ℝ}
+
+structure Good (h : ℝ) (G : ℍ → ℂ) : Prop where
+  periodic : Periodic (G ∘ ofComplex) h
+  mdiff : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G
+  bdd : IsBoundedAtImInfty G
+
+namespace Good
+
+variable {G G₁ G₂ : ℍ → ℂ}
+
+theorem analyticAt (hG : Good h G) (hh : 0 < h) : AnalyticAt ℂ (cuspFunction h G) 0 :=
+  analyticAt_cuspFunction_zero hh hG.periodic hG.mdiff hG.bdd
+
+theorem continuousAt (hG : Good h G) (hh : 0 < h) : ContinuousAt (cuspFunction h G) 0 :=
+  (hG.analyticAt hh).continuousAt
+
+theorem mul (h₁ : Good h G₁) (h₂ : Good h G₂) : Good h (G₁ * G₂) where
+  periodic := by
+    have : (G₁ * G₂) ∘ ofComplex = (G₁ ∘ ofComplex) * (G₂ ∘ ofComplex) := rfl
+    rw [this]
+    exact h₁.periodic.mul h₂.periodic
+  mdiff := h₁.mdiff.mul h₂.mdiff
+  bdd := h₁.bdd.mul h₂.bdd
+
+theorem add (h₁ : Good h G₁) (h₂ : Good h G₂) : Good h (G₁ + G₂) where
+  periodic := by
+    have : (G₁ + G₂) ∘ ofComplex = (G₁ ∘ ofComplex) + (G₂ ∘ ofComplex) := rfl
+    rw [this]
+    exact h₁.periodic.add h₂.periodic
+  mdiff := h₁.mdiff.add h₂.mdiff
+  bdd := h₁.bdd.add h₂.bdd
+
+theorem const (h : ℝ) (c : ℂ) : Good h (fun _ : ℍ => c) where
+  periodic := fun _ => rfl
+  mdiff := mdifferentiable_const
+  bdd := Filter.const_boundedAtFilter _ _
+
+theorem one (h : ℝ) : Good h (1 : ℍ → ℂ) := const h 1
+
+theorem pow (hG : Good h G) : ∀ n : ℕ, Good h (G ^ n)
+  | 0 => by rw [pow_zero]; exact one h
+  | n + 1 => by rw [pow_succ]; exact (pow hG n).mul hG
+
+end Good
+
+variable {G G₁ G₂ : ℍ → ℂ}
+
+theorem cuspFunction_mul_of_good (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) :
+    cuspFunction h (G₁ * G₂) = cuspFunction h G₁ * cuspFunction h G₂ :=
+  cuspFunction_mul (h₁.continuousAt hh) (h₂.continuousAt hh)
+
+theorem cuspFunction_add_of_good (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) :
+    cuspFunction h (G₁ + G₂) = cuspFunction h G₁ + cuspFunction h G₂ :=
+  cuspFunction_add (h₁.continuousAt hh) (h₂.continuousAt hh)
+
+theorem qExpansion_mul_of_good (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) :
+    qExpansion h (G₁ * G₂) = qExpansion h G₁ * qExpansion h G₂ :=
+  qExpansion_mul (h₁.analyticAt hh) (h₂.analyticAt hh)
+
+theorem qExpansion_add_of_good (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) :
+    qExpansion h (G₁ + G₂) = qExpansion h G₁ + qExpansion h G₂ :=
+  qExpansion_add (h₁.analyticAt hh) (h₂.analyticAt hh)
+
+theorem qExpansion_pow_of_good (hh : 0 < h) (hG : Good h G) :
+    ∀ n : ℕ, qExpansion h (G ^ n) = qExpansion h G ^ n
+  | 0 => by rw [pow_zero, pow_zero, qExpansion_one]
+  | n + 1 => by rw [pow_succ, pow_succ, qExpansion_mul_of_good hh (hG.pow n) hG,
+      qExpansion_pow_of_good hh hG n]
+
+theorem qExpansion_const (hh : 0 < h) (c : ℂ) :
+    qExpansion h (fun _ : ℍ => c) = PowerSeries.C c := by
+  have h1 : (fun _ : ℍ => c) = c • (1 : ℍ → ℂ) := by funext τ; simp
+  rw [h1, qExpansion_smul ((Good.one h).analyticAt hh), qExpansion_one, Algebra.smul_def, mul_one]
+  simp
+
+theorem Good.eq_zero_of_qExpansion_eq_zero (hG : Good h G) (hh : 0 < h) (h0 : qExpansion h G = 0) :
+    G = 0 :=
+  (qExpansion_eq_zero_iff hh hG.periodic hG.mdiff hG.bdd).mp h0
+
+def Q (h : ℝ) (G : ℍ → ℂ) : LaurentSeries ℂ := HahnSeries.ofPowerSeries ℤ ℂ (qExpansion h G)
+
+theorem Q_mul (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) : Q h (G₁ * G₂) = Q h G₁ * Q h G₂ := by
+  simp only [Q, qExpansion_mul_of_good hh h₁ h₂, map_mul]
+
+theorem Q_add (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) : Q h (G₁ + G₂) = Q h G₁ + Q h G₂ := by
+  simp only [Q, qExpansion_add_of_good hh h₁ h₂, map_add]
+
+theorem Q_pow (hh : 0 < h) (hG : Good h G) (n : ℕ) : Q h (G ^ n) = Q h G ^ n := by
+  simp only [Q, qExpansion_pow_of_good hh hG n, map_pow]
+
+theorem Q_one (h : ℝ) : Q h (1 : ℍ → ℂ) = 1 := by
+  simp only [Q, qExpansion_one, map_one]
+
+theorem Q_const (hh : 0 < h) (c : ℂ) : Q h (fun _ : ℍ => c) = HahnSeries.C c := by
+  simp only [Q, qExpansion_const hh c, HahnSeries.ofPowerSeries_C]
+
+theorem Q_eq_zero_iff (hh : 0 < h) (hG : Good h G) : Q h G = 0 ↔ G = 0 := by
+  constructor
+  · intro h0
+    apply hG.eq_zero_of_qExpansion_eq_zero hh
+    have : Function.Injective (HahnSeries.ofPowerSeries ℤ ℂ) := HahnSeries.ofPowerSeries_injective
+    exact this (by rw [map_zero]; exact h0)
+  · rintro rfl
+    simp only [Q, qExpansion_zero, map_zero]
+
+end Toolkit
+
+section LevelOne
+
+local notation "Δ" => ModularForm.discriminant
+
+theorem natCast_mem_strictPeriods (N : ℕ) : (N : ℝ) ∈ (𝒮ℒ).strictPeriods := by
+  simp only [Subgroup.strictPeriods_SL2Z]
+  exact ⟨N, by simp⟩
+
+theorem good_discriminant (N : ℕ) : Good N Δ where
+  periodic := by
+    have := SlashInvariantFormClass.periodic_comp_ofComplex CuspForm.discriminant
+      (natCast_mem_strictPeriods N)
+    simpa using this
+  mdiff := CuspForm.discriminant.holo'
+  bdd := ModularForm.discriminant_isZeroAtImInfty.isBoundedAtImInfty
+
+theorem good_E₄ (N : ℕ) : Good N (ModularForm.E₄ : ℍ → ℂ) where
+  periodic := SlashInvariantFormClass.periodic_comp_ofComplex ModularForm.E₄
+      (natCast_mem_strictPeriods N)
+  mdiff := ModularForm.E₄.holo'
+  bdd := ModularFormClass.bdd_at_infty ModularForm.E₄
+
+theorem discriminant_ne_zero' : (Δ : ℍ → ℂ) ≠ 0 := by
+  intro h0
+  have := congrFun h0 UpperHalfPlane.I
+  exact ModularForm.discriminant_ne_zero _ this
+
+theorem discriminant_pow_ne_zero (m : ℕ) : ((Δ : ℍ → ℂ) ^ m) ≠ 0 := by
+  intro h0
+  have := congrFun h0 UpperHalfPlane.I
+  simp only [Pi.pow_apply, Pi.zero_apply, pow_eq_zero_iff', ne_eq] at this
+  exact ModularForm.discriminant_ne_zero _ this.1
+
+theorem mul_discriminant_pow_eq_zero_iff (F : ℍ → ℂ) (m : ℕ) :
+    F * (Δ : ℍ → ℂ) ^ m = 0 ↔ F = 0 := by
+  constructor
+  · intro h0
+    funext τ
+    have := congrFun h0 τ
+    simp only [Pi.mul_apply, Pi.pow_apply, Pi.zero_apply, mul_eq_zero, pow_eq_zero_iff',
+      ne_eq] at this
+    rcases this with h1 | ⟨h1, _⟩
+    · exact h1
+    · exact absurd h1 (ModularForm.discriminant_ne_zero τ)
+  · rintro rfl
+    exact zero_mul _
+
+theorem Q_discriminant_ne_zero (N : ℕ) [NeZero N] : Q N (Δ : ℍ → ℂ) ≠ 0 := by
+  have hN : (0 : ℝ) < N := Nat.cast_pos.mpr (NeZero.pos N)
+  rw [ne_eq, Q_eq_zero_iff hN (good_discriminant N)]
+  exact discriminant_ne_zero'
+
+end LevelOne
+
+section Ring
+
+local notation "Δ" => ModularForm.discriminant
+
+variable (N : ℕ) [NeZero N]
+
+theorem mdifferentiable_of_mem {F : ℍ → ℂ} (hF : F ∈ ring N) : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F := by
+  have h := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact h.2.2.2.2.1 F hF
+
+theorem eq_zero_or_eq_zero_of_mul_eq_zero {a b : ℍ → ℂ} (ha : a ∈ ring N) (hb : b ∈ ring N)
+    (hab : a * b = 0) : a = 0 ∨ b = 0 := by
+  have h := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact h.2.2.2.2.2 a b ha hb hab
+
+abbrev redMat (γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) (ZMod N) :=
+  (γ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N)
+
+theorem fricke_smul_of_mem (v : Fin 2 → ZMod N) {γ : SL(2, ℤ)}
+    (hγ : γ ∈ CongruenceSubgroup.Gamma N) (τ : ℍ) : fricke N v (γ • τ) = fricke N v τ :=
+  (WLight.frickeFunction_modularity_package N PeriodPair.ofTau (fun _ => ⟨rfl, rfl⟩)).2.2.2.2.2.2.1
+    v γ hγ τ
+
+omit [NeZero N] in
+theorem jAnalytic_smul (γ : SL(2, ℤ)) (τ : ℍ) : jAnalytic (γ • τ) = jAnalytic τ := by
+  have hmem : (γ : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ, rfl⟩
+  have h4 : (ModularForm.E₄ : ℍ → ℂ) ((γ : GL (Fin 2) ℝ) • τ) =
+      denom (γ : GL (Fin 2) ℝ) τ ^ (4 : ℤ) * ModularForm.E₄ τ :=
+    SlashInvariantForm.slash_action_eqn'' _ hmem τ
+  have h12 : ModularForm.discriminant ((γ : GL (Fin 2) ℝ) • τ) =
+      denom (γ : GL (Fin 2) ℝ) τ ^ (12 : ℤ) * ModularForm.discriminant τ := by
+    have := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hmem τ
+    simpa using this
+  have hd : denom (γ : GL (Fin 2) ℝ) τ ≠ 0 := denom_ne_zero _ _
+  have hΔ : ModularForm.discriminant τ ≠ 0 := ModularForm.discriminant_ne_zero τ
+  rw [jAnalytic, jAnalytic, ModularGroup.sl_moeb, h4, h12]
+  field_simp
+
+def precomp (g : SL(2, ℤ)) : (ℍ → ℂ) →ₐ[ℂ] (ℍ → ℂ) :=
+  AlgHom.pi (fun τ => Pi.evalAlgHom ℂ (fun _ : ℍ => ℂ) (g • τ))
+
+omit [NeZero N] in
+@[scoped simp]
+theorem precomp_apply (g : SL(2, ℤ)) (F : ℍ → ℂ) (τ : ℍ) : precomp g F τ = F (g • τ) := rfl
+
+theorem smul_eq_self_of_mem {F : ℍ → ℂ} (hF : F ∈ ring N) {γ : SL(2, ℤ)}
+    (hγ : γ ∈ CongruenceSubgroup.Gamma N) (τ : ℍ) : F (γ • τ) = F τ := by
+  suffices h : ring N ≤ AlgHom.equalizer (precomp γ) (AlgHom.id ℂ (ℍ → ℂ)) by
+    have := h hF
+    rw [AlgHom.mem_equalizer] at this
+    exact congrFun this τ
+  rw [ring, Algebra.adjoin_le_iff]
+  intro G hG
+  rw [SetLike.mem_coe, AlgHom.mem_equalizer]
+  funext τ'
+  rcases hG with rfl | ⟨v, hv, rfl⟩
+  · exact jAnalytic_smul γ τ'
+  · exact fricke_smul_of_mem N v hγ τ'
+
+omit [NeZero N] in
+theorem T_pow_mem_Gamma : ModularGroup.T ^ N ∈ CongruenceSubgroup.Gamma N := by
+  rw [CongruenceSubgroup.Gamma_mem, ← zpow_natCast, ModularGroup.coe_T_zpow]
+  simp
+
+theorem periodic_of_mem {F : ℍ → ℂ} (hF : F ∈ ring N) : Periodic (F ∘ ofComplex) N := by
+  intro w
+  by_cases hw : 0 < w.im
+  · have hw' : 0 < (w + N).im := by simpa using hw
+    simp only [Function.comp_apply, ofComplex_apply_of_im_pos hw, ofComplex_apply_of_im_pos hw']
+    have hT : ModularGroup.T ^ N • (⟨w, hw⟩ : ℍ) = ⟨w + N, hw'⟩ := by
+      rw [← zpow_natCast, modular_T_zpow_smul]
+      ext1
+      simp [add_comm]
+    rw [← hT, smul_eq_self_of_mem N hF (T_pow_mem_Gamma N)]
+  · push Not at hw
+    have hw' : (w + N).im ≤ 0 := by simpa using hw
+    simp only [Function.comp_apply, ofComplex_apply_of_im_nonpos hw,
+      ofComplex_apply_of_im_nonpos hw']
+
+theorem exists_isBoundedAtImInfty_mul_pow {F : ℍ → ℂ} (hF : F ∈ ring N) :
+    ∃ m : ℕ, IsBoundedAtImInfty (F * (Δ : ℍ → ℂ) ^ m) := by
+  have hpkg := WLight.frickeFunction_orbit_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  have hΔb : ∀ k : ℕ, IsBoundedAtImInfty ((Δ : ℍ → ℂ) ^ k) := fun k =>
+    ((good_discriminant N).pow k).bdd
+  induction hF using Algebra.adjoin_induction with
+  | mem G hG =>
+    rcases hG with rfl | ⟨v, hv, rfl⟩
+    · exact hpkg.1.2
+    · exact (hpkg.2.1 v hv).2
+  | algebraMap c =>
+    refine ⟨0, ?_⟩
+    rw [pow_zero, mul_one]
+    exact Filter.const_boundedAtFilter _ _
+  | add F G _ _ ihF ihG =>
+    obtain ⟨m, hm⟩ := ihF
+    obtain ⟨n, hn⟩ := ihG
+    refine ⟨m + n, ?_⟩
+    have : (F + G) * (Δ : ℍ → ℂ) ^ (m + n) =
+        F * (Δ : ℍ → ℂ) ^ m * (Δ : ℍ → ℂ) ^ n + G * (Δ : ℍ → ℂ) ^ n * (Δ : ℍ → ℂ) ^ m := by ring
+    rw [this]
+    exact (hm.mul (hΔb n)).add (hn.mul (hΔb m))
+  | mul F G _ _ ihF ihG =>
+    obtain ⟨m, hm⟩ := ihF
+    obtain ⟨n, hn⟩ := ihG
+    refine ⟨m + n, ?_⟩
+    have : (F * G) * (Δ : ℍ → ℂ) ^ (m + n) = (F * (Δ : ℍ → ℂ) ^ m) * (G * (Δ : ℍ → ℂ) ^ n) := by
+      ring
+    rw [this]
+    exact hm.mul hn
+
+end Ring
+
+section Expansion
+
+local notation "Δ" => ModularForm.discriminant
+
+variable (N : ℕ) [NeZero N]
+
+theorem castN_pos : (0 : ℝ) < N := Nat.cast_pos.mpr (NeZero.pos N)
+
+def PB (F : ℍ → ℂ) (m : ℕ) : Prop := IsBoundedAtImInfty (F * (Δ : ℍ → ℂ) ^ m)
+
+theorem PB.add_right {F : ℍ → ℂ} {m : ℕ} (hm : PB F m) (k : ℕ) : PB F (m + k) := by
+  unfold PB at hm ⊢
+  rw [pow_add, ← mul_assoc]
+  exact hm.mul ((good_discriminant 1).pow k).bdd
+
+theorem good_of_PB {F : ℍ → ℂ} (hF : F ∈ ring N) {m : ℕ} (hm : PB F m) :
+    Good N (F * (Δ : ℍ → ℂ) ^ m) where
+  periodic := by
+    have : (F * (Δ : ℍ → ℂ) ^ m) ∘ ofComplex = (F ∘ ofComplex) * (((Δ : ℍ → ℂ) ^ m) ∘ ofComplex) :=
+      rfl
+    rw [this]
+    exact (periodic_of_mem N hF).mul ((good_discriminant N).pow m).periodic
+  mdiff := (mdifferentiable_of_mem N hF).mul ((good_discriminant N).pow m).mdiff
+  bdd := hm
+
+open Classical in
+def poleOrder (F : ring N) : ℕ := Nat.find (exists_isBoundedAtImInfty_mul_pow N F.2)
+
+theorem poleOrder_spec (F : ring N) : PB (F : ℍ → ℂ) (poleOrder N F) := by
+  classical
+  exact Nat.find_spec (exists_isBoundedAtImInfty_mul_pow N F.2)
+
+def qexpFun (F : ring N) : LaurentSeries ℂ :=
+  Q N ((F : ℍ → ℂ) * (Δ : ℍ → ℂ) ^ poleOrder N F) / Q N (Δ : ℍ → ℂ) ^ poleOrder N F
+
+theorem qexpFun_mul_pow (F : ring N) {m : ℕ} (hm : PB (F : ℍ → ℂ) m) :
+    qexpFun N F * Q N (Δ : ℍ → ℂ) ^ m = Q N ((F : ℍ → ℂ) * (Δ : ℍ → ℂ) ^ m) := by
+  have hN := castN_pos N
+  set m₀ := poleOrder N F with hm₀
+  have hm₀' : PB (F : ℍ → ℂ) m₀ := poleOrder_spec N F
+  have hΔ0 : Q N (Δ : ℍ → ℂ) ≠ 0 := Q_discriminant_ne_zero N
+  have hgood₀ := good_of_PB N F.2 hm₀'
+  have hgoodm := good_of_PB N F.2 hm
+  have hkey : Q N ((F : ℍ → ℂ) * (Δ : ℍ → ℂ) ^ m₀) * Q N (Δ : ℍ → ℂ) ^ m =
+      Q N ((F : ℍ → ℂ) * (Δ : ℍ → ℂ) ^ m) * Q N (Δ : ℍ → ℂ) ^ m₀ := by
+    rw [← Q_pow hN (good_discriminant N), ← Q_pow hN (good_discriminant N),
+      ← Q_mul hN hgood₀ ((good_discriminant N).pow m), ← Q_mul hN hgoodm ((good_discriminant N).pow
+      m₀)]
+    congr 1
+    ring
+  rw [qexpFun, div_mul_eq_mul_div, div_eq_iff (pow_ne_zero _ hΔ0), hkey]
+
+def qexpA : ring N →+* LaurentSeries ℂ where
+  toFun := qexpFun N
+  map_one' := by
+    have h := qexpFun_mul_pow N 1 (m := 0) (by
+      change IsBoundedAtImInfty (((1 : ring N) : ℍ → ℂ) * (Δ : ℍ → ℂ) ^ 0)
+      rw [pow_zero, mul_one, OneMemClass.coe_one]
+      exact (Good.one (N : ℝ)).bdd)
+    rw [pow_zero, mul_one, pow_zero, mul_one, OneMemClass.coe_one] at h
+    rw [h, Q_one]
+  map_mul' F G := by
+    have hΔ0 : Q N (Δ : ℍ → ℂ) ≠ 0 := Q_discriminant_ne_zero N
+    have hN := castN_pos N
+    obtain hF := poleOrder_spec N F
+    obtain hG := poleOrder_spec N G
+    set mF := poleOrder N F
+    set mG := poleOrder N G
+    have hFG : PB (((F * G : ring N)) : ℍ → ℂ) (mF + mG) := by
+      change IsBoundedAtImInfty (((F : ℍ → ℂ) * (G : ℍ → ℂ)) * (Δ : ℍ → ℂ) ^ (mF + mG))
+      have : ((F : ℍ → ℂ) * (G : ℍ → ℂ)) * (Δ : ℍ → ℂ) ^ (mF + mG) =
+          ((F : ℍ → ℂ) * (Δ : ℍ → ℂ) ^ mF) * ((G : ℍ → ℂ) * (Δ : ℍ → ℂ) ^ mG) := by ring
+      rw [this]; exact hF.mul hG
+    have h := qexpFun_mul_pow N (F * G) hFG
+    have h2 : (((F * G : ring N)) : ℍ → ℂ) * (Δ : ℍ → ℂ) ^ (mF + mG) =
+        ((F : ℍ → ℂ) * (Δ : ℍ → ℂ) ^ mF) * ((G : ℍ → ℂ) * (Δ : ℍ → ℂ) ^ mG) := by
+      change ((F : ℍ → ℂ) * (G : ℍ → ℂ)) * (Δ : ℍ → ℂ) ^ (mF + mG) = _; ring
+    rw [h2, Q_mul hN (good_of_PB N F.2 hF) (good_of_PB N G.2 hG), ← qexpFun_mul_pow N F hF,
+      ← qexpFun_mul_pow N G hG] at h
+    apply mul_right_cancel₀ (pow_ne_zero (mF + mG) hΔ0)
+    rw [h]; ring
+  map_zero' := by
+    have h := qexpFun_mul_pow N 0 (m := 0) (by
+      change IsBoundedAtImInfty (((0 : ring N) : ℍ → ℂ) * (Δ : ℍ → ℂ) ^ 0)
+      rw [ZeroMemClass.coe_zero, zero_mul]
+      exact (Good.const (N : ℝ) 0).bdd)
+    rw [pow_zero, mul_one, ZeroMemClass.coe_zero, zero_mul] at h
+    rw [h]
+    simp only [Q, qExpansion_zero, map_zero]
+  map_add' F G := by
+    have hΔ0 : Q N (Δ : ℍ → ℂ) ≠ 0 := Q_discriminant_ne_zero N
+    have hN := castN_pos N
+    have hF := (poleOrder_spec N F).add_right (poleOrder N G)
+    have hG' := (poleOrder_spec N G).add_right (poleOrder N F)
+    set m := poleOrder N F + poleOrder N G with hm
+    have hG : PB (G : ℍ → ℂ) m := by rw [hm, add_comm]; exact hG'
+    have hFG : PB (((F + G : ring N)) : ℍ → ℂ) m := by
+      change IsBoundedAtImInfty (((F : ℍ → ℂ) + (G : ℍ → ℂ)) * (Δ : ℍ → ℂ) ^ m)
+      rw [add_mul]; exact hF.add hG
+    have h := qexpFun_mul_pow N (F + G) hFG
+    have h2 : (((F + G : ring N)) : ℍ → ℂ) * (Δ : ℍ → ℂ) ^ m =
+        (F : ℍ → ℂ) * (Δ : ℍ → ℂ) ^ m + (G : ℍ → ℂ) * (Δ : ℍ → ℂ) ^ m := by
+      change ((F : ℍ → ℂ) + (G : ℍ → ℂ)) * (Δ : ℍ → ℂ) ^ m = _; ring
+    rw [h2, Q_add hN (good_of_PB N F.2 hF) (good_of_PB N G.2 hG), ← qexpFun_mul_pow N F hF,
+      ← qexpFun_mul_pow N G hG] at h
+    apply mul_right_cancel₀ (pow_ne_zero m hΔ0)
+    rw [h]; ring
+
+theorem qexpA_apply (F : ring N) : qexpA N F = qexpFun N F := rfl
+
+theorem qexpA_mul_pow (F : ℍ → ℂ) (hF : F ∈ ring N) {m : ℕ}
+    (hm : IsBoundedAtImInfty (F * (Δ : ℍ → ℂ) ^ m)) :
+    qexpA N ⟨F, hF⟩ * Q N (Δ : ℍ → ℂ) ^ m = Q N (F * (Δ : ℍ → ℂ) ^ m) :=
+  qexpFun_mul_pow N ⟨F, hF⟩ hm
+
+theorem qexpA_algebraMap (c : ℂ) : qexpA N (algebraMap ℂ (ring N) c) = HahnSeries.C c := by
+  have hcoe : ((algebraMap ℂ (ring N) c : ring N) : ℍ → ℂ) = fun _ => c := by
+    funext τ; simp [Algebra.algebraMap_eq_smul_one]
+  have h := qexpA_mul_pow N (fun _ : ℍ => c) (by rw [← hcoe]; exact (algebraMap ℂ (ring N) c).2)
+    (m := 0) (by rw [pow_zero, mul_one]; exact (Good.const (N : ℝ) c).bdd)
+  rw [pow_zero, mul_one, pow_zero, mul_one, Q_const (castN_pos N)] at h
+  have hc : algebraMap ℂ (ring N) c = ⟨fun _ : ℍ => c, by
+    rw [← hcoe]; exact (algebraMap ℂ (ring N) c).2⟩ :=
+    Subtype.ext hcoe
+  rw [hc]
+  exact h
+
+theorem qexpA_injective : Function.Injective (qexpA N) := by
+  intro F G hFG
+  rw [← sub_eq_zero] at hFG ⊢
+  rw [← map_sub] at hFG
+  set H := F - G
+  have hm := poleOrder_spec N H
+  have h := qexpA_mul_pow N (H : ℍ → ℂ) H.2 hm
+  rw [show (⟨(H : ℍ → ℂ), H.2⟩ : ring N) = H from rfl, hFG, zero_mul, eq_comm,
+    Q_eq_zero_iff (castN_pos N) (good_of_PB N H.2 hm), mul_discriminant_pow_eq_zero_iff] at h
+  exact Subtype.ext h
+
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ring N) K] [IsScalarTower ℂ (ring N) K]
+  [IsFractionRing (ring N) K]
+
+theorem algebraMap_laurentSeries (c : ℂ) : algebraMap ℂ (LaurentSeries ℂ) c = HahnSeries.C c := by
+  have h1 : algebraMap ℂ (PowerSeries ℂ) c = PowerSeries.C c := by simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+
+def qexpK : K →ₐ[ℂ] LaurentSeries ℂ :=
+  { IsFractionRing.lift (qexpA_injective N) with
+    commutes' := fun c => by
+      change IsFractionRing.lift (qexpA_injective N) (algebraMap ℂ K c) = _
+      rw [IsScalarTower.algebraMap_apply ℂ (ring N) K, IsFractionRing.lift_algebraMap,
+        qexpA_algebraMap, algebraMap_laurentSeries] }
+
+theorem qexpK_algebraMap (F : ring N) : qexpK N K (algebraMap (ring N) K F) = qexpA N F := by
+  change IsFractionRing.lift (qexpA_injective N) (algebraMap (ring N) K F) = _
+  exact IsFractionRing.lift_algebraMap (qexpA_injective N) F
+
+end Expansion
+
+section Width
+
+local notation "Δ" => ModularForm.discriminant
+
+variable (N : ℕ) [NeZero N]
+
+theorem qParam_pow_mul (τ : ℍ) (n : ℕ) :
+    Periodic.qParam (N : ℝ) (τ : ℂ) ^ (N * n) = Periodic.qParam 1 (τ : ℂ) ^ n := by
+  have hN : (N : ℂ) ≠ 0 := by exact_mod_cast NeZero.ne N
+  rw [pow_mul]
+  congr 1
+  rw [Periodic.qParam, Periodic.qParam, ← Complex.exp_nat_mul]
+  congr 1
+  push_cast
+  field_simp
+
+
+theorem Q_natCast_eq_qExpand {f : ℍ → ℂ} (hf : Good 1 f) :
+    Q N f = ModularCurve.qExpand ℂ N (Q 1 f) := by
+  have hNpos : (0 : ℝ) < N := Nat.cast_pos.mpr (NeZero.pos N)
+  have hN0 : (N : ℕ) ≠ 0 := NeZero.ne N
+  set a : ℕ → ℂ := fun m => (qExpansion 1 f).coeff m with ha
+  have hsum1 : ∀ τ : ℍ, HasSum (fun m => a m • Periodic.qParam 1 (τ : ℂ) ^ m) (f τ) :=
+    fun τ => hasSum_qExpansion one_pos hf.periodic hf.mdiff hf.bdd τ
+  have hinj : Function.Injective (fun n : ℕ => N * n) := mul_right_injective₀ hN0
+  set c : ℕ → ℂ := Function.extend (fun n : ℕ => N * n) a 0 with hc
+  have hc_apply : ∀ n, c (N * n) = a n := fun n => hinj.extend_apply _ _ n
+  have hc_zero : ∀ m, (¬ ∃ n, N * n = m) → c m = 0 := fun m hm => by
+    rw [hc, Function.extend_apply' _ _ _ hm]; rfl
+  have hsumN : ∀ τ : ℍ, HasSum (fun m => c m • Periodic.qParam (N : ℝ) (τ : ℂ) ^ m) (f τ) := by
+    intro τ
+    have key : (fun m => c m • Periodic.qParam (N : ℝ) (τ : ℂ) ^ m) =
+        Function.extend (fun n : ℕ => N * n) (fun n => a n • Periodic.qParam 1 (τ : ℂ) ^ n) 0 := by
+      funext m
+      by_cases hm : ∃ n, N * n = m
+      · obtain ⟨n, rfl⟩ := hm
+        rw [hinj.extend_apply, hc_apply, qParam_pow_mul]
+      · rw [Function.extend_apply' _ _ _ hm, hc_zero m hm, zero_smul]; rfl
+    rw [key, hasSum_extend_zero hinj]
+    exact hsum1 τ
+  have hgoodN : Good N f :=
+    { periodic := by simpa using hf.periodic.nat_mul N
+      mdiff := hf.mdiff
+      bdd := hf.bdd }
+  have hcoeff : ∀ m, c m = (qExpansion N f).coeff m := by
+    have hsumN' : ∀ τ : ℍ, HasSum (fun m => (qExpansion N f).coeff m • Periodic.qParam (N : ℝ) (τ :
+      ℂ) ^ m) (f τ) :=
+      fun τ => hasSum_qExpansion hNpos hgoodN.periodic hgoodN.mdiff hgoodN.bdd τ
+    have h1 :=
+      (hasFPowerSeriesOnBall_cuspFunction hNpos (hgoodN.analyticAt hNpos) hsumN).hasFPowerSeriesAt
+    have h2 :=
+      (hasFPowerSeriesOnBall_cuspFunction hNpos (hgoodN.analyticAt hNpos) hsumN').hasFPowerSeriesAt
+    have heq := h1.eq_formalMultilinearSeries h2
+    have := (FormalMultilinearSeries.ofScalars_series_eq_iff (E := ℂ) c _).mp heq
+    exact fun m => congrFun this m
+  ext k
+  rw [Q, Q]
+  rcases lt_or_ge k 0 with hk | hk
+  · rw [ModularCurve.ofPowerSeries_coeff_of_neg _ hk]
+    by_cases hdvd : (N : ℤ) ∣ k
+    · obtain ⟨k', rfl⟩ := hdvd
+      rw [ModularCurve.qExpand_coeff_mul]
+      have hk' : k' < 0 := by
+        by_contra h; push Not at h
+        have : (0 : ℤ) ≤ (N : ℤ) * k' := mul_nonneg (by positivity) h
+        omega
+      rw [ModularCurve.ofPowerSeries_coeff_of_neg _ hk']
+    · rw [ModularCurve.qExpand_coeff_of_not_dvd N _ hdvd]
+  · lift k to ℕ using hk
+    rw [HahnSeries.ofPowerSeries_apply_coeff, ← hcoeff]
+    by_cases hdvd : (N : ℤ) ∣ (k : ℤ)
+    · obtain ⟨k', hk'⟩ := hdvd
+      have hk'0 : 0 ≤ k' := by
+        by_contra h; push Not at h
+        have : (N : ℤ) * k' < 0 := mul_neg_of_pos_of_neg (by exact_mod_cast NeZero.pos N) h
+        omega
+      lift k' to ℕ using hk'0
+      have hkk : k = N * k' := by exact_mod_cast hk'
+      rw [hk', ModularCurve.qExpand_coeff_mul, HahnSeries.ofPowerSeries_apply_coeff, hkk, hc_apply]
+    · rw [ModularCurve.qExpand_coeff_of_not_dvd N _ hdvd, hc_zero]
+      rintro ⟨n, hn⟩
+      exact hdvd ⟨n, by rw [← hn]; push_cast; ring⟩
+
+theorem jAnalytic_mul_discriminant :
+    jAnalytic * (Δ : ℍ → ℂ) ^ 1 = (ModularForm.E₄ : ℍ → ℂ) ^ 3 := by
+  funext τ
+  simp only [Pi.mul_apply, Pi.pow_apply, pow_one, jAnalytic]
+  field_simp [ModularForm.discriminant_ne_zero τ]
+
+theorem isBoundedAtImInfty_jAnalytic_mul :
+    IsBoundedAtImInfty (jAnalytic * (Δ : ℍ → ℂ) ^ 1) := by
+  rw [jAnalytic_mul_discriminant]
+  exact ((good_E₄ 1).pow 3).bdd
+
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ring N) K] [IsScalarTower ℂ (ring N) K]
+  [IsFractionRing (ring N) K]
+
+theorem qexpK_jGen :
+    qexpK N K (algebraMap (ring N) K (jGen N)) = ModularCurve.qExpand ℂ N (jqModC ℂ) := by
+  have hN := castN_pos N
+  have hΔ0 : Q N (Δ : ℍ → ℂ) ≠ 0 := Q_discriminant_ne_zero N
+  rw [qexpK_algebraMap]
+  have h := qexpA_mul_pow N jAnalytic (jAnalytic_mem N) isBoundedAtImInfty_jAnalytic_mul
+  rw [pow_one, jAnalytic_mul_discriminant, Q_pow hN (good_E₄ N) 3] at h
+  change qexpA N (jGen N) * Q N (Δ : ℍ → ℂ) = Q N (ModularForm.E₄ : ℍ → ℂ) ^ 3 at h
+  rw [← eq_div_iff hΔ0] at h
+  have hE : Good 1 (ModularForm.E₄ : ℍ → ℂ) := by simpa using good_E₄ 1
+  have hD : Good 1 (Δ : ℍ → ℂ) := by simpa using good_discriminant 1
+  rw [h, Q_natCast_eq_qExpand N hE, Q_natCast_eq_qExpand N hD, ← map_pow, ← map_div₀,
+    ModularCurve.jqModC_eq_qExpansion_E4_cube_div_discriminant]
+  rfl
+
+end Width
+
+end ModularCurve.LevelN.QExpEmbedding
+end
+
+open ModularCurve.LevelN.QExpEmbedding in
+theorem solution (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring N) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring N) K]
+    [IsFractionRing (ModularCurve.LevelN.ring N) K] :
+    ∃ E : K →ₐ[ℂ] LaurentSeries ℂ,
+      E (algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)) =
+          ModularCurve.qExpand ℂ N (ModularCurve.jqModC ℂ) ∧
+      ∀ (F : UpperHalfPlane → ℂ) (hF : F ∈ ModularCurve.LevelN.ring N) (m : ℕ),
+        UpperHalfPlane.IsBoundedAtImInfty (F * ModularForm.discriminant ^ m) →
+        E (algebraMap (ModularCurve.LevelN.ring N) K ⟨F, hF⟩) *
+            HahnSeries.ofPowerSeries ℤ ℂ
+              (UpperHalfPlane.qExpansion N (ModularForm.discriminant : UpperHalfPlane → ℂ)) ^ m =
+          HahnSeries.ofPowerSeries ℤ ℂ
+            (UpperHalfPlane.qExpansion N (F * ModularForm.discriminant ^ m)) := by
+  refine ⟨qexpK N K, qexpK_jGen N K, fun F hF m hm => ?_⟩
+  rw [qexpK_algebraMap]
+  exact qexpA_mul_pow N F hF hm
+
+end S_ModularCurve_LevelN_exists_algHom_laurentSeries_qExpansion
+end P2MW
+export P2MW.S_ModularCurve_LevelN_exists_algHom_laurentSeries_qExpansion (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.LevelN.exists_algHom_laurentSeries_qExpansion (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring N) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring N) K]
+    [IsFractionRing (ModularCurve.LevelN.ring N) K] :
+    ∃ E : K →ₐ[ℂ] LaurentSeries ℂ,
+      E (algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)) =
+          ModularCurve.qExpand ℂ N (ModularCurve.jqModC ℂ) ∧
+      ∀ (F : UpperHalfPlane → ℂ) (hF : F ∈ ModularCurve.LevelN.ring N) (m : ℕ),
+        UpperHalfPlane.IsBoundedAtImInfty (F * ModularForm.discriminant ^ m) →
+        E (algebraMap (ModularCurve.LevelN.ring N) K ⟨F, hF⟩) *
+            HahnSeries.ofPowerSeries ℤ ℂ
+              (UpperHalfPlane.qExpansion N (ModularForm.discriminant : UpperHalfPlane → ℂ)) ^ m =
+          HahnSeries.ofPowerSeries ℤ ℂ
+            (UpperHalfPlane.qExpansion N (F * ModularForm.discriminant ^ m)) :=
+  solution N K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_linearMap_regularDifferentials_cuspForm_injective.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_linearMap_regularDifferentials_cuspForm_injective.lean
new file mode 100644
index 0000000000..c6d5aac9af
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_linearMap_regularDifferentials_cuspForm_injective.lean
@@ -0,0 +1,186 @@
+/-
+Based on Prove2Me node ModularCurve.LevelN.exists_linearMap_regularDifferentials_cuspForm_injective
+(387b4b02-e95c-587a-95a2-f833ec353568) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e181f19b-2f78-503f-87d7-3bad4100556d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RegularDifferentials
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LevelNFunctionField
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_linearMap_regularDifferentials_mdifferentiable
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_isZeroAtImInfty_slash_of_mem_regularDifferentials
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_slash_eq_self_of_mem_Gamma_of_mul_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Regular differentials inject into weight-2 cusp forms for Γ(N)
+
+Theorem statement: `ModularCurve.LevelN.exists_linearMap_regularDifferentials_cuspForm_injective`
+(`387b4b02-e95c-587a-95a2-f833ec353568`), by Claude, 2026-09-05.
+
+Proof: submission `e181f19b-2f78-503f-87d7-3bad4100556d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number with $N \neq 0$, and let $K$ be a field that is simultaneously a
+$\mathbb{C}$-algebra and an algebra over [`ModularCurve.LevelN.ring
+N`](def/ModularCurve_LevelNFunctionField.html#L28) — the $\mathbb{C}$-subalgebra of the functions
+$\mathbb{H} \to \mathbb{C}$ generated by `jAnalytic` together with all the functions `fricke N v`
+for $v : \mathrm{Fin}\,2 \to \mathbb{Z}/N$ with $v \neq 0$ — such that the two algebra structures
+are compatible (the scalar tower $\mathbb{C} \to$ `ring N` $\to K$) and $K$ is a fraction field of
+`ring N`. The assertion is that there exists an injective $\mathbb{C}$-linear map from
+[`AlgebraicCurve.regularDifferentials ℂ K`](def/AlgebraicCurve_RegularDifferentials.html#L26) to
+`CuspForm (CongruenceSubgroup.Gamma N) 2`. Here `regularDifferentials ℂ K` is the
+$\mathbb{C}$-submodule of the Kähler differentials $\Omega_{K/\mathbb{C}}$ consisting of those
+$\omega$ such that for every place $v$ of $K$ over $\mathbb{C}$ — that is, every valuation subring
+of $K$ which contains the image of $\mathbb{C}$, is not all of $K$, and is a principal ideal ring —
+one has $\omega = f \cdot \mathrm{d}t_v$ for some $f$ in that valuation subring, where $t_v$ is the
+chosen uniformiser of $v$; and `CuspForm (CongruenceSubgroup.Gamma N) 2` is the space of holomorphic
+weight-$2$ cusp forms for the principal congruence subgroup $\Gamma(N)$.
+
+This is the injection of the differentials of the first kind on the modular curve of level $N$,
+presented as the function field $K$ of the algebra generated by $j$ and the Fricke functions, into
+the weight-$2$ cusp forms for $\Gamma(N)$; classically the map is $\omega = h\,\mathrm{d}j \mapsto h
+\cdot j'/(2\pi i)$. It is used in the bound relating $12g - 12$ plus a cusp contribution to the
+dimension of $S_2(\Gamma(N))$, via
+[`ModularCurve.twelve_mul_add_mul_index_le_finrank_cuspForm_Gamma`]
+(thm.html#ModularCurve.twelve_mul_add_mul_index_le_finrank_cuspForm_Gamma).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_LevelN_exists_linearMap_regularDifferentials_cuspForm_injective.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_LevelN_exists_linearMap_regularDifferentials_cuspForm_injective
+
+noncomputable section
+
+open UpperHalfPlane
+open scoped Manifold MatrixGroups ModularForm
+
+namespace ModularCurve
+p2m_export "ModularCurve" "LevelN.ring \
+  LevelN.exists_linearMap_regularDifferentials_mdifferentiable \
+  LevelN.isZeroAtImInfty_slash_of_mem_regularDifferentials \
+  LevelN.slash_eq_self_of_mem_Gamma_of_mul_eq"
+namespace LevelN
+p2m_export "ModularCurve.LevelN" "ring exists_linearMap_regularDifferentials_mdifferentiable \
+  isZeroAtImInfty_slash_of_mem_regularDifferentials slash_eq_self_of_mem_Gamma_of_mul_eq"
+namespace CuspFormAssembly
+p2m_open "ModularCurve.LevelN ModularCurve"
+
+variable (N : ℕ) [NeZero N]
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ring N) K] [IsScalarTower ℂ (ring N) K]
+  [IsFractionRing (ring N) K]
+
+def Ψ : AlgebraicCurve.regularDifferentials ℂ K →ₗ[ℂ] (ℍ → ℂ) :=
+  (exists_linearMap_regularDifferentials_mdifferentiable N K).2.choose
+
+theorem Ψ_spec :
+    Function.Injective (Ψ N K) ∧
+      (∀ ω, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (Ψ N K ω)) ∧
+      ∀ (ω : AlgebraicCurve.regularDifferentials ℂ K) (a b c e : ℍ → ℂ)
+        (ha : a ∈ ring N) (hb : b ∈ ring N) (hc : c ∈ ring N) (he : e ∈ ring N),
+        b ≠ 0 → e ≠ 0 →
+        (ω : KaehlerDifferential ℂ K) =
+          (algebraMap (ring N) K ⟨a, ha⟩ / algebraMap (ring N) K ⟨b, hb⟩) •
+            KaehlerDifferential.D ℂ K (algebraMap (ring N) K ⟨c, hc⟩ / algebraMap (ring N) K ⟨e,
+              he⟩) →
+        ∀ τ : ℍ, Ψ N K ω τ * b τ * e τ ^ 2 =
+          a τ * (e τ * deriv (c ∘ ofComplex) τ - c τ * deriv (e ∘ ofComplex) τ) :=
+  (exists_linearMap_regularDifferentials_mdifferentiable N K).2.choose_spec
+
+theorem exists_rep (ω : KaehlerDifferential ℂ K) (hω : ω ∈ AlgebraicCurve.regularDifferentials ℂ K)
+    :
+    ∃ (a b c e : ℍ → ℂ) (ha : a ∈ ring N) (hb : b ∈ ring N) (hc : c ∈ ring N) (he : e ∈ ring N),
+      b ≠ 0 ∧ e ≠ 0 ∧
+      ω = (algebraMap (ring N) K ⟨a, ha⟩ / algebraMap (ring N) K ⟨b, hb⟩) •
+        KaehlerDifferential.D ℂ K (algebraMap (ring N) K ⟨c, hc⟩ / algebraMap (ring N) K ⟨e, he⟩) :=
+  (exists_linearMap_regularDifferentials_mdifferentiable N K).1 ω hω
+
+def toCuspForm (ω : AlgebraicCurve.regularDifferentials ℂ K) :
+    CuspForm (CongruenceSubgroup.Gamma N) 2 where
+  toFun := Ψ N K ω
+  slash_action_eq' := by
+    intro A hA
+    obtain ⟨γ, hγ, rfl⟩ := hA
+    obtain ⟨a, b, c, e, ha, hb, hc, he, hb0, he0, hω⟩ :=
+      exists_rep N K (ω : KaehlerDifferential ℂ K) ω.2
+    exact slash_eq_self_of_mem_Gamma_of_mul_eq N (Ψ N K ω) ((Ψ_spec N K).2.1 ω) a b c e ha hb hc he
+      hb0 he0 ((Ψ_spec N K).2.2 ω a b c e ha hb hc he hb0 he0 hω) γ hγ
+  holo' := (Ψ_spec N K).2.1 ω
+  zero_at_cusps' := by
+    intro cusp hc
+    rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z] at hc
+    rw [OnePoint.isZeroAt_iff_forall_SL2Z hc]
+    intro δ _
+    exact isZeroAtImInfty_slash_of_mem_regularDifferentials N K (ω : KaehlerDifferential ℂ K) ω.2
+      (Ψ N K ω) (fun a b c e ha hb hc he hb0 he0 hω => (Ψ_spec N K).2.2 ω a b c e ha hb hc he hb0
+        he0 hω) δ
+
+@[scoped simp]
+theorem coe_toCuspForm (ω : AlgebraicCurve.regularDifferentials ℂ K) :
+    ((toCuspForm N K ω : CuspForm (CongruenceSubgroup.Gamma N) 2) : ℍ → ℂ) = Ψ N K ω := rfl
+
+def Φ : AlgebraicCurve.regularDifferentials ℂ K →ₗ[ℂ] CuspForm (CongruenceSubgroup.Gamma N) 2 where
+  toFun := toCuspForm N K
+  map_add' ω₁ ω₂ := by
+    apply DFunLike.ext'
+    simp [map_add]
+  map_smul' c ω := by
+    apply DFunLike.ext'
+    simp [map_smul]
+
+theorem Φ_apply (ω : AlgebraicCurve.regularDifferentials ℂ K) : Φ N K ω = toCuspForm N K ω := rfl
+
+theorem Φ_injective : Function.Injective (Φ N K) := by
+  intro ω₁ ω₂ h
+  apply (Ψ_spec N K).1
+  have := congrArg (fun f : CuspForm (CongruenceSubgroup.Gamma N) 2 => (f : ℍ → ℂ)) h
+  simpa only [Φ_apply, coe_toCuspForm] using this
+
+end ModularCurve.LevelN.CuspFormAssembly
+
+theorem solution (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring N) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring N) K]
+    [IsFractionRing (ModularCurve.LevelN.ring N) K] :
+    ∃ Φ : AlgebraicCurve.regularDifferentials ℂ K →ₗ[ℂ] CuspForm (CongruenceSubgroup.Gamma N) 2,
+      Function.Injective Φ :=
+  ⟨ModularCurve.LevelN.CuspFormAssembly.Φ N K, ModularCurve.LevelN.CuspFormAssembly.Φ_injective N K⟩
+
+end
+end S_ModularCurve_LevelN_exists_linearMap_regularDifferentials_cuspForm_injective
+end P2MW
+export P2MW.S_ModularCurve_LevelN_exists_linearMap_regularDifferentials_cuspForm_injective
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.LevelN.exists_linearMap_regularDifferentials_cuspForm_injective
+    (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring N) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring N) K]
+    [IsFractionRing (ModularCurve.LevelN.ring N) K] :
+    ∃ Φ : AlgebraicCurve.regularDifferentials ℂ K →ₗ[ℂ] CuspForm (CongruenceSubgroup.Gamma N) 2,
+      Function.Injective Φ :=
+  solution N K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_linearMap_regularDifferentials_mdifferentiable.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_linearMap_regularDifferentials_mdifferentiable.lean
new file mode 100644
index 0000000000..23edbc2b1b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_linearMap_regularDifferentials_mdifferentiable.lean
@@ -0,0 +1,971 @@
+/-
+Based on Prove2Me node ModularCurve.LevelN.exists_linearMap_regularDifferentials_mdifferentiable
+(fc27f9fc-c074-52b0-905f-212471904b97) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a7c4745a-d7a4-5a51-80f0-a56599741478
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RegularDifferentials
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LevelNFunctionField
+
+import Mathlib.Algebra.CharP.Pi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_of_orderMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelN_structure_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Regular differentials of the level N function field as F(τ) dτ
+
+Theorem statement: `ModularCurve.LevelN.exists_linearMap_regularDifferentials_mdifferentiable`
+(`fc27f9fc-c074-52b0-905f-212471904b97`), by Claude, 2026-09-05.
+
+Proof: submission `a7c4745a-d7a4-5a51-80f0-a56599741478`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N \ge 1$ and let $A_N =$ [`ModularCurve.LevelN.ring
+N`](def/ModularCurve_LevelNFunctionField.html#L28) be the $\mathbb{C}$-subalgebra of the algebra of
+functions $\mathbb{H} \to \mathbb{C}$ generated by `jAnalytic` together with all Fricke functions
+`fricke N v` for $0 \neq v \in (\mathbb{Z}/N)^2$. Let $K$ be a field which is simultaneously a
+$\mathbb{C}$-algebra and an $A_N$-algebra, compatibly, and which is a fraction field of $A_N$. Write
+$\Omega_{\mathrm{reg}} =$ [`AlgebraicCurve.regularDifferentials ℂ
+K`](def/AlgebraicCurve_RegularDifferentials.html#L26) for the $\mathbb{C}$-submodule of
+$\Omega_{K/\mathbb{C}}$ of those $\omega$ such that for every place $v$ of $K/\mathbb{C}$ — that is,
+every valuation subring of $K$ containing the image of $\mathbb{C}$, distinct from $K$, and a
+principal ideal ring — there is $f$ in that valuation subring with $\omega = f \cdot d(t_v)$, $t_v$
+a uniformiser of $v$. Two assertions are made. First, every $\omega \in \Omega_{\mathrm{reg}}$ has
+the shape $\omega = (a/b)\cdot d(c/e)$ for functions $a,b,c,e : \mathbb{H} \to \mathbb{C}$ lying in
+$A_N$ with $b \neq 0$ and $e \neq 0$, where $a,b,c,e$ are mapped into $K$ by the structure map and
+$d$ is the universal derivation of $K$ over $\mathbb{C}$. Second, there is an injective
+$\mathbb{C}$-linear map $\Psi : \Omega_{\mathrm{reg}} \to (\mathbb{H} \to \mathbb{C})$ such that
+each $\Psi\omega$ is holomorphic on $\mathbb{H}$, and such that for every $\omega$ and every
+presentation $\omega = (a/b)\cdot d(c/e)$ as above (with $a,b,c,e \in A_N$, $b,e \neq 0$) one has,
+for all $\tau \in \mathbb{H}$, $$\Psi\omega(\tau)\, b(\tau)\, e(\tau)^2 = a(\tau)\bigl(e(\tau)\,
+c'(\tau) - c(\tau)\, e'(\tau)\bigr),$$ the derivatives being complex derivatives of $c$ and $e$
+transported to $\mathbb{C}$ along `UpperHalfPlane.ofComplex`.
+
+This is the analytic half of the classical identification of the differentials of the first kind on
+the modular curve of level $N$ with holomorphic differentials $F(\tau)\,d\tau$ on the upper half
+plane: a regular differential of the function field $K$ is determined by, and determines, a
+holomorphic function $F$ on $\mathbb{H}$ through $\omega = F(\tau)\,d\tau$, the correspondence being
+recorded by the displayed cross-multiplied identity so as to avoid dividing by the zeros of $b$ and
+$e$. It is used by
+[`ModularCurve.LevelN.exists_linearMap_regularDifferentials_cuspForm_injective`]
+(thm.html#ModularCurve.LevelN.exists_linearMap_regularDifferentials_cuspForm_injective),
+where the image of $\Psi$ is matched with weight $2$ cusp forms of level $N$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_LevelN_exists_linearMap_regularDifferentials_mdifferentiable.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_LevelN_exists_linearMap_regularDifferentials_mdifferentiable
+
+
+noncomputable section
+
+open UpperHalfPlane Filter Topology Function
+open scoped Manifold MatrixGroups
+
+namespace ModularCurve
+p2m_export "ModularCurve" "LevelN.ring"
+namespace LevelN
+p2m_export "ModularCurve.LevelN" "wp fricke jAnalytic ring jGen"
+namespace HolDiff
+p2m_open "ModularCurve.LevelN ModularCurve"
+
+variable (N : ℕ) [NeZero N]
+
+theorem pkg :
+    let A_N : Subalgebra ℂ (ℍ → ℂ) := Algebra.adjoin ℂ
+      (insert jAnalytic {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke N v})
+    (∀ P : Polynomial ℂ, (∀ τ : ℍ, P.eval (jAnalytic τ) = 0) → P = 0)
+    ∧ (∀ F ∈ A_N, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F)
+    ∧ (∀ a b : ℍ → ℂ, a ∈ A_N → b ∈ A_N → a * b = 0 → a = 0 ∨ b = 0) := by
+  have h := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact ⟨h.2.2.2.1, h.2.2.2.2.1, h.2.2.2.2.2⟩
+
+theorem mdifferentiable_of_mem {F : ℍ → ℂ} (hF : F ∈ ring N) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F :=
+  (pkg N).2.1 F hF
+
+theorem eq_zero_or_eq_zero_of_mul_eq_zero {a b : ℍ → ℂ} (ha : a ∈ ring N) (hb : b ∈ ring N)
+    (hab : a * b = 0) : a = 0 ∨ b = 0 :=
+  (pkg N).2.2 a b ha hb hab
+
+theorem mul_ne_zero_of_mem {a b : ℍ → ℂ} (ha : a ∈ ring N) (hb : b ∈ ring N) (ha0 : a ≠ 0)
+    (hb0 : b ≠ 0) : a * b ≠ 0 := fun h =>
+  (eq_zero_or_eq_zero_of_mul_eq_zero N ha hb h).elim ha0 hb0
+
+include N in
+theorem jAnalytic_transcendental (P : Polynomial ℂ) (hP : ∀ τ : ℍ, P.eval (jAnalytic τ) = 0) :
+    P = 0 :=
+  (pkg N).1 P hP
+
+scoped instance instIsDomain : IsDomain (ring N) := by
+  have hnz : NoZeroDivisors (ring N) := ⟨fun {a b} h => by
+    rcases eq_zero_or_eq_zero_of_mul_eq_zero N a.2 b.2 (by simpa using congrArg Subtype.val h)
+      with h | h
+    · exact Or.inl (Subtype.ext h)
+    · exact Or.inr (Subtype.ext h)⟩
+  have hnt : Nontrivial (ring N) := ⟨⟨0, 1, fun h => by
+    have := congrFun (congrArg Subtype.val h) UpperHalfPlane.I
+    simp at this⟩⟩
+  exact NoZeroDivisors.to_isDomain _
+
+def 𝕌 : Set ℂ := {z : ℂ | 0 < z.im}
+
+theorem isOpen_𝕌 : IsOpen 𝕌 := isOpen_upperHalfPlaneSet
+
+theorem isPreconnected_𝕌 : IsPreconnected 𝕌 := (convex_halfSpace_im_gt 0).isPreconnected
+
+theorem I_mem_𝕌 : ((UpperHalfPlane.I : ℍ) : ℂ) ∈ 𝕌 := UpperHalfPlane.I.im_pos
+
+theorem coe_mem_𝕌 (τ : ℍ) : (τ : ℂ) ∈ 𝕌 := τ.im_pos
+
+def up (F : ℍ → ℂ) : ℂ → ℂ := F ∘ ofComplex
+
+theorem up_apply_coe (F : ℍ → ℂ) (τ : ℍ) : up F τ = F τ := by
+  simp [up, ofComplex_apply]
+
+theorem up_apply_of_mem (F : ℍ → ℂ) {z : ℂ} (hz : z ∈ 𝕌) : up F z = F ⟨z, hz⟩ := by
+  simp [up, ofComplex_apply_of_im_pos hz]
+
+@[scoped simp] theorem up_mul (F G : ℍ → ℂ) : up (F * G) = up F * up G := rfl
+@[scoped simp] theorem up_add (F G : ℍ → ℂ) : up (F + G) = up F + up G := rfl
+@[scoped simp] theorem up_zero : up (0 : ℍ → ℂ) = 0 := rfl
+@[scoped simp] theorem up_one : up (1 : ℍ → ℂ) = 1 := rfl
+
+theorem up_eq_zero_iff (F : ℍ → ℂ) : (∀ z ∈ 𝕌, up F z = 0) ↔ F = 0 := by
+  constructor
+  · intro h
+    funext τ
+    simpa [up_apply_coe] using h τ (coe_mem_𝕌 τ)
+  · rintro rfl z _
+    rfl
+
+theorem analyticOnNhd_up {F : ℍ → ℂ} (hF : F ∈ ring N) : AnalyticOnNhd ℂ (up F) 𝕌 := by
+  intro z hz
+  have hd : DifferentiableOn ℂ (up F) 𝕌 :=
+    UpperHalfPlane.mdifferentiable_iff.mp (mdifferentiable_of_mem N hF)
+  exact hd.analyticAt (isOpen_𝕌.mem_nhds hz)
+
+theorem analyticAt_up {F : ℍ → ℂ} (hF : F ∈ ring N) {z : ℂ} (hz : z ∈ 𝕌) :
+    AnalyticAt ℂ (up F) z :=
+  analyticOnNhd_up N hF z hz
+
+theorem differentiableAt_up {F : ℍ → ℂ} (hF : F ∈ ring N) {z : ℂ} (hz : z ∈ 𝕌) :
+    DifferentiableAt ℂ (up F) z :=
+  (analyticAt_up N hF hz).differentiableAt
+
+def 𝓕 : Filter ℂ := Filter.codiscreteWithin 𝕌
+
+theorem mem_𝓕_iff {s : Set ℂ} : s ∈ 𝓕 ↔ ∀ x ∈ 𝕌, s ∈ 𝓝[≠] x := by
+  rw [𝓕, mem_codiscreteWithin_iff_forall_mem_nhdsNE]
+  refine forall₂_congr fun x hx => ⟨fun h => ?_, fun h => mem_of_superset h Set.subset_union_left⟩
+  have hU : 𝕌 ∈ 𝓝[≠] x := mem_nhdsWithin_of_mem_nhds (isOpen_𝕌.mem_nhds hx)
+  filter_upwards [h, hU] with y hy hyU
+  exact hy.resolve_right (fun h' => h' hyU)
+
+theorem 𝕌_mem_𝓕 : 𝕌 ∈ 𝓕 := Filter.self_mem_codiscreteWithin 𝕌
+
+theorem eventuallyEq_𝓕_iff {f g : ℂ → ℂ} : f =ᶠ[𝓕] g ↔ ∀ x ∈ 𝕌, f =ᶠ[𝓝[≠] x] g :=
+  mem_𝓕_iff
+
+theorem eventually_nhdsNE_of_𝓕 {p : ℂ → Prop} (h : ∀ᶠ z in 𝓕, p z) {x : ℂ} (hx : x ∈ 𝕌) :
+    ∀ᶠ z in 𝓝[≠] x, p z :=
+  mem_𝓕_iff.mp h x hx
+
+scoped instance 𝓕_neBot : NeBot 𝓕 := by
+  refine ⟨fun h => ?_⟩
+  have hmem : (∅ : Set ℂ) ∈ 𝓕 := by rw [h]; exact Filter.mem_bot
+  have := mem_𝓕_iff.mp hmem _ I_mem_𝕌
+  exact (NormedField.nhdsNE_neBot ((UpperHalfPlane.I : ℍ) : ℂ)).ne (empty_mem_iff_bot.mp this)
+
+theorem eventually_ne_zero {F : ℍ → ℂ} (hF : F ∈ ring N) (hF0 : F ≠ 0) :
+    ∀ᶠ z in 𝓕, up F z ≠ 0 := by
+  rcases (analyticOnNhd_up N hF).eqOn_zero_or_eventually_ne_zero_of_preconnected
+    isPreconnected_𝕌 with h | h
+  · exact absurd ((up_eq_zero_iff F).mp fun z hz => h hz) hF0
+  · exact h
+
+theorem eqOn_of_eventuallyEq_𝓕 {f g : ℂ → ℂ} (hf : AnalyticOnNhd ℂ f 𝕌) (hg : AnalyticOnNhd ℂ g 𝕌)
+    (h : f =ᶠ[𝓕] g) : Set.EqOn f g 𝕌 :=
+  hf.eqOn_of_preconnected_of_frequently_eq hg isPreconnected_𝕌 I_mem_𝕌
+    ((eventuallyEq_𝓕_iff.mp h _ I_mem_𝕌).frequently)
+
+theorem eventually_eventuallyEq_nhds {f g : ℂ → ℂ} {τ : ℂ} (h : f =ᶠ[𝓝[≠] τ] g) :
+    ∀ᶠ z in 𝓝[≠] τ, f =ᶠ[𝓝 z] g := by
+  rw [Filter.EventuallyEq, eventually_nhdsWithin_iff] at h
+  rw [eventually_nhdsWithin_iff]
+  filter_upwards [h.eventually_nhds] with z hz hzτ
+  filter_upwards [hz, eventually_ne_nhds (Set.mem_compl_singleton_iff.mp hzτ)] with w hw hwτ
+  exact hw (Set.mem_compl_singleton_iff.mpr hwτ)
+
+theorem deriv_eventuallyEq_nhdsNE {f g : ℂ → ℂ} {τ : ℂ} (h : f =ᶠ[𝓝[≠] τ] g) :
+    deriv f =ᶠ[𝓝[≠] τ] deriv g :=
+  (eventually_eventuallyEq_nhds h).mono fun _ hz => hz.deriv_eq
+
+theorem eventually_eventuallyEq_nhds_of_𝓕 {f g : ℂ → ℂ} (h : f =ᶠ[𝓕] g) :
+    ∀ᶠ z in 𝓕, f =ᶠ[𝓝 z] g := by
+  have h' := h
+  rw [Filter.EventuallyEq] at h'
+  filter_upwards [h', 𝕌_mem_𝓕] with z hz hzU
+  have hne : f =ᶠ[𝓝[≠] z] g := eventuallyEq_𝓕_iff.mp h z hzU
+  rw [Filter.EventuallyEq, eventually_nhdsWithin_iff] at hne
+  filter_upwards [hne] with w hw
+  by_cases hwz : w = z
+  · rw [hwz]; exact hz
+  · exact hw hwz
+
+theorem deriv_eventuallyEq_𝓕 {f g : ℂ → ℂ} (h : f =ᶠ[𝓕] g) : deriv f =ᶠ[𝓕] deriv g :=
+  (eventually_eventuallyEq_nhds_of_𝓕 h).mono fun _ hz => hz.deriv_eq
+
+section Real
+
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ring N) K] [IsScalarTower ℂ (ring N) K]
+  [IsFractionRing (ring N) K]
+
+omit [NeZero N] [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem algebraMap_injective : Function.Injective (algebraMap (ring N) K) :=
+  IsFractionRing.injective (ring N) K
+
+omit [NeZero N] [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem algebraMap_ne_zero {b : ring N} (hb : (b : ℍ → ℂ) ≠ 0) : algebraMap (ring N) K b ≠ 0 :=
+  fun h => hb (by
+    have : b = 0 := algebraMap_injective N K (by rw [h, map_zero])
+    simp [this])
+
+omit [NeZero N] [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem exists_rep (k : K) :
+    ∃ ab : ring N × ring N, (ab.2 : ℍ → ℂ) ≠ 0 ∧
+      algebraMap (ring N) K ab.1 / algebraMap (ring N) K ab.2 = k := by
+  obtain ⟨a, b, hb, h⟩ := IsFractionRing.div_surjective (A := ring N) k
+  refine ⟨(a, b), ?_, h⟩
+  intro hb0
+  have : b = 0 := Subtype.ext hb0
+  rw [this] at hb
+  exact zero_notMem_nonZeroDivisors hb
+
+def num (k : K) : ring N := (exists_rep N K k).choose.1
+
+def den (k : K) : ring N := (exists_rep N K k).choose.2
+
+omit [NeZero N] [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem den_ne_zero (k : K) : ((den N K k : ring N) : ℍ → ℂ) ≠ 0 :=
+  (exists_rep N K k).choose_spec.1
+
+omit [NeZero N] [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem num_div_den (k : K) :
+    algebraMap (ring N) K (num N K k) / algebraMap (ring N) K (den N K k) = k :=
+  (exists_rep N K k).choose_spec.2
+
+def real (k : K) : ℂ → ℂ := fun z => up (num N K k : ℍ → ℂ) z / up (den N K k : ℍ → ℂ) z
+
+omit [NeZero N] [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem cross_mul_eq {a b a' b' : ring N} (hb : (b : ℍ → ℂ) ≠ 0) (hb' : (b' : ℍ → ℂ) ≠ 0)
+    (h : algebraMap (ring N) K a / algebraMap (ring N) K b =
+      algebraMap (ring N) K a' / algebraMap (ring N) K b') :
+    (a : ℍ → ℂ) * (b' : ℍ → ℂ) = (a' : ℍ → ℂ) * (b : ℍ → ℂ) := by
+  rw [div_eq_div_iff (algebraMap_ne_zero N K hb) (algebraMap_ne_zero N K hb'), ← map_mul,
+    ← map_mul] at h
+  have := algebraMap_injective N K h
+  simpa using congrArg Subtype.val this
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem real_eventuallyEq {k : K} {a b : ring N} (hb : (b : ℍ → ℂ) ≠ 0)
+    (h : algebraMap (ring N) K a / algebraMap (ring N) K b = k) :
+    real N K k =ᶠ[𝓕] fun z => up (a : ℍ → ℂ) z / up (b : ℍ → ℂ) z := by
+  have hx := cross_mul_eq N K (den_ne_zero N K k) hb ((num_div_den N K k).trans h.symm)
+  filter_upwards [eventually_ne_zero N (den N K k).2 (den_ne_zero N K k),
+    eventually_ne_zero N b.2 hb] with z h1 h2
+  have := congrFun (congrArg up hx) z
+  simp only [up_mul, Pi.mul_apply] at this
+  simp only [real]
+  field_simp
+  linear_combination this
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem real_algebraMap (a : ring N) : real N K (algebraMap (ring N) K a) =ᶠ[𝓕] up (a : ℍ → ℂ) := by
+  have h : algebraMap (ring N) K a / algebraMap (ring N) K 1 = algebraMap (ring N) K a := by simp
+  filter_upwards [real_eventuallyEq N K (a := a) (b := 1) (by simp) h] with z hz
+  simpa using hz
+
+theorem real_const (c : ℂ) : real N K (algebraMap ℂ K c) =ᶠ[𝓕] fun _ => c := by
+  rw [IsScalarTower.algebraMap_apply ℂ (ring N) K]
+  filter_upwards [real_algebraMap N K (algebraMap ℂ (ring N) c)] with z hz
+  rw [hz]
+  simp [up, Algebra.algebraMap_eq_smul_one]
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem real_mul (k l : K) : real N K (k * l) =ᶠ[𝓕] fun z => real N K k z * real N K l z := by
+  have hb := mul_ne_zero_of_mem N (den N K k).2 (den N K l).2 (den_ne_zero N K k)
+    (den_ne_zero N K l)
+  have h : algebraMap (ring N) K (num N K k * num N K l) /
+      algebraMap (ring N) K (den N K k * den N K l) = k * l := by
+    rw [map_mul, map_mul, mul_div_mul_comm, num_div_den, num_div_den]
+  filter_upwards [real_eventuallyEq N K (a := num N K k * num N K l)
+    (b := den N K k * den N K l) hb h] with z hz
+  rw [hz]
+  simp only [real, Subalgebra.coe_mul, up_mul, Pi.mul_apply]
+  rw [mul_div_mul_comm]
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem real_add (k l : K) : real N K (k + l) =ᶠ[𝓕] fun z => real N K k z + real N K l z := by
+  have hb := mul_ne_zero_of_mem N (den N K k).2 (den N K l).2 (den_ne_zero N K k)
+    (den_ne_zero N K l)
+  have hk := algebraMap_ne_zero N K (den_ne_zero N K k)
+  have hl := algebraMap_ne_zero N K (den_ne_zero N K l)
+  have h : algebraMap (ring N) K (num N K k * den N K l + num N K l * den N K k) /
+      algebraMap (ring N) K (den N K k * den N K l) = k + l := by
+    conv_rhs => rw [← num_div_den N K k, ← num_div_den N K l]
+    rw [map_add, map_mul, map_mul, map_mul]
+    field_simp
+  filter_upwards [real_eventuallyEq N K (a := num N K k * den N K l + num N K l * den N K k)
+    (b := den N K k * den N K l) hb h, eventually_ne_zero N (den N K k).2 (den_ne_zero N K k),
+    eventually_ne_zero N (den N K l).2 (den_ne_zero N K l)] with z hz h1 h2
+  rw [hz]
+  simp only [real, Subalgebra.coe_mul, Subalgebra.coe_add, up_mul, up_add, Pi.mul_apply,
+    Pi.add_apply]
+  field_simp
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem eventually_differentiableAt_real (k : K) :
+    ∀ᶠ z in 𝓕, DifferentiableAt ℂ (real N K k) z := by
+  filter_upwards [eventually_ne_zero N (den N K k).2 (den_ne_zero N K k), 𝕌_mem_𝓕] with z hz hzU
+  exact (differentiableAt_up N (num N K k).2 hzU).div (differentiableAt_up N (den N K k).2 hzU) hz
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem meromorphicAt_real (k : K) {z : ℂ} (hz : z ∈ 𝕌) : MeromorphicAt (real N K k) z :=
+  ((analyticAt_up N (num N K k).2 hz).meromorphicAt).div
+    ((analyticAt_up N (den N K k).2 hz).meromorphicAt)
+
+end Real
+
+section Germs
+
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ring N) K] [IsScalarTower ℂ (ring N) K]
+  [IsFractionRing (ring N) K]
+
+@[nolint unusedArguments]
+def Gm (_N : ℕ) (_K : Type*) : Type := Filter.Germ 𝓕 ℂ
+
+scoped instance instCommRingGm : CommRing (Gm N K) := inferInstanceAs (CommRing (Filter.Germ 𝓕 ℂ))
+
+def germ (f : ℂ → ℂ) : Gm N K := ((f : Filter.Germ 𝓕 ℂ) : Gm N K)
+
+omit [NeZero N] [Field K] [Algebra ℂ K] [Algebra (↥(ring N)) K] [IsScalarTower ℂ (↥(ring N)) K]
+  [IsFractionRing (↥(ring N)) K] in
+theorem germ_eq_iff {f g : ℂ → ℂ} : germ N K f = germ N K g ↔ f =ᶠ[𝓕] g := Filter.Germ.coe_eq
+
+omit [NeZero N] [Field K] [Algebra ℂ K] [Algebra (↥(ring N)) K] [IsScalarTower ℂ (↥(ring N)) K]
+  [IsFractionRing (↥(ring N)) K] in
+theorem germ_mul (f g : ℂ → ℂ) : germ N K (fun z => f z * g z) = germ N K f * germ N K g := rfl
+
+omit [NeZero N] [Field K] [Algebra ℂ K] [Algebra (↥(ring N)) K] [IsScalarTower ℂ (↥(ring N)) K]
+  [IsFractionRing (↥(ring N)) K] in
+theorem germ_mul' (f g : ℂ → ℂ) : germ N K (f * g) = germ N K f * germ N K g := rfl
+
+omit [NeZero N] [Field K] [Algebra ℂ K] [Algebra (↥(ring N)) K] [IsScalarTower ℂ (↥(ring N)) K]
+  [IsFractionRing (↥(ring N)) K] in
+theorem germ_add (f g : ℂ → ℂ) : germ N K (fun z => f z + g z) = germ N K f + germ N K g := rfl
+
+omit [NeZero N] [Field K] [Algebra ℂ K] [Algebra (↥(ring N)) K] [IsScalarTower ℂ (↥(ring N)) K]
+  [IsFractionRing (↥(ring N)) K] in
+theorem germ_add' (f g : ℂ → ℂ) : germ N K (f + g) = germ N K f + germ N K g := rfl
+
+omit [NeZero N] [Field K] [Algebra ℂ K] [Algebra (↥(ring N)) K] [IsScalarTower ℂ (↥(ring N)) K]
+  [IsFractionRing (↥(ring N)) K] in
+theorem germ_zero : germ N K (fun _ => (0 : ℂ)) = 0 := rfl
+
+omit [NeZero N] [Field K] [Algebra ℂ K] [Algebra (↥(ring N)) K] [IsScalarTower ℂ (↥(ring N)) K]
+  [IsFractionRing (↥(ring N)) K] in
+theorem germ_zero' : germ N K (0 : ℂ → ℂ) = 0 := rfl
+
+omit [NeZero N] [Field K] [Algebra ℂ K] [Algebra (↥(ring N)) K] [IsScalarTower ℂ (↥(ring N)) K]
+  [IsFractionRing (↥(ring N)) K] in
+theorem germ_one : germ N K (fun _ => (1 : ℂ)) = 1 := rfl
+
+omit [NeZero N] [Field K] [Algebra ℂ K] [Algebra (↥(ring N)) K] [IsScalarTower ℂ (↥(ring N)) K]
+  [IsFractionRing (↥(ring N)) K] in
+theorem germ_surjective (m : Gm N K) : ∃ f : ℂ → ℂ, germ N K f = m := by
+  induction m using Filter.Germ.inductionOn with
+  | h f => exact ⟨f, rfl⟩
+
+def φ : K →+* Gm N K where
+  toFun k := germ N K (real N K k)
+  map_one' := by
+    rw [← germ_one, germ_eq_iff]
+    have h := real_const N K 1
+    rwa [map_one] at h
+  map_mul' x y := by
+    rw [← germ_mul, germ_eq_iff]
+    exact real_mul N K x y
+  map_zero' := by
+    rw [← germ_zero, germ_eq_iff]
+    have h := real_const N K 0
+    rwa [map_zero] at h
+  map_add' x y := by
+    rw [← germ_add, germ_eq_iff]
+    exact real_add N K x y
+
+theorem φ_apply (k : K) : φ N K k = germ N K (real N K k) := rfl
+
+scoped instance algebraK : Algebra K (Gm N K) := (φ N K).toAlgebra
+
+scoped instance algebraC : Algebra ℂ (Gm N K) := ((φ N K).comp (algebraMap ℂ K)).toAlgebra
+
+scoped instance isScalarTower : IsScalarTower ℂ K (Gm N K) :=
+  IsScalarTower.of_algebraMap_eq (fun _ => rfl)
+
+theorem smul_def_K (y : K) (m : Gm N K) : y • m = germ N K (real N K y) * m := rfl
+
+theorem smul_def_C (c : ℂ) (m : Gm N K) : c • m = germ N K (real N K (algebraMap ℂ K c)) * m := rfl
+
+theorem smul_germ_C (c : ℂ) (f : ℂ → ℂ) : c • germ N K f = germ N K (fun z => c * f z) := by
+  rw [smul_def_C, ← germ_mul, germ_eq_iff]
+  filter_upwards [real_const N K c] with z hz
+  rw [hz]
+
+def δ : Derivation ℂ K (Gm N K) where
+  toFun y := germ N K (deriv (real N K y))
+  map_add' x y := by
+    rw [← germ_add, germ_eq_iff]
+    filter_upwards [deriv_eventuallyEq_𝓕 (real_add N K x y),
+      eventually_differentiableAt_real N K x, eventually_differentiableAt_real N K y]
+      with z hz hx hy
+    rw [hz, deriv_fun_add hx hy]
+  map_smul' c x := by
+    simp only [RingHom.id_apply]
+    rw [smul_def_C, ← germ_mul, germ_eq_iff]
+    have h1 : real N K (c • x) =ᶠ[𝓕] fun z => c * real N K x z := by
+      rw [Algebra.smul_def]
+      filter_upwards [real_mul N K (algebraMap ℂ K c) x, real_const N K c] with z hz hc
+      rw [hz, hc]
+    filter_upwards [deriv_eventuallyEq_𝓕 h1, real_const N K c] with z h1 h2
+    rw [h1, h2, deriv_const_mul_field]
+  map_one_eq_zero' := by
+    simp only [LinearMap.coe_mk, AddHom.coe_mk]
+    rw [← germ_zero, germ_eq_iff]
+    have h1 := real_const N K 1
+    rw [map_one] at h1
+    filter_upwards [deriv_eventuallyEq_𝓕 h1] with z hz
+    rw [hz, deriv_const]
+  leibniz' x y := by
+    simp only [LinearMap.coe_mk, AddHom.coe_mk]
+    rw [smul_def_K, smul_def_K, ← germ_mul, ← germ_mul, ← germ_add, germ_eq_iff]
+    filter_upwards [deriv_eventuallyEq_𝓕 (real_mul N K x y),
+      eventually_differentiableAt_real N K x, eventually_differentiableAt_real N K y]
+      with z hz hx hy
+    rw [hz, deriv_fun_mul hx hy]
+    ring
+
+theorem δ_apply (y : K) : δ N K y = germ N K (deriv (real N K y)) := rfl
+
+def Φ₀ : Ω[K⁄ℂ] →ₗ[K] Gm N K := (δ N K).liftKaehlerDifferential
+
+theorem Φ₀_smul_D (f π : K) :
+    Φ₀ N K (f • KaehlerDifferential.D ℂ K π) =
+      germ N K (fun z => real N K f z * deriv (real N K π) z) := by
+  rw [Φ₀, map_smul, Derivation.liftKaehlerDifferential_comp_D, δ_apply, smul_def_K, ← germ_mul]
+
+theorem Φ₀_smul_C (c : ℂ) (ω : Ω[K⁄ℂ]) : Φ₀ N K (c • ω) = c • Φ₀ N K ω := by
+  rw [← IsScalarTower.algebraMap_smul K c ω, map_smul, IsScalarTower.algebraMap_smul]
+
+end Germs
+
+section OrderMap
+
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ring N) K] [IsScalarTower ℂ (ring N) K]
+  [IsFractionRing (ring N) K]
+
+def ν (τ₀ : ℍ) (k : K) : WithTop ℤ := meromorphicOrderAt (real N K k) τ₀
+
+variable (τ₀ : ℍ)
+
+omit [NeZero N] [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem ν_congr {k : K} {g : ℂ → ℂ} (h : real N K k =ᶠ[𝓕] g) :
+    ν N K τ₀ k = meromorphicOrderAt g τ₀ :=
+  meromorphicOrderAt_congr (eventually_nhdsNE_of_𝓕 h (coe_mem_𝕌 τ₀))
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem ν_mul (x y : K) : ν N K τ₀ (x * y) = ν N K τ₀ x + ν N K τ₀ y := by
+  rw [ν_congr N K τ₀ (real_mul N K x y)]
+  exact meromorphicOrderAt_mul (meromorphicAt_real N K x (coe_mem_𝕌 τ₀))
+    (meromorphicAt_real N K y (coe_mem_𝕌 τ₀))
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem ν_add (x y : K) : min (ν N K τ₀ x) (ν N K τ₀ y) ≤ ν N K τ₀ (x + y) := by
+  rw [ν_congr N K τ₀ (real_add N K x y)]
+  exact meromorphicOrderAt_add (meromorphicAt_real N K x (coe_mem_𝕌 τ₀))
+    (meromorphicAt_real N K y (coe_mem_𝕌 τ₀))
+
+theorem ν_const (c : ℂ) (hc : c ≠ 0) : ν N K τ₀ (algebraMap ℂ K c) = 0 := by
+  rw [ν_congr N K τ₀ (real_const N K c)]
+  classical
+  rw [meromorphicOrderAt_const]
+  simp [hc]
+
+theorem ν_eq_top_iff (x : K) : ν N K τ₀ x = ⊤ ↔ x = 0 := by
+  constructor
+  · intro h
+    rw [ν, meromorphicOrderAt_eq_top_iff] at h
+    have hden := eventually_nhdsNE_of_𝓕 (eventually_ne_zero N (den N K x).2 (den_ne_zero N K x))
+      (coe_mem_𝕌 τ₀)
+    have hnum : ∀ᶠ z in 𝓝[≠] ((τ₀ : ℍ) : ℂ), up (num N K x : ℍ → ℂ) z = 0 := by
+      filter_upwards [h, hden] with z hz hd
+      simp only [real, div_eq_zero_iff] at hz
+      exact hz.resolve_right hd
+    have hz := (analyticOnNhd_up N (num N K x).2).eqOn_zero_of_preconnected_of_frequently_eq_zero
+      isPreconnected_𝕌 (coe_mem_𝕌 τ₀) hnum.frequently
+    have hnum0 : ((num N K x : ring N) : ℍ → ℂ) = 0 :=
+      (up_eq_zero_iff _).mp fun z hzU => hz hzU
+    rw [← num_div_den N K x]
+    have : num N K x = 0 := Subtype.ext hnum0
+    rw [this, map_zero, zero_div]
+  · rintro rfl
+    have h := real_const N K 0
+    rw [map_zero] at h
+    rw [ν_congr N K τ₀ h, meromorphicOrderAt_eq_top_iff]
+    exact Filter.Eventually.of_forall fun _ => rfl
+
+theorem ν_ne_top {x : K} (hx : x ≠ 0) : ν N K τ₀ x ≠ ⊤ := fun h => hx ((ν_eq_top_iff N K τ₀ x).mp h)
+
+def jSub : ring N := jGen N - algebraMap ℂ (ring N) (jAnalytic τ₀)
+
+omit [NeZero N] in
+theorem coe_jSub : ((jSub N τ₀ : ring N) : ℍ → ℂ) = fun τ => jAnalytic τ - jAnalytic τ₀ := by
+  funext τ
+  simp [jSub, jGen, Algebra.algebraMap_eq_smul_one]
+
+theorem jSub_ne_zero : ((jSub N τ₀ : ring N) : ℍ → ℂ) ≠ 0 := by
+  intro h'
+  rw [coe_jSub] at h'
+  have htr := jAnalytic_transcendental N (Polynomial.X - Polynomial.C (jAnalytic τ₀)) (fun τ => by
+    have := congrFun h' τ
+    simp only [Pi.zero_apply] at this
+    simp [this])
+  have := congrArg (Polynomial.eval (jAnalytic τ₀ + 1)) htr
+  simp at this
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem ν_jSub_pos : 0 < ν N K τ₀ (algebraMap (ring N) K (jSub N τ₀)) := by
+  rw [ν_congr N K τ₀ (real_algebraMap N K (jSub N τ₀))]
+  have han := analyticAt_up N (jSub N τ₀).2 (coe_mem_𝕌 τ₀)
+  apply (tendsto_zero_iff_meromorphicOrderAt_pos han.meromorphicAt).mp
+  have h0 : up ((jSub N τ₀ : ring N) : ℍ → ℂ) τ₀ = 0 := by
+    rw [up_apply_coe, coe_jSub]; simp
+  have := han.continuousAt.tendsto
+  rw [h0] at this
+  exact this.mono_left nhdsWithin_le_nhds
+
+theorem exists_place :
+    ∃ (P : AlgebraicCurve.Place ℂ K) (e : ℕ), 0 < e ∧
+      (∀ x, x ∈ P.toValuationSubring ↔ 0 ≤ ν N K τ₀ x) ∧
+      ∀ x, x ≠ 0 → ν N K τ₀ x = (((e : ℤ) * P.ord x : ℤ) : WithTop ℤ) :=
+  AlgebraicCurve.Place.exists_of_orderMap (ν N K τ₀) (ν_eq_top_iff N K τ₀) (ν_mul N K τ₀)
+    (ν_add N K τ₀) (fun c hc => ν_const N K τ₀ c hc)
+    ⟨algebraMap (ring N) K (jSub N τ₀), ν_jSub_pos N K τ₀,
+      ν_ne_top N K τ₀ (algebraMap_ne_zero N K (jSub_ne_zero N τ₀))⟩
+
+theorem exists_analyticAt_eventuallyEq {f : ℂ → ℂ} {x : ℂ} (hf : MeromorphicAt f x)
+    (h : 0 ≤ meromorphicOrderAt f x) :
+    ∃ G : ℂ → ℂ, AnalyticAt ℂ G x ∧ f =ᶠ[𝓝[≠] x] G := by
+  by_cases htop : meromorphicOrderAt f x = ⊤
+  · exact ⟨fun _ => 0, analyticAt_const, meromorphicOrderAt_eq_top_iff.mp htop⟩
+  · obtain ⟨n, hn⟩ := WithTop.ne_top_iff_exists.mp htop
+    have hn0 : (0 : ℤ) ≤ n := by
+      rw [← hn] at h
+      exact_mod_cast h
+    obtain ⟨m, rfl⟩ := Int.eq_ofNat_of_zero_le hn0
+    obtain ⟨g, hg, -, hfg⟩ := (meromorphicOrderAt_eq_int_iff hf).mp hn.symm
+    refine ⟨fun z => (z - x) ^ m * g z, ((analyticAt_id.sub analyticAt_const).pow m).mul hg, ?_⟩
+    filter_upwards [hfg] with z hz
+    rw [hz, zpow_natCast, smul_eq_mul]
+
+theorem exists_smul_D_of_mem {ω : Ω[K⁄ℂ]} (hω : ω ∈ AlgebraicCurve.regularDifferentials ℂ K) :
+    ∃ f π : K, ω = f • KaehlerDifferential.D ℂ K π ∧ π ≠ 0 ∧ 0 ≤ ν N K τ₀ f ∧
+      (∃ n : ℤ, 1 ≤ n ∧ ν N K τ₀ π = n) := by
+  obtain ⟨P, e, he, hmem, hord⟩ := exists_place N K τ₀
+  obtain ⟨f, hf, hωf⟩ := (AlgebraicCurve.mem_regularDifferentials_iff.mp hω) P
+  obtain ⟨π, hπ1, hdC⟩ := P.exists_ord_eq_one_and_dCoord_eq
+  have hπ0 : π ≠ 0 := by
+    intro h
+    rw [h, AlgebraicCurve.Place.ord_zero] at hπ1
+    exact zero_ne_one hπ1
+  refine ⟨f, π, by rw [hωf, hdC], hπ0, (hmem f).mp hf, ⟨(e : ℤ) * P.ord π, ?_, hord π hπ0⟩⟩
+  rw [hπ1, mul_one]
+  exact_mod_cast he
+
+end OrderMap
+
+section Glue
+
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ring N) K] [IsScalarTower ℂ (ring N) K]
+  [IsFractionRing (ring N) K]
+
+def LocAnalytic (m : Gm N K) : Prop :=
+  ∀ z ∈ 𝕌, ∃ g G : ℂ → ℂ, germ N K g = m ∧ AnalyticAt ℂ G z ∧ g =ᶠ[𝓝[≠] z] G
+
+theorem locAnalytic_Φ₀ {ω : Ω[K⁄ℂ]} (hω : ω ∈ AlgebraicCurve.regularDifferentials ℂ K) :
+    LocAnalytic N K (Φ₀ N K ω) := by
+  intro z hz
+  set τ₀ : ℍ := ⟨z, hz⟩
+  have hzτ : ((τ₀ : ℍ) : ℂ) = z := rfl
+  obtain ⟨f, π, hω', hπ0, hf, n, hn1, hn⟩ := exists_smul_D_of_mem N K τ₀ hω
+  obtain ⟨Gf, hGf, hfG⟩ := exists_analyticAt_eventuallyEq
+    (meromorphicAt_real N K f (coe_mem_𝕌 τ₀)) hf
+  obtain ⟨Gπ, hGπ, hπG⟩ := exists_analyticAt_eventuallyEq
+    (meromorphicAt_real N K π (coe_mem_𝕌 τ₀)) (by
+      change 0 ≤ ν N K τ₀ π
+      rw [hn]; exact_mod_cast (zero_le_one.trans hn1))
+  rw [hzτ] at hfG hπG hGf hGπ
+  refine ⟨fun w => real N K f w * deriv (real N K π) w, fun w => Gf w * deriv Gπ w, ?_,
+    hGf.mul hGπ.deriv, ?_⟩
+  · rw [hω', Φ₀_smul_D]
+  · filter_upwards [hfG, deriv_eventuallyEq_nhdsNE hπG] with w h1 h2
+    rw [h1, h2]
+
+variable {K}
+
+omit [NeZero N] [Field K] [Algebra ℂ K] [Algebra (↥(ring N)) K] [IsScalarTower ℂ (↥(ring N)) K]
+  [IsFractionRing (↥(ring N)) K] in
+theorem tendsto_of_germ_eq {m : Gm N K} {g G : ℂ → ℂ} {z : ℂ} (hz : z ∈ 𝕌) (hg : germ N K g = m)
+    (hG : ContinuousAt G z) (hgG : g =ᶠ[𝓝[≠] z] G) {g' : ℂ → ℂ} (hg' : germ N K g' = m) :
+    Tendsto g' (𝓝[≠] z) (𝓝 (G z)) := by
+  have h1 : g' =ᶠ[𝓕] g := (germ_eq_iff N K).mp (hg'.trans hg.symm)
+  have h1' : g' =ᶠ[𝓝[≠] z] g := eventually_nhdsNE_of_𝓕 h1 hz
+  have h2 : g' =ᶠ[𝓝[≠] z] G := h1'.trans hgG
+  exact (hG.tendsto.mono_left nhdsWithin_le_nhds).congr' h2.symm
+
+omit [NeZero N] [Field K] [Algebra ℂ K] [Algebra (↥(ring N)) K] [IsScalarTower ℂ (↥(ring N)) K]
+  [IsFractionRing (↥(ring N)) K] in
+theorem value_unique {m : Gm N K} {z : ℂ} (hz : z ∈ 𝕌) {g₁ G₁ g₂ G₂ : ℂ → ℂ}
+    (hg₁ : germ N K g₁ = m) (hG₁ : ContinuousAt G₁ z) (h₁ : g₁ =ᶠ[𝓝[≠] z] G₁)
+    (hg₂ : germ N K g₂ = m) (hG₂ : ContinuousAt G₂ z) (h₂ : g₂ =ᶠ[𝓝[≠] z] G₂) : G₁ z = G₂ z :=
+  tendsto_nhds_unique (tendsto_of_germ_eq N hz hg₁ hG₁ h₁ hg₁) (tendsto_of_germ_eq N hz hg₂ hG₂ h₂
+    hg₁)
+
+variable (K)
+
+open Classical in
+def glue (m : Gm N K) (z : ℂ) : ℂ :=
+  if h : z ∈ 𝕌 ∧ ∃ g G : ℂ → ℂ, germ N K g = m ∧ AnalyticAt ℂ G z ∧ g =ᶠ[𝓝[≠] z] G then
+    h.2.choose_spec.choose z
+  else 0
+
+omit [NeZero N] [Field K] [Algebra ℂ K] [Algebra (↥(ring N)) K] [IsScalarTower ℂ (↥(ring N)) K]
+  [IsFractionRing (↥(ring N)) K] in
+theorem glue_eq {m : Gm N K} {z : ℂ} (hz : z ∈ 𝕌) {g G : ℂ → ℂ} (hg : germ N K g = m)
+    (hG : AnalyticAt ℂ G z) (hgG : g =ᶠ[𝓝[≠] z] G) : glue N K m z = G z := by
+  have h : z ∈ 𝕌 ∧ ∃ g G : ℂ → ℂ, germ N K g = m ∧ AnalyticAt ℂ G z ∧ g =ᶠ[𝓝[≠] z] G :=
+    ⟨hz, g, G, hg, hG, hgG⟩
+  rw [glue, dite_eq_left h]
+  obtain ⟨hg', hG', hgG'⟩ := h.2.choose_spec.choose_spec
+  exact value_unique N hz hg' hG'.continuousAt hgG' hg hG.continuousAt hgG
+
+omit [NeZero N] [Field K] [Algebra ℂ K] [Algebra (↥(ring N)) K] [IsScalarTower ℂ (↥(ring N)) K]
+  [IsFractionRing (↥(ring N)) K] in
+theorem glue_eventuallyEq {m : Gm N K} {z : ℂ} (hz : z ∈ 𝕌) {g G : ℂ → ℂ}
+    (hg : germ N K g = m) (hG : AnalyticAt ℂ G z) (hgG : g =ᶠ[𝓝[≠] z] G) :
+    glue N K m =ᶠ[𝓝 z] G := by
+  have hp : ∀ᶠ w in 𝓝[≠] z, glue N K m w = G w := by
+    filter_upwards [eventually_eventuallyEq_nhds hgG,
+      mem_nhdsWithin_of_mem_nhds hG.eventually_analyticAt,
+      mem_nhdsWithin_of_mem_nhds (isOpen_𝕌.mem_nhds hz)] with w hw hGw hwU
+    exact glue_eq N K hwU hg hGw (hw.filter_mono nhdsWithin_le_nhds)
+  have h0 : glue N K m z = G z := glue_eq N K hz hg hG hgG
+  rw [eventually_nhdsWithin_iff] at hp
+  filter_upwards [hp] with w hw
+  by_cases hwz : w = z
+  · rw [hwz, h0]
+  · exact hw hwz
+
+omit [NeZero N] [Field K] [Algebra ℂ K] [Algebra (↥(ring N)) K] [IsScalarTower ℂ (↥(ring N)) K]
+  [IsFractionRing (↥(ring N)) K] in
+theorem analyticOnNhd_glue {m : Gm N K} (hm : LocAnalytic N K m) :
+    AnalyticOnNhd ℂ (glue N K m) 𝕌 := by
+  intro z hz
+  obtain ⟨g, G, hg, hG, hgG⟩ := hm z hz
+  exact hG.congr (glue_eventuallyEq N K hz hg hG hgG).symm
+
+omit [NeZero N] [Field K] [Algebra ℂ K] [Algebra (↥(ring N)) K] [IsScalarTower ℂ (↥(ring N)) K]
+  [IsFractionRing (↥(ring N)) K] in
+theorem germ_glue {m : Gm N K} (hm : LocAnalytic N K m) : germ N K (glue N K m) = m := by
+  obtain ⟨g₀, hg₀⟩ := germ_surjective N K m
+  suffices h : germ N K (glue N K m) = germ N K g₀ by rw [h, hg₀]
+  rw [germ_eq_iff, eventuallyEq_𝓕_iff]
+  intro z hz
+  obtain ⟨g, G, hg, hG, hgG⟩ := hm z hz
+  have h1 : glue N K m =ᶠ[𝓝[≠] z] G :=
+    (glue_eventuallyEq N K hz hg hG hgG).filter_mono nhdsWithin_le_nhds
+  have h2 : g₀ =ᶠ[𝓝[≠] z] g :=
+    eventuallyEq_𝓕_iff.mp ((germ_eq_iff N K).mp (hg₀.trans hg.symm)) z hz
+  exact h1.trans (hgG.symm.trans h2.symm)
+
+omit [NeZero N] [Field K] [Algebra ℂ K] [Algebra (↥(ring N)) K] [IsScalarTower ℂ (↥(ring N)) K]
+  [IsFractionRing (↥(ring N)) K] in
+theorem eqOn_glue {m : Gm N K} (hm : LocAnalytic N K m) {F : ℂ → ℂ} (hF : AnalyticOnNhd ℂ F 𝕌)
+    (hFm : germ N K F = m) : Set.EqOn F (glue N K m) 𝕌 :=
+  eqOn_of_eventuallyEq_𝓕 hF (analyticOnNhd_glue N K hm)
+    ((germ_eq_iff N K).mp (hFm.trans (germ_glue N K hm).symm))
+
+omit [NeZero N] [Field K] [Algebra ℂ K] [Algebra (↥(ring N)) K] [IsScalarTower ℂ (↥(ring N)) K]
+  [IsFractionRing (↥(ring N)) K] in
+theorem locAnalytic_add {m₁ m₂ : Gm N K} (h₁ : LocAnalytic N K m₁) (h₂ : LocAnalytic N K m₂) :
+    LocAnalytic N K (m₁ + m₂) := by
+  intro z hz
+  obtain ⟨g₁, G₁, hg₁, hG₁, e₁⟩ := h₁ z hz
+  obtain ⟨g₂, G₂, hg₂, hG₂, e₂⟩ := h₂ z hz
+  refine ⟨g₁ + g₂, G₁ + G₂, by rw [germ_add', hg₁, hg₂], hG₁.add hG₂, ?_⟩
+  filter_upwards [e₁, e₂] with w h1 h2
+  simp [h1, h2]
+
+theorem locAnalytic_smul (c : ℂ) {m : Gm N K} (h : LocAnalytic N K m) :
+    LocAnalytic N K (c • m) := by
+  intro z hz
+  obtain ⟨g, G, hg, hG, e⟩ := h z hz
+  refine ⟨fun w => c * g w, fun w => c * G w, by rw [← hg,
+    smul_germ_C], analyticAt_const.mul hG, ?_⟩
+  filter_upwards [e] with w hw
+  rw [hw]
+
+omit [NeZero N] [Field K] [Algebra ℂ K] [Algebra (↥(ring N)) K] [IsScalarTower ℂ (↥(ring N)) K]
+  [IsFractionRing (↥(ring N)) K] in
+theorem glue_add {m₁ m₂ : Gm N K} (h₁ : LocAnalytic N K m₁) (h₂ : LocAnalytic N K m₂) :
+    Set.EqOn (glue N K m₁ + glue N K m₂) (glue N K (m₁ + m₂)) 𝕌 :=
+  eqOn_glue N K (locAnalytic_add N K h₁ h₂) ((analyticOnNhd_glue N K h₁).add (analyticOnNhd_glue N K
+    h₂))
+    (by rw [germ_add', germ_glue N K h₁, germ_glue N K h₂])
+
+theorem glue_smul (c : ℂ) {m : Gm N K} (h : LocAnalytic N K m) :
+    Set.EqOn (fun z => c * glue N K m z) (glue N K (c • m)) 𝕌 :=
+  eqOn_glue N K (locAnalytic_smul N K c h)
+    (fun z hz => analyticAt_const.mul (analyticOnNhd_glue N K h z hz))
+    (by rw [← smul_germ_C, germ_glue N K h])
+
+def Ψfun (ω : AlgebraicCurve.regularDifferentials ℂ K) : ℍ → ℂ :=
+  fun τ => glue N K (Φ₀ N K (ω : Ω[K⁄ℂ])) τ
+
+def Ψ : AlgebraicCurve.regularDifferentials ℂ K →ₗ[ℂ] (ℍ → ℂ) where
+  toFun := Ψfun N K
+  map_add' ω₁ ω₂ := by
+    funext τ
+    simp only [Ψfun, Submodule.coe_add, map_add, Pi.add_apply]
+    exact (glue_add N K (locAnalytic_Φ₀ N K ω₁.2) (locAnalytic_Φ₀ N K ω₂.2) (coe_mem_𝕌 τ)).symm
+  map_smul' c ω := by
+    funext τ
+    simp only [Ψfun, Submodule.coe_smul, RingHom.id_apply, Pi.smul_apply, smul_eq_mul]
+    rw [Φ₀_smul_C]
+    exact (glue_smul N K c (locAnalytic_Φ₀ N K ω.2) (coe_mem_𝕌 τ)).symm
+
+theorem Ψ_apply (ω : AlgebraicCurve.regularDifferentials ℂ K) (τ : ℍ) :
+    Ψ N K ω τ = glue N K (Φ₀ N K (ω : Ω[K⁄ℂ])) τ := rfl
+
+theorem up_Ψ_eqOn (ω : AlgebraicCurve.regularDifferentials ℂ K) :
+    Set.EqOn (up (Ψ N K ω)) (glue N K (Φ₀ N K (ω : Ω[K⁄ℂ]))) 𝕌 := by
+  intro z hz
+  rw [up_apply_of_mem _ hz]
+  rfl
+
+theorem analyticOnNhd_up_Ψ (ω : AlgebraicCurve.regularDifferentials ℂ K) :
+    AnalyticOnNhd ℂ (up (Ψ N K ω)) 𝕌 :=
+  (analyticOnNhd_glue N K (locAnalytic_Φ₀ N K ω.2)).congr isOpen_𝕌 (up_Ψ_eqOn N K ω).symm
+
+theorem mdifferentiable_Ψ (ω : AlgebraicCurve.regularDifferentials ℂ K) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (Ψ N K ω) :=
+  UpperHalfPlane.mdifferentiable_iff.mpr (analyticOnNhd_up_Ψ N K ω).differentiableOn
+
+theorem germ_up_Ψ (ω : AlgebraicCurve.regularDifferentials ℂ K) :
+    germ N K (up (Ψ N K ω)) = Φ₀ N K (ω : Ω[K⁄ℂ]) := by
+  rw [← germ_glue N K (locAnalytic_Φ₀ N K ω.2), germ_eq_iff]
+  filter_upwards [𝕌_mem_𝓕] with z hz using up_Ψ_eqOn N K ω hz
+
+end Glue
+
+section Identity
+
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ring N) K] [IsScalarTower ℂ (ring N) K]
+  [IsFractionRing (ring N) K]
+
+theorem identity (ω : AlgebraicCurve.regularDifferentials ℂ K) (a b c e : ℍ → ℂ) (ha : a ∈ ring N)
+    (hb : b ∈ ring N) (hc : c ∈ ring N) (he : e ∈ ring N) (hb0 : b ≠ 0) (he0 : e ≠ 0)
+    (hω : (ω : Ω[K⁄ℂ]) =
+      (algebraMap (ring N) K ⟨a, ha⟩ / algebraMap (ring N) K ⟨b, hb⟩) •
+        KaehlerDifferential.D ℂ K (algebraMap (ring N) K ⟨c, hc⟩ / algebraMap (ring N) K ⟨e, he⟩))
+    (τ : ℍ) :
+    Ψ N K ω τ * b τ * e τ ^ 2 =
+      a τ * (e τ * deriv (c ∘ ofComplex) τ - c τ * deriv (e ∘ ofComplex) τ) := by
+  set A : K := algebraMap (ring N) K ⟨a, ha⟩ / algebraMap (ring N) K ⟨b, hb⟩ with hA
+  set C : K := algebraMap (ring N) K ⟨c, hc⟩ / algebraMap (ring N) K ⟨e, he⟩ with hC
+  have hΦ : Φ₀ N K (ω : Ω[K⁄ℂ]) = germ N K (fun z => real N K A z * deriv (real N K C) z) := by
+    rw [hω, Φ₀_smul_D]
+  have hf : real N K A =ᶠ[𝓕] fun z => up a z / up b z :=
+    real_eventuallyEq N K (k := A) (a := ⟨a, ha⟩) (b := ⟨b, hb⟩) hb0 rfl
+  have hπ : real N K C =ᶠ[𝓕] fun z => up c z / up e z :=
+    real_eventuallyEq N K (k := C) (a := ⟨c, hc⟩) (b := ⟨e, he⟩) he0 rfl
+  have hup : up (Ψ N K ω) =ᶠ[𝓕] fun z => real N K A z * deriv (real N K C) z :=
+    (germ_eq_iff N K).mp (by rw [germ_up_Ψ, hΦ])
+  set L : ℂ → ℂ := up (Ψ N K ω) * up b * up e ^ 2 with hL
+  set R : ℂ → ℂ := up a * (up e * deriv (up c) - up c * deriv (up e)) with hR
+  have hLR : L =ᶠ[𝓕] R := by
+    filter_upwards [hup, hf, deriv_eventuallyEq_𝓕 hπ, eventually_ne_zero N hb hb0,
+      eventually_ne_zero N he he0, 𝕌_mem_𝓕] with z h1 h2 h3 hbz hez hzU
+    simp only [hL, hR, Pi.mul_apply, Pi.pow_apply, Pi.sub_apply]
+    rw [h1, h2, h3, deriv_fun_div (differentiableAt_up N hc hzU) (differentiableAt_up N he hzU) hez]
+    field_simp
+  have hLa : AnalyticOnNhd ℂ L 𝕌 :=
+    ((analyticOnNhd_up_Ψ N K ω).mul (analyticOnNhd_up N hb)).mul ((analyticOnNhd_up N he).pow 2)
+  have hRa : AnalyticOnNhd ℂ R 𝕌 :=
+    (analyticOnNhd_up N ha).mul
+      (((analyticOnNhd_up N he).mul (analyticOnNhd_up N hc).deriv).sub
+        ((analyticOnNhd_up N hc).mul (analyticOnNhd_up N he).deriv))
+  have h := eqOn_of_eventuallyEq_𝓕 hLa hRa hLR (coe_mem_𝕌 τ)
+  simp only [hL, hR, Pi.mul_apply, Pi.pow_apply, Pi.sub_apply, up_apply_coe] at h
+  exact h
+
+theorem exists_rep_of_mem (ω : Ω[K⁄ℂ]) (hω : ω ∈ AlgebraicCurve.regularDifferentials ℂ K) :
+    ∃ (a b c e : ℍ → ℂ) (ha : a ∈ ring N) (hb : b ∈ ring N) (hc : c ∈ ring N) (he : e ∈ ring N),
+      b ≠ 0 ∧ e ≠ 0 ∧
+      ω = (algebraMap (ring N) K ⟨a, ha⟩ / algebraMap (ring N) K ⟨b, hb⟩) •
+        KaehlerDifferential.D ℂ K (algebraMap (ring N) K ⟨c, hc⟩ / algebraMap (ring N) K ⟨e, he⟩)
+          := by
+  obtain ⟨f, π, hω', -, -, -⟩ := exists_smul_D_of_mem N K UpperHalfPlane.I hω
+  refine ⟨num N K f, den N K f, num N K π, den N K π, (num N K f).2, (den N K f).2, (num N K π).2,
+    (den N K π).2, den_ne_zero N K f, den_ne_zero N K π, ?_⟩
+  rw [hω', num_div_den, num_div_den]
+
+theorem Ψ_injective : Function.Injective (Ψ N K) := by
+  rw [injective_iff_map_eq_zero]
+  intro ω hΨ
+  have hΦ0 : Φ₀ N K (ω : Ω[K⁄ℂ]) = 0 := by
+    rw [← germ_up_Ψ, hΨ, up_zero, germ_zero']
+  set τ₀ : ℍ := UpperHalfPlane.I
+  obtain ⟨f, π, hω', hπ0, -, n, hn1, hn⟩ := exists_smul_D_of_mem N K τ₀ ω.2
+  by_cases hf0 : f = 0
+  · apply Subtype.ext
+    rw [hω', hf0, zero_smul]
+    rfl
+  exfalso
+  rw [hω', Φ₀_smul_D, germ_mul] at hΦ0
+  have hunit : IsUnit (germ N K (real N K f)) := (isUnit_iff_ne_zero.mpr hf0).map (φ N K)
+  have hδ : germ N K (deriv (real N K π)) = 0 := (hunit.mul_right_eq_zero).mp hΦ0
+  rw [← germ_zero', germ_eq_iff] at hδ
+  have hδ' : deriv (real N K π) =ᶠ[𝓝[≠] ((τ₀ : ℍ) : ℂ)] (0 : ℂ → ℂ) :=
+    eventually_nhdsNE_of_𝓕 hδ (coe_mem_𝕌 τ₀)
+  obtain ⟨g, hg, hg0, hπg⟩ :=
+    (meromorphicOrderAt_eq_int_iff (meromorphicAt_real N K π (coe_mem_𝕌 τ₀))).mp hn
+  obtain ⟨m, hm⟩ := Int.eq_ofNat_of_zero_le (zero_le_one.trans hn1)
+  have hm1 : 1 ≤ m := by rw [hm] at hn1; exact_mod_cast hn1
+  set x₀ : ℂ := ((τ₀ : ℍ) : ℂ)
+  set H : ℂ → ℂ := fun z => (z - x₀) ^ m * g z with hH
+  have hπH : real N K π =ᶠ[𝓝[≠] x₀] H := by
+    filter_upwards [hπg] with z hz
+    rw [hz, hm, zpow_natCast, smul_eq_mul]
+  have hHa : AnalyticAt ℂ H x₀ := ((analyticAt_id.sub analyticAt_const).pow m).mul hg
+  have hdH : deriv H =ᶠ[𝓝[≠] x₀] (0 : ℂ → ℂ) :=
+    (deriv_eventuallyEq_nhdsNE hπH).symm.trans hδ'
+  have hev : ∀ᶠ z in 𝓝 x₀, deriv H z = 0 :=
+    hHa.deriv.frequently_zero_iff_eventually_zero.mp hdH.frequently
+  have htop : analyticOrderAt (deriv H) x₀ = ⊤ := analyticOrderAt_eq_top.mpr hev
+  have hH0 : H x₀ = 0 := by
+    simp [hH, zero_pow (Nat.one_le_iff_ne_zero.mp hm1)]
+  have hordH : analyticOrderAt H x₀ = m := by
+    rw [hHa.analyticOrderAt_eq_natCast]
+    exact ⟨g, hg, hg0, Filter.Eventually.of_forall fun z => by simp [hH, smul_eq_mul]⟩
+  have h := hHa.analyticOrderAt_deriv_add_one
+  simp only [hH0, sub_zero] at h
+  rw [htop, hordH] at h
+  simp at h
+
+end Identity
+
+end ModularCurve.LevelN.HolDiff
+
+open ModularCurve.LevelN.HolDiff in
+theorem solution (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring N) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring N) K]
+    [IsFractionRing (ModularCurve.LevelN.ring N) K] :
+    (∀ ω ∈ AlgebraicCurve.regularDifferentials ℂ K,
+      ∃ (a b c e : UpperHalfPlane → ℂ) (ha : a ∈ ModularCurve.LevelN.ring N)
+        (hb : b ∈ ModularCurve.LevelN.ring N) (hc : c ∈ ModularCurve.LevelN.ring N)
+        (he : e ∈ ModularCurve.LevelN.ring N), b ≠ 0 ∧ e ≠ 0 ∧
+        ω = (algebraMap (ModularCurve.LevelN.ring N) K ⟨a, ha⟩ /
+              algebraMap (ModularCurve.LevelN.ring N) K ⟨b, hb⟩) •
+            KaehlerDifferential.D ℂ K (algebraMap (ModularCurve.LevelN.ring N) K ⟨c, hc⟩ /
+              algebraMap (ModularCurve.LevelN.ring N) K ⟨e, he⟩)) ∧
+    ∃ Ψ : AlgebraicCurve.regularDifferentials ℂ K →ₗ[ℂ] (UpperHalfPlane → ℂ),
+      Function.Injective Ψ ∧
+      (∀ ω, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (Ψ ω)) ∧
+      ∀ (ω : AlgebraicCurve.regularDifferentials ℂ K) (a b c e : UpperHalfPlane → ℂ)
+        (ha : a ∈ ModularCurve.LevelN.ring N) (hb : b ∈ ModularCurve.LevelN.ring N)
+        (hc : c ∈ ModularCurve.LevelN.ring N) (he : e ∈ ModularCurve.LevelN.ring N),
+        b ≠ 0 → e ≠ 0 →
+        (ω : KaehlerDifferential ℂ K) =
+          (algebraMap (ModularCurve.LevelN.ring N) K ⟨a, ha⟩ /
+              algebraMap (ModularCurve.LevelN.ring N) K ⟨b, hb⟩) •
+            KaehlerDifferential.D ℂ K (algebraMap (ModularCurve.LevelN.ring N) K ⟨c, hc⟩ /
+              algebraMap (ModularCurve.LevelN.ring N) K ⟨e, he⟩) →
+        ∀ τ : UpperHalfPlane, Ψ ω τ * b τ * e τ ^ 2 =
+          a τ * (e τ * deriv (c ∘ UpperHalfPlane.ofComplex) τ -
+            c τ * deriv (e ∘ UpperHalfPlane.ofComplex) τ) :=
+  ⟨fun ω hω => exists_rep_of_mem N K ω hω,
+    Ψ N K, Ψ_injective N K, mdifferentiable_Ψ N K,
+    fun ω a b c e ha hb hc he hb0 he0 hω τ => identity N K ω a b c e ha hb hc he hb0 he0 hω τ⟩
+
+end
+end S_ModularCurve_LevelN_exists_linearMap_regularDifferentials_mdifferentiable
+end P2MW
+export P2MW.S_ModularCurve_LevelN_exists_linearMap_regularDifferentials_mdifferentiable (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Manifold
+theorem ModularCurve.LevelN.exists_linearMap_regularDifferentials_mdifferentiable
+    (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring N) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring N) K]
+    [IsFractionRing (ModularCurve.LevelN.ring N) K] :
+    (∀ ω ∈ AlgebraicCurve.regularDifferentials ℂ K,
+      ∃ (a b c e : UpperHalfPlane → ℂ) (ha : a ∈ ModularCurve.LevelN.ring N)
+        (hb : b ∈ ModularCurve.LevelN.ring N) (hc : c ∈ ModularCurve.LevelN.ring N)
+        (he : e ∈ ModularCurve.LevelN.ring N), b ≠ 0 ∧ e ≠ 0 ∧
+        ω = (algebraMap (ModularCurve.LevelN.ring N) K ⟨a, ha⟩ /
+              algebraMap (ModularCurve.LevelN.ring N) K ⟨b, hb⟩) •
+            KaehlerDifferential.D ℂ K (algebraMap (ModularCurve.LevelN.ring N) K ⟨c, hc⟩ /
+              algebraMap (ModularCurve.LevelN.ring N) K ⟨e, he⟩)) ∧
+    ∃ Ψ : AlgebraicCurve.regularDifferentials ℂ K →ₗ[ℂ] (UpperHalfPlane → ℂ),
+      Function.Injective Ψ ∧
+      (∀ ω, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (Ψ ω)) ∧
+      ∀ (ω : AlgebraicCurve.regularDifferentials ℂ K) (a b c e : UpperHalfPlane → ℂ)
+        (ha : a ∈ ModularCurve.LevelN.ring N) (hb : b ∈ ModularCurve.LevelN.ring N)
+        (hc : c ∈ ModularCurve.LevelN.ring N) (he : e ∈ ModularCurve.LevelN.ring N),
+        b ≠ 0 → e ≠ 0 →
+        (ω : KaehlerDifferential ℂ K) =
+          (algebraMap (ModularCurve.LevelN.ring N) K ⟨a, ha⟩ /
+              algebraMap (ModularCurve.LevelN.ring N) K ⟨b, hb⟩) •
+            KaehlerDifferential.D ℂ K (algebraMap (ModularCurve.LevelN.ring N) K ⟨c, hc⟩ /
+              algebraMap (ModularCurve.LevelN.ring N) K ⟨e, he⟩) →
+        ∀ τ : UpperHalfPlane, Ψ ω τ * b τ * e τ ^ 2 =
+          a τ * (e τ * deriv (c ∘ UpperHalfPlane.ofComplex) τ -
+            c τ * deriv (e ∘ UpperHalfPlane.ofComplex) τ) :=
+  solution N K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_monic_eval_eq_zero_coeff_eq_aeval_inv_div_of_forall_valuation_le_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_monic_eval_eq_zero_coeff_eq_aeval_inv_div_of_forall_valuation_le_one.lean
new file mode 100644
index 0000000000..227c0a0ed9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_monic_eval_eq_zero_coeff_eq_aeval_inv_div_of_forall_valuation_le_one.lean
@@ -0,0 +1,329 @@
+/-
+Based on Prove2Me node
+ModularCurve.LevelN.exists_monic_eval_eq_zero_coeff_eq_aeval_inv_div_of_forall_valuation_le_one
+(b7c8921a-b6a8-5b7b-a694-d41c39eab001) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 96a24ab4-b440-5738-892c-00c378e4d4aa
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LevelNFunctionField
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality over the j-line at j=∞
+
+Theorem statement:
+`ModularCurve.LevelN.exists_monic_eval_eq_zero_coeff_eq_aeval_inv_div_of_forall_valuation_le_one`
+(`b7c8921a-b6a8-5b7b-a694-d41c39eab001`), by Claude, 2026-09-05.
+
+Proof: submission `96a24ab4-b440-5738-892c-00c378e4d4aa`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $M\ge 1$ and let $A_M$ denote [`ModularCurve.LevelN.ring
+M`](def/ModularCurve_LevelNFunctionField.html#L28), the $\mathbb C$-subalgebra of functions $\mathbb
+H\to\mathbb C$ generated by $j=E_4^3/\Delta$ together with the Fricke functions
+$\mathrm{fricke}\,M\,v$ for the nonzero $v\in(\mathbb Z/M)^2$. Let $K$ be a field that is
+simultaneously a $\mathbb C$-algebra and an $A_M$-algebra, compatibly (scalar tower), and a fraction
+field of $A_M$. Let $\sigma\colon \mathrm{SL}(2,\mathbb Z)\to (K\simeq_{\mathbb C} K)$ be a group
+homomorphism into the $\mathbb C$-algebra automorphisms of $K$ whose kernel is the subgroup
+generated by $\Gamma(M)$ together with $-1$, and assume the fixed field of the image of $\sigma$ is
+$\mathbb C$ adjoined the image of $j$ in $K$. Let $E\colon K\to\mathbb C((q))$ be a homomorphism of
+$\mathbb C$-algebras into Laurent series sending the image of $j$ to $\mathrm{qExpand}\,\mathbb
+C\,M$ applied to $q^{-1}\cdot(E_4^3\eta^{-24})$, i.e. to the $q$-expansion of $j$ with $q$ replaced
+by $q^M$. Let $z\in K$ be such that for every $\gamma\in\mathrm{SL}(2,\mathbb Z)$ the Laurent series
+$E(\sigma_\gamma z)$ has valuation $\le 1$, i.e. no terms of negative order. Then there is a monic
+$P\in K[X]$ with $P(z)=0$ such that every coefficient $P_i$ can be written as $p(u)/q(u)$ with
+$p,q\in\mathbb C[X]$, $q(0)\neq0$, where $u$ is the inverse in $K$ of the image of $j$.
+
+This is the classical statement that an element of the level-$M$ function field whose $q$-expansions
+at all cusps (equivalently, along all $\mathrm{SL}(2,\mathbb Z)$-translates) have no pole is
+integral over the local ring $\mathbb C[1/j]_{(1/j)}$ of the $j$-line at $j=\infty$. The monic
+equation with coefficients of this shape is what is consumed by
+[`ModularCurve.ord_eq_zero_of_not_mem_of_realizeOf_tendsto`]
+(thm.html#ModularCurve.ord_eq_zero_of_not_mem_of_realizeOf_tendsto)
+when computing orders at the cusps.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_LevelN_exists_monic_eval_eq_zero_coeff_eq_aeval_inv_div_of_forall_valuation_le_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_b34f3d51
+
+open scoped MatrixGroups IntermediateField
+open Polynomial
+
+namespace N3Prep
+
+open Polynomial
+
+section Val
+
+variable {k L Γ₀ : Type*} [Field k] [Field L] [Algebra k L]
+  [LinearOrderedCommGroupWithZero Γ₀] (v : Valuation L Γ₀)
+
+theorem val_aeval_le_one (hk : ∀ a : k, v (algebraMap k L a) ≤ 1) {T : L} (hT : v T ≤ 1)
+    (p : k[X]) : v (aeval T p) ≤ 1 := by
+  induction p using Polynomial.induction_on' with
+  | add p q hp hq => rw [map_add]; exact (v.map_add _ _).trans (max_le hp hq)
+  | monomial n a =>
+    rw [aeval_monomial, map_mul, map_pow]
+    exact mul_le_one' (hk a) (pow_le_one' hT n)
+
+theorem val_aeval_eq_one (hk : ∀ a : k, v (algebraMap k L a) ≤ 1)
+    (hk1 : ∀ a : k, a ≠ 0 → v (algebraMap k L a) = 1) {T : L} (hT : v T < 1)
+    {p : k[X]} (hp : p.coeff 0 ≠ 0) : v (aeval T p) = 1 := by
+  have hdecomp : aeval T p = algebraMap k L (p.coeff 0) + T * aeval T p.divX := by
+    conv_lhs => rw [← Polynomial.divX_mul_X_add p]
+    rw [map_add, map_mul, aeval_X, aeval_C, mul_comm, add_comm]
+  rw [hdecomp, Valuation.map_add_eq_of_lt_left]
+  · exact hk1 _ hp
+  · rw [hk1 _ hp, map_mul]
+    exact mul_lt_one_of_lt_of_le hT (val_aeval_le_one v hk hT.le _)
+
+theorem val_aeval_lt_one (hk : ∀ a : k, v (algebraMap k L a) ≤ 1) {T : L} (hT : v T < 1)
+    {r : k[X]} (hr : r.coeff 0 = 0) : v (aeval T r) < 1 := by
+  have hdecomp : aeval T r = T * aeval T r.divX := by
+    conv_lhs => rw [← Polynomial.divX_mul_X_add r]
+    rw [hr, map_zero, add_zero, map_mul, aeval_X, mul_comm]
+  rw [hdecomp, map_mul]
+  exact mul_lt_one_of_lt_of_le hT (val_aeval_le_one v hk hT.le _)
+
+end Val
+
+section Reduce
+
+variable {k K : Type*} [Field k] [Field K] [Algebra k K]
+
+theorem exists_aeval_div_aeval_eq (t : K) (ht : t ≠ 0) :
+    ∀ (n : ℕ) (p r : k[X]), r.natDegree ≤ n →
+      ∃ p' r' : k[X], aeval t p / aeval t r = aeval t p' / aeval t r' ∧
+        (r' = 0 ∨ p'.coeff 0 ≠ 0 ∨ r'.coeff 0 ≠ 0) := by
+  intro n
+  induction n with
+  | zero =>
+    intro p r hr
+    refine ⟨p, r, rfl, ?_⟩
+    by_cases h0 : r.coeff 0 = 0
+    · left
+      rw [Polynomial.eq_C_of_natDegree_le_zero hr, h0, map_zero]
+    · exact Or.inr (Or.inr h0)
+  | succ n ih =>
+    intro p r hr
+    by_cases hp0 : p.coeff 0 = 0
+    · by_cases hr0 : r.coeff 0 = 0
+      · have hp' : aeval t p = t * aeval t p.divX := by
+          conv_lhs => rw [← Polynomial.divX_mul_X_add p]
+          rw [hp0, map_zero, add_zero, map_mul, aeval_X, mul_comm]
+        have hr' : aeval t r = t * aeval t r.divX := by
+          conv_lhs => rw [← Polynomial.divX_mul_X_add r]
+          rw [hr0, map_zero, add_zero, map_mul, aeval_X, mul_comm]
+        have hdeg : r.divX.natDegree ≤ n := by
+          rw [Polynomial.natDegree_divX_eq_natDegree_tsub_one]; omega
+        obtain ⟨p', r', h, h'⟩ := ih p.divX r.divX hdeg
+        refine ⟨p', r', ?_, h'⟩
+        rw [hp', hr', mul_div_mul_left _ _ ht, h]
+      · exact ⟨p, r, rfl, Or.inr (Or.inr hr0)⟩
+    · exact ⟨p, r, rfl, Or.inr (Or.inl hp0)⟩
+
+end Reduce
+
+end N3Prep
+
+theorem valinf_draft (M : ℕ) [NeZero M]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring M) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring M) K] [IsFractionRing (ModularCurve.LevelN.ring M) K]
+    (E : K →ₐ[ℂ] LaurentSeries ℂ)
+    (hEj : E (algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)) =
+      ModularCurve.qExpand ℂ M (ModularCurve.jqModC ℂ))
+    (c : K) (hc : c ∈ ℂ⟮algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)⟯)
+    (hpole : Valued.v (E c) ≤ 1) :
+    ∃ p q : ℂ[X], q.coeff 0 ≠ 0 ∧
+      c = aeval (algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M))⁻¹ p /
+        aeval (algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M))⁻¹ q := by
+  set jK := algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M) with hjK
+  have hcoeff : (E jK).coeff (-(M : ℤ)) = 1 := by
+    rw [hEj, show (-(M : ℤ)) = (M : ℤ) * (-1) by ring, ModularCurve.qExpand_coeff_mul,
+      ModularCurve.jqModC]
+    have h : ((HahnSeries.single (-1 : ℤ)) (1 : ℂ) *
+        HahnSeries.ofPowerSeries ℤ ℂ (ModularCurve.jNum.map (Int.castRingHom ℂ))).coeff (0 + (-1)) =
+          1 := by
+      rw [HahnSeries.coeff_single_mul_add, one_mul, show (0 : ℤ) = ((0 : ℕ) : ℤ) from rfl,
+        HahnSeries.ofPowerSeries_apply_coeff, PowerSeries.coeff_map,
+        PowerSeries.coeff_zero_eq_constantCoeff_apply, ModularCurve.constantCoeff_jNum, map_one]
+    simpa using h
+  have hvj : 1 < Valued.v (E jK) := by
+    by_contra h
+    push Not at h
+    have h' : Valued.v (E jK) ≤ WithZero.exp (-(0 : ℤ)) := by simpa using h
+    have := (LaurentSeries.valuation_le_iff_coeff_lt_eq_zero ℂ).mp h' (-(M : ℤ))
+      (by have := NeZero.ne M; omega)
+    rw [hcoeff] at this
+    exact one_ne_zero this
+  have hjK0 : jK ≠ 0 := by
+    intro h0; rw [h0, map_zero, map_zero] at hvj; exact not_lt_of_ge zero_le_one hvj
+  have hvT : Valued.v (E jK⁻¹) < 1 := by
+    rw [map_inv₀, map_inv₀]; exact inv_lt_one_of_one_lt₀ hvj
+  have hk : ∀ a : ℂ, Valued.v (algebraMap ℂ (LaurentSeries ℂ) a) ≤ 1 := by
+    intro a
+    rw [LaurentSeries.val_le_one_iff_eq_coe]
+    exact ⟨PowerSeries.C a, by rw [HahnSeries.ofPowerSeries_C, LaurentSeries.algebraMap_apply]⟩
+  have hk1 : ∀ a : ℂ, a ≠ 0 → Valued.v (algebraMap ℂ (LaurentSeries ℂ) a) = 1 := by
+    intro a ha
+    apply le_antisymm (hk a)
+    have h := hk a⁻¹
+    rw [map_inv₀, map_inv₀] at h
+    have hpos : 0 < Valued.v (algebraMap ℂ (LaurentSeries ℂ) a) := by
+      rw [Valuation.pos_iff]; exact (_root_.map_ne_zero _).mpr ha
+    exact (inv_le_one₀ hpos).mp h
+  have hc' : c ∈ ℂ⟮jK⁻¹⟯ := by
+    have hle : ℂ⟮jK⟯ ≤ ℂ⟮jK⁻¹⟯ := by
+      rw [IntermediateField.adjoin_simple_le_iff]
+      have := inv_mem (IntermediateField.mem_adjoin_simple_self ℂ jK⁻¹)
+      rwa [inv_inv] at this
+    exact hle hc
+  obtain ⟨p₀, r₀, hc₀⟩ := (IntermediateField.mem_adjoin_simple_iff ℂ c).mp hc'
+  obtain ⟨p, r, hpr, hcase⟩ :=
+    N3Prep.exists_aeval_div_aeval_eq jK⁻¹ (inv_ne_zero hjK0) r₀.natDegree p₀ r₀ le_rfl
+  rw [hpr] at hc₀
+  rcases hcase with hr | hp | hr
+  · refine ⟨0, 1, by simp, ?_⟩
+    rw [hc₀, hr]; simp
+  · by_cases hr0 : r.coeff 0 = 0
+    · by_cases hrz : aeval jK⁻¹ r = 0
+      · refine ⟨0, 1, by simp, ?_⟩
+        rw [hc₀, hrz]; simp
+      · exfalso
+        have hEc : E c = aeval (E jK⁻¹) p / aeval (E jK⁻¹) r := by
+          rw [hc₀, map_div₀, Polynomial.aeval_algHom_apply, Polynomial.aeval_algHom_apply]
+        have h1 : Valued.v (aeval (E jK⁻¹) p) = 1 := N3Prep.val_aeval_eq_one _ hk hk1 hvT hp
+        have h2 : Valued.v (aeval (E jK⁻¹) r) < 1 := N3Prep.val_aeval_lt_one _ hk hvT hr0
+        have h3 : Valued.v (aeval (E jK⁻¹) r) ≠ 0 := by
+          rw [Valuation.ne_zero_iff, Polynomial.aeval_algHom_apply]
+          exact (_root_.map_ne_zero E).mpr hrz
+        have : 1 < Valued.v (E c) := by
+          rw [hEc, map_div₀, h1, one_div]
+          exact (one_lt_inv₀ (zero_lt_iff.mpr h3)).mpr h2
+        exact not_lt_of_ge hpole this
+    · exact ⟨p, r, hr0, hc₀⟩
+  · exact ⟨p, r, hr, hc₀⟩
+
+theorem N3Prep.exists_monic_eval_eq_zero_coeff_mem_fixedField
+    {F K L : Type*} [Field F] [Field K] [Algebra F K] [Field L] [Algebra F L]
+    (H : Subgroup (K ≃ₐ[F] K)) [Finite H] (z : K) (E : K →ₐ[F] L) (S : Subring L)
+    (hS : ∀ h : H, E ((h : K ≃ₐ[F] K) z) ∈ S) :
+    ∃ P : K[X], P.Monic ∧ P.eval z = 0 ∧
+      (∀ i, P.coeff i ∈ IntermediateField.fixedField H) ∧ ∀ i, E (P.coeff i) ∈ S := by
+  classical
+  have : Fintype H := Fintype.ofFinite H
+  refine ⟨∏ h : H, (X - C ((h : K ≃ₐ[F] K) z)), ?_, ?_, ?_, ?_⟩
+  · exact monic_prod_of_monic _ _ fun h _ => monic_X_sub_C _
+  · rw [eval_prod]
+    apply Finset.prod_eq_zero (Finset.mem_univ (1 : H))
+    simp
+  · intro i
+    rw [IntermediateField.mem_fixedField_iff]
+    intro g hg
+    have hmap : (∏ h : H, (X - C ((h : K ≃ₐ[F] K) z))).map (g : K →+* K) =
+        ∏ h : H, (X - C ((h : K ≃ₐ[F] K) z)) := by
+      rw [Polynomial.map_prod]
+      simp only [Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C, RingHom.coe_coe]
+      exact Fintype.prod_bijective (fun h : H => (⟨g, hg⟩ : H) * h) (Group.mulLeft_bijective _)
+        _ _ fun h => rfl
+    have := congrArg (fun P : K[X] => P.coeff i) hmap
+    simpa only [Polynomial.coeff_map, RingHom.coe_coe] using this
+  · intro i
+    set Q : S[X] := ∏ h : H, (X - C (⟨E ((h : K ≃ₐ[F] K) z), hS h⟩ : S)) with hQ
+    have hmapE : (∏ h : H, (X - C ((h : K ≃ₐ[F] K) z))).map (E : K →+* L) = Q.map S.subtype := by
+      rw [hQ, Polynomial.map_prod, Polynomial.map_prod]
+      simp only [Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C, RingHom.coe_coe,
+        Subring.subtype_apply]
+    have h1 : E ((∏ h : H, (X - C ((h : K ≃ₐ[F] K) z))).coeff i) = (Q.map S.subtype).coeff i := by
+      rw [← hmapE, Polynomial.coeff_map, RingHom.coe_coe]
+    rw [h1, Polynomial.coeff_map]
+    exact (Q.coeff i).2
+
+theorem solution
+    (M : ℕ) [NeZero M]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring M) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring M) K]
+    [IsFractionRing (ModularCurve.LevelN.ring M) K]
+    (σ : SL(2, ℤ) →* (K ≃ₐ[ℂ] K))
+    (hker : σ.ker = CongruenceSubgroup.Gamma M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)))
+    (hfixed : IntermediateField.fixedField σ.range =
+      IntermediateField.adjoin ℂ
+        ({algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)} : Set K))
+    (E : K →ₐ[ℂ] LaurentSeries ℂ)
+    (hEj : E (algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)) =
+      ModularCurve.qExpand ℂ M (ModularCurve.jqModC ℂ))
+    (z : K) (hz : ∀ γ : SL(2, ℤ), Valued.v (E (σ γ z)) ≤ 1) :
+    ∃ P : K[X], P.Monic ∧ P.eval z = 0 ∧
+      ∀ i : ℕ, ∃ p q : ℂ[X], q.coeff 0 ≠ 0 ∧
+        P.coeff i =
+          aeval (algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M))⁻¹ p /
+            aeval (algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M))⁻¹ q := by
+  classical
+  have : σ.ker.FiniteIndex := by
+    rw [hker]; exact Subgroup.finiteIndex_of_le le_sup_left
+  have : Finite σ.range :=
+    Finite.of_equiv _ (QuotientGroup.quotientKerEquivRange σ).toEquiv
+  obtain ⟨P, hPm, hPz, hPfix, hPint⟩ :=
+    N3Prep.exists_monic_eval_eq_zero_coeff_mem_fixedField σ.range z E
+      (Valued.v (R := LaurentSeries ℂ)).integer (by
+        rintro ⟨h, γ, rfl⟩
+        exact (Valuation.mem_integer_iff _ _).mpr (hz γ))
+  refine ⟨P, hPm, hPz, fun i => ?_⟩
+  exact valinf_draft M K E hEj (P.coeff i) (hfixed ▸ hPfix i)
+    ((Valuation.mem_integer_iff _ _).mp (hPint i))
+
+end S_OVERLONG_b34f3d51
+end P2MW
+export
+  P2MW.S_OVERLONG_b34f3d51
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Polynomial
+open scoped MatrixGroups
+theorem
+  ModularCurve.LevelN.exists_monic_eval_eq_zero_coeff_eq_aeval_inv_div_of_forall_valuation_le_one
+    (M : ℕ) [NeZero M]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring M) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring M) K]
+    [IsFractionRing (ModularCurve.LevelN.ring M) K]
+    (σ : SL(2, ℤ) →* (K ≃ₐ[ℂ] K))
+    (hker : σ.ker = CongruenceSubgroup.Gamma M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)))
+    (hfixed : IntermediateField.fixedField σ.range =
+      IntermediateField.adjoin ℂ
+        ({algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)} : Set K))
+    (E : K →ₐ[ℂ] LaurentSeries ℂ)
+    (hEj : E (algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)) =
+      ModularCurve.qExpand ℂ M (ModularCurve.jqModC ℂ))
+    (z : K) (hz : ∀ γ : SL(2, ℤ), Valued.v (E (σ γ z)) ≤ 1) :
+    ∃ P : K[X], P.Monic ∧ P.eval z = 0 ∧
+      ∀ i : ℕ, ∃ p q : ℂ[X], q.coeff 0 ≠ 0 ∧
+        P.coeff i =
+          aeval (algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M))⁻¹ p /
+            aeval (algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M))⁻¹ q :=
+  solution M K σ hker hfixed E hEj z hz
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_monoidHom_algEquiv_fixedField_eq_adjoin.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_monoidHom_algEquiv_fixedField_eq_adjoin.lean
new file mode 100644
index 0000000000..a33388e1ad
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_monoidHom_algEquiv_fixedField_eq_adjoin.lean
@@ -0,0 +1,567 @@
+/-
+Based on Prove2Me node ModularCurve.LevelN.exists_monoidHom_algEquiv_fixedField_eq_adjoin
+(05254901-c2d0-58c4-921f-8fa611dadbd3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7e7f48c7-04f5-5ade-a712-5cfe259aa413
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LevelNFunctionField
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_modularity_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelN_structure_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Galois structure of the level-N modular function field
+
+Theorem statement: `ModularCurve.LevelN.exists_monoidHom_algEquiv_fixedField_eq_adjoin`
+(`05254901-c2d0-58c4-921f-8fa611dadbd3`), by Claude, 2026-09-05.
+
+Proof: submission `7e7f48c7-04f5-5ade-a712-5cfe259aa413`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a non-zero natural number and let $A_N$ denote [`ModularCurve.LevelN.ring
+N`](def/ModularCurve_LevelNFunctionField.html#L28), the $\mathbb{C}$-subalgebra of the algebra of
+all functions $\mathfrak{H} \to \mathbb{C}$ generated by $j = E_4^3/\Delta$ (written `jAnalytic`)
+together with the functions `fricke N v` for the non-zero $v \in (\mathbb{Z}/N)^2$. Let $K$ be a
+field carrying compatible $\mathbb{C}$- and $A_N$-algebra structures (a scalar tower $\mathbb{C} \to
+A_N \to K$) and which is a fraction field of $A_N$. The assertion is the existence of a proof `hst`
+that $A_N$ is stable under $F \mapsto (\tau \mapsto F(\gamma \cdot \tau))$ for every $\gamma \in
+\mathrm{SL}_2(\mathbb{Z})$, and of a group homomorphism $\sigma : \mathrm{SL}_2(\mathbb{Z}) \to (K
+\simeq_{\mathbb{C}} K)$ into the $\mathbb{C}$-algebra automorphisms of $K$, such that:
+$\sigma_\gamma$ sends the image in $K$ of $F \in A_N$ to the image of $\tau \mapsto F(\gamma^{-1}
+\cdot \tau)$; the kernel of $\sigma$ is the subgroup generated by $\Gamma(N)$ and $-1$; the fixed
+field of the range of $\sigma$ is the intermediate field $\mathbb{C}$-generated by the image of $j$
+(`jGen N`); that image is transcendental over $\mathbb{C}$; $K$ is finite-dimensional over
+$\mathbb{C}(j)$ of degree equal to the index of $\Gamma(N) \sqcup \langle -1 \rangle$ in
+$\mathrm{SL}_2(\mathbb{Z})$; and $K/\mathbb{C}(j)$ is Galois.
+
+This is the classical description of the function field of the modular curve $X(N)$ over
+$\mathbb{C}$: it is a Galois extension of $\mathbb{C}(j) = \mathbb{C}(X(1))$ with group
+$\mathrm{SL}_2(\mathbb{Z})/\pm\Gamma(N)$ acting by $F \mapsto F \circ \gamma^{-1}$. It underlies the
+later counting of fibres and double cosets and the genus estimates for the level-$N$ function field,
+such as
+[`ModularCurve.LevelN.twelve_mul_add_mul_index_le_genusFF`]
+(thm.html#ModularCurve.LevelN.twelve_mul_add_mul_index_le_genusFF)
+and
+[`ModularCurve.natCard_doubleCoset_le_card_fibres_of_finrank_eq_index`]
+(thm.html#ModularCurve.natCard_doubleCoset_le_card_fibres_of_finrank_eq_index).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_LevelN_exists_monoidHom_algEquiv_fixedField_eq_adjoin.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_LevelN_exists_monoidHom_algEquiv_fixedField_eq_adjoin
+
+
+open UpperHalfPlane
+open scoped MatrixGroups
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "LevelN.ring LevelN.jGen"
+namespace LevelN
+p2m_export "ModularCurve.LevelN" "wp fricke jAnalytic generators ring jAnalytic_mem fricke_mem \
+  jGen coe_jGen"
+namespace GaloisStructure
+p2m_open "ModularCurve.LevelN ModularCurve"
+
+variable (N : ℕ)
+
+abbrev Gpm : Subgroup SL(2, ℤ) := CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))
+
+scoped instance zpowers_neg_one_normal : (Subgroup.zpowers (-1 : SL(2, ℤ))).Normal :=
+  ⟨fun n hn g => by
+    obtain ⟨k, rfl⟩ := Subgroup.mem_zpowers_iff.mp hn
+    have hc : Commute g ((-1 : SL(2, ℤ)) ^ k) := (Commute.neg_one_right g).zpow_right k
+    rw [hc.eq, mul_inv_cancel_right]
+    exact Subgroup.zpow_mem _ (Subgroup.mem_zpowers _) k⟩
+
+theorem neg_one_mem_Gpm : (-1 : SL(2, ℤ)) ∈ Gpm N :=
+  Subgroup.mem_sup_right (Subgroup.mem_zpowers _)
+
+theorem mem_Gpm_of_mem {g : SL(2, ℤ)} (hg : g ∈ CongruenceSubgroup.Gamma N) : g ∈ Gpm N :=
+  Subgroup.mem_sup_left hg
+
+theorem neg_mem_Gpm {g : SL(2, ℤ)} (hg : g ∈ Gpm N) : -g ∈ Gpm N := by
+  rw [← neg_one_mul]; exact (Gpm N).mul_mem (neg_one_mem_Gpm N) hg
+
+theorem exists_of_mem_Gpm {g : SL(2, ℤ)} (hg : g ∈ Gpm N) :
+    ∃ γ : SL(2, ℤ), γ ∈ CongruenceSubgroup.Gamma N ∧ (g = γ ∨ g = -γ) := by
+  obtain ⟨y, hy, z, hz, rfl⟩ := Subgroup.mem_sup_of_normal_right.mp hg
+  obtain ⟨k, rfl⟩ := Subgroup.mem_zpowers_iff.mp hz
+  refine ⟨y, hy, ?_⟩
+  have h2 : ((-1 : SL(2, ℤ)) ^ (2 : ℤ)) = 1 := by rw [zpow_two]; simp
+  rcases Int.even_or_odd k with ⟨m, rfl⟩ | ⟨m, rfl⟩
+  · left
+    rw [← two_mul, zpow_mul, h2, one_zpow, mul_one]
+  · right
+    rw [zpow_add, zpow_mul, h2, one_zpow, one_mul, zpow_one, mul_neg_one]
+
+theorem mem_Gpm_iff (g : SL(2, ℤ)) :
+    g ∈ Gpm N ↔ g ∈ CongruenceSubgroup.Gamma N ∨ -g ∈ CongruenceSubgroup.Gamma N := by
+  constructor
+  · intro hg
+    obtain ⟨γ, hγ, h | h⟩ := exists_of_mem_Gpm N hg
+    · left; rwa [h]
+    · right; rw [h, neg_neg]; exact hγ
+  · rintro (h | h)
+    · exact mem_Gpm_of_mem N h
+    · have := neg_mem_Gpm N (mem_Gpm_of_mem N h)
+      rwa [neg_neg] at this
+
+scoped instance Gpm_finiteIndex [NeZero N] : (Gpm N).FiniteIndex :=
+  Subgroup.finiteIndex_of_le (le_sup_left : CongruenceSubgroup.Gamma N ≤ Gpm N)
+
+abbrev redMat (γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) (ZMod N) :=
+  (γ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N)
+
+variable [NeZero N]
+
+theorem fixer_eq :
+    {γ : SL(2, ℤ) | ∀ v : Fin 2 → ZMod N, v ≠ 0 →
+        fricke N (Matrix.vecMul v (redMat N γ)) = fricke N v} =
+      {γ : SL(2, ℤ) | γ ∈ CongruenceSubgroup.Gamma N ∨ -γ ∈ CongruenceSubgroup.Gamma N} := by
+  have h := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact h.1
+
+theorem invariant_fraction (a b : ℍ → ℂ) (ha : a ∈ ring N) (hb : b ∈ ring N) (hb0 : b ≠ 0)
+    (hinv : ∀ γ : SL(2, ℤ), a * (b ∘ (γ • ·)) = (a ∘ (γ • ·)) * b) :
+    ∃ p q : Polynomial ℂ, q ≠ 0 ∧
+      a * (fun τ => q.eval (jAnalytic τ)) = b * (fun τ => p.eval (jAnalytic τ)) := by
+  have h := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact h.2.1 a b ha hb hb0 hinv
+
+omit [NeZero N] in
+theorem eq_zero_of_eval_jAnalytic (P : Polynomial ℂ) (hP : ∀ τ : ℍ, P.eval (jAnalytic τ) = 0) :
+    P = 0 := by
+  have h := WLight.levelN_structure_package 1 PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp 1)
+    (fun v τ => rfl) (fricke 1) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact h.2.2.2.1 P hP
+
+theorem fricke_smul (v : Fin 2 → ZMod N) (γ : SL(2, ℤ)) (τ : ℍ) :
+    fricke N v (γ • τ) = fricke N (Matrix.vecMul v (redMat N γ)) τ :=
+  (WLight.frickeFunction_modularity_package N PeriodPair.ofTau
+    (by simp [PeriodPair.ofTau])).1 v γ τ
+
+omit [NeZero N] in
+theorem jAnalytic_smul (γ : SL(2, ℤ)) (τ : ℍ) : jAnalytic (γ • τ) = jAnalytic τ := by
+  have hmem : (γ : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ, rfl⟩
+  have h4 : (ModularForm.E₄ : ℍ → ℂ) ((γ : GL (Fin 2) ℝ) • τ) =
+      denom (γ : GL (Fin 2) ℝ) τ ^ (4 : ℤ) * ModularForm.E₄ τ :=
+    SlashInvariantForm.slash_action_eqn'' _ hmem τ
+  have h12 : ModularForm.discriminant ((γ : GL (Fin 2) ℝ) • τ) =
+      denom (γ : GL (Fin 2) ℝ) τ ^ (12 : ℤ) * ModularForm.discriminant τ := by
+    have := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hmem τ
+    simpa using this
+  have hd : denom (γ : GL (Fin 2) ℝ) τ ≠ 0 := denom_ne_zero _ _
+  have hΔ : ModularForm.discriminant τ ≠ 0 := ModularForm.discriminant_ne_zero τ
+  rw [jAnalytic, jAnalytic, ModularGroup.sl_moeb, h4, h12]
+  field_simp
+
+omit [NeZero N] in
+theorem vecMul_ne_zero {v : Fin 2 → ZMod N} (hv : v ≠ 0) (γ : SL(2, ℤ)) :
+    Matrix.vecMul v (redMat N γ) ≠ 0 := by
+  intro h
+  apply hv
+  have hdet : (redMat N γ).det = 1 := by
+    have := congrArg ((↑) : ℤ → ZMod N) γ.2
+    rw [Int.cast_one] at this
+    rw [← this, redMat]
+    exact (RingHom.map_det (Int.castRingHom (ZMod N)) _).symm
+  have hunit : IsUnit (redMat N γ).det := by rw [hdet]; exact isUnit_one
+  have := congrArg (fun w => Matrix.vecMul w (redMat N γ)⁻¹) h
+  simp only [Matrix.vecMul_vecMul, Matrix.mul_nonsing_inv _ hunit, Matrix.vecMul_one,
+    Matrix.zero_vecMul] at this
+  exact this
+
+omit [NeZero N] in
+def precomp (g : SL(2, ℤ)) : (ℍ → ℂ) →ₐ[ℂ] (ℍ → ℂ) :=
+  AlgHom.pi (fun τ => Pi.evalAlgHom ℂ (fun _ : ℍ => ℂ) (g • τ))
+
+omit [NeZero N] in
+@[scoped simp]
+theorem precomp_apply (g : SL(2, ℤ)) (F : ℍ → ℂ) (τ : ℍ) : precomp g F τ = F (g • τ) := rfl
+
+theorem precomp_mem (g : SL(2, ℤ)) {F : ℍ → ℂ} (hF : F ∈ ring N) : precomp g F ∈ ring N := by
+  have hle : (ring N).map (precomp g) ≤ ring N := by
+    rw [ring, AlgHom.map_adjoin, Algebra.adjoin_le_iff]
+    rintro _ ⟨G, hG, rfl⟩
+    rcases hG with rfl | ⟨v, hv, rfl⟩
+    · have : precomp g jAnalytic = jAnalytic := funext fun τ => jAnalytic_smul g τ
+      rw [this]
+      exact jAnalytic_mem N
+    · have : precomp g (fricke N v) = fricke N (Matrix.vecMul v (redMat N g)) :=
+        funext fun τ => fricke_smul N v g τ
+      rw [this]
+      exact fricke_mem N (vecMul_ne_zero N hv g)
+  exact hle ⟨F, hF, rfl⟩
+
+theorem comp_smul_mem (g : SL(2, ℤ)) {F : ℍ → ℂ} (hF : F ∈ ring N) :
+    (fun τ : ℍ => F (g • τ)) ∈ ring N :=
+  precomp_mem N g hF
+
+def res (g : SL(2, ℤ)) : ring N →ₐ[ℂ] ring N :=
+  ((precomp g).comp (ring N).val).codRestrict (ring N) fun F => precomp_mem N g F.2
+
+@[scoped simp]
+theorem coe_res_apply (g : SL(2, ℤ)) (F : ring N) (τ : ℍ) :
+    ((res N g F : ring N) : ℍ → ℂ) τ = (F : ℍ → ℂ) (g • τ) := rfl
+
+theorem res_comp (g h : SL(2, ℤ)) : (res N g).comp (res N h) = res N (h * g) := by
+  ext F τ
+  simp [mul_smul]
+
+theorem res_one : res N 1 = AlgHom.id ℂ (ring N) := by
+  ext F τ
+  simp
+
+def ρ (γ : SL(2, ℤ)) : ring N ≃ₐ[ℂ] ring N :=
+  AlgEquiv.ofAlgHom (res N γ⁻¹) (res N γ)
+    (by rw [res_comp, mul_inv_cancel, res_one])
+    (by rw [res_comp, inv_mul_cancel, res_one])
+
+@[scoped simp]
+theorem coe_ρ_apply (γ : SL(2, ℤ)) (F : ring N) (τ : ℍ) :
+    ((ρ N γ F : ring N) : ℍ → ℂ) τ = (F : ℍ → ℂ) (γ⁻¹ • τ) := rfl
+
+def ρHom : SL(2, ℤ) →* (ring N ≃ₐ[ℂ] ring N) where
+  toFun := ρ N
+  map_one' := by
+    ext F τ
+    simp
+  map_mul' γ δ := by
+    ext F τ
+    simp [mul_smul]
+
+@[scoped simp]
+theorem coe_ρHom_apply (γ : SL(2, ℤ)) (F : ring N) (τ : ℍ) :
+    ((ρHom N γ F : ring N) : ℍ → ℂ) τ = (F : ℍ → ℂ) (γ⁻¹ • τ) := rfl
+
+section FractionField
+
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ring N) K] [IsScalarTower ℂ (ring N) K]
+  [IsFractionRing (ring N) K]
+
+def σHom : SL(2, ℤ) →* (K ≃ₐ[ℂ] K) :=
+  (IsFractionRing.fieldEquivOfAlgEquivHom ℂ K).comp (ρHom N)
+
+theorem σHom_algebraMap (γ : SL(2, ℤ)) (F : ring N) :
+    σHom N K γ (algebraMap (ring N) K F) = algebraMap (ring N) K (ρHom N γ F) := by
+  simp [σHom]
+
+theorem σHom_algebraMap' (γ : SL(2, ℤ)) (F : ℍ → ℂ) (hF : F ∈ ring N) :
+    σHom N K γ (algebraMap (ring N) K ⟨F, hF⟩) =
+      algebraMap (ring N) K ⟨fun τ : ℍ => F (γ⁻¹ • τ), comp_smul_mem N γ⁻¹ hF⟩ := by
+  rw [σHom_algebraMap]
+  rfl
+
+theorem ker_σHom : (σHom N K).ker = (ρHom N).ker := by
+  rw [σHom, ← MonoidHom.comap_ker,
+    (MonoidHom.ker_eq_bot_iff _).mpr (IsFractionRing.fieldEquivOfAlgEquivHom_injective ℂ (ring N) ℂ
+    K),
+    MonoidHom.comap_bot]
+
+omit [NeZero N] in
+theorem algHom_eq_id_of_forall {φ : ring N →ₐ[ℂ] ring N}
+    (h : ∀ (G : ℍ → ℂ) (hG : G ∈ generators N), φ ⟨G, Algebra.subset_adjoin hG⟩ =
+      ⟨G, Algebra.subset_adjoin hG⟩) : φ = AlgHom.id ℂ (ring N) := by
+  ext1 F
+  obtain ⟨F, hF⟩ := F
+  change F ∈ Algebra.adjoin ℂ (generators N) at hF
+  induction hF using Algebra.adjoin_induction with
+  | mem x hx => exact h x hx
+  | algebraMap c =>
+      have : (⟨algebraMap ℂ (ℍ → ℂ) c, _⟩ : ring N) = algebraMap ℂ (ring N) c := rfl
+      rw [this, AlgHom.commutes]; rfl
+  | add x y hx hy ihx ihy =>
+      have : (⟨x + y, _⟩ : ring N) = ⟨x, hx⟩ + ⟨y, hy⟩ := rfl
+      rw [this, map_add, ihx, ihy]; rfl
+  | mul x y hx hy ihx ihy =>
+      have : (⟨x * y, _⟩ : ring N) = ⟨x, hx⟩ * ⟨y, hy⟩ := rfl
+      rw [this, map_mul, ihx, ihy]; rfl
+
+theorem ρHom_eq_one_iff (γ : SL(2, ℤ)) :
+    ρHom N γ = 1 ↔
+      ∀ v : Fin 2 → ZMod N, v ≠ 0 → fricke N (Matrix.vecMul v (redMat N γ⁻¹)) = fricke N v := by
+  constructor
+  · intro h v hv
+    have hF :=
+      congrArg (fun e : ring N ≃ₐ[ℂ] ring N => ((e ⟨fricke N v, fricke_mem N hv⟩ : ring N) : ℍ → ℂ))
+        h
+    funext τ
+    have := congrFun hF τ
+    change fricke N v (γ⁻¹ • τ) = fricke N v τ at this
+    rwa [fricke_smul] at this
+  · intro h
+    apply AlgEquiv.coe_toAlgHom_injective
+    change (res N γ⁻¹ : ring N →ₐ[ℂ] ring N) = AlgHom.id ℂ (ring N)
+    refine algHom_eq_id_of_forall N fun G hG => ?_
+    apply Subtype.ext
+    funext τ
+    change G (γ⁻¹ • τ) = G τ
+    rcases hG with rfl | ⟨v, hv, rfl⟩
+    · exact jAnalytic_smul γ⁻¹ τ
+    · rw [fricke_smul, h v hv]
+
+theorem ker_ρHom : (ρHom N).ker = Gpm N := by
+  ext γ
+  rw [MonoidHom.mem_ker, ρHom_eq_one_iff]
+  have hset := fixer_eq N
+  have hmem : γ⁻¹ ∈ {γ : SL(2, ℤ) | ∀ v : Fin 2 → ZMod N, v ≠ 0 →
+      fricke N (Matrix.vecMul v (redMat N γ)) = fricke N v} ↔
+      γ⁻¹ ∈ {γ : SL(2, ℤ) | γ ∈ CongruenceSubgroup.Gamma N ∨ -γ ∈ CongruenceSubgroup.Gamma N} := by
+    rw [hset]
+  simp only [Set.mem_ofPred_eq] at hmem
+  rw [hmem, ← mem_Gpm_iff, inv_mem_iff]
+
+theorem ker_σHom_eq : (σHom N K).ker = Gpm N := by
+  rw [ker_σHom, ker_ρHom]
+
+abbrev jK : K := algebraMap (ring N) K (jGen N)
+
+theorem ρHom_jGen (γ : SL(2, ℤ)) : ρHom N γ (jGen N) = jGen N := by
+  apply Subtype.ext
+  funext τ
+  change jAnalytic (γ⁻¹ • τ) = jAnalytic τ
+  exact jAnalytic_smul γ⁻¹ τ
+
+theorem σHom_jK (γ : SL(2, ℤ)) : σHom N K γ (jK N K) = jK N K := by
+  change σHom N K γ (algebraMap (ring N) K (jGen N)) = algebraMap (ring N) K (jGen N)
+  rw [σHom_algebraMap, ρHom_jGen]
+
+omit [NeZero N] in
+theorem coe_aeval_jGen (p : Polynomial ℂ) (τ : ℍ) :
+    ((Polynomial.aeval (jGen N) p : ring N) : ℍ → ℂ) τ = p.eval (jAnalytic τ) := by
+  have h1 : ((Polynomial.aeval (jGen N) p : ring N) : ℍ → ℂ) =
+      Polynomial.aeval (jAnalytic) p := by
+    rw [← coe_jGen N, ← Subalgebra.coe_val, ← Polynomial.aeval_algHom_apply]
+  rw [h1]
+  have h2 : (Polynomial.aeval jAnalytic p) τ =
+      Pi.evalAlgHom ℂ (fun _ : ℍ => ℂ) τ (Polynomial.aeval jAnalytic p) := rfl
+  rw [h2, ← Polynomial.aeval_algHom_apply, Polynomial.coe_aeval_eq_eval]
+  rfl
+
+omit [NeZero N] in
+theorem transcendental_jK : Transcendental ℂ (jK N K) := by
+  rw [transcendental_iff]
+  intro P hP
+  apply eq_zero_of_eval_jAnalytic P
+  intro τ
+  change Polynomial.aeval (algebraMap (ring N) K (jGen N)) P = 0 at hP
+  rw [Polynomial.aeval_algebraMap_apply,
+    map_eq_zero_iff _ (IsFractionRing.injective (ring N) K)] at hP
+  rw [← coe_aeval_jGen N P τ, hP]
+  rfl
+
+omit [NeZero N] in
+theorem aeval_jK_ne_zero {q : Polynomial ℂ} (hq : q ≠ 0) : Polynomial.aeval (jK N K) q ≠ 0 :=
+  fun h => hq ((transcendental_iff.mp (transcendental_jK N K)) q h)
+
+theorem fixedField_eq :
+    IntermediateField.fixedField (σHom N K).range =
+      IntermediateField.adjoin ℂ ({jK N K} : Set K) := by
+  apply le_antisymm
+  · intro x hx
+    rw [IntermediateField.mem_fixedField_iff] at hx
+    obtain ⟨a, b, hb, rfl⟩ := IsFractionRing.div_surjective (A := ring N) x
+    have hb0 : (b : ℍ → ℂ) ≠ 0 := by
+      intro h
+      have : b = 0 := Subtype.ext h
+      rw [this] at hb
+      exact zero_notMem_nonZeroDivisors hb
+    have hbK : algebraMap (ring N) K b ≠ 0 :=
+      IsFractionRing.to_map_ne_zero_of_mem_nonZeroDivisors hb
+    have hinv : ∀ γ : SL(2, ℤ), (a : ℍ → ℂ) * ((b : ℍ → ℂ) ∘ (γ • ·)) =
+        ((a : ℍ → ℂ) ∘ (γ • ·)) * (b : ℍ → ℂ) := by
+      intro γ
+      have h := hx (σHom N K γ⁻¹) ⟨γ⁻¹, rfl⟩
+      rw [map_div₀, σHom_algebraMap, σHom_algebraMap, div_eq_div_iff _ hbK] at h
+      · rw [← map_mul, ← map_mul] at h
+        have h' := IsFractionRing.injective (ring N) K h
+        have h'' := congrArg (fun F : ring N => (F : ℍ → ℂ)) h'
+        simp only [Subalgebra.coe_mul] at h''
+        funext τ
+        have := congrFun h'' τ
+        simp only [Pi.mul_apply, coe_ρHom_apply, inv_inv, Function.comp_apply] at this ⊢
+        rw [this]
+      · rw [map_ne_zero_iff _ (IsFractionRing.injective (ring N) K)]
+        intro h0
+        apply hb0
+        have h1 := congrArg (fun F : ring N => (F : ℍ → ℂ)) h0
+        simp only [ZeroMemClass.coe_zero] at h1
+        funext τ
+        have := congrFun h1 (γ⁻¹ • τ)
+        simp only [coe_ρHom_apply, Pi.zero_apply, inv_inv, smul_inv_smul] at this
+        exact this
+    obtain ⟨p, q, hq, hpq⟩ := invariant_fraction N a b a.2 b.2 hb0 hinv
+    have hqK : Polynomial.aeval (jK N K) q ≠ 0 := aeval_jK_ne_zero N K hq
+    have hab : algebraMap (ring N) K a / algebraMap (ring N) K b =
+        Polynomial.aeval (jK N K) p / Polynomial.aeval (jK N K) q := by
+      rw [div_eq_div_iff hbK hqK]
+      change algebraMap (ring N) K a * Polynomial.aeval (algebraMap (ring N) K (jGen N)) q =
+        Polynomial.aeval (algebraMap (ring N) K (jGen N)) p * algebraMap (ring N) K b
+      rw [Polynomial.aeval_algebraMap_apply, Polynomial.aeval_algebraMap_apply, ← map_mul,
+        ← map_mul]
+      congr 1
+      apply Subtype.ext
+      funext τ
+      have := congrFun hpq τ
+      simp only [Pi.mul_apply] at this
+      simp only [Subalgebra.coe_mul, Pi.mul_apply, coe_aeval_jGen]
+      rw [this, mul_comm]
+    rw [hab]
+    exact div_mem
+      (IntermediateField.algebra_adjoin_le_adjoin ℂ _ (Polynomial.aeval_mem_adjoin_singleton ℂ _))
+      (IntermediateField.algebra_adjoin_le_adjoin ℂ _ (Polynomial.aeval_mem_adjoin_singleton ℂ _))
+  · rw [IntermediateField.adjoin_le_iff, Set.singleton_subset_iff, SetLike.mem_coe,
+      IntermediateField.mem_fixedField_iff]
+    rintro _ ⟨γ, rfl⟩
+    exact σHom_jK N K γ
+
+theorem finite_range : Finite (σHom N K).range := by
+  have h := Subgroup.index_ker (σHom N K)
+  rw [ker_σHom_eq] at h
+  exact Nat.finite_of_card_ne_zero (h ▸ Subgroup.FiniteIndex.index_ne_zero)
+
+theorem natCard_range : Nat.card (σHom N K).range = (Gpm N).index := by
+  rw [← ker_σHom_eq N K, Subgroup.index_ker]
+
+theorem isGalois_fixedField : IsGalois (IntermediateField.fixedField (σHom N K).range) K := by
+  have := finite_range N K
+  exact IsGalois.of_fixed_field K (σHom N K).range
+
+theorem finrank_fixedField :
+    Module.finrank (IntermediateField.fixedField (σHom N K).range) K = (Gpm N).index := by
+  have := finite_range N K
+  have := Fintype.ofFinite (σHom N K).range
+  rw [← natCard_range N K, Nat.card_eq_fintype_card]
+  exact FixedPoints.finrank_eq_card (σHom N K).range K
+
+theorem finiteDimensional_fixedField :
+    FiniteDimensional (IntermediateField.fixedField (σHom N K).range) K := by
+  apply Module.finite_of_finrank_pos
+  rw [finrank_fixedField]
+  exact Nat.pos_of_ne_zero Subgroup.FiniteIndex.index_ne_zero
+
+theorem main :
+    ∃ (hst : ∀ γ : SL(2, ℤ), ∀ F ∈ ModularCurve.LevelN.ring N,
+        (fun τ : UpperHalfPlane => F (γ • τ)) ∈ ModularCurve.LevelN.ring N)
+      (σ : SL(2, ℤ) →* (K ≃ₐ[ℂ] K)),
+      (∀ (γ : SL(2, ℤ)) (F : UpperHalfPlane → ℂ) (hF : F ∈ ModularCurve.LevelN.ring N),
+          σ γ (algebraMap (ModularCurve.LevelN.ring N) K ⟨F, hF⟩) =
+            algebraMap (ModularCurve.LevelN.ring N) K
+              ⟨fun τ : UpperHalfPlane => F (γ⁻¹ • τ), hst γ⁻¹ F hF⟩) ∧
+      σ.ker = CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) ∧
+      IntermediateField.fixedField σ.range =
+        IntermediateField.adjoin ℂ
+          ({algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)} : Set K) ∧
+      Transcendental ℂ (algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)) ∧
+      FiniteDimensional
+          (IntermediateField.adjoin ℂ
+            ({algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)} : Set K)) K ∧
+      Module.finrank
+          (IntermediateField.adjoin ℂ
+            ({algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)} : Set K)) K =
+        (CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index ∧
+      IsGalois
+          (IntermediateField.adjoin ℂ
+            ({algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)} : Set K)) K
+              := by
+  refine ⟨fun γ F hF => comp_smul_mem N γ hF, σHom N K, fun γ F hF => σHom_algebraMap' N K γ F hF,
+    ker_σHom_eq N K, fixedField_eq N K, transcendental_jK N K, ?_, ?_, ?_⟩
+  · rw [← fixedField_eq N K]; exact finiteDimensional_fixedField N K
+  · rw [← fixedField_eq N K]; exact finrank_fixedField N K
+  · rw [← fixedField_eq N K]; exact isGalois_fixedField N K
+
+end FractionField
+
+end ModularCurve.LevelN.GaloisStructure
+end
+
+theorem solution (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring N) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring N) K]
+    [IsFractionRing (ModularCurve.LevelN.ring N) K] :
+    ∃ (hst : ∀ γ : SL(2, ℤ), ∀ F ∈ ModularCurve.LevelN.ring N,
+        (fun τ : UpperHalfPlane => F (γ • τ)) ∈ ModularCurve.LevelN.ring N)
+      (σ : SL(2, ℤ) →* (K ≃ₐ[ℂ] K)),
+      (∀ (γ : SL(2, ℤ)) (F : UpperHalfPlane → ℂ) (hF : F ∈ ModularCurve.LevelN.ring N),
+          σ γ (algebraMap (ModularCurve.LevelN.ring N) K ⟨F, hF⟩) =
+            algebraMap (ModularCurve.LevelN.ring N) K
+              ⟨fun τ : UpperHalfPlane => F (γ⁻¹ • τ), hst γ⁻¹ F hF⟩) ∧
+      σ.ker = CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) ∧
+      IntermediateField.fixedField σ.range =
+        IntermediateField.adjoin ℂ
+          ({algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)} : Set K) ∧
+      Transcendental ℂ (algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)) ∧
+      FiniteDimensional
+          (IntermediateField.adjoin ℂ
+            ({algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)} : Set K)) K ∧
+      Module.finrank
+          (IntermediateField.adjoin ℂ
+            ({algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)} : Set K)) K =
+        (CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index ∧
+      IsGalois
+          (IntermediateField.adjoin ℂ
+            ({algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)} : Set K)) K :=
+  ModularCurve.LevelN.GaloisStructure.main N K
+
+end S_ModularCurve_LevelN_exists_monoidHom_algEquiv_fixedField_eq_adjoin
+end P2MW
+export P2MW.S_ModularCurve_LevelN_exists_monoidHom_algEquiv_fixedField_eq_adjoin (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.LevelN.exists_monoidHom_algEquiv_fixedField_eq_adjoin (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring N) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring N) K]
+    [IsFractionRing (ModularCurve.LevelN.ring N) K] :
+    ∃ (hst : ∀ γ : SL(2, ℤ), ∀ F ∈ ModularCurve.LevelN.ring N,
+        (fun τ : UpperHalfPlane => F (γ • τ)) ∈ ModularCurve.LevelN.ring N)
+      (σ : SL(2, ℤ) →* (K ≃ₐ[ℂ] K)),
+      (∀ (γ : SL(2, ℤ)) (F : UpperHalfPlane → ℂ) (hF : F ∈ ModularCurve.LevelN.ring N),
+          σ γ (algebraMap (ModularCurve.LevelN.ring N) K ⟨F, hF⟩) =
+            algebraMap (ModularCurve.LevelN.ring N) K
+              ⟨fun τ : UpperHalfPlane => F (γ⁻¹ • τ), hst γ⁻¹ F hF⟩) ∧
+      σ.ker = CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) ∧
+      IntermediateField.fixedField σ.range =
+        IntermediateField.adjoin ℂ
+          ({algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)} : Set K) ∧
+      Transcendental ℂ (algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)) ∧
+      FiniteDimensional
+          (IntermediateField.adjoin ℂ
+            ({algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)} : Set K)) K ∧
+      Module.finrank
+          (IntermediateField.adjoin ℂ
+            ({algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)} : Set K)) K =
+        (CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index ∧
+      IsGalois
+          (IntermediateField.adjoin ℂ
+            ({algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)} : Set K)) K :=
+  solution N K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_place_analyticOrderAt_eq_mul_ord.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_place_analyticOrderAt_eq_mul_ord.lean
new file mode 100644
index 0000000000..0645ee465e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_place_analyticOrderAt_eq_mul_ord.lean
@@ -0,0 +1,493 @@
+/-
+Based on Prove2Me node ModularCurve.LevelN.exists_place_analyticOrderAt_eq_mul_ord
+(57fb77d2-1fea-5703-ad43-d794fe9d748e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1c964b08-dabf-5da5-9f08-01096d19e23f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LevelNFunctionField
+
+import Mathlib.Algebra.CharP.Pi
+import Mathlib.Order.CompletePartialOrder
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelN_structure_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Analytic order at τ₀ is e times the order at a place
+
+Theorem statement: `ModularCurve.LevelN.exists_place_analyticOrderAt_eq_mul_ord`
+(`57fb77d2-1fea-5703-ad43-d794fe9d748e`), by Claude, 2026-09-05.
+
+Proof: submission `1c964b08-dabf-5da5-9f08-01096d19e23f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N \geq 1$ and let $A_N$ denote [`ModularCurve.LevelN.ring
+N`](def/ModularCurve_LevelNFunctionField.html#L28), the $\mathbb{C}$-subalgebra of the algebra of
+all functions $\mathbb{H} \to \mathbb{C}$ generated by the set consisting of the function
+`jAnalytic` together with all functions `fricke N v` for $v \colon \mathrm{Fin}\,2 \to \mathbb{Z}/N$
+with $v \neq 0$ (in the packaging theorem invoked, such generators are pinned down by the formulas
+$E_4^3/\Delta$ and $-\tfrac{1}{2592}(E_4E_6/\Delta)\cdot(2\pi i)^{-2}\wp\big((v_0\tau+v_1)/N\big)$
+for the lattice $\mathbb{Z}\tau+\mathbb{Z}$). Let $K$ be a field that is simultaneously a
+$\mathbb{C}$-algebra and an $A_N$-algebra, compatibly (scalar tower $\mathbb{C} \to A_N \to K$), and
+which is a fraction field of $A_N$; let $\tau_0 \in \mathbb{H}$. The assertion is that there exist a
+place $W$ of $K$ over $\mathbb{C}$ — that is, a valuation subring of $K$ containing the image of
+$\mathbb{C}$, different from all of $K$, and a principal ideal ring, with order function
+$\operatorname{ord}_W(f) = -\log$ of the adic valuation attached to its height-one prime — and a
+natural number $e > 0$, both independent of $F$, such that for every $F \colon \mathbb{H} \to
+\mathbb{C}$ lying in $A_N$ and not the zero function, the analytic order of vanishing at $\tau_0 \in
+\mathbb{C}$ of $F \circ \mathrm{ofComplex}$ is not $\top$, and its value as an integer equals $e
+\cdot \operatorname{ord}_W$ of the image of $F$ in $K$.
+
+This compares the local analytic data of level-$N$ modular functions at a point of the upper
+half-plane with the valuation-theoretic data of the function field $\mathbb{C}(X(N))$: the order of
+vanishing at $\tau_0$ is a positive integer multiple of the normalised order at a place of $K$, the
+factor $e$ being classically the ramification index of $\mathbb{H} \to X(N)$ at $\tau_0$. It is used
+in the computations of the order of the $j$-generator at such places, namely
+[`ModularCurve.LevelN.exists_place_ord_jGen_eq_three_two_and_stabilizer_subset_zpowers`]
+(thm.html#ModularCurve.LevelN.exists_place_ord_jGen_eq_three_two_and_stabilizer_subset_zpowers)
+and
+[`ModularCurve.LevelN.exists_place_ord_jGen_le_two_three_level`]
+(thm.html#ModularCurve.LevelN.exists_place_ord_jGen_le_two_three_level).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_LevelN_exists_place_analyticOrderAt_eq_mul_ord.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_LevelN_exists_place_analyticOrderAt_eq_mul_ord
+
+
+open UpperHalfPlane Filter Topology
+open scoped MatrixGroups Manifold
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "LevelN.ring"
+namespace LevelN
+p2m_export "ModularCurve.LevelN" "wp fricke jAnalytic ring jGen"
+namespace AnalyticOrderPlace
+p2m_open "ModularCurve.LevelN ModularCurve"
+
+variable (N : ℕ) [NeZero N]
+
+theorem mdifferentiable_of_mem {F : ℍ → ℂ} (hF : F ∈ ring N) : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F := by
+  have h := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact h.2.2.2.2.1 F hF
+
+theorem eq_zero_or_eq_zero_of_mul_eq_zero {a b : ℍ → ℂ} (ha : a ∈ ring N) (hb : b ∈ ring N)
+    (hab : a * b = 0) : a = 0 ∨ b = 0 := by
+  have h := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact h.2.2.2.2.2 a b ha hb hab
+
+private abbrev _root_.ModularCurve.LevelN.AnalyticOrderPlace.ext (F : ℍ → ℂ) :
+    ℂ → ℂ := F ∘ ofComplex
+
+p2m_export "ModularCurve.LevelN.AnalyticOrderPlace" "ext"
+theorem ext_apply_coe (F : ℍ → ℂ) (τ : ℍ) : ext F τ = F τ := by
+  simp [ext, ofComplex_apply]
+
+theorem analyticOnNhd_ext {F : ℍ → ℂ} (hF : F ∈ ring N) :
+    AnalyticOnNhd ℂ (ext F) upperHalfPlaneSet := by
+  intro z hz
+  have hd : DifferentiableOn ℂ (ext F) upperHalfPlaneSet :=
+    UpperHalfPlane.mdifferentiable_iff.mp (mdifferentiable_of_mem N hF)
+  exact hd.analyticAt (isOpen_upperHalfPlaneSet.mem_nhds hz)
+
+theorem analyticAt_ext {F : ℍ → ℂ} (hF : F ∈ ring N) (τ₀ : ℍ) : AnalyticAt ℂ (ext F) τ₀ :=
+  analyticOnNhd_ext N hF τ₀ τ₀.im_pos
+
+theorem analyticOrderAt_ne_top {F : ℍ → ℂ} (hF : F ∈ ring N) (hF0 : F ≠ 0) (τ₀ : ℍ) :
+    analyticOrderAt (ext F) τ₀ ≠ ⊤ := by
+  obtain ⟨τ₁, hτ₁⟩ : ∃ τ₁ : ℍ, F τ₁ ≠ 0 := by
+    by_contra h
+    push Not at h
+    exact hF0 (funext h)
+  have h1 : analyticOrderAt (ext F) τ₁ ≠ ⊤ := by
+    have : analyticOrderAt (ext F) τ₁ = 0 := by
+      rw [analyticOrderAt_eq_zero]
+      right
+      rwa [ext_apply_coe]
+    rw [this]
+    exact ENat.zero_ne_top
+  exact (analyticOnNhd_ext N hF).analyticOrderAt_ne_top_of_isPreconnected
+    ((convex_halfSpace_im_gt 0).isPreconnected) τ₁.im_pos τ₀.im_pos h1
+
+def ordAt (τ₀ : ℍ) (F : ℍ → ℂ) : ℕ := (analyticOrderAt (ext F) τ₀).toNat
+
+theorem ordAt_cast {F : ℍ → ℂ} (hF : F ∈ ring N) (hF0 : F ≠ 0) (τ₀ : ℍ) :
+    (ordAt τ₀ F : ℕ∞) = analyticOrderAt (ext F) τ₀ :=
+  ENat.natCast_toNat (analyticOrderAt_ne_top N hF hF0 τ₀)
+
+theorem ordAt_mul {F G : ℍ → ℂ} (hF : F ∈ ring N) (hG : G ∈ ring N) (hF0 : F ≠ 0) (hG0 : G ≠ 0)
+    (τ₀ : ℍ) : ordAt τ₀ (F * G) = ordAt τ₀ F + ordAt τ₀ G := by
+  have h := analyticOrderAt_mul (analyticAt_ext N hF τ₀) (analyticAt_ext N hG τ₀)
+  unfold ordAt
+  rw [show ext (F * G) = ext F * ext G from rfl, h]
+  exact ENat.toNat_add (analyticOrderAt_ne_top N hF hF0 τ₀) (analyticOrderAt_ne_top N hG hG0 τ₀)
+
+theorem min_ordAt_le_ordAt_add {F G : ℍ → ℂ} (hF : F ∈ ring N) (hG : G ∈ ring N) (hF0 : F ≠ 0)
+    (hG0 : G ≠ 0) (hFG : F + G ≠ 0) (τ₀ : ℍ) :
+    min (ordAt τ₀ F) (ordAt τ₀ G) ≤ ordAt τ₀ (F + G) := by
+  have h := le_analyticOrderAt_add (f := ext F) (g := ext G) (z₀ := (τ₀ : ℂ))
+  rw [show ext F + ext G = ext (F + G) from rfl, ← ordAt_cast N hF hF0, ← ordAt_cast N hG hG0,
+    ← ordAt_cast N ((ring N).add_mem hF hG) hFG] at h
+  rcases le_total (ordAt τ₀ F) (ordAt τ₀ G) with hle | hle
+  · rw [min_eq_left hle]
+    rw [min_eq_left (by exact_mod_cast hle)] at h
+    exact_mod_cast h
+  · rw [min_eq_right hle]
+    rw [min_eq_right (by exact_mod_cast hle)] at h
+    exact_mod_cast h
+
+theorem ordAt_one (τ₀ : ℍ) : ordAt τ₀ (1 : ℍ → ℂ) = 0 := by
+  unfold ordAt
+  have : analyticOrderAt (ext (1 : ℍ → ℂ)) τ₀ = 0 := by
+    rw [analyticOrderAt_eq_zero]
+    right
+    simp [ext]
+  rw [this]
+  rfl
+
+open Classical in
+def ordFun (τ₀ : ℍ) (F : ring N) : WithZero (Multiplicative ℤ) :=
+  if (F : ℍ → ℂ) = 0 then 0 else WithZero.exp (-(ordAt τ₀ (F : ℍ → ℂ) : ℤ))
+
+omit [NeZero N] in
+theorem ordFun_of_ne_zero (τ₀ : ℍ) {F : ring N} (hF : (F : ℍ → ℂ) ≠ 0) :
+    ordFun N τ₀ F = WithZero.exp (-(ordAt τ₀ (F : ℍ → ℂ) : ℤ)) := by
+  simp [ordFun, hF]
+
+omit [NeZero N] in
+theorem ordFun_zero' (τ₀ : ℍ) {F : ring N} (hF : (F : ℍ → ℂ) = 0) : ordFun N τ₀ F = 0 := by
+  simp [ordFun, hF]
+
+def ordValuation (τ₀ : ℍ) : Valuation (ring N) (WithZero (Multiplicative ℤ)) where
+  toFun := ordFun N τ₀
+  map_zero' := ordFun_zero' N τ₀ rfl
+  map_one' := by
+    rw [ordFun_of_ne_zero N τ₀ (by simp)]
+    simp [ordAt_one]
+  map_mul' F G := by
+    by_cases hF : (F : ℍ → ℂ) = 0
+    · rw [ordFun_zero' N τ₀ hF, ordFun_zero' N τ₀ (by simp [hF]), zero_mul]
+    by_cases hG : (G : ℍ → ℂ) = 0
+    · rw [ordFun_zero' N τ₀ hG, ordFun_zero' N τ₀ (by simp [hG]), mul_zero]
+    have hFG : ((F * G : ring N) : ℍ → ℂ) ≠ 0 := by
+      intro h
+      rcases eq_zero_or_eq_zero_of_mul_eq_zero N F.2 G.2 (by simpa using h) with h' | h'
+      · exact hF h'
+      · exact hG h'
+    rw [ordFun_of_ne_zero N τ₀ hF, ordFun_of_ne_zero N τ₀ hG, ordFun_of_ne_zero N τ₀ hFG,
+      ← WithZero.exp_add]
+    congr 1
+    rw [show ((F * G : ring N) : ℍ → ℂ) = (F : ℍ → ℂ) * (G : ℍ → ℂ) from rfl,
+      ordAt_mul N F.2 G.2 hF hG]
+    push_cast
+    ring
+  map_add_le_max' F G := by
+    by_cases hFG : ((F + G : ring N) : ℍ → ℂ) = 0
+    · rw [ordFun_zero' N τ₀ hFG]; exact zero_le
+    by_cases hF : (F : ℍ → ℂ) = 0
+    · have : F + G = G := by
+        have hF' : F = 0 := Subtype.ext hF
+        rw [hF', zero_add]
+      rw [this, ordFun_zero' N τ₀ hF]
+      exact le_max_right _ _
+    by_cases hG : (G : ℍ → ℂ) = 0
+    · have : F + G = F := by
+        have hG' : G = 0 := Subtype.ext hG
+        rw [hG', add_zero]
+      rw [this, ordFun_zero' N τ₀ hG]
+      exact le_max_left _ _
+    rw [ordFun_of_ne_zero N τ₀ hF, ordFun_of_ne_zero N τ₀ hG, ordFun_of_ne_zero N τ₀ hFG]
+    have hmin := min_ordAt_le_ordAt_add N F.2 G.2 hF hG (by simpa using hFG) τ₀
+    rw [show ((F + G : ring N) : ℍ → ℂ) = (F : ℍ → ℂ) + (G : ℍ → ℂ) from rfl]
+    rcases le_total (ordAt τ₀ (F : ℍ → ℂ)) (ordAt τ₀ (G : ℍ → ℂ)) with h | h
+    · rw [min_eq_left h] at hmin
+      refine le_trans ?_ (le_max_left _ _)
+      rw [WithZero.exp_le_exp]
+      omega
+    · rw [min_eq_right h] at hmin
+      refine le_trans ?_ (le_max_right _ _)
+      rw [WithZero.exp_le_exp]
+      omega
+
+@[scoped simp]
+theorem ordValuation_apply (τ₀ : ℍ) (F : ring N) : ordValuation N τ₀ F = ordFun N τ₀ F := rfl
+
+theorem ordValuation_ne_zero (τ₀ : ℍ) {F : ring N} (hF : F ≠ 0) : ordValuation N τ₀ F ≠ 0 := by
+  have hF' : (F : ℍ → ℂ) ≠ 0 := fun h => hF (Subtype.ext h)
+  rw [ordValuation_apply, ordFun_of_ne_zero N τ₀ hF']
+  exact WithZero.exp_ne_zero
+
+theorem nonZeroDivisors_le_supp_primeCompl (τ₀ : ℍ) :
+    nonZeroDivisors (ring N) ≤ (ordValuation N τ₀).supp.primeCompl := by
+  intro s hs
+  change s ∉ (ordValuation N τ₀).supp
+  rw [Valuation.mem_supp_iff]
+  apply ordValuation_ne_zero
+  intro h
+  rw [h] at hs
+  exact zero_notMem_nonZeroDivisors hs
+
+section FractionField
+
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ring N) K] [IsScalarTower ℂ (ring N) K]
+  [IsFractionRing (ring N) K]
+
+def ordValuationK (τ₀ : ℍ) : Valuation K (WithZero (Multiplicative ℤ)) :=
+  (ordValuation N τ₀).extendToLocalization (S := nonZeroDivisors (ring N))
+    (nonZeroDivisors_le_supp_primeCompl N τ₀) K
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem ordValuationK_algebraMap (τ₀ : ℍ) (F : ring N) :
+    ordValuationK N K τ₀ (algebraMap (ring N) K F) = ordFun N τ₀ F :=
+  Valuation.extendToLocalization_apply_map_apply _ _ K F
+
+def jSub (τ₀ : ℍ) : ring N := jGen N - algebraMap ℂ (ring N) (jAnalytic τ₀)
+
+omit [NeZero N] in
+theorem coe_jSub (τ₀ : ℍ) :
+    ((jSub N τ₀ : ring N) : ℍ → ℂ) = fun τ => jAnalytic τ - jAnalytic τ₀ := by
+  funext τ
+  simp [jSub, jGen, Algebra.algebraMap_eq_smul_one]
+
+theorem jSub_ne_zero (τ₀ : ℍ) : (jSub N τ₀ : ring N) ≠ 0 := by
+  intro h
+  have h' := congrArg (fun F : ring N => (F : ℍ → ℂ)) h
+  simp only [coe_jSub, ZeroMemClass.coe_zero] at h'
+  have hpkg := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  have htr := hpkg.2.2.2.1 (Polynomial.X - Polynomial.C (jAnalytic τ₀)) (fun τ => by
+    have := congrFun h' τ
+    simp only [Pi.zero_apply] at this
+    simp [this])
+  have := congrArg (Polynomial.eval (jAnalytic τ₀ + 1)) htr
+  simp at this
+
+theorem ordAt_jSub_pos (τ₀ : ℍ) : 0 < ordAt τ₀ ((jSub N τ₀ : ring N) : ℍ → ℂ) := by
+  have hne : ((jSub N τ₀ : ring N) : ℍ → ℂ) ≠ 0 := fun h => jSub_ne_zero N τ₀ (Subtype.ext h)
+  have hcast := ordAt_cast N (jSub N τ₀).2 hne τ₀
+  by_contra h0
+  push Not at h0
+  have h0' : ordAt τ₀ ((jSub N τ₀ : ring N) : ℍ → ℂ) = 0 := Nat.le_zero.mp h0
+  rw [h0', Nat.cast_zero, eq_comm, analyticOrderAt_eq_zero] at hcast
+  rcases hcast with h | h
+  · exact h (analyticAt_ext N (jSub N τ₀).2 τ₀)
+  · apply h
+    rw [ext_apply_coe, coe_jSub]
+    simp
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem ordValuationK_jSub_lt_one (τ₀ : ℍ) :
+    ordValuationK N K τ₀ (algebraMap (ring N) K (jSub N τ₀)) < 1 := by
+  rw [ordValuationK_algebraMap, ordFun_of_ne_zero N τ₀ (fun h => jSub_ne_zero N τ₀ (Subtype.ext h)),
+    ← WithZero.exp_zero, WithZero.exp_lt_exp]
+  have := ordAt_jSub_pos N τ₀
+  omega
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem isNontrivial_ordValuationK (τ₀ : ℍ) : (ordValuationK N K τ₀).IsNontrivial := by
+  refine ⟨algebraMap (ring N) K (jSub N τ₀), ?_, ?_⟩
+  · rw [ordValuationK_algebraMap]
+    exact ordValuation_ne_zero N τ₀ (jSub_ne_zero N τ₀)
+  · exact (ordValuationK_jSub_lt_one N K τ₀).ne
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem nontrivial_valueGroup (τ₀ : ℍ) :
+    Nontrivial (ordValuationK N K τ₀).toMonoidWithZeroHom.valueGroup := by
+  rw [Subgroup.nontrivial_iff_exists_ne_one]
+  have hne : ordValuationK N K τ₀ (algebraMap (ring N) K (jSub N τ₀)) ≠ 0 := by
+    rw [ordValuationK_algebraMap]
+    exact ordValuation_ne_zero N τ₀ (jSub_ne_zero N τ₀)
+  refine ⟨Units.mk0 _ hne, ?_, ?_⟩
+  · exact MonoidWithZeroHom.mem_valueGroup _ ⟨_, rfl⟩
+  · intro h
+    have h' :=
+      congrArg (fun u : (WithZero (Multiplicative ℤ))ˣ => (u : WithZero (Multiplicative ℤ))) h
+    simp only [Units.val_mk0, Units.val_one] at h'
+    exact (ordValuationK_jSub_lt_one N K τ₀).ne h'
+
+def analyticPlace (τ₀ : ℍ) : AlgebraicCurve.Place ℂ K :=
+  haveI := nontrivial_valueGroup N K τ₀
+  { toValuationSubring := (ordValuationK N K τ₀).valuationSubring
+    algebraMap_mem' := fun a => by
+      rw [Valuation.mem_valuationSubring_iff]
+      by_cases ha : a = 0
+      · simp [ha]
+      · rw [IsScalarTower.algebraMap_apply ℂ (ring N) K, ordValuationK_algebraMap,
+          ordFun_of_ne_zero N τ₀ (by
+            intro h
+            have := congrFun h UpperHalfPlane.I
+            simp [Algebra.algebraMap_eq_smul_one, ha] at this)]
+        rw [← WithZero.exp_zero, WithZero.exp_le_exp]
+        have : ordAt τ₀ ((algebraMap ℂ (ring N) a : ring N) : ℍ → ℂ) = 0 := by
+          unfold ordAt
+          have : analyticOrderAt (ext ((algebraMap ℂ (ring N) a : ring N) : ℍ → ℂ)) τ₀ = 0 := by
+            rw [analyticOrderAt_eq_zero]
+            right
+            simp [ext, Algebra.algebraMap_eq_smul_one, ha]
+          rw [this]; rfl
+        omega
+    ne_top' := by
+      rw [ne_eq, Valuation.valuationSubring_eq_top_iff, not_not]
+      exact isNontrivial_ordValuationK N K τ₀
+    isPrincipalIdealRing' :=
+      (Valuation.valuationSubring_isDiscreteValuationRing
+        (ordValuationK N K τ₀)).toIsPrincipalIdealRing }
+
+@[scoped simp]
+theorem analyticPlace_toValuationSubring (τ₀ : ℍ) :
+    (analyticPlace N K τ₀).toValuationSubring = (ordValuationK N K τ₀).valuationSubring := rfl
+
+theorem mem_analyticPlace_iff (τ₀ : ℍ) (x : K) :
+    x ∈ (analyticPlace N K τ₀).toValuationSubring ↔ ordValuationK N K τ₀ x ≤ 1 := by
+  rw [analyticPlace_toValuationSubring, Valuation.mem_valuationSubring_iff]
+
+theorem inv_jSub_notMem (τ₀ : ℍ) :
+    (algebraMap (ring N) K (jSub N τ₀))⁻¹ ∉ (analyticPlace N K τ₀).toValuationSubring := by
+  rw [mem_analyticPlace_iff, map_inv₀, not_le, one_lt_inv₀]
+  · exact ordValuationK_jSub_lt_one N K τ₀
+  · rw [ordValuationK_algebraMap]
+    exact (zero_le.lt_of_ne (ordValuation_ne_zero N τ₀ (jSub_ne_zero N τ₀)).symm)
+
+theorem jSub_mem_nonunits (τ₀ : ℍ) :
+    algebraMap (ring N) K (jSub N τ₀) ∈ (analyticPlace N K τ₀).toValuationSubring.nonunits := by
+  rw [ValuationSubring.mem_nonunits_iff_or]
+  exact Or.inr (inv_jSub_notMem N K τ₀)
+
+theorem algebraMap_mem_analyticPlace (τ₀ : ℍ) (F : ring N) :
+    algebraMap (ring N) K F ∈ (analyticPlace N K τ₀).toValuationSubring := by
+  rw [mem_analyticPlace_iff, ordValuationK_algebraMap]
+  by_cases hF : (F : ℍ → ℂ) = 0
+  · rw [ordFun_zero' N τ₀ hF]; exact zero_le
+  · rw [ordFun_of_ne_zero N τ₀ hF, ← WithZero.exp_zero, WithZero.exp_le_exp]
+    omega
+
+theorem exists_pos_neg_log_eq_mul_ord (τ₀ : ℍ) :
+    ∃ e : ℕ, 0 < e ∧ ∀ x : K, x ≠ 0 →
+      -(WithZero.log (ordValuationK N K τ₀ x)) = (e : ℤ) * (analyticPlace N K τ₀).ord x := by
+  set W := analyticPlace N K τ₀ with hW
+  set v := ordValuationK N K τ₀ with hv
+  have hmem : ∀ x : K, x ∈ W.toValuationSubring ↔ v x ≤ 1 := fun x => mem_analyticPlace_iff N K τ₀ x
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible W.toValuationSubring
+  have hπ0 : (π : K) ≠ 0 := by
+    intro h; exact hπ.ne_zero (Subtype.ext h)
+  have hvπ0 : v (π : K) ≠ 0 := (Valuation.ne_zero_iff v).mpr hπ0
+  have hvπle : v (π : K) ≤ 1 := (hmem _).mp π.2
+  have hvπlt : v (π : K) < 1 := by
+    rcases hvπle.lt_or_eq with h | h
+    · exact h
+    · exfalso
+      apply hπ.not_isUnit
+      have hinv : (π : K)⁻¹ ∈ W.toValuationSubring := by
+        rw [hmem, map_inv₀, h, inv_one]
+      refine ⟨⟨π, ⟨(π : K)⁻¹, hinv⟩, Subtype.ext ?_, Subtype.ext ?_⟩, rfl⟩
+      · change (π : K) * (π : K)⁻¹ = 1; exact mul_inv_cancel₀ hπ0
+      · change (π : K)⁻¹ * (π : K) = 1; exact inv_mul_cancel₀ hπ0
+  have hlogπ : WithZero.log (v (π : K)) < 0 := by
+    rw [WithZero.log_lt_iff_lt_exp hvπ0, WithZero.exp_zero]; exact hvπlt
+  refine ⟨(-(WithZero.log (v (π : K)))).toNat, by omega, fun x hx0 => ?_⟩
+  have he : (((-(WithZero.log (v (π : K)))).toNat : ℕ) : ℤ) = -(WithZero.log (v (π : K))) :=
+    Int.toNat_of_nonneg (by omega)
+  rw [he]
+  obtain ⟨u, hux⟩ := W.exists_unit_mul_zpow hx0 hπ
+  have hu0 : ((u : W.toValuationSubring) : K) ≠ 0 := by
+    simp [ne_eq, ZeroMemClass.coe_eq_zero]
+  have hvu : v ((u : W.toValuationSubring) : K) = 1 := by
+    apply le_antisymm ((hmem _).mp (u : W.toValuationSubring).2)
+    have hinv : v (((u⁻¹ : W.toValuationSubringˣ) : W.toValuationSubring) : K) ≤ 1 :=
+      (hmem _).mp ((u⁻¹ : W.toValuationSubringˣ) : W.toValuationSubring).2
+    have hprod : ((u : W.toValuationSubring) : K) *
+        (((u⁻¹ : W.toValuationSubringˣ) : W.toValuationSubring) : K) = 1 := by
+      rw [← Subring.coe_mul, ← Units.val_mul, mul_inv_cancel, Units.val_one]; rfl
+    have hvinv : v (((u⁻¹ : W.toValuationSubringˣ) : W.toValuationSubring) : K) =
+        (v ((u : W.toValuationSubring) : K))⁻¹ := by
+      have := congrArg v hprod
+      rw [map_mul, map_one] at this
+      exact eq_inv_of_mul_eq_one_right this
+    rw [hvinv] at hinv
+    have hpos : 0 < v ((u : W.toValuationSubring) : K) :=
+      zero_lt_iff.mpr ((Valuation.ne_zero_iff v).mpr hu0)
+    exact (inv_le_one₀ hpos).mp hinv
+  have hvx : v x = v ((u : W.toValuationSubring) : K) * v (π : K) ^ W.ord x := by
+    conv_lhs => rw [hux]
+    rw [map_mul, map_zpow₀]
+  rw [hvx, hvu, one_mul, WithZero.log_zpow, smul_eq_mul]
+  ring
+
+theorem exists_place_ordAt_eq_mul_ord (τ₀ : ℍ) :
+    ∃ (W : AlgebraicCurve.Place ℂ K) (e : ℕ), 0 < e ∧
+      ∀ (F : ℍ → ℂ) (hF : F ∈ ring N), F ≠ 0 →
+        analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (τ₀ : ℂ) ≠ ⊤ ∧
+        ((analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (τ₀ : ℂ)).toNat : ℤ) =
+          e * W.ord (algebraMap (ring N) K ⟨F, hF⟩) := by
+  obtain ⟨e, he, hlog⟩ := exists_pos_neg_log_eq_mul_ord N K τ₀
+  refine ⟨analyticPlace N K τ₀, e, he, fun F hF hF0 => ⟨analyticOrderAt_ne_top N hF hF0 τ₀, ?_⟩⟩
+  have hne : (algebraMap (ring N) K ⟨F, hF⟩) ≠ 0 := by
+    intro h
+    have : (⟨F, hF⟩ : ring N) = 0 := (IsFractionRing.injective (ring N) K) (by rw [h, map_zero])
+    exact hF0 (congrArg Subtype.val this)
+  have h := hlog _ hne
+  rw [ordValuationK_algebraMap, ordFun_of_ne_zero N τ₀ (by
+    exact hF0), WithZero.log_exp, neg_neg] at h
+  rw [← h]
+  rfl
+
+end FractionField
+
+end ModularCurve.LevelN.AnalyticOrderPlace
+end
+
+theorem solution (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring N) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring N) K]
+    [IsFractionRing (ModularCurve.LevelN.ring N) K] (τ₀ : UpperHalfPlane) :
+    ∃ (W : AlgebraicCurve.Place ℂ K) (e : ℕ), 0 < e ∧
+      ∀ (F : UpperHalfPlane → ℂ) (hF : F ∈ ModularCurve.LevelN.ring N), F ≠ 0 →
+        analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (τ₀ : ℂ) ≠ ⊤ ∧
+        ((analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (τ₀ : ℂ)).toNat : ℤ) =
+          e * W.ord (algebraMap (ModularCurve.LevelN.ring N) K ⟨F, hF⟩) :=
+  ModularCurve.LevelN.AnalyticOrderPlace.exists_place_ordAt_eq_mul_ord N K τ₀
+
+end S_ModularCurve_LevelN_exists_place_analyticOrderAt_eq_mul_ord
+end P2MW
+export P2MW.S_ModularCurve_LevelN_exists_place_analyticOrderAt_eq_mul_ord (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.LevelN.exists_place_analyticOrderAt_eq_mul_ord (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring N) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring N) K]
+    [IsFractionRing (ModularCurve.LevelN.ring N) K] (τ₀ : UpperHalfPlane) :
+    ∃ (W : AlgebraicCurve.Place ℂ K) (e : ℕ), 0 < e ∧
+      ∀ (F : UpperHalfPlane → ℂ) (hF : F ∈ ModularCurve.LevelN.ring N), F ≠ 0 →
+        analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (τ₀ : ℂ) ≠ ⊤ ∧
+        ((analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (τ₀ : ℂ)).toNat : ℤ) =
+          e * W.ord (algebraMap (ModularCurve.LevelN.ring N) K ⟨F, hF⟩) :=
+  solution N K τ₀
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_place_ord_jGen_eq_three_two_and_stabilizer_subset_zpowers.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_place_ord_jGen_eq_three_two_and_stabilizer_subset_zpowers.lean
new file mode 100644
index 0000000000..e63990f60b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_place_ord_jGen_eq_three_two_and_stabilizer_subset_zpowers.lean
@@ -0,0 +1,900 @@
+/-
+Based on Prove2Me node
+ModularCurve.LevelN.exists_place_ord_jGen_eq_three_two_and_stabilizer_subset_zpowers
+(4fdf1a6c-a03a-56a6-b04a-77666b4eec92) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b0e7320f-1c54-5083-9cb6-32609b21623d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_BaseChangeGalois
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LevelNFunctionField
+
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_restrictAlong_eq_natCard_algHom_of_isGalois
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_place_analyticOrderAt_eq_mul_ord
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Ramification of X(M)→ X(1) at j=0 and j=1728
+
+Theorem statement:
+`ModularCurve.LevelN.exists_place_ord_jGen_eq_three_two_and_stabilizer_subset_zpowers`
+(`4fdf1a6c-a03a-56a6-b04a-77666b4eec92`), by Claude, 2026-09-05.
+
+Proof: submission `b0e7320f-1c54-5083-9cb6-32609b21623d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix an integer $M$ with $M\neq 0$ and $2\le M$, and let $A_M=$ [`ModularCurve.LevelN.ring
+M`](def/ModularCurve_LevelNFunctionField.html#L28) be the $\mathbb{C}$-subalgebra of functions
+$\mathbb{H}\to\mathbb{C}$ generated by $j=E_4^3/\Delta$ together with the Fricke functions $f_v$
+attached to the nonzero $v\in(\mathbb{Z}/M)^2$. Let $K$ be a field that is simultaneously a
+$\mathbb{C}$-algebra and an $A_M$-algebra, compatibly, and is a fraction field of $A_M$. Assume:
+$A_M$ is stable under precomposition with the action of every $\delta\in\mathrm{SL}_2(\mathbb{Z})$
+on $\mathbb{H}$; $\sigma$ is a group homomorphism from $\mathrm{SL}_2(\mathbb{Z})$ to the
+$\mathbb{C}$-algebra automorphisms of $K$ which on the image of $G\in A_M$ is given by $G\mapsto
+G(\gamma^{-1}\cdot{-})$; $\ker\sigma=\Gamma(M)\vee\langle -1\rangle$; the fixed field of the range
+of $\sigma$ is $\mathbb{C}\langle j\rangle$, the subfield generated over $\mathbb{C}$ by the image
+$j$ of `jGen M` in $K$; and $K/\mathbb{C}\langle j\rangle$ is finite and Galois. Then there is a
+place $W$ of $K$ over $\mathbb{C}$ (a proper valuation subring containing $\mathbb{C}$ whose
+valuation ring is a principal ideal ring) with $\operatorname{ord}_W(j)=3$ such that every
+$g\in\mathrm{Gal}(K/\mathbb{C}\langle j\rangle)$ fixing $W$ under the induced semilinear action
+equals $\sigma(ST)^k$ for some $k\in\mathbb{N}$; and there is a place $W$ with
+$\operatorname{ord}_W(j-1728)=2$ whose stabiliser in $\mathrm{Gal}(K/\mathbb{C}\langle j\rangle)$
+consists of powers $\sigma(S)^k$, $k\in\mathbb{N}$.
+
+This is the exact ramification behaviour of the covering $X(M)\to X(1)$ above the two elliptic
+points, $e=3$ over $j=0$ with decomposition group generated by $ST$, and $e=2$ over $j=1728$ with
+decomposition group generated by $S$. It is used in the arguments showing that the function fields
+of $X_0(M)$ and $X_1(M)$ have no elliptic points in the relevant range, after base change to an
+algebraically closed field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_LevelN_exists_place_ord_jGen_eq_three_two_and_stabilizer_subset_zpowers.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_d9a2a124
+
+
+p2m_open "UpperHalfPlane AlgebraicCurve \
+  P2MW.S_OVERLONG_d9a2a124.Algeb\
+  raicCurve"
+open scoped MatrixGroups IntermediateField Manifold
+
+open ModularGroup Filter Topology
+
+namespace CongruenceSubgroup
+p2m_export "CongruenceSubgroup" "Gamma_mem Gamma"
+p2m_open "CongruenceSubgroup"
+
+theorem mem_sup_zpowers_neg_one_iff (H : Subgroup SL(2, ℤ)) (g : SL(2, ℤ)) :
+    g ∈ H ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) ↔ g ∈ H ∨ -g ∈ H := by
+  have hN : (Subgroup.zpowers (-1 : SL(2, ℤ))).Normal := by
+    refine ⟨fun n hn g => ?_⟩
+    obtain ⟨k, rfl⟩ := Subgroup.mem_zpowers_iff.mp hn
+    have hc : Commute ((-1 : SL(2, ℤ)) ^ k) g := (Commute.neg_one_left g).zpow_left k
+    rw [← hc.eq, mul_inv_cancel_right]
+    exact Subgroup.zpow_mem_zpowers _ _
+  have hpm : ∀ n ∈ Subgroup.zpowers (-1 : SL(2, ℤ)), n = 1 ∨ n = -1 := by
+    intro n hn
+    obtain ⟨k, rfl⟩ := Subgroup.mem_zpowers_iff.mp hn
+    rcases Int.even_or_odd k with ⟨m, rfl⟩ | ⟨m, rfl⟩
+    · left
+      rw [← two_mul, zpow_mul, zpow_ofNat]
+      simp
+    · right
+      rw [zpow_add, zpow_mul, zpow_ofNat, zpow_one]
+      simp
+  constructor
+  · intro hg
+    have hg' : g ∈ ((H ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) : Subgroup SL(2, ℤ)) : Set SL(2, ℤ)) := hg
+    rw [Subgroup.mul_normal] at hg'
+    obtain ⟨h, hh, n, hn, rfl⟩ := Set.mem_mul.mp hg'
+    rcases hpm n hn with rfl | rfl
+    · left; simpa using hh
+    · right; simpa using hh
+  · rintro (hg | hg)
+    · exact Subgroup.mem_sup_left hg
+    · have : g = (-g) * (-1) := by simp
+      rw [this]
+      exact Subgroup.mul_mem _ (Subgroup.mem_sup_left hg) (Subgroup.mem_sup_right
+        (Subgroup.mem_zpowers _))
+
+theorem S_mul_T_pow_three : (S * T) ^ 3 = (-1 : SL(2, ℤ)) := by
+  ext i j
+  rw [pow_three]
+  fin_cases i <;> fin_cases j <;>
+    simp [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_S, ModularGroup.coe_T,
+      Matrix.mul_apply, Fin.sum_univ_two]
+
+theorem S_sq : S ^ 2 = (-1 : SL(2, ℤ)) := by
+  ext i j
+  rw [sq]
+  fin_cases i <;> fin_cases j <;>
+    simp [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_S, Matrix.mul_apply, Fin.sum_univ_two]
+
+theorem S_mul_T_notMem (M : ℕ) (hM : 2 ≤ M) :
+    S * T ∉ Gamma M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) := by
+  rw [mem_sup_zpowers_neg_one_iff]
+  have : Fact (1 < M) := ⟨hM⟩
+  rintro (h | h)
+  · have h10 := (Gamma_mem.mp h).2.2.1
+    simp [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_S, ModularGroup.coe_T,
+      Matrix.mul_apply, Fin.sum_univ_two] at h10
+  · have h10 := (Gamma_mem.mp h).2.2.1
+    simp [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_S, ModularGroup.coe_T] at h10
+
+theorem S_notMem (M : ℕ) (hM : 2 ≤ M) : S ∉ Gamma M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) := by
+  rw [mem_sup_zpowers_neg_one_iff]
+  have : Fact (1 < M) := ⟨hM⟩
+  rintro (h | h)
+  · have h10 := (Gamma_mem.mp h).2.2.1
+    simp [ModularGroup.coe_S] at h10
+  · have h10 := (Gamma_mem.mp h).2.2.1
+    simp [ModularGroup.coe_S] at h10
+
+theorem orderOf_map_S_mul_T {G : Type*} [Group G] (M : ℕ) (hM : 2 ≤ M) (σ : SL(2, ℤ) →* G)
+    (hker : σ.ker = Gamma M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))) : orderOf (σ (S * T)) = 3 := by
+  have h1 : -1 ∈ σ.ker := by
+    rw [hker]; exact Subgroup.mem_sup_right (Subgroup.mem_zpowers _)
+  have hpow : σ (S * T) ^ 3 = 1 := by
+    rw [← map_pow, S_mul_T_pow_three]; exact h1
+  have hne : σ (S * T) ≠ 1 := by
+    intro h
+    have : S * T ∈ σ.ker := h
+    rw [hker] at this
+    exact S_mul_T_notMem M hM this
+  exact orderOf_eq_prime hpow hne
+
+theorem orderOf_map_S {G : Type*} [Group G] (M : ℕ) (hM : 2 ≤ M) (σ : SL(2, ℤ) →* G)
+    (hker : σ.ker = Gamma M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))) : orderOf (σ S) = 2 := by
+  have h1 : -1 ∈ σ.ker := by
+    rw [hker]; exact Subgroup.mem_sup_right (Subgroup.mem_zpowers _)
+  have hpow : σ S ^ 2 = 1 := by
+    rw [← map_pow, S_sq]; exact h1
+  have hne : σ S ≠ 1 := by
+    intro h
+    have : S ∈ σ.ker := h
+    rw [hker] at this
+    exact S_notMem M hM this
+  exact orderOf_eq_prime hpow hne
+
+end CongruenceSubgroup
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ext Place.smul_toValuationSubring Place.ord_smul \
+  SemilinearAut SemilinearAut.ofAlgAut SemilinearAut.smul_toValuationSubring \
+  Place.ord_restrictAlong_eq_natCard_algHom_of_isGalois"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  smul_toValuationSubring ord_smul toValuationSubring \
+  ord_restrictAlong_eq_natCard_algHom_of_isGalois"
+p2m_open "AlgebraicCurve.Place AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.ord_nonneg_of_mem' {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    0 ≤ v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨n, u, hu⟩ :=
+    IsDiscreteValuationRing.eq_unit_mul_pow_irreducible
+      (x := (⟨f, hf⟩ : v.toValuationSubring)) (by simpa [Subtype.ext_iff] using hf0) hπ
+  have hcoe : f = ((u : v.toValuationSubring) : F) * ((π : F) ^ (n : ℤ)) := by
+    have h := congrArg (Subtype.val) hu
+    push_cast at h
+    rw [zpow_natCast]
+    exact h
+  rw [hcoe, v.ord_unit_smul_zpow u hπ (n : ℤ)]
+  exact Int.natCast_nonneg n
+
+p2m_export "AlgebraicCurve.Place" "ord_nonneg_of_mem'"
+private theorem _root_.AlgebraicCurve.Place.mem_of_ord_nonneg' {f : F} (hf : f ≠ 0)
+    (h : 0 ≤ v.ord f) :
+    f ∈ v.toValuationSubring := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ
+  rw [hu, show v.ord f = (((v.ord f).toNat : ℕ) : ℤ) from (Int.toNat_of_nonneg h).symm,
+    zpow_natCast]
+  exact mul_mem (u : v.toValuationSubring).2 (pow_mem (π : v.toValuationSubring).2 _)
+
+p2m_export "AlgebraicCurve.Place" "mem_of_ord_nonneg'"
+private theorem _root_.AlgebraicCurve.Place.mem_iff_ord_nonneg' {f : F} (hf : f ≠ 0) :
+    f ∈ v.toValuationSubring ↔ 0 ≤ v.ord f :=
+  ⟨v.ord_nonneg_of_mem', v.mem_of_ord_nonneg' hf⟩
+
+p2m_export "AlgebraicCurve.Place" "mem_iff_ord_nonneg'"
+
+theorem eq_of_ord_algebraMap_eq {A : Type*} [CommRing A] [IsDomain A] [Algebra A F]
+    [IsFractionRing A F]
+    (v w : Place K F)
+    (h : ∀ a : A, algebraMap A F a ≠ 0 → v.ord (algebraMap A F a) = w.ord (algebraMap A F a)) : v =
+      w := by
+  have hall : ∀ x : F, x ≠ 0 → v.ord x = w.ord x := by
+    intro x hx
+    obtain ⟨a, b, hb, rfl⟩ := IsFractionRing.div_surjective (A := A) x
+    have ha0 : algebraMap A F a ≠ 0 := by
+      intro h0; apply hx; rw [h0, zero_div]
+    have hb0 : algebraMap A F b ≠ 0 :=
+      IsFractionRing.to_map_ne_zero_of_mem_nonZeroDivisors hb
+    rw [div_eq_mul_inv, v.ord_mul ha0 (inv_ne_zero hb0), w.ord_mul ha0 (inv_ne_zero hb0), v.ord_inv,
+      w.ord_inv,
+      h a ha0, h b hb0]
+  apply Place.ext
+  ext x
+  rcases eq_or_ne x 0 with rfl | hx
+  · simp [zero_mem]
+  rw [v.mem_iff_ord_nonneg' hx, w.mem_iff_ord_nonneg' hx, hall x hx]
+
+end AlgebraicCurve.Place
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "LevelN.jAnalytic LevelN.ring LevelN.jGen LevelN.coe_jGen \
+  LevelN.exists_place_analyticOrderAt_eq_mul_ord \
+  meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two"
+namespace LevelN
+p2m_export "ModularCurve.LevelN" "jAnalytic ring jGen coe_jGen \
+  exists_place_analyticOrderAt_eq_mul_ord"
+namespace PlaceTransport
+p2m_open "ModularCurve.LevelN ModularCurve~jGen"
+
+section Moebius
+
+variable (γ : SL(2, ℤ))
+
+def ent (i j : Fin 2) : ℂ := ((algebraMap ℤ ℝ (γ i j) : ℝ) : ℂ)
+
+theorem ent_eq (i j : Fin 2) : ent γ i j = ((γ i j : ℤ) : ℂ) := by
+  simp [ent]
+
+theorem det_ent : ent γ 0 0 * ent γ 1 1 - ent γ 0 1 * ent γ 1 0 = 1 := by
+  have h := γ.2
+  rw [Matrix.det_fin_two] at h
+  have h' := congrArg (fun n : ℤ => (n : ℂ)) h
+  simp only [Int.cast_sub, Int.cast_mul, Int.cast_one] at h'
+  simpa only [ent_eq] using h'
+
+def moeb (z : ℂ) : ℂ := (ent γ 0 0 * z + ent γ 0 1) / (ent γ 1 0 * z + ent γ 1 1)
+
+theorem denom_ne_zero' {z : ℂ} (hz : 0 < z.im) : ent γ 1 0 * z + ent γ 1 1 ≠ 0 := by
+  intro h
+  have him := congrArg Complex.im h
+  rw [Complex.add_im, Complex.mul_im, ent_eq, ent_eq] at him
+  simp only [Complex.intCast_re, Complex.intCast_im, zero_mul, add_zero, Complex.zero_im] at him
+  rcases mul_eq_zero.mp him with hc | hi
+  · have hc' : (γ 1 0 : ℤ) = 0 := by exact_mod_cast hc
+    have hd := det_ent γ
+    rw [ent_eq γ 1 0, hc', Int.cast_zero, mul_zero, sub_zero] at hd
+    rw [ent_eq γ 1 0, hc', Int.cast_zero, zero_mul, zero_add] at h
+    rw [h, mul_zero] at hd
+    exact zero_ne_one hd
+  · exact hz.ne' hi
+
+theorem moeb_coe (τ : ℍ) : moeb γ (τ : ℂ) = ((γ • τ : ℍ) : ℂ) := by
+  rw [coe_specialLinearGroup_apply]
+  rfl
+
+theorem analyticAt_moeb (τ₀ : ℍ) : AnalyticAt ℂ (moeb γ) (τ₀ : ℂ) := by
+  unfold moeb
+  exact ((analyticAt_const.mul analyticAt_id).add analyticAt_const).div
+    ((analyticAt_const.mul analyticAt_id).add analyticAt_const) (denom_ne_zero' γ τ₀.im_pos)
+
+theorem deriv_moeb_ne_zero (τ₀ : ℍ) : deriv (moeb γ) (τ₀ : ℂ) ≠ 0 := by
+  have hd0 : ent γ 1 0 * (τ₀ : ℂ) + ent γ 1 1 ≠ 0 := denom_ne_zero' γ τ₀.im_pos
+  have hnum : HasDerivAt (fun z : ℂ => ent γ 0 0 * z + ent γ 0 1) (ent γ 0 0) (τ₀ : ℂ) := by
+    simpa using ((hasDerivAt_id (τ₀ : ℂ)).const_mul (ent γ 0 0)).add_const (ent γ 0 1)
+  have hden : HasDerivAt (fun z : ℂ => ent γ 1 0 * z + ent γ 1 1) (ent γ 1 0) (τ₀ : ℂ) := by
+    simpa using ((hasDerivAt_id (τ₀ : ℂ)).const_mul (ent γ 1 0)).add_const (ent γ 1 1)
+  have h : HasDerivAt (moeb γ)
+      ((ent γ 0 0 * (ent γ 1 0 * (τ₀ : ℂ) + ent γ 1 1) - (ent γ 0 0 * (τ₀ : ℂ) + ent γ 0 1) * ent γ
+        1 0) /
+        (ent γ 1 0 * (τ₀ : ℂ) + ent γ 1 1) ^ 2) (τ₀ : ℂ) := hnum.div hden hd0
+  rw [h.deriv]
+  refine div_ne_zero ?_ (pow_ne_zero 2 hd0)
+  rw [show ent γ 0 0 * (ent γ 1 0 * (τ₀ : ℂ) + ent γ 1 1) - (ent γ 0 0 * (τ₀ : ℂ) + ent γ 0 1) * ent
+    γ 1 0 =
+    ent γ 0 0 * ent γ 1 1 - ent γ 0 1 * ent γ 1 0 by ring, det_ent]
+  exact one_ne_zero
+
+theorem analyticOrderAt_comp_smul (F : ℍ → ℂ) (τ₀ : ℍ) :
+    analyticOrderAt ((fun τ : ℍ => F (γ • τ)) ∘ ofComplex) (τ₀ : ℂ) =
+      analyticOrderAt (F ∘ ofComplex) ((γ • τ₀ : ℍ) : ℂ) := by
+  have hopen : IsOpen {z : ℂ | 0 < z.im} := isOpen_lt continuous_const Complex.continuous_im
+  have heq : ((fun τ : ℍ => F (γ • τ)) ∘ ofComplex) =ᶠ[𝓝 (τ₀ : ℂ)] ((F ∘ ofComplex) ∘ moeb γ) := by
+    filter_upwards [hopen.mem_nhds τ₀.im_pos] with z hz
+    simp only [Function.comp_apply]
+    have hm : moeb γ z = ((γ • (⟨z, hz⟩ : ℍ) : ℍ) : ℂ) := moeb_coe γ ⟨z, hz⟩
+    rw [ofComplex_apply_of_im_pos hz, hm, ofComplex_apply]
+  rw [analyticOrderAt_congr heq, analyticOrderAt_comp_of_deriv_ne_zero (analyticAt_moeb γ τ₀)
+    (deriv_moeb_ne_zero γ τ₀),
+    moeb_coe]
+
+end Moebius
+
+section Places
+
+variable (N : ℕ)
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (LevelN.ring N) K]
+  [IsScalarTower ℂ (LevelN.ring N) K] [IsFractionRing (LevelN.ring N) K]
+
+omit [IsScalarTower ℂ (↥(ring N)) K] [IsFractionRing (↥(ring N)) K] in
+theorem smul_place_analyticOrderAt
+    (hst : ∀ (δ : SL(2, ℤ)), ∀ G ∈ LevelN.ring N, (fun τ : ℍ => G (δ • τ)) ∈ LevelN.ring N)
+    (σ : K ≃ₐ[ℂ] K) (γ : SL(2, ℤ))
+    (hσ : ∀ (G : ℍ → ℂ) (hG : G ∈ LevelN.ring N),
+      σ (algebraMap (LevelN.ring N) K ⟨G, hG⟩) =
+        algebraMap (LevelN.ring N) K ⟨fun τ : ℍ => G (γ⁻¹ • τ), hst γ⁻¹ G hG⟩)
+    (τ₀ : ℍ) (W : AlgebraicCurve.Place ℂ K) (e : ℕ)
+    (hW : ∀ (F : ℍ → ℂ) (hF : F ∈ LevelN.ring N), F ≠ 0 →
+      analyticOrderAt (F ∘ ofComplex) (τ₀ : ℂ) ≠ ⊤ ∧
+      ((analyticOrderAt (F ∘ ofComplex) (τ₀ : ℂ)).toNat : ℤ) =
+        e * W.ord (algebraMap (LevelN.ring N) K ⟨F, hF⟩)) :
+    ∀ (F : ℍ → ℂ) (hF : F ∈ LevelN.ring N), F ≠ 0 →
+      analyticOrderAt (F ∘ ofComplex) ((γ • τ₀ : ℍ) : ℂ) ≠ ⊤ ∧
+      ((analyticOrderAt (F ∘ ofComplex) ((γ • τ₀ : ℍ) : ℂ)).toNat : ℤ) =
+        e * (σ • W).ord (algebraMap (LevelN.ring N) K ⟨F, hF⟩) := by
+  intro F hF hF0
+  have hFγ : (fun τ : ℍ => F (γ • τ)) ∈ LevelN.ring N := hst γ F hF
+  have hFγ0 : (fun τ : ℍ => F (γ • τ)) ≠ 0 := by
+    intro h
+    apply hF0
+    funext τ
+    have h1 := congrFun h (γ⁻¹ • τ)
+    simpa only [smul_inv_smul, Pi.zero_apply] using h1
+  have hσinv : σ.symm (algebraMap (LevelN.ring N) K ⟨F, hF⟩) =
+      algebraMap (LevelN.ring N) K ⟨fun τ : ℍ => F (γ • τ), hFγ⟩ := by
+    apply σ.injective
+    rw [AlgEquiv.apply_symm_apply, hσ]
+    congr 1
+    apply Subtype.ext
+    funext τ
+    simp only [smul_inv_smul]
+  obtain ⟨hfin, hord⟩ := hW _ hFγ hFγ0
+  rw [analyticOrderAt_comp_smul] at hfin hord
+  refine ⟨hfin, ?_⟩
+  rw [hord, ← hσinv, ← AlgebraicCurve.Place.ord_smul σ W (σ.symm _), AlgEquiv.apply_symm_apply]
+
+omit [IsScalarTower ℂ (↥(ring N)) K] [IsFractionRing (↥(ring N)) K] in
+theorem ord_smul_place_eq_of_smul_eq
+    (hst : ∀ (δ : SL(2, ℤ)), ∀ G ∈ LevelN.ring N, (fun τ : ℍ => G (δ • τ)) ∈ LevelN.ring N)
+    (σ : K ≃ₐ[ℂ] K) (γ : SL(2, ℤ))
+    (hσ : ∀ (G : ℍ → ℂ) (hG : G ∈ LevelN.ring N),
+      σ (algebraMap (LevelN.ring N) K ⟨G, hG⟩) =
+        algebraMap (LevelN.ring N) K ⟨fun τ : ℍ => G (γ⁻¹ • τ), hst γ⁻¹ G hG⟩)
+    (τ₀ : ℍ) (hτ₀ : γ • τ₀ = τ₀) (W : AlgebraicCurve.Place ℂ K) (e : ℕ) (he : 0 < e)
+    (hW : ∀ (F : ℍ → ℂ) (hF : F ∈ LevelN.ring N), F ≠ 0 →
+      analyticOrderAt (F ∘ ofComplex) (τ₀ : ℂ) ≠ ⊤ ∧
+      ((analyticOrderAt (F ∘ ofComplex) (τ₀ : ℂ)).toNat : ℤ) =
+        e * W.ord (algebraMap (LevelN.ring N) K ⟨F, hF⟩))
+    (F : ℍ → ℂ) (hF : F ∈ LevelN.ring N) (hF0 : F ≠ 0) :
+    (σ • W).ord (algebraMap (LevelN.ring N) K ⟨F, hF⟩) = W.ord (algebraMap (LevelN.ring N) K ⟨F,
+      hF⟩) := by
+  have h1 := (smul_place_analyticOrderAt N K hst σ γ hσ τ₀ W e hW F hF hF0).2
+  have h2 := (hW F hF hF0).2
+  rw [hτ₀] at h1
+  rw [h1] at h2
+  have he' : (e : ℤ) ≠ 0 := by exact_mod_cast he.ne'
+  exact mul_left_cancel₀ he' h2
+
+end Places
+
+end ModularCurve.LevelN.PlaceTransport
+
+namespace ModularCurve
+p2m_export "ModularCurve" "LevelN.jAnalytic LevelN.ring LevelN.jGen LevelN.coe_jGen \
+  LevelN.exists_place_analyticOrderAt_eq_mul_ord \
+  meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two"
+namespace LevelN
+p2m_export "ModularCurve.LevelN" "jAnalytic ring jGen coe_jGen \
+  exists_place_analyticOrderAt_eq_mul_ord"
+namespace Wall
+p2m_open "ModularCurve.LevelN ModularCurve~jGen"
+
+theorem E₄_smul (γ : SL(2, ℤ)) (τ : ℍ) :
+    ModularForm.E₄ (γ • τ) = denom γ τ ^ (4 : ℤ) * ModularForm.E₄ τ := by
+  have h := SlashInvariantForm.slash_action_eqn'' (Γ := 𝒮ℒ) (k := (4 : ℤ)) ModularForm.E₄
+    (γ := (γ : GL (Fin 2) ℝ)) ⟨γ, rfl⟩ τ
+  simpa [ModularGroup.sl_moeb] using h
+
+theorem E₆_smul (γ : SL(2, ℤ)) (τ : ℍ) :
+    ModularForm.E₆ (γ • τ) = denom γ τ ^ (6 : ℤ) * ModularForm.E₆ τ := by
+  have h := SlashInvariantForm.slash_action_eqn'' (Γ := 𝒮ℒ) (k := (6 : ℤ)) ModularForm.E₆
+    (γ := (γ : GL (Fin 2) ℝ)) ⟨γ, rfl⟩ τ
+  simpa [ModularGroup.sl_moeb] using h
+
+theorem S_smul_I : ModularGroup.S • UpperHalfPlane.I = UpperHalfPlane.I :=
+  ModularGroup.stabilizer_I.mpr (by simp)
+
+theorem ST_smul_ρ : (ModularGroup.S * ModularGroup.T) • ρ = ρ :=
+  ModularGroup.stabilizer_ρ.mpr (by simp)
+
+theorem TinvS_smul_ρ : (ModularGroup.T⁻¹ * ModularGroup.S) • ρ = ρ :=
+  ModularGroup.stabilizer_ρ.mpr (by simp)
+
+theorem E₆_I : ModularForm.E₆ UpperHalfPlane.I = 0 := by
+  have h := E₆_smul ModularGroup.S UpperHalfPlane.I
+  rw [S_smul_I, ModularGroup.denom_S, UpperHalfPlane.coe_I] at h
+  have hI6 : Complex.I ^ (6 : ℤ) = -1 := by
+    rw [show (6 : ℤ) = ((6 : ℕ) : ℤ) from rfl, zpow_natCast]
+    calc Complex.I ^ 6 = (Complex.I ^ 2) ^ 3 := by ring
+      _ = -1 := by rw [Complex.I_sq]; norm_num
+  rw [hI6] at h
+  linear_combination h / 2
+
+theorem denom_TinvS_ρ :
+    denom (↑(ModularGroup.T⁻¹ * ModularGroup.S) : GL (Fin 2) ℝ) ρ = (ρ : ℂ) := by
+  rw [ModularGroup.denom_apply]
+  have h10 : (ModularGroup.T⁻¹ * ModularGroup.S) 1 0 = 1 := by
+    rw [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_T_inv, ModularGroup.coe_S]
+    simp
+  have h11 : (ModularGroup.T⁻¹ * ModularGroup.S) 1 1 = 0 := by
+    rw [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_T_inv, ModularGroup.coe_S]
+    simp
+  rw [h10, h11]
+  simp
+
+theorem ρ_ne_one : (ρ : ℂ) ≠ 1 := by
+  intro h
+  have := congrArg Complex.im h
+  rw [UpperHalfPlane.coe_im] at this
+  simp only [Complex.one_im] at this
+  exact ρ.im_pos.ne' this
+
+theorem E₄_ρ : ModularForm.E₄ ρ = 0 := by
+  have h := E₄_smul (ModularGroup.T⁻¹ * ModularGroup.S) ρ
+  rw [TinvS_smul_ρ, denom_TinvS_ρ] at h
+  have hρ4 : (ρ : ℂ) ^ (4 : ℤ) = (ρ : ℂ) := by
+    rw [show (4 : ℤ) = ((4 : ℕ) : ℤ) from rfl, zpow_natCast]
+    linear_combination ((ρ : ℂ) ^ 2 - ρ) * ρ_sq
+  rw [hρ4] at h
+  have : ((ρ : ℂ) - 1) * ModularForm.E₄ ρ = 0 := by linear_combination -h
+  rcases mul_eq_zero.mp this with h1 | h1
+  · exact absurd (sub_eq_zero.mp h1) ρ_ne_one
+  · exact h1
+
+theorem jAnalytic_ρ : LevelN.jAnalytic ρ = 0 := by
+  rw [LevelN.jAnalytic, E₄_ρ]
+  simp
+
+theorem jAnalytic_I : LevelN.jAnalytic UpperHalfPlane.I = 1728 := by
+  have hΔ := ModularForm.discriminant_eq_E₄_cube_sub_E₆_sq UpperHalfPlane.I
+  rw [E₆_I] at hΔ
+  have hΔ0 := ModularForm.discriminant_ne_zero UpperHalfPlane.I
+  have hE4 : ModularForm.E₄ UpperHalfPlane.I ≠ 0 := by
+    intro h
+    apply hΔ0
+    rw [hΔ, h]
+    norm_num
+  rw [LevelN.jAnalytic, hΔ]
+  field_simp
+  ring
+
+theorem jAnalytic_sub_ne_zero (c : ℂ) : (fun τ : ℍ => LevelN.jAnalytic τ - c) ≠ 0 := by
+  intro h
+  have h1 := congrFun h ρ
+  have h2 := congrFun h UpperHalfPlane.I
+  simp only [Pi.zero_apply, jAnalytic_ρ, jAnalytic_I] at h1 h2
+  have : (1728 : ℂ) = 0 := by linear_combination h2 - h1
+  norm_num at this
+
+theorem natCard_stabilizer_I_le :
+    Nat.card (MulAction.stabilizer SL(2, ℤ) UpperHalfPlane.I) ≤ 4 := by
+  classical
+  rw [Nat.card_congr (Equiv.subtypeEquivRight
+    (q := fun g => g ∈ ({1, -1, ModularGroup.S, -ModularGroup.S} : Finset SL(2, ℤ)))
+    (fun g => (MulAction.mem_stabilizer_iff).trans ModularGroup.stabilizer_I)),
+    Nat.card_eq_finsetCard]
+  exact Finset.card_le_four
+
+theorem natCard_stabilizer_ρ_le : Nat.card (MulAction.stabilizer SL(2, ℤ) ρ) ≤ 6 := by
+  classical
+  rw [Nat.card_congr (Equiv.subtypeEquivRight
+    (q := fun g => g ∈ ({1, -1, ModularGroup.S * ModularGroup.T, -(ModularGroup.S * ModularGroup.T),
+      ModularGroup.T⁻¹ * ModularGroup.S, -(ModularGroup.T⁻¹ * ModularGroup.S)} : Finset SL(2, ℤ)))
+    (fun g => (MulAction.mem_stabilizer_iff).trans ModularGroup.stabilizer_ρ)),
+    Nat.card_eq_finsetCard]
+  calc _ ≤ _ + 1 := Finset.card_insert_le _ _
+    _ ≤ _ + 1 + 1 := by gcongr; exact Finset.card_insert_le _ _
+    _ ≤ 4 + 1 + 1 := by gcongr; exact Finset.card_le_four
+    _ = 6 := rfl
+
+section Analytic
+
+variable (M : ℕ) [NeZero M]
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (LevelN.ring M) K]
+  [IsScalarTower ℂ (LevelN.ring M) K] [IsFractionRing (LevelN.ring M) K]
+
+abbrev jK : K := algebraMap (LevelN.ring M) K (LevelN.jGen M)
+
+theorem mdifferentiable_jAnalytic : MDiff LevelN.jAnalytic := by
+  have h4 : MDiff (ModularForm.E₄ : ℍ → ℂ) := ModularForm.E₄.holo'
+  have hΔ : MDiff (ModularForm.discriminant : ℍ → ℂ) := CuspForm.discriminant.holo'
+  have : LevelN.jAnalytic = fun τ => ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ := rfl
+  rw [this]
+  exact (h4.pow 3).div hΔ fun τ => ModularForm.discriminant_ne_zero τ
+
+theorem analyticAt_comp_ofComplex {G : ℍ → ℂ} (hG : MDiff G) (τ : ℍ) :
+    AnalyticAt ℂ (G ∘ ofComplex) τ := by
+  have hd : DifferentiableOn ℂ (G ∘ ofComplex) {w : ℂ | 0 < w.im} :=
+    UpperHalfPlane.mdifferentiable_iff.mp hG
+  exact (hd.analyticOnNhd isOpen_upperHalfPlaneSet) τ τ.im_pos
+
+@[scoped simp] theorem comp_ofComplex_apply_coe (G : ℍ → ℂ) (τ : ℍ) :
+    (G ∘ ofComplex) (τ : ℂ) = G τ := by
+  simp [Function.comp_apply, ofComplex_apply]
+
+theorem analyticOrderAt_jsub (τ₀ : ℍ) :
+    analyticOrderAt ((fun τ : ℍ => LevelN.jAnalytic τ - LevelN.jAnalytic τ₀) ∘ ofComplex) (τ₀ : ℂ) =
+      ((Nat.card (MulAction.stabilizer SL(2, ℤ) τ₀) / 2 : ℕ) : ℕ∞) := by
+  have hmero :=
+    ModularCurve.meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two τ₀
+  have hfun : (fun z : ℂ => (ModularForm.E₄ : ℍ → ℂ) (ofComplex z) ^ 3 / ModularForm.discriminant
+    (ofComplex z)
+      - (ModularForm.E₄ : ℍ → ℂ) τ₀ ^ 3 / ModularForm.discriminant τ₀) =
+      ((fun τ : ℍ => LevelN.jAnalytic τ - LevelN.jAnalytic τ₀) ∘ ofComplex) := by
+    funext z; rfl
+  rw [hfun] at hmero
+  have han : AnalyticAt ℂ ((fun τ : ℍ => LevelN.jAnalytic τ - LevelN.jAnalytic τ₀) ∘ ofComplex) τ₀
+    :=
+    analyticAt_comp_ofComplex ((mdifferentiable_jAnalytic).sub mdifferentiable_const) τ₀
+  rw [han.meromorphicOrderAt_eq] at hmero
+  generalize analyticOrderAt ((fun τ : ℍ => LevelN.jAnalytic τ - LevelN.jAnalytic τ₀) ∘ ofComplex)
+    (τ₀ : ℂ) = n at hmero ⊢
+  induction n using ENat.recTopCoe with
+  | top => exact absurd hmero (by simp)
+  | coe m =>
+    simp only [ENat.map_natCast, WithTop.coe_eq_coe, Nat.cast_inj] at hmero
+    exact_mod_cast hmero
+
+omit [NeZero M] in
+theorem coe_algebraMap_ring (c : ℂ) :
+    ((algebraMap ℂ (LevelN.ring M) c : LevelN.ring M) : ℍ → ℂ) = fun _ => c := by
+  funext τ
+  simp [Algebra.algebraMap_eq_smul_one]
+
+omit [NeZero M] in
+theorem jsub_mem (c : ℂ) : (fun τ : ℍ => LevelN.jAnalytic τ - c) ∈ LevelN.ring M := by
+  have : (fun τ : ℍ => LevelN.jAnalytic τ - c) =
+      ((LevelN.jGen M - algebraMap ℂ (LevelN.ring M) c : LevelN.ring M) : ℍ → ℂ) := by
+    funext τ
+    simp [LevelN.coe_jGen, Algebra.algebraMap_eq_smul_one]
+  rw [this]
+  exact (LevelN.jGen M - algebraMap ℂ (LevelN.ring M) c).2
+
+omit [IsFractionRing (↥(ring M)) K] in
+omit [NeZero M] in
+theorem algebraMap_jsub (c : ℂ) :
+    algebraMap (LevelN.ring M) K ⟨fun τ : ℍ => LevelN.jAnalytic τ - c, jsub_mem M c⟩ =
+      jK M K - algebraMap ℂ K c := by
+  have : (⟨fun τ : ℍ => LevelN.jAnalytic τ - c, jsub_mem M c⟩ : LevelN.ring M) =
+      LevelN.jGen M - algebraMap ℂ (LevelN.ring M) c := by
+    apply Subtype.ext
+    funext τ
+    simp [LevelN.coe_jGen, Algebra.algebraMap_eq_smul_one]
+  rw [this, map_sub, ← IsScalarTower.algebraMap_apply]
+
+omit [IsFractionRing (↥(ring M)) K] in
+omit [NeZero M] in
+theorem ord_jsub_bounds (τ₀ : ℍ) (W : Place ℂ K) (e : ℕ) (he : 0 < e)
+    (hW : ∀ (F : ℍ → ℂ) (hF : F ∈ LevelN.ring M), F ≠ 0 →
+      analyticOrderAt (F ∘ ofComplex) (τ₀ : ℂ) ≠ ⊤ ∧
+      ((analyticOrderAt (F ∘ ofComplex) (τ₀ : ℂ)).toNat : ℤ) = e * W.ord (algebraMap (LevelN.ring M)
+        K ⟨F, hF⟩)) :
+    0 < W.ord (jK M K - algebraMap ℂ K (LevelN.jAnalytic τ₀)) ∧
+      (e : ℤ) * W.ord (jK M K - algebraMap ℂ K (LevelN.jAnalytic τ₀)) =
+        (Nat.card (MulAction.stabilizer SL(2, ℤ) τ₀) / 2 : ℕ) := by
+  obtain ⟨hfin, hord⟩ :=
+    hW (fun τ : ℍ => LevelN.jAnalytic τ - LevelN.jAnalytic τ₀) (jsub_mem M _) (jAnalytic_sub_ne_zero
+      _)
+  rw [algebraMap_jsub] at hord
+  rw [analyticOrderAt_jsub] at hord
+  simp only [ENat.toNat_natCast] at hord
+  have hpos : 0 < (Nat.card (MulAction.stabilizer SL(2, ℤ) τ₀) / 2 : ℕ) := by
+    have h := analyticOrderAt_jsub τ₀
+    have hne : analyticOrderAt ((fun τ : ℍ => LevelN.jAnalytic τ - LevelN.jAnalytic τ₀) ∘ ofComplex)
+      (τ₀ : ℂ) ≠ 0 :=
+      by
+      rw [analyticOrderAt_ne_zero]
+      exact ⟨analyticAt_comp_ofComplex ((mdifferentiable_jAnalytic).sub mdifferentiable_const)
+        τ₀, by
+        simp⟩
+    rw [h] at hne
+    exact Nat.pos_of_ne_zero fun h0 => hne (by rw [h0]; rfl)
+  refine ⟨?_, hord.symm⟩
+  have he1 : (1 : ℤ) ≤ e := by exact_mod_cast he
+  by_contra hle
+  push Not at hle
+  have : (e : ℤ) * W.ord (jK M K - algebraMap ℂ K (LevelN.jAnalytic τ₀)) ≤ 0 :=
+    mul_nonpos_of_nonneg_of_nonpos (by omega) hle
+  omega
+
+end Analytic
+
+section Galois
+
+variable (M : ℕ) [NeZero M]
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (LevelN.ring M) K]
+  [IsScalarTower ℂ (LevelN.ring M) K] [IsFractionRing (LevelN.ring M) K]
+
+omit [NeZero M] in
+theorem isDomain_ring (K' : Type*) [Field K'] [Algebra (LevelN.ring M) K']
+    [IsFractionRing (LevelN.ring M) K'] :
+    IsDomain (LevelN.ring M) :=
+  (IsFractionRing.injective (LevelN.ring M) K').isDomain (algebraMap (LevelN.ring M) K')
+
+theorem apply_eq_self_of_mem_adjoin (t : K) (ψ : K →ₐ[ℂ] K) (ht : ψ t = t) (z : K) (hz : z ∈ ℂ⟮t⟯) :
+    ψ z = z := by
+  let S : IntermediateField ℂ K :=
+    (AlgHom.equalizer ψ (AlgHom.id ℂ K)).toIntermediateField (fun x hx => by
+    simp only [AlgHom.mem_equalizer, AlgHom.coe_id, id_eq] at hx ⊢
+    rw [map_inv₀, hx])
+  have hle : ℂ⟮t⟯ ≤ S := by
+    rw [IntermediateField.adjoin_le_iff, Set.singleton_subset_iff]
+    change ψ t = AlgHom.id ℂ K t
+    rw [ht]; rfl
+  exact hle hz
+
+theorem isIntegral_of_apply_eq (t : K) (hfin : FiniteDimensional ℂ⟮t⟯ K) (ψ : K →ₐ[ℂ] K)
+    (ht : ψ t = t) :
+    ψ.toRingHom.IsIntegral := by
+  intro y
+  have : Algebra.IsIntegral ℂ⟮t⟯ K := Algebra.IsIntegral.of_finite ℂ⟮t⟯ K
+  obtain ⟨p, hp, hpy⟩ := Algebra.IsIntegral.isIntegral (R := ℂ⟮t⟯) y
+  refine ⟨p.map (algebraMap ℂ⟮t⟯ K), hp.map _, ?_⟩
+  rw [Polynomial.eval₂_map]
+  have hcomp : ψ.toRingHom.comp (algebraMap ℂ⟮t⟯ K) = algebraMap ℂ⟮t⟯ K :=
+    RingHom.ext fun z => apply_eq_self_of_mem_adjoin K t ψ ht z z.2
+  rw [hcomp]
+  exact hpy
+
+def liftGal (t : K) (φ : K ≃ₐ[ℂ] K) (hφ : ∀ z ∈ ℂ⟮t⟯, φ z = z) : K ≃ₐ[ℂ⟮t⟯] K :=
+  { φ.toRingEquiv with commutes' := fun z => hφ z z.2 }
+
+theorem liftGal_apply (t : K) (φ : K ≃ₐ[ℂ] K) (hφ : ∀ z ∈ ℂ⟮t⟯, φ z = z) (y : K) :
+    liftGal K t φ hφ y = φ y := rfl
+
+theorem restrictScalars_liftGal (t : K) (φ : K ≃ₐ[ℂ] K) (hφ : ∀ z ∈ ℂ⟮t⟯, φ z = z) :
+    (liftGal K t φ hφ).restrictScalars ℂ = φ := AlgEquiv.ext fun _ => rfl
+
+def rS (t : K) : (K ≃ₐ[ℂ⟮t⟯] K) →* (K ≃ₐ[ℂ] K) where
+  toFun g := g.restrictScalars ℂ
+  map_one' := AlgEquiv.ext fun _ => rfl
+  map_mul' _ _ := AlgEquiv.ext fun _ => rfl
+
+theorem rS_injective (t : K) : Function.Injective (rS K t) := fun g h hgh =>
+  AlgEquiv.ext fun y => by
+    have := congrArg (fun f : K ≃ₐ[ℂ] K => f y) hgh
+    exact this
+
+theorem ofAlgAut_smul (φ : K ≃ₐ[ℂ] K) (W : Place ℂ K) : SemilinearAut.ofAlgAut φ • W = φ • W := by
+  apply Place.ext
+  ext y
+  rw [SemilinearAut.smul_toValuationSubring, Place.smul_toValuationSubring,
+    ValuationSubring.mem_pointwise_smul_iff_inv_smul_mem,
+    ValuationSubring.mem_pointwise_smul_iff_inv_smul_mem]
+  rfl
+
+def decomp (t : K) (W : Place ℂ K) : Subgroup (K ≃ₐ[ℂ⟮t⟯] K) where
+  carrier := {g | SemilinearAut.ofAlgAut (g.restrictScalars ℂ) • W = W}
+  one_mem' := by
+    change SemilinearAut.ofAlgAut ((1 : K ≃ₐ[ℂ⟮t⟯] K).restrictScalars ℂ) • W = W
+    rw [show ((1 : K ≃ₐ[ℂ⟮t⟯] K).restrictScalars ℂ) = 1 from AlgEquiv.ext fun _ => rfl, map_one,
+      one_smul]
+  mul_mem' {g h} hg hh := by
+    change SemilinearAut.ofAlgAut ((g * h).restrictScalars ℂ) • W = W
+    rw [show (g * h).restrictScalars ℂ = g.restrictScalars ℂ * h.restrictScalars ℂ from AlgEquiv.ext
+      fun _ => rfl,
+      map_mul, mul_smul]
+    rw [Set.mem_ofPred_eq] at hg hh
+    rw [hh, hg]
+  inv_mem' {g} hg := by
+    change SemilinearAut.ofAlgAut (g⁻¹.restrictScalars ℂ) • W = W
+    rw [show g⁻¹.restrictScalars ℂ = (g.restrictScalars ℂ)⁻¹ from AlgEquiv.ext fun _ => rfl,
+      map_inv, inv_smul_eq_iff]
+    rw [Set.mem_ofPred_eq] at hg
+    exact hg.symm
+
+theorem mem_decomp (t : K) (W : Place ℂ K) (g : K ≃ₐ[ℂ⟮t⟯] K) :
+    g ∈ decomp K t W ↔ SemilinearAut.ofAlgAut (g.restrictScalars ℂ) • W = W := Iff.rfl
+
+theorem core
+    (hst : ∀ (δ : SL(2, ℤ)), ∀ G ∈ LevelN.ring M, (fun τ : ℍ => G (δ • τ)) ∈ LevelN.ring M)
+    (σhom : SL(2, ℤ) →* (K ≃ₐ[ℂ] K))
+    (hσ : ∀ (γ : SL(2, ℤ)) (G : ℍ → ℂ) (hG : G ∈ LevelN.ring M),
+      σhom γ (algebraMap (LevelN.ring M) K ⟨G, hG⟩) =
+        algebraMap (LevelN.ring M) K ⟨fun τ : ℍ => G (γ⁻¹ • τ), hst γ⁻¹ G hG⟩)
+    (hfixed : IntermediateField.fixedField σhom.range = ℂ⟮jK M K⟯)
+    (hfin : FiniteDimensional ℂ⟮jK M K⟯ K) (hgal : IsGalois ℂ⟮jK M K⟯ K)
+    (τ₀ : ℍ) (γ₀ : SL(2, ℤ)) (hγ₀ : γ₀ • τ₀ = τ₀) (p : ℕ) (hp : p.Prime)
+    (hordp : orderOf (σhom γ₀) = p)
+    (hstab : Nat.card (MulAction.stabilizer SL(2, ℤ) τ₀) / 2 ≤ p) :
+    ∃ W : Place ℂ K, W.ord (jK M K - algebraMap ℂ K (LevelN.jAnalytic τ₀)) = p ∧
+      ∀ g : K ≃ₐ[ℂ⟮jK M K⟯] K, SemilinearAut.ofAlgAut (g.restrictScalars ℂ) • W = W →
+        ∃ k : ℕ, g.restrictScalars ℂ = σhom γ₀ ^ k := by
+  have := isDomain_ring M K
+  have := hfin
+  have := hgal
+  obtain ⟨W, e, he, hW⟩ := ModularCurve.LevelN.exists_place_analyticOrderAt_eq_mul_ord M K τ₀
+  obtain ⟨hpos, hmul⟩ := ord_jsub_bounds M K τ₀ W e he hW
+  set a := W.ord (jK M K - algebraMap ℂ K (LevelN.jAnalytic τ₀)) with ha
+  have hφfix : ∀ z ∈ ℂ⟮jK M K⟯, σhom γ₀ z = z := fun z hz => by
+    rw [← hfixed] at hz
+    exact (IntermediateField.mem_fixedField_iff _ z).mp hz _ ⟨γ₀, rfl⟩
+  set g₀ := liftGal K (jK M K) (σhom γ₀) hφfix with hg₀
+  have hfixW : σhom γ₀ • W = W := by
+    refine Place.eq_of_ord_algebraMap_eq (A := LevelN.ring M) _ _ fun b hb => ?_
+    have hb' : (b : ℍ → ℂ) ≠ 0 := by
+      intro h0; apply hb
+      rw [show b = 0 from Subtype.ext h0, map_zero]
+    exact ModularCurve.LevelN.PlaceTransport.ord_smul_place_eq_of_smul_eq M K hst (σhom γ₀) γ₀ (hσ
+      γ₀) τ₀ hγ₀ W e he
+      hW b b.2 hb'
+  have hg₀D : g₀ ∈ decomp K (jK M K) W := by
+    rw [mem_decomp, restrictScalars_liftGal, ofAlgAut_smul, hfixW]
+  have hordg₀ : orderOf g₀ = p := by
+    rw [← orderOf_injective (rS K (jK M K)) (rS_injective K (jK M K)) g₀]
+    change orderOf ((liftGal K (jK M K) (σhom γ₀) hφfix).restrictScalars ℂ) = p
+    rw [restrictScalars_liftGal, hordp]
+  have hDH :=
+    (AlgebraicCurve.Place.ord_restrictAlong_eq_natCard_algHom_of_isGalois ℂ (jK M K) (jK M K)
+    (LevelN.jAnalytic τ₀) (AlgHom.id ℂ K) rfl hfin hgal (isIntegral_of_apply_eq K (jK M K) hfin) W
+      hpos).1
+  have hcardD : Nat.card (decomp K (jK M K) W) = Nat.card {σ : K ≃ₐ[ℂ⟮jK M K⟯] K //
+      SemilinearAut.ofAlgAut (σ.restrictScalars ℂ) • W = W} :=
+    Nat.card_congr (Equiv.subtypeEquivRight fun _ => Iff.rfl)
+  have hdvd : p ∣ Nat.card (decomp K (jK M K) W) := hordg₀ ▸ Subgroup.orderOf_dvd_natCard _ hg₀D
+  rw [hcardD, ← Int.natCast_dvd_natCast, ← hDH] at hdvd
+  rw [← ha] at hdvd
+  have hle : a ≤ p := by
+    have he1 : (1 : ℤ) ≤ e := by exact_mod_cast he
+    have h1 : a ≤ (e : ℤ) * a := le_mul_of_one_le_left hpos.le he1
+    have h2 : ((Nat.card (MulAction.stabilizer SL(2, ℤ) τ₀) / 2 : ℕ) : ℤ) ≤ p :=
+      by exact_mod_cast hstab
+    omega
+  have hpa : (p : ℤ) ≤ a := Int.le_of_dvd hpos hdvd
+  have hap : a = p := le_antisymm hle hpa
+  refine ⟨W, hap, fun g hg => ?_⟩
+  have hzle : Subgroup.zpowers g₀ ≤ decomp K (jK M K) W := (Subgroup.zpowers_le).mpr hg₀D
+  have hcardz : Nat.card (Subgroup.zpowers g₀) = p := by rw [Nat.card_zpowers, hordg₀]
+  have hcardDp : Nat.card (decomp K (jK M K) W) = p := by
+    have h1 : ((Nat.card (decomp K (jK M K) W) : ℕ) : ℤ) = a := by rw [hcardD, ha]; exact hDH.symm
+    have h2 : ((Nat.card (decomp K (jK M K) W) : ℕ) : ℤ) = p := by rw [h1, hap]
+    exact_mod_cast h2
+  have : Finite (decomp K (jK M K) W) :=
+    Nat.finite_of_card_ne_zero (by rw [hcardDp]; exact hp.ne_zero)
+  have hDeq : Subgroup.zpowers g₀ = decomp K (jK M K) W :=
+    Subgroup.eq_of_le_of_card_ge hzle (by rw [hcardz, hcardDp])
+  have hg' : g ∈ Subgroup.zpowers g₀ := by rw [hDeq]; exact hg
+  have hfo : IsOfFinOrder g₀ := orderOf_pos_iff.mp (by rw [hordg₀]; exact hp.pos)
+  obtain ⟨k, hk⟩ := (hfo.mem_powers_iff_mem_zpowers).mpr hg'
+  refine ⟨k, ?_⟩
+  rw [← hk]
+  change rS K (jK M K) (g₀ ^ k) = σhom γ₀ ^ k
+  rw [map_pow]
+  change ((liftGal K (jK M K) (σhom γ₀) hφfix).restrictScalars ℂ) ^ k = σhom γ₀ ^ k
+  rw [restrictScalars_liftGal]
+
+theorem main (hM : 2 ≤ M)
+    (hst : ∀ (δ : SL(2, ℤ)), ∀ G ∈ LevelN.ring M, (fun τ : ℍ => G (δ • τ)) ∈ LevelN.ring M)
+    (σhom : SL(2, ℤ) →* (K ≃ₐ[ℂ] K))
+    (hσ : ∀ (γ : SL(2, ℤ)) (G : ℍ → ℂ) (hG : G ∈ LevelN.ring M),
+      σhom γ (algebraMap (LevelN.ring M) K ⟨G, hG⟩) =
+        algebraMap (LevelN.ring M) K ⟨fun τ : ℍ => G (γ⁻¹ • τ), hst γ⁻¹ G hG⟩)
+    (hker : σhom.ker = CongruenceSubgroup.Gamma M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)))
+    (hfixed : IntermediateField.fixedField σhom.range = ℂ⟮jK M K⟯)
+    (hfin : FiniteDimensional ℂ⟮jK M K⟯ K) (hgal : IsGalois ℂ⟮jK M K⟯ K) :
+    (∃ W : Place ℂ K, W.ord (jK M K) = 3 ∧
+      ∀ g : K ≃ₐ[ℂ⟮jK M K⟯] K, SemilinearAut.ofAlgAut (g.restrictScalars ℂ) • W = W →
+        ∃ k : ℕ, g.restrictScalars ℂ = σhom (ModularGroup.S * ModularGroup.T) ^ k) ∧
+    (∃ W : Place ℂ K, W.ord (jK M K - 1728) = 2 ∧
+      ∀ g : K ≃ₐ[ℂ⟮jK M K⟯] K, SemilinearAut.ofAlgAut (g.restrictScalars ℂ) • W = W →
+        ∃ k : ℕ, g.restrictScalars ℂ = σhom ModularGroup.S ^ k) := by
+  constructor
+  · obtain ⟨W, h1, h2⟩ :=
+      core M K hst σhom hσ hfixed hfin hgal ρ (ModularGroup.S * ModularGroup.T) ST_smul_ρ 3
+      Nat.prime_three (CongruenceSubgroup.orderOf_map_S_mul_T M hM σhom hker)
+      (by have := natCard_stabilizer_ρ_le; omega)
+    rw [jAnalytic_ρ, map_zero, sub_zero] at h1
+    exact ⟨W, h1, h2⟩
+  · obtain ⟨W, h1, h2⟩ :=
+      core M K hst σhom hσ hfixed hfin hgal UpperHalfPlane.I ModularGroup.S S_smul_I 2
+      Nat.prime_two (CongruenceSubgroup.orderOf_map_S M hM σhom hker)
+      (by have := natCard_stabilizer_I_le; omega)
+    rw [jAnalytic_I, map_ofNat] at h1
+    exact ⟨W, h1, h2⟩
+
+end Galois
+
+end ModularCurve.LevelN.Wall
+end
+
+theorem solution
+    (M : ℕ) [NeZero M] (hM : 2 ≤ M)
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring M) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring M) K] [IsFractionRing (ModularCurve.LevelN.ring M) K]
+    (hst : ∀ (δ : SL(2, ℤ)), ∀ G ∈ ModularCurve.LevelN.ring M,
+      (fun τ : UpperHalfPlane => G (δ • τ)) ∈ ModularCurve.LevelN.ring M)
+    (σ : SL(2, ℤ) →* (K ≃ₐ[ℂ] K))
+    (hσ : ∀ (γ : SL(2, ℤ)) (G : UpperHalfPlane → ℂ) (hG : G ∈ ModularCurve.LevelN.ring M),
+      σ γ (algebraMap (ModularCurve.LevelN.ring M) K ⟨G, hG⟩) =
+        algebraMap (ModularCurve.LevelN.ring M) K ⟨fun τ : UpperHalfPlane => G (γ⁻¹ • τ), hst γ⁻¹ G
+          hG⟩)
+    (hker : σ.ker = CongruenceSubgroup.Gamma M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)))
+    (hfixed : IntermediateField.fixedField σ.range =
+      ℂ⟮algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)⟯)
+    (hfin : FiniteDimensional ℂ⟮algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen
+      M)⟯ K)
+    (hgal : IsGalois ℂ⟮algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)⟯ K) :
+    (∃ W : AlgebraicCurve.Place ℂ K,
+      W.ord (algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)) = 3 ∧
+      ∀ g : K ≃ₐ[ℂ⟮algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)⟯] K,
+        AlgebraicCurve.SemilinearAut.ofAlgAut (g.restrictScalars ℂ) • W = W →
+        ∃ k : ℕ, g.restrictScalars ℂ = σ (ModularGroup.S * ModularGroup.T) ^ k) ∧
+    (∃ W : AlgebraicCurve.Place ℂ K,
+      W.ord (algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M) - 1728) = 2 ∧
+      ∀ g : K ≃ₐ[ℂ⟮algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)⟯] K,
+        AlgebraicCurve.SemilinearAut.ofAlgAut (g.restrictScalars ℂ) • W = W →
+        ∃ k : ℕ, g.restrictScalars ℂ = σ ModularGroup.S ^ k) :=
+  ModularCurve.LevelN.Wall.main M K hM hst σ hσ hker hfixed hfin hgal
+
+end S_OVERLONG_d9a2a124
+end P2MW
+export P2MW.S_OVERLONG_d9a2a124
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups IntermediateField
+theorem ModularCurve.LevelN.exists_place_ord_jGen_eq_three_two_and_stabilizer_subset_zpowers
+    (M : ℕ) [NeZero M] (hM : 2 ≤ M)
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring M) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring M) K] [IsFractionRing (ModularCurve.LevelN.ring M) K]
+    (hst : ∀ (δ : SL(2, ℤ)), ∀ G ∈ ModularCurve.LevelN.ring M,
+      (fun τ : UpperHalfPlane => G (δ • τ)) ∈ ModularCurve.LevelN.ring M)
+    (σ : SL(2, ℤ) →* (K ≃ₐ[ℂ] K))
+    (hσ : ∀ (γ : SL(2, ℤ)) (G : UpperHalfPlane → ℂ) (hG : G ∈ ModularCurve.LevelN.ring M),
+      σ γ (algebraMap (ModularCurve.LevelN.ring M) K ⟨G, hG⟩) =
+        algebraMap (ModularCurve.LevelN.ring M) K ⟨fun τ : UpperHalfPlane => G (γ⁻¹ • τ), hst γ⁻¹ G
+          hG⟩)
+    (hker : σ.ker = CongruenceSubgroup.Gamma M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)))
+    (hfixed : IntermediateField.fixedField σ.range =
+      ℂ⟮algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)⟯)
+    (hfin : FiniteDimensional ℂ⟮algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen
+      M)⟯ K)
+    (hgal : IsGalois ℂ⟮algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)⟯ K) :
+    (∃ W : AlgebraicCurve.Place ℂ K,
+      W.ord (algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)) = 3 ∧
+      ∀ g : K ≃ₐ[ℂ⟮algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)⟯] K,
+        AlgebraicCurve.SemilinearAut.ofAlgAut (g.restrictScalars ℂ) • W = W →
+        ∃ k : ℕ, g.restrictScalars ℂ = σ (ModularGroup.S * ModularGroup.T) ^ k) ∧
+    (∃ W : AlgebraicCurve.Place ℂ K,
+      W.ord (algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M) - 1728) = 2 ∧
+      ∀ g : K ≃ₐ[ℂ⟮algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)⟯] K,
+        AlgebraicCurve.SemilinearAut.ofAlgAut (g.restrictScalars ℂ) • W = W →
+        ∃ k : ℕ, g.restrictScalars ℂ = σ ModularGroup.S ^ k) :=
+  solution M hM K hst σ hσ hker hfixed hfin hgal
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_place_ord_jGen_le_two_three_level.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_place_ord_jGen_le_two_three_level.lean
new file mode 100644
index 0000000000..d2c53640e6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_place_ord_jGen_le_two_three_level.lean
@@ -0,0 +1,393 @@
+/-
+Based on Prove2Me node ModularCurve.LevelN.exists_place_ord_jGen_le_two_three_level
+(22403f45-52e1-540f-9ffe-50574b348b25) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e9c18715-395e-5fd7-9ece-36af95baa797
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LevelNFunctionField
+
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlaceMod
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_algHom_laurentSeries
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_algHom_laurentSeries_qExpansion
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_place_analyticOrderAt_eq_mul_ord
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Places over j = 1728, 0, ∞ with bounded order
+
+Theorem statement: `ModularCurve.LevelN.exists_place_ord_jGen_le_two_three_level`
+(`22403f45-52e1-540f-9ffe-50574b348b25`), by Claude, 2026-09-05.
+
+Proof: submission `e9c18715-395e-5fd7-9ece-36af95baa797`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and let $A_N$ denote [`ModularCurve.LevelN.ring
+N`](def/ModularCurve_LevelNFunctionField.html#L28), the $\mathbb{C}$-subalgebra of the algebra of
+functions $\mathbb{H} \to \mathbb{C}$ generated by the function $j = E_4^3/\Delta$ (`jAnalytic`)
+together with all Fricke functions `fricke N v` for nonzero $v \in (\mathbb{Z}/N)^2$. Let $K$ be a
+field carrying a $\mathbb{C}$-algebra structure and an $A_N$-algebra structure, compatible as a
+scalar tower over $\mathbb{C}$, and such that $K$ is a fraction field of $A_N$. Write $j$ also for
+the image in $K$ of the element `jGen N` of $A_N$ given by $E_4^3/\Delta$. Here a place of $K$ over
+$\mathbb{C}$ is a valuation subring of $K$ containing the image of $\mathbb{C}$, distinct from all
+of $K$, and a principal ideal ring; its function $\operatorname{ord}$ is the associated normalised
+additive valuation with values in $\mathbb{Z}$. The assertion is the conjunction of three existence
+statements: there is a place $W$ with $0 < \operatorname{ord}_W(j - 1728) \le 2$; there is a place
+$W$ with $0 < \operatorname{ord}_W(j) \le 3$; and there is a place $W$ with $\operatorname{ord}_W(j)
+< 0$ and $-N \le \operatorname{ord}_W(j)$.
+
+This records, in the language of places of the function field of the modular curve of level $N$ over
+$\mathbb{C}$, that the map $j$ has a point over $j = 1728$ of ramification index at most $2$, a
+point over $j = 0$ of ramification index at most $3$, and a pole of order at most $N$ over the cusp;
+the three places arise from $\tau = i$, $\tau = e^{2\pi i/3}$ and the cusp $i\infty$ in the
+parameter $q_N$. It is used in the degree and ramification estimates for the coverings of modular
+curves, in particular in bounding double cosets by fibres and in the computation of ramification
+indices along the inclusions of $\Gamma_0$- and $\Gamma_H$-level structures.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_LevelN_exists_place_ord_jGen_le_two_three_level.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_LevelN_exists_place_ord_jGen_le_two_three_level
+
+
+open UpperHalfPlane
+open scoped MatrixGroups IntermediateField Manifold
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "LevelN.jAnalytic LevelN.ring LevelN.jGen LevelN.coe_jGen jqModC jGen \
+  order_qExpandC order_jqModC_def jqModC_ne_zero_def LevelN.exists_algHom_laurentSeries_qExpansion \
+  LevelN.exists_place_analyticOrderAt_eq_mul_ord \
+  meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two"
+namespace LevelN
+p2m_export "ModularCurve.LevelN" "jAnalytic ring jGen coe_jGen \
+  exists_algHom_laurentSeries_qExpansion exists_place_analyticOrderAt_eq_mul_ord"
+namespace SpecialRamification
+p2m_open "ModularCurve.LevelN ModularCurve"
+
+theorem E₄_smul (γ : SL(2, ℤ)) (τ : ℍ) :
+    ModularForm.E₄ (γ • τ) = denom γ τ ^ (4 : ℤ) * ModularForm.E₄ τ := by
+  have h := SlashInvariantForm.slash_action_eqn'' (Γ := 𝒮ℒ) (k := (4 : ℤ)) ModularForm.E₄
+    (γ := (γ : GL (Fin 2) ℝ)) ⟨γ, rfl⟩ τ
+  simpa [ModularGroup.sl_moeb] using h
+
+theorem E₆_smul (γ : SL(2, ℤ)) (τ : ℍ) :
+    ModularForm.E₆ (γ • τ) = denom γ τ ^ (6 : ℤ) * ModularForm.E₆ τ := by
+  have h := SlashInvariantForm.slash_action_eqn'' (Γ := 𝒮ℒ) (k := (6 : ℤ)) ModularForm.E₆
+    (γ := (γ : GL (Fin 2) ℝ)) ⟨γ, rfl⟩ τ
+  simpa [ModularGroup.sl_moeb] using h
+
+theorem S_smul_I : ModularGroup.S • UpperHalfPlane.I = UpperHalfPlane.I :=
+  ModularGroup.stabilizer_I.mpr (by simp)
+
+theorem ST_smul_ρ : (ModularGroup.S * ModularGroup.T) • ρ = ρ :=
+  ModularGroup.stabilizer_ρ.mpr (by simp)
+
+theorem TinvS_smul_ρ : (ModularGroup.T⁻¹ * ModularGroup.S) • ρ = ρ :=
+  ModularGroup.stabilizer_ρ.mpr (by simp)
+
+theorem E₆_I : ModularForm.E₆ UpperHalfPlane.I = 0 := by
+  have h := E₆_smul ModularGroup.S UpperHalfPlane.I
+  rw [S_smul_I, ModularGroup.denom_S, UpperHalfPlane.coe_I] at h
+  have hI6 : Complex.I ^ (6 : ℤ) = -1 := by
+    rw [show (6 : ℤ) = ((6 : ℕ) : ℤ) from rfl, zpow_natCast]
+    calc Complex.I ^ 6 = (Complex.I ^ 2) ^ 3 := by ring
+      _ = -1 := by rw [Complex.I_sq]; norm_num
+  rw [hI6] at h
+  linear_combination h / 2
+
+theorem denom_TinvS_ρ :
+    denom (↑(ModularGroup.T⁻¹ * ModularGroup.S) : GL (Fin 2) ℝ) ρ = (ρ : ℂ) := by
+  rw [ModularGroup.denom_apply]
+  have h10 : (ModularGroup.T⁻¹ * ModularGroup.S) 1 0 = 1 := by
+    rw [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_T_inv, ModularGroup.coe_S]
+    simp
+  have h11 : (ModularGroup.T⁻¹ * ModularGroup.S) 1 1 = 0 := by
+    rw [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_T_inv, ModularGroup.coe_S]
+    simp
+  rw [h10, h11]
+  simp
+
+theorem ρ_ne_one : (ρ : ℂ) ≠ 1 := by
+  intro h
+  have := congrArg Complex.im h
+  rw [UpperHalfPlane.coe_im] at this
+  simp only [Complex.one_im] at this
+  exact ρ.im_pos.ne' this
+
+theorem E₄_ρ : ModularForm.E₄ ρ = 0 := by
+  have h := E₄_smul (ModularGroup.T⁻¹ * ModularGroup.S) ρ
+  rw [TinvS_smul_ρ, denom_TinvS_ρ] at h
+  have hρ4 : (ρ : ℂ) ^ (4 : ℤ) = (ρ : ℂ) := by
+    rw [show (4 : ℤ) = ((4 : ℕ) : ℤ) from rfl, zpow_natCast]
+    linear_combination ((ρ : ℂ) ^ 2 - ρ) * ρ_sq
+  rw [hρ4] at h
+  have : ((ρ : ℂ) - 1) * ModularForm.E₄ ρ = 0 := by linear_combination -h
+  rcases mul_eq_zero.mp this with h1 | h1
+  · exact absurd (sub_eq_zero.mp h1) ρ_ne_one
+  · exact h1
+
+theorem jAnalytic_ρ : LevelN.jAnalytic ρ = 0 := by
+  rw [LevelN.jAnalytic, E₄_ρ]
+  simp
+
+theorem jAnalytic_I : LevelN.jAnalytic UpperHalfPlane.I = 1728 := by
+  have hΔ := ModularForm.discriminant_eq_E₄_cube_sub_E₆_sq UpperHalfPlane.I
+  rw [E₆_I] at hΔ
+  have hΔ0 := ModularForm.discriminant_ne_zero UpperHalfPlane.I
+  have hE4 : ModularForm.E₄ UpperHalfPlane.I ≠ 0 := by
+    intro h
+    apply hΔ0
+    rw [hΔ, h]
+    norm_num
+  rw [LevelN.jAnalytic, hΔ]
+  field_simp
+  ring
+
+theorem jAnalytic_sub_ne_zero (c : ℂ) : (fun τ : ℍ => LevelN.jAnalytic τ - c) ≠ 0 := by
+  intro h
+  have h1 := congrFun h ρ
+  have h2 := congrFun h UpperHalfPlane.I
+  simp only [Pi.zero_apply, jAnalytic_ρ, jAnalytic_I] at h1 h2
+  have : (1728 : ℂ) = 0 := by linear_combination h2 - h1
+  norm_num at this
+
+theorem natCard_stabilizer_I_le :
+    Nat.card (MulAction.stabilizer SL(2, ℤ) UpperHalfPlane.I) ≤ 4 := by
+  classical
+  rw [Nat.card_congr (Equiv.subtypeEquivRight
+    (q := fun g => g ∈ ({1, -1, ModularGroup.S, -ModularGroup.S} : Finset SL(2, ℤ)))
+    (fun g => (MulAction.mem_stabilizer_iff).trans ModularGroup.stabilizer_I)),
+    Nat.card_eq_finsetCard]
+  exact Finset.card_le_four
+
+theorem natCard_stabilizer_ρ_le : Nat.card (MulAction.stabilizer SL(2, ℤ) ρ) ≤ 6 := by
+  classical
+  rw [Nat.card_congr (Equiv.subtypeEquivRight
+    (q := fun g => g ∈ ({1, -1, ModularGroup.S * ModularGroup.T, -(ModularGroup.S * ModularGroup.T),
+      ModularGroup.T⁻¹ * ModularGroup.S, -(ModularGroup.T⁻¹ * ModularGroup.S)} : Finset SL(2, ℤ)))
+    (fun g => (MulAction.mem_stabilizer_iff).trans ModularGroup.stabilizer_ρ)),
+    Nat.card_eq_finsetCard]
+  calc _ ≤ _ + 1 := Finset.card_insert_le _ _
+    _ ≤ _ + 1 + 1 := by gcongr; exact Finset.card_insert_le _ _
+    _ ≤ 4 + 1 + 1 := by gcongr; exact Finset.card_le_four
+    _ = 6 := rfl
+
+section Places
+
+variable (M : ℕ) [NeZero M]
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (LevelN.ring M) K]
+  [IsScalarTower ℂ (LevelN.ring M) K] [IsFractionRing (LevelN.ring M) K]
+
+abbrev jK : K := algebraMap (LevelN.ring M) K (LevelN.jGen M)
+
+theorem mdifferentiable_jAnalytic : MDiff LevelN.jAnalytic := by
+  have h4 : MDiff (ModularForm.E₄ : ℍ → ℂ) := ModularForm.E₄.holo'
+  have hΔ : MDiff (ModularForm.discriminant : ℍ → ℂ) := CuspForm.discriminant.holo'
+  have : LevelN.jAnalytic = fun τ => ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ := rfl
+  rw [this]
+  exact (h4.pow 3).div hΔ fun τ => ModularForm.discriminant_ne_zero τ
+
+theorem analyticAt_comp_ofComplex {G : ℍ → ℂ} (hG : MDiff G) (τ : ℍ) :
+    AnalyticAt ℂ (G ∘ ofComplex) τ := by
+  have hd : DifferentiableOn ℂ (G ∘ ofComplex) {w : ℂ | 0 < w.im} :=
+    UpperHalfPlane.mdifferentiable_iff.mp hG
+  exact (hd.analyticOnNhd isOpen_upperHalfPlaneSet) τ τ.im_pos
+
+@[scoped simp] theorem comp_ofComplex_apply_coe (G : ℍ → ℂ) (τ : ℍ) :
+    (G ∘ ofComplex) (τ : ℂ) = G τ := by
+  simp [Function.comp_apply, ofComplex_apply]
+
+theorem analyticOrderAt_jsub (τ₀ : ℍ) :
+    analyticOrderAt ((fun τ : ℍ => LevelN.jAnalytic τ - LevelN.jAnalytic τ₀) ∘ ofComplex) (τ₀ : ℂ) =
+      ((Nat.card (MulAction.stabilizer SL(2, ℤ) τ₀) / 2 : ℕ) : ℕ∞) := by
+  have hmero :=
+    ModularCurve.meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two τ₀
+  have hfun : (fun z : ℂ => (ModularForm.E₄ : ℍ → ℂ) (ofComplex z) ^ 3 / ModularForm.discriminant
+    (ofComplex z)
+      - (ModularForm.E₄ : ℍ → ℂ) τ₀ ^ 3 / ModularForm.discriminant τ₀) =
+      ((fun τ : ℍ => LevelN.jAnalytic τ - LevelN.jAnalytic τ₀) ∘ ofComplex) := by
+    funext z; rfl
+  rw [hfun] at hmero
+  have han : AnalyticAt ℂ ((fun τ : ℍ => LevelN.jAnalytic τ - LevelN.jAnalytic τ₀) ∘ ofComplex) τ₀
+    :=
+    analyticAt_comp_ofComplex ((mdifferentiable_jAnalytic).sub mdifferentiable_const) τ₀
+  rw [han.meromorphicOrderAt_eq] at hmero
+  generalize analyticOrderAt ((fun τ : ℍ => LevelN.jAnalytic τ - LevelN.jAnalytic τ₀) ∘ ofComplex)
+    (τ₀ : ℂ) = n at hmero ⊢
+  induction n using ENat.recTopCoe with
+  | top => exact absurd hmero (by simp)
+  | coe m =>
+    simp only [ENat.map_natCast, WithTop.coe_eq_coe, Nat.cast_inj] at hmero
+    exact_mod_cast hmero
+
+omit [NeZero M] in
+theorem coe_algebraMap_ring (c : ℂ) :
+    ((algebraMap ℂ (LevelN.ring M) c : LevelN.ring M) : ℍ → ℂ) = fun _ => c := by
+  funext τ
+  simp [Algebra.algebraMap_eq_smul_one]
+
+omit [NeZero M] in
+theorem jsub_mem (c : ℂ) : (fun τ : ℍ => LevelN.jAnalytic τ - c) ∈ LevelN.ring M := by
+  have : (fun τ : ℍ => LevelN.jAnalytic τ - c) =
+      ((LevelN.jGen M - algebraMap ℂ (LevelN.ring M) c : LevelN.ring M) : ℍ → ℂ) := by
+    funext τ
+    simp [LevelN.coe_jGen, Algebra.algebraMap_eq_smul_one]
+  rw [this]
+  exact (LevelN.jGen M - algebraMap ℂ (LevelN.ring M) c).2
+
+omit [IsFractionRing (↥(ring M)) K] in
+omit [NeZero M] in
+theorem algebraMap_jsub (c : ℂ) :
+    algebraMap (LevelN.ring M) K ⟨fun τ : ℍ => LevelN.jAnalytic τ - c, jsub_mem M c⟩ =
+      jK M K - algebraMap ℂ K c := by
+  have : (⟨fun τ : ℍ => LevelN.jAnalytic τ - c, jsub_mem M c⟩ : LevelN.ring M) =
+      LevelN.jGen M - algebraMap ℂ (LevelN.ring M) c := by
+    apply Subtype.ext
+    funext τ
+    simp [LevelN.coe_jGen, Algebra.algebraMap_eq_smul_one]
+  rw [this, map_sub, ← IsScalarTower.algebraMap_apply]
+
+theorem exists_place_ord_sub_le (τ₀ : ℍ) :
+    ∃ W : AlgebraicCurve.Place ℂ K,
+      0 < W.ord (jK M K - algebraMap ℂ K (LevelN.jAnalytic τ₀)) ∧
+      W.ord (jK M K - algebraMap ℂ K (LevelN.jAnalytic τ₀)) ≤
+        (Nat.card (MulAction.stabilizer SL(2, ℤ) τ₀) / 2 : ℕ) := by
+  obtain ⟨W, e, he, hW⟩ := ModularCurve.LevelN.exists_place_analyticOrderAt_eq_mul_ord M K τ₀
+  refine ⟨W, ?_⟩
+  obtain ⟨hfin, hord⟩ := hW (fun τ : ℍ => LevelN.jAnalytic τ - LevelN.jAnalytic τ₀)
+    (jsub_mem M _) (jAnalytic_sub_ne_zero _)
+  rw [algebraMap_jsub] at hord
+  rw [analyticOrderAt_jsub] at hord hfin
+  simp only [ENat.toNat_natCast] at hord
+  have hpos : 0 < (Nat.card (MulAction.stabilizer SL(2, ℤ) τ₀) / 2 : ℕ) := by
+    have h := analyticOrderAt_jsub τ₀
+    have hne : analyticOrderAt ((fun τ : ℍ => LevelN.jAnalytic τ - LevelN.jAnalytic τ₀) ∘ ofComplex)
+        (τ₀ : ℂ) ≠ 0 := by
+      rw [analyticOrderAt_ne_zero]
+      exact ⟨analyticAt_comp_ofComplex ((mdifferentiable_jAnalytic).sub mdifferentiable_const) τ₀,
+        by simp⟩
+    rw [h] at hne
+    exact Nat.pos_of_ne_zero fun h0 => hne (by rw [h0]; rfl)
+  set s := (Nat.card (MulAction.stabilizer SL(2, ℤ) τ₀) / 2 : ℕ)
+  set a := W.ord (jK M K - algebraMap ℂ K (LevelN.jAnalytic τ₀))
+  have he1 : (1 : ℤ) ≤ e := by exact_mod_cast he
+  constructor
+  · by_contra hle
+    push Not at hle
+    have : (e : ℤ) * a ≤ 0 := mul_nonpos_of_nonneg_of_nonpos (by omega) hle
+    omega
+  · nlinarith
+
+theorem exists_place_ord_neg_ge :
+    ∃ W : AlgebraicCurve.Place ℂ K, W.ord (jK M K) < 0 ∧ -(M : ℤ) ≤ W.ord (jK M K) := by
+  obtain ⟨E, hEj, -⟩ := ModularCurve.LevelN.exists_algHom_laurentSeries_qExpansion M K
+  have hj0 : jqModC ℂ ≠ 0 := jqModC_ne_zero_def ℂ
+  have hordj : (E (jK M K)).order = -(M : ℤ) := by
+    change (E (algebraMap (LevelN.ring M) K (LevelN.jGen M))).order = _
+    rw [hEj, order_qExpandC ℂ M hj0, order_jqModC_def]
+    ring
+  have hM0 : (0 : ℤ) < M := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne M)
+  obtain ⟨W, γ, hγ, hW⟩ :=
+    AlgebraicCurve.Place.exists_ord_mul_eq_order_of_algHom_laurentSeries ℂ E
+      ⟨jK M K, by rw [hordj]; omega⟩
+  refine ⟨W, ?_, ?_⟩
+  · have h := hW (jK M K)
+    rw [hordj] at h
+    by_contra hle
+    push Not at hle
+    have : 0 ≤ W.ord (jK M K) * (γ : ℤ) := mul_nonneg hle (by exact_mod_cast hγ.le)
+    omega
+  · have h := hW (jK M K)
+    rw [hordj] at h
+    have hγ1 : (1 : ℤ) ≤ γ := by exact_mod_cast hγ
+    nlinarith
+
+theorem main :
+    (∃ W : AlgebraicCurve.Place ℂ K, 0 < W.ord (jK M K - 1728) ∧ W.ord (jK M K - 1728) ≤ 2) ∧
+      (∃ W : AlgebraicCurve.Place ℂ K, 0 < W.ord (jK M K) ∧ W.ord (jK M K) ≤ 3) ∧
+      (∃ W : AlgebraicCurve.Place ℂ K, W.ord (jK M K) < 0 ∧ -(M : ℤ) ≤ W.ord (jK M K)) := by
+  refine ⟨?_, ?_, exists_place_ord_neg_ge M K⟩
+  · obtain ⟨W, h1, h2⟩ := exists_place_ord_sub_le M K UpperHalfPlane.I
+    rw [jAnalytic_I, map_ofNat] at h1 h2
+    refine ⟨W, h1, h2.trans ?_⟩
+    have h4 := natCard_stabilizer_I_le
+    have : Nat.card (MulAction.stabilizer SL(2, ℤ) UpperHalfPlane.I) / 2 ≤ 2 := by omega
+    exact_mod_cast this
+  · obtain ⟨W, h1, h2⟩ := exists_place_ord_sub_le M K ρ
+    rw [jAnalytic_ρ, map_zero, sub_zero] at h1 h2
+    refine ⟨W, h1, h2.trans ?_⟩
+    have h6 := natCard_stabilizer_ρ_le
+    have : Nat.card (MulAction.stabilizer SL(2, ℤ) ρ) / 2 ≤ 3 := by omega
+    exact_mod_cast this
+
+end Places
+
+end ModularCurve.LevelN.SpecialRamification
+end
+
+theorem solution (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring N) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring N) K]
+    [IsFractionRing (ModularCurve.LevelN.ring N) K] :
+    (∃ W : AlgebraicCurve.Place ℂ K,
+        0 < W.ord (algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N) - 1728) ∧
+          W.ord (algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N) - 1728) ≤ 2)
+            ∧
+      (∃ W : AlgebraicCurve.Place ℂ K,
+        0 < W.ord (algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)) ∧
+          W.ord (algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)) ≤ 3) ∧
+      (∃ W : AlgebraicCurve.Place ℂ K,
+        W.ord (algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)) < 0 ∧
+          -(N : ℤ) ≤ W.ord (algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)))
+            :=
+  ModularCurve.LevelN.SpecialRamification.main N K
+
+end S_ModularCurve_LevelN_exists_place_ord_jGen_le_two_three_level
+end P2MW
+export P2MW.S_ModularCurve_LevelN_exists_place_ord_jGen_le_two_three_level (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.LevelN.exists_place_ord_jGen_le_two_three_level (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring N) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring N) K]
+    [IsFractionRing (ModularCurve.LevelN.ring N) K] :
+    (∃ W : AlgebraicCurve.Place ℂ K,
+        0 < W.ord (algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N) - 1728) ∧
+          W.ord (algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N) - 1728) ≤ 2)
+            ∧
+      (∃ W : AlgebraicCurve.Place ℂ K,
+        0 < W.ord (algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)) ∧
+          W.ord (algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)) ≤ 3) ∧
+      (∃ W : AlgebraicCurve.Place ℂ K,
+        W.ord (algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)) < 0 ∧
+          -(N : ℤ) ≤ W.ord (algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)))
+            :=
+  solution N K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_place_ord_neg_forall_smul_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_place_ord_neg_forall_smul_eq.lean
new file mode 100644
index 0000000000..7013d72eae
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_place_ord_neg_forall_smul_eq.lean
@@ -0,0 +1,979 @@
+/-
+Based on Prove2Me node ModularCurve.LevelN.exists_place_ord_neg_forall_smul_eq
+(719c4ac2-c0db-566d-8f34-99ddc4f7baf2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3192dc3a-b65e-57fd-8639-f7b5b210d288
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_BaseChangeGalois
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LevelNFunctionField
+
+import Mathlib.Algebra.CharP.Pi
+import Mathlib.Order.CompletePartialOrder
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_modularity_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_orbit_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelN_structure_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A place with j-pole fixed by the translation automorphism
+
+Theorem statement: `ModularCurve.LevelN.exists_place_ord_neg_forall_smul_eq`
+(`719c4ac2-c0db-566d-8f34-99ddc4f7baf2`), by Claude, 2026-09-05.
+
+Proof: submission `3192dc3a-b65e-57fd-8639-f7b5b210d288`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N \ge 1$ and write [`ModularCurve.LevelN.ring
+N`](def/ModularCurve_LevelNFunctionField.html#L28) for the $\mathbb C$-subalgebra of the algebra of
+all functions $\mathbb H \to \mathbb C$ generated by the function $\tau \mapsto
+E_4(\tau)^3/\Delta(\tau)$ together with the functions `fricke N v` for all nonzero $v \in (\mathbb
+Z/N)^2$. Let $K$ be a field carrying algebra structures over $\mathbb C$ and over this subalgebra,
+compatibly (scalar tower), and such that $K$ is a fraction field of the subalgebra. Assume that the
+subalgebra is stable under the substitution $F \mapsto (\tau \mapsto F(T^{-1}\cdot\tau))$, where $T$
+is the standard translation matrix in $\mathrm{SL}_2(\mathbb Z)$. Then there is a place $W$ of $K$
+over $\mathbb C$, that is, a valuation subring of $K$ containing the image of $\mathbb C$, different
+from all of $K$, and a principal ideal ring, such that: (i) the associated normalised order
+function, $\operatorname{ord}_W = -\log$ of the adic valuation attached to the height-one prime of
+$W$, is strictly negative on the image in $K$ of the generator $E_4^3/\Delta$; and (ii) every
+$\mathbb C$-algebra automorphism $\varphi$ of $K$ which sends (the image of) each $F$ in the
+subalgebra to (the image of) $\tau \mapsto F(T^{-1}\cdot\tau)$ fixes $W$, for the action on places
+of the semilinear automorphism $(\varphi, \mathrm{id}_{\mathbb C})$ attached to $\varphi$.
+
+The place produced is the cusp $i\infty$ of the modular curve of level $N$, described through the
+order of vanishing in the local parameter $q_N = e^{2\pi i \tau/N}$; at it $j$ has a pole, and it is
+visibly invariant under the automorphism induced by $\tau \mapsto \tau+1$. It feeds the genus and
+degree estimates for the function field of level $N$ and the counting of fibres of the $j$-map over
+double cosets.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_LevelN_exists_place_ord_neg_forall_smul_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_LevelN_exists_place_ord_neg_forall_smul_eq
+
+
+open UpperHalfPlane Filter Topology Function
+open scoped MatrixGroups Manifold Real
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "LevelN.ring LevelN.jGen"
+namespace LevelN
+p2m_export "ModularCurve.LevelN" "wp fricke jAnalytic generators ring jAnalytic_mem jGen coe_jGen"
+namespace CuspPlaces
+p2m_open "ModularCurve.LevelN ModularCurve"
+
+section Toolkit
+
+variable {h : ℝ}
+
+structure Good (h : ℝ) (G : ℍ → ℂ) : Prop where
+  periodic : Periodic (G ∘ ofComplex) h
+  mdiff : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G
+  bdd : IsBoundedAtImInfty G
+
+namespace Good
+
+variable {G G₁ G₂ : ℍ → ℂ}
+
+theorem analyticAt (hG : Good h G) (hh : 0 < h) : AnalyticAt ℂ (cuspFunction h G) 0 :=
+  analyticAt_cuspFunction_zero hh hG.periodic hG.mdiff hG.bdd
+
+theorem continuousAt (hG : Good h G) (hh : 0 < h) : ContinuousAt (cuspFunction h G) 0 :=
+  (hG.analyticAt hh).continuousAt
+
+theorem mul (h₁ : Good h G₁) (h₂ : Good h G₂) : Good h (G₁ * G₂) where
+  periodic := by
+    have : (G₁ * G₂) ∘ ofComplex = (G₁ ∘ ofComplex) * (G₂ ∘ ofComplex) := rfl
+    rw [this]
+    exact h₁.periodic.mul h₂.periodic
+  mdiff := h₁.mdiff.mul h₂.mdiff
+  bdd := h₁.bdd.mul h₂.bdd
+
+theorem add (h₁ : Good h G₁) (h₂ : Good h G₂) : Good h (G₁ + G₂) where
+  periodic := by
+    have : (G₁ + G₂) ∘ ofComplex = (G₁ ∘ ofComplex) + (G₂ ∘ ofComplex) := rfl
+    rw [this]
+    exact h₁.periodic.add h₂.periodic
+  mdiff := h₁.mdiff.add h₂.mdiff
+  bdd := h₁.bdd.add h₂.bdd
+
+theorem const (h : ℝ) (c : ℂ) : Good h (fun _ : ℍ => c) where
+  periodic := fun _ => rfl
+  mdiff := mdifferentiable_const
+  bdd := Filter.const_boundedAtFilter _ _
+
+theorem one (h : ℝ) : Good h (1 : ℍ → ℂ) := const h 1
+
+theorem pow (hG : Good h G) : ∀ n : ℕ, Good h (G ^ n)
+  | 0 => by rw [pow_zero]; exact one h
+  | n + 1 => by rw [pow_succ]; exact (pow hG n).mul hG
+
+end Good
+
+variable {G G₁ G₂ : ℍ → ℂ}
+
+theorem cuspFunction_mul_of_good (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) :
+    cuspFunction h (G₁ * G₂) = cuspFunction h G₁ * cuspFunction h G₂ :=
+  cuspFunction_mul (h₁.continuousAt hh) (h₂.continuousAt hh)
+
+theorem cuspFunction_add_of_good (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) :
+    cuspFunction h (G₁ + G₂) = cuspFunction h G₁ + cuspFunction h G₂ :=
+  cuspFunction_add (h₁.continuousAt hh) (h₂.continuousAt hh)
+
+theorem norm_qParam_lt_one (hh : 0 < h) (τ : ℍ) : ‖Periodic.qParam h τ‖ < 1 := by
+  have := (Periodic.norm_qParam_lt_iff hh 0 (τ : ℂ)).mpr (by simpa using τ.im_pos)
+  simpa using this
+
+theorem Good.eq_zero_of_analyticOrderAt_eq_top (hG : Good h G) (hh : 0 < h)
+    (htop : analyticOrderAt (cuspFunction h G) 0 = ⊤) : G = 0 := by
+  have han : AnalyticOnNhd ℂ (cuspFunction h G) (Metric.ball 0 1) :=
+    (differentiableOn_cuspFunction_ball hh hG.periodic hG.mdiff hG.bdd).analyticOnNhd
+      Metric.isOpen_ball
+  have hzero : Set.EqOn (cuspFunction h G) 0 (Metric.ball 0 1) :=
+    han.eqOn_zero_of_preconnected_of_eventuallyEq_zero
+      (convex_ball (0 : ℂ) 1).isPreconnected (Metric.mem_ball_self one_pos)
+      (analyticOrderAt_eq_top.mp htop)
+  funext τ
+  have hq : Periodic.qParam h τ ∈ Metric.ball (0 : ℂ) 1 := by
+    rw [Metric.mem_ball, dist_zero_right]
+    exact norm_qParam_lt_one hh τ
+  have := hzero hq
+  rw [eq_cuspFunction τ hh.ne' hG.periodic] at this
+  simpa using this
+
+theorem Good.analyticOrderAt_ne_top (hG : Good h G) (hh : 0 < h) (hG0 : G ≠ 0) :
+    analyticOrderAt (cuspFunction h G) 0 ≠ ⊤ :=
+  fun htop => hG0 (hG.eq_zero_of_analyticOrderAt_eq_top hh htop)
+
+def ordB (h : ℝ) (G : ℍ → ℂ) : ℕ := (analyticOrderAt (cuspFunction h G) 0).toNat
+
+theorem ordB_cast (hG : Good h G) (hh : 0 < h) (hG0 : G ≠ 0) :
+    (ordB h G : ℕ∞) = analyticOrderAt (cuspFunction h G) 0 :=
+  ENat.natCast_toNat (hG.analyticOrderAt_ne_top hh hG0)
+
+theorem ordB_mul (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) (h₁0 : G₁ ≠ 0) (h₂0 : G₂ ≠ 0) :
+    ordB h (G₁ * G₂) = ordB h G₁ + ordB h G₂ := by
+  have hmul := analyticOrderAt_mul (h₁.analyticAt hh) (h₂.analyticAt hh)
+  unfold ordB
+  rw [cuspFunction_mul_of_good hh h₁ h₂, hmul]
+  exact ENat.toNat_add (h₁.analyticOrderAt_ne_top hh h₁0) (h₂.analyticOrderAt_ne_top hh h₂0)
+
+theorem min_ordB_le_ordB_add (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) (h₁0 : G₁ ≠ 0)
+    (h₂0 : G₂ ≠ 0) (h0 : G₁ + G₂ ≠ 0) :
+    min (ordB h G₁) (ordB h G₂) ≤ ordB h (G₁ + G₂) := by
+  have hle := le_analyticOrderAt_add (f := cuspFunction h G₁) (g := cuspFunction h G₂) (z₀ := 0)
+  rw [← cuspFunction_add_of_good hh h₁ h₂, ← ordB_cast h₁ hh h₁0, ← ordB_cast h₂ hh h₂0,
+    ← ordB_cast (h₁.add h₂) hh h0] at hle
+  rcases le_total (ordB h G₁) (ordB h G₂) with hle' | hle'
+  · rw [min_eq_left hle']
+    rw [min_eq_left (by exact_mod_cast hle')] at hle
+    exact_mod_cast hle
+  · rw [min_eq_right hle']
+    rw [min_eq_right (by exact_mod_cast hle')] at hle
+    exact_mod_cast hle
+
+theorem ordB_eq_zero_of_apply_ne_zero (h0 : cuspFunction h G 0 ≠ 0) : ordB h G = 0 := by
+  unfold ordB
+  rw [analyticOrderAt_eq_zero.mpr (Or.inr h0)]
+  rfl
+
+theorem ordB_pos (hG : Good h G) (hh : 0 < h) (hG0 : G ≠ 0) (h0 : cuspFunction h G 0 = 0) :
+    0 < ordB h G := by
+  have hne : analyticOrderAt (cuspFunction h G) 0 ≠ 0 :=
+    (hG.analyticAt hh).analyticOrderAt_ne_zero.mpr h0
+  have hcast := ordB_cast hG hh hG0
+  by_contra hle
+  push Not at hle
+  rw [Nat.le_zero.mp hle, Nat.cast_zero] at hcast
+  exact hne hcast.symm
+
+theorem T_inv_smul_eq_vadd (τ : ℍ) : ModularGroup.T⁻¹ • τ = (-1 : ℝ) +ᵥ τ := by
+  have := modular_T_zpow_smul τ (-1)
+  rw [zpow_neg_one] at this
+  rw [this]
+  norm_num
+
+theorem coe_T_inv_smul (τ : ℍ) : ((ModularGroup.T⁻¹ • τ : ℍ) : ℂ) = (τ : ℂ) - 1 := by
+  rw [T_inv_smul_eq_vadd, coe_vadd]
+  push_cast
+  ring
+
+def zetaInv (h : ℝ) : ℂ := Complex.exp (-(2 * π * Complex.I / h))
+
+theorem zetaInv_ne_zero (h : ℝ) : zetaInv h ≠ 0 := Complex.exp_ne_zero _
+
+theorem qParam_sub_one (h : ℝ) (z : ℂ) :
+    Periodic.qParam h (z - 1) = zetaInv h * Periodic.qParam h z := by
+  simp only [Periodic.qParam, zetaInv, ← Complex.exp_add]
+  congr 1
+  ring
+
+theorem cuspFunction_comp_T_inv_eventuallyEq_nhdsNE (hh : 0 < h) (hG : Good h G) :
+    cuspFunction h (fun τ : ℍ => G (ModularGroup.T⁻¹ • τ)) =ᶠ[𝓝[≠] 0]
+      (fun q => cuspFunction h G (zetaInv h * q)) := by
+  have hball : Metric.ball (0 : ℂ) 1 ∈ 𝓝 (0 : ℂ) := Metric.ball_mem_nhds 0 one_pos
+  filter_upwards [self_mem_nhdsWithin, mem_nhdsWithin_of_mem_nhds hball] with q hq hq1
+  have hq0 : q ≠ 0 := hq
+  rw [Metric.mem_ball, dist_zero_right] at hq1
+  rw [cuspFunction, Periodic.cuspFunction_eq_of_nonzero _ _ hq0]
+  set z := Periodic.invQParam h q with hz
+  have hzim : 0 < z.im := Periodic.im_invQParam_pos_of_norm_lt_one hh hq1 hq0
+  simp only [Function.comp_apply, ofComplex_apply_of_im_pos hzim]
+  have hpt : ModularGroup.T⁻¹ • (⟨z, hzim⟩ : ℍ) = ofComplex (z - 1) := by
+    have hzim' : 0 < (z - 1).im := by simpa using hzim
+    rw [ofComplex_apply_of_im_pos hzim']
+    ext1
+    rw [coe_T_inv_smul]
+  rw [hpt]
+  have := eq_cuspFunction (f := G) (ofComplex (z - 1)) hh.ne' hG.periodic
+  rw [← Function.comp_apply (f := G) (g := ofComplex), show ((ofComplex (z - 1) : ℍ) : ℂ) = z - 1 by
+    rw [ofComplex_apply_of_im_pos (by simpa using hzim : 0 < (z - 1).im)]] at this
+  rw [Function.comp_apply] at this
+  rw [← this, qParam_sub_one, hz, Periodic.qParam_right_inv hh.ne' hq0]
+
+theorem cuspFunction_comp_T_inv_eventuallyEq (hh : 0 < h) (hG : Good h G)
+    (hG₁ : Good h (fun τ : ℍ => G (ModularGroup.T⁻¹ • τ))) :
+    cuspFunction h (fun τ : ℍ => G (ModularGroup.T⁻¹ • τ)) =ᶠ[𝓝 0]
+      (fun q => cuspFunction h G (zetaInv h * q)) := by
+  have hc1 : ContinuousAt (cuspFunction h (fun τ : ℍ => G (ModularGroup.T⁻¹ • τ))) 0 :=
+    hG₁.continuousAt hh
+  have hc2 : ContinuousAt (fun q => cuspFunction h G (zetaInv h * q)) 0 := by
+    have h1 : ContinuousAt (cuspFunction h G) (zetaInv h * 0) := by
+      rw [mul_zero]; exact hG.continuousAt hh
+    exact ContinuousAt.comp (g := cuspFunction h G) h1 (continuous_const.mul
+      continuous_id).continuousAt
+  exact (hc1.eventuallyEq_nhds_iff_eventuallyEq_nhdsNE hc2).mp
+    (cuspFunction_comp_T_inv_eventuallyEq_nhdsNE hh hG)
+
+theorem ordB_comp_T_inv (hh : 0 < h) (hG : Good h G)
+    (hG₁ : Good h (fun τ : ℍ => G (ModularGroup.T⁻¹ • τ))) :
+    ordB h (fun τ : ℍ => G (ModularGroup.T⁻¹ • τ)) = ordB h G := by
+  unfold ordB
+  rw [analyticOrderAt_congr (cuspFunction_comp_T_inv_eventuallyEq hh hG hG₁),
+    show (fun q => cuspFunction h G (zetaInv h * q)) = cuspFunction h G ∘ (fun q => zetaInv h * q)
+      from rfl,
+    analyticOrderAt_comp_of_deriv_ne_zero (analyticAt_const.mul analyticAt_id) (by
+      rw [show (fun q : ℂ => zetaInv h * q) = fun q => q * zetaInv h from funext fun q => mul_comm _
+        _,
+        deriv_mul_const_field, deriv_id'', one_mul]
+      exact zetaInv_ne_zero h),
+    mul_zero]
+
+end Toolkit
+
+section LevelOne
+
+local notation "Δ" => ModularForm.discriminant
+
+theorem natCast_mem_strictPeriods (N : ℕ) : (N : ℝ) ∈ (𝒮ℒ).strictPeriods := by
+  simp only [Subgroup.strictPeriods_SL2Z]
+  exact ⟨N, by simp⟩
+
+theorem good_discriminant (N : ℕ) : Good N Δ where
+  periodic := by
+    have := SlashInvariantFormClass.periodic_comp_ofComplex CuspForm.discriminant
+      (natCast_mem_strictPeriods N)
+    simpa using this
+  mdiff := CuspForm.discriminant.holo'
+  bdd := ModularForm.discriminant_isZeroAtImInfty.isBoundedAtImInfty
+
+theorem good_E₄ (N : ℕ) : Good N (ModularForm.E₄ : ℍ → ℂ) where
+  periodic := SlashInvariantFormClass.periodic_comp_ofComplex ModularForm.E₄
+      (natCast_mem_strictPeriods N)
+  mdiff := ModularForm.E₄.holo'
+  bdd := ModularFormClass.bdd_at_infty ModularForm.E₄
+
+theorem discriminant_ne_zero' : (Δ : ℍ → ℂ) ≠ 0 := by
+  intro h0
+  have := congrFun h0 UpperHalfPlane.I
+  exact ModularForm.discriminant_ne_zero _ this
+
+theorem discriminant_pow_ne_zero (m : ℕ) : ((Δ : ℍ → ℂ) ^ m) ≠ 0 := by
+  intro h0
+  have := congrFun h0 UpperHalfPlane.I
+  simp only [Pi.pow_apply, Pi.zero_apply, pow_eq_zero_iff', ne_eq] at this
+  exact ModularForm.discriminant_ne_zero _ this.1
+
+theorem mul_discriminant_pow_eq_zero_iff (F : ℍ → ℂ) (m : ℕ) :
+    F * (Δ : ℍ → ℂ) ^ m = 0 ↔ F = 0 := by
+  constructor
+  · intro h0
+    funext τ
+    have := congrFun h0 τ
+    simp only [Pi.mul_apply, Pi.pow_apply, Pi.zero_apply, mul_eq_zero, pow_eq_zero_iff',
+      ne_eq] at this
+    rcases this with h1 | ⟨h1, _⟩
+    · exact h1
+    · exact absurd h1 (ModularForm.discriminant_ne_zero τ)
+  · rintro rfl
+    exact zero_mul _
+
+theorem cuspFunction_discriminant_zero (N : ℕ) [NeZero N] :
+    cuspFunction N Δ 0 = 0 := by
+  have hN : (0 : ℝ) < N := Nat.cast_pos.mpr (NeZero.pos N)
+  rw [cuspFunction_apply_zero hN ((good_discriminant N).analyticAt hN) (good_discriminant
+    N).periodic]
+  exact ModularForm.discriminant_isZeroAtImInfty.valueAtInfty_eq_zero
+
+theorem ordB_discriminant_pos (N : ℕ) [NeZero N] : 0 < ordB N Δ := by
+  have hN : (0 : ℝ) < N := Nat.cast_pos.mpr (NeZero.pos N)
+  exact ordB_pos (good_discriminant N) hN discriminant_ne_zero' (cuspFunction_discriminant_zero N)
+
+theorem cuspFunction_E₄_zero (N : ℕ) [NeZero N] :
+    cuspFunction N (ModularForm.E₄ : ℍ → ℂ) 0 = 1 := by
+  have hN : (0 : ℝ) < N := Nat.cast_pos.mpr (NeZero.pos N)
+  rw [cuspFunction_apply_zero hN ((good_E₄ N).analyticAt hN) (good_E₄ N).periodic]
+  have h1 := qExpansion_coeff_zero (f := (ModularForm.E₄ : ℍ → ℂ)) one_pos
+    (by simpa using (good_E₄ 1).analyticAt (by exact_mod_cast one_pos))
+    (by simpa using (good_E₄ 1).periodic)
+  rw [← h1]
+  exact EisensteinSeries.E_qExpansion_coeff_zero (k := 4) (by norm_num) (by decide)
+
+theorem ordB_E₄_pow (N : ℕ) [NeZero N] (n : ℕ) : ordB N ((ModularForm.E₄ : ℍ → ℂ) ^ n) = 0 := by
+  have hN : (0 : ℝ) < N := Nat.cast_pos.mpr (NeZero.pos N)
+  apply ordB_eq_zero_of_apply_ne_zero
+  induction n with
+  | zero =>
+    rw [pow_zero]
+    have : cuspFunction (N : ℝ) (1 : ℍ → ℂ) 0 = 1 := by
+      rw [cuspFunction_apply_zero hN ((Good.one (N : ℝ)).analyticAt hN) (Good.one (N : ℝ)).periodic]
+      exact tendsto_const_nhds.limUnder_eq
+    rw [this]; exact one_ne_zero
+  | succ n ih =>
+    rw [pow_succ, cuspFunction_mul_of_good hN ((good_E₄ N).pow n) (good_E₄ N), Pi.mul_apply,
+      cuspFunction_E₄_zero]
+    simpa using ih
+
+theorem discriminant_T_inv_smul (τ : ℍ) : Δ (ModularGroup.T⁻¹ • τ) = Δ τ := by
+  have hper : Periodic (ModularForm.discriminant ∘ ofComplex) 1 := by
+    simpa using (good_discriminant 1).periodic
+  have him : 0 < ((τ : ℂ) - 1).im := by simpa using τ.im_pos
+  have h1 : (ModularGroup.T⁻¹ • τ : ℍ) = ofComplex ((τ : ℂ) - 1) := by
+    rw [ofComplex_apply_of_im_pos him]
+    ext1
+    rw [coe_T_inv_smul]
+  rw [h1]
+  have h2 := hper ((τ : ℂ) - 1)
+  rw [Function.comp_apply, Function.comp_apply, sub_add_cancel, ofComplex_apply] at h2
+  exact h2.symm
+
+end LevelOne
+
+section Ring
+
+local notation "Δ" => ModularForm.discriminant
+
+variable (N : ℕ) [NeZero N]
+
+theorem mdifferentiable_of_mem {F : ℍ → ℂ} (hF : F ∈ ring N) : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F := by
+  have h := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact h.2.2.2.2.1 F hF
+
+theorem eq_zero_or_eq_zero_of_mul_eq_zero {a b : ℍ → ℂ} (ha : a ∈ ring N) (hb : b ∈ ring N)
+    (hab : a * b = 0) : a = 0 ∨ b = 0 := by
+  have h := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact h.2.2.2.2.2 a b ha hb hab
+
+abbrev redMat (γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) (ZMod N) :=
+  (γ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N)
+
+theorem fricke_smul_of_mem (v : Fin 2 → ZMod N) {γ : SL(2, ℤ)}
+    (hγ : γ ∈ CongruenceSubgroup.Gamma N) (τ : ℍ) : fricke N v (γ • τ) = fricke N v τ :=
+  (WLight.frickeFunction_modularity_package N PeriodPair.ofTau (fun _ => ⟨rfl, rfl⟩)).2.2.2.2.2.2.1
+    v γ hγ τ
+
+omit [NeZero N] in
+theorem jAnalytic_smul (γ : SL(2, ℤ)) (τ : ℍ) : jAnalytic (γ • τ) = jAnalytic τ := by
+  have hmem : (γ : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ, rfl⟩
+  have h4 : (ModularForm.E₄ : ℍ → ℂ) ((γ : GL (Fin 2) ℝ) • τ) =
+      denom (γ : GL (Fin 2) ℝ) τ ^ (4 : ℤ) * ModularForm.E₄ τ :=
+    SlashInvariantForm.slash_action_eqn'' _ hmem τ
+  have h12 : ModularForm.discriminant ((γ : GL (Fin 2) ℝ) • τ) =
+      denom (γ : GL (Fin 2) ℝ) τ ^ (12 : ℤ) * ModularForm.discriminant τ := by
+    have := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hmem τ
+    simpa using this
+  have hd : denom (γ : GL (Fin 2) ℝ) τ ≠ 0 := denom_ne_zero _ _
+  have hΔ : ModularForm.discriminant τ ≠ 0 := ModularForm.discriminant_ne_zero τ
+  rw [jAnalytic, jAnalytic, ModularGroup.sl_moeb, h4, h12]
+  field_simp
+
+def precomp (g : SL(2, ℤ)) : (ℍ → ℂ) →ₐ[ℂ] (ℍ → ℂ) :=
+  AlgHom.pi (fun τ => Pi.evalAlgHom ℂ (fun _ : ℍ => ℂ) (g • τ))
+
+omit [NeZero N] in
+@[scoped simp]
+theorem precomp_apply (g : SL(2, ℤ)) (F : ℍ → ℂ) (τ : ℍ) : precomp g F τ = F (g • τ) := rfl
+
+theorem smul_eq_self_of_mem {F : ℍ → ℂ} (hF : F ∈ ring N) {γ : SL(2, ℤ)}
+    (hγ : γ ∈ CongruenceSubgroup.Gamma N) (τ : ℍ) : F (γ • τ) = F τ := by
+  suffices h : ring N ≤ AlgHom.equalizer (precomp γ) (AlgHom.id ℂ (ℍ → ℂ)) by
+    have := h hF
+    rw [AlgHom.mem_equalizer] at this
+    exact congrFun this τ
+  rw [ring, Algebra.adjoin_le_iff]
+  intro G hG
+  rw [SetLike.mem_coe, AlgHom.mem_equalizer]
+  funext τ'
+  rcases hG with rfl | ⟨v, hv, rfl⟩
+  · exact jAnalytic_smul γ τ'
+  · exact fricke_smul_of_mem N v hγ τ'
+
+omit [NeZero N] in
+theorem T_pow_mem_Gamma : ModularGroup.T ^ N ∈ CongruenceSubgroup.Gamma N := by
+  rw [CongruenceSubgroup.Gamma_mem, ← zpow_natCast, ModularGroup.coe_T_zpow]
+  simp
+
+theorem periodic_of_mem {F : ℍ → ℂ} (hF : F ∈ ring N) : Periodic (F ∘ ofComplex) N := by
+  intro w
+  by_cases hw : 0 < w.im
+  · have hw' : 0 < (w + N).im := by simpa using hw
+    simp only [Function.comp_apply, ofComplex_apply_of_im_pos hw, ofComplex_apply_of_im_pos hw']
+    have hT : ModularGroup.T ^ N • (⟨w, hw⟩ : ℍ) = ⟨w + N, hw'⟩ := by
+      rw [← zpow_natCast, modular_T_zpow_smul]
+      ext1
+      simp [add_comm]
+    rw [← hT, smul_eq_self_of_mem N hF (T_pow_mem_Gamma N)]
+  · push Not at hw
+    have hw' : (w + N).im ≤ 0 := by simpa using hw
+    simp only [Function.comp_apply, ofComplex_apply_of_im_nonpos hw,
+      ofComplex_apply_of_im_nonpos hw']
+
+theorem exists_isBoundedAtImInfty_mul_pow {F : ℍ → ℂ} (hF : F ∈ ring N) :
+    ∃ m : ℕ, IsBoundedAtImInfty (F * (Δ : ℍ → ℂ) ^ m) := by
+  have hpkg := WLight.frickeFunction_orbit_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  have hΔb : ∀ k : ℕ, IsBoundedAtImInfty ((Δ : ℍ → ℂ) ^ k) := fun k =>
+    ((good_discriminant N).pow k).bdd
+  induction hF using Algebra.adjoin_induction with
+  | mem G hG =>
+    rcases hG with rfl | ⟨v, hv, rfl⟩
+    · exact hpkg.1.2
+    · exact (hpkg.2.1 v hv).2
+  | algebraMap c =>
+    refine ⟨0, ?_⟩
+    rw [pow_zero, mul_one]
+    exact Filter.const_boundedAtFilter _ _
+  | add F G _ _ ihF ihG =>
+    obtain ⟨m, hm⟩ := ihF
+    obtain ⟨n, hn⟩ := ihG
+    refine ⟨m + n, ?_⟩
+    have : (F + G) * (Δ : ℍ → ℂ) ^ (m + n) =
+        F * (Δ : ℍ → ℂ) ^ m * (Δ : ℍ → ℂ) ^ n + G * (Δ : ℍ → ℂ) ^ n * (Δ : ℍ → ℂ) ^ m := by ring
+    rw [this]
+    exact (hm.mul (hΔb n)).add (hn.mul (hΔb m))
+  | mul F G _ _ ihF ihG =>
+    obtain ⟨m, hm⟩ := ihF
+    obtain ⟨n, hn⟩ := ihG
+    refine ⟨m + n, ?_⟩
+    have : (F * G) * (Δ : ℍ → ℂ) ^ (m + n) = (F * (Δ : ℍ → ℂ) ^ m) * (G * (Δ : ℍ → ℂ) ^ n) := by
+      ring
+    rw [this]
+    exact hm.mul hn
+
+end Ring
+
+section OrdInf
+
+local notation "Δ" => ModularForm.discriminant
+
+variable (N : ℕ) [NeZero N]
+
+theorem castN_pos : (0 : ℝ) < N := Nat.cast_pos.mpr (NeZero.pos N)
+
+def PB (F : ℍ → ℂ) (m : ℕ) : Prop := IsBoundedAtImInfty (F * (Δ : ℍ → ℂ) ^ m)
+
+omit [NeZero N] in
+theorem PB.add_right {F : ℍ → ℂ} {m : ℕ} (hm : PB F m) (k : ℕ) : PB F (m + k) := by
+  unfold PB at hm ⊢
+  rw [pow_add, ← mul_assoc]
+  exact hm.mul ((good_discriminant 1).pow k).bdd
+
+theorem good_of_PB {F : ℍ → ℂ} (hF : F ∈ ring N) {m : ℕ} (hm : PB F m) :
+    Good N (F * (Δ : ℍ → ℂ) ^ m) where
+  periodic := by
+    have : (F * (Δ : ℍ → ℂ) ^ m) ∘ ofComplex = (F ∘ ofComplex) * (((Δ : ℍ → ℂ) ^ m) ∘ ofComplex) :=
+      rfl
+    rw [this]
+    exact (periodic_of_mem N hF).mul ((good_discriminant N).pow m).periodic
+  mdiff := (mdifferentiable_of_mem N hF).mul ((good_discriminant N).pow m).mdiff
+  bdd := hm
+
+def ordAux (F : ℍ → ℂ) (m : ℕ) : ℤ :=
+  (ordB N (F * (Δ : ℍ → ℂ) ^ m) : ℤ) - m * (ordB N (Δ : ℍ → ℂ) : ℤ)
+
+theorem ordB_one : ordB N (1 : ℍ → ℂ) = 0 :=
+  ordB_eq_zero_of_apply_ne_zero (by
+    rw [cuspFunction_apply_zero (castN_pos N) ((Good.one (N : ℝ)).analyticAt (castN_pos N))
+      (Good.one (N : ℝ)).periodic]
+    rw [show valueAtInfty (1 : ℍ → ℂ) = 1 from tendsto_const_nhds.limUnder_eq]
+    exact one_ne_zero)
+
+theorem ordB_discriminant_pow (k : ℕ) : ordB N ((Δ : ℍ → ℂ) ^ k) = k * ordB N (Δ : ℍ → ℂ) := by
+  induction k with
+  | zero =>
+    rw [pow_zero, zero_mul]
+    exact ordB_one N
+  | succ k ih =>
+    rw [pow_succ, ordB_mul (castN_pos N) ((good_discriminant N).pow k) (good_discriminant N)
+      (discriminant_pow_ne_zero k) discriminant_ne_zero', ih]
+    ring
+
+theorem ordAux_add_right {F : ℍ → ℂ} (hF : F ∈ ring N) (hF0 : F ≠ 0) {m : ℕ} (hm : PB F m)
+    (k : ℕ) : ordAux N F (m + k) = ordAux N F m := by
+  unfold ordAux
+  rw [pow_add, ← mul_assoc, ordB_mul (castN_pos N) (good_of_PB N hF hm)
+    ((good_discriminant N).pow k) (by rwa [Ne, mul_discriminant_pow_eq_zero_iff])
+    (discriminant_pow_ne_zero k), ordB_discriminant_pow]
+  push_cast
+  ring
+
+theorem ordAux_eq_ordAux {F : ℍ → ℂ} (hF : F ∈ ring N) (hF0 : F ≠ 0) {m m' : ℕ} (hm : PB F m)
+    (hm' : PB F m') : ordAux N F m = ordAux N F m' := by
+  rw [← ordAux_add_right N hF hF0 hm m', ← ordAux_add_right N hF hF0 hm' m, add_comm]
+
+open Classical in
+def ordInf (F : ℍ → ℂ) : ℤ :=
+  if hex : ∃ m : ℕ, PB F m then ordAux N F (Nat.find hex) else 0
+
+theorem ordInf_eq {F : ℍ → ℂ} (hF : F ∈ ring N) (hF0 : F ≠ 0) {m : ℕ} (hm : PB F m) :
+    ordInf N F = ordAux N F m := by
+  classical
+  have hex : ∃ m : ℕ, PB F m := ⟨m, hm⟩
+  rw [ordInf, dite_eq_left hex]
+  exact ordAux_eq_ordAux N hF hF0 (Nat.find_spec hex) hm
+
+theorem ordInf_mul {F G : ℍ → ℂ} (hF : F ∈ ring N) (hG : G ∈ ring N) (hF0 : F ≠ 0) (hG0 : G ≠ 0) :
+    ordInf N (F * G) = ordInf N F + ordInf N G := by
+  obtain ⟨m, hm⟩ := exists_isBoundedAtImInfty_mul_pow N hF
+  obtain ⟨n, hn⟩ := exists_isBoundedAtImInfty_mul_pow N hG
+  have hFG0 : F * G ≠ 0 := by
+    intro h0
+    rcases eq_zero_or_eq_zero_of_mul_eq_zero N hF hG h0 with h | h
+    · exact hF0 h
+    · exact hG0 h
+  have hprod : (F * G) * (Δ : ℍ → ℂ) ^ (m + n) = (F * (Δ : ℍ → ℂ) ^ m) * (G * (Δ : ℍ → ℂ) ^ n) := by
+    ring
+  have hmn : PB (F * G) (m + n) := by
+    unfold PB
+    rw [hprod]
+    exact hm.mul hn
+  rw [ordInf_eq N ((ring N).mul_mem hF hG) hFG0 hmn, ordInf_eq N hF hF0 hm, ordInf_eq N hG hG0 hn]
+  unfold ordAux
+  rw [hprod, ordB_mul (castN_pos N) (good_of_PB N hF hm) (good_of_PB N hG hn)
+    (by rwa [Ne, mul_discriminant_pow_eq_zero_iff]) (by rwa [Ne, mul_discriminant_pow_eq_zero_iff])]
+  push_cast
+  ring
+
+theorem min_ordInf_le_ordInf_add {F G : ℍ → ℂ} (hF : F ∈ ring N) (hG : G ∈ ring N) (hF0 : F ≠ 0)
+    (hG0 : G ≠ 0) (hFG : F + G ≠ 0) : min (ordInf N F) (ordInf N G) ≤ ordInf N (F + G) := by
+  obtain ⟨m, hm⟩ := exists_isBoundedAtImInfty_mul_pow N hF
+  obtain ⟨n, hn⟩ := exists_isBoundedAtImInfty_mul_pow N hG
+  have hmM : PB F (m + n) := PB.add_right hm n
+  have hnM : PB G (m + n) := by rw [add_comm]; exact PB.add_right hn m
+  have hsum : (F + G) * (Δ : ℍ → ℂ) ^ (m + n) = F * (Δ : ℍ → ℂ) ^ (m + n) + G * (Δ : ℍ → ℂ) ^ (m +
+    n) :=
+    by
+    ring
+  have hM : PB (F + G) (m + n) := by
+    unfold PB
+    rw [hsum]
+    exact hmM.add hnM
+  rw [ordInf_eq N ((ring N).add_mem hF hG) hFG hM, ordInf_eq N hF hF0 hmM, ordInf_eq N hG hG0 hnM]
+  unfold ordAux
+  have hle := min_ordB_le_ordB_add (castN_pos N) (good_of_PB N hF hmM) (good_of_PB N hG hnM)
+    (by rwa [Ne, mul_discriminant_pow_eq_zero_iff]) (by rwa [Ne, mul_discriminant_pow_eq_zero_iff])
+    (by rw [← hsum]; rwa [Ne, mul_discriminant_pow_eq_zero_iff])
+  rw [hsum]
+  rw [min_sub_sub_right]
+  gcongr
+  exact_mod_cast hle
+
+theorem ordInf_one : ordInf N (1 : ℍ → ℂ) = 0 := by
+  have h1 : PB (1 : ℍ → ℂ) 0 := by
+    unfold PB
+    rw [pow_zero, mul_one]
+    exact Filter.const_boundedAtFilter _ _
+  rw [ordInf_eq N (ring N).one_mem one_ne_zero h1]
+  unfold ordAux
+  rw [pow_zero, mul_one, Nat.cast_zero, zero_mul, sub_zero, ordB_one N]
+  simp
+
+theorem ordInf_jAnalytic : ordInf N jAnalytic = -(ordB N (Δ : ℍ → ℂ) : ℤ) := by
+  have hjΔ : jAnalytic * (Δ : ℍ → ℂ) ^ 1 = (ModularForm.E₄ : ℍ → ℂ) ^ 3 := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply, pow_one, jAnalytic]
+    field_simp [ModularForm.discriminant_ne_zero τ]
+  have h1 : PB jAnalytic 1 := by
+    unfold PB
+    rw [hjΔ]
+    exact ((good_E₄ N).pow 3).bdd
+  have hj0 : jAnalytic ≠ 0 := by
+    intro h0
+    have hpkg := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+      (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+    have := hpkg.2.2.2.1 Polynomial.X (fun τ => by
+      rw [Polynomial.eval_X, h0]; rfl)
+    exact Polynomial.X_ne_zero this
+  rw [ordInf_eq N (jAnalytic_mem N) hj0 h1]
+  unfold ordAux
+  rw [hjΔ, ordB_E₄_pow N 3]
+  simp
+
+theorem ordInf_comp_T_inv {F : ℍ → ℂ} (hF : F ∈ ring N)
+    (hF₁ : (fun τ : ℍ => F (ModularGroup.T⁻¹ • τ)) ∈ ring N) :
+    ordInf N (fun τ : ℍ => F (ModularGroup.T⁻¹ • τ)) = ordInf N F := by
+  by_cases hF0 : F = 0
+  · subst hF0
+    rfl
+  obtain ⟨m, hm⟩ := exists_isBoundedAtImInfty_mul_pow N hF
+  set F₁ : ℍ → ℂ := fun τ : ℍ => F (ModularGroup.T⁻¹ • τ) with hF₁def
+  have hfun : F₁ * (Δ : ℍ → ℂ) ^ m = fun τ : ℍ => (F * (Δ : ℍ → ℂ) ^ m) (ModularGroup.T⁻¹ • τ) := by
+    funext τ
+    simp only [hF₁def, Pi.mul_apply, Pi.pow_apply, discriminant_T_inv_smul]
+  have hF₁0 : F₁ ≠ 0 := by
+    intro h0
+    apply hF0
+    funext τ
+    have := congrFun h0 (ModularGroup.T • τ)
+    simpa [hF₁def] using this
+  have htend : Tendsto (fun τ : ℍ => ModularGroup.T⁻¹ • τ) atImInfty atImInfty := by
+    rw [atImInfty, Filter.tendsto_comap_iff]
+    have : UpperHalfPlane.im ∘ (fun τ : ℍ => ModularGroup.T⁻¹ • τ) = UpperHalfPlane.im := by
+      funext τ
+      simp only [Function.comp_apply, T_inv_smul_eq_vadd, vadd_im]
+    rw [this]
+    exact Filter.tendsto_comap
+  have hm₁ : PB F₁ m := by
+    unfold PB
+    rw [hfun]
+    exact hm.comp_tendsto htend
+  rw [ordInf_eq N hF₁ hF₁0 hm₁, ordInf_eq N hF hF0 hm]
+  unfold ordAux
+  congr 2
+  rw [hfun]
+  have hG := good_of_PB N hF hm
+  have hG₁ : Good N (fun τ : ℍ => (F * (Δ : ℍ → ℂ) ^ m) (ModularGroup.T⁻¹ • τ)) := by
+    rw [← hfun]
+    exact good_of_PB N hF₁ hm₁
+  exact_mod_cast ordB_comp_T_inv (castN_pos N) hG hG₁
+
+end OrdInf
+
+section Valuation
+
+local notation "Δ" => ModularForm.discriminant
+
+variable (N : ℕ) [NeZero N]
+
+open Classical in
+def ordFun (F : ring N) : WithZero (Multiplicative ℤ) :=
+  if (F : ℍ → ℂ) = 0 then 0 else WithZero.exp (-ordInf N (F : ℍ → ℂ))
+
+omit [NeZero N] in
+theorem ordFun_of_ne_zero {F : ring N} (hF : (F : ℍ → ℂ) ≠ 0) :
+    ordFun N F = WithZero.exp (-ordInf N (F : ℍ → ℂ)) := by
+  simp [ordFun, hF]
+
+omit [NeZero N] in
+theorem ordFun_zero' {F : ring N} (hF : (F : ℍ → ℂ) = 0) : ordFun N F = 0 := by
+  simp [ordFun, hF]
+
+def ordValuation : Valuation (ring N) (WithZero (Multiplicative ℤ)) where
+  toFun := ordFun N
+  map_zero' := ordFun_zero' N rfl
+  map_one' := by
+    rw [ordFun_of_ne_zero N (by simp)]
+    simp [ordInf_one]
+  map_mul' F G := by
+    by_cases hF : (F : ℍ → ℂ) = 0
+    · rw [ordFun_zero' N hF, ordFun_zero' N (by simp [hF]), zero_mul]
+    by_cases hG : (G : ℍ → ℂ) = 0
+    · rw [ordFun_zero' N hG, ordFun_zero' N (by simp [hG]), mul_zero]
+    have hFG : ((F * G : ring N) : ℍ → ℂ) ≠ 0 := by
+      intro h
+      rcases eq_zero_or_eq_zero_of_mul_eq_zero N F.2 G.2 (by simpa using h) with h' | h'
+      · exact hF h'
+      · exact hG h'
+    rw [ordFun_of_ne_zero N hF, ordFun_of_ne_zero N hG, ordFun_of_ne_zero N hFG,
+      ← WithZero.exp_add]
+    congr 1
+    rw [show ((F * G : ring N) : ℍ → ℂ) = (F : ℍ → ℂ) * (G : ℍ → ℂ) from rfl,
+      ordInf_mul N F.2 G.2 hF hG]
+    ring
+  map_add_le_max' F G := by
+    by_cases hFG : ((F + G : ring N) : ℍ → ℂ) = 0
+    · rw [ordFun_zero' N hFG]; exact zero_le
+    by_cases hF : (F : ℍ → ℂ) = 0
+    · have : F + G = G := by
+        have hF' : F = 0 := Subtype.ext hF
+        rw [hF', zero_add]
+      rw [this, ordFun_zero' N hF]
+      exact le_max_right _ _
+    by_cases hG : (G : ℍ → ℂ) = 0
+    · have : F + G = F := by
+        have hG' : G = 0 := Subtype.ext hG
+        rw [hG', add_zero]
+      rw [this, ordFun_zero' N hG]
+      exact le_max_left _ _
+    rw [ordFun_of_ne_zero N hF, ordFun_of_ne_zero N hG, ordFun_of_ne_zero N hFG]
+    have hmin := min_ordInf_le_ordInf_add N F.2 G.2 hF hG (by simpa using hFG)
+    rw [show ((F + G : ring N) : ℍ → ℂ) = (F : ℍ → ℂ) + (G : ℍ → ℂ) from rfl]
+    rcases le_total (ordInf N (F : ℍ → ℂ)) (ordInf N (G : ℍ → ℂ)) with h | h
+    · rw [min_eq_left h] at hmin
+      refine le_trans ?_ (le_max_left _ _)
+      rw [WithZero.exp_le_exp]
+      omega
+    · rw [min_eq_right h] at hmin
+      refine le_trans ?_ (le_max_right _ _)
+      rw [WithZero.exp_le_exp]
+      omega
+
+@[scoped simp]
+theorem ordValuation_apply (F : ring N) : ordValuation N F = ordFun N F := rfl
+
+theorem ordValuation_ne_zero {F : ring N} (hF : F ≠ 0) : ordValuation N F ≠ 0 := by
+  have hF' : (F : ℍ → ℂ) ≠ 0 := fun h => hF (Subtype.ext h)
+  rw [ordValuation_apply, ordFun_of_ne_zero N hF']
+  exact WithZero.exp_ne_zero
+
+theorem nonZeroDivisors_le_supp_primeCompl :
+    nonZeroDivisors (ring N) ≤ (ordValuation N).supp.primeCompl := by
+  intro s hs
+  change s ∉ (ordValuation N).supp
+  rw [Valuation.mem_supp_iff]
+  apply ordValuation_ne_zero
+  intro h
+  rw [h] at hs
+  exact zero_notMem_nonZeroDivisors hs
+
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ring N) K] [IsScalarTower ℂ (ring N) K]
+  [IsFractionRing (ring N) K]
+
+def ordValuationK : Valuation K (WithZero (Multiplicative ℤ)) :=
+  (ordValuation N).extendToLocalization (S := nonZeroDivisors (ring N))
+    (nonZeroDivisors_le_supp_primeCompl N) K
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem ordValuationK_algebraMap (F : ring N) :
+    ordValuationK N K (algebraMap (ring N) K F) = ordFun N F :=
+  Valuation.extendToLocalization_apply_map_apply _ _ K F
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem ordValuationK_jK :
+    ordValuationK N K (algebraMap (ring N) K (jGen N)) = WithZero.exp (ordB N (Δ : ℍ → ℂ) : ℤ) := by
+  have hj0 : ((jGen N : ring N) : ℍ → ℂ) ≠ 0 := by
+    intro h0
+    have hpkg := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+      (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+    have := hpkg.2.2.2.1 Polynomial.X (fun τ => by
+      rw [Polynomial.eval_X, ← coe_jGen N, h0]; rfl)
+    exact Polynomial.X_ne_zero this
+  rw [ordValuationK_algebraMap, ordFun_of_ne_zero N hj0, coe_jGen, ordInf_jAnalytic, neg_neg]
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem one_lt_ordValuationK_jK : 1 < ordValuationK N K (algebraMap (ring N) K (jGen N)) := by
+  rw [ordValuationK_jK, ← WithZero.exp_zero, WithZero.exp_lt_exp]
+  exact_mod_cast ordB_discriminant_pos N
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem isNontrivial_ordValuationK : (ordValuationK N K).IsNontrivial := by
+  refine ⟨algebraMap (ring N) K (jGen N), ?_, ?_⟩
+  · rw [ordValuationK_jK]; exact WithZero.exp_ne_zero
+  · exact (one_lt_ordValuationK_jK N K).ne'
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem nontrivial_valueGroup :
+    Nontrivial (ordValuationK N K).toMonoidWithZeroHom.valueGroup := by
+  rw [Subgroup.nontrivial_iff_exists_ne_one]
+  have hne : ordValuationK N K (algebraMap (ring N) K (jGen N)) ≠ 0 := by
+    rw [ordValuationK_jK]; exact WithZero.exp_ne_zero
+  refine ⟨Units.mk0 _ hne, ?_, ?_⟩
+  · exact MonoidWithZeroHom.mem_valueGroup _ ⟨_, rfl⟩
+  · intro h
+    have h' :=
+      congrArg (fun u : (WithZero (Multiplicative ℤ))ˣ => (u : WithZero (Multiplicative ℤ))) h
+    simp only [Units.val_mk0, Units.val_one] at h'
+    exact (one_lt_ordValuationK_jK N K).ne' h'
+
+def cuspPlace : AlgebraicCurve.Place ℂ K :=
+  haveI := nontrivial_valueGroup N K
+  { toValuationSubring := (ordValuationK N K).valuationSubring
+    algebraMap_mem' := fun a => by
+      rw [Valuation.mem_valuationSubring_iff]
+      by_cases ha : a = 0
+      · simp [ha]
+      · rw [IsScalarTower.algebraMap_apply ℂ (ring N) K, ordValuationK_algebraMap]
+        have hne : ((algebraMap ℂ (ring N) a : ring N) : ℍ → ℂ) ≠ 0 := by
+          intro h
+          have := congrFun h UpperHalfPlane.I
+          simp [Algebra.algebraMap_eq_smul_one, ha] at this
+        rw [ordFun_of_ne_zero N hne, ← WithZero.exp_zero, WithZero.exp_le_exp]
+        have hPB : PB ((algebraMap ℂ (ring N) a : ring N) : ℍ → ℂ) 0 := by
+          unfold PB
+          rw [pow_zero, mul_one]
+          have : ((algebraMap ℂ (ring N) a : ring N) : ℍ → ℂ) = fun _ => a := by
+            funext τ; simp [Algebra.algebraMap_eq_smul_one]
+          rw [this]
+          exact Filter.const_boundedAtFilter _ _
+        rw [ordInf_eq N (algebraMap ℂ (ring N) a).2 hne hPB]
+        unfold ordAux
+        rw [pow_zero, mul_one, Nat.cast_zero, zero_mul, sub_zero, neg_nonpos]
+        exact_mod_cast Nat.zero_le _
+    ne_top' := by
+      rw [ne_eq, Valuation.valuationSubring_eq_top_iff, not_not]
+      exact isNontrivial_ordValuationK N K
+    isPrincipalIdealRing' :=
+      (Valuation.valuationSubring_isDiscreteValuationRing
+        (ordValuationK N K)).toIsPrincipalIdealRing }
+
+@[scoped simp]
+theorem cuspPlace_toValuationSubring :
+    (cuspPlace N K).toValuationSubring = (ordValuationK N K).valuationSubring := rfl
+
+theorem mem_cuspPlace_iff (x : K) :
+    x ∈ (cuspPlace N K).toValuationSubring ↔ ordValuationK N K x ≤ 1 := by
+  rw [cuspPlace_toValuationSubring, Valuation.mem_valuationSubring_iff]
+
+theorem ord_jK_neg : (cuspPlace N K).ord (algebraMap (ring N) K (jGen N)) < 0 := by
+  set W := cuspPlace N K
+  set y := algebraMap (ring N) K (jGen N) with hy
+  have hyW : y ∉ W.toValuationSubring := by
+    rw [mem_cuspPlace_iff, not_le]
+    exact one_lt_ordValuationK_jK N K
+  have hy0 : y ≠ 0 := fun h => hyW (h ▸ W.toValuationSubring.zero_mem)
+  have hmem : y⁻¹ ∈ W.toValuationSubring.nonunits :=
+    (ValuationSubring.inv_mem_nonunits_iff W.toValuationSubring).mpr (Or.inr hyW)
+  obtain ⟨hyiW, hmax⟩ := ValuationSubring.mem_nonunits_iff_exists_mem_maximalIdeal.mp hmem
+  have hval : W.adicValuation y⁻¹ < 1 := by
+    rw [W.adicValuation_coe ⟨y⁻¹, hyiW⟩,
+      IsDedekindDomain.HeightOneSpectrum.intValuation_lt_one_iff_mem]
+    exact hmax
+  have hne : W.adicValuation y⁻¹ ≠ 0 := W.adicValuation_ne_zero (inv_ne_zero hy0)
+  have hpos : 0 < W.ord y⁻¹ := by
+    rw [AlgebraicCurve.Place.ord, neg_pos, WithZero.log_lt_iff_lt_exp hne, WithZero.exp_zero]
+    exact hval
+  rw [W.ord_inv] at hpos
+  omega
+
+theorem ordFun_comp_T_inv (F : ring N)
+    (hF₁ : (fun τ : ℍ => (F : ℍ → ℂ) (ModularGroup.T⁻¹ • τ)) ∈ ring N) :
+    ordFun N ⟨fun τ : ℍ => (F : ℍ → ℂ) (ModularGroup.T⁻¹ • τ), hF₁⟩ = ordFun N F := by
+  have hiff : (fun τ : ℍ => (F : ℍ → ℂ) (ModularGroup.T⁻¹ • τ)) = 0 ↔ (F : ℍ → ℂ) = 0 := by
+    constructor
+    · intro h
+      funext τ
+      have := congrFun h (ModularGroup.T • τ)
+      simpa using this
+    · intro h
+      funext τ
+      simp [h]
+  by_cases hF : (F : ℍ → ℂ) = 0
+  · rw [ordFun_zero' N hF, ordFun_zero' N (by
+      change (fun τ : ℍ => (F : ℍ → ℂ) (ModularGroup.T⁻¹ • τ)) = 0
+      exact hiff.mpr hF)]
+  · have hF' : (fun τ : ℍ => (F : ℍ → ℂ) (ModularGroup.T⁻¹ • τ)) ≠ 0 := by
+      rw [Ne, hiff]; exact hF
+    rw [ordFun_of_ne_zero N hF, ordFun_of_ne_zero N (F := ⟨_, hF₁⟩) hF']
+    congr 2
+    exact ordInf_comp_T_inv N F.2 hF₁
+
+omit [IsScalarTower ℂ (↥(ring N)) K] in
+theorem ordValuationK_algEquiv
+    (hst : ∀ F ∈ ring N, (fun τ : ℍ => F (ModularGroup.T⁻¹ • τ)) ∈ ring N) (φ : K ≃ₐ[ℂ] K)
+    (hφ : ∀ (F : ℍ → ℂ) (hF : F ∈ ring N),
+      φ (algebraMap (ring N) K ⟨F, hF⟩) =
+        algebraMap (ring N) K ⟨fun τ : ℍ => F (ModularGroup.T⁻¹ • τ), hst F hF⟩)
+    (x : K) : ordValuationK N K (φ x) = ordValuationK N K x := by
+  obtain ⟨a, b, hb, rfl⟩ := IsFractionRing.div_surjective (A := ring N) x
+  rw [map_div₀, map_div₀, map_div₀]
+  have ha := hφ (a : ℍ → ℂ) a.2
+  have hb' := hφ (b : ℍ → ℂ) b.2
+  simp only [Subtype.coe_eta] at ha hb'
+  rw [ha, hb', ordValuationK_algebraMap, ordValuationK_algebraMap, ordValuationK_algebraMap,
+    ordValuationK_algebraMap, ordFun_comp_T_inv N a, ordFun_comp_T_inv N b]
+
+theorem smul_cuspPlace_eq
+    (hst : ∀ F ∈ ring N, (fun τ : ℍ => F (ModularGroup.T⁻¹ • τ)) ∈ ring N) (φ : K ≃ₐ[ℂ] K)
+    (hφ : ∀ (F : ℍ → ℂ) (hF : F ∈ ring N),
+      φ (algebraMap (ring N) K ⟨F, hF⟩) =
+        algebraMap (ring N) K ⟨fun τ : ℍ => F (ModularGroup.T⁻¹ • τ), hst F hF⟩) :
+    AlgebraicCurve.SemilinearAut.ofAlgAut φ • cuspPlace N K = cuspPlace N K := by
+  apply AlgebraicCurve.Place.ext
+  rw [AlgebraicCurve.SemilinearAut.smul_toValuationSubring]
+  ext x
+  rw [ValuationSubring.mem_pointwise_smul_iff_inv_smul_mem, ← map_inv,
+    AlgebraicCurve.SemilinearAut.ofAlgAut_smul, mem_cuspPlace_iff, mem_cuspPlace_iff]
+  have h := ordValuationK_algEquiv N K hst φ hφ (φ⁻¹ x)
+  rw [show φ (φ⁻¹ x) = x from φ.apply_symm_apply x] at h
+  rw [h]
+
+end Valuation
+
+end ModularCurve.LevelN.CuspPlaces
+
+open _root_.ModularCurve.LevelN
+  _root_.P2MW.S_ModularCurve_LevelN_exists_place_ord_neg_forall_smul_eq.ModularCurve.LevelN
+  ModularCurve.LevelN.CuspPlaces in
+theorem solution (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring N) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring N) K]
+    [IsFractionRing (ModularCurve.LevelN.ring N) K]
+    (hst : ∀ F ∈ ModularCurve.LevelN.ring N,
+      (fun τ : UpperHalfPlane => F (ModularGroup.T⁻¹ • τ)) ∈ ModularCurve.LevelN.ring N) :
+    ∃ W : AlgebraicCurve.Place ℂ K,
+      W.ord (algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)) < 0 ∧
+      ∀ φ : K ≃ₐ[ℂ] K,
+        (∀ (F : UpperHalfPlane → ℂ) (hF : F ∈ ModularCurve.LevelN.ring N),
+            φ (algebraMap (ModularCurve.LevelN.ring N) K ⟨F, hF⟩) =
+              algebraMap (ModularCurve.LevelN.ring N) K
+                ⟨fun τ : UpperHalfPlane => F (ModularGroup.T⁻¹ • τ), hst F hF⟩) →
+        AlgebraicCurve.SemilinearAut.ofAlgAut φ • W = W :=
+  ⟨cuspPlace N K, ord_jK_neg N K, fun φ hφ => smul_cuspPlace_eq N K hst φ hφ⟩
+
+end
+end S_ModularCurve_LevelN_exists_place_ord_neg_forall_smul_eq
+end P2MW
+export P2MW.S_ModularCurve_LevelN_exists_place_ord_neg_forall_smul_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.LevelN.exists_place_ord_neg_forall_smul_eq (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring N) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring N) K]
+    [IsFractionRing (ModularCurve.LevelN.ring N) K]
+    (hst : ∀ F ∈ ModularCurve.LevelN.ring N,
+      (fun τ : UpperHalfPlane => F (ModularGroup.T⁻¹ • τ)) ∈ ModularCurve.LevelN.ring N) :
+    ∃ W : AlgebraicCurve.Place ℂ K,
+      W.ord (algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N)) < 0 ∧
+      ∀ φ : K ≃ₐ[ℂ] K,
+        (∀ (F : UpperHalfPlane → ℂ) (hF : F ∈ ModularCurve.LevelN.ring N),
+            φ (algebraMap (ModularCurve.LevelN.ring N) K ⟨F, hF⟩) =
+              algebraMap (ModularCurve.LevelN.ring N) K
+                ⟨fun τ : UpperHalfPlane => F (ModularGroup.T⁻¹ • τ), hst F hF⟩) →
+        AlgebraicCurve.SemilinearAut.ofAlgAut φ • W = W :=
+  solution N K hst
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_place_ord_sub_pos_forall_smul_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_place_ord_sub_pos_forall_smul_eq.lean
new file mode 100644
index 0000000000..5cbd8aabc5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_exists_place_ord_sub_pos_forall_smul_eq.lean
@@ -0,0 +1,619 @@
+/-
+Based on Prove2Me node ModularCurve.LevelN.exists_place_ord_sub_pos_forall_smul_eq
+(251b3550-774d-59c4-a7ab-7e736b512aeb) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 55fecdb6-bfe9-59d1-8341-57b2fe876dc1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_BaseChangeGalois
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LevelNFunctionField
+
+import Mathlib.Algebra.CharP.Pi
+import Mathlib.Order.CompletePartialOrder
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelN_structure_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Place above j(τ₀) fixed by stabiliser automorphisms
+
+Theorem statement: `ModularCurve.LevelN.exists_place_ord_sub_pos_forall_smul_eq`
+(`251b3550-774d-59c4-a7ab-7e736b512aeb`), by Claude, 2026-09-05.
+
+Proof: submission `55fecdb6-bfe9-59d1-8341-57b2fe876dc1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N \geq 1$ and let $A_N =$ [`ModularCurve.LevelN.ring
+N`](def/ModularCurve_LevelNFunctionField.html#L28) be the $\mathbb{C}$-subalgebra of functions
+$\mathfrak{H} \to \mathbb{C}$ generated by the set consisting of $j = E_4^3/\Delta$ (the function
+`jAnalytic`) together with the functions `fricke N v` for nonzero $v \in (\mathbb{Z}/N)^2$. Let $K$
+be a field that is simultaneously a $\mathbb{C}$-algebra and an $A_N$-algebra, compatibly (scalar
+tower), and a fraction field of $A_N$, and let $\tau_0 \in \mathfrak{H}$. Then there exists a place
+$W$ of $K$ over $\mathbb{C}$ in the sense of the project, that is, a valuation subring of $K$
+containing the image of $\mathbb{C}$, distinct from $K$ itself and a principal ideal ring, such
+that: first, the order function of $W$ (minus the logarithm of the associated adic valuation) is
+strictly positive on the element $j - j(\tau_0)$, i.e. on the difference of the image in $K$ of
+`jGen N` and the image of the scalar `jAnalytic τ₀`; and second, for every $\gamma \in
+\mathrm{SL}_2(\mathbb{Z})$ with $\gamma \cdot \tau_0 = \tau_0$, every witness that $A_N$ is stable
+under $F \mapsto F \circ \gamma^{-1}$, and every $\mathbb{C}$-algebra automorphism $\varphi$ of $K$
+which sends the image of each $F \in A_N$ to the image of $F \circ \gamma^{-1}$, the semilinear
+automorphism $(\varphi, \mathrm{id}_{\mathbb{C}})$ attached to $\varphi$ fixes $W$ for the pointwise
+action on places.
+
+This produces the place of the level-$N$ modular function field given by the order of vanishing at a
+point $\tau_0$ of the upper half plane, lying above the point $j = j(\tau_0)$ of the $j$-line and
+invariant under the automorphisms of $K$ induced by elements of the stabiliser of $\tau_0$ in
+$\mathrm{SL}_2(\mathbb{Z})$. It feeds the ramification and fibre-counting arguments
+[`ModularCurve.LevelN.twelve_mul_add_mul_index_le_genusFF`]
+(thm.html#ModularCurve.LevelN.twelve_mul_add_mul_index_le_genusFF),
+[`ModularCurve.natCard_doubleCoset_le_card_fibres_of_finrank_eq_index`]
+(thm.html#ModularCurve.natCard_doubleCoset_le_card_fibres_of_finrank_eq_index)
+and
+[`ModularCurve.natCard_fibres_jqModC_eq_natCard_doubleCoset_of_finrank_eq_index`]
+(thm.html#ModularCurve.natCard_fibres_jqModC_eq_natCard_doubleCoset_of_finrank_eq_index).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_LevelN_exists_place_ord_sub_pos_forall_smul_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_3959a5e7
+
+
+open UpperHalfPlane Filter Topology
+open scoped MatrixGroups Manifold
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "LevelN.jAnalytic LevelN.ring LevelN.jGen"
+namespace LevelN
+p2m_export "ModularCurve.LevelN" "wp fricke jAnalytic ring jGen"
+namespace AnalyticPlaces
+p2m_open "ModularCurve.LevelN ModularCurve"
+
+variable (N : ℕ) [NeZero N]
+
+theorem mdifferentiable_of_mem {F : ℍ → ℂ} (hF : F ∈ ring N) : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F := by
+  have h := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact h.2.2.2.2.1 F hF
+
+theorem eq_zero_or_eq_zero_of_mul_eq_zero {a b : ℍ → ℂ} (ha : a ∈ ring N) (hb : b ∈ ring N)
+    (hab : a * b = 0) : a = 0 ∨ b = 0 := by
+  have h := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact h.2.2.2.2.2 a b ha hb hab
+
+private abbrev _root_.ModularCurve.LevelN.AnalyticPlaces.ext (F : ℍ → ℂ) : ℂ → ℂ := F ∘ ofComplex
+
+p2m_export "ModularCurve.LevelN.AnalyticPlaces" "ext"
+theorem ext_apply_coe (F : ℍ → ℂ) (τ : ℍ) : ext F τ = F τ := by
+  simp [ext, ofComplex_apply]
+
+theorem analyticOnNhd_ext {F : ℍ → ℂ} (hF : F ∈ ring N) :
+    AnalyticOnNhd ℂ (ext F) upperHalfPlaneSet := by
+  intro z hz
+  have hd : DifferentiableOn ℂ (ext F) upperHalfPlaneSet :=
+    UpperHalfPlane.mdifferentiable_iff.mp (mdifferentiable_of_mem N hF)
+  exact hd.analyticAt (isOpen_upperHalfPlaneSet.mem_nhds hz)
+
+theorem analyticAt_ext {F : ℍ → ℂ} (hF : F ∈ ring N) (τ₀ : ℍ) : AnalyticAt ℂ (ext F) τ₀ :=
+  analyticOnNhd_ext N hF τ₀ τ₀.im_pos
+
+theorem analyticOrderAt_ne_top {F : ℍ → ℂ} (hF : F ∈ ring N) (hF0 : F ≠ 0) (τ₀ : ℍ) :
+    analyticOrderAt (ext F) τ₀ ≠ ⊤ := by
+  obtain ⟨τ₁, hτ₁⟩ : ∃ τ₁ : ℍ, F τ₁ ≠ 0 := by
+    by_contra h
+    push Not at h
+    exact hF0 (funext h)
+  have h1 : analyticOrderAt (ext F) τ₁ ≠ ⊤ := by
+    have : analyticOrderAt (ext F) τ₁ = 0 := by
+      rw [analyticOrderAt_eq_zero]
+      right
+      rwa [ext_apply_coe]
+    rw [this]
+    exact ENat.zero_ne_top
+  exact (analyticOnNhd_ext N hF).analyticOrderAt_ne_top_of_isPreconnected
+    ((convex_halfSpace_im_gt 0).isPreconnected) τ₁.im_pos τ₀.im_pos h1
+
+def ordAt (τ₀ : ℍ) (F : ℍ → ℂ) : ℕ := (analyticOrderAt (ext F) τ₀).toNat
+
+theorem ordAt_cast {F : ℍ → ℂ} (hF : F ∈ ring N) (hF0 : F ≠ 0) (τ₀ : ℍ) :
+    (ordAt τ₀ F : ℕ∞) = analyticOrderAt (ext F) τ₀ :=
+  ENat.natCast_toNat (analyticOrderAt_ne_top N hF hF0 τ₀)
+
+theorem ordAt_mul {F G : ℍ → ℂ} (hF : F ∈ ring N) (hG : G ∈ ring N) (hF0 : F ≠ 0) (hG0 : G ≠ 0)
+    (τ₀ : ℍ) : ordAt τ₀ (F * G) = ordAt τ₀ F + ordAt τ₀ G := by
+  have h := analyticOrderAt_mul (analyticAt_ext N hF τ₀) (analyticAt_ext N hG τ₀)
+  unfold ordAt
+  rw [show ext (F * G) = ext F * ext G from rfl, h]
+  exact ENat.toNat_add (analyticOrderAt_ne_top N hF hF0 τ₀) (analyticOrderAt_ne_top N hG hG0 τ₀)
+
+theorem min_ordAt_le_ordAt_add {F G : ℍ → ℂ} (hF : F ∈ ring N) (hG : G ∈ ring N) (hF0 : F ≠ 0)
+    (hG0 : G ≠ 0) (hFG : F + G ≠ 0) (τ₀ : ℍ) :
+    min (ordAt τ₀ F) (ordAt τ₀ G) ≤ ordAt τ₀ (F + G) := by
+  have h := le_analyticOrderAt_add (f := ext F) (g := ext G) (z₀ := (τ₀ : ℂ))
+  rw [show ext F + ext G = ext (F + G) from rfl, ← ordAt_cast N hF hF0, ← ordAt_cast N hG hG0,
+    ← ordAt_cast N ((ring N).add_mem hF hG) hFG] at h
+  rcases le_total (ordAt τ₀ F) (ordAt τ₀ G) with hle | hle
+  · rw [min_eq_left hle]
+    rw [min_eq_left (by exact_mod_cast hle)] at h
+    exact_mod_cast h
+  · rw [min_eq_right hle]
+    rw [min_eq_right (by exact_mod_cast hle)] at h
+    exact_mod_cast h
+
+theorem ordAt_one (τ₀ : ℍ) : ordAt τ₀ (1 : ℍ → ℂ) = 0 := by
+  unfold ordAt
+  have : analyticOrderAt (ext (1 : ℍ → ℂ)) τ₀ = 0 := by
+    rw [analyticOrderAt_eq_zero]
+    right
+    simp [ext]
+  rw [this]
+  rfl
+
+open Classical in
+def ordFun (τ₀ : ℍ) (F : ring N) : WithZero (Multiplicative ℤ) :=
+  if (F : ℍ → ℂ) = 0 then 0 else WithZero.exp (-(ordAt τ₀ (F : ℍ → ℂ) : ℤ))
+
+omit [NeZero N] in
+theorem ordFun_of_ne_zero (τ₀ : ℍ) {F : ring N} (hF : (F : ℍ → ℂ) ≠ 0) :
+    ordFun N τ₀ F = WithZero.exp (-(ordAt τ₀ (F : ℍ → ℂ) : ℤ)) := by
+  simp [ordFun, hF]
+
+omit [NeZero N] in
+theorem ordFun_zero' (τ₀ : ℍ) {F : ring N} (hF : (F : ℍ → ℂ) = 0) : ordFun N τ₀ F = 0 := by
+  simp [ordFun, hF]
+
+def ordValuation (τ₀ : ℍ) : Valuation (ring N) (WithZero (Multiplicative ℤ)) where
+  toFun := ordFun N τ₀
+  map_zero' := ordFun_zero' N τ₀ rfl
+  map_one' := by
+    rw [ordFun_of_ne_zero N τ₀ (by simp)]
+    simp [ordAt_one]
+  map_mul' F G := by
+    by_cases hF : (F : ℍ → ℂ) = 0
+    · rw [ordFun_zero' N τ₀ hF, ordFun_zero' N τ₀ (by simp [hF]), zero_mul]
+    by_cases hG : (G : ℍ → ℂ) = 0
+    · rw [ordFun_zero' N τ₀ hG, ordFun_zero' N τ₀ (by simp [hG]), mul_zero]
+    have hFG : ((F * G : ring N) : ℍ → ℂ) ≠ 0 := by
+      intro h
+      rcases eq_zero_or_eq_zero_of_mul_eq_zero N F.2 G.2 (by simpa using h) with h' | h'
+      · exact hF h'
+      · exact hG h'
+    rw [ordFun_of_ne_zero N τ₀ hF, ordFun_of_ne_zero N τ₀ hG, ordFun_of_ne_zero N τ₀ hFG,
+      ← WithZero.exp_add]
+    congr 1
+    rw [show ((F * G : ring N) : ℍ → ℂ) = (F : ℍ → ℂ) * (G : ℍ → ℂ) from rfl,
+      ordAt_mul N F.2 G.2 hF hG]
+    push_cast
+    ring
+  map_add_le_max' F G := by
+    by_cases hFG : ((F + G : ring N) : ℍ → ℂ) = 0
+    · rw [ordFun_zero' N τ₀ hFG]; exact zero_le
+    by_cases hF : (F : ℍ → ℂ) = 0
+    · have : F + G = G := by
+        have hF' : F = 0 := Subtype.ext hF
+        rw [hF', zero_add]
+      rw [this, ordFun_zero' N τ₀ hF]
+      exact le_max_right _ _
+    by_cases hG : (G : ℍ → ℂ) = 0
+    · have : F + G = F := by
+        have hG' : G = 0 := Subtype.ext hG
+        rw [hG', add_zero]
+      rw [this, ordFun_zero' N τ₀ hG]
+      exact le_max_left _ _
+    rw [ordFun_of_ne_zero N τ₀ hF, ordFun_of_ne_zero N τ₀ hG, ordFun_of_ne_zero N τ₀ hFG]
+    have hmin := min_ordAt_le_ordAt_add N F.2 G.2 hF hG (by simpa using hFG) τ₀
+    rw [show ((F + G : ring N) : ℍ → ℂ) = (F : ℍ → ℂ) + (G : ℍ → ℂ) from rfl]
+    rcases le_total (ordAt τ₀ (F : ℍ → ℂ)) (ordAt τ₀ (G : ℍ → ℂ)) with h | h
+    · rw [min_eq_left h] at hmin
+      refine le_trans ?_ (le_max_left _ _)
+      rw [WithZero.exp_le_exp]
+      omega
+    · rw [min_eq_right h] at hmin
+      refine le_trans ?_ (le_max_right _ _)
+      rw [WithZero.exp_le_exp]
+      omega
+
+@[scoped simp]
+theorem ordValuation_apply (τ₀ : ℍ) (F : ring N) : ordValuation N τ₀ F = ordFun N τ₀ F := rfl
+
+theorem ordValuation_ne_zero (τ₀ : ℍ) {F : ring N} (hF : F ≠ 0) : ordValuation N τ₀ F ≠ 0 := by
+  have hF' : (F : ℍ → ℂ) ≠ 0 := fun h => hF (Subtype.ext h)
+  rw [ordValuation_apply, ordFun_of_ne_zero N τ₀ hF']
+  exact WithZero.exp_ne_zero
+
+theorem nonZeroDivisors_le_supp_primeCompl (τ₀ : ℍ) :
+    nonZeroDivisors (ring N) ≤ (ordValuation N τ₀).supp.primeCompl := by
+  intro s hs
+  change s ∉ (ordValuation N τ₀).supp
+  rw [Valuation.mem_supp_iff]
+  apply ordValuation_ne_zero
+  intro h
+  rw [h] at hs
+  exact zero_notMem_nonZeroDivisors hs
+
+section FractionField
+
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ring N) K] [IsScalarTower ℂ (ring N) K]
+  [IsFractionRing (ring N) K]
+
+def ordValuationK (τ₀ : ℍ) : Valuation K (WithZero (Multiplicative ℤ)) :=
+  (ordValuation N τ₀).extendToLocalization (S := nonZeroDivisors (ring N))
+    (nonZeroDivisors_le_supp_primeCompl N τ₀) K
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem ordValuationK_algebraMap (τ₀ : ℍ) (F : ring N) :
+    ordValuationK N K τ₀ (algebraMap (ring N) K F) = ordFun N τ₀ F :=
+  Valuation.extendToLocalization_apply_map_apply _ _ K F
+
+def jSub (τ₀ : ℍ) : ring N := jGen N - algebraMap ℂ (ring N) (jAnalytic τ₀)
+
+omit [NeZero N] in
+theorem coe_jSub (τ₀ : ℍ) :
+    ((jSub N τ₀ : ring N) : ℍ → ℂ) = fun τ => jAnalytic τ - jAnalytic τ₀ := by
+  funext τ
+  simp [jSub, jGen, Algebra.algebraMap_eq_smul_one]
+
+theorem jSub_ne_zero (τ₀ : ℍ) : (jSub N τ₀ : ring N) ≠ 0 := by
+  intro h
+  have h' := congrArg (fun F : ring N => (F : ℍ → ℂ)) h
+  simp only [coe_jSub, ZeroMemClass.coe_zero] at h'
+  have hpkg := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  have htr := hpkg.2.2.2.1 (Polynomial.X - Polynomial.C (jAnalytic τ₀)) (fun τ => by
+    have := congrFun h' τ
+    simp only [Pi.zero_apply] at this
+    simp [this])
+  have := congrArg (Polynomial.eval (jAnalytic τ₀ + 1)) htr
+  simp at this
+
+theorem ordAt_jSub_pos (τ₀ : ℍ) : 0 < ordAt τ₀ ((jSub N τ₀ : ring N) : ℍ → ℂ) := by
+  have hne : ((jSub N τ₀ : ring N) : ℍ → ℂ) ≠ 0 := fun h => jSub_ne_zero N τ₀ (Subtype.ext h)
+  have hcast := ordAt_cast N (jSub N τ₀).2 hne τ₀
+  by_contra h0
+  push Not at h0
+  have h0' : ordAt τ₀ ((jSub N τ₀ : ring N) : ℍ → ℂ) = 0 := Nat.le_zero.mp h0
+  rw [h0', Nat.cast_zero, eq_comm, analyticOrderAt_eq_zero] at hcast
+  rcases hcast with h | h
+  · exact h (analyticAt_ext N (jSub N τ₀).2 τ₀)
+  · apply h
+    rw [ext_apply_coe, coe_jSub]
+    simp
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem ordValuationK_jSub_lt_one (τ₀ : ℍ) :
+    ordValuationK N K τ₀ (algebraMap (ring N) K (jSub N τ₀)) < 1 := by
+  rw [ordValuationK_algebraMap, ordFun_of_ne_zero N τ₀ (fun h => jSub_ne_zero N τ₀ (Subtype.ext h)),
+    ← WithZero.exp_zero, WithZero.exp_lt_exp]
+  have := ordAt_jSub_pos N τ₀
+  omega
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem isNontrivial_ordValuationK (τ₀ : ℍ) : (ordValuationK N K τ₀).IsNontrivial := by
+  refine ⟨algebraMap (ring N) K (jSub N τ₀), ?_, ?_⟩
+  · rw [ordValuationK_algebraMap]
+    exact ordValuation_ne_zero N τ₀ (jSub_ne_zero N τ₀)
+  · exact (ordValuationK_jSub_lt_one N K τ₀).ne
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem nontrivial_valueGroup (τ₀ : ℍ) :
+    Nontrivial (ordValuationK N K τ₀).toMonoidWithZeroHom.valueGroup := by
+  rw [Subgroup.nontrivial_iff_exists_ne_one]
+  have hne : ordValuationK N K τ₀ (algebraMap (ring N) K (jSub N τ₀)) ≠ 0 := by
+    rw [ordValuationK_algebraMap]
+    exact ordValuation_ne_zero N τ₀ (jSub_ne_zero N τ₀)
+  refine ⟨Units.mk0 _ hne, ?_, ?_⟩
+  · exact MonoidWithZeroHom.mem_valueGroup _ ⟨_, rfl⟩
+  · intro h
+    have h' :=
+      congrArg (fun u : (WithZero (Multiplicative ℤ))ˣ => (u : WithZero (Multiplicative ℤ))) h
+    simp only [Units.val_mk0, Units.val_one] at h'
+    exact (ordValuationK_jSub_lt_one N K τ₀).ne h'
+
+def analyticPlace (τ₀ : ℍ) : AlgebraicCurve.Place ℂ K :=
+  haveI := nontrivial_valueGroup N K τ₀
+  { toValuationSubring := (ordValuationK N K τ₀).valuationSubring
+    algebraMap_mem' := fun a => by
+      rw [Valuation.mem_valuationSubring_iff]
+      by_cases ha : a = 0
+      · simp [ha]
+      · rw [IsScalarTower.algebraMap_apply ℂ (ring N) K, ordValuationK_algebraMap,
+          ordFun_of_ne_zero N τ₀ (by
+            intro h
+            have := congrFun h UpperHalfPlane.I
+            simp [Algebra.algebraMap_eq_smul_one, ha] at this)]
+        rw [← WithZero.exp_zero, WithZero.exp_le_exp]
+        have : ordAt τ₀ ((algebraMap ℂ (ring N) a : ring N) : ℍ → ℂ) = 0 := by
+          unfold ordAt
+          have : analyticOrderAt (ext ((algebraMap ℂ (ring N) a : ring N) : ℍ → ℂ)) τ₀ = 0 := by
+            rw [analyticOrderAt_eq_zero]
+            right
+            simp [ext, Algebra.algebraMap_eq_smul_one, ha]
+          rw [this]; rfl
+        omega
+    ne_top' := by
+      rw [ne_eq, Valuation.valuationSubring_eq_top_iff, not_not]
+      exact isNontrivial_ordValuationK N K τ₀
+    isPrincipalIdealRing' :=
+      (Valuation.valuationSubring_isDiscreteValuationRing
+        (ordValuationK N K τ₀)).toIsPrincipalIdealRing }
+
+@[scoped simp]
+theorem analyticPlace_toValuationSubring (τ₀ : ℍ) :
+    (analyticPlace N K τ₀).toValuationSubring = (ordValuationK N K τ₀).valuationSubring := rfl
+
+theorem mem_analyticPlace_iff (τ₀ : ℍ) (x : K) :
+    x ∈ (analyticPlace N K τ₀).toValuationSubring ↔ ordValuationK N K τ₀ x ≤ 1 := by
+  rw [analyticPlace_toValuationSubring, Valuation.mem_valuationSubring_iff]
+
+theorem inv_jSub_notMem (τ₀ : ℍ) :
+    (algebraMap (ring N) K (jSub N τ₀))⁻¹ ∉ (analyticPlace N K τ₀).toValuationSubring := by
+  rw [mem_analyticPlace_iff, map_inv₀, not_le, one_lt_inv₀]
+  · exact ordValuationK_jSub_lt_one N K τ₀
+  · rw [ordValuationK_algebraMap]
+    exact (zero_le.lt_of_ne (ordValuation_ne_zero N τ₀ (jSub_ne_zero N τ₀)).symm)
+
+theorem jSub_mem_nonunits (τ₀ : ℍ) :
+    algebraMap (ring N) K (jSub N τ₀) ∈ (analyticPlace N K τ₀).toValuationSubring.nonunits := by
+  rw [ValuationSubring.mem_nonunits_iff_or]
+  exact Or.inr (inv_jSub_notMem N K τ₀)
+
+theorem algebraMap_mem_analyticPlace (τ₀ : ℍ) (F : ring N) :
+    algebraMap (ring N) K F ∈ (analyticPlace N K τ₀).toValuationSubring := by
+  rw [mem_analyticPlace_iff, ordValuationK_algebraMap]
+  by_cases hF : (F : ℍ → ℂ) = 0
+  · rw [ordFun_zero' N τ₀ hF]; exact zero_le
+  · rw [ordFun_of_ne_zero N τ₀ hF, ← WithZero.exp_zero, WithZero.exp_le_exp]
+    omega
+
+end FractionField
+
+omit [NeZero N] in
+def moeb (δ : SL(2, ℤ)) (z : ℂ) : ℂ :=
+  (((δ 0 0 : ℤ) : ℂ) * z + ((δ 0 1 : ℤ) : ℂ)) / (((δ 1 0 : ℤ) : ℂ) * z + ((δ 1 1 : ℤ) : ℂ))
+
+omit [NeZero N] in
+theorem coe_smul_eq_moeb (δ : SL(2, ℤ)) (τ : ℍ) : ((δ • τ : ℍ) : ℂ) = moeb δ τ := by
+  rw [UpperHalfPlane.specialLinearGroup_apply]
+  simp [moeb]
+
+omit [NeZero N] in
+theorem moeb_denom_ne_zero (δ : SL(2, ℤ)) (τ : ℍ) :
+    ((δ 1 0 : ℤ) : ℂ) * (τ : ℂ) + ((δ 1 1 : ℤ) : ℂ) ≠ 0 := by
+  intro h
+  have him := congrArg Complex.im h
+  simp only [Complex.add_im, Complex.mul_im, Complex.intCast_re, Complex.intCast_im, zero_mul,
+    add_zero, Complex.zero_im] at him
+  have hc : ((δ 1 0 : ℤ) : ℝ) = 0 := by
+    rcases mul_eq_zero.mp him with h1 | h1
+    · exact h1
+    · exact absurd h1 τ.im_pos.ne'
+  have hc' : (δ 1 0 : ℤ) = 0 := by exact_mod_cast hc
+  have hre := congrArg Complex.re h
+  simp only [Complex.intCast_re, zero_mul, Complex.zero_re, hc', Int.cast_zero, zero_add] at hre
+  have hd' : (δ 1 1 : ℤ) = 0 := by exact_mod_cast hre
+  have hdet := δ.2
+  rw [Matrix.det_fin_two, hc', hd'] at hdet
+  simp at hdet
+
+omit [NeZero N] in
+theorem analyticAt_moeb (δ : SL(2, ℤ)) (τ : ℍ) : AnalyticAt ℂ (moeb δ) τ := by
+  unfold moeb
+  exact ((analyticAt_const.mul analyticAt_id).add analyticAt_const).div
+    ((analyticAt_const.mul analyticAt_id).add analyticAt_const) (moeb_denom_ne_zero δ τ)
+
+omit [NeZero N] in
+theorem hasDerivAt_moeb (δ : SL(2, ℤ)) (τ : ℍ) :
+    HasDerivAt (moeb δ) ((((δ 1 0 : ℤ) : ℂ) * (τ : ℂ) + ((δ 1 1 : ℤ) : ℂ)) ^ 2)⁻¹ τ := by
+  have hden := moeb_denom_ne_zero δ τ
+  have hnum : HasDerivAt (fun z : ℂ => ((δ 0 0 : ℤ) : ℂ) * z + ((δ 0 1 : ℤ) : ℂ))
+      ((δ 0 0 : ℤ) : ℂ) (τ : ℂ) := by
+    simpa using ((hasDerivAt_id (τ : ℂ)).const_mul ((δ 0 0 : ℤ) : ℂ)).add_const ((δ 0 1 : ℤ) : ℂ)
+  have hden' : HasDerivAt (fun z : ℂ => ((δ 1 0 : ℤ) : ℂ) * z + ((δ 1 1 : ℤ) : ℂ))
+      ((δ 1 0 : ℤ) : ℂ) (τ : ℂ) := by
+    simpa using ((hasDerivAt_id (τ : ℂ)).const_mul ((δ 1 0 : ℤ) : ℂ)).add_const ((δ 1 1 : ℤ) : ℂ)
+  have h := hnum.div hden' hden
+  have hdet : ((δ 0 0 : ℤ) : ℂ) * ((δ 1 1 : ℤ) : ℂ) - ((δ 0 1 : ℤ) : ℂ) * ((δ 1 0 : ℤ) : ℂ) = 1 :=
+    by
+    have := δ.2
+    rw [Matrix.det_fin_two] at this
+    exact_mod_cast this
+  convert h using 1 <;> try rfl
+  rw [inv_eq_one_div]
+  congr 1
+  linear_combination -hdet
+
+omit [NeZero N] in
+theorem deriv_moeb_ne_zero (δ : SL(2, ℤ)) (τ : ℍ) : deriv (moeb δ) τ ≠ 0 := by
+  rw [(hasDerivAt_moeb δ τ).deriv]
+  exact inv_ne_zero (pow_ne_zero _ (moeb_denom_ne_zero δ τ))
+
+omit [NeZero N] in
+theorem ext_comp_smul_eventuallyEq (δ : SL(2, ℤ)) (F : ℍ → ℂ) (τ₀ : ℍ) :
+    ext (fun τ : ℍ => F (δ • τ)) =ᶠ[𝓝 (τ₀ : ℂ)] (ext F ∘ moeb δ) := by
+  filter_upwards [isOpen_upperHalfPlaneSet.mem_nhds τ₀.im_pos] with z hz
+  have hz' : 0 < z.im := hz
+  simp only [ext, Function.comp_apply, ofComplex_apply_of_im_pos hz']
+  have hmem : 0 < (moeb δ z).im := by
+    have := (δ • (⟨z, hz'⟩ : ℍ)).im_pos
+    rwa [show ((δ • (⟨z, hz'⟩ : ℍ) : ℍ).im) = (moeb δ z).im by
+      rw [← UpperHalfPlane.coe_im, coe_smul_eq_moeb]] at this
+  rw [ofComplex_apply_of_im_pos hmem]
+  congr 1
+  ext1
+  simpa using coe_smul_eq_moeb δ ⟨z, hz'⟩
+
+omit [NeZero N] in
+theorem analyticOrderAt_ext_comp_smul (δ : SL(2, ℤ)) (F : ℍ → ℂ) (τ₀ : ℍ) :
+    analyticOrderAt (ext (fun τ : ℍ => F (δ • τ))) τ₀ = analyticOrderAt (ext F) ((δ • τ₀ : ℍ) : ℂ)
+      := by
+  rw [analyticOrderAt_congr (ext_comp_smul_eventuallyEq δ F τ₀),
+    analyticOrderAt_comp_of_deriv_ne_zero (analyticAt_moeb δ τ₀) (deriv_moeb_ne_zero δ τ₀),
+    coe_smul_eq_moeb]
+
+omit [NeZero N] in
+theorem ordAt_comp_smul (δ : SL(2, ℤ)) (F : ℍ → ℂ) (τ₀ : ℍ) :
+    ordAt τ₀ (fun τ : ℍ => F (δ • τ)) = ordAt (δ • τ₀) F := by
+  unfold ordAt
+  rw [analyticOrderAt_ext_comp_smul]
+
+omit [NeZero N] in
+theorem comp_smul_eq_zero_iff (δ : SL(2, ℤ)) (F : ℍ → ℂ) :
+    (fun τ : ℍ => F (δ • τ)) = 0 ↔ F = 0 := by
+  constructor
+  · intro h
+    funext τ
+    have := congrFun h (δ⁻¹ • τ)
+    simpa using this
+  · rintro rfl
+    rfl
+
+omit [NeZero N] in
+theorem ordFun_comp_smul (τ₀ : ℍ) (δ : SL(2, ℤ)) (hδ : δ • τ₀ = τ₀) (F : ring N)
+    (hFδ : (fun τ : ℍ => (F : ℍ → ℂ) (δ • τ)) ∈ ring N) :
+    ordFun N τ₀ ⟨fun τ : ℍ => (F : ℍ → ℂ) (δ • τ), hFδ⟩ = ordFun N τ₀ F := by
+  by_cases hF : (F : ℍ → ℂ) = 0
+  · rw [ordFun_zero' N τ₀ hF, ordFun_zero' N τ₀ (by
+      change (fun τ : ℍ => (F : ℍ → ℂ) (δ • τ)) = 0
+      rw [comp_smul_eq_zero_iff]; exact hF)]
+  · have hF' : (fun τ : ℍ => (F : ℍ → ℂ) (δ • τ)) ≠ 0 := by
+      rw [Ne, comp_smul_eq_zero_iff]; exact hF
+    rw [ordFun_of_ne_zero N τ₀ hF, ordFun_of_ne_zero N τ₀ (F := ⟨_, hFδ⟩) hF']
+    congr 2
+    change ((ordAt τ₀ (fun τ : ℍ => (F : ℍ → ℂ) (δ • τ)) : ℕ) : ℤ) = _
+    rw [ordAt_comp_smul, hδ]
+
+section Stabiliser
+
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ring N) K] [IsScalarTower ℂ (ring N) K]
+  [IsFractionRing (ring N) K]
+
+omit [IsScalarTower ℂ (↥(ring N)) K] in
+theorem ordValuationK_algEquiv (τ₀ : ℍ) (δ : SL(2, ℤ)) (hδ : δ • τ₀ = τ₀)
+    (hst : ∀ F ∈ ring N, (fun τ : ℍ => F (δ • τ)) ∈ ring N) (φ : K ≃ₐ[ℂ] K)
+    (hφ : ∀ (F : ℍ → ℂ) (hF : F ∈ ring N),
+      φ (algebraMap (ring N) K ⟨F, hF⟩) = algebraMap (ring N) K ⟨fun τ : ℍ => F (δ • τ), hst F hF⟩)
+    (x : K) : ordValuationK N K τ₀ (φ x) = ordValuationK N K τ₀ x := by
+  obtain ⟨a, b, hb, rfl⟩ := IsFractionRing.div_surjective (A := ring N) x
+  rw [map_div₀, map_div₀, map_div₀]
+  have ha := hφ (a : ℍ → ℂ) a.2
+  have hb' := hφ (b : ℍ → ℂ) b.2
+  simp only [Subtype.coe_eta] at ha hb'
+  rw [ha, hb', ordValuationK_algebraMap, ordValuationK_algebraMap, ordValuationK_algebraMap,
+    ordValuationK_algebraMap, ordFun_comp_smul N τ₀ δ hδ a, ordFun_comp_smul N τ₀ δ hδ b]
+
+theorem smul_analyticPlace_eq (τ₀ : ℍ) (δ : SL(2, ℤ)) (hδ : δ • τ₀ = τ₀)
+    (hst : ∀ F ∈ ring N, (fun τ : ℍ => F (δ • τ)) ∈ ring N) (φ : K ≃ₐ[ℂ] K)
+    (hφ : ∀ (F : ℍ → ℂ) (hF : F ∈ ring N),
+      φ (algebraMap (ring N) K ⟨F, hF⟩) = algebraMap (ring N) K ⟨fun τ : ℍ => F (δ • τ), hst F
+        hF⟩) :
+    AlgebraicCurve.SemilinearAut.ofAlgAut φ • analyticPlace N K τ₀ = analyticPlace N K τ₀ := by
+  apply AlgebraicCurve.Place.ext
+  rw [AlgebraicCurve.SemilinearAut.smul_toValuationSubring]
+  ext x
+  rw [ValuationSubring.mem_pointwise_smul_iff_inv_smul_mem, ← map_inv,
+    AlgebraicCurve.SemilinearAut.ofAlgAut_smul, mem_analyticPlace_iff, mem_analyticPlace_iff]
+  have h := ordValuationK_algEquiv N K τ₀ δ hδ hst φ hφ (φ⁻¹ x)
+  rw [show φ (φ⁻¹ x) = x from φ.apply_symm_apply x] at h
+  rw [h]
+
+theorem ord_jSub_pos (τ₀ : ℍ) :
+    0 < (analyticPlace N K τ₀).ord (algebraMap (ring N) K (jGen N) - algebraMap ℂ K (jAnalytic τ₀))
+      := by
+  have hmem := jSub_mem_nonunits N K τ₀
+  have heq : algebraMap (ring N) K (jSub N τ₀) =
+      algebraMap (ring N) K (jGen N) - algebraMap ℂ K (jAnalytic τ₀) := by
+    rw [jSub, map_sub, ← IsScalarTower.algebraMap_apply]
+  rw [← heq]
+  set W := analyticPlace N K τ₀
+  set y := algebraMap (ring N) K (jSub N τ₀) with hy
+  have hy0 : y ≠ 0 := by
+    rw [hy]
+    intro h
+    exact jSub_ne_zero N τ₀ ((IsFractionRing.injective (ring N) K)
+      (by rw [h, map_zero]))
+  obtain ⟨hyW, hmax⟩ := ValuationSubring.mem_nonunits_iff_exists_mem_maximalIdeal.mp hmem
+  have hval : W.adicValuation y < 1 := by
+    rw [W.adicValuation_coe ⟨y, hyW⟩,
+      IsDedekindDomain.HeightOneSpectrum.intValuation_lt_one_iff_mem]
+    exact hmax
+  have hne : W.adicValuation y ≠ 0 := W.adicValuation_ne_zero hy0
+  rw [AlgebraicCurve.Place.ord, neg_pos, WithZero.log_lt_iff_lt_exp hne, WithZero.exp_zero]
+  exact hval
+
+end Stabiliser
+
+end ModularCurve.LevelN.AnalyticPlaces
+
+open _root_.ModularCurve.LevelN
+  _root_.P2MW.S_OVERLONG_3959a5e7.ModularCurve.LevelN
+  _root_.P2MW.S_OVERLONG_3959a5e7.ModularCurve.LevelN.AnalyticPlaces
+  in
+theorem solution (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring N) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring N) K]
+    [IsFractionRing (ModularCurve.LevelN.ring N) K] (τ₀ : UpperHalfPlane) :
+    ∃ W : AlgebraicCurve.Place ℂ K,
+      0 < W.ord (algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N) -
+          algebraMap ℂ K (ModularCurve.LevelN.jAnalytic τ₀)) ∧
+      ∀ (γ : SL(2, ℤ)) (_ : γ • τ₀ = τ₀)
+        (hst : ∀ F ∈ ModularCurve.LevelN.ring N,
+          (fun τ : UpperHalfPlane => F (γ⁻¹ • τ)) ∈ ModularCurve.LevelN.ring N)
+        (φ : K ≃ₐ[ℂ] K),
+        (∀ (F : UpperHalfPlane → ℂ) (hF : F ∈ ModularCurve.LevelN.ring N),
+            φ (algebraMap (ModularCurve.LevelN.ring N) K ⟨F, hF⟩) =
+              algebraMap (ModularCurve.LevelN.ring N) K
+                ⟨fun τ : UpperHalfPlane => F (γ⁻¹ • τ), hst F hF⟩) →
+        AlgebraicCurve.SemilinearAut.ofAlgAut φ • W = W := by
+  refine ⟨analyticPlace N K τ₀, ord_jSub_pos N K τ₀, ?_⟩
+  intro γ hγ hst φ hφ
+  have hδ : γ⁻¹ • τ₀ = τ₀ := by
+    conv_lhs => rw [← hγ]
+    rw [inv_smul_smul]
+  exact smul_analyticPlace_eq N K τ₀ γ⁻¹ hδ hst φ hφ
+
+end
+end S_OVERLONG_3959a5e7
+end P2MW
+export P2MW.S_OVERLONG_3959a5e7 (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.LevelN.exists_place_ord_sub_pos_forall_smul_eq (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring N) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring N) K]
+    [IsFractionRing (ModularCurve.LevelN.ring N) K] (τ₀ : UpperHalfPlane) :
+    ∃ W : AlgebraicCurve.Place ℂ K,
+      0 < W.ord (algebraMap (ModularCurve.LevelN.ring N) K (ModularCurve.LevelN.jGen N) -
+          algebraMap ℂ K (ModularCurve.LevelN.jAnalytic τ₀)) ∧
+      ∀ (γ : SL(2, ℤ)) (_ : γ • τ₀ = τ₀)
+        (hst : ∀ F ∈ ModularCurve.LevelN.ring N,
+          (fun τ : UpperHalfPlane => F (γ⁻¹ • τ)) ∈ ModularCurve.LevelN.ring N)
+        (φ : K ≃ₐ[ℂ] K),
+        (∀ (F : UpperHalfPlane → ℂ) (hF : F ∈ ModularCurve.LevelN.ring N),
+            φ (algebraMap (ModularCurve.LevelN.ring N) K ⟨F, hF⟩) =
+              algebraMap (ModularCurve.LevelN.ring N) K
+                ⟨fun τ : UpperHalfPlane => F (γ⁻¹ • τ), hst F hF⟩) →
+        AlgebraicCurve.SemilinearAut.ofAlgAut φ • W = W :=
+  solution N K τ₀
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_isDomain_ring.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_isDomain_ring.lean
new file mode 100644
index 0000000000..8f2a64ab72
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_isDomain_ring.lean
@@ -0,0 +1,94 @@
+/-
+Based on Prove2Me node ModularCurve.LevelN.isDomain_ring
+(fccdc20b-3a1a-5bc6-a90b-d25f25b7fb94) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1f2d0570-7bf2-5618-a906-add1a8ff3677
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LevelNFunctionField
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelN_structure_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The level-M modular function algebra is a domain
+
+Theorem statement: `ModularCurve.LevelN.isDomain_ring` (`fccdc20b-3a1a-5bc6-a90b-d25f25b7fb94`), by
+Claude, 2026-09-05.
+
+Proof: submission `1f2d0570-7bf2-5618-a906-add1a8ff3677`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $M \neq 0$. Inside the commutative $\mathbb{C}$-algebra of all functions
+$\mathbb{H} \to \mathbb{C}$ with pointwise operations, consider the $\mathbb{C}$-subalgebra
+[`ModularCurve.LevelN.ring M`](def/ModularCurve_LevelNFunctionField.html#L28), defined as the
+algebra generated by the set [`ModularCurve.LevelN.generators
+M`](def/ModularCurve_LevelNFunctionField.html#L25), which consists of the function
+[`ModularCurve.LevelN.jAnalytic`](def/ModularCurve_LevelNFunctionField.html#L22) together with all
+functions of the form [`ModularCurve.LevelN.fricke M
+v`](def/ModularCurve_LevelNFunctionField.html#L19) for $v \colon \mathrm{Fin}\,2 \to \mathbb{Z}/M$
+with $v \neq 0$; concretely, the first generator is $\tau \mapsto E_4(\tau)^3/\Delta(\tau)$, and the
+generator attached to $v$ is $\tau \mapsto -\bigl(E_4(\tau)E_6(\tau)/\Delta(\tau)\bigr)/2592 \cdot
+(2\pi i)^{-2}\,\wp\bigl(\tfrac{v_0\tau + v_1}{M}\bigr)$, the Weierstrass $\wp$-function being taken
+for the period pair with $\omega_1 = \tau$, $\omega_2 = 1$. The assertion is that this subalgebra,
+with its induced ring structure, is an integral domain: it is a nontrivial commutative ring in which
+a product of two nonzero elements is nonzero.
+
+This supplies the fact tacitly needed to speak of the function field of the modular curve of level
+$M$: the ring of functions generated by $j$ and the nonzero Fricke functions has a field of
+fractions, so statements about the level-$M$ function field phrased for an arbitrary fraction field
+of this ring may be instantiated. It is used in the treatment of orders of vanishing and of the
+$X_1$-function-field relations for coprime levels.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_LevelN_isDomain_ring.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_LevelN_isDomain_ring
+
+open scoped MatrixGroups
+
+theorem solution (M : ℕ) [NeZero M] : IsDomain (ModularCurve.LevelN.ring M) := by
+  have hpkg := WLight.levelN_structure_package M PeriodPair.ofTau
+    (fun τ => ⟨PeriodPair.ofTau_ω₁ τ, PeriodPair.ofTau_ω₂ τ⟩)
+    (ModularCurve.LevelN.wp M) (fun v τ => rfl)
+    (ModularCurve.LevelN.fricke M) (fun v τ => rfl)
+    ModularCurve.LevelN.jAnalytic (fun τ => rfl)
+  obtain ⟨-, -, -, -, -, hdom⟩ := hpkg
+  have : NoZeroDivisors (ModularCurve.LevelN.ring M) := ⟨fun {a b} h => by
+    have h' := hdom (a : UpperHalfPlane → ℂ) (b : UpperHalfPlane → ℂ) a.2 b.2
+      (by simpa using congrArg Subtype.val h)
+    rcases h' with ha | hb
+    · left; exact Subtype.ext ha
+    · right; exact Subtype.ext hb⟩
+  have : Nontrivial (ModularCurve.LevelN.ring M) := inferInstance
+  exact NoZeroDivisors.to_isDomain _
+
+end S_ModularCurve_LevelN_isDomain_ring
+end P2MW
+export P2MW.S_ModularCurve_LevelN_isDomain_ring (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem ModularCurve.LevelN.isDomain_ring (M : ℕ) [NeZero M] :
+    IsDomain (ModularCurve.LevelN.ring M) :=
+  solution M
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_isZeroAtImInfty_slash_of_mem_regularDifferentials.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_isZeroAtImInfty_slash_of_mem_regularDifferentials.lean
new file mode 100644
index 0000000000..ea051edc06
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_isZeroAtImInfty_slash_of_mem_regularDifferentials.lean
@@ -0,0 +1,969 @@
+/-
+Based on Prove2Me node ModularCurve.LevelN.isZeroAtImInfty_slash_of_mem_regularDifferentials
+(23d0ecd6-c944-594c-af05-13d149f8c0cb) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 68d565ba-6a42-586f-bfa1-32032978340e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RegularDifferentials
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LevelNFunctionField
+
+import Mathlib.Algebra.CharP.Pi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_of_orderMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_modularity_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_orbit_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelN_structure_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Regular differentials of level N vanish at every cusp
+
+Theorem statement: `ModularCurve.LevelN.isZeroAtImInfty_slash_of_mem_regularDifferentials`
+(`23d0ecd6-c944-594c-af05-13d149f8c0cb`), by Claude, 2026-09-05.
+
+Proof: submission `68d565ba-6a42-586f-bfa1-32032978340e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N \ge 1$ and write $A_N =$ [`ModularCurve.LevelN.ring
+N`](def/ModularCurve_LevelNFunctionField.html#L28) for the $\mathbb{C}$-subalgebra of functions
+$\mathbb{H} \to \mathbb{C}$ generated by the analytic $j$-function together with the Fricke
+functions $\mathrm{fricke}\,N\,v$ for $0 \ne v \in (\mathbb{Z}/N)^2$. Let $K$ be a field that is
+simultaneously a $\mathbb{C}$-algebra and an $A_N$-algebra, compatibly (scalar tower), and that is a
+fraction field of $A_N$. Let $\omega \in \Omega_{K/\mathbb{C}}$ lie in
+[`AlgebraicCurve.regularDifferentials`](def/AlgebraicCurve_RegularDifferentials.html#L26), i.e. for
+every place $v$ of $K/\mathbb{C}$ — a valuation subring of $K$ containing the image of $\mathbb{C}$,
+distinct from $K$, and a principal ideal ring — there is $f$ in that valuation subring with $\omega
+= f \cdot d t_v$, where $t_v$ is the chosen uniformiser of $v$. Let $F : \mathbb{H} \to \mathbb{C}$
+be a function representing $\omega$ as $F(\tau)\,d\tau$ in the following sense: whenever $a, b, c, e
+\in A_N$ with $b \ne 0$, $e \ne 0$ and $\omega = (a/b) \cdot d(c/e)$ in $\Omega_{K/\mathbb{C}}$
+(images taken under $A_N \to K$), one has $F(\tau)\,b(\tau)\,e(\tau)^2 =
+a(\tau)\bigl(e(\tau)c'(\tau) - c(\tau)e'(\tau)\bigr)$ for all $\tau \in \mathbb{H}$, the derivatives
+being those of the functions transported to the complex plane. Then for every $\delta \in
+\mathrm{SL}(2,\mathbb{Z})$ the weight-$2$ slash $F \mid_2 \delta$ is zero at $i\infty$.
+
+This is the assertion that a differential of the first kind on the modular curve of level $N$, read
+on the upper half-plane as $F(\tau)\,d\tau$, gives a function $F$ vanishing at every cusp, the cusps
+being the places of the function field obtained from the $q$-expansion valuations at $\delta \cdot
+i\infty$. It feeds the construction of an injective linear map from the regular differentials of the
+level-$N$ function field to weight-$2$ cusp forms,
+[`ModularCurve.LevelN.exists_linearMap_regularDifferentials_cuspForm_injective`]
+(thm.html#ModularCurve.LevelN.exists_linearMap_regularDifferentials_cuspForm_injective).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_LevelN_isZeroAtImInfty_slash_of_mem_regularDifferentials.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_LevelN_isZeroAtImInfty_slash_of_mem_regularDifferentials
+
+
+noncomputable section
+
+p2m_open "UpperHalfPlane Filter Topology Function Complex Function.Complex"
+open scoped Manifold MatrixGroups ModularForm
+
+namespace ModularCurve
+p2m_export "ModularCurve" "LevelN.ring"
+namespace LevelN
+p2m_export "ModularCurve.LevelN" "wp fricke jAnalytic generators ring jAnalytic_mem fricke_mem \
+  jGen coe_jGen"
+namespace CuspVanish
+p2m_open "ModularCurve.LevelN ModularCurve"
+
+variable (N : ℕ) [NeZero N]
+
+local notation "𝕢" => Function.Periodic.qParam
+
+abbrev redMat (γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) (ZMod N) :=
+  (γ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N)
+
+theorem structure_pkg :
+    let A_N : Subalgebra ℂ (ℍ → ℂ) := Algebra.adjoin ℂ
+      (insert jAnalytic {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke N v})
+    (∀ P : Polynomial ℂ, (∀ τ : ℍ, P.eval (jAnalytic τ) = 0) → P = 0)
+    ∧ (∀ F ∈ A_N, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F)
+    ∧ (∀ a b : ℍ → ℂ, a ∈ A_N → b ∈ A_N → a * b = 0 → a = 0 ∨ b = 0) := by
+  have h := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact ⟨h.2.2.2.1, h.2.2.2.2.1, h.2.2.2.2.2⟩
+
+theorem mdifferentiable_of_mem {F : ℍ → ℂ} (hF : F ∈ ring N) : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F :=
+  (structure_pkg N).2.1 F hF
+
+theorem eq_zero_or_eq_zero_of_mul_eq_zero {a b : ℍ → ℂ} (ha : a ∈ ring N) (hb : b ∈ ring N)
+    (hab : a * b = 0) : a = 0 ∨ b = 0 :=
+  (structure_pkg N).2.2 a b ha hb hab
+
+theorem mul_ne_zero_of_mem {a b : ℍ → ℂ} (ha : a ∈ ring N) (hb : b ∈ ring N) (ha0 : a ≠ 0)
+    (hb0 : b ≠ 0) : a * b ≠ 0 := fun h =>
+  (eq_zero_or_eq_zero_of_mul_eq_zero N ha hb h).elim ha0 hb0
+
+include N in
+theorem jAnalytic_transcendental (P : Polynomial ℂ) (hP : ∀ τ : ℍ, P.eval (jAnalytic τ) = 0) :
+    P = 0 :=
+  (structure_pkg N).1 P hP
+
+theorem fricke_smul (v : Fin 2 → ZMod N) (γ : SL(2, ℤ)) (τ : ℍ) :
+    fricke N v (γ • τ) = fricke N (Matrix.vecMul v (redMat N γ)) τ :=
+  (WLight.frickeFunction_modularity_package N PeriodPair.ofTau (fun _ => ⟨rfl, rfl⟩)).1 v γ τ
+
+theorem fricke_smul_of_mem (v : Fin 2 → ZMod N) {γ : SL(2, ℤ)}
+    (hγ : γ ∈ CongruenceSubgroup.Gamma N) (τ : ℍ) : fricke N v (γ • τ) = fricke N v τ :=
+  (WLight.frickeFunction_modularity_package N PeriodPair.ofTau
+    (fun _ => ⟨rfl, rfl⟩)).2.2.2.2.2.2.1 v γ hγ τ
+
+theorem orbit_pkg :
+    (∃ m : ℕ, IsBoundedAtImInfty (jAnalytic * ModularForm.discriminant ^ m)) ∧
+    ∀ v : Fin 2 → ZMod N, v ≠ 0 →
+      ∃ m : ℕ, IsBoundedAtImInfty (fricke N v * ModularForm.discriminant ^ m) := by
+  have h := WLight.frickeFunction_orbit_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact ⟨h.1.2, fun v hv => (h.2.1 v hv).2⟩
+
+omit [NeZero N] in
+theorem jAnalytic_smul (γ : SL(2, ℤ)) (τ : ℍ) : jAnalytic (γ • τ) = jAnalytic τ := by
+  have hmem : (γ : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ, rfl⟩
+  have h4 : (ModularForm.E₄ : ℍ → ℂ) ((γ : GL (Fin 2) ℝ) • τ) =
+      denom (γ : GL (Fin 2) ℝ) τ ^ (4 : ℤ) * ModularForm.E₄ τ :=
+    SlashInvariantForm.slash_action_eqn'' _ hmem τ
+  have h12 : ModularForm.discriminant ((γ : GL (Fin 2) ℝ) • τ) =
+      denom (γ : GL (Fin 2) ℝ) τ ^ (12 : ℤ) * ModularForm.discriminant τ := by
+    have := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hmem τ
+    simpa using this
+  have hd : denom (γ : GL (Fin 2) ℝ) τ ≠ 0 := denom_ne_zero _ _
+  have hΔ : ModularForm.discriminant τ ≠ 0 := ModularForm.discriminant_ne_zero τ
+  rw [jAnalytic, jAnalytic, ModularGroup.sl_moeb, h4, h12]
+  field_simp
+
+omit [NeZero N] in
+theorem vecMul_ne_zero {v : Fin 2 → ZMod N} (hv : v ≠ 0) (γ : SL(2, ℤ)) :
+    Matrix.vecMul v (redMat N γ) ≠ 0 := by
+  intro h
+  apply hv
+  have hdet : (redMat N γ).det = 1 := by
+    have := congrArg ((↑) : ℤ → ZMod N) γ.2
+    rw [Int.cast_one] at this
+    rw [← this, redMat]
+    exact (RingHom.map_det (Int.castRingHom (ZMod N)) _).symm
+  have hunit : IsUnit (redMat N γ).det := by rw [hdet]; exact isUnit_one
+  have := congrArg (fun w => Matrix.vecMul w (redMat N γ)⁻¹) h
+  simp only [Matrix.vecMul_vecMul, Matrix.mul_nonsing_inv _ hunit, Matrix.vecMul_one,
+    Matrix.zero_vecMul] at this
+  exact this
+
+omit [NeZero N] in
+def precomp (g : SL(2, ℤ)) : (ℍ → ℂ) →ₐ[ℂ] (ℍ → ℂ) :=
+  AlgHom.pi (fun τ => Pi.evalAlgHom ℂ (fun _ : ℍ => ℂ) (g • τ))
+
+omit [NeZero N] in
+@[scoped simp]
+theorem precomp_apply (g : SL(2, ℤ)) (F : ℍ → ℂ) (τ : ℍ) : precomp g F τ = F (g • τ) := rfl
+
+theorem precomp_mem (g : SL(2, ℤ)) {F : ℍ → ℂ} (hF : F ∈ ring N) : precomp g F ∈ ring N := by
+  have hle : (ring N).map (precomp g) ≤ ring N := by
+    rw [ring, AlgHom.map_adjoin, Algebra.adjoin_le_iff]
+    rintro _ ⟨G, hG, rfl⟩
+    rcases hG with rfl | ⟨v, hv, rfl⟩
+    · have : precomp g jAnalytic = jAnalytic := funext fun τ => jAnalytic_smul g τ
+      rw [this]
+      exact jAnalytic_mem N
+    · have : precomp g (fricke N v) = fricke N (Matrix.vecMul v (redMat N g)) :=
+        funext fun τ => fricke_smul N v g τ
+      rw [this]
+      exact fricke_mem N (vecMul_ne_zero N hv g)
+  exact hle ⟨F, hF, rfl⟩
+
+theorem precomp_precomp_inv (g : SL(2, ℤ)) (F : ℍ → ℂ) : precomp g⁻¹ (precomp g F) = F := by
+  funext τ
+  simp [smul_smul]
+
+theorem precomp_ne_zero (g : SL(2, ℤ)) {F : ℍ → ℂ} (hF : F ≠ 0) : precomp g F ≠ 0 := fun h =>
+  hF (by rw [← precomp_precomp_inv g F, h, map_zero])
+
+theorem apply_smul_of_mem {γ : SL(2, ℤ)} (hγ : γ ∈ CongruenceSubgroup.Gamma N) {F : ℍ → ℂ}
+    (hF : F ∈ ring N) (τ : ℍ) : F (γ • τ) = F τ := by
+  have hle : ring N ≤ AlgHom.equalizer (precomp γ) (AlgHom.id ℂ (ℍ → ℂ)) := by
+    rw [ring, Algebra.adjoin_le_iff]
+    intro G hG
+    rw [SetLike.mem_coe, AlgHom.mem_equalizer, AlgHom.id_apply]
+    funext τ
+    rw [precomp_apply]
+    rcases hG with rfl | ⟨v, hv, rfl⟩
+    · exact jAnalytic_smul γ τ
+    · exact fricke_smul_of_mem N v hγ τ
+  have := hle hF
+  rw [AlgHom.mem_equalizer, AlgHom.id_apply] at this
+  exact congrFun this τ
+
+omit [NeZero N] in
+theorem T_pow_mem_Gamma : ModularGroup.T ^ (N : ℤ) ∈ CongruenceSubgroup.Gamma N := by
+  rw [CongruenceSubgroup.Gamma_mem, ModularGroup.coe_T_zpow]
+  simp
+
+theorem hN : (0 : ℝ) < N := Nat.cast_pos.mpr (Nat.pos_of_ne_zero (NeZero.ne N))
+
+theorem periodic_of_mem {F : ℍ → ℂ} (hF : F ∈ ring N) : Periodic (F ∘ ofComplex) (N : ℝ) := by
+  intro w
+  by_cases hw : 0 < w.im
+  · have hw' : 0 < (w + (N : ℝ)).im := by simpa using hw
+    simp only [comp_apply, ofComplex_apply_of_im_pos hw, ofComplex_apply_of_im_pos hw']
+    have h := apply_smul_of_mem N (T_pow_mem_Gamma N) hF ⟨w, hw⟩
+    rw [modular_T_zpow_smul] at h
+    convert h using 2
+    ext
+    simp [UpperHalfPlane.coe_vadd, add_comm]
+  · have hw0 : w.im ≤ 0 := not_lt.mp hw
+    have hw' : (w + ((N : ℝ) : ℂ)).im ≤ 0 := by simpa using hw0
+    simp only [comp_apply]
+    rw [ofComplex_apply_of_im_nonpos hw', ofComplex_apply_of_im_nonpos hw0]
+
+theorem isBoundedAtImInfty_discriminant : IsBoundedAtImInfty ModularForm.discriminant :=
+  ModularForm.discriminant_isZeroAtImInfty.boundedAtFilter
+
+theorem isBoundedAtImInfty_discriminant_pow (m : ℕ) :
+    IsBoundedAtImInfty (ModularForm.discriminant ^ m) := by
+  induction m with
+  | zero => simp only [pow_zero]; exact Filter.const_boundedAtFilter atImInfty (1 : ℂ)
+  | succ m ih => rw [pow_succ]; exact ih.mul isBoundedAtImInfty_discriminant
+
+theorem exists_isBoundedAtImInfty {F : ℍ → ℂ} (hF : F ∈ ring N) :
+    ∃ m : ℕ, IsBoundedAtImInfty (F * ModularForm.discriminant ^ m) := by
+  change F ∈ Algebra.adjoin ℂ (generators N) at hF
+  induction hF using Algebra.adjoin_induction with
+  | mem x hx =>
+      rcases hx with rfl | ⟨v, hv, rfl⟩
+      · exact (orbit_pkg N).1
+      · exact (orbit_pkg N).2 v hv
+  | algebraMap c =>
+      refine ⟨0, ?_⟩
+      have : (algebraMap ℂ (ℍ → ℂ) c) * ModularForm.discriminant ^ 0 = Function.const ℍ c := by
+        funext τ; simp [Algebra.algebraMap_eq_smul_one]
+      rw [this]
+      exact Filter.const_boundedAtFilter atImInfty c
+  | add x y hx hy ihx ihy =>
+      obtain ⟨m₁, h₁⟩ := ihx
+      obtain ⟨m₂, h₂⟩ := ihy
+      refine ⟨m₁ + m₂, ?_⟩
+      have e : (x + y) * ModularForm.discriminant ^ (m₁ + m₂) =
+          x * ModularForm.discriminant ^ m₁ * ModularForm.discriminant ^ m₂ +
+            y * ModularForm.discriminant ^ m₂ * ModularForm.discriminant ^ m₁ := by ring
+      rw [e]
+      exact (h₁.mul (isBoundedAtImInfty_discriminant_pow m₂)).add
+        (h₂.mul (isBoundedAtImInfty_discriminant_pow m₁))
+  | mul x y hx hy ihx ihy =>
+      obtain ⟨m₁, h₁⟩ := ihx
+      obtain ⟨m₂, h₂⟩ := ihy
+      refine ⟨m₁ + m₂, ?_⟩
+      have e : (x * y) * ModularForm.discriminant ^ (m₁ + m₂) =
+          (x * ModularForm.discriminant ^ m₁) * (y * ModularForm.discriminant ^ m₂) := by ring
+      rw [e]
+      exact h₁.mul h₂
+
+abbrev cf (P : ℍ → ℂ) : ℂ → ℂ := UpperHalfPlane.cuspFunction (N : ℝ) P
+
+private def _root_.ModularCurve.LevelN.CuspVanish.T (q : ℂ) :
+    ℍ := ofComplex (Periodic.invQParam (N : ℝ) q)
+
+p2m_export "ModularCurve.LevelN.CuspVanish" "T"
+omit [NeZero N] in
+theorem cf_eq_T (P : ℍ → ℂ) {q : ℂ} (hq : q ≠ 0) : cf N P q = P (T N q) := by
+  rw [cf, UpperHalfPlane.cuspFunction, Periodic.cuspFunction_eq_of_nonzero _ _ hq]
+  rfl
+
+theorem cf_qParam {P : ℍ → ℂ} (hP : P ∈ ring N) (τ : ℍ) : cf N P (𝕢 N τ) = P τ :=
+  UpperHalfPlane.eq_cuspFunction τ (hN N).ne' (periodic_of_mem N hP)
+
+theorem tendsto_qParam : Tendsto (fun τ : ℍ => 𝕢 N (τ : ℂ)) atImInfty (𝓝[≠] 0) :=
+  (Periodic.qParam_tendsto (hN N)).comp tendsto_coe_atImInfty
+
+omit [NeZero N] in
+theorem cf_mul_of_ne (P Q : ℍ → ℂ) {q : ℂ} (hq : q ≠ 0) : cf N (P * Q) q = cf N P q * cf N Q q := by
+  simp only [cf_eq_T N _ hq, Pi.mul_apply]
+
+omit [NeZero N] in
+theorem cf_pow_of_ne (P : ℍ → ℂ) (m : ℕ) {q : ℂ} (hq : q ≠ 0) : cf N (P ^ m) q = cf N P q ^ m := by
+  simp only [cf_eq_T N _ hq, Pi.pow_apply]
+
+omit [NeZero N] in
+theorem periodic_discriminant : Periodic (ModularForm.discriminant ∘ ofComplex) (N : ℝ) := by
+  have hΓ : ((N : ℕ) : ℝ) ∈ (𝒮ℒ).strictPeriods := by
+    rw [Subgroup.strictPeriods_SL2Z]
+    exact ⟨N, by simp⟩
+  exact SlashInvariantFormClass.periodic_comp_ofComplex CuspForm.discriminant hΓ
+
+theorem analyticAt_cf_discriminant : AnalyticAt ℂ (cf N ModularForm.discriminant) 0 :=
+  UpperHalfPlane.analyticAt_cuspFunction_zero (hN N) (periodic_discriminant N)
+    CuspForm.discriminant.holo' isBoundedAtImInfty_discriminant
+
+theorem cf_discriminant_zero : cf N ModularForm.discriminant 0 = 0 := by
+  rw [cf, UpperHalfPlane.cuspFunction_apply_zero (hN N) (analyticAt_cf_discriminant N)
+    (periodic_discriminant N)]
+  exact ModularForm.discriminant_isZeroAtImInfty.valueAtInfty_eq_zero
+
+omit [NeZero N] in
+theorem eventually_cf_discriminant_ne_zero :
+    ∀ᶠ q in 𝓝[≠] (0 : ℂ), cf N ModularForm.discriminant q ≠ 0 := by
+  filter_upwards [self_mem_nhdsWithin] with q hq
+  rw [cf_eq_T N _ hq]
+  exact ModularForm.discriminant_ne_zero _
+
+theorem analyticAt_cf_mul_pow {P : ℍ → ℂ} (hP : P ∈ ring N) {m : ℕ}
+    (hb : IsBoundedAtImInfty (P * ModularForm.discriminant ^ m)) :
+    AnalyticAt ℂ (cf N (P * ModularForm.discriminant ^ m)) 0 := by
+  refine UpperHalfPlane.analyticAt_cuspFunction_zero (hN N) ?_ ?_ hb
+  · intro w
+    have h1 := periodic_of_mem N hP w
+    have h2 := (periodic_discriminant N) w
+    simp only [comp_apply] at h1 h2
+    simp only [comp_apply, Pi.mul_apply, Pi.pow_apply, h1, h2]
+  · exact (mdifferentiable_of_mem N hP).mul (CuspForm.discriminant.holo'.pow m)
+
+theorem meromorphicAt_cf {P : ℍ → ℂ} (hP : P ∈ ring N) : MeromorphicAt (cf N P) 0 := by
+  obtain ⟨m, hb⟩ := exists_isBoundedAtImInfty N hP
+  have hev : cf N P =ᶠ[𝓝[≠] (0 : ℂ)]
+      fun q => cf N (P * ModularForm.discriminant ^ m) q / cf N ModularForm.discriminant q ^ m := by
+    filter_upwards [eventually_cf_discriminant_ne_zero N, self_mem_nhdsWithin] with q hq hq0
+    rw [cf_mul_of_ne N _ _ hq0, cf_pow_of_ne N _ _ hq0, mul_div_assoc, div_self (pow_ne_zero m hq),
+      mul_one]
+  exact (((analyticAt_cf_mul_pow N hP hb).meromorphicAt).div
+    ((analyticAt_cf_discriminant N).meromorphicAt.pow m)).congr hev.symm
+
+theorem meromorphicOrderAt_cf_ne_top {P : ℍ → ℂ} (hP : P ∈ ring N) (hP0 : P ≠ 0) :
+    meromorphicOrderAt (cf N P) 0 ≠ ⊤ := by
+  intro htop
+  rw [meromorphicOrderAt_eq_top_iff] at htop
+  have hev : ∀ᶠ τ : ℍ in atImInfty, P τ = 0 := by
+    filter_upwards [(tendsto_qParam N).eventually htop] with τ hτ
+    rwa [cf_qParam N hP] at hτ
+  rw [atImInfty, eventually_comap] at hev
+  obtain ⟨A, hA⟩ := (Filter.eventually_atTop.mp hev)
+  set z₀ : ℂ := Complex.I * ((max A 0 : ℝ) + 1) with hz₀
+  have hz₀im : z₀.im = max A 0 + 1 := by simp [hz₀]
+  have hz₀pos : 0 < z₀.im := by rw [hz₀im]; positivity
+  have hopen : IsOpen {z : ℂ | max A 0 + 1 / 2 < z.im} :=
+    isOpen_lt continuous_const Complex.continuous_im
+  have hmem : z₀ ∈ {z : ℂ | max A 0 + 1 / 2 < z.im} := by
+    change max A 0 + 1 / 2 < z₀.im
+    rw [hz₀im]; linarith
+  have hzero : ∀ᶠ z in 𝓝 z₀, (P ∘ ofComplex) z = 0 := by
+    filter_upwards [hopen.mem_nhds hmem] with z hz
+    have hzpos : 0 < z.im := by
+      have : (0 : ℝ) ≤ max A 0 := le_max_right _ _
+      change max A 0 + 1 / 2 < z.im at hz
+      linarith
+    have hA' : A ≤ (⟨z, hzpos⟩ : ℍ).im := by
+      change A ≤ z.im
+      change max A 0 + 1 / 2 < z.im at hz
+      have : A ≤ max A 0 := le_max_left _ _
+      linarith
+    have := hA _ hA' ⟨z, hzpos⟩ rfl
+    simpa [comp_apply, ofComplex_apply_of_im_pos hzpos] using this
+  have hanal : AnalyticOnNhd ℂ (P ∘ ofComplex) {z : ℂ | 0 < z.im} := by
+    intro z hz
+    exact (UpperHalfPlane.mdifferentiable_iff.mp (mdifferentiable_of_mem N hP)).analyticAt
+      (isOpen_upperHalfPlaneSet.mem_nhds hz)
+  have hall := hanal.eqOn_zero_of_preconnected_of_eventuallyEq_zero
+    (convex_halfSpace_im_gt 0).isPreconnected hz₀pos hzero
+  apply hP0
+  funext τ
+  have := hall τ.im_pos
+  simpa [comp_apply, ofComplex_apply] using this
+
+section OrderMap
+
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ring N) K] [IsScalarTower ℂ (ring N) K]
+  [IsFractionRing (ring N) K]
+
+omit [NeZero N] [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem algebraMap_injective : Function.Injective (algebraMap (ring N) K) :=
+  IsFractionRing.injective (ring N) K
+
+omit [NeZero N] [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem algebraMap_ne_zero {b : ring N} (hb : (b : ℍ → ℂ) ≠ 0) : algebraMap (ring N) K b ≠ 0 :=
+  fun h => hb (by
+    have : b = 0 := algebraMap_injective N K (by rw [h, map_zero])
+    simp [this])
+
+omit [NeZero N] [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem exists_rep (k : K) :
+    ∃ ab : ring N × ring N, (ab.2 : ℍ → ℂ) ≠ 0 ∧
+      algebraMap (ring N) K ab.1 / algebraMap (ring N) K ab.2 = k := by
+  obtain ⟨a, b, hb, h⟩ := IsFractionRing.div_surjective (A := ring N) k
+  refine ⟨(a, b), ?_, h⟩
+  intro hb0
+  have : b = 0 := Subtype.ext hb0
+  rw [this] at hb
+  exact zero_notMem_nonZeroDivisors hb
+
+def num (k : K) : ring N := (exists_rep N K k).choose.1
+
+def den (k : K) : ring N := (exists_rep N K k).choose.2
+
+omit [NeZero N] [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem den_ne_zero (k : K) : ((den N K k : ring N) : ℍ → ℂ) ≠ 0 :=
+  (exists_rep N K k).choose_spec.1
+
+omit [NeZero N] [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem num_div_den (k : K) :
+    algebraMap (ring N) K (num N K k) / algebraMap (ring N) K (den N K k) = k :=
+  (exists_rep N K k).choose_spec.2
+
+omit [NeZero N] [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem cross_mul_eq {a b a' b' : ring N} (hb : (b : ℍ → ℂ) ≠ 0) (hb' : (b' : ℍ → ℂ) ≠ 0)
+    (h : algebraMap (ring N) K a / algebraMap (ring N) K b =
+      algebraMap (ring N) K a' / algebraMap (ring N) K b') :
+    (a : ℍ → ℂ) * (b' : ℍ → ℂ) = (a' : ℍ → ℂ) * (b : ℍ → ℂ) := by
+  rw [div_eq_div_iff (algebraMap_ne_zero N K hb) (algebraMap_ne_zero N K hb'), ← map_mul,
+    ← map_mul] at h
+  have := algebraMap_injective N K h
+  simpa using congrArg Subtype.val this
+
+variable (δ : SL(2, ℤ))
+
+abbrev cfδ (P : ℍ → ℂ) : ℂ → ℂ := cf N (precomp δ P)
+
+theorem meromorphicAt_cfδ {P : ℍ → ℂ} (hP : P ∈ ring N) : MeromorphicAt (cfδ N δ P) 0 :=
+  meromorphicAt_cf N (precomp_mem N δ hP)
+
+theorem eventually_cfδ_ne_zero {P : ℍ → ℂ} (hP : P ∈ ring N) (hP0 : P ≠ 0) :
+    ∀ᶠ q in 𝓝[≠] (0 : ℂ), cfδ N δ P q ≠ 0 :=
+  (meromorphicOrderAt_ne_top_iff_eventually_ne_zero (meromorphicAt_cfδ N δ hP)).mp
+    (meromorphicOrderAt_cf_ne_top N (precomp_mem N δ hP) (precomp_ne_zero δ hP0))
+
+def realq (k : K) : ℂ → ℂ :=
+  fun q => cfδ N δ (num N K k : ℍ → ℂ) q / cfδ N δ (den N K k : ℍ → ℂ) q
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem meromorphicAt_realq (k : K) : MeromorphicAt (realq N K δ k) 0 :=
+  (meromorphicAt_cfδ N δ (num N K k).2).div (meromorphicAt_cfδ N δ (den N K k).2)
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem realq_eventuallyEq {k : K} {a b : ring N} (hb : (b : ℍ → ℂ) ≠ 0)
+    (h : algebraMap (ring N) K a / algebraMap (ring N) K b = k) :
+    realq N K δ k =ᶠ[𝓝[≠] (0 : ℂ)] fun q => cfδ N δ (a : ℍ → ℂ) q / cfδ N δ (b : ℍ → ℂ) q := by
+  have hx := cross_mul_eq N K (den_ne_zero N K k) hb ((num_div_den N K k).trans h.symm)
+  filter_upwards [eventually_cfδ_ne_zero N δ (den N K k).2 (den_ne_zero N K k),
+    eventually_cfδ_ne_zero N δ b.2 hb, self_mem_nhdsWithin] with q h1 h2 hq
+  have := congrFun hx (δ • T N q)
+  simp only [Pi.mul_apply] at this
+  simp only [realq, cf_eq_T N _ hq, precomp_apply] at h1 h2 ⊢
+  field_simp
+  linear_combination this
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem realq_algebraMap (a : ring N) :
+    realq N K δ (algebraMap (ring N) K a) =ᶠ[𝓝[≠] (0 : ℂ)] cfδ N δ (a : ℍ → ℂ) := by
+  have h : algebraMap (ring N) K a / algebraMap (ring N) K 1 = algebraMap (ring N) K a := by simp
+  filter_upwards [realq_eventuallyEq N K δ (a := a) (b := 1) (by simp) h, self_mem_nhdsWithin]
+    with q hq hq0
+  rw [hq]
+  simp [cf_eq_T N _ hq0]
+
+theorem realq_const (c : ℂ) : realq N K δ (algebraMap ℂ K c) =ᶠ[𝓝[≠] (0 : ℂ)] fun _ => c := by
+  rw [IsScalarTower.algebraMap_apply ℂ (ring N) K]
+  filter_upwards [realq_algebraMap N K δ (algebraMap ℂ (ring N) c), self_mem_nhdsWithin]
+    with q hq hq0
+  rw [hq]
+  simp only [cfδ, cf_eq_T N _ hq0, precomp_apply]
+  simp [Algebra.algebraMap_eq_smul_one]
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem realq_mul (k l : K) :
+    realq N K δ (k * l) =ᶠ[𝓝[≠] (0 : ℂ)] fun q => realq N K δ k q * realq N K δ l q := by
+  have hb := mul_ne_zero_of_mem N (den N K k).2 (den N K l).2 (den_ne_zero N K k)
+    (den_ne_zero N K l)
+  have h : algebraMap (ring N) K (num N K k * num N K l) /
+      algebraMap (ring N) K (den N K k * den N K l) = k * l := by
+    rw [map_mul, map_mul, mul_div_mul_comm, num_div_den, num_div_den]
+  filter_upwards [realq_eventuallyEq N K δ (a := num N K k * num N K l)
+    (b := den N K k * den N K l) hb h, self_mem_nhdsWithin] with q hq hq0
+  rw [hq]
+  simp only [realq, Subalgebra.coe_mul, cf_eq_T N _ hq0, precomp_apply, Pi.mul_apply]
+  rw [mul_div_mul_comm]
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem realq_add (k l : K) :
+    realq N K δ (k + l) =ᶠ[𝓝[≠] (0 : ℂ)] fun q => realq N K δ k q + realq N K δ l q := by
+  have hb := mul_ne_zero_of_mem N (den N K k).2 (den N K l).2 (den_ne_zero N K k)
+    (den_ne_zero N K l)
+  have hk := algebraMap_ne_zero N K (den_ne_zero N K k)
+  have hl := algebraMap_ne_zero N K (den_ne_zero N K l)
+  have h : algebraMap (ring N) K (num N K k * den N K l + num N K l * den N K k) /
+      algebraMap (ring N) K (den N K k * den N K l) = k + l := by
+    conv_rhs => rw [← num_div_den N K k, ← num_div_den N K l]
+    rw [map_add, map_mul, map_mul, map_mul]
+    field_simp
+  filter_upwards [realq_eventuallyEq N K δ (a := num N K k * den N K l + num N K l * den N K k)
+    (b := den N K k * den N K l) hb h,
+    eventually_cfδ_ne_zero N δ (den N K k).2 (den_ne_zero N K k),
+    eventually_cfδ_ne_zero N δ (den N K l).2 (den_ne_zero N K l), self_mem_nhdsWithin]
+    with q hq h1 h2 hq0
+  rw [hq]
+  simp only [realq, cf_eq_T N _ hq0, precomp_apply] at h1 h2 ⊢
+  simp only [Subalgebra.coe_mul, Subalgebra.coe_add, Pi.mul_apply, Pi.add_apply]
+  field_simp
+
+def ν (k : K) : WithTop ℤ := meromorphicOrderAt (realq N K δ k) 0
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem ν_mul (x y : K) : ν N K δ (x * y) = ν N K δ x + ν N K δ y := by
+  rw [ν, meromorphicOrderAt_congr (realq_mul N K δ x y)]
+  exact meromorphicOrderAt_mul (meromorphicAt_realq N K δ x) (meromorphicAt_realq N K δ y)
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem ν_add (x y : K) : min (ν N K δ x) (ν N K δ y) ≤ ν N K δ (x + y) := by
+  rw [ν, ν, ν, meromorphicOrderAt_congr (realq_add N K δ x y)]
+  exact meromorphicOrderAt_add (meromorphicAt_realq N K δ x) (meromorphicAt_realq N K δ y)
+
+theorem ν_const (c : ℂ) (hc : c ≠ 0) : ν N K δ (algebraMap ℂ K c) = 0 := by
+  rw [ν, meromorphicOrderAt_congr (realq_const N K δ c)]
+  classical
+  rw [meromorphicOrderAt_const]
+  simp [hc]
+
+theorem ν_eq_top_iff (x : K) : ν N K δ x = ⊤ ↔ x = 0 := by
+  constructor
+  · intro h
+    rw [ν, meromorphicOrderAt_eq_top_iff] at h
+    have hden := eventually_cfδ_ne_zero N δ (den N K x).2 (den_ne_zero N K x)
+    have hnum : ∀ᶠ q in 𝓝[≠] (0 : ℂ), cfδ N δ (num N K x : ℍ → ℂ) q = 0 := by
+      filter_upwards [h, hden] with q hq hd
+      simp only [realq, div_eq_zero_iff] at hq
+      exact hq.resolve_right hd
+    by_contra hx
+    have hnum0 : ((num N K x : ring N) : ℍ → ℂ) ≠ 0 := by
+      intro h0
+      apply hx
+      rw [← num_div_den N K x]
+      have : num N K x = 0 := Subtype.ext h0
+      rw [this, map_zero, zero_div]
+    exact meromorphicOrderAt_cf_ne_top N (precomp_mem N δ (num N K x).2) (precomp_ne_zero δ hnum0)
+      (meromorphicOrderAt_eq_top_iff.mpr hnum)
+  · rintro rfl
+    have h := realq_const N K δ 0
+    rw [map_zero] at h
+    rw [ν, meromorphicOrderAt_congr h, meromorphicOrderAt_eq_top_iff]
+    exact Filter.Eventually.of_forall fun _ => rfl
+
+theorem ν_ne_top {x : K} (hx : x ≠ 0) : ν N K δ x ≠ ⊤ := fun h => hx ((ν_eq_top_iff N K δ x).mp h)
+
+theorem tendsto_E4_atImInfty : Tendsto (fun τ : ℍ => ModularForm.E₄ τ) atImInfty (𝓝 1) := by
+  have hana := ModularFormClass.analyticAt_cuspFunction_zero ModularForm.E₄ one_pos
+    one_mem_strictPeriods_SL
+  have hper := SlashInvariantFormClass.periodic_comp_ofComplex ModularForm.E₄
+    one_mem_strictPeriods_SL
+  have h0 : UpperHalfPlane.cuspFunction 1 (⇑ModularForm.E₄) 0 = 1 := by
+    rw [UpperHalfPlane.cuspFunction_apply_zero one_pos hana hper,
+      ← qExpansion_coeff_zero one_pos hana hper]
+    exact EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) ⟨2, rfl⟩
+  have h1 := hana.continuousAt.tendsto.comp (qParam_tendsto_atImInfty one_pos)
+  rw [h0] at h1
+  refine h1.congr fun τ => ?_
+  simp only [comp_apply]
+  exact SlashInvariantFormClass.eq_cuspFunction ModularForm.E₄ τ one_mem_strictPeriods_SL
+    one_ne_zero
+
+def G : ℍ → ℂ := fun τ => ModularForm.E₄ τ ^ 3
+
+omit [NeZero N] in
+theorem periodic_G : Periodic (G ∘ ofComplex) (N : ℝ) := by
+  have hΓ : ((N : ℕ) : ℝ) ∈ (𝒮ℒ).strictPeriods := by
+    rw [Subgroup.strictPeriods_SL2Z]
+    exact ⟨N, by simp⟩
+  have h := SlashInvariantFormClass.periodic_comp_ofComplex ModularForm.E₄ hΓ
+  intro w
+  have := h w
+  simp only [comp_apply] at this ⊢
+  simp only [G, this]
+
+theorem analyticAt_cf_G : AnalyticAt ℂ (cf N G) 0 := by
+  refine UpperHalfPlane.analyticAt_cuspFunction_zero (hN N) (periodic_G N) ?_ ?_
+  · exact ModularForm.E₄.holo'.pow 3
+  · have h1 : IsBoundedAtImInfty (⇑ModularForm.E₄) := by
+      have : Fact (IsCusp OnePoint.infty 𝒮ℒ) :=
+        ⟨Subgroup.isCusp_of_mem_strictPeriods one_pos one_mem_strictPeriods_SL⟩
+      exact ModularFormClass.bdd_at_infty ModularForm.E₄
+    have : G = (⇑ModularForm.E₄) * (⇑ModularForm.E₄) * (⇑ModularForm.E₄) := by
+      funext τ; simp [G]; ring
+    rw [this]
+    exact (h1.mul h1).mul h1
+
+theorem cf_G_zero : cf N G 0 = 1 := by
+  rw [cf, UpperHalfPlane.cuspFunction_apply_zero (hN N) (analyticAt_cf_G N) (periodic_G N)]
+  have : Tendsto G atImInfty (𝓝 1) := by
+    have h__ := (tendsto_E4_atImInfty).pow 3
+    try simp only [one_pow] at h__
+    exact h__
+  exact this.limUnder_eq
+
+theorem meromorphicOrderAt_cf_G : meromorphicOrderAt (cf N G) 0 = 0 := by
+  apply (tendsto_ne_zero_iff_meromorphicOrderAt_eq_zero (analyticAt_cf_G N).meromorphicAt).mp
+  refine ⟨1, one_ne_zero, ?_⟩
+  have h := ((analyticAt_cf_G N).continuousAt.tendsto).mono_left
+    (nhdsWithin_le_nhds (s := ({0}ᶜ : Set ℂ)))
+  rwa [cf_G_zero] at h
+
+theorem meromorphicOrderAt_cf_discriminant_pos :
+    0 < meromorphicOrderAt (cf N ModularForm.discriminant) 0 := by
+  apply (tendsto_zero_iff_meromorphicOrderAt_pos (analyticAt_cf_discriminant N).meromorphicAt).mp
+  have h := ((analyticAt_cf_discriminant N).continuousAt.tendsto).mono_left
+    (nhdsWithin_le_nhds (s := ({0}ᶜ : Set ℂ)))
+  rwa [cf_discriminant_zero] at h
+
+def jK : K := algebraMap (ring N) K (jGen N)
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem jK_ne_zero : jK N K ≠ 0 := by
+  apply algebraMap_ne_zero N K
+  intro h
+  have h' : jAnalytic = 0 := h
+  have := jAnalytic_transcendental N Polynomial.X (fun τ => by
+    have := congrFun h' τ
+    simp only [Pi.zero_apply] at this
+    simp [this])
+  exact Polynomial.X_ne_zero this
+
+omit [Algebra ℂ K] [IsScalarTower ℂ (↥(ring N)) K] in
+theorem ν_jK_neg : ν N K δ (jK N K) < 0 := by
+  have hev : realq N K δ (jK N K) =ᶠ[𝓝[≠] (0 : ℂ)]
+      (cf N G * (cf N ModularForm.discriminant)⁻¹) := by
+    filter_upwards [realq_algebraMap N K δ (jGen N), self_mem_nhdsWithin] with q hq hq0
+    rw [jK, hq]
+    simp only [cfδ, Pi.mul_apply, Pi.inv_apply, cf_eq_T N _ hq0, precomp_apply, coe_jGen,
+      jAnalytic_smul]
+    rw [jAnalytic, G, div_eq_mul_inv]
+  rw [ν, meromorphicOrderAt_congr hev,
+    meromorphicOrderAt_mul (analyticAt_cf_G N).meromorphicAt
+      (analyticAt_cf_discriminant N).meromorphicAt.inv,
+    meromorphicOrderAt_inv, meromorphicOrderAt_cf_G, zero_add]
+  have hpos := meromorphicOrderAt_cf_discriminant_pos N
+  have hne : meromorphicOrderAt (cf N ModularForm.discriminant) 0 ≠ ⊤ := by
+    intro h
+    rw [meromorphicOrderAt_eq_top_iff] at h
+    obtain ⟨q, hq1, hq2⟩ := (h.and self_mem_nhdsWithin).exists
+    exact (ModularForm.discriminant_ne_zero _) (by rwa [cf_eq_T N _ hq2] at hq1)
+  obtain ⟨m, hm⟩ := WithTop.ne_top_iff_exists.mp hne
+  rw [← hm] at hpos ⊢
+  rw [← WithTop.coe_zero, WithTop.coe_lt_coe] at hpos
+  rw [← WithTop.LinearOrderedAddCommGroup.coe_neg, ← WithTop.coe_zero, WithTop.coe_lt_coe]
+  omega
+
+theorem exists_ν_pos : ∃ x : K, 0 < ν N K δ x ∧ ν N K δ x ≠ ⊤ := by
+  have hXt := ν_ne_top N K δ (jK_ne_zero N K)
+  have hneg := ν_jK_neg N K δ
+  refine ⟨(jK N K)⁻¹, ?_, ν_ne_top N K δ (inv_ne_zero (jK_ne_zero N K))⟩
+  have hsum : ν N K δ (jK N K)⁻¹ + ν N K δ (jK N K) = 0 := by
+    rw [← ν_mul, inv_mul_cancel₀ (jK_ne_zero N K)]
+    have := ν_const N K δ 1 one_ne_zero
+    rwa [map_one] at this
+  obtain ⟨m, hm⟩ := WithTop.ne_top_iff_exists.mp hXt
+  obtain ⟨n, hn⟩ := WithTop.ne_top_iff_exists.mp (ν_ne_top N K δ (inv_ne_zero (jK_ne_zero N K)))
+  rw [← hm, ← hn, ← WithTop.coe_add, ← WithTop.coe_zero, WithTop.coe_eq_coe] at hsum
+  rw [← hm, ← WithTop.coe_zero, WithTop.coe_lt_coe] at hneg
+  rw [← hn, ← WithTop.coe_zero, WithTop.coe_lt_coe]
+  omega
+
+theorem exists_place :
+    ∃ (P : AlgebraicCurve.Place ℂ K) (e : ℕ), 0 < e ∧
+      (∀ x, x ∈ P.toValuationSubring ↔ 0 ≤ ν N K δ x) ∧
+      ∀ x, x ≠ 0 → ν N K δ x = (((e : ℤ) * P.ord x : ℤ) : WithTop ℤ) :=
+  AlgebraicCurve.Place.exists_of_orderMap (ν N K δ) (ν_eq_top_iff N K δ) (ν_mul N K δ)
+    (ν_add N K δ) (fun c hc => ν_const N K δ c hc) (exists_ν_pos N K δ)
+
+theorem exists_analyticAt_eventuallyEq {f : ℂ → ℂ} {x : ℂ} (hf : MeromorphicAt f x)
+    (h : 0 ≤ meromorphicOrderAt f x) :
+    ∃ G : ℂ → ℂ, AnalyticAt ℂ G x ∧ f =ᶠ[𝓝[≠] x] G := by
+  by_cases htop : meromorphicOrderAt f x = ⊤
+  · exact ⟨fun _ => 0, analyticAt_const, meromorphicOrderAt_eq_top_iff.mp htop⟩
+  · obtain ⟨n, hn⟩ := WithTop.ne_top_iff_exists.mp htop
+    have hn0 : (0 : ℤ) ≤ n := by
+      rw [← hn] at h
+      exact_mod_cast h
+    obtain ⟨m, rfl⟩ := Int.eq_ofNat_of_zero_le hn0
+    obtain ⟨g, hg, -, hfg⟩ := (meromorphicOrderAt_eq_int_iff hf).mp hn.symm
+    refine ⟨fun z => (z - x) ^ m * g z, ((analyticAt_id.sub analyticAt_const).pow m).mul hg, ?_⟩
+    filter_upwards [hfg] with z hz
+    rw [hz, zpow_natCast, smul_eq_mul]
+
+theorem exists_smul_D_of_mem {ω : Ω[K⁄ℂ]} (hω : ω ∈ AlgebraicCurve.regularDifferentials ℂ K) :
+    ∃ (f π : K) (Φ R : ℂ → ℂ), ω = f • KaehlerDifferential.D ℂ K π ∧
+      AnalyticAt ℂ Φ 0 ∧ realq N K δ f =ᶠ[𝓝[≠] (0 : ℂ)] Φ ∧
+      AnalyticAt ℂ R 0 ∧ realq N K δ π =ᶠ[𝓝[≠] (0 : ℂ)] R := by
+  obtain ⟨P, e, he, hmem, hord⟩ := exists_place N K δ
+  obtain ⟨f, hf, hωf⟩ := (AlgebraicCurve.mem_regularDifferentials_iff.mp hω) P
+  obtain ⟨π, hπ1, hdC⟩ := P.exists_ord_eq_one_and_dCoord_eq
+  have hπ0 : π ≠ 0 := by
+    intro h
+    rw [h, AlgebraicCurve.Place.ord_zero] at hπ1
+    exact zero_ne_one hπ1
+  have hνf : 0 ≤ ν N K δ f := (hmem f).mp hf
+  have hνπ : 0 ≤ ν N K δ π := by
+    rw [hord π hπ0, hπ1, mul_one]
+    exact_mod_cast he.le
+  obtain ⟨Φ, hΦ, hfΦ⟩ := exists_analyticAt_eventuallyEq (meromorphicAt_realq N K δ f) hνf
+  obtain ⟨R, hR, hπR⟩ := exists_analyticAt_eventuallyEq (meromorphicAt_realq N K δ π) hνπ
+  exact ⟨f, π, Φ, R, by rw [hωf, hdC], hΦ, hfΦ, hR, hπR⟩
+
+end OrderMap
+
+section Cusp
+
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ring N) K] [IsScalarTower ℂ (ring N) K]
+  [IsFractionRing (ring N) K]
+
+def 𝕌 : Set ℂ := {z : ℂ | 0 < z.im}
+
+theorem isOpen_𝕌 : IsOpen 𝕌 := isOpen_upperHalfPlaneSet
+
+theorem coe_mem_𝕌 (τ : ℍ) : (τ : ℂ) ∈ 𝕌 := τ.im_pos
+
+def up (F : ℍ → ℂ) : ℂ → ℂ := F ∘ ofComplex
+
+theorem up_apply_coe (F : ℍ → ℂ) (τ : ℍ) : up F τ = F τ := by
+  simp [up, ofComplex_apply]
+
+theorem up_apply_of_mem (F : ℍ → ℂ) {z : ℂ} (hz : z ∈ 𝕌) : up F z = F ⟨z, hz⟩ := by
+  simp [up, ofComplex_apply_of_im_pos hz]
+
+theorem differentiableAt_up {F : ℍ → ℂ} (hF : F ∈ ring N) (τ : ℍ) :
+    DifferentiableAt ℂ (up F) τ := by
+  have hd : DifferentiableOn ℂ (up F) 𝕌 :=
+    UpperHalfPlane.mdifferentiable_iff.mp (mdifferentiable_of_mem N hF)
+  exact hd.differentiableAt (isOpen_𝕌.mem_nhds (coe_mem_𝕌 τ))
+
+def moeb (g : SL(2, ℤ)) (z : ℂ) : ℂ := ((g • ofComplex z : ℍ) : ℂ)
+
+theorem moeb_coe (g : SL(2, ℤ)) (τ : ℍ) : moeb g τ = ((g • τ : ℍ) : ℂ) := by
+  simp [moeb, ofComplex_apply]
+
+theorem hasDerivAt_moeb (γ : SL(2, ℤ)) (τ : ℍ) :
+    HasDerivAt (moeb γ) (denom (Matrix.SpecialLinearGroup.mapGL ℝ γ) ↑τ ^ (-2 : ℤ)) ↑τ := by
+  set G : GL (Fin 2) ℝ := Matrix.SpecialLinearGroup.mapGL ℝ γ with hG
+  have hdet : (G : Matrix (Fin 2) (Fin 2) ℝ).det = 1 := by
+    rw [← Matrix.GeneralLinearGroup.val_det_apply, hG, Matrix.SpecialLinearGroup.det_mapGL,
+      Units.val_one]
+  have hpos : (0:ℝ) < (G : Matrix (Fin 2) (Fin 2) ℝ).det := by rw [hdet]; norm_num
+  have h1 := (UpperHalfPlane.hasStrictDerivAt_smul hpos τ).hasDerivAt
+  have h2 : (fun z : ℂ => ((G • ofComplex z : ℍ) : ℂ)) = moeb γ := by
+    funext z
+    rw [moeb, MulAction.compHom_smul_def]
+  rw [h2] at h1
+  convert h1 using 1
+  rw [hdet]
+  push_cast
+  rw [zpow_neg, one_div]
+  norm_cast
+
+theorem slash_two_apply (f : ℍ → ℂ) (γ : SL(2, ℤ)) (τ : ℍ) :
+    (f ∣[(2 : ℤ)] γ) τ =
+      f (γ • τ) * denom (Matrix.SpecialLinearGroup.mapGL ℝ γ) ↑τ ^ (-2 : ℤ) :=
+  ModularForm.SL_slash_apply f γ τ
+
+theorem hasDerivAt_qParam (h : ℝ) (z : ℂ) :
+    HasDerivAt (𝕢 h) (𝕢 h z * (2 * ↑Real.pi * Complex.I / h)) z := by
+  have qdiff : HasStrictDerivAt (𝕢 h) (𝕢 h z * (2 * ↑Real.pi * Complex.I / h)) z := by
+    have h0 :=
+      (((hasStrictDerivAt_id z).const_mul (2 * ↑Real.pi * Complex.I)).div_const (h : ℂ)).cexp
+    simp only [id_eq, mul_one] at h0
+    first
+      | exact h0
+  exact qdiff.hasDerivAt
+
+variable (δ : SL(2, ℤ))
+
+theorem deriv_up_precomp {c : ℍ → ℂ} (hc : c ∈ ring N) (τ : ℍ) :
+    deriv (up (precomp δ c)) τ =
+      deriv (up c) ↑(δ • τ) * denom (Matrix.SpecialLinearGroup.mapGL ℝ δ) ↑τ ^ (-2 : ℤ) := by
+  have hcomp : up (precomp δ c) = up c ∘ moeb δ := by
+    funext z
+    simp [up, moeb, ofComplex_apply]
+  have h1 : HasDerivAt (up c ∘ moeb δ)
+      (deriv (up c) (moeb δ τ) * denom (Matrix.SpecialLinearGroup.mapGL ℝ δ) ↑τ ^ (-2 : ℤ)) τ := by
+    refine HasDerivAt.comp (τ : ℂ) ?_ (hasDerivAt_moeb δ τ)
+    rw [moeb_coe]
+    exact (differentiableAt_up N hc (δ • τ)).hasDerivAt
+  rw [hcomp, h1.deriv, moeb_coe]
+
+theorem quot_eq_comp_qParam {P Q : ℍ → ℂ} (hP : P ∈ ring N) (hQ : Q ∈ ring N) :
+    Set.EqOn (fun z => up (precomp δ P) z / up (precomp δ Q) z)
+      ((fun q => cfδ N δ P q / cfδ N δ Q q) ∘ 𝕢 N) 𝕌 := by
+  intro z hz
+  have hP' := cf_qParam N (precomp_mem N δ hP) ⟨z, hz⟩
+  have hQ' := cf_qParam N (precomp_mem N δ hQ) ⟨z, hz⟩
+  simp only [comp_apply, cfδ] at hP' hQ' ⊢
+  rw [hP', hQ', up_apply_of_mem _ hz, up_apply_of_mem _ hz]
+
+theorem slash_apply_eq {F : ℍ → ℂ} {a b c e : ℍ → ℂ} (hc : c ∈ ring N)
+    (he : e ∈ ring N)
+    (hid : ∀ τ : ℍ, F τ * b τ * e τ ^ 2 =
+      a τ * (e τ * deriv (c ∘ ofComplex) τ - c τ * deriv (e ∘ ofComplex) τ))
+    (τ : ℍ) (hbτ : b (δ • τ) ≠ 0) (heτ : e (δ • τ) ≠ 0) :
+    (F ∣[(2 : ℤ)] δ) τ =
+      a (δ • τ) / b (δ • τ) * deriv (fun z => up (precomp δ c) z / up (precomp δ e) z) τ := by
+  set D : ℂ := denom (Matrix.SpecialLinearGroup.mapGL ℝ δ) ↑τ ^ (-2 : ℤ) with hD
+  have hD0 : D ≠ 0 := zpow_ne_zero _ (denom_ne_zero _ _)
+  have hdc := deriv_up_precomp N δ hc τ
+  have hde := deriv_up_precomp N δ he τ
+  rw [← hD] at hdc hde
+  have hdiffC := differentiableAt_up N (precomp_mem N δ hc) τ
+  have hdiffE := differentiableAt_up N (precomp_mem N δ he) τ
+  have hEτ : up (precomp δ e) τ = e (δ • τ) := by rw [up_apply_coe, precomp_apply]
+  have hCτ : up (precomp δ c) τ = c (δ • τ) := by rw [up_apply_coe, precomp_apply]
+  have hEτ0 : up (precomp δ e) τ ≠ 0 := by rwa [hEτ]
+  rw [deriv_fun_div hdiffC hdiffE hEτ0, hdc, hde, hEτ, hCτ, slash_two_apply, ← hD]
+  have h1 := hid (δ • τ)
+  change F (δ • τ) * b (δ • τ) * e (δ • τ) ^ 2 =
+    a (δ • τ) * (e (δ • τ) * deriv (up c) ↑(δ • τ) - c (δ • τ) * deriv (up e) ↑(δ • τ)) at h1
+  field_simp
+  linear_combination h1
+
+variable {K}
+
+omit [NeZero N] in
+theorem eventuallyEq_nhds_of_nhdsNE {f g : ℂ → ℂ} {x : ℂ} (h : f =ᶠ[𝓝[≠] x] g) :
+    ∀ᶠ z in 𝓝[≠] x, f =ᶠ[𝓝 z] g := by
+  rw [Filter.EventuallyEq, eventually_nhdsWithin_iff] at h
+  rw [eventually_nhdsWithin_iff]
+  filter_upwards [h.eventually_nhds] with z hz hzτ
+  filter_upwards [hz, eventually_ne_nhds (Set.mem_compl_singleton_iff.mp hzτ)] with w hw hwτ
+  exact hw (Set.mem_compl_singleton_iff.mpr hwτ)
+
+theorem isZeroAtImInfty_slash {ω : Ω[K⁄ℂ]} (hω : ω ∈ AlgebraicCurve.regularDifferentials ℂ K)
+    (F : ℍ → ℂ)
+    (hF : ∀ (a b c e : ℍ → ℂ) (ha : a ∈ ring N) (hb : b ∈ ring N) (hc : c ∈ ring N)
+      (he : e ∈ ring N), b ≠ 0 → e ≠ 0 →
+      ω = (algebraMap (ring N) K ⟨a, ha⟩ / algebraMap (ring N) K ⟨b, hb⟩) •
+        KaehlerDifferential.D ℂ K (algebraMap (ring N) K ⟨c, hc⟩ / algebraMap (ring N) K ⟨e, he⟩) →
+      ∀ τ : ℍ, F τ * b τ * e τ ^ 2 =
+        a τ * (e τ * deriv (c ∘ ofComplex) τ - c τ * deriv (e ∘ ofComplex) τ)) :
+    IsZeroAtImInfty (F ∣[(2 : ℤ)] δ) := by
+  obtain ⟨f, π, Φ, R, hω', hΦ, hfΦ, hR, hπR⟩ := exists_smul_D_of_mem N K δ hω
+  set a : ring N := num N K f
+  set b : ring N := den N K f
+  set c : ring N := num N K π
+  set e : ring N := den N K π
+  have hb0 : (b : ℍ → ℂ) ≠ 0 := den_ne_zero N K f
+  have he0 : (e : ℍ → ℂ) ≠ 0 := den_ne_zero N K π
+  have hid := hF a b c e a.2 b.2 c.2 e.2 hb0 he0 (by rw [hω', num_div_den, num_div_den])
+  have hrf : realq N K δ f = fun q => cfδ N δ (a : ℍ → ℂ) q / cfδ N δ (b : ℍ → ℂ) q := rfl
+  have hrπ : realq N K δ π = fun q => cfδ N δ (c : ℍ → ℂ) q / cfδ N δ (e : ℍ → ℂ) q := rfl
+  set κ : ℂ := 2 * ↑Real.pi * Complex.I / (N : ℝ) with hκ
+  set H : ℂ → ℂ := fun q => Φ q * (deriv R q * (q * κ)) with hH
+  have hev : ∀ᶠ τ : ℍ in atImInfty, (F ∣[(2 : ℤ)] δ) τ = H (𝕢 N τ) := by
+    have h1 := eventually_cfδ_ne_zero N δ b.2 hb0
+    have h2 := eventually_cfδ_ne_zero N δ e.2 he0
+    have h3 := hfΦ
+    have h4 := eventuallyEq_nhds_of_nhdsNE hπR
+    have h5 : ∀ᶠ q in 𝓝[≠] (0 : ℂ), AnalyticAt ℂ R q :=
+      mem_nhdsWithin_of_mem_nhds hR.eventually_analyticAt
+    filter_upwards [(tendsto_qParam N).eventually (h1.and (h2.and (h3.and (h4.and h5))))]
+      with τ hτ
+    obtain ⟨hbq, heq, hfq, hπq, hRq⟩ := hτ
+    have hbτ : (b : ℍ → ℂ) (δ • τ) ≠ 0 := by
+      have := cf_qParam N (precomp_mem N δ b.2) τ
+      rw [precomp_apply] at this
+      rwa [← this]
+    have heτ : (e : ℍ → ℂ) (δ • τ) ≠ 0 := by
+      have := cf_qParam N (precomp_mem N δ e.2) τ
+      rw [precomp_apply] at this
+      rwa [← this]
+    rw [slash_apply_eq N δ c.2 e.2 hid τ hbτ heτ]
+    have hΦq : (a : ℍ → ℂ) (δ • τ) / (b : ℍ → ℂ) (δ • τ) = Φ (𝕢 N τ) := by
+      rw [← hfq]
+      have ha' := cf_qParam N (precomp_mem N δ a.2) τ
+      have hb' := cf_qParam N (precomp_mem N δ b.2) τ
+      rw [precomp_apply] at ha' hb'
+      simp only [hrf, cfδ]
+      rw [ha', hb']
+    have hRq' : deriv (fun z => up (precomp δ (c : ℍ → ℂ)) z / up (precomp δ (e : ℍ → ℂ)) z) τ =
+        deriv R (𝕢 N τ) * (𝕢 N τ * κ) := by
+      have hE1 : (fun z => up (precomp δ (c : ℍ → ℂ)) z / up (precomp δ (e : ℍ → ℂ)) z)
+          =ᶠ[𝓝 (τ : ℂ)] ((fun q => cfδ N δ (c : ℍ → ℂ) q / cfδ N δ (e : ℍ → ℂ) q) ∘ 𝕢 N) :=
+        Filter.eventuallyEq_of_mem (isOpen_𝕌.mem_nhds (coe_mem_𝕌 τ))
+          (quot_eq_comp_qParam N δ c.2 e.2)
+      have hE2 : ((fun q => cfδ N δ (c : ℍ → ℂ) q / cfδ N δ (e : ℍ → ℂ) q) ∘ 𝕢 N)
+          =ᶠ[𝓝 (τ : ℂ)] (R ∘ 𝕢 N) :=
+        (Periodic.continuous_qParam.continuousAt.tendsto.eventually hπq).mono
+          fun z hz => by
+            simp only [comp_apply]
+            rw [← hz, hrπ]
+      rw [(hE1.trans hE2).deriv_eq]
+      exact (hRq.differentiableAt.hasDerivAt.comp (τ : ℂ) (hasDerivAt_qParam N τ)).deriv
+    rw [hΦq, hRq']
+  have hH0 : Tendsto H (𝓝[≠] (0 : ℂ)) (𝓝 0) := by
+    have hcont : ContinuousAt H 0 :=
+      hΦ.continuousAt.mul (hR.deriv.continuousAt.mul (continuousAt_id.mul continuousAt_const))
+    have := hcont.tendsto
+    simp only [hH, mul_zero, zero_mul] at this
+    exact this.mono_left nhdsWithin_le_nhds
+  exact ((hH0.comp (tendsto_qParam N)).congr' (hev.mono fun τ hτ => hτ.symm) :)
+
+end Cusp
+
+end ModularCurve.LevelN.CuspVanish
+
+theorem solution (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring N) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring N) K]
+    [IsFractionRing (ModularCurve.LevelN.ring N) K]
+    (ω : KaehlerDifferential ℂ K) (hω : ω ∈ AlgebraicCurve.regularDifferentials ℂ K)
+    (F : UpperHalfPlane → ℂ)
+    (hF : ∀ (a b c e : UpperHalfPlane → ℂ) (ha : a ∈ ModularCurve.LevelN.ring N)
+      (hb : b ∈ ModularCurve.LevelN.ring N) (hc : c ∈ ModularCurve.LevelN.ring N)
+      (he : e ∈ ModularCurve.LevelN.ring N), b ≠ 0 → e ≠ 0 →
+      ω = (algebraMap (ModularCurve.LevelN.ring N) K ⟨a, ha⟩ /
+            algebraMap (ModularCurve.LevelN.ring N) K ⟨b, hb⟩) •
+          KaehlerDifferential.D ℂ K (algebraMap (ModularCurve.LevelN.ring N) K ⟨c, hc⟩ /
+            algebraMap (ModularCurve.LevelN.ring N) K ⟨e, he⟩) →
+      ∀ τ : UpperHalfPlane, F τ * b τ * e τ ^ 2 =
+        a τ * (e τ * deriv (c ∘ UpperHalfPlane.ofComplex) τ -
+          c τ * deriv (e ∘ UpperHalfPlane.ofComplex) τ))
+    (δ : SL(2, ℤ)) :
+    UpperHalfPlane.IsZeroAtImInfty (F ∣[(2 : ℤ)] δ) :=
+  ModularCurve.LevelN.CuspVanish.isZeroAtImInfty_slash N δ hω F hF
+
+end
+end S_ModularCurve_LevelN_isZeroAtImInfty_slash_of_mem_regularDifferentials
+end P2MW
+export P2MW.S_ModularCurve_LevelN_isZeroAtImInfty_slash_of_mem_regularDifferentials (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups ModularForm
+theorem ModularCurve.LevelN.isZeroAtImInfty_slash_of_mem_regularDifferentials (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring N) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring N) K]
+    [IsFractionRing (ModularCurve.LevelN.ring N) K]
+    (ω : KaehlerDifferential ℂ K) (hω : ω ∈ AlgebraicCurve.regularDifferentials ℂ K)
+    (F : UpperHalfPlane → ℂ)
+    (hF : ∀ (a b c e : UpperHalfPlane → ℂ) (ha : a ∈ ModularCurve.LevelN.ring N)
+      (hb : b ∈ ModularCurve.LevelN.ring N) (hc : c ∈ ModularCurve.LevelN.ring N)
+      (he : e ∈ ModularCurve.LevelN.ring N), b ≠ 0 → e ≠ 0 →
+      ω = (algebraMap (ModularCurve.LevelN.ring N) K ⟨a, ha⟩ /
+            algebraMap (ModularCurve.LevelN.ring N) K ⟨b, hb⟩) •
+          KaehlerDifferential.D ℂ K (algebraMap (ModularCurve.LevelN.ring N) K ⟨c, hc⟩ /
+            algebraMap (ModularCurve.LevelN.ring N) K ⟨e, he⟩) →
+      ∀ τ : UpperHalfPlane, F τ * b τ * e τ ^ 2 =
+        a τ * (e τ * deriv (c ∘ UpperHalfPlane.ofComplex) τ -
+          c τ * deriv (e ∘ UpperHalfPlane.ofComplex) τ))
+    (δ : SL(2, ℤ)) :
+    UpperHalfPlane.IsZeroAtImInfty (F ∣[(2 : ℤ)] δ) :=
+  solution N K ω hω F hF δ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_slash_eq_self_of_mem_Gamma_of_mul_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_slash_eq_self_of_mem_Gamma_of_mul_eq.lean
new file mode 100644
index 0000000000..95eeb97791
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_slash_eq_self_of_mem_Gamma_of_mul_eq.lean
@@ -0,0 +1,332 @@
+/-
+Based on Prove2Me node ModularCurve.LevelN.slash_eq_self_of_mem_Gamma_of_mul_eq
+(16bfc875-4874-52bf-95c1-f9b8c0a5796d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d1dcdfea-5846-5a00-aecd-535a05eaba65
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LevelNFunctionField
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_modularity_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelN_structure_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Weight-two Γ(N)-invariance of (a/b) (c/e)'
+
+Theorem statement: `ModularCurve.LevelN.slash_eq_self_of_mem_Gamma_of_mul_eq`
+(`16bfc875-4874-52bf-95c1-f9b8c0a5796d`), by Claude, 2026-09-05.
+
+Proof: submission `d1dcdfea-5846-5a00-aecd-535a05eaba65`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $N$ with $N \neq 0$, and let $A_N \subseteq (\mathbb{H} \to \mathbb{C})$ be the
+$\mathbb{C}$-subalgebra [`ModularCurve.LevelN.ring
+N`](def/ModularCurve_LevelNFunctionField.html#L28), defined as the $\mathbb{C}$-algebra generated by
+the function `jAnalytic` together with all the functions `fricke N v` for $v \in (\mathbb{Z}/N)^2$
+with $v \neq 0$. Let $F : \mathbb{H} \to \mathbb{C}$ be holomorphic, in the sense of being
+differentiable for the standard complex-manifold structures on the upper half-plane and on
+$\mathbb{C}$, and let $a, b, c, e : \mathbb{H} \to \mathbb{C}$ be four elements of $A_N$ with $b$
+and $e$ not the zero function. Assume that for every $\tau \in \mathbb{H}$ one has $$F(\tau)\,
+b(\tau)\, e(\tau)^2 = a(\tau)\bigl(e(\tau)\, c'(\tau) - c(\tau)\, e'(\tau)\bigr),$$ where the
+derivatives are the complex derivatives at $\tau$ of the compositions of $c$ and $e$ with
+`UpperHalfPlane.ofComplex`; informally, $F = (a/b)\,(c/e)'$ away from the zeros of $be$. Then for
+every $\gamma \in \mathrm{SL}_2(\mathbb{Z})$ lying in the principal congruence subgroup $\Gamma(N)$,
+the weight-$2$ slash action leaves $F$ unchanged: $F \mid_2 \gamma = F$ as functions on
+$\mathbb{H}$.
+
+This is the automorphy half of the classical description of differentials of the first kind on the
+modular curve $X(N)$: a function of the form $(a/b)\,d(c/e)/d\tau$ with $a,b,c,e$ modular functions
+of level $N$ transforms with weight $2$ under $\Gamma(N)$. It is used in the construction of an
+injective linear map from regular differentials to cusp forms,
+[`ModularCurve.LevelN.exists_linearMap_regularDifferentials_cuspForm_injective`]
+(thm.html#ModularCurve.LevelN.exists_linearMap_regularDifferentials_cuspForm_injective).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_LevelN_slash_eq_self_of_mem_Gamma_of_mul_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_LevelN_slash_eq_self_of_mem_Gamma_of_mul_eq
+
+
+noncomputable section
+
+open UpperHalfPlane Filter Topology Function
+open scoped Manifold MatrixGroups ModularForm
+
+namespace ModularCurve
+p2m_export "ModularCurve" "LevelN.ring"
+namespace LevelN
+p2m_export "ModularCurve.LevelN" "wp fricke jAnalytic generators ring"
+namespace WeightTwo
+p2m_open "ModularCurve.LevelN ModularCurve"
+
+variable (N : ℕ) [NeZero N]
+
+abbrev redMat (γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) (ZMod N) :=
+  (γ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N)
+
+theorem mdifferentiable_of_mem {F : ℍ → ℂ} (hF : F ∈ ring N) : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F := by
+  have h := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact h.2.2.2.2.1 F hF
+
+theorem eq_zero_or_eq_zero_of_mul_eq_zero {a b : ℍ → ℂ} (ha : a ∈ ring N) (hb : b ∈ ring N)
+    (hab : a * b = 0) : a = 0 ∨ b = 0 := by
+  have h := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact h.2.2.2.2.2 a b ha hb hab
+
+theorem fricke_smul_of_mem (v : Fin 2 → ZMod N) {γ : SL(2, ℤ)}
+    (hγ : γ ∈ CongruenceSubgroup.Gamma N) (τ : ℍ) : fricke N v (γ • τ) = fricke N v τ :=
+  (WLight.frickeFunction_modularity_package N PeriodPair.ofTau
+    (fun _ => ⟨rfl, rfl⟩)).2.2.2.2.2.2.1 v γ hγ τ
+
+omit [NeZero N] in
+theorem jAnalytic_smul (γ : SL(2, ℤ)) (τ : ℍ) : jAnalytic (γ • τ) = jAnalytic τ := by
+  have hmem : (γ : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ, rfl⟩
+  have h4 : (ModularForm.E₄ : ℍ → ℂ) ((γ : GL (Fin 2) ℝ) • τ) =
+      denom (γ : GL (Fin 2) ℝ) τ ^ (4 : ℤ) * ModularForm.E₄ τ :=
+    SlashInvariantForm.slash_action_eqn'' _ hmem τ
+  have h12 : ModularForm.discriminant ((γ : GL (Fin 2) ℝ) • τ) =
+      denom (γ : GL (Fin 2) ℝ) τ ^ (12 : ℤ) * ModularForm.discriminant τ := by
+    have := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hmem τ
+    simpa using this
+  have hd : denom (γ : GL (Fin 2) ℝ) τ ≠ 0 := denom_ne_zero _ _
+  have hΔ : ModularForm.discriminant τ ≠ 0 := ModularForm.discriminant_ne_zero τ
+  rw [jAnalytic, jAnalytic, ModularGroup.sl_moeb, h4, h12]
+  field_simp
+
+omit [NeZero N] in
+def precomp (g : SL(2, ℤ)) : (ℍ → ℂ) →ₐ[ℂ] (ℍ → ℂ) :=
+  AlgHom.pi (fun τ => Pi.evalAlgHom ℂ (fun _ : ℍ => ℂ) (g • τ))
+
+omit [NeZero N] in
+@[scoped simp]
+theorem precomp_apply (g : SL(2, ℤ)) (F : ℍ → ℂ) (τ : ℍ) : precomp g F τ = F (g • τ) := rfl
+
+theorem apply_smul_of_mem {γ : SL(2, ℤ)} (hγ : γ ∈ CongruenceSubgroup.Gamma N) {F : ℍ → ℂ}
+    (hF : F ∈ ring N) (τ : ℍ) : F (γ • τ) = F τ := by
+  have hle : ring N ≤ AlgHom.equalizer (precomp γ) (AlgHom.id ℂ (ℍ → ℂ)) := by
+    rw [ring, Algebra.adjoin_le_iff]
+    intro G hG
+    rw [SetLike.mem_coe, AlgHom.mem_equalizer, AlgHom.id_apply]
+    funext τ
+    rw [precomp_apply]
+    rcases hG with rfl | ⟨v, hv, rfl⟩
+    · exact jAnalytic_smul γ τ
+    · exact fricke_smul_of_mem N v hγ τ
+  have := hle hF
+  rw [AlgHom.mem_equalizer, AlgHom.id_apply] at this
+  exact congrFun this τ
+
+def 𝕌 : Set ℂ := {z : ℂ | 0 < z.im}
+
+theorem isOpen_𝕌 : IsOpen 𝕌 := isOpen_upperHalfPlaneSet
+
+theorem isPreconnected_𝕌 : IsPreconnected 𝕌 := (convex_halfSpace_im_gt 0).isPreconnected
+
+theorem coe_mem_𝕌 (τ : ℍ) : (τ : ℂ) ∈ 𝕌 := τ.im_pos
+
+def up (F : ℍ → ℂ) : ℂ → ℂ := F ∘ ofComplex
+
+theorem up_apply_coe (F : ℍ → ℂ) (τ : ℍ) : up F τ = F τ := by
+  simp [up, ofComplex_apply]
+
+theorem analyticOnNhd_up_of_mdifferentiable {F : ℍ → ℂ} (hF : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F) :
+    AnalyticOnNhd ℂ (up F) 𝕌 := by
+  intro z hz
+  have hd : DifferentiableOn ℂ (up F) 𝕌 := UpperHalfPlane.mdifferentiable_iff.mp hF
+  exact hd.analyticAt (isOpen_𝕌.mem_nhds hz)
+
+theorem analyticOnNhd_up {F : ℍ → ℂ} (hF : F ∈ ring N) : AnalyticOnNhd ℂ (up F) 𝕌 :=
+  analyticOnNhd_up_of_mdifferentiable (mdifferentiable_of_mem N hF)
+
+theorem differentiableAt_up {F : ℍ → ℂ} (hF : F ∈ ring N) (τ : ℍ) :
+    DifferentiableAt ℂ (up F) τ :=
+  (analyticOnNhd_up N hF τ (coe_mem_𝕌 τ)).differentiableAt
+
+theorem up_eq_zero_iff (F : ℍ → ℂ) : (∀ z ∈ 𝕌, up F z = 0) ↔ F = 0 := by
+  constructor
+  · intro h
+    funext τ
+    simpa [up_apply_coe] using h τ (coe_mem_𝕌 τ)
+  · rintro rfl z _
+    rfl
+
+theorem eventually_ne_zero {F : ℍ → ℂ} (hF : F ∈ ring N) (hF0 : F ≠ 0) (τ : ℍ) :
+    ∀ᶠ z in 𝓝[≠] (τ : ℂ), up F z ≠ 0 := by
+  rcases (analyticOnNhd_up N hF τ (coe_mem_𝕌 τ)).eventually_eq_zero_or_eventually_ne_zero
+    with h | h
+  · exfalso
+    apply hF0
+    rw [← up_eq_zero_iff]
+    intro z hz
+    exact (analyticOnNhd_up N hF).eqOn_zero_of_preconnected_of_eventuallyEq_zero
+      isPreconnected_𝕌 (coe_mem_𝕌 τ) h hz
+  · exact h
+
+theorem eq_zero_of_mul_eq_zero {G : ℍ → ℂ} (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G) {p : ℍ → ℂ}
+    (hp : p ∈ ring N) (hp0 : p ≠ 0) (h : ∀ τ : ℍ, p τ ≠ 0 → G τ = 0) : G = 0 := by
+  funext τ
+  have hcont : ContinuousAt (up G) τ :=
+    (analyticOnNhd_up_of_mdifferentiable hG τ (coe_mem_𝕌 τ)).continuousAt
+  have hev : ∀ᶠ z in 𝓝[≠] (τ : ℂ), up G z = 0 := by
+    filter_upwards [eventually_ne_zero N hp hp0 τ,
+      mem_nhdsWithin_of_mem_nhds (isOpen_𝕌.mem_nhds (coe_mem_𝕌 τ))] with z hz hzU
+    have hz' : p ⟨z, hzU⟩ ≠ 0 := by
+      simpa [up, ofComplex_apply_of_im_pos hzU] using hz
+    have := h ⟨z, hzU⟩ hz'
+    simpa [up, ofComplex_apply_of_im_pos hzU] using this
+  have h1 : Tendsto (up G) (𝓝[≠] (τ : ℂ)) (𝓝 (up G τ)) := hcont.tendsto.mono_left nhdsWithin_le_nhds
+  have h2 : Tendsto (up G) (𝓝[≠] (τ : ℂ)) (𝓝 0) :=
+    tendsto_const_nhds.congr' (hev.mono fun z hz => hz.symm)
+  have := tendsto_nhds_unique h1 h2
+  rwa [up_apply_coe] at this
+
+def moeb (g : SL(2, ℤ)) (z : ℂ) : ℂ := ((g • ofComplex z : ℍ) : ℂ)
+
+theorem moeb_coe (g : SL(2, ℤ)) (τ : ℍ) : moeb g τ = ((g • τ : ℍ) : ℂ) := by
+  simp [moeb, ofComplex_apply]
+
+theorem hasDerivAt_moeb (γ : SL(2, ℤ)) (τ : ℍ) :
+    HasDerivAt (moeb γ) (denom (Matrix.SpecialLinearGroup.mapGL ℝ γ) ↑τ ^ (-2 : ℤ)) ↑τ := by
+  set G : GL (Fin 2) ℝ := Matrix.SpecialLinearGroup.mapGL ℝ γ with hG
+  have hdet : (G : Matrix (Fin 2) (Fin 2) ℝ).det = 1 := by
+    rw [← Matrix.GeneralLinearGroup.val_det_apply, hG, Matrix.SpecialLinearGroup.det_mapGL,
+      Units.val_one]
+  have hpos : (0:ℝ) < (G : Matrix (Fin 2) (Fin 2) ℝ).det := by rw [hdet]; norm_num
+  have h1 := (UpperHalfPlane.hasStrictDerivAt_smul hpos τ).hasDerivAt
+  have h2 : (fun z : ℂ => ((G • ofComplex z : ℍ) : ℂ)) = moeb γ := by
+    funext z
+    rw [moeb, MulAction.compHom_smul_def]
+  rw [h2] at h1
+  convert h1 using 1
+  rw [hdet]
+  push_cast
+  rw [zpow_neg, one_div]
+  norm_cast
+
+theorem deriv_up_smul {γ : SL(2, ℤ)} (hγ : γ ∈ CongruenceSubgroup.Gamma N) {c : ℍ → ℂ}
+    (hc : c ∈ ring N) (τ : ℍ) :
+    deriv (up c) ↑(γ • τ) * denom (Matrix.SpecialLinearGroup.mapGL ℝ γ) ↑τ ^ (-2 : ℤ) =
+      deriv (up c) τ := by
+  have hinv : up c ∘ moeb γ = up c := by
+    funext z
+    simp only [comp_apply, up, moeb, ofComplex_apply]
+    exact apply_smul_of_mem N hγ hc _
+  have h1 : HasDerivAt (up c ∘ moeb γ)
+      (deriv (up c) (moeb γ τ) * denom (Matrix.SpecialLinearGroup.mapGL ℝ γ) ↑τ ^ (-2 : ℤ)) τ := by
+    refine HasDerivAt.comp (τ : ℂ) ?_ (hasDerivAt_moeb γ τ)
+    rw [moeb_coe]
+    exact (differentiableAt_up N hc (γ • τ)).hasDerivAt
+  rw [hinv] at h1
+  rw [← moeb_coe]
+  exact h1.deriv.symm
+
+theorem slash_two_apply (f : ℍ → ℂ) (γ : SL(2, ℤ)) (τ : ℍ) :
+    (f ∣[(2 : ℤ)] γ) τ =
+      f (γ • τ) * denom (Matrix.SpecialLinearGroup.mapGL ℝ γ) ↑τ ^ (-2 : ℤ) :=
+  ModularForm.SL_slash_apply f γ τ
+
+theorem slash_apply_eq_of_ne {F : ℍ → ℂ} {a b c e : ℍ → ℂ} (ha : a ∈ ring N) (hb : b ∈ ring N)
+    (hc : c ∈ ring N) (he : e ∈ ring N)
+    (h : ∀ τ : ℍ, F τ * b τ * e τ ^ 2 =
+      a τ * (e τ * deriv (c ∘ ofComplex) τ - c τ * deriv (e ∘ ofComplex) τ))
+    {γ : SL(2, ℤ)} (hγ : γ ∈ CongruenceSubgroup.Gamma N) (τ : ℍ) (hbe : b τ * e τ ≠ 0) :
+    (F ∣[(2 : ℤ)] γ) τ = F τ := by
+  set D : ℂ := denom (Matrix.SpecialLinearGroup.mapGL ℝ γ) ↑τ ^ (-2 : ℤ) with hD
+  have hD0 : D ≠ 0 := zpow_ne_zero _ (denom_ne_zero _ _)
+  have h1 := h (γ • τ)
+  rw [apply_smul_of_mem N hγ ha, apply_smul_of_mem N hγ hb, apply_smul_of_mem N hγ hc,
+    apply_smul_of_mem N hγ he] at h1
+  have hc' : deriv (c ∘ ofComplex) ↑(γ • τ) = deriv (c ∘ ofComplex) τ * D⁻¹ := by
+    rw [eq_mul_inv_iff_mul_eq₀ hD0]
+    exact deriv_up_smul N hγ hc τ
+  have he' : deriv (e ∘ ofComplex) ↑(γ • τ) = deriv (e ∘ ofComplex) τ * D⁻¹ := by
+    rw [eq_mul_inv_iff_mul_eq₀ hD0]
+    exact deriv_up_smul N hγ he τ
+  rw [hc', he'] at h1
+  have h2 := h τ
+  rw [slash_two_apply]
+  have h3 : F (γ • τ) * (b τ * e τ ^ 2) = (F τ * D⁻¹) * (b τ * e τ ^ 2) := by
+    calc F (γ • τ) * (b τ * e τ ^ 2) = F (γ • τ) * b τ * e τ ^ 2 := by ring
+      _ = a τ * (e τ * (deriv (c ∘ ofComplex) τ * D⁻¹) - c τ * (deriv (e ∘ ofComplex) τ * D⁻¹)) :=
+        h1
+      _ = (a τ * (e τ * deriv (c ∘ ofComplex) τ - c τ * deriv (e ∘ ofComplex) τ)) * D⁻¹ := by ring
+      _ = (F τ * b τ * e τ ^ 2) * D⁻¹ := by rw [h2]
+      _ = (F τ * D⁻¹) * (b τ * e τ ^ 2) := by ring
+  have hbe2 : b τ * e τ ^ 2 ≠ 0 := by
+    have hb0 : b τ ≠ 0 := left_ne_zero_of_mul hbe
+    have he0 : e τ ≠ 0 := right_ne_zero_of_mul hbe
+    exact mul_ne_zero hb0 (pow_ne_zero 2 he0)
+  have h4 : F (γ • τ) = F τ * D⁻¹ := mul_right_cancel₀ hbe2 h3
+  rw [h4, mul_assoc, inv_mul_cancel₀ hD0, mul_one]
+
+theorem slash_eq_self {F : ℍ → ℂ} (hF : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F) {a b c e : ℍ → ℂ}
+    (ha : a ∈ ring N) (hb : b ∈ ring N) (hc : c ∈ ring N) (he : e ∈ ring N) (hb0 : b ≠ 0)
+    (he0 : e ≠ 0)
+    (h : ∀ τ : ℍ, F τ * b τ * e τ ^ 2 =
+      a τ * (e τ * deriv (c ∘ ofComplex) τ - c τ * deriv (e ∘ ofComplex) τ))
+    {γ : SL(2, ℤ)} (hγ : γ ∈ CongruenceSubgroup.Gamma N) :
+    F ∣[(2 : ℤ)] γ = F := by
+  have hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (F ∣[(2 : ℤ)] γ - F) := (hF.slash 2 _).sub hF
+  have hp : b * e ∈ ring N := (ring N).mul_mem hb he
+  have hp0 : b * e ≠ 0 := fun h0 =>
+    (eq_zero_or_eq_zero_of_mul_eq_zero N hb he h0).elim hb0 he0
+  have := eq_zero_of_mul_eq_zero N hG hp hp0 (fun τ hτ => by
+    rw [Pi.sub_apply, slash_apply_eq_of_ne N ha hb hc he h hγ τ hτ, sub_self])
+  exact sub_eq_zero.mp this
+
+end ModularCurve.LevelN.WeightTwo
+
+theorem solution (N : ℕ) [NeZero N] (F : UpperHalfPlane → ℂ)
+    (hF : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F)
+    (a b c e : UpperHalfPlane → ℂ) (ha : a ∈ ModularCurve.LevelN.ring N)
+    (hb : b ∈ ModularCurve.LevelN.ring N) (hc : c ∈ ModularCurve.LevelN.ring N)
+    (he : e ∈ ModularCurve.LevelN.ring N) (hb0 : b ≠ 0) (he0 : e ≠ 0)
+    (h : ∀ τ : UpperHalfPlane, F τ * b τ * e τ ^ 2 =
+      a τ * (e τ * deriv (c ∘ UpperHalfPlane.ofComplex) τ -
+        c τ * deriv (e ∘ UpperHalfPlane.ofComplex) τ))
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma N) :
+    F ∣[(2 : ℤ)] γ = F :=
+  ModularCurve.LevelN.WeightTwo.slash_eq_self N hF ha hb hc he hb0 he0 h hγ
+
+end
+end S_ModularCurve_LevelN_slash_eq_self_of_mem_Gamma_of_mul_eq
+end P2MW
+export P2MW.S_ModularCurve_LevelN_slash_eq_self_of_mem_Gamma_of_mul_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Manifold MatrixGroups ModularForm
+theorem ModularCurve.LevelN.slash_eq_self_of_mem_Gamma_of_mul_eq (N : ℕ) [NeZero N]
+    (F : UpperHalfPlane → ℂ) (hF : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F)
+    (a b c e : UpperHalfPlane → ℂ) (ha : a ∈ ModularCurve.LevelN.ring N)
+    (hb : b ∈ ModularCurve.LevelN.ring N) (hc : c ∈ ModularCurve.LevelN.ring N)
+    (he : e ∈ ModularCurve.LevelN.ring N) (hb0 : b ≠ 0) (he0 : e ≠ 0)
+    (h : ∀ τ : UpperHalfPlane, F τ * b τ * e τ ^ 2 =
+      a τ * (e τ * deriv (c ∘ UpperHalfPlane.ofComplex) τ -
+        c τ * deriv (e ∘ UpperHalfPlane.ofComplex) τ))
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma N) :
+    F ∣[(2 : ℤ)] γ = F :=
+  solution N F hF a b c e ha hb hc he hb0 he0 h γ hγ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_twelve_mul_add_mul_index_le_genusFF.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_twelve_mul_add_mul_index_le_genusFF.lean
new file mode 100644
index 0000000000..334f974927
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_twelve_mul_add_mul_index_le_genusFF.lean
@@ -0,0 +1,664 @@
+/-
+Based on Prove2Me node ModularCurve.LevelN.twelve_mul_add_mul_index_le_genusFF
+(4d8ea939-d6e9-53f2-b8e0-64b3279c447c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1cab8fef-a829-5ce1-ab34-b1401ca56088
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Repartitions
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LevelNFunctionField
+
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.Data.Int.Star
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_min_ord_le_ord_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_restrictAlong_eq_natCard_algHom_of_isGalois
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_sum_ord_sub_one_le_two_mul_genusFF_of_isSeparable
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_monoidHom_algEquiv_fixedField_eq_adjoin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_place_ord_neg_forall_smul_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_place_ord_sub_pos_forall_smul_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Genus lower bound for the level-N modular function field
+
+Theorem statement: `ModularCurve.LevelN.twelve_mul_add_mul_index_le_genusFF`
+(`4d8ea939-d6e9-53f2-b8e0-64b3279c447c`), by Claude, 2026-09-05.
+
+Proof: submission `1cab8fef-a829-5ce1-ab34-b1401ca56088`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, nonzero, with $2 \le N$, and let $K$ be a field carrying an algebra
+structure over $\mathbb{C}$ and over [`ModularCurve.LevelN.ring
+N`](def/ModularCurve_LevelNFunctionField.html#L28), these being compatible (a scalar tower), and
+such that $K$ is a fraction field of [`ModularCurve.LevelN.ring
+N`](def/ModularCurve_LevelNFunctionField.html#L28). Here [`ModularCurve.LevelN.ring
+N`](def/ModularCurve_LevelNFunctionField.html#L28) is the $\mathbb{C}$-subalgebra of the algebra of
+functions $\mathbb{H} \to \mathbb{C}$ on the upper half-plane generated by the set consisting of the
+analytic $j$-function `jAnalytic` together with all Fricke functions `fricke N v` for $v :
+\mathrm{Fin}\,2 \to \mathbb{Z}/N$ with $v \neq 0$; thus $K$ is a model of the field of modular
+functions of level $N$. Write $\mu_N$ for the index in $\mathrm{SL}_2(\mathbb{Z})$ of the subgroup
+generated by the principal congruence subgroup $\Gamma(N)$ together with the integer powers of $-1$,
+and $g =$ [`AlgebraicCurve.genusFF ℂ K`](def/AlgebraicCurve_Repartitions.html#L145), the
+$\mathbb{C}$-dimension of the space $H^1$ attached to the zero divisor in the group of divisors
+$\mathrm{Place}\,\mathbb{C}\,K \to_{\mathrm{f}} \mathbb{Z}$ of the function field $K/\mathbb{C}$.
+The assertion is the inequality of natural numbers $$12N + N\mu_N \le 12N\,g + 6\mu_N,$$
+equivalently $g \ge 1 + \mu_N(N-6)/(12N)$.
+
+This is the classical genus formula for the modular curve $X(N)$, $N \ge 2$, in the form of the
+inequality $g \ge 1 + \mu_N(N-6)/(12N)$ obtained from the ramification of $K/\mathbb{C}(j)$ above $j
+= 0, 1728, \infty$ and the Riemann–Hurwitz bound, with $g$ taken in the adelic (function-field)
+sense. It is used to bound from below the dimension of the space of cusp forms for $\Gamma(N)$, in
+[`ModularCurve.twelve_mul_add_mul_index_le_finrank_cuspForm_Gamma`]
+(thm.html#ModularCurve.twelve_mul_add_mul_index_le_finrank_cuspForm_Gamma).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_LevelN_twelve_mul_add_mul_index_le_genusFF.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_LevelN_twelve_mul_add_mul_index_le_genusFF
+
+
+open UpperHalfPlane
+open scoped MatrixGroups IntermediateField
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "LevelN.ring LevelN.exists_monoidHom_algEquiv_fixedField_eq_adjoin \
+  LevelN.exists_place_ord_sub_pos_forall_smul_eq LevelN.exists_place_ord_neg_forall_smul_eq"
+namespace LevelN
+p2m_export "ModularCurve.LevelN" "jAnalytic ring jGen \
+  exists_monoidHom_algEquiv_fixedField_eq_adjoin exists_place_ord_sub_pos_forall_smul_eq \
+  exists_place_ord_neg_forall_smul_eq"
+namespace GenusBound
+p2m_open "ModularCurve.LevelN ModularCurve~jGen"
+
+def rho : ℍ := ⟨-1 / 2 + (Real.sqrt 3 / 2 : ℝ) * Complex.I, by
+  simp only [Complex.add_im, Complex.div_ofNat_im, Complex.neg_im, Complex.one_im, neg_zero,
+    zero_div, Complex.mul_im, Complex.ofReal_re, Complex.I_im, mul_one, Complex.ofReal_im,
+    Complex.I_re, mul_zero, add_zero, zero_add]
+  positivity⟩
+
+theorem coe_rho : ((rho : ℍ) : ℂ) = -1 / 2 + (Real.sqrt 3 / 2 : ℝ) * Complex.I := rfl
+
+theorem rho_sq : ((rho : ℍ) : ℂ) ^ 2 + (rho : ℂ) + 1 = 0 := by
+  have h3 : ((Real.sqrt 3 : ℝ) : ℂ) ^ 2 = 3 := by
+    rw [← Complex.ofReal_pow, Real.sq_sqrt (by norm_num : (0 : ℝ) ≤ 3)]
+    norm_num
+  rw [coe_rho]
+  push_cast
+  ring_nf
+  rw [Complex.I_sq]
+  linear_combination (1 / 4 : ℂ) * h3 - (1/4:ℂ) * h3 + (-(1:ℂ)/4) * (h3)
+
+theorem ST_smul_rho : (ModularGroup.S * ModularGroup.T) • rho = rho := by
+  have hρ := rho_sq
+  have hne : ((rho : ℍ) : ℂ) + 1 ≠ 0 := by
+    intro h
+    have him := congrArg Complex.im h
+    rw [coe_rho] at him
+    simp at him
+  apply UpperHalfPlane.ext
+  rw [UpperHalfPlane.specialLinearGroup_apply]
+  simp only [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_S, ModularGroup.coe_T]
+  simp only [Matrix.cons_mul, Matrix.vecMul_cons, Matrix.head_cons, Matrix.tail_cons,
+    Matrix.empty_vecMul, Matrix.empty_mul]
+  simp
+  field_simp
+  linear_combination -hρ
+
+theorem E₄_rho : ModularForm.E₄ rho = 0 := by
+  set γ : SL(2, ℤ) := ModularGroup.S * ModularGroup.T with hγ
+  have hmem : (γ : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ, rfl⟩
+  have h4 : (ModularForm.E₄ : ℍ → ℂ) ((γ : GL (Fin 2) ℝ) • rho) =
+      denom (γ : GL (Fin 2) ℝ) rho ^ (4 : ℤ) * ModularForm.E₄ rho :=
+    SlashInvariantForm.slash_action_eqn'' _ hmem rho
+  rw [← ModularGroup.sl_moeb, hγ, ST_smul_rho] at h4
+  have hden : denom ((ModularGroup.S * ModularGroup.T : SL(2, ℤ)) : GL (Fin 2) ℝ) rho =
+      (rho : ℂ) + 1 := by
+    simp [denom, ModularGroup.coe_S, ModularGroup.coe_T, Matrix.mul_apply, Fin.sum_univ_two]
+  rw [hden] at h4
+  have hω : ((rho : ℂ) + 1) ^ 2 = ((rho : ℂ) + 1) - 1 := by linear_combination rho_sq
+  have hω4 : ((rho : ℂ) + 1) ^ (4 : ℤ) = -((rho : ℂ) + 1) := by
+    rw [show ((rho : ℂ) + 1) ^ (4 : ℤ) = (((rho : ℂ) + 1) ^ 2) ^ 2 by norm_cast; ring, hω]
+    linear_combination rho_sq
+  rw [hω4] at h4
+  have hne : -((rho : ℂ) + 1) - 1 ≠ 0 := by
+    intro h
+    have him := congrArg Complex.im h
+    rw [coe_rho] at him
+    simp at him
+  have : (-((rho : ℂ) + 1) - 1) * ModularForm.E₄ rho = 0 := by linear_combination -h4
+  rcases mul_eq_zero.mp this with h | h
+  · exact absurd h hne
+  · exact h
+
+theorem jAnalytic_rho : jAnalytic rho = 0 := by
+  rw [jAnalytic, E₄_rho]
+  simp
+
+theorem S_smul_I : ModularGroup.S • UpperHalfPlane.I = UpperHalfPlane.I := by
+  apply UpperHalfPlane.ext
+  rw [modular_S_smul]
+  change (-(UpperHalfPlane.I : ℂ))⁻¹ = (UpperHalfPlane.I : ℂ)
+  rw [coe_I, Complex.inv_def]
+  simp
+
+theorem E₆_I : ModularForm.E₆ UpperHalfPlane.I = 0 := by
+  have hmem : ((ModularGroup.S : SL(2, ℤ)) : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨ModularGroup.S, rfl⟩
+  have h6 : (ModularForm.E₆ : ℍ → ℂ) (((ModularGroup.S : SL(2, ℤ)) : GL (Fin 2) ℝ) •
+    UpperHalfPlane.I) =
+      denom ((ModularGroup.S : SL(2, ℤ)) : GL (Fin 2) ℝ) UpperHalfPlane.I ^ (6 : ℤ) *
+        ModularForm.E₆ UpperHalfPlane.I :=
+    SlashInvariantForm.slash_action_eqn'' _ hmem UpperHalfPlane.I
+  rw [← ModularGroup.sl_moeb, S_smul_I] at h6
+  have hden : denom ((ModularGroup.S : SL(2, ℤ)) : GL (Fin 2) ℝ) UpperHalfPlane.I = Complex.I := by
+    simp [denom, ModularGroup.coe_S]
+  rw [hden, show (Complex.I) ^ (6 : ℤ) = -1 by
+    rw [show (6 : ℤ) = ((6 : ℕ) : ℤ) from rfl, zpow_natCast]
+    rw [show (6 : ℕ) = 2 * 3 from rfl, pow_mul, Complex.I_sq]; norm_num] at h6
+  linear_combination h6 / 2
+
+theorem jAnalytic_I : jAnalytic UpperHalfPlane.I = 1728 := by
+  have hΔ := ModularForm.discriminant_eq_E₄_cube_sub_E₆_sq UpperHalfPlane.I
+  rw [E₆_I] at hΔ
+  have hΔ0 := ModularForm.discriminant_ne_zero UpperHalfPlane.I
+  have hE4 : ModularForm.E₄ UpperHalfPlane.I ≠ 0 := by
+    intro h
+    apply hΔ0
+    rw [hΔ, h]
+    norm_num
+  rw [jAnalytic, hΔ]
+  field_simp
+  ring
+
+abbrev Gpm (N : ℕ) : Subgroup SL(2, ℤ) :=
+  CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))
+
+theorem mem_Gpm_imp (N : ℕ) {g : SL(2, ℤ)} (hg : g ∈ Gpm N) :
+    g ∈ CongruenceSubgroup.Gamma N ∨ -g ∈ CongruenceSubgroup.Gamma N := by
+  have : (CongruenceSubgroup.Gamma N).Normal := CongruenceSubgroup.Gamma_normal N
+  obtain ⟨y, hy, z, hz, rfl⟩ := Subgroup.mem_sup_of_normal_left.mp hg
+  obtain ⟨k, rfl⟩ := Subgroup.mem_zpowers_iff.mp hz
+  have h2 : ((-1 : SL(2, ℤ)) ^ (2 : ℤ)) = 1 := by rw [zpow_two]; simp
+  rcases Int.even_or_odd k with ⟨m, rfl⟩ | ⟨m, rfl⟩
+  · left
+    rw [← two_mul, zpow_mul, h2, one_zpow, mul_one]
+    exact hy
+  · right
+    rw [zpow_add, zpow_mul, h2, one_zpow, one_mul, zpow_one, mul_neg_one, neg_neg]
+    exact hy
+
+theorem entry_10_eq_zero_of_mem_Gpm (N : ℕ) {g : SL(2, ℤ)} (hg : g ∈ Gpm N) :
+    ((g 1 0 : ℤ) : ZMod N) = 0 := by
+  rcases mem_Gpm_imp N hg with h | h
+  · exact (CongruenceSubgroup.Gamma_mem.mp h).2.2.1
+  · have := (CongruenceSubgroup.Gamma_mem.mp h).2.2.1
+    rw [Matrix.SpecialLinearGroup.coe_neg, Matrix.neg_apply, Int.cast_neg, neg_eq_zero] at this
+    exact this
+
+theorem entry_01_eq_zero_of_mem_Gpm (N : ℕ) {g : SL(2, ℤ)} (hg : g ∈ Gpm N) :
+    ((g 0 1 : ℤ) : ZMod N) = 0 := by
+  rcases mem_Gpm_imp N hg with h | h
+  · exact (CongruenceSubgroup.Gamma_mem.mp h).2.1
+  · have := (CongruenceSubgroup.Gamma_mem.mp h).2.1
+    rw [Matrix.SpecialLinearGroup.coe_neg, Matrix.neg_apply, Int.cast_neg, neg_eq_zero] at this
+    exact this
+
+theorem dvd_of_T_pow_mem (N : ℕ) {n : ℕ} (h : ModularGroup.T ^ n ∈ Gpm N) : N ∣ n := by
+  have h01 := entry_01_eq_zero_of_mem_Gpm N h
+  rw [← zpow_natCast, ModularGroup.coe_T_zpow] at h01
+  simp only [Matrix.of_apply, Matrix.cons_val', Matrix.cons_val_one, Matrix.cons_val_fin_one,
+    Matrix.cons_val_zero, Int.cast_natCast] at h01
+  exact (ZMod.natCast_eq_zero_iff n N).mp h01
+
+theorem one_ne_zero_zmod {N : ℕ} (hN : 2 ≤ N) : (1 : ZMod N) ≠ 0 := by
+  have : Fact (1 < N) := ⟨hN⟩
+  exact one_ne_zero
+
+theorem dvd_of_S_pow_mem {N : ℕ} (hN : 2 ≤ N) {n : ℕ} (h : ModularGroup.S ^ n ∈ Gpm N) : 2 ∣ n := by
+  by_contra hodd
+  rw [Nat.two_dvd_ne_zero, ← Nat.odd_iff] at hodd
+  obtain ⟨k, rfl⟩ := hodd
+  have hS2 : (ModularGroup.S : SL(2, ℤ)) ^ 2 = -1 := by
+    ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp [pow_two, ModularGroup.coe_S, Matrix.mul_apply, Fin.sum_univ_two]
+  have hpow : (ModularGroup.S : SL(2, ℤ)) ^ (2 * k + 1) = (-1) ^ k * ModularGroup.S := by
+    rw [pow_succ, pow_mul, hS2]
+  rw [hpow] at h
+  have h10 := entry_10_eq_zero_of_mem_Gpm N h
+  rcases neg_one_pow_eq_or SL(2, ℤ) k with hk | hk
+  · rw [hk, one_mul, ModularGroup.coe_S] at h10
+    simp only [Matrix.of_apply, Matrix.cons_val', Matrix.cons_val_zero, Matrix.cons_val_one,
+      Matrix.cons_val_fin_one, Int.cast_one] at h10
+    exact one_ne_zero_zmod hN h10
+  · rw [hk, neg_one_mul, Matrix.SpecialLinearGroup.coe_neg, ModularGroup.coe_S] at h10
+    simp only [Matrix.neg_apply, Matrix.of_apply, Matrix.cons_val', Matrix.cons_val_zero,
+      Matrix.cons_val_one, Matrix.cons_val_fin_one, Int.cast_neg, Int.cast_one, neg_eq_zero] at h10
+    exact one_ne_zero_zmod hN h10
+
+theorem dvd_of_ST_pow_mem {N : ℕ} (hN : 2 ≤ N) {n : ℕ}
+    (h : (ModularGroup.S * ModularGroup.T) ^ n ∈ Gpm N) : 3 ∣ n := by
+  have hST : ((ModularGroup.S * ModularGroup.T : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) =
+      !![0, -1; 1, 1] := by
+    rw [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_S, ModularGroup.coe_T]
+    ext i j
+    fin_cases i <;> fin_cases j <;> simp [Matrix.mul_apply, Fin.sum_univ_two]
+  have hST2 : (((ModularGroup.S * ModularGroup.T) ^ 2 : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) =
+      !![-1, -1; 1, 0] := by
+    rw [Matrix.SpecialLinearGroup.coe_pow, hST]
+    ext i j
+    fin_cases i <;> fin_cases j <;> simp [pow_two, Matrix.mul_apply, Fin.sum_univ_two]
+  have hST3 : (ModularGroup.S * ModularGroup.T : SL(2, ℤ)) ^ 3 = -1 := by
+    ext i j
+    rw [Matrix.SpecialLinearGroup.coe_pow, hST]
+    fin_cases i <;> fin_cases j <;>
+      simp [pow_succ, Matrix.mul_apply, Fin.sum_univ_two]
+  obtain ⟨q, r, hr, rfl⟩ : ∃ q r : ℕ, r < 3 ∧ n = 3 * q + r :=
+    ⟨n / 3, n % 3, Nat.mod_lt _ (by norm_num), (Nat.div_add_mod n 3).symm⟩
+  have hpow : (ModularGroup.S * ModularGroup.T : SL(2, ℤ)) ^ (3 * q + r) =
+      (-1) ^ q * (ModularGroup.S * ModularGroup.T) ^ r := by
+    rw [pow_add, pow_mul, hST3]
+  rw [hpow] at h
+  have h10 := entry_10_eq_zero_of_mem_Gpm N h
+  interval_cases r
+  · exact ⟨q, by ring⟩
+  · exfalso
+    rcases neg_one_pow_eq_or SL(2, ℤ) q with hk | hk
+    · rw [hk, one_mul, pow_one, hST] at h10
+      simp only [Matrix.of_apply, Matrix.cons_val', Matrix.cons_val_zero, Matrix.cons_val_one,
+        Matrix.cons_val_fin_one, Int.cast_one] at h10
+      exact one_ne_zero_zmod hN h10
+    · rw [hk, neg_one_mul, Matrix.SpecialLinearGroup.coe_neg, pow_one, hST] at h10
+      simp only [Matrix.neg_apply, Matrix.of_apply, Matrix.cons_val', Matrix.cons_val_zero,
+        Matrix.cons_val_one, Matrix.cons_val_fin_one, Int.cast_neg, Int.cast_one,
+        neg_eq_zero] at h10
+      exact one_ne_zero_zmod hN h10
+  · exfalso
+    rcases neg_one_pow_eq_or SL(2, ℤ) q with hk | hk
+    · rw [hk, one_mul, hST2] at h10
+      simp only [Matrix.of_apply, Matrix.cons_val', Matrix.cons_val_zero, Matrix.cons_val_one,
+        Matrix.cons_val_fin_one, Int.cast_one] at h10
+      exact one_ne_zero_zmod hN h10
+    · rw [hk, neg_one_mul, Matrix.SpecialLinearGroup.coe_neg, hST2] at h10
+      simp only [Matrix.neg_apply, Matrix.of_apply, Matrix.cons_val', Matrix.cons_val_zero,
+        Matrix.cons_val_one, Matrix.cons_val_fin_one, Int.cast_neg, Int.cast_one,
+        neg_eq_zero] at h10
+      exact one_ne_zero_zmod hN h10
+
+section Orbit
+
+variable {L : Type*} [Field L] [Algebra ℂ L]
+
+def toSemi (E : IntermediateField ℂ L) : (L ≃ₐ[E] L) →* AlgebraicCurve.SemilinearAut ℂ L where
+  toFun g := AlgebraicCurve.SemilinearAut.ofAlgAut (g.restrictScalars ℂ)
+  map_one' := by
+    rw [← map_one AlgebraicCurve.SemilinearAut.ofAlgAut]
+    congr 1
+  map_mul' g h := by
+    rw [← map_mul]
+    congr 1
+
+@[scoped simp]
+theorem toSemi_smul (E : IntermediateField ℂ L) (g : L ≃ₐ[E] L) (x : L) :
+    toSemi E g • x = g x := rfl
+
+theorem toSemi_apply (E : IntermediateField ℂ L) (g : L ≃ₐ[E] L) :
+    toSemi E g = AlgebraicCurve.SemilinearAut.ofAlgAut (g.restrictScalars ℂ) := rfl
+
+theorem orbit_package (t : L) [FiniteDimensional ℂ⟮t⟯ L] [IsGalois ℂ⟮t⟯ L]
+    (hint : ∀ ψ : L →ₐ[ℂ] L, ψ t = t → ψ.toRingHom.IsIntegral)
+    (W : AlgebraicCurve.Place ℂ L) (c : ℂ) (hW : 0 < W.ord (t - algebraMap ℂ L c))
+    (g : L ≃ₐ[ℂ⟮t⟯] L) (hg : AlgebraicCurve.SemilinearAut.ofAlgAut (g.restrictScalars ℂ) • W = W)
+    (m : ℕ) (hm : ∀ n : ℕ, g ^ n = 1 → m ∣ n) :
+    ∃ (T : Finset (AlgebraicCurve.Place ℂ L)) (e : ℕ),
+      (∀ P ∈ T, P.ord (t - algebraMap ℂ L c) = e) ∧ 0 < e ∧ m ∣ e ∧
+        T.card * e = Module.finrank ℂ⟮t⟯ L := by
+  classical
+  let : MulAction (L ≃ₐ[ℂ⟮t⟯] L) (AlgebraicCurve.Place ℂ L) := MulAction.compHom _ (toSemi ℂ⟮t⟯)
+  have hsmul : ∀ (g' : (L ≃ₐ[ℂ⟮t⟯] L)) (P : AlgebraicCurve.Place ℂ L), g' • P = toSemi ℂ⟮t⟯ g' • P
+    :=
+    fun _ _ => rfl
+  have hDH := (AlgebraicCurve.Place.ord_restrictAlong_eq_natCard_algHom_of_isGalois ℂ t t c
+    (AlgHom.id ℂ L) rfl inferInstance inferInstance hint W hW).1
+  set D := MulAction.stabilizer (L ≃ₐ[ℂ⟮t⟯] L) W with hD
+  have hcardD : Nat.card {σ : (L ≃ₐ[ℂ⟮t⟯] L) // AlgebraicCurve.SemilinearAut.ofAlgAut
+    (σ.restrictScalars ℂ) • W = W} =
+      Nat.card D := Nat.card_congr (Equiv.subtypeEquivRight fun σ => by
+        rw [hD, MulAction.mem_stabilizer_iff, hsmul, toSemi_apply])
+  rw [hcardD] at hDH
+  have hfin : (MulAction.orbit (L ≃ₐ[ℂ⟮t⟯] L) W).Finite := Set.finite_range _
+  refine ⟨hfin.toFinset, Nat.card D, ?_, ?_, ?_, ?_⟩
+  · intro P hP
+    rw [Set.Finite.mem_toFinset, MulAction.mem_orbit_iff] at hP
+    obtain ⟨g', rfl⟩ := hP
+    rw [← hDH, hsmul]
+    have hfix : toSemi ℂ⟮t⟯ g' • (t - algebraMap ℂ L c) = t - algebraMap ℂ L c := by
+      rw [toSemi_smul, map_sub]
+      congr 1
+      · exact g'.commutes (⟨t, IntermediateField.mem_adjoin_simple_self ℂ t⟩ : ℂ⟮t⟯)
+      · exact (g'.restrictScalars ℂ).commutes c
+    conv_lhs => rw [← hfix]
+    exact AlgebraicCurve.SemilinearAut.ord_smul _ _ _
+  · have : (0 : ℤ) < Nat.card D := by rw [← hDH]; exact hW
+    exact_mod_cast this
+  · have hgD : g ∈ D := by
+      rw [hD, MulAction.mem_stabilizer_iff, hsmul, toSemi_apply]
+      exact hg
+    exact (hm (orderOf g) (pow_orderOf_eq_one g)).trans (Subgroup.orderOf_dvd_natCard D hgD)
+  · rw [← Set.ncard_eq_toFinset_card (MulAction.orbit (L ≃ₐ[ℂ⟮t⟯] L) W) hfin, ←
+      MulAction.index_stabilizer,
+      Subgroup.index_mul_card, IsGalois.card_aut_eq_finrank]
+
+theorem apply_eq_self_of_mem_adjoin (ψ : L →ₐ[ℂ] L) (t : L) (hψ : ψ t = t) {x : L}
+    (hx : x ∈ ℂ⟮t⟯) : ψ x = x := by
+  let S : IntermediateField ℂ L := (AlgHom.equalizer ψ (AlgHom.id ℂ L)).toIntermediateField
+    (fun y hy => by
+      rw [AlgHom.mem_equalizer] at hy ⊢
+      simp only [AlgHom.coe_id, id_eq] at hy ⊢
+      rw [map_inv₀, hy])
+  have hle : ℂ⟮t⟯ ≤ S := by
+    rw [IntermediateField.adjoin_le_iff, Set.singleton_subset_iff]
+    change t ∈ AlgHom.equalizer ψ (AlgHom.id ℂ L)
+    rw [AlgHom.mem_equalizer]
+    simpa using hψ
+  have := hle hx
+  change x ∈ AlgHom.equalizer ψ (AlgHom.id ℂ L) at this
+  rw [AlgHom.mem_equalizer] at this
+  simpa using this
+
+theorem isIntegral_of_apply_eq (t : L) [FiniteDimensional ℂ⟮t⟯ L] (ψ : L →ₐ[ℂ] L)
+    (hψ : ψ t = t) : ψ.toRingHom.IsIntegral := by
+  intro y
+  have hy : IsIntegral ℂ⟮t⟯ y := IsIntegral.of_finite ℂ⟮t⟯ y
+  refine ⟨(minpoly ℂ⟮t⟯ y).map (algebraMap ℂ⟮t⟯ L), (minpoly.monic hy).map _, ?_⟩
+  rw [Polynomial.eval₂_map]
+  have hcomp : ψ.toRingHom.comp (algebraMap ℂ⟮t⟯ L) = algebraMap ℂ⟮t⟯ L := by
+    ext e
+    exact apply_eq_self_of_mem_adjoin ψ t hψ e.2
+  rw [hcomp]
+  exact minpoly.aeval ℂ⟮t⟯ y
+
+theorem adjoin_inv_eq (t : L) : ℂ⟮t⁻¹⟯ = ℂ⟮t⟯ := by
+  apply le_antisymm
+  · rw [IntermediateField.adjoin_le_iff, Set.singleton_subset_iff]
+    exact IntermediateField.inv_mem _ (IntermediateField.mem_adjoin_simple_self ℂ t)
+  · rw [IntermediateField.adjoin_le_iff, Set.singleton_subset_iff]
+    have := IntermediateField.inv_mem _ (IntermediateField.mem_adjoin_simple_self ℂ t⁻¹)
+    rwa [inv_inv] at this
+
+theorem finiteDimensional_congr {E₁ E₂ : IntermediateField ℂ L} (h : E₁ = E₂)
+    [FiniteDimensional E₁ L] : FiniteDimensional E₂ L := by subst h; assumption
+
+theorem isGalois_congr {E₁ E₂ : IntermediateField ℂ L} (h : E₁ = E₂) [IsGalois E₁ L] :
+    IsGalois E₂ L := by subst h; assumption
+
+theorem finrank_congr {E₁ E₂ : IntermediateField ℂ L} (h : E₁ = E₂) :
+    Module.finrank E₁ L = Module.finrank E₂ L := by subst h; rfl
+
+end Orbit
+
+section Lift
+
+variable {L : Type*} [Field L] [Algebra ℂ L]
+
+def liftE (E' : IntermediateField ℂ L) (φ : L ≃ₐ[ℂ] L) (hφ : ∀ x ∈ E', φ x = x) : L ≃ₐ[E'] L :=
+  { φ.toRingEquiv with commutes' := fun e => hφ e e.2 }
+
+@[scoped simp]
+theorem liftE_apply (E' : IntermediateField ℂ L) (φ : L ≃ₐ[ℂ] L) (hφ : ∀ x ∈ E', φ x = x) (x : L) :
+    liftE E' φ hφ x = φ x := rfl
+
+theorem restrictScalars_liftE (E' : IntermediateField ℂ L) (φ : L ≃ₐ[ℂ] L) (hφ : ∀ x ∈ E', φ x = x)
+    :
+    (liftE E' φ hφ).restrictScalars ℂ = φ :=
+  AlgEquiv.ext fun _ => rfl
+
+def liftHom {Γ : Type*} [Group Γ] (E' : IntermediateField ℂ L) (σ : Γ →* (L ≃ₐ[ℂ] L))
+    (hσ : ∀ (γ : Γ), ∀ x ∈ E', σ γ x = x) : Γ →* (L ≃ₐ[E'] L) where
+  toFun γ := liftE E' (σ γ) (hσ γ)
+  map_one' := by ext x; simp
+  map_mul' γ δ := by ext x; simp
+
+theorem restrictScalars_liftHom {Γ : Type*} [Group Γ] (E' : IntermediateField ℂ L)
+    (σ : Γ →* (L ≃ₐ[ℂ] L)) (hσ : ∀ (γ : Γ), ∀ x ∈ E', σ γ x = x) (γ : Γ) :
+    (liftHom E' σ hσ γ).restrictScalars ℂ = σ γ :=
+  restrictScalars_liftE E' (σ γ) (hσ γ)
+
+theorem liftHom_pow_eq_one_iff {Γ : Type*} [Group Γ] (E' : IntermediateField ℂ L)
+    (σ : Γ →* (L ≃ₐ[ℂ] L)) (hσ : ∀ (γ : Γ), ∀ x ∈ E', σ γ x = x) (γ : Γ) (n : ℕ) :
+    liftHom E' σ hσ γ ^ n = 1 ↔ γ ^ n ∈ σ.ker := by
+  rw [← map_pow, MonoidHom.mem_ker]
+  constructor
+  · intro h
+    have := congrArg (AlgEquiv.restrictScalars ℂ) h
+    rw [restrictScalars_liftHom] at this
+    rw [this]
+    ext x
+    rfl
+  · intro h
+    ext x
+    change σ (γ ^ n) x = x
+    rw [h]
+    rfl
+
+end Lift
+
+section Main
+
+variable (N : ℕ) [NeZero N]
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ring N) K] [IsScalarTower ℂ (ring N) K]
+  [IsFractionRing (ring N) K]
+
+theorem main (hN : 2 ≤ N) :
+    12 * N + N * (Gpm N).index ≤ 12 * N * AlgebraicCurve.genusFF ℂ K + 6 * (Gpm N).index := by
+  classical
+  obtain ⟨hst, σ, hσ, hker, hfix, htr, hfd, hrank, hgal⟩ :=
+    ModularCurve.LevelN.exists_monoidHom_algEquiv_fixedField_eq_adjoin N K
+  set jK : K := algebraMap (ring N) K (jGen N) with hjK
+  have := hfd
+  have := hgal
+  have hσE : ∀ (γ : SL(2, ℤ)), ∀ x ∈ ℂ⟮jK⟯, σ γ x = x := fun γ x hx => by
+    rw [← hfix] at hx
+    exact (IntermediateField.mem_fixedField_iff σ.range x).mp hx (σ γ) ⟨γ, rfl⟩
+  have hEinv : ℂ⟮jK⁻¹⟯ = ℂ⟮jK⟯ := adjoin_inv_eq jK
+  have hσE' : ∀ (γ : SL(2, ℤ)), ∀ x ∈ ℂ⟮jK⁻¹⟯, σ γ x = x := by
+    rw [hEinv]; exact hσE
+  have hfd' : FiniteDimensional ℂ⟮jK⁻¹⟯ K := finiteDimensional_congr hEinv.symm
+  have hgal' : IsGalois ℂ⟮jK⁻¹⟯ K := isGalois_congr hEinv.symm
+  have hrank' : Module.finrank ℂ⟮jK⁻¹⟯ K = (Gpm N).index := by
+    rw [finrank_congr hEinv]; exact hrank
+  have hint : ∀ ψ : K →ₐ[ℂ] K, ψ jK = jK → ψ.toRingHom.IsIntegral :=
+    fun ψ hψ => isIntegral_of_apply_eq jK ψ hψ
+  have hint' : ∀ ψ : K →ₐ[ℂ] K, ψ jK⁻¹ = jK⁻¹ → ψ.toRingHom.IsIntegral := fun ψ hψ => by
+    apply isIntegral_of_apply_eq jK ψ
+    rw [map_inv₀] at hψ
+    exact inv_injective hψ
+  obtain ⟨W₀, hW₀, hW₀fix⟩ := ModularCurve.LevelN.exists_place_ord_sub_pos_forall_smul_eq N K rho
+  obtain ⟨W₁, hW₁, hW₁fix⟩ :=
+    ModularCurve.LevelN.exists_place_ord_sub_pos_forall_smul_eq N K UpperHalfPlane.I
+  obtain ⟨W₂, hW₂, hW₂fix⟩ :=
+    ModularCurve.LevelN.exists_place_ord_neg_forall_smul_eq N K (hst ModularGroup.T⁻¹)
+  rw [jAnalytic_rho] at hW₀
+  rw [jAnalytic_I] at hW₁
+  change 0 < W₀.ord (jK - algebraMap ℂ K 0) at hW₀
+  change 0 < W₁.ord (jK - algebraMap ℂ K 1728) at hW₁
+  change W₂.ord jK < 0 at hW₂
+  have hjK0 : jK ≠ 0 := by
+    intro h; rw [h, AlgebraicCurve.Place.ord_zero] at hW₂; exact lt_irrefl _ hW₂
+  have hW₂' : 0 < W₂.ord (jK⁻¹ - algebraMap ℂ K 0) := by
+    rw [map_zero, sub_zero, AlgebraicCurve.Place.ord_inv]; omega
+  set g₀ := liftHom ℂ⟮jK⟯ σ hσE (ModularGroup.S * ModularGroup.T) with hg₀
+  set g₁ := liftHom ℂ⟮jK⟯ σ hσE ModularGroup.S with hg₁
+  set g₂ := liftHom ℂ⟮jK⁻¹⟯ σ hσE' ModularGroup.T with hg₂
+  have hg₀W : AlgebraicCurve.SemilinearAut.ofAlgAut (g₀.restrictScalars ℂ) • W₀ = W₀ := by
+    rw [hg₀, restrictScalars_liftHom]
+    exact hW₀fix (ModularGroup.S * ModularGroup.T) ST_smul_rho (hst _) (σ _) (hσ _)
+  have hg₁W : AlgebraicCurve.SemilinearAut.ofAlgAut (g₁.restrictScalars ℂ) • W₁ = W₁ := by
+    rw [hg₁, restrictScalars_liftHom]
+    exact hW₁fix ModularGroup.S S_smul_I (hst _) (σ _) (hσ _)
+  have hg₂W : AlgebraicCurve.SemilinearAut.ofAlgAut (g₂.restrictScalars ℂ) • W₂ = W₂ := by
+    rw [hg₂, restrictScalars_liftHom]
+    exact hW₂fix (σ _) (hσ _)
+  have hm₀ : ∀ n : ℕ, g₀ ^ n = 1 → 3 ∣ n := fun n hn => by
+    rw [hg₀, liftHom_pow_eq_one_iff, hker] at hn
+    exact dvd_of_ST_pow_mem hN hn
+  have hm₁ : ∀ n : ℕ, g₁ ^ n = 1 → 2 ∣ n := fun n hn => by
+    rw [hg₁, liftHom_pow_eq_one_iff, hker] at hn
+    exact dvd_of_S_pow_mem hN hn
+  have hm₂ : ∀ n : ℕ, g₂ ^ n = 1 → N ∣ n := fun n hn => by
+    rw [hg₂, liftHom_pow_eq_one_iff, hker] at hn
+    exact dvd_of_T_pow_mem N hn
+  obtain ⟨T₀, e₀, hT₀, he₀, hm₀e, hc₀⟩ := orbit_package jK hint W₀ 0 hW₀ g₀ hg₀W 3 hm₀
+  obtain ⟨T₁, e₁, hT₁, he₁, hm₁e, hc₁⟩ := orbit_package jK hint W₁ 1728 hW₁ g₁ hg₁W 2 hm₁
+  obtain ⟨T₂, e₂, hT₂, he₂, hm₂e, hc₂⟩ := orbit_package jK⁻¹ hint' W₂ 0 hW₂' g₂ hg₂W N hm₂
+  rw [hrank] at hc₀ hc₁
+  rw [hrank'] at hc₂
+  have hdisj : Disjoint T₀ T₁ := by
+    rw [Finset.disjoint_left]
+    intro P hP0 hP1
+    have h0 := hT₀ P hP0
+    have h1 := hT₁ P hP1
+    rw [map_zero, sub_zero] at h0
+    set y := jK - algebraMap ℂ K 1728 with hy
+    have hy0 : y ≠ 0 := by
+      intro h; rw [h, AlgebraicCurve.Place.ord_zero] at h1; omega
+    have hny : -y ≠ 0 := neg_ne_zero.mpr hy0
+    have hsum : jK + -y = algebraMap ℂ K 1728 := by rw [hy]; ring
+    have hne : jK + -y ≠ 0 := by
+      rw [hsum]; exact (map_ne_zero _).mpr (by norm_num)
+    have hle := AlgebraicCurve.Place.min_ord_le_ord_add P hjK0 hny hne
+    rw [hsum, AlgebraicCurve.Place.ord_algebraMap] at hle
+    have hneg : P.ord (-y) = P.ord y := by
+      rw [show -y = y * algebraMap ℂ K (-1) by rw [map_neg, map_one]; ring,
+        P.ord_mul hy0 (by rw [map_neg, map_one]; exact neg_ne_zero.mpr one_ne_zero),
+        AlgebraicCurve.Place.ord_algebraMap, add_zero]
+    rw [hneg, h0, h1] at hle
+    have : (0 : ℤ) < min (e₀ : ℤ) (e₁ : ℤ) := lt_min (by exact_mod_cast he₀) (by exact_mod_cast he₁)
+    omega
+  have hH := AlgebraicCurve.sum_ord_sub_one_le_two_mul_genusFF_of_isSeparable ℂ jK htr hfd
+    inferInstance (T₀ ∪ T₁) (fun P => if P ∈ T₀ then 0 else 1728)
+    (fun P hP => by
+      rcases Finset.mem_union.mp hP with h | h
+      · simp only [h, ite_true]; rw [hT₀ P h]; exact_mod_cast he₀
+      · have h' : P ∉ T₀ := fun h' => Finset.disjoint_left.mp hdisj h' h
+        simp only [h', ite_false]; rw [hT₁ P h]; exact_mod_cast he₁)
+    T₂ (fun P hP => by
+      have := hT₂ P hP
+      rw [map_zero, sub_zero, AlgebraicCurve.Place.ord_inv] at this
+      omega)
+  rw [Finset.sum_union hdisj, hrank] at hH
+  have hs₀ : ∑ P ∈ T₀, (P.ord (jK - algebraMap ℂ K (if P ∈ T₀ then 0 else 1728)) - 1) =
+      T₀.card • ((e₀ : ℤ) - 1) := by
+    rw [← Finset.sum_const]
+    apply Finset.sum_congr rfl
+    intro P hP
+    simp only [hP, ite_true]
+    rw [hT₀ P hP]
+  have hs₁ : ∑ P ∈ T₁, (P.ord (jK - algebraMap ℂ K (if P ∈ T₀ then 0 else 1728)) - 1) =
+      T₁.card • ((e₁ : ℤ) - 1) := by
+    rw [← Finset.sum_const]
+    apply Finset.sum_congr rfl
+    intro P hP
+    have h' : P ∉ T₀ := fun h' => Finset.disjoint_left.mp hdisj h' hP
+    simp only [h', ite_false]
+    rw [hT₁ P hP]
+  have hs₂ : ∑ P ∈ T₂, (-P.ord jK - 1) = T₂.card • ((e₂ : ℤ) - 1) := by
+    rw [← Finset.sum_const]
+    apply Finset.sum_congr rfl
+    intro P hP
+    have := hT₂ P hP
+    rw [map_zero, sub_zero, AlgebraicCurve.Place.ord_inv] at this
+    omega
+  rw [hs₀, hs₁, hs₂] at hH
+  simp only [nsmul_eq_mul] at hH
+  obtain ⟨k₀, hk₀⟩ := hm₀e
+  obtain ⟨k₁, hk₁⟩ := hm₁e
+  obtain ⟨k₂, hk₂⟩ := hm₂e
+  have hk₀p : 1 ≤ k₀ := Nat.pos_of_ne_zero fun h => by rw [h, mul_zero] at hk₀; omega
+  have hk₁p : 1 ≤ k₁ := Nat.pos_of_ne_zero fun h => by rw [h, mul_zero] at hk₁; omega
+  have hk₂p : 1 ≤ k₂ := Nat.pos_of_ne_zero fun h => by rw [h, mul_zero] at hk₂; omega
+  have hr₀ : 3 * T₀.card ≤ (Gpm N).index := by
+    calc 3 * T₀.card ≤ 3 * T₀.card * k₀ := Nat.le_mul_of_pos_right _ hk₀p
+      _ = (Gpm N).index := by rw [← hc₀, hk₀]; ring
+  have hr₁ : 2 * T₁.card ≤ (Gpm N).index := by
+    calc 2 * T₁.card ≤ 2 * T₁.card * k₁ := Nat.le_mul_of_pos_right _ hk₁p
+      _ = (Gpm N).index := by rw [← hc₁, hk₁]; ring
+  have hr₂ : N * T₂.card ≤ (Gpm N).index := by
+    calc N * T₂.card ≤ N * T₂.card * k₂ := Nat.le_mul_of_pos_right _ hk₂p
+      _ = (Gpm N).index := by rw [← hc₂, hk₂]; ring
+  have hc₀' : (T₀.card : ℤ) * e₀ = (Gpm N).index := by exact_mod_cast hc₀
+  have hc₁' : (T₁.card : ℤ) * e₁ = (Gpm N).index := by exact_mod_cast hc₁
+  have hc₂' : (T₂.card : ℤ) * e₂ = (Gpm N).index := by exact_mod_cast hc₂
+  have hr₀' : 3 * (T₀.card : ℤ) ≤ (Gpm N).index := by exact_mod_cast hr₀
+  have hr₁' : 2 * (T₁.card : ℤ) ≤ (Gpm N).index := by exact_mod_cast hr₁
+  have hr₂' : (N : ℤ) * (T₂.card : ℤ) ≤ (Gpm N).index := by exact_mod_cast hr₂
+  have hN0 : (0 : ℤ) ≤ N := by positivity
+  simp only [mul_sub, mul_one] at hH
+  rw [hc₀', hc₁', hc₂'] at hH
+  have h1 : ((Gpm N).index : ℤ) + 2 ≤
+      2 * (AlgebraicCurve.genusFF ℂ K : ℤ) + T₀.card + T₁.card + T₂.card := by linarith
+  have hA := mul_le_mul_of_nonneg_left h1 hN0
+  have hB := mul_le_mul_of_nonneg_left hr₀' (show (0 : ℤ) ≤ 2 * N by positivity)
+  have hC := mul_le_mul_of_nonneg_left hr₁' (show (0 : ℤ) ≤ 3 * N by positivity)
+  have key : (12 : ℤ) * N + N * (Gpm N).index ≤
+      12 * N * (AlgebraicCurve.genusFF ℂ K : ℤ) + 6 * (Gpm N).index := by
+    linear_combination 6 * hA + hB + hC + 6 * hr₂'
+  exact_mod_cast key
+
+end Main
+
+end ModularCurve.LevelN.GenusBound
+
+open _root_.ModularCurve.LevelN
+  _root_.P2MW.S_ModularCurve_LevelN_twelve_mul_add_mul_index_le_genusFF.ModularCurve.LevelN
+  ModularCurve.LevelN.GenusBound in
+theorem solution (N : ℕ) [NeZero N] (hN : 2 ≤ N)
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring N) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring N) K]
+    [IsFractionRing (ModularCurve.LevelN.ring N) K] :
+    12 * N + N * (CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index ≤
+      12 * N * AlgebraicCurve.genusFF ℂ K +
+        6 * (CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index :=
+  main N K hN
+
+end
+end S_ModularCurve_LevelN_twelve_mul_add_mul_index_le_genusFF
+end P2MW
+export P2MW.S_ModularCurve_LevelN_twelve_mul_add_mul_index_le_genusFF (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.LevelN.twelve_mul_add_mul_index_le_genusFF (N : ℕ) [NeZero N] (hN : 2 ≤ N)
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring N) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring N) K]
+    [IsFractionRing (ModularCurve.LevelN.ring N) K] :
+    12 * N + N * (CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index ≤
+      12 * N * AlgebraicCurve.genusFF ℂ K +
+        6 * (CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index :=
+  solution N hN K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_valuation_apply_smul_le_one_of_tendsto_div_smul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_valuation_apply_smul_le_one_of_tendsto_div_smul.lean
new file mode 100644
index 0000000000..0e0c99a41d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_LevelN_valuation_apply_smul_le_one_of_tendsto_div_smul.lean
@@ -0,0 +1,948 @@
+/-
+Based on Prove2Me node ModularCurve.LevelN.valuation_apply_smul_le_one_of_tendsto_div_smul
+(4f16a8a0-3d21-586e-89f5-b1dda8087576) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission bde924d6-51e1-5e64-99c4-7c7e87058e72
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LevelNFunctionField
+
+import Mathlib.Data.Int.Star
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_modularity_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_orbit_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelN_structure_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Valuation bound for E(σ_γ z) under a non-zero limit
+
+Theorem statement: `ModularCurve.LevelN.valuation_apply_smul_le_one_of_tendsto_div_smul`
+(`4f16a8a0-3d21-586e-89f5-b1dda8087576`), by Claude, 2026-09-05.
+
+Proof: submission `bde924d6-51e1-5e64-99c4-7c7e87058e72`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $M \ge 1$ and let $A_M =$ [`ModularCurve.LevelN.ring
+M`](def/ModularCurve_LevelNFunctionField.html#L28) be the $\mathbb{C}$-subalgebra of functions
+$\mathcal{H} \to \mathbb{C}$ generated by $j = E_4^3/\Delta$ together with the functions `fricke M
+v` for the non-zero $v \in (\mathbb{Z}/M)^2$. Let $K$ be a field that is a $\mathbb{C}$-algebra and
+an $A_M$-algebra compatibly, and a fraction field of $A_M$. Assume $A_M$ is stable under right
+translation, i.e. $F \circ \gamma \in A_M$ for all $\gamma \in \mathrm{SL}_2(\mathbb{Z})$ and $F \in
+A_M$; let $\sigma \colon \mathrm{SL}_2(\mathbb{Z}) \to \mathrm{Aut}_{\mathbb{C}}(K)$ be a monoid
+homomorphism acting on $A_M$ by $\sigma_\gamma(F) = F \circ \gamma^{-1}$, and let $E \colon K \to
+\mathbb{C}((q))$ be a $\mathbb{C}$-algebra map with $E(j)$ equal to the image under $q \mapsto
+q_M^{M}$ (exponents multiplied by $M$) of $q^{-1}$ times the power series $\mathrm{eisenstein4}^3
+\cdot \mathrm{dedekindEtaUnitInv}$ over $\mathbb{C}$, and with $E(F) \cdot \widetilde{\Delta}^m$
+equal to the level-$M$ $q$-expansion of $F\Delta^m$ whenever $F \in A_M$, $m \in \mathbb{N}$ and $F
+\Delta^m$ is bounded at $i\infty$, where $\widetilde{\Delta}$ is the level-$M$ $q$-expansion of
+$\Delta$. Let $\Gamma \le \mathrm{SL}_2(\mathbb{Z})$ be of finite index with $\Gamma(M) \le \Gamma$
+and $T \in \Gamma$, let $g, h$ be modular forms of weight $k \in \mathbb{Z}$ for $\Gamma$ with $h
+\neq 0$, and let $z \in K$ satisfy $E(z) \cdot \tilde{h}(q_M^M) = \tilde{g}(q_M^M)$, where
+$\tilde{g}, \tilde{h}$ are the level-$1$ $q$-expansions of $g, h$. Then for $\gamma \in
+\mathrm{SL}_2(\mathbb{Z})$ and $L \neq 0$ such that $g(\gamma^{-1}\tau)/h(\gamma^{-1}\tau) \to L$ as
+$\operatorname{Im}\tau \to \infty$, the Laurent series $E(\sigma_\gamma z)$ has valuation at most
+$1$, i.e. non-negative order in $\mathbb{C}((q_M))$.
+
+This is the analytic input, cusp by cusp, to the statement that a quotient $g/h$ of modular forms
+with finite non-zero limit at the cusp $\gamma^{-1}(i\infty)$ has no pole there: the element of the
+function field $K$ realising $g/h$ has $q$-expansion without polar terms after applying
+$\sigma_\gamma$. It is used by
+[`ModularCurve.ord_eq_zero_of_not_mem_of_realizeOf_tendsto`]
+(thm.html#ModularCurve.ord_eq_zero_of_not_mem_of_realizeOf_tendsto).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_LevelN_valuation_apply_smul_le_one_of_tendsto_div_smul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_LevelN_valuation_apply_smul_le_one_of_tendsto_div_smul
+
+
+open UpperHalfPlane Filter Topology Function
+open scoped MatrixGroups Manifold Real
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "LevelN.ring LevelN.jGen jqModC qExpand qExpand_coeff_mul \
+  qExpand_coeff_of_not_dvd ofPowerSeries_coeff_of_neg jGen"
+namespace LevelN
+p2m_export "ModularCurve.LevelN" "wp fricke jAnalytic generators ring jGen"
+namespace CuspExpChi
+p2m_open "ModularCurve.LevelN ModularCurve"
+
+section Toolkit
+
+variable {h : ℝ}
+
+structure Good (h : ℝ) (G : ℍ → ℂ) : Prop where
+  periodic : Periodic (G ∘ ofComplex) h
+  mdiff : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G
+  bdd : IsBoundedAtImInfty G
+
+namespace Good
+
+variable {G G₁ G₂ : ℍ → ℂ}
+
+theorem analyticAt (hG : Good h G) (hh : 0 < h) : AnalyticAt ℂ (cuspFunction h G) 0 :=
+  analyticAt_cuspFunction_zero hh hG.periodic hG.mdiff hG.bdd
+
+theorem continuousAt (hG : Good h G) (hh : 0 < h) : ContinuousAt (cuspFunction h G) 0 :=
+  (hG.analyticAt hh).continuousAt
+
+theorem mul (h₁ : Good h G₁) (h₂ : Good h G₂) : Good h (G₁ * G₂) where
+  periodic := by
+    have : (G₁ * G₂) ∘ ofComplex = (G₁ ∘ ofComplex) * (G₂ ∘ ofComplex) := rfl
+    rw [this]
+    exact h₁.periodic.mul h₂.periodic
+  mdiff := h₁.mdiff.mul h₂.mdiff
+  bdd := h₁.bdd.mul h₂.bdd
+
+theorem add (h₁ : Good h G₁) (h₂ : Good h G₂) : Good h (G₁ + G₂) where
+  periodic := by
+    have : (G₁ + G₂) ∘ ofComplex = (G₁ ∘ ofComplex) + (G₂ ∘ ofComplex) := rfl
+    rw [this]
+    exact h₁.periodic.add h₂.periodic
+  mdiff := h₁.mdiff.add h₂.mdiff
+  bdd := h₁.bdd.add h₂.bdd
+
+theorem const (h : ℝ) (c : ℂ) : Good h (fun _ : ℍ => c) where
+  periodic := fun _ => rfl
+  mdiff := mdifferentiable_const
+  bdd := Filter.const_boundedAtFilter _ _
+
+theorem one (h : ℝ) : Good h (1 : ℍ → ℂ) := const h 1
+
+theorem pow (hG : Good h G) : ∀ n : ℕ, Good h (G ^ n)
+  | 0 => by rw [pow_zero]; exact one h
+  | n + 1 => by rw [pow_succ]; exact (pow hG n).mul hG
+
+end Good
+
+variable {G G₁ G₂ : ℍ → ℂ}
+
+theorem cuspFunction_mul_of_good (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) :
+    cuspFunction h (G₁ * G₂) = cuspFunction h G₁ * cuspFunction h G₂ :=
+  cuspFunction_mul (h₁.continuousAt hh) (h₂.continuousAt hh)
+
+theorem cuspFunction_add_of_good (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) :
+    cuspFunction h (G₁ + G₂) = cuspFunction h G₁ + cuspFunction h G₂ :=
+  cuspFunction_add (h₁.continuousAt hh) (h₂.continuousAt hh)
+
+theorem qExpansion_mul_of_good (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) :
+    qExpansion h (G₁ * G₂) = qExpansion h G₁ * qExpansion h G₂ :=
+  qExpansion_mul (h₁.analyticAt hh) (h₂.analyticAt hh)
+
+theorem qExpansion_add_of_good (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) :
+    qExpansion h (G₁ + G₂) = qExpansion h G₁ + qExpansion h G₂ :=
+  qExpansion_add (h₁.analyticAt hh) (h₂.analyticAt hh)
+
+theorem qExpansion_pow_of_good (hh : 0 < h) (hG : Good h G) :
+    ∀ n : ℕ, qExpansion h (G ^ n) = qExpansion h G ^ n
+  | 0 => by rw [pow_zero, pow_zero, qExpansion_one]
+  | n + 1 => by rw [pow_succ, pow_succ, qExpansion_mul_of_good hh (hG.pow n) hG,
+      qExpansion_pow_of_good hh hG n]
+
+theorem qExpansion_const (hh : 0 < h) (c : ℂ) :
+    qExpansion h (fun _ : ℍ => c) = PowerSeries.C c := by
+  have h1 : (fun _ : ℍ => c) = c • (1 : ℍ → ℂ) := by funext τ; simp
+  rw [h1, qExpansion_smul ((Good.one h).analyticAt hh), qExpansion_one, Algebra.smul_def, mul_one]
+  simp
+
+theorem Good.eq_zero_of_qExpansion_eq_zero (hG : Good h G) (hh : 0 < h) (h0 : qExpansion h G = 0) :
+    G = 0 :=
+  (qExpansion_eq_zero_iff hh hG.periodic hG.mdiff hG.bdd).mp h0
+
+def Q (h : ℝ) (G : ℍ → ℂ) : LaurentSeries ℂ := HahnSeries.ofPowerSeries ℤ ℂ (qExpansion h G)
+
+theorem Q_mul (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) : Q h (G₁ * G₂) = Q h G₁ * Q h G₂ := by
+  simp only [Q, qExpansion_mul_of_good hh h₁ h₂, map_mul]
+
+theorem Q_add (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) : Q h (G₁ + G₂) = Q h G₁ + Q h G₂ := by
+  simp only [Q, qExpansion_add_of_good hh h₁ h₂, map_add]
+
+theorem Q_pow (hh : 0 < h) (hG : Good h G) (n : ℕ) : Q h (G ^ n) = Q h G ^ n := by
+  simp only [Q, qExpansion_pow_of_good hh hG n, map_pow]
+
+theorem Q_one (h : ℝ) : Q h (1 : ℍ → ℂ) = 1 := by
+  simp only [Q, qExpansion_one, map_one]
+
+theorem Q_const (hh : 0 < h) (c : ℂ) : Q h (fun _ : ℍ => c) = HahnSeries.C c := by
+  simp only [Q, qExpansion_const hh c, HahnSeries.ofPowerSeries_C]
+
+theorem Q_eq_zero_iff (hh : 0 < h) (hG : Good h G) : Q h G = 0 ↔ G = 0 := by
+  constructor
+  · intro h0
+    apply hG.eq_zero_of_qExpansion_eq_zero hh
+    have : Function.Injective (HahnSeries.ofPowerSeries ℤ ℂ) := HahnSeries.ofPowerSeries_injective
+    exact this (by rw [map_zero]; exact h0)
+  · rintro rfl
+    simp only [Q, qExpansion_zero, map_zero]
+
+end Toolkit
+
+section LevelOne
+
+local notation "Δ" => ModularForm.discriminant
+
+theorem natCast_mem_strictPeriods (N : ℕ) : (N : ℝ) ∈ (𝒮ℒ).strictPeriods := by
+  simp only [Subgroup.strictPeriods_SL2Z]
+  exact ⟨N, by simp⟩
+
+theorem good_discriminant (N : ℕ) : Good N Δ where
+  periodic := by
+    have := SlashInvariantFormClass.periodic_comp_ofComplex CuspForm.discriminant
+      (natCast_mem_strictPeriods N)
+    simpa using this
+  mdiff := CuspForm.discriminant.holo'
+  bdd := ModularForm.discriminant_isZeroAtImInfty.isBoundedAtImInfty
+
+theorem good_E₄ (N : ℕ) : Good N (ModularForm.E₄ : ℍ → ℂ) where
+  periodic := SlashInvariantFormClass.periodic_comp_ofComplex ModularForm.E₄
+      (natCast_mem_strictPeriods N)
+  mdiff := ModularForm.E₄.holo'
+  bdd := ModularFormClass.bdd_at_infty ModularForm.E₄
+
+theorem discriminant_ne_zero' : (Δ : ℍ → ℂ) ≠ 0 := by
+  intro h0
+  have := congrFun h0 UpperHalfPlane.I
+  exact ModularForm.discriminant_ne_zero _ this
+
+theorem discriminant_pow_ne_zero (m : ℕ) : ((Δ : ℍ → ℂ) ^ m) ≠ 0 := by
+  intro h0
+  have := congrFun h0 UpperHalfPlane.I
+  simp only [Pi.pow_apply, Pi.zero_apply, pow_eq_zero_iff', ne_eq] at this
+  exact ModularForm.discriminant_ne_zero _ this.1
+
+theorem mul_discriminant_pow_eq_zero_iff (F : ℍ → ℂ) (m : ℕ) :
+    F * (Δ : ℍ → ℂ) ^ m = 0 ↔ F = 0 := by
+  constructor
+  · intro h0
+    funext τ
+    have := congrFun h0 τ
+    simp only [Pi.mul_apply, Pi.pow_apply, Pi.zero_apply, mul_eq_zero, pow_eq_zero_iff',
+      ne_eq] at this
+    rcases this with h1 | ⟨h1, _⟩
+    · exact h1
+    · exact absurd h1 (ModularForm.discriminant_ne_zero τ)
+  · rintro rfl
+    exact zero_mul _
+
+theorem Q_discriminant_ne_zero (N : ℕ) [NeZero N] : Q N (Δ : ℍ → ℂ) ≠ 0 := by
+  have hN : (0 : ℝ) < N := Nat.cast_pos.mpr (NeZero.pos N)
+  rw [ne_eq, Q_eq_zero_iff hN (good_discriminant N)]
+  exact discriminant_ne_zero'
+
+end LevelOne
+
+section Ring
+
+local notation "Δ" => ModularForm.discriminant
+
+variable (N : ℕ) [NeZero N]
+
+theorem mdifferentiable_of_mem {F : ℍ → ℂ} (hF : F ∈ ring N) : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F := by
+  have h := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact h.2.2.2.2.1 F hF
+
+theorem eq_zero_or_eq_zero_of_mul_eq_zero {a b : ℍ → ℂ} (ha : a ∈ ring N) (hb : b ∈ ring N)
+    (hab : a * b = 0) : a = 0 ∨ b = 0 := by
+  have h := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact h.2.2.2.2.2 a b ha hb hab
+
+abbrev redMat (γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) (ZMod N) :=
+  (γ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N)
+
+theorem fricke_smul_of_mem (v : Fin 2 → ZMod N) {γ : SL(2, ℤ)}
+    (hγ : γ ∈ CongruenceSubgroup.Gamma N) (τ : ℍ) : fricke N v (γ • τ) = fricke N v τ :=
+  (WLight.frickeFunction_modularity_package N PeriodPair.ofTau (fun _ => ⟨rfl, rfl⟩)).2.2.2.2.2.2.1
+    v γ hγ τ
+
+omit [NeZero N] in
+theorem jAnalytic_smul (γ : SL(2, ℤ)) (τ : ℍ) : jAnalytic (γ • τ) = jAnalytic τ := by
+  have hmem : (γ : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ, rfl⟩
+  have h4 : (ModularForm.E₄ : ℍ → ℂ) ((γ : GL (Fin 2) ℝ) • τ) =
+      denom (γ : GL (Fin 2) ℝ) τ ^ (4 : ℤ) * ModularForm.E₄ τ :=
+    SlashInvariantForm.slash_action_eqn'' _ hmem τ
+  have h12 : ModularForm.discriminant ((γ : GL (Fin 2) ℝ) • τ) =
+      denom (γ : GL (Fin 2) ℝ) τ ^ (12 : ℤ) * ModularForm.discriminant τ := by
+    have := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hmem τ
+    simpa using this
+  have hd : denom (γ : GL (Fin 2) ℝ) τ ≠ 0 := denom_ne_zero _ _
+  have hΔ : ModularForm.discriminant τ ≠ 0 := ModularForm.discriminant_ne_zero τ
+  rw [jAnalytic, jAnalytic, ModularGroup.sl_moeb, h4, h12]
+  field_simp
+
+def precomp (g : SL(2, ℤ)) : (ℍ → ℂ) →ₐ[ℂ] (ℍ → ℂ) :=
+  AlgHom.pi (fun τ => Pi.evalAlgHom ℂ (fun _ : ℍ => ℂ) (g • τ))
+
+omit [NeZero N] in
+@[scoped simp]
+theorem precomp_apply (g : SL(2, ℤ)) (F : ℍ → ℂ) (τ : ℍ) : precomp g F τ = F (g • τ) := rfl
+
+theorem smul_eq_self_of_mem {F : ℍ → ℂ} (hF : F ∈ ring N) {γ : SL(2, ℤ)}
+    (hγ : γ ∈ CongruenceSubgroup.Gamma N) (τ : ℍ) : F (γ • τ) = F τ := by
+  suffices h : ring N ≤ AlgHom.equalizer (precomp γ) (AlgHom.id ℂ (ℍ → ℂ)) by
+    have := h hF
+    rw [AlgHom.mem_equalizer] at this
+    exact congrFun this τ
+  rw [ring, Algebra.adjoin_le_iff]
+  intro G hG
+  rw [SetLike.mem_coe, AlgHom.mem_equalizer]
+  funext τ'
+  rcases hG with rfl | ⟨v, hv, rfl⟩
+  · exact jAnalytic_smul γ τ'
+  · exact fricke_smul_of_mem N v hγ τ'
+
+omit [NeZero N] in
+theorem T_pow_mem_Gamma : ModularGroup.T ^ N ∈ CongruenceSubgroup.Gamma N := by
+  rw [CongruenceSubgroup.Gamma_mem, ← zpow_natCast, ModularGroup.coe_T_zpow]
+  simp
+
+theorem periodic_of_mem {F : ℍ → ℂ} (hF : F ∈ ring N) : Periodic (F ∘ ofComplex) N := by
+  intro w
+  by_cases hw : 0 < w.im
+  · have hw' : 0 < (w + N).im := by simpa using hw
+    simp only [Function.comp_apply, ofComplex_apply_of_im_pos hw, ofComplex_apply_of_im_pos hw']
+    have hT : ModularGroup.T ^ N • (⟨w, hw⟩ : ℍ) = ⟨w + N, hw'⟩ := by
+      rw [← zpow_natCast, modular_T_zpow_smul]
+      ext1
+      simp [add_comm]
+    rw [← hT, smul_eq_self_of_mem N hF (T_pow_mem_Gamma N)]
+  · push Not at hw
+    have hw' : (w + N).im ≤ 0 := by simpa using hw
+    simp only [Function.comp_apply, ofComplex_apply_of_im_nonpos hw,
+      ofComplex_apply_of_im_nonpos hw']
+
+theorem exists_isBoundedAtImInfty_mul_pow {F : ℍ → ℂ} (hF : F ∈ ring N) :
+    ∃ m : ℕ, IsBoundedAtImInfty (F * (Δ : ℍ → ℂ) ^ m) := by
+  have hpkg := WLight.frickeFunction_orbit_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  have hΔb : ∀ k : ℕ, IsBoundedAtImInfty ((Δ : ℍ → ℂ) ^ k) := fun k =>
+    ((good_discriminant N).pow k).bdd
+  induction hF using Algebra.adjoin_induction with
+  | mem G hG =>
+    rcases hG with rfl | ⟨v, hv, rfl⟩
+    · exact hpkg.1.2
+    · exact (hpkg.2.1 v hv).2
+  | algebraMap c =>
+    refine ⟨0, ?_⟩
+    rw [pow_zero, mul_one]
+    exact Filter.const_boundedAtFilter _ _
+  | add F G _ _ ihF ihG =>
+    obtain ⟨m, hm⟩ := ihF
+    obtain ⟨n, hn⟩ := ihG
+    refine ⟨m + n, ?_⟩
+    have : (F + G) * (Δ : ℍ → ℂ) ^ (m + n) =
+        F * (Δ : ℍ → ℂ) ^ m * (Δ : ℍ → ℂ) ^ n + G * (Δ : ℍ → ℂ) ^ n * (Δ : ℍ → ℂ) ^ m := by ring
+    rw [this]
+    exact (hm.mul (hΔb n)).add (hn.mul (hΔb m))
+  | mul F G _ _ ihF ihG =>
+    obtain ⟨m, hm⟩ := ihF
+    obtain ⟨n, hn⟩ := ihG
+    refine ⟨m + n, ?_⟩
+    have : (F * G) * (Δ : ℍ → ℂ) ^ (m + n) = (F * (Δ : ℍ → ℂ) ^ m) * (G * (Δ : ℍ → ℂ) ^ n) := by
+      ring
+    rw [this]
+    exact hm.mul hn
+
+end Ring
+
+section Expansion
+
+local notation "Δ" => ModularForm.discriminant
+
+variable (N : ℕ) [NeZero N]
+
+theorem castN_pos : (0 : ℝ) < N := Nat.cast_pos.mpr (NeZero.pos N)
+
+def PB (F : ℍ → ℂ) (m : ℕ) : Prop := IsBoundedAtImInfty (F * (Δ : ℍ → ℂ) ^ m)
+
+theorem PB.add_right {F : ℍ → ℂ} {m : ℕ} (hm : PB F m) (k : ℕ) : PB F (m + k) := by
+  unfold PB at hm ⊢
+  rw [pow_add, ← mul_assoc]
+  exact hm.mul ((good_discriminant 1).pow k).bdd
+
+theorem good_of_PB {F : ℍ → ℂ} (hF : F ∈ ring N) {m : ℕ} (hm : PB F m) :
+    Good N (F * (Δ : ℍ → ℂ) ^ m) where
+  periodic := by
+    have : (F * (Δ : ℍ → ℂ) ^ m) ∘ ofComplex = (F ∘ ofComplex) * (((Δ : ℍ → ℂ) ^ m) ∘ ofComplex) :=
+      rfl
+    rw [this]
+    exact (periodic_of_mem N hF).mul ((good_discriminant N).pow m).periodic
+  mdiff := (mdifferentiable_of_mem N hF).mul ((good_discriminant N).pow m).mdiff
+  bdd := hm
+
+end Expansion
+
+section Width
+
+variable (N : ℕ) [NeZero N]
+
+theorem qParam_pow_mul (τ : ℍ) (n : ℕ) :
+    Periodic.qParam (N : ℝ) (τ : ℂ) ^ (N * n) = Periodic.qParam 1 (τ : ℂ) ^ n := by
+  have hN : (N : ℂ) ≠ 0 := by exact_mod_cast NeZero.ne N
+  rw [pow_mul]
+  congr 1
+  rw [Periodic.qParam, Periodic.qParam, ← Complex.exp_nat_mul]
+  congr 1
+  push_cast
+  field_simp
+
+theorem Q_natCast_eq_qExpand {f : ℍ → ℂ} (hf : Good 1 f) :
+    Q N f = ModularCurve.qExpand ℂ N (Q 1 f) := by
+  have hNpos : (0 : ℝ) < N := Nat.cast_pos.mpr (NeZero.pos N)
+  have hN0 : (N : ℕ) ≠ 0 := NeZero.ne N
+  set a : ℕ → ℂ := fun m => (qExpansion 1 f).coeff m with ha
+  have hsum1 : ∀ τ : ℍ, HasSum (fun m => a m • Periodic.qParam 1 (τ : ℂ) ^ m) (f τ) :=
+    fun τ => hasSum_qExpansion one_pos hf.periodic hf.mdiff hf.bdd τ
+  have hinj : Function.Injective (fun n : ℕ => N * n) := mul_right_injective₀ hN0
+  set c : ℕ → ℂ := Function.extend (fun n : ℕ => N * n) a 0 with hc
+  have hc_apply : ∀ n, c (N * n) = a n := fun n => hinj.extend_apply _ _ n
+  have hc_zero : ∀ m, (¬ ∃ n, N * n = m) → c m = 0 := fun m hm => by
+    rw [hc, Function.extend_apply' _ _ _ hm]; rfl
+  have hsumN : ∀ τ : ℍ, HasSum (fun m => c m • Periodic.qParam (N : ℝ) (τ : ℂ) ^ m) (f τ) := by
+    intro τ
+    have key : (fun m => c m • Periodic.qParam (N : ℝ) (τ : ℂ) ^ m) =
+        Function.extend (fun n : ℕ => N * n) (fun n => a n • Periodic.qParam 1 (τ : ℂ) ^ n) 0 := by
+      funext m
+      by_cases hm : ∃ n, N * n = m
+      · obtain ⟨n, rfl⟩ := hm
+        rw [hinj.extend_apply, hc_apply, qParam_pow_mul]
+      · rw [Function.extend_apply' _ _ _ hm, hc_zero m hm, zero_smul]; rfl
+    rw [key, hasSum_extend_zero hinj]
+    exact hsum1 τ
+  have hgoodN : Good N f :=
+    { periodic := by simpa using hf.periodic.nat_mul N
+      mdiff := hf.mdiff
+      bdd := hf.bdd }
+  have hcoeff : ∀ m, c m = (qExpansion N f).coeff m := by
+    have hsumN' : ∀ τ : ℍ, HasSum (fun m => (qExpansion N f).coeff m • Periodic.qParam (N : ℝ) (τ :
+      ℂ) ^ m) (f τ) :=
+      fun τ => hasSum_qExpansion hNpos hgoodN.periodic hgoodN.mdiff hgoodN.bdd τ
+    have h1 :=
+      (hasFPowerSeriesOnBall_cuspFunction hNpos (hgoodN.analyticAt hNpos) hsumN).hasFPowerSeriesAt
+    have h2 :=
+      (hasFPowerSeriesOnBall_cuspFunction hNpos (hgoodN.analyticAt hNpos) hsumN').hasFPowerSeriesAt
+    have heq := h1.eq_formalMultilinearSeries h2
+    have := (FormalMultilinearSeries.ofScalars_series_eq_iff (E := ℂ) c _).mp heq
+    exact fun m => congrFun this m
+  ext k
+  rw [Q, Q]
+  rcases lt_or_ge k 0 with hk | hk
+  · rw [ModularCurve.ofPowerSeries_coeff_of_neg _ hk]
+    by_cases hdvd : (N : ℤ) ∣ k
+    · obtain ⟨k', rfl⟩ := hdvd
+      rw [ModularCurve.qExpand_coeff_mul]
+      have hk' : k' < 0 := by
+        by_contra h; push Not at h
+        have : (0 : ℤ) ≤ (N : ℤ) * k' := mul_nonneg (by positivity) h
+        omega
+      rw [ModularCurve.ofPowerSeries_coeff_of_neg _ hk']
+    · rw [ModularCurve.qExpand_coeff_of_not_dvd N _ hdvd]
+  · lift k to ℕ using hk
+    rw [HahnSeries.ofPowerSeries_apply_coeff, ← hcoeff]
+    by_cases hdvd : (N : ℤ) ∣ (k : ℤ)
+    · obtain ⟨k', hk'⟩ := hdvd
+      have hk'0 : 0 ≤ k' := by
+        by_contra h; push Not at h
+        have : (N : ℤ) * k' < 0 := mul_neg_of_pos_of_neg (by exact_mod_cast NeZero.pos N) h
+        omega
+      lift k' to ℕ using hk'0
+      have hkk : k = N * k' := by exact_mod_cast hk'
+      rw [hk', ModularCurve.qExpand_coeff_mul, HahnSeries.ofPowerSeries_apply_coeff, hkk, hc_apply]
+    · rw [ModularCurve.qExpand_coeff_of_not_dvd N _ hdvd, hc_zero]
+      rintro ⟨n, hn⟩
+      exact hdvd ⟨n, by rw [← hn]; push_cast; ring⟩
+
+end Width
+
+section Chart
+
+theorem exists_chart {N : ℕ} [NeZero N] {F : ℍ → ℂ} (hF : Good N F)
+    (hF0 : qExpansion N F ≠ 0) :
+    ∃ u : ℂ → ℂ, ContinuousAt u 0 ∧
+      u 0 = (qExpansion N F).coeff ((qExpansion N F).order.toNat) ∧ u 0 ≠ 0 ∧
+      ∀ τ : ℍ, F τ = Periodic.qParam N τ ^ ((qExpansion N F).order.toNat) *
+        u (Periodic.qParam N τ) := by
+  have pF := hF.periodic
+  have dF := hF.mdiff
+  have bF := hF.bdd
+  have hN : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  set P := qExpansion N F with hP
+  have hsummN : Summable fun n : ℕ => ‖P.coeff n‖ * (1 / 2 : ℝ) ^ n := by
+    let : FiniteDimensional ℝ ℂ := Complex.basisOneI.finiteDimensional_of_finite
+    have h1 : HasSum (fun n : ℕ => P.coeff n • ((1 / 2 : ℝ) : ℂ) ^ n)
+        (cuspFunction N F ((1 / 2 : ℝ) : ℂ)) :=
+      hasSum_qExpansion_of_norm_lt hN pF dF bF (by
+        rw [Complex.norm_real]
+        norm_num)
+    refine (summable_norm_iff.mpr h1.summable).congr fun n => ?_
+    rw [norm_smul, norm_pow, Complex.norm_real]
+    norm_num
+  have hsummShift : Summable fun j : ℕ => ‖P.coeff ((P.order.toNat) + j)‖ * (1 / 2 : ℝ) ^ j := by
+    have h1 : Summable fun j : ℕ =>
+        ‖P.coeff (j + P.order.toNat)‖ * (1 / 2 : ℝ) ^ (j + P.order.toNat) :=
+      (summable_nat_add_iff (f := fun n : ℕ => ‖P.coeff n‖ * (1 / 2 : ℝ) ^ n)
+        (P.order.toNat)).mpr hsummN
+    have h2 := h1.mul_right ((2 : ℝ) ^ P.order.toNat)
+    refine h2.congr fun j => ?_
+    have hpow : ((1 : ℝ) / 2) ^ P.order.toNat * (2 : ℝ) ^ P.order.toNat = 1 := by
+      rw [← mul_pow]
+      norm_num
+    rw [pow_add, add_comm j P.order.toNat]
+    linear_combination ‖P.coeff (P.order.toNat + j)‖ * ((1 : ℝ) / 2) ^ j * hpow
+  set u : ℂ → ℂ := fun z => ∑' j : ℕ, P.coeff (P.order.toNat + j) * z ^ j with hu
+  have hucont : ContinuousOn u (Metric.ball (0 : ℂ) (1 / 2)) := by
+    refine continuousOn_tsum (fun j => ?_) hsummShift fun j z hz => ?_
+    · exact (continuous_const.mul (continuous_pow j)).continuousOn
+    · rw [norm_mul, norm_pow]
+      gcongr
+      exact le_of_lt (by simpa [Metric.mem_ball, dist_zero_right] using hz)
+  have huCA : ContinuousAt u 0 :=
+    hucont.continuousAt (Metric.ball_mem_nhds _ (by norm_num))
+  have hu0 : u 0 = P.coeff (P.order.toNat) := by
+    have hval : u 0 = ∑' j : ℕ, P.coeff (P.order.toNat + j) * (0 : ℂ) ^ j := rfl
+    rw [hval, tsum_eq_single 0 fun j hj => by simp [zero_pow hj]]
+    simp
+  have hum : P.coeff (P.order.toNat) ≠ 0 := PowerSeries.coeff_order hF0
+  refine ⟨u, huCA, hu0, by rw [hu0]; exact hum, fun τ => ?_⟩
+  set z := Periodic.qParam (N : ℝ) (τ : ℂ) with hz
+  have hz1 : ‖z‖ < 1 := UpperHalfPlane.norm_qParam_lt_one N τ
+  have hz0 : z ≠ 0 := Complex.exp_ne_zero _
+  have hsum : HasSum (fun n : ℕ => P.coeff n • z ^ n) (F τ) :=
+    hasSum_qExpansion hN pF dF bF τ
+  have hshift : HasSum (fun j : ℕ => P.coeff (j + P.order.toNat) • z ^ (j + P.order.toNat))
+      (F τ) := by
+    have hvan : ∑ i ∈ Finset.range (P.order.toNat), P.coeff i • z ^ i = 0 := by
+      refine Finset.sum_eq_zero fun i hi => ?_
+      rw [PowerSeries.coeff_of_lt_order_toNat i (Finset.mem_range.mp hi), zero_smul]
+    have h4 := (hasSum_nat_add_iff' (P.order.toNat)).mpr hsum
+    rwa [hvan, sub_zero] at h4
+  have husum : HasSum (fun j : ℕ => P.coeff (P.order.toNat + j) * z ^ j)
+      (F τ / z ^ P.order.toNat) := by
+    have h2 : HasSum (fun j : ℕ => (P.coeff (P.order.toNat + j) * z ^ j) * z ^ P.order.toNat)
+        (F τ) := by
+      have heq : (fun j : ℕ => (P.coeff (P.order.toNat + j) * z ^ j) * z ^ P.order.toNat) =
+          fun j : ℕ => P.coeff (j + P.order.toNat) • z ^ (j + P.order.toNat) := by
+        funext j
+        rw [smul_eq_mul, pow_add, add_comm j (P.order.toNat)]
+        ring
+      rw [heq]
+      exact hshift
+    have h3 := h2.div_const (z ^ P.order.toNat)
+    have heq2 : (fun j : ℕ => P.coeff (P.order.toNat + j) * z ^ j * z ^ P.order.toNat /
+        z ^ P.order.toNat) = fun j : ℕ => P.coeff (P.order.toNat + j) * z ^ j := by
+      funext j
+      rw [mul_div_assoc, div_self (pow_ne_zero _ hz0), mul_one]
+    rwa [heq2] at h3
+  have huz : u z = F τ / z ^ P.order.toNat := husum.tsum_eq
+  rw [huz, mul_div_cancel₀ _ (pow_ne_zero _ hz0)]
+
+theorem eventually_ne_zero_atImInfty {N : ℕ} [NeZero N] {F : ℍ → ℂ} (hF : Good N F)
+    (hF0 : qExpansion N F ≠ 0) : ∀ᶠ τ : ℍ in atImInfty, F τ ≠ 0 := by
+  have hN : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  obtain ⟨u, hu, -, hu0, hid⟩ := exists_chart hF hF0
+  have h1 : Tendsto (fun τ : ℍ => u (Periodic.qParam N τ)) atImInfty (𝓝 (u 0)) :=
+    hu.tendsto.comp (qParam_tendsto_atImInfty hN)
+  filter_upwards [h1.eventually_ne hu0] with τ hτ
+  rw [hid τ]
+  exact mul_ne_zero (pow_ne_zero _ (Complex.exp_ne_zero _)) hτ
+
+theorem order_eq_of_tendsto_div {N : ℕ} [NeZero N] {G H : ℍ → ℂ} (hG : Good N G) (hH : Good N H)
+    (hG0 : qExpansion N G ≠ 0) (hH0 : qExpansion N H ≠ 0) {L : ℂ} (hL : L ≠ 0)
+    (hlim : Tendsto (fun τ : ℍ => G τ / H τ) atImInfty (𝓝 L)) :
+    (qExpansion N G).order = (qExpansion N H).order := by
+  have hN : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  obtain ⟨uG, cG, -, nG, idG⟩ := exists_chart hG hG0
+  obtain ⟨uH, cH, -, nH, idH⟩ := exists_chart hH hH0
+  set a := (qExpansion (N : ℝ) G).order.toNat with ha
+  set b := (qExpansion (N : ℝ) H).order.toNat with hb
+  have hq : Tendsto (fun τ : ℍ => Periodic.qParam (N : ℝ) (τ : ℂ)) atImInfty (𝓝 0) :=
+    qParam_tendsto_atImInfty hN
+  have hTG : Tendsto (fun τ : ℍ => uG (Periodic.qParam N τ)) atImInfty (𝓝 (uG 0)) :=
+    cG.tendsto.comp hq
+  have hTH : Tendsto (fun τ : ℍ => uH (Periodic.qParam N τ)) atImInfty (𝓝 (uH 0)) :=
+    cH.tendsto.comp hq
+  have hquot : ∀ τ : ℍ, G τ / H τ =
+      Periodic.qParam (N : ℝ) (τ : ℂ) ^ a / Periodic.qParam (N : ℝ) (τ : ℂ) ^ b *
+        (uG (Periodic.qParam N τ) / uH (Periodic.qParam N τ)) := by
+    intro τ
+    rw [idG τ, idH τ, mul_div_mul_comm]
+  have hab : a = b := by
+    by_contra hne
+    rcases Nat.lt_or_gt_of_ne hne with hlt | hgt
+    · obtain ⟨d, hd⟩ := Nat.exists_eq_add_of_lt hlt
+      have hinv : Tendsto (fun τ : ℍ => H τ / G τ) atImInfty (𝓝 L⁻¹) := by
+        have := hlim.inv₀ hL
+        refine this.congr fun τ => ?_
+        exact inv_div _ _
+      have hzero : Tendsto (fun τ : ℍ => H τ / G τ) atImInfty (𝓝 0) := by
+        have hform : ∀ τ : ℍ, H τ / G τ =
+            Periodic.qParam (N : ℝ) (τ : ℂ) ^ (d + 1) *
+              (uH (Periodic.qParam N τ) / uG (Periodic.qParam N τ)) := by
+          intro τ
+          have hz0 : Periodic.qParam (N : ℝ) (τ : ℂ) ≠ 0 := Complex.exp_ne_zero _
+          rw [idG τ, idH τ, hd, mul_div_mul_comm, show a + d + 1 = (d + 1) + a by ring, pow_add,
+            mul_div_cancel_right₀ _ (pow_ne_zero _ hz0)]
+        have h1 : Tendsto (fun τ : ℍ => Periodic.qParam (N : ℝ) (τ : ℂ) ^ (d + 1)) atImInfty (𝓝 0)
+          :=
+          by
+          have := hq.pow (d + 1)
+          rwa [zero_pow (Nat.succ_ne_zero d)] at this
+        have h2 := h1.mul (hTH.div hTG nG)
+        rw [zero_mul] at h2
+        exact h2.congr fun τ => (hform τ).symm
+      have := tendsto_nhds_unique hinv hzero
+      exact (inv_ne_zero hL) this
+    · obtain ⟨d, hd⟩ := Nat.exists_eq_add_of_lt hgt
+      have hzero : Tendsto (fun τ : ℍ => G τ / H τ) atImInfty (𝓝 0) := by
+        have hform : ∀ τ : ℍ, G τ / H τ =
+            Periodic.qParam (N : ℝ) (τ : ℂ) ^ (d + 1) *
+              (uG (Periodic.qParam N τ) / uH (Periodic.qParam N τ)) := by
+          intro τ
+          have hz0 : Periodic.qParam (N : ℝ) (τ : ℂ) ≠ 0 := Complex.exp_ne_zero _
+          rw [idG τ, idH τ, hd, mul_div_mul_comm, show b + d + 1 = (d + 1) + b by ring, pow_add,
+            mul_div_cancel_right₀ _ (pow_ne_zero _ hz0)]
+        have h1 : Tendsto (fun τ : ℍ => Periodic.qParam (N : ℝ) (τ : ℂ) ^ (d + 1)) atImInfty (𝓝 0)
+          :=
+          by
+          have := hq.pow (d + 1)
+          rwa [zero_pow (Nat.succ_ne_zero d)] at this
+        have h2 := h1.mul (hTG.div hTH nH)
+        rw [zero_mul] at h2
+        exact h2.congr fun τ => (hform τ).symm
+      exact hL (tendsto_nhds_unique hlim hzero)
+  have hfinG : (qExpansion (N : ℝ) G).order ≠ ⊤ := fun h => hG0 (PowerSeries.order_eq_top.mp h)
+  have hfinH : (qExpansion (N : ℝ) H).order ≠ ⊤ := fun h => hH0 (PowerSeries.order_eq_top.mp h)
+  rw [← ENat.natCast_toNat hfinG, ← ENat.natCast_toNat hfinH]
+  exact congrArg _ hab
+
+end Chart
+
+section Orders
+
+theorem order_inv_laurent {x : LaurentSeries ℂ} (hx : x ≠ 0) : (x⁻¹).order = -x.order := by
+  have h := HahnSeries.order_mul hx (inv_ne_zero hx)
+  rw [mul_inv_cancel₀ hx, HahnSeries.order_one] at h
+  omega
+
+theorem order_eq_of_coeff {x : LaurentSeries ℂ} {m : ℤ}
+    (hm : x.coeff m ≠ 0) (hlt : ∀ k < m, x.coeff k = 0) : x.order = m := by
+  have hx : x ≠ 0 := fun h => hm (by simp [h])
+  apply le_antisymm (HahnSeries.order_le_of_coeff_ne_zero hm)
+  by_contra hlt'
+  exact (fun h => hx (HahnSeries.coeff_order_eq_zero.mp h)) (hlt _ (not_le.mp hlt'))
+
+theorem order_ofPowerSeries {p : PowerSeries ℂ} (hp : p ≠ 0) :
+    (HahnSeries.ofPowerSeries ℤ ℂ p).order = p.order.toNat := by
+  apply order_eq_of_coeff
+  · rw [HahnSeries.ofPowerSeries_apply_coeff]
+    exact PowerSeries.coeff_order hp
+  · intro k hk
+    rcases lt_or_ge k 0 with hk0 | hk0
+    · exact ModularCurve.ofPowerSeries_coeff_of_neg _ hk0
+    · obtain ⟨n, rfl⟩ := Int.eq_ofNat_of_zero_le hk0
+      rw [HahnSeries.ofPowerSeries_apply_coeff]
+      exact PowerSeries.coeff_of_lt_order_toNat n (by exact_mod_cast hk)
+
+end Orders
+
+section Assembly
+
+local notation "Δ" => ModularForm.discriminant
+
+theorem eq_of_Q_eq {w : ℝ} (hw : 0 < w) {P P' : ℍ → ℂ} (hP : Good w P) (hP' : Good w P')
+    (hQ : Q w P = Q w P') : P = P' := by
+  have hneg : Good w ((fun _ : ℍ => (-1 : ℂ)) * P') := (Good.const w (-1)).mul hP'
+  have hsum : Good w (P + (fun _ : ℍ => (-1 : ℂ)) * P') := hP.add hneg
+  have h0 : Q w (P + (fun _ : ℍ => (-1 : ℂ)) * P') = 0 := by
+    rw [Q_add hw hP hneg, Q_mul hw (Good.const w (-1)) hP', Q_const hw, hQ, map_neg, map_one]
+    ring
+  have h1 := (Q_eq_zero_iff hw hsum).mp h0
+  funext τ
+  have := congrFun h1 τ
+  simp only [Pi.add_apply, Pi.mul_apply, Pi.zero_apply] at this
+  linear_combination this
+
+theorem good_one_modularForm {Γ : Subgroup SL(2, ℤ)} (hT : ModularGroup.T ∈ Γ) {k : ℤ}
+    (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) : Good 1 (f : ℍ → ℂ) := by
+  have h1 : (1 : ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+    rw [Subgroup.strictPeriods_eq_zmultiples_one_of_T_mem hT]
+    exact AddSubgroup.mem_zmultiples _
+  have : Fact (IsCusp OnePoint.infty (Γ : Subgroup (GL (Fin 2) ℝ))) :=
+    ⟨Subgroup.isCusp_of_mem_strictPeriods one_pos h1⟩
+  exact
+    { periodic := SlashInvariantFormClass.periodic_comp_ofComplex f h1
+      mdiff := f.holo'
+      bdd := ModularFormClass.bdd_at_infty f }
+
+theorem good_nat_modularForm (M : ℕ) {Γ : Subgroup SL(2, ℤ)} (hT : ModularGroup.T ∈ Γ) {k : ℤ}
+    (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) : Good M (f : ℍ → ℂ) :=
+  { periodic := by simpa using (good_one_modularForm hT f).periodic.nat_mul M
+    mdiff := (good_one_modularForm hT f).mdiff
+    bdd := (good_one_modularForm hT f).bdd }
+
+theorem qExpansion_ne_zero_of_Q_ne_zero {w : ℝ} {F : ℍ → ℂ} (hF : Q w F ≠ 0) : qExpansion w F ≠ 0 :=
+  fun hp => hF (by rw [Q, hp, map_zero])
+
+end Assembly
+
+end ModularCurve.LevelN.CuspExpChi
+end
+
+open ModularCurve.LevelN.CuspExpChi UpperHalfPlane Filter in
+open scoped MatrixGroups Topology Manifold in
+theorem solution
+    (M : ℕ) [NeZero M]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring M) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring M) K]
+    [IsFractionRing (ModularCurve.LevelN.ring M) K]
+    (hst : ∀ γ : SL(2, ℤ), ∀ F ∈ ModularCurve.LevelN.ring M,
+      (fun τ : UpperHalfPlane => F (γ • τ)) ∈ ModularCurve.LevelN.ring M)
+    (σ : SL(2, ℤ) →* (K ≃ₐ[ℂ] K))
+    (hσ : ∀ (γ : SL(2, ℤ)) (F : UpperHalfPlane → ℂ) (hF : F ∈ ModularCurve.LevelN.ring M),
+      σ γ (algebraMap (ModularCurve.LevelN.ring M) K ⟨F, hF⟩) =
+        algebraMap (ModularCurve.LevelN.ring M) K
+          ⟨fun τ : UpperHalfPlane => F (γ⁻¹ • τ), hst γ⁻¹ F hF⟩)
+    (E : K →ₐ[ℂ] LaurentSeries ℂ)
+    (hEq : ∀ (F : UpperHalfPlane → ℂ) (hF : F ∈ ModularCurve.LevelN.ring M) (m : ℕ),
+      UpperHalfPlane.IsBoundedAtImInfty (F * ModularForm.discriminant ^ m) →
+        E (algebraMap (ModularCurve.LevelN.ring M) K ⟨F, hF⟩) *
+            HahnSeries.ofPowerSeries ℤ ℂ
+              (UpperHalfPlane.qExpansion M (ModularForm.discriminant : UpperHalfPlane → ℂ)) ^ m =
+          HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion M (F * ModularForm.discriminant ^
+            m)))
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex]
+    (hT : ModularGroup.T ∈ Γ)
+    {k : ℤ} (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (z : K)
+    (hz : E z * ModularCurve.qExpand ℂ M
+        ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+      ModularCurve.qExpand ℂ M
+        ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ))
+    (γ : SL(2, ℤ)) (L : ℂ) (hL : L ≠ 0)
+    (hlim : Filter.Tendsto
+      (fun τ : UpperHalfPlane => (g : UpperHalfPlane → ℂ) (γ⁻¹ • τ) / (h : UpperHalfPlane → ℂ) (γ⁻¹
+        • τ))
+      atImInfty (𝓝 L)) :
+    Valued.v (E (σ γ z)) ≤ 1 := by
+  classical
+  have hMpos : (0 : ℝ) < M := Nat.cast_pos.mpr (NeZero.pos M)
+  suffices key : ∀ n : ℤ, n < 0 → (E (σ γ z)).coeff n = 0 by
+    have := (LaurentSeries.valuation_le_iff_coeff_lt_eq_zero ℂ (D := 0)).mpr key
+    simpa using this
+  obtain ⟨a, b, hbnz, hzab⟩ := IsFractionRing.div_surjective (A := ModularCurve.LevelN.ring M) z
+  have hb0 : ((b : ModularCurve.LevelN.ring M) : UpperHalfPlane → ℂ) ≠ 0 := by
+    intro h0
+    apply nonZeroDivisors.ne_zero hbnz
+    exact Subtype.ext (by rw [h0]; rfl)
+  set af : UpperHalfPlane → ℂ := ((a : ModularCurve.LevelN.ring M) : UpperHalfPlane → ℂ) with haf
+  set bf : UpperHalfPlane → ℂ := ((b : ModularCurve.LevelN.ring M) : UpperHalfPlane → ℂ) with hbf
+  have haA : af ∈ ModularCurve.LevelN.ring M := (a : ModularCurve.LevelN.ring M).2
+  have hbA : bf ∈ ModularCurve.LevelN.ring M := (b : ModularCurve.LevelN.ring M).2
+  have ha'A : (fun τ : UpperHalfPlane => af (γ⁻¹ • τ)) ∈ ModularCurve.LevelN.ring M :=
+    hst γ⁻¹ af haA
+  have hb'A : (fun τ : UpperHalfPlane => bf (γ⁻¹ • τ)) ∈ ModularCurve.LevelN.ring M :=
+    hst γ⁻¹ bf hbA
+  set a' : UpperHalfPlane → ℂ := fun τ : UpperHalfPlane => af (γ⁻¹ • τ) with ha'
+  set b' : UpperHalfPlane → ℂ := fun τ : UpperHalfPlane => bf (γ⁻¹ • τ) with hb'
+  have hσa : σ γ (algebraMap (ModularCurve.LevelN.ring M) K a) =
+      algebraMap (ModularCurve.LevelN.ring M) K ⟨a', ha'A⟩ := hσ γ af haA
+  have hσb : σ γ (algebraMap (ModularCurve.LevelN.ring M) K b) =
+      algebraMap (ModularCurve.LevelN.ring M) K ⟨b', hb'A⟩ := hσ γ bf hbA
+  have hzσ : σ γ z = algebraMap (ModularCurve.LevelN.ring M) K ⟨a', ha'A⟩ /
+      algebraMap (ModularCurve.LevelN.ring M) K ⟨b', hb'A⟩ := by
+    rw [← hzab, map_div₀, hσa, hσb]
+  obtain ⟨m₁, hm₁⟩ := exists_isBoundedAtImInfty_mul_pow M ha'A
+  obtain ⟨m₂, hm₂⟩ := exists_isBoundedAtImInfty_mul_pow M hb'A
+  have hPa : PB a' (m₁ + m₂) := PB.add_right hm₁ m₂
+  have hPb : PB b' (m₁ + m₂) := by
+    have := PB.add_right hm₂ m₁
+    rwa [add_comm] at this
+  set m : ℕ := m₁ + m₂ with hm
+  have gd1 : Good M (a' * (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ m) :=
+    good_of_PB M ha'A hPa
+  have gd2 : Good M (b' * (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ m) :=
+    good_of_PB M hb'A hPb
+  have hQΔ : Q M (ModularForm.discriminant : UpperHalfPlane → ℂ) ≠ 0 := Q_discriminant_ne_zero M
+  have hEa : E (algebraMap (ModularCurve.LevelN.ring M) K ⟨a', ha'A⟩) * Q M
+    (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ m =
+      Q M (a' * (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ m) := hEq a' ha'A m hPa
+  have hEb : E (algebraMap (ModularCurve.LevelN.ring M) K ⟨b', hb'A⟩) * Q M
+    (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ m =
+      Q M (b' * (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ m) := hEq b' hb'A m hPb
+  have hb'ne : b' ≠ 0 := by
+    intro h0
+    apply hb0
+    funext τ
+    have := congrFun h0 (γ • τ)
+    simpa [hb'] using this
+  have hQb : Q M (b' * (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ m) ≠ 0 := by
+    rw [ne_eq, Q_eq_zero_iff hMpos gd2, mul_discriminant_pow_eq_zero_iff]
+    exact hb'ne
+  have hEz : E (σ γ z) = Q M (a' * (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ m) / Q M (b' *
+    (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ m) :=
+    by
+    rw [hzσ, map_div₀, ← hEa, ← hEb, mul_div_mul_right _ _ (pow_ne_zero _ hQΔ)]
+  obtain ⟨n₁, hn₁⟩ := exists_isBoundedAtImInfty_mul_pow M haA
+  obtain ⟨n₂, hn₂⟩ := exists_isBoundedAtImInfty_mul_pow M hbA
+  have hPa0 : PB af (n₁ + n₂) := PB.add_right hn₁ n₂
+  have hPb0 : PB bf (n₁ + n₂) := by
+    have := PB.add_right hn₂ n₁
+    rwa [add_comm] at this
+  set n : ℕ := n₁ + n₂ with hn
+  have gda : Good M (af * (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ n) :=
+    good_of_PB M haA hPa0
+  have gdb : Good M (bf * (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ n) :=
+    good_of_PB M hbA hPb0
+  have hEa0 : E (algebraMap (ModularCurve.LevelN.ring M) K a) * Q M (ModularForm.discriminant :
+    UpperHalfPlane → ℂ) ^ n =
+      Q M (af * (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ n) := hEq af haA n hPa0
+  have hEb0 : E (algebraMap (ModularCurve.LevelN.ring M) K b) * Q M (ModularForm.discriminant :
+    UpperHalfPlane → ℂ) ^ n =
+      Q M (bf * (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ n) := hEq bf hbA n hPb0
+  have hQb0 : Q M (bf * (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ n) ≠ 0 := by
+    rw [ne_eq, Q_eq_zero_iff hMpos gdb, mul_discriminant_pow_eq_zero_iff]
+    exact hb0
+  have gdh : Good M (h : UpperHalfPlane → ℂ) := good_nat_modularForm M hT h
+  have gdg : Good M (g : UpperHalfPlane → ℂ) := good_nat_modularForm M hT g
+  have hQh : Q M (h : UpperHalfPlane → ℂ) = ModularCurve.qExpand ℂ M (Q 1 (h : UpperHalfPlane → ℂ))
+    :=
+    Q_natCast_eq_qExpand M (good_one_modularForm hT h)
+  have hQg : Q M (g : UpperHalfPlane → ℂ) = ModularCurve.qExpand ℂ M (Q 1 (g : UpperHalfPlane → ℂ))
+    :=
+    Q_natCast_eq_qExpand M (good_one_modularForm hT g)
+  have hz' : E z * Q M (h : UpperHalfPlane → ℂ) = Q M (g : UpperHalfPlane → ℂ) := by
+    rw [hQh, hQg]
+    exact hz
+  have hEz0 : E z = Q M (af * (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ n) / Q M (bf *
+    (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ n) :=
+    by
+    rw [← hzab, map_div₀, ← hEa0, ← hEb0, mul_div_mul_right _ _ (pow_ne_zero _ hQΔ)]
+  have hfun : af * (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ n * (h : UpperHalfPlane → ℂ) =
+      bf * (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ n * (g : UpperHalfPlane → ℂ) := by
+    apply eq_of_Q_eq hMpos (gda.mul gdh) (gdb.mul gdg)
+    rw [Q_mul hMpos gda gdh, Q_mul hMpos gdb gdg, ← hz', hEz0]
+    field_simp
+  have hrel : ∀ τ : UpperHalfPlane, af τ * (h : UpperHalfPlane → ℂ) τ = bf τ * (g : UpperHalfPlane →
+    ℂ) τ :=
+    by
+    intro τ
+    have := congrFun hfun τ
+    simp only [Pi.mul_apply, Pi.pow_apply] at this
+    have hΔ : (ModularForm.discriminant : UpperHalfPlane → ℂ) τ ^ n ≠ 0 :=
+      pow_ne_zero _ (ModularForm.discriminant_ne_zero τ)
+    have := mul_right_cancel₀ hΔ (by
+      calc af τ * (h : UpperHalfPlane → ℂ) τ * (ModularForm.discriminant : UpperHalfPlane → ℂ) τ ^ n
+          = af τ * (ModularForm.discriminant : UpperHalfPlane → ℂ) τ ^ n * (h : UpperHalfPlane → ℂ)
+            τ := by
+            ring
+        _ = bf τ * (ModularForm.discriminant : UpperHalfPlane → ℂ) τ ^ n * (g : UpperHalfPlane → ℂ)
+          τ := this
+        _ = bf τ * (g : UpperHalfPlane → ℂ) τ * (ModularForm.discriminant : UpperHalfPlane → ℂ) τ ^
+          n := by
+          ring)
+    exact this
+  have hev1 : ∀ᶠ τ : UpperHalfPlane in atImInfty,
+      (g : UpperHalfPlane → ℂ) (γ⁻¹ • τ) / (h : UpperHalfPlane → ℂ) (γ⁻¹ • τ) ≠ 0 :=
+    hlim.eventually_ne hL
+  have hev2 : ∀ᶠ τ : UpperHalfPlane in atImInfty, (b' * (ModularForm.discriminant : UpperHalfPlane →
+    ℂ) ^ m) τ ≠ 0 :=
+    eventually_ne_zero_atImInfty gd2 (qExpansion_ne_zero_of_Q_ne_zero hQb)
+  have hlim' : Tendsto (fun τ : UpperHalfPlane =>
+      (a' * (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ m) τ / (b' * (ModularForm.discriminant
+        : UpperHalfPlane → ℂ) ^ m) τ) atImInfty (𝓝 L) := by
+    refine hlim.congr' ?_
+    filter_upwards [hev1, hev2] with τ h1 h2
+    have hh' : (h : UpperHalfPlane → ℂ) (γ⁻¹ • τ) ≠ 0 := fun h0 => h1 (by rw [h0, div_zero])
+    have hb'τ : b' τ ≠ 0 := by
+      intro h0
+      apply h2
+      simp only [Pi.mul_apply, Pi.pow_apply, h0, zero_mul]
+    have hr := hrel (γ⁻¹ • τ)
+    have hΔ : (ModularForm.discriminant : UpperHalfPlane → ℂ) τ ^ m ≠ 0 :=
+      pow_ne_zero _ (ModularForm.discriminant_ne_zero τ)
+    simp only [Pi.mul_apply, Pi.pow_apply]
+    rw [mul_div_mul_right _ _ hΔ, div_eq_div_iff hh' hb'τ]
+    change (g : UpperHalfPlane → ℂ) (γ⁻¹ • τ) * bf (γ⁻¹ • τ) = af (γ⁻¹ • τ) * (h : UpperHalfPlane →
+      ℂ) (γ⁻¹ • τ)
+    linear_combination -hr
+  by_cases hQa : Q M (a' * (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ m) = 0
+  · intro n hn
+    rw [hEz, hQa, zero_div, HahnSeries.coeff_zero]
+  · have hord := order_eq_of_tendsto_div gd1 gd2 (qExpansion_ne_zero_of_Q_ne_zero hQa)
+      (qExpansion_ne_zero_of_Q_ne_zero hQb) hL hlim'
+    have horder : (Q M (a' * (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ m) / Q M (b' *
+      (ModularForm.discriminant : UpperHalfPlane → ℂ) ^ m)).order = 0 :=
+      by
+      rw [div_eq_mul_inv, HahnSeries.order_mul hQa (inv_ne_zero hQb), order_inv_laurent hQb, Q, Q,
+        order_ofPowerSeries (qExpansion_ne_zero_of_Q_ne_zero hQa),
+        order_ofPowerSeries (qExpansion_ne_zero_of_Q_ne_zero hQb), hord]
+      omega
+    intro n hn
+    rw [hEz]
+    exact HahnSeries.coeff_eq_zero_of_lt_order (by rw [horder]; exact hn)
+
+end S_ModularCurve_LevelN_valuation_apply_smul_le_one_of_tendsto_div_smul
+end P2MW
+export P2MW.S_ModularCurve_LevelN_valuation_apply_smul_le_one_of_tendsto_div_smul (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane
+open scoped MatrixGroups Topology
+theorem ModularCurve.LevelN.valuation_apply_smul_le_one_of_tendsto_div_smul
+    (M : ℕ) [NeZero M]
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring M) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring M) K]
+    [IsFractionRing (ModularCurve.LevelN.ring M) K]
+    (hst : ∀ γ : SL(2, ℤ), ∀ F ∈ ModularCurve.LevelN.ring M,
+      (fun τ : UpperHalfPlane => F (γ • τ)) ∈ ModularCurve.LevelN.ring M)
+    (σ : SL(2, ℤ) →* (K ≃ₐ[ℂ] K))
+    (hσ : ∀ (γ : SL(2, ℤ)) (F : UpperHalfPlane → ℂ) (hF : F ∈ ModularCurve.LevelN.ring M),
+      σ γ (algebraMap (ModularCurve.LevelN.ring M) K ⟨F, hF⟩) =
+        algebraMap (ModularCurve.LevelN.ring M) K
+          ⟨fun τ : UpperHalfPlane => F (γ⁻¹ • τ), hst γ⁻¹ F hF⟩)
+    (E : K →ₐ[ℂ] LaurentSeries ℂ)
+    (hEq : ∀ (F : UpperHalfPlane → ℂ) (hF : F ∈ ModularCurve.LevelN.ring M) (m : ℕ),
+      UpperHalfPlane.IsBoundedAtImInfty (F * ModularForm.discriminant ^ m) →
+        E (algebraMap (ModularCurve.LevelN.ring M) K ⟨F, hF⟩) *
+            HahnSeries.ofPowerSeries ℤ ℂ
+              (UpperHalfPlane.qExpansion M (ModularForm.discriminant : UpperHalfPlane → ℂ)) ^ m =
+          HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion M (F * ModularForm.discriminant ^
+            m)))
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex]
+    (hT : ModularGroup.T ∈ Γ)
+    {k : ℤ} (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (z : K)
+    (hz : E z * ModularCurve.qExpand ℂ M
+        ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+      ModularCurve.qExpand ℂ M
+        ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ))
+    (γ : SL(2, ℤ)) (L : ℂ) (hL : L ≠ 0)
+    (hlim : Filter.Tendsto
+      (fun τ : UpperHalfPlane => (g : UpperHalfPlane → ℂ) (γ⁻¹ • τ) / (h : UpperHalfPlane → ℂ) (γ⁻¹
+        • τ))
+      atImInfty (𝓝 L)) :
+    Valued.v (E (σ γ z)) ≤ 1 :=
+  solution M K hst σ hσ E hEq Γ hT g h z hz γ L hL hlim
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_eq_of_prime.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_eq_of_prime.lean
new file mode 100644
index 0000000000..008740ada8
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_eq_of_prime.lean
@@ -0,0 +1,160 @@
+/-
+Based on Prove2Me node ModularCurve.ModularPolynomialData.eq_of_prime
+(8104e31e-e7e5-576b-83ff-95b68463f328) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f0162e94-64db-5958-bc3d-e85754b88568
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqN_eq_of_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_evalAtJ_injective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+import Mathlib.FieldTheory.Minpoly.Field
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Uniqueness of prime-level modular polynomial data
+
+Theorem statement: `ModularCurve.ModularPolynomialData.eq_of_prime`
+(`8104e31e-e7e5-576b-83ff-95b68463f328`), by Claude, 2026-09-05.
+
+Proof: submission `f0162e94-64db-5958-bc3d-e85754b88568`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $p$ be a prime. A term of the structure `ModularPolynomialData p` consists of a polynomial $\Phi
+\in (\mathbb{Z}[Y])[X]$ together with three properties: $\Phi$ is monic (in $X$), its $X$-degree
+equals `dedekindPsi p`, defined as $\sum_{d \mid p,\ d \text{ squarefree}} p/d$, and $\Phi$ vanishes
+when its coefficients in $\mathbb{Z}[Y]$ are mapped into the Laurent series field $\mathbb{Q}((q))$
+by the ring homomorphism `evalAtJ`, namely evaluation at the Laurent series `jq`, and $X$ is set
+equal to `jqN p`; here `jq` and `jqN p` are the $q$-expansion models of the modular function $j$ and
+of $j$ at $q^p$. The theorem asserts that for any two such terms $d$ and $d'$ one has $d = d'$: the
+data at prime level are unique, hence in particular their underlying polynomials $\Phi$ agree. No
+further hypotheses are imposed.
+
+This is the uniqueness half of the statement that the classical modular polynomial $\Phi_p(X,Y)$ is
+pinned down, at prime level, by being monic of $X$-degree $\psi(p)$ with $\Phi_p(j(q^p), j(q)) = 0$.
+It is used to transfer properties established for one particular construction of the level-$p$
+modular polynomial (irreducibility over $\mathbb{Q}(j)$, symmetry of the two variables, separability
+of the reduction) to an arbitrary term of `ModularPolynomialData p`, and in the analysis of the
+fibres of the associated curve in characteristic $p$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ModularPolynomialData_eq_of_prime.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ModularPolynomialData_eq_of_prime
+
+noncomputable section
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_ModularPolynomialData_eq_of_prime.ModularCurve \
+  ModularCurve.PhiGen"
+open scoped IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jq jqN dedekindPsi ModularPolynomialData evalAtJGen \
+  algebraMap_comp_evalAtJGen ModularPolynomialData.toAdjoin PhiIrreducible \
+  finrank_adjoin_jqN_eq_of_prime dedekindPsi_prime exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve"
+
+theorem evalAtJGen_injective : Function.Injective evalAtJGen := by
+  have h : Function.Injective ((algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) ∘ evalAtJGen) := by
+    rw [← RingHom.coe_comp, algebraMap_comp_evalAtJGen]; exact evalAtJ_injective
+  exact h.of_comp
+
+theorem aeval_jqN_toAdjoin {N : ℕ} [NeZero N] (data : ModularPolynomialData N) :
+    Polynomial.aeval (jqN N) data.toAdjoin = 0 := by
+  rw [ModularPolynomialData.toAdjoin, Polynomial.aeval_def, Polynomial.eval₂_map,
+    algebraMap_comp_evalAtJGen]
+  exact data.eval_eq_zero
+
+theorem natDegree_toAdjoin {N : ℕ} [NeZero N] (data : ModularPolynomialData N) :
+    data.toAdjoin.natDegree = dedekindPsi N := by
+  rw [ModularPolynomialData.toAdjoin, data.monic.natDegree_map, data.natDegree_eq]
+
+theorem toAdjoin_eq_minpoly (p : ℕ) [hp : Fact p.Prime] (data : ModularPolynomialData p) :
+    data.toAdjoin = minpoly ℚ⟮jq⟯ (jqN p) := by
+  have hint : IsIntegral ℚ⟮jq⟯ (jqN p) := ⟨data.toAdjoin, data.toAdjoin_monic, by
+    simpa [Polynomial.aeval_def] using aeval_jqN_toAdjoin data⟩
+  have hdeg : (minpoly ℚ⟮jq⟯ (jqN p)).natDegree = p + 1 := by
+    rw [← IntermediateField.adjoin.finrank hint]
+    exact finrank_adjoin_jqN_eq_of_prime p
+  refine Polynomial.eq_of_monic_of_dvd_of_natDegree_le (minpoly.monic hint) data.toAdjoin_monic
+    (minpoly.dvd _ _ (aeval_jqN_toAdjoin data)) ?_
+  rw [hdeg, natDegree_toAdjoin, dedekindPsi_prime hp.out]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jq jqN dedekindPsi ModularPolynomialData evalAtJGen \
+  algebraMap_comp_evalAtJGen ModularPolynomialData.toAdjoin PhiIrreducible \
+  finrank_adjoin_jqN_eq_of_prime dedekindPsi_prime exists_phiIrreducible_evalSymm"
+namespace ModularPolynomialData
+p2m_export "ModularCurve.ModularPolynomialData" "toAdjoin toAdjoin_monic monic eval_eq_zero \
+  natDegree_eq Φ"
+end ModularCurve.ModularPolynomialData
+p2m_open_scoped "ModularCurve ModularCurve.ModularPolynomialData" in
+open ModularCurve.W1 in
+private theorem ModularCurve.ModularPolynomialData.eq_of_prime (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (d d' : ModularPolynomialData p) :
+    d = d' := by
+  have h : d.Φ = d'.Φ := by
+    apply Polynomial.map_injective evalAtJGen evalAtJGen_injective
+    change d.toAdjoin = d'.toAdjoin
+    rw [toAdjoin_eq_minpoly, toAdjoin_eq_minpoly]
+  cases d; cases d'
+  cases h
+  rfl
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jq jqN dedekindPsi ModularPolynomialData evalAtJGen \
+  algebraMap_comp_evalAtJGen ModularPolynomialData.toAdjoin PhiIrreducible \
+  finrank_adjoin_jqN_eq_of_prime dedekindPsi_prime exists_phiIrreducible_evalSymm"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.phiIrreducible_of_prime (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (data : ModularPolynomialData p) :
+    PhiIrreducible data := by
+  obtain ⟨d₀, h, -⟩ := exists_phiIrreducible_evalSymm p
+  rwa [ModularCurve.ModularPolynomialData.eq_of_prime p data d₀]
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_ModularPolynomialData_eq_of_prime.ModularCurve
+  in
+theorem solution (p : ℕ) [hp : Fact (Nat.Prime p)] (d d' : ModularPolynomialData p) : d = d' :=
+  ModularCurve.ModularPolynomialData.eq_of_prime p d d'
+
+end
+end S_ModularCurve_ModularPolynomialData_eq_of_prime
+end P2MW
+export P2MW.S_ModularCurve_ModularPolynomialData_eq_of_prime (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.ModularPolynomialData.eq_of_prime (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (d d' : ModularPolynomialData p) :
+    d = d' :=
+  solution p d d'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_eval_E4_cube_div_discriminant_coset_eq_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_eval_E4_cube_div_discriminant_coset_eq_zero.lean
new file mode 100644
index 0000000000..6232454770
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_eval_E4_cube_div_discriminant_coset_eq_zero.lean
@@ -0,0 +1,174 @@
+/-
+Based on Prove2Me node
+ModularCurve.ModularPolynomialData.eval_E4_cube_div_discriminant_coset_eq_zero
+(10a8535e-aaea-506b-b133-07bb1902183c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9fda4869-e363-5b9e-a9c7-640238431521
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PrimCosetReps
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Matrix_SpecialLinearGroup_exists_eq_mul_diagonal_mul_of_gcd_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_E4_cube_div_discriminant_smul_eq_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Coset representatives give roots of Φ_N(j(τ),·)
+
+Theorem statement: `ModularCurve.ModularPolynomialData.eval_E4_cube_div_discriminant_coset_eq_zero`
+(`10a8535e-aaea-506b-b133-07bb1902183c`), by Claude, 2026-09-05.
+
+Proof: submission `9fda4869-e363-5b9e-a9c7-640238431521`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and let `data` be a datum of type
+[`ModularCurve.ModularPolynomialData N`](def/ModularCurve_X0.html#L215), i.e. a two-variable
+integral polynomial $\Phi =$ `data.Φ` in `Polynomial (Polynomial ℤ)` which is monic in the outer
+variable, whose degree in that variable equals `dedekindPsi N` $= \sum_{d \mid N,\ d \text{
+squarefree}} N/d$, and which satisfies the formal relation `Φ.eval₂ evalAtJ (jqN N) = 0` in Laurent
+series over $\mathbb{Q}$, where the coefficient polynomials are evaluated at the $q$-expansion of
+$j$ and the outer variable at `jqN N`. Let $(a,b,d)$ be a triple of natural numbers lying in
+[`ModularCurve.primCosetReps N`](def/ModularCurve_PrimCosetReps.html#L8), that is, $a, b, d \le N$
+with $a d = N$, $b < d$ and $\gcd(a, \gcd(b,d)) = 1$. Let $\tau, \tau'$ be points of the upper
+half-plane whose complex coordinates satisfy $\tau' = (a\tau + b)/d$. Writing $j(z) =
+E_4(z)^3/\Delta(z)$ for the quotient of the Eisenstein series `ModularForm.E₄` cubed by
+`ModularForm.discriminant`, the conclusion is that the complex polynomial obtained from $\Phi$ by
+mapping each integral coefficient polynomial to its value at $j(\tau)$ under $\mathbb{Z} \to
+\mathbb{C}$ vanishes at $j(\tau')$; in classical notation, $\Phi_N\bigl(j(\tau),
+j\bigl(\tfrac{a\tau+b}{d}\bigr)\bigr) = 0$.
+
+This is the analytic statement that every function $\tau \mapsto j((a\tau+b)/d)$ attached to a
+primitive coset representative of level $N$ is a root of $\Phi_N(j(\tau), Y)$, the classical first
+assertion about the modular equation. It supplies the input, not available from the single formal
+identity $\Phi_N(j(q), j(q^N)) = 0$ at composite $N$, used in the construction of coset root data
+for $X_0(N)$ and in the vanishing of $\Phi_N$ on cyclic isogenies of complex tori.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ModularPolynomialData_eval_E4_cube_div_discriminant_coset_eq_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ModularPolynomialData_eval_E4_cube_div_discriminant_coset_eq_zero
+
+noncomputable section
+
+p2m_open "ModularCurve \
+  P2MW.S_ModularCurve_ModularPolynomialData_eval_E4_cube_div_discriminant_coset_eq_zero.ModularCurv\
+  e UpperHalfPlane Polynomial"
+open scoped MatrixGroups
+
+namespace ModularCurve
+p2m_export "ModularCurve" "ModularPolynomialData primCosetReps mem_primCosetReps \
+  ModularPolynomialData.eval_E4_cube_div_discriminant_smul_eq_zero"
+namespace CosetRootAux
+p2m_open "ModularCurve"
+
+def jt (z : ℍ) : ℂ := (ModularForm.E₄ : ℍ → ℂ) z ^ 3 / ModularForm.discriminant z
+
+theorem sl_mem (γ : SL(2, ℤ)) : (γ : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ, rfl⟩
+
+theorem jt_smul (γ : SL(2, ℤ)) (z : ℍ) : jt ((γ : GL (Fin 2) ℝ) • z) = jt z := by
+  unfold jt
+  have h4 := SlashInvariantForm.slash_action_eqn'' (ModularForm.E₄) (sl_mem γ) z
+  have h12 := SlashInvariantForm.slash_action_eqn'' (CuspForm.discriminant) (sl_mem γ) z
+  rw [CuspForm.coe_discriminant] at h12
+  have hd : denom (γ : GL (Fin 2) ℝ) (z : ℂ) ≠ 0 := UpperHalfPlane.denom_ne_zero _ z
+  have hΔ : ModularForm.discriminant z ≠ 0 := ModularForm.discriminant_ne_zero z
+  rw [show (ModularForm.E₄ : ℍ → ℂ) ((γ : GL (Fin 2) ℝ) • z) = ModularForm.E₄ ((γ : GL (Fin 2) ℝ) •
+    z) from rfl, h4, h12]
+  field_simp
+
+theorem upperTriangularGL_eq {N a b d : ℕ} (hN : N ≠ 0) (γ₁ γ₂ : SL(2, ℤ))
+    (hM : !![(a : ℤ), b; 0, d] = (γ₁ : Matrix (Fin 2) (Fin 2) ℤ) * !![(N : ℤ), 0; 0, 1] * (γ₂ :
+      Matrix (Fin 2) (Fin 2) ℤ))
+    (had' : (a : ℝ) * d ≠ 0) :
+    ModularForm.upperTriangularGL a b d had' = (γ₁ : GL (Fin 2) ℝ) * ModularForm.heckeDiagMatrix N *
+      (γ₂ : GL (Fin 2) ℝ) := by
+  apply Units.ext
+  have hmap := congrArg (fun M : Matrix (Fin 2) (Fin 2) ℤ => M.map (Int.castRingHom ℝ)) hM
+  simp only [Matrix.map_mul] at hmap
+  rw [Units.val_mul, Units.val_mul, ModularForm.val_upperTriangularGL,
+    ModularForm.val_heckeDiagMatrix hN]
+  convert hmap using 3 <;> first | rfl | (ext i j; fin_cases i <;> fin_cases j <;> simp)
+
+theorem coe_upperTriangularGL_smul {a b d : ℕ} (ha : 0 < a) (hd : 0 < d) (had' : (a : ℝ) * d ≠ 0)
+    (τ : ℍ) :
+    ((ModularForm.upperTriangularGL a b d had' • τ : ℍ) : ℂ) = ((a : ℂ) * τ + b) / d := by
+  have hdet : 0 < ((ModularForm.upperTriangularGL (a : ℝ) b d had').det : ℝ) := by
+    rw [Matrix.GeneralLinearGroup.val_det_apply, ModularForm.val_upperTriangularGL,
+      Matrix.det_fin_two_of]
+    have : (0 : ℝ) < a * d := mul_pos (by exact_mod_cast ha) (by exact_mod_cast hd)
+    linarith
+  rw [UpperHalfPlane.coe_smul_of_det_pos hdet]
+  simp [UpperHalfPlane.num, UpperHalfPlane.denom, ModularForm.val_upperTriangularGL]
+
+end ModularCurve.CosetRootAux
+
+open ModularCurve.CosetRootAux in
+theorem solution (N : ℕ) [NeZero N]
+    (data : ModularCurve.ModularPolynomialData N) {a b d : ℕ}
+    (habd : (a, b, d) ∈ ModularCurve.primCosetReps N)
+    (τ τ' : ℍ) (hτ' : (τ' : ℂ) = ((a : ℂ) * τ + b) / d) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom ℂ)
+        ((ModularForm.E₄ : ℍ → ℂ) τ ^ 3 / ModularForm.discriminant τ))).eval
+      ((ModularForm.E₄ : ℍ → ℂ) τ' ^ 3 / ModularForm.discriminant τ') = 0 := by
+  have hN : N ≠ 0 := NeZero.ne N
+  rw [mem_primCosetReps hN] at habd
+  obtain ⟨had, hbd, hgcd⟩ := habd
+  have ha : 0 < a := Nat.pos_of_ne_zero (by rintro rfl; exact hN (by simpa using had.symm))
+  have hd : 0 < d := Nat.pos_of_ne_zero (by rintro rfl; exact hN (by simpa using had.symm))
+  have had' : (a : ℝ) * d ≠ 0 := by exact_mod_cast (mul_pos ha hd).ne'
+  obtain ⟨γ₁, γ₂, hM⟩ :=
+    Matrix.SpecialLinearGroup.exists_eq_mul_diagonal_mul_of_gcd_eq_one hN had hgcd
+  set g : GL (Fin 2) ℝ := ModularForm.upperTriangularGL a b d had' with hg
+  have hgeq : g = (γ₁ : GL (Fin 2) ℝ) * ModularForm.heckeDiagMatrix N * (γ₂ : GL (Fin 2) ℝ) :=
+    upperTriangularGL_eq hN γ₁ γ₂ hM had'
+  have hτ'pt : τ' = g • τ :=
+    UpperHalfPlane.ext (by rw [hτ', hg, coe_upperTriangularGL_smul ha hd had'])
+  set σ : ℍ := (γ₂ : GL (Fin 2) ℝ) • τ with hσ
+  have h1 : τ' = (γ₁ : GL (Fin 2) ℝ) • (ModularForm.heckeDiagMatrix N • σ) := by
+    rw [hτ'pt, hgeq, mul_smul, mul_smul]
+  change (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom ℂ) (jt τ))).eval (jt τ') = 0
+  rw [h1, jt_smul, show jt τ = jt σ from by rw [hσ, jt_smul]]
+  exact ModularCurve.ModularPolynomialData.eval_E4_cube_div_discriminant_smul_eq_zero N data σ _
+    (ModularForm.coe_heckeDiagMatrix_smul hN σ)
+
+end
+
+end S_ModularCurve_ModularPolynomialData_eval_E4_cube_div_discriminant_coset_eq_zero
+end P2MW
+export P2MW.S_ModularCurve_ModularPolynomialData_eval_E4_cube_div_discriminant_coset_eq_zero
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane
+theorem ModularCurve.ModularPolynomialData.eval_E4_cube_div_discriminant_coset_eq_zero (N : ℕ)
+    [NeZero N]
+    (data : ModularCurve.ModularPolynomialData N) {a b d : ℕ}
+    (habd : (a, b, d) ∈ ModularCurve.primCosetReps N)
+    (τ τ' : ℍ) (hτ' : (τ' : ℂ) = ((a : ℂ) * τ + b) / d) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom ℂ)
+        ((ModularForm.E₄ : ℍ → ℂ) τ ^ 3 / ModularForm.discriminant τ))).eval
+      ((ModularForm.E₄ : ℍ → ℂ) τ' ^ 3 / ModularForm.discriminant τ') = 0 :=
+  solution N data habd τ τ' hτ'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_eval_E4_cube_div_discriminant_smul_eq_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_eval_E4_cube_div_discriminant_smul_eq_zero.lean
new file mode 100644
index 0000000000..1dea0e7249
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_eval_E4_cube_div_discriminant_smul_eq_zero.lean
@@ -0,0 +1,474 @@
+/-
+Based on Prove2Me node ModularCurve.ModularPolynomialData.eval_E4_cube_div_discriminant_smul_eq_zero
+(eccf1cb1-5baa-5df8-bcbf-cef680be6556) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 76aef4d5-47ab-5a83-ab70-a432a0a218cd
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_degeneracy_Gamma0
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_qExpansion_heckeDiagMatrix_smul_eq_qExpand_of_levelOne
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Modular equation on H: Φ_N(j(σ),j(Nσ))=0
+
+Theorem statement: `ModularCurve.ModularPolynomialData.eval_E4_cube_div_discriminant_smul_eq_zero`
+(`eccf1cb1-5baa-5df8-bcbf-cef680be6556`), by Claude, 2026-09-05.
+
+Proof: submission `76aef4d5-47ab-5a83-ab70-a432a0a218cd`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a non-zero natural number $N$ and a packet `data` of modular-polynomial data of level $N$, that
+is, a polynomial $\Phi =$ `data.Φ` in $\mathbb Z[X][Y]$ which is monic in $Y$, whose degree in $Y$
+equals `dedekindPsi N` $= \sum_{d \mid N,\ d \text{ squarefree}} N/d$, and which satisfies the
+formal identity `Φ.eval₂ evalAtJ (jqN N) = 0` in the field of Laurent series over $\mathbb Q$, where
+`evalAtJ` is the ring homomorphism $\mathbb Z[X] \to \mathbb Q((q))$ evaluating at the formal
+$q$-expansion `jq` of $j$ and `jqN N` is the corresponding series attached to $N$. Let $\sigma,
+\sigma'$ be points of the upper half-plane whose coordinates satisfy $\sigma' = N\sigma$ in $\mathbb
+C$. The conclusion is that the complex polynomial in one variable obtained from $\Phi$ by applying
+to each coefficient in $\mathbb Z[X]$ the evaluation homomorphism sending $X$ to
+$E_4(\sigma)^3/\Delta(\sigma)$ and integers to their images in $\mathbb C$, when evaluated at
+$E_4(\sigma')^3/\Delta(\sigma')$, gives $0$; here $E_4$ is the normalised weight-four Eisenstein
+series and $\Delta$ the discriminant modular form of level one.
+
+This is the analytic form of the modular equation: the classical relation $\Phi_N(j(\sigma),
+j(N\sigma)) = 0$ on the upper half-plane, with $j$ written as $E_4^3/\Delta$ and with $\Phi_N$ taken
+from any packet of modular-polynomial data specified by its formal $q$-expansion identity. It is
+used to pass from the formal identity between $q$-expansions to values at points of $\mathfrak H$,
+and is cited in the corresponding statement for the other points of the $\Gamma_0(N)$-coset,
+[`ModularCurve.ModularPolynomialData.eval_E4_cube_div_discriminant_coset_eq_zero`]
+(thm.html#ModularCurve.ModularPolynomialData.eval_E4_cube_div_discriminant_coset_eq_zero).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ModularPolynomialData_eval_E4_cube_div_discriminant_smul_eq_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ModularPolynomialData_eval_E4_cube_div_discriminant_smul_eq_zero
+
+noncomputable section
+
+p2m_open "ModularCurve \
+  P2MW.S_ModularCurve_ModularPolynomialData_eval_E4_cube_div_discriminant_smul_eq_zero.ModularCurv\
+  e UpperHalfPlane Polynomial"
+open scoped MatrixGroups
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  jNum constantCoeff_jNum jq jqN evalAtJ evalAtJ_X ModularPolynomialData jqModC jqModC_rat \
+  map_jqModC coeffMap coeffMap_coeff jqModC_eq_qExpansion_E4_cube_div_discriminant"
+namespace DeepCosetAux
+p2m_open "ModularCurve"
+
+theorem gamma0_one_eq_top : CongruenceSubgroup.Gamma0 1 = ⊤ := by
+  ext A
+  simp [CongruenceSubgroup.Gamma0_mem, eq_iff_true_of_subsingleton]
+
+theorem gamma0_one_coe :
+    ((CongruenceSubgroup.Gamma0 1 : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) = 𝒮ℒ := by
+  simp [gamma0_one_eq_top, MonoidHom.range_eq_map]
+
+theorem heckeDiagMatrix_one : ModularForm.heckeDiagMatrix 1 = 1 := by
+  apply Units.ext
+  simp [Matrix.one_fin_two]
+
+theorem one_mem_sp (M : ℕ) : (1 : ℝ) ∈
+    ((CongruenceSubgroup.Gamma0 M : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)).strictPeriods
+      := by
+  rw [CongruenceSubgroup.strictPeriods_Gamma0]
+  exact AddSubgroup.mem_zmultiples 1
+
+def e4cubeSL : ModularForm 𝒮ℒ 12 :=
+  ModularForm.mcast (by norm_num) ((ModularForm.E₄.mul ModularForm.E₄).mul ModularForm.E₄)
+
+theorem coe_e4cubeSL : ⇑e4cubeSL = fun τ => (ModularForm.E₄ : ℍ → ℂ) τ ^ 3 := by
+  funext τ
+  change (((ModularForm.E₄.mul ModularForm.E₄).mul ModularForm.E₄ : ModularForm 𝒮ℒ _) : ℍ → ℂ) τ = _
+  rw [ModularForm.coe_mul, ModularForm.coe_mul]
+  simp only [Pi.mul_apply]
+  ring
+
+def deltaSL : ModularForm 𝒮ℒ 12 := CuspForm.toModularFormₗ CuspForm.discriminant
+
+theorem coe_deltaSL : ⇑deltaSL = ModularForm.discriminant := by
+  change ⇑(CuspForm.toModularFormₗ CuspForm.discriminant) = _
+  rw [← CuspForm.coe_discriminant]
+  rfl
+
+def e4cube1 :
+    ModularForm (CongruenceSubgroup.Gamma0 1) 12 := ModularForm.mcast rfl e4cubeSL gamma0_one_coe
+def delta1 :
+    ModularForm (CongruenceSubgroup.Gamma0 1) 12 := ModularForm.mcast rfl deltaSL gamma0_one_coe
+theorem coe_e4cube1 : ⇑e4cube1 = ⇑e4cubeSL := rfl
+theorem coe_delta1 : ⇑delta1 = ⇑deltaSL := rfl
+
+def An (f : ℍ → ℂ) : Prop := AnalyticAt ℂ (cuspFunction 1 f) 0
+
+theorem an_of_modularForm {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [Γ.HasDetPlusMinusOne]
+    (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) (f : ModularForm Γ k) : An ⇑f := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  exact UpperHalfPlane.analyticAt_cuspFunction_zero one_pos
+    (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (ModularFormClass.holo f)
+    (ModularFormClass.bdd_at_infty f)
+
+theorem An.mul {f g : ℍ → ℂ} (hf : An f) (hg : An g) : An (f * g) := by
+  unfold An at *
+  rw [UpperHalfPlane.cuspFunction_mul hf.continuousAt hg.continuousAt]
+  exact hf.mul hg
+
+theorem An.add {f g : ℍ → ℂ} (hf : An f) (hg : An g) : An (f + g) := by
+  unfold An at *
+  rw [UpperHalfPlane.cuspFunction_add hf.continuousAt hg.continuousAt]
+  exact hf.add hg
+
+theorem An.smul {f : ℍ → ℂ} (hf : An f) (c : ℂ) : An (c • f) := by
+  unfold An at *
+  rw [UpperHalfPlane.cuspFunction_smul hf.continuousAt]
+  exact hf.const_smul
+
+theorem qExpansion_finset_prod {ι : Type*} (s : Finset ι) (f : ι → ℍ → ℂ) (h : ∀ l ∈ s, An (f l))
+    (h1 : An (1 : ℍ → ℂ)) :
+    An (∏ l ∈ s, f l) ∧ qExpansion 1 (∏ l ∈ s, f l) = ∏ l ∈ s, qExpansion 1 (f l) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => exact ⟨by simpa using h1, by simp [UpperHalfPlane.qExpansion_one]⟩
+  | insert a s ha ih =>
+    obtain ⟨hA, hq⟩ := ih (fun l hl => h l (Finset.mem_insert_of_mem hl))
+    have hfa : An (f a) := h a (Finset.mem_insert_self a s)
+    rw [Finset.prod_insert ha, Finset.prod_insert ha]
+    exact ⟨hfa.mul hA, by rw [UpperHalfPlane.qExpansion_mul hfa hA, hq]⟩
+
+theorem qExpansion_finset_sum_smul {ι : Type*} (s : Finset ι) (c : ι → ℂ) (f : ι → ℍ → ℂ)
+    (h : ∀ l ∈ s, An (f l)) (h0 : An (0 : ℍ → ℂ)) :
+    An (∑ l ∈ s, c l • f l) ∧ qExpansion 1 (∑ l ∈ s, c l • f l) = ∑ l ∈ s, c l • qExpansion 1 (f l)
+      := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => exact ⟨by simpa using h0, by simp [UpperHalfPlane.qExpansion_zero]⟩
+  | insert a s ha ih =>
+    obtain ⟨hA, hq⟩ := ih (fun l hl => h l (Finset.mem_insert_of_mem hl))
+    have hfa : An (c a • f a) := (h a (Finset.mem_insert_self a s)).smul (c a)
+    rw [Finset.sum_insert ha, Finset.sum_insert ha]
+    refine ⟨hfa.add hA, ?_⟩
+    rw [UpperHalfPlane.qExpansion_add hfa hA, hq,
+      UpperHalfPlane.qExpansion_smul (h a (Finset.mem_insert_self a s))]
+
+theorem pow_mul_div_pow {K : Type*} [Field K] (x D : K) (hD : D ≠ 0) {k m : ℕ} (hk : k ≤ m) :
+    D ^ m * (x / D) ^ k = x ^ k * D ^ (m - k) := by
+  have hDk : D ^ k ≠ 0 := pow_ne_zero _ hD
+  calc D ^ m * (x / D) ^ k = D ^ (k + (m - k)) * (x / D) ^ k := by rw [Nat.add_sub_cancel' hk]
+    _ = D ^ (m - k) * (D ^ k * (x ^ k / D ^ k)) := by rw [_root_.pow_add, div_pow]; ring
+    _ = D ^ (m - k) * x ^ k := by rw [mul_div_assoc', mul_div_cancel_left₀ _ hDk]
+    _ = x ^ k * D ^ (m - k) := mul_comm _ _
+
+section Mono
+
+variable {Γ : Subgroup (GL (Fin 2) ℝ)} [Γ.HasDetPlusMinusOne]
+
+def fam (e δ eN δN : ModularForm Γ 12) (m n i k : ℕ) : Fin m ⊕ Fin n → ModularForm Γ 12 :=
+  Sum.elim (fun l : Fin m => if (l : ℕ) < k then e else δ) (fun l : Fin n => if (l : ℕ) < i then eN
+    else δN)
+
+theorem card_univ_mul (m n : ℕ) :
+    (((Finset.univ : Finset (Fin m ⊕ Fin n)).card : ℕ) : ℤ) * 12 = 12 * ((m + n : ℕ) : ℤ) := by
+  simp [Finset.card_univ, Fintype.card_sum, Fintype.card_fin]
+  ring
+
+def mono (e δ eN δN : ModularForm Γ 12) (m n i k : ℕ) : ModularForm Γ (12 * ((m + n : ℕ) : ℤ)) :=
+  ModularForm.mcast (card_univ_mul m n) (ModularForm.prodEqualWeights (s := Finset.univ) (fam e δ eN
+    δN m n i k))
+
+theorem prod_ite_pow {M : Type*} [CommMonoid M] (p q : ℕ) (hpq : q ≤ p) (x y : M) :
+    (∏ l : Fin p, if (l : ℕ) < q then x else y) = x ^ q * y ^ (p - q) := by
+  rw [Fin.prod_univ_eq_prod_range (fun l => if l < q then x else y) p, Finset.prod_ite,
+    Finset.prod_const,
+    Finset.prod_const]
+  congr 2
+  · rw [show (Finset.range p).filter (fun l => l < q) = Finset.range q from by
+      ext l; simp only [Finset.mem_filter, Finset.mem_range]; omega]
+    exact Finset.card_range q
+  · rw [show (Finset.range p).filter (fun l => ¬ l < q) = Finset.Ico q p from by
+      ext l; simp only [Finset.mem_filter, Finset.mem_range, Finset.mem_Ico]; omega]
+    exact Nat.card_Ico q p
+
+theorem coe_mono (e δ eN δN : ModularForm Γ 12) {m n i k : ℕ} (hi : i ≤ n) (hk : k ≤ m) :
+    ⇑(mono e δ eN δN m n i k) = (⇑e) ^ k * (⇑δ) ^ (m - k) * ((⇑eN) ^ i * (⇑δN) ^ (n - i)) := by
+  change ⇑(ModularForm.prodEqualWeights (s := Finset.univ) (fam e δ eN δN m n i k)) = _
+  rw [ModularForm.coe_prodEqualWeights, Fintype.prod_sum_type]
+  simp only [fam, Sum.elim_inl, Sum.elim_inr]
+  rw [show (∏ l : Fin m, ⇑(if (l : ℕ) < k then e else δ)) = ∏ l : Fin m, (if (l : ℕ) < k then (⇑e)
+    else (⇑δ)) from
+      Finset.prod_congr rfl (fun l _ => by split_ifs <;> rfl),
+    show (∏ l : Fin n, ⇑(if (l : ℕ) < i then eN else δN)) = ∏ l : Fin n, (if (l : ℕ) < i then (⇑eN)
+      else (⇑δN)) from
+      Finset.prod_congr rfl (fun l _ => by split_ifs <;> rfl),
+    prod_ite_pow m k hk, prod_ite_pow n i hi]
+
+def coeAddHom (k : ℤ) : ModularForm Γ k →+ (ℍ → ℂ) :=
+  { toFun := fun f => ⇑f, map_zero' := rfl, map_add' := fun _ _ => rfl }
+
+end Mono
+
+end ModularCurve.DeepCosetAux
+
+open ModularCurve.DeepCosetAux in
+theorem solution (N : ℕ) [NeZero N]
+    (data : ModularCurve.ModularPolynomialData N) (σ σ' : ℍ) (hσ' : (σ' : ℂ) = (N : ℂ) * σ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom ℂ)
+        ((ModularForm.E₄ : ℍ → ℂ) σ ^ 3 / ModularForm.discriminant σ))).eval
+      ((ModularForm.E₄ : ℍ → ℂ) σ' ^ 3 / ModularForm.discriminant σ') = 0 := by
+  classical
+  have hN : N ≠ 0 := NeZero.ne N
+  have hσ'pt : σ' = ModularForm.heckeDiagMatrix N • σ :=
+    UpperHalfPlane.ext (by rw [hσ', ModularForm.coe_heckeDiagMatrix_smul hN])
+  obtain ⟨e, he⟩ := ModularForm.exists_degeneracy_Gamma0 (show 1 * 1 ∣ N by simp) e4cube1
+  obtain ⟨δ, hδ⟩ := ModularForm.exists_degeneracy_Gamma0 (show 1 * 1 ∣ N by simp) delta1
+  obtain ⟨eN, heN⟩ := ModularForm.exists_degeneracy_Gamma0 (show N * 1 ∣ N by simp) e4cube1
+  obtain ⟨δN, hδN⟩ := ModularForm.exists_degeneracy_Gamma0 (show N * 1 ∣ N by simp) delta1
+  have he' : ⇑e = fun τ => (ModularForm.E₄ : ℍ → ℂ) τ ^ 3 := by
+    rw [he, heckeDiagMatrix_one]; funext τ; rw [one_smul, coe_e4cube1, coe_e4cubeSL]
+  have hδ' : ⇑δ = ModularForm.discriminant := by
+    rw [hδ, heckeDiagMatrix_one]; funext τ; rw [one_smul, coe_delta1, coe_deltaSL]
+  have heN' : ⇑eN = fun τ => e4cubeSL (ModularForm.heckeDiagMatrix N • τ) := by rw [heN]; rfl
+  have hδN' : ⇑δN = fun τ => deltaSL (ModularForm.heckeDiagMatrix N • τ) := by rw [hδN]; rfl
+  set A : LaurentSeries ℂ := ((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) : PowerSeries ℂ) :
+    LaurentSeries ℂ) with hA
+  set D : LaurentSeries ℂ := ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) :
+    LaurentSeries ℂ)
+    with hD
+  set J : LaurentSeries ℂ := jqModC ℂ with hJ
+  have hJAD : J = A ^ 3 / D := ModularCurve.jqModC_eq_qExpansion_E4_cube_div_discriminant
+  have hD0 : D ≠ 0 := by
+    intro h0
+    have : J = 0 := by rw [hJAD, h0, div_zero]
+    have h1 : J.coeff (-1) = 1 := by
+      rw [hJ, jqModC]
+      have h := HahnSeries.coeff_single_mul_add (a := (0 : ℤ)) (b := (-1 : ℤ)) (r := (1 : ℂ))
+        (x := HahnSeries.ofPowerSeries ℤ ℂ (jNum.map (Int.castRingHom ℂ)))
+      rw [zero_add, one_mul] at h
+      rw [h]
+      have h0' := HahnSeries.ofPowerSeries_apply_coeff (Γ := ℤ) (jNum.map (Int.castRingHom ℂ)) 0
+      rw [Nat.cast_zero] at h0'
+      rw [h0', PowerSeries.coeff_map, PowerSeries.coeff_zero_eq_constantCoeff_apply,
+        constantCoeff_jNum, map_one]
+    rw [this, HahnSeries.coeff_zero] at h1
+    exact zero_ne_one h1
+  have hΓ := one_mem_sp N
+  have hAn4 : An (ModularForm.E₄ : ℍ → ℂ) :=
+    an_of_modularForm one_mem_strictPeriods_SL ModularForm.E₄
+  have hqe4cube : ((qExpansion 1 (e4cubeSL : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) = A ^ 3 :=
+    by
+    have h3 : (e4cubeSL : ℍ → ℂ) = (ModularForm.E₄ : ℍ → ℂ) * (ModularForm.E₄ : ℍ → ℂ) *
+      (ModularForm.E₄ : ℍ → ℂ) :=
+      by
+      rw [coe_e4cubeSL]; funext τ; simp [pow_succ]
+    rw [h3, UpperHalfPlane.qExpansion_mul (hAn4.mul hAn4) hAn4, UpperHalfPlane.qExpansion_mul hAn4
+      hAn4, hA]
+    simp [pow_succ, PowerSeries.coe_mul]
+  have hqe : ((qExpansion 1 (e : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) = A ^ 3 := by
+    rw [show (e : ℍ → ℂ) = (e4cubeSL : ℍ → ℂ) from by rw [he', coe_e4cubeSL], hqe4cube]
+  have hqδ : ((qExpansion 1 (δ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) = D := by rw [hδ']
+  have hqeN : ((qExpansion 1 (eN : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) = qExpand ℂ N (A ^ 3)
+    :=
+    by
+    rw [heN', ModularForm.qExpansion_heckeDiagMatrix_smul_eq_qExpand_of_levelOne N e4cubeSL,
+      hqe4cube]
+  have hqδN : ((qExpansion 1 (δN : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) = qExpand ℂ N D := by
+    rw [hδN', ModularForm.qExpansion_heckeDiagMatrix_smul_eq_qExpand_of_levelOne N deltaSL,
+      coe_deltaSL]
+  set n : ℕ := data.Φ.natDegree with hn
+  set m : ℕ := (Finset.range (n + 1)).sup (fun i => (data.Φ.coeff i).natDegree) with hm
+  have hmi : ∀ i ∈ Finset.range (n + 1), (data.Φ.coeff i).natDegree ≤ m := fun i hi =>
+    Finset.le_sup (f := fun i => (data.Φ.coeff i).natDegree) hi
+  set c : ℕ → ℕ → ℝ := fun i k => (((data.Φ.coeff i).coeff k : ℤ) : ℝ) with hc
+  have an_mf : ∀ f : ModularForm (CongruenceSubgroup.Gamma0 N) 12, An ⇑f :=
+    fun f => an_of_modularForm hΓ f
+  have qexp_pow : ∀ (f : ℍ → ℂ) (hf : An f) (p : ℕ), An (f ^ p) ∧ qExpansion 1 (f ^ p) = qExpansion
+    1 f ^ p :=
+    by
+    intro f hf p
+    have := qExpansion_finset_prod (Finset.range p) (fun _ => f) (fun _ _ => hf)
+      (by simpa [ModularForm.one_coe_eq_one] using
+        an_of_modularForm hΓ (1 : ModularForm (CongruenceSubgroup.Gamma0 N) 0))
+    simpa [Finset.prod_const, Finset.card_range] using this
+  have an_mf' : ∀ f : ModularForm (CongruenceSubgroup.Gamma0 N) (12 * ((m + n : ℕ) : ℤ)), An ⇑f :=
+    fun f => an_of_modularForm hΓ f
+  have qexp_mono : ∀ i k, i ≤ n → k ≤ m → An ((mono e δ eN δN m n i k) : ℍ → ℂ) ∧
+      (((qExpansion 1 ((mono e δ eN δN m n i k) : ℍ → ℂ)) : PowerSeries ℂ) : LaurentSeries ℂ)
+        = (A ^ 3) ^ k * D ^ (m - k) * ((qExpand ℂ N (A ^ 3)) ^ i * (qExpand ℂ N D) ^ (n - i)) := by
+    intro i k hi hk
+    refine ⟨an_mf' _, ?_⟩
+    rw [coe_mono e δ eN δN hi hk]
+    obtain ⟨a1, q1⟩ := qexp_pow _ (an_mf e) k
+    obtain ⟨a2, q2⟩ := qexp_pow _ (an_mf δ) (m - k)
+    obtain ⟨a3, q3⟩ := qexp_pow _ (an_mf eN) i
+    obtain ⟨a4, q4⟩ := qexp_pow _ (an_mf δN) (n - i)
+    rw [UpperHalfPlane.qExpansion_mul (a1.mul a2) (a3.mul a4), UpperHalfPlane.qExpansion_mul a1 a2,
+      UpperHalfPlane.qExpansion_mul a3 a4, q1, q2, q3, q4]
+    simp only [PowerSeries.coe_mul, PowerSeries.coe_pow]
+    rw [hqe, hqδ, hqeN, hqδN]
+  let idx : Finset (ℕ × ℕ) := Finset.range (n + 1) ×ˢ Finset.range (m + 1)
+  let H : ModularForm (CongruenceSubgroup.Gamma0 N) (12 * ((m + n : ℕ) : ℤ)) :=
+    ∑ p ∈ idx, c p.1 p.2 • mono e δ eN δN m n p.1 p.2
+  have hidx : ∀ p ∈ idx, p.1 ≤ n ∧ p.2 ≤ m := by
+    intro p hp
+    simp only [idx, Finset.mem_product, Finset.mem_range] at hp
+    omega
+  have hHcoe : (H : ℍ → ℂ) = ∑ p ∈ idx, ((c p.1 p.2 : ℝ) : ℂ) • ((mono e δ eN δN m n p.1 p.2) : ℍ →
+    ℂ) :=
+    by
+    change coeAddHom _ H = _
+    rw [map_sum]
+    refine Finset.sum_congr rfl (fun p _ => ?_)
+    change ⇑(c p.1 p.2 • mono e δ eN δN m n p.1 p.2) = _
+    rw [FunLike.coe_smul]
+    funext τ
+    simp only [Pi.smul_apply, Complex.real_smul, smul_eq_mul]
+  have hformal : (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries ℂ)) J)).eval
+    (qExpand ℂ N J) = 0 :=
+    by
+    have h0 := data.eval_eq_zero
+    have h1 := congrArg (coeffMap (algebraMap ℚ ℂ)) h0
+    rw [map_zero, Polynomial.hom_eval₂] at h1
+    have hcomp : (coeffMap (algebraMap ℚ ℂ)).comp evalAtJ
+        = Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries ℂ)) J := by
+      refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+      rw [RingHom.coe_comp, Function.comp_apply, evalAtJ_X, Polynomial.coe_eval₂RingHom,
+        Polynomial.eval₂_X,
+        hJ, ← jqModC_rat]
+      exact map_jqModC (algebraMap ℚ ℂ)
+    have hjN : coeffMap (algebraMap ℚ ℂ) (jqN N) = qExpand ℂ N J := by
+      rw [hJ, ← map_jqModC (algebraMap ℚ ℂ) (K := ℚ), jqModC_rat]
+      change coeffMap (algebraMap ℚ ℂ) (qExpand ℚ N jq) = qExpand ℂ N (coeffMap (algebraMap ℚ ℂ) jq)
+      ext k
+      by_cases hk : (N : ℤ) ∣ k
+      · obtain ⟨r, rfl⟩ := hk
+        rw [coeffMap_coeff, qExpand_coeff_mul, qExpand_coeff_mul, coeffMap_coeff]
+      · rw [coeffMap_coeff, qExpand_coeff_of_not_dvd N _ hk, qExpand_coeff_of_not_dvd N _ hk,
+          map_zero]
+    rw [hcomp, hjN] at h1
+    rw [Polynomial.eval_map]
+    first
+    | exact h1
+  have hqH : qExpansion 1 (H : ℍ → ℂ) = 0 := by
+    apply HahnSeries.ofPowerSeries_injective (Γ := ℤ) (R := ℂ)
+    rw [map_zero]
+    show (((qExpansion 1 (H : ℍ → ℂ)) : PowerSeries ℂ) : LaurentSeries ℂ) = 0
+    rw [hHcoe]
+    obtain ⟨-, hq⟩ := qExpansion_finset_sum_smul idx (fun p => ((c p.1 p.2 : ℝ) : ℂ))
+      (fun p => ((mono e δ eN δN m n p.1 p.2) : ℍ → ℂ)) (fun p _ => an_mf' _)
+      (by
+        simpa [FunLike.coe_zero] using an_of_modularForm hΓ (0 : ModularForm
+          (CongruenceSubgroup.Gamma0 N) 0))
+    rw [hq, map_sum]
+    have hterm : ∀ p ∈ idx, ((((c p.1 p.2 : ℝ) : ℂ) • qExpansion 1 ((mono e δ eN δN m n p.1 p.2) : ℍ
+      → ℂ) : PowerSeries ℂ) :
+        LaurentSeries ℂ) = D ^ m * (qExpand ℂ N D) ^ n *
+          (HahnSeries.C ((c p.1 p.2 : ℝ) : ℂ) * J ^ p.2 * (qExpand ℂ N J) ^ p.1) := by
+      intro p hp
+      obtain ⟨hi, hk⟩ := hidx p hp
+      rw [PowerSeries.coe_smul, (qexp_mono p.1 p.2 hi hk).2, hJAD, map_div₀, map_pow]
+      have hDN0 : qExpand ℂ N D ≠ 0 := fun h => hD0 (qExpand_injective N (by rw [h, map_zero]))
+      rw [← HahnSeries.C_mul_eq_smul]
+      rw [show D ^ m * qExpand ℂ N D ^ n * (HahnSeries.C ((c p.1 p.2 : ℝ) : ℂ) * (A ^ 3 / D) ^ p.2 *
+            ((qExpand ℂ N A) ^ 3 / qExpand ℂ N D) ^ p.1)
+          = HahnSeries.C ((c p.1 p.2 : ℝ) : ℂ) * (D ^ m * (A ^ 3 / D) ^ p.2) *
+            (qExpand ℂ N D ^ n * ((qExpand ℂ N A) ^ 3 / qExpand ℂ N D) ^ p.1) by ring,
+        pow_mul_div_pow _ _ hD0 hk, pow_mul_div_pow _ _ hDN0 hi]
+      ring
+    rw [Finset.sum_congr rfl hterm, ← Finset.mul_sum]
+    suffices hsum : ∑ p ∈ idx, HahnSeries.C ((c p.1 p.2 : ℝ) : ℂ) * J ^ p.2 * (qExpand ℂ N J) ^ p.1
+      = 0 by
+      rw [hsum, mul_zero]
+    rw [← hformal, Polynomial.eval_map, Polynomial.eval₂_eq_sum_range' _ (Nat.lt_succ_self _),
+      Finset.sum_product]
+    refine Finset.sum_congr rfl (fun i hi => ?_)
+    rw [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_eq_sum_range' _ (Nat.lt_succ_of_le (hmi i
+      hi)), Finset.sum_mul]
+    refine Finset.sum_congr rfl (fun k _ => ?_)
+    simp only [hc, eq_intCast, Complex.ofReal_intCast]
+    rw [← map_intCast (HahnSeries.C : ℂ →+* LaurentSeries ℂ)]
+  have hH0 : H = 0 := (ModularForm.qExpansion_eq_zero_iff one_pos hΓ H).mp hqH
+  have hpt : (H : ℍ → ℂ) σ = 0 := by rw [hH0]; rfl
+  rw [hHcoe, Finset.sum_apply] at hpt
+  have hterm' : ∀ p ∈ idx, ((((c p.1 p.2 : ℝ) : ℂ)) • ((mono e δ eN δN m n p.1 p.2) : ℍ → ℂ)) σ
+      = ModularForm.discriminant σ ^ m * ModularForm.discriminant σ' ^ n *
+        (((c p.1 p.2 : ℝ) : ℂ) * ((ModularForm.E₄ : ℍ → ℂ) σ ^ 3 / ModularForm.discriminant σ) ^ p.2
+          *
+          ((ModularForm.E₄ : ℍ → ℂ) σ' ^ 3 / ModularForm.discriminant σ') ^ p.1) := by
+    intro p hp
+    obtain ⟨hi, hk⟩ := hidx p hp
+    rw [Pi.smul_apply, coe_mono e δ eN δN hi hk, smul_eq_mul]
+    simp only [Pi.mul_apply, Pi.pow_apply]
+    rw [he', hδ', heN', hδN', coe_e4cubeSL, coe_deltaSL]
+    simp only []
+    rw [← hσ'pt]
+    have hd1 : ModularForm.discriminant σ ≠ 0 := ModularForm.discriminant_ne_zero σ
+    have hd2 : ModularForm.discriminant σ' ≠ 0 := ModularForm.discriminant_ne_zero σ'
+    rw [show ModularForm.discriminant σ ^ m * ModularForm.discriminant σ' ^ n *
+          ((((c p.1 p.2 : ℝ) : ℂ)) * ((ModularForm.E₄ : ℍ → ℂ) σ ^ 3 / ModularForm.discriminant σ) ^
+            p.2 *
+            ((ModularForm.E₄ : ℍ → ℂ) σ' ^ 3 / ModularForm.discriminant σ') ^ p.1)
+        = (((c p.1 p.2 : ℝ) : ℂ)) * (ModularForm.discriminant σ ^ m *
+            ((ModularForm.E₄ : ℍ → ℂ) σ ^ 3 / ModularForm.discriminant σ) ^ p.2) *
+          (ModularForm.discriminant σ' ^ n * ((ModularForm.E₄ : ℍ → ℂ) σ' ^ 3 /
+            ModularForm.discriminant σ') ^ p.1) by
+            ring,
+      pow_mul_div_pow _ _ hd1 hk, pow_mul_div_pow _ _ hd2 hi]
+    ring
+  rw [Finset.sum_congr rfl hterm', ← Finset.mul_sum] at hpt
+  have hnz : ModularForm.discriminant σ ^ m * ModularForm.discriminant σ' ^ n ≠ 0 :=
+    mul_ne_zero (pow_ne_zero _ (ModularForm.discriminant_ne_zero σ)) (pow_ne_zero _
+      (ModularForm.discriminant_ne_zero σ'))
+  have hsum0 := (mul_eq_zero.mp hpt).resolve_left hnz
+  rw [Polynomial.eval_map, Polynomial.eval₂_eq_sum_range' _ (Nat.lt_succ_self _)]
+  rw [Finset.sum_product] at hsum0
+  rw [← hsum0]
+  refine Finset.sum_congr rfl (fun i hi => ?_)
+  rw [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_eq_sum_range' _ (Nat.lt_succ_of_le (hmi i hi)),
+    Finset.sum_mul]
+  refine Finset.sum_congr rfl (fun k _ => ?_)
+  simp only [hc, eq_intCast, Complex.ofReal_intCast]
+
+end
+
+end S_ModularCurve_ModularPolynomialData_eval_E4_cube_div_discriminant_smul_eq_zero
+end P2MW
+export P2MW.S_ModularCurve_ModularPolynomialData_eval_E4_cube_div_discriminant_smul_eq_zero
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane
+theorem ModularCurve.ModularPolynomialData.eval_E4_cube_div_discriminant_smul_eq_zero (N : ℕ)
+    [NeZero N]
+    (data : ModularCurve.ModularPolynomialData N) (σ σ' : ℍ) (hσ' : (σ' : ℂ) = (N : ℂ) * σ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom ℂ)
+        ((ModularForm.E₄ : ℍ → ℂ) σ ^ 3 / ModularForm.discriminant σ))).eval
+      ((ModularForm.E₄ : ℍ → ℂ) σ' ^ 3 / ModularForm.discriminant σ') = 0 :=
+  solution N data σ σ' hσ'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_eval_jLattice_eq_zero_of_isAddCyclic.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_eval_jLattice_eq_zero_of_isAddCyclic.lean
new file mode 100644
index 0000000000..aea8902879
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_eval_jLattice_eq_zero_of_isAddCyclic.lean
@@ -0,0 +1,94 @@
+/-
+Based on Prove2Me node ModularCurve.ModularPolynomialData.eval_jLattice_eq_zero_of_isAddCyclic
+(4bb6612b-c26e-5d42-8b4a-afd082885716) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 93c8ef3d-c745-5267-8679-807c0a52bc0f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_PeriodPair_Uniformization
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_E4_cube_div_discriminant_coset_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_jLattice_ofTau
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Φ_N(j(Λ),j(Λ'))=0 for cyclic sublattices of index N
+
+Theorem statement: `ModularCurve.ModularPolynomialData.eval_jLattice_eq_zero_of_isAddCyclic`
+(`4bb6612b-c26e-5d42-8b4a-afd082885716`), by Claude, 2026-09-05.
+
+Proof: submission `93c8ef3d-c745-5267-8679-807c0a52bc0f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and let `data` be a [`ModularCurve.ModularPolynomialData
+N`](def/ModularCurve_X0.html#L215), that is, a polynomial $\Phi \in (\mathbb{Z}[X])[Y]$ which is
+monic in $Y$, whose degree in $Y$ equals the Dedekind function value $\psi(N) = \sum_{d \mid N,\ d
+\text{ squarefree}} N/d$, and which is annihilated by the substitution sending the coefficient
+variable to the $q$-expansion of $j$ and $Y$ to the series `jqN N` in Laurent series over
+$\mathbb{Q}$. Let $L$ and $L'$ be period pairs, i.e. lattices in $\mathbb{C}$ given by a pair of
+periods, such that the lattice of $L'$ is contained, as a subset of $\mathbb{C}$, in the lattice of
+$L$, such that the index of the additive subgroup of $L$'s lattice cut out by $L'$'s lattice equals
+$N$, and such that the corresponding quotient group is cyclic. Then, writing $j(M) =
+1728\,g_2(M)^3/(g_2(M)^3 - 27 g_3(M)^2)$ for the lattice invariant `jLattice`, the polynomial
+obtained from $\Phi$ by evaluating each coefficient in $\mathbb{C}$ at $j(L)$ (along $\mathbb{Z} \to
+\mathbb{C}$) vanishes at $j(L')$; that is, $\Phi\bigl(j(L), j(L')\bigr) = 0$.
+
+This is the analytic description of $Y_0(N)(\mathbb{C})$ as the zero locus of the modular
+polynomial: a pair of $j$-invariants of lattices related by a cyclic sublattice inclusion of index
+$N$ is a root of $\Phi_N$. It feeds the transfer of the modular equation to elliptic curves, being
+used for the statements about $j$-invariants of curves linked by an isogeny whose kernel is cyclic
+of the appropriate order.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ModularPolynomialData_eval_jLattice_eq_zero_of_isAddCyclic.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ModularPolynomialData_eval_jLattice_eq_zero_of_isAddCyclic
+
+open UpperHalfPlane
+
+theorem solution
+    (N : ℕ) [NeZero N] (data : ModularCurve.ModularPolynomialData N) (L L' : PeriodPair)
+    (hsub : (L'.lattice : Set ℂ) ⊆ L.lattice) (hidx : PeriodPair.sublatticeIndex L L' = N)
+    (hcyc : IsAddCyclic (PeriodPair.sublatticeQuotient L L')) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom ℂ) L.jLattice)).eval L'.jLattice = 0 := by
+  obtain ⟨a, b, d, τ, σ, habd, hσ, hjL, hjL'⟩ :=
+    PeriodPair.exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic L L' hsub hidx hcyc
+  rw [hjL, hjL', PeriodPair.jLattice_ofTau, PeriodPair.jLattice_ofTau]
+  exact ModularCurve.ModularPolynomialData.eval_E4_cube_div_discriminant_coset_eq_zero
+    N data habd τ σ hσ
+
+end S_ModularCurve_ModularPolynomialData_eval_jLattice_eq_zero_of_isAddCyclic
+end P2MW
+export P2MW.S_ModularCurve_ModularPolynomialData_eval_jLattice_eq_zero_of_isAddCyclic (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane
+theorem ModularCurve.ModularPolynomialData.eval_jLattice_eq_zero_of_isAddCyclic
+    (N : ℕ) [NeZero N] (data : ModularCurve.ModularPolynomialData N) (L L' : PeriodPair)
+    (hsub : (L'.lattice : Set ℂ) ⊆ L.lattice) (hidx : PeriodPair.sublatticeIndex L L' = N)
+    (hcyc : IsAddCyclic (PeriodPair.sublatticeQuotient L L')) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom ℂ) L.jLattice)).eval L'.jLattice = 0 :=
+  solution N data L L' hsub hidx hcyc
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_mul_eq_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_mul_eq_zero.lean
new file mode 100644
index 0000000000..3acbe48612
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_mul_eq_zero.lean
@@ -0,0 +1,119 @@
+/-
+Based on Prove2Me node ModularCurve.ModularPolynomialData.eval_jqNModC_mul_eq_zero
+(ab724e6a-4529-5d24-9a04-8ca86401ed38) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 06a8b185-979e-5851-afda-578c5c1f8736
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_injective
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Modular equation Φ_ℓ(j(qᵈ),j(q^{dℓ}))=0 over any base ring
+
+Theorem statement: `ModularCurve.ModularPolynomialData.eval_jqNModC_mul_eq_zero`
+(`ab724e6a-4529-5d24-9a04-8ca86401ed38`), by Claude, 2026-09-05.
+
+Proof: submission `06a8b185-979e-5851-afda-578c5c1f8736`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell \ge 1$ and let `data` be a modular-polynomial datum of level $\ell$, that is, a
+two-variable integral polynomial $\Phi =$ `data.Φ` $\in (\mathbb{Z}[X])[Y]$ which is monic in $Y$,
+whose degree in $Y$ equals $\psi(\ell) = \sum_{d \mid \ell,\ d \text{ squarefree}} \ell/d$, and
+which satisfies $\Phi(j(q), j(q^{\ell})) = 0$ in the field of rational Laurent series
+$\mathbb{Q}((q))$, the evaluation being: coefficients in $\mathbb{Z}[X]$ sent to $\mathbb{Q}((q))$
+by $X \mapsto$ the $q$-expansion $j(q)$, and $Y \mapsto$ its image under the exponent-scaling ring
+endomorphism $q \mapsto q^{\ell}$. Let $K$ be any commutative ring and $d \ge 1$. Write `jqNModC K
+d` for the Laurent series over $K$ obtained from $q^{-1}$ times the image in $K[[q]]$ of the
+integral power series part of $j$ by multiplying all exponents by $d$, i.e. for the reduction to $K$
+of the $q$-expansion of $j(q^{d})$. Then $\Phi$ evaluated with coefficients in $\mathbb{Z}[X]$
+mapped to $K((q))$ by $X \mapsto$ `jqNModC K d` and with $Y \mapsto$ `jqNModC K (d * ℓ)` is $0$ in
+$K((q))$.
+
+This is the classical modular equation $\Phi_\ell(j(q^{d}), j(q^{d\ell})) = 0$, transported from its
+defining identity over $\mathbb{Q}$ to the Laurent series ring over an arbitrary commutative ring
+$K$ and to an arbitrary scaling $q \mapsto q^{d}$ of the variable. It is the basic algebraic
+relation used throughout the treatment of modular curves in characteristic $p$, for instance in
+computing the relative degree of $K(j(q^{d}))$-extensions generated by $j(q^{d\ell})$ and in the
+localisation arguments for the reduction of $X_0$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ModularPolynomialData_eval_jqNModC_mul_eq_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ModularPolynomialData_eval_jqNModC_mul_eq_zero
+
+open ModularCurve IntermediateField Polynomial
+
+private theorem coeffMap_jqNModC {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S) (n : ℕ)
+    [NeZero n] :
+    coeffMap f (jqNModC R n) = jqNModC S n := by
+  unfold jqNModC
+  rw [coeffMap_qExpand]
+  exact congrArg (qExpand S n) (map_jqModC f)
+
+private theorem coeffMap_eval₂_jqNModC {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S)
+    (Φ : Polynomial (Polynomial ℤ)) (d e : ℕ) [NeZero d] [NeZero e] :
+    coeffMap f (Φ.eval₂ (aeval (R := ℤ) (jqNModC R d)).toRingHom (jqNModC R e))
+      = Φ.eval₂ (aeval (R := ℤ) (jqNModC S d)).toRingHom (jqNModC S e) := by
+  rw [Polynomial.hom_eval₂, coeffMap_jqNModC]
+  congr 1
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp [coeffMap_jqNModC]
+
+private theorem eval₂_rat_of_data {ℓ : ℕ} [NeZero ℓ] (data : ModularPolynomialData ℓ) (d : ℕ)
+    [NeZero d] :
+    data.Φ.eval₂ (aeval (R := ℤ) (jqNModC ℚ d)).toRingHom (jqNModC ℚ (d * ℓ)) = 0 := by
+  have hcomp : (qExpand ℚ d).comp evalAtJ = (aeval (R := ℤ) (jqNModC ℚ d)).toRingHom := by
+    refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+    simp [evalAtJ]
+    rfl
+  have := congrArg (qExpand ℚ d) data.eval_eq_zero
+  rw [map_zero, Polynomial.hom_eval₂, hcomp, jqN, qExpand_qExpand] at this
+  exact this
+
+theorem solution {ℓ : ℕ} [NeZero ℓ] (data : ModularCurve.ModularPolynomialData ℓ) (K : Type*)
+    [CommRing K] (d : ℕ) [NeZero d] :
+    data.Φ.eval₂ (Polynomial.aeval (R := ℤ) (ModularCurve.jqNModC K d)).toRingHom
+      (ModularCurve.jqNModC K (d * ℓ)) = 0 := by
+  have hZ : data.Φ.eval₂ (aeval (R := ℤ) (jqNModC ℤ d)).toRingHom (jqNModC ℤ (d * ℓ)) = 0 := by
+    apply coeffMap_injective (f := Int.castRingHom ℚ) Int.cast_injective
+    rw [coeffMap_eval₂_jqNModC, map_zero]
+    exact eval₂_rat_of_data data d
+  have := congrArg (coeffMap (Int.castRingHom K)) hZ
+  rwa [coeffMap_eval₂_jqNModC, map_zero] at this
+
+end S_ModularCurve_ModularPolynomialData_eval_jqNModC_mul_eq_zero
+end P2MW
+export P2MW.S_ModularCurve_ModularPolynomialData_eval_jqNModC_mul_eq_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.ModularPolynomialData.eval_jqNModC_mul_eq_zero {ℓ : ℕ} [NeZero ℓ]
+    (data : ModularCurve.ModularPolynomialData ℓ) (K : Type*) [CommRing K] (d : ℕ) [NeZero d] :
+    data.Φ.eval₂ (Polynomial.aeval (R := ℤ) (ModularCurve.jqNModC K d)).toRingHom
+      (ModularCurve.jqNModC K (d * ℓ)) = 0 :=
+  solution data K d
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_of_mul_eq_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_of_mul_eq_zero.lean
new file mode 100644
index 0000000000..151916ae37
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_of_mul_eq_zero.lean
@@ -0,0 +1,125 @@
+/-
+Based on Prove2Me node ModularCurve.ModularPolynomialData.eval_jqNModC_of_mul_eq_zero
+(857041f0-823c-5465-a742-fd4e66afc586) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4553c6bb-5dea-52bf-98f9-38d0d6cd8b62
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_injective
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Swapped modular equation Φ_ℓ(j(q^{dℓ}),j(qᵈ))=0 over any ring
+
+Theorem statement: `ModularCurve.ModularPolynomialData.eval_jqNModC_of_mul_eq_zero`
+(`857041f0-823c-5465-a742-fd4e66afc586`), by Claude, 2026-09-05.
+
+Proof: submission `4553c6bb-5dea-52bf-98f9-38d0d6cd8b62`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a nonzero natural number and let `data` be a `ModularPolynomialData ℓ`, that is, a
+polynomial $\Phi =$ `data.Φ` in $(\mathbb{Z}[X])[Y]$ which is monic in $Y$, whose $Y$-degree equals
+$\sum_{e \mid \ell,\ e \text{ squarefree}} \ell/e$, and which satisfies the relation
+$\Phi(\mathrm{jq}, \mathrm{jqN}\,\ell) = 0$ in $\mathbb{Q}((q))$, obtained by sending the
+coefficient variable $X$ to the $q$-expansion $\mathrm{jq}$ of $j$ and the variable $Y$ to its
+substitution $q \mapsto q^{\ell}$. Assume moreover `EvalSymm data.Φ`: for all Laurent series $x, y$
+over $\mathbb{Q}$, substituting $x$ for $X$ and $y$ for $Y$ gives the same value as substituting $y$
+for $X$ and $x$ for $Y$. Let $K$ be any commutative ring and $d$ a nonzero natural number. Then, in
+the Laurent series ring $K((q))$, evaluating $\Phi$ with coefficient variable $X \mapsto$ `jqNModC K
+(d * ℓ)` and variable $Y \mapsto$ `jqNModC K d` yields $0$, where `jqNModC K N` is the image in
+$K((q))$ of the $q$-expansion of $j$ (coefficients reduced along $\mathbb{Z} \to K$) after the
+substitution $q \mapsto q^{N}$. Note the order of the two arguments: the relation asserted is
+$\Phi(j(q^{d\ell}), j(q^{d})) = 0$.
+
+This is the modular equation of level $\ell$ transported to the pair of $q$-expansions
+$j(q^{d\ell})$, $j(q^{d})$, with coefficients in an arbitrary commutative ring and with the two
+arguments in the order opposite to the defining relation. It is the basic algebraic relation used
+downstream to bound degrees of the extensions generated by the series `jqNModC K d`, for instance in
+the computation of the relative degree of $\mathbb{Q}(j(q^{d}))$-adjunctions as the Dedekind
+$\psi$-value, and in the reduction of such data modulo $p$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ModularPolynomialData_eval_jqNModC_of_mul_eq_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ModularPolynomialData_eval_jqNModC_of_mul_eq_zero
+
+open ModularCurve IntermediateField Polynomial
+
+private theorem coeffMap_jqNModC {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S) (n : ℕ)
+    [NeZero n] :
+    coeffMap f (jqNModC R n) = jqNModC S n := by
+  unfold jqNModC
+  rw [coeffMap_qExpand]
+  exact congrArg (qExpand S n) (map_jqModC f)
+
+private theorem coeffMap_eval₂_jqNModC {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S)
+    (Φ : Polynomial (Polynomial ℤ)) (d e : ℕ) [NeZero d] [NeZero e] :
+    coeffMap f (Φ.eval₂ (aeval (R := ℤ) (jqNModC R d)).toRingHom (jqNModC R e))
+      = Φ.eval₂ (aeval (R := ℤ) (jqNModC S d)).toRingHom (jqNModC S e) := by
+  rw [Polynomial.hom_eval₂, coeffMap_jqNModC]
+  congr 1
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp [coeffMap_jqNModC]
+
+private theorem eval₂_rat_of_data {ℓ : ℕ} [NeZero ℓ] (data : ModularPolynomialData ℓ) (d : ℕ)
+    [NeZero d] :
+    data.Φ.eval₂ (aeval (R := ℤ) (jqNModC ℚ d)).toRingHom (jqNModC ℚ (d * ℓ)) = 0 := by
+  have hcomp : (qExpand ℚ d).comp evalAtJ = (aeval (R := ℤ) (jqNModC ℚ d)).toRingHom := by
+    refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+    simp [evalAtJ]
+    rfl
+  have := congrArg (qExpand ℚ d) data.eval_eq_zero
+  rw [map_zero, Polynomial.hom_eval₂, hcomp, jqN, qExpand_qExpand] at this
+  exact this
+
+theorem solution {ℓ : ℕ} [NeZero ℓ] (data : ModularCurve.ModularPolynomialData ℓ)
+    (hsymm : ModularCurve.EvalSymm data.Φ) (K : Type*) [CommRing K] (d : ℕ) [NeZero d] :
+    data.Φ.eval₂ (Polynomial.aeval (R := ℤ) (ModularCurve.jqNModC K (d * ℓ))).toRingHom
+      (ModularCurve.jqNModC K d) = 0 := by
+  have hQ : data.Φ.eval₂ (aeval (R := ℤ) (jqNModC ℚ (d * ℓ))).toRingHom (jqNModC ℚ d) = 0 := by
+    rw [hsymm]
+    exact eval₂_rat_of_data data d
+  have hZ : data.Φ.eval₂ (aeval (R := ℤ) (jqNModC ℤ (d * ℓ))).toRingHom (jqNModC ℤ d) = 0 := by
+    apply coeffMap_injective (f := Int.castRingHom ℚ) Int.cast_injective
+    rw [coeffMap_eval₂_jqNModC, map_zero]
+    exact hQ
+  have := congrArg (coeffMap (Int.castRingHom K)) hZ
+  rwa [coeffMap_eval₂_jqNModC, map_zero] at this
+
+end S_ModularCurve_ModularPolynomialData_eval_jqNModC_of_mul_eq_zero
+end P2MW
+export P2MW.S_ModularCurve_ModularPolynomialData_eval_jqNModC_of_mul_eq_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.ModularPolynomialData.eval_jqNModC_of_mul_eq_zero {ℓ : ℕ} [NeZero ℓ]
+    (data : ModularCurve.ModularPolynomialData ℓ) (hsymm : ModularCurve.EvalSymm data.Φ) (K : Type*)
+    [CommRing K] (d : ℕ) [NeZero d] :
+    data.Φ.eval₂ (Polynomial.aeval (R := ℤ) (ModularCurve.jqNModC K (d * ℓ))).toRingHom
+      (ModularCurve.jqNModC K d) = 0 :=
+  solution data hsymm K d
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_hasRamBound_three_of_isRoot_at_zero_of_odd.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_hasRamBound_three_of_isRoot_at_zero_of_odd.lean
new file mode 100644
index 0000000000..39df21a610
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_hasRamBound_three_of_isRoot_at_zero_of_odd.lean
@@ -0,0 +1,321 @@
+/-
+Based on Prove2Me node ModularCurve.ModularPolynomialData.hasRamBound_three_of_isRoot_at_zero_of_odd
+(dbb0d3a2-2171-5545-9f0e-e7d76d439858) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7b716834-9ae5-5123-b355-eb8cd0febb8e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_RamificationBound
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import Mathlib.Algebra.CharP.Invertible
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_mem_puiseuxRamSubfield_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental_of_odd
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_isUnit_discriminant_and_c4_cube_eq_mul_X_cube_powerSeries
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_hasRamBound_one_of_nsmul_eq_zero_of_isUnit_discriminant_powerSeries
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Roots of Φ_N(t,Y) over ℚ̄ have ramification bound 3 (N odd)
+
+Theorem statement: `ModularCurve.ModularPolynomialData.hasRamBound_three_of_isRoot_at_zero_of_odd`
+(`dbb0d3a2-2171-5545-9f0e-e7d76d439858`), by Claude, 2026-09-05.
+
+Proof: submission `7b716834-9ae5-5123-b355-eb8cd0febb8e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number with $N \neq 0$ and $N$ odd, and let `data` be a piece of modular
+polynomial data of level $N$: a polynomial $\Phi \in \mathbb Z[X][Y]$ which is monic (in $Y$), whose
+degree equals $\sum_{d \mid N,\ d \text{ squarefree}} N/d$, and which satisfies $\Phi = 0$ after
+evaluating its $\mathbb Z[X]$-coefficients by `evalAtJ`, the ring homomorphism $\mathbb Z[X] \to
+\mathbb Q((q))$ sending $X$ to the $q$-expansion `jq` of $j$, at the element `jqN N` (the
+corresponding expansion at level $N$). Let $r$ be an element of the Hahn series field
+$\mathrm{HahnSeries}\ \mathbb Q\ \overline{\mathbb Q}$, with rational exponents and coefficients in
+`AlgebraicClosure ℚ`. Assume $r$ is a root of the one-variable polynomial obtained from $\Phi$ by
+mapping each coefficient through evaluation of $\mathbb Z[X]$ at the monomial $t =$
+`HahnSeries.single 1 1`, along the canonical map $\mathbb Z \to \mathrm{HahnSeries}\ \mathbb Q\
+\overline{\mathbb Q}$; that is, $\Phi(t, r) = 0$. The conclusion is [`HahnSeries.HasRamBound 3
+r`](def/HahnSeries_RamificationBound.html#L32), i.e. the support of $r$ is contained in the range of
+$k \mapsto k/3$ for $k \in \mathbb Z$, so $r$ is a Puiseux series in $t^{1/3}$.
+
+In classical terms: taking $t = j$ as a local parameter on the $j$-line at $j = 0$, the roots of
+$\Phi_N(t,Y)$ are the local branches of $X_0(N)$ above $j = 0$, and the assertion is that the
+ramification index of $X_0(N) \to X(1)$ at each such point divides $3$, reflecting the order-$3$
+stabiliser of the elliptic point $\rho = e^{2\pi i/3}$ in $\mathrm{PSL}_2(\mathbb Z)$. It feeds the
+divisibility statements
+[`ModularCurve.ord_jBar_dvd_three_of_odd`](thm.html#ModularCurve.ord_jBar_dvd_three_of_odd),
+[`ModularCurve.ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound`]
+(thm.html#ModularCurve.ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound)
+and
+[`ModularCurve.ord_jBar_sub_1728_dvd_two_of_odd`]
+(thm.html#ModularCurve.ord_jBar_sub_1728_dvd_two_of_odd).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ModularPolynomialData_hasRamBound_three_of_isRoot_at_zero_of_odd.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ModularPolynomialData_hasRamBound_three_of_isRoot_at_zero_of_odd
+
+
+p2m_open "HahnSeries Polynomial WeierstrassCurve~specialize"
+
+local notation "ℚ̄" => AlgebraicClosure ℚ
+local notation "𝕂" => HahnSeries ℚ (AlgebraicClosure ℚ)
+
+noncomputable section
+
+namespace P2MWs13
+namespace Wire
+
+variable {K : Type*} [Field K]
+
+def hahnExpMul (n : ℕ) (hn : 0 < n) : HahnSeries ℚ K →+* HahnSeries ℚ K :=
+  HahnSeries.embDomainRingHom (AddMonoidHom.mulRight (n : ℚ))
+    (mul_left_injective₀ (Nat.cast_ne_zero.mpr hn.ne'))
+    (fun _ _ => mul_le_mul_iff_of_pos_right (Nat.cast_pos.mpr hn))
+
+@[scoped simp] theorem hahnExpMul_single (n : ℕ) (hn : 0 < n) (q : ℚ) (c : K) :
+    hahnExpMul n hn (HahnSeries.single q c) = HahnSeries.single (q * n) c := by
+  unfold hahnExpMul
+  rw [embDomainRingHom_apply, embDomain_single]
+  rfl
+
+@[scoped simp] theorem hahnExpMul_coeff_mul (n : ℕ) (hn : 0 < n) (r : HahnSeries ℚ K) (q : ℚ) :
+    (hahnExpMul n hn r).coeff (q * n) = r.coeff q :=
+  HahnSeries.embDomain_coeff
+
+theorem hasRamBound_one_hahnExpMul_iff (n : ℕ) (hn : 0 < n) (r : HahnSeries ℚ K) :
+    HasRamBound 1 (hahnExpMul n hn r) ↔ HasRamBound n r := by
+  have hnQ : (n : ℚ) ≠ 0 := Nat.cast_ne_zero.mpr hn.ne'
+  constructor
+  · intro h q hq
+    have hnq : q * n ∈ (hahnExpMul n hn r).support := by
+      rw [HahnSeries.mem_support, hahnExpMul_coeff_mul]; exact hq
+    obtain ⟨k, hk⟩ := h hnq
+    refine ⟨k, ?_⟩
+    simp only [Nat.cast_one, div_one] at hk
+    field_simp
+    linarith
+  · intro h q hq
+    obtain ⟨p, rfl⟩ : ∃ p : ℚ, p * n = q := ⟨q / n, div_mul_cancel₀ q hnQ⟩
+    have hp : p ∈ r.support := by
+      rw [HahnSeries.mem_support, ← hahnExpMul_coeff_mul n hn]; exact hq
+    obtain ⟨k, hk⟩ := h hp
+    refine ⟨k, ?_⟩
+    simp only [Nat.cast_one, div_one]
+    field_simp at hk
+    linarith [hk]
+
+abbrev spec (Φ : Polynomial (Polynomial ℤ)) (j₀ : HahnSeries ℚ K) : Polynomial (HahnSeries ℚ K) :=
+  Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ K)) j₀)
+
+theorem hahnExpMul_comp_eval (n : ℕ) (hn : 0 < n) (j₀ : HahnSeries ℚ K) :
+    (hahnExpMul n hn).comp (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ K)) j₀)
+      = Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ K)) (hahnExpMul n hn j₀) := by
+  refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+  simp [Polynomial.eval₂RingHom]
+
+theorem spec_hahnExpMul (n : ℕ) (hn : 0 < n) (Φ : Polynomial (Polynomial ℤ)) (j₀ : HahnSeries ℚ K) :
+    spec Φ (hahnExpMul n hn j₀) = (spec Φ j₀).map (hahnExpMul n hn) := by
+  rw [spec, spec, Polynomial.map_map, hahnExpMul_comp_eval]
+
+theorem hasRamBound_one_ofPowerSeries (p : PowerSeries K) :
+    HasRamBound 1 (HahnSeries.ofPowerSeries ℚ K p) := by
+  intro q hq
+  have hq' : q ∈ Set.range ((↑) : ℕ → ℚ) := by
+    by_contra h
+    rw [HahnSeries.mem_support, HahnSeries.ofPowerSeries_apply] at hq
+    exact hq (HahnSeries.embDomain_of_notMem_range (by simpa using h))
+  obtain ⟨m, rfl⟩ := hq'
+  exact ⟨(m : ℤ), by push_cast; ring⟩
+
+theorem algebraMap_eq_C (a : K) : algebraMap K (HahnSeries ℚ K) a = HahnSeries.C a := by
+  have h1 : algebraMap K (PowerSeries K) a = PowerSeries.C a := by simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+
+theorem transcendental_single_one : Transcendental K (HahnSeries.single (1 : ℚ) (1 : K)) := by
+  rw [transcendental_iff_injective]
+  have heq : (Polynomial.aeval (R := K) (HahnSeries.single (1:ℚ) (1:K))).toRingHom
+      = (HahnSeries.ofPowerSeries ℚ K).comp (Polynomial.coeToPowerSeries.ringHom (R := K)) := by
+    refine Polynomial.ringHom_ext (fun a => ?_) ?_
+    · change Polynomial.aeval (R := K) (HahnSeries.single (1:ℚ) (1:K)) (Polynomial.C a) = _
+      rw [Polynomial.aeval_C, algebraMap_eq_C,
+        RingHom.coe_comp, Function.comp_apply, Polynomial.coeToPowerSeries.ringHom_apply,
+        Polynomial.coe_C, HahnSeries.ofPowerSeries_C]
+    · change Polynomial.aeval (R := K) (HahnSeries.single (1:ℚ) (1:K)) Polynomial.X = _
+      rw [Polynomial.aeval_X, RingHom.coe_comp, Function.comp_apply,
+        Polynomial.coeToPowerSeries.ringHom_apply, Polynomial.coe_X, HahnSeries.ofPowerSeries_X]
+  intro p q hpq
+  have hpq' : (HahnSeries.ofPowerSeries ℚ K) (p : PowerSeries K)
+      = (HahnSeries.ofPowerSeries ℚ K) (q : PowerSeries K) := by
+    have hp := congrFun (congrArg DFunLike.coe heq) p
+    have hq := congrFun (congrArg DFunLike.coe heq) q
+    simp only [AlgHom.toRingHom_eq_coe, RingHom.coe_coe, RingHom.coe_comp,
+      Function.comp_apply, Polynomial.coeToPowerSeries.ringHom_apply] at hp hq
+    rw [← hp, ← hq]; exact hpq
+  exact Polynomial.coe_injective K (HahnSeries.ofPowerSeries_injective hpq')
+
+theorem transcendental_rat_of_qbar (x : 𝕂) (h : Transcendental ℚ̄ x) : Transcendental ℚ x := by
+  rintro ⟨p, hp0, hpx⟩
+  refine h ⟨p.map (algebraMap ℚ ℚ̄),
+    (Polynomial.map_ne_zero_iff (algebraMap ℚ ℚ̄).injective).mpr hp0, ?_⟩
+  rw [Polynomial.aeval_def, Polynomial.eval₂_map,
+    Subsingleton.elim ((algebraMap ℚ̄ 𝕂).comp (algebraMap ℚ ℚ̄)) (algebraMap ℚ 𝕂),
+    ← Polynomial.aeval_def]
+  exact hpx
+
+theorem transcendental_single_three :
+    Transcendental ℚ (HahnSeries.single (3 : ℚ) (1 : ℚ̄) : 𝕂) := by
+  refine transcendental_rat_of_qbar _ (fun halg => ?_)
+  refine transcendental_single_one (K := ℚ̄) (IsAlgebraic.of_pow (n := 3) (by norm_num) ?_)
+  rw [HahnSeries.single_pow, one_pow]
+  have h3 : (3 : ℕ) • (1 : ℚ) = 3 := by norm_num
+  rwa [h3]
+
+theorem transcendental_1728_add_single_two :
+    Transcendental ℚ ((1728 : 𝕂) + HahnSeries.single (2 : ℚ) (1 : ℚ̄)) := by
+  refine transcendental_rat_of_qbar _ (fun halg => ?_)
+  have h1728 : IsAlgebraic ℚ̄ ((1728 : ℕ) : 𝕂) := isAlgebraic_natCast 1728
+  rw [Nat.cast_ofNat] at h1728
+  have hsq : IsAlgebraic ℚ̄ (HahnSeries.single (2 : ℚ) (1 : ℚ̄) : 𝕂) := by
+    have := (IsIntegral.sub halg.isIntegral h1728.isIntegral).isAlgebraic
+    simpa using this
+  refine transcendental_single_one (K := ℚ̄) (IsAlgebraic.of_pow (n := 2) (by norm_num) ?_)
+  rw [HahnSeries.single_pow, one_pow]
+  have h2 : (2 : ℕ) • (1 : ℚ) = 2 := by norm_num
+  rwa [h2]
+
+theorem j_eq_single_three_one (𝓔 : WeierstrassCurve (PowerSeries K)) (hΔ : IsUnit 𝓔.Δ)
+    (hc4 : 𝓔.c₄ ^ 3 = 𝓔.Δ * PowerSeries.X ^ 3) :
+    haveI : 𝓔.IsElliptic := ⟨hΔ⟩
+    (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).j = HahnSeries.single (3 : ℚ) (1 : K) := by
+  have : 𝓔.IsElliptic := ⟨hΔ⟩
+  have hWΔ : IsUnit (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).Δ := by
+    rw [WeierstrassCurve.map_Δ]; exact hΔ.map _
+  have hΔj : (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).Δ *
+      (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).j
+      = (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).c₄ ^ 3 := by
+    rw [WeierstrassCurve.j, ← WeierstrassCurve.coe_Δ', ← mul_assoc, ← Units.val_mul,
+      mul_inv_cancel, Units.val_one, one_mul]
+  have hc4' : (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).c₄ ^ 3
+      = (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).Δ * HahnSeries.single (3 : ℚ) (1 : K) := by
+    rw [WeierstrassCurve.map_c₄, ← map_pow, hc4, map_mul, map_pow, HahnSeries.ofPowerSeries_X,
+      HahnSeries.single_pow, one_pow, WeierstrassCurve.map_Δ]
+    congr 2
+    simp [nsmul_eq_mul]
+  exact hWΔ.mul_left_cancel (hΔj.trans hc4')
+
+theorem j_eq_1728_add_single_two_one (𝓔 : WeierstrassCurve (PowerSeries K)) (hΔ : IsUnit 𝓔.Δ)
+    (hc6 : 𝓔.c₆ ^ 2 = 𝓔.Δ * PowerSeries.X ^ 2) :
+    haveI : 𝓔.IsElliptic := ⟨hΔ⟩
+    (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).j
+      = (1728 : HahnSeries ℚ K) + HahnSeries.single (2 : ℚ) (1 : K) := by
+  have : 𝓔.IsElliptic := ⟨hΔ⟩
+  have hWΔ : IsUnit (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).Δ := by
+    rw [WeierstrassCurve.map_Δ]; exact hΔ.map _
+  have hΔj : (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).Δ *
+      (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).j
+      = (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).c₄ ^ 3 := by
+    rw [WeierstrassCurve.j, ← WeierstrassCurve.coe_Δ', ← mul_assoc, ← Units.val_mul,
+      mul_inv_cancel, Units.val_one, one_mul]
+  have hc4c6 : 𝓔.c₄ ^ 3 - 𝓔.c₆ ^ 2 = 1728 * 𝓔.Δ := by
+    simp only [WeierstrassCurve.c₄, WeierstrassCurve.c₆, WeierstrassCurve.Δ,
+      WeierstrassCurve.b₂, WeierstrassCurve.b₄, WeierstrassCurve.b₆, WeierstrassCurve.b₈]
+    ring
+  have hc4' : (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).c₄ ^ 3
+      = (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).Δ
+        * ((1728 : HahnSeries ℚ K) + HahnSeries.single (2 : ℚ) (1 : K)) := by
+    have hc4'' : 𝓔.c₄ ^ 3 = 𝓔.Δ * (1728 + PowerSeries.X ^ 2) := by
+      have := hc4c6; linear_combination this + hc6
+    rw [WeierstrassCurve.map_c₄, ← map_pow, hc4'', map_mul, WeierstrassCurve.map_Δ,
+      map_add, map_ofNat, map_pow, HahnSeries.ofPowerSeries_X, HahnSeries.single_pow, one_pow]
+    congr 3
+    simp [nsmul_eq_mul]
+  exact hWΔ.mul_left_cancel (hΔj.trans hc4')
+
+end P2MWs13.Wire
+end
+
+p2m_open "WeierstrassCurve~specialize" in
+open P2MWs13.Wire HahnSeries Polynomial in
+theorem solution
+    {N : ℕ} [NeZero N] (hN : Odd N) (data : ModularCurve.ModularPolynomialData N)
+    (r : HahnSeries ℚ (AlgebraicClosure ℚ))
+    (hroot : (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure
+      ℚ)))
+      (HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)))).IsRoot r) :
+    HahnSeries.HasRamBound 3 r := by
+  classical
+  obtain ⟨𝓔, hΔ, hc⟩ :=
+    WeierstrassCurve.exists_isUnit_discriminant_and_c4_cube_eq_mul_X_cube_powerSeries
+      (AlgebraicClosure ℚ) two_ne_zero three_ne_zero
+  have h𝓔E : 𝓔.IsElliptic := ⟨hΔ⟩
+  have hjW : (𝓔.map (HahnSeries.ofPowerSeries ℚ ℚ̄)).j = HahnSeries.single (3 : ℚ) (1 : ℚ̄) :=
+    j_eq_single_three_one 𝓔 hΔ hc
+  have ht : Transcendental ℚ (𝓔.map (HahnSeries.ofPowerSeries ℚ ℚ̄)).j := by
+    rw [hjW]; exact transcendental_single_three
+  have hτj : hahnExpMul 3 (by norm_num) (HahnSeries.single (1 : ℚ) (1 : ℚ̄))
+      = (𝓔.map (HahnSeries.ofPowerSeries ℚ ℚ̄)).j := by
+    rw [hahnExpMul_single, one_mul, hjW]
+    norm_num
+  have hτroot : (spec data.Φ (𝓔.map (HahnSeries.ofPowerSeries ℚ ℚ̄)).j).IsRoot
+      (hahnExpMul 3 (by norm_num) r) := by
+    rw [← hτj, spec_hahnExpMul]
+    change Polynomial.eval _ _ = 0
+    rw [Polynomial.eval_map, Polynomial.eval₂_hom, show Polynomial.eval r (spec data.Φ _) = 0 from
+      hroot, map_zero]
+  have hmemL : ∀ y : 𝕂, y ∈ HahnSeries.puiseuxRamSubfield ℚ̄ Nat.one_pos ↔ HasRamBound 1 y :=
+    fun y => HahnSeries.mem_puiseuxRamSubfield_iff Nat.one_pos
+  have hτrL : hahnExpMul 3 (by norm_num) r ∈ HahnSeries.puiseuxRamSubfield ℚ̄ Nat.one_pos := by
+    refine ModularCurve.ModularPolynomialData.mem_of_isRoot_map_j_of_transcendental_of_odd hN data
+      (𝓔.map (HahnSeries.ofPowerSeries ℚ ℚ̄)) ht (HahnSeries.puiseuxRamSubfield ℚ̄ Nat.one_pos)
+      ?_ ?_ ?_ ?_ ?_ ?_ _ hτroot
+    · rw [WeierstrassCurve.map_a₁, hmemL]; exact hasRamBound_one_ofPowerSeries _
+    · rw [WeierstrassCurve.map_a₂, hmemL]; exact hasRamBound_one_ofPowerSeries _
+    · rw [WeierstrassCurve.map_a₃, hmemL]; exact hasRamBound_one_ofPowerSeries _
+    · rw [WeierstrassCurve.map_a₄, hmemL]; exact hasRamBound_one_ofPowerSeries _
+    · rw [WeierstrassCurve.map_a₆, hmemL]; exact hasRamBound_one_ofPowerSeries _
+    · intro x y hns hd
+      have h :=
+        WeierstrassCurve.hasRamBound_one_of_nsmul_eq_zero_of_isUnit_discriminant_powerSeries 𝓔 hΔ
+          (Nat.pos_of_ne_zero (NeZero.ne N)) x y hns hd
+      exact ⟨(hmemL x).mpr h.1, (hmemL y).mpr h.2⟩
+  exact (hasRamBound_one_hahnExpMul_iff 3 (by norm_num) r).mp ((hmemL _).mp hτrL)
+
+end S_ModularCurve_ModularPolynomialData_hasRamBound_three_of_isRoot_at_zero_of_odd
+end P2MW
+export P2MW.S_ModularCurve_ModularPolynomialData_hasRamBound_three_of_isRoot_at_zero_of_odd
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.ModularPolynomialData.hasRamBound_three_of_isRoot_at_zero_of_odd
+    {N : ℕ} [NeZero N] (hN : Odd N) (data : ModularCurve.ModularPolynomialData N)
+    (r : HahnSeries ℚ (AlgebraicClosure ℚ))
+    (hroot : (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure
+      ℚ)))
+      (HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)))).IsRoot r) :
+    HahnSeries.HasRamBound 3 r :=
+  solution hN data r hroot
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_hasRamBound_two_of_isRoot_at_1728_of_odd.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_hasRamBound_two_of_isRoot_at_1728_of_odd.lean
new file mode 100644
index 0000000000..4527bb8026
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_hasRamBound_two_of_isRoot_at_1728_of_odd.lean
@@ -0,0 +1,319 @@
+/-
+Based on Prove2Me node ModularCurve.ModularPolynomialData.hasRamBound_two_of_isRoot_at_1728_of_odd
+(2d2e6665-ed6a-52fe-a1dd-cf8924639f22) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 59a469aa-34a0-5f93-95d9-177a14c3d8cd
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_RamificationBound
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import Mathlib.Algebra.CharP.Invertible
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_mem_puiseuxRamSubfield_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental_of_odd
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_isUnit_discriminant_and_c6_sq_eq_mul_X_sq_powerSeries
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_hasRamBound_one_of_nsmul_eq_zero_of_isUnit_discriminant_powerSeries
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Roots of Φ_N(1728+t,Y) have ramification bound 2 for odd N
+
+Theorem statement: `ModularCurve.ModularPolynomialData.hasRamBound_two_of_isRoot_at_1728_of_odd`
+(`2d2e6665-ed6a-52fe-a1dd-cf8924639f22`), by Claude, 2026-09-05.
+
+Proof: submission `59a469aa-34a0-5f93-95d9-177a14c3d8cd`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number which is odd, and let `data` be a modular polynomial datum of
+level $N$: a polynomial $\Phi \in \mathbb{Z}[X][Y]$ which is monic in $Y$, whose $Y$-degree equals
+$\sum_{d \mid N,\ d \text{ squarefree}} N/d$, and which satisfies $\Phi(j(q), j_N(q)) = 0$, the
+substitution being the ring map $\mathbb{Z}[X] \to \mathbb{Q}((q))$ sending $X$ to the $q$-expansion
+`jq` and the outer variable being evaluated at `jqN N`. Work in the Hahn series field
+$\overline{\mathbb{Q}}((t^{\mathbb{Q}}))$ of Hahn series with rational exponents and coefficients in
+`AlgebraicClosure ℚ`, and write $t$ for the Hahn series `HahnSeries.single 1 1`. Let $r$ be such a
+Hahn series which is a root of the one-variable polynomial obtained from $\Phi$ by mapping its
+coefficients in $\mathbb{Z}[X]$ into the Hahn series field via the integer structure map together
+with $X \mapsto 1728 + t$. Then $r$ has ramification bound $2$, that is, the support of $r$ is
+contained in the set of rationals $k/2$ with $k \in \mathbb{Z}$.
+
+Since $t = j - 1728$ is a local parameter at $j = 1728$, this is the statement that the ramification
+index of $X_0(N) \to X(1)$ at every point above $j = 1728$ divides $2$, reflecting the order-$2$
+stabiliser of $i$ in $\mathrm{PSL}_2(\mathbb{Z})$, for odd level $N$. It feeds the divisibility
+results
+[`ModularCurve.ord_jBar_sub_1728_dvd_two_of_odd`]
+(thm.html#ModularCurve.ord_jBar_sub_1728_dvd_two_of_odd),
+[`ModularCurve.ord_jBar_dvd_three_of_odd`](thm.html#ModularCurve.ord_jBar_dvd_three_of_odd) and
+[`ModularCurve.ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound`]
+(thm.html#ModularCurve.ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ModularPolynomialData_hasRamBound_two_of_isRoot_at_1728_of_odd.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ModularPolynomialData_hasRamBound_two_of_isRoot_at_1728_of_odd
+
+
+p2m_open "HahnSeries Polynomial WeierstrassCurve~specialize"
+
+local notation "ℚ̄" => AlgebraicClosure ℚ
+local notation "𝕂" => HahnSeries ℚ (AlgebraicClosure ℚ)
+
+noncomputable section
+
+namespace P2MWs13
+namespace Wire
+
+variable {K : Type*} [Field K]
+
+def hahnExpMul (n : ℕ) (hn : 0 < n) : HahnSeries ℚ K →+* HahnSeries ℚ K :=
+  HahnSeries.embDomainRingHom (AddMonoidHom.mulRight (n : ℚ))
+    (mul_left_injective₀ (Nat.cast_ne_zero.mpr hn.ne'))
+    (fun _ _ => mul_le_mul_iff_of_pos_right (Nat.cast_pos.mpr hn))
+
+@[scoped simp] theorem hahnExpMul_single (n : ℕ) (hn : 0 < n) (q : ℚ) (c : K) :
+    hahnExpMul n hn (HahnSeries.single q c) = HahnSeries.single (q * n) c := by
+  unfold hahnExpMul
+  rw [embDomainRingHom_apply, embDomain_single]
+  rfl
+
+@[scoped simp] theorem hahnExpMul_coeff_mul (n : ℕ) (hn : 0 < n) (r : HahnSeries ℚ K) (q : ℚ) :
+    (hahnExpMul n hn r).coeff (q * n) = r.coeff q :=
+  HahnSeries.embDomain_coeff
+
+theorem hasRamBound_one_hahnExpMul_iff (n : ℕ) (hn : 0 < n) (r : HahnSeries ℚ K) :
+    HasRamBound 1 (hahnExpMul n hn r) ↔ HasRamBound n r := by
+  have hnQ : (n : ℚ) ≠ 0 := Nat.cast_ne_zero.mpr hn.ne'
+  constructor
+  · intro h q hq
+    have hnq : q * n ∈ (hahnExpMul n hn r).support := by
+      rw [HahnSeries.mem_support, hahnExpMul_coeff_mul]; exact hq
+    obtain ⟨k, hk⟩ := h hnq
+    refine ⟨k, ?_⟩
+    simp only [Nat.cast_one, div_one] at hk
+    field_simp
+    linarith
+  · intro h q hq
+    obtain ⟨p, rfl⟩ : ∃ p : ℚ, p * n = q := ⟨q / n, div_mul_cancel₀ q hnQ⟩
+    have hp : p ∈ r.support := by
+      rw [HahnSeries.mem_support, ← hahnExpMul_coeff_mul n hn]; exact hq
+    obtain ⟨k, hk⟩ := h hp
+    refine ⟨k, ?_⟩
+    simp only [Nat.cast_one, div_one]
+    field_simp at hk
+    linarith [hk]
+
+abbrev spec (Φ : Polynomial (Polynomial ℤ)) (j₀ : HahnSeries ℚ K) : Polynomial (HahnSeries ℚ K) :=
+  Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ K)) j₀)
+
+theorem hahnExpMul_comp_eval (n : ℕ) (hn : 0 < n) (j₀ : HahnSeries ℚ K) :
+    (hahnExpMul n hn).comp (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ K)) j₀)
+      = Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ K)) (hahnExpMul n hn j₀) := by
+  refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+  simp [Polynomial.eval₂RingHom]
+
+theorem spec_hahnExpMul (n : ℕ) (hn : 0 < n) (Φ : Polynomial (Polynomial ℤ)) (j₀ : HahnSeries ℚ K) :
+    spec Φ (hahnExpMul n hn j₀) = (spec Φ j₀).map (hahnExpMul n hn) := by
+  rw [spec, spec, Polynomial.map_map, hahnExpMul_comp_eval]
+
+theorem hasRamBound_one_ofPowerSeries (p : PowerSeries K) :
+    HasRamBound 1 (HahnSeries.ofPowerSeries ℚ K p) := by
+  intro q hq
+  have hq' : q ∈ Set.range ((↑) : ℕ → ℚ) := by
+    by_contra h
+    rw [HahnSeries.mem_support, HahnSeries.ofPowerSeries_apply] at hq
+    exact hq (HahnSeries.embDomain_of_notMem_range (by simpa using h))
+  obtain ⟨m, rfl⟩ := hq'
+  exact ⟨(m : ℤ), by push_cast; ring⟩
+
+theorem algebraMap_eq_C (a : K) : algebraMap K (HahnSeries ℚ K) a = HahnSeries.C a := by
+  have h1 : algebraMap K (PowerSeries K) a = PowerSeries.C a := by simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+
+theorem transcendental_single_one : Transcendental K (HahnSeries.single (1 : ℚ) (1 : K)) := by
+  rw [transcendental_iff_injective]
+  have heq : (Polynomial.aeval (R := K) (HahnSeries.single (1:ℚ) (1:K))).toRingHom
+      = (HahnSeries.ofPowerSeries ℚ K).comp (Polynomial.coeToPowerSeries.ringHom (R := K)) := by
+    refine Polynomial.ringHom_ext (fun a => ?_) ?_
+    · change Polynomial.aeval (R := K) (HahnSeries.single (1:ℚ) (1:K)) (Polynomial.C a) = _
+      rw [Polynomial.aeval_C, algebraMap_eq_C,
+        RingHom.coe_comp, Function.comp_apply, Polynomial.coeToPowerSeries.ringHom_apply,
+        Polynomial.coe_C, HahnSeries.ofPowerSeries_C]
+    · change Polynomial.aeval (R := K) (HahnSeries.single (1:ℚ) (1:K)) Polynomial.X = _
+      rw [Polynomial.aeval_X, RingHom.coe_comp, Function.comp_apply,
+        Polynomial.coeToPowerSeries.ringHom_apply, Polynomial.coe_X, HahnSeries.ofPowerSeries_X]
+  intro p q hpq
+  have hpq' : (HahnSeries.ofPowerSeries ℚ K) (p : PowerSeries K)
+      = (HahnSeries.ofPowerSeries ℚ K) (q : PowerSeries K) := by
+    have hp := congrFun (congrArg DFunLike.coe heq) p
+    have hq := congrFun (congrArg DFunLike.coe heq) q
+    simp only [AlgHom.toRingHom_eq_coe, RingHom.coe_coe, RingHom.coe_comp,
+      Function.comp_apply, Polynomial.coeToPowerSeries.ringHom_apply] at hp hq
+    rw [← hp, ← hq]; exact hpq
+  exact Polynomial.coe_injective K (HahnSeries.ofPowerSeries_injective hpq')
+
+theorem transcendental_rat_of_qbar (x : 𝕂) (h : Transcendental ℚ̄ x) : Transcendental ℚ x := by
+  rintro ⟨p, hp0, hpx⟩
+  refine h ⟨p.map (algebraMap ℚ ℚ̄),
+    (Polynomial.map_ne_zero_iff (algebraMap ℚ ℚ̄).injective).mpr hp0, ?_⟩
+  rw [Polynomial.aeval_def, Polynomial.eval₂_map,
+    Subsingleton.elim ((algebraMap ℚ̄ 𝕂).comp (algebraMap ℚ ℚ̄)) (algebraMap ℚ 𝕂),
+    ← Polynomial.aeval_def]
+  exact hpx
+
+theorem transcendental_single_three :
+    Transcendental ℚ (HahnSeries.single (3 : ℚ) (1 : ℚ̄) : 𝕂) := by
+  refine transcendental_rat_of_qbar _ (fun halg => ?_)
+  refine transcendental_single_one (K := ℚ̄) (IsAlgebraic.of_pow (n := 3) (by norm_num) ?_)
+  rw [HahnSeries.single_pow, one_pow]
+  have h3 : (3 : ℕ) • (1 : ℚ) = 3 := by norm_num
+  rwa [h3]
+
+theorem transcendental_1728_add_single_two :
+    Transcendental ℚ ((1728 : 𝕂) + HahnSeries.single (2 : ℚ) (1 : ℚ̄)) := by
+  refine transcendental_rat_of_qbar _ (fun halg => ?_)
+  have h1728 : IsAlgebraic ℚ̄ ((1728 : ℕ) : 𝕂) := isAlgebraic_natCast 1728
+  rw [Nat.cast_ofNat] at h1728
+  have hsq : IsAlgebraic ℚ̄ (HahnSeries.single (2 : ℚ) (1 : ℚ̄) : 𝕂) := by
+    have := (IsIntegral.sub halg.isIntegral h1728.isIntegral).isAlgebraic
+    simpa using this
+  refine transcendental_single_one (K := ℚ̄) (IsAlgebraic.of_pow (n := 2) (by norm_num) ?_)
+  rw [HahnSeries.single_pow, one_pow]
+  have h2 : (2 : ℕ) • (1 : ℚ) = 2 := by norm_num
+  rwa [h2]
+
+theorem j_eq_single_three_one (𝓔 : WeierstrassCurve (PowerSeries K)) (hΔ : IsUnit 𝓔.Δ)
+    (hc4 : 𝓔.c₄ ^ 3 = 𝓔.Δ * PowerSeries.X ^ 3) :
+    haveI : 𝓔.IsElliptic := ⟨hΔ⟩
+    (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).j = HahnSeries.single (3 : ℚ) (1 : K) := by
+  have : 𝓔.IsElliptic := ⟨hΔ⟩
+  have hWΔ : IsUnit (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).Δ := by
+    rw [WeierstrassCurve.map_Δ]; exact hΔ.map _
+  have hΔj : (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).Δ *
+      (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).j
+      = (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).c₄ ^ 3 := by
+    rw [WeierstrassCurve.j, ← WeierstrassCurve.coe_Δ', ← mul_assoc, ← Units.val_mul,
+      mul_inv_cancel, Units.val_one, one_mul]
+  have hc4' : (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).c₄ ^ 3
+      = (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).Δ * HahnSeries.single (3 : ℚ) (1 : K) := by
+    rw [WeierstrassCurve.map_c₄, ← map_pow, hc4, map_mul, map_pow, HahnSeries.ofPowerSeries_X,
+      HahnSeries.single_pow, one_pow, WeierstrassCurve.map_Δ]
+    congr 2
+    simp [nsmul_eq_mul]
+  exact hWΔ.mul_left_cancel (hΔj.trans hc4')
+
+theorem j_eq_1728_add_single_two_one (𝓔 : WeierstrassCurve (PowerSeries K)) (hΔ : IsUnit 𝓔.Δ)
+    (hc6 : 𝓔.c₆ ^ 2 = 𝓔.Δ * PowerSeries.X ^ 2) :
+    haveI : 𝓔.IsElliptic := ⟨hΔ⟩
+    (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).j
+      = (1728 : HahnSeries ℚ K) + HahnSeries.single (2 : ℚ) (1 : K) := by
+  have : 𝓔.IsElliptic := ⟨hΔ⟩
+  have hWΔ : IsUnit (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).Δ := by
+    rw [WeierstrassCurve.map_Δ]; exact hΔ.map _
+  have hΔj : (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).Δ *
+      (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).j
+      = (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).c₄ ^ 3 := by
+    rw [WeierstrassCurve.j, ← WeierstrassCurve.coe_Δ', ← mul_assoc, ← Units.val_mul,
+      mul_inv_cancel, Units.val_one, one_mul]
+  have hc4c6 : 𝓔.c₄ ^ 3 - 𝓔.c₆ ^ 2 = 1728 * 𝓔.Δ := by
+    simp only [WeierstrassCurve.c₄, WeierstrassCurve.c₆, WeierstrassCurve.Δ,
+      WeierstrassCurve.b₂, WeierstrassCurve.b₄, WeierstrassCurve.b₆, WeierstrassCurve.b₈]
+    ring
+  have hc4' : (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).c₄ ^ 3
+      = (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).Δ
+        * ((1728 : HahnSeries ℚ K) + HahnSeries.single (2 : ℚ) (1 : K)) := by
+    have hc4'' : 𝓔.c₄ ^ 3 = 𝓔.Δ * (1728 + PowerSeries.X ^ 2) := by
+      have := hc4c6; linear_combination this + hc6
+    rw [WeierstrassCurve.map_c₄, ← map_pow, hc4'', map_mul, WeierstrassCurve.map_Δ,
+      map_add, map_ofNat, map_pow, HahnSeries.ofPowerSeries_X, HahnSeries.single_pow, one_pow]
+    congr 3
+    simp [nsmul_eq_mul]
+  exact hWΔ.mul_left_cancel (hΔj.trans hc4')
+
+end P2MWs13.Wire
+end
+
+p2m_open "WeierstrassCurve~specialize" in
+open P2MWs13.Wire HahnSeries Polynomial in
+theorem solution
+    {N : ℕ} [NeZero N] (hN : Odd N) (data : ModularCurve.ModularPolynomialData N)
+    (r : HahnSeries ℚ (AlgebraicClosure ℚ))
+    (hroot : (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure
+      ℚ)))
+      ((1728 : HahnSeries ℚ (AlgebraicClosure ℚ)) + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure
+        ℚ)))).IsRoot r) :
+    HahnSeries.HasRamBound 2 r := by
+  classical
+  obtain ⟨𝓔, hΔ, hc⟩ :=
+    WeierstrassCurve.exists_isUnit_discriminant_and_c6_sq_eq_mul_X_sq_powerSeries (AlgebraicClosure
+      ℚ) two_ne_zero three_ne_zero
+  have h𝓔E : 𝓔.IsElliptic := ⟨hΔ⟩
+  have hjW : (𝓔.map (HahnSeries.ofPowerSeries ℚ ℚ̄)).j = (1728 : 𝕂) + HahnSeries.single (2 : ℚ) (1 :
+    ℚ̄) :=
+    j_eq_1728_add_single_two_one 𝓔 hΔ hc
+  have ht : Transcendental ℚ (𝓔.map (HahnSeries.ofPowerSeries ℚ ℚ̄)).j := by
+    rw [hjW]; exact transcendental_1728_add_single_two
+  have hτj : hahnExpMul 2 (by norm_num) ((1728 : 𝕂) + HahnSeries.single (1 : ℚ) (1 : ℚ̄))
+      = (𝓔.map (HahnSeries.ofPowerSeries ℚ ℚ̄)).j := by
+    rw [map_add, map_ofNat, hahnExpMul_single, one_mul, hjW]
+    norm_num
+  have hτroot : (spec data.Φ (𝓔.map (HahnSeries.ofPowerSeries ℚ ℚ̄)).j).IsRoot
+      (hahnExpMul 2 (by norm_num) r) := by
+    rw [← hτj, spec_hahnExpMul]
+    change Polynomial.eval _ _ = 0
+    rw [Polynomial.eval_map, Polynomial.eval₂_hom, show Polynomial.eval r (spec data.Φ _) = 0 from
+      hroot, map_zero]
+  have hmemL : ∀ y : 𝕂, y ∈ HahnSeries.puiseuxRamSubfield ℚ̄ Nat.one_pos ↔ HasRamBound 1 y :=
+    fun y => HahnSeries.mem_puiseuxRamSubfield_iff Nat.one_pos
+  have hτrL : hahnExpMul 2 (by norm_num) r ∈ HahnSeries.puiseuxRamSubfield ℚ̄ Nat.one_pos := by
+    refine ModularCurve.ModularPolynomialData.mem_of_isRoot_map_j_of_transcendental_of_odd hN data
+      (𝓔.map (HahnSeries.ofPowerSeries ℚ ℚ̄)) ht (HahnSeries.puiseuxRamSubfield ℚ̄ Nat.one_pos)
+      ?_ ?_ ?_ ?_ ?_ ?_ _ hτroot
+    · rw [WeierstrassCurve.map_a₁, hmemL]; exact hasRamBound_one_ofPowerSeries _
+    · rw [WeierstrassCurve.map_a₂, hmemL]; exact hasRamBound_one_ofPowerSeries _
+    · rw [WeierstrassCurve.map_a₃, hmemL]; exact hasRamBound_one_ofPowerSeries _
+    · rw [WeierstrassCurve.map_a₄, hmemL]; exact hasRamBound_one_ofPowerSeries _
+    · rw [WeierstrassCurve.map_a₆, hmemL]; exact hasRamBound_one_ofPowerSeries _
+    · intro x y hns hd
+      have h :=
+        WeierstrassCurve.hasRamBound_one_of_nsmul_eq_zero_of_isUnit_discriminant_powerSeries 𝓔 hΔ
+          (Nat.pos_of_ne_zero (NeZero.ne N)) x y hns hd
+      exact ⟨(hmemL x).mpr h.1, (hmemL y).mpr h.2⟩
+  exact (hasRamBound_one_hahnExpMul_iff 2 (by norm_num) r).mp ((hmemL _).mp hτrL)
+
+end S_ModularCurve_ModularPolynomialData_hasRamBound_two_of_isRoot_at_1728_of_odd
+end P2MW
+export P2MW.S_ModularCurve_ModularPolynomialData_hasRamBound_two_of_isRoot_at_1728_of_odd (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.ModularPolynomialData.hasRamBound_two_of_isRoot_at_1728_of_odd
+    {N : ℕ} [NeZero N] (hN : Odd N) (data : ModularCurve.ModularPolynomialData N)
+    (r : HahnSeries ℚ (AlgebraicClosure ℚ))
+    (hroot : (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure
+      ℚ)))
+      ((1728 : HahnSeries ℚ (AlgebraicClosure ℚ)) + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure
+        ℚ)))).IsRoot r) :
+    HahnSeries.HasRamBound 2 r :=
+  solution hN data r hroot
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_isIntegral_jqN.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_isIntegral_jqN.lean
new file mode 100644
index 0000000000..bdee409401
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_isIntegral_jqN.lean
@@ -0,0 +1,86 @@
+/-
+Based on Prove2Me node ModularCurve.ModularPolynomialData.isIntegral_jqN
+(28db7efc-0808-5a57-9883-8212753294ed) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 12b3ebdc-4713-5fec-84d4-fcc6fb481bd5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# j(q^N) is integral over ℚ(j(q))
+
+Theorem statement: `ModularCurve.ModularPolynomialData.isIntegral_jqN`
+(`28db7efc-0808-5a57-9883-8212753294ed`), by Claude, 2026-09-05.
+
+Proof: submission `12b3ebdc-4713-5fec-84d4-fcc6fb481bd5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $N \neq 0$. Work inside the field of Laurent series $\mathbb{Q}((q))$
+(`LaurentSeries ℚ`, Hahn series over $\mathbb{Q}$ with value group $\mathbb{Z}$), with the
+distinguished element $jq = q^{-1} \cdot jNumQ$, where $jNumQ$ is the integral power series $jNum$
+pushed along $\mathbb{Z} \to \mathbb{Q}$, and with $jqN\,N = qExpand\,\mathbb{Q}\,N\,(jq)$, the
+image of $jq$ under the ring endomorphism of $\mathbb{Q}((q))$ induced by multiplication by $N$ on
+exponents, i.e. the substitution $q \mapsto q^N$. Assume given a datum `data : ModularPolynomialData
+N`, that is: a polynomial $\Phi \in (\mathbb{Z}[X])[Y]$ which is monic in $Y$, whose degree in $Y$
+equals $\sum_{d \mid N,\ d \text{ squarefree}} N/d$, and which satisfies $\Phi(jq, jqN\,N) = 0$, the
+coefficients of $\Phi$ being evaluated at $jq$ through the ring homomorphism $evalAtJ :
+\mathbb{Z}[X] \to \mathbb{Q}((q))$, $X \mapsto jq$. The conclusion is that $jqN\,N$ is integral over
+the intermediate field $\mathbb{Q}\langle jq\rangle = \mathbb{Q}(jq) \subseteq \mathbb{Q}((q))$.
+
+This is the integrality half of the classical statement that $\mathbb{Q}(j(q), j(q^N))$ is a finite
+extension of the rational function field $\mathbb{Q}(j(q))$, the modular equation $\Phi_N$ providing
+a monic relation for $j(q^N)$ over $\mathbb{Z}[j(q)]$. It is used in the construction of the Fricke
+involution on the algebraic model of $X_0(N)$, via
+[`ModularCurve.exists_isFrickeAut_of_modularPolynomialData`]
+(thm.html#ModularCurve.exists_isFrickeAut_of_modularPolynomialData).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ModularPolynomialData_isIntegral_jqN.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ModularPolynomialData_isIntegral_jqN
+
+open ModularCurve IntermediateField
+
+noncomputable section
+
+theorem solution {N : ℕ} [NeZero N] (data : ModularPolynomialData N) : IsIntegral ℚ⟮jq⟯ (jqN N) :=by
+  refine ⟨data.toAdjoin, data.toAdjoin_monic, ?_⟩
+  rw [ModularPolynomialData.toAdjoin, Polynomial.eval₂_map, algebraMap_comp_evalAtJGen]
+  exact data.eval_eq_zero
+
+end
+
+end S_ModularCurve_ModularPolynomialData_isIntegral_jqN
+end P2MW
+export P2MW.S_ModularCurve_ModularPolynomialData_isIntegral_jqN (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve IntermediateField
+theorem ModularCurve.ModularPolynomialData.isIntegral_jqN {N : ℕ} [NeZero N]
+    (data : ModularPolynomialData N) :
+    IsIntegral ℚ⟮jq⟯ (jqN N) :=
+  solution data
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_isRoot_map_j_veluQuotient_j_of_addOrderOf_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_isRoot_map_j_veluQuotient_j_of_addOrderOf_eq.lean
new file mode 100644
index 0000000000..a548d1b74e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_isRoot_map_j_veluQuotient_j_of_addOrderOf_eq.lean
@@ -0,0 +1,161 @@
+/-
+Based on Prove2Me node
+ModularCurve.ModularPolynomialData.isRoot_map_j_veluQuotient_j_of_addOrderOf_eq
+(ec49970f-20d9-5977-874f-ff3faa19fdb8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6b60dcc9-6933-5c44-9597-a3241e77bb1d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_OddOrderSummingSet
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_Velu
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_isAlgClosed_rat
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_and_abelTheorem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Forward modular equation for odd Vélu quotients
+
+Theorem statement: `ModularCurve.ModularPolynomialData.isRoot_map_j_veluQuotient_j_of_addOrderOf_eq`
+(`ec49970f-20d9-5977-874f-ff3faa19fdb8`), by Claude, 2026-09-05.
+
+Proof: submission `6b60dcc9-6933-5c44-9597-a3241e77bb1d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\mathbb K$ be the Hahn series field $\mathrm{HahnSeries}\ \mathbb Q\ \overline{\mathbb Q}$
+(rational exponents, coefficients in an algebraic closure of $\mathbb Q$), and let $W$ be a
+Weierstrass curve over $\mathbb K$ whose discriminant is a unit. Let $n$ be a natural number and $Q$
+a point of the affine model of $W$ with $\mathrm{addOrderOf}\,Q = 2n+1$. Form the finite set $S =
+\{(x(kQ), y(kQ)) : 1 \le k \le n\} \subseteq \mathbb K \times \mathbb K$ (the point at infinity
+contributing $(0,0)$), and the Vélu quotient $W/S$, the Weierstrass curve with the same $a_1, a_2,
+a_3$ and with $a_4$ replaced by $a_4 - 5\sum_{P \in S} T(P)$ and $a_6$ by $a_6 - b_2\sum_{P \in S}
+T(P) - 7\sum_{P \in S} W(P)$. Assume the discriminant of $W/S$ is nonzero, so that $W/S$ is again
+elliptic. Let $\mathrm{data}$ consist of a polynomial $\Phi \in \mathbb Z[X][Y]$, monic in $Y$, of
+$Y$-degree $\sum_{d \mid 2n+1,\ d \text{ squarefree}} (2n+1)/d$, satisfying $\Phi(j(q), j(q^{2n+1}))
+= 0$ in the Laurent series field over $\mathbb Q$. Then $j(W/S)$ is a root of the one-variable
+polynomial over $\mathbb K$ obtained from $\Phi$ by mapping each coefficient in $\mathbb Z[X]$ to
+its value at $X = j(W)$.
+
+This is the forward half of the moduli interpretation of the modular polynomial of level $N = 2n+1$:
+a curve cyclically $N$-isogenous to $E$ has $j$-invariant a root of $\Phi_N(j(E), \cdot)$. It is
+used, over the Hahn series field where a transcendental $j$-invariant is available, to identify the
+roots of $\Phi_N(j, \cdot)$ with the $j$-invariants of the Vélu quotients by the cyclic subgroups of
+order $N$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ModularPolynomialData_isRoot_map_j_veluQuotient_j_of_addOrderOf_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ModularPolynomialData_isRoot_map_j_veluQuotient_j_of_addOrderOf_eq
+
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+local notation "𝕂" => HahnSeries ℚ (AlgebraicClosure ℚ)
+
+theorem solution
+    [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    (n : ℕ) (Q : W.toAffine.Point) (hQ : addOrderOf Q = 2 * n + 1)
+    (hΔ : (W.veluQuotient (W.oddOrderSummingSet Q n)).Δ ≠ 0)
+    (data : ModularCurve.ModularPolynomialData (2 * n + 1)) :
+    haveI : (W.veluQuotient (W.oddOrderSummingSet Q n)).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ)))
+      W.j)).IsRoot
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).j := by
+  have hE' : (W.veluQuotient (W.oddOrderSummingSet Q n)).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+  have : IsAlgClosed 𝕂 := HahnSeries.isAlgClosed_rat
+  have : CharZero 𝕂 :=
+    (RingHom.charZero_iff (HahnSeries.C (R := AlgebraicClosure ℚ) (Γ := ℚ)).injective).mp
+      inferInstance
+  have : W.toAffine.IsElliptic := ‹W.IsElliptic›
+  have : (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.IsElliptic := hE'
+  have : IsDedekindDomain W.toAffine.CoordinateRing := CoordinateRing.isDedekindDomain W
+  have : HasPrincipalDivisors 𝕂 W.toAffine.FunctionField :=
+    hasPrincipalDivisors_functionField W.toAffine
+  obtain ⟨g, hgc, hga⟩ :=
+    exists_genusOnePlaceGate_isCentred_and_abelTheorem (F := 𝕂) (W := W.toAffine)
+  let := g
+  have := hgc
+  have := hga
+  have : IsDedekindDomain (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.CoordinateRing :=
+    CoordinateRing.isDedekindDomain (W.veluQuotient (W.oddOrderSummingSet Q n))
+  have : HasPrincipalDivisors 𝕂 (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.FunctionField
+    :=
+    hasPrincipalDivisors_functionField (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine
+  obtain ⟨g', hgc', hga'⟩ :=
+    exists_genusOnePlaceGate_isCentred_and_abelTheorem (F := 𝕂)
+      (W := (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine)
+  let := g'
+  have := hgc'
+  have := hga'
+  obtain ⟨ι, hι, hfin, hdeg, hker⟩ :=
+    WeierstrassCurve.exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples
+      (W := W) (Q := Q) (n := n) hQ hΔ
+  have : CharZero (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.FunctionField :=
+    charZero_of_injective_algebraMap
+      (algebraMap 𝕂 (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.FunctionField).injective
+  have hsep : SeparableAlong 𝕂 ι := by
+    let := algebraAlong ι
+    have := isScalarTower_along ι
+    have : Module.Finite (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.FunctionField
+        W.toAffine.FunctionField := hfin
+    change Algebra.IsSeparable _ _
+    infer_instance
+  have hN : NormFormulaAlong 𝕂 ι hfin := AlgebraicCurve.normFormulaAlong ι hfin hsep
+  have hkerQ := hker hN
+  have : NeZero (2 * n + 1) := ⟨by omega⟩
+  have hcyc : IsAddCyclic (pointMapOfPushforward ι hι hfin hN).ker := by
+    rw [hkerQ]; infer_instance
+  have hcard : Nat.card (pointMapOfPushforward ι hι hfin hN).ker = 2 * n + 1 := by
+    rw [hkerQ, Nat.card_zmultiples, hQ]
+  exact
+    eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward
+    𝕂 W.toAffine (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine ι hι hfin hN (2 * n + 1)
+    hcyc hcard data
+
+end S_ModularCurve_ModularPolynomialData_isRoot_map_j_veluQuotient_j_of_addOrderOf_eq
+end P2MW
+export P2MW.S_ModularCurve_ModularPolynomialData_isRoot_map_j_veluQuotient_j_of_addOrderOf_eq
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine
+theorem ModularCurve.ModularPolynomialData.isRoot_map_j_veluQuotient_j_of_addOrderOf_eq
+    [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    (n : ℕ) (Q : W.toAffine.Point) (hQ : addOrderOf Q = 2 * n + 1)
+    (hΔ : (W.veluQuotient (W.oddOrderSummingSet Q n)).Δ ≠ 0)
+    (data : ModularCurve.ModularPolynomialData (2 * n + 1)) :
+    haveI : (W.veluQuotient (W.oddOrderSummingSet Q n)).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ)))
+      W.j)).IsRoot
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).j :=
+  solution W n Q hQ hΔ data
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_isUnit_leadingCoeff_diag.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_isUnit_leadingCoeff_diag.lean
new file mode 100644
index 0000000000..ccef5fabae
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_isUnit_leadingCoeff_diag.lean
@@ -0,0 +1,87 @@
+/-
+Based on Prove2Me node ModularCurve.ModularPolynomialData.isUnit_leadingCoeff_diag
+(eb3740e2-0f8a-56bd-a7fb-8908046f7310) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1b019bcc-f8a0-5e33-8a09-38179830a5c7
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_isUnit_leadingCoeff_diag_of_not_isSquare
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Diagonal modular polynomial has unit leading coefficient
+
+Theorem statement: `ModularCurve.ModularPolynomialData.isUnit_leadingCoeff_diag`
+(`eb3740e2-0f8a-56bd-a7fb-8908046f7310`), by Claude, 2026-09-05.
+
+Proof: submission `1b019bcc-f8a0-5e33-8a09-38179830a5c7`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, nonzero, with $2 \le N$ and $N$ not a square in $\mathbb{N}$, and let
+`data` be a term of the structure [`ModularCurve.ModularPolynomialData
+N`](def/ModularCurve_X0.html#L215), that is: a polynomial $\Phi =$ `data.Φ` in $(\mathbb{Z}[X])[Y]$
+which is monic, whose degree in $Y$ equals `dedekindPsi N` $= \sum_{d \mid N,\ d \text{ squarefree}}
+N/d$, and which satisfies the $q$-expansion relation `Φ.eval₂ evalAtJ (jqN N) = 0`, where `evalAtJ`
+is the ring homomorphism $\mathbb{Z}[X] \to$ `LaurentSeries ℚ` sending $X$ to `jq` and `jqN N` is
+the corresponding element attached to level $N$; so $\Phi$ is a modular polynomial of level $N$. The
+conclusion is that the diagonal specialisation $\Phi(X,X) \in \mathbb{Z}[X]$, formed as
+`data.Φ.eval₂ (RingHom.id (Polynomial ℤ)) Polynomial.X` (coefficients left alone, the outer variable
+sent to $X$), has leading coefficient a unit of $\mathbb{Z}$, i.e. equal to $\pm 1$. Nothing is
+asserted about the degree of $\Phi(X,X)$.
+
+This is the classical statement that $\Phi_N(X,X)$ is, up to sign, monic when $N$ is not a perfect
+square, the source of integrality of singular moduli and of the $j$-invariants of curves carrying a
+cyclic endomorphism of degree $N$. It is used in the construction of integral models for isogeny
+endomorphism data, in
+[`WeierstrassCurve.Affine.IsogenyEndDatum.exists_forall_pointEnd_eq_zsmul_of_not_isIntegral_j`]
+(thm.html#WeierstrassCurve.Affine.IsogenyEndDatum.
+exists_forall_pointEnd_eq_zsmul_of_not_isIntegral_j)
+and
+[`WeierstrassCurve.Affine.IsogenyEndDatum.exists_forall_pointEnd_eq_zsmul_of_transcendental_j`]
+(thm.html#WeierstrassCurve.Affine.IsogenyEndDatum.
+exists_forall_pointEnd_eq_zsmul_of_transcendental_j).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ModularPolynomialData_isUnit_leadingCoeff_diag.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ModularPolynomialData_isUnit_leadingCoeff_diag
+
+theorem solution
+    (N : ℕ) [NeZero N] (h2 : 2 ≤ N) (hN : ¬ IsSquare N)
+    (data : ModularCurve.ModularPolynomialData N) :
+    IsUnit (data.Φ.eval₂ (RingHom.id (Polynomial ℤ)) Polynomial.X).leadingCoeff :=
+  (fun _ => ModularCurve.ModularPolynomialData.isUnit_leadingCoeff_diag_of_not_isSquare N hN data)
+    h2
+
+end S_ModularCurve_ModularPolynomialData_isUnit_leadingCoeff_diag
+end P2MW
+export P2MW.S_ModularCurve_ModularPolynomialData_isUnit_leadingCoeff_diag (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.ModularPolynomialData.isUnit_leadingCoeff_diag
+    (N : ℕ) [NeZero N] (h2 : 2 ≤ N) (hN : ¬ IsSquare N)
+    (data : ModularCurve.ModularPolynomialData N) :
+    IsUnit (data.Φ.eval₂ (RingHom.id (Polynomial ℤ)) Polynomial.X).leadingCoeff :=
+  solution N h2 hN data
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_isUnit_leadingCoeff_diag_of_not_isSquare.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_isUnit_leadingCoeff_diag_of_not_isSquare.lean
new file mode 100644
index 0000000000..9d1dd96a88
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_isUnit_leadingCoeff_diag_of_not_isSquare.lean
@@ -0,0 +1,756 @@
+/-
+Based on Prove2Me node ModularCurve.ModularPolynomialData.isUnit_leadingCoeff_diag_of_not_isSquare
+(4bb1346a-3137-5367-bd86-316bfef9d9ed) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 275c90a1-2f8f-5135-bc89-8293fe48778f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_minpoly_jqN_map_eq_prod_slots
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqN_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularFunctionField_eq_full
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_evalAtJ_injective
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.FieldTheory.Minpoly.Field
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Unit leading coefficient of Φ_N(X,X) for non-square N
+
+Theorem statement: `ModularCurve.ModularPolynomialData.isUnit_leadingCoeff_diag_of_not_isSquare`
+(`4bb1346a-3137-5367-bd86-316bfef9d9ed`), by Claude, 2026-09-05.
+
+Proof: submission `275c90a1-2f8f-5135-bc89-8293fe48778f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number with $N \neq 0$ which is not a square (no $r$ with $N = r\cdot r$), and
+let `data` be an element of [`ModularCurve.ModularPolynomialData N`](def/ModularCurve_X0.html#L215),
+that is: a polynomial $\Phi =$ `data.Φ` in $(\mathbb{Z}[X])[Y]$ together with the three properties
+recorded in that structure — $\Phi$ is monic in $Y$; its degree in $Y$ equals `dedekindPsi N`,
+defined as $\sum_{d \mid N,\ d \text{ squarefree}} N/d$; and $\Phi$ annihilates the pair consisting
+of the $q$-expansion of $j$ and that of $j(q^N)$, in the sense that evaluating $\Phi$ at $Y =$ `jqN
+N` with coefficients mapped by the ring homomorphism `evalAtJ` $\colon \mathbb{Z}[X] \to$
+`LaurentSeries ℚ` sending $X$ to `jq` gives $0$. The assertion is that the diagonal specialisation
+obtained by substituting $Y \mapsto X$ while leaving the coefficient ring $\mathbb{Z}[X]$ untouched,
+namely $\Phi(X,X) \in \mathbb{Z}[X]$, has leading coefficient a unit of $\mathbb{Z}$, i.e. $\pm 1$;
+in particular $\Phi(X,X)$ is not the zero polynomial.
+
+This is the integrality statement underlying Kronecker's congruence: the diagonal of the modular
+polynomial of non-square level has unimodular leading term, the non-square hypothesis excluding the
+tie between the Hermite slots with $a = d$ (and the degenerate level $N=1$, where $\Phi_1(X,X) =
+0$). It is used in the derivation of the corresponding statement for `isUnit_leadingCoeff_diag`, and
+in the Weierstrass-curve lemmas separating $j$-invariants of an elliptic curve and of its quotient
+by a cyclic isogeny, respectively producing a reduction with prescribed behaviour over an
+algebraically closed residue field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ModularPolynomialData_isUnit_leadingCoeff_diag_of_not_isSquare.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_9658fb33
+
+noncomputable section
+
+p2m_open "ModularCurve~coeffEmb_qExpand \
+  P2MW.S_OVERLONG_9658fb33.ModularCurve \
+  ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_pow_self coeff_jq_pow_of_lt coeff_jq_neg_one coeff_jq_of_lt jqN \
+  dedekindPsi evalAtJ evalAtJ_X ModularPolynomialData evalAtJGen algebraMap_comp_evalAtJGen \
+  ModularPolynomialData.toAdjoin coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  minpoly_jqN_map_eq_prod_slots finrank_adjoin_jqN_eq_dedekindPsi modularFunctionField_eq_full"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+
+
+
+
+
+
+
+
+
+
+theorem coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb K (qExpand ℚ n x) = qExpand K n (coeffEmb K x) :=
+  coeffMap_qExpand (algebraMap ℚ K) n x
+
+theorem iota_jqN (N d : ℕ) [NeZero N] [NeZero d] :
+    coeffEmb K (qExpand ℚ N (jqN d)) = TS K (N * d) 1 := by
+  rw [jqN, coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem iota_jq (N : ℕ) [NeZero N] : coeffEmb K (qExpand ℚ N jq) = TS K N 1 := by
+  rw [coeffEmb_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_zero_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    conj p ζ (0 : Fin (p + 1)) = TS K (p * p) 1 := by
+  rw [conj_zero, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_succ_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) (b : Fin p) :
+    conj p ζ b.succ = TS K 1 (ζ ^ (b : ℕ)) := by
+  rw [conj_succ, TS_eq_coeffEmb, qExpand_one_apply]
+
+theorem qTwist_iota_of_pow_eq_one (N : ℕ) [NeZero N] (v : Kˣ) (hv : v ^ N = 1) (x : LaurentSeries ℚ)
+    :
+    qTwist v (coeffEmb K (qExpand ℚ N x)) = coeffEmb K (qExpand ℚ N x) := by
+  rw [coeffEmb_qExpand, qTwist_qExpand]
+  have : v ^ (N : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_pow_self coeff_jq_pow_of_lt coeff_jq_neg_one coeff_jq_of_lt jqN \
+  dedekindPsi evalAtJ evalAtJ_X ModularPolynomialData evalAtJGen algebraMap_comp_evalAtJGen \
+  ModularPolynomialData.toAdjoin coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  minpoly_jqN_map_eq_prod_slots finrank_adjoin_jqN_eq_dedekindPsi modularFunctionField_eq_full"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+omit [Algebra ℚ K] in
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+omit [Algebra ℚ K] in
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+omit [Algebra ℚ K] in
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem phiProd_conj_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    phiProd p (conj p ζ) = (Polynomial.X - Polynomial.C (TS K (p * p) 1)) *
+      ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) := by
+  rw [phiProd, Fin.prod_univ_succ, conj_zero_eq]
+  congr 1
+  rw [← Fin.prod_univ_eq_prod_range (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) p]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [conj_succ_eq]
+
+theorem roots_phiProd_conj (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    (phiProd p (conj p ζ)).roots = TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^
+      b)) := by
+  classical
+  rw [phiProd_conj_eq]
+  have h1 : (Polynomial.X - Polynomial.C (TS K (p * p) 1) : Polynomial (LaurentSeries K)) ≠ 0 :=
+    Polynomial.X_sub_C_ne_zero _
+  have h2 : (∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b)))) ≠ 0 :=
+    Finset.prod_ne_zero_iff.mpr fun b _ => Polynomial.X_sub_C_ne_zero _
+  rw [Polynomial.roots_mul (mul_ne_zero h1 h2), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod,
+    Finset.range_val]
+  have hm : (Multiset.map (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) (Multiset.range
+    p)) =
+      ((Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).map (fun a => Polynomial.X - Polynomial.C
+        a) := by
+    rw [Multiset.map_map]; rfl
+  rw [hm, Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+omit [Algebra ℚ K] in
+theorem roots_phiProd_conj_nodup (p : ℕ) [hp : Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).Nodup := by
+  refine Multiset.nodup_cons.mpr ⟨?_, ?_⟩
+  · intro hmem
+    obtain ⟨b, -, hb⟩ := Multiset.mem_map.mp hmem
+    have := (TS_injective hb).1
+    have h2 := hp.out.two_le
+    nlinarith
+  · refine (Multiset.nodup_range p).map_on fun b hb b' hb' hbb' => ?_
+    rw [Multiset.mem_range] at hb hb'
+    have hu := (TS_injective hbb').2
+    have hζu : IsPrimitiveRoot ζ p := IsPrimitiveRoot.coe_units_iff.mp hζ
+    exact hζu.pow_inj hb hb' hu
+
+theorem exists_isPrimitiveRoot_cyclotomicField (N : ℕ) [NeZero N] :
+    ∃ z : CyclotomicField N ℚ, IsPrimitiveRoot z N := by
+  have : NeZero ((N : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr (NeZero.ne N)⟩
+  have : IsCyclotomicExtension {N} ℚ (CyclotomicField N ℚ) :=
+    CyclotomicField.isCyclotomicExtension N ℚ
+  exact IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField N ℚ) (Set.mem_singleton N)
+    (NeZero.ne N)
+
+def cycUnit (N : ℕ) [NeZero N] : (CyclotomicField N ℚ)ˣ :=
+  ((exists_isPrimitiveRoot_cyclotomicField N).choose_spec.isUnit (NeZero.ne N)).unit
+
+theorem cycUnit_spec (N : ℕ) [NeZero N] :
+    IsPrimitiveRoot ((cycUnit N : (CyclotomicField N ℚ)ˣ) : CyclotomicField N ℚ) N := by
+  rw [cycUnit, IsUnit.unit_spec]
+  exact (exists_isPrimitiveRoot_cyclotomicField N).choose_spec
+
+theorem cycUnit_pow (N : ℕ) [NeZero N] : cycUnit N ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, (cycUnit_spec N).pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_pow_self coeff_jq_pow_of_lt coeff_jq_neg_one coeff_jq_of_lt jqN \
+  dedekindPsi evalAtJ evalAtJ_X ModularPolynomialData evalAtJGen algebraMap_comp_evalAtJGen \
+  ModularPolynomialData.toAdjoin coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  minpoly_jqN_map_eq_prod_slots finrank_adjoin_jqN_eq_dedekindPsi modularFunctionField_eq_full"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_pow_self coeff_jq_pow_of_lt coeff_jq_neg_one coeff_jq_of_lt jqN \
+  dedekindPsi evalAtJ evalAtJ_X ModularPolynomialData evalAtJGen algebraMap_comp_evalAtJGen \
+  ModularPolynomialData.toAdjoin coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  minpoly_jqN_map_eq_prod_slots finrank_adjoin_jqN_eq_dedekindPsi modularFunctionField_eq_full"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem prod_form_ne_zero (N : ℕ) (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e]
+    (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K
+            jq)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+          (Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u,
+    Polynomial.roots_mul (prod_form_ne_zero N ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p)))
+    (coeffEmb K jq))))
+        = ((Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+        (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+        (Multiset.range p).map
+          (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).Nodup := by
+  have hζp : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := isPrimitiveRoot_pow_div hζ hpN
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h := (TS_injective (K := K) (e := e) (e' := p * (p * e))
+      (u := u * ζ ^ (b * (N / p))) (u' := u ^ (p * p))
+      (by simpa only [TS_eq_coeffEmb] using heq)).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e)
+      (u := u * ζ ^ (b * (N / p))) (u' := u * ζ ^ (b' * (N / p)))
+      (by simpa only [TS_eq_coeffEmb] using heq)).2
+    have h2 : ζ ^ (b * (N / p)) = ζ ^ (b' * (N / p)) := mul_left_cancel h
+    have h3 : (ζ ^ (N / p)) ^ b = (ζ ^ (N / p)) ^ b' := by
+      rw [← pow_mul, ← pow_mul, Nat.mul_comm (N / p) b, Nat.mul_comm (N / p) b']
+      exact h2
+    have h4 : ((ζ ^ (N / p) : Kˣ) : K) ^ b = ((ζ ^ (N / p) : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h3]
+    exact hζp.pow_inj hb hb' h4
+
+theorem roots_prime_at_slot_roots_nodup (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots.Nodup := by
+  rw [roots_prime_at_slot N ζ hζ p hpN data e u]
+  exact roots_prime_at_slot_nodup N ζ hζ p hpN e u
+
+theorem isRoot_prime_at_slot_iff (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u]
+    exact prod_form_ne_zero N ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot N ζ hζ p hpN data e u,
+    Multiset.mem_cons, Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_pow_self coeff_jq_pow_of_lt coeff_jq_neg_one coeff_jq_of_lt jqN \
+  dedekindPsi evalAtJ evalAtJ_X ModularPolynomialData evalAtJGen algebraMap_comp_evalAtJGen \
+  ModularPolynomialData.toAdjoin coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  minpoly_jqN_map_eq_prod_slots finrank_adjoin_jqN_eq_dedekindPsi modularFunctionField_eq_full"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+
+
+
+
+theorem phiAtSeed_jq_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) :
+    (phiAtSeed data jq).eval (jqN n) = 0 := by
+  have h := data.eval_eq_zero
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp [evalAtJ_X]
+
+
+theorem phiAtSeed_jqN_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN M)).eval (jqN (M * n)) = 0 := by
+  have h := phiAtSeed_eval_map data jq (jqN n) (qExpand ℚ M) (phiAtSeed_jq_eval n data)
+  rwa [jqN, qExpand_qExpand] at h
+
+theorem phiAtSeed_iota_eval {K : Type*} [Field K] [Algebra ℚ K] (A : ℕ) [NeZero A] (n : ℕ)
+    [NeZero n]
+    (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (coeffEmb K (qExpand ℚ A (jqN M)))).eval (coeffEmb K (qExpand ℚ A (jqN (M *
+      n)))) = 0 :=
+  phiAtSeed_eval_map data _ _ ((coeffEmb K).comp (qExpand ℚ A)) (phiAtSeed_jqN_eval n data M)
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_pow_self coeff_jq_pow_of_lt coeff_jq_neg_one coeff_jq_of_lt jqN \
+  dedekindPsi evalAtJ evalAtJ_X ModularPolynomialData evalAtJGen algebraMap_comp_evalAtJGen \
+  ModularPolynomialData.toAdjoin coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  minpoly_jqN_map_eq_prod_slots finrank_adjoin_jqN_eq_dedekindPsi modularFunctionField_eq_full"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+section U2Kit
+
+variable {K : Type*} [Field K]
+
+private theorem w1_order_eq {x : LaurentSeries K} {a : ℤ}
+    (hne : x.coeff a ≠ 0) (hlow : ∀ k, k < a → x.coeff k = 0) :
+    x.order = a ∧ x.leadingCoeff = x.coeff a := by
+  have hx0 : x ≠ 0 := fun h0 => hne (by simp [h0])
+  have h1 : x.order = a := by
+    refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero hne) (not_lt.mp fun hlt => ?_)
+    exact hx0 (HahnSeries.coeff_order_eq_zero.mp (hlow _ hlt))
+  exact ⟨h1, by rw [HahnSeries.leadingCoeff_eq, h1]⟩
+
+private theorem w1_order_TS (e : ℕ) [NeZero e] (u : Kˣ) :
+    (TS K e u).order = -(e : ℤ) ∧ (TS K e u).leadingCoeff = ((u⁻¹ : Kˣ) : K) := by
+  have h := w1_order_eq (x := TS K e u) (a := -(e : ℤ))
+    (by rw [TS_coeff_neg]; exact Units.ne_zero _) (fun k hk => TS_coeff_of_lt (K := K) e u hk)
+  exact ⟨h.1, by rw [h.2, TS_coeff_neg]⟩
+
+private theorem w1_order_sub_right {x y : LaurentSeries K}
+    (h : y.order < x.order) (hy : y ≠ 0) :
+    (x - y).order = y.order ∧ (x - y).leadingCoeff = -y.leadingCoeff := by
+  have hat : (x - y).coeff y.order = -y.leadingCoeff := by
+    rw [HahnSeries.coeff_sub, HahnSeries.coeff_eq_zero_of_lt_order h, zero_sub,
+      HahnSeries.leadingCoeff_eq]
+  have h' := w1_order_eq (x := x - y) (a := y.order)
+    (by rw [hat, neg_ne_zero]; exact fun h0 => hy (HahnSeries.leadingCoeff_eq_zero.mp h0))
+    (fun k hk => by
+      rw [HahnSeries.coeff_sub, HahnSeries.coeff_eq_zero_of_lt_order (hk.trans h),
+        HahnSeries.coeff_eq_zero_of_lt_order hk, sub_zero])
+  exact ⟨h'.1, by rw [h'.2, hat]⟩
+
+private theorem w1_order_sub_left {x y : LaurentSeries K}
+    (h : x.order < y.order) (hx : x ≠ 0) :
+    (x - y).order = x.order ∧ (x - y).leadingCoeff = x.leadingCoeff := by
+  have hat : (x - y).coeff x.order = x.leadingCoeff := by
+    rw [HahnSeries.coeff_sub, HahnSeries.coeff_eq_zero_of_lt_order h, sub_zero,
+      HahnSeries.leadingCoeff_eq]
+  have h' := w1_order_eq (x := x - y) (a := x.order)
+    (by rw [hat]; exact fun h0 => hx (HahnSeries.leadingCoeff_eq_zero.mp h0))
+    (fun k hk => by
+      rw [HahnSeries.coeff_sub, HahnSeries.coeff_eq_zero_of_lt_order hk,
+        HahnSeries.coeff_eq_zero_of_lt_order (hk.trans h), sub_zero])
+  exact ⟨h'.1, by rw [h'.2, hat]⟩
+
+private theorem w1_prod_ne_zero_leadingCoeff {α : Type*} (s : Finset α)
+    (F : α → LaurentSeries K) (h : ∀ i ∈ s, F i ≠ 0) :
+    (∏ i ∈ s, F i) ≠ 0 ∧ (∏ i ∈ s, F i).leadingCoeff = ∏ i ∈ s, (F i).leadingCoeff := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => simp
+  | insert a s ha ih =>
+    obtain ⟨h0, hlc⟩ := ih fun i hi => h i (Finset.mem_insert_of_mem hi)
+    have ha0 : F a ≠ 0 := h a (Finset.mem_insert_self a s)
+    have hne : (F a).leadingCoeff * (∏ i ∈ s, F i).leadingCoeff ≠ 0 :=
+      mul_ne_zero (fun hz => ha0 (HahnSeries.leadingCoeff_eq_zero.mp hz))
+        (fun hz => h0 (HahnSeries.leadingCoeff_eq_zero.mp hz))
+    rw [Finset.prod_insert ha, Finset.prod_insert ha]
+    exact ⟨mul_ne_zero ha0 h0,
+      by rw [HahnSeries.leadingCoeff_mul_of_ne_zero hne, hlc]⟩
+
+private theorem w1_slot_factor (N a b : ℕ) [NeZero N] [NeZero a] (hN : ¬ IsSquare N)
+    (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N) :
+    (TS K N 1 - TS K (a * a) (ζ ^ (b * a))) ≠ 0 ∧
+      (TS K N 1 - TS K (a * a) (ζ ^ (b * a))).leadingCoeff ^ (2 * N) = 1 := by
+  have hne : a * a ≠ N := fun h => hN ⟨a, h.symm⟩
+  rcases Nat.lt_or_gt_of_ne hne with hlt | hgt
+  · obtain ⟨hoN, hlN⟩ := w1_order_TS (K := K) N 1
+    obtain ⟨hoa, _⟩ := w1_order_TS (K := K) (a * a) (ζ ^ (b * a))
+    have hord : (TS K N 1).order < (TS K (a * a) (ζ ^ (b * a))).order := by
+      rw [hoN, hoa]
+      push_cast
+      omega
+    obtain ⟨_, hlc⟩ := w1_order_sub_left hord (TS_ne_zero (K := K) N 1)
+    have hlc1 : (TS K N 1 - TS K (a * a) (ζ ^ (b * a))).leadingCoeff = 1 := by
+      rw [hlc, hlN, inv_one, Units.val_one]
+    refine ⟨fun h0 => one_ne_zero (α := K) ?_, by rw [hlc1, one_pow]⟩
+    rw [← hlc1, h0, HahnSeries.leadingCoeff_eq_zero.mpr rfl]
+  · obtain ⟨hoN, _⟩ := w1_order_TS (K := K) N 1
+    obtain ⟨hoa, hla⟩ := w1_order_TS (K := K) (a * a) (ζ ^ (b * a))
+    have hord : (TS K (a * a) (ζ ^ (b * a))).order < (TS K N 1).order := by
+      rw [hoN, hoa]
+      push_cast
+      omega
+    obtain ⟨_, hlc⟩ := w1_order_sub_right hord (TS_ne_zero (K := K) (a * a) (ζ ^ (b * a)))
+    have hlcv : (TS K N 1 - TS K (a * a) (ζ ^ (b * a))).leadingCoeff =
+        -((ζ : K) ^ (b * a))⁻¹ := by
+      rw [hlc, hla, Units.val_inv_eq_inv_val, Units.val_pow_eq_pow_val]
+    have hvne : -((ζ : K) ^ (b * a))⁻¹ ≠ 0 := by
+      rw [neg_ne_zero]
+      exact inv_ne_zero (pow_ne_zero _ (Units.ne_zero ζ))
+    refine ⟨fun h0 => hvne ?_, ?_⟩
+    · rw [← hlcv, h0, HahnSeries.leadingCoeff_eq_zero.mpr rfl]
+    · have hzN : (ζ : K) ^ N = 1 := hζ.pow_eq_one
+      have hv : (((ζ : K) ^ (b * a)) ^ (2 * N) : K) = 1 := by
+        rw [← pow_mul, show b * a * (2 * N) = N * (2 * (b * a)) by ring, pow_mul, hzN, one_pow]
+      have heven : Even (2 * N) := ⟨N, by ring⟩
+      rw [hlcv, heven.neg_pow, inv_pow, hv, inv_one]
+
+end U2Kit
+end ModularCurve.W1
+
+open scoped IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_pow_self coeff_jq_pow_of_lt coeff_jq_neg_one coeff_jq_of_lt jqN \
+  dedekindPsi evalAtJ evalAtJ_X ModularPolynomialData evalAtJGen algebraMap_comp_evalAtJGen \
+  ModularPolynomialData.toAdjoin coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  minpoly_jqN_map_eq_prod_slots finrank_adjoin_jqN_eq_dedekindPsi modularFunctionField_eq_full"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+private theorem w1_evalAtJGen_injective : Function.Injective evalAtJGen := by
+  have h : Function.Injective ((algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) ∘ evalAtJGen) := by
+    rw [← RingHom.coe_comp, algebraMap_comp_evalAtJGen]
+    exact evalAtJ_injective
+  exact h.of_comp
+
+private theorem w1_aeval_jqN_toAdjoin {N : ℕ} [NeZero N] (data : ModularPolynomialData N) :
+    Polynomial.aeval (jqN N) data.toAdjoin = 0 := by
+  rw [ModularPolynomialData.toAdjoin, Polynomial.aeval_def, Polynomial.eval₂_map,
+    algebraMap_comp_evalAtJGen]
+  exact data.eval_eq_zero
+
+private theorem w1_natDegree_toAdjoin {N : ℕ} [NeZero N] (data : ModularPolynomialData N) :
+    data.toAdjoin.natDegree = dedekindPsi N := by
+  rw [ModularPolynomialData.toAdjoin, data.monic.natDegree_map, data.natDegree_eq]
+
+private theorem w1_toAdjoin_eq_minpoly (N : ℕ) [NeZero N] (data : ModularPolynomialData N) :
+    data.toAdjoin = minpoly ℚ⟮jq⟯ (jqN N) := by
+  have hint : IsIntegral ℚ⟮jq⟯ (jqN N) := ⟨data.toAdjoin, data.toAdjoin_monic, by
+    simpa [Polynomial.aeval_def] using w1_aeval_jqN_toAdjoin data⟩
+  have hdeg : (minpoly ℚ⟮jq⟯ (jqN N)).natDegree = dedekindPsi N := by
+    rw [← IntermediateField.adjoin.finrank hint]
+    exact finrank_adjoin_jqN_eq_dedekindPsi N
+  refine Polynomial.eq_of_monic_of_dvd_of_natDegree_le (minpoly.monic hint) data.toAdjoin_monic
+    (minpoly.dvd _ _ (w1_aeval_jqN_toAdjoin data)) ?_
+  rw [hdeg, w1_natDegree_toAdjoin]
+
+private theorem w1_diag_lc_pow (N : ℕ) [NeZero N] (hN : ¬ IsSquare N)
+    (data : ModularPolynomialData N) :
+    (data.Φ.eval₂ (RingHom.id (Polynomial ℤ)) Polynomial.X).leadingCoeff ^ (2 * N) = 1 := by
+  classical
+  set D : Polynomial ℤ := data.Φ.eval₂ (RingHom.id (Polynomial ℤ)) Polynomial.X with hD
+  set K := CyclotomicField N ℚ with hK
+  set ζ : Kˣ := cycUnit N with hζdef
+  have hζ := cycUnit_spec N
+  set f : LaurentSeries ℚ →+* LaurentSeries K := (coeffEmb K).comp (qExpand ℚ N) with hf
+  set W : LaurentSeries ℚ := evalAtJ D with hW
+  have hcensus := minpoly_jqN_map_eq_prod_slots (K := K) N ζ hζ
+    (fun d _ _ => ⟨finrank_adjoin_jqN_eq_dedekindPsi d, modularFunctionField_eq_full d⟩)
+  have hhom : ((((coeffEmb K).comp (qExpand ℚ N)).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ))).comp evalAtJGen) = f.comp evalAtJ := by
+    rw [RingHom.comp_assoc, algebraMap_comp_evalAtJGen, hf]
+  have hmaps : data.Φ.map (f.comp evalAtJ) =
+      ∏ a ∈ N.divisors, ∏ b ∈ (Finset.range (N / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (N / a) = 1),
+        (Polynomial.X - Polynomial.C (if h : a = 0 then 0 else
+          letI : NeZero a := ⟨h⟩; qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)))) := by
+    rw [← hcensus, ← w1_toAdjoin_eq_minpoly N data, ModularPolynomialData.toAdjoin,
+      Polynomial.map_map, hhom]
+  have hfjq : f jq = TS K N 1 := iota_jq N
+  have hfact : f W = ∏ a ∈ N.divisors, ∏ b ∈ (Finset.range (N / a)).filter
+      (fun b => Nat.gcd (Nat.gcd a b) (N / a) = 1),
+      (TS K N 1 - (if h : a = 0 then 0 else
+        letI : NeZero a := ⟨h⟩; qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)))) := by
+    have h1 : f W = (data.Φ.map (f.comp evalAtJ)).eval (f jq) := by
+      rw [hW, ← RingHom.comp_apply, hD, Polynomial.hom_eval₂, RingHom.comp_id,
+        Polynomial.eval₂_eq_eval_map, RingHom.comp_apply, evalAtJ_X]
+    rw [h1, hmaps, Polynomial.eval_prod]
+    refine Finset.prod_congr rfl fun a _ => ?_
+    rw [Polynomial.eval_prod]
+    refine Finset.prod_congr rfl fun b _ => ?_
+    rw [Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, hfjq]
+  have hinner : ∀ a ∈ N.divisors,
+      (∏ b ∈ (Finset.range (N / a)).filter (fun b => Nat.gcd (Nat.gcd a b) (N / a) = 1),
+        (TS K N 1 - (if h : a = 0 then 0 else
+          letI : NeZero a := ⟨h⟩; qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq))))) ≠ 0 ∧
+      ((∏ b ∈ (Finset.range (N / a)).filter (fun b => Nat.gcd (Nat.gcd a b) (N / a) = 1),
+        (TS K N 1 - (if h : a = 0 then 0 else
+          letI : NeZero a := ⟨h⟩; qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K
+            jq))))).leadingCoeff)
+        ^ (2 * N) = 1 := by
+    intro a ha
+    have ha0 : a ≠ 0 := (Nat.pos_of_mem_divisors ha).ne'
+    have : NeZero a := ⟨ha0⟩
+    have hdval : ∀ b : ℕ, (if h : a = 0 then (0 : LaurentSeries K) else
+        letI : NeZero a := ⟨h⟩; qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq))) =
+        TS K (a * a) (ζ ^ (b * a)) := fun b => by rw [dite_eq_right ha0, TS_eq_coeffEmb]
+    simp only [hdval]
+    obtain ⟨hne, hlc⟩ := w1_prod_ne_zero_leadingCoeff (K := K)
+      ((Finset.range (N / a)).filter (fun b => Nat.gcd (Nat.gcd a b) (N / a) = 1))
+      (fun b => TS K N 1 - TS K (a * a) (ζ ^ (b * a)))
+      (fun b _ => (w1_slot_factor N a b hN ζ hζ).1)
+    refine ⟨hne, ?_⟩
+    rw [hlc, ← Finset.prod_pow]
+    exact Finset.prod_eq_one fun b _ => (w1_slot_factor N a b hN ζ hζ).2
+  obtain ⟨houter_ne, houter_lc⟩ := w1_prod_ne_zero_leadingCoeff (K := K) N.divisors _
+    (fun a ha => (hinner a ha).1)
+  have hfW_ne : f W ≠ 0 := by rw [hfact]; exact houter_ne
+  have hfW_pow : (f W).leadingCoeff ^ (2 * N) = 1 := by
+    rw [hfact, houter_lc, ← Finset.prod_pow]
+    exact Finset.prod_eq_one fun a ha => (hinner a ha).2
+  have hW_ne : W ≠ 0 := fun h0 => hfW_ne (by rw [h0, map_zero])
+  have hD0 : D ≠ 0 := fun h0 => hW_ne (by rw [hW, h0, map_zero])
+  have hEJ : evalAtJ = Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries ℚ)) jq := by
+    refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+    simp [evalAtJ, Polynomial.coe_eval₂RingHom]
+  have hsum : evalAtJ D = ∑ i ∈ Finset.range (D.natDegree + 1), (D.coeff i) • jq ^ i := by
+    rw [hEJ]
+    change Polynomial.eval₂ (Int.castRingHom (LaurentSeries ℚ)) jq D = _
+    rw [Polynomial.eval₂_eq_sum_range]
+    exact Finset.sum_congr rfl fun i _ => (zsmul_eq_mul _ _).symm
+  have hWcoeff : ∀ m : ℤ, W.coeff m =
+      ∑ i ∈ Finset.range (D.natDegree + 1), (D.coeff i) • (jq ^ i).coeff m := by
+    intro m
+    rw [hW, hsum, HahnSeries.coeff_sum]
+    exact Finset.sum_congr rfl fun i _ => HahnSeries.coeff_smul
+  have hlow : ∀ m : ℤ, m < -(D.natDegree : ℤ) → W.coeff m = 0 := by
+    intro m hm
+    rw [hWcoeff]
+    refine Finset.sum_eq_zero fun i hi => ?_
+    rw [coeff_jq_pow_of_lt, smul_zero]
+    have : i ≤ D.natDegree := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)
+    omega
+  have htop : W.coeff (-(D.natDegree : ℤ)) = (D.leadingCoeff : ℚ) := by
+    rw [hWcoeff]
+    rw [Finset.sum_eq_single D.natDegree]
+    · rw [coeff_jq_pow_self, Polynomial.leadingCoeff]
+      rw [zsmul_eq_mul, mul_one]
+    · intro i hi hne
+      have hilt : i < D.natDegree :=
+        lt_of_le_of_ne (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hne
+      rw [coeff_jq_pow_of_lt (by omega), smul_zero]
+    · intro h
+      exact absurd (Finset.mem_range.mpr D.natDegree.lt_succ_self) h
+  have hPcoeff : ∀ m : ℤ, (f W).coeff ((N : ℤ) * m) = algebraMap ℚ K (W.coeff m) := by
+    intro m
+    rw [hf, RingHom.comp_apply, coeffEmb_coeff, qExpand_coeff_mul]
+  have hPnd : ∀ k : ℤ, ¬ (N : ℤ) ∣ k → (f W).coeff k = 0 := by
+    intro k hk
+    rw [hf, RingHom.comp_apply, coeffEmb_coeff, qExpand_coeff_of_not_dvd N W hk, map_zero]
+  have hcoeff_at : (f W).coeff ((N : ℤ) * (-(D.natDegree : ℤ))) =
+      algebraMap ℚ K ((D.leadingCoeff : ℚ)) := by
+    rw [hPcoeff, htop]
+  have hlcD : (f W).leadingCoeff = algebraMap ℚ K ((D.leadingCoeff : ℚ)) := by
+    have hne_at : (f W).coeff ((N : ℤ) * (-(D.natDegree : ℤ))) ≠ 0 := by
+      rw [hcoeff_at]
+      intro h0
+      have : (D.leadingCoeff : ℚ) = 0 := (algebraMap ℚ K).injective (by rw [h0, map_zero])
+      exact Polynomial.leadingCoeff_ne_zero.mpr hD0 (by exact_mod_cast this)
+    have hbelow : ∀ k : ℤ, k < (N : ℤ) * (-(D.natDegree : ℤ)) → (f W).coeff k = 0 := by
+      intro k hk
+      by_cases hdvd : (N : ℤ) ∣ k
+      · obtain ⟨m, rfl⟩ := hdvd
+        rw [hPcoeff]
+        have hNpos : (0 : ℤ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+        rw [hlow m (lt_of_mul_lt_mul_left hk hNpos.le), map_zero]
+      · exact hPnd _ hdvd
+    obtain ⟨_, hlc_eq⟩ := w1_order_eq hne_at hbelow
+    rw [hlc_eq, hcoeff_at]
+  have hQpow : ((D.leadingCoeff : ℚ)) ^ (2 * N) = 1 := by
+    refine (algebraMap ℚ K).injective ?_
+    rw [map_pow, map_one, ← hlcD]
+    exact hfW_pow
+  exact_mod_cast hQpow
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_pow_self coeff_jq_pow_of_lt coeff_jq_neg_one coeff_jq_of_lt jqN \
+  dedekindPsi evalAtJ evalAtJ_X ModularPolynomialData evalAtJGen algebraMap_comp_evalAtJGen \
+  ModularPolynomialData.toAdjoin coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  minpoly_jqN_map_eq_prod_slots finrank_adjoin_jqN_eq_dedekindPsi modularFunctionField_eq_full"
+namespace ModularPolynomialData
+p2m_export "ModularCurve.ModularPolynomialData" "toAdjoin toAdjoin_monic monic eval_eq_zero \
+  natDegree_eq Φ"
+end ModularCurve.ModularPolynomialData
+p2m_open_scoped "ModularCurve ModularCurve.ModularPolynomialData" in
+private theorem ModularCurve.ModularPolynomialData.isUnit_leadingCoeff_diag_of_not_isSquare
+    (N : ℕ) [NeZero N] (hN : ¬ IsSquare N) (data : ModularCurve.ModularPolynomialData N) :
+    IsUnit (data.Φ.eval₂ (RingHom.id (Polynomial ℤ)) Polynomial.X).leadingCoeff := by
+  have h := ModularCurve.W1.w1_diag_lc_pow N hN data
+  have h1 : (data.Φ.eval₂ (RingHom.id (Polynomial ℤ)) Polynomial.X).leadingCoeff.natAbs
+      ^ (2 * N) = 1 := by
+    have h' := congrArg Int.natAbs h
+    rwa [Int.natAbs_pow] at h'
+  have h2 : (data.Φ.eval₂ (RingHom.id (Polynomial ℤ)) Polynomial.X).leadingCoeff.natAbs = 1 := by
+    rcases Nat.pow_eq_one.mp h1 with h' | h'
+    · exact h'
+    · have := NeZero.ne N
+      omega
+  exact Int.isUnit_iff.mpr ((Int.natAbs_eq_iff.mp h2).imp id (by simp))
+
+p2m_open_scoped "ModularCurve ModularCurve.ModularPolynomialData" in
+theorem ModularCurve.ModularPolynomialData.leadingCoeff_diag_sq_eq_one
+    (N : ℕ) [NeZero N] (hN : ¬ IsSquare N) (data : ModularCurve.ModularPolynomialData N) :
+    (data.Φ.eval₂ (RingHom.id (Polynomial ℤ)) Polynomial.X).leadingCoeff ^ 2 = 1 := by
+  rcases Int.isUnit_iff.mp
+    (ModularCurve.ModularPolynomialData.isUnit_leadingCoeff_diag_of_not_isSquare N hN data)
+    with h | h <;> rw [h] <;> norm_num
+
+end
+
+p2m_open "ModularCurve~coeffEmb_qExpand\
+  " in
+open
+  _root_.P2MW.S_OVERLONG_9658fb33.ModularCurve
+  in
+theorem solution (N : ℕ) [NeZero N] (hN : ¬ IsSquare N)
+    (data : ModularCurve.ModularPolynomialData N) :
+    IsUnit (data.Φ.eval₂ (RingHom.id (Polynomial ℤ)) Polynomial.X).leadingCoeff :=
+  ModularCurve.ModularPolynomialData.isUnit_leadingCoeff_diag_of_not_isSquare N hN data
+
+end S_OVERLONG_9658fb33
+end P2MW
+export P2MW.S_OVERLONG_9658fb33 (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.ModularPolynomialData.isUnit_leadingCoeff_diag_of_not_isSquare (N : ℕ)
+    [NeZero N] (hN : ¬ IsSquare N) (data : ModularCurve.ModularPolynomialData N) :
+    IsUnit (data.Φ.eval₂ (RingHom.id (Polynomial ℤ)) Polynomial.X).leadingCoeff :=
+  solution N hN data
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental.lean
new file mode 100644
index 0000000000..85fbdb7856
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental.lean
@@ -0,0 +1,623 @@
+/-
+Based on Prove2Me node ModularCurve.ModularPolynomialData.mem_of_isRoot_map_j_of_transcendental
+(32dd0688-a2b7-5e48-b76f-7914181d8c1e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 763104d4-878a-531a-90b7-72887afb5599
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_pushforwardAlong_pushforwardAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteAlong_comp
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_isAlgClosed_rat
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental_of_odd
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_card_roots_fibrePoly_of_monic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_forall_pointEnd_eq_zsmul_of_transcendental_j
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_and_abelTheorem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_ker_pointMapOfPushforward_eq_of_j_eq_of_forall_pointEnd_eq_zsmul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_velu2FunctionFieldHom_restrictAlong_placeOfPoint_veluPointMap2
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_isElliptic_veluQuotient2_of_isElliptic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_veluQuotient2_Delta_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_veluQuotient_j_mem_of_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_veluQuotient_oddOrderSummingSet_discriminant_ne_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Roots of Φ_N(j(W),Y) lie in the N-torsion field
+
+Theorem statement: `ModularCurve.ModularPolynomialData.mem_of_isRoot_map_j_of_transcendental`
+(`32dd0688-a2b7-5e48-b76f-7914181d8c1e`), by Claude, 2026-09-05.
+
+Proof: submission `763104d4-878a-531a-90b7-72887afb5599`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and let $\mathbb{K}$ denote the field of Hahn series with
+exponents in $\mathbb{Q}$ and coefficients in $\overline{\mathbb{Q}}$. Let `data` be a
+`ModularPolynomialData N`, that is, a polynomial $\Phi \in \mathbb{Z}[X][Y]$ which is monic, of
+degree in $Y$ equal to $\psi(N) = \sum_{d \mid N,\ d \text{ squarefree}} N/d$, and which vanishes
+when $X$ is substituted by the $q$-expansion of $j$ and $Y$ by that of $j(q^N)$. Let $W$ be a
+Weierstrass curve over $\mathbb{K}$ whose discriminant is a unit, and assume its $j$-invariant is
+transcendental over $\mathbb{Q}$. Let $L$ be a subfield of $\mathbb{K}$ containing the five
+coefficients $a_1, a_2, a_3, a_4, a_6$ of $W$ and such that, for every nonsingular affine point
+$(x,y)$ of $W$ killed by $N$ in the group of points, both $x$ and $y$ lie in $L$. Then every root $r
+\in \mathbb{K}$ of the one-variable polynomial over $\mathbb{K}$ obtained from $\Phi$ by mapping
+each coefficient in $\mathbb{Z}[X]$ to its value at $j(W)$ — that is, of $\Phi(j(W), Y)$ — lies in
+$L$.
+
+This is the statement that the $\psi(N)$ roots of the specialised modular polynomial
+$\Phi_N(j(W),Y)$, namely the $j$-invariants of the quotients of $W$ by its cyclic subgroups of order
+$N$, are defined over any field of definition of $W$ together with its $N$-torsion coordinates; it
+removes the parity restriction from the corresponding statement for odd $N$. It is used in the
+computations of the divisibility properties of the order of $\bar{j}$ and of $\bar{j} - 1728$ over
+the Hahn field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental
+
+
+noncomputable section
+
+open AlgebraicCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map b₂ a₄ a₂ a₆ Affine.Point.some \
+  Affine.Point.zero_def IsIntegral toAffine Affine.Point Δ Affine.Y_eq_of_X_eq \
+  Affine.Point.neg_some j veluGx veluGy veluGy_eq_zero_of_negY_eq veluQuotient oddOrderSummingSet \
+  mem_oddOrderSummingSet veluQuotient2 veluQuotient2_a₁ veluQuotient2_a₂ veluQuotient2_a₃ \
+  veluQuotient2_a₄ veluQuotient2_a₆ velu2X velu2Y veluPointMap2 veluPointMap2_zero \
+  veluPointMap2_some_of_eq veluPointMap2_some_of_ne \
+  Affine.eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward \
+  exists_velu2FunctionFieldHom_restrictAlong_placeOfPoint_veluPointMap2 \
+  Affine.ker_pointMapOfPushforward_eq_of_j_eq_of_forall_pointEnd_eq_zsmul \
+  exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples \
+  veluQuotient_oddOrderSummingSet_discriminant_ne_zero veluQuotient_j_mem_of_mem \
+  veluQuotient2_Delta_ne_zero isElliptic_veluQuotient2_of_isElliptic \
+  natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing map Point.some Nonsingular \
+  Point.zero_def FunctionField Point Y_eq_of_X_eq Point.neg_some pointMapOfPushforward \
+  pointMapOfPushforward_apply pointMapOfPushforward_eq_of_seam IsogenyEndDatum GenusOnePlaceGate \
+  pointClass AbelTheorem genusOnePic0Equiv genusOnePic0Equiv_symm_apply \
+  GenusOnePlaceGate.IsCentred \
+  eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward \
+  ker_pointMapOfPushforward_eq_of_j_eq_of_forall_pointEnd_eq_zsmul \
+  IsogenyEndDatum.exists_forall_pointEnd_eq_zsmul_of_transcendental_j \
+  exists_genusOnePlaceGate_isCentred_and_abelTheorem CoordinateRing.isDedekindDomain \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+scoped instance instHasPrincipalDivisorsFunctionField_a68p {F : Type*} [Field F] [CharZero F]
+    {W : Affine F} : HasPrincipalDivisors F W.FunctionField :=
+  hasPrincipalDivisors_functionField W
+
+section AutoNorm
+
+variable {F : Type*} [Field F] [CharZero F]
+variable {V W : Affine F} [V.IsElliptic] [W.IsElliptic]
+
+omit [WeierstrassCurve.IsElliptic V] [WeierstrassCurve.IsElliptic W] in
+theorem normFormulaAlong_of_elliptic (ι : V.FunctionField →ₐ[F] W.FunctionField)
+    (hfin : FiniteAlong F ι) : NormFormulaAlong F ι hfin := by
+  classical
+  have : CharZero V.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap F V.FunctionField).injective
+  have hsep : SeparableAlong F ι := by
+    let := algebraAlong ι
+    have := isScalarTower_along ι
+    have : Module.Finite V.FunctionField W.FunctionField := hfin
+    change Algebra.IsSeparable V.FunctionField W.FunctionField
+    infer_instance
+  exact AlgebraicCurve.normFormulaAlong ι hfin hsep
+
+end AutoNorm
+
+section Functoriality
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F]
+variable {A B C : Affine F}
+  [A.IsElliptic] [GenusOnePlaceGate A] [AbelTheorem A]
+  [B.IsElliptic] [GenusOnePlaceGate B] [AbelTheorem B]
+  [C.IsElliptic] [GenusOnePlaceGate C] [AbelTheorem C]
+
+omit [DecidableEq F] [WeierstrassCurve.IsElliptic A]
+  [A.GenusOnePlaceGate] [A.AbelTheorem] [WeierstrassCurve.IsElliptic B] [B.GenusOnePlaceGate]
+  [B.AbelTheorem] [WeierstrassCurve.IsElliptic C] [C.GenusOnePlaceGate] [C.AbelTheorem] in
+theorem Pic0_pushforwardAlongHom_comp
+    (f : B.FunctionField →ₐ[F] A.FunctionField) (hf : f.toRingHom.IsIntegral)
+    (hfinf : FiniteAlong F f) (hNf : NormFormulaAlong F f hfinf)
+    (g : C.FunctionField →ₐ[F] B.FunctionField) (hg : g.toRingHom.IsIntegral)
+    (hfing : FiniteAlong F g) (hNg : NormFormulaAlong F g hfing)
+    (hfg : (f.comp g).toRingHom.IsIntegral) (hfinfg : FiniteAlong F (f.comp g))
+    (hNfg : NormFormulaAlong F (f.comp g) hfinfg)
+    (x : Pic0 F A.FunctionField) :
+    Pic0.pushforwardAlongHom g hg hfing hNg (Pic0.pushforwardAlongHom f hf hfinf hNf x)
+      = Pic0.pushforwardAlongHom (f.comp g) hfg hfinfg hNfg x := by
+  obtain ⟨D, rfl⟩ := Pic0.mk_surjective x
+  rw [Pic0.pushforwardAlongHom_mk, Pic0.pushforwardAlongHom_mk, Pic0.pushforwardAlongHom_mk]
+  refine congrArg _ ?_
+  refine Subtype.ext ?_
+  rw [Pic0.coe_pushforwardAlongDegZero, Pic0.coe_pushforwardAlongDegZero,
+    Pic0.coe_pushforwardAlongDegZero]
+  exact Divisor.pushforwardAlong_pushforwardAlong g f hg hf hfg (D : Divisor F A.FunctionField)
+
+omit [WeierstrassCurve.IsElliptic A] [WeierstrassCurve.IsElliptic B]
+  [WeierstrassCurve.IsElliptic C] in
+theorem pointMapOfPushforward_comp
+    (f : B.FunctionField →ₐ[F] A.FunctionField) (hf : f.toRingHom.IsIntegral)
+    (hfinf : FiniteAlong F f) (hNf : NormFormulaAlong F f hfinf)
+    (g : C.FunctionField →ₐ[F] B.FunctionField) (hg : g.toRingHom.IsIntegral)
+    (hfing : FiniteAlong F g) (hNg : NormFormulaAlong F g hfing)
+    (hfg : (f.comp g).toRingHom.IsIntegral) (hfinfg : FiniteAlong F (f.comp g))
+    (hNfg : NormFormulaAlong F (f.comp g) hfinfg) (P : A.Point) :
+    pointMapOfPushforward (f.comp g) hfg hfinfg hNfg P
+      = pointMapOfPushforward g hg hfing hNg (pointMapOfPushforward f hf hfinf hNf P) := by
+  have key : ∀ x : Pic0 F B.FunctionField, pointClass (genusOnePic0Equiv B x) = x := fun x => by
+    rw [← genusOnePic0Equiv_symm_apply, AddEquiv.symm_apply_apply]
+  rw [pointMapOfPushforward_apply, pointMapOfPushforward_apply, pointMapOfPushforward_apply, key,
+    Pic0_pushforwardAlongHom_comp f hf hfinf hNf g hg hfing hNg hfg hfinfg hNfg]
+
+end Functoriality
+
+end WeierstrassCurve.Affine
+
+namespace A68
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental.WeierstrassCurve \
+  WeierstrassCurve.Affine \
+  P2MW.S_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental.WeierstrassCurve.\
+  Affine AlgebraicCurve Polynomial"
+
+attribute [local instance] Classical.propDecidable
+
+section Generic
+
+variable {F : Type} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+
+omit [IsAlgClosed F] [CharZero F] in
+theorem oddOrderSummingSet_coords_mem (W : WeierstrassCurve F) (L : Subfield F) {n : ℕ}
+    {Q : W.toAffine.Point} (hord : addOrderOf Q = 2 * n + 1)
+    (hcoord : ∀ (k : ℕ) (x y : F) (h : W.toAffine.Nonsingular x y),
+      k • Q = Point.some x y h → x ∈ L ∧ y ∈ L) :
+    ∀ P ∈ W.oddOrderSummingSet Q n, P.1 ∈ L ∧ P.2 ∈ L := by
+  intro P hP
+  obtain ⟨k, hk1, hkn, hkP⟩ := W.mem_oddOrderSummingSet.mp hP
+  have hkQne : k • Q ≠ 0 := by
+    intro h
+    rw [← addOrderOf_dvd_iff_nsmul_eq_zero, hord] at h
+    exact absurd (Nat.le_of_dvd hk1 h) (by omega)
+  rcases hkQ : (k • Q) with _ | ⟨x, y, hns⟩
+  · exact absurd hkQ hkQne
+  rw [← hkP, hkQ]
+  exact hcoord k x y hns hkQ
+
+theorem exists_generator_of_isAddCyclic {G : Type*} [AddCommGroup G] (H : AddSubgroup G)
+    (hc : IsAddCyclic H) {m : ℕ} (hm : Nat.card H = m) :
+    ∃ g : G, AddSubgroup.zmultiples g = H ∧ addOrderOf g = m := by
+  obtain ⟨⟨g, hgH⟩, hg⟩ := hc.exists_generator
+  have hzm : AddSubgroup.zmultiples g = H := by
+    apply le_antisymm (AddSubgroup.zmultiples_le.mpr hgH)
+    intro x hx
+    obtain ⟨k, hk⟩ := AddSubgroup.mem_zmultiples_iff.mp (hg ⟨x, hx⟩)
+    exact AddSubgroup.mem_zmultiples_iff.mpr ⟨k, by simpa using congrArg Subtype.val hk⟩
+  refine ⟨g, hzm, ?_⟩
+  rw [← Nat.card_zmultiples g, hzm, hm]
+
+set_option genInjectivity false in
+structure IsoTarget (W : WeierstrassCurve F) [W.IsElliptic] [GenusOnePlaceGate W.toAffine]
+    [AbelTheorem W.toAffine] (g : W.toAffine.Point) (L : Subfield F) where
+  V : WeierstrassCurve F
+  [ell : V.IsElliptic]
+  [gate : GenusOnePlaceGate V.toAffine]
+  [centred : GenusOnePlaceGate.IsCentred V.toAffine]
+  [abel : AbelTheorem V.toAffine]
+  ι : V.toAffine.FunctionField →ₐ[F] W.toAffine.FunctionField
+  hι : ι.toRingHom.IsIntegral
+  hfin : FiniteAlong F ι
+  j_mem : V.j ∈ L
+  ker_eq : ∀ hN : NormFormulaAlong F ι hfin,
+    (pointMapOfPushforward ι hι hfin hN).ker = AddSubgroup.zmultiples g
+
+theorem isoTarget_odd (n : ℕ) (W : WeierstrassCurve F) [W.IsElliptic]
+    [GenusOnePlaceGate W.toAffine] [GenusOnePlaceGate.IsCentred W.toAffine]
+    [AbelTheorem W.toAffine] (L : Subfield F)
+    (h₁ : W.a₁ ∈ L) (h₂ : W.a₂ ∈ L) (h₃ : W.a₃ ∈ L) (h₄ : W.a₄ ∈ L) (h₆ : W.a₆ ∈ L)
+    (g : W.toAffine.Point) (hg : addOrderOf g = 2 * n + 1)
+    (hcoord : ∀ (k : ℕ) (x y : F) (h : W.toAffine.Nonsingular x y),
+      k • g = Point.some x y h → x ∈ L ∧ y ∈ L) :
+    Nonempty (IsoTarget W g L) := by
+  have hΔ' : (W.veluQuotient (W.oddOrderSummingSet g n)).Δ ≠ 0 :=
+    WeierstrassCurve.veluQuotient_oddOrderSummingSet_discriminant_ne_zero two_ne_zero W n g hg
+  have hell : (W.veluQuotient (W.oddOrderSummingSet g n)).IsElliptic :=
+    ⟨isUnit_iff_ne_zero.mpr hΔ'⟩
+  have : IsDedekindDomain (W.veluQuotient (W.oddOrderSummingSet g n)).toAffine.CoordinateRing :=
+    CoordinateRing.isDedekindDomain (W.veluQuotient (W.oddOrderSummingSet g n))
+  obtain ⟨gV, hcV, haV⟩ := exists_genusOnePlaceGate_isCentred_and_abelTheorem
+    (W := (W.veluQuotient (W.oddOrderSummingSet g n)).toAffine)
+  let := gV
+  have := hcV
+  have := haV
+  obtain ⟨ι, hι, hfin, -, hker⟩ :=
+    WeierstrassCurve.exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples hg hΔ'
+  have hj : (W.veluQuotient (W.oddOrderSummingSet g n)).j ∈ L :=
+    WeierstrassCurve.veluQuotient_j_mem_of_mem W L _ h₁ h₂ h₃ h₄ h₆
+      (oddOrderSummingSet_coords_mem W L hg hcoord) hΔ'
+  exact ⟨{ V := W.veluQuotient (W.oddOrderSummingSet g n), ι := ι, hι := hι, hfin := hfin,
+           j_mem := hj, ker_eq := hker }⟩
+
+omit [DecidableEq F] in
+omit [IsAlgClosed F] [CharZero F] in
+theorem veluGx_mem (W : WeierstrassCurve F) (L : Subfield F)
+    (h₁ : W.a₁ ∈ L) (h₂ : W.a₂ ∈ L) (h₄ : W.a₄ ∈ L) {x₀ y₀ : F} (hx : x₀ ∈ L) (hy : y₀ ∈ L) :
+    W.veluGx x₀ y₀ ∈ L := by
+  classical
+  unfold WeierstrassCurve.veluGx
+  have h3 : (3 : F) ∈ L := by simp
+  have h2' : (2 : F) ∈ L := by simp
+  exact sub_mem (add_mem (add_mem (mul_mem h3 (pow_mem hx 2)) (mul_mem (mul_mem h2' h₂) hx)) h₄)
+    (mul_mem h₁ hy)
+
+theorem isoTarget_even_step (M : ℕ) (hM : 0 < M)
+    (ih : ∀ (W' : WeierstrassCurve F) [W'.IsElliptic] [GenusOnePlaceGate W'.toAffine]
+      [GenusOnePlaceGate.IsCentred W'.toAffine] [AbelTheorem W'.toAffine] (L : Subfield F),
+      W'.a₁ ∈ L → W'.a₂ ∈ L → W'.a₃ ∈ L → W'.a₄ ∈ L → W'.a₆ ∈ L →
+      ∀ g' : W'.toAffine.Point, addOrderOf g' = M →
+      (∀ (k : ℕ) (x y : F) (h : W'.toAffine.Nonsingular x y),
+        k • g' = Point.some x y h → x ∈ L ∧ y ∈ L) → Nonempty (IsoTarget W' g' L))
+    (W : WeierstrassCurve F) [W.IsElliptic]
+    [GenusOnePlaceGate W.toAffine] [GenusOnePlaceGate.IsCentred W.toAffine]
+    [AbelTheorem W.toAffine] (L : Subfield F)
+    (h₁ : W.a₁ ∈ L) (h₂ : W.a₂ ∈ L) (h₃ : W.a₃ ∈ L) (h₄ : W.a₄ ∈ L) (h₆ : W.a₆ ∈ L)
+    (g : W.toAffine.Point) (hg : addOrderOf g = 2 * M)
+    (hcoord : ∀ (k : ℕ) (x y : F) (h : W.toAffine.Nonsingular x y),
+      k • g = Point.some x y h → x ∈ L ∧ y ∈ L) :
+    Nonempty (IsoTarget W g L) := by
+  have hQne : M • g ≠ 0 := by
+    intro h
+    have hdvd := addOrderOf_dvd_of_nsmul_eq_zero h
+    rw [hg] at hdvd
+    exact absurd (Nat.le_of_dvd hM hdvd) (by omega)
+  have hQQ : M • g + M • g = 0 := by
+    rw [← add_nsmul, ← two_mul, ← hg]; exact addOrderOf_nsmul_eq_zero g
+  rcases hQ : (M • g) with _ | ⟨x₀, y₀, hns⟩
+  · exact absurd hQ hQne
+  rw [hQ] at hQQ
+  have hneg : -(Point.some x₀ y₀ hns : W.toAffine.Point) = Point.some x₀ y₀ hns :=
+    neg_eq_iff_add_eq_zero.mpr hQQ
+  rw [Affine.Point.neg_some] at hneg
+  have hy : W.toAffine.negY x₀ y₀ = y₀ := by injection hneg
+  have hgy : W.veluGy x₀ y₀ = 0 := WeierstrassCurve.veluGy_eq_zero_of_negY_eq (W := W) hy
+  have hQeq : W.toAffine.Equation x₀ y₀ := hns.1
+  obtain ⟨hx₀L, hy₀L⟩ := hcoord M x₀ y₀ hns hQ
+  have hΔW : W.Δ ≠ 0 := W.isUnit_Δ.ne_zero
+  have hΔ₁ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0 :=
+    WeierstrassCurve.veluQuotient2_Delta_ne_zero hΔW hQeq hgy
+  have : (W.veluQuotient2 x₀ y₀).IsElliptic :=
+    WeierstrassCurve.isElliptic_veluQuotient2_of_isElliptic hQeq hgy
+  have : IsDedekindDomain (W.veluQuotient2 x₀ y₀).toAffine.CoordinateRing :=
+    CoordinateRing.isDedekindDomain (W.veluQuotient2 x₀ y₀)
+  obtain ⟨gV, hcV, haV⟩ := exists_genusOnePlaceGate_isCentred_and_abelTheorem
+    (W := (W.veluQuotient2 x₀ y₀).toAffine)
+  let := gV
+  have := hcV
+  have := haV
+  obtain ⟨ι₁, hι₁, hfin₁, hseam⟩ :=
+    WeierstrassCurve.exists_velu2FunctionFieldHom_restrictAlong_placeOfPoint_veluPointMap2 hQeq hgy
+      hΔ₁
+  have hN₁ : NormFormulaAlong F ι₁ hfin₁ := normFormulaAlong_of_elliptic ι₁ hfin₁
+  set p₁ := pointMapOfPushforward ι₁ hι₁ hfin₁ hN₁ with hp₁_def
+  have hp₁ : ∀ P, p₁ P = WeierstrassCurve.veluPointMap2 two_ne_zero hQeq hgy hΔ₁ P :=
+    pointMapOfPushforward_eq_of_seam ι₁ hι₁ hfin₁ hN₁ _
+      (by rw [Affine.Point.zero_def]; exact WeierstrassCurve.veluPointMap2_zero _ _ _ _) hseam
+  have hp₁Q : p₁ (Point.some x₀ y₀ hns) = 0 := by
+    rw [hp₁, WeierstrassCurve.veluPointMap2_some_of_eq two_ne_zero hQeq hgy hΔ₁ hns rfl,
+      Affine.Point.zero_def]
+  have hker₁ : ∀ P : W.toAffine.Point, p₁ P = 0 → P = 0 ∨ P = Point.some x₀ y₀ hns := by
+    intro P hP
+    rcases P with _ | ⟨x, y, h⟩
+    · exact Or.inl Affine.Point.zero_def.symm
+    · right
+      by_cases hx : x = x₀
+      · rcases Affine.Y_eq_of_X_eq h.1 hns.1 hx with hyy | hyy
+        · subst hx; subst hyy; rfl
+        · subst hx; rw [hy] at hyy; subst hyy; rfl
+      · rw [hp₁, WeierstrassCurve.veluPointMap2_some_of_ne two_ne_zero hQeq hgy hΔ₁ h hx,
+          Affine.Point.zero_def] at hP
+        cases hP
+  have hg₁ord : addOrderOf (p₁ g) = M := by
+    refine (addOrderOf_eq_iff hM).mpr ⟨?_, ?_⟩
+    · rw [← map_nsmul, hQ, hp₁Q]
+    · intro k hkM hk0 hk
+      rw [← map_nsmul] at hk
+      rcases hker₁ _ hk with hk' | hk'
+      · have hdvd := addOrderOf_dvd_of_nsmul_eq_zero hk'
+        rw [hg] at hdvd
+        exact absurd (Nat.le_of_dvd hk0 hdvd) (by omega)
+      · have hsub : (M - k) • g = 0 := by
+          have : (M - k) • g + k • g = M • g := by
+            rw [← add_nsmul, Nat.sub_add_cancel hkM.le]
+          rw [hk', ← hQ] at this
+          exact add_eq_right.mp this
+        have hdvd := addOrderOf_dvd_of_nsmul_eq_zero hsub
+        rw [hg] at hdvd
+        exact absurd (Nat.le_of_dvd (by omega) hdvd) (by omega)
+  have hgx : W.veluGx x₀ y₀ ∈ L := veluGx_mem W L h₁ h₂ h₄ hx₀L hy₀L
+  have hcoord₁ : ∀ (k : ℕ) (x y : F) (h : (W.veluQuotient2 x₀ y₀).toAffine.Nonsingular x y),
+      k • p₁ g = Point.some x y h → x ∈ L ∧ y ∈ L := by
+    intro k x y h hk
+    rw [← map_nsmul, hp₁] at hk
+    rcases hkg : (k • g) with _ | ⟨x', y', h'⟩
+    · rw [hkg, WeierstrassCurve.veluPointMap2_zero] at hk; cases hk
+    · rw [hkg] at hk
+      by_cases hx' : x' = x₀
+      · rw [WeierstrassCurve.veluPointMap2_some_of_eq two_ne_zero hQeq hgy hΔ₁ h' hx'] at hk
+        cases hk
+      · rw [WeierstrassCurve.veluPointMap2_some_of_ne two_ne_zero hQeq hgy hΔ₁ h' hx'] at hk
+        obtain ⟨hxL, hyL⟩ := hcoord k x' y' h' hkg
+        have hxx : W.velu2X x₀ y₀ x' = x ∧ W.velu2Y x₀ y₀ x' y' = y := by
+          injection hk with hxe hye; exact ⟨hxe, hye⟩
+        obtain ⟨hxe, hye⟩ := hxx
+        refine ⟨?_, ?_⟩
+        · rw [← hxe]; unfold WeierstrassCurve.velu2X
+          exact add_mem hxL (div_mem hgx (sub_mem hxL hx₀L))
+        · rw [← hye]; unfold WeierstrassCurve.velu2Y
+          exact sub_mem hyL (div_mem (mul_mem hgx (sub_mem (add_mem (mul_mem h₁ (sub_mem hxL hx₀L))
+            hyL) hy₀L)) (pow_mem (sub_mem hxL hx₀L) 2))
+  have hb₂ : W.b₂ ∈ L := by
+    unfold WeierstrassCurve.b₂
+    have h4 : (4 : F) ∈ L := by simp
+    exact add_mem (pow_mem h₁ 2) (mul_mem h4 h₂)
+  have h₄' : (W.veluQuotient2 x₀ y₀).a₄ ∈ L := by
+    rw [WeierstrassCurve.veluQuotient2_a₄]
+    have h5 : (5 : F) ∈ L := by simp
+    exact sub_mem h₄ (mul_mem h5 hgx)
+  have h₆' : (W.veluQuotient2 x₀ y₀).a₆ ∈ L := by
+    rw [WeierstrassCurve.veluQuotient2_a₆]
+    have h7 : (7 : F) ∈ L := by simp
+    exact sub_mem (sub_mem h₆ (mul_mem hb₂ hgx)) (mul_mem h7 (mul_mem hx₀L hgx))
+  obtain ⟨T₂⟩ := ih (W.veluQuotient2 x₀ y₀) L
+    (by rw [WeierstrassCurve.veluQuotient2_a₁]; exact h₁)
+    (by rw [WeierstrassCurve.veluQuotient2_a₂]; exact h₂)
+    (by rw [WeierstrassCurve.veluQuotient2_a₃]; exact h₃) h₄' h₆' (p₁ g) hg₁ord hcoord₁
+  let := T₂.gate
+  have := T₂.ell
+  have := T₂.centred
+  have := T₂.abel
+  have hN₂ : NormFormulaAlong F T₂.ι T₂.hfin := normFormulaAlong_of_elliptic T₂.ι T₂.hfin
+  set p₂ := pointMapOfPushforward T₂.ι T₂.hι T₂.hfin hN₂ with hp₂_def
+  have hker₂ : p₂.ker = AddSubgroup.zmultiples (p₁ g) := T₂.ker_eq hN₂
+  have hι : (ι₁.comp T₂.ι).toRingHom.IsIntegral := RingHom.IsIntegral.trans _ _ T₂.hι hι₁
+  have hfin : FiniteAlong F (ι₁.comp T₂.ι) := finiteAlong_comp T₂.ι ι₁ T₂.hfin hfin₁
+  have hker : ∀ hN : NormFormulaAlong F (ι₁.comp T₂.ι) hfin,
+      (pointMapOfPushforward (ι₁.comp T₂.ι) hι hfin hN).ker = AddSubgroup.zmultiples g := by
+    intro hN
+    have hcomp : ∀ P, pointMapOfPushforward (ι₁.comp T₂.ι) hι hfin hN P = p₂ (p₁ P) := fun P =>
+      pointMapOfPushforward_comp ι₁ hι₁ hfin₁ hN₁ T₂.ι T₂.hι T₂.hfin hN₂ hι hfin hN P
+    refine AddSubgroup.ext fun P => ?_
+    rw [AddMonoidHom.mem_ker, hcomp]
+    constructor
+    · intro hP
+      have hP' : p₁ P ∈ p₂.ker := AddMonoidHom.mem_ker.mpr hP
+      rw [hker₂, AddSubgroup.mem_zmultiples_iff] at hP'
+      obtain ⟨k, hk⟩ := hP'
+      have hdiff : p₁ (P - k • g) = 0 := by rw [map_sub, map_zsmul, hk, sub_self]
+      rcases hker₁ _ hdiff with h0 | h0
+      · rw [sub_eq_zero] at h0
+        rw [h0]; exact AddSubgroup.zsmul_mem _ (AddSubgroup.mem_zmultiples g) k
+      · rw [sub_eq_iff_eq_add] at h0
+        rw [h0, ← hQ]
+        exact AddSubgroup.add_mem _ (AddSubgroup.nsmul_mem _ (AddSubgroup.mem_zmultiples g) M)
+          (AddSubgroup.zsmul_mem _ (AddSubgroup.mem_zmultiples g) k)
+    · intro hP
+      obtain ⟨k, rfl⟩ := AddSubgroup.mem_zmultiples_iff.mp hP
+      have : p₂ (p₁ g) = 0 := by
+        have hmem : p₁ g ∈ p₂.ker := by rw [hker₂]; exact AddSubgroup.mem_zmultiples _
+        exact AddMonoidHom.mem_ker.mp hmem
+      rw [map_zsmul, map_zsmul, this, zsmul_zero]
+  exact ⟨{ V := T₂.V, ι := ι₁.comp T₂.ι, hι := hι, hfin := hfin, j_mem := T₂.j_mem,
+           ker_eq := hker }⟩
+
+theorem exists_isoTarget (N : ℕ) :
+    ∀ (W : WeierstrassCurve F) [W.IsElliptic] [GenusOnePlaceGate W.toAffine]
+      [GenusOnePlaceGate.IsCentred W.toAffine] [AbelTheorem W.toAffine] (L : Subfield F),
+      W.a₁ ∈ L → W.a₂ ∈ L → W.a₃ ∈ L → W.a₄ ∈ L → W.a₆ ∈ L →
+      ∀ g : W.toAffine.Point, 0 < N → addOrderOf g = N →
+      (∀ (k : ℕ) (x y : F) (h : W.toAffine.Nonsingular x y),
+        k • g = Point.some x y h → x ∈ L ∧ y ∈ L) → Nonempty (IsoTarget W g L) := by
+  induction N using Nat.strong_induction_on with
+  | _ N ih =>
+    intro W _ _ _ _ L h₁ h₂ h₃ h₄ h₆ g hN hg hcoord
+    rcases Nat.even_or_odd N with ⟨M, rfl⟩ | ⟨n, rfl⟩
+    · have hM : 0 < M := by omega
+      exact isoTarget_even_step M hM
+        (fun W' _ _ _ _ L' h₁' h₂' h₃' h₄' h₆' g' hg' hcoord' =>
+          ih M (by omega) W' L' h₁' h₂' h₃' h₄' h₆' g' hM hg' hcoord')
+        W L h₁ h₂ h₃ h₄ h₆ g (by rw [hg]; ring) hcoord
+    · exact isoTarget_odd n W L h₁ h₂ h₃ h₄ h₆ g hg hcoord
+
+theorem main {N : ℕ} [NeZero N] (data : ModularCurve.ModularPolynomialData N)
+    (W : WeierstrassCurve F) [W.IsElliptic] (ht : Transcendental ℚ W.j) (L : Subfield F)
+    (h₁ : W.a₁ ∈ L) (h₂ : W.a₂ ∈ L) (h₃ : W.a₃ ∈ L) (h₄ : W.a₄ ∈ L) (h₆ : W.a₆ ∈ L)
+    (htors : ∀ (x y : F) (h : W.toAffine.Nonsingular x y),
+      N • (Point.some x y h : W.toAffine.Point) = 0 → x ∈ L ∧ y ∈ L)
+    (r : F) (hr : (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom F) W.j)).IsRoot r) :
+    r ∈ L := by
+  classical
+  have : IsDedekindDomain W.toAffine.CoordinateRing := CoordinateRing.isDedekindDomain W
+  obtain ⟨gW, hcW, haW⟩ := exists_genusOnePlaceGate_isCentred_and_abelTheorem (W := W.toAffine)
+  let := gW
+  have := hcW
+  have := haW
+  have hNs : ∀ D : IsogenyEndDatum W.toAffine, NormFormulaAlong F D.ι D.hfin := fun D =>
+    normFormulaAlong_of_elliptic D.ι D.hfin
+  have hEnd : ∀ D : IsogenyEndDatum W.toAffine, ∃ m : ℤ, ∀ P : W.toAffine.Point,
+      D.pointEnd (hNs D) P = m • P := fun D =>
+    IsogenyEndDatum.exists_forall_pointEnd_eq_zsmul_of_transcendental_j W hNs ht D
+  have hN0 : 0 < N := Nat.pos_of_ne_zero (NeZero.ne N)
+  have hNK : ((N : ℕ) : F) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne N)
+  set Φj := data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom F) W.j) with hΦj
+  have hΦjm : Φj.Monic := data.monic.map _
+  let B := {H : AddSubgroup W.toAffine.Point // IsAddCyclic H ∧ Nat.card H = N}
+  have hBcard : Nat.card B = ModularCurve.dedekindPsi N :=
+    WeierstrassCurve.natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed
+      (F := F) (K := F) W hNK
+  have hψpos : 0 < ModularCurve.dedekindPsi N := by
+    unfold ModularCurve.dedekindPsi
+    refine Finset.sum_pos' (fun _ _ => Nat.zero_le _) ⟨1, ?_, ?_⟩
+    · simp [Nat.mem_divisors, NeZero.ne N]
+    · simp [hN0]
+  have : Finite B := Nat.finite_of_card_ne_zero (hBcard ▸ hψpos.ne')
+  have : Fintype B := Fintype.ofFinite _
+  have hgen : ∀ H : B, ∃ g : W.toAffine.Point, AddSubgroup.zmultiples g = H.1 ∧ addOrderOf g = N :=
+    fun H => exists_generator_of_isAddCyclic H.1 H.2.1 H.2.2
+  choose gen hgenH hgenord using hgen
+  have hcoord : ∀ (H : B) (k : ℕ) (x y : F) (h : W.toAffine.Nonsingular x y),
+      k • gen H = Point.some x y h → x ∈ L ∧ y ∈ L := by
+    intro H k x y h hk
+    apply htors
+    rw [← hk, smul_comm, (hgenord H ▸ addOrderOf_nsmul_eq_zero (gen H) : N • gen H = 0), smul_zero]
+  let T : ∀ H : B, IsoTarget W (gen H) L := fun H =>
+    Classical.choice (exists_isoTarget N W L h₁ h₂ h₃ h₄ h₆ (gen H) hN0 (hgenord H) (hcoord H))
+  let jH : B → F := fun H =>
+    haveI := (T H).ell
+    (T H).V.j
+  have hjHmem : ∀ H : B, jH H ∈ L := fun H => (T H).j_mem
+  have hjHroot : ∀ H : B, Φj.IsRoot (jH H) := by
+    intro H
+    let := (T H).gate
+    have := (T H).ell
+    have := (T H).centred
+    have := (T H).abel
+    have hN' : NormFormulaAlong F (T H).ι (T H).hfin := normFormulaAlong_of_elliptic _ _
+    have hker := (T H).ker_eq hN'
+    have hcyc : IsAddCyclic (pointMapOfPushforward (T H).ι (T H).hι (T H).hfin hN').ker := by
+      rw [hker]; infer_instance
+    have hcard : Nat.card (pointMapOfPushforward (T H).ι (T H).hι (T H).hfin hN').ker = N := by
+      rw [hker, Nat.card_zmultiples, hgenord]
+    exact eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward
+      F W.toAffine (T H).V.toAffine (T H).ι (T H).hι (T H).hfin hN' N hcyc hcard data
+  have hjHinj : Function.Injective jH := by
+    intro H H' hjeq
+    let := (T H).gate
+    have := (T H).ell
+    have := (T H).centred
+    have := (T H).abel
+    let := (T H').gate
+    have := (T H').ell
+    have := (T H').centred
+    have := (T H').abel
+    have hN₁ : NormFormulaAlong F (T H).ι (T H).hfin := normFormulaAlong_of_elliptic _ _
+    have hN₂ : NormFormulaAlong F (T H').ι (T H').hfin := normFormulaAlong_of_elliptic _ _
+    have hker := (T H).ker_eq hN₁
+    have hker' := (T H').ker_eq hN₂
+    have hcard : Nat.card (pointMapOfPushforward (T H).ι (T H).hι (T H).hfin hN₁).ker
+        = Nat.card (pointMapOfPushforward (T H').ι (T H').hι (T H').hfin hN₂).ker := by
+      rw [hker, hker', Nat.card_zmultiples, Nat.card_zmultiples, hgenord, hgenord]
+    have heq :=
+      WeierstrassCurve.Affine.ker_pointMapOfPushforward_eq_of_j_eq_of_forall_pointEnd_eq_zsmul
+      W hNs hEnd (T H).V (T H').V (T H).ι (T H).hι (T H).hfin hN₁ (T H').ι (T H').hι (T H').hfin
+      hN₂ hcard hjeq
+    rw [hker, hker'] at heq
+    exact Subtype.ext ((hgenH H).symm.trans (heq.trans (hgenH H')))
+  have hJcard : (Finset.univ.image jH).card = ModularCurve.dedekindPsi N := by
+    rw [Finset.card_image_of_injective _ hjHinj, Finset.card_univ, ← Nat.card_eq_fintype_card,
+      hBcard]
+  have hJsub : Finset.univ.image jH ⊆ Φj.roots.toFinset := by
+    intro x hx
+    obtain ⟨H, -, rfl⟩ := Finset.mem_image.mp hx
+    rw [Multiset.mem_toFinset, Polynomial.mem_roots hΦjm.ne_zero]
+    exact hjHroot H
+  have hroots : Φj.roots.toFinset = Finset.univ.image jH := by
+    refine (Finset.eq_of_subset_of_card_le hJsub ?_).symm
+    calc Φj.roots.toFinset.card ≤ Multiset.card Φj.roots := Multiset.toFinset_card_le _
+      _ = ModularCurve.dedekindPsi N := by
+          rw [hΦj, ← data.natDegree_eq]
+          exact ModularCurve.card_roots_fibrePoly_of_monic (K := F) data.monic W.j
+      _ = (Finset.univ.image jH).card := hJcard.symm
+  have hrmem : r ∈ Φj.roots.toFinset := by
+    rw [Multiset.mem_toFinset, Polynomial.mem_roots hΦjm.ne_zero]; exact hr
+  rw [hroots] at hrmem
+  obtain ⟨H, -, rfl⟩ := Finset.mem_image.mp hrmem
+  exact hjHmem H
+
+end Generic
+end A68
+end
+
+theorem solution
+    {N : ℕ} [NeZero N] (data : ModularCurve.ModularPolynomialData N)
+    [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    (ht : Transcendental ℚ W.j)
+    (L : Subfield (HahnSeries ℚ (AlgebraicClosure ℚ)))
+    (h₁ : W.a₁ ∈ L) (h₂ : W.a₂ ∈ L) (h₃ : W.a₃ ∈ L) (h₄ : W.a₄ ∈ L) (h₆ : W.a₆ ∈ L)
+    (htors : ∀ (x y : HahnSeries ℚ (AlgebraicClosure ℚ)) (h : W.toAffine.Nonsingular x y),
+      N • (WeierstrassCurve.Affine.Point.some x y h : W.toAffine.Point) = 0 → x ∈ L ∧ y ∈ L)
+    (r : HahnSeries ℚ (AlgebraicClosure ℚ))
+    (hr : (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ)))
+      W.j)).IsRoot r) :
+    r ∈ L := by
+  by_cases hodd : Odd N
+  · exact ModularCurve.ModularPolynomialData.mem_of_isRoot_map_j_of_transcendental_of_odd hodd data
+      W
+      ht L h₁ h₂ h₃ h₄ h₆ htors r hr
+  · have : IsAlgClosed (HahnSeries ℚ (AlgebraicClosure ℚ)) := HahnSeries.isAlgClosed_rat
+    have : CharZero (HahnSeries ℚ (AlgebraicClosure ℚ)) :=
+      (RingHom.charZero_iff (HahnSeries.C (R := AlgebraicClosure ℚ) (Γ := ℚ)).injective).mp
+        inferInstance
+    have ht' : @Transcendental ℚ (HahnSeries ℚ (AlgebraicClosure ℚ)) _ _
+        DivisionRing.toRatAlgebra W.j := by
+      convert ht; exact Subsingleton.elim _ _
+    exact A68.main data W ht' L h₁ h₂ h₃ h₄ h₆ htors r hr
+
+end S_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental
+end P2MW
+export P2MW.S_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.ModularPolynomialData.mem_of_isRoot_map_j_of_transcendental
+    {N : ℕ} [NeZero N] (data : ModularCurve.ModularPolynomialData N)
+    [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    (ht : Transcendental ℚ W.j)
+    (L : Subfield (HahnSeries ℚ (AlgebraicClosure ℚ)))
+    (h₁ : W.a₁ ∈ L) (h₂ : W.a₂ ∈ L) (h₃ : W.a₃ ∈ L) (h₄ : W.a₄ ∈ L) (h₆ : W.a₆ ∈ L)
+    (htors : ∀ (x y : HahnSeries ℚ (AlgebraicClosure ℚ)) (h : W.toAffine.Nonsingular x y),
+      N • (WeierstrassCurve.Affine.Point.some x y h : W.toAffine.Point) = 0 → x ∈ L ∧ y ∈ L)
+    (r : HahnSeries ℚ (AlgebraicClosure ℚ))
+    (hr : (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ)))
+      W.j)).IsRoot r) :
+    r ∈ L :=
+  solution data W ht L h₁ h₂ h₃ h₄ h₆ htors r hr
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental_of_odd.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental_of_odd.lean
new file mode 100644
index 0000000000..c1fd97c8ea
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental_of_odd.lean
@@ -0,0 +1,222 @@
+/-
+Based on Prove2Me node
+ModularCurve.ModularPolynomialData.mem_of_isRoot_map_j_of_transcendental_of_odd
+(ab127387-aafa-5673-9e11-75310cd2c2bd) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a43cdecf-3371-5f38-a79c-6dfdea4aff62
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_isAlgClosed_rat
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_isRoot_map_j_veluQuotient_j_of_addOrderOf_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_card_roots_fibrePoly_of_monic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_veluQuotient_j_mem_of_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_veluQuotient_oddOrderSummingSet_discriminant_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_zmultiples_eq_of_veluQuotient_j_eq_of_transcendental
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Roots of Φ_N(j(E),Y) lie in L
+
+Theorem statement: `ModularCurve.ModularPolynomialData.mem_of_isRoot_map_j_of_transcendental_of_odd`
+(`ab127387-aafa-5673-9e11-75310cd2c2bd`), by Claude, 2026-09-05.
+
+Proof: submission `a43cdecf-3371-5f38-a79c-6dfdea4aff62`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N\ge 1$ odd and write $\mathbb K = \mathrm{HahnSeries}\,\mathbb Q\,\overline{\mathbb Q}$, the
+field of Hahn series with rational exponents and coefficients in $\overline{\mathbb Q}$. Let `data`
+consist of a polynomial $\Phi \in \mathbb Z[X][Y]$ that is monic in $Y$, whose $Y$-degree equals
+$\mathrm{dedekindPsi}\,N = \sum_{d \mid N,\ d \text{ squarefree}} N/d$, and which vanishes when $X$
+is specialised to the $q$-expansion of $j$ and $Y$ to that of $j(q^N)$. Let $W$ be a Weierstrass
+curve over $\mathbb K$ which is elliptic and whose $j$-invariant is transcendental over $\mathbb Q$,
+and let $L \subseteq \mathbb K$ be a subfield containing the five coefficients $a_1, a_2, a_3, a_4,
+a_6$ of $W$ and such that for every pair $(x,y)$ of elements of $\mathbb K$ defining a nonsingular
+affine point $P$ of $W$ with $N \cdot P = 0$, both $x$ and $y$ lie in $L$. Then every $r \in \mathbb
+K$ with $\Phi(j(W), r) = 0$ — that is, every root of the one-variable polynomial over $\mathbb K$
+obtained from $\Phi$ by mapping each coefficient in $\mathbb Z[X]$ to its value at $j(W)$ — lies in
+$L$.
+
+This is the statement that the roots of the level-$N$ modular polynomial specialised at $j(E)$ are
+the $j$-invariants of the quotients of $E$ by its cyclic subgroups of order $N$, and hence are
+defined over any field containing the coefficients of $E$ and the coordinates of its $N$-torsion. It
+feeds the three ramification estimates
+[`ModularCurve.ModularPolynomialData.hasRamBound_one_of_isRoot_off_zero_1728_of_odd`]
+(thm.html#ModularCurve.ModularPolynomialData.hasRamBound_one_of_isRoot_off_zero_1728_of_odd),
+[`ModularCurve.ModularPolynomialData.hasRamBound_two_of_isRoot_at_1728_of_odd`]
+(thm.html#ModularCurve.ModularPolynomialData.hasRamBound_two_of_isRoot_at_1728_of_odd)
+and
+[`ModularCurve.ModularPolynomialData.hasRamBound_three_of_isRoot_at_zero_of_odd`]
+(thm.html#ModularCurve.ModularPolynomialData.hasRamBound_three_of_isRoot_at_zero_of_odd).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental_of_odd.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental_of_odd
+
+
+open WeierstrassCurve WeierstrassCurve.Affine Polynomial
+
+namespace S13K2
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+theorem oddOrderSummingSet_coords_mem (L : Subfield F) {n : ℕ} {Q : W.toAffine.Point}
+    (hord : addOrderOf Q = 2 * n + 1)
+    (htors : ∀ (x y : F) (h : W.toAffine.Nonsingular x y),
+      (2 * n + 1) • (Point.some x y h : W.toAffine.Point) = 0 → x ∈ L ∧ y ∈ L) :
+    ∀ P ∈ W.oddOrderSummingSet Q n, P.1 ∈ L ∧ P.2 ∈ L := by
+  intro P hP
+  obtain ⟨k, hk1, hkn, hkP⟩ := W.mem_oddOrderSummingSet.mp hP
+  have hkQne : k • Q ≠ 0 := by
+    intro h
+    rw [← addOrderOf_dvd_iff_nsmul_eq_zero, hord] at h
+    exact absurd (Nat.le_of_dvd hk1 h) (by omega)
+  rcases hkQ : (k • Q) with _ | ⟨x, y, hns⟩
+  · exact absurd hkQ hkQne
+  have hQd : (2 * n + 1) • Q = 0 := hord ▸ addOrderOf_nsmul_eq_zero Q
+  have hd : (2 * n + 1) • (Point.some x y hns : W.toAffine.Point) = 0 := by
+    rw [← hkQ, smul_comm, hQd, smul_zero]
+  rw [← hkP, hkQ]
+  exact htors x y hns hd
+
+theorem exists_generator_of_isAddCyclic {G : Type*} [AddCommGroup G] (H : AddSubgroup G)
+    (hc : IsAddCyclic H) {m : ℕ} (hm : Nat.card H = m) :
+    ∃ g : G, AddSubgroup.zmultiples g = H ∧ addOrderOf g = m := by
+  obtain ⟨⟨g, hgH⟩, hg⟩ := hc.exists_generator
+  have hzm : AddSubgroup.zmultiples g = H := by
+    apply le_antisymm (AddSubgroup.zmultiples_le.mpr hgH)
+    intro x hx
+    obtain ⟨k, hk⟩ := AddSubgroup.mem_zmultiples_iff.mp (hg ⟨x, hx⟩)
+    exact AddSubgroup.mem_zmultiples_iff.mpr ⟨k, by simpa using congrArg Subtype.val hk⟩
+  refine ⟨g, hzm, ?_⟩
+  rw [← Nat.card_zmultiples g, hzm, hm]
+
+end S13K2
+
+open S13K2 in
+theorem solution
+    {N : ℕ} [NeZero N] (hN : Odd N) (data : ModularCurve.ModularPolynomialData N)
+    [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    (ht : Transcendental ℚ W.j)
+    (L : Subfield (HahnSeries ℚ (AlgebraicClosure ℚ)))
+    (h₁ : W.a₁ ∈ L) (h₂ : W.a₂ ∈ L) (h₃ : W.a₃ ∈ L) (h₄ : W.a₄ ∈ L) (h₆ : W.a₆ ∈ L)
+    (htors : ∀ (x y : HahnSeries ℚ (AlgebraicClosure ℚ)) (h : W.toAffine.Nonsingular x y),
+      N • (WeierstrassCurve.Affine.Point.some x y h : W.toAffine.Point) = 0 → x ∈ L ∧ y ∈ L)
+    (r : HahnSeries ℚ (AlgebraicClosure ℚ))
+    (hr : (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ)))
+      W.j)).IsRoot r) :
+    r ∈ L := by
+  have hK : IsAlgClosed (HahnSeries ℚ (AlgebraicClosure ℚ)) := HahnSeries.isAlgClosed_rat
+  have : CharZero (HahnSeries ℚ (AlgebraicClosure ℚ)) :=
+    (RingHom.charZero_iff (HahnSeries.C (R := AlgebraicClosure ℚ) (Γ := ℚ)).injective).mp
+      inferInstance
+  obtain ⟨n, rfl⟩ := hN
+  have h2 : (2 : HahnSeries ℚ (AlgebraicClosure ℚ)) ≠ 0 := two_ne_zero
+  have hNK : ((2 * n + 1 : ℕ) : HahnSeries ℚ (AlgebraicClosure ℚ)) ≠ 0 :=
+    Nat.cast_ne_zero.mpr (by omega)
+  set Φj := data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure
+    ℚ))) W.j)
+    with hΦj
+  have hΦjm : Φj.Monic := data.monic.map _
+  let B := {H : AddSubgroup W.toAffine.Point // IsAddCyclic H ∧ Nat.card H = 2 * n + 1}
+  have hBcard : Nat.card B = ModularCurve.dedekindPsi (2 * n + 1) :=
+    WeierstrassCurve.natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed
+      (F := HahnSeries ℚ (AlgebraicClosure ℚ)) (K := HahnSeries ℚ (AlgebraicClosure ℚ)) W hNK
+  have hψpos : 0 < ModularCurve.dedekindPsi (2 * n + 1) := by
+    unfold ModularCurve.dedekindPsi
+    refine Finset.sum_pos' (fun _ _ => Nat.zero_le _) ⟨1, ?_, ?_⟩
+    · simp [Nat.mem_divisors]
+    · simp
+  have : Finite B := Nat.finite_of_card_ne_zero (hBcard ▸ hψpos.ne')
+  have : Fintype B := Fintype.ofFinite _
+  have hgen : ∀ H : B, ∃ g : W.toAffine.Point,
+      AddSubgroup.zmultiples g = H.1 ∧ addOrderOf g = 2 * n + 1 :=
+    fun H => exists_generator_of_isAddCyclic H.1 H.2.1 H.2.2
+  choose gen hgenH hgenord using hgen
+  have hΔgen : ∀ H : B, (W.veluQuotient (W.oddOrderSummingSet (gen H) n)).Δ ≠ 0 := fun H =>
+    WeierstrassCurve.veluQuotient_oddOrderSummingSet_discriminant_ne_zero h2 W n (gen H) (hgenord H)
+  let jH : B → HahnSeries ℚ (AlgebraicClosure ℚ) := fun H =>
+    haveI : (W.veluQuotient (W.oddOrderSummingSet (gen H) n)).IsElliptic := ⟨isUnit_iff_ne_zero.mpr
+      (hΔgen H)⟩
+    (W.veluQuotient (W.oddOrderSummingSet (gen H) n)).j
+  have hjHmem : ∀ H : B, jH H ∈ L := fun H =>
+    WeierstrassCurve.veluQuotient_j_mem_of_mem W L _ h₁ h₂ h₃ h₄ h₆
+      (oddOrderSummingSet_coords_mem W L (hgenord H) htors) (hΔgen H)
+  have hjHroot : ∀ H : B, Φj.IsRoot (jH H) := fun H =>
+    ModularCurve.ModularPolynomialData.isRoot_map_j_veluQuotient_j_of_addOrderOf_eq W n (gen H)
+      (hgenord H)
+      (hΔgen H) data
+  have hjHinj : Function.Injective jH := by
+    intro H H' hjeq
+    have hz :=
+      WeierstrassCurve.zmultiples_eq_of_veluQuotient_j_eq_of_transcendental W ht n (gen H) (gen H')
+      (hgenord H) (hgenord H') (hΔgen H) (hΔgen H') hjeq
+    exact Subtype.ext ((hgenH H).symm.trans (hz.trans (hgenH H')))
+  have hJcard : (Finset.univ.image jH).card = ModularCurve.dedekindPsi (2 * n + 1) := by
+    rw [Finset.card_image_of_injective _ hjHinj, Finset.card_univ, ← Nat.card_eq_fintype_card,
+      hBcard]
+  have hJsub : Finset.univ.image jH ⊆ Φj.roots.toFinset := by
+    intro x hx
+    obtain ⟨H, -, rfl⟩ := Finset.mem_image.mp hx
+    rw [Multiset.mem_toFinset, Polynomial.mem_roots hΦjm.ne_zero]
+    exact hjHroot H
+  have hroots : Φj.roots.toFinset = Finset.univ.image jH := by
+    refine (Finset.eq_of_subset_of_card_le hJsub ?_).symm
+    calc Φj.roots.toFinset.card ≤ Multiset.card Φj.roots := Multiset.toFinset_card_le _
+      _ = ModularCurve.dedekindPsi (2 * n + 1) := by
+          rw [hΦj, ← data.natDegree_eq]
+          exact ModularCurve.card_roots_fibrePoly_of_monic (K := HahnSeries ℚ (AlgebraicClosure ℚ))
+            data.monic W.j
+      _ = (Finset.univ.image jH).card := hJcard.symm
+  have hrmem : r ∈ Φj.roots.toFinset := by
+    rw [Multiset.mem_toFinset, Polynomial.mem_roots hΦjm.ne_zero]; exact hr
+  rw [hroots] at hrmem
+  obtain ⟨H, -, rfl⟩ := Finset.mem_image.mp hrmem
+  exact hjHmem H
+
+end S_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental_of_odd
+end P2MW
+export P2MW.S_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental_of_odd
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.ModularPolynomialData.mem_of_isRoot_map_j_of_transcendental_of_odd
+    {N : ℕ} [NeZero N] (hN : Odd N) (data : ModularCurve.ModularPolynomialData N)
+    [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    (ht : Transcendental ℚ W.j)
+    (L : Subfield (HahnSeries ℚ (AlgebraicClosure ℚ)))
+    (h₁ : W.a₁ ∈ L) (h₂ : W.a₂ ∈ L) (h₃ : W.a₃ ∈ L) (h₄ : W.a₄ ∈ L) (h₆ : W.a₆ ∈ L)
+    (htors : ∀ (x y : HahnSeries ℚ (AlgebraicClosure ℚ)) (h : W.toAffine.Nonsingular x y),
+      N • (WeierstrassCurve.Affine.Point.some x y h : W.toAffine.Point) = 0 → x ∈ L ∧ y ∈ L)
+    (r : HahnSeries ℚ (AlgebraicClosure ℚ))
+    (hr : (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ)))
+      W.j)).IsRoot r) :
+    r ∈ L :=
+  solution hN data W ht L h₁ h₂ h₃ h₄ h₆ htors r hr
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_transposeToAdjoin_monic_of_qExpansion.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_transposeToAdjoin_monic_of_qExpansion.lean
new file mode 100644
index 0000000000..35b35849f7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ModularPolynomialData_transposeToAdjoin_monic_of_qExpansion.lean
@@ -0,0 +1,988 @@
+/-
+Based on Prove2Me node ModularCurve.ModularPolynomialData.transposeToAdjoin_monic_of_qExpansion
+(6b155394-313a-5c59-926d-42044b44adeb) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 75e540ac-bba0-5910-aec6-52ef444a7819
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime
+import Mathlib.Algebra.Polynomial.Roots
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Algebra
+import Mathlib.FieldTheory.Minpoly.Field
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.RingTheory.Polynomial.GaussLemma
+import Mathlib.RingTheory.Polynomial.RationalRoot
+import Mathlib.Tactic.Linarith
+import Mathlib.Tactic.LinearCombination
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Transpose of Φ monic of degree ψ(N) over ℚ(j)
+
+Theorem statement: `ModularCurve.ModularPolynomialData.transposeToAdjoin_monic_of_qExpansion`
+(`6b155394-313a-5c59-926d-42044b44adeb`), by Claude, 2026-09-05.
+
+Proof: submission `75e540ac-bba0-5910-aec6-52ef444a7819`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a positive level $N$ and let `data` be a modular-polynomial packet at level $N$: a bivariate
+polynomial $\Phi \in (\mathbb{Z}[X])[Y]$ which is monic in $Y$, of $Y$-degree $\psi(N) = \sum_{d
+\mid N,\ d \text{ squarefree}} N/d$, and which satisfies $\Phi(j, j_N) = 0$, where the inner
+variable is specialised through the ring map `evalAtJ` sending $X$ to the Laurent $q$-series $jq$
+and the outer variable to the series `jqN N`. Write $\Phi = \sum_k \Phi_k(X)\,Y^k$ with $\Phi_k \in
+\mathbb{Z}[X]$. Assume three conditions on the $q$-expansions $\Phi_k(jq) \in$ `LaurentSeries ℚ`:
+the coefficient of $\Phi_0(jq)$ in degree $-\psi(N)$ equals $1$; for every natural $m > \psi(N)$ the
+coefficient of $\Phi_0(jq)$ in degree $-m$ vanishes; and for every $k \neq 0$ and every natural $m
+\geq \psi(N)$ the coefficient of $\Phi_k(jq)$ in degree $-m$ vanishes. Then the transposed
+polynomial `swapBivar data.Φ`, obtained by interchanging the two variables, with coefficients mapped
+into the simple extension $\mathbb{Q}(jq)$ by evaluation of $\mathbb{Z}[X]$ at the generator $jq$,
+is monic and has degree exactly $\psi(N)$.
+
+This records the classical degree and leading-coefficient statement for the modular equation read in
+the other variable: the pole orders of the $q$-expansions $\Phi_k(j)$, together with the simplicity
+of the pole of $j$, pin down the $X$-degree of $\Phi$ as $\psi(N)$ and its leading $X$-coefficient
+as $1$. It is used by
+[`ModularCurve.PhiGen.evalSymm_of_coeff_evalAtJ_eq`]
+(thm.html#ModularCurve.PhiGen.evalSymm_of_coeff_evalAtJ_eq)
+in establishing the symmetry properties of the modular polynomial over $\mathbb{Q}(j)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ModularPolynomialData_transposeToAdjoin_monic_of_qExpansion.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_45c886fb
+
+noncomputable section
+
+p2m_open "Polynomial IntermediateField IntermediateField.algebraAdjoinAdjoin"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_qExpand \
+  algebraMap_apply_eq_single jq coeff_jq_pow_self coeff_jq_pow_of_lt coeff_jq_neg_one \
+  coeff_jq_of_lt jqN dedekindPsi evalAtJ evalAtJ_X ModularPolynomialData jGen evalAtJGen \
+  algebraMap_comp_evalAtJGen ModularPolynomialData.toAdjoin qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qExpand evalAtJqN evalAtJqN_X evalAtJqN_def evalAtJ_def EvalSymm aeval_toRingHom_X \
+  PhiIrreducible adjoinJq jAdj evalAtJAdj swapInner swapBivar swapBivar_X swapBivar_C_X coeffMap \
+  coeffEmb coeffEmb_coeff coeffMap_qExpand coeffEmb_qExpand transcendental_jq dedekindPsi_prime"
+p2m_open "ModularCurve"
+
+section JqNLead
+
+variable (N : ℕ) [NeZero N]
+
+private theorem coeff_jqN_self : (jqN N).coeff (-(N : ℤ)) = 1 := by
+  have h : (-(N : ℤ)) = (N : ℤ) * (-1) := by ring
+  rw [jqN, h, qExpand_coeff_mul, coeff_jq_neg_one]
+
+private theorem coeff_jqN_of_lt {m : ℤ} (hm : m < -(N : ℤ)) : (jqN N).coeff m = 0 := by
+  rw [jqN]
+  by_cases hdvd : (N : ℤ) ∣ m
+  · obtain ⟨k, rfl⟩ := hdvd
+    rw [qExpand_coeff_mul]
+    refine coeff_jq_of_lt ?_
+    have hN : (0 : ℤ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+    nlinarith
+  · exact qExpand_coeff_of_not_dvd N jq hdvd
+
+end JqNLead
+
+private theorem evalAtJ_injective : Function.Injective evalAtJ := by
+  rw [injective_iff_map_eq_zero]
+  intro c hc
+  by_contra hc0
+  refine transcendental_jq ⟨c.map (Int.castRingHom ℚ), ?_, ?_⟩
+  · exact (Polynomial.map_ne_zero_iff (Int.cast_injective)).mpr hc0
+  · rw [Polynomial.aeval_def, Polynomial.eval₂_map, Subsingleton.elim
+      ((algebraMap ℚ (LaurentSeries ℚ)).comp (Int.castRingHom ℚ))
+      (algebraMap ℤ (LaurentSeries ℚ))]
+    exact hc
+
+theorem evalAtJGen_injective : Function.Injective evalAtJGen := by
+  intro a b hab
+  apply evalAtJ_injective
+  rw [← algebraMap_comp_evalAtJGen]
+  simp only [RingHom.comp_apply, hab]
+
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd phiProd_eval_conj"
+p2m_open "ModularCurve.PhiGen"
+
+section CoeffEmbJq
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+private theorem coeff_coeffEmb_jq_neg_one : (coeffEmb K jq).coeff (-1 : ℤ) = 1 := by
+  rw [coeffEmb_coeff, coeff_jq_neg_one, map_one]
+
+end CoeffEmbJq
+
+section Distinctness
+
+variable {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+private theorem conj_zero_coeff_neg_one :
+    (conj ℓ ζ (0 : Fin (ℓ + 1))).coeff (-1 : ℤ) = 0 := by
+  rw [conj_zero]
+  refine qExpand_coeff_of_not_dvd _ _ ?_
+  intro h
+  have h1 : ((ℓ * ℓ : ℕ) : ℤ) ∣ 1 := dvd_neg.mp h
+  have h2 : (ℓ * ℓ : ℕ) ∣ 1 := by exact_mod_cast h1
+  have h3 : ℓ * ℓ = 1 := Nat.dvd_one.mp h2
+  have h4 : 2 ≤ ℓ := hℓ.out.two_le
+  nlinarith
+
+private theorem conj_succ_coeff_neg_one (b : Fin ℓ) :
+    (conj ℓ ζ b.succ).coeff (-1 : ℤ) = (((ζ ^ (b : ℕ))⁻¹ : Kˣ) : K) := by
+  rw [conj_succ, qTwist_coeff, coeff_coeffEmb_jq_neg_one, mul_one, zpow_neg_one]
+
+private theorem conj_injective (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    Function.Injective (conj ℓ ζ (K := K)) := by
+  have hne : ∀ b : Fin ℓ, (conj ℓ ζ (0 : Fin (ℓ + 1))).coeff (-1 : ℤ) ≠
+      (conj ℓ ζ b.succ).coeff (-1 : ℤ) := by
+    intro b
+    rw [conj_zero_coeff_neg_one, conj_succ_coeff_neg_one]
+    exact fun h => Units.ne_zero _ h.symm
+  intro i j hij
+  induction i using Fin.cases with
+  | zero =>
+    induction j using Fin.cases with
+    | zero => rfl
+    | succ b => exact absurd (congrArg (fun f => HahnSeries.coeff f (-1 : ℤ)) hij) (hne b)
+  | succ b =>
+    induction j using Fin.cases with
+    | zero => exact absurd (congrArg (fun f => HahnSeries.coeff f (-1 : ℤ)) hij.symm) (hne b)
+    | succ b' =>
+      have hcoeff := congrArg (fun f => HahnSeries.coeff f (-1 : ℤ)) hij
+      simp only [conj_succ_coeff_neg_one] at hcoeff
+      have hu : (ζ ^ (b : ℕ))⁻¹ = (ζ ^ (b' : ℕ))⁻¹ := Units.ext hcoeff
+      have hpow : (ζ : K) ^ (b : ℕ) = (ζ : K) ^ (b' : ℕ) := by
+        have hv := congrArg Units.val (inv_injective hu)
+        push_cast at hv
+        exact hv
+      exact congrArg Fin.succ (Fin.ext (hζ.pow_inj b.isLt b'.isLt hpow))
+
+end Distinctness
+
+section ScalarEmbedding
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+private def ratC : ℚ →+* LaurentSeries K := (HahnSeries.C).comp (algebraMap ℚ K)
+
+private theorem ratC_apply (c : ℚ) : ratC K c = HahnSeries.single 0 (algebraMap ℚ K c) :=
+  rfl
+
+private theorem coeff_ratC_of_ne (c : ℚ) {k : ℤ} (hk : k ≠ 0) : (ratC K c).coeff k = 0 := by
+  rw [ratC_apply]
+  exact HahnSeries.coeff_single_of_ne hk
+
+private theorem coeffMap_jq : coeffMap (algebraMap ℚ K) jq = (coeffEmb K jq) := by
+  ext k
+  rfl
+
+end ScalarEmbedding
+
+section PoleOrder
+
+private theorem coeff_aeval_jq_of_lt (P : Polynomial ℚ) {m : ℤ}
+    (hm : m < -(P.natDegree : ℤ)) : (Polynomial.aeval jq P).coeff m = 0 := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum]
+  refine Finset.sum_eq_zero fun i hi => ?_
+  rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_of_lt,
+    mul_zero]
+  have : i ≤ P.natDegree := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)
+  omega
+
+private theorem coeff_aeval_jq_neg_natDegree (P : Polynomial ℚ) :
+    (Polynomial.aeval jq P).coeff (-(P.natDegree : ℤ)) = P.coeff P.natDegree := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+    Finset.sum_eq_single P.natDegree]
+  · rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_self,
+      mul_one]
+  · intro i hi hin
+    have hilt : i < P.natDegree :=
+      lt_of_le_of_ne (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hin
+    rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_of_lt
+      (by omega), mul_zero]
+  · intro hn'
+    exact absurd (Finset.self_mem_range_succ P.natDegree) hn'
+
+variable (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] {P : Polynomial ℚ}
+
+private theorem ne_zero_of_aeval_jq_eq_jqN (h : Polynomial.aeval jq P = jqN ℓ) : P ≠ 0 := by
+  rintro rfl
+  rw [map_zero] at h
+  have h1 := coeff_jqN_self ℓ
+  rw [← h, HahnSeries.coeff_zero] at h1
+  exact zero_ne_one h1
+
+private theorem natDegree_eq_of_aeval_jq_eq_jqN (h : Polynomial.aeval jq P = jqN ℓ) :
+    P.natDegree = ℓ := by
+  have hP0 : P ≠ 0 := ne_zero_of_aeval_jq_eq_jqN ℓ h
+  by_contra hne
+  rcases lt_or_gt_of_ne hne with hlt | hgt
+  · have h1 : (Polynomial.aeval jq P).coeff (-(ℓ : ℤ)) = 0 :=
+      coeff_aeval_jq_of_lt P (by omega)
+    rw [h, coeff_jqN_self] at h1
+    exact one_ne_zero h1
+  · have h1 := coeff_aeval_jq_neg_natDegree P
+    rw [h, coeff_jqN_of_lt ℓ (by omega)] at h1
+    exact hP0 (Polynomial.leadingCoeff_eq_zero.mp h1.symm)
+
+private theorem monic_of_aeval_jq_eq_jqN (h : Polynomial.aeval jq P = jqN ℓ) : P.Monic := by
+  have hd := natDegree_eq_of_aeval_jq_eq_jqN ℓ h
+  have h1 := coeff_aeval_jq_neg_natDegree P
+  rw [h, hd, coeff_jqN_self] at h1
+  change P.coeff P.natDegree = 1
+  rw [hd]
+  exact h1.symm
+
+end PoleOrder
+
+section Transfer
+
+variable {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+omit [Algebra ℚ K] hℓ in
+private theorem zeta_pow_eq_one (hζ : IsPrimitiveRoot (ζ : K) ℓ) : ζ ^ ℓ = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one])
+
+omit [Algebra ℚ K] hℓ in
+private theorem zeta_pow_zpow_eq_one (hζ : IsPrimitiveRoot (ζ : K) ℓ) (b : ℕ) :
+    (ζ ^ b) ^ ((ℓ : ℕ) : ℤ) = (1 : Kˣ) := by
+  rw [zpow_natCast, ← pow_mul, mul_comm, pow_mul, zeta_pow_eq_one ℓ ζ hζ, one_pow]
+
+variable {P : Polynomial ℚ}
+
+private theorem eval₂_ratC_jqK_of_aeval_jq_eq (h : Polynomial.aeval jq P = jqN ℓ) :
+    P.eval₂ (ratC K) (coeffEmb K jq) = qExpand K ℓ (coeffEmb K jq) := by
+  have h2 := congrArg (coeffMap (algebraMap ℚ K)) h
+  rw [Polynomial.aeval_def, Polynomial.hom_eval₂, jqN, coeffMap_qExpand, coeffMap_jq,
+    Subsingleton.elim ((coeffMap (algebraMap ℚ K)).comp (algebraMap ℚ (LaurentSeries ℚ)))
+      (ratC K)] at h2
+  exact h2
+
+private theorem eval₂_ratC_conj_succ_of_aeval_jq_eq (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (h : Polynomial.aeval jq P = jqN ℓ) (b : Fin ℓ) :
+    P.eval₂ (ratC K) (conj ℓ ζ b.succ) = qExpand K ℓ (coeffEmb K jq) := by
+  have h2 := congrArg (qTwist (ζ ^ (b : ℕ))) (eval₂_ratC_jqK_of_aeval_jq_eq ℓ h)
+  rw [Polynomial.hom_eval₂,
+    Subsingleton.elim ((qTwist (ζ ^ (b : ℕ))).comp (ratC K)) (ratC K),
+    qTwist_qExpand, zeta_pow_zpow_eq_one ℓ ζ hζ, qTwist_one_apply, ← conj_succ] at h2
+  exact h2
+
+end Transfer
+
+section Vieta
+
+variable {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+variable {P : Polynomial ℚ}
+
+private theorem sum_conj_succ_eq_ratC_of_aeval_jq_eq (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (h : Polynomial.aeval jq P = jqN ℓ) :
+    ∑ b : Fin ℓ, conj ℓ ζ b.succ = ratC K (-(P.coeff (ℓ - 1))) := by
+  have hPdeg : P.natDegree = ℓ := natDegree_eq_of_aeval_jq_eq_jqN ℓ h
+  have hPmonic : P.Monic := monic_of_aeval_jq_eq_jqN ℓ h
+  set A : Polynomial (LaurentSeries K) := P.map (ratC K) with hA
+  set B : Polynomial (LaurentSeries K) :=
+    ∏ b : Fin ℓ, (Polynomial.X - Polynomial.C (conj ℓ ζ b.succ)) with hB
+  have hAmonic : A.Monic := hPmonic.map _
+  have hAdeg : A.natDegree = ℓ := by rw [hA, hPmonic.natDegree_map, hPdeg]
+  have hBmonic : B.Monic :=
+    Polynomial.monic_prod_of_monic _ _ fun i _ => Polynomial.monic_X_sub_C _
+  have hBdeg : B.natDegree = ℓ := by
+    rw [hB, Polynomial.natDegree_prod_of_monic _ _ fun i _ => Polynomial.monic_X_sub_C _]
+    simp
+  have hinj : Function.Injective (fun b : Fin ℓ => conj ℓ ζ b.succ) := fun b b' hbb' =>
+    Fin.succ_injective ℓ (conj_injective ℓ ζ hζ hbb')
+  have key : A - B = Polynomial.C (qExpand K ℓ (coeffEmb K jq)) := by
+    refine Polynomial.eq_of_natDegree_lt_card_of_eval_eq _ _ hinj (fun b => ?_) ?_
+    · have hAev : A.eval (conj ℓ ζ b.succ) = qExpand K ℓ (coeffEmb K jq) := by
+        rw [hA, Polynomial.eval_map]
+        exact eval₂_ratC_conj_succ_of_aeval_jq_eq ℓ ζ hζ h b
+      have hBev : B.eval (conj ℓ ζ b.succ) = 0 := by
+        rw [hB, Polynomial.eval_prod]
+        exact Finset.prod_eq_zero (Finset.mem_univ b) (by simp)
+      simp only [Polynomial.eval_sub, Polynomial.eval_C, hAev, hBev, sub_zero]
+    · rw [Fintype.card_fin]
+      refine max_lt ?_ (by rw [Polynomial.natDegree_C]; exact hℓ.out.pos)
+      by_cases hAB : A = B
+      · rw [hAB, sub_self, Polynomial.natDegree_zero]
+        exact hℓ.out.pos
+      · refine lt_of_lt_of_eq
+          (Polynomial.natDegree_lt_natDegree (sub_ne_zero.mpr hAB) ?_) hAdeg
+        exact Polynomial.degree_sub_lt_left
+          (by rw [Polynomial.degree_eq_natDegree hAmonic.ne_zero,
+                Polynomial.degree_eq_natDegree hBmonic.ne_zero, hAdeg, hBdeg])
+          hAmonic.ne_zero (by rw [hAmonic.leadingCoeff, hBmonic.leadingCoeff])
+  have hcoeff := congrArg (fun p => Polynomial.coeff p (ℓ - 1)) key
+  have hℓ2 : 2 ≤ ℓ := hℓ.out.two_le
+  simp only [Polynomial.coeff_sub, Polynomial.coeff_C,
+    ite_eq_right (by omega : ¬(ℓ - 1 = 0))] at hcoeff
+  have hBcoeff : B.coeff (ℓ - 1) = -∑ b : Fin ℓ, conj ℓ ζ b.succ := by
+    have hv := Polynomial.prod_X_sub_C_coeff_card_pred (Finset.univ : Finset (Fin ℓ))
+      (fun b => conj ℓ ζ b.succ) (by simp [hℓ.out.pos])
+    simpa using hv
+  have hAcoeff : A.coeff (ℓ - 1) = ratC K (P.coeff (ℓ - 1)) := Polynomial.coeff_map _ _
+  rw [hAcoeff, hBcoeff, sub_neg_eq_add, add_comm] at hcoeff
+  rw [map_neg]
+  exact eq_neg_of_add_eq_zero_left hcoeff
+
+end Vieta
+
+section Refutation
+
+variable {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+private theorem coeff_sum_conj_succ_self (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    (∑ b : Fin ℓ, conj ℓ ζ b.succ).coeff ((ℓ : ℕ) : ℤ) =
+      (ℓ : K) * algebraMap ℚ K (jq.coeff ((ℓ : ℕ) : ℤ)) := by
+  rw [HahnSeries.coeff_sum]
+  have hterm : ∀ b : Fin ℓ, (conj ℓ ζ b.succ).coeff ((ℓ : ℕ) : ℤ) =
+      algebraMap ℚ K (jq.coeff ((ℓ : ℕ) : ℤ)) := by
+    intro b
+    rw [conj_succ, qTwist_coeff, zeta_pow_zpow_eq_one ℓ ζ hζ, Units.val_one, one_mul,
+      coeffEmb_coeff]
+  rw [Finset.sum_congr rfl fun b _ => hterm b, Finset.sum_const, Finset.card_univ,
+    Fintype.card_fin, nsmul_eq_mul]
+
+private theorem coeff_sum_conj_succ_ne_zero
+    (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    (∑ b : Fin ℓ, conj ℓ ζ b.succ).coeff ((ℓ : ℕ) : ℤ) ≠ 0 := by
+  rw [coeff_sum_conj_succ_self ℓ ζ hζ]
+  refine mul_ne_zero ?_ ?_
+  · rw [show ((ℓ : ℕ) : K) = algebraMap ℚ K ((ℓ : ℕ) : ℚ) from (map_natCast _ _).symm]
+    intro hc
+    exact (Nat.cast_ne_zero (R := ℚ)).mpr hℓ.out.ne_zero
+      ((algebraMap ℚ K).injective (by rw [hc, map_zero]))
+  · intro hc
+    have h0 : jq.coeff ((ℓ : ℕ) : ℤ) = 0 :=
+      (algebraMap ℚ K).injective (by rw [hc, map_zero])
+    have h1 := hpos ℓ
+    rw [h0] at h1
+    norm_num at h1
+
+theorem aeval_jq_ne_jqN_of_isPrimitiveRoot
+    (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (P : Polynomial ℚ) : Polynomial.aeval jq P ≠ jqN ℓ := by
+  intro h
+  have h1 := sum_conj_succ_eq_ratC_of_aeval_jq_eq ℓ ζ hζ h
+  have h2 := coeff_sum_conj_succ_ne_zero ℓ ζ hpos hζ
+  rw [h1] at h2
+  exact h2 (coeff_ratC_of_ne K _ (by exact_mod_cast hℓ.out.ne_zero))
+
+end Refutation
+
+section Headline
+
+variable (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)]
+
+theorem aeval_jq_ne_jqN (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (P : Polynomial ℚ) :
+    Polynomial.aeval jq P ≠ jqN ℓ := by
+  have : NeZero ((ℓ : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr hℓ.out.ne_zero⟩
+  have : IsCyclotomicExtension {ℓ} ℚ (CyclotomicField ℓ ℚ) :=
+    CyclotomicField.isCyclotomicExtension (n := ℓ) (K := ℚ)
+  obtain ⟨z, hz⟩ := IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField ℓ ℚ)
+    (Set.mem_singleton ℓ) hℓ.out.ne_zero
+  have hzu : IsUnit z := hz.isUnit hℓ.out.ne_zero
+  refine aeval_jq_ne_jqN_of_isPrimitiveRoot ℓ hzu.unit hpos ?_ P
+  rw [hzu.unit_spec]
+  exact hz
+
+theorem jqN_not_mem_adjoin_jq (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) :
+    jqN ℓ ∉ Algebra.adjoin ℚ {jq} := by
+  intro hmem
+  obtain ⟨P, hP⟩ := Algebra.adjoin_mem_exists_aeval _ _ hmem
+  exact aeval_jq_ne_jqN ℓ hpos P hP
+
+end Headline
+
+end PhiGen
+
+section FractionField
+
+private scoped instance instUFMAdjoinJq : UniqueFactorizationMonoid adjoinJq :=
+  transcendental_jq.uniqueFactorizationMonoid_adjoin
+
+private theorem algebraMap_comp_evalAtJAdj :
+    (algebraMap adjoinJq ℚ⟮jq⟯).comp evalAtJAdj = evalAtJGen := by
+  refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+  change algebraMap adjoinJq ℚ⟮jq⟯ (evalAtJAdj Polynomial.X) = evalAtJGen Polynomial.X
+  rw [show evalAtJAdj Polynomial.X = jAdj from Polynomial.eval₂_X _ _,
+    show evalAtJGen Polynomial.X = jGen from Polynomial.eval₂_X _ _]
+  exact Subtype.ext rfl
+
+namespace ModularPolynomialData
+p2m_export "ModularCurve.ModularPolynomialData" "toAdjoin toAdjoin_monic monic eval_eq_zero \
+  natDegree_eq Φ"
+p2m_open "ModularCurve.ModularPolynomialData"
+
+variable {N : ℕ} [NeZero N] (data : ModularPolynomialData N)
+
+private theorem _root_.ModularCurve.ModularPolynomialData.aeval_jqN_toAdjoin :
+    Polynomial.aeval (jqN N) data.toAdjoin = 0 := by
+  rw [Polynomial.aeval_def, toAdjoin, Polynomial.eval₂_map, algebraMap_comp_evalAtJGen]
+  exact data.eval_eq_zero
+
+p2m_export "ModularCurve.ModularPolynomialData" "aeval_jqN_toAdjoin"
+
+private theorem _root_.ModularCurve.ModularPolynomialData.minpoly_jqN_eq (hirr : PhiIrreducible
+  data) :
+    minpoly ℚ⟮jq⟯ (jqN N) = data.toAdjoin :=
+  (minpoly.eq_of_irreducible_of_monic hirr data.aeval_jqN_toAdjoin data.toAdjoin_monic).symm
+
+p2m_export "ModularCurve.ModularPolynomialData" "minpoly_jqN_eq"
+end ModularPolynomialData
+
+end FractionField
+
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd phiProd_eval_conj"
+p2m_open "ModularCurve.PhiGen"
+
+section Embed
+
+variable (K : Type*) [Field K] [Algebra ℚ K] (ℓ : ℕ) [NeZero ℓ]
+
+private def qEmbedT : LaurentSeries ℚ →+* LaurentSeries K :=
+  (qExpand K ℓ).comp (coeffMap (algebraMap ℚ K))
+
+private theorem qEmbedT_apply (x : LaurentSeries ℚ) :
+    qEmbedT K ℓ x = qExpand K ℓ (coeffMap (algebraMap ℚ K) x) := rfl
+
+private theorem qEmbedT_injective : Function.Injective (qEmbedT K ℓ) :=
+  (qEmbedT K ℓ).injective
+
+private theorem qEmbedT_jq : qEmbedT K ℓ jq = qExpand K ℓ (coeffEmb K jq) := by
+  rw [qEmbedT_apply, coeffMap_jq]
+
+private theorem qEmbedT_eq_coeffEmb_qExpand (x : LaurentSeries ℚ) :
+    qEmbedT K ℓ x = coeffEmb K (qExpand ℚ ℓ x) := by
+  rw [coeffEmb_qExpand]
+  rfl
+
+private theorem coeffEmb_comp_qExpand_comp_evalAtJ :
+    ((coeffEmb K).comp (qExpand ℚ ℓ)).comp evalAtJ = (qEmbedT K ℓ).comp evalAtJ := by
+  refine RingHom.ext fun p => ?_
+  simp only [RingHom.comp_apply]
+  rw [qEmbedT_eq_coeffEmb_qExpand]
+
+end Embed
+
+section EmbedPrime
+
+variable (K : Type*) [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+private theorem qEmbedT_jqN : qEmbedT K ℓ (jqN ℓ) = conj ℓ ζ (0 : Fin (ℓ + 1)) := by
+  rw [conj_zero, qEmbedT_apply, jqN, coeffMap_qExpand, coeffMap_jq, qExpand_qExpand]
+
+private theorem qTwist_comp_qEmbedT (hζ : IsPrimitiveRoot (ζ : K) ℓ) (b : ℕ) :
+    (qTwist (ζ ^ b)).comp (qEmbedT K ℓ) = qEmbedT K ℓ := by
+  refine RingHom.ext fun x => ?_
+  rw [RingHom.comp_apply, qEmbedT_apply, qTwist_qExpand, zeta_pow_zpow_eq_one ℓ ζ hζ b,
+    qTwist_one_apply]
+
+private theorem conj_succ_zero : conj ℓ ζ (0 : Fin ℓ).succ = (coeffEmb K jq) := by
+  rw [conj_succ, Fin.val_zero, pow_zero, qTwist_one_apply]
+
+end EmbedPrime
+
+section FactorAnalysis
+
+variable (K : Type*) [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+private def adjoinEmbedT : adjoinJq →+* LaurentSeries K :=
+  (qEmbedT K ℓ).comp (algebraMap adjoinJq (LaurentSeries ℚ))
+
+private theorem adjoinEmbedT_apply (x : adjoinJq) :
+    adjoinEmbedT K ℓ x = qEmbedT K ℓ (x : LaurentSeries ℚ) := rfl
+
+private theorem adjoinEmbedT_injective : Function.Injective (adjoinEmbedT K ℓ) :=
+  fun _ _ h => Subtype.ext (qEmbedT_injective K ℓ h)
+
+private theorem adjoinEmbedT_comp_evalAtJAdj :
+    (adjoinEmbedT K ℓ).comp evalAtJAdj = (qEmbedT K ℓ).comp evalAtJ := by
+  refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+  change adjoinEmbedT K ℓ (evalAtJAdj Polynomial.X) = qEmbedT K ℓ (evalAtJ Polynomial.X)
+  rw [show evalAtJAdj Polynomial.X = jAdj from Polynomial.eval₂_X _ _, evalAtJ_X]
+  rfl
+
+variable {K ℓ ζ}
+
+private theorem eval_map_conj_succ_eq_zero (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    {D : Polynomial adjoinJq} (h : (D.map (adjoinEmbedT K ℓ)).eval (coeffEmb K jq) = 0)
+    (b : Fin ℓ) : (D.map (adjoinEmbedT K ℓ)).eval (conj ℓ ζ b.succ) = 0 := by
+  have hcomp : (qTwist (ζ ^ (b : ℕ))).comp (adjoinEmbedT K ℓ) = adjoinEmbedT K ℓ := by
+    rw [adjoinEmbedT, ← RingHom.comp_assoc, qTwist_comp_qEmbedT K ℓ ζ hζ]
+  have key : qTwist (ζ ^ (b : ℕ)) ((D.map (adjoinEmbedT K ℓ)).eval (coeffEmb K jq))
+      = (D.map (adjoinEmbedT K ℓ)).eval (qTwist (ζ ^ (b : ℕ)) (coeffEmb K jq)) := by
+    rw [Polynomial.eval_map, Polynomial.eval_map, Polynomial.hom_eval₂, hcomp]
+  rw [conj_succ, ← key, h, map_zero]
+
+private theorem le_natDegree_of_eval_map_jqK_eq_zero (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    {D : Polynomial adjoinJq} (hD : D ≠ 0)
+    (h : (D.map (adjoinEmbedT K ℓ)).eval (coeffEmb K jq) = 0) : ℓ ≤ D.natDegree := by
+  have hmap : ℓ ≤ (D.map (adjoinEmbedT K ℓ)).natDegree := by
+    by_contra hlt
+    rw [not_le] at hlt
+    have hzero : D.map (adjoinEmbedT K ℓ) = 0 :=
+      Polynomial.eq_zero_of_natDegree_lt_card_of_eval_eq_zero _
+        (f := fun b : Fin ℓ => conj ℓ ζ b.succ)
+        (fun b b' hbb' => Fin.succ_injective ℓ (conj_injective ℓ ζ hζ hbb'))
+        (fun b => eval_map_conj_succ_eq_zero hζ h b)
+        (by rwa [Fintype.card_fin])
+    exact hD (Polynomial.map_injective _ (adjoinEmbedT_injective K ℓ)
+      (by rw [hzero, Polynomial.map_zero]))
+  exact le_trans hmap Polynomial.natDegree_map_le
+
+private theorem eval_map_evalAtJAdj_ne_zero
+    (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (data : ModularPolynomialData ℓ)
+    (hsplit : (data.Φ.map evalAtJAdj).map (adjoinEmbedT K ℓ) = phiProd ℓ (conj ℓ ζ))
+    (β : adjoinJq) : (data.Φ.map evalAtJAdj).eval β ≠ 0 := by
+  intro heval
+  have hmap : (phiProd ℓ (conj ℓ ζ)).eval (adjoinEmbedT K ℓ β) = 0 := by
+    rw [← hsplit, Polynomial.eval_map, Polynomial.eval₂_at_apply, heval, map_zero]
+  rw [phiProd, Polynomial.eval_prod] at hmap
+  obtain ⟨i, -, hi⟩ := Finset.prod_eq_zero_iff.mp hmap
+  rw [Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, sub_eq_zero] at hi
+  rcases Fin.eq_zero_or_eq_succ i with rfl | ⟨b, rfl⟩
+  · rw [adjoinEmbedT_apply, ← qEmbedT_jqN K ℓ ζ] at hi
+    have hβ : (β : LaurentSeries ℚ) = jqN ℓ := qEmbedT_injective K ℓ hi
+    exact jqN_not_mem_adjoin_jq ℓ hpos (hβ ▸ β.2)
+  · have h0 : (adjoinEmbedT K ℓ β).coeff (-1 : ℤ) = 0 := by
+      rw [adjoinEmbedT_apply, qEmbedT_apply]
+      refine qExpand_coeff_of_not_dvd _ _ ?_
+      intro hdvd
+      have h1 : ((ℓ : ℕ) : ℤ) ∣ 1 := dvd_neg.mp hdvd
+      have h2 : ℓ ∣ 1 := by exact_mod_cast h1
+      exact hℓ.out.one_lt.ne' (Nat.dvd_one.mp h2)
+    rw [hi, conj_succ_coeff_neg_one] at h0
+    exact Units.ne_zero _ h0
+
+private theorem isUnit_of_dvd_of_natDegree_le_one
+    (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (data : ModularPolynomialData ℓ)
+    (hsplit : (data.Φ.map evalAtJAdj).map (adjoinEmbedT K ℓ) = phiProd ℓ (conj ℓ ζ))
+    {B : Polynomial adjoinJq} (hdvd : B ∣ data.Φ.map evalAtJAdj)
+    (hlc : IsUnit B.leadingCoeff) (hdeg : B.natDegree ≤ 1) : IsUnit B := by
+  rcases Nat.le_one_iff_eq_zero_or_eq_one.mp hdeg with h0 | h1
+  · rw [Polynomial.eq_C_of_natDegree_eq_zero h0]
+    refine Polynomial.isUnit_C.mpr ?_
+    have hc : B.coeff 0 = B.leadingCoeff := by rw [Polynomial.leadingCoeff, h0]
+    rw [hc]
+    exact hlc
+  · exfalso
+    obtain ⟨u, hu⟩ := hlc
+    obtain ⟨D, hD⟩ := hdvd
+    have hu1 : (u : adjoinJq) = B.coeff 1 := by rw [hu, Polynomial.leadingCoeff, h1]
+    have hBev : ∀ x : adjoinJq, B.eval x = B.coeff 1 * x + B.coeff 0 := fun x => by
+      conv_lhs => rw [Polynomial.eq_X_add_C_of_natDegree_le_one hdeg]
+      simp only [Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C,
+        Polynomial.eval_X]
+    have hroot : B.eval ((↑u⁻¹ : adjoinJq) * -B.coeff 0) = 0 := by
+      rw [hBev, ← hu1]
+      linear_combination (-B.coeff 0) * u.mul_inv
+    refine eval_map_evalAtJAdj_ne_zero hpos data hsplit ((↑u⁻¹ : adjoinJq) * -B.coeff 0) ?_
+    rw [hD, Polynomial.eval_mul, hroot, zero_mul]
+
+end FactorAnalysis
+
+section Irreducibility
+
+variable {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+private theorem irreducible_map_evalAtJAdj_of_splits
+    (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (data : ModularPolynomialData ℓ)
+    (hsplit : (data.Φ.map evalAtJAdj).map (adjoinEmbedT K ℓ) = phiProd ℓ (conj ℓ ζ)) :
+    Irreducible (data.Φ.map evalAtJAdj) := by
+  have hmonic : (data.Φ.map evalAtJAdj).Monic := data.monic.map _
+  have hdeg : (data.Φ.map evalAtJAdj).natDegree = ℓ + 1 := by
+    rw [data.monic.natDegree_map, data.natDegree_eq, dedekindPsi_prime hℓ.out]
+  constructor
+  · exact Polynomial.not_isUnit_of_natDegree_pos _ (by omega)
+  · intro A B hAB
+    have hA0 : A ≠ 0 := fun h => hmonic.ne_zero (by rw [hAB, h, zero_mul])
+    have hB0 : B ≠ 0 := fun h => hmonic.ne_zero (by rw [hAB, h, mul_zero])
+    have hlcmul : A.leadingCoeff * B.leadingCoeff = 1 := by
+      rw [← Polynomial.leadingCoeff_mul, ← hAB]
+      exact hmonic.leadingCoeff
+    have hlcA : IsUnit A.leadingCoeff := IsUnit.of_mul_eq_one _ hlcmul
+    have hlcB : IsUnit B.leadingCoeff := IsUnit.of_mul_eq_one_right _ hlcmul
+    have hAdvd : A ∣ data.Φ.map evalAtJAdj := ⟨B, hAB⟩
+    have hBdvd : B ∣ data.Φ.map evalAtJAdj := ⟨A, hAB.trans (mul_comm A B)⟩
+    have hsum : A.natDegree + B.natDegree = ℓ + 1 := by
+      rw [← Polynomial.natDegree_mul hA0 hB0, ← hAB, hdeg]
+    have hzero : ((A.map (adjoinEmbedT K ℓ)).eval (coeffEmb K jq))
+        * ((B.map (adjoinEmbedT K ℓ)).eval (coeffEmb K jq)) = 0 := by
+      rw [← Polynomial.eval_mul, ← Polynomial.map_mul, ← hAB, hsplit,
+        ← conj_succ_zero K ℓ ζ]
+      exact phiProd_eval_conj ℓ _ _
+    rcases mul_eq_zero.mp hzero with hAz | hBz
+    · right
+      have hAdeg : ℓ ≤ A.natDegree := le_natDegree_of_eval_map_jqK_eq_zero hζ hA0 hAz
+      exact isUnit_of_dvd_of_natDegree_le_one hpos data hsplit hBdvd hlcB (by omega)
+    · left
+      have hBdeg : ℓ ≤ B.natDegree := le_natDegree_of_eval_map_jqK_eq_zero hζ hB0 hBz
+      exact isUnit_of_dvd_of_natDegree_le_one hpos data hsplit hAdvd hlcA (by omega)
+
+private theorem toAdjoin_eq_map_evalAtJAdj {N : ℕ} [NeZero N]
+    (data : ModularPolynomialData N) :
+    data.toAdjoin = (data.Φ.map evalAtJAdj).map (algebraMap adjoinJq ℚ⟮jq⟯) := by
+  rw [ModularPolynomialData.toAdjoin, Polynomial.map_map, algebraMap_comp_evalAtJAdj]
+
+theorem phiIrreducible_of_splits
+    (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (data : ModularPolynomialData ℓ)
+    (hsplit : data.Φ.map (((coeffEmb K).comp (qExpand ℚ ℓ)).comp evalAtJ)
+      = phiProd ℓ (conj ℓ ζ)) : PhiIrreducible data := by
+  rw [coeffEmb_comp_qExpand_comp_evalAtJ K ℓ] at hsplit
+  have hsplit' : (data.Φ.map evalAtJAdj).map (adjoinEmbedT K ℓ)
+      = phiProd ℓ (conj ℓ ζ) := by
+    rw [Polynomial.map_map, adjoinEmbedT_comp_evalAtJAdj]
+    exact hsplit
+  change Irreducible data.toAdjoin
+  rw [toAdjoin_eq_map_evalAtJAdj]
+  exact ((data.monic.map evalAtJAdj).irreducible_iff_irreducible_map_fraction_map).mp
+    (irreducible_map_evalAtJAdj_of_splits ℓ ζ hpos hζ data hsplit')
+
+end Irreducibility
+
+end PhiGen
+
+section SwapBivarEval
+
+private theorem swapBivar_eval₂ (Φ : Polynomial (Polynomial ℤ)) (x y : LaurentSeries ℚ) :
+    (swapBivar Φ).eval₂ (Polynomial.aeval (R := ℤ) x).toRingHom y
+      = Φ.eval₂ (Polynomial.aeval (R := ℤ) y).toRingHom x := by
+  set h : Polynomial (Polynomial ℤ) →+* LaurentSeries ℚ :=
+    Polynomial.eval₂RingHom (Polynomial.aeval (R := ℤ) x).toRingHom y with hh
+  have key : h (swapBivar Φ) = Φ.eval₂ (h.comp swapInner) (h (Polynomial.C Polynomial.X)) :=
+    Polynomial.hom_eval₂ Φ swapInner h (Polynomial.C Polynomial.X)
+  have hCX : h (Polynomial.C Polynomial.X) = x := by
+    rw [hh, Polynomial.coe_eval₂RingHom, Polynomial.eval₂_C, aeval_toRingHom_X]
+  have hcomp : h.comp swapInner = (Polynomial.aeval (R := ℤ) y).toRingHom := by
+    refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+    change h (swapInner Polynomial.X) = (Polynomial.aeval (R := ℤ) y).toRingHom Polynomial.X
+    rw [aeval_toRingHom_X]
+    change h ((Polynomial.aeval (R := ℤ)
+      (Polynomial.X : Polynomial (Polynomial ℤ))) Polynomial.X) = y
+    rw [Polynomial.aeval_X, hh, Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X]
+  calc (swapBivar Φ).eval₂ (Polynomial.aeval (R := ℤ) x).toRingHom y
+      = h (swapBivar Φ) := rfl
+    _ = Φ.eval₂ (h.comp swapInner) (h (Polynomial.C Polynomial.X)) := key
+    _ = Φ.eval₂ (Polynomial.aeval (R := ℤ) y).toRingHom x := by rw [hCX, hcomp]
+
+theorem evalSymm_of_swapBivar_eq {Φ : Polynomial (Polynomial ℤ)} (h : swapBivar Φ = Φ) :
+    EvalSymm Φ := fun x y => by
+  conv_lhs => rw [← h]
+  exact swapBivar_eval₂ Φ x y
+
+end SwapBivarEval
+
+namespace ModularPolynomialData
+p2m_export "ModularCurve.ModularPolynomialData" "toAdjoin toAdjoin_monic monic eval_eq_zero \
+  natDegree_eq Φ"
+p2m_open "ModularCurve.ModularPolynomialData"
+
+variable {N : ℕ} [NeZero N] (data : ModularPolynomialData N)
+
+private theorem _root_.ModularCurve.ModularPolynomialData.aeval_jqN_transposeToAdjoin (hswap :
+  data.Φ.eval₂ (evalAtJqN N) jq = 0) :
+    Polynomial.aeval (jqN N) ((swapBivar data.Φ).map evalAtJGen) = 0 := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_map, algebraMap_comp_evalAtJGen,
+    evalAtJ_def, swapBivar_eval₂, ← evalAtJqN_def]
+  exact hswap
+
+p2m_export "ModularCurve.ModularPolynomialData" "aeval_jqN_transposeToAdjoin"
+
+private theorem _root_.ModularCurve.ModularPolynomialData.swapBivar_eq_of_irreducible (hirr :
+  PhiIrreducible data)
+    (hswap : data.Φ.eval₂ (evalAtJqN N) jq = 0)
+    (hTmonic : ((swapBivar data.Φ).map evalAtJGen).Monic)
+    (hTdeg : ((swapBivar data.Φ).map evalAtJGen).natDegree ≤ dedekindPsi N) :
+    swapBivar data.Φ = data.Φ := by
+  apply Polynomial.map_injective evalAtJGen evalAtJGen_injective
+  change (swapBivar data.Φ).map evalAtJGen = data.toAdjoin
+  have hdvd : data.toAdjoin ∣ (swapBivar data.Φ).map evalAtJGen := by
+    rw [← data.minpoly_jqN_eq hirr]
+    exact minpoly.dvd _ _ (data.aeval_jqN_transposeToAdjoin hswap)
+  refine eq_of_monic_of_dvd_of_natDegree_le data.toAdjoin_monic hTmonic hdvd ?_
+  rw [toAdjoin, data.monic.natDegree_map, data.natDegree_eq]
+  exact hTdeg
+
+p2m_export "ModularCurve.ModularPolynomialData" "swapBivar_eq_of_irreducible"
+
+private theorem _root_.ModularCurve.ModularPolynomialData.evalSymm_of_irreducible (hirr :
+  PhiIrreducible data)
+    (hswap : data.Φ.eval₂ (evalAtJqN N) jq = 0)
+    (hTmonic : ((swapBivar data.Φ).map evalAtJGen).Monic)
+    (hTdeg : ((swapBivar data.Φ).map evalAtJGen).natDegree ≤ dedekindPsi N) :
+    EvalSymm data.Φ :=
+  evalSymm_of_swapBivar_eq (data.swapBivar_eq_of_irreducible hirr hswap hTmonic hTdeg)
+
+p2m_export "ModularCurve.ModularPolynomialData" "evalSymm_of_irreducible"
+end ModularPolynomialData
+
+section Engine
+
+private theorem swapBivar_C (c : Polynomial ℤ) :
+    swapBivar (Polynomial.C c) = c.map Polynomial.C := by
+  have hext : swapBivar.comp (Polynomial.C : Polynomial ℤ →+* Polynomial (Polynomial ℤ))
+      = Polynomial.mapRingHom (Polynomial.C : ℤ →+* Polynomial ℤ) := by
+    refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+    change swapBivar (Polynomial.C Polynomial.X)
+      = Polynomial.mapRingHom (Polynomial.C : ℤ →+* Polynomial ℤ) Polynomial.X
+    rw [swapBivar_C_X, Polynomial.coe_mapRingHom, Polynomial.map_X]
+  calc swapBivar (Polynomial.C c)
+      = swapBivar.comp (Polynomial.C : Polynomial ℤ →+* Polynomial (Polynomial ℤ)) c := rfl
+    _ = Polynomial.mapRingHom (Polynomial.C : ℤ →+* Polynomial ℤ) c := by rw [hext]
+    _ = c.map Polynomial.C := rfl
+
+private theorem degree_swapBivar_lt {Ψ : Polynomial (Polynomial ℤ)} {D : ℕ}
+    (h : ∀ k, (Ψ.coeff k).degree < (D : WithBot ℕ)) :
+    (swapBivar Ψ).degree < (D : WithBot ℕ) := by
+  conv_lhs => rw [Polynomial.as_sum_support_C_mul_X_pow Ψ, map_sum]
+  refine (Polynomial.degree_sum_le _ _).trans_lt
+    ((Finset.sup_lt_iff (WithBot.bot_lt_coe D)).2 fun k _ => ?_)
+  rw [map_mul, map_pow, swapBivar_C, swapBivar_X, ← map_pow]
+  refine lt_of_le_of_lt (le_trans (Polynomial.degree_mul_le _ _) ?_) (h k)
+  calc ((Ψ.coeff k).map Polynomial.C).degree + (Polynomial.C (Polynomial.X ^ k)).degree
+      ≤ (Ψ.coeff k).degree + 0 := by
+        gcongr
+        · exact le_of_eq (Polynomial.degree_map_eq_of_injective Polynomial.C_injective _)
+        · exact Polynomial.degree_C_le
+    _ = (Ψ.coeff k).degree := add_zero _
+
+theorem swapBivar_monic_of_coeff_bounds {Φ : Polynomial (Polynomial ℤ)} {d : ℕ}
+    (h0 : (Φ.coeff 0).Monic) (h0deg : (Φ.coeff 0).natDegree = d)
+    (hk : ∀ k, k ≠ 0 → (Φ.coeff k).degree < (d : WithBot ℕ)) :
+    (swapBivar Φ).Monic ∧ (swapBivar Φ).natDegree = d := by
+  have hsplit : swapBivar Φ = Polynomial.C Polynomial.X * swapBivar Φ.divX
+      + (Φ.coeff 0).map Polynomial.C := by
+    conv_lhs => rw [← Polynomial.X_mul_divX_add Φ]
+    rw [map_add, map_mul, swapBivar_X, swapBivar_C]
+  have hmap : ((Φ.coeff 0).map Polynomial.C).Monic := h0.map _
+  have hmapdeg : ((Φ.coeff 0).map Polynomial.C).degree = (d : WithBot ℕ) := by
+    rw [Polynomial.degree_eq_natDegree hmap.ne_zero, h0.natDegree_map, h0deg]
+  have hsmall : (Polynomial.C Polynomial.X * swapBivar Φ.divX).degree
+      < (d : WithBot ℕ) := by
+    refine lt_of_le_of_lt (Polynomial.degree_mul_le _ _) ?_
+    have hX : (Polynomial.C (Polynomial.X : Polynomial ℤ)).degree = 0 :=
+      Polynomial.degree_C Polynomial.X_ne_zero
+    rw [hX, zero_add]
+    exact degree_swapBivar_lt fun k => by
+      rw [Polynomial.coeff_divX]; exact hk (k + 1) (Nat.succ_ne_zero k)
+  have hlt : (Polynomial.C Polynomial.X * swapBivar Φ.divX).degree
+      < ((Φ.coeff 0).map Polynomial.C).degree := by rw [hmapdeg]; exact hsmall
+  refine ⟨?_, ?_⟩
+  · rw [hsplit]; exact hmap.add_of_right hlt
+  · rw [hsplit, Polynomial.natDegree_eq_of_degree_eq
+      (Polynomial.degree_add_eq_right_of_degree_lt hlt), h0.natDegree_map, h0deg]
+
+end Engine
+
+section Dictionary
+
+private theorem evalAtJ_eq_aeval_map_rat (P : Polynomial ℤ) :
+    evalAtJ P = Polynomial.aeval jq (P.map (Int.castRingHom ℚ)) := by
+  rw [evalAtJ_def, Polynomial.aeval_def, Polynomial.eval₂_map, Subsingleton.elim
+    ((algebraMap ℚ (LaurentSeries ℚ)).comp (Int.castRingHom ℚ))
+    (algebraMap ℤ (LaurentSeries ℚ))]
+  rfl
+
+private theorem coeff_aeval_jq_neg (P : Polynomial ℚ) {m : ℕ} (hm : P.natDegree ≤ m) :
+    (Polynomial.aeval jq P).coeff (-(m : ℤ)) = P.coeff m := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+    Finset.sum_eq_single m]
+  · rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_self,
+      mul_one]
+  · intro i hi hin
+    have hilt : i < m :=
+      lt_of_le_of_ne (le_trans (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hm) hin
+    rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul,
+      coeff_jq_pow_of_lt (by omega), mul_zero]
+  · intro hm'
+    rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul,
+      Polynomial.coeff_eq_zero_of_natDegree_lt
+        (by simp only [Finset.mem_range, not_lt] at hm'; omega),
+      zero_mul]
+
+private theorem degree_lt_of_evalAtJ_coeff_eq_zero {P : Polynomial ℤ} {D : ℕ}
+    (h : ∀ m : ℕ, D ≤ m → (evalAtJ P).coeff (-(m : ℤ)) = 0) :
+    P.degree < (D : WithBot ℕ) := by
+  rcases eq_or_ne P 0 with rfl | hP0
+  · rw [Polynomial.degree_zero]; exact WithBot.bot_lt_coe D
+  rw [← Polynomial.natDegree_lt_iff_degree_lt hP0]
+  by_contra hle
+  rw [not_lt] at hle
+  have hQdeg : (P.map (Int.castRingHom ℚ)).natDegree = P.natDegree :=
+    Polynomial.natDegree_map_eq_of_injective Int.cast_injective P
+  have hcoeff := coeff_aeval_jq_neg (P.map (Int.castRingHom ℚ)) (m := P.natDegree) hQdeg.le
+  rw [← evalAtJ_eq_aeval_map_rat, h P.natDegree hle, Polynomial.coeff_map,
+    eq_intCast] at hcoeff
+  have hlead : P.coeff P.natDegree = 0 := by exact_mod_cast hcoeff.symm
+  exact hP0 (Polynomial.leadingCoeff_eq_zero.mp hlead)
+
+private theorem monic_of_evalAtJ_coeff_eq_one {P : Polynomial ℤ} {D : ℕ}
+    (hle : P.natDegree ≤ D) (h1 : (evalAtJ P).coeff (-(D : ℤ)) = 1) :
+    P.Monic ∧ P.natDegree = D := by
+  have hQdeg : (P.map (Int.castRingHom ℚ)).natDegree = P.natDegree :=
+    Polynomial.natDegree_map_eq_of_injective Int.cast_injective P
+  have hcoeff := coeff_aeval_jq_neg (P.map (Int.castRingHom ℚ)) (m := D) (hQdeg.le.trans hle)
+  rw [← evalAtJ_eq_aeval_map_rat, h1, Polynomial.coeff_map, eq_intCast] at hcoeff
+  have hPD : P.coeff D = 1 := by exact_mod_cast hcoeff.symm
+  have hge : D ≤ P.natDegree :=
+    Polynomial.le_natDegree_of_ne_zero (by rw [hPD]; exact one_ne_zero)
+  exact ⟨Polynomial.monic_of_natDegree_le_of_coeff_eq_one D hle hPD, le_antisymm hle hge⟩
+
+private theorem natDegree_le_of_evalAtJ_coeff_eq_zero {P : Polynomial ℤ} {D : ℕ}
+    (h : ∀ m : ℕ, D < m → (evalAtJ P).coeff (-(m : ℤ)) = 0) :
+    P.natDegree ≤ D := by
+  rcases eq_or_ne P 0 with rfl | hP0
+  · simp
+  by_contra hlt
+  rw [not_le] at hlt
+  have hdeg := degree_lt_of_evalAtJ_coeff_eq_zero (P := P) (D := D + 1)
+    (fun m hm => h m (by omega))
+  rw [← Polynomial.natDegree_lt_iff_degree_lt hP0] at hdeg
+  omega
+
+end Dictionary
+
+namespace ModularPolynomialData
+p2m_export "ModularCurve.ModularPolynomialData" "toAdjoin toAdjoin_monic monic eval_eq_zero \
+  natDegree_eq Φ"
+p2m_open "ModularCurve.ModularPolynomialData"
+
+variable {N : ℕ} [NeZero N] (data : ModularPolynomialData N)
+
+private theorem _root_.ModularCurve.ModularPolynomialData.transposeToAdjoin_monic_of_coeff_bounds
+    (h0 : (data.Φ.coeff 0).Monic) (h0deg : (data.Φ.coeff 0).natDegree = dedekindPsi N)
+    (hk : ∀ k, k ≠ 0 → (data.Φ.coeff k).degree < (dedekindPsi N : WithBot ℕ)) :
+    ((swapBivar data.Φ).map evalAtJGen).Monic ∧
+      ((swapBivar data.Φ).map evalAtJGen).natDegree = dedekindPsi N := by
+  obtain ⟨hmonic, hdeg⟩ := swapBivar_monic_of_coeff_bounds h0 h0deg hk
+  exact ⟨hmonic.map _, by rw [hmonic.natDegree_map, hdeg]⟩
+
+p2m_export "ModularCurve.ModularPolynomialData" "transposeToAdjoin_monic_of_coeff_bounds"
+
+private theorem transposeToAdjoin_monic_of_qExpansion
+    (h0top : (evalAtJ (data.Φ.coeff 0)).coeff (-(dedekindPsi N : ℤ)) = 1)
+    (h0le : ∀ m : ℕ, dedekindPsi N < m → (evalAtJ (data.Φ.coeff 0)).coeff (-(m : ℤ)) = 0)
+    (hk : ∀ k, k ≠ 0 → ∀ m : ℕ, dedekindPsi N ≤ m →
+      (evalAtJ (data.Φ.coeff k)).coeff (-(m : ℤ)) = 0) :
+    ((swapBivar data.Φ).map evalAtJGen).Monic ∧
+      ((swapBivar data.Φ).map evalAtJGen).natDegree = dedekindPsi N := by
+  obtain ⟨h0monic, h0deg⟩ := monic_of_evalAtJ_coeff_eq_one
+    (natDegree_le_of_evalAtJ_coeff_eq_zero h0le) h0top
+  exact data.transposeToAdjoin_monic_of_coeff_bounds h0monic h0deg
+    fun k hk0 => degree_lt_of_evalAtJ_coeff_eq_zero (hk k hk0)
+
+end ModularPolynomialData
+
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd phiProd_eval_conj"
+p2m_open "ModularCurve.PhiGen"
+
+section Swap
+
+variable {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+theorem eval_swap_eq_zero_of_splits (data : ModularPolynomialData ℓ)
+    (hsplit : data.Φ.map (((coeffEmb K).comp (qExpand ℚ ℓ)).comp evalAtJ)
+      = phiProd ℓ (conj ℓ ζ)) :
+    data.Φ.eval₂ (evalAtJqN ℓ) jq = 0 := by
+  rw [coeffEmb_comp_qExpand_comp_evalAtJ K ℓ] at hsplit
+  have h1 : data.Φ.eval₂ ((qEmbedT K ℓ).comp evalAtJ) (coeffEmb K jq) = 0 := by
+    rw [← Polynomial.eval_map, hsplit, ← conj_succ_zero K ℓ ζ, phiProd,
+      Polynomial.eval_prod]
+    exact Finset.prod_eq_zero (Finset.mem_univ ((0 : Fin ℓ).succ)) (by simp)
+  have h2 : data.Φ.eval₂ ((qExpand K ℓ).comp ((qEmbedT K ℓ).comp evalAtJ))
+      (qExpand K ℓ (coeffEmb K jq)) = 0 := by
+    have h := congrArg (qExpand K ℓ) h1
+    rwa [Polynomial.hom_eval₂, map_zero] at h
+  apply qEmbedT_injective K ℓ
+  rw [map_zero, Polynomial.hom_eval₂, qEmbedT_jq]
+  have hhom : (qEmbedT K ℓ).comp (evalAtJqN ℓ)
+      = (qExpand K ℓ).comp ((qEmbedT K ℓ).comp evalAtJ) := by
+    refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+    change qEmbedT K ℓ (evalAtJqN ℓ Polynomial.X)
+      = qExpand K ℓ (qEmbedT K ℓ (evalAtJ Polynomial.X))
+    rw [evalAtJqN_X, evalAtJ_X, qEmbedT_jq, qEmbedT_jqN K ℓ ζ, conj_zero, qExpand_qExpand]
+  rw [hhom]
+  exact h2
+
+theorem evalSymm_of_splits
+    (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (data : ModularPolynomialData ℓ)
+    (hsplit : data.Φ.map (((coeffEmb K).comp (qExpand ℚ ℓ)).comp evalAtJ)
+      = phiProd ℓ (conj ℓ ζ))
+    (hTmonic : ((swapBivar data.Φ).map evalAtJGen).Monic)
+    (hTdeg : ((swapBivar data.Φ).map evalAtJGen).natDegree ≤ dedekindPsi ℓ) :
+    EvalSymm data.Φ :=
+  data.evalSymm_of_irreducible (phiIrreducible_of_splits ℓ ζ hpos hζ data hsplit)
+    (eval_swap_eq_zero_of_splits ℓ ζ data hsplit) hTmonic hTdeg
+
+end Swap
+
+end PhiGen
+
+end ModularCurve
+end
+
+
+open _root_.ModularCurve
+  _root_.P2MW.S_OVERLONG_45c886fb.ModularCurve
+  _root_.ModularCurve.PhiGen
+  _root_.P2MW.S_OVERLONG_45c886fb.ModularCurve.PhiGen
+  in
+theorem solution {N : ℕ} [NeZero N] (data : ModularPolynomialData N)
+    (h0top : (evalAtJ (data.Φ.coeff 0)).coeff (-(dedekindPsi N : ℤ)) = 1)
+    (h0le : ∀ m : ℕ, dedekindPsi N < m → (evalAtJ (data.Φ.coeff 0)).coeff (-(m : ℤ)) = 0)
+    (hk : ∀ k, k ≠ 0 → ∀ m : ℕ, dedekindPsi N ≤ m → (evalAtJ (data.Φ.coeff k)).coeff (-(m : ℤ)) = 0)
+    :
+    ((swapBivar data.Φ).map evalAtJGen).Monic ∧ ((swapBivar data.Φ).map evalAtJGen).natDegree =
+      dedekindPsi N :=
+  ModularCurve.ModularPolynomialData.transposeToAdjoin_monic_of_qExpansion data h0top h0le hk
+
+end S_OVERLONG_45c886fb
+end P2MW
+export P2MW.S_OVERLONG_45c886fb (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.ModularPolynomialData.transposeToAdjoin_monic_of_qExpansion {N : ℕ} [NeZero N]
+    (data : ModularPolynomialData N)
+    (h0top : (evalAtJ (data.Φ.coeff 0)).coeff (-(dedekindPsi N : ℤ)) = 1)
+    (h0le : ∀ m : ℕ, dedekindPsi N < m → (evalAtJ (data.Φ.coeff 0)).coeff (-(m : ℤ)) = 0)
+    (hk : ∀ k, k ≠ 0 → ∀ m : ℕ, dedekindPsi N ≤ m → (evalAtJ (data.Φ.coeff k)).coeff (-(m : ℤ)) = 0)
+    :
+    ((swapBivar data.Φ).map evalAtJGen).Monic ∧ ((swapBivar data.Φ).map evalAtJGen).natDegree =
+      dedekindPsi N :=
+  solution data h0top h0le hk
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_Period_existsUnique_isParabolicHom_sup_zpowers_neg_one_apply_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_Period_existsUnique_isParabolicHom_sup_zpowers_neg_one_apply_eq.lean
new file mode 100644
index 0000000000..f82307366a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_Period_existsUnique_isParabolicHom_sup_zpowers_neg_one_apply_eq.lean
@@ -0,0 +1,250 @@
+/-
+Based on Prove2Me node ModularCurve.Period.existsUnique_isParabolicHom_sup_zpowers_neg_one_apply_eq
+(c2d4705b-da14-5756-838c-dc8765afc682) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2c3bf78f-e9c1-5ebb-8b95-4b6bac3b5e01
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodMap
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Unique parabolic extension of a character across -1
+
+Theorem statement: `ModularCurve.Period.existsUnique_isParabolicHom_sup_zpowers_neg_one_apply_eq`
+(`c2d4705b-da14-5756-838c-dc8765afc682`), by Claude, 2026-09-05.
+
+Proof: submission `2c3bf78f-e9c1-5ebb-8b95-4b6bac3b5e01`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of $\mathrm{SL}_2(\mathbb{Z})$, let $A$ be an additive abelian group, and
+let $\psi$ be an additive homomorphism from $\Gamma$, regarded as an additive group via `Additive`,
+to $A$ (equivalently, a homomorphism of groups $\Gamma \to A$). Assume $\psi$ is parabolic in the
+sense of the predicate [`ModularCurve.Period.IsParabolicHom`](def/ModularCurve_PeriodMap.html#L15):
+for every $\gamma \in \Gamma$ whose underlying integer matrix satisfies $(\operatorname{tr}\gamma)^2
+= 4$, one has $\psi(\gamma) = 0$. Write $\Gamma \sqcup \langle -1\rangle$ for the subgroup of
+$\mathrm{SL}_2(\mathbb{Z})$ generated by $\Gamma$ together with the integer powers of $-1$. The
+assertion is that there is exactly one additive homomorphism $\varphi$ from $\Gamma \sqcup \langle
+-1 \rangle$ (again viewed additively) to $A$ with the two properties: $\varphi$ is parabolic, i.e.
+$\varphi(\delta) = 0$ for every $\delta$ in $\Gamma \sqcup \langle -1 \rangle$ with
+$(\operatorname{tr}\delta)^2 = 4$; and $\varphi$ restricts to $\psi$ along the inclusion, i.e.
+$\varphi(\gamma) = \psi(\gamma)$ for every $\gamma \in \Gamma$, where on the left $\gamma$ is viewed
+as an element of the larger subgroup.
+
+This says that parabolic characters do not see the centre: restriction along $\Gamma \hookrightarrow
+\pm\Gamma$ is a bijection between the parabolic characters of $\pm\Gamma$ and those of $\Gamma$,
+which permits period computations to be carried out on the subgroup generated by $\Gamma$ and $-1$.
+It is used in the comparison of cup pairings under conjugation
+([`ModularCurve.CupPairing.pair_comp_eq_of_conjRel`]
+(thm.html#ModularCurve.CupPairing.pair_comp_eq_of_conjRel))
+and in the rank formula
+[`ModularCurve.six_mul_level_mul_finrank_parabolicHoms_Gamma_add_eq`]
+(thm.html#ModularCurve.six_mul_level_mul_finrank_parabolicHoms_Gamma_add_eq).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_Period_existsUnique_isParabolicHom_sup_zpowers_neg_one_apply_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_Period_existsUnique_isParabolicHom_sup_zpowers_neg_one_apply_eq
+
+open scoped MatrixGroups
+
+namespace ParabolicPlusMinus
+
+open ModularCurve.Period
+
+variable (Γ : Subgroup SL(2, ℤ))
+
+abbrev pm : Subgroup SL(2, ℤ) := Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))
+
+theorem neg_one_mem_pm : (-1 : SL(2, ℤ)) ∈ pm Γ :=
+  Subgroup.mem_sup_right (Subgroup.mem_zpowers _)
+
+theorem mem_pm_of_mem {g : SL(2, ℤ)} (hg : g ∈ Γ) : g ∈ pm Γ := Subgroup.mem_sup_left hg
+
+scoped instance zpowers_neg_one_normal : (Subgroup.zpowers (-1 : SL(2, ℤ))).Normal :=
+  ⟨fun n hn g => by
+    obtain ⟨k, rfl⟩ := Subgroup.mem_zpowers_iff.mp hn
+    have hc : Commute g ((-1 : SL(2, ℤ)) ^ k) := (Commute.neg_one_right g).zpow_right k
+    rw [hc.eq, mul_inv_cancel_right]
+    exact Subgroup.zpow_mem _ (Subgroup.mem_zpowers _) k⟩
+
+theorem exists_of_mem_pm {g : SL(2, ℤ)} (hg : g ∈ pm Γ) :
+    ∃ γ : SL(2, ℤ), γ ∈ Γ ∧ (g = γ ∨ g = -γ) := by
+  obtain ⟨y, hy, z, hz, rfl⟩ := Subgroup.mem_sup_of_normal_right.mp hg
+  obtain ⟨k, rfl⟩ := Subgroup.mem_zpowers_iff.mp hz
+  refine ⟨y, hy, ?_⟩
+  rcases Int.even_or_odd k with ⟨m, rfl⟩ | ⟨m, rfl⟩
+  · left
+    have : ((-1 : SL(2, ℤ)) ^ (2 : ℤ)) = 1 := by rw [zpow_two]; simp
+    rw [← two_mul, zpow_mul, this, one_zpow, mul_one]
+  · right
+    have : ((-1 : SL(2, ℤ)) ^ (2 : ℤ)) = 1 := by rw [zpow_two]; simp
+    rw [zpow_add, zpow_mul, this, one_zpow, one_mul, zpow_one, mul_neg_one]
+
+theorem trace_neg_sq (γ : SL(2, ℤ)) :
+    (((-γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace) ^ 2 =
+      ((γ : Matrix (Fin 2) (Fin 2) ℤ).trace) ^ 2 := by
+  rw [Matrix.SpecialLinearGroup.coe_neg, Matrix.trace_neg, neg_sq]
+
+theorem trace_neg_one_sq : (((-1 : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace) ^ 2 = 4 := by
+  rw [trace_neg_sq]; simp
+
+variable {Γ}
+variable {A : Type*} [AddCommGroup A] (ψ : Additive Γ →+ A) (hψ : IsParabolicHom Γ ψ)
+
+include hψ in
+theorem apply_neg_one (h : (-1 : SL(2, ℤ)) ∈ Γ) : ψ (Additive.ofMul ⟨-1, h⟩) = 0 :=
+  hψ ⟨-1, h⟩ trace_neg_one_sq
+
+include hψ in
+theorem apply_eq_of_eq_or_eq_neg {γ δ : SL(2, ℤ)} (hγ : γ ∈ Γ) (hδ : δ ∈ Γ)
+    (h : γ = δ ∨ γ = -δ) : ψ (Additive.ofMul ⟨γ, hγ⟩) = ψ (Additive.ofMul ⟨δ, hδ⟩) := by
+  rcases h with rfl | rfl
+  · rfl
+  · have hm : (-1 : SL(2, ℤ)) ∈ Γ := by
+      have := Γ.mul_mem hγ (Γ.inv_mem hδ)
+      simpa using this
+    have hprod : (⟨-δ, hγ⟩ : Γ) = ⟨-1, hm⟩ * ⟨δ, hδ⟩ := Subtype.ext (by simp)
+    rw [hprod, ofMul_mul, map_add, apply_neg_one ψ hψ hm, zero_add]
+
+noncomputable def rep (g : pm Γ) : SL(2, ℤ) := (exists_of_mem_pm Γ g.2).choose
+
+theorem rep_mem (g : pm Γ) : rep g ∈ Γ := (exists_of_mem_pm Γ g.2).choose_spec.1
+
+theorem eq_or_eq_neg_rep (g : pm Γ) : (g : SL(2, ℤ)) = rep g ∨ (g : SL(2, ℤ)) = -rep g :=
+  (exists_of_mem_pm Γ g.2).choose_spec.2
+
+noncomputable def extFun (g : pm Γ) : A := ψ (Additive.ofMul ⟨rep g, rep_mem g⟩)
+
+include hψ in
+theorem extFun_eq (g : pm Γ) {γ : SL(2, ℤ)} (hγ : γ ∈ Γ)
+    (h : (g : SL(2, ℤ)) = γ ∨ (g : SL(2, ℤ)) = -γ) : extFun ψ g = ψ (Additive.ofMul ⟨γ, hγ⟩) := by
+  unfold extFun
+  apply apply_eq_of_eq_or_eq_neg ψ hψ
+  rcases eq_or_eq_neg_rep g with h1 | h1 <;> rcases h with h2 | h2
+  · exact Or.inl (h1.symm.trans h2)
+  · exact Or.inr (h1.symm.trans h2)
+  · exact Or.inr (by rw [← neg_eq_iff_eq_neg.mpr h1, h2])
+  · exact Or.inl (by have := h1.symm.trans h2; exact neg_injective this)
+
+private noncomputable def _root_.ParabolicPlusMinus.ext : Additive (pm Γ) →+ A where
+  toFun g := extFun ψ (Additive.toMul g)
+  map_zero' := by
+    change extFun ψ (1 : pm Γ) = 0
+    rw [extFun_eq ψ hψ (1 : pm Γ) Γ.one_mem (Or.inl rfl)]
+    exact map_zero ψ
+  map_add' x y := by
+    change extFun ψ (Additive.toMul x * Additive.toMul y) = extFun ψ (Additive.toMul x) + extFun ψ
+      (Additive.toMul y)
+    set g := Additive.toMul x
+    set g' := Additive.toMul y
+    have hgg : ((g * g' : pm Γ) : SL(2, ℤ)) = rep g * rep g' ∨
+        ((g * g' : pm Γ) : SL(2, ℤ)) = -(rep g * rep g') := by
+      rw [Subgroup.coe_mul]
+      rcases eq_or_eq_neg_rep g with h1 | h1 <;> rcases eq_or_eq_neg_rep g' with h2 | h2 <;>
+        rw [h1, h2]
+      · exact Or.inl rfl
+      · exact Or.inr (by simp)
+      · exact Or.inr (by simp)
+      · exact Or.inl (by simp)
+    rw [extFun_eq ψ hψ (g * g') (Γ.mul_mem (rep_mem g) (rep_mem g')) hgg]
+    have : (⟨rep g * rep g', Γ.mul_mem (rep_mem g) (rep_mem g')⟩ : Γ) =
+        ⟨rep g, rep_mem g⟩ * ⟨rep g', rep_mem g'⟩ := rfl
+    rw [this, ofMul_mul, map_add]
+    rfl
+
+p2m_export "ParabolicPlusMinus" "ext"
+theorem ext_apply_of_mem (γ : Γ) :
+    ext ψ hψ (Additive.ofMul ⟨(γ : SL(2, ℤ)), mem_pm_of_mem Γ γ.2⟩) = ψ (Additive.ofMul γ) :=
+  extFun_eq ψ hψ _ γ.2 (Or.inl rfl)
+
+theorem isParabolicHom_ext : IsParabolicHom (pm Γ) (ext ψ hψ) := by
+  intro g hg
+  change extFun ψ g = 0
+  rw [extFun]
+  apply hψ
+  rcases eq_or_eq_neg_rep g with h | h
+  · simpa [h] using hg
+  · have : ((g : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace ^ 2 =
+        ((rep g : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace ^ 2 := by
+      rw [h, trace_neg_sq]
+    rw [← this]; exact hg
+
+theorem unique_ext (φ : Additive (pm Γ) →+ A) (hφ : IsParabolicHom (pm Γ) φ)
+    (hφψ : ∀ γ : Γ, φ (Additive.ofMul ⟨(γ : SL(2, ℤ)), mem_pm_of_mem Γ γ.2⟩) = ψ (Additive.ofMul γ))
+      :
+    φ = ext ψ hψ := by
+  ext x
+  set g := Additive.toMul x
+  change φ (Additive.ofMul g) = ext ψ hψ (Additive.ofMul g)
+  have hm1 : φ (Additive.ofMul ⟨-1, neg_one_mem_pm Γ⟩) = 0 :=
+    hφ ⟨-1, neg_one_mem_pm Γ⟩ trace_neg_one_sq
+  rcases eq_or_eq_neg_rep g with h | h
+  · have hg : g = ⟨rep g, mem_pm_of_mem Γ (rep_mem g)⟩ := Subtype.ext h
+    rw [hg, hφψ ⟨rep g, rep_mem g⟩]
+    exact (extFun_eq ψ hψ (⟨rep g, mem_pm_of_mem Γ (rep_mem g)⟩ : pm Γ) (rep_mem g) (Or.inl
+      rfl)).symm
+  · have hg : g = ⟨-1, neg_one_mem_pm Γ⟩ * ⟨rep g, mem_pm_of_mem Γ (rep_mem g)⟩ :=
+      Subtype.ext (by rw [h]; simp)
+    rw [hg, ofMul_mul, map_add, map_add, hm1, zero_add, hφψ ⟨rep g, rep_mem g⟩]
+    have e1 : ext ψ hψ (Additive.ofMul (⟨rep g, mem_pm_of_mem Γ (rep_mem g)⟩ : pm Γ)) =
+        ψ (Additive.ofMul ⟨rep g, rep_mem g⟩) :=
+      extFun_eq ψ hψ (⟨rep g, mem_pm_of_mem Γ (rep_mem g)⟩ : pm Γ) (rep_mem g) (Or.inl rfl)
+    have e2 : ext ψ hψ (Additive.ofMul (⟨-1, neg_one_mem_pm Γ⟩ : pm Γ)) = ψ (Additive.ofMul ⟨1,
+      Γ.one_mem⟩) :=
+      extFun_eq ψ hψ (⟨-1, neg_one_mem_pm Γ⟩ : pm Γ) Γ.one_mem (Or.inr (by simp))
+    rw [e1, e2]
+    have : (⟨1, Γ.one_mem⟩ : Γ) = 1 := rfl
+    rw [this, ofMul_one, map_zero, zero_add]
+
+end ParabolicPlusMinus
+
+theorem solution
+    (Γ : Subgroup SL(2, ℤ)) (A : Type*) [AddCommGroup A]
+    (ψ : Additive Γ →+ A) (hψ : ModularCurve.Period.IsParabolicHom Γ ψ) :
+    ∃! φ : Additive ↥(Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))) →+ A,
+      ModularCurve.Period.IsParabolicHom (Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))) φ ∧
+        ∀ γ : Γ, φ (Additive.ofMul ⟨(γ : SL(2, ℤ)), Subgroup.mem_sup_left γ.2⟩) = ψ (Additive.ofMul
+          γ) := by
+  refine ⟨ParabolicPlusMinus.ext ψ hψ, ⟨ParabolicPlusMinus.isParabolicHom_ext ψ hψ,
+    ParabolicPlusMinus.ext_apply_of_mem ψ hψ⟩, ?_⟩
+  rintro φ ⟨hφ, hφψ⟩
+  exact ParabolicPlusMinus.unique_ext ψ hψ φ hφ hφψ
+
+end S_ModularCurve_Period_existsUnique_isParabolicHom_sup_zpowers_neg_one_apply_eq
+end P2MW
+export P2MW.S_ModularCurve_Period_existsUnique_isParabolicHom_sup_zpowers_neg_one_apply_eq
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.Period.existsUnique_isParabolicHom_sup_zpowers_neg_one_apply_eq
+    (Γ : Subgroup SL(2, ℤ)) (A : Type*) [AddCommGroup A]
+    (ψ : Additive Γ →+ A) (hψ : ModularCurve.Period.IsParabolicHom Γ ψ) :
+    ∃! φ : Additive ↥(Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))) →+ A,
+      ModularCurve.Period.IsParabolicHom (Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))) φ ∧
+        ∀ γ : Γ, φ (Additive.ofMul ⟨(γ : SL(2, ℤ)), Subgroup.mem_sup_left γ.2⟩) = ψ (Additive.ofMul
+          γ) :=
+  solution Γ A ψ hψ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_Period_exists_basis_parabolicHoms_castAddHom_comp.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_Period_exists_basis_parabolicHoms_castAddHom_comp.lean
new file mode 100644
index 0000000000..97142bd869
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_Period_exists_basis_parabolicHoms_castAddHom_comp.lean
@@ -0,0 +1,592 @@
+/-
+Based on Prove2Me node ModularCurve.Period.exists_basis_parabolicHoms_castAddHom_comp
+(63e31f11-3de3-5c5d-846a-f1f14017a610) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 462dd42a-1fbd-5fe9-a0e7-2bf863a49563
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodMap
+public import Mathlib.LinearAlgebra.Basis.Defs
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Matrix_SpecialLinearGroup_exists_generators_free_mod_neg_one_of_forall_trace_ne
+import Mathlib.LinearAlgebra.Basis.Basic
+import Mathlib.GroupTheory.Schreier
+import Mathlib.GroupTheory.FreeGroup.Basic
+import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+import Mathlib.LinearAlgebra.FreeModule.PID
+import Mathlib.LinearAlgebra.Dimension.Free
+import Mathlib.LinearAlgebra.Finsupp.LinearCombination
+import Mathlib.Algebra.Module.Torsion.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# An integral basis of parabolic characters survives base change
+
+Theorem statement: `ModularCurve.Period.exists_basis_parabolicHoms_castAddHom_comp`
+(`63e31f11-3de3-5c5d-846a-f1f14017a610`), by Claude, 2026-09-05.
+
+Proof: submission `462dd42a-1fbd-5fe9-a0e7-2bf863a49563`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of $\mathrm{SL}(2,\mathbb{Z})$ of finite index. For a commutative
+coefficient setup, [`ModularCurve.Period.parabolicHoms R Γ A`](def/ModularCurve_PeriodMap.html#L62)
+denotes the $R$-submodule of the additive homomorphisms $\mathrm{Additive}\,\Gamma \to A$ consisting
+of those $\varphi$ that vanish on every $\gamma \in \Gamma$ whose underlying integral matrix has
+$(\operatorname{tr}\gamma)^2 = 4$, i.e. trace $\pm 2$. The assertion is that there exist a natural
+number $n$ and a $\mathbb{Z}$-basis $b$, indexed by $\mathrm{Fin}\,n$, of `parabolicHoms ℤ Γ ℤ` —
+the group of homomorphisms $\Gamma \to \mathbb{Z}$ killing all elements of trace $\pm 2$ — with the
+following property: for every field $K$ of characteristic zero, in any universe, there is a
+$K$-basis $b^K$, again indexed by $\mathrm{Fin}\,n$, of `parabolicHoms K Γ K`, such that for each
+index $i$ the underlying additive homomorphism $\mathrm{Additive}\,\Gamma \to K$ of $b^K_i$ equals
+the composite of $b_i$ with the canonical additive map $\mathbb{Z} \to K$. In particular the
+$K$-dimension of the space of parabolic characters with values in $K$ equals $n$ for every such $K$.
+
+This records that the parabolic characters of a finite-index subgroup of $\mathrm{SL}(2,\mathbb{Z})$
+form a free abelian group of finite rank whose dual basis remains a basis after any base change to a
+field of characteristic zero, the torsion of the parabolic quotient of $\Gamma^{\mathrm{ab}}$ being
+invisible to torsion-free targets. It provides the uniform rank used in the Eichler–Shimura
+comparison for the relevant congruence subgroups and in the construction of the Hecke action on
+parabolic cohomology.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_Period_exists_basis_parabolicHoms_castAddHom_comp.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_Period_exists_basis_parabolicHoms_castAddHom_comp
+
+open scoped MatrixGroups
+
+namespace DeskWA_D3
+namespace L2
+
+private theorem neg_one_mem_Gamma_two : (-1 : SL(2, ℤ)) ∈ CongruenceSubgroup.Gamma 2 := by
+  rw [CongruenceSubgroup.Gamma_mem]
+  simp only [Matrix.SpecialLinearGroup.coe_neg, Matrix.SpecialLinearGroup.coe_one,
+    Matrix.neg_apply, Matrix.one_apply_eq, ne_eq, zero_ne_one, not_false_eq_true,
+    Matrix.one_apply_ne, one_ne_zero, neg_zero, Int.cast_zero, Int.cast_neg, Int.cast_one]
+  decide
+
+private theorem trace_ne_of_mem_Gamma_two {γ : SL(2, ℤ)} (h : γ ∈ CongruenceSubgroup.Gamma 2) :
+    (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 0 ∧ (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 1 ∧
+      (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ -1 := by
+  rw [CongruenceSubgroup.Gamma_mem] at h
+  obtain ⟨ha, hb, hc, hd⟩ := h
+  have hdet := Matrix.SpecialLinearGroup.det_coe γ
+  rw [Matrix.det_fin_two] at hdet
+  rw [Matrix.trace_fin_two]
+  have dvd_of_one : ∀ x : ℤ, (x : ZMod 2) = 1 → (2 : ℤ) ∣ x - 1 := fun x hx =>
+    (ZMod.intCast_zmod_eq_zero_iff_dvd (x - 1) 2).1 (by rw [Int.cast_sub, Int.cast_one, hx,
+      sub_self])
+  have dvd_of_zero : ∀ x : ℤ, (x : ZMod 2) = 0 → (2 : ℤ) ∣ x := fun x hx =>
+    (ZMod.intCast_zmod_eq_zero_iff_dvd x 2).1 hx
+  obtain ⟨a', ha'⟩ := dvd_of_one _ ha
+  obtain ⟨b', hb'⟩ := dvd_of_zero _ hb
+  obtain ⟨c', hc'⟩ := dvd_of_zero _ hc
+  obtain ⟨d', hd'⟩ := dvd_of_one _ hd
+  refine ⟨?_, ?_, ?_⟩ <;> intro htr
+  · have h11 : (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 1 = -(2 * a' + 1) := by omega
+    have h00 : (γ : Matrix (Fin 2) (Fin 2) ℤ) 0 0 = 2 * a' + 1 := by omega
+    rw [h00, h11, hb', hc'] at hdet
+    have key : (4 : ℤ) * (a' * a' + a' + b' * c') = -2 := by linear_combination (-1 : ℤ) * hdet
+    generalize a' * a' + a' + b' * c' = X at key
+    omega
+  · omega
+  · omega
+
+private theorem fg_of_fg_finiteIndex {G : Type*} [Group G] (H : Subgroup G) [H.FiniteIndex]
+    [hH : Group.FG H] : Group.FG G := by
+  classical
+  obtain ⟨S, hS, hSfin⟩ := Group.fg_iff.1 hH
+  rw [Group.fg_iff]
+  refine ⟨(Subtype.val '' S) ∪ Set.range (fun q : G ⧸ H => q.out), ?_,
+    (hSfin.image _).union (Set.finite_range _)⟩
+  rw [eq_top_iff]
+  rintro x -
+  obtain ⟨h, hh⟩ := QuotientGroup.mk_out_eq_mul H x
+  have hx : x = (QuotientGroup.mk (s := H) x).out * (h : G)⁻¹ := by
+    rw [hh, mul_inv_cancel_right]
+  rw [hx]
+  refine Subgroup.mul_mem _ (Subgroup.subset_closure (Or.inr ⟨_, rfl⟩)) (Subgroup.inv_mem _ ?_)
+  have hmem : (h : G) ∈ (Subgroup.closure S).map H.subtype := by
+    rw [hS]; exact ⟨h, trivial, rfl⟩
+  rw [MonoidHom.map_closure] at hmem
+  exact Subgroup.closure_mono Set.subset_union_left hmem
+
+private theorem fg_Gamma_two : Group.FG (CongruenceSubgroup.Gamma 2) := by
+  obtain ⟨gens, hcl, -⟩ :=
+    Matrix.SpecialLinearGroup.exists_generators_free_mod_neg_one_of_forall_trace_ne
+      (CongruenceSubgroup.Gamma 2) neg_one_mem_Gamma_two (fun γ hγ => trace_ne_of_mem_Gamma_two hγ)
+  rw [Group.fg_iff]
+  exact ⟨_, hcl, (Set.finite_range gens).union (Set.finite_singleton _)⟩
+
+private theorem fg_SL2Z : Group.FG SL(2, ℤ) :=
+  haveI := fg_Gamma_two
+  fg_of_fg_finiteIndex (CongruenceSubgroup.Gamma 2)
+
+private theorem fg_of_finiteIndex (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] : Group.FG Γ :=
+  haveI := fg_SL2Z
+  Subgroup.fg_of_index_ne_zero Γ
+
+private theorem exists_generators (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] :
+    ∃ (n : ℕ) (g : Fin n → Γ), Subgroup.closure (Set.range g) = ⊤ := by
+  obtain ⟨n, S, -, hS⟩ := Group.fg_iff'.1 (fg_of_finiteIndex Γ)
+  refine ⟨S.card, Subtype.val ∘ S.equivFin.symm, ?_⟩
+  rw [Set.range_comp, Equiv.range_eq_univ, Set.image_univ, Subtype.range_coe_subtype]
+  exact hS
+
+section Presentation
+
+variable {Γ : Subgroup SL(2, ℤ)} {n : ℕ} (g : Fin n → Γ)
+
+private def π : FreeGroup (Fin n) →* Γ := FreeGroup.lift g
+
+private theorem π_surjective (hg : Subgroup.closure (Set.range g) = ⊤) :
+    Function.Surjective (π g) := by
+  rw [← MonoidHom.range_eq_top, π, FreeGroup.range_lift_eq_closure, hg]
+
+private def abHom : FreeGroup (Fin n) →* Multiplicative (Fin n → ℤ) :=
+  FreeGroup.lift fun i => Multiplicative.ofAdd (Pi.single i 1)
+
+private def ab (w : FreeGroup (Fin n)) : Fin n → ℤ := Multiplicative.toAdd (abHom w)
+
+private theorem ab_of (i : Fin n) : ab (FreeGroup.of i) = Pi.single i 1 := by
+  simp [ab, abHom]
+
+variable {A : Type*} [AddCommGroup A]
+
+private def pair (c : Fin n → ℤ) (z : Fin n → A) : A := ∑ i, c i • z i
+
+private theorem pair_eq_linearCombination (c : Fin n → ℤ) (z : Fin n → A) :
+    pair c z = Fintype.linearCombination ℤ z c := by
+  rw [Fintype.linearCombination_apply]; rfl
+
+private theorem pair_add_left (c c' : Fin n → ℤ) (z : Fin n → A) :
+    pair (c + c') z = pair c z + pair c' z := by
+  simp only [pair_eq_linearCombination, map_add]
+
+private theorem pair_smul_left (k : ℤ) (c : Fin n → ℤ) (z : Fin n → A) :
+    pair (k • c) z = k • pair c z := by
+  simp only [pair_eq_linearCombination, map_zsmul]
+
+private theorem pair_zero_left (z : Fin n → A) : pair (0 : Fin n → ℤ) z = 0 := by
+  simp only [pair_eq_linearCombination, map_zero]
+
+private theorem pair_single (i : Fin n) (z : Fin n → A) : pair (Pi.single i 1) z = z i := by
+  classical
+  simp [pair, Pi.single_apply]
+
+private theorem pair_map {B : Type*} [AddCommGroup B] (f : A →+ B) (c : Fin n → ℤ) (z : Fin n → A) :
+    f (pair c z) = pair c (f ∘ z) := by
+  simp [pair, map_sum, map_zsmul]
+
+private def pairHom (z : Fin n → A) : (Fin n → ℤ) →+ A where
+  toFun c := pair c z
+  map_zero' := pair_zero_left z
+  map_add' c c' := pair_add_left c c' z
+
+private def Lz (z : Fin n → A) : FreeGroup (Fin n) →* Multiplicative A :=
+  FreeGroup.lift fun i => Multiplicative.ofAdd (z i)
+
+private theorem toAdd_Lz (z : Fin n → A) (w : FreeGroup (Fin n)) :
+    Multiplicative.toAdd (Lz z w) = pair (ab w) z := by
+  have key : Lz z = (AddMonoidHom.toMultiplicative (pairHom z)).comp abHom := by
+    refine FreeGroup.ext_hom _ _ fun i => ?_
+    simp only [Lz, FreeGroup.lift_apply_of, MonoidHom.coe_comp, Function.comp_apply]
+    change Multiplicative.ofAdd (z i) = Multiplicative.ofAdd (pairHom z (ab (FreeGroup.of i)))
+    rw [ab_of]; change _ = Multiplicative.ofAdd (pair (Pi.single i 1) z); rw [pair_single]
+  rw [key]; rfl
+
+private theorem apply_π (φ : Additive Γ →+ A) (w : FreeGroup (Fin n)) :
+    φ (Additive.ofMul (π g w)) = pair (ab w) (fun i => φ (Additive.ofMul (g i))) := by
+  have key : (AddMonoidHom.toMultiplicativeRight φ).comp (π g)
+      = Lz (fun i => φ (Additive.ofMul (g i))) := by
+    refine FreeGroup.ext_hom _ _ fun i => ?_
+    simp only [MonoidHom.coe_comp, Function.comp_apply, π, FreeGroup.lift_apply_of, Lz]
+    rfl
+  have := congrArg (fun f => Multiplicative.toAdd (f w)) key
+  simp only [MonoidHom.coe_comp, Function.comp_apply] at this
+  rw [toAdd_Lz] at this
+  exact this
+
+private def IsPar (γ : Γ) : Prop := ((γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace ^ 2 = 4
+
+private theorem isPar_one : IsPar (1 : Γ) := by
+  simp [IsPar]
+
+private def R : Submodule ℤ (Fin n → ℤ) :=
+  Submodule.span ℤ {c | ∃ w, IsPar (π g w) ∧ ab w = c}
+
+private theorem ab_mem_R {w : FreeGroup (Fin n)} (hw : IsPar (π g w)) : ab w ∈ R g :=
+  Submodule.subset_span ⟨w, hw, rfl⟩
+
+private def ev (φ : Additive Γ →+ A) : Fin n → A := fun i => φ (Additive.ofMul (g i))
+
+private theorem ev_perp {φ : Additive Γ →+ A} (hφ : φ ∈ ModularCurve.Period.parabolicHoms ℤ Γ A) :
+    ∀ c ∈ R g, pair c (ev g φ) = 0 := by
+  intro c hc
+  induction hc using Submodule.span_induction with
+  | mem c hc =>
+    obtain ⟨w, hw, rfl⟩ := hc
+    change pair (ab w) (fun i => φ (Additive.ofMul (g i))) = 0
+    rw [← apply_π]; exact hφ _ hw
+  | zero => exact pair_zero_left _
+  | add c c' _ _ hc hc' => rw [pair_add_left, hc, hc', add_zero]
+  | smul k c _ hc => rw [pair_smul_left, hc, smul_zero]
+
+private theorem ev_injective (hg : Subgroup.closure (Set.range g) = ⊤) {φ ψ : Additive Γ →+ A}
+    (h : ev g φ = ev g ψ) : φ = ψ := by
+  have : AddMonoidHom.toMultiplicativeRight φ = AddMonoidHom.toMultiplicativeRight ψ := by
+    refine MonoidHom.eq_of_eqOn_dense hg ?_
+    rintro _ ⟨i, rfl⟩
+    exact congrArg Multiplicative.ofAdd (congrFun h i)
+  exact AddMonoidHom.toMultiplicativeRight.injective this
+
+variable {g}
+
+private theorem Lz_eq_one_of_mem_ker {z : Fin n → A} (hz : ∀ c ∈ R g, pair c z = 0)
+    {w : FreeGroup (Fin n)} (hw : w ∈ (π g).ker) : Lz z w = 1 := by
+  apply Multiplicative.toAdd.injective
+  rw [toAdd_Lz, toAdd_one]
+  refine hz _ (ab_mem_R g ?_)
+  rw [MonoidHom.mem_ker] at hw; rw [hw]; exact isPar_one
+
+private theorem Lz_eq_of_π_eq {z : Fin n → A} (hz : ∀ c ∈ R g, pair c z = 0)
+    {w₁ w₂ : FreeGroup (Fin n)} (h : π g w₁ = π g w₂) : Lz z w₁ = Lz z w₂ := by
+  have hk : w₁⁻¹ * w₂ ∈ (π g).ker := by
+    rw [MonoidHom.mem_ker, map_mul, map_inv, h, inv_mul_cancel]
+  have := Lz_eq_one_of_mem_ker hz hk
+  rw [map_mul, map_inv, inv_mul_eq_one] at this
+  exact this
+
+variable (g)
+
+private noncomputable def liftFun (hg : Subgroup.closure (Set.range g) = ⊤) (z : Fin n → A) (γ : Γ)
+    :
+    A :=
+  Multiplicative.toAdd (Lz z (Function.surjInv (π_surjective g hg) γ))
+
+private theorem liftFun_π (hg : Subgroup.closure (Set.range g) = ⊤) {z : Fin n → A}
+    (hz : ∀ c ∈ R g, pair c z = 0) (w : FreeGroup (Fin n)) :
+    liftFun g hg z (π g w) = pair (ab w) z := by
+  rw [liftFun, ← toAdd_Lz]
+  exact congrArg _ (Lz_eq_of_π_eq hz (Function.surjInv_eq (π_surjective g hg) _))
+
+private noncomputable def liftHom (hg : Subgroup.closure (Set.range g) = ⊤) (z : Fin n → A)
+    (hz : ∀ c ∈ R g, pair c z = 0) : Additive Γ →+ A where
+  toFun x := liftFun g hg z (Additive.toMul x)
+  map_zero' := by
+    change liftFun g hg z 1 = 0
+    rw [← map_one (π g), liftFun_π g hg hz, ← toAdd_Lz, map_one, toAdd_one]
+  map_add' x y := by
+    obtain ⟨w₁, h₁⟩ := π_surjective g hg (Additive.toMul x)
+    obtain ⟨w₂, h₂⟩ := π_surjective g hg (Additive.toMul y)
+    change liftFun g hg z (Additive.toMul x * Additive.toMul y) = _
+    rw [← h₁, ← h₂, ← map_mul, liftFun_π g hg hz, liftFun_π g hg hz, liftFun_π g hg hz,
+      ← toAdd_Lz, ← toAdd_Lz, ← toAdd_Lz, map_mul, toAdd_mul]
+
+private theorem liftHom_π (hg : Subgroup.closure (Set.range g) = ⊤) {z : Fin n → A}
+    (hz : ∀ c ∈ R g, pair c z = 0) (w : FreeGroup (Fin n)) :
+    liftHom g hg z hz (Additive.ofMul (π g w)) = pair (ab w) z :=
+  liftFun_π g hg hz w
+
+private theorem liftHom_mem (hg : Subgroup.closure (Set.range g) = ⊤) {z : Fin n → A}
+    (hz : ∀ c ∈ R g, pair c z = 0) : liftHom g hg z hz ∈ ModularCurve.Period.parabolicHoms ℤ Γ A :=
+      by
+  intro γ hγ
+  obtain ⟨w, rfl⟩ := π_surjective g hg γ
+  rw [liftHom_π]
+  exact hz _ (ab_mem_R g hγ)
+
+private theorem ev_liftHom (hg : Subgroup.closure (Set.range g) = ⊤) {z : Fin n → A}
+    (hz : ∀ c ∈ R g, pair c z = 0) : ev g (liftHom g hg z hz) = z := by
+  funext i
+  have := liftHom_π g hg hz (FreeGroup.of i)
+  rw [π, FreeGroup.lift_apply_of, ab_of, pair_single] at this
+  exact this
+
+private abbrev Q := (Fin n → ℤ) ⧸ R g
+
+private abbrev Qf := Q g ⧸ Submodule.torsion ℤ (Q g)
+
+private def proj : (Fin n → ℤ) →ₗ[ℤ] Qf g := (Submodule.torsion ℤ (Q g)).mkQ ∘ₗ (R g).mkQ
+
+private theorem proj_surjective : Function.Surjective (proj g) :=
+  (Submodule.mkQ_surjective _).comp (Submodule.mkQ_surjective _)
+
+private scoped instance instFiniteQ : Module.Finite ℤ (Q g) := Module.Finite.quotient ℤ (R g)
+
+private scoped instance instFiniteQf : Module.Finite ℤ (Qf g) := Module.Finite.quotient ℤ _
+
+private scoped instance instIsTorsionFreeQf : Module.IsTorsionFree ℤ (Qf g) :=
+  Submodule.QuotientTorsion.instIsTorsionFree
+
+private scoped instance instFreeQf : Module.Free ℤ (Qf g) :=
+  Module.free_of_finite_type_torsion_free'
+
+private noncomputable def t : ℕ := Module.finrank ℤ (Qf g)
+
+private noncomputable def ε : Module.Basis (Fin (t g)) ℤ (Qf g) := Module.finBasis ℤ (Qf g)
+
+private noncomputable def cLift (k : Fin (t g)) :
+    Fin n → ℤ := Function.surjInv (proj_surjective g) (ε g k)
+
+private theorem proj_cLift (k : Fin (t g)) : proj g (cLift g k) = ε g k :=
+  Function.surjInv_eq (proj_surjective g) _
+
+private noncomputable def Λ (z : Fin n → A) : Fin (t g) → A := fun k => pair (cLift g k) z
+
+private noncomputable def descend (hA : ∀ (a : ℤ) (x : A), a ≠ 0 → a • x = 0 → x = 0)
+    (z : Fin n → A) (hz : ∀ c ∈ R g, pair c z = 0) : Qf g →ₗ[ℤ] A :=
+  (Submodule.torsion ℤ (Q g)).liftQ
+    ((R g).liftQ (Fintype.linearCombination ℤ z) (by
+      intro c hc
+      rw [LinearMap.mem_ker, ← pair_eq_linearCombination]
+      exact hz c hc))
+    (by
+      intro x hx
+      obtain ⟨⟨a, ha⟩, hax⟩ := (Submodule.mem_torsion_iff x).1 hx
+      rw [LinearMap.mem_ker]
+      refine hA a _ (nonZeroDivisors.ne_zero ha) ?_
+      rw [← map_zsmul]
+      change (R g).liftQ _ _ ((⟨a, ha⟩ : nonZeroDivisors ℤ) • x) = 0
+      rw [hax, map_zero])
+
+private theorem descend_proj (hA : ∀ (a : ℤ) (x : A), a ≠ 0 → a • x = 0 → x = 0)
+    (z : Fin n → A) (hz : ∀ c ∈ R g, pair c z = 0) (c : Fin n → ℤ) :
+    descend g hA z hz (proj g c) = pair c z := by
+  change (Submodule.torsion ℤ (Q g)).liftQ _ _
+    (Submodule.Quotient.mk (Submodule.Quotient.mk c)) = _
+  rw [Submodule.liftQ_apply]
+  erw [Submodule.liftQ_apply]
+  rw [← pair_eq_linearCombination]
+
+private theorem Λ_eq_descend (hA : ∀ (a : ℤ) (x : A), a ≠ 0 → a • x = 0 → x = 0)
+    (z : Fin n → A) (hz : ∀ c ∈ R g, pair c z = 0) (k : Fin (t g)) :
+    Λ g z k = descend g hA z hz (ε g k) := by
+  rw [Λ, ← proj_cLift, descend_proj]
+
+private theorem Λ_injective (hA : ∀ (a : ℤ) (x : A), a ≠ 0 → a • x = 0 → x = 0)
+    {z z' : Fin n → A} (hz : ∀ c ∈ R g, pair c z = 0) (hz' : ∀ c ∈ R g, pair c z' = 0)
+    (h : Λ g z = Λ g z') : z = z' := by
+  have hd : descend g hA z hz = descend g hA z' hz' := by
+    refine (ε g).ext fun k => ?_
+    rw [← Λ_eq_descend, ← Λ_eq_descend, h]
+  funext i
+  have := congrArg (fun f => f (proj g (Pi.single i 1))) hd
+  simp only [descend_proj, pair_single] at this
+  exact this
+
+private theorem pair_stdBasis (G : (Fin n → ℤ) →ₗ[ℤ] A) (c : Fin n → ℤ) :
+    pair c (fun i => G (Pi.single i 1)) = G c := by
+  classical
+  simp only [pair, ← map_zsmul]
+  rw [← map_sum]
+  congr 1
+  funext j
+  simp [Finset.sum_apply, Pi.single_apply]
+
+private theorem Λ_surjective (y : Fin (t g) → A) :
+    ∃ z : Fin n → A, (∀ c ∈ R g, pair c z = 0) ∧ Λ g z = y := by
+  classical
+  let F : Qf g →ₗ[ℤ] A := (ε g).constr ℤ y
+  refine ⟨fun i => F (proj g (Pi.single i 1)), ?_, ?_⟩
+  · intro c hc
+    have h1 := pair_stdBasis (F ∘ₗ proj g) c
+    simp only [LinearMap.coe_comp, Function.comp_apply] at h1
+    rw [h1]
+    have : proj g c = 0 := by
+      have h0 : (R g).mkQ c = 0 := (Submodule.Quotient.mk_eq_zero (R g)).2 hc
+      change (Submodule.torsion ℤ (Q g)).mkQ ((R g).mkQ c) = 0
+      rw [h0, map_zero]
+    rw [this, map_zero]
+  · funext k
+    change pair (cLift g k) _ = y k
+    have h1 := pair_stdBasis (F ∘ₗ proj g) (cLift g k)
+    simp only [LinearMap.coe_comp, Function.comp_apply] at h1
+    rw [h1, proj_cLift]
+    exact (ε g).constr_basis ℤ y k
+
+private theorem coord_bijective (hg : Subgroup.closure (Set.range g) = ⊤)
+    (hA : ∀ (a : ℤ) (x : A), a ≠ 0 → a • x = 0 → x = 0) :
+    Function.Bijective (fun φ : ModularCurve.Period.parabolicHoms ℤ Γ A => Λ g (ev g (φ : Additive Γ
+      →+ A))) := by
+  constructor
+  · intro φ ψ h
+    exact Subtype.ext (ev_injective g hg (Λ_injective g hA (ev_perp g φ.2) (ev_perp g ψ.2) h))
+  · intro y
+    obtain ⟨z, hz, hy⟩ := Λ_surjective g y
+    exact ⟨⟨liftHom g hg z hz, liftHom_mem g hg hz⟩, by simp only [ev_liftHom]; exact hy⟩
+
+end Presentation
+
+section Main
+
+variable {Γ : Subgroup SL(2, ℤ)} {n : ℕ} (g : Fin n → Γ)
+
+private theorem mem_parabolicHoms_iff {R' : Type*} [Semiring R'] {A : Type*} [AddCommGroup A]
+    [Module R' A]
+    (φ : Additive Γ →+ A) :
+    φ ∈ ModularCurve.Period.parabolicHoms R' Γ A ↔ ModularCurve.Period.IsParabolicHom Γ φ :=
+  Iff.rfl
+
+private theorem pair_add_right {A : Type*} [AddCommGroup A] (c : Fin n → ℤ) (z z' : Fin n → A) :
+    pair c (z + z') = pair c z + pair c z' := by
+  simp [pair, Finset.sum_add_distrib]
+
+private theorem pair_smul_right {A : Type*} [AddCommGroup A] {S : Type*} [Monoid S]
+    [DistribMulAction S A]
+    [SMulCommClass ℤ S A] (c : Fin n → ℤ) (r : S) (z : Fin n → A) :
+    pair c (r • z) = r • pair c z := by
+  simp only [pair, Pi.smul_apply, Finset.smul_sum]
+  exact Finset.sum_congr rfl fun i _ => smul_comm (c i) r (z i)
+
+private theorem Λ_add {A : Type*} [AddCommGroup A] (z z' : Fin n → A) :
+    Λ g (z + z') = Λ g z + Λ g z' := by
+  funext k; exact pair_add_right _ _ _
+
+private theorem Λ_smul {A : Type*} [AddCommGroup A] {S : Type*} [Monoid S] [DistribMulAction S A]
+    [SMulCommClass ℤ S A] (r : S) (z : Fin n → A) : Λ g (r • z) = r • Λ g z := by
+  funext k; exact pair_smul_right _ _ _
+
+private theorem int_tf : ∀ (a : ℤ) (x : ℤ), a ≠ 0 → a • x = 0 → x = 0 := fun a x ha h => by
+  rw [smul_eq_mul] at h; exact (mul_eq_zero.1 h).resolve_left ha
+
+private theorem field_tf (K : Type*) [Field K] [CharZero K] :
+    ∀ (a : ℤ) (x : K), a ≠ 0 → a • x = 0 → x = 0 := fun a x ha h => by
+  rw [zsmul_eq_mul] at h; exact (mul_eq_zero.1 h).resolve_left (Int.cast_ne_zero.2 ha)
+
+private noncomputable def coordZlin :
+    ModularCurve.Period.parabolicHoms ℤ Γ ℤ →ₗ[ℤ] (Fin (t g) → ℤ) where
+  toFun φ := Λ g (ev g (φ : Additive Γ →+ ℤ))
+  map_add' φ ψ := by
+    change Λ g (ev g ((φ : Additive Γ →+ ℤ) + (ψ : Additive Γ →+ ℤ))) = _
+    rw [← Λ_add]; rfl
+  map_smul' m φ := by
+    change Λ g (ev g (m • (φ : Additive Γ →+ ℤ))) = m • Λ g (ev g (φ : Additive Γ →+ ℤ))
+    rw [← Λ_smul]; rfl
+
+private noncomputable def coordZ (hg : Subgroup.closure (Set.range g) = ⊤) :
+    ModularCurve.Period.parabolicHoms ℤ Γ ℤ ≃ₗ[ℤ] (Fin (t g) → ℤ) :=
+  LinearEquiv.ofBijective (coordZlin g) (coord_bijective g hg int_tf)
+
+private theorem coordZ_apply (hg : Subgroup.closure (Set.range g) = ⊤)
+    (φ : ModularCurve.Period.parabolicHoms ℤ Γ ℤ) :
+    coordZ g hg φ = Λ g (ev g (φ : Additive Γ →+ ℤ)) := rfl
+
+private noncomputable def coordKlin (K : Type*) [Field K] :
+    ModularCurve.Period.parabolicHoms K Γ K →ₗ[K] (Fin (t g) → K) where
+  toFun φ := Λ g (ev g (φ : Additive Γ →+ K))
+  map_add' φ ψ := by
+    change Λ g (ev g ((φ : Additive Γ →+ K) + (ψ : Additive Γ →+ K))) = _
+    rw [← Λ_add]; rfl
+  map_smul' r φ := by
+    change Λ g (ev g (r • (φ : Additive Γ →+ K))) = r • Λ g (ev g (φ : Additive Γ →+ K))
+    rw [← Λ_smul]; rfl
+
+private theorem coordK_bijective (hg : Subgroup.closure (Set.range g) = ⊤) (K : Type*) [Field K]
+    [CharZero K] :
+    Function.Bijective (coordKlin g K) := by
+  have hb := coord_bijective g hg (field_tf K)
+  refine ⟨fun φ ψ h => ?_, fun y => ?_⟩
+  · have key := @hb.1
+      ⟨(φ : Additive Γ →+ K), (mem_parabolicHoms_iff _).2 ((mem_parabolicHoms_iff _).1 φ.2)⟩
+      ⟨(ψ : Additive Γ →+ K), (mem_parabolicHoms_iff _).2 ((mem_parabolicHoms_iff _).1 ψ.2)⟩ h
+    exact Subtype.ext (congrArg Subtype.val key)
+  · obtain ⟨φ, hφ⟩ := hb.2 y
+    exact ⟨⟨(φ : Additive Γ →+ K), (mem_parabolicHoms_iff _).2 ((mem_parabolicHoms_iff _).1 φ.2)⟩,
+      hφ⟩
+
+private noncomputable def coordK (hg : Subgroup.closure (Set.range g) = ⊤) (K : Type*) [Field K]
+    [CharZero K] :
+    ModularCurve.Period.parabolicHoms K Γ K ≃ₗ[K] (Fin (t g) → K) :=
+  LinearEquiv.ofBijective (coordKlin g K) (coordK_bijective g hg K)
+
+private theorem coordK_apply (hg : Subgroup.closure (Set.range g) = ⊤) (K : Type*) [Field K]
+    [CharZero K]
+    (φ : ModularCurve.Period.parabolicHoms K Γ K) :
+    coordK g hg K φ = Λ g (ev g (φ : Additive Γ →+ K)) := rfl
+
+private theorem castAddHom_comp_mem (K : Type*) [Field K] {φ : Additive Γ →+ ℤ}
+    (hφ : φ ∈ ModularCurve.Period.parabolicHoms ℤ Γ ℤ) :
+    (Int.castAddHom K).comp φ ∈ ModularCurve.Period.parabolicHoms K Γ K := by
+  intro γ hγ
+  change ((φ (Additive.ofMul γ) : ℤ) : K) = 0
+  rw [hφ γ hγ, Int.cast_zero]
+
+private theorem main (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] :
+    ∃ (n : ℕ) (b : Module.Basis (Fin n) ℤ (ModularCurve.Period.parabolicHoms ℤ Γ ℤ)),
+      ∀ (K : Type*) [Field K] [CharZero K],
+        ∃ bK : Module.Basis (Fin n) K (ModularCurve.Period.parabolicHoms K Γ K),
+          ∀ i, (bK i : Additive Γ →+ K) = (Int.castAddHom K).comp (b i : Additive Γ →+ ℤ) := by
+  obtain ⟨n, g, hg⟩ := exists_generators Γ
+  refine ⟨t g, Module.Basis.ofEquivFun (coordZ g hg), fun K _ _ =>
+    ⟨Module.Basis.ofEquivFun (coordK g hg K), fun i => ?_⟩⟩
+  have hmem : (Int.castAddHom K).comp
+      ((Module.Basis.ofEquivFun (coordZ g hg) i : ModularCurve.Period.parabolicHoms ℤ Γ ℤ) :
+        Additive Γ →+ ℤ) ∈ ModularCurve.Period.parabolicHoms K Γ K :=
+    castAddHom_comp_mem K (Module.Basis.ofEquivFun (coordZ g hg) i).2
+  have hcoord : coordK g hg K ⟨_, hmem⟩ = Pi.single i 1 := by
+    funext k
+    rw [coordK_apply]
+    change pair (cLift g k) ((Int.castAddHom K) ∘ ev g
+      ((Module.Basis.ofEquivFun (coordZ g hg) i : ModularCurve.Period.parabolicHoms ℤ Γ ℤ) :
+        Additive Γ →+ ℤ)) = _
+    rw [← pair_map]
+    rw [show pair (cLift g k) (ev g ((Module.Basis.ofEquivFun (coordZ g hg) i :
+        ModularCurve.Period.parabolicHoms ℤ Γ ℤ) : Additive Γ →+ ℤ))
+        = coordZ g hg (Module.Basis.ofEquivFun (coordZ g hg) i) k from rfl]
+    rw [Module.Basis.coe_ofEquivFun, LinearEquiv.apply_symm_apply]
+    simp [Pi.single_apply]
+  calc ((Module.Basis.ofEquivFun (coordK g hg K) i : ModularCurve.Period.parabolicHoms K Γ K) :
+        Additive Γ →+ K)
+      = (((coordK g hg K).symm (Pi.single i 1) : ModularCurve.Period.parabolicHoms K Γ K) :
+          Additive Γ →+ K) := by rw [Module.Basis.coe_ofEquivFun]
+    _ = _ := by rw [← hcoord, LinearEquiv.symm_apply_apply]
+
+end Main
+
+end L2
+end DeskWA_D3
+
+open scoped MatrixGroups in
+theorem solution
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] :
+    ∃ (n : ℕ) (b : Module.Basis (Fin n) ℤ (ModularCurve.Period.parabolicHoms ℤ Γ ℤ)),
+      ∀ (K : Type*) [Field K] [CharZero K],
+        ∃ bK : Module.Basis (Fin n) K (ModularCurve.Period.parabolicHoms K Γ K),
+          ∀ i, (bK i : Additive Γ →+ K) = (Int.castAddHom K).comp (b i : Additive Γ →+ ℤ) :=
+  DeskWA_D3.L2.main Γ
+
+end S_ModularCurve_Period_exists_basis_parabolicHoms_castAddHom_comp
+end P2MW
+export P2MW.S_ModularCurve_Period_exists_basis_parabolicHoms_castAddHom_comp (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.Period.exists_basis_parabolicHoms_castAddHom_comp
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] :
+    ∃ (n : ℕ) (b : Module.Basis (Fin n) ℤ (ModularCurve.Period.parabolicHoms ℤ Γ ℤ)),
+      ∀ (K : Type*) [Field K] [CharZero K],
+        ∃ bK : Module.Basis (Fin n) K (ModularCurve.Period.parabolicHoms K Γ K),
+          ∀ i, (bK i : Additive Γ →+ K) = (Int.castAddHom K).comp (b i : Additive Γ →+ ℤ) :=
+  solution Γ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_Period_exists_basis_parabolicHoms_of_isAddTorsionFree.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_Period_exists_basis_parabolicHoms_of_isAddTorsionFree.lean
new file mode 100644
index 0000000000..779c08cc9c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_Period_exists_basis_parabolicHoms_of_isAddTorsionFree.lean
@@ -0,0 +1,371 @@
+/-
+Based on Prove2Me node ModularCurve.Period.exists_basis_parabolicHoms_of_isAddTorsionFree
+(4b95a52a-d74a-57d1-ba7d-5f43023fa729) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 775080f5-701d-553e-9497-26d6fbafc5de
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodMap
+public import Mathlib.LinearAlgebra.Basis.Defs
+
+import Mathlib.GroupTheory.FiniteAbelian.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_HeckeAlgebraHom
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integral parabolic characters base-change to torsion-free rings
+
+Theorem statement: `ModularCurve.Period.exists_basis_parabolicHoms_of_isAddTorsionFree`
+(`4b95a52a-d74a-57d1-ba7d-5f43023fa729`), by Claude, 2026-09-05.
+
+Proof: submission `775080f5-701d-553e-9497-26d6fbafc5de`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of $\mathrm{SL}_2(\mathbb{Z})$ of finite index. For a commutative ring
+$R$, [`ModularCurve.Period.parabolicHoms R Γ R`](def/ModularCurve_PeriodMap.html#L62) denotes the
+$R$-submodule of $\mathrm{Hom}(\mathrm{Additive}\,\Gamma, R)$ — the additive group homomorphisms
+from $\Gamma$, written additively, to $R$ — consisting of those $\varphi$ with $\varphi(\gamma)=0$
+for every $\gamma\in\Gamma$ whose underlying integral $2\times 2$ matrix satisfies
+$\operatorname{tr}(\gamma)^2=4$, i.e. $\operatorname{tr}(\gamma)=\pm 2$. The assertion is that there
+exist a natural number $n$ and a basis $b$ of the $\mathbb{Z}$-module
+[`ModularCurve.Period.parabolicHoms ℤ Γ ℤ`](def/ModularCurve_PeriodMap.html#L62) indexed by
+$\mathrm{Fin}\,n$ such that for every commutative ring $R$ that is additively torsion-free there is
+a basis $b^R$ of the $R$-module [`ModularCurve.Period.parabolicHoms R Γ
+R`](def/ModularCurve_PeriodMap.html#L62), again indexed by $\mathrm{Fin}\,n$, whose members are the
+base changes of those of $b$: for each $i$, the homomorphism $b^R_i : \mathrm{Additive}\,\Gamma \to
+R$ equals $b_i$ followed by the canonical additive map $\mathbb{Z}\to R$. In particular each such
+`parabolicHoms R Γ R` is free of the same rank $n$, with basis the image of a fixed integral basis.
+
+This is the parabolic part $H^1_{\mathrm{par}}(\Gamma, R)$ of the first cohomology of $\Gamma$ with
+trivial coefficients, here realised concretely as the characters of $\Gamma$ vanishing on elements
+of trace $\pm 2$, and the statement says that over additively torsion-free coefficient rings this
+module is the base change of the integral one, uniformly in $R$ and with a single basis. It
+underlies the constructions of period lattices and modular symbols in the project, and is invoked by
+the results on Hecke and diamond operators acting on integral parabolic classes.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_Period_exists_basis_parabolicHoms_of_isAddTorsionFree.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_Period_exists_basis_parabolicHoms_of_isAddTorsionFree
+
+
+namespace ParInt
+
+open scoped MatrixGroups
+open ModularCurve.Period
+
+variable (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex]
+
+abbrev A : Type := Additive (Abelianization ↥Γ)
+
+scoped instance : AddGroup.FG (A Γ) := by
+  have : Group.FG (Abelianization ↥Γ) :=
+    Group.fg_of_surjective (f := Abelianization.of) (QuotientGroup.mk_surjective)
+  infer_instance
+
+def cls (γ : ↥Γ) : A Γ := Additive.ofMul (Abelianization.of γ)
+
+omit [Γ.FiniteIndex] in
+theorem cls_mul (γ δ : ↥Γ) : cls Γ (γ * δ) = cls Γ γ + cls Γ δ := by
+  simp [cls, ofMul_mul]
+
+def P : AddSubgroup (A Γ) :=
+  AddSubgroup.closure {a | ∃ γ : ↥Γ, ((γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace ^ 2 = 4 ∧ a =
+    cls Γ γ}
+
+abbrev Q : Type := A Γ ⧸ P Γ
+
+scoped instance : AddGroup.FG (Q Γ) := inferInstance
+
+def π (γ : ↥Γ) : Q Γ := (cls Γ γ : A Γ)
+
+omit [Γ.FiniteIndex] in
+theorem π_mul (γ δ : ↥Γ) : π Γ (γ * δ) = π Γ γ + π Γ δ := by
+  simp [π, cls_mul]
+
+omit [Γ.FiniteIndex] in
+theorem π_one : π Γ 1 = 0 := by
+  have h := π_mul Γ 1 1
+  rw [mul_one] at h
+  have : π Γ 1 + π Γ 1 = π Γ 1 + 0 := by rw [add_zero]; exact h.symm
+  exact add_left_cancel this
+
+omit [Γ.FiniteIndex] in
+theorem π_eq_zero_of_trace (γ : ↥Γ) (hγ : ((γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace ^ 2 = 4)
+    :
+    π Γ γ = 0 := by
+  change ((cls Γ γ : A Γ) : Q Γ) = 0
+  rw [QuotientAddGroup.eq_zero_iff]
+  exact AddSubgroup.subset_closure ⟨γ, hγ, rfl⟩
+
+omit [Γ.FiniteIndex] in
+theorem π_surjective : Function.Surjective (π Γ) := by
+  intro q
+  induction q using QuotientAddGroup.induction_on with
+  | H a =>
+    obtain ⟨x, rfl⟩ : ∃ x : Abelianization ↥Γ, Additive.ofMul x = a := ⟨Additive.toMul a, rfl⟩
+    obtain ⟨γ, rfl⟩ := QuotientGroup.mk_surjective x
+    exact ⟨γ, rfl⟩
+
+section Factor
+
+variable {Γ} {R : Type*} [AddCommGroup R]
+
+def liftA (φ : Additive ↥Γ →+ R) : A Γ →+ R :=
+  MonoidHom.toAdditiveLeft (Abelianization.lift (AddMonoidHom.toMultiplicativeRight φ))
+
+omit [Γ.FiniteIndex] in
+theorem liftA_cls (φ : Additive ↥Γ →+ R) (γ : ↥Γ) : liftA φ (cls Γ γ) = φ (Additive.ofMul γ) := by
+  simp [liftA, cls, Abelianization.lift_apply_of]
+
+omit [Γ.FiniteIndex] in
+theorem P_le_ker (φ : Additive ↥Γ →+ R) (hφ : IsParabolicHom Γ φ) : P Γ ≤ (liftA φ).ker := by
+  rw [P, AddSubgroup.closure_le]
+  rintro a ⟨γ, hγ, rfl⟩
+  change liftA φ (cls Γ γ) = 0
+  rw [liftA_cls]
+  exact hφ γ hγ
+
+def liftQ (φ : Additive ↥Γ →+ R) (hφ : IsParabolicHom Γ φ) : Q Γ →+ R :=
+  QuotientAddGroup.lift (P Γ) (liftA φ) (P_le_ker φ hφ)
+
+omit [Γ.FiniteIndex] in
+theorem liftQ_π (φ : Additive ↥Γ →+ R) (hφ : IsParabolicHom Γ φ) (γ : ↥Γ) :
+    liftQ φ hφ (π Γ γ) = φ (Additive.ofMul γ) := by
+  change QuotientAddGroup.lift (P Γ) (liftA φ) (P_le_ker φ hφ) ((cls Γ γ : A Γ) : Q Γ) = _
+  rw [QuotientAddGroup.lift_mk, liftA_cls]
+
+theorem apply_eq_zero_of_isOfFinAddOrder [IsAddTorsionFree R] {G : Type*} [AddCommGroup G]
+    (f : G →+ R) (x : G) (hx : IsOfFinAddOrder x) : f x = 0 := by
+  obtain ⟨n, hn, hnx⟩ := hx.exists_nsmul_eq_zero
+  have h : n • f x = n • (0 : R) := by rw [← map_nsmul, hnx, map_zero, nsmul_zero]
+  exact IsAddTorsionFree.nsmul_right_injective hn.ne' h
+
+end Factor
+
+section Coord
+
+structure Decomp where
+  n : ℕ
+  T : Type
+  instT : AddCommGroup T
+  finT : Finite T
+  E : Q Γ ≃+ (Fin n →₀ ℤ) × T
+
+attribute [scoped instance] Decomp.instT Decomp.finT
+
+theorem nonempty_decomp : Nonempty (Decomp Γ) := by
+  obtain ⟨n, ι, hι, p, hp, e, ⟨E⟩⟩ := AddCommGroup.equiv_free_prod_directSum_zmod (Q Γ)
+  have : ∀ i, NeZero (p i ^ e i) := fun i => ⟨pow_ne_zero _ (hp i).ne_zero⟩
+  have : Finite ι := Finite.of_fintype ι
+  have : Finite (DirectSum ι fun i => ZMod (p i ^ e i)) :=
+    Finite.of_injective (fun x : DirectSum ι (fun i => ZMod (p i ^ e i)) =>
+      (x : Π i, ZMod (p i ^ e i))) DFunLike.coe_injective
+  exact ⟨⟨n, _, inferInstance, inferInstance, E⟩⟩
+
+variable {Γ} (D : Decomp Γ)
+
+noncomputable def coord (i : Fin D.n) : Q Γ →+ ℤ :=
+  (Finsupp.applyAddHom i).comp ((AddMonoidHom.fst _ _).comp D.E.toAddMonoidHom)
+
+omit [Γ.FiniteIndex] in
+@[scoped simp] theorem coord_apply (i : Fin D.n) (q : Q Γ) : coord D i q = (D.E q).1 i := rfl
+
+noncomputable def sect (v : Fin D.n →₀ ℤ) : Q Γ := D.E.symm (v, 0)
+
+omit [Γ.FiniteIndex] in
+@[scoped simp] theorem E_sect (v : Fin D.n →₀ ℤ) : D.E (sect D v) = (v, 0) := D.E.apply_symm_apply _
+
+omit [Γ.FiniteIndex] in
+theorem coord_sect (i : Fin D.n) (v : Fin D.n →₀ ℤ) : coord D i (sect D v) = v i := by
+  rw [coord_apply, E_sect]
+
+omit [Γ.FiniteIndex] in
+theorem isOfFinAddOrder_sub_sect (q : Q Γ) :
+    IsOfFinAddOrder (q - sect D (D.E q).1) := by
+  have h : D.E (q - sect D (D.E q).1) = (0, (D.E q).2) := by
+    rw [map_sub, E_sect, Prod.ext_iff]
+    simp
+  have hfin : IsOfFinAddOrder ((0, (D.E q).2) : (Fin D.n →₀ ℤ) × D.T) := by
+    have h2 : IsOfFinAddOrder (D.E q).2 := isOfFinAddOrder_of_finite _
+    obtain ⟨m, hm, hm2⟩ := h2.exists_nsmul_eq_zero
+    refine isOfFinAddOrder_iff_nsmul_eq_zero.mpr ⟨m, hm, ?_⟩
+    rw [Prod.ext_iff]
+    exact ⟨by simp, by simpa using hm2⟩
+  have hq : q - sect D (D.E q).1 = D.E.symm (0, (D.E q).2) := by
+    apply D.E.injective; rw [h, AddEquiv.apply_symm_apply]
+  rw [hq]
+  exact D.E.symm.toAddMonoidHom.isOfFinAddOrder hfin
+
+end Coord
+
+section Basis
+
+variable {Γ} (D : Decomp Γ) (R : Type*) [CommRing R]
+
+noncomputable def chi (i : Fin D.n) : Additive ↥Γ →+ R where
+  toFun x := (coord D i (π Γ (Additive.toMul x)) : R)
+  map_zero' := by
+    change ((coord D i (π Γ 1) : ℤ) : R) = 0
+    rw [π_one, map_zero, Int.cast_zero]
+  map_add' x y := by
+    change ((coord D i (π Γ (Additive.toMul x * Additive.toMul y)) : ℤ) : R) = _
+    rw [π_mul, map_add, Int.cast_add]
+
+omit [Γ.FiniteIndex] in
+theorem chi_apply (i : Fin D.n) (γ : ↥Γ) :
+    chi D R i (Additive.ofMul γ) = (coord D i (π Γ γ) : R) := rfl
+
+omit [Γ.FiniteIndex] in
+theorem chi_mem (i : Fin D.n) : chi D R i ∈ parabolicHoms R Γ R := by
+  intro γ hγ
+  rw [chi_apply, π_eq_zero_of_trace Γ γ hγ, map_zero, Int.cast_zero]
+
+omit [Γ.FiniteIndex] in
+theorem chi_int_cast (i : Fin D.n) :
+    (Int.castAddHom R).comp (chi D ℤ i) = chi D R i := by
+  refine AddMonoidHom.ext fun x => ?_
+  simp [chi]
+
+noncomputable def Θ : (Fin D.n → R) →ₗ[R] ↥(parabolicHoms R Γ R) where
+  toFun c := ∑ i, c i • (⟨chi D R i, chi_mem D R i⟩ : ↥(parabolicHoms R Γ R))
+  map_add' c c' := by
+    rw [← Finset.sum_add_distrib]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [Pi.add_apply, add_smul]
+  map_smul' r c := by
+    rw [Finset.smul_sum]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [Pi.smul_apply, smul_eq_mul, mul_smul, RingHom.id_apply]
+
+omit [Γ.FiniteIndex] in
+theorem Θ_apply_apply (c : Fin D.n → R) (γ : ↥Γ) :
+    ((Θ D R c : ↥(parabolicHoms R Γ R)) : Additive ↥Γ →+ R) (Additive.ofMul γ) =
+      ∑ i, c i * (coord D i (π Γ γ) : R) := by
+  simp only [Θ, LinearMap.coe_mk, AddHom.coe_mk, Submodule.coe_sum, Submodule.coe_smul,
+    AddMonoidHom.finsetSum_apply, AddMonoidHom.smul_apply, chi_apply, smul_eq_mul]
+
+omit [Γ.FiniteIndex] in
+theorem Θ_single (i : Fin D.n) :
+    ((Θ D R (Pi.single i 1) : ↥(parabolicHoms R Γ R)) : Additive ↥Γ →+ R) = chi D R i := by
+  refine AddMonoidHom.ext fun x => ?_
+  obtain ⟨γ, rfl⟩ : ∃ γ, Additive.ofMul γ = x := ⟨Additive.toMul x, rfl⟩
+  rw [Θ_apply_apply, chi_apply, Finset.sum_eq_single i]
+  · simp
+  · intro j _ hji; simp [Pi.single_eq_of_ne hji]
+  · intro h; exact absurd (Finset.mem_univ i) h
+
+omit [Γ.FiniteIndex] in
+theorem exists_coord_eq_single (j : Fin D.n) :
+    ∃ γ : ↥Γ, ∀ i, coord D i (π Γ γ) = if i = j then 1 else 0 := by
+  obtain ⟨γ, hγ⟩ := π_surjective Γ (sect D (Finsupp.single j 1))
+  refine ⟨γ, fun i => ?_⟩
+  rw [hγ, coord_sect, Finsupp.single_apply]
+  by_cases h : i = j
+  · subst h; simp
+  · rw [ite_eq_right (Ne.symm h), ite_eq_right h]
+
+omit [Γ.FiniteIndex] in
+theorem Θ_injective : Function.Injective (Θ D R) := by
+  intro c c' h
+  funext j
+  obtain ⟨γ, hγ⟩ := exists_coord_eq_single D j
+  have := congrArg (fun φ : ↥(parabolicHoms R Γ R) => (φ : Additive ↥Γ →+ R) (Additive.ofMul γ)) h
+  simp only [Θ_apply_apply, hγ] at this
+  simpa [Finset.sum_ite_eq', Finset.mem_univ] using this
+
+omit [Γ.FiniteIndex] in
+theorem Θ_surjective [IsAddTorsionFree R] : Function.Surjective (Θ D R) := by
+  intro φ
+  set ψ : Q Γ →+ R := liftQ (φ : Additive ↥Γ →+ R) φ.2 with hψ
+  refine ⟨fun i => ψ (sect D (Finsupp.single i 1)), Subtype.ext ?_⟩
+  refine AddMonoidHom.ext fun x => ?_
+  obtain ⟨γ, rfl⟩ : ∃ γ, Additive.ofMul γ = x := ⟨Additive.toMul x, rfl⟩
+  rw [Θ_apply_apply, ← liftQ_π (φ : Additive ↥Γ →+ R) φ.2 γ]
+  set q := π Γ γ with hq
+  have hkill : ψ (q - sect D (D.E q).1) = 0 :=
+    apply_eq_zero_of_isOfFinAddOrder ψ _ (isOfFinAddOrder_sub_sect D q)
+  have hq' : ψ q = ψ (sect D (D.E q).1) := by
+    rw [map_sub, sub_eq_zero] at hkill; exact hkill
+  rw [hq']
+  have hv : sect D (D.E q).1 = ∑ i, ((D.E q).1 i) • sect D (Finsupp.single i 1) := by
+    have hsect : ∀ v w : Fin D.n →₀ ℤ, sect D (v + w) = sect D v + sect D w := by
+      intro v w; unfold sect; rw [← map_add, Prod.mk_add_mk, add_zero]
+    have hsmul : ∀ (m : ℤ) (v : Fin D.n →₀ ℤ), sect D (m • v) = m • sect D v := by
+      intro m v; unfold sect; rw [← map_zsmul, Prod.smul_mk, smul_zero]
+    conv_lhs => rw [← Finsupp.univ_sum_single (D.E q).1]
+    rw [show sect D (∑ i, Finsupp.single i ((D.E q).1 i)) =
+        ∑ i, sect D (Finsupp.single i ((D.E q).1 i)) from map_sum
+          (⟨⟨sect D, by
+            unfold sect; rw [← map_zero D.E.symm]; rfl⟩, hsect⟩ : (Fin D.n →₀ ℤ) →+ Q Γ) _ _]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [← hsmul, Finsupp.smul_single, smul_eq_mul, mul_one]
+  rw [hv, map_sum]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [map_zsmul, coord_apply, zsmul_eq_mul, mul_comm]
+
+noncomputable def basisR [IsAddTorsionFree R] : Module.Basis (Fin D.n) R ↥(parabolicHoms R Γ R) :=
+  Module.Basis.map (Pi.basisFun R (Fin D.n)) (LinearEquiv.ofBijective (Θ D R) ⟨Θ_injective D R,
+    Θ_surjective D R⟩)
+
+omit [Γ.FiniteIndex] in
+theorem coe_basisR [IsAddTorsionFree R] (i : Fin D.n) :
+    ((basisR D R i : ↥(parabolicHoms R Γ R)) : Additive ↥Γ →+ R) = chi D R i := by
+  rw [basisR, Module.Basis.map_apply, Pi.basisFun_apply, LinearEquiv.ofBijective_apply, Θ_single]
+
+end Basis
+
+theorem main :
+    ∃ (n : ℕ) (b : Module.Basis (Fin n) ℤ ↥(parabolicHoms ℤ Γ ℤ)),
+      ∀ (R : Type*) [CommRing R] [IsAddTorsionFree R],
+        ∃ bR : Module.Basis (Fin n) R ↥(parabolicHoms R Γ R),
+          ∀ i, (bR i : Additive ↥Γ →+ R) = (Int.castAddHom R).comp (b i : Additive ↥Γ →+ ℤ) := by
+  obtain ⟨D⟩ := nonempty_decomp Γ
+  refine ⟨D.n, basisR D ℤ, fun R _ _ => ⟨basisR D R, fun i => ?_⟩⟩
+  rw [coe_basisR, coe_basisR, chi_int_cast]
+
+end ParInt
+
+open scoped MatrixGroups in
+theorem solution
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] :
+    ∃ (n : ℕ) (b : Module.Basis (Fin n) ℤ (ModularCurve.Period.parabolicHoms ℤ Γ ℤ)),
+      ∀ (R : Type*) [CommRing R] [IsAddTorsionFree R],
+        ∃ bR : Module.Basis (Fin n) R (ModularCurve.Period.parabolicHoms R Γ R),
+          ∀ i, (bR i : Additive Γ →+ R) = (Int.castAddHom R).comp (b i : Additive Γ →+ ℤ) :=
+  ParInt.main Γ
+
+end S_ModularCurve_Period_exists_basis_parabolicHoms_of_isAddTorsionFree
+end P2MW
+export P2MW.S_ModularCurve_Period_exists_basis_parabolicHoms_of_isAddTorsionFree (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.Period.exists_basis_parabolicHoms_of_isAddTorsionFree
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] :
+    ∃ (n : ℕ) (b : Module.Basis (Fin n) ℤ (ModularCurve.Period.parabolicHoms ℤ Γ ℤ)),
+      ∀ (R : Type*) [CommRing R] [IsAddTorsionFree R],
+        ∃ bR : Module.Basis (Fin n) R (ModularCurve.Period.parabolicHoms R Γ R),
+          ∀ i, (bR i : Additive Γ →+ R) = (Int.castAddHom R).comp (b i : Additive Γ →+ ℤ) :=
+  solution Γ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_Period_finrank_parabolicHoms_add_natCard_le_finrank_addMonoidHom_add_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_Period_finrank_parabolicHoms_add_natCard_le_finrank_addMonoidHom_add_one.lean
new file mode 100644
index 0000000000..357a6e0ac4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_Period_finrank_parabolicHoms_add_natCard_le_finrank_addMonoidHom_add_one.lean
@@ -0,0 +1,231 @@
+/-
+Based on Prove2Me node
+ModularCurve.Period.finrank_parabolicHoms_add_natCard_le_finrank_addMonoidHom_add_one
+(0f90f902-6270-5272-a743-919daad53e1d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e8a15ddc-6513-5410-9aca-ec001d8484c8
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodMap
+
+import Mathlib.GroupTheory.Schreier
+import Mathlib.LinearAlgebra.Matrix.FixedDetMatrices
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.PicardGroup
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Matrix_SpecialLinearGroup_exists_addMonoidHom_conj_T_pow_minimalPeriod_eq_of_finsum_eq_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Parabolic characters plus cusp count bounded by dimHom(Γ,K)+1
+
+Theorem statement:
+`ModularCurve.Period.finrank_parabolicHoms_add_natCard_le_finrank_addMonoidHom_add_one`
+(`0f90f902-6270-5272-a743-919daad53e1d`), by Claude, 2026-09-05.
+
+Proof: submission `e8a15ddc-6513-5410-9aca-ec001d8484c8`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of finite index in $\mathrm{SL}_2(\mathbb{Z})$ containing $-1$, and let
+$K$ be a field. Consider the $K$-vector space $\mathrm{Hom}(\Gamma,K)$ of additive group
+homomorphisms from the additive group underlying $\Gamma$ (that is, `Additive Γ`) to $K$, and inside
+it the subspace [`ModularCurve.Period.parabolicHoms K Γ K`](def/ModularCurve_PeriodMap.html#L62)
+consisting of those $\varphi$ with $\varphi(\gamma)=0$ for every $\gamma\in\Gamma$ whose image in
+$M_2(\mathbb{Z})$ has $(\operatorname{tr}\gamma)^2=4$, i.e. trace $\pm 2$. Let the cusp set be the
+quotient of $\mathrm{SL}_2(\mathbb{Z})/\Gamma$ by the orbit equivalence relation for the action of
+the cyclic group $\langle T\rangle$ of integer powers of $T=\begin{pmatrix}1&1\\0&1\end{pmatrix}$,
+and let its cardinality be measured by `Nat.card`. The assertion is the numerical inequality
+$$\dim_K \big(\text{parabolic homomorphisms}\big) + \#\big(\langle T\rangle\text{-orbits on
+}\mathrm{SL}_2(\mathbb{Z})/\Gamma\big) \le \dim_K \mathrm{Hom}(\Gamma,K) + 1,$$
+the dimensions being Mathlib's `Module.finrank`.
+
+This is the standard dimension count comparing parabolic cohomology in degree one with the full
+character space of $\Gamma$, the discrepancy being governed by the number of cusps: the evaluation
+of a character on the cusp generators covers the hyperplane of sum-zero functions on the cusps. It
+is used in the project's computations of $\dim_K H^1_{\mathrm{par}}$ for $\Gamma_0(N)$ and
+$\Gamma(N)$, namely in
+[`ModularCurve.finrank_parabolicHoms_gamma0_le_two_mul_genusFormula`]
+(thm.html#ModularCurve.finrank_parabolicHoms_gamma0_le_two_mul_genusFormula)
+and
+[`ModularCurve.six_mul_level_mul_finrank_parabolicHoms_Gamma_add_eq`]
+(thm.html#ModularCurve.six_mul_level_mul_finrank_parabolicHoms_Gamma_add_eq).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_Period_finrank_parabolicHoms_add_natCard_le_finrank_addMonoidHom_add_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_46337943
+
+
+open Matrix MatrixGroups Subgroup MulAction ModularCurve.Period
+
+noncomputable section
+
+namespace BassSerreCuspDim
+
+variable (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (K : Type) [Field K]
+
+abbrev Cu : Type := orbitRel.Quotient (zpowers ModularGroup.T) (SL(2, ℤ) ⧸ Γ)
+
+def cusp (x : SL(2, ℤ) ⧸ Γ) : Cu Γ := Quotient.mk (orbitRel (zpowers ModularGroup.T) _) x
+
+omit [Γ.FiniteIndex] in
+theorem cusp_surjective : Function.Surjective (cusp Γ) := Quotient.mk_surjective
+
+def wd (x : SL(2, ℤ) ⧸ Γ) : ℕ := Function.minimalPeriod (fun y => ModularGroup.T • y) x
+
+omit [Γ.FiniteIndex] in
+theorem gen_mem (g : SL(2, ℤ)) : g⁻¹ * ModularGroup.T ^ wd Γ (g : SL(2, ℤ) ⧸ Γ) * g ∈ Γ := by
+  have h0 : ModularGroup.T ^ wd Γ (g : SL(2, ℤ) ⧸ Γ) • (g : SL(2, ℤ) ⧸ Γ) = (g : SL(2, ℤ) ⧸ Γ) :=
+    (MulAction.pow_smul_eq_iff_minimalPeriod_dvd).mpr dvd_rfl
+  have h1 : ((ModularGroup.T ^ wd Γ (g : SL(2, ℤ) ⧸ Γ) * g : SL(2, ℤ)) : SL(2, ℤ) ⧸ Γ)
+      = (g : SL(2, ℤ) ⧸ Γ) := h0
+  rw [QuotientGroup.eq] at h1
+  have h2 := Γ.inv_mem h1
+  simpa only [_root_.mul_inv_rev, inv_inv, mul_assoc] using h2
+
+def rep (c : Cu Γ) : SL(2, ℤ) := Quotient.out (Quotient.out c)
+
+omit [Γ.FiniteIndex] in
+theorem cusp_rep (c : Cu Γ) : cusp Γ (rep Γ c : SL(2, ℤ) ⧸ Γ) = c := by
+  rw [rep, QuotientGroup.out_eq', cusp]; exact Quotient.out_eq c
+
+def genOf (c : Cu Γ) : Γ := ⟨_, gen_mem Γ (rep Γ c)⟩
+
+omit [Γ.FiniteIndex] in
+theorem trace_genOf (c : Cu Γ) :
+    ((genOf Γ c : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace = 2 := by
+  change (((rep Γ c)⁻¹ * ModularGroup.T ^ wd Γ (rep Γ c : SL(2, ℤ) ⧸ Γ) * rep Γ c : SL(2, ℤ)) :
+      Matrix (Fin 2) (Fin 2) ℤ).trace = 2
+  rw [Matrix.SpecialLinearGroup.coe_mul, Matrix.trace_mul_comm, Matrix.SpecialLinearGroup.coe_mul,
+    ← Matrix.mul_assoc, ← Matrix.SpecialLinearGroup.coe_mul, mul_inv_cancel,
+    Matrix.SpecialLinearGroup.coe_one, Matrix.one_mul, ← zpow_natCast, ModularGroup.coe_T_zpow]
+  simp [Matrix.trace_fin_two]
+
+def ev : (Additive Γ →+ K) →ₗ[K] (Cu Γ → K) where
+  toFun φ c := φ (Additive.ofMul (genOf Γ c))
+  map_add' _ _ := rfl
+  map_smul' _ _ := rfl
+
+omit [Γ.FiniteIndex] in
+theorem parabolicHoms_le_ker : parabolicHoms K Γ K ≤ LinearMap.ker (ev Γ K) := by
+  intro φ hφ
+  rw [LinearMap.mem_ker]
+  funext c
+  exact hφ (genOf Γ c) (by rw [trace_genOf]; norm_num)
+
+def sumL [Fintype (Cu Γ)] : (Cu Γ → K) →ₗ[K] K where
+  toFun v := ∑ c, v c
+  map_add' _ _ := by simp [Finset.sum_add_distrib]
+  map_smul' _ _ := by simp [Finset.mul_sum]
+
+theorem ker_sumL_le_range (hneg : (-1 : SL(2, ℤ)) ∈ Γ) [Fintype (Cu Γ)] :
+    LinearMap.ker (sumL Γ K) ≤ LinearMap.range (ev Γ K) := by
+  intro v hv
+  rw [LinearMap.mem_ker] at hv
+  have hv' : ∑ᶠ c, v c = 0 := by rw [finsum_eq_sum_of_fintype]; exact hv
+  obtain ⟨φ, hφ⟩ :=
+    Matrix.SpecialLinearGroup.exists_addMonoidHom_conj_T_pow_minimalPeriod_eq_of_finsum_eq_zero
+      Γ hneg K v hv'
+  refine ⟨φ, funext fun c => ?_⟩
+  change φ (Additive.ofMul (genOf Γ c)) = v c
+  have key := hφ (rep Γ c) (gen_mem Γ (rep Γ c))
+  exact key.trans (congrArg v (cusp_rep Γ c))
+
+theorem finrank_ker_sumL_add_one [Fintype (Cu Γ)] :
+    Module.finrank K (LinearMap.ker (sumL Γ K)) + 1 = Fintype.card (Cu Γ) := by
+  classical
+  have c₀ : Cu Γ := cusp Γ ((1 : SL(2, ℤ)) : SL(2, ℤ) ⧸ Γ)
+  have hsurj : Function.Surjective (sumL Γ K) := fun r =>
+    ⟨Pi.single c₀ r, by simp [sumL]⟩
+  have h1 : Module.finrank K (LinearMap.range (sumL Γ K)) = 1 := by
+    rw [LinearMap.range_eq_top.mpr hsurj, finrank_top, Module.finrank_self]
+  have h2 := LinearMap.finrank_range_add_finrank_ker (sumL Γ K)
+  rw [h1, Module.finrank_fintype_fun_eq_card] at h2
+  omega
+
+theorem moduleFinite_hom : Module.Finite K (Additive Γ →+ K) := by
+  classical
+  have : Group.FG SL(2, ℤ) := Group.fg_iff.mpr
+    ⟨{ModularGroup.S, ModularGroup.T}, SpecialLinearGroup.SL2Z_generators,
+      (Set.finite_singleton _).insert _⟩
+  have hΓ : Group.FG Γ := Subgroup.fg_of_index_ne_zero _
+  obtain ⟨_, s, _, hs⟩ := Group.fg_iff'.mp hΓ
+  let e : (Additive Γ →+ K) →ₗ[K] (s → K) :=
+    { toFun := fun φ i => φ (Additive.ofMul (i : Γ))
+      map_add' := fun _ _ => rfl
+      map_smul' := fun _ _ => rfl }
+  refine Module.Finite.of_injective e ?_
+  intro φ ψ h
+  have key : ∀ γ : Γ, φ (Additive.ofMul γ) = ψ (Additive.ofMul γ) := by
+    intro γ
+    have hγ : γ ∈ Subgroup.closure (s : Set Γ) := by rw [hs]; exact Subgroup.mem_top γ
+    induction hγ using Subgroup.closure_induction with
+    | mem x hx => exact congrFun h ⟨x, hx⟩
+    | one => rw [ofMul_one, map_zero, map_zero]
+    | mul x y _ _ hx hy => rw [ofMul_mul, map_add, map_add, hx, hy]
+    | inv x _ hx => rw [ofMul_inv, map_neg, map_neg, hx]
+  exact AddMonoidHom.ext fun x => key (Additive.toMul x)
+
+theorem main (hneg : (-1 : SL(2, ℤ)) ∈ Γ) :
+    Module.finrank K (parabolicHoms K Γ K) + Nat.card (Cu Γ)
+      ≤ Module.finrank K (Additive Γ →+ K) + 1 := by
+  classical
+  have : Fintype (Cu Γ) := Fintype.ofFinite _
+  have := moduleFinite_hom Γ K
+  have h1 : Module.finrank K (parabolicHoms K Γ K) ≤ Module.finrank K (LinearMap.ker (ev Γ K)) :=
+    Submodule.finrank_mono (parabolicHoms_le_ker Γ K)
+  have h2 : Module.finrank K (LinearMap.ker (sumL Γ K))
+      ≤ Module.finrank K (LinearMap.range (ev Γ K)) :=
+    Submodule.finrank_mono (ker_sumL_le_range Γ K hneg)
+  have h3 := finrank_ker_sumL_add_one Γ K
+  have h4 := LinearMap.finrank_range_add_finrank_ker (ev Γ K)
+  rw [Nat.card_eq_fintype_card]
+  omega
+
+end BassSerreCuspDim
+
+theorem solution (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hneg : (-1 : Matrix.SpecialLinearGroup (Fin 2) ℤ) ∈ Γ) (K : Type) [Field K] :
+    Module.finrank K (ModularCurve.Period.parabolicHoms K Γ K)
+      + Nat.card (MulAction.orbitRel.Quotient (Subgroup.zpowers ModularGroup.T)
+          (Matrix.SpecialLinearGroup (Fin 2) ℤ ⧸ Γ))
+      ≤ Module.finrank K (Additive Γ →+ K) + 1 :=
+  BassSerreCuspDim.main Γ K hneg
+
+end
+end S_OVERLONG_46337943
+end P2MW
+export P2MW.S_OVERLONG_46337943
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem ModularCurve.Period.finrank_parabolicHoms_add_natCard_le_finrank_addMonoidHom_add_one
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hneg : (-1 : Matrix.SpecialLinearGroup (Fin 2) ℤ) ∈ Γ) (K : Type) [Field K] :
+    Module.finrank K (ModularCurve.Period.parabolicHoms K Γ K)
+      + Nat.card (MulAction.orbitRel.Quotient (Subgroup.zpowers ModularGroup.T)
+          (Matrix.SpecialLinearGroup (Fin 2) ℤ ⧸ Γ))
+      ≤ Module.finrank K (Additive Γ →+ K) + 1 :=
+  solution Γ hneg K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_Period_six_mul_finrank_parabolicHoms_add_le_index.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_Period_six_mul_finrank_parabolicHoms_add_le_index.lean
new file mode 100644
index 0000000000..50ad7f5f57
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_Period_six_mul_finrank_parabolicHoms_add_le_index.lean
@@ -0,0 +1,762 @@
+/-
+Based on Prove2Me node ModularCurve.Period.six_mul_finrank_parabolicHoms_add_le_index
+(278088aa-c9e8-5f31-afbb-900e37712afb) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission abeaa323-0cf8-5930-bb74-909fb0df7faf
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CuspSpace
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodMap
+
+import Mathlib.LinearAlgebra.FreeModule.PID
+import Mathlib.LinearAlgebra.Matrix.FixedDetMatrices
+import Mathlib.RingTheory.Etale.Weakly
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.PicardGroup
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import Mathlib.RingTheory.TotallySplit
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Signature form of the Eichler–Shimura Betti bound
+
+Theorem statement: `ModularCurve.Period.six_mul_finrank_parabolicHoms_add_le_index`
+(`278088aa-c9e8-5f31-afbb-900e37712afb`), by Claude, 2026-09-05.
+
+Proof: submission `abeaa323-0cf8-5930-bb74-909fb0df7faf`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a positive natural number and let $K$ be a field of characteristic zero. Consider the
+congruence subgroup $\Gamma_0(N) \le \mathrm{SL}_2(\mathbb{Z})$ and the following four quantities.
+First, the $K$-dimension of [`ModularCurve.Period.parabolicHoms K (CongruenceSubgroup.Gamma0 N)
+K`](def/ModularCurve_PeriodMap.html#L62), the $K$-submodule of the additive homomorphisms $\varphi
+\colon \mathrm{Additive}\,\Gamma_0(N) \to K$ satisfying $\varphi(\gamma) = 0$ for every $\gamma \in
+\Gamma_0(N)$ whose underlying integral matrix has trace with square $4$, that is, trace $\pm 2$.
+Second, the cardinality of [`ModularCurve.CuspSpace N`](def/ModularCurve_CuspSpace.html#L103), the
+quotient of $\mathbb{P}^1(\mathbb{Q})$ (the one-point compactification `OnePoint ℚ`) by the orbit
+relation of the image of $\Gamma_0(N)$ in $\mathrm{GL}_2(\mathbb{Q})$ under `mapGL ℚ`. Third, the
+cardinality of the set of elements of the left coset space $\mathrm{SL}_2(\mathbb{Z})/\Gamma_0(N)$
+fixed by the action of $S = \begin{pmatrix}0&-1\\1&0\end{pmatrix}$. Fourth, the cardinality of the
+set of cosets fixed by $ST = \begin{pmatrix}0&-1\\1&1\end{pmatrix}$. The assertion is the inequality
+$$6\,\dim_K H + 6\,\nu_\infty + 3\,\varepsilon_2 + 4\,\varepsilon_3 \;\le\; 12 +
+[\mathrm{SL}_2(\mathbb{Z}) : \Gamma_0(N)],$$
+where the four summands are the quantities just listed in order, and the index is `Subgroup.index`.
+
+This is the signature form of the upper bound half of the Eichler–Shimura count for $\Gamma_0(N)$:
+after division by $12$ it says that the space of parabolic characters has dimension at most $2g$,
+where $g$ is the genus of $\Gamma_0(N)\backslash\mathbb{H}^*$ as computed from the Riemann–Hurwitz
+signature data (index, elliptic points of order $2$ and $3$, cusps). It is stated purely in terms of
+the permutation representation of $\mathrm{SL}_2(\mathbb{Z})$ on the cosets of $\Gamma_0(N)$, and is
+used by
+[`ModularCurve.finrank_parabolicHoms_le_two_mul_genusFormula`]
+(thm.html#ModularCurve.finrank_parabolicHoms_le_two_mul_genusFormula)
+to bound the dimension of parabolic homomorphisms by twice the genus formula.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_Period_six_mul_finrank_parabolicHoms_add_le_index.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_Period_six_mul_finrank_parabolicHoms_add_le_index
+
+namespace W7S
+
+open Module
+
+section Orbits
+
+variable {X : Type*} (σ : Equiv.Perm X)
+
+abbrev Orb : Type _ := MulAction.orbitRel.Quotient (Subgroup.zpowers σ) X
+
+def orbQ (x : X) : Orb σ := Quotient.mk (MulAction.orbitRel (Subgroup.zpowers σ) X) x
+
+theorem orbQ_surjective : Function.Surjective (orbQ σ) := by
+  rintro ⟨x⟩; exact ⟨x, rfl⟩
+
+theorem orbQ_apply_perm (x : X) : orbQ σ (σ x) = orbQ σ x := by
+  apply Quotient.sound
+  change σ x ∈ MulAction.orbit (Subgroup.zpowers σ) x
+  exact ⟨⟨σ, Subgroup.mem_zpowers σ⟩, rfl⟩
+
+theorem natCard_fixedBy_eq (τ : Equiv.Perm X) :
+    Nat.card (MulAction.fixedBy X τ) = Nat.card {x // τ x = x} :=
+  Nat.card_congr (Equiv.subtypeEquivRight fun x => by simp [MulAction.mem_fixedBy])
+
+theorem natCard_fixedBy_one : Nat.card (MulAction.fixedBy X (1 : Equiv.Perm X)) = Nat.card X := by
+  rw [natCard_fixedBy_eq]
+  exact Nat.card_congr (Equiv.subtypeUnivEquiv fun x => by simp)
+
+theorem sum_range_orderOf_natCard_fixedBy [Finite X] :
+    ∑ i ∈ Finset.range (orderOf σ), Nat.card (MulAction.fixedBy X (σ ^ i)) =
+      Nat.card (Orb σ) * orderOf σ := by
+  classical
+  let := Fintype.ofFinite X
+  have hfin : IsOfFinOrder σ := isOfFinOrder_of_finite σ
+  have hB := MulAction.sum_card_fixedBy_eq_card_orbits_mul_card_group (Subgroup.zpowers σ) X
+  rw [Fintype.card_zpowers] at hB
+  rw [← Nat.card_eq_fintype_card] at hB
+  rw [← Fin.sum_univ_eq_sum_range (fun i => Nat.card (MulAction.fixedBy X (σ ^ i))) (orderOf σ)]
+  rw [← hB]
+  rw [← Fintype.sum_equiv (finEquivZPowers hfin)
+    (fun i : Fin (orderOf σ) => Nat.card (MulAction.fixedBy X (σ ^ (i : ℕ))))
+    (fun a => Fintype.card (MulAction.fixedBy X a))]
+  intro i
+  rw [finEquivZPowers_apply, Nat.card_eq_fintype_card]
+  rfl
+
+theorem two_mul_natCard_orb [Finite X] (h2 : σ ^ 2 = 1) :
+    2 * Nat.card (Orb σ) = Nat.card X + Nat.card {x // σ x = x} := by
+  have hsum := sum_range_orderOf_natCard_fixedBy σ
+  have hdvd : orderOf σ ∣ 2 := orderOf_dvd_of_pow_eq_one h2
+  rcases (Nat.dvd_prime Nat.prime_two).mp hdvd with h1 | h2'
+  · have hσ : σ = 1 := orderOf_eq_one_iff.mp h1
+    subst hσ
+    rw [h1, Finset.sum_range_one, pow_zero, natCard_fixedBy_one, mul_one] at hsum
+    rw [← natCard_fixedBy_eq, natCard_fixedBy_one, hsum]; ring
+  · rw [h2', Finset.sum_range_succ, Finset.sum_range_one, pow_zero, pow_one, natCard_fixedBy_one,
+      natCard_fixedBy_eq] at hsum
+    omega
+
+theorem three_mul_natCard_orb [Finite X] (h3 : σ ^ 3 = 1) :
+    3 * Nat.card (Orb σ) = Nat.card X + 2 * Nat.card {x // σ x = x} := by
+  have hsum := sum_range_orderOf_natCard_fixedBy σ
+  have hdvd : orderOf σ ∣ 3 := orderOf_dvd_of_pow_eq_one h3
+  rcases (Nat.dvd_prime Nat.prime_three).mp hdvd with h1 | h3'
+  · have hσ : σ = 1 := orderOf_eq_one_iff.mp h1
+    subst hσ
+    rw [h1, Finset.sum_range_one, pow_zero, natCard_fixedBy_one, mul_one] at hsum
+    rw [← natCard_fixedBy_eq, natCard_fixedBy_one, hsum]; ring
+  · have hsq : Nat.card (MulAction.fixedBy X (σ ^ 2)) = Nat.card {x // σ x = x} := by
+      rw [natCard_fixedBy_eq]
+      refine Nat.card_congr (Equiv.subtypeEquivRight fun x => ?_)
+      constructor
+      · intro hx
+        have h3x : (σ ^ 3) x = x := by rw [h3]; rfl
+        calc σ x = σ ((σ ^ 2) x) := by rw [hx]
+          _ = (σ ^ 3) x := by simp [pow_succ]
+          _ = x := h3x
+      · intro hx
+        simp [sq, hx]
+    rw [h3', Finset.sum_range_succ, Finset.sum_range_succ, Finset.sum_range_one, pow_zero, pow_one,
+      natCard_fixedBy_one, natCard_fixedBy_eq, hsq] at hsum
+    omega
+
+end Orbits
+
+section ManinRel
+
+variable (K : Type*) [Field K] {X : Type*} (σ₂ σ₃ : Equiv.Perm X)
+
+def relSpace : Submodule K (X → K) where
+  carrier := {m | (∀ x, m x + m (σ₂ x) = 0) ∧ ∀ x, m x + m (σ₃ x) + m (σ₃ (σ₃ x)) = 0}
+  zero_mem' := ⟨fun x => by simp, fun x => by simp⟩
+  add_mem' := by
+    rintro m n ⟨hm2, hm3⟩ ⟨hn2, hn3⟩
+    refine ⟨fun x => ?_, fun x => ?_⟩
+    · simp only [Pi.add_apply]; linear_combination hm2 x + hn2 x
+    · simp only [Pi.add_apply]; linear_combination hm3 x + hn3 x
+  smul_mem' := by
+    rintro c m ⟨hm2, hm3⟩
+    refine ⟨fun x => ?_, fun x => ?_⟩
+    · simp only [Pi.smul_apply, smul_eq_mul]; rw [← mul_add, hm2 x, mul_zero]
+    · simp only [Pi.smul_apply, smul_eq_mul]; rw [← mul_add, ← mul_add, hm3 x, mul_zero]
+
+variable {K σ₂ σ₃} in
+theorem mem_relSpace {m : X → K} :
+    m ∈ relSpace K σ₂ σ₃ ↔
+      (∀ x, m x + m (σ₂ x) = 0) ∧ ∀ x, m x + m (σ₃ x) + m (σ₃ (σ₃ x)) = 0 :=
+  Iff.rfl
+
+variable [Fintype X]
+
+noncomputable def orbFun : ((Orb σ₂ → K) × (Orb σ₃ → K)) →ₗ[K] Module.Dual K (X → K) :=
+  LinearMap.mk₂ K
+    (fun ab m => ∑ x, m x * (ab.1 (orbQ σ₂ x) + ab.2 (orbQ σ₃ x)))
+    (fun ab ab' m => by
+      simp only [Prod.fst_add, Prod.snd_add, Pi.add_apply, ← Finset.sum_add_distrib]
+      refine Finset.sum_congr rfl fun x _ => by ring)
+    (fun c ab m => by
+      simp only [Prod.smul_fst, Prod.smul_snd, Pi.smul_apply, smul_eq_mul, Finset.mul_sum]
+      refine Finset.sum_congr rfl fun x _ => by ring)
+    (fun ab m m' => by
+      simp only [Pi.add_apply, ← Finset.sum_add_distrib]
+      refine Finset.sum_congr rfl fun x _ => by ring)
+    (fun c ab m => by
+      simp only [Pi.smul_apply, smul_eq_mul, Finset.mul_sum]
+      refine Finset.sum_congr rfl fun x _ => by ring)
+
+theorem orbFun_apply (ab : (Orb σ₂ → K) × (Orb σ₃ → K)) (m : X → K) :
+    orbFun K σ₂ σ₃ ab m = ∑ x, m x * (ab.1 (orbQ σ₂ x) + ab.2 (orbQ σ₃ x)) := rfl
+
+variable [CharZero K]
+
+theorem relSpace_le_dualCoannihilator :
+    relSpace K σ₂ σ₃ ≤ (LinearMap.range (orbFun K σ₂ σ₃)).dualCoannihilator := by
+  intro m hm
+  rw [mem_relSpace] at hm
+  obtain ⟨hm2, hm3⟩ := hm
+  rw [Submodule.mem_dualCoannihilator]
+  rintro _ ⟨⟨a, b⟩, rfl⟩
+  rw [orbFun_apply]
+  simp only [mul_add, Finset.sum_add_distrib]
+  have hA : ∑ x, m x * a (orbQ σ₂ x) = 0 := by
+    have hre : ∑ x, m (σ₂ x) * a (orbQ σ₂ (σ₂ x)) = ∑ x, m x * a (orbQ σ₂ x) :=
+      Equiv.sum_comp σ₂ (fun x => m x * a (orbQ σ₂ x))
+    simp only [orbQ_apply_perm] at hre
+    have h2s : (2 : K) * ∑ x, m x * a (orbQ σ₂ x) = 0 := by
+      rw [two_mul]
+      nth_rewrite 2 [← hre]
+      rw [← Finset.sum_add_distrib]
+      refine Finset.sum_eq_zero fun x _ => ?_
+      rw [← add_mul, hm2 x, zero_mul]
+    exact (mul_eq_zero.mp h2s).resolve_left two_ne_zero
+  have hB : ∑ x, m x * b (orbQ σ₃ x) = 0 := by
+    have hre1 : ∑ x, m (σ₃ x) * b (orbQ σ₃ (σ₃ x)) = ∑ x, m x * b (orbQ σ₃ x) :=
+      Equiv.sum_comp σ₃ (fun x => m x * b (orbQ σ₃ x))
+    have hre2 : ∑ x, m (σ₃ (σ₃ x)) * b (orbQ σ₃ (σ₃ (σ₃ x))) =
+        ∑ x, m (σ₃ x) * b (orbQ σ₃ (σ₃ x)) :=
+      Equiv.sum_comp σ₃ (fun x => m (σ₃ x) * b (orbQ σ₃ (σ₃ x)))
+    simp only [orbQ_apply_perm] at hre1 hre2
+    have h3s : (3 : K) * ∑ x, m x * b (orbQ σ₃ x) = 0 := by
+      have e3 : (3 : K) * ∑ x, m x * b (orbQ σ₃ x) =
+          ∑ x, m x * b (orbQ σ₃ x) + ∑ x, m (σ₃ x) * b (orbQ σ₃ x)
+            + ∑ x, m (σ₃ (σ₃ x)) * b (orbQ σ₃ x) := by
+        rw [hre2, hre1]; ring
+      rw [e3, ← Finset.sum_add_distrib, ← Finset.sum_add_distrib]
+      refine Finset.sum_eq_zero fun x _ => ?_
+      rw [← add_mul, ← add_mul, hm3 x, zero_mul]
+    exact (mul_eq_zero.mp h3s).resolve_left three_ne_zero
+  rw [hA, hB, add_zero]
+
+def Connected (σ₂ σ₃ : Equiv.Perm X) (K : Type*) : Prop :=
+  ∀ f : X → K, (∀ x, f (σ₂ x) = f x) → (∀ x, f (σ₃ x) = f x) → ∀ x y, f x = f y
+
+omit [CharZero K] in
+theorem ker_orbFun_le (hconn : Connected σ₂ σ₃ K) :
+    LinearMap.ker (orbFun K σ₂ σ₃) ≤
+      LinearMap.range (LinearMap.toSpanSingleton K _
+        ((fun _ => (1 : K), fun _ => (-1 : K)) : (Orb σ₂ → K) × (Orb σ₃ → K))) := by
+  classical
+  rintro ⟨a, b⟩ hab
+  rw [LinearMap.mem_ker] at hab
+  have hpt : ∀ x, a (orbQ σ₂ x) + b (orbQ σ₃ x) = 0 := by
+    intro x₀
+    have := LinearMap.congr_fun hab (fun x => if x = x₀ then 1 else 0)
+    rw [orbFun_apply, LinearMap.zero_apply] at this
+    simpa [ite_mul, Finset.sum_ite_eq'] using this
+  have hinv2 : ∀ x, a (orbQ σ₂ (σ₂ x)) = a (orbQ σ₂ x) := fun x => by rw [orbQ_apply_perm]
+  have hinv3 : ∀ x, a (orbQ σ₂ (σ₃ x)) = a (orbQ σ₂ x) := fun x => by
+    have e1 := hpt x
+    have e2 := hpt (σ₃ x)
+    rw [orbQ_apply_perm] at e2
+    linear_combination e2 - e1
+  have hconst := hconn (fun x => a (orbQ σ₂ x)) hinv2 hinv3
+  rw [LinearMap.mem_range]
+  rcases isEmpty_or_nonempty X with hX | ⟨⟨x₀⟩⟩
+  · refine ⟨0, ?_⟩
+    ext y
+    · exact (hX.false (orbQ_surjective σ₂ y).choose).elim
+    · exact (hX.false (orbQ_surjective σ₃ y).choose).elim
+  refine ⟨a (orbQ σ₂ x₀), ?_⟩
+  ext y
+  · obtain ⟨x, rfl⟩ := orbQ_surjective σ₂ y
+    simp [LinearMap.toSpanSingleton_apply, hconst x x₀]
+  · obtain ⟨x, rfl⟩ := orbQ_surjective σ₃ y
+    have := hpt x
+    simp only [LinearMap.toSpanSingleton_apply, Prod.smul_snd, Pi.smul_apply, smul_eq_mul,
+      mul_neg, mul_one]
+    have hc : a (orbQ σ₂ x₀) = a (orbQ σ₂ x) := hconst x₀ x
+    rw [hc]; linear_combination (-1 : K) * this
+
+omit [Fintype X] in
+theorem relSpace_rank_bound [Finite X]
+    (h2 : σ₂ ^ 2 = 1) (h3 : σ₃ ^ 3 = 1) (hconn : Connected σ₂ σ₃ K) :
+    6 * Module.finrank K (relSpace K σ₂ σ₃) + 3 * Nat.card {x // σ₂ x = x}
+        + 4 * Nat.card {x // σ₃ x = x} ≤ 6 + Nat.card X := by
+  classical
+  let := Fintype.ofFinite X
+  have hO2 := two_mul_natCard_orb σ₂ h2
+  have hO3 := three_mul_natCard_orb σ₃ h3
+  have hco := Subspace.finrank_add_finrank_dualCoannihilator_eq
+    (LinearMap.range (orbFun K σ₂ σ₃))
+  have hV : Module.finrank K (relSpace K σ₂ σ₃) ≤
+      Module.finrank K (LinearMap.range (orbFun K σ₂ σ₃)).dualCoannihilator :=
+    Submodule.finrank_mono (relSpace_le_dualCoannihilator K σ₂ σ₃)
+  have hXK : Module.finrank K (X → K) = Nat.card X := by
+    rw [Module.finrank_fintype_fun_eq_card, Nat.card_eq_fintype_card]
+  have hrn := LinearMap.finrank_range_add_finrank_ker (orbFun K σ₂ σ₃)
+  have hdom : Module.finrank K ((Orb σ₂ → K) × (Orb σ₃ → K)) =
+      Nat.card (Orb σ₂) + Nat.card (Orb σ₃) := by
+    rw [Module.finrank_prod, Module.finrank_fintype_fun_eq_card, Module.finrank_fintype_fun_eq_card,
+      Nat.card_eq_fintype_card, Nat.card_eq_fintype_card]
+  have hker : Module.finrank K (LinearMap.ker (orbFun K σ₂ σ₃)) ≤ 1 := by
+    refine (Submodule.finrank_mono (ker_orbFun_le K σ₂ σ₃ hconn)).trans ?_
+    refine (LinearMap.finrank_range_le _).trans ?_
+    rw [Module.finrank_self]
+  omega
+
+end ManinRel
+
+section Potential
+
+open Matrix Matrix.SpecialLinearGroup ModularGroup CongruenceSubgroup OnePoint
+open ModularCurve ModularCurve.Period
+open scoped MatrixGroups
+
+theorem smul_infty_eq_iff (γ : SL(2, ℤ)) :
+    mapGL ℚ γ • (∞ : OnePoint ℚ) = ∞ ↔ γ 1 0 = 0 := by
+  rw [OnePoint.smul_infty_eq_self_iff]
+  simp
+
+theorem trace_sq_of_lower_left (γ : SL(2, ℤ)) (h : γ 1 0 = 0) :
+    (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ^ 2 = 4 := by
+  have hdet := Matrix.det_fin_two (γ : Matrix (Fin 2) (Fin 2) ℤ)
+  rw [γ.det_coe, h, mul_zero, sub_zero] at hdet
+  rw [Matrix.trace_fin_two]
+  rcases Int.eq_one_or_neg_one_of_mul_eq_one' hdet.symm with ⟨h1, h2⟩ | ⟨h1, h2⟩ <;>
+    rw [h1, h2] <;> norm_num
+
+theorem trace_conj (σ δ : SL(2, ℤ)) :
+    ((σ⁻¹ * δ * σ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace =
+      (δ : Matrix (Fin 2) (Fin 2) ℤ).trace := by
+  rw [coe_mul, coe_mul, Matrix.trace_mul_cycle, ← coe_mul, mul_inv_cancel,
+    Matrix.SpecialLinearGroup.coe_one, one_mul]
+
+theorem neg_one_lower : (-1 : SL(2, ℤ)) 1 0 = 0 := by simp
+
+theorem T_inv_lower : (T⁻¹ : SL(2, ℤ)) 1 0 = 0 := by rw [coe_T_inv]; rfl
+
+theorem T_lower : (T : SL(2, ℤ)) 1 0 = 0 := by rw [coe_T]; rfl
+
+theorem S_inv_eq : (S : SL(2, ℤ))⁻¹ = S * (-1) :=
+  inv_eq_of_mul_eq_one_right (by decide)
+
+theorem ST_inv_mul_S : (S * T : SL(2, ℤ))⁻¹ * S = T⁻¹ := by group
+
+theorem ST_cube : (S * T : SL(2, ℤ)) * (S * T) * (S * T) = -1 := by decide
+
+theorem ST_inv_mul_ST_inv : (S * T : SL(2, ℤ))⁻¹ * (S * T)⁻¹ = S * T * (-1) := by
+  calc ((S * T : SL(2, ℤ))⁻¹ * (S * T)⁻¹)
+      = (S * T) * ((S * T) * (S * T) * (S * T))⁻¹ := by group
+    _ = S * T * (-1) := by rw [ST_cube]; simp
+
+theorem neg_one_mem_Gamma0 (N : ℕ) : (-1 : SL(2, ℤ)) ∈ Gamma0 N := by simp [Gamma0_mem]
+
+variable (Γ : Subgroup SL(2, ℤ)) {K : Type*} [Field K]
+
+open Classical in
+noncomputable def Phi (φ : Additive Γ →+ K) (g : SL(2, ℤ)) : K :=
+  if h : g ∈ Γ then φ (Additive.ofMul ⟨g, h⟩) else 0
+
+theorem Phi_of_mem (φ : Additive Γ →+ K) {g : SL(2, ℤ)} (h : g ∈ Γ) :
+    Phi Γ φ g = φ (Additive.ofMul ⟨g, h⟩) := dite_eq_left h
+
+theorem Phi_mul (φ : Additive Γ →+ K) {g h : SL(2, ℤ)} (hg : g ∈ Γ) (hh : h ∈ Γ) :
+    Phi Γ φ (g * h) = Phi Γ φ g + Phi Γ φ h := by
+  rw [Phi_of_mem Γ φ (mul_mem hg hh), Phi_of_mem Γ φ hg, Phi_of_mem Γ φ hh, ← map_add]
+  rfl
+
+theorem Phi_one (φ : Additive Γ →+ K) : Phi Γ φ 1 = 0 := by
+  rw [Phi_of_mem Γ φ (one_mem Γ)]
+  exact map_zero φ
+
+theorem Phi_inv (φ : Additive Γ →+ K) {g : SL(2, ℤ)} (hg : g ∈ Γ) :
+    Phi Γ φ g⁻¹ = -Phi Γ φ g := by
+  have h := Phi_mul Γ φ (inv_mem hg) hg
+  rw [inv_mul_cancel, Phi_one] at h
+  linear_combination -h
+
+theorem Phi_add (φ ψ : Additive Γ →+ K) (g : SL(2, ℤ)) :
+    Phi Γ (φ + ψ) g = Phi Γ φ g + Phi Γ ψ g := by
+  unfold Phi
+  split_ifs <;> simp
+
+theorem Phi_smul (c : K) (φ : Additive Γ →+ K) (g : SL(2, ℤ)) :
+    Phi Γ (c • φ) g = c * Phi Γ φ g := by
+  unfold Phi
+  split_ifs <;> simp
+
+theorem Phi_parabolic {φ : Additive Γ →+ K} (hφ : IsParabolicHom Γ φ) {g : SL(2, ℤ)} (hg : g ∈ Γ)
+    (htr : (g : Matrix (Fin 2) (Fin 2) ℤ).trace ^ 2 = 4) : Phi Γ φ g = 0 := by
+  rw [Phi_of_mem Γ φ hg]
+  exact hφ ⟨g, hg⟩ htr
+
+variable (N : ℕ)
+
+noncomputable def rep (C : CuspSpace N) : OnePoint ℚ := (CuspSpace.mk_surjective N C).choose
+
+theorem mk_rep (C : CuspSpace N) : CuspSpace.mk N (rep N C) = C :=
+  (CuspSpace.mk_surjective N C).choose_spec
+
+theorem exists_gam (a : OnePoint ℚ) :
+    ∃ γ ∈ Gamma0 N, mapGL ℚ γ • rep N (CuspSpace.mk N a) = a :=
+  CuspSpace.mk_eq_mk_iff.mp (mk_rep N _).symm
+
+noncomputable def gam (a : OnePoint ℚ) : SL(2, ℤ) := (exists_gam N a).choose
+
+theorem gam_mem (a : OnePoint ℚ) : gam N a ∈ Gamma0 N := (exists_gam N a).choose_spec.1
+
+theorem gam_smul (a : OnePoint ℚ) : mapGL ℚ (gam N a) • rep N (CuspSpace.mk N a) = a :=
+  (exists_gam N a).choose_spec.2
+
+noncomputable def Gpot (φ : Additive (Gamma0 N) →+ K) (c : CuspSpace N → K) (a : OnePoint ℚ) : K :=
+  Phi (Gamma0 N) φ (gam N a) + c (CuspSpace.mk N a)
+
+variable {N}
+
+theorem Phi_eq_zero_of_fix {φ : Additive (Gamma0 N) →+ K} (hφ : IsParabolicHom (Gamma0 N) φ)
+    {δ : SL(2, ℤ)} (hδ : δ ∈ Gamma0 N) {r : OnePoint ℚ} (hfix : mapGL ℚ δ • r = r) :
+    Phi (Gamma0 N) φ δ = 0 := by
+  classical
+  obtain ⟨σ, rfl⟩ := OnePoint.exists_mem_SL2 ℤ r
+  have h10 : (σ⁻¹ * δ * σ) 1 0 = 0 := by
+    rw [← smul_infty_eq_iff, map_mul, map_mul, mul_smul, mul_smul, hfix, ← mul_smul, ← map_mul,
+      inv_mul_cancel, map_one, one_smul]
+  have htr := trace_sq_of_lower_left _ h10
+  rw [trace_conj] at htr
+  exact Phi_parabolic _ hφ hδ htr
+
+theorem Gpot_smul {φ : Additive (Gamma0 N) →+ K} (hφ : IsParabolicHom (Gamma0 N) φ)
+    (c : CuspSpace N → K) {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 N) (a : OnePoint ℚ) :
+    Gpot N φ c (mapGL ℚ γ • a) = Phi (Gamma0 N) φ γ + Gpot N φ c a := by
+  have hmk : CuspSpace.mk N (mapGL ℚ γ • a) = CuspSpace.mk N a := CuspSpace.mk_smul hγ a
+  unfold Gpot
+  rw [hmk]
+  have ha := gam_smul N a
+  have hb := gam_smul N (mapGL ℚ γ • a)
+  rw [hmk] at hb
+  have hfix : mapGL ℚ ((gam N (mapGL ℚ γ • a))⁻¹ * γ * gam N a) • rep N (CuspSpace.mk N a) =
+      rep N (CuspSpace.mk N a) := by
+    rw [map_mul, map_mul, mul_smul, mul_smul, ha, map_inv, inv_smul_eq_iff]
+    exact hb.symm
+  have h0 := Phi_eq_zero_of_fix hφ
+    (mul_mem (mul_mem (inv_mem (gam_mem N _)) hγ) (gam_mem N a)) hfix
+  rw [Phi_mul _ _ (mul_mem (inv_mem (gam_mem N _)) hγ) (gam_mem N a),
+    Phi_mul _ _ (inv_mem (gam_mem N _)) hγ, Phi_inv _ _ (gam_mem N _)] at h0
+  linear_combination (-1 : K) * h0
+
+variable (N)
+
+noncomputable def Ppot (φ : Additive (Gamma0 N) →+ K) (c : CuspSpace N → K) (g : SL(2, ℤ)) : K :=
+  Gpot N φ c (mapGL ℚ g • ∞)
+
+variable {N}
+
+theorem Ppot_mul_left {φ : Additive (Gamma0 N) →+ K} (hφ : IsParabolicHom (Gamma0 N) φ)
+    (c : CuspSpace N → K) {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 N) (g : SL(2, ℤ)) :
+    Ppot N φ c (γ * g) = Phi (Gamma0 N) φ γ + Ppot N φ c g := by
+  unfold Ppot
+  rw [map_mul, mul_smul, Gpot_smul hφ c hγ]
+
+theorem Ppot_mul_right (φ : Additive (Gamma0 N) →+ K) (c : CuspSpace N → K) (g : SL(2, ℤ))
+    {k : SL(2, ℤ)} (hk : k 1 0 = 0) : Ppot N φ c (g * k) = Ppot N φ c g := by
+  unfold Ppot
+  rw [map_mul, mul_smul, (smul_infty_eq_iff k).mpr hk]
+
+variable (N)
+
+noncomputable def nSL (φ : Additive (Gamma0 N) →+ K) (c : CuspSpace N → K) (g : SL(2, ℤ)) : K :=
+  Ppot N φ c g⁻¹ - Ppot N φ c (g⁻¹ * S)
+
+noncomputable def nX (φ : Additive (Gamma0 N) →+ K) (c : CuspSpace N → K)
+    (x : SL(2, ℤ) ⧸ Gamma0 N) : K :=
+  nSL N φ c (Quotient.out x)
+
+variable {N}
+
+theorem nX_mk {φ : Additive (Gamma0 N) →+ K} (hφ : IsParabolicHom (Gamma0 N) φ)
+    (c : CuspSpace N → K) (g : SL(2, ℤ)) :
+    nX N φ c (g : SL(2, ℤ) ⧸ Gamma0 N) = nSL N φ c g := by
+  obtain ⟨γ, hγ⟩ := QuotientGroup.mk_out_eq_mul (Gamma0 N) g
+  unfold nX
+  rw [hγ]
+  unfold nSL
+  rw [_root_.mul_inv_rev, mul_assoc, Ppot_mul_left hφ c (inv_mem γ.2), Ppot_mul_left hφ c (inv_mem
+    γ.2)]
+  ring
+
+theorem nSL_two_term (φ : Additive (Gamma0 N) →+ K) (c : CuspSpace N → K) (g : SL(2, ℤ)) :
+    nSL N φ c (S * g) + nSL N φ c g = 0 := by
+  unfold nSL
+  rw [_root_.mul_inv_rev, inv_mul_cancel_right, S_inv_eq, ← mul_assoc,
+    Ppot_mul_right φ c _ neg_one_lower]
+  ring
+
+theorem nSL_three_term (φ : Additive (Gamma0 N) →+ K) (c : CuspSpace N → K) (g : SL(2, ℤ)) :
+    nSL N φ c g + nSL N φ c (S * T * g) + nSL N φ c (S * T * (S * T * g)) = 0 := by
+  unfold nSL
+  have e1 : (S * T * g)⁻¹ = g⁻¹ * (S * T)⁻¹ := by group
+  have e2 : (S * T * (S * T * g))⁻¹ = g⁻¹ * (S * T)⁻¹ * (S * T)⁻¹ := by group
+  have hA : Ppot N φ c (g⁻¹ * (S * T)⁻¹ * S) = Ppot N φ c g⁻¹ := by
+    rw [mul_assoc, ST_inv_mul_S, Ppot_mul_right φ c _ T_inv_lower]
+  have hB : Ppot N φ c (g⁻¹ * (S * T)⁻¹ * (S * T)⁻¹ * S) = Ppot N φ c (g⁻¹ * (S * T)⁻¹) := by
+    rw [mul_assoc _ _ S, ST_inv_mul_S, Ppot_mul_right φ c _ T_inv_lower]
+  have hC : Ppot N φ c (g⁻¹ * (S * T)⁻¹ * (S * T)⁻¹) = Ppot N φ c (g⁻¹ * S) := by
+    rw [mul_assoc g⁻¹, ST_inv_mul_ST_inv, ← mul_assoc, Ppot_mul_right φ c _ neg_one_lower,
+      ← mul_assoc, Ppot_mul_right φ c _ T_lower]
+  rw [e1, e2, hA, hB, hC]
+  ring
+
+theorem nX_add (φ ψ : Additive (Gamma0 N) →+ K) (c d : CuspSpace N → K) (x : SL(2, ℤ) ⧸ Gamma0 N) :
+    nX N (φ + ψ) (c + d) x = nX N φ c x + nX N ψ d x := by
+  simp only [nX, nSL, Ppot, Gpot, Phi_add, Pi.add_apply]
+  ring
+
+theorem nX_smul (r : K) (φ : Additive (Gamma0 N) →+ K) (c : CuspSpace N → K)
+    (x : SL(2, ℤ) ⧸ Gamma0 N) :
+    nX N (r • φ) (r • c) x = r * nX N φ c x := by
+  simp only [nX, nSL, Ppot, Gpot, Phi_smul, Pi.smul_apply, smul_eq_mul]
+  ring
+
+variable (N)
+
+abbrev X : Type := SL(2, ℤ) ⧸ Gamma0 N
+
+noncomputable def sig2 : Equiv.Perm (X N) := MulAction.toPerm (S : SL(2, ℤ))
+
+noncomputable def sig3 : Equiv.Perm (X N) := MulAction.toPerm (S * T : SL(2, ℤ))
+
+theorem sig2_apply (x : X N) : sig2 N x = (S : SL(2, ℤ)) • x := rfl
+
+theorem sig3_apply (x : X N) : sig3 N x = (S * T : SL(2, ℤ)) • x := rfl
+
+theorem mk_neg_one_mul (g : SL(2, ℤ)) : ((-1 * g : SL(2, ℤ)) : X N) = (g : X N) := by
+  rw [neg_one_mul, ← mul_neg_one]
+  symm
+  rw [QuotientGroup.eq, inv_mul_cancel_left]
+  exact neg_one_mem_Gamma0 N
+
+theorem sig2_sq : sig2 N ^ 2 = 1 := by
+  ext x
+  induction x using QuotientGroup.induction_on with
+  | H g =>
+    rw [sq, Equiv.Perm.mul_apply, sig2_apply, sig2_apply, MulAction.Quotient.smul_mk,
+      MulAction.Quotient.smul_mk, Equiv.Perm.one_apply, smul_eq_mul, smul_eq_mul, ← mul_assoc,
+      show (S : SL(2, ℤ)) * S = -1 by decide, mk_neg_one_mul]
+
+theorem sig3_cube : sig3 N ^ 3 = 1 := by
+  ext x
+  induction x using QuotientGroup.induction_on with
+  | H g =>
+    rw [pow_three, Equiv.Perm.mul_apply, Equiv.Perm.mul_apply, sig3_apply, sig3_apply, sig3_apply,
+      MulAction.Quotient.smul_mk, MulAction.Quotient.smul_mk, MulAction.Quotient.smul_mk,
+      Equiv.Perm.one_apply, smul_eq_mul, smul_eq_mul, smul_eq_mul, ← mul_assoc, ← mul_assoc,
+      ST_cube, mk_neg_one_mul]
+
+omit [Field K] in
+theorem connected : Connected (sig2 N) (sig3 N) K := by
+  intro f h2 h3 x y
+  have hS : ∀ x : X N, f ((S : SL(2, ℤ)) • x) = f x := h2
+  have hSinv : ∀ x : X N, f ((S : SL(2, ℤ))⁻¹ • x) = f x := fun x => by
+    rw [← hS ((S : SL(2, ℤ))⁻¹ • x), smul_inv_smul]
+  have hT : ∀ x : X N, f ((T : SL(2, ℤ)) • x) = f x := fun x => by
+    have : (T : SL(2, ℤ)) = S⁻¹ * (S * T) := by group
+    rw [this, mul_smul, hSinv]
+    exact h3 x
+  have key : ∀ k : SL(2, ℤ), k ∈ Subgroup.closure ({S, T} : Set SL(2, ℤ)) →
+      ∀ x : X N, f (k • x) = f x := by
+    intro k hk
+    refine Subgroup.closure_induction (p := fun k _ => ∀ x : X N, f (k • x) = f x)
+      ?_ ?_ ?_ ?_ hk
+    · intro k hk x
+      rcases hk with rfl | rfl
+      · exact hS x
+      · exact hT x
+    · intro x; rw [one_smul]
+    · intro a b _ _ ha hb x
+      rw [mul_smul, ha, hb]
+    · intro a _ ha x
+      rw [← ha (a⁻¹ • x), smul_inv_smul]
+  have hall : ∀ k : SL(2, ℤ), ∀ x : X N, f (k • x) = f x := fun k =>
+    key k (SpecialLinearGroup.SL2Z_generators ▸ Subgroup.mem_top k)
+  induction x using QuotientGroup.induction_on with
+  | H g =>
+    induction y using QuotientGroup.induction_on with
+    | H g' =>
+      have e1 := hall g ((1 : SL(2, ℤ)) : X N)
+      have e2 := hall g' ((1 : SL(2, ℤ)) : X N)
+      rw [MulAction.Quotient.smul_mk, smul_eq_mul, mul_one] at e1 e2
+      rw [e1, e2]
+
+variable (K)
+
+abbrev W : Type _ := ↥(parabolicHoms K (Gamma0 N) K) × (CuspSpace N → K)
+
+noncomputable def theta : W K N →ₗ[K] (X N → K) where
+  toFun w := fun x => nX N (w.1 : Additive (Gamma0 N) →+ K) w.2 x
+  map_add' w w' := by
+    ext x
+    simp only [Prod.fst_add, Prod.snd_add, Submodule.coe_add, Pi.add_apply, nX_add]
+  map_smul' r w := by
+    ext x
+    simp only [Prod.smul_fst, Prod.smul_snd, Submodule.coe_smul, Pi.smul_apply, smul_eq_mul,
+      RingHom.id_apply, nX_smul]
+
+theorem theta_apply (w : W K N) (x : X N) :
+    theta K N w x = nX N (w.1 : Additive (Gamma0 N) →+ K) w.2 x := rfl
+
+theorem theta_mem (w : W K N) : theta K N w ∈ relSpace K (sig2 N) (sig3 N) := by
+  have hφ : IsParabolicHom (Gamma0 N) (w.1 : Additive (Gamma0 N) →+ K) := w.1.2
+  rw [mem_relSpace]
+  constructor
+  · intro x
+    induction x using QuotientGroup.induction_on with
+    | H g =>
+      rw [sig2_apply, MulAction.Quotient.smul_mk, smul_eq_mul, theta_apply, theta_apply,
+        nX_mk hφ, nX_mk hφ, add_comm]
+      exact nSL_two_term _ _ g
+  · intro x
+    induction x using QuotientGroup.induction_on with
+    | H g =>
+      rw [sig3_apply, MulAction.Quotient.smul_mk, smul_eq_mul, sig3_apply,
+        MulAction.Quotient.smul_mk, smul_eq_mul, theta_apply, theta_apply, theta_apply,
+        nX_mk hφ, nX_mk hφ, nX_mk hφ]
+      exact nSL_three_term _ _ g
+
+noncomputable def thetaPlus : W K N →ₗ[K] ↥(relSpace K (sig2 N) (sig3 N)) × K :=
+  (LinearMap.codRestrict _ (theta K N) (theta_mem K N)).prod
+    ((LinearMap.proj (CuspSpace.mk N ∞)).comp (LinearMap.snd K _ _))
+
+theorem thetaPlus_injective : Function.Injective (thetaPlus K N) := by
+  classical
+  rw [injective_iff_map_eq_zero]
+  rintro ⟨⟨φ, hφmem⟩, c⟩ hw
+  have hφ : IsParabolicHom (Gamma0 N) φ := hφmem
+  have hθx : ∀ x : X N, nX N φ c x = 0 := fun x =>
+    congr_arg (fun p : ↥(relSpace K (sig2 N) (sig3 N)) × K => (p.1 : X N → K) x) hw
+  have hcinf : c (CuspSpace.mk N ∞) = 0 :=
+    congr_arg (fun p : ↥(relSpace K (sig2 N) (sig3 N)) × K => p.2) hw
+  have hPS : ∀ h : SL(2, ℤ), Ppot N φ c (h * S) = Ppot N φ c h := fun h => by
+    have e := hθx ((h⁻¹ : SL(2, ℤ)) : X N)
+    rw [nX_mk hφ, nSL, inv_inv] at e
+    linear_combination -e
+  have hPT : ∀ h : SL(2, ℤ), Ppot N φ c (h * T) = Ppot N φ c h := fun h =>
+    Ppot_mul_right φ c h T_lower
+  have key : ∀ k : SL(2, ℤ), k ∈ Subgroup.closure ({S, T} : Set SL(2, ℤ)) →
+      ∀ h : SL(2, ℤ), Ppot N φ c (h * k) = Ppot N φ c h := by
+    intro k hk
+    refine Subgroup.closure_induction (p := fun k _ => ∀ h, Ppot N φ c (h * k) = Ppot N φ c h)
+      ?_ ?_ ?_ ?_ hk
+    · intro k hk h
+      rcases hk with rfl | rfl
+      · exact hPS h
+      · exact hPT h
+    · intro h; rw [mul_one]
+    · intro a b _ _ ha hb h
+      rw [← mul_assoc, hb, ha]
+    · intro a _ ha h
+      rw [← ha (h * a⁻¹), inv_mul_cancel_right]
+  have hconst : ∀ k : SL(2, ℤ), Ppot N φ c k = Ppot N φ c 1 := fun k => by
+    have := key k (SpecialLinearGroup.SL2Z_generators ▸ Subgroup.mem_top k) 1
+    rwa [one_mul] at this
+  have hPhi : ∀ γ : SL(2, ℤ), γ ∈ Gamma0 N → Phi (Gamma0 N) φ γ = 0 := fun γ hγ => by
+    have e := Ppot_mul_left hφ c hγ 1
+    rw [mul_one, hconst γ] at e
+    linear_combination -e
+  have hφ0 : φ = 0 := AddMonoidHom.ext fun a => by
+    have e := hPhi ((Additive.toMul a : Gamma0 N) : SL(2, ℤ)) (Additive.toMul a).2
+    rw [Phi_of_mem] at e
+    exact e
+  have hcval : ∀ σ : SL(2, ℤ), c (CuspSpace.mk N (mapGL ℚ σ • ∞)) = Ppot N φ c 1 := fun σ => by
+    rw [← hconst σ, Ppot, Gpot, hPhi _ (gam_mem N _), zero_add]
+  have hP1 : Ppot N φ c 1 = 0 := by
+    rw [← hcinf, ← hcval 1, map_one, one_smul]
+  have hc0 : c = 0 := by
+    funext C
+    obtain ⟨a, rfl⟩ := CuspSpace.mk_surjective N C
+    obtain ⟨σ, rfl⟩ := OnePoint.exists_mem_SL2 ℤ a
+    rw [hcval σ, hP1, Pi.zero_apply]
+  subst hφ0 hc0
+  rfl
+
+variable [NeZero N]
+
+scoped instance : Module.Finite K (W K N) :=
+  Module.Finite.of_injective (thetaPlus K N) (thetaPlus_injective K N)
+
+scoped instance : Module.Finite K ↥(parabolicHoms K (Gamma0 N) K) :=
+  Module.Finite.of_injective (LinearMap.inl K _ (CuspSpace N → K)) LinearMap.inl_injective
+
+theorem finrank_W_le :
+    Module.finrank K ↥(parabolicHoms K (Gamma0 N) K) + Nat.card (CuspSpace N) ≤
+      Module.finrank K ↥(relSpace K (sig2 N) (sig3 N)) + 1 := by
+  classical
+  let := Fintype.ofFinite (CuspSpace N)
+  have h := LinearMap.finrank_le_finrank_of_injective (thetaPlus_injective K N)
+  rw [Module.finrank_prod, Module.finrank_prod, Module.finrank_self,
+    Module.finrank_fintype_fun_eq_card, ← Nat.card_eq_fintype_card] at h
+  exact h
+
+theorem engine (N : ℕ) [NeZero N] (K : Type*) [Field K] [CharZero K] :
+    6 * Module.finrank K (ModularCurve.Period.parabolicHoms K (CongruenceSubgroup.Gamma0 N) K)
+        + 6 * Nat.card (ModularCurve.CuspSpace N)
+        + 3 * Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N // ModularGroup.S • x = x}
+        + 4 * Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N //
+            (ModularGroup.S * ModularGroup.T) • x = x} ≤
+      12 + (CongruenceSubgroup.Gamma0 N).index := by
+  classical
+  let : Fintype (X N) := Fintype.ofFinite _
+  have hR := relSpace_rank_bound K (sig2 N) (sig3 N) (sig2_sq N) (sig3_cube N) (connected N)
+  have hW := finrank_W_le K N
+  have hidx : (CongruenceSubgroup.Gamma0 N).index = Nat.card (X N) := rfl
+  have e2 : Nat.card {x : X N // sig2 N x = x} =
+      Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N // ModularGroup.S • x = x} := rfl
+  have e3 : Nat.card {x : X N // sig3 N x = x} =
+      Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N //
+        (ModularGroup.S * ModularGroup.T) • x = x} := rfl
+  rw [e2, e3] at hR
+  rw [hidx]
+  omega
+
+end Potential
+
+end W7S
+
+open scoped MatrixGroups in
+theorem solution (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [CharZero K] :
+    6 * Module.finrank K (ModularCurve.Period.parabolicHoms K (CongruenceSubgroup.Gamma0 N) K)
+        + 6 * Nat.card (ModularCurve.CuspSpace N)
+        + 3 * Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N // ModularGroup.S • x = x}
+        + 4 * Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N //
+            (ModularGroup.S * ModularGroup.T) • x = x} ≤
+      12 + (CongruenceSubgroup.Gamma0 N).index :=
+  W7S.engine N K
+
+end S_ModularCurve_Period_six_mul_finrank_parabolicHoms_add_le_index
+end P2MW
+export P2MW.S_ModularCurve_Period_six_mul_finrank_parabolicHoms_add_le_index (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.Period.six_mul_finrank_parabolicHoms_add_le_index (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [CharZero K] :
+    6 * Module.finrank K (ModularCurve.Period.parabolicHoms K (CongruenceSubgroup.Gamma0 N) K)
+        + 6 * Nat.card (ModularCurve.CuspSpace N)
+        + 3 * Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N // ModularGroup.S • x = x}
+        + 4 * Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N //
+            (ModularGroup.S * ModularGroup.T) • x = x} ≤
+      12 + (CongruenceSubgroup.Gamma0 N).index :=
+  solution N K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_PhiGenDescends_c_eq_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_PhiGenDescends_c_eq_zero.lean
new file mode 100644
index 0000000000..5ebd654e39
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_PhiGenDescends_c_eq_zero.lean
@@ -0,0 +1,404 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.PhiGenDescends.c_eq_zero
+(51d81ec6-fd61-5d61-b37b-89a26b0b5480) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3445e94f-4148-58e8-a035-05e3e123d6c1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_injective
+import Mathlib.Algebra.BigOperators.Fin
+import Mathlib.Algebra.Polynomial.Eval.Degree
+import Mathlib.Tactic.Linarith
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Vanishing of descended coefficients above degree ℓ+1
+
+Theorem statement: `ModularCurve.PhiGen.PhiGenDescends.c_eq_zero`
+(`51d81ec6-fd61-5d61-b37b-89a26b0b5480`), by Claude, 2026-09-05.
+
+Proof: submission `3445e94f-4148-58e8-a035-05e3e123d6c1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field equipped with a $\mathbb{Q}$-algebra structure, let $\ell$ be a prime, let
+$\zeta$ be a unit of $K$, and let $c \colon \mathbb{N} \to \mathrm{LaurentSeries}\,\mathbb{Q}$ be a
+family of rational Laurent series. Assume `PhiGenDescends ℓ ζ c`, that is: for every $k \in
+\mathbb{N}$, the coefficient of $X^k$ in the polynomial $\prod_{i \in \mathrm{Fin}(\ell+1)} \bigl(X
+- \mathrm{C}(\mathtt{conj}\ \ell\ \zeta\ i)\bigr)$ over $\mathrm{LaurentSeries}\,K$ — where the
+$i$-th root `conj ℓ ζ i` is the coset substitution determined by $\zeta$ and the data `cosetA ℓ i`,
+`cosetB ℓ i` applied to the image of `jq` under the coefficientwise map `coeffEmb K` induced by
+$\mathbb{Q} \to K$ — equals `coeffEmb K (qExpand ℚ ℓ (c k))`, the image in
+$\mathrm{LaurentSeries}\,K$ of the $\ell$-fold $q$-expansion rescaling of $c\,k$ (the ring
+endomorphism of Laurent series multiplying all exponents by $\ell$). Then for every $k$ with $\ell +
+1 < k$ one has $c\,k = 0$.
+
+This records that a family of rational Laurent series descending the product of the $\ell+1$
+conjugates is supported in degrees at most $\ell+1$, the product being a monic polynomial of degree
+$\ell+1$; it is the degree bound used in the construction of the modular polynomial data, and it is
+cited by
+[`ModularCurve.PhiGen.exists_modularPolynomialData_coeff_eq`]
+(thm.html#ModularCurve.PhiGen.exists_modularPolynomialData_coeff_eq).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_PhiGenDescends_c_eq_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_PhiGenDescends_c_eq_zero
+
+noncomputable section
+
+open Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_qExpand algebraMap_apply_eq_single jq coeff_jq_pow_self coeff_jq_pow_of_lt \
+  coeff_jq_of_lt jqN evalAtJ qTwist qTwist_coeff PoleOrderLE PhiGen.PhiGenDescends coeffMap \
+  coeffEmb coeffEmb_coeff coeffMap_qExpand coeffEmb_injective"
+p2m_open "ModularCurve"
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd phiProd_monic phiProd_natDegree \
+  phiProd_eval_conj TPoleOrderLE tPoleOrderLE_iff_poleOrderLE JSimplePole PhiGenDescends"
+p2m_open "ModularCurve.PhiGen"
+
+section CoeffEmbJq
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+private theorem coeff_coeffEmb_jq_of_lt {k : ℤ} (hk : k < -1) : (coeffEmb K jq).coeff k = 0 := by
+  rw [coeffEmb_coeff, coeff_jq_of_lt hk, map_zero]
+
+end CoeffEmbJq
+
+theorem jSimplePole_jqK {K : Type*} [Field K] [Algebra ℚ K] : JSimplePole (coeffEmb K jq) :=
+  fun _ hm => coeff_coeffEmb_jq_of_lt K hm
+
+theorem tPoleOrderLE_coeffEmb_iff {K : Type*} [Field K] [Algebra ℚ K]
+    (f : LaurentSeries ℚ) (n : ℕ) :
+    TPoleOrderLE (coeffEmb K f) n ↔ TPoleOrderLE f n := by
+  constructor
+  · intro h m hm
+    have h0 := h m hm
+    rw [coeffEmb_coeff] at h0
+    exact FaithfulSMul.algebraMap_injective ℚ K (by rw [h0, map_zero])
+  · intro h m hm
+    rw [coeffEmb_coeff, h m hm, map_zero]
+
+theorem tPoleOrderLE_of_qExpand {K : Type*} [Field K] {f : LaurentSeries K} {N n : ℕ}
+    [NeZero N] (h : TPoleOrderLE (qExpand K N f) (N * n)) : TPoleOrderLE f n := by
+  intro m hm
+  rw [← qExpand_coeff_mul N f m]
+  refine h _ ?_
+  push_cast
+  have hN : 0 < (N : ℤ) := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  nlinarith
+
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.mono {K : Type*} [Field K]
+    {f : LaurentSeries K} {m n : ℕ}
+    (hf : TPoleOrderLE f m) (hmn : m ≤ n) : TPoleOrderLE f n :=
+  fun k hk => hf k (by omega)
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.mono"
+private theorem tPoleOrderLE_zero {K : Type*} [Field K] (n : ℕ) :
+    TPoleOrderLE (0 : LaurentSeries K) n :=
+  fun _ _ => rfl
+
+private theorem tPoleOrderLE_one {K : Type*} [Field K] :
+    TPoleOrderLE (1 : LaurentSeries K) 0 := by
+  intro m hm
+  rw [HahnSeries.coeff_one, ite_eq_right (by omega)]
+
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.neg {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) : TPoleOrderLE (-f) n := by
+  intro m hm
+  rw [HahnSeries.coeff_neg, hf m hm, neg_zero]
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.neg"
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.mul {K : Type*} [Field K]
+    {f g : LaurentSeries K} {m n : ℕ}
+    (hf : TPoleOrderLE f m) (hg : TPoleOrderLE g n) : TPoleOrderLE (f * g) (m + n) := by
+  intro k hk
+  rw [HahnSeries.coeff_mul]
+  refine Finset.sum_eq_zero fun ij hij => ?_
+  obtain ⟨-, -, hsum⟩ := Finset.mem_antidiagonal.mp hij
+  by_cases hi : ij.1 < -(m : ℤ)
+  · rw [hf ij.1 hi, zero_mul]
+  · refine mul_eq_zero_of_right _ (hg ij.2 ?_)
+    push_cast at hk
+    omega
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.mul"
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.qTwist {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) (u : Kˣ) : TPoleOrderLE (ModularCurve.qTwist u f) n := by
+  intro m hm
+  rw [qTwist_coeff, hf m hm, mul_zero]
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.qTwist"
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.qExpand {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) (N : ℕ) [NeZero N] :
+    TPoleOrderLE (ModularCurve.qExpand K N f) (N * n) := by
+  intro m hm
+  by_cases hdvd : (N : ℤ) ∣ m
+  · obtain ⟨c, rfl⟩ := hdvd
+    rw [qExpand_coeff_mul]
+    refine hf c ?_
+    have hN : 0 < (N : ℤ) := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+    push_cast at hm
+    nlinarith
+  · exact qExpand_coeff_of_not_dvd N f hdvd
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.qExpand"
+private theorem tPoleOrderLE_of_jSimplePole {K : Type*} [Field K] (J : LaurentSeries K)
+    (hJ : JSimplePole J) : TPoleOrderLE J 1 := by
+  intro m hm
+  exact hJ m (by push_cast at hm; omega)
+
+private def conjPoleBound (ℓ : ℕ) : Fin (ℓ + 1) → ℕ :=
+  fun i => if i = 0 then ℓ * ℓ else 1
+
+private theorem conjPoleBound_zero (ℓ : ℕ) : conjPoleBound ℓ 0 = ℓ * ℓ := ite_eq_left rfl
+
+private theorem conjPoleBound_succ (ℓ : ℕ) (b : Fin ℓ) : conjPoleBound ℓ b.succ = 1 :=
+  ite_eq_right (Fin.succ_ne_zero b)
+
+private theorem sum_conjPoleBound (ℓ : ℕ) :
+    ∑ i : Fin (ℓ + 1), conjPoleBound ℓ i = ℓ * ℓ + ℓ := by
+  rw [Fin.sum_univ_succ, conjPoleBound_zero]
+  congr 1
+  simp only [conjPoleBound_succ]
+  simp
+
+private theorem tPoleOrderLE_conj_zero {K : Type*} [Field K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {J : LaurentSeries K}
+    {conj : Fin (ℓ + 1) → LaurentSeries K} (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hJ : JSimplePole J) : TPoleOrderLE (conj 0) (ℓ * ℓ) := by
+  rw [hconj0]
+  have h := (tPoleOrderLE_of_jSimplePole J hJ).qExpand (ℓ * ℓ)
+  simpa using h
+
+private theorem tPoleOrderLE_conj_succ {K : Type*} [Field K] {ℓ : ℕ} {ζ : Kˣ}
+    {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (b : Fin ℓ) : TPoleOrderLE (conj b.succ) 1 := by
+  rw [hconjS b]
+  exact (tPoleOrderLE_of_jSimplePole J hJ).qTwist _
+
+private theorem tPoleOrderLE_conj {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+    {ζ : Kˣ} {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (i : Fin (ℓ + 1)) :
+    TPoleOrderLE (conj i) (conjPoleBound ℓ i) := by
+  rcases Fin.eq_zero_or_eq_succ i with rfl | ⟨b, rfl⟩
+  · rw [conjPoleBound_zero]
+    exact tPoleOrderLE_conj_zero hconj0 hJ
+  · rw [conjPoleBound_succ]
+    exact tPoleOrderLE_conj_succ hconjS hJ b
+
+private theorem tPoleOrderLE_coeff_X_sub_C {K : Type*} [Field K] {a : LaurentSeries K}
+    {n : ℕ} (ha : TPoleOrderLE a n) (k : ℕ) :
+    TPoleOrderLE ((Polynomial.X - Polynomial.C a).coeff k) n := by
+  match k with
+  | 0 =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X_zero, Polynomial.coeff_C_zero,
+      zero_sub]
+    exact ha.neg
+  | 1 =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X_one, Polynomial.coeff_C,
+      ite_eq_right (one_ne_zero), sub_zero]
+    exact tPoleOrderLE_one.mono (Nat.zero_le _)
+  | (k + 2) =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X, Polynomial.coeff_C]
+    rw [ite_eq_right (by omega), ite_eq_right (by omega), sub_zero]
+    exact tPoleOrderLE_zero _
+
+private theorem tPoleOrderLE_coeff_mul {K : Type*} [Field K]
+    {p q : Polynomial (LaurentSeries K)} {m n : ℕ}
+    (hp : ∀ k, TPoleOrderLE (p.coeff k) m) (hq : ∀ k, TPoleOrderLE (q.coeff k) n) (k : ℕ) :
+    TPoleOrderLE ((p * q).coeff k) (m + n) := by
+  rw [Polynomial.coeff_mul]
+  intro a ha
+  rw [HahnSeries.coeff_sum]
+  exact Finset.sum_eq_zero fun ij _ => (hp ij.1).mul (hq ij.2) a ha
+
+private theorem tPoleOrderLE_coeff_prod {K : Type*} [Field K] {ι : Type*} (s : Finset ι)
+    (p : ι → Polynomial (LaurentSeries K)) (n : ι → ℕ)
+    (hp : ∀ i ∈ s, ∀ k, TPoleOrderLE ((p i).coeff k) (n i)) :
+    ∀ k, TPoleOrderLE ((∏ i ∈ s, p i).coeff k) (∑ i ∈ s, n i) := by
+  induction s using Finset.cons_induction with
+  | empty =>
+    intro k
+    simp only [Finset.prod_empty, Finset.sum_empty]
+    rcases Nat.eq_zero_or_pos k with rfl | hk
+    · simpa using tPoleOrderLE_one
+    · rw [Polynomial.coeff_one, ite_eq_right (by omega)]
+      exact tPoleOrderLE_zero 0
+  | cons a s ha ih =>
+    intro k
+    rw [Finset.prod_cons, Finset.sum_cons]
+    exact tPoleOrderLE_coeff_mul (hp a (Finset.mem_cons_self a s))
+      (ih fun i hi k => hp i (Finset.mem_cons_of_mem hi) k) k
+
+private theorem phiProd_def {K : Type*} [Field K] (ℓ : ℕ)
+    (conj : Fin (ℓ + 1) → LaurentSeries K) :
+    phiProd ℓ conj = ∏ i : Fin (ℓ + 1), (Polynomial.X - Polynomial.C (conj i)) := rfl
+
+private theorem tPoleOrderLE_phiProd_coeff {K : Type*} [Field K] (ℓ : ℕ)
+    [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (J : LaurentSeries K)
+    (conj : Fin (ℓ + 1) → LaurentSeries K) (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (k : ℕ) :
+    TPoleOrderLE ((phiProd ℓ conj).coeff k) (ℓ * ℓ + ℓ) := by
+  rw [phiProd_def, ← sum_conjPoleBound ℓ]
+  exact tPoleOrderLE_coeff_prod Finset.univ _ (conjPoleBound ℓ)
+    (fun i _ k => tPoleOrderLE_coeff_X_sub_C (tPoleOrderLE_conj hconj0 hconjS hJ i) k) k
+
+theorem coeffEmb_qExpand_injective {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] :
+    Function.Injective (fun f : LaurentSeries ℚ => coeffEmb K (qExpand ℚ ℓ f)) :=
+  (coeffEmb_injective K).comp (qExpand_injective (R := ℚ) ℓ)
+
+theorem PhiGenDescends.c_top {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) : c (ℓ + 1) = 1 := by
+  refine coeffEmb_qExpand_injective (K := K) (ℓ := ℓ) ?_
+  have h1 : (phiProd ℓ (conj ℓ ζ)).coeff (ℓ + 1) = 1 := by
+    have h := (phiProd_monic ℓ (conj ℓ ζ)).coeff_natDegree
+    rwa [phiProd_natDegree ℓ (conj ℓ ζ)] at h
+  simp only [← hc (ℓ + 1), h1, map_one]
+
+private theorem PhiGenDescends.c_eq_zero {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) {k : ℕ} (hk : ℓ + 1 < k) : c k = 0 := by
+  refine coeffEmb_qExpand_injective (K := K) (ℓ := ℓ) ?_
+  have h1 : (phiProd ℓ (conj ℓ ζ)).coeff k = 0 :=
+    Polynomial.coeff_eq_zero_of_natDegree_lt (by rw [phiProd_natDegree]; exact hk)
+  simp only [← hc k, h1, map_zero]
+
+theorem PhiGenDescends.poleOrderLE {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) (k : ℕ) : PoleOrderLE (c k) (ℓ + 1) := by
+  have hW3 : TPoleOrderLE ((phiProd ℓ (conj ℓ ζ)).coeff k) (ℓ * ℓ + ℓ) :=
+    tPoleOrderLE_phiProd_coeff ℓ ζ (coeffEmb K jq) (conj ℓ ζ) (conj_zero ℓ ζ) (conj_succ ℓ ζ)
+      jSimplePole_jqK k
+  rw [hc k, tPoleOrderLE_coeffEmb_iff] at hW3
+  rw [← tPoleOrderLE_iff_poleOrderLE]
+  exact tPoleOrderLE_of_qExpand (hW3.mono (le_of_eq (by ring)))
+
+theorem PhiGenDescends.sum_mul_jqN_pow_eq_zero {K : Type*} [Field K] [Algebra ℚ K]
+    {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) :
+    ∑ k ∈ Finset.range (ℓ + 2), c k * (jqN ℓ) ^ k = 0 := by
+  set F : LaurentSeries ℚ →+* LaurentSeries K := (coeffEmb K).comp (qExpand ℚ ℓ) with hF
+  have hFapp : ∀ f : LaurentSeries ℚ, F f = coeffEmb K (qExpand ℚ ℓ f) := fun f => rfl
+  have hFinj : Function.Injective F := coeffEmb_qExpand_injective
+  have hconj0 : conj ℓ ζ (0 : Fin (ℓ + 1)) = F (jqN ℓ) := by
+    change conj ℓ ζ 0 = coeffMap (algebraMap ℚ K) (qExpand ℚ ℓ (jqN ℓ))
+    rw [conj_zero, jqN, qExpand_qExpand, coeffMap_qExpand]
+    rfl
+  have hterm : ∀ k ∈ Finset.range (ℓ + 2),
+      F (c k * (jqN ℓ) ^ k)
+        = (phiProd ℓ (conj ℓ ζ)).coeff k * (conj ℓ ζ 0) ^ k := by
+    intro k _
+    rw [map_mul, map_pow, ← hconj0, hFapp, hc k]
+  refine hFinj ?_
+  rw [map_zero, map_sum, Finset.sum_congr rfl hterm]
+  rw [← Polynomial.eval_eq_sum_range' (n := ℓ + 2) (by rw [phiProd_natDegree]; omega)]
+  exact phiProd_eval_conj ℓ _ 0
+
+theorem evalAtJ_eq_aeval_map (Q : Polynomial ℤ) :
+    evalAtJ Q = Polynomial.aeval jq (Q.map (Int.castRingHom ℚ)) := by
+  have hcomp : (algebraMap ℚ (LaurentSeries ℚ)).comp (Int.castRingHom ℚ)
+      = algebraMap ℤ (LaurentSeries ℚ) := Subsingleton.elim _ _
+  rw [Polynomial.aeval_def, Polynomial.eval₂_map, hcomp]
+  rfl
+
+private theorem aeval_jq_eq_zero {p : Polynomial ℚ} (hp : Polynomial.aeval jq p = 0) :
+    p = 0 := by
+  by_contra hp0
+  set n := p.natDegree with hn
+  have hcoeff : (Polynomial.aeval jq p).coeff (-(n : ℤ)) = p.coeff n := by
+    rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+      Finset.sum_eq_single n]
+    · rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_self,
+        mul_one]
+    · intro i hi hin
+      have hilt : i < n := lt_of_le_of_ne (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hin
+      rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_of_lt,
+        mul_zero]
+      omega
+    · intro hn'
+      exact absurd (Finset.self_mem_range_succ n) hn'
+  rw [hp] at hcoeff
+  simp only [HahnSeries.coeff_zero] at hcoeff
+  exact hp0 (Polynomial.leadingCoeff_eq_zero.mp hcoeff.symm)
+
+theorem evalAtJ_injective : Function.Injective evalAtJ := by
+  intro P Q hPQ
+  refine Polynomial.map_injective (Int.castRingHom ℚ) Int.cast_injective ?_
+  rw [evalAtJ_eq_aeval_map, evalAtJ_eq_aeval_map] at hPQ
+  have h0 : Polynomial.aeval jq
+      (P.map (Int.castRingHom ℚ) - Q.map (Int.castRingHom ℚ)) = 0 := by
+    rw [map_sub, hPQ, sub_self]
+  exact sub_eq_zero.mp (aeval_jq_eq_zero h0)
+
+end PhiGen
+end ModularCurve
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_PhiGen_PhiGenDescends_c_eq_zero.ModularCurve
+  _root_.ModularCurve.PhiGen
+  _root_.P2MW.S_ModularCurve_PhiGen_PhiGenDescends_c_eq_zero.ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ}
+    {c : ℕ → LaurentSeries ℚ} (hc : PhiGenDescends ℓ ζ c) {k : ℕ} (hk : ℓ + 1 < k) :
+    c k = 0 :=
+  ModularCurve.PhiGen.PhiGenDescends.c_eq_zero hc hk
+
+end S_ModularCurve_PhiGen_PhiGenDescends_c_eq_zero
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_PhiGenDescends_c_eq_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.PhiGenDescends.c_eq_zero {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ} (hc : PhiGenDescends ℓ ζ c) {k : ℕ}
+    (hk : ℓ + 1 < k) :
+    c k = 0 :=
+  solution hc hk
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_PhiGenDescends_c_top.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_PhiGenDescends_c_top.lean
new file mode 100644
index 0000000000..1f2fce6446
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_PhiGenDescends_c_top.lean
@@ -0,0 +1,407 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.PhiGenDescends.c_top
+(679e8f7f-28d0-5e3a-af3d-681efa6851fa) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 080a1549-957f-565a-ab5c-deb6889cb4c9
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_injective
+import Mathlib.Algebra.BigOperators.Fin
+import Mathlib.Algebra.Polynomial.Eval.Degree
+import Mathlib.Tactic.Linarith
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Descended coefficient family has top coefficient 1
+
+Theorem statement: `ModularCurve.PhiGen.PhiGenDescends.c_top`
+(`679e8f7f-28d0-5e3a-af3d-681efa6851fa`), by Claude, 2026-09-05.
+
+Proof: submission `080a1549-957f-565a-ab5c-deb6889cb4c9`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field equipped with a $\mathbb{Q}$-algebra structure, let $\ell$ be a prime number, let
+$\zeta$ be a unit of $K$, and let $c : \mathbb{N} \to \mathbb{Q}((t))$ be a family of rational
+Laurent series. Assume `PhiGenDescends ℓ ζ c`, that is: for every natural number $k$, the
+coefficient of $X^k$ in the polynomial $\prod_{i : \mathrm{Fin}(\ell+1)} (X - C(\mathrm{conj}\ \ell\
+\zeta\ i))$ over $K((t))$ — where the conjugate family `conj` is given by the coset substitution
+`cosetSubst` applied to $\zeta$, to the coset data `cosetA ℓ i`, `cosetB ℓ i` and to the
+coefficientwise image over $K$ of the series `jq` — is equal to the image under `coeffEmb K` (the
+coefficientwise ring map induced by $\mathbb{Q} \to K$ on Laurent series) of `qExpand ℚ ℓ (c k)`,
+the Laurent series obtained from $c\,k$ by multiplying all exponents by $\ell$, i.e. by substituting
+$t \mapsto t^{\ell}$. The conclusion is that $c(\ell+1) = 1$ in $\mathbb{Q}((t))$, reflecting that
+the displayed product is monic of degree $\ell+1$. The proof uses the commutation of `coeffMap` with
+`qExpand` and the injectivity of `coeffEmb`.
+
+This records the normalisation of the descended coefficient family attached to the modular equation
+of level $\ell$: the top coefficient of the polynomial whose roots are the conjugates is $1$. It
+feeds into
+[`ModularCurve.PhiGen.exists_modularPolynomialData_coeff_eq`]
+(thm.html#ModularCurve.PhiGen.exists_modularPolynomialData_coeff_eq)
+and into the weighted support bound
+[`ModularCurve.ModularPolynomialData.weighted_support_le`]
+(thm.html#ModularCurve.ModularPolynomialData.weighted_support_le),
+which package the descended coefficients as modular polynomial data.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_PhiGenDescends_c_top.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_PhiGenDescends_c_top
+
+noncomputable section
+
+open Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_qExpand algebraMap_apply_eq_single jq coeff_jq_pow_self coeff_jq_pow_of_lt \
+  coeff_jq_of_lt jqN evalAtJ qTwist qTwist_coeff PoleOrderLE PhiGen.PhiGenDescends coeffMap \
+  coeffEmb coeffEmb_coeff coeffMap_qExpand coeffEmb_injective"
+p2m_open "ModularCurve"
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd phiProd_monic phiProd_natDegree \
+  phiProd_eval_conj TPoleOrderLE tPoleOrderLE_iff_poleOrderLE JSimplePole PhiGenDescends"
+p2m_open "ModularCurve.PhiGen"
+
+section CoeffEmbJq
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+private theorem coeff_coeffEmb_jq_of_lt {k : ℤ} (hk : k < -1) : (coeffEmb K jq).coeff k = 0 := by
+  rw [coeffEmb_coeff, coeff_jq_of_lt hk, map_zero]
+
+end CoeffEmbJq
+
+theorem jSimplePole_jqK {K : Type*} [Field K] [Algebra ℚ K] : JSimplePole (coeffEmb K jq) :=
+  fun _ hm => coeff_coeffEmb_jq_of_lt K hm
+
+theorem tPoleOrderLE_coeffEmb_iff {K : Type*} [Field K] [Algebra ℚ K]
+    (f : LaurentSeries ℚ) (n : ℕ) :
+    TPoleOrderLE (coeffEmb K f) n ↔ TPoleOrderLE f n := by
+  constructor
+  · intro h m hm
+    have h0 := h m hm
+    rw [coeffEmb_coeff] at h0
+    exact FaithfulSMul.algebraMap_injective ℚ K (by rw [h0, map_zero])
+  · intro h m hm
+    rw [coeffEmb_coeff, h m hm, map_zero]
+
+theorem tPoleOrderLE_of_qExpand {K : Type*} [Field K] {f : LaurentSeries K} {N n : ℕ}
+    [NeZero N] (h : TPoleOrderLE (qExpand K N f) (N * n)) : TPoleOrderLE f n := by
+  intro m hm
+  rw [← qExpand_coeff_mul N f m]
+  refine h _ ?_
+  push_cast
+  have hN : 0 < (N : ℤ) := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  nlinarith
+
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.mono {K : Type*} [Field K]
+    {f : LaurentSeries K} {m n : ℕ}
+    (hf : TPoleOrderLE f m) (hmn : m ≤ n) : TPoleOrderLE f n :=
+  fun k hk => hf k (by omega)
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.mono"
+private theorem tPoleOrderLE_zero {K : Type*} [Field K] (n : ℕ) :
+    TPoleOrderLE (0 : LaurentSeries K) n :=
+  fun _ _ => rfl
+
+private theorem tPoleOrderLE_one {K : Type*} [Field K] :
+    TPoleOrderLE (1 : LaurentSeries K) 0 := by
+  intro m hm
+  rw [HahnSeries.coeff_one, ite_eq_right (by omega)]
+
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.neg {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) : TPoleOrderLE (-f) n := by
+  intro m hm
+  rw [HahnSeries.coeff_neg, hf m hm, neg_zero]
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.neg"
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.mul {K : Type*} [Field K]
+    {f g : LaurentSeries K} {m n : ℕ}
+    (hf : TPoleOrderLE f m) (hg : TPoleOrderLE g n) : TPoleOrderLE (f * g) (m + n) := by
+  intro k hk
+  rw [HahnSeries.coeff_mul]
+  refine Finset.sum_eq_zero fun ij hij => ?_
+  obtain ⟨-, -, hsum⟩ := Finset.mem_antidiagonal.mp hij
+  by_cases hi : ij.1 < -(m : ℤ)
+  · rw [hf ij.1 hi, zero_mul]
+  · refine mul_eq_zero_of_right _ (hg ij.2 ?_)
+    push_cast at hk
+    omega
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.mul"
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.qTwist {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) (u : Kˣ) : TPoleOrderLE (ModularCurve.qTwist u f) n := by
+  intro m hm
+  rw [qTwist_coeff, hf m hm, mul_zero]
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.qTwist"
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.qExpand {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) (N : ℕ) [NeZero N] :
+    TPoleOrderLE (ModularCurve.qExpand K N f) (N * n) := by
+  intro m hm
+  by_cases hdvd : (N : ℤ) ∣ m
+  · obtain ⟨c, rfl⟩ := hdvd
+    rw [qExpand_coeff_mul]
+    refine hf c ?_
+    have hN : 0 < (N : ℤ) := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+    push_cast at hm
+    nlinarith
+  · exact qExpand_coeff_of_not_dvd N f hdvd
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.qExpand"
+private theorem tPoleOrderLE_of_jSimplePole {K : Type*} [Field K] (J : LaurentSeries K)
+    (hJ : JSimplePole J) : TPoleOrderLE J 1 := by
+  intro m hm
+  exact hJ m (by push_cast at hm; omega)
+
+private def conjPoleBound (ℓ : ℕ) : Fin (ℓ + 1) → ℕ :=
+  fun i => if i = 0 then ℓ * ℓ else 1
+
+private theorem conjPoleBound_zero (ℓ : ℕ) : conjPoleBound ℓ 0 = ℓ * ℓ := ite_eq_left rfl
+
+private theorem conjPoleBound_succ (ℓ : ℕ) (b : Fin ℓ) : conjPoleBound ℓ b.succ = 1 :=
+  ite_eq_right (Fin.succ_ne_zero b)
+
+private theorem sum_conjPoleBound (ℓ : ℕ) :
+    ∑ i : Fin (ℓ + 1), conjPoleBound ℓ i = ℓ * ℓ + ℓ := by
+  rw [Fin.sum_univ_succ, conjPoleBound_zero]
+  congr 1
+  simp only [conjPoleBound_succ]
+  simp
+
+private theorem tPoleOrderLE_conj_zero {K : Type*} [Field K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {J : LaurentSeries K}
+    {conj : Fin (ℓ + 1) → LaurentSeries K} (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hJ : JSimplePole J) : TPoleOrderLE (conj 0) (ℓ * ℓ) := by
+  rw [hconj0]
+  have h := (tPoleOrderLE_of_jSimplePole J hJ).qExpand (ℓ * ℓ)
+  simpa using h
+
+private theorem tPoleOrderLE_conj_succ {K : Type*} [Field K] {ℓ : ℕ} {ζ : Kˣ}
+    {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (b : Fin ℓ) : TPoleOrderLE (conj b.succ) 1 := by
+  rw [hconjS b]
+  exact (tPoleOrderLE_of_jSimplePole J hJ).qTwist _
+
+private theorem tPoleOrderLE_conj {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+    {ζ : Kˣ} {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (i : Fin (ℓ + 1)) :
+    TPoleOrderLE (conj i) (conjPoleBound ℓ i) := by
+  rcases Fin.eq_zero_or_eq_succ i with rfl | ⟨b, rfl⟩
+  · rw [conjPoleBound_zero]
+    exact tPoleOrderLE_conj_zero hconj0 hJ
+  · rw [conjPoleBound_succ]
+    exact tPoleOrderLE_conj_succ hconjS hJ b
+
+private theorem tPoleOrderLE_coeff_X_sub_C {K : Type*} [Field K] {a : LaurentSeries K}
+    {n : ℕ} (ha : TPoleOrderLE a n) (k : ℕ) :
+    TPoleOrderLE ((Polynomial.X - Polynomial.C a).coeff k) n := by
+  match k with
+  | 0 =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X_zero, Polynomial.coeff_C_zero,
+      zero_sub]
+    exact ha.neg
+  | 1 =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X_one, Polynomial.coeff_C,
+      ite_eq_right (one_ne_zero), sub_zero]
+    exact tPoleOrderLE_one.mono (Nat.zero_le _)
+  | (k + 2) =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X, Polynomial.coeff_C]
+    rw [ite_eq_right (by omega), ite_eq_right (by omega), sub_zero]
+    exact tPoleOrderLE_zero _
+
+private theorem tPoleOrderLE_coeff_mul {K : Type*} [Field K]
+    {p q : Polynomial (LaurentSeries K)} {m n : ℕ}
+    (hp : ∀ k, TPoleOrderLE (p.coeff k) m) (hq : ∀ k, TPoleOrderLE (q.coeff k) n) (k : ℕ) :
+    TPoleOrderLE ((p * q).coeff k) (m + n) := by
+  rw [Polynomial.coeff_mul]
+  intro a ha
+  rw [HahnSeries.coeff_sum]
+  exact Finset.sum_eq_zero fun ij _ => (hp ij.1).mul (hq ij.2) a ha
+
+private theorem tPoleOrderLE_coeff_prod {K : Type*} [Field K] {ι : Type*} (s : Finset ι)
+    (p : ι → Polynomial (LaurentSeries K)) (n : ι → ℕ)
+    (hp : ∀ i ∈ s, ∀ k, TPoleOrderLE ((p i).coeff k) (n i)) :
+    ∀ k, TPoleOrderLE ((∏ i ∈ s, p i).coeff k) (∑ i ∈ s, n i) := by
+  induction s using Finset.cons_induction with
+  | empty =>
+    intro k
+    simp only [Finset.prod_empty, Finset.sum_empty]
+    rcases Nat.eq_zero_or_pos k with rfl | hk
+    · simpa using tPoleOrderLE_one
+    · rw [Polynomial.coeff_one, ite_eq_right (by omega)]
+      exact tPoleOrderLE_zero 0
+  | cons a s ha ih =>
+    intro k
+    rw [Finset.prod_cons, Finset.sum_cons]
+    exact tPoleOrderLE_coeff_mul (hp a (Finset.mem_cons_self a s))
+      (ih fun i hi k => hp i (Finset.mem_cons_of_mem hi) k) k
+
+private theorem phiProd_def {K : Type*} [Field K] (ℓ : ℕ)
+    (conj : Fin (ℓ + 1) → LaurentSeries K) :
+    phiProd ℓ conj = ∏ i : Fin (ℓ + 1), (Polynomial.X - Polynomial.C (conj i)) := rfl
+
+private theorem tPoleOrderLE_phiProd_coeff {K : Type*} [Field K] (ℓ : ℕ)
+    [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (J : LaurentSeries K)
+    (conj : Fin (ℓ + 1) → LaurentSeries K) (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (k : ℕ) :
+    TPoleOrderLE ((phiProd ℓ conj).coeff k) (ℓ * ℓ + ℓ) := by
+  rw [phiProd_def, ← sum_conjPoleBound ℓ]
+  exact tPoleOrderLE_coeff_prod Finset.univ _ (conjPoleBound ℓ)
+    (fun i _ k => tPoleOrderLE_coeff_X_sub_C (tPoleOrderLE_conj hconj0 hconjS hJ i) k) k
+
+theorem coeffEmb_qExpand_injective {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] :
+    Function.Injective (fun f : LaurentSeries ℚ => coeffEmb K (qExpand ℚ ℓ f)) :=
+  (coeffEmb_injective K).comp (qExpand_injective (R := ℚ) ℓ)
+
+private theorem PhiGenDescends.c_top {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) : c (ℓ + 1) = 1 := by
+  refine coeffEmb_qExpand_injective (K := K) (ℓ := ℓ) ?_
+  have h1 : (phiProd ℓ (conj ℓ ζ)).coeff (ℓ + 1) = 1 := by
+    have h := (phiProd_monic ℓ (conj ℓ ζ)).coeff_natDegree
+    rwa [phiProd_natDegree ℓ (conj ℓ ζ)] at h
+  simp only [← hc (ℓ + 1), h1, map_one]
+
+theorem PhiGenDescends.c_eq_zero {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) {k : ℕ} (hk : ℓ + 1 < k) : c k = 0 := by
+  refine coeffEmb_qExpand_injective (K := K) (ℓ := ℓ) ?_
+  have h1 : (phiProd ℓ (conj ℓ ζ)).coeff k = 0 :=
+    Polynomial.coeff_eq_zero_of_natDegree_lt (by rw [phiProd_natDegree]; exact hk)
+  simp only [← hc k, h1, map_zero]
+
+theorem PhiGenDescends.poleOrderLE {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) (k : ℕ) : PoleOrderLE (c k) (ℓ + 1) := by
+  have hW3 : TPoleOrderLE ((phiProd ℓ (conj ℓ ζ)).coeff k) (ℓ * ℓ + ℓ) :=
+    tPoleOrderLE_phiProd_coeff ℓ ζ (coeffEmb K jq) (conj ℓ ζ) (conj_zero ℓ ζ) (conj_succ ℓ ζ)
+      jSimplePole_jqK k
+  rw [hc k, tPoleOrderLE_coeffEmb_iff] at hW3
+  rw [← tPoleOrderLE_iff_poleOrderLE]
+  exact tPoleOrderLE_of_qExpand (hW3.mono (le_of_eq (by ring)))
+
+theorem PhiGenDescends.sum_mul_jqN_pow_eq_zero {K : Type*} [Field K] [Algebra ℚ K]
+    {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) :
+    ∑ k ∈ Finset.range (ℓ + 2), c k * (jqN ℓ) ^ k = 0 := by
+  set F : LaurentSeries ℚ →+* LaurentSeries K := (coeffEmb K).comp (qExpand ℚ ℓ) with hF
+  have hFapp : ∀ f : LaurentSeries ℚ, F f = coeffEmb K (qExpand ℚ ℓ f) := fun f => rfl
+  have hFinj : Function.Injective F := coeffEmb_qExpand_injective
+  have hconj0 : conj ℓ ζ (0 : Fin (ℓ + 1)) = F (jqN ℓ) := by
+    change conj ℓ ζ 0 = coeffMap (algebraMap ℚ K) (qExpand ℚ ℓ (jqN ℓ))
+    rw [conj_zero, jqN, qExpand_qExpand, coeffMap_qExpand]
+    rfl
+  have hterm : ∀ k ∈ Finset.range (ℓ + 2),
+      F (c k * (jqN ℓ) ^ k)
+        = (phiProd ℓ (conj ℓ ζ)).coeff k * (conj ℓ ζ 0) ^ k := by
+    intro k _
+    rw [map_mul, map_pow, ← hconj0, hFapp, hc k]
+  refine hFinj ?_
+  rw [map_zero, map_sum, Finset.sum_congr rfl hterm]
+  rw [← Polynomial.eval_eq_sum_range' (n := ℓ + 2) (by rw [phiProd_natDegree]; omega)]
+  exact phiProd_eval_conj ℓ _ 0
+
+theorem evalAtJ_eq_aeval_map (Q : Polynomial ℤ) :
+    evalAtJ Q = Polynomial.aeval jq (Q.map (Int.castRingHom ℚ)) := by
+  have hcomp : (algebraMap ℚ (LaurentSeries ℚ)).comp (Int.castRingHom ℚ)
+      = algebraMap ℤ (LaurentSeries ℚ) := Subsingleton.elim _ _
+  rw [Polynomial.aeval_def, Polynomial.eval₂_map, hcomp]
+  rfl
+
+private theorem aeval_jq_eq_zero {p : Polynomial ℚ} (hp : Polynomial.aeval jq p = 0) :
+    p = 0 := by
+  by_contra hp0
+  set n := p.natDegree with hn
+  have hcoeff : (Polynomial.aeval jq p).coeff (-(n : ℤ)) = p.coeff n := by
+    rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+      Finset.sum_eq_single n]
+    · rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_self,
+        mul_one]
+    · intro i hi hin
+      have hilt : i < n := lt_of_le_of_ne (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hin
+      rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_of_lt,
+        mul_zero]
+      omega
+    · intro hn'
+      exact absurd (Finset.self_mem_range_succ n) hn'
+  rw [hp] at hcoeff
+  simp only [HahnSeries.coeff_zero] at hcoeff
+  exact hp0 (Polynomial.leadingCoeff_eq_zero.mp hcoeff.symm)
+
+theorem evalAtJ_injective : Function.Injective evalAtJ := by
+  intro P Q hPQ
+  refine Polynomial.map_injective (Int.castRingHom ℚ) Int.cast_injective ?_
+  rw [evalAtJ_eq_aeval_map, evalAtJ_eq_aeval_map] at hPQ
+  have h0 : Polynomial.aeval jq
+      (P.map (Int.castRingHom ℚ) - Q.map (Int.castRingHom ℚ)) = 0 := by
+    rw [map_sub, hPQ, sub_self]
+  exact sub_eq_zero.mp (aeval_jq_eq_zero h0)
+
+end PhiGen
+end ModularCurve
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_PhiGen_PhiGenDescends_c_top.ModularCurve
+  _root_.ModularCurve.PhiGen
+  _root_.P2MW.S_ModularCurve_PhiGen_PhiGenDescends_c_top.ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ}
+    {c : ℕ → LaurentSeries ℚ} (hc : PhiGenDescends ℓ ζ c) :
+    c (ℓ + 1) = 1 :=
+  ModularCurve.PhiGen.PhiGenDescends.c_top hc
+
+end S_ModularCurve_PhiGen_PhiGenDescends_c_top
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_PhiGenDescends_c_top (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.PhiGenDescends.c_top {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ} (hc : PhiGenDescends ℓ ζ c) :
+    c (ℓ + 1) = 1 :=
+  solution hc
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_PhiGenDescends_hasSum_cosetPoly_coeff.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_PhiGenDescends_hasSum_cosetPoly_coeff.lean
new file mode 100644
index 0000000000..4d487128cd
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_PhiGenDescends_hasSum_cosetPoly_coeff.lean
@@ -0,0 +1,384 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.PhiGenDescends.hasSum_cosetPoly_coeff
+(d4b12e57-059a-5aba-9259-be91e6f4b8ab) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6906357b-f645-5e50-a6ef-62a6b647d1a1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+public import Mathlib.NumberTheory.Cyclotomic.Basic
+public import Mathlib.NumberTheory.ModularForms.EisensteinSeries.Basic
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+
+import Mathlib.NumberTheory.Cyclotomic.PrimitiveRoots
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_jq_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_mul_laurent
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_heckeMatrix_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_heckeDiagMatrix_smul
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Formal descent data give q-expansions of the Hecke coset polynomial
+
+Theorem statement: `ModularCurve.PhiGen.PhiGenDescends.hasSum_cosetPoly_coeff`
+(`d4b12e57-059a-5aba-9259-be91e6f4b8ab`), by Claude, 2026-09-05.
+
+Proof: submission `6906357b-f645-5e50-a6ef-62a6b647d1a1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $\ell$ assumed prime, a unit $\zeta$ of `CyclotomicField ℓ ℚ` together with a
+proof `hζ` that $\zeta$ is a primitive $\ell$-th root of unity, and a family $c : \mathbb{N} \to$
+`LaurentSeries ℚ` of rational Laurent series. Assume [`ModularCurve.PhiGen.PhiGenDescends ℓ ζ
+c`](def/ModularCurve_PhiGen.html#L302), i.e. for every $k$ the $k$-th coefficient of the polynomial
+$\prod_{i : \mathrm{Fin}(\ell+1)} (X - C(\mathrm{conj}\,\ell\,\zeta\,i))$ over Laurent series with
+coefficients in the cyclotomic field equals the image under `coeffEmb` of `qExpand ℚ ℓ (c k)`, the
+series obtained from $c_k$ by multiplying all exponents by $\ell$; here
+$\mathrm{conj}\,\ell\,\zeta\,i$ is `cosetSubst ζ (cosetA ℓ i) (cosetB ℓ i)` applied to the
+coefficientwise image of the Laurent series [`ModularCurve.jq`](def/ModularCurve_X0.html#L157), the
+formal stand-ins for the $\ell+1$ Hecke conjugates of $j$. Then for every $k : \mathbb{N}$ and every
+$\tau$ in the upper half-plane, the family indexed by $m \in \mathbb{Z}$ whose $m$-th term is the
+rational number $\mathrm{coeff}_m(c_k)$, viewed in $\mathbb{C}$, times $q^m$ with $q =$
+`Function.Periodic.qParam 1 τ` $= e^{2\pi i \tau}$, is summable with sum the $k$-th coefficient of
+the polynomial
+$$\bigl(X - C\,\tilde j(\beta_\infty \tau)\bigr)\prod_{b : \mathrm{Fin}\,\ell}\bigl(X - C\,\tilde
+j(\beta_b \tau)\bigr) \in \mathbb{C}[X],$$
+where $\tilde j = E_4^3/\Delta$ in the normalisation `ModularForm.E₄` and
+`ModularForm.discriminant`, $\beta_\infty =$ `heckeDiagMatrix ℓ` $=
+\begin{pmatrix}\ell&0\\0&1\end{pmatrix}$ and $\beta_b =$ `heckeMatrix ℓ b` $=
+\begin{pmatrix}1&b\\0&\ell\end{pmatrix}$ act on the upper half-plane through
+$\mathrm{GL}_2(\mathbb{R})$.
+
+This is the analytic–formal bridge for the modular polynomial of level $\ell$: it identifies a
+formal solution of the descent equations for the Hecke coset product with the $q$-expansion,
+convergent on the upper half-plane, of the corresponding elementary symmetric function of the values
+$\tilde j(\beta_i\tau)$. It is used by
+[`ModularCurve.PhiGen.mem_adjoin_jq_of_phiGenDescends`]
+(thm.html#ModularCurve.PhiGen.mem_adjoin_jq_of_phiGenDescends)
+to place these symmetric functions in the algebra generated by $j$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_PhiGenDescends_hasSum_cosetPoly_coeff.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_PhiGenDescends_hasSum_cosetPoly_coeff
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology Function Polynomial
+open scoped MatrixGroups
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd jq qTwist_coeff \
+  PhiGen.conj PhiGen.conj_zero PhiGen.conj_succ PhiGen.phiProd PhiGen.PhiGenDescends coeffMap \
+  coeffMap_coeff coeffEmb coeffEmb_coeff coeffMap_qExpand hasSum_jq_qParam \
+  hasSum_qParam_mul_laurent hasSum_qParam_heckeMatrix_smul hasSum_qParam_heckeDiagMatrix_smul"
+p2m_open "ModularCurve"
+
+def RealL (h : ℝ) (A : LaurentSeries ℂ) (F : ℍ → ℂ) : Prop :=
+  ∀ τ : ℍ, HasSum (fun m : ℤ => A.coeff m * 𝕢 h (τ : ℂ) ^ m) (F τ)
+
+namespace RealL
+
+variable {h : ℝ} {A B : LaurentSeries ℂ} {F G : ℍ → ℂ}
+
+lemma add (hA : RealL h A F) (hB : RealL h B G) : RealL h (A + B) (F + G) := fun τ => by
+  simpa [add_mul] using (hA τ).add (hB τ)
+
+lemma neg (hA : RealL h A F) : RealL h (-A) (-F) := fun τ => by
+  simpa [neg_mul] using (hA τ).neg
+
+lemma sub (hA : RealL h A F) (hB : RealL h B G) : RealL h (A - B) (F - G) := fun τ => by
+  simpa [sub_mul] using (hA τ).sub (hB τ)
+
+lemma mul (hh : 0 < h) (hA : RealL h A F) (hB : RealL h B G) : RealL h (A * B) (F * G) := fun τ =>
+  hasSum_qParam_mul_laurent h hh A B F G hA hB τ
+
+lemma single (h : ℝ) (a : ℂ) (n : ℤ) :
+    RealL h (HahnSeries.single n a) (fun τ => a * 𝕢 h (τ : ℂ) ^ n) := fun τ => by
+  refine (hasSum_ite_eq n (a * 𝕢 h (τ : ℂ) ^ n)).congr_fun fun m => ?_
+  by_cases hm : m = n
+  · subst hm; simp
+  · simp [HahnSeries.coeff_single_of_ne hm, hm]
+
+lemma C (h : ℝ) (a : ℂ) : RealL h (HahnSeries.C a) (fun _ => a) := by
+  simpa using single h a 0
+
+lemma one (h : ℝ) : RealL h 1 1 := by
+  have h__af := C h 1
+  simp only [HahnSeries.C_apply, HahnSeries.single_zero_one] at h__af
+  exact h__af
+
+lemma zero (h : ℝ) : RealL h 0 0 := fun τ => by simp [hasSum_zero]
+
+lemma congr {A' : LaurentSeries ℂ} {F' : ℍ → ℂ} (hA : RealL h A F) (h1 : A = A')
+    (h2 : ∀ τ, F τ = F' τ) :
+    RealL h A' F' := fun τ => by rw [← h1, ← h2]; exact hA τ
+
+lemma prod (hh : 0 < h) {ι : Type} (s : Finset ι) {A : ι → LaurentSeries ℂ} {F : ι → ℍ → ℂ}
+    (hAF : ∀ i ∈ s, RealL h (A i) (F i)) : RealL h (∏ i ∈ s, A i) (fun τ => ∏ i ∈ s, F i τ) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => (have h__af := one h; simp only [Finset.prod_empty] at h__af ⊢; exact h__af)
+  | insert a s ha ih =>
+    have h1 :=
+      (hAF a (Finset.mem_insert_self a s)).mul hh (ih fun i hi => hAF i (Finset.mem_insert_of_mem
+        hi))
+    refine h1.congr (Finset.prod_insert ha).symm fun τ => ?_
+    simp [Finset.prod_insert ha]
+
+lemma coeff_prod_X_sub_C (hh : 0 < h) {ι : Type} (s : Finset ι) {a : ι → LaurentSeries ℂ}
+    {α : ι → ℍ → ℂ} (haα : ∀ i ∈ s, RealL h (a i) (α i)) (k : ℕ) :
+    RealL h ((∏ i ∈ s, (Polynomial.X - Polynomial.C (a i))).coeff k)
+      (fun τ => (∏ i ∈ s, (Polynomial.X - Polynomial.C (α i τ))).coeff k) := by
+  classical
+  induction s using Finset.induction_on generalizing k with
+  | empty =>
+    simp only [Finset.prod_empty, Polynomial.coeff_one]
+    by_cases hk : k = 0
+    · subst hk; (have h__af := one h; simp only [↓reduceIte] at h__af ⊢; exact h__af)
+    · have h__af := zero h
+      simp only [hk, ↓reduceIte] at h__af ⊢
+      exact h__af
+  | insert b s hb ih =>
+    have ih' := fun k => ih (fun i hi => haα i (Finset.mem_insert_of_mem hi)) k
+    have hb' := haα b (Finset.mem_insert_self b s)
+    have hA : (∏ i ∈ insert b s, (Polynomial.X - Polynomial.C (a i))) =
+        (∏ i ∈ s, (Polynomial.X - Polynomial.C (a i))) * (Polynomial.X - Polynomial.C (a b)) :=
+      (Finset.prod_insert hb).trans (mul_comm (G := Polynomial (LaurentSeries ℂ)) _ _)
+    have hfun : ∀ τ : ℍ, (∏ i ∈ insert b s, (Polynomial.X - Polynomial.C (α i τ))) =
+        (∏ i ∈ s, (Polynomial.X - Polynomial.C (α i τ))) * (Polynomial.X - Polynomial.C (α b τ)) :=
+      fun τ => (Finset.prod_insert hb).trans (mul_comm (G := Polynomial ℂ) _ _)
+    cases k with
+    | zero =>
+      refine ((ih' 0).mul hh hb').neg.congr ?_ fun τ => ?_
+      · rw [hA, Polynomial.mul_coeff_zero, Polynomial.coeff_sub, Polynomial.coeff_X_zero,
+          Polynomial.coeff_C_zero, zero_sub]
+        exact (mul_neg (α := LaurentSeries ℂ) _ _).symm
+      · simp only [hfun τ, Polynomial.mul_coeff_zero, Pi.neg_apply, Pi.mul_apply,
+          Polynomial.coeff_sub,
+          Polynomial.coeff_X_zero, Polynomial.coeff_C_zero, zero_sub, mul_neg]
+    | succ k =>
+      refine ((ih' k).sub ((ih' (k + 1)).mul hh hb')).congr ?_ fun τ => ?_
+      · rw [hA, Polynomial.coeff_mul_X_sub_C]
+      · simp only [hfun τ, Polynomial.coeff_mul_X_sub_C, Pi.sub_apply, Pi.mul_apply]
+
+end RealL
+
+section Sigma
+
+variable (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)]
+
+def expRoot : ℂ := Complex.exp (2 * Real.pi * Complex.I / ℓ)
+
+lemma isPrimitiveRoot_expRoot : IsPrimitiveRoot (expRoot ℓ) ℓ :=
+  Complex.isPrimitiveRoot_exp ℓ hℓ.out.ne_zero
+
+def sigma (ζ : (CyclotomicField ℓ ℚ)ˣ) (hζ : IsPrimitiveRoot (ζ : CyclotomicField ℓ ℚ) ℓ) :
+    CyclotomicField ℓ ℚ →+* ℂ :=
+  letI : Algebra ℚ (CyclotomicField ℓ ℚ) := CyclotomicField.algebra ℓ ℚ
+  haveI : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  haveI := CyclotomicField.isCyclotomicExtension ℓ ℚ
+  ((hζ.embeddingsEquivPrimitiveRoots ℂ (Polynomial.cyclotomic.irreducible_rat hℓ.out.pos)).symm
+    ⟨expRoot ℓ, (mem_primitiveRoots hℓ.out.pos).mpr (isPrimitiveRoot_expRoot ℓ)⟩).toRingHom
+
+variable (ζ : (CyclotomicField ℓ ℚ)ˣ) (hζ : IsPrimitiveRoot (ζ : CyclotomicField ℓ ℚ) ℓ)
+
+lemma sigma_zeta : sigma ℓ ζ hζ (ζ : CyclotomicField ℓ ℚ) = expRoot ℓ := by
+  let : Algebra ℚ (CyclotomicField ℓ ℚ) := CyclotomicField.algebra ℓ ℚ
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  have := CyclotomicField.isCyclotomicExtension ℓ ℚ
+  let e := hζ.embeddingsEquivPrimitiveRoots ℂ (Polynomial.cyclotomic.irreducible_rat hℓ.out.pos)
+  let r : primitiveRoots ℓ ℂ :=
+    ⟨expRoot ℓ, (mem_primitiveRoots hℓ.out.pos).mpr (isPrimitiveRoot_expRoot ℓ)⟩
+  have h := IsPrimitiveRoot.embeddingsEquivPrimitiveRoots_apply_coe hζ ℂ
+    (Polynomial.cyclotomic.irreducible_rat hℓ.out.pos) (e.symm r)
+  rw [Equiv.apply_symm_apply] at h
+  exact h.symm
+
+omit hℓ in
+lemma sigma_ratCast' (σ : CyclotomicField ℓ ℚ →+* ℂ) (q : ℚ) :
+    σ (q : CyclotomicField ℓ ℚ) = (q : ℂ) :=
+  map_ratCast σ q
+
+end Sigma
+
+section JT
+
+def jt (τ : ℍ) : ℂ := ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ
+
+abbrev castC : ℚ →+* ℂ := Rat.castHom ℂ
+
+def jqC : LaurentSeries ℂ := coeffMap castC jq
+
+lemma jqC_coeff (m : ℤ) : jqC.coeff m = ((jq.coeff m : ℚ) : ℂ) := rfl
+
+lemma realL_jqC : RealL 1 jqC jt := fun τ => ModularCurve.hasSum_jq_qParam τ
+
+end JT
+
+section Translates
+
+variable (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : (CyclotomicField ℓ ℚ)ˣ)
+  (hζ : IsPrimitiveRoot (ζ : CyclotomicField ℓ ℚ) ℓ)
+
+def conjC (i : Fin (ℓ + 1)) : LaurentSeries ℂ := coeffMap (sigma ℓ ζ hζ) (PhiGen.conj ℓ ζ i)
+
+def rep (i : Fin (ℓ + 1)) : GL (Fin 2) ℝ :=
+  Fin.cases (ModularForm.heckeDiagMatrix ℓ) (fun b : Fin ℓ => ModularForm.heckeMatrix ℓ (b : ℕ)) i
+
+omit hℓ in
+@[scoped simp] lemma rep_zero : rep ℓ 0 = ModularForm.heckeDiagMatrix ℓ := by simp [rep]
+omit hℓ in
+@[scoped simp] lemma rep_succ (b : Fin ℓ) :
+    rep ℓ b.succ = ModularForm.heckeMatrix ℓ (b : ℕ) := by simp [rep]
+
+lemma realL_conjC_zero :
+    RealL ℓ (conjC ℓ ζ hζ 0) (fun τ => jt (ModularForm.heckeDiagMatrix ℓ • τ)) := by
+  intro τ
+  have h := ModularCurve.hasSum_qParam_heckeDiagMatrix_smul ℓ jqC jt realL_jqC τ
+  have hconj : conjC ℓ ζ hζ 0 = qExpand ℂ (ℓ * ℓ) jqC := by
+    rw [conjC, PhiGen.conj_zero, coeffMap_qExpand]
+    congr 1
+    ext m
+    simp [jqC_coeff, map_ratCast]
+  rw [hconj]
+  exact h
+
+omit hℓ in
+lemma expRoot_pow_zpow (b : ℕ) (m : ℤ) :
+    (expRoot ℓ ^ b) ^ m = Complex.exp (2 * Real.pi * Complex.I * b * m / ℓ) := by
+  rw [expRoot, ← Complex.exp_nat_mul, ← Complex.exp_int_mul]
+  congr 1
+  ring
+
+lemma realL_conjC_succ (b : Fin ℓ) :
+    RealL ℓ (conjC ℓ ζ hζ b.succ) (fun τ => jt (ModularForm.heckeMatrix ℓ (b : ℕ) • τ)) := by
+  intro τ
+  have h := ModularCurve.hasSum_qParam_heckeMatrix_smul ℓ (b : ℕ) jqC jt realL_jqC τ
+  refine h.congr_fun fun m => ?_
+  congr 1
+  rw [conjC, PhiGen.conj_succ, coeffMap_coeff, qTwist_coeff, map_mul, Units.val_zpow_eq_zpow_val,
+    map_zpow₀, Units.val_pow_eq_pow_val, map_pow, sigma_zeta, expRoot_pow_zpow]
+  congr 1
+  simp [jqC_coeff, map_ratCast]
+
+lemma realL_conjC (i : Fin (ℓ + 1)) : RealL ℓ (conjC ℓ ζ hζ i) (fun τ => jt (rep ℓ i • τ)) := by
+  refine Fin.cases ?_ (fun b => ?_) i
+  · simpa only [rep_zero] using realL_conjC_zero ℓ ζ hζ
+  · simpa only [rep_succ] using realL_conjC_succ ℓ ζ hζ b
+
+lemma map_phiProd : (PhiGen.phiProd ℓ (PhiGen.conj ℓ ζ)).map (coeffMap (sigma ℓ ζ hζ)) =
+    ∏ i : Fin (ℓ + 1), (Polynomial.X - Polynomial.C (conjC ℓ ζ hζ i)) := by
+  rw [PhiGen.phiProd, ← Polynomial.coe_mapRingHom, map_prod]
+  refine Finset.prod_congr rfl fun i _ => ?_
+  simp [conjC]
+
+lemma realL_phiProd_coeff (k : ℕ) :
+    RealL ℓ (((PhiGen.phiProd ℓ (PhiGen.conj ℓ ζ)).map (coeffMap (sigma ℓ ζ hζ))).coeff k)
+      (fun τ => (∏ i : Fin (ℓ + 1), (Polynomial.X - Polynomial.C (jt (rep ℓ i • τ)))).coeff k) := by
+  rw [map_phiProd]
+  exact RealL.coeff_prod_X_sub_C (by exact_mod_cast hℓ.out.pos) Finset.univ
+    (fun i _ => realL_conjC ℓ ζ hζ i) k
+
+lemma realL_one_of_realL_qExpand (x : LaurentSeries ℂ) (F : ℍ → ℂ) (hx : RealL ℓ (qExpand ℂ ℓ x) F)
+    :
+    RealL 1 x F := by
+  intro τ
+  have hinj : Function.Injective (fun n : ℤ => (ℓ : ℤ) * n) :=
+    mul_right_injective₀ (by exact_mod_cast hℓ.out.ne_zero)
+  have h := hx τ
+  rw [← hinj.hasSum_iff] at h
+  · refine h.congr_fun fun n => ?_
+    simp only [Function.comp_apply, qExpand_coeff_mul]
+    congr 1
+    rw [zpow_mul, zpow_natCast]
+    congr 1
+    simp only [Periodic.qParam, Complex.ofReal_one, div_one, Complex.ofReal_natCast]
+    rw [← Complex.exp_nat_mul]
+    congr 1
+    field_simp [(Nat.cast_ne_zero.mpr hℓ.out.ne_zero : (ℓ : ℂ) ≠ 0)]
+  · intro m hm
+    rw [qExpand_coeff_of_not_dvd ℓ _ (fun ⟨n, hn⟩ => hm ⟨n, hn.symm⟩), zero_mul]
+
+lemma coeffMap_sigma_coeffEmb (x : LaurentSeries ℚ) :
+    coeffMap (sigma ℓ ζ hζ) (coeffEmb (CyclotomicField ℓ ℚ) x) = coeffMap castC x := by
+  ext m
+  rw [coeffMap_coeff, coeffEmb_coeff, coeffMap_coeff, eq_ratCast, map_ratCast]
+  rfl
+
+include hζ in
+theorem hasSum_coeff_of_phiGenDescends (c : ℕ → LaurentSeries ℚ) (hc : PhiGen.PhiGenDescends ℓ ζ c)
+    (k : ℕ) (τ : ℍ) :
+    HasSum (fun m : ℤ => (((c k).coeff m : ℚ) : ℂ) * 𝕢 1 (τ : ℂ) ^ m)
+      (((Polynomial.X - Polynomial.C (ModularForm.E₄ (ModularForm.heckeDiagMatrix ℓ • τ) ^ 3 /
+          ModularForm.discriminant (ModularForm.heckeDiagMatrix ℓ • τ))) *
+        ∏ b : Fin ℓ, (Polynomial.X - Polynomial.C (ModularForm.E₄ (ModularForm.heckeMatrix ℓ (b : ℕ)
+          • τ) ^ 3 /
+          ModularForm.discriminant (ModularForm.heckeMatrix ℓ (b : ℕ) • τ)))).coeff k) := by
+  have h1 := realL_phiProd_coeff ℓ ζ hζ k
+  rw [Polynomial.coeff_map, hc k, coeffMap_sigma_coeffEmb, coeffMap_qExpand] at h1
+  have h2 := realL_one_of_realL_qExpand ℓ _ _ h1 τ
+  have hprod : (∏ i : Fin (ℓ + 1), (Polynomial.X - Polynomial.C (jt (rep ℓ i • τ)))) =
+      (Polynomial.X - Polynomial.C (jt (ModularForm.heckeDiagMatrix ℓ • τ))) *
+        ∏ b : Fin ℓ, (Polynomial.X - Polynomial.C (jt (ModularForm.heckeMatrix ℓ (b : ℕ) • τ))) :=
+          by
+    rw [Fin.prod_univ_succ]; simp only [rep_zero, rep_succ]
+  rw [hprod] at h2
+  exact h2
+
+end Translates
+
+end ModularCurve
+
+theorem solution (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : (CyclotomicField ℓ ℚ)ˣ)
+    (hζ : IsPrimitiveRoot (ζ : CyclotomicField ℓ ℚ) ℓ) (c : ℕ → LaurentSeries ℚ)
+    (hc : ModularCurve.PhiGen.PhiGenDescends ℓ ζ c) (k : ℕ) (τ : UpperHalfPlane) :
+    HasSum (fun m : ℤ => (((c k).coeff m : ℚ) : ℂ) * Function.Periodic.qParam 1 (τ : ℂ) ^ m)
+      (((Polynomial.X - Polynomial.C (ModularForm.E₄ (ModularForm.heckeDiagMatrix ℓ • τ) ^ 3 /
+      ModularForm.discriminant (ModularForm.heckeDiagMatrix ℓ • τ))) * ∏ b : Fin ℓ, (Polynomial.X -
+      Polynomial.C (ModularForm.E₄ (ModularForm.heckeMatrix ℓ (b : ℕ) • τ) ^ 3 /
+      ModularForm.discriminant (ModularForm.heckeMatrix ℓ (b : ℕ) • τ)))).coeff k) :=
+  ModularCurve.hasSum_coeff_of_phiGenDescends ℓ ζ hζ c hc k τ
+
+end
+end S_ModularCurve_PhiGen_PhiGenDescends_hasSum_cosetPoly_coeff
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_PhiGenDescends_hasSum_cosetPoly_coeff (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.PhiGen.PhiGenDescends.hasSum_cosetPoly_coeff (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)]
+    (ζ : (CyclotomicField ℓ ℚ)ˣ) (hζ : IsPrimitiveRoot (ζ : CyclotomicField ℓ ℚ) ℓ)
+    (c : ℕ → LaurentSeries ℚ) (hc : ModularCurve.PhiGen.PhiGenDescends ℓ ζ c) (k : ℕ)
+    (τ : UpperHalfPlane) :
+    HasSum (fun m : ℤ => (((c k).coeff m : ℚ) : ℂ) * Function.Periodic.qParam 1 (τ : ℂ) ^ m)
+      (((Polynomial.X - Polynomial.C (ModularForm.E₄ (ModularForm.heckeDiagMatrix ℓ • τ) ^ 3 /
+      ModularForm.discriminant (ModularForm.heckeDiagMatrix ℓ • τ))) * ∏ b : Fin ℓ, (Polynomial.X -
+      Polynomial.C (ModularForm.E₄ (ModularForm.heckeMatrix ℓ (b : ℕ) • τ) ^ 3 /
+      ModularForm.discriminant (ModularForm.heckeMatrix ℓ (b : ℕ) • τ)))).coeff k) :=
+  solution ℓ ζ hζ c hc k τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_PhiGenDescends_intCoeffs.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_PhiGenDescends_intCoeffs.lean
new file mode 100644
index 0000000000..c13811aca7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_PhiGenDescends_intCoeffs.lean
@@ -0,0 +1,314 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.PhiGenDescends.intCoeffs
+(ae0a893b-f12e-59f5-a601-8cf451da577a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b5b2f85b-7e0c-5ab0-abce-6c675d90775d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import Mathlib.RingTheory.IntegralClosure.IntegrallyClosed
+import Mathlib.RingTheory.Polynomial.RationalRoot
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality of the descended coefficients of Φ_ℓ
+
+Theorem statement: `ModularCurve.PhiGen.PhiGenDescends.intCoeffs`
+(`ae0a893b-f12e-59f5-a601-8cf451da577a`), by Claude, 2026-09-05.
+
+Proof: submission `b5b2f85b-7e0c-5ab0-abce-6c675d90775d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field equipped with an algebra structure over $\mathbb{Q}$, let $\ell$ be a prime, let
+$\zeta$ be a unit of $K$, and let $c \colon \mathbb{N} \to \mathrm{LaurentSeries}\,\mathbb{Q}$ be a
+family of rational Laurent series. Assume `PhiGenDescends ℓ ζ c`, that is: for every $k$, the
+coefficient of $X^k$ in the monic polynomial $\prod_{i \in \mathrm{Fin}(\ell+1)} (X -
+\mathrm{conj}\,\ell\,\zeta\,i)$ over $\mathrm{LaurentSeries}\,K$ equals the image under `coeffEmb K`
+(the coefficientwise application of $\mathbb{Q} \to K$) of `qExpand ℚ ℓ (c k)`, the Laurent series
+obtained from $c_k$ by multiplying all exponents by $\ell$; here the $\ell+1$ series
+$\mathrm{conj}\,\ell\,\zeta\,i$ are obtained from the coefficientwise image in $K$ of the series
+`jq` by the substitution `cosetSubst` attached to $\zeta$ and to the data `cosetA ℓ i`, `cosetB ℓ
+i`. Assume further that $\zeta^\ell = 1$. Then for every $k$ the series $c_k$ satisfies `IntCoeffs`:
+for each $m \in \mathbb{Z}$ there is an integer $z$ with $c_k$'s coefficient in degree $m$ equal to
+the image of $z$ in $\mathbb{Q}$.
+
+This is the integrality of the coefficients of the modular equation of prime level $\ell$: the
+elementary symmetric functions of the $\ell+1$ conjugates of the $q$-expansion of $j$ descend to
+Laurent series with integral coefficients. It feeds the construction of the modular polynomial data
+for $X_0(\ell)$, being used in
+[`ModularCurve.ModularPolynomialData.weighted_support_le`]
+(thm.html#ModularCurve.ModularPolynomialData.weighted_support_le),
+[`ModularCurve.PhiGen.splits_of_prime`](thm.html#ModularCurve.PhiGen.splits_of_prime) and
+[`ModularCurve.exists_modularPolynomialData_evalSymm`]
+(thm.html#ModularCurve.exists_modularPolynomialData_evalSymm).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_PhiGenDescends_intCoeffs.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_PhiGenDescends_intCoeffs
+
+noncomputable section
+
+open Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd jNum jNumQ jq \
+  ofPowerSeries_coeff_of_neg jq_pow qTwist qTwist_coeff PhiGen.PhiGenDescends coeffEmb \
+  coeffEmb_coeff"
+p2m_open "ModularCurve"
+
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd IntCoeffs PhiGenDescends"
+p2m_open "ModularCurve.PhiGen"
+
+section JqIntegrality
+
+private theorem intCoeffs_jq_pow (n : ℕ) : IntCoeffs (jq ^ n) := by
+  intro m
+  rw [jq_pow, HahnSeries.coeff_single_mul, one_mul]
+  by_cases hneg : (m - -(n : ℤ)) < 0
+  · exact ⟨0, by rw [ofPowerSeries_coeff_of_neg _ hneg, Int.cast_zero]⟩
+  · refine ⟨(PowerSeries.coeff (m - -(n : ℤ)).toNat (jNum ^ n) : ℤ), ?_⟩
+    have hcast : (m - -(n : ℤ)) = (((m - -(n : ℤ)).toNat : ℕ) : ℤ) :=
+      (Int.toNat_of_nonneg (not_lt.mp hneg)).symm
+    rw [hcast, HahnSeries.ofPowerSeries_apply_coeff]
+    change PowerSeries.coeff _ (jNumQ ^ n) = _
+    rw [jNumQ, ← map_pow, PowerSeries.coeff_map]
+    rfl
+
+private theorem intCoeffs_jq : IntCoeffs jq := by
+  have h := intCoeffs_jq_pow 1
+  rwa [pow_one] at h
+
+end JqIntegrality
+
+section IntegralCoeffs
+
+variable {K : Type*} [Field K]
+
+private def CoeffsIntegral (f : LaurentSeries K) : Prop :=
+  ∀ m : ℤ, f.coeff m ∈ integralClosure ℤ K
+
+private theorem coeffsIntegral_zero : CoeffsIntegral (0 : LaurentSeries K) := fun _ =>
+  Subalgebra.zero_mem _
+
+private theorem coeffsIntegral_one : CoeffsIntegral (1 : LaurentSeries K) := by
+  intro m
+  rw [HahnSeries.coeff_one]
+  split
+  · exact Subalgebra.one_mem _
+  · exact Subalgebra.zero_mem _
+
+private theorem CoeffsIntegral.neg {f : LaurentSeries K} (hf : CoeffsIntegral f) :
+    CoeffsIntegral (-f) := by
+  intro m
+  rw [HahnSeries.coeff_neg]
+  exact Subalgebra.neg_mem _ (hf m)
+
+private theorem CoeffsIntegral.mul {f g : LaurentSeries K} (hf : CoeffsIntegral f)
+    (hg : CoeffsIntegral g) : CoeffsIntegral (f * g) := by
+  intro m
+  rw [HahnSeries.coeff_mul]
+  exact Subalgebra.sum_mem _ fun ij _ => Subalgebra.mul_mem _ (hf ij.1) (hg ij.2)
+
+private theorem CoeffsIntegral.qExpand {f : LaurentSeries K} (hf : CoeffsIntegral f)
+    (N : ℕ) [NeZero N] : CoeffsIntegral (ModularCurve.qExpand K N f) := by
+  intro m
+  by_cases hdvd : (N : ℤ) ∣ m
+  · obtain ⟨c, rfl⟩ := hdvd
+    rw [qExpand_coeff_mul]
+    exact hf c
+  · rw [qExpand_coeff_of_not_dvd N f hdvd]
+    exact Subalgebra.zero_mem _
+
+private theorem CoeffsIntegral.qTwist {f : LaurentSeries K} (hf : CoeffsIntegral f)
+    (u : Kˣ) (hu : ∀ m : ℤ, ((u ^ m : Kˣ) : K) ∈ integralClosure ℤ K) :
+    CoeffsIntegral (ModularCurve.qTwist u f) := by
+  intro m
+  rw [qTwist_coeff]
+  exact Subalgebra.mul_mem _ (hu m) (hf m)
+
+private theorem intCast_mem_integralClosure (z : ℤ) : (z : K) ∈ integralClosure ℤ K := by
+  rw [mem_integralClosure_iff]
+  refine ⟨Polynomial.X - Polynomial.C z, Polynomial.monic_X_sub_C z, ?_⟩
+  simp
+
+private theorem val_mem_integralClosure_of_pow_eq_one {u : Kˣ} {n : ℕ} (hn : n ≠ 0)
+    (hu : u ^ n = 1) : (u : K) ∈ integralClosure ℤ K := by
+  rw [mem_integralClosure_iff]
+  refine ⟨Polynomial.X ^ n - Polynomial.C 1, Polynomial.monic_X_pow_sub_C 1 hn, ?_⟩
+  have hval : (u : K) ^ n = 1 := by
+    rw [← Units.val_pow_eq_pow_val, hu, Units.val_one]
+  simp [hval]
+
+private theorem zpow_val_mem_integralClosure_of_pow_eq_one {u : Kˣ} {n : ℕ} (hn : n ≠ 0)
+    (hu : u ^ n = 1) (m : ℤ) : ((u ^ m : Kˣ) : K) ∈ integralClosure ℤ K := by
+  have hrw : u ^ m = u ^ (m % (n : ℤ)).toNat := by
+    have h1 : u ^ m = u ^ (m % (n : ℤ)) := by
+      conv_lhs => rw [← Int.emod_add_mul_ediv m (n : ℤ)]
+      rw [zpow_add, zpow_mul, zpow_natCast, hu, one_zpow, mul_one]
+    rw [h1, ← zpow_natCast,
+      Int.toNat_of_nonneg (Int.emod_nonneg m (by exact_mod_cast hn))]
+  rw [hrw, Units.val_pow_eq_pow_val]
+  exact Subalgebra.pow_mem _ (val_mem_integralClosure_of_pow_eq_one hn hu) _
+
+private theorem coeffsIntegral_coeff_X_sub_C {a : LaurentSeries K}
+    (ha : CoeffsIntegral a) (k : ℕ) :
+    CoeffsIntegral ((Polynomial.X - Polynomial.C a).coeff k) := by
+  match k with
+  | 0 =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X_zero, Polynomial.coeff_C_zero,
+      zero_sub]
+    exact CoeffsIntegral.neg ha
+  | 1 =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X_one, Polynomial.coeff_C,
+      ite_eq_right (one_ne_zero), sub_zero]
+    exact coeffsIntegral_one
+  | (k + 2) =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X, Polynomial.coeff_C]
+    rw [ite_eq_right (by omega), ite_eq_right (by omega), sub_zero]
+    exact coeffsIntegral_zero
+
+private theorem coeffsIntegral_coeff_mul {p q : Polynomial (LaurentSeries K)}
+    (hp : ∀ k, CoeffsIntegral (p.coeff k)) (hq : ∀ k, CoeffsIntegral (q.coeff k))
+    (k : ℕ) : CoeffsIntegral ((p * q).coeff k) := by
+  rw [Polynomial.coeff_mul]
+  intro a
+  rw [HahnSeries.coeff_sum]
+  exact Subalgebra.sum_mem _ fun ij _ => CoeffsIntegral.mul (hp ij.1) (hq ij.2) a
+
+private theorem coeffsIntegral_coeff_prod {ι : Type*} (s : Finset ι)
+    (p : ι → Polynomial (LaurentSeries K))
+    (hp : ∀ i ∈ s, ∀ k, CoeffsIntegral ((p i).coeff k)) :
+    ∀ k, CoeffsIntegral ((∏ i ∈ s, p i).coeff k) := by
+  induction s using Finset.cons_induction with
+  | empty =>
+    intro k
+    simp only [Finset.prod_empty]
+    rcases Nat.eq_zero_or_pos k with rfl | hk
+    · simpa using coeffsIntegral_one
+    · rw [Polynomial.coeff_one, ite_eq_right (by omega)]
+      exact coeffsIntegral_zero
+  | cons a s _ha ih =>
+    intro k
+    rw [Finset.prod_cons]
+    exact coeffsIntegral_coeff_mul (hp a (Finset.mem_cons_self a s))
+      (ih fun i hi k => hp i (Finset.mem_cons_of_mem hi) k) k
+
+end IntegralCoeffs
+
+section ConjIntegral
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem coeffsIntegral_jqK : CoeffsIntegral (coeffEmb K jq) := by
+  intro m
+  obtain ⟨z, hz⟩ := intCoeffs_jq m
+  rw [coeffEmb_coeff, hz, map_intCast]
+  exact intCast_mem_integralClosure z
+
+variable (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+private theorem coeffsIntegral_conj (hζ1 : ζ ^ ℓ = 1) (i : Fin (ℓ + 1)) :
+    CoeffsIntegral (conj ℓ ζ i) := by
+  induction i using Fin.cases with
+  | zero =>
+    rw [conj_zero]
+    exact CoeffsIntegral.qExpand coeffsIntegral_jqK (ℓ * ℓ)
+  | succ b =>
+    rw [conj_succ]
+    refine CoeffsIntegral.qTwist coeffsIntegral_jqK _ fun m => ?_
+    refine zpow_val_mem_integralClosure_of_pow_eq_one hℓ.out.ne_zero ?_ m
+    rw [← pow_mul, mul_comm (b : ℕ) ℓ, pow_mul, hζ1, one_pow]
+
+variable {ℓ ζ}
+
+private theorem coeffsIntegral_phiProd_coeff (hζ1 : ζ ^ ℓ = 1) (k : ℕ) :
+    CoeffsIntegral ((phiProd ℓ (conj ℓ ζ)).coeff k) := by
+  rw [phiProd]
+  exact coeffsIntegral_coeff_prod Finset.univ _
+    (fun i _ k => coeffsIntegral_coeff_X_sub_C (coeffsIntegral_conj ℓ ζ hζ1 i) k) k
+
+end ConjIntegral
+
+section IntegralityDescent
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem exists_intCast_eq_of_mem {q : ℚ}
+    (h : algebraMap ℚ K q ∈ integralClosure ℤ K) : ∃ z : ℤ, q = (z : ℚ) := by
+  rw [mem_integralClosure_iff] at h
+  obtain ⟨P, hPmonic, hPeval⟩ := h
+  have hcomp : algebraMap ℤ K = (algebraMap ℚ K).comp (Int.castRingHom ℚ) :=
+    Subsingleton.elim _ _
+  rw [hcomp, ← Polynomial.hom_eval₂] at hPeval
+  have h0 : Polynomial.eval₂ (Int.castRingHom ℚ) q P = 0 :=
+    FaithfulSMul.algebraMap_injective ℚ K (by rw [hPeval, map_zero])
+  have hint : IsIntegral ℤ q :=
+    ⟨P, hPmonic, by
+      rwa [show algebraMap ℤ ℚ = Int.castRingHom ℚ from Subsingleton.elim _ _]⟩
+  obtain ⟨z, hz⟩ := IsIntegrallyClosed.isIntegral_iff.mp hint
+  exact ⟨z, by rw [← hz]; simp⟩
+
+variable {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+
+private theorem PhiGenDescends.intCoeffs (hc : PhiGenDescends ℓ ζ c) (hζ1 : ζ ^ ℓ = 1) (k : ℕ) :
+    IntCoeffs (c k) := by
+  intro m
+  have h1 : algebraMap ℚ K ((c k).coeff m)
+      = ((phiProd ℓ (conj ℓ ζ)).coeff k).coeff ((ℓ : ℤ) * m) := by
+    rw [hc k, coeffEmb_coeff, qExpand_coeff_mul]
+  have h2 := coeffsIntegral_phiProd_coeff hζ1 k ((ℓ : ℤ) * m)
+  rw [← h1] at h2
+  exact exists_intCast_eq_of_mem h2
+
+end IntegralityDescent
+
+end PhiGen
+
+end ModularCurve
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_PhiGen_PhiGenDescends_intCoeffs.ModularCurve
+  _root_.ModularCurve.PhiGen
+  _root_.P2MW.S_ModularCurve_PhiGen_PhiGenDescends_intCoeffs.ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ}
+    {c : ℕ → LaurentSeries ℚ} (hc : PhiGenDescends ℓ ζ c) (hζ1 : ζ ^ ℓ = 1) (k : ℕ) :
+    IntCoeffs (c k) :=
+  ModularCurve.PhiGen.PhiGenDescends.intCoeffs hc hζ1 k
+
+end S_ModularCurve_PhiGen_PhiGenDescends_intCoeffs
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_PhiGenDescends_intCoeffs (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.PhiGenDescends.intCoeffs {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ} (hc : PhiGenDescends ℓ ζ c)
+    (hζ1 : ζ ^ ℓ = 1) (k : ℕ) :
+    IntCoeffs (c k) :=
+  solution hc hζ1 k
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_PhiGenDescends_poleOrderLE.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_PhiGenDescends_poleOrderLE.lean
new file mode 100644
index 0000000000..d322c09826
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_PhiGenDescends_poleOrderLE.lean
@@ -0,0 +1,412 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.PhiGenDescends.poleOrderLE
+(78c5f2e1-bde3-532a-9293-958c72dc0121) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1742ce90-b7aa-54a0-941e-667b9883825d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_injective
+import Mathlib.Algebra.BigOperators.Fin
+import Mathlib.Algebra.Polynomial.Eval.Degree
+import Mathlib.Tactic.Linarith
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Pole order at most ℓ+1 for descended coefficients
+
+Theorem statement: `ModularCurve.PhiGen.PhiGenDescends.poleOrderLE`
+(`78c5f2e1-bde3-532a-9293-958c72dc0121`), by Claude, 2026-09-05.
+
+Proof: submission `1742ce90-b7aa-54a0-941e-667b9883825d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field equipped with a $\mathbb{Q}$-algebra structure, let $\ell$ be a prime, let
+$\zeta$ be a unit of $K$, and let $c : \mathbb{N} \to \mathbb{Q}((q))$ be a family of Laurent series
+over $\mathbb{Q}$. Assume `PhiGenDescends ℓ ζ c`, that is: for every $k \in \mathbb{N}$, the
+coefficient of $X^k$ in the monic polynomial $\prod_{i \in \mathrm{Fin}(\ell+1)} (X -
+\mathrm{conj}\,\ell\,\zeta\,i)$ over $K((q))$, whose roots are the $\ell+1$ conjugate Laurent series
+`conj ℓ ζ i` produced by the coset substitution `cosetSubst` applied to the coefficientwise image of
+the series `jq` in $K((q))$, coincides with
+$\mathrm{coeffEmb}_K(\mathrm{qExpand}_{\mathbb{Q},\ell}(c_k))$; here
+$\mathrm{qExpand}_{\mathbb{Q},\ell}$ is the ring homomorphism of $\mathbb{Q}((q))$ multiplying all
+exponents by $\ell$, and $\mathrm{coeffEmb}_K$ applies $\mathbb{Q} \to K$ to each coefficient. Then
+for every $k \in \mathbb{N}$ one has `PoleOrderLE (c k) (ℓ + 1)`, i.e. the coefficient of $q^{m}$ in
+$c_k$ vanishes for every integer $m < -(\ell+1)$: each $c_k$ has a pole of order at most $\ell+1$ at
+$q = 0$.
+
+This is the pole bound for the coefficient family descending the product over the $\ell+1$
+conjugates, the series whose coefficients give the modular equation of level $\ell$; the bound
+$\ell+1$ results from the bound $\ell^2+\ell$ on the product's coefficients together with the
+substitution multiplying exponents by $\ell$. It feeds the support bound
+[`ModularCurve.ModularPolynomialData.weighted_support_le`]
+(thm.html#ModularCurve.ModularPolynomialData.weighted_support_le)
+and the construction of modular polynomial data in
+[`ModularCurve.PhiGen.exists_modularPolynomialData_coeff_eq`]
+(thm.html#ModularCurve.PhiGen.exists_modularPolynomialData_coeff_eq),
+as well as
+[`ModularCurve.PhiGen.evalSymm_of_coeff_evalAtJ_eq`]
+(thm.html#ModularCurve.PhiGen.evalSymm_of_coeff_evalAtJ_eq).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_PhiGenDescends_poleOrderLE.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_PhiGenDescends_poleOrderLE
+
+noncomputable section
+
+open Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_qExpand algebraMap_apply_eq_single jq coeff_jq_pow_self coeff_jq_pow_of_lt \
+  coeff_jq_of_lt jqN evalAtJ qTwist qTwist_coeff PoleOrderLE PhiGen.PhiGenDescends coeffMap \
+  coeffEmb coeffEmb_coeff coeffMap_qExpand coeffEmb_injective"
+p2m_open "ModularCurve"
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd phiProd_monic phiProd_natDegree \
+  phiProd_eval_conj TPoleOrderLE tPoleOrderLE_iff_poleOrderLE JSimplePole PhiGenDescends"
+p2m_open "ModularCurve.PhiGen"
+
+section CoeffEmbJq
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+private theorem coeff_coeffEmb_jq_of_lt {k : ℤ} (hk : k < -1) : (coeffEmb K jq).coeff k = 0 := by
+  rw [coeffEmb_coeff, coeff_jq_of_lt hk, map_zero]
+
+end CoeffEmbJq
+
+theorem jSimplePole_jqK {K : Type*} [Field K] [Algebra ℚ K] : JSimplePole (coeffEmb K jq) :=
+  fun _ hm => coeff_coeffEmb_jq_of_lt K hm
+
+theorem tPoleOrderLE_coeffEmb_iff {K : Type*} [Field K] [Algebra ℚ K]
+    (f : LaurentSeries ℚ) (n : ℕ) :
+    TPoleOrderLE (coeffEmb K f) n ↔ TPoleOrderLE f n := by
+  constructor
+  · intro h m hm
+    have h0 := h m hm
+    rw [coeffEmb_coeff] at h0
+    exact FaithfulSMul.algebraMap_injective ℚ K (by rw [h0, map_zero])
+  · intro h m hm
+    rw [coeffEmb_coeff, h m hm, map_zero]
+
+theorem tPoleOrderLE_of_qExpand {K : Type*} [Field K] {f : LaurentSeries K} {N n : ℕ}
+    [NeZero N] (h : TPoleOrderLE (qExpand K N f) (N * n)) : TPoleOrderLE f n := by
+  intro m hm
+  rw [← qExpand_coeff_mul N f m]
+  refine h _ ?_
+  push_cast
+  have hN : 0 < (N : ℤ) := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  nlinarith
+
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.mono {K : Type*} [Field K]
+    {f : LaurentSeries K} {m n : ℕ}
+    (hf : TPoleOrderLE f m) (hmn : m ≤ n) : TPoleOrderLE f n :=
+  fun k hk => hf k (by omega)
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.mono"
+private theorem tPoleOrderLE_zero {K : Type*} [Field K] (n : ℕ) :
+    TPoleOrderLE (0 : LaurentSeries K) n :=
+  fun _ _ => rfl
+
+private theorem tPoleOrderLE_one {K : Type*} [Field K] :
+    TPoleOrderLE (1 : LaurentSeries K) 0 := by
+  intro m hm
+  rw [HahnSeries.coeff_one, ite_eq_right (by omega)]
+
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.neg {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) : TPoleOrderLE (-f) n := by
+  intro m hm
+  rw [HahnSeries.coeff_neg, hf m hm, neg_zero]
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.neg"
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.mul {K : Type*} [Field K]
+    {f g : LaurentSeries K} {m n : ℕ}
+    (hf : TPoleOrderLE f m) (hg : TPoleOrderLE g n) : TPoleOrderLE (f * g) (m + n) := by
+  intro k hk
+  rw [HahnSeries.coeff_mul]
+  refine Finset.sum_eq_zero fun ij hij => ?_
+  obtain ⟨-, -, hsum⟩ := Finset.mem_antidiagonal.mp hij
+  by_cases hi : ij.1 < -(m : ℤ)
+  · rw [hf ij.1 hi, zero_mul]
+  · refine mul_eq_zero_of_right _ (hg ij.2 ?_)
+    push_cast at hk
+    omega
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.mul"
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.qTwist {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) (u : Kˣ) : TPoleOrderLE (ModularCurve.qTwist u f) n := by
+  intro m hm
+  rw [qTwist_coeff, hf m hm, mul_zero]
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.qTwist"
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.qExpand {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) (N : ℕ) [NeZero N] :
+    TPoleOrderLE (ModularCurve.qExpand K N f) (N * n) := by
+  intro m hm
+  by_cases hdvd : (N : ℤ) ∣ m
+  · obtain ⟨c, rfl⟩ := hdvd
+    rw [qExpand_coeff_mul]
+    refine hf c ?_
+    have hN : 0 < (N : ℤ) := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+    push_cast at hm
+    nlinarith
+  · exact qExpand_coeff_of_not_dvd N f hdvd
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.qExpand"
+private theorem tPoleOrderLE_of_jSimplePole {K : Type*} [Field K] (J : LaurentSeries K)
+    (hJ : JSimplePole J) : TPoleOrderLE J 1 := by
+  intro m hm
+  exact hJ m (by push_cast at hm; omega)
+
+private def conjPoleBound (ℓ : ℕ) : Fin (ℓ + 1) → ℕ :=
+  fun i => if i = 0 then ℓ * ℓ else 1
+
+private theorem conjPoleBound_zero (ℓ : ℕ) : conjPoleBound ℓ 0 = ℓ * ℓ := ite_eq_left rfl
+
+private theorem conjPoleBound_succ (ℓ : ℕ) (b : Fin ℓ) : conjPoleBound ℓ b.succ = 1 :=
+  ite_eq_right (Fin.succ_ne_zero b)
+
+private theorem sum_conjPoleBound (ℓ : ℕ) :
+    ∑ i : Fin (ℓ + 1), conjPoleBound ℓ i = ℓ * ℓ + ℓ := by
+  rw [Fin.sum_univ_succ, conjPoleBound_zero]
+  congr 1
+  simp only [conjPoleBound_succ]
+  simp
+
+private theorem tPoleOrderLE_conj_zero {K : Type*} [Field K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {J : LaurentSeries K}
+    {conj : Fin (ℓ + 1) → LaurentSeries K} (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hJ : JSimplePole J) : TPoleOrderLE (conj 0) (ℓ * ℓ) := by
+  rw [hconj0]
+  have h := (tPoleOrderLE_of_jSimplePole J hJ).qExpand (ℓ * ℓ)
+  simpa using h
+
+private theorem tPoleOrderLE_conj_succ {K : Type*} [Field K] {ℓ : ℕ} {ζ : Kˣ}
+    {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (b : Fin ℓ) : TPoleOrderLE (conj b.succ) 1 := by
+  rw [hconjS b]
+  exact (tPoleOrderLE_of_jSimplePole J hJ).qTwist _
+
+private theorem tPoleOrderLE_conj {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+    {ζ : Kˣ} {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (i : Fin (ℓ + 1)) :
+    TPoleOrderLE (conj i) (conjPoleBound ℓ i) := by
+  rcases Fin.eq_zero_or_eq_succ i with rfl | ⟨b, rfl⟩
+  · rw [conjPoleBound_zero]
+    exact tPoleOrderLE_conj_zero hconj0 hJ
+  · rw [conjPoleBound_succ]
+    exact tPoleOrderLE_conj_succ hconjS hJ b
+
+private theorem tPoleOrderLE_coeff_X_sub_C {K : Type*} [Field K] {a : LaurentSeries K}
+    {n : ℕ} (ha : TPoleOrderLE a n) (k : ℕ) :
+    TPoleOrderLE ((Polynomial.X - Polynomial.C a).coeff k) n := by
+  match k with
+  | 0 =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X_zero, Polynomial.coeff_C_zero,
+      zero_sub]
+    exact ha.neg
+  | 1 =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X_one, Polynomial.coeff_C,
+      ite_eq_right (one_ne_zero), sub_zero]
+    exact tPoleOrderLE_one.mono (Nat.zero_le _)
+  | (k + 2) =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X, Polynomial.coeff_C]
+    rw [ite_eq_right (by omega), ite_eq_right (by omega), sub_zero]
+    exact tPoleOrderLE_zero _
+
+private theorem tPoleOrderLE_coeff_mul {K : Type*} [Field K]
+    {p q : Polynomial (LaurentSeries K)} {m n : ℕ}
+    (hp : ∀ k, TPoleOrderLE (p.coeff k) m) (hq : ∀ k, TPoleOrderLE (q.coeff k) n) (k : ℕ) :
+    TPoleOrderLE ((p * q).coeff k) (m + n) := by
+  rw [Polynomial.coeff_mul]
+  intro a ha
+  rw [HahnSeries.coeff_sum]
+  exact Finset.sum_eq_zero fun ij _ => (hp ij.1).mul (hq ij.2) a ha
+
+private theorem tPoleOrderLE_coeff_prod {K : Type*} [Field K] {ι : Type*} (s : Finset ι)
+    (p : ι → Polynomial (LaurentSeries K)) (n : ι → ℕ)
+    (hp : ∀ i ∈ s, ∀ k, TPoleOrderLE ((p i).coeff k) (n i)) :
+    ∀ k, TPoleOrderLE ((∏ i ∈ s, p i).coeff k) (∑ i ∈ s, n i) := by
+  induction s using Finset.cons_induction with
+  | empty =>
+    intro k
+    simp only [Finset.prod_empty, Finset.sum_empty]
+    rcases Nat.eq_zero_or_pos k with rfl | hk
+    · simpa using tPoleOrderLE_one
+    · rw [Polynomial.coeff_one, ite_eq_right (by omega)]
+      exact tPoleOrderLE_zero 0
+  | cons a s ha ih =>
+    intro k
+    rw [Finset.prod_cons, Finset.sum_cons]
+    exact tPoleOrderLE_coeff_mul (hp a (Finset.mem_cons_self a s))
+      (ih fun i hi k => hp i (Finset.mem_cons_of_mem hi) k) k
+
+private theorem phiProd_def {K : Type*} [Field K] (ℓ : ℕ)
+    (conj : Fin (ℓ + 1) → LaurentSeries K) :
+    phiProd ℓ conj = ∏ i : Fin (ℓ + 1), (Polynomial.X - Polynomial.C (conj i)) := rfl
+
+private theorem tPoleOrderLE_phiProd_coeff {K : Type*} [Field K] (ℓ : ℕ)
+    [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (J : LaurentSeries K)
+    (conj : Fin (ℓ + 1) → LaurentSeries K) (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (k : ℕ) :
+    TPoleOrderLE ((phiProd ℓ conj).coeff k) (ℓ * ℓ + ℓ) := by
+  rw [phiProd_def, ← sum_conjPoleBound ℓ]
+  exact tPoleOrderLE_coeff_prod Finset.univ _ (conjPoleBound ℓ)
+    (fun i _ k => tPoleOrderLE_coeff_X_sub_C (tPoleOrderLE_conj hconj0 hconjS hJ i) k) k
+
+theorem coeffEmb_qExpand_injective {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] :
+    Function.Injective (fun f : LaurentSeries ℚ => coeffEmb K (qExpand ℚ ℓ f)) :=
+  (coeffEmb_injective K).comp (qExpand_injective (R := ℚ) ℓ)
+
+theorem PhiGenDescends.c_top {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) : c (ℓ + 1) = 1 := by
+  refine coeffEmb_qExpand_injective (K := K) (ℓ := ℓ) ?_
+  have h1 : (phiProd ℓ (conj ℓ ζ)).coeff (ℓ + 1) = 1 := by
+    have h := (phiProd_monic ℓ (conj ℓ ζ)).coeff_natDegree
+    rwa [phiProd_natDegree ℓ (conj ℓ ζ)] at h
+  simp only [← hc (ℓ + 1), h1, map_one]
+
+theorem PhiGenDescends.c_eq_zero {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) {k : ℕ} (hk : ℓ + 1 < k) : c k = 0 := by
+  refine coeffEmb_qExpand_injective (K := K) (ℓ := ℓ) ?_
+  have h1 : (phiProd ℓ (conj ℓ ζ)).coeff k = 0 :=
+    Polynomial.coeff_eq_zero_of_natDegree_lt (by rw [phiProd_natDegree]; exact hk)
+  simp only [← hc k, h1, map_zero]
+
+private theorem PhiGenDescends.poleOrderLE {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) (k : ℕ) : PoleOrderLE (c k) (ℓ + 1) := by
+  have hW3 : TPoleOrderLE ((phiProd ℓ (conj ℓ ζ)).coeff k) (ℓ * ℓ + ℓ) :=
+    tPoleOrderLE_phiProd_coeff ℓ ζ (coeffEmb K jq) (conj ℓ ζ) (conj_zero ℓ ζ) (conj_succ ℓ ζ)
+      jSimplePole_jqK k
+  rw [hc k, tPoleOrderLE_coeffEmb_iff] at hW3
+  rw [← tPoleOrderLE_iff_poleOrderLE]
+  exact tPoleOrderLE_of_qExpand (hW3.mono (le_of_eq (by ring)))
+
+theorem PhiGenDescends.sum_mul_jqN_pow_eq_zero {K : Type*} [Field K] [Algebra ℚ K]
+    {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) :
+    ∑ k ∈ Finset.range (ℓ + 2), c k * (jqN ℓ) ^ k = 0 := by
+  set F : LaurentSeries ℚ →+* LaurentSeries K := (coeffEmb K).comp (qExpand ℚ ℓ) with hF
+  have hFapp : ∀ f : LaurentSeries ℚ, F f = coeffEmb K (qExpand ℚ ℓ f) := fun f => rfl
+  have hFinj : Function.Injective F := coeffEmb_qExpand_injective
+  have hconj0 : conj ℓ ζ (0 : Fin (ℓ + 1)) = F (jqN ℓ) := by
+    change conj ℓ ζ 0 = coeffMap (algebraMap ℚ K) (qExpand ℚ ℓ (jqN ℓ))
+    rw [conj_zero, jqN, qExpand_qExpand, coeffMap_qExpand]
+    rfl
+  have hterm : ∀ k ∈ Finset.range (ℓ + 2),
+      F (c k * (jqN ℓ) ^ k)
+        = (phiProd ℓ (conj ℓ ζ)).coeff k * (conj ℓ ζ 0) ^ k := by
+    intro k _
+    rw [map_mul, map_pow, ← hconj0, hFapp, hc k]
+  refine hFinj ?_
+  rw [map_zero, map_sum, Finset.sum_congr rfl hterm]
+  rw [← Polynomial.eval_eq_sum_range' (n := ℓ + 2) (by rw [phiProd_natDegree]; omega)]
+  exact phiProd_eval_conj ℓ _ 0
+
+theorem evalAtJ_eq_aeval_map (Q : Polynomial ℤ) :
+    evalAtJ Q = Polynomial.aeval jq (Q.map (Int.castRingHom ℚ)) := by
+  have hcomp : (algebraMap ℚ (LaurentSeries ℚ)).comp (Int.castRingHom ℚ)
+      = algebraMap ℤ (LaurentSeries ℚ) := Subsingleton.elim _ _
+  rw [Polynomial.aeval_def, Polynomial.eval₂_map, hcomp]
+  rfl
+
+private theorem aeval_jq_eq_zero {p : Polynomial ℚ} (hp : Polynomial.aeval jq p = 0) :
+    p = 0 := by
+  by_contra hp0
+  set n := p.natDegree with hn
+  have hcoeff : (Polynomial.aeval jq p).coeff (-(n : ℤ)) = p.coeff n := by
+    rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+      Finset.sum_eq_single n]
+    · rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_self,
+        mul_one]
+    · intro i hi hin
+      have hilt : i < n := lt_of_le_of_ne (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hin
+      rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_of_lt,
+        mul_zero]
+      omega
+    · intro hn'
+      exact absurd (Finset.self_mem_range_succ n) hn'
+  rw [hp] at hcoeff
+  simp only [HahnSeries.coeff_zero] at hcoeff
+  exact hp0 (Polynomial.leadingCoeff_eq_zero.mp hcoeff.symm)
+
+theorem evalAtJ_injective : Function.Injective evalAtJ := by
+  intro P Q hPQ
+  refine Polynomial.map_injective (Int.castRingHom ℚ) Int.cast_injective ?_
+  rw [evalAtJ_eq_aeval_map, evalAtJ_eq_aeval_map] at hPQ
+  have h0 : Polynomial.aeval jq
+      (P.map (Int.castRingHom ℚ) - Q.map (Int.castRingHom ℚ)) = 0 := by
+    rw [map_sub, hPQ, sub_self]
+  exact sub_eq_zero.mp (aeval_jq_eq_zero h0)
+
+end PhiGen
+end ModularCurve
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_PhiGen_PhiGenDescends_poleOrderLE.ModularCurve
+  _root_.ModularCurve.PhiGen
+  _root_.P2MW.S_ModularCurve_PhiGen_PhiGenDescends_poleOrderLE.ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ}
+    {c : ℕ → LaurentSeries ℚ} (hc : PhiGenDescends ℓ ζ c) (k : ℕ) :
+    PoleOrderLE (c k) (ℓ + 1) :=
+  ModularCurve.PhiGen.PhiGenDescends.poleOrderLE hc k
+
+end S_ModularCurve_PhiGen_PhiGenDescends_poleOrderLE
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_PhiGenDescends_poleOrderLE (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.PhiGenDescends.poleOrderLE {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ} (hc : PhiGenDescends ℓ ζ c) (k : ℕ)
+    :
+    PoleOrderLE (c k) (ℓ + 1) :=
+  solution hc k
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_PhiGenDescends_sum_mul_jqN_pow_eq_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_PhiGenDescends_sum_mul_jqN_pow_eq_zero.lean
new file mode 100644
index 0000000000..ea134f757b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_PhiGenDescends_sum_mul_jqN_pow_eq_zero.lean
@@ -0,0 +1,408 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.PhiGenDescends.sum_mul_jqN_pow_eq_zero
+(91ac86c2-21b0-512a-8404-c805a4d56b52) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission dd26778e-5332-5ffa-ac89-f7cde3c65779
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_injective
+import Mathlib.Algebra.BigOperators.Fin
+import Mathlib.Algebra.Polynomial.Eval.Degree
+import Mathlib.Tactic.Linarith
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Descended coefficients annihilate j(q^ℓ)
+
+Theorem statement: `ModularCurve.PhiGen.PhiGenDescends.sum_mul_jqN_pow_eq_zero`
+(`91ac86c2-21b0-512a-8404-c805a4d56b52`), by Claude, 2026-09-05.
+
+Proof: submission `dd26778e-5332-5ffa-ac89-f7cde3c65779`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field equipped with a $\mathbb{Q}$-algebra structure, let $\ell$ be a prime, let
+$\zeta$ be a unit of $K$, and let $c : \mathbb{N} \to$ `LaurentSeries ℚ` be a family of Laurent
+series over $\mathbb{Q}$. Assume `PhiGenDescends ℓ ζ c`, that is: for every $k$, the $k$-th
+coefficient of the polynomial $\prod_{i : \mathrm{Fin}(\ell+1)} (X -
+C(\mathtt{conj}\,\ell\,\zeta\,i))$ over `LaurentSeries K` — where the $i$-th conjugate is
+`cosetSubst ζ (cosetA ℓ i) (cosetB ℓ i)` applied to the image of the $q$-expansion `jq` under the
+coefficientwise embedding `coeffEmb K` — is equal to `coeffEmb K (qExpand ℚ ℓ (c k))`, the image
+under that embedding of the series obtained from $c_k$ by the substitution $q \mapsto q^{\ell}$. The
+conclusion is the identity $\sum_{k=0}^{\ell+1} c_k \cdot (\mathtt{jqN}\ \ell)^k = 0$ in
+`LaurentSeries ℚ`, where $\mathtt{jqN}\ \ell = \mathtt{qExpand}\ \mathbb{Q}\ \ell\ \mathtt{jq}$ is
+the $q$-expansion of $j$ with $q$ replaced by $q^{\ell}$.
+
+This is the vanishing $\Phi_{\ell}(j(q), j(q^{\ell})) = 0$ of the modular equation of level $\ell$,
+recorded at the level of Laurent series and before the coefficients $c_k$ are identified as
+polynomials in $j$. It is used in the construction of the modular polynomial data for $X_0(\ell)$,
+namely by
+[`ModularCurve.ModularPolynomialData.weighted_support_le`]
+(thm.html#ModularCurve.ModularPolynomialData.weighted_support_le)
+and
+[`ModularCurve.PhiGen.exists_modularPolynomialData_coeff_eq`]
+(thm.html#ModularCurve.PhiGen.exists_modularPolynomialData_coeff_eq).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_PhiGenDescends_sum_mul_jqN_pow_eq_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_PhiGenDescends_sum_mul_jqN_pow_eq_zero
+
+noncomputable section
+
+open Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_qExpand algebraMap_apply_eq_single jq coeff_jq_pow_self coeff_jq_pow_of_lt \
+  coeff_jq_of_lt jqN evalAtJ qTwist qTwist_coeff PoleOrderLE PhiGen.PhiGenDescends coeffMap \
+  coeffEmb coeffEmb_coeff coeffMap_qExpand coeffEmb_injective"
+p2m_open "ModularCurve"
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd phiProd_monic phiProd_natDegree \
+  phiProd_eval_conj TPoleOrderLE tPoleOrderLE_iff_poleOrderLE JSimplePole PhiGenDescends"
+p2m_open "ModularCurve.PhiGen"
+
+section CoeffEmbJq
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+private theorem coeff_coeffEmb_jq_of_lt {k : ℤ} (hk : k < -1) : (coeffEmb K jq).coeff k = 0 := by
+  rw [coeffEmb_coeff, coeff_jq_of_lt hk, map_zero]
+
+end CoeffEmbJq
+
+theorem jSimplePole_jqK {K : Type*} [Field K] [Algebra ℚ K] : JSimplePole (coeffEmb K jq) :=
+  fun _ hm => coeff_coeffEmb_jq_of_lt K hm
+
+theorem tPoleOrderLE_coeffEmb_iff {K : Type*} [Field K] [Algebra ℚ K]
+    (f : LaurentSeries ℚ) (n : ℕ) :
+    TPoleOrderLE (coeffEmb K f) n ↔ TPoleOrderLE f n := by
+  constructor
+  · intro h m hm
+    have h0 := h m hm
+    rw [coeffEmb_coeff] at h0
+    exact FaithfulSMul.algebraMap_injective ℚ K (by rw [h0, map_zero])
+  · intro h m hm
+    rw [coeffEmb_coeff, h m hm, map_zero]
+
+theorem tPoleOrderLE_of_qExpand {K : Type*} [Field K] {f : LaurentSeries K} {N n : ℕ}
+    [NeZero N] (h : TPoleOrderLE (qExpand K N f) (N * n)) : TPoleOrderLE f n := by
+  intro m hm
+  rw [← qExpand_coeff_mul N f m]
+  refine h _ ?_
+  push_cast
+  have hN : 0 < (N : ℤ) := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  nlinarith
+
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.mono {K : Type*} [Field K]
+    {f : LaurentSeries K} {m n : ℕ}
+    (hf : TPoleOrderLE f m) (hmn : m ≤ n) : TPoleOrderLE f n :=
+  fun k hk => hf k (by omega)
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.mono"
+private theorem tPoleOrderLE_zero {K : Type*} [Field K] (n : ℕ) :
+    TPoleOrderLE (0 : LaurentSeries K) n :=
+  fun _ _ => rfl
+
+private theorem tPoleOrderLE_one {K : Type*} [Field K] :
+    TPoleOrderLE (1 : LaurentSeries K) 0 := by
+  intro m hm
+  rw [HahnSeries.coeff_one, ite_eq_right (by omega)]
+
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.neg {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) : TPoleOrderLE (-f) n := by
+  intro m hm
+  rw [HahnSeries.coeff_neg, hf m hm, neg_zero]
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.neg"
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.mul {K : Type*} [Field K]
+    {f g : LaurentSeries K} {m n : ℕ}
+    (hf : TPoleOrderLE f m) (hg : TPoleOrderLE g n) : TPoleOrderLE (f * g) (m + n) := by
+  intro k hk
+  rw [HahnSeries.coeff_mul]
+  refine Finset.sum_eq_zero fun ij hij => ?_
+  obtain ⟨-, -, hsum⟩ := Finset.mem_antidiagonal.mp hij
+  by_cases hi : ij.1 < -(m : ℤ)
+  · rw [hf ij.1 hi, zero_mul]
+  · refine mul_eq_zero_of_right _ (hg ij.2 ?_)
+    push_cast at hk
+    omega
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.mul"
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.qTwist {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) (u : Kˣ) : TPoleOrderLE (ModularCurve.qTwist u f) n := by
+  intro m hm
+  rw [qTwist_coeff, hf m hm, mul_zero]
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.qTwist"
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.qExpand {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) (N : ℕ) [NeZero N] :
+    TPoleOrderLE (ModularCurve.qExpand K N f) (N * n) := by
+  intro m hm
+  by_cases hdvd : (N : ℤ) ∣ m
+  · obtain ⟨c, rfl⟩ := hdvd
+    rw [qExpand_coeff_mul]
+    refine hf c ?_
+    have hN : 0 < (N : ℤ) := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+    push_cast at hm
+    nlinarith
+  · exact qExpand_coeff_of_not_dvd N f hdvd
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.qExpand"
+private theorem tPoleOrderLE_of_jSimplePole {K : Type*} [Field K] (J : LaurentSeries K)
+    (hJ : JSimplePole J) : TPoleOrderLE J 1 := by
+  intro m hm
+  exact hJ m (by push_cast at hm; omega)
+
+private def conjPoleBound (ℓ : ℕ) : Fin (ℓ + 1) → ℕ :=
+  fun i => if i = 0 then ℓ * ℓ else 1
+
+private theorem conjPoleBound_zero (ℓ : ℕ) : conjPoleBound ℓ 0 = ℓ * ℓ := ite_eq_left rfl
+
+private theorem conjPoleBound_succ (ℓ : ℕ) (b : Fin ℓ) : conjPoleBound ℓ b.succ = 1 :=
+  ite_eq_right (Fin.succ_ne_zero b)
+
+private theorem sum_conjPoleBound (ℓ : ℕ) :
+    ∑ i : Fin (ℓ + 1), conjPoleBound ℓ i = ℓ * ℓ + ℓ := by
+  rw [Fin.sum_univ_succ, conjPoleBound_zero]
+  congr 1
+  simp only [conjPoleBound_succ]
+  simp
+
+private theorem tPoleOrderLE_conj_zero {K : Type*} [Field K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {J : LaurentSeries K}
+    {conj : Fin (ℓ + 1) → LaurentSeries K} (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hJ : JSimplePole J) : TPoleOrderLE (conj 0) (ℓ * ℓ) := by
+  rw [hconj0]
+  have h := (tPoleOrderLE_of_jSimplePole J hJ).qExpand (ℓ * ℓ)
+  simpa using h
+
+private theorem tPoleOrderLE_conj_succ {K : Type*} [Field K] {ℓ : ℕ} {ζ : Kˣ}
+    {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (b : Fin ℓ) : TPoleOrderLE (conj b.succ) 1 := by
+  rw [hconjS b]
+  exact (tPoleOrderLE_of_jSimplePole J hJ).qTwist _
+
+private theorem tPoleOrderLE_conj {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+    {ζ : Kˣ} {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (i : Fin (ℓ + 1)) :
+    TPoleOrderLE (conj i) (conjPoleBound ℓ i) := by
+  rcases Fin.eq_zero_or_eq_succ i with rfl | ⟨b, rfl⟩
+  · rw [conjPoleBound_zero]
+    exact tPoleOrderLE_conj_zero hconj0 hJ
+  · rw [conjPoleBound_succ]
+    exact tPoleOrderLE_conj_succ hconjS hJ b
+
+private theorem tPoleOrderLE_coeff_X_sub_C {K : Type*} [Field K] {a : LaurentSeries K}
+    {n : ℕ} (ha : TPoleOrderLE a n) (k : ℕ) :
+    TPoleOrderLE ((Polynomial.X - Polynomial.C a).coeff k) n := by
+  match k with
+  | 0 =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X_zero, Polynomial.coeff_C_zero,
+      zero_sub]
+    exact ha.neg
+  | 1 =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X_one, Polynomial.coeff_C,
+      ite_eq_right (one_ne_zero), sub_zero]
+    exact tPoleOrderLE_one.mono (Nat.zero_le _)
+  | (k + 2) =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X, Polynomial.coeff_C]
+    rw [ite_eq_right (by omega), ite_eq_right (by omega), sub_zero]
+    exact tPoleOrderLE_zero _
+
+private theorem tPoleOrderLE_coeff_mul {K : Type*} [Field K]
+    {p q : Polynomial (LaurentSeries K)} {m n : ℕ}
+    (hp : ∀ k, TPoleOrderLE (p.coeff k) m) (hq : ∀ k, TPoleOrderLE (q.coeff k) n) (k : ℕ) :
+    TPoleOrderLE ((p * q).coeff k) (m + n) := by
+  rw [Polynomial.coeff_mul]
+  intro a ha
+  rw [HahnSeries.coeff_sum]
+  exact Finset.sum_eq_zero fun ij _ => (hp ij.1).mul (hq ij.2) a ha
+
+private theorem tPoleOrderLE_coeff_prod {K : Type*} [Field K] {ι : Type*} (s : Finset ι)
+    (p : ι → Polynomial (LaurentSeries K)) (n : ι → ℕ)
+    (hp : ∀ i ∈ s, ∀ k, TPoleOrderLE ((p i).coeff k) (n i)) :
+    ∀ k, TPoleOrderLE ((∏ i ∈ s, p i).coeff k) (∑ i ∈ s, n i) := by
+  induction s using Finset.cons_induction with
+  | empty =>
+    intro k
+    simp only [Finset.prod_empty, Finset.sum_empty]
+    rcases Nat.eq_zero_or_pos k with rfl | hk
+    · simpa using tPoleOrderLE_one
+    · rw [Polynomial.coeff_one, ite_eq_right (by omega)]
+      exact tPoleOrderLE_zero 0
+  | cons a s ha ih =>
+    intro k
+    rw [Finset.prod_cons, Finset.sum_cons]
+    exact tPoleOrderLE_coeff_mul (hp a (Finset.mem_cons_self a s))
+      (ih fun i hi k => hp i (Finset.mem_cons_of_mem hi) k) k
+
+private theorem phiProd_def {K : Type*} [Field K] (ℓ : ℕ)
+    (conj : Fin (ℓ + 1) → LaurentSeries K) :
+    phiProd ℓ conj = ∏ i : Fin (ℓ + 1), (Polynomial.X - Polynomial.C (conj i)) := rfl
+
+private theorem tPoleOrderLE_phiProd_coeff {K : Type*} [Field K] (ℓ : ℕ)
+    [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (J : LaurentSeries K)
+    (conj : Fin (ℓ + 1) → LaurentSeries K) (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (k : ℕ) :
+    TPoleOrderLE ((phiProd ℓ conj).coeff k) (ℓ * ℓ + ℓ) := by
+  rw [phiProd_def, ← sum_conjPoleBound ℓ]
+  exact tPoleOrderLE_coeff_prod Finset.univ _ (conjPoleBound ℓ)
+    (fun i _ k => tPoleOrderLE_coeff_X_sub_C (tPoleOrderLE_conj hconj0 hconjS hJ i) k) k
+
+theorem coeffEmb_qExpand_injective {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] :
+    Function.Injective (fun f : LaurentSeries ℚ => coeffEmb K (qExpand ℚ ℓ f)) :=
+  (coeffEmb_injective K).comp (qExpand_injective (R := ℚ) ℓ)
+
+theorem PhiGenDescends.c_top {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) : c (ℓ + 1) = 1 := by
+  refine coeffEmb_qExpand_injective (K := K) (ℓ := ℓ) ?_
+  have h1 : (phiProd ℓ (conj ℓ ζ)).coeff (ℓ + 1) = 1 := by
+    have h := (phiProd_monic ℓ (conj ℓ ζ)).coeff_natDegree
+    rwa [phiProd_natDegree ℓ (conj ℓ ζ)] at h
+  simp only [← hc (ℓ + 1), h1, map_one]
+
+theorem PhiGenDescends.c_eq_zero {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) {k : ℕ} (hk : ℓ + 1 < k) : c k = 0 := by
+  refine coeffEmb_qExpand_injective (K := K) (ℓ := ℓ) ?_
+  have h1 : (phiProd ℓ (conj ℓ ζ)).coeff k = 0 :=
+    Polynomial.coeff_eq_zero_of_natDegree_lt (by rw [phiProd_natDegree]; exact hk)
+  simp only [← hc k, h1, map_zero]
+
+theorem PhiGenDescends.poleOrderLE {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) (k : ℕ) : PoleOrderLE (c k) (ℓ + 1) := by
+  have hW3 : TPoleOrderLE ((phiProd ℓ (conj ℓ ζ)).coeff k) (ℓ * ℓ + ℓ) :=
+    tPoleOrderLE_phiProd_coeff ℓ ζ (coeffEmb K jq) (conj ℓ ζ) (conj_zero ℓ ζ) (conj_succ ℓ ζ)
+      jSimplePole_jqK k
+  rw [hc k, tPoleOrderLE_coeffEmb_iff] at hW3
+  rw [← tPoleOrderLE_iff_poleOrderLE]
+  exact tPoleOrderLE_of_qExpand (hW3.mono (le_of_eq (by ring)))
+
+private theorem PhiGenDescends.sum_mul_jqN_pow_eq_zero {K : Type*} [Field K] [Algebra ℚ K]
+    {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) :
+    ∑ k ∈ Finset.range (ℓ + 2), c k * (jqN ℓ) ^ k = 0 := by
+  set F : LaurentSeries ℚ →+* LaurentSeries K := (coeffEmb K).comp (qExpand ℚ ℓ) with hF
+  have hFapp : ∀ f : LaurentSeries ℚ, F f = coeffEmb K (qExpand ℚ ℓ f) := fun f => rfl
+  have hFinj : Function.Injective F := coeffEmb_qExpand_injective
+  have hconj0 : conj ℓ ζ (0 : Fin (ℓ + 1)) = F (jqN ℓ) := by
+    change conj ℓ ζ 0 = coeffMap (algebraMap ℚ K) (qExpand ℚ ℓ (jqN ℓ))
+    rw [conj_zero, jqN, qExpand_qExpand, coeffMap_qExpand]
+    rfl
+  have hterm : ∀ k ∈ Finset.range (ℓ + 2),
+      F (c k * (jqN ℓ) ^ k)
+        = (phiProd ℓ (conj ℓ ζ)).coeff k * (conj ℓ ζ 0) ^ k := by
+    intro k _
+    rw [map_mul, map_pow, ← hconj0, hFapp, hc k]
+  refine hFinj ?_
+  rw [map_zero, map_sum, Finset.sum_congr rfl hterm]
+  rw [← Polynomial.eval_eq_sum_range' (n := ℓ + 2) (by rw [phiProd_natDegree]; omega)]
+  exact phiProd_eval_conj ℓ _ 0
+
+theorem evalAtJ_eq_aeval_map (Q : Polynomial ℤ) :
+    evalAtJ Q = Polynomial.aeval jq (Q.map (Int.castRingHom ℚ)) := by
+  have hcomp : (algebraMap ℚ (LaurentSeries ℚ)).comp (Int.castRingHom ℚ)
+      = algebraMap ℤ (LaurentSeries ℚ) := Subsingleton.elim _ _
+  rw [Polynomial.aeval_def, Polynomial.eval₂_map, hcomp]
+  rfl
+
+private theorem aeval_jq_eq_zero {p : Polynomial ℚ} (hp : Polynomial.aeval jq p = 0) :
+    p = 0 := by
+  by_contra hp0
+  set n := p.natDegree with hn
+  have hcoeff : (Polynomial.aeval jq p).coeff (-(n : ℤ)) = p.coeff n := by
+    rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+      Finset.sum_eq_single n]
+    · rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_self,
+        mul_one]
+    · intro i hi hin
+      have hilt : i < n := lt_of_le_of_ne (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hin
+      rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_of_lt,
+        mul_zero]
+      omega
+    · intro hn'
+      exact absurd (Finset.self_mem_range_succ n) hn'
+  rw [hp] at hcoeff
+  simp only [HahnSeries.coeff_zero] at hcoeff
+  exact hp0 (Polynomial.leadingCoeff_eq_zero.mp hcoeff.symm)
+
+theorem evalAtJ_injective : Function.Injective evalAtJ := by
+  intro P Q hPQ
+  refine Polynomial.map_injective (Int.castRingHom ℚ) Int.cast_injective ?_
+  rw [evalAtJ_eq_aeval_map, evalAtJ_eq_aeval_map] at hPQ
+  have h0 : Polynomial.aeval jq
+      (P.map (Int.castRingHom ℚ) - Q.map (Int.castRingHom ℚ)) = 0 := by
+    rw [map_sub, hPQ, sub_self]
+  exact sub_eq_zero.mp (aeval_jq_eq_zero h0)
+
+end PhiGen
+end ModularCurve
+
+end
+
+open _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_PhiGen_PhiGenDescends_sum_mul_jqN_pow_eq_zero.ModularCurve
+  _root_.ModularCurve.PhiGen
+  _root_.P2MW.S_ModularCurve_PhiGen_PhiGenDescends_sum_mul_jqN_pow_eq_zero.ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ}
+    {c : ℕ → LaurentSeries ℚ} (hc : PhiGenDescends ℓ ζ c) :
+    ∑ k ∈ Finset.range (ℓ + 2), c k * (jqN ℓ) ^ k = 0 :=
+  ModularCurve.PhiGen.PhiGenDescends.sum_mul_jqN_pow_eq_zero hc
+
+end S_ModularCurve_PhiGen_PhiGenDescends_sum_mul_jqN_pow_eq_zero
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_PhiGenDescends_sum_mul_jqN_pow_eq_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.PhiGenDescends.sum_mul_jqN_pow_eq_zero {K : Type*} [Field K]
+    [Algebra ℚ K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) :
+    ∑ k ∈ Finset.range (ℓ + 2), c k * (jqN ℓ) ^ k = 0 :=
+  solution hc
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_aeval_jq_intCoeffs_descent.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_aeval_jq_intCoeffs_descent.lean
new file mode 100644
index 0000000000..bdfbe58096
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_aeval_jq_intCoeffs_descent.lean
@@ -0,0 +1,380 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.aeval_jq_intCoeffs_descent
+(20bc4d07-b455-5870-b4a2-a361286e6d87) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 14f64e6b-3442-5798-ab13-6cb394637d5a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import Mathlib.Algebra.BigOperators.Fin
+import Mathlib.Tactic.Linarith
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality descent for polynomials in j
+
+Theorem statement: `ModularCurve.PhiGen.aeval_jq_intCoeffs_descent`
+(`20bc4d07-b455-5870-b4a2-a361286e6d87`), by Claude, 2026-09-05.
+
+Proof: submission `14f64e6b-3442-5798-ab13-6cb394637d5a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $P \in \mathbb{Q}[X]$ and let `jq` denote the Laurent series over $\mathbb{Q}$ given by $q^{-1}$
+times the image under $\mathbb{Z} \to \mathbb{Q}$ of the integral power series `jNum`; that is, `jq`
+is the product of the Hahn series `HahnSeries.single (-1) 1` with the Laurent series attached to
+`jNumQ`. Suppose that `IntCoeffs` holds for the evaluation of $P$ at `jq` inside the
+$\mathbb{Q}$-algebra of Laurent series, i.e. for every integer $m$ the coefficient of $q^m$ in
+$P(\mathrm{jq})$ lies in the image of $\mathbb{Z} \to \mathbb{Q}$: there is $z \in \mathbb{Z}$ with
+that coefficient equal to $(z : \mathbb{Q})$. Then for every natural number $k$ there exists $z \in
+\mathbb{Z}$ with $P.\mathrm{coeff}\ k = (z : \mathbb{Q})$, i.e. every coefficient of $P$ is a
+rational integer. The conclusion is stated coefficientwise for a single but arbitrary index $k$,
+rather than as membership of $P$ in $\mathbb{Z}[X]$.
+
+This is the standard integrality descent for the $q$-expansion principle applied to the
+$j$-invariant: since $q\,\mathrm{jq}$ is an integral power series with constant term $1$, the
+passage from $P$ to the $q$-expansion of $P(j)$ is unitriangular with respect to the degree
+filtration, so integrality of the expansion forces integrality of the coefficients. It is used in
+the construction of the integral modular polynomial data for $\Phi_\ell$, being cited by
+[`ModularCurve.PhiGen.exists_modularPolynomialData_coeff_eq`]
+(thm.html#ModularCurve.PhiGen.exists_modularPolynomialData_coeff_eq)
+and by [`ModularCurve.kroneckerPairIntegral`](thm.html#ModularCurve.kroneckerPairIntegral).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_aeval_jq_intCoeffs_descent.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_aeval_jq_intCoeffs_descent
+
+noncomputable section
+
+open Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd \
+  algebraMap_apply_eq_single jNum jNumQ jq ofPowerSeries_coeff_of_neg jq_pow coeff_jq_pow_self \
+  coeff_jq_pow_of_lt qTwist qTwist_coeff"
+p2m_open "ModularCurve"
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj phiProd TPoleOrderLE JSimplePole IntCoeffs"
+p2m_open "ModularCurve.PhiGen"
+
+namespace TPoleOrderLE
+
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.mono {K : Type*} [Field K]
+    {f : LaurentSeries K} {m n : ℕ}
+    (hf : TPoleOrderLE f m) (hmn : m ≤ n) : TPoleOrderLE f n :=
+  fun k hk => hf k (by omega)
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.mono"
+@[scoped simp]
+theorem tPoleOrderLE_zero {K : Type*} [Field K] (n : ℕ) :
+    TPoleOrderLE (0 : LaurentSeries K) n :=
+  fun _ _ => rfl
+
+theorem tPoleOrderLE_one {K : Type*} [Field K] : TPoleOrderLE (1 : LaurentSeries K) 0 := by
+  intro m hm
+  rw [HahnSeries.coeff_one, ite_eq_right (by omega)]
+
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.neg {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) : TPoleOrderLE (-f) n := by
+  intro m hm
+  rw [HahnSeries.coeff_neg, hf m hm, neg_zero]
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.neg"
+theorem TPoleOrderLE.add {K : Type*} [Field K] {f g : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) (hg : TPoleOrderLE g n) : TPoleOrderLE (f + g) n := by
+  intro m hm
+  rw [HahnSeries.coeff_add, hf m hm, hg m hm, add_zero]
+
+namespace TPoleOrderLE
+
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.mul {K : Type*} [Field K]
+    {f g : LaurentSeries K} {m n : ℕ}
+    (hf : TPoleOrderLE f m) (hg : TPoleOrderLE g n) : TPoleOrderLE (f * g) (m + n) := by
+  intro k hk
+  rw [HahnSeries.coeff_mul]
+  refine Finset.sum_eq_zero fun ij hij => ?_
+  obtain ⟨-, -, hsum⟩ := Finset.mem_antidiagonal.mp hij
+  by_cases hi : ij.1 < -(m : ℤ)
+  · rw [hf ij.1 hi, zero_mul]
+  · refine mul_eq_zero_of_right _ (hg ij.2 ?_)
+    push_cast at hk
+    omega
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.mul"
+namespace TPoleOrderLE
+
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.qTwist {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) (u : Kˣ) : TPoleOrderLE (ModularCurve.qTwist u f) n := by
+  intro m hm
+  rw [qTwist_coeff, hf m hm, mul_zero]
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.qTwist"
+namespace TPoleOrderLE
+
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.qExpand {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) (N : ℕ) [NeZero N] :
+    TPoleOrderLE (ModularCurve.qExpand K N f) (N * n) := by
+  intro m hm
+  by_cases hdvd : (N : ℤ) ∣ m
+  · obtain ⟨c, rfl⟩ := hdvd
+    rw [qExpand_coeff_mul]
+    refine hf c ?_
+    have hN : 0 < (N : ℤ) := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+    push_cast at hm
+    nlinarith
+  · exact qExpand_coeff_of_not_dvd N f hdvd
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.qExpand"
+
+theorem tPoleOrderLE_of_jSimplePole {K : Type*} [Field K] (J : LaurentSeries K)
+    (hJ : JSimplePole J) : TPoleOrderLE J 1 := by
+  intro m hm
+  exact hJ m (by push_cast at hm; omega)
+
+private def conjPoleBound (ℓ : ℕ) : Fin (ℓ + 1) → ℕ :=
+  fun i => if i = 0 then ℓ * ℓ else 1
+
+@[scoped simp]
+private theorem conjPoleBound_zero (ℓ : ℕ) : conjPoleBound ℓ 0 = ℓ * ℓ := ite_eq_left rfl
+
+@[scoped simp]
+private theorem conjPoleBound_succ (ℓ : ℕ) (b : Fin ℓ) : conjPoleBound ℓ b.succ = 1 :=
+  ite_eq_right (Fin.succ_ne_zero b)
+
+private theorem sum_conjPoleBound (ℓ : ℕ) :
+    ∑ i : Fin (ℓ + 1), conjPoleBound ℓ i = ℓ * ℓ + ℓ := by
+  rw [Fin.sum_univ_succ, conjPoleBound_zero]
+  congr 1
+  simp only [conjPoleBound_succ]
+  simp
+
+theorem tPoleOrderLE_conj_zero {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+    {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J) (hJ : JSimplePole J) :
+    TPoleOrderLE (conj 0) (ℓ * ℓ) := by
+  rw [hconj0]
+  have h := (tPoleOrderLE_of_jSimplePole J hJ).qExpand (ℓ * ℓ)
+  simpa using h
+
+theorem tPoleOrderLE_conj_succ {K : Type*} [Field K] {ℓ : ℕ} {ζ : Kˣ}
+    {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (b : Fin ℓ) : TPoleOrderLE (conj b.succ) 1 := by
+  rw [hconjS b]
+  exact (tPoleOrderLE_of_jSimplePole J hJ).qTwist _
+
+private theorem tPoleOrderLE_conj {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+    {ζ : Kˣ} {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (i : Fin (ℓ + 1)) :
+    TPoleOrderLE (conj i) (conjPoleBound ℓ i) := by
+  rcases Fin.eq_zero_or_eq_succ i with rfl | ⟨b, rfl⟩
+  · rw [conjPoleBound_zero]
+    exact tPoleOrderLE_conj_zero hconj0 hJ
+  · rw [conjPoleBound_succ]
+    exact tPoleOrderLE_conj_succ hconjS hJ b
+
+theorem tPoleOrderLE_coeff_X_sub_C {K : Type*} [Field K] {a : LaurentSeries K} {n : ℕ}
+    (ha : TPoleOrderLE a n) (k : ℕ) :
+    TPoleOrderLE ((Polynomial.X - Polynomial.C a).coeff k) n := by
+  match k with
+  | 0 =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X_zero, Polynomial.coeff_C_zero,
+      zero_sub]
+    exact ha.neg
+  | 1 =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X_one, Polynomial.coeff_C,
+      ite_eq_right (one_ne_zero), sub_zero]
+    exact tPoleOrderLE_one.mono (Nat.zero_le _)
+  | (k + 2) =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X, Polynomial.coeff_C]
+    rw [ite_eq_right (by omega), ite_eq_right (by omega), sub_zero]
+    exact tPoleOrderLE_zero _
+
+theorem tPoleOrderLE_coeff_mul {K : Type*} [Field K] {p q : Polynomial (LaurentSeries K)}
+    {m n : ℕ} (hp : ∀ k, TPoleOrderLE (p.coeff k) m) (hq : ∀ k, TPoleOrderLE (q.coeff k) n)
+    (k : ℕ) : TPoleOrderLE ((p * q).coeff k) (m + n) := by
+  rw [Polynomial.coeff_mul]
+  intro a ha
+  rw [HahnSeries.coeff_sum]
+  exact Finset.sum_eq_zero fun ij _ => (hp ij.1).mul (hq ij.2) a ha
+
+theorem tPoleOrderLE_coeff_prod {K : Type*} [Field K] {ι : Type*} (s : Finset ι)
+    (p : ι → Polynomial (LaurentSeries K)) (n : ι → ℕ)
+    (hp : ∀ i ∈ s, ∀ k, TPoleOrderLE ((p i).coeff k) (n i)) :
+    ∀ k, TPoleOrderLE ((∏ i ∈ s, p i).coeff k) (∑ i ∈ s, n i) := by
+  induction s using Finset.cons_induction with
+  | empty =>
+    intro k
+    simp only [Finset.prod_empty, Finset.sum_empty]
+    rcases Nat.eq_zero_or_pos k with rfl | hk
+    · simpa using tPoleOrderLE_one
+    · rw [Polynomial.coeff_one, ite_eq_right (by omega)]
+      exact tPoleOrderLE_zero 0
+  | cons a s ha ih =>
+    intro k
+    rw [Finset.prod_cons, Finset.sum_cons]
+    exact tPoleOrderLE_coeff_mul (hp a (Finset.mem_cons_self a s))
+      (ih fun i hi k => hp i (Finset.mem_cons_of_mem hi) k) k
+
+private theorem phiProd_def {K : Type*} [Field K] (ℓ : ℕ)
+    (conj : Fin (ℓ + 1) → LaurentSeries K) :
+    phiProd ℓ conj = ∏ i : Fin (ℓ + 1), (Polynomial.X - Polynomial.C (conj i)) := rfl
+
+theorem tPoleOrderLE_phiProd_coeff {K : Type*} [Field K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)]
+    (ζ : Kˣ) (J : LaurentSeries K) (conj : Fin (ℓ + 1) → LaurentSeries K)
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (k : ℕ) :
+    TPoleOrderLE ((phiProd ℓ conj).coeff k) (ℓ * ℓ + ℓ) := by
+  rw [phiProd_def, ← sum_conjPoleBound ℓ]
+  exact tPoleOrderLE_coeff_prod Finset.univ _ (conjPoleBound ℓ)
+    (fun i _ k => tPoleOrderLE_coeff_X_sub_C (tPoleOrderLE_conj hconj0 hconjS hJ i) k) k
+
+namespace IntCoeffs
+private theorem _root_.ModularCurve.PhiGen.IntCoeffs.sub {f g : LaurentSeries ℚ} (hf : IntCoeffs f)
+    (hg : IntCoeffs g) :
+    IntCoeffs (f - g) := by
+  intro m
+  obtain ⟨a, ha⟩ := hf m
+  obtain ⟨b, hb⟩ := hg m
+  exact ⟨a - b, by rw [HahnSeries.coeff_sub, ha, hb]; push_cast; ring⟩
+
+end IntCoeffs
+p2m_export "ModularCurve.PhiGen" "IntCoeffs.sub"
+
+theorem intCoeffs_jq_pow (n : ℕ) : IntCoeffs (jq ^ n) := by
+  intro m
+  rw [jq_pow, HahnSeries.coeff_single_mul, one_mul]
+  by_cases hneg : (m - -(n : ℤ)) < 0
+  · exact ⟨0, by rw [ofPowerSeries_coeff_of_neg _ hneg, Int.cast_zero]⟩
+  · refine ⟨(PowerSeries.coeff (m - -(n : ℤ)).toNat (jNum ^ n) : ℤ), ?_⟩
+    have hcast : (m - -(n : ℤ)) = (((m - -(n : ℤ)).toNat : ℕ) : ℤ) :=
+      (Int.toNat_of_nonneg (not_lt.mp hneg)).symm
+    rw [hcast, HahnSeries.ofPowerSeries_apply_coeff]
+    change PowerSeries.coeff _ (jNumQ ^ n) = _
+    rw [jNumQ, ← map_pow, PowerSeries.coeff_map]
+    rfl
+
+theorem intCoeffs_jq : IntCoeffs jq := by
+  have h := intCoeffs_jq_pow 1
+  rwa [pow_one] at h
+
+theorem intCoeffs_algebraMap_int_mul_jq_pow (z : ℤ) (n : ℕ) :
+    IntCoeffs (algebraMap ℚ (LaurentSeries ℚ) ((z : ℚ)) * jq ^ n) := by
+  intro m
+  obtain ⟨a, ha⟩ := intCoeffs_jq_pow n m
+  refine ⟨z * a, ?_⟩
+  rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, ha]
+  push_cast
+  ring
+
+private theorem coeff_aeval_jq_neg (P : Polynomial ℚ) {m : ℕ} (hm : P.natDegree ≤ m) :
+    (Polynomial.aeval jq P).coeff (-(m : ℤ)) = P.coeff m := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+    Finset.sum_eq_single m]
+  · rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_self,
+      mul_one]
+  · intro i hi hin
+    have hilt : i < m :=
+      lt_of_le_of_ne (le_trans (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hm) hin
+    rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul,
+      coeff_jq_pow_of_lt (by omega), mul_zero]
+  · intro hm'
+    rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul,
+      Polynomial.coeff_eq_zero_of_natDegree_lt
+        (by simp only [Finset.mem_range, not_lt] at hm'; omega),
+      zero_mul]
+
+private theorem aeval_jq_intCoeffs_descent (P : Polynomial ℚ)
+    (hP : IntCoeffs (Polynomial.aeval jq P)) (k : ℕ) : ∃ z : ℤ, P.coeff k = (z : ℚ) := by
+  suffices H : ∀ d : ℕ, ∀ P : Polynomial ℚ, P.natDegree = d →
+      IntCoeffs (Polynomial.aeval jq P) → ∀ k : ℕ, ∃ z : ℤ, P.coeff k = (z : ℚ) by
+    exact H P.natDegree P rfl hP k
+  intro d
+  induction d using Nat.strong_induction_on with
+  | _ d ih =>
+  intro P hd hP k
+  obtain ⟨zd, hzd⟩ := hP (-(d : ℤ))
+  have hlead : P.coeff d = (zd : ℚ) := by
+    rw [← coeff_aeval_jq_neg P hd.le, hzd]
+  rcases lt_trichotomy k d with hk | rfl | hk
+  · set Q : Polynomial ℚ := P - Polynomial.C (P.coeff d) * Polynomial.X ^ d with hQ
+    have hQcoeff : Q.coeff k = P.coeff k := by
+      rw [hQ, Polynomial.coeff_sub, Polynomial.coeff_C_mul, Polynomial.coeff_X_pow,
+        ite_eq_right (by omega), mul_zero, sub_zero]
+    have hQdeg : Q.natDegree < d := by
+      rcases eq_or_ne Q 0 with hQ0 | hQ0
+      · rw [hQ0, Polynomial.natDegree_zero]; omega
+      refine lt_of_le_of_ne ?_ ?_
+      · refine le_trans (Polynomial.natDegree_sub_le _ _) ?_
+        rw [hd]
+        exact max_le le_rfl (Polynomial.natDegree_C_mul_X_pow_le _ _)
+      · intro hcon
+        apply hQ0
+        rw [← Polynomial.leadingCoeff_eq_zero, Polynomial.leadingCoeff, hcon, hQ,
+          Polynomial.coeff_sub, Polynomial.coeff_C_mul, Polynomial.coeff_X_pow, ite_eq_left rfl,
+          mul_one, sub_self]
+    have hQint : IntCoeffs (Polynomial.aeval jq Q) := by
+      rw [hQ, map_sub, map_mul, Polynomial.aeval_C, map_pow, Polynomial.aeval_X, hlead]
+      exact hP.sub (intCoeffs_algebraMap_int_mul_jq_pow zd d)
+    obtain ⟨z, hz⟩ := ih Q.natDegree hQdeg Q rfl hQint k
+    exact ⟨z, by rw [← hQcoeff, hz]⟩
+  · exact ⟨zd, hlead⟩
+  · exact ⟨0, by rw [Polynomial.coeff_eq_zero_of_natDegree_lt (by omega), Int.cast_zero]⟩
+
+end PhiGen
+end ModularCurve
+end
+
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_PhiGen_aeval_jq_intCoeffs_descent.ModularCurve
+  _root_.ModularCurve.PhiGen
+  _root_.P2MW.S_ModularCurve_PhiGen_aeval_jq_intCoeffs_descent.ModularCurve.PhiGen in
+theorem solution (P : Polynomial ℚ) (hP : IntCoeffs (Polynomial.aeval jq P)) (k : ℕ) :
+    ∃ z : ℤ, P.coeff k = (z : ℚ) :=
+  ModularCurve.PhiGen.aeval_jq_intCoeffs_descent P hP k
+
+end S_ModularCurve_PhiGen_aeval_jq_intCoeffs_descent
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_aeval_jq_intCoeffs_descent (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.aeval_jq_intCoeffs_descent (P : Polynomial ℚ)
+    (hP : IntCoeffs (Polynomial.aeval jq P)) (k : ℕ) :
+    ∃ z : ℤ, P.coeff k = (z : ℚ) :=
+  solution P hP k
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_conj_injective.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_conj_injective.lean
new file mode 100644
index 0000000000..4dc0089493
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_conj_injective.lean
@@ -0,0 +1,163 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.conj_injective
+(fa6cf53f-de6b-5acd-b40f-70795dc1b0ef) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e9e176a5-e66a-5873-871c-39c9128b1937
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+
+import Mathlib.Tactic.Linarith
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The ℓ+1 conjugate expansions of j are distinct
+
+Theorem statement: `ModularCurve.PhiGen.conj_injective` (`fa6cf53f-de6b-5acd-b40f-70795dc1b0ef`), by
+Claude, 2026-09-05.
+
+Proof: submission `e9e176a5-e66a-5873-871c-39c9128b1937`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field equipped with a $\mathbb{Q}$-algebra structure, let $\ell$ be a prime, and let
+$\zeta$ be a unit of $K$ whose underlying element is a primitive $\ell$-th root of unity. The
+assertion is that the family $\mathrm{conj}\ \ell\ \zeta : \mathrm{Fin}(\ell+1) \to
+\mathrm{LaurentSeries}\ K$ is injective. Here, for an index $i$, $\mathrm{conj}\ \ell\ \zeta\ i$ is
+obtained by applying the ring homomorphism `cosetSubst` $\zeta\ a\ b$, with $a = \mathrm{cosetA}\
+\ell\ i$ equal to $\ell$ for $i = 0$ and to $1$ otherwise, and $b = \mathrm{cosetB}\ \ell\ i$ equal
+to $0$ for $i = 0$ and to $i - 1$ otherwise, to the Laurent series `coeffEmb K jq`, the
+coefficientwise image under $\mathbb{Q} \to K$ of the rational Laurent series `jq` (the
+$q$-expansion of the modular invariant $j$). The homomorphism `cosetSubst` $\zeta\ a\ b$ is by
+definition the composite of `qTwist` $(\zeta^{ab})$ followed by `qExpand K` $(a \cdot a)$, so that
+the index $0$ contributes the expansion re-indexed by $\ell^2$ and the indices $b+1$, $0 \le b <
+\ell$, contribute the twists by $\zeta^{b}$. Thus the $\ell+1$ Laurent series so produced are
+pairwise distinct.
+
+These $\ell+1$ Laurent series are the $q$-expansions of the conjugates of $j$ under coset
+representatives for $\Gamma_0(\ell)$ in $\mathrm{SL}_2(\mathbb{Z})$, namely $j(q^{\ell^2})$ and the
+$j(\zeta^b q)$; their distinctness is what makes the associated degree-$(\ell+1)$ modular polynomial
+separable in the relevant sense. The result is used in the proofs that a $\Gamma_0$-invariant
+expansion lies in the modular function field, is integral over the ring generated by `jq`, and has
+the expected image under the Fricke involution.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_conj_injective.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_conj_injective
+
+noncomputable section
+
+open Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand_coeff_mul qExpand_coeff_of_not_dvd jq coeff_jq_neg_one \
+  qTwist_coeff cosetSubst coeffEmb coeffEmb_coeff"
+p2m_open "ModularCurve"
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "cosetA conj conj_zero conj_succ"
+p2m_open "ModularCurve.PhiGen"
+
+section CoeffEmbJq
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+private theorem coeff_coeffEmb_jq_neg_one : (coeffEmb K jq).coeff (-1 : ℤ) = 1 := by
+  rw [coeffEmb_coeff, coeff_jq_neg_one, map_one]
+
+end CoeffEmbJq
+
+theorem conj_zero_coeff_neg_one {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ)
+    [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) :
+    (conj ℓ ζ (0 : Fin (ℓ + 1))).coeff (-1 : ℤ) = 0 := by
+  rw [conj_zero]
+  refine qExpand_coeff_of_not_dvd _ _ ?_
+  intro h
+  have h1 : ((ℓ * ℓ : ℕ) : ℤ) ∣ 1 := dvd_neg.mp h
+  have h2 : (ℓ * ℓ : ℕ) ∣ 1 := by exact_mod_cast h1
+  have h3 : ℓ * ℓ = 1 := Nat.dvd_one.mp h2
+  have h4 : 2 ≤ ℓ := hℓ.out.two_le
+  nlinarith
+
+theorem conj_zero_coeff_neg_sq {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ)
+    [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) :
+    (conj ℓ ζ (0 : Fin (ℓ + 1))).coeff (-(ℓ * ℓ : ℕ) : ℤ) = 1 := by
+  rw [conj_zero, show (-(ℓ * ℓ : ℕ) : ℤ) = ((ℓ * ℓ : ℕ) : ℤ) * (-1 : ℤ) by ring,
+    qExpand_coeff_mul, coeff_coeffEmb_jq_neg_one]
+
+theorem conj_succ_coeff_neg_one {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ)
+    [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (b : Fin ℓ) :
+    (conj ℓ ζ b.succ).coeff (-1 : ℤ) = (((ζ ^ (b : ℕ))⁻¹ : Kˣ) : K) := by
+  rw [conj_succ, qTwist_coeff, coeff_coeffEmb_jq_neg_one, mul_one, zpow_neg_one]
+
+private theorem conj_injective {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ)
+    [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    Function.Injective (conj ℓ ζ (K := K)) := by
+  have hne : ∀ b : Fin ℓ, (conj ℓ ζ (0 : Fin (ℓ + 1))).coeff (-1 : ℤ) ≠
+      (conj ℓ ζ b.succ).coeff (-1 : ℤ) := by
+    intro b
+    rw [conj_zero_coeff_neg_one, conj_succ_coeff_neg_one]
+    exact fun h => Units.ne_zero _ h.symm
+  intro i j hij
+  induction i using Fin.cases with
+  | zero =>
+    induction j using Fin.cases with
+    | zero => rfl
+    | succ b => exact absurd (congrArg (fun f => HahnSeries.coeff f (-1 : ℤ)) hij) (hne b)
+  | succ b =>
+    induction j using Fin.cases with
+    | zero => exact absurd (congrArg (fun f => HahnSeries.coeff f (-1 : ℤ)) hij.symm) (hne b)
+    | succ b' =>
+      have hcoeff := congrArg (fun f => HahnSeries.coeff f (-1 : ℤ)) hij
+      simp only [conj_succ_coeff_neg_one] at hcoeff
+      have hu : (ζ ^ (b : ℕ))⁻¹ = (ζ ^ (b' : ℕ))⁻¹ := Units.ext hcoeff
+      have hpow : (ζ : K) ^ (b : ℕ) = (ζ : K) ^ (b' : ℕ) := by
+        have hv := congrArg Units.val (inv_injective hu)
+        push_cast at hv
+        exact hv
+      exact congrArg Fin.succ (Fin.ext (hζ.pow_inj b.isLt b'.isLt hpow))
+
+end PhiGen
+end ModularCurve
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_PhiGen_conj_injective.ModularCurve
+  _root_.ModularCurve.PhiGen _root_.P2MW.S_ModularCurve_PhiGen_conj_injective.ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    Function.Injective (conj ℓ ζ (K := K)) :=
+  ModularCurve.PhiGen.conj_injective ℓ ζ hζ
+
+end S_ModularCurve_PhiGen_conj_injective
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_conj_injective (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.conj_injective {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ)
+    [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    Function.Injective (conj ℓ ζ (K := K)) :=
+  solution ℓ ζ hζ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_evalAtJ_injective.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_evalAtJ_injective.lean
new file mode 100644
index 0000000000..f98404b4ac
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_evalAtJ_injective.lean
@@ -0,0 +1,403 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.evalAtJ_injective
+(4d325b73-db93-53aa-896c-9b9b539ab24a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 005db492-b20f-5881-915b-8717e9cea6a3
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_injective
+import Mathlib.Algebra.BigOperators.Fin
+import Mathlib.Algebra.Polynomial.Eval.Degree
+import Mathlib.Tactic.Linarith
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Injectivity of evaluation at j(q)
+
+Theorem statement: `ModularCurve.PhiGen.evalAtJ_injective` (`4d325b73-db93-53aa-896c-9b9b539ab24a`),
+by Claude, 2026-09-05.
+
+Proof: submission `005db492-b20f-5881-915b-8717e9cea6a3`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+The assertion concerns the ring homomorphism `evalAtJ` from the polynomial ring $\mathbb{Z}[X]$ to
+the field of formal Laurent series $\mathbb{Q}((q))$, defined as the $\mathbb{Z}$-algebra evaluation
+map sending a polynomial $P$ to $P(\mathtt{jq})$, where `jq` is the fixed Laurent series over
+$\mathbb{Q}$ playing the role of the $q$-expansion of the modular $j$-invariant, viewed as a ring
+homomorphism. The theorem takes no arguments and no hypotheses: it states that this map is injective
+as a function, i.e. that a polynomial with integer coefficients which vanishes after substituting
+the Laurent series `jq` for its variable is the zero polynomial. Equivalently, the element `jq` of
+$\mathbb{Q}((q))$ satisfies no nontrivial polynomial relation with integer coefficients; since
+$\mathbb{Q}$ is the fraction field of $\mathbb{Z}$, this amounts to the transcendence of `jq` over
+$\mathbb{Q}$ inside the Laurent series field.
+
+This is the basic transcendence statement underlying the use of $q$-expansions to pin down
+polynomial identities between modular functions: a relation among $q$-expansions can be read back as
+an identity of polynomials. It is used by the results on `ModularPolynomialData`, among them
+[`ModularCurve.ModularPolynomialData.eq_all`](thm.html#ModularCurve.ModularPolynomialData.eq_all),
+[`ModularCurve.ModularPolynomialData.eq_of_prime`]
+(thm.html#ModularCurve.ModularPolynomialData.eq_of_prime)
+and
+[`ModularCurve.ModularPolynomialData.isUnit_leadingCoeff_diag_of_not_isSquare`]
+(thm.html#ModularCurve.ModularPolynomialData.isUnit_leadingCoeff_diag_of_not_isSquare),
+where modular polynomials are characterised through their behaviour on $q$-expansions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_evalAtJ_injective.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_evalAtJ_injective
+
+noncomputable section
+
+open Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_qExpand algebraMap_apply_eq_single jq coeff_jq_pow_self coeff_jq_pow_of_lt \
+  coeff_jq_of_lt jqN evalAtJ qTwist qTwist_coeff PoleOrderLE coeffMap coeffEmb coeffEmb_coeff \
+  coeffMap_qExpand coeffEmb_injective"
+p2m_open "ModularCurve"
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd phiProd_monic phiProd_natDegree \
+  phiProd_eval_conj TPoleOrderLE tPoleOrderLE_iff_poleOrderLE JSimplePole PhiGenDescends"
+p2m_open "ModularCurve.PhiGen"
+
+section CoeffEmbJq
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+private theorem coeff_coeffEmb_jq_of_lt {k : ℤ} (hk : k < -1) : (coeffEmb K jq).coeff k = 0 := by
+  rw [coeffEmb_coeff, coeff_jq_of_lt hk, map_zero]
+
+end CoeffEmbJq
+
+theorem jSimplePole_jqK {K : Type*} [Field K] [Algebra ℚ K] : JSimplePole (coeffEmb K jq) :=
+  fun _ hm => coeff_coeffEmb_jq_of_lt K hm
+
+theorem tPoleOrderLE_coeffEmb_iff {K : Type*} [Field K] [Algebra ℚ K]
+    (f : LaurentSeries ℚ) (n : ℕ) :
+    TPoleOrderLE (coeffEmb K f) n ↔ TPoleOrderLE f n := by
+  constructor
+  · intro h m hm
+    have h0 := h m hm
+    rw [coeffEmb_coeff] at h0
+    exact FaithfulSMul.algebraMap_injective ℚ K (by rw [h0, map_zero])
+  · intro h m hm
+    rw [coeffEmb_coeff, h m hm, map_zero]
+
+theorem tPoleOrderLE_of_qExpand {K : Type*} [Field K] {f : LaurentSeries K} {N n : ℕ}
+    [NeZero N] (h : TPoleOrderLE (qExpand K N f) (N * n)) : TPoleOrderLE f n := by
+  intro m hm
+  rw [← qExpand_coeff_mul N f m]
+  refine h _ ?_
+  push_cast
+  have hN : 0 < (N : ℤ) := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  nlinarith
+
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.mono {K : Type*} [Field K]
+    {f : LaurentSeries K} {m n : ℕ}
+    (hf : TPoleOrderLE f m) (hmn : m ≤ n) : TPoleOrderLE f n :=
+  fun k hk => hf k (by omega)
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.mono"
+private theorem tPoleOrderLE_zero {K : Type*} [Field K] (n : ℕ) :
+    TPoleOrderLE (0 : LaurentSeries K) n :=
+  fun _ _ => rfl
+
+private theorem tPoleOrderLE_one {K : Type*} [Field K] :
+    TPoleOrderLE (1 : LaurentSeries K) 0 := by
+  intro m hm
+  rw [HahnSeries.coeff_one, ite_eq_right (by omega)]
+
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.neg {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) : TPoleOrderLE (-f) n := by
+  intro m hm
+  rw [HahnSeries.coeff_neg, hf m hm, neg_zero]
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.neg"
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.mul {K : Type*} [Field K]
+    {f g : LaurentSeries K} {m n : ℕ}
+    (hf : TPoleOrderLE f m) (hg : TPoleOrderLE g n) : TPoleOrderLE (f * g) (m + n) := by
+  intro k hk
+  rw [HahnSeries.coeff_mul]
+  refine Finset.sum_eq_zero fun ij hij => ?_
+  obtain ⟨-, -, hsum⟩ := Finset.mem_antidiagonal.mp hij
+  by_cases hi : ij.1 < -(m : ℤ)
+  · rw [hf ij.1 hi, zero_mul]
+  · refine mul_eq_zero_of_right _ (hg ij.2 ?_)
+    push_cast at hk
+    omega
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.mul"
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.qTwist {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) (u : Kˣ) : TPoleOrderLE (ModularCurve.qTwist u f) n := by
+  intro m hm
+  rw [qTwist_coeff, hf m hm, mul_zero]
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.qTwist"
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.qExpand {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) (N : ℕ) [NeZero N] :
+    TPoleOrderLE (ModularCurve.qExpand K N f) (N * n) := by
+  intro m hm
+  by_cases hdvd : (N : ℤ) ∣ m
+  · obtain ⟨c, rfl⟩ := hdvd
+    rw [qExpand_coeff_mul]
+    refine hf c ?_
+    have hN : 0 < (N : ℤ) := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+    push_cast at hm
+    nlinarith
+  · exact qExpand_coeff_of_not_dvd N f hdvd
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.qExpand"
+private theorem tPoleOrderLE_of_jSimplePole {K : Type*} [Field K] (J : LaurentSeries K)
+    (hJ : JSimplePole J) : TPoleOrderLE J 1 := by
+  intro m hm
+  exact hJ m (by push_cast at hm; omega)
+
+private def conjPoleBound (ℓ : ℕ) : Fin (ℓ + 1) → ℕ :=
+  fun i => if i = 0 then ℓ * ℓ else 1
+
+private theorem conjPoleBound_zero (ℓ : ℕ) : conjPoleBound ℓ 0 = ℓ * ℓ := ite_eq_left rfl
+
+private theorem conjPoleBound_succ (ℓ : ℕ) (b : Fin ℓ) : conjPoleBound ℓ b.succ = 1 :=
+  ite_eq_right (Fin.succ_ne_zero b)
+
+private theorem sum_conjPoleBound (ℓ : ℕ) :
+    ∑ i : Fin (ℓ + 1), conjPoleBound ℓ i = ℓ * ℓ + ℓ := by
+  rw [Fin.sum_univ_succ, conjPoleBound_zero]
+  congr 1
+  simp only [conjPoleBound_succ]
+  simp
+
+private theorem tPoleOrderLE_conj_zero {K : Type*} [Field K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {J : LaurentSeries K}
+    {conj : Fin (ℓ + 1) → LaurentSeries K} (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hJ : JSimplePole J) : TPoleOrderLE (conj 0) (ℓ * ℓ) := by
+  rw [hconj0]
+  have h := (tPoleOrderLE_of_jSimplePole J hJ).qExpand (ℓ * ℓ)
+  simpa using h
+
+private theorem tPoleOrderLE_conj_succ {K : Type*} [Field K] {ℓ : ℕ} {ζ : Kˣ}
+    {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (b : Fin ℓ) : TPoleOrderLE (conj b.succ) 1 := by
+  rw [hconjS b]
+  exact (tPoleOrderLE_of_jSimplePole J hJ).qTwist _
+
+private theorem tPoleOrderLE_conj {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+    {ζ : Kˣ} {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (i : Fin (ℓ + 1)) :
+    TPoleOrderLE (conj i) (conjPoleBound ℓ i) := by
+  rcases Fin.eq_zero_or_eq_succ i with rfl | ⟨b, rfl⟩
+  · rw [conjPoleBound_zero]
+    exact tPoleOrderLE_conj_zero hconj0 hJ
+  · rw [conjPoleBound_succ]
+    exact tPoleOrderLE_conj_succ hconjS hJ b
+
+private theorem tPoleOrderLE_coeff_X_sub_C {K : Type*} [Field K] {a : LaurentSeries K}
+    {n : ℕ} (ha : TPoleOrderLE a n) (k : ℕ) :
+    TPoleOrderLE ((Polynomial.X - Polynomial.C a).coeff k) n := by
+  match k with
+  | 0 =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X_zero, Polynomial.coeff_C_zero,
+      zero_sub]
+    exact ha.neg
+  | 1 =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X_one, Polynomial.coeff_C,
+      ite_eq_right (one_ne_zero), sub_zero]
+    exact tPoleOrderLE_one.mono (Nat.zero_le _)
+  | (k + 2) =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X, Polynomial.coeff_C]
+    rw [ite_eq_right (by omega), ite_eq_right (by omega), sub_zero]
+    exact tPoleOrderLE_zero _
+
+private theorem tPoleOrderLE_coeff_mul {K : Type*} [Field K]
+    {p q : Polynomial (LaurentSeries K)} {m n : ℕ}
+    (hp : ∀ k, TPoleOrderLE (p.coeff k) m) (hq : ∀ k, TPoleOrderLE (q.coeff k) n) (k : ℕ) :
+    TPoleOrderLE ((p * q).coeff k) (m + n) := by
+  rw [Polynomial.coeff_mul]
+  intro a ha
+  rw [HahnSeries.coeff_sum]
+  exact Finset.sum_eq_zero fun ij _ => (hp ij.1).mul (hq ij.2) a ha
+
+private theorem tPoleOrderLE_coeff_prod {K : Type*} [Field K] {ι : Type*} (s : Finset ι)
+    (p : ι → Polynomial (LaurentSeries K)) (n : ι → ℕ)
+    (hp : ∀ i ∈ s, ∀ k, TPoleOrderLE ((p i).coeff k) (n i)) :
+    ∀ k, TPoleOrderLE ((∏ i ∈ s, p i).coeff k) (∑ i ∈ s, n i) := by
+  induction s using Finset.cons_induction with
+  | empty =>
+    intro k
+    simp only [Finset.prod_empty, Finset.sum_empty]
+    rcases Nat.eq_zero_or_pos k with rfl | hk
+    · simpa using tPoleOrderLE_one
+    · rw [Polynomial.coeff_one, ite_eq_right (by omega)]
+      exact tPoleOrderLE_zero 0
+  | cons a s ha ih =>
+    intro k
+    rw [Finset.prod_cons, Finset.sum_cons]
+    exact tPoleOrderLE_coeff_mul (hp a (Finset.mem_cons_self a s))
+      (ih fun i hi k => hp i (Finset.mem_cons_of_mem hi) k) k
+
+private theorem phiProd_def {K : Type*} [Field K] (ℓ : ℕ)
+    (conj : Fin (ℓ + 1) → LaurentSeries K) :
+    phiProd ℓ conj = ∏ i : Fin (ℓ + 1), (Polynomial.X - Polynomial.C (conj i)) := rfl
+
+private theorem tPoleOrderLE_phiProd_coeff {K : Type*} [Field K] (ℓ : ℕ)
+    [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (J : LaurentSeries K)
+    (conj : Fin (ℓ + 1) → LaurentSeries K) (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (k : ℕ) :
+    TPoleOrderLE ((phiProd ℓ conj).coeff k) (ℓ * ℓ + ℓ) := by
+  rw [phiProd_def, ← sum_conjPoleBound ℓ]
+  exact tPoleOrderLE_coeff_prod Finset.univ _ (conjPoleBound ℓ)
+    (fun i _ k => tPoleOrderLE_coeff_X_sub_C (tPoleOrderLE_conj hconj0 hconjS hJ i) k) k
+
+theorem coeffEmb_qExpand_injective {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] :
+    Function.Injective (fun f : LaurentSeries ℚ => coeffEmb K (qExpand ℚ ℓ f)) :=
+  (coeffEmb_injective K).comp (qExpand_injective (R := ℚ) ℓ)
+
+theorem PhiGenDescends.c_top {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) : c (ℓ + 1) = 1 := by
+  refine coeffEmb_qExpand_injective (K := K) (ℓ := ℓ) ?_
+  have h1 : (phiProd ℓ (conj ℓ ζ)).coeff (ℓ + 1) = 1 := by
+    have h := (phiProd_monic ℓ (conj ℓ ζ)).coeff_natDegree
+    rwa [phiProd_natDegree ℓ (conj ℓ ζ)] at h
+  simp only [← hc (ℓ + 1), h1, map_one]
+
+theorem PhiGenDescends.c_eq_zero {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) {k : ℕ} (hk : ℓ + 1 < k) : c k = 0 := by
+  refine coeffEmb_qExpand_injective (K := K) (ℓ := ℓ) ?_
+  have h1 : (phiProd ℓ (conj ℓ ζ)).coeff k = 0 :=
+    Polynomial.coeff_eq_zero_of_natDegree_lt (by rw [phiProd_natDegree]; exact hk)
+  simp only [← hc k, h1, map_zero]
+
+theorem PhiGenDescends.poleOrderLE {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) (k : ℕ) : PoleOrderLE (c k) (ℓ + 1) := by
+  have hW3 : TPoleOrderLE ((phiProd ℓ (conj ℓ ζ)).coeff k) (ℓ * ℓ + ℓ) :=
+    tPoleOrderLE_phiProd_coeff ℓ ζ (coeffEmb K jq) (conj ℓ ζ) (conj_zero ℓ ζ) (conj_succ ℓ ζ)
+      jSimplePole_jqK k
+  rw [hc k, tPoleOrderLE_coeffEmb_iff] at hW3
+  rw [← tPoleOrderLE_iff_poleOrderLE]
+  exact tPoleOrderLE_of_qExpand (hW3.mono (le_of_eq (by ring)))
+
+theorem PhiGenDescends.sum_mul_jqN_pow_eq_zero {K : Type*} [Field K] [Algebra ℚ K]
+    {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) :
+    ∑ k ∈ Finset.range (ℓ + 2), c k * (jqN ℓ) ^ k = 0 := by
+  set F : LaurentSeries ℚ →+* LaurentSeries K := (coeffEmb K).comp (qExpand ℚ ℓ) with hF
+  have hFapp : ∀ f : LaurentSeries ℚ, F f = coeffEmb K (qExpand ℚ ℓ f) := fun f => rfl
+  have hFinj : Function.Injective F := coeffEmb_qExpand_injective
+  have hconj0 : conj ℓ ζ (0 : Fin (ℓ + 1)) = F (jqN ℓ) := by
+    change conj ℓ ζ 0 = coeffMap (algebraMap ℚ K) (qExpand ℚ ℓ (jqN ℓ))
+    rw [conj_zero, jqN, qExpand_qExpand, coeffMap_qExpand]
+    rfl
+  have hterm : ∀ k ∈ Finset.range (ℓ + 2),
+      F (c k * (jqN ℓ) ^ k)
+        = (phiProd ℓ (conj ℓ ζ)).coeff k * (conj ℓ ζ 0) ^ k := by
+    intro k _
+    rw [map_mul, map_pow, ← hconj0, hFapp, hc k]
+  refine hFinj ?_
+  rw [map_zero, map_sum, Finset.sum_congr rfl hterm]
+  rw [← Polynomial.eval_eq_sum_range' (n := ℓ + 2) (by rw [phiProd_natDegree]; omega)]
+  exact phiProd_eval_conj ℓ _ 0
+
+theorem evalAtJ_eq_aeval_map (Q : Polynomial ℤ) :
+    evalAtJ Q = Polynomial.aeval jq (Q.map (Int.castRingHom ℚ)) := by
+  have hcomp : (algebraMap ℚ (LaurentSeries ℚ)).comp (Int.castRingHom ℚ)
+      = algebraMap ℤ (LaurentSeries ℚ) := Subsingleton.elim _ _
+  rw [Polynomial.aeval_def, Polynomial.eval₂_map, hcomp]
+  rfl
+
+private theorem aeval_jq_eq_zero {p : Polynomial ℚ} (hp : Polynomial.aeval jq p = 0) :
+    p = 0 := by
+  by_contra hp0
+  set n := p.natDegree with hn
+  have hcoeff : (Polynomial.aeval jq p).coeff (-(n : ℤ)) = p.coeff n := by
+    rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+      Finset.sum_eq_single n]
+    · rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_self,
+        mul_one]
+    · intro i hi hin
+      have hilt : i < n := lt_of_le_of_ne (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hin
+      rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_of_lt,
+        mul_zero]
+      omega
+    · intro hn'
+      exact absurd (Finset.self_mem_range_succ n) hn'
+  rw [hp] at hcoeff
+  simp only [HahnSeries.coeff_zero] at hcoeff
+  exact hp0 (Polynomial.leadingCoeff_eq_zero.mp hcoeff.symm)
+
+private theorem evalAtJ_injective : Function.Injective evalAtJ := by
+  intro P Q hPQ
+  refine Polynomial.map_injective (Int.castRingHom ℚ) Int.cast_injective ?_
+  rw [evalAtJ_eq_aeval_map, evalAtJ_eq_aeval_map] at hPQ
+  have h0 : Polynomial.aeval jq
+      (P.map (Int.castRingHom ℚ) - Q.map (Int.castRingHom ℚ)) = 0 := by
+    rw [map_sub, hPQ, sub_self]
+  exact sub_eq_zero.mp (aeval_jq_eq_zero h0)
+
+end PhiGen
+end ModularCurve
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_PhiGen_evalAtJ_injective.ModularCurve
+  _root_.ModularCurve.PhiGen _root_.P2MW.S_ModularCurve_PhiGen_evalAtJ_injective.ModularCurve.PhiGen
+  in
+theorem solution : Function.Injective evalAtJ :=
+  ModularCurve.PhiGen.evalAtJ_injective
+
+end S_ModularCurve_PhiGen_evalAtJ_injective
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_evalAtJ_injective (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.evalAtJ_injective :
+    Function.Injective evalAtJ :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_evalSymm_of_coeff_evalAtJ_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_evalSymm_of_coeff_evalAtJ_eq.lean
new file mode 100644
index 0000000000..ca1c2c52b0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_evalSymm_of_coeff_evalAtJ_eq.lean
@@ -0,0 +1,205 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.evalSymm_of_coeff_evalAtJ_eq
+(b2c93b85-1361-55fd-a290-b3429226fa2f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a592ac79-051d-5abe-9c4d-f0214d50b34f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_transposeToAdjoin_monic_of_qExpansion
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_PhiGenDescends_poleOrderLE
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_evalSymm_of_splits
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_phiProd_conj_coeff_eq_zero_of_le
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_phiProd_conj_coeff_zero_lead
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_of_coeff_evalAtJ_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Evaluation symmetry of a modular polynomial packet with descended coefficients
+
+Theorem statement: `ModularCurve.PhiGen.evalSymm_of_coeff_evalAtJ_eq`
+(`b2c93b85-1361-55fd-a290-b3429226fa2f`), by Claude, 2026-09-05.
+
+Proof: submission `a592ac79-051d-5abe-9c4d-f0214d50b34f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field that is an algebra over $\mathbb{Q}$, let $\ell$ be a prime, and let $\zeta$ be a
+unit of $K$ whose underlying element is a primitive $\ell$-th root of unity. Let $c : \mathbb{N} \to
+\mathrm{LaurentSeries}\,\mathbb{Q}$ be a family of rational Laurent series satisfying
+`PhiGenDescends ℓ ζ c`, that is: for every $k$, the $k$-th coefficient of the monic polynomial
+$\prod_{i \in \mathrm{Fin}(\ell+1)} (X - \mathrm{conj}\,\ell\,\zeta\,i)$ over
+$\mathrm{LaurentSeries}\,K$ equals the image under `coeffEmb K` (coefficientwise application of
+$\mathbb{Q} \to K$) of $q \mapsto q^{\ell}$ substituted into $c\,k$, i.e. of `qExpand ℚ ℓ (c k)`.
+Let `data` be a `ModularPolynomialData ℓ`: a polynomial $\Phi \in (\mathbb{Z}[X])[Y]$ that is monic,
+of degree $\psi(\ell) = \sum_{d \mid \ell,\ d \text{ squarefree}} \ell/d$ in $Y$, and with $\Phi$
+vanishing when its inner coefficients are evaluated at the $q$-expansion of $j$ and $Y$ at `jqN ℓ`.
+Assume further that for every $k$ the coefficient $\Phi_k \in \mathbb{Z}[X]$ evaluated at the
+$q$-expansion of $j$ equals $c\,k$. Then `EvalSymm data.Φ` holds: for all rational Laurent series
+$x, y$, evaluating $\Phi$ with inner variable $x$ and outer variable $y$ gives the same result as
+with inner variable $y$ and outer variable $x$.
+
+This is the symmetry $\Phi_\ell(X,Y) = \Phi_\ell(Y,X)$ of the modular equation of prime level
+$\ell$, established for a packet of data whose coefficients are prescribed by a descended family of
+$q$-expansions. It is used in the construction of modular polynomials, being cited by
+[`ModularCurve.exists_modularPolynomialData_evalSymm`]
+(thm.html#ModularCurve.exists_modularPolynomialData_evalSymm),
+[`ModularCurve.exists_phiIrreducible_evalSymm`]
+(thm.html#ModularCurve.exists_phiIrreducible_evalSymm)
+and [`ModularCurve.modularPolynomialFamily`](thm.html#ModularCurve.modularPolynomialFamily).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_evalSymm_of_coeff_evalAtJ_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_evalSymm_of_coeff_evalAtJ_eq
+
+noncomputable section
+
+open Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul dedekindPsi evalAtJ ModularPolynomialData \
+  EvalSymm coeffEmb coeffEmb_coeff dedekindPsi_prime"
+p2m_open "ModularCurve"
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj phiProd PhiGenDescends phiProd_conj_coeff_zero_lead \
+  phiProd_conj_coeff_eq_zero_of_le splits_of_coeff_evalAtJ_eq evalSymm_of_splits"
+p2m_open "ModularCurve.PhiGen"
+
+section Seam
+
+variable {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ}
+variable {c : ℕ → LaurentSeries ℚ}
+
+namespace PhiGenDescends
+p2m_export "ModularCurve.PhiGen.PhiGenDescends" "poleOrderLE"
+end PhiGenDescends
+namespace PhiGenDescends
+p2m_open_scoped "ModularCurve.PhiGen.PhiGenDescends" in
+private theorem _root_.ModularCurve.PhiGen.PhiGenDescends.coeff_phiProd_coeff
+    (hc : PhiGenDescends ℓ ζ c) (k : ℕ) (m : ℤ) :
+    ((phiProd ℓ (conj ℓ ζ)).coeff k).coeff ((ℓ : ℤ) * m) = algebraMap ℚ K ((c k).coeff m) := by
+  rw [hc k, coeffEmb_coeff, qExpand_coeff_mul]
+
+end PhiGenDescends
+p2m_export "ModularCurve.PhiGen" "PhiGenDescends.coeff_phiProd_coeff"
+namespace PhiGenDescends
+p2m_open_scoped "ModularCurve.PhiGen.PhiGenDescends" in
+private theorem _root_.ModularCurve.PhiGen.PhiGenDescends.c_zero_coeff_lead (hc : PhiGenDescends ℓ ζ
+  c)
+    (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    (c 0).coeff (-((ℓ + 1 : ℕ) : ℤ)) = 1 := by
+  refine (algebraMap ℚ K).injective ?_
+  rw [← hc.coeff_phiProd_coeff 0 (-((ℓ + 1 : ℕ) : ℤ)), map_one]
+  have hidx : (ℓ : ℤ) * (-((ℓ + 1 : ℕ) : ℤ)) = -((ℓ * ℓ + ℓ : ℕ) : ℤ) := by push_cast; ring
+  rw [hidx]
+  exact phiProd_conj_coeff_zero_lead ℓ ζ hζ
+
+end PhiGenDescends
+p2m_export "ModularCurve.PhiGen" "PhiGenDescends.c_zero_coeff_lead"
+namespace PhiGenDescends
+p2m_open_scoped "ModularCurve.PhiGen.PhiGenDescends" in
+private theorem _root_.ModularCurve.PhiGen.PhiGenDescends.c_coeff_eq_zero_of_ne_zero (hc :
+  PhiGenDescends ℓ ζ c)
+    (k : ℕ) (hk : k ≠ 0) (m : ℕ) (hm : ℓ + 1 ≤ m) :
+    (c k).coeff (-(m : ℤ)) = 0 := by
+  refine (algebraMap ℚ K).injective ?_
+  rw [← hc.coeff_phiProd_coeff k (-(m : ℤ)), map_zero]
+  have hidx : (ℓ : ℤ) * (-(m : ℤ)) = -((ℓ * m : ℕ) : ℤ) := by push_cast; ring
+  rw [hidx]
+  exact phiProd_conj_coeff_eq_zero_of_le ℓ ζ k hk (ℓ * m) (by nlinarith [hℓ.out.two_le])
+
+end PhiGenDescends
+p2m_export "ModularCurve.PhiGen" "PhiGenDescends.c_coeff_eq_zero_of_ne_zero"
+namespace PhiGenDescends
+p2m_open_scoped "ModularCurve.PhiGen.PhiGenDescends" in
+private theorem _root_.ModularCurve.PhiGen.PhiGenDescends.c_zero_coeff_eq_zero_of_lt (hc :
+  PhiGenDescends ℓ ζ c)
+    (m : ℕ) (hm : ℓ + 1 < m) :
+    (c 0).coeff (-(m : ℤ)) = 0 :=
+  hc.poleOrderLE 0 (-(m : ℤ)) (by push_cast; omega)
+
+end PhiGenDescends
+p2m_export "ModularCurve.PhiGen" "PhiGenDescends.c_zero_coeff_eq_zero_of_lt"
+end Seam
+
+section Symmetry
+
+variable {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ}
+variable {c : ℕ → LaurentSeries ℚ}
+
+private theorem evalSymm_of_coeff_evalAtJ_eq (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (hc : PhiGenDescends ℓ ζ c) (data : ModularPolynomialData ℓ)
+    (hcoeff : ∀ k, evalAtJ (data.Φ.coeff k) = c k) :
+    EvalSymm data.Φ := by
+  have hsplit : data.Φ.map (((coeffEmb K).comp (qExpand ℚ ℓ)).comp evalAtJ) = phiProd ℓ (conj ℓ ζ)
+    :=
+    splits_of_coeff_evalAtJ_eq ζ hc data hcoeff
+  have h0top : (evalAtJ (data.Φ.coeff 0)).coeff (-((dedekindPsi ℓ : ℕ) : ℤ)) = 1 := by
+    rw [hcoeff 0, dedekindPsi_prime hℓ.out]
+    exact hc.c_zero_coeff_lead hζ
+  have h0le : ∀ m : ℕ, dedekindPsi ℓ < m →
+      (evalAtJ (data.Φ.coeff 0)).coeff (-(m : ℤ)) = 0 := by
+    intro m hm
+    rw [hcoeff 0]
+    exact hc.c_zero_coeff_eq_zero_of_lt m (by rwa [dedekindPsi_prime hℓ.out] at hm)
+  have hk : ∀ k, k ≠ 0 → ∀ m : ℕ, dedekindPsi ℓ ≤ m →
+      (evalAtJ (data.Φ.coeff k)).coeff (-(m : ℤ)) = 0 := by
+    intro k hk0 m hm
+    rw [hcoeff k]
+    exact hc.c_coeff_eq_zero_of_ne_zero k hk0 m (by rwa [dedekindPsi_prime hℓ.out] at hm)
+  obtain ⟨hTmonic, hTdeg⟩ := data.transposeToAdjoin_monic_of_qExpansion h0top h0le hk
+  exact evalSymm_of_splits ℓ ζ hζ data hsplit hTmonic hTdeg.le
+
+end Symmetry
+
+end PhiGen
+end ModularCurve
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_PhiGen_evalSymm_of_coeff_evalAtJ_eq.ModularCurve
+  _root_.ModularCurve.PhiGen
+  _root_.P2MW.S_ModularCurve_PhiGen_evalSymm_of_coeff_evalAtJ_eq.ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ}
+    {c : ℕ → LaurentSeries ℚ} (hζ : IsPrimitiveRoot (ζ : K) ℓ) (hc : PhiGenDescends ℓ ζ c)
+    (data : ModularPolynomialData ℓ) (hcoeff : ∀ k, evalAtJ (data.Φ.coeff k) = c k) :
+    EvalSymm data.Φ :=
+  ModularCurve.PhiGen.evalSymm_of_coeff_evalAtJ_eq hζ hc data hcoeff
+
+end S_ModularCurve_PhiGen_evalSymm_of_coeff_evalAtJ_eq
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_evalSymm_of_coeff_evalAtJ_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.evalSymm_of_coeff_evalAtJ_eq {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ} (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (hc : PhiGenDescends ℓ ζ c) (data : ModularPolynomialData ℓ)
+    (hcoeff : ∀ k, evalAtJ (data.Φ.coeff k) = c k) :
+    EvalSymm data.Φ :=
+  solution hζ hc data hcoeff
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_evalSymm_of_splits.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_evalSymm_of_splits.lean
new file mode 100644
index 0000000000..222a7ff422
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_evalSymm_of_splits.lean
@@ -0,0 +1,990 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.evalSymm_of_splits
+(bd35dbad-dce7-57a0-a3be-bfe56ea31d43) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2a1aa078-8c68-546b-bbcf-2d5d2e6282a0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_one_le_coeff_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime
+import Mathlib.Algebra.Polynomial.Roots
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Algebra
+import Mathlib.FieldTheory.Minpoly.Field
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.RingTheory.Polynomial.GaussLemma
+import Mathlib.RingTheory.Polynomial.RationalRoot
+import Mathlib.Tactic.Linarith
+import Mathlib.Tactic.LinearCombination
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Symmetry of Φ_ℓ from its splitting into conjugates
+
+Theorem statement: `ModularCurve.PhiGen.evalSymm_of_splits`
+(`bd35dbad-dce7-57a0-a3be-bfe56ea31d43`), by Claude, 2026-09-05.
+
+Proof: submission `2a1aa078-8c68-546b-bbcf-2d5d2e6282a0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field equipped with a $\mathbb{Q}$-algebra structure, let $\ell$ be a prime, and let
+$\zeta \in K^\times$ be such that $\zeta$ is a primitive $\ell$-th root of unity in $K$. Let `data`
+be a modular-polynomial packet of level $\ell$, that is, a polynomial $\Phi \in \mathbb{Z}[X][Y]$
+that is monic in $Y$, of degree $\psi(\ell) = \sum_{d \mid \ell,\ d \text{ squarefree}} \ell/d$, and
+satisfies $\Phi(j, j_{(\ell)}) = 0$ after substituting the $q$-expansion $jq$ of the modular
+invariant for $X$. Three hypotheses are assumed. First, applying to the coefficients of $\Phi$ the
+composite $X \mapsto jq$, then the exponent-scaling map `qExpand ℚ ℓ`, then the coefficient
+extension $\mathbb{Q} \to K$, yields the polynomial $\prod_{i \in \mathrm{Fin}(\ell+1)} \bigl(Y -
+\mathrm{conj}\,\ell\,\zeta\,i\bigr)$ over the Laurent series over $K$, where the $i$-th conjugate is
+obtained from $jq$ over $K$ by the twist `qTwist (ζ ^ (a * b))` followed by multiplication of
+exponents by $a^2$, with $(a,b) = (\ell, 0)$ for $i = 0$ and $(a,b) = (1, i-1)$ otherwise. Second,
+the transpose `swapBivar data.Φ`, mapped by $X \mapsto$ the generator $j$ of $\mathbb{Q}\langle
+jq\rangle$, is monic. Third, that transpose has degree at most $\psi(\ell)$. The conclusion is
+`EvalSymm data.Φ`: for all Laurent series $x, y$ over $\mathbb{Q}$, $\Phi(x,y) = \Phi(y,x)$.
+
+This is the classical symmetry $\Phi_N(X,Y) = \Phi_N(Y,X)$ of the modular polynomial, in the case of
+prime level, derived here from the splitting of $\Phi_\ell$ into the product over the $\ell+1$
+conjugates together with degree and monicity control on the transpose. It feeds the criterion
+[`ModularCurve.PhiGen.evalSymm_of_coeff_evalAtJ_eq`]
+(thm.html#ModularCurve.PhiGen.evalSymm_of_coeff_evalAtJ_eq),
+which reduces the symmetry to a comparison of coefficients after evaluation at the $q$-expansion of
+$j$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_evalSymm_of_splits.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_evalSymm_of_splits
+
+noncomputable section
+
+p2m_open "Polynomial IntermediateField IntermediateField.algebraAdjoinAdjoin"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_qExpand \
+  algebraMap_apply_eq_single jq coeff_jq_pow_self coeff_jq_pow_of_lt coeff_jq_neg_one \
+  coeff_jq_of_lt jqN dedekindPsi evalAtJ evalAtJ_X ModularPolynomialData jGen evalAtJGen \
+  algebraMap_comp_evalAtJGen ModularPolynomialData.toAdjoin qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qExpand evalAtJqN evalAtJqN_X evalAtJqN_def evalAtJ_def EvalSymm aeval_toRingHom_X \
+  PhiIrreducible adjoinJq jAdj evalAtJAdj swapInner swapBivar swapBivar_X swapBivar_C_X coeffMap \
+  coeffEmb coeffEmb_coeff one_le_coeff_jq coeffMap_qExpand coeffEmb_qExpand transcendental_jq \
+  dedekindPsi_prime"
+p2m_open "ModularCurve"
+
+section JqNLead
+
+variable (N : ℕ) [NeZero N]
+
+private theorem coeff_jqN_self : (jqN N).coeff (-(N : ℤ)) = 1 := by
+  have h : (-(N : ℤ)) = (N : ℤ) * (-1) := by ring
+  rw [jqN, h, qExpand_coeff_mul, coeff_jq_neg_one]
+
+private theorem coeff_jqN_of_lt {m : ℤ} (hm : m < -(N : ℤ)) : (jqN N).coeff m = 0 := by
+  rw [jqN]
+  by_cases hdvd : (N : ℤ) ∣ m
+  · obtain ⟨k, rfl⟩ := hdvd
+    rw [qExpand_coeff_mul]
+    refine coeff_jq_of_lt ?_
+    have hN : (0 : ℤ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+    nlinarith
+  · exact qExpand_coeff_of_not_dvd N jq hdvd
+
+end JqNLead
+
+private theorem evalAtJ_injective : Function.Injective evalAtJ := by
+  rw [injective_iff_map_eq_zero]
+  intro c hc
+  by_contra hc0
+  refine transcendental_jq ⟨c.map (Int.castRingHom ℚ), ?_, ?_⟩
+  · exact (Polynomial.map_ne_zero_iff (Int.cast_injective)).mpr hc0
+  · rw [Polynomial.aeval_def, Polynomial.eval₂_map, Subsingleton.elim
+      ((algebraMap ℚ (LaurentSeries ℚ)).comp (Int.castRingHom ℚ))
+      (algebraMap ℤ (LaurentSeries ℚ))]
+    exact hc
+
+theorem evalAtJGen_injective : Function.Injective evalAtJGen := by
+  intro a b hab
+  apply evalAtJ_injective
+  rw [← algebraMap_comp_evalAtJGen]
+  simp only [RingHom.comp_apply, hab]
+
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd phiProd_eval_conj"
+p2m_open "ModularCurve.PhiGen"
+
+section CoeffEmbJq
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+private theorem coeff_coeffEmb_jq_neg_one : (coeffEmb K jq).coeff (-1 : ℤ) = 1 := by
+  rw [coeffEmb_coeff, coeff_jq_neg_one, map_one]
+
+end CoeffEmbJq
+
+section Distinctness
+
+variable {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+private theorem conj_zero_coeff_neg_one :
+    (conj ℓ ζ (0 : Fin (ℓ + 1))).coeff (-1 : ℤ) = 0 := by
+  rw [conj_zero]
+  refine qExpand_coeff_of_not_dvd _ _ ?_
+  intro h
+  have h1 : ((ℓ * ℓ : ℕ) : ℤ) ∣ 1 := dvd_neg.mp h
+  have h2 : (ℓ * ℓ : ℕ) ∣ 1 := by exact_mod_cast h1
+  have h3 : ℓ * ℓ = 1 := Nat.dvd_one.mp h2
+  have h4 : 2 ≤ ℓ := hℓ.out.two_le
+  nlinarith
+
+private theorem conj_succ_coeff_neg_one (b : Fin ℓ) :
+    (conj ℓ ζ b.succ).coeff (-1 : ℤ) = (((ζ ^ (b : ℕ))⁻¹ : Kˣ) : K) := by
+  rw [conj_succ, qTwist_coeff, coeff_coeffEmb_jq_neg_one, mul_one, zpow_neg_one]
+
+private theorem conj_injective (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    Function.Injective (conj ℓ ζ (K := K)) := by
+  have hne : ∀ b : Fin ℓ, (conj ℓ ζ (0 : Fin (ℓ + 1))).coeff (-1 : ℤ) ≠
+      (conj ℓ ζ b.succ).coeff (-1 : ℤ) := by
+    intro b
+    rw [conj_zero_coeff_neg_one, conj_succ_coeff_neg_one]
+    exact fun h => Units.ne_zero _ h.symm
+  intro i j hij
+  induction i using Fin.cases with
+  | zero =>
+    induction j using Fin.cases with
+    | zero => rfl
+    | succ b => exact absurd (congrArg (fun f => HahnSeries.coeff f (-1 : ℤ)) hij) (hne b)
+  | succ b =>
+    induction j using Fin.cases with
+    | zero => exact absurd (congrArg (fun f => HahnSeries.coeff f (-1 : ℤ)) hij.symm) (hne b)
+    | succ b' =>
+      have hcoeff := congrArg (fun f => HahnSeries.coeff f (-1 : ℤ)) hij
+      simp only [conj_succ_coeff_neg_one] at hcoeff
+      have hu : (ζ ^ (b : ℕ))⁻¹ = (ζ ^ (b' : ℕ))⁻¹ := Units.ext hcoeff
+      have hpow : (ζ : K) ^ (b : ℕ) = (ζ : K) ^ (b' : ℕ) := by
+        have hv := congrArg Units.val (inv_injective hu)
+        push_cast at hv
+        exact hv
+      exact congrArg Fin.succ (Fin.ext (hζ.pow_inj b.isLt b'.isLt hpow))
+
+end Distinctness
+
+section ScalarEmbedding
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+private def ratC : ℚ →+* LaurentSeries K := (HahnSeries.C).comp (algebraMap ℚ K)
+
+private theorem ratC_apply (c : ℚ) : ratC K c = HahnSeries.single 0 (algebraMap ℚ K c) :=
+  rfl
+
+private theorem coeff_ratC_of_ne (c : ℚ) {k : ℤ} (hk : k ≠ 0) : (ratC K c).coeff k = 0 := by
+  rw [ratC_apply]
+  exact HahnSeries.coeff_single_of_ne hk
+
+private theorem coeffMap_jq : coeffMap (algebraMap ℚ K) jq = (coeffEmb K jq) := by
+  ext k
+  rfl
+
+end ScalarEmbedding
+
+section PoleOrder
+
+private theorem coeff_aeval_jq_of_lt (P : Polynomial ℚ) {m : ℤ}
+    (hm : m < -(P.natDegree : ℤ)) : (Polynomial.aeval jq P).coeff m = 0 := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum]
+  refine Finset.sum_eq_zero fun i hi => ?_
+  rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_of_lt,
+    mul_zero]
+  have : i ≤ P.natDegree := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)
+  omega
+
+private theorem coeff_aeval_jq_neg_natDegree (P : Polynomial ℚ) :
+    (Polynomial.aeval jq P).coeff (-(P.natDegree : ℤ)) = P.coeff P.natDegree := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+    Finset.sum_eq_single P.natDegree]
+  · rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_self,
+      mul_one]
+  · intro i hi hin
+    have hilt : i < P.natDegree :=
+      lt_of_le_of_ne (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hin
+    rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_of_lt
+      (by omega), mul_zero]
+  · intro hn'
+    exact absurd (Finset.self_mem_range_succ P.natDegree) hn'
+
+variable (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] {P : Polynomial ℚ}
+
+private theorem ne_zero_of_aeval_jq_eq_jqN (h : Polynomial.aeval jq P = jqN ℓ) : P ≠ 0 := by
+  rintro rfl
+  rw [map_zero] at h
+  have h1 := coeff_jqN_self ℓ
+  rw [← h, HahnSeries.coeff_zero] at h1
+  exact zero_ne_one h1
+
+private theorem natDegree_eq_of_aeval_jq_eq_jqN (h : Polynomial.aeval jq P = jqN ℓ) :
+    P.natDegree = ℓ := by
+  have hP0 : P ≠ 0 := ne_zero_of_aeval_jq_eq_jqN ℓ h
+  by_contra hne
+  rcases lt_or_gt_of_ne hne with hlt | hgt
+  · have h1 : (Polynomial.aeval jq P).coeff (-(ℓ : ℤ)) = 0 :=
+      coeff_aeval_jq_of_lt P (by omega)
+    rw [h, coeff_jqN_self] at h1
+    exact one_ne_zero h1
+  · have h1 := coeff_aeval_jq_neg_natDegree P
+    rw [h, coeff_jqN_of_lt ℓ (by omega)] at h1
+    exact hP0 (Polynomial.leadingCoeff_eq_zero.mp h1.symm)
+
+private theorem monic_of_aeval_jq_eq_jqN (h : Polynomial.aeval jq P = jqN ℓ) : P.Monic := by
+  have hd := natDegree_eq_of_aeval_jq_eq_jqN ℓ h
+  have h1 := coeff_aeval_jq_neg_natDegree P
+  rw [h, hd, coeff_jqN_self] at h1
+  change P.coeff P.natDegree = 1
+  rw [hd]
+  exact h1.symm
+
+end PoleOrder
+
+section Transfer
+
+variable {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+omit [Algebra ℚ K] hℓ in
+private theorem zeta_pow_eq_one (hζ : IsPrimitiveRoot (ζ : K) ℓ) : ζ ^ ℓ = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one])
+
+omit [Algebra ℚ K] hℓ in
+private theorem zeta_pow_zpow_eq_one (hζ : IsPrimitiveRoot (ζ : K) ℓ) (b : ℕ) :
+    (ζ ^ b) ^ ((ℓ : ℕ) : ℤ) = (1 : Kˣ) := by
+  rw [zpow_natCast, ← pow_mul, mul_comm, pow_mul, zeta_pow_eq_one ℓ ζ hζ, one_pow]
+
+variable {P : Polynomial ℚ}
+
+private theorem eval₂_ratC_jqK_of_aeval_jq_eq (h : Polynomial.aeval jq P = jqN ℓ) :
+    P.eval₂ (ratC K) (coeffEmb K jq) = qExpand K ℓ (coeffEmb K jq) := by
+  have h2 := congrArg (coeffMap (algebraMap ℚ K)) h
+  rw [Polynomial.aeval_def, Polynomial.hom_eval₂, jqN, coeffMap_qExpand, coeffMap_jq,
+    Subsingleton.elim ((coeffMap (algebraMap ℚ K)).comp (algebraMap ℚ (LaurentSeries ℚ)))
+      (ratC K)] at h2
+  exact h2
+
+private theorem eval₂_ratC_conj_succ_of_aeval_jq_eq (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (h : Polynomial.aeval jq P = jqN ℓ) (b : Fin ℓ) :
+    P.eval₂ (ratC K) (conj ℓ ζ b.succ) = qExpand K ℓ (coeffEmb K jq) := by
+  have h2 := congrArg (qTwist (ζ ^ (b : ℕ))) (eval₂_ratC_jqK_of_aeval_jq_eq ℓ h)
+  rw [Polynomial.hom_eval₂,
+    Subsingleton.elim ((qTwist (ζ ^ (b : ℕ))).comp (ratC K)) (ratC K),
+    qTwist_qExpand, zeta_pow_zpow_eq_one ℓ ζ hζ, qTwist_one_apply, ← conj_succ] at h2
+  exact h2
+
+end Transfer
+
+section Vieta
+
+variable {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+variable {P : Polynomial ℚ}
+
+private theorem sum_conj_succ_eq_ratC_of_aeval_jq_eq (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (h : Polynomial.aeval jq P = jqN ℓ) :
+    ∑ b : Fin ℓ, conj ℓ ζ b.succ = ratC K (-(P.coeff (ℓ - 1))) := by
+  have hPdeg : P.natDegree = ℓ := natDegree_eq_of_aeval_jq_eq_jqN ℓ h
+  have hPmonic : P.Monic := monic_of_aeval_jq_eq_jqN ℓ h
+  set A : Polynomial (LaurentSeries K) := P.map (ratC K) with hA
+  set B : Polynomial (LaurentSeries K) :=
+    ∏ b : Fin ℓ, (Polynomial.X - Polynomial.C (conj ℓ ζ b.succ)) with hB
+  have hAmonic : A.Monic := hPmonic.map _
+  have hAdeg : A.natDegree = ℓ := by rw [hA, hPmonic.natDegree_map, hPdeg]
+  have hBmonic : B.Monic :=
+    Polynomial.monic_prod_of_monic _ _ fun i _ => Polynomial.monic_X_sub_C _
+  have hBdeg : B.natDegree = ℓ := by
+    rw [hB, Polynomial.natDegree_prod_of_monic _ _ fun i _ => Polynomial.monic_X_sub_C _]
+    simp
+  have hinj : Function.Injective (fun b : Fin ℓ => conj ℓ ζ b.succ) := fun b b' hbb' =>
+    Fin.succ_injective ℓ (conj_injective ℓ ζ hζ hbb')
+  have key : A - B = Polynomial.C (qExpand K ℓ (coeffEmb K jq)) := by
+    refine Polynomial.eq_of_natDegree_lt_card_of_eval_eq _ _ hinj (fun b => ?_) ?_
+    · have hAev : A.eval (conj ℓ ζ b.succ) = qExpand K ℓ (coeffEmb K jq) := by
+        rw [hA, Polynomial.eval_map]
+        exact eval₂_ratC_conj_succ_of_aeval_jq_eq ℓ ζ hζ h b
+      have hBev : B.eval (conj ℓ ζ b.succ) = 0 := by
+        rw [hB, Polynomial.eval_prod]
+        exact Finset.prod_eq_zero (Finset.mem_univ b) (by simp)
+      simp only [Polynomial.eval_sub, Polynomial.eval_C, hAev, hBev, sub_zero]
+    · rw [Fintype.card_fin]
+      refine max_lt ?_ (by rw [Polynomial.natDegree_C]; exact hℓ.out.pos)
+      by_cases hAB : A = B
+      · rw [hAB, sub_self, Polynomial.natDegree_zero]
+        exact hℓ.out.pos
+      · refine lt_of_lt_of_eq
+          (Polynomial.natDegree_lt_natDegree (sub_ne_zero.mpr hAB) ?_) hAdeg
+        exact Polynomial.degree_sub_lt_left
+          (by rw [Polynomial.degree_eq_natDegree hAmonic.ne_zero,
+                Polynomial.degree_eq_natDegree hBmonic.ne_zero, hAdeg, hBdeg])
+          hAmonic.ne_zero (by rw [hAmonic.leadingCoeff, hBmonic.leadingCoeff])
+  have hcoeff := congrArg (fun p => Polynomial.coeff p (ℓ - 1)) key
+  have hℓ2 : 2 ≤ ℓ := hℓ.out.two_le
+  simp only [Polynomial.coeff_sub, Polynomial.coeff_C,
+    ite_eq_right (by omega : ¬(ℓ - 1 = 0))] at hcoeff
+  have hBcoeff : B.coeff (ℓ - 1) = -∑ b : Fin ℓ, conj ℓ ζ b.succ := by
+    have hv := Polynomial.prod_X_sub_C_coeff_card_pred (Finset.univ : Finset (Fin ℓ))
+      (fun b => conj ℓ ζ b.succ) (by simp [hℓ.out.pos])
+    simpa using hv
+  have hAcoeff : A.coeff (ℓ - 1) = ratC K (P.coeff (ℓ - 1)) := Polynomial.coeff_map _ _
+  rw [hAcoeff, hBcoeff, sub_neg_eq_add, add_comm] at hcoeff
+  rw [map_neg]
+  exact eq_neg_of_add_eq_zero_left hcoeff
+
+end Vieta
+
+section Refutation
+
+variable {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+private theorem coeff_sum_conj_succ_self (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    (∑ b : Fin ℓ, conj ℓ ζ b.succ).coeff ((ℓ : ℕ) : ℤ) =
+      (ℓ : K) * algebraMap ℚ K (jq.coeff ((ℓ : ℕ) : ℤ)) := by
+  rw [HahnSeries.coeff_sum]
+  have hterm : ∀ b : Fin ℓ, (conj ℓ ζ b.succ).coeff ((ℓ : ℕ) : ℤ) =
+      algebraMap ℚ K (jq.coeff ((ℓ : ℕ) : ℤ)) := by
+    intro b
+    rw [conj_succ, qTwist_coeff, zeta_pow_zpow_eq_one ℓ ζ hζ, Units.val_one, one_mul,
+      coeffEmb_coeff]
+  rw [Finset.sum_congr rfl fun b _ => hterm b, Finset.sum_const, Finset.card_univ,
+    Fintype.card_fin, nsmul_eq_mul]
+
+private theorem coeff_sum_conj_succ_ne_zero
+    (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    (∑ b : Fin ℓ, conj ℓ ζ b.succ).coeff ((ℓ : ℕ) : ℤ) ≠ 0 := by
+  rw [coeff_sum_conj_succ_self ℓ ζ hζ]
+  refine mul_ne_zero ?_ ?_
+  · rw [show ((ℓ : ℕ) : K) = algebraMap ℚ K ((ℓ : ℕ) : ℚ) from (map_natCast _ _).symm]
+    intro hc
+    exact (Nat.cast_ne_zero (R := ℚ)).mpr hℓ.out.ne_zero
+      ((algebraMap ℚ K).injective (by rw [hc, map_zero]))
+  · intro hc
+    have h0 : jq.coeff ((ℓ : ℕ) : ℤ) = 0 :=
+      (algebraMap ℚ K).injective (by rw [hc, map_zero])
+    have h1 := hpos ℓ
+    rw [h0] at h1
+    norm_num at h1
+
+theorem aeval_jq_ne_jqN_of_isPrimitiveRoot
+    (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (P : Polynomial ℚ) : Polynomial.aeval jq P ≠ jqN ℓ := by
+  intro h
+  have h1 := sum_conj_succ_eq_ratC_of_aeval_jq_eq ℓ ζ hζ h
+  have h2 := coeff_sum_conj_succ_ne_zero ℓ ζ hpos hζ
+  rw [h1] at h2
+  exact h2 (coeff_ratC_of_ne K _ (by exact_mod_cast hℓ.out.ne_zero))
+
+end Refutation
+
+section Headline
+
+variable (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)]
+
+theorem aeval_jq_ne_jqN (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (P : Polynomial ℚ) :
+    Polynomial.aeval jq P ≠ jqN ℓ := by
+  have : NeZero ((ℓ : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr hℓ.out.ne_zero⟩
+  have : IsCyclotomicExtension {ℓ} ℚ (CyclotomicField ℓ ℚ) :=
+    CyclotomicField.isCyclotomicExtension (n := ℓ) (K := ℚ)
+  obtain ⟨z, hz⟩ := IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField ℓ ℚ)
+    (Set.mem_singleton ℓ) hℓ.out.ne_zero
+  have hzu : IsUnit z := hz.isUnit hℓ.out.ne_zero
+  refine aeval_jq_ne_jqN_of_isPrimitiveRoot ℓ hzu.unit hpos ?_ P
+  rw [hzu.unit_spec]
+  exact hz
+
+theorem jqN_not_mem_adjoin_jq (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) :
+    jqN ℓ ∉ Algebra.adjoin ℚ {jq} := by
+  intro hmem
+  obtain ⟨P, hP⟩ := Algebra.adjoin_mem_exists_aeval _ _ hmem
+  exact aeval_jq_ne_jqN ℓ hpos P hP
+
+end Headline
+
+end PhiGen
+
+section FractionField
+
+private scoped instance instUFMAdjoinJq : UniqueFactorizationMonoid adjoinJq :=
+  transcendental_jq.uniqueFactorizationMonoid_adjoin
+
+private theorem algebraMap_comp_evalAtJAdj :
+    (algebraMap adjoinJq ℚ⟮jq⟯).comp evalAtJAdj = evalAtJGen := by
+  refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+  change algebraMap adjoinJq ℚ⟮jq⟯ (evalAtJAdj Polynomial.X) = evalAtJGen Polynomial.X
+  rw [show evalAtJAdj Polynomial.X = jAdj from Polynomial.eval₂_X _ _,
+    show evalAtJGen Polynomial.X = jGen from Polynomial.eval₂_X _ _]
+  exact Subtype.ext rfl
+
+namespace ModularPolynomialData
+p2m_export "ModularCurve.ModularPolynomialData" "toAdjoin toAdjoin_monic monic eval_eq_zero \
+  natDegree_eq Φ"
+p2m_open "ModularCurve.ModularPolynomialData"
+
+variable {N : ℕ} [NeZero N] (data : ModularPolynomialData N)
+
+private theorem _root_.ModularCurve.ModularPolynomialData.aeval_jqN_toAdjoin :
+    Polynomial.aeval (jqN N) data.toAdjoin = 0 := by
+  rw [Polynomial.aeval_def, toAdjoin, Polynomial.eval₂_map, algebraMap_comp_evalAtJGen]
+  exact data.eval_eq_zero
+
+p2m_export "ModularCurve.ModularPolynomialData" "aeval_jqN_toAdjoin"
+
+private theorem _root_.ModularCurve.ModularPolynomialData.minpoly_jqN_eq (hirr : PhiIrreducible
+  data) :
+    minpoly ℚ⟮jq⟯ (jqN N) = data.toAdjoin :=
+  (minpoly.eq_of_irreducible_of_monic hirr data.aeval_jqN_toAdjoin data.toAdjoin_monic).symm
+
+p2m_export "ModularCurve.ModularPolynomialData" "minpoly_jqN_eq"
+end ModularPolynomialData
+
+end FractionField
+
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd phiProd_eval_conj"
+p2m_open "ModularCurve.PhiGen"
+
+section Embed
+
+variable (K : Type*) [Field K] [Algebra ℚ K] (ℓ : ℕ) [NeZero ℓ]
+
+private def qEmbedT : LaurentSeries ℚ →+* LaurentSeries K :=
+  (qExpand K ℓ).comp (coeffMap (algebraMap ℚ K))
+
+private theorem qEmbedT_apply (x : LaurentSeries ℚ) :
+    qEmbedT K ℓ x = qExpand K ℓ (coeffMap (algebraMap ℚ K) x) := rfl
+
+private theorem qEmbedT_injective : Function.Injective (qEmbedT K ℓ) :=
+  (qEmbedT K ℓ).injective
+
+private theorem qEmbedT_jq : qEmbedT K ℓ jq = qExpand K ℓ (coeffEmb K jq) := by
+  rw [qEmbedT_apply, coeffMap_jq]
+
+private theorem qEmbedT_eq_coeffEmb_qExpand (x : LaurentSeries ℚ) :
+    qEmbedT K ℓ x = coeffEmb K (qExpand ℚ ℓ x) := by
+  rw [coeffEmb_qExpand]
+  rfl
+
+private theorem coeffEmb_comp_qExpand_comp_evalAtJ :
+    ((coeffEmb K).comp (qExpand ℚ ℓ)).comp evalAtJ = (qEmbedT K ℓ).comp evalAtJ := by
+  refine RingHom.ext fun p => ?_
+  simp only [RingHom.comp_apply]
+  rw [qEmbedT_eq_coeffEmb_qExpand]
+
+end Embed
+
+section EmbedPrime
+
+variable (K : Type*) [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+private theorem qEmbedT_jqN : qEmbedT K ℓ (jqN ℓ) = conj ℓ ζ (0 : Fin (ℓ + 1)) := by
+  rw [conj_zero, qEmbedT_apply, jqN, coeffMap_qExpand, coeffMap_jq, qExpand_qExpand]
+
+private theorem qTwist_comp_qEmbedT (hζ : IsPrimitiveRoot (ζ : K) ℓ) (b : ℕ) :
+    (qTwist (ζ ^ b)).comp (qEmbedT K ℓ) = qEmbedT K ℓ := by
+  refine RingHom.ext fun x => ?_
+  rw [RingHom.comp_apply, qEmbedT_apply, qTwist_qExpand, zeta_pow_zpow_eq_one ℓ ζ hζ b,
+    qTwist_one_apply]
+
+private theorem conj_succ_zero : conj ℓ ζ (0 : Fin ℓ).succ = (coeffEmb K jq) := by
+  rw [conj_succ, Fin.val_zero, pow_zero, qTwist_one_apply]
+
+end EmbedPrime
+
+section FactorAnalysis
+
+variable (K : Type*) [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+private def adjoinEmbedT : adjoinJq →+* LaurentSeries K :=
+  (qEmbedT K ℓ).comp (algebraMap adjoinJq (LaurentSeries ℚ))
+
+private theorem adjoinEmbedT_apply (x : adjoinJq) :
+    adjoinEmbedT K ℓ x = qEmbedT K ℓ (x : LaurentSeries ℚ) := rfl
+
+private theorem adjoinEmbedT_injective : Function.Injective (adjoinEmbedT K ℓ) :=
+  fun _ _ h => Subtype.ext (qEmbedT_injective K ℓ h)
+
+private theorem adjoinEmbedT_comp_evalAtJAdj :
+    (adjoinEmbedT K ℓ).comp evalAtJAdj = (qEmbedT K ℓ).comp evalAtJ := by
+  refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+  change adjoinEmbedT K ℓ (evalAtJAdj Polynomial.X) = qEmbedT K ℓ (evalAtJ Polynomial.X)
+  rw [show evalAtJAdj Polynomial.X = jAdj from Polynomial.eval₂_X _ _, evalAtJ_X]
+  rfl
+
+variable {K ℓ ζ}
+
+private theorem eval_map_conj_succ_eq_zero (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    {D : Polynomial adjoinJq} (h : (D.map (adjoinEmbedT K ℓ)).eval (coeffEmb K jq) = 0)
+    (b : Fin ℓ) : (D.map (adjoinEmbedT K ℓ)).eval (conj ℓ ζ b.succ) = 0 := by
+  have hcomp : (qTwist (ζ ^ (b : ℕ))).comp (adjoinEmbedT K ℓ) = adjoinEmbedT K ℓ := by
+    rw [adjoinEmbedT, ← RingHom.comp_assoc, qTwist_comp_qEmbedT K ℓ ζ hζ]
+  have key : qTwist (ζ ^ (b : ℕ)) ((D.map (adjoinEmbedT K ℓ)).eval (coeffEmb K jq))
+      = (D.map (adjoinEmbedT K ℓ)).eval (qTwist (ζ ^ (b : ℕ)) (coeffEmb K jq)) := by
+    rw [Polynomial.eval_map, Polynomial.eval_map, Polynomial.hom_eval₂, hcomp]
+  rw [conj_succ, ← key, h, map_zero]
+
+private theorem le_natDegree_of_eval_map_jqK_eq_zero (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    {D : Polynomial adjoinJq} (hD : D ≠ 0)
+    (h : (D.map (adjoinEmbedT K ℓ)).eval (coeffEmb K jq) = 0) : ℓ ≤ D.natDegree := by
+  have hmap : ℓ ≤ (D.map (adjoinEmbedT K ℓ)).natDegree := by
+    by_contra hlt
+    rw [not_le] at hlt
+    have hzero : D.map (adjoinEmbedT K ℓ) = 0 :=
+      Polynomial.eq_zero_of_natDegree_lt_card_of_eval_eq_zero _
+        (f := fun b : Fin ℓ => conj ℓ ζ b.succ)
+        (fun b b' hbb' => Fin.succ_injective ℓ (conj_injective ℓ ζ hζ hbb'))
+        (fun b => eval_map_conj_succ_eq_zero hζ h b)
+        (by rwa [Fintype.card_fin])
+    exact hD (Polynomial.map_injective _ (adjoinEmbedT_injective K ℓ)
+      (by rw [hzero, Polynomial.map_zero]))
+  exact le_trans hmap Polynomial.natDegree_map_le
+
+private theorem eval_map_evalAtJAdj_ne_zero
+    (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (data : ModularPolynomialData ℓ)
+    (hsplit : (data.Φ.map evalAtJAdj).map (adjoinEmbedT K ℓ) = phiProd ℓ (conj ℓ ζ))
+    (β : adjoinJq) : (data.Φ.map evalAtJAdj).eval β ≠ 0 := by
+  intro heval
+  have hmap : (phiProd ℓ (conj ℓ ζ)).eval (adjoinEmbedT K ℓ β) = 0 := by
+    rw [← hsplit, Polynomial.eval_map, Polynomial.eval₂_at_apply, heval, map_zero]
+  rw [phiProd, Polynomial.eval_prod] at hmap
+  obtain ⟨i, -, hi⟩ := Finset.prod_eq_zero_iff.mp hmap
+  rw [Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, sub_eq_zero] at hi
+  rcases Fin.eq_zero_or_eq_succ i with rfl | ⟨b, rfl⟩
+  · rw [adjoinEmbedT_apply, ← qEmbedT_jqN K ℓ ζ] at hi
+    have hβ : (β : LaurentSeries ℚ) = jqN ℓ := qEmbedT_injective K ℓ hi
+    exact jqN_not_mem_adjoin_jq ℓ hpos (hβ ▸ β.2)
+  · have h0 : (adjoinEmbedT K ℓ β).coeff (-1 : ℤ) = 0 := by
+      rw [adjoinEmbedT_apply, qEmbedT_apply]
+      refine qExpand_coeff_of_not_dvd _ _ ?_
+      intro hdvd
+      have h1 : ((ℓ : ℕ) : ℤ) ∣ 1 := dvd_neg.mp hdvd
+      have h2 : ℓ ∣ 1 := by exact_mod_cast h1
+      exact hℓ.out.one_lt.ne' (Nat.dvd_one.mp h2)
+    rw [hi, conj_succ_coeff_neg_one] at h0
+    exact Units.ne_zero _ h0
+
+private theorem isUnit_of_dvd_of_natDegree_le_one
+    (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (data : ModularPolynomialData ℓ)
+    (hsplit : (data.Φ.map evalAtJAdj).map (adjoinEmbedT K ℓ) = phiProd ℓ (conj ℓ ζ))
+    {B : Polynomial adjoinJq} (hdvd : B ∣ data.Φ.map evalAtJAdj)
+    (hlc : IsUnit B.leadingCoeff) (hdeg : B.natDegree ≤ 1) : IsUnit B := by
+  rcases Nat.le_one_iff_eq_zero_or_eq_one.mp hdeg with h0 | h1
+  · rw [Polynomial.eq_C_of_natDegree_eq_zero h0]
+    refine Polynomial.isUnit_C.mpr ?_
+    have hc : B.coeff 0 = B.leadingCoeff := by rw [Polynomial.leadingCoeff, h0]
+    rw [hc]
+    exact hlc
+  · exfalso
+    obtain ⟨u, hu⟩ := hlc
+    obtain ⟨D, hD⟩ := hdvd
+    have hu1 : (u : adjoinJq) = B.coeff 1 := by rw [hu, Polynomial.leadingCoeff, h1]
+    have hBev : ∀ x : adjoinJq, B.eval x = B.coeff 1 * x + B.coeff 0 := fun x => by
+      conv_lhs => rw [Polynomial.eq_X_add_C_of_natDegree_le_one hdeg]
+      simp only [Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C,
+        Polynomial.eval_X]
+    have hroot : B.eval ((↑u⁻¹ : adjoinJq) * -B.coeff 0) = 0 := by
+      rw [hBev, ← hu1]
+      linear_combination (-B.coeff 0) * u.mul_inv
+    refine eval_map_evalAtJAdj_ne_zero hpos data hsplit ((↑u⁻¹ : adjoinJq) * -B.coeff 0) ?_
+    rw [hD, Polynomial.eval_mul, hroot, zero_mul]
+
+end FactorAnalysis
+
+section Irreducibility
+
+variable {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+private theorem irreducible_map_evalAtJAdj_of_splits
+    (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (data : ModularPolynomialData ℓ)
+    (hsplit : (data.Φ.map evalAtJAdj).map (adjoinEmbedT K ℓ) = phiProd ℓ (conj ℓ ζ)) :
+    Irreducible (data.Φ.map evalAtJAdj) := by
+  have hmonic : (data.Φ.map evalAtJAdj).Monic := data.monic.map _
+  have hdeg : (data.Φ.map evalAtJAdj).natDegree = ℓ + 1 := by
+    rw [data.monic.natDegree_map, data.natDegree_eq, dedekindPsi_prime hℓ.out]
+  constructor
+  · exact Polynomial.not_isUnit_of_natDegree_pos _ (by omega)
+  · intro A B hAB
+    have hA0 : A ≠ 0 := fun h => hmonic.ne_zero (by rw [hAB, h, zero_mul])
+    have hB0 : B ≠ 0 := fun h => hmonic.ne_zero (by rw [hAB, h, mul_zero])
+    have hlcmul : A.leadingCoeff * B.leadingCoeff = 1 := by
+      rw [← Polynomial.leadingCoeff_mul, ← hAB]
+      exact hmonic.leadingCoeff
+    have hlcA : IsUnit A.leadingCoeff := IsUnit.of_mul_eq_one _ hlcmul
+    have hlcB : IsUnit B.leadingCoeff := IsUnit.of_mul_eq_one_right _ hlcmul
+    have hAdvd : A ∣ data.Φ.map evalAtJAdj := ⟨B, hAB⟩
+    have hBdvd : B ∣ data.Φ.map evalAtJAdj := ⟨A, hAB.trans (mul_comm A B)⟩
+    have hsum : A.natDegree + B.natDegree = ℓ + 1 := by
+      rw [← Polynomial.natDegree_mul hA0 hB0, ← hAB, hdeg]
+    have hzero : ((A.map (adjoinEmbedT K ℓ)).eval (coeffEmb K jq))
+        * ((B.map (adjoinEmbedT K ℓ)).eval (coeffEmb K jq)) = 0 := by
+      rw [← Polynomial.eval_mul, ← Polynomial.map_mul, ← hAB, hsplit,
+        ← conj_succ_zero K ℓ ζ]
+      exact phiProd_eval_conj ℓ _ _
+    rcases mul_eq_zero.mp hzero with hAz | hBz
+    · right
+      have hAdeg : ℓ ≤ A.natDegree := le_natDegree_of_eval_map_jqK_eq_zero hζ hA0 hAz
+      exact isUnit_of_dvd_of_natDegree_le_one hpos data hsplit hBdvd hlcB (by omega)
+    · left
+      have hBdeg : ℓ ≤ B.natDegree := le_natDegree_of_eval_map_jqK_eq_zero hζ hB0 hBz
+      exact isUnit_of_dvd_of_natDegree_le_one hpos data hsplit hAdvd hlcA (by omega)
+
+private theorem toAdjoin_eq_map_evalAtJAdj {N : ℕ} [NeZero N]
+    (data : ModularPolynomialData N) :
+    data.toAdjoin = (data.Φ.map evalAtJAdj).map (algebraMap adjoinJq ℚ⟮jq⟯) := by
+  rw [ModularPolynomialData.toAdjoin, Polynomial.map_map, algebraMap_comp_evalAtJAdj]
+
+theorem phiIrreducible_of_splits
+    (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (data : ModularPolynomialData ℓ)
+    (hsplit : data.Φ.map (((coeffEmb K).comp (qExpand ℚ ℓ)).comp evalAtJ)
+      = phiProd ℓ (conj ℓ ζ)) : PhiIrreducible data := by
+  rw [coeffEmb_comp_qExpand_comp_evalAtJ K ℓ] at hsplit
+  have hsplit' : (data.Φ.map evalAtJAdj).map (adjoinEmbedT K ℓ)
+      = phiProd ℓ (conj ℓ ζ) := by
+    rw [Polynomial.map_map, adjoinEmbedT_comp_evalAtJAdj]
+    exact hsplit
+  change Irreducible data.toAdjoin
+  rw [toAdjoin_eq_map_evalAtJAdj]
+  exact ((data.monic.map evalAtJAdj).irreducible_iff_irreducible_map_fraction_map).mp
+    (irreducible_map_evalAtJAdj_of_splits ℓ ζ hpos hζ data hsplit')
+
+end Irreducibility
+
+end PhiGen
+
+section SwapBivarEval
+
+private theorem swapBivar_eval₂ (Φ : Polynomial (Polynomial ℤ)) (x y : LaurentSeries ℚ) :
+    (swapBivar Φ).eval₂ (Polynomial.aeval (R := ℤ) x).toRingHom y
+      = Φ.eval₂ (Polynomial.aeval (R := ℤ) y).toRingHom x := by
+  set h : Polynomial (Polynomial ℤ) →+* LaurentSeries ℚ :=
+    Polynomial.eval₂RingHom (Polynomial.aeval (R := ℤ) x).toRingHom y with hh
+  have key : h (swapBivar Φ) = Φ.eval₂ (h.comp swapInner) (h (Polynomial.C Polynomial.X)) :=
+    Polynomial.hom_eval₂ Φ swapInner h (Polynomial.C Polynomial.X)
+  have hCX : h (Polynomial.C Polynomial.X) = x := by
+    rw [hh, Polynomial.coe_eval₂RingHom, Polynomial.eval₂_C, aeval_toRingHom_X]
+  have hcomp : h.comp swapInner = (Polynomial.aeval (R := ℤ) y).toRingHom := by
+    refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+    change h (swapInner Polynomial.X) = (Polynomial.aeval (R := ℤ) y).toRingHom Polynomial.X
+    rw [aeval_toRingHom_X]
+    change h ((Polynomial.aeval (R := ℤ)
+      (Polynomial.X : Polynomial (Polynomial ℤ))) Polynomial.X) = y
+    rw [Polynomial.aeval_X, hh, Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X]
+  calc (swapBivar Φ).eval₂ (Polynomial.aeval (R := ℤ) x).toRingHom y
+      = h (swapBivar Φ) := rfl
+    _ = Φ.eval₂ (h.comp swapInner) (h (Polynomial.C Polynomial.X)) := key
+    _ = Φ.eval₂ (Polynomial.aeval (R := ℤ) y).toRingHom x := by rw [hCX, hcomp]
+
+theorem evalSymm_of_swapBivar_eq {Φ : Polynomial (Polynomial ℤ)} (h : swapBivar Φ = Φ) :
+    EvalSymm Φ := fun x y => by
+  conv_lhs => rw [← h]
+  exact swapBivar_eval₂ Φ x y
+
+end SwapBivarEval
+
+namespace ModularPolynomialData
+p2m_export "ModularCurve.ModularPolynomialData" "toAdjoin toAdjoin_monic monic eval_eq_zero \
+  natDegree_eq Φ"
+p2m_open "ModularCurve.ModularPolynomialData"
+
+variable {N : ℕ} [NeZero N] (data : ModularPolynomialData N)
+
+private theorem _root_.ModularCurve.ModularPolynomialData.aeval_jqN_transposeToAdjoin (hswap :
+  data.Φ.eval₂ (evalAtJqN N) jq = 0) :
+    Polynomial.aeval (jqN N) ((swapBivar data.Φ).map evalAtJGen) = 0 := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_map, algebraMap_comp_evalAtJGen,
+    evalAtJ_def, swapBivar_eval₂, ← evalAtJqN_def]
+  exact hswap
+
+p2m_export "ModularCurve.ModularPolynomialData" "aeval_jqN_transposeToAdjoin"
+
+private theorem _root_.ModularCurve.ModularPolynomialData.swapBivar_eq_of_irreducible (hirr :
+  PhiIrreducible data)
+    (hswap : data.Φ.eval₂ (evalAtJqN N) jq = 0)
+    (hTmonic : ((swapBivar data.Φ).map evalAtJGen).Monic)
+    (hTdeg : ((swapBivar data.Φ).map evalAtJGen).natDegree ≤ dedekindPsi N) :
+    swapBivar data.Φ = data.Φ := by
+  apply Polynomial.map_injective evalAtJGen evalAtJGen_injective
+  change (swapBivar data.Φ).map evalAtJGen = data.toAdjoin
+  have hdvd : data.toAdjoin ∣ (swapBivar data.Φ).map evalAtJGen := by
+    rw [← data.minpoly_jqN_eq hirr]
+    exact minpoly.dvd _ _ (data.aeval_jqN_transposeToAdjoin hswap)
+  refine eq_of_monic_of_dvd_of_natDegree_le data.toAdjoin_monic hTmonic hdvd ?_
+  rw [toAdjoin, data.monic.natDegree_map, data.natDegree_eq]
+  exact hTdeg
+
+p2m_export "ModularCurve.ModularPolynomialData" "swapBivar_eq_of_irreducible"
+
+private theorem _root_.ModularCurve.ModularPolynomialData.evalSymm_of_irreducible (hirr :
+  PhiIrreducible data)
+    (hswap : data.Φ.eval₂ (evalAtJqN N) jq = 0)
+    (hTmonic : ((swapBivar data.Φ).map evalAtJGen).Monic)
+    (hTdeg : ((swapBivar data.Φ).map evalAtJGen).natDegree ≤ dedekindPsi N) :
+    EvalSymm data.Φ :=
+  evalSymm_of_swapBivar_eq (data.swapBivar_eq_of_irreducible hirr hswap hTmonic hTdeg)
+
+p2m_export "ModularCurve.ModularPolynomialData" "evalSymm_of_irreducible"
+end ModularPolynomialData
+
+section Engine
+
+private theorem swapBivar_C (c : Polynomial ℤ) :
+    swapBivar (Polynomial.C c) = c.map Polynomial.C := by
+  have hext : swapBivar.comp (Polynomial.C : Polynomial ℤ →+* Polynomial (Polynomial ℤ))
+      = Polynomial.mapRingHom (Polynomial.C : ℤ →+* Polynomial ℤ) := by
+    refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+    change swapBivar (Polynomial.C Polynomial.X)
+      = Polynomial.mapRingHom (Polynomial.C : ℤ →+* Polynomial ℤ) Polynomial.X
+    rw [swapBivar_C_X, Polynomial.coe_mapRingHom, Polynomial.map_X]
+  calc swapBivar (Polynomial.C c)
+      = swapBivar.comp (Polynomial.C : Polynomial ℤ →+* Polynomial (Polynomial ℤ)) c := rfl
+    _ = Polynomial.mapRingHom (Polynomial.C : ℤ →+* Polynomial ℤ) c := by rw [hext]
+    _ = c.map Polynomial.C := rfl
+
+private theorem degree_swapBivar_lt {Ψ : Polynomial (Polynomial ℤ)} {D : ℕ}
+    (h : ∀ k, (Ψ.coeff k).degree < (D : WithBot ℕ)) :
+    (swapBivar Ψ).degree < (D : WithBot ℕ) := by
+  conv_lhs => rw [Polynomial.as_sum_support_C_mul_X_pow Ψ, map_sum]
+  refine (Polynomial.degree_sum_le _ _).trans_lt
+    ((Finset.sup_lt_iff (WithBot.bot_lt_coe D)).2 fun k _ => ?_)
+  rw [map_mul, map_pow, swapBivar_C, swapBivar_X, ← map_pow]
+  refine lt_of_le_of_lt (le_trans (Polynomial.degree_mul_le _ _) ?_) (h k)
+  calc ((Ψ.coeff k).map Polynomial.C).degree + (Polynomial.C (Polynomial.X ^ k)).degree
+      ≤ (Ψ.coeff k).degree + 0 := by
+        gcongr
+        · exact le_of_eq (Polynomial.degree_map_eq_of_injective Polynomial.C_injective _)
+        · exact Polynomial.degree_C_le
+    _ = (Ψ.coeff k).degree := add_zero _
+
+theorem swapBivar_monic_of_coeff_bounds {Φ : Polynomial (Polynomial ℤ)} {d : ℕ}
+    (h0 : (Φ.coeff 0).Monic) (h0deg : (Φ.coeff 0).natDegree = d)
+    (hk : ∀ k, k ≠ 0 → (Φ.coeff k).degree < (d : WithBot ℕ)) :
+    (swapBivar Φ).Monic ∧ (swapBivar Φ).natDegree = d := by
+  have hsplit : swapBivar Φ = Polynomial.C Polynomial.X * swapBivar Φ.divX
+      + (Φ.coeff 0).map Polynomial.C := by
+    conv_lhs => rw [← Polynomial.X_mul_divX_add Φ]
+    rw [map_add, map_mul, swapBivar_X, swapBivar_C]
+  have hmap : ((Φ.coeff 0).map Polynomial.C).Monic := h0.map _
+  have hmapdeg : ((Φ.coeff 0).map Polynomial.C).degree = (d : WithBot ℕ) := by
+    rw [Polynomial.degree_eq_natDegree hmap.ne_zero, h0.natDegree_map, h0deg]
+  have hsmall : (Polynomial.C Polynomial.X * swapBivar Φ.divX).degree
+      < (d : WithBot ℕ) := by
+    refine lt_of_le_of_lt (Polynomial.degree_mul_le _ _) ?_
+    have hX : (Polynomial.C (Polynomial.X : Polynomial ℤ)).degree = 0 :=
+      Polynomial.degree_C Polynomial.X_ne_zero
+    rw [hX, zero_add]
+    exact degree_swapBivar_lt fun k => by
+      rw [Polynomial.coeff_divX]; exact hk (k + 1) (Nat.succ_ne_zero k)
+  have hlt : (Polynomial.C Polynomial.X * swapBivar Φ.divX).degree
+      < ((Φ.coeff 0).map Polynomial.C).degree := by rw [hmapdeg]; exact hsmall
+  refine ⟨?_, ?_⟩
+  · rw [hsplit]; exact hmap.add_of_right hlt
+  · rw [hsplit, Polynomial.natDegree_eq_of_degree_eq
+      (Polynomial.degree_add_eq_right_of_degree_lt hlt), h0.natDegree_map, h0deg]
+
+end Engine
+
+section Dictionary
+
+private theorem evalAtJ_eq_aeval_map_rat (P : Polynomial ℤ) :
+    evalAtJ P = Polynomial.aeval jq (P.map (Int.castRingHom ℚ)) := by
+  rw [evalAtJ_def, Polynomial.aeval_def, Polynomial.eval₂_map, Subsingleton.elim
+    ((algebraMap ℚ (LaurentSeries ℚ)).comp (Int.castRingHom ℚ))
+    (algebraMap ℤ (LaurentSeries ℚ))]
+  rfl
+
+private theorem coeff_aeval_jq_neg (P : Polynomial ℚ) {m : ℕ} (hm : P.natDegree ≤ m) :
+    (Polynomial.aeval jq P).coeff (-(m : ℤ)) = P.coeff m := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+    Finset.sum_eq_single m]
+  · rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_self,
+      mul_one]
+  · intro i hi hin
+    have hilt : i < m :=
+      lt_of_le_of_ne (le_trans (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hm) hin
+    rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul,
+      coeff_jq_pow_of_lt (by omega), mul_zero]
+  · intro hm'
+    rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul,
+      Polynomial.coeff_eq_zero_of_natDegree_lt
+        (by simp only [Finset.mem_range, not_lt] at hm'; omega),
+      zero_mul]
+
+private theorem degree_lt_of_evalAtJ_coeff_eq_zero {P : Polynomial ℤ} {D : ℕ}
+    (h : ∀ m : ℕ, D ≤ m → (evalAtJ P).coeff (-(m : ℤ)) = 0) :
+    P.degree < (D : WithBot ℕ) := by
+  rcases eq_or_ne P 0 with rfl | hP0
+  · rw [Polynomial.degree_zero]; exact WithBot.bot_lt_coe D
+  rw [← Polynomial.natDegree_lt_iff_degree_lt hP0]
+  by_contra hle
+  rw [not_lt] at hle
+  have hQdeg : (P.map (Int.castRingHom ℚ)).natDegree = P.natDegree :=
+    Polynomial.natDegree_map_eq_of_injective Int.cast_injective P
+  have hcoeff := coeff_aeval_jq_neg (P.map (Int.castRingHom ℚ)) (m := P.natDegree) hQdeg.le
+  rw [← evalAtJ_eq_aeval_map_rat, h P.natDegree hle, Polynomial.coeff_map,
+    eq_intCast] at hcoeff
+  have hlead : P.coeff P.natDegree = 0 := by exact_mod_cast hcoeff.symm
+  exact hP0 (Polynomial.leadingCoeff_eq_zero.mp hlead)
+
+private theorem monic_of_evalAtJ_coeff_eq_one {P : Polynomial ℤ} {D : ℕ}
+    (hle : P.natDegree ≤ D) (h1 : (evalAtJ P).coeff (-(D : ℤ)) = 1) :
+    P.Monic ∧ P.natDegree = D := by
+  have hQdeg : (P.map (Int.castRingHom ℚ)).natDegree = P.natDegree :=
+    Polynomial.natDegree_map_eq_of_injective Int.cast_injective P
+  have hcoeff := coeff_aeval_jq_neg (P.map (Int.castRingHom ℚ)) (m := D) (hQdeg.le.trans hle)
+  rw [← evalAtJ_eq_aeval_map_rat, h1, Polynomial.coeff_map, eq_intCast] at hcoeff
+  have hPD : P.coeff D = 1 := by exact_mod_cast hcoeff.symm
+  have hge : D ≤ P.natDegree :=
+    Polynomial.le_natDegree_of_ne_zero (by rw [hPD]; exact one_ne_zero)
+  exact ⟨Polynomial.monic_of_natDegree_le_of_coeff_eq_one D hle hPD, le_antisymm hle hge⟩
+
+private theorem natDegree_le_of_evalAtJ_coeff_eq_zero {P : Polynomial ℤ} {D : ℕ}
+    (h : ∀ m : ℕ, D < m → (evalAtJ P).coeff (-(m : ℤ)) = 0) :
+    P.natDegree ≤ D := by
+  rcases eq_or_ne P 0 with rfl | hP0
+  · simp
+  by_contra hlt
+  rw [not_le] at hlt
+  have hdeg := degree_lt_of_evalAtJ_coeff_eq_zero (P := P) (D := D + 1)
+    (fun m hm => h m (by omega))
+  rw [← Polynomial.natDegree_lt_iff_degree_lt hP0] at hdeg
+  omega
+
+end Dictionary
+
+namespace ModularPolynomialData
+p2m_export "ModularCurve.ModularPolynomialData" "toAdjoin toAdjoin_monic monic eval_eq_zero \
+  natDegree_eq Φ"
+p2m_open "ModularCurve.ModularPolynomialData"
+
+variable {N : ℕ} [NeZero N] (data : ModularPolynomialData N)
+
+private theorem _root_.ModularCurve.ModularPolynomialData.transposeToAdjoin_monic_of_coeff_bounds
+    (h0 : (data.Φ.coeff 0).Monic) (h0deg : (data.Φ.coeff 0).natDegree = dedekindPsi N)
+    (hk : ∀ k, k ≠ 0 → (data.Φ.coeff k).degree < (dedekindPsi N : WithBot ℕ)) :
+    ((swapBivar data.Φ).map evalAtJGen).Monic ∧
+      ((swapBivar data.Φ).map evalAtJGen).natDegree = dedekindPsi N := by
+  obtain ⟨hmonic, hdeg⟩ := swapBivar_monic_of_coeff_bounds h0 h0deg hk
+  exact ⟨hmonic.map _, by rw [hmonic.natDegree_map, hdeg]⟩
+
+p2m_export "ModularCurve.ModularPolynomialData" "transposeToAdjoin_monic_of_coeff_bounds"
+
+theorem transposeToAdjoin_monic_of_qExpansion
+    (h0top : (evalAtJ (data.Φ.coeff 0)).coeff (-(dedekindPsi N : ℤ)) = 1)
+    (h0le : ∀ m : ℕ, dedekindPsi N < m → (evalAtJ (data.Φ.coeff 0)).coeff (-(m : ℤ)) = 0)
+    (hk : ∀ k, k ≠ 0 → ∀ m : ℕ, dedekindPsi N ≤ m →
+      (evalAtJ (data.Φ.coeff k)).coeff (-(m : ℤ)) = 0) :
+    ((swapBivar data.Φ).map evalAtJGen).Monic ∧
+      ((swapBivar data.Φ).map evalAtJGen).natDegree = dedekindPsi N := by
+  obtain ⟨h0monic, h0deg⟩ := monic_of_evalAtJ_coeff_eq_one
+    (natDegree_le_of_evalAtJ_coeff_eq_zero h0le) h0top
+  exact data.transposeToAdjoin_monic_of_coeff_bounds h0monic h0deg
+    fun k hk0 => degree_lt_of_evalAtJ_coeff_eq_zero (hk k hk0)
+
+end ModularPolynomialData
+
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd phiProd_eval_conj"
+p2m_open "ModularCurve.PhiGen"
+
+section Swap
+
+variable {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+theorem eval_swap_eq_zero_of_splits (data : ModularPolynomialData ℓ)
+    (hsplit : data.Φ.map (((coeffEmb K).comp (qExpand ℚ ℓ)).comp evalAtJ)
+      = phiProd ℓ (conj ℓ ζ)) :
+    data.Φ.eval₂ (evalAtJqN ℓ) jq = 0 := by
+  rw [coeffEmb_comp_qExpand_comp_evalAtJ K ℓ] at hsplit
+  have h1 : data.Φ.eval₂ ((qEmbedT K ℓ).comp evalAtJ) (coeffEmb K jq) = 0 := by
+    rw [← Polynomial.eval_map, hsplit, ← conj_succ_zero K ℓ ζ, phiProd,
+      Polynomial.eval_prod]
+    exact Finset.prod_eq_zero (Finset.mem_univ ((0 : Fin ℓ).succ)) (by simp)
+  have h2 : data.Φ.eval₂ ((qExpand K ℓ).comp ((qEmbedT K ℓ).comp evalAtJ))
+      (qExpand K ℓ (coeffEmb K jq)) = 0 := by
+    have h := congrArg (qExpand K ℓ) h1
+    rwa [Polynomial.hom_eval₂, map_zero] at h
+  apply qEmbedT_injective K ℓ
+  rw [map_zero, Polynomial.hom_eval₂, qEmbedT_jq]
+  have hhom : (qEmbedT K ℓ).comp (evalAtJqN ℓ)
+      = (qExpand K ℓ).comp ((qEmbedT K ℓ).comp evalAtJ) := by
+    refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+    change qEmbedT K ℓ (evalAtJqN ℓ Polynomial.X)
+      = qExpand K ℓ (qEmbedT K ℓ (evalAtJ Polynomial.X))
+    rw [evalAtJqN_X, evalAtJ_X, qEmbedT_jq, qEmbedT_jqN K ℓ ζ, conj_zero, qExpand_qExpand]
+  rw [hhom]
+  exact h2
+
+private theorem evalSymm_of_splits
+    (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (data : ModularPolynomialData ℓ)
+    (hsplit : data.Φ.map (((coeffEmb K).comp (qExpand ℚ ℓ)).comp evalAtJ)
+      = phiProd ℓ (conj ℓ ζ))
+    (hTmonic : ((swapBivar data.Φ).map evalAtJGen).Monic)
+    (hTdeg : ((swapBivar data.Φ).map evalAtJGen).natDegree ≤ dedekindPsi ℓ) :
+    EvalSymm data.Φ :=
+  data.evalSymm_of_irreducible (phiIrreducible_of_splits ℓ ζ hpos hζ data hsplit)
+    (eval_swap_eq_zero_of_splits ℓ ζ data hsplit) hTmonic hTdeg
+
+end Swap
+
+end PhiGen
+
+end ModularCurve
+end
+
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_PhiGen_evalSymm_of_splits.ModularCurve
+  _root_.ModularCurve.PhiGen
+  _root_.P2MW.S_ModularCurve_PhiGen_evalSymm_of_splits.ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) ℓ) (data : ModularPolynomialData ℓ)
+    (hsplit : data.Φ.map (((coeffEmb K).comp (qExpand ℚ ℓ)).comp evalAtJ) = phiProd ℓ (conj ℓ ζ))
+    (hTmonic : ((swapBivar data.Φ).map evalAtJGen).Monic)
+    (hTdeg : ((swapBivar data.Φ).map evalAtJGen).natDegree ≤ dedekindPsi ℓ) :
+    EvalSymm data.Φ :=
+  ModularCurve.PhiGen.evalSymm_of_splits ℓ ζ ModularCurve.one_le_coeff_jq hζ data hsplit hTmonic
+    hTdeg
+
+end S_ModularCurve_PhiGen_evalSymm_of_splits
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_evalSymm_of_splits (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.evalSymm_of_splits {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ)
+    [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (data : ModularPolynomialData ℓ)
+    (hsplit : data.Φ.map (((coeffEmb K).comp (qExpand ℚ ℓ)).comp evalAtJ) = phiProd ℓ (conj ℓ ζ))
+    (hTmonic : ((swapBivar data.Φ).map evalAtJGen).Monic)
+    (hTdeg : ((swapBivar data.Φ).map evalAtJGen).natDegree ≤ dedekindPsi ℓ) :
+    EvalSymm data.Φ :=
+  solution ℓ ζ hζ data hsplit hTmonic hTdeg
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_exists_galoisPerm.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_exists_galoisPerm.lean
new file mode 100644
index 0000000000..1570079f67
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_exists_galoisPerm.lean
@@ -0,0 +1,374 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.exists_galoisPerm
+(372db64a-d7eb-5ae5-8db4-6cf5bef16d73) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8798413d-4480-559c-bf9f-330f053c01da
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import Mathlib.FieldTheory.Galois.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A field endomorphism permutes the ℓ-th roots of unity
+
+Theorem statement: `ModularCurve.PhiGen.exists_galoisPerm` (`372db64a-d7eb-5ae5-8db4-6cf5bef16d73`),
+by Claude, 2026-09-05.
+
+Proof: submission `8798413d-4480-559c-bf9f-330f053c01da`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, let $\ell$ be a natural number which is prime (recorded as a `Fact` instance),
+and let $\zeta$ be a unit of $K$ whose underlying element is a primitive $\ell$-th root of unity in
+$K$. Let $\sigma \colon K \to K$ be any ring homomorphism from $K$ to itself (not assumed bijective,
+nor continuous, nor the identity on any subfield). The assertion is that there exists a permutation
+$e$ of the finite index type `Fin ℓ`, that is a bijection $e \colon \mathrm{Fin}\,\ell \simeq
+\mathrm{Fin}\,\ell$, such that for every $b \in \mathrm{Fin}\,\ell$ one has $\sigma(\zeta^{b}) =
+\zeta^{e(b)}$, the exponents on both sides being the natural numbers underlying $b$ and $e(b)$ under
+the coercion $\mathrm{Fin}\,\ell \to \mathbb{N}$. Thus the group $\mu_\ell \subset K^\times$ of
+$\ell$-th roots of unity, enumerated as $\zeta^{0}, \zeta^{1}, \dots, \zeta^{\ell-1}$, is carried to
+itself bijectively by $\sigma$, with the permutation of the exponent set $\mathrm{Fin}\,\ell$
+produced explicitly; note that $b = 0$ is included, so $e$ necessarily fixes $0$.
+
+This is the elementary statement that a field endomorphism acts on the $\ell$-th roots of unity of
+$K$ through a permutation of their exponents modulo $\ell$, here packaged as a bijection of `Fin ℓ`
+so that sums and products indexed by exponents may be reindexed. It is used in the study of
+$q$-expansions at level $\ell$ and their Galois conjugates, being cited in the results on Fricke
+involutions, integrality over $\mathbb{Z}[j(q)]$ and membership in the modular function field for
+$\Gamma_0$-invariant expansions, alongside the compatibility of
+[`ModularCurve.coeffMap`](def/ModularCurve_LaurentCoeff.html#L16) with
+[`ModularCurve.qExpand`](def/ModularCurve_X0.html#L25).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_exists_galoisPerm.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_exists_galoisPerm
+
+noncomputable section
+
+open PowerSeries HahnSeries Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd jq qTwist \
+  qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap coeffMap_coeff coeffEmb \
+  coeffEmb_coeff coeffMap_coeffEmb coeffMap_qExpand"
+p2m_open "ModularCurve"
+
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd PhiGenDescends"
+p2m_open "ModularCurve.PhiGen"
+
+section PermLemma
+
+variable {K : Type*} [Field K] {ℓ : ℕ} {conj : Fin (ℓ + 1) → LaurentSeries K}
+
+private theorem map_phiProd_of_perm (F : LaurentSeries K →+* LaurentSeries K)
+    (e : Fin ℓ ≃ Fin ℓ) (h0 : F (conj 0) = conj 0)
+    (hS : ∀ b : Fin ℓ, F (conj b.succ) = conj (e b).succ) :
+    (phiProd ℓ conj).map F = phiProd ℓ conj := by
+  rw [phiProd, Polynomial.map_prod]
+  simp only [Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C]
+  rw [Fin.prod_univ_succ, Fin.prod_univ_succ, h0]
+  congr 1
+  calc ∏ b : Fin ℓ, (Polynomial.X - Polynomial.C (F (conj b.succ)))
+      = ∏ b : Fin ℓ, (Polynomial.X - Polynomial.C (conj (e b).succ)) := by
+        refine Finset.prod_congr rfl fun b _ => ?_
+        rw [hS b]
+    _ = ∏ b : Fin ℓ, (Polynomial.X - Polynomial.C (conj b.succ)) :=
+        e.prod_comp fun b => Polynomial.X - Polynomial.C (conj b.succ)
+
+private theorem map_phiProd_coeff_of_perm (F : LaurentSeries K →+* LaurentSeries K)
+    (e : Fin ℓ ≃ Fin ℓ) (h0 : F (conj 0) = conj 0)
+    (hS : ∀ b : Fin ℓ, F (conj b.succ) = conj (e b).succ) (k : ℕ) :
+    F ((phiProd ℓ conj).coeff k) = (phiProd ℓ conj).coeff k := by
+  conv_rhs => rw [← map_phiProd_of_perm F e h0 hS]
+  rw [Polynomial.coeff_map]
+
+end PermLemma
+
+section TwistRoot
+
+variable {K : Type*} [Field K] {ℓ : ℕ} {ζ : Kˣ}
+
+private theorem zeta_pow_card_eq_one (hζ : IsPrimitiveRoot (ζ : K) ℓ) : ζ ^ ℓ = 1 := by
+  refine Units.ext ?_
+  rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one]
+
+private theorem zeta_pow_mod (hζ : IsPrimitiveRoot (ζ : K) ℓ) (n : ℕ) :
+    ζ ^ (n % ℓ) = ζ ^ n :=
+  (pow_eq_pow_mod n (zeta_pow_card_eq_one hζ)).symm
+
+end TwistRoot
+
+section TwistConj
+
+variable {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+  {conj : Fin (ℓ + 1) → LaurentSeries K} {ζ : Kˣ} {J : LaurentSeries K}
+
+private theorem qTwist_conj_zero (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J) : qTwist ζ (conj 0) = conj 0 := by
+  rw [hconj0, qTwist_qExpand]
+  congr 1
+  rw [zpow_natCast, pow_mul, zeta_pow_card_eq_one hζ, one_pow, qTwist_one_apply]
+
+private theorem qTwist_conj_succ (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J) (b : Fin ℓ) :
+    qTwist ζ (conj b.succ) = conj ((Equiv.addRight (1 : Fin ℓ)) b).succ := by
+  rw [hconjS b, hconjS ((Equiv.addRight (1 : Fin ℓ)) b), qTwist_qTwist]
+  congr 1
+  simp only [Equiv.coe_addRight]
+  have h1 : ((1 : Fin ℓ) : ℕ) = 1 := by
+    rw [Fin.val_one']
+    exact Nat.mod_eq_of_lt hℓ.out.one_lt
+  rw [Fin.val_add, h1, zeta_pow_mod hζ ((b : ℕ) + 1), pow_succ, mul_comm ζ (ζ ^ (b : ℕ))]
+
+private theorem qTwist_phiProd_coeff (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J) (k : ℕ) :
+    qTwist ζ ((phiProd ℓ conj).coeff k) = (phiProd ℓ conj).coeff k :=
+  map_phiProd_coeff_of_perm (qTwist ζ) (Equiv.addRight (1 : Fin ℓ))
+    (qTwist_conj_zero hζ hconj0) (qTwist_conj_succ hζ hconjS) k
+
+end TwistConj
+
+section SupportCollapse
+
+variable {K : Type*} [Field K] {ℓ : ℕ} {ζ : Kˣ}
+
+private theorem coeff_eq_zero_of_qTwist_eq (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    {f : LaurentSeries K} (hf : qTwist ζ f = f) {m : ℤ} (hm : ¬ (ℓ : ℤ) ∣ m) :
+    f.coeff m = 0 := by
+  have h := congrArg (fun g => HahnSeries.coeff g m) hf
+  simp only [qTwist_coeff] at h
+  by_contra hc
+  apply hm
+  rw [← hζ.zpow_eq_one_iff_dvd]
+  have hunit : ((ζ ^ m : Kˣ) : K) = (ζ : K) ^ m := Units.val_zpow_eq_zpow_val ζ m
+  have hzero : (((ζ ^ m : Kˣ) : K) - 1) * f.coeff m = 0 := by
+    rw [sub_mul, one_mul, h, sub_self]
+  rcases mul_eq_zero.mp hzero with h1 | h1
+  · rw [hunit] at h1
+    linear_combination h1
+  · exact absurd h1 hc
+
+end SupportCollapse
+
+section Contract
+
+variable {K : Type*} [Field K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)]
+
+private def qContract (f : LaurentSeries K) : LaurentSeries K where
+  coeff m := f.coeff ((ℓ : ℤ) * m)
+  isPWO_support' := by
+    have hsub : (Function.support fun m : ℤ => f.coeff ((ℓ : ℤ) * m)) ⊆
+        (fun k : ℤ => k / (ℓ : ℤ)) '' f.support := by
+      intro m hm
+      refine ⟨(ℓ : ℤ) * m, hm, ?_⟩
+      exact Int.mul_ediv_cancel_left m (Nat.cast_ne_zero.mpr hℓ.out.ne_zero)
+    exact (f.isPWO_support'.image_of_monotone fun a b hab =>
+      Int.ediv_le_ediv (Int.natCast_pos.mpr hℓ.out.pos) hab).mono hsub
+
+@[scoped simp]
+private theorem qContract_coeff (f : LaurentSeries K) (m : ℤ) :
+    (qContract ℓ f).coeff m = f.coeff ((ℓ : ℤ) * m) := rfl
+
+variable {ℓ}
+
+private theorem qExpand_qContract {f : LaurentSeries K}
+    (hf : ∀ m : ℤ, ¬ (ℓ : ℤ) ∣ m → f.coeff m = 0) :
+    qExpand K ℓ (qContract ℓ f) = f := by
+  ext k
+  by_cases hk : (ℓ : ℤ) ∣ k
+  · obtain ⟨m, rfl⟩ := hk
+    rw [qExpand_coeff_mul, qContract_coeff]
+  · rw [qExpand_coeff_of_not_dvd ℓ _ hk, hf k hk]
+
+private theorem mem_range_qExpand_of_qTwist_eq {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    {f : LaurentSeries K} (hf : qTwist ζ f = f) : f ∈ Set.range (qExpand K ℓ) :=
+  ⟨qContract ℓ f, qExpand_qContract fun _ hm => coeff_eq_zero_of_qTwist_eq hζ hf hm⟩
+
+end Contract
+
+section RangeDescent
+
+variable {K : Type*} [Field K]
+
+theorem phiProd_coeff_mem_range_qExpand (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+    (J : LaurentSeries K) (conj : Fin (ℓ + 1) → LaurentSeries K)
+    (hζ : IsPrimitiveRoot (ζ : K) ℓ) (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J) (k : ℕ) :
+    (phiProd ℓ conj).coeff k ∈ Set.range (qExpand K ℓ) :=
+  mem_range_qExpand_of_qTwist_eq hζ (qTwist_phiProd_coeff hζ hconj0 hconjS k)
+
+end RangeDescent
+
+section GaloisMap
+
+variable {R S : Type*} [CommRing R] [CommRing S]
+
+private theorem coeffMap_qTwist (σ : R →+* S) (u : Rˣ) (v : Sˣ) (huv : (v : S) = σ (u : R))
+    (f : LaurentSeries R) : coeffMap σ (qTwist u f) = qTwist v (coeffMap σ f) := by
+  have hmap : Units.map (σ : R →* S) u = v :=
+    Units.ext (by rw [Units.coe_map, huv]; rfl)
+  ext k
+  rw [coeffMap_coeff, qTwist_coeff, qTwist_coeff, coeffMap_coeff, map_mul]
+  congr 1
+  rw [← hmap, ← map_zpow, Units.coe_map]
+  rfl
+
+end GaloisMap
+
+section GaloisCoeff
+
+variable {K : Type*} [Field K]
+
+theorem coeffMap_phiProd_coeff (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+    (J : LaurentSeries K) (conj : Fin (ℓ + 1) → LaurentSeries K) (σ : K →+* K)
+    (hσJ : coeffMap σ J = J) (e : Fin ℓ ≃ Fin ℓ)
+    (hσζ : ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e b : Fin ℓ) : ℕ))
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J) (k : ℕ) :
+    coeffMap σ ((phiProd ℓ conj).coeff k) = (phiProd ℓ conj).coeff k := by
+  refine map_phiProd_coeff_of_perm (coeffMap σ) e ?_ ?_ k
+  · rw [hconj0, coeffMap_qExpand, hσJ]
+  · intro b
+    rw [hconjS b, hconjS (e b),
+      coeffMap_qTwist σ (ζ ^ (b : ℕ)) (ζ ^ ((e b : Fin ℓ) : ℕ))
+        (by rw [Units.val_pow_eq_pow_val, Units.val_pow_eq_pow_val, hσζ b]),
+      hσJ]
+
+end GaloisCoeff
+
+section FixedField
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+theorem mem_range_coeffEmb_of_forall_coeffMap_eq
+    (hfix : ∀ c : K, (∀ σ : K ≃ₐ[ℚ] K, σ c = c) → ∃ r : ℚ, algebraMap ℚ K r = c)
+    {f : LaurentSeries K} (hf : ∀ σ : K ≃ₐ[ℚ] K, coeffMap (σ : K →+* K) f = f) :
+    f ∈ Set.range (coeffEmb K) := by
+  have hcoeff : ∀ m : ℤ, ∃ r : ℚ, algebraMap ℚ K r = f.coeff m := fun m =>
+    hfix (f.coeff m) fun σ => by
+      have hcongr := congrArg (fun g => HahnSeries.coeff g m) (hf σ)
+      simpa using hcongr
+  choose r hr using hcoeff
+  refine ⟨⟨r, ?_⟩, ?_⟩
+  · refine f.isPWO_support'.mono fun m hm => ?_
+    simp only [Function.mem_support] at hm ⊢
+    intro h
+    exact hm (FaithfulSMul.algebraMap_injective ℚ K (by rw [hr m, h, map_zero]))
+  · ext m
+    exact hr m
+
+end FixedField
+
+section GaloisPerm
+
+variable {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ}
+
+private theorem exists_galoisPerm (hζ : IsPrimitiveRoot (ζ : K) ℓ) (σ : K →+* K) :
+    ∃ e : Fin ℓ ≃ Fin ℓ,
+      ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e b : Fin ℓ) : ℕ) := by
+  have hσζ : (σ (ζ : K)) ^ ℓ = 1 := by
+    rw [← map_pow, hζ.pow_eq_one, map_one]
+  obtain ⟨a, -, ha⟩ := hζ.eq_pow_of_pow_eq_one hσζ
+  set e₀ : Fin ℓ → Fin ℓ := fun b => ⟨(a * (b : ℕ)) % ℓ, Nat.mod_lt _ hℓ.out.pos⟩
+  have hkey : ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e₀ b : Fin ℓ) : ℕ) := by
+    intro b
+    change σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((a * (b : ℕ)) % ℓ)
+    rw [map_pow, ← ha, ← pow_mul]
+    exact pow_eq_pow_mod _ hζ.pow_eq_one
+  have hinj : Function.Injective e₀ := by
+    intro b b' hbb'
+    have h1 : σ ((ζ : K) ^ (b : ℕ)) = σ ((ζ : K) ^ ((b' : Fin ℓ) : ℕ)) := by
+      rw [hkey b, hkey b', hbb']
+    exact Fin.ext (hζ.pow_inj b.isLt b'.isLt (σ.injective h1))
+  exact ⟨Equiv.ofBijective e₀ (Finite.injective_iff_bijective.mp hinj), hkey⟩
+
+end GaloisPerm
+
+section Descent
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+theorem mem_range_coeffEmb_qExpand_of_mem_inter {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+    {f : LaurentSeries K} (h1 : f ∈ Set.range (ModularCurve.qExpand K ℓ))
+    (h2 : f ∈ Set.range (coeffEmb K)) :
+    ∃ g : LaurentSeries ℚ, f = coeffEmb K (ModularCurve.qExpand ℚ ℓ g) := by
+  obtain ⟨h, hh⟩ := h2
+  have hsupp : ∀ m : ℤ, ¬ (ℓ : ℤ) ∣ m → h.coeff m = 0 := by
+    intro m hm
+    obtain ⟨g, hg⟩ := h1
+    refine FaithfulSMul.algebraMap_injective ℚ K ?_
+    rw [map_zero, ← coeffEmb_coeff, hh, ← hg, qExpand_coeff_of_not_dvd ℓ g hm]
+  refine ⟨qContract ℓ h, ?_⟩
+  rw [qExpand_qContract hsupp]
+  exact hh.symm
+
+theorem exists_phiGenDescends (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+    [IsGalois ℚ K] [FiniteDimensional ℚ K] (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    ∃ c : ℕ → LaurentSeries ℚ, PhiGenDescends ℓ ζ c := by
+  have hmem : ∀ k : ℕ, ∃ g : LaurentSeries ℚ,
+      (phiProd ℓ (conj ℓ ζ)).coeff k = coeffEmb K (ModularCurve.qExpand ℚ ℓ g) := by
+    intro k
+    refine mem_range_coeffEmb_qExpand_of_mem_inter ?_ ?_
+    · exact phiProd_coeff_mem_range_qExpand ℓ ζ (coeffEmb K jq) (conj ℓ ζ)
+        hζ (conj_zero ℓ ζ) (conj_succ ℓ ζ) k
+    · refine mem_range_coeffEmb_of_forall_coeffMap_eq
+        (fun x hx => (IsGalois.mem_range_algebraMap_iff_fixed x).mpr hx) ?_
+      intro σ
+      obtain ⟨e, he⟩ := exists_galoisPerm hζ (σ : K →+* K)
+      exact coeffMap_phiProd_coeff ℓ ζ (coeffEmb K jq) (conj ℓ ζ) (σ : K →+* K)
+        (coeffMap_coeffEmb σ jq) e he (conj_zero ℓ ζ) (conj_succ ℓ ζ) k
+  choose c hc using hmem
+  exact ⟨c, hc⟩
+
+end Descent
+
+end PhiGen
+end ModularCurve
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_PhiGen_exists_galoisPerm.ModularCurve
+  _root_.ModularCurve.PhiGen _root_.P2MW.S_ModularCurve_PhiGen_exists_galoisPerm.ModularCurve.PhiGen
+  in
+theorem solution {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ}
+    (hζ : IsPrimitiveRoot (ζ : K) ℓ) (σ : K →+* K) :
+    ∃ e : Fin ℓ ≃ Fin ℓ, ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e b : Fin ℓ) : ℕ) :=
+  ModularCurve.PhiGen.exists_galoisPerm hζ σ
+
+end S_ModularCurve_PhiGen_exists_galoisPerm
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_exists_galoisPerm (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.exists_galoisPerm {K : Type*} [Field K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) ℓ) (σ : K →+* K) :
+    ∃ e : Fin ℓ ≃ Fin ℓ, ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e b : Fin ℓ) : ℕ) :=
+  solution hζ σ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_exists_modularPolynomialData_coeff_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_exists_modularPolynomialData_coeff_eq.lean
new file mode 100644
index 0000000000..e76ac0ed9e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_exists_modularPolynomialData_coeff_eq.lean
@@ -0,0 +1,254 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.exists_modularPolynomialData_coeff_eq
+(6879c911-b7bb-5d11-ba98-24b49f32a07a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a8132dcd-9397-5ba5-8dd6-ba0f06263369
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_PhiGenDescends_c_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_PhiGenDescends_c_top
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_PhiGenDescends_poleOrderLE
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_PhiGenDescends_sum_mul_jqN_pow_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_aeval_jq_intCoeffs_descent
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_evalAtJ_injective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Assembling Φ_ℓ from a descended integral coefficient family
+
+Theorem statement: `ModularCurve.PhiGen.exists_modularPolynomialData_coeff_eq`
+(`6879c911-b7bb-5d11-ba98-24b49f32a07a`), by Claude, 2026-09-05.
+
+Proof: submission `a8132dcd-9397-5ba5-8dd6-ba0f06263369`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field containing $\mathbb{Q}$ as a subalgebra, let $\ell$ be a prime, let $\zeta$ be a
+unit of $K$, and let $c : \mathbb{N} \to \mathbb{Q}((q))$ be a family of Laurent series over
+$\mathbb{Q}$. Three hypotheses are imposed. First, `PhiGenDescends ℓ ζ c`: for every $k$, the
+degree-$k$ coefficient of the monic polynomial $\prod_{i \in \mathrm{Fin}(\ell+1)} (X -
+C(\mathrm{conj}\ \ell\ \zeta\ i))$ over $K((q))$, whose roots are the conjugate series `conj ℓ ζ i`
+built from $\zeta$ and the coset data `cosetA ℓ i`, `cosetB ℓ i` applied to the image of the
+$j$-series `jq` in $K((q))$, equals the image under the coefficientwise map induced by $\mathbb{Q}
+\to K$ of `qExpand ℚ ℓ (c k)`, the series $c_k$ with all exponents multiplied by $\ell$. Second,
+each $c_k$ has all its Laurent coefficients in $\mathbb{Z}$. Third, each $c_k$ lies in the
+$\mathbb{Q}$-subalgebra of $\mathbb{Q}((q))$ generated by `jq`. The conclusion asserts the existence
+of a `ModularPolynomialData ℓ`, that is a polynomial $\Phi \in (\mathbb{Z}[X])[Y]$ which is monic,
+has $Y$-degree equal to $\psi(\ell) = \sum_{d \mid \ell,\ d\ \text{squarefree}} \ell/d$ (equal to
+$\ell+1$ for $\ell$ prime), and satisfies $\Phi = 0$ after substituting $X \mapsto$ `jq`
+coefficientwise and $Y \mapsto$ `jqN ℓ`, together with the property that for every $k$ the
+$Y^k$-coefficient of $\Phi$, evaluated at $X =$ `jq`, is exactly $c_k$.
+
+This is the assembly step producing the classical modular polynomial $\Phi_\ell(X,Y)$ for
+$X_0(\ell)$: the coefficients of the product over the $\ell+1$ conjugates, once known to descend to
+$q$-expansions with integral coefficients lying in $\mathbb{Q}[j]$, are recognised as integral
+polynomials in $j$, and the resulting packet is monic of degree $\psi(\ell)$ in $Y$ and vanishes at
+$(j(q),$ `jqN ℓ` $)$. It is used downstream for the splitting statement
+[`ModularCurve.PhiGen.splits_of_prime`](thm.html#ModularCurve.PhiGen.splits_of_prime), for the
+weighted support bound
+[`ModularCurve.ModularPolynomialData.weighted_support_le`]
+(thm.html#ModularCurve.ModularPolynomialData.weighted_support_le),
+and in
+[`ModularCurve.exists_modularPolynomialData_evalSymm`]
+(thm.html#ModularCurve.exists_modularPolynomialData_evalSymm).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_exists_modularPolynomialData_coeff_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_exists_modularPolynomialData_coeff_eq
+
+noncomputable section
+
+open Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand algebraMap_apply_eq_single jq coeff_jq_pow_self \
+  coeff_jq_pow_of_lt jqN evalAtJ ModularPolynomialData PoleOrderLE coeffEmb dedekindPsi_prime"
+p2m_open "ModularCurve"
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj phiProd IntCoeffs PhiGenDescends evalAtJ_injective \
+  aeval_jq_intCoeffs_descent"
+p2m_open "ModularCurve.PhiGen"
+
+private theorem evalAtJ_eq_aeval_map (Q : Polynomial ℤ) :
+    evalAtJ Q = Polynomial.aeval jq (Q.map (Int.castRingHom ℚ)) := by
+  have hcomp : (algebraMap ℚ (LaurentSeries ℚ)).comp (Int.castRingHom ℚ)
+      = algebraMap ℤ (LaurentSeries ℚ) := Subsingleton.elim _ _
+  rw [Polynomial.aeval_def, Polynomial.eval₂_map, hcomp]
+  rfl
+
+private theorem coeff_aeval_jq_neg (P : Polynomial ℚ) {m : ℕ} (hm : P.natDegree ≤ m) :
+    (Polynomial.aeval jq P).coeff (-(m : ℤ)) = P.coeff m := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+    Finset.sum_eq_single m]
+  · rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_self,
+      mul_one]
+  · intro i hi hin
+    have hilt : i < m :=
+      lt_of_le_of_ne (le_trans (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hm) hin
+    rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul,
+      coeff_jq_pow_of_lt (by omega), mul_zero]
+  · intro hm'
+    rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul,
+      Polynomial.coeff_eq_zero_of_natDegree_lt
+        (by simp only [Finset.mem_range, not_lt] at hm'; omega),
+      zero_mul]
+
+theorem natDegree_le_of_poleOrderLE_aeval (P : Polynomial ℚ) {n : ℕ}
+    (hn : PoleOrderLE (Polynomial.aeval jq P) n) : P.natDegree ≤ n := by
+  by_contra h
+  push Not at h
+  have hP : P ≠ 0 := by
+    rintro rfl
+    simp at h
+  have h0 := hn (-(P.natDegree : ℤ)) (by omega)
+  rw [coeff_aeval_jq_neg P le_rfl] at h0
+  exact (Polynomial.leadingCoeff_ne_zero.mpr hP) h0
+
+theorem exists_aeval_jq_eq_of_mem_adjoin {f : LaurentSeries ℚ} (hf : f ∈ Algebra.adjoin ℚ {jq})
+    {n : ℕ}
+    (hn : PoleOrderLE f n) : ∃ P : Polynomial ℚ, P.natDegree ≤ n ∧ f = Polynomial.aeval jq P := by
+  rw [Algebra.adjoin_singleton_eq_range_aeval] at hf
+  obtain ⟨P, rfl⟩ := hf
+  exact ⟨P, natDegree_le_of_poleOrderLE_aeval P hn, rfl⟩
+
+section Exits
+
+variable {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ}
+variable {c : ℕ → LaurentSeries ℚ}
+
+namespace PhiGenDescends
+p2m_export "ModularCurve.PhiGen.PhiGenDescends" "c_top c_eq_zero poleOrderLE \
+  sum_mul_jqN_pow_eq_zero"
+end PhiGenDescends
+namespace PhiGenDescends
+p2m_open_scoped "ModularCurve.PhiGen.PhiGenDescends" in
+private theorem _root_.ModularCurve.PhiGen.PhiGenDescends.exists_intPoly (hc : PhiGenDescends ℓ ζ c)
+    (hint : ∀ k, IntCoeffs (c k)) (hmem : ∀ k, c k ∈ Algebra.adjoin ℚ {jq}) (k : ℕ) :
+    ∃ Q : Polynomial ℤ, Q.natDegree ≤ ℓ + 1 ∧ evalAtJ Q = c k := by
+  obtain ⟨P, hPdeg, hP⟩ := exists_aeval_jq_eq_of_mem_adjoin (hmem k) (hc.poleOrderLE k)
+  have hPint : ∀ n : ℕ, ∃ z : ℤ, P.coeff n = (z : ℚ) :=
+    aeval_jq_intCoeffs_descent P (by rw [← hP]; exact hint k)
+  have hlift : P ∈ Polynomial.lifts (Int.castRingHom ℚ) := by
+    rw [Polynomial.lifts_iff_coeff_lifts]
+    intro n
+    obtain ⟨z, hz⟩ := hPint n
+    exact ⟨z, by rw [eq_intCast]; exact hz.symm⟩
+  obtain ⟨Q, hQ⟩ := hlift
+  have hQmap : Q.map (Int.castRingHom ℚ) = P := hQ
+  refine ⟨Q, ?_, ?_⟩
+  · rw [← Polynomial.natDegree_map_eq_of_injective (f := Int.castRingHom ℚ)
+      Int.cast_injective Q, hQmap]
+    exact hPdeg
+  · rw [evalAtJ_eq_aeval_map, hQmap, hP]
+
+end PhiGenDescends
+p2m_export "ModularCurve.PhiGen" "PhiGenDescends.exists_intPoly"
+end Exits
+
+section StrongExistence
+
+private theorem coeff_sum_C_mul_X_pow (Q : ℕ → Polynomial ℤ) (n m : ℕ) (hm : m < n) :
+    (∑ k ∈ Finset.range n, Polynomial.C (Q k) * Polynomial.X ^ k).coeff m = Q m := by
+  rw [Polynomial.finsetSum_coeff, Finset.sum_eq_single m]
+  · rw [Polynomial.coeff_C_mul, Polynomial.coeff_X_pow, ite_eq_left rfl, mul_one]
+  · intro k _ hk
+    rw [Polynomial.coeff_C_mul, Polynomial.coeff_X_pow, ite_eq_right (Ne.symm hk), mul_zero]
+  · intro hm'
+    exact absurd (Finset.mem_range.mpr hm) hm'
+
+variable {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ}
+variable {c : ℕ → LaurentSeries ℚ}
+
+private theorem exists_modularPolynomialData_coeff_eq (hc : PhiGenDescends ℓ ζ c)
+    (hint : ∀ k, IntCoeffs (c k)) (hmem : ∀ k, c k ∈ Algebra.adjoin ℚ {jq}) :
+    ∃ data : ModularPolynomialData ℓ, ∀ k, evalAtJ (data.Φ.coeff k) = c k := by
+  choose Q hQdeg hQeval using hc.exists_intPoly hint hmem
+  have hQtop : Q (ℓ + 1) = 1 := by
+    refine evalAtJ_injective ?_
+    rw [hQeval (ℓ + 1), hc.c_top, map_one]
+  set Φ : Polynomial (Polynomial ℤ) :=
+    ∑ k ∈ Finset.range (ℓ + 2), Polynomial.C (Q k) * Polynomial.X ^ k with hΦ
+  have hΦtop : Φ.coeff (ℓ + 1) = 1 := by
+    rw [hΦ, coeff_sum_C_mul_X_pow Q (ℓ + 2) (ℓ + 1) (by omega), hQtop]
+  have hΦdeg_le : Φ.natDegree ≤ ℓ + 1 := by
+    rw [hΦ]
+    refine Polynomial.natDegree_sum_le_of_forall_le _ _ fun k hk => ?_
+    refine le_trans (Polynomial.natDegree_C_mul_le _ _) ?_
+    rw [Polynomial.natDegree_X_pow]
+    exact Nat.lt_succ_iff.mp (Finset.mem_range.mp hk)
+  have hΦdeg : Φ.natDegree = ℓ + 1 :=
+    le_antisymm hΦdeg_le
+      (Polynomial.le_natDegree_of_ne_zero (by rw [hΦtop]; exact one_ne_zero))
+  have hΦcoeff : ∀ k, evalAtJ (Φ.coeff k) = c k := by
+    intro k
+    by_cases hk : k < ℓ + 2
+    · rw [hΦ, coeff_sum_C_mul_X_pow Q (ℓ + 2) k hk, hQeval k]
+    · rw [Polynomial.coeff_eq_zero_of_natDegree_lt (by omega : Φ.natDegree < k), map_zero,
+        hc.c_eq_zero (by omega : ℓ + 1 < k)]
+  refine ⟨⟨Φ, ?_, ?_, ?_⟩, hΦcoeff⟩
+  · change Φ.coeff Φ.natDegree = 1
+    rw [hΦdeg]
+    exact hΦtop
+  · rw [hΦdeg, dedekindPsi_prime hℓ.out]
+  · rw [Polynomial.eval₂_eq_sum_range' evalAtJ (n := ℓ + 2) (by rw [hΦdeg]; omega) (jqN ℓ)]
+    have hterm : ∀ k ∈ Finset.range (ℓ + 2),
+        evalAtJ (Φ.coeff k) * (jqN ℓ) ^ k = c k * (jqN ℓ) ^ k := by
+      intro k _
+      rw [hΦcoeff k]
+    rw [Finset.sum_congr rfl hterm]
+    exact hc.sum_mul_jqN_pow_eq_zero
+
+end StrongExistence
+
+end PhiGen
+end ModularCurve
+
+end
+
+open _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_PhiGen_exists_modularPolynomialData_coeff_eq.ModularCurve
+  _root_.ModularCurve.PhiGen
+  _root_.P2MW.S_ModularCurve_PhiGen_exists_modularPolynomialData_coeff_eq.ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ}
+    {c : ℕ → LaurentSeries ℚ} (hc : PhiGenDescends ℓ ζ c) (hint : ∀ k, IntCoeffs (c k))
+    (hmem : ∀ k, c k ∈ Algebra.adjoin ℚ {jq}) :
+    ∃ data : ModularPolynomialData ℓ, ∀ k, evalAtJ (data.Φ.coeff k) = c k :=
+  ModularCurve.PhiGen.exists_modularPolynomialData_coeff_eq hc hint hmem
+
+end S_ModularCurve_PhiGen_exists_modularPolynomialData_coeff_eq
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_exists_modularPolynomialData_coeff_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.exists_modularPolynomialData_coeff_eq {K : Type*} [Field K]
+    [Algebra ℚ K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {c : ℕ → LaurentSeries ℚ}
+    (hc : PhiGenDescends ℓ ζ c) (hint : ∀ k, IntCoeffs (c k))
+    (hmem : ∀ k, c k ∈ Algebra.adjoin ℚ {jq}) :
+    ∃ data : ModularPolynomialData ℓ, ∀ k, evalAtJ (data.Φ.coeff k) = c k :=
+  solution hc hint hmem
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_exists_phiGenDescends.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_exists_phiGenDescends.lean
new file mode 100644
index 0000000000..781c91fb62
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_exists_phiGenDescends.lean
@@ -0,0 +1,378 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.exists_phiGenDescends
+(418bc88b-897a-537e-9a6f-9ce9729e3520) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a4a76579-0112-5bc2-a34d-1d33729bc6ef
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+public import Mathlib.FieldTheory.Galois.Basic
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Descent of the coefficients of Φ_ℓ to ℚ((q))
+
+Theorem statement: `ModularCurve.PhiGen.exists_phiGenDescends`
+(`418bc88b-897a-537e-9a6f-9ce9729e3520`), by Claude, 2026-09-05.
+
+Proof: submission `a4a76579-0112-5bc2-a34d-1d33729bc6ef`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field equipped with a $\mathbb{Q}$-algebra structure, let $\ell$ be a prime, and let
+$\zeta$ be a unit of $K$. Assume that $K$ is a finite Galois extension of $\mathbb{Q}$ and that the
+image of $\zeta$ in $K$ is a primitive $\ell$-th root of unity. The assertion is that there exists a
+family $c : \mathbb{N} \to \mathbb{Q}((q))$ of rational Laurent series with `PhiGenDescends ℓ ζ c`,
+that is: for every natural number $k$, the coefficient of $X^k$ in the monic polynomial $\prod_{i :
+\mathrm{Fin}(\ell+1)} (X - \mathrm{conj}\,\ell\,\zeta\,i) \in K((t))[X]$, whose roots are the
+$\ell+1$ series $\mathrm{conj}\,\ell\,\zeta\,i = \mathrm{cosetSubst}\ \zeta\
+(\mathrm{cosetA}\,\ell\,i)\ (\mathrm{cosetB}\,\ell\,i)$ applied to the coefficientwise image in
+$K((t))$ of the series `jq`, is equal to the coefficientwise image under $\mathbb{Q} \to K$ of
+$\mathrm{qExpand}\ \mathbb{Q}\ \ell\ (c_k)$, the series obtained from $c_k$ by multiplying all
+exponents by $\ell$. Thus each coefficient of the product lies in the image of $\mathbb{Q}((q))$
+under the substitution $q \mapsto t^{\ell}$ followed by base change to $K$; the family $c$ itself is
+only asserted to exist, with no normalisation or uniqueness claim.
+
+This is the existence half of the construction of the modular polynomial $\Phi_\ell(j, Y)$ from the
+$\ell+1$ conjugate $q$-expansions: it records simultaneously that the elementary symmetric functions
+of the conjugates are series in $t^{\ell}$ and that they have rational coefficients. It feeds the
+assembly of the modular polynomial data for $X_0(\ell)$, in particular
+[`ModularCurve.exists_modularPolynomialData_evalSymm`]
+(thm.html#ModularCurve.exists_modularPolynomialData_evalSymm),
+[`ModularCurve.ModularPolynomialData.weighted_support_le`]
+(thm.html#ModularCurve.ModularPolynomialData.weighted_support_le)
+and [`ModularCurve.PhiGen.splits_of_prime`](thm.html#ModularCurve.PhiGen.splits_of_prime).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_exists_phiGenDescends.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_exists_phiGenDescends
+
+noncomputable section
+
+open PowerSeries HahnSeries Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd jq qTwist \
+  qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap coeffMap_coeff coeffEmb \
+  coeffEmb_coeff coeffMap_coeffEmb coeffMap_qExpand"
+p2m_open "ModularCurve"
+
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd PhiGenDescends"
+p2m_open "ModularCurve.PhiGen"
+
+section PermLemma
+
+variable {K : Type*} [Field K] {ℓ : ℕ} {conj : Fin (ℓ + 1) → LaurentSeries K}
+
+private theorem map_phiProd_of_perm (F : LaurentSeries K →+* LaurentSeries K)
+    (e : Fin ℓ ≃ Fin ℓ) (h0 : F (conj 0) = conj 0)
+    (hS : ∀ b : Fin ℓ, F (conj b.succ) = conj (e b).succ) :
+    (phiProd ℓ conj).map F = phiProd ℓ conj := by
+  rw [phiProd, Polynomial.map_prod]
+  simp only [Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C]
+  rw [Fin.prod_univ_succ, Fin.prod_univ_succ, h0]
+  congr 1
+  calc ∏ b : Fin ℓ, (Polynomial.X - Polynomial.C (F (conj b.succ)))
+      = ∏ b : Fin ℓ, (Polynomial.X - Polynomial.C (conj (e b).succ)) := by
+        refine Finset.prod_congr rfl fun b _ => ?_
+        rw [hS b]
+    _ = ∏ b : Fin ℓ, (Polynomial.X - Polynomial.C (conj b.succ)) :=
+        e.prod_comp fun b => Polynomial.X - Polynomial.C (conj b.succ)
+
+private theorem map_phiProd_coeff_of_perm (F : LaurentSeries K →+* LaurentSeries K)
+    (e : Fin ℓ ≃ Fin ℓ) (h0 : F (conj 0) = conj 0)
+    (hS : ∀ b : Fin ℓ, F (conj b.succ) = conj (e b).succ) (k : ℕ) :
+    F ((phiProd ℓ conj).coeff k) = (phiProd ℓ conj).coeff k := by
+  conv_rhs => rw [← map_phiProd_of_perm F e h0 hS]
+  rw [Polynomial.coeff_map]
+
+end PermLemma
+
+section TwistRoot
+
+variable {K : Type*} [Field K] {ℓ : ℕ} {ζ : Kˣ}
+
+private theorem zeta_pow_card_eq_one (hζ : IsPrimitiveRoot (ζ : K) ℓ) : ζ ^ ℓ = 1 := by
+  refine Units.ext ?_
+  rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one]
+
+private theorem zeta_pow_mod (hζ : IsPrimitiveRoot (ζ : K) ℓ) (n : ℕ) :
+    ζ ^ (n % ℓ) = ζ ^ n :=
+  (pow_eq_pow_mod n (zeta_pow_card_eq_one hζ)).symm
+
+end TwistRoot
+
+section TwistConj
+
+variable {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+  {conj : Fin (ℓ + 1) → LaurentSeries K} {ζ : Kˣ} {J : LaurentSeries K}
+
+private theorem qTwist_conj_zero (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J) : qTwist ζ (conj 0) = conj 0 := by
+  rw [hconj0, qTwist_qExpand]
+  congr 1
+  rw [zpow_natCast, pow_mul, zeta_pow_card_eq_one hζ, one_pow, qTwist_one_apply]
+
+private theorem qTwist_conj_succ (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J) (b : Fin ℓ) :
+    qTwist ζ (conj b.succ) = conj ((Equiv.addRight (1 : Fin ℓ)) b).succ := by
+  rw [hconjS b, hconjS ((Equiv.addRight (1 : Fin ℓ)) b), qTwist_qTwist]
+  congr 1
+  simp only [Equiv.coe_addRight]
+  have h1 : ((1 : Fin ℓ) : ℕ) = 1 := by
+    rw [Fin.val_one']
+    exact Nat.mod_eq_of_lt hℓ.out.one_lt
+  rw [Fin.val_add, h1, zeta_pow_mod hζ ((b : ℕ) + 1), pow_succ, mul_comm ζ (ζ ^ (b : ℕ))]
+
+private theorem qTwist_phiProd_coeff (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J) (k : ℕ) :
+    qTwist ζ ((phiProd ℓ conj).coeff k) = (phiProd ℓ conj).coeff k :=
+  map_phiProd_coeff_of_perm (qTwist ζ) (Equiv.addRight (1 : Fin ℓ))
+    (qTwist_conj_zero hζ hconj0) (qTwist_conj_succ hζ hconjS) k
+
+end TwistConj
+
+section SupportCollapse
+
+variable {K : Type*} [Field K] {ℓ : ℕ} {ζ : Kˣ}
+
+private theorem coeff_eq_zero_of_qTwist_eq (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    {f : LaurentSeries K} (hf : qTwist ζ f = f) {m : ℤ} (hm : ¬ (ℓ : ℤ) ∣ m) :
+    f.coeff m = 0 := by
+  have h := congrArg (fun g => HahnSeries.coeff g m) hf
+  simp only [qTwist_coeff] at h
+  by_contra hc
+  apply hm
+  rw [← hζ.zpow_eq_one_iff_dvd]
+  have hunit : ((ζ ^ m : Kˣ) : K) = (ζ : K) ^ m := Units.val_zpow_eq_zpow_val ζ m
+  have hzero : (((ζ ^ m : Kˣ) : K) - 1) * f.coeff m = 0 := by
+    rw [sub_mul, one_mul, h, sub_self]
+  rcases mul_eq_zero.mp hzero with h1 | h1
+  · rw [hunit] at h1
+    linear_combination h1
+  · exact absurd h1 hc
+
+end SupportCollapse
+
+section Contract
+
+variable {K : Type*} [Field K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)]
+
+private def qContract (f : LaurentSeries K) : LaurentSeries K where
+  coeff m := f.coeff ((ℓ : ℤ) * m)
+  isPWO_support' := by
+    have hsub : (Function.support fun m : ℤ => f.coeff ((ℓ : ℤ) * m)) ⊆
+        (fun k : ℤ => k / (ℓ : ℤ)) '' f.support := by
+      intro m hm
+      refine ⟨(ℓ : ℤ) * m, hm, ?_⟩
+      exact Int.mul_ediv_cancel_left m (Nat.cast_ne_zero.mpr hℓ.out.ne_zero)
+    exact (f.isPWO_support'.image_of_monotone fun a b hab =>
+      Int.ediv_le_ediv (Int.natCast_pos.mpr hℓ.out.pos) hab).mono hsub
+
+@[scoped simp]
+private theorem qContract_coeff (f : LaurentSeries K) (m : ℤ) :
+    (qContract ℓ f).coeff m = f.coeff ((ℓ : ℤ) * m) := rfl
+
+variable {ℓ}
+
+private theorem qExpand_qContract {f : LaurentSeries K}
+    (hf : ∀ m : ℤ, ¬ (ℓ : ℤ) ∣ m → f.coeff m = 0) :
+    qExpand K ℓ (qContract ℓ f) = f := by
+  ext k
+  by_cases hk : (ℓ : ℤ) ∣ k
+  · obtain ⟨m, rfl⟩ := hk
+    rw [qExpand_coeff_mul, qContract_coeff]
+  · rw [qExpand_coeff_of_not_dvd ℓ _ hk, hf k hk]
+
+private theorem mem_range_qExpand_of_qTwist_eq {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    {f : LaurentSeries K} (hf : qTwist ζ f = f) : f ∈ Set.range (qExpand K ℓ) :=
+  ⟨qContract ℓ f, qExpand_qContract fun _ hm => coeff_eq_zero_of_qTwist_eq hζ hf hm⟩
+
+end Contract
+
+section RangeDescent
+
+variable {K : Type*} [Field K]
+
+theorem phiProd_coeff_mem_range_qExpand (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+    (J : LaurentSeries K) (conj : Fin (ℓ + 1) → LaurentSeries K)
+    (hζ : IsPrimitiveRoot (ζ : K) ℓ) (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J) (k : ℕ) :
+    (phiProd ℓ conj).coeff k ∈ Set.range (qExpand K ℓ) :=
+  mem_range_qExpand_of_qTwist_eq hζ (qTwist_phiProd_coeff hζ hconj0 hconjS k)
+
+end RangeDescent
+
+section GaloisMap
+
+variable {R S : Type*} [CommRing R] [CommRing S]
+
+private theorem coeffMap_qTwist (σ : R →+* S) (u : Rˣ) (v : Sˣ) (huv : (v : S) = σ (u : R))
+    (f : LaurentSeries R) : coeffMap σ (qTwist u f) = qTwist v (coeffMap σ f) := by
+  have hmap : Units.map (σ : R →* S) u = v :=
+    Units.ext (by rw [Units.coe_map, huv]; rfl)
+  ext k
+  rw [coeffMap_coeff, qTwist_coeff, qTwist_coeff, coeffMap_coeff, map_mul]
+  congr 1
+  rw [← hmap, ← map_zpow, Units.coe_map]
+  rfl
+
+end GaloisMap
+
+section GaloisCoeff
+
+variable {K : Type*} [Field K]
+
+theorem coeffMap_phiProd_coeff (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+    (J : LaurentSeries K) (conj : Fin (ℓ + 1) → LaurentSeries K) (σ : K →+* K)
+    (hσJ : coeffMap σ J = J) (e : Fin ℓ ≃ Fin ℓ)
+    (hσζ : ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e b : Fin ℓ) : ℕ))
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J) (k : ℕ) :
+    coeffMap σ ((phiProd ℓ conj).coeff k) = (phiProd ℓ conj).coeff k := by
+  refine map_phiProd_coeff_of_perm (coeffMap σ) e ?_ ?_ k
+  · rw [hconj0, coeffMap_qExpand, hσJ]
+  · intro b
+    rw [hconjS b, hconjS (e b),
+      coeffMap_qTwist σ (ζ ^ (b : ℕ)) (ζ ^ ((e b : Fin ℓ) : ℕ))
+        (by rw [Units.val_pow_eq_pow_val, Units.val_pow_eq_pow_val, hσζ b]),
+      hσJ]
+
+end GaloisCoeff
+
+section FixedField
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+theorem mem_range_coeffEmb_of_forall_coeffMap_eq
+    (hfix : ∀ c : K, (∀ σ : K ≃ₐ[ℚ] K, σ c = c) → ∃ r : ℚ, algebraMap ℚ K r = c)
+    {f : LaurentSeries K} (hf : ∀ σ : K ≃ₐ[ℚ] K, coeffMap (σ : K →+* K) f = f) :
+    f ∈ Set.range (coeffEmb K) := by
+  have hcoeff : ∀ m : ℤ, ∃ r : ℚ, algebraMap ℚ K r = f.coeff m := fun m =>
+    hfix (f.coeff m) fun σ => by
+      have hcongr := congrArg (fun g => HahnSeries.coeff g m) (hf σ)
+      simpa using hcongr
+  choose r hr using hcoeff
+  refine ⟨⟨r, ?_⟩, ?_⟩
+  · refine f.isPWO_support'.mono fun m hm => ?_
+    simp only [Function.mem_support] at hm ⊢
+    intro h
+    exact hm (FaithfulSMul.algebraMap_injective ℚ K (by rw [hr m, h, map_zero]))
+  · ext m
+    exact hr m
+
+end FixedField
+
+section GaloisPerm
+
+variable {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ}
+
+theorem exists_galoisPerm (hζ : IsPrimitiveRoot (ζ : K) ℓ) (σ : K →+* K) :
+    ∃ e : Fin ℓ ≃ Fin ℓ,
+      ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e b : Fin ℓ) : ℕ) := by
+  have hσζ : (σ (ζ : K)) ^ ℓ = 1 := by
+    rw [← map_pow, hζ.pow_eq_one, map_one]
+  obtain ⟨a, -, ha⟩ := hζ.eq_pow_of_pow_eq_one hσζ
+  set e₀ : Fin ℓ → Fin ℓ := fun b => ⟨(a * (b : ℕ)) % ℓ, Nat.mod_lt _ hℓ.out.pos⟩
+  have hkey : ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e₀ b : Fin ℓ) : ℕ) := by
+    intro b
+    change σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((a * (b : ℕ)) % ℓ)
+    rw [map_pow, ← ha, ← pow_mul]
+    exact pow_eq_pow_mod _ hζ.pow_eq_one
+  have hinj : Function.Injective e₀ := by
+    intro b b' hbb'
+    have h1 : σ ((ζ : K) ^ (b : ℕ)) = σ ((ζ : K) ^ ((b' : Fin ℓ) : ℕ)) := by
+      rw [hkey b, hkey b', hbb']
+    exact Fin.ext (hζ.pow_inj b.isLt b'.isLt (σ.injective h1))
+  exact ⟨Equiv.ofBijective e₀ (Finite.injective_iff_bijective.mp hinj), hkey⟩
+
+end GaloisPerm
+
+section Descent
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+theorem mem_range_coeffEmb_qExpand_of_mem_inter {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+    {f : LaurentSeries K} (h1 : f ∈ Set.range (ModularCurve.qExpand K ℓ))
+    (h2 : f ∈ Set.range (coeffEmb K)) :
+    ∃ g : LaurentSeries ℚ, f = coeffEmb K (ModularCurve.qExpand ℚ ℓ g) := by
+  obtain ⟨h, hh⟩ := h2
+  have hsupp : ∀ m : ℤ, ¬ (ℓ : ℤ) ∣ m → h.coeff m = 0 := by
+    intro m hm
+    obtain ⟨g, hg⟩ := h1
+    refine FaithfulSMul.algebraMap_injective ℚ K ?_
+    rw [map_zero, ← coeffEmb_coeff, hh, ← hg, qExpand_coeff_of_not_dvd ℓ g hm]
+  refine ⟨qContract ℓ h, ?_⟩
+  rw [qExpand_qContract hsupp]
+  exact hh.symm
+
+private theorem exists_phiGenDescends (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+    [IsGalois ℚ K] [FiniteDimensional ℚ K] (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    ∃ c : ℕ → LaurentSeries ℚ, PhiGenDescends ℓ ζ c := by
+  have hmem : ∀ k : ℕ, ∃ g : LaurentSeries ℚ,
+      (phiProd ℓ (conj ℓ ζ)).coeff k = coeffEmb K (ModularCurve.qExpand ℚ ℓ g) := by
+    intro k
+    refine mem_range_coeffEmb_qExpand_of_mem_inter ?_ ?_
+    · exact phiProd_coeff_mem_range_qExpand ℓ ζ (coeffEmb K jq) (conj ℓ ζ)
+        hζ (conj_zero ℓ ζ) (conj_succ ℓ ζ) k
+    · refine mem_range_coeffEmb_of_forall_coeffMap_eq
+        (fun x hx => (IsGalois.mem_range_algebraMap_iff_fixed x).mpr hx) ?_
+      intro σ
+      obtain ⟨e, he⟩ := exists_galoisPerm hζ (σ : K →+* K)
+      exact coeffMap_phiProd_coeff ℓ ζ (coeffEmb K jq) (conj ℓ ζ) (σ : K →+* K)
+        (coeffMap_coeffEmb σ jq) e he (conj_zero ℓ ζ) (conj_succ ℓ ζ) k
+  choose c hc using hmem
+  exact ⟨c, hc⟩
+
+end Descent
+
+end PhiGen
+end ModularCurve
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_PhiGen_exists_phiGenDescends.ModularCurve
+  _root_.ModularCurve.PhiGen
+  _root_.P2MW.S_ModularCurve_PhiGen_exists_phiGenDescends.ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+    [IsGalois ℚ K] [FiniteDimensional ℚ K] (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    ∃ c : ℕ → LaurentSeries ℚ, PhiGenDescends ℓ ζ c :=
+  ModularCurve.PhiGen.exists_phiGenDescends ℓ ζ hζ
+
+end S_ModularCurve_PhiGen_exists_phiGenDescends
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_exists_phiGenDescends (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.exists_phiGenDescends {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ)
+    [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) [IsGalois ℚ K] [FiniteDimensional ℚ K]
+    (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    ∃ c : ℕ → LaurentSeries ℚ, PhiGenDescends ℓ ζ c :=
+  solution ℓ ζ hζ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_mem_adjoin_jq_of_phiGenDescends.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_mem_adjoin_jq_of_phiGenDescends.lean
new file mode 100644
index 0000000000..a70cf38ad0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_mem_adjoin_jq_of_phiGenDescends.lean
@@ -0,0 +1,126 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.mem_adjoin_jq_of_phiGenDescends
+(a4ed865b-516c-5b55-8d36-8079c307dc26) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1ee80e3a-fc52-5318-8dcc-0ec47b387159
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+public import Mathlib.NumberTheory.Cyclotomic.Basic
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+import Mathlib.NumberTheory.Cyclotomic.PrimitiveRoots
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import Mathlib.NumberTheory.ModularForms.EisensteinSeries.Basic
+import Mathlib.NumberTheory.ModularForms.Discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_PhiGenDescends_hasSum_cosetPoly_coeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_mem_adjoin_jq_of_hasSum_of_slash_invariant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_cosetPoly_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_E4_cube_div_discriminant_smul
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Coefficients of the generic level-ℓ modular polynomial lie in ℚ[j]
+
+Theorem statement: `ModularCurve.PhiGen.mem_adjoin_jq_of_phiGenDescends`
+(`a4ed865b-516c-5b55-8d36-8079c307dc26`), by Claude, 2026-09-05.
+
+Proof: submission `1ee80e3a-fc52-5318-8dcc-0ec47b387159`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a prime, let $\zeta$ be a unit of the cyclotomic field `CyclotomicField ℓ ℚ` whose
+underlying element is a primitive $\ell$-th root of unity, and let $c : \mathbb{N} \to$
+`LaurentSeries ℚ` be a family of rational Laurent series. Assume `PhiGenDescends ℓ ζ c`: for every
+$k$, the $k$-th coefficient of the monic polynomial $\prod_{i : \mathrm{Fin}(\ell+1)} (X -
+C(\mathrm{conj}\ \ell\ \zeta\ i))$ over the Laurent series of the cyclotomic field, whose roots are
+the formal conjugates `conj ℓ ζ i` obtained by applying the substitution `cosetSubst ζ (cosetA ℓ i)
+(cosetB ℓ i)` to the coefficientwise image `coeffEmb` of the formal $q$-expansion `jq`, equals the
+coefficientwise image under `coeffEmb` of `qExpand ℚ ℓ (c k)`, the series $c_k$ with its exponents
+multiplied by $\ell$. Then, for every natural number $k$, the series $c_k$ lies in `Algebra.adjoin ℚ
+{jq}`, the $\mathbb{Q}$-subalgebra of `LaurentSeries ℚ` generated by `jq` $=
+q^{-1}\cdot$`ofPowerSeries jNumQ`. Thus each solution of the descent equations is a polynomial in
+$j$ with rational coefficients.
+
+This is the analytic leg of the construction of the modular polynomial $\Phi_\ell$: it identifies
+the coefficients of $\prod_i (X - j\circ\beta_i)$, taken over the $\ell+1$ Hecke cosets of level
+$\ell$, as elements of $\mathbb{Q}[j]$, so that $\Phi_\ell(X,Y) \in \mathbb{Q}[X,Y]$ with
+$\Phi_\ell(X,j) = \prod_i (X - j\circ\beta_i)$. It is used in the construction of the modular
+polynomial data for $X_0(\ell)$ and in the statements about splitting and about the weighted support
+of that data; integrality, symmetry and the degree bounds are established separately.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_mem_adjoin_jq_of_phiGenDescends.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_mem_adjoin_jq_of_phiGenDescends
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology Function Polynomial
+open scoped MatrixGroups
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jq PhiGen.PhiGenDescends PhiGen.PhiGenDescends.hasSum_cosetPoly_coeff \
+  mem_adjoin_jq_of_hasSum_of_slash_invariant cosetPoly_smul E4_cube_div_discriminant_smul"
+p2m_open "ModularCurve"
+
+section JT
+
+def jt (τ : ℍ) : ℂ := ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ
+
+lemma jt_smul (γ : SL(2, ℤ)) (τ : ℍ) : jt (γ • τ) = jt τ :=
+  ModularCurve.E4_cube_div_discriminant_smul γ τ
+
+end JT
+
+end ModularCurve
+
+open _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_PhiGen_mem_adjoin_jq_of_phiGenDescends.ModularCurve ModularCurve.PhiGen
+  in
+theorem solution (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : (CyclotomicField ℓ ℚ)ˣ)
+    (hζ : IsPrimitiveRoot (ζ : CyclotomicField ℓ ℚ) ℓ) (c : ℕ → LaurentSeries ℚ)
+    (hc : PhiGenDescends ℓ ζ c) (k : ℕ) :
+    c k ∈ Algebra.adjoin ℚ {jq} := by
+  refine ModularCurve.mem_adjoin_jq_of_hasSum_of_slash_invariant (c k) _
+    (ModularCurve.PhiGen.PhiGenDescends.hasSum_cosetPoly_coeff ℓ ζ hζ c hc k) fun γ τ => ?_
+  exact congrArg (fun p : Polynomial ℂ => p.coeff k)
+    (ModularCurve.cosetPoly_smul ℓ hℓ.out ModularCurve.jt ModularCurve.jt_smul γ τ)
+
+end
+
+end S_ModularCurve_PhiGen_mem_adjoin_jq_of_phiGenDescends
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_mem_adjoin_jq_of_phiGenDescends (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.mem_adjoin_jq_of_phiGenDescends (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)]
+    (ζ : (CyclotomicField ℓ ℚ)ˣ) (hζ : IsPrimitiveRoot (ζ : CyclotomicField ℓ ℚ) ℓ)
+    (c : ℕ → LaurentSeries ℚ) (hc : PhiGenDescends ℓ ζ c) (k : ℕ) :
+    c k ∈ Algebra.adjoin ℚ {jq} :=
+  solution ℓ ζ hζ c hc k
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_mem_range_coeffEmb_of_forall_coeffMap_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_mem_range_coeffEmb_of_forall_coeffMap_eq.lean
new file mode 100644
index 0000000000..9eff4a9d5b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_mem_range_coeffEmb_of_forall_coeffMap_eq.lean
@@ -0,0 +1,376 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.mem_range_coeffEmb_of_forall_coeffMap_eq
+(c8517c1a-d0d4-54f2-ab48-a9e7e5266f6b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5b57bc84-4d8e-5d56-86fb-e77445909b00
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.FieldTheory.Galois.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Coefficientwise Galois descent for Laurent series
+
+Theorem statement: `ModularCurve.PhiGen.mem_range_coeffEmb_of_forall_coeffMap_eq`
+(`c8517c1a-d0d4-54f2-ab48-a9e7e5266f6b`), by Claude, 2026-09-05.
+
+Proof: submission `5b57bc84-4d8e-5d56-86fb-e77445909b00`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field equipped with a $\mathbb{Q}$-algebra structure, and assume the descent hypothesis
+`hfix`: every $c \in K$ fixed by all $\mathbb{Q}$-algebra automorphisms $\sigma : K
+\simeq_{\mathbb{Q}} K$ of $K$ lies in the image of the structure map $\mathbb{Q} \to K$, i.e. $c =
+\mathrm{algebraMap}\,\mathbb{Q}\,K\,(r)$ for some rational $r$. Let $f$ be a Laurent series over $K$
+and suppose that for every such automorphism $\sigma$ one has $\mathrm{coeffMap}\,\sigma\,(f) = f$,
+where $\mathrm{coeffMap}\,\varphi$ denotes the ring homomorphism on Laurent series induced by
+applying a ring homomorphism $\varphi$ to each coefficient (the underlying map being
+`HahnSeries.map`); thus $f$ is assumed fixed coefficientwise by the whole automorphism group of $K$
+over $\mathbb{Q}$. The conclusion is that $f$ belongs to the range of `coeffEmb K`, the
+coefficientwise extension of scalars $\mathrm{coeffMap}(\mathrm{algebraMap}\,\mathbb{Q}\,K)$ from
+Laurent series over $\mathbb{Q}$ to Laurent series over $K$: some Laurent series with rational
+coefficients has image $f$.
+
+This is Galois descent for Laurent series, applied coefficient by coefficient: the hypothesis `hfix`
+(valid, for instance, when $K/\mathbb{Q}$ is finite Galois) transfers fixed-field information from
+$K$ to the ring of Laurent series over $K$. It is used to recognise $q$-expansions of modular forms
+and modular units as having rational coefficients, and is cited in the construction of rational
+families and embedding bases, and in identifying Fricke involution images of $\Gamma_0$-invariant
+expansions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_mem_range_coeffEmb_of_forall_coeffMap_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_mem_range_coeffEmb_of_forall_coeffMap_eq
+
+noncomputable section
+
+open PowerSeries HahnSeries Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd jq qTwist \
+  qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap coeffMap_coeff coeffEmb \
+  coeffEmb_coeff coeffMap_coeffEmb coeffMap_qExpand"
+p2m_open "ModularCurve"
+
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd PhiGenDescends"
+p2m_open "ModularCurve.PhiGen"
+
+section PermLemma
+
+variable {K : Type*} [Field K] {ℓ : ℕ} {conj : Fin (ℓ + 1) → LaurentSeries K}
+
+private theorem map_phiProd_of_perm (F : LaurentSeries K →+* LaurentSeries K)
+    (e : Fin ℓ ≃ Fin ℓ) (h0 : F (conj 0) = conj 0)
+    (hS : ∀ b : Fin ℓ, F (conj b.succ) = conj (e b).succ) :
+    (phiProd ℓ conj).map F = phiProd ℓ conj := by
+  rw [phiProd, Polynomial.map_prod]
+  simp only [Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C]
+  rw [Fin.prod_univ_succ, Fin.prod_univ_succ, h0]
+  congr 1
+  calc ∏ b : Fin ℓ, (Polynomial.X - Polynomial.C (F (conj b.succ)))
+      = ∏ b : Fin ℓ, (Polynomial.X - Polynomial.C (conj (e b).succ)) := by
+        refine Finset.prod_congr rfl fun b _ => ?_
+        rw [hS b]
+    _ = ∏ b : Fin ℓ, (Polynomial.X - Polynomial.C (conj b.succ)) :=
+        e.prod_comp fun b => Polynomial.X - Polynomial.C (conj b.succ)
+
+private theorem map_phiProd_coeff_of_perm (F : LaurentSeries K →+* LaurentSeries K)
+    (e : Fin ℓ ≃ Fin ℓ) (h0 : F (conj 0) = conj 0)
+    (hS : ∀ b : Fin ℓ, F (conj b.succ) = conj (e b).succ) (k : ℕ) :
+    F ((phiProd ℓ conj).coeff k) = (phiProd ℓ conj).coeff k := by
+  conv_rhs => rw [← map_phiProd_of_perm F e h0 hS]
+  rw [Polynomial.coeff_map]
+
+end PermLemma
+
+section TwistRoot
+
+variable {K : Type*} [Field K] {ℓ : ℕ} {ζ : Kˣ}
+
+private theorem zeta_pow_card_eq_one (hζ : IsPrimitiveRoot (ζ : K) ℓ) : ζ ^ ℓ = 1 := by
+  refine Units.ext ?_
+  rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one]
+
+private theorem zeta_pow_mod (hζ : IsPrimitiveRoot (ζ : K) ℓ) (n : ℕ) :
+    ζ ^ (n % ℓ) = ζ ^ n :=
+  (pow_eq_pow_mod n (zeta_pow_card_eq_one hζ)).symm
+
+end TwistRoot
+
+section TwistConj
+
+variable {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+  {conj : Fin (ℓ + 1) → LaurentSeries K} {ζ : Kˣ} {J : LaurentSeries K}
+
+private theorem qTwist_conj_zero (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J) : qTwist ζ (conj 0) = conj 0 := by
+  rw [hconj0, qTwist_qExpand]
+  congr 1
+  rw [zpow_natCast, pow_mul, zeta_pow_card_eq_one hζ, one_pow, qTwist_one_apply]
+
+private theorem qTwist_conj_succ (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J) (b : Fin ℓ) :
+    qTwist ζ (conj b.succ) = conj ((Equiv.addRight (1 : Fin ℓ)) b).succ := by
+  rw [hconjS b, hconjS ((Equiv.addRight (1 : Fin ℓ)) b), qTwist_qTwist]
+  congr 1
+  simp only [Equiv.coe_addRight]
+  have h1 : ((1 : Fin ℓ) : ℕ) = 1 := by
+    rw [Fin.val_one']
+    exact Nat.mod_eq_of_lt hℓ.out.one_lt
+  rw [Fin.val_add, h1, zeta_pow_mod hζ ((b : ℕ) + 1), pow_succ, mul_comm ζ (ζ ^ (b : ℕ))]
+
+private theorem qTwist_phiProd_coeff (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J) (k : ℕ) :
+    qTwist ζ ((phiProd ℓ conj).coeff k) = (phiProd ℓ conj).coeff k :=
+  map_phiProd_coeff_of_perm (qTwist ζ) (Equiv.addRight (1 : Fin ℓ))
+    (qTwist_conj_zero hζ hconj0) (qTwist_conj_succ hζ hconjS) k
+
+end TwistConj
+
+section SupportCollapse
+
+variable {K : Type*} [Field K] {ℓ : ℕ} {ζ : Kˣ}
+
+private theorem coeff_eq_zero_of_qTwist_eq (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    {f : LaurentSeries K} (hf : qTwist ζ f = f) {m : ℤ} (hm : ¬ (ℓ : ℤ) ∣ m) :
+    f.coeff m = 0 := by
+  have h := congrArg (fun g => HahnSeries.coeff g m) hf
+  simp only [qTwist_coeff] at h
+  by_contra hc
+  apply hm
+  rw [← hζ.zpow_eq_one_iff_dvd]
+  have hunit : ((ζ ^ m : Kˣ) : K) = (ζ : K) ^ m := Units.val_zpow_eq_zpow_val ζ m
+  have hzero : (((ζ ^ m : Kˣ) : K) - 1) * f.coeff m = 0 := by
+    rw [sub_mul, one_mul, h, sub_self]
+  rcases mul_eq_zero.mp hzero with h1 | h1
+  · rw [hunit] at h1
+    linear_combination h1
+  · exact absurd h1 hc
+
+end SupportCollapse
+
+section Contract
+
+variable {K : Type*} [Field K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)]
+
+private def qContract (f : LaurentSeries K) : LaurentSeries K where
+  coeff m := f.coeff ((ℓ : ℤ) * m)
+  isPWO_support' := by
+    have hsub : (Function.support fun m : ℤ => f.coeff ((ℓ : ℤ) * m)) ⊆
+        (fun k : ℤ => k / (ℓ : ℤ)) '' f.support := by
+      intro m hm
+      refine ⟨(ℓ : ℤ) * m, hm, ?_⟩
+      exact Int.mul_ediv_cancel_left m (Nat.cast_ne_zero.mpr hℓ.out.ne_zero)
+    exact (f.isPWO_support'.image_of_monotone fun a b hab =>
+      Int.ediv_le_ediv (Int.natCast_pos.mpr hℓ.out.pos) hab).mono hsub
+
+@[scoped simp]
+private theorem qContract_coeff (f : LaurentSeries K) (m : ℤ) :
+    (qContract ℓ f).coeff m = f.coeff ((ℓ : ℤ) * m) := rfl
+
+variable {ℓ}
+
+private theorem qExpand_qContract {f : LaurentSeries K}
+    (hf : ∀ m : ℤ, ¬ (ℓ : ℤ) ∣ m → f.coeff m = 0) :
+    qExpand K ℓ (qContract ℓ f) = f := by
+  ext k
+  by_cases hk : (ℓ : ℤ) ∣ k
+  · obtain ⟨m, rfl⟩ := hk
+    rw [qExpand_coeff_mul, qContract_coeff]
+  · rw [qExpand_coeff_of_not_dvd ℓ _ hk, hf k hk]
+
+private theorem mem_range_qExpand_of_qTwist_eq {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    {f : LaurentSeries K} (hf : qTwist ζ f = f) : f ∈ Set.range (qExpand K ℓ) :=
+  ⟨qContract ℓ f, qExpand_qContract fun _ hm => coeff_eq_zero_of_qTwist_eq hζ hf hm⟩
+
+end Contract
+
+section RangeDescent
+
+variable {K : Type*} [Field K]
+
+theorem phiProd_coeff_mem_range_qExpand (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+    (J : LaurentSeries K) (conj : Fin (ℓ + 1) → LaurentSeries K)
+    (hζ : IsPrimitiveRoot (ζ : K) ℓ) (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J) (k : ℕ) :
+    (phiProd ℓ conj).coeff k ∈ Set.range (qExpand K ℓ) :=
+  mem_range_qExpand_of_qTwist_eq hζ (qTwist_phiProd_coeff hζ hconj0 hconjS k)
+
+end RangeDescent
+
+section GaloisMap
+
+variable {R S : Type*} [CommRing R] [CommRing S]
+
+private theorem coeffMap_qTwist (σ : R →+* S) (u : Rˣ) (v : Sˣ) (huv : (v : S) = σ (u : R))
+    (f : LaurentSeries R) : coeffMap σ (qTwist u f) = qTwist v (coeffMap σ f) := by
+  have hmap : Units.map (σ : R →* S) u = v :=
+    Units.ext (by rw [Units.coe_map, huv]; rfl)
+  ext k
+  rw [coeffMap_coeff, qTwist_coeff, qTwist_coeff, coeffMap_coeff, map_mul]
+  congr 1
+  rw [← hmap, ← map_zpow, Units.coe_map]
+  rfl
+
+end GaloisMap
+
+section GaloisCoeff
+
+variable {K : Type*} [Field K]
+
+theorem coeffMap_phiProd_coeff (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+    (J : LaurentSeries K) (conj : Fin (ℓ + 1) → LaurentSeries K) (σ : K →+* K)
+    (hσJ : coeffMap σ J = J) (e : Fin ℓ ≃ Fin ℓ)
+    (hσζ : ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e b : Fin ℓ) : ℕ))
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J) (k : ℕ) :
+    coeffMap σ ((phiProd ℓ conj).coeff k) = (phiProd ℓ conj).coeff k := by
+  refine map_phiProd_coeff_of_perm (coeffMap σ) e ?_ ?_ k
+  · rw [hconj0, coeffMap_qExpand, hσJ]
+  · intro b
+    rw [hconjS b, hconjS (e b),
+      coeffMap_qTwist σ (ζ ^ (b : ℕ)) (ζ ^ ((e b : Fin ℓ) : ℕ))
+        (by rw [Units.val_pow_eq_pow_val, Units.val_pow_eq_pow_val, hσζ b]),
+      hσJ]
+
+end GaloisCoeff
+
+section FixedField
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem mem_range_coeffEmb_of_forall_coeffMap_eq
+    (hfix : ∀ c : K, (∀ σ : K ≃ₐ[ℚ] K, σ c = c) → ∃ r : ℚ, algebraMap ℚ K r = c)
+    {f : LaurentSeries K} (hf : ∀ σ : K ≃ₐ[ℚ] K, coeffMap (σ : K →+* K) f = f) :
+    f ∈ Set.range (coeffEmb K) := by
+  have hcoeff : ∀ m : ℤ, ∃ r : ℚ, algebraMap ℚ K r = f.coeff m := fun m =>
+    hfix (f.coeff m) fun σ => by
+      have hcongr := congrArg (fun g => HahnSeries.coeff g m) (hf σ)
+      simpa using hcongr
+  choose r hr using hcoeff
+  refine ⟨⟨r, ?_⟩, ?_⟩
+  · refine f.isPWO_support'.mono fun m hm => ?_
+    simp only [Function.mem_support] at hm ⊢
+    intro h
+    exact hm (FaithfulSMul.algebraMap_injective ℚ K (by rw [hr m, h, map_zero]))
+  · ext m
+    exact hr m
+
+end FixedField
+
+section GaloisPerm
+
+variable {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ}
+
+theorem exists_galoisPerm (hζ : IsPrimitiveRoot (ζ : K) ℓ) (σ : K →+* K) :
+    ∃ e : Fin ℓ ≃ Fin ℓ,
+      ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e b : Fin ℓ) : ℕ) := by
+  have hσζ : (σ (ζ : K)) ^ ℓ = 1 := by
+    rw [← map_pow, hζ.pow_eq_one, map_one]
+  obtain ⟨a, -, ha⟩ := hζ.eq_pow_of_pow_eq_one hσζ
+  set e₀ : Fin ℓ → Fin ℓ := fun b => ⟨(a * (b : ℕ)) % ℓ, Nat.mod_lt _ hℓ.out.pos⟩
+  have hkey : ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e₀ b : Fin ℓ) : ℕ) := by
+    intro b
+    change σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((a * (b : ℕ)) % ℓ)
+    rw [map_pow, ← ha, ← pow_mul]
+    exact pow_eq_pow_mod _ hζ.pow_eq_one
+  have hinj : Function.Injective e₀ := by
+    intro b b' hbb'
+    have h1 : σ ((ζ : K) ^ (b : ℕ)) = σ ((ζ : K) ^ ((b' : Fin ℓ) : ℕ)) := by
+      rw [hkey b, hkey b', hbb']
+    exact Fin.ext (hζ.pow_inj b.isLt b'.isLt (σ.injective h1))
+  exact ⟨Equiv.ofBijective e₀ (Finite.injective_iff_bijective.mp hinj), hkey⟩
+
+end GaloisPerm
+
+section Descent
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+theorem mem_range_coeffEmb_qExpand_of_mem_inter {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+    {f : LaurentSeries K} (h1 : f ∈ Set.range (ModularCurve.qExpand K ℓ))
+    (h2 : f ∈ Set.range (coeffEmb K)) :
+    ∃ g : LaurentSeries ℚ, f = coeffEmb K (ModularCurve.qExpand ℚ ℓ g) := by
+  obtain ⟨h, hh⟩ := h2
+  have hsupp : ∀ m : ℤ, ¬ (ℓ : ℤ) ∣ m → h.coeff m = 0 := by
+    intro m hm
+    obtain ⟨g, hg⟩ := h1
+    refine FaithfulSMul.algebraMap_injective ℚ K ?_
+    rw [map_zero, ← coeffEmb_coeff, hh, ← hg, qExpand_coeff_of_not_dvd ℓ g hm]
+  refine ⟨qContract ℓ h, ?_⟩
+  rw [qExpand_qContract hsupp]
+  exact hh.symm
+
+theorem exists_phiGenDescends (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+    [IsGalois ℚ K] [FiniteDimensional ℚ K] (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    ∃ c : ℕ → LaurentSeries ℚ, PhiGenDescends ℓ ζ c := by
+  have hmem : ∀ k : ℕ, ∃ g : LaurentSeries ℚ,
+      (phiProd ℓ (conj ℓ ζ)).coeff k = coeffEmb K (ModularCurve.qExpand ℚ ℓ g) := by
+    intro k
+    refine mem_range_coeffEmb_qExpand_of_mem_inter ?_ ?_
+    · exact phiProd_coeff_mem_range_qExpand ℓ ζ (coeffEmb K jq) (conj ℓ ζ)
+        hζ (conj_zero ℓ ζ) (conj_succ ℓ ζ) k
+    · refine mem_range_coeffEmb_of_forall_coeffMap_eq
+        (fun x hx => (IsGalois.mem_range_algebraMap_iff_fixed x).mpr hx) ?_
+      intro σ
+      obtain ⟨e, he⟩ := exists_galoisPerm hζ (σ : K →+* K)
+      exact coeffMap_phiProd_coeff ℓ ζ (coeffEmb K jq) (conj ℓ ζ) (σ : K →+* K)
+        (coeffMap_coeffEmb σ jq) e he (conj_zero ℓ ζ) (conj_succ ℓ ζ) k
+  choose c hc using hmem
+  exact ⟨c, hc⟩
+
+end Descent
+
+end PhiGen
+end ModularCurve
+end
+
+open _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_PhiGen_mem_range_coeffEmb_of_forall_coeffMap_eq.ModularCurve
+  _root_.ModularCurve.PhiGen
+  _root_.P2MW.S_ModularCurve_PhiGen_mem_range_coeffEmb_of_forall_coeffMap_eq.ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] [Algebra ℚ K]
+    (hfix : ∀ c : K, (∀ σ : K ≃ₐ[ℚ] K, σ c = c) → ∃ r : ℚ, algebraMap ℚ K r = c)
+    {f : LaurentSeries K} (hf : ∀ σ : K ≃ₐ[ℚ] K, coeffMap (σ : K →+* K) f = f) :
+    f ∈ Set.range (coeffEmb K) :=
+  ModularCurve.PhiGen.mem_range_coeffEmb_of_forall_coeffMap_eq hfix hf
+
+end S_ModularCurve_PhiGen_mem_range_coeffEmb_of_forall_coeffMap_eq
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_mem_range_coeffEmb_of_forall_coeffMap_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.mem_range_coeffEmb_of_forall_coeffMap_eq {K : Type*} [Field K]
+    [Algebra ℚ K] (hfix : ∀ c : K, (∀ σ : K ≃ₐ[ℚ] K, σ c = c) → ∃ r : ℚ, algebraMap ℚ K r = c)
+    {f : LaurentSeries K} (hf : ∀ σ : K ≃ₐ[ℚ] K, coeffMap (σ : K →+* K) f = f) :
+    f ∈ Set.range (coeffEmb K) :=
+  solution hfix hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_mem_range_coeffEmb_qExpand_of_mem_inter.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_mem_range_coeffEmb_qExpand_of_mem_inter.lean
new file mode 100644
index 0000000000..159b8aca0d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_mem_range_coeffEmb_qExpand_of_mem_inter.lean
@@ -0,0 +1,373 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.mem_range_coeffEmb_qExpand_of_mem_inter
+(2bcc2b0e-71b3-551c-bfc5-30f24d78b8e7) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 91597332-2d37-5dbd-94b3-cf4b3ea22d30
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.FieldTheory.Galois.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Joint descent for q-expansions with rational coefficients
+
+Theorem statement: `ModularCurve.PhiGen.mem_range_coeffEmb_qExpand_of_mem_inter`
+(`2bcc2b0e-71b3-551c-bfc5-30f24d78b8e7`), by Claude, 2026-09-05.
+
+Proof: submission `91597332-2d37-5dbd-94b3-cf4b3ea22d30`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field of characteristic zero, regarded as a $\mathbb{Q}$-algebra, let $\ell$ be a
+prime, and let $f$ be a Laurent series over $K$ (an element of `LaurentSeries K`, i.e. a Hahn series
+over $K$ with value group $\mathbb{Z}$). Two hypotheses are imposed on $f$. First, $f$ lies in the
+range of [`ModularCurve.qExpand K ℓ`](def/ModularCurve_X0.html#L25), the ring homomorphism that
+embeds the domain of exponents along multiplication by $\ell$ on $\mathbb{Z}$; that is, $f$ is
+obtained from some series over $K$ by the substitution $t \mapsto t^{\ell}$, so its support is
+contained in $\ell\mathbb{Z}$. Second, $f$ lies in the range of `coeffEmb K`, the ring homomorphism
+`LaurentSeries ℚ →+* LaurentSeries K` acting coefficientwise through the structure map $\mathbb{Q}
+\to K$; that is, all coefficients of $f$ lie in the image of $\mathbb{Q}$. The conclusion is that
+these two descents may be performed simultaneously: there exists a Laurent series $g$ over
+$\mathbb{Q}$ with $f =$ `coeffEmb K (ModularCurve.qExpand ℚ ℓ g)`.
+
+A compatibility statement between the substitution $t \mapsto t^{\ell}$ on Laurent series and
+coefficientwise base change from $\mathbb{Q}$, resting on the fact that `coeffMap` commutes with
+`qExpand`. It is used in the study of $q$-expansions of functions on $X_0(N)$, for instance in the
+integrality and Fricke involution arguments for modular units and for $j(q)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_mem_range_coeffEmb_qExpand_of_mem_inter.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_mem_range_coeffEmb_qExpand_of_mem_inter
+
+noncomputable section
+
+open PowerSeries HahnSeries Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd jq qTwist \
+  qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap coeffMap_coeff coeffEmb \
+  coeffEmb_coeff coeffMap_coeffEmb coeffMap_qExpand"
+p2m_open "ModularCurve"
+
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd PhiGenDescends"
+p2m_open "ModularCurve.PhiGen"
+
+section PermLemma
+
+variable {K : Type*} [Field K] {ℓ : ℕ} {conj : Fin (ℓ + 1) → LaurentSeries K}
+
+private theorem map_phiProd_of_perm (F : LaurentSeries K →+* LaurentSeries K)
+    (e : Fin ℓ ≃ Fin ℓ) (h0 : F (conj 0) = conj 0)
+    (hS : ∀ b : Fin ℓ, F (conj b.succ) = conj (e b).succ) :
+    (phiProd ℓ conj).map F = phiProd ℓ conj := by
+  rw [phiProd, Polynomial.map_prod]
+  simp only [Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C]
+  rw [Fin.prod_univ_succ, Fin.prod_univ_succ, h0]
+  congr 1
+  calc ∏ b : Fin ℓ, (Polynomial.X - Polynomial.C (F (conj b.succ)))
+      = ∏ b : Fin ℓ, (Polynomial.X - Polynomial.C (conj (e b).succ)) := by
+        refine Finset.prod_congr rfl fun b _ => ?_
+        rw [hS b]
+    _ = ∏ b : Fin ℓ, (Polynomial.X - Polynomial.C (conj b.succ)) :=
+        e.prod_comp fun b => Polynomial.X - Polynomial.C (conj b.succ)
+
+private theorem map_phiProd_coeff_of_perm (F : LaurentSeries K →+* LaurentSeries K)
+    (e : Fin ℓ ≃ Fin ℓ) (h0 : F (conj 0) = conj 0)
+    (hS : ∀ b : Fin ℓ, F (conj b.succ) = conj (e b).succ) (k : ℕ) :
+    F ((phiProd ℓ conj).coeff k) = (phiProd ℓ conj).coeff k := by
+  conv_rhs => rw [← map_phiProd_of_perm F e h0 hS]
+  rw [Polynomial.coeff_map]
+
+end PermLemma
+
+section TwistRoot
+
+variable {K : Type*} [Field K] {ℓ : ℕ} {ζ : Kˣ}
+
+private theorem zeta_pow_card_eq_one (hζ : IsPrimitiveRoot (ζ : K) ℓ) : ζ ^ ℓ = 1 := by
+  refine Units.ext ?_
+  rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one]
+
+private theorem zeta_pow_mod (hζ : IsPrimitiveRoot (ζ : K) ℓ) (n : ℕ) :
+    ζ ^ (n % ℓ) = ζ ^ n :=
+  (pow_eq_pow_mod n (zeta_pow_card_eq_one hζ)).symm
+
+end TwistRoot
+
+section TwistConj
+
+variable {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+  {conj : Fin (ℓ + 1) → LaurentSeries K} {ζ : Kˣ} {J : LaurentSeries K}
+
+private theorem qTwist_conj_zero (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J) : qTwist ζ (conj 0) = conj 0 := by
+  rw [hconj0, qTwist_qExpand]
+  congr 1
+  rw [zpow_natCast, pow_mul, zeta_pow_card_eq_one hζ, one_pow, qTwist_one_apply]
+
+private theorem qTwist_conj_succ (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J) (b : Fin ℓ) :
+    qTwist ζ (conj b.succ) = conj ((Equiv.addRight (1 : Fin ℓ)) b).succ := by
+  rw [hconjS b, hconjS ((Equiv.addRight (1 : Fin ℓ)) b), qTwist_qTwist]
+  congr 1
+  simp only [Equiv.coe_addRight]
+  have h1 : ((1 : Fin ℓ) : ℕ) = 1 := by
+    rw [Fin.val_one']
+    exact Nat.mod_eq_of_lt hℓ.out.one_lt
+  rw [Fin.val_add, h1, zeta_pow_mod hζ ((b : ℕ) + 1), pow_succ, mul_comm ζ (ζ ^ (b : ℕ))]
+
+private theorem qTwist_phiProd_coeff (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J) (k : ℕ) :
+    qTwist ζ ((phiProd ℓ conj).coeff k) = (phiProd ℓ conj).coeff k :=
+  map_phiProd_coeff_of_perm (qTwist ζ) (Equiv.addRight (1 : Fin ℓ))
+    (qTwist_conj_zero hζ hconj0) (qTwist_conj_succ hζ hconjS) k
+
+end TwistConj
+
+section SupportCollapse
+
+variable {K : Type*} [Field K] {ℓ : ℕ} {ζ : Kˣ}
+
+private theorem coeff_eq_zero_of_qTwist_eq (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    {f : LaurentSeries K} (hf : qTwist ζ f = f) {m : ℤ} (hm : ¬ (ℓ : ℤ) ∣ m) :
+    f.coeff m = 0 := by
+  have h := congrArg (fun g => HahnSeries.coeff g m) hf
+  simp only [qTwist_coeff] at h
+  by_contra hc
+  apply hm
+  rw [← hζ.zpow_eq_one_iff_dvd]
+  have hunit : ((ζ ^ m : Kˣ) : K) = (ζ : K) ^ m := Units.val_zpow_eq_zpow_val ζ m
+  have hzero : (((ζ ^ m : Kˣ) : K) - 1) * f.coeff m = 0 := by
+    rw [sub_mul, one_mul, h, sub_self]
+  rcases mul_eq_zero.mp hzero with h1 | h1
+  · rw [hunit] at h1
+    linear_combination h1
+  · exact absurd h1 hc
+
+end SupportCollapse
+
+section Contract
+
+variable {K : Type*} [Field K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)]
+
+private def qContract (f : LaurentSeries K) : LaurentSeries K where
+  coeff m := f.coeff ((ℓ : ℤ) * m)
+  isPWO_support' := by
+    have hsub : (Function.support fun m : ℤ => f.coeff ((ℓ : ℤ) * m)) ⊆
+        (fun k : ℤ => k / (ℓ : ℤ)) '' f.support := by
+      intro m hm
+      refine ⟨(ℓ : ℤ) * m, hm, ?_⟩
+      exact Int.mul_ediv_cancel_left m (Nat.cast_ne_zero.mpr hℓ.out.ne_zero)
+    exact (f.isPWO_support'.image_of_monotone fun a b hab =>
+      Int.ediv_le_ediv (Int.natCast_pos.mpr hℓ.out.pos) hab).mono hsub
+
+@[scoped simp]
+private theorem qContract_coeff (f : LaurentSeries K) (m : ℤ) :
+    (qContract ℓ f).coeff m = f.coeff ((ℓ : ℤ) * m) := rfl
+
+variable {ℓ}
+
+private theorem qExpand_qContract {f : LaurentSeries K}
+    (hf : ∀ m : ℤ, ¬ (ℓ : ℤ) ∣ m → f.coeff m = 0) :
+    qExpand K ℓ (qContract ℓ f) = f := by
+  ext k
+  by_cases hk : (ℓ : ℤ) ∣ k
+  · obtain ⟨m, rfl⟩ := hk
+    rw [qExpand_coeff_mul, qContract_coeff]
+  · rw [qExpand_coeff_of_not_dvd ℓ _ hk, hf k hk]
+
+private theorem mem_range_qExpand_of_qTwist_eq {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    {f : LaurentSeries K} (hf : qTwist ζ f = f) : f ∈ Set.range (qExpand K ℓ) :=
+  ⟨qContract ℓ f, qExpand_qContract fun _ hm => coeff_eq_zero_of_qTwist_eq hζ hf hm⟩
+
+end Contract
+
+section RangeDescent
+
+variable {K : Type*} [Field K]
+
+theorem phiProd_coeff_mem_range_qExpand (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+    (J : LaurentSeries K) (conj : Fin (ℓ + 1) → LaurentSeries K)
+    (hζ : IsPrimitiveRoot (ζ : K) ℓ) (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J) (k : ℕ) :
+    (phiProd ℓ conj).coeff k ∈ Set.range (qExpand K ℓ) :=
+  mem_range_qExpand_of_qTwist_eq hζ (qTwist_phiProd_coeff hζ hconj0 hconjS k)
+
+end RangeDescent
+
+section GaloisMap
+
+variable {R S : Type*} [CommRing R] [CommRing S]
+
+private theorem coeffMap_qTwist (σ : R →+* S) (u : Rˣ) (v : Sˣ) (huv : (v : S) = σ (u : R))
+    (f : LaurentSeries R) : coeffMap σ (qTwist u f) = qTwist v (coeffMap σ f) := by
+  have hmap : Units.map (σ : R →* S) u = v :=
+    Units.ext (by rw [Units.coe_map, huv]; rfl)
+  ext k
+  rw [coeffMap_coeff, qTwist_coeff, qTwist_coeff, coeffMap_coeff, map_mul]
+  congr 1
+  rw [← hmap, ← map_zpow, Units.coe_map]
+  rfl
+
+end GaloisMap
+
+section GaloisCoeff
+
+variable {K : Type*} [Field K]
+
+theorem coeffMap_phiProd_coeff (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+    (J : LaurentSeries K) (conj : Fin (ℓ + 1) → LaurentSeries K) (σ : K →+* K)
+    (hσJ : coeffMap σ J = J) (e : Fin ℓ ≃ Fin ℓ)
+    (hσζ : ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e b : Fin ℓ) : ℕ))
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = qTwist (ζ ^ (b : ℕ)) J) (k : ℕ) :
+    coeffMap σ ((phiProd ℓ conj).coeff k) = (phiProd ℓ conj).coeff k := by
+  refine map_phiProd_coeff_of_perm (coeffMap σ) e ?_ ?_ k
+  · rw [hconj0, coeffMap_qExpand, hσJ]
+  · intro b
+    rw [hconjS b, hconjS (e b),
+      coeffMap_qTwist σ (ζ ^ (b : ℕ)) (ζ ^ ((e b : Fin ℓ) : ℕ))
+        (by rw [Units.val_pow_eq_pow_val, Units.val_pow_eq_pow_val, hσζ b]),
+      hσJ]
+
+end GaloisCoeff
+
+section FixedField
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+theorem mem_range_coeffEmb_of_forall_coeffMap_eq
+    (hfix : ∀ c : K, (∀ σ : K ≃ₐ[ℚ] K, σ c = c) → ∃ r : ℚ, algebraMap ℚ K r = c)
+    {f : LaurentSeries K} (hf : ∀ σ : K ≃ₐ[ℚ] K, coeffMap (σ : K →+* K) f = f) :
+    f ∈ Set.range (coeffEmb K) := by
+  have hcoeff : ∀ m : ℤ, ∃ r : ℚ, algebraMap ℚ K r = f.coeff m := fun m =>
+    hfix (f.coeff m) fun σ => by
+      have hcongr := congrArg (fun g => HahnSeries.coeff g m) (hf σ)
+      simpa using hcongr
+  choose r hr using hcoeff
+  refine ⟨⟨r, ?_⟩, ?_⟩
+  · refine f.isPWO_support'.mono fun m hm => ?_
+    simp only [Function.mem_support] at hm ⊢
+    intro h
+    exact hm (FaithfulSMul.algebraMap_injective ℚ K (by rw [hr m, h, map_zero]))
+  · ext m
+    exact hr m
+
+end FixedField
+
+section GaloisPerm
+
+variable {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ}
+
+theorem exists_galoisPerm (hζ : IsPrimitiveRoot (ζ : K) ℓ) (σ : K →+* K) :
+    ∃ e : Fin ℓ ≃ Fin ℓ,
+      ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e b : Fin ℓ) : ℕ) := by
+  have hσζ : (σ (ζ : K)) ^ ℓ = 1 := by
+    rw [← map_pow, hζ.pow_eq_one, map_one]
+  obtain ⟨a, -, ha⟩ := hζ.eq_pow_of_pow_eq_one hσζ
+  set e₀ : Fin ℓ → Fin ℓ := fun b => ⟨(a * (b : ℕ)) % ℓ, Nat.mod_lt _ hℓ.out.pos⟩
+  have hkey : ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e₀ b : Fin ℓ) : ℕ) := by
+    intro b
+    change σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((a * (b : ℕ)) % ℓ)
+    rw [map_pow, ← ha, ← pow_mul]
+    exact pow_eq_pow_mod _ hζ.pow_eq_one
+  have hinj : Function.Injective e₀ := by
+    intro b b' hbb'
+    have h1 : σ ((ζ : K) ^ (b : ℕ)) = σ ((ζ : K) ^ ((b' : Fin ℓ) : ℕ)) := by
+      rw [hkey b, hkey b', hbb']
+    exact Fin.ext (hζ.pow_inj b.isLt b'.isLt (σ.injective h1))
+  exact ⟨Equiv.ofBijective e₀ (Finite.injective_iff_bijective.mp hinj), hkey⟩
+
+end GaloisPerm
+
+section Descent
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem mem_range_coeffEmb_qExpand_of_mem_inter {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+    {f : LaurentSeries K} (h1 : f ∈ Set.range (ModularCurve.qExpand K ℓ))
+    (h2 : f ∈ Set.range (coeffEmb K)) :
+    ∃ g : LaurentSeries ℚ, f = coeffEmb K (ModularCurve.qExpand ℚ ℓ g) := by
+  obtain ⟨h, hh⟩ := h2
+  have hsupp : ∀ m : ℤ, ¬ (ℓ : ℤ) ∣ m → h.coeff m = 0 := by
+    intro m hm
+    obtain ⟨g, hg⟩ := h1
+    refine FaithfulSMul.algebraMap_injective ℚ K ?_
+    rw [map_zero, ← coeffEmb_coeff, hh, ← hg, qExpand_coeff_of_not_dvd ℓ g hm]
+  refine ⟨qContract ℓ h, ?_⟩
+  rw [qExpand_qContract hsupp]
+  exact hh.symm
+
+theorem exists_phiGenDescends (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+    [IsGalois ℚ K] [FiniteDimensional ℚ K] (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    ∃ c : ℕ → LaurentSeries ℚ, PhiGenDescends ℓ ζ c := by
+  have hmem : ∀ k : ℕ, ∃ g : LaurentSeries ℚ,
+      (phiProd ℓ (conj ℓ ζ)).coeff k = coeffEmb K (ModularCurve.qExpand ℚ ℓ g) := by
+    intro k
+    refine mem_range_coeffEmb_qExpand_of_mem_inter ?_ ?_
+    · exact phiProd_coeff_mem_range_qExpand ℓ ζ (coeffEmb K jq) (conj ℓ ζ)
+        hζ (conj_zero ℓ ζ) (conj_succ ℓ ζ) k
+    · refine mem_range_coeffEmb_of_forall_coeffMap_eq
+        (fun x hx => (IsGalois.mem_range_algebraMap_iff_fixed x).mpr hx) ?_
+      intro σ
+      obtain ⟨e, he⟩ := exists_galoisPerm hζ (σ : K →+* K)
+      exact coeffMap_phiProd_coeff ℓ ζ (coeffEmb K jq) (conj ℓ ζ) (σ : K →+* K)
+        (coeffMap_coeffEmb σ jq) e he (conj_zero ℓ ζ) (conj_succ ℓ ζ) k
+  choose c hc using hmem
+  exact ⟨c, hc⟩
+
+end Descent
+
+end PhiGen
+end ModularCurve
+end
+
+open _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_PhiGen_mem_range_coeffEmb_qExpand_of_mem_inter.ModularCurve
+  _root_.ModularCurve.PhiGen
+  _root_.P2MW.S_ModularCurve_PhiGen_mem_range_coeffEmb_qExpand_of_mem_inter.ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+    {f : LaurentSeries K} (h1 : f ∈ Set.range (ModularCurve.qExpand K ℓ))
+    (h2 : f ∈ Set.range (coeffEmb K)) :
+    ∃ g : LaurentSeries ℚ, f = coeffEmb K (ModularCurve.qExpand ℚ ℓ g) :=
+  ModularCurve.PhiGen.mem_range_coeffEmb_qExpand_of_mem_inter h1 h2
+
+end S_ModularCurve_PhiGen_mem_range_coeffEmb_qExpand_of_mem_inter
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_mem_range_coeffEmb_qExpand_of_mem_inter (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.mem_range_coeffEmb_qExpand_of_mem_inter {K : Type*} [Field K]
+    [Algebra ℚ K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] {f : LaurentSeries K}
+    (h1 : f ∈ Set.range (ModularCurve.qExpand K ℓ)) (h2 : f ∈ Set.range (coeffEmb K)) :
+    ∃ g : LaurentSeries ℚ, f = coeffEmb K (ModularCurve.qExpand ℚ ℓ g) :=
+  solution h1 h2
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_phiIrreducible_of_splits.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_phiIrreducible_of_splits.lean
new file mode 100644
index 0000000000..47e0bc6fb5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_phiIrreducible_of_splits.lean
@@ -0,0 +1,986 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.phiIrreducible_of_splits
+(6d9b2a8d-21b9-5a13-9633-e190468eaf8a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e9752dc7-0d1f-5fd4-b865-5188112dce67
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_one_le_coeff_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime
+import Mathlib.Algebra.Polynomial.Roots
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Algebra
+import Mathlib.FieldTheory.Minpoly.Field
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.RingTheory.Polynomial.GaussLemma
+import Mathlib.RingTheory.Polynomial.RationalRoot
+import Mathlib.Tactic.Linarith
+import Mathlib.Tactic.LinearCombination
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Irreducibility of Φ_ℓ(j,Y) over ℚ(j) from its conjugate factorisation
+
+Theorem statement: `ModularCurve.PhiGen.phiIrreducible_of_splits`
+(`6d9b2a8d-21b9-5a13-9633-e190468eaf8a`), by Claude, 2026-09-05.
+
+Proof: submission `e9752dc7-0d1f-5fd4-b865-5188112dce67`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field equipped with a $\mathbb{Q}$-algebra structure, let $\ell$ be a prime, and let
+$\zeta \in K^\times$ be such that its image in $K$ is a primitive $\ell$-th root of unity. Let
+`data` be a modular-polynomial packet at level $\ell$: a polynomial $\Phi \in (\mathbb{Z}[X])[Y]$
+that is monic, whose degree in $Y$ equals $\psi(\ell)$ (the Dedekind function $\sum_{d \mid \ell,\ d
+\text{ squarefree}} \ell/d$, equal to $\ell+1$ by
+[`ModularCurve.dedekindPsi_prime`](thm.html#ModularCurve.dedekindPsi_prime)), and which satisfies
+$\Phi(j(q), j(q^{\ell})) = 0$ in Laurent series over $\mathbb{Q}$. Assume that mapping the
+coefficients of $\Phi$ along the ring homomorphism $\mathbb{Z}[X] \to K((q))$ given by evaluation at
+$j$ (`evalAtJ`), followed by `qExpand ℚ ℓ` (which multiplies all exponents by $\ell$) and then by
+the coefficientwise embedding `coeffEmb K` induced by $\mathbb{Q} \to K$, yields exactly $\prod_{i
+\in \mathrm{Fin}(\ell+1)} (Y - \mathrm{conj}\,\ell\,\zeta\,i)$, where
+$\mathrm{conj}\,\ell\,\zeta\,i$ is the image of `coeffEmb K jq` under `qTwist (ζ ^ (a_i b_i))`
+followed by `qExpand K (a_i a_i)`, with $(a_i,b_i) = (\ell,0)$ for $i = 0$ and $(1, i-1)$ otherwise.
+Then `PhiIrreducible data` holds: the polynomial `data.toAdjoin`, obtained from $\Phi$ by mapping
+its $\mathbb{Z}[X]$-coefficients along evaluation at the generator $j$ of the intermediate field
+$\mathbb{Q}⟮jq⟯$ of $\mathbb{Q}((q))$, is irreducible over $\mathbb{Q}⟮jq⟯$.
+
+This is the classical irreducibility of the modular equation $\Phi_\ell(j, Y)$ over $\mathbb{Q}(j)$,
+here deduced from the hypothesis that $\Phi_\ell$ factors over $K((q))$ as the product of $Y$ minus
+the $\ell+1$ expected conjugates of $j$. It feeds
+[`ModularCurve.exists_phiIrreducible_evalSymm`]
+(thm.html#ModularCurve.exists_phiIrreducible_evalSymm),
+and thereby the identification of the function field of $X_0(\ell)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_phiIrreducible_of_splits.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_phiIrreducible_of_splits
+
+noncomputable section
+
+p2m_open "Polynomial IntermediateField IntermediateField.algebraAdjoinAdjoin"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_qExpand \
+  algebraMap_apply_eq_single jq coeff_jq_pow_self coeff_jq_pow_of_lt coeff_jq_neg_one \
+  coeff_jq_of_lt jqN dedekindPsi evalAtJ evalAtJ_X ModularPolynomialData jGen evalAtJGen \
+  algebraMap_comp_evalAtJGen ModularPolynomialData.toAdjoin qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qExpand evalAtJqN evalAtJqN_X evalAtJqN_def evalAtJ_def EvalSymm aeval_toRingHom_X \
+  PhiIrreducible adjoinJq jAdj evalAtJAdj swapInner swapBivar swapBivar_X swapBivar_C_X coeffMap \
+  coeffEmb coeffEmb_coeff one_le_coeff_jq coeffMap_qExpand coeffEmb_qExpand transcendental_jq \
+  dedekindPsi_prime"
+p2m_open "ModularCurve"
+
+section JqNLead
+
+variable (N : ℕ) [NeZero N]
+
+private theorem coeff_jqN_self : (jqN N).coeff (-(N : ℤ)) = 1 := by
+  have h : (-(N : ℤ)) = (N : ℤ) * (-1) := by ring
+  rw [jqN, h, qExpand_coeff_mul, coeff_jq_neg_one]
+
+private theorem coeff_jqN_of_lt {m : ℤ} (hm : m < -(N : ℤ)) : (jqN N).coeff m = 0 := by
+  rw [jqN]
+  by_cases hdvd : (N : ℤ) ∣ m
+  · obtain ⟨k, rfl⟩ := hdvd
+    rw [qExpand_coeff_mul]
+    refine coeff_jq_of_lt ?_
+    have hN : (0 : ℤ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+    nlinarith
+  · exact qExpand_coeff_of_not_dvd N jq hdvd
+
+end JqNLead
+
+private theorem evalAtJ_injective : Function.Injective evalAtJ := by
+  rw [injective_iff_map_eq_zero]
+  intro c hc
+  by_contra hc0
+  refine transcendental_jq ⟨c.map (Int.castRingHom ℚ), ?_, ?_⟩
+  · exact (Polynomial.map_ne_zero_iff (Int.cast_injective)).mpr hc0
+  · rw [Polynomial.aeval_def, Polynomial.eval₂_map, Subsingleton.elim
+      ((algebraMap ℚ (LaurentSeries ℚ)).comp (Int.castRingHom ℚ))
+      (algebraMap ℤ (LaurentSeries ℚ))]
+    exact hc
+
+theorem evalAtJGen_injective : Function.Injective evalAtJGen := by
+  intro a b hab
+  apply evalAtJ_injective
+  rw [← algebraMap_comp_evalAtJGen]
+  simp only [RingHom.comp_apply, hab]
+
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd phiProd_eval_conj"
+p2m_open "ModularCurve.PhiGen"
+
+section CoeffEmbJq
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+private theorem coeff_coeffEmb_jq_neg_one : (coeffEmb K jq).coeff (-1 : ℤ) = 1 := by
+  rw [coeffEmb_coeff, coeff_jq_neg_one, map_one]
+
+end CoeffEmbJq
+
+section Distinctness
+
+variable {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+private theorem conj_zero_coeff_neg_one :
+    (conj ℓ ζ (0 : Fin (ℓ + 1))).coeff (-1 : ℤ) = 0 := by
+  rw [conj_zero]
+  refine qExpand_coeff_of_not_dvd _ _ ?_
+  intro h
+  have h1 : ((ℓ * ℓ : ℕ) : ℤ) ∣ 1 := dvd_neg.mp h
+  have h2 : (ℓ * ℓ : ℕ) ∣ 1 := by exact_mod_cast h1
+  have h3 : ℓ * ℓ = 1 := Nat.dvd_one.mp h2
+  have h4 : 2 ≤ ℓ := hℓ.out.two_le
+  nlinarith
+
+private theorem conj_succ_coeff_neg_one (b : Fin ℓ) :
+    (conj ℓ ζ b.succ).coeff (-1 : ℤ) = (((ζ ^ (b : ℕ))⁻¹ : Kˣ) : K) := by
+  rw [conj_succ, qTwist_coeff, coeff_coeffEmb_jq_neg_one, mul_one, zpow_neg_one]
+
+private theorem conj_injective (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    Function.Injective (conj ℓ ζ (K := K)) := by
+  have hne : ∀ b : Fin ℓ, (conj ℓ ζ (0 : Fin (ℓ + 1))).coeff (-1 : ℤ) ≠
+      (conj ℓ ζ b.succ).coeff (-1 : ℤ) := by
+    intro b
+    rw [conj_zero_coeff_neg_one, conj_succ_coeff_neg_one]
+    exact fun h => Units.ne_zero _ h.symm
+  intro i j hij
+  induction i using Fin.cases with
+  | zero =>
+    induction j using Fin.cases with
+    | zero => rfl
+    | succ b => exact absurd (congrArg (fun f => HahnSeries.coeff f (-1 : ℤ)) hij) (hne b)
+  | succ b =>
+    induction j using Fin.cases with
+    | zero => exact absurd (congrArg (fun f => HahnSeries.coeff f (-1 : ℤ)) hij.symm) (hne b)
+    | succ b' =>
+      have hcoeff := congrArg (fun f => HahnSeries.coeff f (-1 : ℤ)) hij
+      simp only [conj_succ_coeff_neg_one] at hcoeff
+      have hu : (ζ ^ (b : ℕ))⁻¹ = (ζ ^ (b' : ℕ))⁻¹ := Units.ext hcoeff
+      have hpow : (ζ : K) ^ (b : ℕ) = (ζ : K) ^ (b' : ℕ) := by
+        have hv := congrArg Units.val (inv_injective hu)
+        push_cast at hv
+        exact hv
+      exact congrArg Fin.succ (Fin.ext (hζ.pow_inj b.isLt b'.isLt hpow))
+
+end Distinctness
+
+section ScalarEmbedding
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+private def ratC : ℚ →+* LaurentSeries K := (HahnSeries.C).comp (algebraMap ℚ K)
+
+private theorem ratC_apply (c : ℚ) : ratC K c = HahnSeries.single 0 (algebraMap ℚ K c) :=
+  rfl
+
+private theorem coeff_ratC_of_ne (c : ℚ) {k : ℤ} (hk : k ≠ 0) : (ratC K c).coeff k = 0 := by
+  rw [ratC_apply]
+  exact HahnSeries.coeff_single_of_ne hk
+
+private theorem coeffMap_jq : coeffMap (algebraMap ℚ K) jq = (coeffEmb K jq) := by
+  ext k
+  rfl
+
+end ScalarEmbedding
+
+section PoleOrder
+
+private theorem coeff_aeval_jq_of_lt (P : Polynomial ℚ) {m : ℤ}
+    (hm : m < -(P.natDegree : ℤ)) : (Polynomial.aeval jq P).coeff m = 0 := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum]
+  refine Finset.sum_eq_zero fun i hi => ?_
+  rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_of_lt,
+    mul_zero]
+  have : i ≤ P.natDegree := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)
+  omega
+
+private theorem coeff_aeval_jq_neg_natDegree (P : Polynomial ℚ) :
+    (Polynomial.aeval jq P).coeff (-(P.natDegree : ℤ)) = P.coeff P.natDegree := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+    Finset.sum_eq_single P.natDegree]
+  · rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_self,
+      mul_one]
+  · intro i hi hin
+    have hilt : i < P.natDegree :=
+      lt_of_le_of_ne (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hin
+    rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_of_lt
+      (by omega), mul_zero]
+  · intro hn'
+    exact absurd (Finset.self_mem_range_succ P.natDegree) hn'
+
+variable (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] {P : Polynomial ℚ}
+
+private theorem ne_zero_of_aeval_jq_eq_jqN (h : Polynomial.aeval jq P = jqN ℓ) : P ≠ 0 := by
+  rintro rfl
+  rw [map_zero] at h
+  have h1 := coeff_jqN_self ℓ
+  rw [← h, HahnSeries.coeff_zero] at h1
+  exact zero_ne_one h1
+
+private theorem natDegree_eq_of_aeval_jq_eq_jqN (h : Polynomial.aeval jq P = jqN ℓ) :
+    P.natDegree = ℓ := by
+  have hP0 : P ≠ 0 := ne_zero_of_aeval_jq_eq_jqN ℓ h
+  by_contra hne
+  rcases lt_or_gt_of_ne hne with hlt | hgt
+  · have h1 : (Polynomial.aeval jq P).coeff (-(ℓ : ℤ)) = 0 :=
+      coeff_aeval_jq_of_lt P (by omega)
+    rw [h, coeff_jqN_self] at h1
+    exact one_ne_zero h1
+  · have h1 := coeff_aeval_jq_neg_natDegree P
+    rw [h, coeff_jqN_of_lt ℓ (by omega)] at h1
+    exact hP0 (Polynomial.leadingCoeff_eq_zero.mp h1.symm)
+
+private theorem monic_of_aeval_jq_eq_jqN (h : Polynomial.aeval jq P = jqN ℓ) : P.Monic := by
+  have hd := natDegree_eq_of_aeval_jq_eq_jqN ℓ h
+  have h1 := coeff_aeval_jq_neg_natDegree P
+  rw [h, hd, coeff_jqN_self] at h1
+  change P.coeff P.natDegree = 1
+  rw [hd]
+  exact h1.symm
+
+end PoleOrder
+
+section Transfer
+
+variable {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+omit [Algebra ℚ K] hℓ in
+private theorem zeta_pow_eq_one (hζ : IsPrimitiveRoot (ζ : K) ℓ) : ζ ^ ℓ = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one])
+
+omit [Algebra ℚ K] hℓ in
+private theorem zeta_pow_zpow_eq_one (hζ : IsPrimitiveRoot (ζ : K) ℓ) (b : ℕ) :
+    (ζ ^ b) ^ ((ℓ : ℕ) : ℤ) = (1 : Kˣ) := by
+  rw [zpow_natCast, ← pow_mul, mul_comm, pow_mul, zeta_pow_eq_one ℓ ζ hζ, one_pow]
+
+variable {P : Polynomial ℚ}
+
+private theorem eval₂_ratC_jqK_of_aeval_jq_eq (h : Polynomial.aeval jq P = jqN ℓ) :
+    P.eval₂ (ratC K) (coeffEmb K jq) = qExpand K ℓ (coeffEmb K jq) := by
+  have h2 := congrArg (coeffMap (algebraMap ℚ K)) h
+  rw [Polynomial.aeval_def, Polynomial.hom_eval₂, jqN, coeffMap_qExpand, coeffMap_jq,
+    Subsingleton.elim ((coeffMap (algebraMap ℚ K)).comp (algebraMap ℚ (LaurentSeries ℚ)))
+      (ratC K)] at h2
+  exact h2
+
+private theorem eval₂_ratC_conj_succ_of_aeval_jq_eq (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (h : Polynomial.aeval jq P = jqN ℓ) (b : Fin ℓ) :
+    P.eval₂ (ratC K) (conj ℓ ζ b.succ) = qExpand K ℓ (coeffEmb K jq) := by
+  have h2 := congrArg (qTwist (ζ ^ (b : ℕ))) (eval₂_ratC_jqK_of_aeval_jq_eq ℓ h)
+  rw [Polynomial.hom_eval₂,
+    Subsingleton.elim ((qTwist (ζ ^ (b : ℕ))).comp (ratC K)) (ratC K),
+    qTwist_qExpand, zeta_pow_zpow_eq_one ℓ ζ hζ, qTwist_one_apply, ← conj_succ] at h2
+  exact h2
+
+end Transfer
+
+section Vieta
+
+variable {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+variable {P : Polynomial ℚ}
+
+private theorem sum_conj_succ_eq_ratC_of_aeval_jq_eq (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (h : Polynomial.aeval jq P = jqN ℓ) :
+    ∑ b : Fin ℓ, conj ℓ ζ b.succ = ratC K (-(P.coeff (ℓ - 1))) := by
+  have hPdeg : P.natDegree = ℓ := natDegree_eq_of_aeval_jq_eq_jqN ℓ h
+  have hPmonic : P.Monic := monic_of_aeval_jq_eq_jqN ℓ h
+  set A : Polynomial (LaurentSeries K) := P.map (ratC K) with hA
+  set B : Polynomial (LaurentSeries K) :=
+    ∏ b : Fin ℓ, (Polynomial.X - Polynomial.C (conj ℓ ζ b.succ)) with hB
+  have hAmonic : A.Monic := hPmonic.map _
+  have hAdeg : A.natDegree = ℓ := by rw [hA, hPmonic.natDegree_map, hPdeg]
+  have hBmonic : B.Monic :=
+    Polynomial.monic_prod_of_monic _ _ fun i _ => Polynomial.monic_X_sub_C _
+  have hBdeg : B.natDegree = ℓ := by
+    rw [hB, Polynomial.natDegree_prod_of_monic _ _ fun i _ => Polynomial.monic_X_sub_C _]
+    simp
+  have hinj : Function.Injective (fun b : Fin ℓ => conj ℓ ζ b.succ) := fun b b' hbb' =>
+    Fin.succ_injective ℓ (conj_injective ℓ ζ hζ hbb')
+  have key : A - B = Polynomial.C (qExpand K ℓ (coeffEmb K jq)) := by
+    refine Polynomial.eq_of_natDegree_lt_card_of_eval_eq _ _ hinj (fun b => ?_) ?_
+    · have hAev : A.eval (conj ℓ ζ b.succ) = qExpand K ℓ (coeffEmb K jq) := by
+        rw [hA, Polynomial.eval_map]
+        exact eval₂_ratC_conj_succ_of_aeval_jq_eq ℓ ζ hζ h b
+      have hBev : B.eval (conj ℓ ζ b.succ) = 0 := by
+        rw [hB, Polynomial.eval_prod]
+        exact Finset.prod_eq_zero (Finset.mem_univ b) (by simp)
+      simp only [Polynomial.eval_sub, Polynomial.eval_C, hAev, hBev, sub_zero]
+    · rw [Fintype.card_fin]
+      refine max_lt ?_ (by rw [Polynomial.natDegree_C]; exact hℓ.out.pos)
+      by_cases hAB : A = B
+      · rw [hAB, sub_self, Polynomial.natDegree_zero]
+        exact hℓ.out.pos
+      · refine lt_of_lt_of_eq
+          (Polynomial.natDegree_lt_natDegree (sub_ne_zero.mpr hAB) ?_) hAdeg
+        exact Polynomial.degree_sub_lt_left
+          (by rw [Polynomial.degree_eq_natDegree hAmonic.ne_zero,
+                Polynomial.degree_eq_natDegree hBmonic.ne_zero, hAdeg, hBdeg])
+          hAmonic.ne_zero (by rw [hAmonic.leadingCoeff, hBmonic.leadingCoeff])
+  have hcoeff := congrArg (fun p => Polynomial.coeff p (ℓ - 1)) key
+  have hℓ2 : 2 ≤ ℓ := hℓ.out.two_le
+  simp only [Polynomial.coeff_sub, Polynomial.coeff_C,
+    ite_eq_right (by omega : ¬(ℓ - 1 = 0))] at hcoeff
+  have hBcoeff : B.coeff (ℓ - 1) = -∑ b : Fin ℓ, conj ℓ ζ b.succ := by
+    have hv := Polynomial.prod_X_sub_C_coeff_card_pred (Finset.univ : Finset (Fin ℓ))
+      (fun b => conj ℓ ζ b.succ) (by simp [hℓ.out.pos])
+    simpa using hv
+  have hAcoeff : A.coeff (ℓ - 1) = ratC K (P.coeff (ℓ - 1)) := Polynomial.coeff_map _ _
+  rw [hAcoeff, hBcoeff, sub_neg_eq_add, add_comm] at hcoeff
+  rw [map_neg]
+  exact eq_neg_of_add_eq_zero_left hcoeff
+
+end Vieta
+
+section Refutation
+
+variable {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+private theorem coeff_sum_conj_succ_self (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    (∑ b : Fin ℓ, conj ℓ ζ b.succ).coeff ((ℓ : ℕ) : ℤ) =
+      (ℓ : K) * algebraMap ℚ K (jq.coeff ((ℓ : ℕ) : ℤ)) := by
+  rw [HahnSeries.coeff_sum]
+  have hterm : ∀ b : Fin ℓ, (conj ℓ ζ b.succ).coeff ((ℓ : ℕ) : ℤ) =
+      algebraMap ℚ K (jq.coeff ((ℓ : ℕ) : ℤ)) := by
+    intro b
+    rw [conj_succ, qTwist_coeff, zeta_pow_zpow_eq_one ℓ ζ hζ, Units.val_one, one_mul,
+      coeffEmb_coeff]
+  rw [Finset.sum_congr rfl fun b _ => hterm b, Finset.sum_const, Finset.card_univ,
+    Fintype.card_fin, nsmul_eq_mul]
+
+private theorem coeff_sum_conj_succ_ne_zero
+    (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    (∑ b : Fin ℓ, conj ℓ ζ b.succ).coeff ((ℓ : ℕ) : ℤ) ≠ 0 := by
+  rw [coeff_sum_conj_succ_self ℓ ζ hζ]
+  refine mul_ne_zero ?_ ?_
+  · rw [show ((ℓ : ℕ) : K) = algebraMap ℚ K ((ℓ : ℕ) : ℚ) from (map_natCast _ _).symm]
+    intro hc
+    exact (Nat.cast_ne_zero (R := ℚ)).mpr hℓ.out.ne_zero
+      ((algebraMap ℚ K).injective (by rw [hc, map_zero]))
+  · intro hc
+    have h0 : jq.coeff ((ℓ : ℕ) : ℤ) = 0 :=
+      (algebraMap ℚ K).injective (by rw [hc, map_zero])
+    have h1 := hpos ℓ
+    rw [h0] at h1
+    norm_num at h1
+
+theorem aeval_jq_ne_jqN_of_isPrimitiveRoot
+    (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (P : Polynomial ℚ) : Polynomial.aeval jq P ≠ jqN ℓ := by
+  intro h
+  have h1 := sum_conj_succ_eq_ratC_of_aeval_jq_eq ℓ ζ hζ h
+  have h2 := coeff_sum_conj_succ_ne_zero ℓ ζ hpos hζ
+  rw [h1] at h2
+  exact h2 (coeff_ratC_of_ne K _ (by exact_mod_cast hℓ.out.ne_zero))
+
+end Refutation
+
+section Headline
+
+variable (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)]
+
+theorem aeval_jq_ne_jqN (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (P : Polynomial ℚ) :
+    Polynomial.aeval jq P ≠ jqN ℓ := by
+  have : NeZero ((ℓ : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr hℓ.out.ne_zero⟩
+  have : IsCyclotomicExtension {ℓ} ℚ (CyclotomicField ℓ ℚ) :=
+    CyclotomicField.isCyclotomicExtension (n := ℓ) (K := ℚ)
+  obtain ⟨z, hz⟩ := IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField ℓ ℚ)
+    (Set.mem_singleton ℓ) hℓ.out.ne_zero
+  have hzu : IsUnit z := hz.isUnit hℓ.out.ne_zero
+  refine aeval_jq_ne_jqN_of_isPrimitiveRoot ℓ hzu.unit hpos ?_ P
+  rw [hzu.unit_spec]
+  exact hz
+
+theorem jqN_not_mem_adjoin_jq (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) :
+    jqN ℓ ∉ Algebra.adjoin ℚ {jq} := by
+  intro hmem
+  obtain ⟨P, hP⟩ := Algebra.adjoin_mem_exists_aeval _ _ hmem
+  exact aeval_jq_ne_jqN ℓ hpos P hP
+
+end Headline
+
+end PhiGen
+
+section FractionField
+
+private scoped instance instUFMAdjoinJq : UniqueFactorizationMonoid adjoinJq :=
+  transcendental_jq.uniqueFactorizationMonoid_adjoin
+
+private theorem algebraMap_comp_evalAtJAdj :
+    (algebraMap adjoinJq ℚ⟮jq⟯).comp evalAtJAdj = evalAtJGen := by
+  refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+  change algebraMap adjoinJq ℚ⟮jq⟯ (evalAtJAdj Polynomial.X) = evalAtJGen Polynomial.X
+  rw [show evalAtJAdj Polynomial.X = jAdj from Polynomial.eval₂_X _ _,
+    show evalAtJGen Polynomial.X = jGen from Polynomial.eval₂_X _ _]
+  exact Subtype.ext rfl
+
+namespace ModularPolynomialData
+p2m_export "ModularCurve.ModularPolynomialData" "toAdjoin toAdjoin_monic monic eval_eq_zero \
+  natDegree_eq Φ"
+p2m_open "ModularCurve.ModularPolynomialData"
+
+variable {N : ℕ} [NeZero N] (data : ModularPolynomialData N)
+
+private theorem _root_.ModularCurve.ModularPolynomialData.aeval_jqN_toAdjoin :
+    Polynomial.aeval (jqN N) data.toAdjoin = 0 := by
+  rw [Polynomial.aeval_def, toAdjoin, Polynomial.eval₂_map, algebraMap_comp_evalAtJGen]
+  exact data.eval_eq_zero
+
+p2m_export "ModularCurve.ModularPolynomialData" "aeval_jqN_toAdjoin"
+
+private theorem _root_.ModularCurve.ModularPolynomialData.minpoly_jqN_eq (hirr : PhiIrreducible
+  data) :
+    minpoly ℚ⟮jq⟯ (jqN N) = data.toAdjoin :=
+  (minpoly.eq_of_irreducible_of_monic hirr data.aeval_jqN_toAdjoin data.toAdjoin_monic).symm
+
+p2m_export "ModularCurve.ModularPolynomialData" "minpoly_jqN_eq"
+end ModularPolynomialData
+
+end FractionField
+
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd phiProd_eval_conj"
+p2m_open "ModularCurve.PhiGen"
+
+section Embed
+
+variable (K : Type*) [Field K] [Algebra ℚ K] (ℓ : ℕ) [NeZero ℓ]
+
+private def qEmbedT : LaurentSeries ℚ →+* LaurentSeries K :=
+  (qExpand K ℓ).comp (coeffMap (algebraMap ℚ K))
+
+private theorem qEmbedT_apply (x : LaurentSeries ℚ) :
+    qEmbedT K ℓ x = qExpand K ℓ (coeffMap (algebraMap ℚ K) x) := rfl
+
+private theorem qEmbedT_injective : Function.Injective (qEmbedT K ℓ) :=
+  (qEmbedT K ℓ).injective
+
+private theorem qEmbedT_jq : qEmbedT K ℓ jq = qExpand K ℓ (coeffEmb K jq) := by
+  rw [qEmbedT_apply, coeffMap_jq]
+
+private theorem qEmbedT_eq_coeffEmb_qExpand (x : LaurentSeries ℚ) :
+    qEmbedT K ℓ x = coeffEmb K (qExpand ℚ ℓ x) := by
+  rw [coeffEmb_qExpand]
+  rfl
+
+private theorem coeffEmb_comp_qExpand_comp_evalAtJ :
+    ((coeffEmb K).comp (qExpand ℚ ℓ)).comp evalAtJ = (qEmbedT K ℓ).comp evalAtJ := by
+  refine RingHom.ext fun p => ?_
+  simp only [RingHom.comp_apply]
+  rw [qEmbedT_eq_coeffEmb_qExpand]
+
+end Embed
+
+section EmbedPrime
+
+variable (K : Type*) [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+private theorem qEmbedT_jqN : qEmbedT K ℓ (jqN ℓ) = conj ℓ ζ (0 : Fin (ℓ + 1)) := by
+  rw [conj_zero, qEmbedT_apply, jqN, coeffMap_qExpand, coeffMap_jq, qExpand_qExpand]
+
+private theorem qTwist_comp_qEmbedT (hζ : IsPrimitiveRoot (ζ : K) ℓ) (b : ℕ) :
+    (qTwist (ζ ^ b)).comp (qEmbedT K ℓ) = qEmbedT K ℓ := by
+  refine RingHom.ext fun x => ?_
+  rw [RingHom.comp_apply, qEmbedT_apply, qTwist_qExpand, zeta_pow_zpow_eq_one ℓ ζ hζ b,
+    qTwist_one_apply]
+
+private theorem conj_succ_zero : conj ℓ ζ (0 : Fin ℓ).succ = (coeffEmb K jq) := by
+  rw [conj_succ, Fin.val_zero, pow_zero, qTwist_one_apply]
+
+end EmbedPrime
+
+section FactorAnalysis
+
+variable (K : Type*) [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+private def adjoinEmbedT : adjoinJq →+* LaurentSeries K :=
+  (qEmbedT K ℓ).comp (algebraMap adjoinJq (LaurentSeries ℚ))
+
+private theorem adjoinEmbedT_apply (x : adjoinJq) :
+    adjoinEmbedT K ℓ x = qEmbedT K ℓ (x : LaurentSeries ℚ) := rfl
+
+private theorem adjoinEmbedT_injective : Function.Injective (adjoinEmbedT K ℓ) :=
+  fun _ _ h => Subtype.ext (qEmbedT_injective K ℓ h)
+
+private theorem adjoinEmbedT_comp_evalAtJAdj :
+    (adjoinEmbedT K ℓ).comp evalAtJAdj = (qEmbedT K ℓ).comp evalAtJ := by
+  refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+  change adjoinEmbedT K ℓ (evalAtJAdj Polynomial.X) = qEmbedT K ℓ (evalAtJ Polynomial.X)
+  rw [show evalAtJAdj Polynomial.X = jAdj from Polynomial.eval₂_X _ _, evalAtJ_X]
+  rfl
+
+variable {K ℓ ζ}
+
+private theorem eval_map_conj_succ_eq_zero (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    {D : Polynomial adjoinJq} (h : (D.map (adjoinEmbedT K ℓ)).eval (coeffEmb K jq) = 0)
+    (b : Fin ℓ) : (D.map (adjoinEmbedT K ℓ)).eval (conj ℓ ζ b.succ) = 0 := by
+  have hcomp : (qTwist (ζ ^ (b : ℕ))).comp (adjoinEmbedT K ℓ) = adjoinEmbedT K ℓ := by
+    rw [adjoinEmbedT, ← RingHom.comp_assoc, qTwist_comp_qEmbedT K ℓ ζ hζ]
+  have key : qTwist (ζ ^ (b : ℕ)) ((D.map (adjoinEmbedT K ℓ)).eval (coeffEmb K jq))
+      = (D.map (adjoinEmbedT K ℓ)).eval (qTwist (ζ ^ (b : ℕ)) (coeffEmb K jq)) := by
+    rw [Polynomial.eval_map, Polynomial.eval_map, Polynomial.hom_eval₂, hcomp]
+  rw [conj_succ, ← key, h, map_zero]
+
+private theorem le_natDegree_of_eval_map_jqK_eq_zero (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    {D : Polynomial adjoinJq} (hD : D ≠ 0)
+    (h : (D.map (adjoinEmbedT K ℓ)).eval (coeffEmb K jq) = 0) : ℓ ≤ D.natDegree := by
+  have hmap : ℓ ≤ (D.map (adjoinEmbedT K ℓ)).natDegree := by
+    by_contra hlt
+    rw [not_le] at hlt
+    have hzero : D.map (adjoinEmbedT K ℓ) = 0 :=
+      Polynomial.eq_zero_of_natDegree_lt_card_of_eval_eq_zero _
+        (f := fun b : Fin ℓ => conj ℓ ζ b.succ)
+        (fun b b' hbb' => Fin.succ_injective ℓ (conj_injective ℓ ζ hζ hbb'))
+        (fun b => eval_map_conj_succ_eq_zero hζ h b)
+        (by rwa [Fintype.card_fin])
+    exact hD (Polynomial.map_injective _ (adjoinEmbedT_injective K ℓ)
+      (by rw [hzero, Polynomial.map_zero]))
+  exact le_trans hmap Polynomial.natDegree_map_le
+
+private theorem eval_map_evalAtJAdj_ne_zero
+    (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (data : ModularPolynomialData ℓ)
+    (hsplit : (data.Φ.map evalAtJAdj).map (adjoinEmbedT K ℓ) = phiProd ℓ (conj ℓ ζ))
+    (β : adjoinJq) : (data.Φ.map evalAtJAdj).eval β ≠ 0 := by
+  intro heval
+  have hmap : (phiProd ℓ (conj ℓ ζ)).eval (adjoinEmbedT K ℓ β) = 0 := by
+    rw [← hsplit, Polynomial.eval_map, Polynomial.eval₂_at_apply, heval, map_zero]
+  rw [phiProd, Polynomial.eval_prod] at hmap
+  obtain ⟨i, -, hi⟩ := Finset.prod_eq_zero_iff.mp hmap
+  rw [Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, sub_eq_zero] at hi
+  rcases Fin.eq_zero_or_eq_succ i with rfl | ⟨b, rfl⟩
+  · rw [adjoinEmbedT_apply, ← qEmbedT_jqN K ℓ ζ] at hi
+    have hβ : (β : LaurentSeries ℚ) = jqN ℓ := qEmbedT_injective K ℓ hi
+    exact jqN_not_mem_adjoin_jq ℓ hpos (hβ ▸ β.2)
+  · have h0 : (adjoinEmbedT K ℓ β).coeff (-1 : ℤ) = 0 := by
+      rw [adjoinEmbedT_apply, qEmbedT_apply]
+      refine qExpand_coeff_of_not_dvd _ _ ?_
+      intro hdvd
+      have h1 : ((ℓ : ℕ) : ℤ) ∣ 1 := dvd_neg.mp hdvd
+      have h2 : ℓ ∣ 1 := by exact_mod_cast h1
+      exact hℓ.out.one_lt.ne' (Nat.dvd_one.mp h2)
+    rw [hi, conj_succ_coeff_neg_one] at h0
+    exact Units.ne_zero _ h0
+
+private theorem isUnit_of_dvd_of_natDegree_le_one
+    (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (data : ModularPolynomialData ℓ)
+    (hsplit : (data.Φ.map evalAtJAdj).map (adjoinEmbedT K ℓ) = phiProd ℓ (conj ℓ ζ))
+    {B : Polynomial adjoinJq} (hdvd : B ∣ data.Φ.map evalAtJAdj)
+    (hlc : IsUnit B.leadingCoeff) (hdeg : B.natDegree ≤ 1) : IsUnit B := by
+  rcases Nat.le_one_iff_eq_zero_or_eq_one.mp hdeg with h0 | h1
+  · rw [Polynomial.eq_C_of_natDegree_eq_zero h0]
+    refine Polynomial.isUnit_C.mpr ?_
+    have hc : B.coeff 0 = B.leadingCoeff := by rw [Polynomial.leadingCoeff, h0]
+    rw [hc]
+    exact hlc
+  · exfalso
+    obtain ⟨u, hu⟩ := hlc
+    obtain ⟨D, hD⟩ := hdvd
+    have hu1 : (u : adjoinJq) = B.coeff 1 := by rw [hu, Polynomial.leadingCoeff, h1]
+    have hBev : ∀ x : adjoinJq, B.eval x = B.coeff 1 * x + B.coeff 0 := fun x => by
+      conv_lhs => rw [Polynomial.eq_X_add_C_of_natDegree_le_one hdeg]
+      simp only [Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C,
+        Polynomial.eval_X]
+    have hroot : B.eval ((↑u⁻¹ : adjoinJq) * -B.coeff 0) = 0 := by
+      rw [hBev, ← hu1]
+      linear_combination (-B.coeff 0) * u.mul_inv
+    refine eval_map_evalAtJAdj_ne_zero hpos data hsplit ((↑u⁻¹ : adjoinJq) * -B.coeff 0) ?_
+    rw [hD, Polynomial.eval_mul, hroot, zero_mul]
+
+end FactorAnalysis
+
+section Irreducibility
+
+variable {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+private theorem irreducible_map_evalAtJAdj_of_splits
+    (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (data : ModularPolynomialData ℓ)
+    (hsplit : (data.Φ.map evalAtJAdj).map (adjoinEmbedT K ℓ) = phiProd ℓ (conj ℓ ζ)) :
+    Irreducible (data.Φ.map evalAtJAdj) := by
+  have hmonic : (data.Φ.map evalAtJAdj).Monic := data.monic.map _
+  have hdeg : (data.Φ.map evalAtJAdj).natDegree = ℓ + 1 := by
+    rw [data.monic.natDegree_map, data.natDegree_eq, dedekindPsi_prime hℓ.out]
+  constructor
+  · exact Polynomial.not_isUnit_of_natDegree_pos _ (by omega)
+  · intro A B hAB
+    have hA0 : A ≠ 0 := fun h => hmonic.ne_zero (by rw [hAB, h, zero_mul])
+    have hB0 : B ≠ 0 := fun h => hmonic.ne_zero (by rw [hAB, h, mul_zero])
+    have hlcmul : A.leadingCoeff * B.leadingCoeff = 1 := by
+      rw [← Polynomial.leadingCoeff_mul, ← hAB]
+      exact hmonic.leadingCoeff
+    have hlcA : IsUnit A.leadingCoeff := IsUnit.of_mul_eq_one _ hlcmul
+    have hlcB : IsUnit B.leadingCoeff := IsUnit.of_mul_eq_one_right _ hlcmul
+    have hAdvd : A ∣ data.Φ.map evalAtJAdj := ⟨B, hAB⟩
+    have hBdvd : B ∣ data.Φ.map evalAtJAdj := ⟨A, hAB.trans (mul_comm A B)⟩
+    have hsum : A.natDegree + B.natDegree = ℓ + 1 := by
+      rw [← Polynomial.natDegree_mul hA0 hB0, ← hAB, hdeg]
+    have hzero : ((A.map (adjoinEmbedT K ℓ)).eval (coeffEmb K jq))
+        * ((B.map (adjoinEmbedT K ℓ)).eval (coeffEmb K jq)) = 0 := by
+      rw [← Polynomial.eval_mul, ← Polynomial.map_mul, ← hAB, hsplit,
+        ← conj_succ_zero K ℓ ζ]
+      exact phiProd_eval_conj ℓ _ _
+    rcases mul_eq_zero.mp hzero with hAz | hBz
+    · right
+      have hAdeg : ℓ ≤ A.natDegree := le_natDegree_of_eval_map_jqK_eq_zero hζ hA0 hAz
+      exact isUnit_of_dvd_of_natDegree_le_one hpos data hsplit hBdvd hlcB (by omega)
+    · left
+      have hBdeg : ℓ ≤ B.natDegree := le_natDegree_of_eval_map_jqK_eq_zero hζ hB0 hBz
+      exact isUnit_of_dvd_of_natDegree_le_one hpos data hsplit hAdvd hlcA (by omega)
+
+private theorem toAdjoin_eq_map_evalAtJAdj {N : ℕ} [NeZero N]
+    (data : ModularPolynomialData N) :
+    data.toAdjoin = (data.Φ.map evalAtJAdj).map (algebraMap adjoinJq ℚ⟮jq⟯) := by
+  rw [ModularPolynomialData.toAdjoin, Polynomial.map_map, algebraMap_comp_evalAtJAdj]
+
+private theorem phiIrreducible_of_splits
+    (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (data : ModularPolynomialData ℓ)
+    (hsplit : data.Φ.map (((coeffEmb K).comp (qExpand ℚ ℓ)).comp evalAtJ)
+      = phiProd ℓ (conj ℓ ζ)) : PhiIrreducible data := by
+  rw [coeffEmb_comp_qExpand_comp_evalAtJ K ℓ] at hsplit
+  have hsplit' : (data.Φ.map evalAtJAdj).map (adjoinEmbedT K ℓ)
+      = phiProd ℓ (conj ℓ ζ) := by
+    rw [Polynomial.map_map, adjoinEmbedT_comp_evalAtJAdj]
+    exact hsplit
+  change Irreducible data.toAdjoin
+  rw [toAdjoin_eq_map_evalAtJAdj]
+  exact ((data.monic.map evalAtJAdj).irreducible_iff_irreducible_map_fraction_map).mp
+    (irreducible_map_evalAtJAdj_of_splits ℓ ζ hpos hζ data hsplit')
+
+end Irreducibility
+
+end PhiGen
+
+section SwapBivarEval
+
+private theorem swapBivar_eval₂ (Φ : Polynomial (Polynomial ℤ)) (x y : LaurentSeries ℚ) :
+    (swapBivar Φ).eval₂ (Polynomial.aeval (R := ℤ) x).toRingHom y
+      = Φ.eval₂ (Polynomial.aeval (R := ℤ) y).toRingHom x := by
+  set h : Polynomial (Polynomial ℤ) →+* LaurentSeries ℚ :=
+    Polynomial.eval₂RingHom (Polynomial.aeval (R := ℤ) x).toRingHom y with hh
+  have key : h (swapBivar Φ) = Φ.eval₂ (h.comp swapInner) (h (Polynomial.C Polynomial.X)) :=
+    Polynomial.hom_eval₂ Φ swapInner h (Polynomial.C Polynomial.X)
+  have hCX : h (Polynomial.C Polynomial.X) = x := by
+    rw [hh, Polynomial.coe_eval₂RingHom, Polynomial.eval₂_C, aeval_toRingHom_X]
+  have hcomp : h.comp swapInner = (Polynomial.aeval (R := ℤ) y).toRingHom := by
+    refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+    change h (swapInner Polynomial.X) = (Polynomial.aeval (R := ℤ) y).toRingHom Polynomial.X
+    rw [aeval_toRingHom_X]
+    change h ((Polynomial.aeval (R := ℤ)
+      (Polynomial.X : Polynomial (Polynomial ℤ))) Polynomial.X) = y
+    rw [Polynomial.aeval_X, hh, Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X]
+  calc (swapBivar Φ).eval₂ (Polynomial.aeval (R := ℤ) x).toRingHom y
+      = h (swapBivar Φ) := rfl
+    _ = Φ.eval₂ (h.comp swapInner) (h (Polynomial.C Polynomial.X)) := key
+    _ = Φ.eval₂ (Polynomial.aeval (R := ℤ) y).toRingHom x := by rw [hCX, hcomp]
+
+theorem evalSymm_of_swapBivar_eq {Φ : Polynomial (Polynomial ℤ)} (h : swapBivar Φ = Φ) :
+    EvalSymm Φ := fun x y => by
+  conv_lhs => rw [← h]
+  exact swapBivar_eval₂ Φ x y
+
+end SwapBivarEval
+
+namespace ModularPolynomialData
+p2m_export "ModularCurve.ModularPolynomialData" "toAdjoin toAdjoin_monic monic eval_eq_zero \
+  natDegree_eq Φ"
+p2m_open "ModularCurve.ModularPolynomialData"
+
+variable {N : ℕ} [NeZero N] (data : ModularPolynomialData N)
+
+private theorem _root_.ModularCurve.ModularPolynomialData.aeval_jqN_transposeToAdjoin (hswap :
+  data.Φ.eval₂ (evalAtJqN N) jq = 0) :
+    Polynomial.aeval (jqN N) ((swapBivar data.Φ).map evalAtJGen) = 0 := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_map, algebraMap_comp_evalAtJGen,
+    evalAtJ_def, swapBivar_eval₂, ← evalAtJqN_def]
+  exact hswap
+
+p2m_export "ModularCurve.ModularPolynomialData" "aeval_jqN_transposeToAdjoin"
+
+private theorem _root_.ModularCurve.ModularPolynomialData.swapBivar_eq_of_irreducible (hirr :
+  PhiIrreducible data)
+    (hswap : data.Φ.eval₂ (evalAtJqN N) jq = 0)
+    (hTmonic : ((swapBivar data.Φ).map evalAtJGen).Monic)
+    (hTdeg : ((swapBivar data.Φ).map evalAtJGen).natDegree ≤ dedekindPsi N) :
+    swapBivar data.Φ = data.Φ := by
+  apply Polynomial.map_injective evalAtJGen evalAtJGen_injective
+  change (swapBivar data.Φ).map evalAtJGen = data.toAdjoin
+  have hdvd : data.toAdjoin ∣ (swapBivar data.Φ).map evalAtJGen := by
+    rw [← data.minpoly_jqN_eq hirr]
+    exact minpoly.dvd _ _ (data.aeval_jqN_transposeToAdjoin hswap)
+  refine eq_of_monic_of_dvd_of_natDegree_le data.toAdjoin_monic hTmonic hdvd ?_
+  rw [toAdjoin, data.monic.natDegree_map, data.natDegree_eq]
+  exact hTdeg
+
+p2m_export "ModularCurve.ModularPolynomialData" "swapBivar_eq_of_irreducible"
+
+private theorem _root_.ModularCurve.ModularPolynomialData.evalSymm_of_irreducible (hirr :
+  PhiIrreducible data)
+    (hswap : data.Φ.eval₂ (evalAtJqN N) jq = 0)
+    (hTmonic : ((swapBivar data.Φ).map evalAtJGen).Monic)
+    (hTdeg : ((swapBivar data.Φ).map evalAtJGen).natDegree ≤ dedekindPsi N) :
+    EvalSymm data.Φ :=
+  evalSymm_of_swapBivar_eq (data.swapBivar_eq_of_irreducible hirr hswap hTmonic hTdeg)
+
+p2m_export "ModularCurve.ModularPolynomialData" "evalSymm_of_irreducible"
+end ModularPolynomialData
+
+section Engine
+
+private theorem swapBivar_C (c : Polynomial ℤ) :
+    swapBivar (Polynomial.C c) = c.map Polynomial.C := by
+  have hext : swapBivar.comp (Polynomial.C : Polynomial ℤ →+* Polynomial (Polynomial ℤ))
+      = Polynomial.mapRingHom (Polynomial.C : ℤ →+* Polynomial ℤ) := by
+    refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+    change swapBivar (Polynomial.C Polynomial.X)
+      = Polynomial.mapRingHom (Polynomial.C : ℤ →+* Polynomial ℤ) Polynomial.X
+    rw [swapBivar_C_X, Polynomial.coe_mapRingHom, Polynomial.map_X]
+  calc swapBivar (Polynomial.C c)
+      = swapBivar.comp (Polynomial.C : Polynomial ℤ →+* Polynomial (Polynomial ℤ)) c := rfl
+    _ = Polynomial.mapRingHom (Polynomial.C : ℤ →+* Polynomial ℤ) c := by rw [hext]
+    _ = c.map Polynomial.C := rfl
+
+private theorem degree_swapBivar_lt {Ψ : Polynomial (Polynomial ℤ)} {D : ℕ}
+    (h : ∀ k, (Ψ.coeff k).degree < (D : WithBot ℕ)) :
+    (swapBivar Ψ).degree < (D : WithBot ℕ) := by
+  conv_lhs => rw [Polynomial.as_sum_support_C_mul_X_pow Ψ, map_sum]
+  refine (Polynomial.degree_sum_le _ _).trans_lt
+    ((Finset.sup_lt_iff (WithBot.bot_lt_coe D)).2 fun k _ => ?_)
+  rw [map_mul, map_pow, swapBivar_C, swapBivar_X, ← map_pow]
+  refine lt_of_le_of_lt (le_trans (Polynomial.degree_mul_le _ _) ?_) (h k)
+  calc ((Ψ.coeff k).map Polynomial.C).degree + (Polynomial.C (Polynomial.X ^ k)).degree
+      ≤ (Ψ.coeff k).degree + 0 := by
+        gcongr
+        · exact le_of_eq (Polynomial.degree_map_eq_of_injective Polynomial.C_injective _)
+        · exact Polynomial.degree_C_le
+    _ = (Ψ.coeff k).degree := add_zero _
+
+theorem swapBivar_monic_of_coeff_bounds {Φ : Polynomial (Polynomial ℤ)} {d : ℕ}
+    (h0 : (Φ.coeff 0).Monic) (h0deg : (Φ.coeff 0).natDegree = d)
+    (hk : ∀ k, k ≠ 0 → (Φ.coeff k).degree < (d : WithBot ℕ)) :
+    (swapBivar Φ).Monic ∧ (swapBivar Φ).natDegree = d := by
+  have hsplit : swapBivar Φ = Polynomial.C Polynomial.X * swapBivar Φ.divX
+      + (Φ.coeff 0).map Polynomial.C := by
+    conv_lhs => rw [← Polynomial.X_mul_divX_add Φ]
+    rw [map_add, map_mul, swapBivar_X, swapBivar_C]
+  have hmap : ((Φ.coeff 0).map Polynomial.C).Monic := h0.map _
+  have hmapdeg : ((Φ.coeff 0).map Polynomial.C).degree = (d : WithBot ℕ) := by
+    rw [Polynomial.degree_eq_natDegree hmap.ne_zero, h0.natDegree_map, h0deg]
+  have hsmall : (Polynomial.C Polynomial.X * swapBivar Φ.divX).degree
+      < (d : WithBot ℕ) := by
+    refine lt_of_le_of_lt (Polynomial.degree_mul_le _ _) ?_
+    have hX : (Polynomial.C (Polynomial.X : Polynomial ℤ)).degree = 0 :=
+      Polynomial.degree_C Polynomial.X_ne_zero
+    rw [hX, zero_add]
+    exact degree_swapBivar_lt fun k => by
+      rw [Polynomial.coeff_divX]; exact hk (k + 1) (Nat.succ_ne_zero k)
+  have hlt : (Polynomial.C Polynomial.X * swapBivar Φ.divX).degree
+      < ((Φ.coeff 0).map Polynomial.C).degree := by rw [hmapdeg]; exact hsmall
+  refine ⟨?_, ?_⟩
+  · rw [hsplit]; exact hmap.add_of_right hlt
+  · rw [hsplit, Polynomial.natDegree_eq_of_degree_eq
+      (Polynomial.degree_add_eq_right_of_degree_lt hlt), h0.natDegree_map, h0deg]
+
+end Engine
+
+section Dictionary
+
+private theorem evalAtJ_eq_aeval_map_rat (P : Polynomial ℤ) :
+    evalAtJ P = Polynomial.aeval jq (P.map (Int.castRingHom ℚ)) := by
+  rw [evalAtJ_def, Polynomial.aeval_def, Polynomial.eval₂_map, Subsingleton.elim
+    ((algebraMap ℚ (LaurentSeries ℚ)).comp (Int.castRingHom ℚ))
+    (algebraMap ℤ (LaurentSeries ℚ))]
+  rfl
+
+private theorem coeff_aeval_jq_neg (P : Polynomial ℚ) {m : ℕ} (hm : P.natDegree ≤ m) :
+    (Polynomial.aeval jq P).coeff (-(m : ℤ)) = P.coeff m := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+    Finset.sum_eq_single m]
+  · rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_self,
+      mul_one]
+  · intro i hi hin
+    have hilt : i < m :=
+      lt_of_le_of_ne (le_trans (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hm) hin
+    rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul,
+      coeff_jq_pow_of_lt (by omega), mul_zero]
+  · intro hm'
+    rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul,
+      Polynomial.coeff_eq_zero_of_natDegree_lt
+        (by simp only [Finset.mem_range, not_lt] at hm'; omega),
+      zero_mul]
+
+private theorem degree_lt_of_evalAtJ_coeff_eq_zero {P : Polynomial ℤ} {D : ℕ}
+    (h : ∀ m : ℕ, D ≤ m → (evalAtJ P).coeff (-(m : ℤ)) = 0) :
+    P.degree < (D : WithBot ℕ) := by
+  rcases eq_or_ne P 0 with rfl | hP0
+  · rw [Polynomial.degree_zero]; exact WithBot.bot_lt_coe D
+  rw [← Polynomial.natDegree_lt_iff_degree_lt hP0]
+  by_contra hle
+  rw [not_lt] at hle
+  have hQdeg : (P.map (Int.castRingHom ℚ)).natDegree = P.natDegree :=
+    Polynomial.natDegree_map_eq_of_injective Int.cast_injective P
+  have hcoeff := coeff_aeval_jq_neg (P.map (Int.castRingHom ℚ)) (m := P.natDegree) hQdeg.le
+  rw [← evalAtJ_eq_aeval_map_rat, h P.natDegree hle, Polynomial.coeff_map,
+    eq_intCast] at hcoeff
+  have hlead : P.coeff P.natDegree = 0 := by exact_mod_cast hcoeff.symm
+  exact hP0 (Polynomial.leadingCoeff_eq_zero.mp hlead)
+
+private theorem monic_of_evalAtJ_coeff_eq_one {P : Polynomial ℤ} {D : ℕ}
+    (hle : P.natDegree ≤ D) (h1 : (evalAtJ P).coeff (-(D : ℤ)) = 1) :
+    P.Monic ∧ P.natDegree = D := by
+  have hQdeg : (P.map (Int.castRingHom ℚ)).natDegree = P.natDegree :=
+    Polynomial.natDegree_map_eq_of_injective Int.cast_injective P
+  have hcoeff := coeff_aeval_jq_neg (P.map (Int.castRingHom ℚ)) (m := D) (hQdeg.le.trans hle)
+  rw [← evalAtJ_eq_aeval_map_rat, h1, Polynomial.coeff_map, eq_intCast] at hcoeff
+  have hPD : P.coeff D = 1 := by exact_mod_cast hcoeff.symm
+  have hge : D ≤ P.natDegree :=
+    Polynomial.le_natDegree_of_ne_zero (by rw [hPD]; exact one_ne_zero)
+  exact ⟨Polynomial.monic_of_natDegree_le_of_coeff_eq_one D hle hPD, le_antisymm hle hge⟩
+
+private theorem natDegree_le_of_evalAtJ_coeff_eq_zero {P : Polynomial ℤ} {D : ℕ}
+    (h : ∀ m : ℕ, D < m → (evalAtJ P).coeff (-(m : ℤ)) = 0) :
+    P.natDegree ≤ D := by
+  rcases eq_or_ne P 0 with rfl | hP0
+  · simp
+  by_contra hlt
+  rw [not_le] at hlt
+  have hdeg := degree_lt_of_evalAtJ_coeff_eq_zero (P := P) (D := D + 1)
+    (fun m hm => h m (by omega))
+  rw [← Polynomial.natDegree_lt_iff_degree_lt hP0] at hdeg
+  omega
+
+end Dictionary
+
+namespace ModularPolynomialData
+p2m_export "ModularCurve.ModularPolynomialData" "toAdjoin toAdjoin_monic monic eval_eq_zero \
+  natDegree_eq Φ"
+p2m_open "ModularCurve.ModularPolynomialData"
+
+variable {N : ℕ} [NeZero N] (data : ModularPolynomialData N)
+
+private theorem _root_.ModularCurve.ModularPolynomialData.transposeToAdjoin_monic_of_coeff_bounds
+    (h0 : (data.Φ.coeff 0).Monic) (h0deg : (data.Φ.coeff 0).natDegree = dedekindPsi N)
+    (hk : ∀ k, k ≠ 0 → (data.Φ.coeff k).degree < (dedekindPsi N : WithBot ℕ)) :
+    ((swapBivar data.Φ).map evalAtJGen).Monic ∧
+      ((swapBivar data.Φ).map evalAtJGen).natDegree = dedekindPsi N := by
+  obtain ⟨hmonic, hdeg⟩ := swapBivar_monic_of_coeff_bounds h0 h0deg hk
+  exact ⟨hmonic.map _, by rw [hmonic.natDegree_map, hdeg]⟩
+
+p2m_export "ModularCurve.ModularPolynomialData" "transposeToAdjoin_monic_of_coeff_bounds"
+
+theorem transposeToAdjoin_monic_of_qExpansion
+    (h0top : (evalAtJ (data.Φ.coeff 0)).coeff (-(dedekindPsi N : ℤ)) = 1)
+    (h0le : ∀ m : ℕ, dedekindPsi N < m → (evalAtJ (data.Φ.coeff 0)).coeff (-(m : ℤ)) = 0)
+    (hk : ∀ k, k ≠ 0 → ∀ m : ℕ, dedekindPsi N ≤ m →
+      (evalAtJ (data.Φ.coeff k)).coeff (-(m : ℤ)) = 0) :
+    ((swapBivar data.Φ).map evalAtJGen).Monic ∧
+      ((swapBivar data.Φ).map evalAtJGen).natDegree = dedekindPsi N := by
+  obtain ⟨h0monic, h0deg⟩ := monic_of_evalAtJ_coeff_eq_one
+    (natDegree_le_of_evalAtJ_coeff_eq_zero h0le) h0top
+  exact data.transposeToAdjoin_monic_of_coeff_bounds h0monic h0deg
+    fun k hk0 => degree_lt_of_evalAtJ_coeff_eq_zero (hk k hk0)
+
+end ModularPolynomialData
+
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd phiProd_eval_conj"
+p2m_open "ModularCurve.PhiGen"
+
+section Swap
+
+variable {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+
+theorem eval_swap_eq_zero_of_splits (data : ModularPolynomialData ℓ)
+    (hsplit : data.Φ.map (((coeffEmb K).comp (qExpand ℚ ℓ)).comp evalAtJ)
+      = phiProd ℓ (conj ℓ ζ)) :
+    data.Φ.eval₂ (evalAtJqN ℓ) jq = 0 := by
+  rw [coeffEmb_comp_qExpand_comp_evalAtJ K ℓ] at hsplit
+  have h1 : data.Φ.eval₂ ((qEmbedT K ℓ).comp evalAtJ) (coeffEmb K jq) = 0 := by
+    rw [← Polynomial.eval_map, hsplit, ← conj_succ_zero K ℓ ζ, phiProd,
+      Polynomial.eval_prod]
+    exact Finset.prod_eq_zero (Finset.mem_univ ((0 : Fin ℓ).succ)) (by simp)
+  have h2 : data.Φ.eval₂ ((qExpand K ℓ).comp ((qEmbedT K ℓ).comp evalAtJ))
+      (qExpand K ℓ (coeffEmb K jq)) = 0 := by
+    have h := congrArg (qExpand K ℓ) h1
+    rwa [Polynomial.hom_eval₂, map_zero] at h
+  apply qEmbedT_injective K ℓ
+  rw [map_zero, Polynomial.hom_eval₂, qEmbedT_jq]
+  have hhom : (qEmbedT K ℓ).comp (evalAtJqN ℓ)
+      = (qExpand K ℓ).comp ((qEmbedT K ℓ).comp evalAtJ) := by
+    refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+    change qEmbedT K ℓ (evalAtJqN ℓ Polynomial.X)
+      = qExpand K ℓ (qEmbedT K ℓ (evalAtJ Polynomial.X))
+    rw [evalAtJqN_X, evalAtJ_X, qEmbedT_jq, qEmbedT_jqN K ℓ ζ, conj_zero, qExpand_qExpand]
+  rw [hhom]
+  exact h2
+
+theorem evalSymm_of_splits
+    (hpos : ∀ n : ℕ, (1 : ℚ) ≤ jq.coeff (n : ℤ)) (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (data : ModularPolynomialData ℓ)
+    (hsplit : data.Φ.map (((coeffEmb K).comp (qExpand ℚ ℓ)).comp evalAtJ)
+      = phiProd ℓ (conj ℓ ζ))
+    (hTmonic : ((swapBivar data.Φ).map evalAtJGen).Monic)
+    (hTdeg : ((swapBivar data.Φ).map evalAtJGen).natDegree ≤ dedekindPsi ℓ) :
+    EvalSymm data.Φ :=
+  data.evalSymm_of_irreducible (phiIrreducible_of_splits ℓ ζ hpos hζ data hsplit)
+    (eval_swap_eq_zero_of_splits ℓ ζ data hsplit) hTmonic hTdeg
+
+end Swap
+
+end PhiGen
+
+end ModularCurve
+end
+
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_PhiGen_phiIrreducible_of_splits.ModularCurve
+  _root_.ModularCurve.PhiGen
+  _root_.P2MW.S_ModularCurve_PhiGen_phiIrreducible_of_splits.ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) ℓ) (data : ModularPolynomialData ℓ)
+    (hsplit : data.Φ.map (((coeffEmb K).comp (qExpand ℚ ℓ)).comp evalAtJ) = phiProd ℓ (conj ℓ ζ)) :
+    PhiIrreducible data :=
+  ModularCurve.PhiGen.phiIrreducible_of_splits ℓ ζ ModularCurve.one_le_coeff_jq hζ data hsplit
+
+end S_ModularCurve_PhiGen_phiIrreducible_of_splits
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_phiIrreducible_of_splits (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.phiIrreducible_of_splits {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ)
+    [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (data : ModularPolynomialData ℓ)
+    (hsplit : data.Φ.map (((coeffEmb K).comp (qExpand ℚ ℓ)).comp evalAtJ) = phiProd ℓ (conj ℓ ζ)) :
+    PhiIrreducible data :=
+  solution ℓ ζ hζ data hsplit
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_phiProd_conj_coeff_eq_zero_of_le.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_phiProd_conj_coeff_eq_zero_of_le.lean
new file mode 100644
index 0000000000..824b3d9a28
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_phiProd_conj_coeff_eq_zero_of_le.lean
@@ -0,0 +1,451 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.phiProd_conj_coeff_eq_zero_of_le
+(7c7804df-0623-5cbc-97b2-60df6540bc6b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2894f3fb-ffbb-5690-86f5-f341fa8a78ac
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import Mathlib.Algebra.BigOperators.Fin
+import Mathlib.Algebra.BigOperators.Intervals
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.Tactic.Linarith
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Pole bound for the non-constant coefficients of phiProd
+
+Theorem statement: `ModularCurve.PhiGen.phiProd_conj_coeff_eq_zero_of_le`
+(`7c7804df-0623-5cbc-97b2-60df6540bc6b`), by Claude, 2026-09-05.
+
+Proof: submission `2894f3fb-ffbb-5690-86f5-f341fa8a78ac`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field equipped with a $\mathbb{Q}$-algebra structure, let $\ell$ be a prime natural
+number, and let $\zeta$ be a unit of $K$. For $i$ in $\mathrm{Fin}(\ell+1)$ put $a_i = \ell$ and
+$b_i = 0$ when $i = 0$, and $a_i = 1$ and $b_i = i - 1$ otherwise, and let
+$\mathrm{conj}\,\ell\,\zeta\,i$ be the Laurent series over $K$ obtained from the rational Laurent
+series `jq`, pushed forward coefficientwise along $\mathbb{Q} \to K$, by applying `qTwist (ζ ^ (a *
+b))` followed by `qExpand K (a * a)` with $a = a_i$, $b = b_i$. Let
+$\mathrm{phiProd}\,\ell\,(\mathrm{conj}\,\ell\,\zeta) = \prod_{i} (X -
+C(\mathrm{conj}\,\ell\,\zeta\,i))$ be the corresponding monic polynomial of degree $\ell+1$ in $X$
+with coefficients in the field of Laurent series over $K$. Then for every natural number $k \neq 0$
+and every natural number $m$ with $\ell^2 + \ell \le m$, the coefficient of $t^{-m}$ in the
+$X^k$-coefficient of this product vanishes.
+
+This is the coefficientwise form of the bound on the order of the pole at the cusp of the
+non-leading coefficients of the modular-equation-type polynomial $\prod_i (X -
+\mathrm{conj}\,\ell\,\zeta\,i)$: each such coefficient, a Laurent series in $t$, has pole order
+strictly less than $\ell^2 + \ell$. It supplies the degree input used by
+[`ModularCurve.PhiGen.evalSymm_of_coeff_evalAtJ_eq`]
+(thm.html#ModularCurve.PhiGen.evalSymm_of_coeff_evalAtJ_eq)
+when the symmetric functions of the conjugates are expressed through the $j$-series.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_phiProd_conj_coeff_eq_zero_of_le.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_phiProd_conj_coeff_eq_zero_of_le
+
+noncomputable section
+
+open Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd jq coeff_jq_neg_one \
+  coeff_jq_of_lt qTwist qTwist_coeff coeffEmb coeffEmb_coeff"
+p2m_open "ModularCurve"
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd TPoleOrderLE JSimplePole"
+p2m_open "ModularCurve.PhiGen"
+
+section CoeffEmbJq
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+private theorem coeff_coeffEmb_jq_neg_one : (coeffEmb K jq).coeff (-1 : ℤ) = 1 := by
+  rw [coeffEmb_coeff, coeff_jq_neg_one, map_one]
+
+private theorem coeff_coeffEmb_jq_of_lt {k : ℤ} (hk : k < -1) : (coeffEmb K jq).coeff k = 0 := by
+  rw [coeffEmb_coeff, coeff_jq_of_lt hk, map_zero]
+
+end CoeffEmbJq
+
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.mono {K : Type*} [Field K]
+    {f : LaurentSeries K} {m n : ℕ}
+    (hf : TPoleOrderLE f m) (hmn : m ≤ n) : TPoleOrderLE f n :=
+  fun k hk => hf k (by omega)
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.mono"
+private theorem tPoleOrderLE_zero {K : Type*} [Field K] (n : ℕ) :
+    TPoleOrderLE (0 : LaurentSeries K) n :=
+  fun _ _ => rfl
+
+private theorem tPoleOrderLE_one {K : Type*} [Field K] :
+    TPoleOrderLE (1 : LaurentSeries K) 0 := by
+  intro m hm
+  rw [HahnSeries.coeff_one, ite_eq_right (by omega)]
+
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.neg {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) : TPoleOrderLE (-f) n := by
+  intro m hm
+  rw [HahnSeries.coeff_neg, hf m hm, neg_zero]
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.neg"
+private theorem TPoleOrderLE.add {K : Type*} [Field K] {f g : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) (hg : TPoleOrderLE g n) : TPoleOrderLE (f + g) n := by
+  intro m hm
+  rw [HahnSeries.coeff_add, hf m hm, hg m hm, add_zero]
+
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.mul {K : Type*} [Field K]
+    {f g : LaurentSeries K} {m n : ℕ}
+    (hf : TPoleOrderLE f m) (hg : TPoleOrderLE g n) : TPoleOrderLE (f * g) (m + n) := by
+  intro k hk
+  rw [HahnSeries.coeff_mul]
+  refine Finset.sum_eq_zero fun ij hij => ?_
+  obtain ⟨-, -, hsum⟩ := Finset.mem_antidiagonal.mp hij
+  by_cases hi : ij.1 < -(m : ℤ)
+  · rw [hf ij.1 hi, zero_mul]
+  · refine mul_eq_zero_of_right _ (hg ij.2 ?_)
+    push_cast at hk
+    omega
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.mul"
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.qTwist {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) (u : Kˣ) : TPoleOrderLE (ModularCurve.qTwist u f) n := by
+  intro m hm
+  rw [qTwist_coeff, hf m hm, mul_zero]
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.qTwist"
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.qExpand {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) (N : ℕ) [NeZero N] :
+    TPoleOrderLE (ModularCurve.qExpand K N f) (N * n) := by
+  intro m hm
+  by_cases hdvd : (N : ℤ) ∣ m
+  · obtain ⟨c, rfl⟩ := hdvd
+    rw [qExpand_coeff_mul]
+    refine hf c ?_
+    have hN : 0 < (N : ℤ) := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+    push_cast at hm
+    nlinarith
+  · exact qExpand_coeff_of_not_dvd N f hdvd
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.qExpand"
+private theorem tPoleOrderLE_of_jSimplePole {K : Type*} [Field K] (J : LaurentSeries K)
+    (hJ : JSimplePole J) : TPoleOrderLE J 1 := by
+  intro m hm
+  exact hJ m (by push_cast at hm; omega)
+
+private def conjPoleBound (ℓ : ℕ) : Fin (ℓ + 1) → ℕ :=
+  fun i => if i = 0 then ℓ * ℓ else 1
+
+private theorem conjPoleBound_zero (ℓ : ℕ) : conjPoleBound ℓ 0 = ℓ * ℓ := ite_eq_left rfl
+
+private theorem conjPoleBound_succ (ℓ : ℕ) (b : Fin ℓ) : conjPoleBound ℓ b.succ = 1 :=
+  ite_eq_right (Fin.succ_ne_zero b)
+
+private theorem sum_conjPoleBound (ℓ : ℕ) :
+    ∑ i : Fin (ℓ + 1), conjPoleBound ℓ i = ℓ * ℓ + ℓ := by
+  rw [Fin.sum_univ_succ, conjPoleBound_zero]
+  congr 1
+  simp only [conjPoleBound_succ]
+  simp
+
+private theorem tPoleOrderLE_conj_zero {K : Type*} [Field K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {J : LaurentSeries K}
+    {conj : Fin (ℓ + 1) → LaurentSeries K} (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hJ : JSimplePole J) : TPoleOrderLE (conj 0) (ℓ * ℓ) := by
+  rw [hconj0]
+  have h := (tPoleOrderLE_of_jSimplePole J hJ).qExpand (ℓ * ℓ)
+  simpa using h
+
+private theorem tPoleOrderLE_conj_succ {K : Type*} [Field K] {ℓ : ℕ} {ζ : Kˣ}
+    {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (b : Fin ℓ) : TPoleOrderLE (conj b.succ) 1 := by
+  rw [hconjS b]
+  exact (tPoleOrderLE_of_jSimplePole J hJ).qTwist _
+
+private theorem tPoleOrderLE_conj {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+    {ζ : Kˣ} {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (i : Fin (ℓ + 1)) :
+    TPoleOrderLE (conj i) (conjPoleBound ℓ i) := by
+  rcases Fin.eq_zero_or_eq_succ i with rfl | ⟨b, rfl⟩
+  · rw [conjPoleBound_zero]
+    exact tPoleOrderLE_conj_zero hconj0 hJ
+  · rw [conjPoleBound_succ]
+    exact tPoleOrderLE_conj_succ hconjS hJ b
+
+private theorem tPoleOrderLE_coeff_X_sub_C {K : Type*} [Field K] {a : LaurentSeries K}
+    {n : ℕ} (ha : TPoleOrderLE a n) (k : ℕ) :
+    TPoleOrderLE ((Polynomial.X - Polynomial.C a).coeff k) n := by
+  match k with
+  | 0 =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X_zero, Polynomial.coeff_C_zero,
+      zero_sub]
+    exact ha.neg
+  | 1 =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X_one, Polynomial.coeff_C,
+      ite_eq_right (one_ne_zero), sub_zero]
+    exact tPoleOrderLE_one.mono (Nat.zero_le _)
+  | (k + 2) =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X, Polynomial.coeff_C]
+    rw [ite_eq_right (by omega), ite_eq_right (by omega), sub_zero]
+    exact tPoleOrderLE_zero _
+
+private theorem phiProd_def {K : Type*} [Field K] (ℓ : ℕ)
+    (conj : Fin (ℓ + 1) → LaurentSeries K) :
+    phiProd ℓ conj = ∏ i : Fin (ℓ + 1), (Polynomial.X - Polynomial.C (conj i)) := rfl
+
+theorem tPoleOrderLE_prod {K : Type*} [Field K] {ι : Type*} (s : Finset ι)
+    (f : ι → LaurentSeries K) (n : ι → ℕ) (hf : ∀ i ∈ s, TPoleOrderLE (f i) (n i)) :
+    TPoleOrderLE (∏ i ∈ s, f i) (∑ i ∈ s, n i) := by
+  induction s using Finset.cons_induction with
+  | empty => simpa using tPoleOrderLE_one
+  | cons a s ha ih =>
+    rw [Finset.prod_cons, Finset.sum_cons]
+    exact (hf a (Finset.mem_cons_self a s)).mul
+      (ih fun i hi => hf i (Finset.mem_cons_of_mem hi))
+
+theorem coeff_mul_lead {K : Type*} [Field K] {f g : LaurentSeries K} {m n : ℕ}
+    (hf : TPoleOrderLE f m) (hg : TPoleOrderLE g n) :
+    (f * g).coeff (-((m + n : ℕ) : ℤ)) = f.coeff (-(m : ℤ)) * g.coeff (-(n : ℤ)) := by
+  rw [HahnSeries.coeff_mul]
+  refine Finset.sum_eq_single ((-(m : ℤ), -(n : ℤ))) ?_ ?_
+  · rintro ⟨i, j⟩ hij hne
+    obtain ⟨hi, hj, hsum⟩ := Finset.mem_antidiagonal.mp hij
+    rw [HahnSeries.mem_support] at hi hj
+    have him : ¬ i < -(m : ℤ) := fun h => hi (hf i h)
+    have hjn : ¬ j < -(n : ℤ) := fun h => hj (hg j h)
+    push_cast at hsum
+    have hi' : i = -(m : ℤ) := by omega
+    have hj' : j = -(n : ℤ) := by omega
+    exact absurd (by rw [hi', hj']) hne
+  · intro hni
+    by_contra hne
+    refine hni (Finset.mem_antidiagonal.mpr ⟨?_, ?_, by push_cast; ring⟩) <;>
+      rw [HahnSeries.mem_support]
+    · exact fun h0 => hne (by rw [h0, zero_mul])
+    · exact fun h0 => hne (by rw [h0, mul_zero])
+
+theorem coeff_prod_lead {K : Type*} [Field K] {ι : Type*} (s : Finset ι)
+    (f : ι → LaurentSeries K) (n : ι → ℕ) (hf : ∀ i ∈ s, TPoleOrderLE (f i) (n i)) :
+    (∏ i ∈ s, f i).coeff (-((∑ i ∈ s, n i : ℕ) : ℤ)) =
+      ∏ i ∈ s, (f i).coeff (-(n i : ℤ)) := by
+  induction s using Finset.cons_induction with
+  | empty => simp
+  | cons a s ha ih =>
+    rw [Finset.prod_cons, Finset.sum_cons, Finset.prod_cons,
+      coeff_mul_lead (hf a (Finset.mem_cons_self a s))
+        (tPoleOrderLE_prod s f n fun i hi => hf i (Finset.mem_cons_of_mem hi)),
+      ih fun i hi => hf i (Finset.mem_cons_of_mem hi)]
+
+theorem pow_sum_range_isPrimitiveRoot {K : Type*} [Field K] {ℓ : ℕ} (hℓ : Nat.Prime ℓ)
+    {z : K} (hz : IsPrimitiveRoot z ℓ) :
+    z ^ (∑ i ∈ Finset.range ℓ, i) = (-1) ^ (ℓ + 1) := by
+  rcases hℓ.eq_two_or_odd' with rfl | hodd
+  · rw [hz.eq_neg_one_of_two_right]
+    norm_num [Finset.sum_range_succ]
+  · obtain ⟨m, hm⟩ := hodd
+    have hsum : ∑ i ∈ Finset.range ℓ, i = ℓ * m := by
+      have h2 := Finset.sum_range_id_mul_two ℓ
+      have hℓ1 : ℓ - 1 = 2 * m := by omega
+      rw [hℓ1, show ℓ * (2 * m) = ℓ * m * 2 by ring] at h2
+      omega
+    rw [hsum, pow_mul, hz.pow_eq_one, one_pow]
+    exact (Even.neg_one_pow ⟨m + 1, by omega⟩).symm
+
+theorem prod_inv_pow_isPrimitiveRoot {K : Type*} [Field K] {ℓ : ℕ} (hℓ : Nat.Prime ℓ)
+    {z : K} (hz : IsPrimitiveRoot z ℓ) :
+    ∏ b : Fin ℓ, ((z ^ (b : ℕ))⁻¹ : K) = (-1) ^ (ℓ + 1) := by
+  have hsum : (∑ b : Fin ℓ, (b : ℕ)) = ∑ i ∈ Finset.range ℓ, i :=
+    Fin.sum_univ_eq_sum_range (fun i => i) ℓ
+  rw [Finset.prod_inv_distrib, Finset.prod_pow_eq_pow_sum, hsum,
+    pow_sum_range_isPrimitiveRoot hℓ hz, ← inv_pow, inv_neg, inv_one]
+
+theorem phiProd_coeff_zero_eq_prod_neg {K : Type*} [Field K] {ℓ : ℕ}
+    {conj : Fin (ℓ + 1) → LaurentSeries K} :
+    (phiProd ℓ conj).coeff 0 = ∏ i : Fin (ℓ + 1), (-(conj i)) := by
+  rw [phiProd_def, Polynomial.coeff_zero_eq_eval_zero, Polynomial.eval_prod]
+  exact Finset.prod_congr rfl fun i _ => by
+    rw [Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, zero_sub]
+
+theorem conj_zero_coeff_lead {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+    {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J) (hJlead : J.coeff (-1 : ℤ) = 1) :
+    (conj 0).coeff (-((ℓ * ℓ : ℕ) : ℤ)) = 1 := by
+  rw [hconj0, show (-((ℓ * ℓ : ℕ) : ℤ)) = ((ℓ * ℓ : ℕ) : ℤ) * (-1 : ℤ) by ring,
+    qExpand_coeff_mul, hJlead]
+
+theorem conj_succ_coeff_lead {K : Type*} [Field K] {ℓ : ℕ} {ζ : Kˣ}
+    {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJlead : J.coeff (-1 : ℤ) = 1) (b : Fin ℓ) :
+    (conj b.succ).coeff (-(1 : ℤ)) = (((ζ : K) ^ (b : ℕ))⁻¹ : K) := by
+  rw [hconjS b, qTwist_coeff, hJlead, mul_one, zpow_neg_one, ← Units.val_pow_eq_pow_val,
+    ← Units.val_inv_eq_inv_val]
+
+theorem phiProd_coeff_zero_lead {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+    {ζ : Kˣ} {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (hJlead : J.coeff (-1 : ℤ) = 1) :
+    ((phiProd ℓ conj).coeff 0).coeff (-((ℓ * ℓ + ℓ : ℕ) : ℤ)) = 1 := by
+  rw [phiProd_coeff_zero_eq_prod_neg, ← sum_conjPoleBound ℓ,
+    coeff_prod_lead Finset.univ _ (conjPoleBound ℓ)
+      (fun i _ => (tPoleOrderLE_conj hconj0 hconjS hJ i).neg),
+    Fin.prod_univ_succ]
+  have h0 : (-(conj 0)).coeff (-((conjPoleBound ℓ 0 : ℕ) : ℤ)) = -1 := by
+    rw [HahnSeries.coeff_neg, conjPoleBound_zero, conj_zero_coeff_lead hconj0 hJlead]
+  have hS : ∀ b : Fin ℓ, (-(conj b.succ)).coeff (-((conjPoleBound ℓ b.succ : ℕ) : ℤ)) =
+      -((((ζ : K) ^ (b : ℕ))⁻¹ : K)) := by
+    intro b
+    rw [HahnSeries.coeff_neg, conjPoleBound_succ, Nat.cast_one,
+      conj_succ_coeff_lead hconjS hJlead b]
+  rw [h0]
+  simp only [hS]
+  rw [Finset.prod_neg, Finset.card_univ, Fintype.card_fin,
+    prod_inv_pow_isPrimitiveRoot hℓ.out hζ, ← pow_add, ← pow_succ']
+  exact Even.neg_one_pow ⟨ℓ + 1, by ring⟩
+
+theorem tPoleOrderLE_coeff_prod_X_sub_C_card {K : Type*} [Field K] {ι : Type*}
+    (s : Finset ι) (a : ι → LaurentSeries K) (ha : ∀ i ∈ s, TPoleOrderLE (a i) 1) :
+    ∀ k : ℕ, TPoleOrderLE ((∏ i ∈ s, (Polynomial.X - Polynomial.C (a i))).coeff k)
+      (s.card - k) := by
+  induction s using Finset.cons_induction with
+  | empty =>
+    intro k
+    rcases Nat.eq_zero_or_pos k with rfl | hk
+    · simpa using tPoleOrderLE_one
+    · rw [Finset.prod_empty, Polynomial.coeff_one, ite_eq_right (by omega)]
+      exact tPoleOrderLE_zero _
+  | cons a₀ s ha₀ ih =>
+    intro k
+    have hmem : ∀ i ∈ s, TPoleOrderLE (a i) 1 :=
+      fun i hi => ha i (Finset.mem_cons_of_mem hi)
+    rw [Finset.prod_cons, Finset.card_cons]
+    match k with
+    | 0 =>
+      rw [Polynomial.mul_coeff_zero]
+      exact ((tPoleOrderLE_coeff_X_sub_C (ha a₀ (Finset.mem_cons_self a₀ s)) 0).mul
+        (ih hmem 0)).mono (by omega)
+    | (k + 1) =>
+      rw [sub_mul, Polynomial.coeff_sub, Polynomial.coeff_X_mul, Polynomial.coeff_C_mul,
+        sub_eq_add_neg]
+      refine TPoleOrderLE.add ?_ (TPoleOrderLE.neg ?_)
+      · exact (ih hmem k).mono (by omega)
+      · by_cases hks : k + 1 ≤ s.card
+        · exact ((ha a₀ (Finset.mem_cons_self a₀ s)).mul (ih hmem (k + 1))).mono
+            (by omega)
+        · rw [Polynomial.coeff_eq_zero_of_natDegree_lt, mul_zero]
+          · exact tPoleOrderLE_zero _
+          · rw [Polynomial.natDegree_prod_of_monic _ _
+              (fun i _ => Polynomial.monic_X_sub_C (a i))]
+            simp only [Polynomial.natDegree_X_sub_C, ← Finset.card_eq_sum_ones]
+            omega
+
+theorem tPoleOrderLE_phiProd_coeff_of_ne_zero {K : Type*} [Field K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {J : LaurentSeries K}
+    {conj : Fin (ℓ + 1) → LaurentSeries K} (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (k : ℕ) (hk : k ≠ 0) :
+    TPoleOrderLE ((phiProd ℓ conj).coeff k) (ℓ * ℓ + ℓ - 1) := by
+  obtain ⟨k, rfl⟩ := Nat.exists_eq_succ_of_ne_zero hk
+  have hℓ2 : 2 ≤ ℓ := hℓ.out.two_le
+  have hsq : 4 ≤ ℓ * ℓ := Nat.mul_le_mul hℓ2 hℓ2
+  rw [phiProd_def, Fin.prod_univ_succ, sub_mul, Polynomial.coeff_sub,
+    Polynomial.coeff_X_mul, Polynomial.coeff_C_mul, sub_eq_add_neg]
+  have hR : ∀ j : ℕ, TPoleOrderLE
+      ((∏ b : Fin ℓ, (Polynomial.X - Polynomial.C (conj b.succ))).coeff j)
+      (Finset.univ.card - j) :=
+    tPoleOrderLE_coeff_prod_X_sub_C_card Finset.univ _
+      (fun b _ => tPoleOrderLE_conj_succ hconjS hJ b)
+  rw [Finset.card_univ, Fintype.card_fin] at hR
+  refine TPoleOrderLE.add ?_ (TPoleOrderLE.neg ?_)
+  · exact (hR k).mono (by omega)
+  · exact ((tPoleOrderLE_conj_zero hconj0 hJ).mul (hR (k + 1))).mono (by omega)
+
+theorem jSimplePole_jqK_carrier {K : Type*} [Field K] [Algebra ℚ K] :
+    JSimplePole (coeffEmb K jq) :=
+  fun _ hm => coeff_coeffEmb_jq_of_lt K hm
+
+theorem phiProd_conj_coeff_zero_lead {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ)
+    [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    ((phiProd ℓ (conj ℓ ζ)).coeff 0).coeff (-((ℓ * ℓ + ℓ : ℕ) : ℤ)) = 1 :=
+  phiProd_coeff_zero_lead (conj_zero ℓ ζ) (conj_succ ℓ ζ)
+    (jSimplePole_jqK_carrier (K := K)) hζ (coeff_coeffEmb_jq_neg_one K)
+
+theorem tPoleOrderLE_phiProd_conj_of_ne_zero {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ)
+    [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (k : ℕ) (hk : k ≠ 0) :
+    TPoleOrderLE ((phiProd ℓ (conj ℓ ζ)).coeff k) (ℓ * ℓ + ℓ - 1) :=
+  tPoleOrderLE_phiProd_coeff_of_ne_zero (conj_zero ℓ ζ) (conj_succ ℓ ζ)
+    (jSimplePole_jqK_carrier (K := K)) k hk
+
+private theorem phiProd_conj_coeff_eq_zero_of_le {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ)
+    [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (k : ℕ) (hk : k ≠ 0) (m : ℕ)
+    (hm : ℓ * ℓ + ℓ ≤ m) : ((phiProd ℓ (conj ℓ ζ)).coeff k).coeff (-(m : ℤ)) = 0 := by
+  have hℓ2 : 2 ≤ ℓ := hℓ.out.two_le
+  exact tPoleOrderLE_phiProd_conj_of_ne_zero ℓ ζ k hk (-(m : ℤ)) (by omega)
+
+end PhiGen
+end ModularCurve
+
+end
+
+open _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_PhiGen_phiProd_conj_coeff_eq_zero_of_le.ModularCurve
+  _root_.ModularCurve.PhiGen
+  _root_.P2MW.S_ModularCurve_PhiGen_phiProd_conj_coeff_eq_zero_of_le.ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+    (k : ℕ) (hk : k ≠ 0) (m : ℕ) (hm : ℓ * ℓ + ℓ ≤ m) :
+    ((phiProd ℓ (conj ℓ ζ)).coeff k).coeff (-(m : ℤ)) = 0 :=
+  ModularCurve.PhiGen.phiProd_conj_coeff_eq_zero_of_le ℓ ζ k hk m hm
+
+end S_ModularCurve_PhiGen_phiProd_conj_coeff_eq_zero_of_le
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_phiProd_conj_coeff_eq_zero_of_le (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.phiProd_conj_coeff_eq_zero_of_le {K : Type*} [Field K] [Algebra ℚ K]
+    (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (k : ℕ) (hk : k ≠ 0) (m : ℕ) (hm : ℓ * ℓ + ℓ ≤ m) :
+    ((phiProd ℓ (conj ℓ ζ)).coeff k).coeff (-(m : ℤ)) = 0 :=
+  solution ℓ ζ k hk m hm
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_phiProd_conj_coeff_zero_lead.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_phiProd_conj_coeff_zero_lead.lean
new file mode 100644
index 0000000000..56b11cca9e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_phiProd_conj_coeff_zero_lead.lean
@@ -0,0 +1,451 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.phiProd_conj_coeff_zero_lead
+(df8372d0-9499-58e3-ae67-455f2247f76d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 296cd38c-5a33-52eb-a04c-653340126243
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+
+import Mathlib.Algebra.BigOperators.Fin
+import Mathlib.Algebra.BigOperators.Intervals
+import Mathlib.Tactic.Linarith
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Leading t-coefficient of the constant term of Φ_ℓ
+
+Theorem statement: `ModularCurve.PhiGen.phiProd_conj_coeff_zero_lead`
+(`df8372d0-9499-58e3-ae67-455f2247f76d`), by Claude, 2026-09-05.
+
+Proof: submission `296cd38c-5a33-52eb-a04c-653340126243`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field equipped with a $\mathbb{Q}$-algebra structure, let $\ell$ be a prime, and let
+$\zeta$ be a unit of $K$ whose underlying element is a primitive $\ell$-th root of unity. For each
+$i \in \mathrm{Fin}(\ell+1)$ put $a_i = \ell$, $b_i = 0$ if $i = 0$ and $a_i = 1$, $b_i = i-1$
+otherwise, and let `conj ℓ ζ i` be the Laurent series over $K$ obtained from the rational Laurent
+series `jq`, transported coefficientwise to $K$ along $\mathbb{Q} \to K$ by `coeffEmb`, by applying
+the twisting homomorphism `qTwist (ζ ^ (a_i * b_i))` followed by the substitution homomorphism
+`qExpand K (a_i * a_i)`. Let `phiProd ℓ (conj ℓ ζ)` be the one-variable polynomial $\prod_{i \in
+\mathrm{Fin}(\ell+1)} (X - C(\mathrm{conj}\ \ell\ \zeta\ i))$ over `LaurentSeries K`. The assertion
+is that its degree-$0$ coefficient, a Laurent series over $K$, has Hahn-series coefficient equal to
+$1$ at the exponent $-(\ell^2+\ell)$.
+
+This records the normalisation of the constant term of the generic modular polynomial $\Phi_\ell$ in
+the $q$-expansion model: the product of the $\ell+1$ conjugates, taken with the sign $(-1)^{\ell+1}$
+coming from expanding the product, has leading term exactly $t^{-(\ell^2+\ell)}$. It is used in the
+control of the weighted support of the modular polynomial data
+([`ModularCurve.ModularPolynomialData.weighted_support_le`]
+(thm.html#ModularCurve.ModularPolynomialData.weighted_support_le))
+and in
+[`ModularCurve.PhiGen.evalSymm_of_coeff_evalAtJ_eq`]
+(thm.html#ModularCurve.PhiGen.evalSymm_of_coeff_evalAtJ_eq).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_phiProd_conj_coeff_zero_lead.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_phiProd_conj_coeff_zero_lead
+
+noncomputable section
+
+open Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd jq coeff_jq_neg_one \
+  coeff_jq_of_lt qTwist qTwist_coeff coeffEmb coeffEmb_coeff"
+p2m_open "ModularCurve"
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd TPoleOrderLE JSimplePole"
+p2m_open "ModularCurve.PhiGen"
+
+section CoeffEmbJq
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+private theorem coeff_coeffEmb_jq_neg_one : (coeffEmb K jq).coeff (-1 : ℤ) = 1 := by
+  rw [coeffEmb_coeff, coeff_jq_neg_one, map_one]
+
+private theorem coeff_coeffEmb_jq_of_lt {k : ℤ} (hk : k < -1) : (coeffEmb K jq).coeff k = 0 := by
+  rw [coeffEmb_coeff, coeff_jq_of_lt hk, map_zero]
+
+end CoeffEmbJq
+
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.mono {K : Type*} [Field K]
+    {f : LaurentSeries K} {m n : ℕ}
+    (hf : TPoleOrderLE f m) (hmn : m ≤ n) : TPoleOrderLE f n :=
+  fun k hk => hf k (by omega)
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.mono"
+private theorem tPoleOrderLE_zero {K : Type*} [Field K] (n : ℕ) :
+    TPoleOrderLE (0 : LaurentSeries K) n :=
+  fun _ _ => rfl
+
+private theorem tPoleOrderLE_one {K : Type*} [Field K] :
+    TPoleOrderLE (1 : LaurentSeries K) 0 := by
+  intro m hm
+  rw [HahnSeries.coeff_one, ite_eq_right (by omega)]
+
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.neg {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) : TPoleOrderLE (-f) n := by
+  intro m hm
+  rw [HahnSeries.coeff_neg, hf m hm, neg_zero]
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.neg"
+private theorem TPoleOrderLE.add {K : Type*} [Field K] {f g : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) (hg : TPoleOrderLE g n) : TPoleOrderLE (f + g) n := by
+  intro m hm
+  rw [HahnSeries.coeff_add, hf m hm, hg m hm, add_zero]
+
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.mul {K : Type*} [Field K]
+    {f g : LaurentSeries K} {m n : ℕ}
+    (hf : TPoleOrderLE f m) (hg : TPoleOrderLE g n) : TPoleOrderLE (f * g) (m + n) := by
+  intro k hk
+  rw [HahnSeries.coeff_mul]
+  refine Finset.sum_eq_zero fun ij hij => ?_
+  obtain ⟨-, -, hsum⟩ := Finset.mem_antidiagonal.mp hij
+  by_cases hi : ij.1 < -(m : ℤ)
+  · rw [hf ij.1 hi, zero_mul]
+  · refine mul_eq_zero_of_right _ (hg ij.2 ?_)
+    push_cast at hk
+    omega
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.mul"
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.qTwist {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) (u : Kˣ) : TPoleOrderLE (ModularCurve.qTwist u f) n := by
+  intro m hm
+  rw [qTwist_coeff, hf m hm, mul_zero]
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.qTwist"
+namespace TPoleOrderLE
+private theorem _root_.ModularCurve.PhiGen.TPoleOrderLE.qExpand {K : Type*} [Field K]
+    {f : LaurentSeries K} {n : ℕ}
+    (hf : TPoleOrderLE f n) (N : ℕ) [NeZero N] :
+    TPoleOrderLE (ModularCurve.qExpand K N f) (N * n) := by
+  intro m hm
+  by_cases hdvd : (N : ℤ) ∣ m
+  · obtain ⟨c, rfl⟩ := hdvd
+    rw [qExpand_coeff_mul]
+    refine hf c ?_
+    have hN : 0 < (N : ℤ) := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+    push_cast at hm
+    nlinarith
+  · exact qExpand_coeff_of_not_dvd N f hdvd
+
+end TPoleOrderLE
+p2m_export "ModularCurve.PhiGen" "TPoleOrderLE.qExpand"
+private theorem tPoleOrderLE_of_jSimplePole {K : Type*} [Field K] (J : LaurentSeries K)
+    (hJ : JSimplePole J) : TPoleOrderLE J 1 := by
+  intro m hm
+  exact hJ m (by push_cast at hm; omega)
+
+private def conjPoleBound (ℓ : ℕ) : Fin (ℓ + 1) → ℕ :=
+  fun i => if i = 0 then ℓ * ℓ else 1
+
+private theorem conjPoleBound_zero (ℓ : ℕ) : conjPoleBound ℓ 0 = ℓ * ℓ := ite_eq_left rfl
+
+private theorem conjPoleBound_succ (ℓ : ℕ) (b : Fin ℓ) : conjPoleBound ℓ b.succ = 1 :=
+  ite_eq_right (Fin.succ_ne_zero b)
+
+private theorem sum_conjPoleBound (ℓ : ℕ) :
+    ∑ i : Fin (ℓ + 1), conjPoleBound ℓ i = ℓ * ℓ + ℓ := by
+  rw [Fin.sum_univ_succ, conjPoleBound_zero]
+  congr 1
+  simp only [conjPoleBound_succ]
+  simp
+
+private theorem tPoleOrderLE_conj_zero {K : Type*} [Field K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {J : LaurentSeries K}
+    {conj : Fin (ℓ + 1) → LaurentSeries K} (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hJ : JSimplePole J) : TPoleOrderLE (conj 0) (ℓ * ℓ) := by
+  rw [hconj0]
+  have h := (tPoleOrderLE_of_jSimplePole J hJ).qExpand (ℓ * ℓ)
+  simpa using h
+
+private theorem tPoleOrderLE_conj_succ {K : Type*} [Field K] {ℓ : ℕ} {ζ : Kˣ}
+    {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (b : Fin ℓ) : TPoleOrderLE (conj b.succ) 1 := by
+  rw [hconjS b]
+  exact (tPoleOrderLE_of_jSimplePole J hJ).qTwist _
+
+private theorem tPoleOrderLE_conj {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+    {ζ : Kˣ} {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (i : Fin (ℓ + 1)) :
+    TPoleOrderLE (conj i) (conjPoleBound ℓ i) := by
+  rcases Fin.eq_zero_or_eq_succ i with rfl | ⟨b, rfl⟩
+  · rw [conjPoleBound_zero]
+    exact tPoleOrderLE_conj_zero hconj0 hJ
+  · rw [conjPoleBound_succ]
+    exact tPoleOrderLE_conj_succ hconjS hJ b
+
+private theorem tPoleOrderLE_coeff_X_sub_C {K : Type*} [Field K] {a : LaurentSeries K}
+    {n : ℕ} (ha : TPoleOrderLE a n) (k : ℕ) :
+    TPoleOrderLE ((Polynomial.X - Polynomial.C a).coeff k) n := by
+  match k with
+  | 0 =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X_zero, Polynomial.coeff_C_zero,
+      zero_sub]
+    exact ha.neg
+  | 1 =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X_one, Polynomial.coeff_C,
+      ite_eq_right (one_ne_zero), sub_zero]
+    exact tPoleOrderLE_one.mono (Nat.zero_le _)
+  | (k + 2) =>
+    simp only [Polynomial.coeff_sub, Polynomial.coeff_X, Polynomial.coeff_C]
+    rw [ite_eq_right (by omega), ite_eq_right (by omega), sub_zero]
+    exact tPoleOrderLE_zero _
+
+private theorem phiProd_def {K : Type*} [Field K] (ℓ : ℕ)
+    (conj : Fin (ℓ + 1) → LaurentSeries K) :
+    phiProd ℓ conj = ∏ i : Fin (ℓ + 1), (Polynomial.X - Polynomial.C (conj i)) := rfl
+
+theorem tPoleOrderLE_prod {K : Type*} [Field K] {ι : Type*} (s : Finset ι)
+    (f : ι → LaurentSeries K) (n : ι → ℕ) (hf : ∀ i ∈ s, TPoleOrderLE (f i) (n i)) :
+    TPoleOrderLE (∏ i ∈ s, f i) (∑ i ∈ s, n i) := by
+  induction s using Finset.cons_induction with
+  | empty => simpa using tPoleOrderLE_one
+  | cons a s ha ih =>
+    rw [Finset.prod_cons, Finset.sum_cons]
+    exact (hf a (Finset.mem_cons_self a s)).mul
+      (ih fun i hi => hf i (Finset.mem_cons_of_mem hi))
+
+theorem coeff_mul_lead {K : Type*} [Field K] {f g : LaurentSeries K} {m n : ℕ}
+    (hf : TPoleOrderLE f m) (hg : TPoleOrderLE g n) :
+    (f * g).coeff (-((m + n : ℕ) : ℤ)) = f.coeff (-(m : ℤ)) * g.coeff (-(n : ℤ)) := by
+  rw [HahnSeries.coeff_mul]
+  refine Finset.sum_eq_single ((-(m : ℤ), -(n : ℤ))) ?_ ?_
+  · rintro ⟨i, j⟩ hij hne
+    obtain ⟨hi, hj, hsum⟩ := Finset.mem_antidiagonal.mp hij
+    rw [HahnSeries.mem_support] at hi hj
+    have him : ¬ i < -(m : ℤ) := fun h => hi (hf i h)
+    have hjn : ¬ j < -(n : ℤ) := fun h => hj (hg j h)
+    push_cast at hsum
+    have hi' : i = -(m : ℤ) := by omega
+    have hj' : j = -(n : ℤ) := by omega
+    exact absurd (by rw [hi', hj']) hne
+  · intro hni
+    by_contra hne
+    refine hni (Finset.mem_antidiagonal.mpr ⟨?_, ?_, by push_cast; ring⟩) <;>
+      rw [HahnSeries.mem_support]
+    · exact fun h0 => hne (by rw [h0, zero_mul])
+    · exact fun h0 => hne (by rw [h0, mul_zero])
+
+theorem coeff_prod_lead {K : Type*} [Field K] {ι : Type*} (s : Finset ι)
+    (f : ι → LaurentSeries K) (n : ι → ℕ) (hf : ∀ i ∈ s, TPoleOrderLE (f i) (n i)) :
+    (∏ i ∈ s, f i).coeff (-((∑ i ∈ s, n i : ℕ) : ℤ)) =
+      ∏ i ∈ s, (f i).coeff (-(n i : ℤ)) := by
+  induction s using Finset.cons_induction with
+  | empty => simp
+  | cons a s ha ih =>
+    rw [Finset.prod_cons, Finset.sum_cons, Finset.prod_cons,
+      coeff_mul_lead (hf a (Finset.mem_cons_self a s))
+        (tPoleOrderLE_prod s f n fun i hi => hf i (Finset.mem_cons_of_mem hi)),
+      ih fun i hi => hf i (Finset.mem_cons_of_mem hi)]
+
+theorem pow_sum_range_isPrimitiveRoot {K : Type*} [Field K] {ℓ : ℕ} (hℓ : Nat.Prime ℓ)
+    {z : K} (hz : IsPrimitiveRoot z ℓ) :
+    z ^ (∑ i ∈ Finset.range ℓ, i) = (-1) ^ (ℓ + 1) := by
+  rcases hℓ.eq_two_or_odd' with rfl | hodd
+  · rw [hz.eq_neg_one_of_two_right]
+    norm_num [Finset.sum_range_succ]
+  · obtain ⟨m, hm⟩ := hodd
+    have hsum : ∑ i ∈ Finset.range ℓ, i = ℓ * m := by
+      have h2 := Finset.sum_range_id_mul_two ℓ
+      have hℓ1 : ℓ - 1 = 2 * m := by omega
+      rw [hℓ1, show ℓ * (2 * m) = ℓ * m * 2 by ring] at h2
+      omega
+    rw [hsum, pow_mul, hz.pow_eq_one, one_pow]
+    exact (Even.neg_one_pow ⟨m + 1, by omega⟩).symm
+
+theorem prod_inv_pow_isPrimitiveRoot {K : Type*} [Field K] {ℓ : ℕ} (hℓ : Nat.Prime ℓ)
+    {z : K} (hz : IsPrimitiveRoot z ℓ) :
+    ∏ b : Fin ℓ, ((z ^ (b : ℕ))⁻¹ : K) = (-1) ^ (ℓ + 1) := by
+  have hsum : (∑ b : Fin ℓ, (b : ℕ)) = ∑ i ∈ Finset.range ℓ, i :=
+    Fin.sum_univ_eq_sum_range (fun i => i) ℓ
+  rw [Finset.prod_inv_distrib, Finset.prod_pow_eq_pow_sum, hsum,
+    pow_sum_range_isPrimitiveRoot hℓ hz, ← inv_pow, inv_neg, inv_one]
+
+theorem phiProd_coeff_zero_eq_prod_neg {K : Type*} [Field K] {ℓ : ℕ}
+    {conj : Fin (ℓ + 1) → LaurentSeries K} :
+    (phiProd ℓ conj).coeff 0 = ∏ i : Fin (ℓ + 1), (-(conj i)) := by
+  rw [phiProd_def, Polynomial.coeff_zero_eq_eval_zero, Polynomial.eval_prod]
+  exact Finset.prod_congr rfl fun i _ => by
+    rw [Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, zero_sub]
+
+theorem conj_zero_coeff_lead {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+    {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J) (hJlead : J.coeff (-1 : ℤ) = 1) :
+    (conj 0).coeff (-((ℓ * ℓ : ℕ) : ℤ)) = 1 := by
+  rw [hconj0, show (-((ℓ * ℓ : ℕ) : ℤ)) = ((ℓ * ℓ : ℕ) : ℤ) * (-1 : ℤ) by ring,
+    qExpand_coeff_mul, hJlead]
+
+theorem conj_succ_coeff_lead {K : Type*} [Field K] {ℓ : ℕ} {ζ : Kˣ}
+    {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJlead : J.coeff (-1 : ℤ) = 1) (b : Fin ℓ) :
+    (conj b.succ).coeff (-(1 : ℤ)) = (((ζ : K) ^ (b : ℕ))⁻¹ : K) := by
+  rw [hconjS b, qTwist_coeff, hJlead, mul_one, zpow_neg_one, ← Units.val_pow_eq_pow_val,
+    ← Units.val_inv_eq_inv_val]
+
+theorem phiProd_coeff_zero_lead {K : Type*} [Field K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+    {ζ : Kˣ} {J : LaurentSeries K} {conj : Fin (ℓ + 1) → LaurentSeries K}
+    (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+    (hJlead : J.coeff (-1 : ℤ) = 1) :
+    ((phiProd ℓ conj).coeff 0).coeff (-((ℓ * ℓ + ℓ : ℕ) : ℤ)) = 1 := by
+  rw [phiProd_coeff_zero_eq_prod_neg, ← sum_conjPoleBound ℓ,
+    coeff_prod_lead Finset.univ _ (conjPoleBound ℓ)
+      (fun i _ => (tPoleOrderLE_conj hconj0 hconjS hJ i).neg),
+    Fin.prod_univ_succ]
+  have h0 : (-(conj 0)).coeff (-((conjPoleBound ℓ 0 : ℕ) : ℤ)) = -1 := by
+    rw [HahnSeries.coeff_neg, conjPoleBound_zero, conj_zero_coeff_lead hconj0 hJlead]
+  have hS : ∀ b : Fin ℓ, (-(conj b.succ)).coeff (-((conjPoleBound ℓ b.succ : ℕ) : ℤ)) =
+      -((((ζ : K) ^ (b : ℕ))⁻¹ : K)) := by
+    intro b
+    rw [HahnSeries.coeff_neg, conjPoleBound_succ, Nat.cast_one,
+      conj_succ_coeff_lead hconjS hJlead b]
+  rw [h0]
+  simp only [hS]
+  rw [Finset.prod_neg, Finset.card_univ, Fintype.card_fin,
+    prod_inv_pow_isPrimitiveRoot hℓ.out hζ, ← pow_add, ← pow_succ']
+  exact Even.neg_one_pow ⟨ℓ + 1, by ring⟩
+
+theorem tPoleOrderLE_coeff_prod_X_sub_C_card {K : Type*} [Field K] {ι : Type*}
+    (s : Finset ι) (a : ι → LaurentSeries K) (ha : ∀ i ∈ s, TPoleOrderLE (a i) 1) :
+    ∀ k : ℕ, TPoleOrderLE ((∏ i ∈ s, (Polynomial.X - Polynomial.C (a i))).coeff k)
+      (s.card - k) := by
+  induction s using Finset.cons_induction with
+  | empty =>
+    intro k
+    rcases Nat.eq_zero_or_pos k with rfl | hk
+    · simpa using tPoleOrderLE_one
+    · rw [Finset.prod_empty, Polynomial.coeff_one, ite_eq_right (by omega)]
+      exact tPoleOrderLE_zero _
+  | cons a₀ s ha₀ ih =>
+    intro k
+    have hmem : ∀ i ∈ s, TPoleOrderLE (a i) 1 :=
+      fun i hi => ha i (Finset.mem_cons_of_mem hi)
+    rw [Finset.prod_cons, Finset.card_cons]
+    match k with
+    | 0 =>
+      rw [Polynomial.mul_coeff_zero]
+      exact ((tPoleOrderLE_coeff_X_sub_C (ha a₀ (Finset.mem_cons_self a₀ s)) 0).mul
+        (ih hmem 0)).mono (by omega)
+    | (k + 1) =>
+      rw [sub_mul, Polynomial.coeff_sub, Polynomial.coeff_X_mul, Polynomial.coeff_C_mul,
+        sub_eq_add_neg]
+      refine TPoleOrderLE.add ?_ (TPoleOrderLE.neg ?_)
+      · exact (ih hmem k).mono (by omega)
+      · by_cases hks : k + 1 ≤ s.card
+        · exact ((ha a₀ (Finset.mem_cons_self a₀ s)).mul (ih hmem (k + 1))).mono
+            (by omega)
+        · rw [Polynomial.coeff_eq_zero_of_natDegree_lt, mul_zero]
+          · exact tPoleOrderLE_zero _
+          · rw [Polynomial.natDegree_prod_of_monic _ _
+              (fun i _ => Polynomial.monic_X_sub_C (a i))]
+            simp only [Polynomial.natDegree_X_sub_C, ← Finset.card_eq_sum_ones]
+            omega
+
+theorem tPoleOrderLE_phiProd_coeff_of_ne_zero {K : Type*} [Field K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] {ζ : Kˣ} {J : LaurentSeries K}
+    {conj : Fin (ℓ + 1) → LaurentSeries K} (hconj0 : conj 0 = qExpand K (ℓ * ℓ) J)
+    (hconjS : ∀ b : Fin ℓ, conj b.succ = ModularCurve.qTwist (ζ ^ (b : ℕ)) J)
+    (hJ : JSimplePole J) (k : ℕ) (hk : k ≠ 0) :
+    TPoleOrderLE ((phiProd ℓ conj).coeff k) (ℓ * ℓ + ℓ - 1) := by
+  obtain ⟨k, rfl⟩ := Nat.exists_eq_succ_of_ne_zero hk
+  have hℓ2 : 2 ≤ ℓ := hℓ.out.two_le
+  have hsq : 4 ≤ ℓ * ℓ := Nat.mul_le_mul hℓ2 hℓ2
+  rw [phiProd_def, Fin.prod_univ_succ, sub_mul, Polynomial.coeff_sub,
+    Polynomial.coeff_X_mul, Polynomial.coeff_C_mul, sub_eq_add_neg]
+  have hR : ∀ j : ℕ, TPoleOrderLE
+      ((∏ b : Fin ℓ, (Polynomial.X - Polynomial.C (conj b.succ))).coeff j)
+      (Finset.univ.card - j) :=
+    tPoleOrderLE_coeff_prod_X_sub_C_card Finset.univ _
+      (fun b _ => tPoleOrderLE_conj_succ hconjS hJ b)
+  rw [Finset.card_univ, Fintype.card_fin] at hR
+  refine TPoleOrderLE.add ?_ (TPoleOrderLE.neg ?_)
+  · exact (hR k).mono (by omega)
+  · exact ((tPoleOrderLE_conj_zero hconj0 hJ).mul (hR (k + 1))).mono (by omega)
+
+theorem jSimplePole_jqK_carrier {K : Type*} [Field K] [Algebra ℚ K] :
+    JSimplePole (coeffEmb K jq) :=
+  fun _ hm => coeff_coeffEmb_jq_of_lt K hm
+
+private theorem phiProd_conj_coeff_zero_lead {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ)
+    [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    ((phiProd ℓ (conj ℓ ζ)).coeff 0).coeff (-((ℓ * ℓ + ℓ : ℕ) : ℤ)) = 1 :=
+  phiProd_coeff_zero_lead (conj_zero ℓ ζ) (conj_succ ℓ ζ)
+    (jSimplePole_jqK_carrier (K := K)) hζ (coeff_coeffEmb_jq_neg_one K)
+
+theorem tPoleOrderLE_phiProd_conj_of_ne_zero {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ)
+    [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (k : ℕ) (hk : k ≠ 0) :
+    TPoleOrderLE ((phiProd ℓ (conj ℓ ζ)).coeff k) (ℓ * ℓ + ℓ - 1) :=
+  tPoleOrderLE_phiProd_coeff_of_ne_zero (conj_zero ℓ ζ) (conj_succ ℓ ζ)
+    (jSimplePole_jqK_carrier (K := K)) k hk
+
+theorem phiProd_conj_coeff_eq_zero_of_le {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ)
+    [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (k : ℕ) (hk : k ≠ 0) (m : ℕ)
+    (hm : ℓ * ℓ + ℓ ≤ m) : ((phiProd ℓ (conj ℓ ζ)).coeff k).coeff (-(m : ℤ)) = 0 := by
+  have hℓ2 : 2 ≤ ℓ := hℓ.out.two_le
+  exact tPoleOrderLE_phiProd_conj_of_ne_zero ℓ ζ k hk (-(m : ℤ)) (by omega)
+
+end PhiGen
+end ModularCurve
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_PhiGen_phiProd_conj_coeff_zero_lead.ModularCurve
+  _root_.ModularCurve.PhiGen
+  _root_.P2MW.S_ModularCurve_PhiGen_phiProd_conj_coeff_zero_lead.ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    ((phiProd ℓ (conj ℓ ζ)).coeff 0).coeff (-((ℓ * ℓ + ℓ : ℕ) : ℤ)) = 1 :=
+  ModularCurve.PhiGen.phiProd_conj_coeff_zero_lead ℓ ζ hζ
+
+end S_ModularCurve_PhiGen_phiProd_conj_coeff_zero_lead
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_phiProd_conj_coeff_zero_lead (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.phiProd_conj_coeff_zero_lead {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ)
+    [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    ((phiProd ℓ (conj ℓ ζ)).coeff 0).coeff (-((ℓ * ℓ + ℓ : ℕ) : ℤ)) = 1 :=
+  solution ℓ ζ hζ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_splits_of_coeff_evalAtJ_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_splits_of_coeff_evalAtJ_eq.lean
new file mode 100644
index 0000000000..12b68fdec1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_splits_of_coeff_evalAtJ_eq.lean
@@ -0,0 +1,122 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.splits_of_coeff_evalAtJ_eq
+(6cde1021-2e2d-529d-b0df-4dbbd8fd0215) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ad21c462-0bb7-56ad-a7e6-6bc9c4ceac47
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Descended coefficients force Φ to split into conjugates
+
+Theorem statement: `ModularCurve.PhiGen.splits_of_coeff_evalAtJ_eq`
+(`6cde1021-2e2d-529d-b0df-4dbbd8fd0215`), by Claude, 2026-09-05.
+
+Proof: submission `ad21c462-0bb7-56ad-a7e6-6bc9c4ceac47`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field equipped with a $\mathbb{Q}$-algebra structure, let $\ell$ be a natural number
+carrying a `Fact` instance that it is prime, let $\zeta$ be a unit of $K$, and let $c \colon
+\mathbb{N} \to \mathbb{Q}((q))$ be a family of Laurent series over $\mathbb{Q}$. Assume
+`PhiGenDescends ℓ ζ c`, that is: for every $k$, the $k$-th coefficient of the product $\prod_{i \in
+\mathrm{Fin}(\ell+1)} \bigl(X - C(\mathrm{conj}\,\ell\,\zeta\,i)\bigr)$ over $K((q))$ — where
+$\mathrm{conj}\,\ell\,\zeta\,i$ is obtained from the image of the $j$-expansion $jq$ in $K((q))$ by
+the twist $q \mapsto \zeta^{ab}q$ followed by $q \mapsto q^{a^2}$, with $a = \ell,\ b = 0$ for $i =
+0$ and $a = 1,\ b = i-1$ otherwise — equals the image of $c_k$ under $q \mapsto q^{\ell}$ followed
+by coefficientwise base change $\mathbb{Q} \to K$. Let `data` consist of a monic $\Phi \in
+\mathbb{Z}[X][Y]$ of $Y$-degree $\psi(\ell) = \ell + 1$ satisfying $\Phi(jq, \cdot)$ annihilating
+$jqN\ \ell$, and assume that for every $k$ the $k$-th $Y$-coefficient of $\Phi$, evaluated at $X =
+jq$, equals $c_k$. Then applying to the coefficients of $\Phi$ the ring homomorphism $X \mapsto jq$,
+followed by $q \mapsto q^{\ell}$ and by base change to $K$, yields exactly that product $\prod_i (X
+- C(\mathrm{conj}\,\ell\,\zeta\,i))$.
+
+This is the modular equation for $X_0(\ell)$ read as a factorisation: the classical statement that
+$\Phi_\ell(X,Y)$, specialised at $X = j(q)$ and re-expanded in $q^{1/\ell}$-style coordinates, is
+the monic polynomial whose roots are the $\ell+1$ conjugates $j(q^{\ell^2})$ and $j(\zeta^{i}q)$. It
+feeds the symmetry and splitting statements
+[`ModularCurve.PhiGen.evalSymm_of_coeff_evalAtJ_eq`]
+(thm.html#ModularCurve.PhiGen.evalSymm_of_coeff_evalAtJ_eq),
+[`ModularCurve.PhiGen.splits_of_prime`](thm.html#ModularCurve.PhiGen.splits_of_prime) and
+[`ModularCurve.exists_phiIrreducible_evalSymm`]
+(thm.html#ModularCurve.exists_phiIrreducible_evalSymm).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_splits_of_coeff_evalAtJ_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_splits_of_coeff_evalAtJ_eq
+
+noncomputable section
+
+open Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand evalAtJ ModularPolynomialData coeffEmb"
+p2m_open "ModularCurve"
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj phiProd PhiGenDescends"
+p2m_open "ModularCurve.PhiGen"
+
+section Splitting
+
+variable {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)]
+variable (ζ : Kˣ) {c : ℕ → LaurentSeries ℚ}
+
+private theorem splits_of_coeff_evalAtJ_eq (hc : PhiGenDescends ℓ ζ c)
+    (data : ModularPolynomialData ℓ)
+    (hcoeff : ∀ k, evalAtJ (data.Φ.coeff k) = c k) :
+    data.Φ.map (((coeffEmb K).comp (qExpand ℚ ℓ)).comp evalAtJ) = phiProd ℓ (conj ℓ ζ) := by
+  refine Polynomial.ext fun k => ?_
+  rw [Polynomial.coeff_map, RingHom.comp_apply, RingHom.comp_apply, hcoeff k, hc k]
+
+end Splitting
+
+end PhiGen
+end ModularCurve
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_PhiGen_splits_of_coeff_evalAtJ_eq.ModularCurve
+  _root_.ModularCurve.PhiGen
+  _root_.P2MW.S_ModularCurve_PhiGen_splits_of_coeff_evalAtJ_eq.ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ} [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+    {c : ℕ → LaurentSeries ℚ} (hc : PhiGenDescends ℓ ζ c) (data : ModularPolynomialData ℓ)
+    (hcoeff : ∀ k, evalAtJ (data.Φ.coeff k) = c k) :
+    data.Φ.map (((coeffEmb K).comp (qExpand ℚ ℓ)).comp evalAtJ) = phiProd ℓ (conj ℓ ζ) :=
+  ModularCurve.PhiGen.splits_of_coeff_evalAtJ_eq ζ hc data hcoeff
+
+end S_ModularCurve_PhiGen_splits_of_coeff_evalAtJ_eq
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_splits_of_coeff_evalAtJ_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.splits_of_coeff_evalAtJ_eq {K : Type*} [Field K] [Algebra ℚ K] {ℓ : ℕ}
+    [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) {c : ℕ → LaurentSeries ℚ} (hc : PhiGenDescends ℓ ζ c)
+    (data : ModularPolynomialData ℓ) (hcoeff : ∀ k, evalAtJ (data.Φ.coeff k) = c k) :
+    data.Φ.map (((coeffEmb K).comp (qExpand ℚ ℓ)).comp evalAtJ) = phiProd ℓ (conj ℓ ζ) :=
+  solution ζ hc data hcoeff
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_splits_of_prime.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_splits_of_prime.lean
new file mode 100644
index 0000000000..d74d9cf88e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_splits_of_prime.lean
@@ -0,0 +1,405 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.splits_of_prime
+(d0261f5d-094d-5699-ac34-71cdc26fe4ff) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 841200db-fa61-5936-a5d1-fded7cab1c3c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eq_of_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_exists_phiGenDescends
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_PhiGenDescends_intCoeffs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_mem_adjoin_jq_of_phiGenDescends
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_exists_modularPolynomialData_coeff_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_of_coeff_evalAtJ_eq
+import Mathlib.NumberTheory.Cyclotomic.PrimitiveRoots
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Prime-level modular polynomial splits over any field with ζₚ
+
+Theorem statement: `ModularCurve.PhiGen.splits_of_prime` (`d0261f5d-094d-5699-ac34-71cdc26fe4ff`),
+by Claude, 2026-09-05.
+
+Proof: submission `841200db-fa61-5936-a5d1-fded7cab1c3c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field equipped with a $\mathbb{Q}$-algebra structure, let $p$ be a prime, let $\zeta$
+be a unit of $K$ whose underlying element is a primitive $p$-th root of unity, and let `data` be any
+modular polynomial datum of level $p$, that is, a polynomial $\Phi \in (\mathbb{Z}[X])[Y]$ that is
+monic in $Y$, has $Y$-degree $\psi(p)=\sum_{d \mid p,\ d \text{ squarefree}} p/d$, and satisfies
+$\Phi(j(q), j(q^p)) = 0$ in the Laurent series field over $\mathbb{Q}$, where coefficients in
+$\mathbb{Z}[X]$ are evaluated at the $q$-expansion `jq` of $j$ by `evalAtJ`. The conclusion is an
+identity of polynomials over `LaurentSeries K`: applying to each coefficient of $\Phi$ the ring
+homomorphism "evaluate at `jq`, then substitute $t \mapsto t^{p}$ (multiply all exponents by $p$),
+then embed the coefficients into $K$" yields $\prod_{i \in \mathrm{Fin}(p+1)} \bigl(Y -
+\mathrm{conj}\,p\,\zeta\,i\bigr)$. Here the $i$-th factor's root is obtained from the image of `jq`
+in `LaurentSeries K` by twisting the variable by $\zeta^{ab}$ and then multiplying exponents by
+$a^{2}$, with $(a,b) = (p,0)$ for $i = 0$ and $(a,b) = (1, i-1)$ otherwise.
+
+This is the classical factorisation of the modular equation of prime level, $\Phi_p(j(q),Y) = (Y -
+j(q^{p}))\prod_{b=0}^{p-1}(Y - j(\zeta^{b} q^{1/p}))$, indexed by the $p+1$ cosets of $\Gamma_0(p)$
+in $\mathrm{SL}_2(\mathbb{Z})$, here in the form of an identity of polynomials over a Laurent series
+field. Compared with
+[`ModularCurve.PhiGen.splits_of_coeff_evalAtJ_eq`]
+(thm.html#ModularCurve.PhiGen.splits_of_coeff_evalAtJ_eq)
+it carries no descent hypothesis on the coefficients of the datum, being stated for every level-$p$
+datum and every field with a primitive $p$-th root of unity; it feeds the splitting statements
+[`ModularCurve.PhiGen.splits_prime_at_slot`](thm.html#ModularCurve.PhiGen.splits_prime_at_slot) and
+its variants.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_splits_of_prime.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_splits_of_prime
+
+noncomputable section
+
+p2m_open "ModularCurve~coeffEmb_qExpand P2MW.S_ModularCurve_PhiGen_splits_of_prime.ModularCurve \
+  ModularCurve.PhiGen P2MW.S_ModularCurve_PhiGen_splits_of_prime.ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ evalAtJ_X \
+  ModularPolynomialData coeffMap coeffMap_coeff coeffMap_coeffMap coeffMap_congr coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  coeffMap_qExpand ModularPolynomialData.eq_of_prime"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+
+
+
+
+
+
+
+
+
+
+theorem coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb K (qExpand ℚ n x) = qExpand K n (coeffEmb K x) :=
+  coeffMap_qExpand (algebraMap ℚ K) n x
+
+theorem iota_jqN (N d : ℕ) [NeZero N] [NeZero d] :
+    coeffEmb K (qExpand ℚ N (jqN d)) = TS K (N * d) 1 := by
+  rw [jqN, coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem iota_jq (N : ℕ) [NeZero N] : coeffEmb K (qExpand ℚ N jq) = TS K N 1 := by
+  rw [coeffEmb_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_zero_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    conj p ζ (0 : Fin (p + 1)) = TS K (p * p) 1 := by
+  rw [conj_zero, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_succ_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) (b : Fin p) :
+    conj p ζ b.succ = TS K 1 (ζ ^ (b : ℕ)) := by
+  rw [conj_succ, TS_eq_coeffEmb, qExpand_one_apply]
+
+theorem qTwist_iota_of_pow_eq_one (N : ℕ) [NeZero N] (v : Kˣ) (hv : v ^ N = 1) (x : LaurentSeries ℚ)
+    :
+    qTwist v (coeffEmb K (qExpand ℚ N x)) = coeffEmb K (qExpand ℚ N x) := by
+  rw [coeffEmb_qExpand, qTwist_qExpand]
+  have : v ^ (N : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ evalAtJ_X \
+  ModularPolynomialData coeffMap coeffMap_coeff coeffMap_coeffMap coeffMap_congr coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  coeffMap_qExpand ModularPolynomialData.eq_of_prime"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+omit [Algebra ℚ K] in
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+omit [Algebra ℚ K] in
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+omit [Algebra ℚ K] in
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem phiProd_conj_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    phiProd p (conj p ζ) = (Polynomial.X - Polynomial.C (TS K (p * p) 1)) *
+      ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) := by
+  rw [phiProd, Fin.prod_univ_succ, conj_zero_eq]
+  congr 1
+  rw [← Fin.prod_univ_eq_prod_range (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) p]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [conj_succ_eq]
+
+theorem roots_phiProd_conj (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    (phiProd p (conj p ζ)).roots = TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^
+      b)) := by
+  classical
+  rw [phiProd_conj_eq]
+  have h1 : (Polynomial.X - Polynomial.C (TS K (p * p) 1) : Polynomial (LaurentSeries K)) ≠ 0 :=
+    Polynomial.X_sub_C_ne_zero _
+  have h2 : (∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b)))) ≠ 0 :=
+    Finset.prod_ne_zero_iff.mpr fun b _ => Polynomial.X_sub_C_ne_zero _
+  rw [Polynomial.roots_mul (mul_ne_zero h1 h2), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod,
+    Finset.range_val]
+  have hm : (Multiset.map (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) (Multiset.range
+    p)) =
+      ((Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).map (fun a => Polynomial.X - Polynomial.C
+        a) := by
+    rw [Multiset.map_map]; rfl
+  rw [hm, Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+omit [Algebra ℚ K] in
+theorem roots_phiProd_conj_nodup (p : ℕ) [hp : Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).Nodup := by
+  refine Multiset.nodup_cons.mpr ⟨?_, ?_⟩
+  · intro hmem
+    obtain ⟨b, -, hb⟩ := Multiset.mem_map.mp hmem
+    have := (TS_injective hb).1
+    have h2 := hp.out.two_le
+    nlinarith
+  · refine (Multiset.nodup_range p).map_on fun b hb b' hb' hbb' => ?_
+    rw [Multiset.mem_range] at hb hb'
+    have hu := (TS_injective hbb').2
+    have hζu : IsPrimitiveRoot ζ p := IsPrimitiveRoot.coe_units_iff.mp hζ
+    exact hζu.pow_inj hb hb' hu
+
+theorem exists_isPrimitiveRoot_cyclotomicField (N : ℕ) [NeZero N] :
+    ∃ z : CyclotomicField N ℚ, IsPrimitiveRoot z N := by
+  have : NeZero ((N : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr (NeZero.ne N)⟩
+  have : IsCyclotomicExtension {N} ℚ (CyclotomicField N ℚ) :=
+    CyclotomicField.isCyclotomicExtension N ℚ
+  exact IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField N ℚ) (Set.mem_singleton N)
+    (NeZero.ne N)
+
+def cycUnit (N : ℕ) [NeZero N] : (CyclotomicField N ℚ)ˣ :=
+  ((exists_isPrimitiveRoot_cyclotomicField N).choose_spec.isUnit (NeZero.ne N)).unit
+
+theorem cycUnit_spec (N : ℕ) [NeZero N] :
+    IsPrimitiveRoot ((cycUnit N : (CyclotomicField N ℚ)ˣ) : CyclotomicField N ℚ) N := by
+  rw [cycUnit, IsUnit.unit_spec]
+  exact (exists_isPrimitiveRoot_cyclotomicField N).choose_spec
+
+theorem cycUnit_pow (N : ℕ) [NeZero N] : cycUnit N ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, (cycUnit_spec N).pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ evalAtJ_X \
+  ModularPolynomialData coeffMap coeffMap_coeff coeffMap_coeffMap coeffMap_congr coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  coeffMap_qExpand ModularPolynomialData.eq_of_prime"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+
+
+
+
+theorem phiAtSeed_jq_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) :
+    (phiAtSeed data jq).eval (jqN n) = 0 := by
+  have h := data.eval_eq_zero
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp [evalAtJ_X]
+
+
+theorem phiAtSeed_jqN_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN M)).eval (jqN (M * n)) = 0 := by
+  have h := phiAtSeed_eval_map data jq (jqN n) (qExpand ℚ M) (phiAtSeed_jq_eval n data)
+  rwa [jqN, qExpand_qExpand] at h
+
+theorem phiAtSeed_iota_eval {K : Type*} [Field K] [Algebra ℚ K] (A : ℕ) [NeZero A] (n : ℕ)
+    [NeZero n]
+    (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (coeffEmb K (qExpand ℚ A (jqN M)))).eval (coeffEmb K (qExpand ℚ A (jqN (M *
+      n)))) = 0 :=
+  phiAtSeed_eval_map data _ _ ((coeffEmb K).comp (qExpand ℚ A)) (phiAtSeed_jqN_eval n data M)
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ evalAtJ_X \
+  ModularPolynomialData coeffMap coeffMap_coeff coeffMap_coeffMap coeffMap_congr coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  coeffMap_qExpand ModularPolynomialData.eq_of_prime"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+section transport
+
+variable {K₀ K : Type*} [Field K₀] [Algebra ℚ K₀] [Field K] [Algebra ℚ K]
+
+omit [Algebra ℚ K₀] [Algebra ℚ K] in
+theorem coeffMap_qTwist (σ : K₀ →+* K) (u : K₀ˣ) (f : LaurentSeries K₀) :
+    coeffMap σ (qTwist u f) = qTwist (Units.map σ.toMonoidHom u) (coeffMap σ f) := by
+  ext k
+  simp only [coeffMap_coeff, qTwist_coeff, map_mul]
+  congr 1
+  rw [← map_zpow, Units.coe_map]
+  rfl
+
+theorem coeffMap_coeffEmb_algHom (σ : K₀ →ₐ[ℚ] K) (x : LaurentSeries ℚ) :
+    coeffMap (σ : K₀ →+* K) (coeffEmb K₀ x) = coeffEmb K x := by
+  rw [coeffEmb, coeffEmb, coeffMap_coeffMap]
+  exact coeffMap_congr (σ.comp_algebraMap) x
+
+theorem coeffMap_TS (σ : K₀ →ₐ[ℚ] K) (e : ℕ) [NeZero e] (u : K₀ˣ) :
+    coeffMap (σ : K₀ →+* K) (TS K₀ e u) = TS K e (Units.map (σ : K₀ →+* K).toMonoidHom u) := by
+  rw [TS_eq_coeffEmb, TS_eq_coeffEmb, coeffMap_qExpand, coeffMap_qTwist, coeffMap_coeffEmb_algHom]
+
+theorem coeffMap_conj (σ : K₀ →ₐ[ℚ] K) (p : ℕ) [Fact p.Prime] (ζ : K₀ˣ) (i : Fin (p + 1)) :
+    coeffMap (σ : K₀ →+* K) (conj p ζ i) = conj p (Units.map (σ : K₀ →+* K).toMonoidHom ζ) i := by
+  refine Fin.cases ?_ (fun b => ?_) i
+  · rw [conj_zero_eq, conj_zero_eq, coeffMap_TS, map_one]
+  · rw [conj_succ_eq, conj_succ_eq, coeffMap_TS, map_pow]
+
+theorem map_coeffMap_phiProd (σ : K₀ →ₐ[ℚ] K) (p : ℕ) [Fact p.Prime] (ζ : K₀ˣ) :
+    (phiProd p (conj p ζ)).map (coeffMap (σ : K₀ →+* K)) =
+      phiProd p (conj p (Units.map (σ : K₀ →+* K).toMonoidHom ζ)) := by
+  rw [phiProd, phiProd, Polynomial.map_prod]
+  refine Finset.prod_congr rfl fun i _ => ?_
+  rw [Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C, coeffMap_conj]
+
+end transport
+
+theorem splits_of_prime_cyclotomicField (p : ℕ) [hp : Fact p.Prime] (data : ModularPolynomialData p)
+    :
+    data.Φ.map (((coeffEmb (CyclotomicField p ℚ)).comp (qExpand ℚ p)).comp evalAtJ) =
+      phiProd p (conj p (cycUnit p)) := by
+  have : NeZero ((p : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr hp.out.ne_zero⟩
+  have : IsCyclotomicExtension {p} ℚ (CyclotomicField p ℚ) :=
+    CyclotomicField.isCyclotomicExtension p ℚ
+  have : IsGalois ℚ (CyclotomicField p ℚ) :=
+    IsCyclotomicExtension.isGalois {p} ℚ (CyclotomicField p ℚ)
+  have : FiniteDimensional ℚ (CyclotomicField p ℚ) :=
+    IsCyclotomicExtension.finiteDimensional {p} ℚ (CyclotomicField p ℚ)
+  have hζ := cycUnit_spec p
+  obtain ⟨c, hc⟩ := exists_phiGenDescends p (cycUnit p) hζ
+  have hint : ∀ k, IntCoeffs (c k) := fun k => hc.intCoeffs (cycUnit_pow p) k
+  have hmem : ∀ k, c k ∈ Algebra.adjoin ℚ {jq} :=
+    fun k => mem_adjoin_jq_of_phiGenDescends p (cycUnit p) hζ c hc k
+  obtain ⟨data₀, hdata₀⟩ := exists_modularPolynomialData_coeff_eq hc hint hmem
+  rw [ModularCurve.ModularPolynomialData.eq_of_prime p data data₀]
+  exact splits_of_coeff_evalAtJ_eq (cycUnit p) hc data₀ hdata₀
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ evalAtJ_X \
+  ModularPolynomialData coeffMap coeffMap_coeff coeffMap_coeffMap coeffMap_congr coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  coeffMap_qExpand ModularPolynomialData.eq_of_prime"
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd IntCoeffs exists_phiGenDescends \
+  mem_adjoin_jq_of_phiGenDescends exists_modularPolynomialData_coeff_eq splits_of_coeff_evalAtJ_eq"
+end ModularCurve.PhiGen
+p2m_open_scoped "ModularCurve ModularCurve.PhiGen" in
+open ModularCurve.W1 in
+private theorem ModularCurve.PhiGen.splits_of_prime {K : Type*} [Field K] [Algebra ℚ K] (p : ℕ)
+    [hp : Fact (Nat.Prime p)] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) :
+    data.Φ.map (((coeffEmb K).comp (qExpand ℚ p)).comp evalAtJ) = phiProd p (conj p ζ) := by
+  have : NeZero ((p : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr hp.out.ne_zero⟩
+  have : IsCyclotomicExtension {p} ℚ (CyclotomicField p ℚ) :=
+    CyclotomicField.isCyclotomicExtension p ℚ
+  have hζ₀ := cycUnit_spec p
+  have hirr := Polynomial.cyclotomic.irreducible_rat hp.out.pos
+  obtain ⟨σ, hσ⟩ : ∃ σ : CyclotomicField p ℚ →ₐ[ℚ] K, σ (cycUnit p : CyclotomicField p ℚ) = ζ :=
+    ⟨(hζ₀.embeddingsEquivPrimitiveRoots K hirr).symm ⟨ζ, (mem_primitiveRoots hp.out.pos).mpr hζ⟩, by
+      rw [← hζ₀.embeddingsEquivPrimitiveRoots_apply_coe K hirr, Equiv.apply_symm_apply]⟩
+  have hσu : Units.map (σ : CyclotomicField p ℚ →+* K).toMonoidHom (cycUnit p) = ζ :=
+    Units.ext (by rw [Units.coe_map]; exact hσ)
+  have h :=
+    congrArg (Polynomial.map (coeffMap (σ : CyclotomicField p ℚ →+* K)))
+      (splits_of_prime_cyclotomicField p data)
+  rw [map_coeffMap_phiProd, hσu, Polynomial.map_map] at h
+  convert h using 2
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp only [RingHom.comp_apply, evalAtJ_X]
+  rw [coeffMap_coeffEmb_algHom]
+
+p2m_open "ModularCurve~coeffEmb_qExpand\
+  " in
+open _root_.P2MW.S_ModularCurve_PhiGen_splits_of_prime.ModularCurve _root_.ModularCurve.PhiGen
+  _root_.P2MW.S_ModularCurve_PhiGen_splits_of_prime.ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] [Algebra ℚ K] (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) (data : ModularPolynomialData p) :
+    data.Φ.map (((coeffEmb K).comp (qExpand ℚ p)).comp evalAtJ) = phiProd p (conj p ζ) :=
+  ModularCurve.PhiGen.splits_of_prime p ζ hζ data
+
+end
+end S_ModularCurve_PhiGen_splits_of_prime
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_splits_of_prime (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.splits_of_prime {K : Type*} [Field K] [Algebra ℚ K] (p : ℕ)
+    [hp : Fact (Nat.Prime p)] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) :
+    data.Φ.map (((coeffEmb K).comp (qExpand ℚ p)).comp evalAtJ) = phiProd p (conj p ζ) :=
+  solution p ζ hζ data
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_splits_prime_at_slot.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_splits_prime_at_slot.lean
new file mode 100644
index 0000000000..120b1ab906
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_splits_prime_at_slot.lean
@@ -0,0 +1,344 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.splits_prime_at_slot
+(6645bdfa-6ae3-5bd7-ad42-8762b3625fa3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c650d6a1-c562-5ce8-8e80-09d28e1b831d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_of_prime
+import Mathlib.Algebra.Polynomial.Roots
+import Mathlib.Algebra.BigOperators.Fin
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Twisted prime-level splitting of the modular polynomial Φₚ
+
+Theorem statement: `ModularCurve.PhiGen.splits_prime_at_slot`
+(`6645bdfa-6ae3-5bd7-ad42-8762b3625fa3`), by Claude, 2026-09-05.
+
+Proof: submission `c650d6a1-c562-5ce8-8e80-09d28e1b831d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field of characteristic zero (a $\mathbb{Q}$-algebra), let $N$ be a nonzero natural
+number, and let $\zeta \in K^{\times}$ be a unit whose underlying element is a primitive $N$-th root
+of unity. Let $p$ be a prime dividing $N$, and let `data` provide a level-$p$ modular polynomial,
+i.e. a monic $\Phi \in \mathbb{Z}[X][Y]$ of degree $\psi(p) = \sum_{d \mid p,\ d \text{ squarefree}}
+p/d = p+1$ in $Y$ satisfying $\Phi(j(q), j(q^{p})) = 0$ for the Laurent-series $j$-expansion $j_q =
+q^{-1}\cdot(\text{power series } j_{\mathrm{Num}})$ over $\mathbb{Q}$. Let $e$ be a nonzero natural
+number and $u \in K^{\times}$. Write $\hat{\jmath}_{w}(t^{m})$ for the Laurent series over $K$
+obtained from the image of $j_q$ in $K((t))$ by the twist multiplying the coefficient in degree $k$
+by $w^{k}$ and then by the exponent dilation $t \mapsto t^{m}$. The conclusion is an identity in
+$K((t))[Y]$: substituting $\hat{\jmath}_{u^{p}}(t^{pe})$ for the inner variable of $\Phi$
+(coefficients mapped through $\mathbb{Z} \to K((t))$) gives $$\Bigl(Y -
+\hat{\jmath}_{u^{p^{2}}}(t^{p\cdot pe})\Bigr)\prod_{b=0}^{p-1}\Bigl(Y -
+\hat{\jmath}_{u\zeta^{b(N/p)}}(t^{e})\Bigr),$$ a product of $p+1$ monic linear factors.
+
+This is the classical splitting of the level-$p$ modular equation, $\Phi_p(j(q^{p}), Y) = (Y -
+j(q^{p^{2}}))\prod_{b<p}(Y - j(\zeta_p^{b} q))$, transported to an arbitrary twisted and dilated
+$q$-parameter $u t^{e}$, with $\zeta^{N/p}$ serving as the primitive $p$-th root of unity. It is the
+basic local step in the purely algebraic determination of $[\mathbb{Q}(j,j_N):\mathbb{Q}(j)] =
+\psi(N)$, i.e. of the irreducibility of the modular polynomial $\Phi_N$ over $\mathbb{Q}(j)$, and is
+invoked throughout that development.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_splits_prime_at_slot.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_splits_prime_at_slot
+
+noncomputable section
+
+p2m_open "ModularCurve~coeffEmb_qExpand \
+  P2MW.S_ModularCurve_PhiGen_splits_prime_at_slot.ModularCurve ModularCurve.PhiGen \
+  P2MW.S_ModularCurve_PhiGen_splits_prime_at_slot.ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN evalAtJ evalAtJ_X ModularPolynomialData \
+  coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  coeffMap_qExpand PhiGen.splits_of_prime"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+
+
+
+
+
+
+
+
+
+
+theorem coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb K (qExpand ℚ n x) = qExpand K n (coeffEmb K x) :=
+  coeffMap_qExpand (algebraMap ℚ K) n x
+
+theorem iota_jqN (N d : ℕ) [NeZero N] [NeZero d] :
+    coeffEmb K (qExpand ℚ N (jqN d)) = TS K (N * d) 1 := by
+  rw [jqN, coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem iota_jq (N : ℕ) [NeZero N] : coeffEmb K (qExpand ℚ N jq) = TS K N 1 := by
+  rw [coeffEmb_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_zero_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    conj p ζ (0 : Fin (p + 1)) = TS K (p * p) 1 := by
+  rw [conj_zero, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_succ_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) (b : Fin p) :
+    conj p ζ b.succ = TS K 1 (ζ ^ (b : ℕ)) := by
+  rw [conj_succ, TS_eq_coeffEmb, qExpand_one_apply]
+
+theorem qTwist_iota_of_pow_eq_one (N : ℕ) [NeZero N] (v : Kˣ) (hv : v ^ N = 1) (x : LaurentSeries ℚ)
+    :
+    qTwist v (coeffEmb K (qExpand ℚ N x)) = coeffEmb K (qExpand ℚ N x) := by
+  rw [coeffEmb_qExpand, qTwist_qExpand]
+  have : v ^ (N : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN evalAtJ evalAtJ_X ModularPolynomialData \
+  coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  coeffMap_qExpand PhiGen.splits_of_prime"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN evalAtJ evalAtJ_X ModularPolynomialData \
+  coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  coeffMap_qExpand PhiGen.splits_of_prime"
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd splits_of_prime"
+end ModularCurve.PhiGen
+p2m_open_scoped "ModularCurve ModularCurve.PhiGen" in
+private theorem ModularCurve.PhiGen.splits_prime_at_slot {K : Type*} [Field K] [Algebra ℚ K] (N : ℕ)
+    [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (hpN : p ∣ N) (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K)) (qExpand K (p * e)
+      (qTwist (u ^ p) (coeffEmb K jq)))) = (Polynomial.X - Polynomial.C (qExpand K (p * (p * e))
+      (qTwist (u ^ (p * p)) (coeffEmb K jq)))) * ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C
+      (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))) := by
+  have hζp : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p :=
+    ModularCurve.W1.isPrimitiveRoot_pow_div hζ hpN
+  have h0 := ModularCurve.PhiGen.splits_of_prime p (ζ ^ (N / p)) hζp data
+  have hhom : Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq)))
+      = ((qExpand K e).comp (qTwist u)).comp (((coeffEmb K).comp (qExpand ℚ p)).comp evalAtJ) := by
+    refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+    simp only [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X, RingHom.comp_apply, evalAtJ_X]
+    rw [ModularCurve.W1.iota_jq, ModularCurve.W1.qExpand_qTwist_TS, mul_one, zpow_natCast]
+    simpa only [TS_eq_coeffEmb] using (ModularCurve.W1.TS_congr (Nat.mul_comm e p) (u ^ p)).symm
+  have h₀ : ((qExpand K e).comp (qTwist u)) (conj p (ζ ^ (N / p)) (0 : Fin (p + 1)))
+      = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)) := by
+    rw [RingHom.comp_apply, ModularCurve.W1.conj_zero_eq, ModularCurve.W1.qExpand_qTwist_TS,
+      mul_one, zpow_natCast]
+    simpa only [TS_eq_coeffEmb] using
+      ModularCurve.W1.TS_congr (by ring : e * (p * p) = p * (p * e)) (u ^ (p * p))
+  have h₁ : ∀ b : Fin p, ((qExpand K e).comp (qTwist u)) (conj p (ζ ^ (N / p)) b.succ)
+      = qExpand K e (qTwist (u * ζ ^ ((b : ℕ) * (N / p))) (coeffEmb K jq)) := by
+    intro b
+    rw [RingHom.comp_apply, ModularCurve.W1.conj_succ_eq, ModularCurve.W1.qExpand_qTwist_TS,
+      Nat.cast_one, zpow_one, ← pow_mul, Nat.mul_comm (N / p) (b : ℕ)]
+    simpa only [TS_eq_coeffEmb] using ModularCurve.W1.TS_congr (mul_one e) (u * ζ ^ ((b : ℕ) * (N /
+      p)))
+  rw [hhom, ← Polynomial.map_map, h0,
+    show phiProd p (conj p (ζ ^ (N / p)))
+        = ∏ i : Fin (p + 1), (Polynomial.X - Polynomial.C (conj p (ζ ^ (N / p)) i)) from rfl,
+    Polynomial.map_prod]
+  simp only [Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C]
+  simp only [Fin.prod_univ_succ]
+  congr 1
+  · rw [h₀]
+  · rw [Finset.prod_range
+      (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K
+      jq))))]
+    exact Finset.prod_congr rfl fun i _ => by rw [h₁ i]
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN evalAtJ evalAtJ_X ModularPolynomialData \
+  coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  coeffMap_qExpand PhiGen.splits_of_prime"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem prod_form_ne_zero (N : ℕ) (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e]
+    (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K
+            jq)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+          (Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u,
+    Polynomial.roots_mul (prod_form_ne_zero N ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p)))
+    (coeffEmb K jq))))
+        = ((Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+        (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+        (Multiset.range p).map
+          (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).Nodup := by
+  have hζp : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := isPrimitiveRoot_pow_div hζ hpN
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h := (TS_injective (K := K) (e := e) (e' := p * (p * e))
+      (u := u * ζ ^ (b * (N / p))) (u' := u ^ (p * p))
+      (by simpa only [TS_eq_coeffEmb] using heq)).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e)
+      (u := u * ζ ^ (b * (N / p))) (u' := u * ζ ^ (b' * (N / p)))
+      (by simpa only [TS_eq_coeffEmb] using heq)).2
+    have h2 : ζ ^ (b * (N / p)) = ζ ^ (b' * (N / p)) := mul_left_cancel h
+    have h3 : (ζ ^ (N / p)) ^ b = (ζ ^ (N / p)) ^ b' := by
+      rw [← pow_mul, ← pow_mul, Nat.mul_comm (N / p) b, Nat.mul_comm (N / p) b']
+      exact h2
+    have h4 : ((ζ ^ (N / p) : Kˣ) : K) ^ b = ((ζ ^ (N / p) : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h3]
+    exact hζp.pow_inj hb hb' h4
+
+theorem roots_prime_at_slot_roots_nodup (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots.Nodup := by
+  rw [roots_prime_at_slot N ζ hζ p hpN data e u]
+  exact roots_prime_at_slot_nodup N ζ hζ p hpN e u
+
+theorem isRoot_prime_at_slot_iff (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u]
+    exact prod_form_ne_zero N ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot N ζ hζ p hpN data e u,
+    Multiset.mem_cons, Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+end ModularCurve.W1
+
+end
+
+p2m_open "ModularCurve~coeffEmb_qExpand\
+  " in
+open _root_.P2MW.S_ModularCurve_PhiGen_splits_prime_at_slot.ModularCurve _root_.ModularCurve.PhiGen
+  _root_.P2MW.S_ModularCurve_PhiGen_splits_prime_at_slot.ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] [Algebra ℚ K] (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K)) (qExpand K (p * e)
+      (qTwist (u ^ p) (coeffEmb K jq)))) = (Polynomial.X - Polynomial.C (qExpand K (p * (p * e))
+      (qTwist (u ^ (p * p)) (coeffEmb K jq)))) * ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C
+      (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))) :=
+  ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u
+
+end S_ModularCurve_PhiGen_splits_prime_at_slot
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_splits_prime_at_slot (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.splits_prime_at_slot {K : Type*} [Field K] [Algebra ℚ K] (N : ℕ)
+    [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (hpN : p ∣ N) (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K)) (qExpand K (p * e)
+      (qTwist (u ^ p) (coeffEmb K jq)))) = (Polynomial.X - Polynomial.C (qExpand K (p * (p * e))
+      (qTwist (u ^ (p * p)) (coeffEmb K jq)))) * ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C
+      (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))) :=
+  solution N ζ hζ p hpN data e u
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_splits_prime_at_slot_of_isPrimitiveRoot.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_splits_prime_at_slot_of_isPrimitiveRoot.lean
new file mode 100644
index 0000000000..5b836dc1d5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_splits_prime_at_slot_of_isPrimitiveRoot.lean
@@ -0,0 +1,660 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot
+(d9095e24-91b1-5043-93c5-196e9d87e5b0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c2b3fefc-b92f-55d4-bef5-c549467bd7d4
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_injective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_neg_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_order_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_mul_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_of_mul_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_of_prime
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.RingTheory.AdjoinRoot
+import Mathlib.RingTheory.Polynomial.Cyclotomic.Roots
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Prime-level splitting of Φₚ at the slot uq^e
+
+Theorem statement: `ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot`
+(`d9095e24-91b1-5043-93c5-196e9d87e5b0`), by Claude, 2026-09-05.
+
+Proof: submission `c2b3fefc-b92f-55d4-bef5-c549467bd7d4`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, $p$ a prime, and $\zeta \in K^\times$ a unit whose image in $K$ is a primitive
+$p$-th root of unity (so $K$ has characteristic $\neq p$). Let `data` be a level-$p$ modular
+polynomial datum: a polynomial $\Phi \in \mathbb{Z}[X][Y]$, monic, of degree $\sum_{d \mid p,\ d
+\text{ squarefree}} p/d = p+1$ in $Y$, satisfying $\Phi(j(q), j(q^p)) = 0$ in $\mathbb{Q}((q))$,
+where $j$ denotes the formal $q$-expansion `jq` and the inner variable is evaluated at $j(q)$. Let
+$e$ be a nonzero natural number and $u \in K^\times$. Write $j_K = q^{-1}\cdot(\text{image of }
+E_4^3/\text{(eta factor)})$ for the $j$-expansion `jqModC K` over $K$, and for a unit $v$ and
+nonzero $N$ let $v, N$ act on $K((q))$ by the ring homomorphisms `qTwist` ($q \mapsto vq$, i.e. the
+$k$-th coefficient is multiplied by $v^k$) and `qExpand` ($q \mapsto q^N$). Then, in $K((q))[Y]$,
+specialising the integer coefficients of $\Phi$ into $K((q))$ and its inner variable at $j_K(u^p
+q^{pe})$ yields $$\Phi\bigl(j_K(u^pq^{pe}), Y\bigr) = \bigl(Y -
+j_K(u^{p^2}q^{p^2e})\bigr)\prod_{b=0}^{p-1}\bigl(Y - j_K(u\zeta^b q^{e})\bigr).$$
+
+This is the classical factorisation of the level-$p$ modular polynomial, $\Phi_p(j(p\tau), Y) = (Y -
+j(p^2\tau))\prod_{b<p}(Y - j((\tau+b)/p))$, in the formal $q$-expansion model over an arbitrary
+field containing a primitive $p$-th root of unity, and stated at an arbitrary slot $s = uq^e$ rather
+than only at $s = q$. It supplies the list of the $p+1$ expansions lying above a given conjugate one
+step up a tower of $q$-expansion fields, and is used in the construction of monic factorisations of
+$\Phi$ over such fields, in the proof that $j(q^{dp})$ lies in the relevant modular function field,
+and in the chart computations on $X_1(p)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_splits_prime_at_slot_of_isPrimitiveRoot.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_splits_prime_at_slot_of_isPrimitiveRoot
+
+noncomputable section
+
+p2m_open "ModularCurve \
+  P2MW.S_ModularCurve_PhiGen_splits_prime_at_slot_of_isPrimitiveRoot.ModularCurve \
+  ModularCurve.PhiGen \
+  P2MW.S_ModularCurve_PhiGen_splits_prime_at_slot_of_isPrimitiveRoot.ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq dedekindPsi evalAtJ evalAtJ_X ModularPolynomialData coeffMap \
+  coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  EvalSymm jqModC jqNModC jqModC_rat map_jqModC coeffMap_qExpand coeffMap_injective \
+  coeff_jqModC_neg_one order_jqModC PhiGen.splits_of_prime"
+namespace W1
+p2m_open "ModularCurve"
+
+variable {K : Type*} [Field K]
+
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+theorem jqModC_eq_TS : jqModC K = TS K 1 1 := by
+  rw [TS, qTwist_one_apply, qExpand_one_apply]
+
+theorem jqNModC_eq_TS (d : ℕ) [NeZero d] : jqNModC K d = TS K d 1 := by
+  rw [jqNModC, TS, qTwist_one_apply]
+
+theorem qExpand_jqNModC (A d : ℕ) [NeZero A] [NeZero d] :
+    qExpand K A (jqNModC K d) = TS K (A * d) 1 := by
+  rw [jqNModC_eq_TS, qExpand_TS]
+
+theorem qExpand_jqModC_eq_TS (A : ℕ) [NeZero A] : qExpand K A (jqModC K) = TS K A 1 := by
+  rw [TS, qTwist_one_apply]
+
+theorem qTwist_qExpand_of_pow_eq_one (A : ℕ) [NeZero A] (v : Kˣ) (hv : v ^ A = 1)
+    (x : LaurentSeries K) :
+    qTwist v (qExpand K A x) = qExpand K A x := by
+  rw [qTwist_qExpand]
+  have : v ^ (A : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq dedekindPsi evalAtJ evalAtJ_X ModularPolynomialData coeffMap \
+  coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  EvalSymm jqModC jqNModC jqModC_rat map_jqModC coeffMap_qExpand coeffMap_injective \
+  coeff_jqModC_neg_one order_jqModC PhiGen.splits_of_prime"
+namespace W1
+p2m_open "ModularCurve"
+
+section transport
+
+variable {R S : Type*} [CommRing R] [CommRing S]
+
+theorem coeffMap_qTwist (σ : R →+* S) (u : Rˣ) (f : LaurentSeries R) :
+    coeffMap σ (qTwist u f) = qTwist (Units.map σ.toMonoidHom u) (coeffMap σ f) := by
+  ext k
+  simp only [coeffMap_coeff, qTwist_coeff, map_mul]
+  congr 1
+  rw [← map_zpow, Units.coe_map]
+  rfl
+
+end transport
+
+variable {K : Type*} [Field K]
+
+theorem coeffMap_TS {L : Type*} [Field L] (σ : L →+* K) (e : ℕ) [NeZero e] (u : Lˣ) :
+    coeffMap σ (TS L e u) = TS K e (Units.map σ.toMonoidHom u) := by
+  rw [TS, TS, coeffMap_qExpand, coeffMap_qTwist]
+  exact congrArg (fun z => qExpand K e (qTwist (Units.map σ.toMonoidHom u) z)) (map_jqModC σ)
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem units_pow_eq_one_of_isPrimitiveRoot {N : ℕ} {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N) :
+    ζ ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq dedekindPsi evalAtJ evalAtJ_X ModularPolynomialData coeffMap \
+  coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  EvalSymm jqModC jqNModC jqModC_rat map_jqModC coeffMap_qExpand coeffMap_injective \
+  coeff_jqModC_neg_one order_jqModC PhiGen.splits_of_prime"
+namespace W1
+p2m_open "ModularCurve"
+
+
+
+
+
+
+theorem phiAtSeed_jqNModC_eval {R : Type*} [CommRing R] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n)
+    (d : ℕ) [NeZero d] : (phiAtSeed data (jqNModC R d)).eval (jqNModC R (d * n)) = 0 := by
+  have h := data.eval_jqNModC_mul_eq_zero R d
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  exact Polynomial.ringHom_ext' (RingHom.ext_int _ _) (by first | simp)
+
+theorem phiAtSeed_jqNModC_eval_symm {R : Type*} [CommRing R] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n)
+    (hsymm : EvalSymm data.Φ) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (jqNModC R (d * n))).eval (jqNModC R d) = 0 := by
+  have h := data.eval_jqNModC_of_mul_eq_zero hsymm R d
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  exact Polynomial.ringHom_ext' (RingHom.ext_int _ _) (by first | simp)
+
+theorem phiAtSeed_TS_eval {K : Type*} [Field K] (A : ℕ) [NeZero A] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (TS K (A * d) 1)).eval (TS K (A * (d * n)) 1) = 0 := by
+  have h := phiAtSeed_eval_map data _ _ (qExpand K A) (phiAtSeed_jqNModC_eval (R := K) n data d)
+  rwa [qExpand_jqNModC, qExpand_jqNModC] at h
+
+theorem phiAtSeed_TS_eval_symm {K : Type*} [Field K] (A : ℕ) [NeZero A] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n) (hsymm : EvalSymm data.Φ) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (TS K (A * (d * n)) 1)).eval (TS K (A * d) 1) = 0 := by
+  have h :=
+    phiAtSeed_eval_map data _ _ (qExpand K A) (phiAtSeed_jqNModC_eval_symm (R := K) n data hsymm d)
+  rwa [qExpand_jqNModC, qExpand_jqNModC] at h
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq dedekindPsi evalAtJ evalAtJ_X ModularPolynomialData coeffMap \
+  coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  EvalSymm jqModC jqNModC jqModC_rat map_jqModC coeffMap_qExpand coeffMap_injective \
+  coeff_jqModC_neg_one order_jqModC PhiGen.splits_of_prime"
+namespace W1
+p2m_open "ModularCurve"
+
+section ksplitEngine
+
+private theorem ksplit_exists_isPrimitiveRoot (N : ℕ) [NeZero N] :
+    ∃ z : CyclotomicField N ℚ, IsPrimitiveRoot z N := by
+  have : NeZero ((N : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr (NeZero.ne N)⟩
+  have : IsCyclotomicExtension {N} ℚ (CyclotomicField N ℚ) :=
+    CyclotomicField.isCyclotomicExtension N ℚ
+  exact IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField N ℚ) (Set.mem_singleton N)
+    (NeZero.ne N)
+
+private def ksplitCycUnit (N : ℕ) [NeZero N] : (CyclotomicField N ℚ)ˣ :=
+  ((ksplit_exists_isPrimitiveRoot N).choose_spec.isUnit (NeZero.ne N)).unit
+
+private theorem ksplitCycUnit_spec (N : ℕ) [NeZero N] :
+    IsPrimitiveRoot ((ksplitCycUnit N : (CyclotomicField N ℚ)ˣ) : CyclotomicField N ℚ) N := by
+  rw [ksplitCycUnit, IsUnit.unit_spec]
+  exact (ksplit_exists_isPrimitiveRoot N).choose_spec
+
+private theorem ksplit_comp_evalAtJ {L : Type*} [CommRing L] (φ : LaurentSeries ℚ →+* L) :
+    φ.comp evalAtJ = Polynomial.eval₂RingHom (Int.castRingHom L) (φ jq) := by
+  refine Polynomial.ringHom_ext (fun a => ?_) ?_
+  · have h1 : evalAtJ (Polynomial.C a) = ((a : ℤ) : LaurentSeries ℚ) := by
+      simp [evalAtJ]
+    rw [RingHom.comp_apply, h1, map_intCast, Polynomial.coe_eval₂RingHom, Polynomial.eval₂_C]
+    simp
+  · rw [RingHom.comp_apply, evalAtJ_X, Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X]
+
+variable (p : ℕ) [hp : Fact (Nat.Prime p)]
+
+omit hp in
+private theorem ksplit_root_pow : (AdjoinRoot.root (Polynomial.cyclotomic p ℤ)) ^ p = 1 := by
+  obtain ⟨c, hc⟩ := Polynomial.cyclotomic.dvd_X_pow_sub_one p ℤ
+  have hmk : AdjoinRoot.mk (Polynomial.cyclotomic p ℤ) (Polynomial.X ^ p - 1) = 0 := by
+    rw [hc, map_mul, AdjoinRoot.mk_self, zero_mul]
+  have h0 : Polynomial.aeval (AdjoinRoot.root (Polynomial.cyclotomic p ℤ))
+      (Polynomial.X ^ p - 1 : Polynomial ℤ) = 0 := by
+    rw [AdjoinRoot.aeval_eq]
+    exact hmk
+  rw [map_sub, map_pow, Polynomial.aeval_X, map_one] at h0
+  exact sub_eq_zero.mp h0
+
+private def ksplitZeta : (AdjoinRoot (Polynomial.cyclotomic p ℤ))ˣ where
+  val := AdjoinRoot.root (Polynomial.cyclotomic p ℤ)
+  inv := (AdjoinRoot.root (Polynomial.cyclotomic p ℤ)) ^ (p - 1)
+  val_inv := by
+    rw [← pow_succ']
+    rw [Nat.sub_add_cancel hp.out.one_le]
+    exact ksplit_root_pow p
+  inv_val := by
+    rw [← pow_succ]
+    rw [Nat.sub_add_cancel hp.out.one_le]
+    exact ksplit_root_pow p
+
+private def ksplitIota : AdjoinRoot (Polynomial.cyclotomic p ℤ) →+* CyclotomicField p ℚ :=
+  AdjoinRoot.lift (Int.castRingHom (CyclotomicField p ℚ))
+    ((ksplitCycUnit p : (CyclotomicField p ℚ)ˣ) : CyclotomicField p ℚ) (by
+      rw [Polynomial.eval₂_eq_eval_map, Polynomial.map_cyclotomic_int]
+      exact Polynomial.IsRoot.eq_zero ((ksplitCycUnit_spec p).isRoot_cyclotomic hp.out.pos))
+
+private theorem ksplitIota_root :
+    ksplitIota p (AdjoinRoot.root (Polynomial.cyclotomic p ℤ))
+      = ((ksplitCycUnit p : (CyclotomicField p ℚ)ˣ) : CyclotomicField p ℚ) :=
+  AdjoinRoot.lift_root _
+
+private theorem ksplitIota_units_zeta :
+    Units.map (ksplitIota p).toMonoidHom (ksplitZeta p) = ksplitCycUnit p :=
+  Units.ext (by rw [Units.coe_map]; exact ksplitIota_root p)
+
+private theorem ksplitIota_injective : Function.Injective (ksplitIota p) := by
+  rw [injective_iff_map_eq_zero]
+  intro a ha
+  obtain ⟨g, rfl⟩ := AdjoinRoot.mk_surjective a
+  rw [ksplitIota, AdjoinRoot.lift_mk] at ha
+  rw [AdjoinRoot.mk_eq_zero]
+  have hq : Polynomial.aeval ((ksplitCycUnit p : (CyclotomicField p ℚ)ˣ) : CyclotomicField p ℚ)
+      (g.map (Int.castRingHom ℚ)) = 0 := by
+    rw [Polynomial.aeval_def, Polynomial.eval₂_map,
+      show (algebraMap ℚ (CyclotomicField p ℚ)).comp (Int.castRingHom ℚ)
+        = Int.castRingHom (CyclotomicField p ℚ) from RingHom.ext_int _ _]
+    exact ha
+  have hdvd : Polynomial.cyclotomic p ℚ ∣ g.map (Int.castRingHom ℚ) := by
+    rw [Polynomial.cyclotomic_eq_minpoly_rat (ksplitCycUnit_spec p) hp.out.pos]
+    exact minpoly.dvd ℚ _ hq
+  rw [← Polynomial.map_cyclotomic_int p ℚ] at hdvd
+  exact (Polynomial.map_dvd_map (Int.castRingHom ℚ) Int.cast_injective
+    (Polynomial.cyclotomic.monic p ℤ)).mp hdvd
+
+omit hp in
+private theorem ksplit_coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb (CyclotomicField p ℚ) (qExpand ℚ n x) = qExpand (CyclotomicField p ℚ) n (coeffEmb
+      (CyclotomicField p ℚ) x) :=
+  coeffMap_qExpand (algebraMap ℚ (CyclotomicField p ℚ)) n x
+
+omit hp in
+private theorem ksplit_coeffEmb_jq :
+    coeffEmb (CyclotomicField p ℚ) jq = jqModC (CyclotomicField p ℚ) := by
+  rw [coeffEmb, ← jqModC_rat]
+  exact map_jqModC (algebraMap ℚ (CyclotomicField p ℚ))
+
+private theorem ksplit_integral (data : ModularPolynomialData p) :
+    phiAtSeed data (qExpand (AdjoinRoot (Polynomial.cyclotomic p ℤ)) p (jqModC (AdjoinRoot
+      (Polynomial.cyclotomic p ℤ))))
+      = (Polynomial.X - Polynomial.C (qExpand (AdjoinRoot (Polynomial.cyclotomic p ℤ)) (p * p)
+          (jqModC (AdjoinRoot (Polynomial.cyclotomic p ℤ)))))
+        * ∏ b : Fin p, (Polynomial.X - Polynomial.C (qTwist ((ksplitZeta p) ^ (b : ℕ))
+            (jqModC (AdjoinRoot (Polynomial.cyclotomic p ℤ))))) := by
+  classical
+  have hK := ModularCurve.PhiGen.splits_of_prime p (ksplitCycUnit p) (ksplitCycUnit_spec p) data
+  have hLK : data.Φ.map (((coeffEmb (CyclotomicField p ℚ)).comp (qExpand ℚ p)).comp evalAtJ)
+      = phiAtSeed data (qExpand (CyclotomicField p ℚ) p (jqModC (CyclotomicField p ℚ))) := by
+    have hseed : ((coeffEmb (CyclotomicField p ℚ)).comp (qExpand ℚ p)) jq
+        = qExpand (CyclotomicField p ℚ) p (jqModC (CyclotomicField p ℚ)) := by
+      rw [RingHom.comp_apply, ksplit_coeffEmb_qExpand, ksplit_coeffEmb_jq]
+    rw [ksplit_comp_evalAtJ, hseed, phiAtSeed]
+  have hseedO : coeffMap (ksplitIota p)
+      (qExpand (AdjoinRoot (Polynomial.cyclotomic p ℤ)) p (jqModC (AdjoinRoot (Polynomial.cyclotomic
+        p ℤ))))
+      = qExpand (CyclotomicField p ℚ) p (jqModC (CyclotomicField p ℚ)) := by
+    rw [coeffMap_qExpand]
+    congr 1
+    exact map_jqModC (ksplitIota p)
+  have hmapProd :
+      ((Polynomial.X - Polynomial.C (qExpand (AdjoinRoot (Polynomial.cyclotomic p ℤ)) (p * p)
+          (jqModC (AdjoinRoot (Polynomial.cyclotomic p ℤ)))))
+        * ∏ b : Fin p, (Polynomial.X - Polynomial.C (qTwist ((ksplitZeta p) ^ (b : ℕ))
+            (jqModC (AdjoinRoot (Polynomial.cyclotomic p ℤ)))))).map (coeffMap (ksplitIota p))
+      = phiProd p (conj p (ksplitCycUnit p)) := by
+    rw [phiProd, Fin.prod_univ_succ, Polynomial.map_mul]
+    congr 1
+    · rw [Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C, conj_zero]
+      congr 2
+      rw [coeffMap_qExpand, ksplit_coeffEmb_jq]
+      congr 1
+      exact map_jqModC (ksplitIota p)
+    · rw [← Polynomial.coe_mapRingHom, map_prod]
+      refine Finset.prod_congr rfl fun b _ => ?_
+      rw [Polynomial.coe_mapRingHom, Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C,
+        conj_succ, coeffMap_qTwist, map_pow, ksplitIota_units_zeta, ksplit_coeffEmb_jq]
+      exact congrArg
+        (fun z => Polynomial.X - Polynomial.C (qTwist (ksplitCycUnit p ^ (b : ℕ)) z))
+        (map_jqModC (ksplitIota p))
+  apply Polynomial.map_injective (coeffMap (ksplitIota p))
+    (ModularCurve.coeffMap_injective (ksplitIota_injective p))
+  rw [phiAtSeed_map, hseedO, hmapProd, ← hLK]
+  exact hK
+
+variable {K : Type*} [Field K]
+
+private def ksplitLift (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) p) :
+    AdjoinRoot (Polynomial.cyclotomic p ℤ) →+* K :=
+  AdjoinRoot.lift (Int.castRingHom K) (ζ : K) (by
+    rw [Polynomial.eval₂_eq_eval_map, Polynomial.map_cyclotomic_int]
+    exact Polynomial.IsRoot.eq_zero (hζ.isRoot_cyclotomic hp.out.pos))
+
+private theorem ksplitLift_root (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) p) :
+    ksplitLift p ζ hζ (AdjoinRoot.root (Polynomial.cyclotomic p ℤ)) = ζ :=
+  AdjoinRoot.lift_root _
+
+private theorem ksplitLift_units_zeta (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) p) :
+    Units.map (ksplitLift p ζ hζ).toMonoidHom (ksplitZeta p) = ζ :=
+  Units.ext (by rw [Units.coe_map]; exact ksplitLift_root p ζ hζ)
+
+theorem phiAtSeed_qExpand_prime_eq (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) :
+    phiAtSeed data (qExpand K p (jqModC K))
+      = (Polynomial.X - Polynomial.C (qExpand K (p * p) (jqModC K)))
+        * ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (qTwist (ζ ^ b) (jqModC K))) := by
+  classical
+  have h := congrArg (Polynomial.map (coeffMap (ksplitLift p ζ hζ))) (ksplit_integral p data)
+  have hseed : coeffMap (ksplitLift p ζ hζ)
+      (qExpand (AdjoinRoot (Polynomial.cyclotomic p ℤ)) p (jqModC (AdjoinRoot (Polynomial.cyclotomic
+        p ℤ))))
+      = qExpand K p (jqModC K) := by
+    rw [coeffMap_qExpand]
+    congr 1
+    exact map_jqModC (ksplitLift p ζ hζ)
+  have hspread : coeffMap (ksplitLift p ζ hζ)
+      (qExpand (AdjoinRoot (Polynomial.cyclotomic p ℤ)) (p * p) (jqModC (AdjoinRoot
+        (Polynomial.cyclotomic p ℤ))))
+      = qExpand K (p * p) (jqModC K) := by
+    rw [coeffMap_qExpand]
+    congr 1
+    exact map_jqModC (ksplitLift p ζ hζ)
+  have hfac : ∀ b : Fin p,
+      (Polynomial.mapRingHom (coeffMap (ksplitLift p ζ hζ)))
+        (Polynomial.X - Polynomial.C (qTwist ((ksplitZeta p) ^ (b : ℕ))
+          (jqModC (AdjoinRoot (Polynomial.cyclotomic p ℤ)))))
+      = Polynomial.X - Polynomial.C (qTwist (ζ ^ (b : ℕ)) (jqModC K)) := by
+    intro b
+    rw [Polynomial.coe_mapRingHom, Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C,
+      coeffMap_qTwist, map_pow, ksplitLift_units_zeta]
+    exact congrArg (fun z => Polynomial.X - Polynomial.C (qTwist (ζ ^ (b : ℕ)) z))
+      (map_jqModC (ksplitLift p ζ hζ))
+  rw [phiAtSeed_map, hseed, Polynomial.map_mul, Polynomial.map_sub, Polynomial.map_X,
+    Polynomial.map_C,
+    hspread, ← Polynomial.coe_mapRingHom, map_prod, Finset.prod_congr rfl fun b _ => hfac b] at h
+  have hr : (∏ b : Fin p, (Polynomial.X - Polynomial.C (qTwist (ζ ^ (b : ℕ)) (jqModC K))))
+      = ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (qTwist (ζ ^ b) (jqModC K))) :=
+    Fin.prod_univ_eq_prod_range (fun b => Polynomial.X - Polynomial.C (qTwist (ζ ^ b) (jqModC K))) p
+  rw [hr] at h
+  exact h
+
+theorem phiAtSeed_slot_prime_eq (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    phiAtSeed data (qExpand K (p * e) (qTwist (u ^ p) (jqModC K)))
+      = (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K))))
+        * ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ b)
+          (jqModC K)))) := by
+  classical
+  set f : LaurentSeries K →+* LaurentSeries K := (qExpand K e).comp (qTwist u) with hf
+  have hseed : f (qExpand K p (jqModC K)) = qExpand K (p * e) (qTwist (u ^ p) (jqModC K)) := by
+    rw [hf, RingHom.comp_apply, qTwist_qExpand, qExpand_qExpand, zpow_natCast]
+    exact qExpand_congr (Nat.mul_comm e p) _
+  have hspread : f (qExpand K (p * p) (jqModC K)) = qExpand K (p * (p * e)) (qTwist (u ^ (p * p))
+    (jqModC K)) :=
+    by
+    rw [hf, RingHom.comp_apply, qTwist_qExpand, qExpand_qExpand, zpow_natCast]
+    exact qExpand_congr (by ring) _
+  have hfac : ∀ b ∈ Finset.range p,
+      (Polynomial.mapRingHom f) (Polynomial.X - Polynomial.C (qTwist (ζ ^ b) (jqModC K)))
+        = Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ b) (jqModC K))) := by
+    intro b _
+    rw [Polynomial.coe_mapRingHom, Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C, hf,
+      RingHom.comp_apply, qTwist_qTwist]
+  have h := congrArg (Polynomial.map f) (phiAtSeed_qExpand_prime_eq p ζ hζ data)
+  rw [phiAtSeed_map, hseed, Polynomial.map_mul, Polynomial.map_sub, Polynomial.map_X,
+    Polynomial.map_C,
+    hspread, ← Polynomial.coe_mapRingHom, map_prod, Finset.prod_congr rfl hfac] at h
+  exact h
+
+end ksplitEngine
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq dedekindPsi evalAtJ evalAtJ_X ModularPolynomialData coeffMap \
+  coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  EvalSymm jqModC jqNModC jqModC_rat map_jqModC coeffMap_qExpand coeffMap_injective \
+  coeff_jqModC_neg_one order_jqModC PhiGen.splits_of_prime"
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd splits_of_prime"
+end ModularCurve.PhiGen
+p2m_open_scoped "ModularCurve ModularCurve.PhiGen" in
+open ModularCurve.W1 in
+private theorem ModularCurve.PhiGen.splits_prime_of_isPrimitiveRoot {K : Type*} [Field K] (p : ℕ)
+    [hp : Fact (Nat.Prime p)] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) :
+    data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K)) (qExpand K p (jqModC
+      K))) = (Polynomial.X - Polynomial.C (qExpand K (p * p) (jqModC K))) * ∏ b ∈ Finset.range p,
+      (Polynomial.X - Polynomial.C (qTwist (ζ ^ b) (jqModC K))) :=
+  phiAtSeed_qExpand_prime_eq p ζ hζ data
+
+p2m_open_scoped "ModularCurve ModularCurve.PhiGen" in
+open ModularCurve.W1 in
+private theorem ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot {K : Type*} [Field K]
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K)) (qExpand K (p * e)
+      (qTwist (u ^ p) (jqModC K)))) = (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist
+      (u ^ (p * p)) (jqModC K)))) * ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (qExpand K e
+      (qTwist (u * ζ ^ b) (jqModC K)))) :=
+  phiAtSeed_slot_prime_eq p ζ hζ data e u
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq dedekindPsi evalAtJ evalAtJ_X ModularPolynomialData coeffMap \
+  coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  EvalSymm jqModC jqNModC jqModC_rat map_jqModC coeffMap_qExpand coeffMap_injective \
+  coeff_jqModC_neg_one order_jqModC PhiGen.splits_of_prime"
+namespace W1
+p2m_open "ModularCurve"
+
+variable {K : Type*} [Field K]
+
+private theorem prod_form_ne_zero (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e] (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ b) (jqModC K)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (jqModC K))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K))) ::ₘ
+          (Multiset.range p).map (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot p ζ hζ data e u,
+    Polynomial.roots_mul (prod_form_ne_zero ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ b) (jqModC K))))
+        = ((Multiset.range p).map (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K))) (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K))) ::ₘ
+        (Multiset.range p).map (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K)))).Nodup := by
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h :=
+      (TS_injective (K := K) (e := e) (e' := p * (p * e)) (u := u * ζ ^ b) (u' := u ^ (p * p))
+        heq).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e) (u := u * ζ ^ b) (u' := u * ζ ^ b') heq).2
+    have h2 : ζ ^ b = ζ ^ b' := mul_left_cancel h
+    have h3 : ((ζ : Kˣ) : K) ^ b = ((ζ : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h2]
+    exact hζ.pow_inj hb hb' h3
+
+theorem roots_prime_at_slot_roots_nodup (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (jqModC K))))).roots.Nodup := by
+  rw [roots_prime_at_slot p ζ hζ data e u]
+  exact roots_prime_at_slot_nodup p ζ hζ e u
+
+theorem isRoot_prime_at_slot_iff (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (jqModC K))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ b) (jqModC K)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (jqModC K)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot p ζ hζ data e u]
+    exact prod_form_ne_zero ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot p ζ hζ data e u, Multiset.mem_cons,
+    Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+theorem roots_phiAtSeed_TS (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (phiAtSeed data (TS K (p * e) (u ^ p))).roots
+      = TS K (p * (p * e)) (u ^ (p * p)) ::ₘ (Multiset.range p).map (fun b => TS K e (u * ζ ^ b)) :=
+  roots_prime_at_slot p ζ hζ data e u
+
+end ModularCurve.W1
+
+p2m_open_scoped "ModularCurve ModularCurve.PhiGen" in
+open ModularCurve.W1 in
+private theorem ModularCurve.PhiGen.roots_nodup_prime_at_slot_of_isPrimitiveRoot {K : Type*}
+    [Field K] (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K)) (qExpand K (p * e)
+      (qTwist (u ^ p) (jqModC K))))).roots.Nodup :=
+  roots_prime_at_slot_roots_nodup p ζ hζ data e u
+
+end
+
+open _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_PhiGen_splits_prime_at_slot_of_isPrimitiveRoot.ModularCurve
+  _root_.ModularCurve.PhiGen
+  _root_.P2MW.S_ModularCurve_PhiGen_splits_prime_at_slot_of_isPrimitiveRoot.ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K)) (qExpand K (p * e)
+      (qTwist (u ^ p) (jqModC K)))) = (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist
+      (u ^ (p * p)) (jqModC K)))) * ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (qExpand K e
+      (qTwist (u * ζ ^ b) (jqModC K)))) :=
+  ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot p ζ hζ data e u
+
+end S_ModularCurve_PhiGen_splits_prime_at_slot_of_isPrimitiveRoot
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_splits_prime_at_slot_of_isPrimitiveRoot (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot {K : Type*} [Field K] (p : ℕ)
+    [hp : Fact (Nat.Prime p)] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K)) (qExpand K (p * e)
+      (qTwist (u ^ p) (jqModC K)))) = (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist
+      (u ^ (p * p)) (jqModC K)))) * ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (qExpand K e
+      (qTwist (u * ζ ^ b) (jqModC K)))) :=
+  solution p ζ hζ data e u
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_sum_qTwist_coeff.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_sum_qTwist_coeff.lean
new file mode 100644
index 0000000000..0ea16c7898
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_PhiGen_sum_qTwist_coeff.lean
@@ -0,0 +1,692 @@
+/-
+Based on Prove2Me node ModularCurve.PhiGen.sum_qTwist_coeff
+(a671034f-d53b-5757-9df2-3d57dbe05eeb) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission fef0a926-2de7-5c6b-9b97-ea26696755bc
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_DegeneracyTower
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_of_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_minpoly_jqN_eq_toAdjoin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_aeval_jqN_toAdjoin
+import Mathlib.RingTheory.Trace.Basic
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.NumberTheory.Cyclotomic.PrimitiveRoots
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Summing q-twists over the ℓ-th roots of unity
+
+Theorem statement: `ModularCurve.PhiGen.sum_qTwist_coeff` (`a671034f-d53b-5757-9df2-3d57dbe05eeb`),
+by Claude, 2026-09-05.
+
+Proof: submission `fef0a926-2de7-5c6b-9b97-ea26696755bc`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field carrying a $\mathbb{Q}$-algebra structure, let $\ell$ be a natural number, and
+let $\zeta$ be a unit of $K$ whose underlying element is a primitive $\ell$-th root of unity. For a
+unit $u$ of a commutative ring, `qTwist u` denotes the ring endomorphism of the Laurent series (Hahn
+series over $\mathbb{Z}$) that multiplies the coefficient of index $k \in \mathbb{Z}$ by the
+integral power $u^{k}$, i.e. formally the substitution $f(q) \mapsto f(uq)$. The assertion is that
+for every Laurent series $f$ over $K$ and every integer $k$, the $k$-th coefficient of
+$\sum_{b=0}^{\ell-1} \mathrm{qTwist}(\zeta^{b})\,f$ equals $\ell \cdot a_k(f)$, where $a_k(f)$ is
+the $k$-th coefficient of $f$ and $\ell$ is read in $K$, when $\ell$ divides $k$ in $\mathbb{Z}$,
+and equals $0$ otherwise. No restriction is placed on $\ell$: for $\ell = 0$ the sum is empty and
+both sides vanish, and for $\ell = 1$ the statement is trivial.
+
+This is the orthogonality relation for the $\ell$-th roots of unity, in the form in which it is
+applied to formal $q$-expansions: averaging a Laurent series over the twists $q \mapsto \zeta^{b} q$
+projects onto the coefficients in degrees divisible by $\ell$. It is used in the coefficient
+computations for the $q$-expansion model of the modular curve, notably by
+[`ModularCurve.PhiGen.weightTwo_coeff_sum_slots`]
+(thm.html#ModularCurve.PhiGen.weightTwo_coeff_sum_slots),
+[`ModularCurve.theta_coeff`](thm.html#ModularCurve.theta_coeff) and
+[`ModularCurve.theta_mul`](thm.html#ModularCurve.theta_mul).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_PhiGen_sum_qTwist_coeff.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_PhiGen_sum_qTwist_coeff
+
+noncomputable section
+
+p2m_open "ModularCurve~coeffEmb_qExpand P2MW.S_ModularCurve_PhiGen_sum_qTwist_coeff.ModularCurve \
+  ModularCurve.PhiGen P2MW.S_ModularCurve_PhiGen_sum_qTwist_coeff.ModularCurve.PhiGen"
+open scoped IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ evalAtJ_X \
+  ModularPolynomialData evalAtJGen algebraMap_comp_evalAtJGen ModularPolynomialData.toAdjoin \
+  modularFunctionFieldFull coeffEmb coeffEmb_coeff laurentBaseChange qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand heckeBetaBar coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot PhiGen.splits_of_prime minpoly_jqN_eq_toAdjoin exists_phiIrreducible \
+  aeval_jqN_toAdjoin"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+
+
+
+
+
+
+
+
+
+
+theorem coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb K (qExpand ℚ n x) = qExpand K n (coeffEmb K x) :=
+  coeffMap_qExpand (algebraMap ℚ K) n x
+
+theorem iota_jqN (N d : ℕ) [NeZero N] [NeZero d] :
+    coeffEmb K (qExpand ℚ N (jqN d)) = TS K (N * d) 1 := by
+  rw [jqN, coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem iota_jq (N : ℕ) [NeZero N] : coeffEmb K (qExpand ℚ N jq) = TS K N 1 := by
+  rw [coeffEmb_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_zero_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    conj p ζ (0 : Fin (p + 1)) = TS K (p * p) 1 := by
+  rw [conj_zero, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_succ_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) (b : Fin p) :
+    conj p ζ b.succ = TS K 1 (ζ ^ (b : ℕ)) := by
+  rw [conj_succ, TS_eq_coeffEmb, qExpand_one_apply]
+
+theorem qTwist_iota_of_pow_eq_one (N : ℕ) [NeZero N] (v : Kˣ) (hv : v ^ N = 1) (x : LaurentSeries ℚ)
+    :
+    qTwist v (coeffEmb K (qExpand ℚ N x)) = coeffEmb K (qExpand ℚ N x) := by
+  rw [coeffEmb_qExpand, qTwist_qExpand]
+  have : v ^ (N : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ evalAtJ_X \
+  ModularPolynomialData evalAtJGen algebraMap_comp_evalAtJGen ModularPolynomialData.toAdjoin \
+  modularFunctionFieldFull coeffEmb coeffEmb_coeff laurentBaseChange qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand heckeBetaBar coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot PhiGen.splits_of_prime minpoly_jqN_eq_toAdjoin exists_phiIrreducible \
+  aeval_jqN_toAdjoin"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+omit [Algebra ℚ K] in
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+omit [Algebra ℚ K] in
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+omit [Algebra ℚ K] in
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem phiProd_conj_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    phiProd p (conj p ζ) = (Polynomial.X - Polynomial.C (TS K (p * p) 1)) *
+      ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) := by
+  rw [phiProd, Fin.prod_univ_succ, conj_zero_eq]
+  congr 1
+  rw [← Fin.prod_univ_eq_prod_range (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) p]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [conj_succ_eq]
+
+theorem roots_phiProd_conj (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    (phiProd p (conj p ζ)).roots = TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^
+      b)) := by
+  classical
+  rw [phiProd_conj_eq]
+  have h1 : (Polynomial.X - Polynomial.C (TS K (p * p) 1) : Polynomial (LaurentSeries K)) ≠ 0 :=
+    Polynomial.X_sub_C_ne_zero _
+  have h2 : (∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b)))) ≠ 0 :=
+    Finset.prod_ne_zero_iff.mpr fun b _ => Polynomial.X_sub_C_ne_zero _
+  rw [Polynomial.roots_mul (mul_ne_zero h1 h2), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod,
+    Finset.range_val]
+  have hm : (Multiset.map (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) (Multiset.range
+    p)) =
+      ((Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).map (fun a => Polynomial.X - Polynomial.C
+        a) := by
+    rw [Multiset.map_map]; rfl
+  rw [hm, Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+omit [Algebra ℚ K] in
+theorem roots_phiProd_conj_nodup (p : ℕ) [hp : Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).Nodup := by
+  refine Multiset.nodup_cons.mpr ⟨?_, ?_⟩
+  · intro hmem
+    obtain ⟨b, -, hb⟩ := Multiset.mem_map.mp hmem
+    have := (TS_injective hb).1
+    have h2 := hp.out.two_le
+    nlinarith
+  · refine (Multiset.nodup_range p).map_on fun b hb b' hb' hbb' => ?_
+    rw [Multiset.mem_range] at hb hb'
+    have hu := (TS_injective hbb').2
+    have hζu : IsPrimitiveRoot ζ p := IsPrimitiveRoot.coe_units_iff.mp hζ
+    exact hζu.pow_inj hb hb' hu
+
+theorem exists_isPrimitiveRoot_cyclotomicField (N : ℕ) [NeZero N] :
+    ∃ z : CyclotomicField N ℚ, IsPrimitiveRoot z N := by
+  have : NeZero ((N : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr (NeZero.ne N)⟩
+  have : IsCyclotomicExtension {N} ℚ (CyclotomicField N ℚ) :=
+    CyclotomicField.isCyclotomicExtension N ℚ
+  exact IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField N ℚ) (Set.mem_singleton N)
+    (NeZero.ne N)
+
+def cycUnit (N : ℕ) [NeZero N] : (CyclotomicField N ℚ)ˣ :=
+  ((exists_isPrimitiveRoot_cyclotomicField N).choose_spec.isUnit (NeZero.ne N)).unit
+
+theorem cycUnit_spec (N : ℕ) [NeZero N] :
+    IsPrimitiveRoot ((cycUnit N : (CyclotomicField N ℚ)ˣ) : CyclotomicField N ℚ) N := by
+  rw [cycUnit, IsUnit.unit_spec]
+  exact (exists_isPrimitiveRoot_cyclotomicField N).choose_spec
+
+theorem cycUnit_pow (N : ℕ) [NeZero N] : cycUnit N ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, (cycUnit_spec N).pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ evalAtJ_X \
+  ModularPolynomialData evalAtJGen algebraMap_comp_evalAtJGen ModularPolynomialData.toAdjoin \
+  modularFunctionFieldFull coeffEmb coeffEmb_coeff laurentBaseChange qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand heckeBetaBar coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot PhiGen.splits_of_prime minpoly_jqN_eq_toAdjoin exists_phiIrreducible \
+  aeval_jqN_toAdjoin"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ evalAtJ_X \
+  ModularPolynomialData evalAtJGen algebraMap_comp_evalAtJGen ModularPolynomialData.toAdjoin \
+  modularFunctionFieldFull coeffEmb coeffEmb_coeff laurentBaseChange qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand heckeBetaBar coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot PhiGen.splits_of_prime minpoly_jqN_eq_toAdjoin exists_phiIrreducible \
+  aeval_jqN_toAdjoin"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem prod_form_ne_zero (N : ℕ) (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e]
+    (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K
+            jq)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+          (Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u,
+    Polynomial.roots_mul (prod_form_ne_zero N ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p)))
+    (coeffEmb K jq))))
+        = ((Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+        (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+        (Multiset.range p).map
+          (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).Nodup := by
+  have hζp : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := isPrimitiveRoot_pow_div hζ hpN
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h := (TS_injective (K := K) (e := e) (e' := p * (p * e))
+      (u := u * ζ ^ (b * (N / p))) (u' := u ^ (p * p))
+      (by simpa only [TS_eq_coeffEmb] using heq)).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e)
+      (u := u * ζ ^ (b * (N / p))) (u' := u * ζ ^ (b' * (N / p)))
+      (by simpa only [TS_eq_coeffEmb] using heq)).2
+    have h2 : ζ ^ (b * (N / p)) = ζ ^ (b' * (N / p)) := mul_left_cancel h
+    have h3 : (ζ ^ (N / p)) ^ b = (ζ ^ (N / p)) ^ b' := by
+      rw [← pow_mul, ← pow_mul, Nat.mul_comm (N / p) b, Nat.mul_comm (N / p) b']
+      exact h2
+    have h4 : ((ζ ^ (N / p) : Kˣ) : K) ^ b = ((ζ ^ (N / p) : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h3]
+    exact hζp.pow_inj hb hb' h4
+
+theorem roots_prime_at_slot_roots_nodup (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots.Nodup := by
+  rw [roots_prime_at_slot N ζ hζ p hpN data e u]
+  exact roots_prime_at_slot_nodup N ζ hζ p hpN e u
+
+theorem isRoot_prime_at_slot_iff (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u]
+    exact prod_form_ne_zero N ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot N ζ hζ p hpN data e u,
+    Multiset.mem_cons, Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ evalAtJ_X \
+  ModularPolynomialData evalAtJGen algebraMap_comp_evalAtJGen ModularPolynomialData.toAdjoin \
+  modularFunctionFieldFull coeffEmb coeffEmb_coeff laurentBaseChange qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand heckeBetaBar coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot PhiGen.splits_of_prime minpoly_jqN_eq_toAdjoin exists_phiIrreducible \
+  aeval_jqN_toAdjoin"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+
+
+
+
+theorem phiAtSeed_jq_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) :
+    (phiAtSeed data jq).eval (jqN n) = 0 := by
+  have h := data.eval_eq_zero
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp [evalAtJ_X]
+
+
+theorem phiAtSeed_jqN_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN M)).eval (jqN (M * n)) = 0 := by
+  have h := phiAtSeed_eval_map data jq (jqN n) (qExpand ℚ M) (phiAtSeed_jq_eval n data)
+  rwa [jqN, qExpand_qExpand] at h
+
+theorem phiAtSeed_iota_eval {K : Type*} [Field K] [Algebra ℚ K] (A : ℕ) [NeZero A] (n : ℕ)
+    [NeZero n]
+    (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (coeffEmb K (qExpand ℚ A (jqN M)))).eval (coeffEmb K (qExpand ℚ A (jqN (M *
+      n)))) = 0 :=
+  phiAtSeed_eval_map data _ _ ((coeffEmb K).comp (qExpand ℚ A)) (phiAtSeed_jqN_eval n data M)
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ evalAtJ_X \
+  ModularPolynomialData evalAtJGen algebraMap_comp_evalAtJGen ModularPolynomialData.toAdjoin \
+  modularFunctionFieldFull coeffEmb coeffEmb_coeff laurentBaseChange qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand heckeBetaBar coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot PhiGen.splits_of_prime minpoly_jqN_eq_toAdjoin exists_phiIrreducible \
+  aeval_jqN_toAdjoin"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+private theorem geom_telescope {K : Type*} [Field K] (x : K) (n : ℕ) :
+    (∑ i ∈ Finset.range n, x ^ i) * (x - 1) = x ^ n - 1 := by
+  induction n with
+  | zero => simp
+  | succ m ih => rw [Finset.sum_range_succ, add_mul, ih]; ring
+
+open Classical in
+private theorem sum_pow_of_pow_eq_one {K : Type*} [Field K] {x : K} {ℓ : ℕ} (hx : x ^ ℓ = 1) :
+    ∑ b ∈ Finset.range ℓ, x ^ b = if x = 1 then (ℓ : K) else 0 := by
+  by_cases h1 : x = 1
+  · subst h1
+    simp
+  · rw [ite_eq_right h1]
+    have h2 := geom_telescope x ℓ
+    rw [hx, sub_self] at h2
+    rcases mul_eq_zero.mp h2 with h | h
+    · exact h
+    · exact absurd (sub_eq_zero.mp h) h1
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ evalAtJ_X \
+  ModularPolynomialData evalAtJGen algebraMap_comp_evalAtJGen ModularPolynomialData.toAdjoin \
+  modularFunctionFieldFull coeffEmb coeffEmb_coeff laurentBaseChange qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand heckeBetaBar coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot PhiGen.splits_of_prime minpoly_jqN_eq_toAdjoin exists_phiIrreducible \
+  aeval_jqN_toAdjoin"
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "conj conj_zero conj_succ phiProd splits_prime_at_slot \
+  splits_of_prime"
+end ModularCurve.PhiGen
+p2m_open_scoped "ModularCurve ModularCurve.PhiGen" in
+private theorem ModularCurve.PhiGen.sum_qTwist_coeff {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ)
+    (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) ℓ) (f : LaurentSeries K) (k : ℤ) :
+    (∑ b ∈ Finset.range ℓ, qTwist (ζ ^ b) f).coeff k
+      = if (ℓ : ℤ) ∣ k then (ℓ : K) * f.coeff k else 0 := by
+  rw [HahnSeries.coeff_sum]
+  have hval : ∀ b ∈ Finset.range ℓ, (qTwist (ζ ^ b) f).coeff k
+      = ((ζ ^ k : Kˣ) : K) ^ b * f.coeff k := by
+    intro b _
+    rw [qTwist_coeff]
+    congr 1
+    rw [← Units.val_pow_eq_pow_val]
+    congr 1
+    rw [← zpow_natCast ζ b, ← zpow_mul, mul_comm (b : ℤ) k, zpow_mul, zpow_natCast]
+  rw [Finset.sum_congr rfl hval, ← Finset.sum_mul]
+  have hx1 : ((ζ ^ k : Kˣ) : K) ^ ℓ = 1 := by
+    have h1 : (ζ : K) ^ ℓ = 1 := hζ.pow_eq_one
+    have h2 : ((ζ ^ k) ^ ℓ : Kˣ) = 1 := by
+      rw [← zpow_natCast (ζ ^ k) ℓ, ← zpow_mul, mul_comm k (ℓ : ℤ), zpow_mul, zpow_natCast]
+      refine Units.ext ?_
+      rw [Units.val_zpow_eq_zpow_val, Units.val_pow_eq_pow_val, h1, Units.val_one, one_zpow]
+    calc ((ζ ^ k : Kˣ) : K) ^ ℓ = (((ζ ^ k) ^ ℓ : Kˣ) : K) := by
+          rw [Units.val_pow_eq_pow_val]
+      _ = 1 := by rw [h2, Units.val_one]
+  rw [ModularCurve.W1.sum_pow_of_pow_eq_one hx1]
+  have hiff : ((ζ ^ k : Kˣ) : K) = 1 ↔ (ℓ : ℤ) ∣ k := by
+    rw [Units.val_zpow_eq_zpow_val]
+    exact hζ.zpow_eq_one_iff_dvd k
+  by_cases hd : (ℓ : ℤ) ∣ k
+  · rw [ite_eq_left hd, ite_eq_left (hiff.mpr hd)]
+  · rw [ite_eq_right hd, ite_eq_right (fun h => hd (hiff.mp h)), zero_mul]
+
+p2m_open_scoped "ModularCurve ModularCurve.PhiGen" in
+private theorem ModularCurve.PhiGen.coeff_sum_slots {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ)
+    [NeZero ℓ] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) ℓ) (f : LaurentSeries K) (n : ℤ) :
+    (qExpand K (ℓ * ℓ) f + ∑ b ∈ Finset.range ℓ, qTwist (ζ ^ b) f).coeff ((ℓ : ℤ) * n)
+      = (if (ℓ : ℤ) ∣ n then f.coeff (n / ℓ) else 0) + (ℓ : K) * f.coeff ((ℓ : ℤ) * n) := by
+  have hℓ0 : (ℓ : ℤ) ≠ 0 := Int.natCast_ne_zero.mpr (NeZero.ne ℓ)
+  rw [HahnSeries.coeff_add, sum_qTwist_coeff ℓ ζ hζ, ite_eq_left (Dvd.intro n rfl)]
+  congr 1
+  by_cases hd : (ℓ : ℤ) ∣ n
+  · obtain ⟨n', rfl⟩ := hd
+    rw [ite_eq_left (Dvd.intro n' rfl)]
+    have h1 : (ℓ : ℤ) * ((ℓ : ℤ) * n') = ((ℓ * ℓ : ℕ) : ℤ) * n' := by push_cast; ring
+    rw [h1, qExpand_coeff_mul, Int.mul_ediv_cancel_left n' hℓ0]
+  · rw [ite_eq_right hd]
+    refine qExpand_coeff_of_not_dvd (R := K) (N := ℓ * ℓ) f ?_
+    intro hcon
+    refine hd ?_
+    obtain ⟨c, hc⟩ := hcon
+    refine ⟨c, ?_⟩
+    have h2 : (ℓ : ℤ) * n = (ℓ : ℤ) * ((ℓ : ℤ) * c) := by
+      rw [hc]; push_cast; ring
+    exact mul_left_cancel₀ hℓ0 h2
+
+p2m_open_scoped "ModularCurve ModularCurve.PhiGen" in
+private theorem ModularCurve.PhiGen.coeff_sum_slots_not_dvd {K : Type*} [Field K] [Algebra ℚ K]
+    (ℓ : ℕ) [NeZero ℓ] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) ℓ) (f : LaurentSeries K)
+    {k : ℤ} (hk : ¬ (ℓ : ℤ) ∣ k) :
+    (qExpand K (ℓ * ℓ) f + ∑ b ∈ Finset.range ℓ, qTwist (ζ ^ b) f).coeff k = 0 := by
+  rw [HahnSeries.coeff_add, sum_qTwist_coeff ℓ ζ hζ, ite_eq_right hk]
+  rw [qExpand_coeff_of_not_dvd (R := K) (N := ℓ * ℓ) f (fun hcon => hk ?_), add_zero]
+  obtain ⟨c, hc⟩ := hcon
+  exact ⟨(ℓ : ℤ) * c, by rw [hc]; push_cast; ring⟩
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ evalAtJ_X \
+  ModularPolynomialData evalAtJGen algebraMap_comp_evalAtJGen ModularPolynomialData.toAdjoin \
+  modularFunctionFieldFull coeffEmb coeffEmb_coeff laurentBaseChange qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand heckeBetaBar coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot PhiGen.splits_of_prime minpoly_jqN_eq_toAdjoin exists_phiIrreducible \
+  aeval_jqN_toAdjoin"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.coeff_trace_heckeBeta (L : Type*) [Field L] [Algebra ℚ L] (N ℓ : ℕ)
+    [NeZero N] [NeZero ℓ] (ζ : Lˣ) (hζ : IsPrimitiveRoot (ζ : L) ℓ)
+    (hle : laurentBaseChange L (modularFunctionFieldFull N)
+      ≤ laurentBaseChange L (modularFunctionFieldFull (N * ℓ)))
+    (g : laurentBaseChange L (modularFunctionFieldFull N))
+    (htr : qExpand L ℓ
+        ((Algebra.trace (laurentBaseChange L (modularFunctionFieldFull N))
+            (IntermediateField.extendScalars hle)
+            ⟨(heckeBetaBar L N ℓ g : LaurentSeries L),
+              (IntermediateField.mem_extendScalars hle).mpr (heckeBetaBar L N ℓ g).2⟩
+          : LaurentSeries L))
+      = qExpand L (ℓ * ℓ) (g : LaurentSeries L)
+          + ∑ b ∈ Finset.range ℓ, qTwist (ζ ^ b) (g : LaurentSeries L)) (n : ℤ) :
+    ((Algebra.trace (laurentBaseChange L (modularFunctionFieldFull N))
+        (IntermediateField.extendScalars hle)
+        ⟨(heckeBetaBar L N ℓ g : LaurentSeries L),
+          (IntermediateField.mem_extendScalars hle).mpr (heckeBetaBar L N ℓ g).2⟩
+      : LaurentSeries L)).coeff n
+      = (if (ℓ : ℤ) ∣ n then (g : LaurentSeries L).coeff (n / ℓ) else 0)
+          + (ℓ : L) * (g : LaurentSeries L).coeff ((ℓ : ℤ) * n) := by
+  have h1 := congrArg (fun s : LaurentSeries L => s.coeff ((ℓ : ℤ) * n)) htr
+  beta_reduce at h1
+  rw [qExpand_coeff_mul, ModularCurve.PhiGen.coeff_sum_slots ℓ ζ hζ] at h1
+  exact h1
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.trace_jqN_prime {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ)
+    [hp : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) ℓ) :
+    coeffEmb K (qExpand ℚ ℓ ((Algebra.trace ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN ℓ⟯
+        (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN ℓ)) : LaurentSeries ℚ)))
+      = qExpand K (ℓ * ℓ) (coeffEmb K jq)
+          + ∑ b ∈ Finset.range ℓ, qTwist (ζ ^ b) (coeffEmb K jq) := by
+  have : NeZero ℓ := ⟨hp.out.ne_zero⟩
+  obtain ⟨data, hirr⟩ := ModularCurve.exists_phiIrreducible ℓ
+  have haev : Polynomial.aeval (jqN ℓ) data.toAdjoin = 0 := aeval_jqN_toAdjoin data
+  have hα : IsIntegral ℚ⟮jq⟯ (jqN ℓ) :=
+    ⟨data.toAdjoin, data.toAdjoin_monic, by rw [← Polynomial.aeval_def]; exact haev⟩
+  have : FiniteDimensional ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN ℓ⟯ :=
+    IntermediateField.adjoin.finiteDimensional hα
+  let : Algebra ℚ⟮jq⟯ (LaurentSeries K) :=
+    ((((coeffEmb K).comp (qExpand ℚ ℓ))).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ))).toAlgebra
+  set gen := IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN ℓ) with hgen
+  have hming : minpoly ℚ⟮jq⟯ gen = data.toAdjoin := by
+    rw [hgen, IntermediateField.minpoly_gen, minpoly_jqN_eq_toAdjoin data hirr]
+  have hmap : (minpoly ℚ⟮jq⟯ gen).map (algebraMap ℚ⟮jq⟯ (LaurentSeries K))
+      = phiProd ℓ (conj ℓ ζ) := by
+    rw [hming, ModularPolynomialData.toAdjoin, Polynomial.map_map]
+    have hcomp : (algebraMap ℚ⟮jq⟯ (LaurentSeries K)).comp evalAtJGen
+        = ((coeffEmb K).comp (qExpand ℚ ℓ)).comp evalAtJ := by
+      have h0 : algebraMap ℚ⟮jq⟯ (LaurentSeries K)
+          = (((coeffEmb K).comp (qExpand ℚ ℓ))).comp
+            (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) := rfl
+      rw [h0, RingHom.comp_assoc, algebraMap_comp_evalAtJGen]
+    rw [hcomp]
+    exact ModularCurve.PhiGen.splits_of_prime ℓ ζ hζ data
+  have hprod : phiProd ℓ (conj ℓ ζ)
+      = ((Finset.univ.val.map (conj ℓ ζ)).map
+          (fun r => Polynomial.X - Polynomial.C r)).prod := by
+    rw [phiProd, Finset.prod_eq_multiset_prod, Multiset.map_map]
+    rfl
+  have hroots : ((minpoly ℚ⟮jq⟯ gen).map
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries K))).roots = Finset.univ.val.map (conj ℓ ζ) := by
+    rw [hmap, hprod]
+    exact Polynomial.roots_multiset_prod_X_sub_C _
+  have hdegmap : ((minpoly ℚ⟮jq⟯ gen).map
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries K))).natDegree = ℓ + 1 := by
+    rw [hmap, hprod]
+    have hmon : ∀ f ∈ (Finset.univ.val.map (conj ℓ ζ)).map
+        (fun r => Polynomial.X - Polynomial.C r), f.Monic := by
+      intro f hf
+      obtain ⟨r, -, rfl⟩ := Multiset.mem_map.mp hf
+      exact Polynomial.monic_X_sub_C r
+    rw [Polynomial.natDegree_multiset_prod_of_monic _ hmon, Multiset.map_map]
+    have h1 : ((Finset.univ.val.map (conj ℓ ζ)).map
+        (Polynomial.natDegree ∘ fun r => Polynomial.X - Polynomial.C r))
+        = (Finset.univ.val.map (conj ℓ ζ)).map (fun _ => 1) :=
+      Multiset.map_congr rfl fun r _ => Polynomial.natDegree_X_sub_C r
+    rw [h1, Multiset.map_const', Multiset.sum_replicate, Multiset.card_map, smul_eq_mul,
+      mul_one]
+    simp
+  have hsp : ((minpoly ℚ⟮jq⟯ gen).map
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries K))).Splits := by
+    rw [Polynomial.splits_iff_card_roots, hroots, hdegmap, Multiset.card_map]
+    simp
+  have hgint : IsIntegral ℚ⟮jq⟯ gen := IsIntegral.of_finite ℚ⟮jq⟯ gen
+  have hfin1 : Module.finrank ℚ⟮jq⟯⟮gen⟯ ℚ⟮jq⟯⟮jqN ℓ⟯ = 1 := by
+    let : Module.Free ℚ⟮jq⟯ ℚ⟮jq⟯⟮gen⟯ := Module.Free.of_divisionRing _ _
+    let : Module.Free ℚ⟮jq⟯⟮gen⟯ ℚ⟮jq⟯⟮jqN ℓ⟯ := Module.Free.of_divisionRing _ _
+    have htow := Module.finrank_mul_finrank ℚ⟮jq⟯ ℚ⟮jq⟯⟮gen⟯ ℚ⟮jq⟯⟮jqN ℓ⟯
+    have ha : Module.finrank ℚ⟮jq⟯ ℚ⟮jq⟯⟮gen⟯ = (minpoly ℚ⟮jq⟯ gen).natDegree :=
+      IntermediateField.adjoin.finrank hgint
+    have hb : Module.finrank ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN ℓ⟯ = (minpoly ℚ⟮jq⟯ (jqN ℓ)).natDegree :=
+      IntermediateField.adjoin.finrank hα
+    have hc : (minpoly ℚ⟮jq⟯ gen).natDegree = (minpoly ℚ⟮jq⟯ (jqN ℓ)).natDegree := by
+      rw [hgen, IntermediateField.minpoly_gen]
+    have hpos : 0 < Module.finrank ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN ℓ⟯ := Module.finrank_pos
+    rw [ha, hc, ← hb] at htow
+    exact Nat.eq_of_mul_eq_mul_left hpos (by rw [htow, Nat.mul_one])
+  have htr := trace_eq_sum_roots (F := LaurentSeries K) (x := gen) hsp
+  rw [hfin1, one_smul, Polynomial.aroots_def, hroots] at htr
+  have hlhs : algebraMap ℚ⟮jq⟯ (LaurentSeries K) (Algebra.trace ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN ℓ⟯ gen)
+      = coeffEmb K (qExpand ℚ ℓ ((Algebra.trace ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN ℓ⟯ gen : ℚ⟮jq⟯)
+        : LaurentSeries ℚ)) := rfl
+  have hsum : (Finset.univ.val.map (conj ℓ ζ)).sum
+      = qExpand K (ℓ * ℓ) (coeffEmb K jq)
+        + ∑ b ∈ Finset.range ℓ, qTwist (ζ ^ b) (coeffEmb K jq) := by
+    have h1 : (Finset.univ.val.map (conj ℓ ζ)).sum = ∑ i : Fin (ℓ + 1), conj ℓ ζ i :=
+      (Finset.sum_eq_multiset_sum _ _).symm
+    rw [h1, Fin.sum_univ_succ]
+    congr 1
+    · have h2 : conj ℓ ζ 0 = ModularCurve.W1.TS K (ℓ * ℓ) 1 :=
+        ModularCurve.W1.conj_zero_eq ℓ ζ
+      have h3 : ModularCurve.W1.TS K (ℓ * ℓ) 1
+          = qExpand K (ℓ * ℓ) (qTwist 1 (coeffEmb K jq)) := TS_eq_coeffEmb _ _
+      rw [h2, h3, qTwist_one_apply]
+    · rw [← Fin.sum_univ_eq_sum_range (fun b => qTwist (ζ ^ b) (coeffEmb K jq)) ℓ]
+      refine Finset.sum_congr rfl fun b _ => ?_
+      have h4 : conj ℓ ζ b.succ = ModularCurve.W1.TS K 1 (ζ ^ (b : ℕ)) :=
+        ModularCurve.W1.conj_succ_eq ℓ ζ b
+      have h5 : ModularCurve.W1.TS K 1 (ζ ^ (b : ℕ))
+          = qExpand K 1 (qTwist (ζ ^ (b : ℕ)) (coeffEmb K jq)) := TS_eq_coeffEmb _ _
+      rw [h4, h5, qExpand_one_apply]
+  rw [hlhs] at htr
+  rw [htr, hsum]
+
+end
+
+p2m_open "ModularCurve~coeffEmb_qExpand\
+  " in
+open _root_.P2MW.S_ModularCurve_PhiGen_sum_qTwist_coeff.ModularCurve _root_.ModularCurve.PhiGen
+  _root_.P2MW.S_ModularCurve_PhiGen_sum_qTwist_coeff.ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) ℓ) (f : LaurentSeries K) (k : ℤ) :
+    (∑ b ∈ Finset.range ℓ, qTwist (ζ ^ b) f).coeff k = if (ℓ : ℤ) ∣ k then (ℓ : K) * f.coeff k else
+      0 :=
+  ModularCurve.PhiGen.sum_qTwist_coeff ℓ ζ hζ f k
+
+end S_ModularCurve_PhiGen_sum_qTwist_coeff
+end P2MW
+export P2MW.S_ModularCurve_PhiGen_sum_qTwist_coeff (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.PhiGen.sum_qTwist_coeff {K : Type*} [Field K] [Algebra ℚ K] (ℓ : ℕ) (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) ℓ) (f : LaurentSeries K) (k : ℤ) :
+    (∑ b ∈ Finset.range ℓ, qTwist (ζ ^ b) f).coeff k = if (ℓ : ℤ) ∣ k then (ℓ : K) * f.coeff k else
+      0 :=
+  solution ℓ ζ hζ f k
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_closure.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_closure.lean
new file mode 100644
index 0000000000..acd71c0b73
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_closure.lean
@@ -0,0 +1,386 @@
+/-
+Based on Prove2Me node ModularCurve.StarBank.closure
+(506259df-1746-5601-8078-8d4459e1363c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e6072c74-7a2a-585a-8414-029d17d75a09
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import Mathlib.FieldTheory.IsAlgClosed.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Divisibility G∘ R ∣ c Gᵖ⁺¹ from q-expansion identities
+
+Theorem statement: `ModularCurve.StarBank.closure` (`506259df-1746-5601-8078-8d4459e1363c`), by
+Claude, 2026-09-05.
+
+Proof: submission `e6072c74-7a2a-585a-8414-029d17d75a09`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field, $p$ a prime, $\zeta$ a unit of $K$, $M$ a natural number
+and $G, R \in K[X]$. Write $j = q^{-1}\cdot\mathrm{jNum}$ for the Laurent series `jqModC K`, the
+image in $K((q))$ of the integral power series $E_4^3\cdot\mathrm{dedekindEtaUnitInv}$ shifted by
+$q^{-1}$, and $\Delta = q\prod_{n\ge 1}(1-q^n)^{24}$ for the Laurent series `HahnSeries.single 1 1 *
+ofPowerSeries (etaProd)^24` over $K$; for a unit $u$ let $f(uq)$ denote `qTwist u f`, the ring
+endomorphism multiplying the coefficient of $q^k$ by $u^k$, and let $f(q^N)$ denote `qExpand K N f`,
+the ring endomorphism multiplying all exponents by $N$ (so $j(q^p)$ is `jqNModC K p`). Four
+identities in $K((q))$, respectively in $K((q))[X]$, are assumed: $G(j)\,\Delta^M = 1$; $R(j) =
+j(q^p)$; the coefficientwise image of $R$ in $K((q))[X]$ minus the constant $j(q^p)$ equals
+$\prod_{b=0}^{p-1}\bigl(X - j(\zeta^b q)\bigr)$; and the norm identity
+$\bigl(\prod_{b=0}^{p-1}\Delta(\zeta^b q)\bigr)\cdot\Delta(q^{p^2}) =
+\bigl(\prod_{b=0}^{p-1}\zeta^b\bigr)\cdot\Delta(q^p)^{p+1}$. The conclusion is that there exists $c
+\in K$, $c \neq 0$, such that $G(R(X))$ divides $c\,G(X)^{p+1}$ in $K[X]$.
+
+The third hypothesis exhibits $R$ as the monic degree-$p$ polynomial whose roots are the $q$-twisted
+expansions $j(\zeta^b q)$, and the fourth is the norm identity for the discriminant function along
+the same twists; the conclusion expresses that the root set of $G$ is stable under passing from
+$\beta$ to the roots of $R(X) - R(\beta)$, in the strong form of a divisibility in $K[X]$. It is the
+closure step used by [`ModularCurve.StarBank.starBank`](thm.html#ModularCurve.StarBank.starBank) in
+the formal $q$-expansion treatment of the modular equation relating $j(q)$ and $j(q^p)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_StarBank_closure.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_StarBank_closure
+
+noncomputable section
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_StarBank_closure.ModularCurve"
+
+local notation "𝓓[" K "]" =>
+  (HahnSeries.single (1 : ℤ) (1 : K) *
+    HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24)
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qTwist qTwist_single qExpand qExpand_C qExpand_injective \
+  qExpand_qExpand etaProd jNum constantCoeff_jNum ofPowerSeries_coeff_of_neg jqModC jqNModC"
+namespace W1
+p2m_open "ModularCurve"
+
+section Kit
+
+variable (K : Type*) [Field K]
+
+theorem jqModC_pow (n : ℕ) :
+    jqModC K ^ n = HahnSeries.single (-(n : ℤ)) (1 : K) *
+      HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) jNum ^ n) := by
+  have h : n • (-1 : ℤ) = -(n : ℤ) := by simp
+  rw [jqModC, mul_pow, HahnSeries.single_pow, one_pow, h, ← map_pow]
+
+theorem coeff_jqModC_pow_self (n : ℕ) : (jqModC K ^ n).coeff (-(n : ℤ)) = 1 := by
+  rw [jqModC_pow, HahnSeries.coeff_single_mul, one_mul, sub_neg_eq_add, neg_add_cancel,
+    show (0 : ℤ) = ((0 : ℕ) : ℤ) from rfl, HahnSeries.ofPowerSeries_apply_coeff,
+    PowerSeries.coeff_zero_eq_constantCoeff, map_pow, ←
+    PowerSeries.coeff_zero_eq_constantCoeff_apply,
+    PowerSeries.coeff_map, PowerSeries.coeff_zero_eq_constantCoeff_apply, constantCoeff_jNum,
+    map_one, one_pow]
+
+theorem coeff_jqModC_pow_of_lt {n : ℕ} {m : ℤ} (hm : m < -(n : ℤ)) :
+    (jqModC K ^ n).coeff m = 0 := by
+  rw [jqModC_pow, HahnSeries.coeff_single_mul, one_mul]
+  exact ofPowerSeries_coeff_of_neg _ (by omega)
+
+theorem algebraMap_eq_C (c : K) : algebraMap K (LaurentSeries K) c = HahnSeries.C c := by
+  have h1 : algebraMap K (PowerSeries K) c = PowerSeries.C c := by simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+
+theorem aeval_jqModC_eq_sum (P : Polynomial K) :
+    Polynomial.aeval (jqModC K) P =
+      ∑ i ∈ Finset.range (P.natDegree + 1),
+        algebraMap K (LaurentSeries K) (P.coeff i) * jqModC K ^ i := by
+  conv_lhs => rw [P.as_sum_range_C_mul_X_pow]
+  rw [map_sum]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [map_mul, Polynomial.aeval_C, map_pow, Polynomial.aeval_X]
+
+theorem coeff_aeval_jqModC (P : Polynomial K) (m : ℤ) :
+    (Polynomial.aeval (jqModC K) P).coeff m =
+      ∑ i ∈ Finset.range (P.natDegree + 1), P.coeff i * (jqModC K ^ i).coeff m := by
+  rw [aeval_jqModC_eq_sum, HahnSeries.coeff_sum]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [algebraMap_eq_C, HahnSeries.C_apply, HahnSeries.coeff_single_zero_mul]
+
+theorem coeff_aeval_jqModC_neg_natDegree (P : Polynomial K) :
+    (Polynomial.aeval (jqModC K) P).coeff (-(P.natDegree : ℤ)) = P.leadingCoeff := by
+  rw [coeff_aeval_jqModC, Finset.sum_range_succ, coeff_jqModC_pow_self, mul_one,
+    Finset.sum_eq_zero fun i hi => ?_, zero_add, Polynomial.leadingCoeff]
+  rw [coeff_jqModC_pow_of_lt K (by have := Finset.mem_range.1 hi; omega), mul_zero]
+
+theorem aeval_jqModC_injective :
+    Function.Injective (Polynomial.aeval (jqModC K) : Polynomial K → LaurentSeries K) := by
+  intro P Q h
+  by_contra hne
+  have h0 : Polynomial.aeval (jqModC K) (P - Q) = 0 := by rw [map_sub, h, sub_self]
+  have hlc := coeff_aeval_jqModC_neg_natDegree K (P - Q)
+  rw [h0, HahnSeries.coeff_zero] at hlc
+  exact hne (sub_eq_zero.1 (Polynomial.leadingCoeff_eq_zero.1 hlc.symm))
+
+theorem qTwist_C (u : Kˣ) (c : K) : qTwist u (HahnSeries.C c) = HahnSeries.C c := by
+  rw [HahnSeries.C_apply, qTwist_single, zpow_zero, Units.val_one, one_mul]
+
+theorem qTwist_aeval (u : Kˣ) (x : LaurentSeries K) (P : Polynomial K) :
+    qTwist u (Polynomial.aeval x P) = Polynomial.aeval (qTwist u x) P := by
+  rw [Polynomial.aeval_def, Polynomial.aeval_def, Polynomial.hom_eval₂]
+  congr 1
+  exact RingHom.ext fun c => by rw [RingHom.comp_apply, algebraMap_eq_C, qTwist_C]
+
+theorem qExpand_aeval (N : ℕ) [NeZero N] (x : LaurentSeries K) (P : Polynomial K) :
+    qExpand K N (Polynomial.aeval x P) = Polynomial.aeval (qExpand K N x) P := by
+  rw [Polynomial.aeval_def, Polynomial.aeval_def, Polynomial.hom_eval₂]
+  congr 1
+  exact RingHom.ext fun c => by rw [RingHom.comp_apply, algebraMap_eq_C, qExpand_C]
+
+theorem prod_map_sub_comm (s : Multiset K) (x : LaurentSeries K) :
+    (s.map fun α => x - algebraMap K (LaurentSeries K) α).prod =
+      (-1) ^ Multiset.card s * (s.map fun α => algebraMap K (LaurentSeries K) α - x).prod := by
+  induction s using Multiset.induction_on with
+  | empty => simp
+  | cons a s ih =>
+    rw [Multiset.map_cons, Multiset.prod_cons, Multiset.map_cons, Multiset.prod_cons, ih,
+      Multiset.card_cons, pow_succ]
+    ring
+
+variable [IsAlgClosed K]
+
+theorem aeval_eq_prod_roots (G : Polynomial K) (x : LaurentSeries K) :
+    Polynomial.aeval x G =
+      algebraMap K (LaurentSeries K) G.leadingCoeff * (-1) ^ Multiset.card G.roots *
+        (G.roots.map fun α => algebraMap K (LaurentSeries K) α - x).prod := by
+  conv_lhs => rw [(IsAlgClosed.splits G).eq_prod_roots]
+  rw [map_mul, Polynomial.aeval_C, map_multiset_prod, Multiset.map_map, mul_assoc,
+    ← prod_map_sub_comm]
+  congr 2
+  exact Multiset.map_congr rfl fun α _ => by
+    simp only [Function.comp_apply, map_sub, Polynomial.aeval_X, Polynomial.aeval_C]
+
+end Kit
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qTwist qTwist_single qExpand qExpand_C qExpand_injective \
+  qExpand_qExpand etaProd jNum constantCoeff_jNum ofPowerSeries_coeff_of_neg jqModC jqNModC"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.StarBank.closure {K : Type*} [Field K] [IsAlgClosed K] (p : ℕ)
+    [Fact p.Prime]
+    (ζ : Kˣ) {M : ℕ} {G R : Polynomial K}
+    (hstar : Polynomial.aeval (jqModC K) G *
+        (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^ M = 1)
+    (hR : Polynomial.aeval (jqModC K) R = jqNModC K p)
+    (hpress : R.map (algebraMap K (LaurentSeries K)) - Polynomial.C (jqNModC K p) =
+        ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (qTwist (ζ ^ b) (jqModC K))))
+    (hnorm : (∏ b ∈ Finset.range p, qTwist (ζ ^ b)
+        (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24)) *
+      qExpand K (p * p) (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) =
+    HahnSeries.C (((∏ b ∈ Finset.range p, ζ ^ b : Kˣ) : K)) *
+      qExpand K p (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^
+        (p + 1)) :
+    ∃ c : K, c ≠ 0 ∧ G.comp R ∣ Polynomial.C c * G ^ (p + 1) := by
+  have hjp : jqNModC K p = qExpand K p (jqModC K) := rfl
+  have F2 : ∀ α : K, algebraMap K (LaurentSeries K) (R.eval α) - jqNModC K p =
+      ∏ b ∈ Finset.range p, (algebraMap K (LaurentSeries K) α - qTwist (ζ ^ b) (jqModC K)) := by
+    intro α
+    have h := congrArg (Polynomial.eval (algebraMap K (LaurentSeries K) α)) hpress
+    rw [Polynomial.eval_sub, Polynomial.eval_C, Polynomial.eval_map, Polynomial.eval₂_at_apply,
+      Polynomial.eval_prod] at h
+    simpa only [Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C] using h
+  have F3 : Polynomial.aeval (jqNModC K p)
+      ((G.roots.map fun α => Polynomial.C (R.eval α) - Polynomial.X).prod) =
+      ∏ b ∈ Finset.range p, (G.roots.map fun α =>
+        algebraMap K (LaurentSeries K) α - qTwist (ζ ^ b) (jqModC K)).prod := by
+    rw [map_multiset_prod, Multiset.map_map]
+    have h1 : (G.roots.map ((Polynomial.aeval (jqNModC K p)) ∘ fun α =>
+        Polynomial.C (R.eval α) - Polynomial.X)) =
+        G.roots.map fun α => ∏ b ∈ Finset.range p,
+          (algebraMap K (LaurentSeries K) α - qTwist (ζ ^ b) (jqModC K)) := by
+      refine Multiset.map_congr rfl fun α _ => ?_
+      rw [Function.comp_apply, map_sub, Polynomial.aeval_C, Polynomial.aeval_X]
+      exact F2 α
+    rw [h1]
+    simp only [Finset.prod_eq_multiset_prod]
+    exact Multiset.prod_map_prod_map _ _
+  have F4 : ∏ b ∈ Finset.range p, Polynomial.aeval (qTwist (ζ ^ b) (jqModC K)) G =
+      (algebraMap K (LaurentSeries K) G.leadingCoeff * (-1) ^ Multiset.card G.roots) ^ p *
+        Polynomial.aeval (jqNModC K p)
+          ((G.roots.map fun α => Polynomial.C (R.eval α) - Polynomial.X).prod) := by
+    rw [F3, Finset.prod_congr rfl fun b _ => aeval_eq_prod_roots K G (qTwist (ζ ^ b) (jqModC K)),
+      Finset.prod_mul_distrib, Finset.prod_const, Finset.card_range]
+  have F5 : (∏ b ∈ Finset.range p, Polynomial.aeval (qTwist (ζ ^ b) (jqModC K)) G) *
+      (∏ b ∈ Finset.range p, qTwist (ζ ^ b) 𝓓[K]) ^ M = 1 := by
+    rw [← Finset.prod_pow, ← Finset.prod_mul_distrib]
+    refine Finset.prod_eq_one fun b _ => ?_
+    have h := congrArg (qTwist (ζ ^ b)) hstar
+    rwa [map_mul, map_pow, (qTwist (ζ ^ b)).map_one, qTwist_aeval] at h
+  have F6 : Polynomial.aeval (jqNModC K p) G * qExpand K p 𝓓[K] ^ M = 1 := by
+    have h := congrArg (qExpand K p) hstar
+    rwa [map_mul, map_pow, (qExpand K p).map_one, qExpand_aeval] at h
+  have F7 : Polynomial.aeval (qExpand K (p * p) (jqModC K)) G * qExpand K (p * p) 𝓓[K] ^ M = 1 := by
+    have h := congrArg (qExpand K (p * p)) hstar
+    rwa [map_mul, map_pow, (qExpand K (p * p)).map_one, qExpand_aeval] at h
+  have F54 : (algebraMap K (LaurentSeries K) G.leadingCoeff * (-1) ^ Multiset.card G.roots) ^ p *
+      Polynomial.aeval (jqNModC K p)
+        ((G.roots.map fun α => Polynomial.C (R.eval α) - Polynomial.X).prod) *
+      (∏ b ∈ Finset.range p, qTwist (ζ ^ b) 𝓓[K]) ^ M = 1 := by
+    rw [← F4]; exact F5
+  have key : Polynomial.aeval (jqNModC K p) G ^ (p + 1) =
+      (algebraMap K (LaurentSeries K) G.leadingCoeff * (-1) ^ Multiset.card G.roots) ^ p *
+        HahnSeries.C (((∏ b ∈ Finset.range p, ζ ^ b : Kˣ) : K)) ^ M *
+        Polynomial.aeval (jqNModC K p)
+          ((G.roots.map fun α => Polynomial.C (R.eval α) - Polynomial.X).prod) *
+        Polynomial.aeval (qExpand K (p * p) (jqModC K)) G := by
+    calc Polynomial.aeval (jqNModC K p) G ^ (p + 1)
+        = Polynomial.aeval (jqNModC K p) G ^ (p + 1) *
+            (Polynomial.aeval (qExpand K (p * p) (jqModC K)) G * qExpand K (p * p) 𝓓[K] ^ M) *
+            ((algebraMap K (LaurentSeries K) G.leadingCoeff * (-1) ^ Multiset.card G.roots) ^ p *
+              Polynomial.aeval (jqNModC K p)
+                ((G.roots.map fun α => Polynomial.C (R.eval α) - Polynomial.X).prod) *
+              (∏ b ∈ Finset.range p, qTwist (ζ ^ b) 𝓓[K]) ^ M) := by
+          rw [F7, F54, mul_one, mul_one]
+      _ = (algebraMap K (LaurentSeries K) G.leadingCoeff * (-1) ^ Multiset.card G.roots) ^ p *
+            Polynomial.aeval (jqNModC K p)
+              ((G.roots.map fun α => Polynomial.C (R.eval α) - Polynomial.X).prod) *
+            Polynomial.aeval (qExpand K (p * p) (jqModC K)) G *
+            Polynomial.aeval (jqNModC K p) G ^ (p + 1) *
+            ((∏ b ∈ Finset.range p, qTwist (ζ ^ b) 𝓓[K]) * qExpand K (p * p) 𝓓[K]) ^ M := by
+          ring
+      _ = (algebraMap K (LaurentSeries K) G.leadingCoeff * (-1) ^ Multiset.card G.roots) ^ p *
+            Polynomial.aeval (jqNModC K p)
+              ((G.roots.map fun α => Polynomial.C (R.eval α) - Polynomial.X).prod) *
+            Polynomial.aeval (qExpand K (p * p) (jqModC K)) G *
+            Polynomial.aeval (jqNModC K p) G ^ (p + 1) *
+            (HahnSeries.C (((∏ b ∈ Finset.range p, ζ ^ b : Kˣ) : K)) *
+              qExpand K p 𝓓[K] ^ (p + 1)) ^ M := by
+          rw [hnorm]
+      _ = (algebraMap K (LaurentSeries K) G.leadingCoeff * (-1) ^ Multiset.card G.roots) ^ p *
+            HahnSeries.C (((∏ b ∈ Finset.range p, ζ ^ b : Kˣ) : K)) ^ M *
+            Polynomial.aeval (jqNModC K p)
+              ((G.roots.map fun α => Polynomial.C (R.eval α) - Polynomial.X).prod) *
+            Polynomial.aeval (qExpand K (p * p) (jqModC K)) G *
+            (Polynomial.aeval (jqNModC K p) G * qExpand K p 𝓓[K] ^ M) ^ (p + 1) := by
+          ring
+      _ = (algebraMap K (LaurentSeries K) G.leadingCoeff * (-1) ^ Multiset.card G.roots) ^ p *
+            HahnSeries.C (((∏ b ∈ Finset.range p, ζ ^ b : Kˣ) : K)) ^ M *
+            Polynomial.aeval (jqNModC K p)
+              ((G.roots.map fun α => Polynomial.C (R.eval α) - Polynomial.X).prod) *
+            Polynomial.aeval (qExpand K (p * p) (jqModC K)) G := by
+          rw [F6, one_pow, mul_one]
+  have hκL : algebraMap K (LaurentSeries K)
+      ((G.leadingCoeff * (-1) ^ Multiset.card G.roots) ^ p *
+        (((∏ b ∈ Finset.range p, ζ ^ b : Kˣ) : K)) ^ M) =
+      (algebraMap K (LaurentSeries K) G.leadingCoeff * (-1) ^ Multiset.card G.roots) ^ p *
+        HahnSeries.C (((∏ b ∈ Finset.range p, ζ ^ b : Kˣ) : K)) ^ M := by
+    rw [map_mul, map_pow, map_pow, map_mul, map_pow, map_neg, map_one,
+      algebraMap_eq_C K (((∏ b ∈ Finset.range p, ζ ^ b : Kˣ) : K))]
+  have hP1 : qExpand K p (Polynomial.aeval (jqModC K) (G ^ (p + 1))) =
+      Polynomial.aeval (jqNModC K p) G ^ (p + 1) := by
+    rw [map_pow, map_pow, qExpand_aeval, ← hjp]
+  have hP2 : qExpand K p (Polynomial.aeval (jqModC K)
+      (Polynomial.C ((G.leadingCoeff * (-1) ^ Multiset.card G.roots) ^ p *
+          (((∏ b ∈ Finset.range p, ζ ^ b : Kˣ) : K)) ^ M) *
+        (G.roots.map fun α => Polynomial.C (R.eval α) - Polynomial.X).prod * G.comp R)) =
+      (algebraMap K (LaurentSeries K) G.leadingCoeff * (-1) ^ Multiset.card G.roots) ^ p *
+        HahnSeries.C (((∏ b ∈ Finset.range p, ζ ^ b : Kˣ) : K)) ^ M *
+        Polynomial.aeval (jqNModC K p)
+          ((G.roots.map fun α => Polynomial.C (R.eval α) - Polynomial.X).prod) *
+        Polynomial.aeval (qExpand K (p * p) (jqModC K)) G := by
+    rw [map_mul, map_mul, map_mul, map_mul, Polynomial.aeval_C, Polynomial.aeval_comp, hR, hjp, ←
+      qExpand_aeval, qExpand_qExpand,
+      algebraMap_eq_C, qExpand_C, ← algebraMap_eq_C, hκL, qExpand_aeval, qExpand_aeval]
+  have hpoly : G ^ (p + 1) =
+      Polynomial.C ((G.leadingCoeff * (-1) ^ Multiset.card G.roots) ^ p *
+          (((∏ b ∈ Finset.range p, ζ ^ b : Kˣ) : K)) ^ M) *
+        (G.roots.map fun α => Polynomial.C (R.eval α) - Polynomial.X).prod * G.comp R :=
+    aeval_jqModC_injective K (qExpand_injective (R := K) (N := p) (hP1.trans (key.trans hP2.symm)))
+  exact ⟨1, one_ne_zero, Polynomial.C ((G.leadingCoeff * (-1) ^ Multiset.card G.roots) ^ p *
+      (((∏ b ∈ Finset.range p, ζ ^ b : Kˣ) : K)) ^ M) *
+    (G.roots.map fun α => Polynomial.C (R.eval α) - Polynomial.X).prod,
+    by rw [map_one, one_mul, hpoly]; ring⟩
+
+example (c : ℚ) (hc : c ≠ 0) :
+    ¬ ((Polynomial.X : Polynomial ℚ).comp (Polynomial.X + 1) ∣
+        Polynomial.C c * Polynomial.X ^ (2 + 1)) := by
+  intro h
+  have h0 : ((Polynomial.X : Polynomial ℚ).comp (Polynomial.X + 1)).eval (-1) = 0 := by simp
+  have h1 := Polynomial.eval_eq_zero_of_dvd_of_eval_eq_zero h h0
+  simp only [Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_pow, Polynomial.eval_X] at h1
+  norm_num at h1
+  exact hc h1
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_StarBank_closure.ModularCurve in
+theorem solution {K : Type*} [Field K] [IsAlgClosed K] (p : ℕ) [Fact p.Prime]
+    (ζ : Kˣ) {M : ℕ} {G R : Polynomial K}
+    (hstar : Polynomial.aeval (jqModC K) G *
+        (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^ M = 1)
+    (hR : Polynomial.aeval (jqModC K) R = jqNModC K p)
+    (hpress : R.map (algebraMap K (LaurentSeries K)) - Polynomial.C (jqNModC K p) =
+        ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (qTwist (ζ ^ b) (jqModC K))))
+    (hnorm : (∏ b ∈ Finset.range p, qTwist (ζ ^ b)
+        (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24)) *
+      qExpand K (p * p) (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) =
+    HahnSeries.C (((∏ b ∈ Finset.range p, ζ ^ b : Kˣ) : K)) *
+      qExpand K p (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^
+        (p + 1)) :
+    ∃ c : K, c ≠ 0 ∧ G.comp R ∣ Polynomial.C c * G ^ (p + 1) :=
+  ModularCurve.StarBank.closure p ζ hstar hR hpress hnorm
+
+end S_ModularCurve_StarBank_closure
+end P2MW
+export P2MW.S_ModularCurve_StarBank_closure (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.StarBank.closure {K : Type*} [Field K] [IsAlgClosed K] (p : ℕ) [Fact p.Prime]
+    (ζ : Kˣ) {M : ℕ} {G R : Polynomial K}
+    (hstar : Polynomial.aeval (jqModC K) G *
+        (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^ M = 1)
+    (hR : Polynomial.aeval (jqModC K) R = jqNModC K p)
+    (hpress : R.map (algebraMap K (LaurentSeries K)) - Polynomial.C (jqNModC K p) =
+        ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (qTwist (ζ ^ b) (jqModC K))))
+    (hnorm : (∏ b ∈ Finset.range p, qTwist (ζ ^ b)
+        (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24)) *
+      qExpand K (p * p) (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) =
+    HahnSeries.C (((∏ b ∈ Finset.range p, ζ ^ b : Kˣ) : K)) *
+      qExpand K p (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^
+        (p + 1)) :
+    ∃ c : K, c ≠ 0 ∧ G.comp R ∣ Polynomial.C c * G ^ (p + 1) :=
+  solution p ζ hstar hR hpress hnorm
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_count.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_count.lean
new file mode 100644
index 0000000000..1ce324837f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_count.lean
@@ -0,0 +1,252 @@
+/-
+Based on Prove2Me node ModularCurve.StarBank.count
+(ae69b4a6-0fc7-551f-af80-2e78508efb87) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a70999c6-2825-59be-8cd3-99a201d54ecf
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+
+import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure
+import Mathlib.Algebra.Field.ZMod
+import Mathlib.Data.ZMod.Basic
+import Mathlib.Data.Nat.Prime.Basic
+import Mathlib.Algebra.Order.BigOperators.Group.Finset
+import Mathlib.Algebra.Polynomial.Roots
+import Mathlib.Algebra.Polynomial.Splits
+import Mathlib.Algebra.Polynomial.Coeff
+import Mathlib.Algebra.Polynomial.Monic
+import Mathlib.Algebra.Polynomial.Degree.Lemmas
+import Mathlib.Data.Nat.Choose.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Rigidity for G∘ R ∣ c Gᵖ⁺¹ with R monic of degree p
+
+Theorem statement: `ModularCurve.StarBank.count` (`ae69b4a6-0fc7-551f-af80-2e78508efb87`), by
+Claude, 2026-09-05.
+
+Proof: submission `a70999c6-2825-59be-8cd3-99a201d54ecf`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field and let $p$ be a natural number with $2 \le p$ whose image
+in $K$ is nonzero (so $\operatorname{char} K \nmid p$; $p$ is not assumed prime). Let $R, G \in
+K[X]$, with $R$ monic of degree exactly $p$ (`natDegree` $= p$) and $G$ of positive degree, and let
+$c \in K$ be nonzero. Assume that the composite $G(R(X))$ divides $c \cdot G(X)^{p+1}$ in $K[X]$.
+Then there is a $\beta_0 \in K$ such that, first, every root $\beta$ of $G$ in $K$ equals $\beta_0$
+— that is, $G$ has a single root, necessarily $\beta_0$, so $G$ is a nonzero scalar times
+$(X-\beta_0)^{\deg G}$ — and, second, $R$ is given exactly by $$R = (X - \beta_0)^p + \beta_0 .$$
+The conclusion is an existence statement: the same $\beta_0$ serves both for the root of $G$ and for
+the normal form of $R$. No hypothesis of separability or of coprimality between $R$ and $G$ is
+imposed, and the divisibility is required only up to the nonzero constant $c$.
+
+A purely polynomial rigidity statement: divisibility of $c\,G^{p+1}$ by $G\circ R$ forces
+$R(X)-R(\beta) = (X-\beta)^p$ at each root $\beta$ of $G$, and comparison of the coefficients of
+$X^{p-1}$ (which equals $-p\beta$, whence the need for $p$ invertible and $p \ge 2$) shows that two
+distinct roots cannot coexist. It is used by
+[`ModularCurve.StarBank.starBank`](thm.html#ModularCurve.StarBank.starBank) in the analysis of
+correspondences between the $j$-invariant and its Hecke translates, where the hypothesis on $p$ in
+$K$ excludes the characteristic-$p$ phenomenon $R = X^p$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_StarBank_count.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_StarBank_count
+
+open Polynomial
+
+namespace ModularCurve.StarBank
+
+private theorem _root_.ModularCurve.StarBank.count' {K : Type*} [Field K] [IsAlgClosed K] {p : ℕ}
+    (hp0 : (p : K) ≠ 0) (hp2 : 2 ≤ p) {R G : Polynomial K} (hR : R.Monic)
+    (hRdeg : R.natDegree = p) (hG : 0 < G.natDegree) {c : K} (hc : c ≠ 0)
+    (hdvd : G.comp R ∣ Polynomial.C c * G ^ (p + 1)) :
+    ∃ β₀ : K, (∀ β : K, G.IsRoot β → β = β₀) ∧
+      R = (Polynomial.X - Polynomial.C β₀) ^ p + Polynomial.C β₀ := by
+  classical
+  have hG0 : G ≠ 0 := fun h => by simp [h] at hG
+  have hclosure : ∀ γ : K, G.IsRoot (R.eval γ) → G.IsRoot γ := by
+    intro γ hγ
+    obtain ⟨H, hH⟩ := hdvd
+    have he := congrArg (eval γ) hH
+    simp only [eval_mul, eval_C, eval_pow, eval_comp] at he
+    rw [show G.eval (R.eval γ) = 0 from hγ, zero_mul] at he
+    rcases mul_eq_zero.mp he with h | h
+    · exact absurd h hc
+    · exact (pow_eq_zero_iff (by omega : p + 1 ≠ 0)).mp h
+  set S : Finset K := G.roots.toFinset with hS
+  have hmemS : ∀ {β : K}, β ∈ S ↔ G.IsRoot β := by
+    intro β
+    rw [hS, Multiset.mem_toFinset, mem_roots']
+    exact ⟨fun h => h.2, fun h => ⟨hG0, h⟩⟩
+  have hmonic : ∀ b : K, (R - C b).Monic := fun b =>
+    hR.sub_of_left (lt_of_le_of_lt degree_C_le
+      (natDegree_pos_iff_degree_pos.mp (by omega)))
+  have hdegS : ∀ b : K, (R - C b).natDegree = p := fun b => by
+    rw [natDegree_sub_C, hRdeg]
+  have hcard : ∀ b : K, (R - C b).roots.card = p := fun b =>
+    (splits_iff_card_roots.mp (IsAlgClosed.splits _)).trans (hdegS b)
+  have hsub : ∀ b ∈ S, (R - C b).roots.toFinset ⊆ S := by
+    intro b hb γ hγ
+    rw [Multiset.mem_toFinset, mem_roots'] at hγ
+    have hev : R.eval γ = b := by
+      have h := hγ.2
+      rw [IsRoot, eval_sub, eval_C, sub_eq_zero] at h
+      exact h
+    exact hmemS.mpr (hclosure γ (by rw [hev]; exact hmemS.mp hb))
+  have hinner : ∀ b ∈ S, (∑ γ ∈ S, (R - C b).roots.count γ) = p := by
+    intro b hb
+    rw [← Finset.sum_subset (hsub b hb) (fun γ _ hγ =>
+      Multiset.count_eq_zero.mpr fun hmem => hγ (Multiset.mem_toFinset.mpr hmem))]
+    rw [Multiset.toFinset_sum_count_eq]
+    exact hcard b
+  set M : Multiset K := ∑ b ∈ S, (R - C b).roots with hM
+  have hterm0 : ∀ γ b : K, b ∈ S → b ≠ R.eval γ → (R - C b).roots.count γ = 0 := by
+    intro γ b _ hbne
+    rw [Multiset.count_eq_zero]
+    intro hmem
+    rw [mem_roots'] at hmem
+    have h := hmem.2
+    rw [IsRoot, eval_sub, eval_C, sub_eq_zero] at h
+    exact hbne h.symm
+  have hMcount : ∀ γ : K, R.eval γ ∈ S → M.count γ = (R - C (R.eval γ)).roots.count γ := by
+    intro γ hin
+    rw [hM, Multiset.count_sum']
+    exact Finset.sum_eq_single_of_mem _ hin fun b hb hbne => hterm0 γ b hb hbne
+  have hMcount0 : ∀ γ : K, R.eval γ ∉ S → M.count γ = 0 := by
+    intro γ hnot
+    rw [hM, Multiset.count_sum']
+    exact Finset.sum_eq_zero fun b hb => hterm0 γ b hb fun h => hnot (h ▸ hb)
+  have hMle : ∀ γ ∈ S, M.count γ ≤ p := by
+    intro γ _
+    by_cases hin : R.eval γ ∈ S
+    · rw [hMcount γ hin]
+      exact (Multiset.count_le_card _ _).trans (hcard _).le
+    · rw [hMcount0 γ hin]
+      exact Nat.zero_le p
+  have hMsum : (∑ γ ∈ S, M.count γ) = ∑ γ ∈ S, p :=
+    calc (∑ γ ∈ S, M.count γ)
+        = ∑ γ ∈ S, ∑ b ∈ S, (R - C b).roots.count γ :=
+          Finset.sum_congr rfl fun γ _ => by rw [hM, Multiset.count_sum']
+      _ = ∑ b ∈ S, ∑ γ ∈ S, (R - C b).roots.count γ := Finset.sum_comm
+      _ = ∑ b ∈ S, p := Finset.sum_congr rfl hinner
+  have hMeq : ∀ γ ∈ S, M.count γ = p := (Finset.sum_eq_sum_iff_of_le hMle).mp hMsum
+  have hfact : ∀ γ ∈ S, R.eval γ ∈ S ∧ R - C (R.eval γ) = (X - C γ) ^ p := by
+    intro γ hγ
+    have hin : R.eval γ ∈ S := by
+      by_contra hnot
+      have h0 := hMcount0 γ hnot
+      rw [hMeq γ hγ] at h0
+      omega
+    refine ⟨hin, ?_⟩
+    have hcnt : (R - C (R.eval γ)).roots.count γ = p := by
+      rw [← hMcount γ hin]
+      exact hMeq γ hγ
+    have hall : ∀ b ∈ (R - C (R.eval γ)).roots, b = γ := by
+      have hcc : (R - C (R.eval γ)).roots.count γ = (R - C (R.eval γ)).roots.card :=
+        hcnt.trans (hcard _).symm
+      exact fun b hb => (Multiset.count_eq_card.mp hcc b hb).symm
+    have hrep : (R - C (R.eval γ)).roots = Multiset.replicate p γ := by
+      have h1 := Multiset.eq_replicate_card.mpr hall
+      rwa [hcard] at h1
+    have h2 := (IsAlgClosed.splits (R - C (R.eval γ))).eq_prod_roots_of_monic (hmonic _)
+    rw [hrep, Multiset.map_replicate, Multiset.prod_replicate] at h2
+    exact h2
+  obtain ⟨β₀, hβ₀⟩ := IsAlgClosed.exists_root G (natDegree_pos_iff_degree_pos.mp hG).ne'
+  have hβ₀S : β₀ ∈ S := hmemS.mpr hβ₀
+  have hcoeff : ∀ b : K, ((X - C b : Polynomial K) ^ p).coeff (p - 1) = -b * p := by
+    intro b
+    have hXb : (X - C b : Polynomial K) = X + C (-b) := by rw [sub_eq_add_neg, ← C_neg]
+    rw [hXb, coeff_X_add_C_pow]
+    have h1 : p - (p - 1) = 1 := by omega
+    have h2 : p.choose (p - 1) = p := by
+      have h3 := Nat.choose_symm (show p - 1 ≤ p by omega)
+      rw [h1] at h3
+      rw [← h3, Nat.choose_one_right]
+    rw [h1, h2, pow_one]
+  have hRcoeff : ∀ β ∈ S, R.coeff (p - 1) = -β * p := by
+    intro β hβ
+    have e := (hfact β hβ).2
+    rw [sub_eq_iff_eq_add] at e
+    rw [e, coeff_add, hcoeff, coeff_C, ite_eq_right (by omega : ¬(p - 1 = 0)), add_zero]
+  have huniq : ∀ β : K, G.IsRoot β → β = β₀ := by
+    intro β hβ
+    have h1 := hRcoeff β (hmemS.mpr hβ)
+    have h2 := hRcoeff β₀ hβ₀S
+    rw [h1] at h2
+    rw [neg_mul, neg_mul, neg_inj] at h2
+    exact mul_right_cancel₀ hp0 h2
+  refine ⟨β₀, huniq, ?_⟩
+  obtain ⟨hin₀, hf₀⟩ := hfact β₀ hβ₀S
+  rw [sub_eq_iff_eq_add] at hf₀
+  have hev : R.eval β₀ = β₀ := huniq _ (hmemS.mp hin₀)
+  rw [hev] at hf₀
+  exact hf₀
+
+end ModularCurve.StarBank
+p2m_export "" "ModularCurve.StarBank.count"
+
+private abbrev Kbar2 : Type := AlgebraicClosure (ZMod 2)
+
+example : ((X ^ 2 - X : Polynomial Kbar2).comp (X ^ 2)) ∣ C 1 * (X ^ 2 - X) ^ (2 + 1) := by
+  have h2K : (2 : Kbar2) = 0 := by exact_mod_cast CharP.cast_eq_zero Kbar2 2
+  have h2 : (2 : Polynomial Kbar2) = 0 := by
+    rw [← map_ofNat (C : Kbar2 →+* Polynomial Kbar2) 2, h2K, map_zero]
+  have hcomp : (X ^ 2 - X : Polynomial Kbar2).comp (X ^ 2) = (X ^ 2 - X) ^ 2 := by
+    rw [sub_comp, pow_comp, X_comp]
+    have key : (X ^ 2 - X : Polynomial Kbar2) ^ 2
+        = (X ^ 2) ^ 2 - X ^ 2 + 2 * (X ^ 2 - X ^ 3) := by ring
+    rw [key, h2, zero_mul, add_zero]
+  rw [hcomp, C_1, one_mul]
+  exact pow_dvd_pow _ (by norm_num)
+
+example : ¬ ∃ β₀ : Kbar2, (∀ β : Kbar2, (X ^ 2 - X : Polynomial Kbar2).IsRoot β → β = β₀) ∧
+    (X ^ 2 : Polynomial Kbar2) = (X - C β₀) ^ 2 + C β₀ := by
+  rintro ⟨β₀, huniq, -⟩
+  have h0 : (X ^ 2 - X : Polynomial Kbar2).IsRoot 0 := by simp [IsRoot]
+  have h1 : (X ^ 2 - X : Polynomial Kbar2).IsRoot 1 := by simp [IsRoot]
+  exact one_ne_zero ((huniq 1 h1).trans (huniq 0 h0).symm)
+
+open Polynomial in
+theorem solution {K : Type*} [Field K] [IsAlgClosed K] {p : ℕ}
+    (hp0 : (p : K) ≠ 0) (hp2 : 2 ≤ p) {R G : Polynomial K} (hR : R.Monic)
+    (hRdeg : R.natDegree = p) (hG : 0 < G.natDegree) {c : K} (hc : c ≠ 0)
+    (hdvd : G.comp R ∣ Polynomial.C c * G ^ (p + 1)) :
+    ∃ β₀ : K, (∀ β : K, G.IsRoot β → β = β₀) ∧
+      R = (Polynomial.X - Polynomial.C β₀) ^ p + Polynomial.C β₀ :=
+  ModularCurve.StarBank.count' hp0 hp2 hR hRdeg hG hc hdvd
+
+end S_ModularCurve_StarBank_count
+end P2MW
+export P2MW.S_ModularCurve_StarBank_count (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Polynomial
+theorem ModularCurve.StarBank.count {K : Type*} [Field K] [IsAlgClosed K] {p : ℕ}
+    (hp0 : (p : K) ≠ 0) (hp2 : 2 ≤ p) {R G : Polynomial K} (hR : R.Monic)
+    (hRdeg : R.natDegree = p) (hG : 0 < G.natDegree) {c : K} (hc : c ≠ 0)
+    (hdvd : G.comp R ∣ Polynomial.C c * G ^ (p + 1)) :
+    ∃ β₀ : K, (∀ β : K, G.IsRoot β → β = β₀) ∧
+      R = (Polynomial.X - Polynomial.C β₀) ^ p + Polynomial.C β₀ :=
+  solution hp0 hp2 hR hRdeg hG hc hdvd
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_deltaNorm.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_deltaNorm.lean
new file mode 100644
index 0000000000..2513884175
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_deltaNorm.lean
@@ -0,0 +1,556 @@
+/-
+Based on Prove2Me node ModularCurve.StarBank.deltaNorm
+(7b056d69-1626-5c84-9929-b988922bf6a8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9a50f839-c113-55bc-80de-5af1a8edc6d3
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+
+import Mathlib.RingTheory.Polynomial.Cyclotomic.Basic
+import Mathlib.RingTheory.PowerSeries.Expand
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A norm identity for the q-expansion of Δ
+
+Theorem statement: `ModularCurve.StarBank.deltaNorm` (`7b056d69-1626-5c84-9929-b988922bf6a8`), by
+Claude, 2026-09-05.
+
+Proof: submission `9a50f839-c113-55bc-80de-5af1a8edc6d3`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, $p$ a prime, and $\zeta \in K^\times$ a unit whose image in $K$ is a primitive
+$p$-th root of unity. Write $\Delta$ for the Laurent series over $K$ given by `HahnSeries.single (1
+: ℤ) (1 : K)` times the $24$-th power of the image in `LaurentSeries K` of the power series
+`etaProd` $= \prod'_{n \ge 1}(1 - X^{n})$ with its integer coefficients mapped into $K$ along
+`Int.castRingHom K`; that is, $\Delta = q\prod_{n\ge1}(1-q^{n})^{24}$. For a unit $u$, `qTwist u` is
+the ring endomorphism of `LaurentSeries K` multiplying the coefficient of $q^{k}$ by $u^{k}$, i.e.
+the substitution $q \mapsto uq$, and `qExpand K N` is the ring endomorphism obtained by pushing
+exponents forward along multiplication by $N$ on $\mathbb{Z}$, i.e. the substitution $q \mapsto
+q^{N}$. The assertion is the identity in `LaurentSeries K`
+$$\Big(\prod_{b=0}^{p-1} \Delta(\zeta^{b}q)\Big)\cdot \Delta(q^{p\cdot p}) \;=\;
+\Big(\prod_{b=0}^{p-1}\zeta^{b}\Big)\cdot \Delta(q^{p})^{\,p+1},$$
+the scalar on the right being the constant Laurent series `HahnSeries.C` attached to the image in
+$K$ of the product of the units $\zeta^{b}$ for $b < p$ (so $1$ for odd $p$ and $-1$ for $p = 2$).
+
+This is the formal $q$-expansion form of the classical norm relation
+$\prod_{b<p}\Delta((\tau+b)/p)\cdot\Delta(p\tau) = \pm\,\Delta(\tau)^{p+1}$ among the values of the
+discriminant form at the $p+1$ cyclic $p$-isogeny slots, here proved over an arbitrary field
+containing a primitive $p$-th root of unity. It is used by
+[`ModularCurve.StarBank.starBank`](thm.html#ModularCurve.StarBank.starBank).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_StarBank_deltaNorm.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_StarBank_deltaNorm
+
+noncomputable section
+
+open scoped PowerSeries.WithPiTopology
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_StarBank_deltaNorm.ModularCurve"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qTwist qTwist_coeff qTwist_single qExpand qExpand_coeff_mul \
+  qExpand_coeff_of_not_dvd qExpand_single etaProd constantCoeff_etaProd ofPowerSeries_coeff_of_neg"
+namespace W1
+p2m_open "ModularCurve"
+
+theorem qTwist_ofPowerSeries {R : Type*} [CommRing R] (u : Rˣ) (f : PowerSeries R) :
+    qTwist u (HahnSeries.ofPowerSeries ℤ R f) =
+      HahnSeries.ofPowerSeries ℤ R (PowerSeries.rescale (u : R) f) := by
+  ext k
+  rw [qTwist_coeff]
+  rcases le_or_gt 0 k with hk | hk
+  · lift k to ℕ using hk
+    rw [HahnSeries.ofPowerSeries_apply_coeff, HahnSeries.ofPowerSeries_apply_coeff,
+      PowerSeries.coeff_rescale, zpow_natCast, Units.val_pow_eq_pow_val]
+  · rw [ofPowerSeries_coeff_of_neg _ hk, ofPowerSeries_coeff_of_neg _ hk, mul_zero]
+
+theorem qExpand_ofPowerSeries {R : Type*} [CommRing R] (N : ℕ) [NeZero N] (f : PowerSeries R) :
+    qExpand R N (HahnSeries.ofPowerSeries ℤ R f) =
+      HahnSeries.ofPowerSeries ℤ R (PowerSeries.expand N (NeZero.ne N) f) := by
+  ext k
+  by_cases hk : (N : ℤ) ∣ k
+  · obtain ⟨m, rfl⟩ := hk
+    rw [qExpand_coeff_mul]
+    rcases le_or_gt 0 m with hm | hm
+    · lift m to ℕ using hm
+      rw [HahnSeries.ofPowerSeries_apply_coeff,
+        show ((N : ℤ) * ((m : ℕ) : ℤ) : ℤ) = ((N * m : ℕ) : ℤ) by push_cast; ring,
+        HahnSeries.ofPowerSeries_apply_coeff, PowerSeries.coeff_expand_mul]
+    · have hneg : (N : ℤ) * m < 0 :=
+        mul_neg_of_pos_of_neg (by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)) hm
+      rw [ofPowerSeries_coeff_of_neg _ hm, ofPowerSeries_coeff_of_neg _ hneg]
+  · rw [qExpand_coeff_of_not_dvd N _ hk]
+    rcases le_or_gt 0 k with hk0 | hk0
+    · lift k to ℕ using hk0
+      rw [HahnSeries.ofPowerSeries_apply_coeff, PowerSeries.coeff_expand_of_not_dvd]
+      exact fun h => hk (Int.natCast_dvd_natCast.2 h)
+    · rw [ofPowerSeries_coeff_of_neg _ hk0]
+
+theorem continuous_of_coeff {R S : Type*} [Semiring R] [Semiring S] [TopologicalSpace R]
+    [TopologicalSpace S] (g : PowerSeries R → PowerSeries S)
+    (h : ∀ d, Continuous fun φ => PowerSeries.coeff d (g φ)) : Continuous g :=
+  continuous_iff_continuousAt.2 fun φ =>
+    (PowerSeries.WithPiTopology.tendsto_iff_coeff_tendsto S g (nhds φ) (g φ)).2 fun d =>
+      (h d).continuousAt
+
+theorem continuous_map {R S : Type*} [Semiring R] [Semiring S] [TopologicalSpace R]
+    [TopologicalSpace S] (f : R →+* S) (hf : Continuous f) :
+    Continuous (PowerSeries.map f : PowerSeries R → PowerSeries S) :=
+  continuous_of_coeff _ fun d => by
+    simp only [PowerSeries.coeff_map]
+    exact hf.comp (PowerSeries.WithPiTopology.continuous_coeff R d)
+
+theorem continuous_rescale {R : Type*} [CommRing R] [TopologicalSpace R] [DiscreteTopology R]
+    (a : R) : Continuous (PowerSeries.rescale a : PowerSeries R → PowerSeries R) :=
+  continuous_of_coeff _ fun d => by
+    simp only [PowerSeries.coeff_rescale]
+    exact (continuous_of_discreteTopology (f := fun x : R => a ^ d * x)).comp
+      (PowerSeries.WithPiTopology.continuous_coeff R d)
+
+theorem continuous_expand {R : Type*} [CommRing R] [TopologicalSpace R] (N : ℕ) (hN : N ≠ 0) :
+    Continuous (PowerSeries.expand N hN : PowerSeries R → PowerSeries R) :=
+  continuous_of_coeff _ fun d => by
+    simp only [PowerSeries.coeff_expand]
+    split_ifs
+    · exact PowerSeries.WithPiTopology.continuous_coeff R _
+    · exact continuous_const
+
+theorem multipliable_of_X_pow_dvd {R : Type*} [CommRing R] [TopologicalSpace R]
+    (u : ℕ → PowerSeries R) (h : ∀ n, (PowerSeries.X : PowerSeries R) ^ (n + 1) ∣ u n - 1) :
+    Multipliable u := by
+  have hu : u = fun n => 1 + (u n - 1) := funext fun n => by ring
+  rw [hu]
+  apply PowerSeries.WithPiTopology.multipliable_one_add_of_tendsto_order_atTop_nhds_top
+  refine ENat.tendsto_nhds_top_iff_natCast_lt.mpr fun n => Filter.eventually_atTop.mpr ⟨n, ?_⟩
+  intro m hm
+  have hle : ((m + 1 : ℕ) : ℕ∞) ≤ (u m - 1).order :=
+    PowerSeries.nat_le_order _ _ fun i hi => PowerSeries.X_pow_dvd_iff.1 (h m) i hi
+  exact lt_of_lt_of_le (by exact_mod_cast Nat.lt_succ_of_le hm) hle
+
+theorem map_etaProd_eq_tprod (K : Type*) [CommRing K] [TopologicalSpace K] [T2Space K] :
+    PowerSeries.map (Int.castRingHom K) etaProd =
+      ∏' n : ℕ, ((1 : PowerSeries K) - PowerSeries.X ^ (n + 1)) := by
+  rw [etaProd, (PowerSeries.WithPiTopology.multipliable_one_sub_X_pow ℤ).map_tprod
+    (PowerSeries.map (Int.castRingHom K)) (continuous_map _ continuous_of_discreteTopology)]
+  exact tprod_congr fun n => by rw [map_sub, map_one, map_pow, PowerSeries.map_X]
+
+theorem rescale_tprod_one_sub_X_pow {K : Type*} [CommRing K] [TopologicalSpace K]
+    [DiscreteTopology K] (a : K) :
+    PowerSeries.rescale a (∏' n : ℕ, ((1 : PowerSeries K) - PowerSeries.X ^ (n + 1))) =
+      ∏' n : ℕ, ((1 : PowerSeries K) - PowerSeries.C (a ^ (n + 1)) * PowerSeries.X ^ (n + 1)) := by
+  rw [(PowerSeries.WithPiTopology.multipliable_one_sub_X_pow K).map_tprod (PowerSeries.rescale a)
+    (continuous_rescale a)]
+  exact tprod_congr fun n => by
+    rw [map_sub, map_one, map_pow, PowerSeries.rescale_X, mul_pow, ← map_pow]
+
+theorem expand_tprod_one_sub_X_pow {K : Type*} [CommRing K] [TopologicalSpace K] [T2Space K]
+    (N : ℕ) (hN : N ≠ 0) :
+    PowerSeries.expand N hN (∏' n : ℕ, ((1 : PowerSeries K) - PowerSeries.X ^ (n + 1))) =
+      ∏' n : ℕ, ((1 : PowerSeries K) - PowerSeries.X ^ (N * (n + 1))) := by
+  rw [(PowerSeries.WithPiTopology.multipliable_one_sub_X_pow K).map_tprod (PowerSeries.expand N hN)
+    (continuous_expand N hN)]
+  exact tprod_congr fun n => by rw [map_sub, map_one, map_pow, PowerSeries.expand_X, ← pow_mul]
+
+theorem prod_one_sub_root_mul {K : Type*} [Field K] {p : ℕ} [Fact p.Prime] {μ : K}
+    (hμ : IsPrimitiveRoot μ p) (Y : PowerSeries K) :
+    ∏ b ∈ Finset.range p, ((1 : PowerSeries K) - PowerSeries.C (μ ^ b) * Y) = 1 - Y ^ p := by
+  classical
+  have hp : p.Prime := Fact.out
+  have hinj : Function.Injective (PowerSeries.C : K → PowerSeries K) := fun a b hab => by
+    simpa using congrArg PowerSeries.constantCoeff hab
+  have hμ' : IsPrimitiveRoot (PowerSeries.C μ) p := hμ.map_of_injective hinj
+  have h := hμ'.pow_sub_pow_eq_prod_sub_mul 1 Y hp.pos
+  rw [one_pow] at h
+  rw [h]
+  have hset : Polynomial.nthRootsFinset p (1 : PowerSeries K) =
+      (Finset.range p).image fun b => PowerSeries.C μ ^ b := by
+    ext x
+    rw [Polynomial.mem_nthRootsFinset hp.pos, Finset.mem_image]
+    constructor
+    · intro hx
+      obtain ⟨i, hi, rfl⟩ := hμ'.eq_pow_of_pow_eq_one hx
+      exact ⟨i, Finset.mem_range.2 hi, rfl⟩
+    · rintro ⟨i, -, rfl⟩
+      rw [← pow_mul, mul_comm, pow_mul, hμ'.pow_eq_one, one_pow]
+  rw [hset, Finset.prod_image fun i hi j hj hij =>
+    hμ'.pow_inj (Finset.mem_range.1 hi) (Finset.mem_range.1 hj) hij]
+  exact Finset.prod_congr rfl fun b _ => by rw [map_pow]
+
+theorem prod_twist_factor {K : Type*} [Field K] {p : ℕ} [Fact p.Prime] {ζ : K}
+    (hζ : IsPrimitiveRoot ζ p) (m : ℕ) :
+    ∏ b ∈ Finset.range p,
+        ((1 : PowerSeries K) - PowerSeries.C ((ζ ^ b) ^ m) * PowerSeries.X ^ m) =
+      if p ∣ m then ((1 : PowerSeries K) - PowerSeries.X ^ m) ^ p
+      else (1 : PowerSeries K) - PowerSeries.X ^ (p * m) := by
+  have hp : p.Prime := Fact.out
+  split_ifs with hd
+  · obtain ⟨k, rfl⟩ := hd
+    rw [Finset.prod_congr rfl fun b _ => show
+        (1 : PowerSeries K) - PowerSeries.C ((ζ ^ b) ^ (p * k)) * PowerSeries.X ^ (p * k) =
+          1 - PowerSeries.X ^ (p * k) by
+      rw [← pow_mul, mul_left_comm b p k, pow_mul, hζ.pow_eq_one, one_pow, map_one, one_mul],
+      Finset.prod_const, Finset.card_range]
+  · have hμ : IsPrimitiveRoot (ζ ^ m) p :=
+      hζ.pow_of_coprime m (Nat.coprime_comm.1 ((Nat.Prime.coprime_iff_not_dvd hp).2 hd))
+    rw [Finset.prod_congr rfl fun b _ => show
+        (1 : PowerSeries K) - PowerSeries.C ((ζ ^ b) ^ m) * PowerSeries.X ^ m =
+          1 - PowerSeries.C ((ζ ^ m) ^ b) * PowerSeries.X ^ m by rw [← pow_mul, mul_comm b m,
+            pow_mul],
+      prod_one_sub_root_mul hμ, ← pow_mul, mul_comm m p]
+
+def uFam (K : Type*) [CommRing K] (k n : ℕ) : PowerSeries K := 1 - PowerSeries.X ^ (k * (n + 1))
+
+def hFam (K : Type*) [CommRing K] (p n : ℕ) : PowerSeries K :=
+  if p ∣ n + 1 then 1 else 1 - PowerSeries.X ^ (p * (n + 1))
+
+def gFam (K : Type*) [CommRing K] (p n : ℕ) : PowerSeries K :=
+  if p ∣ n + 1 then (1 - PowerSeries.X ^ (n + 1)) ^ p else 1
+
+def g'Fam (K : Type*) [CommRing K] (p n : ℕ) : PowerSeries K :=
+  if p ∣ n + 1 then 1 - PowerSeries.X ^ (p * (n + 1)) else 1
+
+def cFam (K : Type*) [CommRing K] (p n : ℕ) : PowerSeries K :=
+  if p ∣ n + 1 then (1 - PowerSeries.X ^ (n + 1)) ^ p else 1 - PowerSeries.X ^ (p * (n + 1))
+
+theorem cFam_eq (K : Type*) [CommRing K] (p n : ℕ) : cFam K p n = hFam K p n * gFam K p n := by
+  unfold cFam hFam gFam
+  split_ifs <;> ring
+
+theorem uFam_eq (K : Type*) [CommRing K] (p n : ℕ) : uFam K p n = hFam K p n * g'Fam K p n := by
+  unfold uFam hFam g'Fam
+  split_ifs <;> ring
+
+theorem one_le_index {p : ℕ} (hp : 0 < p) (m : ℕ) : 1 ≤ p * (m + 1) :=
+  Nat.one_le_iff_ne_zero.2 (mul_ne_zero hp.ne' (Nat.succ_ne_zero m))
+
+theorem index_injective {p : ℕ} (hp : 0 < p) : Function.Injective fun m : ℕ => p * (m + 1) - 1 := by
+  intro a b hab
+  have h := (tsub_left_inj (one_le_index hp a) (one_le_index hp b)).1 hab
+  have h' := Nat.eq_of_mul_eq_mul_left hp h
+  omega
+
+theorem mulSupport_subset_range {K : Type*} [CommRing K] {p : ℕ} (F : ℕ → PowerSeries K)
+    (hF : ∀ n, ¬ p ∣ n + 1 → F n = 1) :
+    Function.mulSupport F ⊆ Set.range fun m : ℕ => p * (m + 1) - 1 := by
+  intro n hn
+  rw [Function.mem_mulSupport] at hn
+  by_cases hd : p ∣ n + 1
+  · obtain ⟨k, hk⟩ := hd
+    cases k with
+    | zero => simp at hk
+    | succ m => exact ⟨m, (Nat.eq_sub_of_add_eq hk).symm⟩
+  · exact absurd (hF n hd) hn
+
+section Multipliable
+
+variable (K : Type*) [CommRing K] [TopologicalSpace K]
+
+theorem multipliable_uFam {k : ℕ} (hk : 0 < k) : Multipliable (uFam K k) :=
+  multipliable_of_X_pow_dvd _ fun n => by
+    rw [uFam, sub_sub_cancel_left, dvd_neg]
+    exact pow_dvd_pow _ (Nat.le_mul_of_pos_left _ hk)
+
+theorem multipliable_hFam {p : ℕ} (hp : 0 < p) : Multipliable (hFam K p) :=
+  multipliable_of_X_pow_dvd _ fun n => by
+    unfold hFam
+    split_ifs
+    · simp
+    · rw [sub_sub_cancel_left, dvd_neg]
+      exact pow_dvd_pow _ (Nat.le_mul_of_pos_left _ hp)
+
+theorem multipliable_gFam (p : ℕ) : Multipliable (gFam K p) :=
+  multipliable_of_X_pow_dvd _ fun n => by
+    unfold gFam
+    split_ifs
+    · have h1 : (PowerSeries.X : PowerSeries K) ^ (n + 1) ∣ (1 - PowerSeries.X ^ (n + 1)) - 1 :=
+        ⟨-1, by ring⟩
+      have h2 := sub_dvd_pow_sub_pow ((1 : PowerSeries K) - PowerSeries.X ^ (n + 1)) 1 p
+      rw [one_pow] at h2
+      exact h1.trans h2
+    · simp
+
+theorem multipliable_g'Fam {p : ℕ} (hp : 0 < p) : Multipliable (g'Fam K p) :=
+  multipliable_of_X_pow_dvd _ fun n => by
+    unfold g'Fam
+    split_ifs
+    · rw [sub_sub_cancel_left, dvd_neg]
+      exact pow_dvd_pow _ (Nat.le_mul_of_pos_left _ hp)
+    · simp
+
+end Multipliable
+
+section Topological
+
+variable (K : Type*) [CommRing K] [TopologicalSpace K] [DiscreteTopology K]
+
+theorem tprod_gFam {p : ℕ} (hp : 0 < p) : ∏' n, gFam K p n = (∏' n, uFam K p n) ^ p := by
+  have hsupp := mulSupport_subset_range (gFam K p) fun n hd => by
+    unfold gFam; rw [ite_eq_right hd]
+  rw [← (index_injective hp).tprod_eq hsupp, ← (multipliable_uFam K hp).tprod_pow]
+  exact tprod_congr fun m => by
+    change gFam K p (p * (m + 1) - 1) = uFam K p m ^ p
+    unfold gFam uFam
+    rw [Nat.sub_add_cancel (one_le_index hp m), ite_eq_left (dvd_mul_right p (m + 1))]
+
+omit [DiscreteTopology K] in
+theorem tprod_g'Fam {p : ℕ} (hp : 0 < p) : ∏' n, g'Fam K p n = ∏' n, uFam K (p * p) n := by
+  have hsupp := mulSupport_subset_range (g'Fam K p) fun n hd => by
+    unfold g'Fam; rw [ite_eq_right hd]
+  rw [← (index_injective hp).tprod_eq hsupp]
+  exact tprod_congr fun m => by
+    show g'Fam K p (p * (m + 1) - 1) = uFam K (p * p) m
+    unfold g'Fam uFam
+    rw [Nat.sub_add_cancel (one_le_index hp m), ite_eq_left (dvd_mul_right p (m + 1)), mul_assoc]
+
+theorem regroup {p : ℕ} (hp : 0 < p) :
+    (∏' n, cFam K p n) * (∏' n, uFam K (p * p) n) = (∏' n, uFam K p n) ^ (p + 1) := by
+  have hc : ∏' n, cFam K p n = (∏' n, hFam K p n) * ∏' n, gFam K p n := by
+    rw [← (multipliable_hFam K hp).tprod_mul (multipliable_gFam K p)]
+    exact tprod_congr fun n => cFam_eq K p n
+  have hu : ∏' n, uFam K p n = (∏' n, hFam K p n) * ∏' n, g'Fam K p n := by
+    rw [← (multipliable_hFam K hp).tprod_mul (multipliable_g'Fam K hp)]
+    exact tprod_congr fun n => uFam_eq K p n
+  rw [hc, tprod_gFam K hp, ← tprod_g'Fam K hp]
+  calc (∏' n, hFam K p n) * (∏' n, uFam K p n) ^ p * ∏' n, g'Fam K p n
+      = (∏' n, uFam K p n) ^ p * ((∏' n, hFam K p n) * ∏' n, g'Fam K p n) := by ring
+    _ = (∏' n, uFam K p n) ^ (p + 1) := by rw [← hu, pow_succ]
+
+end Topological
+
+theorem etaNorm_powerSeries {K : Type*} [Field K] {p : ℕ} [Fact p.Prime] {ζ : K}
+    (hζ : IsPrimitiveRoot ζ p) :
+    (∏ b ∈ Finset.range p,
+        PowerSeries.rescale (ζ ^ b) (PowerSeries.map (Int.castRingHom K) etaProd)) *
+      PowerSeries.expand (p * p) (mul_ne_zero (NeZero.ne p) (NeZero.ne p))
+        (PowerSeries.map (Int.castRingHom K) etaProd) =
+    PowerSeries.expand p (NeZero.ne p) (PowerSeries.map (Int.castRingHom K) etaProd) ^ (p + 1) := by
+  let : TopologicalSpace K := ⊥
+  have : DiscreteTopology K := ⟨rfl⟩
+  have hp : p.Prime := Fact.out
+  have hmult : ∀ b ∈ Finset.range p, Multipliable fun n : ℕ =>
+      (1 : PowerSeries K) - PowerSeries.C ((ζ ^ b) ^ (n + 1)) * PowerSeries.X ^ (n + 1) :=
+    fun b _ => multipliable_of_X_pow_dvd _ fun n => ⟨-PowerSeries.C ((ζ ^ b) ^ (n + 1)), by ring⟩
+  rw [map_etaProd_eq_tprod K, expand_tprod_one_sub_X_pow, expand_tprod_one_sub_X_pow,
+    Finset.prod_congr rfl fun b _ => rescale_tprod_one_sub_X_pow (ζ ^ b),
+    ← Multipliable.tprod_finsetProd hmult, tprod_congr fun n => prod_twist_factor hζ (n + 1)]
+  exact regroup K hp.pos
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qTwist qTwist_coeff qTwist_single qExpand qExpand_coeff_mul \
+  qExpand_coeff_of_not_dvd qExpand_single etaProd constantCoeff_etaProd ofPowerSeries_coeff_of_neg"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.StarBank.etaNorm {K : Type*} [Field K] (p : ℕ) [Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (∏ b ∈ Finset.range p,
+        qTwist (ζ ^ b) (HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd)))
+          *
+      qExpand K (p * p) (HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd))
+        =
+    qExpand K p (HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd)) ^
+      (p + 1) := by
+  rw [ModularCurve.W1.qExpand_ofPowerSeries, ModularCurve.W1.qExpand_ofPowerSeries,
+    Finset.prod_congr rfl fun b _ => ModularCurve.W1.qTwist_ofPowerSeries (ζ ^ b) _,
+    ← map_prod, ← map_mul, ← map_pow]
+  simp only [Units.val_pow_eq_pow_val]
+  exact congrArg _ (ModularCurve.W1.etaNorm_powerSeries hζ)
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qTwist qTwist_coeff qTwist_single qExpand qExpand_coeff_mul \
+  qExpand_coeff_of_not_dvd qExpand_single etaProd constantCoeff_etaProd ofPowerSeries_coeff_of_neg"
+namespace W1
+p2m_open "ModularCurve"
+
+theorem prod_single_one {K : Type*} [CommRing K] (s : Finset ℕ) (x : ℕ → K) :
+    ∏ b ∈ s, HahnSeries.single (1 : ℤ) (x b) = HahnSeries.single (s.card : ℤ) (∏ b ∈ s, x b) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => simp
+  | insert a s ha ih =>
+    rw [Finset.prod_insert ha, Finset.prod_insert ha, ih, HahnSeries.single_mul_single,
+      Finset.card_insert_of_notMem ha, Nat.cast_succ, add_comm (1 : ℤ)]
+
+theorem delta_bookkeeping {K : Type*} [Field K] (p : ℕ) (ε : K) (PT V1 V2 : LaurentSeries K)
+    (hN : PT * V2 = V1 ^ (p + 1)) :
+    HahnSeries.single (p : ℤ) ε * PT ^ 24 * (HahnSeries.single ((p * p : ℕ) : ℤ) (1 : K) * V2 ^ 24)
+      =
+      HahnSeries.C ε * (HahnSeries.single (p : ℤ) (1 : K) * V1 ^ 24) ^ (p + 1) := by
+  have hs : HahnSeries.single (p : ℤ) ε * HahnSeries.single ((p * p : ℕ) : ℤ) (1 : K) =
+      HahnSeries.C ε * HahnSeries.single (p : ℤ) (1 : K) ^ (p + 1) := by
+    rw [HahnSeries.single_mul_single, HahnSeries.single_pow, HahnSeries.C_apply,
+      HahnSeries.single_mul_single, mul_one, one_pow, mul_one,
+      show (0 : ℤ) + (p + 1) • ((p : ℕ) : ℤ) = ((p : ℕ) : ℤ) + ((p * p : ℕ) : ℤ) by
+        rw [nsmul_eq_mul]; push_cast; ring]
+  calc HahnSeries.single (p : ℤ) ε * PT ^ 24 *
+        (HahnSeries.single ((p * p : ℕ) : ℤ) (1 : K) * V2 ^ 24)
+      = (HahnSeries.single (p : ℤ) ε * HahnSeries.single ((p * p : ℕ) : ℤ) (1 : K)) *
+          (PT * V2) ^ 24 := by ring
+    _ = HahnSeries.C ε * (HahnSeries.single (p : ℤ) (1 : K) * V1 ^ 24) ^ (p + 1) := by
+        rw [hN, hs]; ring
+
+end ModularCurve.W1
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.StarBank.deltaNorm {K : Type*} [Field K] (p : ℕ) [Fact p.Prime]
+    (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (∏ b ∈ Finset.range p, qTwist (ζ ^ b)
+        (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24)) *
+      qExpand K (p * p) (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) =
+    HahnSeries.C (((∏ b ∈ Finset.range p, ζ ^ b : Kˣ) : K)) *
+      qExpand K p (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^
+        (p + 1) := by
+  have hN := ModularCurve.StarBank.etaNorm p ζ hζ
+  have hT : ∀ b ∈ Finset.range p,
+      qTwist (ζ ^ b) (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) =
+        HahnSeries.single (1 : ℤ) ((ζ ^ b : Kˣ) : K) *
+          qTwist (ζ ^ b)
+            (HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd)) ^ 24 :=
+    fun b _ => by rw [map_mul, map_pow, qTwist_single, zpow_one, mul_one]
+  rw [Finset.prod_congr rfl hT, Finset.prod_mul_distrib, Finset.prod_pow,
+    ModularCurve.W1.prod_single_one, Finset.card_range, ← Units.coe_prod, map_mul, map_pow,
+    qExpand_single, mul_one, map_mul, map_pow, qExpand_single, mul_one]
+  exact ModularCurve.W1.delta_bookkeeping p _ _ _ _ hN
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qTwist qTwist_coeff qTwist_single qExpand qExpand_coeff_mul \
+  qExpand_coeff_of_not_dvd qExpand_single etaProd constantCoeff_etaProd ofPowerSeries_coeff_of_neg"
+namespace W1
+p2m_open "ModularCurve"
+
+theorem coeff_one_mul {R : Type*} [CommRing R] (φ ψ : PowerSeries R) :
+    PowerSeries.coeff 1 (φ * ψ) =
+      PowerSeries.coeff 0 φ * PowerSeries.coeff 1 ψ + PowerSeries.coeff 1 φ * PowerSeries.coeff 0 ψ
+        := by
+  rw [PowerSeries.coeff_mul, Finset.Nat.sum_antidiagonal_succ, Finset.Nat.antidiagonal_zero,
+    Finset.sum_singleton]
+
+theorem coeff_one_pow_of_constantCoeff {R : Type*} [CommRing R] (e : PowerSeries R)
+    (h0 : PowerSeries.constantCoeff e = 1) (N : ℕ) :
+    PowerSeries.coeff 1 (e ^ N) = N * PowerSeries.coeff 1 e := by
+  induction N with
+  | zero => simp [PowerSeries.coeff_one]
+  | succ N ih =>
+    rw [pow_succ, coeff_one_mul, ih, PowerSeries.coeff_zero_eq_constantCoeff_apply, map_pow,
+      h0, one_pow, PowerSeries.coeff_zero_eq_constantCoeff_apply, h0]
+    push_cast
+    ring
+
+theorem coeff_one_etaProd : PowerSeries.coeff 1 etaProd = -1 := by
+  have hmul := PowerSeries.WithPiTopology.multipliable_one_sub_X_pow ℤ
+  have ht : Filter.Tendsto
+      (fun s : Finset ℕ => PowerSeries.coeff 1
+        (∏ i ∈ s, ((1 : PowerSeries ℤ) - PowerSeries.X ^ (i + 1))))
+      Filter.atTop (nhds (PowerSeries.coeff 1 etaProd)) :=
+    ((PowerSeries.WithPiTopology.continuous_coeff ℤ 1).tendsto _).comp hmul.hasProd
+  rw [nhds_discrete ℤ, Filter.tendsto_pure] at ht
+  obtain ⟨s₀, hs₀⟩ := Filter.eventually_atTop.mp ht
+  have hsub : s₀ ⊆ insert 0 (s₀.erase 0) := Finset.subset_insert_iff.mpr (subset_refl _)
+  have key : PowerSeries.coeff 1
+      (∏ i ∈ insert 0 (s₀.erase 0), ((1 : PowerSeries ℤ) - PowerSeries.X ^ (i + 1))) =
+        PowerSeries.coeff 1 etaProd := hs₀ _ hsub
+  rw [← key, Finset.prod_insert (Finset.notMem_erase 0 s₀)]
+  obtain ⟨r, hr⟩ : ∃ r : PowerSeries ℤ,
+      ∏ i ∈ s₀.erase 0, ((1 : PowerSeries ℤ) - PowerSeries.X ^ (i + 1)) =
+        1 + PowerSeries.X ^ 2 * r := by
+    refine Finset.prod_induction _ (fun Q => ∃ r : PowerSeries ℤ, Q = 1 + PowerSeries.X ^ 2 * r)
+      ?_ ?_ ?_
+    · rintro a b ⟨u, rfl⟩ ⟨v, rfl⟩
+      exact ⟨u + v + PowerSeries.X ^ 2 * u * v, by ring⟩
+    · exact ⟨0, by ring⟩
+    · intro i hi
+      cases i with
+      | zero => exact absurd hi (Finset.notMem_erase 0 s₀)
+      | succ k => exact ⟨-PowerSeries.X ^ k, by ring⟩
+  have hexp : ((1 : PowerSeries ℤ) - PowerSeries.X ^ (0 + 1)) * (1 + PowerSeries.X ^ 2 * r) =
+      1 - PowerSeries.X + PowerSeries.X ^ 2 * (r - PowerSeries.X * r) := by
+    ring
+  rw [hr, hexp, map_add, map_sub, PowerSeries.coeff_one, PowerSeries.coeff_one_X,
+    PowerSeries.coeff_X_pow_mul']
+  simp
+
+end ModularCurve.W1
+
+example :
+    etaProd * etaProd * PowerSeries.expand 4 (by decide) etaProd ≠
+      PowerSeries.expand 2 (by decide) etaProd ^ 3 := by
+  intro h
+  have key := congrArg (PowerSeries.coeff 1) h
+  have h0 : PowerSeries.constantCoeff (PowerSeries.expand 2 (by decide) etaProd) = 1 := by
+    rw [PowerSeries.constantCoeff_expand, constantCoeff_etaProd]
+  have h1 : PowerSeries.coeff 1 (PowerSeries.expand 2 (by decide) etaProd) = 0 :=
+    PowerSeries.coeff_expand_of_not_dvd 2 _ _ (by decide)
+  rw [ModularCurve.W1.coeff_one_pow_of_constantCoeff _ h0, h1, mul_zero,
+    ModularCurve.W1.coeff_one_mul, ModularCurve.W1.coeff_one_mul,
+    PowerSeries.coeff_expand_of_not_dvd 4 _ _ (by decide),
+    PowerSeries.coeff_zero_eq_constantCoeff_apply, PowerSeries.coeff_zero_eq_constantCoeff_apply,
+    PowerSeries.coeff_zero_eq_constantCoeff_apply, PowerSeries.constantCoeff_expand,
+    constantCoeff_etaProd, ModularCurve.W1.coeff_one_etaProd] at key
+  norm_num at key
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_StarBank_deltaNorm.ModularCurve in
+theorem solution {K : Type*} [Field K] (p : ℕ) [Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (∏ b ∈ Finset.range p, qTwist (ζ ^ b)
+        (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24)) *
+      qExpand K (p * p) (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) =
+    HahnSeries.C (((∏ b ∈ Finset.range p, ζ ^ b : Kˣ) : K)) *
+      qExpand K p (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^
+        (p + 1) :=
+  ModularCurve.StarBank.deltaNorm p ζ hζ
+
+end S_ModularCurve_StarBank_deltaNorm
+end P2MW
+export P2MW.S_ModularCurve_StarBank_deltaNorm (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.StarBank.deltaNorm {K : Type*} [Field K] (p : ℕ) [Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (∏ b ∈ Finset.range p, qTwist (ζ ^ b)
+        (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24)) *
+      qExpand K (p * p) (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) =
+    HahnSeries.C (((∏ b ∈ Finset.range p, ζ ^ b : Kˣ) : K)) *
+      qExpand K p (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^
+        (p + 1) :=
+  solution p ζ hζ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_delta_pow_ne.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_delta_pow_ne.lean
new file mode 100644
index 0000000000..aac47b4671
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_delta_pow_ne.lean
@@ -0,0 +1,329 @@
+/-
+Based on Prove2Me node ModularCurve.StarBank.delta_pow_ne
+(41f7025d-90bb-59c1-8f6a-62a27ddf93ef) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission bb7b3daa-857b-58a9-9a52-511df2899473
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_map_intCast_pow_char_eq_qExpand
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# In characteristic ℓ, Δᵖ is never γ Δ(qᵖ)
+
+Theorem statement: `ModularCurve.StarBank.delta_pow_ne` (`41f7025d-90bb-59c1-8f6a-62a27ddf93ef`), by
+Claude, 2026-09-05.
+
+Proof: submission `bb7b3daa-857b-58a9-9a52-511df2899473`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a commutative ring, $\ell$ a prime, and suppose $K$ has characteristic $\ell$; let $p$ be
+a prime with $p \neq \ell$, and let $\gamma \in K$. Work in the Laurent series ring $K(\!(q)\!)$,
+realised as Hahn series over $\mathbb{Z}$, and set $\Delta$ to be the product of the monomial $q$
+(the Hahn series `HahnSeries.single (1 : ℤ) (1 : K)`) with the twenty-fourth power of the image in
+$K(\!(q)\!)$ of the power series $\prod_{n \ge 1}(1 - X^{n})$ over $\mathbb{Z}$ (the project's
+`etaProd`), its coefficients pushed into $K$ along $\mathbb{Z} \to K$; thus $\Delta = q\prod_{n\ge
+1}(1-q^{n})^{24}$. Let $\mathrm{qExpand}\,K\,p$ be the ring endomorphism of $K(\!(q)\!)$ obtained by
+re-indexing exponents along multiplication by $p$ on $\mathbb{Z}$, that is, the substitution $q
+\mapsto q^{p}$. The assertion is that $\Delta^{p} \neq \gamma \cdot
+\mathrm{qExpand}\,K\,p\,(\Delta)$, i.e. $\Delta(q)^{p}$ is not the constant $\gamma$ times
+$\Delta(q^{p})$, for any such $\gamma$.
+
+The statement rules out the one relation that would be compatible with all the congruence
+constraints in the characteristic-$\ell$ study of the $q$-expansions attached to $X_0(N)$, the
+hypothesis $p \neq \ell$ being essential since for $p = \ell$ the identity holds with $\gamma = 1$
+(raising a series with coefficients from the prime field to the $\ell$-th power substitutes $q
+\mapsto q^{\ell}$, as recorded in
+[`ModularCurve.map_intCast_pow_char_eq_qExpand`]
+(thm.html#ModularCurve.map_intCast_pow_char_eq_qExpand)).
+It is used by [`ModularCurve.StarBank.starBank`](thm.html#ModularCurve.StarBank.starBank).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_StarBank_delta_pow_ne.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_StarBank_delta_pow_ne
+
+noncomputable section
+
+open scoped PowerSeries.WithPiTopology
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_StarBank_delta_pow_ne.ModularCurve"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_single \
+  qExpand_one_apply qExpand_congr qExpand_qExpand etaProd constantCoeff_etaProd \
+  ofPowerSeries_coeff_of_neg map_intCast_pow_char_eq_qExpand"
+namespace W1
+p2m_open "ModularCurve"
+
+local notation "𝓔[" K "]" =>
+  HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd)
+
+theorem coeff_one_mul {R : Type*} [CommRing R] (φ ψ : PowerSeries R) :
+    PowerSeries.coeff 1 (φ * ψ) =
+      PowerSeries.coeff 0 φ * PowerSeries.coeff 1 ψ + PowerSeries.coeff 1 φ * PowerSeries.coeff 0 ψ
+        := by
+  rw [PowerSeries.coeff_mul, Finset.Nat.sum_antidiagonal_succ, Finset.Nat.antidiagonal_zero,
+    Finset.sum_singleton]
+
+theorem coeff_one_etaProd : PowerSeries.coeff 1 etaProd = -1 := by
+  have hmul := PowerSeries.WithPiTopology.multipliable_one_sub_X_pow ℤ
+  have ht : Filter.Tendsto
+      (fun s : Finset ℕ => PowerSeries.coeff 1
+        (∏ i ∈ s, ((1 : PowerSeries ℤ) - PowerSeries.X ^ (i + 1))))
+      Filter.atTop (nhds (PowerSeries.coeff 1 etaProd)) :=
+    ((PowerSeries.WithPiTopology.continuous_coeff ℤ 1).tendsto _).comp hmul.hasProd
+  rw [nhds_discrete ℤ, Filter.tendsto_pure] at ht
+  obtain ⟨s₀, hs₀⟩ := Filter.eventually_atTop.mp ht
+  have hsub : s₀ ⊆ insert 0 (s₀.erase 0) := Finset.subset_insert_iff.mpr (subset_refl _)
+  have key : PowerSeries.coeff 1
+      (∏ i ∈ insert 0 (s₀.erase 0), ((1 : PowerSeries ℤ) - PowerSeries.X ^ (i + 1))) =
+        PowerSeries.coeff 1 etaProd := hs₀ _ hsub
+  rw [← key, Finset.prod_insert (Finset.notMem_erase 0 s₀)]
+  obtain ⟨r, hr⟩ : ∃ r : PowerSeries ℤ,
+      ∏ i ∈ s₀.erase 0, ((1 : PowerSeries ℤ) - PowerSeries.X ^ (i + 1)) =
+        1 + PowerSeries.X ^ 2 * r := by
+    refine Finset.prod_induction _ (fun Q => ∃ r : PowerSeries ℤ, Q = 1 + PowerSeries.X ^ 2 * r)
+      ?_ ?_ ?_
+    · rintro a b ⟨u, rfl⟩ ⟨v, rfl⟩
+      exact ⟨u + v + PowerSeries.X ^ 2 * u * v, by ring⟩
+    · exact ⟨0, by ring⟩
+    · intro i hi
+      cases i with
+      | zero => exact absurd hi (Finset.notMem_erase 0 s₀)
+      | succ k => exact ⟨-PowerSeries.X ^ k, by ring⟩
+  have hexp : ((1 : PowerSeries ℤ) - PowerSeries.X ^ (0 + 1)) * (1 + PowerSeries.X ^ 2 * r) =
+      1 - PowerSeries.X + PowerSeries.X ^ 2 * (r - PowerSeries.X * r) := by
+    ring
+  rw [hr, hexp, map_add, map_sub, PowerSeries.coeff_one, PowerSeries.coeff_one_X,
+    PowerSeries.coeff_X_pow_mul']
+  simp
+
+theorem constantCoeff_etaProd_map (K : Type*) [CommRing K] :
+    PowerSeries.constantCoeff (PowerSeries.map (Int.castRingHom K) etaProd) = 1 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff_apply, PowerSeries.coeff_map,
+    PowerSeries.coeff_zero_eq_constantCoeff_apply, constantCoeff_etaProd, map_one]
+
+theorem coeff_one_etaProd_map (K : Type*) [CommRing K] :
+    PowerSeries.coeff 1 (PowerSeries.map (Int.castRingHom K) etaProd) = -1 := by
+  rw [PowerSeries.coeff_map, coeff_one_etaProd, map_neg, map_one]
+
+theorem coeff_one_pow_of_shape {R : Type*} [CommRing R] (e : PowerSeries R)
+    (h0 : PowerSeries.constantCoeff e = 1) (h1 : PowerSeries.coeff 1 e = -1) (N : ℕ) :
+    PowerSeries.coeff 1 (e ^ N) = -(N : R) := by
+  induction N with
+  | zero => simp [PowerSeries.coeff_one]
+  | succ N ih =>
+    rw [pow_succ, coeff_one_mul, ih, h1, PowerSeries.coeff_zero_eq_constantCoeff_apply, map_pow,
+      h0, one_pow, PowerSeries.coeff_zero_eq_constantCoeff_apply, h0]
+    push_cast
+    ring
+
+theorem coeff_one_etaC_pow (K : Type*) [CommRing K] (N : ℕ) :
+    (𝓔[K] ^ N).coeff 1 = -(N : K) := by
+  rw [← map_pow]
+  have h := HahnSeries.ofPowerSeries_apply_coeff (Γ := ℤ)
+    (PowerSeries.map (Int.castRingHom K) etaProd ^ N) 1
+  rw [Nat.cast_one] at h
+  rw [h]
+  exact coeff_one_pow_of_shape _ (constantCoeff_etaProd_map K) (coeff_one_etaProd_map K) N
+
+theorem ofPowerSeries_map {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S)
+    (u : PowerSeries R) :
+    (HahnSeries.ofPowerSeries ℤ R u).map f = HahnSeries.ofPowerSeries ℤ S (PowerSeries.map f u) :=
+      by
+  ext k
+  rw [HahnSeries.map_coeff]
+  rcases le_or_gt 0 k with hk | hk
+  · lift k to ℕ using hk
+    rw [HahnSeries.ofPowerSeries_apply_coeff, HahnSeries.ofPowerSeries_apply_coeff,
+      PowerSeries.coeff_map]
+  · rw [ofPowerSeries_coeff_of_neg _ hk, ofPowerSeries_coeff_of_neg _ hk, map_zero]
+
+theorem map_intCast_pow_char_pow_eq_qExpand (K : Type*) [CommRing K] (ℓ : ℕ) [Fact ℓ.Prime]
+    [CharP K ℓ] (s : LaurentSeries ℤ) (c : ℕ) :
+    (s.map (Int.castRingHom K)) ^ (ℓ ^ c) = qExpand K (ℓ ^ c) (s.map (Int.castRingHom K)) := by
+  induction c with
+  | zero => rw [qExpand_congr (pow_zero ℓ), qExpand_one_apply, pow_zero, pow_one]
+  | succ c ih =>
+    calc (s.map (Int.castRingHom K)) ^ (ℓ ^ (c + 1))
+        = ((s.map (Int.castRingHom K)) ^ ℓ) ^ (ℓ ^ c) := by rw [← pow_mul, ← pow_succ']
+      _ = qExpand K ℓ ((s.map (Int.castRingHom K)) ^ (ℓ ^ c)) := by
+          rw [map_intCast_pow_char_eq_qExpand ℓ s, ← map_pow]
+      _ = qExpand K (ℓ ^ (c + 1)) (s.map (Int.castRingHom K)) := by
+          rw [ih, qExpand_qExpand, qExpand_congr (pow_succ' ℓ c).symm]
+
+theorem etaC_pow_char (K : Type*) [CommRing K] (ℓ : ℕ) [Fact ℓ.Prime] [CharP K ℓ] :
+    𝓔[K] ^ ℓ = qExpand K ℓ 𝓔[K] := by
+  rw [← ofPowerSeries_map]
+  exact map_intCast_pow_char_eq_qExpand ℓ _
+
+theorem etaC_pow_char_pow (K : Type*) [CommRing K] (ℓ : ℕ) [Fact ℓ.Prime] [CharP K ℓ] (c : ℕ) :
+    𝓔[K] ^ (ℓ ^ c) = qExpand K (ℓ ^ c) 𝓔[K] := by
+  rw [← ofPowerSeries_map]
+  exact map_intCast_pow_char_pow_eq_qExpand K ℓ _ c
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_single \
+  qExpand_one_apply qExpand_congr qExpand_qExpand etaProd constantCoeff_etaProd \
+  ofPowerSeries_coeff_of_neg map_intCast_pow_char_eq_qExpand"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+theorem ModularCurve.StarBank.etaProd_pow_ne (K : Type*) [CommRing K] {ℓ : ℕ} [Fact ℓ.Prime]
+    [CharP K ℓ] (p : ℕ) [NeZero p] (hp : (p : K) ≠ 0) (hp1 : p ≠ 1) (γ : K) :
+    HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ (24 * p) ≠
+      HahnSeries.C γ * qExpand K p
+        (HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) := by
+  have hℓ : ℓ.Prime := Fact.out
+  have hℓp : ¬ ℓ ∣ p := fun h => hp ((CharP.cast_eq_zero_iff K ℓ p).2 h)
+  obtain ⟨c, m, hm, h24⟩ :=
+    Nat.exists_eq_pow_mul_and_not_dvd (show (24 : ℕ) ≠ 0 by decide) ℓ hℓ.one_lt.ne'
+  intro h
+  have key : (HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^
+        (24 * p)).coeff ((ℓ ^ c : ℕ) : ℤ) =
+      (HahnSeries.C γ * qExpand K p
+        (HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24)).coeff
+          ((ℓ ^ c : ℕ) : ℤ) := by
+    rw [h]
+  have hL : (HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^
+        (24 * p)).coeff ((ℓ ^ c : ℕ) : ℤ) = -((m * p : ℕ) : K) := by
+    have e1 : HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^
+          (24 * p) =
+        qExpand K (ℓ ^ c)
+          (HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^
+            (m * p)) := by
+      rw [h24, show ℓ ^ c * m * p = ℓ ^ c * (m * p) by ring, pow_mul,
+        ModularCurve.W1.etaC_pow_char_pow K ℓ c, map_pow]
+    have e2 := qExpand_coeff_mul (R := K) (ℓ ^ c)
+      (HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ (m * p)) 1
+    rw [mul_one] at e2
+    rw [e1, e2, ModularCurve.W1.coeff_one_etaC_pow]
+  have hR : (HahnSeries.C γ * qExpand K p
+      (HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24)).coeff
+        ((ℓ ^ c : ℕ) : ℤ) = 0 := by
+    rw [HahnSeries.C_mul_eq_smul, HahnSeries.coeff_smul, qExpand_coeff_of_not_dvd, smul_zero]
+    rw [Int.natCast_dvd_natCast]
+    intro hd
+    obtain ⟨k, -, hpk⟩ := (Nat.dvd_prime_pow hℓ).1 hd
+    cases k with
+    | zero => exact hp1 (by simpa using hpk)
+    | succ k =>
+      rw [hpk] at hℓp
+      exact hℓp (dvd_pow_self ℓ (Nat.succ_ne_zero k))
+  rw [hL, hR, neg_eq_zero] at key
+  rcases (Nat.Prime.dvd_mul hℓ).1 ((CharP.cast_eq_zero_iff K ℓ (m * p)).1 key) with h1 | h2
+  · exact hm h1
+  · exact hℓp h2
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.StarBank.delta_pow_ne (K : Type*) [CommRing K] {ℓ : ℕ} [Fact ℓ.Prime]
+    [CharP K ℓ] {p : ℕ} [Fact p.Prime] (hpℓ : p ≠ ℓ) (γ : K) :
+    (HahnSeries.single (1 : ℤ) (1 : K) *
+        HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^ p ≠
+      HahnSeries.C γ * qExpand K p (HahnSeries.single (1 : ℤ) (1 : K) *
+        HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) := by
+  have hp : p.Prime := Fact.out
+  have hℓ : ℓ.Prime := Fact.out
+  have hpK : (p : K) ≠ 0 := fun h0 =>
+    hpℓ ((Nat.prime_dvd_prime_iff_eq hℓ hp).1 ((CharP.cast_eq_zero_iff K ℓ p).1 h0)).symm
+  intro h
+  apply ModularCurve.StarBank.etaProd_pow_ne K p hpK hp.ne_one γ
+  have hu : HahnSeries.single (-(p : ℤ)) (1 : K) * HahnSeries.single (p : ℤ) (1 : K) = 1 := by
+    rw [HahnSeries.single_mul_single, neg_add_cancel, mul_one, HahnSeries.single_zero_one]
+  have hsp : HahnSeries.single (1 : ℤ) (1 : K) ^ p = HahnSeries.single (p : ℤ) (1 : K) := by
+    rw [HahnSeries.single_pow, one_pow, nsmul_eq_mul, mul_one]
+  calc HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ (24 * p)
+      = HahnSeries.single (-(p : ℤ)) (1 : K) * (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^ p := by
+        rw [mul_pow, hsp, ← mul_assoc, hu, one_mul, pow_mul]
+    _ = HahnSeries.single (-(p : ℤ)) (1 : K) * (HahnSeries.C γ * qExpand K p
+          (HahnSeries.single (1 : ℤ) (1 : K) *
+            HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24)) := by
+        rw [h]
+    _ = HahnSeries.C γ * qExpand K p
+          (HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) := by
+        rw [map_mul, qExpand_single, mul_one, mul_left_comm,
+          ← mul_assoc (HahnSeries.single (-(p : ℤ)) (1 : K)), hu, one_mul]
+
+section Falsifier
+
+variable (K : Type*) [CommRing K] (ℓ : ℕ) [Fact ℓ.Prime] [CharP K ℓ]
+
+example :
+    HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ ℓ =
+      qExpand K ℓ (HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd)) :=
+  ModularCurve.W1.etaC_pow_char K ℓ
+
+example :
+    HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ (24 * ℓ) =
+      HahnSeries.C (1 : K) * qExpand K ℓ
+        (HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) := by
+  rw [HahnSeries.C_one, one_mul, mul_comm 24 ℓ, pow_mul, ModularCurve.W1.etaC_pow_char K ℓ,
+    ← map_pow]
+
+example :
+    (HahnSeries.single (1 : ℤ) (1 : K) *
+        HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^ ℓ =
+      HahnSeries.C (1 : K) * qExpand K ℓ (HahnSeries.single (1 : ℤ) (1 : K) *
+        HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) := by
+  rw [HahnSeries.C_one, one_mul, map_mul, map_pow, ← ModularCurve.W1.etaC_pow_char K ℓ,
+    qExpand_single, mul_one, mul_pow, HahnSeries.single_pow, one_pow, nsmul_eq_mul, mul_one,
+    ← pow_mul, ← pow_mul, mul_comm ℓ 24]
+
+example :
+    HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ (24 * 1) =
+      HahnSeries.C (1 : K) * qExpand K 1
+        (HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) := by
+  rw [mul_one, HahnSeries.C_one, one_mul, qExpand_one_apply]
+
+end Falsifier
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_StarBank_delta_pow_ne.ModularCurve in
+theorem solution (K : Type*) [CommRing K] {ℓ : ℕ} [Fact ℓ.Prime]
+    [CharP K ℓ] {p : ℕ} [Fact p.Prime] (hpℓ : p ≠ ℓ) (γ : K) :
+    (HahnSeries.single (1 : ℤ) (1 : K) *
+        HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^ p ≠
+      HahnSeries.C γ * qExpand K p (HahnSeries.single (1 : ℤ) (1 : K) *
+        HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) :=
+  ModularCurve.StarBank.delta_pow_ne K hpℓ γ
+
+end S_ModularCurve_StarBank_delta_pow_ne
+end P2MW
+export P2MW.S_ModularCurve_StarBank_delta_pow_ne (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.StarBank.delta_pow_ne (K : Type*) [CommRing K] {ℓ : ℕ} [Fact ℓ.Prime]
+    [CharP K ℓ] {p : ℕ} [Fact p.Prime] (hpℓ : p ≠ ℓ) (γ : K) :
+    (HahnSeries.single (1 : ℤ) (1 : K) *
+        HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^ p ≠
+      HahnSeries.C γ * qExpand K p (HahnSeries.single (1 : ℤ) (1 : K) *
+        HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) :=
+  solution K hpℓ γ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_eisInt_not_dvd_num.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_eisInt_not_dvd_num.lean
new file mode 100644
index 0000000000..d0b634cb7e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_eisInt_not_dvd_num.lean
@@ -0,0 +1,214 @@
+/-
+Based on Prove2Me node ModularCurve.StarBank.eisInt_not_dvd_num
+(49c86ba7-b6c8-5534-ad98-1771659f0c35) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9a5d7aaa-26a5-50c4-9520-094c178e9ea0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.EisensteinSeries.QExpansion
+
+import Mathlib.NumberTheory.Bernoulli
+import Mathlib.Algebra.GCDMonoid.FinsetLemmas
+import Mathlib.Data.Rat.Lemmas
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A prime ℓ ≥ 5 does not divide num(B_{ℓ-1})
+
+Theorem statement: `ModularCurve.StarBank.eisInt_not_dvd_num`
+(`49c86ba7-b6c8-5534-ad98-1771659f0c35`), by Claude, 2026-09-05.
+
+Proof: submission `9a5d7aaa-26a5-50c4-9520-094c178e9ea0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a natural number that is prime, and assume $5 \le \ell$. The assertion is that the
+integer $\ell$ does not divide the numerator of the rational number $B_{\ell-1}$, where `bernoulli`
+denotes Mathlib's Bernoulli numbers (the convention with $B_1 = 1/2$) and the numerator is the one
+of the canonical representation of a rational in lowest terms with positive denominator, so that
+$\mathrm{num}$ and $\mathrm{den}$ are coprime. The index $\ell - 1$ is truncated natural
+subtraction, which under the hypothesis $5 \le \ell$ is the ordinary $\ell - 1 \ge 4$; the
+hypothesis is what ties the index to the prime, and the statement is false for unrelated indices
+(for instance $691$ divides the numerator of $B_{12}$). Equivalently, $B_{\ell-1}$ is nonzero and,
+when written in lowest terms, has $\ell$-adic valuation exactly $-1$ for its denominator rather than
+any positive power of $\ell$ in its numerator.
+
+This is the standard consequence of the von Staudt–Clausen congruence for the particular index $\ell
+- 1$: since $(\ell-1) \mid (\ell-1)$, the prime $\ell$ enters the denominator of $B_{\ell-1}$, and
+coprimality of numerator and denominator then forbids $\ell$ from dividing the numerator. It is used
+to see that the constant term of the integral Eisenstein series of weight $\ell - 1$ is a unit
+modulo $\ell$, so that its reduction modulo $\ell$ is a nonzero constant; in this form it feeds the
+construction [`ModularCurve.StarBank.starBank`](thm.html#ModularCurve.StarBank.starBank) and the
+statements about $q$-expansion models of $j$ and of cusp forms that cite it.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_StarBank_eisInt_not_dvd_num.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_StarBank_eisInt_not_dvd_num
+
+open scoped ArithmeticFunction.sigma
+open Finset
+
+namespace ModularCurve
+namespace W1
+
+theorem eisInt_not_dvd_den_shift {ℓ : ℕ} [Fact ℓ.Prime] (hℓ5 : 5 ≤ ℓ) :
+    ¬ ℓ ∣ (bernoulli (ℓ - 1) + 1 / (ℓ : ℚ)).den := by
+  have hℓp : ℓ.Prime := Fact.out
+  obtain ⟨m, hm⟩ := hℓp.odd_of_ne_two (by omega)
+  set k₀ := (ℓ - 1) / 2 with hk₀def
+  have h2k₀ : 2 * k₀ = ℓ - 1 := by omega
+  obtain ⟨z, hz⟩ := Bernoulli.vonStaudt_clausen k₀
+  rw [h2k₀] at hz
+  have hrange : ℓ - 1 + 2 = ℓ + 1 := by omega
+  rw [hrange] at hz
+  set S := {p ∈ range (ℓ + 1) | p.Prime ∧ p - 1 ∣ ℓ - 1} with hSdef
+  have hℓS : ℓ ∈ S := by
+    simp only [hSdef, mem_filter, mem_range]
+    exact ⟨Nat.lt_succ_self ℓ, hℓp, dvd_refl _⟩
+  have hsplit := (add_sum_erase S (fun p => (1 : ℚ) / (p : ℚ)) hℓS).symm
+  rw [hsplit] at hz
+  have hz' : bernoulli (ℓ - 1) + 1 / (ℓ : ℚ)
+      = (z : ℚ) - ∑ p ∈ S.erase ℓ, (1 : ℚ) / (p : ℚ) := by
+    linarith [hz]
+  rw [hz', Rat.intCast_sub_den]
+  have hdendvd := Rat.den_sum_dvd_prod_den (S.erase ℓ) (fun p => (1 : ℚ) / (p : ℚ))
+  have hcop : (∏ p ∈ S.erase ℓ, ((1 : ℚ) / (p : ℚ)).den).Coprime ℓ := by
+    refine Nat.Coprime.prod_left fun p hp => ?_
+    have hpS : p ∈ S := Finset.mem_of_mem_erase hp
+    have hpne : p ≠ ℓ := Finset.ne_of_mem_erase hp
+    have hpp : p.Prime := (mem_filter.mp hpS).2.1
+    have : ((1 : ℚ) / (p : ℚ)).den = p := by simp [hpp.ne_zero]
+    rw [this]
+    exact (Nat.coprime_primes hpp hℓp).mpr hpne
+  intro hdvd
+  exact (Nat.Prime.coprime_iff_not_dvd hℓp).mp
+    (Nat.Coprime.of_dvd_left hdendvd hcop).symm hdvd
+
+end ModularCurve.W1
+
+theorem ModularCurve.StarBank.eisInt_dvd_den {ℓ : ℕ} [Fact ℓ.Prime] (hℓ5 : 5 ≤ ℓ) :
+    ℓ ∣ (bernoulli (ℓ - 1)).den := by
+  have hℓp : ℓ.Prime := Fact.out
+  have hshift := ModularCurve.W1.eisInt_not_dvd_den_shift hℓ5
+  have hℓden : ((1 : ℚ) / (ℓ : ℚ)).den = ℓ := by simp [hℓp.ne_zero]
+  have hdvd : ℓ ∣ (bernoulli (ℓ - 1) + 1 / (ℓ : ℚ)).den * (bernoulli (ℓ - 1)).den := by
+    have h := Rat.sub_den_dvd (bernoulli (ℓ - 1) + 1 / (ℓ : ℚ)) (bernoulli (ℓ - 1))
+    have hsimp : bernoulli (ℓ - 1) + 1 / (ℓ : ℚ) - bernoulli (ℓ - 1) = 1 / (ℓ : ℚ) := by ring
+    rw [hsimp, hℓden] at h
+    exact h
+  exact ((hℓp.dvd_mul).mp hdvd).resolve_left hshift
+
+private theorem ModularCurve.StarBank.eisInt_not_dvd_num {ℓ : ℕ} [Fact ℓ.Prime] (hℓ5 : 5 ≤ ℓ) :
+    ¬ (ℓ : ℤ) ∣ (bernoulli (ℓ - 1)).num := by
+  intro hdvd
+  have hden := ModularCurve.StarBank.eisInt_dvd_den hℓ5
+  have hnum : ℓ ∣ (bernoulli (ℓ - 1)).num.natAbs := by
+    have := Int.natAbs_dvd_natAbs.mpr hdvd
+    simpa using this
+  have hcop := (bernoulli (ℓ - 1)).reduced
+  have hgcd : ℓ ∣ Nat.gcd (bernoulli (ℓ - 1)).num.natAbs (bernoulli (ℓ - 1)).den :=
+    Nat.dvd_gcd hnum hden
+  unfold Nat.Coprime at hcop
+  rw [hcop] at hgcd
+  exact (Nat.Prime.one_lt (Fact.out : ℓ.Prime)).ne' (Nat.dvd_one.mp hgcd)
+
+theorem ModularCurve.StarBank.eisInt_bernoulli_ne_zero
+    {ℓ : ℕ} [Fact ℓ.Prime] (hℓ5 : 5 ≤ ℓ) : bernoulli (ℓ - 1) ≠ 0 := by
+  intro h
+  have := ModularCurve.StarBank.eisInt_dvd_den hℓ5
+  rw [h, Rat.den_zero] at this
+  exact (Nat.Prime.one_lt (Fact.out : ℓ.Prime)).ne' (Nat.dvd_one.mp this)
+
+theorem ModularCurve.StarBank.eisInt_coeff {ℓ : ℕ} [Fact ℓ.Prime] (hℓ5 : 5 ≤ ℓ)
+    (hk : 3 ≤ ℓ - 1) (m : ℕ) :
+    ∃ z : ℤ, ((bernoulli (ℓ - 1)).num : ℂ)
+          * (UpperHalfPlane.qExpansion 1 (ModularForm.E hk)).coeff m = ↑z
+        ∧ (m = 0 → z = (bernoulli (ℓ - 1)).num) ∧ (1 ≤ m → (ℓ : ℤ) ∣ z) := by
+  classical
+  have hℓp : ℓ.Prime := Fact.out
+  have hkeven : Even (ℓ - 1) := by
+    obtain ⟨c, hc⟩ := hℓp.odd_of_ne_two (by omega); exact ⟨c, by omega⟩
+  set B := bernoulli (ℓ - 1) with hBdef
+  have hB0 : B ≠ 0 := ModularCurve.StarBank.eisInt_bernoulli_ne_zero hℓ5
+  have hcoeff := EisensteinSeries.E_qExpansion_coeff hk hkeven m
+  rcases Nat.eq_zero_or_pos m with hm0 | hm1
+  · subst hm0
+    refine ⟨B.num, ?_, fun _ => rfl, by omega⟩
+    rw [hcoeff]; simp
+  · have hm1' : m ≠ 0 := hm1.ne'
+    rw [hcoeff, ite_eq_right hm1']
+    refine ⟨-(2 * (↑(ℓ - 1) : ℤ) * (↑B.den : ℤ) * (↑(σ (ℓ - 1 - 1) m) : ℤ)), ?_, ?_, ?_⟩
+    · have hnum : (B.num : ℂ) ≠ 0 := by
+        exact_mod_cast Rat.num_ne_zero.mpr hB0
+      have hcast : ((B : ℚ) : ℂ) = (B.num : ℂ) / (B.den : ℂ) := by
+        exact_mod_cast Rat.cast_def (K := ℂ) B
+      rw [hcast]
+      have hden0 : (B.den : ℂ) ≠ 0 := by
+        exact_mod_cast B.den_ne_zero
+      field_simp
+      push_cast
+      ring
+    · intro h; omega
+    · intro _
+      have hd : (ℓ : ℤ) ∣ (↑B.den : ℤ) :=
+        Int.natCast_dvd_natCast.mpr (ModularCurve.StarBank.eisInt_dvd_den hℓ5)
+      exact dvd_neg.mpr ((hd.mul_left _).mul_right _)
+
+private theorem ModularCurve.StarBank.eisInt_series {ℓ : ℕ} [Fact ℓ.Prime] (hℓ5 : 5 ≤ ℓ)
+    (hk : 3 ≤ ℓ - 1) :
+    ∃ T : PowerSeries ℤ,
+      T.map (Int.castRingHom ℂ)
+        = ((bernoulli (ℓ - 1)).num : ℂ) • UpperHalfPlane.qExpansion 1 (⇑(ModularForm.E hk))
+      ∧ PowerSeries.constantCoeff T = (bernoulli (ℓ - 1)).num
+      ∧ ∀ m, 1 ≤ m → (ℓ : ℤ) ∣ T.coeff m := by
+  classical
+  refine ⟨PowerSeries.mk fun m => (ModularCurve.StarBank.eisInt_coeff hℓ5 hk m).choose,
+    ?_, ?_, ?_⟩
+  · ext m
+    rw [PowerSeries.coeff_map, PowerSeries.coeff_mk, PowerSeries.coeff_smul, smul_eq_mul]
+    exact (ModularCurve.StarBank.eisInt_coeff hℓ5 hk m).choose_spec.1.symm
+  · rw [← PowerSeries.coeff_zero_eq_constantCoeff_apply, PowerSeries.coeff_mk]
+    exact (ModularCurve.StarBank.eisInt_coeff hℓ5 hk 0).choose_spec.2.1 rfl
+  · intro m hm
+    rw [PowerSeries.coeff_mk]
+    exact (ModularCurve.StarBank.eisInt_coeff hℓ5 hk m).choose_spec.2.2 hm
+
+example : ¬ (7 : ℤ) ∣ (-240 : ℤ) := by decide
+
+open scoped ArithmeticFunction.sigma
+open Finset in
+theorem solution {ℓ : ℕ} [Fact ℓ.Prime] (hℓ5 : 5 ≤ ℓ) :
+    ¬ (ℓ : ℤ) ∣ (bernoulli (ℓ - 1)).num :=
+  ModularCurve.StarBank.eisInt_not_dvd_num hℓ5
+
+end S_ModularCurve_StarBank_eisInt_not_dvd_num
+end P2MW
+export P2MW.S_ModularCurve_StarBank_eisInt_not_dvd_num (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped ArithmeticFunction.sigma
+open Finset
+theorem ModularCurve.StarBank.eisInt_not_dvd_num {ℓ : ℕ} [Fact ℓ.Prime] (hℓ5 : 5 ≤ ℓ) :
+    ¬ (ℓ : ℤ) ∣ (bernoulli (ℓ - 1)).num :=
+  solution hℓ5
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_eisInt_series.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_eisInt_series.lean
new file mode 100644
index 0000000000..892cf89bf4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_eisInt_series.lean
@@ -0,0 +1,225 @@
+/-
+Based on Prove2Me node ModularCurve.StarBank.eisInt_series
+(c94d7baa-e8cf-5c0b-a2c8-ce38cfa7f6ea) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 98120d6c-91e1-5ce5-8096-cca865364810
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.EisensteinSeries.QExpansion
+
+import Mathlib.NumberTheory.Bernoulli
+import Mathlib.Algebra.GCDMonoid.FinsetLemmas
+import Mathlib.Data.Rat.Lemmas
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integral model of num(B_{ℓ-1})E_{ℓ-1}, positive coefficients divisible by ℓ
+
+Theorem statement: `ModularCurve.StarBank.eisInt_series` (`c94d7baa-e8cf-5c0b-a2c8-ce38cfa7f6ea`),
+by Claude, 2026-09-05.
+
+Proof: submission `98120d6c-91e1-5ce5-8096-cca865364810`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a prime with $5 \le \ell$, and let $hk$ be a proof of $3 \le \ell - 1$ (natural
+subtraction), which serves as the index needed to form Mathlib's normalised level-one Eisenstein
+series `ModularForm.E hk` of weight $\ell - 1$. Write $B_{\ell-1}$ for the $(\ell-1)$-st Bernoulli
+number, a rational number, and $\mathrm{num}(B_{\ell-1})$ for its numerator in lowest terms. The
+assertion is the existence of a formal power series $T$ with integer coefficients such that: the
+image of $T$ under the coefficientwise ring homomorphism $\mathbb{Z} \to \mathbb{C}$ equals
+$\mathrm{num}(B_{\ell-1})$ times the $q$-expansion of width $1$ of the underlying function of
+`ModularForm.E hk` on the upper half-plane; the constant coefficient of $T$ is
+$\mathrm{num}(B_{\ell-1})$; and for every $m \ge 1$ the coefficient of $q^m$ in $T$ is divisible by
+$\ell$ in $\mathbb{Z}$. Note that $hk$ follows from $5 \le \ell$ but is required to name the
+Eisenstein series.
+
+This is the integral form of the congruence $E_{\ell-1} \equiv 1 \pmod \ell$ for the normalised
+weight $\ell-1$ level-one Eisenstein series, in the shape of an explicit integral power series whose
+reduction modulo $\ell$ is constant up to the unit $\mathrm{num}(B_{\ell-1})$. It feeds the
+construction of integral $q$-expansion data for level-one and level-$N$ modular forms, and is used
+in the constructions built around
+[`ModularCurve.StarBank.starBank`](thm.html#ModularCurve.StarBank.starBank) and in the integrality
+statements for the Igusa function field of $X_1$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_StarBank_eisInt_series.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_StarBank_eisInt_series
+
+open scoped ArithmeticFunction.sigma
+open Finset
+
+namespace ModularCurve
+namespace W1
+
+theorem eisInt_not_dvd_den_shift {ℓ : ℕ} [Fact ℓ.Prime] (hℓ5 : 5 ≤ ℓ) :
+    ¬ ℓ ∣ (bernoulli (ℓ - 1) + 1 / (ℓ : ℚ)).den := by
+  have hℓp : ℓ.Prime := Fact.out
+  obtain ⟨m, hm⟩ := hℓp.odd_of_ne_two (by omega)
+  set k₀ := (ℓ - 1) / 2 with hk₀def
+  have h2k₀ : 2 * k₀ = ℓ - 1 := by omega
+  obtain ⟨z, hz⟩ := Bernoulli.vonStaudt_clausen k₀
+  rw [h2k₀] at hz
+  have hrange : ℓ - 1 + 2 = ℓ + 1 := by omega
+  rw [hrange] at hz
+  set S := {p ∈ range (ℓ + 1) | p.Prime ∧ p - 1 ∣ ℓ - 1} with hSdef
+  have hℓS : ℓ ∈ S := by
+    simp only [hSdef, mem_filter, mem_range]
+    exact ⟨Nat.lt_succ_self ℓ, hℓp, dvd_refl _⟩
+  have hsplit := (add_sum_erase S (fun p => (1 : ℚ) / (p : ℚ)) hℓS).symm
+  rw [hsplit] at hz
+  have hz' : bernoulli (ℓ - 1) + 1 / (ℓ : ℚ)
+      = (z : ℚ) - ∑ p ∈ S.erase ℓ, (1 : ℚ) / (p : ℚ) := by
+    linarith [hz]
+  rw [hz', Rat.intCast_sub_den]
+  have hdendvd := Rat.den_sum_dvd_prod_den (S.erase ℓ) (fun p => (1 : ℚ) / (p : ℚ))
+  have hcop : (∏ p ∈ S.erase ℓ, ((1 : ℚ) / (p : ℚ)).den).Coprime ℓ := by
+    refine Nat.Coprime.prod_left fun p hp => ?_
+    have hpS : p ∈ S := Finset.mem_of_mem_erase hp
+    have hpne : p ≠ ℓ := Finset.ne_of_mem_erase hp
+    have hpp : p.Prime := (mem_filter.mp hpS).2.1
+    have : ((1 : ℚ) / (p : ℚ)).den = p := by simp [hpp.ne_zero]
+    rw [this]
+    exact (Nat.coprime_primes hpp hℓp).mpr hpne
+  intro hdvd
+  exact (Nat.Prime.coprime_iff_not_dvd hℓp).mp
+    (Nat.Coprime.of_dvd_left hdendvd hcop).symm hdvd
+
+end ModularCurve.W1
+
+theorem ModularCurve.StarBank.eisInt_dvd_den {ℓ : ℕ} [Fact ℓ.Prime] (hℓ5 : 5 ≤ ℓ) :
+    ℓ ∣ (bernoulli (ℓ - 1)).den := by
+  have hℓp : ℓ.Prime := Fact.out
+  have hshift := ModularCurve.W1.eisInt_not_dvd_den_shift hℓ5
+  have hℓden : ((1 : ℚ) / (ℓ : ℚ)).den = ℓ := by simp [hℓp.ne_zero]
+  have hdvd : ℓ ∣ (bernoulli (ℓ - 1) + 1 / (ℓ : ℚ)).den * (bernoulli (ℓ - 1)).den := by
+    have h := Rat.sub_den_dvd (bernoulli (ℓ - 1) + 1 / (ℓ : ℚ)) (bernoulli (ℓ - 1))
+    have hsimp : bernoulli (ℓ - 1) + 1 / (ℓ : ℚ) - bernoulli (ℓ - 1) = 1 / (ℓ : ℚ) := by ring
+    rw [hsimp, hℓden] at h
+    exact h
+  exact ((hℓp.dvd_mul).mp hdvd).resolve_left hshift
+
+private theorem ModularCurve.StarBank.eisInt_not_dvd_num {ℓ : ℕ} [Fact ℓ.Prime] (hℓ5 : 5 ≤ ℓ) :
+    ¬ (ℓ : ℤ) ∣ (bernoulli (ℓ - 1)).num := by
+  intro hdvd
+  have hden := ModularCurve.StarBank.eisInt_dvd_den hℓ5
+  have hnum : ℓ ∣ (bernoulli (ℓ - 1)).num.natAbs := by
+    have := Int.natAbs_dvd_natAbs.mpr hdvd
+    simpa using this
+  have hcop := (bernoulli (ℓ - 1)).reduced
+  have hgcd : ℓ ∣ Nat.gcd (bernoulli (ℓ - 1)).num.natAbs (bernoulli (ℓ - 1)).den :=
+    Nat.dvd_gcd hnum hden
+  unfold Nat.Coprime at hcop
+  rw [hcop] at hgcd
+  exact (Nat.Prime.one_lt (Fact.out : ℓ.Prime)).ne' (Nat.dvd_one.mp hgcd)
+
+theorem ModularCurve.StarBank.eisInt_bernoulli_ne_zero
+    {ℓ : ℕ} [Fact ℓ.Prime] (hℓ5 : 5 ≤ ℓ) : bernoulli (ℓ - 1) ≠ 0 := by
+  intro h
+  have := ModularCurve.StarBank.eisInt_dvd_den hℓ5
+  rw [h, Rat.den_zero] at this
+  exact (Nat.Prime.one_lt (Fact.out : ℓ.Prime)).ne' (Nat.dvd_one.mp this)
+
+theorem ModularCurve.StarBank.eisInt_coeff {ℓ : ℕ} [Fact ℓ.Prime] (hℓ5 : 5 ≤ ℓ)
+    (hk : 3 ≤ ℓ - 1) (m : ℕ) :
+    ∃ z : ℤ, ((bernoulli (ℓ - 1)).num : ℂ)
+          * (UpperHalfPlane.qExpansion 1 (ModularForm.E hk)).coeff m = ↑z
+        ∧ (m = 0 → z = (bernoulli (ℓ - 1)).num) ∧ (1 ≤ m → (ℓ : ℤ) ∣ z) := by
+  classical
+  have hℓp : ℓ.Prime := Fact.out
+  have hkeven : Even (ℓ - 1) := by
+    obtain ⟨c, hc⟩ := hℓp.odd_of_ne_two (by omega); exact ⟨c, by omega⟩
+  set B := bernoulli (ℓ - 1) with hBdef
+  have hB0 : B ≠ 0 := ModularCurve.StarBank.eisInt_bernoulli_ne_zero hℓ5
+  have hcoeff := EisensteinSeries.E_qExpansion_coeff hk hkeven m
+  rcases Nat.eq_zero_or_pos m with hm0 | hm1
+  · subst hm0
+    refine ⟨B.num, ?_, fun _ => rfl, by omega⟩
+    rw [hcoeff]; simp
+  · have hm1' : m ≠ 0 := hm1.ne'
+    rw [hcoeff, ite_eq_right hm1']
+    refine ⟨-(2 * (↑(ℓ - 1) : ℤ) * (↑B.den : ℤ) * (↑(σ (ℓ - 1 - 1) m) : ℤ)), ?_, ?_, ?_⟩
+    · have hnum : (B.num : ℂ) ≠ 0 := by
+        exact_mod_cast Rat.num_ne_zero.mpr hB0
+      have hcast : ((B : ℚ) : ℂ) = (B.num : ℂ) / (B.den : ℂ) := by
+        exact_mod_cast Rat.cast_def (K := ℂ) B
+      rw [hcast]
+      have hden0 : (B.den : ℂ) ≠ 0 := by
+        exact_mod_cast B.den_ne_zero
+      field_simp
+      push_cast
+      ring
+    · intro h; omega
+    · intro _
+      have hd : (ℓ : ℤ) ∣ (↑B.den : ℤ) :=
+        Int.natCast_dvd_natCast.mpr (ModularCurve.StarBank.eisInt_dvd_den hℓ5)
+      exact dvd_neg.mpr ((hd.mul_left _).mul_right _)
+
+private theorem ModularCurve.StarBank.eisInt_series {ℓ : ℕ} [Fact ℓ.Prime] (hℓ5 : 5 ≤ ℓ)
+    (hk : 3 ≤ ℓ - 1) :
+    ∃ T : PowerSeries ℤ,
+      T.map (Int.castRingHom ℂ)
+        = ((bernoulli (ℓ - 1)).num : ℂ) • UpperHalfPlane.qExpansion 1 (⇑(ModularForm.E hk))
+      ∧ PowerSeries.constantCoeff T = (bernoulli (ℓ - 1)).num
+      ∧ ∀ m, 1 ≤ m → (ℓ : ℤ) ∣ T.coeff m := by
+  classical
+  refine ⟨PowerSeries.mk fun m => (ModularCurve.StarBank.eisInt_coeff hℓ5 hk m).choose,
+    ?_, ?_, ?_⟩
+  · ext m
+    rw [PowerSeries.coeff_map, PowerSeries.coeff_mk, PowerSeries.coeff_smul, smul_eq_mul]
+    exact (ModularCurve.StarBank.eisInt_coeff hℓ5 hk m).choose_spec.1.symm
+  · rw [← PowerSeries.coeff_zero_eq_constantCoeff_apply, PowerSeries.coeff_mk]
+    exact (ModularCurve.StarBank.eisInt_coeff hℓ5 hk 0).choose_spec.2.1 rfl
+  · intro m hm
+    rw [PowerSeries.coeff_mk]
+    exact (ModularCurve.StarBank.eisInt_coeff hℓ5 hk m).choose_spec.2.2 hm
+
+example : ¬ (7 : ℤ) ∣ (-240 : ℤ) := by decide
+
+open scoped ArithmeticFunction.sigma
+open Finset in
+theorem solution {ℓ : ℕ} [Fact ℓ.Prime] (hℓ5 : 5 ≤ ℓ)
+    (hk : 3 ≤ ℓ - 1) :
+    ∃ T : PowerSeries ℤ,
+      T.map (Int.castRingHom ℂ)
+        = ((bernoulli (ℓ - 1)).num : ℂ) • UpperHalfPlane.qExpansion 1 (⇑(ModularForm.E hk))
+      ∧ PowerSeries.constantCoeff T = (bernoulli (ℓ - 1)).num
+      ∧ ∀ m, 1 ≤ m → (ℓ : ℤ) ∣ T.coeff m :=
+  ModularCurve.StarBank.eisInt_series hℓ5 hk
+
+end S_ModularCurve_StarBank_eisInt_series
+end P2MW
+export P2MW.S_ModularCurve_StarBank_eisInt_series (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped ArithmeticFunction.sigma
+open Finset
+theorem ModularCurve.StarBank.eisInt_series {ℓ : ℕ} [Fact ℓ.Prime] (hℓ5 : 5 ≤ ℓ)
+    (hk : 3 ≤ ℓ - 1) :
+    ∃ T : PowerSeries ℤ,
+      T.map (Int.castRingHom ℂ)
+        = ((bernoulli (ℓ - 1)).num : ℂ) • UpperHalfPlane.qExpansion 1 (⇑(ModularForm.E hk))
+      ∧ PowerSeries.constantCoeff T = (bernoulli (ℓ - 1)).num
+      ∧ ∀ m, 1 ≤ m → (ℓ : ℤ) ∣ T.coeff m :=
+  solution hℓ5 hk
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_hassePolyDescent.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_hassePolyDescent.lean
new file mode 100644
index 0000000000..18cd8d7180
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_hassePolyDescent.lean
@@ -0,0 +1,489 @@
+/-
+Based on Prove2Me node ModularCurve.StarBank.hassePolyDescent
+(37f6ded8-5704-5737-8913-1fdf1ea40a52) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9ec71275-03fa-5858-a5b5-6f3a44cce468
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import Mathlib.NumberTheory.ModularForms.LevelOne.DimensionFormula
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_qExpansion_eq_aeval_mul_pow_levelOne
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant
+import Mathlib.Algebra.Polynomial.Lifts
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integral descent: T = G(j) Δ^N with deg G = N
+
+Theorem statement: `ModularCurve.StarBank.hassePolyDescent`
+(`37f6ded8-5704-5737-8913-1fdf1ea40a52`), by Claude, 2026-09-05.
+
+Proof: submission `9ec71275-03fa-5858-a5b5-6f3a44cce468`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number and let $F$ be a modular form of weight $12N$ for the full modular
+group. Suppose $T$ is a power series with integer coefficients whose image under the coefficientwise
+map $\mathbb{Z}\to\mathbb{C}$ is the $q$-expansion of $F$ of width $1$, and suppose the constant
+coefficient of $T$ is non-zero. Then there exists a polynomial $G$ with integer coefficients such
+that: the degree of $G$ is exactly $N$; the coefficient of $X^N$ in $G$ is the constant coefficient
+of $T$; and, in the field of Laurent series over $\mathbb{Z}$, the image of $T$ equals $G$ evaluated
+at [`ModularCurve.jqModC ℤ`](def/ModularCurve_JqCoeff.html#L15) multiplied by the $N$-th power of
+$q\cdot\big(\prod_{n\ge 1}(1-q^{n})\big)^{24}$, that is, of the Laurent series $\Delta$ obtained
+from `HahnSeries.single (1 : ℤ) 1` times the twenty-fourth power of the formal product
+[`ModularCurve.etaProd`](def/ModularCurve_X0.html#L119) $=\prod_{n\ge 1}(1-X^{n})$. Here
+[`ModularCurve.jqModC ℤ`](def/ModularCurve_JqCoeff.html#L15) is the integral Laurent-series model of
+$j$, defined as $q^{-1}$ times the power series [`ModularCurve.jNum`](def/ModularCurve_X0.html#L142)
+$=$ `eisenstein4`$^3\cdot$`dedekindEtaUnitInv` (coefficients transported along
+$\mathbb{Z}\to\mathbb{Z}$). So $T = G(j)\,\Delta^{N}$ with $\deg G = N$ and leading coefficient the
+constant term of $T$.
+
+This is the integral refinement, with exact degree and leading coefficient, of the classical fact
+that a level-one form of weight $12N$ is a polynomial of degree at most $N$ in $j$ times
+$\Delta^{N}$; the hypothesis that the constant term be non-zero is what forces the degree to be
+exactly $N$. It is used in the construction of modular units on $X_0(N)$, in particular by
+[`ModularCurve.StarBank.starBank`](thm.html#ModularCurve.StarBank.starBank) and by
+[`ModularCurve.exists_natDegree_eq_sub_one_and_modularUnit_intCast_eq_aeval_jqModC_of_charP`]
+(thm.html#ModularCurve.
+exists_natDegree_eq_sub_one_and_modularUnit_intCast_eq_aeval_jqModC_of_charP),
+and rests on the corresponding statement over $\mathbb{C}$ together with the identifications of the
+$q$-expansions of $\Delta$ and of $E_4^3/\Delta$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_StarBank_hassePolyDescent.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_StarBank_hassePolyDescent
+
+p2m_open "Polynomial HahnSeries ModularCurve \
+  P2MW.S_ModularCurve_StarBank_hassePolyDescent.ModularCurve UpperHalfPlane"
+open scoped MatrixGroups
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC etaProd dedekindEtaUnit constantCoeff_dedekindEtaUnit jNum \
+  constantCoeff_jNum ofPowerSeries_coeff_of_neg jq_pow \
+  qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit \
+  jqModC_eq_qExpansion_E4_cube_div_discriminant"
+namespace W1
+p2m_open "ModularCurve"
+
+theorem powerSeries_map_intCast_self (u : PowerSeries ℤ) : u.map (Int.castRingHom ℤ) = u := by
+  rw [RingHom.ext_int (Int.castRingHom ℤ) (RingHom.id ℤ)]
+  exact congrFun PowerSeries.map_id u
+
+theorem jqModC_pow_eq (K : Type*) [CommRing K] (a : ℕ) :
+    jqModC K ^ a
+      = HahnSeries.single (-(a : ℤ)) 1
+        * HahnSeries.ofPowerSeries ℤ K (jNum.map (Int.castRingHom K) ^ a) := by
+  have h : a • (-1 : ℤ) = -(a : ℤ) := by simp
+  rw [jqModC, mul_pow, HahnSeries.single_pow, one_pow, h, ← map_pow]
+
+theorem jqModC_pow_mul_etaBlock (K : Type*) [CommRing K] (a N : ℕ) :
+    jqModC K ^ a
+        * (HahnSeries.single (1 : ℤ) 1
+            * HahnSeries.ofPowerSeries ℤ K (dedekindEtaUnit.map (Int.castRingHom K))) ^ N
+      = HahnSeries.single ((N : ℤ) - a) 1
+        * HahnSeries.ofPowerSeries ℤ K
+            (jNum.map (Int.castRingHom K) ^ a * dedekindEtaUnit.map (Int.castRingHom K) ^ N) := by
+  have h1 : N • (1 : ℤ) = (N : ℤ) := by simp
+  rw [jqModC_pow_eq, mul_pow, HahnSeries.single_pow, one_pow, h1,
+    show (HahnSeries.ofPowerSeries ℤ K (dedekindEtaUnit.map (Int.castRingHom K))) ^ N
+        = HahnSeries.ofPowerSeries ℤ K (dedekindEtaUnit.map (Int.castRingHom K) ^ N) from
+      (map_pow _ _ _).symm,
+    mul_mul_mul_comm, HahnSeries.single_mul_single, one_mul,
+    show HahnSeries.ofPowerSeries ℤ K (jNum.map (Int.castRingHom K) ^ a)
+          * HahnSeries.ofPowerSeries ℤ K (dedekindEtaUnit.map (Int.castRingHom K) ^ N)
+        = HahnSeries.ofPowerSeries ℤ K (jNum.map (Int.castRingHom K) ^ a
+            * dedekindEtaUnit.map (Int.castRingHom K) ^ N) from (map_mul _ _ _).symm,
+    show (-(a : ℤ) + (N : ℤ)) = (N : ℤ) - a from by ring]
+
+theorem coeff_single_mul_ofPowerSeries_nonneg {K : Type*} [Semiring K] (c : ℤ)
+    (U : PowerSeries K) (n : ℕ) :
+    (HahnSeries.single c (1 : K) * HahnSeries.ofPowerSeries ℤ K U).coeff (c + (n : ℤ))
+      = PowerSeries.coeff n U := by
+  rw [HahnSeries.coeff_single_mul, one_mul, add_sub_cancel_left]
+  exact HahnSeries.ofPowerSeries_apply_coeff U n
+
+theorem coeff_single_mul_ofPowerSeries_neg {K : Type*} [Semiring K] (c : ℤ)
+    (U : PowerSeries K) {g : ℤ} (hg : g < c) :
+    (HahnSeries.single c (1 : K) * HahnSeries.ofPowerSeries ℤ K U).coeff g = 0 := by
+  rw [HahnSeries.coeff_single_mul, one_mul,
+    ModularCurve.ofPowerSeries_coeff_of_neg _ (show g - c < 0 by omega)]
+
+theorem coeff_ofPowerSeries_map (U : PowerSeries ℤ) (g : ℤ) :
+    (HahnSeries.ofPowerSeries ℤ ℂ (U.map (Int.castRingHom ℂ))).coeff g
+      = (((HahnSeries.ofPowerSeries ℤ ℤ U).coeff g : ℤ) : ℂ) := by
+  rcases le_or_gt 0 g with hg | hg
+  · lift g to ℕ using hg
+    rw [HahnSeries.ofPowerSeries_apply_coeff, HahnSeries.ofPowerSeries_apply_coeff,
+      PowerSeries.coeff_map, Int.coe_castRingHom]
+  · rw [ModularCurve.ofPowerSeries_coeff_of_neg _ hg,
+      ModularCurve.ofPowerSeries_coeff_of_neg _ hg, Int.cast_zero]
+
+theorem algebraMap_laurent_eq_single (K : Type*) [CommRing K] (c : K) :
+    algebraMap K (LaurentSeries K) c = HahnSeries.single (0 : ℤ) c := by
+  have h1 : algebraMap K (PowerSeries K) c = PowerSeries.C c := by simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+  rfl
+
+theorem coeff_single_zero_mul {K : Type*} [Ring K] (c : K) (y : LaurentSeries K) (g : ℤ) :
+    (HahnSeries.single (0 : ℤ) c * y).coeff g = c * y.coeff g := by
+  rw [HahnSeries.coeff_single_mul, sub_zero]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC etaProd dedekindEtaUnit constantCoeff_dedekindEtaUnit jNum \
+  constantCoeff_jNum ofPowerSeries_coeff_of_neg jq_pow \
+  qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit \
+  jqModC_eq_qExpansion_E4_cube_div_discriminant"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.StarBank.hassePolyDescent {N : ℕ}
+    (F : ModularForm 𝒮ℒ (12 * (N : ℤ))) {T : PowerSeries ℤ}
+    (hT : T.map (Int.castRingHom ℂ) = UpperHalfPlane.qExpansion 1 ⇑F)
+    (h0 : PowerSeries.constantCoeff T ≠ 0) :
+    ∃ G : Polynomial ℤ, G.natDegree = N ∧ G.coeff N = PowerSeries.constantCoeff T ∧
+      HahnSeries.ofPowerSeries ℤ ℤ T
+        = Polynomial.aeval (ModularCurve.jqModC ℤ) G
+          * (HahnSeries.single (1 : ℤ) 1
+              * HahnSeries.ofPowerSeries ℤ ℤ ModularCurve.etaProd ^ 24) ^ N := by
+  obtain ⟨P, hPdeg, hPid⟩ := ModularForm.exists_qExpansion_eq_aeval_mul_pow_levelOne N F
+  rw [← ModularCurve.jqModC_eq_qExpansion_E4_cube_div_discriminant, ← hT,
+    ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit] at hPid
+  have hXded : HahnSeries.ofPowerSeries ℤ ℂ
+      ((PowerSeries.X * ModularCurve.dedekindEtaUnit).map (Int.castRingHom ℂ))
+      = HahnSeries.single (1 : ℤ) 1
+        * HahnSeries.ofPowerSeries ℤ ℂ (dedekindEtaUnit.map (Int.castRingHom ℂ)) := by
+    rw [map_mul, PowerSeries.map_X, map_mul, HahnSeries.ofPowerSeries_X]
+  rw [hXded] at hPid
+  have hCa : ∀ a : ℕ, (jNum ^ a * dedekindEtaUnit ^ N).map (Int.castRingHom ℂ)
+      = jNum.map (Int.castRingHom ℂ) ^ a * dedekindEtaUnit.map (Int.castRingHom ℂ) ^ N := by
+    intro a
+    rw [map_mul, map_pow, map_pow]
+  have hsum : Polynomial.aeval (jqModC ℂ) P
+      * (HahnSeries.single (1 : ℤ) 1
+          * HahnSeries.ofPowerSeries ℤ ℂ (dedekindEtaUnit.map (Int.castRingHom ℂ))) ^ N
+      = ∑ a ∈ Finset.range (N + 1),
+          HahnSeries.single (0 : ℤ) (P.coeff a)
+            * (HahnSeries.single ((N : ℤ) - a) 1
+                * HahnSeries.ofPowerSeries ℤ ℂ
+                    ((jNum ^ a * dedekindEtaUnit ^ N).map (Int.castRingHom ℂ))) := by
+    rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum,
+      Polynomial.sum_over_range' P (fun n => by rw [map_zero, zero_mul]) (N + 1)
+        (Nat.lt_succ_of_le hPdeg), Finset.sum_mul]
+    refine Finset.sum_congr rfl fun a _ => ?_
+    rw [mul_assoc, ModularCurve.W1.algebraMap_laurent_eq_single,
+      ModularCurve.W1.jqModC_pow_mul_etaBlock ℂ a N, ← hCa a]
+  rw [hsum] at hPid
+  have hkey : ∀ i : ℕ, i ≤ N →
+      ((PowerSeries.coeff (N - i) T : ℤ) : ℂ)
+        = ∑ a ∈ Finset.range (N + 1), P.coeff a *
+            (if i ≤ a
+              then ((PowerSeries.coeff (a - i) (jNum ^ a * dedekindEtaUnit ^ N) : ℤ) : ℂ)
+              else 0) := by
+    intro i hi
+    have h1 := congrArg (fun x : LaurentSeries ℂ => x.coeff ((N : ℤ) - i)) hPid
+    have hL : (HahnSeries.ofPowerSeries ℤ ℂ (T.map (Int.castRingHom ℂ))).coeff ((N : ℤ) - i)
+        = ((PowerSeries.coeff (N - i) T : ℤ) : ℂ) := by
+      rw [show ((N : ℤ) - i) = ((N - i : ℕ) : ℤ) from by omega,
+        HahnSeries.ofPowerSeries_apply_coeff, PowerSeries.coeff_map, Int.coe_castRingHom]
+    have hR : (∑ a ∈ Finset.range (N + 1),
+          HahnSeries.single (0 : ℤ) (P.coeff a)
+            * (HahnSeries.single ((N : ℤ) - a) 1
+                * HahnSeries.ofPowerSeries ℤ ℂ
+                    ((jNum ^ a * dedekindEtaUnit ^ N).map (Int.castRingHom ℂ)))).coeff
+            ((N : ℤ) - i)
+        = ∑ a ∈ Finset.range (N + 1), P.coeff a *
+            (if i ≤ a
+              then ((PowerSeries.coeff (a - i) (jNum ^ a * dedekindEtaUnit ^ N) : ℤ) : ℂ)
+              else 0) := by
+      rw [HahnSeries.coeff_sum]
+      refine Finset.sum_congr rfl fun a _ => ?_
+      rw [ModularCurve.W1.coeff_single_zero_mul]
+      congr 1
+      by_cases hia : i ≤ a
+      · rw [ite_eq_left hia, show ((N : ℤ) - i) = ((N : ℤ) - a) + ((a - i : ℕ) : ℤ) from by omega,
+          ModularCurve.W1.coeff_single_mul_ofPowerSeries_nonneg, PowerSeries.coeff_map,
+          Int.coe_castRingHom]
+      · rw [ite_eq_right hia]
+        exact ModularCurve.W1.coeff_single_mul_ofPowerSeries_neg _ _ (by omega)
+    rw [hL, hR] at h1
+    exact h1
+  have hdiag : ∀ i : ℕ, PowerSeries.coeff 0 (jNum ^ i * dedekindEtaUnit ^ N) = 1 := by
+    intro i
+    have h1 : PowerSeries.constantCoeff (jNum ^ i * dedekindEtaUnit ^ N) = 1 := by
+      rw [map_mul, map_pow, map_pow, ModularCurve.constantCoeff_jNum,
+        ModularCurve.constantCoeff_dedekindEtaUnit, one_pow, one_pow, one_mul]
+    rw [← h1]
+    exact congrFun PowerSeries.coeff_zero_eq_constantCoeff _
+  have hPN : P.coeff N = ((PowerSeries.constantCoeff T : ℤ) : ℂ) := by
+    have hk := hkey N le_rfl
+    have hdiagN : (if N ≤ N
+        then ((PowerSeries.coeff (N - N) (jNum ^ N * dedekindEtaUnit ^ N) : ℤ) : ℂ)
+        else 0) = 1 := by
+      rw [ite_eq_left le_rfl, Nat.sub_self, hdiag N, Int.cast_one]
+    rw [Finset.sum_eq_single_of_mem N (Finset.mem_range.mpr (Nat.lt_succ_self N))
+      (fun a ha hne => by
+        rw [ite_eq_right (show ¬N ≤ a from by
+          have := Finset.mem_range.mp ha
+          omega), mul_zero]), hdiagN, mul_one, Nat.sub_self] at hk
+    rw [← hk]
+    congr 1
+    exact congrFun PowerSeries.coeff_zero_eq_constantCoeff T
+  have hstep : ∀ i : ℕ, i ≤ N →
+      (∀ a : ℕ, a ≤ N → i < a → P.coeff a ∈ Set.range ⇑(Int.castRingHom ℂ)) →
+      P.coeff i ∈ Set.range ⇑(Int.castRingHom ℂ) := by
+    intro i hi hIH
+    have hk := hkey i hi
+    have hmem : i ∈ Finset.range (N + 1) := Finset.mem_range.mpr (by omega)
+    have hdiagterm : (if i ≤ i
+        then ((PowerSeries.coeff (i - i) (jNum ^ i * dedekindEtaUnit ^ N) : ℤ) : ℂ)
+        else 0) = 1 := by
+      rw [ite_eq_left le_rfl, Nat.sub_self, hdiag i, Int.cast_one]
+    rw [← Finset.add_sum_erase _ _ hmem, hdiagterm, mul_one] at hk
+    have hPi : P.coeff i
+        = ((PowerSeries.coeff (N - i) T : ℤ) : ℂ)
+          - ∑ a ∈ (Finset.range (N + 1)).erase i, P.coeff a *
+              (if i ≤ a
+                then ((PowerSeries.coeff (a - i) (jNum ^ a * dedekindEtaUnit ^ N) : ℤ) : ℂ)
+                else 0) := by
+      rw [hk]
+      ring
+    rw [hPi]
+    have hSmem : (∑ a ∈ (Finset.range (N + 1)).erase i, P.coeff a *
+        (if i ≤ a
+          then ((PowerSeries.coeff (a - i) (jNum ^ a * dedekindEtaUnit ^ N) : ℤ) : ℂ)
+          else 0)) ∈ (Int.castRingHom ℂ).range := by
+      refine Subring.sum_mem _ fun a ha => ?_
+      by_cases hia : i ≤ a
+      · have haN : a ≤ N := by
+          have := Finset.mem_range.mp (Finset.mem_of_mem_erase ha)
+          omega
+        have hlt : i < a := lt_of_le_of_ne hia (Ne.symm (Finset.ne_of_mem_erase ha))
+        obtain ⟨z, hz⟩ := hIH a haN hlt
+        rw [ite_eq_left hia, ← hz]
+        refine Subring.mul_mem _ (RingHom.mem_range.mpr ⟨z, rfl⟩)
+          (RingHom.mem_range.mpr
+            ⟨PowerSeries.coeff (a - i) (jNum ^ a * dedekindEtaUnit ^ N),
+              by rw [Int.coe_castRingHom]⟩)
+      · rw [ite_eq_right hia, mul_zero]
+        exact Subring.zero_mem _
+    obtain ⟨zS, hzS⟩ := RingHom.mem_range.mp hSmem
+    exact ⟨PowerSeries.coeff (N - i) T - zS, by rw [map_sub, hzS, Int.coe_castRingHom]⟩
+  have hmemP : ∀ i : ℕ, i ≤ N → P.coeff i ∈ Set.range ⇑(Int.castRingHom ℂ) := by
+    have H : ∀ j : ℕ, ∀ i : ℕ, i ≤ N → N - i ≤ j →
+        P.coeff i ∈ Set.range ⇑(Int.castRingHom ℂ) := by
+      intro j
+      induction j with
+      | zero =>
+        intro i hi hj
+        exact hstep i hi fun a ha hia => absurd hia (by omega)
+      | succ j IH =>
+        intro i hi hj
+        exact hstep i hi fun a ha hia => IH a ha (by omega)
+    exact fun i hi => H N i hi (by omega)
+  have hlifts : P ∈ Polynomial.lifts (Int.castRingHom ℂ) := by
+    rw [Polynomial.lifts_iff_coeff_lifts]
+    intro n
+    rcases (show n ≤ N ∨ N < n from by omega) with hn | hn
+    · exact hmemP n hn
+    · rw [Polynomial.coeff_eq_zero_of_natDegree_lt (lt_of_le_of_lt hPdeg hn)]
+      exact ⟨0, map_zero _⟩
+  obtain ⟨G, hG⟩ := (Polynomial.mem_lifts P).mp hlifts
+  have hGcoeff : ∀ n : ℕ, ((G.coeff n : ℤ) : ℂ) = P.coeff n := by
+    intro n
+    rw [← hG, Polynomial.coeff_map, Int.coe_castRingHom]
+  have hGN : G.coeff N = PowerSeries.constantCoeff T := by
+    apply Int.cast_injective (α := ℂ)
+    rw [hGcoeff N, hPN]
+  have hGdeg : G.natDegree = N := by
+    refine le_antisymm (Polynomial.natDegree_le_iff_coeff_eq_zero.mpr fun m hm => ?_)
+      (Polynomial.le_natDegree_of_ne_zero ?_)
+    · apply Int.cast_injective (α := ℂ)
+      rw [hGcoeff m, Int.cast_zero]
+      exact Polynomial.coeff_eq_zero_of_natDegree_lt (lt_of_le_of_lt hPdeg hm)
+    · rw [hGN]
+      exact h0
+  refine ⟨G, hGdeg, hGN, ?_⟩
+  have hblock : HahnSeries.single (1 : ℤ) (1 : ℤ)
+      * HahnSeries.ofPowerSeries ℤ ℤ ModularCurve.etaProd ^ 24
+      = HahnSeries.single (1 : ℤ) 1
+        * HahnSeries.ofPowerSeries ℤ ℤ (dedekindEtaUnit.map (Int.castRingHom ℤ)) := by
+    rw [← map_pow, ← dedekindEtaUnit, ModularCurve.W1.powerSeries_map_intCast_self]
+  have hZsum : Polynomial.aeval (jqModC ℤ) G
+      * (HahnSeries.single (1 : ℤ) 1
+          * HahnSeries.ofPowerSeries ℤ ℤ ModularCurve.etaProd ^ 24) ^ N
+      = ∑ a ∈ Finset.range (N + 1),
+          HahnSeries.single (0 : ℤ) (G.coeff a)
+            * (HahnSeries.single ((N : ℤ) - a) 1
+                * HahnSeries.ofPowerSeries ℤ ℤ (jNum ^ a * dedekindEtaUnit ^ N)) := by
+    rw [hblock, Polynomial.aeval_def, Polynomial.eval₂_eq_sum,
+      Polynomial.sum_over_range' G (fun n => by rw [map_zero, zero_mul]) (N + 1)
+        (show G.natDegree < N + 1 by omega), Finset.sum_mul]
+    refine Finset.sum_congr rfl fun a _ => ?_
+    rw [mul_assoc, ModularCurve.W1.algebraMap_laurent_eq_single,
+      ModularCurve.W1.jqModC_pow_mul_etaBlock ℤ a N,
+      ModularCurve.W1.powerSeries_map_intCast_self jNum,
+      ModularCurve.W1.powerSeries_map_intCast_self dedekindEtaUnit]
+  rw [hZsum]
+  ext g
+  have hfinal : (((HahnSeries.ofPowerSeries ℤ ℤ T).coeff g : ℤ) : ℂ)
+      = (((∑ a ∈ Finset.range (N + 1),
+          HahnSeries.single (0 : ℤ) (G.coeff a)
+            * (HahnSeries.single ((N : ℤ) - a) 1
+                * HahnSeries.ofPowerSeries ℤ ℤ (jNum ^ a * dedekindEtaUnit ^ N))).coeff g
+          : ℤ) : ℂ) :=
+    calc (((HahnSeries.ofPowerSeries ℤ ℤ T).coeff g : ℤ) : ℂ)
+      = (HahnSeries.ofPowerSeries ℤ ℂ (T.map (Int.castRingHom ℂ))).coeff g :=
+        (ModularCurve.W1.coeff_ofPowerSeries_map T g).symm
+    _ = (∑ a ∈ Finset.range (N + 1),
+          HahnSeries.single (0 : ℤ) (P.coeff a)
+            * (HahnSeries.single ((N : ℤ) - a) 1
+                * HahnSeries.ofPowerSeries ℤ ℂ
+                    ((jNum ^ a * dedekindEtaUnit ^ N).map (Int.castRingHom ℂ)))).coeff g := by
+        rw [hPid]
+    _ = ∑ a ∈ Finset.range (N + 1),
+          (((HahnSeries.single (0 : ℤ) (G.coeff a)
+              * (HahnSeries.single ((N : ℤ) - a) 1
+                  * HahnSeries.ofPowerSeries ℤ ℤ (jNum ^ a * dedekindEtaUnit ^ N))).coeff g
+            : ℤ) : ℂ) := by
+        rw [HahnSeries.coeff_sum]
+        refine Finset.sum_congr rfl fun a _ => ?_
+        rw [ModularCurve.W1.coeff_single_zero_mul, ModularCurve.W1.coeff_single_zero_mul,
+          Int.cast_mul, ← hGcoeff a]
+        congr 1
+        rw [HahnSeries.coeff_single_mul, HahnSeries.coeff_single_mul, one_mul, one_mul]
+        exact ModularCurve.W1.coeff_ofPowerSeries_map _ _
+    _ = (((∑ a ∈ Finset.range (N + 1),
+          HahnSeries.single (0 : ℤ) (G.coeff a)
+            * (HahnSeries.single ((N : ℤ) - a) 1
+                * HahnSeries.ofPowerSeries ℤ ℤ (jNum ^ a * dedekindEtaUnit ^ N))).coeff g
+          : ℤ) : ℂ) := by
+        rw [HahnSeries.coeff_sum]
+        exact (map_sum (Int.castRingHom ℂ) _ _).symm
+  exact_mod_cast hfinal
+
+example : (PowerSeries.X * ModularCurve.dedekindEtaUnit).map (Int.castRingHom ℂ)
+    = UpperHalfPlane.qExpansion 1 ModularForm.discriminant :=
+  ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit.symm
+
+example : PowerSeries.constantCoeff (PowerSeries.X * ModularCurve.dedekindEtaUnit) = (0 : ℤ) := by
+  simp
+
+example : ¬ ∃ G : Polynomial ℤ, G.natDegree = 1 ∧
+    HahnSeries.ofPowerSeries ℤ ℤ (PowerSeries.X * ModularCurve.dedekindEtaUnit)
+      = Polynomial.aeval (ModularCurve.jqModC ℤ) G
+        * (HahnSeries.single (1 : ℤ) 1
+            * HahnSeries.ofPowerSeries ℤ ℤ ModularCurve.etaProd ^ 24) ^ 1 := by
+  rintro ⟨G, hdeg, hid⟩
+  have hblock : HahnSeries.single (1 : ℤ) (1 : ℤ)
+      * HahnSeries.ofPowerSeries ℤ ℤ ModularCurve.etaProd ^ 24
+      = HahnSeries.single (1 : ℤ) 1
+        * HahnSeries.ofPowerSeries ℤ ℤ (dedekindEtaUnit.map (Int.castRingHom ℤ)) := by
+    rw [← map_pow, ← dedekindEtaUnit, ModularCurve.W1.powerSeries_map_intCast_self]
+  have hsum1 : Polynomial.aeval (ModularCurve.jqModC ℤ) G
+      * (HahnSeries.single (1 : ℤ) 1
+          * HahnSeries.ofPowerSeries ℤ ℤ ModularCurve.etaProd ^ 24) ^ 1
+      = ∑ a ∈ Finset.range (1 + 1),
+          HahnSeries.single (0 : ℤ) (G.coeff a)
+            * (jqModC ℤ ^ a
+                * (HahnSeries.single (1 : ℤ) 1
+                    * HahnSeries.ofPowerSeries ℤ ℤ
+                        (dedekindEtaUnit.map (Int.castRingHom ℤ))) ^ 1) := by
+    rw [hblock, Polynomial.aeval_def, Polynomial.eval₂_eq_sum,
+      Polynomial.sum_over_range' G (fun n => by rw [map_zero, zero_mul]) (1 + 1)
+        (show G.natDegree < 1 + 1 by omega), Finset.sum_mul]
+    refine Finset.sum_congr rfl fun a _ => ?_
+    rw [mul_assoc, ModularCurve.W1.algebraMap_laurent_eq_single]
+  rw [hsum1] at hid
+  have hterm0 : (jqModC ℤ ^ 0
+      * (HahnSeries.single (1 : ℤ) 1
+          * HahnSeries.ofPowerSeries ℤ ℤ
+              (dedekindEtaUnit.map (Int.castRingHom ℤ))) ^ 1).coeff (0 : ℤ) = 0 := by
+    rw [ModularCurve.W1.jqModC_pow_mul_etaBlock ℤ 0 1]
+    exact ModularCurve.W1.coeff_single_mul_ofPowerSeries_neg _ _ (by omega)
+  have hterm1 : (jqModC ℤ ^ 1
+      * (HahnSeries.single (1 : ℤ) 1
+          * HahnSeries.ofPowerSeries ℤ ℤ
+              (dedekindEtaUnit.map (Int.castRingHom ℤ))) ^ 1).coeff (0 : ℤ) = 1 := by
+    rw [ModularCurve.W1.jqModC_pow_mul_etaBlock ℤ 1 1,
+      show ((0 : ℤ)) = (((1 : ℕ) : ℤ) - ((1 : ℕ) : ℤ)) + ((0 : ℕ) : ℤ) from by omega,
+      ModularCurve.W1.coeff_single_mul_ofPowerSeries_nonneg,
+      ModularCurve.W1.powerSeries_map_intCast_self,
+      ModularCurve.W1.powerSeries_map_intCast_self, pow_one, pow_one]
+    have h1 : PowerSeries.constantCoeff (jNum * dedekindEtaUnit) = 1 := by
+      rw [map_mul, ModularCurve.constantCoeff_jNum,
+        ModularCurve.constantCoeff_dedekindEtaUnit, one_mul]
+    rw [← h1]
+    exact congrFun PowerSeries.coeff_zero_eq_constantCoeff _
+  have hL0 : (HahnSeries.ofPowerSeries ℤ ℤ
+      (PowerSeries.X * ModularCurve.dedekindEtaUnit)).coeff (0 : ℤ) = 0 := by
+    rw [show ((0 : ℤ)) = (((0 : ℕ) : ℤ)) from rfl, HahnSeries.ofPowerSeries_apply_coeff,
+      congrFun PowerSeries.coeff_zero_eq_constantCoeff
+        (PowerSeries.X * ModularCurve.dedekindEtaUnit)]
+    simp
+  have hid0 := congrArg (fun x : LaurentSeries ℤ => x.coeff (0 : ℤ)) hid
+  rw [hL0, HahnSeries.coeff_sum, Finset.sum_range_succ, Finset.sum_range_one,
+    ModularCurve.W1.coeff_single_zero_mul, ModularCurve.W1.coeff_single_zero_mul,
+    hterm0, hterm1, mul_zero, mul_one, zero_add] at hid0
+  have hGne : G ≠ 0 := fun h => by
+    rw [h, Polynomial.natDegree_zero] at hdeg
+    exact absurd hdeg (by norm_num)
+  have hlead : G.leadingCoeff = 0 := by
+    rw [Polynomial.leadingCoeff, hdeg]
+    exact hid0.symm
+  exact hGne (Polynomial.leadingCoeff_eq_zero.mp hlead)
+
+p2m_open "Polynomial HahnSeries ModularCurve \
+  P2MW.S_ModularCurve_StarBank_hassePolyDescent.ModularCurve UpperHalfPlane"
+open scoped MatrixGroups in
+theorem solution {N : ℕ}
+    (F : ModularForm 𝒮ℒ (12 * (N : ℤ))) {T : PowerSeries ℤ}
+    (hT : T.map (Int.castRingHom ℂ) = UpperHalfPlane.qExpansion 1 ⇑F)
+    (h0 : PowerSeries.constantCoeff T ≠ 0) :
+    ∃ G : Polynomial ℤ, G.natDegree = N ∧ G.coeff N = PowerSeries.constantCoeff T ∧
+      HahnSeries.ofPowerSeries ℤ ℤ T
+        = Polynomial.aeval (ModularCurve.jqModC ℤ) G
+          * (HahnSeries.single (1 : ℤ) 1
+              * HahnSeries.ofPowerSeries ℤ ℤ ModularCurve.etaProd ^ 24) ^ N :=
+  ModularCurve.StarBank.hassePolyDescent F hT h0
+
+end S_ModularCurve_StarBank_hassePolyDescent
+end P2MW
+export P2MW.S_ModularCurve_StarBank_hassePolyDescent (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Polynomial HahnSeries ModularCurve UpperHalfPlane
+open scoped MatrixGroups
+theorem ModularCurve.StarBank.hassePolyDescent {N : ℕ}
+    (F : ModularForm 𝒮ℒ (12 * (N : ℤ))) {T : PowerSeries ℤ}
+    (hT : T.map (Int.castRingHom ℂ) = UpperHalfPlane.qExpansion 1 ⇑F)
+    (h0 : PowerSeries.constantCoeff T ≠ 0) :
+    ∃ G : Polynomial ℤ, G.natDegree = N ∧ G.coeff N = PowerSeries.constantCoeff T ∧
+      HahnSeries.ofPowerSeries ℤ ℤ T
+        = Polynomial.aeval (ModularCurve.jqModC ℤ) G
+          * (HahnSeries.single (1 : ℤ) 1
+              * HahnSeries.ofPowerSeries ℤ ℤ ModularCurve.etaProd ^ 24) ^ N :=
+  solution F hT h0
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_onePoint.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_onePoint.lean
new file mode 100644
index 0000000000..08f9664683
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_onePoint.lean
@@ -0,0 +1,288 @@
+/-
+Based on Prove2Me node ModularCurve.StarBank.onePoint
+(31c10fd7-bb04-514e-81dd-cdd1e203001b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 37dafe0c-19e2-599a-a26c-776a82bc6f25
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import Mathlib.Data.ZMod.Basic
+import Mathlib.Data.Nat.Choose.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# One-point case: (j-β₀)Δ is a nonzero constant
+
+Theorem statement: `ModularCurve.StarBank.onePoint` (`31c10fd7-bb04-514e-81dd-cdd1e203001b`), by
+Claude, 2026-09-05.
+
+Proof: submission `37dafe0c-19e2-599a-a26c-776a82bc6f25`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, $M$ a natural number whose image in $K$ is nonzero, and let $c, \beta_0 \in K$
+with $c \neq 0$. Work in the Laurent series field $K((q))$ (Hahn series over $\mathbb{Z}$ with
+values in $K$), and write $j$ for [`ModularCurve.jqModC K`](def/ModularCurve_JqCoeff.html#L15),
+namely $q^{-1}$ times the image in $K$ of the integral power series `jNum` $=$ `eisenstein4`$^3
+\cdot$ `dedekindEtaUnitInv`, and $\Delta$ for the element $q \cdot \bigl(\prod_{n \ge 1}(1 -
+q^{n})\bigr)^{24}$, obtained from the integral power series `etaProd` $= \prod_{n \ge 0}(1 -
+X^{n+1})$ by reducing its coefficients into $K$, raising to the $24$th power and multiplying by $q$.
+Assume that evaluating the polynomial $c\,(X - \beta_0)^M$ at $j$ and multiplying by $\Delta^M$
+gives $1$, i.e. $c\,(j - \beta_0)^M \Delta^M = 1$ in $K((q))$. Then there exists $\gamma \in K$,
+$\gamma \neq 0$, such that $(j - \beta_0)\,\Delta$ equals the constant Laurent series $\gamma$.
+
+This is the extraction of an $M$-th root in $K((q))$ in the degenerate case where the polynomial
+relation $G(j)\Delta^M = 1$ involves a single $j$-value $\beta_0$: invertibility of $M$ in $K$
+forces the $M$-th root $(j-\beta_0)\Delta$ of the constant $c^{-1}$ to be itself constant. It is
+used by [`ModularCurve.StarBank.starBank`](thm.html#ModularCurve.StarBank.starBank) in the analysis
+of $q$-expansion relations on the modular curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_StarBank_onePoint.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_StarBank_onePoint
+
+p2m_open "Polynomial HahnSeries ModularCurve P2MW.S_ModularCurve_StarBank_onePoint.ModularCurve"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC etaProd"
+namespace W1
+p2m_open "ModularCurve"
+
+section OnePointKit
+
+variable {K : Type*} [Field K]
+
+theorem algebraMap_laurent_eq_single (K' : Type*) [CommRing K'] (c : K') :
+    algebraMap K' (LaurentSeries K') c = HahnSeries.single (0 : ℤ) c := by
+  have h1 : algebraMap K' (PowerSeries K') c = PowerSeries.C c := by simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+  rfl
+
+theorem leadingCoeff_laurent_pow (x : LaurentSeries K) (n : ℕ) :
+    (x ^ n).leadingCoeff = x.leadingCoeff ^ n := by
+  induction n with
+  | zero =>
+    rw [pow_zero, pow_zero, HahnSeries.leadingCoeff_eq, HahnSeries.order_one,
+      ← HahnSeries.single_zero_one, HahnSeries.coeff_single, ite_eq_left rfl]
+  | succ n ih =>
+    rw [pow_succ, pow_succ, HahnSeries.leadingCoeff_mul, ih]
+
+theorem order_laurent_pow {x : LaurentSeries K} (hx : x ≠ 0) (n : ℕ) :
+    (x ^ n).order = n • x.order := by
+  induction n with
+  | zero =>
+    rw [pow_zero, zero_smul, HahnSeries.order_one]
+  | succ n ih =>
+    have hlc : (x ^ n).leadingCoeff * x.leadingCoeff ≠ 0 := by
+      rw [leadingCoeff_laurent_pow]
+      exact mul_ne_zero (pow_ne_zero _ (HahnSeries.leadingCoeff_ne_zero.mpr hx))
+        (HahnSeries.leadingCoeff_ne_zero.mpr hx)
+    rw [pow_succ, HahnSeries.order_mul_of_ne_zero hlc, ih, succ_nsmul]
+
+theorem coeff_C_mul (c : K) (y : LaurentSeries K) (g : ℤ) :
+    (HahnSeries.C c * y).coeff g = c * y.coeff g := by
+  rw [show (HahnSeries.C c : LaurentSeries K) = HahnSeries.single 0 c from rfl,
+    HahnSeries.coeff_single_mul, sub_zero]
+
+theorem coeff_C_of_ne (c : K) {g : ℤ} (hg : g ≠ 0) :
+    (HahnSeries.C c : LaurentSeries K).coeff g = 0 := by
+  rw [show (HahnSeries.C c : LaurentSeries K) = HahnSeries.single 0 c from rfl,
+    HahnSeries.coeff_single, ite_eq_right hg]
+
+theorem eq_C_of_pow_eq_C {x : LaurentSeries K} {γ₀ : K} {M : ℕ}
+    (hM : (M : K) ≠ 0) (hγ₀ : γ₀ ≠ 0) (hx : x ^ M = HahnSeries.C γ₀) :
+    ∃ γ : K, γ ≠ 0 ∧ x = HahnSeries.C γ := by
+  have hM0 : M ≠ 0 := fun h => hM (by rw [h, Nat.cast_zero])
+  have hx0 : x ≠ 0 := by
+    intro h0
+    rw [h0, zero_pow hM0] at hx
+    apply hγ₀
+    have h1 := congrArg (fun z : LaurentSeries K => z.coeff 0) hx.symm
+    rw [show (HahnSeries.C γ₀ : LaurentSeries K) = HahnSeries.single 0 γ₀ from rfl,
+      HahnSeries.coeff_single, ite_eq_left rfl] at h1
+    exact h1.trans rfl
+  have horder : x.order = 0 := by
+    have h2 := order_laurent_pow hx0 M
+    rw [hx, HahnSeries.order_C] at h2
+    have h3 : (M : ℤ) * x.order = 0 := by rw [← nsmul_eq_mul]; exact h2.symm
+    rcases mul_eq_zero.mp h3 with h4 | h4
+    · exact absurd h4 (Int.natCast_ne_zero.mpr hM0)
+    · exact h4
+  set γ : K := x.coeff 0 with hγdef
+  have hγ : γ ≠ 0 := by
+    rw [hγdef, ← horder]
+    exact fun h => hx0 (HahnSeries.coeff_order_eq_zero.mp h)
+  refine ⟨γ, hγ, ?_⟩
+  by_contra hne
+  have hy0 : x - HahnSeries.C γ ≠ 0 := fun h => hne (by rwa [sub_eq_zero] at h)
+  set y : LaurentSeries K := x - HahnSeries.C γ with hydef
+  set r : ℤ := y.order with hrdef
+  have hyr : y.coeff r ≠ 0 := fun h => hy0 (HahnSeries.coeff_order_eq_zero.mp h)
+  have hylow : ∀ k : ℤ, k ≤ 0 → y.coeff k = 0 := by
+    intro k hk
+    rcases lt_or_eq_of_le hk with hk0 | hk0
+    · rw [hydef, HahnSeries.coeff_sub,
+        HahnSeries.coeff_eq_zero_of_lt_order (by rw [horder]; exact hk0),
+        coeff_C_of_ne γ (ne_of_lt hk0), sub_zero]
+    · rw [hydef, HahnSeries.coeff_sub, hk0,
+        show (HahnSeries.C γ : LaurentSeries K) = HahnSeries.single 0 γ from rfl,
+        HahnSeries.coeff_single, ite_eq_left rfl, ← hγdef, sub_self]
+  have hr1 : 1 ≤ r := by
+    by_contra hr0
+    exact hyr (hylow r (by omega))
+  have hrne : r ≠ 0 := by omega
+  have hxsplit : x = HahnSeries.C γ + y := by rw [hydef]; ring
+  have hch : M.choose (M - 1) = M := by
+    have h3 := Nat.choose_symm (show M - 1 ≤ M by omega)
+    rw [show M - (M - 1) = 1 from by omega] at h3
+    rw [← h3, Nat.choose_one_right]
+  have hcoeffM : (x ^ M).coeff r = γ ^ (M - 1) * (M : K) * y.coeff r := by
+    rw [hxsplit, add_pow, HahnSeries.coeff_sum]
+    rw [Finset.sum_eq_single_of_mem (M - 1) (Finset.mem_range.mpr (by omega))
+      (fun b hb hbne => ?_)]
+    · have h1 : M - (M - 1) = 1 := by omega
+      have hC : (HahnSeries.C γ : LaurentSeries K) ^ (M - 1) * y ^ (M - (M - 1))
+            * ((M.choose (M - 1) : ℕ) : LaurentSeries K)
+          = HahnSeries.C (γ ^ (M - 1) * (M : K)) * y := by
+        rw [h1, pow_one, hch, ← map_pow, ← map_natCast (HahnSeries.C (Γ := ℤ) (R := K)) M,
+          mul_right_comm, ← map_mul]
+      rw [hC, coeff_C_mul]
+    · have hbM : b ≤ M := by
+        have := Finset.mem_range.mp hb
+        omega
+      rcases eq_or_ne b M with hbeq | hbM'
+      · subst hbeq
+        rw [Nat.sub_self, pow_zero, mul_one, Nat.choose_self, Nat.cast_one, mul_one,
+          ← map_pow, coeff_C_of_ne _ hrne]
+      · have hb2 : 2 ≤ M - b := by omega
+        have hCb : (HahnSeries.C γ : LaurentSeries K) ^ b * y ^ (M - b)
+              * ((M.choose b : ℕ) : LaurentSeries K)
+            = HahnSeries.C (γ ^ b * (M.choose b : K)) * y ^ (M - b) := by
+          rw [← map_pow, ← map_natCast (HahnSeries.C (Γ := ℤ) (R := K)) (M.choose b),
+            mul_right_comm, ← map_mul]
+        have hyb : (y ^ (M - b)).coeff r = 0 := by
+          apply HahnSeries.coeff_eq_zero_of_lt_order
+          rw [order_laurent_pow hy0, nsmul_eq_mul]
+          have h2b : (2 : ℤ) ≤ ((M - b : ℕ) : ℤ) := by exact_mod_cast hb2
+          nlinarith
+        rw [hCb, coeff_C_mul, hyb, mul_zero]
+  rw [hx] at hcoeffM
+  rw [coeff_C_of_ne _ hrne] at hcoeffM
+  exact absurd hcoeffM.symm
+    (mul_ne_zero (mul_ne_zero (pow_ne_zero _ hγ) hM) hyr)
+
+end OnePointKit
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC etaProd"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.StarBank.onePoint {K : Type*} [Field K] {M : ℕ}
+    (hM : (M : K) ≠ 0) {c : K} (hc : c ≠ 0) {β₀ : K}
+    (hstar : Polynomial.aeval (ModularCurve.jqModC K)
+          (Polynomial.C c * (Polynomial.X - Polynomial.C β₀) ^ M)
+        * (HahnSeries.single (1 : ℤ) 1
+            * HahnSeries.ofPowerSeries ℤ K
+                (PowerSeries.map (Int.castRingHom K) ModularCurve.etaProd) ^ 24) ^ M
+        = 1) :
+    ∃ γ : K, γ ≠ 0 ∧
+      (ModularCurve.jqModC K - HahnSeries.C β₀)
+        * (HahnSeries.single (1 : ℤ) 1
+            * HahnSeries.ofPowerSeries ℤ K
+                (PowerSeries.map (Int.castRingHom K) ModularCurve.etaProd) ^ 24)
+        = HahnSeries.C γ := by
+  set D : LaurentSeries K := HahnSeries.single (1 : ℤ) 1
+    * HahnSeries.ofPowerSeries ℤ K
+        (PowerSeries.map (Int.castRingHom K) ModularCurve.etaProd) ^ 24 with hD
+  have haeval : Polynomial.aeval (jqModC K) (Polynomial.C c * (Polynomial.X - Polynomial.C β₀) ^ M)
+      = HahnSeries.C c * (jqModC K - HahnSeries.C β₀) ^ M := by
+    rw [map_mul, map_pow, map_sub, Polynomial.aeval_X, Polynomial.aeval_C, Polynomial.aeval_C,
+      ModularCurve.W1.algebraMap_laurent_eq_single K c,
+      ModularCurve.W1.algebraMap_laurent_eq_single K β₀]
+    rfl
+  rw [haeval] at hstar
+  have hgroup : HahnSeries.C c * ((jqModC K - HahnSeries.C β₀) * D) ^ M = 1 := by
+    rw [mul_pow, ← mul_assoc]
+    exact hstar
+  have hpow : ((jqModC K - HahnSeries.C β₀) * D) ^ M = HahnSeries.C c⁻¹ := by
+    have h2 := congrArg (fun z : LaurentSeries K => HahnSeries.C c⁻¹ * z) hgroup
+    rw [← mul_assoc, ← map_mul, inv_mul_cancel₀ hc, map_one, one_mul, mul_one] at h2
+    exact h2
+  obtain ⟨γ, hγ, hxC⟩ := ModularCurve.W1.eq_C_of_pow_eq_C hM (inv_ne_zero hc) hpow
+  exact ⟨γ, hγ, hxC⟩
+
+example : (((1 : LaurentSeries (ZMod 2)) + HahnSeries.single (1 : ℤ) 1) ^ 2).coeff 1 = 0 := by
+  rw [add_sq, one_pow, mul_one, HahnSeries.coeff_add, HahnSeries.coeff_add,
+    HahnSeries.single_pow, two_mul, HahnSeries.coeff_add,
+    ← HahnSeries.single_zero_one, HahnSeries.coeff_single, HahnSeries.coeff_single,
+    HahnSeries.coeff_single]
+  norm_num
+  decide
+
+example : (((1 : LaurentSeries (ZMod 2)) + HahnSeries.single (1 : ℤ) 1) - 1).coeff 1 ≠ 0 := by
+  rw [add_sub_cancel_left, HahnSeries.coeff_single, ite_eq_left rfl]
+  decide
+
+open Polynomial HahnSeries _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_StarBank_onePoint.ModularCurve in
+theorem solution {K : Type*} [Field K] {M : ℕ}
+    (hM : (M : K) ≠ 0) {c : K} (hc : c ≠ 0) {β₀ : K}
+    (hstar : Polynomial.aeval (ModularCurve.jqModC K)
+          (Polynomial.C c * (Polynomial.X - Polynomial.C β₀) ^ M)
+        * (HahnSeries.single (1 : ℤ) 1
+            * HahnSeries.ofPowerSeries ℤ K
+                (PowerSeries.map (Int.castRingHom K) ModularCurve.etaProd) ^ 24) ^ M
+        = 1) :
+    ∃ γ : K, γ ≠ 0 ∧
+      (ModularCurve.jqModC K - HahnSeries.C β₀)
+        * (HahnSeries.single (1 : ℤ) 1
+            * HahnSeries.ofPowerSeries ℤ K
+                (PowerSeries.map (Int.castRingHom K) ModularCurve.etaProd) ^ 24)
+        = HahnSeries.C γ :=
+  ModularCurve.StarBank.onePoint hM hc hstar
+
+end S_ModularCurve_StarBank_onePoint
+end P2MW
+export P2MW.S_ModularCurve_StarBank_onePoint (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Polynomial HahnSeries ModularCurve
+theorem ModularCurve.StarBank.onePoint {K : Type*} [Field K] {M : ℕ}
+    (hM : (M : K) ≠ 0) {c : K} (hc : c ≠ 0) {β₀ : K}
+    (hstar : Polynomial.aeval (ModularCurve.jqModC K)
+          (Polynomial.C c * (Polynomial.X - Polynomial.C β₀) ^ M)
+        * (HahnSeries.single (1 : ℤ) 1
+            * HahnSeries.ofPowerSeries ℤ K
+                (PowerSeries.map (Int.castRingHom K) ModularCurve.etaProd) ^ 24) ^ M
+        = 1) :
+    ∃ γ : K, γ ≠ 0 ∧
+      (ModularCurve.jqModC K - HahnSeries.C β₀)
+        * (HahnSeries.single (1 : ℤ) 1
+            * HahnSeries.ofPowerSeries ℤ K
+                (PowerSeries.map (Int.castRingHom K) ModularCurve.etaProd) ^ 24)
+        = HahnSeries.C γ :=
+  solution hM hc hstar
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_press.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_press.lean
new file mode 100644
index 0000000000..5ee914b2a7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_press.lean
@@ -0,0 +1,285 @@
+/-
+Based on Prove2Me node ModularCurve.StarBank.press
+(f155204d-9081-5d43-beed-383c2e0ac1f8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 51efb82f-e553-5a34-8565-694a5883938a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_neg_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_pow_self
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_pow_of_lt
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Monicity and splitting of a polynomial relation R(j(q))=j(qᵖ)
+
+Theorem statement: `ModularCurve.StarBank.press` (`f155204d-9081-5d43-beed-383c2e0ac1f8`), by
+Claude, 2026-09-05.
+
+Proof: submission `51efb82f-e553-5a34-8565-694a5883938a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, $p$ a prime, and $\zeta$ a unit of $K$ whose image in $K$ is a primitive $p$-th
+root of unity. Write $j(q) :=$ `jqModC K` for the Laurent series
+$q^{-1}\cdot\iota(E_4^3\,\eta^{-1}\text{-unit})$ over $K$, i.e. the formal power series `jNum` $=$
+`eisenstein4`$^3\cdot$`dedekindEtaUnitInv` with its integer coefficients pushed into $K$, shifted by
+the monomial $q^{-1}$; and write $j(q^p) :=$ `jqNModC K p` for its image under `qExpand K p`, the
+ring endomorphism of $K((q))$ that multiplies all exponents by $p$ (substitution $q \mapsto q^p$).
+Let $R \in K[X]$ be a polynomial with $R(j(q)) = j(q^p)$ in $K((q))$. Then $R$ is monic, its natural
+degree is exactly $p$, and in $K((q))[X]$ one has the identity
+$$R^{K((q))}(X) - j(q^p) \;=\; \prod_{b=0}^{p-1}\bigl(X - \mathrm{qTwist}(\zeta^b)\,j(q)\bigr),$$
+where $R^{K((q))}$ is $R$ with coefficients mapped along $K \to K((q))$, the subtracted term is the
+constant polynomial with value $j(q^p)$, and `qTwist` $(\zeta^b)$ is the ring endomorphism of
+$K((q))$ multiplying the coefficient of $q^k$ by $\zeta^{bk}$, i.e. the substitution $q \mapsto
+\zeta^b q$ applied to $j(q)$.
+
+This is the formal $q$-expansion form of the classical observation that a hypothetical polynomial
+relation $j(q^p) = R(j(q))$ forces $R$ to be monic of degree $p$ with $R(X) - j(q^p)$ split by the
+$p$ twists $j(\zeta^b q)$, the twists fixing $j(q^p)$ and being pairwise distinct precisely because
+$\zeta$ has exact order $p$. It is used by
+[`ModularCurve.StarBank.starBank`](thm.html#ModularCurve.StarBank.starBank), in the course of ruling
+out such a relation and hence establishing the relevant non-integrality/degree statement for the
+modular correspondence.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_StarBank_press.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_StarBank_press
+
+noncomputable section
+
+p2m_open "HahnSeries PowerSeries ModularCurve P2MW.S_ModularCurve_StarBank_press.ModularCurve"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qTwist qTwist_coeff qTwist_single qTwist_one_apply qTwist_qExpand \
+  qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd algebraMap_laurentSeries_eq_single jqModC \
+  jqNModC coeff_jqModC_neg_one coeff_jqModC_pow_self coeff_jqModC_pow_of_lt"
+namespace W1
+p2m_open "ModularCurve"
+
+variable {K : Type*} [Field K]
+
+private theorem coeff_algebraMap_mul (c : K) (x : LaurentSeries K) (k : ℤ) :
+    (algebraMap K (LaurentSeries K) c * x).coeff k = c * x.coeff k := by
+  rw [algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_zero_mul]
+
+theorem coeff_aeval_jqModC_of_lt (P : Polynomial K) {m : ℤ} (hm : m < -(P.natDegree : ℤ)) :
+    (Polynomial.aeval (jqModC K) P).coeff m = 0 := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum]
+  refine Finset.sum_eq_zero fun i hi => ?_
+  have hi' : i ≤ P.natDegree := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)
+  rw [coeff_algebraMap_mul, ModularCurve.coeff_jqModC_pow_of_lt K (b := i) (m := m) (by omega),
+    mul_zero]
+
+theorem coeff_aeval_jqModC_neg_natDegree (P : Polynomial K) :
+    (Polynomial.aeval (jqModC K) P).coeff (-(P.natDegree : ℤ)) = P.coeff P.natDegree := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+    Finset.sum_eq_single P.natDegree]
+  · rw [coeff_algebraMap_mul, ModularCurve.coeff_jqModC_pow_self K P.natDegree, mul_one]
+  · intro i hi hin
+    have hilt : i < P.natDegree := lt_of_le_of_ne (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hin
+    rw [coeff_algebraMap_mul,
+      ModularCurve.coeff_jqModC_pow_of_lt K (b := i) (m := -(P.natDegree : ℤ)) (by omega),
+      mul_zero]
+  · intro hn
+    exact absurd (Finset.self_mem_range_succ P.natDegree) hn
+
+variable (p : ℕ) [hp : Fact (Nat.Prime p)]
+
+theorem coeff_jqNModC_self : (jqNModC K p).coeff (-(p : ℤ)) = 1 := by
+  have h : ((p : ℤ) * (-1) : ℤ) = -(p : ℤ) := by ring
+  rw [jqNModC, ← h, qExpand_coeff_mul, ModularCurve.coeff_jqModC_neg_one]
+
+theorem coeff_jqNModC_of_lt {m : ℤ} (hm : m < -(p : ℤ)) : (jqNModC K p).coeff m = 0 := by
+  by_cases hd : (p : ℤ) ∣ m
+  · obtain ⟨n, rfl⟩ := hd
+    rw [jqNModC, qExpand_coeff_mul]
+    have hn : n < -1 := by
+      have hp0 : (0 : ℤ) < (p : ℤ) := by exact_mod_cast hp.out.pos
+      nlinarith
+    have h := ModularCurve.coeff_jqModC_pow_of_lt K (b := 1) (m := n) (by simpa using hn)
+    simpa using h
+  · exact qExpand_coeff_of_not_dvd (R := K) (N := p) _ hd
+
+variable {p} {R : Polynomial K}
+
+theorem ne_zero_of_aeval_eq (h : Polynomial.aeval (jqModC K) R = jqNModC K p) : R ≠ 0 := by
+  rintro rfl
+  rw [map_zero] at h
+  have h1 := coeff_jqNModC_self (K := K) p
+  rw [← h, HahnSeries.coeff_zero] at h1
+  exact zero_ne_one h1
+
+theorem natDegree_eq_of_aeval_eq (h : Polynomial.aeval (jqModC K) R = jqNModC K p) :
+    R.natDegree = p := by
+  have hR0 : R ≠ 0 := ne_zero_of_aeval_eq h
+  by_contra hne
+  rcases lt_or_gt_of_ne hne with hlt | hgt
+  · have h1 : (Polynomial.aeval (jqModC K) R).coeff (-(p : ℤ)) = 0 :=
+      coeff_aeval_jqModC_of_lt R (by omega)
+    rw [h, coeff_jqNModC_self] at h1
+    exact one_ne_zero h1
+  · have h1 := coeff_aeval_jqModC_neg_natDegree R
+    rw [h, coeff_jqNModC_of_lt p (m := -(R.natDegree : ℤ)) (by omega)] at h1
+    exact hR0 (Polynomial.leadingCoeff_eq_zero.mp h1.symm)
+
+theorem monic_of_aeval_eq (h : Polynomial.aeval (jqModC K) R = jqNModC K p) : R.Monic := by
+  have hd := natDegree_eq_of_aeval_eq h
+  have h1 := coeff_aeval_jqModC_neg_natDegree R
+  rw [h, hd, coeff_jqNModC_self] at h1
+  change R.coeff R.natDegree = 1
+  rw [hd]; exact h1.symm
+
+theorem qTwist_qExpand_of_pow_eq_one (A : ℕ) [NeZero A] (v : Kˣ) (hv : v ^ A = 1)
+    (x : LaurentSeries K) : qTwist v (qExpand K A x) = qExpand K A x := by
+  rw [qTwist_qExpand]
+  have : v ^ (A : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+theorem units_pow_eq_one_of_isPrimitiveRoot {N : ℕ} {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N) :
+    ζ ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one])
+
+theorem qTwist_algebraMap (v : Kˣ) (c : K) :
+    qTwist v (algebraMap K (LaurentSeries K) c) = algebraMap K (LaurentSeries K) c := by
+  rw [algebraMap_laurentSeries_eq_single, qTwist_single, zpow_zero, Units.val_one, one_mul]
+
+theorem qTwist_comp_algebraMap (v : Kˣ) :
+    (qTwist v).comp (algebraMap K (LaurentSeries K)) = algebraMap K (LaurentSeries K) :=
+  RingHom.ext fun c => qTwist_algebraMap v c
+
+variable {ζ : Kˣ}
+
+theorem aeval_qTwist_jqModC_eq_of_aeval_eq (hζ : IsPrimitiveRoot (ζ : K) p)
+    (h : Polynomial.aeval (jqModC K) R = jqNModC K p) (b : ℕ) :
+    Polynomial.aeval (qTwist (ζ ^ b) (jqModC K)) R = jqNModC K p := by
+  have hζp : ζ ^ p = 1 := units_pow_eq_one_of_isPrimitiveRoot hζ
+  have hvb : (ζ ^ b) ^ p = 1 := by rw [← pow_mul, Nat.mul_comm, pow_mul, hζp, one_pow]
+  have h2 := congrArg (qTwist (ζ ^ b)) h
+  rw [Polynomial.aeval_def, Polynomial.hom_eval₂, qTwist_comp_algebraMap, jqNModC,
+    qTwist_qExpand_of_pow_eq_one p (ζ ^ b) hvb] at h2
+  rw [Polynomial.aeval_def]
+  exact h2
+
+omit hp in
+theorem qTwist_pow_jqModC_injective (hζ : IsPrimitiveRoot (ζ : K) p) :
+    Function.Injective (fun b : Fin p => qTwist (ζ ^ (b : ℕ)) (jqModC K)) := by
+  intro b b' h
+  have hcoeff : ∀ v : Kˣ, (qTwist v (jqModC K)).coeff (-1 : ℤ) = ((v⁻¹ : Kˣ) : K) := by
+    intro v
+    rw [qTwist_coeff, ModularCurve.coeff_jqModC_neg_one, mul_one, zpow_neg_one]
+  have h1 := congrArg (fun x => x.coeff (-1 : ℤ)) h
+  simp only [hcoeff] at h1
+  have h2 : ζ ^ (b : ℕ) = ζ ^ (b' : ℕ) := inv_injective (Units.val_injective h1)
+  have h3 : ((ζ : Kˣ) : K) ^ (b : ℕ) = ((ζ : Kˣ) : K) ^ (b' : ℕ) := by
+    rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h2]
+  exact Fin.ext (hζ.pow_inj b.isLt b'.isLt h3)
+
+end ModularCurve.W1
+
+open ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qTwist qTwist_coeff qTwist_single qTwist_one_apply qTwist_qExpand \
+  qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd algebraMap_laurentSeries_eq_single jqModC \
+  jqNModC coeff_jqModC_neg_one coeff_jqModC_pow_self coeff_jqModC_pow_of_lt"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.StarBank.press {K : Type*} [Field K] (p : ℕ) [Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) {R : Polynomial K}
+    (hR : Polynomial.aeval (jqModC K) R = jqNModC K p) :
+    R.Monic ∧ R.natDegree = p ∧
+      R.map (algebraMap K (LaurentSeries K)) - Polynomial.C (jqNModC K p) =
+        ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (qTwist (ζ ^ b) (jqModC K))) := by
+  have hp : Fact p.Prime := inferInstance
+  refine ⟨monic_of_aeval_eq hR, natDegree_eq_of_aeval_eq hR, ?_⟩
+  set A : Polynomial (LaurentSeries K) := R.map (algebraMap K (LaurentSeries K)) with hA
+  set B : Polynomial (LaurentSeries K) :=
+    ∏ b : Fin p, (Polynomial.X - Polynomial.C (qTwist (ζ ^ (b : ℕ)) (jqModC K))) with hB
+  have hAmonic : A.Monic := (monic_of_aeval_eq hR).map _
+  have hAdeg : A.natDegree = p := by
+    rw [hA, (monic_of_aeval_eq hR).natDegree_map, natDegree_eq_of_aeval_eq hR]
+  have hBmonic : B.Monic :=
+    Polynomial.monic_prod_of_monic _ _ fun i _ => Polynomial.monic_X_sub_C _
+  have hBdeg : B.natDegree = p := by
+    rw [hB, Polynomial.natDegree_prod_of_monic _ _ fun i _ => Polynomial.monic_X_sub_C _]
+    simp
+  have key : A - B = Polynomial.C (jqNModC K p) := by
+    refine Polynomial.eq_of_natDegree_lt_card_of_eval_eq _ _
+      (qTwist_pow_jqModC_injective hζ) (fun b => ?_) ?_
+    · have hAev : A.eval (qTwist (ζ ^ (b : ℕ)) (jqModC K)) = jqNModC K p := by
+        rw [hA, Polynomial.eval_map_algebraMap]
+        exact aeval_qTwist_jqModC_eq_of_aeval_eq hζ hR b
+      have hBev : B.eval (qTwist (ζ ^ (b : ℕ)) (jqModC K)) = 0 := by
+        rw [hB, Polynomial.eval_prod]
+        exact Finset.prod_eq_zero (Finset.mem_univ b) (by simp)
+      simp only [Polynomial.eval_sub, Polynomial.eval_C, hAev, hBev, sub_zero]
+    · rw [Fintype.card_fin]
+      refine max_lt ?_ (by rw [Polynomial.natDegree_C]; exact hp.out.pos)
+      by_cases hAB : A = B
+      · rw [hAB, sub_self, Polynomial.natDegree_zero]; exact hp.out.pos
+      · refine lt_of_lt_of_eq (Polynomial.natDegree_lt_natDegree (sub_ne_zero.mpr hAB) ?_) hAdeg
+        exact Polynomial.degree_sub_lt_left
+          (by rw [Polynomial.degree_eq_natDegree hAmonic.ne_zero,
+            Polynomial.degree_eq_natDegree hBmonic.ne_zero, hAdeg, hBdeg])
+          hAmonic.ne_zero (by rw [hAmonic.leadingCoeff, hBmonic.leadingCoeff])
+  have hconcl : A - Polynomial.C (jqNModC K p) = B := by
+    rw [← key]; ring
+  rw [hconcl, hB, Finset.prod_range]
+
+example : ¬ IsPrimitiveRoot ((1 : ℚˣ) : ℚ) 2 := by
+  intro h
+  have := h.pow_inj (i := 0) (j := 1) (by omega) (by omega) (by simp)
+  omega
+
+example : qTwist ((1 : ℚˣ) ^ 0) (jqModC ℚ) = qTwist ((1 : ℚˣ) ^ 1) (jqModC ℚ) := by
+  simp [qTwist_one_apply]
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_StarBank_press.ModularCurve in
+theorem solution {K : Type*} [Field K] (p : ℕ) [Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) {R : Polynomial K}
+    (hR : Polynomial.aeval (jqModC K) R = jqNModC K p) :
+    R.Monic ∧ R.natDegree = p ∧
+      R.map (algebraMap K (LaurentSeries K)) - Polynomial.C (jqNModC K p) =
+        ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (qTwist (ζ ^ b) (jqModC K))) :=
+  ModularCurve.StarBank.press p ζ hζ hR
+
+end
+end S_ModularCurve_StarBank_press
+end P2MW
+export P2MW.S_ModularCurve_StarBank_press (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.StarBank.press {K : Type*} [Field K] (p : ℕ) [Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) {R : Polynomial K}
+    (hR : Polynomial.aeval (jqModC K) R = jqNModC K p) :
+    R.Monic ∧ R.natDegree = p ∧
+      R.map (algebraMap K (LaurentSeries K)) - Polynomial.C (jqNModC K p) =
+        ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (qTwist (ζ ^ b) (jqModC K))) :=
+  solution p ζ hζ hR
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_starBank.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_starBank.lean
new file mode 100644
index 0000000000..7fa7ef0b15
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_starBank.lean
@@ -0,0 +1,515 @@
+/-
+Based on Prove2Me node ModularCurve.StarBank.starBank
+(5202b741-fc8c-5ad3-969f-c470542edd10) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7c7b8207-5b3d-5cb9-ad77-5d21a6182861
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_closure
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_count
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_deltaNorm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_delta_pow_ne
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_eisInt_not_dvd_num
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_eisInt_series
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_hassePolyDescent
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_onePoint
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_press
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_starK
+import Mathlib.FieldTheory.IsAlgClosed.Basic
+import Mathlib.RingTheory.RootsOfUnity.AlgebraicallyClosed
+import Mathlib.Algebra.Field.ZMod
+import Mathlib.Algebra.CharP.Algebra
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# In characteristic ℓ, j(qᵖ)notin K(j(q)) for p≠ℓ
+
+Theorem statement: `ModularCurve.StarBank.starBank` (`5202b741-fc8c-5ad3-969f-c470542edd10`), by
+Claude, 2026-09-05.
+
+Proof: submission `7c7b8207-5b3d-5cb9-ad77-5d21a6182861`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field of characteristic $\ell$, with $\ell$ prime, and let $p$ be a prime with $p \ne
+\ell$. Work inside the field `LaurentSeries K` of formal Laurent series over $K$, viewed as a
+$K$-algebra. Here `jqModC K` is the formal $q$-expansion of the modular invariant with its integral
+coefficients pushed into $K$: it is the product of the Hahn series $q^{-1}$ (the monomial
+`HahnSeries.single (-1) 1`) with the image in `LaurentSeries K` of the integral power series `jNum`
+$=$ `eisenstein4 ^ 3 * dedekindEtaUnitInv` under the coefficient map $\mathbb{Z} \to K$. For $N \neq
+0$, `jqNModC K N` is the image of `jqModC K` under the ring homomorphism `qExpand K N`, which
+multiplies all Hahn-series exponents by $N$, i.e. performs the substitution $q \mapsto q^{N}$; thus
+`jqNModC K p` is $j(q^{p})$. The assertion is that $j(q^{p})$ does not belong to
+`IntermediateField.adjoin K {jqModC K}`, the intermediate field of `LaurentSeries K` over $K$
+generated by $j(q)$; in classical notation, $j(q^{p}) \notin K\bigl(j(q)\bigr)$.
+
+This is the characteristic-$\ell$ separability statement for the degeneracy map $q \mapsto q^{p}$ on
+$q$-expansions: the hypothesis $p \ne \ell$ cannot be dropped, since in characteristic $\ell$ one
+has $j(q^{\ell}) = j(q)^{\ell}$, which lies in $K(j(q))$. It underlies the study of the function
+field of $X_0(N)$ over $K$ in this formalisation, being used for the irreducibility of the reduced
+modular polynomial over $K(j)$, for the count of poles of $j(q)$ in the full modular function field,
+and for the construction of automorphisms of the field of $q$-expansions fixing $j(q)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_StarBank_starBank.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_StarBank_starBank
+
+p2m_open "Polynomial HahnSeries ModularCurve P2MW.S_ModularCurve_StarBank_starBank.ModularCurve"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC jqNModC map_jqModC qExpand qExpand_coeff_mul \
+  qExpand_coeff_of_not_dvd qExpand_C etaProd constantCoeff_etaProd qTwist \
+  jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne StarBank.closure StarBank.count \
+  StarBank.deltaNorm StarBank.delta_pow_ne StarBank.eisInt_not_dvd_num StarBank.eisInt_series \
+  StarBank.hassePolyDescent StarBank.onePoint StarBank.press StarBank.starK"
+namespace W1
+p2m_open "ModularCurve"
+
+section Kit
+
+variable {K : Type*} [Field K]
+
+theorem coeff_single_mul_ofPowerSeries_nonneg' (c : ℤ) (U : PowerSeries K) (n : ℕ) :
+    (HahnSeries.single c (1 : K) * HahnSeries.ofPowerSeries ℤ K U).coeff (c + (n : ℤ))
+      = PowerSeries.coeff n U := by
+  rw [HahnSeries.coeff_single_mul, one_mul, add_sub_cancel_left]
+  exact HahnSeries.ofPowerSeries_apply_coeff U n
+
+theorem eq_C_leadingCoeff_mul_pow_of_forall_root [IsAlgClosed K] {G : Polynomial K} {β₀ : K}
+    (huniq : ∀ β : K, G.IsRoot β → β = β₀) :
+    G = Polynomial.C G.leadingCoeff * (Polynomial.X - Polynomial.C β₀) ^ G.natDegree := by
+  have hcard : G.roots.card = G.natDegree :=
+    Polynomial.splits_iff_card_roots.mp (IsAlgClosed.splits G)
+  have hall : ∀ b ∈ G.roots, b = β₀ := fun b hb => huniq b (Polynomial.mem_roots'.mp hb).2
+  have hrep : G.roots = Multiset.replicate G.natDegree β₀ := by
+    have h1 := Multiset.eq_replicate_card.mpr hall
+    rwa [hcard] at h1
+  have h2 := Polynomial.C_leadingCoeff_mul_prod_multiset_X_sub_C hcard
+  rw [hrep, Multiset.map_replicate, Multiset.prod_replicate] at h2
+  exact h2.symm
+
+theorem dSeries_ne_zero :
+    (HahnSeries.single (1 : ℤ) 1
+        * HahnSeries.ofPowerSeries ℤ K
+            (PowerSeries.map (Int.castRingHom K) ModularCurve.etaProd) ^ 24)
+      ≠ 0 := by
+  intro h0
+  rw [show (HahnSeries.ofPowerSeries ℤ K
+        (PowerSeries.map (Int.castRingHom K) ModularCurve.etaProd)) ^ 24
+      = HahnSeries.ofPowerSeries ℤ K
+          ((PowerSeries.map (Int.castRingHom K) ModularCurve.etaProd) ^ 24) from
+    (map_pow _ _ _).symm] at h0
+  have h3 : PowerSeries.constantCoeff
+      (PowerSeries.map (Int.castRingHom K) ModularCurve.etaProd) = 1 := by
+    have h4 := PowerSeries.coeff_map (Int.castRingHom K) 0 ModularCurve.etaProd
+    rw [PowerSeries.coeff_zero_eq_constantCoeff_apply,
+      PowerSeries.coeff_zero_eq_constantCoeff_apply, ModularCurve.constantCoeff_etaProd,
+      map_one] at h4
+    exact h4
+  have h1 : (HahnSeries.single (1 : ℤ) (1 : K)
+      * HahnSeries.ofPowerSeries ℤ K
+          ((PowerSeries.map (Int.castRingHom K) ModularCurve.etaProd) ^ 24)).coeff
+        ((1 : ℤ) + ((0 : ℕ) : ℤ)) = 1 := by
+    rw [coeff_single_mul_ofPowerSeries_nonneg',
+      PowerSeries.coeff_zero_eq_constantCoeff_apply, map_pow, h3, one_pow]
+  rw [h0] at h1
+  exact one_ne_zero
+    (h1.symm.trans (show ((0 : LaurentSeries K)).coeff ((1 : ℤ) + ((0 : ℕ) : ℤ)) = 0 from rfl))
+
+theorem endgame_read (p : ℕ) [NeZero p] (hp1 : 1 ≤ p) {β₀ γ : K} (hγ : γ ≠ 0)
+    (honept : (jqModC K - HahnSeries.C β₀)
+        * (HahnSeries.single (1 : ℤ) 1
+            * HahnSeries.ofPowerSeries ℤ K
+                (PowerSeries.map (Int.castRingHom K) ModularCurve.etaProd) ^ 24)
+      = HahnSeries.C γ)
+    (hpress : qExpand K p (jqModC K)
+      = (jqModC K - HahnSeries.C β₀) ^ p + HahnSeries.C β₀) :
+    (HahnSeries.single (1 : ℤ) 1
+        * HahnSeries.ofPowerSeries ℤ K
+            (PowerSeries.map (Int.castRingHom K) ModularCurve.etaProd) ^ 24) ^ p
+      = HahnSeries.C (γ ^ (p - 1))
+        * qExpand K p (HahnSeries.single (1 : ℤ) 1
+            * HahnSeries.ofPowerSeries ℤ K
+                (PowerSeries.map (Int.castRingHom K) ModularCurve.etaProd) ^ 24) := by
+  set D : LaurentSeries K := HahnSeries.single (1 : ℤ) 1
+    * HahnSeries.ofPowerSeries ℤ K
+        (PowerSeries.map (Int.castRingHom K) ModularCurve.etaProd) ^ 24 with hD
+  have hD0 : D ≠ 0 := dSeries_ne_zero
+  have hCγ0 : (HahnSeries.C γ : LaurentSeries K) ≠ 0 := by
+    intro h
+    apply hγ
+    have h1 := congrArg (fun z : LaurentSeries K => z.coeff 0) h
+    rw [show (HahnSeries.C γ : LaurentSeries K) = HahnSeries.single 0 γ from rfl,
+      HahnSeries.coeff_single, ite_eq_left rfl] at h1
+    exact h1.trans rfl
+  have hq := congrArg (qExpand K p) honept
+  rw [map_mul, ModularCurve.qExpand_C] at hq
+  have hqj : qExpand K p (jqModC K - HahnSeries.C β₀)
+      = (jqModC K - HahnSeries.C β₀) ^ p := by
+    rw [map_sub, ModularCurve.qExpand_C, hpress, add_sub_cancel_right]
+  rw [hqj] at hq
+  have hj : jqModC K - HahnSeries.C β₀ = HahnSeries.C γ * D⁻¹ := by
+    rw [← honept]
+    exact (mul_inv_cancel_right₀ hD0 _).symm
+  rw [hj, mul_pow] at hq
+  have h6 := congrArg (fun z : LaurentSeries K => z * D ^ p) hq
+  rw [show HahnSeries.C γ ^ p * D⁻¹ ^ p * qExpand K p D * D ^ p
+      = HahnSeries.C γ ^ p * qExpand K p D * (D⁻¹ * D) ^ p from by ring,
+    inv_mul_cancel₀ hD0, one_pow, mul_one] at h6
+  have h7 : HahnSeries.C γ * (HahnSeries.C (γ ^ (p - 1)) * qExpand K p D)
+      = HahnSeries.C γ * D ^ p := by
+    calc HahnSeries.C γ * (HahnSeries.C (γ ^ (p - 1)) * qExpand K p D)
+        = HahnSeries.C γ ^ p * qExpand K p D := by
+          rw [← mul_assoc, ← map_mul, ← pow_succ', Nat.sub_add_cancel hp1, map_pow]
+      _ = HahnSeries.C γ * D ^ p := h6
+  exact (mul_left_cancel₀ hCγ0 h7).symm
+
+end Kit
+
+section Descent
+
+variable {K K' : Type*} [Field K] [Field K']
+
+theorem algebraMap_laurent_eq_single' (K'' : Type*) [CommRing K''] (c : K'') :
+    algebraMap K'' (LaurentSeries K'') c = HahnSeries.single (0 : ℤ) c := by
+  have h1 : algebraMap K'' (PowerSeries K'') c = PowerSeries.C c := by simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+  rfl
+
+private def laurentMapRingHom (φ : K →+* K') : LaurentSeries K →+* LaurentSeries K' where
+  toFun x := x.map φ
+  map_one' := by
+    ext g
+    rw [HahnSeries.map_coeff,
+      show (1 : LaurentSeries K) = HahnSeries.single 0 1 from HahnSeries.single_zero_one.symm,
+      show (1 : LaurentSeries K') = HahnSeries.single 0 1 from HahnSeries.single_zero_one.symm,
+      HahnSeries.coeff_single, HahnSeries.coeff_single]
+    split_ifs
+    · exact map_one φ
+    · exact map_zero φ
+  map_mul' x y := HahnSeries.map_mul φ.toNonUnitalRingHom
+  map_zero' := by
+    ext g
+    rw [HahnSeries.map_coeff]
+    exact map_zero φ
+  map_add' x y := by
+    ext g
+    rw [HahnSeries.map_coeff, HahnSeries.coeff_add, HahnSeries.coeff_add,
+      HahnSeries.map_coeff, HahnSeries.map_coeff]
+    exact map_add φ _ _
+
+end Descent
+
+section Transport
+
+variable {K K' : Type*} [Field K] [Field K']
+
+theorem qExpand_map_comm (φ : K →+* K') (N : ℕ) [NeZero N] (f : LaurentSeries K) :
+    (ModularCurve.qExpand K N f).map φ = ModularCurve.qExpand K' N (f.map φ) := by
+  ext g
+  rw [HahnSeries.map_coeff]
+  by_cases hg : (N : ℤ) ∣ g
+  · obtain ⟨k, hk⟩ := hg
+    subst hk
+    rw [ModularCurve.qExpand_coeff_mul, ModularCurve.qExpand_coeff_mul, HahnSeries.map_coeff]
+  · rw [ModularCurve.qExpand_coeff_of_not_dvd (hk := hg),
+      ModularCurve.qExpand_coeff_of_not_dvd (hk := hg), map_zero]
+
+theorem jqNModC_map_comm (φ : K →+* K') (p : ℕ) [NeZero p] :
+    (ModularCurve.jqNModC K p).map φ = ModularCurve.jqNModC K' p := by
+  rw [ModularCurve.jqNModC, ModularCurve.jqNModC, qExpand_map_comm, ModularCurve.map_jqModC]
+
+theorem aeval_jqModC_map_comm (φ : K →+* K') (R : Polynomial K) :
+    (Polynomial.aeval (ModularCurve.jqModC K) R).map φ
+      = Polynomial.aeval (ModularCurve.jqModC K') (R.map φ) := by
+  have hcomp : (laurentMapRingHom φ).comp (algebraMap K (LaurentSeries K))
+      = (algebraMap K' (LaurentSeries K')).comp φ := by
+    refine RingHom.ext fun c => ?_
+    change (algebraMap K (LaurentSeries K) c).map φ = algebraMap K' (LaurentSeries K') (φ c)
+    rw [algebraMap_laurent_eq_single', algebraMap_laurent_eq_single']
+    ext g
+    rw [HahnSeries.map_coeff, HahnSeries.coeff_single, HahnSeries.coeff_single]
+    split_ifs
+    · rfl
+    · exact map_zero φ
+  rw [Polynomial.aeval_def, Polynomial.aeval_def, Polynomial.eval₂_map,
+    show (Polynomial.eval₂ (algebraMap K (LaurentSeries K)) (ModularCurve.jqModC K) R).map φ
+      = laurentMapRingHom φ
+          (Polynomial.eval₂ (algebraMap K (LaurentSeries K)) (ModularCurve.jqModC K) R) from rfl,
+    Polynomial.hom_eval₂, hcomp,
+    show laurentMapRingHom φ (ModularCurve.jqModC K)
+      = (ModularCurve.jqModC K).map φ from rfl,
+    ModularCurve.map_jqModC]
+
+end Transport
+
+section PrimRoot
+
+theorem natCast_prime_ne_zero (K : Type*) [Field K] {ℓ p : ℕ} [Fact ℓ.Prime] [Fact p.Prime]
+    [CharP K ℓ] (hpℓ : p ≠ ℓ) : (p : K) ≠ 0 := by
+  intro h
+  rw [CharP.cast_eq_zero_iff K ℓ] at h
+  exact hpℓ ((Nat.prime_dvd_prime_iff_eq Fact.out Fact.out).mp h).symm
+
+theorem exists_primitiveRoot_units (K : Type*) [Field K] [IsAlgClosed K] (p : ℕ)
+    [Fact p.Prime] (hp : (p : K) ≠ 0) : ∃ ζ : Kˣ, IsPrimitiveRoot ((ζ : Kˣ) : K) p := by
+  have : NeZero ((p : K)) := ⟨hp⟩
+  obtain ⟨z, hz⟩ := HasEnoughRootsOfUnity.exists_primitiveRoot K p
+  obtain ⟨u, hu⟩ := hz.isUnit (Nat.Prime.ne_zero Fact.out)
+  exact ⟨u, hu.symm ▸ hz⟩
+
+end PrimRoot
+
+section HasseDischarge
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_StarBank_starBank.ModularCurve UpperHalfPlane"
+open scoped MatrixGroups
+
+theorem hasse_input {ℓ : ℕ} [Fact ℓ.Prime] (hℓ5 : 5 ≤ ℓ) :
+    ∃ (T : PowerSeries ℤ) (G : Polynomial ℤ),
+      (∀ m, 1 ≤ m → (ℓ : ℤ) ∣ T.coeff m) ∧ ¬ (ℓ : ℤ) ∣ PowerSeries.constantCoeff T
+      ∧ G.natDegree = ℓ - 1 ∧ G.coeff (ℓ - 1) = PowerSeries.constantCoeff T
+      ∧ HahnSeries.ofPowerSeries ℤ ℤ T
+          = Polynomial.aeval (ModularCurve.jqModC ℤ) G
+            * (HahnSeries.single (1 : ℤ) (1 : ℤ)
+                * HahnSeries.ofPowerSeries ℤ ℤ ModularCurve.etaProd ^ 24) ^ (ℓ - 1) := by
+  have hk : 3 ≤ ℓ - 1 := by omega
+  obtain ⟨T, hTmap, hTconst, hTdvd⟩ := ModularCurve.StarBank.eisInt_series hℓ5 hk
+  have hnum0 : ¬ (ℓ : ℤ) ∣ (_root_.bernoulli (ℓ - 1)).num :=
+    ModularCurve.StarBank.eisInt_not_dvd_num hℓ5
+  have hmapZ : T.map (Int.castRingHom (ZMod ℓ))
+      = PowerSeries.C (((_root_.bernoulli (ℓ - 1)).num : ZMod ℓ)) := by
+    ext n
+    rw [PowerSeries.coeff_map, PowerSeries.coeff_C]
+    rcases Nat.eq_zero_or_pos n with hn | hn
+    · subst hn
+      rw [ite_eq_left rfl, PowerSeries.coeff_zero_eq_constantCoeff_apply, hTconst]
+      rfl
+    · rw [ite_eq_right (by omega)]
+      exact (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mpr (hTdvd n hn)
+  have hmapZ12 : (T ^ 12).map (Int.castRingHom (ZMod ℓ))
+      = PowerSeries.C ((((_root_.bernoulli (ℓ - 1)).num : ZMod ℓ)) ^ 12) := by
+    rw [map_pow, hmapZ, ← map_pow]
+  have hnumZ : (((_root_.bernoulli (ℓ - 1)).num : ZMod ℓ)) ≠ 0 :=
+    fun h => hnum0 ((ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp h)
+  have hdvd12 : ∀ m, 1 ≤ m → (ℓ : ℤ) ∣ (T ^ 12).coeff m := by
+    intro m hm
+    have h1 := congrArg (fun u : PowerSeries (ZMod ℓ) => PowerSeries.coeff m u) hmapZ12
+    simp only [PowerSeries.coeff_map, PowerSeries.coeff_C] at h1
+    rw [ite_eq_right (by omega : ¬ m = 0)] at h1
+    exact (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp h1
+  have hconst12 : PowerSeries.constantCoeff (T ^ 12) = (_root_.bernoulli (ℓ - 1)).num ^ 12 := by
+    rw [map_pow, hTconst]
+  have hnot12 : ¬ (ℓ : ℤ) ∣ PowerSeries.constantCoeff (T ^ 12) := by
+    rw [hconst12, ← ZMod.intCast_zmod_eq_zero_iff_dvd]
+    push_cast
+    exact pow_ne_zero 12 hnumZ
+  have hw : ((12 : ℕ) : ℤ) * ((ℓ - 1 : ℕ) : ℤ) = 12 * ((ℓ - 1 : ℕ) : ℤ) := by norm_num
+  have hT12 : (T ^ 12).map (Int.castRingHom ℂ)
+      = UpperHalfPlane.qExpansion 1
+          ⇑(ModularForm.mcast hw
+              ((((_root_.bernoulli (ℓ - 1)).num : ℂ) • ModularForm.E hk).pow 12)) := by
+    have h1 : UpperHalfPlane.qExpansion 1
+        ⇑(ModularForm.mcast hw
+            ((((_root_.bernoulli (ℓ - 1)).num : ℂ) • ModularForm.E hk).pow 12))
+        = UpperHalfPlane.qExpansion 1
+            ⇑((((_root_.bernoulli (ℓ - 1)).num : ℂ) • ModularForm.E hk).pow 12) := rfl
+    rw [h1, ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL,
+      FunLike.coe_smul,
+      ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL, map_pow, hTmap]
+  have h0 : PowerSeries.constantCoeff (T ^ 12) ≠ 0 := by
+    rw [hconst12]
+    intro h
+    exact hnum0 ((pow_eq_zero_iff (by norm_num : (12 : ℕ) ≠ 0)).mp h ▸ dvd_zero _)
+  obtain ⟨G, hGdeg, hGcoeff, hGid⟩ := ModularCurve.StarBank.hassePolyDescent
+    (ModularForm.mcast hw ((((_root_.bernoulli (ℓ - 1)).num : ℂ) • ModularForm.E hk).pow 12))
+    hT12 h0
+  exact ⟨T ^ 12, G, hdvd12, hnot12, hGdeg, hGcoeff, hGid⟩
+
+end HasseDischarge
+
+end ModularCurve.W1
+
+section Core
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_StarBank_starBank.ModularCurve"
+
+private theorem starBank_core {K : Type*} [Field K] [IsAlgClosed K] {ℓ p : ℕ}
+    [Fact ℓ.Prime] [Fact p.Prime] [CharP K ℓ] (hpℓ : p ≠ ℓ)
+    (hstarK : ∃ M : ℕ, 1 ≤ M ∧ (M : K) ≠ 0 ∧ ∃ G : Polynomial K, G.natDegree = M
+      ∧ Polynomial.aeval (jqModC K) G
+          * (HahnSeries.single (1 : ℤ) (1 : K)
+              * HahnSeries.ofPowerSeries ℤ K
+                  (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^ M = 1)
+    (hpress : ∀ (ζ : Kˣ), IsPrimitiveRoot (ζ : K) p → ∀ {R : Polynomial K},
+      Polynomial.aeval (jqModC K) R = jqNModC K p →
+      R.Monic ∧ R.natDegree = p ∧
+        R.map (algebraMap K (LaurentSeries K)) - Polynomial.C (jqNModC K p) =
+          ∏ b ∈ Finset.range p,
+            (Polynomial.X - Polynomial.C (qTwist (ζ ^ b) (jqModC K))))
+    (hnorm : ∀ (ζ : Kˣ), IsPrimitiveRoot (ζ : K) p →
+      (∏ b ∈ Finset.range p, qTwist (ζ ^ b)
+          (HahnSeries.single (1 : ℤ) (1 : K) *
+            HahnSeries.ofPowerSeries ℤ K
+              (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24)) *
+        qExpand K (p * p) (HahnSeries.single (1 : ℤ) (1 : K) *
+            HahnSeries.ofPowerSeries ℤ K
+              (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) =
+      HahnSeries.C (((∏ b ∈ Finset.range p, ζ ^ b : Kˣ) : K)) *
+        qExpand K p (HahnSeries.single (1 : ℤ) (1 : K) *
+            HahnSeries.ofPowerSeries ℤ K
+              (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^ (p + 1))
+    (hclosure : ∀ (ζ : Kˣ) {M : ℕ} {G R : Polynomial K},
+      Polynomial.aeval (jqModC K) G *
+          (HahnSeries.single (1 : ℤ) (1 : K) *
+            HahnSeries.ofPowerSeries ℤ K
+              (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^ M = 1 →
+      Polynomial.aeval (jqModC K) R = jqNModC K p →
+      (R.map (algebraMap K (LaurentSeries K)) - Polynomial.C (jqNModC K p) =
+          ∏ b ∈ Finset.range p,
+            (Polynomial.X - Polynomial.C (qTwist (ζ ^ b) (jqModC K)))) →
+      ((∏ b ∈ Finset.range p, qTwist (ζ ^ b)
+          (HahnSeries.single (1 : ℤ) (1 : K) *
+            HahnSeries.ofPowerSeries ℤ K
+              (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24)) *
+        qExpand K (p * p) (HahnSeries.single (1 : ℤ) (1 : K) *
+            HahnSeries.ofPowerSeries ℤ K
+              (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) =
+      HahnSeries.C (((∏ b ∈ Finset.range p, ζ ^ b : Kˣ) : K)) *
+        qExpand K p (HahnSeries.single (1 : ℤ) (1 : K) *
+            HahnSeries.ofPowerSeries ℤ K
+              (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^ (p + 1)) →
+      ∃ c : K, c ≠ 0 ∧ G.comp R ∣ Polynomial.C c * G ^ (p + 1))
+    (hcount : ∀ (_ : (p : K) ≠ 0) (_ : 2 ≤ p) {R G : Polynomial K} (_ : R.Monic)
+      (_ : R.natDegree = p) (_ : 0 < G.natDegree) {c : K} (_ : c ≠ 0)
+      (_ : G.comp R ∣ Polynomial.C c * G ^ (p + 1)),
+      ∃ β₀ : K, (∀ β : K, G.IsRoot β → β = β₀) ∧
+        R = (Polynomial.X - Polynomial.C β₀) ^ p + Polynomial.C β₀)
+    (honepoint : ∀ {M : ℕ} (_ : (M : K) ≠ 0) {c : K} (_ : c ≠ 0) {β₀ : K}
+      (_ : Polynomial.aeval (jqModC K)
+            (Polynomial.C c * (Polynomial.X - Polynomial.C β₀) ^ M)
+          * (HahnSeries.single (1 : ℤ) 1
+              * HahnSeries.ofPowerSeries ℤ K
+                  (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^ M
+          = 1),
+      ∃ γ : K, γ ≠ 0 ∧
+        (jqModC K - HahnSeries.C β₀)
+          * (HahnSeries.single (1 : ℤ) 1
+              * HahnSeries.ofPowerSeries ℤ K
+                  (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24)
+          = HahnSeries.C γ)
+    (hdelta : ∀ (γ : K),
+      (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K
+            (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^ p ≠
+        HahnSeries.C γ * qExpand K p (HahnSeries.single (1 : ℤ) (1 : K) *
+          HahnSeries.ofPowerSeries ℤ K
+            (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24))
+    {R : Polynomial K} (hRmem : Polynomial.aeval (jqModC K) R = jqNModC K p) : False := by
+  have hp0 : (p : K) ≠ 0 := ModularCurve.W1.natCast_prime_ne_zero K hpℓ
+  obtain ⟨ζ, hζ⟩ := ModularCurve.W1.exists_primitiveRoot_units K p hp0
+  obtain ⟨hRmon, hRdeg, hRprod⟩ := hpress ζ hζ hRmem
+  obtain ⟨M, hM1, hMK, G, hGdeg, hGstar⟩ := hstarK
+  obtain ⟨c, hc, hdvd⟩ := hclosure ζ hGstar hRmem hRprod (hnorm ζ hζ)
+  have hGpos : 0 < G.natDegree := by rw [hGdeg]; omega
+  obtain ⟨β₀, huniq, hRform⟩ :=
+    hcount hp0 (Nat.Prime.two_le Fact.out) hRmon hRdeg hGpos hc hdvd
+  have hG0 : G ≠ 0 := by
+    intro h0
+    rw [h0, map_zero, zero_mul] at hGstar
+    exact zero_ne_one hGstar
+  have hlc : G.leadingCoeff ≠ 0 := fun h => hG0 (Polynomial.leadingCoeff_eq_zero.mp h)
+  have hGfact := ModularCurve.W1.eq_C_leadingCoeff_mul_pow_of_forall_root huniq
+  rw [hGfact, hGdeg] at hGstar
+  obtain ⟨γ, hγ, honep⟩ := honepoint hMK hlc hGstar
+  have hpressEq : qExpand K p (jqModC K)
+      = (jqModC K - HahnSeries.C β₀) ^ p + HahnSeries.C β₀ := by
+    have h1 : Polynomial.aeval (jqModC K) R
+        = (jqModC K - HahnSeries.C β₀) ^ p + HahnSeries.C β₀ := by
+      rw [hRform, map_add, map_pow, map_sub, Polynomial.aeval_X, Polynomial.aeval_C,
+        ModularCurve.W1.algebraMap_laurent_eq_single']
+      rfl
+    rw [← h1, hRmem, ModularCurve.jqNModC]
+  have hDp := ModularCurve.W1.endgame_read p ((Nat.Prime.one_lt (Fact.out : p.Prime)).le)
+    hγ honep hpressEq
+  exact hdelta (γ ^ (p - 1)) hDp
+
+end Core
+
+section Root
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_StarBank_starBank.ModularCurve"
+open scoped MatrixGroups
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC jqNModC map_jqModC qExpand qExpand_coeff_mul \
+  qExpand_coeff_of_not_dvd qExpand_C etaProd constantCoeff_etaProd qTwist \
+  jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne StarBank.closure StarBank.count \
+  StarBank.deltaNorm StarBank.delta_pow_ne StarBank.eisInt_not_dvd_num StarBank.eisInt_series \
+  StarBank.hassePolyDescent StarBank.onePoint StarBank.press StarBank.starK"
+namespace StarBank
+p2m_export "ModularCurve.StarBank" "closure count deltaNorm delta_pow_ne eisInt_not_dvd_num \
+  eisInt_series hassePolyDescent onePoint press starK"
+end ModularCurve.StarBank
+p2m_open_scoped "ModularCurve ModularCurve.StarBank" in
+private theorem ModularCurve.StarBank.starBank {K : Type*} [Field K] {ℓ : ℕ} [Fact ℓ.Prime]
+    [CharP K ℓ] {p : ℕ} [Fact p.Prime] (hpℓ : p ≠ ℓ) :
+    jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) := by
+  apply ModularCurve.jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne
+  intro R0 hR0
+  have : CharP (AlgebraicClosure K) ℓ :=
+    charP_of_injective_algebraMap (algebraMap K (AlgebraicClosure K)).injective ℓ
+  have hR1 : Polynomial.aeval (jqModC (AlgebraicClosure K))
+      (R0.map (algebraMap K (AlgebraicClosure K)))
+      = jqNModC (AlgebraicClosure K) p := by
+    rw [← ModularCurve.W1.aeval_jqModC_map_comm, hR0, ModularCurve.W1.jqNModC_map_comm]
+  exact starBank_core hpℓ
+    (ModularCurve.StarBank.starK (AlgebraicClosure K) ModularCurve.W1.hasse_input)
+    (ModularCurve.StarBank.press p) (ModularCurve.StarBank.deltaNorm p)
+    (ModularCurve.StarBank.closure p) ModularCurve.StarBank.count
+    ModularCurve.StarBank.onePoint
+    (ModularCurve.StarBank.delta_pow_ne (AlgebraicClosure K) hpℓ) hR1
+
+end Root
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_StarBank_starBank.ModularCurve in
+theorem solution {K : Type*} [Field K] {ℓ : ℕ} [Fact ℓ.Prime]
+    [CharP K ℓ] {p : ℕ} [Fact p.Prime] (hpℓ : p ≠ ℓ) :
+    jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) :=
+  ModularCurve.StarBank.starBank hpℓ
+
+end S_ModularCurve_StarBank_starBank
+end P2MW
+export P2MW.S_ModularCurve_StarBank_starBank (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.StarBank.starBank {K : Type*} [Field K] {ℓ : ℕ} [Fact ℓ.Prime]
+    [CharP K ℓ] {p : ℕ} [Fact p.Prime] (hpℓ : p ≠ ℓ) :
+    jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) :=
+  solution hpℓ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_starK.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_starK.lean
new file mode 100644
index 0000000000..66d233d27a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_StarBank_starK.lean
@@ -0,0 +1,295 @@
+/-
+Based on Prove2Me node ModularCurve.StarBank.starK
+(43a91ee6-8546-5654-8b64-6c03f3e8a430) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 341ef078-c553-5118-a420-e3b8d38b820d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import Mathlib.Algebra.Polynomial.Degree.Lemmas
+import Mathlib.Algebra.CharP.Lemmas
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Characteristic ℓ: a unit identity G(j)Δ^M = 1
+
+Theorem statement: `ModularCurve.StarBank.starK` (`43a91ee6-8546-5654-8b64-6c03f3e8a430`), by
+Claude, 2026-09-05.
+
+Proof: submission `341ef078-c553-5118-a420-e3b8d38b820d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, $\ell$ a prime, and suppose $K$ has characteristic $\ell$ (as a `CharP`
+instance). Work inside the Laurent series ring `LaurentSeries K` with the two distinguished elements
+built from integral $q$-expansions: $j$, given by `jqModC K`, namely $q^{-1}$ (the Hahn series
+`single (-1) 1`) times the power series `jNum` $= E_4^3\cdot(\eta\text{-unit})^{-1}$ with its
+coefficients read in $K$, where $E_4$ is `eisenstein4`, the series with constant term $1$ and $n$-th
+coefficient $240\sigma_3(n)$, and $(\eta\text{-unit})^{-1}$ is the power-series inverse of
+`etaProd`$^{24} = \prod_{n\ge 1}(1-q^n)^{24}$; and the discriminant $\Delta$, given by
+$q\cdot\big(\prod_{n\ge1}(1-q^n)\big)^{24}$, i.e. `single 1 1` times the $24$th power of the image
+of `etaProd` in $K$. The single hypothesis is conditional: if $5\le\ell$, there are a power series
+$T\in\mathbb{Z}[[q]]$ and a polynomial $G\in\mathbb{Z}[X]$ such that $\ell$ divides every
+coefficient of $T$ of index $\ge 1$, $\ell$ does not divide the constant coefficient of $T$, $G$ has
+degree $\ell-1$ with $(\ell-1)$-st coefficient equal to that constant coefficient, and the identity
+$T = G(j)\,\Delta^{\ell-1}$ holds in `LaurentSeries ℤ` (with $j$ and $\Delta$ formed over
+$\mathbb{Z}$ as above). The conclusion is that there exist a natural number $M$ with $1\le M$ whose
+image in $K$ is nonzero, and a polynomial $G\in K[X]$ of degree exactly $M$, such that
+$G(j)\cdot\Delta^{M} = 1$ in `LaurentSeries K`, the evaluation being `Polynomial.aeval` at `jqModC
+K`.
+
+The hypothesis packages, for $\ell\ge 5$, the reduction modulo $\ell$ of the classical congruence
+for the Eisenstein series of weight $\ell-1$ (the Hasse invariant), expressed entirely in terms of
+$q$-expansions: $E_{\ell-1} = G(j)\Delta^{\ell-1}$ with $G$ of degree $\ell-1$. Unlike the textbook
+formulation, nothing here concerns modular forms or the curve $X_0(N)$ as such: all objects are
+formal Laurent series, and the output is a purely formal unit identity saying that $\Delta^{-M}$ is
+a polynomial in $j$ of degree $M$ with $M$ invertible in $K$. The identity is used in the proof that
+$j(q^p)$ does not lie in $K(j(q))$ for a prime $p\ne\ell$
+([`ModularCurve.StarBank.starBank`](thm.html#ModularCurve.StarBank.starBank)), where the finitely
+many roots of $G$ supply the $j$-values on which the characteristic-$\ell$ argument is run and the
+invertibility of $M$ in $K$ is needed.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_StarBank_starK.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_StarBank_starK
+
+open HahnSeries PowerSeries
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC map_jqModC eisenstein4 etaProd dedekindEtaUnit \
+  dedekindEtaUnitInv dedekindEtaUnit_mul_inv jNum ofPowerSeries_coeff_of_neg"
+namespace W1
+p2m_open "ModularCurve"
+
+noncomputable abbrev Dseries (K : Type*) [CommRing K] : LaurentSeries K :=
+  HahnSeries.single (1 : ℤ) (1 : K)
+    * HahnSeries.ofPowerSeries ℤ K (PowerSeries.map (Int.castRingHom K) ModularCurve.etaProd) ^ 24
+
+private def hahnMapRingHom {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S) :
+    LaurentSeries R →+* LaurentSeries S where
+  toFun x := x.map f
+  map_one' := HahnSeries.map_one f.toMonoidWithZeroHom
+  map_mul' _ _ := HahnSeries.map_mul f.toNonUnitalRingHom
+  map_zero' := HahnSeries.map_zero f.toZeroHom
+  map_add' _ _ := HahnSeries.map_add f.toAddMonoidHom
+
+private theorem hahnMapRingHom_apply {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S)
+    (x : LaurentSeries R) : hahnMapRingHom f x = x.map f := rfl
+
+theorem ofPowerSeries_map {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S)
+    (u : PowerSeries R) :
+    (HahnSeries.ofPowerSeries ℤ R u).map f = HahnSeries.ofPowerSeries ℤ S (PowerSeries.map f u) :=
+      by
+  ext k
+  rw [HahnSeries.map_coeff]
+  rcases le_or_gt 0 k with hk | hk
+  · lift k to ℕ using hk
+    rw [HahnSeries.ofPowerSeries_apply_coeff, HahnSeries.ofPowerSeries_apply_coeff,
+      PowerSeries.coeff_map]
+  · rw [ModularCurve.ofPowerSeries_coeff_of_neg _ hk,
+      ModularCurve.ofPowerSeries_coeff_of_neg _ hk, map_zero]
+
+private theorem hahnMapRingHom_ofPowerSeries {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S)
+    (u : PowerSeries R) :
+    hahnMapRingHom f (HahnSeries.ofPowerSeries ℤ R u)
+      = HahnSeries.ofPowerSeries ℤ S (PowerSeries.map f u) :=
+  ofPowerSeries_map f u
+
+private theorem hahnMapRingHom_single {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S)
+    (g : ℤ) (r : R) :
+    hahnMapRingHom f (HahnSeries.single g r) = HahnSeries.single g (f r) :=
+  HahnSeries.map_single (f := f.toZeroHom)
+
+private theorem hahnMapRingHom_etaBlock (K : Type*) [CommRing K] :
+    hahnMapRingHom (Int.castRingHom K)
+        (HahnSeries.single (1 : ℤ) (1 : ℤ)
+          * HahnSeries.ofPowerSeries ℤ ℤ ModularCurve.etaProd ^ 24)
+      = HahnSeries.single (1 : ℤ) (1 : K)
+          * HahnSeries.ofPowerSeries ℤ K
+              (PowerSeries.map (Int.castRingHom K) ModularCurve.etaProd) ^ 24 := by
+  rw [map_mul, map_pow, hahnMapRingHom_single, hahnMapRingHom_ofPowerSeries, map_one]
+
+private theorem hahnMapRingHom_aeval_jqModC (K : Type*) [CommRing K] (G : Polynomial ℤ) :
+    hahnMapRingHom (Int.castRingHom K) (Polynomial.aeval (ModularCurve.jqModC ℤ) G)
+      = Polynomial.aeval (ModularCurve.jqModC K) (G.map (Int.castRingHom K)) := by
+  have h := Polynomial.map_aeval_eq_aeval_map
+    (R := ℤ) (S := LaurentSeries ℤ) (T := K) (U := LaurentSeries K)
+    (φ := Int.castRingHom K) (ψ := hahnMapRingHom (Int.castRingHom K))
+    (RingHom.ext_int _ _) G (ModularCurve.jqModC ℤ)
+  rw [h, hahnMapRingHom_apply, ModularCurve.map_jqModC]
+
+private theorem powerSeries_map_eq_C_of_dvd {K : Type*} [CommRing K] {ℓ : ℕ} [CharP K ℓ]
+    {T : PowerSeries ℤ} (hT : ∀ m, 1 ≤ m → (ℓ : ℤ) ∣ T.coeff m) :
+    T.map (Int.castRingHom K) = PowerSeries.C ((PowerSeries.constantCoeff T : ℤ) : K) := by
+  ext m
+  rw [PowerSeries.coeff_map, PowerSeries.coeff_C]
+  rcases Nat.eq_zero_or_pos m with rfl | hm
+  · rw [ite_eq_left rfl, ← PowerSeries.coeff_zero_eq_constantCoeff_apply, eq_intCast]
+  · rw [ite_eq_right hm.ne']
+    exact_mod_cast (CharP.intCast_eq_zero_iff K ℓ _).mpr (hT m hm)
+
+private theorem eisenstein4_map_of_240 {K : Type*} [CommRing K] (h240 : (240 : K) = 0) :
+    PowerSeries.map (Int.castRingHom K) ModularCurve.eisenstein4 = 1 := by
+  ext n
+  rw [PowerSeries.coeff_map, ModularCurve.eisenstein4, PowerSeries.coeff_mk, PowerSeries.coeff_one]
+  rcases Nat.eq_zero_or_pos n with rfl | hn
+  · simp
+  · rw [ite_eq_right hn.ne', ite_eq_right hn.ne']
+    have h240Z : (Int.castRingHom K) (240 : ℤ) = 0 := by
+      simp only [eq_intCast]; exact_mod_cast h240
+    rw [map_mul, h240Z, zero_mul]
+
+theorem jqModC_mul_Dseries_of_240 {K : Type*} [CommRing K] (h240 : (240 : K) = 0) :
+    ModularCurve.jqModC K * Dseries K = 1 := by
+  have heis := eisenstein4_map_of_240 h240
+  have hjnum : PowerSeries.map (Int.castRingHom K) ModularCurve.jNum
+      = PowerSeries.map (Int.castRingHom K) ModularCurve.dedekindEtaUnitInv := by
+    rw [ModularCurve.jNum, map_mul, map_pow, heis, one_pow, one_mul]
+  have heta : HahnSeries.ofPowerSeries ℤ K
+        (PowerSeries.map (Int.castRingHom K) ModularCurve.etaProd) ^ 24
+      = HahnSeries.ofPowerSeries ℤ K
+        (PowerSeries.map (Int.castRingHom K) ModularCurve.dedekindEtaUnit) := by
+    rw [ModularCurve.dedekindEtaUnit, map_pow, map_pow]
+  rw [ModularCurve.jqModC, Dseries, hjnum, heta]
+  have hinv : PowerSeries.map (Int.castRingHom K) ModularCurve.dedekindEtaUnitInv
+      * PowerSeries.map (Int.castRingHom K) ModularCurve.dedekindEtaUnit = 1 := by
+    rw [← map_mul, mul_comm, ModularCurve.dedekindEtaUnit_mul_inv, map_one]
+  calc HahnSeries.single (-1 : ℤ) (1 : K)
+        * HahnSeries.ofPowerSeries ℤ K
+            (PowerSeries.map (Int.castRingHom K) ModularCurve.dedekindEtaUnitInv)
+        * (HahnSeries.single (1 : ℤ) (1 : K)
+            * HahnSeries.ofPowerSeries ℤ K
+                (PowerSeries.map (Int.castRingHom K) ModularCurve.dedekindEtaUnit))
+      = (HahnSeries.single (-1 : ℤ) (1 : K) * HahnSeries.single (1 : ℤ) (1 : K))
+        * (HahnSeries.ofPowerSeries ℤ K
+              (PowerSeries.map (Int.castRingHom K) ModularCurve.dedekindEtaUnitInv)
+            * HahnSeries.ofPowerSeries ℤ K
+              (PowerSeries.map (Int.castRingHom K) ModularCurve.dedekindEtaUnit)) := by ring
+    _ = HahnSeries.single (0 : ℤ) (1 : K)
+        * HahnSeries.ofPowerSeries ℤ K (1 : PowerSeries K) := by
+        rw [HahnSeries.single_mul_single, ← map_mul, hinv]; ring_nf
+    _ = 1 := by rw [HahnSeries.single_zero_one, map_one, one_mul]
+
+end ModularCurve.W1
+
+p2m_open "P2MW.S_ModularCurve_StarBank_starK.ModularCurve.W1 ModularCurve \
+  P2MW.S_ModularCurve_StarBank_starK.ModularCurve"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC map_jqModC eisenstein4 etaProd dedekindEtaUnit \
+  dedekindEtaUnitInv dedekindEtaUnit_mul_inv jNum ofPowerSeries_coeff_of_neg"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.StarBank.starK_of_240 (K : Type*) [Field K] (h240 : (240 : K) = 0) :
+    ∃ M : ℕ, 1 ≤ M ∧ (M : K) ≠ 0 ∧ ∃ G : Polynomial K, G.natDegree = M
+      ∧ Polynomial.aeval (jqModC K) G
+          * (HahnSeries.single (1 : ℤ) (1 : K)
+              * HahnSeries.ofPowerSeries ℤ K
+                  (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^ M = 1 := by
+  refine ⟨1, le_refl 1, ?_, Polynomial.X, Polynomial.natDegree_X, ?_⟩
+  · exact_mod_cast one_ne_zero (α := K)
+  · rw [Polynomial.aeval_X, pow_one]
+    exact ModularCurve.W1.jqModC_mul_Dseries_of_240 h240
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.StarBank.starK (K : Type*) [Field K] {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+    (hHasse : 5 ≤ ℓ → ∃ (T : PowerSeries ℤ) (G : Polynomial ℤ),
+        (∀ m, 1 ≤ m → (ℓ : ℤ) ∣ T.coeff m) ∧ ¬ (ℓ : ℤ) ∣ PowerSeries.constantCoeff T
+        ∧ G.natDegree = ℓ - 1 ∧ G.coeff (ℓ - 1) = PowerSeries.constantCoeff T
+        ∧ HahnSeries.ofPowerSeries ℤ ℤ T
+            = Polynomial.aeval (jqModC ℤ) G
+              * (HahnSeries.single (1 : ℤ) (1 : ℤ)
+                  * HahnSeries.ofPowerSeries ℤ ℤ etaProd ^ 24) ^ (ℓ - 1)) :
+    ∃ M : ℕ, 1 ≤ M ∧ (M : K) ≠ 0 ∧ ∃ G : Polynomial K, G.natDegree = M
+      ∧ Polynomial.aeval (jqModC K) G
+          * (HahnSeries.single (1 : ℤ) (1 : K)
+              * HahnSeries.ofPowerSeries ℤ K
+                  (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^ M = 1 := by
+  have hℓp : ℓ.Prime := Fact.out
+  rcases lt_or_ge ℓ 5 with hℓ5 | hℓ5
+  · have hℓdvd : ℓ ∣ 240 := by
+      interval_cases ℓ <;> first | decide | exact absurd hℓp (by decide)
+    exact ModularCurve.StarBank.starK_of_240 K ((CharP.cast_eq_zero_iff K ℓ 240).mpr hℓdvd)
+  · obtain ⟨T, G₀, hTdvd, hTconst, hGdeg, hGcoeff, hId⟩ := hHasse hℓ5
+    set cT := PowerSeries.constantCoeff T with hcTdef
+    have hcTK : ((cT : ℤ) : K) ≠ 0 := fun h =>
+      hTconst ((CharP.intCast_eq_zero_iff K ℓ cT).mp h)
+    have hmap := congrArg (hahnMapRingHom (Int.castRingHom K)) hId
+    rw [map_mul, map_pow, hahnMapRingHom_aeval_jqModC, hahnMapRingHom_etaBlock,
+      hahnMapRingHom_apply, ofPowerSeries_map, powerSeries_map_eq_C_of_dvd hTdvd,
+      HahnSeries.ofPowerSeries_C] at hmap
+    refine ⟨ℓ - 1, by omega, ?_,
+      Polynomial.C (((cT : ℤ) : K)⁻¹) * G₀.map (Int.castRingHom K), ?_, ?_⟩
+    · have h1 : (1 : ℕ) ≤ ℓ := hℓp.one_lt.le
+      have : ((ℓ - 1 : ℕ) : K) = (ℓ : K) - 1 := by exact_mod_cast Nat.cast_sub h1
+      rw [this, CharP.cast_eq_zero K ℓ, zero_sub]
+      exact neg_ne_zero.mpr one_ne_zero
+    · have hdegK : (G₀.map (Int.castRingHom K)).natDegree = ℓ - 1 := by
+        refine Polynomial.natDegree_map_of_leadingCoeff_ne_zero _ ?_ |>.trans hGdeg
+        rw [Polynomial.leadingCoeff, hGdeg, hGcoeff]; simpa using hcTK
+      rw [Polynomial.natDegree_C_mul (inv_ne_zero hcTK), hdegK]
+    · rw [map_mul (Polynomial.aeval (jqModC K)), Polynomial.aeval_C, mul_assoc, ← hmap,
+        ← hcTdef, HahnSeries.algebraMap_apply', PowerSeries.algebraMap_eq,
+        HahnSeries.ofPowerSeries_C, ← map_mul, inv_mul_cancel₀ hcTK, map_one]
+
+example : ((720 : ℤ) : ℚ) ≠ 0 := by decide
+
+open HahnSeries PowerSeries _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_StarBank_starK.ModularCurve in
+theorem solution (K : Type*) [Field K] {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+    (hHasse : 5 ≤ ℓ → ∃ (T : PowerSeries ℤ) (G : Polynomial ℤ),
+        (∀ m, 1 ≤ m → (ℓ : ℤ) ∣ T.coeff m) ∧ ¬ (ℓ : ℤ) ∣ PowerSeries.constantCoeff T
+        ∧ G.natDegree = ℓ - 1 ∧ G.coeff (ℓ - 1) = PowerSeries.constantCoeff T
+        ∧ HahnSeries.ofPowerSeries ℤ ℤ T
+            = Polynomial.aeval (jqModC ℤ) G
+              * (HahnSeries.single (1 : ℤ) (1 : ℤ)
+                  * HahnSeries.ofPowerSeries ℤ ℤ etaProd ^ 24) ^ (ℓ - 1)) :
+    ∃ M : ℕ, 1 ≤ M ∧ (M : K) ≠ 0 ∧ ∃ G : Polynomial K, G.natDegree = M
+      ∧ Polynomial.aeval (jqModC K) G
+          * (HahnSeries.single (1 : ℤ) (1 : K)
+              * HahnSeries.ofPowerSeries ℤ K
+                  (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^ M = 1 :=
+  ModularCurve.StarBank.starK K hHasse
+
+end S_ModularCurve_StarBank_starK
+end P2MW
+export P2MW.S_ModularCurve_StarBank_starK (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open HahnSeries PowerSeries ModularCurve
+theorem ModularCurve.StarBank.starK (K : Type*) [Field K] {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ]
+    (hHasse : 5 ≤ ℓ → ∃ (T : PowerSeries ℤ) (G : Polynomial ℤ),
+        (∀ m, 1 ≤ m → (ℓ : ℤ) ∣ T.coeff m) ∧ ¬ (ℓ : ℤ) ∣ PowerSeries.constantCoeff T
+        ∧ G.natDegree = ℓ - 1 ∧ G.coeff (ℓ - 1) = PowerSeries.constantCoeff T
+        ∧ HahnSeries.ofPowerSeries ℤ ℤ T
+            = Polynomial.aeval (jqModC ℤ) G
+              * (HahnSeries.single (1 : ℤ) (1 : ℤ)
+                  * HahnSeries.ofPowerSeries ℤ ℤ etaProd ^ 24) ^ (ℓ - 1)) :
+    ∃ M : ℕ, 1 ≤ M ∧ (M : K) ≠ 0 ∧ ∃ G : Polynomial K, G.natDegree = M
+      ∧ Polynomial.aeval (jqModC K) G
+          * (HahnSeries.single (1 : ℤ) (1 : K)
+              * HahnSeries.ofPowerSeries ℤ K
+                  (PowerSeries.map (Int.castRingHom K) etaProd) ^ 24) ^ M = 1 :=
+  solution K hHasse
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_TatePoint_b3Act_dictN_of_monodromy.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_TatePoint_b3Act_dictN_of_monodromy.lean
new file mode 100644
index 0000000000..65c54c46ae
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_TatePoint_b3Act_dictN_of_monodromy.lean
@@ -0,0 +1,258 @@
+/-
+Based on Prove2Me node ModularCurve.TatePoint.b3Act_dictN_of_monodromy
+(9fb411a8-cad4-5c09-bfa5-c4106b960394) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4b381b7c-062b-569d-a82b-385836cfa01c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CycSubRootBridgeN
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_SpecialisationBridge
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Monodromy equivariance of the level-N dictionary
+
+Theorem statement: `ModularCurve.TatePoint.b3Act_dictN_of_monodromy`
+(`9fb411a8-cad4-5c09-bfa5-c4106b960394`), by Claude, 2026-09-05.
+
+Proof: submission `4b381b7c-062b-569d-a82b-385836cfa01c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N \geq 1$ and $j_0 \in \overline{\mathbb{Q}}$, write $H =
+\mathrm{HahnSeries}\,\mathbb{Q}\,\overline{\mathbb{Q}}$ for the Hahn series field with rational
+exponents over $\overline{\mathbb{Q}}$, and assume the three level-$N$ hypotheses
+`FullKernelIsRootAt N`, `FullKernelInjAt N`, `FullKernelDiscAt N`: respectively, that for an
+elliptic $W/H$ and a point $Q$ of additive order $N$ with
+$(W.\mathrm{fullKernelQuotient}\,Q\,N).\Delta \neq 0$ the $j$-invariant of that quotient is a root
+of $\Phi$ specialised at $W.j$, for every datum; that when $W.j$ is transcendental over $\mathbb{Q}$
+two such points $Q,Q'$ with equal quotient $j$-invariants generate the same subgroup $\mathbb{Z}Q =
+\mathbb{Z}Q'$; and that over any algebraically closed field of characteristic $\neq 2$ the quotient
+by the group generated by a point of order $N$ has nonzero discriminant. The assertion is: for every
+modular polynomial datum `data` of level $N$ (a monic $\Phi \in \mathbb{Z}[X][Y]$ of degree
+$\psi(N)$ vanishing on the $q$-expansion pair), every element $m$ of the monodromy subgroup (the
+image under `hahnTwistHom` of the characters $\chi : \mathbb{Q} \to \overline{\mathbb{Q}}^{\times}$
+with $\chi(1) = 1$, acting on Hahn series by scaling the coefficient of exponent $a$ by $\chi(a)$),
+and all $r, r'$ roots in $H$ of $\Phi$ specialised at the $j$-invariant of the near curve
+$\mathrm{ofJ}(j_0 + t)$ with $r' = m(r)$, the pushforward of subgroups along `nearTransport j₀ m`
+sends the underlying cyclic subgroup of order $N$ that `dictN` attaches to $r$ to the one it
+attaches to $r'$.
+
+This is the monodromy equivariance of the root/cyclic-subgroup dictionary at level $N$: the
+bijection between roots of the modular polynomial at the near curve and order-$N$ cyclic subgroups
+of its points intertwines the Galois-type action of the monodromy group on roots with transport of
+subgroups along the induced automorphism of the near model. It is used by
+[`ModularCurve.exists_elliptic_cycSub_orbitMap`]
+(thm.html#ModularCurve.exists_elliptic_cycSub_orbitMap),
+where equivariance turns the bijection of sets into a map of monodromy orbits for the subsequent
+counting argument.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_TatePoint_b3Act_dictN_of_monodromy.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_TatePoint_b3Act_dictN_of_monodromy
+
+open scoped Classical
+
+noncomputable section
+
+namespace S15CycSubN
+
+open ModularCurve ModularCurve.TatePoint ModularCurve.B3 WeierstrassCurve
+
+attribute [local instance] ModularCurve.TatePoint.isAlgClosed_H ModularCurve.TatePoint.charZero_H
+
+theorem veluGx_map {R S : Type*} [CommRing R] [CommRing S] (W : WeierstrassCurve R) (φ : R →+* S)
+    (x y : R) : (W.map φ).veluGx (φ x) (φ y) = φ (W.veluGx x y) := by
+  simp only [veluGx, map_a₁, map_a₂, map_a₄, map_sub, map_add, map_mul, map_pow, map_ofNat]
+
+theorem veluGy_map {R S : Type*} [CommRing R] [CommRing S] (W : WeierstrassCurve R) (φ : R →+* S)
+    (x y : R) : (W.map φ).veluGy (φ x) (φ y) = φ (W.veluGy x y) := by
+  simp only [veluGy, map_a₁, map_a₃, map_neg, map_add, map_mul, map_ofNat]
+
+theorem veluQuotientOfSums_map {R S : Type*} [CommRing R] [CommRing S] (W : WeierstrassCurve R)
+    (φ : R →+* S) (t w : R) :
+    (W.veluQuotientOfSums t w).map φ = (W.map φ).veluQuotientOfSums (φ t) (φ w) := by
+  ext
+  · simp only [map_a₁, veluQuotientOfSums_a₁]
+  · simp only [map_a₂, veluQuotientOfSums_a₂]
+  · simp only [map_a₃, veluQuotientOfSums_a₃]
+  · simp only [map_a₄, veluQuotientOfSums_a₄, map_sub, map_mul, map_ofNat]
+  · simp only [map_a₆, veluQuotientOfSums_a₆, map_b₂, map_sub, map_mul, map_ofNat]
+
+theorem j_congr {V V' : WeierstrassCurve H} (h : V = V') (hV : V.IsElliptic) (hV' : V'.IsElliptic) :
+    @WeierstrassCurve.j H _ V hV = @WeierstrassCurve.j H _ V' hV' := by
+  subst h; rfl
+
+section Transport
+
+variable (j₀ : Qbar) (m : HahnSeries.monodromy Qbar)
+
+theorem coordsOrZero_nearTransport (P : (nearCurve j₀).toAffine.Point) :
+    (nearTransport j₀ m P).coordsOrZero =
+      Prod.map ((m : H ≃ₐ[Qbar] H) : H →+* H) ((m : H ≃ₐ[Qbar] H) : H →+* H) P.coordsOrZero := by
+  rcases P with _ | ⟨x, y, h⟩
+  · have h0 : nearTransport j₀ m (Affine.Point.zero) = Affine.Point.zero :=
+      map_zero (nearTransport j₀ m)
+    rw [h0, Affine.Point.coordsOrZero_zero]
+    ext <;> simp
+  · rw [nearTransport_some]
+    rfl
+
+theorem oddOrderSummingSet_nearTransport (g : (nearCurve j₀).toAffine.Point) (n : ℕ) :
+    (nearCurve j₀).oddOrderSummingSet (nearTransport j₀ m g) n =
+      ((nearCurve j₀).oddOrderSummingSet g n).image
+        (Prod.map ((m : H ≃ₐ[Qbar] H) : H →+* H) ((m : H ≃ₐ[Qbar] H) : H →+* H)) := by
+  simp only [WeierstrassCurve.oddOrderSummingSet, Finset.image_image]
+  congr 1
+  funext k
+  rw [Function.comp_apply, ← coordsOrZero_nearTransport, map_nsmul]
+
+theorem addOrderOf_nearTransport (P : (nearCurve j₀).toAffine.Point) :
+    addOrderOf (nearTransport j₀ m P) = addOrderOf P := by
+  rw [addOrderOf_eq_addOrderOf_iff]
+  intro n
+  rw [← map_nsmul]
+  simpa only [map_zero] using
+    (show nearTransport j₀ m (n • P) = nearTransport j₀ m 0 ↔ n • P = 0 from
+      (nearTransport j₀ m).injective.eq_iff)
+
+theorem fullKernelQuotient_nearTransport (Q : (nearCurve j₀).toAffine.Point) (N : ℕ) :
+    (nearCurve j₀).fullKernelQuotient (nearTransport j₀ m Q) N =
+      ((nearCurve j₀).fullKernelQuotient Q N).map ((m : H ≃ₐ[Qbar] H) : H →+* H) := by
+  have hE := nearCurve_map_of_mem_monodromy j₀ m.2
+  have hinj : Function.Injective
+      (Prod.map ((m : H ≃ₐ[Qbar] H) : H →+* H) ((m : H ≃ₐ[Qbar] H) : H →+* H)) :=
+    Prod.map_injective.mpr ⟨(m : H ≃ₐ[Qbar] H).injective, (m : H ≃ₐ[Qbar] H).injective⟩
+  have hgx : ∀ x y : H, (nearCurve j₀).veluGx ((m : H ≃ₐ[Qbar] H) x) ((m : H ≃ₐ[Qbar] H) y) =
+      (m : H ≃ₐ[Qbar] H) ((nearCurve j₀).veluGx x y) := fun x y => by
+    have h := veluGx_map (nearCurve j₀) ((m : H ≃ₐ[Qbar] H) : H →+* H) x y
+    rw [hE] at h
+    exact h
+  have hgy : ∀ x y : H, (nearCurve j₀).veluGy ((m : H ≃ₐ[Qbar] H) x) ((m : H ≃ₐ[Qbar] H) y) =
+      (m : H ≃ₐ[Qbar] H) ((nearCurve j₀).veluGy x y) := fun x y => by
+    have h := veluGy_map (nearCurve j₀) ((m : H ≃ₐ[Qbar] H) : H →+* H) x y
+    rw [hE] at h
+    exact h
+  have hq := veluQuotientOfSums_map (nearCurve j₀) ((m : H ≃ₐ[Qbar] H) : H →+* H)
+  rw [hE] at hq
+  rw [fullKernelQuotient, fullKernelQuotient, hq, oddOrderSummingSet_nearTransport,
+    Finset.sum_image (hinj.injOn.mono (Set.subset_univ _)),
+    Finset.sum_image (hinj.injOn.mono (Set.subset_univ _)), map_sum, map_sum]
+  congr 1
+  · refine Finset.sum_congr rfl fun P _ => ?_
+    obtain ⟨x, y⟩ := P
+    exact hgx x y
+  · refine Finset.sum_congr rfl fun P _ => ?_
+    obtain ⟨x, y⟩ := P
+    change (m : H ≃ₐ[Qbar] H) x * (nearCurve j₀).veluGx ((m : H ≃ₐ[Qbar] H) x) ((m : H ≃ₐ[Qbar] H)
+      y) -
+        (m : H ≃ₐ[Qbar] H) y * (nearCurve j₀).veluGy ((m : H ≃ₐ[Qbar] H) x) ((m : H ≃ₐ[Qbar] H) y) =
+      (m : H ≃ₐ[Qbar] H) (x * (nearCurve j₀).veluGx x y - y * (nearCurve j₀).veluGy x y)
+    rw [map_sub, map_mul, map_mul, hgx, hgy]
+
+theorem j_fullKernelQuotient_nearTransport (Q : (nearCurve j₀).toAffine.Point) (N : ℕ)
+    (hQ : ((nearCurve j₀).fullKernelQuotient Q N).IsElliptic)
+    (hQ' : ((nearCurve j₀).fullKernelQuotient (nearTransport j₀ m Q) N).IsElliptic) :
+    @WeierstrassCurve.j H _ _ hQ' = (m : H ≃ₐ[Qbar] H) (@WeierstrassCurve.j H _ _ hQ) := by
+  have := hQ
+  rw [j_congr (fullKernelQuotient_nearTransport j₀ m Q N) hQ' inferInstance]
+  exact WeierstrassCurve.map_j _ _
+
+end Transport
+
+theorem b3Act_dictN_of_monodromy (N : ℕ) [NeZero N] (j₀ : Qbar)
+    (hW1 : FullKernelIsRootAt N) (hW2 : FullKernelInjAt N) (hW3 : FullKernelDiscAt N) :
+    ∀ (data : ModularPolynomialData N) (m : HahnSeries.monodromy Qbar)
+      (r r' : RootsAt data (nearCurve j₀).j),
+      r'.1 = (↑m : H ≃ₐ[Qbar] H) r.1 →
+        B3.b3Act j₀ m (dictN N data j₀ hW1 hW2 hW3 r).1 =
+          (dictN N data j₀ hW1 hW2 hW3 r').1 := by
+  intro data m r r' hr
+  set G : CycSubH (nearCurve j₀) N := dictN N data j₀ hW1 hW2 hW3 r with hGdef
+  set G'' : CycSubH (nearCurve j₀) N := dictN N data j₀ hW1 hW2 hW3 r' with hG''def
+  have hA1 : r = cycSubRootN (nearCurve j₀) hW1 hW3 data G :=
+    (dictN_apply_eq_iff N data j₀ hW1 hW2 hW3 r G).mp hGdef.symm
+  have hA2 : r' = cycSubRootN (nearCurve j₀) hW1 hW3 data G'' :=
+    (dictN_apply_eq_iff N data j₀ hW1 hW2 hW3 r' G'').mp hG''def.symm
+  have hordτg : addOrderOf (nearTransport j₀ m (cycSubGen (nearCurve j₀) G)) = N := by
+    rw [addOrderOf_nearTransport]; exact addOrderOf_cycSubGen _ G
+  have hQel : ((nearCurve j₀).fullKernelQuotient (cycSubGen (nearCurve j₀) G) N).IsElliptic :=
+    isElliptic_fullKernelQuotient_cycSubGen (nearCurve j₀) hW3 G
+  have hΔ' : ((nearCurve j₀).fullKernelQuotient
+      (nearTransport j₀ m (cycSubGen (nearCurve j₀) G)) N).Δ ≠ 0 :=
+    hW3 two_ne_zero (nearCurve j₀) _ hordτg
+  have hQel' : ((nearCurve j₀).fullKernelQuotient
+      (nearTransport j₀ m (cycSubGen (nearCurve j₀) G)) N).IsElliptic :=
+    ⟨isUnit_iff_ne_zero.mpr hΔ'⟩
+  have hB := j_fullKernelQuotient_nearTransport j₀ m (cycSubGen (nearCurve j₀) G) N hQel hQel'
+  have hjj : (cycSubRootN (nearCurve j₀) hW1 hW3 data G'').1 = @WeierstrassCurve.j H _ _ hQel' := by
+    calc (cycSubRootN (nearCurve j₀) hW1 hW3 data G'').1
+        = r'.1 := by rw [← hA2]
+      _ = (m : H ≃ₐ[Qbar] H) r.1 := hr
+      _ = (m : H ≃ₐ[Qbar] H) (cycSubRootN (nearCurve j₀) hW1 hW3 data G).1 := by rw [← hA1]
+      _ = (m : H ≃ₐ[Qbar] H) (@WeierstrassCurve.j H _ _ hQel) := rfl
+      _ = @WeierstrassCurve.j H _ _ hQel' := hB.symm
+  have hzm : AddSubgroup.zmultiples (cycSubGen (nearCurve j₀) G'') =
+      AddSubgroup.zmultiples (nearTransport j₀ m (cycSubGen (nearCurve j₀) G)) :=
+    hW2 (nearCurve j₀) (transcendental_rat_of_transcendental_qbar (nearCurve_j_transcendental j₀))
+      (cycSubGen (nearCurve j₀) G'') (nearTransport j₀ m (cycSubGen (nearCurve j₀) G))
+      (addOrderOf_cycSubGen _ G'') hordτg
+      (isElliptic_fullKernelQuotient_cycSubGen (nearCurve j₀) hW3 G'').isUnit.ne_zero hΔ' hjj
+  calc B3.b3Act j₀ m G.1
+      = B3.b3Act j₀ m (AddSubgroup.zmultiples (cycSubGen (nearCurve j₀) G)) := by
+        rw [← coe_eq_zmultiples_cycSubGen]
+    _ = AddSubgroup.zmultiples (nearTransport j₀ m (cycSubGen (nearCurve j₀) G)) :=
+        b3Act_zmultiples j₀ m (cycSubGen (nearCurve j₀) G)
+    _ = AddSubgroup.zmultiples (cycSubGen (nearCurve j₀) G'') := hzm.symm
+    _ = G''.1 := (coe_eq_zmultiples_cycSubGen (nearCurve j₀) G'').symm
+
+end S15CycSubN
+
+open ModularCurve ModularCurve.TatePoint in
+theorem solution (N : ℕ) [NeZero N] (j₀ : Qbar)
+    (hW1 : FullKernelIsRootAt N) (hW2 : FullKernelInjAt N) (hW3 : FullKernelDiscAt N) :
+    ∀ (data : ModularPolynomialData N) (m : HahnSeries.monodromy Qbar)
+      (r r' : RootsAt data (nearCurve j₀).j),
+      r'.1 = (↑m : H ≃ₐ[Qbar] H) r.1 →
+        B3.b3Act j₀ m (dictN N data j₀ hW1 hW2 hW3 r).1 =
+          (dictN N data j₀ hW1 hW2 hW3 r').1 :=
+  S15CycSubN.b3Act_dictN_of_monodromy N j₀ hW1 hW2 hW3
+
+end
+
+end S_ModularCurve_TatePoint_b3Act_dictN_of_monodromy
+end P2MW
+export P2MW.S_ModularCurve_TatePoint_b3Act_dictN_of_monodromy (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Classical
+theorem ModularCurve.TatePoint.b3Act_dictN_of_monodromy (N : ℕ) [NeZero N] (j₀ : Qbar)
+    (hW1 : FullKernelIsRootAt N) (hW2 : FullKernelInjAt N) (hW3 : FullKernelDiscAt N) :
+    ∀ (data : ModularPolynomialData N) (m : HahnSeries.monodromy Qbar)
+      (r r' : RootsAt data (nearCurve j₀).j),
+      r'.1 = (↑m : H ≃ₐ[Qbar] H) r.1 →
+        B3.b3Act j₀ m (dictN N data j₀ hW1 hW2 hW3 r).1 =
+          (dictN N data j₀ hW1 hW2 hW3 r').1 :=
+  solution N j₀ hW1 hW2 hW3
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_TatePoint_fullKernelDiscAt.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_TatePoint_fullKernelDiscAt.lean
new file mode 100644
index 0000000000..cbc4b79ead
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_TatePoint_fullKernelDiscAt.lean
@@ -0,0 +1,775 @@
+/-
+Based on Prove2Me node ModularCurve.TatePoint.fullKernelDiscAt
+(776cd2c0-e88a-5f6f-b499-83c9fe48469e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 950ed5c1-103f-588c-b746-7faeb68f5b73
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CycSubRootBridgeN
+
+import Mathlib.Algebra.Field.ZMod
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluPointMap2
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_addMonoidHom_coe_eq_veluPointMap2
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_fiberAdd_veluGx_cleared_four
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_fiberAdd_asymWeight_cleared_sixteen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_TatePoint_fullKernelDiscAt_of_odd
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_isElliptic_veluQuotient2_of_isElliptic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_two_smul_some_eq_zero_iff
+
+/-!
+# Nonvanishing discriminant of the full-kernel quotient at every level
+
+Theorem statement: `ModularCurve.TatePoint.fullKernelDiscAt`
+(`776cd2c0-e88a-5f6f-b499-83c9fe48469e`), by Claude, 2026-09-05.
+
+Proof: submission `950ed5c1-103f-588c-b746-7faeb68f5b73`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number. The assertion is the predicate `FullKernelDiscAt N`, namely:
+for every algebraically closed field $L$ (in the base universe, with decidable equality) in which $2
+\neq 0$, every Weierstrass curve $W$ over $L$ that is elliptic, and every point $Q$ of the affine
+curve $W$ whose additive order `addOrderOf Q` equals $N$, the Weierstrass curve
+`W.fullKernelQuotient Q N` has nonzero discriminant, $\Delta \neq 0$. Here `W.fullKernelQuotient Q
+N` is the curve `W.veluQuotientOfSums s t` built from the two Vélu sums taken over the finite set
+`W.oddOrderSummingSet Q (N - 1)`: the first argument is $s = \sum_P \mathrm{veluGx}(P_1, P_2)$ and
+the second is $t = \sum_P \bigl(P_1 \cdot \mathrm{veluGx}(P_1,P_2) - P_2 \cdot
+\mathrm{veluGy}(P_1,P_2)\bigr)$, the sums running over the coordinate pairs $P$ of that set. Thus
+the conclusion is that for every level $N$, even as well as odd, the Vélu-type quotient of $W$ by
+the cyclic group generated by a point of exact order $N$ is again nondegenerate.
+
+This is the nondegeneracy statement for the quotient of an elliptic curve by a cyclic subgroup of
+order $N$ computed by Vélu's formulae: the quotient curve is again elliptic, which is what makes
+statements about its $j$-invariant meaningful. It is used by
+[`ModularCurve.exists_elliptic_cycSub_orbitMap`]
+(thm.html#ModularCurve.exists_elliptic_cycSub_orbitMap),
+in the construction of elliptic curves with prescribed cyclic subgroup data on the modular curve
+side.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_TatePoint_fullKernelDiscAt.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace KernelTower
+
+theorem mem_zmultiples_iff_of_two_nsmul_eq_zero {A : Type*} [AddCommGroup A] {T : A}
+    (hT : 2 • T = 0) (x : A) : x ∈ AddSubgroup.zmultiples T ↔ x = 0 ∨ x = T := by
+  constructor
+  · intro hx
+    rw [AddSubgroup.mem_zmultiples_iff] at hx
+    obtain ⟨k, rfl⟩ := hx
+    have h2 : (2 : ℤ) • T = 0 := by rw [two_zsmul, ← two_nsmul, hT]
+    rcases Int.emod_two_eq_zero_or_one k with h | h
+    · left
+      obtain ⟨c, rfl⟩ := Int.dvd_of_emod_eq_zero h
+      rw [mul_comm, mul_zsmul, h2, zsmul_zero]
+    · right
+      have hk : k = 2 * (k / 2) + 1 := by omega
+      rw [hk, add_zsmul, one_zsmul, mul_comm, mul_zsmul, h2, zsmul_zero, zero_add]
+  · rintro (rfl | rfl)
+    · exact AddSubgroup.zero_mem _
+    · exact AddSubgroup.mem_zmultiples _
+
+theorem dvd_of_nsmul_mem_zmultiples_nsmul {A : Type*} [AddCommGroup A] {Q : A} {M : ℕ}
+    (hQ : addOrderOf Q = 2 * M) {k : ℕ} (hk : k • Q ∈ AddSubgroup.zmultiples (M • Q)) :
+    M ∣ k := by
+  rw [AddSubgroup.mem_zmultiples_iff] at hk
+  obtain ⟨z, hz⟩ := hk
+  have h0 : ((k : ℤ) - z * M) • Q = 0 := by
+    rw [sub_zsmul, natCast_zsmul, ← hz, mul_zsmul, natCast_zsmul, add_neg_cancel]
+  have hdvd : ((addOrderOf Q : ℕ) : ℤ) ∣ (k : ℤ) - z * M :=
+    (addOrderOf_dvd_iff_zsmul_eq_zero).mpr h0
+  rw [hQ, Nat.cast_mul, Nat.cast_ofNat] at hdvd
+  have hM : (M : ℤ) ∣ (k : ℤ) - z * M := (Dvd.intro_left 2 rfl).trans hdvd
+  have hk' : (M : ℤ) ∣ (k : ℤ) := by
+    have := Int.dvd_add hM (Dvd.intro_left z rfl : (M : ℤ) ∣ z * M)
+    rwa [sub_add_cancel] at this
+  exact Int.natCast_dvd_natCast.mp hk'
+
+theorem addOrderOf_map_of_ker_eq_zmultiples {A B : Type*} [AddCommGroup A] [AddCommGroup B]
+    (φ : A →+ B) {Q : A} {M : ℕ} (hM : M ≠ 0) (hQ : addOrderOf Q = 2 * M)
+    (hker : φ.ker = AddSubgroup.zmultiples (M • Q)) : addOrderOf (φ Q) = M := by
+  refine (addOrderOf_eq_iff (Nat.pos_of_ne_zero hM)).mpr ⟨?_, fun k hkM hk0 hk => ?_⟩
+  · rw [← map_nsmul, ← AddMonoidHom.mem_ker, hker]
+    exact AddSubgroup.mem_zmultiples _
+  · rw [← map_nsmul, ← AddMonoidHom.mem_ker, hker] at hk
+    exact absurd (Nat.le_of_dvd hk0 (dvd_of_nsmul_mem_zmultiples_nsmul hQ hk)) (not_le.mpr hkM)
+
+theorem ker_le_zmultiples_of_ker_eq {A B : Type*} [AddCommGroup A] [AddCommGroup B]
+    (φ : A →+ B) {Q : A} {M : ℕ} (hker : φ.ker = AddSubgroup.zmultiples (M • Q)) :
+    φ.ker ≤ AddSubgroup.zmultiples Q := by
+  rw [hker, AddSubgroup.zmultiples_le]
+  exact AddSubgroup.nsmul_mem _ (AddSubgroup.mem_zmultiples Q) M
+
+theorem ker_comp_eq_zmultiples {A B C : Type*} [AddCommGroup A] [AddCommGroup B]
+    [AddCommGroup C] (φ : A →+ B) (ψ : B →+ C) {Q : A}
+    (hφ : φ.ker ≤ AddSubgroup.zmultiples Q) (hψ : ψ.ker = AddSubgroup.zmultiples (φ Q)) :
+    (ψ.comp φ).ker = AddSubgroup.zmultiples Q := by
+  ext x
+  rw [AddMonoidHom.mem_ker, AddMonoidHom.comp_apply]
+  constructor
+  · intro hx
+    have hx' : φ x ∈ ψ.ker := hx
+    rw [hψ, AddSubgroup.mem_zmultiples_iff] at hx'
+    obtain ⟨k, hk⟩ := hx'
+    have hmem : x - k • Q ∈ φ.ker := by
+      rw [AddMonoidHom.mem_ker, map_sub, map_zsmul, hk, sub_self]
+    have hk' : k • Q ∈ AddSubgroup.zmultiples Q :=
+      AddSubgroup.zsmul_mem _ (AddSubgroup.mem_zmultiples Q) k
+    simpa using AddSubgroup.add_mem _ (hφ hmem) hk'
+  · intro hx
+    rw [AddSubgroup.mem_zmultiples_iff] at hx
+    obtain ⟨k, rfl⟩ := hx
+    have h0 : ψ (φ Q) = 0 := by
+      rw [← AddMonoidHom.mem_ker, hψ]
+      exact AddSubgroup.mem_zmultiples _
+    rw [map_zsmul, map_zsmul, h0, zsmul_zero]
+
+theorem natCard_zmultiples_of_addOrderOf_eq {A : Type*} [AddCommGroup A] (Q : A) {N : ℕ}
+    (hQ : addOrderOf Q = N) : Nat.card (AddSubgroup.zmultiples Q) = N := by
+  rw [Nat.card_zmultiples, hQ]
+
+theorem nsmul_not_mem_ker {A B : Type*} [AddCommGroup A] [AddCommGroup B] (φ : A →+ B)
+    {Q : A} {M : ℕ} (hQ : addOrderOf Q = 2 * M)
+    (hker : φ.ker = AddSubgroup.zmultiples (M • Q)) {k : ℕ} (hk0 : 0 < k) (hk2 : k < 2 * M)
+    (hkM : k ≠ M) : k • Q ∉ φ.ker := by
+  rw [hker]
+  intro hk
+  obtain ⟨c, rfl⟩ := dvd_of_nsmul_mem_zmultiples_nsmul hQ hk
+  rcases c with _ | _ | c
+  · exact absurd rfl (Nat.pos_iff_ne_zero.mp hk0)
+  · exact hkM (mul_one M)
+  · exact absurd hk2 (by nlinarith)
+
+theorem addOrderOf_veluPointMap2 {F : Type*} [Field F] [DecidableEq F] (hchar : (2 : F) ≠ 0)
+    (W : WeierstrassCurve F) [W.IsElliptic] (Q : W.toAffine.Point) (M : ℕ) (hM : M ≠ 0)
+    (hQ : addOrderOf Q = 2 * M)
+    {x₀ y₀ : F} {h₀ : W.toAffine.Nonsingular x₀ y₀} (hMQ : M • Q = .some x₀ y₀ h₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hΔ₂ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0)
+    (hker₀ : ∀ P : W.toAffine.Point,
+      WeierstrassCurve.veluPointMap2 hchar h₀.1 hgy hΔ₂ P = 0 ↔ P = 0 ∨ P = .some x₀ y₀ h₀) :
+    addOrderOf (WeierstrassCurve.veluPointMap2 hchar h₀.1 hgy hΔ₂ Q) = M := by
+  obtain ⟨φ, hφ⟩ := W.exists_addMonoidHom_coe_eq_veluPointMap2 hchar h₀.1 hgy hΔ₂
+  have h2MQ : 2 • (M • Q) = 0 := by
+    rw [← mul_nsmul', ← hQ]
+    exact addOrderOf_nsmul_eq_zero Q
+  have hker : φ.ker = AddSubgroup.zmultiples (M • Q) := by
+    ext P
+    rw [AddMonoidHom.mem_ker, congrFun hφ P, hker₀ P,
+      mem_zmultiples_iff_of_two_nsmul_eq_zero h2MQ, hMQ]
+  have h := addOrderOf_map_of_ker_eq_zmultiples φ hM hQ hker
+  rwa [congrFun hφ Q] at h
+
+example : addOrderOf (AddMonoidHom.mulLeft (2 : ZMod 4) 1) = 2 :=
+  addOrderOf_map_of_ker_eq_zmultiples (AddMonoidHom.mulLeft (2 : ZMod 4)) (Q := 1) (M := 2)
+    two_ne_zero (by rw [ZMod.addOrderOf_one]) (by
+      ext x
+      rw [AddMonoidHom.mem_ker, AddMonoidHom.coe_mulLeft,
+        mem_zmultiples_iff_of_two_nsmul_eq_zero (by decide)]
+      revert x
+      decide)
+
+example : ((AddMonoidHom.mulLeft (2 : ZMod 4)).comp (AddMonoidHom.mulLeft (2 : ZMod 4))).ker =
+    AddSubgroup.zmultiples (1 : ZMod 4) := by
+  have hker : (AddMonoidHom.mulLeft (2 : ZMod 4)).ker = AddSubgroup.zmultiples (2 • (1 : ZMod 4)) :=
+    by
+    ext x
+    rw [AddMonoidHom.mem_ker, AddMonoidHom.coe_mulLeft,
+      mem_zmultiples_iff_of_two_nsmul_eq_zero (by decide)]
+    revert x
+    decide
+  refine ker_comp_eq_zmultiples _ _ (ker_le_zmultiples_of_ker_eq _ hker) ?_
+  rw [hker, AddMonoidHom.coe_mulLeft]
+  rfl
+
+end KernelTower
+
+namespace WeierstrassCurve
+
+namespace VeluTwoKernel
+
+theorem negY_eq_of_veluGy_eq_zero {R : Type*} [CommRing R] {W : WeierstrassCurve R}
+    {x₀ y₀ : R} (hgy : W.veluGy x₀ y₀ = 0) : W.toAffine.negY x₀ y₀ = y₀ := by
+  simp only [veluGy] at hgy
+  simp only [Affine.negY]
+  linear_combination hgy
+
+theorem eq_of_equation_of_veluGy_eq_zero {F : Type*} [Field F] {W : WeierstrassCurve F}
+    {x₀ y₀ : F} (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0)
+    {y : F} (h : W.toAffine.Equation x₀ y) : y = y₀ := by
+  rcases Affine.Y_eq_of_X_eq h hQ rfl with hy | hy
+  · exact hy
+  · rw [hy, negY_eq_of_veluGy_eq_zero hgy]
+
+theorem some_eq_some_of_veluGy_eq_zero {F : Type*} [Field F] {W : WeierstrassCurve F}
+    {x₀ y₀ : F} (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0)
+    (hns : W.toAffine.Nonsingular x₀ y₀) {x y : F} (h : W.toAffine.Nonsingular x y)
+    (hx : x = x₀) : (.some x y h : W.toAffine.Point) = .some x₀ y₀ hns := by
+  have hy : y = y₀ := eq_of_equation_of_veluGy_eq_zero hQ hgy (hx ▸ h.left)
+  subst hx
+  subst hy
+  rfl
+
+theorem veluPointMap2_eq_zero_iff {F : Type*} [Field F] {W : WeierstrassCurve F}
+    (h2 : (2 : F) ≠ 0) {x₀ y₀ : F} (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hΔ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0)
+    (hns : W.toAffine.Nonsingular x₀ y₀) (P : W.toAffine.Point) :
+    veluPointMap2 h2 hQ hgy hΔ P = 0 ↔ P = 0 ∨ P = .some x₀ y₀ hns := by
+  constructor
+  · intro hP
+    cases P with
+    | zero => exact Or.inl rfl
+    | some x y h =>
+      by_cases hx : x = x₀
+      · exact Or.inr (some_eq_some_of_veluGy_eq_zero hQ hgy hns h hx)
+      · rw [veluPointMap2_some_of_ne h2 hQ hgy hΔ h hx] at hP
+        exact absurd hP (Affine.Point.some_ne_zero _)
+  · rintro (rfl | rfl)
+    · exact veluPointMap2_zero h2 hQ hgy hΔ
+    · exact veluPointMap2_some_of_eq h2 hQ hgy hΔ hns rfl
+
+theorem ker_eq_zmultiples {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F}
+    (h2 : (2 : F) ≠ 0) {x₀ y₀ : F} (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hΔ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0)
+    (hns : W.toAffine.Nonsingular x₀ y₀)
+    (φ : W.toAffine.Point →+ (W.veluQuotient2 x₀ y₀).toAffine.Point)
+    (hφ : ∀ P, φ P = veluPointMap2 h2 hQ hgy hΔ P) :
+    φ.ker = AddSubgroup.zmultiples (.some x₀ y₀ hns) := by
+  refine le_antisymm ?_ (AddSubgroup.zmultiples_le.mpr ?_)
+  · intro P hP
+    rw [AddMonoidHom.mem_ker, hφ P] at hP
+    rcases (veluPointMap2_eq_zero_iff h2 hQ hgy hΔ hns P).mp hP with rfl | rfl
+    · exact zero_mem _
+    · exact AddSubgroup.mem_zmultiples _
+  · rw [AddMonoidHom.mem_ker, hφ]
+    exact veluPointMap2_some_of_eq h2 hQ hgy hΔ hns rfl
+end WeierstrassCurve.VeluTwoKernel
+
+namespace WeierstrassCurve
+
+section FiberField
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+private theorem _root_.WeierstrassCurve.xnum_eq {x y x₀ y₀ l x' : F}
+    (hl : l * (x - x₀) = y - y₀)
+    (hx'd : x' = l ^ 2 + W.a₁ * l - W.a₂ - x - x₀) :
+    x' * (x - x₀) ^ 2 = ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2)
+      := by
+  rw [hx'd]
+  linear_combination (l * (x - x₀) + (y - y₀) + W.a₁ * (x - x₀)) * hl
+
+private theorem _root_.WeierstrassCurve.ynum_eq {x y x₀ y₀ l x' y' : F}
+    (hl : l * (x - x₀) = y - y₀)
+    (hx'd : x' = l ^ 2 + W.a₁ * l - W.a₂ - x - x₀)
+    (hy'd : y' = l * (x - x') - y - W.a₁ * x' - W.a₃) :
+    y' * (x - x₀) ^ 3 = ((y - y₀) * (x * (x - x₀) ^ 2 - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) -
+      (W.a₂ + x + x₀) * (x - x₀) ^ 2)) - y * (x - x₀) ^ 3 - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) *
+      (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (x - x₀) - W.a₃ * (x - x₀) ^ 3) := by
+  have hXn := W.xnum_eq hl hx'd
+  rw [hy'd]
+  linear_combination (x * (x - x₀) ^ 2 - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x +
+    x₀) * (x - x₀) ^ 2)) * hl
+    - (l + W.a₁) * (x - x₀) * hXn
+
+private theorem _root_.WeierstrassCurve.fiberAdd_veluGx_field (hchar : (2 : F) ≠ 0)
+    {x y x₀ y₀ l x' y' : F}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hx : x ≠ x₀)
+    (hl : l * (x - x₀) = y - y₀)
+    (hx'd : x' = l ^ 2 + W.a₁ * l - W.a₂ - x - x₀)
+    (hy'd : y' = l * (x - x') - y - W.a₁ * x' - W.a₃) :
+    W.veluGx x y + W.veluGx x' y'
+      = 3 * (x + W.veluGx x₀ y₀ / (x - x₀)) ^ 2 + 2 * W.a₂ * (x + W.veluGx x₀ y₀ / (x - x₀)) + (W.a₄
+        - 5 * W.veluGx x₀ y₀) - W.a₁ * (y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^
+        2) := by
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  have h4 : (4 : F) ≠ 0 := by
+    have h := pow_ne_zero 2 hchar
+    norm_num at h
+    exact h
+  have hXn := W.xnum_eq hl hx'd
+  have hYn := W.ynum_eq hl hx'd hy'd
+  have hXd : (x + W.veluGx x₀ y₀ / (x - x₀)) * (x - x₀) = x * (x - x₀) + W.veluGx x₀ y₀ :=
+    by field_simp
+  have hYd : (y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) * (x - x₀) ^ 2
+      = y * (x - x₀) ^ 2 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) := by field_simp
+  refine mul_right_cancel₀ (mul_ne_zero h4 (pow_ne_zero 4 hd)) ?_
+  calc (W.veluGx x y + W.veluGx x' y') * (4 * (x - x₀) ^ 4)
+      = 4 * (W.veluGx x y * (x - x₀) ^ 4 + (3 * (x' * (x - x₀) ^ 2) ^ 2 + 2 * W.a₂ * (x' * (x - x₀)
+        ^ 2) * (x - x₀) ^ 2 + W.a₄ * (x - x₀) ^ 4 - W.a₁ * (y' * (x - x₀) ^ 3) * (x - x₀))) := by
+        simp only [veluGx]; ring
+    _ = 4 * (W.veluGx x y * (x - x₀) ^ 4 + (3 * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ +
+      x + x₀) * (x - x₀) ^ 2) ^ 2 + 2 * W.a₂ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ +
+      x + x₀) * (x - x₀) ^ 2) * (x - x₀) ^ 2 + W.a₄ * (x - x₀) ^ 4 - W.a₁ * ((y - y₀) * (x * (x -
+      x₀) ^ 2 - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2)) - y *
+      (x - x₀) ^ 3 - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀)
+      ^ 2) * (x - x₀) - W.a₃ * (x - x₀) ^ 3) * (x - x₀))) := by
+      rw [hXn, hYn]
+    _ = 4 * (3 * (x * (x - x₀) ^ 2 + W.veluGx x₀ y₀ * (x - x₀)) ^ 2 + 2 * W.a₂ * (x * (x - x₀) ^ 2 +
+      W.veluGx x₀ y₀ * (x - x₀)) * (x - x₀) ^ 2 + (W.a₄ - 5 * W.veluGx x₀ y₀) * (x - x₀) ^ 4 - W.a₁
+      * (y * (x - x₀) ^ 3 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) * (x - x₀)) * (x - x₀)) :=
+      W.fiberAdd_veluGx_cleared_four x y x₀ y₀ hP hQ hgy
+    _ = (3 * (x + W.veluGx x₀ y₀ / (x - x₀)) ^ 2 + 2 * W.a₂ * (x + W.veluGx x₀ y₀ / (x - x₀)) +
+      (W.a₄ - 5 * W.veluGx x₀ y₀) - W.a₁ * (y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x -
+      x₀) ^ 2))
+          * (4 * (x - x₀) ^ 4) := by
+        rw [show (3 * (x + W.veluGx x₀ y₀ / (x - x₀)) ^ 2 + 2 * W.a₂ * (x + W.veluGx x₀ y₀ / (x -
+          x₀)) + (W.a₄ - 5 * W.veluGx x₀ y₀) - W.a₁ * (y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y -
+          y₀) / (x - x₀) ^ 2))
+              * (4 * (x - x₀) ^ 4)
+          = 4 * (3 * ((x + W.veluGx x₀ y₀ / (x - x₀)) * (x - x₀)) ^ 2 * (x - x₀) ^ 2
+            + 2 * W.a₂ * ((x + W.veluGx x₀ y₀ / (x - x₀)) * (x - x₀)) * (x - x₀) ^ 3
+            + (W.a₄ - 5 * W.veluGx x₀ y₀) * (x - x₀) ^ 4
+            - W.a₁ * ((y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) * (x - x₀) ^
+              2) * (x - x₀) ^ 2) from by
+              ring, hXd, hYd]
+        ring
+
+private theorem _root_.WeierstrassCurve.fiberAdd_asymWeight_field (hchar : (2 : F) ≠ 0) {x y x₀ y₀ l
+    x' y' : F}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hx : x ≠ x₀)
+    (hl : l * (x - x₀) = y - y₀)
+    (hx'd : x' = l ^ 2 + W.a₁ * l - W.a₂ - x - x₀)
+    (hy'd : y' = l * (x - x') - y - W.a₁ * x' - W.a₃) :
+    (x * W.veluGx x y - y * W.veluGy x y) + (x' * W.veluGx x' y' - y' * W.veluGy x' y')
+      = (x + W.veluGx x₀ y₀ / (x - x₀)) * (3 * (x + W.veluGx x₀ y₀ / (x - x₀)) ^ 2 + 2 * W.a₂ * (x +
+          W.veluGx x₀ y₀ / (x - x₀)) + (W.a₄ - 5 * W.veluGx x₀ y₀) - W.a₁ * (y - W.veluGx x₀ y₀ *
+          (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2))
+        - (y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) * (-(2 * (y - W.veluGx x₀
+            y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) + W.a₁ * (x + W.veluGx x₀ y₀ / (x - x₀))
+            + W.a₃)) := by
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  have h16 : (16 : F) ≠ 0 := by
+    have h := pow_ne_zero 4 hchar
+    norm_num at h
+    exact h
+  have hXn := W.xnum_eq hl hx'd
+  have hYn := W.ynum_eq hl hx'd hy'd
+  have hXd : (x + W.veluGx x₀ y₀ / (x - x₀)) * (x - x₀) = x * (x - x₀) + W.veluGx x₀ y₀ :=
+    by field_simp
+  have hYd : (y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) * (x - x₀) ^ 2
+      = y * (x - x₀) ^ 2 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) := by field_simp
+  refine mul_right_cancel₀ (mul_ne_zero h16 (pow_ne_zero 6 hd)) ?_
+  calc ((x * W.veluGx x y - y * W.veluGy x y)
+        + (x' * W.veluGx x' y' - y' * W.veluGy x' y')) * (16 * (x - x₀) ^ 6)
+      = 16 * ((x * W.veluGx x y - y * W.veluGy x y) * (x - x₀) ^ 6 + ((x' * (x - x₀) ^ 2) * (3 * (x'
+          * (x - x₀) ^ 2) ^ 2 + 2 * W.a₂ * (x' * (x - x₀) ^ 2) * (x - x₀) ^ 2 + W.a₄ * (x - x₀) ^ 4
+          - W.a₁ * (y' * (x - x₀) ^ 3) * (x - x₀)) - (y' * (x - x₀) ^ 3) * (-(2 * (y' * (x - x₀) ^
+          3) + W.a₁ * (x' * (x - x₀) ^ 2) * (x - x₀) + W.a₃ * (x - x₀) ^ 3)))) := by
+        simp only [veluGx, veluGy]; ring
+    _ = 16 * ((x * W.veluGx x y - y * W.veluGy x y) * (x - x₀) ^ 6 + (((y - y₀) ^ 2 + W.a₁ * (y -
+        y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (3 * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x
+        - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2) ^ 2 + 2 * W.a₂ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) *
+        (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (x - x₀) ^ 2 + W.a₄ * (x - x₀) ^ 4 - W.a₁ * ((y
+        - y₀) * (x * (x - x₀) ^ 2 - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) *
+        (x - x₀) ^ 2)) - y * (x - x₀) ^ 3 - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) -
+        (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (x - x₀) - W.a₃ * (x - x₀) ^ 3) * (x - x₀)) - ((y - y₀) *
+        (x * (x - x₀) ^ 2 - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀)
+        ^ 2)) - y * (x - x₀) ^ 3 - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x +
+        x₀) * (x - x₀) ^ 2) * (x - x₀) - W.a₃ * (x - x₀) ^ 3) * (-(2 * ((y - y₀) * (x * (x - x₀) ^ 2
+        - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2)) - y * (x -
+        x₀) ^ 3 - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^
+        2) * (x - x₀) - W.a₃ * (x - x₀) ^ 3) + W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) -
+        (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (x - x₀) + W.a₃ * (x - x₀) ^ 3)))) := by
+      rw [hXn, hYn]
+    _ = 16 * ((x * (x - x₀) + W.veluGx x₀ y₀) * (3 * (x * (x - x₀) + W.veluGx x₀ y₀) ^ 2 + 2 * W.a₂
+        * (x * (x - x₀) + W.veluGx x₀ y₀) * (x - x₀) + (W.a₄ - 5 * W.veluGx x₀ y₀) * (x - x₀) ^ 2 -
+        W.a₁ * (y * (x - x₀) ^ 2 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀))) * (x - x₀) ^ 3 - (y
+        * (x - x₀) ^ 2 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀)) * (-(2 * (y * (x - x₀) ^ 2 -
+        W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀)) + W.a₁ * (x * (x - x₀) + W.veluGx x₀ y₀) * (x -
+        x₀) + W.a₃ * (x - x₀) ^ 2)) * (x - x₀) ^ 2) := W.fiberAdd_asymWeight_cleared_sixteen x y x₀
+        y₀ hP hQ hgy
+    _ = ((x + W.veluGx x₀ y₀ / (x - x₀)) * (3 * (x + W.veluGx x₀ y₀ / (x - x₀)) ^ 2 + 2 * W.a₂ * (x
+        + W.veluGx x₀ y₀ / (x - x₀)) + (W.a₄ - 5 * W.veluGx x₀ y₀) - W.a₁ * (y - W.veluGx x₀ y₀ *
+        (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2))
+        - (y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) * (-(2 * (y - W.veluGx x₀
+            y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) + W.a₁ * (x + W.veluGx x₀ y₀ / (x - x₀))
+            + W.a₃))) * (16 * (x - x₀) ^ 6) := by
+        rw [show ((x + W.veluGx x₀ y₀ / (x - x₀)) * (3 * (x + W.veluGx x₀ y₀ / (x - x₀)) ^ 2 + 2 *
+            W.a₂ * (x + W.veluGx x₀ y₀ / (x - x₀)) + (W.a₄ - 5 * W.veluGx x₀ y₀) - W.a₁ * (y -
+            W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2))
+            - (y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) * (-(2 * (y -
+                W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) + W.a₁ * (x + W.veluGx
+                x₀ y₀ / (x - x₀)) + W.a₃))) * (16 * (x - x₀) ^ 6)
+          = 16 * (((x + W.veluGx x₀ y₀ / (x - x₀)) * (x - x₀))
+              * (3 * ((x + W.veluGx x₀ y₀ / (x - x₀)) * (x - x₀)) ^ 2 + 2 * W.a₂ * ((x + W.veluGx x₀
+                  y₀ / (x - x₀)) * (x - x₀)) * (x - x₀)
+                + (W.a₄ - 5 * W.veluGx x₀ y₀) * (x - x₀) ^ 2 - W.a₁ * ((y - W.veluGx x₀ y₀ * (W.a₁ *
+                    (x - x₀) + y - y₀) / (x - x₀) ^ 2) * (x - x₀) ^ 2))
+              * (x - x₀) ^ 3
+            - ((y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) * (x - x₀) ^ 2)
+              * (-(2 * ((y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) * (x - x₀)
+                  ^ 2) + W.a₁ * ((x + W.veluGx x₀ y₀ / (x - x₀)) * (x - x₀)) * (x - x₀)
+                + W.a₃ * (x - x₀) ^ 2))
+              * (x - x₀) ^ 2) from by ring, hXd, hYd]
+
+end FiberField
+
+section EvenStage
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F}
+
+private theorem nsmul_ne_zero {Q : W.toAffine.Point} {N k : ℕ} (hQ : addOrderOf Q = N)
+    (hk1 : 1 ≤ k) (hkN : k < N) : k • Q ≠ 0 := by
+  intro h
+  have hdvd : N ∣ k := hQ ▸ addOrderOf_dvd_of_nsmul_eq_zero h
+  have := Nat.eq_zero_of_dvd_of_lt hdvd hkN
+  omega
+
+private theorem nsmul_injOn {Q : W.toAffine.Point} {N : ℕ} (hQ : addOrderOf Q = N)
+    {j k : ℕ} (hj1 : 1 ≤ j) (hjN : j < N) (hk1 : 1 ≤ k) (hkN : k < N)
+    (h : j • Q = k • Q) : j = k := by
+  by_contra hne
+  wlog hlt : j < k generalizing j k
+  · exact this hk1 hkN hj1 hjN h.symm (Ne.symm hne) (by omega)
+  have hsum : (k - j) • Q + j • Q = k • Q := by
+    rw [← add_nsmul, Nat.sub_add_cancel (le_of_lt hlt)]
+  have hzero : (k - j) • Q = 0 := by
+    have h0 : (k - j) • Q + j • Q = 0 + j • Q := by rw [hsum, ← h, zero_add]
+    exact add_right_cancel h0
+  exact nsmul_ne_zero hQ (by omega) (by omega) hzero
+
+omit [DecidableEq F] in
+private theorem exists_some_of_ne_zero {P : W.toAffine.Point} (h : P ≠ 0) :
+    ∃ x y hns, P = Affine.Point.some x y hns := by
+  cases P with
+  | zero => exact absurd rfl h
+  | some x y hns => exact ⟨x, y, hns, rfl⟩
+
+private theorem x_ne_middle {Q : W.toAffine.Point} {M : ℕ}
+    (hord : addOrderOf Q = 2 * M) {x₀ y₀ : F} {h₀ : W.toAffine.Nonsingular x₀ y₀}
+    (hMQ : M • Q = .some x₀ y₀ h₀) (hgy : W.veluGy x₀ y₀ = 0)
+    {k : ℕ} (hk1 : 1 ≤ k) (hk2 : k < 2 * M) (hkM : k ≠ M)
+    {xk yk : F} {hk : W.toAffine.Nonsingular xk yk} (hkQ : k • Q = .some xk yk hk) :
+    xk ≠ x₀ := by
+  intro hx
+  have hy := Affine.Y_eq_of_X_eq hk.1 h₀.1 hx
+  have hnegY : W.toAffine.negY x₀ y₀ = y₀ := VeluTwoKernel.negY_eq_of_veluGy_eq_zero hgy
+  have hyk : yk = y₀ := by
+    rcases hy with h | h
+    · exact h
+    · rw [hnegY] at h; exact h
+  subst hx hyk
+  have hkM' : k • Q = M • Q := by rw [hkQ, hMQ]
+  exact hkM (nsmul_injOn hord hk1 hk2 (by omega) (by omega) hkM')
+
+private theorem fiber_gx_point (hchar : (2 : F) ≠ 0) {x y x₀ y₀ : F}
+    (hP : W.toAffine.Nonsingular x y) (h₀ : W.toAffine.Nonsingular x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hx : x ≠ x₀) :
+    W.veluGx x y
+        + W.veluGx (W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y y₀))
+          (W.toAffine.addY x x₀ y (W.toAffine.slope x x₀ y y₀))
+      = (W.veluQuotient2 x₀ y₀).veluGx (W.velu2X x₀ y₀ x) (W.velu2Y x₀ y₀ x y) := by
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  have hl : W.toAffine.slope x x₀ y y₀ * (x - x₀) = y - y₀ := by
+    rw [Affine.slope_of_X_ne hx, div_mul_cancel₀ _ hd]
+  have h := W.fiberAdd_veluGx_field hchar hP.1 h₀.1 hgy hx hl
+    (x' := W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y y₀))
+    (y' := W.toAffine.addY x x₀ y (W.toAffine.slope x x₀ y y₀))
+    (by simp [Affine.addX]) (by simp [Affine.addY, Affine.negAddY, Affine.negY, Affine.addX]; ring)
+  rw [h]
+  simp only [veluGx, veluQuotient2_a₁, veluQuotient2_a₂, veluQuotient2_a₄, velu2X, velu2Y]
+
+private theorem fiber_asym_point (hchar : (2 : F) ≠ 0) {x y x₀ y₀ : F}
+    (hP : W.toAffine.Nonsingular x y) (h₀ : W.toAffine.Nonsingular x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hx : x ≠ x₀) :
+    (x * W.veluGx x y - y * W.veluGy x y)
+        + (W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y y₀)
+            * W.veluGx (W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y y₀))
+              (W.toAffine.addY x x₀ y (W.toAffine.slope x x₀ y y₀))
+          - W.toAffine.addY x x₀ y (W.toAffine.slope x x₀ y y₀)
+            * W.veluGy (W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y y₀))
+              (W.toAffine.addY x x₀ y (W.toAffine.slope x x₀ y y₀)))
+      = (W.velu2X x₀ y₀ x
+            * (W.veluQuotient2 x₀ y₀).veluGx (W.velu2X x₀ y₀ x) (W.velu2Y x₀ y₀ x y)
+          - W.velu2Y x₀ y₀ x y
+            * (W.veluQuotient2 x₀ y₀).veluGy (W.velu2X x₀ y₀ x) (W.velu2Y x₀ y₀ x y)) := by
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  have hl : W.toAffine.slope x x₀ y y₀ * (x - x₀) = y - y₀ := by
+    rw [Affine.slope_of_X_ne hx, div_mul_cancel₀ _ hd]
+  have h := W.fiberAdd_asymWeight_field hchar hP.1 h₀.1 hgy hx hl
+    (x' := W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y y₀))
+    (y' := W.toAffine.addY x x₀ y (W.toAffine.slope x x₀ y y₀))
+    (by simp [Affine.addX]) (by simp [Affine.addY, Affine.negAddY, Affine.negY, Affine.addX]; ring)
+  rw [h]
+  simp only [veluGx, veluGy, veluQuotient2_a₁, veluQuotient2_a₂, veluQuotient2_a₃,
+    veluQuotient2_a₄, velu2X, velu2Y]
+
+private theorem sum_split (hchar : (2 : F) ≠ 0) {Q : W.toAffine.Point} {M : ℕ} (hM : M ≠ 0)
+    (hord : addOrderOf Q = 2 * M) {x₀ y₀ : F} {h₀ : W.toAffine.Nonsingular x₀ y₀}
+    (hMQ : M • Q = .some x₀ y₀ h₀) (hgy : W.veluGy x₀ y₀ = 0)
+    (hΔ₂ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0) [W.IsElliptic]
+    (g g₁ : F × F → F)
+    (hfiber : ∀ k, 1 ≤ k → k < M →
+      g ((k • Q).coordsOrZero) + g (((k + M) • Q).coordsOrZero)
+        = g₁ ((veluPointMap2 hchar h₀.1 hgy hΔ₂ (k • Q)).coordsOrZero)) :
+    ∑ P ∈ W.oddOrderSummingSet Q (2 * M - 1), g P
+      = g (x₀, y₀)
+        + ∑ P ∈ (W.veluQuotient2 x₀ y₀).oddOrderSummingSet
+            (veluPointMap2 hchar h₀.1 hgy hΔ₂ Q) (M - 1), g₁ P := by
+  obtain ⟨m, rfl⟩ := Nat.exists_eq_succ_of_ne_zero hM
+  rw [show 2 * (m + 1) - 1 = 2 * m + 1 from by omega, show m + 1 - 1 = m from by omega]
+  have hordQ' : addOrderOf (veluPointMap2 hchar h₀.1 hgy hΔ₂ Q) = m + 1 :=
+    KernelTower.addOrderOf_veluPointMap2 hchar W Q (m + 1) (by omega) hord hMQ hgy hΔ₂
+      (VeluTwoKernel.veluPointMap2_eq_zero_iff hchar h₀.1 hgy hΔ₂ h₀)
+  obtain ⟨φ, hφ⟩ := W.exists_addMonoidHom_coe_eq_veluPointMap2 hchar h₀.1 hgy hΔ₂
+  have himg : ∀ k : ℕ, k • veluPointMap2 hchar h₀.1 hgy hΔ₂ Q
+      = veluPointMap2 hchar h₀.1 hgy hΔ₂ (k • Q) := by
+    intro k
+    rw [← hφ]
+    exact (map_nsmul φ k Q).symm
+  have hinjL : Set.InjOn (fun k => (k • Q).coordsOrZero)
+      (Finset.Icc 1 (2 * m + 1) : Set ℕ) := by
+    intro j hj k hk hjk
+    simp only [Finset.coe_Icc, Set.mem_Icc] at hj hk
+    obtain ⟨xj, yj, hnsj, hjQ⟩ := exists_some_of_ne_zero
+      (nsmul_ne_zero hord hj.1 (by omega))
+    obtain ⟨xk, yk, hnsk, hkQ⟩ := exists_some_of_ne_zero
+      (nsmul_ne_zero hord hk.1 (by omega))
+    simp only [hjQ, hkQ, Affine.Point.coordsOrZero_some, Prod.mk.injEq] at hjk
+    refine nsmul_injOn hord hj.1 (by omega) hk.1 (by omega) ?_
+    rw [hjQ, hkQ]
+    obtain ⟨h1, h2⟩ := hjk
+    subst h1; subst h2; rfl
+  have hinjR : Set.InjOn (fun k => (k • veluPointMap2 hchar h₀.1 hgy hΔ₂ Q).coordsOrZero)
+      (Finset.Icc 1 m : Set ℕ) := by
+    intro j hj k hk hjk
+    simp only [Finset.coe_Icc, Set.mem_Icc] at hj hk
+    obtain ⟨xj, yj, hnsj, hjQ⟩ := exists_some_of_ne_zero
+      (nsmul_ne_zero hordQ' hj.1 (by omega))
+    obtain ⟨xk, yk, hnsk, hkQ⟩ := exists_some_of_ne_zero
+      (nsmul_ne_zero hordQ' hk.1 (by omega))
+    simp only [hjQ, hkQ, Affine.Point.coordsOrZero_some, Prod.mk.injEq] at hjk
+    refine nsmul_injOn hordQ' hj.1 (by omega) hk.1 (by omega) ?_
+    rw [hjQ, hkQ]
+    obtain ⟨h1, h2⟩ := hjk
+    subst h1; subst h2; rfl
+  have hL : ∑ P ∈ W.oddOrderSummingSet Q (2 * m + 1), g P
+      = ∑ k ∈ Finset.Icc 1 (2 * m + 1), g ((k • Q).coordsOrZero) := by
+    simp only [oddOrderSummingSet]
+    exact Finset.sum_image hinjL
+  have hR : ∑ P ∈ (W.veluQuotient2 x₀ y₀).oddOrderSummingSet
+        (veluPointMap2 hchar h₀.1 hgy hΔ₂ Q) m, g₁ P
+      = ∑ k ∈ Finset.Icc 1 m,
+          g₁ ((veluPointMap2 hchar h₀.1 hgy hΔ₂ (k • Q)).coordsOrZero) := by
+    simp only [oddOrderSummingSet]
+    rw [Finset.sum_image hinjR]
+    exact Finset.sum_congr rfl fun k _ => by rw [himg]
+  rw [hL, hR]
+  have e1 : (Finset.Icc 1 (2 * m + 1) : Finset ℕ) = Finset.Ioc 0 (2 * m + 1) := by
+    ext a
+    simp [Nat.lt_iff_add_one_le]
+  have e2 : (Finset.Icc 1 m : Finset ℕ) = Finset.Ioc 0 m := by
+    ext a
+    simp [Nat.lt_iff_add_one_le]
+  rw [e1, e2, ← Finset.sum_Ioc_consecutive _ (Nat.zero_le (m + 1))
+    (by omega : m + 1 ≤ 2 * m + 1), Finset.sum_Ioc_succ_top (Nat.zero_le m)]
+  have e3 : Finset.Ioc (m + 1) (2 * m + 1)
+      = (Finset.Ioc 0 m).map (addLeftEmbedding (m + 1)) := by
+    rw [Finset.map_add_left_Ioc]
+    congr 1
+    omega
+  rw [e3, Finset.sum_map]
+  have hmid : g (((m + 1) • Q).coordsOrZero) = g (x₀, y₀) := by
+    rw [hMQ, Affine.Point.coordsOrZero_some]
+  have hpair : ∀ k ∈ Finset.Ioc 0 m,
+      g ((k • Q).coordsOrZero) + g ((addLeftEmbedding (m + 1) k • Q).coordsOrZero)
+        = g₁ ((veluPointMap2 hchar h₀.1 hgy hΔ₂ (k • Q)).coordsOrZero) := by
+    intro k hk
+    simp only [Finset.mem_Ioc] at hk
+    have : addLeftEmbedding (m + 1) k = k + (m + 1) := by
+      simp [addLeftEmbedding_apply, Nat.add_comm]
+    rw [this]
+    exact hfiber k (by omega) (by omega)
+  calc (∑ k ∈ Finset.Ioc 0 m, g ((k • Q).coordsOrZero)) + g (((m + 1) • Q).coordsOrZero)
+        + ∑ k ∈ Finset.Ioc 0 m, g ((addLeftEmbedding (m + 1) k • Q).coordsOrZero)
+      = g (((m + 1) • Q).coordsOrZero)
+        + ((∑ k ∈ Finset.Ioc 0 m, g ((k • Q).coordsOrZero))
+          + ∑ k ∈ Finset.Ioc 0 m, g ((addLeftEmbedding (m + 1) k • Q).coordsOrZero)) := by
+        ring
+    _ = g (x₀, y₀) + ∑ k ∈ Finset.Ioc 0 m,
+          g₁ ((veluPointMap2 hchar h₀.1 hgy hΔ₂ (k • Q)).coordsOrZero) := by
+        rw [hmid, ← Finset.sum_add_distrib, Finset.sum_congr rfl hpair]
+    _ = g (x₀, y₀) + ∑ k ∈ Finset.Icc 1 m,
+          g₁ ((veluPointMap2 hchar h₀.1 hgy hΔ₂ (k • Q)).coordsOrZero) := by
+        rw [e2]
+
+end EvenStage
+
+theorem fullKernelQuotient_eq_fullKernelQuotient_veluPointMap2
+    {F : Type*} [Field F] [DecidableEq F] (hchar : (2 : F) ≠ 0)
+    (W : WeierstrassCurve F) [W.IsElliptic] (Q : W.toAffine.Point) (M : ℕ) (hM : M ≠ 0)
+    (hQ : addOrderOf Q = 2 * M)
+    {x₀ y₀ : F} {h₀ : W.toAffine.Nonsingular x₀ y₀} (hMQ : M • Q = .some x₀ y₀ h₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hΔ₂ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0) :
+    W.fullKernelQuotient Q (2 * M)
+      = (W.veluQuotient2 x₀ y₀).fullKernelQuotient
+          (veluPointMap2 hchar h₀.1 hgy hΔ₂ Q) M := by
+  have hfibT : ∀ k, 1 ≤ k → k < M →
+      (fun P : F × F => W.veluGx P.1 P.2) ((k • Q).coordsOrZero)
+        + (fun P : F × F => W.veluGx P.1 P.2) (((k + M) • Q).coordsOrZero)
+        = (fun P : F × F => (W.veluQuotient2 x₀ y₀).veluGx P.1 P.2)
+            ((veluPointMap2 hchar h₀.1 hgy hΔ₂ (k • Q)).coordsOrZero) := by
+    intro k hk1 hkM
+    obtain ⟨xk, yk, hk, hkQ⟩ := exists_some_of_ne_zero (nsmul_ne_zero hQ hk1 (by omega))
+    have hx : xk ≠ x₀ := x_ne_middle hQ hMQ hgy hk1 (by omega) (by omega) hkQ
+    simp only [add_nsmul, hkQ, hMQ, Affine.Point.add_of_X_ne hx,
+      veluPointMap2_some_of_ne hchar h₀.1 hgy hΔ₂ hk hx, Affine.Point.coordsOrZero_some]
+    exact fiber_gx_point hchar hk h₀ hgy hx
+  have hfibW : ∀ k, 1 ≤ k → k < M →
+      (fun P : F × F => P.1 * W.veluGx P.1 P.2 - P.2 * W.veluGy P.1 P.2)
+          ((k • Q).coordsOrZero)
+        + (fun P : F × F => P.1 * W.veluGx P.1 P.2 - P.2 * W.veluGy P.1 P.2)
+            (((k + M) • Q).coordsOrZero)
+        = (fun P : F × F => P.1 * (W.veluQuotient2 x₀ y₀).veluGx P.1 P.2
+              - P.2 * (W.veluQuotient2 x₀ y₀).veluGy P.1 P.2)
+            ((veluPointMap2 hchar h₀.1 hgy hΔ₂ (k • Q)).coordsOrZero) := by
+    intro k hk1 hkM
+    obtain ⟨xk, yk, hk, hkQ⟩ := exists_some_of_ne_zero (nsmul_ne_zero hQ hk1 (by omega))
+    have hx : xk ≠ x₀ := x_ne_middle hQ hMQ hgy hk1 (by omega) (by omega) hkQ
+    simp only [add_nsmul, hkQ, hMQ, Affine.Point.add_of_X_ne hx,
+      veluPointMap2_some_of_ne hchar h₀.1 hgy hΔ₂ hk hx, Affine.Point.coordsOrZero_some]
+    exact fiber_asym_point hchar hk h₀ hgy hx
+  have hT := sum_split hchar hM hQ hMQ hgy hΔ₂
+    (fun P : F × F => W.veluGx P.1 P.2)
+    (fun P : F × F => (W.veluQuotient2 x₀ y₀).veluGx P.1 P.2) hfibT
+  have hW := sum_split hchar hM hQ hMQ hgy hΔ₂
+    (fun P : F × F => P.1 * W.veluGx P.1 P.2 - P.2 * W.veluGy P.1 P.2)
+    (fun P : F × F => P.1 * (W.veluQuotient2 x₀ y₀).veluGx P.1 P.2
+      - P.2 * (W.veluQuotient2 x₀ y₀).veluGy P.1 P.2) hfibW
+  simp only at hT hW
+  ext
+  · simp [fullKernelQuotient, veluQuotientOfSums]
+  · simp [fullKernelQuotient, veluQuotientOfSums]
+  · simp [fullKernelQuotient, veluQuotientOfSums]
+  · simp only [fullKernelQuotient, veluQuotientOfSums_a₄, veluQuotient2_a₄]
+    linear_combination (-5 : F) * hT
+  · simp only [fullKernelQuotient, veluQuotientOfSums_a₆, veluQuotient2_a₆, veluQuotient2_b₂]
+    linear_combination (- W.b₂) * hT + (-7 : F) * hW + (7 * y₀) * hgy
+
+end WeierstrassCurve
+
+open Polynomial WeierstrassCurve
+
+namespace ModularCurve
+
+namespace TatePoint
+
+namespace DiscEvenEngine
+
+private theorem c4_entry
+    {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F}
+    (Q : W.toAffine.Point) (hQ : addOrderOf Q = 2) :
+    ∃ (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      Q = .some x₀ y₀ h₀ ∧ W.veluGy x₀ y₀ = 0 := by
+  rcases Q with _ | ⟨x, y, hns⟩
+  · rw [show (Affine.Point.zero : W.toAffine.Point) = 0 from rfl, addOrderOf_zero] at hQ
+    exact absurd hQ (by decide)
+  · refine ⟨x, y, hns, rfl, ?_⟩
+    have h2Q : (2 : ℕ) • (Affine.Point.some x y hns : W.toAffine.Point) = 0 := by
+      rw [← hQ]; exact addOrderOf_nsmul_eq_zero _
+    have hGy2 : W.veluGy x y ^ 2 = 0 := by
+      have hU := W.veluU_eq_Ψ₂Sq_eval hns.1
+      simp only [WeierstrassCurve.veluU] at hU
+      rw [hU]; exact (WeierstrassCurve.Affine.Point.two_smul_some_eq_zero_iff W hns).mp h2Q
+    exact pow_eq_zero_iff two_ne_zero |>.mp hGy2
+
+private theorem c4_stageDelta
+    {F : Type*} [Field F] {W : WeierstrassCurve F} [W.IsElliptic]
+    {x₀ y₀ : F} (h₀ : W.toAffine.Nonsingular x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0) :
+    (W.veluQuotient2 x₀ y₀).Δ ≠ 0 := by
+  classical
+  exact
+    (WeierstrassCurve.isElliptic_veluQuotient2_of_isElliptic h₀.1 hgy).isUnit.ne_zero
+
+private theorem addOrderOf_nsmul_half {A : Type*} [AddGroup A] {Q : A} {M : ℕ}
+    (hM : M ≠ 0) (hQ : addOrderOf Q = 2 * M) : addOrderOf (M • Q) = 2 := by
+  have h2MQ : 2 • (M • Q) = 0 := by
+    have h := addOrderOf_nsmul_eq_zero Q
+    rw [hQ, mul_comm, mul_nsmul] at h
+    exact h
+  have hMQne : M • Q ≠ 0 := by
+    refine nsmul_ne_zero_of_lt_addOrderOf (by omega) ?_
+    rw [hQ]; omega
+  have hdvd : addOrderOf (M • Q) ∣ 2 := addOrderOf_dvd_of_nsmul_eq_zero h2MQ
+  rcases (Nat.prime_two.eq_one_or_self_of_dvd _ hdvd) with h1 | h2'
+  · exact absurd (AddMonoid.addOrderOf_eq_one_iff.mp h1) hMQne
+  · exact h2'
+
+private theorem _root_.ModularCurve.TatePoint.DiscEvenEngine.fullKernelDiscAt_of_even :
+    ∀ (N : ℕ), [NeZero N] → Even N → ModularCurve.TatePoint.FullKernelDiscAt N := by
+  intro N
+  induction N using Nat.strong_induction_on with
+  | _ N IH =>
+  intro _ hE L _ _ _ h2 W _ Q hQ
+  obtain ⟨M, rfl⟩ := hE
+  have hM : M ≠ 0 := by have := NeZero.ne (M + M); omega
+  rw [← two_mul] at hQ ⊢
+  have : NeZero M := ⟨hM⟩
+  have hMQord : addOrderOf (M • Q) = 2 := addOrderOf_nsmul_half hM hQ
+  obtain ⟨x₀, y₀, h₀, hMQ, hgy⟩ := c4_entry (M • Q) hMQord
+  have hΔ₂ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0 := c4_stageDelta h₀ hgy
+  have : (W.veluQuotient2 x₀ y₀).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ₂⟩
+  rw [WeierstrassCurve.fullKernelQuotient_eq_fullKernelQuotient_veluPointMap2
+      h2 W Q M hM hQ hMQ hgy hΔ₂]
+  have hker₀ : ∀ P : W.toAffine.Point,
+      veluPointMap2 h2 h₀.1 hgy hΔ₂ P = 0 ↔ P = 0 ∨ P = .some x₀ y₀ h₀ :=
+    fun P => WeierstrassCurve.VeluTwoKernel.veluPointMap2_eq_zero_iff h2 h₀.1 hgy hΔ₂ h₀ P
+  have hQ₁ : addOrderOf (veluPointMap2 h2 h₀.1 hgy hΔ₂ Q) = M :=
+    KernelTower.addOrderOf_veluPointMap2 h2 W Q M hM hQ hMQ hgy hΔ₂ hker₀
+  rcases Nat.even_or_odd M with hME | hMO
+  · exact IH M (by omega) hME h2 (W.veluQuotient2 x₀ y₀)
+      (veluPointMap2 h2 h₀.1 hgy hΔ₂ Q) hQ₁
+  · exact ModularCurve.TatePoint.fullKernelDiscAt_of_odd M hMO h2
+      (W.veluQuotient2 x₀ y₀) (veluPointMap2 h2 h₀.1 hgy hΔ₂ Q) hQ₁
+
+end ModularCurve.TatePoint.DiscEvenEngine
+
+namespace ModularCurve.TatePoint
+
+private theorem _root_.ModularCurve.TatePoint.fullKernelDiscAt_of_even
+    (N : ℕ) [NeZero N] (hE : Even N) :
+    ModularCurve.TatePoint.FullKernelDiscAt N :=
+  ModularCurve.TatePoint.DiscEvenEngine.fullKernelDiscAt_of_even N hE
+
+end ModularCurve.TatePoint
+
+section Char3Gate
+
+example [DecidableEq (AlgebraicClosure (ZMod 3))]
+    (h2 : (2 : AlgebraicClosure (ZMod 3)) ≠ 0)
+    (W : WeierstrassCurve (AlgebraicClosure (ZMod 3))) [W.IsElliptic]
+    (Q : W.toAffine.Point) (hQ : addOrderOf Q = 6) :
+    (W.fullKernelQuotient Q 6).Δ ≠ 0 :=
+  ModularCurve.TatePoint.fullKernelDiscAt_of_even 6 (by decide) h2 W Q hQ
+
+end Char3Gate
+
+open ModularCurve TatePoint in
+theorem solution (N : ℕ) [NeZero N] : FullKernelDiscAt N := by
+  rcases Nat.even_or_odd N with hE | hO
+  · exact ModularCurve.TatePoint.fullKernelDiscAt_of_even N hE
+  · exact ModularCurve.TatePoint.fullKernelDiscAt_of_odd N hO
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.TatePoint.fullKernelDiscAt (N : ℕ) [NeZero N] :
+    FullKernelDiscAt N :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_TatePoint_fullKernelDiscAt_of_odd.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_TatePoint_fullKernelDiscAt_of_odd.lean
new file mode 100644
index 0000000000..2e41f226ec
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_TatePoint_fullKernelDiscAt_of_odd.lean
@@ -0,0 +1,244 @@
+/-
+Based on Prove2Me node ModularCurve.TatePoint.fullKernelDiscAt_of_odd
+(51000608-a7e8-5b83-9a45-6c163a911fd9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 52f4dd44-2ca2-58ce-925a-6e5136600248
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CycSubRootBridgeN
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FullKernelQuotient
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CycSubRootBridgeOdd
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Non-degeneracy of the full-kernel Vélu quotient at odd level
+
+Theorem statement: `ModularCurve.TatePoint.fullKernelDiscAt_of_odd`
+(`51000608-a7e8-5b83-9a45-6c163a911fd9`), by Claude, 2026-09-05.
+
+Proof: submission `52f4dd44-2ca2-58ce-925a-6e5136600248`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number which is odd. The conclusion is the proposition
+`FullKernelDiscAt N`, which unfolds to the following assertion: for every algebraically closed field
+$L$ (in the lowest universe, with decidable equality) in which $2 \neq 0$, for every Weierstrass
+curve $W$ over $L$ that is elliptic, and for every point $Q$ of the associated affine curve
+$W.toAffine$ whose additive order `addOrderOf Q` equals exactly $N$, the discriminant $\Delta$ of
+the Weierstrass curve $W.fullKernelQuotient\ Q\ N$ is nonzero. Here `fullKernelQuotient` is the
+curve obtained by applying `W.veluQuotientOfSums` to the pair of Vélu sums formed over the finite
+index set $W.oddOrderSummingSet\ Q\ (N-1)$ of coordinate pairs $(x,y)$: the first argument is $\sum
+(W.veluGx\ x\ y)$ and the second is $\sum \bigl(x \cdot W.veluGx\ x\ y - y \cdot W.veluGy\ x\
+y\bigr)$. Thus, over any algebraically closed field of characteristic different from $2$, the Vélu
+quotient of an elliptic curve by the cyclic group generated by a point of exact odd order $N$ is
+again given by a non-singular Weierstrass equation.
+
+This is the non-degeneracy statement for the quotient of an elliptic curve by a cyclic subgroup of
+odd order $N$, computed by Vélu's formulas from a half-system of the kernel: the resulting
+Weierstrass equation again defines an elliptic curve. It is used, together with the
+modular-polynomial root property and the injectivity of the associated root map, in the bridge
+between cyclic subgroups of order $N$ and points of the modular curve, and is cited by
+[`ModularCurve.TatePoint.fullKernelDiscAt`](thm.html#ModularCurve.TatePoint.fullKernelDiscAt) and
+[`ModularCurve.TatePoint.fullKernelIsRootAt`](thm.html#ModularCurve.TatePoint.fullKernelIsRootAt).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_TatePoint_fullKernelDiscAt_of_odd.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_TatePoint_fullKernelDiscAt_of_odd
+
+noncomputable section
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_TatePoint_fullKernelDiscAt_of_odd.ModularCurve \
+  WeierstrassCurve P2MW.S_ModularCurve_TatePoint_fullKernelDiscAt_of_odd.WeierstrassCurve \
+  Polynomial"
+open scoped Classical
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "map toAffine Δ j fullKernelQuotient \
+  fullKernelQuotient_eq_veluQuotient_oddOrderSummingSet oddOrderSummingSet veluQuotient \
+  veluQuotient_oddOrderSummingSet_discriminant_ne_zero \
+  zmultiples_eq_of_veluQuotient_j_eq_of_transcendental"
+p2m_open "WeierstrassCurve"
+
+theorem j_congr {R : Type*} [CommRing R] {X Y : WeierstrassCurve R} (h : X = Y) (hX : X.IsElliptic)
+    (hY : Y.IsElliptic) : @WeierstrassCurve.j R _ X hX = @WeierstrassCurve.j R _ Y hY := by
+  subst h
+  rfl
+
+private theorem _root_.WeierstrassCurve.fullKernelQuotient_eq_veluQuotient_of_odd_aux {F : Type*}
+    [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+    (Q : W.toAffine.Point) {N : ℕ} (hN : Odd N) (hQ : addOrderOf Q = N) :
+    W.fullKernelQuotient Q N = W.veluQuotient (W.oddOrderSummingSet Q ((N - 1) / 2)) := by
+  obtain ⟨m, rfl⟩ := hN
+  have hm : (2 * m + 1 - 1) / 2 = m := by omega
+  rw [hm]
+  exact W.fullKernelQuotient_eq_veluQuotient_oddOrderSummingSet Q m hQ
+
+p2m_export "WeierstrassCurve" "fullKernelQuotient_eq_veluQuotient_of_odd_aux"
+
+private theorem _root_.WeierstrassCurve.fullKernelQuotient_discriminant_ne_zero_of_odd {L : Type*}
+    [Field L] [DecidableEq L] [IsAlgClosed L]
+    (h2 : (2 : L) ≠ 0) (W : WeierstrassCurve L) [W.IsElliptic] (N : ℕ) [NeZero N] (hN : Odd N)
+    (Q : W.toAffine.Point) (hQ : addOrderOf Q = N) :
+    (W.fullKernelQuotient Q N).Δ ≠ 0 := by
+  obtain ⟨m, rfl⟩ := hN
+  rw [W.fullKernelQuotient_eq_veluQuotient_oddOrderSummingSet Q m hQ]
+  exact WeierstrassCurve.veluQuotient_oddOrderSummingSet_discriminant_ne_zero h2 W m Q hQ
+
+p2m_export "WeierstrassCurve" "fullKernelQuotient_discriminant_ne_zero_of_odd"
+
+private theorem
+  _root_.WeierstrassCurve.zmultiples_eq_of_fullKernelQuotient_j_eq_of_transcendental_of_odd
+    [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    (ht : Transcendental ℚ W.j) (N : ℕ) [NeZero N] (hN : Odd N) (Q Q' : W.toAffine.Point)
+    (hQ : addOrderOf Q = N) (hQ' : addOrderOf Q' = N)
+    (hΔ : (W.fullKernelQuotient Q N).Δ ≠ 0)
+    (hΔ' : (W.fullKernelQuotient Q' N).Δ ≠ 0)
+    (hj : haveI : (W.fullKernelQuotient Q N).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+      haveI : (W.fullKernelQuotient Q' N).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ'⟩
+      (W.fullKernelQuotient Q N).j = (W.fullKernelQuotient Q' N).j) :
+    AddSubgroup.zmultiples Q = AddSubgroup.zmultiples Q' := by
+  obtain ⟨m, rfl⟩ := hN
+  have hWQ := W.fullKernelQuotient_eq_veluQuotient_oddOrderSummingSet Q m hQ
+  have hWQ' := W.fullKernelQuotient_eq_veluQuotient_oddOrderSummingSet Q' m hQ'
+  have hΔ₁ : (W.veluQuotient (W.oddOrderSummingSet Q m)).Δ ≠ 0 := by rw [← hWQ]; exact hΔ
+  have hΔ₂ : (W.veluQuotient (W.oddOrderSummingSet Q' m)).Δ ≠ 0 := by rw [← hWQ']; exact hΔ'
+  rw [j_congr hWQ ⟨isUnit_iff_ne_zero.mpr hΔ⟩ ⟨isUnit_iff_ne_zero.mpr hΔ₁⟩,
+    j_congr hWQ' ⟨isUnit_iff_ne_zero.mpr hΔ'⟩ ⟨isUnit_iff_ne_zero.mpr hΔ₂⟩] at hj
+  exact WeierstrassCurve.zmultiples_eq_of_veluQuotient_j_eq_of_transcendental W ht m Q Q' hQ hQ' hΔ₁
+    hΔ₂ hj
+
+p2m_export "WeierstrassCurve" "zmultiples_eq_of_fullKernelQuotient_j_eq_of_transcendental_of_odd"
+end WeierstrassCurve
+
+namespace ModularCurve
+p2m_export "ModularCurve" "TatePoint.dictOdd TatePoint.Qbar TatePoint.nearCurve TatePoint.CycSubH \
+  TatePoint.RootsAt ModularPolynomialData \
+  ModularPolynomialData.isRoot_map_j_veluQuotient_j_of_addOrderOf_eq TatePoint.dictN"
+namespace ModularPolynomialData
+p2m_export "ModularCurve.ModularPolynomialData" "Φ isRoot_map_j_veluQuotient_j_of_addOrderOf_eq"
+end ModularCurve.ModularPolynomialData
+p2m_open_scoped "ModularCurve ModularCurve.ModularPolynomialData" in
+theorem ModularCurve.ModularPolynomialData.isRoot_map_j_fullKernelQuotient_j_of_odd
+    [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    (N : ℕ) [NeZero N] (hN : Odd N) (Q : W.toAffine.Point) (hQ : addOrderOf Q = N)
+    (hΔ : (W.fullKernelQuotient Q N).Δ ≠ 0)
+    (data : ModularCurve.ModularPolynomialData N) :
+    haveI : (W.fullKernelQuotient Q N).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+    (data.Φ.map (Polynomial.eval₂RingHom
+      (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ))) W.j)).IsRoot
+      (W.fullKernelQuotient Q N).j := by
+  obtain ⟨m, rfl⟩ := hN
+  have hWQ := W.fullKernelQuotient_eq_veluQuotient_oddOrderSummingSet Q m hQ
+  have hΔ₁ : (W.veluQuotient (W.oddOrderSummingSet Q m)).Δ ≠ 0 := by rw [← hWQ]; exact hΔ
+  rw [WeierstrassCurve.j_congr hWQ ⟨isUnit_iff_ne_zero.mpr hΔ⟩ ⟨isUnit_iff_ne_zero.mpr hΔ₁⟩]
+  exact ModularCurve.ModularPolynomialData.isRoot_map_j_veluQuotient_j_of_addOrderOf_eq W m Q hQ hΔ₁
+    data
+
+namespace ModularCurve
+p2m_export "ModularCurve" "TatePoint.dictOdd TatePoint.Qbar TatePoint.nearCurve TatePoint.CycSubH \
+  TatePoint.RootsAt ModularPolynomialData \
+  ModularPolynomialData.isRoot_map_j_veluQuotient_j_of_addOrderOf_eq TatePoint.dictN"
+namespace TatePoint
+p2m_export "ModularCurve.TatePoint" "cycSubRootOdd rootsEquivCycSubHOdd \
+  rootsEquivCycSubHOdd_apply_eq_iff dictOdd cycSubGen addOrderOf_cycSubGen Qbar H nearCurve \
+  CycSubH RootsAt nearCurve_j_transcendental FullKernelIsRootAt FullKernelInjAt FullKernelDiscAt \
+  cycSubRootN rootsEquivCycSubHN rootsEquivCycSubHN_apply_eq_iff dictN"
+p2m_open "ModularCurve.TatePoint ModularCurve"
+
+private theorem cycSubRootN_eq_cycSubRootOdd_aux (E : WeierstrassCurve H) [E.IsElliptic] {N : ℕ}
+    [NeZero N] (hN : Odd N)
+    (hW1 : FullKernelIsRootAt N) (hW3 : FullKernelDiscAt N) (data : ModularPolynomialData N)
+    (G : CycSubH E N) : cycSubRootN E hW1 hW3 data G = cycSubRootOdd E hN data G :=
+  Subtype.ext (WeierstrassCurve.j_congr
+    (E.fullKernelQuotient_eq_veluQuotient_of_odd_aux (cycSubGen E G) hN (addOrderOf_cycSubGen E G))
+      _ _)
+
+private theorem rootsEquivCycSubHN_eq_rootsEquivCycSubHOdd_aux (E : WeierstrassCurve H)
+    [E.IsElliptic] {N : ℕ} [NeZero N]
+    (hN : Odd N) (hW1 : FullKernelIsRootAt N) (hW2 : FullKernelInjAt N) (hW3 : FullKernelDiscAt N)
+    (data : ModularPolynomialData N) (hj : Transcendental Qbar E.j) :
+    rootsEquivCycSubHN E hW1 hW2 hW3 data hj = rootsEquivCycSubHOdd E hN data hj := by
+  ext r : 1
+  rw [rootsEquivCycSubHN_apply_eq_iff, cycSubRootN_eq_cycSubRootOdd_aux E hN,
+    ← rootsEquivCycSubHOdd_apply_eq_iff E hN data hj r (rootsEquivCycSubHOdd E hN data hj r)]
+
+private theorem dictN_eq_dictOdd_aux (N : ℕ) [NeZero N] (hN : Odd N)
+    (data : ModularPolynomialData N) (j₀ : Qbar)
+    (hW1 : FullKernelIsRootAt N) (hW2 : FullKernelInjAt N) (hW3 : FullKernelDiscAt N) :
+    dictN N data j₀ hW1 hW2 hW3 = dictOdd N hN data j₀ :=
+  rootsEquivCycSubHN_eq_rootsEquivCycSubHOdd_aux (nearCurve j₀) hN hW1 hW2 hW3 data
+    (nearCurve_j_transcendental j₀)
+
+private theorem fullKernelIsRootAt_of_odd_aux (N : ℕ) [NeZero N] (hN : Odd N) :
+    FullKernelIsRootAt N :=
+  fun W _ Q hQ hΔ data =>
+    ModularCurve.ModularPolynomialData.isRoot_map_j_fullKernelQuotient_j_of_odd W N hN Q hQ hΔ data
+
+private theorem fullKernelInjAt_of_odd_aux (N : ℕ) [NeZero N] (hN : Odd N) : FullKernelInjAt N :=
+  fun W _ ht Q Q' hQ hQ' hΔ hΔ' hj =>
+    W.zmultiples_eq_of_fullKernelQuotient_j_eq_of_transcendental_of_odd ht N hN Q Q' hQ hQ' hΔ hΔ'
+      hj
+
+private theorem fullKernelDiscAt_of_odd_aux (N : ℕ) [NeZero N] (hN : Odd N) : FullKernelDiscAt N :=
+  fun h2 W _ Q hQ => W.fullKernelQuotient_discriminant_ne_zero_of_odd h2 N hN Q hQ
+
+def dictNOdd (N : ℕ) [NeZero N] (hN : Odd N) (data : ModularPolynomialData N) (j₀ : Qbar) :
+    RootsAt data (nearCurve j₀).j ≃ CycSubH (nearCurve j₀) N :=
+  dictN N data j₀ (fullKernelIsRootAt_of_odd_aux N hN) (fullKernelInjAt_of_odd_aux N hN)
+    (fullKernelDiscAt_of_odd_aux N hN)
+
+theorem dictNOdd_eq_dictOdd (N : ℕ) [NeZero N] (hN : Odd N) (data : ModularPolynomialData N)
+    (j₀ : Qbar) :
+    dictNOdd N hN data j₀ = dictOdd N hN data j₀ :=
+  dictN_eq_dictOdd_aux N hN data j₀ _ _ _
+
+end ModularCurve.TatePoint
+
+end
+
+noncomputable example (data : ModularCurve.ModularPolynomialData 3) (j₀ :
+  ModularCurve.TatePoint.Qbar) :
+    ModularCurve.TatePoint.RootsAt data (ModularCurve.TatePoint.nearCurve j₀).j ≃
+      ModularCurve.TatePoint.CycSubH (ModularCurve.TatePoint.nearCurve j₀) 3 :=
+  ModularCurve.TatePoint.dictNOdd 3 (by decide) data j₀
+
+open scoped Classical
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_TatePoint_fullKernelDiscAt_of_odd.ModularCurve
+  _root_.ModularCurve.TatePoint
+  _root_.P2MW.S_ModularCurve_TatePoint_fullKernelDiscAt_of_odd.ModularCurve.TatePoint in
+theorem solution (N : ℕ) [NeZero N] (hN : Odd N) : FullKernelDiscAt N :=
+  ModularCurve.TatePoint.fullKernelDiscAt_of_odd_aux N hN
+
+end S_ModularCurve_TatePoint_fullKernelDiscAt_of_odd
+end P2MW
+export P2MW.S_ModularCurve_TatePoint_fullKernelDiscAt_of_odd (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Classical
+theorem ModularCurve.TatePoint.fullKernelDiscAt_of_odd (N : ℕ) [NeZero N] (hN : Odd N) :
+    FullKernelDiscAt N :=
+  solution N hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_TatePoint_fullKernelInjAt.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_TatePoint_fullKernelInjAt.lean
new file mode 100644
index 0000000000..28e36f58ce
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_TatePoint_fullKernelInjAt.lean
@@ -0,0 +1,153 @@
+/-
+Based on Prove2Me node ModularCurve.TatePoint.fullKernelInjAt
+(806a70f5-a83e-5cd1-ab7a-43f432d4d456) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 32e0efa2-00c3-57cc-926b-c6453101382c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CycSubRootBridgeN
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_abelTheorem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_separableAlong_of_charZero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_ker_pointMapOfPushforward_eq_of_j_eq_of_forall_pointEnd_eq_zsmul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_forall_pointEnd_eq_zsmul_of_transcendental_j
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_forall_normFormulaAlong_of_isAlgClosed_of_charZero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_functionFieldHom_fullKernelQuotient_pointMapOfPushforward_ker_eq_zmultiples
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Injectivity of the full-kernel quotient at level N
+
+Theorem statement: `ModularCurve.TatePoint.fullKernelInjAt`
+(`806a70f5-a83e-5cd1-ab7a-43f432d4d456`), by Claude, 2026-09-05.
+
+Proof: submission `32e0efa2-00c3-57cc-926b-c6453101382c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, assumed nonzero, and write $H$ for the field of Hahn series with
+exponents in $\mathbb{Q}$ and coefficients in $\overline{\mathbb{Q}}$. The theorem asserts the
+property `FullKernelInjAt N`, namely: for any decidable equality on $H$, any Weierstrass curve $W$
+over $H$ that is elliptic (its discriminant a unit) and whose $j$-invariant is transcendental over
+$\mathbb{Q}$, and any two points $Q, Q'$ of the associated affine curve whose additive orders are
+both exactly $N$, suppose the two curves $W.\mathrm{fullKernelQuotient}\,Q\,N$ and
+$W.\mathrm{fullKernelQuotient}\,Q'\,N$ — the Vélu quotients formed from the sums $\sum
+\mathrm{veluGx}(P)$ and $\sum (x_P\,\mathrm{veluGx}(P) - y_P\,\mathrm{veluGy}(P))$ over the
+odd-order summing set of $Q$, respectively $Q'$, with parameter $N-1$ — both have nonzero
+discriminant, so that both are elliptic, and suppose their $j$-invariants (computed with those
+elliptic structures) are equal. Then the subgroups of integer multiples of $Q$ and of $Q'$ in the
+group of points of $W$ coincide, i.e. $\mathbb{Z}Q = \mathbb{Z}Q'$.
+
+This is the injectivity half of the dictionary between cyclic subgroups of order $N$ of an elliptic
+curve with transcendental $j$-invariant and the $j$-invariants of the corresponding Vélu quotients:
+distinct cyclic subgroups of order $N$ give distinct quotient $j$-invariants. It is used in
+identifying the fibre of the modular polynomial with the set of quotient $j$-invariants and in
+producing elliptic curves with prescribed cyclic-subgroup orbit data.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_TatePoint_fullKernelInjAt.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_TatePoint_fullKernelInjAt
+
+open ModularCurve ModularCurve.TatePoint WeierstrassCurve AlgebraicCurve
+
+namespace KernelTower
+
+theorem transcendental_rat_irrel {K : Type*} [Field K] {i₁ i₂ : Algebra ℚ K} {x : K}
+    (h : @Transcendental ℚ K _ _ i₁ x) : @Transcendental ℚ K _ _ i₂ x := by
+  have hi : i₁ = i₂ := Subsingleton.elim _ _
+  subst hi
+  exact h
+
+theorem charZero_functionField {F : Type*} [Field F] [CharZero F] (V : WeierstrassCurve F) :
+    CharZero V.toAffine.FunctionField :=
+  charZero_of_injective_algebraMap (algebraMap F V.toAffine.FunctionField).injective
+
+private theorem fullKernelInjAt' (N : ℕ) [NeZero N] : FullKernelInjAt N := by
+  intro _ W _ ht Q Q' hQ hQ' hΔ hΔ' hj
+  let := isAlgClosed_H
+  let := charZero_H
+  have hV : (W.fullKernelQuotient Q N).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+  have hV' : (W.fullKernelQuotient Q' N).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ'⟩
+  obtain ⟨gW, hcW, hAW⟩ :=
+    Affine.exists_genusOnePlaceGate_isCentred_abelTheorem W.toAffine
+  let := gW
+  have := hcW
+  have := hAW
+  obtain ⟨gV, hcV, hAV⟩ := Affine.exists_genusOnePlaceGate_isCentred_abelTheorem
+    (W.fullKernelQuotient Q N).toAffine
+  let := gV
+  have := hcV
+  have := hAV
+  obtain ⟨gV', hcV', hAV'⟩ := Affine.exists_genusOnePlaceGate_isCentred_abelTheorem
+    (W.fullKernelQuotient Q' N).toAffine
+  let := gV'
+  have := hcV'
+  have := hAV'
+  obtain ⟨ι, hι, hfin, hker⟩ :=
+    exists_functionFieldHom_fullKernelQuotient_pointMapOfPushforward_ker_eq_zmultiples
+      (W := W) (Q := Q) (N := N) hQ hΔ
+  obtain ⟨ι', hι', hfin', hker'⟩ :=
+    exists_functionFieldHom_fullKernelQuotient_pointMapOfPushforward_ker_eq_zmultiples
+      (W := W) (Q := Q') (N := N) hQ' hΔ'
+  have := Affine.hasPrincipalDivisors_of_isAlgClosed W.toAffine
+  have := charZero_functionField (W.fullKernelQuotient Q N)
+  have := charZero_functionField (W.fullKernelQuotient Q' N)
+  have hN : AlgebraicCurve.NormFormulaAlong H ι hfin :=
+    AlgebraicCurve.normFormulaAlong ι hfin (AlgebraicCurve.separableAlong_of_charZero ι hι)
+  have hN' : AlgebraicCurve.NormFormulaAlong H ι' hfin' :=
+    AlgebraicCurve.normFormulaAlong ι' hfin' (AlgebraicCurve.separableAlong_of_charZero ι' hι')
+  have hNs :=
+    Affine.forall_normFormulaAlong_of_isAlgClosed_of_charZero W.toAffine
+  have hE : ∀ D : Affine.IsogenyEndDatum W.toAffine,
+      ∃ m : ℤ, ∀ P : W.toAffine.Point, D.pointEnd (hNs D) P = m • P :=
+    fun D =>
+      Affine.IsogenyEndDatum.exists_forall_pointEnd_eq_zsmul_of_transcendental_j
+      W hNs (transcendental_rat_irrel ht) D
+  have hcard : Nat.card (Affine.pointMapOfPushforward ι hι hfin hN).ker
+      = Nat.card (Affine.pointMapOfPushforward ι' hι' hfin' hN').ker := by
+    rw [hker hN, hker' hN', Nat.card_zmultiples, Nat.card_zmultiples, hQ, hQ']
+  have hkk :=
+    Affine.ker_pointMapOfPushforward_eq_of_j_eq_of_forall_pointEnd_eq_zsmul W hNs
+      hE
+      (W.fullKernelQuotient Q N) (W.fullKernelQuotient Q' N) ι hι hfin hN ι' hι' hfin' hN' hcard hj
+  rw [hker hN, hker' hN'] at hkk
+  exact hkk
+
+end KernelTower
+
+open ModularCurve ModularCurve.TatePoint in
+theorem solution (N : ℕ) [NeZero N] : FullKernelInjAt N :=
+  KernelTower.fullKernelInjAt' N
+
+end S_ModularCurve_TatePoint_fullKernelInjAt
+end P2MW
+export P2MW.S_ModularCurve_TatePoint_fullKernelInjAt (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.TatePoint.fullKernelInjAt (N : ℕ) [NeZero N] :
+    FullKernelInjAt N :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_TatePoint_fullKernelIsRootAt.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_TatePoint_fullKernelIsRootAt.lean
new file mode 100644
index 0000000000..5c5ae4f39f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_TatePoint_fullKernelIsRootAt.lean
@@ -0,0 +1,147 @@
+/-
+Based on Prove2Me node ModularCurve.TatePoint.fullKernelIsRootAt
+(23ca53b5-f2e7-5cd2-8741-b29b81da83dd) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 27b7bf19-a294-502e-95d7-4a5853cff1d7
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CycSubRootBridgeN
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FullKernelQuotient
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_abelTheorem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_functionFieldHom_fullKernelQuotient_pointMapOfPushforward_ker_eq_zmultiples
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_separableAlong_of_charZero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_TatePoint_fullKernelIsRootAt_of_odd
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_TatePoint_fullKernelDiscAt_of_odd
+
+/-!
+# Root property of the full-kernel quotient at every level
+
+Theorem statement: `ModularCurve.TatePoint.fullKernelIsRootAt`
+(`23ca53b5-f2e7-5cd2-8741-b29b81da83dd`), by Claude, 2026-09-05.
+
+Proof: submission `27b7bf19-a294-502e-95d7-4a5853cff1d7`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number. The assertion is the predicate `FullKernelIsRootAt N`, which
+says the following. Write $H$ for the field of Hahn series with rational exponents and coefficients
+in an algebraic closure of $\mathbb{Q}$. For every Weierstrass curve $W$ over $H$ that is elliptic,
+every point $Q$ of the associated affine curve whose additive order is exactly $N$, and under the
+hypothesis $h\Delta$ that the discriminant of `W.fullKernelQuotient Q N` is nonzero — so that this
+curve is itself elliptic, the relevant instance being produced from $h\Delta$ — and for every datum
+`data : ModularCurve.ModularPolynomialData N`, consisting of a polynomial $\Phi \in
+\mathbb{Z}[X][Y]$ that is monic, of degree $\psi(N)$ (Dedekind's $\psi$) in $Y$, and satisfies
+$\Phi(j(q), j(q^N)) = 0$ as a $q$-expansion identity: the one-variable polynomial over $H$ obtained
+from $\Phi$ by applying to each coefficient the evaluation of integer polynomials at $j(W)$ has $j$
+of `W.fullKernelQuotient Q N` as a root. Here `fullKernelQuotient` is the Vélu quotient formed from
+the sums $\sum G_x(P)$ and $\sum (x_P G_x(P) - y_P G_y(P))$ over the set `W.oddOrderSummingSet Q (N
+- 1)`.
+
+This is the classical statement that the modular polynomial of level $N$ vanishes at the pair
+$(j(E), j(E/C))$ for $C$ the cyclic subgroup of order $N$ generated by a point, in the form needed
+over the Hahn-series field used for the Tate-curve analysis, with the quotient given by Vélu's
+explicit formulae for the full kernel. It is one of the hypotheses entering the level-$N$ dictionary
+between roots of the modular polynomial and cyclic subgroups of order $N$, and is used by
+[`ModularCurve.ModularPolynomialData.
+fibrePoly_j_eq_prod_fullKernelQuotient_j_of_transcendental_of_charZero`]
+(thm.html#ModularCurve.ModularPolynomialData.
+fibrePoly_j_eq_prod_fullKernelQuotient_j_of_transcendental_of_charZero)
+and by
+[`ModularCurve.exists_elliptic_cycSub_orbitMap`]
+(thm.html#ModularCurve.exists_elliptic_cycSub_orbitMap).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_TatePoint_fullKernelIsRootAt.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+noncomputable section
+
+namespace ModularCurve
+namespace TatePoint
+
+attribute [local instance] isAlgClosed_H charZero_H
+
+local notation "H" => HahnSeries ℚ (AlgebraicClosure ℚ)
+
+theorem fullKernelIsRootAt_of_tower
+    (N : ℕ) [NeZero N] : FullKernelIsRootAt N := by
+  rcases Nat.even_or_odd N with hE | hO
+  · intro _ W _ Q hQ hΔ data
+    let : (W.fullKernelQuotient Q N).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+    obtain ⟨gW, hgWc, hgWa⟩ := exists_genusOnePlaceGate_isCentred_abelTheorem W.toAffine
+    let := gW
+    have : GenusOnePlaceGate.IsCentred W.toAffine := hgWc
+    have : AbelTheorem W.toAffine := hgWa
+    obtain ⟨gV, hgVc, hgVa⟩ :=
+      exists_genusOnePlaceGate_isCentred_abelTheorem
+        (W.fullKernelQuotient Q N).toAffine
+    let := gV
+    have : GenusOnePlaceGate.IsCentred (W.fullKernelQuotient Q N).toAffine := hgVc
+    have : AbelTheorem (W.fullKernelQuotient Q N).toAffine := hgVa
+    obtain ⟨ι, hι, hfin, hker⟩ :=
+      exists_functionFieldHom_fullKernelQuotient_pointMapOfPushforward_ker_eq_zmultiples
+        hQ hΔ
+    have : HasPrincipalDivisors H W.toAffine.FunctionField :=
+      hasPrincipalDivisors_of_isAlgClosed W.toAffine
+    have : CharZero ((W.fullKernelQuotient Q N).toAffine.FunctionField) :=
+      charZero_of_injective_algebraMap (algebraMap H _).injective
+    have hsep : SeparableAlong H ι := AlgebraicCurve.separableAlong_of_charZero ι hι
+    have hN : NormFormulaAlong H ι hfin := AlgebraicCurve.normFormulaAlong ι hfin hsep
+    have hkerQ := hker hN
+    have hcyc : IsAddCyclic (pointMapOfPushforward ι hι hfin hN).ker := by
+      rw [hkerQ]; infer_instance
+    have hcard : Nat.card (pointMapOfPushforward ι hι hfin hN).ker = N := by
+      rw [hkerQ, Nat.card_zmultiples]; exact hQ
+    exact
+      eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward
+      H W.toAffine (W.fullKernelQuotient Q N).toAffine ι hι hfin hN N hcyc hcard data
+  · exact fullKernelIsRootAt_of_odd N hO
+
+theorem fullKernelDiscAt_of_tower
+    (hevD : ∀ (N : ℕ) [NeZero N], Even N → FullKernelDiscAt N) (N : ℕ) [NeZero N] :
+    FullKernelDiscAt N := by
+  rcases Nat.even_or_odd N with hE | hO
+  · exact hevD N hE
+  · exact fullKernelDiscAt_of_odd N hO
+
+end ModularCurve.TatePoint
+
+end
+
+private theorem ModularCurve.TatePoint.fullKernelIsRootAt_aux
+    (N : ℕ) [NeZero N] : ModularCurve.TatePoint.FullKernelIsRootAt N :=
+  ModularCurve.TatePoint.fullKernelIsRootAt_of_tower N
+
+open ModularCurve TatePoint in
+theorem solution (N : ℕ) [NeZero N] : FullKernelIsRootAt N :=
+  ModularCurve.TatePoint.fullKernelIsRootAt_aux N
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.TatePoint.fullKernelIsRootAt (N : ℕ) [NeZero N] :
+    FullKernelIsRootAt N :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_TatePoint_fullKernelIsRootAt_of_odd.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_TatePoint_fullKernelIsRootAt_of_odd.lean
new file mode 100644
index 0000000000..66d6027261
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_TatePoint_fullKernelIsRootAt_of_odd.lean
@@ -0,0 +1,244 @@
+/-
+Based on Prove2Me node ModularCurve.TatePoint.fullKernelIsRootAt_of_odd
+(6fe3f97f-7a7c-504d-a72b-329e539e4016) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e394d22c-2b9d-59c4-9997-70325fbc01f0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CycSubRootBridgeN
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FullKernelQuotient
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CycSubRootBridgeOdd
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Root property of the full-kernel quotient at odd levels
+
+Theorem statement: `ModularCurve.TatePoint.fullKernelIsRootAt_of_odd`
+(`6fe3f97f-7a7c-504d-a72b-329e539e4016`), by Claude, 2026-09-05.
+
+Proof: submission `e394d22c-2b9d-59c4-9997-70325fbc01f0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a positive natural number which is odd. The assertion is the predicate
+`FullKernelIsRootAt N`, namely: for every Weierstrass curve $W$ over the field $H$ of Hahn series
+with rational exponents and coefficients in $\overline{\mathbb{Q}}$ which is elliptic, every point
+$Q$ of the affine model of $W$ whose additive order is exactly $N$, under the hypothesis $h_\Delta$
+that the discriminant of the curve $W.\mathrm{fullKernelQuotient}\,Q\,N$ is nonzero (so that this
+curve is itself elliptic, its discriminant being a unit), and for every datum `data` of type
+[`ModularCurve.ModularPolynomialData N`](def/ModularCurve_X0.html#L215) — that is, a polynomial
+$\Phi \in \mathbb{Z}[X][Y]$ which is monic, has natural degree equal to $\psi(N)$ (the Dedekind
+$\psi$-function of $N$), and satisfies $\Phi$ evaluated at `evalAtJ` and `jqN N` equal to zero — the
+one-variable polynomial over $H$ obtained from $\Phi$ by mapping each coefficient through evaluation
+of its integer polynomial at $j(W)$ has the $j$-invariant of $W.\mathrm{fullKernelQuotient}\,Q\,N$
+as a root. Here $W.\mathrm{fullKernelQuotient}\,Q\,N$ is the Weierstrass curve produced by Vélu's
+construction `veluQuotientOfSums` from the sums of $G_x(P)$ and of $x_P G_x(P) - y_P G_y(P)$ over
+the set `W.oddOrderSummingSet Q (N - 1)`.
+
+This is the level-$N$ modular equation $\Phi_N\bigl(j(W), j(W/\langle Q\rangle)\bigr) = 0$ for the
+Vélu quotient of an elliptic curve by the cyclic group generated by a point of exact order $N$,
+stated over the Hahn-series field used for the Tate curve. It is the odd-level case of the root
+property and feeds into
+[`ModularCurve.TatePoint.fullKernelIsRootAt`](thm.html#ModularCurve.TatePoint.fullKernelIsRootAt).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_TatePoint_fullKernelIsRootAt_of_odd.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_TatePoint_fullKernelIsRootAt_of_odd
+
+noncomputable section
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_TatePoint_fullKernelIsRootAt_of_odd.ModularCurve \
+  WeierstrassCurve P2MW.S_ModularCurve_TatePoint_fullKernelIsRootAt_of_odd.WeierstrassCurve \
+  Polynomial"
+open scoped Classical
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "map toAffine Δ j fullKernelQuotient \
+  fullKernelQuotient_eq_veluQuotient_oddOrderSummingSet oddOrderSummingSet veluQuotient \
+  veluQuotient_oddOrderSummingSet_discriminant_ne_zero \
+  zmultiples_eq_of_veluQuotient_j_eq_of_transcendental"
+p2m_open "WeierstrassCurve"
+
+theorem j_congr {R : Type*} [CommRing R] {X Y : WeierstrassCurve R} (h : X = Y) (hX : X.IsElliptic)
+    (hY : Y.IsElliptic) : @WeierstrassCurve.j R _ X hX = @WeierstrassCurve.j R _ Y hY := by
+  subst h
+  rfl
+
+private theorem _root_.WeierstrassCurve.fullKernelQuotient_eq_veluQuotient_of_odd_aux {F : Type*}
+    [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+    (Q : W.toAffine.Point) {N : ℕ} (hN : Odd N) (hQ : addOrderOf Q = N) :
+    W.fullKernelQuotient Q N = W.veluQuotient (W.oddOrderSummingSet Q ((N - 1) / 2)) := by
+  obtain ⟨m, rfl⟩ := hN
+  have hm : (2 * m + 1 - 1) / 2 = m := by omega
+  rw [hm]
+  exact W.fullKernelQuotient_eq_veluQuotient_oddOrderSummingSet Q m hQ
+
+p2m_export "WeierstrassCurve" "fullKernelQuotient_eq_veluQuotient_of_odd_aux"
+
+private theorem _root_.WeierstrassCurve.fullKernelQuotient_discriminant_ne_zero_of_odd {L : Type*}
+    [Field L] [DecidableEq L] [IsAlgClosed L]
+    (h2 : (2 : L) ≠ 0) (W : WeierstrassCurve L) [W.IsElliptic] (N : ℕ) [NeZero N] (hN : Odd N)
+    (Q : W.toAffine.Point) (hQ : addOrderOf Q = N) :
+    (W.fullKernelQuotient Q N).Δ ≠ 0 := by
+  obtain ⟨m, rfl⟩ := hN
+  rw [W.fullKernelQuotient_eq_veluQuotient_oddOrderSummingSet Q m hQ]
+  exact WeierstrassCurve.veluQuotient_oddOrderSummingSet_discriminant_ne_zero h2 W m Q hQ
+
+p2m_export "WeierstrassCurve" "fullKernelQuotient_discriminant_ne_zero_of_odd"
+
+private theorem
+  _root_.WeierstrassCurve.zmultiples_eq_of_fullKernelQuotient_j_eq_of_transcendental_of_odd
+    [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    (ht : Transcendental ℚ W.j) (N : ℕ) [NeZero N] (hN : Odd N) (Q Q' : W.toAffine.Point)
+    (hQ : addOrderOf Q = N) (hQ' : addOrderOf Q' = N)
+    (hΔ : (W.fullKernelQuotient Q N).Δ ≠ 0)
+    (hΔ' : (W.fullKernelQuotient Q' N).Δ ≠ 0)
+    (hj : haveI : (W.fullKernelQuotient Q N).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+      haveI : (W.fullKernelQuotient Q' N).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ'⟩
+      (W.fullKernelQuotient Q N).j = (W.fullKernelQuotient Q' N).j) :
+    AddSubgroup.zmultiples Q = AddSubgroup.zmultiples Q' := by
+  obtain ⟨m, rfl⟩ := hN
+  have hWQ := W.fullKernelQuotient_eq_veluQuotient_oddOrderSummingSet Q m hQ
+  have hWQ' := W.fullKernelQuotient_eq_veluQuotient_oddOrderSummingSet Q' m hQ'
+  have hΔ₁ : (W.veluQuotient (W.oddOrderSummingSet Q m)).Δ ≠ 0 := by rw [← hWQ]; exact hΔ
+  have hΔ₂ : (W.veluQuotient (W.oddOrderSummingSet Q' m)).Δ ≠ 0 := by rw [← hWQ']; exact hΔ'
+  rw [j_congr hWQ ⟨isUnit_iff_ne_zero.mpr hΔ⟩ ⟨isUnit_iff_ne_zero.mpr hΔ₁⟩,
+    j_congr hWQ' ⟨isUnit_iff_ne_zero.mpr hΔ'⟩ ⟨isUnit_iff_ne_zero.mpr hΔ₂⟩] at hj
+  exact WeierstrassCurve.zmultiples_eq_of_veluQuotient_j_eq_of_transcendental W ht m Q Q' hQ hQ' hΔ₁
+    hΔ₂ hj
+
+p2m_export "WeierstrassCurve" "zmultiples_eq_of_fullKernelQuotient_j_eq_of_transcendental_of_odd"
+end WeierstrassCurve
+
+namespace ModularCurve
+p2m_export "ModularCurve" "TatePoint.dictOdd TatePoint.Qbar TatePoint.nearCurve TatePoint.CycSubH \
+  TatePoint.RootsAt ModularPolynomialData \
+  ModularPolynomialData.isRoot_map_j_veluQuotient_j_of_addOrderOf_eq TatePoint.dictN"
+namespace ModularPolynomialData
+p2m_export "ModularCurve.ModularPolynomialData" "Φ isRoot_map_j_veluQuotient_j_of_addOrderOf_eq"
+end ModularCurve.ModularPolynomialData
+p2m_open_scoped "ModularCurve ModularCurve.ModularPolynomialData" in
+theorem ModularCurve.ModularPolynomialData.isRoot_map_j_fullKernelQuotient_j_of_odd
+    [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    (N : ℕ) [NeZero N] (hN : Odd N) (Q : W.toAffine.Point) (hQ : addOrderOf Q = N)
+    (hΔ : (W.fullKernelQuotient Q N).Δ ≠ 0)
+    (data : ModularCurve.ModularPolynomialData N) :
+    haveI : (W.fullKernelQuotient Q N).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+    (data.Φ.map (Polynomial.eval₂RingHom
+      (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ))) W.j)).IsRoot
+      (W.fullKernelQuotient Q N).j := by
+  obtain ⟨m, rfl⟩ := hN
+  have hWQ := W.fullKernelQuotient_eq_veluQuotient_oddOrderSummingSet Q m hQ
+  have hΔ₁ : (W.veluQuotient (W.oddOrderSummingSet Q m)).Δ ≠ 0 := by rw [← hWQ]; exact hΔ
+  rw [WeierstrassCurve.j_congr hWQ ⟨isUnit_iff_ne_zero.mpr hΔ⟩ ⟨isUnit_iff_ne_zero.mpr hΔ₁⟩]
+  exact ModularCurve.ModularPolynomialData.isRoot_map_j_veluQuotient_j_of_addOrderOf_eq W m Q hQ hΔ₁
+    data
+
+namespace ModularCurve
+p2m_export "ModularCurve" "TatePoint.dictOdd TatePoint.Qbar TatePoint.nearCurve TatePoint.CycSubH \
+  TatePoint.RootsAt ModularPolynomialData \
+  ModularPolynomialData.isRoot_map_j_veluQuotient_j_of_addOrderOf_eq TatePoint.dictN"
+namespace TatePoint
+p2m_export "ModularCurve.TatePoint" "cycSubRootOdd rootsEquivCycSubHOdd \
+  rootsEquivCycSubHOdd_apply_eq_iff dictOdd cycSubGen addOrderOf_cycSubGen Qbar H nearCurve \
+  CycSubH RootsAt nearCurve_j_transcendental FullKernelIsRootAt FullKernelInjAt FullKernelDiscAt \
+  cycSubRootN rootsEquivCycSubHN rootsEquivCycSubHN_apply_eq_iff dictN"
+p2m_open "ModularCurve.TatePoint ModularCurve"
+
+private theorem cycSubRootN_eq_cycSubRootOdd_aux (E : WeierstrassCurve H) [E.IsElliptic] {N : ℕ}
+    [NeZero N] (hN : Odd N)
+    (hW1 : FullKernelIsRootAt N) (hW3 : FullKernelDiscAt N) (data : ModularPolynomialData N)
+    (G : CycSubH E N) : cycSubRootN E hW1 hW3 data G = cycSubRootOdd E hN data G :=
+  Subtype.ext (WeierstrassCurve.j_congr
+    (E.fullKernelQuotient_eq_veluQuotient_of_odd_aux (cycSubGen E G) hN (addOrderOf_cycSubGen E G))
+      _ _)
+
+private theorem rootsEquivCycSubHN_eq_rootsEquivCycSubHOdd_aux (E : WeierstrassCurve H)
+    [E.IsElliptic] {N : ℕ} [NeZero N]
+    (hN : Odd N) (hW1 : FullKernelIsRootAt N) (hW2 : FullKernelInjAt N) (hW3 : FullKernelDiscAt N)
+    (data : ModularPolynomialData N) (hj : Transcendental Qbar E.j) :
+    rootsEquivCycSubHN E hW1 hW2 hW3 data hj = rootsEquivCycSubHOdd E hN data hj := by
+  ext r : 1
+  rw [rootsEquivCycSubHN_apply_eq_iff, cycSubRootN_eq_cycSubRootOdd_aux E hN,
+    ← rootsEquivCycSubHOdd_apply_eq_iff E hN data hj r (rootsEquivCycSubHOdd E hN data hj r)]
+
+private theorem dictN_eq_dictOdd_aux (N : ℕ) [NeZero N] (hN : Odd N)
+    (data : ModularPolynomialData N) (j₀ : Qbar)
+    (hW1 : FullKernelIsRootAt N) (hW2 : FullKernelInjAt N) (hW3 : FullKernelDiscAt N) :
+    dictN N data j₀ hW1 hW2 hW3 = dictOdd N hN data j₀ :=
+  rootsEquivCycSubHN_eq_rootsEquivCycSubHOdd_aux (nearCurve j₀) hN hW1 hW2 hW3 data
+    (nearCurve_j_transcendental j₀)
+
+private theorem fullKernelIsRootAt_of_odd_aux (N : ℕ) [NeZero N] (hN : Odd N) :
+    FullKernelIsRootAt N :=
+  fun W _ Q hQ hΔ data =>
+    ModularCurve.ModularPolynomialData.isRoot_map_j_fullKernelQuotient_j_of_odd W N hN Q hQ hΔ data
+
+private theorem fullKernelInjAt_of_odd_aux (N : ℕ) [NeZero N] (hN : Odd N) : FullKernelInjAt N :=
+  fun W _ ht Q Q' hQ hQ' hΔ hΔ' hj =>
+    W.zmultiples_eq_of_fullKernelQuotient_j_eq_of_transcendental_of_odd ht N hN Q Q' hQ hQ' hΔ hΔ'
+      hj
+
+private theorem fullKernelDiscAt_of_odd_aux (N : ℕ) [NeZero N] (hN : Odd N) : FullKernelDiscAt N :=
+  fun h2 W _ Q hQ => W.fullKernelQuotient_discriminant_ne_zero_of_odd h2 N hN Q hQ
+
+def dictNOdd (N : ℕ) [NeZero N] (hN : Odd N) (data : ModularPolynomialData N) (j₀ : Qbar) :
+    RootsAt data (nearCurve j₀).j ≃ CycSubH (nearCurve j₀) N :=
+  dictN N data j₀ (fullKernelIsRootAt_of_odd_aux N hN) (fullKernelInjAt_of_odd_aux N hN)
+    (fullKernelDiscAt_of_odd_aux N hN)
+
+theorem dictNOdd_eq_dictOdd (N : ℕ) [NeZero N] (hN : Odd N) (data : ModularPolynomialData N)
+    (j₀ : Qbar) :
+    dictNOdd N hN data j₀ = dictOdd N hN data j₀ :=
+  dictN_eq_dictOdd_aux N hN data j₀ _ _ _
+
+end ModularCurve.TatePoint
+
+end
+
+noncomputable example (data : ModularCurve.ModularPolynomialData 3) (j₀ :
+  ModularCurve.TatePoint.Qbar) :
+    ModularCurve.TatePoint.RootsAt data (ModularCurve.TatePoint.nearCurve j₀).j ≃
+      ModularCurve.TatePoint.CycSubH (ModularCurve.TatePoint.nearCurve j₀) 3 :=
+  ModularCurve.TatePoint.dictNOdd 3 (by decide) data j₀
+
+open scoped Classical
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_TatePoint_fullKernelIsRootAt_of_odd.ModularCurve
+  _root_.ModularCurve.TatePoint
+  _root_.P2MW.S_ModularCurve_TatePoint_fullKernelIsRootAt_of_odd.ModularCurve.TatePoint in
+theorem solution (N : ℕ) [NeZero N] (hN : Odd N) : FullKernelIsRootAt N :=
+  ModularCurve.TatePoint.fullKernelIsRootAt_of_odd_aux N hN
+
+end S_ModularCurve_TatePoint_fullKernelIsRootAt_of_odd
+end P2MW
+export P2MW.S_ModularCurve_TatePoint_fullKernelIsRootAt_of_odd (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Classical
+theorem ModularCurve.TatePoint.fullKernelIsRootAt_of_odd (N : ℕ) [NeZero N] (hN : Odd N) :
+    FullKernelIsRootAt N :=
+  solution N hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_adjoin_jBar_jNBar_eq_top.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_adjoin_jBar_jNBar_eq_top.lean
new file mode 100644
index 0000000000..137e3f5c99
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_adjoin_jBar_jNBar_eq_top.lean
@@ -0,0 +1,663 @@
+/-
+Based on Prove2Me node ModularCurve.adjoin_jBar_jNBar_eq_top
+(a0bc6702-c087-5351-80e5-1c64917ae73e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 016e144d-12a4-5af6-8241-6f30d87269fe
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlace
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_RamificationBound
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularFunctionField_eq_full
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_adjoin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_mem_puiseuxRamSubfield_iff
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_BaseChangeGalois
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceInfty
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_hasRamBound
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_algEquiv_smul_eq_of_restrict_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_restrict_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_eq_ofHeightOneSpectrum_or_eq_placeInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_isAlgClosed_rat
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Base change of modular function field generated by j and j_N
+
+Theorem statement: `ModularCurve.adjoin_jBar_jNBar_eq_top` (`a0bc6702-c087-5351-80e5-1c64917ae73e`),
+by Claude, 2026-09-05.
+
+Proof: submission `016e144d-12a4-5af6-8241-6f30d87269fe`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with an algebra structure over $\mathbb{Q}$, and let $N$ be a nonzero
+natural number. Write $jq \in \mathbb{Q}((q))$ for the Laurent series $q^{-1}$ times the image in
+$\mathbb{Q}((q))$ of the integral power series `jNum`, i.e. the $q$-expansion of the modular
+$j$-invariant, and let `qExpand ℚ d` be the ring endomorphism of $\mathbb{Q}((q))$ substituting $q
+\mapsto q^{d}$ (transport of the Hahn-series exponents along multiplication by $d$ on $\mathbb{Z}$).
+The field `modularFunctionFieldFull N` is the intermediate field of $\mathbb{Q}((q))/\mathbb{Q}$
+generated by all `qExpand ℚ d jq` with $d$ a nonzero divisor of $N$, and its base change
+`laurentBaseChange L (modularFunctionFieldFull N)` is the intermediate field of $L((q))/L$ generated
+by the image of that set under the coefficientwise embedding `coeffEmb L` induced by $\mathbb{Q} \to
+L$. The assertion is that, inside this base-changed field, the $L$-intermediate field generated by
+just the two elements `coeffEmb L jq` and `coeffEmb L (qExpand ℚ N jq)` — each taken with its
+membership in the base change — is all of it, i.e. equals $\top$.
+
+This is the $L$-rational form of the classical statement that the function field of $X_0(N)$ is
+generated by $j$ and $j_N = j(q^N)$; it supplies the generation half used to compare or extend
+embeddings of that field by their values on these two elements alone, and says nothing about the
+degree of the extension or the modular polynomial $\Phi_N$. It is invoked throughout the analysis of
+places and Hecke divisors on the characteristic-$p$ models of the modular curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_adjoin_jBar_jNBar_eq_top.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_adjoin_jBar_jNBar_eq_top
+
+noncomputable section
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_adjoin_jBar_jNBar_eq_top.ModularCurve"
+
+namespace HahnSeries
+p2m_export "HahnSeries" "support algebraMap_apply' ofPowerSeries_C support_embDomain_subset single \
+  embDomain order mem_support powerSeriesAlgebra coeff order_mul order_le_of_coeff_ne_zero \
+  ofPowerSeries_X algebraMap_apply coeff_zero embDomainRingHom_C C map ofPowerSeries_apply_coeff \
+  single_ne_zero order_zero ofPowerSeries_injective ofPowerSeries coeff_order_eq_zero \
+  ofPowerSeries_apply embDomain_single order_single HasRamBound puiseuxRamSubfield \
+  mem_puiseuxRamSubfield_iff isAlgClosed_rat"
+p2m_open "HahnSeries"
+
+variable {K : Type*} [Field K]
+
+theorem algebraMap_eq_C' (a : K) : algebraMap K (HahnSeries ℚ K) a = C a := by
+  rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_eq, ofPowerSeries_C]
+
+theorem C_mem_puiseuxRamSubfield {e : ℕ} (he : 0 < e) (a : K) :
+    (C a : HahnSeries ℚ K) ∈ puiseuxRamSubfield K he :=
+  RingHom.mem_fieldRange.mpr ⟨C a, embDomainRingHom_C⟩
+
+theorem single_one_mem_puiseuxRamSubfield {e : ℕ} (he : 0 < e) (c : K) :
+    single (1 : ℚ) c ∈ puiseuxRamSubfield K he := by
+  refine RingHom.mem_fieldRange.mpr ⟨single (e : ℤ) c, ?_⟩
+  change embDomain _ (single (e : ℤ) c) = single (1 : ℚ) c
+  rw [embDomain_single]
+  change single (((e : ℤ) : ℚ) / e) c = single 1 c
+  rw [Int.cast_natCast, div_self (Nat.cast_ne_zero.mpr he.ne')]
+
+end HahnSeries
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place SemilinearAut SemilinearAut.ofAlgAut \
+  SemilinearAut.ofAlgAut_smul SemilinearAut.ord_smul Place.ord_ofHeightOneSpectrum_ne_zero_iff \
+  RationalFunctionField.heightOneSpectrumOfIrreducible \
+  RationalFunctionField.heightOneSpectrumOfIrreducible_asIdeal RationalFunctionField.finitePlace \
+  RationalFunctionField.finitePlace_def Place.exists_ord_mul_eq_order_of_hasRamBound \
+  Place.exists_algEquiv_smul_eq_of_restrict_eq Place.exists_restrict_eq \
+  RationalFunctionField.eq_ofHeightOneSpectrum_or_eq_placeInfty \
+  RationalFunctionField.ord_placeInfty_algebraMap"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ord ord_coe_irreducible ord_smul toValuationSubring \
+  ramificationIndex ramificationIndex_pos restrict ord_restrict \
+  ord_ofHeightOneSpectrum_ne_zero_iff exists_ord_mul_eq_order_of_hasRamBound \
+  exists_algEquiv_smul_eq_of_restrict_eq exists_restrict_eq"
+end AlgebraicCurve.Place
+p2m_open_scoped "AlgebraicCurve AlgebraicCurve.Place" in
+private theorem AlgebraicCurve.Place.ord_pos_and_dvd_of_hasRamBound {K L F : Type*} [Field K]
+    [Field L]
+    [Algebra K L] [Field F] [Algebra K F] (φ : F →ₐ[K] HahnSeries ℚ L) {d : ℕ}
+    (hram : ∀ x : F, HahnSeries.HasRamBound d (φ x)) (v : AlgebraicCurve.Place K F) {g : ℚ}
+    (hg : 0 < g) (hφv : ∀ x : F, (v.ord x : ℚ) * g = (φ x).order) {x₀ : F}
+    (hx₀ : (φ x₀).order = 1) :
+    0 < v.ord x₀ ∧ v.ord x₀ ∣ (d : ℤ) := by
+  have h1 : (v.ord x₀ : ℚ) * g = 1 := by rw [hφv, hx₀]
+  have hpos : (0 : ℚ) < v.ord x₀ := by
+    by_contra hle
+    have : (v.ord x₀ : ℚ) * g ≤ 0 := mul_nonpos_of_nonpos_of_nonneg (not_lt.mp hle) hg.le
+    rw [h1] at this
+    exact absurd this (not_le.mpr one_pos)
+  obtain ⟨π₀, hπ₀⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπ : v.ord (π₀ : F) = 1 := v.ord_coe_irreducible hπ₀
+  have hgπ : g = (φ (π₀ : F)).order := by
+    have := hφv (π₀ : F); rwa [hπ, Int.cast_one, one_mul] at this
+  have hπne : φ (π₀ : F) ≠ 0 := by
+    intro h0
+    rw [h0, HahnSeries.order_zero] at hgπ
+    exact hg.ne' hgπ
+  obtain ⟨k, hk⟩ := hram (π₀ : F) (fun h => hπne (HahnSeries.coeff_order_eq_zero.mp h))
+  dsimp only at hk
+  have hd : (d : ℚ) ≠ 0 := by
+    intro hd
+    simp only [hd, div_zero] at hk
+    rw [← hk] at hgπ
+    exact hg.ne' hgπ
+  have hk' : (v.ord x₀ : ℚ) * k = d := by
+    rw [hgπ, ← hk] at h1
+    field_simp at h1
+    linarith
+  have hkint : v.ord x₀ * k = (d : ℤ) := by exact_mod_cast hk'
+  exact ⟨by exact_mod_cast hpos, Dvd.intro k hkint⟩
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand jq jqN evalAtJ evalAtJ_X ModularPolynomialData \
+  FunctionFieldGeneration modularFunctionField modularFunctionFieldFull jqd_mem_full coeffEmb \
+  laurentBaseChange coeffEmb_mem_laurentBaseChange jq_mem_full modularFunctionField_eq_full \
+  laurentBaseChange_adjoin"
+p2m_open "ModularCurve"
+
+variable (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N]
+
+private theorem isRoot_map_Φ_apply_jBar_of_dvd {d : ℕ} [NeZero d] (hd : d ∣ N)
+    (dd : ModularPolynomialData d)
+    {A : Type*} [CommRing A] [Algebra L A]
+    (φ : laurentBaseChange L (modularFunctionFieldFull N) →ₐ[L] A) :
+    (dd.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom A)
+      (φ ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩))).IsRoot
+      (φ ⟨coeffEmb L (qExpand ℚ d jq),
+        coeffEmb_mem_laurentBaseChange L (jqd_mem_full N hd)⟩) := by
+  have hθ : ((laurentBaseChange L (modularFunctionFieldFull N)).val :
+        laurentBaseChange L (modularFunctionFieldFull N) →+* LaurentSeries L).comp
+      (Polynomial.eval₂RingHom (Int.castRingHom (laurentBaseChange L (modularFunctionFieldFull N)))
+        ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩)
+      = (coeffEmb L).comp evalAtJ := by
+    refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+    simp only [RingHom.coe_comp, Function.comp_apply, Polynomial.coe_eval₂RingHom,
+      Polynomial.eval₂_X, evalAtJ_X]
+    rfl
+  have key : dd.Φ.eval₂
+      (Polynomial.eval₂RingHom (Int.castRingHom (laurentBaseChange L (modularFunctionFieldFull N)))
+        ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩)
+      (⟨coeffEmb L (qExpand ℚ d jq), coeffEmb_mem_laurentBaseChange L (jqd_mem_full N hd)⟩ :
+        laurentBaseChange L (modularFunctionFieldFull N)) = 0 := by
+    apply ((laurentBaseChange L (modularFunctionFieldFull N)).val :
+        laurentBaseChange L (modularFunctionFieldFull N) →+* LaurentSeries L).injective
+    rw [Polynomial.hom_eval₂, hθ, map_zero]
+    have h2 : ((laurentBaseChange L (modularFunctionFieldFull N)).val :
+        laurentBaseChange L (modularFunctionFieldFull N) →+* LaurentSeries L)
+        ⟨coeffEmb L (qExpand ℚ d jq), coeffEmb_mem_laurentBaseChange L (jqd_mem_full N hd)⟩
+        = coeffEmb L (jqN d) := rfl
+    rw [h2, ← Polynomial.hom_eval₂, dd.eval_eq_zero, map_zero]
+  have hρ : (φ : laurentBaseChange L (modularFunctionFieldFull N) →+* A).comp
+      (Polynomial.eval₂RingHom (Int.castRingHom (laurentBaseChange L (modularFunctionFieldFull N)))
+        ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩)
+      = Polynomial.eval₂RingHom (Int.castRingHom A)
+          (φ ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩) := by
+    refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+    simp only [RingHom.coe_comp, Function.comp_apply, Polynomial.coe_eval₂RingHom,
+      Polynomial.eval₂_X]
+    rfl
+  rw [Polynomial.IsRoot.def, Polynomial.eval_map, ← hρ]
+  have h3 := Polynomial.hom_eval₂ dd.Φ
+    (Polynomial.eval₂RingHom (Int.castRingHom (laurentBaseChange L (modularFunctionFieldFull N)))
+      ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩)
+    (φ : laurentBaseChange L (modularFunctionFieldFull N) →+* A)
+    (⟨coeffEmb L (qExpand ℚ d jq), coeffEmb_mem_laurentBaseChange L (jqd_mem_full N hd)⟩ :
+      laurentBaseChange L (modularFunctionFieldFull N))
+  rw [key, map_zero] at h3
+  exact h3.symm
+
+private theorem isRoot_map_Φ_apply_jBar (data : ModularPolynomialData N) {A : Type*} [CommRing A]
+    [Algebra L A] (φ : laurentBaseChange L (modularFunctionFieldFull N) →ₐ[L] A) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom A)
+      (φ ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩))).IsRoot
+      (φ ⟨coeffEmb L (qExpand ℚ N jq),
+        coeffEmb_mem_laurentBaseChange L (jqd_mem_full N (dvd_refl N))⟩) :=
+  isRoot_map_Φ_apply_jBar_of_dvd L N (dvd_refl N) data φ
+
+private theorem laurentBaseChange_full_eq_adjoin_pair :
+    laurentBaseChange L (modularFunctionFieldFull N)
+      = IntermediateField.adjoin L {coeffEmb L jq, coeffEmb L (qExpand ℚ N jq)} := by
+  rw [← modularFunctionField_eq_full N, modularFunctionField, laurentBaseChange_adjoin,
+    Set.image_pair]
+
+private theorem adjoin_jBar_jNBar_eq_top :
+    IntermediateField.adjoin L
+      ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩,
+        ⟨coeffEmb L (qExpand ℚ N jq),
+          coeffEmb_mem_laurentBaseChange L (jqd_mem_full N (dvd_refl N))⟩} :
+        Set (laurentBaseChange L (modularFunctionFieldFull N)))
+      = ⊤ := by
+  rw [eq_top_iff]
+  rintro x -
+  refine (IntermediateField.mem_lift x).mp ?_
+  have hle : laurentBaseChange L (modularFunctionFieldFull N)
+      ≤ IntermediateField.lift (IntermediateField.adjoin L
+          ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩,
+            ⟨coeffEmb L (qExpand ℚ N jq),
+              coeffEmb_mem_laurentBaseChange L (jqd_mem_full N (dvd_refl N))⟩} :
+            Set (laurentBaseChange L (modularFunctionFieldFull N)))) := by
+    refine (laurentBaseChange_full_eq_adjoin_pair L N).le.trans ?_
+    rw [IntermediateField.adjoin_le_iff]
+    rintro y (rfl | rfl)
+    · exact (IntermediateField.mem_lift
+        (⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩ :
+          laurentBaseChange L (modularFunctionFieldFull N))).mpr
+        (IntermediateField.subset_adjoin _ _ (Set.mem_insert _ _))
+    · exact (IntermediateField.mem_lift
+        (⟨coeffEmb L (qExpand ℚ N jq), coeffEmb_mem_laurentBaseChange L (jqd_mem_full N (dvd_refl
+          N))⟩ :
+          laurentBaseChange L (modularFunctionFieldFull N))).mpr
+        (IntermediateField.subset_adjoin _ _ (Set.mem_insert_of_mem _ rfl))
+  exact hle x.2
+
+end ModularCurve
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand jq jqN evalAtJ evalAtJ_X ModularPolynomialData \
+  FunctionFieldGeneration modularFunctionField modularFunctionFieldFull jqd_mem_full coeffEmb \
+  laurentBaseChange coeffEmb_mem_laurentBaseChange jq_mem_full modularFunctionField_eq_full \
+  laurentBaseChange_adjoin"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.ord_jBar_sub_pos_and_dvd_of_forall_isRoot_hasRamBound (L : Type*)
+    [Field L]
+    [Algebra ℚ L] (N : ℕ) [NeZero N] (data : ModularCurve.ModularPolynomialData N) (j₀ : L)
+    {d : ℕ} (hd : 0 < d)
+    (hroots : ∀ r : HahnSeries ℚ L,
+      (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ L))
+        (HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : L)))).IsRoot r →
+        HahnSeries.HasRamBound d r)
+    (v : AlgebraicCurve.Place L (ModularCurve.laurentBaseChange L
+      (ModularCurve.modularFunctionFieldFull N)))
+    (φ : ModularCurve.laurentBaseChange L (ModularCurve.modularFunctionFieldFull N)
+      →ₐ[L] HahnSeries ℚ L)
+    (hφj : φ ⟨ModularCurve.coeffEmb L ModularCurve.jq,
+        ModularCurve.coeffEmb_mem_laurentBaseChange L (ModularCurve.jq_mem_full N)⟩
+      = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : L))
+    {g : ℚ} (hg : 0 < g) (hφv : ∀ x, (v.ord x : ℚ) * g = (φ x).order) :
+    0 < v.ord (⟨ModularCurve.coeffEmb L ModularCurve.jq,
+          ModularCurve.coeffEmb_mem_laurentBaseChange L (ModularCurve.jq_mem_full N)⟩
+        - algebraMap L _ j₀) ∧
+      v.ord (⟨ModularCurve.coeffEmb L ModularCurve.jq,
+          ModularCurve.coeffEmb_mem_laurentBaseChange L (ModularCurve.jq_mem_full N)⟩
+        - algebraMap L _ j₀) ∣ (d : ℤ) := by
+  let P : IntermediateField L (HahnSeries ℚ L) :=
+    (HahnSeries.puiseuxRamSubfield L hd).toIntermediateField (by
+      intro a
+      rw [HahnSeries.algebraMap_eq_C']
+      exact HahnSeries.C_mem_puiseuxRamSubfield hd a)
+  have hjP : (⟨ModularCurve.coeffEmb L ModularCurve.jq,
+      ModularCurve.coeffEmb_mem_laurentBaseChange L (ModularCurve.jq_mem_full N)⟩ :
+      ModularCurve.laurentBaseChange L (ModularCurve.modularFunctionFieldFull N)) ∈ P.comap φ := by
+    change φ _ ∈ HahnSeries.puiseuxRamSubfield L hd
+    rw [hφj]
+    exact add_mem (HahnSeries.C_mem_puiseuxRamSubfield hd j₀)
+      (HahnSeries.single_one_mem_puiseuxRamSubfield hd 1)
+  have hjNP : (⟨ModularCurve.coeffEmb L (ModularCurve.qExpand ℚ N ModularCurve.jq),
+      ModularCurve.coeffEmb_mem_laurentBaseChange L (ModularCurve.jqd_mem_full N (dvd_refl N))⟩ :
+      ModularCurve.laurentBaseChange L (ModularCurve.modularFunctionFieldFull N)) ∈ P.comap φ := by
+    change φ _ ∈ HahnSeries.puiseuxRamSubfield L hd
+    refine (HahnSeries.mem_puiseuxRamSubfield_iff hd).mpr (hroots _ ?_)
+    have h := ModularCurve.isRoot_map_Φ_apply_jBar L N data φ
+    rwa [hφj] at h
+  have htop : P.comap φ = ⊤ := by
+    refine eq_top_iff.mpr ?_
+    rw [← ModularCurve.adjoin_jBar_jNBar_eq_top L N, IntermediateField.adjoin_le_iff]
+    exact Set.insert_subset_iff.mpr ⟨hjP, Set.singleton_subset_iff.mpr hjNP⟩
+  have hall : ∀ x, HahnSeries.HasRamBound d (φ x) := fun x => by
+    have hx : x ∈ P.comap φ := by rw [htop]; exact IntermediateField.mem_top
+    exact (HahnSeries.mem_puiseuxRamSubfield_iff hd).mp hx
+  refine AlgebraicCurve.Place.ord_pos_and_dvd_of_hasRamBound φ hall v hg hφv ?_
+  have hC : algebraMap L (HahnSeries ℚ L) j₀ = HahnSeries.C j₀ := HahnSeries.algebraMap_eq_C' j₀
+  rw [map_sub, hφj, AlgHom.commutes, hC, add_sub_cancel_left, HahnSeries.order_single one_ne_zero]
+
+open Polynomial
+
+namespace HahnSeries
+p2m_export "HahnSeries" "support algebraMap_apply' ofPowerSeries_C support_embDomain_subset single \
+  embDomain order mem_support powerSeriesAlgebra coeff order_mul order_le_of_coeff_ne_zero \
+  ofPowerSeries_X algebraMap_apply coeff_zero embDomainRingHom_C C map ofPowerSeries_apply_coeff \
+  single_ne_zero order_zero ofPowerSeries_injective ofPowerSeries coeff_order_eq_zero \
+  ofPowerSeries_apply embDomain_single order_single HasRamBound puiseuxRamSubfield \
+  mem_puiseuxRamSubfield_iff isAlgClosed_rat"
+p2m_open "HahnSeries"
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+
+theorem algebraMap_eq_C_algebraMap (k : K) :
+    algebraMap K (HahnSeries ℚ L) k = C (algebraMap K L k) := by
+  rw [HahnSeries.algebraMap_apply',
+    show algebraMap K (PowerSeries L) k = PowerSeries.C (algebraMap K L k) from
+      MvPowerSeries.algebraMap_apply (σ := Unit) (R := K) (A := L),
+    ofPowerSeries_C]
+
+omit [Algebra K L] in
+theorem eval₂_C_single_one_eq_ofPowerSeries (r : L[X]) :
+    r.eval₂ (C : L →+* HahnSeries ℚ L) (single (1 : ℚ) (1 : L)) = ofPowerSeries ℚ L (r : PowerSeries
+      L) := by
+  have h : (Polynomial.eval₂RingHom (C : L →+* HahnSeries ℚ L) (single (1 : ℚ) 1))
+      = (ofPowerSeries ℚ L).comp (Polynomial.coeToPowerSeries.ringHom : L[X] →+* PowerSeries L)
+        := by
+    refine Polynomial.ringHom_ext (fun c => ?_) ?_
+    · rw [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_C, RingHom.comp_apply,
+        Polynomial.coeToPowerSeries.ringHom_apply, Polynomial.coe_C, ofPowerSeries_C]
+    · rw [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X, RingHom.comp_apply,
+        Polynomial.coeToPowerSeries.ringHom_apply, Polynomial.coe_X, ofPowerSeries_X]
+  exact RingHom.congr_fun h r
+
+omit [Algebra K L] in
+theorem eval₂_C_single_one_ne_zero_and_order_eq_one (q : L[X]) (h0 : q.coeff 0 = 0)
+    (h1 : q.coeff 1 ≠ 0) :
+    q.eval₂ (C : L →+* HahnSeries ℚ L) (single (1 : ℚ) (1 : L)) ≠ 0 ∧
+      (q.eval₂ (C : L →+* HahnSeries ℚ L) (single (1 : ℚ) (1 : L))).order = 1 := by
+  have hq : q = q.divX * Polynomial.X := by
+    conv_lhs => rw [← Polynomial.divX_mul_X_add q, h0, map_zero, add_zero]
+  have hs' : q.divX.eval₂ (C : L →+* HahnSeries ℚ L) (single (1 : ℚ) (1 : L))
+      = ofPowerSeries ℚ L (q.divX : PowerSeries L) := eval₂_C_single_one_eq_ofPowerSeries _
+  have hs0 : (ofPowerSeries ℚ L (q.divX : PowerSeries L)).coeff 0 = q.coeff 1 := by
+    rw [show (0 : ℚ) = ((0 : ℕ) : ℚ) from Nat.cast_zero.symm, ofPowerSeries_apply_coeff,
+      Polynomial.coeff_coe, Polynomial.coeff_divX]
+  have hsne : ofPowerSeries ℚ L (q.divX : PowerSeries L) ≠ 0 := fun h =>
+    h1 (by rw [← hs0, h, HahnSeries.coeff_zero])
+  have hord_s : (ofPowerSeries ℚ L (q.divX : PowerSeries L)).order = 0 := by
+    apply le_antisymm
+    · exact order_le_of_coeff_ne_zero (by rw [hs0]; exact h1)
+    · have hmem : (ofPowerSeries ℚ L (q.divX : PowerSeries L)).order
+          ∈ (ofPowerSeries ℚ L (q.divX : PowerSeries L)).support := by
+        rw [HahnSeries.mem_support]
+        exact fun h => hsne (coeff_order_eq_zero.mp h)
+      rw [ofPowerSeries_apply] at hmem ⊢
+      obtain ⟨n, -, hn⟩ := support_embDomain_subset hmem
+      rw [← hn]
+      exact Nat.cast_nonneg n
+  have ht : (single (1 : ℚ) (1 : L)) ≠ 0 := single_ne_zero one_ne_zero
+  rw [hq, Polynomial.eval₂_mul, Polynomial.eval₂_X, hs']
+  exact ⟨mul_ne_zero hsne ht, by rw [order_mul hsne ht, hord_s, order_single one_ne_zero, zero_add]⟩
+
+theorem eval₂_C_comp_add_single_eq_taylor (p : K[X]) (a : L) :
+    p.eval₂ ((C : L →+* HahnSeries ℚ L).comp (algebraMap K L)) (C a + single (1 : ℚ) (1 : L))
+      = (Polynomial.taylor a (p.map (algebraMap K L))).eval₂ (C : L →+* HahnSeries ℚ L)
+          (single (1 : ℚ) (1 : L)) := by
+  rw [← Polynomial.eval₂_map, Polynomial.taylor_apply, Polynomial.eval₂_comp, Polynomial.eval₂_add,
+    Polynomial.eval₂_X, Polynomial.eval₂_C, add_comm]
+
+theorem eval₂_C_add_single_ne_zero_and_order_eq_one (p : K[X]) (a : L)
+    (ha : Polynomial.aeval a p = 0)
+    (ha' : Polynomial.aeval a (Polynomial.derivative p) ≠ 0) :
+    p.eval₂ ((C : L →+* HahnSeries ℚ L).comp (algebraMap K L)) (C a + single (1 : ℚ) (1 : L)) ≠ 0 ∧
+      (p.eval₂ ((C : L →+* HahnSeries ℚ L).comp (algebraMap K L)) (C a + single (1 : ℚ) (1 :
+        L))).order = 1 := by
+  have hshift := eval₂_C_comp_add_single_eq_taylor p a
+  have h0 : (Polynomial.taylor a (p.map (algebraMap K L))).coeff 0 = 0 := by
+    rw [Polynomial.taylor_coeff_zero, Polynomial.eval_map, ← Polynomial.aeval_def, ha]
+  have h1 : (Polynomial.taylor a (p.map (algebraMap K L))).coeff 1 ≠ 0 := by
+    rw [Polynomial.taylor_coeff_one, Polynomial.derivative_map, Polynomial.eval_map, ←
+      Polynomial.aeval_def]
+    exact ha'
+  rw [hshift]
+  exact eval₂_C_single_one_ne_zero_and_order_eq_one _ h0 h1
+
+end HahnSeries
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place SemilinearAut SemilinearAut.ofAlgAut \
+  SemilinearAut.ofAlgAut_smul SemilinearAut.ord_smul Place.ord_ofHeightOneSpectrum_ne_zero_iff \
+  RationalFunctionField.heightOneSpectrumOfIrreducible \
+  RationalFunctionField.heightOneSpectrumOfIrreducible_asIdeal RationalFunctionField.finitePlace \
+  RationalFunctionField.finitePlace_def Place.exists_ord_mul_eq_order_of_hasRamBound \
+  Place.exists_algEquiv_smul_eq_of_restrict_eq Place.exists_restrict_eq \
+  RationalFunctionField.eq_ofHeightOneSpectrum_or_eq_placeInfty \
+  RationalFunctionField.ord_placeInfty_algebraMap"
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "heightOneSpectrumOfIrreducible \
+  heightOneSpectrumOfIrreducible_asIdeal finitePlace finitePlace_def \
+  eq_ofHeightOneSpectrum_or_eq_placeInfty ord_placeInfty_algebraMap"
+end AlgebraicCurve.RationalFunctionField
+p2m_open_scoped "AlgebraicCurve AlgebraicCurve.RationalFunctionField" in
+private theorem AlgebraicCurve.RationalFunctionField.eq_finitePlace_of_ord_pos {K : Type*} [Field K]
+    {p : K[X]}
+    (hp : Irreducible p) (v : AlgebraicCurve.Place K (RatFunc K))
+    (hv : 0 < v.ord (algebraMap K[X] (RatFunc K) p)) :
+    v = AlgebraicCurve.RationalFunctionField.finitePlace K hp := by
+  classical
+  rcases AlgebraicCurve.RationalFunctionField.eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w,
+    rfl⟩ | rfl
+  · have hmem : p ∈ w.asIdeal :=
+      (AlgebraicCurve.Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w
+        hp.ne_zero).mp hv.ne'
+    have heq : w = AlgebraicCurve.RationalFunctionField.heightOneSpectrumOfIrreducible K hp := by
+      refine IsDedekindDomain.HeightOneSpectrum.ext ?_
+      rw [AlgebraicCurve.RationalFunctionField.heightOneSpectrumOfIrreducible_asIdeal]
+      exact ((PrincipalIdealRing.isMaximal_of_irreducible hp).eq_of_le w.isPrime.ne_top
+        ((Ideal.span_singleton_le_iff_mem _).mpr hmem)).symm
+    rw [heq, AlgebraicCurve.RationalFunctionField.finitePlace_def]
+  · exfalso
+    rw [AlgebraicCurve.RationalFunctionField.ord_placeInfty_algebraMap hp.ne_zero] at hv
+    have := Int.natCast_nonneg p.natDegree
+    omega
+
+p2m_open_scoped "AlgebraicCurve AlgebraicCurve.Place" in
+private theorem AlgebraicCurve.Place.ord_dvd_of_hahnSeries_embedding_of_isGalois
+    {K L M : Type*} [Field K] [Field L] [Algebra K L] [Field M] [Algebra K M]
+    [Algebra (RatFunc K) M] [IsScalarTower K (RatFunc K) M]
+    [FiniteDimensional (RatFunc K) M] [IsGalois (RatFunc K) M]
+    (p : Polynomial K) (hp : Irreducible p) (a : L)
+    (ha : Polynomial.aeval a p = 0) (ha' : Polynomial.aeval a (Polynomial.derivative p) ≠ 0)
+    {d : ℕ} (hd : 0 < d) (ψ : M →ₐ[K] HahnSeries ℚ L)
+    (hψX : ψ (algebraMap (RatFunc K) M (algebraMap (Polynomial K) (RatFunc K) Polynomial.X))
+      = HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L))
+    (hψ : ∀ m : M, HahnSeries.HasRamBound d (ψ m))
+    (W : AlgebraicCurve.Place K M)
+    (hW : 0 < W.ord (algebraMap (RatFunc K) M (algebraMap (Polynomial K) (RatFunc K) p))) :
+    W.ord (algebraMap (RatFunc K) M (algebraMap (Polynomial K) (RatFunc K) p)) ∣ (d : ℤ) := by
+  have hχ : (((ψ : M →+* HahnSeries ℚ L).comp (algebraMap (RatFunc K) M)).comp (algebraMap K[X]
+    (RatFunc K)))
+      = Polynomial.eval₂RingHom ((HahnSeries.C : L →+* HahnSeries ℚ L).comp (algebraMap K L))
+          (HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L)) := by
+    refine Polynomial.ringHom_ext (fun k => ?_) ?_
+    · change ψ (algebraMap (RatFunc K) M (algebraMap K[X] (RatFunc K) (Polynomial.C k)))
+        = Polynomial.eval₂ _ _ (Polynomial.C k)
+      rw [Polynomial.eval₂_C, RatFunc.algebraMap_C, RingHom.comp_apply,
+        show (RatFunc.C k : RatFunc K) = algebraMap K (RatFunc K) k from rfl,
+        ← IsScalarTower.algebraMap_apply, AlgHom.commutes, HahnSeries.algebraMap_eq_C_algebraMap]
+    · change ψ (algebraMap (RatFunc K) M (algebraMap K[X] (RatFunc K) Polynomial.X))
+        = Polynomial.eval₂ _ _ Polynomial.X
+      rw [Polynomial.eval₂_X, hψX]
+  have hψp : ψ (algebraMap (RatFunc K) M (algebraMap K[X] (RatFunc K) p))
+      = p.eval₂ ((HahnSeries.C : L →+* HahnSeries ℚ L).comp (algebraMap K L))
+          (HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L)) := RingHom.congr_fun hχ p
+  have hord : (ψ (algebraMap (RatFunc K) M (algebraMap K[X] (RatFunc K) p))).order = 1 := by
+    rw [hψp]; exact (HahnSeries.eval₂_C_add_single_ne_zero_and_order_eq_one p a ha ha').2
+  obtain ⟨W₀, g, hg, hφv⟩ := AlgebraicCurve.Place.exists_ord_mul_eq_order_of_hasRamBound ψ hd hψ
+    ⟨_, by rw [hord]; exact one_ne_zero⟩
+  have h0 := AlgebraicCurve.Place.ord_pos_and_dvd_of_hasRamBound ψ hψ W₀ hg hφv hord
+  have hres : ∀ V : AlgebraicCurve.Place K M,
+      0 < V.ord (algebraMap (RatFunc K) M (algebraMap K[X] (RatFunc K) p)) →
+        V.restrict (RatFunc K) = AlgebraicCurve.RationalFunctionField.finitePlace K hp := by
+    intro V hV
+    refine AlgebraicCurve.RationalFunctionField.eq_finitePlace_of_ord_pos hp _ ?_
+    have he := V.ramificationIndex_pos (F := RatFunc K)
+    rw [V.ord_restrict (F := RatFunc K)] at hV
+    exact pos_of_mul_pos_right hV (by exact_mod_cast he.le)
+  have hWW₀ : W.restrict (RatFunc K) = W₀.restrict (RatFunc K) :=
+    (hres W hW).trans (hres W₀ h0.1).symm
+  obtain ⟨σ, hσ⟩ := AlgebraicCurve.Place.exists_algEquiv_smul_eq_of_restrict_eq W₀ W hWW₀
+  have hfix : AlgebraicCurve.SemilinearAut.ofAlgAut (σ.restrictScalars K)
+      • (algebraMap (RatFunc K) M (algebraMap K[X] (RatFunc K) p))
+      = algebraMap (RatFunc K) M (algebraMap K[X] (RatFunc K) p) := by
+    rw [AlgebraicCurve.SemilinearAut.ofAlgAut_smul, AlgEquiv.restrictScalars_apply,
+      AlgEquiv.commutes]
+  rw [← hσ, ← hfix, AlgebraicCurve.SemilinearAut.ord_smul]
+  exact h0.2
+
+p2m_open_scoped "AlgebraicCurve AlgebraicCurve.Place" in
+open IntermediateField in
+private theorem AlgebraicCurve.Place.ord_dvd_of_forall_hahnSeries_embedding_hasRamBound
+    {K L F : Type*} [Field K] [CharZero K] [Field L] [Algebra K L] [IsAlgClosed L]
+    [Field F] [Algebra K F] [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [FiniteDimensional (RatFunc K) F]
+    (p : Polynomial K) (hp : Irreducible p) (a : L)
+    (ha : Polynomial.aeval a p = 0) (ha' : Polynomial.aeval a (Polynomial.derivative p) ≠ 0)
+    {d : ℕ} (hd : 0 < d)
+    (hF : ∀ ψ : F →ₐ[K] HahnSeries ℚ L,
+      ψ (algebraMap (RatFunc K) F (algebraMap (Polynomial K) (RatFunc K) Polynomial.X))
+          = HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L) →
+        ∀ x : F, HahnSeries.HasRamBound d (ψ x))
+    (w : AlgebraicCurve.Place K F)
+    (hw : 0 < w.ord (algebraMap (RatFunc K) F (algebraMap (Polynomial K) (RatFunc K) p))) :
+    w.ord (algebraMap (RatFunc K) F (algebraMap (Polynomial K) (RatFunc K) p)) ∣ (d : ℤ) := by
+  classical
+  let φ₀ : K[X] →ₐ[K] HahnSeries ℚ L :=
+    Polynomial.aeval (HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L))
+  have hφ₀ : ∀ q : K[X], φ₀ q = q.eval₂ ((HahnSeries.C : L →+* HahnSeries ℚ L).comp (algebraMap K
+    L))
+      (HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L)) := by
+    intro q
+    change Polynomial.aeval _ q = _
+    rw [Polynomial.aeval_def]
+    congr 1
+    exact RingHom.ext HahnSeries.algebraMap_eq_C_algebraMap
+  have hφ₀inj : Function.Injective φ₀ := by
+    intro q₁ q₂ h
+    have key : ∀ q : K[X], φ₀ q = HahnSeries.ofPowerSeries ℚ L
+        ((Polynomial.taylor a (q.map (algebraMap K L)) : PowerSeries L) : PowerSeries L) := fun q
+          => by
+      rw [hφ₀, HahnSeries.eval₂_C_comp_add_single_eq_taylor,
+        HahnSeries.eval₂_C_single_one_eq_ofPowerSeries]
+    rw [key, key] at h
+    exact Polynomial.map_injective _ (algebraMap K L).injective
+      (Polynomial.taylor_injective a (Polynomial.coe_inj.mp (HahnSeries.ofPowerSeries_injective h)))
+  have hφ₀' : nonZeroDivisors K[X] ≤ (nonZeroDivisors (HahnSeries ℚ L)).comap φ₀ :=
+    nonZeroDivisors_le_comap_nonZeroDivisors_of_injective _ hφ₀inj
+  let ψ₀ : RatFunc K →ₐ[K] HahnSeries ℚ L := RatFunc.liftAlgHom φ₀ hφ₀'
+  have hψ₀ : ∀ q : K[X], ψ₀ (algebraMap K[X] (RatFunc K) q) = φ₀ q := fun q => by
+    have h := RatFunc.liftAlgHom_apply_div φ₀ hφ₀' q 1
+    rwa [map_one, div_one, map_one, div_one] at h
+  have hψ₀X : ψ₀ (algebraMap K[X] (RatFunc K) Polynomial.X) = HahnSeries.C a + HahnSeries.single (1
+    : ℚ) (1 : L) :=
+    by
+    rw [hψ₀]; exact Polynomial.aeval_X _
+  have : Algebra.IsAlgebraic (RatFunc K) F := Algebra.IsAlgebraic.of_finite (RatFunc K) F
+  have : IsAlgClosed (HahnSeries ℚ L) := HahnSeries.isAlgClosed_rat
+  obtain ⟨Ψ, hΨ⟩ := IsAlgClosed.surjective_domRestrict_of_isAlgebraic (K := K) (L := RatFunc K)
+    (M := HahnSeries ℚ L) (E := AlgebraicClosure F) ψ₀
+  have hΨr : ∀ r : RatFunc K, Ψ (algebraMap (RatFunc K) (AlgebraicClosure F) r) = ψ₀ r :=
+    fun r => by
+    rw [← hΨ]; rfl
+  have hφ₀P : ∀ q : K[X], φ₀ q ∈ HahnSeries.puiseuxRamSubfield L hd := by
+    intro q
+    induction q using Polynomial.induction_on' with
+    | add q₁ q₂ h₁ h₂ => rw [map_add]; exact add_mem h₁ h₂
+    | monomial n c =>
+        change Polynomial.aeval _ (Polynomial.monomial n c) ∈ _
+        rw [← Polynomial.C_mul_X_pow_eq_monomial, map_mul, map_pow, Polynomial.aeval_C,
+          Polynomial.aeval_X,
+          HahnSeries.algebraMap_eq_C_algebraMap]
+        exact mul_mem (HahnSeries.C_mem_puiseuxRamSubfield hd _)
+          (pow_mem (add_mem (HahnSeries.C_mem_puiseuxRamSubfield hd _)
+            (HahnSeries.single_one_mem_puiseuxRamSubfield hd _)) _)
+  have hψ₀P : ∀ r : RatFunc K, ψ₀ r ∈ HahnSeries.puiseuxRamSubfield L hd := fun r => by
+    induction r using RatFunc.induction_on with
+    | f p₁ q₁ _ => rw [map_div₀, hψ₀, hψ₀]; exact div_mem (hφ₀P p₁) (hφ₀P q₁)
+  let S : IntermediateField (RatFunc K) (AlgebraicClosure F) :=
+    ((HahnSeries.puiseuxRamSubfield L hd).comap (Ψ : AlgebraicClosure F →+* HahnSeries ℚ
+      L)).toIntermediateField
+      (fun r => by
+        change Ψ (algebraMap (RatFunc K) (AlgebraicClosure F) r) ∈ HahnSeries.puiseuxRamSubfield L
+          hd
+        rw [hΨr]; exact hψ₀P r)
+  have hMS : normalClosure (RatFunc K) F (AlgebraicClosure F) ≤ S := by
+    rw [normalClosure_le_iff]
+    rintro f x ⟨y, rfl⟩
+    change Ψ (f y) ∈ HahnSeries.puiseuxRamSubfield L hd
+    refine (HahnSeries.mem_puiseuxRamSubfield_iff hd).mpr (hF (Ψ.comp (f.restrictScalars K)) ?_ y)
+    change Ψ (f (algebraMap (RatFunc K) F (algebraMap K[X] (RatFunc K) Polynomial.X))) = _
+    rw [f.commutes, hΨr, hψ₀X]
+  have : CharZero F := charZero_of_injective_algebraMap (algebraMap K F).injective
+  have : IsGalois (RatFunc K) (AlgebraicClosure F) := ⟨⟩
+  have : IsScalarTower K F (normalClosure (RatFunc K) F (AlgebraicClosure F)) :=
+    IsScalarTower.of_algebraMap_eq (R := K) (S := F) (A := ↥(normalClosure (RatFunc K) F
+      (AlgebraicClosure F)))
+      (fun k => Subtype.ext (show algebraMap K (AlgebraicClosure F) k
+        = algebraMap F (AlgebraicClosure F) (algebraMap K F k) from IsScalarTower.algebraMap_apply K
+          F _ k))
+  have : Module.Finite F (normalClosure (RatFunc K) F (AlgebraicClosure F)) :=
+    Module.Finite.of_restrictScalars_finite (RatFunc K) F _
+  have : Algebra.IsAlgebraic F (normalClosure (RatFunc K) F (AlgebraicClosure F)) :=
+    Algebra.IsAlgebraic.of_finite F _
+  let ΨM : normalClosure (RatFunc K) F (AlgebraicClosure F) →ₐ[K] HahnSeries ℚ L :=
+    Ψ.comp ((normalClosure (RatFunc K) F (AlgebraicClosure F)).val.restrictScalars K)
+  have hΨM : ∀ m : normalClosure (RatFunc K) F (AlgebraicClosure F), HahnSeries.HasRamBound d (ΨM m)
+    :=
+    fun m => (HahnSeries.mem_puiseuxRamSubfield_iff hd).mp (hMS m.2)
+  have hΨMX : ΨM (algebraMap (RatFunc K) (normalClosure (RatFunc K) F (AlgebraicClosure F))
+      (algebraMap K[X] (RatFunc K) Polynomial.X)) = HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 :
+        L) := by
+    change Ψ ((algebraMap (RatFunc K) (normalClosure (RatFunc K) F (AlgebraicClosure F))
+      (algebraMap K[X] (RatFunc K) Polynomial.X) : AlgebraicClosure F)) = _
+    rw [IntermediateField.coe_algebraMap_apply, hΨr, hψ₀X]
+  obtain ⟨W, hWw⟩ := AlgebraicCurve.Place.exists_restrict_eq
+    (M := normalClosure (RatFunc K) F (AlgebraicClosure F)) w
+  have hpM : algebraMap F (normalClosure (RatFunc K) F (AlgebraicClosure F))
+        (algebraMap (RatFunc K) F (algebraMap K[X] (RatFunc K) p))
+      = algebraMap (RatFunc K) (normalClosure (RatFunc K) F (AlgebraicClosure F)) (algebraMap K[X]
+        (RatFunc K) p) :=
+    (IsScalarTower.algebraMap_apply (RatFunc K) F _ _).symm
+  have hordW : W.ord (algebraMap (RatFunc K) (normalClosure (RatFunc K) F (AlgebraicClosure F))
+        (algebraMap K[X] (RatFunc K) p))
+      = W.ramificationIndex F * w.ord (algebraMap (RatFunc K) F (algebraMap K[X] (RatFunc K) p))
+        := by
+    rw [← hpM, W.ord_restrict (F := F), hWw]
+  have he := W.ramificationIndex_pos (F := F)
+  have hWpos : 0 < W.ord (algebraMap (RatFunc K) (normalClosure (RatFunc K) F (AlgebraicClosure F))
+      (algebraMap K[X] (RatFunc K) p)) := by
+    rw [hordW]; exact mul_pos (by exact_mod_cast he) hw
+  have hdvd :=
+    AlgebraicCurve.Place.ord_dvd_of_hahnSeries_embedding_of_isGalois p hp a ha ha' hd ΨM hΨMX hΨM W
+      hWpos
+  rw [hordW] at hdvd
+  exact dvd_of_mul_left_dvd hdvd
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_adjoin_jBar_jNBar_eq_top.ModularCurve in
+theorem solution (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    IntermediateField.adjoin L
+      ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩,
+        ⟨coeffEmb L (qExpand ℚ N jq),
+          coeffEmb_mem_laurentBaseChange L (jqd_mem_full N (dvd_refl N))⟩} :
+        Set (laurentBaseChange L (modularFunctionFieldFull N)))
+      = ⊤ :=
+  ModularCurve.adjoin_jBar_jNBar_eq_top L N
+
+end S_ModularCurve_adjoin_jBar_jNBar_eq_top
+end P2MW
+export P2MW.S_ModularCurve_adjoin_jBar_jNBar_eq_top (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.adjoin_jBar_jNBar_eq_top (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N]
+    :
+    IntermediateField.adjoin L
+      ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩,
+        ⟨coeffEmb L (qExpand ℚ N jq),
+          coeffEmb_mem_laurentBaseChange L (jqd_mem_full N (dvd_refl N))⟩} :
+        Set (laurentBaseChange L (modularFunctionFieldFull N)))
+      = ⊤ :=
+  solution L N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_aeval_jqN_toAdjoin.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_aeval_jqN_toAdjoin.lean
new file mode 100644
index 0000000000..1c3eac26c7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_aeval_jqN_toAdjoin.lean
@@ -0,0 +1,118 @@
+/-
+Based on Prove2Me node ModularCurve.aeval_jqN_toAdjoin
+(46320c8f-337a-5230-8e70-7d9ba35c7f78) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c9b8ceeb-8645-5962-bd23-8ecb75c5ef1d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# j(q^N) is a root of the modular polynomial over ℚ(j)
+
+Theorem statement: `ModularCurve.aeval_jqN_toAdjoin` (`46320c8f-337a-5230-8e70-7d9ba35c7f78`), by
+Claude, 2026-09-05.
+
+Proof: submission `c9b8ceeb-8645-5962-bd23-8ecb75c5ef1d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and let `data` be a modular-polynomial packet for $N$, i.e. a
+bivariate integral polynomial $\Phi \in (\mathbb{Z}[X])[Y]$ together with three properties: $\Phi$
+is monic in $Y$; its degree in $Y$ equals `dedekindPsi N` $= \sum_{d \mid N,\ d\ \text{squarefree}}
+N/d$; and $\Phi$ vanishes when its coefficients, which lie in $\mathbb{Z}[X]$, are mapped into the
+field of Laurent series $\mathbb{Q}((q))$ by the ring homomorphism `evalAtJ` that evaluates at the
+$q$-expansion `jq` of the modular invariant $j$, and $Y$ is set equal to `jqN N`, the Laurent series
+obtained from `jq` by multiplying all exponents by $N$ (substitution $q \mapsto q^N$). Write
+$\mathbb{Q}\langle jq\rangle$ for the intermediate field of $\mathbb{Q}((q))$ generated over
+$\mathbb{Q}$ by `jq`, and `data.toAdjoin` for the image of $\Phi$ in $\mathbb{Q}\langle
+jq\rangle[Y]$ under coefficientwise application of the homomorphism `evalAtJGen` that sends $X$ to
+the distinguished generator `jGen` of $\mathbb{Q}\langle jq\rangle$. The assertion is that
+evaluating `data.toAdjoin` at `jqN N`, via the inclusion of $\mathbb{Q}\langle jq\rangle$ into
+$\mathbb{Q}((q))$, gives $0$.
+
+This is the statement that $j(q^N)$ is a root of the level-$N$ modular polynomial read as a
+one-variable polynomial over the field generated by $j(q)$, the first step towards identifying that
+polynomial with the minimal polynomial of $j(q^N)$ over $\mathbb{Q}(j(q))$ and hence computing the
+degree $\psi(N)$ of the resulting extension. It is used in the analysis of the modular equation for
+$X_0(N)$, in particular in the irreducibility statement
+[`ModularCurve.phiIrreducible_all`](thm.html#ModularCurve.phiIrreducible_all) and in the coefficient
+computation [`ModularCurve.PhiGen.sum_qTwist_coeff`](thm.html#ModularCurve.PhiGen.sum_qTwist_coeff).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_aeval_jqN_toAdjoin.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_aeval_jqN_toAdjoin
+
+noncomputable section
+
+open Polynomial IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jq jqN dedekindPsi ModularPolynomialData algebraMap_comp_evalAtJGen \
+  ModularPolynomialData.toAdjoin PhiIrreducible"
+p2m_open "ModularCurve"
+
+variable {N : ℕ} [NeZero N]
+
+private theorem aeval_jqN_toAdjoin (data : ModularPolynomialData N) :
+    Polynomial.aeval (jqN N) data.toAdjoin = 0 := by
+  rw [ModularPolynomialData.toAdjoin, Polynomial.aeval_def, Polynomial.eval₂_map,
+    algebraMap_comp_evalAtJGen]
+  exact data.eval_eq_zero
+
+theorem minpoly_jqN_eq_toAdjoin (data : ModularPolynomialData N) (h : PhiIrreducible data) :
+    minpoly ℚ⟮jq⟯ (jqN N) = data.toAdjoin :=
+  (minpoly.eq_of_irreducible_of_monic h (aeval_jqN_toAdjoin data) data.toAdjoin_monic).symm
+
+theorem finrank_adjoin_jqN_eq (data : ModularPolynomialData N) (h : PhiIrreducible data) :
+    Module.finrank ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN N⟯ = dedekindPsi N := by
+  have hint : IsIntegral ℚ⟮jq⟯ (jqN N) := ⟨data.toAdjoin, data.toAdjoin_monic, by
+    rw [← Polynomial.aeval_def]; exact aeval_jqN_toAdjoin data⟩
+  rw [IntermediateField.adjoin.finrank hint, minpoly_jqN_eq_toAdjoin data h,
+    ModularPolynomialData.toAdjoin,
+    data.monic.natDegree_map, data.natDegree_eq]
+
+end ModularCurve
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_aeval_jqN_toAdjoin.ModularCurve
+  ModularCurve.PhiGen in
+theorem solution {N : ℕ} [NeZero N] (data : ModularPolynomialData N) :
+    Polynomial.aeval (jqN N) data.toAdjoin = 0 :=
+  ModularCurve.aeval_jqN_toAdjoin data
+
+end S_ModularCurve_aeval_jqN_toAdjoin
+end P2MW
+export P2MW.S_ModularCurve_aeval_jqN_toAdjoin (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.aeval_jqN_toAdjoin {N : ℕ} [NeZero N] (data : ModularPolynomialData N) :
+    Polynomial.aeval (jqN N) data.toAdjoin = 0 :=
+  solution data
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_aeval_jq_eq_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_aeval_jq_eq_zero.lean
new file mode 100644
index 0000000000..a234d929b6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_aeval_jq_eq_zero.lean
@@ -0,0 +1,97 @@
+/-
+Based on Prove2Me node ModularCurve.aeval_jq_eq_zero
+(6b297b57-a728-5c3d-8a7f-cf5ca651241c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f457ae50-edbf-5862-b501-c5254443a6dd
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A rational polynomial vanishing at j(q) is zero
+
+Theorem statement: `ModularCurve.aeval_jq_eq_zero` (`6b297b57-a728-5c3d-8a7f-cf5ca651241c`), by
+Claude, 2026-09-05.
+
+Proof: submission `f457ae50-edbf-5862-b501-c5254443a6dd`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $p$ be a polynomial in one variable over $\mathbb{Q}$, and suppose that evaluating $p$ at the
+Laurent series `jq` gives $0$, that is, $p(\mathrm{jq}) = 0$ in the field of Laurent series
+`LaurentSeries ℚ` (Hahn series over $\mathbb{Q}$ with value group $\mathbb{Z}$), where the
+evaluation is the $\mathbb{Q}$-algebra map `Polynomial.aeval`. Here `jq` is the element $q^{-1}\cdot
+\mathrm{jNumQ}(q)$, obtained as the product of the Hahn series `HahnSeries.single (-1) 1` supported
+in degree $-1$ with coefficient $1$ and the image under `HahnSeries.ofPowerSeries` of `jNumQ`, the
+power series over $\mathbb{Q}$ got from the integral power series `jNum` by the coefficientwise ring
+map $\mathbb{Z} \to \mathbb{Q}$; thus `jq` is the formal $q$-expansion of the modular $j$-invariant.
+The conclusion is that $p = 0$. Equivalently, `jq` is transcendental over $\mathbb{Q}$ inside
+$\mathbb{Q}((q))$.
+
+This is the basic transcendence statement underlying the construction of the modular function fields
+of $X_0(N)$ inside $\mathbb{Q}((q))$: the $q$-expansion of $j$ satisfies no algebraic relation over
+$\mathbb{Q}$. It is used for
+[`ModularCurve.transcendental_jq`](thm.html#ModularCurve.transcendental_jq) and, after substituting
+$q \mapsto q^N$, for [`ModularCurve.transcendental_jqN`](thm.html#ModularCurve.transcendental_jqN).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_aeval_jq_eq_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_aeval_jq_eq_zero
+
+open ModularCurve IntermediateField
+
+noncomputable section
+
+theorem solution {p : Polynomial ℚ} (hp : Polynomial.aeval jq p = 0) : p = 0 :=by
+  by_contra hp0
+  set n := p.natDegree with hn
+  have hcoeff : (Polynomial.aeval jq p).coeff (-(n : ℤ)) = p.coeff n := by
+    rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+      Finset.sum_eq_single n]
+    · rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_self,
+        mul_one]
+    · intro i hi hin
+      have hilt : i < n := lt_of_le_of_ne (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hin
+      rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_of_lt,
+        mul_zero]
+      omega
+    · intro hn'
+      exact absurd (Finset.self_mem_range_succ n) hn'
+  rw [hp] at hcoeff
+  simp only [HahnSeries.coeff_zero] at hcoeff
+  exact hp0 (Polynomial.leadingCoeff_eq_zero.mp hcoeff.symm)
+
+end
+
+end S_ModularCurve_aeval_jq_eq_zero
+end P2MW
+export P2MW.S_ModularCurve_aeval_jq_eq_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve IntermediateField
+theorem ModularCurve.aeval_jq_eq_zero {p : Polynomial ℚ} (hp : Polynomial.aeval jq p = 0) :
+    p = 0 :=
+  solution hp
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq.lean
new file mode 100644
index 0000000000..9a2c62f93e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq.lean
@@ -0,0 +1,493 @@
+/-
+Based on Prove2Me node ModularCurve.analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq
+(60906260-f073-5409-b93a-d97c5c431efd) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7f31c6b9-95c6-59b2-9bee-da1c3bbfdd63
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import Mathlib.Data.Int.Star
+import Mathlib.Order.CompletePartialOrder
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_four_qCoeff_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_six_qCoeff_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality of X⁶j⁴(j-1728)³ bounds orders of hΔ by gE₄²E₆
+
+Theorem statement: `ModularCurve.analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq`
+(`60906260-f073-5409-b93a-d97c5c431efd`), by Claude, 2026-09-05.
+
+Proof: submission `7f31c6b9-95c6-59b2-9bee-da1c3bbfdd63`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, $k$ an integer, and let $g,h$ be modular forms of weight $k$ for
+$\Gamma_0(N)$. Let $X$ be a Laurent series over $\mathbb{C}$ satisfying $X\cdot\tilde h=\tilde g$ in
+$\mathbb{C}((q))$, where $\tilde g,\tilde h$ denote the $q$-expansions of $g,h$ at $\infty$ taken
+with period $1$ and viewed as Laurent series. Write $J=$ [`ModularCurve.coeffEmb ℂ
+ModularCurve.jq`](def/ModularCurve_LaurentCoeff.html#L81) for the image in $\mathbb{C}((q))$ of the
+Laurent series $q^{-1}\cdot(\mathrm{jNumQ})$ over $\mathbb{Q}$ under the coefficientwise ring map
+induced by $\mathbb{Q}\to\mathbb{C}$, i.e. the $q$-expansion of the modular invariant $j$. Assume
+that $X^6J^4(J-1728)^3$ is integral over the $\mathbb{C}$-subalgebra of $\mathbb{C}((q))$ generated
+by $J$. Then for every $\tau$ in the upper half plane, the analytic order of vanishing at
+$\tau\in\mathbb{C}$ of the function $z\mapsto h(z)\Delta(z)$, composed with
+`UpperHalfPlane.ofComplex`, is at most the analytic order of vanishing at $\tau$ of $z\mapsto
+g(z)E_4(z)^2E_6(z)$, composed with `UpperHalfPlane.ofComplex` (orders taken in
+$\mathbb{N}\cup\{\infty\}$).
+
+The statement converts an integrality hypothesis for the quotient $X=\tilde g/\tilde h$ over
+$\mathbb{C}[j]$ into a pointwise comparison of vanishing orders on the upper half plane, using
+$j=E_4^3/\Delta$ and $j-1728=E_6^2/\Delta$. It is the divisor-theoretic input to
+[`ModularCurve.exists_cuspForm_qExpansion_eq_mul_thetaL_of_isIntegral`]
+(thm.html#ModularCurve.exists_cuspForm_qExpansion_eq_mul_thetaL_of_isIntegral),
+where the resulting divisibility produces a cusp form with prescribed $q$-expansion.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 1600000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq
+
+p2m_open "UpperHalfPlane ModularCurve~coeffEmb_jq"
+open scoped MatrixGroups ModularForm Manifold
+
+noncomputable section
+
+namespace ANb
+
+def Nice (f : ℍ → ℂ) : Prop :=
+  Function.Periodic (f ∘ ofComplex) 1 ∧ MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f ∧ IsBoundedAtImInfty f
+
+theorem Nice.mul {f g : ℍ → ℂ} (hf : Nice f) (hg : Nice g) : Nice (f * g) :=
+  ⟨by simpa [Function.comp_def] using hf.1.mul hg.1, hf.2.1.mul hg.2.1, hf.2.2.mul hg.2.2⟩
+
+theorem Nice.add {f g : ℍ → ℂ} (hf : Nice f) (hg : Nice g) : Nice (f + g) :=
+  ⟨by simpa [Function.comp_def] using hf.1.add hg.1, hf.2.1.add hg.2.1, hf.2.2.add hg.2.2⟩
+
+theorem Nice.const (c : ℂ) : Nice (fun _ => c) :=
+  ⟨fun _ => rfl, mdifferentiable_const, Filter.const_boundedAtFilter _ _⟩
+
+def niceSubalgebra : Subalgebra ℂ (ℍ → ℂ) where
+  carrier := {f | Nice f}
+  mul_mem' hf hg := hf.mul hg
+  add_mem' hf hg := hf.add hg
+  algebraMap_mem' c := Nice.const c
+
+local notation "𝒩" => niceSubalgebra
+
+theorem an (f : 𝒩) : AnalyticAt ℂ (cuspFunction 1 (f : ℍ → ℂ)) 0 :=
+  UpperHalfPlane.analyticAt_cuspFunction_zero one_pos f.2.1 f.2.2.1 f.2.2.2
+
+def qexpHom : 𝒩 →ₐ[ℂ] PowerSeries ℂ where
+  toFun f := qExpansion 1 (f : ℍ → ℂ)
+  map_one' := UpperHalfPlane.qExpansion_one 1
+  map_mul' f g := UpperHalfPlane.qExpansion_mul (an f) (an g)
+  map_zero' := UpperHalfPlane.qExpansion_zero 1
+  map_add' f g := UpperHalfPlane.qExpansion_add (an f) (an g)
+  commutes' c := by
+    have h1 : ((algebraMap ℂ (ℍ → ℂ) c : ℍ → ℂ)) = c • (1 : ℍ → ℂ) := by
+      funext z; simp
+    have a1 : AnalyticAt ℂ (cuspFunction 1 (1 : ℍ → ℂ)) 0 := an (1 : 𝒩)
+    change qExpansion 1 (algebraMap ℂ (ℍ → ℂ) c) = _
+    rw [h1, UpperHalfPlane.qExpansion_smul a1 c, UpperHalfPlane.qExpansion_one,
+      Algebra.algebraMap_eq_smul_one]
+
+theorem qexpHom_apply (f : 𝒩) : qexpHom f = qExpansion 1 (f : ℍ → ℂ) := rfl
+
+def ψ : 𝒩 →ₐ[ℂ] LaurentSeries ℂ :=
+  { (HahnSeries.ofPowerSeries ℤ ℂ).comp qexpHom.toRingHom with
+    commutes' := fun c => by
+      change HahnSeries.ofPowerSeries ℤ ℂ (qexpHom (algebraMap ℂ 𝒩 c)) = _
+      rw [qexpHom.commutes, HahnSeries.algebraMap_apply'] }
+
+theorem ψ_apply (f : 𝒩) : ψ f = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (f : ℍ → ℂ)) := rfl
+
+theorem ψ_injective : Function.Injective ψ := by
+  intro f g hfg
+  rw [ψ_apply, ψ_apply] at hfg
+  have h := HahnSeries.ofPowerSeries_injective hfg
+  have h' : qExpansion 1 ((f : ℍ → ℂ) - (g : ℍ → ℂ)) = 0 := by
+    rw [UpperHalfPlane.qExpansion_sub (an f) (an g), h, sub_self]
+  have hn : Nice ((f : ℍ → ℂ) - (g : ℍ → ℂ)) := (f - g).2
+  have h0 := (UpperHalfPlane.qExpansion_eq_zero_iff one_pos hn.1 hn.2.1 hn.2.2).mp h'
+  exact Subtype.ext (sub_eq_zero.mp h0)
+
+theorem ψ_eq_zero_iff (f : 𝒩) : ψ f = 0 ↔ f = 0 :=
+  ⟨fun h => ψ_injective (by rw [h, map_zero]), fun h => by rw [h, map_zero]⟩
+
+def toC : 𝒩 →ₐ[ℂ] (ℂ → ℂ) where
+  toFun f := (f : ℍ → ℂ) ∘ ofComplex
+  map_one' := rfl
+  map_mul' _ _ := rfl
+  map_zero' := rfl
+  map_add' _ _ := rfl
+  commutes' _ := rfl
+
+theorem toC_apply (f : 𝒩) : toC f = (f : ℍ → ℂ) ∘ ofComplex := rfl
+
+theorem analyticAt_toC (f : 𝒩) (τ : ℍ) : AnalyticAt ℂ (toC f) (τ : ℂ) := by
+  have hd : DifferentiableOn ℂ ((f : ℍ → ℂ) ∘ ofComplex) {z : ℂ | 0 < z.im} :=
+    UpperHalfPlane.mdifferentiable_iff.mp f.2.2.1
+  exact hd.analyticAt ((isOpen_lt continuous_const Complex.continuous_im).mem_nhds τ.im_pos)
+
+theorem nice_of_modularForm {F : Type*} {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (h1 : (1 : ℝ) ∈ Γ.strictPeriods) : Nice (f : ℍ → ℂ) := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Subgroup.isCusp_of_mem_strictPeriods one_pos h1⟩
+  refine ⟨?_, ModularFormClass.holo f, ModularFormClass.bdd_at_infty f⟩
+  simpa using SlashInvariantFormClass.periodic_comp_ofComplex (h := 1) f h1
+
+def ofMF {F : Type*} {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (h1 : (1 : ℝ) ∈ Γ.strictPeriods) : 𝒩 :=
+  ⟨f, nice_of_modularForm f h1⟩
+
+@[scoped simp] theorem coe_ofMF {F : Type*} {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (h1 : (1 : ℝ) ∈ Γ.strictPeriods) :
+    ((ofMF f h1 : 𝒩) : ℍ → ℂ) = f := rfl
+
+theorem one_mem_strictPeriods_gamma0 (N : ℕ) :
+    (1 : ℝ) ∈ (Subgroup.map (Matrix.SpecialLinearGroup.mapGL ℝ) (CongruenceSubgroup.Gamma0
+      N)).strictPeriods := by
+  rw [CongruenceSubgroup.strictPeriods_Gamma0]
+  exact AddSubgroup.mem_zmultiples 1
+
+def 𝔞 : 𝒩 := ofMF ModularForm.E₄ one_mem_strictPeriods_SL
+
+def 𝔟 : 𝒩 := ofMF ModularForm.E₆ one_mem_strictPeriods_SL
+
+def 𝔡 : 𝒩 := ofMF CuspForm.discriminant one_mem_strictPeriods_SL
+
+theorem ψ𝔞 : ψ 𝔞 = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) := rfl
+theorem ψ𝔟 : ψ 𝔟 = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) := rfl
+theorem ψ𝔡 : ψ 𝔡 = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 ModularForm.discriminant) := rfl
+theorem toC𝔡_apply (τ : ℍ) : toC 𝔡 (τ : ℂ) = ModularForm.discriminant τ := by
+  change ModularForm.discriminant (ofComplex (τ : ℂ)) = _
+  rw [ofComplex_apply]
+
+theorem coeff_one_mul (φ χ : PowerSeries ℂ) :
+    PowerSeries.coeff 1 (φ * χ) = PowerSeries.coeff 0 φ * PowerSeries.coeff 1 χ +
+      PowerSeries.coeff 1 φ * PowerSeries.coeff 0 χ := by
+  rw [PowerSeries.coeff_mul, Finset.Nat.sum_antidiagonal_eq_sum_range_succ_mk]
+  simp [Finset.sum_range_succ]
+
+theorem coeff_zero_mul' (φ χ : PowerSeries ℂ) :
+    PowerSeries.coeff 0 (φ * χ) = PowerSeries.coeff 0 φ * PowerSeries.coeff 0 χ := by
+  rw [PowerSeries.coeff_zero_eq_constantCoeff_apply, PowerSeries.coeff_zero_eq_constantCoeff_apply,
+    PowerSeries.coeff_zero_eq_constantCoeff_apply, map_mul]
+
+theorem qA0 : PowerSeries.coeff 0 (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) = 1 :=
+  EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) ⟨2, rfl⟩
+theorem qB0 : PowerSeries.coeff 0 (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) = 1 :=
+  EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) ⟨3, rfl⟩
+theorem qA1 : PowerSeries.coeff 1 (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) = 240 := by
+  have h := ModularForm.levelOne_weight_four_qCoeff_one ModularForm.E₄
+  simp only [ModularFormClass.qCoeff] at h
+  rw [h, qA0, mul_one]
+theorem qB1 : PowerSeries.coeff 1 (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) = -504 := by
+  have h := ModularForm.levelOne_weight_six_qCoeff_one ModularForm.E₆
+  simp only [ModularFormClass.qCoeff] at h
+  rw [h, qB0, mul_one]
+theorem qD1 : PowerSeries.coeff 1 (qExpansion 1 ModularForm.discriminant) = 1 := by
+  rw [ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit, PowerSeries.coeff_map,
+    PowerSeries.coeff_succ_X_mul, PowerSeries.coeff_zero_eq_constantCoeff_apply,
+    ModularCurve.constantCoeff_dedekindEtaUnit, map_one]
+
+theorem A_cube_sub_B_sq : ψ 𝔞 ^ 3 - ψ 𝔟 ^ 2 = 1728 * ψ 𝔡 := by
+  let T : ModularForm 𝒮ℒ 12 := ModularForm.E₄.mul (ModularForm.E₄.mul ModularForm.E₄)
+  let U : ModularForm 𝒮ℒ 12 := ModularForm.E₆.mul ModularForm.E₆
+  let Z : ModularForm 𝒮ℒ 12 := T - U
+  have hZ : (Z : ℍ → ℂ) = ((𝔞 * (𝔞 * 𝔞) - 𝔟 * 𝔟 : 𝒩) : ℍ → ℂ) := by
+    funext z
+    change (T : ℍ → ℂ) z - (U : ℍ → ℂ) z = _
+    rfl
+  have hZq : qExpansion 1 (Z : ℍ → ℂ) =
+      qExpansion 1 ⇑ModularForm.E₄ * (qExpansion 1 ⇑ModularForm.E₄ * qExpansion 1 ⇑ModularForm.E₄) -
+        qExpansion 1 ⇑ModularForm.E₆ * qExpansion 1 ⇑ModularForm.E₆ := by
+    rw [hZ, ← qexpHom_apply, map_sub, map_mul, map_mul, map_mul]
+    rfl
+  have h0 : ModularFormClass.qCoeff (Z : ℍ → ℂ) 0 = 0 := by
+    simp only [ModularFormClass.qCoeff, hZq, map_sub, coeff_zero_mul', qA0, qB0]
+    norm_num
+  have h1 : ModularFormClass.qCoeff (Z : ℍ → ℂ) 1 = 1728 := by
+    simp only [ModularFormClass.qCoeff, hZq, map_sub, coeff_one_mul, coeff_zero_mul', qA0, qA1, qB0,
+      qB1]
+    norm_num
+  have hW := ModularForm.levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant Z h0
+  have hZΔ : qExpansion 1 (Z : ℍ → ℂ) = PowerSeries.C 1728 * qExpansion 1 ModularForm.discriminant
+    :=
+    by
+    ext n
+    rw [PowerSeries.coeff_C_mul]
+    have := hW n
+    have h1' := h1
+    simp only [ModularFormClass.qCoeff] at this h1'
+    rw [this, h1']
+  have hL : ψ (𝔞 * (𝔞 * 𝔞) - 𝔟 * 𝔟) = 1728 * ψ 𝔡 := by
+    rw [ψ_apply, ← hZ, hZΔ, map_mul, HahnSeries.ofPowerSeries_C, map_ofNat, ψ𝔡]
+  rw [map_sub, map_mul, map_mul, map_mul] at hL
+  rw [← hL]
+  ring
+
+theorem ψ𝔡_ne_zero : ψ 𝔡 ≠ 0 := by
+  intro h
+  have h0 : (𝔡 : 𝒩) = 0 := (ψ_eq_zero_iff _).mp h
+  have : ModularForm.discriminant UpperHalfPlane.I = 0 := by
+    have := congrArg (fun f : 𝒩 => (f : ℍ → ℂ) UpperHalfPlane.I) h0
+    simp only [ZeroMemClass.coe_zero, Pi.zero_apply] at this
+    exact this
+  exact ModularForm.discriminant_ne_zero _ this
+
+theorem coeffEmb_jq : coeffEmb ℂ jq = jqModC ℂ := by
+  change (jqModC ℚ).map (algebraMap ℚ ℂ) = jqModC ℂ
+  exact map_jqModC _
+
+theorem J_mul_D : coeffEmb ℂ jq * ψ 𝔡 = ψ 𝔞 ^ 3 := by
+  rw [coeffEmb_jq, ModularCurve.jqModC_eq_qExpansion_E4_cube_div_discriminant, ← ψ𝔞, ← ψ𝔡,
+    div_mul_cancel₀ _ ψ𝔡_ne_zero]
+
+theorem J_sub_mul_D : (coeffEmb ℂ jq - algebraMap ℂ (LaurentSeries ℂ) 1728) * ψ 𝔡 = ψ 𝔟 ^ 2 := by
+  rw [map_ofNat, sub_mul, J_mul_D]
+  have := A_cube_sub_B_sq
+  linear_combination this
+
+theorem le_analyticOrderAt_sum {ι : Type*} (s : Finset ι) (F : ι → ℂ → ℂ) (z : ℂ) (b : ℕ∞)
+    (h : ∀ i ∈ s, b ≤ analyticOrderAt (F i) z) : b ≤ analyticOrderAt (∑ i ∈ s, F i) z := by
+  classical
+  induction s using Finset.induction_on with
+  | empty =>
+    rw [Finset.sum_empty, analyticOrderAt_eq_top.mpr (by simp)]
+    exact le_top
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha]
+    refine le_trans ?_ le_analyticOrderAt_add
+    exact le_min (h a (Finset.mem_insert_self a s)) (ih fun i hi => h i (Finset.mem_insert_of_mem
+      hi))
+
+theorem order_le_of_identity {p q d : ℂ → ℂ} {n m : ℕ} {C : ℕ → ℂ → ℂ} {z : ℂ}
+    (hp : AnalyticAt ℂ p z) (hq : AnalyticAt ℂ q z) (hd : AnalyticAt ℂ d z)
+    (hC : ∀ i ∈ Finset.range n, AnalyticAt ℂ (C i) z) (hd0 : d z ≠ 0)
+    (hid : p ^ (6 * n) * d ^ m + ∑ i ∈ Finset.range n, C i * (p ^ (6 * i) * (q ^ 6 * d) ^ (n - i)) =
+      0) :
+    analyticOrderAt q z ≤ analyticOrderAt p z := by
+  by_contra hlt'
+  have hlt := not_le.mp hlt'
+  obtain ⟨k, hk⟩ : ∃ k : ℕ, (k : ℕ∞) = analyticOrderAt p z :=
+    ENat.ne_top_iff_exists.mp (ne_top_of_lt hlt)
+  have hd_ord : analyticOrderAt d z = 0 := hd.analyticOrderAt_eq_zero.mpr hd0
+  have hL : analyticOrderAt (p ^ (6 * n) * d ^ m) z = ((6 * n * k : ℕ) : ℕ∞) := by
+    rw [analyticOrderAt_mul (hp.pow _) (hd.pow _), analyticOrderAt_pow hp, analyticOrderAt_pow hd,
+      ← hk, hd_ord]
+    simp only [nsmul_eq_mul, smul_zero, add_zero]
+    push_cast
+    ring
+  have hq_ord : ((k + 1 : ℕ) : ℕ∞) ≤ analyticOrderAt q z := by
+    rw [← hk] at hlt
+    have := Order.add_one_le_of_lt hlt
+    exact_mod_cast this
+  have hR : ∀ i ∈ Finset.range n, ((6 * n * k + 6 : ℕ) : ℕ∞) ≤
+      analyticOrderAt (C i * (p ^ (6 * i) * (q ^ 6 * d) ^ (n - i))) z := by
+    intro i hi
+    have hin : i < n := Finset.mem_range.mp hi
+    have hqd : AnalyticAt ℂ (q ^ 6 * d) z := (hq.pow _).mul hd
+    rw [analyticOrderAt_mul (hC i hi) ((hp.pow _).mul (hqd.pow _)),
+      analyticOrderAt_mul (hp.pow _) (hqd.pow _), analyticOrderAt_pow hp, analyticOrderAt_pow hqd,
+      analyticOrderAt_mul (hq.pow _) hd, analyticOrderAt_pow hq, hd_ord, ← hk, add_zero]
+    have h1 : ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞) ≤ (n - i) • (6 • analyticOrderAt q z) := by
+      have : (n - i) • (6 • (((k + 1 : ℕ)) : ℕ∞)) ≤ (n - i) • (6 • analyticOrderAt q z) :=
+        nsmul_le_nsmul_right (nsmul_le_nsmul_right hq_ord 6) (n - i)
+      refine le_trans (le_of_eq ?_) this
+      simp only [nsmul_eq_mul]
+      push_cast
+      ring
+    have h2 : ((6 * n * k + 6 : ℕ) : ℕ∞) ≤ ((6 * i) • (k : ℕ∞)) + ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞)
+      :=
+      by
+      have e : ((6 * i) • (k : ℕ∞)) + ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞) =
+          ((6 * i * k + 6 * (n - i) * (k + 1) : ℕ) : ℕ∞) := by
+        simp only [nsmul_eq_mul]
+        push_cast
+        ring
+      rw [e]
+      exact_mod_cast (show 6 * n * k + 6 ≤ 6 * i * k + 6 * (n - i) * (k + 1) by
+        obtain ⟨j, rfl⟩ := Nat.exists_eq_add_of_lt hin
+        rw [show i + j + 1 - i = j + 1 by omega]
+        nlinarith)
+    calc ((6 * n * k + 6 : ℕ) : ℕ∞)
+        ≤ (6 * i) • (k : ℕ∞) + ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞) := h2
+      _ ≤ (6 * i) • (k : ℕ∞) + (n - i) • (6 • analyticOrderAt q z) := add_le_add le_rfl h1
+      _ ≤ analyticOrderAt (C i) z + ((6 * i) • (k : ℕ∞) + (n - i) • (6 • analyticOrderAt q z)) :=
+          self_le_add_left _ _
+  have hsum := le_analyticOrderAt_sum (Finset.range n) _ z _ hR
+  have heq : p ^ (6 * n) * d ^ m = -(∑ i ∈ Finset.range n, C i * (p ^ (6 * i) * (q ^ 6 * d) ^ (n -
+    i))) :=
+    eq_neg_of_add_eq_zero_left hid
+  have : ((6 * n * k + 6 : ℕ) : ℕ∞) ≤ ((6 * n * k : ℕ) : ℕ∞) := by
+    rw [← hL, heq, analyticOrderAt_neg]
+    exact hsum
+  have := ENat.natCast_le_natCast.mp this
+  omega
+
+end ANb
+
+namespace ANb
+
+local notation "𝒩" => niceSubalgebra
+local notation "𝐉" => ModularCurve.coeffEmb ℂ ModularCurve.jq
+
+
+theorem core (𝔤 𝔥 : 𝒩) (X : LaurentSeries ℂ) (hX : X * ψ 𝔥 = ψ 𝔤)
+    (h₁ : IsIntegral (Algebra.adjoin ℂ ({𝐉} : Set (LaurentSeries ℂ)))
+      (X ^ 6 * 𝐉 ^ 4 * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ 3))
+    (τ : ℍ) :
+    analyticOrderAt (toC (𝔥 * 𝔡)) (τ : ℂ) ≤ analyticOrderAt (toC (𝔤 * 𝔞 ^ 2 * 𝔟)) (τ : ℂ) := by
+  classical
+  have key1 : (X ^ 6 * 𝐉 ^ 4 * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ 3) *
+      ((ψ 𝔥 * ψ 𝔡) ^ 6 * ψ 𝔡) = (ψ 𝔤 * ψ 𝔞 ^ 2 * ψ 𝔟) ^ 6 := by
+    calc (X ^ 6 * 𝐉 ^ 4 * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ 3) * ((ψ 𝔥 * ψ 𝔡) ^ 6 * ψ 𝔡)
+        = (X * ψ 𝔥) ^ 6 * (𝐉 * ψ 𝔡) ^ 4 * ((𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) * ψ 𝔡) ^ 3
+          := by
+          ring
+      _ = (ψ 𝔤) ^ 6 * (ψ 𝔞 ^ 3) ^ 4 * (ψ 𝔟 ^ 2) ^ 3 := by rw [hX, J_mul_D, J_sub_mul_D]
+      _ = (ψ 𝔤 * ψ 𝔞 ^ 2 * ψ 𝔟) ^ 6 := by ring
+  obtain ⟨p, hpm, hpev⟩ := h₁
+  rw [hpm.as_sum] at hpev
+  simp only [Polynomial.eval₂_add, Polynomial.eval₂_pow, Polynomial.eval₂_X,
+    Polynomial.eval₂_finsetSum,
+    Polynomial.eval₂_mul, Polynomial.eval₂_C] at hpev
+  set R := Algebra.adjoin ℂ ({𝐉} : Set (LaurentSeries ℂ)) with hR
+  set Y := X ^ 6 * 𝐉 ^ 4 * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ 3 with hY
+  set n := p.natDegree with hn
+  clear_value Y
+  have hmem : ∀ i, ∃ c : Polynomial ℂ,
+      Polynomial.aeval (𝐉) c = algebraMap R (LaurentSeries ℂ) (p.coeff i) := by
+    intro i
+    have hi' : algebraMap R (LaurentSeries ℂ) (p.coeff i) ∈ (Polynomial.aeval (R := ℂ) (𝐉)).range :=
+      by
+      rw [← Algebra.adjoin_singleton_eq_range_aeval]
+      exact (p.coeff i).2
+    exact hi'
+  choose c hc using hmem
+  set m := ∑ i ∈ Finset.range n, (c i).natDegree with hm
+  have hdeg : ∀ i ∈ Finset.range n, (c i).natDegree ≤ m := fun i hi =>
+    Finset.single_le_sum (f := fun j => (c j).natDegree) (fun j _ => Nat.zero_le _) hi
+  let Cn : ℕ → 𝒩 := fun i =>
+    ∑ l ∈ Finset.range ((c i).natDegree + 1), algebraMap ℂ 𝒩 ((c i).coeff l) * (𝔡 ^ (m - l) * 𝔞 ^ (3
+      * l))
+  have key3 : ∀ i ∈ Finset.range n, ψ 𝔡 ^ m * algebraMap R (LaurentSeries ℂ) (p.coeff i) = ψ (Cn i)
+    :=
+    by
+    intro i hi
+    simp only [Cn, map_sum, map_mul, map_pow, AlgHom.commutes]
+    rw [← hc i, Polynomial.aeval_eq_sum_range, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun l hl => ?_
+    have hlm : l ≤ m := (Nat.lt_succ_iff.mp (Finset.mem_range.mp hl)).trans (hdeg i hi)
+    rw [Algebra.smul_def, mul_left_comm]
+    congr 1
+    calc ψ 𝔡 ^ m * 𝐉 ^ l = ψ 𝔡 ^ (m - l) * ψ 𝔡 ^ l * 𝐉 ^ l := by
+          rw [← pow_add, Nat.sub_add_cancel hlm]
+      _ = ψ 𝔡 ^ (m - l) * (𝐉 * ψ 𝔡) ^ l := by rw [mul_pow]; ring
+      _ = ψ 𝔡 ^ (m - l) * ψ 𝔞 ^ (3 * l) := by rw [J_mul_D, ← pow_mul]
+  let P : 𝒩 := 𝔤 * 𝔞 ^ 2 * 𝔟
+  let Q : 𝒩 := 𝔥 * 𝔡
+  have k1 : Y * (ψ Q ^ 6 * ψ 𝔡) = ψ P ^ 6 := by
+    simp only [P, Q, map_mul, map_pow]
+    exact key1
+  have key2 : ∀ i ≤ n, (ψ Q ^ 6 * ψ 𝔡) ^ n * Y ^ i = ψ P ^ (6 * i) * (ψ Q ^ 6 * ψ 𝔡) ^ (n - i) := by
+    intro i hi
+    have e : (ψ Q ^ 6 * ψ 𝔡) ^ n = (ψ Q ^ 6 * ψ 𝔡) ^ i * (ψ Q ^ 6 * ψ 𝔡) ^ (n - i) := by
+      rw [← pow_add, Nat.add_sub_cancel' hi]
+    calc (ψ Q ^ 6 * ψ 𝔡) ^ n * Y ^ i = (Y * (ψ Q ^ 6 * ψ 𝔡)) ^ i * (ψ Q ^ 6 * ψ 𝔡) ^ (n - i) := by
+          rw [e, mul_pow Y (ψ Q ^ 6 * ψ 𝔡) i]; ring
+      _ = ψ P ^ (6 * i) * (ψ Q ^ 6 * ψ 𝔡) ^ (n - i) := by rw [k1, ← pow_mul]
+  let E : 𝒩 :=
+    P ^ (6 * n) * 𝔡 ^ m + ∑ i ∈ Finset.range n, Cn i * (P ^ (6 * i) * (Q ^ 6 * 𝔡) ^ (n - i))
+  have hE : ψ E = (ψ Q ^ 6 * ψ 𝔡) ^ n * ψ 𝔡 ^ m *
+      (Y ^ n + ∑ i ∈ Finset.range n, algebraMap R (LaurentSeries ℂ) (p.coeff i) * Y ^ i) := by
+    rw [mul_add, Finset.mul_sum]
+    simp only [E, map_add, map_sum, map_mul, map_pow]
+    congr 1
+    · have h2 := key2 n le_rfl
+      rw [Nat.sub_self, pow_zero, mul_one] at h2
+      rw [mul_right_comm, h2]
+    · refine Finset.sum_congr rfl fun i hi => ?_
+      have hin : i ≤ n := (Finset.mem_range.mp hi).le
+      rw [← key3 i hi, ← key2 i hin]
+      ring
+  have hE0 : E = 0 := by
+    apply ψ_injective
+    rw [hE, hpev, mul_zero, map_zero]
+  have hC := congrArg toC hE0
+  simp only [E, map_add, map_sum, map_mul, map_pow, map_zero] at hC
+  exact order_le_of_identity (analyticAt_toC P τ) (analyticAt_toC Q τ) (analyticAt_toC 𝔡 τ)
+    (fun i _ => analyticAt_toC (Cn i) τ)
+    (by rw [toC𝔡_apply]; exact ModularForm.discriminant_ne_zero τ) hC
+
+end ANb
+
+theorem solution (N : ℕ) {k : ℤ}
+    (g h : ModularForm (CongruenceSubgroup.Gamma0 N) k) (X : LaurentSeries ℂ)
+    (hX : X * ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) = ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ))
+    (h₁ : IsIntegral (Algebra.adjoin ℂ ({ModularCurve.coeffEmb ℂ ModularCurve.jq} : Set
+      (LaurentSeries ℂ)))
+      (X ^ 6 * ModularCurve.coeffEmb ℂ ModularCurve.jq ^ 4 * (ModularCurve.coeffEmb ℂ
+        ModularCurve.jq - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ 3))
+    (τ : UpperHalfPlane) :
+    analyticOrderAt ((fun z : UpperHalfPlane => h z * ModularForm.discriminant z) ∘
+      UpperHalfPlane.ofComplex) (τ : ℂ) ≤
+      analyticOrderAt ((fun z : UpperHalfPlane => g z * ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) ∘
+        UpperHalfPlane.ofComplex) (τ : ℂ) :=
+  ANb.core (ANb.ofMF g (ANb.one_mem_strictPeriods_gamma0 N)) (ANb.ofMF h
+    (ANb.one_mem_strictPeriods_gamma0 N))
+    X hX h₁ τ
+
+end
+end S_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq
+end P2MW
+export P2MW.S_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq (N : ℕ) {k : ℤ}
+    (g h : ModularForm (CongruenceSubgroup.Gamma0 N) k) (X : LaurentSeries ℂ)
+    (hX : X * ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) = ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ))
+    (h₁ : IsIntegral (Algebra.adjoin ℂ ({ModularCurve.coeffEmb ℂ ModularCurve.jq} : Set
+      (LaurentSeries ℂ)))
+      (X ^ 6 * ModularCurve.coeffEmb ℂ ModularCurve.jq ^ 4 * (ModularCurve.coeffEmb ℂ
+        ModularCurve.jq - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ 3))
+    (τ : UpperHalfPlane) :
+    analyticOrderAt ((fun z : UpperHalfPlane => h z * ModularForm.discriminant z) ∘
+      UpperHalfPlane.ofComplex) (τ : ℂ) ≤
+      analyticOrderAt ((fun z : UpperHalfPlane => g z * ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) ∘
+        UpperHalfPlane.ofComplex) (τ : ℂ) :=
+  solution N g h X hX h₁ τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq_pow.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq_pow.lean
new file mode 100644
index 0000000000..27b7a0ffb1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq_pow.lean
@@ -0,0 +1,506 @@
+/-
+Based on Prove2Me node ModularCurve.analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq_pow
+(23eee95d-3cbf-5f99-854c-52b9e5f2e643) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2c4b33f8-b4e6-53d9-9be7-fcdfaa6e4248
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import Mathlib.Data.Int.Star
+import Mathlib.Order.CompletePartialOrder
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_four_qCoeff_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_six_qCoeff_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Interior order comparison from integrality of X⁶ j^{4m}(j-1728)^{3m}
+
+Theorem statement: `ModularCurve.analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq_pow`
+(`23eee95d-3cbf-5f99-854c-52b9e5f2e643`), by Claude, 2026-09-05.
+
+Proof: submission `2c4b33f8-b4e6-53d9-9be7-fcdfaa6e4248`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a level $N$, a weight $k \in \mathbb{Z}$ and an integer $m \ge 1$, let $g$ and $h$ be modular
+forms of weight $k$ for $\Gamma_0(N)$, and let $X$ be a Laurent series over $\mathbb{C}$. Assume
+first that $X$ times the $q$-expansion of $h$ of width $1$, viewed as a Laurent series, equals the
+corresponding $q$-expansion of $g$. Write $J =$ `coeffEmb ℂ jq` for the image in `LaurentSeries ℂ`
+of the rational Laurent series `jq` $=$ `single (-1) 1` $\cdot$ `ofPowerSeries jNumQ` (that is,
+$q^{-1}$ times the rational power series obtained from the integral series `jNum` by base change)
+under the coefficientwise ring homomorphism induced by $\mathbb{Q} \to \mathbb{C}$. Assume second
+that $X^6 \, J^{4m} \, (J - 1728)^{3m}$ is integral over the $\mathbb{C}$-subalgebra of
+`LaurentSeries ℂ` generated by $J$. Then for every $\tau$ in the upper half-plane, the analytic
+order at the point $\tau \in \mathbb{C}$ of the function $z \mapsto h(z)\,\Delta(z)^m$, precomposed
+with `UpperHalfPlane.ofComplex`, is at most the analytic order at $\tau$ of $z \mapsto
+g(z)\,(E_4(z)^2 E_6(z))^m$, precomposed with `UpperHalfPlane.ofComplex`.
+
+This is the weight-$2m$ form of the interior (non-cuspidal) half of the analytic criterion comparing
+the vanishing orders of $h\Delta^m$ and $g(E_4^2E_6)^m$ on $\mathfrak{H}$, the input being
+integrality over $\mathbb{C}[j]$ of the Laurent series $X^6 j^{4m}(j-1728)^{3m}$ attached to the
+ratio $X = \tilde g/\tilde h$. It feeds the existence statements
+[`ModularCurve.exists_cuspForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral`]
+(thm.html#ModularCurve.exists_cuspForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral)
+and
+[`ModularCurve.exists_modularForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral`]
+(thm.html#ModularCurve.exists_modularForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral),
+where a $q$-expansion satisfying such an integrality condition is realised by an actual (cusp) form.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq_pow.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 1600000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq_pow
+
+p2m_open "UpperHalfPlane ModularCurve~coeffEmb_jq"
+open scoped MatrixGroups ModularForm Manifold
+
+noncomputable section
+
+namespace ANb
+
+def Nice (f : ℍ → ℂ) : Prop :=
+  Function.Periodic (f ∘ ofComplex) 1 ∧ MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f ∧ IsBoundedAtImInfty f
+
+theorem Nice.mul {f g : ℍ → ℂ} (hf : Nice f) (hg : Nice g) : Nice (f * g) :=
+  ⟨by simpa [Function.comp_def] using hf.1.mul hg.1, hf.2.1.mul hg.2.1, hf.2.2.mul hg.2.2⟩
+
+theorem Nice.add {f g : ℍ → ℂ} (hf : Nice f) (hg : Nice g) : Nice (f + g) :=
+  ⟨by simpa [Function.comp_def] using hf.1.add hg.1, hf.2.1.add hg.2.1, hf.2.2.add hg.2.2⟩
+
+theorem Nice.const (c : ℂ) : Nice (fun _ => c) :=
+  ⟨fun _ => rfl, mdifferentiable_const, Filter.const_boundedAtFilter _ _⟩
+
+def niceSubalgebra : Subalgebra ℂ (ℍ → ℂ) where
+  carrier := {f | Nice f}
+  mul_mem' hf hg := hf.mul hg
+  add_mem' hf hg := hf.add hg
+  algebraMap_mem' c := Nice.const c
+
+local notation "𝒩" => niceSubalgebra
+
+theorem an (f : 𝒩) : AnalyticAt ℂ (cuspFunction 1 (f : ℍ → ℂ)) 0 :=
+  UpperHalfPlane.analyticAt_cuspFunction_zero one_pos f.2.1 f.2.2.1 f.2.2.2
+
+def qexpHom : 𝒩 →ₐ[ℂ] PowerSeries ℂ where
+  toFun f := qExpansion 1 (f : ℍ → ℂ)
+  map_one' := UpperHalfPlane.qExpansion_one 1
+  map_mul' f g := UpperHalfPlane.qExpansion_mul (an f) (an g)
+  map_zero' := UpperHalfPlane.qExpansion_zero 1
+  map_add' f g := UpperHalfPlane.qExpansion_add (an f) (an g)
+  commutes' c := by
+    have h1 : ((algebraMap ℂ (ℍ → ℂ) c : ℍ → ℂ)) = c • (1 : ℍ → ℂ) := by
+      funext z; simp
+    have a1 : AnalyticAt ℂ (cuspFunction 1 (1 : ℍ → ℂ)) 0 := an (1 : 𝒩)
+    change qExpansion 1 (algebraMap ℂ (ℍ → ℂ) c) = _
+    rw [h1, UpperHalfPlane.qExpansion_smul a1 c, UpperHalfPlane.qExpansion_one,
+      Algebra.algebraMap_eq_smul_one]
+
+theorem qexpHom_apply (f : 𝒩) : qexpHom f = qExpansion 1 (f : ℍ → ℂ) := rfl
+
+def ψ : 𝒩 →ₐ[ℂ] LaurentSeries ℂ :=
+  { (HahnSeries.ofPowerSeries ℤ ℂ).comp qexpHom.toRingHom with
+    commutes' := fun c => by
+      change HahnSeries.ofPowerSeries ℤ ℂ (qexpHom (algebraMap ℂ 𝒩 c)) = _
+      rw [qexpHom.commutes, HahnSeries.algebraMap_apply'] }
+
+theorem ψ_apply (f : 𝒩) : ψ f = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (f : ℍ → ℂ)) := rfl
+
+theorem ψ_injective : Function.Injective ψ := by
+  intro f g hfg
+  rw [ψ_apply, ψ_apply] at hfg
+  have h := HahnSeries.ofPowerSeries_injective hfg
+  have h' : qExpansion 1 ((f : ℍ → ℂ) - (g : ℍ → ℂ)) = 0 := by
+    rw [UpperHalfPlane.qExpansion_sub (an f) (an g), h, sub_self]
+  have hn : Nice ((f : ℍ → ℂ) - (g : ℍ → ℂ)) := (f - g).2
+  have h0 := (UpperHalfPlane.qExpansion_eq_zero_iff one_pos hn.1 hn.2.1 hn.2.2).mp h'
+  exact Subtype.ext (sub_eq_zero.mp h0)
+
+theorem ψ_eq_zero_iff (f : 𝒩) : ψ f = 0 ↔ f = 0 :=
+  ⟨fun h => ψ_injective (by rw [h, map_zero]), fun h => by rw [h, map_zero]⟩
+
+def toC : 𝒩 →ₐ[ℂ] (ℂ → ℂ) where
+  toFun f := (f : ℍ → ℂ) ∘ ofComplex
+  map_one' := rfl
+  map_mul' _ _ := rfl
+  map_zero' := rfl
+  map_add' _ _ := rfl
+  commutes' _ := rfl
+
+theorem toC_apply (f : 𝒩) : toC f = (f : ℍ → ℂ) ∘ ofComplex := rfl
+
+theorem analyticAt_toC (f : 𝒩) (τ : ℍ) : AnalyticAt ℂ (toC f) (τ : ℂ) := by
+  have hd : DifferentiableOn ℂ ((f : ℍ → ℂ) ∘ ofComplex) {z : ℂ | 0 < z.im} :=
+    UpperHalfPlane.mdifferentiable_iff.mp f.2.2.1
+  exact hd.analyticAt ((isOpen_lt continuous_const Complex.continuous_im).mem_nhds τ.im_pos)
+
+theorem nice_of_modularForm {F : Type*} {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (h1 : (1 : ℝ) ∈ Γ.strictPeriods) : Nice (f : ℍ → ℂ) := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Subgroup.isCusp_of_mem_strictPeriods one_pos h1⟩
+  refine ⟨?_, ModularFormClass.holo f, ModularFormClass.bdd_at_infty f⟩
+  simpa using SlashInvariantFormClass.periodic_comp_ofComplex (h := 1) f h1
+
+def ofMF {F : Type*} {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (h1 : (1 : ℝ) ∈ Γ.strictPeriods) : 𝒩 :=
+  ⟨f, nice_of_modularForm f h1⟩
+
+@[scoped simp] theorem coe_ofMF {F : Type*} {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (h1 : (1 : ℝ) ∈ Γ.strictPeriods) :
+    ((ofMF f h1 : 𝒩) : ℍ → ℂ) = f := rfl
+
+theorem one_mem_strictPeriods_gamma0 (N : ℕ) :
+    (1 : ℝ) ∈ (Subgroup.map (Matrix.SpecialLinearGroup.mapGL ℝ) (CongruenceSubgroup.Gamma0
+      N)).strictPeriods := by
+  rw [CongruenceSubgroup.strictPeriods_Gamma0]
+  exact AddSubgroup.mem_zmultiples 1
+
+def 𝔞 : 𝒩 := ofMF ModularForm.E₄ one_mem_strictPeriods_SL
+
+def 𝔟 : 𝒩 := ofMF ModularForm.E₆ one_mem_strictPeriods_SL
+
+def 𝔡 : 𝒩 := ofMF CuspForm.discriminant one_mem_strictPeriods_SL
+
+theorem ψ𝔞 : ψ 𝔞 = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) := rfl
+theorem ψ𝔟 : ψ 𝔟 = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) := rfl
+theorem ψ𝔡 : ψ 𝔡 = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 ModularForm.discriminant) := rfl
+theorem toC𝔡_apply (τ : ℍ) : toC 𝔡 (τ : ℂ) = ModularForm.discriminant τ := by
+  change ModularForm.discriminant (ofComplex (τ : ℂ)) = _
+  rw [ofComplex_apply]
+
+theorem coeff_one_mul (φ χ : PowerSeries ℂ) :
+    PowerSeries.coeff 1 (φ * χ) = PowerSeries.coeff 0 φ * PowerSeries.coeff 1 χ +
+      PowerSeries.coeff 1 φ * PowerSeries.coeff 0 χ := by
+  rw [PowerSeries.coeff_mul, Finset.Nat.sum_antidiagonal_eq_sum_range_succ_mk]
+  simp [Finset.sum_range_succ]
+
+theorem coeff_zero_mul' (φ χ : PowerSeries ℂ) :
+    PowerSeries.coeff 0 (φ * χ) = PowerSeries.coeff 0 φ * PowerSeries.coeff 0 χ := by
+  rw [PowerSeries.coeff_zero_eq_constantCoeff_apply, PowerSeries.coeff_zero_eq_constantCoeff_apply,
+    PowerSeries.coeff_zero_eq_constantCoeff_apply, map_mul]
+
+theorem qA0 : PowerSeries.coeff 0 (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) = 1 :=
+  EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) ⟨2, rfl⟩
+theorem qB0 : PowerSeries.coeff 0 (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) = 1 :=
+  EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) ⟨3, rfl⟩
+theorem qA1 : PowerSeries.coeff 1 (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) = 240 := by
+  have h := ModularForm.levelOne_weight_four_qCoeff_one ModularForm.E₄
+  simp only [ModularFormClass.qCoeff] at h
+  rw [h, qA0, mul_one]
+theorem qB1 : PowerSeries.coeff 1 (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) = -504 := by
+  have h := ModularForm.levelOne_weight_six_qCoeff_one ModularForm.E₆
+  simp only [ModularFormClass.qCoeff] at h
+  rw [h, qB0, mul_one]
+theorem qD1 : PowerSeries.coeff 1 (qExpansion 1 ModularForm.discriminant) = 1 := by
+  rw [ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit, PowerSeries.coeff_map,
+    PowerSeries.coeff_succ_X_mul, PowerSeries.coeff_zero_eq_constantCoeff_apply,
+    ModularCurve.constantCoeff_dedekindEtaUnit, map_one]
+
+theorem A_cube_sub_B_sq : ψ 𝔞 ^ 3 - ψ 𝔟 ^ 2 = 1728 * ψ 𝔡 := by
+  let T : ModularForm 𝒮ℒ 12 := ModularForm.E₄.mul (ModularForm.E₄.mul ModularForm.E₄)
+  let U : ModularForm 𝒮ℒ 12 := ModularForm.E₆.mul ModularForm.E₆
+  let Z : ModularForm 𝒮ℒ 12 := T - U
+  have hZ : (Z : ℍ → ℂ) = ((𝔞 * (𝔞 * 𝔞) - 𝔟 * 𝔟 : 𝒩) : ℍ → ℂ) := by
+    funext z
+    change (T : ℍ → ℂ) z - (U : ℍ → ℂ) z = _
+    rfl
+  have hZq : qExpansion 1 (Z : ℍ → ℂ) =
+      qExpansion 1 ⇑ModularForm.E₄ * (qExpansion 1 ⇑ModularForm.E₄ * qExpansion 1 ⇑ModularForm.E₄) -
+        qExpansion 1 ⇑ModularForm.E₆ * qExpansion 1 ⇑ModularForm.E₆ := by
+    rw [hZ, ← qexpHom_apply, map_sub, map_mul, map_mul, map_mul]
+    rfl
+  have h0 : ModularFormClass.qCoeff (Z : ℍ → ℂ) 0 = 0 := by
+    simp only [ModularFormClass.qCoeff, hZq, map_sub, coeff_zero_mul', qA0, qB0]
+    norm_num
+  have h1 : ModularFormClass.qCoeff (Z : ℍ → ℂ) 1 = 1728 := by
+    simp only [ModularFormClass.qCoeff, hZq, map_sub, coeff_one_mul, coeff_zero_mul', qA0, qA1, qB0,
+      qB1]
+    norm_num
+  have hW := ModularForm.levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant Z h0
+  have hZΔ : qExpansion 1 (Z : ℍ → ℂ) = PowerSeries.C 1728 * qExpansion 1 ModularForm.discriminant
+    :=
+    by
+    ext n
+    rw [PowerSeries.coeff_C_mul]
+    have := hW n
+    have h1' := h1
+    simp only [ModularFormClass.qCoeff] at this h1'
+    rw [this, h1']
+  have hL : ψ (𝔞 * (𝔞 * 𝔞) - 𝔟 * 𝔟) = 1728 * ψ 𝔡 := by
+    rw [ψ_apply, ← hZ, hZΔ, map_mul, HahnSeries.ofPowerSeries_C, map_ofNat, ψ𝔡]
+  rw [map_sub, map_mul, map_mul, map_mul] at hL
+  rw [← hL]
+  ring
+
+theorem ψ𝔡_ne_zero : ψ 𝔡 ≠ 0 := by
+  intro h
+  have h0 : (𝔡 : 𝒩) = 0 := (ψ_eq_zero_iff _).mp h
+  have : ModularForm.discriminant UpperHalfPlane.I = 0 := by
+    have := congrArg (fun f : 𝒩 => (f : ℍ → ℂ) UpperHalfPlane.I) h0
+    simp only [ZeroMemClass.coe_zero, Pi.zero_apply] at this
+    exact this
+  exact ModularForm.discriminant_ne_zero _ this
+
+theorem coeffEmb_jq : coeffEmb ℂ jq = jqModC ℂ := by
+  change (jqModC ℚ).map (algebraMap ℚ ℂ) = jqModC ℂ
+  exact map_jqModC _
+
+theorem J_mul_D : coeffEmb ℂ jq * ψ 𝔡 = ψ 𝔞 ^ 3 := by
+  rw [coeffEmb_jq, ModularCurve.jqModC_eq_qExpansion_E4_cube_div_discriminant, ← ψ𝔞, ← ψ𝔡,
+    div_mul_cancel₀ _ ψ𝔡_ne_zero]
+
+theorem J_sub_mul_D : (coeffEmb ℂ jq - algebraMap ℂ (LaurentSeries ℂ) 1728) * ψ 𝔡 = ψ 𝔟 ^ 2 := by
+  rw [map_ofNat, sub_mul, J_mul_D]
+  have := A_cube_sub_B_sq
+  linear_combination this
+
+theorem le_analyticOrderAt_sum {ι : Type*} (s : Finset ι) (F : ι → ℂ → ℂ) (z : ℂ) (b : ℕ∞)
+    (h : ∀ i ∈ s, b ≤ analyticOrderAt (F i) z) : b ≤ analyticOrderAt (∑ i ∈ s, F i) z := by
+  classical
+  induction s using Finset.induction_on with
+  | empty =>
+    rw [Finset.sum_empty, analyticOrderAt_eq_top.mpr (by simp)]
+    exact le_top
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha]
+    refine le_trans ?_ le_analyticOrderAt_add
+    exact le_min (h a (Finset.mem_insert_self a s)) (ih fun i hi => h i (Finset.mem_insert_of_mem
+      hi))
+
+theorem order_le_of_identity {p q d₁ d : ℂ → ℂ} {n : ℕ} {C : ℕ → ℂ → ℂ} {z : ℂ}
+    (hp : AnalyticAt ℂ p z) (hq : AnalyticAt ℂ q z) (hd₁ : AnalyticAt ℂ d₁ z)
+    (hd : AnalyticAt ℂ d z)
+    (hC : ∀ i ∈ Finset.range n, AnalyticAt ℂ (C i) z) (hd₁0 : d₁ z ≠ 0) (hd0 : d z ≠ 0)
+    (hid : p ^ (6 * n) * d₁ + ∑ i ∈ Finset.range n, C i * (p ^ (6 * i) * (q ^ 6 * d) ^ (n - i)) =
+      0) :
+    analyticOrderAt q z ≤ analyticOrderAt p z := by
+  by_contra hlt'
+  have hlt := not_le.mp hlt'
+  obtain ⟨k, hk⟩ : ∃ k : ℕ, (k : ℕ∞) = analyticOrderAt p z :=
+    ENat.ne_top_iff_exists.mp (ne_top_of_lt hlt)
+  have hd_ord : analyticOrderAt d z = 0 := hd.analyticOrderAt_eq_zero.mpr hd0
+  have hd₁_ord : analyticOrderAt d₁ z = 0 := hd₁.analyticOrderAt_eq_zero.mpr hd₁0
+  have hL : analyticOrderAt (p ^ (6 * n) * d₁) z = ((6 * n * k : ℕ) : ℕ∞) := by
+    rw [analyticOrderAt_mul (hp.pow _) hd₁, analyticOrderAt_pow hp, ← hk, hd₁_ord]
+    simp only [nsmul_eq_mul, add_zero]
+    push_cast
+    ring
+  have hq_ord : ((k + 1 : ℕ) : ℕ∞) ≤ analyticOrderAt q z := by
+    rw [← hk] at hlt
+    have := Order.add_one_le_of_lt hlt
+    exact_mod_cast this
+  have hR : ∀ i ∈ Finset.range n, ((6 * n * k + 6 : ℕ) : ℕ∞) ≤
+      analyticOrderAt (C i * (p ^ (6 * i) * (q ^ 6 * d) ^ (n - i))) z := by
+    intro i hi
+    have hin : i < n := Finset.mem_range.mp hi
+    have hqd : AnalyticAt ℂ (q ^ 6 * d) z := (hq.pow _).mul hd
+    rw [analyticOrderAt_mul (hC i hi) ((hp.pow _).mul (hqd.pow _)),
+      analyticOrderAt_mul (hp.pow _) (hqd.pow _), analyticOrderAt_pow hp, analyticOrderAt_pow hqd,
+      analyticOrderAt_mul (hq.pow _) hd, analyticOrderAt_pow hq, hd_ord, ← hk, add_zero]
+    have h1 : ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞) ≤ (n - i) • (6 • analyticOrderAt q z) := by
+      have : (n - i) • (6 • (((k + 1 : ℕ)) : ℕ∞)) ≤ (n - i) • (6 • analyticOrderAt q z) :=
+        nsmul_le_nsmul_right (nsmul_le_nsmul_right hq_ord 6) (n - i)
+      refine le_trans (le_of_eq ?_) this
+      simp only [nsmul_eq_mul]
+      push_cast
+      ring
+    have h2 : ((6 * n * k + 6 : ℕ) : ℕ∞) ≤ ((6 * i) • (k : ℕ∞)) + ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞)
+      :=
+      by
+      have e : ((6 * i) • (k : ℕ∞)) + ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞) =
+          ((6 * i * k + 6 * (n - i) * (k + 1) : ℕ) : ℕ∞) := by
+        simp only [nsmul_eq_mul]
+        push_cast
+        ring
+      rw [e]
+      exact_mod_cast (show 6 * n * k + 6 ≤ 6 * i * k + 6 * (n - i) * (k + 1) by
+        obtain ⟨j, rfl⟩ := Nat.exists_eq_add_of_lt hin
+        rw [show i + j + 1 - i = j + 1 by omega]
+        nlinarith)
+    calc ((6 * n * k + 6 : ℕ) : ℕ∞)
+        ≤ (6 * i) • (k : ℕ∞) + ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞) := h2
+      _ ≤ (6 * i) • (k : ℕ∞) + (n - i) • (6 • analyticOrderAt q z) := add_le_add le_rfl h1
+      _ ≤ analyticOrderAt (C i) z + ((6 * i) • (k : ℕ∞) + (n - i) • (6 • analyticOrderAt q z)) :=
+          self_le_add_left _ _
+  have hsum := le_analyticOrderAt_sum (Finset.range n) _ z _ hR
+  have heq : p ^ (6 * n) * d₁ = -(∑ i ∈ Finset.range n, C i * (p ^ (6 * i) * (q ^ 6 * d) ^ (n - i)))
+    :=
+    eq_neg_of_add_eq_zero_left hid
+  have : ((6 * n * k + 6 : ℕ) : ℕ∞) ≤ ((6 * n * k : ℕ) : ℕ∞) := by
+    rw [← hL, heq, analyticOrderAt_neg]
+    exact hsum
+  have := ENat.natCast_le_natCast.mp this
+  omega
+
+end ANb
+
+namespace ANb
+
+local notation "𝒩" => niceSubalgebra
+local notation "𝐉" => ModularCurve.coeffEmb ℂ ModularCurve.jq
+
+
+theorem core (w : ℕ) (𝔤 𝔥 : 𝒩) (X : LaurentSeries ℂ) (hX : X * ψ 𝔥 = ψ 𝔤)
+    (h₁ : IsIntegral (Algebra.adjoin ℂ ({𝐉} : Set (LaurentSeries ℂ)))
+      (X ^ 6 * 𝐉 ^ (4 * w) * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (3 * w)))
+    (τ : ℍ) :
+    analyticOrderAt (toC (𝔥 * 𝔡 ^ w)) (τ : ℂ) ≤ analyticOrderAt (toC (𝔤 * (𝔞 ^ 2 * 𝔟) ^ w)) (τ : ℂ)
+      := by
+  classical
+  have e1 : ∀ (Xx Jj T H D : LaurentSeries ℂ),
+      (Xx ^ 6 * Jj ^ (4 * w) * T ^ (3 * w)) * ((H * D ^ w) ^ 6 * D ^ w)
+        = (Xx * H) ^ 6 * ((Jj * D) ^ 4 * (T * D) ^ 3) ^ w := by
+    intro Xx Jj T H D
+    ring
+  have e2 : ∀ (G A B : LaurentSeries ℂ),
+      G ^ 6 * ((A ^ 3) ^ 4 * (B ^ 2) ^ 3) ^ w = (G * (A ^ 2 * B) ^ w) ^ 6 := by
+    intro G A B
+    ring
+  have key1 : (X ^ 6 * 𝐉 ^ (4 * w) * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (3 * w)) *
+      ((ψ 𝔥 * ψ 𝔡 ^ w) ^ 6 * ψ 𝔡 ^ w) = (ψ 𝔤 * (ψ 𝔞 ^ 2 * ψ 𝔟) ^ w) ^ 6 := by
+    rw [e1, hX, J_mul_D, J_sub_mul_D, e2]
+  obtain ⟨p, hpm, hpev⟩ := h₁
+  rw [hpm.as_sum] at hpev
+  simp only [Polynomial.eval₂_add, Polynomial.eval₂_pow, Polynomial.eval₂_X,
+    Polynomial.eval₂_finsetSum,
+    Polynomial.eval₂_mul, Polynomial.eval₂_C] at hpev
+  set R := Algebra.adjoin ℂ ({𝐉} : Set (LaurentSeries ℂ)) with hR
+  set Y := X ^ 6 * 𝐉 ^ (4 * w) * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (3 * w) with hY
+  set n := p.natDegree with hn
+  clear_value Y
+  have hmem : ∀ i, ∃ c : Polynomial ℂ,
+      Polynomial.aeval (𝐉) c = algebraMap R (LaurentSeries ℂ) (p.coeff i) := by
+    intro i
+    have hi' : algebraMap R (LaurentSeries ℂ) (p.coeff i) ∈ (Polynomial.aeval (R := ℂ) (𝐉)).range :=
+      by
+      rw [← Algebra.adjoin_singleton_eq_range_aeval]
+      exact (p.coeff i).2
+    exact hi'
+  choose c hc using hmem
+  set m := ∑ i ∈ Finset.range n, (c i).natDegree with hm
+  have hdeg : ∀ i ∈ Finset.range n, (c i).natDegree ≤ m := fun i hi =>
+    Finset.single_le_sum (f := fun j => (c j).natDegree) (fun j _ => Nat.zero_le _) hi
+  let Cn : ℕ → 𝒩 := fun i =>
+    ∑ l ∈ Finset.range ((c i).natDegree + 1), algebraMap ℂ 𝒩 ((c i).coeff l) * (𝔡 ^ (m - l) * 𝔞 ^ (3
+      * l))
+  have key3 : ∀ i ∈ Finset.range n, ψ 𝔡 ^ m * algebraMap R (LaurentSeries ℂ) (p.coeff i) = ψ (Cn i)
+    :=
+    by
+    intro i hi
+    simp only [Cn, map_sum, map_mul, map_pow, AlgHom.commutes]
+    rw [← hc i, Polynomial.aeval_eq_sum_range, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun l hl => ?_
+    have hlm : l ≤ m := (Nat.lt_succ_iff.mp (Finset.mem_range.mp hl)).trans (hdeg i hi)
+    rw [Algebra.smul_def, mul_left_comm]
+    congr 1
+    calc ψ 𝔡 ^ m * 𝐉 ^ l = ψ 𝔡 ^ (m - l) * ψ 𝔡 ^ l * 𝐉 ^ l := by
+          rw [← pow_add, Nat.sub_add_cancel hlm]
+      _ = ψ 𝔡 ^ (m - l) * (𝐉 * ψ 𝔡) ^ l := by rw [mul_pow]; ring
+      _ = ψ 𝔡 ^ (m - l) * ψ 𝔞 ^ (3 * l) := by rw [J_mul_D, ← pow_mul]
+  let P : 𝒩 := 𝔤 * (𝔞 ^ 2 * 𝔟) ^ w
+  let Q : 𝒩 := 𝔥 * 𝔡 ^ w
+  have k1 : Y * (ψ Q ^ 6 * ψ 𝔡 ^ w) = ψ P ^ 6 := by
+    simp only [P, Q, map_mul, map_pow]
+    exact key1
+  have key2 : ∀ i ≤ n, (ψ Q ^ 6 * ψ 𝔡 ^ w) ^ n * Y ^ i = ψ P ^ (6 * i) * (ψ Q ^ 6 * ψ 𝔡 ^ w) ^ (n -
+    i) :=
+    by
+    intro i hi
+    have e : (ψ Q ^ 6 * ψ 𝔡 ^ w) ^ n = (ψ Q ^ 6 * ψ 𝔡 ^ w) ^ i * (ψ Q ^ 6 * ψ 𝔡 ^ w) ^ (n - i) := by
+      rw [← pow_add, Nat.add_sub_cancel' hi]
+    calc (ψ Q ^ 6 * ψ 𝔡 ^ w) ^ n * Y ^ i = (Y * (ψ Q ^ 6 * ψ 𝔡 ^ w)) ^ i * (ψ Q ^ 6 * ψ 𝔡 ^ w) ^ (n
+      - i) := by
+          rw [e, mul_pow Y (ψ Q ^ 6 * ψ 𝔡 ^ w) i]; ring
+      _ = ψ P ^ (6 * i) * (ψ Q ^ 6 * ψ 𝔡 ^ w) ^ (n - i) := by rw [k1, ← pow_mul]
+  let E : 𝒩 :=
+    P ^ (6 * n) * 𝔡 ^ m + ∑ i ∈ Finset.range n, Cn i * (P ^ (6 * i) * (Q ^ 6 * 𝔡 ^ w) ^ (n - i))
+  have hE : ψ E = (ψ Q ^ 6 * ψ 𝔡 ^ w) ^ n * ψ 𝔡 ^ m *
+      (Y ^ n + ∑ i ∈ Finset.range n, algebraMap R (LaurentSeries ℂ) (p.coeff i) * Y ^ i) := by
+    rw [mul_add, Finset.mul_sum]
+    simp only [E, map_add, map_sum, map_mul, map_pow]
+    congr 1
+    · have h2 := key2 n le_rfl
+      rw [Nat.sub_self, pow_zero, mul_one] at h2
+      rw [mul_right_comm, h2]
+    · refine Finset.sum_congr rfl fun i hi => ?_
+      have hin : i ≤ n := (Finset.mem_range.mp hi).le
+      rw [← key3 i hi, ← key2 i hin]
+      ring
+  have hE0 : E = 0 := by
+    apply ψ_injective
+    rw [hE, hpev, mul_zero, map_zero]
+  have hC := congrArg toC hE0
+  simp only [E, map_add, map_sum, map_mul, map_pow, map_zero] at hC
+  exact order_le_of_identity (analyticAt_toC P τ) (analyticAt_toC Q τ) ((analyticAt_toC 𝔡 τ).pow m)
+    ((analyticAt_toC 𝔡 τ).pow w) (fun i _ => analyticAt_toC (Cn i) τ)
+    (by rw [Pi.pow_apply, toC𝔡_apply]; exact pow_ne_zero _ (ModularForm.discriminant_ne_zero τ))
+    (by rw [Pi.pow_apply, toC𝔡_apply]; exact pow_ne_zero _ (ModularForm.discriminant_ne_zero τ)) hC
+
+end ANb
+
+theorem solution (N : ℕ) {k : ℤ} (m : ℕ)
+    (g h : ModularForm (CongruenceSubgroup.Gamma0 N) k) (X : LaurentSeries ℂ)
+    (hX : X * ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) = ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ))
+    (h₁ : IsIntegral (Algebra.adjoin ℂ ({ModularCurve.coeffEmb ℂ ModularCurve.jq} : Set
+      (LaurentSeries ℂ)))
+      (X ^ 6 * ModularCurve.coeffEmb ℂ ModularCurve.jq ^ (4 * m) * (ModularCurve.coeffEmb ℂ
+        ModularCurve.jq - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (3 * m)))
+    (τ : UpperHalfPlane) :
+    analyticOrderAt ((fun z : UpperHalfPlane => h z * ModularForm.discriminant z ^ m) ∘
+      UpperHalfPlane.ofComplex) (τ : ℂ) ≤
+      analyticOrderAt ((fun z : UpperHalfPlane => g z * (ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) ^
+        m) ∘ UpperHalfPlane.ofComplex) (τ : ℂ) :=
+  ANb.core m (ANb.ofMF g (ANb.one_mem_strictPeriods_gamma0 N)) (ANb.ofMF h
+    (ANb.one_mem_strictPeriods_gamma0 N))
+    X hX h₁ τ
+
+end
+end S_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq_pow
+end P2MW
+export P2MW.S_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq_pow (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq_pow (N : ℕ) {k : ℤ} (m : ℕ)
+    (g h : ModularForm (CongruenceSubgroup.Gamma0 N) k) (X : LaurentSeries ℂ)
+    (hX : X * ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) = ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ))
+    (h₁ : IsIntegral (Algebra.adjoin ℂ ({ModularCurve.coeffEmb ℂ ModularCurve.jq} : Set
+      (LaurentSeries ℂ)))
+      (X ^ 6 * ModularCurve.coeffEmb ℂ ModularCurve.jq ^ (4 * m) * (ModularCurve.coeffEmb ℂ
+        ModularCurve.jq - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (3 * m)))
+    (τ : UpperHalfPlane) :
+    analyticOrderAt ((fun z : UpperHalfPlane => h z * ModularForm.discriminant z ^ m) ∘
+      UpperHalfPlane.ofComplex) (τ : ℂ) ≤
+      analyticOrderAt ((fun z : UpperHalfPlane => g z * (ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) ^
+        m) ∘ UpperHalfPlane.ofComplex) (τ : ℂ) :=
+  solution N m g h X hX h₁ τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_jqModC_pow.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_jqModC_pow.lean
new file mode 100644
index 0000000000..98c1e64d1d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_jqModC_pow.lean
@@ -0,0 +1,518 @@
+/-
+Based on Prove2Me node ModularCurve.analyticOrderAt_le_of_isIntegral_adjoin_jqModC_pow
+(8268f98e-d271-5ef9-9272-ba9304655faa) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 16b591a4-c5da-5442-8873-0def8b3ddf40
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import Mathlib.Data.Int.Star
+import Mathlib.Order.CompletePartialOrder
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_four_qCoeff_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_six_qCoeff_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality over ℂ[̄ j] bounds analytic orders on H
+
+Theorem statement: `ModularCurve.analyticOrderAt_le_of_isIntegral_adjoin_jqModC_pow`
+(`8268f98e-d271-5ef9-9272-ba9304655faa`), by Claude, 2026-09-05.
+
+Proof: submission `16b591a4-c5da-5442-8873-0def8b3ddf40`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a finite-index subgroup of $\mathrm{SL}_2(\mathbb{Z})$ containing the translation
+matrix $T$, let $k$ be an integer, let $m$ be a natural number with $m \ge 1$, and let $g,h$ be
+modular forms of weight $k$ for the image of $\Gamma$ in $\mathrm{GL}_2(\mathbb{R})$. Let $X \in
+\mathbb{C}((q))$ be a Laurent series such that $X$ times the $q$-expansion of $h$ of period $1$
+equals the $q$-expansion of $g$ of period $1$, both expansions being viewed as Laurent series via
+the inclusion of $\mathbb{C}[[q]]$. Write $\bar j =$ [`ModularCurve.jqModC
+ℂ`](def/ModularCurve_JqCoeff.html#L15) for the Laurent series $q^{-1}$ times the image in
+$\mathbb{C}[[q]]$ of the integral power series $\mathrm{eisenstein4}^3 \cdot
+\mathrm{dedekindEtaUnitInv}$, i.e. the $q$-expansion of the modular invariant $j$. Assume that $X^6
+\cdot \bar j^{\,4m} \cdot (\bar j - 1728)^{3m}$ is integral over the $\mathbb{C}$-subalgebra of
+$\mathbb{C}((q))$ generated by $\bar j$. Then for every $\tau$ in the upper half-plane, the analytic
+order of vanishing at the point $\tau \in \mathbb{C}$ of the function $z \mapsto h(z)\,\Delta(z)^m$,
+transported to $\mathbb{C}$ by precomposition with `UpperHalfPlane.ofComplex`, is at most the
+analytic order of vanishing at $\tau$ of $z \mapsto g(z)\,(E_4(z)^2 E_6(z))^m$, transported in the
+same way.
+
+This is the local form, at points of the upper half-plane, of the standard passage from an integral
+dependence relation over $\mathbb{C}[j]$ to an inequality of divisors: the monic relation, read on
+$\mathbb{H}$, bounds below the order of $g\,(E_4^2E_6)^m/(h\,\Delta^m)$ at the zeros of $E_4$ and
+$E_6$. It is used in the construction of modular and cusp forms with prescribed $q$-expansion, being
+cited by
+[`ModularCurve.exists_cuspForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral_qExpFunctionFieldC`]
+(thm.html#ModularCurve.
+exists_cuspForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral_qExpFunctionFieldC)
+and
+[`ModularCurve.exists_modularForm_gamma1_qExpansion_eq_mul_thetaL_pow_of_isIntegral`]
+(thm.html#ModularCurve.exists_modularForm_gamma1_qExpansion_eq_mul_thetaL_pow_of_isIntegral).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_jqModC_pow.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 1600000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_jqModC_pow
+
+p2m_open "UpperHalfPlane ModularCurve~coeffEmb_jq"
+open scoped MatrixGroups ModularForm Manifold
+
+noncomputable section
+
+namespace ANb
+
+def Nice (f : ℍ → ℂ) : Prop :=
+  Function.Periodic (f ∘ ofComplex) 1 ∧ MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f ∧ IsBoundedAtImInfty f
+
+theorem Nice.mul {f g : ℍ → ℂ} (hf : Nice f) (hg : Nice g) : Nice (f * g) :=
+  ⟨by simpa [Function.comp_def] using hf.1.mul hg.1, hf.2.1.mul hg.2.1, hf.2.2.mul hg.2.2⟩
+
+theorem Nice.add {f g : ℍ → ℂ} (hf : Nice f) (hg : Nice g) : Nice (f + g) :=
+  ⟨by simpa [Function.comp_def] using hf.1.add hg.1, hf.2.1.add hg.2.1, hf.2.2.add hg.2.2⟩
+
+theorem Nice.const (c : ℂ) : Nice (fun _ => c) :=
+  ⟨fun _ => rfl, mdifferentiable_const, Filter.const_boundedAtFilter _ _⟩
+
+def niceSubalgebra : Subalgebra ℂ (ℍ → ℂ) where
+  carrier := {f | Nice f}
+  mul_mem' hf hg := hf.mul hg
+  add_mem' hf hg := hf.add hg
+  algebraMap_mem' c := Nice.const c
+
+local notation "𝒩" => niceSubalgebra
+
+theorem an (f : 𝒩) : AnalyticAt ℂ (cuspFunction 1 (f : ℍ → ℂ)) 0 :=
+  UpperHalfPlane.analyticAt_cuspFunction_zero one_pos f.2.1 f.2.2.1 f.2.2.2
+
+def qexpHom : 𝒩 →ₐ[ℂ] PowerSeries ℂ where
+  toFun f := qExpansion 1 (f : ℍ → ℂ)
+  map_one' := UpperHalfPlane.qExpansion_one 1
+  map_mul' f g := UpperHalfPlane.qExpansion_mul (an f) (an g)
+  map_zero' := UpperHalfPlane.qExpansion_zero 1
+  map_add' f g := UpperHalfPlane.qExpansion_add (an f) (an g)
+  commutes' c := by
+    have h1 : ((algebraMap ℂ (ℍ → ℂ) c : ℍ → ℂ)) = c • (1 : ℍ → ℂ) := by
+      funext z; simp
+    have a1 : AnalyticAt ℂ (cuspFunction 1 (1 : ℍ → ℂ)) 0 := an (1 : 𝒩)
+    change qExpansion 1 (algebraMap ℂ (ℍ → ℂ) c) = _
+    rw [h1, UpperHalfPlane.qExpansion_smul a1 c, UpperHalfPlane.qExpansion_one,
+      Algebra.algebraMap_eq_smul_one]
+
+theorem qexpHom_apply (f : 𝒩) : qexpHom f = qExpansion 1 (f : ℍ → ℂ) := rfl
+
+def ψ : 𝒩 →ₐ[ℂ] LaurentSeries ℂ :=
+  { (HahnSeries.ofPowerSeries ℤ ℂ).comp qexpHom.toRingHom with
+    commutes' := fun c => by
+      change HahnSeries.ofPowerSeries ℤ ℂ (qexpHom (algebraMap ℂ 𝒩 c)) = _
+      rw [qexpHom.commutes, HahnSeries.algebraMap_apply'] }
+
+theorem ψ_apply (f : 𝒩) : ψ f = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (f : ℍ → ℂ)) := rfl
+
+theorem ψ_injective : Function.Injective ψ := by
+  intro f g hfg
+  rw [ψ_apply, ψ_apply] at hfg
+  have h := HahnSeries.ofPowerSeries_injective hfg
+  have h' : qExpansion 1 ((f : ℍ → ℂ) - (g : ℍ → ℂ)) = 0 := by
+    rw [UpperHalfPlane.qExpansion_sub (an f) (an g), h, sub_self]
+  have hn : Nice ((f : ℍ → ℂ) - (g : ℍ → ℂ)) := (f - g).2
+  have h0 := (UpperHalfPlane.qExpansion_eq_zero_iff one_pos hn.1 hn.2.1 hn.2.2).mp h'
+  exact Subtype.ext (sub_eq_zero.mp h0)
+
+theorem ψ_eq_zero_iff (f : 𝒩) : ψ f = 0 ↔ f = 0 :=
+  ⟨fun h => ψ_injective (by rw [h, map_zero]), fun h => by rw [h, map_zero]⟩
+
+def toC : 𝒩 →ₐ[ℂ] (ℂ → ℂ) where
+  toFun f := (f : ℍ → ℂ) ∘ ofComplex
+  map_one' := rfl
+  map_mul' _ _ := rfl
+  map_zero' := rfl
+  map_add' _ _ := rfl
+  commutes' _ := rfl
+
+theorem toC_apply (f : 𝒩) : toC f = (f : ℍ → ℂ) ∘ ofComplex := rfl
+
+theorem analyticAt_toC (f : 𝒩) (τ : ℍ) : AnalyticAt ℂ (toC f) (τ : ℂ) := by
+  have hd : DifferentiableOn ℂ ((f : ℍ → ℂ) ∘ ofComplex) {z : ℂ | 0 < z.im} :=
+    UpperHalfPlane.mdifferentiable_iff.mp f.2.2.1
+  exact hd.analyticAt ((isOpen_lt continuous_const Complex.continuous_im).mem_nhds τ.im_pos)
+
+theorem nice_of_modularForm {F : Type*} {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (h1 : (1 : ℝ) ∈ Γ.strictPeriods) : Nice (f : ℍ → ℂ) := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Subgroup.isCusp_of_mem_strictPeriods one_pos h1⟩
+  refine ⟨?_, ModularFormClass.holo f, ModularFormClass.bdd_at_infty f⟩
+  simpa using SlashInvariantFormClass.periodic_comp_ofComplex (h := 1) f h1
+
+def ofMF {F : Type*} {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (h1 : (1 : ℝ) ∈ Γ.strictPeriods) : 𝒩 :=
+  ⟨f, nice_of_modularForm f h1⟩
+
+@[scoped simp] theorem coe_ofMF {F : Type*} {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (h1 : (1 : ℝ) ∈ Γ.strictPeriods) :
+    ((ofMF f h1 : 𝒩) : ℍ → ℂ) = f := rfl
+
+theorem one_mem_strictPeriods_of_T_mem {Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)}
+    (hT : ModularGroup.T ∈ Γ) :
+    (1 : ℝ) ∈ (Subgroup.map (Matrix.SpecialLinearGroup.mapGL ℝ) Γ).strictPeriods := by
+  rw [Subgroup.strictPeriods_eq_zmultiples_one_of_T_mem hT]
+  exact AddSubgroup.mem_zmultiples 1
+
+def 𝔞 : 𝒩 := ofMF ModularForm.E₄ one_mem_strictPeriods_SL
+
+def 𝔟 : 𝒩 := ofMF ModularForm.E₆ one_mem_strictPeriods_SL
+
+def 𝔡 : 𝒩 := ofMF CuspForm.discriminant one_mem_strictPeriods_SL
+
+theorem ψ𝔞 : ψ 𝔞 = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) := rfl
+theorem ψ𝔟 : ψ 𝔟 = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) := rfl
+theorem ψ𝔡 : ψ 𝔡 = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 ModularForm.discriminant) := rfl
+theorem toC𝔡_apply (τ : ℍ) : toC 𝔡 (τ : ℂ) = ModularForm.discriminant τ := by
+  change ModularForm.discriminant (ofComplex (τ : ℂ)) = _
+  rw [ofComplex_apply]
+
+theorem coeff_one_mul (φ χ : PowerSeries ℂ) :
+    PowerSeries.coeff 1 (φ * χ) = PowerSeries.coeff 0 φ * PowerSeries.coeff 1 χ +
+      PowerSeries.coeff 1 φ * PowerSeries.coeff 0 χ := by
+  rw [PowerSeries.coeff_mul, Finset.Nat.sum_antidiagonal_eq_sum_range_succ_mk]
+  simp [Finset.sum_range_succ]
+
+theorem coeff_zero_mul' (φ χ : PowerSeries ℂ) :
+    PowerSeries.coeff 0 (φ * χ) = PowerSeries.coeff 0 φ * PowerSeries.coeff 0 χ := by
+  rw [PowerSeries.coeff_zero_eq_constantCoeff_apply, PowerSeries.coeff_zero_eq_constantCoeff_apply,
+    PowerSeries.coeff_zero_eq_constantCoeff_apply, map_mul]
+
+theorem qA0 : PowerSeries.coeff 0 (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) = 1 :=
+  EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) ⟨2, rfl⟩
+theorem qB0 : PowerSeries.coeff 0 (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) = 1 :=
+  EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) ⟨3, rfl⟩
+theorem qA1 : PowerSeries.coeff 1 (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) = 240 := by
+  have h := ModularForm.levelOne_weight_four_qCoeff_one ModularForm.E₄
+  simp only [ModularFormClass.qCoeff] at h
+  rw [h, qA0, mul_one]
+theorem qB1 : PowerSeries.coeff 1 (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) = -504 := by
+  have h := ModularForm.levelOne_weight_six_qCoeff_one ModularForm.E₆
+  simp only [ModularFormClass.qCoeff] at h
+  rw [h, qB0, mul_one]
+theorem qD1 : PowerSeries.coeff 1 (qExpansion 1 ModularForm.discriminant) = 1 := by
+  rw [ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit, PowerSeries.coeff_map,
+    PowerSeries.coeff_succ_X_mul, PowerSeries.coeff_zero_eq_constantCoeff_apply,
+    ModularCurve.constantCoeff_dedekindEtaUnit, map_one]
+
+theorem A_cube_sub_B_sq : ψ 𝔞 ^ 3 - ψ 𝔟 ^ 2 = 1728 * ψ 𝔡 := by
+  let T : ModularForm 𝒮ℒ 12 := ModularForm.E₄.mul (ModularForm.E₄.mul ModularForm.E₄)
+  let U : ModularForm 𝒮ℒ 12 := ModularForm.E₆.mul ModularForm.E₆
+  let Z : ModularForm 𝒮ℒ 12 := T - U
+  have hZ : (Z : ℍ → ℂ) = ((𝔞 * (𝔞 * 𝔞) - 𝔟 * 𝔟 : 𝒩) : ℍ → ℂ) := by
+    funext z
+    change (T : ℍ → ℂ) z - (U : ℍ → ℂ) z = _
+    rfl
+  have hZq : qExpansion 1 (Z : ℍ → ℂ) =
+      qExpansion 1 ⇑ModularForm.E₄ * (qExpansion 1 ⇑ModularForm.E₄ * qExpansion 1 ⇑ModularForm.E₄) -
+        qExpansion 1 ⇑ModularForm.E₆ * qExpansion 1 ⇑ModularForm.E₆ := by
+    rw [hZ, ← qexpHom_apply, map_sub, map_mul, map_mul, map_mul]
+    rfl
+  have h0 : ModularFormClass.qCoeff (Z : ℍ → ℂ) 0 = 0 := by
+    simp only [ModularFormClass.qCoeff, hZq, map_sub, coeff_zero_mul', qA0, qB0]
+    norm_num
+  have h1 : ModularFormClass.qCoeff (Z : ℍ → ℂ) 1 = 1728 := by
+    simp only [ModularFormClass.qCoeff, hZq, map_sub, coeff_one_mul, coeff_zero_mul', qA0, qA1, qB0,
+      qB1]
+    norm_num
+  have hW := ModularForm.levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant Z h0
+  have hZΔ : qExpansion 1 (Z : ℍ → ℂ) = PowerSeries.C 1728 * qExpansion 1 ModularForm.discriminant
+    :=
+    by
+    ext n
+    rw [PowerSeries.coeff_C_mul]
+    have := hW n
+    have h1' := h1
+    simp only [ModularFormClass.qCoeff] at this h1'
+    rw [this, h1']
+  have hL : ψ (𝔞 * (𝔞 * 𝔞) - 𝔟 * 𝔟) = 1728 * ψ 𝔡 := by
+    rw [ψ_apply, ← hZ, hZΔ, map_mul, HahnSeries.ofPowerSeries_C, map_ofNat, ψ𝔡]
+  rw [map_sub, map_mul, map_mul, map_mul] at hL
+  rw [← hL]
+  ring
+
+theorem ψ𝔡_ne_zero : ψ 𝔡 ≠ 0 := by
+  intro h
+  have h0 : (𝔡 : 𝒩) = 0 := (ψ_eq_zero_iff _).mp h
+  have : ModularForm.discriminant UpperHalfPlane.I = 0 := by
+    have := congrArg (fun f : 𝒩 => (f : ℍ → ℂ) UpperHalfPlane.I) h0
+    simp only [ZeroMemClass.coe_zero, Pi.zero_apply] at this
+    exact this
+  exact ModularForm.discriminant_ne_zero _ this
+
+theorem coeffEmb_jq : coeffEmb ℂ jq = jqModC ℂ := by
+  change (jqModC ℚ).map (algebraMap ℚ ℂ) = jqModC ℂ
+  exact map_jqModC _
+
+theorem J_mul_D : coeffEmb ℂ jq * ψ 𝔡 = ψ 𝔞 ^ 3 := by
+  rw [coeffEmb_jq, ModularCurve.jqModC_eq_qExpansion_E4_cube_div_discriminant, ← ψ𝔞, ← ψ𝔡,
+    div_mul_cancel₀ _ ψ𝔡_ne_zero]
+
+theorem J_sub_mul_D : (coeffEmb ℂ jq - algebraMap ℂ (LaurentSeries ℂ) 1728) * ψ 𝔡 = ψ 𝔟 ^ 2 := by
+  rw [map_ofNat, sub_mul, J_mul_D]
+  have := A_cube_sub_B_sq
+  linear_combination this
+
+theorem le_analyticOrderAt_sum {ι : Type*} (s : Finset ι) (F : ι → ℂ → ℂ) (z : ℂ) (b : ℕ∞)
+    (h : ∀ i ∈ s, b ≤ analyticOrderAt (F i) z) : b ≤ analyticOrderAt (∑ i ∈ s, F i) z := by
+  classical
+  induction s using Finset.induction_on with
+  | empty =>
+    rw [Finset.sum_empty, analyticOrderAt_eq_top.mpr (by simp)]
+    exact le_top
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha]
+    refine le_trans ?_ le_analyticOrderAt_add
+    exact le_min (h a (Finset.mem_insert_self a s)) (ih fun i hi => h i (Finset.mem_insert_of_mem
+      hi))
+
+theorem order_le_of_identity {p q d₁ d : ℂ → ℂ} {n : ℕ} {C : ℕ → ℂ → ℂ} {z : ℂ}
+    (hp : AnalyticAt ℂ p z) (hq : AnalyticAt ℂ q z) (hd₁ : AnalyticAt ℂ d₁ z)
+    (hd : AnalyticAt ℂ d z)
+    (hC : ∀ i ∈ Finset.range n, AnalyticAt ℂ (C i) z) (hd₁0 : d₁ z ≠ 0) (hd0 : d z ≠ 0)
+    (hid : p ^ (6 * n) * d₁ + ∑ i ∈ Finset.range n, C i * (p ^ (6 * i) * (q ^ 6 * d) ^ (n - i)) =
+      0) :
+    analyticOrderAt q z ≤ analyticOrderAt p z := by
+  by_contra hlt'
+  have hlt := not_le.mp hlt'
+  obtain ⟨k, hk⟩ : ∃ k : ℕ, (k : ℕ∞) = analyticOrderAt p z :=
+    ENat.ne_top_iff_exists.mp (ne_top_of_lt hlt)
+  have hd_ord : analyticOrderAt d z = 0 := hd.analyticOrderAt_eq_zero.mpr hd0
+  have hd₁_ord : analyticOrderAt d₁ z = 0 := hd₁.analyticOrderAt_eq_zero.mpr hd₁0
+  have hL : analyticOrderAt (p ^ (6 * n) * d₁) z = ((6 * n * k : ℕ) : ℕ∞) := by
+    rw [analyticOrderAt_mul (hp.pow _) hd₁, analyticOrderAt_pow hp, ← hk, hd₁_ord]
+    simp only [nsmul_eq_mul, add_zero]
+    push_cast
+    ring
+  have hq_ord : ((k + 1 : ℕ) : ℕ∞) ≤ analyticOrderAt q z := by
+    rw [← hk] at hlt
+    have := Order.add_one_le_of_lt hlt
+    exact_mod_cast this
+  have hR : ∀ i ∈ Finset.range n, ((6 * n * k + 6 : ℕ) : ℕ∞) ≤
+      analyticOrderAt (C i * (p ^ (6 * i) * (q ^ 6 * d) ^ (n - i))) z := by
+    intro i hi
+    have hin : i < n := Finset.mem_range.mp hi
+    have hqd : AnalyticAt ℂ (q ^ 6 * d) z := (hq.pow _).mul hd
+    rw [analyticOrderAt_mul (hC i hi) ((hp.pow _).mul (hqd.pow _)),
+      analyticOrderAt_mul (hp.pow _) (hqd.pow _), analyticOrderAt_pow hp, analyticOrderAt_pow hqd,
+      analyticOrderAt_mul (hq.pow _) hd, analyticOrderAt_pow hq, hd_ord, ← hk, add_zero]
+    have h1 : ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞) ≤ (n - i) • (6 • analyticOrderAt q z) := by
+      have : (n - i) • (6 • (((k + 1 : ℕ)) : ℕ∞)) ≤ (n - i) • (6 • analyticOrderAt q z) :=
+        nsmul_le_nsmul_right (nsmul_le_nsmul_right hq_ord 6) (n - i)
+      refine le_trans (le_of_eq ?_) this
+      simp only [nsmul_eq_mul]
+      push_cast
+      ring
+    have h2 : ((6 * n * k + 6 : ℕ) : ℕ∞) ≤ ((6 * i) • (k : ℕ∞)) + ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞)
+      :=
+      by
+      have e : ((6 * i) • (k : ℕ∞)) + ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞) =
+          ((6 * i * k + 6 * (n - i) * (k + 1) : ℕ) : ℕ∞) := by
+        simp only [nsmul_eq_mul]
+        push_cast
+        ring
+      rw [e]
+      exact_mod_cast (show 6 * n * k + 6 ≤ 6 * i * k + 6 * (n - i) * (k + 1) by
+        obtain ⟨j, rfl⟩ := Nat.exists_eq_add_of_lt hin
+        rw [show i + j + 1 - i = j + 1 by omega]
+        nlinarith)
+    calc ((6 * n * k + 6 : ℕ) : ℕ∞)
+        ≤ (6 * i) • (k : ℕ∞) + ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞) := h2
+      _ ≤ (6 * i) • (k : ℕ∞) + (n - i) • (6 • analyticOrderAt q z) := add_le_add le_rfl h1
+      _ ≤ analyticOrderAt (C i) z + ((6 * i) • (k : ℕ∞) + (n - i) • (6 • analyticOrderAt q z)) :=
+          self_le_add_left _ _
+  have hsum := le_analyticOrderAt_sum (Finset.range n) _ z _ hR
+  have heq : p ^ (6 * n) * d₁ = -(∑ i ∈ Finset.range n, C i * (p ^ (6 * i) * (q ^ 6 * d) ^ (n - i)))
+    :=
+    eq_neg_of_add_eq_zero_left hid
+  have : ((6 * n * k + 6 : ℕ) : ℕ∞) ≤ ((6 * n * k : ℕ) : ℕ∞) := by
+    rw [← hL, heq, analyticOrderAt_neg]
+    exact hsum
+  have := ENat.natCast_le_natCast.mp this
+  omega
+
+end ANb
+
+namespace ANb
+
+local notation "𝒩" => niceSubalgebra
+local notation "𝐉" => ModularCurve.coeffEmb ℂ ModularCurve.jq
+
+
+theorem core (w : ℕ) (𝔤 𝔥 : 𝒩) (X : LaurentSeries ℂ) (hX : X * ψ 𝔥 = ψ 𝔤)
+    (h₁ : IsIntegral (Algebra.adjoin ℂ ({𝐉} : Set (LaurentSeries ℂ)))
+      (X ^ 6 * 𝐉 ^ (4 * w) * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (3 * w)))
+    (τ : ℍ) :
+    analyticOrderAt (toC (𝔥 * 𝔡 ^ w)) (τ : ℂ) ≤ analyticOrderAt (toC (𝔤 * (𝔞 ^ 2 * 𝔟) ^ w)) (τ : ℂ)
+      := by
+  classical
+  have e1 : ∀ (Xx Jj T H D : LaurentSeries ℂ),
+      (Xx ^ 6 * Jj ^ (4 * w) * T ^ (3 * w)) * ((H * D ^ w) ^ 6 * D ^ w)
+        = (Xx * H) ^ 6 * ((Jj * D) ^ 4 * (T * D) ^ 3) ^ w := by
+    intro Xx Jj T H D
+    ring
+  have e2 : ∀ (G A B : LaurentSeries ℂ),
+      G ^ 6 * ((A ^ 3) ^ 4 * (B ^ 2) ^ 3) ^ w = (G * (A ^ 2 * B) ^ w) ^ 6 := by
+    intro G A B
+    ring
+  have key1 : (X ^ 6 * 𝐉 ^ (4 * w) * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (3 * w)) *
+      ((ψ 𝔥 * ψ 𝔡 ^ w) ^ 6 * ψ 𝔡 ^ w) = (ψ 𝔤 * (ψ 𝔞 ^ 2 * ψ 𝔟) ^ w) ^ 6 := by
+    rw [e1, hX, J_mul_D, J_sub_mul_D, e2]
+  obtain ⟨p, hpm, hpev⟩ := h₁
+  rw [hpm.as_sum] at hpev
+  simp only [Polynomial.eval₂_add, Polynomial.eval₂_pow, Polynomial.eval₂_X,
+    Polynomial.eval₂_finsetSum,
+    Polynomial.eval₂_mul, Polynomial.eval₂_C] at hpev
+  set R := Algebra.adjoin ℂ ({𝐉} : Set (LaurentSeries ℂ)) with hR
+  set Y := X ^ 6 * 𝐉 ^ (4 * w) * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (3 * w) with hY
+  set n := p.natDegree with hn
+  clear_value Y
+  have hmem : ∀ i, ∃ c : Polynomial ℂ,
+      Polynomial.aeval (𝐉) c = algebraMap R (LaurentSeries ℂ) (p.coeff i) := by
+    intro i
+    have hi' : algebraMap R (LaurentSeries ℂ) (p.coeff i) ∈ (Polynomial.aeval (R := ℂ) (𝐉)).range :=
+      by
+      rw [← Algebra.adjoin_singleton_eq_range_aeval]
+      exact (p.coeff i).2
+    exact hi'
+  choose c hc using hmem
+  set m := ∑ i ∈ Finset.range n, (c i).natDegree with hm
+  have hdeg : ∀ i ∈ Finset.range n, (c i).natDegree ≤ m := fun i hi =>
+    Finset.single_le_sum (f := fun j => (c j).natDegree) (fun j _ => Nat.zero_le _) hi
+  let Cn : ℕ → 𝒩 := fun i =>
+    ∑ l ∈ Finset.range ((c i).natDegree + 1), algebraMap ℂ 𝒩 ((c i).coeff l) * (𝔡 ^ (m - l) * 𝔞 ^ (3
+      * l))
+  have key3 : ∀ i ∈ Finset.range n, ψ 𝔡 ^ m * algebraMap R (LaurentSeries ℂ) (p.coeff i) = ψ (Cn i)
+    :=
+    by
+    intro i hi
+    simp only [Cn, map_sum, map_mul, map_pow, AlgHom.commutes]
+    rw [← hc i, Polynomial.aeval_eq_sum_range, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun l hl => ?_
+    have hlm : l ≤ m := (Nat.lt_succ_iff.mp (Finset.mem_range.mp hl)).trans (hdeg i hi)
+    rw [Algebra.smul_def, mul_left_comm]
+    congr 1
+    calc ψ 𝔡 ^ m * 𝐉 ^ l = ψ 𝔡 ^ (m - l) * ψ 𝔡 ^ l * 𝐉 ^ l := by
+          rw [← pow_add, Nat.sub_add_cancel hlm]
+      _ = ψ 𝔡 ^ (m - l) * (𝐉 * ψ 𝔡) ^ l := by rw [mul_pow]; ring
+      _ = ψ 𝔡 ^ (m - l) * ψ 𝔞 ^ (3 * l) := by rw [J_mul_D, ← pow_mul]
+  let P : 𝒩 := 𝔤 * (𝔞 ^ 2 * 𝔟) ^ w
+  let Q : 𝒩 := 𝔥 * 𝔡 ^ w
+  have k1 : Y * (ψ Q ^ 6 * ψ 𝔡 ^ w) = ψ P ^ 6 := by
+    simp only [P, Q, map_mul, map_pow]
+    exact key1
+  have key2 : ∀ i ≤ n, (ψ Q ^ 6 * ψ 𝔡 ^ w) ^ n * Y ^ i = ψ P ^ (6 * i) * (ψ Q ^ 6 * ψ 𝔡 ^ w) ^ (n -
+    i) :=
+    by
+    intro i hi
+    have e : (ψ Q ^ 6 * ψ 𝔡 ^ w) ^ n = (ψ Q ^ 6 * ψ 𝔡 ^ w) ^ i * (ψ Q ^ 6 * ψ 𝔡 ^ w) ^ (n - i) := by
+      rw [← pow_add, Nat.add_sub_cancel' hi]
+    calc (ψ Q ^ 6 * ψ 𝔡 ^ w) ^ n * Y ^ i = (Y * (ψ Q ^ 6 * ψ 𝔡 ^ w)) ^ i * (ψ Q ^ 6 * ψ 𝔡 ^ w) ^ (n
+      - i) := by
+          rw [e, mul_pow Y (ψ Q ^ 6 * ψ 𝔡 ^ w) i]; ring
+      _ = ψ P ^ (6 * i) * (ψ Q ^ 6 * ψ 𝔡 ^ w) ^ (n - i) := by rw [k1, ← pow_mul]
+  let E : 𝒩 :=
+    P ^ (6 * n) * 𝔡 ^ m + ∑ i ∈ Finset.range n, Cn i * (P ^ (6 * i) * (Q ^ 6 * 𝔡 ^ w) ^ (n - i))
+  have hE : ψ E = (ψ Q ^ 6 * ψ 𝔡 ^ w) ^ n * ψ 𝔡 ^ m *
+      (Y ^ n + ∑ i ∈ Finset.range n, algebraMap R (LaurentSeries ℂ) (p.coeff i) * Y ^ i) := by
+    rw [mul_add, Finset.mul_sum]
+    simp only [E, map_add, map_sum, map_mul, map_pow]
+    congr 1
+    · have h2 := key2 n le_rfl
+      rw [Nat.sub_self, pow_zero, mul_one] at h2
+      rw [mul_right_comm, h2]
+    · refine Finset.sum_congr rfl fun i hi => ?_
+      have hin : i ≤ n := (Finset.mem_range.mp hi).le
+      rw [← key3 i hi, ← key2 i hin]
+      ring
+  have hE0 : E = 0 := by
+    apply ψ_injective
+    rw [hE, hpev, mul_zero, map_zero]
+  have hC := congrArg toC hE0
+  simp only [E, map_add, map_sum, map_mul, map_pow, map_zero] at hC
+  exact order_le_of_identity (analyticAt_toC P τ) (analyticAt_toC Q τ) ((analyticAt_toC 𝔡 τ).pow m)
+    ((analyticAt_toC 𝔡 τ).pow w) (fun i _ => analyticAt_toC (Cn i) τ)
+    (by rw [Pi.pow_apply, toC𝔡_apply]; exact pow_ne_zero _ (ModularForm.discriminant_ne_zero τ))
+    (by rw [Pi.pow_apply, toC𝔡_apply]; exact pow_ne_zero _ (ModularForm.discriminant_ne_zero τ)) hC
+
+end ANb
+
+theorem solution (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hT : ModularGroup.T ∈ Γ) {k : ℤ} (m : ℕ)
+    (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (X : LaurentSeries ℂ)
+    (hX : X * ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) = ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ))
+    (h₁ : IsIntegral (Algebra.adjoin ℂ ({ModularCurve.jqModC ℂ} : Set (LaurentSeries ℂ)))
+      (X ^ 6 * ModularCurve.jqModC ℂ ^ (4 * m) * (ModularCurve.jqModC ℂ - algebraMap ℂ
+        (LaurentSeries ℂ) 1728) ^ (3 * m)))
+    (τ : UpperHalfPlane) :
+    analyticOrderAt ((fun z : UpperHalfPlane => h z * ModularForm.discriminant z ^ m) ∘
+      UpperHalfPlane.ofComplex) (τ : ℂ) ≤
+      analyticOrderAt ((fun z : UpperHalfPlane => g z * (ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) ^
+        m) ∘ UpperHalfPlane.ofComplex) (τ : ℂ) := by
+  have h₁' : IsIntegral (Algebra.adjoin ℂ ({ModularCurve.coeffEmb ℂ ModularCurve.jq} : Set
+    (LaurentSeries ℂ)))
+      (X ^ 6 * ModularCurve.coeffEmb ℂ ModularCurve.jq ^ (4 * m) *
+        (ModularCurve.coeffEmb ℂ ModularCurve.jq - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (3 * m))
+          := by
+    rw [ANb.coeffEmb_jq]; exact h₁
+  exact ANb.core m (ANb.ofMF g (ANb.one_mem_strictPeriods_of_T_mem hT)) (ANb.ofMF h
+    (ANb.one_mem_strictPeriods_of_T_mem hT))
+    X hX h₁' τ
+
+end
+end S_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_jqModC_pow
+end P2MW
+export P2MW.S_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_jqModC_pow (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+open scoped MatrixGroups ModularForm
+theorem ModularCurve.analyticOrderAt_le_of_isIntegral_adjoin_jqModC_pow
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    {k : ℤ} (m : ℕ)
+    (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (X : LaurentSeries ℂ)
+    (hX : X * ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) = ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ))
+    (h₁ : IsIntegral (Algebra.adjoin ℂ ({ModularCurve.jqModC ℂ} : Set (LaurentSeries ℂ)))
+      (X ^ 6 * ModularCurve.jqModC ℂ ^ (4 * m) * (ModularCurve.jqModC ℂ - algebraMap ℂ
+        (LaurentSeries ℂ) 1728) ^ (3 * m)))
+    (τ : UpperHalfPlane) :
+    analyticOrderAt ((fun z : UpperHalfPlane => h z * ModularForm.discriminant z ^ m) ∘
+      UpperHalfPlane.ofComplex) (τ : ℂ) ≤
+      analyticOrderAt ((fun z : UpperHalfPlane => g z * (ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) ^
+        m) ∘ UpperHalfPlane.ofComplex) (τ : ℂ) :=
+  solution Γ hT m g h X hX h₁ τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_card_eq_cuspCount_of_forall_mem_iff_ord_jBar_neg.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_card_eq_cuspCount_of_forall_mem_iff_ord_jBar_neg.lean
new file mode 100644
index 0000000000..d390d5f9e2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_card_eq_cuspCount_of_forall_mem_iff_ord_jBar_neg.lean
@@ -0,0 +1,247 @@
+/-
+Based on Prove2Me node ModularCurve.card_eq_cuspCount_of_forall_mem_iff_ord_jBar_neg
+(b3cca73c-0614-5ee1-968b-263bb5f17685) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7fd0e88a-2a7a-5516-b878-c9e879a965a7
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_MazurStepThreeInputs
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+
+import Mathlib.RingTheory.RootsOfUnity.AlgebraicallyClosed
+import Mathlib.Data.Nat.Totient
+import Mathlib.Algebra.BigOperators.Group.Finset.Sigma
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_slot_of_isCusp
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_slot_place_eq_iff_modEq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_slot_ord_of_algHom_laurentBaseChange
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_algHom_laurentBaseChange_slot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_algHom_laurentSeries
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCusp_iff_ord_neg
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Number of cusps of X₀(N) over ℚ̄
+
+Theorem statement: `ModularCurve.card_eq_cuspCount_of_forall_mem_iff_ord_jBar_neg`
+(`b3cca73c-0614-5ee1-968b-263bb5f17685`), by Claude, 2026-09-05.
+
+Proof: submission `7fd0e88a-2a7a-5516-b878-c9e879a965a7`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and let $\overline{\mathbb Q}$ be `AlgebraicClosure ℚ`. Work in
+the field $\overline{\mathbb Q}F_N$ = [`ModularCurve.modularFunctionFieldBar
+N`](def/ModularCurve_ArithmeticGalois.html#L111), i.e. the intermediate field of $\overline{\mathbb
+Q}((q))$ over $\overline{\mathbb Q}$ generated by the image, under the coefficientwise embedding
+$\mathbb Q((q)) \to \overline{\mathbb Q}((q))$, of the subfield `modularFunctionFieldFull N` of
+$\mathbb Q((q))$ generated over $\mathbb Q$ by the expansions `divisorExpansions N`. A place of this
+field over $\overline{\mathbb Q}$ is, by the structure
+[`AlgebraicCurve.Place`](def/AlgebraicCurve_DivisorClassGroup.html#L22), a valuation subring
+containing $\overline{\mathbb Q}$, distinct from the whole field, and a principal ideal ring; for
+such a place $v$, $v.\mathrm{ord}$ is minus the logarithm of the associated adic valuation. Let $S$
+be a finite set of such places, and assume that a place $v$ lies in $S$ exactly when
+$v.\mathrm{ord}(\bar\jmath) < 0$, where $\bar\jmath$ = [`ModularCurve.jBar
+N`](def/ModularCurve_MazurStepThreeInputs.html#L43) is the element of $\overline{\mathbb Q}F_N$
+given by the $q$-expansion of the modular invariant. Then $S$ has cardinality
+[`ModularCurve.cuspCount N`](def/ModularCurve_GenusNumerics.html#L13) $= \sum_{d \mid N}
+\varphi(\gcd(d, N/d))$.
+
+This is the classical count of the cusps of $X_0(N)$ over an algebraically closed field of
+characteristic zero, the cusps being realised here as the places of the function field at which
+$\bar\jmath$ has a pole; the hypothesis shape lets a caller supply any finite set cutting out
+exactly those places. It feeds the computation of the genus of $X_0(N)$ and the Riemann–Roch
+estimates used in the analysis of modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_card_eq_cuspCount_of_forall_mem_iff_ord_jBar_neg.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_card_eq_cuspCount_of_forall_mem_iff_ord_jBar_neg
+
+open ModularCurve AlgebraicCurve
+
+namespace CuspCountX0NBar
+
+local notation "Kb" => AlgebraicClosure ℚ
+
+variable (N : ℕ) [NeZero N]
+
+def SlotAt (ζ : Kbˣ) (a b : ℕ)
+    (w : Place Kb (laurentBaseChange Kb (modularFunctionFieldFull N))) : Prop :=
+  ∃ (_ : NeZero a)
+    (ι : laurentBaseChange Kb (modularFunctionFieldFull N) →ₐ[Kb] LaurentSeries Kb) (γ : ℤ),
+    0 < γ ∧
+    ι ⟨coeffEmb Kb jq, coeffEmb_mem_laurentBaseChange Kb (jq_mem_full N)⟩ =
+        qExpand Kb N (coeffEmb Kb jq) ∧
+    ι ⟨coeffEmb Kb (jqN N), coeffEmb_mem_laurentBaseChange Kb (jqd_mem_full N (dvd_refl N))⟩ =
+        qExpand Kb (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb Kb jq)) ∧
+    ∀ x, w.ord x * γ = (ι x).order
+
+theorem order_qExpand_coeffEmb_jq_neg : (qExpand Kb N (coeffEmb Kb jq)).order < 0 := by
+  have h1 : (qExpand Kb N (coeffEmb Kb jq)).coeff ((N : ℤ) * (-1)) ≠ 0 := by
+    rw [qExpand_coeff_mul, coeffEmb_coeff, coeff_jq_neg_one, map_one]
+    exact one_ne_zero
+  have h2 := HahnSeries.order_le_of_coeff_ne_zero h1
+  have hN : (0 : ℤ) < N := by exact_mod_cast NeZero.pos N
+  linarith
+
+variable {N}
+
+theorem neZero_of_dvd {a : ℕ} (ha : a ∣ N) : NeZero a :=
+  ⟨by rintro rfl; exact NeZero.ne N (Nat.eq_zero_of_zero_dvd ha)⟩
+
+theorem div_pos_of_dvd {a : ℕ} (ha : a ∣ N) : 0 < N / a :=
+  haveI := neZero_of_dvd ha
+  Nat.div_pos (Nat.le_of_dvd (NeZero.pos N) ha) (NeZero.pos a)
+
+theorem gcd_pos_of_dvd {a : ℕ} (ha : a ∣ N) : 0 < Nat.gcd a (N / a) :=
+  haveI := neZero_of_dvd ha
+  Nat.gcd_pos_of_pos_left _ (NeZero.pos a)
+
+theorem gcd_gcd_swap (a b c : ℕ) : Nat.gcd (Nat.gcd a b) c = Nat.gcd (Nat.gcd a c) b := by
+  rw [Nat.gcd_assoc, Nat.gcd_comm b c, ← Nat.gcd_assoc]
+
+theorem exists_slotAt (ζ : Kbˣ) (hζ : IsPrimitiveRoot (ζ : Kb) N) {a b : ℕ} (ha : a ∣ N)
+    (hb : b < Nat.gcd a (N / a)) (hcop : Nat.Coprime (Nat.gcd a (N / a)) b) :
+    ∃ w, SlotAt N ζ a b w := by
+  have := neZero_of_dvd ha
+  have hb' : b < N / a :=
+    lt_of_lt_of_le hb (Nat.le_of_dvd (div_pos_of_dvd ha) (Nat.gcd_dvd_right _ _))
+  have hg : Nat.gcd (Nat.gcd a b) (N / a) = 1 := by
+    rw [gcd_gcd_swap]
+    exact Nat.coprime_iff_gcd_eq_one.mp hcop
+  obtain ⟨ι, h1, h2⟩ :=
+    ModularCurve.exists_algHom_laurentBaseChange_slot Kb N ζ hζ a b ha hb' hg
+  have hne : ∃ x, (ι x).order ≠ 0 :=
+    ⟨_, by rw [h1]; exact (order_qExpand_coeffEmb_jq_neg N).ne⟩
+  obtain ⟨w, γ, hγ, hw⟩ :=
+    AlgebraicCurve.Place.exists_ord_mul_eq_order_of_algHom_laurentSeries Kb ι hne
+  exact ⟨w, ‹NeZero a›, ι, γ, by exact_mod_cast hγ, h1, h2, hw⟩
+
+theorem ord_neg_of_slotAt (ζ : Kbˣ) {a b : ℕ} (ha : a ∣ N)
+    {w : Place Kb (laurentBaseChange Kb (modularFunctionFieldFull N))} (h : SlotAt N ζ a b w) :
+    w.ord ⟨coeffEmb Kb jq, coeffEmb_mem_laurentBaseChange Kb (jq_mem_full N)⟩ < 0 := by
+  obtain ⟨_, ι, γ, hγ, h1, h2, hw⟩ := h
+  obtain ⟨-, hj, -⟩ :=
+    ModularCurve.slot_ord_of_algHom_laurentBaseChange Kb N ζ a b ha ι h1 h2 w γ hγ hw
+  rw [hj]
+  have hpos : 0 < N / a / Nat.gcd a (N / a) :=
+    Nat.div_pos (Nat.le_of_dvd (div_pos_of_dvd ha) (Nat.gcd_dvd_right _ _)) (gcd_pos_of_dvd ha)
+  omega
+
+theorem slotAt_eq_iff (ζ : Kbˣ) (hζ : IsPrimitiveRoot (ζ : Kb) N) {a b a' b' : ℕ}
+    (ha : a ∣ N) (ha' : a' ∣ N)
+    {w w' : Place Kb (laurentBaseChange Kb (modularFunctionFieldFull N))}
+    (h : SlotAt N ζ a b w) (h' : SlotAt N ζ a' b' w') :
+    w = w' ↔ a = a' ∧ b ≡ b' [MOD Nat.gcd a (N / a)] := by
+  obtain ⟨_, ι, γ, hγ, h1, h2, hw⟩ := h
+  obtain ⟨_, ι', γ', hγ', h1', h2', hw'⟩ := h'
+  exact ModularCurve.slot_place_eq_iff_modEq Kb N ζ hζ a b ha a' b' ha' ι ι' h1 h2 h1' h2'
+    w w' γ γ' hγ hγ' hw hw'
+
+theorem exists_slotAt_of_ord_neg (ζ : Kbˣ) (hζ : IsPrimitiveRoot (ζ : Kb) N)
+    {v : Place Kb (laurentBaseChange Kb (modularFunctionFieldFull N))}
+    (hv : v.ord ⟨coeffEmb Kb jq, coeffEmb_mem_laurentBaseChange Kb (jq_mem_full N)⟩ < 0) :
+    ∃ a b : ℕ, a ∣ N ∧ Nat.Coprime (Nat.gcd a (N / a)) b ∧ SlotAt N ζ a b v := by
+  have hc : IsCusp (⟨coeffEmb Kb jq, coeffEmb_mem_laurentBaseChange Kb (jq_mem_full N)⟩ :
+      laurentBaseChange Kb (modularFunctionFieldFull N)) v :=
+    (ModularCurve.isCusp_iff_ord_neg _ v).mpr hv
+  obtain ⟨a, b, ha, -, hg, hne, ι, h1, h2, hw⟩ := ModularCurve.exists_slot_of_isCusp Kb N ζ hζ v hc
+  refine ⟨a, b, ha, ?_, hne, ι, ((a * Nat.gcd a (N / a) : ℕ) : ℤ), ?_, h1, h2, hw⟩
+  · rw [gcd_gcd_swap] at hg
+    exact Nat.coprime_iff_gcd_eq_one.mpr hg
+  · have := hne
+    exact_mod_cast Nat.mul_pos (NeZero.pos a) (gcd_pos_of_dvd ha)
+
+variable (N) in
+def labels : Finset (Σ _ : ℕ, ℕ) :=
+  N.divisors.sigma fun a =>
+    {b ∈ Finset.range (Nat.gcd a (N / a)) | (Nat.gcd a (N / a)).Coprime b}
+
+theorem mem_labels {p : Σ _ : ℕ, ℕ} :
+    p ∈ labels N ↔ p.1 ∣ N ∧ p.2 < Nat.gcd p.1 (N / p.1) ∧ (Nat.gcd p.1 (N / p.1)).Coprime p.2 := by
+  simp only [labels, Finset.mem_sigma, Nat.mem_divisors, Finset.mem_filter, Finset.mem_range]
+  exact ⟨fun ⟨⟨h1, _⟩, h2, h3⟩ => ⟨h1, h2, h3⟩, fun ⟨h1, h2, h3⟩ => ⟨⟨h1, NeZero.ne N⟩, h2, h3⟩⟩
+
+variable (N) in
+omit [NeZero N] in
+theorem card_labels : (labels N).card = cuspCount N := by
+  rw [labels, Finset.card_sigma, cuspCount]
+  rfl
+
+end CuspCountX0NBar
+
+open CuspCountX0NBar in
+theorem solution (N : ℕ) [NeZero N]
+    (S : Finset (AlgebraicCurve.Place (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar
+      N)))
+    (hS : ∀ v, v ∈ S ↔ v.ord (ModularCurve.jBar N) < 0) :
+    S.card = ModularCurve.cuspCount N := by
+  obtain ⟨z, hz⟩ := HasEnoughRootsOfUnity.exists_primitiveRoot (AlgebraicClosure ℚ) N
+  set ζ : (AlgebraicClosure ℚ)ˣ := (hz.isUnit (NeZero.ne N)).unit with hζdef
+  have hζ : IsPrimitiveRoot (ζ : AlgebraicClosure ℚ) N := by
+    rw [hζdef, IsUnit.unit_spec]
+    exact hz
+  have hex : ∀ p ∈ labels N, ∃ w, SlotAt N ζ p.1 p.2 w := fun p hp => by
+    obtain ⟨h1, h2, h3⟩ := mem_labels.mp hp
+    exact exists_slotAt ζ hζ h1 h2 h3
+  rw [← card_labels N]
+  symm
+  refine Finset.card_bij (fun p hp => (hex p hp).choose) ?_ ?_ ?_
+  · intro p hp
+    exact (hS _).mpr (ord_neg_of_slotAt ζ (mem_labels.mp hp).1 (hex p hp).choose_spec)
+  · intro p hp p' hp' heq
+    obtain ⟨ha, hb, -⟩ := mem_labels.mp hp
+    obtain ⟨ha', hb', -⟩ := mem_labels.mp hp'
+    obtain ⟨hpa, hmod⟩ :=
+      (slotAt_eq_iff ζ hζ ha ha' (hex p hp).choose_spec (hex p' hp').choose_spec).mp heq
+    obtain ⟨a, b⟩ := p
+    obtain ⟨a', b'⟩ := p'
+    dsimp only at hpa hmod ha hb ha' hb'
+    subst hpa
+    obtain rfl : b = b' := Nat.ModEq.eq_of_lt_of_lt hmod hb hb'
+    rfl
+  · intro v hv
+    obtain ⟨a, b, ha, hcop, hslot⟩ := exists_slotAt_of_ord_neg ζ hζ ((hS v).mp hv)
+    have hg : 0 < Nat.gcd a (N / a) := gcd_pos_of_dvd ha
+    have hmem : (⟨a, b % Nat.gcd a (N / a)⟩ : Σ _ : ℕ, ℕ) ∈ labels N := by
+      refine mem_labels.mpr ⟨ha, Nat.mod_lt _ hg, ?_⟩
+      change Nat.Coprime (Nat.gcd a (N / a)) (b % Nat.gcd a (N / a))
+      rw [Nat.coprime_iff_gcd_eq_one, Nat.gcd_comm (Nat.gcd a (N / a)) (b % Nat.gcd a (N / a)),
+        ← Nat.gcd_rec]
+      exact Nat.coprime_iff_gcd_eq_one.mp hcop
+    refine ⟨⟨a, b % Nat.gcd a (N / a)⟩, hmem, ?_⟩
+    exact (slotAt_eq_iff ζ hζ ha ha (hex _ hmem).choose_spec hslot).mpr
+      ⟨rfl, Nat.mod_modEq _ _⟩
+
+end S_ModularCurve_card_eq_cuspCount_of_forall_mem_iff_ord_jBar_neg
+end P2MW
+export P2MW.S_ModularCurve_card_eq_cuspCount_of_forall_mem_iff_ord_jBar_neg (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.card_eq_cuspCount_of_forall_mem_iff_ord_jBar_neg (N : ℕ) [NeZero N]
+    (S : Finset (AlgebraicCurve.Place (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar
+      N)))
+    (hS : ∀ v, v ∈ S ↔ v.ord (ModularCurve.jBar N) < 0) :
+    S.card = ModularCurve.cuspCount N :=
+  solution N S hS
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_card_eq_natCard_moduliPoint_j_eq_of_EMD.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_card_eq_natCard_moduliPoint_j_eq_of_EMD.lean
new file mode 100644
index 0000000000..f51222e939
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_card_eq_natCard_moduliPoint_j_eq_of_EMD.lean
@@ -0,0 +1,105 @@
+/-
+Based on Prove2Me node ModularCurve.card_eq_natCard_moduliPoint_j_eq_of_EMD
+(02d83ff4-bc05-5a26-a3ca-b2dc3f1a9209) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4ab35182-e427-547b-bfdb-9a2962d7f2df
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EMD
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_card_eq_natCard_quot_samePlace_of_forall_mem_iff_pos_ord
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_natCard_quot_samePlace_eq_natCard_quot_sameOrbit_of_EMD
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_quot_sameOrbit_cycSub_eq_natCard_moduliPoint_j_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Places above j=j₀ count moduli points with that j-invariant
+
+Theorem statement: `ModularCurve.card_eq_natCard_moduliPoint_j_eq_of_EMD`
+(`02d83ff4-bc05-5a26-a3ca-b2dc3f1a9209`), by Claude, 2026-09-05.
+
+Proof: submission `4ab35182-e427-547b-bfdb-9a2962d7f2df`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and let $j_0$ lie in the algebraic closure of $\mathbb{Q}$.
+Assume [`ModularCurve.EMD N j₀`](def/ModularCurve_EMD.html#L46): there is a Weierstrass curve $E_0$
+over $\overline{\mathbb{Q}}$ which is elliptic, with $j(E_0)=j_0$, together with a bijection $\Phi$
+from [`ModularCurve.Emb N j₀`](def/ModularCurve_EMD.html#L22) onto [`ModularCurve.CycSub E₀
+N`](def/ModularCurve_EMD.html#L36) — the subgroups of $E_0(\overline{\mathbb{Q}})$ of the form
+$\mathbb{Z}g$ for a point $g$ of additive order exactly $N$ — such that two members $\psi,\psi'$ of
+`Emb N j₀` satisfy `SamePlace`, i.e. there is a single place $w$ of $\overline{\mathbb{Q}}F_N$ with
+`Induces ψ w` and `Induces ψ' w`, precisely when $\Phi\psi$ and $\Phi\psi'$ satisfy `SameOrbit`,
+i.e. are generated by points $g,g'$ with $g'$ the image of $g$ under the inverse of a Weierstrass
+variable change fixing $E_0$. Here $\overline{\mathbb{Q}}F_N$ is `modularFunctionFieldBar N`, the
+subfield of $\overline{\mathbb{Q}}((t))$ generated over $\overline{\mathbb{Q}}$ by the
+coefficientwise images of the field of modular functions of level $N$ (itself generated over
+$\mathbb{Q}$ by the divisor expansions), and a place is a proper valuation subring containing
+$\overline{\mathbb{Q}}$ which is a principal ideal ring, with $\mathrm{ord}$ the associated
+normalised integer valuation. Let $S$ be a finite set of places of $\overline{\mathbb{Q}}F_N$ over
+$\overline{\mathbb{Q}}$ consisting exactly of those $v$ with $\mathrm{ord}_v(\bar\jmath_N - j_0)>0$,
+where $\bar\jmath_N$ is the coefficient-extended $q$-expansion of the modular invariant. Then the
+cardinality of $S$ equals the number of elements $x$ of `ModuliPoint N (AlgebraicClosure ℚ)` — the
+quotient of the pairs (elliptic Weierstrass curve over $\overline{\mathbb{Q}}$, point of order $N$)
+by the relation generated by variable changes combined with multiplication of the marked point by an
+integer coprime to $N$ — with $j(x)=j_0$.
+
+This identifies the points of $X_0(N)$ over $\overline{\mathbb{Q}}$ lying above a given value $j_0$
+of the modular invariant with the isomorphism classes of pairs (elliptic curve, cyclic subgroup of
+order $N$) having that $j$-invariant, conditionally on the embedding–moduli dictionary at $j_0$. It
+is used in the computation of the numbers of elliptic points $\nu_2,\nu_3$ of $X_0(N)$, via the
+fibres above $j=1728$ and $j=0$, and in the construction of divisors for the Riemann–Roch estimates
+on $X_0(N)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_card_eq_natCard_moduliPoint_j_eq_of_EMD.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_card_eq_natCard_moduliPoint_j_eq_of_EMD
+
+theorem solution (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ) (hEMD : ModularCurve.EMD N j₀)
+    (S : Finset (AlgebraicCurve.Place (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar
+      N)))
+    (hS : ∀ v, v ∈ S ↔ 0 < v.ord (ModularCurve.jBar N - algebraMap (AlgebraicClosure ℚ)
+      ↥(ModularCurve.modularFunctionFieldBar N) j₀)) :
+    S.card = Nat.card {x : ModularCurve.ModuliPoint N (AlgebraicClosure ℚ) //
+      ModularCurve.ModuliPoint.j x = j₀} := by
+  obtain ⟨E₀, hE₀, hj, hcard⟩ :=
+    ModularCurve.exists_natCard_quot_samePlace_eq_natCard_quot_sameOrbit_of_EMD N j₀ hEMD
+  have := hE₀
+  rw [ModularCurve.card_eq_natCard_quot_samePlace_of_forall_mem_iff_pos_ord N j₀ S hS, hcard,
+    ModularCurve.natCard_quot_sameOrbit_cycSub_eq_natCard_moduliPoint_j_eq N E₀, hj]
+
+end S_ModularCurve_card_eq_natCard_moduliPoint_j_eq_of_EMD
+end P2MW
+export P2MW.S_ModularCurve_card_eq_natCard_moduliPoint_j_eq_of_EMD (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.card_eq_natCard_moduliPoint_j_eq_of_EMD (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ) (hEMD : ModularCurve.EMD N j₀)
+    (S : Finset (AlgebraicCurve.Place (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar
+      N)))
+    (hS : ∀ v, v ∈ S ↔ 0 < v.ord (ModularCurve.jBar N - algebraMap (AlgebraicClosure ℚ)
+      ↥(ModularCurve.modularFunctionFieldBar N) j₀)) :
+    S.card = Nat.card {x : ModularCurve.ModuliPoint N (AlgebraicClosure ℚ) //
+      ModularCurve.ModuliPoint.j x = j₀} :=
+  solution N j₀ hEMD S hS
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_card_eq_natCard_quot_samePlace_of_forall_mem_iff_pos_ord.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_card_eq_natCard_quot_samePlace_of_forall_mem_iff_pos_ord.lean
new file mode 100644
index 0000000000..b4eb72986c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_card_eq_natCard_quot_samePlace_of_forall_mem_iff_pos_ord.lean
@@ -0,0 +1,365 @@
+/-
+Based on Prove2Me node ModularCurve.card_eq_natCard_quot_samePlace_of_forall_mem_iff_pos_ord
+(5fc523e3-76b1-51ff-b570-943035ffe63a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission cf63113e-acf9-5bd1-830c-2428d82c591d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EMD
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_hasRamBound
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_hasRamBound_natDegree_factorial_of_isRoot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_mem_puiseuxRamSubfield_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_adjoin_jBar_jNBar_eq_top
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_normalized_algHom_jBar_eq_toNat_ord
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_modularPolynomialData
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Places where jmath̄-j₀ vanishes count embedding classes
+
+Theorem statement: `ModularCurve.card_eq_natCard_quot_samePlace_of_forall_mem_iff_pos_ord`
+(`5fc523e3-76b1-51ff-b570-943035ffe63a`), by Claude, 2026-09-05.
+
+Proof: submission `cf63113e-acf9-5bd1-830c-2428d82c591d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and let $j_0$ be an element of $\overline{\mathbb Q}$ (the Lean
+`AlgebraicClosure ℚ`). Write $\overline{\mathbb Q}F_N$ for [`ModularCurve.modularFunctionFieldBar
+N`](def/ModularCurve_ArithmeticGalois.html#L111), the intermediate field of the Laurent series field
+$\overline{\mathbb Q}((q))$ over $\overline{\mathbb Q}$ generated by the coefficientwise images of
+the elements of `modularFunctionFieldFull N`, itself the subfield of $\mathbb Q((q))$ generated over
+$\mathbb Q$ by the divisor expansions attached to level $N$; let $\bar\jmath =$ `jBar N` be the
+$q$-expansion of the modular invariant viewed in $\overline{\mathbb Q}F_N$. A place of
+$\overline{\mathbb Q}F_N$ over $\overline{\mathbb Q}$ is a valuation subring that contains the image
+of $\overline{\mathbb Q}$, is not all of $\overline{\mathbb Q}F_N$ and is a principal ideal ring;
+$v.\mathrm{ord}$ denotes the associated normalised integer valuation. Let $S$ be a finite set of
+such places, and assume that a place $v$ lies in $S$ precisely when $v.\mathrm{ord}(\bar\jmath -
+j_0) > 0$. Then the cardinality of $S$ equals the number of elements of the quotient of
+[`ModularCurve.Emb N j₀`](def/ModularCurve_EMD.html#L22) — the set of $\overline{\mathbb Q}$-algebra
+homomorphisms $\psi : \overline{\mathbb Q}F_N \to$ `HahnSeries ℚ (AlgebraicClosure ℚ)` (Hahn series
+with rational exponents) satisfying $\psi(\bar\jmath) = j_0 + t$ — by the relation `SamePlace` on
+the underlying homomorphisms: $\psi \sim \psi'$ when there is one place $w$ and positive rationals
+$g, g'$ with $w.\mathrm{ord}(x)\, g = \operatorname{order}(\psi x)$ and $w.\mathrm{ord}(x)\, g' =
+\operatorname{order}(\psi' x)$ for all $x$.
+
+This is the function-field form of the classical description of the points of $X_0(N)$ lying over a
+given $j$-invariant as classes of normalised Puiseux embeddings of the modular function field, the
+places being counted with multiplicity through the order of vanishing of $\bar\jmath - j_0$. It
+feeds the comparison
+[`ModularCurve.card_eq_natCard_moduliPoint_j_eq_of_EMD`]
+(thm.html#ModularCurve.card_eq_natCard_moduliPoint_j_eq_of_EMD)
+between this count of places and the moduli-theoretic count of points with prescribed $j$-invariant.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_card_eq_natCard_quot_samePlace_of_forall_mem_iff_pos_ord.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_card_eq_natCard_quot_samePlace_of_forall_mem_iff_pos_ord
+
+
+noncomputable section
+
+open ModularCurve AlgebraicCurve IntermediateField Polynomial
+
+namespace S12P
+
+variable (N : ℕ) [NeZero N]
+
+abbrev jb : ↥(modularFunctionFieldBar N) :=
+  ⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+    (jq_mem_full N)⟩
+
+abbrev jNb : ↥(modularFunctionFieldBar N) :=
+  ⟨coeffEmb (AlgebraicClosure ℚ) (qExpand ℚ N jq),
+    coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jqd_mem_full N (dvd_refl N))⟩
+
+theorem eval₂_Phi_jb_jNb (data : ModularPolynomialData N) :
+    data.Φ.eval₂ (Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N)) (jb N))
+      (jNb N)
+      = 0 := by
+  apply Subtype.ext
+  have hval : ((modularFunctionFieldBar N).toSubfield.subtype).comp
+      (Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N)) (jb N))
+      = (coeffEmb (AlgebraicClosure ℚ)).comp evalAtJ := by
+    refine Polynomial.ringHom_ext (fun z => by simp) ?_
+    change ((Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N)) (jb N) X :
+        ↥(modularFunctionFieldBar N)) : LaurentSeries (AlgebraicClosure ℚ)) = coeffEmb
+          (AlgebraicClosure ℚ) (evalAtJ X)
+    rw [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X, evalAtJ_X]
+  have h0 := congrArg (coeffEmb (AlgebraicClosure ℚ)) data.eval_eq_zero
+  rw [map_zero, Polynomial.hom_eval₂, ← hval] at h0
+  rw [ZeroMemClass.coe_zero, ← h0]
+  change ((modularFunctionFieldBar N).toSubfield.subtype) _ = _
+  rw [Polynomial.hom_eval₂]
+  rfl
+
+section Hahn
+
+variable {e : ℕ}
+
+theorem hasRamBound_of_one (he : 0 < e) {y : HahnSeries ℚ (AlgebraicClosure ℚ)}
+    (hy : HahnSeries.HasRamBound 1 y) : HahnSeries.HasRamBound e y := by
+  intro g hg
+  obtain ⟨k, hk⟩ := hy hg
+  refine ⟨k * e, ?_⟩
+  simp only [Nat.cast_one, div_one] at hk
+  have he' : (e : ℚ) ≠ 0 := Nat.cast_ne_zero.mpr he.ne'
+  rw [← hk]; push_cast; field_simp
+
+theorem hasRamBound_C (a : AlgebraicClosure ℚ) :
+    HahnSeries.HasRamBound 1 (HahnSeries.C a : HahnSeries ℚ (AlgebraicClosure ℚ)) := by
+  intro g hg
+  have : g ∈ ({0} : Set ℚ) := HahnSeries.support_single_subset (a := (0 : ℚ)) (r := a) hg
+  rw [Set.mem_singleton_iff] at this
+  exact ⟨0, by simp [this]⟩
+
+theorem hasRamBound_C_add_single (a : AlgebraicClosure ℚ) :
+    HahnSeries.HasRamBound 1
+      (HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)) := by
+  intro g hg
+  rcases (HahnSeries.support_add_subset (x := HahnSeries.C a)
+      (y := HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ))) hg with h | h
+  · exact hasRamBound_C a h
+  · have : g ∈ ({1} : Set ℚ) :=
+      HahnSeries.support_single_subset (a := (1 : ℚ)) (r := (1 : AlgebraicClosure ℚ)) h
+    rw [Set.mem_singleton_iff] at this
+    exact ⟨1, by simp [this]⟩
+
+theorem algebraMap_hahn_eq_C (a : AlgebraicClosure ℚ) :
+    algebraMap (AlgebraicClosure ℚ) (HahnSeries ℚ (AlgebraicClosure ℚ)) a = HahnSeries.C a := by
+  rw [HahnSeries.algebraMap_apply']; simp
+
+theorem eval₂RingHom_mem_puiseuxRamSubfield_one (y : HahnSeries ℚ (AlgebraicClosure ℚ))
+    (hy : HahnSeries.HasRamBound 1 y) (q : Polynomial ℤ) :
+    Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ))) y q
+      ∈ HahnSeries.puiseuxRamSubfield (AlgebraicClosure ℚ) (e := 1) one_pos := by
+  rw [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_eq_sum_range]
+  refine Subfield.sum_mem _ (fun i _ => Subfield.mul_mem _ ?_ (Subfield.pow_mem _ ?_ _))
+  · exact intCast_mem _ _
+  · exact (HahnSeries.mem_puiseuxRamSubfield_iff one_pos).mpr hy
+
+end Hahn
+
+theorem exists_forall_hasRamBound (j₀ : AlgebraicClosure ℚ)
+    (ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ] HahnSeries ℚ (AlgebraicClosure ℚ))
+    (hψ : ψ (jb N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)) :
+    ∃ e : ℕ, 0 < e ∧ ∀ z, HahnSeries.HasRamBound e (ψ z) := by
+  obtain ⟨data⟩ := ModularCurve.nonempty_modularPolynomialData N
+  set P : Polynomial (HahnSeries ℚ (AlgebraicClosure ℚ)) :=
+    data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ)))
+      (HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ))) with hPdef
+  have hPmonic : P.Monic := data.monic.map _
+  have hP0 : P ≠ 0 := hPmonic.ne_zero
+  have hcoeff : ∀ i : ℕ, HahnSeries.HasRamBound 1 (P.coeff i) := by
+    intro i
+    rw [hPdef, Polynomial.coeff_map]
+    exact (HahnSeries.mem_puiseuxRamSubfield_iff one_pos).mp
+      (eval₂RingHom_mem_puiseuxRamSubfield_one _ (hasRamBound_C_add_single j₀) _)
+  have hroot : P.IsRoot (ψ (jNb N)) := by
+    rw [Polynomial.IsRoot, hPdef, Polynomial.eval_map, ← hψ]
+    have hcomp : Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ))) (ψ
+      (jb N))
+        = (ψ.toRingHom).comp (Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N))
+          (jb N)) := by
+      refine Polynomial.ringHom_ext (fun z => by simp) ?_
+      simp
+    rw [hcomp]
+    have h := (Polynomial.hom_eval₂ data.Φ
+      (Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N)) (jb N)) ψ.toRingHom
+        (jNb N)).symm
+    rw [eval₂_Phi_jb_jNb N data, map_zero] at h
+    simpa using h
+  have hbN := HahnSeries.hasRamBound_natDegree_factorial_of_isRoot hP0 hcoeff hroot
+  set e := P.natDegree.factorial with hedef
+  have he : 0 < e := Nat.factorial_pos _
+  refine ⟨e, he, ?_⟩
+  let S := HahnSeries.puiseuxRamSubfield (AlgebraicClosure ℚ) (e := e) he
+  have hS : ∀ y, y ∈ S ↔ HahnSeries.HasRamBound e y :=
+    fun y => HahnSeries.mem_puiseuxRamSubfield_iff he
+  let T : IntermediateField (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+    (S.comap ψ.toRingHom).toIntermediateField (fun a => by
+      change ψ (algebraMap (AlgebraicClosure ℚ) _ a) ∈ S
+      rw [ψ.commutes, hS, algebraMap_hahn_eq_C]
+      exact hasRamBound_of_one he (hasRamBound_C a))
+  have hjb : jb N ∈ T := by
+    change ψ (jb N) ∈ S
+    rw [hψ, hS]
+    exact hasRamBound_of_one he (hasRamBound_C_add_single j₀)
+  have hjNb : jNb N ∈ T := by
+    change ψ (jNb N) ∈ S
+    rw [hS]; exact hbN
+  have htop := ModularCurve.adjoin_jBar_jNBar_eq_top (AlgebraicClosure ℚ) N
+  have hle : (⊤ : IntermediateField (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)) ≤ T := by
+    rw [← htop, IntermediateField.adjoin_le_iff]
+    intro z hz
+    rcases hz with rfl | rfl
+    · exact hjb
+    · exact hjNb
+  intro z
+  exact (hS _).mp (hle IntermediateField.mem_top)
+
+omit [NeZero N] in
+theorem mem_iff_ord_nonneg (w : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N))
+    {x : ↥(modularFunctionFieldBar N)} (hx : x ≠ 0) :
+    x ∈ w.toValuationSubring ↔ 0 ≤ w.ord x := by
+  rw [Place.mem_iff_adicValuation_le_one, Place.ord, neg_nonneg,
+    WithZero.log_le_iff_le_exp (w.adicValuation_ne_zero hx), WithZero.exp_zero]
+
+theorem induces_unique
+    {ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ] HahnSeries ℚ (AlgebraicClosure ℚ)}
+    {w w' : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)}
+    (hw : Induces ψ w) (hw' : Induces ψ w') : w = w' := by
+  obtain ⟨g, hg, h⟩ := hw
+  obtain ⟨g', hg', h'⟩ := hw'
+  have key : ∀ x, 0 ≤ w.ord x ↔ 0 ≤ w'.ord x := by
+    intro x
+    have hx := h x
+    rw [← h' x] at hx
+    constructor
+    · intro h0
+      have : 0 ≤ (w'.ord x : ℚ) * g' := by rw [← hx]; positivity
+      exact_mod_cast nonneg_of_mul_nonneg_left this hg'
+    · intro h0
+      have : 0 ≤ (w.ord x : ℚ) * g := by rw [hx]; positivity
+      exact_mod_cast nonneg_of_mul_nonneg_left this hg
+  apply Place.ext
+  ext x
+  rcases eq_or_ne x 0 with rfl | hx
+  · simp [zero_mem]
+  · rw [mem_iff_ord_nonneg N w hx, mem_iff_ord_nonneg N w' hx, key]
+
+theorem pos_ord_of_induces (j₀ : AlgebraicClosure ℚ) (ψ : Emb N j₀)
+    {w : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)} (hw : Induces ψ.1 w) :
+    0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) j₀) := by
+  obtain ⟨g, hg, h⟩ := hw
+  have hx := h (jBar N - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) j₀)
+  rw [map_sub, ψ.2, AlgHom.commutes, algebraMap_hahn_eq_C, add_sub_cancel_left,
+    HahnSeries.order_single (one_ne_zero)] at hx
+  have : (0 : ℚ) < (w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) j₀)
+    : ℚ) * g :=
+    by
+    rw [hx]; exact_mod_cast one_pos
+  exact_mod_cast pos_of_mul_pos_left this hg.le
+
+theorem exists_induces (j₀ : AlgebraicClosure ℚ) (ψ : Emb N j₀) :
+    ∃ w : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N), Induces ψ.1 w := by
+  obtain ⟨e, he, hall⟩ := exists_forall_hasRamBound N j₀ ψ.1 ψ.2
+  have hnt : ∃ x : ↥(modularFunctionFieldBar N), (ψ.1 x).order ≠ 0 := by
+    refine ⟨jBar N - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) j₀, ?_⟩
+    rw [map_sub, ψ.2, AlgHom.commutes, algebraMap_hahn_eq_C, add_sub_cancel_left,
+      HahnSeries.order_single (one_ne_zero)]
+    exact one_ne_zero
+  obtain ⟨w, g, hg, h⟩ :=
+    AlgebraicCurve.Place.exists_ord_mul_eq_order_of_hasRamBound ψ.1 he hall hnt
+  exact ⟨w, g, hg, h⟩
+
+theorem nonempty_emb_induces (j₀ : AlgebraicClosure ℚ)
+    (w : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N))
+    (hw : 0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) j₀)) :
+    ∃ ψ : Emb N j₀, Induces ψ.1 w := by
+  have hcard := ModularCurve.natCard_normalized_algHom_jBar_eq_toNat_ord N j₀ w hw
+  have hpos : 0 < Nat.card {ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ]
+      HahnSeries ℚ (AlgebraicClosure ℚ) //
+      ψ (jBar N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ) ∧
+      ∃ g : ℚ, 0 < g ∧ ∀ x, (w.ord x : ℚ) * g = (ψ x).order} := by
+    rw [hcard]; omega
+  obtain ⟨⟨ψ, hψ, hind⟩⟩ := (Nat.card_pos_iff.mp hpos).1
+  exact ⟨⟨ψ, hψ⟩, hind⟩
+
+def placeOf (j₀ : AlgebraicClosure ℚ) (ψ : Emb N j₀) :
+    Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+  (exists_induces N j₀ ψ).choose
+
+theorem induces_placeOf (j₀ : AlgebraicClosure ℚ) (ψ : Emb N j₀) : Induces ψ.1 (placeOf N j₀ ψ) :=
+  (exists_induces N j₀ ψ).choose_spec
+
+theorem placeOf_eq_iff (j₀ : AlgebraicClosure ℚ) (ψ ψ' : Emb N j₀) :
+    placeOf N j₀ ψ = placeOf N j₀ ψ' ↔ SamePlace ψ.1 ψ'.1 := by
+  constructor
+  · intro h
+    exact ⟨placeOf N j₀ ψ, induces_placeOf N j₀ ψ, h ▸ induces_placeOf N j₀ ψ'⟩
+  · rintro ⟨w, h1, h2⟩
+    rw [induces_unique N (induces_placeOf N j₀ ψ) h1, induces_unique N (induces_placeOf N j₀ ψ') h2]
+
+theorem natCard_quot_eq_of_surjective {X Y : Type*} (r : X → X → Prop) (π : X → Y)
+    (hker : ∀ a b, π a = π b ↔ r a b) (hsurj : Function.Surjective π) :
+    Nat.card (Quot r) = Nat.card Y := by
+  refine Nat.card_congr (Equiv.ofBijective (Quot.lift π (fun a b h => (hker a b).mpr h)) ⟨?_, ?_⟩)
+  · intro q q'
+    induction q using Quot.ind with
+    | mk a =>
+      induction q' using Quot.ind with
+      | mk b =>
+        intro h
+        exact Quot.sound ((hker a b).mp h)
+  · intro y
+    obtain ⟨x, rfl⟩ := hsurj y
+    exact ⟨Quot.mk r x, rfl⟩
+
+theorem card_eq_natCard_quot (j₀ : AlgebraicClosure ℚ)
+    (S : Finset (Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)))
+    (hS : ∀ v, v ∈ S ↔ 0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar
+      N) j₀)) :
+    S.card = Nat.card (Quot (fun ψ ψ' : Emb N j₀ => SamePlace ψ.1 ψ'.1)) := by
+  have hmem : ∀ ψ : Emb N j₀, placeOf N j₀ ψ ∈ S := fun ψ =>
+    (hS _).mpr (pos_ord_of_induces N j₀ ψ (induces_placeOf N j₀ ψ))
+  let π : Emb N j₀ → ↥S := fun ψ => ⟨placeOf N j₀ ψ, hmem ψ⟩
+  have hker : ∀ a b, π a = π b ↔ SamePlace a.1 b.1 := fun a b => by
+    rw [Subtype.ext_iff]
+    exact placeOf_eq_iff N j₀ a b
+  have hsurj : Function.Surjective π := by
+    rintro ⟨w, hw⟩
+    obtain ⟨ψ, hψ⟩ := nonempty_emb_induces N j₀ w ((hS w).mp hw)
+    exact ⟨ψ, Subtype.ext (induces_unique N (induces_placeOf N j₀ ψ) hψ)⟩
+  rw [natCard_quot_eq_of_surjective _ π hker hsurj, Nat.card_eq_fintype_card, Fintype.card_coe]
+
+end S12P
+
+end
+
+theorem solution (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ)
+    (S : Finset (AlgebraicCurve.Place (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar
+      N)))
+    (hS : ∀ v, v ∈ S ↔ 0 < v.ord (ModularCurve.jBar N - algebraMap (AlgebraicClosure ℚ)
+      ↥(ModularCurve.modularFunctionFieldBar N) j₀)) :
+    S.card = Nat.card (Quot (fun ψ ψ' : ModularCurve.Emb N j₀ => ModularCurve.SamePlace ψ.1 ψ'.1))
+      := by
+  exact S12P.card_eq_natCard_quot N j₀ S hS
+
+end S_ModularCurve_card_eq_natCard_quot_samePlace_of_forall_mem_iff_pos_ord
+end P2MW
+export P2MW.S_ModularCurve_card_eq_natCard_quot_samePlace_of_forall_mem_iff_pos_ord (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.card_eq_natCard_quot_samePlace_of_forall_mem_iff_pos_ord (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ)
+    (S : Finset (AlgebraicCurve.Place (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar
+      N)))
+    (hS : ∀ v, v ∈ S ↔ 0 < v.ord (ModularCurve.jBar N - algebraMap (AlgebraicClosure ℚ)
+      ↥(ModularCurve.modularFunctionFieldBar N) j₀)) :
+    S.card = Nat.card (Quot (fun ψ ψ' : ModularCurve.Emb N j₀ => ModularCurve.SamePlace ψ.1 ψ'.1))
+      :=
+  solution N j₀ S hS
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_card_projectiveLine_zmod.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_card_projectiveLine_zmod.lean
new file mode 100644
index 0000000000..fc288dfeb8
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_card_projectiveLine_zmod.lean
@@ -0,0 +1,325 @@
+/-
+Based on Prove2Me node ModularCurve.card_projectiveLine_zmod
+(da9cf975-16fa-5474-94c2-d46f76a0f8b3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 11a8109c-fd19-51db-a906-9c36ab7c9eb6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ProjectiveLine
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime_pow
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_mul_of_coprime
+import Mathlib.Data.Nat.Factorization.Induction
+import Mathlib.Data.Nat.Totient
+import Mathlib.Data.ZMod.Units
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# #P¹(ℤ/N)=ψ(N)
+
+Theorem statement: `ModularCurve.card_projectiveLine_zmod` (`da9cf975-16fa-5474-94c2-d46f76a0f8b3`),
+by Claude, 2026-09-05.
+
+Proof: submission `11a8109c-fd19-51db-a906-9c36ab7c9eb6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number with $N \neq 0$. The projective line `ProjectiveLine (ZMod N)` over the
+ring $\mathbb{Z}/N\mathbb{Z}$ is, by definition, the quotient of the unimodular rows over that ring
+by the equivalence relation `unimodularRowSetoid`. The assertion is that the cardinality of this
+quotient, measured by `Nat.card`, equals $\psi(N)$, where `dedekindPsi N` is defined as the sum
+$\sum_{d \mid N,\ d \text{ squarefree}} N/d$ over the squarefree divisors $d$ of $N$ (so
+$\psi(1)=1$, and in general $\psi(N)=N\prod_{p \mid N}(1+p^{-1})$). Since this value is a positive
+natural number, the statement in particular contains the finiteness of
+$\mathbb{P}^1(\mathbb{Z}/N\mathbb{Z})$, `Nat.card` being $0$ for infinite types. The proof cites the
+multiplicativity of $\psi$ on coprime arguments,
+[`ModularCurve.dedekindPsi_mul_of_coprime`](thm.html#ModularCurve.dedekindPsi_mul_of_coprime), and
+its value $\psi(p^k) = p^k + p^{k-1}$ at prime powers with $k \neq 0$,
+[`ModularCurve.dedekindPsi_prime_pow`](thm.html#ModularCurve.dedekindPsi_prime_pow).
+
+This is the classical count of the points of the projective line over $\mathbb{Z}/N\mathbb{Z}$ by
+the Dedekind psi function. It feeds the index formula $[\mathrm{SL}_2(\mathbb{Z}) : \Gamma_0(N)] =
+\psi(N)$ in [`ModularCurve.Gamma0_index`](thm.html#ModularCurve.Gamma0_index) and the companion
+counting statement
+[`ZMod.natCard_isAddCyclic_addSubgroup_prod_eq_dedekindPsi`]
+(thm.html#ZMod.natCard_isAddCyclic_addSubgroup_prod_eq_dedekindPsi).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_card_projectiveLine_zmod.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_card_projectiveLine_zmod
+
+namespace ModularCurve
+p2m_export "ModularCurve" "IsUnimodularRow isUnimodularRow_one_left isUnimodularRow_one_right \
+  ProjectiveLine ProjectiveLine.map dedekindPsi dedekindPsi_one dedekindPsi_prime_pow \
+  dedekindPsi_mul_of_coprime"
+p2m_open "ModularCurve"
+
+section PrimePower
+
+private theorem isUnit_zmod_prime_pow_iff {p k : ℕ} (hp : p.Prime) (hk : k ≠ 0) (z : ZMod (p ^ k)) :
+    IsUnit z ↔ ZMod.castHom (dvd_pow_self p hk) (ZMod p) z ≠ 0 := by
+  have : NeZero (p ^ k) := ⟨pow_ne_zero k hp.pos.ne'⟩
+  have : Fact p.Prime := ⟨hp⟩
+  constructor
+  · intro h hzero
+    exact (h.map (ZMod.castHom (dvd_pow_self p hk) (ZMod p))).ne_zero hzero
+  · intro h
+    by_contra hz
+    apply h
+    have hval : ¬z.val.Coprime (p ^ k) := fun hcop =>
+      hz (by rw [← ZMod.natCast_zmod_val z]; exact (ZMod.isUnit_iff_coprime _ _).mpr hcop)
+    have hdvd : p ∣ z.val := by
+      by_contra hndvd
+      exact hval (((hp.coprime_iff_not_dvd).mpr hndvd).symm.pow_right k)
+    calc ZMod.castHom (dvd_pow_self p hk) (ZMod p) z
+        = ZMod.castHom (dvd_pow_self p hk) (ZMod p) ((z.val : ℕ) : ZMod (p ^ k)) := by
+          rw [ZMod.natCast_zmod_val]
+      _ = ((z.val : ℕ) : ZMod p) := map_natCast _ _
+      _ = 0 := (ZMod.natCast_eq_zero_iff _ _).mpr hdvd
+
+namespace IsUnimodularRow
+p2m_export "ModularCurve.IsUnimodularRow" "map"
+end IsUnimodularRow
+namespace IsUnimodularRow
+p2m_open_scoped "ModularCurve.IsUnimodularRow" in
+private theorem _root_.ModularCurve.IsUnimodularRow.isUnit_or_isUnit {p k : ℕ} (hp : p.Prime)
+    (hk : k ≠ 0)
+    {a c : ZMod (p ^ k)} (h : IsUnimodularRow a c) : IsUnit a ∨ IsUnit c := by
+  have : Fact p.Prime := ⟨hp⟩
+  by_contra hcon
+  rw [not_or] at hcon
+  have ha : ZMod.castHom (dvd_pow_self p hk) (ZMod p) a = 0 := by
+    by_contra hne
+    exact hcon.1 ((isUnit_zmod_prime_pow_iff hp hk a).mpr hne)
+  have hc : ZMod.castHom (dvd_pow_self p hk) (ZMod p) c = 0 := by
+    by_contra hne
+    exact hcon.2 ((isUnit_zmod_prime_pow_iff hp hk c).mpr hne)
+  obtain ⟨x, y, hxy⟩ := h
+  apply_fun ZMod.castHom (dvd_pow_self p hk) (ZMod p) at hxy
+  rw [map_add, map_mul, map_mul, map_one, ha, hc, mul_zero, mul_zero, add_zero] at hxy
+  exact zero_ne_one hxy
+
+end IsUnimodularRow
+p2m_export "ModularCurve" "IsUnimodularRow.isUnit_or_isUnit"
+
+private noncomputable def isUnitSubtypeEquivUnits (M : Type*) [Monoid M] :
+    { z : M // IsUnit z } ≃ Mˣ where
+  toFun z := z.2.unit
+  invFun u := ⟨u, u.isUnit⟩
+  left_inv z := Subtype.ext z.2.unit_spec
+  right_inv u := Units.ext u.isUnit.unit_spec
+
+private theorem card_not_isUnit_zmod_prime_pow {p k : ℕ} (hp : p.Prime) (hk : k ≠ 0) :
+    Nat.card { z : ZMod (p ^ k) // ¬IsUnit z } = p ^ (k - 1) := by
+  have : NeZero (p ^ k) := ⟨pow_ne_zero k hp.pos.ne'⟩
+  classical
+  have hsplit : Nat.card { z : ZMod (p ^ k) // IsUnit z } +
+      Nat.card { z : ZMod (p ^ k) // ¬IsUnit z } = p ^ k := by
+    rw [← Nat.card_sum, Nat.card_congr (Equiv.sumCompl (IsUnit ·)),
+      Nat.card_eq_fintype_card, ZMod.card]
+  have hunits : Nat.card { z : ZMod (p ^ k) // IsUnit z } = (p ^ k).totient := by
+    rw [Nat.card_congr (isUnitSubtypeEquivUnits (ZMod (p ^ k))), Nat.card_eq_fintype_card,
+      ZMod.card_units_eq_totient]
+  have htot : (p ^ k).totient + p ^ (k - 1) = p ^ k := by
+    obtain ⟨j, rfl⟩ : ∃ j, k = j + 1 := ⟨k - 1, by omega⟩
+    have hp1 : p - 1 + 1 = p := Nat.succ_pred_eq_of_pos hp.pos
+    calc (p ^ (j + 1)).totient + p ^ (j + 1 - 1)
+        = p ^ j * (p - 1) + p ^ j := by rw [Nat.totient_prime_pow_succ hp, Nat.add_sub_cancel]
+      _ = p ^ j * (p - 1 + 1) := by ring
+      _ = p ^ j * p := by rw [hp1]
+      _ = p ^ (j + 1) := (pow_succ p j).symm
+  omega
+
+private theorem card_projectiveLine_prime_pow (p k : ℕ) (hp : p.Prime) (hk : k ≠ 0) :
+    Nat.card (ProjectiveLine (ZMod (p ^ k))) = p ^ k + p ^ (k - 1) := by
+  have : NeZero (p ^ k) := ⟨pow_ne_zero k hp.pos.ne'⟩
+  let f : ZMod (p ^ k) ⊕ { z : ZMod (p ^ k) // ¬IsUnit z } → ProjectiveLine (ZMod (p ^ k)) :=
+    fun s => Sum.rec (fun t => ⟦⟨(1, t), isUnimodularRow_one_left t⟩⟧)
+      (fun m => ⟦⟨(m.1, 1), isUnimodularRow_one_right m.1⟩⟧) s
+  have hbij : Function.Bijective f := by
+    constructor
+    · rintro (t | m) (t' | m') hff
+      · obtain ⟨u, h1, h2⟩ := Quotient.exact hff
+        have h1' : (u : ZMod (p ^ k)) * 1 = 1 := h1
+        have h2' : (u : ZMod (p ^ k)) * t = t' := h2
+        rw [mul_one] at h1'
+        rw [h1', one_mul] at h2'
+        exact congrArg Sum.inl h2'
+      · obtain ⟨u, h1, _⟩ := Quotient.exact hff
+        have h1' : (u : ZMod (p ^ k)) * 1 = m'.1 := h1
+        exact absurd (h1' ▸ (u.isUnit.mul isUnit_one)) m'.2
+      · obtain ⟨u, h1, _⟩ := Quotient.exact hff
+        have h1' : (u : ZMod (p ^ k)) * m.1 = 1 := h1
+        exact absurd ⟨⟨m.1, u, (mul_comm m.1 u).trans h1', h1'⟩, rfl⟩ m.2
+      · obtain ⟨u, h1, h2⟩ := Quotient.exact hff
+        have h1' : (u : ZMod (p ^ k)) * m.1 = m'.1 := h1
+        have h2' : (u : ZMod (p ^ k)) * 1 = 1 := h2
+        rw [mul_one] at h2'
+        rw [h2', one_mul] at h1'
+        exact congrArg Sum.inr (Subtype.ext h1')
+    · intro q
+      obtain ⟨v, rfl⟩ := Quotient.exists_rep q
+      by_cases ha : IsUnit v.1.1
+      · refine ⟨Sum.inl ((ha.unit⁻¹ : (ZMod (p ^ k))ˣ) * v.1.2), Quotient.sound ⟨ha.unit, ?_, ?_⟩⟩
+        · change (ha.unit : ZMod (p ^ k)) * 1 = v.1.1
+          rw [mul_one, ha.unit_spec]
+        · change (ha.unit : ZMod (p ^ k)) * ((ha.unit⁻¹ : (ZMod (p ^ k))ˣ) * v.1.2) = v.1.2
+          rw [Units.mul_inv_cancel_left]
+      · have hc : IsUnit v.1.2 := (v.2.isUnit_or_isUnit hp hk).resolve_left ha
+        have hm : ¬IsUnit ((hc.unit⁻¹ : (ZMod (p ^ k))ˣ) * v.1.1) := fun hcon => by
+          have : IsUnit ((hc.unit : ZMod (p ^ k)) * ((hc.unit⁻¹ : (ZMod (p ^ k))ˣ) * v.1.1)) :=
+            hc.unit.isUnit.mul hcon
+          rw [Units.mul_inv_cancel_left] at this
+          exact ha this
+        refine ⟨Sum.inr ⟨(hc.unit⁻¹ : (ZMod (p ^ k))ˣ) * v.1.1, hm⟩,
+          Quotient.sound ⟨hc.unit, ?_, ?_⟩⟩
+        · change (hc.unit : ZMod (p ^ k)) * ((hc.unit⁻¹ : (ZMod (p ^ k))ˣ) * v.1.1) = v.1.1
+          rw [Units.mul_inv_cancel_left]
+        · change (hc.unit : ZMod (p ^ k)) * 1 = v.1.2
+          rw [mul_one, hc.unit_spec]
+  rw [← Nat.card_eq_of_bijective f hbij, Nat.card_sum, Nat.card_eq_fintype_card, ZMod.card,
+    card_not_isUnit_zmod_prime_pow hp hk]
+
+end PrimePower
+
+section CRT
+
+private def crtFst (M N : ℕ) (h : M.Coprime N) : ZMod (M * N) →+* ZMod M :=
+  (RingHom.fst (ZMod M) (ZMod N)).comp (ZMod.chineseRemainder h).toRingHom
+
+private def crtSnd (M N : ℕ) (h : M.Coprime N) : ZMod (M * N) →+* ZMod N :=
+  (RingHom.snd (ZMod M) (ZMod N)).comp (ZMod.chineseRemainder h).toRingHom
+
+private theorem crtFst_apply (M N : ℕ) (h : M.Coprime N) (z : ZMod (M * N)) :
+    crtFst M N h z = (ZMod.chineseRemainder h z).1 :=
+  rfl
+
+private theorem crtSnd_apply (M N : ℕ) (h : M.Coprime N) (z : ZMod (M * N)) :
+    crtSnd M N h z = (ZMod.chineseRemainder h z).2 :=
+  rfl
+
+private theorem card_projectiveLine_mul (M N : ℕ) [NeZero M] [NeZero N] (h : M.Coprime N) :
+    Nat.card (ProjectiveLine (ZMod (M * N))) =
+      Nat.card (ProjectiveLine (ZMod M)) * Nat.card (ProjectiveLine (ZMod N)) := by
+  have : NeZero (M * N) := ⟨mul_ne_zero (NeZero.ne M) (NeZero.ne N)⟩
+  set e := ZMod.chineseRemainder h with he
+  let F : ProjectiveLine (ZMod (M * N)) → ProjectiveLine (ZMod M) × ProjectiveLine (ZMod N) :=
+    fun q => (ProjectiveLine.map (crtFst M N h) q, ProjectiveLine.map (crtSnd M N h) q)
+  have hbij : Function.Bijective F := by
+    constructor
+    · intro q q'
+      refine Quotient.inductionOn₂ q q' ?_
+      intro v w hvw
+      obtain ⟨hM, hN⟩ := Prod.mk.injEq .. ▸ hvw
+      obtain ⟨u₁, h1M, h2M⟩ := Quotient.exact hM
+      obtain ⟨u₂, h1N, h2N⟩ := Quotient.exact hN
+      have h1M' : (u₁ : ZMod M) * crtFst M N h v.1.1 = crtFst M N h w.1.1 := h1M
+      have h2M' : (u₁ : ZMod M) * crtFst M N h v.1.2 = crtFst M N h w.1.2 := h2M
+      have h1N' : (u₂ : ZMod N) * crtSnd M N h v.1.1 = crtSnd M N h w.1.1 := h1N
+      have h2N' : (u₂ : ZMod N) * crtSnd M N h v.1.2 = crtSnd M N h w.1.2 := h2N
+      have hUmul : e.symm (↑u₁, ↑u₂) * e.symm (↑u₁⁻¹, ↑u₂⁻¹) = 1 := by
+        rw [← map_mul, Prod.mk_mul_mk, Units.mul_inv, Units.mul_inv]
+        exact map_one e.symm
+      have hUmul' : e.symm (↑u₁⁻¹, ↑u₂⁻¹) * e.symm (↑u₁, ↑u₂) = 1 :=
+        (mul_comm _ _).trans hUmul
+      have key : ∀ z z' : ZMod (M * N), (u₁ : ZMod M) * (e z).1 = (e z').1 →
+          (u₂ : ZMod N) * (e z).2 = (e z').2 →
+          e.symm (↑u₁, ↑u₂) * z = z' := by
+        intro z z' hz1 hz2
+        apply e.injective
+        rw [map_mul, RingEquiv.apply_symm_apply]
+        calc (((u₁ : ZMod M), (u₂ : ZMod N)) : ZMod M × ZMod N) * e z
+            = (↑u₁ * (e z).1, ↑u₂ * (e z).2) := Prod.mk_mul_mk ..
+          _ = ((e z').1, (e z').2) := by rw [hz1, hz2]
+          _ = e z' := rfl
+      exact Quotient.sound ⟨⟨e.symm (↑u₁, ↑u₂), e.symm (↑u₁⁻¹, ↑u₂⁻¹), hUmul, hUmul'⟩,
+        key v.1.1 w.1.1 h1M' h1N', key v.1.2 w.1.2 h2M' h2N'⟩
+    · rintro ⟨x, y⟩
+      obtain ⟨a, rfl⟩ := Quotient.exists_rep x
+      obtain ⟨b, rfl⟩ := Quotient.exists_rep y
+      obtain ⟨xa, ya, hab⟩ := a.2
+      obtain ⟨xb, yb, hbb⟩ := b.2
+      have hglue : IsUnimodularRow (e.symm (a.1.1, b.1.1)) (e.symm (a.1.2, b.1.2)) := by
+        refine ⟨e.symm (xa, xb), e.symm (ya, yb), ?_⟩
+        rw [← map_mul, ← map_mul, ← map_add, Prod.mk_mul_mk, Prod.mk_mul_mk, Prod.mk_add_mk,
+          hab, hbb]
+        exact map_one e.symm
+      refine ⟨⟦⟨(e.symm (a.1.1, b.1.1), e.symm (a.1.2, b.1.2)), hglue⟩⟧, ?_⟩
+      have e1 : crtFst M N h (e.symm (a.1.1, b.1.1)) = a.1.1 := by
+        rw [crtFst_apply, RingEquiv.apply_symm_apply]
+      have e2 : crtFst M N h (e.symm (a.1.2, b.1.2)) = a.1.2 := by
+        rw [crtFst_apply, RingEquiv.apply_symm_apply]
+      have e3 : crtSnd M N h (e.symm (a.1.1, b.1.1)) = b.1.1 := by
+        rw [crtSnd_apply, RingEquiv.apply_symm_apply]
+      have e4 : crtSnd M N h (e.symm (a.1.2, b.1.2)) = b.1.2 := by
+        rw [crtSnd_apply, RingEquiv.apply_symm_apply]
+      refine congrArg₂ Prod.mk (Quotient.sound ⟨1, ?_, ?_⟩) (Quotient.sound ⟨1, ?_, ?_⟩)
+      · change (1 : ZMod M) * crtFst M N h (e.symm (a.1.1, b.1.1)) = a.1.1
+        rw [one_mul, e1]
+      · change (1 : ZMod M) * crtFst M N h (e.symm (a.1.2, b.1.2)) = a.1.2
+        rw [one_mul, e2]
+      · change (1 : ZMod N) * crtSnd M N h (e.symm (a.1.1, b.1.1)) = b.1.1
+        rw [one_mul, e3]
+      · change (1 : ZMod N) * crtSnd M N h (e.symm (a.1.2, b.1.2)) = b.1.2
+        rw [one_mul, e4]
+  rw [Nat.card_eq_of_bijective F hbij, Nat.card_prod]
+
+end CRT
+
+end ModularCurve
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_card_projectiveLine_zmod.ModularCurve"
+
+theorem solution (N : ℕ) (hN : N ≠ 0) :
+    Nat.card (ProjectiveLine (ZMod N)) = dedekindPsi N := by
+  induction N using Nat.recOnPosPrimePosCoprime with
+  | prime_pow p n hp hn =>
+      rw [card_projectiveLine_prime_pow p n hp hn.ne', dedekindPsi_prime_pow p n hp hn.ne']
+  | zero => exact absurd rfl hN
+  | one =>
+      rw [dedekindPsi_one]
+      have hrep : ∀ q : ProjectiveLine (ZMod 1),
+          q = ⟦⟨((1 : ZMod 1), (0 : ZMod 1)), isUnimodularRow_one_left 0⟩⟧ := by
+        intro q
+        obtain ⟨v, rfl⟩ := Quotient.exists_rep q
+        exact Quotient.sound ⟨1, Subsingleton.elim _ _, Subsingleton.elim _ _⟩
+      rw [Nat.card_eq_one_iff_unique]
+      exact ⟨⟨fun a b => (hrep a).trans (hrep b).symm⟩,
+        ⟨⟦⟨((1 : ZMod 1), (0 : ZMod 1)), isUnimodularRow_one_left 0⟩⟧⟩⟩
+  | coprime a b ha hb hab iha ihb =>
+      have : NeZero a := ⟨by omega⟩
+      have : NeZero b := ⟨by omega⟩
+      rw [card_projectiveLine_mul a b hab, iha (by omega), ihb (by omega),
+        dedekindPsi_mul_of_coprime a b hab]
+
+end S_ModularCurve_card_projectiveLine_zmod
+end P2MW
+export P2MW.S_ModularCurve_card_projectiveLine_zmod (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.card_projectiveLine_zmod (N : ℕ) (hN : N ≠ 0) :
+    Nat.card (ProjectiveLine (ZMod N)) = dedekindPsi N :=
+  solution N hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_card_roots_fibrePoly_of_monic.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_card_roots_fibrePoly_of_monic.lean
new file mode 100644
index 0000000000..da025daec4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_card_roots_fibrePoly_of_monic.lean
@@ -0,0 +1,92 @@
+/-
+Based on Prove2Me node ModularCurve.card_roots_fibrePoly_of_monic
+(d2cfb1f5-95a0-5392-aacf-986af55eb0aa) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c8598e8f-d261-5d61-b28c-6b9d74b0609a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_FibrePoly
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Monic fibres have exactly degΦ roots over ̄ K
+
+Theorem statement: `ModularCurve.card_roots_fibrePoly_of_monic`
+(`d2cfb1f5-95a0-5392-aacf-986af55eb0aa`), by Claude, 2026-09-05.
+
+Proof: submission `c8598e8f-d261-5d61-b28c-6b9d74b0609a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field and let $\Phi$ be a polynomial in one variable whose
+coefficients are themselves polynomials over $\mathbb{Z}$, i.e. $\Phi \in (\mathbb{Z}[X])[Y]$, and
+assume $\Phi$ is monic as such, so that its leading coefficient is the constant polynomial $1 \in
+\mathbb{Z}[X]$. For any point $a \in K$, form the fibre polynomial `fibrePoly` $\Phi\, a \in K[Y]$,
+obtained by applying to each coefficient of $\Phi$ the ring homomorphism $\mathbb{Z}[X] \to K$ that
+sends integers to $K$ along the canonical map and sends $X$ to $a$; concretely, it is $\Phi(a, Y)$
+regarded as a one-variable polynomial over $K$. The assertion is that the multiset of roots of this
+fibre polynomial in $K$, that is the roots counted with their multiplicities, has cardinality equal
+to the degree of $\Phi$ in the variable $Y$. Note that the monicity hypothesis is used both to keep
+the fibre polynomial nonzero and to preserve its degree under specialisation, so the count is the
+full expected one at every point $a$, with no exceptional fibres.
+
+This is the uniform fibre count for a monic correspondence: specialising a monic $\Phi \in
+(\mathbb{Z}[X])[Y]$ at any point of an algebraically closed field leaves a polynomial of unchanged
+degree, all of whose roots lie in the field. It supplies the root count used by
+[`ModularCurve.ModularPolynomialData.mem_of_isRoot_map_j_of_transcendental`]
+(thm.html#ModularCurve.ModularPolynomialData.mem_of_isRoot_map_j_of_transcendental)
+and
+[`ModularCurve.ModularPolynomialData.mem_of_isRoot_map_j_of_transcendental_of_odd`]
+(thm.html#ModularCurve.ModularPolynomialData.mem_of_isRoot_map_j_of_transcendental_of_odd),
+where the roots of the specialised modular polynomial at a transcendental $j$-invariant must be
+exhausted.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_card_roots_fibrePoly_of_monic.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_card_roots_fibrePoly_of_monic
+
+open Polynomial ModularCurve
+
+theorem solution {K : Type*} [Field K] [IsAlgClosed K]
+    {Φ : Polynomial (Polynomial ℤ)} (hΦ : Φ.Monic) (a : K) :
+    Multiset.card (fibrePoly Φ a).roots = Φ.natDegree := by
+  rw [← (IsAlgClosed.splits (fibrePoly Φ a)).natDegree_eq_card_roots]
+  exact hΦ.natDegree_map _
+
+end S_ModularCurve_card_roots_fibrePoly_of_monic
+end P2MW
+export P2MW.S_ModularCurve_card_roots_fibrePoly_of_monic (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Polynomial
+namespace ModularCurve
+theorem card_roots_fibrePoly_of_monic {K : Type*} [Field K] [IsAlgClosed K]
+    {Φ : Polynomial (Polynomial ℤ)} (hΦ : Φ.Monic) (a : K) :
+    Multiset.card (fibrePoly Φ a).roots = Φ.natDegree :=
+  solution hΦ a
+end ModularCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coe_frickeInvolutionFull_eq_of_hasSum_of_gamma0_invariant.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coe_frickeInvolutionFull_eq_of_hasSum_of_gamma0_invariant.lean
new file mode 100644
index 0000000000..96f24cc046
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coe_frickeInvolutionFull_eq_of_hasSum_of_gamma0_invariant.lean
@@ -0,0 +1,1302 @@
+/-
+Based on Prove2Me node ModularCurve.coe_frickeInvolutionFull_eq_of_hasSum_of_gamma0_invariant
+(d98e6416-da3e-517f-9bda-a6513d150a13) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5ba11f28-d12e-5cbd-82f6-1c2dfb1f7451
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Exp
+public import Mathlib.Analysis.Complex.UpperHalfPlane.MoebiusAction
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_AtkinLehner
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.NumberTheory.Cyclotomic.PrimitiveRoots
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import Mathlib.FieldTheory.Galois.Basic
+import Mathlib.GroupTheory.Perm.Fin
+import Mathlib.NumberTheory.ModularForms.EisensteinSeries.Basic
+import Mathlib.NumberTheory.ModularForms.Discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_exists_galoisPerm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_mem_range_coeffEmb_of_forall_coeffMap_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_mem_range_coeffEmb_qExpand_of_mem_inter
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_conj_injective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_mem_range_qExpand_of_qTwist_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_jq_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_E4_cube_div_discriminant_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_mul_laurent
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_heckeMatrix_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_heckeDiagMatrix_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_mem_adjoin_jq_of_hasSum_of_slash_invariant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_perm_gamma0_cosetReps
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_sl2_heckeDiagMatrix_smul_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurent_qParam_coeff_unique
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isFrickeAutFull_frickeInvolutionFull_prime
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Fricke involution sends the ∞-expansion to the 0-expansion
+
+Theorem statement: `ModularCurve.coe_frickeInvolutionFull_eq_of_hasSum_of_gamma0_invariant`
+(`d98e6416-da3e-517f-9bda-a6513d150a13`), by Claude, 2026-09-05.
+
+Proof: submission `5ba11f28-d12e-5cbd-82f6-1c2dfb1f7451`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a prime, let $f,g$ be Laurent series over $\mathbb{Q}$, and let
+$F\colon\mathfrak{H}\to\mathbb{C}$ be a function on the upper half-plane. Assume: (hF) for every
+$\tau$, the family $m\mapsto f_m\,q_1(\tau)^m$ indexed by $m\in\mathbb{Z}$, where $f_m$ is the
+$m$-th coefficient of $f$ mapped into $\mathbb{C}$ and $q_h(\tau)=e^{2\pi i\tau/h}$ is Mathlib's
+`Function.Periodic.qParam`, is summable with sum $F(\tau)$; (hG) for every $\tau$, the family
+$m\mapsto g_m\,q_\ell(\tau)^m$ is summable with sum $F(S\cdot\tau)$, where $S$ is the standard
+involution in $\mathrm{SL}_2(\mathbb{Z})$; (hinv) $F(\gamma\cdot\tau)=F(\tau)$ for all
+$\gamma\in\Gamma_0(\ell)$ and all $\tau$; and (hf) $f$ lies in `modularFunctionFieldFull ℓ`, the
+intermediate field of $\mathbb{Q}((q))$ obtained by adjoining to $\mathbb{Q}$ the set of series
+$q\mapsto$ `qExpand ℚ d jq` for the nonzero divisors $d$ of $\ell$. The conclusion is that applying
+`frickeInvolutionFull ℓ` to the element $\langle f,\mathrm{hf}\rangle$ and taking the underlying
+Laurent series yields exactly $g$. Here `frickeInvolutionFull ℓ` is, by definition, a chosen
+$\mathbb{Q}$-algebra automorphism $\sigma$ of `modularFunctionFieldFull ℓ` satisfying
+`IsFrickeAutFull ℓ σ` — that is, $\sigma(\mathtt{qExpand}\ \mathbb{Q}\ a\
+\mathtt{jq})=\mathtt{qExpand}\ \mathbb{Q}\ b\ \mathtt{jq}$ whenever $ab=\ell$ with $a,b$ nonzero —
+if such a $\sigma$ exists, and the identity automorphism otherwise; existence for primes is supplied
+by
+[`ModularCurve.isFrickeAutFull_frickeInvolutionFull_prime`]
+(thm.html#ModularCurve.isFrickeAutFull_frickeInvolutionFull_prime).
+
+This is the $q$-expansion form of the statement that the Fricke involution $w_\ell$ on the function
+field of $X_0(\ell)$ interchanges the cusps $\infty$ and $0$: a $\Gamma_0(\ell)$-invariant function
+with expansion $f$ at $\infty$ (period $1$) and expansion $g$ at $0$ (period $\ell$) has
+$w_\ell(f)=g$. It is used to identify the Fricke image of modular unit series and to place the
+resulting series in the modular function field, via
+[`ModularCurve.coe_frickeInvolutionFull_modularUnitSeries`]
+(thm.html#ModularCurve.coe_frickeInvolutionFull_modularUnitSeries)
+and
+[`ModularCurve.sharpUnitSeries_mem_modularFunctionField`]
+(thm.html#ModularCurve.sharpUnitSeries_mem_modularFunctionField).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_coe_frickeInvolutionFull_eq_of_hasSum_of_gamma0_invariant.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_coe_frickeInvolutionFull_eq_of_hasSum_of_gamma0_invariant
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology Function Polynomial
+open scoped MatrixGroups
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq jqN modularFunctionField jq_mem jqN_mem \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiGen.conj PhiGen.conj_zero PhiGen.conj_succ \
+  coeffMap coeffMap_coeff coeffEmb coeffEmb_coeff coeffMap_coeffEmb coeffMap_qExpand \
+  coeffEmb_qExpand PhiGen.exists_galoisPerm PhiGen.mem_range_coeffEmb_of_forall_coeffMap_eq \
+  PhiGen.mem_range_coeffEmb_qExpand_of_mem_inter PhiGen.conj_injective \
+  mem_range_qExpand_of_qTwist_eq hasSum_jq_qParam E4_cube_div_discriminant_smul \
+  hasSum_qParam_mul_laurent hasSum_qParam_heckeMatrix_smul hasSum_qParam_heckeDiagMatrix_smul \
+  mem_adjoin_jq_of_hasSum_of_slash_invariant exists_perm_gamma0_cosetReps \
+  exists_sl2_heckeDiagMatrix_smul_eq laurent_qParam_coeff_unique IsFrickeAutFull \
+  frickeInvolutionFull jq_mem_full isFrickeAutFull_frickeInvolutionFull_prime"
+p2m_open "ModularCurve"
+
+namespace QExpN
+
+section Generic
+
+variable {L L' : Type*} [CommRing L] [CommRing L'] {n : ℕ}
+
+def interpPoly (H Y : Fin n → L) : L[X] :=
+  ∑ i, C (H i) * ∏ m ∈ Finset.univ.erase i, (X - C (Y m))
+
+def conjPoly (H : Fin n → L) : L[X] := ∏ i, (X - C (H i))
+
+omit [CommRing L'] in
+lemma prod_erase_perm (e : Equiv.Perm (Fin n)) (G : Fin n → L[X]) (i : Fin n) :
+    ∏ m ∈ Finset.univ.erase i, G (e m) = ∏ m ∈ Finset.univ.erase (e i), G m := by
+  refine Finset.prod_equiv e (fun m => ?_) (fun m _ => rfl)
+  simp [e.injective.eq_iff]
+
+lemma interpPoly_map (φ : L →+* L') (H Y : Fin n → L) :
+    (interpPoly H Y).map φ = interpPoly (φ ∘ H) (φ ∘ Y) := by
+  simp only [interpPoly, Polynomial.map_sum, Polynomial.map_mul, Polynomial.map_C,
+    Polynomial.map_prod,
+    Polynomial.map_sub, Polynomial.map_X, Function.comp_apply]
+
+lemma conjPoly_map (φ : L →+* L') (H : Fin n → L) : (conjPoly H).map φ = conjPoly (φ ∘ H) := by
+  simp only [conjPoly, Polynomial.map_prod, Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C,
+    Function.comp_apply]
+
+omit [CommRing L'] in
+lemma interpPoly_perm (e : Equiv.Perm (Fin n)) (H Y : Fin n → L) :
+    interpPoly (H ∘ e) (Y ∘ e) = interpPoly H Y := by
+  unfold interpPoly
+  simp only [Function.comp_apply]
+  rw [← Equiv.sum_comp e (fun j => C (H j) * ∏ m ∈ Finset.univ.erase j, (X - C (Y m)))]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [prod_erase_perm e (fun m => X - C (Y m)) i]
+
+omit [CommRing L'] in
+lemma conjPoly_perm (e : Equiv.Perm (Fin n)) (H : Fin n → L) : conjPoly (H ∘ e) = conjPoly H := by
+  unfold conjPoly
+  simp only [Function.comp_apply]
+  exact Equiv.prod_comp e (fun j => X - C (H j))
+
+omit [CommRing L'] in
+lemma interpPoly_eval (H Y : Fin n → L) (i₀ : Fin n) :
+    (interpPoly H Y).eval (Y i₀) = H i₀ * ∏ m ∈ Finset.univ.erase i₀, (Y i₀ - Y m) := by
+  unfold interpPoly
+  rw [Polynomial.eval_finsetSum, Finset.sum_eq_single i₀]
+  · simp [Polynomial.eval_prod]
+  · intro i _ hi
+    rw [Polynomial.eval_mul, Polynomial.eval_prod]
+    refine mul_eq_zero_of_right _ (Finset.prod_eq_zero (i := i₀) (by simp [Ne.symm hi]) ?_)
+    simp
+  · intro h; exact absurd (Finset.mem_univ i₀) h
+
+omit [CommRing L'] in
+lemma conjPoly_eval (H : Fin n → L) (i₀ : Fin n) : (conjPoly H).eval (H i₀) = 0 := by
+  unfold conjPoly
+  rw [Polynomial.eval_prod]
+  exact Finset.prod_eq_zero (Finset.mem_univ i₀) (by simp)
+
+omit [CommRing L'] in
+lemma conjPoly_monic [Nontrivial L] (H : Fin n → L) : (conjPoly H).Monic :=
+  Polynomial.monic_prod_of_monic _ _ fun i _ => Polynomial.monic_X_sub_C (H i)
+
+omit [CommRing L'] in
+lemma conjPoly_natDegree [Nontrivial L] [NoZeroDivisors L] (H : Fin n → L) :
+    (conjPoly H).natDegree = n := by
+  unfold conjPoly
+  rw [Polynomial.natDegree_prod _ _ fun i _ => Polynomial.X_sub_C_ne_zero (H i)]
+  simp
+
+lemma eval_eq_sum_coeff {p : L[X]} {N : ℕ} (hN : p.natDegree < N) (x : L) :
+    p.eval x = ∑ k ∈ Finset.range N, p.coeff k * x ^ k := by
+  rw [Polynomial.eval_eq_sum_range' hN]
+
+end Generic
+
+section Slots
+
+variable {K : Type} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+  (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+
+def slotH (f g : LaurentSeries ℚ) : Fin (ℓ + 1) → LaurentSeries K :=
+  Fin.cases (coeffEmb K (qExpand ℚ ℓ f)) (fun b : Fin ℓ => qTwist (ζ ^ (b : ℕ)) (coeffEmb K g))
+
+@[scoped simp] lemma slotH_zero (f g : LaurentSeries ℚ) :
+    slotH ℓ ζ f g 0 = coeffEmb K (qExpand ℚ ℓ f) := by
+  simp [slotH]
+
+@[scoped simp] lemma slotH_succ (f g : LaurentSeries ℚ) (b : Fin ℓ) :
+    slotH ℓ ζ f g b.succ = qTwist (ζ ^ (b : ℕ)) (coeffEmb K g) := by
+  simp [slotH]
+
+def liftPerm (e : Equiv.Perm (Fin ℓ)) :
+    Equiv.Perm (Fin (ℓ + 1)) := Equiv.Perm.decomposeFin.symm (0, e)
+
+omit hℓ in
+@[scoped simp] lemma liftPerm_zero (e : Equiv.Perm (Fin ℓ)) : liftPerm ℓ e 0 = 0 :=
+  Equiv.Perm.decomposeFin_symm_apply_zero 0 e
+
+omit hℓ in
+@[scoped simp] lemma liftPerm_succ (e : Equiv.Perm (Fin ℓ)) (b : Fin ℓ) :
+    liftPerm ℓ e b.succ = (e b).succ := by
+  rw [liftPerm, Equiv.Perm.decomposeFin_symm_apply_succ, Equiv.swap_self, Equiv.refl_apply]
+
+lemma coeffMap_qTwist {R S : Type*} [CommRing R] [CommRing S] (φ : R →+* S) (u : Rˣ)
+    (x : LaurentSeries R) :
+    coeffMap φ (qTwist u x) = qTwist (Units.map (φ : R →* S) u) (coeffMap φ x) := by
+  ext k
+  simp only [coeffMap_coeff, qTwist_coeff, map_mul]
+  congr 1
+  rw [← map_zpow (Units.map (φ : R →* S)) u k, Units.coe_map]
+  rfl
+
+omit hℓ [Algebra ℚ K] in
+lemma units_map_zeta_pow (σ : K →+* K) (e : Equiv.Perm (Fin ℓ))
+    (he : ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e b : Fin ℓ) : ℕ)) (b : Fin ℓ) :
+    Units.map (σ : K →* K) (ζ ^ (b : ℕ)) = ζ ^ ((e b : Fin ℓ) : ℕ) := by
+  ext
+  rw [Units.coe_map, Units.val_pow_eq_pow_val, Units.val_pow_eq_pow_val]
+  exact he b
+
+lemma coeffMap_slotH (f g : LaurentSeries ℚ) (σ : K ≃ₐ[ℚ] K) (e : Equiv.Perm (Fin ℓ))
+    (he : ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e b : Fin ℓ) : ℕ)) (i : Fin (ℓ + 1)) :
+    coeffMap (σ : K →+* K) (slotH ℓ ζ f g i) = slotH ℓ ζ f g (liftPerm ℓ e i) := by
+  refine Fin.cases ?_ (fun b => ?_) i
+  · rw [liftPerm_zero, slotH_zero, coeffMap_coeffEmb]
+  · rw [liftPerm_succ, slotH_succ, slotH_succ, coeffMap_qTwist, coeffMap_coeffEmb,
+      units_map_zeta_pow ℓ ζ (σ : K →+* K) e (fun b => he b) b]
+
+lemma coeffMap_conj (σ : K ≃ₐ[ℚ] K) (e : Equiv.Perm (Fin ℓ))
+    (he : ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e b : Fin ℓ) : ℕ)) (i : Fin (ℓ + 1)) :
+    coeffMap (σ : K →+* K) (PhiGen.conj ℓ ζ i) = PhiGen.conj ℓ ζ (liftPerm ℓ e i) := by
+  refine Fin.cases ?_ (fun b => ?_) i
+  · rw [liftPerm_zero, PhiGen.conj_zero, coeffMap_qExpand, coeffMap_coeffEmb]
+  · rw [liftPerm_succ, PhiGen.conj_succ, PhiGen.conj_succ, coeffMap_qTwist, coeffMap_coeffEmb,
+      units_map_zeta_pow ℓ ζ (σ : K →+* K) e (fun b => he b) b]
+
+include hζ in
+omit hℓ [Algebra ℚ K] in
+lemma zeta_pow_ell : ζ ^ ℓ = 1 := by
+  ext; rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one]
+
+include hζ in
+omit [Algebra ℚ K] in
+lemma zeta_mul_zeta_pow (b : Fin ℓ) : ζ * ζ ^ (b : ℕ) = ζ ^ (((b + 1 : Fin ℓ)) : ℕ) := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  rw [← pow_succ', Fin.val_add, Fin.val_one', Nat.add_mod_mod]
+  conv_lhs => rw [← Nat.div_add_mod ((b : ℕ) + 1) ℓ, pow_add, pow_mul, zeta_pow_ell ℓ ζ hζ, one_pow,
+    one_mul]
+
+include hζ in
+lemma qTwist_slotH (f g : LaurentSeries ℚ) (i : Fin (ℓ + 1)) :
+    qTwist ζ (slotH ℓ ζ f g i) = slotH ℓ ζ f g (liftPerm ℓ (Equiv.addRight (1 : Fin ℓ)) i) := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  refine Fin.cases ?_ (fun b => ?_) i
+  · rw [liftPerm_zero, slotH_zero, coeffEmb_qExpand, qTwist_qExpand, zpow_natCast, zeta_pow_ell ℓ ζ
+      hζ,
+      qTwist_one_apply]
+  · rw [liftPerm_succ, slotH_succ, slotH_succ, qTwist_qTwist, Equiv.coe_addRight, zeta_mul_zeta_pow
+      ℓ ζ hζ]
+
+include hζ in
+lemma qTwist_conj (i : Fin (ℓ + 1)) :
+    qTwist ζ (PhiGen.conj ℓ ζ i) = PhiGen.conj ℓ ζ (liftPerm ℓ (Equiv.addRight (1 : Fin ℓ)) i) := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  refine Fin.cases ?_ (fun b => ?_) i
+  · rw [liftPerm_zero, PhiGen.conj_zero, qTwist_qExpand]
+    congr 1
+    rw [show ((ℓ * ℓ : ℕ) : ℤ) = ((ℓ * ℓ : ℕ) : ℤ) from rfl, zpow_natCast, pow_mul, zeta_pow_ell ℓ ζ
+      hζ, one_pow,
+      qTwist_one_apply]
+  · rw [liftPerm_succ, PhiGen.conj_succ, PhiGen.conj_succ, qTwist_qTwist, Equiv.coe_addRight,
+      zeta_mul_zeta_pow ℓ ζ hζ]
+
+def interpK (f g : LaurentSeries ℚ) :
+    (LaurentSeries K)[X] := interpPoly (slotH ℓ ζ f g) (PhiGen.conj ℓ ζ)
+
+def conjK (f g : LaurentSeries ℚ) : (LaurentSeries K)[X] := conjPoly (slotH ℓ ζ f g)
+
+variable [IsGalois ℚ K] [FiniteDimensional ℚ K]
+
+include hζ in
+theorem exists_interpK_coeff_eq (f g : LaurentSeries ℚ) (k : ℕ) :
+    ∃ ξ : LaurentSeries ℚ, (interpK ℓ ζ f g).coeff k = coeffEmb K (qExpand ℚ ℓ ξ) := by
+  refine PhiGen.mem_range_coeffEmb_qExpand_of_mem_inter ?_ ?_
+  · refine mem_range_qExpand_of_qTwist_eq ℓ ζ hζ _ ?_
+    rw [← Polynomial.coeff_map, interpK, interpPoly_map]
+    have h1 : (⇑(qTwist ζ) ∘ slotH ℓ ζ f g) = slotH ℓ ζ f g ∘ liftPerm ℓ (Equiv.addRight (1 : Fin
+      ℓ)) :=
+      funext fun i => qTwist_slotH ℓ ζ hζ f g i
+    have h2 : (⇑(qTwist ζ) ∘ PhiGen.conj ℓ ζ) = PhiGen.conj ℓ ζ ∘ liftPerm ℓ (Equiv.addRight (1 :
+      Fin ℓ)) :=
+      funext fun i => qTwist_conj ℓ ζ hζ i
+    rw [h1, h2, interpPoly_perm]
+  · refine PhiGen.mem_range_coeffEmb_of_forall_coeffMap_eq
+      (fun c hc => (IsGalois.mem_range_algebraMap_iff_fixed c).mpr hc) fun σ => ?_
+    obtain ⟨e, he⟩ := PhiGen.exists_galoisPerm hζ (σ : K →+* K)
+    rw [← Polynomial.coeff_map, interpK, interpPoly_map]
+    have h1 : (⇑(coeffMap (σ : K →+* K)) ∘ slotH ℓ ζ f g) = slotH ℓ ζ f g ∘ liftPerm ℓ e :=
+      funext fun i => coeffMap_slotH ℓ ζ f g σ e he i
+    have h2 : (⇑(coeffMap (σ : K →+* K)) ∘ PhiGen.conj ℓ ζ) = PhiGen.conj ℓ ζ ∘ liftPerm ℓ e :=
+      funext fun i => coeffMap_conj ℓ ζ σ e he i
+    rw [h1, h2, interpPoly_perm]
+
+include hζ in
+theorem exists_conjK_coeff_eq (f g : LaurentSeries ℚ) (k : ℕ) :
+    ∃ π : LaurentSeries ℚ, (conjK ℓ ζ f g).coeff k = coeffEmb K (qExpand ℚ ℓ π) := by
+  refine PhiGen.mem_range_coeffEmb_qExpand_of_mem_inter ?_ ?_
+  · refine mem_range_qExpand_of_qTwist_eq ℓ ζ hζ _ ?_
+    rw [← Polynomial.coeff_map, conjK, conjPoly_map]
+    have h1 : (⇑(qTwist ζ) ∘ slotH ℓ ζ f g) = slotH ℓ ζ f g ∘ liftPerm ℓ (Equiv.addRight (1 : Fin
+      ℓ)) :=
+      funext fun i => qTwist_slotH ℓ ζ hζ f g i
+    rw [h1, conjPoly_perm]
+  · refine PhiGen.mem_range_coeffEmb_of_forall_coeffMap_eq
+      (fun c hc => (IsGalois.mem_range_algebraMap_iff_fixed c).mpr hc) fun σ => ?_
+    obtain ⟨e, he⟩ := PhiGen.exists_galoisPerm hζ (σ : K →+* K)
+    rw [← Polynomial.coeff_map, conjK, conjPoly_map]
+    have h1 : (⇑(coeffMap (σ : K →+* K)) ∘ slotH ℓ ζ f g) = slotH ℓ ζ f g ∘ liftPerm ℓ e :=
+      funext fun i => coeffMap_slotH ℓ ζ f g σ e he i
+    rw [h1, conjPoly_perm]
+
+end Slots
+
+def RealL (h : ℝ) (A : LaurentSeries ℂ) (F : ℍ → ℂ) : Prop :=
+  ∀ τ : ℍ, HasSum (fun m : ℤ => A.coeff m * 𝕢 h (τ : ℂ) ^ m) (F τ)
+
+namespace RealL
+
+variable {h : ℝ} {A B : LaurentSeries ℂ} {F G : ℍ → ℂ}
+
+lemma add (hA : RealL h A F) (hB : RealL h B G) : RealL h (A + B) (F + G) := fun τ => by
+  simpa [add_mul] using (hA τ).add (hB τ)
+
+lemma neg (hA : RealL h A F) : RealL h (-A) (-F) := fun τ => by
+  simpa [neg_mul] using (hA τ).neg
+
+lemma sub (hA : RealL h A F) (hB : RealL h B G) : RealL h (A - B) (F - G) := fun τ => by
+  simpa [sub_mul] using (hA τ).sub (hB τ)
+
+lemma mul (hh : 0 < h) (hA : RealL h A F) (hB : RealL h B G) : RealL h (A * B) (F * G) := fun τ =>
+  hasSum_qParam_mul_laurent h hh A B F G hA hB τ
+
+lemma single (h : ℝ) (a : ℂ) (n : ℤ) :
+    RealL h (HahnSeries.single n a) (fun τ => a * 𝕢 h (τ : ℂ) ^ n) := fun τ => by
+  refine (hasSum_ite_eq n (a * 𝕢 h (τ : ℂ) ^ n)).congr_fun fun m => ?_
+  by_cases hm : m = n
+  · subst hm; simp
+  · simp [HahnSeries.coeff_single_of_ne hm, hm]
+
+lemma C (h : ℝ) (a : ℂ) : RealL h (HahnSeries.C a) (fun _ => a) := by
+  simpa using single h a 0
+
+lemma one (h : ℝ) : RealL h 1 1 := by
+  simpa [Pi.one_def] using C h 1
+
+lemma zero (h : ℝ) : RealL h 0 0 := fun τ => by simp [hasSum_zero]
+
+lemma congr {A' : LaurentSeries ℂ} {F' : ℍ → ℂ} (hA : RealL h A F) (h1 : A = A')
+    (h2 : ∀ τ, F τ = F' τ) :
+    RealL h A' F' := fun τ => by rw [← h1, ← h2]; exact hA τ
+
+lemma sum {ι : Type} (s : Finset ι) {A : ι → LaurentSeries ℂ} {F : ι → ℍ → ℂ}
+    (hAF : ∀ i ∈ s, RealL h (A i) (F i)) : RealL h (∑ i ∈ s, A i) (fun τ => ∑ i ∈ s, F i τ) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => simpa [Pi.zero_def] using zero h
+  | insert a s ha ih =>
+    have h1 :=
+      (hAF a (Finset.mem_insert_self a s)).add (ih fun i hi => hAF i (Finset.mem_insert_of_mem hi))
+    refine h1.congr (Finset.sum_insert ha).symm fun τ => ?_
+    simp [Finset.sum_insert ha]
+
+lemma prod (hh : 0 < h) {ι : Type} (s : Finset ι) {A : ι → LaurentSeries ℂ} {F : ι → ℍ → ℂ}
+    (hAF : ∀ i ∈ s, RealL h (A i) (F i)) : RealL h (∏ i ∈ s, A i) (fun τ => ∏ i ∈ s, F i τ) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => simpa [Pi.one_def] using one h
+  | insert a s ha ih =>
+    have h1 :=
+      (hAF a (Finset.mem_insert_self a s)).mul hh (ih fun i hi => hAF i (Finset.mem_insert_of_mem
+        hi))
+    refine h1.congr (Finset.prod_insert ha).symm fun τ => ?_
+    simp [Finset.prod_insert ha]
+
+lemma coeff_prod_X_sub_C (hh : 0 < h) {ι : Type} (s : Finset ι) {a : ι → LaurentSeries ℂ}
+    {α : ι → ℍ → ℂ} (haα : ∀ i ∈ s, RealL h (a i) (α i)) (k : ℕ) :
+    RealL h ((∏ i ∈ s, (Polynomial.X - Polynomial.C (a i))).coeff k)
+      (fun τ => (∏ i ∈ s, (Polynomial.X - Polynomial.C (α i τ))).coeff k) := by
+  classical
+  induction s using Finset.induction_on generalizing k with
+  | empty =>
+    simp only [Finset.prod_empty, Polynomial.coeff_one]
+    by_cases hk : k = 0
+    · subst hk; simpa [Pi.one_def] using one h
+    · simpa [hk, Pi.zero_def] using zero h
+  | insert b s hb ih =>
+    have ih' := fun k => ih (fun i hi => haα i (Finset.mem_insert_of_mem hi)) k
+    have hb' := haα b (Finset.mem_insert_self b s)
+    have hA : (∏ i ∈ insert b s, (Polynomial.X - Polynomial.C (a i))) =
+        (∏ i ∈ s, (Polynomial.X - Polynomial.C (a i))) * (Polynomial.X - Polynomial.C (a b)) :=
+      (Finset.prod_insert hb).trans (mul_comm (G := Polynomial (LaurentSeries ℂ)) _ _)
+    have hfun : ∀ τ : ℍ, (∏ i ∈ insert b s, (Polynomial.X - Polynomial.C (α i τ))) =
+        (∏ i ∈ s, (Polynomial.X - Polynomial.C (α i τ))) * (Polynomial.X - Polynomial.C (α b τ)) :=
+      fun τ => (Finset.prod_insert hb).trans (mul_comm (G := Polynomial ℂ) _ _)
+    cases k with
+    | zero =>
+      refine ((ih' 0).mul hh hb').neg.congr ?_ fun τ => ?_
+      · rw [hA, Polynomial.mul_coeff_zero, Polynomial.coeff_sub, Polynomial.coeff_X_zero,
+          Polynomial.coeff_C_zero, zero_sub]
+        exact (mul_neg (α := LaurentSeries ℂ) _ _).symm
+      · simp only [hfun τ, Polynomial.mul_coeff_zero, Pi.neg_apply, Pi.mul_apply,
+          Polynomial.coeff_sub,
+          Polynomial.coeff_X_zero, Polynomial.coeff_C_zero, zero_sub, mul_neg]
+    | succ k =>
+      refine ((ih' k).sub ((ih' (k + 1)).mul hh hb')).congr ?_ fun τ => ?_
+      · rw [hA, Polynomial.coeff_mul_X_sub_C]
+      · simp only [hfun τ, Polynomial.coeff_mul_X_sub_C, Pi.sub_apply, Pi.mul_apply]
+
+lemma interpPoly_coeff (hh : 0 < h) {n : ℕ} {Hs Ys : Fin n → LaurentSeries ℂ} {η υ : Fin n → ℍ → ℂ}
+    (hH : ∀ i, RealL h (Hs i) (η i)) (hY : ∀ i, RealL h (Ys i) (υ i)) (k : ℕ) :
+    RealL h ((interpPoly Hs Ys).coeff k)
+      (fun τ => (interpPoly (fun i => η i τ) (fun i => υ i τ)).coeff k) := by
+  unfold interpPoly
+  have h1 : ∀ i ∈ (Finset.univ : Finset (Fin n)),
+      RealL h ((Polynomial.C (Hs i) * ∏ m ∈ Finset.univ.erase i, (Polynomial.X - Polynomial.C (Ys
+        m))).coeff k)
+        (fun τ => (Polynomial.C (η i τ) *
+          ∏ m ∈ Finset.univ.erase i, (Polynomial.X - Polynomial.C (υ m τ))).coeff k) := by
+    intro i _
+    refine ((hH i).mul hh (coeff_prod_X_sub_C hh (Finset.univ.erase i) (fun m _ => hY m) k)).congr
+      ?_ fun τ => ?_
+    · rw [Polynomial.coeff_C_mul]
+    · simp only [Pi.mul_apply, Polynomial.coeff_C_mul]
+  refine (sum Finset.univ h1).congr ?_ fun τ => ?_
+  · rw [Polynomial.finsetSum_coeff]
+  · simp only [Polynomial.finsetSum_coeff]
+
+lemma conjPoly_coeff (hh : 0 < h) {n : ℕ} {Hs : Fin n → LaurentSeries ℂ} {η : Fin n → ℍ → ℂ}
+    (hH : ∀ i, RealL h (Hs i) (η i)) (k : ℕ) :
+    RealL h ((conjPoly Hs).coeff k) (fun τ => (conjPoly fun i => η i τ).coeff k) :=
+  coeff_prod_X_sub_C hh Finset.univ (fun i _ => hH i) k
+
+end RealL
+
+section Periods
+
+variable (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)]
+
+lemma realL_one_of_realL_qExpand (x : LaurentSeries ℂ) (F : ℍ → ℂ) (hx : RealL ℓ (qExpand ℂ ℓ x) F)
+    :
+    RealL 1 x F := by
+  intro τ
+  have hinj : Function.Injective (fun n : ℤ => (ℓ : ℤ) * n) :=
+    mul_right_injective₀ (by exact_mod_cast hℓ.out.ne_zero)
+  have h := hx τ
+  rw [← hinj.hasSum_iff] at h
+  · refine h.congr_fun fun n => ?_
+    simp only [Function.comp_apply, qExpand_coeff_mul]
+    congr 1
+    rw [zpow_mul, zpow_natCast]
+    congr 1
+    simp only [Periodic.qParam, Complex.ofReal_one, div_one, Complex.ofReal_natCast]
+    rw [← Complex.exp_nat_mul]
+    congr 1
+    field_simp [(Nat.cast_ne_zero.mpr hℓ.out.ne_zero : (ℓ : ℂ) ≠ 0)]
+  · intro m hm
+    rw [qExpand_coeff_of_not_dvd ℓ _ (fun ⟨n, hn⟩ => hm ⟨n, hn.symm⟩), zero_mul]
+
+lemma realL_qExpand_of_realL_one (x : LaurentSeries ℂ) (F : ℍ → ℂ) (hx : RealL 1 x F) :
+    RealL ℓ (qExpand ℂ ℓ x) F := by
+  intro τ
+  have hinj : Function.Injective (fun n : ℤ => (ℓ : ℤ) * n) :=
+    mul_right_injective₀ (by exact_mod_cast hℓ.out.ne_zero)
+  rw [← hinj.hasSum_iff]
+  · refine (hx τ).congr_fun fun n => ?_
+    simp only [Function.comp_apply, qExpand_coeff_mul]
+    congr 1
+    rw [zpow_mul, zpow_natCast]
+    congr 1
+    simp only [Periodic.qParam, Complex.ofReal_one, div_one, Complex.ofReal_natCast]
+    rw [← Complex.exp_nat_mul]
+    congr 1
+    field_simp [(Nat.cast_ne_zero.mpr hℓ.out.ne_zero : (ℓ : ℂ) ≠ 0)]
+  · intro m hm
+    rw [qExpand_coeff_of_not_dvd ℓ _ (fun ⟨n, hn⟩ => hm ⟨n, hn.symm⟩), zero_mul]
+
+def expRoot : ℂ := Complex.exp (2 * Real.pi * Complex.I / ℓ)
+
+lemma isPrimitiveRoot_expRoot : IsPrimitiveRoot (expRoot ℓ) ℓ :=
+  Complex.isPrimitiveRoot_exp ℓ hℓ.out.ne_zero
+
+omit hℓ in
+lemma expRoot_pow_zpow (b : ℕ) (m : ℤ) :
+    (expRoot ℓ ^ b) ^ m = Complex.exp (2 * Real.pi * Complex.I * b * m / ℓ) := by
+  rw [expRoot, ← Complex.exp_nat_mul, ← Complex.exp_int_mul]
+  congr 1
+  ring
+
+omit hℓ in
+lemma qParam_T_pow_smul (b : ℕ) (τ : ℍ) :
+    𝕢 ℓ (((ModularGroup.T ^ b • τ : ℍ)) : ℂ) = expRoot ℓ ^ b * 𝕢 ℓ (τ : ℂ) := by
+  have h := modular_T_zpow_smul τ (b : ℤ)
+  rw [zpow_natCast] at h
+  rw [h, coe_vadd, expRoot, ← Complex.exp_nat_mul]
+  simp only [Periodic.qParam, Complex.ofReal_natCast, Int.cast_natCast]
+  rw [← Complex.exp_add]
+  congr 1
+  ring
+
+omit hℓ in
+lemma realL_twist (A : LaurentSeries ℂ) (G : ℍ → ℂ) (hA : RealL ℓ A G) (b : ℕ) (B : LaurentSeries ℂ)
+    (hB : ∀ m : ℤ, B.coeff m = (expRoot ℓ ^ b) ^ m * A.coeff m) :
+    RealL ℓ B (fun τ => G (ModularGroup.T ^ b • τ)) := by
+  intro τ
+  have h := hA (ModularGroup.T ^ b • τ)
+  refine h.congr_fun fun m => ?_
+  rw [hB m, qParam_T_pow_smul, mul_zpow]
+  ring
+
+end Periods
+
+section Analytic
+
+variable {K : Type} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+  (hζ : IsPrimitiveRoot (ζ : K) ℓ) (σ : K →+* ℂ) (hσ : σ (ζ : K) = expRoot ℓ)
+
+def jt (τ : ℍ) : ℂ := ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ
+
+def jtN (τ : ℍ) : ℂ := jt (ModularForm.heckeDiagMatrix ℓ • τ)
+
+abbrev castC : ℚ →+* ℂ := Rat.castHom ℂ
+
+omit hℓ in
+lemma coeffMap_sigma_coeffEmb (x : LaurentSeries ℚ) :
+    coeffMap σ (coeffEmb K x) = coeffMap castC x := by
+  ext m
+  rw [coeffMap_coeff, coeffEmb_coeff, coeffMap_coeff, eq_ratCast, map_ratCast]
+  rfl
+
+def cosetRep (i : Fin (ℓ + 1)) : SL(2, ℤ) :=
+  Fin.cases (1 : SL(2, ℤ)) (fun b : Fin ℓ => ModularGroup.S * ModularGroup.T ^ (b : ℕ)) i
+
+omit hℓ in
+@[scoped simp] lemma cosetRep_zero : cosetRep ℓ 0 = 1 := by simp [cosetRep]
+omit hℓ in
+@[scoped simp] lemma cosetRep_succ (b : Fin ℓ) :
+    cosetRep ℓ b.succ = ModularGroup.S * ModularGroup.T ^ (b : ℕ) := by
+  simp [cosetRep]
+
+def slotF (F : ℍ → ℂ) (i : Fin (ℓ + 1)) (τ : ℍ) : ℂ := F (cosetRep ℓ i • τ)
+
+def slotJ (i : Fin (ℓ + 1)) (τ : ℍ) : ℂ := jtN ℓ (cosetRep ℓ i • τ)
+
+variable (f g : LaurentSeries ℚ) (F : ℍ → ℂ)
+  (hF : ∀ τ : ℍ, HasSum (fun m : ℤ => ((f.coeff m : ℚ) : ℂ) * 𝕢 1 (τ : ℂ) ^ m) (F τ))
+  (hG : ∀ τ : ℍ, HasSum (fun m : ℤ => ((g.coeff m : ℚ) : ℂ) * 𝕢 ℓ (τ : ℂ) ^ m) (F (ModularGroup.S •
+    τ)))
+
+include hF in
+omit hℓ in
+lemma realL_fC : RealL 1 (coeffMap castC f) F := fun τ => hF τ
+
+include hG in
+omit hℓ in
+lemma realL_gC : RealL ℓ (coeffMap castC g) (fun τ => F (ModularGroup.S • τ)) := fun τ => hG τ
+
+include hF hG hσ in
+lemma realL_slotH (i : Fin (ℓ + 1)) :
+    RealL ℓ (coeffMap σ (slotH ℓ ζ f g i)) (slotF ℓ F i) := by
+  refine Fin.cases ?_ (fun b => ?_) i
+  · have h := realL_qExpand_of_realL_one ℓ _ _ (realL_fC f F hF)
+    refine h.congr ?_ fun τ => ?_
+    · rw [slotH_zero, coeffMap_sigma_coeffEmb, coeffMap_qExpand]
+    · simp [slotF]
+  · have h :=
+      realL_twist ℓ _ _ (realL_gC ℓ g F hG) (b : ℕ) (coeffMap σ (slotH ℓ ζ f g b.succ)) fun m => by
+      rw [slotH_succ, coeffMap_coeff, qTwist_coeff, map_mul, Units.val_zpow_eq_zpow_val, map_zpow₀,
+        Units.val_pow_eq_pow_val, map_pow, hσ, coeffEmb_coeff, eq_ratCast, map_ratCast,
+        coeffMap_coeff]
+      rfl
+    refine h.congr rfl fun τ => ?_
+    simp only [slotF, cosetRep_succ, mul_smul]
+
+lemma coeffMap_conj_zero_eq :
+    coeffMap σ (PhiGen.conj ℓ ζ 0) = qExpand ℂ (ℓ * ℓ) (coeffMap castC jq) := by
+  rw [PhiGen.conj_zero, coeffMap_qExpand, coeffMap_sigma_coeffEmb]
+
+omit hℓ in
+lemma realL_jqC : RealL 1 (coeffMap castC jq) jt := fun τ => hasSum_jq_qParam τ
+
+omit hℓ in
+lemma heckeDiag_smul_S_T_pow_smul [NeZero ℓ] (b : ℕ) (τ : ℍ) :
+    ModularForm.heckeDiagMatrix ℓ • (ModularGroup.S * ModularGroup.T ^ b) • τ =
+      ModularGroup.S • ModularForm.heckeMatrix ℓ b • τ := by
+  have hT : ((ModularGroup.T ^ b : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) = !![1, (b : ℤ); 0, 1] :=
+    by
+    have := ModularGroup.coe_T_zpow (b : ℤ)
+    rwa [zpow_natCast] at this
+  set g : SL(2, ℤ) := ModularGroup.S * ModularGroup.T ^ b with hg
+  have hg' : (g : Matrix (Fin 2) (Fin 2) ℤ) = !![0, -1; 1, (b : ℤ)] := by
+    rw [hg, Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_S, hT]
+    ext i j
+    fin_cases i <;> fin_cases j <;> simp [Matrix.mul_apply, Fin.sum_univ_two]
+  have h00 : g 0 0 = 0 := congrFun (congrFun hg' 0) 0
+  have h01 : g 0 1 = -1 := congrFun (congrFun hg' 0) 1
+  have h10 : g 1 0 = 1 := congrFun (congrFun hg' 1) 0
+  have h11 : g 1 1 = b := congrFun (congrFun hg' 1) 1
+  clear_value g
+  have hmat : ModularForm.heckeDiagMatrix ℓ * Matrix.SpecialLinearGroup.mapGL ℝ g =
+      Matrix.SpecialLinearGroup.mapGL ℝ ModularGroup.S * ModularForm.heckeMatrix ℓ b := by
+    ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp [Matrix.mul_apply, Fin.sum_univ_two, ModularForm.val_heckeDiagMatrix (NeZero.ne ℓ),
+        ModularForm.val_heckeMatrix (NeZero.ne ℓ), ModularGroup.coe_S, h00, h01, h10, h11]
+  have h1 : ModularForm.heckeDiagMatrix ℓ • g • τ =
+      (ModularForm.heckeDiagMatrix ℓ * Matrix.SpecialLinearGroup.mapGL ℝ g) • τ := by
+    rw [mul_smul]; rfl
+  have h2 : ModularGroup.S • ModularForm.heckeMatrix ℓ b • τ =
+      (Matrix.SpecialLinearGroup.mapGL ℝ ModularGroup.S * ModularForm.heckeMatrix ℓ b) • τ := by
+    rw [mul_smul]; rfl
+  rw [h1, h2, hmat]
+
+include hσ in
+lemma realL_conj (i : Fin (ℓ + 1)) : RealL ℓ (coeffMap σ (PhiGen.conj ℓ ζ i)) (slotJ ℓ i) := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  refine Fin.cases ?_ (fun b => ?_) i
+  · intro τ
+    have h := hasSum_qParam_heckeDiagMatrix_smul ℓ (coeffMap castC jq) jt realL_jqC τ
+    rw [coeffMap_conj_zero_eq]
+    simpa [slotJ, jtN] using h
+  · intro τ
+    have h := hasSum_qParam_heckeMatrix_smul ℓ (b : ℕ) (coeffMap castC jq) jt realL_jqC τ
+    have hval : slotJ ℓ b.succ τ = jt (ModularForm.heckeMatrix ℓ (b : ℕ) • τ) := by
+      rw [slotJ, jtN, cosetRep_succ, heckeDiag_smul_S_T_pow_smul]
+      exact E4_cube_div_discriminant_smul ModularGroup.S _
+    rw [hval]
+    refine h.congr_fun fun m => ?_
+    congr 1
+    rw [PhiGen.conj_succ, coeffMap_coeff, qTwist_coeff, map_mul, Units.val_zpow_eq_zpow_val,
+      map_zpow₀,
+      Units.val_pow_eq_pow_val, map_pow, hσ, expRoot_pow_zpow, coeffEmb_coeff, eq_ratCast,
+      map_ratCast,
+      coeffMap_coeff]
+    rfl
+
+def interpFun (k : ℕ) (τ : ℍ) :
+    ℂ := (interpPoly (fun i => slotF ℓ F i τ) (fun i => slotJ ℓ i τ)).coeff k
+
+def conjFun (k : ℕ) (τ : ℍ) : ℂ := (conjPoly fun i => slotF ℓ F i τ).coeff k
+
+variable (hinv : ∀ γ ∈ CongruenceSubgroup.Gamma0 ℓ, ∀ τ : ℍ, F (γ • τ) = F τ)
+
+omit hℓ in
+lemma jtN_smul [NeZero ℓ] (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 ℓ) (τ : ℍ) :
+    jtN ℓ (γ • τ) = jtN ℓ τ := by
+  obtain ⟨γ', hγ', -⟩ := exists_sl2_heckeDiagMatrix_smul_eq ℓ γ hγ
+  rw [jtN, jtN, hγ' τ]
+  exact E4_cube_div_discriminant_smul γ' _
+
+include hinv in
+lemma slots_smul (γ : SL(2, ℤ)) : ∃ e : Equiv.Perm (Fin (ℓ + 1)),
+    (∀ i τ, slotF ℓ F i (γ • τ) = slotF ℓ F (e i) τ) ∧ (∀ i τ, slotJ ℓ i (γ • τ) = slotJ ℓ (e i) τ)
+      := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  obtain ⟨e, he⟩ := exists_perm_gamma0_cosetReps ℓ γ
+  have key : ∀ (i : Fin (ℓ + 1)) (τ : ℍ),
+      cosetRep ℓ i • γ • τ = (cosetRep ℓ i * γ * (cosetRep ℓ (e i))⁻¹) • cosetRep ℓ (e i) • τ := by
+    intro i τ
+    simp only [smul_smul, inv_mul_cancel_right]
+  have he' : ∀ i, cosetRep ℓ i * γ * (cosetRep ℓ (e i))⁻¹ ∈ CongruenceSubgroup.Gamma0 ℓ := he
+  refine ⟨e, fun i τ => ?_, fun i τ => ?_⟩
+  · rw [slotF, slotF, key, hinv _ (he' i)]
+  · rw [slotJ, slotJ, key, jtN_smul ℓ _ (he' i)]
+
+include hinv in
+lemma interpFun_smul (k : ℕ) (γ : SL(2, ℤ)) (τ : ℍ) :
+    interpFun ℓ F k (γ • τ) = interpFun ℓ F k τ := by
+  obtain ⟨e, h1, h2⟩ := slots_smul ℓ F hinv γ
+  unfold interpFun
+  have hH : (fun i => slotF ℓ F i (γ • τ)) = (fun i => slotF ℓ F i τ) ∘ e := funext fun i => h1 i τ
+  have hY : (fun i => slotJ ℓ i (γ • τ)) = (fun i => slotJ ℓ i τ) ∘ e := funext fun i => h2 i τ
+  rw [hH, hY, interpPoly_perm]
+
+include hinv in
+lemma conjFun_smul (k : ℕ) (γ : SL(2, ℤ)) (τ : ℍ) : conjFun ℓ F k (γ • τ) = conjFun ℓ F k τ := by
+  obtain ⟨e, h1, -⟩ := slots_smul ℓ F hinv γ
+  unfold conjFun
+  have hH : (fun i => slotF ℓ F i (γ • τ)) = (fun i => slotF ℓ F i τ) ∘ e := funext fun i => h1 i τ
+  rw [hH, conjPoly_perm]
+
+include hF hG hσ hinv in
+lemma mem_adjoin_of_interpK_coeff_eq (k : ℕ) (ξ : LaurentSeries ℚ)
+    (hξ : (interpK ℓ ζ f g).coeff k = coeffEmb K (qExpand ℚ ℓ ξ)) : ξ ∈ Algebra.adjoin ℚ {jq} := by
+  have h1 : RealL ℓ (coeffMap σ ((interpK ℓ ζ f g).coeff k)) (interpFun ℓ F k) := by
+    have h := RealL.interpPoly_coeff (h := (ℓ : ℝ)) (by exact_mod_cast hℓ.out.pos)
+      (fun i => realL_slotH ℓ ζ σ hσ f g F hF hG i) (fun i => realL_conj ℓ ζ σ hσ i) k
+    refine h.congr ?_ fun τ => rfl
+    rw [← Polynomial.coeff_map, interpK, interpPoly_map]
+    rfl
+  rw [hξ, coeffMap_sigma_coeffEmb, coeffMap_qExpand] at h1
+  have h2 := realL_one_of_realL_qExpand ℓ _ _ h1
+  exact mem_adjoin_jq_of_hasSum_of_slash_invariant ξ (interpFun ℓ F k) h2
+    (fun γ τ => interpFun_smul ℓ F hinv k γ τ)
+
+include hF hG hσ hinv in
+lemma mem_adjoin_of_conjK_coeff_eq (k : ℕ) (π : LaurentSeries ℚ)
+    (hπ : (conjK ℓ ζ f g).coeff k = coeffEmb K (qExpand ℚ ℓ π)) : π ∈ Algebra.adjoin ℚ {jq} := by
+  have h1 : RealL ℓ (coeffMap σ ((conjK ℓ ζ f g).coeff k)) (conjFun ℓ F k) := by
+    have h := RealL.conjPoly_coeff (h := (ℓ : ℝ)) (by exact_mod_cast hℓ.out.pos)
+      (fun i => realL_slotH ℓ ζ σ hσ f g F hF hG i) k
+    refine h.congr ?_ fun τ => rfl
+    rw [← Polynomial.coeff_map, conjK, conjPoly_map]
+    rfl
+  rw [hπ, coeffMap_sigma_coeffEmb, coeffMap_qExpand] at h1
+  have h2 := realL_one_of_realL_qExpand ℓ _ _ h1
+  exact mem_adjoin_jq_of_hasSum_of_slash_invariant π (conjFun ℓ F k) h2
+    (fun γ τ => conjFun_smul ℓ F hinv k γ τ)
+
+end Analytic
+
+section Assembly
+
+variable {K : Type} [Field K] [Algebra ℚ K] [IsGalois ℚ K] [FiniteDimensional ℚ K]
+  (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) ℓ) (σ : K →+* ℂ)
+  (hσ : σ (ζ : K) = expRoot ℓ)
+  (f g : LaurentSeries ℚ) (F : ℍ → ℂ)
+  (hF : ∀ τ : ℍ, HasSum (fun m : ℤ => ((f.coeff m : ℚ) : ℂ) * 𝕢 1 (τ : ℂ) ^ m) (F τ))
+  (hG : ∀ τ : ℍ, HasSum (fun m : ℤ => ((g.coeff m : ℚ) : ℂ) * 𝕢 ℓ (τ : ℂ) ^ m) (F (ModularGroup.S •
+    τ)))
+  (hinv : ∀ γ ∈ CongruenceSubgroup.Gamma0 ℓ, ∀ τ : ℍ, F (γ • τ) = F τ)
+
+def iota : LaurentSeries ℚ →+* LaurentSeries K := (coeffEmb K).comp (qExpand ℚ ℓ)
+
+omit [IsGalois ℚ K] [FiniteDimensional ℚ K] in
+lemma iota_apply (x : LaurentSeries ℚ) : iota (K := K) ℓ x = coeffEmb K (qExpand ℚ ℓ x) := rfl
+
+omit [IsGalois ℚ K] [FiniteDimensional ℚ K] in
+lemma coeffEmb_injective' :
+    Function.Injective (coeffEmb K : LaurentSeries ℚ → LaurentSeries K) := by
+  intro x y h
+  ext m
+  have hm := congrArg (fun z : LaurentSeries K => z.coeff m) h
+  simp only [coeffEmb_coeff] at hm
+  exact (algebraMap ℚ K).injective hm
+
+omit [IsGalois ℚ K] [FiniteDimensional ℚ K] in
+lemma iota_injective : Function.Injective (iota (K := K) ℓ) :=
+  coeffEmb_injective'.comp (qExpand_injective (R := ℚ) ℓ)
+
+omit [IsGalois ℚ K] [FiniteDimensional ℚ K] in
+lemma iota_eq_slotH_zero : iota ℓ f = slotH ℓ ζ f g 0 := by
+  rw [iota_apply, slotH_zero]
+
+omit [IsGalois ℚ K] [FiniteDimensional ℚ K] in
+lemma iota_jqN : iota (K := K) ℓ (jqN ℓ) = PhiGen.conj ℓ ζ 0 := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  rw [iota_apply, jqN, qExpand_qExpand, PhiGen.conj_zero, coeffEmb_qExpand]
+
+def dHat :
+    LaurentSeries K := ∏ m ∈ Finset.univ.erase (0 : Fin (ℓ + 1)), (PhiGen.conj ℓ ζ 0 - PhiGen.conj ℓ
+      ζ m)
+
+include hζ in
+omit [IsGalois ℚ K] [FiniteDimensional ℚ K] in
+lemma dHat_ne_zero : dHat ℓ ζ ≠ 0 := by
+  rw [dHat, Finset.prod_ne_zero_iff]
+  intro m hm h0
+  exact (Finset.ne_of_mem_erase hm) ((PhiGen.conj_injective ℓ ζ hζ (sub_eq_zero.mp h0)).symm)
+
+include hζ in
+lemma exists_sum_eq_mul_dHat (hmem : ∀ (k : ℕ) (ξ : LaurentSeries ℚ),
+      (interpK ℓ ζ f g).coeff k = coeffEmb K (qExpand ℚ ℓ ξ) → ξ ∈ Algebra.adjoin ℚ {jq}) :
+    ∃ x : LaurentSeries ℚ, x ∈ modularFunctionField ℓ ∧ iota ℓ x = iota ℓ f * dHat ℓ ζ := by
+  classical
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  choose ξ hξ using fun k => exists_interpK_coeff_eq ℓ ζ hζ f g k
+  have hadj : Algebra.adjoin ℚ {jq} ≤ (modularFunctionField ℓ).toSubalgebra :=
+    Algebra.adjoin_le (Set.singleton_subset_iff.mpr (jq_mem ℓ))
+  refine ⟨∑ k ∈ Finset.range ((interpK ℓ ζ f g).natDegree + 1), ξ k * jqN ℓ ^ k, ?_, ?_⟩
+  · refine sum_mem fun k _ => mul_mem (hadj (hmem k (ξ k) (hξ k))) (pow_mem (jqN_mem ℓ) k)
+  · rw [map_sum]
+    simp only [map_mul, map_pow, iota_jqN ℓ ζ, iota_apply, ← hξ]
+    rw [← Polynomial.eval_eq_sum_range, interpK, interpPoly_eval, ← slotH_zero ℓ ζ f g, dHat]
+
+include hζ hσ hF hG hinv in
+theorem mem_modularFunctionField_of_data : f ∈ modularFunctionField ℓ := by
+  classical
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  obtain ⟨x, hx, hιx⟩ := exists_sum_eq_mul_dHat ℓ ζ hζ f g
+    (fun k ξ h => mem_adjoin_of_interpK_coeff_eq ℓ ζ σ hσ f g F hF hG hinv k ξ h)
+  have h1F : ∀ τ : ℍ, HasSum (fun m : ℤ => (((1 : LaurentSeries ℚ).coeff m : ℚ) : ℂ) * 𝕢 1 (τ : ℂ) ^
+    m)
+      ((fun _ : ℍ => (1 : ℂ)) τ) := by
+    intro τ
+    have h := RealL.one 1 τ
+    rw [← map_one (coeffMap castC)] at h
+    exact h
+  have h1G : ∀ τ : ℍ, HasSum (fun m : ℤ => (((1 : LaurentSeries ℚ).coeff m : ℚ) : ℂ) * 𝕢 ℓ (τ : ℂ) ^
+    m)
+      ((fun _ : ℍ => (1 : ℂ)) (ModularGroup.S • τ)) := by
+    intro τ
+    have h := RealL.one (ℓ : ℝ) τ
+    rw [← map_one (coeffMap castC)] at h
+    exact h
+  obtain ⟨d, hd, hιd⟩ := exists_sum_eq_mul_dHat ℓ ζ hζ 1 1
+    (fun k ξ h => mem_adjoin_of_interpK_coeff_eq ℓ ζ σ hσ 1 1 (fun _ => 1) h1F h1G (fun _ _ _ =>
+      rfl) k ξ h)
+  rw [map_one, one_mul] at hιd
+  have hd0 : d ≠ 0 := by
+    rintro rfl
+    exact dHat_ne_zero ℓ ζ hζ (by rw [map_zero] at hιd; exact hιd.symm)
+  have hfd : f * d = x := iota_injective (K := K) ℓ (by rw [map_mul, hιd, hιx])
+  have hf : f = x * d⁻¹ := by rw [← hfd, mul_inv_cancel_right₀ hd0]
+  rw [hf]
+  exact mul_mem hx (inv_mem hd)
+
+include hζ hσ hF hG hinv in
+theorem isIntegral_of_data : IsIntegral (Algebra.adjoin ℚ {jq}) f := by
+  classical
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  choose π hπ using fun k => exists_conjK_coeff_eq ℓ ζ hζ f g k
+  have hπmem : ∀ k, π k ∈ Algebra.adjoin ℚ {jq} := fun k =>
+    mem_adjoin_of_conjK_coeff_eq ℓ ζ σ hσ f g F hF hG hinv k (π k) (hπ k)
+  have hdeg : (conjK ℓ ζ f g).natDegree = ℓ + 1 := conjPoly_natDegree _
+  have hmon : (conjK ℓ ζ f g).Monic := conjPoly_monic _
+  let p : Polynomial (Algebra.adjoin ℚ {jq}) :=
+    ∑ k ∈ Finset.range (ℓ + 2),
+      Polynomial.C (⟨π k, hπmem k⟩ : Algebra.adjoin ℚ {jq}) * (Polynomial.X : Polynomial
+        (Algebra.adjoin ℚ {jq})) ^ k
+  have hcoeffp : ∀ n, p.coeff n = if n < ℓ + 2 then (⟨π n, hπmem n⟩ : Algebra.adjoin ℚ {jq}) else 0
+    :=
+    by
+    intro n
+    simp only [p, Polynomial.finsetSum_coeff, Polynomial.coeff_C_mul, Polynomial.coeff_X_pow,
+      mul_ite, mul_one,
+      mul_zero]
+    rw [Finset.sum_ite_eq]
+    simp only [Finset.mem_range]
+  have hmapmap : (p.map (algebraMap (Algebra.adjoin ℚ {jq}) (LaurentSeries ℚ))).map (iota ℓ) = conjK
+    ℓ ζ f g :=
+    by
+    rw [Polynomial.map_map]
+    simp only [p, Polynomial.map_sum, Polynomial.map_mul, Polynomial.map_pow, Polynomial.map_C,
+      Polynomial.map_X,
+      RingHom.comp_apply]
+    have hk : ∀ k, (iota (K := K) ℓ) ((algebraMap (Algebra.adjoin ℚ {jq}) (LaurentSeries ℚ)) ⟨π k,
+      hπmem k⟩) =
+        (conjK ℓ ζ f g).coeff k :=
+      fun k => (hπ k).symm
+    simp only [hk]
+    exact (Polynomial.as_sum_range_C_mul_X_pow' _ (by rw [hdeg]; omega)).symm
+  refine ⟨p, ?_, ?_⟩
+  · refine Polynomial.monic_of_natDegree_le_of_coeff_eq_one (ℓ + 1) ?_ ?_
+    · exact Polynomial.natDegree_sum_le_of_forall_le _ _ fun k hk =>
+        (Polynomial.natDegree_C_mul_X_pow_le _ k).trans (Nat.lt_succ_iff.mp (Finset.mem_range.mp
+          hk))
+    · rw [hcoeffp, ite_eq_left (by omega)]
+      refine Subtype.ext ?_
+      apply iota_injective (K := K) ℓ
+      rw [iota_apply, ← hπ (ℓ + 1), ← hdeg, hmon.coeff_natDegree]
+      exact (map_one (iota (K := K) ℓ)).symm
+  · rw [Polynomial.eval₂_eq_eval_map]
+    apply iota_injective (K := K) ℓ
+    rw [map_zero]
+    change (iota ℓ) (Polynomial.eval₂ (RingHom.id _) f
+      ((p.map (algebraMap (Algebra.adjoin ℚ {jq}) (LaurentSeries ℚ))))) = 0
+    rw [Polynomial.hom_eval₂, Polynomial.eval₂_eq_eval_map, ← Polynomial.map_map, Polynomial.map_id,
+      hmapmap,
+      iota_eq_slotH_zero ℓ ζ f g, conjK]
+    exact conjPoly_eval _ 0
+
+end Assembly
+
+section Main
+
+variable (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)]
+
+def sigma (ζ : (CyclotomicField ℓ ℚ)ˣ) (hζ : IsPrimitiveRoot (ζ : CyclotomicField ℓ ℚ) ℓ) :
+    CyclotomicField ℓ ℚ →+* ℂ :=
+  letI : Algebra ℚ (CyclotomicField ℓ ℚ) := CyclotomicField.algebra ℓ ℚ
+  haveI : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  haveI := CyclotomicField.isCyclotomicExtension ℓ ℚ
+  ((hζ.embeddingsEquivPrimitiveRoots ℂ (Polynomial.cyclotomic.irreducible_rat hℓ.out.pos)).symm
+    ⟨expRoot ℓ, (mem_primitiveRoots hℓ.out.pos).mpr (isPrimitiveRoot_expRoot ℓ)⟩).toRingHom
+
+lemma sigma_zeta (ζ : (CyclotomicField ℓ ℚ)ˣ) (hζ : IsPrimitiveRoot (ζ : CyclotomicField ℓ ℚ) ℓ) :
+    sigma ℓ ζ hζ (ζ : CyclotomicField ℓ ℚ) = expRoot ℓ := by
+  let : Algebra ℚ (CyclotomicField ℓ ℚ) := CyclotomicField.algebra ℓ ℚ
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  have := CyclotomicField.isCyclotomicExtension ℓ ℚ
+  let e := hζ.embeddingsEquivPrimitiveRoots ℂ (Polynomial.cyclotomic.irreducible_rat hℓ.out.pos)
+  let r : primitiveRoots ℓ ℂ :=
+    ⟨expRoot ℓ, (mem_primitiveRoots hℓ.out.pos).mpr (isPrimitiveRoot_expRoot ℓ)⟩
+  have h := IsPrimitiveRoot.embeddingsEquivPrimitiveRoots_apply_coe hζ ℂ
+    (Polynomial.cyclotomic.irreducible_rat hℓ.out.pos) (e.symm r)
+  rw [Equiv.apply_symm_apply] at h
+  exact h.symm
+
+variable (f g : LaurentSeries ℚ) (F : ℍ → ℂ)
+  (hF : ∀ τ : ℍ, HasSum (fun m : ℤ => ((f.coeff m : ℚ) : ℂ) * 𝕢 1 (τ : ℂ) ^ m) (F τ))
+  (hG : ∀ τ : ℍ, HasSum (fun m : ℤ => ((g.coeff m : ℚ) : ℂ) * 𝕢 ℓ (τ : ℂ) ^ m) (F (ModularGroup.S •
+    τ)))
+  (hinv : ∀ γ ∈ CongruenceSubgroup.Gamma0 ℓ, ∀ τ : ℍ, F (γ • τ) = F τ)
+
+include hF hG hinv in
+theorem mem_modularFunctionField : f ∈ modularFunctionField ℓ := by
+  have : NeZero ((ℓ : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr hℓ.out.ne_zero⟩
+  have hcyc : IsCyclotomicExtension {ℓ} ℚ (CyclotomicField ℓ ℚ) :=
+    CyclotomicField.isCyclotomicExtension (n := ℓ) (K := ℚ)
+  have : FiniteDimensional ℚ (CyclotomicField ℓ ℚ) :=
+    IsCyclotomicExtension.finiteDimensional {ℓ} ℚ (CyclotomicField ℓ ℚ)
+  have : IsGalois ℚ (CyclotomicField ℓ ℚ) :=
+    IsCyclotomicExtension.isGalois (S := {ℓ}) (K := ℚ) (L := CyclotomicField ℓ ℚ)
+  obtain ⟨z, hz⟩ := IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField ℓ ℚ)
+    (Set.mem_singleton ℓ) hℓ.out.ne_zero
+  have hzu : IsUnit z := hz.isUnit hℓ.out.ne_zero
+  have hζ : IsPrimitiveRoot ((hzu.unit : (CyclotomicField ℓ ℚ)ˣ) : CyclotomicField ℓ ℚ) ℓ := by
+    rw [hzu.unit_spec]; exact hz
+  exact mem_modularFunctionField_of_data ℓ hzu.unit hζ (sigma ℓ hzu.unit hζ) (sigma_zeta ℓ hzu.unit
+    hζ)
+    f g F hF hG hinv
+
+include hF hG hinv in
+theorem isIntegral_adjoin_jq : IsIntegral (Algebra.adjoin ℚ {jq}) f := by
+  have : NeZero ((ℓ : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr hℓ.out.ne_zero⟩
+  have hcyc : IsCyclotomicExtension {ℓ} ℚ (CyclotomicField ℓ ℚ) :=
+    CyclotomicField.isCyclotomicExtension (n := ℓ) (K := ℚ)
+  have : FiniteDimensional ℚ (CyclotomicField ℓ ℚ) :=
+    IsCyclotomicExtension.finiteDimensional {ℓ} ℚ (CyclotomicField ℓ ℚ)
+  have : IsGalois ℚ (CyclotomicField ℓ ℚ) :=
+    IsCyclotomicExtension.isGalois (S := {ℓ}) (K := ℚ) (L := CyclotomicField ℓ ℚ)
+  obtain ⟨z, hz⟩ := IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField ℓ ℚ)
+    (Set.mem_singleton ℓ) hℓ.out.ne_zero
+  have hzu : IsUnit z := hz.isUnit hℓ.out.ne_zero
+  have hζ : IsPrimitiveRoot ((hzu.unit : (CyclotomicField ℓ ℚ)ˣ) : CyclotomicField ℓ ℚ) ℓ := by
+    rw [hzu.unit_spec]; exact hz
+  exact isIntegral_of_data ℓ hzu.unit hζ (sigma ℓ hzu.unit hζ) (sigma_zeta ℓ hzu.unit hζ) f g F hF
+    hG hinv
+
+end Main
+
+section FrickeTransport
+
+lemma natDegree_interpPoly_lt {L : Type*} [CommRing L] {n : ℕ} (H Y : Fin (n + 1) → L) :
+    (interpPoly H Y).natDegree < n + 1 := by
+  unfold interpPoly
+  refine Nat.lt_succ_of_le (Polynomial.natDegree_sum_le_of_forall_le _ _ fun i _ => ?_)
+  refine (Polynomial.natDegree_C_mul_le _ _).trans ((Polynomial.natDegree_prod_le _ _).trans ?_)
+  refine (Finset.sum_le_sum fun m _ => Polynomial.natDegree_X_sub_C_le (Y m)).trans ?_
+  simp [Finset.card_erase_of_mem (Finset.mem_univ i)]
+
+variable {K : Type} [Field K] [Algebra ℚ K] [IsGalois ℚ K] [FiniteDimensional ℚ K]
+  (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) ℓ) (σ : K →+* ℂ)
+  (hσ : σ (ζ : K) = expRoot ℓ)
+  (f g : LaurentSeries ℚ) (F : ℍ → ℂ)
+  (hF : ∀ τ : ℍ, HasSum (fun m : ℤ => ((f.coeff m : ℚ) : ℂ) * 𝕢 1 (τ : ℂ) ^ m) (F τ))
+  (hG : ∀ τ : ℍ, HasSum (fun m : ℤ => ((g.coeff m : ℚ) : ℂ) * 𝕢 ℓ (τ : ℂ) ^ m) (F (ModularGroup.S •
+    τ)))
+  (hinv : ∀ γ ∈ CongruenceSubgroup.Gamma0 ℓ, ∀ τ : ℍ, F (γ • τ) = F τ)
+
+lemma realL_jtN_S : RealL ℓ (coeffMap castC jq) (fun τ => jtN ℓ (ModularGroup.S • τ)) := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  intro τ
+  have hpt : ModularForm.heckeDiagMatrix ℓ • ModularGroup.S • τ = ModularGroup.S •
+    ModularForm.heckeMatrix ℓ 0 • τ :=
+    by
+    have h := heckeDiag_smul_S_T_pow_smul ℓ 0 τ
+    rwa [pow_zero, mul_one] at h
+  have h := hasSum_qParam_heckeMatrix_smul ℓ 0 (coeffMap castC jq) jt realL_jqC τ
+  have hval : jtN ℓ (ModularGroup.S • τ) = jt (ModularForm.heckeMatrix ℓ 0 • τ) := by
+    simp only [jtN]
+    rw [hpt]
+    exact E4_cube_div_discriminant_smul ModularGroup.S _
+  change HasSum _ (jtN ℓ (ModularGroup.S • τ))
+  rw [hval]
+  refine h.congr_fun fun m => ?_
+  simp
+
+lemma realL_sum_qExpand_mul_jq_pow (n : ℕ) (ξ : ℕ → LaurentSeries ℚ) (Ξ : ℕ → ℍ → ℂ)
+    (hξ : ∀ k, RealL 1 (coeffMap castC (ξ k)) (Ξ k))
+    (hΞ : ∀ k (γ : SL(2, ℤ)) τ, Ξ k (γ • τ) = Ξ k τ) :
+    RealL ℓ (coeffMap castC (∑ k ∈ Finset.range n, qExpand ℚ ℓ (ξ k) * jq ^ k))
+      (fun τ => ∑ k ∈ Finset.range n, Ξ k (ModularGroup.S • τ) * jtN ℓ (ModularGroup.S • τ) ^ k)
+        := by
+  have hℓpos : (0 : ℝ) < ℓ := by exact_mod_cast hℓ.out.pos
+  have hk : ∀ k ∈ Finset.range n, RealL ℓ (coeffMap castC (qExpand ℚ ℓ (ξ k) * jq ^ k))
+      (fun τ => Ξ k (ModularGroup.S • τ) * jtN ℓ (ModularGroup.S • τ) ^ k) := by
+    intro k _
+    have h1 : RealL ℓ (coeffMap castC (qExpand ℚ ℓ (ξ k))) (fun τ => Ξ k (ModularGroup.S • τ)) := by
+      have h := realL_qExpand_of_realL_one ℓ _ _ (hξ k)
+      refine h.congr (coeffMap_qExpand _ _ _).symm fun τ => (hΞ k ModularGroup.S τ).symm
+    have h2 : RealL ℓ (coeffMap castC (jq ^ k)) (fun τ => jtN ℓ (ModularGroup.S • τ) ^ k) := by
+      have h := RealL.prod hℓpos (Finset.range k) (fun _ _ => realL_jtN_S ℓ)
+      refine h.congr ?_ fun τ => ?_
+      · rw [Finset.prod_const, Finset.card_range, map_pow]
+      · simp [Finset.prod_const, Finset.card_range]
+    exact (h1.mul hℓpos h2).congr (map_mul _ _ _).symm fun τ => rfl
+  exact (RealL.sum (Finset.range n) hk).congr (map_sum _ _ _).symm fun τ => rfl
+
+lemma coeffMap_castC_injective :
+    Function.Injective (coeffMap castC : LaurentSeries ℚ → LaurentSeries ℂ) := by
+  intro x y h
+  ext m
+  have hm := congrArg (fun z : LaurentSeries ℂ => z.coeff m) h
+  simp only [coeffMap_coeff] at hm
+  exact castC.injective hm
+
+def embW (w : modularFunctionFieldFull ℓ ≃ₐ[ℚ] modularFunctionFieldFull ℓ) :
+    modularFunctionFieldFull ℓ →+* LaurentSeries ℚ :=
+  (algebraMap (modularFunctionFieldFull ℓ) (LaurentSeries ℚ)).comp (w : modularFunctionFieldFull ℓ
+    →+* modularFunctionFieldFull ℓ)
+
+omit hℓ in
+lemma embW_apply (w : modularFunctionFieldFull ℓ ≃ₐ[ℚ] modularFunctionFieldFull ℓ)
+    (x : modularFunctionFieldFull ℓ) :
+    embW ℓ w x = ((w x : modularFunctionFieldFull ℓ) : LaurentSeries ℚ) := rfl
+
+lemma embW_of_mem_adjoin (w : modularFunctionFieldFull ℓ ≃ₐ[ℚ] modularFunctionFieldFull ℓ)
+    (hw : IsFrickeAutFull ℓ w) (ξ : LaurentSeries ℚ) (hξ : ξ ∈ Algebra.adjoin ℚ {jq})
+    (hξ' : ξ ∈ modularFunctionFieldFull ℓ) : embW ℓ w ⟨ξ, hξ'⟩ = qExpand ℚ ℓ ξ := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  revert hξ'
+  induction hξ using Algebra.adjoin_induction with
+  | mem x hx =>
+    intro hξ'
+    rw [Set.mem_singleton_iff] at hx
+    subst hx
+    have h := hw 1 ℓ (one_mul ℓ) inferInstance inferInstance
+    have h1 : (⟨qExpand ℚ 1 jq, jqd_mem_full ℓ (Dvd.intro ℓ (one_mul ℓ))⟩ : modularFunctionFieldFull
+      ℓ) =
+        ⟨jq, hξ'⟩ := Subtype.ext (qExpand_one_apply jq)
+    rw [h1] at h
+    rw [embW_apply, h]
+  | algebraMap r =>
+    intro hξ'
+    have hR : qExpand ℚ ℓ (algebraMap ℚ (LaurentSeries ℚ) r) = algebraMap ℚ (LaurentSeries ℚ) r :=
+      RingHom.congr_fun (RingHom.ext_rat ((qExpand ℚ ℓ).comp (algebraMap ℚ (LaurentSeries ℚ)))
+        (algebraMap ℚ (LaurentSeries ℚ))) r
+    let χ : ℚ →+* modularFunctionFieldFull ℓ := (algebraMap ℚ (LaurentSeries ℚ)).codRestrict
+      (modularFunctionFieldFull ℓ) (fun x => IntermediateField.algebraMap_mem _ x)
+    have hχ : χ = algebraMap ℚ (modularFunctionFieldFull ℓ) := RingHom.ext_rat _ _
+    have he : (⟨algebraMap ℚ (LaurentSeries ℚ) r, hξ'⟩ : modularFunctionFieldFull ℓ) =
+        algebraMap ℚ (modularFunctionFieldFull ℓ) r := by
+      rw [← hχ]; rfl
+    have hval : ((algebraMap ℚ (modularFunctionFieldFull ℓ) r : modularFunctionFieldFull ℓ) :
+      LaurentSeries ℚ) =
+        algebraMap ℚ (LaurentSeries ℚ) r := by
+      rw [← he]
+    rw [hR, he, embW_apply, AlgEquiv.commutes, hval]
+  | add x y hx hy ihx ihy =>
+    intro hξ'
+    have hx' : x ∈ modularFunctionFieldFull ℓ :=
+      (Algebra.adjoin_le (S := (modularFunctionFieldFull ℓ).toSubalgebra)
+      (Set.singleton_subset_iff.mpr (jq_mem_full ℓ))) hx
+    have hy' : y ∈ modularFunctionFieldFull ℓ :=
+      (Algebra.adjoin_le (S := (modularFunctionFieldFull ℓ).toSubalgebra)
+      (Set.singleton_subset_iff.mpr (jq_mem_full ℓ))) hy
+    have : (⟨x + y, hξ'⟩ : modularFunctionFieldFull ℓ) = ⟨x, hx'⟩ + ⟨y, hy'⟩ := rfl
+    rw [this, map_add, map_add, ihx hx', ihy hy']
+  | mul x y hx hy ihx ihy =>
+    intro hξ'
+    have hx' : x ∈ modularFunctionFieldFull ℓ :=
+      (Algebra.adjoin_le (S := (modularFunctionFieldFull ℓ).toSubalgebra)
+      (Set.singleton_subset_iff.mpr (jq_mem_full ℓ))) hx
+    have hy' : y ∈ modularFunctionFieldFull ℓ :=
+      (Algebra.adjoin_le (S := (modularFunctionFieldFull ℓ).toSubalgebra)
+      (Set.singleton_subset_iff.mpr (jq_mem_full ℓ))) hy
+    have : (⟨x * y, hξ'⟩ : modularFunctionFieldFull ℓ) = ⟨x, hx'⟩ * ⟨y, hy'⟩ := rfl
+    rw [this, map_mul, map_mul, ihx hx', ihy hy']
+
+include hζ hσ hF hG hinv in
+theorem fricke_transport (w : modularFunctionFieldFull ℓ ≃ₐ[ℚ] modularFunctionFieldFull ℓ)
+    (hw : IsFrickeAutFull ℓ w) (hf : f ∈ modularFunctionFieldFull ℓ) :
+    ((w ⟨f, hf⟩ : modularFunctionFieldFull ℓ) : LaurentSeries ℚ) = g := by
+  classical
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  have hℓpos : (0 : ℝ) < ℓ := by exact_mod_cast hℓ.out.pos
+  have hadj : Algebra.adjoin ℚ {jq} ≤ (modularFunctionFieldFull ℓ).toSubalgebra :=
+    Algebra.adjoin_le (Set.singleton_subset_iff.mpr (jq_mem_full ℓ))
+  have hFle := modularFunctionField_le_full ℓ
+  choose ξ hξ using fun k => exists_interpK_coeff_eq ℓ ζ hζ f g k
+  have h1F : ∀ τ : ℍ, HasSum (fun m : ℤ => (((1 : LaurentSeries ℚ).coeff m : ℚ) : ℂ) * 𝕢 1 (τ : ℂ) ^
+    m)
+      ((fun _ : ℍ => (1 : ℂ)) τ) := by
+    intro τ; have h := RealL.one 1 τ; rw [← map_one (coeffMap castC)] at h; exact h
+  have h1G : ∀ τ : ℍ, HasSum (fun m : ℤ => (((1 : LaurentSeries ℚ).coeff m : ℚ) : ℂ) * 𝕢 ℓ (τ : ℂ) ^
+    m)
+      ((fun _ : ℍ => (1 : ℂ)) (ModularGroup.S • τ)) := by
+    intro τ; have h := RealL.one (ℓ : ℝ) τ; rw [← map_one (coeffMap castC)] at h; exact h
+  have h1inv : ∀ γ ∈ CongruenceSubgroup.Gamma0 ℓ, ∀ τ : ℍ, (fun _ : ℍ => (1 : ℂ)) (γ • τ) = (fun _ :
+    ℍ => (1 : ℂ)) τ :=
+    fun _ _ _ => rfl
+  choose ξ1 hξ1 using fun k => exists_interpK_coeff_eq ℓ ζ hζ (1 : LaurentSeries ℚ) 1 k
+  have hξmem : ∀ k, ξ k ∈ Algebra.adjoin ℚ {jq} := fun k =>
+    mem_adjoin_of_interpK_coeff_eq ℓ ζ σ hσ f g F hF hG hinv k (ξ k) (hξ k)
+  have hξ1mem : ∀ k, ξ1 k ∈ Algebra.adjoin ℚ {jq} := fun k =>
+    mem_adjoin_of_interpK_coeff_eq ℓ ζ σ hσ 1 1 (fun _ => 1) h1F h1G h1inv k (ξ1 k) (hξ1 k)
+  have hreal : ∀ k, RealL 1 (coeffMap castC (ξ k)) (interpFun ℓ F k) := by
+    intro k
+    have h := RealL.interpPoly_coeff (h := (ℓ : ℝ)) hℓpos
+      (fun i => realL_slotH ℓ ζ σ hσ f g F hF hG i) (fun i => realL_conj ℓ ζ σ hσ i) k
+    have h' : RealL ℓ (coeffMap σ ((interpK ℓ ζ f g).coeff k)) (interpFun ℓ F k) := by
+      refine h.congr ?_ fun τ => rfl
+      rw [← Polynomial.coeff_map, interpK, interpPoly_map]; rfl
+    rw [hξ k, coeffMap_sigma_coeffEmb, coeffMap_qExpand] at h'
+    exact realL_one_of_realL_qExpand ℓ _ _ h'
+  have hreal1 : ∀ k, RealL 1 (coeffMap castC (ξ1 k)) (interpFun ℓ (fun _ => (1 : ℂ)) k) := by
+    intro k
+    have h := RealL.interpPoly_coeff (h := (ℓ : ℝ)) hℓpos
+      (fun i => realL_slotH ℓ ζ σ hσ 1 1 (fun _ => (1 : ℂ)) h1F h1G i) (fun i => realL_conj ℓ ζ σ hσ
+        i) k
+    have h' : RealL ℓ (coeffMap σ ((interpK ℓ ζ (1 : LaurentSeries ℚ) 1).coeff k)) (interpFun ℓ (fun
+      _ => (1 : ℂ)) k) :=
+      by
+      refine h.congr ?_ fun τ => rfl
+      rw [← Polynomial.coeff_map, interpK, interpPoly_map]; rfl
+    rw [hξ1 k, coeffMap_sigma_coeffEmb, coeffMap_qExpand] at h'
+    exact realL_one_of_realL_qExpand ℓ _ _ h'
+  set x : LaurentSeries ℚ := ∑ k ∈ Finset.range (ℓ + 1), ξ k * jqN ℓ ^ k with hx
+  set d : LaurentSeries ℚ := ∑ k ∈ Finset.range (ℓ + 1), ξ1 k * jqN ℓ ^ k with hd
+  set x' : LaurentSeries ℚ := ∑ k ∈ Finset.range (ℓ + 1), qExpand ℚ ℓ (ξ k) * jq ^ k with hx'
+  set d' : LaurentSeries ℚ := ∑ k ∈ Finset.range (ℓ + 1), qExpand ℚ ℓ (ξ1 k) * jq ^ k with hd'
+  have hxmem : x ∈ modularFunctionFieldFull ℓ :=
+    sum_mem fun k _ => mul_mem (hadj (hξmem k)) (pow_mem (hFle (jqN_mem ℓ)) k)
+  have hdmem : d ∈ modularFunctionFieldFull ℓ :=
+    sum_mem fun k _ => mul_mem (hadj (hξ1mem k)) (pow_mem (hFle (jqN_mem ℓ)) k)
+  have hιx : iota (K := K) ℓ x = iota ℓ f * dHat ℓ ζ := by
+    have hdeg : (interpK ℓ ζ f g).natDegree < ℓ + 1 := natDegree_interpPoly_lt _ _
+    rw [hx, map_sum]
+    simp only [map_mul, map_pow, iota_jqN ℓ ζ, iota_apply, ← hξ]
+    rw [← Polynomial.eval_eq_sum_range' hdeg, interpK, interpPoly_eval, ← slotH_zero ℓ ζ f g, dHat]
+  have hιd : iota (K := K) ℓ d = dHat ℓ ζ := by
+    have hdeg : (interpK ℓ ζ (1 : LaurentSeries ℚ) 1).natDegree < ℓ + 1 :=
+      natDegree_interpPoly_lt _ _
+    rw [hd, map_sum]
+    simp only [map_mul, map_pow, iota_jqN ℓ ζ, iota_apply, ← hξ1]
+    rw [← Polynomial.eval_eq_sum_range' hdeg, interpK, interpPoly_eval, dHat, slotH_zero, map_one,
+      map_one, one_mul]
+  have hd0 : d ≠ 0 := by
+    intro h0; exact dHat_ne_zero ℓ ζ hζ (by rw [h0, map_zero] at hιd; exact hιd.symm)
+  have hfd : f * d = x := iota_injective (K := K) ℓ (by rw [map_mul, hιd, hιx])
+  have hwx : embW ℓ w ⟨x, hxmem⟩ = x' := by
+    have : (⟨x, hxmem⟩ : modularFunctionFieldFull ℓ) =
+        ∑ k ∈ Finset.range (ℓ + 1), ⟨ξ k, hadj (hξmem k)⟩ * ⟨jqN ℓ, hFle (jqN_mem ℓ)⟩ ^ k := by
+      apply Subtype.ext
+      simp only [hx]
+      push_cast
+      rfl
+    rw [this, map_sum, hx']
+    refine Finset.sum_congr rfl fun k _ => ?_
+    rw [map_mul, map_pow, embW_of_mem_adjoin ℓ w hw (ξ k) (hξmem k)]
+    congr 1
+    have h := hw ℓ 1 (mul_one ℓ) inferInstance inferInstance
+    have h1 : (⟨qExpand ℚ 1 jq, jqd_mem_full ℓ (Dvd.intro_left ℓ (mul_one ℓ))⟩ :
+      modularFunctionFieldFull ℓ) =
+        ⟨jq, jq_mem_full ℓ⟩ := Subtype.ext (qExpand_one_apply jq)
+    have h2 : (⟨qExpand ℚ ℓ jq, jqd_mem_full ℓ (Dvd.intro 1 (mul_one ℓ))⟩ : modularFunctionFieldFull
+      ℓ) =
+        ⟨jqN ℓ, hFle (jqN_mem ℓ)⟩ := Subtype.ext rfl
+    rw [h1, h2] at h
+    rw [embW_apply, h]
+  have hwd : embW ℓ w ⟨d, hdmem⟩ = d' := by
+    have : (⟨d, hdmem⟩ : modularFunctionFieldFull ℓ) =
+        ∑ k ∈ Finset.range (ℓ + 1), ⟨ξ1 k, hadj (hξ1mem k)⟩ * ⟨jqN ℓ, hFle (jqN_mem ℓ)⟩ ^ k := by
+      apply Subtype.ext
+      simp only [hd]
+      push_cast
+      rfl
+    rw [this, map_sum, hd']
+    refine Finset.sum_congr rfl fun k _ => ?_
+    rw [map_mul, map_pow, embW_of_mem_adjoin ℓ w hw (ξ1 k) (hξ1mem k)]
+    congr 1
+    have h := hw ℓ 1 (mul_one ℓ) inferInstance inferInstance
+    have h1 : (⟨qExpand ℚ 1 jq, jqd_mem_full ℓ (Dvd.intro_left ℓ (mul_one ℓ))⟩ :
+      modularFunctionFieldFull ℓ) =
+        ⟨jq, jq_mem_full ℓ⟩ := Subtype.ext (qExpand_one_apply jq)
+    have h2 : (⟨qExpand ℚ ℓ jq, jqd_mem_full ℓ (Dvd.intro 1 (mul_one ℓ))⟩ : modularFunctionFieldFull
+      ℓ) =
+        ⟨jqN ℓ, hFle (jqN_mem ℓ)⟩ := Subtype.ext rfl
+    rw [h1, h2] at h
+    rw [embW_apply, h]
+  have hXpt : ∀ (Φ : ℍ → ℂ) (τ : ℍ), ∑ k ∈ Finset.range (ℓ + 1), interpFun ℓ Φ k τ * jtN ℓ τ ^ k =
+      Φ τ * ∏ m ∈ Finset.univ.erase (0 : Fin (ℓ + 1)), (slotJ ℓ 0 τ - slotJ ℓ m τ) := by
+    intro Φ τ
+    have h1 := interpPoly_eval (fun i => slotF ℓ Φ i τ) (fun i => slotJ ℓ i τ) 0
+    have h2 := Polynomial.eval_eq_sum_range'
+      (natDegree_interpPoly_lt (fun i => slotF ℓ Φ i τ) (fun i => slotJ ℓ i τ)) ((fun i => slotJ ℓ i
+        τ) 0)
+    simp only [] at h1 h2
+    have h0 : slotJ ℓ 0 τ = jtN ℓ τ := by simp [slotJ]
+    have hF0 : slotF ℓ Φ 0 τ = Φ τ := by simp [slotF]
+    simp only [interpFun]
+    rw [← h0, ← h2, h1, hF0]
+  have hrx' : RealL ℓ (coeffMap castC x') (fun τ => F (ModularGroup.S • τ) *
+      ∏ m ∈ Finset.univ.erase (0 : Fin (ℓ + 1)), (slotJ ℓ 0 (ModularGroup.S • τ) - slotJ ℓ m
+        (ModularGroup.S • τ))) := by
+    have h := realL_sum_qExpand_mul_jq_pow ℓ (ℓ + 1) ξ (fun k => interpFun ℓ F k) hreal
+      (fun k γ τ => interpFun_smul ℓ F hinv k γ τ)
+    exact h.congr rfl fun τ => hXpt F (ModularGroup.S • τ)
+  have hrd' : RealL ℓ (coeffMap castC d') (fun τ =>
+      ∏ m ∈ Finset.univ.erase (0 : Fin (ℓ + 1)), (slotJ ℓ 0 (ModularGroup.S • τ) - slotJ ℓ m
+        (ModularGroup.S • τ))) := by
+    have h :=
+      realL_sum_qExpand_mul_jq_pow ℓ (ℓ + 1) ξ1 (fun k => interpFun ℓ (fun _ => (1 : ℂ)) k) hreal1
+      (fun k γ τ => interpFun_smul ℓ (fun _ => (1 : ℂ)) h1inv k γ τ)
+    refine h.congr rfl fun τ => ?_
+    rw [hXpt (fun _ => (1 : ℂ)) (ModularGroup.S • τ), one_mul]
+  have hrg : RealL ℓ (coeffMap castC g) (fun τ => F (ModularGroup.S • τ)) := fun τ => hG τ
+  have hx'gd : x' = g * d' := by
+    apply coeffMap_castC_injective
+    rw [map_mul]
+    exact laurent_qParam_coeff_unique ℓ hℓpos _ _ _ hrx' (hrg.mul hℓpos hrd')
+  have hd'0 : d' ≠ 0 := by
+    rw [← hwd, embW_apply]
+    intro h0
+    apply hd0
+    have : (w ⟨d, hdmem⟩ : modularFunctionFieldFull ℓ) = 0 := Subtype.ext h0
+    have := w.injective (this.trans (map_zero w).symm)
+    exact congrArg Subtype.val this
+  have hprod : (⟨f, hf⟩ : modularFunctionFieldFull ℓ) * ⟨d, hdmem⟩ = ⟨x, hxmem⟩ := Subtype.ext hfd
+  have key : embW ℓ w ⟨f, hf⟩ * d' = g * d' := by
+    rw [← hx'gd, ← hwx, ← hprod, map_mul, hwd]
+  have := mul_right_cancel₀ hd'0 key
+  rwa [embW_apply] at this
+
+end FrickeTransport
+
+end QExpN
+end ModularCurve
+end
+
+theorem solution (ℓ : ℕ) [Fact (Nat.Prime ℓ)] (f g : LaurentSeries ℚ) (F : UpperHalfPlane → ℂ) (hF :
+  ∀ τ : UpperHalfPlane, HasSum (fun m : ℤ => ((f.coeff m : ℚ) : ℂ) * Function.Periodic.qParam 1 (τ :
+  ℂ) ^ m) (F τ)) (hG : ∀ τ : UpperHalfPlane, HasSum (fun m : ℤ => ((g.coeff m : ℚ) : ℂ) *
+  Function.Periodic.qParam ℓ (τ : ℂ) ^ m) (F (ModularGroup.S • τ))) (hinv : ∀ γ ∈
+  CongruenceSubgroup.Gamma0 ℓ, ∀ τ : UpperHalfPlane, F (γ • τ) = F τ) (hf : f ∈
+  ModularCurve.modularFunctionFieldFull ℓ) :
+    ((ModularCurve.frickeInvolutionFull ℓ ⟨f, hf⟩ : ModularCurve.modularFunctionFieldFull ℓ) :
+      LaurentSeries ℚ) = g := by
+  have hℓ : Fact (Nat.Prime ℓ) := inferInstance
+  have : NeZero ((ℓ : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr hℓ.out.ne_zero⟩
+  have hcyc : IsCyclotomicExtension {ℓ} ℚ (CyclotomicField ℓ ℚ) :=
+    CyclotomicField.isCyclotomicExtension (n := ℓ) (K := ℚ)
+  have : FiniteDimensional ℚ (CyclotomicField ℓ ℚ) :=
+    IsCyclotomicExtension.finiteDimensional {ℓ} ℚ (CyclotomicField ℓ ℚ)
+  have : IsGalois ℚ (CyclotomicField ℓ ℚ) :=
+    IsCyclotomicExtension.isGalois (S := {ℓ}) (K := ℚ) (L := CyclotomicField ℓ ℚ)
+  obtain ⟨z, hz⟩ := IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField ℓ ℚ)
+    (Set.mem_singleton ℓ) hℓ.out.ne_zero
+  have hzu : IsUnit z := hz.isUnit hℓ.out.ne_zero
+  have hζ : IsPrimitiveRoot ((hzu.unit : (CyclotomicField ℓ ℚ)ˣ) : CyclotomicField ℓ ℚ) ℓ := by
+    rw [hzu.unit_spec]; exact hz
+  exact ModularCurve.QExpN.fricke_transport ℓ hzu.unit hζ (ModularCurve.QExpN.sigma ℓ hzu.unit hζ)
+    (ModularCurve.QExpN.sigma_zeta ℓ hzu.unit hζ) f g F hF hG hinv
+      (ModularCurve.frickeInvolutionFull ℓ)
+    (ModularCurve.isFrickeAutFull_frickeInvolutionFull_prime ℓ) hf
+
+end S_ModularCurve_coe_frickeInvolutionFull_eq_of_hasSum_of_gamma0_invariant
+end P2MW
+export P2MW.S_ModularCurve_coe_frickeInvolutionFull_eq_of_hasSum_of_gamma0_invariant (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.coe_frickeInvolutionFull_eq_of_hasSum_of_gamma0_invariant (ℓ : ℕ) [Fact
+  (Nat.Prime ℓ)] (f g : LaurentSeries ℚ) (F : UpperHalfPlane → ℂ) (hF : ∀ τ : UpperHalfPlane, HasSum
+  (fun m : ℤ => ((f.coeff m : ℚ) : ℂ) * Function.Periodic.qParam 1 (τ : ℂ) ^ m) (F τ)) (hG : ∀ τ :
+  UpperHalfPlane, HasSum (fun m : ℤ => ((g.coeff m : ℚ) : ℂ) * Function.Periodic.qParam ℓ (τ : ℂ) ^
+  m) (F (ModularGroup.S • τ))) (hinv : ∀ γ ∈ CongruenceSubgroup.Gamma0 ℓ, ∀ τ : UpperHalfPlane, F (γ
+  • τ) = F τ) (hf : f ∈ ModularCurve.modularFunctionFieldFull ℓ) :
+    ((ModularCurve.frickeInvolutionFull ℓ ⟨f, hf⟩ : ModularCurve.modularFunctionFieldFull ℓ) :
+      LaurentSeries ℚ) = g :=
+  solution ℓ f g F hF hG hinv hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coe_frickeInvolutionFull_modularUnitSeries.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coe_frickeInvolutionFull_modularUnitSeries.lean
new file mode 100644
index 0000000000..934ee67222
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coe_frickeInvolutionFull_modularUnitSeries.lean
@@ -0,0 +1,96 @@
+/-
+Based on Prove2Me node ModularCurve.coe_frickeInvolutionFull_modularUnitSeries
+(79408102-26d3-5260-b18d-9dc1e6671f44) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 870e3474-6437-5122-8229-fc8052e94490
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ModularUnit
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_AtkinLehner
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+import Mathlib.NumberTheory.ModularForms.Discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_modularUnitSeries_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_smul_modularUnitSeries_inv_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_discriminant_div_discriminant_heckeDiagMatrix_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coe_frickeInvolutionFull_eq_of_hasSum_of_gamma0_invariant
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Fricke involution sends Ogg's unit to ℓ¹²u_ℓ⁻¹
+
+Theorem statement: `ModularCurve.coe_frickeInvolutionFull_modularUnitSeries`
+(`79408102-26d3-5260-b18d-9dc1e6671f44`), by Claude, 2026-09-05.
+
+Proof: submission `870e3474-6437-5122-8229-fc8052e94490`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a prime. Inside the field $\mathbb{Q}((q))$ of rational Laurent series,
+[`ModularCurve.modularUnitSeries`](def/ModularCurve_ModularUnit.html#L127) $\ell$ denotes the series
+$u_\ell = \Delta \cdot (\Delta^{(\ell)})^{-1}$, where $\Delta$ is the Laurent series $q\prod_{n\ge
+1}(1-q^n)^{24}$ built from the single term $q$ and the power series `dedekindEtaUnitQ`, and
+$\Delta^{(\ell)}$ is its image under the substitution $q \mapsto q^{\ell}$ given by `qExpand ℚ ℓ`.
+Let `modularFunctionFieldFull ℓ` be the intermediate field of $\mathbb{Q}((q))$ over $\mathbb{Q}$
+generated by the set of series `qExpand ℚ d jq` for the nonzero divisors $d$ of $\ell$, and let
+`hmem` be a witness that $u_\ell$ lies in that field. Let `frickeInvolutionFull ℓ` be the
+$\mathbb{Q}$-algebra automorphism of this field chosen, if one exists, to satisfy `IsFrickeAutFull
+ℓ`, i.e. to interchange `qExpand ℚ a jq` and `qExpand ℚ b jq` whenever $ab=\ell$ (and the identity
+automorphism otherwise). The assertion is that the image of the element $u_\ell$ of
+`modularFunctionFieldFull ℓ` under this automorphism, regarded again as a Laurent series, is
+$\ell^{12}$ times $u_\ell^{-1}$, the scalar acting coefficientwise.
+
+This is the classical behaviour of Ogg's modular unit $u_\ell = \Delta(q)/\Delta(q^{\ell})$ under
+the Fricke involution $w_\ell$ on the modular function field of level $\ell$, namely $w_\ell(u_\ell)
+= \ell^{12} u_\ell^{-1}$, recorded here at the level of $q$-expansions. It feeds the construction of
+models and of residue/specialisation data for the curves $X_0(\ell)$ used further on.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_coe_frickeInvolutionFull_modularUnitSeries.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_coe_frickeInvolutionFull_modularUnitSeries
+
+theorem solution (ℓ : ℕ) [Fact (Nat.Prime ℓ)]
+    (hmem : ModularCurve.modularUnitSeries ℓ ∈ ModularCurve.modularFunctionFieldFull ℓ) :
+    ((ModularCurve.frickeInvolutionFull ℓ ⟨ModularCurve.modularUnitSeries ℓ, hmem⟩ :
+      ModularCurve.modularFunctionFieldFull ℓ) : LaurentSeries ℚ) = (ℓ : ℚ) ^ 12 •
+      (ModularCurve.modularUnitSeries ℓ)⁻¹ := by
+  have : NeZero ℓ := ⟨(Fact.out : Nat.Prime ℓ).ne_zero⟩
+  exact ModularCurve.coe_frickeInvolutionFull_eq_of_hasSum_of_gamma0_invariant ℓ
+    (ModularCurve.modularUnitSeries ℓ) ((ℓ : ℚ) ^ 12 • (ModularCurve.modularUnitSeries ℓ)⁻¹)
+    (fun τ => ModularForm.discriminant τ
+      / ModularForm.discriminant (ModularForm.heckeDiagMatrix ℓ • τ))
+    (fun τ => ModularCurve.hasSum_modularUnitSeries_qParam ℓ τ)
+    (fun τ => ModularCurve.hasSum_smul_modularUnitSeries_inv_qParam ℓ τ)
+    (fun γ hγ τ => ModularCurve.discriminant_div_discriminant_heckeDiagMatrix_smul ℓ γ hγ τ) hmem
+
+end S_ModularCurve_coe_frickeInvolutionFull_modularUnitSeries
+end P2MW
+export P2MW.S_ModularCurve_coe_frickeInvolutionFull_modularUnitSeries (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.coe_frickeInvolutionFull_modularUnitSeries (ℓ : ℕ) [Fact (Nat.Prime ℓ)]
+    (hmem : ModularCurve.modularUnitSeries ℓ ∈ ModularCurve.modularFunctionFieldFull ℓ) :
+    ((ModularCurve.frickeInvolutionFull ℓ ⟨ModularCurve.modularUnitSeries ℓ, hmem⟩ :
+      ModularCurve.modularFunctionFieldFull ℓ) : LaurentSeries ℚ) = (ℓ : ℚ) ^ 12 •
+      (ModularCurve.modularUnitSeries ℓ)⁻¹ :=
+  solution ℓ hmem
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coe_qExpansion_normalizedDerivOfComplex.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coe_qExpansion_normalizedDerivOfComplex.lean
new file mode 100644
index 0000000000..a342415ba9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coe_qExpansion_normalizedDerivOfComplex.lean
@@ -0,0 +1,323 @@
+/-
+Based on Prove2Me node ModularCurve.coe_qExpansion_normalizedDerivOfComplex
+(81d39c60-3004-5e5a-9072-36998eb4606e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2ecd88f2-89da-55cd-befd-892c9c121431
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QExpansionDiff
+public import Mathlib.NumberTheory.ModularForms.Derivative
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import Mathlib.Analysis.Calculus.FDeriv.Analytic
+public import Mathlib.Analysis.SpecialFunctions.ExpDeriv
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_theta_coeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# q-expansion of the normalised derivative equals θ of the q-expansion
+
+Theorem statement: `ModularCurve.coe_qExpansion_normalizedDerivOfComplex`
+(`81d39c60-3004-5e5a-9072-36998eb4606e`), by Claude, 2026-09-05.
+
+Proof: submission `2ecd88f2-89da-55cd-befd-892c9c121431`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F \colon \mathbb{H} \to \mathbb{C}$ be a function on the upper half plane such that the
+composite $F \circ$ `UpperHalfPlane.ofComplex` is periodic of period $1$, such that $F$ is
+differentiable as a map of complex manifolds (with the standard charts on source and target), and
+such that $F$ is bounded at $i\infty$ in the sense of `UpperHalfPlane.IsBoundedAtImInfty`. Form the
+$q$-expansion of period $1$ of the function `Derivative.normalizedDerivOfComplex F` obtained from
+$F$, and the $q$-expansion of period $1$ of $F$ itself; both are power series over $\mathbb{C}$, and
+each is regarded as a Laurent series via the canonical inclusion of `PowerSeries ℂ` into
+`LaurentSeries ℂ`. The assertion is the equality of Laurent series
+$$\mathrm{qExp}\bigl(\mathrm{normalizedDerivOfComplex}\,F\bigr) =
+\theta\bigl(\mathrm{qExp}(F)\bigr),$$
+where $\theta =$ [`ModularCurve.thetaL ℂ`](def/ModularCurve_QExpansionDiff.html#L16) is the
+$\mathbb{C}$-linear operator on `LaurentSeries ℂ` sending $f$ to $\mathrm{single}(1,1) \cdot
+\mathrm{derivative}(f)$, that is, the operator $q\,\mathrm{d}/\mathrm{d}q$, whose effect on
+coefficients is multiplication of the coefficient of $q^{n}$ by $n$. No modularity or weight
+hypothesis on $F$ occurs; the conclusion is an identity of formal series.
+
+This packages the coefficientwise description of the normalised derivative $\tfrac{1}{2\pi
+i}\,\mathrm{d}/\mathrm{d}\tau$ on $q$-expansions as a single identity between a transcendentally
+defined operator on functions on $\mathbb{H}$ and the purely formal operator
+$q\,\mathrm{d}/\mathrm{d}q$ on Laurent series, the coefficient computation being supplied by
+[`ModularCurve.theta_coeff`](thm.html#ModularCurve.theta_coeff). It is used in the computation of
+the $q$-expansion of the first Rankin–Cohen bracket,
+[`ModularForm.exists_rankinCohen_one_qExpansion_eq`]
+(thm.html#ModularForm.exists_rankinCohen_one_qExpansion_eq).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_coe_qExpansion_normalizedDerivOfComplex.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_coe_qExpansion_normalizedDerivOfComplex
+
+open UpperHalfPlane Complex Function
+open scoped Real Manifold
+
+namespace ModularCurve
+p2m_export "ModularCurve" "thetaL thetaL_apply theta_coeff"
+p2m_open "ModularCurve"
+
+private lemma norm_qParam_one_lt_one (τ : ℍ) : ‖Function.Periodic.qParam 1 (τ : ℂ)‖ < 1 := by
+  have h1 : 0 < 2 * Real.pi * τ.im / 1 := by positivity
+  simpa [Function.Periodic.qParam, Complex.norm_exp, neg_div] using h1
+
+private lemma hasDerivAt_qParam_one (z : ℂ) :
+    HasDerivAt (fun w : ℂ => Function.Periodic.qParam 1 w)
+      (2 * Real.pi * Complex.I * Function.Periodic.qParam 1 z) z := by
+  simp only [Function.Periodic.qParam, Complex.ofReal_one, div_one]
+  have h0 : HasDerivAt (fun w : ℂ => 2 * (Real.pi : ℂ) * Complex.I * w)
+      (2 * (Real.pi : ℂ) * Complex.I) z := by
+    simpa using (hasDerivAt_id z).const_mul (2 * (Real.pi : ℂ) * Complex.I)
+  simpa [mul_comm] using h0.cexp
+
+private lemma normalizedDerivOfComplex_eq_qParam_mul_deriv
+    (F : ℍ → ℂ) (hper : Function.Periodic (F ∘ UpperHalfPlane.ofComplex) 1)
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F) (hbdd : UpperHalfPlane.IsBoundedAtImInfty F) (τ : ℍ) :
+    Derivative.normalizedDerivOfComplex F τ =
+      Function.Periodic.qParam 1 (τ : ℂ) *
+        deriv (UpperHalfPlane.cuspFunction 1 F) (Function.Periodic.qParam 1 (τ : ℂ)) := by
+  have hper' : Function.Periodic (F ∘ UpperHalfPlane.ofComplex) ((1 : ℝ) : ℂ) := by
+    rwa [Complex.ofReal_one]
+  have hmem : (τ : ℂ) ∈ UpperHalfPlane.upperHalfPlaneSet := τ.2
+  have heq : (F ∘ UpperHalfPlane.ofComplex) =ᶠ[nhds (τ : ℂ)]
+      (fun z => UpperHalfPlane.cuspFunction 1 F (Function.Periodic.qParam 1 z)) := by
+    filter_upwards [UpperHalfPlane.isOpen_upperHalfPlaneSet.mem_nhds hmem] with z hz
+    have h2 := UpperHalfPlane.eq_cuspFunction (f := F) (⟨z, hz⟩ : ℍ) one_ne_zero hper'
+    simp only [Function.comp_apply, UpperHalfPlane.ofComplex_apply_of_im_pos hz]
+    exact h2.symm
+  have hq : ‖Function.Periodic.qParam 1 (τ : ℂ)‖ < 1 := norm_qParam_one_lt_one τ
+  have hg : DifferentiableAt ℂ (UpperHalfPlane.cuspFunction 1 F)
+      (Function.Periodic.qParam 1 (τ : ℂ)) :=
+    UpperHalfPlane.differentiableAt_cuspFunction one_pos hper' hhol hbdd hq
+  have hcomp : HasDerivAt (fun z => UpperHalfPlane.cuspFunction 1 F (Function.Periodic.qParam 1 z))
+      (deriv (UpperHalfPlane.cuspFunction 1 F) (Function.Periodic.qParam 1 (τ : ℂ)) *
+        (2 * Real.pi * Complex.I * Function.Periodic.qParam 1 (τ : ℂ))) (τ : ℂ) :=
+    hg.hasDerivAt.comp (τ : ℂ) (hasDerivAt_qParam_one (τ : ℂ))
+  change (2 * (Real.pi : ℂ) * Complex.I)⁻¹ * deriv (F ∘ UpperHalfPlane.ofComplex) (τ : ℂ) = _
+  rw [Filter.EventuallyEq.deriv_eq heq, hcomp.deriv]
+  have h2πI : (2 * (Real.pi : ℂ) * Complex.I) ≠ 0 := Complex.two_pi_I_ne_zero
+  field_simp
+
+private lemma periodic_normalizedDerivOfComplex
+    (F : ℍ → ℂ) (hper : Function.Periodic (F ∘ UpperHalfPlane.ofComplex) 1) :
+    Function.Periodic (Derivative.normalizedDerivOfComplex F ∘ UpperHalfPlane.ofComplex) 1 := by
+  intro w
+  by_cases! hw : 0 < w.im
+  · have hw1 : 0 < (w + 1).im := by simpa using hw
+    have hderiv : deriv (F ∘ UpperHalfPlane.ofComplex) (w + 1) =
+        deriv (F ∘ UpperHalfPlane.ofComplex) w := by
+      conv_rhs => rw [show (F ∘ UpperHalfPlane.ofComplex) =
+        fun z => (F ∘ UpperHalfPlane.ofComplex) (z + 1) from funext fun z => (hper z).symm]
+      rw [deriv_comp_add_const]
+    simp only [Function.comp_apply, UpperHalfPlane.ofComplex_apply_of_im_pos hw1,
+      UpperHalfPlane.ofComplex_apply_of_im_pos hw, Derivative.normalizedDerivOfComplex]
+    rw [hderiv]
+  · have hw1 : (w + 1).im ≤ 0 := by simpa using hw
+    simp only [Function.comp_apply, UpperHalfPlane.ofComplex_apply_of_im_nonpos hw1,
+      UpperHalfPlane.ofComplex_apply_of_im_nonpos hw]
+
+private lemma isZeroAtImInfty_normalizedDerivOfComplex
+    (F : ℍ → ℂ) (hper : Function.Periodic (F ∘ UpperHalfPlane.ofComplex) 1)
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F) (hbdd : UpperHalfPlane.IsBoundedAtImInfty F) :
+    UpperHalfPlane.IsZeroAtImInfty (Derivative.normalizedDerivOfComplex F) := by
+  have hper' : Function.Periodic (F ∘ UpperHalfPlane.ofComplex) ((1 : ℝ) : ℂ) := by
+    rwa [Complex.ofReal_one]
+  have hgball : AnalyticOnNhd ℂ (UpperHalfPlane.cuspFunction 1 F) (Metric.ball 0 1) :=
+    (UpperHalfPlane.differentiableOn_cuspFunction_ball one_pos hper' hhol hbdd).analyticOnNhd
+      Metric.isOpen_ball
+  have hderiv_cont : ContinuousAt (deriv (UpperHalfPlane.cuspFunction 1 F)) 0 :=
+    ((hgball.deriv 0 (by simp)).continuousAt)
+  have hq0 : Filter.Tendsto (fun τ : ℍ => Function.Periodic.qParam 1 (τ : ℂ))
+      UpperHalfPlane.atImInfty (nhds 0) := UpperHalfPlane.qParam_tendsto_atImInfty one_pos
+  have hmul : Filter.Tendsto
+      (fun τ : ℍ => Function.Periodic.qParam 1 (τ : ℂ) *
+        deriv (UpperHalfPlane.cuspFunction 1 F) (Function.Periodic.qParam 1 (τ : ℂ)))
+      UpperHalfPlane.atImInfty (nhds 0) := by
+    have h1 := hq0.mul ((hderiv_cont.tendsto).comp hq0)
+    simpa [Function.comp_def] using h1
+  exact hmul.congr fun τ =>
+    (normalizedDerivOfComplex_eq_qParam_mul_deriv F hper hhol hbdd τ).symm
+
+private lemma qExpansion_coeff_unique'
+    {f : ℍ → ℂ} {c : ℕ → ℂ}
+    (hana : AnalyticAt ℂ (UpperHalfPlane.cuspFunction 1 f) 0)
+    (hs : ∀ τ : ℍ, HasSum (fun m : ℕ => c m • Function.Periodic.qParam 1 (τ : ℂ) ^ m) (f τ))
+    (m : ℕ) : c m = (UpperHalfPlane.qExpansion 1 f).coeff m := by
+  have h1 : HasFPowerSeriesAt (UpperHalfPlane.cuspFunction 1 f)
+      (FormalMultilinearSeries.ofScalars ℂ c) 0 :=
+    (UpperHalfPlane.hasFPowerSeriesOnBall_cuspFunction one_pos hana hs).hasFPowerSeriesAt
+  have h2 : HasFPowerSeriesAt (UpperHalfPlane.cuspFunction 1 f)
+      (FormalMultilinearSeries.ofScalars ℂ
+        (fun n => (UpperHalfPlane.qExpansion 1 f).coeff n)) 0 := by
+    simpa [UpperHalfPlane.qExpansion_coeff, div_eq_mul_inv, mul_comm]
+      using hana.hasFPowerSeriesAt
+  have h3 := h1.eq_formalMultilinearSeries h2
+  have h4 := congrArg (fun p : FormalMultilinearSeries ℂ ℂ ℂ =>
+    FormalMultilinearSeries.coeff p m) h3
+  simpa [FormalMultilinearSeries.coeff_ofScalars] using h4
+
+private lemma hasSum_qExpansion_normalizedDerivOfComplex
+    (F : ℍ → ℂ) (hper : Function.Periodic (F ∘ UpperHalfPlane.ofComplex) 1)
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F) (hbdd : UpperHalfPlane.IsBoundedAtImInfty F) (τ : ℍ) :
+    HasSum
+      (fun m : ℕ => ((m : ℂ) * (UpperHalfPlane.qExpansion 1 F).coeff m) •
+        Function.Periodic.qParam 1 (τ : ℂ) ^ m)
+      (Derivative.normalizedDerivOfComplex F τ) := by
+  have hper' : Function.Periodic (F ∘ UpperHalfPlane.ofComplex) ((1 : ℝ) : ℂ) := by
+    rwa [Complex.ofReal_one]
+  set q : ℂ := Function.Periodic.qParam 1 (τ : ℂ) with hq_def
+  have hq : ‖q‖ < 1 := norm_qParam_one_lt_one τ
+  have han : AnalyticAt ℂ (UpperHalfPlane.cuspFunction 1 F) 0 :=
+    UpperHalfPlane.analyticAt_cuspFunction_zero one_pos hper' hhol hbdd
+  have hsum : ∀ σ : ℍ, HasSum
+      (fun m : ℕ => (UpperHalfPlane.qExpansion 1 F).coeff m •
+        Function.Periodic.qParam 1 (σ : ℂ) ^ m) (F σ) :=
+    UpperHalfPlane.hasSum_qExpansion one_pos hper' hhol hbdd
+  have hball : HasFPowerSeriesOnBall (UpperHalfPlane.cuspFunction 1 F)
+      (FormalMultilinearSeries.ofScalars ℂ
+        (fun m => (UpperHalfPlane.qExpansion 1 F).coeff m)) 0 1 :=
+    UpperHalfPlane.hasFPowerSeriesOnBall_cuspFunction one_pos han hsum
+  have hballD : HasFPowerSeriesOnBall (fderiv ℂ (UpperHalfPlane.cuspFunction 1 F))
+      (FormalMultilinearSeries.ofScalars ℂ
+        (fun m => (UpperHalfPlane.qExpansion 1 F).coeff m)).derivSeries 0 1 := hball.fderiv
+  have hqmem : q ∈ Metric.eball (0 : ℂ) 1 := by
+    rw [← ENNReal.coe_one, Metric.eball_coe, mem_ball_zero_iff]
+    simpa using hq
+  have h1 : HasSum
+      (fun n : ℕ => (FormalMultilinearSeries.ofScalars ℂ
+        (fun m => (UpperHalfPlane.qExpansion 1 F).coeff m)).derivSeries n (fun _ => q))
+      (fderiv ℂ (UpperHalfPlane.cuspFunction 1 F) q) := by
+    have h0 := hballD.hasSum hqmem
+    simpa using h0
+  have h2 : HasSum
+      (fun n : ℕ => ((FormalMultilinearSeries.ofScalars ℂ
+        (fun m => (UpperHalfPlane.qExpansion 1 F).coeff m)).derivSeries n (fun _ => q)) q)
+      (fderiv ℂ (UpperHalfPlane.cuspFunction 1 F) q q) :=
+    h1.mapL (ContinuousLinearMap.apply ℂ ℂ q)
+  have hterm : ∀ n : ℕ,
+      ((FormalMultilinearSeries.ofScalars ℂ
+        (fun m => (UpperHalfPlane.qExpansion 1 F).coeff m)).derivSeries n (fun _ => q)) q =
+        (((n + 1 : ℕ) : ℂ) * (UpperHalfPlane.qExpansion 1 F).coeff (n + 1)) • q ^ (n + 1) := by
+    intro n
+    rw [FormalMultilinearSeries.derivSeries_apply_diag,
+      FormalMultilinearSeries.apply_eq_pow_smul_coeff, FormalMultilinearSeries.coeff_ofScalars]
+    simp only [smul_eq_mul, nsmul_eq_mul]
+    push_cast
+    ring
+  have hfd : fderiv ℂ (UpperHalfPlane.cuspFunction 1 F) q q =
+      q * deriv (UpperHalfPlane.cuspFunction 1 F) q := by
+    have h9 : fderiv ℂ (UpperHalfPlane.cuspFunction 1 F) q q =
+        fderiv ℂ (UpperHalfPlane.cuspFunction 1 F) q (q • 1) := by norm_num
+    have h10 : (fderiv ℂ (UpperHalfPlane.cuspFunction 1 F) q) 1 =
+        deriv (UpperHalfPlane.cuspFunction 1 F) q := rfl
+    rw [h9, ContinuousLinearMap.map_smul, smul_eq_mul, h10]
+  have h3 : HasSum
+      (fun n : ℕ => (((n + 1 : ℕ) : ℂ) * (UpperHalfPlane.qExpansion 1 F).coeff (n + 1)) •
+        q ^ (n + 1)) (q * deriv (UpperHalfPlane.cuspFunction 1 F) q) := by
+    have h2' := h2
+    simp only [hterm] at h2'
+    rw [← hfd]
+    exact h2'
+  have h5 : HasSum
+      (fun m : ℕ => ((m : ℂ) * (UpperHalfPlane.qExpansion 1 F).coeff m) • q ^ m)
+      ((q * deriv (UpperHalfPlane.cuspFunction 1 F) q) + ∑ i ∈ Finset.range 1,
+        ((i : ℂ) * (UpperHalfPlane.qExpansion 1 F).coeff i) • q ^ i) :=
+    (hasSum_nat_add_iff 1).mp h3
+  rw [normalizedDerivOfComplex_eq_qParam_mul_deriv F hper hhol hbdd τ]
+  simpa using h5
+
+private theorem qExpansion_coeff_normalizedDerivOfComplex
+    (F : ℍ → ℂ) (hper : Function.Periodic (F ∘ UpperHalfPlane.ofComplex) 1)
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F) (hbdd : UpperHalfPlane.IsBoundedAtImInfty F) (m : ℕ) :
+    (UpperHalfPlane.qExpansion 1 (Derivative.normalizedDerivOfComplex F)).coeff m =
+      (m : ℂ) * (UpperHalfPlane.qExpansion 1 F).coeff m := by
+  have hperD : Function.Periodic
+      (Derivative.normalizedDerivOfComplex F ∘ UpperHalfPlane.ofComplex) ((1 : ℝ) : ℂ) := by
+    rw [Complex.ofReal_one]
+    exact periodic_normalizedDerivOfComplex F hper
+  have hholD : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (Derivative.normalizedDerivOfComplex F) :=
+    Derivative.normalizedDerivOfComplex_mdifferentiable hhol
+  have hbddD : UpperHalfPlane.IsBoundedAtImInfty (Derivative.normalizedDerivOfComplex F) :=
+    (isZeroAtImInfty_normalizedDerivOfComplex F hper hhol hbdd).isBoundedAtImInfty
+  have hanD : AnalyticAt ℂ (UpperHalfPlane.cuspFunction 1
+      (Derivative.normalizedDerivOfComplex F)) 0 :=
+    UpperHalfPlane.analyticAt_cuspFunction_zero one_pos hperD hholD hbddD
+  exact (qExpansion_coeff_unique' hanD
+    (hasSum_qExpansion_normalizedDerivOfComplex F hper hhol hbdd) m).symm
+
+private theorem coe_qExpansion_normalizedDerivOfComplex
+    (F : ℍ → ℂ) (hper : Function.Periodic (F ∘ UpperHalfPlane.ofComplex) 1)
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F) (hbdd : UpperHalfPlane.IsBoundedAtImInfty F) :
+    ((UpperHalfPlane.qExpansion 1 (Derivative.normalizedDerivOfComplex F) : PowerSeries ℂ) :
+        LaurentSeries ℂ) =
+      ModularCurve.thetaL ℂ
+        ((UpperHalfPlane.qExpansion 1 F : PowerSeries ℂ) : LaurentSeries ℂ) := by
+  ext k
+  rw [ModularCurve.thetaL_apply, ModularCurve.theta_coeff]
+  rcases le_or_gt 0 k with hk | hk
+  · lift k to ℕ using hk
+    rw [LaurentSeries.coeff_coe_powerSeries, LaurentSeries.coeff_coe_powerSeries,
+      qExpansion_coeff_normalizedDerivOfComplex F hper hhol hbdd k]
+    simp [zsmul_eq_mul]
+  · have hL : ∀ φ : PowerSeries ℂ, ((φ : PowerSeries ℂ) : LaurentSeries ℂ).coeff k = 0 := by
+      intro φ
+      show (HahnSeries.ofPowerSeries ℤ ℂ φ).coeff k = 0
+      rw [HahnSeries.ofPowerSeries_apply, HahnSeries.embDomain_of_notMem_range]
+      simp only [Set.mem_range, not_exists]
+      intro n hn
+      simp only [Nat.castOrderEmbedding_apply] at hn
+      omega
+    rw [hL, hL, smul_zero]
+
+end ModularCurve
+
+p2m_open "UpperHalfPlane Complex Function.Complex Function ModularCurve \
+  P2MW.S_ModularCurve_coe_qExpansion_normalizedDerivOfComplex.ModularCurve"
+open scoped Real Manifold in
+theorem solution (F : ℍ → ℂ) (hper : Function.Periodic (F ∘ UpperHalfPlane.ofComplex) 1)
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F) (hbdd : UpperHalfPlane.IsBoundedAtImInfty F) :
+    ((UpperHalfPlane.qExpansion 1 (Derivative.normalizedDerivOfComplex F) : PowerSeries ℂ) :
+        LaurentSeries ℂ) =
+      ModularCurve.thetaL ℂ
+        ((UpperHalfPlane.qExpansion 1 F : PowerSeries ℂ) : LaurentSeries ℂ) :=
+  ModularCurve.coe_qExpansion_normalizedDerivOfComplex F hper hhol hbdd
+
+end S_ModularCurve_coe_qExpansion_normalizedDerivOfComplex
+end P2MW
+export P2MW.S_ModularCurve_coe_qExpansion_normalizedDerivOfComplex (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane Complex Function ModularCurve
+open scoped Real Manifold
+theorem ModularCurve.coe_qExpansion_normalizedDerivOfComplex (F : ℍ → ℂ)
+    (hper : Function.Periodic (F ∘ UpperHalfPlane.ofComplex) 1)
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F) (hbdd : UpperHalfPlane.IsBoundedAtImInfty F) :
+    ((UpperHalfPlane.qExpansion 1 (Derivative.normalizedDerivOfComplex F) : PowerSeries ℂ) :
+        LaurentSeries ℂ) =
+      ModularCurve.thetaL ℂ
+        ((UpperHalfPlane.qExpansion 1 F : PowerSeries ℂ) : LaurentSeries ℂ) :=
+  solution F hper hhol hbdd
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeffEmb_injective.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeffEmb_injective.lean
new file mode 100644
index 0000000000..af83a406b6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeffEmb_injective.lean
@@ -0,0 +1,76 @@
+/-
+Based on Prove2Me node ModularCurve.coeffEmb_injective
+(f6fc8541-669e-5884-8b15-9534e19b03e3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 0ed76221-f7ce-5d77-a069-446f771f9dd9
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_injective
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Injectivity of the coefficient embedding ℚ((q)) → L((q))
+
+Theorem statement: `ModularCurve.coeffEmb_injective` (`f6fc8541-669e-5884-8b15-9534e19b03e3`), by
+Claude, 2026-09-05.
+
+Proof: submission `0ed76221-f7ce-5d77-a069-446f771f9dd9`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbb{Q}$-algebra structure. For a ring homomorphism $f \colon
+R \to S$ of commutative rings, [`ModularCurve.coeffMap f`](def/ModularCurve_LaurentCoeff.html#L16)
+denotes the ring homomorphism $\mathrm{LaurentSeries}\,R \to \mathrm{LaurentSeries}\,S$ obtained by
+applying $f$ to each coefficient, that is, sending a formal Laurent series (a Hahn series over
+$\mathbb{Z}$) $\sum_k a_k q^k$ to $\sum_k f(a_k) q^k$; and [`ModularCurve.coeffEmb
+L`](def/ModularCurve_LaurentCoeff.html#L81) is the instance of this construction for the structure
+map $\mathbb{Q} \to L$, a ring homomorphism $\mathbb{Q}((q)) \to L((q))$. The theorem asserts that
+this map [`ModularCurve.coeffEmb L`](def/ModularCurve_LaurentCoeff.html#L81) is injective as a
+function.
+
+An elementary compatibility statement about the coefficientwise extension of scalars on formal
+Laurent series, recording that $q$-expansions with rational coefficients are determined by their
+images over any field of characteristic zero containing $\mathbb{Q}$. It is used throughout the
+treatment of $q$-expansions on modular curves, for instance in the descent arguments for generators
+of the function field (pole orders, values of coefficients, and behaviour at the cusp).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_coeffEmb_injective.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_coeffEmb_injective
+
+open ModularCurve IntermediateField HahnSeries
+
+theorem solution (L : Type*) [Field L] [Algebra ℚ L] :
+    Function.Injective (ModularCurve.coeffEmb L) :=
+  coeffMap_injective (FaithfulSMul.algebraMap_injective ℚ L)
+
+end S_ModularCurve_coeffEmb_injective
+end P2MW
+export P2MW.S_ModularCurve_coeffEmb_injective (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.coeffEmb_injective (L : Type*) [Field L] [Algebra ℚ L] :
+    Function.Injective (ModularCurve.coeffEmb L) :=
+  solution L
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeffEmb_jq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeffEmb_jq.lean
new file mode 100644
index 0000000000..81bd9cdf1e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeffEmb_jq.lean
@@ -0,0 +1,113 @@
+/-
+Based on Prove2Me node ModularCurve.coeffEmb_jq
+(b0e612d7-234d-5adf-ab0c-b154cd1e1d4c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a32be3f5-ed52-5bd9-b716-43aa69032e10
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+
+import Mathlib.RingTheory.Algebraic.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Coefficient embedding sends j(q) over ℚ to j(q) over L
+
+Theorem statement: `ModularCurve.coeffEmb_jq` (`b0e612d7-234d-5adf-ab0c-b154cd1e1d4c`), by Claude,
+2026-09-05.
+
+Proof: submission `a32be3f5-ed52-5bd9-b716-43aa69032e10`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbb{Q}$-algebra structure. Write $\mathtt{jNum} \in
+\mathbb{Z}[[q]]$ for the integral power series $E_4^3 \cdot \eta^{-24}$-type numerator built from
+`eisenstein4` and `dedekindEtaUnitInv`, and for a commutative ring $K$ let `jqModC K` be the Laurent
+series $q^{-1}\cdot \iota(\mathtt{jNum}\otimes K)$, that is, the product of the Hahn series
+$\mathrm{single}\,(-1)\,1$ with the image of $\mathtt{jNum}$ under coefficientwise reduction along
+$\mathbb{Z} \to K$, viewed as a Laurent series. Let `jq` be the same construction over $\mathbb{Q}$,
+namely $\mathrm{single}\,(-1)\,1$ times the Laurent series attached to $\mathtt{jNumQ} =
+\mathtt{jNum}$ mapped along $\mathbb{Z} \to \mathbb{Q}$. Let `coeffEmb L` be the ring homomorphism
+$\mathbb{Q}((q)) \to L((q))$ obtained by applying the structure map $\mathbb{Q} \to L$ to each
+coefficient. The theorem asserts that `coeffEmb L` carries `jq` to `jqModC L`: the two routes to the
+$q$-expansion of $j$ in $L((q))$, one factoring through $\mathbb{Q}$ and one reducing the integral
+series directly, coincide.
+
+This is the compatibility of the $q$-expansion of the modular invariant $j$ with base change of
+coefficients from $\mathbb{Q}$ to an arbitrary field of characteristic zero. It is used throughout
+the treatment of the modular curves $X_0(N)$ and of $q$-expansions of forms, for instance in
+computing degrees of field extensions generated by $j$ and in transferring $q$-expansion identities
+between coefficient fields.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_coeffEmb_jq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_coeffEmb_jq
+
+noncomputable section
+open HahnSeries
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC jqNModC jqModC_rat map_jqModC qExpand qExpand_coeff_mul \
+  qExpand_coeff_of_not_dvd jq jqN coeffMap coeffEmb"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+theorem ModularCurve.CharLRows.coeffEmb_jq (L : Type*) [Field L] [Algebra ℚ L] :
+    coeffEmb L jq = jqModC L := by
+  rw [← jqModC_rat]
+  exact map_jqModC (algebraMap ℚ L)
+
+p2m_open_scoped "ModularCurve" in
+theorem ModularCurve.CharLRows.map_qExpand_aux {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S)
+    (N : ℕ) [NeZero N]
+    (x : LaurentSeries R) : (qExpand R N x).map f = qExpand S N (x.map f) := by
+  ext k
+  rw [HahnSeries.map_coeff]
+  by_cases hk : (N : ℤ) ∣ k
+  · obtain ⟨m, rfl⟩ := hk
+    rw [qExpand_coeff_mul, qExpand_coeff_mul, HahnSeries.map_coeff]
+  · rw [qExpand_coeff_of_not_dvd N _ hk, qExpand_coeff_of_not_dvd N _ hk, map_zero]
+
+p2m_open_scoped "ModularCurve" in
+theorem ModularCurve.CharLRows.coeffEmb_jqN (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    coeffEmb L (jqN N) = jqNModC L N := by
+  rw [jqN, jqNModC, ← CharLRows.coeffEmb_jq L]
+  exact CharLRows.map_qExpand_aux (algebraMap ℚ L) N jq
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_coeffEmb_jq.ModularCurve in
+theorem solution (L : Type*) [Field L] [Algebra ℚ L] :
+    coeffEmb L jq = jqModC L :=
+  CharLRows.coeffEmb_jq L
+
+end S_ModularCurve_coeffEmb_jq
+end P2MW
+export P2MW.S_ModularCurve_coeffEmb_jq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.coeffEmb_jq (L : Type*) [Field L] [Algebra ℚ L] :
+    coeffEmb L jq = jqModC L :=
+  solution L
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeffEmb_jqN.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeffEmb_jqN.lean
new file mode 100644
index 0000000000..7cd6f35ee4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeffEmb_jqN.lean
@@ -0,0 +1,113 @@
+/-
+Based on Prove2Me node ModularCurve.coeffEmb_jqN
+(8094905f-a606-5432-92de-2a3ebb4fd545) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e0a94de0-7b4f-5ed1-b18d-fab351f21872
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+
+import Mathlib.RingTheory.Algebraic.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Coefficient embedding commutes with the q^N-expansion of j
+
+Theorem statement: `ModularCurve.coeffEmb_jqN` (`8094905f-a606-5432-92de-2a3ebb4fd545`), by Claude,
+2026-09-05.
+
+Proof: submission `e0a94de0-7b4f-5ed1-b18d-fab351f21872`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbb{Q}$-algebra structure and let $N$ be a natural number
+that is nonzero. Consider the coefficientwise ring homomorphism `coeffEmb L : LaurentSeries ℚ →+*
+LaurentSeries L`, which is `coeffMap` applied to the structure map $\mathbb{Q} \to L$, i.e. the map
+applying $\mathbb{Q} \to L$ to each coefficient of a formal Laurent series (a Hahn series over
+$\mathbb{Z}$). On the source side, `jqN N` is `qExpand ℚ N` applied to the rational $q$-expansion
+`jq` of $j$, where `qExpand R N` is the ring homomorphism on Laurent series induced by embedding the
+exponent group $\mathbb{Z}$ into itself by multiplication by $N$, that is the substitution $q
+\mapsto q^N$. On the target side, `jqNModC L N` is `qExpand L N` applied to `jqModC L`, the series
+$q^{-1}$ times the image under $\mathbb{Z} \to L$ of the integral power series `jNum`. The assertion
+is the equality of the two elements of `LaurentSeries L`: transporting coefficients from
+$\mathbb{Q}$ to $L$ after substituting $q \mapsto q^N$ in `jq` gives exactly the $L$-coefficient
+series `jqNModC L N`.
+
+This is the compatibility of the $q$-expansion of the modular invariant $j(q^N)$ with change of
+coefficient field: the rational expansion has integral coefficients, so its image in $L((q))$ is the
+series constructed directly over $L$. It is used throughout the treatment of the modular curves
+$X_0(N)$ over general characteristic-zero base fields, where expansions over $L$ must be identified
+with the images of the rational ones.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_coeffEmb_jqN.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_coeffEmb_jqN
+
+noncomputable section
+open HahnSeries
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC jqNModC jqModC_rat map_jqModC qExpand qExpand_coeff_mul \
+  qExpand_coeff_of_not_dvd jq jqN coeffMap coeffEmb"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+theorem ModularCurve.CharLRows.coeffEmb_jq (L : Type*) [Field L] [Algebra ℚ L] :
+    coeffEmb L jq = jqModC L := by
+  rw [← jqModC_rat]
+  exact map_jqModC (algebraMap ℚ L)
+
+p2m_open_scoped "ModularCurve" in
+theorem ModularCurve.CharLRows.map_qExpand_aux {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S)
+    (N : ℕ) [NeZero N]
+    (x : LaurentSeries R) : (qExpand R N x).map f = qExpand S N (x.map f) := by
+  ext k
+  rw [HahnSeries.map_coeff]
+  by_cases hk : (N : ℤ) ∣ k
+  · obtain ⟨m, rfl⟩ := hk
+    rw [qExpand_coeff_mul, qExpand_coeff_mul, HahnSeries.map_coeff]
+  · rw [qExpand_coeff_of_not_dvd N _ hk, qExpand_coeff_of_not_dvd N _ hk, map_zero]
+
+p2m_open_scoped "ModularCurve" in
+theorem ModularCurve.CharLRows.coeffEmb_jqN (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    coeffEmb L (jqN N) = jqNModC L N := by
+  rw [jqN, jqNModC, ← CharLRows.coeffEmb_jq L]
+  exact CharLRows.map_qExpand_aux (algebraMap ℚ L) N jq
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_coeffEmb_jqN.ModularCurve in
+theorem solution (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    coeffEmb L (jqN N) = jqNModC L N :=
+  CharLRows.coeffEmb_jqN L N
+
+end S_ModularCurve_coeffEmb_jqN
+end P2MW
+export P2MW.S_ModularCurve_coeffEmb_jqN (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.coeffEmb_jqN (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    coeffEmb L (jqN N) = jqNModC L N :=
+  solution L N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeffEmb_qExpand.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeffEmb_qExpand.lean
new file mode 100644
index 0000000000..2f76226a79
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeffEmb_qExpand.lean
@@ -0,0 +1,85 @@
+/-
+Based on Prove2Me node ModularCurve.coeffEmb_qExpand
+(84acfb74-3619-5a14-903d-99887aa67993) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9d7acf02-2ba9-5f6a-96e7-487ba04adacc
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Coefficient extension commutes with q↦ qⁿ
+
+Theorem statement: `ModularCurve.coeffEmb_qExpand` (`84acfb74-3619-5a14-903d-99887aa67993`), by
+Claude, 2026-09-05.
+
+Proof: submission `9d7acf02-2ba9-5f6a-96e7-487ba04adacc`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbb{Q}$-algebra structure, let $n$ be a nonzero natural
+number and let $x$ be a formal Laurent series over $\mathbb{Q}$, that is an element of
+`LaurentSeries ℚ` $=$ `HahnSeries ℤ ℚ`. Two ring homomorphisms are involved. First,
+[`ModularCurve.coeffEmb L`](def/ModularCurve_LaurentCoeff.html#L81) is
+[`ModularCurve.coeffMap`](def/ModularCurve_LaurentCoeff.html#L16) applied to the structure map
+$\mathbb{Q}\to L$: it is the coefficientwise ring homomorphism $\mathbb{Q}((q))\to L((q))$ sending a
+Hahn series to its image under the map induced on coefficients, $\sum_k a_k q^k\mapsto\sum_k
+\iota(a_k)q^k$. Second, for a commutative ring $R$, [`ModularCurve.qExpand R
+n`](def/ModularCurve_X0.html#L25) is the ring homomorphism on `LaurentSeries R` obtained by
+embedding the index domain along the order-preserving injective additive map $k\mapsto nk$ on
+$\mathbb{Z}$, i.e. the substitution $q\mapsto q^n$. The assertion is the equality of the two
+composites at $x$: applying $q\mapsto q^n$ over $\mathbb{Q}$ and then extending coefficients to $L$
+gives the same element of $L((q))$ as extending coefficients first and then applying $q\mapsto q^n$
+over $L$.
+
+A compatibility between the two basic operations on $q$-expansions used throughout the treatment of
+modular curves: extension of the field of coefficients and the degeneracy substitution $q\mapsto
+q^n$. It is invoked whenever $q$-expansion identities over $\mathbb{Q}$ are transported to a larger
+coefficient field, for instance in the analysis of level structures and of the fields generated by
+$q$-expansions of modular functions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_coeffEmb_qExpand.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_coeffEmb_qExpand
+
+open ModularCurve IntermediateField HahnSeries
+
+theorem solution (L : Type*) [Field L] [Algebra ℚ L] (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    ModularCurve.coeffEmb L (ModularCurve.qExpand ℚ n x) = ModularCurve.qExpand L n
+      (ModularCurve.coeffEmb L x) :=
+  coeffMap_qExpand _ n x
+
+end S_ModularCurve_coeffEmb_qExpand
+end P2MW
+export P2MW.S_ModularCurve_coeffEmb_qExpand (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.coeffEmb_qExpand (L : Type*) [Field L] [Algebra ℚ L] (n : ℕ) [NeZero n]
+    (x : LaurentSeries ℚ) :
+    ModularCurve.coeffEmb L (ModularCurve.qExpand ℚ n x) = ModularCurve.qExpand L n
+      (ModularCurve.coeffEmb L x) :=
+  solution L n x
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeffMap_injective.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeffMap_injective.lean
new file mode 100644
index 0000000000..84f0139b52
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeffMap_injective.lean
@@ -0,0 +1,78 @@
+/-
+Based on Prove2Me node ModularCurve.coeffMap_injective
+(b5b348dd-46df-59d9-bc45-da150bc74902) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3c959031-c535-57cb-b5b9-fe1cf6a83301
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Coefficientwise map on Laurent series preserves injectivity
+
+Theorem statement: `ModularCurve.coeffMap_injective` (`b5b348dd-46df-59d9-bc45-da150bc74902`), by
+Claude, 2026-09-05.
+
+Proof: submission `3c959031-c535-57cb-b5b9-fe1cf6a83301`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ and $S$ be commutative rings and let $f\colon R\to S$ be a ring homomorphism. The project's
+[`ModularCurve.coeffMap f`](def/ModularCurve_LaurentCoeff.html#L16) is the ring homomorphism
+$R((q))\to S((q))$ between formal Laurent series rings, realised as Hahn series with value group
+$\mathbb{Z}$, that applies $f$ to each coefficient: the series $x$ with coefficients
+$(x_k)_{k\in\mathbb{Z}}$ is sent to the series with coefficients $(f(x_k))_{k\in\mathbb{Z}}$ (its
+support being contained in that of $x$), and this assignment respects $0$, $1$, addition and
+multiplication. The assertion is that if $f$ is injective as a function $R\to S$, then
+[`ModularCurve.coeffMap f`](def/ModularCurve_LaurentCoeff.html#L16) is injective as a function
+$R((q))\to S((q))$.
+
+An elementary functoriality statement for the coefficientwise extension of a ring homomorphism to
+formal Laurent series; it underlies the coefficient embedding $\mathbb{Q}((q))\to L((q))$ used to
+base change intermediate fields of $\mathbb{Q}((q))/\mathbb{Q}$ to a field $L$ of characteristic
+zero. It is invoked throughout the treatment of $q$-expansions on modular curves, for instance in
+the constructions of charts, poles and level fields attached to full-level structures.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_coeffMap_injective.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_coeffMap_injective
+
+open ModularCurve IntermediateField HahnSeries
+
+theorem solution {R S : Type*} [CommRing R] [CommRing S] {f : R →+* S} (hf : Function.Injective f) :
+    Function.Injective (ModularCurve.coeffMap f) :=
+  fun x y hxy => by
+  ext k
+  exact hf (by simpa using congrArg (fun z => HahnSeries.coeff z k) hxy)
+
+end S_ModularCurve_coeffMap_injective
+end P2MW
+export P2MW.S_ModularCurve_coeffMap_injective (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.coeffMap_injective {R S : Type*} [CommRing R] [CommRing S] {f : R →+* S}
+    (hf : Function.Injective f) :
+    Function.Injective (ModularCurve.coeffMap f) :=
+  solution hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeffMap_qExpand.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeffMap_qExpand.lean
new file mode 100644
index 0000000000..795d67cb33
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeffMap_qExpand.lean
@@ -0,0 +1,90 @@
+/-
+Based on Prove2Me node ModularCurve.coeffMap_qExpand
+(39773b6e-30c2-5a33-a065-542cc042c58e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 388768f4-c83e-56ec-ae62-5a3757fac62e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Coefficientwise maps commute with q↦ qⁿ
+
+Theorem statement: `ModularCurve.coeffMap_qExpand` (`39773b6e-30c2-5a33-a065-542cc042c58e`), by
+Claude, 2026-09-05.
+
+Proof: submission `388768f4-c83e-56ec-ae62-5a3757fac62e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ and $S$ be commutative rings, let $f \colon R \to S$ be a ring homomorphism, let $n$ be a
+nonzero natural number, and let $x$ be a formal Laurent series over $R$, that is, an element of
+`LaurentSeries R`, the Hahn series over $\mathbb{Z}$ with coefficients in $R$. Here
+[`ModularCurve.coeffMap f`](def/ModularCurve_LaurentCoeff.html#L16) is the ring homomorphism
+$\mathrm{LaurentSeries}\,R \to \mathrm{LaurentSeries}\,S$ obtained by applying $f$ to each
+coefficient, and [`ModularCurve.qExpand R n`](def/ModularCurve_X0.html#L25) is the ring homomorphism
+of `LaurentSeries R` given by embedding the index domain along multiplication by $n$ on $\mathbb{Z}$
+(an injective, strictly monotone additive map since $n \neq 0$), i.e. the substitution $q \mapsto
+q^{n}$, which sends $\sum_k a_k q^k$ to $\sum_k a_k q^{nk}$. The assertion is the equality
+$$\mathrm{coeffMap}\,f\,\bigl(\mathrm{qExpand}_R\,n\,(x)\bigr) \;=\;
+\mathrm{qExpand}_S\,n\,\bigl(\mathrm{coeffMap}\,f\,(x)\bigr),$$
+so that reindexing the exponents along $k \mapsto nk$ and transporting the coefficients along $f$
+commute.
+
+This is the elementary compatibility between change of coefficient ring and the substitution $q
+\mapsto q^{n}$ on formal Laurent series, the operation that carries the $q$-expansion of $f(\tau)$
+to that of $f(n\tau)$. It is used throughout the treatment of modular curves and their function
+fields, in particular when coefficientwise field embeddings or Galois actions are compared with the
+degeneracy maps of the modular tower.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_coeffMap_qExpand.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_coeffMap_qExpand
+
+open ModularCurve IntermediateField HahnSeries
+
+theorem solution {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S) (n : ℕ) [NeZero n]
+    (x : LaurentSeries R) :
+    ModularCurve.coeffMap f (ModularCurve.qExpand R n x) = ModularCurve.qExpand S n
+      (ModularCurve.coeffMap f x) :=
+  by
+  ext k
+  by_cases hk : (n : ℤ) ∣ k
+  · obtain ⟨m, rfl⟩ := hk
+    rw [coeffMap_coeff, qExpand_coeff_mul, qExpand_coeff_mul, coeffMap_coeff]
+  · rw [coeffMap_coeff, qExpand_coeff_of_not_dvd n _ hk, qExpand_coeff_of_not_dvd n _ hk,
+      map_zero]
+
+end S_ModularCurve_coeffMap_qExpand
+end P2MW
+export P2MW.S_ModularCurve_coeffMap_qExpand (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.coeffMap_qExpand {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S) (n : ℕ)
+    [NeZero n] (x : LaurentSeries R) :
+    ModularCurve.coeffMap f (ModularCurve.qExpand R n x) = ModularCurve.qExpand S n
+      (ModularCurve.coeffMap f x) :=
+  solution f n x
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeff_eq_zero_of_hasSum_of_slash_invariant.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeff_eq_zero_of_hasSum_of_slash_invariant.lean
new file mode 100644
index 0000000000..94a569f90f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeff_eq_zero_of_hasSum_of_slash_invariant.lean
@@ -0,0 +1,264 @@
+/-
+Based on Prove2Me node ModularCurve.coeff_eq_zero_of_hasSum_of_slash_invariant
+(0e938601-a688-501e-85a5-4562c1fd5267) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 0d689232-56a2-596e-9b69-a9106d3230c1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Exp
+public import Mathlib.Analysis.Complex.UpperHalfPlane.MoebiusAction
+
+import Mathlib.NumberTheory.ModularForms.NormTrace
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# SL₂(ℤ)-invariance plus holomorphic q-expansion forces constancy
+
+Theorem statement: `ModularCurve.coeff_eq_zero_of_hasSum_of_slash_invariant`
+(`0e938601-a688-501e-85a5-4562c1fd5267`), by Claude, 2026-09-05.
+
+Proof: submission `0d689232-56a2-596e-9b69-a9106d3230c1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F \colon \mathfrak{H} \to \mathbb{C}$ be a function on the upper half-plane and let $(c_m)_{m
+\ge 0}$ be a sequence of complex numbers. Two hypotheses are imposed. First, for every $\tau \in
+\mathfrak{H}$ the family $m \mapsto c_m\, q^m$, where $q = e^{2\pi i \tau}$ is Mathlib's
+$q$-parameter `Function.Periodic.qParam 1` evaluated at $\tau$, is summable with sum $F(\tau)$; thus
+$F$ is everywhere given by a convergent power series in $q$ with no polar part and no negative-index
+terms. Second, $F$ is invariant under the Möbius action of $\mathrm{SL}_2(\mathbb{Z})$ on
+$\mathfrak{H}$: $F(\gamma \cdot \tau) = F(\tau)$ for all $\gamma \in \mathrm{SL}_2(\mathbb{Z})$ and
+all $\tau \in \mathfrak{H}$. The conclusion is that $c_m = 0$ for every index $m \ne 0$.
+Consequently $F$ is the constant function with value $c_0$. No holomorphy or growth condition on $F$
+is assumed beyond the existence of the convergent $q$-expansion itself.
+
+This is the weight-zero Liouville step: a modular function for the full level-one group which is
+holomorphic on $\mathfrak{H}$ and at the cusp is constant, here recorded as the vanishing of all
+higher $q$-expansion coefficients. It is used in the proof that the coefficients of the modular
+polynomial, viewed as functions on the upper half-plane, lie in the ring generated by $j$, via
+[`ModularCurve.mem_adjoin_jq_of_hasSum_of_slash_invariant`]
+(thm.html#ModularCurve.mem_adjoin_jq_of_hasSum_of_slash_invariant).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_coeff_eq_zero_of_hasSum_of_slash_invariant.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_coeff_eq_zero_of_hasSum_of_slash_invariant
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology Function
+open scoped MatrixGroups ModularForm
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+
+namespace Realized
+
+variable {h : ℝ} {F : ℍ → ℂ} {c : ℕ → ℂ}
+
+lemma norm_qParam_lt_one_of_pos (hh : 0 < h) (τ : ℍ) : ‖𝕢 h (τ : ℂ)‖ < 1 := by
+  rw [Periodic.norm_qParam, Real.exp_lt_one_iff, neg_mul, coe_im, neg_mul, neg_div, neg_lt_zero]
+  exact div_pos (by positivity [τ.im_pos]) hh
+
+lemma hasSum_cuspFunction_punctured (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) {q : ℂ} (hq : ‖q‖ < 1)
+    (hq1 : q ≠ 0) : HasSum (fun m : ℕ => c m * q ^ m) (cuspFunction h F q) := by
+  have h1 := Periodic.im_invQParam_pos_of_norm_lt_one hh hq hq1
+  let τ : ℍ := ⟨Periodic.invQParam h q, h1⟩
+  have h2 := Periodic.cuspFunction_eq_of_nonzero h (F ∘ ofComplex) hq1
+  have h3 : cuspFunction h F q = F τ := by
+    simpa [τ, cuspFunction, UpperHalfPlane.ofComplex_apply_of_im_pos h1] using h2
+  have h4 : 𝕢 h (τ : ℂ) = q := Periodic.qParam_right_inv hh.ne' hq1
+  rw [h3, ← h4]
+  exact hF τ
+
+lemma hasFPowerSeriesOnBall_update (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) :
+    HasFPowerSeriesOnBall (update (cuspFunction h F) 0 (c 0)) (.ofScalars ℂ c) 0 1 := by
+  constructor
+  · refine le_of_forall_lt_imp_le_of_dense fun r hr ↦ ?_
+    rcases eq_or_ne r 0 with rfl | hr'
+    · simp
+    · lift r to NNReal using hr.ne_top
+      let : FiniteDimensional ℝ ℂ := basisOneI.finiteDimensional_of_finite
+      apply FormalMultilinearSeries.le_radius_of_summable
+      simpa [norm_mul, mul_comm] using
+        (hasSum_cuspFunction_punctured hh hF (q := r) (by simpa using hr)
+          (mod_cast hr')).summable.norm
+  · simp
+  · intro y hy
+    rw [zero_add]
+    rw [← ENNReal.coe_one, Metric.eball_coe, NNReal.coe_one, mem_ball_zero_iff] at hy
+    rcases eq_or_ne y 0 with rfl | hy'
+    · simpa +contextual [zero_pow_eq] using hasSum_ite_eq 0 (c 0)
+    · simpa [update_of_ne hy', mul_comm] using hasSum_cuspFunction_punctured hh hF hy hy'
+
+def discFun (h : ℝ) (F : ℍ → ℂ) (c : ℕ → ℂ) : ℂ → ℂ := update (cuspFunction h F) 0 (c 0)
+
+lemma hasSum_discFun (hh : 0 < h) (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ))
+    {q : ℂ} (hq : ‖q‖ < 1) : HasSum (fun m : ℕ => c m * q ^ m) (discFun h F c q) := by
+  have hy : q ∈ Metric.eball (0 : ℂ) 1 := by
+    rw [← ENNReal.coe_one, Metric.eball_coe]; simpa using hq
+  have h := (hasFPowerSeriesOnBall_update hh hF).hasSum hy
+  rw [zero_add] at h
+  simpa [discFun, mul_comm] using h
+
+lemma apply_eq_discFun (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ))
+    (τ : ℍ) : F τ = discFun h F c (𝕢 h (τ : ℂ)) :=
+  (hF τ).unique (hasSum_discFun hh hF (norm_qParam_lt_one_of_pos hh τ))
+
+lemma differentiableOn_discFun (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) :
+    DifferentiableOn ℂ (discFun h F c) (Metric.ball 0 1) := by
+  have h1 := (hasFPowerSeriesOnBall_update hh hF).differentiableOn
+  rwa [← ENNReal.coe_one, Metric.eball_coe, NNReal.coe_one] at h1
+
+lemma continuousAt_discFun (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) {q : ℂ} (hq : ‖q‖ < 1) :
+    ContinuousAt (discFun h F c) q :=
+  ((differentiableOn_discFun hh hF).differentiableAt
+    (Metric.isOpen_ball.mem_nhds (by simpa using hq))).continuousAt
+
+lemma discFun_zero : discFun h F c 0 = c 0 := by simp [discFun]
+
+theorem mdifferentiable (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) :
+    MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) F := by
+  rw [UpperHalfPlane.mdifferentiable_iff]
+  have h1 : DifferentiableOn ℂ (fun z : ℂ => discFun h F c (𝕢 h z)) {z : ℂ | 0 < z.im} := by
+    intro z hz
+    have hzq : ‖𝕢 h z‖ < 1 := by
+      have := norm_qParam_lt_one_of_pos hh ⟨z, hz⟩
+      simpa using this
+    exact (((differentiableOn_discFun hh hF).differentiableAt
+      (Metric.isOpen_ball.mem_nhds (by simpa using hzq))).comp z
+      ((Periodic.differentiable_qParam (h := h)) z)).differentiableWithinAt
+  refine h1.congr fun z hz => ?_
+  simp only [Function.comp_apply, apply_eq_discFun hh hF, ofComplex_apply_of_im_pos hz]
+
+theorem tendsto_atImInfty (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) :
+    Tendsto F atImInfty (𝓝 (c 0)) := by
+  have h1 : Tendsto (fun τ : ℍ => discFun h F c (𝕢 h (τ : ℂ))) atImInfty (𝓝 (discFun h F c 0)) :=
+    (continuousAt_discFun hh hF (q := 0) (by simp)).tendsto.comp (qParam_tendsto_atImInfty hh)
+  rw [discFun_zero] at h1
+  exact h1.congr fun τ => (apply_eq_discFun hh hF τ).symm
+
+theorem isBoundedAtImInfty (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) :
+    IsBoundedAtImInfty F :=
+  (tendsto_atImInfty hh hF).isBigO_one ℝ
+
+theorem periodic (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) :
+    Periodic (F ∘ ofComplex) h := by
+  intro w
+  by_cases hw : 0 < w.im
+  · have hw' : 0 < (w + h).im := by simpa using hw
+    simp only [Function.comp_apply, apply_eq_discFun hh hF, ofComplex_apply_of_im_pos hw,
+      ofComplex_apply_of_im_pos hw']
+    congr 1
+    simp only [Periodic.qParam]
+    rw [show 2 * ↑Real.pi * Complex.I * (w + ↑h) / ↑h = 2 * ↑Real.pi * Complex.I * w / ↑h + 2 *
+      ↑Real.pi * Complex.I by
+      field_simp [(Complex.ofReal_ne_zero.mpr hh.ne')]]
+    rw [Complex.exp_add, Complex.exp_two_pi_mul_I, mul_one]
+  · push Not at hw
+    have hw' : (w + h).im ≤ 0 := by simpa using hw
+    simp only [Function.comp_apply, ofComplex_apply_eq_of_im_nonpos hw' hw]
+
+theorem coeff_unique {d : ℕ → ℂ} (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ))
+    (hF' : ∀ τ : ℍ, HasSum (fun m : ℕ => d m * 𝕢 h (τ : ℂ) ^ m) (F τ)) : c = d := by
+  have hc := hasFPowerSeriesOnBall_update hh hF
+  have hd := hasFPowerSeriesOnBall_update hh hF'
+  have hlim : ∀ {e : ℕ → ℂ}, HasFPowerSeriesOnBall (update (cuspFunction h F) 0 (e 0)) (.ofScalars ℂ
+    e) 0 1 →
+      Tendsto (cuspFunction h F) (𝓝[≠] 0) (𝓝 (e 0)) := by
+    intro e he
+    have h1 : Tendsto (update (cuspFunction h F) 0 (e 0)) (𝓝[≠] 0) (𝓝 (e 0)) := by
+      have := he.hasFPowerSeriesAt.continuousAt.tendsto
+      rw [update_self] at this
+      exact this.mono_left nhdsWithin_le_nhds
+    refine h1.congr' ?_
+    filter_upwards [self_mem_nhdsWithin] with z hz using update_of_ne hz ..
+  have h0 : c 0 = d 0 := tendsto_nhds_unique (hlim hc) (hlim hd)
+  have hd' : HasFPowerSeriesOnBall (update (cuspFunction h F) 0 (c 0)) (.ofScalars ℂ d) 0 1 :=
+    h0 ▸ hd
+  have heq := hc.hasFPowerSeriesAt.eq_formalMultilinearSeries hd'.hasFPowerSeriesAt
+  funext m
+  simpa using congr_arg (FormalMultilinearSeries.coeff · m) heq
+
+end Realized
+
+end ModularCurve
+
+open ModularCurve in
+theorem solution {F : UpperHalfPlane → ℂ} {c : ℕ → ℂ} (hF : ∀ τ : UpperHalfPlane, HasSum (fun m : ℕ
+  => c m * Function.Periodic.qParam 1 (τ : ℂ) ^ m) (F τ)) (hinv : ∀ (γ : Matrix.SpecialLinearGroup
+  (Fin 2) ℤ) (τ : UpperHalfPlane), F (γ • τ) = F τ) {m : ℕ} (hm : m ≠ 0) :
+    c m = 0 := by
+  have hslash : ∀ γ : SL(2, ℤ), F ∣[(0 : ℤ)] γ = F := fun γ => by
+    funext τ
+    rw [ModularForm.SL_slash_apply, hinv, neg_zero, zpow_zero, mul_one]
+  let f : ModularForm 𝒮ℒ 0 :=
+    { toFun := F
+      slash_action_eq' := fun A hA => by
+        obtain ⟨γ, rfl⟩ := hA
+        exact hslash γ
+      holo' := Realized.mdifferentiable one_pos hF
+      bdd_at_cusps' := fun {cusp} hc => by
+        rw [OnePoint.isBoundedAt_iff_forall_SL2Z hc]
+        intro γ _
+        rw [hslash γ]
+        exact Realized.isBoundedAtImInfty one_pos hF }
+  obtain ⟨κ, hκ⟩ := ModularForm.eq_const_of_weight_zero f
+  have hFκ : ∀ τ : ℍ, F τ = κ := fun τ => by
+    exact congr_fun hκ τ
+  have hF' : ∀ τ : ℍ, HasSum (fun m : ℕ => (Pi.single (M := fun _ => ℂ) 0 κ m) * 𝕢 1 (τ : ℂ) ^ m) (F
+    τ) :=
+    by
+    intro τ
+    rw [hFκ τ]
+    have := hasSum_ite_eq 0 κ
+    refine this.congr_fun fun n => ?_
+    by_cases hn : n = 0
+    · subst hn; simp
+    · simp [hn]
+  have heq := Realized.coeff_unique one_pos hF hF'
+  rw [heq, Pi.single_apply, ite_eq_right hm]
+
+end
+
+end S_ModularCurve_coeff_eq_zero_of_hasSum_of_slash_invariant
+end P2MW
+export P2MW.S_ModularCurve_coeff_eq_zero_of_hasSum_of_slash_invariant (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.coeff_eq_zero_of_hasSum_of_slash_invariant {F : UpperHalfPlane → ℂ} {c : ℕ → ℂ}
+  (hF : ∀ τ : UpperHalfPlane, HasSum (fun m : ℕ => c m * Function.Periodic.qParam 1 (τ : ℂ) ^ m) (F
+  τ)) (hinv : ∀ (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) (τ : UpperHalfPlane), F (γ • τ) = F τ) {m
+  : ℕ} (hm : m ≠ 0) :
+    c m = 0 :=
+  solution hF hinv hm
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeff_jqModC_neg_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeff_jqModC_neg_one.lean
new file mode 100644
index 0000000000..c45dad3fe2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeff_jqModC_neg_one.lean
@@ -0,0 +1,162 @@
+/-
+Based on Prove2Me node ModularCurve.coeff_jqModC_neg_one
+(04648caf-af88-5da0-a32d-39381fd62321) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission fc930705-c839-5035-97c2-8bbf0890d842
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import Mathlib.RingTheory.Algebraic.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The q⁻¹ coefficient of ̄ j is 1
+
+Theorem statement: `ModularCurve.coeff_jqModC_neg_one` (`04648caf-af88-5da0-a32d-39381fd62321`), by
+Claude, 2026-09-05.
+
+Proof: submission `fc930705-c839-5035-97c2-8bbf0890d842`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a commutative ring. The Laurent series $\bar j =$ `jqModC K` $\in K((q))$ is by
+definition the product of the Hahn series `HahnSeries.single (-1) 1`, i.e. the monomial $q^{-1}$
+with coefficient $1$, with the image in $K((q))$ of the power series obtained from the integral
+power series `jNum` $= E_4^3 \cdot$ `dedekindEtaUnitInv` $\in \mathbb{Z}[[q]]$ by applying the ring
+homomorphism $\mathbb{Z} \to K$ coefficientwise and then including $K[[q]]$ into $K((q))$. The
+theorem asserts that the coefficient of this Laurent series at the exponent $-1 \in \mathbb{Z}$
+equals $1$ in $K$. No hypotheses beyond the commutative ring structure on $K$ are imposed; in
+particular $K$ may be trivial, in which case the assertion is vacuous, and $K$ may have any
+characteristic.
+
+This records the leading behaviour of the $q$-expansion $j = q^{-1} + 744 + \cdots$ after reduction
+of coefficients into an arbitrary commutative ring: the pole at the cusp has exact order one and
+normalised leading coefficient. It is the normalisation used throughout the treatment of
+$q$-expansions on $X_0(N)$ and of mod $p$ modular forms, and is invoked, among other places, in the
+identification of functions in the mod $p$ form and cusp form modules via their $q$-expansions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_coeff_jqModC_neg_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_coeff_jqModC_neg_one
+
+noncomputable section
+open HahnSeries
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC jNum constantCoeff_jNum ofPowerSeries_coeff_of_neg jq_pow"
+p2m_open "ModularCurve"
+namespace CharLRows
+
+variable (K : Type*) [CommRing K]
+
+theorem jqModC_pow (n : ℕ) :
+    (jqModC K) ^ n = HahnSeries.single (-(n : ℤ)) 1 *
+      HahnSeries.ofPowerSeries ℤ K ((jNum.map (Int.castRingHom K)) ^ n) := by
+  have h : n • (-1 : ℤ) = -(n : ℤ) := by simp
+  rw [jqModC, mul_pow, HahnSeries.single_pow, one_pow, h, ← map_pow]
+
+theorem constantCoeff_jNum_map : PowerSeries.constantCoeff (jNum.map (Int.castRingHom K)) = 1 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff, PowerSeries.coeff_map,
+    PowerSeries.coeff_zero_eq_constantCoeff,
+    constantCoeff_jNum, map_one]
+
+theorem coeff_jqModC_pow_self (n : ℕ) : ((jqModC K) ^ n).coeff (-(n : ℤ)) = 1 := by
+  rw [jqModC_pow, HahnSeries.coeff_single_mul, one_mul, sub_neg_eq_add, neg_add_cancel,
+    show (0 : ℤ) = ((0 : ℕ) : ℤ) from rfl, HahnSeries.ofPowerSeries_apply_coeff,
+    PowerSeries.coeff_zero_eq_constantCoeff, map_pow, constantCoeff_jNum_map, one_pow]
+
+theorem coeff_jqModC_pow_of_lt {n : ℕ} {m : ℤ} (hm : m < -(n : ℤ)) :
+    ((jqModC K) ^ n).coeff m = 0 := by
+  rw [jqModC_pow, HahnSeries.coeff_single_mul, one_mul]
+  exact ofPowerSeries_coeff_of_neg _ (by omega)
+
+theorem coeff_jqModC_neg_one : (jqModC K).coeff (-1 : ℤ) = 1 := by
+  simpa using coeff_jqModC_pow_self K 1
+
+theorem algebraMap_laurentSeries_eq_single (c : K) :
+    algebraMap K (LaurentSeries K) c = HahnSeries.single 0 c := by
+  have h1 : algebraMap K (PowerSeries K) c = PowerSeries.C c := by simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+  rfl
+
+theorem aeval_jqModC_eq_zero {p : Polynomial K} (hp : Polynomial.aeval (jqModC K) p = 0) :
+    p = 0 := by
+  by_contra hp0
+  set n := p.natDegree with hn
+  have hcoeff : (Polynomial.aeval (jqModC K) p).coeff (-(n : ℤ)) = p.coeff n := by
+    rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+      Finset.sum_eq_single n]
+    · rw [algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_zero_mul,
+        coeff_jqModC_pow_self, mul_one]
+    · intro i hi hin
+      have hilt : i < n := lt_of_le_of_ne (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hin
+      rw [algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_zero_mul,
+        coeff_jqModC_pow_of_lt, mul_zero]
+      omega
+    · intro hn'
+      exact absurd (Finset.self_mem_range_succ n) hn'
+  rw [hp] at hcoeff
+  simp only [HahnSeries.coeff_zero] at hcoeff
+  exact hp0 (Polynomial.leadingCoeff_eq_zero.mp hcoeff.symm)
+
+theorem transcendental_jqModC : Transcendental K (jqModC K) :=
+  transcendental_iff.mpr fun _ hp => aeval_jqModC_eq_zero K hp
+
+theorem jqModC_ne_zero [Nontrivial K] : jqModC K ≠ 0 := by
+  intro h
+  have h1 : (jqModC K).coeff (-1 : ℤ) = 1 := coeff_jqModC_neg_one K
+  rw [h, HahnSeries.coeff_zero] at h1
+  exact zero_ne_one h1
+
+theorem order_jqModC [Nontrivial K] : (jqModC K).order = -1 := by
+  refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero ?_) ?_
+  · rw [coeff_jqModC_neg_one]
+    exact one_ne_zero
+  · by_contra hlt
+    rw [not_le] at hlt
+    refine HahnSeries.coeff_order_eq_zero.not.mpr (jqModC_ne_zero K) ?_
+    have h := coeff_jqModC_pow_of_lt K (n := 1) (m := (jqModC K).order)
+      (by simpa using hlt)
+    simpa using h
+
+end CharLRows
+
+end ModularCurve
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_coeff_jqModC_neg_one.ModularCurve in
+theorem solution (K : Type*) [CommRing K] :
+    (jqModC K).coeff (-1 : ℤ) = 1 :=
+  CharLRows.coeff_jqModC_neg_one K
+
+end S_ModularCurve_coeff_jqModC_neg_one
+end P2MW
+export P2MW.S_ModularCurve_coeff_jqModC_neg_one (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.coeff_jqModC_neg_one (K : Type*) [CommRing K] :
+    (jqModC K).coeff (-1 : ℤ) = 1 :=
+  solution K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeff_jqModC_pow_of_lt.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeff_jqModC_pow_of_lt.lean
new file mode 100644
index 0000000000..2a2fee67a2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeff_jqModC_pow_of_lt.lean
@@ -0,0 +1,165 @@
+/-
+Based on Prove2Me node ModularCurve.coeff_jqModC_pow_of_lt
+(29ce3c8f-0582-52a8-98cf-a811e40f47e0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f4622861-e830-5563-b46e-80d090e0f430
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import Mathlib.RingTheory.Algebraic.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# No coefficients below q⁻ᵇ in j(q)ᵇ
+
+Theorem statement: `ModularCurve.coeff_jqModC_pow_of_lt` (`29ce3c8f-0582-52a8-98cf-a811e40f47e0`),
+by Claude, 2026-09-05.
+
+Proof: submission `f4622861-e830-5563-b46e-80d090e0f430`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a commutative ring, let $b$ be a natural number and let $m$ be an integer with $m < -b$.
+Here `jqModC K` is the element of the Laurent series field `LaurentSeries K` (Hahn series over $K$
+with value group $\mathbb{Z}$) given by $\mathrm{single}(-1,1)$, the series $q^{-1}$, multiplied by
+the image under `HahnSeries.ofPowerSeries` of the power series `jNum` $= E_4^3 \cdot
+\eta$-unit-inverse $\in \mathbb{Z}[[q]]$ with its coefficients pushed into $K$ along the canonical
+ring homomorphism $\mathbb{Z} \to K$; that is, the $q$-expansion of the modular invariant $j$ read
+in $K((q))$. The assertion is that the coefficient of $q^m$ in the $b$-th power $(\mathtt{jqModC }
+K)^b$ vanishes. Equivalently, $(\mathtt{jqModC } K)^b$ lies in $q^{-b}\,K[[q]]$: it has a pole at
+$q=0$ of order at most $b$. No hypothesis beyond $m < -b$ is imposed; in particular $K$ may have
+characteristic $p$ or be non-reduced, and the case $b = 0$ is included.
+
+This is the elementary statement that the $q$-expansion of $j$ has leading term $q^{-1}$, so that
+its powers have poles of bounded order, transported to an arbitrary coefficient ring. It underlies
+the degree and order bookkeeping for $q$-expansions of modular functions on $X_0(N)$, and is used,
+together with the companion computation of the coefficient in degree $-b$, to show that $j$ is
+transcendental over $K$ and that the order of `jqModC K` is $-1$; it is cited at several places
+where $q$-expansions of modular units and of level-$N$ analogues are compared.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_coeff_jqModC_pow_of_lt.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_coeff_jqModC_pow_of_lt
+
+noncomputable section
+open HahnSeries
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC jNum constantCoeff_jNum ofPowerSeries_coeff_of_neg jq_pow"
+p2m_open "ModularCurve"
+namespace CharLRows
+
+variable (K : Type*) [CommRing K]
+
+theorem jqModC_pow (n : ℕ) :
+    (jqModC K) ^ n = HahnSeries.single (-(n : ℤ)) 1 *
+      HahnSeries.ofPowerSeries ℤ K ((jNum.map (Int.castRingHom K)) ^ n) := by
+  have h : n • (-1 : ℤ) = -(n : ℤ) := by simp
+  rw [jqModC, mul_pow, HahnSeries.single_pow, one_pow, h, ← map_pow]
+
+theorem constantCoeff_jNum_map : PowerSeries.constantCoeff (jNum.map (Int.castRingHom K)) = 1 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff, PowerSeries.coeff_map,
+    PowerSeries.coeff_zero_eq_constantCoeff,
+    constantCoeff_jNum, map_one]
+
+theorem coeff_jqModC_pow_self (n : ℕ) : ((jqModC K) ^ n).coeff (-(n : ℤ)) = 1 := by
+  rw [jqModC_pow, HahnSeries.coeff_single_mul, one_mul, sub_neg_eq_add, neg_add_cancel,
+    show (0 : ℤ) = ((0 : ℕ) : ℤ) from rfl, HahnSeries.ofPowerSeries_apply_coeff,
+    PowerSeries.coeff_zero_eq_constantCoeff, map_pow, constantCoeff_jNum_map, one_pow]
+
+theorem coeff_jqModC_pow_of_lt {n : ℕ} {m : ℤ} (hm : m < -(n : ℤ)) :
+    ((jqModC K) ^ n).coeff m = 0 := by
+  rw [jqModC_pow, HahnSeries.coeff_single_mul, one_mul]
+  exact ofPowerSeries_coeff_of_neg _ (by omega)
+
+theorem coeff_jqModC_neg_one : (jqModC K).coeff (-1 : ℤ) = 1 := by
+  simpa using coeff_jqModC_pow_self K 1
+
+theorem algebraMap_laurentSeries_eq_single (c : K) :
+    algebraMap K (LaurentSeries K) c = HahnSeries.single 0 c := by
+  have h1 : algebraMap K (PowerSeries K) c = PowerSeries.C c := by simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+  rfl
+
+theorem aeval_jqModC_eq_zero {p : Polynomial K} (hp : Polynomial.aeval (jqModC K) p = 0) :
+    p = 0 := by
+  by_contra hp0
+  set n := p.natDegree with hn
+  have hcoeff : (Polynomial.aeval (jqModC K) p).coeff (-(n : ℤ)) = p.coeff n := by
+    rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+      Finset.sum_eq_single n]
+    · rw [algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_zero_mul,
+        coeff_jqModC_pow_self, mul_one]
+    · intro i hi hin
+      have hilt : i < n := lt_of_le_of_ne (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hin
+      rw [algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_zero_mul,
+        coeff_jqModC_pow_of_lt, mul_zero]
+      omega
+    · intro hn'
+      exact absurd (Finset.self_mem_range_succ n) hn'
+  rw [hp] at hcoeff
+  simp only [HahnSeries.coeff_zero] at hcoeff
+  exact hp0 (Polynomial.leadingCoeff_eq_zero.mp hcoeff.symm)
+
+theorem transcendental_jqModC : Transcendental K (jqModC K) :=
+  transcendental_iff.mpr fun _ hp => aeval_jqModC_eq_zero K hp
+
+theorem jqModC_ne_zero [Nontrivial K] : jqModC K ≠ 0 := by
+  intro h
+  have h1 : (jqModC K).coeff (-1 : ℤ) = 1 := coeff_jqModC_neg_one K
+  rw [h, HahnSeries.coeff_zero] at h1
+  exact zero_ne_one h1
+
+theorem order_jqModC [Nontrivial K] : (jqModC K).order = -1 := by
+  refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero ?_) ?_
+  · rw [coeff_jqModC_neg_one]
+    exact one_ne_zero
+  · by_contra hlt
+    rw [not_le] at hlt
+    refine HahnSeries.coeff_order_eq_zero.not.mpr (jqModC_ne_zero K) ?_
+    have h := coeff_jqModC_pow_of_lt K (n := 1) (m := (jqModC K).order)
+      (by simpa using hlt)
+    simpa using h
+
+end CharLRows
+
+end ModularCurve
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_coeff_jqModC_pow_of_lt.ModularCurve in
+theorem solution (K : Type*) [CommRing K] {b : ℕ} {m : ℤ} (hm : m < -(b : ℤ)) :
+    ((jqModC K) ^ b).coeff m = 0 :=
+  CharLRows.coeff_jqModC_pow_of_lt K hm
+
+end S_ModularCurve_coeff_jqModC_pow_of_lt
+end P2MW
+export P2MW.S_ModularCurve_coeff_jqModC_pow_of_lt (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.coeff_jqModC_pow_of_lt (K : Type*) [CommRing K] {b : ℕ} {m : ℤ}
+    (hm : m < -(b : ℤ)) :
+    ((jqModC K) ^ b).coeff m = 0 :=
+  solution K hm
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeff_jqModC_pow_self.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeff_jqModC_pow_self.lean
new file mode 100644
index 0000000000..db37c5f634
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_coeff_jqModC_pow_self.lean
@@ -0,0 +1,163 @@
+/-
+Based on Prove2Me node ModularCurve.coeff_jqModC_pow_self
+(1918cc1f-3da5-53c7-b67e-2a94e1e9e5f8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9265beca-7791-5ecb-8229-8f29ae6b70dc
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import Mathlib.RingTheory.Algebraic.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The coefficient of q⁻ᵇ in j(q)ᵇ is 1
+
+Theorem statement: `ModularCurve.coeff_jqModC_pow_self` (`1918cc1f-3da5-53c7-b67e-2a94e1e9e5f8`), by
+Claude, 2026-09-05.
+
+Proof: submission `9265beca-7791-5ecb-8229-8f29ae6b70dc`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a commutative ring and let $b$ be a natural number. Work in the Laurent series ring
+`LaurentSeries K`, realised as Hahn series over $\mathbb{Z}$ with coefficients in $K$. The element
+`jqModC K` is defined as the product of the Hahn series `HahnSeries.single (-1) 1`, i.e. $q^{-1}$,
+with the image under `HahnSeries.ofPowerSeries` of the power series `jNum` pushed forward along the
+canonical ring map $\mathbb{Z} \to K$, where `jNum` $=$ `eisenstein4`$^3\cdot$`dedekindEtaUnitInv`
+is the integral power series giving the holomorphic part of the $q$-expansion of the modular
+invariant. The theorem asserts that the coefficient of `jqModC K` raised to the power $b$ at the
+index $-(b : \mathbb{Z})$ equals $1$ in $K$. In other words, in $K((q))$ the $b$-th power of the
+reduction of the $j$-expansion has coefficient $1$ at $q^{-b}$; no hypothesis beyond commutativity
+of $K$ is imposed, and the case $b = 0$ is included.
+
+This records the normalisation of the leading term of the $q$-expansion of the modular invariant $j
+= q^{-1} + 744 + \cdots$: its leading coefficient is $1$, hence a unit in every coefficient ring,
+and the same holds for all powers. It is used throughout the treatment of the models of the modular
+curves, for instance in the construction and comparison of prolongations of places where the order
+of vanishing of the $j$-function has to be computed.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_coeff_jqModC_pow_self.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_coeff_jqModC_pow_self
+
+noncomputable section
+open HahnSeries
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC jNum constantCoeff_jNum ofPowerSeries_coeff_of_neg jq_pow"
+p2m_open "ModularCurve"
+namespace CharLRows
+
+variable (K : Type*) [CommRing K]
+
+theorem jqModC_pow (n : ℕ) :
+    (jqModC K) ^ n = HahnSeries.single (-(n : ℤ)) 1 *
+      HahnSeries.ofPowerSeries ℤ K ((jNum.map (Int.castRingHom K)) ^ n) := by
+  have h : n • (-1 : ℤ) = -(n : ℤ) := by simp
+  rw [jqModC, mul_pow, HahnSeries.single_pow, one_pow, h, ← map_pow]
+
+theorem constantCoeff_jNum_map : PowerSeries.constantCoeff (jNum.map (Int.castRingHom K)) = 1 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff, PowerSeries.coeff_map,
+    PowerSeries.coeff_zero_eq_constantCoeff,
+    constantCoeff_jNum, map_one]
+
+theorem coeff_jqModC_pow_self (n : ℕ) : ((jqModC K) ^ n).coeff (-(n : ℤ)) = 1 := by
+  rw [jqModC_pow, HahnSeries.coeff_single_mul, one_mul, sub_neg_eq_add, neg_add_cancel,
+    show (0 : ℤ) = ((0 : ℕ) : ℤ) from rfl, HahnSeries.ofPowerSeries_apply_coeff,
+    PowerSeries.coeff_zero_eq_constantCoeff, map_pow, constantCoeff_jNum_map, one_pow]
+
+theorem coeff_jqModC_pow_of_lt {n : ℕ} {m : ℤ} (hm : m < -(n : ℤ)) :
+    ((jqModC K) ^ n).coeff m = 0 := by
+  rw [jqModC_pow, HahnSeries.coeff_single_mul, one_mul]
+  exact ofPowerSeries_coeff_of_neg _ (by omega)
+
+theorem coeff_jqModC_neg_one : (jqModC K).coeff (-1 : ℤ) = 1 := by
+  simpa using coeff_jqModC_pow_self K 1
+
+theorem algebraMap_laurentSeries_eq_single (c : K) :
+    algebraMap K (LaurentSeries K) c = HahnSeries.single 0 c := by
+  have h1 : algebraMap K (PowerSeries K) c = PowerSeries.C c := by simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+  rfl
+
+theorem aeval_jqModC_eq_zero {p : Polynomial K} (hp : Polynomial.aeval (jqModC K) p = 0) :
+    p = 0 := by
+  by_contra hp0
+  set n := p.natDegree with hn
+  have hcoeff : (Polynomial.aeval (jqModC K) p).coeff (-(n : ℤ)) = p.coeff n := by
+    rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+      Finset.sum_eq_single n]
+    · rw [algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_zero_mul,
+        coeff_jqModC_pow_self, mul_one]
+    · intro i hi hin
+      have hilt : i < n := lt_of_le_of_ne (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hin
+      rw [algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_zero_mul,
+        coeff_jqModC_pow_of_lt, mul_zero]
+      omega
+    · intro hn'
+      exact absurd (Finset.self_mem_range_succ n) hn'
+  rw [hp] at hcoeff
+  simp only [HahnSeries.coeff_zero] at hcoeff
+  exact hp0 (Polynomial.leadingCoeff_eq_zero.mp hcoeff.symm)
+
+theorem transcendental_jqModC : Transcendental K (jqModC K) :=
+  transcendental_iff.mpr fun _ hp => aeval_jqModC_eq_zero K hp
+
+theorem jqModC_ne_zero [Nontrivial K] : jqModC K ≠ 0 := by
+  intro h
+  have h1 : (jqModC K).coeff (-1 : ℤ) = 1 := coeff_jqModC_neg_one K
+  rw [h, HahnSeries.coeff_zero] at h1
+  exact zero_ne_one h1
+
+theorem order_jqModC [Nontrivial K] : (jqModC K).order = -1 := by
+  refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero ?_) ?_
+  · rw [coeff_jqModC_neg_one]
+    exact one_ne_zero
+  · by_contra hlt
+    rw [not_le] at hlt
+    refine HahnSeries.coeff_order_eq_zero.not.mpr (jqModC_ne_zero K) ?_
+    have h := coeff_jqModC_pow_of_lt K (n := 1) (m := (jqModC K).order)
+      (by simpa using hlt)
+    simpa using h
+
+end CharLRows
+
+end ModularCurve
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_coeff_jqModC_pow_self.ModularCurve in
+theorem solution (K : Type*) [CommRing K] (b : ℕ) :
+    ((jqModC K) ^ b).coeff (-(b : ℤ)) = 1 :=
+  CharLRows.coeff_jqModC_pow_self K b
+
+end S_ModularCurve_coeff_jqModC_pow_self
+end P2MW
+export P2MW.S_ModularCurve_coeff_jqModC_pow_self (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.coeff_jqModC_pow_self (K : Type*) [CommRing K] (b : ℕ) :
+    ((jqModC K) ^ b).coeff (-(b : ℤ)) = 1 :=
+  solution K b
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_cosetPoly_smul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_cosetPoly_smul.lean
new file mode 100644
index 0000000000..75e957b727
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_cosetPoly_smul.lean
@@ -0,0 +1,346 @@
+/-
+Based on Prove2Me node ModularCurve.cosetPoly_smul
+(99e07f35-34d4-566d-802a-a22d72644af5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5def7a6b-054f-58cd-8f1b-7ce3eabbaac1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import Mathlib.Algebra.Field.ZMod
+import Mathlib.Topology.Compactification.OnePoint.ProjectiveLine
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# SL₂(ℤ)-invariance of the Hecke coset polynomial at ℓ
+
+Theorem statement: `ModularCurve.cosetPoly_smul` (`99e07f35-34d4-566d-802a-a22d72644af5`), by
+Claude, 2026-09-05.
+
+Proof: submission `5def7a6b-054f-58cd-8f1b-7ce3eabbaac1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a prime and let $F \colon \mathfrak H \to \mathbb C$ be any function on the upper
+half-plane which is invariant under the Möbius action of $\mathrm{SL}_2(\mathbb Z)$, that is
+$F(\gamma \cdot \tau) = F(\tau)$ for all $\gamma \in \mathrm{SL}_2(\mathbb Z)$ and all $\tau \in
+\mathfrak H$. Fix further $\gamma \in \mathrm{SL}_2(\mathbb Z)$ and $\tau \in \mathfrak H$. The
+matrices involved are those named
+[`ModularForm.heckeDiagMatrix`](def/ModularForm_HeckeOperator.html#L21) and
+[`ModularForm.heckeMatrix`](def/ModularForm_HeckeOperator.html#L18), viewed in
+$\mathrm{GL}_2(\mathbb R)$ and acting on $\mathfrak H$: since $\ell \neq 0$, `heckeDiagMatrix ℓ` is
+the upper triangular matrix $!![\ell, 0; 0, 1]$, acting by $\tau \mapsto \ell\tau$, and for $j \in
+\mathbb N$, `heckeMatrix ℓ j` is $!![1, j; 0, \ell]$, acting by $\tau \mapsto (\tau + j)/\ell$ (both
+definitions return the identity matrix when the index $\ell$ is $0$). The assertion is the identity
+in $\mathbb C[X]$
+$$\bigl(X - F(\ell\,(\gamma\tau))\bigr)\prod_{b \in \mathrm{Fin}\,\ell}\bigl(X - F\bigl((\gamma\tau
++ b)/\ell\bigr)\bigr) \;=\; \bigl(X - F(\ell\tau)\bigr)\prod_{b \in \mathrm{Fin}\,\ell}\bigl(X -
+F\bigl((\tau + b)/\ell\bigr)\bigr),$$
+the products being over the $\ell$ values $b = 0, \dots, \ell-1$ coerced from `Fin ℓ` to $\mathbb
+N$; the two monic polynomials of degree $\ell + 1$ attached to $\gamma\tau$ and to $\tau$ coincide.
+
+This is the invariance step in the classical construction of the modular polynomial: the $\ell + 1$
+matrices $!![\ell,0;0,1]$ and $!![1,b;0,\ell]$ represent the left cosets of $\mathrm{SL}_2(\mathbb
+Z)$ in the set of integral matrices of determinant $\ell$, right multiplication by $\gamma \in
+\mathrm{SL}_2(\mathbb Z)$ permutes these cosets, and the product over the cosets is therefore
+unchanged. It is used by
+[`ModularCurve.PhiGen.mem_adjoin_jq_of_phiGenDescends`]
+(thm.html#ModularCurve.PhiGen.mem_adjoin_jq_of_phiGenDescends),
+where the coefficients of this polynomial, taken for $F = j$, are identified as modular functions of
+level one.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_cosetPoly_smul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_cosetPoly_smul
+
+noncomputable section
+
+open Matrix.SpecialLinearGroup UpperHalfPlane Polynomial
+open scoped MatrixGroups ModularForm OnePoint
+
+namespace ModularCurve
+
+namespace CosetPoly
+
+open ModularForm
+
+@[scoped simp] theorem mapGL_apply (g : SL(2, ℤ)) (i j : Fin 2) :
+    (mapGL ℝ g : GL (Fin 2) ℝ) i j = ((g i j : ℤ) : ℝ) := by
+  simp
+
+theorem det_eq (g : SL(2, ℤ)) : g 0 0 * g 1 1 - g 0 1 * g 1 0 = 1 := by
+  have h := g.det_coe
+  rwa [Matrix.det_fin_two] at h
+
+section commutation
+
+variable {p : ℕ} (hp : p ≠ 0)
+include hp
+
+theorem heckeMatrix_mul_of_eq (g : SL(2, ℤ)) (j j' : ℕ) (e : ℤ)
+    (he : g 0 1 + j * g 1 1 = j' * (g 0 0 + j * g 1 0) + p * e) :
+    ∃ g' : SL(2, ℤ), heckeMatrix p j * mapGL ℝ g = mapGL ℝ g' * heckeMatrix p j' := by
+  have hdet := det_eq g
+  refine ⟨⟨!![g 0 0 + j * g 1 0, e; p * g 1 0, g 1 1 - g 1 0 * j'], ?_⟩, ?_⟩
+  · rw [Matrix.det_fin_two_of]
+    linear_combination hdet + (g 1 0) * he
+  · ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp only [Fin.zero_eta, Fin.isValue, Units.val_mul, ne_eq, hp, not_false_eq_true,
+        val_heckeMatrix, mapGL_coe_matrix, algebraMap_int_eq, map_apply_coe,
+        RingHom.mapMatrix_apply, Int.coe_castRingHom, Matrix.mul_apply, Matrix.of_apply,
+        Matrix.cons_val', Matrix.cons_val_fin_one, Matrix.cons_val_zero, Matrix.map_apply,
+        Fin.sum_univ_two, one_mul, Matrix.cons_val_one, Int.cast_add, Int.cast_mul,
+        Int.cast_natCast, mul_one, mul_zero, add_zero, Fin.mk_one, zero_mul, zero_add, Int.cast_sub]
+    all_goals first
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination this)
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination -this)
+      | ring1
+
+theorem heckeMatrix_mul_of_eq' (g : SL(2, ℤ)) (j : ℕ) (e : ℤ)
+    (he : g 0 0 + j * g 1 0 = p * e) :
+    ∃ g' : SL(2, ℤ), heckeMatrix p j * mapGL ℝ g = mapGL ℝ g' * heckeDiagMatrix p := by
+  have hdet := det_eq g
+  refine ⟨⟨!![e, g 0 1 + j * g 1 1; g 1 0, p * g 1 1], ?_⟩, ?_⟩
+  · rw [Matrix.det_fin_two_of]
+    linear_combination hdet - (g 1 1) * he
+  · ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp only [Fin.zero_eta, Fin.isValue, Units.val_mul, ne_eq, hp, not_false_eq_true,
+        val_heckeMatrix, mapGL_coe_matrix, algebraMap_int_eq, map_apply_coe,
+        RingHom.mapMatrix_apply, Int.coe_castRingHom, Matrix.mul_apply, Matrix.of_apply,
+        Matrix.cons_val', Matrix.cons_val_fin_one, Matrix.cons_val_zero, Matrix.map_apply,
+        Fin.sum_univ_two, one_mul, Matrix.cons_val_one, val_heckeDiagMatrix, Int.cast_add,
+        Int.cast_mul, Int.cast_natCast, mul_zero, add_zero, Fin.mk_one, mul_one, zero_add, zero_mul]
+    all_goals first
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination this)
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination -this)
+      | ring1
+
+theorem heckeDiagMatrix_mul_of_eq (g : SL(2, ℤ)) (j' : ℕ) (e : ℤ)
+    (he : g 1 1 = g 1 0 * j' + p * e) :
+    ∃ g' : SL(2, ℤ), heckeDiagMatrix p * mapGL ℝ g = mapGL ℝ g' * heckeMatrix p j' := by
+  have hdet := det_eq g
+  refine ⟨⟨!![p * g 0 0, g 0 1 - g 0 0 * j'; g 1 0, e], ?_⟩, ?_⟩
+  · rw [Matrix.det_fin_two_of]
+    linear_combination hdet - (g 0 0) * he
+  · ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp only [Fin.zero_eta, Fin.isValue, Units.val_mul, ne_eq, hp, not_false_eq_true,
+        val_heckeDiagMatrix, mapGL_coe_matrix, algebraMap_int_eq, map_apply_coe,
+        RingHom.mapMatrix_apply, Int.coe_castRingHom, Matrix.mul_apply, Matrix.of_apply,
+        Matrix.cons_val', Matrix.cons_val_fin_one, Matrix.cons_val_zero, Matrix.map_apply,
+        Fin.sum_univ_two, Matrix.cons_val_one, zero_mul, add_zero, val_heckeMatrix, Int.cast_mul,
+        Int.cast_natCast, mul_one, Int.cast_sub, mul_zero, Fin.mk_one, one_mul, zero_add]
+    all_goals first
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination this)
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination -this)
+      | ring1
+
+theorem heckeDiagMatrix_mul_of_eq' (g : SL(2, ℤ)) (e : ℤ) (he : g 1 0 = p * e) :
+    ∃ g' : SL(2, ℤ), heckeDiagMatrix p * mapGL ℝ g = mapGL ℝ g' * heckeDiagMatrix p := by
+  have hdet := det_eq g
+  refine ⟨⟨!![g 0 0, p * g 0 1; e, g 1 1], ?_⟩, ?_⟩
+  · rw [Matrix.det_fin_two_of]
+    linear_combination hdet + (g 0 1) * he
+  · ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp only [Fin.zero_eta, Fin.isValue, Units.val_mul, ne_eq, hp, not_false_eq_true,
+        val_heckeDiagMatrix, mapGL_coe_matrix, algebraMap_int_eq, map_apply_coe,
+        RingHom.mapMatrix_apply, Int.coe_castRingHom, Matrix.mul_apply, Matrix.of_apply,
+        Matrix.cons_val', Matrix.cons_val_fin_one, Matrix.cons_val_zero, Matrix.map_apply,
+        Fin.sum_univ_two, Matrix.cons_val_one, zero_mul, add_zero, Int.cast_mul, Int.cast_natCast,
+        mul_zero, Fin.mk_one, mul_one, zero_add, one_mul]
+    all_goals first
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination this)
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination -this)
+      | ring1
+
+end commutation
+
+section projectiveLine
+
+variable {p : ℕ}
+
+def heckeRep (p : ℕ) (x : OnePoint (ZMod p)) : GL (Fin 2) ℝ :=
+  x.elim (heckeDiagMatrix p) (fun j ↦ heckeMatrix p j.val)
+
+@[scoped simp] theorem heckeRep_infty : heckeRep p ∞ = heckeDiagMatrix p := rfl
+
+@[scoped simp] theorem heckeRep_coe (j : ZMod p) : heckeRep p j = heckeMatrix p j.val := rfl
+
+variable [Fact p.Prime]
+
+variable (p) in
+def redMatrix (g : SL(2, ℤ)) : GL (Fin 2) (ZMod p) :=
+  Matrix.GeneralLinearGroup.mkOfDetNeZero
+    !![((g 1 1 : ℤ) : ZMod p), ((g 0 1 : ℤ) : ZMod p); ((g 1 0 : ℤ) : ZMod p), ((g 0 0 : ℤ) : ZMod
+      p)]
+    (by
+      have := congrArg (Int.cast : ℤ → ZMod p) (det_eq g)
+      push_cast at this
+      rw [Matrix.det_fin_two_of,
+        show ((g 1 1 : ℤ) : ZMod p) * ((g 0 0 : ℤ) : ZMod p) - ((g 0 1 : ℤ) : ZMod p) * ((g 1 0 : ℤ)
+          : ZMod p)
+          = 1 by linear_combination this]
+      exact one_ne_zero)
+
+@[scoped simp] theorem redMatrix_apply_zero_zero (g : SL(2, ℤ)) :
+    redMatrix p g 0 0 = ((g 1 1 : ℤ) : ZMod p) := by
+  simp [redMatrix]
+
+@[scoped simp] theorem redMatrix_apply_zero_one (g : SL(2, ℤ)) :
+    redMatrix p g 0 1 = ((g 0 1 : ℤ) : ZMod p) := by
+  simp [redMatrix]
+
+@[scoped simp] theorem redMatrix_apply_one_zero (g : SL(2, ℤ)) :
+    redMatrix p g 1 0 = ((g 1 0 : ℤ) : ZMod p) := by
+  simp [redMatrix]
+
+@[scoped simp] theorem redMatrix_apply_one_one (g : SL(2, ℤ)) :
+    redMatrix p g 1 1 = ((g 0 0 : ℤ) : ZMod p) := by
+  simp [redMatrix]
+
+scoped instance : NeZero p := ⟨(Fact.out : p.Prime).ne_zero⟩
+
+theorem heckeRep_mul (g : SL(2, ℤ)) (x : OnePoint (ZMod p)) :
+    ∃ g' : SL(2, ℤ), heckeRep p x * mapGL ℝ g = mapGL ℝ g' * heckeRep p (redMatrix p g • x) := by
+  have hp : p ≠ 0 := (Fact.out : p.Prime).ne_zero
+  induction x using OnePoint.rec with
+  | infty =>
+    rw [OnePoint.smul_infty_eq_ite]
+    by_cases hc : ((g 1 0 : ℤ) : ZMod p) = 0
+    · rw [ite_eq_left (by simpa using hc), heckeRep_infty]
+      obtain ⟨e, he⟩ := (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp hc
+      exact heckeDiagMatrix_mul_of_eq' hp g e he
+    · rw [ite_eq_right (by simpa using hc), heckeRep_infty, heckeRep_coe]
+      set y : ZMod p := redMatrix p g 0 0 / redMatrix p g 1 0 with hy
+      obtain ⟨e, he⟩ : (p : ℤ) ∣ g 1 1 - g 1 0 * y.val := by
+        rw [← ZMod.intCast_zmod_eq_zero_iff_dvd]
+        push_cast
+        rw [ZMod.natCast_zmod_val, hy, redMatrix_apply_zero_zero, redMatrix_apply_one_zero,
+          mul_div_cancel₀ _ hc, sub_self]
+      exact heckeDiagMatrix_mul_of_eq hp g y.val e (by linear_combination he)
+  | coe j =>
+    rw [OnePoint.smul_some_eq_ite]
+    by_cases h : redMatrix p g 1 0 * j + redMatrix p g 1 1 = 0
+    · rw [ite_eq_left h, heckeRep_infty, heckeRep_coe]
+      rw [redMatrix_apply_one_zero, redMatrix_apply_one_one] at h
+      obtain ⟨e, he⟩ : (p : ℤ) ∣ g 0 0 + j.val * g 1 0 := by
+        rw [← ZMod.intCast_zmod_eq_zero_iff_dvd]
+        push_cast
+        rw [ZMod.natCast_zmod_val]
+        linear_combination h
+      exact heckeMatrix_mul_of_eq' hp g j.val e he
+    · rw [ite_eq_right h, heckeRep_coe, heckeRep_coe]
+      set y : ZMod p := (redMatrix p g 0 0 * j + redMatrix p g 0 1) /
+        (redMatrix p g 1 0 * j + redMatrix p g 1 1) with hy
+      obtain ⟨e, he⟩ : (p : ℤ) ∣ g 0 1 + j.val * g 1 1 - y.val * (g 0 0 + j.val * g 1 0) := by
+        rw [← ZMod.intCast_zmod_eq_zero_iff_dvd]
+        push_cast
+        rw [ZMod.natCast_zmod_val, ZMod.natCast_zmod_val,
+          show ((g 0 0 : ℤ) : ZMod p) + j * ((g 1 0 : ℤ) : ZMod p)
+            = redMatrix p g 1 0 * j + redMatrix p g 1 1 by
+              rw [redMatrix_apply_one_zero, redMatrix_apply_one_one]; ring,
+          hy, div_mul_cancel₀ _ h, redMatrix_apply_zero_zero, redMatrix_apply_zero_one]
+        ring
+      exact heckeMatrix_mul_of_eq hp g j.val y.val e (by linear_combination he)
+
+theorem apply_heckeRep_smul_smul (F : ℍ → ℂ) (hF : ∀ (γ : SL(2, ℤ)) (τ : ℍ), F (γ • τ) = F τ)
+    (g : SL(2, ℤ)) (x : OnePoint (ZMod p)) (τ : ℍ) :
+    F (heckeRep p x • g • τ) = F (heckeRep p (redMatrix p g • x) • τ) := by
+  obtain ⟨g', hmul⟩ := heckeRep_mul g x
+  have h1 : heckeRep p x • g • τ = (heckeRep p x * mapGL ℝ g) • τ := by
+    rw [mul_smul]; rfl
+  have h2 : (mapGL ℝ g' * heckeRep p (redMatrix p g • x)) • τ
+      = g' • heckeRep p (redMatrix p g • x) • τ := by
+    rw [mul_smul]; rfl
+  rw [h1, hmul, h2, hF]
+
+end projectiveLine
+
+section reindex
+
+variable {p : ℕ} [NeZero p]
+
+theorem prod_range_eq_prod_zmod {M : Type} [CommMonoid M] (G : ℕ → M) :
+    ∏ j ∈ Finset.range p, G j = ∏ x : ZMod p, G x.val := by
+  refine Finset.prod_nbij' (fun j : ℕ ↦ (j : ZMod p)) (fun x : ZMod p ↦ x.val) (fun _ _ ↦
+    Finset.mem_univ _)
+    (fun x _ ↦ Finset.mem_range.mpr x.val_lt) (fun j hj ↦ ?_) (fun x _ ↦ ?_) (fun j hj ↦ ?_)
+  · exact ZMod.val_cast_of_lt (Finset.mem_range.mp hj)
+  · exact ZMod.natCast_zmod_val x
+  · rw [ZMod.val_cast_of_lt (Finset.mem_range.mp hj)]
+
+theorem prod_fin_eq_prod_zmod {M : Type} [CommMonoid M] (G : ℕ → M) :
+    ∏ b : Fin p, G (b : ℕ) = ∏ x : ZMod p, G x.val := by
+  rw [Fin.prod_univ_eq_prod_range, prod_range_eq_prod_zmod]
+
+theorem cosetPoly_eq_prod_onePoint (F : ℍ → ℂ) (τ : ℍ) :
+    (X - C (F (heckeDiagMatrix p • τ))) * ∏ b : Fin p, (X - C (F (heckeMatrix p (b : ℕ) • τ)))
+      = ∏ x : OnePoint (ZMod p), (X - C (F (heckeRep p x • τ))) := by
+  rw [prod_fin_eq_prod_zmod (fun j ↦ X - C (F (heckeMatrix p j • τ)))]
+  exact (Fintype.prod_option (fun x : OnePoint (ZMod p) ↦ X - C (F (heckeRep p x • τ)))).symm
+
+end reindex
+
+theorem cosetPoly_smul' (ℓ : ℕ) (hℓ : ℓ.Prime) (F : ℍ → ℂ)
+    (hF : ∀ (γ : SL(2, ℤ)) (τ : ℍ), F (γ • τ) = F τ) (γ : SL(2, ℤ)) (τ : ℍ) :
+    (X - C (F (heckeDiagMatrix ℓ • γ • τ))) * ∏ b : Fin ℓ, (X - C (F (heckeMatrix ℓ (b : ℕ) • γ •
+      τ)))
+      = (X - C (F (heckeDiagMatrix ℓ • τ))) * ∏ b : Fin ℓ, (X - C (F (heckeMatrix ℓ (b : ℕ) • τ)))
+        := by
+  have : Fact ℓ.Prime := ⟨hℓ⟩
+  rw [cosetPoly_eq_prod_onePoint F (γ • τ), cosetPoly_eq_prod_onePoint F τ]
+  calc ∏ x : OnePoint (ZMod ℓ), (X - C (F (heckeRep ℓ x • γ • τ)))
+      = ∏ x : OnePoint (ZMod ℓ), (X - C (F (heckeRep ℓ (redMatrix ℓ γ • x) • τ))) :=
+        Finset.prod_congr rfl fun x _ ↦ by rw [apply_heckeRep_smul_smul F hF γ x τ]
+    _ = ∏ x : OnePoint (ZMod ℓ), (X - C (F (heckeRep ℓ x • τ))) :=
+        Equiv.prod_comp (MulAction.toPerm (redMatrix ℓ γ)) (fun x ↦ X - C (F (heckeRep ℓ x • τ)))
+
+end CosetPoly
+end ModularCurve
+end
+
+theorem solution (ℓ : ℕ) (hℓ : ℓ.Prime) (F : UpperHalfPlane → ℂ)
+    (hF : ∀ (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) (τ : UpperHalfPlane), F (γ • τ) = F τ)
+    (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) (τ : UpperHalfPlane) :
+    (Polynomial.X - Polynomial.C (F (ModularForm.heckeDiagMatrix ℓ • γ • τ))) * ∏ b : Fin ℓ,
+      (Polynomial.X - Polynomial.C (F (ModularForm.heckeMatrix ℓ (b : ℕ) • γ • τ))) = (Polynomial.X
+      - Polynomial.C (F (ModularForm.heckeDiagMatrix ℓ • τ))) * ∏ b : Fin ℓ, (Polynomial.X -
+      Polynomial.C (F (ModularForm.heckeMatrix ℓ (b : ℕ) • τ))) :=
+  ModularCurve.CosetPoly.cosetPoly_smul' ℓ hℓ F hF γ τ
+
+end S_ModularCurve_cosetPoly_smul
+end P2MW
+export P2MW.S_ModularCurve_cosetPoly_smul (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.cosetPoly_smul (ℓ : ℕ) (hℓ : ℓ.Prime) (F : UpperHalfPlane → ℂ)
+    (hF : ∀ (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) (τ : UpperHalfPlane), F (γ • τ) = F τ)
+    (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) (τ : UpperHalfPlane) :
+    (Polynomial.X - Polynomial.C (F (ModularForm.heckeDiagMatrix ℓ • γ • τ))) * ∏ b : Fin ℓ,
+      (Polynomial.X - Polynomial.C (F (ModularForm.heckeMatrix ℓ (b : ℕ) • γ • τ))) = (Polynomial.X
+      - Polynomial.C (F (ModularForm.heckeDiagMatrix ℓ • τ))) * ∏ b : Fin ℓ, (Polynomial.X -
+      Polynomial.C (F (ModularForm.heckeMatrix ℓ (b : ℕ) • τ))) :=
+  solution ℓ hℓ F hF γ τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_cuspZeroBar_ne_cuspInftyBar.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_cuspZeroBar_ne_cuspInftyBar.lean
new file mode 100644
index 0000000000..2acfad00ba
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_cuspZeroBar_ne_cuspInftyBar.lean
@@ -0,0 +1,90 @@
+/-
+Based on Prove2Me node ModularCurve.cuspZeroBar_ne_cuspInftyBar
+(d2518335-7eea-5c45-a9c2-b57c920ec522) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 33712220-7faa-5fdf-9bd8-eaa155683b18
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CuspidalClass
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_cuspZeroBar_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_cuspInftyBar_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The cusps ̄ 0 and ∞̄ are distinct for N>1
+
+Theorem statement: `ModularCurve.cuspZeroBar_ne_cuspInftyBar`
+(`d2518335-7eea-5c45-a9c2-b57c920ec522`), by Claude, 2026-09-05.
+
+Proof: submission `33712220-7faa-5fdf-9bd8-eaa155683b18`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number. Assume first that the distinguished automorphism
+`frickeInvolutionFull N` of the modular function field $F_N^{\mathrm{full}} =$
+`modularFunctionFieldFull N` — the subfield of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by the
+divisor expansions attached to $N$ — satisfies the predicate `IsFrickeAutFull N`, that is: for every
+factorisation $ab = N$ into nonzero natural numbers it carries the element of $F_N^{\mathrm{full}}$
+given by the $q$-series $\mathrm{qExpand}\,a$ applied to the $q$-expansion of $j$ (substituting $q
+\mapsto q^a$) to the element given by $\mathrm{qExpand}\,b$ applied to that same expansion. Assume
+further that $1 < N$. The conclusion is that the two places `cuspZeroBar N` and `cuspInftyBar N` of
+the base-changed field `modularFunctionFieldBar N` $= \bar{\mathbb{Q}}\cdot F_N^{\mathrm{full}}
+\subseteq \bar{\mathbb{Q}}((q))$ over $\bar{\mathbb{Q}}$ are distinct. Here `cuspInftyBar N` is the
+$q$-adic place at $q = 0$, given by the valuation subring of elements of nonnegative order,
+witnessed by the coefficient-extended $q$-expansion of $j$ (of order $-1$); and `cuspZeroBar N` is
+its translate under the Galois-type action of `frickeInvolutionBar N`, the
+$\bar{\mathbb{Q}}$-automorphism of `modularFunctionFieldBar N` induced by `frickeInvolutionFull N`.
+
+This is the statement that, on the modular curve attached to $F_N^{\mathrm{full}}$ with $N > 1$, the
+cusp $0$ (the Fricke translate of $\infty$) is not the cusp $\infty$; it is what gives the cuspidal
+divisor $(\bar 0) - (\bar\infty)$ content. It is used by the results on the cuspidal divisor class,
+among them the nonvanishing of that class and the bound on its order, and by the classification of
+the places lying over the cusps.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_cuspZeroBar_ne_cuspInftyBar.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_cuspZeroBar_ne_cuspInftyBar
+
+open ModularCurve AlgebraicCurve
+open scoped Pointwise
+
+theorem solution (N : ℕ) [NeZero N] (h : IsFrickeAutFull N (frickeInvolutionFull N)) (hN : 1 < N) :
+    cuspZeroBar N ≠ cuspInftyBar N := by
+  intro e
+  have h0 := ModularCurve.ord_cuspZeroBar_coeffEmb_jq N h
+  rw [e, ModularCurve.ord_cuspInftyBar_coeffEmb_jq] at h0
+  have : (N : ℤ) = 1 := by linarith
+  exact absurd (Nat.cast_eq_one.mp this) hN.ne'
+
+end S_ModularCurve_cuspZeroBar_ne_cuspInftyBar
+end P2MW
+export P2MW.S_ModularCurve_cuspZeroBar_ne_cuspInftyBar (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.cuspZeroBar_ne_cuspInftyBar (N : ℕ) [NeZero N]
+    (h : IsFrickeAutFull N (frickeInvolutionFull N)) (hN : 1 < N) :
+    cuspZeroBar N ≠ cuspInftyBar N :=
+  solution N h hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_dedekindPsi_le_finrank_adjoin_qExpFunctionFieldC_gamma0.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_dedekindPsi_le_finrank_adjoin_qExpFunctionFieldC_gamma0.lean
new file mode 100644
index 0000000000..721517b91f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_dedekindPsi_le_finrank_adjoin_qExpFunctionFieldC_gamma0.lean
@@ -0,0 +1,147 @@
+/-
+Based on Prove2Me node ModularCurve.dedekindPsi_le_finrank_adjoin_qExpFunctionFieldC_gamma0
+(2ce1ed64-8cdd-574d-99d7-02f3ead4fec5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 76485080-d23d-5c87-b12e-eb8b70859a13
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.FieldTheory.Relrank
+import Mathlib.RingTheory.Flat.TorsionFree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqModC_modularFunctionFieldFullC_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularFunctionFieldFullC_le_qExpFunctionFieldC_gamma0
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree at least ψ(M) over K(j) for X₀(M)
+
+Theorem statement: `ModularCurve.dedekindPsi_le_finrank_adjoin_qExpFunctionFieldC_gamma0`
+(`2ce1ed64-8cdd-574d-99d7-02f3ead4fec5`), by Claude, 2026-09-05.
+
+Proof: submission `76485080-d23d-5c87-b12e-eb8b70859a13`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and $M$ a positive integer whose image in $K$ is nonzero. Let $F =$
+[`ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M)`](def/ModularCurve_X1.html#L101)
+be the intermediate field of the Laurent series field `LaurentSeries K` generated over $K$ by the
+set of all quotients $\overline{p_f}/\overline{p_g}$, where $f,g$ are modular forms of one and the
+same weight $k \in \mathbb{Z}$ for $\Gamma_0(M)$ regarded inside $\mathrm{GL}_2(\mathbb{R})$, $p_f,
+p_g$ are power series over $\mathbb{Z}$ satisfying `IsIntegralQExp f pf` and `IsIntegralQExp g pg`,
+and the coefficientwise image $\overline{p_g}$ of $p_g$ in $K$ is nonzero. Let $x \in F$ be an
+element whose underlying Laurent series is [`ModularCurve.jqModC
+K`](def/ModularCurve_JqCoeff.html#L15), that is $q^{-1}$ times the image in $K$ of the power series
+$E_4^3 \eta^{-24}$ (the $q$-expansion of the modular invariant $j$). Assume that $F$ is
+finite-dimensional over the intermediate field $K(x)$ obtained by adjoining $x$ to $K$ inside $F$.
+Then $\psi(M) \le [F : K(x)]$, where $\psi(M)$ is [`ModularCurve.dedekindPsi
+M`](def/ModularCurve_X0.html#L201), defined as $\sum_{d \mid M,\ d \text{ squarefree}} M/d$.
+
+This is Igusa's lower bound for the degree of $X_0(M)$ over the $j$-line, in $q$-expansion form and
+over an arbitrary coefficient field in which $M$ is invertible. It is used in the computation of
+relative degrees and indices for the congruence subgroups $\Gamma_0$ and $\Gamma_H$, and in the
+local analysis of valuation subrings on $X_0(p)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_dedekindPsi_le_finrank_adjoin_qExpFunctionFieldC_gamma0.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_dedekindPsi_le_finrank_adjoin_qExpFunctionFieldC_gamma0
+
+private theorem igT3s_finrank_adjoin_eq_relfinrank {K E : Type*} [Field K] [Field E] [Algebra K E]
+    (F : IntermediateField K E) (x : F) :
+    Module.finrank (IntermediateField.adjoin K ({x} : Set F)) F =
+      (IntermediateField.adjoin K ({(x : E)} : Set E)).relfinrank F := by
+  have hlift : IntermediateField.lift (IntermediateField.adjoin K ({x} : Set F)) =
+      IntermediateField.adjoin K ({(x : E)} : Set E) := by
+    rw [IntermediateField.lift_adjoin]; simp
+  have hle : IntermediateField.adjoin K ({(x : E)} : Set E) ≤ F := by
+    rw [← hlift]; exact IntermediateField.lift_le _
+  rw [IntermediateField.relfinrank_eq_finrank_of_le hle]
+  let i : (IntermediateField.adjoin K ({x} : Set F)) ≃+*
+      (IntermediateField.adjoin K ({(x : E)} : Set E)) :=
+    ((IntermediateField.liftAlgEquiv (IntermediateField.adjoin K ({x} : Set F))).trans
+      (IntermediateField.equivOfEq hlift)).toRingEquiv
+  let j : F ≃+* (IntermediateField.extendScalars hle) := RingEquiv.refl _
+  refine Algebra.finrank_eq_of_equiv_equiv i j ?_
+  ext a
+  rfl
+
+theorem solution
+    (K : Type*) [Field K] (M : ℕ) [NeZero M] (hM : (M : K) ≠ 0)
+    (x : ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M))
+    (hx : (x : LaurentSeries K) = ModularCurve.jqModC K)
+    [FiniteDimensional
+      (IntermediateField.adjoin K
+        ({x} : Set (ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M))))
+      (ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M))] :
+    ModularCurve.dedekindPsi M ≤
+      Module.finrank
+        (IntermediateField.adjoin K
+          ({x} : Set (ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M))))
+        (ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M)) := by
+  have hn : 0 < Module.finrank (IntermediateField.adjoin K
+      ({x} : Set (ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M))))
+      (ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M)) := Module.finrank_pos
+  have h1 : Module.finrank (IntermediateField.adjoin K
+      ({x} : Set (ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M))))
+      (ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M)) =
+      (IntermediateField.adjoin K ({ModularCurve.jqModC K} : Set (LaurentSeries K))).relfinrank
+        (ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M)) := by
+    rw [← hx]
+    exact igT3s_finrank_adjoin_eq_relfinrank _ x
+  have h2 : (IntermediateField.adjoin K ({ModularCurve.jqModC K} : Set (LaurentSeries
+    K))).relfinrank
+      (ModularCurve.modularFunctionFieldFullC K M) = ModularCurve.dedekindPsi M := by
+    rw [← ModularCurve.finrank_adjoin_jqModC_modularFunctionFieldFullC_eq_dedekindPsi K M hM]
+    exact (igT3s_finrank_adjoin_eq_relfinrank (ModularCurve.modularFunctionFieldFullC K M)
+      ⟨ModularCurve.jqModC K, ModularCurve.jqModC_mem_full K M⟩).symm
+  have hAB : IntermediateField.adjoin K ({ModularCurve.jqModC K} : Set (LaurentSeries K)) ≤
+      ModularCurve.modularFunctionFieldFullC K M :=
+    IntermediateField.adjoin_le_iff.mpr (Set.singleton_subset_iff.mpr (ModularCurve.jqModC_mem_full
+      K M))
+  have hBC : ModularCurve.modularFunctionFieldFullC K M ≤
+      ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M) :=
+    ModularCurve.modularFunctionFieldFullC_le_qExpFunctionFieldC_gamma0 K M
+  have htower := IntermediateField.relfinrank_mul_relfinrank hAB hBC
+  rw [h2, ← h1] at htower
+  exact Nat.le_of_dvd hn ⟨_, htower.symm⟩
+
+end S_ModularCurve_dedekindPsi_le_finrank_adjoin_qExpFunctionFieldC_gamma0
+end P2MW
+export P2MW.S_ModularCurve_dedekindPsi_le_finrank_adjoin_qExpFunctionFieldC_gamma0 (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.dedekindPsi_le_finrank_adjoin_qExpFunctionFieldC_gamma0
+    (K : Type*) [Field K] (M : ℕ) [NeZero M] (hM : (M : K) ≠ 0)
+    (x : ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M))
+    (hx : (x : LaurentSeries K) = ModularCurve.jqModC K)
+    [FiniteDimensional
+      (IntermediateField.adjoin K
+        ({x} : Set (ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M))))
+      (ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M))] :
+    ModularCurve.dedekindPsi M ≤
+      Module.finrank
+        (IntermediateField.adjoin K
+          ({x} : Set (ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M))))
+        (ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M)) :=
+  solution K M hM x hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_dedekindPsi_mul_of_coprime.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_dedekindPsi_mul_of_coprime.lean
new file mode 100644
index 0000000000..52a5eb0c98
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_dedekindPsi_mul_of_coprime.lean
@@ -0,0 +1,520 @@
+/-
+Based on Prove2Me node ModularCurve.dedekindPsi_mul_of_coprime
+(279a2b31-54aa-5736-b408-0c9a53ca3d30) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission cdb27e77-3b26-5ce0-beb7-e90f5223354a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import Mathlib.NumberTheory.ArithmeticFunction.Misc
+import Mathlib.RingTheory.Polynomial.Resultant.Basic
+import Mathlib.FieldTheory.IsAlgClosed.Basic
+import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Multiplicativity of the Dedekind ψ function
+
+Theorem statement: `ModularCurve.dedekindPsi_mul_of_coprime`
+(`279a2b31-54aa-5736-b408-0c9a53ca3d30`), by Claude, 2026-09-05.
+
+Proof: submission `cdb27e77-3b26-5ce0-beb7-e90f5223354a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+For natural numbers $M$ and $N$ that are coprime, the function $\psi$ defined by $$\psi(N) =
+\sum_{\substack{d \mid N \\ d \text{ squarefree}}} N/d,$$ the sum being over the divisors $d$ of $N$
+in the sense of `Nat.divisors` (so over an empty set when $N = 0$) that are squarefree, with $N/d$
+the quotient of natural numbers, which is exact since $d$ divides $N$, satisfies $\psi(MN) =
+\psi(M)\,\psi(N)$. No positivity hypothesis is imposed on $M$ or $N$: the case where one of them
+vanishes is covered, both sides then being $0$ unless the other is $1$. Thus `dedekindPsi` is
+multiplicative on coprime pairs; for $N \geq 1$ its value is $N \prod_{p \mid N} (1 + 1/p)$, but
+that closed form is not what the statement asserts.
+
+This is the multiplicativity, on coprime arguments, of the Dedekind $\psi$ function, which computes
+the index of $\Gamma_0(N)$ in $\mathrm{SL}_2(\mathbb{Z})$. It is used throughout the index and genus
+computations for the modular curves $X_0(N)$ and their relatives, for instance in reducing such
+quantities to prime powers.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_dedekindPsi_mul_of_coprime.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_dedekindPsi_mul_of_coprime
+
+noncomputable section
+
+open Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_qExpand jq jqN dedekindPsi evalAtJ evalAtJ_X \
+  ModularPolynomialData"
+p2m_open "ModularCurve"
+
+section DedekindPsi
+
+p2m_open "Finset Nat Finset.Nat ArithmeticFunction"
+
+private def squarefreeIndicator : ArithmeticFunction ℕ :=
+  ⟨fun n => if Squarefree n then 1 else 0, by simp [not_squarefree_zero]⟩
+
+@[scoped simp]
+private theorem squarefreeIndicator_apply {n : ℕ} :
+    squarefreeIndicator n = if Squarefree n then 1 else 0 :=
+  rfl
+
+private theorem isMultiplicative_squarefreeIndicator :
+    squarefreeIndicator.IsMultiplicative := by
+  refine ⟨by simp, fun {m n} h => ?_⟩
+  simp only [squarefreeIndicator_apply, Nat.squarefree_mul h]
+  by_cases hm : Squarefree m <;> by_cases hn : Squarefree n <;> simp [hm, hn]
+
+private theorem dedekindPsi_eq_mul_apply (N : ℕ) :
+    dedekindPsi N = (squarefreeIndicator * ArithmeticFunction.id) N :=
+  calc dedekindPsi N
+      = ∑ d ∈ N.divisors, squarefreeIndicator d * ArithmeticFunction.id (N / d) := by
+        rw [dedekindPsi, sum_filter]
+        refine Finset.sum_congr rfl fun d _ => ?_
+        by_cases hd : Squarefree d <;> simp [hd]
+    _ = ∑ x ∈ N.divisorsAntidiagonal, squarefreeIndicator x.1 * ArithmeticFunction.id x.2 :=
+        (Nat.sum_divisorsAntidiagonal fun d e =>
+          squarefreeIndicator d * ArithmeticFunction.id e).symm
+    _ = (squarefreeIndicator * ArithmeticFunction.id) N := ArithmeticFunction.mul_apply.symm
+
+private theorem isMultiplicative_squarefreeIndicator_mul_id :
+    (squarefreeIndicator * ArithmeticFunction.id).IsMultiplicative :=
+  isMultiplicative_squarefreeIndicator.mul isMultiplicative_id
+
+private theorem dedekindPsi_mul_of_coprime (M N : ℕ) (h : Nat.Coprime M N) :
+    dedekindPsi (M * N) = dedekindPsi M * dedekindPsi N := by
+  simp only [dedekindPsi_eq_mul_apply]
+  exact isMultiplicative_squarefreeIndicator_mul_id.map_mul_of_coprime h
+
+private theorem le_dedekindPsi (N : ℕ) (hN : N ≠ 0) : N ≤ dedekindPsi N := by
+  rw [dedekindPsi]
+  have h1 : (1 : ℕ) ∈ {d ∈ N.divisors | Squarefree d} :=
+    Finset.mem_filter.mpr ⟨Nat.one_mem_divisors.mpr hN, squarefree_one⟩
+  simpa using Finset.single_le_sum (f := fun d => N / d) (fun d _ => Nat.zero_le _) h1
+
+private theorem dedekindPsi_pos (N : ℕ) (hN : N ≠ 0) : 0 < dedekindPsi N :=
+  lt_of_lt_of_le (Nat.pos_of_ne_zero hN) (le_dedekindPsi N hN)
+
+end DedekindPsi
+
+section FibrePoly
+
+variable {K : Type*} [Field K]
+
+private def fibrePoly (Φ : Polynomial (Polynomial ℤ)) (a : K) : Polynomial K :=
+  Φ.map (Polynomial.eval₂RingHom (Int.castRingHom K) a)
+
+private theorem monic_fibrePoly {Φ : Polynomial (Polynomial ℤ)} (hΦ : Φ.Monic) (a : K) :
+    (fibrePoly Φ a).Monic :=
+  hΦ.map _
+
+private theorem natDegree_fibrePoly {Φ : Polynomial (Polynomial ℤ)} (hΦ : Φ.Monic) (a : K) :
+    (fibrePoly Φ a).natDegree = Φ.natDegree :=
+  hΦ.natDegree_map _
+
+private theorem card_roots_fibrePoly_of_monic [IsAlgClosed K]
+    {Φ : Polynomial (Polynomial ℤ)} (hΦ : Φ.Monic) (a : K) :
+    Multiset.card (fibrePoly Φ a).roots = Φ.natDegree := by
+  rw [← (IsAlgClosed.splits (fibrePoly Φ a)).natDegree_eq_card_roots]
+  exact natDegree_fibrePoly hΦ a
+
+private def compositeFibrePoly (Φ Φ' : Polynomial (Polynomial ℤ)) (a : K) : Polynomial K :=
+  ((fibrePoly Φ a).roots.map fun b => fibrePoly Φ' b).prod
+
+private theorem compositeFibrePoly_def (Φ Φ' : Polynomial (Polynomial ℤ)) (a : K) :
+    compositeFibrePoly Φ Φ' a
+      = ((fibrePoly Φ a).roots.map fun b => fibrePoly Φ' b).prod :=
+  rfl
+
+private theorem monic_compositeFibrePoly {Φ Φ' : Polynomial (Polynomial ℤ)} (hΦ' : Φ'.Monic)
+    (a : K) : (compositeFibrePoly Φ Φ' a).Monic :=
+  monic_multiset_prod_of_monic _ _ fun _ _ => monic_fibrePoly hΦ' _
+
+end FibrePoly
+
+section Lifts
+
+private def resLiftInner (Φ : Polynomial (Polynomial ℤ)) :
+    Polynomial (Polynomial (Polynomial ℤ)) :=
+  Φ.map (Polynomial.C : Polynomial ℤ →+* Polynomial (Polynomial ℤ))
+
+private def resLiftOuter (Φ' : Polynomial (Polynomial ℤ)) :
+    Polynomial (Polynomial (Polynomial ℤ)) :=
+  Φ'.eval₂ (Polynomial.mapRingHom (Int.castRingHom (Polynomial (Polynomial ℤ))))
+    (Polynomial.C (Polynomial.X : Polynomial (Polynomial ℤ)))
+
+private def resLiftOuterK (K : Type*) [Field K] (Φ' : Polynomial (Polynomial ℤ)) :
+    Polynomial (Polynomial K) :=
+  Φ'.eval₂ (Polynomial.mapRingHom (Int.castRingHom (Polynomial K)))
+    (Polynomial.C (Polynomial.X : Polynomial K))
+
+end Lifts
+
+section Specialize
+
+variable {K : Type*} [Field K]
+
+private def specializeAt (a : K) :
+    Polynomial (Polynomial ℤ) →+* Polynomial K :=
+  Polynomial.mapRingHom (Polynomial.eval₂RingHom (Int.castRingHom K) a)
+
+private theorem specializeAt_eq_fibrePoly (a : K) (Ψ : Polynomial (Polynomial ℤ)) :
+    specializeAt a Ψ = fibrePoly Ψ a :=
+  rfl
+
+private theorem map_resLiftInner (Φ : Polynomial (Polynomial ℤ)) (a : K) :
+    (resLiftInner Φ).map (specializeAt a)
+      = (fibrePoly Φ a).map (Polynomial.C : K →+* Polynomial K) := by
+  have h : (specializeAt (K := K) a).comp
+        (Polynomial.C : Polynomial ℤ →+* Polynomial (Polynomial ℤ))
+      = (Polynomial.C : K →+* Polynomial K).comp
+          (Polynomial.eval₂RingHom (Int.castRingHom K) a) := by
+    refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+    simp [specializeAt]
+  rw [resLiftInner, Polynomial.map_map, h, ← Polynomial.map_map]
+  rfl
+
+private theorem map_resLiftOuter (Φ' : Polynomial (Polynomial ℤ)) (a : K) :
+    (resLiftOuter Φ').map (specializeAt a) = resLiftOuterK K Φ' := by
+  have hF : (Polynomial.mapRingHom (specializeAt (K := K) a)).comp
+        (Polynomial.mapRingHom (Int.castRingHom (Polynomial (Polynomial ℤ))))
+      = Polynomial.mapRingHom (Int.castRingHom (Polynomial K)) := by
+    refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+    simp [specializeAt]
+  have hX : (Polynomial.mapRingHom (specializeAt (K := K) a))
+        (Polynomial.C (Polynomial.X : Polynomial (Polynomial ℤ)))
+      = Polynomial.C (Polynomial.X : Polynomial K) := by
+    simp [specializeAt]
+  calc (resLiftOuter Φ').map (specializeAt a)
+      = (Polynomial.mapRingHom (specializeAt a))
+          (Φ'.eval₂ (Polynomial.mapRingHom
+            (Int.castRingHom (Polynomial (Polynomial ℤ))))
+            (Polynomial.C (Polynomial.X : Polynomial (Polynomial ℤ)))) := rfl
+    _ = Φ'.eval₂ ((Polynomial.mapRingHom (specializeAt a)).comp
+          (Polynomial.mapRingHom (Int.castRingHom (Polynomial (Polynomial ℤ)))))
+          ((Polynomial.mapRingHom (specializeAt a))
+            (Polynomial.C (Polynomial.X : Polynomial (Polynomial ℤ)))) :=
+        Polynomial.hom_eval₂ ..
+    _ = resLiftOuterK K Φ' := by rw [hF, hX]; rfl
+
+private theorem eval_C_resLiftOuterK (Φ' : Polynomial (Polynomial ℤ)) (b : K) :
+    (resLiftOuterK K Φ').eval (Polynomial.C b) = fibrePoly Φ' b := by
+  have hF : (Polynomial.evalRingHom (Polynomial.C b : Polynomial K)).comp
+        (Polynomial.mapRingHom (Int.castRingHom (Polynomial K)))
+      = (Polynomial.C : K →+* Polynomial K).comp
+          (Polynomial.eval₂RingHom (Int.castRingHom K) b) := by
+    refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+    simp
+  have hX : (Polynomial.evalRingHom (Polynomial.C b : Polynomial K))
+        (Polynomial.C (Polynomial.X : Polynomial K)) = Polynomial.X := by
+    simp
+  calc (resLiftOuterK K Φ').eval (Polynomial.C b)
+      = (Polynomial.evalRingHom (Polynomial.C b))
+          (Φ'.eval₂ (Polynomial.mapRingHom (Int.castRingHom (Polynomial K)))
+            (Polynomial.C (Polynomial.X : Polynomial K))) := rfl
+    _ = Φ'.eval₂ ((Polynomial.evalRingHom (Polynomial.C b)).comp
+          (Polynomial.mapRingHom (Int.castRingHom (Polynomial K))))
+          ((Polynomial.evalRingHom (Polynomial.C b))
+            (Polynomial.C (Polynomial.X : Polynomial K))) := Polynomial.hom_eval₂ ..
+    _ = fibrePoly Φ' b := by rw [hF, hX]; rfl
+
+private theorem natDegree_resLiftOuterK_le (Φ' : Polynomial (Polynomial ℤ)) (a : K) :
+    (resLiftOuterK K Φ').natDegree ≤ (resLiftOuter Φ').natDegree := by
+  rw [← map_resLiftOuter Φ' a]
+  exact Polynomial.natDegree_map_le
+
+end Specialize
+
+section BiResultant
+
+private def biResultant (Φ Φ' : Polynomial (Polynomial ℤ)) : Polynomial (Polynomial ℤ) :=
+  Polynomial.resultant (resLiftInner Φ) (resLiftOuter Φ')
+    Φ.natDegree (resLiftOuter Φ').natDegree
+
+variable {K : Type*} [Field K] [IsAlgClosed K]
+
+private theorem fibrePoly_biResultant {Φ : Polynomial (Polynomial ℤ)}
+    (Φ' : Polynomial (Polynomial ℤ)) (hΦ : Φ.Monic) (a : K) :
+    fibrePoly (biResultant Φ Φ') a = compositeFibrePoly Φ Φ' a := by
+  rw [← specializeAt_eq_fibrePoly, biResultant, ← Polynomial.resultant_map_map,
+    map_resLiftInner, map_resLiftOuter]
+  have hmono : ((fibrePoly Φ a).map (Polynomial.C : K →+* Polynomial K)).Monic :=
+    (monic_fibrePoly hΦ a).map _
+  have hdeg : ((fibrePoly Φ a).map (Polynomial.C : K →+* Polynomial K)).natDegree
+      = Φ.natDegree :=
+    ((monic_fibrePoly hΦ a).natDegree_map _).trans (hΦ.natDegree_map _)
+  have hsplit : ((fibrePoly Φ a).map (Polynomial.C : K →+* Polynomial K)).Splits :=
+    (IsAlgClosed.splits (fibrePoly Φ a)).map _
+  rw [← hdeg, Polynomial.resultant_eq_prod_eval _ _ _
+      (natDegree_resLiftOuterK_le Φ' a) hsplit, hmono.leadingCoeff, one_pow, one_mul]
+  rw [(IsAlgClosed.splits (fibrePoly Φ a)).roots_map_of_injective Polynomial.C_injective,
+    Multiset.map_map, compositeFibrePoly_def]
+  congr 1
+  exact Multiset.map_congr rfl fun b _ => eval_C_resLiftOuterK Φ' b
+
+end BiResultant
+
+section MonicDegree
+
+private theorem natDegree_compositeFibrePoly {K : Type*} [Field K] [IsAlgClosed K]
+    {Φ Φ' : Polynomial (Polynomial ℤ)} (hΦ : Φ.Monic) (hΦ' : Φ'.Monic) (a : K) :
+    (compositeFibrePoly Φ Φ' a).natDegree = Φ.natDegree * Φ'.natDegree := by
+  rw [compositeFibrePoly_def, natDegree_multiset_prod_of_monic _
+    (fun _ hb => by
+      obtain ⟨b, -, rfl⟩ := Multiset.mem_map.mp hb
+      exact monic_fibrePoly hΦ' b)]
+  rw [Multiset.map_map]
+  have hsame : ((fibrePoly Φ a).roots.map fun b => (fibrePoly Φ' b).natDegree)
+      = (fibrePoly Φ a).roots.map fun _ => Φ'.natDegree :=
+    Multiset.map_congr rfl fun b _ => natDegree_fibrePoly hΦ' b
+  rw [Function.comp_def, hsame, Multiset.map_const', Multiset.sum_replicate,
+    card_roots_fibrePoly_of_monic hΦ a, smul_eq_mul]
+
+local notation "ℚ̄" => AlgebraicClosure ℚ
+
+private theorem intPoly_eq_C_of_forall_algebraicClosure_eval (p : Polynomial ℤ) (c : ℤ)
+    (h : ∀ a : ℚ̄, p.eval₂ (Int.castRingHom ℚ̄) a = (c : ℚ̄)) :
+    p = Polynomial.C c := by
+  have hinj : Function.Injective (Int.castRingHom ℚ̄) := fun x y hxy =>
+    Int.cast_injective (α := ℚ̄) hxy
+  refine Polynomial.map_injective _ hinj ?_
+  rw [Polynomial.map_C]
+  refine Polynomial.funext fun a => ?_
+  rw [Polynomial.eval_map, Polynomial.eval_C]
+  exact h a
+
+private theorem coeff_fibrePoly {K : Type*} [Field K] (Ψ : Polynomial (Polynomial ℤ))
+    (a : K) (j : ℕ) :
+    (fibrePoly Ψ a).coeff j = (Ψ.coeff j).eval₂ (Int.castRingHom K) a := by
+  rw [fibrePoly, Polynomial.coeff_map, Polynomial.coe_eval₂RingHom]
+
+private theorem eval₂_coeff_biResultant_eq_coeff_compositeFibrePoly {K : Type*} [Field K]
+    [IsAlgClosed K] {Φ Φ' : Polynomial (Polynomial ℤ)} (hΦ : Φ.Monic) (a : K) (j : ℕ) :
+    ((biResultant Φ Φ').coeff j).eval₂ (Int.castRingHom K) a
+      = (compositeFibrePoly Φ Φ' a).coeff j := by
+  rw [← fibrePoly_biResultant Φ' hΦ a, coeff_fibrePoly]
+
+private theorem coeff_biResultant_natDegree_mul_natDegree
+    {Φ Φ' : Polynomial (Polynomial ℤ)} (hΦ : Φ.Monic) (hΦ' : Φ'.Monic) :
+    (biResultant Φ Φ').coeff (Φ.natDegree * Φ'.natDegree) = 1 := by
+  have h := intPoly_eq_C_of_forall_algebraicClosure_eval
+    ((biResultant Φ Φ').coeff (Φ.natDegree * Φ'.natDegree)) 1 ?_
+  · simpa using h
+  intro a
+  rw [eval₂_coeff_biResultant_eq_coeff_compositeFibrePoly hΦ a, Int.cast_one,
+    ← natDegree_compositeFibrePoly hΦ hΦ' a]
+  exact (monic_compositeFibrePoly hΦ' a).coeff_natDegree
+
+private theorem coeff_biResultant_eq_zero_of_natDegree_mul_lt
+    {Φ Φ' : Polynomial (Polynomial ℤ)} (hΦ : Φ.Monic) (hΦ' : Φ'.Monic) {j : ℕ}
+    (hj : Φ.natDegree * Φ'.natDegree < j) : (biResultant Φ Φ').coeff j = 0 := by
+  have h := intPoly_eq_C_of_forall_algebraicClosure_eval ((biResultant Φ Φ').coeff j) 0 ?_
+  · simpa using h
+  intro a
+  rw [eval₂_coeff_biResultant_eq_coeff_compositeFibrePoly hΦ a, Int.cast_zero]
+  exact Polynomial.coeff_eq_zero_of_natDegree_lt
+    ((natDegree_compositeFibrePoly hΦ hΦ' a).symm ▸ hj)
+
+private theorem monic_biResultant {Φ Φ' : Polynomial (Polynomial ℤ)}
+    (hΦ : Φ.Monic) (hΦ' : Φ'.Monic) : (biResultant Φ Φ').Monic :=
+  Polynomial.monic_of_natDegree_le_of_coeff_eq_one (Φ.natDegree * Φ'.natDegree)
+    (Polynomial.natDegree_le_iff_coeff_eq_zero.mpr fun _ hj =>
+      coeff_biResultant_eq_zero_of_natDegree_mul_lt hΦ hΦ' hj)
+    (coeff_biResultant_natDegree_mul_natDegree hΦ hΦ')
+
+private theorem natDegree_biResultant {Φ Φ' : Polynomial (Polynomial ℤ)}
+    (hΦ : Φ.Monic) (hΦ' : Φ'.Monic) :
+    (biResultant Φ Φ').natDegree = Φ.natDegree * Φ'.natDegree :=
+  Polynomial.natDegree_eq_of_le_of_coeff_ne_zero
+    (Polynomial.natDegree_le_iff_coeff_eq_zero.mpr fun _ hj =>
+      coeff_biResultant_eq_zero_of_natDegree_mul_lt hΦ hΦ' hj)
+    (by rw [coeff_biResultant_natDegree_mul_natDegree hΦ hΦ']; exact one_ne_zero)
+
+end MonicDegree
+
+section Engine
+
+private def evalModularPair {R : Type*} [CommRing R] (x y : R)
+    (Φ : Polynomial (Polynomial ℤ)) : R :=
+  Φ.eval₂ (Polynomial.eval₂RingHom (Int.castRingHom R) x) y
+
+private theorem evalModularPair_eq_eval_fibrePoly {K : Type*} [Field K] (a b : K)
+    (Φ : Polynomial (Polynomial ℤ)) :
+    evalModularPair a b Φ = (fibrePoly Φ a).eval b := by
+  rw [evalModularPair, fibrePoly, Polynomial.eval_map]
+
+private theorem Polynomial.resultant_eq_zero_of_isRoot_isRoot {R : Type*} [CommRing R]
+    {f g : R[X]} {b : R} (hf : f.IsRoot b) (hg : g.IsRoot b)
+    {m n : ℕ} (hfm : f.natDegree ≤ m) (hgn : g.natDegree ≤ n) (hmn : m ≠ 0 ∨ n ≠ 0) :
+    Polynomial.resultant f g m n = 0 := by
+  obtain ⟨p, q, _, _, hbez⟩ := Polynomial.exists_mul_add_mul_eq_C_resultant f g hfm hgn hmn
+  have heval := congrArg (Polynomial.eval b) hbez
+  simp only [Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C, hf.eq_zero,
+    hg.eq_zero, zero_mul, add_zero] at heval
+  exact heval.symm
+
+variable {K : Type*} [Field K]
+
+private theorem eval_map_evalRingHom_resLiftOuterK (Φ' : Polynomial (Polynomial ℤ))
+    (b c : K) :
+    ((resLiftOuterK K Φ').map (Polynomial.evalRingHom c)).eval b
+      = evalModularPair b c Φ' :=
+  calc ((resLiftOuterK K Φ').map (Polynomial.evalRingHom c)).eval b
+      = (resLiftOuterK K Φ').eval₂ (Polynomial.evalRingHom c)
+          ((Polynomial.evalRingHom c) (Polynomial.C b)) := by
+        rw [Polynomial.eval_map, Polynomial.coe_evalRingHom, Polynomial.eval_C]
+    _ = (Polynomial.evalRingHom c) ((resLiftOuterK K Φ').eval (Polynomial.C b)) :=
+        Polynomial.eval₂_hom _ _
+    _ = evalModularPair b c Φ' := by
+        rw [eval_C_resLiftOuterK, Polynomial.coe_evalRingHom,
+          evalModularPair_eq_eval_fibrePoly]
+
+private theorem evalModularPair_biResultant_eq_zero_of_common
+    {Φ Φ' : Polynomial (Polynomial ℤ)} (hΦ : Φ.Monic) (hΦpos : Φ.natDegree ≠ 0)
+    {a b c : K} (hab : evalModularPair a b Φ = 0) (hbc : evalModularPair b c Φ' = 0) :
+    evalModularPair a c (biResultant Φ Φ') = 0 := by
+  rw [evalModularPair_eq_eval_fibrePoly, ← specializeAt_eq_fibrePoly, biResultant,
+    ← Polynomial.resultant_map_map, map_resLiftInner, map_resLiftOuter,
+    show Polynomial.eval c
+        = ⇑(Polynomial.evalRingHom c : Polynomial K →+* K) from rfl,
+    ← Polynomial.resultant_map_map, Polynomial.map_map]
+  rw [show (Polynomial.evalRingHom c).comp (Polynomial.C : K →+* Polynomial K)
+        = RingHom.id K from
+      RingHom.ext fun _ => Polynomial.eval_C,
+    Polynomial.map_id]
+  refine Polynomial.resultant_eq_zero_of_isRoot_isRoot
+    (b := b)
+    ?_ ?_ (natDegree_fibrePoly hΦ a).le ?_ (Or.inl hΦpos)
+  · rw [Polynomial.IsRoot, ← evalModularPair_eq_eval_fibrePoly]
+    exact hab
+  · rw [Polynomial.IsRoot, eval_map_evalRingHom_resLiftOuterK]
+    exact hbc
+  · exact Polynomial.natDegree_map_le.trans (natDegree_resLiftOuterK_le Φ' a)
+
+end Engine
+
+section QExpansion
+
+namespace ModularPolynomialData
+p2m_export "ModularCurve.ModularPolynomialData" "monic eval_eq_zero natDegree_eq Φ"
+end ModularPolynomialData
+namespace ModularPolynomialData
+p2m_open_scoped "ModularCurve.ModularPolynomialData" in
+private theorem _root_.ModularCurve.ModularPolynomialData.eval₂_qExpand_eq_zero {N : ℕ} [NeZero N]
+    (data : ModularPolynomialData N) (ℓ : ℕ) [NeZero ℓ] :
+    data.Φ.eval₂ ((qExpand ℚ ℓ).comp evalAtJ) (jqN (ℓ * N)) = 0 := by
+  have h := congrArg (qExpand ℚ ℓ) data.eval_eq_zero
+  rw [map_zero, Polynomial.hom_eval₂] at h
+  rwa [show qExpand ℚ ℓ (jqN N) = jqN (ℓ * N) from qExpand_qExpand N ℓ jq] at h
+
+end ModularPolynomialData
+p2m_export "ModularCurve" "ModularPolynomialData.eval₂_qExpand_eq_zero"
+
+private theorem evalAtJ_eq_eval₂RingHom_intCast_jq :
+    evalAtJ = Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries ℚ)) jq := by
+  refine Polynomial.ringHom_ext' ?_ ?_
+  · exact Subsingleton.elim _ _
+  · rw [evalAtJ_X, Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X]
+
+private theorem qExpand_comp_evalAtJ_eq_eval₂RingHom (m : ℕ) [NeZero m] :
+    (qExpand ℚ m).comp evalAtJ
+      = Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries ℚ)) (jqN m) := by
+  refine Polynomial.ringHom_ext' ?_ ?_
+  · exact Subsingleton.elim _ _
+  · rw [RingHom.comp_apply, evalAtJ_X, Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X]
+    rfl
+
+namespace ModularPolynomialData
+p2m_open_scoped "ModularCurve.ModularPolynomialData" in
+private theorem _root_.ModularCurve.ModularPolynomialData.eval₂_biResultant_eq_zero {m n : ℕ}
+    [NeZero m]
+    [NeZero n] (data : ModularPolynomialData m) (data' : ModularPolynomialData n) :
+    (biResultant data.Φ data'.Φ).eval₂ evalAtJ (jqN (m * n)) = 0 := by
+  rw [evalAtJ_eq_eval₂RingHom_intCast_jq,
+    show (biResultant data.Φ data'.Φ).eval₂
+          (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries ℚ)) jq) (jqN (m * n))
+        = evalModularPair jq (jqN (m * n)) (biResultant data.Φ data'.Φ) from rfl]
+  have hmpos : data.Φ.natDegree ≠ 0 := by
+    rw [data.natDegree_eq]
+    exact (dedekindPsi_pos m (NeZero.ne m)).ne'
+  refine evalModularPair_biResultant_eq_zero_of_common data.monic hmpos
+    (b := jqN m) ?_ ?_
+  · change data.Φ.eval₂ (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries ℚ)) jq)
+        (jqN m) = 0
+    rw [← evalAtJ_eq_eval₂RingHom_intCast_jq]
+    exact data.eval_eq_zero
+  · change data'.Φ.eval₂
+        (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries ℚ)) (jqN m))
+        (jqN (m * n)) = 0
+    rw [← qExpand_comp_evalAtJ_eq_eval₂RingHom]
+    exact data'.eval₂_qExpand_eq_zero m
+
+end ModularPolynomialData
+p2m_export "ModularCurve" "ModularPolynomialData.eval₂_biResultant_eq_zero"
+end QExpansion
+
+namespace ModularPolynomialData
+p2m_open_scoped "ModularCurve.ModularPolynomialData" in
+private def _root_.ModularCurve.ModularPolynomialData.biResultantPacket {m n : ℕ} [NeZero m]
+    [NeZero n]
+    (data : ModularPolynomialData m) (data' : ModularPolynomialData n)
+    (hmn : Nat.Coprime m n) :
+    ModularPolynomialData (m * n) where
+  Φ := biResultant data.Φ data'.Φ
+  monic := monic_biResultant data.monic data'.monic
+  natDegree_eq := by
+    rw [natDegree_biResultant data.monic data'.monic, data.natDegree_eq, data'.natDegree_eq,
+      dedekindPsi_mul_of_coprime m n hmn]
+  eval_eq_zero := data.eval₂_biResultant_eq_zero data'
+
+end ModularPolynomialData
+p2m_export "ModularCurve" "ModularPolynomialData.biResultantPacket"
+
+theorem nonempty_modularPolynomialData_mul_of_coprime {m n : ℕ} [NeZero m] [NeZero n]
+    (data : ModularPolynomialData m) (data' : ModularPolynomialData n)
+    (hmn : Nat.Coprime m n) : Nonempty (ModularPolynomialData (m * n)) :=
+  ⟨data.biResultantPacket data' hmn⟩
+
+end ModularCurve
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_dedekindPsi_mul_of_coprime.ModularCurve
+  ModularCurve.PhiGen in
+theorem solution (M N : ℕ) (h : Nat.Coprime M N) :
+    dedekindPsi (M * N) = dedekindPsi M * dedekindPsi N :=
+  ModularCurve.dedekindPsi_mul_of_coprime M N h
+
+end S_ModularCurve_dedekindPsi_mul_of_coprime
+end P2MW
+export P2MW.S_ModularCurve_dedekindPsi_mul_of_coprime (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.dedekindPsi_mul_of_coprime (M N : ℕ) (h : Nat.Coprime M N) :
+    dedekindPsi (M * N) = dedekindPsi M * dedekindPsi N :=
+  solution M N h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_dedekindPsi_of_squarefree.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_dedekindPsi_of_squarefree.lean
new file mode 100644
index 0000000000..1f5ed0b560
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_dedekindPsi_of_squarefree.lean
@@ -0,0 +1,138 @@
+/-
+Based on Prove2Me node ModularCurve.dedekindPsi_of_squarefree
+(7d026fe4-23a4-5b1a-9f86-5ecdcf6436bc) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a9fedc75-775a-59ea-9cd9-0296dc065c0d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_mul_of_coprime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime
+import Mathlib.Data.Nat.Factorization.Induction
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Dedekind ψ at squarefree level
+
+Theorem statement: `ModularCurve.dedekindPsi_of_squarefree`
+(`7d026fe4-23a4-5b1a-9f86-5ecdcf6436bc`), by Claude, 2026-09-05.
+
+Proof: submission `a9fedc75-775a-59ea-9cd9-0296dc065c0d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number which is squarefree. Here $\psi(N)$ is defined as the natural-number sum
+$\sum_{d} N/d$, taken over those $d$ in the finset of divisors of $N$ which are themselves
+squarefree, the quotient being natural division (for $N = 0$ the divisor finset is empty, so
+$\psi(0) = 0$; squarefreeness of $N$ in any case forces $N \neq 0$). The assertion is the equality
+of natural numbers $$\psi(N) = \prod_{p \in \mathrm{primeFactors}(N)} (p + 1),$$ the product running
+over the finset of prime factors of $N$. In particular the right-hand side is the empty product $1$
+when $N = 1$, matching $\psi(1) = 1$. Thus for squarefree $N$ the sum over squarefree divisors
+collapses to the familiar product formula $N \prod_{p \mid N} (1 + 1/p)$, stated here in the
+integral form $\prod_{p \mid N}(p+1)$.
+
+The function $\psi$ is Dedekind's psi function, the degree of the modular equation of level $N$,
+i.e. the expected degree of the function field of $X_0(N)$ over $\mathbb{Q}(j)$. This closed formula
+at squarefree levels is used by the statements on the degree of $\mathbb{Q}(j)(j_N)$ over
+$\mathbb{Q}(j)$ and on generation of the function field at squarefree level, such as
+[`ModularCurve.finrank_adjoin_jqN_eq_of_squarefree`]
+(thm.html#ModularCurve.finrank_adjoin_jqN_eq_of_squarefree),
+[`ModularCurve.functionFieldGeneration_of_squarefree`]
+(thm.html#ModularCurve.functionFieldGeneration_of_squarefree)
+and [`ModularCurve.relfinrank_adjoin_primes`](thm.html#ModularCurve.relfinrank_adjoin_primes).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_dedekindPsi_of_squarefree.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_dedekindPsi_of_squarefree
+
+namespace ModularCurve
+p2m_export "ModularCurve" "dedekindPsi dedekindPsi_one dedekindPsi_mul_of_coprime dedekindPsi_prime"
+namespace W1
+p2m_open "ModularCurve"
+
+private theorem psi_prime_pow_aux {p : ℕ} (hp : p.Prime) (k : ℕ) :
+    ModularCurve.dedekindPsi (p ^ (k + 1)) = p ^ (k + 1) + p ^ k := by
+  unfold ModularCurve.dedekindPsi
+  have hfil : Finset.filter (fun d => Squarefree d) (p ^ (k + 1)).divisors = {1, p} := by
+    ext x
+    simp only [Finset.mem_filter, Nat.mem_divisors_prime_pow hp, Finset.mem_insert,
+      Finset.mem_singleton]
+    constructor
+    · rintro ⟨⟨j, -, rfl⟩, hsq⟩
+      rcases Nat.eq_zero_or_pos j with rfl | hj0
+      · exact Or.inl (pow_zero p)
+      · have hj1 : j = 1 := ((Nat.squarefree_pow_iff hp.ne_one hj0.ne').mp hsq).2
+        subst hj1
+        exact Or.inr (pow_one p)
+    · rintro (rfl | rfl)
+      · exact ⟨⟨0, Nat.zero_le _, (pow_zero p).symm⟩, squarefree_one⟩
+      · exact ⟨⟨1, by omega, (pow_one _).symm⟩, hp.prime.squarefree⟩
+  rw [hfil, Finset.sum_pair hp.one_lt.ne, Nat.div_one, pow_succ,
+    Nat.mul_div_cancel _ hp.pos]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "dedekindPsi dedekindPsi_one dedekindPsi_mul_of_coprime dedekindPsi_prime"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.dedekindPsi_prime_pow {p : ℕ} (hp : p.Prime) (k : ℕ) :
+    dedekindPsi (p ^ (k + 1)) = (p + 1) * p ^ k := by
+  rw [ModularCurve.W1.psi_prime_pow_aux hp k, Nat.add_mul, Nat.one_mul, ← pow_succ']
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.dedekindPsi_of_squarefree {N : ℕ} (hN : Squarefree N) :
+    dedekindPsi N = ∏ p ∈ N.primeFactors, (p + 1) := by
+  revert hN
+  induction N using Nat.recOnPosPrimePosCoprime with
+  | prime_pow p n hp hn =>
+    intro hsq
+    have hn1 : n = 1 := ((Nat.squarefree_pow_iff hp.ne_one hn.ne').mp hsq).2
+    subst hn1
+    rw [pow_one, ModularCurve.dedekindPsi_prime hp, hp.primeFactors, Finset.prod_singleton]
+  | zero => exact fun h => absurd h not_squarefree_zero
+  | one =>
+    intro _
+    rw [ModularCurve.dedekindPsi_one, Nat.primeFactors_one, Finset.prod_empty]
+  | coprime a b ha hb hab iha ihb =>
+    intro hsq
+    obtain ⟨-, hsa, hsb⟩ := Nat.squarefree_mul_iff.mp hsq
+    rw [ModularCurve.dedekindPsi_mul_of_coprime a b hab,
+      Nat.primeFactors_mul (by omega : a ≠ 0) (by omega : b ≠ 0),
+      Finset.prod_union hab.disjoint_primeFactors, iha hsa, ihb hsb]
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_dedekindPsi_of_squarefree.ModularCurve in
+theorem solution {N : ℕ} (hN : Squarefree N) : dedekindPsi N = ∏ p ∈ N.primeFactors, (p + 1) :=
+  ModularCurve.dedekindPsi_of_squarefree hN
+
+end S_ModularCurve_dedekindPsi_of_squarefree
+end P2MW
+export P2MW.S_ModularCurve_dedekindPsi_of_squarefree (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.dedekindPsi_of_squarefree {N : ℕ} (hN : Squarefree N) :
+    dedekindPsi N = ∏ p ∈ N.primeFactors, (p + 1) :=
+  solution hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_dedekindPsi_pos.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_dedekindPsi_pos.lean
new file mode 100644
index 0000000000..44b4377450
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_dedekindPsi_pos.lean
@@ -0,0 +1,74 @@
+/-
+Based on Prove2Me node ModularCurve.dedekindPsi_pos
+(607c1d4d-f64f-5dde-8549-a2bf11e49376) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 50145f2c-2790-5e0f-9b5d-b9483f1e7751
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_le_dedekindPsi
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Positivity of ψ(N) for N ≠ 0
+
+Theorem statement: `ModularCurve.dedekindPsi_pos` (`607c1d4d-f64f-5dde-8549-a2bf11e49376`), by
+Claude, 2026-09-05.
+
+Proof: submission `50145f2c-2790-5e0f-9b5d-b9483f1e7751`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number with $N \neq 0$. The quantity `dedekindPsi N` is defined as the sum,
+over those divisors $d$ of $N$ that are squarefree, of the natural-number quotient $N/d$; for $N
+\neq 0$ this is the usual Dedekind function $\psi(N) = N\prod_{p \mid N}(1 + 1/p)$, the summands
+being indexed by the squarefree divisors $d$ of $N$ and $N/d$ being an exact division. The assertion
+is that this natural number is strictly positive, i.e. $0 < \psi(N)$. (For $N = 0$ the divisor set
+is empty and the sum would be $0$, so the hypothesis $N \neq 0$ is needed.)
+
+This is the elementary positivity statement for the Dedekind $\psi$ function, the multiplicative
+function giving the index $[\mathrm{SL}_2(\mathbb{Z}) : \Gamma_0(N)]$ and hence the degree of the
+covering $X_0(N) \to X(1)$. It serves to licence division by $\psi(N)$ in the genus and
+Riemann–Hurwitz computations for $X_0(N)$, and is cited widely throughout the development of the
+modular curve models.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_dedekindPsi_pos.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_dedekindPsi_pos
+
+open ModularCurve
+
+theorem solution (N : ℕ) (hN : N ≠ 0) : 0 < dedekindPsi N :=
+  lt_of_lt_of_le (Nat.pos_of_ne_zero hN) (ModularCurve.le_dedekindPsi N hN)
+
+end S_ModularCurve_dedekindPsi_pos
+end P2MW
+export P2MW.S_ModularCurve_dedekindPsi_pos (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.dedekindPsi_pos (N : ℕ) (hN : N ≠ 0) :
+    0 < dedekindPsi N :=
+  solution N hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_dedekindPsi_prime.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_dedekindPsi_prime.lean
new file mode 100644
index 0000000000..51324ec38d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_dedekindPsi_prime.lean
@@ -0,0 +1,81 @@
+/-
+Based on Prove2Me node ModularCurve.dedekindPsi_prime
+(78858587-fcf2-5ab7-b77b-f7327132f734) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9568acc4-f330-51e3-a30f-5aca4d5d65a3
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Value of `dedekindPsi` at a prime: ψ(p)=p+1
+
+Theorem statement: `ModularCurve.dedekindPsi_prime` (`78858587-fcf2-5ab7-b77b-f7327132f734`), by
+Claude, 2026-09-05.
+
+Proof: submission `9568acc4-f330-51e3-a30f-5aca4d5d65a3`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $p$ be a natural number, and assume $p$ is prime. The quantity $\mathrm{dedekindPsi}\,N$ is
+defined, for a natural number $N$, as the sum $\sum_{d} N/d$ taken over those divisors $d$ of $N$
+(in the sense of `Nat.divisors`, so positive divisors of a nonzero $N$) that are squarefree, the
+quotient $N/d$ being natural-number division. The theorem asserts the equality of natural numbers
+$\mathrm{dedekindPsi}\,p = p + 1$. Since the divisors of a prime $p$ are exactly $1$ and $p$, and
+both are squarefree, the defining sum has precisely the two terms $p/1 = p$ and $p/p = 1$. Thus the
+statement is the evaluation at a prime of the arithmetic function whose general value is $\psi(N) =
+N\prod_{\ell \mid N}(1 + 1/\ell)$, here presented through its squarefree-divisor sum definition; no
+further hypotheses beyond primality of $p$ enter.
+
+The function $\mathrm{dedekindPsi}$ is the Dedekind $\psi$ function, which for level $N$ records the
+index $[\mathrm{SL}_2(\mathbb{Z}):\Gamma_0(N)]$ and the degree in each variable of the modular
+polynomial $\Phi_N$; the present lemma is the prime case $\psi(p)=p+1$. It is used throughout the
+algebraic treatment of $X_0(N)$ in the project, for instance in the counting arguments for fibres
+over the $j$-line and in the genus and cusp estimates that invoke it.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_dedekindPsi_prime.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_dedekindPsi_prime
+
+open ModularCurve IntermediateField
+
+noncomputable section
+
+theorem solution {p : ℕ} (hp : p.Prime) : dedekindPsi p = p + 1 :=by
+  rw [dedekindPsi, Finset.sum_filter, hp.divisors, Finset.sum_pair hp.one_lt.ne]
+  simp [hp.squarefree, Nat.div_self hp.pos]
+
+end
+
+end S_ModularCurve_dedekindPsi_prime
+end P2MW
+export P2MW.S_ModularCurve_dedekindPsi_prime (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve IntermediateField
+theorem ModularCurve.dedekindPsi_prime {p : ℕ} (hp : p.Prime) :
+    dedekindPsi p = p + 1 :=
+  solution hp
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_dedekindPsi_prime_pow.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_dedekindPsi_prime_pow.lean
new file mode 100644
index 0000000000..6865c7c988
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_dedekindPsi_prime_pow.lean
@@ -0,0 +1,104 @@
+/-
+Based on Prove2Me node ModularCurve.dedekindPsi_prime_pow
+(42b5757b-a2d0-5c42-9ab9-c8450d39a549) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c9b681dd-26eb-582b-acc2-c2e8fb075045
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import Mathlib.Data.Nat.Squarefree
+import Mathlib.NumberTheory.Divisors
+import Mathlib.Tactic.IntervalCases
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Dedekind ψ at a prime power
+
+Theorem statement: `ModularCurve.dedekindPsi_prime_pow` (`42b5757b-a2d0-5c42-9ab9-c8450d39a549`), by
+Claude, 2026-09-05.
+
+Proof: submission `c9b681dd-26eb-582b-acc2-c2e8fb075045`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $p$ and $k$ be natural numbers, with $p$ prime and $k \neq 0$. The function `dedekindPsi` is
+defined on a natural number $N$ by $\mathrm{dedekindPsi}(N) = \sum_{d} N/d$, the sum being over
+those $d$ in the finite set of divisors of $N$ that are squarefree, with $N/d$ the natural-number
+quotient. The assertion is the equality of natural numbers $$\mathrm{dedekindPsi}(p^k) = p^k +
+p^{k-1},$$ where $k-1$ denotes truncated subtraction in $\mathbb{N}$ (harmless here, since $k \neq
+0$). Equivalently, $\mathrm{dedekindPsi}(p^k) = p^{k-1}(p+1)$: only the divisors $1$ and $p$ of
+$p^k$ are squarefree, so the defining sum has exactly the two terms $p^k/1$ and $p^k/p$.
+
+This is the single Euler factor of the Dedekind $\psi$ function, $\psi(N) = N \prod_{p \mid N}(1 +
+1/p)$, which records the index $[\mathrm{SL}_2(\mathbb{Z}) : \Gamma_0(N)]$ and hence the degree of
+the covering $X_0(N) \to X(1)$. Together with multiplicativity of $\psi$ on coprime arguments it
+pins down $\psi$ at every positive integer, and it is used throughout the numerical work on indices,
+orbit counts and genus formulas for modular curves in this development.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_dedekindPsi_prime_pow.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_dedekindPsi_prime_pow
+
+p2m_open "ModularCurve Finset Nat Finset.Nat"
+
+theorem solution (p k : ℕ) (hp : p.Prime) (hk : k ≠ 0) :
+    dedekindPsi (p ^ k) = p ^ k + p ^ (k - 1) := by
+  have hsqfree : ∀ j, Squarefree (p ^ j) ↔ j ≤ 1 := fun j => by
+    constructor
+    · intro hsq
+      by_contra hj
+      exact hp.one_lt.ne'
+        (Nat.isUnit_iff.mp (hsq p (by rw [← pow_two]; exact pow_dvd_pow p (by omega))))
+    · intro hj
+      interval_cases j
+      · simp
+      · simpa using hp.prime.squarefree
+  have hfilter : {d ∈ (p ^ k).divisors | Squarefree d} = {1, p} := by
+    ext d
+    simp only [Finset.mem_filter, Nat.mem_divisors, Finset.mem_insert, Finset.mem_singleton]
+    constructor
+    · rintro ⟨⟨hdvd, -⟩, hsq⟩
+      obtain ⟨j, hj, rfl⟩ := (Nat.dvd_prime_pow hp).mp hdvd
+      have : j ≤ 1 := (hsqfree j).mp hsq
+      interval_cases j
+      · exact Or.inl (pow_zero p)
+      · exact Or.inr (pow_one p)
+    · rintro (rfl | rfl)
+      · exact ⟨⟨one_dvd _, pow_ne_zero _ hp.pos.ne'⟩, squarefree_one⟩
+      · exact ⟨⟨dvd_pow_self _ hk, pow_ne_zero _ hp.pos.ne'⟩, hp.prime.squarefree⟩
+  have hdiv : p ^ k / p = p ^ (k - 1) := by
+    conv_lhs => rw [show k = (k - 1) + 1 by omega, pow_succ]
+    exact Nat.mul_div_cancel _ hp.pos
+  rw [dedekindPsi, hfilter, Finset.sum_pair hp.one_lt.ne, Nat.div_one, hdiv]
+
+end S_ModularCurve_dedekindPsi_prime_pow
+end P2MW
+export P2MW.S_ModularCurve_dedekindPsi_prime_pow (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.dedekindPsi_prime_pow (p k : ℕ) (hp : p.Prime) (hk : k ≠ 0) :
+    dedekindPsi (p ^ k) = p ^ k + p ^ (k - 1) :=
+  solution p k hp hk
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_deg_eq_one_modularFunctionFieldBar.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_deg_eq_one_modularFunctionFieldBar.lean
new file mode 100644
index 0000000000..302480ff14
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_deg_eq_one_modularFunctionFieldBar.lean
@@ -0,0 +1,235 @@
+/-
+Based on Prove2Me node ModularCurve.deg_eq_one_modularFunctionFieldBar
+(462b7d63-c2fe-5723-b46e-ce8ae3eba2df) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 914c2faf-9973-5702-8ae3-82356f87970e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ArithmeticGalois
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlace
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_laurentBaseChange_modularFunctionFieldFull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_pos
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isAlgebraic_adjoin_of_transcendental
+import Mathlib.FieldTheory.Relrank
+import Mathlib.FieldTheory.IsAlgClosed.Basic
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+import Mathlib.FieldTheory.Minpoly.Basic
+import Mathlib.RingTheory.Algebraic.Integral
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# All places of ℚ̄· F_M have degree one
+
+Theorem statement: `ModularCurve.deg_eq_one_modularFunctionFieldBar`
+(`462b7d63-c2fe-5723-b46e-ce8ae3eba2df`), by Claude, 2026-09-05.
+
+Proof: submission `914c2faf-9973-5702-8ae3-82356f87970e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a positive integer. Write $F_M$ for `modularFunctionFieldFull M`, the subfield of the
+Laurent series field $\mathbb Q((X))$ generated over $\mathbb Q$ by the set `divisorExpansions M`,
+and let `modularFunctionFieldBar M` be its base change `laurentBaseChange`, namely the intermediate
+field of $\overline{\mathbb Q}((X))$ over $\overline{\mathbb Q}$ generated by the image of $F_M$
+under the coefficientwise embedding $\mathbb Q((X)) \to \overline{\mathbb Q}((X))$. The assertion is
+that every place $w$ of `modularFunctionFieldBar M` over $\overline{\mathbb Q}$ has degree one. Here
+a place consists of a valuation subring of the field `modularFunctionFieldBar M` which contains the
+image of $\overline{\mathbb Q}$, is not the whole field, and is a principal ideal ring; its degree
+is the $\overline{\mathbb Q}$-dimension of the residue field of that local ring. Thus the conclusion
+says that the residue field at every such place is $\overline{\mathbb Q}$ itself, i.e. all places of
+the base-changed modular function field are rational over the constant field.
+
+This is the standard fact that over an algebraically closed constant field every place of a function
+field has residue degree one, here for the function field of the modular curve of level $M$ after
+base change to $\overline{\mathbb Q}$. It supplies the degree-one hypothesis used throughout the
+divisor-level Eichler–Shimura bookkeeping and the comparison of places of the characteristic-zero
+model with those of its reductions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_deg_eq_one_modularFunctionFieldBar.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_deg_eq_one_modularFunctionFieldBar
+
+noncomputable section
+
+p2m_open "AlgebraicCurve ModularCurve \
+  P2MW.S_ModularCurve_deg_eq_one_modularFunctionFieldBar.ModularCurve Polynomial"
+
+namespace B2Deg
+
+theorem valuation_aeval_eq_one {K F : Type*} [Field K] [Field F] [Algebra K F] [IsAlgClosed K]
+    (w : Place K F) (y : F)
+    (hy : ∀ c : K, w.toValuationSubring.valuation (y - algebraMap K F c) = 1)
+    (p : K[X]) (hp : p ≠ 0) :
+    w.toValuationSubring.valuation (aeval y p) = 1 := by
+  have hconst : ∀ a : K, a ≠ 0 → w.toValuationSubring.valuation (algebraMap K F a) = 1 := by
+    intro a ha
+    have hu := (IsUnit.mk0 a ha).map (algebraMap K w.toValuationSubring)
+    have h1 := (w.toValuationSubring.valuation_eq_one_iff _).mp hu
+    rwa [Place.coe_algebraMap] at h1
+  have hsplit := IsAlgClosed.splits p
+  have hp' : aeval y p = aeval y (C p.leadingCoeff * (p.roots.map (X - C ·)).prod) := by
+    rw [← hsplit.eq_prod_roots]
+  rw [hp']
+  simp only [map_mul, map_multiset_prod, Multiset.map_map]
+  rw [aeval_C, hconst _ (leadingCoeff_ne_zero.mpr hp), one_mul]
+  refine Multiset.prod_eq_one fun x hx => ?_
+  obtain ⟨c, -, rfl⟩ := Multiset.mem_map.mp hx
+  simpa using hy c
+
+theorem surjective_algebraMap_residueField {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [IsAlgClosed K] (t : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({t} : Set F)) F] (w : Place K F) :
+    Function.Surjective (algebraMap K w.ResidueField) := by
+  intro yb
+  obtain ⟨y, rfl⟩ := IsLocalRing.residue_surjective yb
+  suffices h : ∃ c : K, y - algebraMap K w.toValuationSubring c ∈
+      IsLocalRing.maximalIdeal w.toValuationSubring by
+    obtain ⟨c, hc⟩ := h
+    refine ⟨c, ?_⟩
+    change IsLocalRing.residue _ (algebraMap K w.toValuationSubring c) = IsLocalRing.residue _ y
+    rw [eq_comm, ← sub_eq_zero, ← map_sub, IsLocalRing.residue_eq_zero_iff]
+    exact hc
+  by_cases halg : IsAlgebraic K (y : F)
+  · have hdeg := IsAlgClosed.degree_eq_one_of_irreducible K (minpoly.irreducible halg.isIntegral)
+    obtain ⟨c, hc⟩ := minpoly.mem_range_of_degree_eq_one K (y : F) hdeg
+    refine ⟨c, ?_⟩
+    have h0 : y - algebraMap K w.toValuationSubring c = 0 := Subtype.ext (by simp [← hc])
+    rw [h0]
+    exact zero_mem _
+  · have ht : Transcendental K (y : F) := halg
+    have := AlgebraicCurve.isAlgebraic_adjoin_of_transcendental t ht
+    by_contra hcon
+    simp only [not_exists] at hcon
+    have hunit : ∀ c : K, w.toValuationSubring.valuation ((y : F) - algebraMap K F c) = 1 := by
+      intro c
+      have hle := w.toValuationSubring.valuation_le_one (y - algebraMap K w.toValuationSubring c)
+      have hnlt : ¬ w.toValuationSubring.valuation
+          ((y - algebraMap K w.toValuationSubring c : w.toValuationSubring) : F) < 1 :=
+        fun hlt => hcon c ((w.toValuationSubring.valuation_lt_one_iff _).mpr hlt)
+      have heq := hle.eq_of_not_lt hnlt
+      simpa using heq
+    have hadj : ∀ z : F, z ∈ IntermediateField.adjoin K ({(y : F)} : Set F) →
+        z ∈ w.toValuationSubring := by
+      intro z hz
+      rw [IntermediateField.mem_adjoin_simple_iff] at hz
+      obtain ⟨r, s, rfl⟩ := hz
+      rw [← w.toValuationSubring.valuation_le_one_iff, map_div₀]
+      by_cases hr : r = 0
+      · simp [hr]
+      by_cases hs : s = 0
+      · simp [hs]
+      simp only [valuation_aeval_eq_one w y hunit r hr, valuation_aeval_eq_one w y hunit s hs,
+        div_one,
+        le_refl]
+    apply (w.restrict (IntermediateField.adjoin K ({(y : F)} : Set F))).ne_top'
+    refine SetLike.ext fun z => ⟨fun _ => ValuationSubring.mem_top z, fun _ => ?_⟩
+    rw [Place.mem_restrict_iff, IntermediateField.algebraMap_apply]
+    exact hadj z z.2
+
+theorem deg_eq_one_of_isAlgebraic_adjoin {K F : Type*} [Field K] [Field F] [Algebra K F]
+    [IsAlgClosed K] (t : F)
+    [Algebra.IsAlgebraic (IntermediateField.adjoin K ({t} : Set F)) F] (w : Place K F) :
+    w.deg = 1 := by
+  have : Module.Finite K w.ResidueField :=
+    Module.Finite.of_surjective (Algebra.linearMap K w.ResidueField)
+      (surjective_algebraMap_residueField t w)
+  exact w.deg_eq_one_of_isAlgClosed_of_finite
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+theorem finiteDimensional_adjoin_jBar (M : ℕ) [NeZero M] :
+    FiniteDimensional
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({(⟨coeffEmb (AlgebraicClosure ℚ) jq,
+            coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full M)⟩ :
+            modularFunctionFieldBar M)} : Set (modularFunctionFieldBar M)))
+      (modularFunctionFieldBar M) := by
+  set j : modularFunctionFieldBar M := ⟨coeffEmb (AlgebraicClosure ℚ) jq,
+    coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full M)⟩ with hj
+  have hcm : IntermediateField.comap (modularFunctionFieldBar M).val
+        (IntermediateField.adjoin (AlgebraicClosure ℚ)
+          ({(j : LaurentSeries (AlgebraicClosure ℚ))} :
+            Set (LaurentSeries (AlgebraicClosure ℚ))))
+      = IntermediateField.adjoin (AlgebraicClosure ℚ) ({j} : Set (modularFunctionFieldBar M)) := by
+    rw [← IntermediateField.lift_adjoin_simple]
+    exact IntermediateField.comap_map (modularFunctionFieldBar M).val _
+  have h1 := IntermediateField.finrank_comap
+    (IntermediateField.adjoin (AlgebraicClosure ℚ)
+      ({(j : LaurentSeries (AlgebraicClosure ℚ))} : Set (LaurentSeries (AlgebraicClosure ℚ))))
+    (modularFunctionFieldBar M).val
+  rw [hcm, IntermediateField.fieldRange_val] at h1
+  have h2 : IntermediateField.relfinrank
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({(j : LaurentSeries (AlgebraicClosure ℚ))} : Set (LaurentSeries (AlgebraicClosure ℚ))))
+      (modularFunctionFieldBar M) = dedekindPsi M := by
+    rw [← ModularCurve.relfinrank_full_eq_dedekindPsi M,
+      ← ModularCurve.relfinrank_laurentBaseChange_modularFunctionFieldFull (AlgebraicClosure ℚ) M]
+  have hpos : 0 < IntermediateField.relfinrank
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({(j : LaurentSeries (AlgebraicClosure ℚ))} : Set (LaurentSeries (AlgebraicClosure ℚ))))
+      (modularFunctionFieldBar M) := by
+    rw [h2]
+    exact ModularCurve.dedekindPsi_pos M (NeZero.ne M)
+  rw [← h1] at hpos
+  exact Module.finite_of_finrank_pos hpos
+
+end B2Deg
+
+namespace ModularCurve
+p2m_export "ModularCurve" "modularFunctionFieldBar jq dedekindPsi coeffEmb laurentBaseChange \
+  coeffEmb_mem_laurentBaseChange jq_mem_full relfinrank_laurentBaseChange_modularFunctionFieldFull \
+  relfinrank_full_eq_dedekindPsi dedekindPsi_pos"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+private theorem ModularCurve.deg_eq_one_modularFunctionFieldBar (M : ℕ) [NeZero M]
+    (w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar M)) : w.deg = 1 := by
+  have := B2Deg.finiteDimensional_adjoin_jBar M
+  exact B2Deg.deg_eq_one_of_isAlgebraic_adjoin
+    (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+      coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full M)⟩ :
+      modularFunctionFieldBar M) w
+
+end
+
+open AlgebraicCurve _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_deg_eq_one_modularFunctionFieldBar.ModularCurve in
+theorem solution (M : ℕ) [NeZero M] (w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar M)) :
+    w.deg = 1 :=
+  ModularCurve.deg_eq_one_modularFunctionFieldBar M w
+
+end S_ModularCurve_deg_eq_one_modularFunctionFieldBar
+end P2MW
+export P2MW.S_ModularCurve_deg_eq_one_modularFunctionFieldBar (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve ModularCurve
+theorem ModularCurve.deg_eq_one_modularFunctionFieldBar (M : ℕ) [NeZero M]
+    (w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar M)) :
+    w.deg = 1 :=
+  solution M w
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_deg_jLinePlace1728.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_deg_jLinePlace1728.lean
new file mode 100644
index 0000000000..f210f5439d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_deg_jLinePlace1728.lean
@@ -0,0 +1,84 @@
+/-
+Based on Prove2Me node ModularCurve.deg_jLinePlace1728
+(60ae1463-3d99-596c-bf72-18deed415732) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5f6bcf1c-a579-5ad7-b4fe-a50f72f40176
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JLinePlaces
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The j-line place at j=1728 has degree 1
+
+Theorem statement: `ModularCurve.deg_jLinePlace1728` (`60ae1463-3d99-596c-bf72-18deed415732`), by
+Claude, 2026-09-05.
+
+Proof: submission `5f6bcf1c-a579-5ad7-b4fe-a50f72f40176`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let `jq` be the transcendental element over $\mathbb{Q}$ out of which the $j$-line is built, and let
+$\mathbb{Q}\langle$`jq`$\rangle$ denote the intermediate field it generates; `jLineRingEquiv` is the
+ring isomorphism $\mathrm{RatFunc}\,\mathbb{Q} \cong \mathbb{Q}\langle$`jq`$\rangle$ sending the
+indeterminate to `jq`, obtained from the transcendence of `jq`. Here a place of an extension $F/K$
+is a valuation subring of $F$ that contains the image of $K$, is not the whole of $F$, and is a
+principal ideal ring, and its degree is the $K$-dimension of the residue field of that valuation
+subring. The place `jLinePlace1728` is the transport along `jLineRingEquiv` (which fixes
+$\mathbb{Q}$, so that the transported valuation subring, the preimage under the inverse isomorphism,
+is again a place over $\mathbb{Q}$) of the finite place `placeOfPoint ℚ 1728` of
+$\mathrm{RatFunc}\,\mathbb{Q}$ attached to the irreducible polynomial $X - 1728$. The theorem
+asserts that the degree of `jLinePlace1728` equals $1$; equivalently, its residue field is
+$\mathbb{Q}$ itself, so the place is rational.
+
+This records that the point $j = 1728$ of the $j$-line is a rational place, one of the two
+distinguished points (together with $j = 0$, and the cusp) around which ramification of the modular
+covers is concentrated. It is used in the identification of the number of points of the modular
+curve with $\bar{j} = 1728$, respectively $\bar{j} = 0$, with the counts $\nu_2$ and $\nu_3$ of
+elliptic points of order $2$ and $3$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_deg_jLinePlace1728.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_deg_jLinePlace1728
+
+open IntermediateField AlgebraicCurve AlgebraicCurve.RationalFunctionField
+
+attribute [local instance 2000] RatFunc.instAlgebraOfPolynomial
+attribute [local instance] ModularCurve.instDecidableEqRatFuncRat
+
+theorem solution : ModularCurve.jLinePlace1728.deg = 1 := by
+  unfold ModularCurve.jLinePlace1728
+  rw [Place.deg_congrRingEquiv]
+  exact deg_placeOfPoint ℚ 1728
+
+end S_ModularCurve_deg_jLinePlace1728
+end P2MW
+export P2MW.S_ModularCurve_deg_jLinePlace1728 (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open IntermediateField AlgebraicCurve
+theorem ModularCurve.deg_jLinePlace1728 :
+    ModularCurve.jLinePlace1728.deg = 1 :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_deg_jLinePlaceZero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_deg_jLinePlaceZero.lean
new file mode 100644
index 0000000000..ce956e510a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_deg_jLinePlaceZero.lean
@@ -0,0 +1,90 @@
+/-
+Based on Prove2Me node ModularCurve.deg_jLinePlaceZero
+(6d6e0936-4104-597f-9f2e-43a465c2c9d8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5ec398bb-d3c3-5136-872e-bc5acdce0f66
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JLinePlaces
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The place j=0 of the j-line has degree 1
+
+Theorem statement: `ModularCurve.deg_jLinePlaceZero` (`6d6e0936-4104-597f-9f2e-43a465c2c9d8`), by
+Claude, 2026-09-05.
+
+Proof: submission `5ec398bb-d3c3-5136-872e-bc5acdce0f66`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+The statement concerns the field $\mathbb{Q}\langle j\rangle$ obtained as the intermediate field
+generated over $\mathbb{Q}$ by the element `jq`, which is transcendental over $\mathbb{Q}$; for this
+field the project fixes the place
+[`ModularCurve.jLinePlaceZero`](def/ModularCurve_JLinePlaces.html#L54). Here a place of an extension
+$F/K$ is a valuation subring of $F$ containing the image of $K$, distinct from $F$ itself, and which
+is a principal ideal ring, and its degree is the $K$-dimension of the residue field of that local
+ring. The place in question is obtained by transporting, along the ring isomorphism
+[`ModularCurve.jLineRingEquiv : RatFunc ℚ ≃+* ℚ⟮jq⟯`](def/ModularCurve_JLinePlaces.html#L36)
+determined by the transcendence of `jq` (which sends the indeterminate to `jq` and is the identity
+on $\mathbb{Q}$), the place `placeOfPoint ℚ 0` of the rational function field $\mathbb{Q}(X)$,
+namely the finite place attached to the irreducible polynomial $X-0$; transport replaces the
+valuation subring by its preimage under the inverse isomorphism. The assertion is that the degree of
+this place equals $1$, i.e. its residue field is one-dimensional over $\mathbb{Q}$, so the place is
+rational.
+
+This records that the point $j=0$ of the $j$-line is a rational point, the residue field being
+$\mathbb{Q}$ itself. It is used in the computation of ramification data for the covering of the
+$j$-line by the modular curve, entering the counts
+[`ModularCurve.natCard_ord_jBar_eq_one_eq_nuThree`]
+(thm.html#ModularCurve.natCard_ord_jBar_eq_one_eq_nuThree)
+and
+[`ModularCurve.natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo`]
+(thm.html#ModularCurve.natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo)
+of points above $j=0$ and $j=1728$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_deg_jLinePlaceZero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_deg_jLinePlaceZero
+
+open IntermediateField AlgebraicCurve AlgebraicCurve.RationalFunctionField
+
+attribute [local instance 2000] RatFunc.instAlgebraOfPolynomial
+attribute [local instance] ModularCurve.instDecidableEqRatFuncRat
+
+theorem solution : ModularCurve.jLinePlaceZero.deg = 1 := by
+  unfold ModularCurve.jLinePlaceZero
+  rw [Place.deg_congrRingEquiv]
+  exact deg_placeOfPoint ℚ 0
+
+end S_ModularCurve_deg_jLinePlaceZero
+end P2MW
+export P2MW.S_ModularCurve_deg_jLinePlaceZero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open IntermediateField AlgebraicCurve
+theorem ModularCurve.deg_jLinePlaceZero :
+    ModularCurve.jLinePlaceZero.deg = 1 :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_deg_ne_zero_modularFunctionFieldC.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_deg_ne_zero_modularFunctionFieldC.lean
new file mode 100644
index 0000000000..bf290b8120
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_deg_ne_zero_modularFunctionFieldC.lean
@@ -0,0 +1,176 @@
+/-
+Based on Prove2Me node ModularCurve.deg_ne_zero_modularFunctionFieldC
+(86203315-985f-5ea0-9330-962da2bfe134) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c43290c4-6d44-5ff4-aa2b-6a03143d17b9
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_inertiaDeg_pos_of_finiteDimensional
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_adjoin_jqNModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_modularPolynomialData
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Places of K(j,j_N) have nonzero degree
+
+Theorem statement: `ModularCurve.deg_ne_zero_modularFunctionFieldC`
+(`86203315-985f-5ea0-9330-962da2bfe134`), by Claude, 2026-09-05.
+
+Proof: submission `c43290c4-6d44-5ff4-aa2b-6a03143d17b9`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field (arbitrary characteristic) and let $N$ be a natural number with $N \neq 0$.
+Inside the field $\mathrm{LaurentSeries}\ K$ of Laurent series over $K$, write $j$ for `jqModC K`,
+the series $q^{-1}$ times the image under $K$-coefficient reduction of the integral power series
+`jNum`, and $j_N$ for `jqNModC K N`, obtained from $j$ by the substitution `qExpand K N` (raising
+the variable to the $N$-th power); let `modularFunctionFieldC K N` be the intermediate field
+$K(j,j_N)$ of $\mathrm{LaurentSeries}\ K$ generated over $K$ by these two elements. Let $w$ be a
+place of $K(j,j_N)$ over $K$ in the sense of the project's structure `Place`, that is, a valuation
+subring of $K(j,j_N)$ which contains the image of $K$, is not the whole field, and is a principal
+ideal ring. The conclusion is that $w.\mathrm{deg} \neq 0$, where $w.\mathrm{deg}$ is the
+$K$-dimension $\operatorname{finrank}_K$ of the residue field of that valuation subring;
+equivalently, the residue field of $w$ is a finite extension of $K$.
+
+This is the statement that the level-$N$ modular function field, realised concretely as the subfield
+$K(j,j_N)$ of $K((q))$, is a function field over $K$ in the sense that all its places have finite
+residue degree. It is used in the construction of places of this field from solutions of the modular
+polynomial and in the verifications that the modular function field and its base changes are curves
+over the relevant base fields.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_deg_ne_zero_modularFunctionFieldC.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_deg_ne_zero_modularFunctionFieldC
+
+open AlgebraicCurve ModularCurve IntermediateField Polynomial
+
+noncomputable section
+
+namespace S09T3
+
+section Generic
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+  [Algebra F F'] [IsScalarTower K F F'] [FiniteDimensional F F']
+
+theorem deg_ne_zero_of_restrict (w : Place K F') (h : (w.restrict F).deg ≠ 0) : w.deg ≠ 0 := by
+  rw [← w.deg_restrict_mul_inertiaDeg (F := F)]
+  exact mul_ne_zero h (Place.inertiaDeg_pos_of_finiteDimensional (F := F) w).ne'
+end Generic
+
+variable (K : Type*) [Field K]
+
+abbrev Fj : IntermediateField K (LaurentSeries K) := adjoin K ({jqModC K} : Set (LaurentSeries K))
+
+noncomputable def psi : RatFunc K →ₐ[K] LaurentSeries K :=
+  RatFunc.liftAlgHom (aeval (jqModC K))
+    (nonZeroDivisors_le_comap_nonZeroDivisors_of_injective _
+      (transcendental_iff_injective.mp (transcendental_jqModC K)))
+
+theorem psi_injective : Function.Injective (psi K) :=
+  RatFunc.liftAlgHom_injective _ (transcendental_iff_injective.mp (transcendental_jqModC K))
+
+theorem psi_mem (f : RatFunc K) : psi K f ∈ Fj K := by
+  rw [← f.num_div_denom, psi, RatFunc.liftAlgHom_apply_div]
+  exact (mem_adjoin_simple_iff K _).mpr ⟨_, _, rfl⟩
+
+noncomputable def ratFuncEquiv : RatFunc K ≃+* Fj K :=
+  RingEquiv.ofBijective
+    ({ toFun := fun f => ⟨psi K f, psi_mem K f⟩
+       map_one' := Subtype.ext (map_one (psi K))
+       map_mul' := fun a b => Subtype.ext (map_mul (psi K) a b)
+       map_zero' := Subtype.ext (map_zero (psi K))
+       map_add' := fun a b => Subtype.ext (map_add (psi K) a b) } : RatFunc K →+* Fj K)
+    ⟨fun a b hab => psi_injective K (congrArg Subtype.val hab), by
+      rintro ⟨x, hx⟩
+      obtain ⟨r, s, rfl⟩ := (mem_adjoin_simple_iff K _).mp hx
+      refine ⟨algebraMap _ _ r / algebraMap _ _ s, Subtype.ext ?_⟩
+      change psi K (algebraMap _ _ r / algebraMap _ _ s) = _
+      rw [psi, RatFunc.liftAlgHom_apply_div]⟩
+
+theorem ratFuncEquiv_algebraMap (a : K) :
+    ratFuncEquiv K (algebraMap K (RatFunc K) a) = algebraMap K (Fj K) a :=
+  Subtype.ext (by exact (psi K).commutes a)
+
+theorem deg_ne_zero_Fj (v : Place K (Fj K)) : v.deg ≠ 0 := by
+  rw [← Place.deg_congrRingEquiv (ratFuncEquiv K).symm
+    (Place.symm_algebraMap_comm _ (ratFuncEquiv_algebraMap K)) v]
+  exact RationalFunctionField.deg_ne_zero _
+
+variable (N : ℕ) [NeZero N]
+
+abbrev FjN : IntermediateField (Fj K) (LaurentSeries K) :=
+  adjoin (Fj K) ({jqNModC K N} : Set (LaurentSeries K))
+
+theorem modularFunctionFieldC_eq_restrictScalars :
+    modularFunctionFieldC K N = (FjN K N).restrictScalars K := by
+  change modularFunctionFieldC K N =
+    (adjoin (adjoin K ({jqModC K} : Set (LaurentSeries K))) ({jqNModC K N} : Set (LaurentSeries
+      K))).restrictScalars K
+  erw [adjoin_adjoin_left]
+  rw [Set.singleton_union]
+  rfl
+
+noncomputable def toFjN : modularFunctionFieldC K N ≃+* FjN K N :=
+  (equivOfEq (modularFunctionFieldC_eq_restrictScalars K N)).toRingEquiv.trans
+    { toFun := fun x => ⟨x.1, x.2⟩
+      invFun := fun x => ⟨x.1, x.2⟩
+      left_inv := fun _ => rfl
+      right_inv := fun _ => rfl
+      map_mul' := fun _ _ => rfl
+      map_add' := fun _ _ => rfl }
+
+theorem toFjN_algebraMap (a : K) :
+    toFjN K N (algebraMap K (modularFunctionFieldC K N) a) = algebraMap K (FjN K N) a :=
+  Subtype.ext rfl
+
+end S09T3
+
+end
+
+open S09T3 in
+theorem solution (K : Type*) [Field K] (N : ℕ) [NeZero N] (w : Place K (modularFunctionFieldC K N))
+    :
+    w.deg ≠ 0 := by
+  obtain ⟨data⟩ := nonempty_modularPolynomialData N
+  have : FiniteDimensional (Fj K) (FjN K N) := finiteDimensional_adjoin_jqNModC K data
+  rw [← Place.deg_congrRingEquiv (toFjN K N) (toFjN_algebraMap K N) w]
+  exact deg_ne_zero_of_restrict (F := Fj K) _ (deg_ne_zero_Fj K _)
+
+end S_ModularCurve_deg_ne_zero_modularFunctionFieldC
+end P2MW
+export P2MW.S_ModularCurve_deg_ne_zero_modularFunctionFieldC (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve ModularCurve
+theorem ModularCurve.deg_ne_zero_modularFunctionFieldC (K : Type*) [Field K] (N : ℕ) [NeZero N]
+    (w : Place K (modularFunctionFieldC K N)) :
+    w.deg ≠ 0 :=
+  solution K N w
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_degree_add_one_sub_genusFF_le_finrank_riemannRochSpace.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_degree_add_one_sub_genusFF_le_finrank_riemannRochSpace.lean
new file mode 100644
index 0000000000..d2235b59c3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_degree_add_one_sub_genusFF_le_finrank_riemannRochSpace.lean
@@ -0,0 +1,114 @@
+/-
+Based on Prove2Me node ModularCurve.degree_add_one_sub_genusFF_le_finrank_riemannRochSpace
+(dd98beda-feee-5db6-bfc6-ebe78bbb546e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 52961c71-06cc-5015-80e4-e30e4c065e44
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JZeroHeightForm
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RiemannRochRows
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldRiemannRoch_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCurveOver_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasCanonicalDivisor_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_essFiniteType_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_dCoordGenerates_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_genus_eq_genusFF_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Riemann's inequality for the function field of X₀(N) over ℚ̄
+
+Theorem statement: `ModularCurve.degree_add_one_sub_genusFF_le_finrank_riemannRochSpace`
+(`dd98beda-feee-5db6-bfc6-ebe78bbb546e`), by Claude, 2026-09-05.
+
+Proof: submission `52961c71-06cc-5015-80e4-e30e4c065e44`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and let $F_N =$ `modularFunctionFieldBar N` be the intermediate
+field of $\overline{\mathbb Q} \subseteq \mathrm{LaurentSeries}(\overline{\mathbb Q})$ obtained by
+base change: it is generated over $\overline{\mathbb Q}$ by the image, under the coefficientwise
+embedding of $\mathrm{LaurentSeries}(\mathbb Q)$ into $\mathrm{LaurentSeries}(\overline{\mathbb
+Q})$, of the subfield $\mathbb Q(\mathrm{divisorExpansions}\,N)$ of $\mathrm{LaurentSeries}(\mathbb
+Q)$ generated by the $q$-expansions attached to the divisors of $N$. A place of $F_N$ over
+$\overline{\mathbb Q}$ is, by definition, a valuation subring of $F_N$ that contains the image of
+$\overline{\mathbb Q}$, is not all of $F_N$, and is a principal ideal ring; a divisor is a finitely
+supported function from places to $\mathbb Z$. Let $D$ be such a divisor. Its degree is $\sum_v
+D(v)\,\deg v$, and the Riemann–Roch space $L(D)$ is the $\overline{\mathbb Q}$-submodule of those $f
+\in F_N$ with $v_{\mathrm{adic}}(f) \le \exp(D(v))$ in $\mathbb Z^{m0}$ for every place $v$. The
+assertion is the inequality in $\mathbb Z$
+$$\deg D + 1 - g \;\le\; \dim_{\overline{\mathbb Q}} L(D),$$
+where $g$ is `genusFF`, namely $\dim_{\overline{\mathbb Q}} H^1(0)$ for the zero divisor.
+
+This is Riemann's inequality for the function field of $X_0(N)$ over $\overline{\mathbb Q}$, stated
+in the adelic currency (Riemann–Roch space and the genus defined as $\dim H^1(0)$) used by the
+height and specialisation theory on $J_0(N)$. It is cited when sections of a divisor with prescribed
+behaviour must be produced, for instance in the dimension estimates for spaces of modular forms of
+level $\Gamma_0(N)$ and in the construction of prolongation models and residue pairs on modular
+curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_degree_add_one_sub_genusFF_le_finrank_riemannRochSpace.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_degree_add_one_sub_genusFF_le_finrank_riemannRochSpace
+
+open AlgebraicCurve ModularCurve KaehlerDifferential
+
+theorem solution (N : ℕ) [NeZero N]
+    (D : Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) :
+    D.degree + 1 - (genusFF (AlgebraicClosure ℚ) (modularFunctionFieldBar N) : ℤ)
+      ≤ (Module.finrank (AlgebraicClosure ℚ) ↥(riemannRochSpace D) : ℤ) := by
+  classical
+  have : IsCurveOver (AlgebraicClosure ℚ) (modularFunctionFieldBar N) :=
+    isCurveOver_modularFunctionFieldBar N
+  have : HasCanonicalDivisor (K := AlgebraicClosure ℚ) (F := modularFunctionFieldBar N) :=
+    hasCanonicalDivisor_modularFunctionFieldBar N
+  have : Algebra.EssFiniteType (AlgebraicClosure ℚ) (modularFunctionFieldBar N) :=
+    essFiniteType_modularFunctionFieldBar N
+  have : PerfectField (AlgebraicClosure ℚ) := PerfectField.ofCharZero
+  have : ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), w.DCoordGenerates :=
+    AlgebraicCurve.dCoordGenerates_of_isCurveOver
+  have hRR : FunctionFieldRiemannRoch (AlgebraicClosure ℚ) (modularFunctionFieldBar N) :=
+    functionFieldRiemannRoch_modularFunctionFieldBar N
+  obtain ⟨ω, hω⟩ := exists_ne (0 : Ω[(modularFunctionFieldBar N)⁄(AlgebraicClosure ℚ)])
+  have h := hRR hω D
+  have hg : (genus (AlgebraicClosure ℚ) (modularFunctionFieldBar N) : ℤ)
+      = genusFF (AlgebraicClosure ℚ) (modularFunctionFieldBar N) := by
+    exact_mod_cast genus_eq_genusFF_modularFunctionFieldBar N
+  have h0 : (0 : ℤ) ≤ ell (canonicalDivisorOf hω - D) := Nat.cast_nonneg _
+  change _ ≤ ((ell D : ℕ) : ℤ)
+  rw [← hg]
+  linarith
+
+end S_ModularCurve_degree_add_one_sub_genusFF_le_finrank_riemannRochSpace
+end P2MW
+export P2MW.S_ModularCurve_degree_add_one_sub_genusFF_le_finrank_riemannRochSpace (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve ModularCurve
+theorem ModularCurve.degree_add_one_sub_genusFF_le_finrank_riemannRochSpace (N : ℕ) [NeZero N]
+    (D : Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) :
+    D.degree + 1 - (genusFF (AlgebraicClosure ℚ) (modularFunctionFieldBar N) : ℤ)
+      ≤ (Module.finrank (AlgebraicClosure ℚ) ↥(riemannRochSpace D) : ℤ) :=
+  solution N D
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_degree_canonicalDivisorOf_modularFunctionFieldBar.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_degree_canonicalDivisorOf_modularFunctionFieldBar.lean
new file mode 100644
index 0000000000..0739af912d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_degree_canonicalDivisorOf_modularFunctionFieldBar.lean
@@ -0,0 +1,158 @@
+/-
+Based on Prove2Me node ModularCurve.degree_canonicalDivisorOf_modularFunctionFieldBar
+(98caf52b-11f8-5950-96a7-21cd2381921b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 217dd037-2f18-5c4f-852e-3d79fe30d6d4
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_CanonicalDivisor
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ArithmeticGalois
+
+import Mathlib.RingTheory.Finiteness.ModuleFinitePresentation
+import Mathlib.RingTheory.PicardGroup
+import Mathlib.RingTheory.TotallySplit
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_CanonicalLocalResidueInstanceV2
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JLinePlacesBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_dCoordGenerates_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_degree_canonicalDivisor_eq_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_instIsCurveOverRatFunc
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_essFiniteType_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_of_neZero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCurveOver_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree of a canonical divisor on X₀(N) over ℚ̄ is 2g-2
+
+Theorem statement: `ModularCurve.degree_canonicalDivisorOf_modularFunctionFieldBar`
+(`98caf52b-11f8-5950-96a7-21cd2381921b`), by Claude, 2026-09-05.
+
+Proof: submission `217dd037-2f18-5c4f-852e-3d79fe30d6d4`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number with $N \neq 0$, let $K = \overline{\mathbb Q}$ be the algebraic closure
+of $\mathbb Q$ produced by `AlgebraicClosure`, and let $F =$ [`ModularCurve.modularFunctionFieldBar
+N`](def/ModularCurve_ArithmeticGalois.html#L111) be the intermediate field of $K\,((t))$-type
+Laurent series $\mathrm{LaurentSeries}(K)$ over $K$ obtained by adjoining to $K$ the images, under
+the coefficientwise embedding `coeffEmb`, of all elements of the field
+[`ModularCurve.modularFunctionFieldFull N`](def/ModularCurve_X0.html#L305), the subfield of
+$\mathrm{LaurentSeries}(\mathbb Q)$ generated over $\mathbb Q$ by the divisor expansions
+`divisorExpansions N`. Assume $F$ satisfies
+[`AlgebraicCurve.HasCanonicalDivisor`](def/AlgebraicCurve_CanonicalDivisor.html#L14) over $K$: for
+every nonzero Kähler differential $\omega \in \Omega_{F/K}$ there is a finitely supported function
+$D$ on the places of $F/K$ (valuation subrings of $F$ containing $K$, distinct from $F$ itself,
+whose ideals are all principal) with $D(v) = v.\mathrm{ordDifferential}\,\omega$, the valuation at
+$v$ of the chosen differential coefficient of $\omega$, for every such place $v$. Let $\omega$ be a
+nonzero element of $\Omega_{F/K}$. Then the degree of the associated canonical divisor
+[`AlgebraicCurve.canonicalDivisorOf hω`](def/AlgebraicCurve_CanonicalDivisor.html#L18), namely
+$\sum_v D(v)\,\deg(v)$, equals $2g - 2$ in $\mathbb Z$, where $g$ is
+[`AlgebraicCurve.genus`](def/AlgebraicCurve_CanonicalDivisor.html#L33) of $F$ over $K$, defined as
+$(\deg(\omega_0) + 2)/2$ for a chosen nonzero differential $\omega_0$ (and $0$ if none exists).
+
+This is the classical statement that a canonical divisor on a curve has degree $2g-2$, here for the
+function field of $X_0(N)$ over $\overline{\mathbb Q}$ in its Laurent-expansion model. It underlies
+the Riemann–Roch computations on $X_0(N)$ used later, for instance in the height and Riemann–Roch
+space estimates attached to the $j$-line.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_degree_canonicalDivisorOf_modularFunctionFieldBar.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_degree_canonicalDivisorOf_modularFunctionFieldBar
+
+
+attribute [local instance] ModularCurve.instDecidableEqRatFuncAlgebraicClosure
+
+open ModularCurve AlgebraicCurve
+
+theorem solution (N : ℕ) [NeZero N]
+    [AlgebraicCurve.HasCanonicalDivisor (K := AlgebraicClosure ℚ) (F :=
+      ↥(ModularCurve.modularFunctionFieldBar N))]
+    {ω : Ω[↥(ModularCurve.modularFunctionFieldBar N)⁄(AlgebraicClosure ℚ)]} (hω : ω ≠ 0) :
+    (AlgebraicCurve.canonicalDivisorOf hω).degree
+      = 2 * (AlgebraicCurve.genus (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar N) :
+        ℤ) - 2 := by
+  have : IsCurveOver (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+    isCurveOver_modularFunctionFieldBar N
+  have : HasPrincipalDivisors (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+    IsCurveOver.hasPrincipalDivisors
+  have : Algebra.EssFiniteType (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+    essFiniteType_modularFunctionFieldBar N
+  have hDCG : ∀ w : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N), w.DCoordGenerates :=
+    AlgebraicCurve.dCoordGenerates_of_isCurveOver
+  let algRE : Algebra (RatFunc (AlgebraicClosure ℚ)) ↥(jLineBar N) :=
+    (jLineBarRingEquiv N).toRingHom.toAlgebra
+  let algRF : Algebra (RatFunc (AlgebraicClosure ℚ)) ↥(modularFunctionFieldBar N) :=
+    ((algebraMap ↥(jLineBar N) ↥(modularFunctionFieldBar N)).comp (jLineBarRingEquiv
+      N).toRingHom).toAlgebra
+  have : IsScalarTower (RatFunc (AlgebraicClosure ℚ)) ↥(jLineBar N) ↥(modularFunctionFieldBar N) :=
+    IsScalarTower.of_algebraMap_eq (fun _ => rfl)
+  have : IsScalarTower (AlgebraicClosure ℚ) (RatFunc (AlgebraicClosure ℚ)) ↥(modularFunctionFieldBar
+    N) :=
+    by
+    refine IsScalarTower.of_algebraMap_eq (fun a => ?_)
+    change algebraMap _ _ a = algebraMap ↥(jLineBar N) ↥(modularFunctionFieldBar N)
+      (jLineBarRingEquiv N (algebraMap _ _ a))
+    rw [jLineBarRingEquiv_algebraMap]
+    rfl
+  have : Module.Finite (RatFunc (AlgebraicClosure ℚ)) ↥(jLineBar N) :=
+    Module.Finite.of_surjective (Algebra.linearMap (RatFunc (AlgebraicClosure ℚ)) ↥(jLineBar N))
+      (jLineBarRingEquiv N).surjective
+  have : FiniteDimensional ↥(jLineBar N) ↥(modularFunctionFieldBar N) :=
+    finiteDimensional_adjoin_coeffEmb_jq_of_neZero N
+  have hfinRF : Module.Finite (RatFunc (AlgebraicClosure ℚ)) ↥(modularFunctionFieldBar N) :=
+    Module.Finite.trans ↥(jLineBar N) ↥(modularFunctionFieldBar N)
+  have : Algebra.IsIntegral (RatFunc (AlgebraicClosure ℚ)) ↥(modularFunctionFieldBar N) :=
+    Algebra.IsIntegral.of_finite _ _
+  have : CharZero ↥(modularFunctionFieldBar N) :=
+    charZero_of_injective_algebraMap (algebraMap (AlgebraicClosure ℚ) _).injective
+  have : PerfectField (RatFunc (AlgebraicClosure ℚ)) := PerfectField.ofCharZero
+  have : Algebra.IsSeparable (RatFunc (AlgebraicClosure ℚ)) ↥(modularFunctionFieldBar N) :=
+    Algebra.IsSeparable.of_integral _ _
+  have : IsCurveOver (AlgebraicClosure ℚ) (RatFunc (AlgebraicClosure ℚ)) :=
+    AlgebraicCurve.instIsCurveOverRatFunc (AlgebraicClosure ℚ)
+  have : Algebra.EssFiniteType (Polynomial (AlgebraicClosure ℚ)) (RatFunc (AlgebraicClosure ℚ)) :=
+    Algebra.EssFiniteType.of_isLocalization _ (nonZeroDivisors (Polynomial (AlgebraicClosure ℚ)))
+  have : Algebra.EssFiniteType (AlgebraicClosure ℚ) (RatFunc (AlgebraicClosure ℚ)) :=
+    Algebra.EssFiniteType.comp (AlgebraicClosure ℚ) (Polynomial (AlgebraicClosure ℚ)) (RatFunc
+      (AlgebraicClosure ℚ))
+  have hDCGR : ∀ v : Place (AlgebraicClosure ℚ) (RatFunc (AlgebraicClosure ℚ)), v.DCoordGenerates :=
+    AlgebraicCurve.dCoordGenerates_of_isCurveOver
+  have : HasCanonicalLocalResidueKStar (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+    inferInstance
+  have : HasSeparableResidue (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) := inferInstance
+  exact AlgebraicCurve.degree_canonicalDivisor_eq_of_isAlgClosed hω
+
+end S_ModularCurve_degree_canonicalDivisorOf_modularFunctionFieldBar
+end P2MW
+export P2MW.S_ModularCurve_degree_canonicalDivisorOf_modularFunctionFieldBar (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.degree_canonicalDivisorOf_modularFunctionFieldBar (N : ℕ) [NeZero N]
+    [AlgebraicCurve.HasCanonicalDivisor (K := AlgebraicClosure ℚ) (F :=
+      ↥(ModularCurve.modularFunctionFieldBar N))]
+    {ω : Ω[↥(ModularCurve.modularFunctionFieldBar N)⁄(AlgebraicClosure ℚ)]} (hω : ω ≠ 0) :
+    (AlgebraicCurve.canonicalDivisorOf hω).degree
+      = 2 * (AlgebraicCurve.genus (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar N) :
+        ℤ) - 2 :=
+  solution N hω
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_diffQExpBar_injective_of_neZero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_diffQExpBar_injective_of_neZero.lean
new file mode 100644
index 0000000000..5e06729d84
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_diffQExpBar_injective_of_neZero.lean
@@ -0,0 +1,155 @@
+/-
+Based on Prove2Me node ModularCurve.diffQExpBar_injective_of_neZero
+(271acfec-a8a2-5baf-9ebc-aa1a2b2ffe5a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission af9c00e2-7db0-533d-b230-37296f49077c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_HeckeDifferential
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ArithmeticGalois
+import LeanPool.FLTEichlerShimura.Theorems.Thm_KaehlerDifferential_span_D_eq_top_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isSeparable_adjoin_coeffEmb_jq_full
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Injectivity of the q-expansion map on differentials
+
+Theorem statement: `ModularCurve.diffQExpBar_injective_of_neZero`
+(`271acfec-a8a2-5baf-9ebc-aa1a2b2ffe5a`), by Claude, 2026-09-05.
+
+Proof: submission `af9c00e2-7db0-533d-b230-37296f49077c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number. Write $\bar L = \overline{\mathbb{Q}}$ for the algebraic
+closure of $\mathbb{Q}$, and let `modularFunctionFieldBar N` be the intermediate field of $\bar
+L((q))$ over $\bar L$ obtained as `laurentBaseChange` of `modularFunctionFieldFull N` along
+$\mathbb{Q} \to \bar L$, that is, the level-$N$ modular function field with coefficients extended to
+$\bar L$, realised inside the field of Laurent series in $q$ over $\bar L$. For an intermediate
+field $F$ of $\bar L((q))$ over $\bar L$, `diffQExp` is the $F$-linear map from the module of Kähler
+differentials $\Omega[F/\bar L]$ to $\bar L((q))$ obtained by lifting the derivation `qEulerOn F`
+(the Euler derivation $q\,\mathrm{d}/\mathrm{d}q$ on $F$, valued in Laurent series) through the
+universal derivation $D$; thus $f\,Dg \mapsto f \cdot q\,\mathrm{d}g/\mathrm{d}q$. The abbreviation
+`diffQExpBar N` is this map for $F =$ `modularFunctionFieldBar N`. The assertion is that
+`diffQExpBar N` is injective as a function on $\Omega[\,$`modularFunctionFieldBar N`$/\bar L\,]$.
+
+In classical terms: a differential on the level-$N$ modular curve over $\overline{\mathbb{Q}}$ whose
+$q$-expansion at the cusp $\infty$ vanishes is itself zero, so differentials may be identified with
+their $q$-expansions. It is used in the computation of the space of holomorphic differentials and
+its integral lattice, and in the genus-versus-dimension comparison for weight-two cusp forms on
+$\Gamma_0$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_diffQExpBar_injective_of_neZero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_diffQExpBar_injective_of_neZero
+
+p2m_open "KaehlerDifferential ModularCurve \
+  P2MW.S_ModularCurve_diffQExpBar_injective_of_neZero.ModularCurve"
+
+section Engine
+
+private theorem qEuler_coeffEmb_jq_ne_zero_aux :
+    qEuler (AlgebraicClosure ℚ) (coeffEmb (AlgebraicClosure ℚ) jq) ≠ 0 := by
+  intro h
+  have h1 : (qEuler (AlgebraicClosure ℚ) (coeffEmb (AlgebraicClosure ℚ) jq)).coeff (-1 : ℤ) = -1 :=
+    by
+    simp [qEuler_coeff, coeffEmb_coeff, coeff_jq_neg_one]
+  rw [h] at h1
+  simp at h1
+
+private theorem exists_smul_D_jBar_aux (N : ℕ) [NeZero N]
+    (ω : KaehlerDifferential (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) :
+    ∃ x : modularFunctionFieldBar N,
+      ω = x • D (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+        ⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+          (jq_mem_full N)⟩ := by
+  have : Algebra.IsSeparable
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+          (jq_mem_full N)⟩} :
+          Set (modularFunctionFieldBar N)))
+      (modularFunctionFieldBar N) :=
+    isSeparable_adjoin_coeffEmb_jq_full (AlgebraicClosure ℚ) N
+  have hmem : ω ∈ Submodule.span (modularFunctionFieldBar N)
+      ({(D (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+        ⟨coeffEmb (AlgebraicClosure ℚ) jq,
+          coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩)} :
+        Set (KaehlerDifferential (AlgebraicClosure ℚ) (modularFunctionFieldBar N))) := by
+    rw [span_D_eq_top_of_transcendental (AlgebraicClosure ℚ) _ (transcendental_coeffEmb_jq
+      (AlgebraicClosure ℚ) N)]
+    exact Submodule.mem_top
+  obtain ⟨c, hc⟩ := Submodule.mem_span_singleton.mp hmem
+  exact ⟨c, hc.symm⟩
+
+private theorem diffQExpBar_smul_D_jBar_aux (N : ℕ) [NeZero N] (x : modularFunctionFieldBar N) :
+    diffQExpBar N
+        (x • D (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+          ⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+            (jq_mem_full N)⟩) =
+      (x : LaurentSeries (AlgebraicClosure ℚ)) * qEuler (AlgebraicClosure ℚ) (coeffEmb
+        (AlgebraicClosure ℚ) jq) :=
+  diffQExp_smul_D (modularFunctionFieldBar N) x _
+
+end Engine
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qEuler qEuler_coeff diffQExp_smul_D diffQExpBar modularFunctionFieldBar \
+  jq coeff_jq_neg_one coeffEmb coeffEmb_coeff coeffEmb_mem_laurentBaseChange \
+  transcendental_coeffEmb_jq jq_mem_full isSeparable_adjoin_coeffEmb_jq_full"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.diffQExpBar_injective_of_neZero (N : ℕ) [NeZero N] :
+    Function.Injective (diffQExpBar N) := by
+  intro ω₁ ω₂ h
+  obtain ⟨x₁, rfl⟩ := exists_smul_D_jBar_aux N ω₁
+  obtain ⟨x₂, rfl⟩ := exists_smul_D_jBar_aux N ω₂
+  have h' : (x₁ : LaurentSeries (AlgebraicClosure ℚ)) * qEuler (AlgebraicClosure ℚ) (coeffEmb
+    (AlgebraicClosure ℚ) jq) =
+      (x₂ : LaurentSeries (AlgebraicClosure ℚ)) * qEuler (AlgebraicClosure ℚ) (coeffEmb
+        (AlgebraicClosure ℚ) jq) :=
+    (diffQExpBar_smul_D_jBar_aux N x₁).symm.trans (h.trans (diffQExpBar_smul_D_jBar_aux N x₂))
+  have hx : x₁ = x₂ := Subtype.ext (mul_right_cancel₀ qEuler_coeffEmb_jq_ne_zero_aux h')
+  rw [hx]
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.diffQExpBar_injective (ℓ : ℕ) [Fact ℓ.Prime] :
+    Function.Injective (diffQExpBar ℓ) :=
+  ModularCurve.diffQExpBar_injective_of_neZero ℓ
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_diffQExpBar_injective_of_neZero.ModularCurve in
+theorem solution (N : ℕ) [NeZero N] :
+    Function.Injective (diffQExpBar N) :=
+  ModularCurve.diffQExpBar_injective_of_neZero N
+
+end S_ModularCurve_diffQExpBar_injective_of_neZero
+end P2MW
+export P2MW.S_ModularCurve_diffQExpBar_injective_of_neZero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.diffQExpBar_injective_of_neZero (N : ℕ) [NeZero N] :
+    Function.Injective (diffQExpBar N) :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_discriminant_div_discriminant_heckeDiagMatrix_smul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_discriminant_div_discriminant_heckeDiagMatrix_smul.lean
new file mode 100644
index 0000000000..b84ad57ea7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_discriminant_div_discriminant_heckeDiagMatrix_smul.lean
@@ -0,0 +1,133 @@
+/-
+Based on Prove2Me node ModularCurve.discriminant_div_discriminant_heckeDiagMatrix_smul
+(93e2ea46-9411-5e7f-8098-309280a7ef5c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 770d0625-92a8-5cd1-b933-e875da2cf6a9
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_sl2_heckeDiagMatrix_smul_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Γ₀(N)-invariance of Δ(τ)/Δ(Nτ)
+
+Theorem statement: `ModularCurve.discriminant_div_discriminant_heckeDiagMatrix_smul`
+(`93e2ea46-9411-5e7f-8098-309280a7ef5c`), by Claude, 2026-09-05.
+
+Proof: submission `770d0625-92a8-5cd1-b933-e875da2cf6a9`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number with $N \neq 0$, let $\gamma$ be an element of
+$\mathrm{SL}_2(\mathbb{Z})$ lying in the congruence subgroup $\Gamma_0(N)$, and let $\tau$ be a
+point of the upper half-plane. Write $\Delta$ for Mathlib's `ModularForm.discriminant`, the
+holomorphic function on the upper half-plane underlying the weight-$12$ cusp form for
+$\mathrm{SL}_2(\mathbb{Z})$, and write $\mathrm{heckeDiagMatrix}\ N$ for the element of
+$\mathrm{GL}_2(\mathbb{R})$ which, since $N \neq 0$, is the upper triangular matrix
+$\bigl(\begin{smallmatrix} N & 0 \\ 0 & 1\end{smallmatrix}\bigr)$ (of nonzero determinant $N$), so
+that its action on the upper half-plane sends $\tau$ to $N\tau$. The assertion is the equality of
+quotients of complex numbers
+$$\frac{\Delta(\gamma \cdot \tau)}{\Delta(N\,(\gamma\cdot\tau))} \;=\;
+\frac{\Delta(\tau)}{\Delta(N\tau)},$$
+where $\gamma$ acts through the usual fractional linear action of $\mathrm{SL}_2(\mathbb{Z})$ on the
+upper half-plane. Thus the function $\tau \mapsto \Delta(\tau)/\Delta(N\tau)$ is invariant under
+$\Gamma_0(N)$, pointwise in $\tau$.
+
+This is the analytic invariance of the classical modular unit $u_N(\tau) =
+\Delta(\tau)/\Delta(N\tau) = (\eta(\tau)/\eta(N\tau))^{24}$, a nowhere-vanishing holomorphic
+function on the upper half-plane whose $\Gamma_0(N)$-invariance makes it a function on the modular
+curve $X_0(N)$ away from the cusps. It is used downstream in the construction and $q$-expansion
+analysis of this unit and of the associated series, for instance in the study of its behaviour under
+the Fricke involution and in the integrality statements over $\mathbb{Q}[j]$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_discriminant_div_discriminant_heckeDiagMatrix_smul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_discriminant_div_discriminant_heckeDiagMatrix_smul
+
+noncomputable section
+
+open UpperHalfPlane Matrix.SpecialLinearGroup
+open scoped MatrixGroups ModularForm
+
+namespace ModularCurve
+p2m_export "ModularCurve" "exists_sl2_heckeDiagMatrix_smul_eq"
+p2m_open "ModularCurve"
+
+namespace QexpN
+
+theorem discriminant_div_discriminant_heckeDiagMatrix_smul' (N : ℕ) [NeZero N]
+    (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) (hγ : γ ∈ CongruenceSubgroup.Gamma0 N)
+    (τ : UpperHalfPlane) :
+    ModularForm.discriminant (γ • τ)
+        / ModularForm.discriminant (ModularForm.heckeDiagMatrix N • γ • τ)
+      = ModularForm.discriminant τ
+        / ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ) := by
+  obtain ⟨γ', hact, hden⟩ := ModularCurve.exists_sl2_heckeDiagMatrix_smul_eq N γ hγ
+  have hγSL : (mapGL ℝ γ : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ, rfl⟩
+  have hγ'SL : (mapGL ℝ γ' : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ', rfl⟩
+  have hΔγ : ModularForm.discriminant (γ • τ)
+      = UpperHalfPlane.denom (γ : Matrix.GeneralLinearGroup (Fin 2) ℝ) (τ : ℂ) ^ (12 : ℤ)
+        * ModularForm.discriminant τ := by
+    have h := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hγSL τ
+    simp only [CuspForm.coe_discriminant, zpow_ofNat] at h
+    exact h
+  have hΔγ' : ModularForm.discriminant (γ' • ModularForm.heckeDiagMatrix N • τ)
+      = UpperHalfPlane.denom (γ' : Matrix.GeneralLinearGroup (Fin 2) ℝ)
+          (((ModularForm.heckeDiagMatrix N • τ : UpperHalfPlane)) : ℂ) ^ (12 : ℤ)
+        * ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ) := by
+    have h := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hγ'SL
+        (ModularForm.heckeDiagMatrix N • τ)
+    simp only [CuspForm.coe_discriminant, zpow_ofNat] at h
+    exact h
+  rw [hact τ, hΔγ, hΔγ', hden τ,
+    mul_div_mul_left _ _ (zpow_ne_zero 12 (UpperHalfPlane.denom_ne_zero _ _))]
+
+end QexpN
+
+end ModularCurve
+
+end
+
+theorem solution (N : ℕ) [NeZero N] (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ)
+    (hγ : γ ∈ CongruenceSubgroup.Gamma0 N) (τ : UpperHalfPlane) :
+    ModularForm.discriminant (γ • τ) / ModularForm.discriminant (ModularForm.heckeDiagMatrix N • γ •
+      τ) = ModularForm.discriminant τ / ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)
+      :=
+  ModularCurve.QexpN.discriminant_div_discriminant_heckeDiagMatrix_smul' N γ hγ τ
+
+end S_ModularCurve_discriminant_div_discriminant_heckeDiagMatrix_smul
+end P2MW
+export P2MW.S_ModularCurve_discriminant_div_discriminant_heckeDiagMatrix_smul (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.discriminant_div_discriminant_heckeDiagMatrix_smul (N : ℕ) [NeZero N]
+    (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) (hγ : γ ∈ CongruenceSubgroup.Gamma0 N)
+    (τ : UpperHalfPlane) :
+    ModularForm.discriminant (γ • τ) / ModularForm.discriminant (ModularForm.heckeDiagMatrix N • γ •
+      τ) = ModularForm.discriminant τ / ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)
+      :=
+  solution N γ hγ τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eisenstein4_mul_thetaL_delta_sub_eq_eisenstein6_mul_delta.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eisenstein4_mul_thetaL_delta_sub_eq_eisenstein6_mul_delta.lean
new file mode 100644
index 0000000000..22ea098c90
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eisenstein4_mul_thetaL_delta_sub_eq_eisenstein6_mul_delta.lean
@@ -0,0 +1,171 @@
+/-
+Based on Prove2Me node ModularCurve.eisenstein4_mul_thetaL_delta_sub_eq_eisenstein6_mul_delta
+(7851f343-ff91-55af-ad8e-ab6222852b74) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 49f406ed-791b-5230-989a-2bd7c0b49f4a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QExpansionDiff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_TateFormal
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_E4_eq_map_eisenstein4
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_E6_eq_map_mk
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_theta_coeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_qExpansion_E4_mul_theta_discriminant_sub
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Ramanujan's identity E₄ θΔ-3 θ E₄ Δ=E₆ Δ over ℚ
+
+Theorem statement: `ModularCurve.eisenstein4_mul_thetaL_delta_sub_eq_eisenstein6_mul_delta`
+(`7851f343-ff91-55af-ad8e-ab6222852b74`), by Claude, 2026-09-05.
+
+Proof: submission `49f406ed-791b-5230-989a-2bd7c0b49f4a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+The assertion is a single closed identity in the field of formal Laurent series $\mathbb{Q}((q))$,
+with no variables or hypotheses. Three integral power series are involved: `eisenstein4`, whose
+$n$-th coefficient is $1$ for $n=0$ and $240\sum_{d\mid n}d^{3}$ otherwise; `eisenstein6`, whose
+$n$-th coefficient is $1$ for $n=0$ and $-504\sum_{d\mid n}d^{5}$ otherwise; and
+$X\cdot$`dedekindEtaUnit`, where `dedekindEtaUnit` is the $24$-th power of the infinite product
+$\prod_{n\ge 1}(1-X^{n})$, so that this is the formal $\Delta$-series
+$q\prod_{n\ge1}(1-q^{n})^{24}$. Each is mapped coefficientwise into $\mathbb{Q}[[q]]$ along
+$\mathbb{Z}\to\mathbb{Q}$ and then embedded into $\mathbb{Q}((q))$ as a Hahn series. The operator
+`thetaL` over $\mathbb{Q}$ is the $\mathbb{Q}$-linear map on $\mathbb{Q}((q))$ sending $f$ to
+$q\cdot f'$, i.e. multiplication of the formal derivative by the monomial $q$; on coefficients it
+multiplies the coefficient in degree $k$ by $k$. Writing $E_4$, $E_6$, $\Delta$ for the images of
+the three series and $\theta$ for `thetaL`, the conclusion is $E_4\cdot\theta\Delta-3\,\theta
+E_4\cdot\Delta=E_6\cdot\Delta$ in $\mathbb{Q}((q))$.
+
+This is the formal Laurent-series incarnation, over $\mathbb{Q}$ and with integral $q$-expansions,
+of the Rankin–Cohen bracket identity in weight $18$ relating $E_4$, $E_6$ and $\Delta$; equivalently
+a classical identity of Ramanujan between the coefficient arithmetic of $\sigma_3$, $\sigma_5$ and
+$\tau$. It is used in the formal $q$-expansion calculus on the modular curve, for instance by
+[`ModularCurve.thetaL_jq_mul_deltaSeries`](thm.html#ModularCurve.thetaL_jq_mul_deltaSeries).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_eisenstein4_mul_thetaL_delta_sub_eq_eisenstein6_mul_delta.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_eisenstein4_mul_thetaL_delta_sub_eq_eisenstein6_mul_delta
+
+noncomputable section
+
+p2m_open "ModularCurve \
+  P2MW.S_ModularCurve_eisenstein4_mul_thetaL_delta_sub_eq_eisenstein6_mul_delta.ModularCurve"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "eisenstein6 eisenstein4 dedekindEtaUnit ofPowerSeries_coeff_of_neg \
+  thetaL thetaL_apply qExpansion_E4_eq_map_eisenstein4 qExpansion_E6_eq_map_mk \
+  qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit theta_coeff"
+namespace RC18Transfer
+p2m_open "ModularCurve"
+
+noncomputable def thetaPS {R : Type*} [CommSemiring R] (f : PowerSeries R) : PowerSeries R :=
+  PowerSeries.mk fun n : ℕ => (n : R) * f.coeff n
+
+theorem coeff_thetaPS {R : Type*} [CommSemiring R] (f : PowerSeries R) (n : ℕ) :
+    (thetaPS f).coeff n = (n : R) * f.coeff n := by
+  simp [thetaPS, PowerSeries.coeff_mk]
+
+theorem thetaPS_map {R S : Type*} [CommSemiring R] [CommSemiring S] (φ : R →+* S)
+    (f : PowerSeries R) : PowerSeries.map φ (thetaPS f) = thetaPS (PowerSeries.map φ f) := by
+  ext n
+  simp [coeff_thetaPS, PowerSeries.coeff_map]
+
+theorem ofPowerSeries_thetaPS (f : PowerSeries ℚ) :
+    HahnSeries.ofPowerSeries ℤ ℚ (thetaPS f) = thetaL ℚ (HahnSeries.ofPowerSeries ℤ ℚ f) := by
+  ext k
+  rw [thetaL_apply, ModularCurve.theta_coeff]
+  rcases lt_or_ge k 0 with hk | hk
+  · rw [ofPowerSeries_coeff_of_neg _ hk, ofPowerSeries_coeff_of_neg _ hk, smul_zero]
+  · obtain ⟨n, rfl⟩ := Int.eq_ofNat_of_zero_le hk
+    rw [HahnSeries.ofPowerSeries_apply_coeff, HahnSeries.ofPowerSeries_apply_coeff, coeff_thetaPS,
+      zsmul_eq_mul, Int.cast_natCast]
+
+end ModularCurve.RC18Transfer
+
+open ModularCurve.RC18Transfer in
+theorem solution :
+    HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ) eisenstein4) *
+        thetaL ℚ (HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ) (PowerSeries.X *
+          dedekindEtaUnit)))
+      - 3 * thetaL ℚ (HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ)
+        eisenstein4)) *
+        HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ) (PowerSeries.X *
+          dedekindEtaUnit))
+      = HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ) eisenstein6) *
+        HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ) (PowerSeries.X *
+          dedekindEtaUnit)) := by
+  have hE6 : eisenstein6 =
+      (PowerSeries.mk fun n => if n = 0 then 1 else -504 * ∑ d ∈ n.divisors, (d : ℤ) ^ 5) := rfl
+  have hZ : eisenstein4 * thetaPS (PowerSeries.X * dedekindEtaUnit)
+      - 3 * thetaPS eisenstein4 * (PowerSeries.X * dedekindEtaUnit)
+      = eisenstein6 * (PowerSeries.X * dedekindEtaUnit) := by
+    apply PowerSeries.map_injective (Int.castRingHom ℂ) (RingHom.injective_int _)
+    have hC := ModularForm.qExpansion_E4_mul_theta_discriminant_sub
+    rw [ModularCurve.qExpansion_E4_eq_map_eisenstein4, ModularCurve.qExpansion_E6_eq_map_mk,
+      ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit] at hC
+    have e1 : (PowerSeries.mk fun n : ℕ =>
+        (n : ℂ) * (PowerSeries.map (Int.castRingHom ℂ) (PowerSeries.X * dedekindEtaUnit)).coeff n) =
+        PowerSeries.map (Int.castRingHom ℂ) (thetaPS (PowerSeries.X * dedekindEtaUnit)) := by
+      rw [thetaPS_map]; rfl
+    have e2 : (PowerSeries.mk fun n : ℕ =>
+        (n : ℂ) * (PowerSeries.map (Int.castRingHom ℂ) eisenstein4).coeff n) =
+        PowerSeries.map (Int.castRingHom ℂ) (thetaPS eisenstein4) := by
+      rw [thetaPS_map]; rfl
+    rw [e1, e2] at hC
+    simpa [hE6, map_mul, map_sub, map_ofNat] using hC
+  let ψ : PowerSeries ℤ →+* LaurentSeries ℚ :=
+    (HahnSeries.ofPowerSeries ℤ ℚ).comp (PowerSeries.map (Int.castRingHom ℚ))
+  have hψ : ∀ f : PowerSeries ℤ, ψ f = HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map
+    (Int.castRingHom ℚ) f) :=
+    fun f => rfl
+  have hθ : ∀ f : PowerSeries ℤ, ψ (thetaPS f) = thetaL ℚ (ψ f) := by
+    intro f
+    rw [hψ, hψ, thetaPS_map, ofPowerSeries_thetaPS]
+  have key := congrArg ψ hZ
+  simp only [map_sub, map_mul, map_ofNat, hθ] at key
+  simpa only [hψ, map_mul] using key
+
+end
+
+end S_ModularCurve_eisenstein4_mul_thetaL_delta_sub_eq_eisenstein6_mul_delta
+end P2MW
+export P2MW.S_ModularCurve_eisenstein4_mul_thetaL_delta_sub_eq_eisenstein6_mul_delta (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.eisenstein4_mul_thetaL_delta_sub_eq_eisenstein6_mul_delta :
+    HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ) eisenstein4) *
+        thetaL ℚ (HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ) (PowerSeries.X *
+          dedekindEtaUnit)))
+      - 3 * thetaL ℚ (HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ)
+        eisenstein4)) *
+        HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ) (PowerSeries.X *
+          dedekindEtaUnit))
+      = HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ) eisenstein6) *
+        HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ) (PowerSeries.X *
+          dedekindEtaUnit)) :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_emd_holds.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_emd_holds.lean
new file mode 100644
index 0000000000..90f7aa7947
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_emd_holds.lean
@@ -0,0 +1,105 @@
+/-
+Based on Prove2Me node ModularCurve.emd_holds
+(bca9d32d-6e03-5019-b056-04ad0fdbcc7f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e0e2ab7e-1196-5850-a400-e72b9f4d3e59
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EMD
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_emd_of_beta_docks
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_elliptic_cycSub_orbitMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finite_cycSub
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_place_of_emb
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_place_eq_of_induces
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_normalized_algHom_jBar_eq_toNat_ord
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# EMD holds at every level N and every j₀
+
+Theorem statement: `ModularCurve.emd_holds` (`bca9d32d-6e03-5019-b056-04ad0fdbcc7f`), by Claude,
+2026-09-05.
+
+Proof: submission `e0e2ab7e-1196-5850-a400-e72b9f4d3e59`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number with $N \neq 0$ and let $j_0$ be an element of $\overline{\mathbb{Q}} =$
+`AlgebraicClosure ℚ`. The assertion is that the predicate `EMD N j₀` holds, that is: there is a
+Weierstrass curve $E_0$ over $\overline{\mathbb{Q}}$ which is elliptic and satisfies $j(E_0) = j_0$,
+together with a bijection $\Phi$ between the type `Emb N j₀` — whose elements have as first
+component an $\overline{\mathbb{Q}}$-algebra homomorphism from the level-$N$ field
+`modularFunctionFieldBar N` into the Hahn series ring `HahnSeries ℚ (AlgebraicClosure ℚ)` — and the
+type `CycSub E₀ N` of those additive subgroups $H$ of the group of affine points of $E_0$ for which
+$H = \langle g\rangle$ is the group of integer multiples of some point $g$ of additive order exactly
+$N$, such that for all $\psi, \psi'$ in `Emb N j₀` the following are equivalent: (i) `SamePlace`,
+i.e. there is a place $w$ of `modularFunctionFieldBar N` over $\overline{\mathbb{Q}}$ induced by the
+homomorphism underlying $\psi$ and also by the one underlying $\psi'$; and (ii) `SameOrbit` for the
+subgroups $\Phi(\psi)$ and $\Phi(\psi')$, i.e. there is a variable change $\gamma$ over
+$\overline{\mathbb{Q}}$ with $\gamma \bullet E_0 = E_0$ and generators $g$, $g'$ of the two
+subgroups with $g'$ equal to the image of $g$ under `Point.vcInvFun γ E₀.toAffine`.
+
+This is the local comparison, at the level of places above $j_0$, between normalised embeddings of
+the level-$N$ modular function field into Hahn series and the cyclic subgroups of order $N$ of an
+elliptic curve with $j$-invariant $j_0$, the two sides being matched so that coincidence of the
+induced place corresponds to conjugacy of subgroups under automorphisms of the curve. It is used in
+the analysis of the Riemann–Roch spaces and in the genus computation for `modularFunctionFieldBar
+N`.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_emd_holds.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_emd_holds
+
+noncomputable section
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_emd_holds.ModularCurve"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "emd_of_beta_docks EMD exists_elliptic_cycSub_orbitMap finite_cycSub \
+  exists_place_of_emb place_eq_of_induces natCard_normalized_algHom_jBar_eq_toNat_ord"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.emd_holds (N : ℕ) [NeZero N] (j₀ : AlgebraicClosure ℚ) :
+    EMD N j₀ :=
+  emd_of_beta_docks N j₀ (exists_elliptic_cycSub_orbitMap N j₀) (fun E₀ _ => finite_cycSub N E₀)
+    (fun ψ => exists_place_of_emb N j₀ ψ) (natCard_normalized_algHom_jBar_eq_toNat_ord N j₀)
+    (fun h h' => place_eq_of_induces h h')
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_emd_holds.ModularCurve in
+theorem solution (N : ℕ) [NeZero N] (j₀ : AlgebraicClosure ℚ) :
+    EMD N j₀ :=
+  ModularCurve.emd_holds N j₀
+
+end S_ModularCurve_emd_holds
+end P2MW
+export P2MW.S_ModularCurve_emd_holds (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.emd_holds (N : ℕ) [NeZero N] (j₀ : AlgebraicClosure ℚ) :
+    EMD N j₀ :=
+  solution N j₀
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_emd_of_beta_docks.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_emd_of_beta_docks.lean
new file mode 100644
index 0000000000..b4d0c33271
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_emd_of_beta_docks.lean
@@ -0,0 +1,295 @@
+/-
+Based on Prove2Me node ModularCurve.emd_of_beta_docks
+(964f8ad0-2fbd-509c-95ec-81dda4e54880) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 207ad85b-14ba-5aa7-9cf2-2bd8be889a0c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EMD
+public import Mathlib.RingTheory.HahnSeries.PowerSeries
+public import Mathlib.SetTheory.Cardinal.Finite
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Assembly of `EMD` from five local inputs
+
+Theorem statement: `ModularCurve.emd_of_beta_docks` (`964f8ad0-2fbd-509c-95ec-81dda4e54880`), by
+Claude, 2026-09-05.
+
+Proof: submission `207ad85b-14ba-5aa7-9cf2-2bd8be889a0c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $N \neq 0$ and an element $j_0$ of $\overline{\mathbb{Q}} =$ `AlgebraicClosure
+ℚ`, and write $F_N =$ `modularFunctionFieldBar N` for the subfield of $\overline{\mathbb{Q}}((q))$
+generated over $\overline{\mathbb{Q}}$ by the coefficientwise image of `modularFunctionFieldFull N`
+(itself the subfield of $\mathbb{Q}((q))$ generated by the divisor expansions at level $N$), and
+`jBar N` for the element of $F_N$ given by the $q$-expansion of $j$. Places here are valuation
+subrings of $F_N$ containing $\overline{\mathbb{Q}}$, distinct from $F_N$ and principal, with `ord`
+the associated normalised integer valuation. Four hypotheses are assumed. First, `hβ`: there is an
+elliptic Weierstrass curve $E_0/\overline{\mathbb{Q}}$ with $j(E_0) = j_0$ together with a map $f$
+from `CycSub E₀ N` (the subgroups of the affine points of $E_0$ generated by a point of order
+exactly $N$) to the places $w$ with $\operatorname{ord}_w(\,\mathrm{jBar}\,N - j_0) > 0$, such that
+$f(H) = f(H')$ holds exactly when `SameOrbit E₀ H H'`, i.e. some variable change $\gamma$ fixing
+$E_0$ carries a generator of $H$ to one of $H'$ via `Point.vcInvFun`, and such that for each such
+$w$ the number of $H$ with $f(H) = w$ equals $\operatorname{ord}_w(\,\mathrm{jBar}\,N - j_0)$.
+Second, `hfin`: every elliptic Weierstrass curve over $\overline{\mathbb{Q}}$ has finitely many such
+cyclic subgroups. Third, `hEP`: every $\overline{\mathbb{Q}}$-algebra map $\psi : F_N \to$
+`HahnSeries ℚ` $\overline{\mathbb{Q}}$ normalised by $\psi(\mathrm{jBar}\,N) = j_0 + q$ induces a
+place, that is, admits a place $w$ and a rational $g > 0$ with $g \cdot \operatorname{ord}_w(x) =
+\operatorname{order}(\psi x)$ for all $x$. Fourth, `hPEO`: for each place $w$ with
+$\operatorname{ord}_w(\,\mathrm{jBar}\,N - j_0) > 0$, the number of such normalised $\psi$ inducing
+$w$ equals $\operatorname{ord}_w(\,\mathrm{jBar}\,N - j_0)$. Fifth, `hC535`: a $\psi$ induces at
+most one place. The conclusion is `EMD N j₀`: there are an elliptic $E_0$ with $j(E_0) = j_0$ and a
+bijection $\Phi$ between `Emb N j₀`, whose elements are carried by $\overline{\mathbb{Q}}$-algebra
+maps $F_N \to$ `HahnSeries ℚ` $\overline{\mathbb{Q}}$, and `CycSub E₀ N`, such that two embeddings
+induce a common place exactly when the corresponding subgroups lie in the same orbit.
+
+This is the level-$N$ comparison between the normalised embeddings of the modular function field at
+$j_0$ and the cyclic subgroups of order $N$ of an elliptic curve with invariant $j_0$, the form in
+which the Hecke correspondence enters the local analysis of the covering $X_0(N) \to X(1)$ above
+$j_0$. Here it is derived purely formally from a geometric input, a finiteness input, and the
+existence, counting and uniqueness of the place induced by a normalised embedding; it is used in the
+determination of the numbers of elliptic points, via
+[`ModularCurve.card_filter_ord_jBar_eq_one_eq_nuThree`]
+(thm.html#ModularCurve.card_filter_ord_jBar_eq_one_eq_nuThree)
+and
+[`ModularCurve.card_filter_ord_jBar_sub_1728_eq_one_eq_nuTwo`]
+(thm.html#ModularCurve.card_filter_ord_jBar_sub_1728_eq_one_eq_nuTwo),
+and in [`ModularCurve.emd_holds`](thm.html#ModularCurve.emd_holds).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_emd_of_beta_docks.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_emd_of_beta_docks
+
+noncomputable section
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_emd_of_beta_docks.ModularCurve AlgebraicCurve"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "Emb Induces SamePlace CycSub SameOrbit EMD jBar modularFunctionFieldBar"
+p2m_open "ModularCurve"
+
+private theorem emd_of_beta_docks (N : ℕ) [NeZero N] (j₀ : (AlgebraicClosure ℚ))
+    (hβ : ∃ (E₀ : WeierstrassCurve (AlgebraicClosure ℚ)) (_ : E₀.IsElliptic), E₀.j = j₀ ∧
+      ∃ f : CycSub E₀ N →
+          {w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+            0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)},
+        (∀ H H' : CycSub E₀ N, f H = f H' ↔ SameOrbit E₀ H.1 H'.1) ∧
+        ∀ w : {w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+            0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)},
+          ((w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)).ord
+              (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)).toNat =
+            Nat.card {H : CycSub E₀ N // f H = w})
+    (hfin : ∀ (E₀ : WeierstrassCurve (AlgebraicClosure ℚ)) [E₀.IsElliptic], Finite (CycSub E₀ N))
+    (hEP : ∀ ψ : {ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ]
+          HahnSeries ℚ (AlgebraicClosure ℚ) //
+        ψ (jBar N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)},
+      ∃ (w : AlgebraicCurve.Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)) (g : ℚ),
+        0 < g ∧ ∀ x : ↥(modularFunctionFieldBar N), (w.ord x : ℚ) * g = (ψ.1 x).order)
+    (hPEO : ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N),
+      0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) →
+      Nat.card {ψ : modularFunctionFieldBar N →ₐ[AlgebraicClosure ℚ]
+          HahnSeries ℚ (AlgebraicClosure ℚ) //
+        ψ (jBar N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ) ∧
+        ∃ g : ℚ, 0 < g ∧ ∀ x, (w.ord x : ℚ) * g = (ψ x).order} =
+      (w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)).toNat)
+    (hC535 : ∀ {ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ]
+          HahnSeries ℚ (AlgebraicClosure ℚ)}
+      {w w' : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)},
+      Induces ψ w → Induces ψ w' → w = w')
+    : EMD N j₀ := by
+  classical
+  obtain ⟨E₀, hell, hj, f, hiff, hsize⟩ := hβ
+  have hInd : ∀ ψ : Emb N j₀, ∃ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), Induces
+    ψ.1 w :=
+    by
+    intro ψ
+    obtain ⟨w, g, hg, hx⟩ := hEP ψ
+    exact ⟨w, g, hg, hx⟩
+  choose wOf hwOf using hInd
+  have hC : ∀ c : (AlgebraicClosure ℚ), algebraMap (AlgebraicClosure ℚ) (HahnSeries ℚ
+    (AlgebraicClosure ℚ)) c = HahnSeries.C c :=
+    by
+    intro c
+    rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_eq, HahnSeries.ofPowerSeries_C]
+  have habove : ∀ ψ : Emb N j₀,
+      0 < (wOf ψ).ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)
+        := by
+    intro ψ
+    obtain ⟨g, hg, hx⟩ := hwOf ψ
+    have h1 := hx (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)
+    have himg : ψ.1 (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) =
+        HahnSeries.single (1 : ℚ) (1 : (AlgebraicClosure ℚ)) := by
+      rw [map_sub, ψ.2, AlgHom.commutes, hC]
+      ring
+    rw [himg, HahnSeries.order_single one_ne_zero] at h1
+    have hgne : g ≠ 0 := ne_of_gt hg
+    have h2 : ((wOf ψ).ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)
+      : ℚ) =
+        1 / g := (eq_div_iff hgne).mpr h1
+    have h3 : (0 : ℚ) <
+        ((wOf ψ).ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) : ℚ)
+          := by
+      rw [h2]
+      exact div_pos one_pos hg
+    exact_mod_cast h3
+  let F : Emb N j₀ → {w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+      0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)} :=
+    fun ψ => ⟨wOf ψ, habove ψ⟩
+  have hFiff : ∀ (ψ : Emb N j₀) (w), F ψ = w ↔ Induces ψ.1 w.1 := by
+    intro ψ w
+    constructor
+    · rintro rfl
+      exact hwOf ψ
+    · intro h
+      exact Subtype.ext (hC535 (hwOf ψ) h)
+  have hcardψ : ∀ w, Nat.card {ψ : Emb N j₀ // F ψ = w} =
+      (w.1.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)).toNat
+        := by
+    intro w
+    have e1 : {ψ : Emb N j₀ // F ψ = w} ≃ {ψ : Emb N j₀ // Induces ψ.1 w.1} :=
+      Equiv.subtypeEquivRight fun ψ => hFiff ψ w
+    have e2 : {ψ : Emb N j₀ // Induces ψ.1 w.1} ≃
+        {ψ : ↥(modularFunctionFieldBar N) →ₐ[(AlgebraicClosure ℚ)] HahnSeries ℚ (AlgebraicClosure ℚ)
+          //
+          ψ (jBar N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : (AlgebraicClosure ℚ)) ∧
+          Induces ψ w.1} :=
+      Equiv.subtypeSubtypeEquivSubtypeInter
+        (fun ψ : ↥(modularFunctionFieldBar N) →ₐ[(AlgebraicClosure ℚ)] HahnSeries ℚ
+          (AlgebraicClosure ℚ) =>
+          ψ (jBar N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : (AlgebraicClosure ℚ)))
+        (fun ψ => Induces ψ w.1)
+    rw [Nat.card_congr (e1.trans e2)]
+    exact hPEO w.1 w.2
+  have : E₀.IsElliptic := hell
+  have : Finite (CycSub E₀ N) := hfin E₀
+  have hfinH : ∀ w, Finite {H : CycSub E₀ N // f H = w} := fun _ => Subtype.finite
+  have hfinψ : ∀ w, Finite {ψ : Emb N j₀ // F ψ = w} := by
+    intro w
+    have hne : Nat.card {ψ : Emb N j₀ // F ψ = w} ≠ 0 := by
+      rw [hcardψ w]
+      have := w.2
+      omega
+    exact (Nat.card_ne_zero.mp hne).2
+  have fibEquiv : ∀ w, {ψ : Emb N j₀ // F ψ = w} ≃ {H : CycSub E₀ N // f H = w} := by
+    intro w
+    haveI := hfinψ w
+    haveI := hfinH w
+    haveI := Fintype.ofFinite {ψ : Emb N j₀ // F ψ = w}
+    haveI := Fintype.ofFinite {H : CycSub E₀ N // f H = w}
+    refine Fintype.equivOfCardEq ?_
+    have h := (hcardψ w).trans (hsize w)
+    rwa [Nat.card_eq_fintype_card, Nat.card_eq_fintype_card] at h
+  let Φ : Emb N j₀ ≃ CycSub E₀ N :=
+    ((Equiv.sigmaFiberEquiv F).symm.trans
+      (Equiv.sigmaCongrRight fibEquiv)).trans (Equiv.sigmaFiberEquiv f)
+  have hfΦ : ∀ ψ, f (Φ ψ) = F ψ := fun ψ => ((fibEquiv (F ψ)) ⟨ψ, rfl⟩).2
+  have hSP : ∀ ψ ψ' : Emb N j₀, SamePlace ψ.1 ψ'.1 ↔ F ψ = F ψ' := by
+    intro ψ ψ'
+    constructor
+    · rintro ⟨w, h, h'⟩
+      exact Subtype.ext ((hC535 (hwOf ψ) h).trans (hC535 (hwOf ψ') h').symm)
+    · intro h
+      refine ⟨wOf ψ, hwOf ψ, ?_⟩
+      have hv : wOf ψ' = wOf ψ := congrArg Subtype.val h.symm
+      rw [← hv]
+      exact hwOf ψ'
+  refine ⟨E₀, hell, hj, Φ, fun ψ ψ' => ?_⟩
+  rw [hSP ψ ψ', ← hiff (Φ ψ) (Φ ψ')]
+  rw [hfΦ ψ, hfΦ ψ']
+
+end ModularCurve
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_emd_of_beta_docks.ModularCurve AlgebraicCurve in
+theorem solution (N : ℕ) [NeZero N] (j₀ : (AlgebraicClosure ℚ))
+    (hβ : ∃ (E₀ : WeierstrassCurve (AlgebraicClosure ℚ)) (_ : E₀.IsElliptic), E₀.j = j₀ ∧
+      ∃ f : CycSub E₀ N →
+          {w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+            0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)},
+        (∀ H H' : CycSub E₀ N, f H = f H' ↔ SameOrbit E₀ H.1 H'.1) ∧
+        ∀ w : {w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+            0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)},
+          ((w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)).ord
+              (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)).toNat =
+            Nat.card {H : CycSub E₀ N // f H = w})
+    (hfin : ∀ (E₀ : WeierstrassCurve (AlgebraicClosure ℚ)) [E₀.IsElliptic], Finite (CycSub E₀ N))
+    (hEP : ∀ ψ : {ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ]
+          HahnSeries ℚ (AlgebraicClosure ℚ) //
+        ψ (jBar N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)},
+      ∃ (w : AlgebraicCurve.Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)) (g : ℚ),
+        0 < g ∧ ∀ x : ↥(modularFunctionFieldBar N), (w.ord x : ℚ) * g = (ψ.1 x).order)
+    (hPEO : ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N),
+      0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) →
+      Nat.card {ψ : modularFunctionFieldBar N →ₐ[AlgebraicClosure ℚ]
+          HahnSeries ℚ (AlgebraicClosure ℚ) //
+        ψ (jBar N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ) ∧
+        ∃ g : ℚ, 0 < g ∧ ∀ x, (w.ord x : ℚ) * g = (ψ x).order} =
+      (w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)).toNat)
+    (hC535 : ∀ {ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ]
+          HahnSeries ℚ (AlgebraicClosure ℚ)}
+      {w w' : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)},
+      Induces ψ w → Induces ψ w' → w = w')
+    : EMD N j₀ :=
+  ModularCurve.emd_of_beta_docks N j₀ hβ hfin hEP hPEO hC535
+
+end S_ModularCurve_emd_of_beta_docks
+end P2MW
+export P2MW.S_ModularCurve_emd_of_beta_docks (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.emd_of_beta_docks (N : ℕ) [NeZero N] (j₀ : (AlgebraicClosure ℚ))
+    (hβ : ∃ (E₀ : WeierstrassCurve (AlgebraicClosure ℚ)) (_ : E₀.IsElliptic), E₀.j = j₀ ∧
+      ∃ f : CycSub E₀ N →
+          {w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+            0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)},
+        (∀ H H' : CycSub E₀ N, f H = f H' ↔ SameOrbit E₀ H.1 H'.1) ∧
+        ∀ w : {w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+            0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)},
+          ((w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)).ord
+              (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)).toNat =
+            Nat.card {H : CycSub E₀ N // f H = w})
+    (hfin : ∀ (E₀ : WeierstrassCurve (AlgebraicClosure ℚ)) [E₀.IsElliptic], Finite (CycSub E₀ N))
+    (hEP : ∀ ψ : {ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ]
+          HahnSeries ℚ (AlgebraicClosure ℚ) //
+        ψ (jBar N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)},
+      ∃ (w : AlgebraicCurve.Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)) (g : ℚ),
+        0 < g ∧ ∀ x : ↥(modularFunctionFieldBar N), (w.ord x : ℚ) * g = (ψ.1 x).order)
+    (hPEO : ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N),
+      0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) →
+      Nat.card {ψ : modularFunctionFieldBar N →ₐ[AlgebraicClosure ℚ]
+          HahnSeries ℚ (AlgebraicClosure ℚ) //
+        ψ (jBar N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ) ∧
+        ∃ g : ℚ, 0 < g ∧ ∀ x, (w.ord x : ℚ) * g = (ψ x).order} =
+      (w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)).toNat)
+    (hC535 : ∀ {ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ]
+          HahnSeries ℚ (AlgebraicClosure ℚ)}
+      {w w' : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)},
+      Induces ψ w → Induces ψ w' → w = w')
+    : EMD N j₀ :=
+  solution N j₀ hβ hfin hEP hPEO hC535
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eq_cuspInftyBar_or_eq_cuspZeroBar.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eq_cuspInftyBar_or_eq_cuspZeroBar.lean
new file mode 100644
index 0000000000..75d857c4aa
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eq_cuspInftyBar_or_eq_cuspZeroBar.lean
@@ -0,0 +1,314 @@
+/-
+Based on Prove2Me node ModularCurve.eq_cuspInftyBar_or_eq_cuspZeroBar
+(838f6e71-e7c0-5969-aef1-705a3042b5af) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission dbf3629f-a03b-5832-8812-b9a975b556ab
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CuspidalClass
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_le_finrank
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_inertiaDeg_pos
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_subsingleton_setOf_forall_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_modularFunctionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_full_eq_of_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_modularPolynomialData_of_squarefree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqNModC_le
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_adjoin_jqNModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_cuspInftyBar_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_cuspZeroBar_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_cuspZeroBar_ne_cuspInftyBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCusp_cuspZeroBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCusp_cuspInftyBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isFrickeAutFull_frickeInvolutionFull_prime
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Only two cusps on X₀(ℓ)_ℚ̄ at prime level
+
+Theorem statement: `ModularCurve.eq_cuspInftyBar_or_eq_cuspZeroBar`
+(`838f6e71-e7c0-5969-aef1-705a3042b5af`), by Claude, 2026-09-05.
+
+Proof: submission `dbf3629f-a03b-5832-8812-b9a975b556ab`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a prime and let $\bar F_\ell$ denote `modularFunctionFieldBar ℓ`, the intermediate
+field of $\bar{\mathbb Q}((q))$ over $\bar{\mathbb Q}$ generated by the coefficientwise image under
+`coeffEmb` of `modularFunctionFieldFull ℓ` (itself the subfield of $\mathbb Q((q))$ generated over
+$\mathbb Q$ by the set `divisorExpansions ℓ`). Write $\bar j$ for the element of $\bar F_\ell$
+obtained by applying `coeffEmb` to the Laurent series $q^{-1}\cdot\mathrm{ofPowerSeries}(jNumQ)$,
+i.e. the $q$-expansion of the modular invariant $j$. Let $w$ be a place of $\bar F_\ell$ over
+$\bar{\mathbb Q}$, that is, a valuation subring of $\bar F_\ell$ which is not the whole field,
+contains the image of $\bar{\mathbb Q}$, and is a principal ideal ring. Assume $\bar j$ is not in
+the valuation subring of $w$, which is the meaning of `IsCusp` for $\bar j$ and $w$. Then $w$ equals
+either `cuspInftyBar ℓ`, the place whose valuation subring consists of the elements of non-negative
+$q$-order, or `cuspZeroBar ℓ`, its translate under the Fricke involution `frickeInvolutionBar ℓ`.
+
+This is the classical statement that $X_0(\ell)$ over an algebraically closed field of
+characteristic zero has exactly two cusps, $\infty$ and $0$, here in the form: any place of the
+function field at which $j$ has a pole is one of these two. It is used throughout the analysis of
+places of $\bar F_\ell$ and their specialisations, in particular by the level-one prolongation
+lemmas on divisors and residues.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_eq_cuspInftyBar_or_eq_cuspZeroBar.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_eq_cuspInftyBar_or_eq_cuspZeroBar
+
+p2m_open "ModularCurve~dedekindPsi_prime AlgebraicCurve IntermediateField"
+open scoped Polynomial
+
+noncomputable section
+
+namespace TwoCuspAux
+
+local notation "𝕂" => AlgebraicClosure ℚ
+
+variable (ℓ : ℕ) [Fact ℓ.Prime]
+
+theorem prime' : ℓ.Prime := Fact.out
+
+theorem dedekindPsi_prime : dedekindPsi ℓ = ℓ + 1 := by
+  have hℓ : ℓ.Prime := Fact.out
+  rw [dedekindPsi, hℓ.divisors, Finset.filter_true_of_mem, Finset.sum_pair hℓ.one_lt.ne,
+    Nat.div_one,
+    Nat.div_self hℓ.pos, add_comm]
+  intro d hd
+  simp only [Finset.mem_insert, Finset.mem_singleton] at hd
+  rcases hd with rfl | rfl
+  · exact squarefree_one
+  · exact hℓ.squarefree
+
+def jb :
+    modularFunctionFieldBar ℓ := ⟨coeffEmb 𝕂 jq, coeffEmb_mem_laurentBaseChange 𝕂 (jq_mem_full ℓ)⟩
+
+theorem coe_jb : (jb ℓ : LaurentSeries 𝕂) = jqModC 𝕂 := coeffEmb_jq 𝕂
+
+theorem bar_eq_restrictScalars :
+    modularFunctionFieldBar ℓ = (𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯).restrictScalars 𝕂 := by
+  have hℓ : ℓ.Prime := Fact.out
+  change laurentBaseChange 𝕂 (modularFunctionFieldFull ℓ) = _
+  rw [full_eq_of_prime hℓ, laurentBaseChange_modularFunctionField]
+  exact (adjoin_simple_adjoin_simple 𝕂 (jqModC 𝕂) (jqNModC 𝕂 ℓ)).symm
+
+def σa : RatFunc 𝕂 ≃ₐ[𝕂] 𝕂⟮jqModC 𝕂⟯ :=
+  RatFunc.algEquivOfTranscendental (jqModC 𝕂) (transcendental_jqModC 𝕂)
+
+theorem coe_σa_X : ((σa (RatFunc.X : RatFunc 𝕂) : 𝕂⟮jqModC 𝕂⟯) : LaurentSeries 𝕂) = jqModC 𝕂 :=
+  RatFunc.algEquivOfTranscendental_X (jqModC 𝕂) (transcendental_jqModC 𝕂)
+
+theorem mem_bar_iff (x : LaurentSeries 𝕂) :
+    x ∈ modularFunctionFieldBar ℓ ↔ x ∈ 𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯ := by
+  rw [bar_eq_restrictScalars ℓ, mem_restrictScalars]
+
+def jTr : (𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯) ≃+* modularFunctionFieldBar ℓ where
+  toFun x := ⟨x, (mem_bar_iff ℓ _).mpr x.2⟩
+  invFun y := ⟨y, (mem_bar_iff ℓ _).mp y.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  map_mul' _ _ := rfl
+  map_add' _ _ := rfl
+
+theorem coe_jTr (x : 𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯) :
+    ((jTr ℓ x : modularFunctionFieldBar ℓ) : LaurentSeries 𝕂) = x := by
+  ext
+  rfl
+
+def φ : RatFunc 𝕂 →+* modularFunctionFieldBar ℓ :=
+  (jTr ℓ).toRingHom.comp
+    ((algebraMap (𝕂⟮jqModC 𝕂⟯) (𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯)).comp (σa).toRingEquiv.toRingHom)
+
+theorem φ_apply (x : RatFunc 𝕂) :
+    φ ℓ x = jTr ℓ (algebraMap (𝕂⟮jqModC 𝕂⟯) (𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯) (σa x)) := rfl
+
+theorem coe_algebraMap_tower (y : 𝕂⟮jqModC 𝕂⟯) :
+    ((algebraMap (𝕂⟮jqModC 𝕂⟯) (𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯) y : 𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯) :
+      LaurentSeries 𝕂) = y := by
+  ext
+  rfl
+
+theorem coe_φ (x : RatFunc 𝕂) :
+    ((φ ℓ x : modularFunctionFieldBar ℓ) : LaurentSeries 𝕂) = (σa x : LaurentSeries 𝕂) := by
+  rw [φ_apply, coe_jTr, coe_algebraMap_tower]
+
+theorem φ_algebraMap (k : 𝕂) :
+    φ ℓ (algebraMap 𝕂 (RatFunc 𝕂) k) = algebraMap 𝕂 (modularFunctionFieldBar ℓ) k := by
+  ext
+  rw [coe_φ, AlgEquiv.commutes]
+  rfl
+
+theorem φ_X : φ ℓ (RatFunc.X : RatFunc 𝕂) = jb ℓ := by
+  apply Subtype.ext
+  rw [coe_φ, coe_jb, coe_σa_X]
+
+abbrev algRatFunc : Algebra (RatFunc 𝕂) (modularFunctionFieldBar ℓ) := (φ ℓ).toAlgebra
+
+attribute [local instance] algRatFunc
+
+theorem algebraMap_eq : algebraMap (RatFunc 𝕂) (modularFunctionFieldBar ℓ) = φ ℓ := rfl
+
+theorem isScalarTower_ratFunc : IsScalarTower 𝕂 (RatFunc 𝕂) (modularFunctionFieldBar ℓ) :=
+  IsScalarTower.of_algebraMap_eq fun k => (φ_algebraMap ℓ k).symm
+
+attribute [local instance] isScalarTower_ratFunc
+
+theorem he_compat :
+    (algebraMap (RatFunc 𝕂) (modularFunctionFieldBar ℓ)).comp
+        (σa.symm.toRingEquiv : 𝕂⟮jqModC 𝕂⟯ ≃+* RatFunc 𝕂).toRingHom
+      = (jTr ℓ).toRingHom.comp (algebraMap (𝕂⟮jqModC 𝕂⟯) (𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯)) := by
+  apply RingHom.ext
+  intro y
+  change φ ℓ (σa.symm y) = jTr ℓ (algebraMap _ _ y)
+  rw [φ_apply, AlgEquiv.apply_symm_apply]
+
+theorem finite_ratFunc : Module.Finite (RatFunc 𝕂) (modularFunctionFieldBar ℓ) := by
+  have hℓ : ℓ.Prime := Fact.out
+  obtain ⟨data⟩ := nonempty_modularPolynomialData_of_squarefree ℓ hℓ.squarefree hℓ.one_lt
+  have := finiteDimensional_adjoin_jqNModC 𝕂 data
+  exact Module.Finite.of_equiv_equiv (σa.symm.toRingEquiv : 𝕂⟮jqModC 𝕂⟯ ≃+* RatFunc 𝕂) (jTr ℓ)
+    (he_compat ℓ)
+
+attribute [local instance] finite_ratFunc
+
+theorem finrank_le : Module.finrank (RatFunc 𝕂) (modularFunctionFieldBar ℓ) ≤ ℓ + 1 := by
+  have hℓ : ℓ.Prime := Fact.out
+  obtain ⟨data⟩ := nonempty_modularPolynomialData_of_squarefree ℓ hℓ.squarefree hℓ.one_lt
+  rw [← Algebra.finrank_eq_of_equiv_equiv (σa.symm.toRingEquiv : 𝕂⟮jqModC 𝕂⟯ ≃+* RatFunc 𝕂) (jTr ℓ)
+    (he_compat ℓ), ← dedekindPsi_prime ℓ]
+  exact finrank_adjoin_jqNModC_le 𝕂 data
+
+theorem isSeparable_ratFunc : Algebra.IsSeparable (RatFunc 𝕂) (modularFunctionFieldBar ℓ) :=
+  Algebra.IsAlgebraic.isSeparable_of_perfectField
+
+attribute [local instance] isSeparable_ratFunc
+
+theorem restrict_eq_of_isCusp (u : Place 𝕂 (modularFunctionFieldBar ℓ)) (hu : IsCusp (jb ℓ) u) :
+    u.restrict (RatFunc 𝕂) = (cuspInftyBar ℓ).restrict (RatFunc 𝕂) := by
+  have key : ∀ u' : Place 𝕂 (modularFunctionFieldBar ℓ), IsCusp (jb ℓ) u' →
+      ∀ p : IsDedekindDomain.HeightOneSpectrum 𝕂[X],
+        u'.restrict (RatFunc 𝕂) ≠ Place.ofHeightOneSpectrum p := by
+    intro u' hu' p heq
+    apply hu'
+    have hX : (RatFunc.X : RatFunc 𝕂) ∈ (u'.restrict (RatFunc 𝕂)).toValuationSubring := by
+      rw [heq, Place.ofHeightOneSpectrum_toValuationSubring, Valuation.mem_valuationSubring_iff,
+        ← RatFunc.algebraMap_X]
+      exact p.valuation_le_one _
+    rw [Place.mem_restrict_iff, algebraMap_eq, φ_X] at hX
+    exact hX
+  exact RationalFunctionField.subsingleton_setOf_forall_ne_ofHeightOneSpectrum (key u hu)
+    (key _ (isCusp_cuspInftyBar ℓ))
+
+theorem e_infty : ((cuspInftyBar ℓ).ramificationIndex (RatFunc 𝕂) : ℤ) = 1 ∧
+    ((cuspInftyBar ℓ).restrict (RatFunc 𝕂)).ord RatFunc.X = -1 := by
+  have h := (cuspInftyBar ℓ).ord_restrict (F := RatFunc 𝕂) RatFunc.X
+  rw [algebraMap_eq, φ_X] at h
+  have hj : (cuspInftyBar ℓ).ord (jb ℓ) = -1 := ord_cuspInftyBar_coeffEmb_jq ℓ
+  rw [hj] at h
+  have epos : (0 : ℤ) < (cuspInftyBar ℓ).ramificationIndex (RatFunc 𝕂) := by
+    exact_mod_cast (cuspInftyBar ℓ).ramificationIndex_pos (F := RatFunc 𝕂)
+  have h1 : ((cuspInftyBar ℓ).ramificationIndex (RatFunc 𝕂) : ℤ) *
+      (-((cuspInftyBar ℓ).restrict (RatFunc 𝕂)).ord RatFunc.X) = 1 := by linarith
+  have he := Int.eq_one_of_mul_eq_one_right epos.le h1
+  refine ⟨he, ?_⟩
+  rw [he, one_mul] at h1
+  linarith
+
+theorem e_zero (hw : IsFrickeAutFull ℓ (frickeInvolutionFull ℓ)) :
+    ((cuspZeroBar ℓ).ramificationIndex (RatFunc 𝕂) : ℤ) = ℓ := by
+  have h := (cuspZeroBar ℓ).ord_restrict (F := RatFunc 𝕂) RatFunc.X
+  rw [algebraMap_eq, φ_X, restrict_eq_of_isCusp ℓ _ (isCusp_cuspZeroBar ℓ hw), (e_infty ℓ).2] at h
+  have hj : (cuspZeroBar ℓ).ord (jb ℓ) = -ℓ := ord_cuspZeroBar_coeffEmb_jq ℓ hw
+  rw [hj] at h
+  linarith
+
+theorem eq_cuspInftyBar_or_eq_cuspZeroBar (hw : IsFrickeAutFull ℓ (frickeInvolutionFull ℓ))
+    (w : Place 𝕂 (modularFunctionFieldBar ℓ)) (hc : IsCusp (jb ℓ) w) :
+    w = cuspInftyBar ℓ ∨ w = cuspZeroBar ℓ := by
+  classical
+  by_contra hnot
+  have h1 : w ≠ cuspInftyBar ℓ := fun h => hnot (Or.inl h)
+  have h2 : w ≠ cuspZeroBar ℓ := fun h => hnot (Or.inr h)
+  have hℓ : ℓ.Prime := Fact.out
+  have hne : cuspZeroBar ℓ ≠ cuspInftyBar ℓ := cuspZeroBar_ne_cuspInftyBar ℓ hw hℓ.one_lt
+  have r0 := restrict_eq_of_isCusp ℓ _ (isCusp_cuspZeroBar ℓ hw)
+  have rw' := restrict_eq_of_isCusp ℓ _ hc
+  have hS : ∀ u ∈ ({cuspInftyBar ℓ, cuspZeroBar ℓ, w} : Finset (Place 𝕂 (modularFunctionFieldBar
+    ℓ))),
+      u.restrict (RatFunc 𝕂) = (cuspInftyBar ℓ).restrict (RatFunc 𝕂) := by
+    intro u hu
+    simp only [Finset.mem_insert, Finset.mem_singleton] at hu
+    rcases hu with rfl | rfl | rfl
+    · rfl
+    · exact r0
+    · exact rw'
+  have hsum := Place.sum_ramificationIndex_mul_inertiaDeg_le_finrank _ _ hS
+  rw [Finset.sum_insert (by simp [hne.symm, Ne.symm h1]), Finset.sum_insert (by simp [Ne.symm h2]),
+    Finset.sum_singleton] at hsum
+  have hrank : (Module.finrank (RatFunc 𝕂) (modularFunctionFieldBar ℓ) : ℤ) ≤ ℓ + 1 := by
+    exact_mod_cast finrank_le ℓ
+  have e1 := (e_infty ℓ).1
+  have e0 := e_zero ℓ hw
+  have ew : (1 : ℤ) ≤ w.ramificationIndex (RatFunc 𝕂) := by
+    exact_mod_cast w.ramificationIndex_pos (F := RatFunc 𝕂)
+  have f1 : (1 : ℤ) ≤ (cuspInftyBar ℓ).inertiaDeg (RatFunc 𝕂) := by
+    exact_mod_cast Place.inertiaDeg_pos (F := RatFunc 𝕂) (cuspInftyBar ℓ)
+  have f0 : (1 : ℤ) ≤ (cuspZeroBar ℓ).inertiaDeg (RatFunc 𝕂) := by
+    exact_mod_cast Place.inertiaDeg_pos (F := RatFunc 𝕂) (cuspZeroBar ℓ)
+  have fw : (1 : ℤ) ≤ w.inertiaDeg (RatFunc 𝕂) := by
+    exact_mod_cast Place.inertiaDeg_pos (F := RatFunc 𝕂) w
+  have p0 : (ℓ : ℤ) ≤ ((cuspZeroBar ℓ).ramificationIndex (RatFunc 𝕂) : ℤ) *
+      ((cuspZeroBar ℓ).inertiaDeg (RatFunc 𝕂) : ℤ) := by
+    rw [e0]; nlinarith
+  have pw : (1 : ℤ) ≤ (w.ramificationIndex (RatFunc 𝕂) : ℤ) * (w.inertiaDeg (RatFunc 𝕂) : ℤ) :=
+    one_le_mul_of_one_le_of_one_le ew fw
+  rw [e1, one_mul] at hsum
+  linarith
+
+end TwoCuspAux
+
+open TwoCuspAux in
+theorem solution (ℓ : ℕ) [Fact ℓ.Prime] (w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar ℓ))
+  (hc : IsCusp (⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange (AlgebraicClosure
+  ℚ) (jq_mem_full ℓ)⟩ : modularFunctionFieldBar ℓ) w) :
+    w = cuspInftyBar ℓ ∨ w = cuspZeroBar ℓ :=
+  TwoCuspAux.eq_cuspInftyBar_or_eq_cuspZeroBar ℓ (isFrickeAutFull_frickeInvolutionFull_prime ℓ) w hc
+
+end
+end S_ModularCurve_eq_cuspInftyBar_or_eq_cuspZeroBar
+end P2MW
+export P2MW.S_ModularCurve_eq_cuspInftyBar_or_eq_cuspZeroBar (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.eq_cuspInftyBar_or_eq_cuspZeroBar (ℓ : ℕ) [Fact ℓ.Prime] (w : Place
+  (AlgebraicClosure ℚ) (modularFunctionFieldBar ℓ)) (hc : IsCusp (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+  coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full ℓ)⟩ : modularFunctionFieldBar ℓ)
+  w) :
+    w = cuspInftyBar ℓ ∨ w = cuspZeroBar ℓ :=
+  solution ℓ w hc
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eq_jLinePlace1728_iff_ord_jGen_sub_pos.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eq_jLinePlace1728_iff_ord_jGen_sub_pos.lean
new file mode 100644
index 0000000000..5a60166db8
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eq_jLinePlace1728_iff_ord_jGen_sub_pos.lean
@@ -0,0 +1,143 @@
+/-
+Based on Prove2Me node ModularCurve.eq_jLinePlace1728_iff_ord_jGen_sub_pos
+(bbd97c03-8715-591b-8750-ab5ad0a78c74) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission bad74d33-0a7b-515a-b7bb-ea1a542f7fd6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JLinePlaces
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_X_sub_C
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A place of the j-line is v₁₇₂₈ iff ordᵥ(j-1728)>0
+
+Theorem statement: `ModularCurve.eq_jLinePlace1728_iff_ord_jGen_sub_pos`
+(`bbd97c03-8715-591b-8750-ab5ad0a78c74`), by Claude, 2026-09-05.
+
+Proof: submission `bad74d33-0a7b-515a-b7bb-ea1a542f7fd6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $j$ denote the Laurent series [`ModularCurve.jq`](def/ModularCurve_X0.html#L157) over
+$\mathbb{Q}$, namely $q^{-1}$ times the power series `jNumQ`, let $\mathbb{Q}\langle j\rangle =
+\mathbb{Q}\langle\!\langle\mathrm{jq}\rangle\!\rangle$ be the subfield of the Laurent series field
+generated over $\mathbb{Q}$ by $j$, and let `jGen` be $j$ regarded as an element of that field. For
+a place $v$ of $\mathbb{Q}\langle j\rangle$ over $\mathbb{Q}$ — that is, a valuation subring of
+$\mathbb{Q}\langle j\rangle$ containing the image of $\mathbb{Q}$, different from the whole field,
+and a principal ideal ring — the statement asserts the equivalence of: (i) $v$ equals
+[`ModularCurve.jLinePlace1728`](def/ModularCurve_JLinePlaces.html#L50), the place obtained by
+transporting along the ring isomorphism `jLineRingEquiv : RatFunc ℚ ≃+* ℚ⟮jq⟯` (which carries the
+variable to $j$ and fixes $\mathbb{Q}$) the finite place `placeOfPoint ℚ 1728` of $\mathbb{Q}(T)$
+attached to the irreducible polynomial $T - 1728$; and (ii) $0 < v.\mathrm{ord}(\mathrm{jGen} -
+1728)$, where $v.\mathrm{ord}$ is minus the logarithm of the $\mathbb{Z}^{m0}$-valued adic valuation
+attached to the height-one prime of $v$, so that the condition says $j - 1728$ has a zero at $v$.
+
+This identifies the place $j = 1728$ of the $j$-line over $\mathbb{Q}$ by the vanishing of $j -
+1728$, one of the three distinguished places ($j = 0$, $j = 1728$, $j = \infty$) of the rational
+function field $\mathbb{Q}(j)$. It is used via
+[`ModularCurve.restrict_eq_jLinePlace1728_iff`]
+(thm.html#ModularCurve.restrict_eq_jLinePlace1728_iff)
+to recognise, by an order condition, those places of a modular curve lying over $j = 1728$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_eq_jLinePlace1728_iff_ord_jGen_sub_pos.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_eq_jLinePlace1728_iff_ord_jGen_sub_pos
+
+open IntermediateField AlgebraicCurve AlgebraicCurve.RationalFunctionField
+
+attribute [local instance 2000] RatFunc.instAlgebraOfPolynomial
+attribute [local instance] ModularCurve.instDecidableEqRatFuncRat
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jLineRingEquiv jLineRingEquiv_X instDecidableEqRatFuncRat \
+  jLinePlace1728 jq jGen"
+namespace JLineOrdAux
+p2m_open "ModularCurve"
+
+theorem equiv_X_sub_C (b : ℚ) :
+    ModularCurve.jLineRingEquiv (algebraMap (Polynomial ℚ) (RatFunc ℚ) (Polynomial.X - Polynomial.C
+      b))
+      = ModularCurve.jGen - algebraMap ℚ ↥ℚ⟮ModularCurve.jq⟯ b := by
+  rw [map_sub, RatFunc.algebraMap_X, map_sub, ModularCurve.jLineRingEquiv_X, RatFunc.algebraMap_C]
+  congr 1
+  exact RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom b
+
+theorem exists_eq_congr (v : Place ℚ ↥ℚ⟮ModularCurve.jq⟯) :
+    ∃ v' : Place ℚ (RatFunc ℚ), v = Place.congrRingEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom) v' :=
+  ⟨(Place.congrEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom)).symm v,
+    ((Place.congrEquiv _ _).apply_symm_apply v).symm⟩
+
+theorem ord_congr_jGen_sub (b : ℚ) (v' : Place ℚ (RatFunc ℚ)) :
+    (Place.congrRingEquiv ModularCurve.jLineRingEquiv
+        (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom) v').ord
+      (ModularCurve.jGen - algebraMap ℚ ↥ℚ⟮ModularCurve.jq⟯ b)
+    = (Finsupp.single (placeOfPoint ℚ b) (1 : ℤ) + Finsupp.single (placeInfty ℚ) (-1 : ℤ)) v' := by
+  rw [← equiv_X_sub_C, Place.ord_congrRingEquiv]
+  exact ord_X_sub_C ℚ b v'
+
+theorem injective_congr : Function.Injective (Place.congrRingEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom) : Place ℚ (RatFunc ℚ) → _)
+        :=
+  (Place.congrEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom)).injective
+
+end ModularCurve.JLineOrdAux
+
+open ModularCurve.JLineOrdAux
+
+theorem solution (v : AlgebraicCurve.Place ℚ ↥ℚ⟮ModularCurve.jq⟯) :
+    v = ModularCurve.jLinePlace1728 ↔ 0 < v.ord (ModularCurve.jGen - 1728) := by
+  obtain ⟨v', rfl⟩ := exists_eq_congr v
+  have h := ord_congr_jGen_sub 1728 v'
+  rw [show algebraMap ℚ ↥ℚ⟮ModularCurve.jq⟯ 1728 = 1728 from map_ofNat _ 1728] at h
+  rw [h]
+  have h01 := placeOfPoint_ne_placeInfty ℚ 1728
+  unfold ModularCurve.jLinePlace1728
+  constructor
+  · intro hv
+    rw [injective_congr hv]
+    simp [h01]
+  · intro hlt
+    by_contra hne
+    have hne' : v' ≠ placeOfPoint ℚ 1728 := fun h' => hne (by rw [h'])
+    rcases eq_or_ne v' (placeInfty ℚ) with h0 | h0
+    · subst h0
+      simp [h01.symm] at hlt
+    · simp [hne', h0] at hlt
+
+end S_ModularCurve_eq_jLinePlace1728_iff_ord_jGen_sub_pos
+end P2MW
+export P2MW.S_ModularCurve_eq_jLinePlace1728_iff_ord_jGen_sub_pos (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open IntermediateField AlgebraicCurve
+theorem ModularCurve.eq_jLinePlace1728_iff_ord_jGen_sub_pos (v : AlgebraicCurve.Place ℚ
+  ↥ℚ⟮ModularCurve.jq⟯) :
+    v = ModularCurve.jLinePlace1728 ↔ 0 < v.ord (ModularCurve.jGen - 1728) :=
+  solution v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eq_jLinePlaceInfty_iff_ord_jGen_neg.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eq_jLinePlaceInfty_iff_ord_jGen_neg.lean
new file mode 100644
index 0000000000..a8a0611c6e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eq_jLinePlaceInfty_iff_ord_jGen_neg.lean
@@ -0,0 +1,144 @@
+/-
+Based on Prove2Me node ModularCurve.eq_jLinePlaceInfty_iff_ord_jGen_neg
+(413ef15d-0bcf-59bf-a139-83d5e14af46e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1de9d5da-fc0b-5eb9-8ff9-37e9c945f759
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JLinePlaces
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_X_sub_C
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A place of the j-line is v_∞ iff j has a pole
+
+Theorem statement: `ModularCurve.eq_jLinePlaceInfty_iff_ord_jGen_neg`
+(`413ef15d-0bcf-59bf-a139-83d5e14af46e`), by Claude, 2026-09-05.
+
+Proof: submission `1de9d5da-fc0b-5eb9-8ff9-37e9c945f759`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Here $jq$ denotes the Laurent series $q^{-1}\cdot \mathrm{jNumQ}$ over $\mathbb{Q}$ (the
+$q$-expansion of the modular invariant $j$, with $\mathrm{jNumQ}$ the rational-coefficient power
+series obtained from the integral numerator series), and $\mathbb{Q}\langle jq\rangle$ is the simple
+extension of $\mathbb{Q}$ generated by $jq$ inside the field of Laurent series;
+[`ModularCurve.jGen`](def/ModularCurve_X0.html#L268) is $jq$ viewed as an element of that field. A
+place of $\mathbb{Q}\langle jq\rangle$ over $\mathbb{Q}$ is, by the project's definition, a
+valuation subring of $\mathbb{Q}\langle jq\rangle$ which contains the image of $\mathbb{Q}$, is not
+the whole field, and is a principal ideal ring; for such a place $v$ and $f$ in the field,
+$v.\mathrm{ord}\,f$ is minus the logarithm of the value of $f$ under the adic valuation attached to
+$v$. The place [`ModularCurve.jLinePlaceInfty`](def/ModularCurve_JLinePlaces.html#L58) is the
+transport, along the isomorphism $\mathrm{RatFunc}\,\mathbb{Q}\cong\mathbb{Q}\langle jq\rangle$
+sending the variable to $jq$ (available since $jq$ is transcendental over $\mathbb{Q}$), of the
+place at infinity of $\mathbb{Q}(T)$, i.e. of the valuation subring of the degree valuation. The
+assertion is that for every place $v$ of $\mathbb{Q}\langle jq\rangle$ over $\mathbb{Q}$ one has $v
+=$ `jLinePlaceInfty` if and only if $v.\mathrm{ord}\,(jGen) < 0$.
+
+This identifies the place at infinity of the $j$-line $X(1)$ over $\mathbb{Q}$ as the unique place
+at which $j$ has a pole, all other places lying in the subring where $j$ is integral. It is used by
+[`ModularCurve.restrict_eq_jLinePlaceInfty_iff`]
+(thm.html#ModularCurve.restrict_eq_jLinePlaceInfty_iff)
+in the analysis of places of modular function fields above the $j$-line.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_eq_jLinePlaceInfty_iff_ord_jGen_neg.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_eq_jLinePlaceInfty_iff_ord_jGen_neg
+
+open IntermediateField AlgebraicCurve AlgebraicCurve.RationalFunctionField
+
+attribute [local instance 2000] RatFunc.instAlgebraOfPolynomial
+attribute [local instance] ModularCurve.instDecidableEqRatFuncRat
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jLineRingEquiv jLineRingEquiv_X instDecidableEqRatFuncRat \
+  jLinePlaceInfty jq jGen"
+namespace JLineOrdAux
+p2m_open "ModularCurve"
+
+theorem equiv_X_sub_C (b : ℚ) :
+    ModularCurve.jLineRingEquiv (algebraMap (Polynomial ℚ) (RatFunc ℚ) (Polynomial.X - Polynomial.C
+      b))
+      = ModularCurve.jGen - algebraMap ℚ ↥ℚ⟮ModularCurve.jq⟯ b := by
+  rw [map_sub, RatFunc.algebraMap_X, map_sub, ModularCurve.jLineRingEquiv_X, RatFunc.algebraMap_C]
+  congr 1
+  exact RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom b
+
+theorem exists_eq_congr (v : Place ℚ ↥ℚ⟮ModularCurve.jq⟯) :
+    ∃ v' : Place ℚ (RatFunc ℚ), v = Place.congrRingEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom) v' :=
+  ⟨(Place.congrEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom)).symm v,
+    ((Place.congrEquiv _ _).apply_symm_apply v).symm⟩
+
+theorem ord_congr_jGen_sub (b : ℚ) (v' : Place ℚ (RatFunc ℚ)) :
+    (Place.congrRingEquiv ModularCurve.jLineRingEquiv
+        (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom) v').ord
+      (ModularCurve.jGen - algebraMap ℚ ↥ℚ⟮ModularCurve.jq⟯ b)
+    = (Finsupp.single (placeOfPoint ℚ b) (1 : ℤ) + Finsupp.single (placeInfty ℚ) (-1 : ℤ)) v' := by
+  rw [← equiv_X_sub_C, Place.ord_congrRingEquiv]
+  exact ord_X_sub_C ℚ b v'
+
+theorem injective_congr : Function.Injective (Place.congrRingEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom) : Place ℚ (RatFunc ℚ) → _)
+        :=
+  (Place.congrEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom)).injective
+
+end ModularCurve.JLineOrdAux
+
+open ModularCurve.JLineOrdAux
+
+theorem solution (v : AlgebraicCurve.Place ℚ ↥ℚ⟮ModularCurve.jq⟯) :
+    v = ModularCurve.jLinePlaceInfty ↔ v.ord ModularCurve.jGen < 0 := by
+  obtain ⟨v', rfl⟩ := exists_eq_congr v
+  have h := ord_congr_jGen_sub 0 v'
+  rw [map_zero, sub_zero] at h
+  rw [h]
+  have h01 := placeOfPoint_ne_placeInfty ℚ 0
+  unfold ModularCurve.jLinePlaceInfty
+  constructor
+  · intro hv
+    rw [injective_congr hv]
+    simp [h01.symm]
+  · intro hlt
+    by_contra hne
+    have hne' : v' ≠ placeInfty ℚ := fun h' => hne (by rw [h'])
+    rcases eq_or_ne v' (placeOfPoint ℚ 0) with h0 | h0
+    · subst h0
+      simp [h01] at hlt
+    · simp [hne', h0] at hlt
+
+end S_ModularCurve_eq_jLinePlaceInfty_iff_ord_jGen_neg
+end P2MW
+export P2MW.S_ModularCurve_eq_jLinePlaceInfty_iff_ord_jGen_neg (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open IntermediateField AlgebraicCurve
+theorem ModularCurve.eq_jLinePlaceInfty_iff_ord_jGen_neg (v : AlgebraicCurve.Place ℚ
+  ↥ℚ⟮ModularCurve.jq⟯) :
+    v = ModularCurve.jLinePlaceInfty ↔ v.ord ModularCurve.jGen < 0 :=
+  solution v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eq_jLinePlaceZero_iff_ord_jGen_pos.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eq_jLinePlaceZero_iff_ord_jGen_pos.lean
new file mode 100644
index 0000000000..d55f4063d7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eq_jLinePlaceZero_iff_ord_jGen_pos.lean
@@ -0,0 +1,148 @@
+/-
+Based on Prove2Me node ModularCurve.eq_jLinePlaceZero_iff_ord_jGen_pos
+(12d24bcc-2bc8-5aa1-8bf9-9fb993e8d2f5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 908cba4d-c57a-5e89-ab92-89edfd2886d0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JLinePlaces
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_X_sub_C
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A place of the j-line is v₀ iff ordᵥ(j)>0
+
+Theorem statement: `ModularCurve.eq_jLinePlaceZero_iff_ord_jGen_pos`
+(`12d24bcc-2bc8-5aa1-8bf9-9fb993e8d2f5`), by Claude, 2026-09-05.
+
+Proof: submission `908cba4d-c57a-5e89-ab92-89edfd2886d0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $j(q) \in \mathbb{Q}((q))$ be the Laurent series
+[`ModularCurve.jq`](def/ModularCurve_X0.html#L157), namely $q^{-1}$ times the rational power series
+obtained from the integral numerator series of the modular $j$-function, and let $\mathbb{Q}\langle
+j(q)\rangle$ denote the intermediate field of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by
+$j(q)$; write [`ModularCurve.jGen`](def/ModularCurve_X0.html#L268) for $j(q)$ regarded as an element
+of that field. A place of $\mathbb{Q}\langle j(q)\rangle$ over $\mathbb{Q}$ is, in the sense of the
+project's structure [`AlgebraicCurve.Place`](def/AlgebraicCurve_DivisorClassGroup.html#L22), a
+valuation subring of $\mathbb{Q}\langle j(q)\rangle$ that contains the image of $\mathbb{Q}$, is not
+the whole field, and is a principal ideal ring; for such a $v$ and an element $f$,
+$v.\mathrm{ord}\,f$ is minus the logarithm of the value of $f$ under the associated
+height-one-spectrum adic valuation. Finally,
+[`ModularCurve.jLinePlaceZero`](def/ModularCurve_JLinePlaces.html#L54) is the place obtained by
+transporting, along the isomorphism $\mathbb{Q}(T) \cong \mathbb{Q}\langle j(q)\rangle$ sending $T
+\mapsto j(q)$ (available since $j(q)$ is transcendental over $\mathbb{Q}$), the finite place of
+$\mathbb{Q}(T)$ attached to the irreducible polynomial $T - 0$. The theorem asserts: for every place
+$v$ of $\mathbb{Q}\langle j(q)\rangle$ over $\mathbb{Q}$, one has $v =$ `jLinePlaceZero` if and only
+if $v.\mathrm{ord}\,(j(q)) > 0$.
+
+This is the characterisation of the place $j = 0$ of the $j$-line $X(1)_{\mathbb{Q}}$ as the unique
+place at which the coordinate $j$ has positive order, the other two distinguished places being those
+at $j = 1728$ and $j = \infty$. It is used by
+[`ModularCurve.restrict_eq_jLinePlaceZero_iff`]
+(thm.html#ModularCurve.restrict_eq_jLinePlaceZero_iff),
+which recognises places of the $j$-line obtained by restriction from a larger modular function
+field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_eq_jLinePlaceZero_iff_ord_jGen_pos.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_eq_jLinePlaceZero_iff_ord_jGen_pos
+
+open IntermediateField AlgebraicCurve AlgebraicCurve.RationalFunctionField
+
+attribute [local instance 2000] RatFunc.instAlgebraOfPolynomial
+attribute [local instance] ModularCurve.instDecidableEqRatFuncRat
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jLineRingEquiv jLineRingEquiv_X instDecidableEqRatFuncRat \
+  jLinePlaceZero jq jGen"
+namespace JLineOrdAux
+p2m_open "ModularCurve"
+
+theorem equiv_X_sub_C (b : ℚ) :
+    ModularCurve.jLineRingEquiv (algebraMap (Polynomial ℚ) (RatFunc ℚ) (Polynomial.X - Polynomial.C
+      b))
+      = ModularCurve.jGen - algebraMap ℚ ↥ℚ⟮ModularCurve.jq⟯ b := by
+  rw [map_sub, RatFunc.algebraMap_X, map_sub, ModularCurve.jLineRingEquiv_X, RatFunc.algebraMap_C]
+  congr 1
+  exact RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom b
+
+theorem exists_eq_congr (v : Place ℚ ↥ℚ⟮ModularCurve.jq⟯) :
+    ∃ v' : Place ℚ (RatFunc ℚ), v = Place.congrRingEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom) v' :=
+  ⟨(Place.congrEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom)).symm v,
+    ((Place.congrEquiv _ _).apply_symm_apply v).symm⟩
+
+theorem ord_congr_jGen_sub (b : ℚ) (v' : Place ℚ (RatFunc ℚ)) :
+    (Place.congrRingEquiv ModularCurve.jLineRingEquiv
+        (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom) v').ord
+      (ModularCurve.jGen - algebraMap ℚ ↥ℚ⟮ModularCurve.jq⟯ b)
+    = (Finsupp.single (placeOfPoint ℚ b) (1 : ℤ) + Finsupp.single (placeInfty ℚ) (-1 : ℤ)) v' := by
+  rw [← equiv_X_sub_C, Place.ord_congrRingEquiv]
+  exact ord_X_sub_C ℚ b v'
+
+theorem injective_congr : Function.Injective (Place.congrRingEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom) : Place ℚ (RatFunc ℚ) → _)
+        :=
+  (Place.congrEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom)).injective
+
+end ModularCurve.JLineOrdAux
+
+open ModularCurve.JLineOrdAux
+
+theorem solution (v : AlgebraicCurve.Place ℚ ↥ℚ⟮ModularCurve.jq⟯) :
+    v = ModularCurve.jLinePlaceZero ↔ 0 < v.ord ModularCurve.jGen := by
+  obtain ⟨v', rfl⟩ := exists_eq_congr v
+  have h := ord_congr_jGen_sub 0 v'
+  rw [map_zero, sub_zero] at h
+  rw [h]
+  have h01 := placeOfPoint_ne_placeInfty ℚ 0
+  unfold ModularCurve.jLinePlaceZero
+  constructor
+  · intro hv
+    rw [injective_congr hv]
+    simp [h01]
+  · intro hlt
+    by_contra hne
+    have hne' : v' ≠ placeOfPoint ℚ 0 := fun h' => hne (by rw [h'])
+    rcases eq_or_ne v' (placeInfty ℚ) with h0 | h0
+    · subst h0
+      simp [h01.symm] at hlt
+    · simp [hne', h0] at hlt
+
+end S_ModularCurve_eq_jLinePlaceZero_iff_ord_jGen_pos
+end P2MW
+export P2MW.S_ModularCurve_eq_jLinePlaceZero_iff_ord_jGen_pos (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open IntermediateField AlgebraicCurve
+theorem ModularCurve.eq_jLinePlaceZero_iff_ord_jGen_pos (v : AlgebraicCurve.Place ℚ
+  ↥ℚ⟮ModularCurve.jq⟯) :
+    v = ModularCurve.jLinePlaceZero ↔ 0 < v.ord ModularCurve.jGen :=
+  solution v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eq_zero_of_forall_re_periodOf_eq_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eq_zero_of_forall_re_periodOf_eq_zero.lean
new file mode 100644
index 0000000000..20b42c89f4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eq_zero_of_forall_re_periodOf_eq_zero.lean
@@ -0,0 +1,378 @@
+/-
+Based on Prove2Me node ModularCurve.eq_zero_of_forall_re_periodOf_eq_zero
+(c0a3c859-bbcf-5f52-8a95-ae640a008ab5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c3dc27b9-687d-5cf5-afd0-0b940ea0a76f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodOf
+
+import Mathlib.Analysis.Complex.AbsMax
+import Mathlib.Analysis.InnerProductSpace.OfNorm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_hasEquivariantPrimitiveOf
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_periodOf_apply_eq_sub_of_hasEquivariantPrimitiveOf
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Real periods detect vanishing of weight-2 cusp forms
+
+Theorem statement: `ModularCurve.eq_zero_of_forall_re_periodOf_eq_zero`
+(`c0a3c859-bbcf-5f52-8a95-ae640a008ab5`), by Claude, 2026-09-05.
+
+Proof: submission `c3dc27b9-687d-5cf5-afd0-0b940ea0a76f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of $\mathrm{SL}_2(\mathbb{Z})$ of finite index and let $f$ be a cusp form
+of weight $2$ on $\Gamma$, in the sense of Mathlib's `CuspForm Γ 2`. For each $\gamma \in \Gamma$
+the functional [`ModularCurve.periodOf Γ γ`](def/ModularCurve_PeriodOf.html#L56) is the
+$\mathbb{C}$-linear functional on `CuspForm Γ 2` obtained as [`ModularCurve.periodAlongOf
+Γ`](def/ModularCurve_PeriodOf.html#L42) at the pair of points $i$ and $\gamma \cdot i$ of the upper
+half-plane, namely the functional sending a weight-2 cusp form $g$ to $\int_0^1
+\mathtt{periodIntegrandOf}\,\Gamma\,i\,(\gamma\cdot i)\,g\,t \, \mathrm{d}t$, the integral over the
+unit parameter interval of the integrand attached to the path from $i$ to $\gamma \cdot i$;
+linearity in the form is part of that definition. The hypothesis is that for every $\gamma \in
+\Gamma$ the complex number [`ModularCurve.periodOf Γ γ f`](def/ModularCurve_PeriodOf.html#L56) has
+real part $0$. The conclusion is that $f = 0$ in `CuspForm Γ 2`.
+
+This is the injectivity half of the Eichler–Shimura correspondence over $\mathbb{R}$: the
+real-linear map sending a weight-2 cusp form to the real parts of its periods $\int_i^{\gamma i} f$
+along $\Gamma$ is injective, which is what makes the period lattice span the real dual of
+$S_2(\Gamma)$. It is used in the construction of the Eichler–Shimura map into the first cohomology
+of modular curves for groups $\Gamma_H$, and thence in the comparison of cusp forms with Galois
+representations and Hecke modules.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_eq_zero_of_forall_re_periodOf_eq_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_eq_zero_of_forall_re_periodOf_eq_zero
+
+open scoped MatrixGroups Real Manifold ModularForm
+open UpperHalfPlane Filter Topology Complex Function Metric
+
+namespace ModularCurve
+p2m_export "ModularCurve" "periodOf HasEquivariantPrimitiveOf period \
+  exists_hasEquivariantPrimitiveOf periodOf_apply_eq_sub_of_hasEquivariantPrimitiveOf"
+namespace PeriodRealInjectivityOf
+p2m_open "ModularCurve"
+
+open ModularCurve.Period
+
+local notation "𝕢" => Function.Periodic.qParam
+
+theorem hasDerivAt_smul_ofComplex (γ : SL(2, ℤ)) (τ : ℍ) :
+    HasDerivAt (fun z : ℂ => ((γ • ofComplex z : ℍ) : ℂ))
+      (denom (Matrix.SpecialLinearGroup.mapGL ℝ γ) ↑τ ^ (-2 : ℤ)) ↑τ := by
+  set G : GL (Fin 2) ℝ := Matrix.SpecialLinearGroup.mapGL ℝ γ with hG
+  have hdet : (G : Matrix (Fin 2) (Fin 2) ℝ).det = 1 := by
+    rw [← Matrix.GeneralLinearGroup.val_det_apply, hG, Matrix.SpecialLinearGroup.det_mapGL,
+      Units.val_one]
+  have hpos : (0:ℝ) < (G : Matrix (Fin 2) (Fin 2) ℝ).det := by rw [hdet]; norm_num
+  have h1 := (UpperHalfPlane.hasStrictDerivAt_smul hpos τ).hasDerivAt
+  have h2 : (fun z : ℂ => ((G • ofComplex z : ℍ) : ℂ))
+      = fun z : ℂ => ((γ • ofComplex z : ℍ) : ℂ) := by
+    funext z
+    rw [MulAction.compHom_smul_def]
+  rw [h2] at h1
+  convert h1 using 1
+  rw [hdet]
+  push_cast
+  rw [zpow_neg, one_div]
+  norm_cast
+
+theorem hasDerivAt_comp_smul {G : ℍ → ℂ} {g : ℍ → ℂ}
+    (hG : ∀ τ : ℍ, HasDerivAt (G ∘ ofComplex) (g τ) ↑τ) (γ : SL(2, ℤ)) (τ : ℍ) :
+    HasDerivAt (fun z : ℂ => G (γ • ofComplex z)) ((g ∣[(2:ℤ)] γ) τ) ↑τ := by
+  have hfun : (fun z : ℂ => G (γ • ofComplex z))
+      = (G ∘ ofComplex) ∘ (fun z : ℂ => ((γ • ofComplex z : ℍ) : ℂ)) := by
+    funext z
+    simp only [Function.comp_apply, ofComplex_apply]
+  have houter : HasDerivAt (G ∘ ofComplex) (g (γ • τ))
+      ((fun z : ℂ => ((γ • ofComplex z : ℍ) : ℂ)) ↑τ) := by
+    simpa only [ofComplex_apply] using hG (γ • τ)
+  have hcomp := houter.comp (↑τ : ℂ) (hasDerivAt_smul_ofComplex γ τ)
+  rw [← hfun] at hcomp
+  convert hcomp using 1
+  exact ModularForm.SL_slash_apply (g : ℍ → ℂ) γ τ
+
+theorem tendsto_vadd_atImInfty (x : ℝ) :
+    Tendsto (fun z : ℍ => x +ᵥ z) atImInfty atImInfty := by
+  simp only [atImInfty, tendsto_comap_iff, Function.comp_def]
+  exact tendsto_comap.congr fun z => (vadd_im x z).symm
+
+theorem const_eq_zero_of_tendsto_sub {α : Type*} {l : Filter α} [l.NeBot]
+    {g h : α → ℂ} {L c : ℂ} (hg : Tendsto g l (𝓝 L)) (hh : Tendsto h l (𝓝 L))
+    (hc : ∀ a, g a - h a = c) : c = 0 := by
+  have hsub : Tendsto (fun a => g a - h a) l (𝓝 (L - L)) := hg.sub hh
+  rw [sub_self] at hsub
+  exact tendsto_nhds_unique (tendsto_const_nhds.congr fun a => (hc a).symm) hsub
+
+theorem apply_smul_T_zpow_smul {Γ : Subgroup SL(2, ℤ)} {F : ℍ → ℂ}
+    (hF : IsEquivariantPrimitive Γ F) (δ : SL(2, ℤ)) {L : ℂ}
+    (hlim : Tendsto (fun w : ℍ => F (δ • w)) atImInfty (𝓝 L)) (n : ℤ)
+    (hγ : δ * ModularGroup.T ^ n * δ⁻¹ ∈ Γ) (w : ℍ) :
+    F (δ • (ModularGroup.T ^ n • w)) = F (δ • w) := by
+  have hkey : ∀ w : ℍ, (δ * ModularGroup.T ^ n * δ⁻¹ : SL(2, ℤ)) • ((δ : SL(2, ℤ)) • w)
+      = δ • (ModularGroup.T ^ n • w) := by
+    intro w
+    rw [← mul_smul, ← mul_smul]
+    congr 1
+    group
+  have hc' : ∀ w : ℍ, F (δ • (ModularGroup.T ^ n • w)) - F (δ • w) = hF.period ⟨_, hγ⟩ := by
+    intro w
+    rw [← hkey]
+    exact hF.sub_eq_period ⟨_, hγ⟩ (δ • w)
+  have hc0 : hF.period ⟨_, hγ⟩ = 0 := by
+    refine const_eq_zero_of_tendsto_sub
+      (g := fun w : ℍ => F (δ • (ModularGroup.T ^ n • w)))
+      (h := fun w : ℍ => F (δ • w)) (L := L) ?_ hlim hc'
+    have hfun : (fun w : ℍ => F (δ • (ModularGroup.T ^ n • w)))
+        = (fun w : ℍ => F (δ • w)) ∘ fun w : ℍ => ((n : ℤ) : ℝ) +ᵥ w := by
+      funext w
+      simp only [Function.comp_apply, UpperHalfPlane.modular_T_zpow_smul]
+    rw [hfun]
+    exact hlim.comp (tendsto_vadd_atImInfty ((n : ℤ) : ℝ))
+  have := hc' w
+  rwa [hc0, sub_eq_zero] at this
+
+theorem exists_conj_T_zpow_mem (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] :
+    ∃ M : ℕ, 0 < M ∧ ∀ δ : SL(2, ℤ), δ * ModularGroup.T ^ (M : ℤ) * δ⁻¹ ∈ Γ := by
+  obtain ⟨M, hM, -, hTM⟩ := Subgroup.exists_pow_mem_of_index_ne_zero
+    (Subgroup.FiniteIndex.index_ne_zero (H := Γ.normalCore)) ModularGroup.T
+  refine ⟨M, hM, fun δ => Γ.normalCore_le ?_⟩
+  rw [zpow_natCast]
+  exact Γ.normalCore_normal.conj_mem _ hTM δ
+
+section Main
+
+variable {Γ : Subgroup SL(2, ℤ)} {M : ℕ} {f : CuspForm Γ 2} {F : ℍ → ℂ}
+
+noncomputable def K (F : ℍ → ℂ) (ρ : SL(2, ℤ)) : ℍ → ℂ := fun w => cexp (F (ρ⁻¹ • w))
+
+theorem K_periodic (hF : ModularCurve.HasEquivariantPrimitiveOf Γ f F)
+    (hTM : ∀ δ : SL(2, ℤ), δ * ModularGroup.T ^ (M : ℤ) * δ⁻¹ ∈ Γ) (ρ : SL(2, ℤ)) :
+    Periodic (K F ρ ∘ ofComplex) (M : ℝ) := by
+  obtain ⟨L, hL⟩ := hF.2.2.2 ρ⁻¹
+  intro z
+  by_cases hz : 0 < z.im
+  · have hz' : 0 < (z + (M : ℝ)).im := by simpa using hz
+    simp only [Function.comp_apply, K]
+    rw [ofComplex_apply_of_im_pos hz', ofComplex_apply_of_im_pos hz]
+    have hT : (⟨z + (M : ℝ), hz'⟩ : ℍ) = ModularGroup.T ^ (M : ℤ) • (⟨z, hz⟩ : ℍ) := by
+      rw [UpperHalfPlane.modular_T_zpow_smul]
+      ext1
+      simp [UpperHalfPlane.coe_vadd, add_comm]
+    rw [hT, apply_smul_T_zpow_smul hF.2.2.1 ρ⁻¹ hL (M : ℤ) (by
+      simpa using hTM ρ⁻¹)]
+  · have hz : z.im ≤ 0 := not_lt.mp hz
+    have hz' : (z + (M : ℝ)).im ≤ 0 := by simpa using hz
+    simp only [Function.comp_apply, ofComplex_apply_eq_of_im_nonpos hz' hz]
+
+theorem K_mdifferentiable (hF : ModularCurve.HasEquivariantPrimitiveOf Γ f F) (ρ : SL(2, ℤ)) :
+    MDiff (K F ρ) := by
+  intro τ
+  rw [UpperHalfPlane.mdifferentiableAt_iff]
+  have h1 : DifferentiableAt ℂ (fun z : ℂ => F (ρ⁻¹ • ofComplex z)) ↑τ :=
+    (hasDerivAt_comp_smul hF.1 ρ⁻¹ τ).differentiableAt
+  exact h1.cexp
+
+theorem K_tendsto (hF : ModularCurve.HasEquivariantPrimitiveOf Γ f F) (ρ : SL(2, ℤ)) :
+    ∃ M : ℂ, Tendsto (K F ρ) atImInfty (𝓝 M) := by
+  obtain ⟨L, hL⟩ := hF.2.2.2 ρ⁻¹
+  exact ⟨cexp L, hL.cexp⟩
+
+theorem K_bounded (hF : ModularCurve.HasEquivariantPrimitiveOf Γ f F) (ρ : SL(2, ℤ)) :
+    IsBoundedAtImInfty (K F ρ) := by
+  obtain ⟨M, hM⟩ := K_tendsto hF ρ
+  have := hM.isBigO_one ℝ
+  exact this
+
+noncomputable def Φ (N : ℕ) (F : ℍ → ℂ) (ρ : SL(2, ℤ)) : ℂ → ℂ :=
+  UpperHalfPlane.cuspFunction (N : ℝ) (K F ρ)
+
+variable (hM : 0 < M) (hTM : ∀ δ : SL(2, ℤ), δ * ModularGroup.T ^ (M : ℤ) * δ⁻¹ ∈ Γ)
+
+include hM in
+theorem hNpos : (0 : ℝ) < (M : ℝ) := by exact_mod_cast hM
+
+include hM hTM in
+theorem Φ_differentiableOn (hF : ModularCurve.HasEquivariantPrimitiveOf Γ f F) (ρ : SL(2, ℤ)) :
+    DifferentiableOn ℂ (Φ M F ρ) (ball 0 1) :=
+  differentiableOn_cuspFunction_ball (hNpos hM) (K_periodic hF hTM ρ) (K_mdifferentiable hF ρ)
+    (K_bounded hF ρ)
+
+include hM hTM in
+theorem Φ_qParam (hF : ModularCurve.HasEquivariantPrimitiveOf Γ f F) (ρ : SL(2, ℤ)) (w : ℍ) :
+    Φ M F ρ (𝕢 (M : ℝ) ↑w) = cexp (F (ρ⁻¹ • w)) :=
+  UpperHalfPlane.eq_cuspFunction w (hNpos hM).ne' (K_periodic hF hTM ρ)
+
+theorem qParam_mem_ball (w : ℍ) : 𝕢 (M : ℝ) ↑w ∈ ball (0 : ℂ) 1 ∨ (M : ℝ) ≤ 0 := by
+  by_cases hN : (0 : ℝ) < M
+  · left
+    rw [mem_ball_zero_iff, Function.Periodic.norm_qParam]
+    have him : (0:ℝ) < Complex.im ↑w := w.2
+    calc Real.exp (-2 * π * Complex.im ↑w / M) < Real.exp 0 :=
+          Real.exp_lt_exp.mpr (by
+            apply div_neg_of_neg_of_pos _ hN
+            nlinarith [Real.pi_pos])
+      _ = 1 := Real.exp_zero
+  · right; exact not_lt.mp hN
+
+include hM in
+theorem qParam_mem_ball' (w : ℍ) : 𝕢 (M : ℝ) ↑w ∈ ball (0 : ℂ) 1 := by
+  rcases qParam_mem_ball (M := M) w with h | h
+  · exact h
+  · exact absurd (hNpos hM) (not_lt.mpr h)
+
+include hM in
+theorem qParam_mem_closedBall {w : ℍ} (hw : 1 / 2 ≤ w.im) :
+    𝕢 (M : ℝ) ↑w ∈ closedBall (0 : ℂ) (Real.exp (-π / M)) := by
+  rw [mem_closedBall_zero_iff, Function.Periodic.norm_qParam, Real.exp_le_exp,
+    UpperHalfPlane.coe_im]
+  rw [div_le_div_iff_of_pos_right (hNpos hM)]
+  nlinarith [Real.pi_pos]
+
+theorem re_apply_smul (hF : ModularCurve.HasEquivariantPrimitiveOf Γ f F)
+    (h : ∀ γ : Γ, (ModularCurve.periodOf Γ γ f).re = 0)
+    (γ : Γ) (z : ℍ) :
+    (F ((γ : SL(2, ℤ)) • z)).re = (F z).re := by
+  have h1 := hF.2.2.1.sub_eq_period γ z
+  have h2 : hF.2.2.1.period γ = ModularCurve.periodOf Γ γ f := by
+    rw [ModularCurve.periodOf_apply_eq_sub_of_hasEquivariantPrimitiveOf Γ f hF γ]
+    rfl
+  have h3 : (F ((γ : SL(2, ℤ)) • z) - F z).re = 0 := by rw [h1, h2, h γ]
+  rw [Complex.sub_re, sub_eq_zero] at h3
+  exact h3
+
+theorem norm_exp_apply_smul (hF : ModularCurve.HasEquivariantPrimitiveOf Γ f F)
+    (h : ∀ γ : Γ, (ModularCurve.periodOf Γ γ f).re = 0)
+    {γ : SL(2, ℤ)} (hγ : γ ∈ Γ) (z : ℍ) :
+    ‖cexp (F (γ • z))‖ = ‖cexp (F z)‖ := by
+  rw [Complex.norm_exp, Complex.norm_exp, ← re_apply_smul hF h ⟨γ, hγ⟩ z]
+
+include hM hTM in
+theorem exp_F_const [Γ.FiniteIndex] (hF : ModularCurve.HasEquivariantPrimitiveOf Γ f F)
+    (h : ∀ γ : Γ, (ModularCurve.periodOf Γ γ f).re = 0) :
+    ∃ c : ℂ, ∀ z : ℍ, cexp (F z) = c := by
+  classical
+  have : Fintype (SL(2, ℤ) ⧸ Γ) := Subgroup.fintypeQuotientOfFiniteIndex
+  set r : ℝ := Real.exp (-π / M) with hr
+  have hr0 : 0 ≤ r := (Real.exp_pos _).le
+  have hr1 : r < 1 := by
+    rw [hr, Real.exp_lt_one_iff]
+    exact div_neg_of_neg_of_pos (neg_lt_zero.mpr Real.pi_pos) (hNpos hM)
+  have hmax : ∀ j : SL(2, ℤ) ⧸ Γ, ∃ q ∈ closedBall (0 : ℂ) r,
+      IsMaxOn (norm ∘ Φ M F j.out) (closedBall (0 : ℂ) r) q := fun j =>
+    (isCompact_closedBall (0 : ℂ) r).exists_isMaxOn (nonempty_closedBall.mpr hr0)
+      (((Φ_differentiableOn hM hTM hF j.out).continuousOn.mono (closedBall_subset_ball hr1)).norm)
+  choose q hq hqmax using hmax
+  set m : SL(2, ℤ) ⧸ Γ → ℝ := fun j => ‖Φ M F j.out (q j)‖ with hm
+  obtain ⟨j₀, -, hj₀⟩ := Finset.exists_max_image Finset.univ m ⟨(1 : SL(2, ℤ)), Finset.mem_univ _⟩
+  set B : ℝ := m j₀ with hB
+  have hbound : ∀ z : ℍ, ‖cexp (F z)‖ ≤ B := by
+    intro z
+    obtain ⟨g, hg⟩ := ModularGroup.exists_one_half_le_im_smul z
+    obtain ⟨g0, hg0⟩ := QuotientGroup.mk_out_eq_mul Γ g
+    set j : SL(2, ℤ) ⧸ Γ := QuotientGroup.mk g with hj
+    have h1 : ‖cexp (F z)‖ = ‖Φ M F j.out (𝕢 (M : ℝ) ↑(g • z))‖ := by
+      rw [Φ_qParam hM hTM hF, hg0, mul_inv_rev, mul_smul, inv_smul_smul]
+      exact (norm_exp_apply_smul hF h (inv_mem g0.2) z).symm
+    rw [h1]
+    exact (hqmax j (qParam_mem_closedBall hM hg)).trans (hj₀ j (Finset.mem_univ _))
+  set ρ₀ : SL(2, ℤ) := j₀.out with hρ₀
+  have hΦd : DifferentiableOn ℂ (Φ M F ρ₀) (ball 0 1) := Φ_differentiableOn hM hTM hF ρ₀
+  have hnonzero : ∀ p ∈ ball (0 : ℂ) 1, p ≠ 0 → ‖Φ M F ρ₀ p‖ ≤ B := by
+    intro p hp hp0
+    have him : 0 < (Function.Periodic.invQParam (M : ℝ) p).im :=
+      Function.Periodic.im_invQParam_pos_of_norm_lt_one (hNpos hM) (mem_ball_zero_iff.mp hp) hp0
+    have : Φ M F ρ₀ p = cexp (F (ρ₀⁻¹ • ⟨_, him⟩)) := by
+      rw [Φ, UpperHalfPlane.cuspFunction, Function.Periodic.cuspFunction_eq_of_nonzero _ _ hp0,
+        Function.comp_apply, K, ofComplex_apply_of_im_pos him]
+    rw [this]
+    exact hbound _
+  have hall : ∀ p ∈ ball (0 : ℂ) 1, ‖Φ M F ρ₀ p‖ ≤ B := by
+    intro p hp
+    rcases eq_or_ne p 0 with rfl | hp0
+    · have hcont : ContinuousAt (Φ M F ρ₀) 0 :=
+        (hΦd.differentiableAt (ball_mem_nhds 0 one_pos)).continuousAt
+      have ht : Tendsto (fun p => ‖Φ M F ρ₀ p‖) (𝓝[≠] 0) (𝓝 ‖Φ M F ρ₀ 0‖) :=
+        (hcont.tendsto.mono_left nhdsWithin_le_nhds).norm
+      refine le_of_tendsto ht ?_
+      filter_upwards [self_mem_nhdsWithin,
+        mem_nhdsWithin_of_mem_nhds (ball_mem_nhds (0 : ℂ) one_pos)] with p hp0 hp1
+      exact hnonzero p hp1 hp0
+    · exact hnonzero p hp hp0
+  have hq₀ball : q j₀ ∈ ball (0 : ℂ) 1 := closedBall_subset_ball hr1 (hq j₀)
+  have hismax : IsMaxOn (norm ∘ Φ M F ρ₀) (ball 0 1) (q j₀) := by
+    intro p hp
+    exact hall p hp
+  have hconst := Complex.eq_const_of_exists_max hΦd hq₀ball hismax
+  refine ⟨Φ M F ρ₀ (q j₀), fun z => ?_⟩
+  have h1 : cexp (F z) = Φ M F ρ₀ (𝕢 (M : ℝ) ↑(ρ₀ • z)) := by
+    rw [Φ_qParam hM hTM hF, inv_smul_smul]
+  rw [h1]
+  exact hconst (qParam_mem_ball' hM _)
+
+include hM hTM in
+theorem apply_eq_zero [Γ.FiniteIndex] (hF : ModularCurve.HasEquivariantPrimitiveOf Γ f F)
+    (h : ∀ γ : Γ, (ModularCurve.periodOf Γ γ f).re = 0) (τ : ℍ) :
+    f τ = 0 := by
+  obtain ⟨c, hc⟩ := exp_F_const hM hTM hF h
+  have h1 : HasDerivAt (fun z : ℂ => cexp ((F ∘ ofComplex) z)) (cexp ((F ∘ ofComplex) ↑τ) * f τ) ↑τ
+    :=
+    (hF.1 τ).cexp
+  have h2 : HasDerivAt (fun z : ℂ => cexp ((F ∘ ofComplex) z)) 0 ↑τ := by
+    refine (hasDerivAt_const (↑τ : ℂ) c).congr_of_eventuallyEq ?_
+    filter_upwards [isOpen_upperHalfPlaneSet.mem_nhds τ.im_pos] with z hz
+    simp only [Function.comp_apply, ofComplex_apply_of_im_pos hz]
+    exact hc _
+  have h3 := h1.unique h2
+  rcases mul_eq_zero.mp h3 with h4 | h4
+  · exact absurd h4 (Complex.exp_ne_zero _)
+  · exact h4
+
+end Main
+
+theorem main (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (f : CuspForm Γ 2)
+    (h : ∀ γ : Γ, (ModularCurve.periodOf Γ γ f).re = 0) : f = 0 := by
+  obtain ⟨F, hF⟩ := ModularCurve.exists_hasEquivariantPrimitiveOf Γ f
+  obtain ⟨M, hM, hTM⟩ := exists_conj_T_zpow_mem Γ
+  exact DFunLike.ext f 0 fun τ => by simpa using apply_eq_zero hM hTM hF h τ
+
+end ModularCurve.PeriodRealInjectivityOf
+
+theorem solution (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex]
+    (f : CuspForm Γ 2)
+    (h : ∀ γ : Γ, (ModularCurve.periodOf Γ γ f).re = 0) : f = 0 :=
+  ModularCurve.PeriodRealInjectivityOf.main Γ f h
+
+end S_ModularCurve_eq_zero_of_forall_re_periodOf_eq_zero
+end P2MW
+export P2MW.S_ModularCurve_eq_zero_of_forall_re_periodOf_eq_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.eq_zero_of_forall_re_periodOf_eq_zero (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex]
+    (f : CuspForm Γ 2)
+    (h : ∀ γ : Γ, (ModularCurve.periodOf Γ γ f).re = 0) : f = 0 :=
+  solution Γ f h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_essFiniteType_modularFunctionFieldBar.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_essFiniteType_modularFunctionFieldBar.lean
new file mode 100644
index 0000000000..11aa896df8
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_essFiniteType_modularFunctionFieldBar.lean
@@ -0,0 +1,92 @@
+/-
+Based on Prove2Me node ModularCurve.essFiniteType_modularFunctionFieldBar
+(e3021cc8-b35b-5093-b091-2529a5b5388f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8c392ed2-3044-5e42-90c6-0a4bb1e002f1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ArithmeticGalois
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_adjoin_jBar_jNBar_eq_top
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Essential finite type of ℚ̄-function field of X₀(N)
+
+Theorem statement: `ModularCurve.essFiniteType_modularFunctionFieldBar`
+(`e3021cc8-b35b-5093-b091-2529a5b5388f`), by Claude, 2026-09-05.
+
+Proof: submission `8c392ed2-3044-5e42-90c6-0a4bb1e002f1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $N$ with $N \neq 0$ (as a `NeZero` instance). Inside the field of Laurent
+series $\mathbb{Q}((q))$ let `modularFunctionFieldFull N` be the intermediate field obtained by
+adjoining to $\mathbb{Q}$ the set `divisorExpansions N` of Laurent series, and let $\bar{\mathbb{Q}}
+=$ `AlgebraicClosure ℚ`. The field `modularFunctionFieldBar N` is then `laurentBaseChange` of this
+field along $\mathbb{Q} \to \bar{\mathbb{Q}}$, that is, the intermediate field of
+$\bar{\mathbb{Q}}((q))$ over $\bar{\mathbb{Q}}$ generated by the image of `modularFunctionFieldFull
+N` under the coefficientwise embedding `coeffEmb` $\colon \mathbb{Q}((q)) \to
+\bar{\mathbb{Q}}((q))$. The assertion is that this intermediate field, viewed as a
+$\bar{\mathbb{Q}}$-algebra through its coercion to a type, satisfies `Algebra.EssFiniteType` over
+$\bar{\mathbb{Q}}$: it is essentially of finite type, i.e. a localisation of a finitely generated
+$\bar{\mathbb{Q}}$-subalgebra, which for a field extension amounts to being generated as a field by
+finitely many elements over $\bar{\mathbb{Q}}$. No further hypotheses on $N$ are imposed.
+
+This records that the function field of $X_0(N)$ over an algebraically closed field of
+characteristic zero, realised concretely as a subfield of $\bar{\mathbb{Q}}((q))$ generated by
+$q$-expansions, is a finitely generated field extension of $\bar{\mathbb{Q}}$. It supplies the
+`Algebra.EssFiniteType` hypothesis required by the general curve machinery (Riemann–Roch, canonical
+divisors, places and Jacobians) whenever that machinery is applied to `modularFunctionFieldBar N`,
+and is invoked by a large number of downstream modular-curve results.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_essFiniteType_modularFunctionFieldBar.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_essFiniteType_modularFunctionFieldBar
+
+noncomputable section
+
+open ModularCurve
+
+theorem solution (N : ℕ) [NeZero N] :
+    Algebra.EssFiniteType (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar N) := by
+  refine IntermediateField.fg_top_iff.mp ?_
+  classical
+  refine ⟨{⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+    (jq_mem_full N)⟩,
+      ⟨coeffEmb (AlgebraicClosure ℚ) (qExpand ℚ N jq),
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jqd_mem_full N (dvd_refl N))⟩}, ?_⟩
+  rw [Finset.coe_insert, Finset.coe_singleton]
+  exact adjoin_jBar_jNBar_eq_top (AlgebraicClosure ℚ) N
+
+end
+end S_ModularCurve_essFiniteType_modularFunctionFieldBar
+end P2MW
+export P2MW.S_ModularCurve_essFiniteType_modularFunctionFieldBar (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.essFiniteType_modularFunctionFieldBar (N : ℕ) [NeZero N] :
+    Algebra.EssFiniteType (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar N) :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_evalAtJGen_injective.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_evalAtJGen_injective.lean
new file mode 100644
index 0000000000..ef47455bc9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_evalAtJGen_injective.lean
@@ -0,0 +1,88 @@
+/-
+Based on Prove2Me node ModularCurve.evalAtJGen_injective
+(6958382e-ee18-5cd3-bb1c-f1a25f5d4e40) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f2251c8f-27a4-5ac1-a883-ac8c888064c6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_evalAtJ_injective
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Injectivity of evaluation at the formal j-invariant
+
+Theorem statement: `ModularCurve.evalAtJGen_injective` (`6958382e-ee18-5cd3-bb1c-f1a25f5d4e40`), by
+Claude, 2026-09-05.
+
+Proof: submission `f2251c8f-27a4-5ac1-a883-ac8c888064c6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Work inside the field of Laurent series $\mathbb{Q}((q))$ (formally, `LaurentSeries ℚ`, Hahn series
+over $\mathbb{Q}$ with value group $\mathbb{Z}$). Let `jNumQ` be the power series over $\mathbb{Q}$
+obtained from the integral power series `jNum` by applying the canonical ring homomorphism
+$\mathbb{Z} \to \mathbb{Q}$ coefficientwise, and let `jq` be the Laurent series $q^{-1} \cdot
+\mathrm{jNumQ}$, that is, the product of the Hahn series `single (-1) 1` with the image of `jNumQ`
+in $\mathbb{Q}((q))$. Let $\mathbb{Q}\langle\!\langle \mathrm{jq}\rangle\!\rangle =$ `ℚ⟮jq⟯` be the
+intermediate field of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by `jq`, and let `jGen` denote
+`jq` regarded as an element of that field. The ring homomorphism `evalAtJGen : Polynomial ℤ →+*
+ℚ⟮jq⟯` is evaluation at `jGen` of integral polynomials, the coefficients being transported by the
+canonical map $\mathbb{Z} \to$ `ℚ⟮jq⟯`. The assertion is that this homomorphism is injective:
+distinct polynomials in $\mathbb{Z}[X]$ have distinct values at `jGen`. Equivalently, `jq` is
+transcendental over $\mathbb{Q}$ as far as integral polynomials are concerned: no nonzero $p \in
+\mathbb{Z}[X]$ satisfies $p(\mathrm{jq}) = 0$ in $\mathbb{Q}((q))$.
+
+This is the formal-Laurent-series form of the transcendence of the $j$-invariant over $\mathbb{Q}$,
+packaged so that $\mathbb{Z}[X]$ may be identified with the subring $\mathbb{Z}[\mathrm{jq}]$ of
+`ℚ⟮jq⟯`. It is used in the uniqueness and existence statements for modular polynomial data,
+[`ModularCurve.modularPolynomialData_phi_unique_of_prime`]
+(thm.html#ModularCurve.modularPolynomialData_phi_unique_of_prime)
+and
+[`ModularCurve.nonempty_modularPolynomialData`]
+(thm.html#ModularCurve.nonempty_modularPolynomialData),
+where two polynomials over $\mathbb{Z}[X]$ with equal images must be shown to coincide.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_evalAtJGen_injective.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_evalAtJGen_injective
+
+open ModularCurve IntermediateField
+
+theorem solution :
+    Function.Injective (ModularCurve.evalAtJGen : Polynomial ℤ →+* ↥ℚ⟮ModularCurve.jq⟯) := by
+  intro a b hab
+  apply ModularCurve.PhiGen.evalAtJ_injective
+  rw [← ModularCurve.algebraMap_comp_evalAtJGen, RingHom.comp_apply, RingHom.comp_apply, hab]
+
+end S_ModularCurve_evalAtJGen_injective
+end P2MW
+export P2MW.S_ModularCurve_evalAtJGen_injective (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve IntermediateField
+theorem ModularCurve.evalAtJGen_injective :
+    Function.Injective (ModularCurve.evalAtJGen : Polynomial ℤ →+* ↥ℚ⟮ModularCurve.jq⟯) :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_even_ord_add_ord_of_not_mem_toValuationSubring_laurentBaseChange_gamma1.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_even_ord_add_ord_of_not_mem_toValuationSubring_laurentBaseChange_gamma1.lean
new file mode 100644
index 0000000000..cc216d6dbc
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_even_ord_add_ord_of_not_mem_toValuationSubring_laurentBaseChange_gamma1.lean
@@ -0,0 +1,520 @@
+/-
+Based on Prove2Me node
+ModularCurve.even_ord_add_ord_of_not_mem_toValuationSubring_laurentBaseChange_gamma1
+(46da1d66-da83-5463-9f0e-23c8a08ce13e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c95ac902-5dea-5aae-a692-9822ca1adf02
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QExpansionDiff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0ModL
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_tendsto_realizeOf_mul_exp_of_not_mem_toValuationSubring
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_realizeOf_eq_div
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_thetaL_coeffMap_eq_coeffMap_single_mul_derivative
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_coe_eq_of_levelOne
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_tendsto_slash_div_qParam_pow_of_conj_T_pow_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_omegaRow_T2
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Even parity of ord_P v+ord_P y at cusp places
+
+Theorem statement:
+`ModularCurve.even_ord_add_ord_of_not_mem_toValuationSubring_laurentBaseChange_gamma1`
+(`46da1d66-da83-5463-9f0e-23c8a08ce13e`), by Claude, 2026-09-05.
+
+Proof: submission `c95ac902-5dea-5aae-a692-9822ca1adf02`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $M$ with $M \neq 0$ and $5 \le M$, and let $F$ denote the intermediate field of
+$\mathbb{C}((q))$ over $\mathbb{C}$ obtained as [`ModularCurve.laurentBaseChange ℂ
+(ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1
+M))`](def/ModularCurve_LaurentCoeff.html#L103), i.e. the field generated over $\mathbb{C}$ by the
+coefficientwise images under $\mathbb{Q} \to \mathbb{C}$ of the elements of the subfield of
+$\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by the quotients
+$\mathrm{intSeriesC}\,p_f/\mathrm{intSeriesC}\,p_g$ of integral $q$-expansions of two modular forms
+of the same weight on $\Gamma_1(M)$ (with the denominator nonzero). Let $y \in F$ have underlying
+Laurent series [`ModularCurve.jqModC ℂ`](def/ModularCurve_JqCoeff.html#L15), namely $q^{-1}$ times
+the power series $E_4^3 \cdot \eta^{-\text{unit}}$ (the series `jNum`) with coefficients pushed to
+$\mathbb{C}$. Let $w$ be a nonzero modular form of weight $1$ on $\Gamma_1(M)$, and let $v \in F$
+satisfy, as an identity of Laurent series over $\mathbb{C}$, $v \cdot \vartheta(j) =
+(\text{$q$-expansion of $w$})^2$, where $\vartheta$ is the operator
+[`ModularCurve.thetaL`](def/ModularCurve_QExpansionDiff.html#L16) sending $f$ to $q \cdot f'$. Let
+$P$ be a place of $F$ over $\mathbb{C}$ in the sense of
+[`AlgebraicCurve.Place`](def/AlgebraicCurve_DivisorClassGroup.html#L22): a valuation subring of $F$
+containing $\mathbb{C}$, not equal to all of $F$, and a principal ideal ring. Assume $y$ does not
+lie in that valuation subring. Then $\operatorname{ord}_P v + \operatorname{ord}_P y$ is even, where
+$\operatorname{ord}_P$ is minus the logarithm of the associated height-one-spectrum valuation.
+
+The condition $y \notin \mathcal{O}_P$ singles out the cusp places of the function field of
+$X_1(M)$, where $j$ has a pole; the assertion is the parity statement reflecting that for $M \ge 5$
+all cusps of $\Gamma_1(M)$ are regular, so that a weight-one form has integral order at each cusp.
+It is the cusp half of the parity input to
+[`ModularCurve.exists_divisor_two_mul_eq_ord_add_weightFloor_one_laurentBaseChange_gamma1`]
+(thm.html#ModularCurve.exists_divisor_two_mul_eq_ord_add_weightFloor_one_laurentBaseChange_gamma1),
+which expresses the relevant divisor as twice a divisor.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_even_ord_add_ord_of_not_mem_toValuationSubring_laurentBaseChange_gamma1.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_a7405910
+
+
+open CongruenceSubgroup ModularCurve UpperHalfPlane HahnSeries Filter Topology
+open scoped MatrixGroups ModularForm
+
+noncomputable section
+
+namespace PresVAux
+
+theorem one_mem_strictPeriods_gamma1 (M : ℕ) :
+    (1 : ℝ) ∈ (Subgroup.map (Matrix.SpecialLinearGroup.mapGL ℝ) (CongruenceSubgroup.Gamma1
+      M)).strictPeriods := by
+  rw [CongruenceSubgroup.strictPeriods_Gamma1]
+  exact AddSubgroup.mem_zmultiples 1
+
+theorem jqModC_complex_eq : jqModC ℂ = coeffEmb ℂ jq := by
+  rw [coeffEmb, ← jqModC_rat, coeffMap_jqModC]
+
+theorem thetaL_coeffEmb_jq :
+    thetaL ℂ (coeffEmb ℂ jq) = coeffMap (algebraMap ℚ ℂ) (thetaL ℚ jq) := by
+  rw [coeffEmb, ModularCurve.thetaL_coeffMap_eq_coeffMap_single_mul_derivative]
+  rfl
+
+theorem thetaL_jqModC_mul_discriminant :
+    thetaL ℂ (jqModC ℂ) * ofPowerSeries ℤ ℂ (qExpansion 1 ModularForm.discriminant) =
+      -(ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) ^ 2 *
+        ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ))) := by
+  rw [jqModC_complex_eq, thetaL_coeffEmb_jq]
+  exact omegaRow_T2
+
+theorem exists_presentation (M : ℕ) (w : ModularForm (Gamma1 M) 1) (hw : w ≠ 0)
+    (V : LaurentSeries ℂ)
+    (hv : V * thetaL ℂ (jqModC ℂ) = ofPowerSeries ℤ ℂ (qExpansion 1 w) ^ 2) :
+    ∃ (Gv Hh : ModularForm (Gamma1 M) 14), Hh ≠ 0 ∧
+      ((Hh : ℍ → ℂ) = fun z => ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) ∧
+      ((Gv : ℍ → ℂ) = fun z => -(w z ^ 2 * ModularForm.discriminant z)) ∧
+      V * ((qExpansion 1 (Hh : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+        ((qExpansion 1 (Gv : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) := by
+  have h1 := one_mem_strictPeriods_gamma1 M
+  obtain ⟨E4N, hE4⟩ :=
+    ModularForm.exists_coe_eq_of_levelOne (CongruenceSubgroup.Gamma1 M) ModularForm.E₄
+  obtain ⟨E6N, hE6⟩ :=
+    ModularForm.exists_coe_eq_of_levelOne (CongruenceSubgroup.Gamma1 M) ModularForm.E₆
+  obtain ⟨DN, hD⟩ := ModularForm.exists_coe_eq_of_levelOne (CongruenceSubgroup.Gamma1 M)
+    (ModularFormClass.modularForm (CuspForm.discriminant))
+  have hDcoe : (DN : ℍ → ℂ) = ModularForm.discriminant := by
+    rw [hD]
+    funext z
+    rw [← CuspForm.toModularFormₗ_eq_coe, CuspForm.toModularFormₗ_apply]
+    rfl
+  obtain ⟨Hh, hHhdef⟩ : ∃ Hh : ModularForm (Gamma1 M) 14, Hh = ModularForm.mcast (by
+    norm_num) ((E4N.mul E4N).mul E6N) :=
+    ⟨_, rfl⟩
+  obtain ⟨Gv, hGvdef⟩ : ∃ Gv : ModularForm (Gamma1 M) 14, Gv = ModularForm.mcast (by
+    norm_num) (-((w.mul w).mul DN)) :=
+    ⟨_, rfl⟩
+  have hHhcoe : (Hh : ℍ → ℂ) = fun z => ModularForm.E₄ z ^ 2 * ModularForm.E₆ z := by
+    funext z; simp only [hHhdef, ModularForm.coe_mcast, ModularForm.coe_mul, Pi.mul_apply, hE4,
+      hE6]; ring
+  have hGvcoe : (Gv : ℍ → ℂ) = fun z => -(w z ^ 2 * ModularForm.discriminant z) := by
+    funext z
+    simp only [hGvdef, ModularForm.coe_mcast, FunLike.coe_neg, ModularForm.coe_mul, Pi.neg_apply,
+      Pi.mul_apply, hDcoe]
+    ring
+  have hqE4 : qExpansion 1 (E4N : ℍ → ℂ) = qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) := by rw [hE4]
+  have hqE6 : qExpansion 1 (E6N : ℍ → ℂ) = qExpansion 1 (ModularForm.E₆ : ℍ → ℂ) := by rw [hE6]
+  have hqD : qExpansion 1 (DN : ℍ → ℂ) = qExpansion 1 ModularForm.discriminant := by rw [hDcoe]
+  have hqHh : qExpansion 1 (Hh : ℍ → ℂ) =
+      qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) ^ 2 * qExpansion 1 (ModularForm.E₆ : ℍ → ℂ) := by
+    rw [hHhdef, ModularForm.qExpansion_mcast, ModularForm.qExpansion_mul one_pos h1,
+      ModularForm.qExpansion_mul one_pos h1, hqE4, hqE6]; ring
+  have hqGv : qExpansion 1 (Gv : ℍ → ℂ) = -(qExpansion 1 (w : ℍ → ℂ) ^ 2 * qExpansion 1
+    ModularForm.discriminant) :=
+    by
+    rw [hGvdef, ModularForm.qExpansion_mcast, FunLike.coe_neg, ModularForm.qExpansion_neg one_pos
+      h1,
+      ModularForm.qExpansion_mul one_pos h1, ModularForm.qExpansion_mul one_pos h1, hqD]; ring
+  have hT2 := thetaL_jqModC_mul_discriminant
+  have hDN0 : DN ≠ 0 := by
+    intro h0
+    have hI : (DN : ℍ → ℂ) UpperHalfPlane.I = 0 := by rw [h0]; rfl
+    rw [hDcoe] at hI
+    exact ModularForm.discriminant_ne_zero _ hI
+  have hDq : ofPowerSeries ℤ ℂ (qExpansion 1 ModularForm.discriminant) ≠ 0 := by
+    intro h0
+    apply hDN0
+    have h0' : qExpansion 1 (DN : ℍ → ℂ) = 0 :=
+      HahnSeries.ofPowerSeries_injective (by rw [hqD, h0, map_zero])
+    exact (ModularForm.qExpansion_eq_zero_iff one_pos h1 DN).mp h0'
+  have hW0 : ofPowerSeries ℤ ℂ (qExpansion 1 (w : ℍ → ℂ)) ≠ 0 := by
+    intro h0
+    apply hw
+    have h0' : qExpansion 1 (w : ℍ → ℂ) = 0 :=
+      HahnSeries.ofPowerSeries_injective (by rw [h0, map_zero])
+    exact (ModularForm.qExpansion_eq_zero_iff one_pos h1 w).mp h0'
+  have hHh0 : Hh ≠ 0 := by
+    intro h0
+    have hq0 : ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) ^ 2 *
+        ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) = 0 := by
+      have : qExpansion 1 (Hh : ℍ → ℂ) = 0 :=
+        (ModularForm.qExpansion_eq_zero_iff one_pos h1 Hh).mpr h0
+      rw [hqHh] at this
+      have := congrArg (ofPowerSeries ℤ ℂ) this
+      rwa [map_mul, map_pow, map_zero] at this
+    have hT0 : thetaL ℂ (jqModC ℂ) = 0 := by
+      have := hT2
+      rw [hq0, neg_zero] at this
+      exact (mul_eq_zero.mp this).resolve_right hDq
+    apply hW0
+    have := hv
+    rw [hT0, mul_zero] at this
+    exact pow_eq_zero_iff two_ne_zero |>.mp this.symm
+  refine ⟨Gv, Hh, hHh0, hHhcoe, hGvcoe, ?_⟩
+  rw [hqHh, hqGv, PowerSeries.coe_neg, PowerSeries.coe_mul, PowerSeries.coe_mul,
+    PowerSeries.coe_pow, PowerSeries.coe_pow]
+  linear_combination V * hT2 - ofPowerSeries ℤ ℂ (qExpansion 1 ModularForm.discriminant) * hv
+
+theorem realizeOf_eq (M : ℕ) (w : ModularForm (Gamma1 M) 1) (hw : w ≠ 0) (V : LaurentSeries ℂ)
+    (hv : V * thetaL ℂ (jqModC ℂ) = ofPowerSeries ℤ ℂ (qExpansion 1 w) ^ 2)
+    (z : ℍ) (hz : ModularForm.E₄ z ^ 2 * ModularForm.E₆ z ≠ 0) :
+    ModularCurve.realizeOf (CongruenceSubgroup.Gamma1 M) V z =
+      -(w z ^ 2 * ModularForm.discriminant z) / (ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) := by
+  have hT : ModularGroup.T ∈ CongruenceSubgroup.Gamma1 M := by
+    rw [CongruenceSubgroup.Gamma1_mem]; simp [ModularGroup.T]
+  obtain ⟨Gv, Hh, -, hHhcoe, hGvcoe, hpres⟩ := exists_presentation M w hw V hv
+  rw [ModularCurve.realizeOf_eq_div (CongruenceSubgroup.Gamma1 M) hT Gv Hh _ hpres z (by
+    rw [hHhcoe]; exact hz),
+    hGvcoe, hHhcoe]
+
+end PresVAux
+
+namespace L2Asm
+
+def pmGamma1 (M : ℕ) : Subgroup SL(2, ℤ) where
+  carrier := {g | g ∈ CongruenceSubgroup.Gamma1 M ∨ -g ∈ CongruenceSubgroup.Gamma1 M}
+  one_mem' := Or.inl (one_mem _)
+  mul_mem' := by
+    rintro a b (ha | ha) (hb | hb)
+    · exact Or.inl (mul_mem ha hb)
+    · exact Or.inr (by rw [← mul_neg]; exact mul_mem ha hb)
+    · exact Or.inr (by rw [← neg_mul]; exact mul_mem ha hb)
+    · exact Or.inl (by rw [← neg_mul_neg]; exact mul_mem ha hb)
+  inv_mem' := by
+    rintro a (ha | ha)
+    · exact Or.inl (inv_mem ha)
+    · refine Or.inr ?_
+      have h : (-a)⁻¹ = -a⁻¹ := inv_eq_of_mul_eq_one_right (by rw [neg_mul_neg, mul_inv_cancel])
+      rw [← h]; exact inv_mem ha
+
+theorem sup_le_pmGamma1 (M : ℕ) :
+    CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) ≤ pmGamma1 M :=
+  sup_le (fun _ hg => Or.inl hg)
+    (Subgroup.zpowers_le.2 (Or.inr (by rw [neg_neg]; exact one_mem _)))
+
+theorem trace_conj_T_zpow (σ : SL(2, ℤ)) (h : ℤ) :
+    ((σ * ModularGroup.T ^ h * σ⁻¹ : SL(2, ℤ)) 0 0 : ℤ) + (σ * ModularGroup.T ^ h * σ⁻¹ : SL(2, ℤ))
+      1 1 = 2 := by
+  have h1 : Matrix.trace ((σ * ModularGroup.T ^ h * σ⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) =
+      Matrix.trace ((ModularGroup.T ^ h : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) := by
+    rw [Matrix.SpecialLinearGroup.coe_mul, Matrix.SpecialLinearGroup.coe_mul, Matrix.mul_assoc,
+      Matrix.trace_mul_comm, Matrix.mul_assoc, ← Matrix.SpecialLinearGroup.coe_mul, inv_mul_cancel,
+      Matrix.SpecialLinearGroup.coe_one, Matrix.mul_one]
+  have h2 : ((ModularGroup.T ^ h : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) = !![1, h; 0, 1] :=
+    ModularGroup.coe_T_zpow h
+  rw [Matrix.trace_fin_two, Matrix.trace_fin_two] at h1
+  rw [h2] at h1
+  simpa using h1
+
+theorem conj_T_zpow_mem_Gamma1 (M : ℕ) (hM : ¬ M ∣ 4)
+    (σ : SL(2, ℤ)) (h : ℤ) (hmem : σ * ModularGroup.T ^ h * σ⁻¹ ∈ CongruenceSubgroup.Gamma1 M ⊔
+      Subgroup.zpowers (-1 : SL(2, ℤ))) :
+    σ * ModularGroup.T ^ h * σ⁻¹ ∈ CongruenceSubgroup.Gamma1 M := by
+  rcases (sup_le_pmGamma1 M hmem) with hg | hg
+  · exact hg
+  · exfalso
+    apply hM
+    set g : SL(2, ℤ) := σ * ModularGroup.T ^ h * σ⁻¹ with hgdef
+    have htr : (g 0 0 : ℤ) + g 1 1 = 2 := trace_conj_T_zpow σ h
+    have hneg := (CongruenceSubgroup.Gamma1_mem M (-g)).1 hg
+    have e00 : ((-g : SL(2, ℤ)) 0 0 : ℤ) = -(g 0 0) := by simp [Matrix.SpecialLinearGroup.coe_neg]
+    have e11 : ((-g : SL(2, ℤ)) 1 1 : ℤ) = -(g 1 1) := by simp [Matrix.SpecialLinearGroup.coe_neg]
+    have h00 : (((-(g 0 0) : ℤ)) : ZMod M) = 1 := by rw [← e00]; exact hneg.1
+    have h11 : (((-(g 1 1) : ℤ)) : ZMod M) = 1 := by rw [← e11]; exact hneg.2.1
+    have h2 : (((-2 : ℤ)) : ZMod M) = ((2 : ℤ) : ZMod M) := by
+      have : (((-(g 0 0 + g 1 1) : ℤ)) : ZMod M) = 2 := by
+        push_cast at h00 h11 ⊢
+        linear_combination h00 + h11
+      rw [htr] at this
+      exact_mod_cast this
+    have h3 := ((ZMod.intCast_eq_intCast_iff (-2) 2 M).1 h2).dvd
+    norm_num at h3
+    exact_mod_cast h3
+
+theorem qParam_pow_self (h : ℕ) (hh : 0 < h) (z : ℂ) :
+    Function.Periodic.qParam (h : ℝ) z ^ h = Function.Periodic.qParam 1 z := by
+  simp only [Function.Periodic.qParam, ← Complex.exp_nat_mul, Complex.ofReal_natCast,
+    Complex.ofReal_one, div_one]
+  congr 1
+  have : (h : ℂ) ≠ 0 := by exact_mod_cast hh.ne'
+  field_simp
+
+theorem tendsto_atImInfty_levelOne {k : ℤ} (F : ModularForm 𝒮ℒ k) :
+    Tendsto (fun τ : ℍ => F τ) atImInfty (𝓝 ((qExpansion 1 (F : ℍ → ℂ)).coeff 0)) := by
+  have h1 : (1 : ℝ) ∈ (𝒮ℒ : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+    rw [Subgroup.strictPeriods_SL2Z]
+    exact AddSubgroup.mem_zmultiples 1
+  have hper := SlashInvariantFormClass.periodic_comp_ofComplex F h1
+  have han := ModularFormClass.analyticAt_cuspFunction_zero F one_pos h1
+  rw [UpperHalfPlane.qExpansion_coeff_zero one_pos han hper, ←
+    UpperHalfPlane.cuspFunction_apply_zero one_pos han hper]
+  have : (fun τ : ℍ => F τ) = (cuspFunction 1 F ∘ fun τ : ℍ => Function.Periodic.qParam 1 (τ : ℂ))
+    :=
+    by
+    funext τ; simp [UpperHalfPlane.eq_cuspFunction τ one_ne_zero hper]
+  rw [this]
+  exact han.continuousAt.tendsto.comp (UpperHalfPlane.qParam_tendsto_atImInfty one_pos)
+
+theorem tendsto_E₄_atImInfty : Tendsto (fun τ : ℍ => ModularForm.E₄ τ) atImInfty (𝓝 1) := by
+  have := tendsto_atImInfty_levelOne ModularForm.E₄
+  rwa [show (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)).coeff 0 = 1 from
+    EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) (by decide)] at this
+
+theorem tendsto_E₆_atImInfty : Tendsto (fun τ : ℍ => ModularForm.E₆ τ) atImInfty (𝓝 1) := by
+  have := tendsto_atImInfty_levelOne ModularForm.E₆
+  rwa [show (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)).coeff 0 = 1 from
+    EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) (by decide)] at this
+
+theorem tendsto_discriminant_div_qParam_atImInfty :
+    Tendsto (fun τ : ℍ => ModularForm.discriminant τ / Function.Periodic.qParam 1 (τ : ℂ)) atImInfty
+      (𝓝 1) := by
+  refine (ModularForm.tendsto_atImInfty_tprod_one_sub_eta_q_pow).congr fun τ => ?_
+  have hq : Function.Periodic.qParam 1 (τ : ℂ) ≠ 0 := Complex.exp_ne_zero _
+  rw [eq_div_iff hq, ModularForm.discriminant_eq_q_prod τ, mul_comm]
+
+theorem tendsto_qParam_pow_atImInfty {h : ℝ} (hh : 0 < h) {m : ℕ} (hm : m ≠ 0) :
+    Tendsto (fun τ : ℍ => Function.Periodic.qParam h (τ : ℂ) ^ m) atImInfty (𝓝 0) := by
+  simpa [zero_pow hm] using (UpperHalfPlane.qParam_tendsto_atImInfty hh).pow m
+
+theorem zpow_readout_unique {h : ℝ} (hh : 0 < h) (g : ℍ → ℂ) {a b : ℤ} {L L' : ℂ}
+    (ha : Tendsto (fun τ : ℍ => g τ / Function.Periodic.qParam h (τ : ℂ) ^ a) atImInfty (𝓝 L))
+    (hL : L ≠ 0)
+    (hb : Tendsto (fun τ : ℍ => g τ / Function.Periodic.qParam h (τ : ℂ) ^ b) atImInfty (𝓝 L'))
+    (hL' : L' ≠ 0) :
+    a = b := by
+  have hq : ∀ τ : ℍ, Function.Periodic.qParam h (τ : ℂ) ≠ 0 := fun τ => Complex.exp_ne_zero _
+  have hev : ∀ᶠ τ : ℍ in atImInfty, g τ ≠ 0 := by
+    have := ha.eventually_ne hL
+    filter_upwards [this] with τ hτ
+    intro h0; apply hτ; simp [h0]
+  have hquot : Tendsto (fun τ : ℍ => Function.Periodic.qParam h (τ : ℂ) ^ (a - b)) atImInfty (𝓝 (L'
+    / L)) :=
+    by
+    refine (hb.div ha hL).congr' ?_
+    filter_upwards [hev] with τ hτ
+    simp only [Pi.div_apply]
+    rw [zpow_sub₀ (hq τ)]
+    field_simp
+  rcases lt_trichotomy (a - b) 0 with hlt | heq | hgt
+  · exfalso
+    obtain ⟨m, hm⟩ : ∃ m : ℕ, (b - a : ℤ) = m :=
+      ⟨(b - a).toNat, (Int.toNat_of_nonneg (by omega)).symm⟩
+    have hm0 : m ≠ 0 := by intro h0; rw [h0] at hm; omega
+    have h0 := tendsto_qParam_pow_atImInfty hh hm0
+    have hinv : Tendsto (fun τ : ℍ => (Function.Periodic.qParam h (τ : ℂ) ^ (a - b))⁻¹) atImInfty (𝓝
+      0) :=
+      by
+      refine h0.congr fun τ => ?_
+      rw [← zpow_natCast, ← hm, ← zpow_neg, neg_sub]
+    have := tendsto_nhds_unique (hquot.inv₀ (div_ne_zero hL' hL)) hinv
+    exact (div_ne_zero hL' hL) (inv_eq_zero.mp this)
+  · omega
+  · exfalso
+    obtain ⟨m, hm⟩ : ∃ m : ℕ, (a - b : ℤ) = m := ⟨(a - b).toNat, (Int.toNat_of_nonneg hgt.le).symm⟩
+    have hm0 : m ≠ 0 := by intro h0; rw [h0] at hm; omega
+    have h0 := tendsto_qParam_pow_atImInfty hh hm0
+    have h0' : Tendsto (fun τ : ℍ => Function.Periodic.qParam h (τ : ℂ) ^ (a - b)) atImInfty (𝓝 0)
+      :=
+      by
+      refine h0.congr fun τ => ?_
+      rw [← zpow_natCast, ← hm]
+    have := tendsto_nhds_unique hquot h0'
+    exact (div_ne_zero hL' hL) this
+
+theorem levelOne_smul {k : ℤ} {FF : Type*} [FunLike FF ℍ ℂ] [SlashInvariantFormClass FF 𝒮ℒ k]
+    (F : FF)
+    (σ : SL(2, ℤ)) (τ : ℍ) :
+    F (σ • τ) = denom (σ : GL (Fin 2) ℝ) τ ^ k * F τ := by
+  have hmem : (σ : GL (Fin 2) ℝ) ∈ (𝒮ℒ : Subgroup (GL (Fin 2) ℝ)) := ⟨σ, rfl⟩
+  have := SlashInvariantForm.slash_action_eqn'' F hmem τ
+  rwa [show (σ : GL (Fin 2) ℝ) • τ = σ • τ from rfl] at this
+
+theorem cexp_readout_eq (h : ℕ) (a : ℤ) (τ : ℍ) :
+    Complex.exp (-(2 * Real.pi * Complex.I * (a : ℂ) * (τ : ℂ) / (h : ℂ))) =
+      (Function.Periodic.qParam (h : ℝ) (τ : ℂ) ^ a)⁻¹ := by
+  rw [Function.Periodic.qParam, ← Complex.exp_int_mul, ← Complex.exp_neg, Complex.ofReal_natCast]
+  congr 1
+  ring
+
+end L2Asm
+
+open L2Asm in
+theorem solution
+    (M : ℕ) [NeZero M] (hM : 5 ≤ M)
+    (y : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))))
+    (hy : (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ)
+    (w : ModularForm (Gamma1 M) 1) (hw : w ≠ 0)
+    (v : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))))
+    (hv : (v : LaurentSeries ℂ) * ModularCurve.thetaL ℂ (ModularCurve.jqModC ℂ) =
+      HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 w) ^ 2)
+    (P : AlgebraicCurve.Place ℂ
+        ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+          (CongruenceSubgroup.Gamma1 M))))
+    (hP : y ∉ P.toValuationSubring) :
+    Even (P.ord v + P.ord y) := by
+  classical
+  have : (CongruenceSubgroup.Gamma1 M).FiniteIndex := inferInstance
+  have hT : ModularGroup.T ∈ CongruenceSubgroup.Gamma1 M := by
+    rw [CongruenceSubgroup.Gamma1_mem]; simp [ModularGroup.T]
+  have hΓ := CongruenceSubgroup.Gamma1_is_congruence M
+  have hM4 : ¬ M ∣ 4 := fun h => by have := Nat.le_of_dvd (by norm_num) h; omega
+  have hdeg : Module.finrank
+      ↥(IntermediateField.adjoin ℂ ({y} : Set ↥(ModularCurve.laurentBaseChange ℂ
+        (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))))
+      ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+        (CongruenceSubgroup.Gamma1 M))) =
+      (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index :=
+    ModularCurve.finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index ℂ M y hy
+  obtain ⟨σ, h, hh, hmem, hordy, hread⟩ :=
+    ModularCurve.exists_tendsto_realizeOf_mul_exp_of_not_mem_toValuationSubring
+      (CongruenceSubgroup.Gamma1 M) hT hΓ
+      (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)) rfl y hy hdeg P hP
+  have hper : σ * ModularGroup.T ^ h * σ⁻¹ ∈ CongruenceSubgroup.Gamma1 M := by
+    have := conj_T_zpow_mem_Gamma1 M hM4 σ (h : ℤ) (by rwa [zpow_natCast])
+    rwa [zpow_natCast] at this
+  obtain ⟨n, a, ha, hwlim⟩ :=
+    ModularForm.exists_tendsto_slash_div_qParam_pow_of_conj_T_pow_mem (CongruenceSubgroup.Gamma1 M)
+      1 w hw σ h hh hper
+  have h1 := PresVAux.one_mem_strictPeriods_gamma1 M
+  have hv0 : v ≠ 0 := by
+    intro h0
+    apply hw
+    have hq : ofPowerSeries ℤ ℂ (qExpansion 1 (w : ℍ → ℂ)) ^ 2 = 0 := by rw [← hv, h0]; simp
+    have hq' : qExpansion 1 (w : ℍ → ℂ) = 0 :=
+      HahnSeries.ofPowerSeries_injective (by rw [pow_eq_zero_iff two_ne_zero |>.mp hq, map_zero])
+    exact (ModularForm.qExpansion_eq_zero_iff one_pos h1 w).mp hq'
+  obtain ⟨L, hL, hvlimE⟩ := hread v hv0
+  have hvlim : Tendsto (fun τ : ℍ => ModularCurve.realizeOf (CongruenceSubgroup.Gamma1 M) (v :
+    LaurentSeries ℂ) (σ • τ) /
+      Function.Periodic.qParam (h : ℝ) (τ : ℂ) ^ (P.ord v)) atImInfty (𝓝 L) := by
+    refine hvlimE.congr fun τ => ?_
+    rw [cexp_readout_eq h, div_eq_mul_inv]
+  have hhr : (0 : ℝ) < (h : ℝ) := by exact_mod_cast hh
+  have hev : ∀ᶠ τ : ℍ in atImInfty, ModularForm.E₄ τ ≠ 0 ∧ ModularForm.E₆ τ ≠ 0 :=
+    (tendsto_E₄_atImInfty.eventually_ne one_ne_zero).and (tendsto_E₆_atImInfty.eventually_ne
+      one_ne_zero)
+  have hvlim' : Tendsto (fun τ : ℍ => ModularCurve.realizeOf (CongruenceSubgroup.Gamma1 M) (v :
+    LaurentSeries ℂ) (σ • τ) /
+        Function.Periodic.qParam (h : ℝ) (τ : ℂ) ^ (((2 * n + h : ℕ)) : ℤ)) atImInfty (𝓝 (-(a ^ 2)))
+          := by
+    have key : ∀ τ : ℍ, ModularForm.E₄ τ ≠ 0 → ModularForm.E₆ τ ≠ 0 →
+        ModularCurve.realizeOf (CongruenceSubgroup.Gamma1 M) (v : LaurentSeries ℂ) (σ • τ) /
+          Function.Periodic.qParam (h : ℝ) (τ : ℂ) ^ (((2 * n + h : ℕ)) : ℤ) =
+        -((((w : ℍ → ℂ) ∣[(1 : ℤ)] (σ : GL (Fin 2) ℝ)) τ / Function.Periodic.qParam (h : ℝ) (τ : ℂ)
+          ^ n) ^ 2 *
+          (ModularForm.discriminant τ / Function.Periodic.qParam 1 (τ : ℂ)) /
+          (ModularForm.E₄ τ ^ 2 * ModularForm.E₆ τ)) := by
+      intro τ h4 h6
+      have hd : denom (σ : GL (Fin 2) ℝ) τ ≠ 0 := UpperHalfPlane.denom_ne_zero _ τ
+      have hq : Function.Periodic.qParam (h : ℝ) (τ : ℂ) ≠ 0 := Complex.exp_ne_zero _
+      have hq1 : Function.Periodic.qParam 1 (τ : ℂ) ≠ 0 := Complex.exp_ne_zero _
+      have hE4 := levelOne_smul ModularForm.E₄ σ τ
+      have hE6 := levelOne_smul ModularForm.E₆ σ τ
+      have hD : ModularForm.discriminant (σ • τ) = denom (σ : GL (Fin 2) ℝ) τ ^ (12 : ℤ) *
+        ModularForm.discriminant τ :=
+        levelOne_smul CuspForm.discriminant σ τ
+      have hw' : (w : ℍ → ℂ) (σ • τ) = ((w : ℍ → ℂ) ∣[(1 : ℤ)] (σ : GL (Fin 2) ℝ)) τ * denom (σ : GL
+        (Fin 2) ℝ) τ :=
+        by
+        rw [← ModularForm.SL_slash, ModularForm.SL_slash_apply]
+        field_simp
+      have hz : ModularForm.E₄ (σ • τ) ^ 2 * ModularForm.E₆ (σ • τ) ≠ 0 := by
+        rw [hE4, hE6]
+        exact mul_ne_zero (pow_ne_zero _ (mul_ne_zero (zpow_ne_zero _ hd) h4)) (mul_ne_zero
+          (zpow_ne_zero _ hd) h6)
+      rw [PresVAux.realizeOf_eq M w hw (v : LaurentSeries ℂ) hv (σ • τ) hz, hE4, hE6, hD, hw',
+        show (((2 * n + h : ℕ)) : ℤ) = ((2 * n + h : ℕ) : ℤ) from rfl, zpow_natCast, _root_.pow_add,
+        _root_.pow_mul,
+        ← qParam_pow_self h hh (τ : ℂ)]
+      field_simp
+      ring
+    have hlim : Tendsto (fun τ : ℍ =>
+        -((((w : ℍ → ℂ) ∣[(1 : ℤ)] (σ : GL (Fin 2) ℝ)) τ / Function.Periodic.qParam (h : ℝ) (τ : ℂ)
+          ^ n) ^ 2 *
+          (ModularForm.discriminant τ / Function.Periodic.qParam 1 (τ : ℂ)) /
+          (ModularForm.E₄ τ ^ 2 * ModularForm.E₆ τ))) atImInfty (𝓝 (-(a ^ 2))) := by
+      have := ((hwlim.pow 2).mul tendsto_discriminant_div_qParam_atImInfty).div
+        ((tendsto_E₄_atImInfty.pow 2).mul tendsto_E₆_atImInfty) (by norm_num)
+      simpa using this.neg
+    refine hlim.congr' ?_
+    filter_upwards [hev] with τ hτ
+    exact (key τ hτ.1 hτ.2).symm
+  have hexp : P.ord v = (((2 * n + h : ℕ)) : ℤ) :=
+    zpow_readout_unique hhr _ hvlim hL hvlim' (neg_ne_zero.mpr (pow_ne_zero 2 ha))
+  rw [hexp, hordy]
+  push_cast
+  exact ⟨n, by ring⟩
+
+end
+end S_OVERLONG_a7405910
+end P2MW
+export P2MW.S_OVERLONG_a7405910
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open CongruenceSubgroup ModularCurve
+open scoped MatrixGroups ModularForm
+theorem ModularCurve.even_ord_add_ord_of_not_mem_toValuationSubring_laurentBaseChange_gamma1
+    (M : ℕ) [NeZero M] (hM : 5 ≤ M)
+    (y : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))))
+    (hy : (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ)
+    (w : ModularForm (Gamma1 M) 1) (hw : w ≠ 0)
+    (v : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))))
+    (hv : (v : LaurentSeries ℂ) * ModularCurve.thetaL ℂ (ModularCurve.jqModC ℂ) =
+      HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 w) ^ 2)
+    (P : AlgebraicCurve.Place ℂ
+        ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+          (CongruenceSubgroup.Gamma1 M))))
+    (hP : y ∉ P.toValuationSubring) :
+    Even (P.ord v + P.ord y) :=
+  solution M hM y hy w hw v hv P hP
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_even_ord_add_weightFloor_of_mem_toValuationSubring_laurentBaseChange_gamma1.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_even_ord_add_weightFloor_of_mem_toValuationSubring_laurentBaseChange_gamma1.lean
new file mode 100644
index 0000000000..1b56b6c2d4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_even_ord_add_weightFloor_of_mem_toValuationSubring_laurentBaseChange_gamma1.lean
@@ -0,0 +1,488 @@
+/-
+Based on Prove2Me node
+ModularCurve.even_ord_add_weightFloor_of_mem_toValuationSubring_laurentBaseChange_gamma1
+(44bd2a0d-9100-5e11-8546-1f6573c5bdd2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a8e5a615-3a36-5553-83a2-c074aa242a8e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QExpansionDiff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0ModL
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ComplexPlaceDictionaryOf_exists_pt_eq_of_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ComplexPlaceDictionaryOf_ramification_eq_one_gamma1
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_complexPlaceDictionaryOf
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_realizeOf_eq_div
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_thetaL_coeffMap_eq_coeffMap_single_mul_derivative
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_coe_eq_of_levelOne
+import LeanPool.FLTEichlerShimura.Theorems.Thm_omegaRow_T2
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Interior parity of ord_P(v) plus the weight-floor term
+
+Theorem statement:
+`ModularCurve.even_ord_add_weightFloor_of_mem_toValuationSubring_laurentBaseChange_gamma1`
+(`44bd2a0d-9100-5e11-8546-1f6573c5bdd2`), by Claude, 2026-09-05.
+
+Proof: submission `a8e5a615-3a36-5553-83a2-c074aa242a8e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $M \ge 4$ and let $F$ be the subfield of $\mathbb{C}((q))$ obtained by adjoining to $\mathbb{C}$
+the coefficientwise images under $\mathbb{Q} \to \mathbb{C}$ of the $q$-expansion function field of
+$\Gamma_1(M)$ over $\mathbb{Q}$, the latter being generated over $\mathbb{Q}$ by the quotients of
+integral $q$-expansions of two modular forms of a common weight on $\Gamma_1(M)$. Let $y \in F$ have
+underlying Laurent series $q^{-1}$ times the power series $E_4^3 \cdot \eta^{-24}$ with coefficients
+pushed to $\mathbb{C}$, i.e. the $q$-expansion of $j$. Let $w$ be a nonzero modular form of weight
+$1$ on $\Gamma_1(M)$, and let $v \in F$ satisfy $v \cdot \vartheta(j) = (\text{$q$-expansion of }
+w)^2$ in $\mathbb{C}((q))$, where $\vartheta(f) = q \, df/dq$. Let $P$ be a place of $F$ over
+$\mathbb{C}$ — a proper valuation subring of $F$ containing $\mathbb{C}$ and a principal ideal ring
+— with associated order function $\operatorname{ord}_P$, and assume $y$ lies in that valuation
+subring. Then the integer $$\operatorname{ord}_P(v) +
+\big[\operatorname{ord}_P(y)>0\big]\,\tfrac{2\operatorname{ord}_P(y)}{3} +
+\big[\operatorname{ord}_P(y-1728)>0\big]\,\tfrac{\operatorname{ord}_P(y-1728)}{2} +
+\big[\operatorname{ord}_P(y)<0\big]\,\operatorname{ord}_P(y)$$ is even, the two quotients being
+integer division of positive dividends.
+
+This is the interior (non-cuspidal) half of the parity statement underlying the identification of a
+weight-one form on $\Gamma_1(M)$, $M \ge 4$, with a square root of $v \cdot \vartheta(j)$: at a
+place lying over a point of the upper half-plane, where $\Gamma_1(M)$ has no elliptic fixed points
+and the complex place dictionary is unramified, the order of $v$ corrected by the weight-floor term
+has the parity of twice the order of vanishing of $w$. It feeds the construction of a divisor $D$
+with $2D = \operatorname{div}(v) + \operatorname{div}(\vartheta j)$ on $X_1(M)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_even_ord_add_weightFloor_of_mem_toValuationSubring_laurentBaseChange_gamma1.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_06a8d469
+
+open CongruenceSubgroup ModularCurve UpperHalfPlane HahnSeries Filter Topology
+open scoped MatrixGroups ModularForm
+
+noncomputable section
+
+namespace IntParityAux
+
+theorem one_mem_strictPeriods_gamma1 (M : ℕ) :
+    (1 : ℝ) ∈ (Subgroup.map (Matrix.SpecialLinearGroup.mapGL ℝ) (CongruenceSubgroup.Gamma1
+      M)).strictPeriods := by
+  rw [CongruenceSubgroup.strictPeriods_Gamma1]
+  exact AddSubgroup.mem_zmultiples 1
+
+theorem jqModC_complex_eq : jqModC ℂ = coeffEmb ℂ jq := by
+  rw [coeffEmb, ← jqModC_rat, coeffMap_jqModC]
+
+theorem thetaL_coeffEmb_jq :
+    thetaL ℂ (coeffEmb ℂ jq) = coeffMap (algebraMap ℚ ℂ) (thetaL ℚ jq) := by
+  rw [coeffEmb, ModularCurve.thetaL_coeffMap_eq_coeffMap_single_mul_derivative]
+  rfl
+
+theorem analyticAt_comp_ofComplex {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} (f : ModularForm Γ k)
+    (τ : ℍ) :
+    AnalyticAt ℂ ((f : ℍ → ℂ) ∘ ofComplex) (τ : ℂ) := by
+  have hd : DifferentiableOn ℂ ((f : ℍ → ℂ) ∘ ofComplex) {z : ℂ | 0 < z.im} :=
+    UpperHalfPlane.mdifferentiable_iff.mp f.holo'
+  exact hd.analyticAt ((isOpen_lt continuous_const Complex.continuous_im).mem_nhds τ.im_pos)
+
+theorem analyticOrderAt_ne_top {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} (f : ModularForm Γ k)
+    (hf : f ≠ 0) (τ : ℍ) :
+    analyticOrderAt ((f : ℍ → ℂ) ∘ ofComplex) (τ : ℂ) ≠ ⊤ := by
+  intro htop
+  apply hf
+  rw [analyticOrderAt_eq_top] at htop
+  have hU : IsPreconnected {z : ℂ | 0 < z.im} := (convex_halfSpace_im_gt 0).isPreconnected
+  have han : AnalyticOnNhd ℂ ((f : ℍ → ℂ) ∘ ofComplex) {z : ℂ | 0 < z.im} := fun z hz =>
+    (UpperHalfPlane.mdifferentiable_iff.mp f.holo').analyticAt
+      ((isOpen_lt continuous_const Complex.continuous_im).mem_nhds hz)
+  have hzero := han.eqOn_zero_of_preconnected_of_eventuallyEq_zero hU τ.im_pos htop
+  rw [← FunLike.coe_zero_iff]
+  funext z
+  have := hzero z.im_pos
+  simpa [Function.comp_apply, UpperHalfPlane.ofComplex_apply] using this
+
+theorem exists_nat_meromorphicOrderAt_eq {f : ℂ → ℂ} {x : ℂ} (hf : AnalyticAt ℂ f x)
+    (h : analyticOrderAt f x ≠ ⊤) :
+    ∃ n : ℕ, analyticOrderAt f x = n ∧ meromorphicOrderAt f x = (n : ℤ) := by
+  obtain ⟨n, hn⟩ := ENat.ne_top_iff_exists.mp h
+  refine ⟨n, hn.symm, ?_⟩
+  rw [hf.meromorphicOrderAt_eq, ← hn]
+  rfl
+
+end IntParityAux
+
+open IntParityAux in
+theorem solution
+    (M : ℕ) [NeZero M] (hM : 4 ≤ M)
+    (y : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))))
+    (hy : (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ)
+    (w : ModularForm (Gamma1 M) 1) (hw : w ≠ 0)
+    (v : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))))
+    (hv : (v : LaurentSeries ℂ) * ModularCurve.thetaL ℂ (ModularCurve.jqModC ℂ) =
+      HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 w) ^ 2)
+    (P : AlgebraicCurve.Place ℂ
+        ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+          (CongruenceSubgroup.Gamma1 M))))
+    (hP : y ∈ P.toValuationSubring) :
+    Even (P.ord v +
+          ((if 0 < P.ord y then (2 * P.ord y) / 3 else 0)
+            + (if 0 < P.ord (y - 1728) then (P.ord (y - 1728)) / 2 else 0)
+            + (if P.ord y < 0 then P.ord y else 0))) := by
+  classical
+  have : (CongruenceSubgroup.Gamma1 M).FiniteIndex := inferInstance
+  have hT : ModularGroup.T ∈ CongruenceSubgroup.Gamma1 M := by
+    rw [CongruenceSubgroup.Gamma1_mem]; simp [ModularGroup.T]
+  have h1 := one_mem_strictPeriods_gamma1 M
+  obtain ⟨D⟩ := ModularCurve.exists_complexPlaceDictionaryOf (CongruenceSubgroup.Gamma1 M) hT
+    (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)) rfl
+  obtain ⟨τ, rfl⟩ :=
+    ModularCurve.ComplexPlaceDictionaryOf.exists_pt_eq_of_mem (CongruenceSubgroup.Gamma1 M) hT
+    (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)) rfl D P y hy hP
+  have he : D.ramification τ = 1 :=
+    ModularCurve.ComplexPlaceDictionaryOf.ramification_eq_one_gamma1 M hM _ rfl D τ
+  obtain ⟨hell1, hell2⟩ :=
+    ModularCurve.ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1 ℂ M hM y hy
+  have hoy : 0 ≤ (D.pt τ).ord y := AlgebraicCurve.Place.ord_nonneg_of_mem _ hP
+  obtain ⟨a6, n, hoy', hov⟩ : ∃ (a6 : ℕ) (n : ℤ), (D.pt τ).ord (y - 1728) = 2 * a6 ∧ (D.pt τ).ord v
+    + a6 = 2 * n :=
+    by
+    obtain ⟨E4N, hE4⟩ :=
+      ModularForm.exists_coe_eq_of_levelOne (CongruenceSubgroup.Gamma1 M) ModularForm.E₄
+    obtain ⟨E6N, hE6⟩ :=
+      ModularForm.exists_coe_eq_of_levelOne (CongruenceSubgroup.Gamma1 M) ModularForm.E₆
+    obtain ⟨DN, hD⟩ := ModularForm.exists_coe_eq_of_levelOne (CongruenceSubgroup.Gamma1 M)
+      (ModularFormClass.modularForm (CuspForm.discriminant))
+    have hDcoe : (DN : ℍ → ℂ) = ModularForm.discriminant := by
+      rw [hD]
+      funext z
+      rw [← CuspForm.toModularFormₗ_eq_coe, CuspForm.toModularFormₗ_apply]
+      rfl
+    obtain ⟨P4, hP4def⟩ : ∃ P4 : ModularForm (Gamma1 M) 12, P4 = ModularForm.mcast (by
+      norm_num) ((E4N.mul E4N).mul E4N) :=
+      ⟨_, rfl⟩
+    obtain ⟨Hh, hHhdef⟩ : ∃ Hh : ModularForm (Gamma1 M) 14, Hh = ModularForm.mcast (by
+      norm_num) ((E4N.mul E4N).mul E6N) :=
+      ⟨_, rfl⟩
+    obtain ⟨Gv, hGvdef⟩ : ∃ Gv : ModularForm (Gamma1 M) 14, Gv = ModularForm.mcast (by
+      norm_num) (-((w.mul w).mul DN)) :=
+      ⟨_, rfl⟩
+    obtain ⟨P17, hP17def⟩ : ∃ P17 : ModularForm (Gamma1 M) 12, P17 = P4 - (1728 : ℂ) • DN :=
+      ⟨_, rfl⟩
+    have hP4coe : (P4 : ℍ → ℂ) = fun z => ModularForm.E₄ z ^ 3 := by
+      funext z; simp only [hP4def, ModularForm.coe_mcast, ModularForm.coe_mul, Pi.mul_apply,
+        hE4]; ring
+    have hHhcoe : (Hh : ℍ → ℂ) = fun z => ModularForm.E₄ z ^ 2 * ModularForm.E₆ z := by
+      funext z; simp only [hHhdef, ModularForm.coe_mcast, ModularForm.coe_mul, Pi.mul_apply, hE4,
+        hE6]; ring
+    have hGvcoe : (Gv : ℍ → ℂ) = fun z => -(w z ^ 2 * ModularForm.discriminant z) := by
+      funext z
+      simp only [hGvdef, ModularForm.coe_mcast, FunLike.coe_neg, ModularForm.coe_mul, Pi.neg_apply,
+        Pi.mul_apply, hDcoe]
+      ring
+    have hP17coe : (P17 : ℍ → ℂ) = fun z => ModularForm.E₄ z ^ 3 - 1728 * ModularForm.discriminant z
+      := by
+      funext z
+      rw [hP17def, FunLike.coe_sub, FunLike.coe_smul, Pi.sub_apply, Pi.smul_apply, hP4coe, hDcoe,
+        smul_eq_mul]
+    have hqE4 : qExpansion 1 (E4N : ℍ → ℂ) = qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) := by rw [hE4]
+    have hqE6 : qExpansion 1 (E6N : ℍ → ℂ) = qExpansion 1 (ModularForm.E₆ : ℍ → ℂ) := by rw [hE6]
+    have hqD : qExpansion 1 (DN : ℍ → ℂ) = qExpansion 1 ModularForm.discriminant := by rw [hDcoe]
+    have hqP4 : qExpansion 1 (P4 : ℍ → ℂ) = qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) ^ 3 := by
+      rw [hP4def, ModularForm.qExpansion_mcast, ModularForm.qExpansion_mul one_pos h1,
+        ModularForm.qExpansion_mul one_pos h1, hqE4]; ring
+    have hqHh : qExpansion 1 (Hh : ℍ → ℂ) =
+        qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) ^ 2 * qExpansion 1 (ModularForm.E₆ : ℍ → ℂ) := by
+      rw [hHhdef, ModularForm.qExpansion_mcast, ModularForm.qExpansion_mul one_pos h1,
+        ModularForm.qExpansion_mul one_pos h1, hqE4, hqE6]; ring
+    have hqGv : qExpansion 1 (Gv : ℍ → ℂ) = -(qExpansion 1 (w : ℍ → ℂ) ^ 2 * qExpansion 1
+      ModularForm.discriminant) :=
+      by
+      rw [hGvdef, ModularForm.qExpansion_mcast, FunLike.coe_neg, ModularForm.qExpansion_neg one_pos
+        h1,
+        ModularForm.qExpansion_mul one_pos h1, ModularForm.qExpansion_mul one_pos h1, hqD]; ring
+    have hqP17 : qExpansion 1 (P17 : ℍ → ℂ) =
+        qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) ^ 3 - 1728 * qExpansion 1 ModularForm.discriminant
+          := by
+      rw [hP17def, FunLike.coe_sub, ModularForm.qExpansion_sub one_pos h1, hqP4, FunLike.coe_smul,
+        ModularForm.qExpansion_smul one_pos h1, hqD, Algebra.smul_def, map_ofNat]
+    have hT2 : thetaL ℂ (jqModC ℂ) * ofPowerSeries ℤ ℂ (qExpansion 1 ModularForm.discriminant) =
+        -(ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) ^ 2 *
+          ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ))) := by
+      rw [jqModC_complex_eq, thetaL_coeffEmb_jq]
+      exact omegaRow_T2
+    have hDN0 : DN ≠ 0 := by
+      intro h0
+      have hI : (DN : ℍ → ℂ) UpperHalfPlane.I = 0 := by rw [h0]; rfl
+      rw [hDcoe] at hI
+      exact ModularForm.discriminant_ne_zero _ hI
+    have hDq : ofPowerSeries ℤ ℂ (qExpansion 1 ModularForm.discriminant) ≠ 0 := by
+      intro h0
+      apply hDN0
+      have h0' : qExpansion 1 (DN : ℍ → ℂ) = 0 :=
+        HahnSeries.ofPowerSeries_injective (by rw [hqD, h0, map_zero])
+      exact (ModularForm.qExpansion_eq_zero_iff one_pos h1 DN).mp h0'
+    have hY : (y : LaurentSeries ℂ) * ofPowerSeries ℤ ℂ (qExpansion 1 ModularForm.discriminant) =
+        ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) ^ 3 := by
+      rw [hy, ModularCurve.jqModC_eq_qExpansion_E4_cube_div_discriminant, div_mul_cancel₀ _ hDq]
+    have pres_y : (y : LaurentSeries ℂ) * ((qExpansion 1 (DN : ℍ → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) =
+        ((qExpansion 1 (P4 : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) := by
+      rw [hqD, hqP4, PowerSeries.coe_pow]
+      exact hY
+    have h1728 : ((1728 : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M)))) :
+        LaurentSeries ℂ) = 1728 :=
+      map_ofNat (ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+        (CongruenceSubgroup.Gamma1 M))).val 1728
+    have hcoe17 : ((y - 1728 : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M)))) :
+        LaurentSeries ℂ) = (y : LaurentSeries ℂ) - 1728 := by
+      rw [← h1728]; rfl
+    have pres_y' : ((y - 1728 : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC
+      ℚ (CongruenceSubgroup.Gamma1 M)))) :
+          LaurentSeries ℂ) * ((qExpansion 1 (DN : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+        ((qExpansion 1 (P17 : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) := by
+      rw [hcoe17, hqD, hqP17, PowerSeries.coe_sub, PowerSeries.coe_mul, PowerSeries.coe_pow,
+        map_ofNat]
+      linear_combination hY
+    have pres_v : (v : LaurentSeries ℂ) * ((qExpansion 1 (Hh : ℍ → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) =
+        ((qExpansion 1 (Gv : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) := by
+      rw [hqHh, hqGv, PowerSeries.coe_neg, PowerSeries.coe_mul, PowerSeries.coe_mul,
+        PowerSeries.coe_pow, PowerSeries.coe_pow]
+      linear_combination (v : LaurentSeries ℂ) * hT2 -
+        ofPowerSeries ℤ ℂ (qExpansion 1 ModularForm.discriminant) * hv
+    have hW0 : ofPowerSeries ℤ ℂ (qExpansion 1 (w : ℍ → ℂ)) ≠ 0 := by
+      intro h0
+      apply hw
+      have h0' : qExpansion 1 (w : ℍ → ℂ) = 0 :=
+        HahnSeries.ofPowerSeries_injective (by rw [h0, map_zero])
+      exact (ModularForm.qExpansion_eq_zero_iff one_pos h1 w).mp h0'
+    have hHh0 : Hh ≠ 0 := by
+      intro h0
+      have hq0 : ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) ^ 2 *
+          ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) = 0 := by
+        have : qExpansion 1 (Hh : ℍ → ℂ) = 0 :=
+          (ModularForm.qExpansion_eq_zero_iff one_pos h1 Hh).mpr h0
+        rw [hqHh] at this
+        have := congrArg (ofPowerSeries ℤ ℂ) this
+        rwa [map_mul, map_pow, map_zero] at this
+      have hT0 : thetaL ℂ (jqModC ℂ) = 0 := by
+        have := hT2
+        rw [hq0, neg_zero] at this
+        exact (mul_eq_zero.mp this).resolve_right hDq
+      apply hW0
+      have := hv
+      rw [hT0, mul_zero] at this
+      exact pow_eq_zero_iff two_ne_zero |>.mp this.symm
+    have hv0 : v ≠ 0 := by
+      intro h0
+      apply hW0
+      have := hv
+      rw [h0] at this
+      simp only [ZeroMemClass.coe_zero, zero_mul] at this
+      exact pow_eq_zero_iff two_ne_zero |>.mp this.symm
+    have hy'0 : (y - 1728 : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M)))) ≠ 0 :=
+      by
+      intro h0
+      have h1' : ((y - 1728 : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+        (CongruenceSubgroup.Gamma1 M)))) :
+          LaurentSeries ℂ).coeff (-1) = 1 := by
+        rw [hcoe17, hy, HahnSeries.coeff_sub', Pi.sub_apply]
+        have hj1 : (jqModC ℂ).coeff (-1) = 1 := by
+          have e := HahnSeries.coeff_single_mul_add (r := (1 : ℂ))
+            (x := HahnSeries.ofPowerSeries ℤ ℂ (jNum.map (Int.castRingHom ℂ))) (a := 0) (b := -1)
+          have e0 : (HahnSeries.ofPowerSeries ℤ ℂ (jNum.map (Int.castRingHom ℂ))).coeff 0 = 1 := by
+            have := HahnSeries.ofPowerSeries_apply_coeff (Γ := ℤ) (jNum.map (Int.castRingHom ℂ)) 0
+            rw [Nat.cast_zero] at this
+            rw [this, PowerSeries.coeff_map, PowerSeries.coeff_zero_eq_constantCoeff_apply,
+              ModularCurve.constantCoeff_jNum, map_one]
+          rw [zero_add, one_mul, e0] at e
+          rw [jqModC]
+          exact e
+        have hc : (1728 : LaurentSeries ℂ).coeff (-1) = 0 := by
+          rw [show (1728 : LaurentSeries ℂ) = HahnSeries.C (1728 : ℂ) from (map_ofNat HahnSeries.C
+            1728).symm,
+            HahnSeries.C_apply, HahnSeries.coeff_single_of_ne (by decide)]
+        rw [hj1, hc, sub_zero]
+      rw [h0] at h1'
+      simp at h1'
+    have hRy' : ∀ z : ℍ, ModularCurve.realizeOf (CongruenceSubgroup.Gamma1 M)
+        ((y - 1728 : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+          (CongruenceSubgroup.Gamma1 M)))) : LaurentSeries ℂ) z =
+        ModularForm.E₆ z ^ 2 / ModularForm.discriminant z := by
+      intro z
+      rw [ModularCurve.realizeOf_eq_div (CongruenceSubgroup.Gamma1 M) hT P17 DN _ pres_y' z
+        (by rw [hDcoe]; exact ModularForm.discriminant_ne_zero z), hP17coe, hDcoe]
+      simp only
+      rw [ModularForm.discriminant_eq_E₄_cube_sub_E₆_sq]
+      have hd := ModularForm.discriminant_ne_zero z
+      rw [ModularForm.discriminant_eq_E₄_cube_sub_E₆_sq] at hd
+      field_simp
+      ring
+    have hRv : ∀ z : ℍ, ModularForm.E₄ z ^ 2 * ModularForm.E₆ z ≠ 0 →
+        ModularCurve.realizeOf (CongruenceSubgroup.Gamma1 M) (v : LaurentSeries ℂ) z =
+          -(w z ^ 2 * ModularForm.discriminant z) / (ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) := by
+      intro z hz
+      rw [ModularCurve.realizeOf_eq_div (CongruenceSubgroup.Gamma1 M) hT Gv Hh _ pres_v z (by
+        rw [hHhcoe]; exact hz),
+        hGvcoe, hHhcoe]
+    have haw := analyticAt_comp_ofComplex w τ
+    have ha4 := analyticAt_comp_ofComplex ModularForm.E₄ τ
+    have ha6 := analyticAt_comp_ofComplex ModularForm.E₆ τ
+    have haD := analyticAt_comp_ofComplex DN τ
+    rw [hDcoe] at haD
+    have haH := analyticAt_comp_ofComplex Hh τ
+    obtain ⟨aw, haw', hmw⟩ := exists_nat_meromorphicOrderAt_eq haw (analyticOrderAt_ne_top w hw τ)
+    have hHtop := analyticOrderAt_ne_top Hh hHh0 τ
+    have hBfun : ((Hh : ℍ → ℂ) ∘ ofComplex) = ((ModularForm.E₄ : ℍ → ℂ) ∘ ofComplex) ^ 2 *
+      ((ModularForm.E₆ : ℍ → ℂ) ∘ ofComplex) :=
+      by
+      funext c; simp only [Function.comp_apply, hHhcoe, Pi.mul_apply, Pi.pow_apply]
+    have h4top : analyticOrderAt ((ModularForm.E₄ : ℍ → ℂ) ∘ ofComplex) (τ : ℂ) ≠ ⊤ := by
+      intro ht
+      apply hHtop
+      rw [hBfun, analyticOrderAt_mul (ha4.pow 2) ha6, analyticOrderAt_pow ha4, ht]
+      simp
+    have h6top : analyticOrderAt ((ModularForm.E₆ : ℍ → ℂ) ∘ ofComplex) (τ : ℂ) ≠ ⊤ := by
+      intro ht
+      apply hHtop
+      rw [hBfun, analyticOrderAt_mul (ha4.pow 2) ha6, ht]
+      simp
+    obtain ⟨a4, ha4', hm4⟩ := exists_nat_meromorphicOrderAt_eq ha4 h4top
+    obtain ⟨a6, ha6', hm6⟩ := exists_nat_meromorphicOrderAt_eq ha6 h6top
+    have hmD : meromorphicOrderAt (ModularForm.discriminant ∘ ofComplex) (τ : ℂ) = (0 : ℤ) := by
+      rw [haD.meromorphicOrderAt_eq, (haD.analyticOrderAt_eq_zero).mpr (by
+        simp only [Function.comp_apply,
+          UpperHalfPlane.ofComplex_apply]; exact ModularForm.discriminant_ne_zero τ)]
+      rfl
+    have hFy' : (fun c : ℂ => ModularCurve.realizeOf (CongruenceSubgroup.Gamma1 M)
+        ((y - 1728 : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+          (CongruenceSubgroup.Gamma1 M)))) : LaurentSeries ℂ)
+        (ofComplex c)) = ((ModularForm.E₆ : ℍ → ℂ) ∘ ofComplex) ^ 2 / (ModularForm.discriminant ∘
+          ofComplex) := by
+      funext c
+      simp only [Pi.div_apply, Pi.pow_apply, Function.comp_apply]
+      exact hRy' (ofComplex c)
+    have hmy' := D.meromorphicOrderAt_realizeOf τ (y - 1728) hy'0
+    rw [hFy', meromorphicOrderAt_div (ha6.pow 2).meromorphicAt haD.meromorphicAt,
+      meromorphicOrderAt_pow ha6.meromorphicAt,
+      hm6, hmD, he] at hmy'
+    have hoy' : (D.pt τ).ord (y - 1728) = 2 * a6 := by
+      have : ((2 • (a6 : ℤ) - 0 : ℤ) : WithTop ℤ) = (((1 : ℕ) : ℤ) * (D.pt τ).ord (y - 1728) : ℤ) :=
+        by
+        rw [← hmy']; push_cast; rfl
+      have := WithTop.coe_injective this
+      simp at this
+      omega
+    have hevB : ∀ᶠ c in 𝓝[≠] (τ : ℂ), ((Hh : ℍ → ℂ) ∘ ofComplex) c ≠ 0 := by
+      rcases haH.eventually_eq_zero_or_eventually_ne_zero with h0 | hne
+      · exact absurd (analyticOrderAt_eq_top.mpr h0) hHtop
+      · exact hne
+    have hFv : (fun c : ℂ => ModularCurve.realizeOf (CongruenceSubgroup.Gamma1 M) (v : LaurentSeries
+      ℂ) (ofComplex c)) =ᶠ[𝓝[≠] (τ : ℂ)]
+        -((((w : ℍ → ℂ) ∘ ofComplex) ^ 2 * (ModularForm.discriminant ∘ ofComplex)) /
+          (((ModularForm.E₄ : ℍ → ℂ) ∘ ofComplex) ^ 2 * ((ModularForm.E₆ : ℍ → ℂ) ∘ ofComplex)))
+            := by
+      filter_upwards [hevB] with c hc
+      have hc' : ModularForm.E₄ (ofComplex c) ^ 2 * ModularForm.E₆ (ofComplex c) ≠ 0 := by
+        simpa only [Function.comp_apply, hHhcoe] using hc
+      simp only [Pi.neg_apply, Pi.div_apply, Pi.mul_apply, Pi.pow_apply, Function.comp_apply]
+      rw [hRv _ hc', neg_div]
+    have hmv := D.meromorphicOrderAt_realizeOf τ v hv0
+    rw [meromorphicOrderAt_congr hFv, ← meromorphicOrderAt_neg,
+      meromorphicOrderAt_div ((haw.pow 2).mul haD).meromorphicAt ((ha4.pow 2).mul
+      ha6).meromorphicAt,
+      meromorphicOrderAt_mul (haw.pow 2).meromorphicAt haD.meromorphicAt,
+      meromorphicOrderAt_mul (ha4.pow 2).meromorphicAt ha6.meromorphicAt,
+      meromorphicOrderAt_pow haw.meromorphicAt, meromorphicOrderAt_pow ha4.meromorphicAt,
+      hmw, hm4, hm6, hmD, he] at hmv
+    have hov : (D.pt τ).ord v + a6 = 2 * ((aw : ℤ) - a4) := by
+      have : ((2 • (aw : ℤ) + 0 - (2 • (a4 : ℤ) + a6) : ℤ) : WithTop ℤ) = (((1 : ℕ) : ℤ) * (D.pt
+        τ).ord v : ℤ) :=
+        by
+        rw [← hmv]; push_cast; rfl
+      have := WithTop.coe_injective this
+      simp at this
+      omega
+    exact ⟨a6, (aw : ℤ) - a4, hoy', hov⟩
+  have t3 : (if (D.pt τ).ord y < 0 then (D.pt τ).ord y else 0) = 0 := by
+    rw [ite_eq_right (not_lt.mpr hoy)]
+  have t1 : Even (if 0 < (D.pt τ).ord y then (2 * (D.pt τ).ord y) / 3 else 0) := by
+    split_ifs with h
+    · rw [hell1 _ h]; decide
+    · exact Even.zero
+  rw [t3, add_zero]
+  by_cases h6 : 0 < (D.pt τ).ord (y - 1728)
+  · have h2 : (D.pt τ).ord (y - 1728) = 2 := hell2 _ h6
+    have ha6 : (a6 : ℤ) = 1 := by omega
+    rw [ite_eq_left h6, h2]
+    obtain ⟨t, ht⟩ := t1
+    refine ⟨n + t, ?_⟩
+    norm_num
+    omega
+  · rw [ite_eq_right h6, add_zero]
+    have ha6 : (a6 : ℤ) = 0 := by omega
+    obtain ⟨t, ht⟩ := t1
+    refine ⟨n + t, ?_⟩
+    omega
+
+end
+end S_OVERLONG_06a8d469
+end P2MW
+export
+  P2MW.S_OVERLONG_06a8d469
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open CongruenceSubgroup ModularCurve
+open scoped MatrixGroups ModularForm
+theorem ModularCurve.even_ord_add_weightFloor_of_mem_toValuationSubring_laurentBaseChange_gamma1
+    (M : ℕ) [NeZero M] (hM : 4 ≤ M)
+    (y : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))))
+    (hy : (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ)
+    (w : ModularForm (Gamma1 M) 1) (hw : w ≠ 0)
+    (v : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))))
+    (hv : (v : LaurentSeries ℂ) * ModularCurve.thetaL ℂ (ModularCurve.jqModC ℂ) =
+      HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 w) ^ 2)
+    (P : AlgebraicCurve.Place ℂ
+        ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+          (CongruenceSubgroup.Gamma1 M))))
+    (hP : y ∈ P.toValuationSubring) :
+    Even (P.ord v +
+          ((if 0 < P.ord y then (2 * P.ord y) / 3 else 0)
+            + (if 0 < P.ord (y - 1728) then (P.ord (y - 1728)) / 2 else 0)
+            + (if P.ord y < 0 then P.ord y else 0))) :=
+  solution M hM y hy w hw v hv P hP
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eventually_norm_slash_le_mul_of_isIntegral_adjoin_jqModC_inv_sq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eventually_norm_slash_le_mul_of_isIntegral_adjoin_jqModC_inv_sq.lean
new file mode 100644
index 0000000000..39f988724c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eventually_norm_slash_le_mul_of_isIntegral_adjoin_jqModC_inv_sq.lean
@@ -0,0 +1,882 @@
+/-
+Based on Prove2Me node ModularCurve.eventually_norm_slash_le_mul_of_isIntegral_adjoin_jqModC_inv_sq
+(9bd551e6-c3d5-55c4-b5e6-c3743e9d8521) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f8a47d3c-423e-51a9-aabe-9dca7b583439
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import Mathlib.Data.Int.Star
+import Mathlib.Order.CompletePartialOrder
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_tendsto_atImInfty_of_hasSum_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_four_qCoeff_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_six_qCoeff_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality over ℂ[j⁻¹] bounds growth at every cusp
+
+Theorem statement: `ModularCurve.eventually_norm_slash_le_mul_of_isIntegral_adjoin_jqModC_inv_sq`
+(`9bd551e6-c3d5-55c4-b5e6-c3743e9d8521`), by Claude, 2026-09-05.
+
+Proof: submission `f8a47d3c-423e-51a9-aabe-9dca7b583439`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a finite-index subgroup of $\mathrm{SL}_2(\mathbb{Z})$ containing the translation
+matrix $T$, let $k\in\mathbb{Z}$, and let $m\ge 1$ be a natural number. Let $g,h$ be modular forms
+of weight $k$ for the image of $\Gamma$ in $\mathrm{GL}_2(\mathbb{R})$, with $h\ne 0$, and let $X$
+be a Laurent series over $\mathbb{C}$ satisfying $X\cdot \mathrm{qExp}(h)=\mathrm{qExp}(g)$, where
+$\mathrm{qExp}(\cdot)$ denotes the $q$-expansion of width $1$ viewed in $\mathbb{C}((q))$. Write
+$\bar j=$ `jqModC ℂ`, the Laurent series $q^{-1}$ times the image in $\mathbb{C}[[q]]$ of the
+integral power series `jNum` $=$ `eisenstein4`$^3\cdot$`dedekindEtaUnitInv`. Assume that $X^2\,\bar
+j^{\,m}\,(\bar j-1728)^m$ is integral over the $\mathbb{C}$-subalgebra of $\mathbb{C}((q))$
+generated by $\bar j^{-1}$. Then for every $A\in \mathrm{SL}_2(\mathbb{Z})$ there is a real constant
+$C$ such that, for $\tau$ in the upper half plane eventually along the filter at $i\infty$,
+$$\bigl\|\bigl((z\mapsto g(z)(E_4(z)^2E_6(z))^m)\mid_{k+14m}A\bigr)(\tau)\bigr\|\le
+C\,\bigl\|\bigl((z\mapsto h(z)\Delta(z)^m)\mid_{k+12m}A\bigr)(\tau)\bigr\|,$$
+the slash being taken for the image of $A$ in $\mathrm{GL}_2(\mathbb{R})$.
+
+This is the level-generic growth estimate transporting integrality of a quotient of $q$-expansions
+over $\mathbb{C}[j^{-1}]$ into a bound at an arbitrary cusp, the cusp being reached by the slash
+action of $A\in\mathrm{SL}_2(\mathbb{Z})$ and $j^{-1}$ tending to $0$ there. It is used in the
+construction of a modular form on $\Gamma_1$ whose $q$-expansion is a prescribed multiple of a power
+of a theta series, in
+[`ModularCurve.exists_modularForm_gamma1_qExpansion_eq_mul_thetaL_pow_of_isIntegral`]
+(thm.html#ModularCurve.exists_modularForm_gamma1_qExpansion_eq_mul_thetaL_pow_of_isIntegral).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_eventually_norm_slash_le_mul_of_isIntegral_adjoin_jqModC_inv_sq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 3200000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_eventually_norm_slash_le_mul_of_isIntegral_adjoin_jqModC_inv_sq
+
+p2m_open "UpperHalfPlane ModularCurve~coeffEmb_jq"
+open scoped MatrixGroups ModularForm Manifold
+
+noncomputable section
+
+namespace ANb
+
+def Nice (f : ℍ → ℂ) : Prop :=
+  Function.Periodic (f ∘ ofComplex) 1 ∧ MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f ∧ IsBoundedAtImInfty f
+
+theorem Nice.mul {f g : ℍ → ℂ} (hf : Nice f) (hg : Nice g) : Nice (f * g) :=
+  ⟨by simpa [Function.comp_def] using hf.1.mul hg.1, hf.2.1.mul hg.2.1, hf.2.2.mul hg.2.2⟩
+
+theorem Nice.add {f g : ℍ → ℂ} (hf : Nice f) (hg : Nice g) : Nice (f + g) :=
+  ⟨by simpa [Function.comp_def] using hf.1.add hg.1, hf.2.1.add hg.2.1, hf.2.2.add hg.2.2⟩
+
+theorem Nice.const (c : ℂ) : Nice (fun _ => c) :=
+  ⟨fun _ => rfl, mdifferentiable_const, Filter.const_boundedAtFilter _ _⟩
+
+def niceSubalgebra : Subalgebra ℂ (ℍ → ℂ) where
+  carrier := {f | Nice f}
+  mul_mem' hf hg := hf.mul hg
+  add_mem' hf hg := hf.add hg
+  algebraMap_mem' c := Nice.const c
+
+local notation "𝒩" => niceSubalgebra
+
+theorem an (f : 𝒩) : AnalyticAt ℂ (cuspFunction 1 (f : ℍ → ℂ)) 0 :=
+  UpperHalfPlane.analyticAt_cuspFunction_zero one_pos f.2.1 f.2.2.1 f.2.2.2
+
+def qexpHom : 𝒩 →ₐ[ℂ] PowerSeries ℂ where
+  toFun f := qExpansion 1 (f : ℍ → ℂ)
+  map_one' := UpperHalfPlane.qExpansion_one 1
+  map_mul' f g := UpperHalfPlane.qExpansion_mul (an f) (an g)
+  map_zero' := UpperHalfPlane.qExpansion_zero 1
+  map_add' f g := UpperHalfPlane.qExpansion_add (an f) (an g)
+  commutes' c := by
+    have h1 : ((algebraMap ℂ (ℍ → ℂ) c : ℍ → ℂ)) = c • (1 : ℍ → ℂ) := by
+      funext z; simp
+    have a1 : AnalyticAt ℂ (cuspFunction 1 (1 : ℍ → ℂ)) 0 := an (1 : 𝒩)
+    change qExpansion 1 (algebraMap ℂ (ℍ → ℂ) c) = _
+    rw [h1, UpperHalfPlane.qExpansion_smul a1 c, UpperHalfPlane.qExpansion_one,
+      Algebra.algebraMap_eq_smul_one]
+
+theorem qexpHom_apply (f : 𝒩) : qexpHom f = qExpansion 1 (f : ℍ → ℂ) := rfl
+
+def ψ : 𝒩 →ₐ[ℂ] LaurentSeries ℂ :=
+  { (HahnSeries.ofPowerSeries ℤ ℂ).comp qexpHom.toRingHom with
+    commutes' := fun c => by
+      change HahnSeries.ofPowerSeries ℤ ℂ (qexpHom (algebraMap ℂ 𝒩 c)) = _
+      rw [qexpHom.commutes, HahnSeries.algebraMap_apply'] }
+
+theorem ψ_apply (f : 𝒩) : ψ f = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (f : ℍ → ℂ)) := rfl
+
+theorem ψ_injective : Function.Injective ψ := by
+  intro f g hfg
+  rw [ψ_apply, ψ_apply] at hfg
+  have h := HahnSeries.ofPowerSeries_injective hfg
+  have h' : qExpansion 1 ((f : ℍ → ℂ) - (g : ℍ → ℂ)) = 0 := by
+    rw [UpperHalfPlane.qExpansion_sub (an f) (an g), h, sub_self]
+  have hn : Nice ((f : ℍ → ℂ) - (g : ℍ → ℂ)) := (f - g).2
+  have h0 := (UpperHalfPlane.qExpansion_eq_zero_iff one_pos hn.1 hn.2.1 hn.2.2).mp h'
+  exact Subtype.ext (sub_eq_zero.mp h0)
+
+theorem ψ_eq_zero_iff (f : 𝒩) : ψ f = 0 ↔ f = 0 :=
+  ⟨fun h => ψ_injective (by rw [h, map_zero]), fun h => by rw [h, map_zero]⟩
+
+def toC : 𝒩 →ₐ[ℂ] (ℂ → ℂ) where
+  toFun f := (f : ℍ → ℂ) ∘ ofComplex
+  map_one' := rfl
+  map_mul' _ _ := rfl
+  map_zero' := rfl
+  map_add' _ _ := rfl
+  commutes' _ := rfl
+
+theorem toC_apply (f : 𝒩) : toC f = (f : ℍ → ℂ) ∘ ofComplex := rfl
+
+theorem analyticAt_toC (f : 𝒩) (τ : ℍ) : AnalyticAt ℂ (toC f) (τ : ℂ) := by
+  have hd : DifferentiableOn ℂ ((f : ℍ → ℂ) ∘ ofComplex) {z : ℂ | 0 < z.im} :=
+    UpperHalfPlane.mdifferentiable_iff.mp f.2.2.1
+  exact hd.analyticAt ((isOpen_lt continuous_const Complex.continuous_im).mem_nhds τ.im_pos)
+
+theorem nice_of_modularForm {F : Type*} {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (h1 : (1 : ℝ) ∈ Γ.strictPeriods) : Nice (f : ℍ → ℂ) := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Subgroup.isCusp_of_mem_strictPeriods one_pos h1⟩
+  refine ⟨?_, ModularFormClass.holo f, ModularFormClass.bdd_at_infty f⟩
+  simpa using SlashInvariantFormClass.periodic_comp_ofComplex (h := 1) f h1
+
+def ofMF {F : Type*} {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (h1 : (1 : ℝ) ∈ Γ.strictPeriods) : 𝒩 :=
+  ⟨f, nice_of_modularForm f h1⟩
+
+@[scoped simp] theorem coe_ofMF {F : Type*} {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (h1 : (1 : ℝ) ∈ Γ.strictPeriods) :
+    ((ofMF f h1 : 𝒩) : ℍ → ℂ) = f := rfl
+
+theorem one_mem_strictPeriods_of_T_mem {Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)}
+    (hT : ModularGroup.T ∈ Γ) :
+    (1 : ℝ) ∈ (Subgroup.map (Matrix.SpecialLinearGroup.mapGL ℝ) Γ).strictPeriods := by
+  rw [Subgroup.strictPeriods_eq_zmultiples_one_of_T_mem hT]
+  exact AddSubgroup.mem_zmultiples 1
+
+def 𝔞 : 𝒩 := ofMF ModularForm.E₄ one_mem_strictPeriods_SL
+
+def 𝔟 : 𝒩 := ofMF ModularForm.E₆ one_mem_strictPeriods_SL
+
+def 𝔡 : 𝒩 := ofMF CuspForm.discriminant one_mem_strictPeriods_SL
+
+theorem ψ𝔞 : ψ 𝔞 = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) := rfl
+theorem ψ𝔟 : ψ 𝔟 = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) := rfl
+theorem ψ𝔡 : ψ 𝔡 = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 ModularForm.discriminant) := rfl
+theorem toC𝔡_apply (τ : ℍ) : toC 𝔡 (τ : ℂ) = ModularForm.discriminant τ := by
+  change ModularForm.discriminant (ofComplex (τ : ℂ)) = _
+  rw [ofComplex_apply]
+
+theorem coeff_one_mul (φ χ : PowerSeries ℂ) :
+    PowerSeries.coeff 1 (φ * χ) = PowerSeries.coeff 0 φ * PowerSeries.coeff 1 χ +
+      PowerSeries.coeff 1 φ * PowerSeries.coeff 0 χ := by
+  rw [PowerSeries.coeff_mul, Finset.Nat.sum_antidiagonal_eq_sum_range_succ_mk]
+  simp [Finset.sum_range_succ]
+
+theorem coeff_zero_mul' (φ χ : PowerSeries ℂ) :
+    PowerSeries.coeff 0 (φ * χ) = PowerSeries.coeff 0 φ * PowerSeries.coeff 0 χ := by
+  rw [PowerSeries.coeff_zero_eq_constantCoeff_apply, PowerSeries.coeff_zero_eq_constantCoeff_apply,
+    PowerSeries.coeff_zero_eq_constantCoeff_apply, map_mul]
+
+theorem qA0 : PowerSeries.coeff 0 (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) = 1 :=
+  EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) ⟨2, rfl⟩
+theorem qB0 : PowerSeries.coeff 0 (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) = 1 :=
+  EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) ⟨3, rfl⟩
+theorem qA1 : PowerSeries.coeff 1 (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) = 240 := by
+  have h := ModularForm.levelOne_weight_four_qCoeff_one ModularForm.E₄
+  simp only [ModularFormClass.qCoeff] at h
+  rw [h, qA0, mul_one]
+theorem qB1 : PowerSeries.coeff 1 (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) = -504 := by
+  have h := ModularForm.levelOne_weight_six_qCoeff_one ModularForm.E₆
+  simp only [ModularFormClass.qCoeff] at h
+  rw [h, qB0, mul_one]
+theorem qD1 : PowerSeries.coeff 1 (qExpansion 1 ModularForm.discriminant) = 1 := by
+  rw [ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit, PowerSeries.coeff_map,
+    PowerSeries.coeff_succ_X_mul, PowerSeries.coeff_zero_eq_constantCoeff_apply,
+    ModularCurve.constantCoeff_dedekindEtaUnit, map_one]
+
+theorem A_cube_sub_B_sq : ψ 𝔞 ^ 3 - ψ 𝔟 ^ 2 = 1728 * ψ 𝔡 := by
+  let T : ModularForm 𝒮ℒ 12 := ModularForm.E₄.mul (ModularForm.E₄.mul ModularForm.E₄)
+  let U : ModularForm 𝒮ℒ 12 := ModularForm.E₆.mul ModularForm.E₆
+  let Z : ModularForm 𝒮ℒ 12 := T - U
+  have hZ : (Z : ℍ → ℂ) = ((𝔞 * (𝔞 * 𝔞) - 𝔟 * 𝔟 : 𝒩) : ℍ → ℂ) := by
+    funext z
+    change (T : ℍ → ℂ) z - (U : ℍ → ℂ) z = _
+    rfl
+  have hZq : qExpansion 1 (Z : ℍ → ℂ) =
+      qExpansion 1 ⇑ModularForm.E₄ * (qExpansion 1 ⇑ModularForm.E₄ * qExpansion 1 ⇑ModularForm.E₄) -
+        qExpansion 1 ⇑ModularForm.E₆ * qExpansion 1 ⇑ModularForm.E₆ := by
+    rw [hZ, ← qexpHom_apply, map_sub, map_mul, map_mul, map_mul]
+    rfl
+  have h0 : ModularFormClass.qCoeff (Z : ℍ → ℂ) 0 = 0 := by
+    simp only [ModularFormClass.qCoeff, hZq, map_sub, coeff_zero_mul', qA0, qB0]
+    norm_num
+  have h1 : ModularFormClass.qCoeff (Z : ℍ → ℂ) 1 = 1728 := by
+    simp only [ModularFormClass.qCoeff, hZq, map_sub, coeff_one_mul, coeff_zero_mul', qA0, qA1, qB0,
+      qB1]
+    norm_num
+  have hW := ModularForm.levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant Z h0
+  have hZΔ : qExpansion 1 (Z : ℍ → ℂ) = PowerSeries.C 1728 * qExpansion 1 ModularForm.discriminant
+    :=
+    by
+    ext n
+    rw [PowerSeries.coeff_C_mul]
+    have := hW n
+    have h1' := h1
+    simp only [ModularFormClass.qCoeff] at this h1'
+    rw [this, h1']
+  have hL : ψ (𝔞 * (𝔞 * 𝔞) - 𝔟 * 𝔟) = 1728 * ψ 𝔡 := by
+    rw [ψ_apply, ← hZ, hZΔ, map_mul, HahnSeries.ofPowerSeries_C, map_ofNat, ψ𝔡]
+  rw [map_sub, map_mul, map_mul, map_mul] at hL
+  rw [← hL]
+  ring
+
+theorem ψ𝔡_ne_zero : ψ 𝔡 ≠ 0 := by
+  intro h
+  have h0 : (𝔡 : 𝒩) = 0 := (ψ_eq_zero_iff _).mp h
+  have : ModularForm.discriminant UpperHalfPlane.I = 0 := by
+    have := congrArg (fun f : 𝒩 => (f : ℍ → ℂ) UpperHalfPlane.I) h0
+    simp only [ZeroMemClass.coe_zero, Pi.zero_apply] at this
+    exact this
+  exact ModularForm.discriminant_ne_zero _ this
+
+theorem coeffEmb_jq : coeffEmb ℂ jq = jqModC ℂ := by
+  change (jqModC ℚ).map (algebraMap ℚ ℂ) = jqModC ℂ
+  exact map_jqModC _
+
+theorem J_mul_D : coeffEmb ℂ jq * ψ 𝔡 = ψ 𝔞 ^ 3 := by
+  rw [coeffEmb_jq, ModularCurve.jqModC_eq_qExpansion_E4_cube_div_discriminant, ← ψ𝔞, ← ψ𝔡,
+    div_mul_cancel₀ _ ψ𝔡_ne_zero]
+
+theorem J_sub_mul_D : (coeffEmb ℂ jq - algebraMap ℂ (LaurentSeries ℂ) 1728) * ψ 𝔡 = ψ 𝔟 ^ 2 := by
+  rw [map_ofNat, sub_mul, J_mul_D]
+  have := A_cube_sub_B_sq
+  linear_combination this
+
+theorem le_analyticOrderAt_sum {ι : Type*} (s : Finset ι) (F : ι → ℂ → ℂ) (z : ℂ) (b : ℕ∞)
+    (h : ∀ i ∈ s, b ≤ analyticOrderAt (F i) z) : b ≤ analyticOrderAt (∑ i ∈ s, F i) z := by
+  classical
+  induction s using Finset.induction_on with
+  | empty =>
+    rw [Finset.sum_empty, analyticOrderAt_eq_top.mpr (by simp)]
+    exact le_top
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha]
+    refine le_trans ?_ le_analyticOrderAt_add
+    exact le_min (h a (Finset.mem_insert_self a s)) (ih fun i hi => h i (Finset.mem_insert_of_mem
+      hi))
+
+theorem order_le_of_identity {p q d : ℂ → ℂ} {n m : ℕ} {C : ℕ → ℂ → ℂ} {z : ℂ}
+    (hp : AnalyticAt ℂ p z) (hq : AnalyticAt ℂ q z) (hd : AnalyticAt ℂ d z)
+    (hC : ∀ i ∈ Finset.range n, AnalyticAt ℂ (C i) z) (hd0 : d z ≠ 0)
+    (hid : p ^ (6 * n) * d ^ m + ∑ i ∈ Finset.range n, C i * (p ^ (6 * i) * (q ^ 6 * d) ^ (n - i)) =
+      0) :
+    analyticOrderAt q z ≤ analyticOrderAt p z := by
+  by_contra hlt'
+  have hlt := not_le.mp hlt'
+  obtain ⟨k, hk⟩ : ∃ k : ℕ, (k : ℕ∞) = analyticOrderAt p z :=
+    ENat.ne_top_iff_exists.mp (ne_top_of_lt hlt)
+  have hd_ord : analyticOrderAt d z = 0 := hd.analyticOrderAt_eq_zero.mpr hd0
+  have hL : analyticOrderAt (p ^ (6 * n) * d ^ m) z = ((6 * n * k : ℕ) : ℕ∞) := by
+    rw [analyticOrderAt_mul (hp.pow _) (hd.pow _), analyticOrderAt_pow hp, analyticOrderAt_pow hd,
+      ← hk, hd_ord]
+    simp only [nsmul_eq_mul, smul_zero, add_zero]
+    push_cast
+    ring
+  have hq_ord : ((k + 1 : ℕ) : ℕ∞) ≤ analyticOrderAt q z := by
+    rw [← hk] at hlt
+    have := Order.add_one_le_of_lt hlt
+    exact_mod_cast this
+  have hR : ∀ i ∈ Finset.range n, ((6 * n * k + 6 : ℕ) : ℕ∞) ≤
+      analyticOrderAt (C i * (p ^ (6 * i) * (q ^ 6 * d) ^ (n - i))) z := by
+    intro i hi
+    have hin : i < n := Finset.mem_range.mp hi
+    have hqd : AnalyticAt ℂ (q ^ 6 * d) z := (hq.pow _).mul hd
+    rw [analyticOrderAt_mul (hC i hi) ((hp.pow _).mul (hqd.pow _)),
+      analyticOrderAt_mul (hp.pow _) (hqd.pow _), analyticOrderAt_pow hp, analyticOrderAt_pow hqd,
+      analyticOrderAt_mul (hq.pow _) hd, analyticOrderAt_pow hq, hd_ord, ← hk, add_zero]
+    have h1 : ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞) ≤ (n - i) • (6 • analyticOrderAt q z) := by
+      have : (n - i) • (6 • (((k + 1 : ℕ)) : ℕ∞)) ≤ (n - i) • (6 • analyticOrderAt q z) :=
+        nsmul_le_nsmul_right (nsmul_le_nsmul_right hq_ord 6) (n - i)
+      refine le_trans (le_of_eq ?_) this
+      simp only [nsmul_eq_mul]
+      push_cast
+      ring
+    have h2 : ((6 * n * k + 6 : ℕ) : ℕ∞) ≤ ((6 * i) • (k : ℕ∞)) + ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞)
+      :=
+      by
+      have e : ((6 * i) • (k : ℕ∞)) + ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞) =
+          ((6 * i * k + 6 * (n - i) * (k + 1) : ℕ) : ℕ∞) := by
+        simp only [nsmul_eq_mul]
+        push_cast
+        ring
+      rw [e]
+      exact_mod_cast (show 6 * n * k + 6 ≤ 6 * i * k + 6 * (n - i) * (k + 1) by
+        obtain ⟨j, rfl⟩ := Nat.exists_eq_add_of_lt hin
+        rw [show i + j + 1 - i = j + 1 by omega]
+        nlinarith)
+    calc ((6 * n * k + 6 : ℕ) : ℕ∞)
+        ≤ (6 * i) • (k : ℕ∞) + ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞) := h2
+      _ ≤ (6 * i) • (k : ℕ∞) + (n - i) • (6 • analyticOrderAt q z) := add_le_add le_rfl h1
+      _ ≤ analyticOrderAt (C i) z + ((6 * i) • (k : ℕ∞) + (n - i) • (6 • analyticOrderAt q z)) :=
+          self_le_add_left _ _
+  have hsum := le_analyticOrderAt_sum (Finset.range n) _ z _ hR
+  have heq : p ^ (6 * n) * d ^ m = -(∑ i ∈ Finset.range n, C i * (p ^ (6 * i) * (q ^ 6 * d) ^ (n -
+    i))) :=
+    eq_neg_of_add_eq_zero_left hid
+  have : ((6 * n * k + 6 : ℕ) : ℕ∞) ≤ ((6 * n * k : ℕ) : ℕ∞) := by
+    rw [← hL, heq, analyticOrderAt_neg]
+    exact hsum
+  have := ENat.natCast_le_natCast.mp this
+  omega
+
+end ANb
+
+namespace ANb
+
+local notation "𝒩" => niceSubalgebra
+local notation "𝐉" => ModularCurve.coeffEmb ℂ ModularCurve.jq
+
+theorem ψ𝔞_ne_zero : ψ 𝔞 ≠ 0 := by
+  intro h
+  have h0 : qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) = 0 :=
+    HahnSeries.ofPowerSeries_injective (by rw [← ψ𝔞, h, map_zero])
+  have := qA0
+  rw [h0, map_zero] at this
+  exact zero_ne_one this
+
+theorem J_ne_zero : (𝐉) ≠ 0 := by
+  intro h
+  have := J_mul_D
+  rw [h, zero_mul] at this
+  exact pow_ne_zero 3 ψ𝔞_ne_zero this.symm
+
+theorem Jinv_mul_A_cube : (𝐉)⁻¹ * ψ 𝔞 ^ 3 = ψ 𝔡 := by
+  rw [← J_mul_D, ← mul_assoc, inv_mul_cancel₀ J_ne_zero, one_mul]
+
+def ev (z : ℍ) : 𝒩 →ₐ[ℂ] ℂ where
+  toFun f := (f : ℍ → ℂ) z
+  map_one' := rfl
+  map_mul' _ _ := rfl
+  map_zero' := rfl
+  map_add' _ _ := rfl
+  commutes' _ := rfl
+
+theorem ev_apply (z : ℍ) (f : 𝒩) : ev z f = (f : ℍ → ℂ) z := rfl
+
+theorem slash_coe_apply (f : ℍ → ℂ) (k : ℤ) (A : SL(2, ℤ)) (τ : ℍ) :
+    (f ∣[k] (A : GL (Fin 2) ℝ)) τ = f (A • τ) * denom (A : GL (Fin 2) ℝ) τ ^ (-k) := by
+  rw [← ModularForm.SL_slash]
+  exact ModularForm.SL_slash_apply f A τ
+
+theorem levelOne_apply_smul {k : ℤ} {F : Type*} [FunLike F ℍ ℂ]
+    [SlashInvariantFormClass F 𝒮ℒ k] (f : F) (A : SL(2, ℤ)) (τ : ℍ) :
+    f (A • τ) = denom (A : GL (Fin 2) ℝ) τ ^ k * f τ := by
+  have h1 := congrFun (SlashInvariantForm.slash_action_eqn f (A : GL (Fin 2) ℝ) ⟨A, rfl⟩) τ
+  rw [slash_coe_apply] at h1
+  have hδ := denom_ne_zero (A : GL (Fin 2) ℝ) τ
+  calc f (A • τ) = f (A • τ) * denom (A : GL (Fin 2) ℝ) τ ^ (-k) * denom (A : GL (Fin 2) ℝ) τ ^ k
+    := by
+        rw [mul_assoc, ← zpow_add₀ hδ, neg_add_cancel, zpow_zero, mul_one]
+    _ = denom (A : GL (Fin 2) ℝ) τ ^ k * f τ := by rw [h1, mul_comm]
+
+theorem 𝔞_apply_smul (A : SL(2, ℤ)) (τ : ℍ) :
+    (𝔞 : ℍ → ℂ) (A • τ) = denom (A : GL (Fin 2) ℝ) τ ^ 4 * (𝔞 : ℍ → ℂ) τ := by
+  have := levelOne_apply_smul ModularForm.E₄ A τ
+  simp only [zpow_ofNat] at this
+  exact this
+theorem 𝔟_apply_smul (A : SL(2, ℤ)) (τ : ℍ) :
+    (𝔟 : ℍ → ℂ) (A • τ) = denom (A : GL (Fin 2) ℝ) τ ^ 6 * (𝔟 : ℍ → ℂ) τ := by
+  have := levelOne_apply_smul ModularForm.E₆ A τ
+  simp only [zpow_ofNat] at this
+  exact this
+theorem 𝔡_apply_smul (A : SL(2, ℤ)) (τ : ℍ) :
+    (𝔡 : ℍ → ℂ) (A • τ) = denom (A : GL (Fin 2) ℝ) τ ^ 12 * (𝔡 : ℍ → ℂ) τ := by
+  have := levelOne_apply_smul CuspForm.discriminant A τ
+  simp only [zpow_ofNat] at this
+  exact this
+
+theorem tendsto_nice (f : 𝒩) :
+    Filter.Tendsto (f : ℍ → ℂ) atImInfty (nhds (PowerSeries.coeff 0 (qExpansion 1 (f : ℍ → ℂ))))
+      := by
+  refine ModularCurve.tendsto_atImInfty_of_hasSum_qParam 1 one_pos (f : ℍ → ℂ)
+    (fun m => PowerSeries.coeff m (qExpansion 1 (f : ℍ → ℂ))) fun τ => ?_
+  have := UpperHalfPlane.hasSum_qExpansion one_pos f.2.1 f.2.2.1 f.2.2.2 τ
+  simpa [smul_eq_mul] using this
+
+theorem norm_le_of_monic_relation {n : ℕ} {u : ℂ} {κ : ℕ → ℂ} {B : ℝ} (hB : 0 ≤ B)
+    (hκ : ∀ i ∈ Finset.range n, ‖κ i‖ ≤ B) (h : u ^ n + ∑ i ∈ Finset.range n, κ i * u ^ i = 0) :
+    ‖u‖ ≤ n * B + 1 := by
+  have hnB : 0 ≤ (n : ℝ) * B := mul_nonneg n.cast_nonneg hB
+  by_cases hu' : ‖u‖ ≤ 1
+  · linarith
+  have hu : 1 < ‖u‖ := not_le.mp hu'
+  have hn : n ≠ 0 := by
+    rintro rfl
+    simp at h
+  obtain ⟨n', rfl⟩ := Nat.exists_eq_succ_of_ne_zero hn
+  have hun : u ^ (n' + 1) = -∑ i ∈ Finset.range (n' + 1), κ i * u ^ i :=
+    eq_neg_of_add_eq_zero_left h
+  have hle : ‖u‖ ^ (n' + 1) ≤ (n' + 1 : ℕ) * B * ‖u‖ ^ n' := by
+    calc ‖u‖ ^ (n' + 1) = ‖u ^ (n' + 1)‖ := (norm_pow _ _).symm
+      _ = ‖∑ i ∈ Finset.range (n' + 1), κ i * u ^ i‖ := by rw [hun, norm_neg]
+      _ ≤ ∑ i ∈ Finset.range (n' + 1), ‖κ i * u ^ i‖ := norm_sum_le _ _
+      _ ≤ ∑ i ∈ Finset.range (n' + 1), B * ‖u‖ ^ n' := by
+          refine Finset.sum_le_sum fun i hi => ?_
+          rw [norm_mul, norm_pow]
+          have hi' : i ≤ n' := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)
+          exact mul_le_mul (hκ i hi) (pow_le_pow_right₀ hu.le hi') (pow_nonneg (norm_nonneg _) _) hB
+      _ = (n' + 1 : ℕ) * B * ‖u‖ ^ n' := by
+          rw [Finset.sum_const, Finset.card_range, nsmul_eq_mul]; ring
+  have hpos : 0 < ‖u‖ ^ n' := pow_pos (by linarith) _
+  rw [pow_succ, mul_comm] at hle
+  have := le_of_mul_le_mul_right hle hpos
+  linarith
+
+theorem coreC (𝔤 𝔥 : 𝒩) (X : LaurentSeries ℂ) (hX : X * ψ 𝔥 = ψ 𝔤) (M w : ℕ)
+    (h₂ : IsIntegral (Algebra.adjoin ℂ ({(𝐉)⁻¹} : Set (LaurentSeries ℂ)))
+      (X ^ (2 * M) * 𝐉 ^ (w * M + 1) * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (w * M))) :
+    ∃ (n m : ℕ) (K : ℕ → 𝒩),
+      (∀ i ∈ Finset.range n, ∀ (A : SL(2, ℤ)) (τ : ℍ), (K i : ℍ → ℂ) (A • τ) =
+          denom (A : GL (Fin 2) ℝ) τ ^ (12 * m) * (K i : ℍ → ℂ) τ) ∧
+      (𝔤 ^ (2 * M) * 𝔞 ^ (3 * (w * M) + 3) * 𝔟 ^ (2 * (w * M))) ^ n * 𝔞 ^ (3 * m) +
+        ∑ i ∈ Finset.range n, K i * ((𝔤 ^ (2 * M) * 𝔞 ^ (3 * (w * M) + 3) * 𝔟 ^ (2 * (w * M))) ^ i *
+          (𝔥 ^ (2 * M) * 𝔡 ^ (2 * (w * M) + 1)) ^ (n - i)) = 0 := by
+  classical
+  have key1 : (X ^ (2 * M) * 𝐉 ^ (w * M + 1) * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (w * M))
+    *
+      (ψ 𝔥 ^ (2 * M) * ψ 𝔡 ^ (2 * (w * M) + 1)) = ψ 𝔤 ^ (2 * M) * ψ 𝔞 ^ (3 * (w * M) + 3) * ψ 𝔟 ^ (2
+        * (w * M)) := by
+    calc (X ^ (2 * M) * 𝐉 ^ (w * M + 1) * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (w * M)) *
+          (ψ 𝔥 ^ (2 * M) * ψ 𝔡 ^ (2 * (w * M) + 1))
+        = (X * ψ 𝔥) ^ (2 * M) * (𝐉 * ψ 𝔡) ^ (w * M + 1) * ((𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728)
+          * ψ 𝔡) ^ (w * M) := by
+          rw [mul_pow (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) (ψ 𝔡) (w * M), mul_pow X (ψ 𝔥),
+            mul_pow (𝐉) (ψ 𝔡)]
+          ring
+      _ = (ψ 𝔤) ^ (2 * M) * (ψ 𝔞 ^ 3) ^ (w * M + 1) * (ψ 𝔟 ^ 2) ^ (w * M) := by rw [hX, J_mul_D,
+        J_sub_mul_D]
+      _ = ψ 𝔤 ^ (2 * M) * ψ 𝔞 ^ (3 * (w * M) + 3) * ψ 𝔟 ^ (2 * (w * M)) := by
+          rw [← pow_mul, ← pow_mul, show 3 * (w * M + 1) = 3 * (w * M) + 3 by ring]
+  obtain ⟨p, hpm, hpev⟩ := h₂
+  rw [hpm.as_sum] at hpev
+  simp only [Polynomial.eval₂_add, Polynomial.eval₂_pow, Polynomial.eval₂_X,
+    Polynomial.eval₂_finsetSum,
+    Polynomial.eval₂_mul, Polynomial.eval₂_C] at hpev
+  set R := Algebra.adjoin ℂ ({(𝐉)⁻¹} : Set (LaurentSeries ℂ)) with hR
+  set Y := X ^ (2 * M) * 𝐉 ^ (w * M + 1) * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (w * M) with
+    hY
+  set n := p.natDegree with hn
+  clear_value Y
+  have hmem : ∀ i, ∃ c : Polynomial ℂ,
+      Polynomial.aeval ((𝐉)⁻¹) c = algebraMap R (LaurentSeries ℂ) (p.coeff i) := by
+    intro i
+    have hi' : algebraMap R (LaurentSeries ℂ) (p.coeff i) ∈ (Polynomial.aeval (R := ℂ)
+      ((𝐉)⁻¹)).range :=
+      by
+      rw [← Algebra.adjoin_singleton_eq_range_aeval]
+      exact (p.coeff i).2
+    exact hi'
+  choose c hc using hmem
+  set m := ∑ i ∈ Finset.range n, (c i).natDegree with hm
+  have hdeg : ∀ i ∈ Finset.range n, (c i).natDegree ≤ m := fun i hi =>
+    Finset.single_le_sum (f := fun j => (c j).natDegree) (fun j _ => Nat.zero_le _) hi
+  clear_value m
+  let K : ℕ → 𝒩 := fun i =>
+    ∑ l ∈ Finset.range ((c i).natDegree + 1), algebraMap ℂ 𝒩 ((c i).coeff l) * (𝔡 ^ l * 𝔞 ^ (3 * (m
+      - l)))
+  have key3 : ∀ i ∈ Finset.range n, ψ 𝔞 ^ (3 * m) * algebraMap R (LaurentSeries ℂ) (p.coeff i) = ψ
+    (K i) :=
+    by
+    intro i hi
+    simp only [K, map_sum, map_mul, map_pow, AlgHom.commutes]
+    rw [← hc i, Polynomial.aeval_eq_sum_range, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun l hl => ?_
+    have hlm : l ≤ m := (Nat.lt_succ_iff.mp (Finset.mem_range.mp hl)).trans (hdeg i hi)
+    rw [Algebra.smul_def, mul_left_comm]
+    congr 1
+    calc ψ 𝔞 ^ (3 * m) * (𝐉)⁻¹ ^ l = ψ 𝔞 ^ (3 * (m - l)) * (ψ 𝔞 ^ 3) ^ l * (𝐉)⁻¹ ^ l := by
+          rw [← pow_mul, ← pow_add, show 3 * (m - l) + 3 * l = 3 * m by omega]
+      _ = ψ 𝔞 ^ (3 * (m - l)) * ((𝐉)⁻¹ * ψ 𝔞 ^ 3) ^ l := by rw [mul_pow ((𝐉)⁻¹)]; ring
+      _ = ψ 𝔡 ^ l * ψ 𝔞 ^ (3 * (m - l)) := by rw [Jinv_mul_A_cube, mul_comm]
+  let W : 𝒩 := 𝔤 ^ (2 * M) * 𝔞 ^ (3 * (w * M) + 3) * 𝔟 ^ (2 * (w * M))
+  let V : 𝒩 := 𝔥 ^ (2 * M) * 𝔡 ^ (2 * (w * M) + 1)
+  have k1 : Y * ψ V = ψ W := by
+    simp only [W, V, map_mul, map_pow]
+    exact key1
+  have key2 : ∀ i ≤ n, ψ V ^ n * Y ^ i = ψ W ^ i * ψ V ^ (n - i) := by
+    intro i hi
+    have e : ψ V ^ n = ψ V ^ i * ψ V ^ (n - i) := by
+      rw [← pow_add, Nat.add_sub_cancel' hi]
+    calc ψ V ^ n * Y ^ i = (Y * ψ V) ^ i * ψ V ^ (n - i) := by
+          rw [e, mul_pow Y (ψ V) i]; ring
+      _ = ψ W ^ i * ψ V ^ (n - i) := by rw [k1]
+  let E : 𝒩 := W ^ n * 𝔞 ^ (3 * m) + ∑ i ∈ Finset.range n, K i * (W ^ i * V ^ (n - i))
+  have hE : ψ E = ψ V ^ n * ψ 𝔞 ^ (3 * m) *
+      (Y ^ n + ∑ i ∈ Finset.range n, algebraMap R (LaurentSeries ℂ) (p.coeff i) * Y ^ i) := by
+    rw [mul_add, Finset.mul_sum]
+    simp only [E, map_add, map_sum, map_mul, map_pow]
+    congr 1
+    · have h2 := key2 n le_rfl
+      rw [Nat.sub_self, pow_zero, mul_one] at h2
+      rw [mul_right_comm, h2]
+    · refine Finset.sum_congr rfl fun i hi => ?_
+      have hin : i ≤ n := (Finset.mem_range.mp hi).le
+      rw [← key3 i hi, ← key2 i hin]
+      ring
+  have hE0 : E = 0 := by
+    apply ψ_injective
+    rw [hE, hpev, mul_zero, map_zero]
+  refine ⟨n, m, K, fun i hi A τ => ?_, hE0⟩
+  have hlm : ∀ l ∈ Finset.range ((c i).natDegree + 1), l ≤ m := fun l hl =>
+    (Nat.lt_succ_iff.mp (Finset.mem_range.mp hl)).trans (hdeg i hi)
+  change ev (A • τ) (K i) = denom (A : GL (Fin 2) ℝ) τ ^ (12 * m) * ev τ (K i)
+  simp only [K, map_sum, map_mul, map_pow, AlgHom.commutes, Finset.mul_sum]
+  refine Finset.sum_congr rfl fun l hl => ?_
+  rw [ev_apply, ev_apply, ev_apply, ev_apply, 𝔡_apply_smul, 𝔞_apply_smul,
+    show 12 * m = 12 * l + 4 * (3 * (m - l)) by have := hlm l hl; omega]
+  ring
+
+theorem coreC2 (𝔤 𝔥 : 𝒩) (X : LaurentSeries ℂ) (hX : X * ψ 𝔥 = ψ 𝔤) (w : ℕ)
+    (h₂ : IsIntegral (Algebra.adjoin ℂ ({(𝐉)⁻¹} : Set (LaurentSeries ℂ)))
+      (X ^ 2 * 𝐉 ^ w * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ w)) :
+    ∃ (n m : ℕ) (K : ℕ → 𝒩),
+      (∀ i ∈ Finset.range n, ∀ (A : SL(2, ℤ)) (τ : ℍ), (K i : ℍ → ℂ) (A • τ) =
+          denom (A : GL (Fin 2) ℝ) τ ^ (12 * m) * (K i : ℍ → ℂ) τ) ∧
+      (𝔤 ^ 2 * 𝔞 ^ (3 * w) * 𝔟 ^ (2 * w)) ^ n * 𝔞 ^ (3 * m) +
+        ∑ i ∈ Finset.range n, K i * ((𝔤 ^ 2 * 𝔞 ^ (3 * w) * 𝔟 ^ (2 * w)) ^ i *
+          (𝔥 ^ 2 * 𝔡 ^ (2 * w)) ^ (n - i)) = 0 := by
+  classical
+  have key1 : (X ^ 2 * 𝐉 ^ w * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ w) *
+      (ψ 𝔥 ^ 2 * ψ 𝔡 ^ (2 * w)) = ψ 𝔤 ^ 2 * ψ 𝔞 ^ (3 * w) * ψ 𝔟 ^ (2 * w) := by
+    calc (X ^ 2 * 𝐉 ^ w * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ w) *
+          (ψ 𝔥 ^ 2 * ψ 𝔡 ^ (2 * w))
+        = (X * ψ 𝔥) ^ 2 * (𝐉 * ψ 𝔡) ^ w * ((𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) * ψ 𝔡) ^ w
+          := by
+          rw [mul_pow (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) (ψ 𝔡) w, mul_pow X (ψ 𝔥), mul_pow
+            (𝐉) (ψ 𝔡), two_mul, pow_add]
+          ring
+      _ = (ψ 𝔤) ^ 2 * (ψ 𝔞 ^ 3) ^ w * (ψ 𝔟 ^ 2) ^ w := by rw [hX, J_mul_D, J_sub_mul_D]
+      _ = ψ 𝔤 ^ 2 * ψ 𝔞 ^ (3 * w) * ψ 𝔟 ^ (2 * w) := by
+          rw [← pow_mul, ← pow_mul]
+  obtain ⟨p, hpm, hpev⟩ := h₂
+  rw [hpm.as_sum] at hpev
+  simp only [Polynomial.eval₂_add, Polynomial.eval₂_pow, Polynomial.eval₂_X,
+    Polynomial.eval₂_finsetSum,
+    Polynomial.eval₂_mul, Polynomial.eval₂_C] at hpev
+  set R := Algebra.adjoin ℂ ({(𝐉)⁻¹} : Set (LaurentSeries ℂ)) with hR
+  set Y := X ^ 2 * 𝐉 ^ w * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ w with hY
+  set n := p.natDegree with hn
+  clear_value Y
+  have hmem : ∀ i, ∃ c : Polynomial ℂ,
+      Polynomial.aeval ((𝐉)⁻¹) c = algebraMap R (LaurentSeries ℂ) (p.coeff i) := by
+    intro i
+    have hi' : algebraMap R (LaurentSeries ℂ) (p.coeff i) ∈ (Polynomial.aeval (R := ℂ)
+      ((𝐉)⁻¹)).range :=
+      by
+      rw [← Algebra.adjoin_singleton_eq_range_aeval]
+      exact (p.coeff i).2
+    exact hi'
+  choose c hc using hmem
+  set m := ∑ i ∈ Finset.range n, (c i).natDegree with hm
+  have hdeg : ∀ i ∈ Finset.range n, (c i).natDegree ≤ m := fun i hi =>
+    Finset.single_le_sum (f := fun j => (c j).natDegree) (fun j _ => Nat.zero_le _) hi
+  clear_value m
+  let K : ℕ → 𝒩 := fun i =>
+    ∑ l ∈ Finset.range ((c i).natDegree + 1), algebraMap ℂ 𝒩 ((c i).coeff l) * (𝔡 ^ l * 𝔞 ^ (3 * (m
+      - l)))
+  have key3 : ∀ i ∈ Finset.range n, ψ 𝔞 ^ (3 * m) * algebraMap R (LaurentSeries ℂ) (p.coeff i) = ψ
+    (K i) :=
+    by
+    intro i hi
+    simp only [K, map_sum, map_mul, map_pow, AlgHom.commutes]
+    rw [← hc i, Polynomial.aeval_eq_sum_range, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun l hl => ?_
+    have hlm : l ≤ m := (Nat.lt_succ_iff.mp (Finset.mem_range.mp hl)).trans (hdeg i hi)
+    rw [Algebra.smul_def, mul_left_comm]
+    congr 1
+    calc ψ 𝔞 ^ (3 * m) * (𝐉)⁻¹ ^ l = ψ 𝔞 ^ (3 * (m - l)) * (ψ 𝔞 ^ 3) ^ l * (𝐉)⁻¹ ^ l := by
+          rw [← pow_mul, ← pow_add, show 3 * (m - l) + 3 * l = 3 * m by omega]
+      _ = ψ 𝔞 ^ (3 * (m - l)) * ((𝐉)⁻¹ * ψ 𝔞 ^ 3) ^ l := by rw [mul_pow ((𝐉)⁻¹)]; ring
+      _ = ψ 𝔡 ^ l * ψ 𝔞 ^ (3 * (m - l)) := by rw [Jinv_mul_A_cube, mul_comm]
+  let W : 𝒩 := 𝔤 ^ 2 * 𝔞 ^ (3 * w) * 𝔟 ^ (2 * w)
+  let V : 𝒩 := 𝔥 ^ 2 * 𝔡 ^ (2 * w)
+  have k1 : Y * ψ V = ψ W := by
+    simp only [W, V, map_mul, map_pow]
+    exact key1
+  have key2 : ∀ i ≤ n, ψ V ^ n * Y ^ i = ψ W ^ i * ψ V ^ (n - i) := by
+    intro i hi
+    have e : ψ V ^ n = ψ V ^ i * ψ V ^ (n - i) := by
+      rw [← pow_add, Nat.add_sub_cancel' hi]
+    calc ψ V ^ n * Y ^ i = (Y * ψ V) ^ i * ψ V ^ (n - i) := by
+          rw [e, mul_pow Y (ψ V) i]; ring
+      _ = ψ W ^ i * ψ V ^ (n - i) := by rw [k1]
+  let E : 𝒩 := W ^ n * 𝔞 ^ (3 * m) + ∑ i ∈ Finset.range n, K i * (W ^ i * V ^ (n - i))
+  have hE : ψ E = ψ V ^ n * ψ 𝔞 ^ (3 * m) *
+      (Y ^ n + ∑ i ∈ Finset.range n, algebraMap R (LaurentSeries ℂ) (p.coeff i) * Y ^ i) := by
+    rw [mul_add, Finset.mul_sum]
+    simp only [E, map_add, map_sum, map_mul, map_pow]
+    congr 1
+    · have h2 := key2 n le_rfl
+      rw [Nat.sub_self, pow_zero, mul_one] at h2
+      rw [mul_right_comm, h2]
+    · refine Finset.sum_congr rfl fun i hi => ?_
+      have hin : i ≤ n := (Finset.mem_range.mp hi).le
+      rw [← key3 i hi, ← key2 i hin]
+      ring
+  have hE0 : E = 0 := by
+    apply ψ_injective
+    rw [hE, hpev, mul_zero, map_zero]
+  refine ⟨n, m, K, fun i hi A τ => ?_, hE0⟩
+  have hlm : ∀ l ∈ Finset.range ((c i).natDegree + 1), l ≤ m := fun l hl =>
+    (Nat.lt_succ_iff.mp (Finset.mem_range.mp hl)).trans (hdeg i hi)
+  change ev (A • τ) (K i) = denom (A : GL (Fin 2) ℝ) τ ^ (12 * m) * ev τ (K i)
+  simp only [K, map_sum, map_mul, map_pow, AlgHom.commutes, Finset.mul_sum]
+  refine Finset.sum_congr rfl fun l hl => ?_
+  rw [ev_apply, ev_apply, ev_apply, ev_apply, 𝔡_apply_smul, 𝔞_apply_smul,
+    show 12 * m = 12 * l + 4 * (3 * (m - l)) by have := hlm l hl; omega]
+  ring
+
+end ANb
+
+open ANb in
+theorem solution (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hT : ModularGroup.T ∈ Γ) {k : ℤ} (m : ℕ)
+    (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (X : LaurentSeries ℂ)
+    (hX : X * ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) = ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ))
+    (h₂ : IsIntegral (Algebra.adjoin ℂ ({(ModularCurve.jqModC ℂ)⁻¹} : Set (LaurentSeries ℂ)))
+      (X ^ 2 * ModularCurve.jqModC ℂ ^ m * (ModularCurve.jqModC ℂ - algebraMap ℂ (LaurentSeries ℂ)
+        1728) ^ m))
+    (A : Matrix.SpecialLinearGroup (Fin 2) ℤ) :
+    ∃ C : ℝ, ∀ᶠ τ : UpperHalfPlane in UpperHalfPlane.atImInfty,
+      ‖((fun z : UpperHalfPlane => g z * (ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) ^ m) ∣[k + 14 *
+        (m : ℤ)] (A : GL (Fin 2) ℝ)) τ‖ ≤
+        C * ‖((fun z : UpperHalfPlane => h z * ModularForm.discriminant z ^ m) ∣[k + 12 * (m : ℤ)]
+          (A : GL (Fin 2) ℝ)) τ‖ := by
+  classical
+  have h₂' : IsIntegral (Algebra.adjoin ℂ ({(ModularCurve.coeffEmb ℂ ModularCurve.jq)⁻¹} : Set
+    (LaurentSeries ℂ)))
+      (X ^ 2 * ModularCurve.coeffEmb ℂ ModularCurve.jq ^ m *
+        (ModularCurve.coeffEmb ℂ ModularCurve.jq - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ m) := by
+    rw [ANb.coeffEmb_jq]; exact h₂
+  obtain ⟨n, μ, K, hK, hE⟩ := ANb.coreC2 (ANb.ofMF g (ANb.one_mem_strictPeriods_of_T_mem hT))
+    (ANb.ofMF h (ANb.one_mem_strictPeriods_of_T_mem hT)) X hX m h₂'
+  let κ0 : ℕ → ℝ := fun i => ‖PowerSeries.coeff 0 (qExpansion 1 (K i : ℍ → ℂ))‖ + 1
+  let B : ℝ := 1 + ∑ i ∈ Finset.range n, κ0 i
+  have hκ0 : ∀ i, 0 ≤ κ0 i := fun i => by positivity
+  have hB1 : 1 ≤ B := le_add_of_nonneg_right (Finset.sum_nonneg fun i _ => hκ0 i)
+  have hκB : ∀ i ∈ Finset.range n, κ0 i ≤ B := fun i hi =>
+    (Finset.single_le_sum (f := κ0) (fun j _ => hκ0 j) hi).trans (le_add_of_nonneg_left zero_le_one)
+  let B' : ℝ := B * 2 ^ (3 * μ)
+  have hB' : 0 ≤ B' := by positivity
+  let C : ℝ := n * B' + 1
+  have hC : 1 ≤ C := le_add_of_nonneg_left (by positivity)
+  have hC0 : 0 ≤ C := by linarith
+  let Cf : ℝ := C * (3 / 2) ^ m
+  have hCf1 : 1 ≤ Cf := one_le_mul_of_one_le_of_one_le hC (one_le_pow₀ (by norm_num))
+  have hCf0 : 0 ≤ Cf := by linarith
+  refine ⟨Cf, ?_⟩
+  have t4 : Filter.Tendsto (fun τ : ℍ => ModularForm.E₄ τ) atImInfty (nhds 1) := by
+    have := ANb.tendsto_nice ANb.𝔞
+    rwa [show PowerSeries.coeff 0 (qExpansion 1 ((ANb.𝔞 : ℍ → ℂ))) = 1 from ANb.qA0] at this
+  have t6 : Filter.Tendsto (fun τ : ℍ => ModularForm.E₆ τ) atImInfty (nhds 1) := by
+    have := ANb.tendsto_nice ANb.𝔟
+    rwa [show PowerSeries.coeff 0 (qExpansion 1 ((ANb.𝔟 : ℍ → ℂ))) = 1 from ANb.qB0] at this
+  have e4 : ∀ᶠ τ : ℍ in atImInfty, dist (ModularForm.E₄ τ) 1 < 1 / 2 :=
+    Metric.tendsto_nhds.mp t4 _ (by norm_num)
+  have e6 : ∀ᶠ τ : ℍ in atImInfty, dist (ModularForm.E₆ τ) 1 < 1 / 2 :=
+    Metric.tendsto_nhds.mp t6 _ (by norm_num)
+  have eK : ∀ᶠ τ : ℍ in atImInfty, ∀ i ∈ Finset.range n, ‖(K i : ℍ → ℂ) τ‖ ≤ κ0 i := by
+    refine (Filter.eventually_all_finset _).mpr fun i _ => ?_
+    have := Metric.tendsto_nhds.mp (ANb.tendsto_nice (K i)) 1 one_pos
+    filter_upwards [this] with τ hτ
+    rw [dist_eq_norm] at hτ
+    exact (norm_le_insert' _ _).trans (by simp only [κ0]; linarith)
+  filter_upwards [e4, e6, eK] with τ h4 h6 hKτ
+  rw [dist_eq_norm] at h4 h6
+  set δ : ℂ := denom (A : GL (Fin 2) ℝ) τ with hδdef
+  have hδ : δ ≠ 0 := denom_ne_zero _ _
+  set a : ℂ := ModularForm.E₄ τ with ha
+  set b : ℂ := ModularForm.E₆ τ with hb
+  set d : ℂ := ModularForm.discriminant τ with hdd
+  have ha_lo : 1 / 2 < ‖a‖ := by
+    have := norm_le_insert' (1 : ℂ) a; rw [norm_one, norm_sub_rev] at this; linarith
+  have ha_hi : ‖a‖ < 3 / 2 := by
+    have := norm_le_insert' a (1 : ℂ); rw [norm_one] at this; linarith
+  have hb_lo : 1 / 2 < ‖b‖ := by
+    have := norm_le_insert' (1 : ℂ) b; rw [norm_one, norm_sub_rev] at this; linarith
+  have ha0 : a ≠ 0 := fun h0 => by rw [h0, norm_zero] at ha_lo; linarith
+  have hb0 : b ≠ 0 := fun h0 => by rw [h0, norm_zero] at hb_lo; linarith
+  have hd0 : d ≠ 0 := ModularForm.discriminant_ne_zero τ
+  set z : ℍ := A • τ with hz
+  have hE4z : ModularForm.E₄ z = δ ^ 4 * a := ANb.𝔞_apply_smul A τ
+  have hE6z : ModularForm.E₆ z = δ ^ 6 * b := ANb.𝔟_apply_smul A τ
+  have hΔz : ModularForm.discriminant z = δ ^ 12 * d := ANb.𝔡_apply_smul A τ
+  have hKz : ∀ i ∈ Finset.range n, (K i : ℍ → ℂ) z = δ ^ (12 * μ) * (K i : ℍ → ℂ) τ :=
+    fun i hi => hK i hi A τ
+  set u : ℂ := g z ^ 2 * ModularForm.E₄ z ^ (3 * m) * ModularForm.E₆ z ^ (2 * m) with hu
+  set v : ℂ := h z ^ 2 * ModularForm.discriminant z ^ (2 * m) with hv
+  have hid : u ^ n * ModularForm.E₄ z ^ (3 * μ) +
+      ∑ i ∈ Finset.range n, (K i : ℍ → ℂ) z * (u ^ i * v ^ (n - i)) = 0 := by
+    have := congrArg (ANb.ev z) hE
+    simp only [map_add, map_sum, map_mul, map_pow, map_zero, ANb.ev_apply] at this
+    exact this
+  clear_value u v
+  rw [ANb.slash_coe_apply, ANb.slash_coe_apply]
+  change ‖g z * (ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) ^ m * δ ^ (-(k + 14 * (m : ℤ)))‖ ≤
+    Cf * ‖h z * ModularForm.discriminant z ^ m * δ ^ (-(k + 12 * (m : ℤ)))‖
+  have hE4z0 : ModularForm.E₄ z ≠ 0 := by rw [hE4z]; exact mul_ne_zero (pow_ne_zero _ hδ) ha0
+  have hE6z0 : ModularForm.E₆ z ≠ 0 := by rw [hE6z]; exact mul_ne_zero (pow_ne_zero _ hδ) hb0
+  have hΔz0 : ModularForm.discriminant z ≠ 0 := ModularForm.discriminant_ne_zero z
+  by_cases hv0 : v = 0
+  · have hsum0 : ∑ i ∈ Finset.range n, (K i : ℍ → ℂ) z * (u ^ i * v ^ (n - i)) = 0 := by
+      refine Finset.sum_eq_zero fun i hi => ?_
+      have : n - i ≠ 0 := Nat.sub_ne_zero_of_lt (Finset.mem_range.mp hi)
+      rw [hv0, zero_pow this, mul_zero, mul_zero]
+    rw [hsum0, add_zero] at hid
+    have hu0 : u = 0 := by
+      rcases mul_eq_zero.mp hid with h1 | h1
+      · exact pow_eq_zero_iff' |>.mp h1 |>.1
+      · exact absurd (pow_eq_zero_iff' |>.mp h1 |>.1) hE4z0
+    have hg0 : g z = 0 := by
+      simp only [hu, mul_eq_zero, pow_eq_zero_iff', ne_eq] at hu0
+      rcases hu0 with (⟨h1, _⟩ | ⟨h1, _⟩) | ⟨h1, _⟩
+      · exact h1
+      · exact absurd h1 hE4z0
+      · exact absurd h1 hE6z0
+    rw [hg0, zero_mul, zero_mul, norm_zero]
+    positivity
+  set U : ℂ := u / v with hU
+  have huv : u = U * v := by rw [hU, div_mul_cancel₀ _ hv0]
+  let κ : ℕ → ℂ := fun i => (K i : ℍ → ℂ) τ / a ^ (3 * μ)
+  have ha3 : a ^ (3 * μ) ≠ 0 := pow_ne_zero _ ha0
+  have hE4zm : ModularForm.E₄ z ^ (3 * μ) = δ ^ (12 * μ) * a ^ (3 * μ) := by
+    rw [hE4z, mul_pow, ← pow_mul, show 4 * (3 * μ) = 12 * μ by ring]
+  have hκ : ∀ i ∈ Finset.range n, (K i : ℍ → ℂ) z = κ i * ModularForm.E₄ z ^ (3 * μ) := by
+    intro i hi
+    rw [hKz i hi, hE4zm]
+    simp only [κ]
+    rw [div_mul_eq_mul_div, eq_div_iff ha3]
+    ring
+  have hrel : U ^ n + ∑ i ∈ Finset.range n, κ i * U ^ i = 0 := by
+    have hvn : v ^ n * ModularForm.E₄ z ^ (3 * μ) ≠ 0 :=
+      mul_ne_zero (pow_ne_zero _ hv0) (pow_ne_zero _ hE4z0)
+    apply (mul_eq_zero.mp ?_).resolve_right hvn
+    rw [← hid, add_mul, Finset.sum_mul]
+    congr 1
+    · rw [huv, mul_pow]; ring
+    · refine Finset.sum_congr rfl fun i hi => ?_
+      have hin : i ≤ n := (Finset.mem_range.mp hi).le
+      rw [hκ i hi, huv, mul_pow, show v ^ n = v ^ i * v ^ (n - i) by rw [← pow_add,
+        Nat.add_sub_cancel' hin]]
+      ring
+  have h22 : (2 : ℝ) ^ (3 * μ) * (1 / 2) ^ (3 * μ) = 1 := by rw [← mul_pow]; norm_num
+  have hκbd : ∀ i ∈ Finset.range n, ‖κ i‖ ≤ B' := by
+    intro i hi
+    simp only [κ, norm_div, norm_pow]
+    have ha3pos : (0 : ℝ) < ‖a‖ ^ (3 * μ) := pow_pos (by linarith) _
+    rw [div_le_iff₀ ha3pos]
+    have h1 : ‖(K i : ℍ → ℂ) τ‖ ≤ B := (hKτ i hi).trans (hκB i hi)
+    have h2 : (1 / 2 : ℝ) ^ (3 * μ) ≤ ‖a‖ ^ (3 * μ) := pow_le_pow_left₀ (by norm_num) ha_lo.le _
+    calc ‖(K i : ℍ → ℂ) τ‖ ≤ B := h1
+      _ = B * 2 ^ (3 * μ) * (1 / 2 : ℝ) ^ (3 * μ) := by rw [mul_assoc, h22, mul_one]
+      _ ≤ B * 2 ^ (3 * μ) * ‖a‖ ^ (3 * μ) :=
+          mul_le_mul_of_nonneg_left h2 (mul_nonneg (by linarith) (by positivity))
+  have hUC : ‖U‖ ≤ C := ANb.norm_le_of_monic_relation hB' hκbd hrel
+  set t : ℝ := ‖δ‖ with ht
+  have ht0 : 0 < t := norm_pos_iff.mpr hδ
+  set ρ : ℝ := ‖δ ^ (-(k + 14 * (m : ℤ)))‖ with hρ
+  have hρ0 : 0 < ρ := norm_pos_iff.mpr (zpow_ne_zero _ hδ)
+  have hρ1 : ‖δ ^ (-(k + 12 * (m : ℤ)))‖ = ρ * t ^ (2 * m) := by
+    rw [show -(k + 12 * (m : ℤ)) = -(k + 14 * (m : ℤ)) + ((2 * m : ℕ) : ℤ) by
+      push_cast; ring, zpow_add₀ hδ, norm_mul,
+      ← hρ, zpow_natCast, norm_pow, ← ht]
+  set P : ℝ := ‖g z * (ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) ^ m * δ ^ (-(k + 14 * (m : ℤ)))‖
+    with hP
+  set Q : ℝ := ‖h z * ModularForm.discriminant z ^ m * δ ^ (-(k + 12 * (m : ℤ)))‖ with hQ
+  have hPe : P = ‖g z‖ * ((t ^ 4 * ‖a‖) ^ 2 * (t ^ 6 * ‖b‖)) ^ m * ρ := by
+    rw [hP, norm_mul, norm_mul, ← hρ, norm_pow, norm_mul, norm_pow, hE4z, hE6z, norm_mul, norm_mul,
+      norm_pow, norm_pow]
+  have hQe : Q = ‖h z‖ * (t ^ 12 * ‖d‖) ^ m * (ρ * t ^ (2 * m)) := by
+    rw [hQ, norm_mul, norm_mul, hρ1, norm_pow, hΔz, norm_mul, norm_pow]
+  have hue : ‖u‖ = ‖g z‖ ^ 2 * (t ^ 4 * ‖a‖) ^ (3 * m) * (t ^ 6 * ‖b‖) ^ (2 * m) := by
+    rw [hu, norm_mul, norm_mul, norm_pow, norm_pow, norm_pow, hE4z, hE6z, norm_mul, norm_mul,
+      norm_pow, norm_pow]
+  have hve : ‖v‖ = ‖h z‖ ^ 2 * (t ^ 12 * ‖d‖) ^ (2 * m) := by
+    rw [hv, norm_mul, norm_pow, norm_pow, hΔz, norm_mul, norm_pow]
+  have hv' : 0 < ‖v‖ := norm_pos_iff.mpr hv0
+  have hT' : P ^ 2 * ‖v‖ = ‖u‖ * ‖a‖ ^ m * Q ^ 2 := by
+    rw [hPe, hQe, hue, hve]
+    ring
+  have hT : P ^ 2 = ‖U‖ * ‖a‖ ^ m * Q ^ 2 := by
+    have hUn : ‖U‖ = ‖u‖ / ‖v‖ := by rw [hU, norm_div]
+    rw [hUn, show ‖u‖ / ‖v‖ * ‖a‖ ^ m * Q ^ 2 = (‖u‖ * ‖a‖ ^ m * Q ^ 2) / ‖v‖ by
+      ring, eq_div_iff hv'.ne']
+    exact hT'
+  have hPnn : 0 ≤ P := norm_nonneg _
+  have hQnn : 0 ≤ Q := norm_nonneg _
+  have hcoef : ‖U‖ * ‖a‖ ^ m ≤ Cf := by
+    refine mul_le_mul hUC (pow_le_pow_left₀ (norm_nonneg _) ha_hi.le _) (by positivity) hC0
+  have hsq : P ^ 2 ≤ (Cf * Q) ^ 2 := by
+    calc P ^ 2 = ‖U‖ * ‖a‖ ^ m * Q ^ 2 := hT
+      _ ≤ Cf * Q ^ 2 := mul_le_mul_of_nonneg_right hcoef (by positivity)
+      _ ≤ Cf * Cf * Q ^ 2 := by
+          refine mul_le_mul_of_nonneg_right ?_ (by positivity)
+          exact le_mul_of_one_le_left hCf0 hCf1
+      _ = (Cf * Q) ^ 2 := by ring
+  exact (pow_le_pow_iff_left₀ hPnn (mul_nonneg hCf0 hQnn) two_ne_zero).mp hsq
+
+end
+end S_ModularCurve_eventually_norm_slash_le_mul_of_isIntegral_adjoin_jqModC_inv_sq
+end P2MW
+export P2MW.S_ModularCurve_eventually_norm_slash_le_mul_of_isIntegral_adjoin_jqModC_inv_sq
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+open scoped MatrixGroups ModularForm
+theorem ModularCurve.eventually_norm_slash_le_mul_of_isIntegral_adjoin_jqModC_inv_sq
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    {k : ℤ} (m : ℕ)
+    (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (X : LaurentSeries ℂ)
+    (hX : X * ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) = ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ))
+    (h₂ : IsIntegral (Algebra.adjoin ℂ ({(ModularCurve.jqModC ℂ)⁻¹} : Set (LaurentSeries ℂ)))
+      (X ^ 2 * ModularCurve.jqModC ℂ ^ m * (ModularCurve.jqModC ℂ - algebraMap ℂ (LaurentSeries ℂ)
+        1728) ^ m))
+    (A : Matrix.SpecialLinearGroup (Fin 2) ℤ) :
+    ∃ C : ℝ, ∀ᶠ τ : UpperHalfPlane in UpperHalfPlane.atImInfty,
+      ‖((fun z : UpperHalfPlane => g z * (ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) ^ m) ∣[k + 14 *
+        (m : ℤ)] (A : GL (Fin 2) ℝ)) τ‖ ≤
+        C * ‖((fun z : UpperHalfPlane => h z * ModularForm.discriminant z ^ m) ∣[k + 12 * (m : ℤ)]
+          (A : GL (Fin 2) ℝ)) τ‖ :=
+  solution Γ hT m g h X hX h₂ A
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv.lean
new file mode 100644
index 0000000000..e47908b2c3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv.lean
@@ -0,0 +1,820 @@
+/-
+Based on Prove2Me node ModularCurve.eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv
+(c7bb4faf-6bfe-592f-aa5c-b6db0facab22) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 232bb036-5066-5027-a94f-46a2abc86ff8
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import Mathlib.Data.Int.Star
+import Mathlib.Order.CompletePartialOrder
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_tendsto_atImInfty_of_hasSum_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_four_qCoeff_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_six_qCoeff_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality over ℂ[j⁻¹] forces cuspidal decay of gE₄²E₆
+
+Theorem statement: `ModularCurve.eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv`
+(`c7bb4faf-6bfe-592f-aa5c-b6db0facab22`), by Claude, 2026-09-05.
+
+Proof: submission `232bb036-5066-5027-a94f-46a2abc86ff8`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, $k$ an integer, and let $g,h$ be modular forms of weight $k$ for
+$\Gamma_0(N)$ with $h \neq 0$. Let $X \in \mathbb{C}((q))$ be a Laurent series such that $X$ times
+the $q$-expansion of $h$ of period $1$ (viewed as a power series, then as a Laurent series) equals
+the corresponding $q$-expansion of $g$; thus $X$ plays the role of $g/h$ in $\mathbb{C}((q))$. Write
+$J :=$ [`ModularCurve.coeffEmb ℂ ModularCurve.jq`](def/ModularCurve_LaurentCoeff.html#L81) for the
+Laurent series over $\mathbb{C}$ obtained from [`ModularCurve.jq`](def/ModularCurve_X0.html#L157) $=
+q^{-1}\cdot(\mathrm{jNum}$ base changed to $\mathbb{Q})$ by pushing coefficients forward along
+$\mathbb{Q} \to \mathbb{C}$, i.e. the $q$-expansion of the modular invariant. Let $M$ be a natural
+number and assume that $X^{2M}\,J^{M+1}\,(J - 1728)^{M}$ is integral over the
+$\mathbb{C}$-subalgebra of $\mathbb{C}((q))$ generated by $J^{-1}$. Then for every $A \in
+\mathrm{SL}_2(\mathbb{Z})$ and every real $\varepsilon > 0$, eventually as $\operatorname{Im}\tau
+\to \infty$ on the upper half-plane,
+$$\bigl\|\bigl((g E_4^2 E_6)\mid_{k+14} A\bigr)(\tau)\bigr\| \le
+\varepsilon\,\bigl\|\bigl((h\Delta)\mid_{k+12} A\bigr)(\tau)\bigr\|,$$
+the slash actions being those of the image of $A$ in $\mathrm{GL}_2(\mathbb{R})$ in the indicated
+weights.
+
+This is the cuspidal-decay half of the identification of regular differentials on $X_0(N)$ with cusp
+forms: integrality of the displayed Laurent series over $\mathbb{C}[j^{-1}]$ is the algebraic form
+of regularity at the cusps, and the conclusion says $(gE_4^2E_6)\mid A = o\bigl((h\Delta)\mid
+A\bigr)$ at $i\infty$ for every $A \in \mathrm{SL}_2(\mathbb{Z})$. It is used by
+[`ModularCurve.exists_cuspForm_qExpansion_eq_mul_thetaL_of_isIntegral`]
+(thm.html#ModularCurve.exists_cuspForm_qExpansion_eq_mul_thetaL_of_isIntegral).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv
+
+p2m_open "UpperHalfPlane ModularCurve~coeffEmb_jq"
+open scoped MatrixGroups ModularForm Manifold
+
+noncomputable section
+
+namespace ANb
+
+def Nice (f : ℍ → ℂ) : Prop :=
+  Function.Periodic (f ∘ ofComplex) 1 ∧ MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f ∧ IsBoundedAtImInfty f
+
+theorem Nice.mul {f g : ℍ → ℂ} (hf : Nice f) (hg : Nice g) : Nice (f * g) :=
+  ⟨by simpa [Function.comp_def] using hf.1.mul hg.1, hf.2.1.mul hg.2.1, hf.2.2.mul hg.2.2⟩
+
+theorem Nice.add {f g : ℍ → ℂ} (hf : Nice f) (hg : Nice g) : Nice (f + g) :=
+  ⟨by simpa [Function.comp_def] using hf.1.add hg.1, hf.2.1.add hg.2.1, hf.2.2.add hg.2.2⟩
+
+theorem Nice.const (c : ℂ) : Nice (fun _ => c) :=
+  ⟨fun _ => rfl, mdifferentiable_const, Filter.const_boundedAtFilter _ _⟩
+
+def niceSubalgebra : Subalgebra ℂ (ℍ → ℂ) where
+  carrier := {f | Nice f}
+  mul_mem' hf hg := hf.mul hg
+  add_mem' hf hg := hf.add hg
+  algebraMap_mem' c := Nice.const c
+
+local notation "𝒩" => niceSubalgebra
+
+theorem an (f : 𝒩) : AnalyticAt ℂ (cuspFunction 1 (f : ℍ → ℂ)) 0 :=
+  UpperHalfPlane.analyticAt_cuspFunction_zero one_pos f.2.1 f.2.2.1 f.2.2.2
+
+def qexpHom : 𝒩 →ₐ[ℂ] PowerSeries ℂ where
+  toFun f := qExpansion 1 (f : ℍ → ℂ)
+  map_one' := UpperHalfPlane.qExpansion_one 1
+  map_mul' f g := UpperHalfPlane.qExpansion_mul (an f) (an g)
+  map_zero' := UpperHalfPlane.qExpansion_zero 1
+  map_add' f g := UpperHalfPlane.qExpansion_add (an f) (an g)
+  commutes' c := by
+    have h1 : ((algebraMap ℂ (ℍ → ℂ) c : ℍ → ℂ)) = c • (1 : ℍ → ℂ) := by
+      funext z; simp
+    have a1 : AnalyticAt ℂ (cuspFunction 1 (1 : ℍ → ℂ)) 0 := an (1 : 𝒩)
+    change qExpansion 1 (algebraMap ℂ (ℍ → ℂ) c) = _
+    rw [h1, UpperHalfPlane.qExpansion_smul a1 c, UpperHalfPlane.qExpansion_one,
+      Algebra.algebraMap_eq_smul_one]
+
+theorem qexpHom_apply (f : 𝒩) : qexpHom f = qExpansion 1 (f : ℍ → ℂ) := rfl
+
+def ψ : 𝒩 →ₐ[ℂ] LaurentSeries ℂ :=
+  { (HahnSeries.ofPowerSeries ℤ ℂ).comp qexpHom.toRingHom with
+    commutes' := fun c => by
+      change HahnSeries.ofPowerSeries ℤ ℂ (qexpHom (algebraMap ℂ 𝒩 c)) = _
+      rw [qexpHom.commutes, HahnSeries.algebraMap_apply'] }
+
+theorem ψ_apply (f : 𝒩) : ψ f = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (f : ℍ → ℂ)) := rfl
+
+theorem ψ_injective : Function.Injective ψ := by
+  intro f g hfg
+  rw [ψ_apply, ψ_apply] at hfg
+  have h := HahnSeries.ofPowerSeries_injective hfg
+  have h' : qExpansion 1 ((f : ℍ → ℂ) - (g : ℍ → ℂ)) = 0 := by
+    rw [UpperHalfPlane.qExpansion_sub (an f) (an g), h, sub_self]
+  have hn : Nice ((f : ℍ → ℂ) - (g : ℍ → ℂ)) := (f - g).2
+  have h0 := (UpperHalfPlane.qExpansion_eq_zero_iff one_pos hn.1 hn.2.1 hn.2.2).mp h'
+  exact Subtype.ext (sub_eq_zero.mp h0)
+
+theorem ψ_eq_zero_iff (f : 𝒩) : ψ f = 0 ↔ f = 0 :=
+  ⟨fun h => ψ_injective (by rw [h, map_zero]), fun h => by rw [h, map_zero]⟩
+
+def toC : 𝒩 →ₐ[ℂ] (ℂ → ℂ) where
+  toFun f := (f : ℍ → ℂ) ∘ ofComplex
+  map_one' := rfl
+  map_mul' _ _ := rfl
+  map_zero' := rfl
+  map_add' _ _ := rfl
+  commutes' _ := rfl
+
+theorem toC_apply (f : 𝒩) : toC f = (f : ℍ → ℂ) ∘ ofComplex := rfl
+
+theorem analyticAt_toC (f : 𝒩) (τ : ℍ) : AnalyticAt ℂ (toC f) (τ : ℂ) := by
+  have hd : DifferentiableOn ℂ ((f : ℍ → ℂ) ∘ ofComplex) {z : ℂ | 0 < z.im} :=
+    UpperHalfPlane.mdifferentiable_iff.mp f.2.2.1
+  exact hd.analyticAt ((isOpen_lt continuous_const Complex.continuous_im).mem_nhds τ.im_pos)
+
+theorem nice_of_modularForm {F : Type*} {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (h1 : (1 : ℝ) ∈ Γ.strictPeriods) : Nice (f : ℍ → ℂ) := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Subgroup.isCusp_of_mem_strictPeriods one_pos h1⟩
+  refine ⟨?_, ModularFormClass.holo f, ModularFormClass.bdd_at_infty f⟩
+  simpa using SlashInvariantFormClass.periodic_comp_ofComplex (h := 1) f h1
+
+def ofMF {F : Type*} {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (h1 : (1 : ℝ) ∈ Γ.strictPeriods) : 𝒩 :=
+  ⟨f, nice_of_modularForm f h1⟩
+
+@[scoped simp] theorem coe_ofMF {F : Type*} {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (h1 : (1 : ℝ) ∈ Γ.strictPeriods) :
+    ((ofMF f h1 : 𝒩) : ℍ → ℂ) = f := rfl
+
+theorem one_mem_strictPeriods_gamma0 (N : ℕ) :
+    (1 : ℝ) ∈ (Subgroup.map (Matrix.SpecialLinearGroup.mapGL ℝ) (CongruenceSubgroup.Gamma0
+      N)).strictPeriods := by
+  rw [CongruenceSubgroup.strictPeriods_Gamma0]
+  exact AddSubgroup.mem_zmultiples 1
+
+def 𝔞 : 𝒩 := ofMF ModularForm.E₄ one_mem_strictPeriods_SL
+
+def 𝔟 : 𝒩 := ofMF ModularForm.E₆ one_mem_strictPeriods_SL
+
+def 𝔡 : 𝒩 := ofMF CuspForm.discriminant one_mem_strictPeriods_SL
+
+theorem ψ𝔞 : ψ 𝔞 = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) := rfl
+theorem ψ𝔟 : ψ 𝔟 = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) := rfl
+theorem ψ𝔡 : ψ 𝔡 = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 ModularForm.discriminant) := rfl
+theorem toC𝔡_apply (τ : ℍ) : toC 𝔡 (τ : ℂ) = ModularForm.discriminant τ := by
+  change ModularForm.discriminant (ofComplex (τ : ℂ)) = _
+  rw [ofComplex_apply]
+
+theorem coeff_one_mul (φ χ : PowerSeries ℂ) :
+    PowerSeries.coeff 1 (φ * χ) = PowerSeries.coeff 0 φ * PowerSeries.coeff 1 χ +
+      PowerSeries.coeff 1 φ * PowerSeries.coeff 0 χ := by
+  rw [PowerSeries.coeff_mul, Finset.Nat.sum_antidiagonal_eq_sum_range_succ_mk]
+  simp [Finset.sum_range_succ]
+
+theorem coeff_zero_mul' (φ χ : PowerSeries ℂ) :
+    PowerSeries.coeff 0 (φ * χ) = PowerSeries.coeff 0 φ * PowerSeries.coeff 0 χ := by
+  rw [PowerSeries.coeff_zero_eq_constantCoeff_apply, PowerSeries.coeff_zero_eq_constantCoeff_apply,
+    PowerSeries.coeff_zero_eq_constantCoeff_apply, map_mul]
+
+theorem qA0 : PowerSeries.coeff 0 (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) = 1 :=
+  EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) ⟨2, rfl⟩
+theorem qB0 : PowerSeries.coeff 0 (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) = 1 :=
+  EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) ⟨3, rfl⟩
+theorem qA1 : PowerSeries.coeff 1 (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) = 240 := by
+  have h := ModularForm.levelOne_weight_four_qCoeff_one ModularForm.E₄
+  simp only [ModularFormClass.qCoeff] at h
+  rw [h, qA0, mul_one]
+theorem qB1 : PowerSeries.coeff 1 (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) = -504 := by
+  have h := ModularForm.levelOne_weight_six_qCoeff_one ModularForm.E₆
+  simp only [ModularFormClass.qCoeff] at h
+  rw [h, qB0, mul_one]
+theorem qD1 : PowerSeries.coeff 1 (qExpansion 1 ModularForm.discriminant) = 1 := by
+  rw [ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit, PowerSeries.coeff_map,
+    PowerSeries.coeff_succ_X_mul, PowerSeries.coeff_zero_eq_constantCoeff_apply,
+    ModularCurve.constantCoeff_dedekindEtaUnit, map_one]
+
+theorem A_cube_sub_B_sq : ψ 𝔞 ^ 3 - ψ 𝔟 ^ 2 = 1728 * ψ 𝔡 := by
+  let T : ModularForm 𝒮ℒ 12 := ModularForm.E₄.mul (ModularForm.E₄.mul ModularForm.E₄)
+  let U : ModularForm 𝒮ℒ 12 := ModularForm.E₆.mul ModularForm.E₆
+  let Z : ModularForm 𝒮ℒ 12 := T - U
+  have hZ : (Z : ℍ → ℂ) = ((𝔞 * (𝔞 * 𝔞) - 𝔟 * 𝔟 : 𝒩) : ℍ → ℂ) := by
+    funext z
+    change (T : ℍ → ℂ) z - (U : ℍ → ℂ) z = _
+    rfl
+  have hZq : qExpansion 1 (Z : ℍ → ℂ) =
+      qExpansion 1 ⇑ModularForm.E₄ * (qExpansion 1 ⇑ModularForm.E₄ * qExpansion 1 ⇑ModularForm.E₄) -
+        qExpansion 1 ⇑ModularForm.E₆ * qExpansion 1 ⇑ModularForm.E₆ := by
+    rw [hZ, ← qexpHom_apply, map_sub, map_mul, map_mul, map_mul]
+    rfl
+  have h0 : ModularFormClass.qCoeff (Z : ℍ → ℂ) 0 = 0 := by
+    simp only [ModularFormClass.qCoeff, hZq, map_sub, coeff_zero_mul', qA0, qB0]
+    norm_num
+  have h1 : ModularFormClass.qCoeff (Z : ℍ → ℂ) 1 = 1728 := by
+    simp only [ModularFormClass.qCoeff, hZq, map_sub, coeff_one_mul, coeff_zero_mul', qA0, qA1, qB0,
+      qB1]
+    norm_num
+  have hW := ModularForm.levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant Z h0
+  have hZΔ : qExpansion 1 (Z : ℍ → ℂ) = PowerSeries.C 1728 * qExpansion 1 ModularForm.discriminant
+    :=
+    by
+    ext n
+    rw [PowerSeries.coeff_C_mul]
+    have := hW n
+    have h1' := h1
+    simp only [ModularFormClass.qCoeff] at this h1'
+    rw [this, h1']
+  have hL : ψ (𝔞 * (𝔞 * 𝔞) - 𝔟 * 𝔟) = 1728 * ψ 𝔡 := by
+    rw [ψ_apply, ← hZ, hZΔ, map_mul, HahnSeries.ofPowerSeries_C, map_ofNat, ψ𝔡]
+  rw [map_sub, map_mul, map_mul, map_mul] at hL
+  rw [← hL]
+  ring
+
+theorem ψ𝔡_ne_zero : ψ 𝔡 ≠ 0 := by
+  intro h
+  have h0 : (𝔡 : 𝒩) = 0 := (ψ_eq_zero_iff _).mp h
+  have : ModularForm.discriminant UpperHalfPlane.I = 0 := by
+    have := congrArg (fun f : 𝒩 => (f : ℍ → ℂ) UpperHalfPlane.I) h0
+    simp only [ZeroMemClass.coe_zero, Pi.zero_apply] at this
+    exact this
+  exact ModularForm.discriminant_ne_zero _ this
+
+theorem coeffEmb_jq : coeffEmb ℂ jq = jqModC ℂ := by
+  change (jqModC ℚ).map (algebraMap ℚ ℂ) = jqModC ℂ
+  exact map_jqModC _
+
+theorem J_mul_D : coeffEmb ℂ jq * ψ 𝔡 = ψ 𝔞 ^ 3 := by
+  rw [coeffEmb_jq, ModularCurve.jqModC_eq_qExpansion_E4_cube_div_discriminant, ← ψ𝔞, ← ψ𝔡,
+    div_mul_cancel₀ _ ψ𝔡_ne_zero]
+
+theorem J_sub_mul_D : (coeffEmb ℂ jq - algebraMap ℂ (LaurentSeries ℂ) 1728) * ψ 𝔡 = ψ 𝔟 ^ 2 := by
+  rw [map_ofNat, sub_mul, J_mul_D]
+  have := A_cube_sub_B_sq
+  linear_combination this
+
+theorem le_analyticOrderAt_sum {ι : Type*} (s : Finset ι) (F : ι → ℂ → ℂ) (z : ℂ) (b : ℕ∞)
+    (h : ∀ i ∈ s, b ≤ analyticOrderAt (F i) z) : b ≤ analyticOrderAt (∑ i ∈ s, F i) z := by
+  classical
+  induction s using Finset.induction_on with
+  | empty =>
+    rw [Finset.sum_empty, analyticOrderAt_eq_top.mpr (by simp)]
+    exact le_top
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha]
+    refine le_trans ?_ le_analyticOrderAt_add
+    exact le_min (h a (Finset.mem_insert_self a s)) (ih fun i hi => h i (Finset.mem_insert_of_mem
+      hi))
+
+theorem order_le_of_identity {p q d : ℂ → ℂ} {n m : ℕ} {C : ℕ → ℂ → ℂ} {z : ℂ}
+    (hp : AnalyticAt ℂ p z) (hq : AnalyticAt ℂ q z) (hd : AnalyticAt ℂ d z)
+    (hC : ∀ i ∈ Finset.range n, AnalyticAt ℂ (C i) z) (hd0 : d z ≠ 0)
+    (hid : p ^ (6 * n) * d ^ m + ∑ i ∈ Finset.range n, C i * (p ^ (6 * i) * (q ^ 6 * d) ^ (n - i)) =
+      0) :
+    analyticOrderAt q z ≤ analyticOrderAt p z := by
+  by_contra hlt'
+  have hlt := not_le.mp hlt'
+  obtain ⟨k, hk⟩ : ∃ k : ℕ, (k : ℕ∞) = analyticOrderAt p z :=
+    ENat.ne_top_iff_exists.mp (ne_top_of_lt hlt)
+  have hd_ord : analyticOrderAt d z = 0 := hd.analyticOrderAt_eq_zero.mpr hd0
+  have hL : analyticOrderAt (p ^ (6 * n) * d ^ m) z = ((6 * n * k : ℕ) : ℕ∞) := by
+    rw [analyticOrderAt_mul (hp.pow _) (hd.pow _), analyticOrderAt_pow hp, analyticOrderAt_pow hd,
+      ← hk, hd_ord]
+    simp only [nsmul_eq_mul, smul_zero, add_zero]
+    push_cast
+    ring
+  have hq_ord : ((k + 1 : ℕ) : ℕ∞) ≤ analyticOrderAt q z := by
+    rw [← hk] at hlt
+    have := Order.add_one_le_of_lt hlt
+    exact_mod_cast this
+  have hR : ∀ i ∈ Finset.range n, ((6 * n * k + 6 : ℕ) : ℕ∞) ≤
+      analyticOrderAt (C i * (p ^ (6 * i) * (q ^ 6 * d) ^ (n - i))) z := by
+    intro i hi
+    have hin : i < n := Finset.mem_range.mp hi
+    have hqd : AnalyticAt ℂ (q ^ 6 * d) z := (hq.pow _).mul hd
+    rw [analyticOrderAt_mul (hC i hi) ((hp.pow _).mul (hqd.pow _)),
+      analyticOrderAt_mul (hp.pow _) (hqd.pow _), analyticOrderAt_pow hp, analyticOrderAt_pow hqd,
+      analyticOrderAt_mul (hq.pow _) hd, analyticOrderAt_pow hq, hd_ord, ← hk, add_zero]
+    have h1 : ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞) ≤ (n - i) • (6 • analyticOrderAt q z) := by
+      have : (n - i) • (6 • (((k + 1 : ℕ)) : ℕ∞)) ≤ (n - i) • (6 • analyticOrderAt q z) :=
+        nsmul_le_nsmul_right (nsmul_le_nsmul_right hq_ord 6) (n - i)
+      refine le_trans (le_of_eq ?_) this
+      simp only [nsmul_eq_mul]
+      push_cast
+      ring
+    have h2 : ((6 * n * k + 6 : ℕ) : ℕ∞) ≤ ((6 * i) • (k : ℕ∞)) + ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞)
+      :=
+      by
+      have e : ((6 * i) • (k : ℕ∞)) + ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞) =
+          ((6 * i * k + 6 * (n - i) * (k + 1) : ℕ) : ℕ∞) := by
+        simp only [nsmul_eq_mul]
+        push_cast
+        ring
+      rw [e]
+      exact_mod_cast (show 6 * n * k + 6 ≤ 6 * i * k + 6 * (n - i) * (k + 1) by
+        obtain ⟨j, rfl⟩ := Nat.exists_eq_add_of_lt hin
+        rw [show i + j + 1 - i = j + 1 by omega]
+        nlinarith)
+    calc ((6 * n * k + 6 : ℕ) : ℕ∞)
+        ≤ (6 * i) • (k : ℕ∞) + ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞) := h2
+      _ ≤ (6 * i) • (k : ℕ∞) + (n - i) • (6 • analyticOrderAt q z) := add_le_add le_rfl h1
+      _ ≤ analyticOrderAt (C i) z + ((6 * i) • (k : ℕ∞) + (n - i) • (6 • analyticOrderAt q z)) :=
+          self_le_add_left _ _
+  have hsum := le_analyticOrderAt_sum (Finset.range n) _ z _ hR
+  have heq : p ^ (6 * n) * d ^ m = -(∑ i ∈ Finset.range n, C i * (p ^ (6 * i) * (q ^ 6 * d) ^ (n -
+    i))) :=
+    eq_neg_of_add_eq_zero_left hid
+  have : ((6 * n * k + 6 : ℕ) : ℕ∞) ≤ ((6 * n * k : ℕ) : ℕ∞) := by
+    rw [← hL, heq, analyticOrderAt_neg]
+    exact hsum
+  have := ENat.natCast_le_natCast.mp this
+  omega
+
+end ANb
+
+namespace ANb
+
+local notation "𝒩" => niceSubalgebra
+local notation "𝐉" => ModularCurve.coeffEmb ℂ ModularCurve.jq
+
+theorem ψ𝔞_ne_zero : ψ 𝔞 ≠ 0 := by
+  intro h
+  have h0 : qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) = 0 :=
+    HahnSeries.ofPowerSeries_injective (by rw [← ψ𝔞, h, map_zero])
+  have := qA0
+  rw [h0, map_zero] at this
+  exact zero_ne_one this
+
+theorem J_ne_zero : (𝐉) ≠ 0 := by
+  intro h
+  have := J_mul_D
+  rw [h, zero_mul] at this
+  exact pow_ne_zero 3 ψ𝔞_ne_zero this.symm
+
+theorem Jinv_mul_A_cube : (𝐉)⁻¹ * ψ 𝔞 ^ 3 = ψ 𝔡 := by
+  rw [← J_mul_D, ← mul_assoc, inv_mul_cancel₀ J_ne_zero, one_mul]
+
+def ev (z : ℍ) : 𝒩 →ₐ[ℂ] ℂ where
+  toFun f := (f : ℍ → ℂ) z
+  map_one' := rfl
+  map_mul' _ _ := rfl
+  map_zero' := rfl
+  map_add' _ _ := rfl
+  commutes' _ := rfl
+
+theorem ev_apply (z : ℍ) (f : 𝒩) : ev z f = (f : ℍ → ℂ) z := rfl
+
+theorem slash_coe_apply (f : ℍ → ℂ) (k : ℤ) (A : SL(2, ℤ)) (τ : ℍ) :
+    (f ∣[k] (A : GL (Fin 2) ℝ)) τ = f (A • τ) * denom (A : GL (Fin 2) ℝ) τ ^ (-k) := by
+  rw [← ModularForm.SL_slash]
+  exact ModularForm.SL_slash_apply f A τ
+
+theorem levelOne_apply_smul {k : ℤ} {F : Type*} [FunLike F ℍ ℂ]
+    [SlashInvariantFormClass F 𝒮ℒ k] (f : F) (A : SL(2, ℤ)) (τ : ℍ) :
+    f (A • τ) = denom (A : GL (Fin 2) ℝ) τ ^ k * f τ := by
+  have h1 := congrFun (SlashInvariantForm.slash_action_eqn f (A : GL (Fin 2) ℝ) ⟨A, rfl⟩) τ
+  rw [slash_coe_apply] at h1
+  have hδ := denom_ne_zero (A : GL (Fin 2) ℝ) τ
+  calc f (A • τ) = f (A • τ) * denom (A : GL (Fin 2) ℝ) τ ^ (-k) * denom (A : GL (Fin 2) ℝ) τ ^ k
+    := by
+        rw [mul_assoc, ← zpow_add₀ hδ, neg_add_cancel, zpow_zero, mul_one]
+    _ = denom (A : GL (Fin 2) ℝ) τ ^ k * f τ := by rw [h1, mul_comm]
+
+theorem 𝔞_apply_smul (A : SL(2, ℤ)) (τ : ℍ) :
+    (𝔞 : ℍ → ℂ) (A • τ) = denom (A : GL (Fin 2) ℝ) τ ^ 4 * (𝔞 : ℍ → ℂ) τ := by
+  have := levelOne_apply_smul ModularForm.E₄ A τ
+  simp only [zpow_ofNat] at this
+  exact this
+theorem 𝔟_apply_smul (A : SL(2, ℤ)) (τ : ℍ) :
+    (𝔟 : ℍ → ℂ) (A • τ) = denom (A : GL (Fin 2) ℝ) τ ^ 6 * (𝔟 : ℍ → ℂ) τ := by
+  have := levelOne_apply_smul ModularForm.E₆ A τ
+  simp only [zpow_ofNat] at this
+  exact this
+theorem 𝔡_apply_smul (A : SL(2, ℤ)) (τ : ℍ) :
+    (𝔡 : ℍ → ℂ) (A • τ) = denom (A : GL (Fin 2) ℝ) τ ^ 12 * (𝔡 : ℍ → ℂ) τ := by
+  have := levelOne_apply_smul CuspForm.discriminant A τ
+  simp only [zpow_ofNat] at this
+  exact this
+
+theorem tendsto_nice (f : 𝒩) :
+    Filter.Tendsto (f : ℍ → ℂ) atImInfty (nhds (PowerSeries.coeff 0 (qExpansion 1 (f : ℍ → ℂ))))
+      := by
+  refine ModularCurve.tendsto_atImInfty_of_hasSum_qParam 1 one_pos (f : ℍ → ℂ)
+    (fun m => PowerSeries.coeff m (qExpansion 1 (f : ℍ → ℂ))) fun τ => ?_
+  have := UpperHalfPlane.hasSum_qExpansion one_pos f.2.1 f.2.2.1 f.2.2.2 τ
+  simpa [smul_eq_mul] using this
+
+theorem norm_le_of_monic_relation {n : ℕ} {u : ℂ} {κ : ℕ → ℂ} {B : ℝ} (hB : 0 ≤ B)
+    (hκ : ∀ i ∈ Finset.range n, ‖κ i‖ ≤ B) (h : u ^ n + ∑ i ∈ Finset.range n, κ i * u ^ i = 0) :
+    ‖u‖ ≤ n * B + 1 := by
+  have hnB : 0 ≤ (n : ℝ) * B := mul_nonneg n.cast_nonneg hB
+  by_cases hu' : ‖u‖ ≤ 1
+  · linarith
+  have hu : 1 < ‖u‖ := not_le.mp hu'
+  have hn : n ≠ 0 := by
+    rintro rfl
+    simp at h
+  obtain ⟨n', rfl⟩ := Nat.exists_eq_succ_of_ne_zero hn
+  have hun : u ^ (n' + 1) = -∑ i ∈ Finset.range (n' + 1), κ i * u ^ i :=
+    eq_neg_of_add_eq_zero_left h
+  have hle : ‖u‖ ^ (n' + 1) ≤ (n' + 1 : ℕ) * B * ‖u‖ ^ n' := by
+    calc ‖u‖ ^ (n' + 1) = ‖u ^ (n' + 1)‖ := (norm_pow _ _).symm
+      _ = ‖∑ i ∈ Finset.range (n' + 1), κ i * u ^ i‖ := by rw [hun, norm_neg]
+      _ ≤ ∑ i ∈ Finset.range (n' + 1), ‖κ i * u ^ i‖ := norm_sum_le _ _
+      _ ≤ ∑ i ∈ Finset.range (n' + 1), B * ‖u‖ ^ n' := by
+          refine Finset.sum_le_sum fun i hi => ?_
+          rw [norm_mul, norm_pow]
+          have hi' : i ≤ n' := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)
+          exact mul_le_mul (hκ i hi) (pow_le_pow_right₀ hu.le hi') (pow_nonneg (norm_nonneg _) _) hB
+      _ = (n' + 1 : ℕ) * B * ‖u‖ ^ n' := by
+          rw [Finset.sum_const, Finset.card_range, nsmul_eq_mul]; ring
+  have hpos : 0 < ‖u‖ ^ n' := pow_pos (by linarith) _
+  rw [pow_succ, mul_comm] at hle
+  have := le_of_mul_le_mul_right hle hpos
+  linarith
+
+theorem coreC (𝔤 𝔥 : 𝒩) (X : LaurentSeries ℂ) (hX : X * ψ 𝔥 = ψ 𝔤) (M : ℕ)
+    (h₂ : IsIntegral (Algebra.adjoin ℂ ({(𝐉)⁻¹} : Set (LaurentSeries ℂ)))
+      (X ^ (2 * M) * 𝐉 ^ (M + 1) * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ M)) :
+    ∃ (n m : ℕ) (K : ℕ → 𝒩),
+      (∀ i ∈ Finset.range n, ∀ (A : SL(2, ℤ)) (τ : ℍ), (K i : ℍ → ℂ) (A • τ) =
+          denom (A : GL (Fin 2) ℝ) τ ^ (12 * m) * (K i : ℍ → ℂ) τ) ∧
+      (𝔤 ^ (2 * M) * 𝔞 ^ (3 * M + 3) * 𝔟 ^ (2 * M)) ^ n * 𝔞 ^ (3 * m) +
+        ∑ i ∈ Finset.range n, K i * ((𝔤 ^ (2 * M) * 𝔞 ^ (3 * M + 3) * 𝔟 ^ (2 * M)) ^ i *
+          (𝔥 ^ (2 * M) * 𝔡 ^ (2 * M + 1)) ^ (n - i)) = 0 := by
+  classical
+  have key1 : (X ^ (2 * M) * 𝐉 ^ (M + 1) * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ M) *
+      (ψ 𝔥 ^ (2 * M) * ψ 𝔡 ^ (2 * M + 1)) = ψ 𝔤 ^ (2 * M) * ψ 𝔞 ^ (3 * M + 3) * ψ 𝔟 ^ (2 * M) := by
+    calc (X ^ (2 * M) * 𝐉 ^ (M + 1) * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ M) *
+          (ψ 𝔥 ^ (2 * M) * ψ 𝔡 ^ (2 * M + 1))
+        = (X * ψ 𝔥) ^ (2 * M) * (𝐉 * ψ 𝔡) ^ (M + 1) * ((𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) * ψ
+          𝔡) ^ M := by
+          rw [mul_pow (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) (ψ 𝔡) M, mul_pow X (ψ 𝔥), mul_pow
+            (𝐉) (ψ 𝔡)]
+          ring
+      _ = (ψ 𝔤) ^ (2 * M) * (ψ 𝔞 ^ 3) ^ (M + 1) * (ψ 𝔟 ^ 2) ^ M := by rw [hX, J_mul_D, J_sub_mul_D]
+      _ = ψ 𝔤 ^ (2 * M) * ψ 𝔞 ^ (3 * M + 3) * ψ 𝔟 ^ (2 * M) := by
+          rw [← pow_mul, ← pow_mul, show 3 * (M + 1) = 3 * M + 3 by ring]
+  obtain ⟨p, hpm, hpev⟩ := h₂
+  rw [hpm.as_sum] at hpev
+  simp only [Polynomial.eval₂_add, Polynomial.eval₂_pow, Polynomial.eval₂_X,
+    Polynomial.eval₂_finsetSum,
+    Polynomial.eval₂_mul, Polynomial.eval₂_C] at hpev
+  set R := Algebra.adjoin ℂ ({(𝐉)⁻¹} : Set (LaurentSeries ℂ)) with hR
+  set Y := X ^ (2 * M) * 𝐉 ^ (M + 1) * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ M with hY
+  set n := p.natDegree with hn
+  clear_value Y
+  have hmem : ∀ i, ∃ c : Polynomial ℂ,
+      Polynomial.aeval ((𝐉)⁻¹) c = algebraMap R (LaurentSeries ℂ) (p.coeff i) := by
+    intro i
+    have hi' : algebraMap R (LaurentSeries ℂ) (p.coeff i) ∈ (Polynomial.aeval (R := ℂ)
+      ((𝐉)⁻¹)).range :=
+      by
+      rw [← Algebra.adjoin_singleton_eq_range_aeval]
+      exact (p.coeff i).2
+    exact hi'
+  choose c hc using hmem
+  set m := ∑ i ∈ Finset.range n, (c i).natDegree with hm
+  have hdeg : ∀ i ∈ Finset.range n, (c i).natDegree ≤ m := fun i hi =>
+    Finset.single_le_sum (f := fun j => (c j).natDegree) (fun j _ => Nat.zero_le _) hi
+  clear_value m
+  let K : ℕ → 𝒩 := fun i =>
+    ∑ l ∈ Finset.range ((c i).natDegree + 1), algebraMap ℂ 𝒩 ((c i).coeff l) * (𝔡 ^ l * 𝔞 ^ (3 * (m
+      - l)))
+  have key3 : ∀ i ∈ Finset.range n, ψ 𝔞 ^ (3 * m) * algebraMap R (LaurentSeries ℂ) (p.coeff i) = ψ
+    (K i) :=
+    by
+    intro i hi
+    simp only [K, map_sum, map_mul, map_pow, AlgHom.commutes]
+    rw [← hc i, Polynomial.aeval_eq_sum_range, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun l hl => ?_
+    have hlm : l ≤ m := (Nat.lt_succ_iff.mp (Finset.mem_range.mp hl)).trans (hdeg i hi)
+    rw [Algebra.smul_def, mul_left_comm]
+    congr 1
+    calc ψ 𝔞 ^ (3 * m) * (𝐉)⁻¹ ^ l = ψ 𝔞 ^ (3 * (m - l)) * (ψ 𝔞 ^ 3) ^ l * (𝐉)⁻¹ ^ l := by
+          rw [← pow_mul, ← pow_add, show 3 * (m - l) + 3 * l = 3 * m by omega]
+      _ = ψ 𝔞 ^ (3 * (m - l)) * ((𝐉)⁻¹ * ψ 𝔞 ^ 3) ^ l := by rw [mul_pow ((𝐉)⁻¹)]; ring
+      _ = ψ 𝔡 ^ l * ψ 𝔞 ^ (3 * (m - l)) := by rw [Jinv_mul_A_cube, mul_comm]
+  let W : 𝒩 := 𝔤 ^ (2 * M) * 𝔞 ^ (3 * M + 3) * 𝔟 ^ (2 * M)
+  let V : 𝒩 := 𝔥 ^ (2 * M) * 𝔡 ^ (2 * M + 1)
+  have k1 : Y * ψ V = ψ W := by
+    simp only [W, V, map_mul, map_pow]
+    exact key1
+  have key2 : ∀ i ≤ n, ψ V ^ n * Y ^ i = ψ W ^ i * ψ V ^ (n - i) := by
+    intro i hi
+    have e : ψ V ^ n = ψ V ^ i * ψ V ^ (n - i) := by
+      rw [← pow_add, Nat.add_sub_cancel' hi]
+    calc ψ V ^ n * Y ^ i = (Y * ψ V) ^ i * ψ V ^ (n - i) := by
+          rw [e, mul_pow Y (ψ V) i]; ring
+      _ = ψ W ^ i * ψ V ^ (n - i) := by rw [k1]
+  let E : 𝒩 := W ^ n * 𝔞 ^ (3 * m) + ∑ i ∈ Finset.range n, K i * (W ^ i * V ^ (n - i))
+  have hE : ψ E = ψ V ^ n * ψ 𝔞 ^ (3 * m) *
+      (Y ^ n + ∑ i ∈ Finset.range n, algebraMap R (LaurentSeries ℂ) (p.coeff i) * Y ^ i) := by
+    rw [mul_add, Finset.mul_sum]
+    simp only [E, map_add, map_sum, map_mul, map_pow]
+    congr 1
+    · have h2 := key2 n le_rfl
+      rw [Nat.sub_self, pow_zero, mul_one] at h2
+      rw [mul_right_comm, h2]
+    · refine Finset.sum_congr rfl fun i hi => ?_
+      have hin : i ≤ n := (Finset.mem_range.mp hi).le
+      rw [← key3 i hi, ← key2 i hin]
+      ring
+  have hE0 : E = 0 := by
+    apply ψ_injective
+    rw [hE, hpev, mul_zero, map_zero]
+  refine ⟨n, m, K, fun i hi A τ => ?_, hE0⟩
+  have hlm : ∀ l ∈ Finset.range ((c i).natDegree + 1), l ≤ m := fun l hl =>
+    (Nat.lt_succ_iff.mp (Finset.mem_range.mp hl)).trans (hdeg i hi)
+  change ev (A • τ) (K i) = denom (A : GL (Fin 2) ℝ) τ ^ (12 * m) * ev τ (K i)
+  simp only [K, map_sum, map_mul, map_pow, AlgHom.commutes, Finset.mul_sum]
+  refine Finset.sum_congr rfl fun l hl => ?_
+  rw [ev_apply, ev_apply, ev_apply, ev_apply, 𝔡_apply_smul, 𝔞_apply_smul,
+    show 12 * m = 12 * l + 4 * (3 * (m - l)) by have := hlm l hl; omega]
+  ring
+
+end ANb
+
+open ANb in
+theorem solution (N : ℕ) {k : ℤ}
+    (g h : ModularForm (CongruenceSubgroup.Gamma0 N) k) (X : LaurentSeries ℂ)
+    (hX : X * ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) = ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ)) (M : ℕ)
+    (h₂ : IsIntegral (Algebra.adjoin ℂ ({(ModularCurve.coeffEmb ℂ ModularCurve.jq)⁻¹} : Set
+      (LaurentSeries ℂ)))
+      (X ^ (2 * M) * ModularCurve.coeffEmb ℂ ModularCurve.jq ^ (M + 1) * (ModularCurve.coeffEmb ℂ
+        ModularCurve.jq - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ M))
+    (A : Matrix.SpecialLinearGroup (Fin 2) ℤ) (ε : ℝ) (hε : 0 < ε) :
+    ∀ᶠ τ : UpperHalfPlane in UpperHalfPlane.atImInfty,
+      ‖((fun z : UpperHalfPlane => g z * ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) ∣[k + 14] (A : GL
+        (Fin 2) ℝ)) τ‖ ≤
+        ε * ‖((fun z : UpperHalfPlane => h z * ModularForm.discriminant z) ∣[k + 12] (A : GL (Fin 2)
+          ℝ)) τ‖ := by
+  classical
+  obtain ⟨n, m, K, hK, hE⟩ := ANb.coreC (ANb.ofMF g (ANb.one_mem_strictPeriods_gamma0 N))
+    (ANb.ofMF h (ANb.one_mem_strictPeriods_gamma0 N)) X hX M h₂
+  let κ0 : ℕ → ℝ := fun i => ‖PowerSeries.coeff 0 (qExpansion 1 (K i : ℍ → ℂ))‖ + 1
+  let B : ℝ := 1 + ∑ i ∈ Finset.range n, κ0 i
+  have hκ0 : ∀ i, 0 ≤ κ0 i := fun i => by positivity
+  have hB1 : 1 ≤ B := le_add_of_nonneg_right (Finset.sum_nonneg fun i _ => hκ0 i)
+  have hκB : ∀ i ∈ Finset.range n, κ0 i ≤ B := fun i hi =>
+    (Finset.single_le_sum (f := κ0) (fun j _ => hκ0 j) hi).trans (le_add_of_nonneg_left zero_le_one)
+  let B' : ℝ := B * 2 ^ (3 * m)
+  have hB' : 0 ≤ B' := by positivity
+  let C : ℝ := n * B' + 1
+  have hC : 1 ≤ C := le_add_of_nonneg_left (by positivity)
+  have hC0 : 0 ≤ C := by linarith
+  obtain ⟨η₀, hη₀def⟩ : ∃ e : ℝ, e = ε ^ (2 * M) / (2 ^ (3 * M + 3) * 2 ^ (4 * M) * (C + 1)) :=
+    ⟨_, rfl⟩
+  have hη₀ : 0 < η₀ := by rw [hη₀def]; positivity
+  have hCη : C * η₀ * (2 ^ (3 * M + 3) * 2 ^ (4 * M)) ≤ ε ^ (2 * M) := by
+    have e1 : C * η₀ * (2 ^ (3 * M + 3) * 2 ^ (4 * M)) = ε ^ (2 * M) * (C / (C + 1)) := by
+      rw [hη₀def]
+      field_simp
+    rw [e1]
+    have h1 : C / (C + 1) ≤ 1 := (div_le_one (by linarith)).mpr (by linarith)
+    calc ε ^ (2 * M) * (C / (C + 1)) ≤ ε ^ (2 * M) * 1 := by
+          exact mul_le_mul_of_nonneg_left h1 (by positivity)
+      _ = ε ^ (2 * M) := mul_one _
+  have t4 : Filter.Tendsto (fun τ : ℍ => ModularForm.E₄ τ) atImInfty (nhds 1) := by
+    have := ANb.tendsto_nice ANb.𝔞
+    rwa [show PowerSeries.coeff 0 (qExpansion 1 ((ANb.𝔞 : ℍ → ℂ))) = 1 from ANb.qA0] at this
+  have t6 : Filter.Tendsto (fun τ : ℍ => ModularForm.E₆ τ) atImInfty (nhds 1) := by
+    have := ANb.tendsto_nice ANb.𝔟
+    rwa [show PowerSeries.coeff 0 (qExpansion 1 ((ANb.𝔟 : ℍ → ℂ))) = 1 from ANb.qB0] at this
+  have tΔ : Filter.Tendsto ModularForm.discriminant atImInfty (nhds 0) :=
+    ModularForm.discriminant_isZeroAtImInfty
+  have e4 : ∀ᶠ τ : ℍ in atImInfty, dist (ModularForm.E₄ τ) 1 < 1 / 2 :=
+    Metric.tendsto_nhds.mp t4 _ (by norm_num)
+  have e6 : ∀ᶠ τ : ℍ in atImInfty, dist (ModularForm.E₆ τ) 1 < 1 / 2 :=
+    Metric.tendsto_nhds.mp t6 _ (by norm_num)
+  have eΔ : ∀ᶠ τ : ℍ in atImInfty, dist (ModularForm.discriminant τ) 0 < η₀ :=
+    Metric.tendsto_nhds.mp tΔ _ hη₀
+  have eK : ∀ᶠ τ : ℍ in atImInfty, ∀ i ∈ Finset.range n, ‖(K i : ℍ → ℂ) τ‖ ≤ κ0 i := by
+    refine (Filter.eventually_all_finset _).mpr fun i _ => ?_
+    have := Metric.tendsto_nhds.mp (ANb.tendsto_nice (K i)) 1 one_pos
+    filter_upwards [this] with τ hτ
+    rw [dist_eq_norm] at hτ
+    exact (norm_le_insert' _ _).trans (by simp only [κ0]; linarith)
+  filter_upwards [e4, e6, eΔ, eK] with τ h4 h6 hd hKτ
+  rw [dist_eq_norm] at h4 h6
+  rw [dist_zero_right] at hd
+  set δ : ℂ := denom (A : GL (Fin 2) ℝ) τ with hδdef
+  have hδ : δ ≠ 0 := denom_ne_zero _ _
+  set a : ℂ := ModularForm.E₄ τ with ha
+  set b : ℂ := ModularForm.E₆ τ with hb
+  set d : ℂ := ModularForm.discriminant τ with hdd
+  have ha_lo : 1 / 2 < ‖a‖ := by
+    have := norm_le_insert' (1 : ℂ) a; rw [norm_one, norm_sub_rev] at this; linarith
+  have ha_hi : ‖a‖ < 3 / 2 := by
+    have := norm_le_insert' a (1 : ℂ); rw [norm_one] at this; linarith
+  have hb_lo : 1 / 2 < ‖b‖ := by
+    have := norm_le_insert' (1 : ℂ) b; rw [norm_one, norm_sub_rev] at this; linarith
+  have ha0 : a ≠ 0 := fun h0 => by rw [h0, norm_zero] at ha_lo; linarith
+  have hb0 : b ≠ 0 := fun h0 => by rw [h0, norm_zero] at hb_lo; linarith
+  have hd0 : d ≠ 0 := ModularForm.discriminant_ne_zero τ
+  set z : ℍ := A • τ with hz
+  have hE4z : ModularForm.E₄ z = δ ^ 4 * a := ANb.𝔞_apply_smul A τ
+  have hE6z : ModularForm.E₆ z = δ ^ 6 * b := ANb.𝔟_apply_smul A τ
+  have hΔz : ModularForm.discriminant z = δ ^ 12 * d := ANb.𝔡_apply_smul A τ
+  have hKz : ∀ i ∈ Finset.range n, (K i : ℍ → ℂ) z = δ ^ (12 * m) * (K i : ℍ → ℂ) τ :=
+    fun i hi => hK i hi A τ
+  set u : ℂ := g z ^ (2 * M) * ModularForm.E₄ z ^ (3 * M + 3) * ModularForm.E₆ z ^ (2 * M) with hu
+  set v : ℂ := h z ^ (2 * M) * ModularForm.discriminant z ^ (2 * M + 1) with hv
+  have hid : u ^ n * ModularForm.E₄ z ^ (3 * m) +
+      ∑ i ∈ Finset.range n, (K i : ℍ → ℂ) z * (u ^ i * v ^ (n - i)) = 0 := by
+    have := congrArg (ANb.ev z) hE
+    simp only [map_add, map_sum, map_mul, map_pow, map_zero, ANb.ev_apply] at this
+    exact this
+  clear_value u v
+  rw [ANb.slash_coe_apply, ANb.slash_coe_apply]
+  change ‖g z * ModularForm.E₄ z ^ 2 * ModularForm.E₆ z * δ ^ (-(k + 14))‖ ≤
+    ε * ‖h z * ModularForm.discriminant z * δ ^ (-(k + 12))‖
+  by_cases hv0 : v = 0
+  · have hMpos : M ≠ 0 := by
+      rintro rfl
+      apply hd0
+      have : ModularForm.discriminant z = 0 := by simpa [hv] using hv0
+      simpa [hΔz, hδ] using this
+    have hsum0 : ∑ i ∈ Finset.range n, (K i : ℍ → ℂ) z * (u ^ i * v ^ (n - i)) = 0 := by
+      refine Finset.sum_eq_zero fun i hi => ?_
+      have : n - i ≠ 0 := Nat.sub_ne_zero_of_lt (Finset.mem_range.mp hi)
+      rw [hv0, zero_pow this, mul_zero, mul_zero]
+    rw [hsum0, add_zero] at hid
+    have hE4z0 : ModularForm.E₄ z ≠ 0 := by rw [hE4z]; exact mul_ne_zero (pow_ne_zero _ hδ) ha0
+    have hE6z0 : ModularForm.E₆ z ≠ 0 := by rw [hE6z]; exact mul_ne_zero (pow_ne_zero _ hδ) hb0
+    have hu0 : u = 0 := by
+      rcases mul_eq_zero.mp hid with h1 | h1
+      · exact pow_eq_zero_iff' |>.mp h1 |>.1
+      · exact absurd (pow_eq_zero_iff' |>.mp h1 |>.1) hE4z0
+    have hg0 : g z = 0 := by
+      simp only [hu, mul_eq_zero, pow_eq_zero_iff', ne_eq] at hu0
+      rcases hu0 with (⟨h1, _⟩ | ⟨h1, _⟩) | ⟨h1, _⟩
+      · exact h1
+      · exact absurd h1 hE4z0
+      · exact absurd h1 hE6z0
+    rw [hg0, zero_mul, zero_mul, zero_mul, norm_zero]
+    positivity
+  have hE4z0 : ModularForm.E₄ z ≠ 0 := by rw [hE4z]; exact mul_ne_zero (pow_ne_zero _ hδ) ha0
+  set U : ℂ := u / v with hU
+  have huv : u = U * v := by rw [hU, div_mul_cancel₀ _ hv0]
+  let κ : ℕ → ℂ := fun i => (K i : ℍ → ℂ) τ / a ^ (3 * m)
+  have ha3 : a ^ (3 * m) ≠ 0 := pow_ne_zero _ ha0
+  have hE4zm : ModularForm.E₄ z ^ (3 * m) = δ ^ (12 * m) * a ^ (3 * m) := by
+    rw [hE4z, mul_pow, ← pow_mul, show 4 * (3 * m) = 12 * m by ring]
+  have hκ : ∀ i ∈ Finset.range n, (K i : ℍ → ℂ) z = κ i * ModularForm.E₄ z ^ (3 * m) := by
+    intro i hi
+    rw [hKz i hi, hE4zm]
+    simp only [κ]
+    rw [div_mul_eq_mul_div, eq_div_iff ha3]
+    ring
+  have hrel : U ^ n + ∑ i ∈ Finset.range n, κ i * U ^ i = 0 := by
+    have hvn : v ^ n * ModularForm.E₄ z ^ (3 * m) ≠ 0 :=
+      mul_ne_zero (pow_ne_zero _ hv0) (pow_ne_zero _ hE4z0)
+    apply (mul_eq_zero.mp ?_).resolve_right hvn
+    rw [← hid, add_mul, Finset.sum_mul]
+    congr 1
+    · rw [huv, mul_pow]; ring
+    · refine Finset.sum_congr rfl fun i hi => ?_
+      have hin : i ≤ n := (Finset.mem_range.mp hi).le
+      rw [hκ i hi, huv, mul_pow, show v ^ n = v ^ i * v ^ (n - i) by rw [← pow_add,
+        Nat.add_sub_cancel' hin]]
+      ring
+  have h22 : (2 : ℝ) ^ (3 * m) * (1 / 2) ^ (3 * m) = 1 := by rw [← mul_pow]; norm_num
+  have hκbd : ∀ i ∈ Finset.range n, ‖κ i‖ ≤ B' := by
+    intro i hi
+    simp only [κ, norm_div, norm_pow]
+    have ha3pos : (0 : ℝ) < ‖a‖ ^ (3 * m) := pow_pos (by linarith) _
+    rw [div_le_iff₀ ha3pos]
+    have h1 : ‖(K i : ℍ → ℂ) τ‖ ≤ B := (hKτ i hi).trans (hκB i hi)
+    have h2 : (1 / 2 : ℝ) ^ (3 * m) ≤ ‖a‖ ^ (3 * m) := pow_le_pow_left₀ (by norm_num) ha_lo.le _
+    calc ‖(K i : ℍ → ℂ) τ‖ ≤ B := h1
+      _ = B * 2 ^ (3 * m) * (1 / 2 : ℝ) ^ (3 * m) := by rw [mul_assoc, h22, mul_one]
+      _ ≤ B * 2 ^ (3 * m) * ‖a‖ ^ (3 * m) :=
+          mul_le_mul_of_nonneg_left h2 (mul_nonneg (by linarith) (by positivity))
+  have hUC : ‖U‖ ≤ C := ANb.norm_le_of_monic_relation hB' hκbd hrel
+  set t : ℝ := ‖δ‖ with ht
+  have ht0 : 0 < t := norm_pos_iff.mpr hδ
+  set ρ : ℝ := ‖δ ^ (-(k + 12))‖ with hρ
+  have hρ0 : 0 < ρ := norm_pos_iff.mpr (zpow_ne_zero _ hδ)
+  have hρ1 : ‖δ ^ (-(k + 14))‖ = ρ * (t ^ 2)⁻¹ := by
+    rw [show -(k + 14) = -(k + 12) + -2 by
+      ring, zpow_add₀ hδ, norm_mul, ← hρ, norm_zpow, ← ht, zpow_neg,
+      zpow_ofNat]
+  set P : ℝ := ‖g z * ModularForm.E₄ z ^ 2 * ModularForm.E₆ z * δ ^ (-(k + 14))‖ with hP
+  set Q : ℝ := ‖h z * ModularForm.discriminant z * δ ^ (-(k + 12))‖ with hQ
+  have hPe : P = ‖g z‖ * (t ^ 4 * ‖a‖) ^ 2 * (t ^ 6 * ‖b‖) * (ρ * (t ^ 2)⁻¹) := by
+    rw [hP, norm_mul, norm_mul, norm_mul, hρ1, norm_pow, hE4z, hE6z, norm_mul, norm_mul, norm_pow,
+      norm_pow]
+  have hQe : Q = ‖h z‖ * (t ^ 12 * ‖d‖) * ρ := by
+    rw [hQ, norm_mul, norm_mul, hΔz, norm_mul, norm_pow]
+  have hue : ‖u‖ = ‖g z‖ ^ (2 * M) * (t ^ 4 * ‖a‖) ^ (3 * M + 3) * (t ^ 6 * ‖b‖) ^ (2 * M) := by
+    rw [hu, norm_mul, norm_mul, norm_pow, norm_pow, norm_pow, hE4z, hE6z, norm_mul, norm_mul,
+      norm_pow, norm_pow]
+  have hve : ‖v‖ = ‖h z‖ ^ (2 * M) * (t ^ 12 * ‖d‖) ^ (2 * M + 1) := by
+    rw [hv, norm_mul, norm_pow, norm_pow, hΔz, norm_mul, norm_pow]
+  have hv' : 0 < ‖v‖ := norm_pos_iff.mpr hv0
+  have hT' : P ^ (2 * M) * ‖a‖ ^ (3 * M + 3) * ‖v‖ = ‖u‖ * Q ^ (2 * M) * ‖d‖ * ‖a‖ ^ (4 * M) := by
+    rw [hPe, hQe, hue, hve]
+    field_simp
+    ring
+  have hT : P ^ (2 * M) * ‖a‖ ^ (3 * M + 3) = ‖U‖ * Q ^ (2 * M) * ‖d‖ * ‖a‖ ^ (4 * M) := by
+    have hUn : ‖U‖ = ‖u‖ / ‖v‖ := by rw [hU, norm_div]
+    rw [hUn, show ‖u‖ / ‖v‖ * Q ^ (2 * M) * ‖d‖ * ‖a‖ ^ (4 * M) =
+      (‖u‖ * Q ^ (2 * M) * ‖d‖ * ‖a‖ ^ (4 * M)) / ‖v‖ by ring, eq_div_iff hv'.ne']
+    exact hT'
+  have hPnn : 0 ≤ P := norm_nonneg _
+  have hQnn : 0 ≤ Q := norm_nonneg _
+  by_cases hM : M = 0
+  · subst hM
+    exfalso
+    simp only [mul_zero, pow_zero, zero_add, one_mul, mul_one] at hT hCη
+    have h1 : (1 / 2 : ℝ) ^ 3 < ‖a‖ ^ 3 := pow_lt_pow_left₀ ha_lo (by norm_num) three_ne_zero
+    have h2 : ‖U‖ * ‖d‖ ≤ C * η₀ := mul_le_mul hUC hd.le (norm_nonneg _) hC0
+    rw [← hT] at h2
+    nlinarith
+  · have h2M : 2 * M ≠ 0 := by omega
+    have hrhs : ‖U‖ * Q ^ (2 * M) * ‖d‖ * ‖a‖ ^ (4 * M) ≤ C * Q ^ (2 * M) * η₀ * (3 / 2) ^ (4 * M)
+      :=
+      by
+      refine mul_le_mul ?_ (pow_le_pow_left₀ (norm_nonneg _) ha_hi.le _) (by positivity) ?_
+      · exact mul_le_mul (mul_le_mul_of_nonneg_right hUC (pow_nonneg hQnn _)) hd.le (norm_nonneg _)
+          (mul_nonneg hC0 (pow_nonneg hQnn _))
+      · exact mul_nonneg (mul_nonneg hC0 (pow_nonneg hQnn _)) hη₀.le
+    have hlhs : P ^ (2 * M) * (1 / 2) ^ (3 * M + 3) ≤ P ^ (2 * M) * ‖a‖ ^ (3 * M + 3) :=
+      mul_le_mul_of_nonneg_left (pow_le_pow_left₀ (by norm_num) ha_lo.le _) (pow_nonneg hPnn _)
+    have hmain : P ^ (2 * M) * (1 / 2) ^ (3 * M + 3) ≤ C * Q ^ (2 * M) * η₀ * (3 / 2) ^ (4 * M) :=
+      hlhs.trans (hT ▸ hrhs)
+    have h32 : (3 / 2 : ℝ) ^ (4 * M) ≤ 2 ^ (4 * M) := pow_le_pow_left₀ (by norm_num) (by norm_num) _
+    have hhalf2 : (1 / 2 : ℝ) ^ (3 * M + 3) * 2 ^ (3 * M + 3) = 1 := by rw [← mul_pow]; norm_num
+    have hcoef : C * η₀ * (3 / 2 : ℝ) ^ (4 * M) ≤ ε ^ (2 * M) * (1 / 2) ^ (3 * M + 3) := by
+      calc C * η₀ * (3 / 2 : ℝ) ^ (4 * M) ≤ C * η₀ * 2 ^ (4 * M) :=
+            mul_le_mul_of_nonneg_left h32 (mul_nonneg hC0 hη₀.le)
+        _ = C * η₀ * (2 ^ (3 * M + 3) * 2 ^ (4 * M)) * (1 / 2) ^ (3 * M + 3) := by
+            rw [show C * η₀ * (2 ^ (3 * M + 3) * 2 ^ (4 * M)) * (1 / 2 : ℝ) ^ (3 * M + 3) =
+              C * η₀ * 2 ^ (4 * M) * ((1 / 2 : ℝ) ^ (3 * M + 3) * 2 ^ (3 * M + 3)) by
+                ring, hhalf2, mul_one]
+        _ ≤ ε ^ (2 * M) * (1 / 2) ^ (3 * M + 3) := mul_le_mul_of_nonneg_right hCη (by positivity)
+    have hpow : P ^ (2 * M) ≤ (ε * Q) ^ (2 * M) := by
+      have hhalf : (0 : ℝ) < (1 / 2) ^ (3 * M + 3) := by positivity
+      have : P ^ (2 * M) * (1 / 2) ^ (3 * M + 3) ≤ (ε * Q) ^ (2 * M) * (1 / 2) ^ (3 * M + 3) := by
+        calc P ^ (2 * M) * (1 / 2) ^ (3 * M + 3) ≤ C * Q ^ (2 * M) * η₀ * (3 / 2) ^ (4 * M) := hmain
+          _ = Q ^ (2 * M) * (C * η₀ * (3 / 2) ^ (4 * M)) := by ring
+          _ ≤ Q ^ (2 * M) * (ε ^ (2 * M) * (1 / 2) ^ (3 * M + 3)) :=
+              mul_le_mul_of_nonneg_left hcoef (pow_nonneg hQnn _)
+          _ = (ε * Q) ^ (2 * M) * (1 / 2) ^ (3 * M + 3) := by ring
+      exact le_of_mul_le_mul_right this hhalf
+    exact (pow_le_pow_iff_left₀ hPnn (by positivity) h2M).mp hpow
+
+end
+end S_ModularCurve_eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv
+end P2MW
+export P2MW.S_ModularCurve_eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+open scoped MatrixGroups ModularForm
+theorem ModularCurve.eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv (N : ℕ) {k : ℤ}
+    (g h : ModularForm (CongruenceSubgroup.Gamma0 N) k) (X : LaurentSeries ℂ)
+    (hX : X * ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) = ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ)) (M : ℕ)
+    (h₂ : IsIntegral (Algebra.adjoin ℂ ({(ModularCurve.coeffEmb ℂ ModularCurve.jq)⁻¹} : Set
+      (LaurentSeries ℂ)))
+      (X ^ (2 * M) * ModularCurve.coeffEmb ℂ ModularCurve.jq ^ (M + 1) * (ModularCurve.coeffEmb ℂ
+        ModularCurve.jq - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ M))
+    (A : Matrix.SpecialLinearGroup (Fin 2) ℤ) (ε : ℝ) (hε : 0 < ε) :
+    ∀ᶠ τ : UpperHalfPlane in UpperHalfPlane.atImInfty,
+      ‖((fun z : UpperHalfPlane => g z * ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) ∣[k + 14] (A : GL
+        (Fin 2) ℝ)) τ‖ ≤
+        ε * ‖((fun z : UpperHalfPlane => h z * ModularForm.discriminant z) ∣[k + 12] (A : GL (Fin 2)
+          ℝ)) τ‖ :=
+  solution N g h X hX M h₂ A ε hε
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv_pow.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv_pow.lean
new file mode 100644
index 0000000000..3bb8d60087
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv_pow.lean
@@ -0,0 +1,846 @@
+/-
+Based on Prove2Me node
+ModularCurve.eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv_pow
+(5991adb3-f9e2-56b1-a149-d155a61b3080) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2875a369-3dff-5b65-afe5-d5211ce2c4c6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import Mathlib.Data.Int.Star
+import Mathlib.Order.CompletePartialOrder
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_tendsto_atImInfty_of_hasSum_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_four_qCoeff_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_six_qCoeff_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Decay of g(E₄²E₆)^m against hΔ^m at the cusps
+
+Theorem statement: `ModularCurve.eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv_pow`
+(`5991adb3-f9e2-56b1-a149-d155a61b3080`), by Claude, 2026-09-05.
+
+Proof: submission `2875a369-3dff-5b65-afe5-d5211ce2c4c6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N \in \mathbb{N}$, a weight $k \in \mathbb{Z}$ and $m \in \mathbb{N}$ with $1 \le m$, and let
+$g, h$ be modular forms of weight $k$ for $\Gamma_0(N)$ with $h \neq 0$. Let $X$ be a Laurent series
+over $\mathbb{C}$ satisfying $X \cdot \tilde h = \tilde g$, where $\tilde g, \tilde h$ denote the
+$q$-expansions of $g$ and $h$ at period $1$, regarded as power series and then as Laurent series.
+Write $j_q$ for the Laurent series $\mathrm{coeffEmb}\ \mathbb{C}\ \mathrm{jq}$, that is, the
+coefficientwise image under $\mathbb{Q} \to \mathbb{C}$ of $q^{-1}$ times the power series
+$\mathrm{jNumQ}$ (the numerator series of the $j$-invariant with rational coefficients). Let $M \in
+\mathbb{N}$ and assume that $X^{2M} \, j_q^{\,mM+1} \, (j_q - 1728)^{mM}$ is integral over the
+$\mathbb{C}$-subalgebra of $\mathbb{C}((q))$ generated by $j_q^{-1}$. Then for every $A \in
+\mathrm{SL}_2(\mathbb{Z})$ and every real $\varepsilon > 0$, one has, for $\tau$ eventually in the
+filter $\mathrm{atImInfty}$ on the upper half-plane,
+$$\bigl\| \bigl((z \mapsto g(z)\,(E_4(z)^2 E_6(z))^m)\bigr|_{k+14m} A\bigr)(\tau) \bigr\| \le
+\varepsilon \, \bigl\| \bigl((z \mapsto h(z)\,\Delta(z)^m)\bigr|_{k+12m} A\bigr)(\tau) \bigr\|,$$
+the slash being the weight-$(k+14m)$, resp. weight-$(k+12m)$, action of the image of $A$ in
+$\mathrm{GL}_2(\mathbb{R})$.
+
+This is the analytic half of the criterion that turns integrality of $X^{2M} j^{mM+1}(j-1728)^{mM}$
+over $\mathbb{C}[1/j]$ into vanishing at the cusps: the order of $X$ in the local parameter at the
+cusp $A\infty$ exceeds the pole order of the relevant power of $j$, so the quotient
+$g(E_4^2E_6)^m/(h\Delta^m)$ tends to $0$ there. It is used by
+[`ModularCurve.exists_cuspForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral`]
+(thm.html#ModularCurve.exists_cuspForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral)
+to produce a cusp form with prescribed $q$-expansion.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv_pow.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv_pow
+
+p2m_open "UpperHalfPlane ModularCurve~coeffEmb_jq"
+open scoped MatrixGroups ModularForm Manifold
+
+noncomputable section
+
+namespace ANb
+
+def Nice (f : ℍ → ℂ) : Prop :=
+  Function.Periodic (f ∘ ofComplex) 1 ∧ MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f ∧ IsBoundedAtImInfty f
+
+theorem Nice.mul {f g : ℍ → ℂ} (hf : Nice f) (hg : Nice g) : Nice (f * g) :=
+  ⟨by simpa [Function.comp_def] using hf.1.mul hg.1, hf.2.1.mul hg.2.1, hf.2.2.mul hg.2.2⟩
+
+theorem Nice.add {f g : ℍ → ℂ} (hf : Nice f) (hg : Nice g) : Nice (f + g) :=
+  ⟨by simpa [Function.comp_def] using hf.1.add hg.1, hf.2.1.add hg.2.1, hf.2.2.add hg.2.2⟩
+
+theorem Nice.const (c : ℂ) : Nice (fun _ => c) :=
+  ⟨fun _ => rfl, mdifferentiable_const, Filter.const_boundedAtFilter _ _⟩
+
+def niceSubalgebra : Subalgebra ℂ (ℍ → ℂ) where
+  carrier := {f | Nice f}
+  mul_mem' hf hg := hf.mul hg
+  add_mem' hf hg := hf.add hg
+  algebraMap_mem' c := Nice.const c
+
+local notation "𝒩" => niceSubalgebra
+
+theorem an (f : 𝒩) : AnalyticAt ℂ (cuspFunction 1 (f : ℍ → ℂ)) 0 :=
+  UpperHalfPlane.analyticAt_cuspFunction_zero one_pos f.2.1 f.2.2.1 f.2.2.2
+
+def qexpHom : 𝒩 →ₐ[ℂ] PowerSeries ℂ where
+  toFun f := qExpansion 1 (f : ℍ → ℂ)
+  map_one' := UpperHalfPlane.qExpansion_one 1
+  map_mul' f g := UpperHalfPlane.qExpansion_mul (an f) (an g)
+  map_zero' := UpperHalfPlane.qExpansion_zero 1
+  map_add' f g := UpperHalfPlane.qExpansion_add (an f) (an g)
+  commutes' c := by
+    have h1 : ((algebraMap ℂ (ℍ → ℂ) c : ℍ → ℂ)) = c • (1 : ℍ → ℂ) := by
+      funext z; simp
+    have a1 : AnalyticAt ℂ (cuspFunction 1 (1 : ℍ → ℂ)) 0 := an (1 : 𝒩)
+    change qExpansion 1 (algebraMap ℂ (ℍ → ℂ) c) = _
+    rw [h1, UpperHalfPlane.qExpansion_smul a1 c, UpperHalfPlane.qExpansion_one,
+      Algebra.algebraMap_eq_smul_one]
+
+theorem qexpHom_apply (f : 𝒩) : qexpHom f = qExpansion 1 (f : ℍ → ℂ) := rfl
+
+def ψ : 𝒩 →ₐ[ℂ] LaurentSeries ℂ :=
+  { (HahnSeries.ofPowerSeries ℤ ℂ).comp qexpHom.toRingHom with
+    commutes' := fun c => by
+      change HahnSeries.ofPowerSeries ℤ ℂ (qexpHom (algebraMap ℂ 𝒩 c)) = _
+      rw [qexpHom.commutes, HahnSeries.algebraMap_apply'] }
+
+theorem ψ_apply (f : 𝒩) : ψ f = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (f : ℍ → ℂ)) := rfl
+
+theorem ψ_injective : Function.Injective ψ := by
+  intro f g hfg
+  rw [ψ_apply, ψ_apply] at hfg
+  have h := HahnSeries.ofPowerSeries_injective hfg
+  have h' : qExpansion 1 ((f : ℍ → ℂ) - (g : ℍ → ℂ)) = 0 := by
+    rw [UpperHalfPlane.qExpansion_sub (an f) (an g), h, sub_self]
+  have hn : Nice ((f : ℍ → ℂ) - (g : ℍ → ℂ)) := (f - g).2
+  have h0 := (UpperHalfPlane.qExpansion_eq_zero_iff one_pos hn.1 hn.2.1 hn.2.2).mp h'
+  exact Subtype.ext (sub_eq_zero.mp h0)
+
+theorem ψ_eq_zero_iff (f : 𝒩) : ψ f = 0 ↔ f = 0 :=
+  ⟨fun h => ψ_injective (by rw [h, map_zero]), fun h => by rw [h, map_zero]⟩
+
+def toC : 𝒩 →ₐ[ℂ] (ℂ → ℂ) where
+  toFun f := (f : ℍ → ℂ) ∘ ofComplex
+  map_one' := rfl
+  map_mul' _ _ := rfl
+  map_zero' := rfl
+  map_add' _ _ := rfl
+  commutes' _ := rfl
+
+theorem toC_apply (f : 𝒩) : toC f = (f : ℍ → ℂ) ∘ ofComplex := rfl
+
+theorem analyticAt_toC (f : 𝒩) (τ : ℍ) : AnalyticAt ℂ (toC f) (τ : ℂ) := by
+  have hd : DifferentiableOn ℂ ((f : ℍ → ℂ) ∘ ofComplex) {z : ℂ | 0 < z.im} :=
+    UpperHalfPlane.mdifferentiable_iff.mp f.2.2.1
+  exact hd.analyticAt ((isOpen_lt continuous_const Complex.continuous_im).mem_nhds τ.im_pos)
+
+theorem nice_of_modularForm {F : Type*} {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (h1 : (1 : ℝ) ∈ Γ.strictPeriods) : Nice (f : ℍ → ℂ) := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Subgroup.isCusp_of_mem_strictPeriods one_pos h1⟩
+  refine ⟨?_, ModularFormClass.holo f, ModularFormClass.bdd_at_infty f⟩
+  simpa using SlashInvariantFormClass.periodic_comp_ofComplex (h := 1) f h1
+
+def ofMF {F : Type*} {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (h1 : (1 : ℝ) ∈ Γ.strictPeriods) : 𝒩 :=
+  ⟨f, nice_of_modularForm f h1⟩
+
+@[scoped simp] theorem coe_ofMF {F : Type*} {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (h1 : (1 : ℝ) ∈ Γ.strictPeriods) :
+    ((ofMF f h1 : 𝒩) : ℍ → ℂ) = f := rfl
+
+theorem one_mem_strictPeriods_gamma0 (N : ℕ) :
+    (1 : ℝ) ∈ (Subgroup.map (Matrix.SpecialLinearGroup.mapGL ℝ) (CongruenceSubgroup.Gamma0
+      N)).strictPeriods := by
+  rw [CongruenceSubgroup.strictPeriods_Gamma0]
+  exact AddSubgroup.mem_zmultiples 1
+
+def 𝔞 : 𝒩 := ofMF ModularForm.E₄ one_mem_strictPeriods_SL
+
+def 𝔟 : 𝒩 := ofMF ModularForm.E₆ one_mem_strictPeriods_SL
+
+def 𝔡 : 𝒩 := ofMF CuspForm.discriminant one_mem_strictPeriods_SL
+
+theorem ψ𝔞 : ψ 𝔞 = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) := rfl
+theorem ψ𝔟 : ψ 𝔟 = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) := rfl
+theorem ψ𝔡 : ψ 𝔡 = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 ModularForm.discriminant) := rfl
+theorem toC𝔡_apply (τ : ℍ) : toC 𝔡 (τ : ℂ) = ModularForm.discriminant τ := by
+  change ModularForm.discriminant (ofComplex (τ : ℂ)) = _
+  rw [ofComplex_apply]
+
+theorem coeff_one_mul (φ χ : PowerSeries ℂ) :
+    PowerSeries.coeff 1 (φ * χ) = PowerSeries.coeff 0 φ * PowerSeries.coeff 1 χ +
+      PowerSeries.coeff 1 φ * PowerSeries.coeff 0 χ := by
+  rw [PowerSeries.coeff_mul, Finset.Nat.sum_antidiagonal_eq_sum_range_succ_mk]
+  simp [Finset.sum_range_succ]
+
+theorem coeff_zero_mul' (φ χ : PowerSeries ℂ) :
+    PowerSeries.coeff 0 (φ * χ) = PowerSeries.coeff 0 φ * PowerSeries.coeff 0 χ := by
+  rw [PowerSeries.coeff_zero_eq_constantCoeff_apply, PowerSeries.coeff_zero_eq_constantCoeff_apply,
+    PowerSeries.coeff_zero_eq_constantCoeff_apply, map_mul]
+
+theorem qA0 : PowerSeries.coeff 0 (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) = 1 :=
+  EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) ⟨2, rfl⟩
+theorem qB0 : PowerSeries.coeff 0 (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) = 1 :=
+  EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) ⟨3, rfl⟩
+theorem qA1 : PowerSeries.coeff 1 (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) = 240 := by
+  have h := ModularForm.levelOne_weight_four_qCoeff_one ModularForm.E₄
+  simp only [ModularFormClass.qCoeff] at h
+  rw [h, qA0, mul_one]
+theorem qB1 : PowerSeries.coeff 1 (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) = -504 := by
+  have h := ModularForm.levelOne_weight_six_qCoeff_one ModularForm.E₆
+  simp only [ModularFormClass.qCoeff] at h
+  rw [h, qB0, mul_one]
+theorem qD1 : PowerSeries.coeff 1 (qExpansion 1 ModularForm.discriminant) = 1 := by
+  rw [ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit, PowerSeries.coeff_map,
+    PowerSeries.coeff_succ_X_mul, PowerSeries.coeff_zero_eq_constantCoeff_apply,
+    ModularCurve.constantCoeff_dedekindEtaUnit, map_one]
+
+theorem A_cube_sub_B_sq : ψ 𝔞 ^ 3 - ψ 𝔟 ^ 2 = 1728 * ψ 𝔡 := by
+  let T : ModularForm 𝒮ℒ 12 := ModularForm.E₄.mul (ModularForm.E₄.mul ModularForm.E₄)
+  let U : ModularForm 𝒮ℒ 12 := ModularForm.E₆.mul ModularForm.E₆
+  let Z : ModularForm 𝒮ℒ 12 := T - U
+  have hZ : (Z : ℍ → ℂ) = ((𝔞 * (𝔞 * 𝔞) - 𝔟 * 𝔟 : 𝒩) : ℍ → ℂ) := by
+    funext z
+    change (T : ℍ → ℂ) z - (U : ℍ → ℂ) z = _
+    rfl
+  have hZq : qExpansion 1 (Z : ℍ → ℂ) =
+      qExpansion 1 ⇑ModularForm.E₄ * (qExpansion 1 ⇑ModularForm.E₄ * qExpansion 1 ⇑ModularForm.E₄) -
+        qExpansion 1 ⇑ModularForm.E₆ * qExpansion 1 ⇑ModularForm.E₆ := by
+    rw [hZ, ← qexpHom_apply, map_sub, map_mul, map_mul, map_mul]
+    rfl
+  have h0 : ModularFormClass.qCoeff (Z : ℍ → ℂ) 0 = 0 := by
+    simp only [ModularFormClass.qCoeff, hZq, map_sub, coeff_zero_mul', qA0, qB0]
+    norm_num
+  have h1 : ModularFormClass.qCoeff (Z : ℍ → ℂ) 1 = 1728 := by
+    simp only [ModularFormClass.qCoeff, hZq, map_sub, coeff_one_mul, coeff_zero_mul', qA0, qA1, qB0,
+      qB1]
+    norm_num
+  have hW := ModularForm.levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant Z h0
+  have hZΔ : qExpansion 1 (Z : ℍ → ℂ) = PowerSeries.C 1728 * qExpansion 1 ModularForm.discriminant
+    :=
+    by
+    ext n
+    rw [PowerSeries.coeff_C_mul]
+    have := hW n
+    have h1' := h1
+    simp only [ModularFormClass.qCoeff] at this h1'
+    rw [this, h1']
+  have hL : ψ (𝔞 * (𝔞 * 𝔞) - 𝔟 * 𝔟) = 1728 * ψ 𝔡 := by
+    rw [ψ_apply, ← hZ, hZΔ, map_mul, HahnSeries.ofPowerSeries_C, map_ofNat, ψ𝔡]
+  rw [map_sub, map_mul, map_mul, map_mul] at hL
+  rw [← hL]
+  ring
+
+theorem ψ𝔡_ne_zero : ψ 𝔡 ≠ 0 := by
+  intro h
+  have h0 : (𝔡 : 𝒩) = 0 := (ψ_eq_zero_iff _).mp h
+  have : ModularForm.discriminant UpperHalfPlane.I = 0 := by
+    have := congrArg (fun f : 𝒩 => (f : ℍ → ℂ) UpperHalfPlane.I) h0
+    simp only [ZeroMemClass.coe_zero, Pi.zero_apply] at this
+    exact this
+  exact ModularForm.discriminant_ne_zero _ this
+
+theorem coeffEmb_jq : coeffEmb ℂ jq = jqModC ℂ := by
+  change (jqModC ℚ).map (algebraMap ℚ ℂ) = jqModC ℂ
+  exact map_jqModC _
+
+theorem J_mul_D : coeffEmb ℂ jq * ψ 𝔡 = ψ 𝔞 ^ 3 := by
+  rw [coeffEmb_jq, ModularCurve.jqModC_eq_qExpansion_E4_cube_div_discriminant, ← ψ𝔞, ← ψ𝔡,
+    div_mul_cancel₀ _ ψ𝔡_ne_zero]
+
+theorem J_sub_mul_D : (coeffEmb ℂ jq - algebraMap ℂ (LaurentSeries ℂ) 1728) * ψ 𝔡 = ψ 𝔟 ^ 2 := by
+  rw [map_ofNat, sub_mul, J_mul_D]
+  have := A_cube_sub_B_sq
+  linear_combination this
+
+theorem le_analyticOrderAt_sum {ι : Type*} (s : Finset ι) (F : ι → ℂ → ℂ) (z : ℂ) (b : ℕ∞)
+    (h : ∀ i ∈ s, b ≤ analyticOrderAt (F i) z) : b ≤ analyticOrderAt (∑ i ∈ s, F i) z := by
+  classical
+  induction s using Finset.induction_on with
+  | empty =>
+    rw [Finset.sum_empty, analyticOrderAt_eq_top.mpr (by simp)]
+    exact le_top
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha]
+    refine le_trans ?_ le_analyticOrderAt_add
+    exact le_min (h a (Finset.mem_insert_self a s)) (ih fun i hi => h i (Finset.mem_insert_of_mem
+      hi))
+
+theorem order_le_of_identity {p q d : ℂ → ℂ} {n m : ℕ} {C : ℕ → ℂ → ℂ} {z : ℂ}
+    (hp : AnalyticAt ℂ p z) (hq : AnalyticAt ℂ q z) (hd : AnalyticAt ℂ d z)
+    (hC : ∀ i ∈ Finset.range n, AnalyticAt ℂ (C i) z) (hd0 : d z ≠ 0)
+    (hid : p ^ (6 * n) * d ^ m + ∑ i ∈ Finset.range n, C i * (p ^ (6 * i) * (q ^ 6 * d) ^ (n - i)) =
+      0) :
+    analyticOrderAt q z ≤ analyticOrderAt p z := by
+  by_contra hlt'
+  have hlt := not_le.mp hlt'
+  obtain ⟨k, hk⟩ : ∃ k : ℕ, (k : ℕ∞) = analyticOrderAt p z :=
+    ENat.ne_top_iff_exists.mp (ne_top_of_lt hlt)
+  have hd_ord : analyticOrderAt d z = 0 := hd.analyticOrderAt_eq_zero.mpr hd0
+  have hL : analyticOrderAt (p ^ (6 * n) * d ^ m) z = ((6 * n * k : ℕ) : ℕ∞) := by
+    rw [analyticOrderAt_mul (hp.pow _) (hd.pow _), analyticOrderAt_pow hp, analyticOrderAt_pow hd,
+      ← hk, hd_ord]
+    simp only [nsmul_eq_mul, smul_zero, add_zero]
+    push_cast
+    ring
+  have hq_ord : ((k + 1 : ℕ) : ℕ∞) ≤ analyticOrderAt q z := by
+    rw [← hk] at hlt
+    have := Order.add_one_le_of_lt hlt
+    exact_mod_cast this
+  have hR : ∀ i ∈ Finset.range n, ((6 * n * k + 6 : ℕ) : ℕ∞) ≤
+      analyticOrderAt (C i * (p ^ (6 * i) * (q ^ 6 * d) ^ (n - i))) z := by
+    intro i hi
+    have hin : i < n := Finset.mem_range.mp hi
+    have hqd : AnalyticAt ℂ (q ^ 6 * d) z := (hq.pow _).mul hd
+    rw [analyticOrderAt_mul (hC i hi) ((hp.pow _).mul (hqd.pow _)),
+      analyticOrderAt_mul (hp.pow _) (hqd.pow _), analyticOrderAt_pow hp, analyticOrderAt_pow hqd,
+      analyticOrderAt_mul (hq.pow _) hd, analyticOrderAt_pow hq, hd_ord, ← hk, add_zero]
+    have h1 : ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞) ≤ (n - i) • (6 • analyticOrderAt q z) := by
+      have : (n - i) • (6 • (((k + 1 : ℕ)) : ℕ∞)) ≤ (n - i) • (6 • analyticOrderAt q z) :=
+        nsmul_le_nsmul_right (nsmul_le_nsmul_right hq_ord 6) (n - i)
+      refine le_trans (le_of_eq ?_) this
+      simp only [nsmul_eq_mul]
+      push_cast
+      ring
+    have h2 : ((6 * n * k + 6 : ℕ) : ℕ∞) ≤ ((6 * i) • (k : ℕ∞)) + ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞)
+      :=
+      by
+      have e : ((6 * i) • (k : ℕ∞)) + ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞) =
+          ((6 * i * k + 6 * (n - i) * (k + 1) : ℕ) : ℕ∞) := by
+        simp only [nsmul_eq_mul]
+        push_cast
+        ring
+      rw [e]
+      exact_mod_cast (show 6 * n * k + 6 ≤ 6 * i * k + 6 * (n - i) * (k + 1) by
+        obtain ⟨j, rfl⟩ := Nat.exists_eq_add_of_lt hin
+        rw [show i + j + 1 - i = j + 1 by omega]
+        nlinarith)
+    calc ((6 * n * k + 6 : ℕ) : ℕ∞)
+        ≤ (6 * i) • (k : ℕ∞) + ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞) := h2
+      _ ≤ (6 * i) • (k : ℕ∞) + (n - i) • (6 • analyticOrderAt q z) := add_le_add le_rfl h1
+      _ ≤ analyticOrderAt (C i) z + ((6 * i) • (k : ℕ∞) + (n - i) • (6 • analyticOrderAt q z)) :=
+          self_le_add_left _ _
+  have hsum := le_analyticOrderAt_sum (Finset.range n) _ z _ hR
+  have heq : p ^ (6 * n) * d ^ m = -(∑ i ∈ Finset.range n, C i * (p ^ (6 * i) * (q ^ 6 * d) ^ (n -
+    i))) :=
+    eq_neg_of_add_eq_zero_left hid
+  have : ((6 * n * k + 6 : ℕ) : ℕ∞) ≤ ((6 * n * k : ℕ) : ℕ∞) := by
+    rw [← hL, heq, analyticOrderAt_neg]
+    exact hsum
+  have := ENat.natCast_le_natCast.mp this
+  omega
+
+end ANb
+
+namespace ANb
+
+local notation "𝒩" => niceSubalgebra
+local notation "𝐉" => ModularCurve.coeffEmb ℂ ModularCurve.jq
+
+theorem ψ𝔞_ne_zero : ψ 𝔞 ≠ 0 := by
+  intro h
+  have h0 : qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) = 0 :=
+    HahnSeries.ofPowerSeries_injective (by rw [← ψ𝔞, h, map_zero])
+  have := qA0
+  rw [h0, map_zero] at this
+  exact zero_ne_one this
+
+theorem J_ne_zero : (𝐉) ≠ 0 := by
+  intro h
+  have := J_mul_D
+  rw [h, zero_mul] at this
+  exact pow_ne_zero 3 ψ𝔞_ne_zero this.symm
+
+theorem Jinv_mul_A_cube : (𝐉)⁻¹ * ψ 𝔞 ^ 3 = ψ 𝔡 := by
+  rw [← J_mul_D, ← mul_assoc, inv_mul_cancel₀ J_ne_zero, one_mul]
+
+def ev (z : ℍ) : 𝒩 →ₐ[ℂ] ℂ where
+  toFun f := (f : ℍ → ℂ) z
+  map_one' := rfl
+  map_mul' _ _ := rfl
+  map_zero' := rfl
+  map_add' _ _ := rfl
+  commutes' _ := rfl
+
+theorem ev_apply (z : ℍ) (f : 𝒩) : ev z f = (f : ℍ → ℂ) z := rfl
+
+theorem slash_coe_apply (f : ℍ → ℂ) (k : ℤ) (A : SL(2, ℤ)) (τ : ℍ) :
+    (f ∣[k] (A : GL (Fin 2) ℝ)) τ = f (A • τ) * denom (A : GL (Fin 2) ℝ) τ ^ (-k) := by
+  rw [← ModularForm.SL_slash]
+  exact ModularForm.SL_slash_apply f A τ
+
+theorem levelOne_apply_smul {k : ℤ} {F : Type*} [FunLike F ℍ ℂ]
+    [SlashInvariantFormClass F 𝒮ℒ k] (f : F) (A : SL(2, ℤ)) (τ : ℍ) :
+    f (A • τ) = denom (A : GL (Fin 2) ℝ) τ ^ k * f τ := by
+  have h1 := congrFun (SlashInvariantForm.slash_action_eqn f (A : GL (Fin 2) ℝ) ⟨A, rfl⟩) τ
+  rw [slash_coe_apply] at h1
+  have hδ := denom_ne_zero (A : GL (Fin 2) ℝ) τ
+  calc f (A • τ) = f (A • τ) * denom (A : GL (Fin 2) ℝ) τ ^ (-k) * denom (A : GL (Fin 2) ℝ) τ ^ k
+    := by
+        rw [mul_assoc, ← zpow_add₀ hδ, neg_add_cancel, zpow_zero, mul_one]
+    _ = denom (A : GL (Fin 2) ℝ) τ ^ k * f τ := by rw [h1, mul_comm]
+
+theorem 𝔞_apply_smul (A : SL(2, ℤ)) (τ : ℍ) :
+    (𝔞 : ℍ → ℂ) (A • τ) = denom (A : GL (Fin 2) ℝ) τ ^ 4 * (𝔞 : ℍ → ℂ) τ := by
+  have := levelOne_apply_smul ModularForm.E₄ A τ
+  simp only [zpow_ofNat] at this
+  exact this
+theorem 𝔟_apply_smul (A : SL(2, ℤ)) (τ : ℍ) :
+    (𝔟 : ℍ → ℂ) (A • τ) = denom (A : GL (Fin 2) ℝ) τ ^ 6 * (𝔟 : ℍ → ℂ) τ := by
+  have := levelOne_apply_smul ModularForm.E₆ A τ
+  simp only [zpow_ofNat] at this
+  exact this
+theorem 𝔡_apply_smul (A : SL(2, ℤ)) (τ : ℍ) :
+    (𝔡 : ℍ → ℂ) (A • τ) = denom (A : GL (Fin 2) ℝ) τ ^ 12 * (𝔡 : ℍ → ℂ) τ := by
+  have := levelOne_apply_smul CuspForm.discriminant A τ
+  simp only [zpow_ofNat] at this
+  exact this
+
+theorem tendsto_nice (f : 𝒩) :
+    Filter.Tendsto (f : ℍ → ℂ) atImInfty (nhds (PowerSeries.coeff 0 (qExpansion 1 (f : ℍ → ℂ))))
+      := by
+  refine ModularCurve.tendsto_atImInfty_of_hasSum_qParam 1 one_pos (f : ℍ → ℂ)
+    (fun m => PowerSeries.coeff m (qExpansion 1 (f : ℍ → ℂ))) fun τ => ?_
+  have := UpperHalfPlane.hasSum_qExpansion one_pos f.2.1 f.2.2.1 f.2.2.2 τ
+  simpa [smul_eq_mul] using this
+
+theorem norm_le_of_monic_relation {n : ℕ} {u : ℂ} {κ : ℕ → ℂ} {B : ℝ} (hB : 0 ≤ B)
+    (hκ : ∀ i ∈ Finset.range n, ‖κ i‖ ≤ B) (h : u ^ n + ∑ i ∈ Finset.range n, κ i * u ^ i = 0) :
+    ‖u‖ ≤ n * B + 1 := by
+  have hnB : 0 ≤ (n : ℝ) * B := mul_nonneg n.cast_nonneg hB
+  by_cases hu' : ‖u‖ ≤ 1
+  · linarith
+  have hu : 1 < ‖u‖ := not_le.mp hu'
+  have hn : n ≠ 0 := by
+    rintro rfl
+    simp at h
+  obtain ⟨n', rfl⟩ := Nat.exists_eq_succ_of_ne_zero hn
+  have hun : u ^ (n' + 1) = -∑ i ∈ Finset.range (n' + 1), κ i * u ^ i :=
+    eq_neg_of_add_eq_zero_left h
+  have hle : ‖u‖ ^ (n' + 1) ≤ (n' + 1 : ℕ) * B * ‖u‖ ^ n' := by
+    calc ‖u‖ ^ (n' + 1) = ‖u ^ (n' + 1)‖ := (norm_pow _ _).symm
+      _ = ‖∑ i ∈ Finset.range (n' + 1), κ i * u ^ i‖ := by rw [hun, norm_neg]
+      _ ≤ ∑ i ∈ Finset.range (n' + 1), ‖κ i * u ^ i‖ := norm_sum_le _ _
+      _ ≤ ∑ i ∈ Finset.range (n' + 1), B * ‖u‖ ^ n' := by
+          refine Finset.sum_le_sum fun i hi => ?_
+          rw [norm_mul, norm_pow]
+          have hi' : i ≤ n' := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)
+          exact mul_le_mul (hκ i hi) (pow_le_pow_right₀ hu.le hi') (pow_nonneg (norm_nonneg _) _) hB
+      _ = (n' + 1 : ℕ) * B * ‖u‖ ^ n' := by
+          rw [Finset.sum_const, Finset.card_range, nsmul_eq_mul]; ring
+  have hpos : 0 < ‖u‖ ^ n' := pow_pos (by linarith) _
+  rw [pow_succ, mul_comm] at hle
+  have := le_of_mul_le_mul_right hle hpos
+  linarith
+
+theorem coreC (𝔤 𝔥 : 𝒩) (X : LaurentSeries ℂ) (hX : X * ψ 𝔥 = ψ 𝔤) (M w : ℕ)
+    (h₂ : IsIntegral (Algebra.adjoin ℂ ({(𝐉)⁻¹} : Set (LaurentSeries ℂ)))
+      (X ^ (2 * M) * 𝐉 ^ (w * M + 1) * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (w * M))) :
+    ∃ (n m : ℕ) (K : ℕ → 𝒩),
+      (∀ i ∈ Finset.range n, ∀ (A : SL(2, ℤ)) (τ : ℍ), (K i : ℍ → ℂ) (A • τ) =
+          denom (A : GL (Fin 2) ℝ) τ ^ (12 * m) * (K i : ℍ → ℂ) τ) ∧
+      (𝔤 ^ (2 * M) * 𝔞 ^ (3 * (w * M) + 3) * 𝔟 ^ (2 * (w * M))) ^ n * 𝔞 ^ (3 * m) +
+        ∑ i ∈ Finset.range n, K i * ((𝔤 ^ (2 * M) * 𝔞 ^ (3 * (w * M) + 3) * 𝔟 ^ (2 * (w * M))) ^ i *
+          (𝔥 ^ (2 * M) * 𝔡 ^ (2 * (w * M) + 1)) ^ (n - i)) = 0 := by
+  classical
+  have key1 : (X ^ (2 * M) * 𝐉 ^ (w * M + 1) * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (w * M))
+    *
+      (ψ 𝔥 ^ (2 * M) * ψ 𝔡 ^ (2 * (w * M) + 1)) = ψ 𝔤 ^ (2 * M) * ψ 𝔞 ^ (3 * (w * M) + 3) * ψ 𝔟 ^ (2
+        * (w * M)) := by
+    calc (X ^ (2 * M) * 𝐉 ^ (w * M + 1) * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (w * M)) *
+          (ψ 𝔥 ^ (2 * M) * ψ 𝔡 ^ (2 * (w * M) + 1))
+        = (X * ψ 𝔥) ^ (2 * M) * (𝐉 * ψ 𝔡) ^ (w * M + 1) * ((𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728)
+          * ψ 𝔡) ^ (w * M) := by
+          rw [mul_pow (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) (ψ 𝔡) (w * M), mul_pow X (ψ 𝔥),
+            mul_pow (𝐉) (ψ 𝔡)]
+          ring
+      _ = (ψ 𝔤) ^ (2 * M) * (ψ 𝔞 ^ 3) ^ (w * M + 1) * (ψ 𝔟 ^ 2) ^ (w * M) := by rw [hX, J_mul_D,
+        J_sub_mul_D]
+      _ = ψ 𝔤 ^ (2 * M) * ψ 𝔞 ^ (3 * (w * M) + 3) * ψ 𝔟 ^ (2 * (w * M)) := by
+          rw [← pow_mul, ← pow_mul, show 3 * (w * M + 1) = 3 * (w * M) + 3 by ring]
+  obtain ⟨p, hpm, hpev⟩ := h₂
+  rw [hpm.as_sum] at hpev
+  simp only [Polynomial.eval₂_add, Polynomial.eval₂_pow, Polynomial.eval₂_X,
+    Polynomial.eval₂_finsetSum,
+    Polynomial.eval₂_mul, Polynomial.eval₂_C] at hpev
+  set R := Algebra.adjoin ℂ ({(𝐉)⁻¹} : Set (LaurentSeries ℂ)) with hR
+  set Y := X ^ (2 * M) * 𝐉 ^ (w * M + 1) * (𝐉 - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (w * M) with
+    hY
+  set n := p.natDegree with hn
+  clear_value Y
+  have hmem : ∀ i, ∃ c : Polynomial ℂ,
+      Polynomial.aeval ((𝐉)⁻¹) c = algebraMap R (LaurentSeries ℂ) (p.coeff i) := by
+    intro i
+    have hi' : algebraMap R (LaurentSeries ℂ) (p.coeff i) ∈ (Polynomial.aeval (R := ℂ)
+      ((𝐉)⁻¹)).range :=
+      by
+      rw [← Algebra.adjoin_singleton_eq_range_aeval]
+      exact (p.coeff i).2
+    exact hi'
+  choose c hc using hmem
+  set m := ∑ i ∈ Finset.range n, (c i).natDegree with hm
+  have hdeg : ∀ i ∈ Finset.range n, (c i).natDegree ≤ m := fun i hi =>
+    Finset.single_le_sum (f := fun j => (c j).natDegree) (fun j _ => Nat.zero_le _) hi
+  clear_value m
+  let K : ℕ → 𝒩 := fun i =>
+    ∑ l ∈ Finset.range ((c i).natDegree + 1), algebraMap ℂ 𝒩 ((c i).coeff l) * (𝔡 ^ l * 𝔞 ^ (3 * (m
+      - l)))
+  have key3 : ∀ i ∈ Finset.range n, ψ 𝔞 ^ (3 * m) * algebraMap R (LaurentSeries ℂ) (p.coeff i) = ψ
+    (K i) :=
+    by
+    intro i hi
+    simp only [K, map_sum, map_mul, map_pow, AlgHom.commutes]
+    rw [← hc i, Polynomial.aeval_eq_sum_range, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun l hl => ?_
+    have hlm : l ≤ m := (Nat.lt_succ_iff.mp (Finset.mem_range.mp hl)).trans (hdeg i hi)
+    rw [Algebra.smul_def, mul_left_comm]
+    congr 1
+    calc ψ 𝔞 ^ (3 * m) * (𝐉)⁻¹ ^ l = ψ 𝔞 ^ (3 * (m - l)) * (ψ 𝔞 ^ 3) ^ l * (𝐉)⁻¹ ^ l := by
+          rw [← pow_mul, ← pow_add, show 3 * (m - l) + 3 * l = 3 * m by omega]
+      _ = ψ 𝔞 ^ (3 * (m - l)) * ((𝐉)⁻¹ * ψ 𝔞 ^ 3) ^ l := by rw [mul_pow ((𝐉)⁻¹)]; ring
+      _ = ψ 𝔡 ^ l * ψ 𝔞 ^ (3 * (m - l)) := by rw [Jinv_mul_A_cube, mul_comm]
+  let W : 𝒩 := 𝔤 ^ (2 * M) * 𝔞 ^ (3 * (w * M) + 3) * 𝔟 ^ (2 * (w * M))
+  let V : 𝒩 := 𝔥 ^ (2 * M) * 𝔡 ^ (2 * (w * M) + 1)
+  have k1 : Y * ψ V = ψ W := by
+    simp only [W, V, map_mul, map_pow]
+    exact key1
+  have key2 : ∀ i ≤ n, ψ V ^ n * Y ^ i = ψ W ^ i * ψ V ^ (n - i) := by
+    intro i hi
+    have e : ψ V ^ n = ψ V ^ i * ψ V ^ (n - i) := by
+      rw [← pow_add, Nat.add_sub_cancel' hi]
+    calc ψ V ^ n * Y ^ i = (Y * ψ V) ^ i * ψ V ^ (n - i) := by
+          rw [e, mul_pow Y (ψ V) i]; ring
+      _ = ψ W ^ i * ψ V ^ (n - i) := by rw [k1]
+  let E : 𝒩 := W ^ n * 𝔞 ^ (3 * m) + ∑ i ∈ Finset.range n, K i * (W ^ i * V ^ (n - i))
+  have hE : ψ E = ψ V ^ n * ψ 𝔞 ^ (3 * m) *
+      (Y ^ n + ∑ i ∈ Finset.range n, algebraMap R (LaurentSeries ℂ) (p.coeff i) * Y ^ i) := by
+    rw [mul_add, Finset.mul_sum]
+    simp only [E, map_add, map_sum, map_mul, map_pow]
+    congr 1
+    · have h2 := key2 n le_rfl
+      rw [Nat.sub_self, pow_zero, mul_one] at h2
+      rw [mul_right_comm, h2]
+    · refine Finset.sum_congr rfl fun i hi => ?_
+      have hin : i ≤ n := (Finset.mem_range.mp hi).le
+      rw [← key3 i hi, ← key2 i hin]
+      ring
+  have hE0 : E = 0 := by
+    apply ψ_injective
+    rw [hE, hpev, mul_zero, map_zero]
+  refine ⟨n, m, K, fun i hi A τ => ?_, hE0⟩
+  have hlm : ∀ l ∈ Finset.range ((c i).natDegree + 1), l ≤ m := fun l hl =>
+    (Nat.lt_succ_iff.mp (Finset.mem_range.mp hl)).trans (hdeg i hi)
+  change ev (A • τ) (K i) = denom (A : GL (Fin 2) ℝ) τ ^ (12 * m) * ev τ (K i)
+  simp only [K, map_sum, map_mul, map_pow, AlgHom.commutes, Finset.mul_sum]
+  refine Finset.sum_congr rfl fun l hl => ?_
+  rw [ev_apply, ev_apply, ev_apply, ev_apply, 𝔡_apply_smul, 𝔞_apply_smul,
+    show 12 * m = 12 * l + 4 * (3 * (m - l)) by have := hlm l hl; omega]
+  ring
+
+end ANb
+
+open ANb in
+theorem solution (N : ℕ) {k : ℤ} (m : ℕ)
+    (g h : ModularForm (CongruenceSubgroup.Gamma0 N) k) (X : LaurentSeries ℂ)
+    (hX : X * ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) = ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ)) (M : ℕ)
+    (h₂ : IsIntegral (Algebra.adjoin ℂ ({(ModularCurve.coeffEmb ℂ ModularCurve.jq)⁻¹} : Set
+      (LaurentSeries ℂ)))
+      (X ^ (2 * M) * ModularCurve.coeffEmb ℂ ModularCurve.jq ^ (m * M + 1) * (ModularCurve.coeffEmb
+        ℂ ModularCurve.jq - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (m * M)))
+    (A : Matrix.SpecialLinearGroup (Fin 2) ℤ) (ε : ℝ) (hε : 0 < ε) :
+    ∀ᶠ τ : UpperHalfPlane in UpperHalfPlane.atImInfty,
+      ‖((fun z : UpperHalfPlane => g z * (ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) ^ m) ∣[k + 14 *
+        (m : ℤ)] (A : GL (Fin 2) ℝ)) τ‖ ≤
+        ε * ‖((fun z : UpperHalfPlane => h z * ModularForm.discriminant z ^ m) ∣[k + 12 * (m : ℤ)]
+          (A : GL (Fin 2) ℝ)) τ‖ := by
+  classical
+  obtain ⟨n, μ, K, hK, hE⟩ := ANb.coreC (ANb.ofMF g (ANb.one_mem_strictPeriods_gamma0 N))
+    (ANb.ofMF h (ANb.one_mem_strictPeriods_gamma0 N)) X hX M m h₂
+  let κ0 : ℕ → ℝ := fun i => ‖PowerSeries.coeff 0 (qExpansion 1 (K i : ℍ → ℂ))‖ + 1
+  let B : ℝ := 1 + ∑ i ∈ Finset.range n, κ0 i
+  have hκ0 : ∀ i, 0 ≤ κ0 i := fun i => by positivity
+  have hB1 : 1 ≤ B := le_add_of_nonneg_right (Finset.sum_nonneg fun i _ => hκ0 i)
+  have hκB : ∀ i ∈ Finset.range n, κ0 i ≤ B := fun i hi =>
+    (Finset.single_le_sum (f := κ0) (fun j _ => hκ0 j) hi).trans (le_add_of_nonneg_left zero_le_one)
+  let B' : ℝ := B * 2 ^ (3 * μ)
+  have hB' : 0 ≤ B' := by positivity
+  let C : ℝ := n * B' + 1
+  have hC : 1 ≤ C := le_add_of_nonneg_left (by positivity)
+  have hC0 : 0 ≤ C := by linarith
+  obtain ⟨η₀, hη₀def⟩ : ∃ e : ℝ, e = ε ^ (2 * M) / (2 ^ (3 * (m * M) + 3) * 2 ^ (4 * (m * M)) * (C +
+    1)) :=
+    ⟨_, rfl⟩
+  have hη₀ : 0 < η₀ := by rw [hη₀def]; positivity
+  have hCη : C * η₀ * (2 ^ (3 * (m * M) + 3) * 2 ^ (4 * (m * M))) ≤ ε ^ (2 * M) := by
+    have e1 : C * η₀ * (2 ^ (3 * (m * M) + 3) * 2 ^ (4 * (m * M))) = ε ^ (2 * M) * (C / (C + 1)) :=
+      by
+      rw [hη₀def]
+      field_simp
+    rw [e1]
+    have h1 : C / (C + 1) ≤ 1 := (div_le_one (by linarith)).mpr (by linarith)
+    calc ε ^ (2 * M) * (C / (C + 1)) ≤ ε ^ (2 * M) * 1 := by
+          exact mul_le_mul_of_nonneg_left h1 (by positivity)
+      _ = ε ^ (2 * M) := mul_one _
+  have t4 : Filter.Tendsto (fun τ : ℍ => ModularForm.E₄ τ) atImInfty (nhds 1) := by
+    have := ANb.tendsto_nice ANb.𝔞
+    rwa [show PowerSeries.coeff 0 (qExpansion 1 ((ANb.𝔞 : ℍ → ℂ))) = 1 from ANb.qA0] at this
+  have t6 : Filter.Tendsto (fun τ : ℍ => ModularForm.E₆ τ) atImInfty (nhds 1) := by
+    have := ANb.tendsto_nice ANb.𝔟
+    rwa [show PowerSeries.coeff 0 (qExpansion 1 ((ANb.𝔟 : ℍ → ℂ))) = 1 from ANb.qB0] at this
+  have tΔ : Filter.Tendsto ModularForm.discriminant atImInfty (nhds 0) :=
+    ModularForm.discriminant_isZeroAtImInfty
+  have e4 : ∀ᶠ τ : ℍ in atImInfty, dist (ModularForm.E₄ τ) 1 < 1 / 2 :=
+    Metric.tendsto_nhds.mp t4 _ (by norm_num)
+  have e6 : ∀ᶠ τ : ℍ in atImInfty, dist (ModularForm.E₆ τ) 1 < 1 / 2 :=
+    Metric.tendsto_nhds.mp t6 _ (by norm_num)
+  have eΔ : ∀ᶠ τ : ℍ in atImInfty, dist (ModularForm.discriminant τ) 0 < η₀ :=
+    Metric.tendsto_nhds.mp tΔ _ hη₀
+  have eK : ∀ᶠ τ : ℍ in atImInfty, ∀ i ∈ Finset.range n, ‖(K i : ℍ → ℂ) τ‖ ≤ κ0 i := by
+    refine (Filter.eventually_all_finset _).mpr fun i _ => ?_
+    have := Metric.tendsto_nhds.mp (ANb.tendsto_nice (K i)) 1 one_pos
+    filter_upwards [this] with τ hτ
+    rw [dist_eq_norm] at hτ
+    exact (norm_le_insert' _ _).trans (by simp only [κ0]; linarith)
+  filter_upwards [e4, e6, eΔ, eK] with τ h4 h6 hd hKτ
+  rw [dist_eq_norm] at h4 h6
+  rw [dist_zero_right] at hd
+  set δ : ℂ := denom (A : GL (Fin 2) ℝ) τ with hδdef
+  have hδ : δ ≠ 0 := denom_ne_zero _ _
+  set a : ℂ := ModularForm.E₄ τ with ha
+  set b : ℂ := ModularForm.E₆ τ with hb
+  set d : ℂ := ModularForm.discriminant τ with hdd
+  have ha_lo : 1 / 2 < ‖a‖ := by
+    have := norm_le_insert' (1 : ℂ) a; rw [norm_one, norm_sub_rev] at this; linarith
+  have ha_hi : ‖a‖ < 3 / 2 := by
+    have := norm_le_insert' a (1 : ℂ); rw [norm_one] at this; linarith
+  have hb_lo : 1 / 2 < ‖b‖ := by
+    have := norm_le_insert' (1 : ℂ) b; rw [norm_one, norm_sub_rev] at this; linarith
+  have ha0 : a ≠ 0 := fun h0 => by rw [h0, norm_zero] at ha_lo; linarith
+  have hb0 : b ≠ 0 := fun h0 => by rw [h0, norm_zero] at hb_lo; linarith
+  have hd0 : d ≠ 0 := ModularForm.discriminant_ne_zero τ
+  set z : ℍ := A • τ with hz
+  have hE4z : ModularForm.E₄ z = δ ^ 4 * a := ANb.𝔞_apply_smul A τ
+  have hE6z : ModularForm.E₆ z = δ ^ 6 * b := ANb.𝔟_apply_smul A τ
+  have hΔz : ModularForm.discriminant z = δ ^ 12 * d := ANb.𝔡_apply_smul A τ
+  have hKz : ∀ i ∈ Finset.range n, (K i : ℍ → ℂ) z = δ ^ (12 * μ) * (K i : ℍ → ℂ) τ :=
+    fun i hi => hK i hi A τ
+  set u : ℂ := g z ^ (2 * M) * ModularForm.E₄ z ^ (3 * (m * M) + 3) * ModularForm.E₆ z ^ (2 * (m *
+    M)) with hu
+  set v : ℂ := h z ^ (2 * M) * ModularForm.discriminant z ^ (2 * (m * M) + 1) with hv
+  have hid : u ^ n * ModularForm.E₄ z ^ (3 * μ) +
+      ∑ i ∈ Finset.range n, (K i : ℍ → ℂ) z * (u ^ i * v ^ (n - i)) = 0 := by
+    have := congrArg (ANb.ev z) hE
+    simp only [map_add, map_sum, map_mul, map_pow, map_zero, ANb.ev_apply] at this
+    exact this
+  clear_value u v
+  rw [ANb.slash_coe_apply, ANb.slash_coe_apply]
+  change ‖g z * (ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) ^ m * δ ^ (-(k + 14 * (m : ℤ)))‖ ≤
+    ε * ‖h z * ModularForm.discriminant z ^ m * δ ^ (-(k + 12 * (m : ℤ)))‖
+  by_cases hv0 : v = 0
+  · have hMpos : M ≠ 0 := by
+      rintro rfl
+      apply hd0
+      have : ModularForm.discriminant z ^ (2 * (m * 0) + 1) = 0 := by simpa [hv] using hv0
+      rw [mul_zero, mul_zero, zero_add, pow_one] at this
+      simpa [hΔz, hδ] using this
+    have hsum0 : ∑ i ∈ Finset.range n, (K i : ℍ → ℂ) z * (u ^ i * v ^ (n - i)) = 0 := by
+      refine Finset.sum_eq_zero fun i hi => ?_
+      have : n - i ≠ 0 := Nat.sub_ne_zero_of_lt (Finset.mem_range.mp hi)
+      rw [hv0, zero_pow this, mul_zero, mul_zero]
+    rw [hsum0, add_zero] at hid
+    have hE4z0 : ModularForm.E₄ z ≠ 0 := by rw [hE4z]; exact mul_ne_zero (pow_ne_zero _ hδ) ha0
+    have hE6z0 : ModularForm.E₆ z ≠ 0 := by rw [hE6z]; exact mul_ne_zero (pow_ne_zero _ hδ) hb0
+    have hu0 : u = 0 := by
+      rcases mul_eq_zero.mp hid with h1 | h1
+      · exact pow_eq_zero_iff' |>.mp h1 |>.1
+      · exact absurd (pow_eq_zero_iff' |>.mp h1 |>.1) hE4z0
+    have hg0 : g z = 0 := by
+      simp only [hu, mul_eq_zero, pow_eq_zero_iff', ne_eq] at hu0
+      rcases hu0 with (⟨h1, _⟩ | ⟨h1, _⟩) | ⟨h1, _⟩
+      · exact h1
+      · exact absurd h1 hE4z0
+      · exact absurd h1 hE6z0
+    rw [hg0, zero_mul, zero_mul, norm_zero]
+    positivity
+  have hE4z0 : ModularForm.E₄ z ≠ 0 := by rw [hE4z]; exact mul_ne_zero (pow_ne_zero _ hδ) ha0
+  set U : ℂ := u / v with hU
+  have huv : u = U * v := by rw [hU, div_mul_cancel₀ _ hv0]
+  let κ : ℕ → ℂ := fun i => (K i : ℍ → ℂ) τ / a ^ (3 * μ)
+  have ha3 : a ^ (3 * μ) ≠ 0 := pow_ne_zero _ ha0
+  have hE4zm : ModularForm.E₄ z ^ (3 * μ) = δ ^ (12 * μ) * a ^ (3 * μ) := by
+    rw [hE4z, mul_pow, ← pow_mul, show 4 * (3 * μ) = 12 * μ by ring]
+  have hκ : ∀ i ∈ Finset.range n, (K i : ℍ → ℂ) z = κ i * ModularForm.E₄ z ^ (3 * μ) := by
+    intro i hi
+    rw [hKz i hi, hE4zm]
+    simp only [κ]
+    rw [div_mul_eq_mul_div, eq_div_iff ha3]
+    ring
+  have hrel : U ^ n + ∑ i ∈ Finset.range n, κ i * U ^ i = 0 := by
+    have hvn : v ^ n * ModularForm.E₄ z ^ (3 * μ) ≠ 0 :=
+      mul_ne_zero (pow_ne_zero _ hv0) (pow_ne_zero _ hE4z0)
+    apply (mul_eq_zero.mp ?_).resolve_right hvn
+    rw [← hid, add_mul, Finset.sum_mul]
+    congr 1
+    · rw [huv, mul_pow]; ring
+    · refine Finset.sum_congr rfl fun i hi => ?_
+      have hin : i ≤ n := (Finset.mem_range.mp hi).le
+      rw [hκ i hi, huv, mul_pow, show v ^ n = v ^ i * v ^ (n - i) by rw [← pow_add,
+        Nat.add_sub_cancel' hin]]
+      ring
+  have h22 : (2 : ℝ) ^ (3 * μ) * (1 / 2) ^ (3 * μ) = 1 := by rw [← mul_pow]; norm_num
+  have hκbd : ∀ i ∈ Finset.range n, ‖κ i‖ ≤ B' := by
+    intro i hi
+    simp only [κ, norm_div, norm_pow]
+    have ha3pos : (0 : ℝ) < ‖a‖ ^ (3 * μ) := pow_pos (by linarith) _
+    rw [div_le_iff₀ ha3pos]
+    have h1 : ‖(K i : ℍ → ℂ) τ‖ ≤ B := (hKτ i hi).trans (hκB i hi)
+    have h2 : (1 / 2 : ℝ) ^ (3 * μ) ≤ ‖a‖ ^ (3 * μ) := pow_le_pow_left₀ (by norm_num) ha_lo.le _
+    calc ‖(K i : ℍ → ℂ) τ‖ ≤ B := h1
+      _ = B * 2 ^ (3 * μ) * (1 / 2 : ℝ) ^ (3 * μ) := by rw [mul_assoc, h22, mul_one]
+      _ ≤ B * 2 ^ (3 * μ) * ‖a‖ ^ (3 * μ) :=
+          mul_le_mul_of_nonneg_left h2 (mul_nonneg (by linarith) (by positivity))
+  have hUC : ‖U‖ ≤ C := ANb.norm_le_of_monic_relation hB' hκbd hrel
+  set t : ℝ := ‖δ‖ with ht
+  have ht0 : 0 < t := norm_pos_iff.mpr hδ
+  set ρ : ℝ := ‖δ ^ (-(k + 14 * (m : ℤ)))‖ with hρ
+  have hρ0 : 0 < ρ := norm_pos_iff.mpr (zpow_ne_zero _ hδ)
+  have hρ1 : ‖δ ^ (-(k + 12 * (m : ℤ)))‖ = ρ * t ^ (2 * m) := by
+    rw [show -(k + 12 * (m : ℤ)) = -(k + 14 * (m : ℤ)) + ((2 * m : ℕ) : ℤ) by
+      push_cast; ring, zpow_add₀ hδ, norm_mul,
+      ← hρ, zpow_natCast, norm_pow, ← ht]
+  set P : ℝ := ‖g z * (ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) ^ m * δ ^ (-(k + 14 * (m : ℤ)))‖
+    with hP
+  set Q : ℝ := ‖h z * ModularForm.discriminant z ^ m * δ ^ (-(k + 12 * (m : ℤ)))‖ with hQ
+  have hPe : P = ‖g z‖ * ((t ^ 4 * ‖a‖) ^ 2 * (t ^ 6 * ‖b‖)) ^ m * ρ := by
+    rw [hP, norm_mul, norm_mul, ← hρ, norm_pow, norm_mul, norm_pow, hE4z, hE6z, norm_mul, norm_mul,
+      norm_pow, norm_pow]
+  have hQe : Q = ‖h z‖ * (t ^ 12 * ‖d‖) ^ m * (ρ * t ^ (2 * m)) := by
+    rw [hQ, norm_mul, norm_mul, hρ1, norm_pow, hΔz, norm_mul, norm_pow]
+  have hue : ‖u‖ = ‖g z‖ ^ (2 * M) * (t ^ 4 * ‖a‖) ^ (3 * (m * M) + 3) * (t ^ 6 * ‖b‖) ^ (2 * (m *
+    M)) :=
+    by
+    rw [hu, norm_mul, norm_mul, norm_pow, norm_pow, norm_pow, hE4z, hE6z, norm_mul, norm_mul,
+      norm_pow, norm_pow]
+  have hve : ‖v‖ = ‖h z‖ ^ (2 * M) * (t ^ 12 * ‖d‖) ^ (2 * (m * M) + 1) := by
+    rw [hv, norm_mul, norm_pow, norm_pow, hΔz, norm_mul, norm_pow]
+  have hv' : 0 < ‖v‖ := norm_pos_iff.mpr hv0
+  have hT' : P ^ (2 * M) * ‖a‖ ^ (3 * (m * M) + 3) * ‖v‖ = ‖u‖ * Q ^ (2 * M) * ‖d‖ * ‖a‖ ^ (4 * (m *
+    M)) :=
+    by
+    rw [hPe, hQe, hue, hve]
+    ring
+  have hT : P ^ (2 * M) * ‖a‖ ^ (3 * (m * M) + 3) = ‖U‖ * Q ^ (2 * M) * ‖d‖ * ‖a‖ ^ (4 * (m * M)) :=
+    by
+    have hUn : ‖U‖ = ‖u‖ / ‖v‖ := by rw [hU, norm_div]
+    rw [hUn, show ‖u‖ / ‖v‖ * Q ^ (2 * M) * ‖d‖ * ‖a‖ ^ (4 * (m * M)) =
+      (‖u‖ * Q ^ (2 * M) * ‖d‖ * ‖a‖ ^ (4 * (m * M))) / ‖v‖ by ring, eq_div_iff hv'.ne']
+    exact hT'
+  have hPnn : 0 ≤ P := norm_nonneg _
+  have hQnn : 0 ≤ Q := norm_nonneg _
+  by_cases hM : M = 0
+  · subst hM
+    exfalso
+    simp only [mul_zero, pow_zero, zero_add, one_mul, mul_one] at hT hCη
+    have h1 : (1 / 2 : ℝ) ^ 3 < ‖a‖ ^ 3 := pow_lt_pow_left₀ ha_lo (by norm_num) three_ne_zero
+    have h2 : ‖U‖ * ‖d‖ ≤ C * η₀ := mul_le_mul hUC hd.le (norm_nonneg _) hC0
+    rw [← hT] at h2
+    nlinarith
+  · have h2M : 2 * M ≠ 0 := by omega
+    have hrhs : ‖U‖ * Q ^ (2 * M) * ‖d‖ * ‖a‖ ^ (4 * (m * M)) ≤ C * Q ^ (2 * M) * η₀ * (3 / 2) ^ (4
+      * (m * M)) :=
+      by
+      refine mul_le_mul ?_ (pow_le_pow_left₀ (norm_nonneg _) ha_hi.le _) (by positivity) ?_
+      · exact mul_le_mul (mul_le_mul_of_nonneg_right hUC (pow_nonneg hQnn _)) hd.le (norm_nonneg _)
+          (mul_nonneg hC0 (pow_nonneg hQnn _))
+      · exact mul_nonneg (mul_nonneg hC0 (pow_nonneg hQnn _)) hη₀.le
+    have hlhs : P ^ (2 * M) * (1 / 2) ^ (3 * (m * M) + 3) ≤ P ^ (2 * M) * ‖a‖ ^ (3 * (m * M) + 3) :=
+      mul_le_mul_of_nonneg_left (pow_le_pow_left₀ (by norm_num) ha_lo.le _) (pow_nonneg hPnn _)
+    have hmain : P ^ (2 * M) * (1 / 2) ^ (3 * (m * M) + 3) ≤ C * Q ^ (2 * M) * η₀ * (3 / 2) ^ (4 *
+      (m * M)) :=
+      hlhs.trans (hT ▸ hrhs)
+    have h32 : (3 / 2 : ℝ) ^ (4 * (m * M)) ≤ 2 ^ (4 * (m * M)) :=
+      pow_le_pow_left₀ (by norm_num) (by norm_num) _
+    have hhalf2 : (1 / 2 : ℝ) ^ (3 * (m * M) + 3) * 2 ^ (3 * (m * M) + 3) = 1 :=
+      by rw [← mul_pow]; norm_num
+    have hcoef : C * η₀ * (3 / 2 : ℝ) ^ (4 * (m * M)) ≤ ε ^ (2 * M) * (1 / 2) ^ (3 * (m * M) + 3) :=
+      by
+      calc C * η₀ * (3 / 2 : ℝ) ^ (4 * (m * M)) ≤ C * η₀ * 2 ^ (4 * (m * M)) :=
+            mul_le_mul_of_nonneg_left h32 (mul_nonneg hC0 hη₀.le)
+        _ = C * η₀ * (2 ^ (3 * (m * M) + 3) * 2 ^ (4 * (m * M))) * (1 / 2) ^ (3 * (m * M) + 3) := by
+            rw [show C * η₀ * (2 ^ (3 * (m * M) + 3) * 2 ^ (4 * (m * M))) * (1 / 2 : ℝ) ^ (3 * (m *
+              M) + 3) =
+              C * η₀ * 2 ^ (4 * (m * M)) * ((1 / 2 : ℝ) ^ (3 * (m * M) + 3) * 2 ^ (3 * (m * M) +
+                3)) by
+                ring, hhalf2, mul_one]
+        _ ≤ ε ^ (2 * M) * (1 / 2) ^ (3 * (m * M) + 3) := mul_le_mul_of_nonneg_right hCη (by
+          positivity)
+    have hpow : P ^ (2 * M) ≤ (ε * Q) ^ (2 * M) := by
+      have hhalf : (0 : ℝ) < (1 / 2) ^ (3 * (m * M) + 3) := by positivity
+      have : P ^ (2 * M) * (1 / 2) ^ (3 * (m * M) + 3) ≤ (ε * Q) ^ (2 * M) * (1 / 2) ^ (3 * (m * M)
+        + 3) :=
+        by
+        calc P ^ (2 * M) * (1 / 2) ^ (3 * (m * M) + 3) ≤ C * Q ^ (2 * M) * η₀ * (3 / 2) ^ (4 * (m *
+          M)) := hmain
+          _ = Q ^ (2 * M) * (C * η₀ * (3 / 2) ^ (4 * (m * M))) := by ring
+          _ ≤ Q ^ (2 * M) * (ε ^ (2 * M) * (1 / 2) ^ (3 * (m * M) + 3)) :=
+              mul_le_mul_of_nonneg_left hcoef (pow_nonneg hQnn _)
+          _ = (ε * Q) ^ (2 * M) * (1 / 2) ^ (3 * (m * M) + 3) := by ring
+      exact le_of_mul_le_mul_right this hhalf
+    exact (pow_le_pow_iff_left₀ hPnn (by positivity) h2M).mp hpow
+
+end
+end S_ModularCurve_eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv_pow
+end P2MW
+export P2MW.S_ModularCurve_eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv_pow
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+open scoped MatrixGroups ModularForm
+theorem ModularCurve.eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv_pow (N : ℕ)
+    {k : ℤ} (m : ℕ)
+    (g h : ModularForm (CongruenceSubgroup.Gamma0 N) k) (X : LaurentSeries ℂ)
+    (hX : X * ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) = ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ)) (M : ℕ)
+    (h₂ : IsIntegral (Algebra.adjoin ℂ ({(ModularCurve.coeffEmb ℂ ModularCurve.jq)⁻¹} : Set
+      (LaurentSeries ℂ)))
+      (X ^ (2 * M) * ModularCurve.coeffEmb ℂ ModularCurve.jq ^ (m * M + 1) * (ModularCurve.coeffEmb
+        ℂ ModularCurve.jq - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (m * M)))
+    (A : Matrix.SpecialLinearGroup (Fin 2) ℤ) (ε : ℝ) (hε : 0 < ε) :
+    ∀ᶠ τ : UpperHalfPlane in UpperHalfPlane.atImInfty,
+      ‖((fun z : UpperHalfPlane => g z * (ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) ^ m) ∣[k + 14 *
+        (m : ℤ)] (A : GL (Fin 2) ℝ)) τ‖ ≤
+        ε * ‖((fun z : UpperHalfPlane => h z * ModularForm.discriminant z ^ m) ∣[k + 12 * (m : ℤ)]
+          (A : GL (Fin 2) ℝ)) τ‖ :=
+  solution N m g h X hX M h₂ A ε hε
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_aeval_jq_sub_holomorphicAtInfty.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_aeval_jq_sub_holomorphicAtInfty.lean
new file mode 100644
index 0000000000..efc73bc101
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_aeval_jq_sub_holomorphicAtInfty.lean
@@ -0,0 +1,159 @@
+/-
+Based on Prove2Me node ModularCurve.exists_aeval_jq_sub_holomorphicAtInfty
+(d6346d7d-ef2f-5365-bb82-a00369824747) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 67fb34af-b139-50be-a8ad-8fe2e16bae39
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Killing the pole at q=0 by a polynomial in j(q)
+
+Theorem statement: `ModularCurve.exists_aeval_jq_sub_holomorphicAtInfty`
+(`d6346d7d-ef2f-5365-bb82-a00369824747`), by Claude, 2026-09-05.
+
+Proof: submission `67fb34af-b139-50be-a8ad-8fe2e16bae39`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $n$ be a natural number. The assertion is that for every formal Laurent series $f$ over
+$\mathbb{Q}$ (an element of `LaurentSeries ℚ`, i.e. a Hahn series over $\mathbb{Q}$ with value group
+$\mathbb{Z}$) satisfying `PoleOrderLE f n`, that is, $f$ has vanishing coefficient in degree $k$ for
+every integer $k < -n$, there exists a polynomial $P \in \mathbb{Q}[X]$ with $\deg P \le n$ (in the
+form `P.natDegree ≤ n`) such that `PoleOrderLE (f - Polynomial.aeval jq P) 0` holds, i.e. the
+Laurent series obtained from $f$ by subtracting the value of $P$ at `jq` has vanishing coefficient
+in every negative degree. Here `jq` is the Laurent series $q^{-1}\cdot \iota(\,$`jNumQ`$\,)$, the
+product of the Hahn series `HahnSeries.single (-1) 1` with the image of the power series `jNumQ`
+(the coefficientwise image in $\mathbb{Q}$ of the integral power series `jNum`) under the inclusion
+of power series into Laurent series, and `Polynomial.aeval jq P` is the evaluation of $P$ at this
+element of the $\mathbb{Q}$-algebra of Laurent series. The quantifier over $f$ sits inside the
+conclusion, so the statement is a single assertion about the number $n$.
+
+This is the elementary approximation step underlying the description of the $q$-expansions of
+level-one modular forms: a $q$-series with a pole of order at most $n$ at the cusp can be corrected
+by a polynomial of degree at most $n$ in the $q$-expansion of $j$ so as to become holomorphic there.
+It is used in the proof that a suitably invariant $q$-expansion lies in the algebra generated by
+`jq`, via
+[`ModularCurve.mem_adjoin_jq_of_hasSum_of_slash_invariant`]
+(thm.html#ModularCurve.mem_adjoin_jq_of_hasSum_of_slash_invariant).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_aeval_jq_sub_holomorphicAtInfty.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_aeval_jq_sub_holomorphicAtInfty
+
+noncomputable section
+
+open Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "algebraMap_apply_eq_single jq coeff_jq_pow_self coeff_jq_pow_of_lt \
+  PoleOrderLE"
+p2m_open "ModularCurve"
+
+theorem poleOrderLE_iff_le_order {f : LaurentSeries ℚ} (hf : f ≠ 0) {n : ℕ} :
+    PoleOrderLE f n ↔ -(n : ℤ) ≤ f.order :=
+  (HahnSeries.le_order_iff_forall hf).symm
+
+theorem exists_poleOrderLE (f : LaurentSeries ℚ) : ∃ n : ℕ, PoleOrderLE f n :=
+  ⟨(-f.order).toNat, fun _ hk => HahnSeries.coeff_eq_zero_of_lt_order (by omega)⟩
+
+theorem poleOrderLE_aeval_jq (P : Polynomial ℚ) :
+    PoleOrderLE (Polynomial.aeval jq P) P.natDegree := by
+  intro k hk
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum]
+  refine Finset.sum_eq_zero fun i hi => ?_
+  have hile : i ≤ P.natDegree := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)
+  rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul,
+    coeff_jq_pow_of_lt (by omega), mul_zero]
+
+theorem coeff_aeval_jq_neg (P : Polynomial ℚ) {m : ℕ} (hm : P.natDegree ≤ m) :
+    (Polynomial.aeval jq P).coeff (-(m : ℤ)) = P.coeff m := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+    Finset.sum_eq_single m]
+  · rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul, coeff_jq_pow_self,
+      mul_one]
+  · intro i hi hin
+    have hilt : i < m :=
+      lt_of_le_of_ne (le_trans (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hm) hin
+    rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul,
+      coeff_jq_pow_of_lt (by omega), mul_zero]
+  · intro hm'
+    rw [algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul,
+      Polynomial.coeff_eq_zero_of_natDegree_lt
+        (by simp only [Finset.mem_range, not_lt] at hm'; omega),
+      zero_mul]
+
+theorem poleOrderLE_sub_aeval_jq_succ {f : LaurentSeries ℚ} {n : ℕ}
+    (hf : PoleOrderLE f (n + 1)) :
+    PoleOrderLE
+      (f - Polynomial.aeval jq
+        (Polynomial.C (f.coeff (-(n + 1 : ℕ) : ℤ)) * Polynomial.X ^ (n + 1))) n := by
+  intro k hk
+  rw [HahnSeries.coeff_sub, map_mul, Polynomial.aeval_C, Polynomial.aeval_X_pow,
+    algebraMap_apply_eq_single, HahnSeries.coeff_single_zero_mul]
+  rcases (show k ≤ -((n + 1 : ℕ) : ℤ) by omega).eq_or_lt with heq | hlt
+  · rw [heq, coeff_jq_pow_self, mul_one, sub_self]
+  · rw [hf k hlt, coeff_jq_pow_of_lt hlt, mul_zero, sub_zero]
+
+theorem exists_aeval_jq_sub_holomorphicAtInfty' (n : ℕ) :
+    ∀ f : LaurentSeries ℚ, PoleOrderLE f n →
+      ∃ P : Polynomial ℚ, P.natDegree ≤ n ∧ PoleOrderLE (f - Polynomial.aeval jq P) 0 := by
+  induction n with
+  | zero =>
+    intro f hf
+    exact ⟨0, by simp, by simpa using hf⟩
+  | succ n ih =>
+    intro f hf
+    obtain ⟨Q, hQdeg, hQ⟩ := ih _ (poleOrderLE_sub_aeval_jq_succ hf)
+    refine ⟨Polynomial.C (f.coeff (-(n + 1 : ℕ) : ℤ)) * Polynomial.X ^ (n + 1) + Q, ?_, ?_⟩
+    · refine le_trans (Polynomial.natDegree_add_le _ _)
+        (max_le (Polynomial.natDegree_C_mul_X_pow_le _ _) ?_)
+      omega
+    · intro k hk
+      rw [map_add, sub_add_eq_sub_sub]
+      exact hQ k hk
+
+end ModularCurve
+
+theorem solution (n : ℕ) :
+    ∀ f : LaurentSeries ℚ, ModularCurve.PoleOrderLE f n →
+      ∃ P : Polynomial ℚ, P.natDegree ≤ n ∧ ModularCurve.PoleOrderLE (f - Polynomial.aeval
+        ModularCurve.jq P) 0 :=
+  ModularCurve.exists_aeval_jq_sub_holomorphicAtInfty' n
+
+end
+end S_ModularCurve_exists_aeval_jq_sub_holomorphicAtInfty
+end P2MW
+export P2MW.S_ModularCurve_exists_aeval_jq_sub_holomorphicAtInfty (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.exists_aeval_jq_sub_holomorphicAtInfty (n : ℕ) :
+    ∀ f : LaurentSeries ℚ, PoleOrderLE f n → ∃ P : Polynomial ℚ, P.natDegree ≤ n ∧ PoleOrderLE (f -
+      Polynomial.aeval jq P) 0 :=
+  solution n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_algHom_laurentBaseChange_slot.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_algHom_laurentBaseChange_slot.lean
new file mode 100644
index 0000000000..64a2a3c988
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_algHom_laurentBaseChange_slot.lean
@@ -0,0 +1,251 @@
+/-
+Based on Prove2Me node ModularCurve.exists_algHom_laurentBaseChange_slot
+(a2de6957-8b55-5abe-9d8d-ab2b90d24e87) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7fced64d-979b-58ce-a91c-dc2288b3bb24
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlace
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+public import Mathlib.FieldTheory.Relrank
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_minpoly_jqN_map_eq_prod_slots
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqN_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularFunctionField_eq_full
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_adjoin_pair
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_laurentBaseChange_modularFunctionFieldFull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jqN
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_adjoin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_pos
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cusp-label embedding of the base-changed modular function field
+
+Theorem statement: `ModularCurve.exists_algHom_laurentBaseChange_slot`
+(`a2de6957-8b55-5abe-9d8d-ab2b90d24e87`), by Claude, 2026-09-05.
+
+Proof: submission `7fced64d-979b-58ce-a91c-dc2288b3bb24`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field of characteristic zero (a $\mathbb{Q}$-algebra), let $N \geq 1$, and let $\zeta
+\in K^{\times}$ be a unit whose underlying element of $K$ is a primitive $N$-th root of unity. Let
+$a, b$ be natural numbers with $a \mid N$, $a \neq 0$, $b < N/a$, and $\gcd(\gcd(a,b), N/a) = 1$.
+Write $j(q) = q^{-1}\sum_{n \geq 0} c_n q^n$ for the Laurent series `jq` over $\mathbb{Q}$ (the
+single term $q^{-1}$ times the power series `jNumQ`), let `qExpand R M` be the substitution $f(q)
+\mapsto f(q^{M})$ on Laurent series, `qTwist u` the substitution $f(q) \mapsto f(uq)$, and `coeffEmb
+K` the coefficientwise map $K((q)) \leftarrow \mathbb{Q}((q))$ induced by $\mathbb{Q} \to K$. Then
+there is a $K$-algebra homomorphism $\iota$ from the intermediate field `laurentBaseChange K
+(modularFunctionFieldFull N)` of $K((q))$ — the field generated over $K$ by the image under
+`coeffEmb K` of the $\mathbb{Q}$-subfield of $\mathbb{Q}((q))$ generated by the series $j(q^{d})$
+for the nonzero divisors $d$ of $N$ — into $K((q))$, such that $\iota$ sends the element $j(q)$ to
+$j(q^{N})$ and sends the element $j(q^{N})$ to $j(\zeta^{ab} q^{a^{2}})$, i.e. to `qExpand K (a * a)
+(qTwist (ζ ^ (b * a)) (coeffEmb K jq))`. Only these two values are asserted; no uniqueness claim is
+made.
+
+Classically this is the expansion, at the cusp labelled by the primitive pair $(a,b)$ with $a \mid
+N$, of the function field of $X_0(N)$ over $K$, realised as an embedding into a Laurent series field
+in the parameter playing the role of $q^{1/N}$; the second generator becomes the expansion of
+$j((a\tau + b)/(N/a))$. It is used in the counting of cusps and in the analysis of fibres of the
+Hecke correspondence on $X_0(N)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_algHom_laurentBaseChange_slot.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_algHom_laurentBaseChange_slot
+
+open ModularCurve AlgebraicCurve Polynomial IntermediateField
+
+namespace CD
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+theorem qExpand_coeffEmb (N : ℕ) [NeZero N] (f : LaurentSeries ℚ) :
+    qExpand K N (coeffEmb K f) = coeffEmb K (qExpand ℚ N f) := by
+  ext k
+  by_cases hk : (N : ℤ) ∣ k
+  · obtain ⟨m, rfl⟩ := hk
+    rw [qExpand_coeff_mul, coeffEmb_coeff, coeffEmb_coeff, qExpand_coeff_mul]
+  · rw [qExpand_coeff_of_not_dvd N _ hk, coeffEmb_coeff, qExpand_coeff_of_not_dvd N _ hk,
+      map_zero]
+
+theorem laurentBaseChange_full_eq_adjoin_adjoin (N : ℕ) [NeZero N] :
+    laurentBaseChange K (modularFunctionFieldFull N) =
+      (K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯).restrictScalars K := by
+  rw [laurentBaseChange_adjoin_pair K N (functionFieldGeneration N), ← coeffEmb_jq,
+    ← coeffEmb_jqN]
+  exact (adjoin_simple_adjoin_simple K (coeffEmb K jq) (coeffEmb K (jqN N))).symm
+
+theorem finrank_adjoin_adjoin (N : ℕ) [NeZero N] :
+    Module.finrank K⟮coeffEmb K jq⟯ K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯ = dedekindPsi N := by
+  have hle : K⟮coeffEmb K jq⟯ ≤ laurentBaseChange K (modularFunctionFieldFull N) :=
+    adjoin_simple_le_iff.mpr (coeffEmb_mem_laurentBaseChange K (jq_mem_full N))
+  have h := relfinrank_laurentBaseChange_modularFunctionFieldFull K N
+  rw [relfinrank_full_eq_dedekindPsi, relfinrank_eq_finrank_of_le hle] at h
+  have hext : extendScalars hle = K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯ :=
+    restrictScalars_injective K
+      ((extendScalars_restrictScalars hle).trans (laurentBaseChange_full_eq_adjoin_adjoin K N))
+  rwa [hext] at h
+
+theorem isIntegral_jqN (N : ℕ) [NeZero N] :
+    IsIntegral (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN N) := by
+  let : Module.Free ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN N⟯ := Module.Free.of_divisionRing _ _
+  have hfin : FiniteDimensional (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+        ({jqN N} : Set (LaurentSeries ℚ))) :=
+    Module.finite_of_finrank_pos (R := ℚ⟮jq⟯) (M := ℚ⟮jq⟯⟮jqN N⟯)
+      (by rw [finrank_adjoin_jqN_eq_dedekindPsi]; exact dedekindPsi_pos N (NeZero.ne N))
+  have h := IsIntegral.of_finite (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+    (AdjoinSimple.gen (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN N))
+  rwa [isIntegral_iff, AdjoinSimple.coe_gen] at h
+
+theorem natDegree_minpoly_jqN (N : ℕ) [NeZero N] :
+    (minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN N)).natDegree =
+      dedekindPsi N := by
+  rw [← adjoin.finrank (isIntegral_jqN N), finrank_adjoin_jqN_eq_dedekindPsi]
+
+noncomputable def thetaE :
+    (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) →+* K⟮coeffEmb K jq⟯ :=
+  ((coeffEmb K).comp
+      (algebraMap (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+        (LaurentSeries ℚ))).codRestrict K⟮coeffEmb K jq⟯ fun y => by
+    have h := coeffEmb_mem_laurentBaseChange K y.2
+    rwa [laurentBaseChange_adjoin, Set.image_singleton] at h
+
+theorem minpoly_coeffEmb_jqN (N : ℕ) [NeZero N] :
+    IsIntegral K⟮coeffEmb K jq⟯ (coeffEmb K (jqN N)) ∧
+    minpoly K⟮coeffEmb K jq⟯ (coeffEmb K (jqN N)) =
+      (minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN N)).map
+        (thetaE K) := by
+  have hpm : (minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN N)).Monic :=
+    minpoly.monic (isIntegral_jqN N)
+  have heval : aeval (coeffEmb K (jqN N))
+      ((minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN N)).map
+        (thetaE K)) = 0 := by
+    rw [aeval_def, eval₂_map,
+      show (algebraMap K⟮coeffEmb K jq⟯ (LaurentSeries K)).comp (thetaE K) =
+          (coeffEmb K).comp
+            (algebraMap (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+              (LaurentSeries ℚ)) from RingHom.ext fun _ => rfl,
+      ← hom_eval₂, ← aeval_def, minpoly.aeval, map_zero]
+  have hint : IsIntegral K⟮coeffEmb K jq⟯ (coeffEmb K (jqN N)) :=
+    ⟨_, hpm.map _, by rwa [← aeval_def]⟩
+  refine ⟨hint, (eq_of_monic_of_dvd_of_natDegree_le (minpoly.monic hint) (hpm.map _)
+    (minpoly.dvd _ _ heval) (le_of_eq ?_)).symm⟩
+  rw [hpm.natDegree_map, natDegree_minpoly_jqN, ← adjoin.finrank hint, finrank_adjoin_adjoin]
+
+theorem eval₂_minpoly_slot (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (a b : ℕ) (ha : a ∣ N) (hb : b < N / a) (hg : Nat.gcd (Nat.gcd a b) (N / a) = 1) [NeZero a] :
+    (minpoly K⟮coeffEmb K jq⟯ (coeffEmb K (jqN N))).eval₂
+        ((qExpand K N).comp (algebraMap K⟮coeffEmb K jq⟯ (LaurentSeries K)))
+        (qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq))) = 0 := by
+  rw [(minpoly_coeffEmb_jqN K N).2, eval₂_map,
+    show ((qExpand K N).comp (algebraMap K⟮coeffEmb K jq⟯ (LaurentSeries K))).comp (thetaE K) =
+        ((coeffEmb K).comp (qExpand ℚ N)).comp
+          (algebraMap (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+            (LaurentSeries ℚ)) from RingHom.ext fun y => by
+      change qExpand K N (coeffEmb K (y : LaurentSeries ℚ)) =
+        coeffEmb K (qExpand ℚ N (y : LaurentSeries ℚ))
+      exact qExpand_coeffEmb K N _,
+    ← eval_map,
+    minpoly_jqN_map_eq_prod_slots N ζ hζ
+      (fun d _ _ => ⟨finrank_adjoin_jqN_eq_dedekindPsi d, modularFunctionField_eq_full d⟩),
+    eval_prod]
+  refine Finset.prod_eq_zero (Nat.mem_divisors.mpr ⟨ha, NeZero.ne N⟩) ?_
+  rw [eval_prod]
+  refine Finset.prod_eq_zero (Finset.mem_filter.mpr ⟨Finset.mem_range.mpr hb, hg⟩) ?_
+  simp only [eval_sub, eval_X, eval_C, dite_eq_right (NeZero.ne a), sub_self]
+
+private theorem _root_.ModularCurve.exists_algHom_laurentBaseChange_slot' (N : ℕ) [NeZero N]
+    (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (a b : ℕ) (ha : a ∣ N) (hb : b < N / a) (hg : Nat.gcd (Nat.gcd a b) (N / a) = 1) [NeZero a] :
+    ∃ ι : laurentBaseChange K (modularFunctionFieldFull N) →ₐ[K] LaurentSeries K,
+      ι ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+          qExpand K N (coeffEmb K jq) ∧
+      ι ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩ =
+          qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)) := by
+  obtain ⟨hint, -⟩ := minpoly_coeffEmb_jqN K N
+  let L := AdjoinRoot.lift ((qExpand K N).comp (algebraMap K⟮coeffEmb K jq⟯ (LaurentSeries K)))
+    (qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)))
+    (eval₂_minpoly_slot K N ζ hζ a b ha hb hg)
+  let e := adjoinRootEquivAdjoin K⟮coeffEmb K jq⟯ hint
+  let φ : K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯ →+* LaurentSeries K :=
+    L.comp (e.symm : K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯ →+*
+      AdjoinRoot (minpoly K⟮coeffEmb K jq⟯ (coeffEmb K (jqN N))))
+  have hφalg : ∀ x : K⟮coeffEmb K jq⟯,
+      φ (algebraMap K⟮coeffEmb K jq⟯ K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯ x) =
+        qExpand K N x := fun x => by
+    change L (e.symm (algebraMap _ _ x)) = _
+    rw [AlgEquiv.commutes, AdjoinRoot.algebraMap_eq, AdjoinRoot.lift_of]
+    rfl
+  have hφgen : φ (AdjoinSimple.gen K⟮coeffEmb K jq⟯ (coeffEmb K (jqN N))) =
+      qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)) := by
+    change L (e.symm (AdjoinSimple.gen _ _)) = _
+    rw [adjoinRootEquivAdjoin_symm_apply_gen, AdjoinRoot.lift_root]
+  have hF := laurentBaseChange_full_eq_adjoin_adjoin K N
+  let ι' : (K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯).restrictScalars K →ₐ[K] LaurentSeries K :=
+    { toRingHom := φ
+      commutes' := fun c => by
+        change φ (algebraMap K⟮coeffEmb K jq⟯ K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯
+          (algebraMap K K⟮coeffEmb K jq⟯ c)) = _
+        rw [hφalg]
+        change qExpand K N (algebraMap K (LaurentSeries K) c) = algebraMap K (LaurentSeries K) c
+        rw [algebraMap_laurentSeries_eq_single, qExpand_single, mul_zero] }
+  refine ⟨ι'.comp (inclusion hF.le), ?_, ?_⟩
+  · exact hφalg ⟨coeffEmb K jq, mem_adjoin_simple_self K _⟩
+  · exact hφgen
+
+end CD
+
+open ModularCurve AlgebraicCurve in
+theorem solution (K : Type*) [Field K] [Algebra ℚ K] (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N)
+    (a b : ℕ) (ha : a ∣ N) (hb : b < N / a) (hg : Nat.gcd (Nat.gcd a b) (N / a) = 1) [NeZero a] :
+    ∃ ι : laurentBaseChange K (modularFunctionFieldFull N) →ₐ[K] LaurentSeries K,
+      ι ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+          qExpand K N (coeffEmb K jq) ∧
+      ι ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩ =
+          qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)) :=
+  ModularCurve.exists_algHom_laurentBaseChange_slot' K N ζ hζ a b ha hb hg
+
+end S_ModularCurve_exists_algHom_laurentBaseChange_slot
+end P2MW
+export P2MW.S_ModularCurve_exists_algHom_laurentBaseChange_slot (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.exists_algHom_laurentBaseChange_slot (K : Type*) [Field K] [Algebra ℚ K]
+    (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (a b : ℕ) (ha : a ∣ N) (hb : b < N / a) (hg : Nat.gcd (Nat.gcd a b) (N / a) = 1) [NeZero a] :
+    ∃ ι : laurentBaseChange K (modularFunctionFieldFull N) →ₐ[K] LaurentSeries K,
+      ι ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+          qExpand K N (coeffEmb K jq) ∧
+      ι ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩ =
+          qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)) :=
+  solution K N ζ hζ a b ha hb hg
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_algHom_of_isRoot.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_algHom_of_isRoot.lean
new file mode 100644
index 0000000000..7c458bb607
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_algHom_of_isRoot.lean
@@ -0,0 +1,324 @@
+/-
+Based on Prove2Me node ModularCurve.exists_algHom_of_isRoot
+(7a37c831-c213-5e25-982f-863e3a0bc5a2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4dc8443a-4e64-5d00-bafb-ea00df7894fe
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlace
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_laurentBaseChange_modularFunctionFieldFull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_adjoin_pair
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jqN
+import Mathlib.FieldTheory.Relrank
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+import Mathlib.FieldTheory.Minpoly.Field
+import Mathlib.Algebra.Polynomial.Div
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Prescribing a root of Φ_N by an L-algebra map
+
+Theorem statement: `ModularCurve.exists_algHom_of_isRoot` (`7a37c831-c213-5e25-982f-863e3a0bc5a2`),
+by Claude, 2026-09-05.
+
+Proof: submission `4dc8443a-4e64-5d00-bafb-ea00df7894fe`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbb{Q}$-algebra structure, let $N$ be a nonzero natural
+number, and let `data` be a `ModularPolynomialData N`, that is, a polynomial $\Phi \in
+(\mathbb{Z}[X])[Y]$ which is monic, has degree $\psi(N) = \sum_{d \mid N,\ d \text{ squarefree}}
+N/d$, and satisfies $\Phi = 0$ after substituting the Laurent series $jq = q^{-1}\cdot jNumQ \in
+\mathbb{Q}((q))$ for the inner variable $X$ and $\mathrm{qExpand}\ \mathbb{Q}\ N\ jq$ (the effect of
+$q \mapsto q^N$ on $jq$) for $Y$. Let $A$ be a field extension of $L$ and let $c, y \in A$ be such
+that $c$ is transcendental over $L$ and $y$ is a root of the one-variable polynomial over $A$
+obtained from $\Phi$ by mapping each coefficient in $\mathbb{Z}[X]$ to its value at $c$ under the
+integer-coefficient map into $A$. Then there is an $L$-algebra homomorphism $\psi$ from
+`laurentBaseChange L (modularFunctionFieldFull N)` — the subfield of $L((q))$ generated over $L$ by
+the coefficientwise images under $\mathbb{Q} \to L$ of the elements of the subfield of
+$\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by the expansions $\mathrm{qExpand}\ \mathbb{Q}\ d\
+jq$ for the nonzero divisors $d$ of $N$ — into $A$, carrying the image of $jq$ to $c$ and the image
+of $\mathrm{qExpand}\ \mathbb{Q}\ N\ jq$ to $y$.
+
+This is the existence half of the description of $A$-valued points of the formal model of $X_0(N)$:
+once the $j$-coordinate is specified by a transcendental element $c$ of $A$, every root in $A$ of
+$\Phi_N(c, Y)$ is realised as the image of $j(q^N)$ under some $L$-algebra map out of the
+base-changed level-$N$ modular function field. It is used in
+[`ModularCurve.exists_emb_equiv_rootsAt`](thm.html#ModularCurve.exists_emb_equiv_rootsAt), which
+turns this into a bijection between such embeddings and the root set.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_algHom_of_isRoot.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_algHom_of_isRoot
+
+noncomputable section
+
+open Polynomial IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand jq jqN dedekindPsi evalAtJ evalAtJ_X ModularPolynomialData \
+  modularFunctionFieldFull jqd_mem_full jqModC jqNModC \
+  relfinrank_laurentBaseChange_modularFunctionFieldFull jq_mem_full coeffEmb laurentBaseChange \
+  coeffEmb_mem_laurentBaseChange relfinrank_full_eq_dedekindPsi laurentBaseChange_adjoin_pair \
+  functionFieldGeneration coeffEmb_jq coeffEmb_jqN transcendental_jqModC"
+p2m_open "ModularCurve~jAdj"
+
+namespace B1Zero
+
+abbrev jAdj (L : Type*) [Field L] [Algebra ℚ L] : IntermediateField L (LaurentSeries L) :=
+  IntermediateField.adjoin L ({jqModC L} : Set (LaurentSeries L))
+
+abbrev jGenL (L : Type*) [Field L] [Algebra ℚ L] : jAdj L :=
+  ⟨jqModC L, IntermediateField.mem_adjoin_simple_self L (jqModC L)⟩
+
+abbrev ΦL (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N] (data : ModularPolynomialData N) :
+    Polynomial (jAdj L) :=
+  data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (jAdj L)) (jGenL L))
+
+theorem eval₂_Φ_jqModC_jqNModC (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N]
+    (data : ModularPolynomialData N) :
+    data.Φ.eval₂ (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries L)) (jqModC L))
+      (jqNModC L N) = 0 := by
+  have hθ : (coeffEmb L).comp evalAtJ =
+      Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries L)) (jqModC L) := by
+    refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+    simp only [RingHom.coe_comp, Function.comp_apply, Polynomial.coe_eval₂RingHom,
+      Polynomial.eval₂_X, evalAtJ_X]
+    exact coeffEmb_jq L
+  have h := congrArg (coeffEmb L) data.eval_eq_zero
+  rw [Polynomial.hom_eval₂, hθ, map_zero, coeffEmb_jqN] at h
+  exact h
+
+theorem monic_ΦL (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N]
+    (data : ModularPolynomialData N) : (ΦL L N data).Monic :=
+  data.monic.map _
+
+theorem aeval_jqNModC_ΦL (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N]
+    (data : ModularPolynomialData N) :
+    Polynomial.aeval (jqNModC L N) (ΦL L N data) = 0 := by
+  have hcomp : (algebraMap (jAdj L) (LaurentSeries L)).comp
+        (Polynomial.eval₂RingHom (Int.castRingHom (jAdj L)) (jGenL L)) =
+      Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries L)) (jqModC L) := by
+    refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+    simp only [RingHom.coe_comp, Function.comp_apply, Polynomial.coe_eval₂RingHom,
+      Polynomial.eval₂_X]
+    rfl
+  rw [Polynomial.aeval_def, Polynomial.eval₂_map, hcomp]
+  exact eval₂_Φ_jqModC_jqNModC L N data
+
+theorem isIntegral_jqNModC (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N]
+    (data : ModularPolynomialData N) : IsIntegral (jAdj L) (jqNModC L N) :=
+  ⟨ΦL L N data, monic_ΦL L N data, by
+    rw [← Polynomial.aeval_def]; exact aeval_jqNModC_ΦL L N data⟩
+
+theorem laurentBaseChange_eq_adjoin_pair (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    laurentBaseChange L (modularFunctionFieldFull N) =
+      IntermediateField.adjoin L {jqModC L, jqNModC L N} :=
+  laurentBaseChange_adjoin_pair L N (functionFieldGeneration N)
+
+theorem jAdj_le_laurentBaseChange (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    jAdj L ≤ laurentBaseChange L (modularFunctionFieldFull N) := by
+  rw [IntermediateField.adjoin_simple_le_iff, laurentBaseChange_eq_adjoin_pair L N]
+  exact IntermediateField.subset_adjoin L _ (Set.mem_insert _ _)
+
+theorem adjoin_jqNModC_eq_extendScalars (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    IntermediateField.adjoin (jAdj L) ({jqNModC L N} : Set (LaurentSeries L)) =
+      IntermediateField.extendScalars (jAdj_le_laurentBaseChange L N) := by
+  apply le_antisymm
+  · rw [IntermediateField.adjoin_simple_le_iff, IntermediateField.mem_extendScalars,
+      laurentBaseChange_eq_adjoin_pair L N]
+    exact IntermediateField.subset_adjoin L _ (Set.mem_insert_of_mem _ rfl)
+  · intro x hx
+    rw [IntermediateField.mem_extendScalars, laurentBaseChange_eq_adjoin_pair L N] at hx
+    have ha : jqModC L ∈
+        IntermediateField.adjoin (jAdj L) ({jqNModC L N} : Set (LaurentSeries L)) := by
+      have h := (IntermediateField.adjoin (jAdj L)
+        ({jqNModC L N} : Set (LaurentSeries L))).algebraMap_mem (jGenL L)
+      rwa [IntermediateField.algebraMap_apply] at h
+    have hb : jqNModC L N ∈
+        IntermediateField.adjoin (jAdj L) ({jqNModC L N} : Set (LaurentSeries L)) :=
+      IntermediateField.mem_adjoin_simple_self (jAdj L) (jqNModC L N)
+    have hle : IntermediateField.adjoin L ({jqModC L, jqNModC L N} : Set (LaurentSeries L)) ≤
+        (IntermediateField.adjoin (jAdj L)
+          ({jqNModC L N} : Set (LaurentSeries L))).restrictScalars L :=
+      IntermediateField.adjoin_le_iff.mpr
+        (Set.insert_subset_iff.mpr ⟨ha, Set.singleton_subset_iff.mpr hb⟩)
+    exact (IntermediateField.mem_restrictScalars L).mp (hle hx)
+
+theorem finrank_adjoin_jqNModC (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    Module.finrank (jAdj L)
+      (IntermediateField.adjoin (jAdj L) ({jqNModC L N} : Set (LaurentSeries L))) =
+      dedekindPsi N := by
+  rw [adjoin_jqNModC_eq_extendScalars L N,
+    ← IntermediateField.relfinrank_eq_finrank_of_le (jAdj_le_laurentBaseChange L N)]
+  have e1 : jAdj L = IntermediateField.adjoin L ({coeffEmb L jq} : Set (LaurentSeries L)) := by
+    rw [coeffEmb_jq]
+  rw [e1, relfinrank_laurentBaseChange_modularFunctionFieldFull L N, relfinrank_full_eq_dedekindPsi
+    N]
+
+theorem natDegree_minpoly_jqNModC (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N]
+    (data : ModularPolynomialData N) :
+    (minpoly (jAdj L) (jqNModC L N)).natDegree = dedekindPsi N := by
+  rw [← IntermediateField.adjoin.finrank (isIntegral_jqNModC L N data), finrank_adjoin_jqNModC L N]
+
+end B1Zero
+
+open B1Zero in
+private theorem minpoly_jqNModC_eq (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N]
+    (data : ModularPolynomialData N) :
+    minpoly (↥(IntermediateField.adjoin L ({jqModC L} : Set (LaurentSeries L)))) (jqNModC L N) =
+      data.Φ.map (Polynomial.eval₂RingHom
+        (Int.castRingHom (↥(IntermediateField.adjoin L ({jqModC L} : Set (LaurentSeries L)))))
+        ⟨jqModC L, IntermediateField.mem_adjoin_simple_self L (jqModC L)⟩) := by
+  change minpoly (jAdj L) (jqNModC L N) = ΦL L N data
+  symm
+  refine Polynomial.eq_of_monic_of_dvd_of_natDegree_le (minpoly.monic (isIntegral_jqNModC L N data))
+    (monic_ΦL L N data) (minpoly.dvd _ _ (aeval_jqNModC_ΦL L N data)) (le_of_eq ?_)
+  rw [natDegree_minpoly_jqNModC L N data, (data.monic).natDegree_map, data.natDegree_eq]
+
+section B1cFurniture
+
+variable (L : Type*) [Field L]
+
+abbrev jAdjField : IntermediateField L (LaurentSeries L) := L⟮jqModC L⟯
+
+abbrev jGenL : jAdjField L := AdjoinSimple.gen L (jqModC L)
+
+variable {A : Type*} [Field A] [Algebra L A]
+
+def jBaseHom {c : A} (hc : Transcendental L c) : jAdjField L →ₐ[L] A :=
+  ((L⟮c⟯.val).comp (RatFunc.algEquivOfTranscendental c hc).toAlgHom).comp
+    (RatFunc.algEquivOfTranscendental (jqModC L) (transcendental_jqModC L)).symm.toAlgHom
+
+theorem jBaseHom_jGenL {c : A} (hc : Transcendental L c) : jBaseHom L hc (jGenL L) = c := by
+  have h1 : (RatFunc.algEquivOfTranscendental (jqModC L) (transcendental_jqModC L)).symm
+      (jGenL L) = RatFunc.X :=
+    RatFunc.algEquivOfTranscendental_symm_gen (jqModC L) (transcendental_jqModC L)
+  change L⟮c⟯.val ((RatFunc.algEquivOfTranscendental c hc)
+    ((RatFunc.algEquivOfTranscendental (jqModC L) (transcendental_jqModC L)).symm (jGenL L))) = c
+  rw [h1]
+  exact RatFunc.algEquivOfTranscendental_X c hc
+
+end B1cFurniture
+
+private theorem exists_algHom_of_isRoot (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N]
+    (data : ModularPolynomialData N) {A : Type*} [Field A] [Algebra L A] (c y : A)
+    (hc : Transcendental L c)
+    (hy : (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom A) c)).IsRoot y) :
+    ∃ ψ : laurentBaseChange L (modularFunctionFieldFull N) →ₐ[L] A,
+      ψ ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩ = c ∧
+      ψ ⟨coeffEmb L (qExpand ℚ N jq),
+        coeffEmb_mem_laurentBaseChange L (jqd_mem_full N (dvd_refl N))⟩ = y := by
+  have hB10 := minpoly_jqNModC_eq L N data
+  let φ₀ : jAdjField L →ₐ[L] A := jBaseHom L hc
+  have hφ₀c : φ₀ (jGenL L) = c := jBaseHom_jGenL L hc
+  let : Algebra (jAdjField L) A := φ₀.toRingHom.toAlgebra
+  have hamap : ∀ x, algebraMap (jAdjField L) A x = φ₀ x := fun _ => rfl
+  have : IsScalarTower L (jAdjField L) A :=
+    IsScalarTower.of_algebraMap_eq' (by ext x; exact (φ₀.commutes x).symm)
+  have hΦmonic : (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (jAdjField L))
+      (jGenL L))).Monic := data.monic.map _
+  have hint : IsIntegral (jAdjField L) (jqNModC L N) := by
+    rw [← minpoly.ne_zero_iff, hB10]; exact hΦmonic.ne_zero
+  have hminmap : (minpoly (jAdjField L) (jqNModC L N)).map (algebraMap (jAdjField L) A)
+      = data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom A) c) := by
+    rw [hB10, Polynomial.map_map]
+    congr 1
+    refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+    simp only [RingHom.coe_comp, Function.comp_apply, Polynomial.coe_eval₂RingHom,
+      Polynomial.eval₂_X, hamap]
+    exact hφ₀c
+  have hyroots : y ∈ (minpoly (jAdjField L) (jqNModC L N)).aroots A := by
+    rw [Polynomial.mem_aroots', Polynomial.aeval_def, ← Polynomial.eval_map, hminmap]
+    exact ⟨(data.monic.map _).ne_zero, hy⟩
+  let ψ₁ : (jAdjField L)⟮jqNModC L N⟯ →ₐ[jAdjField L] A :=
+    (algHomAdjoinIntegralEquiv (jAdjField L) hint).symm ⟨y, hyroots⟩
+  have hψ₁gen : ψ₁ (AdjoinSimple.gen (jAdjField L) (jqNModC L N)) = y :=
+    algHomAdjoinIntegralEquiv_symm_apply_gen (jAdjField L) hint ⟨y, hyroots⟩
+  have hadj : ((jAdjField L)⟮jqNModC L N⟯).restrictScalars L
+      = laurentBaseChange L (modularFunctionFieldFull N) := by
+    rw [laurentBaseChange_adjoin_pair L N (functionFieldGeneration N),
+      show ({jqModC L, jqNModC L N} : Set (LaurentSeries L))
+        = {jqModC L} ∪ {jqNModC L N} from (Set.singleton_union).symm,
+      ← IntermediateField.adjoin_adjoin_left]
+  let ψ : laurentBaseChange L (modularFunctionFieldFull N) →ₐ[L] A :=
+    (ψ₁.restrictScalars L).comp (IntermediateField.equivOfEq hadj).symm.toAlgHom
+  refine ⟨ψ, ?_, ?_⟩
+  · have hamb : ((equivOfEq hadj).symm
+          ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩
+          : (jAdjField L)⟮jqNModC L N⟯)
+        = algebraMap (jAdjField L) ((jAdjField L)⟮jqNModC L N⟯) (jGenL L) :=
+      Subtype.ext (coeffEmb_jq L)
+    change ψ₁ ((equivOfEq hadj).symm ⟨coeffEmb L jq, _⟩) = c
+    rw [hamb, ψ₁.commutes, hamap, hφ₀c]
+  · have hamb' : ((equivOfEq hadj).symm
+          ⟨coeffEmb L (qExpand ℚ N jq),
+            coeffEmb_mem_laurentBaseChange L (jqd_mem_full N (dvd_refl N))⟩
+          : (jAdjField L)⟮jqNModC L N⟯)
+        = AdjoinSimple.gen (jAdjField L) (jqNModC L N) :=
+      Subtype.ext (coeffEmb_jqN L N)
+    change ψ₁ ((equivOfEq hadj).symm ⟨coeffEmb L (qExpand ℚ N jq), _⟩) = y
+    rw [hamb', hψ₁gen]
+
+end ModularCurve
+
+end
+
+p2m_open "ModularCurve~jAdj\
+  " in
+open _root_.P2MW.S_ModularCurve_exists_algHom_of_isRoot.ModularCurve in
+theorem solution (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N]
+    (data : ModularPolynomialData N) {A : Type*} [Field A] [Algebra L A] (c y : A)
+    (hc : Transcendental L c)
+    (hy : (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom A) c)).IsRoot y) :
+    ∃ ψ : laurentBaseChange L (modularFunctionFieldFull N) →ₐ[L] A,
+      ψ ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩ = c ∧
+      ψ ⟨coeffEmb L (qExpand ℚ N jq),
+        coeffEmb_mem_laurentBaseChange L (jqd_mem_full N (dvd_refl N))⟩ = y :=
+  ModularCurve.exists_algHom_of_isRoot L N data c y hc hy
+
+end S_ModularCurve_exists_algHom_of_isRoot
+end P2MW
+export P2MW.S_ModularCurve_exists_algHom_of_isRoot (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.exists_algHom_of_isRoot (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N]
+    (data : ModularPolynomialData N) {A : Type*} [Field A] [Algebra L A] (c y : A)
+    (hc : Transcendental L c)
+    (hy : (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom A) c)).IsRoot y) :
+    ∃ ψ : laurentBaseChange L (modularFunctionFieldFull N) →ₐ[L] A,
+      ψ ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩ = c ∧
+      ψ ⟨coeffEmb L (qExpand ℚ N jq),
+        coeffEmb_mem_laurentBaseChange L (jqd_mem_full N (dvd_refl N))⟩ = y :=
+  solution L N data c y hc hy
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_apply_eq_of_forall_ord_eq_zero_tendsto_realizeOf.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_apply_eq_of_forall_ord_eq_zero_tendsto_realizeOf.lean
new file mode 100644
index 0000000000..16da83cd71
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_apply_eq_of_forall_ord_eq_zero_tendsto_realizeOf.lean
@@ -0,0 +1,164 @@
+/-
+Based on Prove2Me node ModularCurve.exists_apply_eq_of_forall_ord_eq_zero_tendsto_realizeOf
+(f8d8616a-dfb9-5303-95c1-39d6175869af) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 781b93e0-8ab9-58b2-894d-c8ea49f426de
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ComplexPlaceDictionaryOf
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_forall_ord_eq_finset
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_eq_zero_of_not_mem_of_realizeOf_tendsto
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cusp places of ℂ·ℚ(X(Γ)) are exhausted by Pl
+
+Theorem statement: `ModularCurve.exists_apply_eq_of_forall_ord_eq_zero_tendsto_realizeOf`
+(`f8d8616a-dfb9-5303-95c1-39d6175869af`), by Claude, 2026-09-05.
+
+Proof: submission `781b93e0-8ab9-58b2-894d-c8ea49f426de`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma\le \mathrm{SL}_2(\mathbb Z)$ be a subgroup of finite index which contains the
+translation matrix `ModularGroup.T` and satisfies the predicate
+`CongruenceSubgroup.IsCongruenceSubgroup`, and let $F_0$ be an intermediate field of $\mathbb
+Q\subset\mathbb Q((q))$ equal to [`ModularCurve.qExpFunctionFieldC ℚ
+Γ`](def/ModularCurve_X1.html#L101), the subfield generated over $\mathbb Q$ by the quotients
+$p_f/p_g$ of integral $q$-expansions of pairs of modular forms of level $\Gamma$ and equal weight
+(with $p_g\ne 0$). Write $F$ for [`ModularCurve.laurentBaseChange ℂ
+F₀`](def/ModularCurve_LaurentCoeff.html#L103), the subfield of $\mathbb C((q))$ generated over
+$\mathbb C$ by the image of $F_0$ under coefficientwise extension of scalars. Let $y\in F$ have
+Laurent series [`ModularCurve.jqModC ℂ`](def/ModularCurve_JqCoeff.html#L15), that is $q^{-1}$ times
+the power series $E_4^3\cdot\eta^{-24}$-type numerator `jNum` pushed to $\mathbb C$. Let
+$\mathrm{Pl}$ assign to each $\sigma\in \mathrm{SL}_2(\mathbb Z)$ a place of $F/\mathbb C$ in the
+sense of [`AlgebraicCurve.Place`](def/AlgebraicCurve_DivisorClassGroup.html#L22) (a proper valuation
+subring of $F$ containing $\mathbb C$ whose ring is a principal ideal ring), subject to two
+hypotheses: $\mathrm{Pl}(\gamma\sigma)=\mathrm{Pl}(\sigma)$ for all $\gamma\in\Gamma$ and all
+$\sigma$; and for every $\sigma$ and every nonzero $x\in F$ with
+$\operatorname{ord}_{\mathrm{Pl}(\sigma)}x=0$ (the negated logarithm of the associated adic
+valuation) there is $L\ne 0$ such that $\tau\mapsto$
+[`ModularCurve.realizeOf`](def/ModularCurve_ComplexPlaceDictionaryOf.html#L15)
+$\Gamma\,x\,(\sigma\cdot\tau)$ tends to $L$ as $\operatorname{Im}\tau\to\infty$, where `realizeOf`
+evaluates $x$ at $\tau$ as $f(\tau)/g(\tau)$ for some choice of modular forms $f,g$ of level
+$\Gamma$ and equal weight with $g(\tau)\ne0$ and $x\cdot q\text{-exp}(g)=q\text{-exp}(f)$, and is
+$0$ if no such pair exists. Then every place $P$ of $F/\mathbb C$ with $y\notin P$ is of the form
+$\mathrm{Pl}(\sigma)$ for some $\sigma\in\mathrm{SL}_2(\mathbb Z)$.
+
+This is the completeness half of the dictionary between cusps of $X(\Gamma)$ and places of its
+function field: the places at which the $j$-expansion fails to be integral, i.e. the cusp places,
+are exactly those produced by the family $\mathrm{Pl}$ indexed by right $\Gamma$-cosets in
+$\mathrm{SL}_2(\mathbb Z)$. It is used in the divisor-theoretic analysis of $q$-expansions at cusps,
+notably in computing orders of vanishing in terms of cusp widths.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_apply_eq_of_forall_ord_eq_zero_tendsto_realizeOf.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_apply_eq_of_forall_ord_eq_zero_tendsto_realizeOf
+
+open CongruenceSubgroup ModularCurve
+open scoped MatrixGroups ModularForm
+
+theorem solution
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    (hΓ : CongruenceSubgroup.IsCongruenceSubgroup Γ)
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (hF : F₀ = ModularCurve.qExpFunctionFieldC ℚ Γ)
+    (y : ↥(ModularCurve.laurentBaseChange ℂ F₀))
+    (hy : (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ)
+    (Pl : SL(2, ℤ) → AlgebraicCurve.Place ℂ ↥(ModularCurve.laurentBaseChange ℂ F₀))
+    (hΓPl : ∀ γ ∈ Γ, ∀ σ : SL(2, ℤ), Pl (γ * σ) = Pl σ)
+    (hlim : ∀ (σ : SL(2, ℤ)) (x : ↥(ModularCurve.laurentBaseChange ℂ F₀)), x ≠ 0 → (Pl σ).ord x = 0
+      →
+      ∃ L : ℂ, L ≠ 0 ∧
+        Filter.Tendsto (fun τ : UpperHalfPlane => ModularCurve.realizeOf Γ (x : LaurentSeries ℂ) (σ
+          • τ))
+          UpperHalfPlane.atImInfty (nhds L))
+    (P : AlgebraicCurve.Place ℂ ↥(ModularCurve.laurentBaseChange ℂ F₀))
+    (hP : y ∉ P.toValuationSubring) :
+    ∃ σ : SL(2, ℤ), Pl σ = P := by
+  classical
+  by_contra hcon
+  push Not at hcon
+  let Pl' : Quotient (QuotientGroup.rightRel Γ) → AlgebraicCurve.Place ℂ
+    ↥(ModularCurve.laurentBaseChange ℂ F₀) :=
+    Quotient.lift Pl (by
+      intro a b hab
+      have hab' : b * a⁻¹ ∈ Γ := QuotientGroup.rightRel_apply.mp hab
+      have h := hΓPl (b * a⁻¹) hab' a
+      rw [inv_mul_cancel_right] at h
+      exact h.symm)
+  have : Finite (Quotient (QuotientGroup.rightRel Γ)) :=
+    Finite.of_equiv _ (QuotientGroup.quotientRightRelEquivQuotientLeftRel Γ).symm
+  have hfin : (Set.range Pl).Finite := by
+    refine (Set.finite_range Pl').subset ?_
+    rintro _ ⟨σ, rfl⟩
+    exact ⟨Quotient.mk _ σ, rfl⟩
+  obtain ⟨S₀, hS₀⟩ : ∃ S₀ : Finset (AlgebraicCurve.Place ℂ ↥(ModularCurve.laurentBaseChange ℂ F₀)),
+      ∀ σ, Pl σ ∈ S₀ := ⟨hfin.toFinset, fun σ => hfin.mem_toFinset.mpr ⟨σ, rfl⟩⟩
+  obtain ⟨g, hg0, hg⟩ := AlgebraicCurve.Place.exists_forall_ord_eq_finset (insert P S₀)
+    (fun v => if v = P then (1 : ℤ) else 0)
+  have hPg : P.ord g = 1 := by
+    have h := hg P (Finset.mem_insert_self P S₀)
+    rwa [ite_eq_left rfl] at h
+  have hσg : ∀ σ : SL(2, ℤ), (Pl σ).ord g = 0 := fun σ => by
+    have h := hg (Pl σ) (Finset.mem_insert_of_mem (hS₀ σ))
+    rwa [ite_eq_right (hcon σ)] at h
+  have hcusp : ∀ σ : SL(2, ℤ), ∃ L : ℂ, L ≠ 0 ∧
+      Filter.Tendsto (fun τ : UpperHalfPlane => ModularCurve.realizeOf Γ (g : LaurentSeries ℂ) (σ •
+        τ)) UpperHalfPlane.atImInfty (nhds L) :=
+    fun σ => hlim σ g hg0 (hσg σ)
+  have h0 : P.ord g = 0 :=
+    ModularCurve.ord_eq_zero_of_not_mem_of_realizeOf_tendsto Γ hT hΓ F₀ hF g
+      (fun τ : UpperHalfPlane => ModularCurve.realizeOf Γ (g : LaurentSeries ℂ) τ) (fun τ =>
+        Filter.EventuallyEq.rfl) hcusp P y hy hP
+  rw [h0] at hPg
+  exact zero_ne_one hPg
+
+end S_ModularCurve_exists_apply_eq_of_forall_ord_eq_zero_tendsto_realizeOf
+end P2MW
+export P2MW.S_ModularCurve_exists_apply_eq_of_forall_ord_eq_zero_tendsto_realizeOf (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open CongruenceSubgroup ModularCurve
+open scoped MatrixGroups ModularForm
+theorem ModularCurve.exists_apply_eq_of_forall_ord_eq_zero_tendsto_realizeOf
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    (hΓ : CongruenceSubgroup.IsCongruenceSubgroup Γ)
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (hF : F₀ = ModularCurve.qExpFunctionFieldC ℚ Γ)
+    (y : ↥(ModularCurve.laurentBaseChange ℂ F₀))
+    (hy : (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ)
+    (Pl : SL(2, ℤ) → AlgebraicCurve.Place ℂ ↥(ModularCurve.laurentBaseChange ℂ F₀))
+    (hΓPl : ∀ γ ∈ Γ, ∀ σ : SL(2, ℤ), Pl (γ * σ) = Pl σ)
+    (hlim : ∀ (σ : SL(2, ℤ)) (x : ↥(ModularCurve.laurentBaseChange ℂ F₀)), x ≠ 0 → (Pl σ).ord x = 0
+      →
+      ∃ L : ℂ, L ≠ 0 ∧
+        Filter.Tendsto (fun τ : UpperHalfPlane => ModularCurve.realizeOf Γ (x : LaurentSeries ℂ) (σ
+          • τ))
+          UpperHalfPlane.atImInfty (nhds L))
+    (P : AlgebraicCurve.Place ℂ ↥(ModularCurve.laurentBaseChange ℂ F₀))
+    (hP : y ∉ P.toValuationSubring) :
+    ∃ σ : SL(2, ℤ), Pl σ = P :=
+  solution Γ hT hΓ F₀ hF y hy Pl hΓPl hlim P hP
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_complexPlaceDictionaryOf.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_complexPlaceDictionaryOf.lean
new file mode 100644
index 0000000000..03695bf80b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_complexPlaceDictionaryOf.lean
@@ -0,0 +1,542 @@
+/-
+Based on Prove2Me node ModularCurve.exists_complexPlaceDictionaryOf
+(8e86d257-e07b-5c73-b441-fc1bd9416747) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission da53e2d4-1cc7-5347-91a1-ea1408e38caa
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ComplexPlaceDictionaryOf
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_of_orderMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC_of_T_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_mem_intFormRatiosC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_realizeOf_eq_div
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of a complex place dictionary for Γ
+
+Theorem statement: `ModularCurve.exists_complexPlaceDictionaryOf`
+(`8e86d257-e07b-5c73-b441-fc1bd9416747`), by Claude, 2026-09-05.
+
+Proof: submission `da53e2d4-1cc7-5347-91a1-ea1408e38caa`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of $\mathrm{SL}_2(\mathbb{Z})$ containing the translation matrix $T$, and
+let $F_0$ be an intermediate field of $\mathbb{Q} \subseteq \mathbb{Q}((q))$ (Laurent series over
+$\mathbb{Q}$) which is assumed equal to [`ModularCurve.qExpFunctionFieldC ℚ
+Γ`](def/ModularCurve_X1.html#L101), i.e. to the subfield generated over $\mathbb{Q}$ by all
+quotients $\iota(p_f)/\iota(p_g)$, where $f,g$ are modular forms of one and the same weight $k$ on
+the image of $\Gamma$ in $\mathrm{GL}_2(\mathbb{R})$, $p_f,p_g$ are integer power series standing to
+$f,g$ in the relation `IsIntegralQExp`, $\iota$ denotes passage to Laurent series over $\mathbb{Q}$
+and $\iota(p_g) \neq 0$. The assertion is that the structure [`ModularCurve.ComplexPlaceDictionaryOf
+Γ F₀`](def/ModularCurve_ComplexPlaceDictionaryOf.html#L47) is inhabited: there exist a map
+$\mathrm{pt}$ from the upper half plane $\mathfrak{H}$ to the places of $\mathbb{C}F_0$ over
+$\mathbb{C}$ — a place being a valuation subring, proper, containing the image of $\mathbb{C}$ and a
+principal ideal ring, where $\mathbb{C}F_0$ is the subfield of $\mathbb{C}((q))$ generated over
+$\mathbb{C}$ by the coefficientwise image of $F_0$ — together with a function $\tau \mapsto e_\tau
+\in \mathbb{N}$, such that: $e_\tau > 0$ for all $\tau$; $\mathrm{pt}(\gamma \cdot \tau) =
+\mathrm{pt}(\tau)$ for $\gamma \in \Gamma$; an element $x \in \mathbb{C}F_0$ lies in the valuation
+subring of $\mathrm{pt}(\tau)$ exactly when $z \mapsto \|\mathrm{realizeOf}_\Gamma(x)(z)\|$ is
+bounded along the punctured-neighbourhood filter of $\tau$; and for $x \neq 0$ the meromorphic order
+at $\tau$ of $z \mapsto \mathrm{realizeOf}_\Gamma(x)(z)$ equals $e_\tau \cdot
+\mathrm{ord}_{\mathrm{pt}(\tau)}(x)$ in $\mathbb{Z} \cup \{\infty\}$. Here
+$\mathrm{realizeOf}_\Gamma(x)(\tau)$ is $g(\tau)/h(\tau)$ for a chosen pair of weight-$k$ modular
+forms $g,h$ on $\Gamma$ with $h(\tau) \neq 0$ and $x$ times the $q$-expansion of $h$ (period $1$)
+equal to that of $g$, and $0$ if no such data exist.
+
+This is the existence half of the classical dictionary identifying the non-cuspidal points of the
+compact Riemann surface $X(\Gamma)(\mathbb{C}) = \Gamma \backslash \mathfrak{H}^{*}$ with places of
+its function field, the valuation at $\mathrm{pt}(\tau)$ being the order of vanishing at $\tau$
+divided by the ramification index $e_\tau$. It underlies the subsequent work with divisors, Hecke
+operators and the Jacobian of $X(\Gamma)$, in particular the computation of $\mathrm{Pic}^0$ of
+$X_H$ as a quotient by a period lattice and the parity statement for orders of functions in the
+$\Gamma_1$ case.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_complexPlaceDictionaryOf.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_complexPlaceDictionaryOf
+
+
+noncomputable section
+
+open UpperHalfPlane Filter
+open scoped MatrixGroups Topology Manifold
+
+namespace ModularCurve
+p2m_export "ModularCurve" "realizeOf ComplexPlaceDictionaryOf coeffEmb coeffEmb_coeff \
+  laurentBaseChange coeffEmb_mem_laurentBaseChange coeff_jq_neg_one qExpFunctionFieldC \
+  intFormRatiosC_subset jqModC jqModC_rat \
+  exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC_of_T_mem \
+  realizeOf_eq_div jqModC_mem_intFormRatiosC"
+namespace ComplexPlaceDictionaryOfExistence
+p2m_open "ModularCurve"
+
+variable {Γ : Subgroup SL(2, ℤ)}
+
+abbrev qL {k : ℤ} (f : ModularForm Γ k) : LaurentSeries ℂ :=
+  ((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+
+structure Pres (Γ : Subgroup SL(2, ℤ)) (x : LaurentSeries ℂ) where
+  k : ℤ
+  g : ModularForm Γ k
+  h : ModularForm Γ k
+  h_ne : h ≠ 0
+  eq : x * qL h = qL g
+
+theorem one_mem_strictPeriods (hT : ModularGroup.T ∈ Γ) :
+    (1 : ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  rw [Subgroup.strictPeriods_eq_zmultiples_one_of_T_mem hT]
+  exact AddSubgroup.mem_zmultiples _
+
+variable [hT : Fact (ModularGroup.T ∈ Γ)]
+
+theorem map_coe_nhdsNE (τ : ℍ) :
+    Filter.map ((↑) : ℍ → ℂ) (𝓝[≠] τ) = 𝓝[≠] (τ : ℂ) := by
+  have h := isOpenEmbedding_coe.map_nhdsWithin_preimage_eq ({(τ : ℂ)}ᶜ) τ
+  have hpre : ((↑) : ℍ → ℂ) ⁻¹' ({(τ : ℂ)}ᶜ : Set ℂ) = ({τ}ᶜ : Set ℍ) := by
+    ext w
+    simp
+  rwa [hpre] at h
+
+theorem eventually_nhdsNE_coe_iff {p : ℍ → Prop} {τ : ℍ} :
+    (∀ᶠ z in 𝓝[≠] (τ : ℂ), p (ofComplex z)) ↔ ∀ᶠ w in 𝓝[≠] τ, p w := by
+  rw [← map_coe_nhdsNE, Filter.eventually_map]
+  simp only [ofComplex_apply]
+
+scoped instance nhdsNE_neBot (τ : ℍ) : (𝓝[≠] τ).NeBot := by
+  have h : (Filter.map ((↑) : ℍ → ℂ) (𝓝[≠] τ)).NeBot := by
+    rw [map_coe_nhdsNE]; infer_instance
+  exact Filter.NeBot.of_map h
+
+theorem isBoundedUnder_nhdsNE_coe_iff {u : ℍ → ℝ} {τ : ℍ} :
+    IsBoundedUnder (· ≤ ·) (𝓝[≠] (τ : ℂ)) (fun z : ℂ => u (ofComplex z)) ↔
+      IsBoundedUnder (· ≤ ·) (𝓝[≠] τ) u := by
+  rw [← map_coe_nhdsNE, Filter.isBoundedUnder_map_iff]
+  simp only [Function.comp_def, ofComplex_apply]
+
+omit hT in
+theorem analyticAt_comp_ofComplex {k : ℤ} (f : ModularForm Γ k)
+    (τ : ℍ) : AnalyticAt ℂ (fun z : ℂ => (f : ℍ → ℂ) (ofComplex z)) (τ : ℂ) := by
+  have hf : DifferentiableOn ℂ ((f : ℍ → ℂ) ∘ ofComplex) {z : ℂ | 0 < z.im} :=
+    UpperHalfPlane.mdifferentiable_iff.mp (ModularFormClass.holo f)
+  exact hf.analyticAt (isOpen_upperHalfPlaneSet.mem_nhds τ.im_pos)
+
+omit hT in
+theorem coe_eq_zero_iff {k : ℤ} (f : ModularForm Γ k) :
+    (f : ℍ → ℂ) = 0 ↔ f = 0 := by
+  constructor
+  · intro h
+    exact DFunLike.coe_injective (h.trans (FunLike.coe_zero).symm)
+  · rintro rfl; rfl
+
+omit hT in
+theorem eventually_ne_zero {k : ℤ} (f : ModularForm Γ k)
+    (hf : f ≠ 0) (τ : ℍ) : ∀ᶠ w in 𝓝[≠] τ, (f : ℍ → ℂ) w ≠ 0 := by
+  by_contra hcon
+  have hfr : ∃ᶠ w in 𝓝[≠] τ, (f : ℍ → ℂ) w = 0 := by
+    simpa [Filter.not_eventually] using hcon
+  exact hf ((coe_eq_zero_iff f).mp (eq_zero_of_frequently (ModularFormClass.holo f) hfr))
+
+omit hT in
+theorem eventually_ne_zero_ofComplex {k : ℤ} (f : ModularForm Γ k)
+    (hf : f ≠ 0) (τ : ℍ) : ∀ᶠ z in 𝓝[≠] (τ : ℂ), (f : ℍ → ℂ) (ofComplex z) ≠ 0 :=
+  eventually_nhdsNE_coe_iff.mpr (eventually_ne_zero f hf τ)
+
+omit hT in
+theorem meromorphicOrderAt_comp_ofComplex_ne_top {k : ℤ}
+    (f : ModularForm Γ k) (hf : f ≠ 0) (τ : ℍ) :
+    meromorphicOrderAt (fun z : ℂ => (f : ℍ → ℂ) (ofComplex z)) (τ : ℂ) ≠ ⊤ :=
+  (meromorphicOrderAt_ne_top_iff_eventually_ne_zero
+    (analyticAt_comp_ofComplex f τ).meromorphicAt).mpr (eventually_ne_zero_ofComplex f hf τ)
+
+theorem qL_ne_zero {k : ℤ} (f : ModularForm Γ k) (hf : f ≠ 0) :
+    qL f ≠ 0 := by
+  intro h
+  apply hf
+  rw [← ModularForm.qExpansion_eq_zero_iff one_pos (one_mem_strictPeriods hT.out)]
+  apply (HahnSeries.ofPowerSeries_injective (Γ := ℤ) (R := ℂ))
+  simpa [qL] using h
+
+theorem realize_eventuallyEq {x : LaurentSeries ℂ} (P : Pres Γ x) (τ : ℍ) :
+    (fun z : ℂ => realizeOf Γ x (ofComplex z)) =ᶠ[𝓝[≠] (τ : ℂ)]
+      fun z : ℂ => (P.g : ℍ → ℂ) (ofComplex z) / (P.h : ℍ → ℂ) (ofComplex z) := by
+  filter_upwards [eventually_ne_zero_ofComplex P.h P.h_ne τ] with z hz
+  exact ModularCurve.realizeOf_eq_div Γ hT.out P.g P.h x P.eq (ofComplex z) hz
+
+omit hT in
+theorem meromorphicAt_div (x : LaurentSeries ℂ) (P : Pres Γ x) (τ : ℍ) :
+    MeromorphicAt (fun z : ℂ => (P.g : ℍ → ℂ) (ofComplex z) / (P.h : ℍ → ℂ) (ofComplex z))
+      (τ : ℂ) :=
+  (analyticAt_comp_ofComplex P.g τ).meromorphicAt.div (analyticAt_comp_ofComplex P.h
+    τ).meromorphicAt
+
+theorem meromorphicAt_realize {x : LaurentSeries ℂ} (P : Pres Γ x) (τ : ℍ) :
+    MeromorphicAt (fun z : ℂ => realizeOf Γ x (ofComplex z)) (τ : ℂ) :=
+  (meromorphicAt_div x P τ).congr (realize_eventuallyEq P τ).symm
+
+theorem meromorphicOrderAt_realize_eq {x : LaurentSeries ℂ} (P : Pres Γ x) (τ : ℍ) :
+    ∃ m : ℤ, 0 ≤ m ∧
+      meromorphicOrderAt (fun z : ℂ => (P.h : ℍ → ℂ) (ofComplex z)) (τ : ℂ) = m ∧
+      meromorphicOrderAt (fun z : ℂ => realizeOf Γ x (ofComplex z)) (τ : ℂ) =
+        meromorphicOrderAt (fun z : ℂ => (P.g : ℍ → ℂ) (ofComplex z)) (τ : ℂ) + ((-m : ℤ) : WithTop
+          ℤ) := by
+  have hh := meromorphicOrderAt_comp_ofComplex_ne_top P.h P.h_ne τ
+  obtain ⟨m, hm⟩ := WithTop.ne_top_iff_exists.mp hh
+  have hm0 : 0 ≤ m := by
+    have := (analyticAt_comp_ofComplex P.h τ).meromorphicOrderAt_nonneg
+    rw [← hm] at this
+    exact_mod_cast this
+  refine ⟨m, hm0, hm.symm, ?_⟩
+  rw [meromorphicOrderAt_congr (realize_eventuallyEq P τ)]
+  have hdiv : (fun z : ℂ => (P.g : ℍ → ℂ) (ofComplex z) / (P.h : ℍ → ℂ) (ofComplex z)) =
+      (fun z : ℂ => (P.g : ℍ → ℂ) (ofComplex z)) * (fun z : ℂ => (P.h : ℍ → ℂ) (ofComplex z))⁻¹ :=
+        by
+    ext z; simp [div_eq_mul_inv]
+  rw [hdiv, meromorphicOrderAt_mul (analyticAt_comp_ofComplex P.g τ).meromorphicAt
+    (analyticAt_comp_ofComplex P.h τ).meromorphicAt.inv, meromorphicOrderAt_inv, ← hm]
+  rfl
+
+theorem qL_mul {a b : ℤ} (f : ModularForm Γ a)
+    (g : ModularForm Γ b) : qL (f.mul g) = qL f * qL g := by
+  simp only [qL, ModularForm.coe_mul,
+    ModularForm.qExpansion_mul_coe one_pos (one_mem_strictPeriods hT.out), PowerSeries.coe_mul]
+
+theorem qL_add {a : ℤ} (f g : ModularForm Γ a) :
+    qL (f + g) = qL f + qL g := by
+  simp only [qL, FunLike.coe_add,
+    ModularForm.qExpansion_add one_pos (one_mem_strictPeriods hT.out), PowerSeries.coe_add]
+
+omit hT in
+theorem qL_one : qL (1 : ModularForm Γ 0) = 1 := by
+  simp only [qL, ModularForm.qExpansion_one, PowerSeries.coe_one]
+
+theorem qL_const (c : ℂ) :
+    qL (c • (1 : ModularForm Γ 0)) = algebraMap ℂ (LaurentSeries ℂ) c := by
+  rw [qL, FunLike.coe_smul,
+    ModularForm.qExpansion_smul one_pos (one_mem_strictPeriods hT.out), ModularForm.qExpansion_one,
+    Algebra.smul_def, mul_one, HahnSeries.algebraMap_apply']
+
+omit hT in
+theorem mul_ne_zero_of_ne_zero {a b : ℤ} (f : ModularForm Γ a)
+    (g : ModularForm Γ b) (hf : f ≠ 0) (hg : g ≠ 0) :
+    f.mul g ≠ 0 := by
+  intro hfg
+  obtain ⟨w, hw⟩ := ((eventually_ne_zero f hf UpperHalfPlane.I).and
+    (eventually_ne_zero g hg UpperHalfPlane.I)).exists
+  have := congrArg (fun F : ModularForm Γ (a + b) => (F : ℍ → ℂ) w) hfg
+  simp only [ModularForm.coe_mul, Pi.mul_apply, FunLike.coe_zero, Pi.zero_apply,
+    mul_eq_zero] at this
+  exact this.elim hw.1 hw.2
+
+omit hT in
+theorem one_ne_zero' : (1 : ModularForm Γ 0) ≠ 0 := by
+  intro h
+  have := congrArg (fun F : ModularForm Γ 0 => (F : ℍ → ℂ) UpperHalfPlane.I) h
+  simp [ModularForm.one_coe_eq_one] at this
+
+abbrev Pres.mul {x y : LaurentSeries ℂ} (P : Pres Γ x) (Q : Pres Γ y) : Pres Γ (x * y) where
+  k := P.k + Q.k
+  g := P.g.mul Q.g
+  h := P.h.mul Q.h
+  h_ne := mul_ne_zero_of_ne_zero P.h Q.h P.h_ne Q.h_ne
+  eq := by
+    rw [qL_mul, qL_mul, ← P.eq, ← Q.eq]; ring
+
+abbrev Pres.add {x y : LaurentSeries ℂ} (P : Pres Γ x) (Q : Pres Γ y) : Pres Γ (x + y) where
+  k := P.k + Q.k
+  g := P.g.mul Q.h + P.h.mul Q.g
+  h := P.h.mul Q.h
+  h_ne := mul_ne_zero_of_ne_zero P.h Q.h P.h_ne Q.h_ne
+  eq := by
+    rw [qL_add, qL_mul, qL_mul, qL_mul, ← P.eq, ← Q.eq]; ring
+
+theorem algebraMap_laurentSeries_eq_C (c : ℂ) :
+    algebraMap ℂ (LaurentSeries ℂ) c = HahnSeries.C c := by
+  rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_eq, HahnSeries.ofPowerSeries_C]
+
+abbrev Pres.const (Γ : Subgroup SL(2, ℤ)) [Fact (ModularGroup.T ∈ Γ)] (c : ℂ) :
+    Pres Γ (algebraMap ℂ (LaurentSeries ℂ) c) where
+  k := 0
+  g := c • (1 : ModularForm Γ 0)
+  h := 1
+  h_ne := one_ne_zero'
+  eq := by
+    rw [qL_one, mul_one, qL_const]
+
+theorem realize_mul_eventuallyEq {x y : LaurentSeries ℂ} (P : Pres Γ x) (Q : Pres Γ y) (τ : ℍ) :
+    (fun z : ℂ => realizeOf Γ (x * y) (ofComplex z)) =ᶠ[𝓝[≠] (τ : ℂ)]
+      (fun z : ℂ => realizeOf Γ x (ofComplex z)) * fun z : ℂ => realizeOf Γ y (ofComplex z) := by
+  filter_upwards [realize_eventuallyEq (P.mul Q) τ, realize_eventuallyEq P τ,
+    realize_eventuallyEq Q τ] with z h1 h2 h3
+  rw [Pi.mul_apply, h2, h3, h1]
+  rw [ModularForm.coe_mul, ModularForm.coe_mul, Pi.mul_apply, Pi.mul_apply, mul_div_mul_comm]
+
+theorem realize_add_eventuallyEq {x y : LaurentSeries ℂ} (P : Pres Γ x) (Q : Pres Γ y) (τ : ℍ) :
+    (fun z : ℂ => realizeOf Γ (x + y) (ofComplex z)) =ᶠ[𝓝[≠] (τ : ℂ)]
+      (fun z : ℂ => realizeOf Γ x (ofComplex z)) + fun z : ℂ => realizeOf Γ y (ofComplex z) := by
+  filter_upwards [realize_eventuallyEq (P.add Q) τ, realize_eventuallyEq P τ,
+    realize_eventuallyEq Q τ, eventually_ne_zero_ofComplex P.h P.h_ne τ,
+    eventually_ne_zero_ofComplex Q.h Q.h_ne τ] with z h1 h2 h3 hP hQ
+  rw [Pi.add_apply, h2, h3, h1]
+  rw [FunLike.coe_add, Pi.add_apply, ModularForm.coe_mul, ModularForm.coe_mul,
+    ModularForm.coe_mul, Pi.mul_apply, Pi.mul_apply, Pi.mul_apply, div_add_div _ _ hP hQ,
+    mul_comm ((P.h : ℍ → ℂ) (ofComplex z)) ((Q.g : ℍ → ℂ) (ofComplex z))]
+
+theorem realize_const_eventuallyEq (c : ℂ) (τ : ℍ) :
+    (fun z : ℂ => realizeOf Γ (algebraMap ℂ (LaurentSeries ℂ) c) (ofComplex z)) =ᶠ[𝓝[≠] (τ : ℂ)]
+      fun _ => c := by
+  filter_upwards [realize_eventuallyEq (Pres.const Γ c) τ] with z h1
+  rw [h1, FunLike.coe_smul, ModularForm.one_coe_eq_one]
+  simp
+
+theorem realize_smul_eventuallyEq {x : LaurentSeries ℂ} (P : Pres Γ x)
+    (γ : Γ) (τ : ℍ) :
+    (fun z : ℂ => realizeOf Γ x ((((γ : SL(2, ℤ)) : GL (Fin 2) ℝ)) • ofComplex z)) =ᶠ[𝓝[≠] (τ : ℂ)]
+      fun z : ℂ => realizeOf Γ x (ofComplex z) := by
+  filter_upwards [eventually_ne_zero_ofComplex P.h P.h_ne τ] with z hz
+  have hsm : (((γ : SL(2, ℤ)) : GL (Fin 2) ℝ)) • ofComplex z = (γ : SL(2, ℤ)) • ofComplex z := by
+    simp
+  have hh : (P.h : ℍ → ℂ) ((γ : SL(2, ℤ)) • ofComplex z) =
+      denom (γ : SL(2, ℤ)) (ofComplex z) ^ P.k * (P.h : ℍ → ℂ) (ofComplex z) :=
+    SlashInvariantForm.slash_action_eqn_SL'' P.h γ.2 _
+  have hg : (P.g : ℍ → ℂ) ((γ : SL(2, ℤ)) • ofComplex z) =
+      denom (γ : SL(2, ℤ)) (ofComplex z) ^ P.k * (P.g : ℍ → ℂ) (ofComplex z) :=
+    SlashInvariantForm.slash_action_eqn_SL'' P.g γ.2 _
+  have hd : (denom (γ : SL(2, ℤ)) (ofComplex z) : ℂ) ^ P.k ≠ 0 :=
+    zpow_ne_zero _ (denom_ne_zero _ _)
+  have hne : (P.h : ℍ → ℂ) ((γ : SL(2, ℤ)) • ofComplex z) ≠ 0 := by
+    rw [hh]; exact mul_ne_zero hd hz
+  rw [hsm, ModularCurve.realizeOf_eq_div Γ hT.out P.g P.h x P.eq _ hne,
+    ModularCurve.realizeOf_eq_div Γ hT.out P.g P.h x P.eq _ hz, hg, hh, mul_div_mul_left _ _ hd]
+
+section OrderFunction
+
+abbrev CF (Γ : Subgroup SL(2, ℤ)) : Type :=
+  ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ Γ))
+
+def pres (x : CF Γ) : Pres Γ (x : LaurentSeries ℂ) :=
+  let E := exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC_of_T_mem
+      Γ hT.out (x : LaurentSeries ℂ) x.2
+  ⟨E.choose, E.choose_spec.choose, E.choose_spec.choose_spec.choose,
+    E.choose_spec.choose_spec.choose_spec.1, E.choose_spec.choose_spec.choose_spec.2⟩
+
+def mu (τ : ℍ) (x : CF Γ) : WithTop ℤ :=
+  meromorphicOrderAt (fun z : ℂ => realizeOf Γ (x : LaurentSeries ℂ) (ofComplex z)) (τ : ℂ)
+
+theorem meromorphicAt_realize' (x : CF Γ) (τ : ℍ) :
+    MeromorphicAt (fun z : ℂ => realizeOf Γ (x : LaurentSeries ℂ) (ofComplex z)) (τ : ℂ) :=
+  meromorphicAt_realize (pres x) τ
+
+theorem mu_mul (τ : ℍ) (x y : CF Γ) : mu τ (x * y) = mu τ x + mu τ y := by
+  change meromorphicOrderAt
+      (fun z : ℂ => realizeOf Γ ((x : LaurentSeries ℂ) * (y : LaurentSeries ℂ)) (ofComplex z)) (τ :
+        ℂ) = _
+  rw [meromorphicOrderAt_congr (realize_mul_eventuallyEq (pres x) (pres y) τ),
+    meromorphicOrderAt_mul (meromorphicAt_realize' x τ) (meromorphicAt_realize' y τ)]
+  rfl
+
+theorem mu_add (τ : ℍ) (x y : CF Γ) : min (mu τ x) (mu τ y) ≤ mu τ (x + y) := by
+  change _ ≤ meromorphicOrderAt
+      (fun z : ℂ => realizeOf Γ ((x : LaurentSeries ℂ) + (y : LaurentSeries ℂ)) (ofComplex z))
+      (τ : ℂ)
+  rw [meromorphicOrderAt_congr (realize_add_eventuallyEq (pres x) (pres y) τ)]
+  exact meromorphicOrderAt_add (meromorphicAt_realize' x τ) (meromorphicAt_realize' y τ)
+
+theorem mu_algebraMap (τ : ℍ) (c : ℂ) (hc : c ≠ 0) : mu τ (algebraMap ℂ (CF Γ) c) = 0 := by
+  classical
+  change meromorphicOrderAt
+      (fun z : ℂ => realizeOf Γ (algebraMap ℂ (LaurentSeries ℂ) c) (ofComplex z)) (τ : ℂ) = 0
+  rw [meromorphicOrderAt_congr (realize_const_eventuallyEq c τ), meromorphicOrderAt_const,
+    ite_eq_right hc]
+
+theorem mu_eq_top_iff (τ : ℍ) (x : CF Γ) : mu τ x = ⊤ ↔ x = 0 := by
+  obtain ⟨m, hm0, hmh, hmu⟩ := meromorphicOrderAt_realize_eq (pres x) τ
+  constructor
+  · intro hx
+    unfold mu at hx
+    rw [hx] at hmu
+    have hg : meromorphicOrderAt (fun z : ℂ => ((pres x).g : ℍ → ℂ) (ofComplex z)) (τ : ℂ) = ⊤ := by
+      rcases WithTop.add_eq_top.mp hmu.symm with h | h
+      · exact h
+      · exact absurd h WithTop.coe_ne_top
+    have hg0 : (pres x).g = 0 := by
+      by_contra hne
+      exact meromorphicOrderAt_comp_ofComplex_ne_top _ hne τ hg
+    have heq := (pres x).eq
+    rw [hg0, show qL (0 : ModularForm Γ (pres x).k) = 0 by
+      simp [qL, UpperHalfPlane.qExpansion_zero]] at heq
+    have hx0 : (x : LaurentSeries ℂ) = 0 :=
+      (mul_eq_zero.mp heq).resolve_right (qL_ne_zero _ (pres x).h_ne)
+    exact_mod_cast hx0
+  · rintro rfl
+    have heq : (0 : LaurentSeries ℂ) * qL (pres (0 : CF Γ)).h = qL (pres (0 : CF Γ)).g :=
+      (pres (0 : CF Γ)).eq
+    rw [zero_mul] at heq
+    have hg0 : (pres (0 : CF Γ)).g = 0 := by
+      by_contra hne
+      exact qL_ne_zero _ hne heq.symm
+    unfold mu
+    rw [hmu, hg0]
+    have h0 : meromorphicOrderAt (fun z : ℂ =>
+        ((0 : ModularForm Γ (pres (0 : CF Γ)).k) : ℍ → ℂ)
+          (ofComplex z)) (τ : ℂ) = ⊤ :=
+      meromorphicOrderAt_eq_top_iff.mpr (Filter.Eventually.of_forall fun _ => by simp)
+    rw [h0, top_add]
+
+theorem mu_ne_top (τ : ℍ) {x : CF Γ} (hx : x ≠ 0) : mu τ x ≠ ⊤ :=
+  fun h => hx ((mu_eq_top_iff τ x).mp h)
+
+theorem mu_one (τ : ℍ) : mu τ (1 : CF Γ) = 0 := by
+  rw [← map_one (algebraMap ℂ (CF Γ))]
+  exact mu_algebraMap τ 1 one_ne_zero
+
+def X (Γ : Subgroup SL(2, ℤ)) : CF Γ :=
+  ⟨coeffEmb ℂ (jqModC ℚ), coeffEmb_mem_laurentBaseChange ℂ
+    (intFormRatiosC_subset ℚ Γ (ModularCurve.jqModC_mem_intFormRatiosC ℚ Γ))⟩
+
+omit hT in
+theorem X_ne_algebraMap (c : ℂ) : X Γ ≠ algebraMap ℂ (CF Γ) c := by
+  intro h
+  have h1 := congrArg (fun y : CF Γ => (y : LaurentSeries ℂ).coeff (-1)) h
+  simp only [X] at h1
+  rw [coeffEmb_coeff, jqModC_rat, coeff_jq_neg_one, map_one] at h1
+  have h2 : ((algebraMap ℂ (CF Γ) c : CF Γ) : LaurentSeries ℂ) = algebraMap ℂ (LaurentSeries ℂ) c :=
+    rfl
+  rw [h2, algebraMap_laurentSeries_eq_C, HahnSeries.C_apply, HahnSeries.coeff_single_of_ne
+    (by norm_num)] at h1
+  exact one_ne_zero h1
+
+omit hT in
+theorem X_ne_zero : X Γ ≠ 0 := by
+  simpa using X_ne_algebraMap (Γ := Γ) 0
+
+theorem exists_mu_pos (τ : ℍ) : ∃ x : CF Γ, 0 < mu τ x ∧ mu τ x ≠ ⊤ := by
+  have hXt := mu_ne_top τ (X_ne_zero (Γ := Γ))
+  by_cases hneg : mu τ (X Γ) < 0
+  · refine ⟨(X Γ)⁻¹, ?_, mu_ne_top τ (inv_ne_zero (X_ne_zero (Γ := Γ)))⟩
+    have hsum : mu τ (X Γ)⁻¹ + mu τ (X Γ) = 0 := by
+      rw [← mu_mul, inv_mul_cancel₀ (X_ne_zero (Γ := Γ)), mu_one]
+    obtain ⟨m, hm⟩ := WithTop.ne_top_iff_exists.mp hXt
+    obtain ⟨n, hn⟩ := WithTop.ne_top_iff_exists.mp (mu_ne_top τ (inv_ne_zero (X_ne_zero (Γ := Γ))))
+    rw [← hm, ← hn, ← WithTop.coe_add, ← WithTop.coe_zero, WithTop.coe_eq_coe] at hsum
+    rw [← hm, ← WithTop.coe_zero, WithTop.coe_lt_coe] at hneg
+    rw [← hn, ← WithTop.coe_zero, WithTop.coe_lt_coe]
+    omega
+  · rw [not_lt] at hneg
+    obtain ⟨c, hc⟩ :=
+      (tendsto_nhds_iff_meromorphicOrderAt_nonneg (meromorphicAt_realize' (X Γ) τ)).mpr hneg
+    refine ⟨X Γ - algebraMap ℂ (CF Γ) c, ?_, mu_ne_top τ (sub_ne_zero.mpr (X_ne_algebraMap c))⟩
+    apply (tendsto_zero_iff_meromorphicOrderAt_pos (meromorphicAt_realize' _ τ)).mp
+    have hlim : Tendsto ((fun z : ℂ => realizeOf Γ ((X Γ : CF Γ) : LaurentSeries ℂ) (ofComplex z)) +
+        fun _ => -c) (𝓝[≠] (τ : ℂ)) (𝓝 0) := by
+      have h__af := hc.add (tendsto_const_nhds (x := -c))
+      simp only [add_neg_cancel] at h__af
+      exact h__af
+    refine hlim.congr' ?_
+    have hcoe : ((X Γ - algebraMap ℂ (CF Γ) c : CF Γ) : LaurentSeries ℂ) =
+        ((X Γ : CF Γ) : LaurentSeries ℂ) + algebraMap ℂ (LaurentSeries ℂ) (-c) := by
+      rw [map_neg, ← sub_eq_add_neg]; rfl
+    rw [hcoe]
+    exact ((realize_add_eventuallyEq (pres (X Γ)) (Pres.const Γ (-c)) τ).trans
+      (EventuallyEq.rfl.add (realize_const_eventuallyEq (-c) τ))).symm
+
+theorem mu_smul (γ : Γ) (τ : ℍ) (x : CF Γ) :
+    mu ((γ : SL(2, ℤ)) • τ) x = mu τ x := by
+  unfold mu
+  have hdet1 : (((γ : SL(2, ℤ)) : GL (Fin 2) ℝ)).val.det = 1 := Matrix.SpecialLinearGroup.det_coe _
+  have hdet : 0 < (((γ : SL(2, ℤ)) : GL (Fin 2) ℝ)).val.det := by rw [hdet1]; exact one_pos
+  rw [show ((((γ : SL(2, ℤ)) • τ : ℍ)) : ℂ) = ↑((((γ : SL(2, ℤ)) : GL (Fin 2) ℝ)) • τ) by simp,
+    ← meromorphicOrderAt_comp_smul hdet]
+  exact meromorphicOrderAt_congr (realize_smul_eventuallyEq (pres x) γ τ)
+
+theorem mu_nonneg_iff (τ : ℍ) (x : CF Γ) :
+    0 ≤ mu τ x ↔
+      IsBoundedUnder (· ≤ ·) (𝓝[≠] τ) (fun z : ℍ => ‖realizeOf Γ (x : LaurentSeries ℂ) z‖) := by
+  rw [← isBoundedUnder_nhdsNE_coe_iff, mu,
+    ← tendsto_nhds_iff_meromorphicOrderAt_nonneg (meromorphicAt_realize' x τ)]
+  constructor
+  · rintro ⟨c, hc⟩
+    exact hc.norm.isBoundedUnder_le
+  · intro hb
+    by_contra hno
+    have hneg : meromorphicOrderAt
+        (fun z : ℂ => realizeOf Γ (x : LaurentSeries ℂ) (ofComplex z)) (τ : ℂ) < 0 := by
+      rw [tendsto_nhds_iff_meromorphicOrderAt_nonneg (meromorphicAt_realize' x τ), not_le] at hno
+      exact hno
+    have hcob :=
+      (tendsto_cobounded_iff_meromorphicOrderAt_neg (meromorphicAt_realize' x τ)).mpr hneg
+    rw [← tendsto_norm_atTop_iff_cobounded] at hcob
+    exact Filter.not_isBoundedUnder_of_tendsto_atTop hcob hb
+
+theorem exists_place (τ : ℍ) :
+    ∃ (P : AlgebraicCurve.Place ℂ (CF Γ)) (e : ℕ), 0 < e ∧
+      (∀ x, x ∈ P.toValuationSubring ↔ 0 ≤ mu τ x) ∧
+      ∀ x, x ≠ 0 → mu τ x = (((e : ℤ) * P.ord x : ℤ) : WithTop ℤ) :=
+  AlgebraicCurve.Place.exists_of_orderMap (mu τ) (mu_eq_top_iff τ) (mu_mul τ) (mu_add τ)
+    (fun c hc => mu_algebraMap τ c hc) (exists_mu_pos τ)
+
+end OrderFunction
+
+end ModularCurve.ComplexPlaceDictionaryOfExistence
+
+open scoped MatrixGroups in
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_exists_complexPlaceDictionaryOf.ModularCurve
+  ModularCurve.ComplexPlaceDictionaryOfExistence in
+theorem solution
+    (Γ : Subgroup SL(2, ℤ)) (hT : ModularGroup.T ∈ Γ)
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (hF : F₀ = ModularCurve.qExpFunctionFieldC ℚ Γ) :
+    Nonempty (ModularCurve.ComplexPlaceDictionaryOf Γ F₀) := by
+  subst hF
+  have : Fact (ModularGroup.T ∈ Γ) := ⟨hT⟩
+  refine ⟨{ pt := fun τ => (exists_place (Γ := Γ) τ).choose
+            ramification := fun τ => (exists_place (Γ := Γ) τ).choose_spec.choose
+            ramification_pos := fun τ => (exists_place (Γ := Γ) τ).choose_spec.choose_spec.1
+            pt_smul := ?_
+            mem_pt_iff := ?_
+            meromorphicOrderAt_realizeOf := ?_ }⟩
+  · intro γ τ
+    apply AlgebraicCurve.Place.ext
+    ext x
+    rw [((exists_place (Γ := Γ) ((γ : SL(2, ℤ)) • τ)).choose_spec.choose_spec.2.1 x),
+      ((exists_place (Γ := Γ) τ).choose_spec.choose_spec.2.1 x), mu_smul]
+  · intro τ x
+    rw [((exists_place (Γ := Γ) τ).choose_spec.choose_spec.2.1 x), mu_nonneg_iff]
+  · intro τ x hx
+    exact (exists_place (Γ := Γ) τ).choose_spec.choose_spec.2.2 x hx
+
+end
+end S_ModularCurve_exists_complexPlaceDictionaryOf
+end P2MW
+export P2MW.S_ModularCurve_exists_complexPlaceDictionaryOf (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.exists_complexPlaceDictionaryOf
+    (Γ : Subgroup SL(2, ℤ)) (hT : ModularGroup.T ∈ Γ)
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (hF : F₀ = ModularCurve.qExpFunctionFieldC ℚ Γ) :
+    Nonempty (ModularCurve.ComplexPlaceDictionaryOf Γ F₀) :=
+  solution Γ hT F₀ hF
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_cuspForm_coeffMap_diffQExpBar_eq_qExpansion_of_mem_regularDifferentialsBar.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_cuspForm_coeffMap_diffQExpBar_eq_qExpansion_of_mem_regularDifferentialsBar.lean
new file mode 100644
index 0000000000..46f85bb993
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_cuspForm_coeffMap_diffQExpBar_eq_qExpansion_of_mem_regularDifferentialsBar.lean
@@ -0,0 +1,264 @@
+/-
+Based on Prove2Me node
+ModularCurve.exists_cuspForm_coeffMap_diffQExpBar_eq_qExpansion_of_mem_regularDifferentialsBar
+(1fa447ab-933b-5209-83b9-b9eca9a63e48) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 58538eff-0347-5df8-bfc7-7e524e1fd05e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_HeckeDifferential
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_cuspForm_qExpansion_eq_mul_thetaL_of_isIntegral
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCurveOver_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_and_isIntegral_of_smul_D_mem_regularDifferentialsBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_theta_coeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Regular differentials on X₀(N)_ℚ̄ are weight-two cusp forms
+
+Theorem statement:
+`ModularCurve.exists_cuspForm_coeffMap_diffQExpBar_eq_qExpansion_of_mem_regularDifferentialsBar`
+(`1fa447ab-933b-5209-83b9-b9eca9a63e48`), by Claude, 2026-09-05.
+
+Proof: submission `58538eff-0347-5df8-bfc7-7e524e1fd05e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a nonzero natural number $N$ and a ring homomorphism $\iota_0 : \overline{\mathbb Q} \to \mathbb
+C$ out of `AlgebraicClosure ℚ`. Let $\overline F_N$ denote `modularFunctionFieldBar N`, the
+intermediate field of $\overline{\mathbb Q}((q))$ over $\overline{\mathbb Q}$ generated by the
+coefficientwise image of `modularFunctionFieldFull N` (itself the subfield of $\mathbb Q((q))$
+generated over $\mathbb Q$ by the set `divisorExpansions N`). Let $\omega$ be an element of the
+module of Kähler differentials $\Omega[\overline F_N / \overline{\mathbb Q}]$, and assume $\omega$
+lies in `regularDifferentialsBar N`, i.e. for every place $v$ of $\overline F_N$ over
+$\overline{\mathbb Q}$ there is an element $g$ of the valuation subring of $v$ with $\omega = g
+\cdot v.\mathrm{dCoord}$. The conclusion asserts the existence of a cusp form $f$ of weight $2$ for
+`CongruenceSubgroup.Gamma0 N` such that the Laurent series $\mathrm{diffQExpBar}\,N\,\omega \in
+\overline{\mathbb Q}((q))$ — the image of $\omega$ under the $\overline F_N$-linear map obtained
+from the derivation `qEulerOn` ($q\,d/dq$) by the universal property of Kähler differentials —
+becomes, after applying $\iota_0$ to each coefficient, exactly the image in $\mathbb C((q))$ of the
+power series `UpperHalfPlane.qExpansion 1 f`, the $q$-expansion of $f$ at the cusp $\infty$ with
+width $1$.
+
+This is the $\Omega \to S_2$ half of the $q$-expansion dictionary between global regular
+differentials on $X_0(N)$ over $\overline{\mathbb Q}$ and weight-two cusp forms on $\Gamma_0(N)$, in
+the direction producing a cusp form from a differential. It is used in the proof of the genus bound
+`CuspForm.genusFormula_le_finrank_gamma0_weight_two`
+and in the construction of the linear equivalence
+`ModularCurve.
+exists_linearEquiv_kaehlerH0_baseChange_intLattice_of_ratCurveModel_of_cuspSection_compat_of_neZero`
+between the differentials of a rational model and the integral lattice of cusp forms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_cuspForm_coeffMap_diffQExpBar_eq_qExpansion_of_mem_regularDifferentialsBar.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_d269e8da
+
+open ModularCurve AlgebraicCurve HahnSeries KaehlerDifferential
+
+
+noncomputable section
+
+namespace C2primeGlue
+
+variable (N : ℕ) [NeZero N]
+
+abbrev jB : modularFunctionFieldBar N :=
+  ⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+    (modularFunctionField_le_full N (jq_mem N))⟩
+
+theorem coeffMap_qEuler {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S) (s : LaurentSeries R)
+    :
+    coeffMap f (qEuler R s) = qEuler S (coeffMap f s) := by
+  ext n
+  simp [qEuler_coeff, coeffMap_coeff]
+
+theorem qEuler_eq_thetaL (s : LaurentSeries ℂ) : qEuler ℂ s = thetaL ℂ s := by
+  ext n
+  rw [qEuler_coeff, thetaL_apply, ModularCurve.theta_coeff, zsmul_eq_mul]
+
+theorem ringHom_rat_eq (ι₀ : AlgebraicClosure ℚ →+* ℂ) :
+    ι₀.comp (algebraMap ℚ (AlgebraicClosure ℚ)) = algebraMap ℚ ℂ :=
+  Subsingleton.elim _ _
+
+theorem coeffMap_coeffEmb' (ι₀ : AlgebraicClosure ℚ →+* ℂ) (z : LaurentSeries ℚ) :
+    coeffMap ι₀ (coeffEmb (AlgebraicClosure ℚ) z) = coeffEmb ℂ z := by
+  rw [coeffEmb, coeffEmb, coeffMap_coeffMap, ringHom_rat_eq]
+
+theorem coeffMap_algebraMap' (ι₀ : AlgebraicClosure ℚ →+* ℂ) (c : AlgebraicClosure ℚ) :
+    coeffMap ι₀ (algebraMap (AlgebraicClosure ℚ) (LaurentSeries (AlgebraicClosure ℚ)) c) =
+      algebraMap ℂ (LaurentSeries ℂ) (ι₀ c) := by
+  rw [algebraMap_laurentSeries_eq_single, algebraMap_laurentSeries_eq_single, coeffMap_single]
+
+omit [NeZero N] in
+theorem coeffMap_mem_laurentBaseChange_complex (ι₀ : AlgebraicClosure ℚ →+* ℂ)
+    {x : LaurentSeries (AlgebraicClosure ℚ)}
+    (hx : x ∈ laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) :
+    coeffMap ι₀ x ∈ laurentBaseChange ℂ (modularFunctionFieldFull N) := by
+  rw [mem_laurentBaseChange_iff] at hx
+  induction hx using Subfield.closure_induction with
+  | mem y hy =>
+      rcases hy with ⟨a, rfl⟩ | ⟨z, hz, rfl⟩
+      · rw [coeffMap_algebraMap']
+        exact (laurentBaseChange ℂ (modularFunctionFieldFull N)).algebraMap_mem _
+      · rw [coeffMap_coeffEmb']
+        exact coeffEmb_mem_laurentBaseChange ℂ hz
+  | one => simp
+  | add x y _ _ hx hy => simpa using add_mem hx hy
+  | neg x _ hx => simpa using neg_mem hx
+  | inv x _ hx => simpa using inv_mem hx
+  | mul x y _ _ hx hy => simpa using mul_mem hx hy
+
+noncomputable def phi (ι₀ : AlgebraicClosure ℚ →+* ℂ) :
+    modularFunctionFieldBar N →+* LaurentSeries ℂ :=
+  (coeffMap ι₀).comp (laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull
+    N)).toSubfield.subtype
+
+omit [NeZero N] in
+theorem phi_apply (ι₀ : AlgebraicClosure ℚ →+* ℂ) (x : modularFunctionFieldBar N) :
+    phi N ι₀ x = coeffMap ι₀ (x : LaurentSeries (AlgebraicClosure ℚ)) := rfl
+
+omit [NeZero N] in
+theorem phi_algebraMap (ι₀ : AlgebraicClosure ℚ →+* ℂ) (c : AlgebraicClosure ℚ) :
+    phi N ι₀ (algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) c) =
+      algebraMap ℂ (LaurentSeries ℂ) (ι₀ c) := by
+  rw [phi_apply]
+  exact coeffMap_algebraMap' ι₀ c
+
+theorem phi_jB (ι₀ : AlgebraicClosure ℚ →+* ℂ) : phi N ι₀ (jB N) = coeffEmb ℂ jq := by
+  rw [phi_apply]
+  exact coeffMap_coeffEmb' ι₀ jq
+
+omit [NeZero N] in
+theorem isIntegral_phi (ι₀ : AlgebraicClosure ℚ →+* ℂ) (a : modularFunctionFieldBar N)
+    {y : modularFunctionFieldBar N}
+    (hy : IsIntegral (Algebra.adjoin (AlgebraicClosure ℚ) ({a} : Set (modularFunctionFieldBar N)))
+      y) :
+    IsIntegral (Algebra.adjoin ℂ ({phi N ι₀ a} : Set (LaurentSeries ℂ))) (phi N ι₀ y) := by
+  have hmem : ∀ r : modularFunctionFieldBar N,
+      r ∈ Algebra.adjoin (AlgebraicClosure ℚ) ({a} : Set (modularFunctionFieldBar N)) →
+      phi N ι₀ r ∈ Algebra.adjoin ℂ ({phi N ι₀ a} : Set (LaurentSeries ℂ)) := by
+    intro r hr
+    induction hr using Algebra.adjoin_induction with
+    | mem r hr =>
+        rw [Set.mem_singleton_iff] at hr
+        subst hr
+        exact Algebra.subset_adjoin (Set.mem_singleton _)
+    | algebraMap c =>
+        rw [phi_algebraMap]
+        exact Subalgebra.algebraMap_mem _ _
+    | add r s _ _ hr hs => rw [map_add]; exact add_mem hr hs
+    | mul r s _ _ hr hs => rw [map_mul]; exact mul_mem hr hs
+  let ψ : Algebra.adjoin (AlgebraicClosure ℚ) ({a} : Set (modularFunctionFieldBar N)) →+*
+      Algebra.adjoin ℂ ({phi N ι₀ a} : Set (LaurentSeries ℂ)) :=
+    ((phi N ι₀).comp (Algebra.adjoin (AlgebraicClosure ℚ) ({a} : Set (modularFunctionFieldBar
+      N))).val.toRingHom).codRestrict
+      (Algebra.adjoin ℂ ({phi N ι₀ a} : Set (LaurentSeries ℂ))) (fun r => hmem r r.2)
+  refine IsIntegral.map_of_comp_eq ψ (phi N ι₀) ?_ hy
+  ext r
+  rfl
+
+theorem D_jB_ne_zero : D (AlgebraicClosure ℚ) (modularFunctionFieldBar N) (jB N) ≠ 0 := by
+  intro h
+  have h1 : diffQExp (modularFunctionFieldBar N) (D (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+    (jB N)) =
+      qEuler (AlgebraicClosure ℚ) ((jB N : modularFunctionFieldBar N) : LaurentSeries
+        (AlgebraicClosure ℚ)) :=
+    diffQExp_D _ _
+  rw [h, map_zero] at h1
+  have h2 := congrArg (fun s : LaurentSeries (AlgebraicClosure ℚ) => s.coeff (-1)) h1
+  simp only at h2
+  rw [qEuler_coeff] at h2
+  have h3 : ((jB N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ)).coeff (-1) = 1
+    :=
+    by
+    change (coeffEmb (AlgebraicClosure ℚ) jq).coeff (-1) = 1
+    rw [coeffEmb_coeff, coeff_jq_neg_one, map_one]
+  rw [h3, HahnSeries.coeff_zero] at h2
+  norm_num at h2
+
+end C2primeGlue
+
+open C2primeGlue in
+theorem solution (N : ℕ) [NeZero N] (ι₀ : AlgebraicClosure ℚ →+* ℂ)
+    (ω : Ω[modularFunctionFieldBar N⁄AlgebraicClosure ℚ])
+    (hω : ω ∈ ModularCurve.regularDifferentialsBar N) :
+    ∃ f : CuspForm (CongruenceSubgroup.Gamma0 N) 2,
+      ModularCurve.coeffMap ι₀ (ModularCurve.diffQExpBar N ω) =
+        HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 f) := by
+  classical
+  have hCO := ModularCurve.isCurveOver_modularFunctionFieldBar N
+  have hrank : Module.finrank (modularFunctionFieldBar N)
+      Ω[modularFunctionFieldBar N⁄AlgebraicClosure ℚ] = 1 := IsCurveOver.finrank_kaehler
+  obtain ⟨x, hx⟩ := (finrank_eq_one_iff_of_nonzero'
+    (D (AlgebraicClosure ℚ) (modularFunctionFieldBar N) (jB N)) (D_jB_ne_zero N)).mp hrank ω
+  have hxreg : x • D (AlgebraicClosure ℚ) (modularFunctionFieldBar N) (jB N) ∈
+    regularDifferentialsBar N :=
+    by
+    rw [hx]; exact hω
+  obtain ⟨h₁, h₂⟩ :=
+    ModularCurve.isIntegral_and_isIntegral_of_smul_D_mem_regularDifferentialsBar N x hxreg
+  have hXmem : phi N ι₀ x ∈ laurentBaseChange ℂ (modularFunctionFieldFull N) :=
+    coeffMap_mem_laurentBaseChange_complex N ι₀ x.2
+  have hJ : phi N ι₀ (jB N) = coeffEmb ℂ jq := phi_jB N ι₀
+  have h1728 : phi N ι₀ (algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) 1728) =
+      algebraMap ℂ (LaurentSeries ℂ) 1728 := by
+    rw [phi_algebraMap, map_ofNat]
+  have h₁' := isIntegral_phi N ι₀ (jB N) h₁
+  have h₂' := isIntegral_phi N ι₀ ((jB N)⁻¹) h₂
+  rw [map_inv₀, hJ] at h₂'
+  rw [hJ] at h₁'
+  simp only [map_mul, map_pow, map_sub, hJ, h1728] at h₁' h₂'
+  obtain ⟨f, hf⟩ :=
+    ModularCurve.exists_cuspForm_qExpansion_eq_mul_thetaL_of_isIntegral N (phi N ι₀ x) hXmem
+    (dedekindPsi N) h₁' h₂'
+  refine ⟨f, ?_⟩
+  have hΘ : ModularCurve.diffQExpBar N ω =
+      ((x : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ)) *
+        qEuler (AlgebraicClosure ℚ) ((jB N : modularFunctionFieldBar N) : LaurentSeries
+          (AlgebraicClosure ℚ)) := by
+    rw [← hx]
+    exact diffQExp_smul_D _ _ _
+  rw [hf, hΘ, map_mul, coeffMap_qEuler, qEuler_eq_thetaL, ← phi_apply, ← phi_apply, hJ]
+
+end
+
+end S_OVERLONG_d269e8da
+end P2MW
+export
+  P2MW.S_OVERLONG_d269e8da
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem
+  ModularCurve.exists_cuspForm_coeffMap_diffQExpBar_eq_qExpansion_of_mem_regularDifferentialsBar
+    (N : ℕ) [NeZero N] (ι₀ : AlgebraicClosure ℚ →+* ℂ)
+    (ω : Ω[modularFunctionFieldBar N⁄AlgebraicClosure ℚ])
+    (hω : ω ∈ ModularCurve.regularDifferentialsBar N) :
+    ∃ f : CuspForm (CongruenceSubgroup.Gamma0 N) 2,
+      ModularCurve.coeffMap ι₀ (ModularCurve.diffQExpBar N ω) =
+        HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 f) :=
+  solution N ι₀ ω hω
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_cuspForm_qExpansion_eq_coeffMap_mul_thetaL_pow_of_isIntegral.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_cuspForm_qExpansion_eq_coeffMap_mul_thetaL_pow_of_isIntegral.lean
new file mode 100644
index 0000000000..cc37dcf384
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_cuspForm_qExpansion_eq_coeffMap_mul_thetaL_pow_of_isIntegral.lean
@@ -0,0 +1,233 @@
+/-
+Based on Prove2Me node
+ModularCurve.exists_cuspForm_qExpansion_eq_coeffMap_mul_thetaL_pow_of_isIntegral
+(f988ed30-c954-549b-ba26-aba2e1c343ed) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission aaea5d3d-15d7-53ac-a57f-7b8bdc8050c5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_MazurStepThreeInputs
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QExpansionDiff
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_cuspForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cusp forms from ℚ̄-rational modular functions via ι₀(x)(vartheta j)^m
+
+Theorem statement:
+`ModularCurve.exists_cuspForm_qExpansion_eq_coeffMap_mul_thetaL_pow_of_isIntegral`
+(`f988ed30-c954-549b-ba26-aba2e1c343ed`), by Claude, 2026-09-05.
+
+Proof: submission `aaea5d3d-15d7-53ac-a57f-7b8bdc8050c5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N \ge 1$ and let $m \ge 1$ be a natural number. Write $F_N \subseteq \mathbb{Q}((q))$ for
+`modularFunctionFieldFull N`, the subfield of the Laurent series field over $\mathbb{Q}$ generated
+over $\mathbb{Q}$ by the family `divisorExpansions N`, and write $\bar F_N =$
+`modularFunctionFieldBar N` for the subfield of $\overline{\mathbb{Q}}((q))$ generated over
+$\overline{\mathbb{Q}}$ by the coefficientwise image of $F_N$ under $\mathbb{Q} \hookrightarrow
+\overline{\mathbb{Q}}$; inside it, $\bar\jmath =$ `jBar N` is the coefficientwise image of the
+Laurent series $jq = q^{-1}\cdot \mathrm{jNumQ}$. Let $\iota_0 : \overline{\mathbb{Q}} \to
+\mathbb{C}$ be a ring homomorphism and let $x \in \bar F_N$. Assume two integrality hypotheses:
+first, that $x^6\,\bar\jmath^{\,4m}(\bar\jmath - 1728)^{3m}$ is integral over the
+$\overline{\mathbb{Q}}$-subalgebra of $\bar F_N$ generated by $\bar\jmath$; second, with $\psi =$
+`dedekindPsi N` $= \sum_{d \mid N,\ d \text{ squarefree}} N/d$, that
+$x^{2\psi}\,\bar\jmath^{\,m\psi+1}(\bar\jmath-1728)^{m\psi}$ is integral over the
+$\overline{\mathbb{Q}}$-subalgebra generated by $\bar\jmath^{-1}$. Then there exists a cusp form $f$
+for $\Gamma_0(N)$ of weight $2m$ (as an integer) whose $q$-expansion at width $1$, viewed as a
+Laurent series over $\mathbb{C}$, equals the product of the coefficientwise image $\iota_0(x)$ of
+$x$ in $\mathbb{C}((q))$ with the $m$-th power of $\vartheta(j) = q\,\frac{d}{dq}\,j(q)$, where
+$j(q)$ is the coefficientwise image of $jq$ in $\mathbb{C}((q))$.
+
+This is the function-field-to-analytic passage in weight $2m$: the two integrality conditions are
+exactly the shape produced by the divisor-theoretic estimates for elements of a Riemann–Roch space
+on $X_0(N)$ over $\overline{\mathbb{Q}}$, and the conclusion converts such an element into an honest
+cusp form of weight $2m$ for $\Gamma_0(N)$. It is used in the proof of the dimension bound
+[`CuspForm.dimFormula_le_finrank_gamma0`](thm.html#CuspForm.dimFormula_le_finrank_gamma0).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_cuspForm_qExpansion_eq_coeffMap_mul_thetaL_pow_of_isIntegral.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_cuspForm_qExpansion_eq_coeffMap_mul_thetaL_pow_of_isIntegral
+
+open ModularCurve HahnSeries
+
+
+noncomputable section
+
+namespace LMapGlue
+
+variable (N : ℕ) [NeZero N]
+
+theorem ringHom_rat_eq (ι₀ : AlgebraicClosure ℚ →+* ℂ) :
+    ι₀.comp (algebraMap ℚ (AlgebraicClosure ℚ)) = algebraMap ℚ ℂ :=
+  Subsingleton.elim _ _
+
+theorem coeffMap_coeffEmb' (ι₀ : AlgebraicClosure ℚ →+* ℂ) (z : LaurentSeries ℚ) :
+    coeffMap ι₀ (coeffEmb (AlgebraicClosure ℚ) z) = coeffEmb ℂ z := by
+  rw [coeffEmb, coeffEmb, coeffMap_coeffMap, ringHom_rat_eq]
+
+theorem coeffMap_algebraMap' (ι₀ : AlgebraicClosure ℚ →+* ℂ) (c : AlgebraicClosure ℚ) :
+    coeffMap ι₀ (algebraMap (AlgebraicClosure ℚ) (LaurentSeries (AlgebraicClosure ℚ)) c) =
+      algebraMap ℂ (LaurentSeries ℂ) (ι₀ c) := by
+  rw [algebraMap_laurentSeries_eq_single, algebraMap_laurentSeries_eq_single, coeffMap_single]
+
+omit [NeZero N] in
+theorem coeffMap_mem_laurentBaseChange_complex (ι₀ : AlgebraicClosure ℚ →+* ℂ)
+    {x : LaurentSeries (AlgebraicClosure ℚ)}
+    (hx : x ∈ laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) :
+    coeffMap ι₀ x ∈ laurentBaseChange ℂ (modularFunctionFieldFull N) := by
+  rw [mem_laurentBaseChange_iff] at hx
+  induction hx using Subfield.closure_induction with
+  | mem y hy =>
+      rcases hy with ⟨a, rfl⟩ | ⟨z, hz, rfl⟩
+      · rw [coeffMap_algebraMap']
+        exact (laurentBaseChange ℂ (modularFunctionFieldFull N)).algebraMap_mem _
+      · rw [coeffMap_coeffEmb']
+        exact coeffEmb_mem_laurentBaseChange ℂ hz
+  | one => simp
+  | add x y _ _ hx hy => simpa using add_mem hx hy
+  | neg x _ hx => simpa using neg_mem hx
+  | inv x _ hx => simpa using inv_mem hx
+  | mul x y _ _ hx hy => simpa using mul_mem hx hy
+
+noncomputable def phi (ι₀ : AlgebraicClosure ℚ →+* ℂ) :
+    modularFunctionFieldBar N →+* LaurentSeries ℂ :=
+  (coeffMap ι₀).comp (laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull
+    N)).toSubfield.subtype
+
+omit [NeZero N] in
+theorem phi_apply (ι₀ : AlgebraicClosure ℚ →+* ℂ) (x : modularFunctionFieldBar N) :
+    phi N ι₀ x = coeffMap ι₀ (x : LaurentSeries (AlgebraicClosure ℚ)) := rfl
+
+omit [NeZero N] in
+theorem phi_algebraMap (ι₀ : AlgebraicClosure ℚ →+* ℂ) (c : AlgebraicClosure ℚ) :
+    phi N ι₀ (algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) c) =
+      algebraMap ℂ (LaurentSeries ℂ) (ι₀ c) := by
+  rw [phi_apply]
+  exact coeffMap_algebraMap' ι₀ c
+
+theorem phi_jBar (ι₀ : AlgebraicClosure ℚ →+* ℂ) : phi N ι₀ (jBar N) = coeffEmb ℂ jq := by
+  rw [phi_apply]
+  exact coeffMap_coeffEmb' ι₀ jq
+
+omit [NeZero N] in
+theorem isIntegral_phi (ι₀ : AlgebraicClosure ℚ →+* ℂ) (a : modularFunctionFieldBar N)
+    {y : modularFunctionFieldBar N}
+    (hy : IsIntegral (Algebra.adjoin (AlgebraicClosure ℚ) ({a} : Set (modularFunctionFieldBar N)))
+      y) :
+    IsIntegral (Algebra.adjoin ℂ ({phi N ι₀ a} : Set (LaurentSeries ℂ))) (phi N ι₀ y) := by
+  have hmem : ∀ r : modularFunctionFieldBar N,
+      r ∈ Algebra.adjoin (AlgebraicClosure ℚ) ({a} : Set (modularFunctionFieldBar N)) →
+      phi N ι₀ r ∈ Algebra.adjoin ℂ ({phi N ι₀ a} : Set (LaurentSeries ℂ)) := by
+    intro r hr
+    induction hr using Algebra.adjoin_induction with
+    | mem r hr =>
+        rw [Set.mem_singleton_iff] at hr
+        subst hr
+        exact Algebra.subset_adjoin (Set.mem_singleton _)
+    | algebraMap c =>
+        rw [phi_algebraMap]
+        exact Subalgebra.algebraMap_mem _ _
+    | add r s _ _ hr hs => rw [map_add]; exact add_mem hr hs
+    | mul r s _ _ hr hs => rw [map_mul]; exact mul_mem hr hs
+  let ψ : Algebra.adjoin (AlgebraicClosure ℚ) ({a} : Set (modularFunctionFieldBar N)) →+*
+      Algebra.adjoin ℂ ({phi N ι₀ a} : Set (LaurentSeries ℂ)) :=
+    ((phi N ι₀).comp (Algebra.adjoin (AlgebraicClosure ℚ) ({a} : Set (modularFunctionFieldBar
+      N))).val.toRingHom).codRestrict
+      (Algebra.adjoin ℂ ({phi N ι₀ a} : Set (LaurentSeries ℂ))) (fun r => hmem r r.2)
+  refine IsIntegral.map_of_comp_eq ψ (phi N ι₀) ?_ hy
+  ext r
+  rfl
+
+end LMapGlue
+
+end
+
+open LMapGlue in
+theorem solution (N : ℕ) [NeZero N] (m : ℕ) (hm : 1 ≤ m)
+    (ι₀ : AlgebraicClosure ℚ →+* ℂ) (x : ↥(ModularCurve.modularFunctionFieldBar N))
+    (h₁ : IsIntegral (Algebra.adjoin (AlgebraicClosure ℚ) ({ModularCurve.jBar N} : Set
+      ↥(ModularCurve.modularFunctionFieldBar N)))
+      (x ^ 6 * ModularCurve.jBar N ^ (4 * m) *
+        (ModularCurve.jBar N - algebraMap (AlgebraicClosure ℚ)
+          ↥(ModularCurve.modularFunctionFieldBar N) 1728) ^ (3 * m)))
+    (h₂ : IsIntegral (Algebra.adjoin (AlgebraicClosure ℚ) ({(ModularCurve.jBar N)⁻¹} : Set
+      ↥(ModularCurve.modularFunctionFieldBar N)))
+      (x ^ (2 * ModularCurve.dedekindPsi N) * ModularCurve.jBar N ^ (m * ModularCurve.dedekindPsi N
+        + 1) *
+        (ModularCurve.jBar N - algebraMap (AlgebraicClosure ℚ)
+          ↥(ModularCurve.modularFunctionFieldBar N) 1728) ^ (m * ModularCurve.dedekindPsi N))) :
+    ∃ f : CuspForm (CongruenceSubgroup.Gamma0 N) (2 * (m : ℤ)),
+      HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 f) =
+        ModularCurve.coeffMap ι₀ ((x : ↥(ModularCurve.modularFunctionFieldBar N)) : LaurentSeries
+          (AlgebraicClosure ℚ)) *
+          ModularCurve.thetaL ℂ (ModularCurve.coeffEmb ℂ ModularCurve.jq) ^ m := by
+  classical
+  have hXmem : phi N ι₀ x ∈ laurentBaseChange ℂ (modularFunctionFieldFull N) :=
+    coeffMap_mem_laurentBaseChange_complex N ι₀ x.2
+  have hJ : phi N ι₀ (jBar N) = coeffEmb ℂ jq := phi_jBar N ι₀
+  have h1728 : phi N ι₀ (algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) 1728) =
+      algebraMap ℂ (LaurentSeries ℂ) 1728 := by
+    rw [phi_algebraMap, map_ofNat]
+  have h₁' := isIntegral_phi N ι₀ (jBar N) h₁
+  have h₂' := isIntegral_phi N ι₀ ((jBar N)⁻¹) h₂
+  rw [map_inv₀, hJ] at h₂'
+  rw [hJ] at h₁'
+  simp only [map_mul, map_pow, map_sub, hJ, h1728] at h₁' h₂'
+  obtain ⟨f, hf⟩ :=
+    ModularCurve.exists_cuspForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral N m hm (phi N ι₀ x)
+      hXmem
+    (dedekindPsi N) h₁' h₂'
+  exact ⟨f, by rw [hf, phi_apply]⟩
+
+end S_ModularCurve_exists_cuspForm_qExpansion_eq_coeffMap_mul_thetaL_pow_of_isIntegral
+end P2MW
+export P2MW.S_ModularCurve_exists_cuspForm_qExpansion_eq_coeffMap_mul_thetaL_pow_of_isIntegral
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.exists_cuspForm_qExpansion_eq_coeffMap_mul_thetaL_pow_of_isIntegral (N : ℕ)
+    [NeZero N] (m : ℕ) (hm : 1 ≤ m)
+    (ι₀ : AlgebraicClosure ℚ →+* ℂ) (x : ↥(ModularCurve.modularFunctionFieldBar N))
+    (h₁ : IsIntegral (Algebra.adjoin (AlgebraicClosure ℚ) ({ModularCurve.jBar N} : Set
+      ↥(ModularCurve.modularFunctionFieldBar N)))
+      (x ^ 6 * ModularCurve.jBar N ^ (4 * m) *
+        (ModularCurve.jBar N - algebraMap (AlgebraicClosure ℚ)
+          ↥(ModularCurve.modularFunctionFieldBar N) 1728) ^ (3 * m)))
+    (h₂ : IsIntegral (Algebra.adjoin (AlgebraicClosure ℚ) ({(ModularCurve.jBar N)⁻¹} : Set
+      ↥(ModularCurve.modularFunctionFieldBar N)))
+      (x ^ (2 * ModularCurve.dedekindPsi N) * ModularCurve.jBar N ^ (m * ModularCurve.dedekindPsi N
+        + 1) *
+        (ModularCurve.jBar N - algebraMap (AlgebraicClosure ℚ)
+          ↥(ModularCurve.modularFunctionFieldBar N) 1728) ^ (m * ModularCurve.dedekindPsi N))) :
+    ∃ f : CuspForm (CongruenceSubgroup.Gamma0 N) (2 * (m : ℤ)),
+      HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 f) =
+        ModularCurve.coeffMap ι₀ ((x : ↥(ModularCurve.modularFunctionFieldBar N)) : LaurentSeries
+          (AlgebraicClosure ℚ)) *
+          ModularCurve.thetaL ℂ (ModularCurve.coeffEmb ℂ ModularCurve.jq) ^ m :=
+  solution N m hm ι₀ x h₁ h₂
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_cuspForm_qExpansion_eq_mul_thetaL_of_isIntegral.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_cuspForm_qExpansion_eq_mul_thetaL_of_isIntegral.lean
new file mode 100644
index 0000000000..d987ad7378
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_cuspForm_qExpansion_eq_mul_thetaL_of_isIntegral.lean
@@ -0,0 +1,267 @@
+/-
+Based on Prove2Me node ModularCurve.exists_cuspForm_qExpansion_eq_mul_thetaL_of_isIntegral
+(51fe59e7-e662-5bf4-ab8e-93e14458f18f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f224858c-cd3c-5edb-b878-ea5eca81ae56
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QExpansionDiff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_thetaL_coeffMap_eq_coeffMap_single_mul_derivative
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_cuspForm_mul_eq_of_analyticOrderAt_le
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_gamma0_qExpansion_eq_of_levelOne
+import LeanPool.FLTEichlerShimura.Theorems.Thm_omegaRow_T2
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality criterion making X θ j a weight-two cusp form
+
+Theorem statement: `ModularCurve.exists_cuspForm_qExpansion_eq_mul_thetaL_of_isIntegral`
+(`51fe59e7-e662-5bf4-ab8e-93e14458f18f`), by Claude, 2026-09-05.
+
+Proof: submission `f224858c-cd3c-5edb-b878-ea5eca81ae56`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and let $J :=$ `coeffEmb ℂ jq` denote the image in $\mathbb
+C((q))$, under the coefficientwise ring map induced by $\mathbb Q \to \mathbb C$, of the Laurent
+series `jq` $= q^{-1}\cdot$ (the rational power series `jNumQ`), i.e. the $q$-expansion of the
+modular invariant $j$. Let $X \in \mathbb C((q))$ be an element of `laurentBaseChange ℂ
+(modularFunctionFieldFull N)`, the intermediate field of $\mathbb C((q))$ obtained by adjoining to
+$\mathbb C$ the coefficientwise images of the subfield of $\mathbb Q((q))$ generated over $\mathbb
+Q$ by the series $q$-rescalings `qExpand ℚ d jq` for the nonzero divisors $d$ of $N$. Let $M$ be a
+natural number, and assume two integrality hypotheses: first, $X^{6} J^{4}(J - 1728)^{3}$ is
+integral over the $\mathbb C$-subalgebra of $\mathbb C((q))$ generated by $J$; second, $X^{2M}
+J^{M+1}(J-1728)^{M}$ is integral over the $\mathbb C$-subalgebra generated by $J^{-1}$. Then there
+exists a cusp form $f$ of weight $2$ for $\Gamma_0(N)$ whose $q$-expansion of period $1$, viewed as
+an element of $\mathbb C((q))$, equals $X \cdot \theta J$, where $\theta$ is the $\mathbb C$-linear
+operator `thetaL` sending a Laurent series to $q$ times its formal derivative.
+
+This is the analytic core of the implication that a regular differential on $X_0(N)$ gives a
+weight-two cusp form, stated purely in terms of $q$-expansions: the two integrality conditions
+encode regularity at the finite points and at the cusps, with no place, valuation or differential
+appearing. It is used in the passage from elements of the space of regular differentials, presented
+by their $q$-expansions, to cusp forms in $S_2(\Gamma_0(N))$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_cuspForm_qExpansion_eq_mul_thetaL_of_isIntegral.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_cuspForm_qExpansion_eq_mul_thetaL_of_isIntegral
+
+open ModularCurve UpperHalfPlane HahnSeries
+open scoped MatrixGroups ModularForm
+
+namespace ANGlue
+
+theorem one_mem_strictPeriods_gamma0 (N : ℕ) :
+    (1 : ℝ) ∈ (Subgroup.map (Matrix.SpecialLinearGroup.mapGL ℝ) (CongruenceSubgroup.Gamma0
+      N)).strictPeriods := by
+  rw [CongruenceSubgroup.strictPeriods_Gamma0]
+  exact AddSubgroup.mem_zmultiples 1
+
+theorem thetaL_coeffEmb_jq :
+    thetaL ℂ (coeffEmb ℂ jq) = coeffMap (algebraMap ℚ ℂ) (thetaL ℚ jq) := by
+  rw [coeffEmb, ModularCurve.thetaL_coeffMap_eq_coeffMap_single_mul_derivative]
+  rfl
+
+end ANGlue
+
+open ANGlue in
+theorem solution (N : ℕ) [NeZero N]
+    (X : LaurentSeries ℂ)
+    (hX : X ∈ ModularCurve.laurentBaseChange ℂ (ModularCurve.modularFunctionFieldFull N)) (M : ℕ)
+    (h₁ : IsIntegral (Algebra.adjoin ℂ ({ModularCurve.coeffEmb ℂ ModularCurve.jq} : Set
+      (LaurentSeries ℂ)))
+      (X ^ 6 * ModularCurve.coeffEmb ℂ ModularCurve.jq ^ 4 *
+        (ModularCurve.coeffEmb ℂ ModularCurve.jq - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ 3))
+    (h₂ : IsIntegral (Algebra.adjoin ℂ ({(ModularCurve.coeffEmb ℂ ModularCurve.jq)⁻¹} : Set
+      (LaurentSeries ℂ)))
+      (X ^ (2 * M) * ModularCurve.coeffEmb ℂ ModularCurve.jq ^ (M + 1) *
+        (ModularCurve.coeffEmb ℂ ModularCurve.jq - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ M)) :
+    ∃ f : CuspForm (CongruenceSubgroup.Gamma0 N) 2,
+      HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 f) =
+        X * ModularCurve.thetaL ℂ (ModularCurve.coeffEmb ℂ ModularCurve.jq) := by
+  classical
+  obtain ⟨k, g, h, hh, hXh⟩ :=
+    ModularCurve.exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange N X hX
+  obtain ⟨E4N, hE4⟩ := ModularForm.exists_gamma0_qExpansion_eq_of_levelOne N ModularForm.E₄
+  obtain ⟨E6N, hE6⟩ := ModularForm.exists_gamma0_qExpansion_eq_of_levelOne N ModularForm.E₆
+  obtain ⟨DN, hD⟩ := ModularForm.exists_gamma0_qExpansion_eq_of_levelOne N
+    (ModularFormClass.modularForm (CuspForm.discriminant))
+  have hDcoe : (DN : ℍ → ℂ) = ModularForm.discriminant := by
+    rw [hD]
+    funext z
+    rw [← CuspForm.toModularFormₗ_eq_coe, CuspForm.toModularFormₗ_apply]
+    rfl
+  obtain ⟨Φ, hΦdef⟩ : ∃ Φ : ModularForm (CongruenceSubgroup.Gamma0 N) (k + (4 + 4) + 6),
+      Φ = (g.mul (E4N.mul E4N)).mul E6N := ⟨_, rfl⟩
+  obtain ⟨Ψ, hΨdef⟩ : ∃ Ψ : ModularForm (CongruenceSubgroup.Gamma0 N) (k + 12), Ψ = h.mul DN :=
+    ⟨_, rfl⟩
+  have hΦcoe : (Φ : ℍ → ℂ) = fun z => g z * ModularForm.E₄ z ^ 2 * ModularForm.E₆ z := by
+    funext z
+    simp only [hΦdef, ModularForm.coe_mul, Pi.mul_apply, hE4, hE6]
+    ring
+  have hΨcoe : (Ψ : ℍ → ℂ) = fun z => h z * ModularForm.discriminant z := by
+    funext z
+    simp only [hΨdef, ModularForm.coe_mul, Pi.mul_apply, hDcoe]
+  have hΨ0 : Ψ ≠ 0 := by
+    intro h0
+    apply hh
+    have hfun : (Ψ : ℍ → ℂ) = 0 := by rw [h0]; rfl
+    rw [hΨcoe] at hfun
+    rw [← FunLike.coe_zero_iff]
+    funext z
+    have := congr_fun hfun z
+    simp only [Pi.zero_apply, mul_eq_zero] at this
+    rcases this with hz | hz
+    · exact hz
+    · exact absurd hz (ModularForm.discriminant_ne_zero z)
+  have hord : ∀ τ : ℍ, analyticOrderAt ((Ψ : ℍ → ℂ) ∘ ofComplex) (τ : ℂ) ≤
+      analyticOrderAt ((Φ : ℍ → ℂ) ∘ ofComplex) (τ : ℂ) := by
+    intro τ
+    rw [hΦcoe, hΨcoe]
+    exact ModularCurve.analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq N g h X hXh h₁ τ
+  have hcusp : ∀ (A : SL(2, ℤ)) (ε : ℝ), 0 < ε → ∀ᶠ τ : ℍ in atImInfty,
+      ‖((Φ : ℍ → ℂ) ∣[k + (4 + 4) + 6] (A : GL (Fin 2) ℝ)) τ‖ ≤ ε * ‖((Ψ : ℍ → ℂ) ∣[k + 12] (A : GL
+        (Fin 2) ℝ)) τ‖ := by
+    intro A ε hε
+    rw [hΦcoe, hΨcoe, show k + (4 + 4) + 6 = k + 14 by ring]
+    exact ModularCurve.eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv N g h X hXh M
+      h₂ A ε hε
+  obtain ⟨f, hf⟩ :=
+    ModularForm.exists_cuspForm_mul_eq_of_analyticOrderAt_le N 2 (by ring) Φ Ψ hΨ0 hord hcusp
+  refine ⟨-f, ?_⟩
+  have h1 := one_mem_strictPeriods_gamma0 N
+  have hfΨ : ((ModularFormClass.modularForm f).mul Ψ : ℍ → ℂ) = (Φ : ℍ → ℂ) := by
+    funext z
+    rw [ModularForm.coe_mul, Pi.mul_apply, ← CuspForm.toModularFormₗ_eq_coe,
+      CuspForm.toModularFormₗ_apply]
+    exact hf z
+  have hcoef : ((ModularFormClass.modularForm f : ModularForm (CongruenceSubgroup.Gamma0 N) 2) : ℍ →
+    ℂ) = (f : ℍ → ℂ) :=
+    by
+    rw [← CuspForm.toModularFormₗ_eq_coe]
+    funext z
+    exact CuspForm.toModularFormₗ_apply f z
+  have hq : qExpansion 1 (f : ℍ → ℂ) * qExpansion 1 (Ψ : ℍ → ℂ) = qExpansion 1 (Φ : ℍ → ℂ) := by
+    have e := ModularForm.qExpansion_mul one_pos h1 (ModularFormClass.modularForm f) Ψ
+    rw [hfΨ, hcoef] at e
+    exact e.symm
+  have hqΨ : qExpansion 1 (Ψ : ℍ → ℂ) = qExpansion 1 (h : ℍ → ℂ) * qExpansion 1
+    ModularForm.discriminant :=
+    by
+    rw [hΨdef, ModularForm.qExpansion_mul one_pos h1, hDcoe]
+  have hqΦ : qExpansion 1 (Φ : ℍ → ℂ) =
+      qExpansion 1 (g : ℍ → ℂ) * (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) * qExpansion 1
+        (ModularForm.E₄ : ℍ → ℂ)) *
+        qExpansion 1 (ModularForm.E₆ : ℍ → ℂ) := by
+    rw [hΦdef, ModularForm.qExpansion_mul one_pos h1, ModularForm.qExpansion_mul one_pos h1,
+      ModularForm.qExpansion_mul one_pos h1, hE4, hE6]
+  have hT2 : thetaL ℂ (coeffEmb ℂ jq) * ((qExpansion 1 ModularForm.discriminant : PowerSeries ℂ) :
+    LaurentSeries ℂ) =
+      -((((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)) ^ 2 *
+        ((qExpansion 1 (ModularForm.E₆ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)) := by
+    rw [thetaL_coeffEmb_jq]
+    exact omegaRow_T2
+  have eq1 : ((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) *
+      ((qExpansion 1 (Ψ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+      ((qExpansion 1 (Φ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) := by
+    rw [← PowerSeries.coe_mul, hq]
+  have eq2 : ((qExpansion 1 (Ψ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+      ((qExpansion 1 (h : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) *
+        ((qExpansion 1 ModularForm.discriminant : PowerSeries ℂ) : LaurentSeries ℂ) := by
+    rw [hqΨ, PowerSeries.coe_mul]
+  have eq3 : ((qExpansion 1 (Φ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+      ((qExpansion 1 (g : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) *
+        (((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) *
+          ((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)) *
+        ((qExpansion 1 (ModularForm.E₆ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) := by
+    rw [hqΦ, PowerSeries.coe_mul, PowerSeries.coe_mul, PowerSeries.coe_mul]
+  have hhq : ((qExpansion 1 (h : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) ≠ 0 := by
+    intro h0
+    apply hh
+    have h0' : qExpansion 1 (h : ℍ → ℂ) = 0 :=
+      HahnSeries.ofPowerSeries_injective (by rw [h0, map_zero])
+    exact (ModularForm.qExpansion_eq_zero_iff one_pos h1 h).mp h0'
+  have hDN0 : DN ≠ 0 := by
+    intro h0
+    have hI : (DN : ℍ → ℂ) UpperHalfPlane.I = 0 := by rw [h0]; rfl
+    rw [hDcoe] at hI
+    exact ModularForm.discriminant_ne_zero _ hI
+  have hDq : ((qExpansion 1 ModularForm.discriminant : PowerSeries ℂ) : LaurentSeries ℂ) ≠ 0 := by
+    intro h0
+    apply hDN0
+    have h0' : qExpansion 1 (DN : ℍ → ℂ) = 0 :=
+      HahnSeries.ofPowerSeries_injective (by rw [hDcoe, h0, map_zero])
+    exact (ModularForm.qExpansion_eq_zero_iff one_pos h1 DN).mp h0'
+  have key : (((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) + X * thetaL ℂ
+    (coeffEmb ℂ jq)) *
+      (((qExpansion 1 (h : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) *
+        ((qExpansion 1 ModularForm.discriminant : PowerSeries ℂ) : LaurentSeries ℂ)) = 0 := by
+    linear_combination eq1 + eq3 - ((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) *
+      eq2 +
+      X * ((qExpansion 1 (h : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) * hT2 -
+      ((((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)) ^ 2 *
+        ((qExpansion 1 (ModularForm.E₆ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)) * hXh
+  have hsum : ((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) + X * thetaL ℂ
+    (coeffEmb ℂ jq) = 0 :=
+    by
+    rcases mul_eq_zero.mp key with h0 | h0
+    · exact h0
+    · exact absurd h0 (mul_ne_zero hhq hDq)
+  have hneg : qExpansion 1 ((-f : CuspForm (CongruenceSubgroup.Gamma0 N) 2) : ℍ → ℂ) = -qExpansion 1
+    (f : ℍ → ℂ) :=
+    by
+    rw [FunLike.coe_neg]
+    exact ModularForm.qExpansion_neg one_pos h1 f
+  change ((qExpansion 1 ((-f : CuspForm (CongruenceSubgroup.Gamma0 N) 2) : ℍ → ℂ) : PowerSeries ℂ) :
+    LaurentSeries ℂ) = _
+  rw [hneg, PowerSeries.coe_neg, eq_neg_of_add_eq_zero_left hsum, neg_neg]
+
+end S_ModularCurve_exists_cuspForm_qExpansion_eq_mul_thetaL_of_isIntegral
+end P2MW
+export P2MW.S_ModularCurve_exists_cuspForm_qExpansion_eq_mul_thetaL_of_isIntegral (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.exists_cuspForm_qExpansion_eq_mul_thetaL_of_isIntegral (N : ℕ) [NeZero N]
+    (X : LaurentSeries ℂ)
+    (hX : X ∈ ModularCurve.laurentBaseChange ℂ (ModularCurve.modularFunctionFieldFull N)) (M : ℕ)
+    (h₁ : IsIntegral (Algebra.adjoin ℂ ({ModularCurve.coeffEmb ℂ ModularCurve.jq} : Set
+      (LaurentSeries ℂ)))
+      (X ^ 6 * ModularCurve.coeffEmb ℂ ModularCurve.jq ^ 4 *
+        (ModularCurve.coeffEmb ℂ ModularCurve.jq - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ 3))
+    (h₂ : IsIntegral (Algebra.adjoin ℂ ({(ModularCurve.coeffEmb ℂ ModularCurve.jq)⁻¹} : Set
+      (LaurentSeries ℂ)))
+      (X ^ (2 * M) * ModularCurve.coeffEmb ℂ ModularCurve.jq ^ (M + 1) *
+        (ModularCurve.coeffEmb ℂ ModularCurve.jq - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ M)) :
+    ∃ f : CuspForm (CongruenceSubgroup.Gamma0 N) 2,
+      HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 f) =
+        X * ModularCurve.thetaL ℂ (ModularCurve.coeffEmb ℂ ModularCurve.jq) :=
+  solution N X hX M h₁ h₂
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_cuspForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_cuspForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral.lean
new file mode 100644
index 0000000000..c30523b21b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_cuspForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral.lean
@@ -0,0 +1,339 @@
+/-
+Based on Prove2Me node ModularCurve.exists_cuspForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral
+(f3a1f418-a302-5827-af73-77a29cd04522) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e615e3a5-1af1-5901-9523-3e01fc30dca7
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QExpansionDiff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq_pow
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv_pow
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_thetaL_coeffMap_eq_coeffMap_single_mul_derivative
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_cuspForm_mul_eq_of_analyticOrderAt_le
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_gamma0_qExpansion_eq_of_levelOne
+import LeanPool.FLTEichlerShimura.Theorems.Thm_omegaRow_T2
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Weight-2m cusp forms from integrality over ℂ[j] and ℂ[1/j]
+
+Theorem statement: `ModularCurve.exists_cuspForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral`
+(`f3a1f418-a302-5827-af73-77a29cd04522`), by Claude, 2026-09-05.
+
+Proof: submission `e615e3a5-1af1-5901-9523-3e01fc30dca7`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N\ge 1$ and let $m\ge 1$ be a natural number. Write $J :=$ [`ModularCurve.coeffEmb ℂ
+ModularCurve.jq`](def/ModularCurve_LaurentCoeff.html#L81) for the image in $\mathbb C((q))$, under
+the coefficientwise ring map induced by $\mathbb Q\to\mathbb C$, of the Laurent series
+$q^{-1}\cdot(\text{the power series } j_{\mathrm{Num}}$ over $\mathbb Q)$, and let $\vartheta$
+denote the $\mathbb C$-linear operator
+[`ModularCurve.thetaL`](def/ModularCurve_QExpansionDiff.html#L16) on $\mathbb C((q))$ sending $f$ to
+$q\cdot f'$. Let $X$ be a Laurent series over $\mathbb C$ lying in [`ModularCurve.laurentBaseChange
+ℂ (ModularCurve.modularFunctionFieldFull N)`](def/ModularCurve_LaurentCoeff.html#L103), that is, in
+the intermediate field of $\mathbb C((q))/\mathbb C$ generated by the coefficientwise images of the
+subfield of $\mathbb Q((q))$ generated over $\mathbb Q$ by the series $q$-expanded along the
+divisors $d\mid N$ of $j$. Let $M$ be a natural number, and assume: (i) $X^{6}J^{4m}(J-1728)^{3m}$
+is integral over the $\mathbb C$-subalgebra of $\mathbb C((q))$ generated by $J$; (ii)
+$X^{2M}J^{mM+1}(J-1728)^{mM}$ is integral over the $\mathbb C$-subalgebra generated by $J^{-1}$.
+Then there exists a cusp form $f$ on $\Gamma_0(N)$ of weight $2m$ whose $q$-expansion of width $1$,
+regarded as a Laurent series, equals $X\cdot(\vartheta J)^{m}$.
+
+This is the analytic criterion recognising an element of the field of modular functions of level
+$N$, multiplied by $(\vartheta j)^m$, as the $q$-expansion of a weight-$2m$ cusp form on
+$\Gamma_0(N)$, the two integrality hypotheses encoding holomorphy on the upper half-plane and the
+vanishing conditions at the cusps. It is used by
+[`ModularCurve.exists_cuspForm_qExpansion_eq_coeffMap_mul_thetaL_pow_of_isIntegral`]
+(thm.html#ModularCurve.exists_cuspForm_qExpansion_eq_coeffMap_mul_thetaL_pow_of_isIntegral),
+and rests on the criterion
+[`ModularForm.exists_cuspForm_mul_eq_of_analyticOrderAt_le`]
+(thm.html#ModularForm.exists_cuspForm_mul_eq_of_analyticOrderAt_le)
+together with the order and growth estimates supplied by the two integrality assumptions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_cuspForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_cuspForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral
+
+open ModularCurve UpperHalfPlane HahnSeries
+open scoped MatrixGroups ModularForm
+
+noncomputable section
+
+namespace ANGlueM
+
+theorem one_mem_strictPeriods_gamma0 (N : ℕ) :
+    (1 : ℝ) ∈ (Subgroup.map (Matrix.SpecialLinearGroup.mapGL ℝ) (CongruenceSubgroup.Gamma0
+      N)).strictPeriods := by
+  rw [CongruenceSubgroup.strictPeriods_Gamma0]
+  exact AddSubgroup.mem_zmultiples 1
+
+theorem thetaL_coeffEmb_jq :
+    thetaL ℂ (coeffEmb ℂ jq) = coeffMap (algebraMap ℚ ℂ) (thetaL ℚ jq) := by
+  rw [coeffEmb, ModularCurve.thetaL_coeffMap_eq_coeffMap_single_mul_derivative]
+  rfl
+
+noncomputable def powMF {Γ : Subgroup (GL (Fin 2) ℝ)} [Γ.HasDetPlusMinusOne] {w : ℤ}
+    (P : ModularForm Γ w) :
+    (m : ℕ) → ModularForm Γ ((m : ℤ) * w)
+  | 0 => ModularForm.mcast (by simp) (1 : ModularForm Γ 0)
+  | m + 1 => ModularForm.mcast (by push_cast; ring) ((powMF P m).mul P)
+
+theorem coe_powMF {Γ : Subgroup (GL (Fin 2) ℝ)} [Γ.HasDetPlusMinusOne] {w : ℤ} (P : ModularForm Γ w)
+    (m : ℕ) :
+    (powMF P m : ℍ → ℂ) = (P : ℍ → ℂ) ^ m := by
+  induction m with
+  | zero =>
+    change ((1 : ModularForm Γ 0) : ℍ → ℂ) = _
+    rw [ModularForm.one_coe_eq_one, pow_zero]
+  | succ m ih =>
+    change (((powMF P m).mul P : ModularForm Γ _) : ℍ → ℂ) = _
+    rw [ModularForm.coe_mul, ih, pow_succ]
+
+theorem qExpansion_powMF_succ {Γ : Subgroup (GL (Fin 2) ℝ)} [Γ.HasDetPlusMinusOne] {w : ℤ}
+    (P : ModularForm Γ w)
+    (h1 : (1 : ℝ) ∈ Γ.strictPeriods) (m : ℕ) :
+    qExpansion 1 (powMF P (m + 1) : ℍ → ℂ) = qExpansion 1 (P : ℍ → ℂ) ^ (m + 1) := by
+  induction m with
+  | zero =>
+    have hc : (powMF P (0 + 1) : ℍ → ℂ) = (P : ℍ → ℂ) := by rw [coe_powMF, zero_add, pow_one]
+    rw [hc, zero_add, pow_one]
+  | succ m ih =>
+    change qExpansion 1 (((powMF P (m + 1)).mul P : ModularForm Γ _) : ℍ → ℂ) = _
+    rw [ModularForm.qExpansion_mul one_pos h1, ih, ← pow_succ]
+
+end ANGlueM
+
+open ANGlueM in
+theorem solution (N : ℕ) [NeZero N] (m : ℕ) (hm : 1 ≤ m)
+    (X : LaurentSeries ℂ)
+    (hX : X ∈ ModularCurve.laurentBaseChange ℂ (ModularCurve.modularFunctionFieldFull N)) (M : ℕ)
+    (h₁ : IsIntegral (Algebra.adjoin ℂ ({ModularCurve.coeffEmb ℂ ModularCurve.jq} : Set
+      (LaurentSeries ℂ)))
+      (X ^ 6 * ModularCurve.coeffEmb ℂ ModularCurve.jq ^ (4 * m) *
+        (ModularCurve.coeffEmb ℂ ModularCurve.jq - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (3 * m)))
+    (h₂ : IsIntegral (Algebra.adjoin ℂ ({(ModularCurve.coeffEmb ℂ ModularCurve.jq)⁻¹} : Set
+      (LaurentSeries ℂ)))
+      (X ^ (2 * M) * ModularCurve.coeffEmb ℂ ModularCurve.jq ^ (m * M + 1) *
+        (ModularCurve.coeffEmb ℂ ModularCurve.jq - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (m *
+          M))) :
+    ∃ f : CuspForm (CongruenceSubgroup.Gamma0 N) (2 * (m : ℤ)),
+      HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 f) =
+        X * ModularCurve.thetaL ℂ (ModularCurve.coeffEmb ℂ ModularCurve.jq) ^ m := by
+  classical
+  obtain ⟨m, rfl⟩ : ∃ m' : ℕ, m = m' + 1 := ⟨m - 1, (Nat.sub_add_cancel hm).symm⟩
+  obtain ⟨k, g, h, hh, hXh⟩ :=
+    ModularCurve.exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange N X hX
+  obtain ⟨E4N, hE4⟩ := ModularForm.exists_gamma0_qExpansion_eq_of_levelOne N ModularForm.E₄
+  obtain ⟨E6N, hE6⟩ := ModularForm.exists_gamma0_qExpansion_eq_of_levelOne N ModularForm.E₆
+  obtain ⟨DN, hD⟩ := ModularForm.exists_gamma0_qExpansion_eq_of_levelOne N
+    (ModularFormClass.modularForm (CuspForm.discriminant))
+  have hDcoe : (DN : ℍ → ℂ) = ModularForm.discriminant := by
+    rw [hD]
+    funext z
+    rw [← CuspForm.toModularFormₗ_eq_coe, CuspForm.toModularFormₗ_apply]
+    rfl
+  have h1 := one_mem_strictPeriods_gamma0 N
+  obtain ⟨P, hPdef⟩ : ∃ P : ModularForm (CongruenceSubgroup.Gamma0 N) ((4 + 4) + 6), P = (E4N.mul
+    E4N).mul E6N :=
+    ⟨_, rfl⟩
+  have hPcoe : (P : ℍ → ℂ) = fun z => ModularForm.E₄ z ^ 2 * ModularForm.E₆ z := by
+    funext z
+    simp only [hPdef, ModularForm.coe_mul, Pi.mul_apply, hE4, hE6]
+    ring
+  obtain ⟨Φ, hΦdef⟩ : ∃ Φ : ModularForm (CongruenceSubgroup.Gamma0 N) (k + ((m + 1 : ℕ) : ℤ) * ((4 +
+    4) + 6)),
+      Φ = g.mul (powMF P (m + 1)) := ⟨_, rfl⟩
+  obtain ⟨Ψ, hΨdef⟩ : ∃ Ψ : ModularForm (CongruenceSubgroup.Gamma0 N) (k + ((m + 1 : ℕ) : ℤ) * 12),
+      Ψ = h.mul (powMF DN (m + 1)) := ⟨_, rfl⟩
+  have hΦcoe : (Φ : ℍ → ℂ) = fun z => g z * (ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) ^ (m + 1)
+    := by
+    funext z
+    rw [hΦdef, ModularForm.coe_mul, coe_powMF, hPcoe, Pi.mul_apply, Pi.pow_apply]
+  have hΨcoe : (Ψ : ℍ → ℂ) = fun z => h z * ModularForm.discriminant z ^ (m + 1) := by
+    funext z
+    rw [hΨdef, ModularForm.coe_mul, coe_powMF, hDcoe, Pi.mul_apply, Pi.pow_apply]
+  have hΨ0 : Ψ ≠ 0 := by
+    intro h0
+    apply hh
+    have hfun : (Ψ : ℍ → ℂ) = 0 := by rw [h0]; rfl
+    rw [hΨcoe] at hfun
+    rw [← FunLike.coe_zero_iff]
+    funext z
+    have := congr_fun hfun z
+    simp only [Pi.zero_apply, mul_eq_zero] at this
+    rcases this with hz | hz
+    · exact hz
+    · exact absurd (pow_eq_zero_iff (Nat.succ_ne_zero m) |>.mp hz) (ModularForm.discriminant_ne_zero
+        z)
+  have hm1 : 1 ≤ m + 1 := Nat.le_add_left 1 m
+  have hord : ∀ τ : ℍ, analyticOrderAt ((Ψ : ℍ → ℂ) ∘ ofComplex) (τ : ℂ) ≤
+      analyticOrderAt ((Φ : ℍ → ℂ) ∘ ofComplex) (τ : ℂ) := by
+    intro τ
+    rw [hΦcoe, hΨcoe]
+    exact ModularCurve.analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq_pow N (m + 1) g h X hXh
+      h₁ τ
+  have hcusp : ∀ (A : SL(2, ℤ)) (ε : ℝ), 0 < ε → ∀ᶠ τ : ℍ in atImInfty,
+      ‖((Φ : ℍ → ℂ) ∣[k + ((m + 1 : ℕ) : ℤ) * ((4 + 4) + 6)] (A : GL (Fin 2) ℝ)) τ‖ ≤
+        ε * ‖((Ψ : ℍ → ℂ) ∣[k + ((m + 1 : ℕ) : ℤ) * 12] (A : GL (Fin 2) ℝ)) τ‖ := by
+    intro A ε hε
+    rw [hΦcoe, hΨcoe, show k + ((m + 1 : ℕ) : ℤ) * ((4 + 4) + 6) = k + 14 * ((m + 1 : ℕ) : ℤ) by
+      ring,
+      show k + ((m + 1 : ℕ) : ℤ) * 12 = k + 12 * ((m + 1 : ℕ) : ℤ) by ring]
+    exact ModularCurve.eventually_norm_slash_le_of_isIntegral_adjoin_coeffEmb_jq_inv_pow N (m + 1) g
+      h X hXh M h₂ A ε hε
+  obtain ⟨f, hf⟩ :=
+    ModularForm.exists_cuspForm_mul_eq_of_analyticOrderAt_le N (2 * ((m + 1 : ℕ) : ℤ))
+    (by push_cast; ring) Φ Ψ hΨ0 hord hcusp
+  have hfΨ : ((ModularFormClass.modularForm f).mul Ψ : ℍ → ℂ) = (Φ : ℍ → ℂ) := by
+    funext z
+    rw [ModularForm.coe_mul, Pi.mul_apply, ← CuspForm.toModularFormₗ_eq_coe,
+      CuspForm.toModularFormₗ_apply]
+    exact hf z
+  have hcoef : ((ModularFormClass.modularForm f : ModularForm (CongruenceSubgroup.Gamma0 N) (2 * ((m
+    + 1 : ℕ) : ℤ))) : ℍ → ℂ) = (f : ℍ → ℂ) :=
+    by
+    rw [← CuspForm.toModularFormₗ_eq_coe]
+    funext z
+    exact CuspForm.toModularFormₗ_apply f z
+  have hq : qExpansion 1 (f : ℍ → ℂ) * qExpansion 1 (Ψ : ℍ → ℂ) = qExpansion 1 (Φ : ℍ → ℂ) := by
+    have e := ModularForm.qExpansion_mul one_pos h1 (ModularFormClass.modularForm f) Ψ
+    rw [hfΨ, hcoef] at e
+    exact e.symm
+  have hqD : qExpansion 1 (powMF DN (m + 1) : ℍ → ℂ) = qExpansion 1 ModularForm.discriminant ^ (m +
+    1) :=
+    by
+    rw [qExpansion_powMF_succ DN h1 m, hDcoe]
+  have hqP : qExpansion 1 (powMF P (m + 1) : ℍ → ℂ) =
+      (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) * qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) *
+        qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) ^ (m + 1) := by
+    rw [qExpansion_powMF_succ P h1 m, hPdef, ModularForm.qExpansion_mul one_pos h1,
+      ModularForm.qExpansion_mul one_pos h1,
+      hE4, hE6]
+  have hqΨ : qExpansion 1 (Ψ : ℍ → ℂ) = qExpansion 1 (h : ℍ → ℂ) * qExpansion 1
+    ModularForm.discriminant ^ (m + 1) :=
+    by
+    rw [hΨdef, ModularForm.qExpansion_mul one_pos h1, hqD]
+  have hqΦ : qExpansion 1 (Φ : ℍ → ℂ) =
+      qExpansion 1 (g : ℍ → ℂ) * (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) * qExpansion 1
+        (ModularForm.E₄ : ℍ → ℂ) *
+        qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) ^ (m + 1) := by
+    rw [hΦdef, ModularForm.qExpansion_mul one_pos h1, hqP]
+  set F : LaurentSeries ℂ := ((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) with hF
+  set Hh : LaurentSeries ℂ := ((qExpansion 1 (h : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) with
+    hHh
+  set G : LaurentSeries ℂ := ((qExpansion 1 (g : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) with hG
+  set D : LaurentSeries ℂ := ((qExpansion 1 ModularForm.discriminant : PowerSeries ℂ) :
+    LaurentSeries ℂ) with hDD
+  set A4 : LaurentSeries ℂ := ((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) : PowerSeries ℂ) :
+    LaurentSeries ℂ) with hA4
+  set A6 : LaurentSeries ℂ := ((qExpansion 1 (ModularForm.E₆ : ℍ → ℂ) : PowerSeries ℂ) :
+    LaurentSeries ℂ) with hA6
+  set T : LaurentSeries ℂ := thetaL ℂ (coeffEmb ℂ jq) with hT
+  have hT2 : T * D = -(A4 ^ 2 * A6) := by
+    rw [hT, thetaL_coeffEmb_jq]
+    exact omegaRow_T2
+  have eq1 : F * (Hh * D ^ (m + 1)) = G * (A4 * A4 * A6) ^ (m + 1) := by
+    rw [hF, hHh, hDD, hG, hA4, hA6, ← PowerSeries.coe_pow, ← PowerSeries.coe_mul, ←
+      PowerSeries.coe_mul, ← hqΨ, hq, hqΦ,
+      PowerSeries.coe_mul, PowerSeries.coe_pow, PowerSeries.coe_mul, PowerSeries.coe_mul]
+  have hhq : Hh ≠ 0 := by
+    intro h0
+    apply hh
+    have h0' : qExpansion 1 (h : ℍ → ℂ) = 0 :=
+      HahnSeries.ofPowerSeries_injective (by rw [← hHh, h0, map_zero])
+    exact (ModularForm.qExpansion_eq_zero_iff one_pos h1 h).mp h0'
+  have hDN0 : DN ≠ 0 := by
+    intro h0
+    have hI : (DN : ℍ → ℂ) UpperHalfPlane.I = 0 := by rw [h0]; rfl
+    rw [hDcoe] at hI
+    exact ModularForm.discriminant_ne_zero _ hI
+  have hDq : D ≠ 0 := by
+    intro h0
+    apply hDN0
+    have h0' : qExpansion 1 (DN : ℍ → ℂ) = 0 :=
+      HahnSeries.ofPowerSeries_injective (by rw [hDcoe, ← hDD, h0, map_zero])
+    exact (ModularForm.qExpansion_eq_zero_iff one_pos h1 DN).mp h0'
+  have hHD : Hh * D ^ (m + 1) ≠ 0 := mul_ne_zero hhq (pow_ne_zero _ hDq)
+  set X2 : LaurentSeries ℂ := A4 ^ 2 * A6 with hX2
+  have eq1' : F * (Hh * D ^ (m + 1)) = X * Hh * X2 ^ (m + 1) := by
+    rw [eq1, ← hXh, hX2]; ring
+  rcases Nat.even_or_odd (m + 1) with hev | hodd
+  · obtain ⟨r, hr⟩ := hev
+    have hsq : (T * D) ^ 2 = X2 ^ 2 := by rw [hT2]; ring
+    have hP2 : X2 ^ (m + 1) = (T * D) ^ (m + 1) := by
+      rw [hr, ← two_mul, pow_mul, pow_mul, hsq]
+    have key : (F - X * T ^ (m + 1)) * (Hh * D ^ (m + 1)) = 0 := by
+      rw [sub_mul, eq1', hP2, mul_pow]; ring
+    have hF' : F = X * T ^ (m + 1) := sub_eq_zero.mp ((mul_eq_zero.mp key).resolve_right hHD)
+    exact ⟨f, hF'⟩
+  · obtain ⟨r, hr⟩ := hodd
+    have hsq : (T * D) ^ 2 = X2 ^ 2 := by rw [hT2]; ring
+    have hP2 : X2 ^ (m + 1) = -(T * D) ^ (m + 1) := by
+      rw [hr, pow_succ, pow_succ, pow_mul, pow_mul, hsq, hT2]; ring
+    have key : (F + X * T ^ (m + 1)) * (Hh * D ^ (m + 1)) = 0 := by
+      rw [add_mul, eq1', hP2, mul_pow]; ring
+    have hF' : F = -(X * T ^ (m + 1)) :=
+      eq_neg_of_add_eq_zero_left ((mul_eq_zero.mp key).resolve_right hHD)
+    refine ⟨-f, ?_⟩
+    have hneg : qExpansion 1 ((-f : CuspForm (CongruenceSubgroup.Gamma0 N) (2 * ((m + 1 : ℕ) : ℤ)))
+      : ℍ → ℂ) =
+        -qExpansion 1 (f : ℍ → ℂ) := by
+      rw [FunLike.coe_neg]
+      exact ModularForm.qExpansion_neg one_pos h1 f
+    change ((qExpansion 1 ((-f : CuspForm (CongruenceSubgroup.Gamma0 N) (2 * ((m + 1 : ℕ) : ℤ))) : ℍ
+      → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) = X * T ^ (m + 1)
+    rw [hneg, PowerSeries.coe_neg, ← hF, hF', neg_neg]
+
+end
+end S_ModularCurve_exists_cuspForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral
+end P2MW
+export P2MW.S_ModularCurve_exists_cuspForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.exists_cuspForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral (N : ℕ) [NeZero N]
+    (m : ℕ) (hm : 1 ≤ m)
+    (X : LaurentSeries ℂ)
+    (hX : X ∈ ModularCurve.laurentBaseChange ℂ (ModularCurve.modularFunctionFieldFull N)) (M : ℕ)
+    (h₁ : IsIntegral (Algebra.adjoin ℂ ({ModularCurve.coeffEmb ℂ ModularCurve.jq} : Set
+      (LaurentSeries ℂ)))
+      (X ^ 6 * ModularCurve.coeffEmb ℂ ModularCurve.jq ^ (4 * m) *
+        (ModularCurve.coeffEmb ℂ ModularCurve.jq - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (3 * m)))
+    (h₂ : IsIntegral (Algebra.adjoin ℂ ({(ModularCurve.coeffEmb ℂ ModularCurve.jq)⁻¹} : Set
+      (LaurentSeries ℂ)))
+      (X ^ (2 * M) * ModularCurve.coeffEmb ℂ ModularCurve.jq ^ (m * M + 1) *
+        (ModularCurve.coeffEmb ℂ ModularCurve.jq - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (m *
+          M))) :
+    ∃ f : CuspForm (CongruenceSubgroup.Gamma0 N) (2 * (m : ℤ)),
+      HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 f) =
+        X * ModularCurve.thetaL ℂ (ModularCurve.coeffEmb ℂ ModularCurve.jq) ^ m :=
+  solution N m hm X hX M h₁ h₂
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_divisor_degree_weight_and_isIntegral_of_mem_riemannRochSpace.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_divisor_degree_weight_and_isIntegral_of_mem_riemannRochSpace.lean
new file mode 100644
index 0000000000..89aab73658
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_divisor_degree_weight_and_isIntegral_of_mem_riemannRochSpace.lean
@@ -0,0 +1,765 @@
+/-
+Based on Prove2Me node
+ModularCurve.exists_divisor_degree_weight_and_isIntegral_of_mem_riemannRochSpace
+(7c8c2611-3f75-5f50-8620-bbc353cafd33) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e35b7e94-2177-503f-ad53-6879f6d8eed9
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Repartitions
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_MazurStepThreeInputs
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Analysis.Normed.Ring.Lemmas
+import Mathlib.Data.Int.Star
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_add_eq_of_lt
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isIntegral_adjoin_of_forall_ord_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_card_eq_cuspCount_of_forall_mem_iff_ord_jBar_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_card_eq_natCard_moduliPoint_j_eq_of_EMD
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_pos
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_deg_eq_one_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_emd_holds
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_of_neZero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCurveOver_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jCoordinate_spec_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_ord_jBar_eq_one_eq_nuThree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_jBar_dvd_three
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_jBar_sub_1728_dvd_two
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_sum_neg_ord_jBar_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_sum_ord_jBar_sub_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A weight-2m divisor on X₀(N)_ℚ̄ with integrality
+
+Theorem statement:
+`ModularCurve.exists_divisor_degree_weight_and_isIntegral_of_mem_riemannRochSpace`
+(`7c8c2611-3f75-5f50-8620-bbc353cafd33`), by Claude, 2026-09-05.
+
+Proof: submission `e35b7e94-2177-503f-ad53-6879f6d8eed9`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N\ge 1$ (a natural number with `NeZero N`) and let $m$ be a natural number with $1\le m$. Write
+$\bar F_N$ for [`ModularCurve.modularFunctionFieldBar
+N`](def/ModularCurve_ArithmeticGalois.html#L111), the intermediate field of $\overline{\mathbb
+Q}((q))$ generated over $\overline{\mathbb Q}$ by the coefficientwise image of
+`modularFunctionFieldFull N`, itself the subfield of $\mathbb Q((q))$ generated over $\mathbb Q$ by
+the divisor expansions attached to $N$, and write $\bar\jmath=$ `jBar N` for the element of $\bar
+F_N$ given by the $q$-expansion of $j$. Put $g=$ `genusFormula N`
+$=1+\psi(N)/12-\nu_2/4-\nu_3/3-\nu_\infty/2$, where $\psi(N)=\sum_{d\mid N,\ d\
+\text{squarefree}}N/d$, $\nu_2=\#\{x\in\mathbb Z/N:x^2+1=0\}$, $\nu_3=\#\{x\in\mathbb
+Z/N:x^2+x+1=0\}$ and $\nu_\infty=$ `cuspCount N` $=\sum_{d\mid N}\varphi(\gcd(d,N/d))$. The
+assertion is that there exists a divisor $D$ on $\bar F_N$ over $\overline{\mathbb Q}$, i.e. a
+finitely supported integer-valued function on the places of $\bar F_N/\overline{\mathbb Q}$
+(valuation subrings containing $\overline{\mathbb Q}$, proper, and principal ideal rings), such
+that, first, with $\deg D=\sum_v D(v)\deg v$,
+$$\deg D+1-g=(2m-1)(g-1)+\lfloor m/2\rfloor\,\nu_2+\lfloor 2m/3\rfloor\,\nu_3+(m-1)\,\nu_\infty$$
+(the floors being natural-number divisions $m/2$ and $2m/3$), and, secondly, every $x$ in the
+Riemann–Roch space of $D$, that is every $x\in\bar F_N$ whose adic valuation at each place $v$ is at
+most $\exp(D(v))$, satisfies two integrality conditions:
+$x^6\,\bar\jmath^{\,4m}(\bar\jmath-1728)^{3m}$ is integral over $\overline{\mathbb Q}[\bar\jmath]$,
+and $x^{2\psi(N)}\,\bar\jmath^{\,m\psi(N)+1}(\bar\jmath-1728)^{m\psi(N)}$ is integral over
+$\overline{\mathbb Q}[\bar\jmath^{-1}]$, where $1728$ denotes its image under the structure map
+$\overline{\mathbb Q}\to\bar F_N$.
+
+This packages the divisor-theoretic input to the dimension formula for cusp forms of weight $2m$ on
+$\Gamma_0(N)$: a divisor whose Riemann–Roch defect is exactly the classical dimension expression,
+together with growth bounds at the places above $j=0$, $j=1728$ and the cusps in the form of
+integrality over $\overline{\mathbb Q}[\bar\jmath]$ and $\overline{\mathbb Q}[\bar\jmath^{-1}]$. It
+is used in the proof of
+[`CuspForm.dimFormula_le_finrank_gamma0`](thm.html#CuspForm.dimFormula_le_finrank_gamma0).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_divisor_degree_weight_and_isIntegral_of_mem_riemannRochSpace.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_divisor_degree_weight_and_isIntegral_of_mem_riemannRochSpace
+
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jBar modularFunctionFieldBar jq coeff_jq_neg_one dedekindPsi coeffEmb \
+  coeffEmb_coeff nuTwo nuThree cuspCount genusFormula EMD ModuliPoint ModuliPoint.j \
+  sum_ord_jBar_sub_eq_dedekindPsi deg_eq_one_modularFunctionFieldBar \
+  jCoordinate_spec_modularFunctionFieldBar sum_neg_ord_jBar_eq_dedekindPsi ord_jBar_dvd_three \
+  ord_jBar_sub_1728_dvd_two card_eq_cuspCount_of_forall_mem_iff_ord_jBar_neg \
+  natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo natCard_ord_jBar_eq_one_eq_nuThree \
+  card_eq_natCard_moduliPoint_j_eq_of_EMD emd_holds transcendental_coeffEmb_jq \
+  isCurveOver_modularFunctionFieldBar finiteDimensional_adjoin_coeffEmb_jq_of_neZero \
+  dedekindPsi_pos"
+namespace LDivDegree
+p2m_open "ModularCurve"
+
+p2m_open "ModularCurve \
+  P2MW.S_ModularCurve_exists_divisor_degree_weight_and_isIntegral_of_mem_riemannRochSpace.ModularCu\
+  rve AlgebraicCurve"
+
+section Generic
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem ord_algebraMap (v : Place K F) {c : K} : v.ord (algebraMap K F c) = 0 := by
+  have h1 : 0 ≤ v.ord (algebraMap K F c) := v.ord_nonneg_of_mem (v.algebraMap_mem' c)
+  have h2 : 0 ≤ v.ord (algebraMap K F c⁻¹) := v.ord_nonneg_of_mem (v.algebraMap_mem' c⁻¹)
+  rw [map_inv₀, v.ord_inv] at h2
+  omega
+
+theorem ord_neg (v : Place K F) (f : F) : v.ord (-f) = v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · simp
+  have h1 : v.ord (-f) = v.ord (-1) + v.ord f := by
+    rw [← v.ord_mul (by norm_num) hf, neg_one_mul]
+  have h2 : v.ord ((-1 : F)) = 0 := by
+    have := v.ord_zpow (-1 : F) 2
+    norm_num at this
+    linarith
+  rw [h1, h2, zero_add]
+
+end Generic
+
+theorem int_eq_of_pos_of_dvd_two {e : ℤ} (he : 0 < e) (hd : e ∣ 2) : e = 1 ∨ e = 2 := by
+  have hle := Int.le_of_dvd (by norm_num) hd
+  interval_cases e
+  · exact Or.inl rfl
+  · exact Or.inr rfl
+
+theorem int_eq_of_pos_of_dvd_three {e : ℤ} (he : 0 < e) (hd : e ∣ 3) : e = 1 ∨ e = 3 := by
+  have hle := Int.le_of_dvd (by norm_num) hd
+  interval_cases e
+  · exact Or.inl rfl
+  · exfalso; norm_num at hd
+  · exact Or.inr rfl
+
+variable (N : ℕ) [NeZero N] (m : ℕ)
+
+local notation "ℚb" => AlgebraicClosure ℚ
+local notation "𝔽" => ModularCurve.modularFunctionFieldBar N
+
+theorem jBar_sub_algebraMap_ne_zero (c : ℚb) : jBar N - algebraMap ℚb 𝔽 c ≠ 0 := by
+  intro h
+  have htr := transcendental_coeffEmb_jq (AlgebraicClosure ℚ) N
+  apply htr
+  have : (jBar N : 𝔽) = algebraMap ℚb 𝔽 c := sub_eq_zero.mp h
+  change IsAlgebraic ℚb (jBar N)
+  rw [this]
+  exact isAlgebraic_algebraMap c
+
+theorem jBar_ne_zero : (jBar N : 𝔽) ≠ 0 := by
+  have h := jBar_sub_algebraMap_ne_zero N 0
+  rwa [map_zero, sub_zero] at h
+
+theorem ord_sub_nonneg {v : Place ℚb 𝔽} (hv : 0 ≤ v.ord (jBar N)) (c : ℚb) :
+    0 ≤ v.ord (jBar N - algebraMap ℚb 𝔽 c) := by
+  rw [← v.mem_iff_ord_nonneg (jBar_sub_algebraMap_ne_zero N c)]
+  exact sub_mem ((v.mem_iff_ord_nonneg (jBar_ne_zero N)).mpr hv) (v.algebraMap_mem' c)
+
+theorem ord_eq_zero_of_pos_1728 {v : Place ℚb 𝔽} (hv : 0 < v.ord (jBar N - algebraMap ℚb 𝔽 1728)) :
+    v.ord (jBar N) = 0 := by
+  have h1728 : v.ord (algebraMap ℚb 𝔽 1728) = 0 := ord_algebraMap v
+  have hne : (algebraMap ℚb 𝔽 1728) ≠ 0 := by
+    rw [Ne, map_eq_zero_iff _ (algebraMap ℚb 𝔽).injective]; norm_num
+  rcases lt_trichotomy (v.ord (jBar N)) 0 with hlt | heq | hgt
+  · have h : v.ord (jBar N + (-(algebraMap ℚb 𝔽 1728))) = v.ord (jBar N) :=
+      v.ord_add_eq_of_lt (jBar_ne_zero N) (neg_ne_zero.mpr hne) (by rw [ord_neg, h1728]; exact hlt)
+    rw [← sub_eq_add_neg] at h
+    omega
+  · exact heq
+  · have h : v.ord (-(algebraMap ℚb 𝔽 1728) + jBar N) = v.ord (-(algebraMap ℚb 𝔽 1728)) :=
+      v.ord_add_eq_of_lt (neg_ne_zero.mpr hne) (jBar_ne_zero N) (by rw [ord_neg, h1728]; exact hgt)
+    rw [neg_add_eq_sub, ord_neg, h1728] at h
+    omega
+
+theorem ord_1728_eq_zero_of_pos {v : Place ℚb 𝔽} (hv : 0 < v.ord (jBar N)) :
+    v.ord (jBar N - algebraMap ℚb 𝔽 1728) = 0 := by
+  have h1728 : v.ord (algebraMap ℚb 𝔽 1728) = 0 := ord_algebraMap v
+  have hne : (algebraMap ℚb 𝔽 1728) ≠ 0 := by
+    rw [Ne, map_eq_zero_iff _ (algebraMap ℚb 𝔽).injective]; norm_num
+  have h : v.ord (-(algebraMap ℚb 𝔽 1728) + jBar N) = v.ord (-(algebraMap ℚb 𝔽 1728)) :=
+    v.ord_add_eq_of_lt (neg_ne_zero.mpr hne) (jBar_ne_zero N) (by rw [ord_neg, h1728]; exact hv)
+  rw [neg_add_eq_sub, ord_neg, h1728] at h
+  exact h
+
+noncomputable def recipe (v : Place ℚb 𝔽) : ℤ :=
+  if v.ord (jBar N) < 0 then (m : ℤ) * v.ord (jBar N) - 1
+  else (m : ℤ) * v.ord (jBar N - algebraMap ℚb 𝔽 1728) / 2 + 2 * (m : ℤ) * v.ord (jBar N) / 3
+
+theorem recipe_of_neg {v : Place ℚb 𝔽} (h : v.ord (jBar N) < 0) :
+    recipe N m v = (m : ℤ) * v.ord (jBar N) - 1 := ite_eq_left h
+
+theorem recipe_of_nonneg {v : Place ℚb 𝔽} (h : 0 ≤ v.ord (jBar N)) :
+    recipe N m v = (m : ℤ) * v.ord (jBar N - algebraMap ℚb 𝔽 1728) / 2 + 2 * (m : ℤ) * v.ord (jBar
+      N) / 3 :=
+  ite_eq_right (not_lt.mpr h)
+
+theorem recipe_of_pos {v : Place ℚb 𝔽} (h : 0 < v.ord (jBar N)) :
+    recipe N m v = 2 * (m : ℤ) * v.ord (jBar N) / 3 := by
+  rw [recipe_of_nonneg N m h.le, ord_1728_eq_zero_of_pos N h, mul_zero, Int.zero_ediv, zero_add]
+
+theorem recipe_of_pos_1728 {v : Place ℚb 𝔽} (h : 0 < v.ord (jBar N - algebraMap ℚb 𝔽 1728)) :
+    recipe N m v = (m : ℤ) * v.ord (jBar N - algebraMap ℚb 𝔽 1728) / 2 := by
+  have h0 := ord_eq_zero_of_pos_1728 N h
+  rw [recipe_of_nonneg N m h0.ge, h0, mul_zero, Int.zero_ediv, add_zero]
+
+theorem recipe_eq_zero {v : Place ℚb 𝔽} (h0 : v.ord (jBar N) = 0)
+    (h1 : ¬ 0 < v.ord (jBar N - algebraMap ℚb 𝔽 1728)) : recipe N m v = 0 := by
+  have hge := ord_sub_nonneg N h0.ge (1728 : ℚb)
+  have he : v.ord (jBar N - algebraMap ℚb 𝔽 1728) = 0 := by omega
+  rw [recipe_of_nonneg N m h0.ge, h0, he]
+  simp
+
+theorem exists_weightDivisor :
+    ∃ D : AlgebraicCurve.Divisor (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar N),
+      ((D.degree : ℚ) + 1 - ModularCurve.genusFormula N =
+        (2 * (m : ℚ) - 1) * (ModularCurve.genusFormula N - 1) + ((m / 2 : ℕ) : ℚ) *
+          (ModularCurve.nuTwo N : ℚ)
+          + ((2 * m / 3 : ℕ) : ℚ) * (ModularCurve.nuThree N : ℚ) + ((m : ℚ) - 1) *
+            (ModularCurve.cuspCount N : ℚ)) ∧
+      (∀ v, 0 ≤ v.ord (jBar N) →
+        D v ≤ (m : ℤ) * v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+          1728) / 2
+          + 2 * (m : ℤ) * v.ord (jBar N) / 3) ∧
+      (∀ v, v.ord (jBar N) < 0 → D v ≤ (m : ℤ) * v.ord (jBar N) - 1) := by
+  classical
+  have hdeg : ∀ w : Place ℚb 𝔽, w.deg = 1 := deg_eq_one_modularFunctionFieldBar N
+  obtain ⟨-, hfinc, hfinI⟩ := jCoordinate_spec_modularFunctionFieldBar N
+  set S0 : Finset (Place ℚb 𝔽) := (hfinc 0).toFinset with hS0def
+  set S1 : Finset (Place ℚb 𝔽) := (hfinc 1728).toFinset with hS1def
+  set Sinf : Finset (Place ℚb 𝔽) := hfinI.toFinset with hSIdef
+  have hS0 : ∀ v, v ∈ S0 ↔ 0 < v.ord (jBar N) := fun v => by
+    rw [hS0def, Set.Finite.mem_toFinset, Set.mem_ofPred_eq, map_zero, sub_zero]
+  have hS1 : ∀ v, v ∈ S1 ↔ 0 < v.ord (jBar N - algebraMap ℚb 𝔽 1728) :=
+    fun v => by rw [hS1def, Set.Finite.mem_toFinset, Set.mem_ofPred_eq]
+  have hSI : ∀ v, v ∈ Sinf ↔ v.ord (jBar N) < 0 := fun v => by
+    rw [hSIdef, Set.Finite.mem_toFinset, Set.mem_ofPred_eq]
+  set S := S0 ∪ S1 ∪ Sinf with hSdef
+  have hS : ∀ v, v ∈ S ↔ v ∈ S0 ∨ v ∈ S1 ∨ v ∈ Sinf := fun v => by
+    simp only [hSdef, Finset.mem_union, or_assoc]
+  have hoff : ∀ v, v ∉ S → recipe N m v = 0 := by
+    intro v hv
+    rw [hS] at hv
+    push Not at hv
+    obtain ⟨hv0, hv1, hvI⟩ := hv
+    rw [hS0] at hv0; rw [hS1] at hv1; rw [hSI] at hvI
+    exact recipe_eq_zero N m (by omega) hv1
+  let D : Divisor ℚb 𝔽 := Finsupp.onFinset S (recipe N m) (fun v hv => by
+    by_contra h
+    exact hv (hoff v h))
+  have hD : ∀ v, D v = recipe N m v := fun v => Finsupp.onFinset_apply
+  refine ⟨D, ?_, fun v hv => ?_, fun v hv => ?_⟩
+  rotate_left
+  · rw [hD, recipe_of_nonneg N m hv]
+  · rw [hD, recipe_of_neg N m hv]
+  have hdisj01 : Disjoint S0 S1 := by
+    rw [Finset.disjoint_left]
+    intro v hv0 hv1
+    rw [hS0] at hv0; rw [hS1] at hv1
+    have := ord_eq_zero_of_pos_1728 N hv1
+    omega
+  have hdisj0I : Disjoint (S0 ∪ S1) Sinf := by
+    rw [Finset.disjoint_left]
+    intro v hv hvI
+    rw [hSI] at hvI
+    rcases Finset.mem_union.mp hv with hv0 | hv1
+    · rw [hS0] at hv0; omega
+    · rw [hS1] at hv1
+      have := ord_eq_zero_of_pos_1728 N hv1
+      omega
+  have hdegsum : D.degree = ∑ v ∈ S, recipe N m v := by
+    rw [Divisor.degree, Finsupp.liftAddHom_apply, Finsupp.sum]
+    have hsupp : D.support ⊆ S := Finsupp.support_onFinset_subset
+    rw [Finset.sum_subset hsupp (fun v _ hv => by
+      have : D v = 0 := by simpa [Finsupp.mem_support_iff] using hv
+      rw [this]; simp)]
+    refine Finset.sum_congr rfl (fun v _ => ?_)
+    rw [AddMonoidHom.mulRight_apply, hdeg v, Nat.cast_one, mul_one, hD]
+  have hsplit : ∑ v ∈ S, recipe N m v
+      = ∑ v ∈ S0, recipe N m v + ∑ v ∈ S1, recipe N m v + ∑ v ∈ Sinf, recipe N m v := by
+    rw [hSdef, Finset.sum_union hdisj0I, Finset.sum_union hdisj01]
+  have hsum0 : 3 * ∑ v ∈ S0, recipe N m v
+      = 3 * ((2 * m / 3 : ℕ) : ℤ) * ((S0.filter fun v => v.ord (jBar N) = 1).card : ℤ)
+        + 2 * (m : ℤ) * ((dedekindPsi N : ℤ) - ((S0.filter fun v => v.ord (jBar N) = 1).card : ℤ))
+          := by
+    have hψ₀ : ∑ v ∈ S0, v.ord (jBar N) = (dedekindPsi N : ℤ) := by
+      have h :=
+        sum_ord_jBar_sub_eq_dedekindPsi N 0 hdeg S0 (fun v => by rw [hS0, map_zero, sub_zero])
+      simpa [map_zero, sub_zero] using h
+    have hcase : ∀ v ∈ S0, (v.ord (jBar N) = 1 ∧ recipe N m v = ((2 * m / 3 : ℕ) : ℤ)) ∨
+        (v.ord (jBar N) = 3 ∧ recipe N m v = 2 * (m : ℤ)) := by
+      intro v hv
+      have hpos := (hS0 v).1 hv
+      have hdvd := ord_jBar_dvd_three N v hpos
+      rw [recipe_of_pos N m hpos]
+      rcases int_eq_of_pos_of_dvd_three hpos hdvd with h1 | h3
+      · left; refine ⟨h1, ?_⟩; rw [h1]; push_cast; omega
+      · right; refine ⟨h3, ?_⟩; rw [h3]; omega
+    rw [Finset.mul_sum, ← Finset.sum_filter_add_sum_filter_not S0 (fun v => v.ord (jBar N) = 1)]
+    rw [← Finset.sum_filter_add_sum_filter_not S0 (fun v => v.ord (jBar N) = 1)] at hψ₀
+    have hA : ∑ v ∈ S0.filter (fun v => v.ord (jBar N) = 1), 3 * recipe N m v
+        = 3 * ((2 * m / 3 : ℕ) : ℤ) * ((S0.filter fun v => v.ord (jBar N) = 1).card : ℤ) := by
+      rw [Finset.sum_congr rfl (g := fun _ => 3 * ((2 * m / 3 : ℕ) : ℤ)) (fun v hv => ?_)]
+      · rw [Finset.sum_const, nsmul_eq_mul]; ring
+      · obtain ⟨hv, h1⟩ := Finset.mem_filter.mp hv
+        rcases hcase v hv with ⟨-, hr⟩ | ⟨h3, -⟩
+        · rw [hr]
+        · omega
+    have hB : ∑ v ∈ S0.filter (fun v => ¬ v.ord (jBar N) = 1), 3 * recipe N m v
+        = 6 * (m : ℤ) * ((S0.filter fun v => ¬ v.ord (jBar N) = 1).card : ℤ) := by
+      rw [Finset.sum_congr rfl (g := fun _ => 6 * (m : ℤ)) (fun v hv => ?_)]
+      · rw [Finset.sum_const, nsmul_eq_mul]; ring
+      · obtain ⟨hv, h1⟩ := Finset.mem_filter.mp hv
+        rcases hcase v hv with ⟨h1', -⟩ | ⟨-, hr⟩
+        · exact absurd h1' h1
+        · rw [hr]; ring
+    have hψA : ∑ v ∈ S0.filter (fun v => v.ord (jBar N) = 1), v.ord (jBar N)
+        = ((S0.filter fun v => v.ord (jBar N) = 1).card : ℤ) := by
+      rw [Finset.sum_congr rfl (g := fun _ => (1 : ℤ)) (fun v hv => (Finset.mem_filter.mp hv).2)]
+      rw [Finset.sum_const, nsmul_eq_mul, mul_one]
+    have hψB : ∑ v ∈ S0.filter (fun v => ¬ v.ord (jBar N) = 1), v.ord (jBar N)
+        = 3 * ((S0.filter fun v => ¬ v.ord (jBar N) = 1).card : ℤ) := by
+      rw [Finset.sum_congr rfl (g := fun _ => (3 : ℤ)) (fun v hv => ?_)]
+      · rw [Finset.sum_const, nsmul_eq_mul, mul_comm]
+      · obtain ⟨hv, h1⟩ := Finset.mem_filter.mp hv
+        rcases hcase v hv with ⟨h1', -⟩ | ⟨h3, -⟩
+        · exact absurd h1' h1
+        · exact h3
+    rw [hA, hB]
+    rw [hψA, hψB] at hψ₀
+    linear_combination (2 * (m : ℤ)) * hψ₀
+  have hsum1 : 2 * ∑ v ∈ S1, recipe N m v
+      = 2 * ((m / 2 : ℕ) : ℤ) * ((S1.filter fun v => v.ord (jBar N - algebraMap ℚb 𝔽 1728) = 1).card
+        : ℤ)
+        + (m : ℤ) * ((dedekindPsi N : ℤ) - ((S1.filter fun v => v.ord (jBar N - algebraMap ℚb 𝔽
+          1728) = 1).card : ℤ)) := by
+    have hψ₁ : ∑ v ∈ S1, v.ord (jBar N - algebraMap ℚb 𝔽 1728) = (dedekindPsi N : ℤ) :=
+      sum_ord_jBar_sub_eq_dedekindPsi N 1728 hdeg S1 hS1
+    have hcase : ∀ v ∈ S1, (v.ord (jBar N - algebraMap ℚb 𝔽 1728) = 1 ∧ recipe N m v = ((m / 2 : ℕ)
+      : ℤ)) ∨
+        (v.ord (jBar N - algebraMap ℚb 𝔽 1728) = 2 ∧ recipe N m v = (m : ℤ)) := by
+      intro v hv
+      have hpos := (hS1 v).1 hv
+      have hdvd := ord_jBar_sub_1728_dvd_two N v hpos
+      rw [recipe_of_pos_1728 N m hpos]
+      rcases int_eq_of_pos_of_dvd_two hpos hdvd with h1 | h2
+      · left; refine ⟨h1, ?_⟩; rw [h1]; push_cast; omega
+      · right; refine ⟨h2, ?_⟩; rw [h2]; omega
+    rw [Finset.mul_sum, ← Finset.sum_filter_add_sum_filter_not S1 (fun v => v.ord (jBar N -
+      algebraMap ℚb 𝔽 1728) = 1)]
+    rw [← Finset.sum_filter_add_sum_filter_not S1 (fun v => v.ord (jBar N - algebraMap ℚb 𝔽 1728) =
+      1)] at hψ₁
+    have hA : ∑ v ∈ S1.filter (fun v => v.ord (jBar N - algebraMap ℚb 𝔽 1728) = 1), 2 * recipe N m v
+        = 2 * ((m / 2 : ℕ) : ℤ) * ((S1.filter fun v => v.ord (jBar N - algebraMap ℚb 𝔽 1728) =
+          1).card : ℤ) := by
+      rw [Finset.sum_congr rfl (g := fun _ => 2 * ((m / 2 : ℕ) : ℤ)) (fun v hv => ?_)]
+      · rw [Finset.sum_const, nsmul_eq_mul]; ring
+      · obtain ⟨hv, h1⟩ := Finset.mem_filter.mp hv
+        rcases hcase v hv with ⟨-, hr⟩ | ⟨h2, -⟩
+        · rw [hr]
+        · omega
+    have hB : ∑ v ∈ S1.filter (fun v => ¬ v.ord (jBar N - algebraMap ℚb 𝔽 1728) = 1), 2 * recipe N m
+      v
+        = 2 * (m : ℤ) * ((S1.filter fun v => ¬ v.ord (jBar N - algebraMap ℚb 𝔽 1728) = 1).card : ℤ)
+          := by
+      rw [Finset.sum_congr rfl (g := fun _ => 2 * (m : ℤ)) (fun v hv => ?_)]
+      · rw [Finset.sum_const, nsmul_eq_mul]; ring
+      · obtain ⟨hv, h1⟩ := Finset.mem_filter.mp hv
+        rcases hcase v hv with ⟨h1', -⟩ | ⟨-, hr⟩
+        · exact absurd h1' h1
+        · rw [hr]
+    have hψA : ∑ v ∈ S1.filter (fun v => v.ord (jBar N - algebraMap ℚb 𝔽 1728) = 1), v.ord (jBar N -
+      algebraMap ℚb 𝔽 1728)
+        = ((S1.filter fun v => v.ord (jBar N - algebraMap ℚb 𝔽 1728) = 1).card : ℤ) := by
+      rw [Finset.sum_congr rfl (g := fun _ => (1 : ℤ)) (fun v hv => (Finset.mem_filter.mp hv).2)]
+      rw [Finset.sum_const, nsmul_eq_mul, mul_one]
+    have hψB : ∑ v ∈ S1.filter (fun v => ¬ v.ord (jBar N - algebraMap ℚb 𝔽 1728) = 1), v.ord (jBar N
+      - algebraMap ℚb 𝔽 1728)
+        = 2 * ((S1.filter fun v => ¬ v.ord (jBar N - algebraMap ℚb 𝔽 1728) = 1).card : ℤ) := by
+      rw [Finset.sum_congr rfl (g := fun _ => (2 : ℤ)) (fun v hv => ?_)]
+      · rw [Finset.sum_const, nsmul_eq_mul, mul_comm]
+      · obtain ⟨hv, h1⟩ := Finset.mem_filter.mp hv
+        rcases hcase v hv with ⟨h1', -⟩ | ⟨h2, -⟩
+        · exact absurd h1' h1
+        · exact h2
+    rw [hA, hB]
+    rw [hψA, hψB] at hψ₁
+    linear_combination (m : ℤ) * hψ₁
+  have hsumI : ∑ v ∈ Sinf, recipe N m v = -(m : ℤ) * (dedekindPsi N : ℤ) - (Sinf.card : ℤ) := by
+    have hψinf : ∑ v ∈ Sinf, -v.ord (jBar N) = (dedekindPsi N : ℤ) :=
+      sum_neg_ord_jBar_eq_dedekindPsi N Sinf hSI
+    rw [Finset.sum_congr rfl (g := fun v => -(m : ℤ) * (-v.ord (jBar N)) + (-1))
+      (fun v hv => by rw [recipe_of_neg N m ((hSI v).1 hv)]; ring)]
+    rw [Finset.sum_add_distrib, ← Finset.mul_sum, hψinf, Finset.sum_const, nsmul_eq_mul, mul_neg,
+      mul_one]
+    ring
+  have hNC : ∀ (P : Place ℚb 𝔽 → Prop) (T : Finset (Place ℚb 𝔽)),
+      (∀ v, v ∈ T ↔ P v) → Nat.card {v // P v} = T.card := by
+    intro P T hT
+    rw [Nat.card_congr (Equiv.subtypeEquivRight (fun v => (hT v).symm) : {v // P v} ≃ {v // v ∈ T}),
+      Nat.card_eq_fintype_card, Fintype.card_coe]
+  have h1728 : (jBar N - 1728 : 𝔽) = jBar N - algebraMap ℚb 𝔽 1728 := by rw [map_ofNat]
+  have hε₂ : (S1.filter fun v => v.ord (jBar N - algebraMap ℚb 𝔽 1728) = 1).card = nuTwo N := by
+    have h2 : ∀ v : Place ℚb 𝔽, 0 < v.ord (jBar N - 1728) → v.ord (jBar N - 1728) ∣ 2 :=
+      fun v hv => by
+      rw [h1728] at hv ⊢
+      exact ord_jBar_sub_1728_dvd_two N v hv
+    have hcount : Nat.card {v : Place ℚb 𝔽 // 0 < v.ord (jBar N - 1728)}
+        = Nat.card {x : ModuliPoint N ℚb // ModuliPoint.j x = (1728 : ℚb)} := by
+      rw [← card_eq_natCard_moduliPoint_j_eq_of_EMD N 1728 (emd_holds N 1728) S1 hS1]
+      exact hNC _ S1 (fun v => by rw [hS1, h1728])
+    have h := natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo N h2 hcount
+    rwa [hNC _ (S1.filter fun v => v.ord (jBar N - algebraMap ℚb 𝔽 1728) = 1)
+      (fun v => by
+        rw [Finset.mem_filter, hS1, h1728]
+        exact ⟨fun hv => hv.2, fun hv => ⟨by rw [hv]; exact one_pos, hv⟩⟩)] at h
+  have hε₃ : (S0.filter fun v => v.ord (jBar N) = 1).card = nuThree N := by
+    have h3 : ∀ v : Place ℚb 𝔽, 0 < v.ord (jBar N) → v.ord (jBar N) ∣ 3 :=
+      fun v hv => ord_jBar_dvd_three N v hv
+    have hcount : Nat.card {v : Place ℚb 𝔽 // 0 < v.ord (jBar N)}
+        = Nat.card {x : ModuliPoint N ℚb // ModuliPoint.j x = (0 : ℚb)} := by
+      rw [← card_eq_natCard_moduliPoint_j_eq_of_EMD N 0 (emd_holds N 0) S0 (fun v => by rw [hS0,
+        map_zero, sub_zero])]
+      exact hNC _ S0 (fun v => by rw [hS0])
+    have h := natCard_ord_jBar_eq_one_eq_nuThree N h3 hcount
+    rwa [hNC _ (S0.filter fun v => v.ord (jBar N) = 1)
+      (fun v => by
+        rw [Finset.mem_filter, hS0]
+        exact ⟨fun hv => hv.2, fun hv => ⟨by rw [hv]; exact one_pos, hv⟩⟩)] at h
+  have hcard : Sinf.card = cuspCount N :=
+    card_eq_cuspCount_of_forall_mem_iff_ord_jBar_neg N Sinf hSI
+  rw [hε₃] at hsum0
+  rw [hε₂] at hsum1
+  rw [hcard] at hsumI
+  set A0 : ℤ := ∑ v ∈ S0, recipe N m v with hA0
+  set A1 : ℤ := ∑ v ∈ S1, recipe N m v with hA1
+  set AI : ℤ := ∑ v ∈ Sinf, recipe N m v with hAI
+  have c0 : (3 : ℚ) * (A0 : ℚ) = 3 * ((2 * m / 3 : ℕ) : ℚ) * (nuThree N : ℚ)
+      + 2 * (m : ℚ) * ((dedekindPsi N : ℚ) - (nuThree N : ℚ)) := by
+    have h := congrArg (fun z : ℤ => (z : ℚ)) hsum0
+    simpa only [Int.cast_mul, Int.cast_add, Int.cast_sub, Int.cast_ofNat, Int.cast_natCast] using h
+  have c1 : (2 : ℚ) * (A1 : ℚ) = 2 * ((m / 2 : ℕ) : ℚ) * (nuTwo N : ℚ)
+      + (m : ℚ) * ((dedekindPsi N : ℚ) - (nuTwo N : ℚ)) := by
+    have h := congrArg (fun z : ℤ => (z : ℚ)) hsum1
+    simpa only [Int.cast_mul, Int.cast_add, Int.cast_sub, Int.cast_ofNat, Int.cast_natCast] using h
+  have cI : (AI : ℚ) = -(m : ℚ) * (dedekindPsi N : ℚ) - (cuspCount N : ℚ) := by
+    have h := congrArg (fun z : ℤ => (z : ℚ)) hsumI
+    simpa only [Int.cast_mul, Int.cast_add, Int.cast_sub, Int.cast_neg, Int.cast_ofNat,
+      Int.cast_natCast] using h
+  have eD : (D.degree : ℚ) = (A0 : ℚ) + (A1 : ℚ) + (AI : ℚ) := by
+    rw [hdegsum, hsplit]; push_cast; ring
+  unfold genusFormula
+  linear_combination eD + (1 / 3 : ℚ) * c0 + (1 / 2 : ℚ) * c1 + cI
+
+end ModularCurve.LDivDegree
+
+p2m_open "ModularCurve \
+  P2MW.S_ModularCurve_exists_divisor_degree_weight_and_isIntegral_of_mem_riemannRochSpace.ModularCu\
+  rve AlgebraicCurve"
+
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jBar modularFunctionFieldBar jq coeff_jq_neg_one dedekindPsi coeffEmb \
+  coeffEmb_coeff nuTwo nuThree cuspCount genusFormula EMD ModuliPoint ModuliPoint.j \
+  sum_ord_jBar_sub_eq_dedekindPsi deg_eq_one_modularFunctionFieldBar \
+  jCoordinate_spec_modularFunctionFieldBar sum_neg_ord_jBar_eq_dedekindPsi ord_jBar_dvd_three \
+  ord_jBar_sub_1728_dvd_two card_eq_cuspCount_of_forall_mem_iff_ord_jBar_neg \
+  natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo natCard_ord_jBar_eq_one_eq_nuThree \
+  card_eq_natCard_moduliPoint_j_eq_of_EMD emd_holds transcendental_coeffEmb_jq \
+  isCurveOver_modularFunctionFieldBar finiteDimensional_adjoin_coeffEmb_jq_of_neZero \
+  dedekindPsi_pos"
+namespace LDivIntegral
+p2m_open "ModularCurve"
+
+variable (N : ℕ) [NeZero N]
+
+theorem jBar_ne_zero : (jBar N : modularFunctionFieldBar N) ≠ 0 := by
+  intro h
+  have h2 : (coeffEmb (AlgebraicClosure ℚ) jq).coeff (-1) = 0 := by
+    have h1 : ((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ)) = 0 := by
+      rw [h]; rfl
+    have : (coeffEmb (AlgebraicClosure ℚ) jq) = 0 := h1
+    rw [this]; rfl
+  rw [coeffEmb_coeff, coeff_jq_neg_one, map_one] at h2
+  exact one_ne_zero h2
+
+section Generic
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem ord_pow' (v : Place K F) (f : F) (n : ℕ) : v.ord (f ^ n) = n * v.ord f := by
+  have := v.ord_zpow f (n : ℤ)
+  rwa [zpow_natCast] at this
+
+theorem ord_algebraMap (v : Place K F) {c : K} : v.ord (algebraMap K F c) = 0 := by
+  have h1 : 0 ≤ v.ord (algebraMap K F c) := v.ord_nonneg_of_mem (v.algebraMap_mem' c)
+  have h2 : 0 ≤ v.ord (algebraMap K F c⁻¹) := v.ord_nonneg_of_mem (v.algebraMap_mem' c⁻¹)
+  rw [map_inv₀, v.ord_inv] at h2
+  omega
+
+theorem ord_neg (v : Place K F) (f : F) : v.ord (-f) = v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · simp
+  have h1 : v.ord (-f) = v.ord (-1) + v.ord f := by
+    rw [← v.ord_mul (by norm_num) hf, neg_one_mul]
+  have h2 : v.ord ((-1 : F)) = 0 := by
+    have := v.ord_zpow (-1 : F) 2
+    norm_num at this
+    linarith
+  rw [h1, h2, zero_add]
+
+theorem six_mul_ediv_two_le (n : ℤ) : 6 * (n / 2) ≤ 3 * n := by
+  have := Int.ediv_mul_le n (by norm_num : (2 : ℤ) ≠ 0)
+  linarith
+
+theorem six_mul_ediv_three_le (n : ℤ) : 6 * (n / 3) ≤ 2 * n := by
+  have := Int.ediv_mul_le n (by norm_num : (3 : ℤ) ≠ 0)
+  linarith
+
+theorem two_mul_ediv_two_le (n : ℤ) : 2 * (n / 2) ≤ n := by
+  have := Int.ediv_mul_le n (by norm_num : (2 : ℤ) ≠ 0)
+  linarith
+
+end Generic
+
+theorem isIntegral_pair_of_mem_riemannRochSpace (m : ℕ)
+    (Dv : Divisor (AlgebraicClosure ℚ) (modularFunctionFieldBar N))
+    (hDfin : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 ≤ v.ord (jBar N) →
+      Dv v ≤ (m : ℤ) * v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+        1728) / 2
+        + 2 * (m : ℤ) * v.ord (jBar N) / 3)
+    (hDcusp : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), v.ord (jBar N) < 0 →
+      Dv v ≤ (m : ℤ) * v.ord (jBar N) - 1)
+    (x : modularFunctionFieldBar N) (hx : x ∈ riemannRochSpace Dv) :
+    IsIntegral (Algebra.adjoin (AlgebraicClosure ℚ) ({jBar N} : Set (modularFunctionFieldBar N)))
+        (x ^ 6 * jBar N ^ (4 * m)
+          * (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) 1728) ^ (3 * m)) ∧
+      IsIntegral (Algebra.adjoin (AlgebraicClosure ℚ) ({(jBar N)⁻¹} : Set (modularFunctionFieldBar
+        N)))
+        (x ^ (2 * dedekindPsi N) * jBar N ^ (m * dedekindPsi N + 1)
+          * (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) 1728) ^ (m *
+            dedekindPsi N)) := by
+  classical
+  have hCO := ModularCurve.isCurveOver_modularFunctionFieldBar N
+  have hFD : FiniteDimensional (IntermediateField.adjoin (AlgebraicClosure ℚ)
+      ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)))
+        (modularFunctionFieldBar N) :=
+    ModularCurve.finiteDimensional_adjoin_coeffEmb_jq_of_neZero N
+  have hPD : HasPrincipalDivisors (AlgebraicClosure ℚ) (modularFunctionFieldBar N) :=
+    IsCurveOver.hasPrincipalDivisors
+  set J : modularFunctionFieldBar N := jBar N with hJdef
+  set ψ : ℕ := dedekindPsi N with hψdef
+  set c1728 : modularFunctionFieldBar N := algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar
+    N) 1728
+    with hc
+  have hψpos : 0 < ψ := ModularCurve.dedekindPsi_pos N (NeZero.ne N)
+  have hJ0 : J ≠ 0 := jBar_ne_zero N
+  by_cases hx0 : x = 0
+  · subst hx0
+    refine ⟨?_, ?_⟩
+    · rw [zero_pow (by norm_num), zero_mul, zero_mul]; exact isIntegral_zero
+    · rw [zero_pow (by omega), zero_mul, zero_mul]; exact isIntegral_zero
+  have hxord : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), -Dv v ≤ v.ord x := by
+    intro v
+    rcases (mem_riemannRochSpace_iff.mp hx) v with h | h
+    · exact absurd h hx0
+    · exact h
+  obtain ⟨Dj, hDj, -⟩ := HasPrincipalDivisors.exists_divisor (K := AlgebraicClosure ℚ)
+    (F := modularFunctionFieldBar N) J hJ0
+  let S : Finset (Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) :=
+    Dj.support.filter (fun v => v.ord J < 0)
+  have hS : ∀ v, v ∈ S ↔ v.ord J < 0 := by
+    intro v
+    simp only [S, Finset.mem_filter, Finsupp.mem_support_iff, and_iff_right_iff_imp]
+    intro hv
+    rw [hDj v]
+    exact hv.ne
+  have hsum : ∑ v ∈ S, -v.ord J = (ψ : ℤ) := by
+    have := ModularCurve.sum_neg_ord_jBar_eq_dedekindPsi N S hS
+    exact_mod_cast this
+  have hwidth : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), v.ord J < 0 → -v.ord J
+    ≤ (ψ : ℤ) :=
+    by
+    intro v hv
+    rw [← hsum]
+    exact Finset.single_le_sum (f := fun w => -w.ord J)
+      (fun w hw => by have := (hS w).mp hw; change (0 : ℤ) ≤ -w.ord J; omega) ((hS v).mpr hv)
+  have hpole : ∃ v₀ : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), v₀.ord J < 0 := by
+    by_contra hno
+    push Not at hno
+    have hSe : S = ∅ := by
+      ext v
+      simp only [Finset.notMem_empty, iff_false]
+      intro hv
+      exact absurd ((hS v).mp hv) (not_lt.mpr (hno v))
+    rw [hSe, Finset.sum_empty] at hsum
+    have h' : (ψ : ℤ) = 0 := hsum.symm
+    omega
+  obtain ⟨v₀, hv₀⟩ := hpole
+  have htr : Transcendental (AlgebraicClosure ℚ) J := by
+    intro halg
+    have hint : IsIntegral (AlgebraicClosure ℚ) J := halg.isIntegral
+    have hint' : IsIntegral v₀.toValuationSubring J := hint.tower_top
+    have hmem : J ∈ v₀.toValuationSubring := by
+      obtain ⟨y, hy⟩ := (IsIntegrallyClosed.isIntegral_iff (R := v₀.toValuationSubring)
+        (K := modularFunctionFieldBar N)).mp hint'
+      rw [← hy]
+      exact y.2
+    have := v₀.ord_nonneg_of_mem hmem
+    omega
+  have h1728ne : (1728 : AlgebraicClosure ℚ) ≠ 0 := by norm_num
+  have hJne1728 : J - c1728 ≠ 0 := by
+    intro h
+    rw [sub_eq_zero] at h
+    have := ord_algebraMap v₀ (c := (1728 : AlgebraicClosure ℚ))
+    rw [hc] at h
+    rw [← h] at this
+    omega
+  have hordJsub_of_neg : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), v.ord J < 0 →
+      v.ord (J - c1728) = v.ord J := by
+    intro v hv
+    have hc0 : v.ord (-c1728) = 0 := by rw [ord_neg]; exact ord_algebraMap v
+    have := v.ord_add_eq_of_lt (f := J) (g := -c1728) hJ0
+      (neg_ne_zero.mpr (by rw [hc, Ne, map_eq_zero]; norm_num)) (by rw [hc0]; exact hv)
+    rwa [← sub_eq_add_neg] at this
+  have hordJsub_nonneg : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 ≤ v.ord J →
+      0 ≤ v.ord (J - c1728) := by
+    intro v hv
+    have hJmem : J ∈ v.toValuationSubring := (v.mem_iff_ord_nonneg hJ0).mpr hv
+    exact v.ord_nonneg_of_mem (sub_mem hJmem (v.algebraMap_mem' _))
+  refine ⟨?_, ?_⟩
+  · refine AlgebraicCurve.isIntegral_adjoin_of_forall_ord_nonneg (K := AlgebraicClosure ℚ)
+      (F := modularFunctionFieldBar N) J _ ?_
+    intro v hvJ
+    have ha := hordJsub_nonneg v hvJ
+    have hD := hDfin v hvJ
+    have hxv := hxord v
+    rw [v.ord_mul (mul_ne_zero (pow_ne_zero _ hx0) (pow_ne_zero _ hJ0)) (pow_ne_zero _ hJne1728),
+      v.ord_mul (pow_ne_zero _ hx0) (pow_ne_zero _ hJ0), ord_pow', ord_pow', ord_pow']
+    have h2 := six_mul_ediv_two_le ((m : ℤ) * v.ord (J - c1728))
+    have h3 := six_mul_ediv_three_le (2 * (m : ℤ) * v.ord J)
+    push_cast
+    nlinarith
+  · have htr' : Transcendental (AlgebraicClosure ℚ) J⁻¹ := by
+      intro halg
+      exact htr (by simpa using halg.inv)
+    have hadj : IntermediateField.adjoin (AlgebraicClosure ℚ) ({J⁻¹} : Set (modularFunctionFieldBar
+      N))
+        = IntermediateField.adjoin (AlgebraicClosure ℚ) ({J} : Set (modularFunctionFieldBar N))
+          := by
+      apply le_antisymm
+      · rw [IntermediateField.adjoin_simple_le_iff]
+        exact inv_mem (IntermediateField.mem_adjoin_simple_self (AlgebraicClosure ℚ) J)
+      · rw [IntermediateField.adjoin_simple_le_iff]
+        have h1 := IntermediateField.mem_adjoin_simple_self (AlgebraicClosure ℚ) (J⁻¹)
+        have h2 : (J⁻¹)⁻¹ ∈ IntermediateField.adjoin (AlgebraicClosure ℚ) ({J⁻¹} : Set
+          (modularFunctionFieldBar N)) :=
+          inv_mem h1
+        rwa [inv_inv] at h2
+    have : FiniteDimensional (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({J⁻¹} : Set (modularFunctionFieldBar N))) (modularFunctionFieldBar N) := by
+      rw [hadj]; exact hFD
+    refine AlgebraicCurve.isIntegral_adjoin_of_forall_ord_nonneg (K := AlgebraicClosure ℚ)
+      (F := modularFunctionFieldBar N) J⁻¹ _ ?_
+    intro v hvJinv
+    rw [v.ord_inv] at hvJinv
+    have hvJ : v.ord J ≤ 0 := by omega
+    rw [v.ord_mul (mul_ne_zero (pow_ne_zero _ hx0) (pow_ne_zero _ hJ0)) (pow_ne_zero _ hJne1728),
+      v.ord_mul (pow_ne_zero _ hx0) (pow_ne_zero _ hJ0), ord_pow', ord_pow', ord_pow']
+    have hxv := hxord v
+    rcases hvJ.lt_or_eq with hneg | hzero
+    · have hw := hwidth v hneg
+      have hD := hDcusp v hneg
+      rw [hordJsub_of_neg v hneg]
+      have hψ1 : (1 : ℤ) ≤ ψ := by exact_mod_cast hψpos
+      push_cast
+      have hx1 : 1 - (m : ℤ) * v.ord J ≤ v.ord x := by linarith
+      nlinarith [mul_le_mul_of_nonneg_left hx1 (by positivity : (0 : ℤ) ≤ 2 * (ψ : ℤ))]
+    · have ha := hordJsub_nonneg v hzero.ge
+      have hD := hDfin v hzero.ge
+      rw [hzero, mul_zero, Int.zero_ediv, add_zero] at hD
+      have h2 := two_mul_ediv_two_le ((m : ℤ) * v.ord (J - c1728))
+      rw [hzero]
+      push_cast
+      nlinarith [mul_le_mul_of_nonneg_left (show -( (m : ℤ) * v.ord (J - c1728) / 2) ≤ v.ord x by
+        linarith)
+        (by positivity : (0 : ℤ) ≤ 2 * (ψ : ℤ))]
+
+end ModularCurve.LDivIntegral
+
+end
+
+theorem solution (N : ℕ) [NeZero N] (m : ℕ) (hm : 1 ≤ m) :
+    ∃ D : AlgebraicCurve.Divisor (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar N),
+      ((D.degree : ℚ) + 1 - ModularCurve.genusFormula N =
+        (2 * (m : ℚ) - 1) * (ModularCurve.genusFormula N - 1) + ((m / 2 : ℕ) : ℚ) *
+          (ModularCurve.nuTwo N : ℚ)
+          + ((2 * m / 3 : ℕ) : ℚ) * (ModularCurve.nuThree N : ℚ) + ((m : ℚ) - 1) *
+            (ModularCurve.cuspCount N : ℚ)) ∧
+      ∀ x : ↥(ModularCurve.modularFunctionFieldBar N), x ∈ AlgebraicCurve.riemannRochSpace D →
+        IsIntegral (Algebra.adjoin (AlgebraicClosure ℚ) ({ModularCurve.jBar N} : Set
+          ↥(ModularCurve.modularFunctionFieldBar N)))
+            (x ^ 6 * ModularCurve.jBar N ^ (4 * m) * (ModularCurve.jBar N - algebraMap
+              (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar N) 1728) ^ (3 * m)) ∧
+          IsIntegral (Algebra.adjoin (AlgebraicClosure ℚ) ({(ModularCurve.jBar N)⁻¹} : Set
+            ↥(ModularCurve.modularFunctionFieldBar N)))
+              (x ^ (2 * ModularCurve.dedekindPsi N) * ModularCurve.jBar N ^ (m *
+                ModularCurve.dedekindPsi N + 1) *
+              (ModularCurve.jBar N - algebraMap (AlgebraicClosure ℚ)
+                ↥(ModularCurve.modularFunctionFieldBar N) 1728) ^ (m * ModularCurve.dedekindPsi N))
+                := by
+  have hm_copy := hm
+  clear hm_copy
+  obtain ⟨D, hdeg, hDfin, hDcusp⟩ := ModularCurve.LDivDegree.exists_weightDivisor N m
+  exact ⟨D, hdeg, fun x hx =>
+    ModularCurve.LDivIntegral.isIntegral_pair_of_mem_riemannRochSpace N m D hDfin hDcusp x hx⟩
+
+end S_ModularCurve_exists_divisor_degree_weight_and_isIntegral_of_mem_riemannRochSpace
+end P2MW
+export P2MW.S_ModularCurve_exists_divisor_degree_weight_and_isIntegral_of_mem_riemannRochSpace
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.exists_divisor_degree_weight_and_isIntegral_of_mem_riemannRochSpace (N : ℕ)
+    [NeZero N] (m : ℕ) (hm : 1 ≤ m) :
+    ∃ D : AlgebraicCurve.Divisor (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar N),
+      ((D.degree : ℚ) + 1 - ModularCurve.genusFormula N =
+        (2 * (m : ℚ) - 1) * (ModularCurve.genusFormula N - 1) + ((m / 2 : ℕ) : ℚ) *
+          (ModularCurve.nuTwo N : ℚ)
+          + ((2 * m / 3 : ℕ) : ℚ) * (ModularCurve.nuThree N : ℚ) + ((m : ℚ) - 1) *
+            (ModularCurve.cuspCount N : ℚ)) ∧
+      ∀ x : ↥(ModularCurve.modularFunctionFieldBar N), x ∈ AlgebraicCurve.riemannRochSpace D →
+        IsIntegral (Algebra.adjoin (AlgebraicClosure ℚ) ({ModularCurve.jBar N} : Set
+          ↥(ModularCurve.modularFunctionFieldBar N)))
+            (x ^ 6 * ModularCurve.jBar N ^ (4 * m) * (ModularCurve.jBar N - algebraMap
+              (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar N) 1728) ^ (3 * m)) ∧
+          IsIntegral (Algebra.adjoin (AlgebraicClosure ℚ) ({(ModularCurve.jBar N)⁻¹} : Set
+            ↥(ModularCurve.modularFunctionFieldBar N)))
+            (x ^ (2 * ModularCurve.dedekindPsi N) * ModularCurve.jBar N ^ (m *
+              ModularCurve.dedekindPsi N + 1) *
+              (ModularCurve.jBar N - algebraMap (AlgebraicClosure ℚ)
+                ↥(ModularCurve.modularFunctionFieldBar N) 1728) ^ (m * ModularCurve.dedekindPsi N))
+                :=
+  solution N m hm
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_divisor_two_mul_eq_ord_add_weightFloor_one_laurentBaseChange_gamma1.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_divisor_two_mul_eq_ord_add_weightFloor_one_laurentBaseChange_gamma1.lean
new file mode 100644
index 0000000000..0aec34891d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_divisor_two_mul_eq_ord_add_weightFloor_one_laurentBaseChange_gamma1.lean
@@ -0,0 +1,193 @@
+/-
+Based on Prove2Me node
+ModularCurve.exists_divisor_two_mul_eq_ord_add_weightFloor_one_laurentBaseChange_gamma1
+(999eb0f0-c36f-54fe-9d6f-784051a0f2d8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4f37cd1a-11d8-50da-ac64-2fff07b58792
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QExpansionDiff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_add_eq_of_lt
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_divisor_forall_eq_weightFloor
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_even_ord_add_ord_of_not_mem_toValuationSubring_laurentBaseChange_gamma1
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_even_ord_add_weightFloor_of_mem_toValuationSubring_laurentBaseChange_gamma1
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCurveOver_laurentBaseChange_qExpFunctionFieldC_gamma1
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Divisor of a weight-one form on X₁(M), M≥ 5
+
+Theorem statement:
+`ModularCurve.exists_divisor_two_mul_eq_ord_add_weightFloor_one_laurentBaseChange_gamma1`
+(`999eb0f0-c36f-54fe-9d6f-784051a0f2d8`), by Claude, 2026-09-05.
+
+Proof: submission `4f37cd1a-11d8-50da-ac64-2fff07b58792`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a natural number with $5 \le M$, and let $F$ denote the intermediate field
+[`ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1
+M))`](def/ModularCurve_LaurentCoeff.html#L103) of $\mathbb{C}((q))$: that is, the subfield generated
+over $\mathbb{C}$ by the coefficientwise images under $\mathbb{Q} \to \mathbb{C}$ of the subfield of
+$\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by the ratios $p_f/p_g$ of integral $q$-expansions of
+modular forms $f, g$ of a common weight for $\Gamma_1(M)$ (with $p_g \neq 0$ in the Laurent series
+field). Assume given: an element $y \in F$ whose underlying Laurent series is [`ModularCurve.jqModC
+ℂ`](def/ModularCurve_JqCoeff.html#L15), namely $q^{-1}$ times the power series $E_4^3 \cdot
+\eta^{-24}$ over $\mathbb{C}$, so the $q$-expansion of $j$; a nonzero modular form $w$ of weight $1$
+for $\Gamma_1(M)$; and an element $v \in F$ such that, in $\mathbb{C}((q))$, the product of $v$ with
+$\vartheta(j(q)) = q\,\frac{d}{dq} j(q)$ equals the square of the $q$-expansion of $w$. The
+conclusion asserts the existence of a divisor $D$ — a finitely supported $\mathbb{Z}$-valued
+function on the places of $F/\mathbb{C}$ — such that for every place $P$, with
+$\operatorname{ord}_P$ the normalised valuation attached to $P$, $$2\,D(P) = \operatorname{ord}_P(v)
++ \Big(\big[\tfrac{2\operatorname{ord}_P(y)}{3}\big] \text{ if } \operatorname{ord}_P(y) > 0\Big) +
+\Big(\big[\tfrac{\operatorname{ord}_P(y - 1728)}{2}\big] \text{ if } \operatorname{ord}_P(y-1728) >
+0\Big) + \Big(\operatorname{ord}_P(y) \text{ if } \operatorname{ord}_P(y) < 0\Big),$$ the integer
+divisions being rounded towards $-\infty$ as in `Int` division, and each bracketed term being $0$
+when its condition fails.
+
+This is the statement that the divisor of a nonzero weight-one form on $X_1(M)$ for $M \ge 5$ is
+integral: the right-hand side, which is $\operatorname{div}(v) + \operatorname{div}(\vartheta j)$
+written through the weight-floor recipe at $m = 1$, is divisible by $2$ at every place, reflecting
+the absence of elliptic points for $M \ge 4$ and the regularity of all cusps for $M \ge 5$. It feeds
+the dimension estimate for spaces of weight-one forms on $\Gamma_1(M)$ used in
+[`ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_odd`]
+(thm.html#ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_odd).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_divisor_two_mul_eq_ord_add_weightFloor_one_laurentBaseChange_gamma1.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_4bc05415
+
+
+open CongruenceSubgroup ModularCurve
+open scoped MatrixGroups ModularForm
+
+namespace O2Asm
+
+theorem ord_const {K F : Type*} [Field K] [Field F] [Algebra K F] (P : AlgebraicCurve.Place K F)
+    {c : K} (hc : c ≠ 0) : P.ord (algebraMap K F c) = 0 := by
+  have hu : IsUnit (⟨algebraMap K F c, P.algebraMap_mem' c⟩ : P.toValuationSubring) :=
+    ⟨⟨⟨algebraMap K F c, P.algebraMap_mem' c⟩, ⟨algebraMap K F c⁻¹, P.algebraMap_mem' c⁻¹⟩,
+      Subtype.ext (by simpa using mul_inv_cancel₀ ((map_ne_zero (algebraMap K F)).mpr hc)),
+      Subtype.ext (by simpa using inv_mul_cancel₀ ((map_ne_zero (algebraMap K F)).mpr hc))⟩, rfl⟩
+  obtain ⟨u, hu⟩ := hu
+  have := P.ord_coe_unit u
+  rwa [hu] at this
+
+end O2Asm
+
+theorem solution
+    (M : ℕ) [NeZero M] (hM : 5 ≤ M)
+    (y : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))))
+    (hy : (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ)
+    (w : ModularForm (Gamma1 M) 1) (hw : w ≠ 0)
+    (v : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))))
+    (hv : (v : LaurentSeries ℂ) * ModularCurve.thetaL ℂ (ModularCurve.jqModC ℂ) =
+      HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 w) ^ 2) :
+    ∃ D : AlgebraicCurve.Divisor ℂ
+        ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+          (CongruenceSubgroup.Gamma1 M))),
+      ∀ P : AlgebraicCurve.Place ℂ
+        ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+          (CongruenceSubgroup.Gamma1 M))),
+        2 * D P = P.ord v +
+          ((if 0 < P.ord y then (2 * P.ord y) / 3 else 0)
+            + (if 0 < P.ord (y - 1728) then (P.ord (y - 1728)) / 2 else 0)
+            + (if P.ord y < 0 then P.ord y else 0)) := by
+  classical
+  have := ModularCurve.isCurveOver_laurentBaseChange_qExpFunctionFieldC_gamma1 ℂ M
+  obtain ⟨W, hW⟩ := AlgebraicCurve.exists_divisor_forall_eq_weightFloor ℂ y 1
+  obtain ⟨Dv, hDv⟩ : ∃ Dv : AlgebraicCurve.Divisor ℂ
+      ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+        (CongruenceSubgroup.Gamma1 M))),
+      ∀ P, Dv P = P.ord v := by
+    rcases eq_or_ne v 0 with h0 | h0
+    · exact ⟨0, fun P => by simp [h0]⟩
+    · obtain ⟨D, hD, -⟩ := AlgebraicCurve.HasPrincipalDivisors.exists_divisor (K := ℂ) v h0
+      exact ⟨D, hD⟩
+  refine ⟨(Dv + W).mapRange (fun n => n / 2) (by simp), fun P => ?_⟩
+  rw [Finsupp.mapRange_apply, Finsupp.add_apply, hDv P, hW P]
+  simp only [Nat.cast_one, mul_one, one_mul]
+  apply Int.two_mul_ediv_two_of_even
+  by_cases hP : y ∈ P.toValuationSubring
+  · exact ModularCurve.even_ord_add_weightFloor_of_mem_toValuationSubring_laurentBaseChange_gamma1 M
+      (by omega) y hy w hw v hv P hP
+  · have h2 :=
+      ModularCurve.even_ord_add_ord_of_not_mem_toValuationSubring_laurentBaseChange_gamma1 M hM
+      y hy w hw v hv P hP
+    have hy0 : y ≠ 0 := fun h => hP (h ▸ zero_mem _)
+    have hneg : P.ord y < 0 := by
+      by_contra hge
+      exact hP (AlgebraicCurve.Place.mem_of_ord_nonneg P hy0 (not_lt.1 hge))
+    have e1728 : (1728 : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M)))) =
+        algebraMap ℂ _ 1728 := (map_ofNat (algebraMap ℂ _) 1728).symm
+    have hc : P.ord (algebraMap ℂ _ (-1728)) = 0 := O2Asm.ord_const P (by norm_num)
+    have hc0 : algebraMap ℂ (↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))))
+        (-1728) ≠ 0 := (map_ne_zero _).2 (by norm_num)
+    have h1728 : P.ord (y - 1728) = P.ord y := by
+      rw [e1728, sub_eq_add_neg, ← map_neg]
+      exact AlgebraicCurve.Place.ord_add_eq_of_lt P hy0 hc0 (by rw [hc]; exact hneg)
+    rw [ite_eq_right (not_lt.2 hneg.le), ite_eq_right (by
+      rw [h1728]; exact not_lt.2 hneg.le), ite_eq_left hneg,
+      zero_add, zero_add]
+    exact h2
+
+end S_OVERLONG_4bc05415
+end P2MW
+export
+  P2MW.S_OVERLONG_4bc05415
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open CongruenceSubgroup ModularCurve
+open scoped MatrixGroups ModularForm
+theorem ModularCurve.exists_divisor_two_mul_eq_ord_add_weightFloor_one_laurentBaseChange_gamma1
+    (M : ℕ) [NeZero M] (hM : 5 ≤ M)
+    (y : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))))
+    (hy : (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ)
+    (w : ModularForm (Gamma1 M) 1) (hw : w ≠ 0)
+    (v : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))))
+    (hv : (v : LaurentSeries ℂ) * ModularCurve.thetaL ℂ (ModularCurve.jqModC ℂ) =
+      HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 w) ^ 2) :
+    ∃ D : AlgebraicCurve.Divisor ℂ
+        ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+          (CongruenceSubgroup.Gamma1 M))),
+      ∀ P : AlgebraicCurve.Place ℂ
+        ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+          (CongruenceSubgroup.Gamma1 M))),
+        2 * D P = P.ord v +
+          ((if 0 < P.ord y then (2 * P.ord y) / 3 else 0)
+            + (if 0 < P.ord (y - 1728) then (P.ord (y - 1728)) / 2 else 0)
+            + (if P.ord y < 0 then P.ord y else 0)) :=
+  solution M hM y hy w hw v hv
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_elliptic_cycSub_orbitMap.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_elliptic_cycSub_orbitMap.lean
new file mode 100644
index 0000000000..ff128896a7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_elliptic_cycSub_orbitMap.lean
@@ -0,0 +1,120 @@
+/-
+Based on Prove2Me node ModularCurve.exists_elliptic_cycSub_orbitMap
+(8e627a00-a37e-5883-bb5b-3a4df6f1fea6) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 874c4d8b-5958-5ccb-a5cf-647f535f6e9c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EMD
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_MazurStepThreeInputs
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CycSubRootBridgeN
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_SpecialisationBridge
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_elliptic_cycSub_orbitMap_of_props
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_TatePoint_fullKernelIsRootAt
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_TatePoint_fullKernelInjAt
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_TatePoint_fullKernelDiscAt
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_TatePoint_b3Act_dictN_of_monodromy
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Places above j₀ and orbits of cyclic N-subgroups
+
+Theorem statement: `ModularCurve.exists_elliptic_cycSub_orbitMap`
+(`8e627a00-a37e-5883-bb5b-3a4df6f1fea6`), by Claude, 2026-09-05.
+
+Proof: submission `874c4d8b-5958-5ccb-a5cf-647f535f6e9c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a positive natural number and let $j_0$ be an element of $\overline{\mathbb{Q}} =$
+`AlgebraicClosure ℚ`. The assertion is that there exist a Weierstrass curve $E_0$ over
+$\overline{\mathbb{Q}}$ which is elliptic (its discriminant is invertible) and has $j$-invariant
+$j_0$, and a map $f$ from `CycSub E₀ N`, the set of subgroups of the group of affine points of $E_0$
+of the form $\langle g\rangle$ for some point $g$ of additive order exactly $N$, to the set of those
+places $w$ of the extension $\overline{\mathbb{Q}} \subseteq$ `modularFunctionFieldBar N` — a
+valuation subring, not the whole field, containing the constants and a principal ideal ring — at
+which $\operatorname{ord}_w(\bar\jmath_N - j_0) > 0$, where `modularFunctionFieldBar N` is the
+subfield of $\overline{\mathbb{Q}}$-Laurent series generated over $\overline{\mathbb{Q}}$ by the
+coefficientwise images of the level-$N$ divisor expansions, $\bar\jmath_N$ is the coefficientwise
+image of the $q$-expansion of $j$, and $\operatorname{ord}_w$ is minus the logarithm of the
+associated height-one-spectrum valuation. The map $f$ satisfies: $f(H) = f(H')$ holds if and only if
+`SameOrbit E₀ H H'`, i.e. there is a variable change $\gamma$ fixing $E_0$ and generators $g$ of
+$H$, $g'$ of $H'$ with $g'$ the image of $g$ under the induced map `Point.vcInvFun` on points; and
+for every such place $w$ the natural number $\operatorname{ord}_w(\bar\jmath_N - j_0)$ equals the
+cardinality of the fibre $f^{-1}(w)$.
+
+This is the local comparison, above a single value $j_0$ of the $j$-line, between the places of the
+level-$N$ modular function field over $\overline{\mathbb{Q}}$ and the orbits of cyclic subgroups of
+order $N$ on an elliptic curve with $j$-invariant $j_0$, the order of vanishing of $j - j_0$ at a
+place matching the size of the corresponding orbit. It is used in the proof of
+[`ModularCurve.emd_holds`](thm.html#ModularCurve.emd_holds) and of
+[`ModularCurve.ord_jBar_sub_eq_one_of_ne_zero_of_ne`]
+(thm.html#ModularCurve.ord_jBar_sub_eq_one_of_ne_zero_of_ne),
+which extracts unramifiedness away from the exceptional $j$-invariants.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_elliptic_cycSub_orbitMap.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_elliptic_cycSub_orbitMap
+
+open ModularCurve AlgebraicCurve
+
+theorem solution (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ) :
+    ∃ (E₀ : WeierstrassCurve (AlgebraicClosure ℚ)) (_ : E₀.IsElliptic), E₀.j = j₀ ∧
+      ∃ f : CycSub E₀ N →
+          {w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+            0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)},
+        (∀ H H' : CycSub E₀ N, f H = f H' ↔ SameOrbit E₀ H.1 H'.1) ∧
+        ∀ w : {w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+            0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)},
+          ((w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)).ord
+              (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)).toNat =
+            Nat.card {H : CycSub E₀ N // f H = w} :=
+  ModularCurve.exists_elliptic_cycSub_orbitMap_of_props N j₀
+    (ModularCurve.TatePoint.fullKernelIsRootAt N) (ModularCurve.TatePoint.fullKernelInjAt N)
+    (ModularCurve.TatePoint.fullKernelDiscAt N)
+    (ModularCurve.TatePoint.b3Act_dictN_of_monodromy N j₀ (ModularCurve.TatePoint.fullKernelIsRootAt
+      N)
+      (ModularCurve.TatePoint.fullKernelInjAt N) (ModularCurve.TatePoint.fullKernelDiscAt N))
+
+end S_ModularCurve_exists_elliptic_cycSub_orbitMap
+end P2MW
+export P2MW.S_ModularCurve_exists_elliptic_cycSub_orbitMap (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.exists_elliptic_cycSub_orbitMap (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ) :
+    ∃ (E₀ : WeierstrassCurve (AlgebraicClosure ℚ)) (_ : E₀.IsElliptic), E₀.j = j₀ ∧
+      ∃ f : CycSub E₀ N →
+          {w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+            0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)},
+        (∀ H H' : CycSub E₀ N, f H = f H' ↔ SameOrbit E₀ H.1 H'.1) ∧
+        ∀ w : {w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+            0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)},
+          ((w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)).ord
+              (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)).toNat =
+            Nat.card {H : CycSub E₀ N // f H = w} :=
+  solution N j₀
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_elliptic_cycSub_orbitMap_of_props.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_elliptic_cycSub_orbitMap_of_props.lean
new file mode 100644
index 0000000000..a0619575b8
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_elliptic_cycSub_orbitMap_of_props.lean
@@ -0,0 +1,366 @@
+/-
+Based on Prove2Me node ModularCurve.exists_elliptic_cycSub_orbitMap_of_props
+(811921d2-90aa-56b7-ab76-d4434088f061) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8378e0da-1b37-505b-bc01-69fdc4656766
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EMD
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_MazurStepThreeInputs
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CycSubRootBridgeN
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_SpecialisationBridge
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_TatePoint
+import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_Monodromy
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_place_of_emb
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_samePlace_iff_exists_monodromy
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_normalized_algHom_jBar_eq_toNat_ord
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_place_eq_of_induces
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_emb_equiv_rootsAt
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_modularPolynomialData
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_B3_specialisationEquivariance_level
+import Mathlib.RingTheory.HahnSeries.PowerSeries
+import Mathlib.SetTheory.Cardinal.Finite
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Orbit correspondence for cyclic N-subgroups over a given j₀
+
+Theorem statement: `ModularCurve.exists_elliptic_cycSub_orbitMap_of_props`
+(`811921d2-90aa-56b7-ab76-d4434088f061`), by Claude, 2026-09-05.
+
+Proof: submission `8378e0da-1b37-505b-bc01-69fdc4656766`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a nonzero natural number $N$ and an element $j_0$ of $\overline{\mathbb{Q}}$, and write $H =
+\mathrm{HahnSeries}\,\mathbb{Q}\,\overline{\mathbb{Q}}$ for the field of Hahn series with rational
+exponents. Four hypotheses are assumed. `FullKernelIsRootAt N`: for every elliptic Weierstrass curve
+$W$ over $H$, every affine point $Q$ of exact additive order $N$ whose full-kernel quotient
+`W.fullKernelQuotient Q N` has nonzero discriminant, and every `ModularPolynomialData N` (a monic
+$\Phi \in \mathbb{Z}[X][Y]$ of degree $\psi(N)$ annihilating the pair of $q$-expansions), the
+$j$-invariant of that quotient is a root of $\Phi$ specialised at $j(W)$. `FullKernelInjAt N`: if
+$j(W)$ is transcendental over $\mathbb{Q}$ and $Q,Q'$ have exact order $N$ with quotients of nonzero
+discriminant and equal $j$-invariants, then $\langle Q\rangle = \langle Q'\rangle$.
+`FullKernelDiscAt N`: over any algebraically closed field in which $2 \neq 0$, such quotients have
+nonzero discriminant. Finally, equivariance: for each `ModularPolynomialData N`, each element $m$ of
+the monodromy group of $H$, and all roots $r,r'$ of $\Phi$ specialised at the $j$-invariant of
+`nearCurve j₀` with $r' = m(r)$, the push-forward `B3.b3Act j₀ m` along `nearTransport j₀ m` sends
+the subgroup attached to $r$ by `dictN` to that attached to $r'$. The conclusion: there is an
+elliptic curve $E_0$ over $\overline{\mathbb{Q}}$ with $j(E_0) = j_0$ and a map $f$ from `CycSub E₀
+N`, the subgroups of $E_0$'s affine point group of the form $\langle g\rangle$ with $g$ of exact
+order $N$, to the places $w$ of `modularFunctionFieldBar N` over $\overline{\mathbb{Q}}$ (valuation
+subrings containing $\overline{\mathbb{Q}}$, proper, principal) with $\mathrm{ord}_w(\bar{j} - j_0)
+> 0$, such that $f(\mathcal H) = f(\mathcal H')$ holds exactly when `SameOrbit E₀` holds, i.e. some
+variable change $\gamma$ fixing $E_0$ carries a generator of $\mathcal H$ to one of $\mathcal H'$,
+and such that for every such place $w$, $\mathrm{ord}_w(\bar{j} - j_0)$ equals the number of
+$\mathcal H$ with $f(\mathcal H) = w$.
+
+This is the level-$N$ form of the comparison between the fibre of the $\Gamma_0(N)$ moduli problem
+above $j_0$, described by cyclic subgroups of order $N$ up to automorphisms of $E_0$, and the places
+of the level-$N$ modular function field at which $\bar{j} - j_0$ has positive order, with the order
+computing the fibre multiplicity. It is stated conditionally on three properties of the full-kernel
+(Vélu) quotient and one monodromy-equivariance property, and is the form from which
+[`ModularCurve.exists_elliptic_cycSub_orbitMap`]
+(thm.html#ModularCurve.exists_elliptic_cycSub_orbitMap)
+is obtained once those inputs are discharged.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_elliptic_cycSub_orbitMap_of_props.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_elliptic_cycSub_orbitMap_of_props
+
+noncomputable section
+
+open scoped Classical
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_exists_elliptic_cycSub_orbitMap_of_props.ModularCurve \
+  ModularCurve.TatePoint AlgebraicCurve WeierstrassCurve Polynomial"
+
+attribute [local instance] ModularCurve.TatePoint.isAlgClosed_H ModularCurve.TatePoint.charZero_H
+
+namespace ModularCurve
+p2m_export "ModularCurve" "Emb Induces SamePlace CycSub SameOrbit EMD jBar jpBar \
+  modularFunctionFieldBar ModularPolynomialData TatePoint.dictN TatePoint.isAlgClosed_H \
+  TatePoint.charZero_H B3.nearTransport B3.b3Act exists_place_of_emb \
+  samePlace_iff_exists_monodromy natCard_normalized_algHom_jBar_eq_toNat_ord place_eq_of_induces \
+  exists_emb_equiv_rootsAt nonempty_modularPolynomialData B3.specialisationEquivariance_level"
+namespace WiringB2
+p2m_open "ModularCurve"
+
+private theorem algebraMap_eq_C (r : Qbar) :
+    algebraMap Qbar H r = HahnSeries.C r := by
+  rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_eq, HahnSeries.ofPowerSeries_C]
+
+theorem map_jNear {j₀ : Qbar} {m : H ≃ₐ[Qbar] H} (hm : m ∈ HahnSeries.monodromy Qbar) :
+    m (jNear j₀) = jNear j₀ := by
+  rw [jNear, map_add, ← algebraMap_eq_C, AlgEquiv.commutes, algebraMap_eq_C,
+    HahnSeries.fixes_single_one_of_mem_monodromy hm]
+
+def twistEmb {p : ℕ} [NeZero p] {j₀ : Qbar} (m : HahnSeries.monodromy Qbar) (ψ : Emb p j₀) :
+    Emb p j₀ :=
+  ⟨((m : H ≃ₐ[Qbar] H).toAlgHom.comp ψ.1 : _ →ₐ[Qbar] H), by
+    have h := ψ.2
+    simp only [AlgHom.comp_apply]
+    rw [show ψ.1 (jBar p) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : Qbar) from h]
+    exact map_jNear m.2⟩
+
+def twistRoot {p : ℕ} [NeZero p] (data : ModularPolynomialData p) (j₀ : Qbar)
+    (m : HahnSeries.monodromy Qbar) (r : RootsAt data (nearCurve j₀).j) :
+    RootsAt data (nearCurve j₀).j :=
+  ⟨(m : H ≃ₐ[Qbar] H) r.1, by
+    have hfix : (m : H ≃ₐ[Qbar] H) (nearCurve j₀).j = (nearCurve j₀).j := by
+      rw [nearCurve_j]; exact map_jNear m.2
+    have hcomp : (((m : H ≃ₐ[Qbar] H) : H →+* H)).comp
+        (Polynomial.eval₂RingHom (Int.castRingHom H) (nearCurve j₀).j) =
+        Polynomial.eval₂RingHom (Int.castRingHom H) (nearCurve j₀).j := by
+      refine Polynomial.ringHom_ext (fun a => ?_) ?_
+      · simp
+      · simpa using hfix
+    have h := r.2.map (f := ((m : H ≃ₐ[Qbar] H) : H →+* H))
+    rwa [Polynomial.map_map, hcomp] at h⟩
+
+theorem samePlace_iff_twistEmb {p : ℕ} [NeZero p] {j₀ : Qbar} (ψ ψ' : Emb p j₀) :
+    SamePlace ψ.1 ψ'.1 ↔ ∃ m : HahnSeries.monodromy Qbar, twistEmb m ψ = ψ' := by
+  rw [ModularCurve.samePlace_iff_exists_monodromy p j₀ ψ ψ']
+  constructor
+  · rintro ⟨m, hm, hcomp⟩
+    exact ⟨⟨m, hm⟩, Subtype.ext hcomp⟩
+  · rintro ⟨m, hm⟩
+    exact ⟨m.1, m.2, congrArg Subtype.val hm⟩
+
+theorem emd_of_alphaN (p : ℕ) [NeZero p] (data : ModularPolynomialData p)
+    (j₀ : Qbar)
+    (hB1 : {e : Emb p j₀ ≃ RootsAt data (nearCurve j₀).j //
+      ∀ ψ : Emb p j₀, (e ψ).1 = ψ.1 (jpBar p)})
+    (dict : RootsAt data (nearCurve j₀).j ≃ CycSubH (nearCurve j₀) p)
+    (act : HahnSeries.monodromy Qbar → (AddSubgroup (nearCurve j₀).toAffine.Point ≃
+      AddSubgroup (nearCurve j₀).toAffine.Point))
+    (hequiv : ∀ (m : HahnSeries.monodromy Qbar) (r : RootsAt data (nearCurve j₀).j),
+      act m (dict r).1 = (dict (twistRoot data j₀ m r)).1)
+    (hB3 : ∃ β : CycSubH (nearCurve j₀) p ≃ CycSub (WeierstrassCurve.ofJ j₀) p,
+      ∀ G G' : CycSubH (nearCurve j₀) p,
+        (∃ m : HahnSeries.monodromy Qbar, act m G.1 = G'.1) ↔
+          SameOrbit (WeierstrassCurve.ofJ j₀) (β G).1 (β G').1) :
+    EMD p j₀ := by
+  obtain ⟨e, he⟩ := hB1
+  obtain ⟨β, hβ⟩ := hB3
+  have hcarry : ∀ (m : HahnSeries.monodromy Qbar) (ψ : Emb p j₀),
+      e (twistEmb m ψ) = twistRoot data j₀ m (e ψ) := fun m ψ =>
+    Subtype.ext (show (e (twistEmb m ψ)).1 = (m : H ≃ₐ[Qbar] H) ((e ψ).1) from by
+      rw [he (twistEmb m ψ), he ψ]; rfl)
+  refine ⟨WeierstrassCurve.ofJ j₀, inferInstance, WeierstrassCurve.ofJ_j j₀,
+    (e.trans dict).trans β, fun ψ ψ' => ?_⟩
+  rw [samePlace_iff_twistEmb ψ ψ']
+  simp only [Equiv.trans_apply]
+  refine Iff.trans ?_ (hβ (dict (e ψ)) (dict (e ψ')))
+  constructor
+  · rintro ⟨m, hm⟩
+    exact ⟨m, by rw [hequiv m (e ψ), ← hcarry m ψ, hm]⟩
+  · rintro ⟨m, hm⟩
+    refine ⟨m, e.injective (dict.injective (Subtype.ext ?_))⟩
+    rw [hcarry m ψ, ← hequiv m (e ψ)]
+    exact hm
+
+end ModularCurve.WiringB2
+
+namespace ModularCurve
+p2m_export "ModularCurve" "Emb Induces SamePlace CycSub SameOrbit EMD jBar jpBar \
+  modularFunctionFieldBar ModularPolynomialData TatePoint.dictN TatePoint.isAlgClosed_H \
+  TatePoint.charZero_H B3.nearTransport B3.b3Act exists_place_of_emb \
+  samePlace_iff_exists_monodromy natCard_normalized_algHom_jBar_eq_toNat_ord place_eq_of_induces \
+  exists_emb_equiv_rootsAt nonempty_modularPolynomialData B3.specialisationEquivariance_level"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+theorem ModularCurve.hbeta_of_emd_docks (N : ℕ) [NeZero N] (j₀ : AlgebraicClosure ℚ)
+    (hEP : ∀ ψ : {ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ]
+          HahnSeries ℚ (AlgebraicClosure ℚ) //
+        ψ (jBar N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)},
+      ∃ (w : AlgebraicCurve.Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)) (g : ℚ),
+        0 < g ∧ ∀ x : ↥(modularFunctionFieldBar N), (w.ord x : ℚ) * g = (ψ.1 x).order)
+    (hPEO : ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N),
+      0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) →
+      Nat.card {ψ : modularFunctionFieldBar N →ₐ[AlgebraicClosure ℚ]
+          HahnSeries ℚ (AlgebraicClosure ℚ) //
+        ψ (jBar N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ) ∧
+        ∃ g : ℚ, 0 < g ∧ ∀ x, (w.ord x : ℚ) * g = (ψ x).order} =
+      (w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)).toNat)
+    (hC535 : ∀ {ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ]
+          HahnSeries ℚ (AlgebraicClosure ℚ)}
+      {w w' : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)},
+      Induces ψ w → Induces ψ w' → w = w')
+    (h : EMD N j₀) :
+    ∃ (E₀ : WeierstrassCurve (AlgebraicClosure ℚ)) (_ : E₀.IsElliptic), E₀.j = j₀ ∧
+      ∃ f : CycSub E₀ N →
+          {w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+            0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)},
+        (∀ H H' : CycSub E₀ N, f H = f H' ↔ SameOrbit E₀ H.1 H'.1) ∧
+        ∀ w : {w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+            0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)},
+          ((w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)).ord
+              (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)).toNat =
+            Nat.card {H : CycSub E₀ N // f H = w} := by
+  classical
+  obtain ⟨E₀, hell, hj, Φ, hiff⟩ := h
+  have hInd : ∀ ψ : Emb N j₀,
+      ∃ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), Induces ψ.1 w := by
+    intro ψ
+    obtain ⟨w, g, hg, hx⟩ := hEP ψ
+    exact ⟨w, g, hg, hx⟩
+  choose wOf hwOf using hInd
+  have hwOf_eq : ∀ (ψ : Emb N j₀) (w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)),
+      Induces ψ.1 w → wOf ψ = w := fun ψ w hw => hC535 (hwOf ψ) hw
+  have hC : ∀ c : AlgebraicClosure ℚ,
+      algebraMap (AlgebraicClosure ℚ) (HahnSeries ℚ (AlgebraicClosure ℚ)) c = HahnSeries.C c := by
+    intro c
+    rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_eq, HahnSeries.ofPowerSeries_C]
+  have habove : ∀ ψ : Emb N j₀, 0 < (wOf ψ).ord
+      (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) := by
+    intro ψ
+    obtain ⟨g, hg, hx⟩ := hwOf ψ
+    have h1 := hx (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)
+    have himg : ψ.1 (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) =
+        HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ) := by
+      rw [map_sub, ψ.2, AlgHom.commutes, hC]
+      ring
+    rw [himg, HahnSeries.order_single one_ne_zero] at h1
+    have hgne : g ≠ 0 := ne_of_gt hg
+    have h2 : ((wOf ψ).ord
+        (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) : ℚ) = 1 / g :=
+      (eq_div_iff hgne).mpr h1
+    have h3 : (0 : ℚ) < ((wOf ψ).ord
+        (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) : ℚ) := by
+      rw [h2]
+      exact div_pos one_pos hg
+    exact_mod_cast h3
+  let f : CycSub E₀ N → {w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+      0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)} :=
+    fun H => ⟨wOf (Φ.symm H), habove (Φ.symm H)⟩
+  have hf : ∀ H, (f H : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) = wOf (Φ.symm H) :=
+    fun H => rfl
+  refine ⟨E₀, hell, hj, f, fun H H' => ?_, fun w => ?_⟩
+  · have key := hiff (Φ.symm H) (Φ.symm H')
+    rw [Equiv.apply_symm_apply, Equiv.apply_symm_apply] at key
+    rw [← key]
+    constructor
+    · intro hHH
+      have hw : wOf (Φ.symm H) = wOf (Φ.symm H') := by
+        have := congrArg Subtype.val hHH
+        simpa [hf] using this
+      exact ⟨wOf (Φ.symm H), hwOf _, hw ▸ hwOf _⟩
+    · rintro ⟨w, hw, hw'⟩
+      apply Subtype.ext
+      rw [hf, hf, hwOf_eq _ w hw, hwOf_eq _ w hw']
+  · have hw := w.2
+    let e1 : {H : CycSub E₀ N // f H = w} ≃ {ψ : Emb N j₀ // Induces ψ.1 w.1} :=
+      { toFun := fun H => ⟨Φ.symm H.1, by
+          have hH : wOf (Φ.symm H.1) = w.1 := by
+            have := congrArg Subtype.val H.2
+            simpa [hf] using this
+          exact hH ▸ hwOf _⟩
+        invFun := fun ψ => ⟨Φ ψ.1, by
+          apply Subtype.ext
+          rw [hf, Equiv.symm_apply_apply, hwOf_eq _ _ ψ.2]⟩
+        left_inv := fun H => by
+          apply Subtype.ext
+          simp
+        right_inv := fun ψ => by
+          apply Subtype.ext
+          simp }
+    let e2 : {ψ : Emb N j₀ // Induces ψ.1 w.1} ≃
+        {ψ : modularFunctionFieldBar N →ₐ[AlgebraicClosure ℚ] HahnSeries ℚ (AlgebraicClosure ℚ) //
+          ψ (jBar N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ) ∧
+          ∃ g : ℚ, 0 < g ∧ ∀ x, (w.1.ord x : ℚ) * g = (ψ x).order} :=
+      Equiv.subtypeSubtypeEquivSubtypeInter
+        (fun ψ : modularFunctionFieldBar N →ₐ[AlgebraicClosure ℚ]
+            HahnSeries ℚ (AlgebraicClosure ℚ) =>
+          ψ (jBar N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ))
+        (fun ψ => ∃ g : ℚ, 0 < g ∧ ∀ x, (w.1.ord x : ℚ) * g = (ψ x).order)
+    rw [Nat.card_congr (e1.trans e2), hPEO w.1 hw]
+
+private def embEquivRootsNear (p : ℕ) [NeZero p] (data : ModularPolynomialData p)
+    (j₀ : Qbar) :
+    {e : Emb p j₀ ≃ RootsAt data (nearCurve j₀).j //
+      ∀ ψ : Emb p j₀, (e ψ).1 = ψ.1 (jpBar p)} := by
+  have h := ModularCurve.exists_emb_equiv_rootsAt p data j₀
+  rw [show jNear j₀ = (nearCurve j₀).j from (nearCurve_j j₀).symm] at h
+  exact ⟨h.choose, h.choose_spec⟩
+
+theorem solution (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ)
+    (hW1 : FullKernelIsRootAt N) (hW2 : FullKernelInjAt N) (hW3 : FullKernelDiscAt N)
+    (hequivN : ∀ data : ModularPolynomialData N,
+      ∀ (m : HahnSeries.monodromy Qbar) (r r' : RootsAt data (nearCurve j₀).j),
+        r'.1 = (m : H ≃ₐ[Qbar] H) r.1 →
+        B3.b3Act j₀ m (dictN N data j₀ hW1 hW2 hW3 r).1 = (dictN N data j₀ hW1 hW2 hW3 r').1)
+    :
+    ∃ (E₀ : WeierstrassCurve (AlgebraicClosure ℚ)) (_ : E₀.IsElliptic), E₀.j = j₀ ∧
+      ∃ f : CycSub E₀ N →
+          {w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+            0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)},
+        (∀ H H' : CycSub E₀ N, f H = f H' ↔ SameOrbit E₀ H.1 H'.1) ∧
+        ∀ w : {w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+            0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)},
+          ((w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)).ord
+              (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)).toNat =
+            Nat.card {H : CycSub E₀ N // f H = w} := by
+  obtain ⟨data⟩ := ModularCurve.nonempty_modularPolynomialData N
+  exact ModularCurve.hbeta_of_emd_docks N j₀
+    (fun ψ => ModularCurve.exists_place_of_emb N j₀ ψ)
+    (ModularCurve.natCard_normalized_algHom_jBar_eq_toNat_ord N j₀)
+    (fun hw hw' => ModularCurve.place_eq_of_induces hw hw')
+    (ModularCurve.WiringB2.emd_of_alphaN N data j₀ (embEquivRootsNear N data j₀)
+      (dictN N data j₀ hW1 hW2 hW3)
+      (fun m => (AddEquiv.mapAddSubgroup (ModularCurve.B3.nearTransport j₀ m)).toEquiv)
+      (fun m r => hequivN data m r (ModularCurve.WiringB2.twistRoot data j₀ m r) rfl)
+      (ModularCurve.B3.specialisationEquivariance_level N j₀))
+
+end
+
+end S_ModularCurve_exists_elliptic_cycSub_orbitMap_of_props
+end P2MW
+export P2MW.S_ModularCurve_exists_elliptic_cycSub_orbitMap_of_props (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Classical
+
+open ModularCurve ModularCurve.TatePoint AlgebraicCurve
+theorem ModularCurve.exists_elliptic_cycSub_orbitMap_of_props (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ)
+    (hW1 : FullKernelIsRootAt N) (hW2 : FullKernelInjAt N) (hW3 : FullKernelDiscAt N)
+    (hequivN : ∀ data : ModularPolynomialData N,
+      ∀ (m : HahnSeries.monodromy Qbar) (r r' : RootsAt data (nearCurve j₀).j),
+        r'.1 = (m : H ≃ₐ[Qbar] H) r.1 →
+        B3.b3Act j₀ m (dictN N data j₀ hW1 hW2 hW3 r).1 = (dictN N data j₀ hW1 hW2 hW3 r').1)
+    :
+    ∃ (E₀ : WeierstrassCurve (AlgebraicClosure ℚ)) (_ : E₀.IsElliptic), E₀.j = j₀ ∧
+      ∃ f : CycSub E₀ N →
+          {w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+            0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)},
+        (∀ H H' : CycSub E₀ N, f H = f H' ↔ SameOrbit E₀ H.1 H'.1) ∧
+        ∀ w : {w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+            0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)},
+          ((w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)).ord
+              (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)).toNat =
+            Nat.card {H : CycSub E₀ N // f H = w} :=
+  solution N j₀ hW1 hW2 hW3 hequivN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_emb_equiv_rootsAt.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_emb_equiv_rootsAt.lean
new file mode 100644
index 0000000000..eca045872e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_emb_equiv_rootsAt.lean
@@ -0,0 +1,238 @@
+/-
+Based on Prove2Me node ModularCurve.exists_emb_equiv_rootsAt
+(82b1c70d-b8c9-54ff-b13e-5bf0adee5677) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 43d1e757-df44-5e53-9740-90f84f9087dc
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EMD
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_TatePoint
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_adjoin_jBar_jNBar_eq_top
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_algHom_of_isRoot
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Normalised embeddings at j₀ versus roots of Φ_N(j₀+t,Y)
+
+Theorem statement: `ModularCurve.exists_emb_equiv_rootsAt` (`82b1c70d-b8c9-54ff-b13e-5bf0adee5677`),
+by Claude, 2026-09-05.
+
+Proof: submission `43d1e757-df44-5e53-9740-90f84f9087dc`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $N$ with $N \neq 0$, a datum `data` consisting of a monic $\Phi \in
+\mathbb{Z}[X][Y]$ of degree $\psi(N) = \sum_{d \mid N,\ d \text{ squarefree}} N/d$ satisfying
+$\Phi(j, j_N) = 0$ for the $q$-expansions, and an element $j_0$ of $\overline{\mathbb{Q}} =$
+`AlgebraicClosure ℚ`. Write $H =$ `HahnSeries ℚ (AlgebraicClosure ℚ)` for the Hahn series with
+rational exponents, and let $\overline{F}_N$ be the intermediate field of $H$ obtained by adjoining
+to $\overline{\mathbb{Q}}$ the images under coefficientwise base change `coeffEmb` of the elements
+of `modularFunctionFieldFull N`. Then there is a bijection $e$ between `Emb N j₀`, the set of
+$\overline{\mathbb{Q}}$-algebra homomorphisms $\psi : \overline{F}_N \to H$ with $\psi(\bar{\jmath})
+= j_0 + t$, where $\bar{\jmath}$ is the base change of the Laurent series `jq` and $j_0 + t$ denotes
+`HahnSeries.C j₀ + HahnSeries.single 1 1`, and `RootsAt data (jNear j₀)`, the set of $y \in H$ that
+are roots of the polynomial obtained from $\Phi$ by substituting $j_0 + t$ for $X$; moreover $e$
+satisfies $e(\psi) = \psi(\bar{\jmath}_N)$ for all $\psi$, where $\bar{\jmath}_N$ is the base change
+of `qExpand ℚ N jq`, the series `jq` with $q$ replaced by $q^N$.
+
+This is the dictionary between normalised Puiseux-type embeddings of the function field of $X_0(N)$
+over $\overline{\mathbb{Q}}$ sending $j$ to $j_0 + t$ and roots of the specialised modular
+polynomial $\Phi_N(j_0 + t, Y)$, the bijection being evaluation at $j(q^N)$. It feeds the
+construction of elliptic models with a distinguished cyclic subgroup, being used by
+[`ModularCurve.exists_elliptic_cycSub_orbitMap_of_props`]
+(thm.html#ModularCurve.exists_elliptic_cycSub_orbitMap_of_props)
+and
+[`ModularCurve.exists_elliptic_cycSub_orbitMap_prime_of_ne_two`]
+(thm.html#ModularCurve.exists_elliptic_cycSub_orbitMap_prime_of_ne_two).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_emb_equiv_rootsAt.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_emb_equiv_rootsAt
+
+
+noncomputable section
+
+open ModularCurve AlgebraicCurve IntermediateField Polynomial
+
+namespace S12E
+
+variable (N : ℕ) [NeZero N]
+
+abbrev jb : ↥(modularFunctionFieldBar N) :=
+  ⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+    (jq_mem_full N)⟩
+
+abbrev jNb : ↥(modularFunctionFieldBar N) :=
+  ⟨coeffEmb (AlgebraicClosure ℚ) (qExpand ℚ N jq),
+    coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jqd_mem_full N (dvd_refl N))⟩
+
+abbrev PhiAt (data : ModularPolynomialData N) (j₀ : AlgebraicClosure ℚ) :
+    Polynomial (HahnSeries ℚ (AlgebraicClosure ℚ)) :=
+  data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ)))
+    (HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)))
+
+theorem eval₂_Phi_jb_jNb (data : ModularPolynomialData N) :
+    data.Φ.eval₂ (Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N)) (jb N))
+      (jNb N)
+      = 0 := by
+  apply Subtype.ext
+  have hval : ((modularFunctionFieldBar N).toSubfield.subtype).comp
+      (Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N)) (jb N))
+      = (coeffEmb (AlgebraicClosure ℚ)).comp evalAtJ := by
+    refine Polynomial.ringHom_ext (fun z => by simp) ?_
+    change ((Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N)) (jb N) X :
+        ↥(modularFunctionFieldBar N)) : LaurentSeries (AlgebraicClosure ℚ)) = coeffEmb
+          (AlgebraicClosure ℚ) (evalAtJ X)
+    rw [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X, evalAtJ_X]
+  have h0 := congrArg (coeffEmb (AlgebraicClosure ℚ)) data.eval_eq_zero
+  rw [map_zero, Polynomial.hom_eval₂, ← hval] at h0
+  rw [ZeroMemClass.coe_zero, ← h0]
+  change ((modularFunctionFieldBar N).toSubfield.subtype) _ = _
+  rw [Polynomial.hom_eval₂]
+  rfl
+
+theorem isRoot_apply_jNb' (data : ModularPolynomialData N) (j₀ : AlgebraicClosure ℚ)
+    (ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ] HahnSeries ℚ (AlgebraicClosure ℚ))
+    (hψ : ψ (jb N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)) :
+    (PhiAt N data j₀).IsRoot (ψ (jNb N)) := by
+  rw [Polynomial.IsRoot, Polynomial.eval_map, ← hψ]
+  have hcomp : Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ))) (ψ (jb
+    N))
+      = (ψ.toRingHom).comp (Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N))
+        (jb N)) := by
+    refine Polynomial.ringHom_ext (fun z => by simp) ?_
+    simp
+  rw [hcomp]
+  have h := (Polynomial.hom_eval₂ data.Φ
+    (Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N)) (jb N)) ψ.toRingHom (jNb
+      N)).symm
+  rw [eval₂_Phi_jb_jNb N data, map_zero] at h
+  simpa using h
+
+theorem isRoot_apply_jNb (data : ModularPolynomialData N) (j₀ : AlgebraicClosure ℚ) (ψ : Emb N j₀) :
+    (PhiAt N data j₀).IsRoot (ψ.1 (jNb N)) :=
+  isRoot_apply_jNb' N data j₀ ψ.1 ψ.2
+
+theorem ext_of_apply_jNb_eq (j₀ : AlgebraicClosure ℚ) (ψ ψ' : Emb N j₀)
+    (h : ψ.1 (jNb N) = ψ'.1 (jNb N)) : ψ = ψ' := by
+  apply Subtype.ext
+  apply AlgHom.ext
+  intro z
+  have hz : z ∈ (⊤ : IntermediateField (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)) := mem_top
+  rw [← ModularCurve.adjoin_jBar_jNBar_eq_top (AlgebraicClosure ℚ) N] at hz
+  induction hz using IntermediateField.adjoin_induction with
+  | mem x hx =>
+    rcases hx with rfl | rfl
+    · exact ψ.2.trans ψ'.2.symm
+    · exact h
+  | algebraMap x => rw [AlgHom.commutes, AlgHom.commutes]
+  | add x y _ _ hx hy => rw [map_add, map_add, hx, hy]
+  | inv x _ hx => rw [map_inv₀, map_inv₀, hx]
+  | mul x y _ _ hx hy => rw [map_mul, map_mul, hx, hy]
+
+theorem algebraMap_hahn_eq_C (a : AlgebraicClosure ℚ) :
+    algebraMap (AlgebraicClosure ℚ) (HahnSeries ℚ (AlgebraicClosure ℚ)) a = HahnSeries.C a := by
+  rw [HahnSeries.algebraMap_apply']; simp
+
+theorem aeval_single_eq (p : Polynomial (AlgebraicClosure ℚ)) :
+    Polynomial.aeval (HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)) p
+      = HahnSeries.ofPowerSeries ℚ (AlgebraicClosure ℚ) (p : PowerSeries (AlgebraicClosure ℚ)) := by
+  induction p using Polynomial.induction_on' with
+  | add p q hp hq => rw [map_add, Polynomial.coe_add, map_add, hp, hq]
+  | monomial n a =>
+    rw [← Polynomial.C_mul_X_pow_eq_monomial, map_mul, map_pow, Polynomial.aeval_C,
+      Polynomial.aeval_X,
+      algebraMap_hahn_eq_C, Polynomial.coe_mul, Polynomial.coe_pow, Polynomial.coe_C,
+      Polynomial.coe_X,
+      map_mul, map_pow, HahnSeries.ofPowerSeries_C, HahnSeries.ofPowerSeries_X]
+
+theorem transcendental_single : Transcendental (AlgebraicClosure ℚ)
+    (HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)) := by
+  rw [transcendental_iff]
+  intro q hq
+  rw [aeval_single_eq, ← map_zero (HahnSeries.ofPowerSeries ℚ (AlgebraicClosure ℚ))] at hq
+  have := HahnSeries.ofPowerSeries_injective hq
+  exact_mod_cast this
+
+theorem transcendental_C_add_single (j₀ : AlgebraicClosure ℚ) : Transcendental (AlgebraicClosure ℚ)
+    (HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)) := by
+  intro halg
+  apply transcendental_single
+  have hC : IsAlgebraic (AlgebraicClosure ℚ) (HahnSeries.C j₀ : HahnSeries ℚ (AlgebraicClosure ℚ))
+    :=
+    by
+    rw [← algebraMap_hahn_eq_C]
+    exact isAlgebraic_algebraMap (R := AlgebraicClosure ℚ) (A := HahnSeries ℚ (AlgebraicClosure ℚ))
+      j₀
+  simpa using halg.sub hC
+
+theorem exists_equiv (data : ModularPolynomialData N) (j₀ : AlgebraicClosure ℚ) :
+    ∃ e : Emb N j₀ ≃ ModularCurve.TatePoint.RootsAt data (ModularCurve.TatePoint.jNear j₀),
+      ∀ ψ : Emb N j₀, (e ψ).1 = ψ.1 (jNb N) := by
+  classical
+  let f : Emb N j₀ → ModularCurve.TatePoint.RootsAt data (ModularCurve.TatePoint.jNear j₀) :=
+    fun ψ => ⟨ψ.1 (jNb N), isRoot_apply_jNb N data j₀ ψ⟩
+  have hinj : Function.Injective f := fun ψ ψ' h =>
+    ext_of_apply_jNb_eq N j₀ ψ ψ' (congrArg Subtype.val h)
+  have hsurj : Function.Surjective f := by
+    rintro ⟨r, hr⟩
+    obtain ⟨ψ, h1, h2⟩ := ModularCurve.exists_algHom_of_isRoot (AlgebraicClosure ℚ) N data
+      (HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)) r
+      (transcendental_C_add_single j₀) hr
+    exact ⟨⟨ψ, h1⟩, Subtype.ext h2⟩
+  exact ⟨Equiv.ofBijective f ⟨hinj, hsurj⟩, fun ψ => rfl⟩
+
+end S12E
+
+end
+
+theorem solution (N : ℕ) [NeZero N] (data : ModularCurve.ModularPolynomialData N)
+    (j₀ : AlgebraicClosure ℚ) :
+    ∃ e : ModularCurve.Emb N j₀ ≃ ModularCurve.TatePoint.RootsAt data (ModularCurve.TatePoint.jNear
+      j₀),
+      ∀ ψ : ModularCurve.Emb N j₀, (e ψ).1 = ψ.1 ⟨ModularCurve.coeffEmb (AlgebraicClosure ℚ)
+        (ModularCurve.qExpand ℚ N ModularCurve.jq),
+        ModularCurve.coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.jqd_mem_full
+          N (dvd_refl N))⟩ := by
+  exact S12E.exists_equiv N data j₀
+
+end S_ModularCurve_exists_emb_equiv_rootsAt
+end P2MW
+export P2MW.S_ModularCurve_exists_emb_equiv_rootsAt (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.exists_emb_equiv_rootsAt (N : ℕ) [NeZero N]
+    (data : ModularCurve.ModularPolynomialData N)
+    (j₀ : AlgebraicClosure ℚ) :
+    ∃ e : ModularCurve.Emb N j₀ ≃ ModularCurve.TatePoint.RootsAt data (ModularCurve.TatePoint.jNear
+      j₀),
+      ∀ ψ : ModularCurve.Emb N j₀, (e ψ).1 = ψ.1 ⟨ModularCurve.coeffEmb (AlgebraicClosure ℚ)
+        (ModularCurve.qExpand ℚ N ModularCurve.jq),
+        ModularCurve.coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.jqd_mem_full
+          N (dvd_refl N))⟩ :=
+  solution N data j₀
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_finset_ord_jBar_sub_pos.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_finset_ord_jBar_sub_pos.lean
new file mode 100644
index 0000000000..914bae5f55
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_finset_ord_jBar_sub_pos.lean
@@ -0,0 +1,419 @@
+/-
+Based on Prove2Me node ModularCurve.exists_finset_ord_jBar_sub_pos
+(a1bd7734-32e6-5f5f-b5d8-f9cd122118bd) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ac7c507d-cc79-55ea-a71e-825ca6c0ac54
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_MazurStepThreeInputs
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_laurentBaseChange_modularFunctionFieldFull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_pos
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_fiberOver
+import Mathlib.FieldTheory.Relrank
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Algebra
+import Mathlib.FieldTheory.Perfect
+import Mathlib.RingTheory.DedekindDomain.AdicValuation
+import Mathlib.RingTheory.Adjoin.Polynomial.Basic
+import Mathlib.RingTheory.Algebraic.Basic
+import Mathlib.RingTheory.PrincipalIdealDomain
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finiteness of the zero locus of jmath̄ - j₀
+
+Theorem statement: `ModularCurve.exists_finset_ord_jBar_sub_pos`
+(`a1bd7734-32e6-5f5f-b5d8-f9cd122118bd`), by Claude, 2026-09-05.
+
+Proof: submission `ac7c507d-cc79-55ea-a71e-825ca6c0ac54`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, assumed nonzero, and let $j_0$ be an element of $\overline{\mathbb{Q}}$
+(the Mathlib algebraic closure of $\mathbb{Q}$). Write $F_N =$ `modularFunctionFieldFull N` for the
+subfield of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by the divisor expansions at level $N$,
+and let $\bar F_N =$ `modularFunctionFieldBar N` be its base change, namely the intermediate field
+of $\overline{\mathbb{Q}}((q))$ over $\overline{\mathbb{Q}}$ generated by the image of $F_N$ under
+the coefficientwise map `coeffEmb` induced by $\mathbb{Q} \hookrightarrow \overline{\mathbb{Q}}$.
+Let $\bar\jmath =$ `jBar N` be the element of $\bar F_N$ obtained by applying `coeffEmb` to the
+$q$-expansion `jq` of the $j$-invariant. The assertion is that there exists a finite set $S$ of
+places of $\bar F_N$ over $\overline{\mathbb{Q}}$ — a place being a proper valuation subring of
+$\bar F_N$ containing the image of $\overline{\mathbb{Q}}$ and being a principal ideal ring — such
+that, for every such place $v$, membership $v \in S$ holds if and only if $0 <
+\operatorname{ord}_v(\bar\jmath - j_0)$, where $\operatorname{ord}_v$ is minus the logarithm of the
+associated adic valuation and $j_0$ is viewed in $\bar F_N$ via the structure map. Thus $S$ is
+exactly the set of places at which $\bar\jmath - j_0$ has strictly positive order, and in particular
+that set is finite.
+
+This is the finiteness of the zero divisor of the non-constant function $\bar\jmath - j_0$ on the
+modular curve of level $N$ over $\overline{\mathbb{Q}}$, packaged as a `Finset` so that sums of
+local orders over the fibre above $j = j_0$ can be formed. It underlies the computation of the total
+order of $\bar\jmath - j_0$ and the description of the action of Hecke divisors and of normalised
+embeddings in the arithmetic study of these function fields.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_finset_ord_jBar_sub_pos.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+open AlgebraicCurve Place
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_finset_ord_jBar_sub_pos
+
+noncomputable section
+
+p2m_open "AlgebraicCurve ModularCurve \
+  P2MW.S_ModularCurve_exists_finset_ord_jBar_sub_pos.ModularCurve IsDedekindDomain WithZero"
+
+namespace B2Peo3
+
+section General
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+
+
+theorem mem_of_ord_sub_pos (w : Place K F) {f : F} {c : K}
+    (h : 0 < w.ord (f - algebraMap K F c)) : f ∈ w.toValuationSubring := by
+  have hne : f - algebraMap K F c ≠ 0 := by
+    intro h0
+    rw [h0, Place.ord_zero] at h
+    exact lt_irrefl _ h
+  have := add_mem (mem_of_ord_nonneg w hne h.le) (w.algebraMap_mem' c)
+  rwa [sub_add_cancel] at this
+
+theorem ord_eq_one_of_valuation_eq (w : Place K F) {v' : Valuation F ℤᵐ⁰}
+    (hv' : v'.valuationSubring = w.toValuationSubring) {x : F} (hx : v' x = exp (-1 : ℤ)) :
+    w.ord x = 1 := by
+  have hE := w.isEquiv_adicValuation_of_valuationSubring_eq hv'
+  have hx0 : v' x ≠ 0 := by rw [hx]; exact exp_ne_zero
+  have hu0 : w.adicValuation x ≠ 0 := (hE.eq_zero).ne.mp hx0
+  have hlt : w.adicValuation x < 1 := by
+    refine hE.lt_one_iff_lt_one.mp ?_
+    rw [hx, ← exp_zero]
+    exact exp_lt_exp.mpr (by norm_num)
+  obtain ⟨ϖ, hϖ⟩ := w.heightOneSpectrum.valuation_exists_uniformizer F
+  change w.adicValuation ϖ = exp (-1 : ℤ) at hϖ
+  have hϖ0 : w.adicValuation ϖ ≠ 0 := by rw [hϖ]; exact exp_ne_zero
+  have hϖlt : v' ϖ < 1 := by
+    refine hE.lt_one_iff_lt_one.mpr ?_
+    rw [hϖ, ← exp_zero]
+    exact exp_lt_exp.mpr (by norm_num)
+  have hϖ0' : v' ϖ ≠ 0 := (hE.eq_zero).ne.mpr hϖ0
+  have hϖle : v' ϖ ≤ v' x := by
+    rw [hx, ← log_le_iff_le_exp hϖ0']
+    have hlog : log (v' ϖ) < 0 := (log_lt_iff_lt_exp hϖ0').mpr (by rw [exp_zero]; exact hϖlt)
+    omega
+  have hge : exp (-1 : ℤ) ≤ w.adicValuation x := by
+    rw [← hϖ]
+    exact (hE ϖ x).mp hϖle
+  have hle' : log (w.adicValuation x) ≤ -1 := by
+    have hlog : log (w.adicValuation x) < 0 :=
+      (log_lt_iff_lt_exp hu0).mpr (by rw [exp_zero]; exact hlt)
+    omega
+  have hge' : -1 ≤ log (w.adicValuation x) := (le_log_iff_exp_le hu0).mpr hge
+  simp only [Place.ord]
+  omega
+
+scoped instance instIsPrincipalIdealRingAdjoinSingleton (t : F) :
+    IsPrincipalIdealRing (Algebra.adjoin K ({t} : Set F)) := by
+  have hmem : ∀ p : Polynomial K, Polynomial.aeval t p ∈ Algebra.adjoin K ({t} : Set F) := by
+    intro p
+    rw [Algebra.adjoin_singleton_eq_range_aeval]
+    exact ⟨p, rfl⟩
+  refine IsPrincipalIdealRing.of_surjective
+    ((Polynomial.aeval t).codRestrict (Algebra.adjoin K ({t} : Set F)) hmem) ?_
+  rintro ⟨a, ha⟩
+  obtain ⟨p, hp⟩ : ∃ p : Polynomial K, Polynomial.aeval t p = a := by
+    rw [Algebra.adjoin_singleton_eq_range_aeval] at ha
+    exact (AlgHom.mem_range _).mp ha
+  exact ⟨p, Subtype.ext hp⟩
+
+def linGen (t : F) (c : K) : Algebra.adjoin K ({t} : Set F) :=
+  ⟨t, Algebra.self_mem_adjoin_singleton K t⟩ - algebraMap K _ c
+
+@[scoped simp] theorem coe_linGen (t : F) (c : K) :
+    ((linGen t c : Algebra.adjoin K ({t} : Set F)) : F) = t - algebraMap K F c := by
+  simp [linGen]
+
+section Transcendental
+
+variable (t : F) (htr : Transcendental K t)
+
+include htr in
+theorem linGen_ne_zero (c : K) : linGen t c ≠ 0 := by
+  intro h
+  have h' := congrArg (fun a : Algebra.adjoin K ({t} : Set F) => (a : F)) h
+  simp only [coe_linGen, ZeroMemClass.coe_zero, sub_eq_zero] at h'
+  exact htr (by rw [h']; exact isAlgebraic_algebraMap c)
+
+def polyEquiv : Polynomial K ≃ₐ[K] Algebra.adjoin K ({t} : Set F) :=
+  (AlgEquiv.ofInjective (Polynomial.aeval t) (transcendental_iff_injective.mp htr)).trans
+    (Subalgebra.equivOfEq _ _ (by rw [Algebra.adjoin_singleton_eq_range_aeval]))
+
+theorem polyEquiv_X_sub_C (c : K) :
+    polyEquiv t htr (Polynomial.X - Polynomial.C c) = linGen t c := by
+  apply Subtype.ext
+  rw [coe_linGen]
+  simp [polyEquiv, Subalgebra.equivOfEq_apply, AlgEquiv.ofInjective_apply]
+
+include htr in
+theorem prime_linGen (c : K) : Prime (linGen t c) := by
+  rw [← polyEquiv_X_sub_C t htr c, MulEquiv.prime_iff]
+  exact Polynomial.prime_X_sub_C c
+
+def linPrime (c : K) : HeightOneSpectrum (Algebra.adjoin K ({t} : Set F)) :=
+  ⟨Ideal.span {linGen t c}, (Ideal.span_singleton_prime (linGen_ne_zero t htr c)).mpr
+    (prime_linGen t htr c), by
+      rw [ne_eq, Ideal.span_singleton_eq_bot]
+      exact linGen_ne_zero t htr c⟩
+
+open scoped IntermediateField.algebraAdjoinAdjoin
+
+def basePlace (c : K) : Place K (IntermediateField.adjoin K ({t} : Set F)) :=
+  Place.ofHeightOneSpectrum (K := K) (linPrime t htr c)
+
+theorem algebraMap_linGen (c : K) :
+    algebraMap (Algebra.adjoin K ({t} : Set F)) (IntermediateField.adjoin K ({t} : Set F))
+        (linGen t c) =
+      IntermediateField.AdjoinSimple.gen K t - algebraMap K _ c := by
+  apply Subtype.ext
+  rw [IntermediateField.algebraAdjoinAdjoin.coe_algebraMap, coe_linGen]
+  simp
+
+theorem ord_basePlace (c : K) :
+    (basePlace t htr c).ord (IntermediateField.AdjoinSimple.gen K t - algebraMap K _ c) = 1 := by
+  rw [← algebraMap_linGen]
+  refine ord_eq_one_of_valuation_eq (basePlace t htr c)
+    (v' := (linPrime t htr c).valuation (IntermediateField.adjoin K ({t} : Set F))) rfl ?_
+  rw [HeightOneSpectrum.valuation_of_algebraMap]
+  exact (linPrime t htr c).intValuation_singleton (linGen_ne_zero t htr c) rfl
+
+theorem forall_algebraMap_mem (v : Place K (IntermediateField.adjoin K ({t} : Set F)))
+    (ht : IntermediateField.AdjoinSimple.gen K t ∈ v.toValuationSubring)
+    (r : Algebra.adjoin K ({t} : Set F)) :
+    algebraMap (Algebra.adjoin K ({t} : Set F)) (IntermediateField.adjoin K ({t} : Set F)) r ∈
+      v.toValuationSubring := by
+  obtain ⟨x, hx⟩ := r
+  change (⟨x, IntermediateField.algebra_adjoin_le_adjoin K _ hx⟩ :
+      IntermediateField.adjoin K ({t} : Set F)) ∈ v.toValuationSubring
+  induction hx using Algebra.adjoin_induction with
+  | mem y hy =>
+    have hy' : y = t := Set.mem_singleton_iff.mp hy
+    subst hy'
+    exact ht
+  | algebraMap a => exact v.algebraMap_mem' a
+  | add y z hy hz ihy ihz => exact add_mem ihy ihz
+  | mul y z hy hz ihy ihz => exact mul_mem ihy ihz
+
+include htr in
+theorem eq_basePlace_of_ord_pos (v : Place K (IntermediateField.adjoin K ({t} : Set F))) (c : K)
+    (hv : 0 < v.ord (IntermediateField.AdjoinSimple.gen K t - algebraMap K _ c)) :
+    v = basePlace t htr c := by
+  have ht : IntermediateField.AdjoinSimple.gen K t ∈ v.toValuationSubring := mem_of_ord_sub_pos v hv
+  have hw := forall_algebraMap_mem t v ht
+  have hmem : linGen t c ∈ Place.center (Algebra.adjoin K ({t} : Set F)) v hw := by
+    rw [Place.mem_center_iff_ord_pos v hw (linGen_ne_zero t htr c), algebraMap_linGen]
+    exact hv
+  have hcenter : Place.center (Algebra.adjoin K ({t} : Set F)) v hw = Ideal.span {linGen t c} := by
+    have : (Ideal.span {linGen t c}).IsPrime := (linPrime t htr c).isPrime
+    have hmax : (Ideal.span {linGen t c}).IsMaximal :=
+      IsPrime.to_maximal_ideal (linPrime t htr c).ne_bot
+    exact (hmax.eq_of_le (Ideal.IsPrime.ne_top inferInstance)
+      ((Ideal.span_singleton_le_iff_mem _).mpr hmem)).symm
+  have hc : Place.centerHeightOneSpectrum (Algebra.adjoin K ({t} : Set F)) v hw =
+      linPrime t htr c := HeightOneSpectrum.ext hcenter
+  apply Place.ext
+  rw [v.toValuationSubring_eq_of_forall_mem hw, hc,
+    HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+  rfl
+
+scoped instance charZero_adjoin [CharZero K] : CharZero (IntermediateField.adjoin K ({t} : Set F))
+  :=
+  charZero_of_injective_algebraMap (algebraMap K _).injective
+
+variable [CharZero K] [FiniteDimensional (IntermediateField.adjoin K ({t} : Set F)) F]
+
+omit [CharZero K] [FiniteDimensional (IntermediateField.adjoin K ({t} : Set F)) F] in
+theorem algebraMap_gen_sub (c : K) :
+    algebraMap (IntermediateField.adjoin K ({t} : Set F)) F
+        (IntermediateField.AdjoinSimple.gen K t - algebraMap K _ c) =
+      t - algebraMap K F c := by
+  rw [map_sub, IntermediateField.AdjoinSimple.algebraMap_gen,
+    ← IsScalarTower.algebraMap_apply]
+
+omit [CharZero K] in
+theorem ord_sub_eq_mul (w : Place K F) (c : K) :
+    w.ord (t - algebraMap K F c) =
+      w.ramificationIndex (IntermediateField.adjoin K ({t} : Set F)) *
+        (w.restrict (IntermediateField.adjoin K ({t} : Set F))).ord
+          (IntermediateField.AdjoinSimple.gen K t - algebraMap K _ c) := by
+  rw [← algebraMap_gen_sub t c, Place.ord_restrict]
+
+omit [CharZero K] in
+include htr in
+theorem restrict_eq_basePlace_iff (w : Place K F) (c : K) :
+    w.restrict (IntermediateField.adjoin K ({t} : Set F)) = basePlace t htr c ↔
+      0 < w.ord (t - algebraMap K F c) := by
+  constructor
+  · intro h
+    rw [ord_sub_eq_mul t w c, h, ord_basePlace, mul_one]
+    exact_mod_cast w.ramificationIndex_pos (F := IntermediateField.adjoin K ({t} : Set F))
+  · intro h
+    refine eq_basePlace_of_ord_pos t htr _ c ?_
+    rw [ord_sub_eq_mul t w c] at h
+    exact (pos_iff_pos_of_mul_pos h).mp
+      (by exact_mod_cast w.ramificationIndex_pos (F := IntermediateField.adjoin K ({t} : Set F)))
+
+omit [CharZero K] in
+include htr in
+theorem ramificationIndex_eq_ord (w : Place K F) (c : K) (h : 0 < w.ord (t - algebraMap K F c)) :
+    (w.ramificationIndex (IntermediateField.adjoin K ({t} : Set F)) : ℤ) =
+      w.ord (t - algebraMap K F c) := by
+  rw [ord_sub_eq_mul t w c, (restrict_eq_basePlace_iff t htr w c).mpr h, ord_basePlace, mul_one]
+
+omit [CharZero K] in
+theorem inertiaDeg_eq_one (w : Place K F) (hw : w.deg = 1) :
+    w.inertiaDeg (IntermediateField.adjoin K ({t} : Set F)) = 1 := by
+  have h := w.deg_restrict_mul_inertiaDeg (F := IntermediateField.adjoin K ({t} : Set F))
+  rw [hw] at h
+  exact Nat.eq_one_of_mul_eq_one_left h
+
+include htr in
+theorem sum_ord_sub_eq_finrank (hdeg : ∀ w : Place K F, w.deg = 1) (c : K)
+    (S : Finset (Place K F)) (hS : ∀ w, w ∈ S ↔ 0 < w.ord (t - algebraMap K F c)) :
+    ∑ w ∈ S, w.ord (t - algebraMap K F c) =
+      Module.finrank (IntermediateField.adjoin K ({t} : Set F)) F := by
+  have hSfib : S = (basePlace t htr c).fiberOver F := by
+    ext w
+    rw [hS, Place.mem_fiberOver, restrict_eq_basePlace_iff t htr]
+  have hsum := Place.sum_ramificationIndex_mul_inertiaDeg_fiberOver (F' := F) (basePlace t htr c)
+  rw [← hSfib] at hsum
+  rw [← hsum]
+  refine Finset.sum_congr rfl fun w hw => ?_
+  rw [inertiaDeg_eq_one t w (hdeg w), Nat.cast_one, mul_one,
+    ramificationIndex_eq_ord t htr w c ((hS w).mp hw)]
+
+include htr in
+theorem exists_finset_ord_sub_pos (c : K) :
+    ∃ S : Finset (Place K F), ∀ w, w ∈ S ↔ 0 < w.ord (t - algebraMap K F c) :=
+  ⟨(basePlace t htr c).fiberOver F, fun w => by
+    rw [Place.mem_fiberOver, restrict_eq_basePlace_iff t htr]⟩
+
+end Transcendental
+
+end General
+
+theorem finrank_adjoin_jBar_eq_dedekindPsi (N : ℕ) [NeZero N] :
+    Module.finrank
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)))
+      (modularFunctionFieldBar N) = dedekindPsi N := by
+  have hcm : IntermediateField.comap (modularFunctionFieldBar N).val
+        (IntermediateField.adjoin (AlgebraicClosure ℚ)
+          ({((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))} :
+            Set (LaurentSeries (AlgebraicClosure ℚ))))
+      = IntermediateField.adjoin (AlgebraicClosure ℚ)
+          ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)) := by
+    rw [← IntermediateField.lift_adjoin_simple]
+    exact IntermediateField.comap_map (modularFunctionFieldBar N).val _
+  have h1 := IntermediateField.finrank_comap
+    (IntermediateField.adjoin (AlgebraicClosure ℚ)
+      ({((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))} :
+        Set (LaurentSeries (AlgebraicClosure ℚ))))
+    (modularFunctionFieldBar N).val
+  rw [hcm, IntermediateField.fieldRange_val] at h1
+  have h2 : IntermediateField.relfinrank
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))} :
+          Set (LaurentSeries (AlgebraicClosure ℚ))))
+      (modularFunctionFieldBar N) = dedekindPsi N := by
+    rw [← ModularCurve.relfinrank_full_eq_dedekindPsi N,
+      ← ModularCurve.relfinrank_laurentBaseChange_modularFunctionFieldFull (AlgebraicClosure ℚ) N]
+  rw [← h2]
+  exact h1
+
+set_option synthInstance.maxHeartbeats 40000 in -- this is needed (DL)
+scoped instance finiteDimensional_adjoin_jBar (N : ℕ) [NeZero N] :
+    FiniteDimensional
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)))
+      (modularFunctionFieldBar N) :=
+  Module.finite_of_finrank_pos (by
+    rw [finrank_adjoin_jBar_eq_dedekindPsi]
+    exact ModularCurve.dedekindPsi_pos N (NeZero.ne N))
+
+end B2Peo3
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jBar modularFunctionFieldBar dedekindPsi \
+  relfinrank_laurentBaseChange_modularFunctionFieldFull relfinrank_full_eq_dedekindPsi \
+  dedekindPsi_pos transcendental_coeffEmb_jq"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+open B2Peo3 in
+private theorem ModularCurve.sum_ord_jBar_sub_eq_dedekindPsi (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ)
+    (hdeg : ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), w.deg = 1)
+    (S : Finset (Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)))
+    (hS : ∀ v, v ∈ S ↔
+      0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)) :
+    ∑ v ∈ S, v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) =
+      dedekindPsi N := by
+  rw [← finrank_adjoin_jBar_eq_dedekindPsi N]
+  exact_mod_cast sum_ord_sub_eq_finrank (jBar N : modularFunctionFieldBar N)
+    (ModularCurve.transcendental_coeffEmb_jq (AlgebraicClosure ℚ) N) hdeg j₀ S hS
+
+p2m_open_scoped "ModularCurve" in
+open B2Peo3 in
+private theorem ModularCurve.exists_finset_ord_jBar_sub_pos (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ) :
+    ∃ S : Finset (Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)), ∀ v, v ∈ S ↔
+      0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) :=
+  exists_finset_ord_sub_pos (jBar N : modularFunctionFieldBar N)
+    (ModularCurve.transcendental_coeffEmb_jq (AlgebraicClosure ℚ) N) j₀
+
+end
+
+open AlgebraicCurve _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_exists_finset_ord_jBar_sub_pos.ModularCurve in
+theorem solution (N : ℕ) [NeZero N] (j₀ : AlgebraicClosure ℚ) :
+    ∃ S : Finset (Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)), ∀ v, v ∈ S ↔
+      0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) :=
+  ModularCurve.exists_finset_ord_jBar_sub_pos N j₀
+
+end S_ModularCurve_exists_finset_ord_jBar_sub_pos
+end P2MW
+export P2MW.S_ModularCurve_exists_finset_ord_jBar_sub_pos (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve ModularCurve
+theorem ModularCurve.exists_finset_ord_jBar_sub_pos (N : ℕ) [NeZero N] (j₀ : AlgebraicClosure ℚ) :
+    ∃ S : Finset (Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)), ∀ v, v ∈ S ↔
+      0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) :=
+  solution N j₀
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_gamma0_qExpansion_div_eq_jqNModC.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_gamma0_qExpansion_div_eq_jqNModC.lean
new file mode 100644
index 0000000000..eaa27c33da
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_gamma0_qExpansion_div_eq_jqNModC.lean
@@ -0,0 +1,215 @@
+/-
+Based on Prove2Me node ModularCurve.exists_gamma0_qExpansion_div_eq_jqNModC
+(487c45be-49de-5217-9073-6af7a93e4443) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 365591de-34bd-57a9-b451-686eabc5ed13
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import Mathlib.NumberTheory.ModularForms.LevelOne.DimensionFormula
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_degeneracy_Gamma0
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurent_qParam_coeff_unique
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# j(q^ℓ) as a ratio of weight-12 forms on Γ₀(ℓ)
+
+Theorem statement: `ModularCurve.exists_gamma0_qExpansion_div_eq_jqNModC`
+(`487c45be-49de-5217-9073-6af7a93e4443`), by Claude, 2026-09-05.
+
+Proof: submission `365591de-34bd-57a9-b451-686eabc5ed13`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a non-zero natural number. The assertion is the existence of two bundled modular forms
+$G$ and $H$ of weight $12$ for the congruence subgroup $\Gamma_0(\ell)$ such that $H \neq 0$ and
+such that, after forming the $q$-expansions of $G$ and $H$ with respect to the period $1$ (power
+series in $q$, viewed inside the field of Laurent series over $\mathbb{C}$ via the canonical
+inclusion), the quotient of the Laurent series attached to $G$ by the one attached to $H$ equals
+[`ModularCurve.jqNModC ℂ ℓ`](def/ModularCurve_JqCoeff.html#L18). By definition the latter is
+[`ModularCurve.qExpand ℂ ℓ`](def/ModularCurve_X0.html#L25) applied to [`ModularCurve.jqModC
+ℂ`](def/ModularCurve_JqCoeff.html#L15), where `jqModC ℂ` is the Laurent series $q^{-1}$ (the
+Hahn-series monomial `single (-1) 1`) multiplied by the image in $\mathbb{C}[[q]]$ of the integral
+power series `jNum` under $\mathbb{Z} \to \mathbb{C}$, and where `qExpand ℂ ℓ` is the ring
+homomorphism of $\mathbb{C}$-Laurent series obtained by re-indexing exponents along multiplication
+by $\ell$ on $\mathbb{Z}$, that is, the substitution $q \mapsto q^{\ell}$. Thus the Laurent series
+$j(q^{\ell})$ is the ratio of the $q$-expansions of two weight-$12$ forms of level $\Gamma_0(\ell)$.
+
+This records that the second standard generator $j(\ell\tau)$ of the function field of $X_0(\ell)$
+is, on the level of $q$-expansions, a ratio of weight-$12$ modular forms of level $\ell$; the two
+forms are the $\ell$-dilates of $E_4^3$ and $\Delta$. It feeds the $q$-expansion computations used
+in the analysis of $X_0(\ell)$, in particular the results on the index and the size of the relevant
+quotient of $\Gamma_0(\ell)$ and the statement producing a modular form whose $q$-expansion times a
+given one is the dilated $j$-series.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_gamma0_qExpansion_div_eq_jqNModC.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_gamma0_qExpansion_div_eq_jqNModC
+
+open UpperHalfPlane
+open scoped MatrixGroups
+
+namespace SolJJLAux
+
+private theorem gamma0_one_eq_top : CongruenceSubgroup.Gamma0 1 = ⊤ := by
+  ext A
+  simp [CongruenceSubgroup.Gamma0_mem, eq_iff_true_of_subsingleton]
+
+private theorem gamma0_one_coe :
+    ((CongruenceSubgroup.Gamma0 1 : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) = 𝒮ℒ := by
+  simp [gamma0_one_eq_top, MonoidHom.range_eq_map]
+
+private noncomputable def e4cube : ModularForm (CongruenceSubgroup.Gamma0 1) 12 :=
+  ModularForm.mcast (by norm_num) (ModularForm.E₄.pow 3) gamma0_one_coe
+
+private noncomputable def delta1 : ModularForm (CongruenceSubgroup.Gamma0 1) 12 :=
+  ModularForm.mcast rfl (CuspForm.toModularFormₗ CuspForm.discriminant) gamma0_one_coe
+
+private theorem coe_e4cube : ⇑e4cube = ⇑(ModularForm.E₄.pow 3) := rfl
+
+private theorem coe_delta1 : ⇑delta1 = ModularForm.discriminant := rfl
+
+private theorem one_mem_sp (N : ℕ) : (1 : ℝ) ∈
+    ((CongruenceSubgroup.Gamma0 N : Subgroup SL(2, ℤ)) :
+      Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  rw [CongruenceSubgroup.strictPeriods_Gamma0]
+  exact AddSubgroup.mem_zmultiples 1
+
+private theorem hasSum_int {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} {F : Type*} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) (τ : ℍ) :
+    HasSum (fun m : ℤ =>
+      ((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ).coeff m *
+        Function.Periodic.qParam 1 (τ : ℂ) ^ m) (f τ) := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  have h0 := UpperHalfPlane.hasSum_qExpansion (f := (f : ℍ → ℂ)) one_pos
+    (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (ModularFormClass.holo f)
+    (ModularFormClass.bdd_at_infty f) τ
+  refine (Function.Injective.hasSum_iff Nat.cast_injective ?_).mp ?_
+  · intro m hm
+    rcases m with n | n
+    · exact absurd ⟨n, rfl⟩ hm
+    · rw [ModularCurve.ofPowerSeries_coeff_of_neg _ (Int.negSucc_lt_zero n), zero_mul]
+  · have hcomp : ((fun m : ℤ =>
+        ((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ).coeff m *
+          Function.Periodic.qParam 1 (τ : ℂ) ^ m) ∘ (Nat.cast : ℕ → ℤ)) =
+        fun n : ℕ => (qExpansion 1 (f : ℍ → ℂ)).coeff n •
+          Function.Periodic.qParam 1 (τ : ℂ) ^ n := by
+      funext n
+      simp only [Function.comp_apply, smul_eq_mul, zpow_natCast,
+        LaurentSeries.coeff_coe_powerSeries]
+    rw [hcomp]
+    exact h0
+
+private theorem hasSum_qExpand (ℓ : ℕ) [NeZero ℓ] {A : LaurentSeries ℂ} {S : ℂ} {τ : ℍ}
+    (h : HasSum (fun m : ℤ => A.coeff m *
+      Function.Periodic.qParam 1 (((ModularForm.heckeDiagMatrix ℓ • τ : ℍ)) : ℂ) ^ m) S) :
+    HasSum (fun m : ℤ => (ModularCurve.qExpand ℂ ℓ A).coeff m *
+      Function.Periodic.qParam 1 (τ : ℂ) ^ m) S := by
+  have hq : Function.Periodic.qParam 1 (((ModularForm.heckeDiagMatrix ℓ • τ : ℍ)) : ℂ) =
+      Function.Periodic.qParam 1 (τ : ℂ) ^ (ℓ : ℕ) := by
+    rw [ModularForm.coe_heckeDiagMatrix_smul (NeZero.ne ℓ) τ]
+    unfold Function.Periodic.qParam
+    rw [← Complex.exp_nat_mul]
+    congr 1
+    ring
+  rw [hq] at h
+  have hinj : Function.Injective (fun m : ℤ => (ℓ : ℤ) * m) :=
+    mul_right_injective₀ (by exact_mod_cast NeZero.ne ℓ)
+  refine (Function.Injective.hasSum_iff hinj ?_).mp ?_
+  · intro m hm
+    have hnd : ¬ ((ℓ : ℕ) : ℤ) ∣ m := by
+      rintro ⟨c, rfl⟩
+      exact hm ⟨c, rfl⟩
+    rw [ModularCurve.qExpand_coeff_of_not_dvd ℓ A hnd, zero_mul]
+  · have hcomp : ((fun m : ℤ => (ModularCurve.qExpand ℂ ℓ A).coeff m *
+        Function.Periodic.qParam 1 (τ : ℂ) ^ m) ∘ (fun m : ℤ => (ℓ : ℤ) * m)) =
+        fun m : ℤ => A.coeff m *
+          (Function.Periodic.qParam 1 (τ : ℂ) ^ (ℓ : ℕ)) ^ m := by
+      funext m
+      simp only [Function.comp_apply]
+      rw [ModularCurve.qExpand_coeff_mul, zpow_mul, zpow_natCast]
+    rw [hcomp]
+    exact h
+
+private theorem qExpansion_coe_dilate {ℓ : ℕ} [NeZero ℓ] {k : ℤ}
+    (f : ModularForm (CongruenceSubgroup.Gamma0 1) k)
+    (g : ModularForm (CongruenceSubgroup.Gamma0 ℓ) k)
+    (hg : ⇑g = fun τ => f (ModularForm.heckeDiagMatrix ℓ • τ)) :
+    ((qExpansion 1 (g : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+      ModularCurve.qExpand ℂ ℓ
+        ((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) := by
+  refine ModularCurve.laurent_qParam_coeff_unique 1 one_pos (g : ℍ → ℂ) _ _
+    (hasSum_int g (one_mem_sp ℓ)) ?_
+  intro τ
+  have h := hasSum_qExpand ℓ (hasSum_int f (one_mem_sp 1) (ModularForm.heckeDiagMatrix ℓ • τ))
+  rw [show f (ModularForm.heckeDiagMatrix ℓ • τ) = g τ from by rw [hg]] at h
+  exact h
+
+end SolJJLAux
+
+theorem solution (ℓ : ℕ) [NeZero ℓ] : ∃ G H : ModularForm (CongruenceSubgroup.Gamma0 ℓ) 12,
+    H ≠ 0 ∧ ((qExpansion 1 (G : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) /
+      ((qExpansion 1 (H : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+      ModularCurve.jqNModC ℂ ℓ := by
+  obtain ⟨G, hG⟩ := ModularForm.exists_degeneracy_Gamma0
+    (show ℓ * 1 ∣ ℓ by simp) SolJJLAux.e4cube
+  obtain ⟨H, hH⟩ := ModularForm.exists_degeneracy_Gamma0
+    (show ℓ * 1 ∣ ℓ by simp) SolJJLAux.delta1
+  have hGL := SolJJLAux.qExpansion_coe_dilate SolJJLAux.e4cube G hG
+  have hHL := SolJJLAux.qExpansion_coe_dilate SolJJLAux.delta1 H hH
+  refine ⟨G, H, ?_, ?_⟩
+  · intro h0
+    refine ModularForm.discriminant_ne_zero
+      (ModularForm.heckeDiagMatrix ℓ • UpperHalfPlane.I) ?_
+    have h1 := congrFun hH UpperHalfPlane.I
+    rw [h0] at h1
+    have h__af := h1.symm
+    simp only [zero_apply] at h__af
+    exact h__af
+  · have he4 : qExpansion 1 (SolJJLAux.e4cube : ℍ → ℂ) =
+        (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) ^ 3 := by
+      rw [SolJJLAux.coe_e4cube]
+      exact ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL ModularForm.E₄ 3
+    have hΔ1 : qExpansion 1 (SolJJLAux.delta1 : ℍ → ℂ) =
+        qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) := by
+      rw [SolJJLAux.coe_delta1]
+    rw [hGL, hHL, he4, hΔ1,
+      show ModularCurve.jqNModC ℂ ℓ = ModularCurve.qExpand ℂ ℓ (ModularCurve.jqModC ℂ) from rfl,
+      ModularCurve.jqModC_eq_qExpansion_E4_cube_div_discriminant, map_div₀,
+      PowerSeries.coe_pow]
+
+end S_ModularCurve_exists_gamma0_qExpansion_div_eq_jqNModC
+end P2MW
+export P2MW.S_ModularCurve_exists_gamma0_qExpansion_div_eq_jqNModC (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane
+theorem ModularCurve.exists_gamma0_qExpansion_div_eq_jqNModC (ℓ : ℕ) [NeZero ℓ] :
+    ∃ G H : ModularForm (CongruenceSubgroup.Gamma0 ℓ) 12, H ≠ 0 ∧ ((qExpansion 1 (G : ℍ → ℂ) :
+      PowerSeries ℂ) : LaurentSeries ℂ) / ((qExpansion 1 (H : ℍ → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) = ModularCurve.jqNModC ℂ ℓ :=
+  solution ℓ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_hasEquivariantPrimitiveOf.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_hasEquivariantPrimitiveOf.lean
new file mode 100644
index 0000000000..ecd62f126c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_hasEquivariantPrimitiveOf.lean
@@ -0,0 +1,296 @@
+/-
+Based on Prove2Me node ModularCurve.exists_hasEquivariantPrimitiveOf
+(b21b1f0a-8a14-5943-be94-173ff5197938) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5748a117-3229-5598-89c9-bd37b4993727
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodOf
+
+import Mathlib.Analysis.Complex.HasPrimitives
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Subgroup_IsArithmetic_exists_nat_mem_strictPeriods_conj
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of an admissible equivariant primitive of a weight-2 cusp form
+
+Theorem statement: `ModularCurve.exists_hasEquivariantPrimitiveOf`
+(`b21b1f0a-8a14-5943-be94-173ff5197938`), by Claude, 2026-09-05.
+
+Proof: submission `5748a117-3229-5598-89c9-bd37b4993727`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of $\mathrm{SL}_2(\mathbb Z)$ of finite index and let $f$ be a cusp form
+of weight $2$ for $\Gamma$. Then there exists a function $F\colon \mathfrak H \to \mathbb C$ on the
+upper half-plane satisfying the four conditions packaged by
+[`ModularCurve.HasEquivariantPrimitiveOf`](def/ModularCurve_PeriodOf.html#L71): (i) for every $\tau
+\in \mathfrak H$ the composite of $F$ with the retraction `ofComplex` of $\mathbb C$ onto $\mathfrak
+H$ is complex-differentiable at the point $\tau \in \mathbb C$ with derivative $f(\tau)$, so that
+$F$ is a holomorphic primitive of $f$; (ii) $F$ tends to $0$ along the filter `atImInfty`, i.e.
+$F(\tau) \to 0$ as $\operatorname{Im}\tau \to \infty$; (iii) $F$ is an equivariant primitive for
+$\Gamma$ in the sense that for each $\gamma \in \Gamma$ there is a constant $c \in \mathbb C$ with
+$F(\gamma \cdot z) - F(z) = c$ for all $z \in \mathfrak H$; and (iv) for every $\delta \in
+\mathrm{SL}_2(\mathbb Z)$ the function $w \mapsto F(\delta \cdot w)$ has a limit $L \in \mathbb C$
+along `atImInfty`, i.e. $F$ has a finite limiting value at every cusp.
+
+This is the existence statement underlying the Eichler–Shimura period integral of a weight-2 cusp
+form: the primitive $\int^\tau f$, normalised to vanish at $i\infty$, whose coboundary on $\Gamma$
+is the period homomorphism and which stays bounded at every cusp. It is the input to the
+construction of the period map and period lattice on modular curves, and is used in the Abel–Jacobi
+and Hecke-eigenform arguments that rest on them.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_hasEquivariantPrimitiveOf.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_hasEquivariantPrimitiveOf
+
+open scoped MatrixGroups Real Manifold ModularForm
+open UpperHalfPlane Filter Topology Complex Function Metric
+
+namespace ModularCurve
+p2m_export "ModularCurve" "HasEquivariantPrimitiveOf period Period.IsEquivariantPrimitive"
+namespace PrimitiveConstructionOf
+p2m_open "ModularCurve"
+
+local notation "𝕢" => Function.Periodic.qParam
+
+theorem hasDerivAt_qParam (h : ℝ) (z : ℂ) :
+    HasDerivAt (𝕢 h) (2 * π * Complex.I / h * 𝕢 h z) z := by
+  have h1 : HasDerivAt (fun w : ℂ => 2 * ↑π * Complex.I * w / ↑h)
+      (2 * ↑π * Complex.I / ↑h) z := by
+    simpa using ((hasDerivAt_id z).const_mul (2 * ↑π * Complex.I)).div_const (↑h : ℂ)
+  have h2 := h1.cexp
+  have hval : 2 * (π:ℂ) * Complex.I / ↑h * 𝕢 h z
+      = cexp (2 * ↑π * Complex.I * z / ↑h) * (2 * ↑π * Complex.I / ↑h) := by
+    simp only [Function.Periodic.qParam]
+    ring
+  rw [hval]
+  exact h2
+
+theorem exists_primitive {h : ℝ} {g : ℍ → ℂ} (hh : 0 < h) (hper : Periodic (g ∘ ofComplex) h)
+    (hhol : MDiff g) (hzero : IsZeroAtImInfty g) :
+    ∃ G : ℍ → ℂ, (∀ τ : ℍ, HasDerivAt (G ∘ ofComplex) (g τ) ↑τ) ∧
+      Tendsto G atImInfty (𝓝 0) := by
+  have hbdd : IsBoundedAtImInfty g := hzero.isBoundedAtImInfty
+  set Φ : ℂ → ℂ := cuspFunction h g with hΦ
+  have hΦdiff : DifferentiableOn ℂ Φ (ball 0 1) :=
+    differentiableOn_cuspFunction_ball hh hper hhol hbdd
+  have hΦ0 : Φ 0 = 0 := by
+    rw [hΦ, cuspFunction_apply_zero hh (analyticAt_cuspFunction_zero hh hper hhol hbdd) hper]
+    exact hzero.valueAtInfty_eq_zero
+  set Φ₁ : ℂ → ℂ := dslope Φ 0 with hΦ₁
+  have hΦ₁diff : DifferentiableOn ℂ Φ₁ (ball 0 1) :=
+    (Complex.differentiableOn_dslope (ball_mem_nhds 0 one_pos)).mpr hΦdiff
+  have hΦ₁mul : ∀ q : ℂ, q * Φ₁ q = Φ q := fun q => by
+    have := sub_smul_dslope Φ 0 q
+    simpa [hΦ0, smul_eq_mul] using this
+  obtain ⟨Ψ, hΨ0, hΨ⟩ := (hΦ₁diff.isExactOn_ball).with_val_at 0 0
+  have hqball : ∀ τ : ℍ, 𝕢 h ↑τ ∈ ball (0:ℂ) 1 := by
+    intro τ
+    rw [mem_ball_zero_iff, Function.Periodic.norm_qParam]
+    have him : (0:ℝ) < Complex.im ↑τ := τ.2
+    calc Real.exp (-2 * π * Complex.im ↑τ / h) < Real.exp 0 :=
+          Real.exp_lt_exp.mpr (by
+            apply div_neg_of_neg_of_pos _ hh
+            nlinarith [Real.pi_pos])
+      _ = 1 := Real.exp_zero
+  refine ⟨fun τ : ℍ => ↑h / (2 * π * Complex.I) * Ψ (𝕢 h ↑τ), fun τ => ?_, ?_⟩
+  · have hchain : HasDerivAt (fun z : ℂ => ↑h / (2 * π * Complex.I) * Ψ (𝕢 h z)) (g τ) ↑τ := by
+      have h1 : HasDerivAt (fun z : ℂ => Ψ (𝕢 h z))
+          (Φ₁ (𝕢 h ↑τ) * (2 * π * Complex.I / h * 𝕢 h ↑τ)) ↑τ :=
+        (hΨ _ (hqball τ)).comp (↑τ : ℂ) (hasDerivAt_qParam h ↑τ)
+      have h2 := h1.const_mul (↑h / (2 * π * Complex.I))
+      refine h2.congr_deriv ?_
+      have hne : (↑h : ℂ) ≠ 0 := ofReal_ne_zero.mpr hh.ne'
+      have h3 : ↑h / (2 * ↑π * Complex.I) * (Φ₁ (𝕢 h ↑τ) * (2 * ↑π * Complex.I / ↑h * 𝕢 h ↑τ))
+          = 𝕢 h ↑τ * Φ₁ (𝕢 h ↑τ) := by
+        field_simp
+      rw [h3, hΦ₁mul]
+      exact eq_cuspFunction τ hh.ne' hper
+    refine hchain.congr_of_eventuallyEq ?_
+    filter_upwards [isOpen_upperHalfPlaneSet.mem_nhds τ.im_pos] with z hz
+    simp only [Function.comp_apply, ofComplex_apply_of_im_pos hz]
+  · have hΨcont : ContinuousAt Ψ 0 :=
+      (hΨ 0 (mem_ball_self one_pos)).differentiableAt.continuousAt
+    have hq0 : Tendsto (fun τ : ℍ => 𝕢 h ↑τ) atImInfty (𝓝 0) :=
+      qParam_tendsto_atImInfty hh
+    have : Tendsto (fun τ : ℍ => Ψ (𝕢 h ↑τ)) atImInfty (𝓝 (Ψ 0)) :=
+      (hΨcont.tendsto).comp hq0
+    rw [hΨ0] at this
+    simpa using this.const_mul (↑h / (2 * π * Complex.I))
+
+theorem apply_eq_apply_of_hasDerivAt_zero {D : ℂ → ℂ}
+    (hD : ∀ τ : ℍ, HasDerivAt D 0 ↑τ) (z w : ℍ) : D ↑z = D ↑w := by
+  have hmem : ∀ σ : ℍ, (↑σ : ℂ) ∈ {c : ℂ | 0 < c.im} := fun σ => σ.2
+  refine isOpen_upperHalfPlaneSet.is_const_of_fderiv_eq_zero
+    ((convex_halfSpace_im_gt 0).isPreconnected)
+    (fun x hx => ((hD ⟨x, hx⟩).differentiableAt).differentiableWithinAt)
+    (fun x hx => ?_) (hmem z) (hmem w)
+  have h0 := ((hD ⟨x, hx⟩).hasFDerivAt).fderiv
+  rw [Pi.zero_apply, h0]
+  ext1
+  simp
+
+theorem sub_eq_const_of_forall_hasDerivAt {F G : ℂ → ℂ} {f : ℍ → ℂ}
+    (hF : ∀ τ : ℍ, HasDerivAt F (f τ) ↑τ) (hG : ∀ τ : ℍ, HasDerivAt G (f τ) ↑τ) :
+    ∃ c : ℂ, ∀ τ : ℍ, F ↑τ - G ↑τ = c := by
+  refine ⟨F ↑UpperHalfPlane.I - G ↑UpperHalfPlane.I, fun τ => ?_⟩
+  exact apply_eq_apply_of_hasDerivAt_zero
+    (D := fun z => F z - G z) (fun σ => ((hF σ).fun_sub (hG σ)).congr_deriv (sub_self _)) τ
+      UpperHalfPlane.I
+
+theorem hasDerivAt_smul_ofComplex (γ : SL(2, ℤ)) (τ : ℍ) :
+    HasDerivAt (fun z : ℂ => ((γ • ofComplex z : ℍ) : ℂ))
+      (denom (Matrix.SpecialLinearGroup.mapGL ℝ γ) ↑τ ^ (-2 : ℤ)) ↑τ := by
+  set G : GL (Fin 2) ℝ := Matrix.SpecialLinearGroup.mapGL ℝ γ with hG
+  have hdet : (G : Matrix (Fin 2) (Fin 2) ℝ).det = 1 := by
+    rw [← Matrix.GeneralLinearGroup.val_det_apply, hG, Matrix.SpecialLinearGroup.det_mapGL,
+      Units.val_one]
+  have hpos : (0:ℝ) < (G : Matrix (Fin 2) (Fin 2) ℝ).det := by rw [hdet]; norm_num
+  have h1 := (UpperHalfPlane.hasStrictDerivAt_smul hpos τ).hasDerivAt
+  have h2 : (fun z : ℂ => ((G • ofComplex z : ℍ) : ℂ))
+      = fun z : ℂ => ((γ • ofComplex z : ℍ) : ℂ) := by
+    funext z
+    rw [MulAction.compHom_smul_def]
+  rw [h2] at h1
+  refine h1.congr_deriv ?_
+  rw [hdet]
+  push_cast
+  rw [zpow_neg, one_div]
+  norm_cast
+
+theorem hasDerivAt_comp_smul {G : ℍ → ℂ} {g : ℍ → ℂ}
+    (hG : ∀ τ : ℍ, HasDerivAt (G ∘ ofComplex) (g τ) ↑τ) (γ : SL(2, ℤ)) (τ : ℍ) :
+    HasDerivAt (fun z : ℂ => G (γ • ofComplex z)) ((g ∣[(2:ℤ)] γ) τ) ↑τ := by
+  have hfun : (fun z : ℂ => G (γ • ofComplex z))
+      = (G ∘ ofComplex) ∘ (fun z : ℂ => ((γ • ofComplex z : ℍ) : ℂ)) := by
+    funext z
+    simp only [Function.comp_apply, ofComplex_apply]
+  have houter : HasDerivAt (G ∘ ofComplex) (g (γ • τ))
+      ((fun z : ℂ => ((γ • ofComplex z : ℍ) : ℂ)) ↑τ) := by
+    simpa only [ofComplex_apply] using hG (γ • τ)
+  have hcomp := houter.comp (↑τ : ℂ) (hasDerivAt_smul_ofComplex γ τ)
+  rw [← hfun] at hcomp
+  refine hcomp.congr_deriv ?_
+  exact (ModularForm.SL_slash_apply (g : ℍ → ℂ) γ τ).symm
+
+section Assembly
+
+open CongruenceSubgroup Matrix.SpecialLinearGroup
+
+variable {k : ℤ} {Γ : Subgroup SL(2, ℤ)} {F : Type*} [FunLike F ℍ ℂ] (f : F)
+
+open scoped Pointwise in
+theorem exists_common_width (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] :
+    ∃ M : ℕ, 0 < M ∧ ∀ δ : SL(2, ℤ), (M : ℝ) ∈ Subgroup.strictPeriods
+      (ConjAct.toConjAct (Matrix.SpecialLinearGroup.mapGL ℝ δ)⁻¹ •
+        (Γ : Subgroup (GL (Fin 2) ℝ))) := by
+  obtain ⟨M, hM, h⟩ :=
+    Subgroup.IsArithmetic.exists_nat_mem_strictPeriods_conj (Γ : Subgroup (GL (Fin 2) ℝ))
+  refine ⟨M, hM, fun δ => ?_⟩
+  have := h δ⁻¹
+  rwa [map_inv] at this
+
+open scoped Pointwise in
+theorem periodic_slash_comp_ofComplex {M : ℕ}
+    [SlashInvariantFormClass F (Γ : Subgroup (GL (Fin 2) ℝ)) k] (δ : SL(2, ℤ))
+    (hM : (M : ℝ) ∈ Subgroup.strictPeriods
+      (ConjAct.toConjAct (Matrix.SpecialLinearGroup.mapGL ℝ δ)⁻¹ •
+        (Γ : Subgroup (GL (Fin 2) ℝ)))) :
+    Periodic (((f : ℍ → ℂ) ∣[k] δ) ∘ ofComplex) (M : ℝ) :=
+  SlashInvariantFormClass.periodic_comp_ofComplex
+    (SlashInvariantForm.translate f (Matrix.SpecialLinearGroup.mapGL ℝ δ)) hM
+
+theorem SL_slash_eq_self_of_mem [SlashInvariantFormClass F (Γ : Subgroup (GL (Fin 2) ℝ)) k]
+    {γ : SL(2, ℤ)} (hγ : γ ∈ Γ) : (f : ℍ → ℂ) ∣[k] γ = f :=
+  SlashInvariantFormClass.slash_action_eq f _ (Subgroup.mem_map_of_mem _ hγ)
+
+variable [Γ.FiniteIndex] [CuspFormClass F (Γ : Subgroup (GL (Fin 2) ℝ)) 2]
+
+theorem exists_equivariantPrimitive :
+    ∃ Fprim : ℍ → ℂ,
+      (∀ τ : ℍ, HasDerivAt (Fprim ∘ ofComplex) (f τ) ↑τ) ∧
+      Tendsto Fprim atImInfty (𝓝 0) ∧
+      ModularCurve.Period.IsEquivariantPrimitive Γ Fprim ∧
+      ∀ δ : SL(2, ℤ), ∃ L : ℂ, Tendsto (fun w : ℍ => Fprim (δ • w)) atImInfty (𝓝 L) := by
+  obtain ⟨M, hM, hwidth⟩ := exists_common_width Γ
+  have hN : (0:ℝ) < (M : ℝ) := by exact_mod_cast hM
+  have hmaster : ∀ δ : SL(2, ℤ), ∃ G : ℍ → ℂ,
+      (∀ τ : ℍ, HasDerivAt (G ∘ ofComplex) (((f : ℍ → ℂ) ∣[(2:ℤ)] δ) τ) ↑τ) ∧
+      Tendsto G atImInfty (𝓝 0) := fun δ =>
+    exists_primitive hN (periodic_slash_comp_ofComplex f δ (hwidth δ))
+      ((CuspFormClass.holo f).slash 2 _) (CuspFormClass.zero_at_infty_slash f δ)
+  obtain ⟨Fprim, hFprim, hFprim0⟩ := hmaster 1
+  have hFf : ∀ τ : ℍ, HasDerivAt (Fprim ∘ ofComplex) (f τ) ↑τ := by
+    intro τ
+    simpa using hFprim τ
+  refine ⟨Fprim, hFf, hFprim0, ?_, ?_⟩
+  · intro γ
+    have hslash : ((f : ℍ → ℂ) ∣[(2:ℤ)] (γ : SL(2, ℤ))) = f := SL_slash_eq_self_of_mem f γ.2
+    have hchain : ∀ τ : ℍ, HasDerivAt (fun z : ℂ => Fprim ((γ : SL(2, ℤ)) • ofComplex z))
+        (f τ) ↑τ := by
+      intro τ
+      have := hasDerivAt_comp_smul hFf (γ : SL(2, ℤ)) τ
+      rwa [hslash] at this
+    obtain ⟨c, hc⟩ := sub_eq_const_of_forall_hasDerivAt hchain hFf
+    exact ⟨c, fun z => by simpa using hc z⟩
+  · intro δ
+    obtain ⟨Gδ, hGδ, hGδ0⟩ := hmaster δ
+    have hchain : ∀ τ : ℍ, HasDerivAt (fun z : ℂ => Fprim (δ • ofComplex z))
+        (((f : ℍ → ℂ) ∣[(2:ℤ)] δ) τ) ↑τ := fun τ => hasDerivAt_comp_smul hFf δ τ
+    obtain ⟨c, hc⟩ := sub_eq_const_of_forall_hasDerivAt hchain hGδ
+    refine ⟨c, ?_⟩
+    have h1 : (fun w : ℍ => Fprim (δ • w)) = fun w : ℍ => (Gδ ∘ ofComplex) ↑w + c := by
+      funext w
+      have := hc w
+      simp only [ofComplex_apply] at this ⊢
+      linear_combination this
+    rw [h1]
+    have : Tendsto (fun w : ℍ => (Gδ ∘ ofComplex) ↑w) atImInfty (𝓝 0) := by
+      simpa [Function.comp_def, ofComplex_apply] using hGδ0
+    simpa using this.add_const c
+
+end Assembly
+
+theorem main (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (f : CuspForm Γ 2) :
+    ∃ F : ℍ → ℂ, ModularCurve.HasEquivariantPrimitiveOf Γ f F :=
+  exists_equivariantPrimitive f
+
+end ModularCurve.PrimitiveConstructionOf
+
+theorem solution (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex]
+    (f : CuspForm Γ 2) :
+    ∃ F : UpperHalfPlane → ℂ, ModularCurve.HasEquivariantPrimitiveOf Γ f F :=
+  ModularCurve.PrimitiveConstructionOf.main Γ f
+
+end S_ModularCurve_exists_hasEquivariantPrimitiveOf
+end P2MW
+export P2MW.S_ModularCurve_exists_hasEquivariantPrimitiveOf (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.exists_hasEquivariantPrimitiveOf (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex]
+    (f : CuspForm Γ 2) :
+    ∃ F : UpperHalfPlane → ℂ, ModularCurve.HasEquivariantPrimitiveOf Γ f F :=
+  solution Γ f
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_intSeriesC_mul_ne_of_gamma0Units_not_mem.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_intSeriesC_mul_ne_of_gamma0Units_not_mem.lean
new file mode 100644
index 0000000000..440e65136a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_intSeriesC_mul_ne_of_gamma0Units_not_mem.lean
@@ -0,0 +1,397 @@
+/-
+Based on Prove2Me node ModularCurve.exists_intSeriesC_mul_ne_of_gamma0Units_not_mem
+(3a1b55d4-a20b-5dc0-a89e-e45ea5305b8c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4a93d60a-1e4c-523a-9bd2-be03627e5e84
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_CohCarrier_Level
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_gamma1_weight_four_isIntegralQExp_partialDivisorSum_slash_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Diamond operators act faithfully on reduced q-expansions
+
+Theorem statement: `ModularCurve.exists_intSeriesC_mul_ne_of_gamma0Units_not_mem`
+(`3a1b55d4-a20b-5dc0-a89e-e45ea5305b8c`), by Claude, 2026-09-05.
+
+Proof: submission `4a93d60a-1e4c-523a-9bd2-be03627e5e84`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, let $M$ be a nonzero natural number whose image in $K$ is nonzero, and let $H$
+be a subgroup of $(\mathbb{Z}/M)^\times$. Let $\gamma \in \mathrm{SL}_2(\mathbb{Z})$ lie in
+$\Gamma_0(M)$, and write $\langle\gamma\rangle :=$ [`CohCarrier.gamma0Units M ⟨γ,
+hγ⟩`](def/CohCarrier_Level.html#L121) for the unit of $\mathbb{Z}/M$ obtained by reducing the
+lower-right entry of $\gamma$ (a unit, with inverse the reduction of the upper-left entry); assume
+$\langle\gamma\rangle$ does not lie in the subgroup $H \sqcup \langle -1\rangle$ of
+$(\mathbb{Z}/M)^\times$ generated by $H$ together with $-1$. Then there are a weight $k \in
+\mathbb{Z}$, four modular forms $f, g, f_1, g_1$ of weight $k$ on the subgroup of
+$\mathrm{GL}_2(\mathbb{R})$ determined by $\Gamma_H(M)$ (the image in $\mathrm{SL}_2(\mathbb{Z})$ of
+the elements of $\Gamma_0(M)$ whose associated unit lies in $H$), power series $p_f, p_g, p_{f_1},
+p_{g_1} \in \mathbb{Z}[[q]]$, and a nonzero $c \in \mathbb{C}$ such that: each of $p_f, p_g,
+p_{f_1}, p_{g_1}$ becomes, after mapping its coefficients into $\mathbb{C}$, the $q$-expansion of
+width $1$ of the corresponding form; $f_1 = c\,(f\mid_k \gamma)$ and $g_1 = c\,(g\mid_k \gamma)$ as
+functions on the upper half-plane; and, writing $\bar p$ for the image of $p$ in $K((q))$ under
+coefficientwise reduction to $K$, one has $\bar p_g \neq 0$, $\bar p_{g_1} \neq 0$ and $\bar p_f \,
+\bar p_{g_1} \neq \bar p_g \, \bar p_{f_1}$.
+
+The conclusion exhibits an explicit witness to the fact that the diamond operator $\langle d
+\rangle$ attached to $\gamma$ moves the reduction modulo the characteristic of $K$ of the modular
+function $f/g$: the cross-ratio inequality says precisely that $\bar p_f/\bar p_g$ and $\bar
+p_{f_1}/\bar p_{g_1}$ differ in $K((q))$. It is used to prove that the action of
+$\Gamma_0(M)/\pm\Gamma_H(M)$ on the $q$-expansion function field of $X_H(M)$ in residue
+characteristic prime to $M$ is faithful, the input to Igusa's irreducibility statement for the
+reduction of $X_H(M) \to X_0(M)$, and is cited by the full-level results producing the corresponding
+group homomorphism into algebra automorphisms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_intSeriesC_mul_ne_of_gamma0Units_not_mem.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_intSeriesC_mul_ne_of_gamma0Units_not_mem
+
+section FaithHelpers
+
+open scoped MatrixGroups ModularForm
+open UpperHalfPlane
+
+private def faithCoeff (M : ℕ) (c : (ZMod M)ˣ) (n : ℕ) : ℤ :=
+  if n = 0 then 0 else
+    ∑ d ∈ n.divisors,
+      if ((n / d : ℕ) : ZMod M) = (c : ZMod M) ∨ ((n / d : ℕ) : ZMod M) = -(c : ZMod M)
+      then (d : ℤ) ^ 3 else 0
+
+private theorem faithCoeff_neg (M : ℕ) (c : (ZMod M)ˣ) (n : ℕ) :
+    faithCoeff M (-c) n = faithCoeff M c n := by
+  by_cases hn : n = 0
+  · simp [faithCoeff, hn]
+  · simp only [faithCoeff, hn, ite_false, Units.val_neg, neg_neg]
+    exact Finset.sum_congr rfl fun d _ => if_congr or_comm rfl rfl
+
+private theorem faithCoeff_one (M : ℕ) (c : (ZMod M)ˣ) :
+    faithCoeff M c 1 = if (1 : ZMod M) = (c : ZMod M) ∨ (1 : ZMod M) = -(c : ZMod M) then 1 else 0
+      := by
+  simp [faithCoeff, Nat.divisors_one]
+
+private theorem faith_ne_neg {M : ℕ} [NeZero M] (hM : 3 ≤ M) (c : (ZMod M)ˣ) : c ≠ -c := by
+  intro h
+  have hc : (c : ZMod M) = -(c : ZMod M) := by
+    rw [← Units.val_neg]
+    exact congrArg Units.val h
+  have h3 : (2 : ZMod M) * (c : ZMod M) = 0 := by
+    rw [two_mul]
+    nth_rw 2 [hc]
+    exact add_neg_cancel _
+  have h2 : ((2 : ℤ) : ZMod M) = 0 := by
+    rw [Int.cast_ofNat]
+    exact (Units.mul_left_eq_zero c).mp h3
+  have hdvd : M ∣ 2 := Int.natCast_dvd_natCast.mp ((ZMod.intCast_zmod_eq_zero_iff_dvd 2 M).mp h2)
+  have := Nat.le_of_dvd two_pos hdvd
+  omega
+
+private theorem faith_sum_even {M : ℕ} [NeZero M] (hM : 3 ≤ M) (A : Finset (ZMod M)ˣ)
+    (hA : ∀ c ∈ A, -c ∈ A) (t : (ZMod M)ˣ → ℤ) (ht : ∀ c, t (-c) = t c) :
+    ∑ c ∈ A, t c =
+      2 * ∑ c ∈ A.filter (fun c : (ZMod M)ˣ => (c : ZMod M).val < ((-c : (ZMod M)ˣ) : ZMod M).val),
+        t c := by
+  classical
+  have hval : ∀ c : (ZMod M)ˣ, (c : ZMod M).val ≠ ((-c : (ZMod M)ˣ) : ZMod M).val := by
+    intro c h
+    apply faith_ne_neg hM c
+    exact Units.ext (ZMod.val_injective M h)
+  rw [← Finset.sum_filter_add_sum_filter_not A
+    (fun c : (ZMod M)ˣ => (c : ZMod M).val < ((-c : (ZMod M)ˣ) : ZMod M).val) t, two_mul]
+  congr 1
+  refine Finset.sum_nbij' (fun c => -c) (fun c => -c) ?_ ?_ (fun c _ => neg_neg c)
+    (fun c _ => neg_neg c) (fun c _ => (ht c).symm)
+  · intro c hc
+    simp only [Finset.mem_filter, not_lt] at hc ⊢
+    refine ⟨hA c hc.1, ?_⟩
+    rw [neg_neg]
+    exact lt_of_le_of_ne hc.2 (Ne.symm (hval c))
+  · intro c hc
+    simp only [Finset.mem_filter, not_lt] at hc ⊢
+    refine ⟨hA c hc.1, ?_⟩
+    rw [neg_neg]
+    exact hc.2.le
+
+end FaithHelpers
+
+open UpperHalfPlane
+
+open scoped MatrixGroups ModularForm in
+theorem solution
+    (K : Type*) [Field K] (M : ℕ) [NeZero M] (hM : (M : K) ≠ 0) (H : Subgroup (ZMod M)ˣ)
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M)
+    (hd : CohCarrier.gamma0Units M ⟨γ, hγ⟩ ∉ H ⊔ Subgroup.zpowers (-1 : (ZMod M)ˣ)) :
+    ∃ (k : ℤ) (f g f₁ g₁ : ModularForm (CohCarrier.GammaH M H : Subgroup (GL (Fin 2) ℝ)) k)
+      (pf pg pf₁ pg₁ : PowerSeries ℤ) (c : ℂ), c ≠ 0 ∧
+      ModularCurve.IsIntegralQExp f pf ∧ ModularCurve.IsIntegralQExp g pg ∧
+      ModularCurve.IsIntegralQExp f₁ pf₁ ∧ ModularCurve.IsIntegralQExp g₁ pg₁ ∧
+      (⇑f₁ : UpperHalfPlane → ℂ) = c • ((⇑f : UpperHalfPlane → ℂ) ∣[k] (γ : GL (Fin 2) ℝ)) ∧
+      (⇑g₁ : UpperHalfPlane → ℂ) = c • ((⇑g : UpperHalfPlane → ℂ) ∣[k] (γ : GL (Fin 2) ℝ)) ∧
+      ModularCurve.intSeriesC K pg ≠ 0 ∧ ModularCurve.intSeriesC K pg₁ ≠ 0 ∧
+      ModularCurve.intSeriesC K pf * ModularCurve.intSeriesC K pg₁ ≠
+        ModularCurve.intSeriesC K pg * ModularCurve.intSeriesC K pf₁ := by
+  classical
+  have hM3 : 3 ≤ M := by
+    by_contra hlt
+    push Not at hlt
+    have hpos : 0 < M := Nat.pos_of_ne_zero (NeZero.ne M)
+    have hcard : Fintype.card (ZMod M)ˣ ≤ 1 := by
+      rw [ZMod.card_units_eq_totient]
+      interval_cases M <;> decide
+    have : Subsingleton (ZMod M)ˣ := Fintype.card_le_one_iff_subsingleton.mp hcard
+    exact hd (by
+      rw [Subsingleton.elim (CohCarrier.gamma0Units M ⟨γ, hγ⟩) 1]; exact Subgroup.one_mem _)
+  obtain ⟨R, hRq, hRs⟩ :=
+    ModularForm.exists_gamma1_weight_four_isIntegralQExp_partialDivisorSum_slash_eq M hM3
+  have hRq' : ∀ c : (ZMod M)ˣ,
+      qExpansion 1 (⇑(R c)) = (PowerSeries.mk (faithCoeff M c)).map (Int.castRingHom ℂ) :=
+    fun c => (hRq c).symm
+  obtain ⟨u, hu⟩ : ∃ u : (ZMod M)ˣ, u = CohCarrier.gamma0Units M ⟨γ, hγ⟩ := ⟨_, rfl⟩
+  obtain ⟨H', hH'⟩ : ∃ H' : Subgroup (ZMod M)ˣ, H' = H ⊔ Subgroup.zpowers (-1) := ⟨_, rfl⟩
+  have hnegH' : ∀ c ∈ H', -c ∈ H' := fun c hc => by
+    rw [show -c = c * (-1) from (mul_neg_one c).symm]
+    exact H'.mul_mem hc (hH' ▸ Subgroup.mem_sup_right (Subgroup.mem_zpowers _))
+  have hHle : H ≤ H' := hH' ▸ le_sup_left
+  have huH' : u ∉ H' := hu ▸ hH' ▸ hd
+  have hnuH' : -u ∉ H' := fun h => huH' (by simpa using hnegH' _ h)
+  let A : Finset (ZMod M)ˣ := Finset.univ.filter (· ∈ H')
+  have hmemA : ∀ c, c ∈ A ↔ c ∈ H' := fun c => by simp [A]
+  have hnegA : ∀ c ∈ A, -c ∈ A := fun c hc => (hmemA _).mpr (hnegH' c ((hmemA c).mp hc))
+  have hnegU : ∀ c ∈ (Finset.univ : Finset (ZMod M)ˣ), -c ∈ (Finset.univ : Finset (ZMod M)ˣ) :=
+    fun c _ => Finset.mem_univ _
+  have h1per : (1 : ℝ) ∈ (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+    rw [CongruenceSubgroup.strictPeriods_Gamma1]
+    exact AddSubgroup.mem_zmultiples 1
+  have hsum_slash : ∀ (s : Finset (ZMod M)ˣ) (φ : (ZMod M)ˣ → ℍ → ℂ) (B : GL (Fin 2) ℝ),
+      ((∑ c ∈ s, φ c) ∣[(4 : ℤ)] B) = ∑ c ∈ s, (φ c ∣[(4 : ℤ)] B) := by
+    intro s φ B
+    induction s using Finset.induction_on with
+    | empty => simp [SlashAction.zero_slash]
+    | insert a s ha ih => rw [Finset.sum_insert ha, Finset.sum_insert ha, SlashAction.add_slash, ih]
+  have hcoe_sum : ∀ (s : Finset (ZMod M)ˣ)
+      (Φ : (ZMod M)ˣ → ModularForm (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) 4),
+      (⇑(∑ c ∈ s, Φ c) : ℍ → ℂ) = ∑ c ∈ s, ⇑(Φ c) := fun s Φ => map_sum (FunLike.coeAddMonoidHom
+        (ModularForm _ 4) ℍ ℂ) Φ s
+  have hqsum : ∀ (s : Finset (ZMod M)ˣ)
+      (Φ : (ZMod M)ˣ → ModularForm (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) 4),
+      qExpansion 1 (⇑(∑ c ∈ s, Φ c)) = ∑ c ∈ s, qExpansion 1 (⇑(Φ c)) := by
+    intro s Φ
+    induction s using Finset.induction_on with
+    | empty => simp [UpperHalfPlane.qExpansion_zero]
+    | insert a s ha ih =>
+      rw [Finset.sum_insert ha, Finset.sum_insert ha, FunLike.coe_add,
+        ModularForm.qExpansion_add one_pos h1per (Φ a) (∑ c ∈ s, Φ c), ih]
+  have hslash_sum : ∀ (s : Finset (ZMod M)ˣ) (v : (ZMod M)ˣ) (β : SL(2, ℤ))
+      (hβ : β ∈ CongruenceSubgroup.Gamma0 M),
+      ((⇑(∑ c ∈ s, R (c * v))) ∣[(4 : ℤ)] (β : GL (Fin 2) ℝ)) =
+        ∑ c ∈ s, ⇑(R (c * v * (CohCarrier.gamma0Units M ⟨β, hβ⟩)⁻¹)) := by
+    intro s v β hβ
+    rw [hcoe_sum, hsum_slash]
+    exact Finset.sum_congr rfl fun c _ => hRs (c * v) β hβ
+  have hreindexA : ∀ (v w : (ZMod M)ˣ), w ∈ H' →
+      ∑ c ∈ A, (⇑(R (c * v * w⁻¹)) : ℍ → ℂ) = ∑ c ∈ A, ⇑(R (c * v)) := by
+    intro v w hw
+    refine Finset.sum_nbij' (fun c => c * w⁻¹) (fun c => c * w) ?_ ?_ (fun c _ => by simp)
+      (fun c _ => by simp) (fun c _ => by rw [mul_right_comm])
+    · intro c hc
+      rw [hmemA] at hc ⊢
+      exact H'.mul_mem hc (H'.inv_mem hw)
+    · intro c hc
+      rw [hmemA] at hc ⊢
+      exact H'.mul_mem hc hw
+  have hreindexU : ∀ (w : (ZMod M)ˣ),
+      ∑ c ∈ (Finset.univ : Finset (ZMod M)ˣ), (⇑(R (c * 1 * w⁻¹)) : ℍ → ℂ) =
+        ∑ c ∈ (Finset.univ : Finset (ZMod M)ˣ), ⇑(R (c * 1)) := by
+    intro w
+    exact Fintype.sum_equiv (Equiv.mulRight w⁻¹) _ _ fun c => by simp
+  have hinvA : ∀ (v : (ZMod M)ˣ) (β : SL(2, ℤ)), β ∈ CohCarrier.GammaH M H →
+      ((⇑(∑ c ∈ A, R (c * v))) ∣[(4 : ℤ)] (β : GL (Fin 2) ℝ)) = ⇑(∑ c ∈ A, R (c * v)) := by
+    intro v β hβ
+    obtain ⟨hβ0, hβH⟩ := CohCarrier.mem_GammaH_iff.mp hβ
+    rw [hslash_sum A v β hβ0, hreindexA v _ (hHle hβH), hcoe_sum]
+  have hinvU : ∀ (β : SL(2, ℤ)), β ∈ CohCarrier.GammaH M H →
+      ((⇑(∑ c ∈ (Finset.univ : Finset (ZMod M)ˣ), R (c * 1))) ∣[(4 : ℤ)] (β : GL (Fin 2) ℝ)) =
+        ⇑(∑ c ∈ (Finset.univ : Finset (ZMod M)ˣ), R (c * 1)) := by
+    intro β hβ
+    obtain ⟨hβ0, _⟩ := CohCarrier.mem_GammaH_iff.mp hβ
+    rw [hslash_sum _ 1 β hβ0, hreindexU, hcoe_sum]
+  have hle1 : CongruenceSubgroup.Gamma1 M ≤ CohCarrier.GammaH M H := by
+    intro β hβ
+    rw [CohCarrier.mem_GammaH_iff]
+    have hβ' := (CongruenceSubgroup.Gamma1_mem M β).mp hβ
+    refine ⟨CongruenceSubgroup.Gamma1_in_Gamma0 M hβ, ?_⟩
+    have h1 : CohCarrier.gamma0Units M ⟨β, CongruenceSubgroup.Gamma1_in_Gamma0 M hβ⟩ = 1 := by
+      refine Units.ext ?_
+      rw [CohCarrier.val_gamma0Units]
+      simpa [CongruenceSubgroup.Gamma0Map] using hβ'.2.1
+    rw [h1]
+    exact H.one_mem
+  have hfinH : (CohCarrier.GammaH M H).FiniteIndex := Subgroup.finiteIndex_of_le hle1
+  have hcusp : ∀ {c : OnePoint ℝ}, IsCusp c (CohCarrier.GammaH M H : Subgroup (GL (Fin 2) ℝ)) →
+      IsCusp c (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) := fun hc =>
+    (Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z _).mpr
+      ((Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z _).mp hc)
+  let lift : ∀ (Φ : ModularForm (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) 4),
+      (∀ β : SL(2, ℤ), β ∈ CohCarrier.GammaH M H → ((⇑Φ) ∣[(4 : ℤ)] (β : GL (Fin 2) ℝ)) = ⇑Φ) →
+      ModularForm (CohCarrier.GammaH M H : Subgroup (GL (Fin 2) ℝ)) 4 := fun Φ hΦ =>
+    { toFun := Φ
+      slash_action_eq' := fun A hA => by
+        obtain ⟨β, hβ, rfl⟩ := Subgroup.mem_map.mp hA
+        exact hΦ β hβ
+      holo' := Φ.holo'
+      bdd_at_cusps' := fun hc => Φ.bdd_at_cusps' (hcusp hc) }
+  have hlift : ∀ Φ hΦ, (⇑(lift Φ hΦ) : ℍ → ℂ) = ⇑Φ := fun _ _ => rfl
+  let fH := lift (∑ c ∈ A, R (c * 1)) (hinvA 1)
+  let f₁H := lift (∑ c ∈ A, R (c * u⁻¹)) (hinvA u⁻¹)
+  let gH := lift (∑ c ∈ (Finset.univ : Finset (ZMod M)ˣ), R (c * 1)) hinvU
+  have hint : ∀ (s : Finset (ZMod M)ˣ) (hs : ∀ c ∈ s, -c ∈ s) (v : (ZMod M)ˣ)
+      (Φ : ModularForm (CohCarrier.GammaH M H : Subgroup (GL (Fin 2) ℝ)) 4),
+      (⇑Φ : ℍ → ℂ) = ⇑(∑ c ∈ s, R (c * v)) →
+      ModularCurve.IsIntegralQExp (⇑((2⁻¹ : ℂ) • Φ))
+        (PowerSeries.mk fun n => (∑ c ∈ s, faithCoeff M (c * v) n) / 2) := by
+    intro s hs v Φ hΦ
+    unfold ModularCurve.IsIntegralQExp
+    rw [FunLike.coe_smul, hΦ, ModularForm.qExpansion_smul one_pos h1per, hqsum]
+    ext n
+    have hterm : ∀ c : (ZMod M)ˣ,
+        (PowerSeries.coeff n) (qExpansion 1 (⇑(R (c * v)))) = ((faithCoeff M (c * v) n : ℤ) : ℂ) :=
+      fun c => by rw [hRq' (c * v), PowerSeries.coeff_map, PowerSeries.coeff_mk, eq_intCast]
+    simp only [PowerSeries.coeff_map, PowerSeries.coeff_mk, map_smul, map_sum, smul_eq_mul,
+      eq_intCast, hterm]
+    rw [← Int.cast_sum,
+      faith_sum_even hM3 s hs (fun c => faithCoeff M (c * v) n)
+        (fun c => by simp only [neg_mul, faithCoeff_neg]),
+      Int.mul_ediv_cancel_left _ two_ne_zero]
+    push_cast
+    ring
+  have hone_ne : (1 : (ZMod M)ˣ) ≠ -1 := faith_ne_neg hM3 1
+  have hPQ : ∀ w : (ZMod M)ˣ,
+      ((1 : ZMod M) = (w : ZMod M) ∨ (1 : ZMod M) = -(w : ZMod M)) ↔ (w = 1 ∨ w = -1) := by
+    intro w
+    rw [← Units.val_neg]
+    constructor
+    · rintro (h | h)
+      · exact Or.inl (Units.val_eq_one.mp h.symm)
+      · exact Or.inr (neg_eq_iff_eq_neg.mp (Units.val_eq_one.mp h.symm))
+    · rintro (rfl | rfl) <;> simp
+  have hcount : ∀ (s : Finset (ZMod M)ˣ) (v : (ZMod M)ˣ),
+      ∑ c ∈ s, faithCoeff M (c * v) 1 = ((s.filter fun c => c * v = 1 ∨ c * v = -1).card : ℤ) := by
+    intro s v
+    rw [Finset.natCast_card_filter]
+    refine Finset.sum_congr rfl fun c _ => ?_
+    simp only [faithCoeff_one, hPQ]
+  have hpair : ∀ (s : Finset (ZMod M)ˣ), (1 : (ZMod M)ˣ) ∈ s → (-1 : (ZMod M)ˣ) ∈ s →
+      (s.filter fun c => c * 1 = 1 ∨ c * 1 = -1).card = 2 := by
+    intro s h1 hm1
+    rw [show (s.filter fun c => c * 1 = 1 ∨ c * 1 = -1) = {1, -1} from ?_, Finset.card_pair hone_ne]
+    ext c
+    simp only [Finset.mem_filter, mul_one, Finset.mem_insert, Finset.mem_singleton]
+    constructor
+    · exact fun h => h.2
+    · rintro (rfl | rfl)
+      · exact ⟨h1, Or.inl rfl⟩
+      · exact ⟨hm1, Or.inr rfl⟩
+  have hempty : (A.filter fun c => c * u⁻¹ = 1 ∨ c * u⁻¹ = -1).card = 0 := by
+    rw [Finset.card_eq_zero, Finset.filter_eq_empty_iff]
+    intro c hc h
+    rw [hmemA] at hc
+    rcases h with h | h
+    · exact huH' (by rw [mul_inv_eq_one] at h; exact h ▸ hc)
+    · exact hnuH' (by rw [mul_inv_eq_iff_eq_mul, neg_one_mul] at h; exact h ▸ hc)
+  have h1A : (1 : (ZMod M)ˣ) ∈ A := (hmemA 1).mpr H'.one_mem
+  have hm1A : (-1 : (ZMod M)ˣ) ∈ A :=
+    (hmemA _).mpr (hH' ▸ Subgroup.mem_sup_right (Subgroup.mem_zpowers _))
+  have hpf1 : PowerSeries.coeff 1 (PowerSeries.mk fun n => (∑ c ∈ A, faithCoeff M (c * 1) n) / 2) =
+    1 :=
+    by
+    rw [PowerSeries.coeff_mk, hcount A 1, hpair A h1A hm1A]
+    norm_num
+  have hpg1 : PowerSeries.coeff 1 (PowerSeries.mk fun n =>
+      (∑ c ∈ (Finset.univ : Finset (ZMod M)ˣ), faithCoeff M (c * 1) n) / 2) = 1 := by
+    rw [PowerSeries.coeff_mk, hcount _ 1, hpair _ (Finset.mem_univ _) (Finset.mem_univ _)]
+    norm_num
+  have hpf₁1 : PowerSeries.coeff 1 (PowerSeries.mk fun n =>
+      (∑ c ∈ A, faithCoeff M (c * u⁻¹) n) / 2) = 0 := by
+    rw [PowerSeries.coeff_mk, hcount A u⁻¹, hempty]
+    norm_num
+  have hcoe1 : ∀ p : PowerSeries ℤ,
+      (ModularCurve.intSeriesC K p).coeff 1 = ((PowerSeries.coeff 1 p : ℤ) : K) := fun p => by
+    rw [ModularCurve.intSeriesC, show (1 : ℤ) = ((1 : ℕ) : ℤ) from rfl,
+      HahnSeries.ofPowerSeries_apply_coeff, PowerSeries.coeff_map, eq_intCast]
+  have hg0 : ModularCurve.intSeriesC K (PowerSeries.mk fun n =>
+      (∑ c ∈ (Finset.univ : Finset (ZMod M)ˣ), faithCoeff M (c * 1) n) / 2) ≠ 0 := by
+    intro h
+    have h1 := hcoe1 (PowerSeries.mk fun n =>
+      (∑ c ∈ (Finset.univ : Finset (ZMod M)ˣ), faithCoeff M (c * 1) n) / 2)
+    rw [h, hpg1, HahnSeries.coeff_zero] at h1
+    exact one_ne_zero (by exact_mod_cast h1.symm)
+  have key : ∀ (Ψ : ℍ → ℂ), ((2⁻¹ : ℂ) • Ψ) ∣[(4 : ℤ)] (γ : GL (Fin 2) ℝ) =
+      (2⁻¹ : ℂ) • (Ψ ∣[(4 : ℤ)] (γ : GL (Fin 2) ℝ)) := fun Ψ =>
+    ModularForm.SL_smul_slash (4 : ℤ) γ Ψ (2⁻¹ : ℂ)
+  refine ⟨4, (2⁻¹ : ℂ) • fH, (2⁻¹ : ℂ) • gH, (2⁻¹ : ℂ) • f₁H, (2⁻¹ : ℂ) • gH,
+    PowerSeries.mk fun n => (∑ c ∈ A, faithCoeff M (c * 1) n) / 2,
+    PowerSeries.mk fun n => (∑ c ∈ (Finset.univ : Finset (ZMod M)ˣ), faithCoeff M (c * 1) n) / 2,
+    PowerSeries.mk fun n => (∑ c ∈ A, faithCoeff M (c * u⁻¹) n) / 2,
+    PowerSeries.mk fun n => (∑ c ∈ (Finset.univ : Finset (ZMod M)ˣ), faithCoeff M (c * 1) n) / 2,
+    1, one_ne_zero, hint A hnegA 1 fH (hlift _ (hinvA 1)), hint _ hnegU 1 gH (hlift _ hinvU),
+    hint A hnegA u⁻¹ f₁H (hlift _ (hinvA u⁻¹)), hint _ hnegU 1 gH (hlift _ hinvU), ?_, ?_, hg0, hg0,
+      ?_⟩
+  · rw [one_smul, FunLike.coe_smul, FunLike.coe_smul, hlift _ (hinvA u⁻¹),
+      hlift _ (hinvA 1), key, hslash_sum A 1 γ hγ, ← hu, hcoe_sum]
+    congr 1
+    exact Finset.sum_congr rfl fun c _ => by rw [mul_one]
+  · rw [one_smul, FunLike.coe_smul, hlift _ hinvU, key, hslash_sum _ 1 γ hγ, ← hu,
+      hreindexU u, hcoe_sum]
+  · intro h
+    rw [mul_comm (ModularCurve.intSeriesC K (PowerSeries.mk fun n =>
+      (∑ c ∈ (Finset.univ : Finset (ZMod M)ˣ), faithCoeff M (c * 1) n) / 2))] at h
+    have h' := mul_right_cancel₀ hg0 h
+    have h1 := congrArg (fun x : LaurentSeries K => x.coeff 1) h'
+    simp only [hcoe1, hpf1, hpf₁1, Int.cast_one, Int.cast_zero] at h1
+    exact one_ne_zero h1
+
+end S_ModularCurve_exists_intSeriesC_mul_ne_of_gamma0Units_not_mem
+end P2MW
+export P2MW.S_ModularCurve_exists_intSeriesC_mul_ne_of_gamma0Units_not_mem (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups ModularForm in
+theorem ModularCurve.exists_intSeriesC_mul_ne_of_gamma0Units_not_mem
+    (K : Type*) [Field K] (M : ℕ) [NeZero M] (hM : (M : K) ≠ 0) (H : Subgroup (ZMod M)ˣ)
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M)
+    (hd : CohCarrier.gamma0Units M ⟨γ, hγ⟩ ∉ H ⊔ Subgroup.zpowers (-1 : (ZMod M)ˣ)) :
+    ∃ (k : ℤ) (f g f₁ g₁ : ModularForm (CohCarrier.GammaH M H : Subgroup (GL (Fin 2) ℝ)) k)
+      (pf pg pf₁ pg₁ : PowerSeries ℤ) (c : ℂ), c ≠ 0 ∧
+      ModularCurve.IsIntegralQExp f pf ∧ ModularCurve.IsIntegralQExp g pg ∧
+      ModularCurve.IsIntegralQExp f₁ pf₁ ∧ ModularCurve.IsIntegralQExp g₁ pg₁ ∧
+      (⇑f₁ : UpperHalfPlane → ℂ) = c • ((⇑f : UpperHalfPlane → ℂ) ∣[k] (γ : GL (Fin 2) ℝ)) ∧
+      (⇑g₁ : UpperHalfPlane → ℂ) = c • ((⇑g : UpperHalfPlane → ℂ) ∣[k] (γ : GL (Fin 2) ℝ)) ∧
+      ModularCurve.intSeriesC K pg ≠ 0 ∧ ModularCurve.intSeriesC K pg₁ ≠ 0 ∧
+      ModularCurve.intSeriesC K pf * ModularCurve.intSeriesC K pg₁ ≠
+        ModularCurve.intSeriesC K pg * ModularCurve.intSeriesC K pf₁ :=
+  solution K M hM H γ hγ hd
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_irreducible_ramificationIndex_eq_ord_aeval_of_restrict_ne_jLinePlaces.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_irreducible_ramificationIndex_eq_ord_aeval_of_restrict_ne_jLinePlaces.lean
new file mode 100644
index 0000000000..095ad736a7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_irreducible_ramificationIndex_eq_ord_aeval_of_restrict_ne_jLinePlaces.lean
@@ -0,0 +1,204 @@
+/-
+Based on Prove2Me node
+ModularCurve.exists_irreducible_ramificationIndex_eq_ord_aeval_of_restrict_ne_jLinePlaces
+(d9c59f6a-f97d-52a7-8ac4-7a0df55b14f2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c5ebd8ec-b1d8-5444-a630-0a1a2eea9ae0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JLinePlaces
+
+import Mathlib.Analysis.Normed.Field.Lemmas
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_of_span
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Ramification index equals ord_w(p(j)) away from 0,1728,∞
+
+Theorem statement:
+`ModularCurve.exists_irreducible_ramificationIndex_eq_ord_aeval_of_restrict_ne_jLinePlaces`
+(`d9c59f6a-f97d-52a7-8ac4-7a0df55b14f2`), by Claude, 2026-09-05.
+
+Proof: submission `c5ebd8ec-b1d8-5444-a630-0a1a2eea9ae0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N\ge 1$ and let $j\in\mathbb{Q}((q))$ denote the Laurent series
+[`ModularCurve.jq`](def/ModularCurve_X0.html#L157); the field $F_N=$
+[`ModularCurve.modularFunctionField N`](def/ModularCurve_X0.html#L250) is the subfield of
+$\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by $j$ and by its $N$-fold $q$-rescaling, viewed as an
+algebra over the intermediate field $\mathbb{Q}\langle j\rangle$ via
+[`ModularCurve.jAdjoinAlgebra`](def/ModularCurve_JLinePlaces.html#L19), and it is assumed that $F_N$
+is integral over $\mathbb{Q}\langle j\rangle$. Let $w$ be a place of $F_N$ over $\mathbb{Q}$, that
+is, a proper valuation subring of $F_N$ containing the image of $\mathbb{Q}$ whose ring is a
+principal ideal ring. Suppose the restriction of $w$ to $\mathbb{Q}\langle j\rangle$ (the preimage
+valuation subring) is none of the three places `jLinePlace1728`, `jLinePlaceZero`,
+`jLinePlaceInfty`, obtained by transporting along the isomorphism
+$\mathbb{Q}(T)\cong\mathbb{Q}\langle j\rangle$, $T\mapsto j$, the places of $\mathbb{Q}(T)$ attached
+to $T-1728$, to $T$, and to the point at infinity. Then there is a monic irreducible
+$p\in\mathbb{Q}[X]$ with $p(0)\neq 0$ and $p(1728)\neq 0$ such that $\mathrm{ord}_w(p(j))>0$ and the
+ramification index of $w$ over $\mathbb{Q}\langle j\rangle$ — the least $n>0$ of the form
+$\mathrm{ord}_w(f)$ for some nonzero $f$ in the base field — equals $\mathrm{ord}_w(p(j))$, where
+$\mathrm{ord}_w$ is the normalised additive valuation of $w$ and $p(j)$ denotes the evaluation of
+$p$ at $j\in F_N$.
+
+This identifies, for a place of the function field of $X_0(N)$ lying over a closed point of the
+$j$-line other than $j=0$, $j=1728$ or $j=\infty$, a uniformiser of the base obtained from the monic
+irreducible polynomial cutting out that closed point, so that the local ramification index is
+computed as $\mathrm{ord}_w(p(j))$. It is the input used in counting the places where
+$\mathrm{ord}_w(j)=1$ and where $\mathrm{ord}_w(j-1728)=1$, i.e. in the computations of the elliptic
+point counts $\nu_3$ and $\nu_2$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_irreducible_ramificationIndex_eq_ord_aeval_of_restrict_ne_jLinePlaces.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_63ec6564
+
+
+open IntermediateField AlgebraicCurve AlgebraicCurve.RationalFunctionField Polynomial
+
+attribute [local instance 2000] RatFunc.instAlgebraOfPolynomial
+attribute [local instance] ModularCurve.instDecidableEqRatFuncRat
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jAdjoinAlgebra algebraMap_jGen_val jLineRingEquiv jLineRingEquiv_X \
+  instDecidableEqRatFuncRat jLinePlace1728 jLinePlaceZero jLinePlaceInfty jq modularFunctionField \
+  jq_mem jGen"
+namespace JLineFiniteAux
+p2m_open "ModularCurve"
+
+theorem exists_eq_congr (v : Place ℚ ↥ℚ⟮ModularCurve.jq⟯) :
+    ∃ v' : Place ℚ (RatFunc ℚ), v = Place.congrRingEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom) v' :=
+  ⟨(Place.congrEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom)).symm v,
+    ((Place.congrEquiv _ _).apply_symm_apply v).symm⟩
+
+theorem equiv_algebraMap (p : ℚ[X]) :
+    ModularCurve.jLineRingEquiv (algebraMap ℚ[X] (RatFunc ℚ) p)
+      = Polynomial.aeval ModularCurve.jGen p := by
+  have key : ModularCurve.jLineRingEquiv.toRingHom.comp (algebraMap ℚ[X] (RatFunc ℚ))
+      = (Polynomial.aeval (R := ℚ) ModularCurve.jGen).toRingHom := by
+    refine Polynomial.ringHom_ext (fun c => ?_) ?_
+    · rw [RingHom.comp_apply, RatFunc.algebraMap_C, AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom,
+        Polynomial.aeval_C]
+      exact RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom c
+    · rw [RingHom.comp_apply, RatFunc.algebraMap_X, AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom,
+        Polynomial.aeval_X]
+      exact ModularCurve.jLineRingEquiv_X
+  exact RingHom.congr_fun key p
+
+end ModularCurve.JLineFiniteAux
+
+open ModularCurve.JLineFiniteAux in
+theorem solution (N : ℕ) [NeZero N] :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ ≠ ModularCurve.jLinePlace1728 →
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ ≠ ModularCurve.jLinePlaceZero →
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ ≠ ModularCurve.jLinePlaceInfty →
+      ∃ p : Polynomial ℚ, Irreducible p ∧ p.Monic ∧ p.eval 0 ≠ 0 ∧ p.eval 1728 ≠ 0 ∧
+        0 < w.ord (Polynomial.aeval (⟨ModularCurve.jq, ModularCurve.jq_mem N⟩ :
+          ↥(ModularCurve.modularFunctionField N)) p) ∧
+        (w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ : ℤ) = w.ord (Polynomial.aeval (⟨ModularCurve.jq,
+          ModularCurve.jq_mem N⟩ : ↥(ModularCurve.modularFunctionField N)) p) := by
+  let := ModularCurve.jAdjoinAlgebra N
+  intro _ w h1728 h0 hinf
+  obtain ⟨v', hv'⟩ := exists_eq_congr (w.restrict ↥ℚ⟮ModularCurve.jq⟯)
+  have hinf' : v' ≠ placeInfty ℚ := by
+    rintro rfl; exact hinf hv'
+  have h0' : v' ≠ placeOfPoint ℚ 0 := by
+    rintro rfl; exact h0 hv'
+  have h1728' : v' ≠ placeOfPoint ℚ 1728 := by
+    rintro rfl; exact h1728 hv'
+  obtain ⟨P, rfl⟩ : ∃ P : IsDedekindDomain.HeightOneSpectrum ℚ[X], v' = Place.ofHeightOneSpectrum P
+    :=
+    by
+    rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v' with h | h
+    · exact h
+    · exact absurd h hinf'
+  obtain ⟨g, hgirr, hPg⟩ := exists_irreducible_span ℚ P
+  have hg0 : g ≠ 0 := hgirr.ne_zero
+  set p : ℚ[X] := normalize g with hp
+  have hpg : Associated g p := (associated_normalize g)
+  have hpirr : Irreducible p := hpg.irreducible hgirr
+  have hpmon : p.Monic := Polynomial.monic_normalize hg0
+  have hp0 : p ≠ 0 := hpirr.ne_zero
+  have hPp : P.asIdeal = Ideal.span {p} := by
+    rw [hPg]; exact Ideal.span_singleton_eq_span_singleton.mpr hpg
+  have hordv : (w.restrict ↥ℚ⟮ModularCurve.jq⟯).ord (Polynomial.aeval ModularCurve.jGen p) = 1 := by
+    rw [hv', ← equiv_algebraMap, Place.ord_congrRingEquiv]
+    exact ord_ofHeightOneSpectrum_of_span P hp0 hPp
+  have hj : algebraMap ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N) ModularCurve.jGen
+      = (⟨ModularCurve.jq, ModularCurve.jq_mem N⟩ : ↥(ModularCurve.modularFunctionField N)) :=
+    Subtype.ext (ModularCurve.algebraMap_jGen_val N)
+  have haeval : Polynomial.aeval (⟨ModularCurve.jq, ModularCurve.jq_mem N⟩ :
+    ↥(ModularCurve.modularFunctionField N)) p
+      = algebraMap ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N) (Polynomial.aeval
+        ModularCurve.jGen p) := by
+    rw [← hj, Polynomial.aeval_algebraMap_apply]
+  have hordw : w.ord (Polynomial.aeval (⟨ModularCurve.jq, ModularCurve.jq_mem N⟩ :
+    ↥(ModularCurve.modularFunctionField N)) p)
+      = (w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ : ℤ) := by
+    rw [haeval, w.ord_restrict (F := ↥ℚ⟮ModularCurve.jq⟯), hordv, mul_one]
+  have hepos : 0 < (w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ : ℤ) := by
+    exact_mod_cast w.ramificationIndex_pos (F := ↥ℚ⟮ModularCurve.jq⟯)
+  have hroot : ∀ a : ℚ, Place.ofHeightOneSpectrum (K := ℚ) (F := RatFunc ℚ) P ≠ placeOfPoint ℚ a →
+      p.eval a ≠ 0 := by
+    intro a hne hpa
+    apply hne
+    have hdvd : (X - C a) ∣ p := dvd_iff_isRoot.mpr hpa
+    have hass : Associated (X - C a) p := (irreducible_X_sub_C a).associated_of_dvd hpirr hdvd
+    rw [placeOfPoint_eq_ofHeightOneSpectrum]
+    congr 1
+    ext1
+    rw [hPp, heightOneSpectrumOfIrreducible_asIdeal]
+    exact Ideal.span_singleton_eq_span_singleton.mpr hass.symm
+  refine ⟨p, hpirr, hpmon, hroot 0 h0', hroot 1728 h1728', ?_, hordw.symm⟩
+  rw [hordw]; exact hepos
+
+end S_OVERLONG_63ec6564
+end P2MW
+export
+  P2MW.S_OVERLONG_63ec6564
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open IntermediateField AlgebraicCurve
+theorem ModularCurve.exists_irreducible_ramificationIndex_eq_ord_aeval_of_restrict_ne_jLinePlaces
+    (N : ℕ) [NeZero N] :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ ≠ ModularCurve.jLinePlace1728 →
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ ≠ ModularCurve.jLinePlaceZero →
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ ≠ ModularCurve.jLinePlaceInfty →
+      ∃ p : Polynomial ℚ, Irreducible p ∧ p.Monic ∧ p.eval 0 ≠ 0 ∧ p.eval 1728 ≠ 0 ∧
+        0 < w.ord (Polynomial.aeval (⟨ModularCurve.jq, ModularCurve.jq_mem N⟩ :
+          ↥(ModularCurve.modularFunctionField N)) p) ∧
+        (w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ : ℤ) = w.ord (Polynomial.aeval (⟨ModularCurve.jq,
+          ModularCurve.jq_mem N⟩ : ↥(ModularCurve.modularFunctionField N)) p) :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_isFrickeAut.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_isFrickeAut.lean
new file mode 100644
index 0000000000..8367cf09f3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_isFrickeAut.lean
@@ -0,0 +1,87 @@
+/-
+Based on Prove2Me node ModularCurve.exists_isFrickeAut
+(c772f910-85f5-5519-8e39-dc3a47976d09) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 05df5b93-8ddd-5a54-a893-1f6a67048873
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_AtkinLehner
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_isFrickeAut_of_modularPolynomialData
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of a Fricke automorphism at prime level
+
+Theorem statement: `ModularCurve.exists_isFrickeAut` (`c772f910-85f5-5519-8e39-dc3a47976d09`), by
+Claude, 2026-09-05.
+
+Proof: submission `05df5b93-8ddd-5a54-a893-1f6a67048873`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a prime. The theorem asserts the existence of an automorphism $\sigma$ of the field
+$F_\ell =$ `modularFunctionField ℓ` as a $\mathbb{Q}$-algebra, where $F_\ell$ is the intermediate
+field of the Laurent series field $\mathbb{Q}((q))$ over $\mathbb{Q}$ generated by the two elements
+$\mathtt{jq}$ and $\mathtt{qExpand}\,\mathbb{Q}\,\ell\,\mathtt{jq}$; here `qExpand ℚ ℓ` is the ring
+homomorphism of $\mathbb{Q}((q))$ obtained by multiplying all exponents by $\ell$, that is, the
+substitution $q \mapsto q^{\ell}$, realised as the `embDomainRingHom` along multiplication by $\ell$
+on the exponent group $\mathbb{Z}$. The automorphism produced satisfies the predicate `IsFrickeAut
+ℓ`, which says exactly that $\sigma$ interchanges the two distinguished elements of $F_\ell$: the
+element $\mathtt{jq}$ (with its membership witness `jq_mem ℓ`) is sent to the element $\mathtt{jqN}\
+\ell$ (with witness `jqN_mem ℓ`), and conversely $\mathtt{jqN}\ \ell$ is sent to $\mathtt{jq}$. Only
+these two equalities on generators are asserted; the statement does not in itself record that
+$\sigma$ has order two as a map on $F_\ell$.
+
+This is the existence of the Fricke involution on the function field of $X_0(\ell)$ for prime level,
+in its concrete incarnation as the $q$-expansion field $\mathbb{Q}(j(q), j(q^{\ell}))$, where it
+exchanges the two generators. It feeds the construction of the Fricke automorphism used in the
+Atkin–Lehner theory of the project, and is cited by
+[`ModularCurve.exists_isFrickeAutFull`](thm.html#ModularCurve.exists_isFrickeAutFull).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_isFrickeAut.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_isFrickeAut
+
+open ModularCurve AlgebraicCurve IntermediateField
+
+noncomputable section
+
+theorem solution (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] :
+    ∃ σ : modularFunctionField ℓ ≃ₐ[ℚ] modularFunctionField ℓ, IsFrickeAut ℓ σ := by
+  obtain ⟨data, hirr, hsymm⟩ := ModularCurve.exists_phiIrreducible_evalSymm ℓ
+  exact ModularCurve.exists_isFrickeAut_of_modularPolynomialData data hsymm hirr
+
+end
+
+end S_ModularCurve_exists_isFrickeAut
+end P2MW
+export P2MW.S_ModularCurve_exists_isFrickeAut (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve IntermediateField
+theorem ModularCurve.exists_isFrickeAut (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] :
+    ∃ σ : modularFunctionField ℓ ≃ₐ[ℚ] modularFunctionField ℓ, IsFrickeAut ℓ σ :=
+  solution ℓ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_isFrickeAutFull.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_isFrickeAutFull.lean
new file mode 100644
index 0000000000..ebef60651f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_isFrickeAutFull.lean
@@ -0,0 +1,132 @@
+/-
+Based on Prove2Me node ModularCurve.exists_isFrickeAutFull
+(15ca057b-f5a1-5d87-b099-8eae7183423f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9354c7a4-b2b7-59df-a528-3890efdc9285
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_AtkinLehner
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_isFrickeAut
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_full_eq_of_prime
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Fricke automorphism of ℚ(j(qᵈ):d∣ℓ) at prime level
+
+Theorem statement: `ModularCurve.exists_isFrickeAutFull` (`15ca057b-f5a1-5d87-b099-8eae7183423f`),
+by Claude, 2026-09-05.
+
+Proof: submission `9354c7a4-b2b7-59df-a528-3890efdc9285`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a natural number carrying the instance that it is prime. The field in play is
+`modularFunctionFieldFull ℓ`, the intermediate field of $\mathbb{Q} \subseteq \mathbb{Q}((q))$
+(Laurent series over $\mathbb{Q}$) obtained by adjoining to $\mathbb{Q}$ the set of Laurent series
+$\mathrm{qExpand}\,\mathbb{Q}\,d\ (\mathrm{jq})$ for all nonzero $d$ dividing $\ell$, where `jq` is
+the distinguished Laurent series playing the role of the $q$-expansion of $j$ and `qExpand ℚ d` is
+the ring homomorphism of Laurent series that multiplies all exponents by $d$ (substitution $q
+\mapsto q^{d}$). The assertion is that there exists a $\mathbb{Q}$-algebra automorphism $\sigma$ of
+this field satisfying `IsFrickeAutFull ℓ σ`, that is: for all natural numbers $a, b$ with $a \cdot b
+= \ell$, both nonzero, $\sigma$ carries the element of `modularFunctionFieldFull ℓ` given by
+$\mathrm{qExpand}\,\mathbb{Q}\,a\ (\mathrm{jq})$ (together with its membership witness, coming from
+$a \mid \ell$) to the element given by $\mathrm{qExpand}\,\mathbb{Q}\,b\ (\mathrm{jq})$. No further
+conditions on $\sigma$ are imposed, and no claim of uniqueness or of $\sigma$ being an involution is
+made.
+
+This is the existence of the Fricke involution $w_\ell$, $\tau \mapsto -1/(\ell\tau)$, in its
+function-field form: an automorphism of the function field of $X_0(\ell)$ interchanging $j$ and
+$j(\ell\,\cdot)$, stated for the divisor-generated presentation $\mathbb{Q}(j(q^{d}) : d \mid
+\ell)$. It feeds the Atkin–Lehner input used downstream in the analysis of values and poles of
+modular functions at points of $X_0(\ell)$, including the treatment of nodes and of Frobenius node
+pairs.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_isFrickeAutFull.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_isFrickeAutFull
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_exists_isFrickeAutFull.ModularCurve AlgebraicCurve \
+  IntermediateField"
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "IsFrickeAutFull qExpand qExpand_one_apply jq jqN modularFunctionField \
+  modularFunctionFieldFull exists_isFrickeAut full_eq_of_prime"
+p2m_open "ModularCurve"
+
+namespace W2B
+
+theorem cast_algEquiv_exists {E E' : IntermediateField ℚ (LaurentSeries ℚ)} (h : E = E')
+    (σ : E ≃ₐ[ℚ] E) :
+    ∃ σ' : E' ≃ₐ[ℚ] E', ∀ x : E', ((σ' x : E') : LaurentSeries ℚ) = σ ⟨x, h ▸ x.2⟩ := by
+  subst h
+  exact ⟨σ, fun _ => rfl⟩
+
+end W2B
+
+end ModularCurve
+
+theorem solution (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] :
+    ∃ σ : modularFunctionFieldFull ℓ ≃ₐ[ℚ] modularFunctionFieldFull ℓ, IsFrickeAutFull ℓ σ := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  have hfull : modularFunctionFieldFull ℓ = modularFunctionField ℓ :=
+    ModularCurve.full_eq_of_prime hℓ.out
+  obtain ⟨σ, hσ⟩ := ModularCurve.exists_isFrickeAut ℓ
+  obtain ⟨σ', hσ'⟩ := ModularCurve.W2B.cast_algEquiv_exists hfull.symm σ
+  refine ⟨σ', ?_⟩
+  intro a b hab _ _
+  have hcases : a = 1 ∧ ℓ = b ∨ ℓ = a ∧ b = 1 := by
+    have hprime : (a * b).Prime := hab ▸ hℓ.out
+    rcases Nat.prime_mul_iff.mp hprime with ⟨_, rfl⟩ | ⟨_, rfl⟩
+    · right; exact ⟨hab.symm.trans (mul_one a), rfl⟩
+    · left; exact ⟨rfl, hab.symm.trans (one_mul b)⟩
+  rcases hcases with ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩
+  · have H : ∀ (y : LaurentSeries ℚ) (hy : y ∈ modularFunctionField ℓ), y = jq →
+        ((σ ⟨y, hy⟩ : modularFunctionField ℓ) : LaurentSeries ℚ) = qExpand ℚ ℓ jq := by
+      rintro y hy rfl
+      exact congrArg Subtype.val hσ.1
+    apply Subtype.ext
+    rw [hσ']
+    exact H _ _ (qExpand_one_apply jq)
+  · have H : ∀ (y : LaurentSeries ℚ) (hy : y ∈ modularFunctionField ℓ), y = jqN ℓ →
+        ((σ ⟨y, hy⟩ : modularFunctionField ℓ) : LaurentSeries ℚ) = qExpand ℚ 1 jq := by
+      rintro y hy rfl
+      exact (congrArg Subtype.val hσ.2).trans (qExpand_one_apply jq).symm
+    apply Subtype.ext
+    rw [hσ']
+    exact H _ _ rfl
+
+end
+
+end S_ModularCurve_exists_isFrickeAutFull
+end P2MW
+export P2MW.S_ModularCurve_exists_isFrickeAutFull (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve IntermediateField
+theorem ModularCurve.exists_isFrickeAutFull (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] :
+    ∃ σ : modularFunctionFieldFull ℓ ≃ₐ[ℚ] modularFunctionFieldFull ℓ, IsFrickeAutFull ℓ σ :=
+  solution ℓ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_isFrickeAut_of_modularPolynomialData.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_isFrickeAut_of_modularPolynomialData.lean
new file mode 100644
index 0000000000..2539e7622a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_isFrickeAut_of_modularPolynomialData.lean
@@ -0,0 +1,377 @@
+/-
+Based on Prove2Me node ModularCurve.exists_isFrickeAut_of_modularPolynomialData
+(2d98832d-0598-5412-a134-3723f57edf59) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ac8bcd9f-0e9e-594e-a05b-0859e59473eb
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_AtkinLehner
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_isIntegral_jqN
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of a Fricke automorphism from symmetric irreducible Φ
+
+Theorem statement: `ModularCurve.exists_isFrickeAut_of_modularPolynomialData`
+(`2d98832d-0598-5412-a134-3723f57edf59`), by Claude, 2026-09-05.
+
+Proof: submission `ac8bcd9f-0e9e-594e-a05b-0859e59473eb`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N \geq 1$ (a natural number with a `NeZero` instance) and let `data` be a modular polynomial
+packet at level $N$: a polynomial $\Phi \in \mathbb{Z}[X][Y]$ which is monic in $Y$, whose degree in
+$Y$ equals $\psi(N) = \sum_{d \mid N,\ d \text{ squarefree}} N/d$, and which satisfies $\Phi(j(q),
+j(q^N)) = 0$ in the Laurent series field $\mathbb{Q}((q))$; here $j(q)$ is the element `jq` and
+$j(q^N)$ is its image `jqN N` under the substitution $q \mapsto q^N$, and the inner coefficients of
+$\Phi$ are evaluated at $j(q)$ by the ring homomorphism `evalAtJ`. Assume two hypotheses on $\Phi$:
+evaluation symmetry, i.e. $\Phi$ evaluated with inner variable $x$ and outer variable $y$ agrees
+with $\Phi$ evaluated with inner variable $y$ and outer variable $x$, for all $x, y \in
+\mathbb{Q}((q))$; and irreducibility of `data.toAdjoin`, the coefficientwise image of $\Phi$ in
+$\mathbb{Q}\langle j(q)\rangle[Y]$. The conclusion is that there exists a $\mathbb{Q}$-algebra
+automorphism $\sigma$ of the intermediate field $\mathbb{Q}(j(q), j(q^N)) \subseteq \mathbb{Q}((q))$
+generated by the two elements, such that $\sigma$ sends $j(q)$ to $j(q^N)$ and $j(q^N)$ to $j(q)$.
+
+This is the existence half of the Fricke involution on the function field of $X_0(N)$: granted a
+symmetric modular polynomial of the expected degree relating $j(q)$ and $j(q^N)$ and irreducible
+over $\mathbb{Q}(j(q))$, the generator-exchanging automorphism exists. It feeds the unconditional
+statement [`ModularCurve.exists_isFrickeAut`](thm.html#ModularCurve.exists_isFrickeAut), from which
+the Fricke involution and the Atkin–Lehner theory at level $N$ are built.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_isFrickeAut_of_modularPolynomialData.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_isFrickeAut_of_modularPolynomialData
+
+p2m_open "ModularCurve \
+  P2MW.S_ModularCurve_exists_isFrickeAut_of_modularPolynomialData.ModularCurve AlgebraicCurve \
+  IntermediateField \
+  P2MW.S_ModularCurve_exists_isFrickeAut_of_modularPolynomialData.IntermediateField"
+
+noncomputable section
+
+namespace IntermediateField
+p2m_export "IntermediateField" "lift AdjoinSimple.gen ext adjoin_simple_adjoin_simple \
+  adjoinRootEquivAdjoin_symm_apply_gen adjoinRootEquivAdjoin restrictScalars adjoin_induction \
+  algebraMap_mem map"
+end IntermediateField
+p2m_open_scoped "IntermediateField" in
+scoped instance IntermediateField.W2B.instIsScalarTowerRatSubtypeMem {L : Type*} [Field L] [Algebra
+  ℚ L]
+    (F : IntermediateField ℚ L) : IsScalarTower ℚ F L :=
+  IsScalarTower.of_algebraMap_eq' (by apply RingHom.ext_rat)
+
+namespace ModularCurve
+p2m_export "ModularCurve" "IsFrickeAut qExpand jq jqN ModularPolynomialData modularFunctionField \
+  jq_mem jqN_mem jGen evalAtJGen algebraMap_comp_evalAtJGen ModularPolynomialData.toAdjoin \
+  evalAtJqN evalAtJqN_X evalAtJqN_def EvalSymm PhiIrreducible"
+p2m_open "ModularCurve"
+
+namespace W2B
+
+section Fricke
+
+variable (N : ℕ) [NeZero N]
+
+theorem algHom_ext_of_eq_on_gens {A : Type*} [DivisionRing A] [Algebra ℚ A]
+    {f g : modularFunctionField N →ₐ[ℚ] A}
+    (hj : f (⟨jq, jq_mem N⟩ : modularFunctionField N) = g (⟨jq, jq_mem N⟩ : modularFunctionField N))
+      (hjN : f (⟨jqN N, jqN_mem N⟩ : modularFunctionField N) = g (⟨jqN N, jqN_mem N⟩ :
+      modularFunctionField N)) : f = g := by
+  ext ⟨x, hx⟩
+  induction hx using IntermediateField.adjoin_induction with
+  | mem x hxS =>
+      rcases hxS with rfl | rfl
+      · exact hj
+      · exact hjN
+  | algebraMap r =>
+      have hr : (⟨algebraMap ℚ (LaurentSeries ℚ) r,
+          (modularFunctionField N).algebraMap_mem r⟩ : modularFunctionField N)
+          = algebraMap ℚ (modularFunctionField N) r := by
+        apply Subtype.ext
+        change algebraMap ℚ (LaurentSeries ℚ) r
+          = ((algebraMap ℚ (modularFunctionField N) r : modularFunctionField N) :
+              LaurentSeries ℚ)
+        rw [eq_ratCast (algebraMap ℚ (LaurentSeries ℚ)) r,
+          eq_ratCast (algebraMap ℚ (modularFunctionField N)) r]
+        norm_cast
+      exact (congrArg f hr).trans
+        ((f.commutes r).trans ((g.commutes r).symm.trans (congrArg g hr.symm)))
+  | add x y hx hy ihx ihy =>
+      change f (⟨x, hx⟩ + ⟨y, hy⟩) = g (⟨x, hx⟩ + ⟨y, hy⟩)
+      rw [map_add, map_add, ihx, ihy]
+  | inv x hx ih =>
+      change f (⟨x, hx⟩⁻¹) = g (⟨x, hx⟩⁻¹)
+      rw [map_inv₀, map_inv₀, ih]
+  | mul x y hx hy ihx ihy =>
+      change f (⟨x, hx⟩ * ⟨y, hy⟩) = g (⟨x, hx⟩ * ⟨y, hy⟩)
+      rw [map_mul, map_mul, ihx, ihy]
+
+variable {N}
+
+theorem exists_isFrickeAut_of_endo (φ : modularFunctionField N →ₐ[ℚ] modularFunctionField N)
+    (h1 : φ (⟨jq, jq_mem N⟩ : modularFunctionField N) = (⟨jqN N, jqN_mem N⟩ : modularFunctionField
+      N)) (h2 : φ (⟨jqN N, jqN_mem N⟩ : modularFunctionField N) = (⟨jq, jq_mem N⟩ :
+      modularFunctionField N)) :
+    ∃ σ : modularFunctionField N ≃ₐ[ℚ] modularFunctionField N, IsFrickeAut N σ := by
+  have hcomp : φ.comp φ = AlgHom.id ℚ (modularFunctionField N) := by
+    refine algHom_ext_of_eq_on_gens N ?_ ?_
+    · change φ (φ (⟨jq, jq_mem N⟩ : modularFunctionField N)) = (⟨jq, jq_mem N⟩ :
+        modularFunctionField N)
+      rw [h1, h2]
+    · change φ (φ (⟨jqN N, jqN_mem N⟩ : modularFunctionField N)) = (⟨jqN N, jqN_mem N⟩ :
+        modularFunctionField N)
+      rw [h2, h1]
+  exact ⟨AlgEquiv.ofAlgHom φ φ hcomp hcomp, h1, h2⟩
+
+end Fricke
+
+section Swap
+
+variable {N : ℕ} [NeZero N] (data : ModularPolynomialData N)
+
+theorem eval_swap_eq_zero (hsymm : EvalSymm data.Φ) :
+    data.Φ.eval₂ (evalAtJqN N) jq = 0 := by
+  rw [evalAtJqN_def, hsymm (jqN N) jq]
+  exact data.eval_eq_zero
+
+theorem aeval_jqN_toAdjoin : Polynomial.aeval (jqN N) data.toAdjoin = 0 := by
+  rw [Polynomial.aeval_def, ModularPolynomialData.toAdjoin, Polynomial.eval₂_map,
+    algebraMap_comp_evalAtJGen]
+  exact data.eval_eq_zero
+
+theorem minpoly_jqN_eq (hirr : PhiIrreducible data) :
+    minpoly ℚ⟮jq⟯ (jqN N) = data.toAdjoin :=
+  (minpoly.eq_of_irreducible_of_monic hirr (aeval_jqN_toAdjoin data) data.toAdjoin_monic).symm
+
+end Swap
+
+section BaseMap
+
+variable (N : ℕ) [NeZero N]
+
+def frickeBaseHom : ℚ⟮jq⟯ →+* LaurentSeries ℚ :=
+  (qExpand ℚ N).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ))
+
+theorem frickeBaseHom_comp_evalAtJGen :
+    (frickeBaseHom N).comp evalAtJGen = evalAtJqN N := by
+  refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+  change frickeBaseHom N (evalAtJGen Polynomial.X) = evalAtJqN N Polynomial.X
+  rw [evalAtJqN_X]
+  change frickeBaseHom N (Polynomial.eval₂ (Int.castRingHom ℚ⟮jq⟯) jGen Polynomial.X) = jqN N
+  rw [Polynomial.eval₂_X]
+  rfl
+
+end BaseMap
+
+section Lift
+
+variable {N : ℕ} [NeZero N] (data : ModularPolynomialData N)
+
+theorem eval₂_minpoly_frickeBaseHom (hsymm : EvalSymm data.Φ) (hirr : PhiIrreducible data) :
+    (minpoly ℚ⟮jq⟯ (jqN N)).eval₂ (frickeBaseHom N) jq = 0 := by
+  rw [minpoly_jqN_eq data hirr, ModularPolynomialData.toAdjoin, Polynomial.eval₂_map,
+    frickeBaseHom_comp_evalAtJGen]
+  exact eval_swap_eq_zero data hsymm
+
+def frickeRelativeHom (hsymm : EvalSymm data.Φ) (hirr : PhiIrreducible data) :
+    ℚ⟮jq⟯⟮jqN N⟯ →+* LaurentSeries ℚ :=
+  (AdjoinRoot.lift (frickeBaseHom N) jq (eval₂_minpoly_frickeBaseHom data hsymm hirr)).comp
+    (adjoinRootEquivAdjoin ℚ⟮jq⟯ data.isIntegral_jqN).symm.toAlgHom.toRingHom
+
+theorem frickeRelativeHom_gen (hsymm : EvalSymm data.Φ) (hirr : PhiIrreducible data) :
+    frickeRelativeHom data hsymm hirr (AdjoinSimple.gen ℚ⟮jq⟯ (jqN N)) = jq := by
+  rw [frickeRelativeHom, RingHom.comp_apply]
+  rw [show (adjoinRootEquivAdjoin ℚ⟮jq⟯ data.isIntegral_jqN).symm.toAlgHom.toRingHom
+        (AdjoinSimple.gen ℚ⟮jq⟯ (jqN N))
+      = AdjoinRoot.root (minpoly ℚ⟮jq⟯ (jqN N)) from
+    adjoinRootEquivAdjoin_symm_apply_gen ℚ⟮jq⟯ data.isIntegral_jqN]
+  exact AdjoinRoot.lift_root _
+
+theorem frickeRelativeHom_algebraMap (hsymm : EvalSymm data.Φ) (hirr : PhiIrreducible data)
+    (c : ℚ⟮jq⟯) :
+    frickeRelativeHom data hsymm hirr (algebraMap ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN N⟯ c)
+      = frickeBaseHom N c := by
+  rw [frickeRelativeHom, RingHom.comp_apply]
+  rw [show (adjoinRootEquivAdjoin ℚ⟮jq⟯ data.isIntegral_jqN).symm.toAlgHom.toRingHom
+        (algebraMap ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN N⟯ c)
+      = algebraMap ℚ⟮jq⟯ (AdjoinRoot (minpoly ℚ⟮jq⟯ (jqN N))) c from
+    (adjoinRootEquivAdjoin ℚ⟮jq⟯ data.isIntegral_jqN).symm.commutes c]
+  rw [AdjoinRoot.algebraMap_eq]
+  exact AdjoinRoot.lift_of _
+
+end Lift
+
+open W2B
+
+section Absolute
+
+variable (N : ℕ) [NeZero N]
+
+theorem modularFunctionField_eq_restrictScalars :
+    modularFunctionField N = (ℚ⟮jq⟯⟮jqN N⟯).restrictScalars ℚ :=
+  (IntermediateField.adjoin_simple_adjoin_simple ℚ jq (jqN N)).symm
+
+def relativeRingEquiv : ℚ⟮jq⟯⟮jqN N⟯ ≃+* modularFunctionField N where
+  toFun x := ⟨(x : LaurentSeries ℚ),
+    (SetLike.ext_iff.mp (modularFunctionField_eq_restrictScalars N) _).mpr x.2⟩
+  invFun y := ⟨(y : LaurentSeries ℚ),
+    (SetLike.ext_iff.mp (modularFunctionField_eq_restrictScalars N) _).mp y.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  map_mul' _ _ := rfl
+  map_add' _ _ := rfl
+
+variable {N} (data : ModularPolynomialData N)
+
+def frickeAbsoluteHom (hsymm : EvalSymm data.Φ) (hirr : PhiIrreducible data) :
+    modularFunctionField N →+* LaurentSeries ℚ :=
+  (frickeRelativeHom data hsymm hirr).comp (relativeRingEquiv N).symm.toRingHom
+
+theorem frickeAbsoluteHom_jInF (hsymm : EvalSymm data.Φ) (hirr : PhiIrreducible data) :
+    frickeAbsoluteHom data hsymm hirr (⟨jq, jq_mem N⟩ : modularFunctionField N) = jqN N := by
+  change frickeRelativeHom data hsymm hirr ((relativeRingEquiv N).symm (⟨jq, jq_mem N⟩ :
+    modularFunctionField N)) = jqN N
+  rw [show (relativeRingEquiv N).symm (⟨jq, jq_mem N⟩ : modularFunctionField N) = algebraMap ℚ⟮jq⟯
+    ℚ⟮jq⟯⟮jqN N⟯ jGen from
+    Subtype.ext rfl]
+  rw [frickeRelativeHom_algebraMap]
+  rfl
+
+theorem frickeAbsoluteHom_jNInF (hsymm : EvalSymm data.Φ) (hirr : PhiIrreducible data) :
+    frickeAbsoluteHom data hsymm hirr (⟨jqN N, jqN_mem N⟩ : modularFunctionField N) = jq := by
+  change frickeRelativeHom data hsymm hirr ((relativeRingEquiv N).symm (⟨jqN N, jqN_mem N⟩ :
+    modularFunctionField N)) = jq
+  rw [show (relativeRingEquiv N).symm (⟨jqN N, jqN_mem N⟩ : modularFunctionField N) =
+    AdjoinSimple.gen ℚ⟮jq⟯ (jqN N) from
+    Subtype.ext rfl]
+  exact frickeRelativeHom_gen data hsymm hirr
+
+theorem mem_of_apply_gens_mem (f : modularFunctionField N →+* LaurentSeries ℚ)
+    (E : IntermediateField ℚ (LaurentSeries ℚ))
+    (hj : f (⟨jq, jq_mem N⟩ : modularFunctionField N) ∈ E)
+    (hjN : f (⟨jqN N, jqN_mem N⟩ : modularFunctionField N) ∈ E) (x : modularFunctionField N) :
+    f x ∈ E := by
+  obtain ⟨x, hx⟩ := x
+  induction hx using IntermediateField.adjoin_induction with
+  | mem y hyS =>
+      rcases hyS with rfl | rfl
+      · exact hj
+      · exact hjN
+  | algebraMap r =>
+      have hr : (⟨algebraMap ℚ (LaurentSeries ℚ) r,
+          (modularFunctionField N).algebraMap_mem r⟩ : modularFunctionField N)
+          = (r : modularFunctionField N) := by
+        apply Subtype.ext
+        change algebraMap ℚ (LaurentSeries ℚ) r
+          = ((r : modularFunctionField N) : LaurentSeries ℚ)
+        rw [eq_ratCast (algebraMap ℚ (LaurentSeries ℚ)) r]
+        norm_cast
+      have hmem : f (r : modularFunctionField N) ∈ E := by
+        rw [map_ratCast]
+        exact SubfieldClass.ratCast_mem E r
+      exact (congrArg f hr).symm ▸ hmem
+  | add x y hx hy ihx ihy =>
+      change f (⟨x, hx⟩ + ⟨y, hy⟩) ∈ E
+      rw [map_add]
+      exact add_mem ihx ihy
+  | inv x hx ih =>
+      change f (⟨x, hx⟩⁻¹) ∈ E
+      rw [map_inv₀]
+      exact inv_mem ih
+  | mul x y hx hy ihx ihy =>
+      have key : (⟨x * y, mul_mem hx hy⟩ : modularFunctionField N) = ⟨x, hx⟩ * ⟨y, hy⟩ :=
+        Subtype.ext ((modularFunctionField N).coe_mul ⟨x, hx⟩ ⟨y, hy⟩).symm
+      have hmem : f (⟨x, hx⟩ * ⟨y, hy⟩) ∈ E := by
+        rw [map_mul]
+        exact mul_mem ihx ihy
+      exact (congrArg f key).symm ▸ hmem
+
+theorem frickeAbsoluteHom_mem (hsymm : EvalSymm data.Φ) (hirr : PhiIrreducible data)
+    (x : modularFunctionField N) :
+    frickeAbsoluteHom data hsymm hirr x ∈ modularFunctionField N := by
+  refine mem_of_apply_gens_mem (frickeAbsoluteHom data hsymm hirr) (modularFunctionField N)
+    ?_ ?_ x
+  · rw [frickeAbsoluteHom_jInF data hsymm hirr]
+    exact jqN_mem N
+  · rw [frickeAbsoluteHom_jNInF data hsymm hirr]
+    exact jq_mem N
+
+end Absolute
+
+section Endo
+
+variable {N : ℕ} [NeZero N] (data : ModularPolynomialData N)
+
+def frickeEndoRingHom (hsymm : EvalSymm data.Φ) (hirr : PhiIrreducible data) :
+    modularFunctionField N →+* modularFunctionField N :=
+  (frickeAbsoluteHom data hsymm hirr).codRestrict (modularFunctionField N)
+    (frickeAbsoluteHom_mem data hsymm hirr)
+
+def frickeEndoAlgHom (hsymm : EvalSymm data.Φ) (hirr : PhiIrreducible data) :
+    modularFunctionField N →ₐ[ℚ] modularFunctionField N where
+  toRingHom := frickeEndoRingHom data hsymm hirr
+  commutes' r := by
+    rw [eq_ratCast (algebraMap ℚ (modularFunctionField N)) r]
+    exact map_ratCast (frickeEndoRingHom data hsymm hirr) r
+
+theorem frickeEndoAlgHom_jInF (hsymm : EvalSymm data.Φ) (hirr : PhiIrreducible data) :
+    frickeEndoAlgHom data hsymm hirr (⟨jq, jq_mem N⟩ : modularFunctionField N) = (⟨jqN N, jqN_mem N⟩
+      : modularFunctionField N) := by
+  apply Subtype.ext
+  exact frickeAbsoluteHom_jInF data hsymm hirr
+
+theorem frickeEndoAlgHom_jNInF (hsymm : EvalSymm data.Φ) (hirr : PhiIrreducible data) :
+    frickeEndoAlgHom data hsymm hirr (⟨jqN N, jqN_mem N⟩ : modularFunctionField N) = (⟨jq, jq_mem N⟩
+      : modularFunctionField N) := by
+  apply Subtype.ext
+  exact frickeAbsoluteHom_jNInF data hsymm hirr
+
+theorem exists_isFrickeAut_of_modularPolynomialData (hsymm : EvalSymm data.Φ)
+    (hirr : PhiIrreducible data) :
+    ∃ σ : modularFunctionField N ≃ₐ[ℚ] modularFunctionField N, IsFrickeAut N σ :=
+  exists_isFrickeAut_of_endo (frickeEndoAlgHom data hsymm hirr)
+    (frickeEndoAlgHom_jInF data hsymm hirr) (frickeEndoAlgHom_jNInF data hsymm hirr)
+
+end Endo
+end W2B
+end ModularCurve
+
+theorem solution {N : ℕ} [NeZero N] (data : ModularPolynomialData N) (hsymm : EvalSymm data.Φ)
+    (hirr : PhiIrreducible data) :
+    ∃ σ : modularFunctionField N ≃ₐ[ℚ] modularFunctionField N, IsFrickeAut N σ :=
+  ModularCurve.W2B.exists_isFrickeAut_of_modularPolynomialData data hsymm hirr
+
+end
+end S_ModularCurve_exists_isFrickeAut_of_modularPolynomialData
+end P2MW
+export P2MW.S_ModularCurve_exists_isFrickeAut_of_modularPolynomialData (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve IntermediateField
+theorem ModularCurve.exists_isFrickeAut_of_modularPolynomialData {N : ℕ} [NeZero N]
+    (data : ModularPolynomialData N) (hsymm : EvalSymm data.Φ) (hirr : PhiIrreducible data) :
+    ∃ σ : modularFunctionField N ≃ₐ[ℚ] modularFunctionField N, IsFrickeAut N σ :=
+  solution data hsymm hirr
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_isIntegralQExp_smul_of_ratCast_qExpansion.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_isIntegralQExp_smul_of_ratCast_qExpansion.lean
new file mode 100644
index 0000000000..91595fd9eb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_isIntegralQExp_smul_of_ratCast_qExpansion.lean
@@ -0,0 +1,569 @@
+/-
+Based on Prove2Me node ModularCurve.exists_isIntegralQExp_smul_of_ratCast_qExpansion
+(db8627ff-d055-576c-ba3d-7cfc7a6eff5f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5aa971bb-a477-5020-8456-da9adfbc0b4f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_EisensteinWeightOne_e1Chi3IsModular
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_ne_zero_forall_intCast_mul_qExpansion_coeff_of_gamma_invariant
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Bounded denominators for rational q-expansions on Γ₁(M)
+
+Theorem statement: `ModularCurve.exists_isIntegralQExp_smul_of_ratCast_qExpansion`
+(`db8627ff-d055-576c-ba3d-7cfc7a6eff5f`), by Claude, 2026-09-05.
+
+Proof: submission `5aa971bb-a477-5020-8456-da9adfbc0b4f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a natural number, assumed nonzero, and let $k$ be an integer. Let $f$ be a modular form
+of weight $k$ for the subgroup $\Gamma_1(M)$ of $\mathrm{GL}_2(\mathbb{R})$, i.e. for
+`CongruenceSubgroup.Gamma1 M` viewed as a subgroup of $\mathrm{GL}(\mathrm{Fin}\ 2)(\mathbb{R})$.
+Assume that the $q$-expansion of $f$ of width $1$ — the expansion in $q = e^{2\pi i \tau}$ given by
+`UpperHalfPlane.qExpansion 1 f` — has rational coefficients, in the sense that for every natural
+number $n$ there is $r \in \mathbb{Q}$ with $n$-th coefficient equal to the image of $r$ in
+$\mathbb{C}$. The conclusion asserts the existence of a nonzero integer $D$ and a formal power
+series $p \in \mathbb{Z}[[X]]$ such that
+[`ModularCurve.IsIntegralQExp`](def/ModularCurve_X1.html#L37) holds for the function $(D :
+\mathbb{C}) \cdot f$ on the upper half-plane together with $p$; by definition this means that the
+power series obtained from $p$ by applying the ring homomorphism $\mathbb{Z} \to \mathbb{C}$
+coefficientwise equals the width-$1$ $q$-expansion of $D \cdot f$. Thus the denominators of the
+Fourier coefficients of $f$ at $\infty$ are bounded, and some nonzero integer multiple of $f$ has
+integral $q$-expansion.
+
+This is the bounded-denominators statement for modular forms on $\Gamma_1(M)$ with rational Fourier
+expansion at $\infty$: the forms with integral $q$-expansion span, over $\mathbb{Q}$, those with
+rational $q$-expansion. It underlies the construction of integral structures on spaces of modular
+and cusp forms used later, and is invoked throughout the treatment of $q$-expansions on modular
+curves, for instance in producing bases of cusp forms on $\Gamma_1(M)$ whose $q$-coefficients are
+integral. The proof cites the modularity of the weight-one Eisenstein series attached to the cubic
+character and a denominator bound for $\Gamma(N)$-invariant functions with rational $q$-coefficients
+after multiplication by a power of the discriminant.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_isIntegralQExp_smul_of_ratCast_qExpansion.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_isIntegralQExp_smul_of_ratCast_qExpansion
+
+noncomputable section
+
+open Complex UpperHalfPlane ModularForm CongruenceSubgroup Function ModularCurve
+open scoped Real Manifold MatrixGroups ModularForm Topology
+
+namespace X1BoundedDenominators
+
+local notation "Γ₁(" M ")" => ((Gamma1 M : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ))
+local notation "Δ" => ModularForm.discriminant
+
+def IsRat (q : PowerSeries ℂ) : Prop := ∀ n, ∃ r : ℚ, q.coeff n = (r : ℂ)
+
+def IsBdd (q : PowerSeries ℂ) : Prop :=
+  ∃ (D : ℤ) (P : PowerSeries ℤ), D ≠ 0 ∧ P.map (Int.castRingHom ℂ) = (D : ℂ) • q
+
+theorem isRat_iff_exists_map {q : PowerSeries ℂ} :
+    IsRat q ↔ ∃ p : PowerSeries ℚ, p.map (algebraMap ℚ ℂ) = q := by
+  constructor
+  · intro h
+    choose r hr using h
+    exact ⟨PowerSeries.mk r, by ext n; simp [hr n]⟩
+  · rintro ⟨p, rfl⟩ n
+    exact ⟨PowerSeries.coeff n p, by rw [PowerSeries.coeff_map]; rfl⟩
+
+theorem IsRat.mul {q q' : PowerSeries ℂ} (h : IsRat q) (h' : IsRat q') : IsRat (q * q') := by
+  rw [isRat_iff_exists_map] at h h' ⊢
+  obtain ⟨p, rfl⟩ := h
+  obtain ⟨p', rfl⟩ := h'
+  exact ⟨p * p', by rw [map_mul]⟩
+
+theorem IsRat.pow {q : PowerSeries ℂ} (h : IsRat q) (n : ℕ) : IsRat (q ^ n) := by
+  rw [isRat_iff_exists_map] at h ⊢
+  obtain ⟨p, rfl⟩ := h
+  exact ⟨p ^ n, by rw [map_pow]⟩
+
+theorem isRat_of_int {q : PowerSeries ℂ} (P : PowerSeries ℤ) (h : P.map (Int.castRingHom ℂ) = q) :
+    IsRat q := fun n => ⟨((PowerSeries.coeff n P : ℤ) : ℚ), by
+      rw [← h, PowerSeries.coeff_map]; simp⟩
+
+theorem isBdd_iff {q : PowerSeries ℂ} :
+    IsBdd q ↔ ∃ D : ℤ, D ≠ 0 ∧ ∀ n, ∃ z : ℤ, (D : ℂ) * q.coeff n = (z : ℂ) := by
+  constructor
+  · rintro ⟨D, P, hD, hP⟩
+    refine ⟨D, hD, fun n => ⟨PowerSeries.coeff n P, ?_⟩⟩
+    have := congrArg (PowerSeries.coeff n) hP
+    rw [PowerSeries.coeff_map, PowerSeries.coeff_smul, smul_eq_mul] at this
+    rw [← this]; simp
+  · rintro ⟨D, hD, h⟩
+    choose z hz using h
+    refine ⟨D, PowerSeries.mk z, hD, ?_⟩
+    ext n
+    rw [PowerSeries.coeff_map, PowerSeries.coeff_smul, PowerSeries.coeff_mk, smul_eq_mul, hz n]
+    simp
+
+theorem IsBdd.of_mul_eq {q p : PowerSeries ℂ} {U : PowerSeries ℤ}
+    (hU : PowerSeries.constantCoeff U = 1)
+    (hp : IsBdd p) (h : q * U.map (Int.castRingHom ℂ) = p) : IsBdd q := by
+  obtain ⟨D, P, hD, hP⟩ := hp
+  have hUunit : IsUnit U := by
+    rw [PowerSeries.isUnit_iff_constantCoeff, hU]; exact isUnit_one
+  obtain ⟨u, hu⟩ := hUunit
+  refine ⟨D, P * ↑u⁻¹, hD, ?_⟩
+  have h1 : (D : ℂ) • q * U.map (Int.castRingHom ℂ) = P.map (Int.castRingHom ℂ) := by
+    rw [smul_mul_assoc, h, hP]
+  calc (P * ↑u⁻¹).map (Int.castRingHom ℂ)
+      = ((D : ℂ) • q * U.map (Int.castRingHom ℂ)) * (↑u⁻¹ : PowerSeries ℤ).map (Int.castRingHom ℂ)
+        := by
+        rw [map_mul, h1]
+    _ = (D : ℂ) • q * ((U * ↑u⁻¹).map (Int.castRingHom ℂ)) := by rw [map_mul, mul_assoc]
+    _ = (D : ℂ) • q := by rw [← hu, Units.mul_inv, map_one, mul_one]
+
+section Level
+
+variable {M : ℕ} {k : ℤ}
+
+theorem T_pow_mem_Gamma1 (M : ℕ) (t : ℤ) : ModularGroup.T ^ t ∈ Gamma1 M := by
+  rw [Gamma1_mem, ModularGroup.coe_T_zpow]
+  simp
+
+theorem T_mem_Gamma1 (M : ℕ) : ModularGroup.T ∈ Gamma1 M := by
+  simp
+
+theorem one_mem_strictPeriods (M : ℕ) : (1 : ℝ) ∈ (Γ₁(M)).strictPeriods := by
+  rw [Subgroup.strictPeriods_eq_zmultiples_one_of_T_mem (T_mem_Gamma1 M)]
+  exact AddSubgroup.mem_zmultiples 1
+
+theorem Gamma_le_Gamma1 (M : ℕ) : CongruenceSubgroup.Gamma M ≤ Gamma1 M := by
+  intro g hg
+  rw [Gamma_mem] at hg
+  rw [Gamma1_mem]
+  exact ⟨hg.1, hg.2.2.2, hg.2.2.1⟩
+
+theorem isBoundedAtImInfty_slash [NeZero M] (f : ModularForm Γ₁(M) k) (γ : SL(2, ℤ)) :
+    IsBoundedAtImInfty ((⇑f : ℍ → ℂ) ∣[k] γ) := by
+  rw [ModularForm.SL_slash, ← OnePoint.isBoundedAt_infty_iff, ← OnePoint.IsBoundedAt.smul_iff]
+  apply f.bdd_at_cusps'
+  rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z]
+  exact isCusp_SL2Z_iff'.mpr ⟨γ, rfl⟩
+
+private theorem _root_.X1BoundedDenominators.Gamma1_le_of_dvd {M' : ℕ} (h : M ∣ M') :
+    Gamma1 M' ≤ Gamma1 M := ModularCurve.Gamma1_le_of_dvd h
+
+p2m_export "X1BoundedDenominators" "Gamma1_le_of_dvd"
+
+def res {M' : ℕ} (h : M ∣ M') (f : ModularForm Γ₁(M) k) : ModularForm Γ₁(M') k :=
+  restrictForm (Subgroup.map_mono (Gamma1_le_of_dvd h)) f
+
+@[scoped simp] theorem coe_res {M' : ℕ} (h : M ∣ M') (f : ModularForm Γ₁(M) k) :
+    (⇑(res h f) : ℍ → ℂ) = f := rfl
+
+def resSL (M : ℕ) {k : ℤ} (f : ModularForm 𝒮ℒ k) : ModularForm Γ₁(M) k :=
+  restrictForm (Subgroup.map_le_range _ _) f
+
+@[scoped simp] theorem coe_resSL (M : ℕ) {k : ℤ} (f : ModularForm 𝒮ℒ k) :
+    (⇑(resSL M f) : ℍ → ℂ) = f := rfl
+
+end Level
+
+section Width
+
+theorem qExpansion_coeff_unique' {h : ℝ} (hh : 0 < h) {g : ℍ → ℂ} {c : ℕ → ℂ}
+    (hg : AnalyticAt ℂ (cuspFunction h g) 0)
+    (hc : ∀ τ : ℍ, HasSum (fun m => c m • Periodic.qParam h τ ^ m) (g τ)) (m : ℕ) :
+    c m = (qExpansion h g).coeff m := by
+  have h1 := (hasFPowerSeriesOnBall_cuspFunction hh hg hc).hasFPowerSeriesAt
+  have h2 : HasFPowerSeriesAt (cuspFunction h g)
+      (FormalMultilinearSeries.ofScalars ℂ fun m => (qExpansion h g).coeff m) 0 := by
+    simpa [qExpansion_coeff, div_eq_mul_inv, mul_comm] using hg.hasFPowerSeriesAt
+  simpa [FormalMultilinearSeries.coeff_ofScalars] using
+    congr_arg (FormalMultilinearSeries.coeff · m) (h1.eq_formalMultilinearSeries h2)
+
+variable (N : ℕ) [NeZero N]
+
+theorem natCast_pos : (0 : ℝ) < (N : ℝ) := Nat.cast_pos.mpr (NeZero.pos N)
+
+theorem qParam_one_eq_pow (τ : ℍ) : Periodic.qParam 1 τ = Periodic.qParam N τ ^ N := by
+  simp only [Periodic.qParam]
+  rw [← Complex.exp_nat_mul]
+  congr 1
+  have : (N : ℂ) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne N)
+  push_cast
+  field_simp
+
+theorem periodic_ofComplex_natCast {g : ℍ → ℂ} (h : Periodic (g ∘ ofComplex) 1) (n : ℕ) :
+    Periodic (g ∘ ofComplex) n := by
+  simpa using h.nat_mul n
+
+theorem qExpansion_coeff_widthN {g : ℍ → ℂ} (hg : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hper : Periodic (g ∘ ofComplex) 1) (hbd : IsBoundedAtImInfty g) (n : ℕ) :
+    (qExpansion N g).coeff n = if (N : ℕ) ∣ n then (qExpansion 1 g).coeff (n / N) else 0 := by
+  classical
+  have hperN : Periodic (g ∘ ofComplex) N := periodic_ofComplex_natCast hper N
+  set c : ℕ → ℂ := fun n => if (N : ℕ) ∣ n then (qExpansion 1 g).coeff (n / N) else 0 with hc
+  have hNpos : 0 < N := NeZero.pos N
+  have hsum : ∀ τ : ℍ, HasSum (fun m => c m • Periodic.qParam N τ ^ m) (g τ) := by
+    intro τ
+    have h1 := hasSum_qExpansion one_pos hper hg hbd τ
+    have hinj : Function.Injective fun m : ℕ => N * m := mul_right_injective₀ hNpos.ne'
+    have hsupp : ∀ x ∉ Set.range (fun m : ℕ => N * m),
+        (fun m => c m • Periodic.qParam N τ ^ m) x = 0 := by
+      intro x hx
+      have : ¬ (N : ℕ) ∣ x := by
+        rintro ⟨y, rfl⟩; exact hx ⟨y, rfl⟩
+      simp [hc, this]
+    refine (hinj.hasSum_iff hsupp).1 ?_
+    convert h1 using 1
+    funext m
+    simp only [comp_apply, hc, dvd_mul_right, ↓reduceIte, Nat.mul_div_cancel_left _ hNpos]
+    rw [qParam_one_eq_pow N τ, ← pow_mul]
+  rw [← qExpansion_coeff_unique' (natCast_pos N) (analyticAt_cuspFunction_zero (natCast_pos N)
+    hperN hg hbd) hsum n]
+
+theorem coeff_widthN_mul {g : ℍ → ℂ} (hg : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hper : Periodic (g ∘ ofComplex) 1) (hbd : IsBoundedAtImInfty g) (n : ℕ) :
+    (qExpansion N g).coeff (N * n) = (qExpansion 1 g).coeff n := by
+  rw [qExpansion_coeff_widthN N hg hper hbd, ite_eq_left (dvd_mul_right N n),
+    Nat.mul_div_cancel_left _ (NeZero.pos N)]
+
+end Width
+
+section Core
+
+variable {M : ℕ} [NeZero M] {k : ℤ}
+
+theorem disc_smul (α : SL(2, ℤ)) (τ : ℍ) :
+    Δ (α • τ) = denom (α : GL (Fin 2) ℝ) τ ^ (12 : ℤ) * Δ τ := by
+  have := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant (Γ := 𝒮ℒ)
+    (γ := (α : GL (Fin 2) ℝ)) ⟨α, rfl⟩ τ
+  rw [CuspForm.coe_discriminant, ← ModularGroup.sl_moeb] at this
+  exact this
+
+theorem levelOne_smul {k' : ℤ} (E : ModularForm 𝒮ℒ k') (α : SL(2, ℤ)) (τ : ℍ) :
+    E (α • τ) = denom (α : GL (Fin 2) ℝ) τ ^ k' * E τ := by
+  have := SlashInvariantForm.slash_action_eqn'' E (Γ := 𝒮ℒ) (γ := (α : GL (Fin 2) ℝ)) ⟨α, rfl⟩ τ
+  rw [← ModularGroup.sl_moeb] at this
+  exact this
+
+theorem isBdd_mul (f : ModularForm Γ₁(M) k) (m : ℕ) {kE : ℤ} (E : ModularForm 𝒮ℒ kE)
+    (hkE : k + kE = 12 * m) (hf : IsRat (qExpansion 1 f)) (hE : IsRat (qExpansion 1 E)) :
+    IsBdd (qExpansion 1 ((⇑f : ℍ → ℂ) * ⇑E)) := by
+  set H : ℍ → ℂ := (⇑f : ℍ → ℂ) * ⇑E with hH
+  set G : ℍ → ℂ := fun τ => H τ / (Δ τ) ^ m with hG
+  have hΔ : ∀ τ : ℍ, (Δ τ) ^ m ≠ 0 := fun τ => pow_ne_zero _ (discriminant_ne_zero τ)
+  have hGΔ : G * Δ ^ m = H := by
+    funext τ; simp only [Pi.mul_apply, Pi.pow_apply, hG]; field_simp [hΔ τ]
+  set HF : ModularForm Γ₁(M) (k + kE) := f.mul (resSL M E) with hHF
+  have hHF_coe : (⇑HF : ℍ → ℂ) = H := by rw [hHF, coe_mul, coe_resSL]
+  have hmdH : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) H := f.holo'.mul E.holo'
+  have hperH : Periodic (H ∘ ofComplex) 1 := by
+    rw [←
+      hHF_coe]; exact SlashInvariantFormClass.periodic_comp_ofComplex HF (one_mem_strictPeriods M)
+  have hbdH : IsBoundedAtImInfty H := by
+    have := (isBoundedAtImInfty_slash f 1).mul (ModularFormClass.bdd_at_infty E)
+    simpa only [SlashAction.slash_one, IsBoundedAtImInfty] using this
+  have hmdΔ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (Δ : ℍ → ℂ) := by
+    rw [← CuspForm.coe_discriminant]; exact CuspForm.discriminant.holo'
+  have hmdG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G := by
+    intro τ
+    exact (hmdH τ).div ((hmdΔ τ).pow m) (hΔ τ)
+  have hcw : ∀ α : SL(2, ℤ), (fun τ => G (α • τ)) * Δ ^ m = ((⇑f : ℍ → ℂ) ∣[k] α) * ⇑E := by
+    intro α
+    funext τ
+    have hd : denom (α : GL (Fin 2) ℝ) τ ≠ 0 := denom_ne_zero _ τ
+    simp only [Pi.mul_apply, Pi.pow_apply, hG, hH]
+    rw [ModularForm.SL_slash_apply, disc_smul, levelOne_smul E, ModularGroup.sl_moeb]
+    have hpow : (denom (α : GL (Fin 2) ℝ) τ ^ (12 : ℤ) * Δ τ) ^ m
+        = denom (α : GL (Fin 2) ℝ) τ ^ (k + kE) * (Δ τ) ^ m := by
+      rw [mul_pow, ← zpow_natCast, ← zpow_mul, hkE]
+    rw [hpow, zpow_add₀ hd, zpow_neg]
+    field_simp [hΔ τ, zpow_ne_zero k hd, zpow_ne_zero kE hd]
+  have hinv1 : ∀ g ∈ Gamma1 M, ∀ τ : ℍ, G (g • τ) = G τ := by
+    intro g hg τ
+    have h1 := congrFun (hcw g) τ
+    simp only [Pi.mul_apply, Pi.pow_apply] at h1
+    have h2 : ((⇑f : ℍ → ℂ) ∣[k] g) = ⇑f := by
+      rw [ModularForm.SL_slash]
+      exact SlashInvariantFormClass.slash_action_eq f _ (Subgroup.mem_map_of_mem _ hg)
+    rw [h2] at h1
+    have h3 : G τ * Δ τ ^ m = f τ * E τ := by
+      have := congrFun hGΔ τ; simpa only [Pi.mul_apply, Pi.pow_apply, hH] using this
+    exact mul_right_cancel₀ (hΔ τ) (h1.trans h3.symm)
+  have hinv : ∀ g ∈ CongruenceSubgroup.Gamma M, ∀ τ : ℍ, G (g • τ) = G τ := fun g hg =>
+    hinv1 g (Gamma_le_Gamma1 M hg)
+  have hbd : ∀ α : SL(2, ℤ), IsBoundedAtImInfty ((fun τ => G (α • τ)) * Δ ^ m) := by
+    intro α
+    rw [hcw α]
+    exact (isBoundedAtImInfty_slash f α).mul (ModularFormClass.bdd_at_infty E)
+  have hrat1 : IsRat (qExpansion 1 H) := by
+    rw [hH]
+    have : qExpansion 1 ((⇑f : ℍ → ℂ) * ⇑E) = qExpansion 1 ⇑f * qExpansion 1 ⇑(resSL M E) := by
+      rw [← coe_resSL M E, ModularForm.qExpansion_mul_coe one_pos (one_mem_strictPeriods M) f (resSL
+        M E)]
+    rw [this]
+    exact hf.mul hE
+  have hratM : ∀ n, ∃ r : ℚ, (qExpansion M (G * Δ ^ m)).coeff n = (r : ℂ) := by
+    intro n
+    rw [hGΔ, qExpansion_coeff_widthN M hmdH hperH hbdH n]
+    split_ifs
+    · exact hrat1 _
+    · exact ⟨0, by simp⟩
+  obtain ⟨D, hD, hint⟩ :=
+    ModularCurve.exists_ne_zero_forall_intCast_mul_qExpansion_coeff_of_gamma_invariant M m G hmdG
+      hinv
+      hbd hratM
+  rw [isBdd_iff]
+  refine ⟨D, hD, fun n => ?_⟩
+  obtain ⟨z, hz⟩ := hint (M * n)
+  refine ⟨z, ?_⟩
+  rw [hGΔ, coeff_widthN_mul M hmdH hperH hbdH n] at hz
+  exact hz
+
+end Core
+
+section Even
+
+variable {M : ℕ} [NeZero M] {k : ℤ}
+
+def P4 : PowerSeries ℤ :=
+  PowerSeries.mk fun m => if m = 0 then 1 else 240 * (ArithmeticFunction.sigma 3 m : ℤ)
+
+def P6 : PowerSeries ℤ :=
+  PowerSeries.mk fun m => if m = 0 then 1 else -504 * (ArithmeticFunction.sigma 5 m : ℤ)
+
+theorem map_P4 : P4.map (Int.castRingHom ℂ) = qExpansion 1 (E₄ : ℍ → ℂ) := by
+  ext n
+  rw [PowerSeries.coeff_map, ModularForm.E₄, EisensteinSeries.E_qExpansion_coeff (by
+    norm_num) (by
+      decide) n,
+    P4, PowerSeries.coeff_mk, eq_intCast]
+  split_ifs with h
+  · simp
+  · rw [show _root_.bernoulli 4 = -1 / 30 by
+      rw [bernoulli_eq_bernoulli'_of_ne_one (by norm_num), bernoulli'_four]]
+    push_cast
+    ring
+
+theorem bernoulli'_six : bernoulli' 6 = 1 / 42 := by
+  rw [bernoulli'_def]
+  norm_num [Finset.sum_range_succ, bernoulli'_zero, bernoulli'_one, bernoulli'_two,
+    bernoulli'_three,
+    bernoulli'_four, Nat.choose]
+  have h5 : bernoulli' 5 = 0 := bernoulli'_eq_zero_of_odd (by decide) (by norm_num)
+  rw [h5]
+  norm_num
+
+theorem map_P6 : P6.map (Int.castRingHom ℂ) = qExpansion 1 (E₆ : ℍ → ℂ) := by
+  ext n
+  rw [PowerSeries.coeff_map, ModularForm.E₆, EisensteinSeries.E_qExpansion_coeff (by
+    norm_num) (by
+      decide) n,
+    P6, PowerSeries.coeff_mk, eq_intCast]
+  split_ifs with h
+  · simp
+  · rw [show _root_.bernoulli 6 = 1 / 42 by
+      rw [bernoulli_eq_bernoulli'_of_ne_one (by norm_num), bernoulli'_six]]
+    push_cast
+    ring
+
+theorem constantCoeff_P4 : PowerSeries.constantCoeff P4 = 1 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff_apply, P4, PowerSeries.coeff_mk]; simp
+
+theorem constantCoeff_P6 : PowerSeries.constantCoeff P6 = 1 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff_apply, P6, PowerSeries.coeff_mk]; simp
+
+def Eaux (a b : ℕ) : ModularForm 𝒮ℒ (a * 4 + b * 6) := (E₄.pow a).mul (E₆.pow b)
+
+theorem qExpansion_Eaux (a b : ℕ) :
+    qExpansion 1 (⇑(Eaux a b)) = (P4 ^ a * P6 ^ b).map (Int.castRingHom ℂ) := by
+  rw [Eaux, coe_mul, ModularForm.qExpansion_mul_coe one_pos one_mem_strictPeriods_SL,
+    ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL,
+    ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL, map_mul, map_pow, map_pow, map_P4,
+    map_P6]
+
+theorem isRat_Eaux (a b : ℕ) : IsRat (qExpansion 1 (⇑(Eaux a b))) :=
+  isRat_of_int _ (qExpansion_Eaux a b).symm
+
+theorem constantCoeff_Eaux (a b : ℕ) : PowerSeries.constantCoeff (P4 ^ a * P6 ^ b) = 1 := by
+  rw [map_mul, map_pow, map_pow, constantCoeff_P4, constantCoeff_P6, one_pow, one_pow, one_mul]
+
+theorem exists_weights (hk : Even k) : ∃ (m a b : ℕ), k + (a * 4 + b * 6 : ℕ) = 12 * (m : ℤ) := by
+  obtain ⟨j, rfl⟩ := hk
+  rcases Int.emod_two_eq_zero_or_one j with hpar | hpar
+  · set q : ℤ := j / 2 with hq
+    have hjq : j = 2 * q := by omega
+    have h0 : 0 ≤ 3 * (j.natAbs : ℤ) + 3 - q := by omega
+    obtain ⟨a, ha⟩ := Int.eq_ofNat_of_zero_le h0
+    refine ⟨j.natAbs + 1, a, 0, ?_⟩
+    simp only [Nat.cast_add, Nat.cast_mul, Nat.cast_ofNat, Nat.cast_one, ← ha]
+    omega
+  · set q : ℤ := j / 2 with hq
+    have hjq : j = 2 * q + 1 := by omega
+    have h0 : 0 ≤ 3 * (j.natAbs : ℤ) + 1 - q := by omega
+    obtain ⟨a, ha⟩ := Int.eq_ofNat_of_zero_le h0
+    refine ⟨j.natAbs + 1, a, 1, ?_⟩
+    simp only [Nat.cast_add, Nat.cast_mul, Nat.cast_ofNat, Nat.cast_one, ← ha]
+    omega
+
+theorem isBdd_of_even (hk : Even k) (f : ModularForm Γ₁(M) k) (hf : IsRat (qExpansion 1 f)) :
+    IsBdd (qExpansion 1 f) := by
+  obtain ⟨m, a, b, hw⟩ := exists_weights hk
+  have key := isBdd_mul f m (Eaux a b) (by exact_mod_cast hw) hf (isRat_Eaux a b)
+  have hprod : qExpansion 1 ((⇑f : ℍ → ℂ) * ⇑(Eaux a b))
+      = qExpansion 1 (⇑f : ℍ → ℂ) * (P4 ^ a * P6 ^ b).map (Int.castRingHom ℂ) := by
+    rw [← qExpansion_Eaux, ← coe_resSL M (Eaux a b),
+      ModularForm.qExpansion_mul_coe one_pos (one_mem_strictPeriods M) f (resSL M (Eaux a b))]
+  exact IsBdd.of_mul_eq (constantCoeff_Eaux a b) key hprod.symm
+
+end Even
+
+section Odd
+
+theorem exists_E1 : ∃ E : ModularForm Γ₁(3) 1,
+    EisensteinWeightOne.e1Chi3.map (Int.castRingHom ℂ) = qExpansion 1 (E : ℍ → ℂ) ∧
+      PowerSeries.constantCoeff EisensteinWeightOne.e1Chi3 = 1 := by
+  obtain ⟨E, hE⟩ := EisensteinWeightOne.e1Chi3IsModular
+  refine ⟨E, ?_, ?_⟩
+  swap
+  · rw [← PowerSeries.coeff_zero_eq_constantCoeff_apply]
+    simp [EisensteinWeightOne.e1Chi3]
+  set c : ℕ → ℤ := fun n => PowerSeries.coeff n EisensteinWeightOne.e1Chi3 with hc
+  have hchi : ∀ d : ℕ, |EisensteinWeightOne.chiNegThree d| ≤ 1 := by
+    intro d
+    unfold EisensteinWeightOne.chiNegThree
+    split_ifs <;> simp
+  have hcbound : ∀ n : ℕ, ‖((c n : ℤ) : ℂ)‖ ≤ 6 * n + 1 := by
+    intro n
+    rw [Complex.norm_intCast]
+    simp only [hc, EisensteinWeightOne.e1Chi3, PowerSeries.coeff_mk]
+    split_ifs with h0
+    · subst h0; simp
+    · have h1 : |EisensteinWeightOne.sigmaChi n| ≤ n := by
+        unfold EisensteinWeightOne.sigmaChi
+        calc |∑ d ∈ n.divisors, EisensteinWeightOne.chiNegThree d|
+            ≤ ∑ d ∈ n.divisors, |EisensteinWeightOne.chiNegThree d| := Finset.abs_sum_le_sum_abs _ _
+          _ ≤ ∑ _d ∈ n.divisors, (1 : ℤ) := Finset.sum_le_sum fun d _ => hchi d
+          _ = n.divisors.card := by simp
+          _ ≤ n := by exact_mod_cast Nat.card_divisors_le_self n
+      have h2 : |6 * EisensteinWeightOne.sigmaChi n| ≤ 6 * (n : ℤ) + 1 := by
+        rw [abs_mul, abs_of_nonneg (by norm_num : (0:ℤ) ≤ 6)]; linarith
+      rw [← Int.cast_abs]
+      exact_mod_cast h2
+  have hsum : ∀ z : ℍ, HasSum (fun n : ℕ => ((c n : ℤ) : ℂ) • Periodic.qParam 1 z ^ n) (E z) := by
+    intro z
+    have hq : ‖Periodic.qParam 1 z‖ < 1 := by
+      have : 0 < 2 * π * z.im / 1 := by have := z.im_pos; positivity
+      simpa [Periodic.qParam, Complex.norm_exp, neg_div] using this
+    have hterm : ∀ n : ℕ, ((c n : ℤ) : ℂ) * Complex.exp (2 * (Real.pi : ℂ) * Complex.I * (n : ℂ) *
+      (z : ℂ))
+        = ((c n : ℤ) : ℂ) • Periodic.qParam 1 z ^ n := by
+      intro n
+      rw [smul_eq_mul, Periodic.qParam, ← Complex.exp_nat_mul]
+      congr 2
+      push_cast
+      ring
+    have hS : Summable (fun n : ℕ => ((c n : ℤ) : ℂ) • Periodic.qParam 1 z ^ n) := by
+      apply Summable.of_norm_bounded (g := fun n : ℕ => (6 * n + 1) * ‖Periodic.qParam 1 z‖ ^ n)
+      · have h1 :=
+          summable_pow_mul_geometric_of_norm_lt_one 1 (r := ‖Periodic.qParam 1 z‖) (by
+            simpa using hq)
+        have h2 :=
+          summable_geometric_of_norm_lt_one (R := ℝ) (by
+            simpa using hq : ‖‖Periodic.qParam 1 z‖‖ < 1)
+        have := (h1.mul_left 6).add h2
+        refine this.congr fun n => ?_
+        simp only [pow_one]; ring
+      · intro n
+        rw [norm_smul, norm_pow]
+        exact mul_le_mul_of_nonneg_right (hcbound n) (pow_nonneg (norm_nonneg _) _)
+    have := hS.hasSum
+    have hEz : (∑' n : ℕ, ((c n : ℤ) : ℂ) • Periodic.qParam 1 z ^ n) = E z := by
+      rw [hE z]; exact tsum_congr fun n => (hterm n).symm
+    rwa [hEz] at this
+  have hcoef : ∀ n, ((c n : ℤ) : ℂ) = (qExpansion 1 (E : ℍ → ℂ)).coeff n := fun n =>
+    ModularFormClass.qExpansion_coeff_unique one_pos (one_mem_strictPeriods 3) hsum n
+  ext n
+  rw [PowerSeries.coeff_map, ← hcoef n]
+  rfl
+
+variable {M : ℕ} [NeZero M] {k : ℤ}
+
+theorem isBdd_of_odd (hk : Odd k) (f : ModularForm Γ₁(M) k) (hf : IsRat (qExpansion 1 f)) :
+    IsBdd (qExpansion 1 f) := by
+  obtain ⟨E, hE, hE0⟩ := exists_E1
+  have : NeZero (3 * M) := ⟨mul_ne_zero three_ne_zero (NeZero.ne M)⟩
+  set f3 : ModularForm Γ₁(3 * M) k := res (dvd_mul_left M 3) f with hf3
+  set E3 : ModularForm Γ₁(3 * M) 1 := res (dvd_mul_right 3 M) E with hE3
+  set F : ModularForm Γ₁(3 * M) (k + 1) := f3.mul E3 with hF
+  have hprod : qExpansion 1 (F : ℍ → ℂ) = qExpansion 1 (f : ℍ → ℂ) *
+      EisensteinWeightOne.e1Chi3.map (Int.castRingHom ℂ) := by
+    rw [hF, coe_mul, ModularForm.qExpansion_mul_coe one_pos (one_mem_strictPeriods (3 * M)) f3 E3,
+      hE]
+    rfl
+  have hFrat : IsRat (qExpansion 1 F) := by
+    rw [hprod]
+    exact hf.mul (isRat_of_int _ rfl)
+  have hk1 : Even (k + 1) := hk.add_one
+  have key := isBdd_of_even hk1 F hFrat
+  exact IsBdd.of_mul_eq hE0 key hprod.symm
+
+end Odd
+
+theorem isBdd_of_isRat {M : ℕ} [NeZero M] {k : ℤ} (f : ModularForm Γ₁(M) k)
+    (hf : IsRat (qExpansion 1 f)) :
+    IsBdd (qExpansion 1 f) := by
+  rcases Int.even_or_odd k with hk | hk
+  · exact isBdd_of_even hk f hf
+  · exact isBdd_of_odd hk f hf
+
+theorem main (M : ℕ) [NeZero M] {k : ℤ} (f : ModularForm Γ₁(M) k) (hf : IsRat (qExpansion 1 f)) :
+    ∃ (D : ℤ) (p : PowerSeries ℤ), D ≠ 0 ∧ IsIntegralQExp ((D : ℂ) • (⇑f : ℍ → ℂ)) p := by
+  obtain ⟨D, P, hD, hP⟩ := isBdd_of_isRat f hf
+  refine ⟨D, P, hD, ?_⟩
+  rw [IsIntegralQExp, hP]
+  have : ((D : ℂ) • (⇑f : ℍ → ℂ)) = ⇑((D : ℂ) • f) := by rw [FunLike.coe_smul]
+  rw [this, ← ModularForm.qExpansion_smul one_pos (one_mem_strictPeriods M)]
+  rfl
+
+end X1BoundedDenominators
+end
+
+theorem solution (M : ℕ) [NeZero M] {k : ℤ}
+    (f : ModularForm (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) k)
+    (hf : ∀ n : ℕ, ∃ r : ℚ, (UpperHalfPlane.qExpansion 1 f).coeff n = (r : ℂ)) :
+    ∃ (D : ℤ) (p : PowerSeries ℤ), D ≠ 0 ∧
+      ModularCurve.IsIntegralQExp ((D : ℂ) • (⇑f : UpperHalfPlane → ℂ)) p :=
+  X1BoundedDenominators.main M f hf
+
+end S_ModularCurve_exists_isIntegralQExp_smul_of_ratCast_qExpansion
+end P2MW
+export P2MW.S_ModularCurve_exists_isIntegralQExp_smul_of_ratCast_qExpansion (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.exists_isIntegralQExp_smul_of_ratCast_qExpansion (M : ℕ) [NeZero M] {k : ℤ}
+    (f : ModularForm (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) k)
+    (hf : ∀ n : ℕ, ∃ r : ℚ, (UpperHalfPlane.qExpansion 1 f).coeff n = (r : ℂ)) :
+    ∃ (D : ℤ) (p : PowerSeries ℤ), D ≠ 0 ∧
+      ModularCurve.IsIntegralQExp ((D : ℂ) • (⇑f : UpperHalfPlane → ℂ)) p :=
+  solution M f hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_isIntegralQExp_smul_slash_of_mem_Gamma0.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_isIntegralQExp_smul_slash_of_mem_Gamma0.lean
new file mode 100644
index 0000000000..a44fb2fd35
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_isIntegralQExp_smul_slash_of_mem_Gamma0.lean
@@ -0,0 +1,168 @@
+/-
+Based on Prove2Me node ModularCurve.exists_isIntegralQExp_smul_slash_of_mem_Gamma0
+(b222066f-2929-5fa8-b798-301ea061b0b8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission fac53f21-6af3-5d32-b373-7a3d3084334f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_isIntegralQExp_smul_of_ratCast_qExpansion
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_ratCast_qExpansion_slash_of_mem_Gamma0
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Slash by Γ₀(M) has integral q-expansion after scaling
+
+Theorem statement: `ModularCurve.exists_isIntegralQExp_smul_slash_of_mem_Gamma0`
+(`b222066f-2929-5fa8-b798-301ea061b0b8`), by Claude, 2026-09-05.
+
+Proof: submission `fac53f21-6af3-5d32-b373-7a3d3084334f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a positive natural number, $k$ an integer, and let $f$ be a modular form of weight $k$
+for the subgroup of $\mathrm{GL}_2(\mathbb{R})$ obtained as the image of $\Gamma_1(M) \le
+\mathrm{SL}_2(\mathbb{Z})$. Suppose $p \in \mathbb{Z}[[X]]$ satisfies [`ModularCurve.IsIntegralQExp
+f p`](def/ModularCurve_X1.html#L37), that is, the image of $p$ under the coefficientwise map
+$\mathbb{Z} \to \mathbb{C}$ equals the $q$-expansion of $f$ of width $1$ (so $f$ has integral
+Fourier coefficients at $\infty$, with $p$ the generating series). Let $\gamma \in
+\mathrm{SL}_2(\mathbb{Z})$ lie in $\Gamma_0(M)$. Then there exist a nonzero integer $D$, a modular
+form $f_1$ of weight $k$ for the same subgroup coming from $\Gamma_1(M)$, and a power series $p_1
+\in \mathbb{Z}[[X]]$, such that the image of $p_1$ in $\mathbb{C}[[X]]$ is the width-$1$
+$q$-expansion of $f_1$, and such that, as functions on the upper half-plane, $f_1 = D \cdot (f
+\mid_k \gamma)$, the weight-$k$ slash of $f$ by $\gamma$. Thus the slash of $f$ by an element of
+$\Gamma_0(M)$ has Fourier coefficients at $\infty$ that are rational with a common bounded
+denominator $D$.
+
+The slash of $f$ by $\gamma \in \Gamma_0(M)$ is the action of the diamond operator $\langle \delta
+\rangle$, $\delta$ the lower-right entry of $\gamma$, on forms of level $M$; the statement records
+that this action preserves integrality of Fourier expansions up to a nonzero integer denominator. It
+is used in the construction of the integral/rational structure on the modular curve $X_1(M)$ and on
+spaces of forms of level $M$, in particular in the treatment of the diamond automorphisms of
+$X_1(M)$ and in the integrality statements for $q$-expansions of cusp forms twisted by such
+operators.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_isIntegralQExp_smul_slash_of_mem_Gamma0.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_isIntegralQExp_smul_slash_of_mem_Gamma0
+
+noncomputable section
+
+open UpperHalfPlane ModularForm CongruenceSubgroup Function ModularCurve
+open scoped MatrixGroups ModularForm Manifold
+
+namespace X1DiamondIntegral
+
+local notation "Γ₁(" M ")" => ((Gamma1 M : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ))
+
+variable {M : ℕ} {k : ℤ}
+
+theorem conj_mem_Gamma1 {γ A : SL(2, ℤ)} (hγ : γ ∈ Gamma0 M) (hA : A ∈ Gamma1 M) :
+    γ * A * γ⁻¹ ∈ Gamma1 M := by
+  have hA0 : A ∈ Gamma0 M := Gamma1_in_Gamma0 M hA
+  set A₀ : Gamma0 M := ⟨A, hA0⟩
+  set γ₀ : Gamma0 M := ⟨γ, hγ⟩
+  have hA1 : A₀ ∈ Gamma1' M := by
+    rw [Gamma1_to_Gamma0_mem]
+    exact (Gamma1_mem M A).mp hA
+  have : (Gamma1' M).Normal := by
+    change ((Gamma0Map M).ker).Normal
+    infer_instance
+  have hconj : γ₀ * A₀ * γ₀⁻¹ ∈ Gamma1' M := Subgroup.Normal.conj_mem inferInstance A₀ hA1 γ₀
+  rw [Gamma1_to_Gamma0_mem] at hconj
+  rw [Gamma1_mem]
+  exact hconj
+
+def diamondSlash [NeZero M] (γ : SL(2, ℤ)) (hγ : γ ∈ Gamma0 M) (f : ModularForm Γ₁(M) k) :
+    ModularForm Γ₁(M) k where
+  toFun := (⇑f : ℍ → ℂ) ∣[k] (γ : GL (Fin 2) ℝ)
+  slash_action_eq' := by
+    intro A hA
+    obtain ⟨A, hA, rfl⟩ := hA
+    have hconj : γ * A * γ⁻¹ ∈ Gamma1 M := conj_mem_Gamma1 hγ hA
+    have hGL : (γ : GL (Fin 2) ℝ) * (A : GL (Fin 2) ℝ)
+        = ((γ * A * γ⁻¹ : SL(2, ℤ)) : GL (Fin 2) ℝ) * (γ : GL (Fin 2) ℝ) := by
+      simp only [map_mul, map_inv, inv_mul_cancel_right]
+    change ((⇑f : ℍ → ℂ) ∣[k] (γ : GL (Fin 2) ℝ)) ∣[k] (A : GL (Fin 2) ℝ)
+      = (⇑f : ℍ → ℂ) ∣[k] (γ : GL (Fin 2) ℝ)
+    rw [← SlashAction.slash_mul, hGL, SlashAction.slash_mul]
+    congr 1
+    exact SlashInvariantFormClass.slash_action_eq f _ (Subgroup.mem_map_of_mem _ hconj)
+  holo' := f.holo'.slash k _
+  bdd_at_cusps' := by
+    intro c hc
+    have hcSL : IsCusp c 𝒮ℒ := (Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z Γ₁(M)).mp hc
+    have hc' : IsCusp ((γ : GL (Fin 2) ℝ) • c) Γ₁(M) := by
+      rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z]
+      exact hcSL.smul_of_mem ⟨γ, rfl⟩
+    exact OnePoint.IsBoundedAt.smul_iff.mp (f.bdd_at_cusps' hc')
+
+theorem coe_diamondSlash [NeZero M] (γ : SL(2, ℤ)) (hγ : γ ∈ Gamma0 M) (f : ModularForm Γ₁(M) k) :
+    (⇑(diamondSlash γ hγ f) : ℍ → ℂ) = (⇑f : ℍ → ℂ) ∣[k] γ := by
+  rw [ModularForm.SL_slash]; rfl
+
+theorem rat_of_isIntegralQExp {f : ℍ → ℂ} {p : PowerSeries ℤ} (h : IsIntegralQExp f p) (n : ℕ) :
+    ∃ r : ℚ, (qExpansion 1 f).coeff n = (r : ℂ) :=
+  ⟨(PowerSeries.coeff n p : ℤ), by rw [← h.coeff n]; push_cast; rfl⟩
+
+end X1DiamondIntegral
+
+open X1DiamondIntegral in
+theorem solution (M : ℕ) [NeZero M] {k : ℤ}
+    (f : ModularForm (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) k)
+    {p : PowerSeries ℤ} (hp : ModularCurve.IsIntegralQExp f p)
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    ∃ (D : ℤ) (f₁ : ModularForm (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) k)
+      (p₁ : PowerSeries ℤ), D ≠ 0 ∧ ModularCurve.IsIntegralQExp f₁ p₁ ∧
+        (⇑f₁ : UpperHalfPlane → ℂ) = (D : ℂ) • ((⇑f : UpperHalfPlane → ℂ) ∣[k] γ) := by
+  have hrat := ModularCurve.exists_ratCast_qExpansion_slash_of_mem_Gamma0 M f
+    (rat_of_isIntegralQExp hp) γ hγ
+  set g : ModularForm (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) k := diamondSlash γ hγ
+    f
+    with hg
+  have hcoe : (⇑g : ℍ → ℂ) = (⇑f : ℍ → ℂ) ∣[k] γ := coe_diamondSlash γ hγ f
+  have hrat' : ∀ n : ℕ, ∃ r : ℚ, (qExpansion 1 g).coeff n = (r : ℂ) := by
+    rw [hcoe]; exact hrat
+  obtain ⟨D, p₁, hD, hint⟩ :=
+    ModularCurve.exists_isIntegralQExp_smul_of_ratCast_qExpansion M g hrat'
+  refine ⟨D, (D : ℂ) • g, p₁, hD, ?_, ?_⟩
+  · rw [FunLike.coe_smul]; exact hint
+  · rw [FunLike.coe_smul, hcoe]
+
+end
+end S_ModularCurve_exists_isIntegralQExp_smul_slash_of_mem_Gamma0
+end P2MW
+export P2MW.S_ModularCurve_exists_isIntegralQExp_smul_slash_of_mem_Gamma0 (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups ModularForm in
+theorem ModularCurve.exists_isIntegralQExp_smul_slash_of_mem_Gamma0 (M : ℕ) [NeZero M] {k : ℤ}
+    (f : ModularForm (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) k)
+    {p : PowerSeries ℤ} (hp : ModularCurve.IsIntegralQExp f p)
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    ∃ (D : ℤ) (f₁ : ModularForm (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) k)
+      (p₁ : PowerSeries ℤ), D ≠ 0 ∧ ModularCurve.IsIntegralQExp f₁ p₁ ∧
+        (⇑f₁ : UpperHalfPlane → ℂ) = (D : ℂ) • ((⇑f : UpperHalfPlane → ℂ) ∣[k] γ) :=
+  solution M f hp γ hγ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_modularForm_gamma1_qExpansion_eq_mul_pow_of_qExpansion_eq_sq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_modularForm_gamma1_qExpansion_eq_mul_pow_of_qExpansion_eq_sq.lean
new file mode 100644
index 0000000000..e586ca314f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_modularForm_gamma1_qExpansion_eq_mul_pow_of_qExpansion_eq_sq.lean
@@ -0,0 +1,281 @@
+/-
+Based on Prove2Me node
+ModularCurve.exists_modularForm_gamma1_qExpansion_eq_mul_pow_of_qExpansion_eq_sq
+(5e6b5c98-6dea-5d8d-8237-b7fb1ea0c6af) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8c98db1a-3e2c-5d24-8dcc-dd75b4c7938c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Order.CompletePartialOrder
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_modularForm_mul_eq_of_analyticOrderAt_le_of_finiteIndex
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Weight-k form from a square on Γ₁(M)
+
+Theorem statement:
+`ModularCurve.exists_modularForm_gamma1_qExpansion_eq_mul_pow_of_qExpansion_eq_sq`
+(`5e6b5c98-6dea-5d8d-8237-b7fb1ea0c6af`), by Claude, 2026-09-05.
+
+Proof: submission `8c98db1a-3e2c-5d24-8dcc-dd75b4c7938c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a nonzero natural number $M$ and a natural number $k$, and let $w$ be a modular form of weight
+$1$ for $\Gamma_1(M)$ (regarded as a subgroup of $\mathrm{GL}_2(\mathbb{R})$). Let $X$ be a Laurent
+series over $\mathbb{C}$ belonging to [`ModularCurve.laurentBaseChange ℂ
+(ModularCurve.qExpFunctionFieldC ℚ (Gamma1 M))`](def/ModularCurve_LaurentCoeff.html#L103), that is,
+to the subfield of $\mathbb{C}((q))$ generated over $\mathbb{C}$ by the coefficientwise image under
+$\mathbb{Q} \to \mathbb{C}$ of the subfield of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by all
+quotients `intSeriesC ℚ pf / intSeriesC ℚ pg`, where $f,g$ are modular forms of one and the same
+weight for $\Gamma_1(M)$, the power series $pf, pg$ over $\mathbb{Z}$ satisfy `IsIntegralQExp` for
+$f$ and $g$ respectively, and `intSeriesC ℚ pg ≠ 0`. Suppose further that there is a modular form
+$F_2$ of weight $2k$ for $\Gamma_1(M)$ whose $q$-expansion of width $1$, viewed as a Laurent series
+over $\mathbb{C}$, equals $\bigl(X \cdot q\text{-}\mathrm{exp}(w)^k\bigr)^2$. Then there exists a
+modular form $f$ of weight $k$ for $\Gamma_1(M)$ whose width-$1$ $q$-expansion, as a Laurent series,
+equals $X \cdot q\text{-}\mathrm{exp}(w)^k$.
+
+This is the holomorphy criterion that a meromorphic modular object of weight $k$ on $\Gamma_1(M)$
+whose square is a holomorphic form of weight $2k$ is itself holomorphic and bounded at the cusps,
+stated at the level of $q$-expansions; the element $X$ of the function field of $X_1(M)$, base
+changed to $\mathbb{C}$, is written as a ratio of forms of a common weight by
+[`ModularCurve.exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC`]
+(thm.html#ModularCurve.
+exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC),
+and the resulting weight-$k$ form is produced by
+[`ModularForm.exists_modularForm_mul_eq_of_analyticOrderAt_le_of_finiteIndex`]
+(thm.html#ModularForm.exists_modularForm_mul_eq_of_analyticOrderAt_le_of_finiteIndex).
+It feeds the construction of many linearly independent forms of odd weight in
+[`ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_odd`]
+(thm.html#ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_odd).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_modularForm_gamma1_qExpansion_eq_mul_pow_of_qExpansion_eq_sq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_modularForm_gamma1_qExpansion_eq_mul_pow_of_qExpansion_eq_sq
+
+open CongruenceSubgroup ModularCurve UpperHalfPlane HahnSeries
+open scoped MatrixGroups ModularForm
+
+noncomputable section
+
+namespace SqrtFormAux
+
+theorem one_mem_strictPeriods_gamma1 (M : ℕ) :
+    (1 : ℝ) ∈ (Subgroup.map (Matrix.SpecialLinearGroup.mapGL ℝ) (CongruenceSubgroup.Gamma1
+      M)).strictPeriods := by
+  rw [CongruenceSubgroup.strictPeriods_Gamma1]
+  exact AddSubgroup.mem_zmultiples 1
+
+theorem analyticAt_comp_ofComplex {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} (f : ModularForm Γ k)
+    (τ : ℍ) :
+    AnalyticAt ℂ ((f : ℍ → ℂ) ∘ ofComplex) (τ : ℂ) := by
+  have hd : DifferentiableOn ℂ ((f : ℍ → ℂ) ∘ ofComplex) {z : ℂ | 0 < z.im} :=
+    UpperHalfPlane.mdifferentiable_iff.mp f.holo'
+  exact hd.analyticAt ((isOpen_lt continuous_const Complex.continuous_im).mem_nhds τ.im_pos)
+
+theorem coe_eq_of_qExpansion_eq {M : ℕ} {a b : ℤ} (f : ModularForm (Gamma1 M) a)
+    (g : ModularForm (Gamma1 M) b)
+    (h : qExpansion 1 (f : ℍ → ℂ) = qExpansion 1 (g : ℍ → ℂ)) : (f : ℍ → ℂ) = g := by
+  have h1 := one_mem_strictPeriods_gamma1 M
+  have : Fact (IsCusp OnePoint.infty (Subgroup.map (Matrix.SpecialLinearGroup.mapGL ℝ)
+    (CongruenceSubgroup.Gamma1 M))) :=
+    ⟨Subgroup.isCusp_of_mem_strictPeriods one_pos h1⟩
+  funext z
+  have hf := hasSum_qExpansion one_pos (SlashInvariantFormClass.periodic_comp_ofComplex f h1)
+    (ModularFormClass.holo f) (ModularFormClass.bdd_at_infty f) z
+  have hg := hasSum_qExpansion one_pos (SlashInvariantFormClass.periodic_comp_ofComplex g h1)
+    (ModularFormClass.holo g) (ModularFormClass.bdd_at_infty g) z
+  rw [h] at hf
+  exact hf.unique hg
+
+theorem le_of_add_eq_two {e x y : ℕ∞} (h : e + (x + x) = y + y) : x ≤ y := by
+  rcases eq_or_ne y ⊤ with hy | hy
+  · exact hy ▸ le_top
+  lift y to ℕ using hy
+  have hx : x ≠ ⊤ := by
+    rintro rfl
+    simp only [add_top] at h
+    exact ENat.natCast_ne_top (y + y) (by push_cast; exact h.symm)
+  lift x to ℕ using hx
+  have he : e ≠ ⊤ := by
+    rintro rfl
+    simp only [top_add] at h
+    exact ENat.natCast_ne_top (y + y) (by push_cast; exact h.symm)
+  lift e to ℕ using he
+  have h' : e + (x + x) = y + y := by exact_mod_cast h
+  exact_mod_cast (show x ≤ y by omega)
+
+end SqrtFormAux
+
+open SqrtFormAux in
+theorem solution
+    (M : ℕ) [NeZero M] (k : ℕ) (w : ModularForm (Gamma1 M) 1)
+    (X : LaurentSeries ℂ)
+    (hX : X ∈ ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M)))
+    (F₂ : ModularForm (Gamma1 M) (2 * (k : ℤ)))
+    (hF₂ : HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 F₂) =
+      (X * HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 w) ^ k) ^ 2) :
+    ∃ f : ModularForm (Gamma1 M) (k : ℤ),
+      HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 f) =
+        X * HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 w) ^ k := by
+  classical
+  have : (CongruenceSubgroup.Gamma1 M).FiniteIndex := inferInstance
+  have hT : ModularGroup.T ∈ CongruenceSubgroup.Gamma1 M := by
+    rw [CongruenceSubgroup.Gamma1_mem]; simp [ModularGroup.T]
+  have h1 := one_mem_strictPeriods_gamma1 M
+  obtain ⟨a, g, h, hh, hXh⟩ :=
+    ModularCurve.exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC
+      (CongruenceSubgroup.Gamma1 M) hT X hX
+  obtain ⟨Φ, hΦdef⟩ : ∃ Φ : ModularForm (Gamma1 M) (a + (k : ℤ) * 1), Φ = g.mul (w.pow k) :=
+    ⟨_, rfl⟩
+  have hΦcoe : (Φ : ℍ → ℂ) = fun z => g z * w z ^ k := by
+    funext z
+    rw [hΦdef, ModularForm.coe_mul, ModularForm.coe_pow, Pi.mul_apply, Pi.pow_apply]
+  have hqΦ : qExpansion 1 (Φ : ℍ → ℂ) = qExpansion 1 (g : ℍ → ℂ) * qExpansion 1 (w : ℍ → ℂ) ^ k :=
+    by
+    rw [hΦdef, ModularForm.qExpansion_mul one_pos h1, ModularForm.qExpansion_pow one_pos h1]
+  obtain ⟨L, hLdef⟩ : ∃ L : ModularForm (Gamma1 M) (2 * (k : ℤ) + (a + a)), L = F₂.mul (h.mul h) :=
+    ⟨_, rfl⟩
+  obtain ⟨R, hRdef⟩ : ∃ R : ModularForm (Gamma1 M) ((a + (k : ℤ) * 1) + (a + (k : ℤ) * 1)), R =
+    Φ.mul Φ :=
+    ⟨_, rfl⟩
+  have hqL : qExpansion 1 (L : ℍ → ℂ) = qExpansion 1 (F₂ : ℍ → ℂ) * (qExpansion 1 (h : ℍ → ℂ) *
+    qExpansion 1 (h : ℍ → ℂ)) :=
+    by
+    rw [hLdef, ModularForm.qExpansion_mul one_pos h1, ModularForm.qExpansion_mul one_pos h1]
+  have hqR : qExpansion 1 (R : ℍ → ℂ) = qExpansion 1 (Φ : ℍ → ℂ) * qExpansion 1 (Φ : ℍ → ℂ) := by
+    rw [hRdef, ModularForm.qExpansion_mul one_pos h1]
+  have hLR : qExpansion 1 (L : ℍ → ℂ) = qExpansion 1 (R : ℍ → ℂ) := by
+    refine HahnSeries.ofPowerSeries_injective (Γ := ℤ) (R := ℂ) ?_
+    simp only [hqL, hqR, hqΦ, map_mul, map_pow]
+    rw [hF₂, ← hXh]
+    ring
+  have hfun : ∀ z : ℍ, F₂ z * (h z * h z) = Φ z * Φ z := by
+    intro z
+    have e := congr_fun (coe_eq_of_qExpansion_eq L R hLR) z
+    rw [hLdef, hRdef] at e
+    simpa only [ModularForm.coe_mul, Pi.mul_apply] using e
+  have hord : ∀ τ : ℍ, analyticOrderAt ((h : ℍ → ℂ) ∘ ofComplex) (τ : ℂ) ≤
+      analyticOrderAt ((Φ : ℍ → ℂ) ∘ ofComplex) (τ : ℂ) := by
+    intro τ
+    have ha := analyticAt_comp_ofComplex h τ
+    have hb := analyticAt_comp_ofComplex Φ τ
+    have hc := analyticAt_comp_ofComplex F₂ τ
+    have hid : ((F₂ : ℍ → ℂ) ∘ ofComplex) * (((h : ℍ → ℂ) ∘ ofComplex) * ((h : ℍ → ℂ) ∘ ofComplex))
+      =
+        ((Φ : ℍ → ℂ) ∘ ofComplex) * ((Φ : ℍ → ℂ) ∘ ofComplex) := by
+      funext c
+      exact hfun (ofComplex c)
+    have e := congrArg (fun F : ℂ → ℂ => analyticOrderAt F (τ : ℂ)) hid
+    rw [analyticOrderAt_mul hc (ha.mul ha), analyticOrderAt_mul ha ha, analyticOrderAt_mul hb
+      hb] at e
+    exact le_of_add_eq_two e
+  have hcusp : ∀ A : SL(2, ℤ), ∃ C : ℝ, ∀ᶠ τ : ℍ in atImInfty,
+      ‖((Φ : ℍ → ℂ) ∣[a + (k : ℤ) * 1] (A : GL (Fin 2) ℝ)) τ‖ ≤ C * ‖((h : ℍ → ℂ) ∣[a] (A : GL (Fin
+        2) ℝ)) τ‖ := by
+    intro A
+    have hbd : IsBoundedAtImInfty ((F₂ : ℍ → ℂ) ∣[2 * (k : ℤ)] (A : GL (Fin 2) ℝ)) := by
+      have := ModularFormClass.bdd_at_infty_slash F₂ A
+      rwa [ModularForm.SL_slash] at this
+    obtain ⟨C, hC⟩ := Asymptotics.IsBigO.bound hbd
+    refine ⟨Real.sqrt (max C 0), hC.mono fun τ hτ => ?_⟩
+    have hτ' : ‖((F₂ : ℍ → ℂ) ∣[2 * (k : ℤ)] (A : GL (Fin 2) ℝ)) τ‖ ≤ max C 0 := by
+      refine hτ.trans ?_
+      simp only [Pi.one_apply, norm_one, mul_one]
+      exact le_max_left _ _
+    have e1 : ((Φ : ℍ → ℂ) * (Φ : ℍ → ℂ)) ∣[(a + (k : ℤ) * 1) + (a + (k : ℤ) * 1)] A =
+        ((Φ : ℍ → ℂ) ∣[a + (k : ℤ) * 1] A) * ((Φ : ℍ → ℂ) ∣[a + (k : ℤ) * 1] A) :=
+      ModularForm.mul_slash_SL2 _ _ A _ _
+    have e2 : ((F₂ : ℍ → ℂ) * ((h : ℍ → ℂ) * (h : ℍ → ℂ))) ∣[2 * (k : ℤ) + (a + a)] A =
+        ((F₂ : ℍ → ℂ) ∣[2 * (k : ℤ)] A) * (((h : ℍ → ℂ) ∣[a] A) * ((h : ℍ → ℂ) ∣[a] A)) := by
+      rw [ModularForm.mul_slash_SL2, ModularForm.mul_slash_SL2]
+    have hf2 : (F₂ : ℍ → ℂ) * ((h : ℍ → ℂ) * (h : ℍ → ℂ)) = (Φ : ℍ → ℂ) * (Φ : ℍ → ℂ) := by
+      funext z
+      exact hfun z
+    have hwt : 2 * (k : ℤ) + (a + a) = (a + (k : ℤ) * 1) + (a + (k : ℤ) * 1) := by ring
+    rw [hf2, hwt, e1] at e2
+    have e3 := congr_fun e2 τ
+    simp only [Pi.mul_apply, ModularForm.SL_slash] at e3
+    have hsq : (((Φ : ℍ → ℂ) ∣[a + (k : ℤ) * 1] (A : GL (Fin 2) ℝ)) τ) ^ 2 =
+        ((F₂ : ℍ → ℂ) ∣[2 * (k : ℤ)] (A : GL (Fin 2) ℝ)) τ * (((h : ℍ → ℂ) ∣[a] (A : GL (Fin 2) ℝ))
+          τ) ^ 2 := by
+      rw [sq, sq]
+      exact e3
+    have hnn : 0 ≤ Real.sqrt (max C 0) * ‖((h : ℍ → ℂ) ∣[a] (A : GL (Fin 2) ℝ)) τ‖ := by positivity
+    refine le_of_pow_le_pow_left₀ two_ne_zero hnn ?_
+    rw [mul_pow, Real.sq_sqrt (le_max_right _ _), ← norm_pow, hsq, norm_mul, norm_pow]
+    exact mul_le_mul_of_nonneg_right hτ' (by positivity)
+  obtain ⟨f, hf⟩ := ModularForm.exists_modularForm_mul_eq_of_analyticOrderAt_le_of_finiteIndex
+    (CongruenceSubgroup.Gamma1 M) (k : ℤ) (by ring) Φ h hh hord hcusp
+  refine ⟨f, ?_⟩
+  have hfh : ((f.mul h : ModularForm _ _) : ℍ → ℂ) = (Φ : ℍ → ℂ) := by
+    funext z
+    rw [ModularForm.coe_mul, Pi.mul_apply]
+    exact hf z
+  have hq : qExpansion 1 (f : ℍ → ℂ) * qExpansion 1 (h : ℍ → ℂ) = qExpansion 1 (Φ : ℍ → ℂ) := by
+    rw [← ModularForm.qExpansion_mul one_pos h1, hfh]
+  have hHh0 : ofPowerSeries ℤ ℂ (qExpansion 1 (h : ℍ → ℂ)) ≠ 0 := by
+    intro h0
+    apply hh
+    have h0' : qExpansion 1 (h : ℍ → ℂ) = 0 :=
+      HahnSeries.ofPowerSeries_injective (by rw [h0, map_zero])
+    exact (ModularForm.qExpansion_eq_zero_iff one_pos h1 h).mp h0'
+  have e : ofPowerSeries ℤ ℂ (qExpansion 1 (f : ℍ → ℂ)) * ofPowerSeries ℤ ℂ (qExpansion 1 (h : ℍ →
+    ℂ)) =
+      ofPowerSeries ℤ ℂ (qExpansion 1 (g : ℍ → ℂ)) * ofPowerSeries ℤ ℂ (qExpansion 1 (w : ℍ → ℂ)) ^
+        k := by
+    rw [← map_pow, ← map_mul, ← map_mul, hq, hqΦ]
+  have key : (ofPowerSeries ℤ ℂ (qExpansion 1 (f : ℍ → ℂ)) - X * ofPowerSeries ℤ ℂ (qExpansion 1 (w
+    : ℍ → ℂ)) ^ k) *
+      ofPowerSeries ℤ ℂ (qExpansion 1 (h : ℍ → ℂ)) = 0 := by
+    rw [sub_mul, e, ← hXh]
+    ring
+  exact sub_eq_zero.mp ((mul_eq_zero.mp key).resolve_right hHh0)
+
+end
+end S_ModularCurve_exists_modularForm_gamma1_qExpansion_eq_mul_pow_of_qExpansion_eq_sq
+end P2MW
+export P2MW.S_ModularCurve_exists_modularForm_gamma1_qExpansion_eq_mul_pow_of_qExpansion_eq_sq
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open CongruenceSubgroup ModularCurve
+open scoped MatrixGroups ModularForm
+theorem ModularCurve.exists_modularForm_gamma1_qExpansion_eq_mul_pow_of_qExpansion_eq_sq
+    (M : ℕ) [NeZero M] (k : ℕ) (w : ModularForm (Gamma1 M) 1)
+    (X : LaurentSeries ℂ)
+    (hX : X ∈ ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M)))
+    (F₂ : ModularForm (Gamma1 M) (2 * (k : ℤ)))
+    (hF₂ : HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 F₂) =
+      (X * HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 w) ^ k) ^ 2) :
+    ∃ f : ModularForm (Gamma1 M) (k : ℤ),
+      HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 f) =
+        X * HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 w) ^ k :=
+  solution M k w X hX F₂ hF₂
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_modularForm_gamma1_qExpansion_eq_mul_thetaL_pow_of_isIntegral.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_modularForm_gamma1_qExpansion_eq_mul_thetaL_pow_of_isIntegral.lean
new file mode 100644
index 0000000000..9fa41725b0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_modularForm_gamma1_qExpansion_eq_mul_thetaL_pow_of_isIntegral.lean
@@ -0,0 +1,342 @@
+/-
+Based on Prove2Me node
+ModularCurve.exists_modularForm_gamma1_qExpansion_eq_mul_thetaL_pow_of_isIntegral
+(1c7c4305-3382-599b-8a46-794fc3fd644d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4702dada-d30b-5bc6-962d-19a441b8573c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QExpansionDiff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0ModL
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_analyticOrderAt_le_of_isIntegral_adjoin_jqModC_pow
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_eventually_norm_slash_le_mul_of_isIntegral_adjoin_jqModC_inv_sq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_thetaL_coeffMap_eq_coeffMap_single_mul_derivative
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_coe_eq_of_levelOne
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_modularForm_mul_eq_of_analyticOrderAt_le_of_finiteIndex
+import LeanPool.FLTEichlerShimura.Theorems.Thm_omegaRow_T2
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Weight-2m criterion on Γ₁(M): X·(vartheta j)^m is a q-expansion
+
+Theorem statement:
+`ModularCurve.exists_modularForm_gamma1_qExpansion_eq_mul_thetaL_pow_of_isIntegral`
+(`1c7c4305-3382-599b-8a46-794fc3fd644d`), by Claude, 2026-09-05.
+
+Proof: submission `4702dada-d30b-5bc6-962d-19a441b8573c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $M \geq 1$ (non-zero) and an integer $m \geq 1$, and let $X$ be a Laurent series over
+$\mathbb{C}$. Assume $X$ lies in [`ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC
+ℚ (CongruenceSubgroup.Gamma1 M))`](def/ModularCurve_LaurentCoeff.html#L103), that is, in the
+subfield of $\mathbb{C}((q))$ generated over $\mathbb{C}$ by the coefficientwise images under
+$\mathbb{Q} \to \mathbb{C}$ of the subfield of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by the
+quotients $p_f/p_g$ of integral $q$-expansions of pairs of modular forms $f,g$ of one and the same
+weight on $\Gamma_1(M)$ with $p_g \neq 0$. Write $\bar{j} =$ [`ModularCurve.jqModC
+ℂ`](def/ModularCurve_JqCoeff.html#L15) for the Laurent series $q^{-1}\,(E_4^3 \cdot \eta\text{-unit
+inverse})$, the $q$-expansion of the $j$-invariant. Assume further that
+$X^6\,\bar{j}^{4m}\,(\bar{j}-1728)^{3m}$ is integral over the $\mathbb{C}$-subalgebra generated by
+$\bar{j}$, and that $X^2\,\bar{j}^{m}\,(\bar{j}-1728)^{m}$ is integral over the
+$\mathbb{C}$-subalgebra generated by $\bar{j}^{-1}$. Then there exists a modular form $f$ of weight
+$2m$ for $\Gamma_1(M)$ whose $q$-expansion of width $1$, viewed as a Laurent series, equals $X \cdot
+(\vartheta\bar{j})^m$, where $\vartheta$ is the operator
+[`ModularCurve.thetaL`](def/ModularCurve_QExpansionDiff.html#L16) sending a Laurent series $w$ to
+$q\,\frac{d}{dq}w$.
+
+This is the $\Gamma_1(M)$ form of the classical criterion recognising a $q$-series as the expansion
+of a holomorphic modular form: the first integrality hypothesis controls the analytic order of
+vanishing on the upper half-plane, the second the growth at every cusp, and the form is obtained by
+dividing modular forms. It is used to produce enough forms of weight $2m$ on $\Gamma_1(M)$ for the
+dimension lower bounds
+[`ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_even`]
+(thm.html#ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_even)
+and
+[`ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_odd`]
+(thm.html#ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_odd).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_modularForm_gamma1_qExpansion_eq_mul_thetaL_pow_of_isIntegral.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_modularForm_gamma1_qExpansion_eq_mul_thetaL_pow_of_isIntegral
+
+open ModularCurve UpperHalfPlane HahnSeries
+open scoped MatrixGroups ModularForm
+
+noncomputable section
+
+namespace ANGlueM
+
+theorem one_mem_strictPeriods_gamma1 (M : ℕ) :
+    (1 : ℝ) ∈ (Subgroup.map (Matrix.SpecialLinearGroup.mapGL ℝ) (CongruenceSubgroup.Gamma1
+      M)).strictPeriods := by
+  rw [CongruenceSubgroup.strictPeriods_Gamma1]
+  exact AddSubgroup.mem_zmultiples 1
+
+theorem jqModC_complex_eq : jqModC ℂ = coeffEmb ℂ jq := by
+  rw [coeffEmb, ← jqModC_rat, coeffMap_jqModC]
+
+theorem thetaL_coeffEmb_jq :
+    thetaL ℂ (coeffEmb ℂ jq) = coeffMap (algebraMap ℚ ℂ) (thetaL ℚ jq) := by
+  rw [coeffEmb, ModularCurve.thetaL_coeffMap_eq_coeffMap_single_mul_derivative]
+  rfl
+
+noncomputable def powMF {Γ : Subgroup (GL (Fin 2) ℝ)} [Γ.HasDetPlusMinusOne] {w : ℤ}
+    (P : ModularForm Γ w) :
+    (m : ℕ) → ModularForm Γ ((m : ℤ) * w)
+  | 0 => ModularForm.mcast (by simp) (1 : ModularForm Γ 0)
+  | m + 1 => ModularForm.mcast (by push_cast; ring) ((powMF P m).mul P)
+
+theorem coe_powMF {Γ : Subgroup (GL (Fin 2) ℝ)} [Γ.HasDetPlusMinusOne] {w : ℤ} (P : ModularForm Γ w)
+    (m : ℕ) :
+    (powMF P m : ℍ → ℂ) = (P : ℍ → ℂ) ^ m := by
+  induction m with
+  | zero =>
+    change ((1 : ModularForm Γ 0) : ℍ → ℂ) = _
+    rw [ModularForm.one_coe_eq_one, pow_zero]
+  | succ m ih =>
+    change (((powMF P m).mul P : ModularForm Γ _) : ℍ → ℂ) = _
+    rw [ModularForm.coe_mul, ih, pow_succ]
+
+theorem qExpansion_powMF_succ {Γ : Subgroup (GL (Fin 2) ℝ)} [Γ.HasDetPlusMinusOne] {w : ℤ}
+    (P : ModularForm Γ w)
+    (h1 : (1 : ℝ) ∈ Γ.strictPeriods) (m : ℕ) :
+    qExpansion 1 (powMF P (m + 1) : ℍ → ℂ) = qExpansion 1 (P : ℍ → ℂ) ^ (m + 1) := by
+  induction m with
+  | zero =>
+    have hc : (powMF P (0 + 1) : ℍ → ℂ) = (P : ℍ → ℂ) := by rw [coe_powMF, zero_add, pow_one]
+    rw [hc, zero_add, pow_one]
+  | succ m ih =>
+    change qExpansion 1 (((powMF P (m + 1)).mul P : ModularForm Γ _) : ℍ → ℂ) = _
+    rw [ModularForm.qExpansion_mul one_pos h1, ih, ← pow_succ]
+
+end ANGlueM
+
+open ANGlueM in
+theorem solution (M : ℕ) [NeZero M] (m : ℕ) (hm : 1 ≤ m)
+    (X : LaurentSeries ℂ)
+    (hX : X ∈ ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M)))
+    (h₁ : IsIntegral (Algebra.adjoin ℂ ({ModularCurve.jqModC ℂ} : Set (LaurentSeries ℂ)))
+      (X ^ 6 * ModularCurve.jqModC ℂ ^ (4 * m) *
+        (ModularCurve.jqModC ℂ - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (3 * m)))
+    (h₂ : IsIntegral (Algebra.adjoin ℂ ({(ModularCurve.jqModC ℂ)⁻¹} : Set (LaurentSeries ℂ)))
+      (X ^ 2 * ModularCurve.jqModC ℂ ^ m *
+        (ModularCurve.jqModC ℂ - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ m)) :
+    ∃ f : ModularForm (CongruenceSubgroup.Gamma1 M) (2 * (m : ℤ)),
+      HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 f) =
+        X * ModularCurve.thetaL ℂ (ModularCurve.jqModC ℂ) ^ m := by
+  classical
+  have : (CongruenceSubgroup.Gamma1 M).FiniteIndex := inferInstance
+  have hT : ModularGroup.T ∈ CongruenceSubgroup.Gamma1 M := by
+    rw [CongruenceSubgroup.Gamma1_mem]; simp [ModularGroup.T]
+  obtain ⟨m, rfl⟩ : ∃ m' : ℕ, m = m' + 1 := ⟨m - 1, (Nat.sub_add_cancel hm).symm⟩
+  obtain ⟨k, g, h, hh, hXh⟩ :=
+    ModularCurve.exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC
+      (CongruenceSubgroup.Gamma1 M) hT X hX
+  obtain ⟨E4N, hE4⟩ :=
+    ModularForm.exists_coe_eq_of_levelOne (CongruenceSubgroup.Gamma1 M) ModularForm.E₄
+  obtain ⟨E6N, hE6⟩ :=
+    ModularForm.exists_coe_eq_of_levelOne (CongruenceSubgroup.Gamma1 M) ModularForm.E₆
+  obtain ⟨DN, hD⟩ := ModularForm.exists_coe_eq_of_levelOne (CongruenceSubgroup.Gamma1 M)
+    (ModularFormClass.modularForm (CuspForm.discriminant))
+  have hDcoe : (DN : ℍ → ℂ) = ModularForm.discriminant := by
+    rw [hD]
+    funext z
+    rw [← CuspForm.toModularFormₗ_eq_coe, CuspForm.toModularFormₗ_apply]
+    rfl
+  have h1 := one_mem_strictPeriods_gamma1 M
+  obtain ⟨P, hPdef⟩ : ∃ P : ModularForm (CongruenceSubgroup.Gamma1 M) ((4 + 4) + 6), P = (E4N.mul
+    E4N).mul E6N :=
+    ⟨_, rfl⟩
+  have hPcoe : (P : ℍ → ℂ) = fun z => ModularForm.E₄ z ^ 2 * ModularForm.E₆ z := by
+    funext z
+    simp only [hPdef, ModularForm.coe_mul, Pi.mul_apply, hE4, hE6]
+    ring
+  obtain ⟨Φ, hΦdef⟩ : ∃ Φ : ModularForm (CongruenceSubgroup.Gamma1 M) (k + ((m + 1 : ℕ) : ℤ) * ((4 +
+    4) + 6)),
+      Φ = g.mul (powMF P (m + 1)) := ⟨_, rfl⟩
+  obtain ⟨Ψ, hΨdef⟩ : ∃ Ψ : ModularForm (CongruenceSubgroup.Gamma1 M) (k + ((m + 1 : ℕ) : ℤ) * 12),
+      Ψ = h.mul (powMF DN (m + 1)) := ⟨_, rfl⟩
+  have hΦcoe : (Φ : ℍ → ℂ) = fun z => g z * (ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) ^ (m + 1)
+    := by
+    funext z
+    rw [hΦdef, ModularForm.coe_mul, coe_powMF, hPcoe, Pi.mul_apply, Pi.pow_apply]
+  have hΨcoe : (Ψ : ℍ → ℂ) = fun z => h z * ModularForm.discriminant z ^ (m + 1) := by
+    funext z
+    rw [hΨdef, ModularForm.coe_mul, coe_powMF, hDcoe, Pi.mul_apply, Pi.pow_apply]
+  have hΨ0 : Ψ ≠ 0 := by
+    intro h0
+    apply hh
+    have hfun : (Ψ : ℍ → ℂ) = 0 := by rw [h0]; rfl
+    rw [hΨcoe] at hfun
+    rw [← FunLike.coe_zero_iff]
+    funext z
+    have := congr_fun hfun z
+    simp only [Pi.zero_apply, mul_eq_zero] at this
+    rcases this with hz | hz
+    · exact hz
+    · exact absurd (pow_eq_zero_iff (Nat.succ_ne_zero m) |>.mp hz) (ModularForm.discriminant_ne_zero
+        z)
+  have hm1 : 1 ≤ m + 1 := Nat.le_add_left 1 m
+  have hord : ∀ τ : ℍ, analyticOrderAt ((Ψ : ℍ → ℂ) ∘ ofComplex) (τ : ℂ) ≤
+      analyticOrderAt ((Φ : ℍ → ℂ) ∘ ofComplex) (τ : ℂ) := by
+    intro τ
+    rw [hΦcoe, hΨcoe]
+    exact ModularCurve.analyticOrderAt_le_of_isIntegral_adjoin_jqModC_pow (CongruenceSubgroup.Gamma1
+      M) hT (m + 1) g h X hXh h₁ τ
+  have hcusp : ∀ A : SL(2, ℤ), ∃ C : ℝ, ∀ᶠ τ : ℍ in atImInfty,
+      ‖((Φ : ℍ → ℂ) ∣[k + ((m + 1 : ℕ) : ℤ) * ((4 + 4) + 6)] (A : GL (Fin 2) ℝ)) τ‖ ≤
+        C * ‖((Ψ : ℍ → ℂ) ∣[k + ((m + 1 : ℕ) : ℤ) * 12] (A : GL (Fin 2) ℝ)) τ‖ := by
+    intro A
+    rw [hΦcoe, hΨcoe, show k + ((m + 1 : ℕ) : ℤ) * ((4 + 4) + 6) = k + 14 * ((m + 1 : ℕ) : ℤ) by
+      ring,
+      show k + ((m + 1 : ℕ) : ℤ) * 12 = k + 12 * ((m + 1 : ℕ) : ℤ) by ring]
+    exact ModularCurve.eventually_norm_slash_le_mul_of_isIntegral_adjoin_jqModC_inv_sq
+      (CongruenceSubgroup.Gamma1 M) hT (m + 1) g h X hXh h₂ A
+  obtain ⟨f, hf⟩ :=
+    ModularForm.exists_modularForm_mul_eq_of_analyticOrderAt_le_of_finiteIndex
+      (CongruenceSubgroup.Gamma1 M) (2 * ((m + 1 : ℕ) : ℤ))
+    (by push_cast; ring) Φ Ψ hΨ0 hord hcusp
+  have hfΨ : (f.mul Ψ : ℍ → ℂ) = (Φ : ℍ → ℂ) := by
+    funext z
+    rw [ModularForm.coe_mul, Pi.mul_apply]
+    exact hf z
+  have hq : qExpansion 1 (f : ℍ → ℂ) * qExpansion 1 (Ψ : ℍ → ℂ) = qExpansion 1 (Φ : ℍ → ℂ) := by
+    have e := ModularForm.qExpansion_mul one_pos h1 f Ψ
+    rw [hfΨ] at e
+    exact e.symm
+  have hqD : qExpansion 1 (powMF DN (m + 1) : ℍ → ℂ) = qExpansion 1 ModularForm.discriminant ^ (m +
+    1) :=
+    by
+    rw [qExpansion_powMF_succ DN h1 m, hDcoe]
+  have hqP : qExpansion 1 (powMF P (m + 1) : ℍ → ℂ) =
+      (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) * qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) *
+        qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) ^ (m + 1) := by
+    rw [qExpansion_powMF_succ P h1 m, hPdef, ModularForm.qExpansion_mul one_pos h1,
+      ModularForm.qExpansion_mul one_pos h1,
+      hE4, hE6]
+  have hqΨ : qExpansion 1 (Ψ : ℍ → ℂ) = qExpansion 1 (h : ℍ → ℂ) * qExpansion 1
+    ModularForm.discriminant ^ (m + 1) :=
+    by
+    rw [hΨdef, ModularForm.qExpansion_mul one_pos h1, hqD]
+  have hqΦ : qExpansion 1 (Φ : ℍ → ℂ) =
+      qExpansion 1 (g : ℍ → ℂ) * (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) * qExpansion 1
+        (ModularForm.E₄ : ℍ → ℂ) *
+        qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) ^ (m + 1) := by
+    rw [hΦdef, ModularForm.qExpansion_mul one_pos h1, hqP]
+  set F : LaurentSeries ℂ := ((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) with hF
+  set Hh : LaurentSeries ℂ := ((qExpansion 1 (h : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) with
+    hHh
+  set G : LaurentSeries ℂ := ((qExpansion 1 (g : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) with hG
+  set D : LaurentSeries ℂ := ((qExpansion 1 ModularForm.discriminant : PowerSeries ℂ) :
+    LaurentSeries ℂ) with hDD
+  set A4 : LaurentSeries ℂ := ((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) : PowerSeries ℂ) :
+    LaurentSeries ℂ) with hA4
+  set A6 : LaurentSeries ℂ := ((qExpansion 1 (ModularForm.E₆ : ℍ → ℂ) : PowerSeries ℂ) :
+    LaurentSeries ℂ) with hA6
+  set T : LaurentSeries ℂ := thetaL ℂ (jqModC ℂ) with hT
+  have hT2 : T * D = -(A4 ^ 2 * A6) := by
+    rw [hT, jqModC_complex_eq, thetaL_coeffEmb_jq]
+    exact omegaRow_T2
+  have eq1 : F * (Hh * D ^ (m + 1)) = G * (A4 * A4 * A6) ^ (m + 1) := by
+    rw [hF, hHh, hDD, hG, hA4, hA6, ← PowerSeries.coe_pow, ← PowerSeries.coe_mul, ←
+      PowerSeries.coe_mul, ← hqΨ, hq, hqΦ,
+      PowerSeries.coe_mul, PowerSeries.coe_pow, PowerSeries.coe_mul, PowerSeries.coe_mul]
+  have hhq : Hh ≠ 0 := by
+    intro h0
+    apply hh
+    have h0' : qExpansion 1 (h : ℍ → ℂ) = 0 :=
+      HahnSeries.ofPowerSeries_injective (by rw [← hHh, h0, map_zero])
+    exact (ModularForm.qExpansion_eq_zero_iff one_pos h1 h).mp h0'
+  have hDN0 : DN ≠ 0 := by
+    intro h0
+    have hI : (DN : ℍ → ℂ) UpperHalfPlane.I = 0 := by rw [h0]; rfl
+    rw [hDcoe] at hI
+    exact ModularForm.discriminant_ne_zero _ hI
+  have hDq : D ≠ 0 := by
+    intro h0
+    apply hDN0
+    have h0' : qExpansion 1 (DN : ℍ → ℂ) = 0 :=
+      HahnSeries.ofPowerSeries_injective (by rw [hDcoe, ← hDD, h0, map_zero])
+    exact (ModularForm.qExpansion_eq_zero_iff one_pos h1 DN).mp h0'
+  have hHD : Hh * D ^ (m + 1) ≠ 0 := mul_ne_zero hhq (pow_ne_zero _ hDq)
+  set X2 : LaurentSeries ℂ := A4 ^ 2 * A6 with hX2
+  have eq1' : F * (Hh * D ^ (m + 1)) = X * Hh * X2 ^ (m + 1) := by
+    rw [eq1, ← hXh, hX2]; ring
+  rcases Nat.even_or_odd (m + 1) with hev | hodd
+  · obtain ⟨r, hr⟩ := hev
+    have hsq : (T * D) ^ 2 = X2 ^ 2 := by rw [hT2]; ring
+    have hP2 : X2 ^ (m + 1) = (T * D) ^ (m + 1) := by
+      rw [hr, ← two_mul, pow_mul, pow_mul, hsq]
+    have key : (F - X * T ^ (m + 1)) * (Hh * D ^ (m + 1)) = 0 := by
+      rw [sub_mul, eq1', hP2, mul_pow]; ring
+    have hF' : F = X * T ^ (m + 1) := sub_eq_zero.mp ((mul_eq_zero.mp key).resolve_right hHD)
+    exact ⟨f, hF'⟩
+  · obtain ⟨r, hr⟩ := hodd
+    have hsq : (T * D) ^ 2 = X2 ^ 2 := by rw [hT2]; ring
+    have hP2 : X2 ^ (m + 1) = -(T * D) ^ (m + 1) := by
+      rw [hr, pow_succ, pow_succ, pow_mul, pow_mul, hsq, hT2]; ring
+    have key : (F + X * T ^ (m + 1)) * (Hh * D ^ (m + 1)) = 0 := by
+      rw [add_mul, eq1', hP2, mul_pow]; ring
+    have hF' : F = -(X * T ^ (m + 1)) :=
+      eq_neg_of_add_eq_zero_left ((mul_eq_zero.mp key).resolve_right hHD)
+    refine ⟨-f, ?_⟩
+    have hneg : qExpansion 1 ((-f : ModularForm (CongruenceSubgroup.Gamma1 M) (2 * ((m + 1 : ℕ) :
+      ℤ))) : ℍ → ℂ) =
+        -qExpansion 1 (f : ℍ → ℂ) := by
+      rw [FunLike.coe_neg]
+      exact ModularForm.qExpansion_neg one_pos h1 f
+    change ((qExpansion 1 ((-f : ModularForm (CongruenceSubgroup.Gamma1 M) (2 * ((m + 1 : ℕ) : ℤ)))
+      : ℍ → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) = X * T ^ (m + 1)
+    rw [hneg, PowerSeries.coe_neg, ← hF, hF', neg_neg]
+
+end
+end S_ModularCurve_exists_modularForm_gamma1_qExpansion_eq_mul_thetaL_pow_of_isIntegral
+end P2MW
+export P2MW.S_ModularCurve_exists_modularForm_gamma1_qExpansion_eq_mul_thetaL_pow_of_isIntegral
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.exists_modularForm_gamma1_qExpansion_eq_mul_thetaL_pow_of_isIntegral (M : ℕ)
+    [NeZero M] (m : ℕ) (hm : 1 ≤ m)
+    (X : LaurentSeries ℂ)
+    (hX : X ∈ ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M)))
+    (h₁ : IsIntegral (Algebra.adjoin ℂ ({ModularCurve.jqModC ℂ} : Set (LaurentSeries ℂ)))
+      (X ^ 6 * ModularCurve.jqModC ℂ ^ (4 * m) *
+        (ModularCurve.jqModC ℂ - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ (3 * m)))
+    (h₂ : IsIntegral (Algebra.adjoin ℂ ({(ModularCurve.jqModC ℂ)⁻¹} : Set (LaurentSeries ℂ)))
+      (X ^ 2 * ModularCurve.jqModC ℂ ^ m *
+        (ModularCurve.jqModC ℂ - algebraMap ℂ (LaurentSeries ℂ) 1728) ^ m)) :
+    ∃ f : ModularForm (CongruenceSubgroup.Gamma1 M) (2 * (m : ℤ)),
+      HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 f) =
+        X * ModularCurve.thetaL ℂ (ModularCurve.jqModC ℂ) ^ m :=
+  solution M m hm X hX h₁ h₂
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_coeffEmb_qExpand_jq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_coeffEmb_qExpand_jq.lean
new file mode 100644
index 0000000000..6bafaae810
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_coeffEmb_qExpand_jq.lean
@@ -0,0 +1,173 @@
+/-
+Based on Prove2Me node ModularCurve.exists_modularForm_mul_qExpansion_eq_coeffEmb_qExpand_jq
+(a5f4f1c9-dd49-5e6b-a2ab-eaf8e3b2d38c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 14ce9729-f5e0-5fc0-a7d5-d1f8075e28fb
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_gamma0_qExpansion_div_eq_jqNModC
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# j(qᵈ) as a ratio of weight-12 forms on Γ₀(N)
+
+Theorem statement: `ModularCurve.exists_modularForm_mul_qExpansion_eq_coeffEmb_qExpand_jq`
+(`a5f4f1c9-dd49-5e6b-a2ab-eaf8e3b2d38c`), by Claude, 2026-09-05.
+
+Proof: submission `14ce9729-f5e0-5fc0-a7d5-d1f8075e28fb`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ and $d$ be nonzero natural numbers with $d \mid N$. Write $\mathrm{jq}$ for the Laurent
+series over $\mathbb Q$ given by $q^{-1}$ times the power series $\mathrm{jNumQ}$ obtained from the
+integral series $\mathrm{jNum}$ by base change along $\mathbb Z \to \mathbb Q$, let
+$\mathrm{qExpand}\ \mathbb Q\ d$ be the ring endomorphism of $\mathbb Q((q))$ that reindexes a
+series along multiplication by $d$ on the exponent group $\mathbb Z$ (the substitution $q \mapsto
+q^d$), and let $\mathrm{coeffEmb}\ \mathbb C : \mathbb Q((q)) \to \mathbb C((q))$ be the
+coefficientwise ring homomorphism induced by $\mathbb Q \to \mathbb C$. The assertion is that there
+exist a weight $k \in \mathbb Z$ and modular forms $g, h$ of weight $k$ for $\Gamma_0(N)$, with $h
+\neq 0$, such that in $\mathbb C((q))$ the product of $\mathrm{coeffEmb}\ \mathbb
+C\,(\mathrm{qExpand}\ \mathbb Q\ d\ \mathrm{jq})$ with the $q$-expansion of $h$ at $i\infty$ of
+width $1$ (Mathlib's `qExpansion 1`, a power series viewed inside $\mathbb C((q))$) equals the
+$q$-expansion of $g$ of width $1$. The conclusion is stated in cleared-denominator form, as an
+equality of products rather than as a quotient, and the weight is only asserted to exist (the proof
+produces $k = 12$).
+
+This records that $j(q^d)$ for $d \mid N$ lies in the field generated by $q$-expansions of modular
+forms on $\Gamma_0(N)$ of a common weight, classically through $j(d\tau) =
+E_4(d\tau)^3/\Delta(d\tau)$. It feeds the study of the Laurent-series realisation of functions on
+$X_0(N)$, being used in the identification of the base-changed Laurent field, in the behaviour of
+orders of $q$-expansions under slash operators, and in a limit/realisation statement for elements
+all of whose orders vanish.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_modularForm_mul_qExpansion_eq_coeffEmb_qExpand_jq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_modularForm_mul_qExpansion_eq_coeffEmb_qExpand_jq
+
+noncomputable section
+
+open UpperHalfPlane
+open scoped MatrixGroups
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd jq coeffEmb \
+  coeffEmb_coeff jqModC jqNModC jqModC_rat map_jqModC exists_gamma0_qExpansion_div_eq_jqNModC"
+namespace JqdRatioOfLevel
+p2m_open "ModularCurve"
+
+theorem coeffEmb_qExpand_eq (d : ℕ) [NeZero d] (x : LaurentSeries ℚ) :
+    coeffEmb ℂ (qExpand ℚ d x) = qExpand ℂ d (coeffEmb ℂ x) := by
+  ext k
+  by_cases hk : (d : ℤ) ∣ k
+  · obtain ⟨m, rfl⟩ := hk
+    rw [coeffEmb_coeff, qExpand_coeff_mul, qExpand_coeff_mul, coeffEmb_coeff]
+  · rw [coeffEmb_coeff, qExpand_coeff_of_not_dvd (hk := hk), qExpand_coeff_of_not_dvd (hk := hk),
+      map_zero]
+
+theorem coeffEmb_jq_eq : coeffEmb ℂ jq = jqModC ℂ := by
+  rw [← jqModC_rat]
+  exact map_jqModC (algebraMap ℚ ℂ)
+
+theorem coeffEmb_qExpand_jq_eq (d : ℕ) [NeZero d] :
+    coeffEmb ℂ (qExpand ℚ d jq) = jqNModC ℂ d := by
+  rw [coeffEmb_qExpand_eq, coeffEmb_jq_eq]
+  rfl
+
+theorem Gamma0_le_of_dvd {d N : ℕ} (hd : d ∣ N) :
+    CongruenceSubgroup.Gamma0 N ≤ CongruenceSubgroup.Gamma0 d := by
+  intro A hA
+  rw [CongruenceSubgroup.Gamma0_mem, ZMod.intCast_zmod_eq_zero_iff_dvd] at hA ⊢
+  exact (Int.natCast_dvd_natCast.mpr hd).trans hA
+
+theorem Gamma0GL_le_of_dvd {d N : ℕ} (hd : d ∣ N) :
+    ((CongruenceSubgroup.Gamma0 N : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) ≤
+      ((CongruenceSubgroup.Gamma0 d : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) :=
+  Subgroup.map_mono (Gamma0_le_of_dvd hd)
+
+def restrict {Γ Γ' : Subgroup (GL (Fin 2) ℝ)} (hle : Γ' ≤ Γ) {k : ℤ} (f : ModularForm Γ k) :
+    ModularForm Γ' k where
+  toFun := f
+  slash_action_eq' γ hγ := SlashInvariantForm.slash_action_eqn f γ (hle hγ)
+  holo' := f.holo'
+  bdd_at_cusps' hc := f.bdd_at_cusps' (hc.mono hle)
+
+@[scoped simp]
+theorem coe_restrict {Γ Γ' : Subgroup (GL (Fin 2) ℝ)} (hle : Γ' ≤ Γ) {k : ℤ}
+    (f : ModularForm Γ k) : ((restrict hle f : ModularForm Γ' k) : ℍ → ℂ) = f := rfl
+
+theorem restrict_ne_zero {Γ Γ' : Subgroup (GL (Fin 2) ℝ)} (hle : Γ' ≤ Γ) {k : ℤ}
+    {f : ModularForm Γ k} (hf : f ≠ 0) : restrict hle f ≠ 0 := by
+  intro h
+  apply hf
+  apply DFunLike.ext
+  intro z
+  have := congrArg (fun g : ModularForm Γ' k => (g : ℍ → ℂ) z) h
+  simpa using this
+
+theorem one_mem_strictPeriods (d : ℕ) :
+    (1 : ℝ) ∈ (CongruenceSubgroup.Gamma0 d : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  simp
+
+theorem qExpansion_coe_ne_zero {d : ℕ} {k : ℤ} (f : ModularForm (CongruenceSubgroup.Gamma0 d) k)
+    (hf : f ≠ 0) : ((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) ≠ 0 := by
+  intro h
+  apply hf
+  rw [← ModularForm.qExpansion_eq_zero_iff one_pos (one_mem_strictPeriods d)]
+  apply HahnSeries.ofPowerSeries_injective (Γ := ℤ) (R := ℂ)
+  simpa using h
+
+end ModularCurve.JqdRatioOfLevel
+end
+
+open UpperHalfPlane in
+open ModularCurve.JqdRatioOfLevel in
+theorem solution (N d : ℕ)
+    [NeZero N] [NeZero d] (hd : d ∣ N) :
+    ∃ (k : ℤ) (g h : ModularForm (CongruenceSubgroup.Gamma0 N) k), h ≠ 0 ∧
+      ModularCurve.coeffEmb ℂ (ModularCurve.qExpand ℚ d ModularCurve.jq) *
+          ((qExpansion 1 (h : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+        ((qExpansion 1 (g : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) := by
+  obtain ⟨G, H, hH, hdiv⟩ := ModularCurve.exists_gamma0_qExpansion_div_eq_jqNModC d
+  have hle := Gamma0GL_le_of_dvd hd
+  refine ⟨12, restrict hle G, restrict hle H, restrict_ne_zero hle hH, ?_⟩
+  rw [coe_restrict, coe_restrict, ModularCurve.JqdRatioOfLevel.coeffEmb_qExpand_jq_eq, ← hdiv]
+  exact div_mul_cancel₀ _ (qExpansion_coe_ne_zero H hH)
+
+end S_ModularCurve_exists_modularForm_mul_qExpansion_eq_coeffEmb_qExpand_jq
+end P2MW
+export P2MW.S_ModularCurve_exists_modularForm_mul_qExpansion_eq_coeffEmb_qExpand_jq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane in
+theorem ModularCurve.exists_modularForm_mul_qExpansion_eq_coeffEmb_qExpand_jq (N d : ℕ)
+    [NeZero N] [NeZero d] (hd : d ∣ N) :
+    ∃ (k : ℤ) (g h : ModularForm (CongruenceSubgroup.Gamma0 N) k), h ≠ 0 ∧
+      ModularCurve.coeffEmb ℂ (ModularCurve.qExpand ℚ d ModularCurve.jq) *
+          ((qExpansion 1 (h : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+        ((qExpansion 1 (g : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) :=
+  solution N d hd
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange.lean
new file mode 100644
index 0000000000..9f95770fe2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange.lean
@@ -0,0 +1,251 @@
+/-
+Based on Prove2Me node ModularCurve.exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange
+(e4d12051-6158-51d7-955c-a9f4ee27bc79) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission fb4dac89-153a-559e-ab17-bff06c476255
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import Mathlib.Analysis.CStarAlgebra.Classes
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_coeffEmb_qExpand_jq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Elements of ℂF_N are ratios of forms on Γ₀(N)
+
+Theorem statement: `ModularCurve.exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange`
+(`e4d12051-6158-51d7-955c-a9f4ee27bc79`), by Claude, 2026-09-05.
+
+Proof: submission `fb4dac89-153a-559e-ab17-bff06c476255`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a positive integer and let $x$ be a Laurent series over $\mathbb{C}$ in the variable $q$.
+Assume $x$ lies in [`ModularCurve.laurentBaseChange ℂ (ModularCurve.modularFunctionFieldFull
+N)`](def/ModularCurve_LaurentCoeff.html#L103), that is, in the intermediate field of
+$\mathbb{C}((q))$ obtained by adjoining to $\mathbb{C}$ the image, under the coefficientwise ring
+homomorphism [`ModularCurve.coeffEmb ℂ`](def/ModularCurve_LaurentCoeff.html#L81) induced by
+$\mathbb{Q} \to \mathbb{C}$, of the subfield [`ModularCurve.modularFunctionFieldFull
+N`](def/ModularCurve_X0.html#L305) of $\mathbb{Q}((q))$, the latter being generated over
+$\mathbb{Q}$ by the set [`ModularCurve.divisorExpansions N`](def/ModularCurve_X0.html#L297) of
+series $\mathrm{qExpand}_{\mathbb{Q}}\, d\ \mathrm{jq}$ for the nonzero divisors $d \mid N$ (the
+expansions of $j$ in $q^d$). The conclusion asserts the existence of an integer $k$ and of two
+modular forms $g, h$ of weight $k$ for the congruence subgroup $\Gamma_0(N)$ with $h \neq 0$, such
+that in $\mathbb{C}((q))$ one has $x \cdot \tilde h = \tilde g$, where $\tilde g, \tilde h \in
+\mathbb{C}[[q]] \subseteq \mathbb{C}((q))$ denote the $q$-expansions of $g$ and $h$ at $i\infty$
+taken with width $1$. Thus $x$ is the $q$-expansion of the ratio $g/h$ of two forms of equal weight
+on $\Gamma_0(N)$.
+
+This is one half of the classical identification of the function field $\mathbb{C}(X_0(N)) =
+\mathbb{C}(j(q^d) : d \mid N)$ with the field of weight-$0$ meromorphic modular functions for
+$\Gamma_0(N)$, in the concrete shape needed to evaluate elements of the Laurent-series field at
+points of the upper half-plane. It is used throughout the dictionary between the algebraic model of
+$X_0(N)$ and the analytic picture, for instance in the treatment of Abel–Jacobi maps, period
+lattices and Hecke correspondences.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange
+
+noncomputable section
+
+open UpperHalfPlane
+open scoped MatrixGroups
+
+namespace ModularCurve
+p2m_export "ModularCurve" "divisorExpansions modularFunctionFieldFull coeffMap_single \
+  algebraMap_laurentSeries_eq_single coeffEmb laurentBaseChange mem_laurentBaseChange_iff \
+  exists_modularForm_mul_qExpansion_eq_coeffEmb_qExpand_jq"
+namespace RatioFieldOfLevel
+p2m_open "ModularCurve"
+
+variable {N : ℕ}
+
+abbrev qL {k : ℤ} (f : ModularForm (CongruenceSubgroup.Gamma0 N) k) : LaurentSeries ℂ :=
+  ((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+
+theorem one_mem_strictPeriods (N : ℕ) :
+    (1 : ℝ) ∈ (CongruenceSubgroup.Gamma0 N : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  simp
+
+theorem qL_ne_zero {k : ℤ} (f : ModularForm (CongruenceSubgroup.Gamma0 N) k) (hf : f ≠ 0) :
+    qL f ≠ 0 := by
+  intro h
+  apply hf
+  rw [← ModularForm.qExpansion_eq_zero_iff one_pos (one_mem_strictPeriods N)]
+  apply (HahnSeries.ofPowerSeries_injective (Γ := ℤ) (R := ℂ))
+  simpa [qL] using h
+
+theorem qL_mul {a b : ℤ} (f : ModularForm (CongruenceSubgroup.Gamma0 N) a)
+    (g : ModularForm (CongruenceSubgroup.Gamma0 N) b) : qL (f.mul g) = qL f * qL g := by
+  simp only [qL, ModularForm.coe_mul,
+    ModularForm.qExpansion_mul_coe one_pos (one_mem_strictPeriods N), PowerSeries.coe_mul]
+
+theorem qL_add {a : ℤ} (f g : ModularForm (CongruenceSubgroup.Gamma0 N) a) :
+    qL (f + g) = qL f + qL g := by
+  simp only [qL, FunLike.coe_add,
+    ModularForm.qExpansion_add one_pos (one_mem_strictPeriods N), PowerSeries.coe_add]
+
+theorem qL_one : qL (1 : ModularForm (CongruenceSubgroup.Gamma0 N) 0) = 1 := by
+  simp only [qL, ModularForm.qExpansion_one, PowerSeries.coe_one]
+
+theorem qL_const (c : ℂ) :
+    qL (c • (1 : ModularForm (CongruenceSubgroup.Gamma0 N) 0)) =
+      algebraMap ℂ (LaurentSeries ℂ) c := by
+  rw [qL, FunLike.coe_smul,
+    ModularForm.qExpansion_smul one_pos (one_mem_strictPeriods N), ModularForm.qExpansion_one,
+    Algebra.smul_def, mul_one, HahnSeries.algebraMap_apply']
+
+theorem one_ne_zero' : (1 : ModularForm (CongruenceSubgroup.Gamma0 N) 0) ≠ 0 := by
+  intro h
+  have := congrArg
+    (fun F : ModularForm (CongruenceSubgroup.Gamma0 N) 0 => (F : ℍ → ℂ) UpperHalfPlane.I) h
+  simp [ModularForm.one_coe_eq_one] at this
+
+theorem mul_ne_zero' {a b : ℤ} (f : ModularForm (CongruenceSubgroup.Gamma0 N) a)
+    (g : ModularForm (CongruenceSubgroup.Gamma0 N) b) (hf : f ≠ 0) (hg : g ≠ 0) :
+    f.mul g ≠ 0 := by
+  intro hfg
+  have h := congrArg (qL (N := N)) hfg
+  rw [qL_mul] at h
+  have h0 : qL (0 : ModularForm (CongruenceSubgroup.Gamma0 N) (a + b)) = 0 := by
+    simp only [qL, FunLike.coe_zero, UpperHalfPlane.qExpansion_zero (1 : ℝ), PowerSeries.coe_zero]
+  rw [h0] at h
+  exact (mul_ne_zero (qL_ne_zero f hf) (qL_ne_zero g hg)) h
+
+variable (N) in
+def IsRatio (x : LaurentSeries ℂ) : Prop :=
+  ∃ (k : ℤ) (g h : ModularForm (CongruenceSubgroup.Gamma0 N) k), h ≠ 0 ∧ x * qL h = qL g
+
+theorem isRatio_algebraMap (c : ℂ) : IsRatio N (algebraMap ℂ (LaurentSeries ℂ) c) :=
+  ⟨0, c • 1, 1, one_ne_zero', by rw [qL_one, mul_one, qL_const]⟩
+
+theorem isRatio_one : IsRatio N 1 := by
+  simpa using isRatio_algebraMap (N := N) 1
+
+theorem IsRatio.mul {x y : LaurentSeries ℂ} (hx : IsRatio N x) (hy : IsRatio N y) :
+    IsRatio N (x * y) := by
+  obtain ⟨a, g, h, hh, hxe⟩ := hx
+  obtain ⟨b, g', h', hh', hye⟩ := hy
+  refine ⟨a + b, g.mul g', h.mul h', mul_ne_zero' h h' hh hh', ?_⟩
+  rw [qL_mul, qL_mul, ← hxe, ← hye]; ring
+
+theorem IsRatio.add {x y : LaurentSeries ℂ} (hx : IsRatio N x) (hy : IsRatio N y) :
+    IsRatio N (x + y) := by
+  obtain ⟨a, g, h, hh, hxe⟩ := hx
+  obtain ⟨b, g', h', hh', hye⟩ := hy
+  refine ⟨a + b, g.mul h' + ModularForm.mcast (add_comm b a) (g'.mul h), h.mul h',
+    mul_ne_zero' h h' hh hh', ?_⟩
+  have hc : qL (ModularForm.mcast (add_comm b a) (g'.mul h)) = qL g' * qL h := by
+    rw [← qL_mul]; simp only [qL, ModularForm.coe_mcast]
+  rw [qL_add, qL_mul, qL_mul, hc, ← hxe, ← hye]; ring
+
+theorem IsRatio.neg {x : LaurentSeries ℂ} (hx : IsRatio N x) : IsRatio N (-x) := by
+  have : -x = algebraMap ℂ (LaurentSeries ℂ) (-1) * x := by rw [map_neg, map_one]; ring
+  rw [this]
+  exact (isRatio_algebraMap (-1)).mul hx
+
+theorem IsRatio.inv {x : LaurentSeries ℂ} (hx : IsRatio N x) : IsRatio N x⁻¹ := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · simpa using isRatio_algebraMap (N := N) 0
+  obtain ⟨a, g, h, hh, hxe⟩ := hx
+  have hg : g ≠ 0 := by
+    intro hg0
+    have : qL g = 0 := by
+      simp only [hg0, qL, FunLike.coe_zero, UpperHalfPlane.qExpansion_zero (1 : ℝ),
+        PowerSeries.coe_zero]
+    rw [this] at hxe
+    exact (mul_ne_zero hx0 (qL_ne_zero h hh)) hxe
+  refine ⟨a, h, g, hg, ?_⟩
+  rw [← hxe, mul_comm x, mul_comm x⁻¹, mul_assoc, mul_inv_cancel₀ hx0, mul_one]
+
+theorem coeffEmb_algebraMap (r : ℚ) :
+    coeffEmb ℂ (algebraMap ℚ (LaurentSeries ℚ) r) = algebraMap ℂ (LaurentSeries ℂ) (r : ℂ) := by
+  rw [algebraMap_laurentSeries_eq_single, algebraMap_laurentSeries_eq_single, coeffEmb,
+    coeffMap_single]
+  simp
+
+variable (N) in
+theorem isRatio_coeffEmb [NeZero N] {y : LaurentSeries ℚ} (hy : y ∈ modularFunctionFieldFull N) :
+    IsRatio N (coeffEmb ℂ y) := by
+  change y ∈ Subfield.closure (Set.range (algebraMap ℚ (LaurentSeries ℚ)) ∪ divisorExpansions N)
+    at hy
+  induction hy using Subfield.closure_induction with
+  | mem z hz =>
+      rcases hz with ⟨r, rfl⟩ | ⟨d, hd0, hdN, rfl⟩
+      · rw [coeffEmb_algebraMap]; exact isRatio_algebraMap _
+      · have := hd0
+        obtain ⟨k, g, h, hh, he⟩ :=
+          ModularCurve.exists_modularForm_mul_qExpansion_eq_coeffEmb_qExpand_jq N d hdN
+        exact ⟨k, g, h, hh, he⟩
+  | one => simpa using isRatio_one (N := N)
+  | add x y _ _ hx hy => simpa using hx.add hy
+  | neg x _ hx => simpa using hx.neg
+  | inv x _ hx => simpa using hx.inv
+  | mul x y _ _ hx hy => simpa using hx.mul hy
+
+variable (N) in
+theorem isRatio_of_mem [NeZero N] {x : LaurentSeries ℂ}
+    (hx : x ∈ laurentBaseChange ℂ (modularFunctionFieldFull N)) : IsRatio N x := by
+  rw [mem_laurentBaseChange_iff] at hx
+  induction hx using Subfield.closure_induction with
+  | mem z hz =>
+      rcases hz with ⟨c, rfl⟩ | ⟨y, hy, rfl⟩
+      · exact isRatio_algebraMap c
+      · exact isRatio_coeffEmb N hy
+  | one => exact isRatio_one
+  | add x y _ _ hx hy => exact hx.add hy
+  | neg x _ hx => exact hx.neg
+  | inv x _ hx => exact hx.inv
+  | mul x y _ _ hx hy => exact hx.mul hy
+
+end ModularCurve.RatioFieldOfLevel
+
+end
+
+open UpperHalfPlane in
+theorem solution (N : ℕ)
+    [NeZero N] (x : LaurentSeries ℂ)
+    (hx : x ∈ ModularCurve.laurentBaseChange ℂ (ModularCurve.modularFunctionFieldFull N)) :
+    ∃ (k : ℤ) (g h : ModularForm (CongruenceSubgroup.Gamma0 N) k), h ≠ 0 ∧
+      x * ((qExpansion 1 (h : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+        ((qExpansion 1 (g : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) :=
+  ModularCurve.RatioFieldOfLevel.isRatio_of_mem N hx
+
+end S_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange
+end P2MW
+export P2MW.S_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane in
+theorem ModularCurve.exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange (N : ℕ)
+    [NeZero N] (x : LaurentSeries ℂ)
+    (hx : x ∈ ModularCurve.laurentBaseChange ℂ (ModularCurve.modularFunctionFieldFull N)) :
+    ∃ (k : ℤ) (g h : ModularForm (CongruenceSubgroup.Gamma0 N) k), h ≠ 0 ∧
+      x * ((qExpansion 1 (h : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+        ((qExpansion 1 (g : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) :=
+  solution N x hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC.lean
new file mode 100644
index 0000000000..a138cd0dac
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC.lean
@@ -0,0 +1,249 @@
+/-
+Based on Prove2Me node
+ModularCurve.exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC
+(33ba6941-ae96-5a37-b6ef-2d875c317bd8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 17f04867-e214-5b77-9a5c-7a449e4ade11
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Analysis.CStarAlgebra.Classes
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_qExpFunctionFieldC_eq
+
+/-!
+# Elements of the base-changed q-expansion field are ratios of forms
+
+Theorem statement:
+`ModularCurve.exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC`
+(`33ba6941-ae96-5a37-b6ef-2d875c317bd8`), by Claude, 2026-09-05.
+
+Proof: submission `17f04867-e214-5b77-9a5c-7a449e4ade11`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of $\mathrm{SL}_2(\mathbb{Z})$ of finite index containing the translation
+matrix $T = \begin{pmatrix}1&1\\0&1\end{pmatrix}$, and let $x$ be a Laurent series over
+$\mathbb{C}$. Assume $x$ lies in [`ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC
+ℚ Γ)`](def/ModularCurve_LaurentCoeff.html#L103), that is, in the intermediate field of
+$\mathbb{C}((q))$ generated over $\mathbb{C}$ by the image of [`ModularCurve.qExpFunctionFieldC ℚ
+Γ`](def/ModularCurve_X1.html#L101) under the coefficientwise map $\mathbb{Q}((q)) \to
+\mathbb{C}((q))$ induced by $\mathbb{Q} \to \mathbb{C}$; here `qExpFunctionFieldC ℚ Γ` is the
+intermediate field of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by the set `intFormRatiosC ℚ Γ`
+of quotients $\mathrm{intSeriesC}\,\mathbb{Q}\,p_f / \mathrm{intSeriesC}\,\mathbb{Q}\,p_g$, taken
+over all $k \in \mathbb{Z}$, all modular forms $f, g$ of weight $k$ for the image of $\Gamma$ in
+$\mathrm{GL}_2(\mathbb{R})$, and all integral power series $p_f, p_g$ satisfying the predicate
+`IsIntegralQExp` relative to $f$ and to $g$ respectively, subject to
+$\mathrm{intSeriesC}\,\mathbb{Q}\,p_g \neq 0$. The conclusion is that there exist a weight $k \in
+\mathbb{Z}$ and modular forms $g, h$ of weight $k$ for $\Gamma$ (viewed as a subgroup of
+$\mathrm{GL}_2(\mathbb{R})$) with $h \neq 0$ such that, in $\mathbb{C}((q))$, the product of $x$
+with the $q$-expansion of $h$ of period $1$ equals the $q$-expansion of $g$ of period $1$, both
+expansions being coerced from power series to Laurent series.
+
+This is the analytic description of the function field of the modular curve of level $\Gamma$: every
+element of $\mathbb{C}\cdot\mathbb{Q}(X(\Gamma))$, realised inside $\mathbb{C}((q))$, is the ratio
+of the $q$-expansions of two modular forms of equal weight on $\Gamma$. It is the $\Gamma$-generic
+form of the corresponding statement for $\Gamma_0(N)$ and serves as a shared input for the
+weight-$2m$ criterion on $\Gamma_1(M)$ and for the identification of regular differentials on
+$X_1(M)$ with weight-$2$ cusp forms, being used in particular by the results on Abel–Jacobi maps and
+point realisation for $\Gamma_H$-level curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+noncomputable section
+
+open UpperHalfPlane
+open scoped MatrixGroups
+
+namespace ModularCurve
+
+namespace RatioFieldOfLevelG
+
+variable {Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)}
+
+abbrev qL {k : ℤ} (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) : LaurentSeries ℂ :=
+  ((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+
+theorem one_mem_strictPeriods (hT : ModularGroup.T ∈ Γ) :
+    (1 : ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  rw [Subgroup.strictPeriods_eq_zmultiples_one_of_T_mem hT]
+  exact AddSubgroup.mem_zmultiples 1
+
+theorem qL_ne_zero (hT : ModularGroup.T ∈ Γ) {k : ℤ}
+    (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hf : f ≠ 0) :
+    qL f ≠ 0 := by
+  intro h
+  apply hf
+  rw [← ModularForm.qExpansion_eq_zero_iff one_pos (one_mem_strictPeriods hT)]
+  apply (HahnSeries.ofPowerSeries_injective (Γ := ℤ) (R := ℂ))
+  simpa [qL] using h
+
+theorem qL_mul (hT : ModularGroup.T ∈ Γ) {a b : ℤ} (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) a)
+    (g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) b) : qL (f.mul g) = qL f * qL g := by
+  simp only [qL, ModularForm.coe_mul,
+    ModularForm.qExpansion_mul_coe one_pos (one_mem_strictPeriods hT), PowerSeries.coe_mul]
+
+theorem qL_add (hT : ModularGroup.T ∈ Γ) {a : ℤ} (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) a)
+    :
+    qL (f + g) = qL f + qL g := by
+  simp only [qL, FunLike.coe_add,
+    ModularForm.qExpansion_add one_pos (one_mem_strictPeriods hT), PowerSeries.coe_add]
+
+theorem qL_one : qL (1 : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 0) = 1 := by
+  simp only [qL, ModularForm.qExpansion_one, PowerSeries.coe_one]
+
+theorem qL_const (hT : ModularGroup.T ∈ Γ) (c : ℂ) :
+    qL (c • (1 : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 0)) =
+      algebraMap ℂ (LaurentSeries ℂ) c := by
+  rw [qL, FunLike.coe_smul,
+    ModularForm.qExpansion_smul one_pos (one_mem_strictPeriods hT), ModularForm.qExpansion_one,
+    Algebra.smul_def, mul_one, HahnSeries.algebraMap_apply']
+
+theorem one_ne_zero' : (1 : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 0) ≠ 0 := by
+  intro h
+  have := congrArg
+    (fun F : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 0 => (F : ℍ → ℂ) UpperHalfPlane.I) h
+  simp [ModularForm.one_coe_eq_one] at this
+
+theorem mul_ne_zero' (hT : ModularGroup.T ∈ Γ) {a b : ℤ}
+    (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) a)
+    (g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) b) (hf : f ≠ 0) (hg : g ≠ 0) :
+    f.mul g ≠ 0 := by
+  intro hfg
+  have h := congrArg (qL (Γ := Γ)) hfg
+  rw [qL_mul hT] at h
+  have h0 : qL (0 : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) (a + b)) = 0 := by
+    simp only [qL, FunLike.coe_zero, UpperHalfPlane.qExpansion_zero (1 : ℝ), PowerSeries.coe_zero]
+  rw [h0] at h
+  exact (mul_ne_zero (qL_ne_zero hT f hf) (qL_ne_zero hT g hg)) h
+
+variable (Γ) in
+def IsRatio (x : LaurentSeries ℂ) : Prop :=
+  ∃ (k : ℤ) (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k), h ≠ 0 ∧ x * qL h = qL g
+
+theorem isRatio_algebraMap (hT : ModularGroup.T ∈ Γ) (c : ℂ) :
+    IsRatio Γ (algebraMap ℂ (LaurentSeries ℂ) c) :=
+  ⟨0, c • 1, 1, one_ne_zero', by rw [qL_one, mul_one, qL_const hT]⟩
+
+theorem isRatio_one (hT : ModularGroup.T ∈ Γ) : IsRatio Γ 1 := by
+  simpa using isRatio_algebraMap hT 1
+
+theorem IsRatio.mul (hT : ModularGroup.T ∈ Γ) {x y : LaurentSeries ℂ} (hx : IsRatio Γ x)
+    (hy : IsRatio Γ y) :
+    IsRatio Γ (x * y) := by
+  obtain ⟨a, g, h, hh, hxe⟩ := hx
+  obtain ⟨b, g', h', hh', hye⟩ := hy
+  refine ⟨a + b, g.mul g', h.mul h', mul_ne_zero' hT h h' hh hh', ?_⟩
+  rw [qL_mul hT, qL_mul hT, ← hxe, ← hye]; ring
+
+theorem IsRatio.add (hT : ModularGroup.T ∈ Γ) {x y : LaurentSeries ℂ} (hx : IsRatio Γ x)
+    (hy : IsRatio Γ y) :
+    IsRatio Γ (x + y) := by
+  obtain ⟨a, g, h, hh, hxe⟩ := hx
+  obtain ⟨b, g', h', hh', hye⟩ := hy
+  refine ⟨a + b, g.mul h' + ModularForm.mcast (add_comm b a) (g'.mul h), h.mul h',
+    mul_ne_zero' hT h h' hh hh', ?_⟩
+  have hc : qL (ModularForm.mcast (add_comm b a) (g'.mul h)) = qL g' * qL h := by
+    rw [← qL_mul hT]; simp only [qL, ModularForm.coe_mcast]
+  rw [qL_add hT, qL_mul hT, qL_mul hT, hc, ← hxe, ← hye]; ring
+
+theorem IsRatio.neg (hT : ModularGroup.T ∈ Γ) {x : LaurentSeries ℂ} (hx : IsRatio Γ x) :
+    IsRatio Γ (-x) := by
+  have : -x = algebraMap ℂ (LaurentSeries ℂ) (-1) * x := by rw [map_neg, map_one]; ring
+  rw [this]
+  exact (isRatio_algebraMap hT (-1)).mul hT hx
+
+theorem IsRatio.inv (hT : ModularGroup.T ∈ Γ) {x : LaurentSeries ℂ} (hx : IsRatio Γ x) :
+    IsRatio Γ x⁻¹ := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · simpa using isRatio_algebraMap hT 0
+  obtain ⟨a, g, h, hh, hxe⟩ := hx
+  have hg : g ≠ 0 := by
+    intro hg0
+    have : qL g = 0 := by
+      simp only [hg0, qL, FunLike.coe_zero, UpperHalfPlane.qExpansion_zero (1 : ℝ),
+        PowerSeries.coe_zero]
+    rw [this] at hxe
+    exact (mul_ne_zero hx0 (qL_ne_zero hT h hh)) hxe
+  refine ⟨a, h, g, hg, ?_⟩
+  rw [← hxe, mul_comm x, mul_comm x⁻¹, mul_assoc, mul_inv_cancel₀ hx0, mul_one]
+
+theorem intSeriesC_eq_qL {k : ℤ} {f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k}
+    {p : PowerSeries ℤ}
+    (hp : IsIntegralQExp (f : ℍ → ℂ) p) : intSeriesC ℂ p = qL f := by
+  rw [intSeriesC, qL]
+  exact congrArg (HahnSeries.ofPowerSeries ℤ ℂ) hp
+
+theorem isRatio_of_mem_intFormRatiosC (hT : ModularGroup.T ∈ Γ) {x : LaurentSeries ℂ}
+    (hx : x ∈ intFormRatiosC ℂ Γ) :
+    IsRatio Γ x := by
+  obtain ⟨k, f, g, pf, pg, hf, hg, hg0, rfl⟩ := hx
+  have hg' : g ≠ 0 := by
+    intro h0
+    apply hg0
+    rw [intSeriesC_eq_qL hg, h0]
+    simp only [qL, FunLike.coe_zero, UpperHalfPlane.qExpansion_zero (1 : ℝ), PowerSeries.coe_zero]
+  refine ⟨k, f, g, hg', ?_⟩
+  rw [intSeriesC_eq_qL hf, intSeriesC_eq_qL hg, div_mul_cancel₀ _ (qL_ne_zero hT g hg')]
+
+theorem isRatio_of_mem (hT : ModularGroup.T ∈ Γ) {x : LaurentSeries ℂ}
+    (hx : x ∈ laurentBaseChange ℂ (qExpFunctionFieldC ℚ Γ)) : IsRatio Γ x := by
+  rw [ModularCurve.laurentBaseChange_qExpFunctionFieldC_eq] at hx
+  change x ∈ Subfield.closure
+    (Set.range (algebraMap ℂ (LaurentSeries ℂ)) ∪ intFormRatiosC ℂ Γ) at hx
+  induction hx using Subfield.closure_induction with
+  | mem z hz =>
+      rcases hz with ⟨c, rfl⟩ | hz
+      · exact isRatio_algebraMap hT c
+      · exact isRatio_of_mem_intFormRatiosC hT hz
+  | one => exact isRatio_one hT
+  | add x y _ _ hx hy => exact hx.add hT hy
+  | neg x _ hx => exact hx.neg hT
+  | inv x _ hx => exact hx.inv hT
+  | mul x y _ _ hx hy => exact hx.mul hT hy
+
+end ModularCurve.RatioFieldOfLevelG
+
+end
+
+open UpperHalfPlane in
+theorem solution (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hT : ModularGroup.T ∈ Γ)
+    (x : LaurentSeries ℂ)
+    (hx : x ∈ ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ)) :
+    ∃ (k : ℤ) (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k), h ≠ 0 ∧
+      x * ((qExpansion 1 (h : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+        ((qExpansion 1 (g : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) :=
+  ModularCurve.RatioFieldOfLevelG.isRatio_of_mem hT hx
+
+end privateSection
+
+public section publicSection
+
+open UpperHalfPlane in
+theorem
+  ModularCurve.exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    (x : LaurentSeries ℂ)
+    (hx : x ∈ ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ)) :
+    ∃ (k : ℤ) (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k), h ≠ 0 ∧
+      x * ((qExpansion 1 (h : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+        ((qExpansion 1 (g : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) :=
+  solution Γ hT x hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC_of_T_mem.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC_of_T_mem.lean
new file mode 100644
index 0000000000..7d83ac7414
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC_of_T_mem.lean
@@ -0,0 +1,289 @@
+/-
+Based on Prove2Me node
+ModularCurve.
+exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC_of_T_mem
+(f63f1e25-7d3e-5e9b-a87a-3c7938f9a13e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b051b46b-d109-56ea-8911-ae482b0dcf57
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Analysis.CStarAlgebra.Classes
+
+/-!
+# Elements of ℂ· F(Γ) are ratios of modular forms
+
+Theorem statement:
+`ModularCurve.
+exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC_of_T_mem`
+(`f63f1e25-7d3e-5e9b-a87a-3c7938f9a13e`), by Claude, 2026-09-05.
+
+Proof: submission `b051b46b-d109-56ea-8911-ae482b0dcf57`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of $\mathrm{SL}_2(\mathbb{Z})$ containing the translation matrix $T$ (no
+finite-index hypothesis is imposed), and let $x$ be a Laurent series over $\mathbb{C}$. Assume $x$
+lies in [`ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+Γ)`](def/ModularCurve_LaurentCoeff.html#L103), that is, in the intermediate field of
+$\mathbb{C}((q))$ generated over $\mathbb{C}$ by the coefficientwise image under $\mathbb{Q} \to
+\mathbb{C}$ of the intermediate field `qExpFunctionFieldC ℚ Γ` of $\mathbb{Q}((q))$, the latter
+being generated over $\mathbb{Q}$ by the set of quotients `intSeriesC ℚ pf / intSeriesC ℚ pg` in
+which $k$ is an integer, $f$ and $g$ are modular forms of weight $k$ for $\Gamma$ (regarded inside
+$\mathrm{GL}_2(\mathbb{R})$), $pf$ and $pg$ are power series over $\mathbb{Z}$ satisfying
+`IsIntegralQExp f pf` and `IsIntegralQExp g pg`, and `intSeriesC ℚ pg ≠ 0`. The conclusion is that
+there are an integer $k$ and modular forms $g, h$ of weight $k$ for $\Gamma$ with $h \neq 0$ such
+that, in $\mathbb{C}((q))$, the product of $x$ with the period-$1$ $q$-expansion of $h$ equals the
+period-$1$ $q$-expansion of $g$.
+
+This identifies the field of $q$-expansions of level $\Gamma$ with the field of $q$-expansions of
+ratios $g/h$ of two modular forms of a single weight on $\Gamma$; the hypothesis $T \in \Gamma$ is
+what makes period-$1$ $q$-expansions multiplicative. It is used in the analysis of the Galois action
+on points of modular curves, in particular in the results describing how algebra automorphisms and
+complex conjugation act on points via $q$-expansions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC_of_T_mem.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+noncomputable section
+
+open UpperHalfPlane
+open scoped MatrixGroups
+
+namespace ModularCurve
+
+namespace RatioFieldOfGroup
+
+variable {Γ : Subgroup SL(2, ℤ)}
+
+abbrev qL {k : ℤ} (f : ModularForm Γ k) : LaurentSeries ℂ :=
+  ((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+
+theorem one_mem_strictPeriods (hT : ModularGroup.T ∈ Γ) :
+    (1 : ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  rw [Subgroup.strictPeriods_eq_zmultiples_one_of_T_mem hT]
+  exact AddSubgroup.mem_zmultiples _
+
+variable (hT : ModularGroup.T ∈ Γ)
+include hT
+
+theorem qL_ne_zero {k : ℤ} (f : ModularForm Γ k) (hf : f ≠ 0) : qL f ≠ 0 := by
+  intro h
+  apply hf
+  rw [← ModularForm.qExpansion_eq_zero_iff one_pos (one_mem_strictPeriods hT)]
+  apply (HahnSeries.ofPowerSeries_injective (Γ := ℤ) (R := ℂ))
+  simpa [qL] using h
+
+theorem qL_mul {a b : ℤ} (f : ModularForm Γ a) (g : ModularForm Γ b) :
+    qL (f.mul g) = qL f * qL g := by
+  simp only [qL, ModularForm.coe_mul,
+    ModularForm.qExpansion_mul_coe one_pos (one_mem_strictPeriods hT), PowerSeries.coe_mul]
+
+theorem qL_add {a : ℤ} (f g : ModularForm Γ a) : qL (f + g) = qL f + qL g := by
+  simp only [qL, FunLike.coe_add,
+    ModularForm.qExpansion_add one_pos (one_mem_strictPeriods hT), PowerSeries.coe_add]
+
+omit hT in
+theorem qL_one : qL (1 : ModularForm Γ 0) = 1 := by
+  simp only [qL, ModularForm.qExpansion_one, PowerSeries.coe_one]
+
+theorem qL_const (c : ℂ) :
+    qL (c • (1 : ModularForm Γ 0)) = algebraMap ℂ (LaurentSeries ℂ) c := by
+  rw [qL, FunLike.coe_smul,
+    ModularForm.qExpansion_smul one_pos (one_mem_strictPeriods hT), ModularForm.qExpansion_one,
+    Algebra.smul_def, mul_one, HahnSeries.algebraMap_apply']
+
+omit hT in
+theorem one_ne_zero' : (1 : ModularForm Γ 0) ≠ 0 := by
+  intro h
+  have := congrArg (fun F : ModularForm Γ 0 => (F : ℍ → ℂ) UpperHalfPlane.I) h
+  simp [ModularForm.one_coe_eq_one] at this
+
+theorem mul_ne_zero'
+    {a b : ℤ} (f : ModularForm Γ a) (g : ModularForm Γ b) (hf : f ≠ 0) (hg : g ≠ 0) :
+    f.mul g ≠ 0 := by
+  intro hfg
+  have h := congrArg (qL (Γ := Γ)) hfg
+  rw [qL_mul hT] at h
+  have h0 : qL (0 : ModularForm Γ (a + b)) = 0 := by
+    simp only [qL, FunLike.coe_zero, UpperHalfPlane.qExpansion_zero (1 : ℝ), PowerSeries.coe_zero]
+  rw [h0] at h
+  exact (mul_ne_zero (qL_ne_zero hT f hf) (qL_ne_zero hT g hg)) h
+
+omit hT in
+variable (Γ) in
+def IsRatio (x : LaurentSeries ℂ) : Prop :=
+  ∃ (k : ℤ) (g h : ModularForm Γ k), h ≠ 0 ∧ x * qL h = qL g
+
+theorem isRatio_algebraMap (c : ℂ) : IsRatio Γ (algebraMap ℂ (LaurentSeries ℂ) c) :=
+  ⟨0, c • 1, 1, one_ne_zero', by rw [qL_one, mul_one, qL_const hT]⟩
+
+theorem isRatio_one : IsRatio Γ 1 := by
+  simpa using isRatio_algebraMap hT 1
+
+theorem IsRatio.mul {x y : LaurentSeries ℂ} (hx : IsRatio Γ x) (hy : IsRatio Γ y) :
+    IsRatio Γ (x * y) := by
+  obtain ⟨a, g, h, hh, hxe⟩ := hx
+  obtain ⟨b, g', h', hh', hye⟩ := hy
+  refine ⟨a + b, g.mul g', h.mul h', mul_ne_zero' hT h h' hh hh', ?_⟩
+  rw [qL_mul hT, qL_mul hT, ← hxe, ← hye]; ring
+
+theorem IsRatio.add {x y : LaurentSeries ℂ} (hx : IsRatio Γ x) (hy : IsRatio Γ y) :
+    IsRatio Γ (x + y) := by
+  obtain ⟨a, g, h, hh, hxe⟩ := hx
+  obtain ⟨b, g', h', hh', hye⟩ := hy
+  refine ⟨a + b, g.mul h' + ModularForm.mcast (add_comm b a) (g'.mul h), h.mul h',
+    mul_ne_zero' hT h h' hh hh', ?_⟩
+  have hc : qL (ModularForm.mcast (add_comm b a) (g'.mul h)) = qL g' * qL h := by
+    rw [← qL_mul hT]; simp only [qL, ModularForm.coe_mcast]
+  rw [qL_add hT, qL_mul hT, qL_mul hT, hc, ← hxe, ← hye]; ring
+
+theorem IsRatio.neg {x : LaurentSeries ℂ} (hx : IsRatio Γ x) : IsRatio Γ (-x) := by
+  have : -x = algebraMap ℂ (LaurentSeries ℂ) (-1) * x := by rw [map_neg, map_one]; ring
+  rw [this]
+  exact (isRatio_algebraMap hT (-1)).mul hT hx
+
+theorem IsRatio.inv {x : LaurentSeries ℂ} (hx : IsRatio Γ x) : IsRatio Γ x⁻¹ := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · simpa using isRatio_algebraMap hT 0
+  obtain ⟨a, g, h, hh, hxe⟩ := hx
+  have hg : g ≠ 0 := by
+    intro hg0
+    have : qL g = 0 := by
+      simp only [hg0, qL, FunLike.coe_zero, UpperHalfPlane.qExpansion_zero (1 : ℝ),
+        PowerSeries.coe_zero]
+    rw [this] at hxe
+    exact (mul_ne_zero hx0 (qL_ne_zero hT h hh)) hxe
+  refine ⟨a, h, g, hg, ?_⟩
+  rw [← hxe, mul_comm x, mul_comm x⁻¹, mul_assoc, mul_inv_cancel₀ hx0, mul_one]
+
+omit hT in
+theorem coeffEmb_algebraMap (r : ℚ) :
+    coeffEmb ℂ (algebraMap ℚ (LaurentSeries ℚ) r) = algebraMap ℂ (LaurentSeries ℂ) (r : ℂ) := by
+  rw [algebraMap_laurentSeries_eq_single, algebraMap_laurentSeries_eq_single, coeffEmb,
+    coeffMap_single]
+  simp
+
+omit hT in
+theorem coeffEmb_intSeriesC (p : PowerSeries ℤ) : coeffEmb ℂ (intSeriesC ℚ p) = intSeriesC ℂ p := by
+  ext k
+  rw [coeffEmb_coeff]
+  rcases lt_or_ge k 0 with hk | hk
+  · rw [intSeriesC, intSeriesC, ofPowerSeries_coeff_of_neg _ hk, ofPowerSeries_coeff_of_neg _ hk,
+      map_zero]
+  · lift k to ℕ using hk with k
+    rw [intSeriesC, intSeriesC, HahnSeries.ofPowerSeries_apply_coeff,
+      HahnSeries.ofPowerSeries_apply_coeff, PowerSeries.coeff_map, PowerSeries.coeff_map,
+      eq_intCast,
+      eq_intCast, map_intCast]
+
+omit hT in
+theorem intSeriesC_eq_qL
+    {k : ℤ} {f : ModularForm Γ k} {p : PowerSeries ℤ} (hf : IsIntegralQExp f p) :
+    intSeriesC ℂ p = qL f := by
+  rw [intSeriesC, hf]
+
+omit hT in
+theorem isRatio_coeffEmb_of_mem_intFormRatiosC {y : LaurentSeries ℚ} (hy : y ∈ intFormRatiosC ℚ Γ) :
+    IsRatio Γ (coeffEmb ℂ y) := by
+  obtain ⟨k, f, g, pf, pg, hf, hg, hg0, rfl⟩ := hy
+  have hpg : pg ≠ 0 := by
+    rintro rfl
+    exact hg0 (intSeriesC_zero ℚ)
+  have hgC : intSeriesC ℂ pg ≠ 0 := by
+    intro h
+    apply hpg
+    ext n
+    have := congrArg (fun s : LaurentSeries ℂ => s.coeff (n : ℤ)) h
+    simp only [intSeriesC, HahnSeries.ofPowerSeries_apply_coeff, PowerSeries.coeff_map, eq_intCast,
+      HahnSeries.coeff_zero, Int.cast_eq_zero] at this
+    simpa using this
+  have hgne : g ≠ 0 := by
+    intro h0
+    apply hgC
+    rw [intSeriesC_eq_qL hg, h0]
+    simp only [qL, FunLike.coe_zero, UpperHalfPlane.qExpansion_zero (1 : ℝ), PowerSeries.coe_zero]
+  refine ⟨k, f, g, hgne, ?_⟩
+  rw [map_div₀, coeffEmb_intSeriesC, coeffEmb_intSeriesC, intSeriesC_eq_qL hf, intSeriesC_eq_qL hg,
+    div_mul_cancel₀ _ (by rw [← intSeriesC_eq_qL hg]; exact hgC)]
+
+theorem isRatio_coeffEmb {y : LaurentSeries ℚ} (hy : y ∈ qExpFunctionFieldC ℚ Γ) :
+    IsRatio Γ (coeffEmb ℂ y) := by
+  change y ∈ Subfield.closure (Set.range (algebraMap ℚ (LaurentSeries ℚ))
+    ∪ intFormRatiosC ℚ Γ) at hy
+  induction hy using Subfield.closure_induction with
+  | mem z hz =>
+      rcases hz with ⟨r, rfl⟩ | hz
+      · rw [coeffEmb_algebraMap]; exact isRatio_algebraMap hT _
+      · exact isRatio_coeffEmb_of_mem_intFormRatiosC hz
+  | one => simpa using isRatio_one hT
+  | add x y _ _ hx hy => simpa using hx.add hT hy
+  | neg x _ hx => simpa using hx.neg hT
+  | inv x _ hx => simpa using hx.inv hT
+  | mul x y _ _ hx hy => simpa using hx.mul hT hy
+
+theorem isRatio_of_mem {x : LaurentSeries ℂ}
+    (hx : x ∈ laurentBaseChange ℂ (qExpFunctionFieldC ℚ Γ)) : IsRatio Γ x := by
+  rw [mem_laurentBaseChange_iff] at hx
+  induction hx using Subfield.closure_induction with
+  | mem z hz =>
+      rcases hz with ⟨c, rfl⟩ | ⟨y, hy, rfl⟩
+      · exact isRatio_algebraMap hT c
+      · exact isRatio_coeffEmb hT hy
+  | one => exact isRatio_one hT
+  | add x y _ _ hx hy => exact hx.add hT hy
+  | neg x _ hx => exact hx.neg hT
+  | inv x _ hx => exact hx.inv hT
+  | mul x y _ _ hx hy => exact hx.mul hT hy
+
+end ModularCurve.RatioFieldOfGroup
+
+end
+
+open scoped MatrixGroups in
+theorem solution
+    (Γ : Subgroup SL(2, ℤ)) (hT : ModularGroup.T ∈ Γ) (x : LaurentSeries ℂ)
+    (hx : x ∈ ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ)) :
+    ∃ (k : ℤ) (g h : ModularForm Γ k), h ≠ 0 ∧
+      x * ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+        =
+        ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+          :=
+  ModularCurve.RatioFieldOfGroup.isRatio_of_mem hT hx
+
+end privateSection
+
+public section publicSection
+
+open scoped MatrixGroups
+namespace ModularCurve
+
+theorem
+  exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC_of_T_mem
+    (Γ : Subgroup SL(2, ℤ)) (hT : ModularGroup.T ∈ Γ) (x : LaurentSeries ℂ)
+    (hx : x ∈ ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ)) :
+    ∃ (k : ℤ) (g h : ModularForm Γ k), h ≠ 0 ∧
+      x * ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+        =
+        ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+          :=
+  solution Γ hT x hx
+
+end ModularCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_monic_evalAtJ_jqN_eq_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_monic_evalAtJ_jqN_eq_zero.lean
new file mode 100644
index 0000000000..f1ff2a2313
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_monic_evalAtJ_jqN_eq_zero.lean
@@ -0,0 +1,161 @@
+/-
+Based on Prove2Me node ModularCurve.exists_monic_evalAtJ_jqN_eq_zero
+(fe691968-8b4a-5117-ad3d-849d8a55961b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c89e6f47-0caf-5f44-afa0-923c89ba9d3a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import Mathlib.Data.Nat.Factorization.Induction
+import Mathlib.RingTheory.IntegralClosure.IsIntegralClosure.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# j(q^N) is integral over ℤ[j(q)]
+
+Theorem statement: `ModularCurve.exists_monic_evalAtJ_jqN_eq_zero`
+(`fe691968-8b4a-5117-ad3d-849d8a55961b`), by Claude, 2026-09-05.
+
+Proof: submission `c89e6f47-0caf-5f44-afa0-923c89ba9d3a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number with $N \neq 0$. The assertion is that there is a polynomial $P$ in one
+variable over the ring $\mathbb{Z}[X]$ of integer polynomials, i.e. $P \in (\mathbb{Z}[X])[Y]$,
+which is monic, and which vanishes when its coefficients are pushed into the field of Laurent series
+$\mathrm{LaurentSeries}\ \mathbb{Q}$ by the ring homomorphism `evalAtJ` and the variable is
+evaluated at `jqN N`. Here `evalAtJ` is the ring homomorphism $\mathbb{Z}[X] \to
+\mathrm{LaurentSeries}\ \mathbb{Q}$ obtained by evaluating at the Laurent series `jq`, the
+$q$-expansion of the modular invariant $j$, so that its image is the subring $\mathbb{Z}[j(q)]$; and
+`jqN N` is the image of `jq` under `qExpand ℚ N`, the ring endomorphism of $\mathrm{LaurentSeries}\
+\mathbb{Q}$ that transports a Hahn series along multiplication by $N$ on the exponent group
+$\mathbb{Z}$ (this map being injective and order-preserving because $N > 0$), that is, the
+substitution $q \mapsto q^N$, so `jqN N` is the $q$-expansion of $j(q^N)$. Thus $j(q^N)$ satisfies a
+monic equation with coefficients in $\mathbb{Z}[j(q)]$; no irreducibility or degree statement is
+made.
+
+This is the integrality half of the classical theory of the modular equation: $j(q^N)$ is integral
+over $\mathbb{Z}[j(q)]$ inside $\mathbb{Q}((q))$, for every $N \geq 1$, with no squarefree
+restriction. It feeds the formal $q$-expansion model of the function field of $X_0(N)$, being cited
+in the construction of modular polynomial data, in the identification of levels where $\Phi_N$ is
+irreducible via a degree computation, and in the study of the $j$-shadow at full level.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_monic_evalAtJ_jqN_eq_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_monic_evalAtJ_jqN_eq_zero
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_qExpand jq jqN jqN_one dedekindPsi evalAtJ evalAtJ_X \
+  ModularPolynomialData exists_phiIrreducible_evalSymm coeffEmb"
+namespace W1
+p2m_open "ModularCurve"
+
+
+
+
+
+theorem phiAtSeed_jq_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) :
+    (phiAtSeed data jq).eval (jqN n) = 0 := by
+  have h := data.eval_eq_zero
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp [evalAtJ_X]
+
+
+theorem phiAtSeed_jqN_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN M)).eval (jqN (M * n)) = 0 := by
+  have h := phiAtSeed_eval_map data jq (jqN n) (qExpand ℚ M) (phiAtSeed_jq_eval n data)
+  rwa [jqN, qExpand_qExpand] at h
+
+theorem jqN_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) : jqN n = jqN m := by subst h; rfl
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_qExpand jq jqN jqN_one dedekindPsi evalAtJ evalAtJ_X \
+  ModularPolynomialData exists_phiIrreducible_evalSymm coeffEmb"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.exists_monic_evalAtJ_jqN_eq_zero (N : ℕ) [NeZero N] :
+    ∃ P : Polynomial (Polynomial ℤ), P.Monic ∧ P.eval₂ evalAtJ (jqN N) = 0 := by
+  let : Algebra (Polynomial ℤ) (LaurentSeries ℚ) := evalAtJ.toAlgebra
+  suffices h : ∀ (n : ℕ) [NeZero n], IsIntegral (Polynomial ℤ) (jqN n) by
+    obtain ⟨P, hP, hval⟩ := h N
+    exact ⟨P, hP, hval⟩
+  intro n
+  induction n using induction_on_primes with
+  | zero => intro h; exact absurd rfl h.out
+  | one =>
+    intro _
+    have hjq : jqN 1 = algebraMap (Polynomial ℤ) (LaurentSeries ℚ) Polynomial.X := by
+      rw [jqN_one]
+      exact evalAtJ_X.symm
+    rw [hjq]
+    exact isIntegral_algebraMap
+  | prime_mul p a hp ih =>
+    intro hpa
+    have hNp : NeZero p := ⟨hp.ne_zero⟩
+    have hNa : NeZero a := ⟨fun h => NeZero.ne (p * a) (by rw [h, Nat.mul_zero])⟩
+    have hNap : NeZero (a * p) := ⟨by rw [Nat.mul_comm]; exact NeZero.ne (p * a)⟩
+    have hFp : Fact p.Prime := ⟨hp⟩
+    have hia : IsIntegral (Polynomial ℤ) (jqN a) := ih
+    obtain ⟨data, -, -⟩ := ModularCurve.exists_phiIrreducible_evalSymm p
+    set A := Algebra.adjoin (Polynomial ℤ) ({jqN a} : Set (LaurentSeries ℚ)) with hA
+    have hmem : jqN a ∈ A := Algebra.self_mem_adjoin_singleton _ _
+    have : Algebra.IsIntegral (Polynomial ℤ) ↥A :=
+      ⟨fun x => isIntegral_algebraMap_iff.mp
+        (IsIntegral.of_mem_of_fg A hia.fg_adjoin_singleton _ x.2)⟩
+    have hroot : Polynomial.eval₂ (algebraMap ↥A (LaurentSeries ℚ)) (jqN (a * p))
+        (phiAtSeed data (⟨jqN a, hmem⟩ : ↥A)) = 0 := by
+      rw [Polynomial.eval₂_eq_eval_map, phiAtSeed_map]
+      exact W1.phiAtSeed_jqN_eval p data a
+    have hint : IsIntegral (Polynomial ℤ) (jqN (a * p)) :=
+      isIntegral_trans (jqN (a * p)) ⟨phiAtSeed data (⟨jqN a, hmem⟩ : ↥A),
+        phiAtSeed_monic data _, hroot⟩
+    rwa [W1.jqN_congr (Nat.mul_comm a p)] at hint
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_exists_monic_evalAtJ_jqN_eq_zero.ModularCurve in
+theorem solution (N : ℕ) [NeZero N] :
+    ∃ P : Polynomial (Polynomial ℤ), P.Monic ∧ P.eval₂ evalAtJ (jqN N) = 0 :=
+  ModularCurve.exists_monic_evalAtJ_jqN_eq_zero N
+
+end S_ModularCurve_exists_monic_evalAtJ_jqN_eq_zero
+end P2MW
+export P2MW.S_ModularCurve_exists_monic_evalAtJ_jqN_eq_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.exists_monic_evalAtJ_jqN_eq_zero (N : ℕ) [NeZero N] :
+    ∃ P : Polynomial (Polynomial ℤ), P.Monic ∧ P.eval₂ evalAtJ (jqN N) = 0 :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_monoidHom_gamma0_algEquiv_qExpFunctionFieldC_gammaH_of_charZero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_monoidHom_gamma0_algEquiv_qExpFunctionFieldC_gammaH_of_charZero.lean
new file mode 100644
index 0000000000..049bd97bd1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_monoidHom_gamma0_algEquiv_qExpFunctionFieldC_gammaH_of_charZero.lean
@@ -0,0 +1,1371 @@
+/-
+Based on Prove2Me node
+ModularCurve.exists_monoidHom_gamma0_algEquiv_qExpFunctionFieldC_gammaH_of_charZero
+(fe6640f4-f025-5455-a866-9bba11379d25) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 48ac79ef-6d2c-5016-99bc-503aa3ea118b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_CohCarrier_Level
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_isIntegralQExp_smul_slash_of_mem_Gamma0
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularFormClass_eq_of_forall_qCoeff_eq
+
+/-!
+# Diamond action of Γ₀(M) on the q-expansion function field
+
+Theorem statement:
+`ModularCurve.exists_monoidHom_gamma0_algEquiv_qExpFunctionFieldC_gammaH_of_charZero`
+(`fe6640f4-f025-5455-a866-9bba11379d25`), by Claude, 2026-09-05.
+
+Proof: submission `48ac79ef-6d2c-5016-99bc-503aa3ea118b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field of characteristic zero, $M$ a non-zero natural number and
+$H\le(\mathbb{Z}/M)^\times$ a subgroup; write $\Gamma_H(M)=$ [`CohCarrier.GammaH M
+H`](def/CohCarrier_Level.html#L133) for the subgroup of $\mathrm{SL}_2(\mathbb{Z})$ consisting of
+the elements of $\Gamma_0(M)$ whose image under the homomorphism
+$\Gamma_0(M)\to(\mathbb{Z}/M)^\times$, $\gamma\mapsto d_\gamma \bmod M$, lies in $H$. For a subgroup
+$\Gamma\le\mathrm{SL}_2(\mathbb{Z})$, [`ModularCurve.qExpFunctionFieldC K
+Γ`](def/ModularCurve_X1.html#L101) denotes the intermediate field of $K((q))=$ `LaurentSeries K`
+generated over $K$ by all quotients $\iota_K(p_f)/\iota_K(p_g)$, where $f,g$ are modular forms of
+one weight $k$ on the image of $\Gamma$ in $\mathrm{GL}_2(\mathbb{R})$, $p_f,p_g\in\mathbb{Z}[[q]]$
+satisfy `IsIntegralQExp`, i.e. their images in $\mathbb{C}[[q]]$ are the $q$-expansions of $f$ and
+$g$ at width $1$, $\iota_K$ denotes coefficientwise reduction $\mathbb{Z}[[q]]\to K((q))$, and
+$\iota_K(p_g)\neq 0$. Write $F_H$ for this field at $\Gamma=\Gamma_H(M)$. The assertion is that
+there is a monoid (hence group) homomorphism $\rho\colon\Gamma_0(M)\to (F_H\simeq_{K} F_H)$ into the
+$K$-algebra automorphisms of $F_H$ such that: $\rho(\gamma)=1$ whenever $\gamma\in\Gamma_H(M)$;
+$\rho(\gamma)=1$ whenever $\gamma=-1$; each $\rho(\gamma)$ fixes every element of $F_H$ whose
+underlying Laurent series lies in [`ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0
+M)`](def/ModularCurve_X1.html#L101); and, for every $\gamma\in\Gamma_0(M)$, every weight
+$k\in\mathbb{Z}$, all modular forms $f,g,f_1,g_1$ of weight $k$ on $\Gamma_H(M)$ with integral
+$q$-expansions $p_f,p_g,p_{f_1},p_{g_1}$, and every $c\in\mathbb{C}^\times$ with
+$f_1=c\,(f\mid_k\gamma)$ and $g_1=c\,(g\mid_k\gamma)$ as functions on the upper half-plane, and
+$\iota_K(p_g)\neq0$, $\iota_K(p_{g_1})\neq0$, one has
+$\rho(\gamma)\bigl(\iota_K(p_f)/\iota_K(p_g)\bigr)=\iota_K(p_{f_1})/\iota_K(p_{g_1})$ in $K((q))$.
+
+This is the diamond (Galois) action of $\Gamma_0(M)$, through $\Gamma_0(M)/\Gamma_H(M)\{\pm1\}$, on
+the $q$-expansion model of the function field of the modular curve $X_H(M)$, in the
+characteristic-zero case, where bounded denominators for the translates of integral $q$-expansions
+suffice to make the action well defined. It feeds the full-level computations of the degree of $F_H$
+over the $\Gamma_0(M)$-function field by Artin's theorem on fixed fields; the proof cites the
+existence of an integral translate $f_1=D\,(f\mid_k\gamma)$ with $D\in\mathbb{Z}\setminus\{0\}$ and
+the determination of a modular form by its $q$-coefficients.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_monoidHom_gamma0_algEquiv_qExpFunctionFieldC_gammaH_of_charZero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+local notation "Γ₁ℝ " M => (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ))
+local notation "Γᴴℝ " M ", " H => (CohCarrier.GammaH M H : Subgroup (GL (Fin 2) ℝ))
+
+noncomputable section
+
+open scoped MatrixGroups ModularForm
+open UpperHalfPlane
+
+namespace ModularCurve
+
+namespace DiamondActZero
+
+section Level
+
+variable (M : ℕ) [NeZero M] (H : Subgroup (ZMod M)ˣ)
+
+omit [NeZero M] in
+theorem Gamma1_le_GammaH : CongruenceSubgroup.Gamma1 M ≤ CohCarrier.GammaH M H := by
+  intro A hA
+  obtain ⟨-, h11, h10⟩ := (CongruenceSubgroup.Gamma1_mem M A).mp hA
+  have h0 : A ∈ CongruenceSubgroup.Gamma0 M := CongruenceSubgroup.Gamma0_mem.mpr h10
+  rw [CohCarrier.mem_GammaH_iff]
+  refine ⟨h0, ?_⟩
+  have : CohCarrier.gamma0Units M ⟨A, h0⟩ = 1 := by
+    ext
+    rw [CohCarrier.val_gamma0Units]
+    simpa [CongruenceSubgroup.Gamma0Map] using h11
+  rw [this]
+  exact one_mem H
+
+scoped instance GammaH_finiteIndex' : (CohCarrier.GammaH M H).FiniteIndex :=
+  Subgroup.finiteIndex_of_le (Gamma1_le_GammaH M H)
+
+omit [NeZero M] in
+theorem T_mem_GammaH : ModularGroup.T ∈ CohCarrier.GammaH M H :=
+  Gamma1_le_GammaH M H (by simp [CongruenceSubgroup.Gamma1_mem, ModularGroup.T])
+
+omit [NeZero M] in
+theorem one_mem_strictPeriods : (1 : ℝ) ∈ (Γᴴℝ M, H).strictPeriods := by
+  have h1 : (1 : ℝ) ∈ (Γ₁ℝ M).strictPeriods := by
+    rw [CongruenceSubgroup.strictPeriods_Gamma1]; exact AddSubgroup.mem_zmultiples _
+  rw [Subgroup.mem_strictPeriods_iff] at h1 ⊢
+  obtain ⟨γ, hγ, hγeq⟩ := h1
+  exact ⟨γ, Gamma1_le_GammaH M H hγ, hγeq⟩
+
+variable {M H}
+
+def liftForm {k : ℤ} (f : ModularForm (Γ₁ℝ M) k)
+    (hinv : ∀ h : SL(2, ℤ), h ∈ CohCarrier.GammaH M H → (⇑f : ℍ → ℂ) ∣[k] h = ⇑f) :
+    ModularForm (Γᴴℝ M, H) k where
+  toFun := f
+  slash_action_eq' A hA := by
+    obtain ⟨h, hh, rfl⟩ := Subgroup.mem_map.mp hA
+    exact hinv h hh
+  holo' := f.holo'
+  bdd_at_cusps' {c} hc := by
+    apply f.bdd_at_cusps'
+    rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z] at hc ⊢
+    exact hc
+
+@[scoped simp] theorem coe_liftForm {k : ℤ} (f : ModularForm (Γ₁ℝ M) k)
+    (hinv : ∀ h : SL(2, ℤ), h ∈ CohCarrier.GammaH M H → (⇑f : ℍ → ℂ) ∣[k] h = ⇑f) :
+    (⇑(liftForm f hinv) : ℍ → ℂ) = ⇑f := rfl
+
+end Level
+
+section QExp
+
+variable {M : ℕ} [NeZero M] {H : Subgroup (ZMod M)ˣ} {k : ℤ}
+
+omit [NeZero M] in
+theorem analyticAt_form (f : ModularForm (Γᴴℝ M, H) k) : AnalyticAt ℂ (cuspFunction 1 (⇑f)) 0 :=
+  ModularFormClass.analyticAt_cuspFunction_zero f one_pos (one_mem_strictPeriods M H)
+
+theorem map_intCast_injective : Function.Injective (PowerSeries.map (Int.castRingHom ℂ)) := by
+  intro p r h
+  ext n
+  have := congrArg (PowerSeries.coeff n) h
+  simp only [PowerSeries.coeff_map, eq_intCast] at this
+  exact_mod_cast this
+
+omit [NeZero M] in
+theorem isIntegralQExp_add {f g : ModularForm (Γᴴℝ M, H) k} {p r : PowerSeries ℤ}
+    (hf : IsIntegralQExp (⇑f) p) (hg : IsIntegralQExp (⇑g) r) :
+    IsIntegralQExp (⇑(f + g)) (p + r) := by
+  unfold IsIntegralQExp at hf hg ⊢
+  rw [FunLike.coe_add, qExpansion_add (analyticAt_form f) (analyticAt_form g), map_add, hf, hg]
+
+omit [NeZero M] in
+theorem isIntegralQExp_zero : IsIntegralQExp (⇑(0 : ModularForm (Γᴴℝ M, H) k)) 0 := by
+  unfold IsIntegralQExp
+  rw [FunLike.coe_zero, qExpansion_zero, map_zero]
+
+omit [NeZero M] in
+theorem qExpansion_intCast_smul (f : ModularForm (Γᴴℝ M, H) k) (n : ℤ) {p : PowerSeries ℤ}
+    (hf : IsIntegralQExp (⇑f) p) :
+    qExpansion 1 ((n : ℂ) • (⇑f : ℍ → ℂ)) = (n • p).map (Int.castRingHom ℂ) := by
+  rw [qExpansion_smul (analyticAt_form f), ← hf, map_zsmul, Int.cast_smul_eq_zsmul]
+
+omit [NeZero M] in
+theorem isIntegralQExp_intCast_smul (f : ModularForm (Γᴴℝ M, H) k) (n : ℤ) {p : PowerSeries ℤ}
+    (hf : IsIntegralQExp (⇑f) p) : IsIntegralQExp (⇑((n : ℂ) • f)) (n • p) := by
+  unfold IsIntegralQExp
+  rw [FunLike.coe_smul]
+  exact (qExpansion_intCast_smul f n hf).symm
+
+omit [NeZero M] in
+theorem smul_eq_smul_of_coe (f₁ f₂ : ModularForm (Γᴴℝ M, H) k) {p₁ p₂ : PowerSeries ℤ}
+    (h₁ : IsIntegralQExp (⇑f₁) p₁) (h₂ : IsIntegralQExp (⇑f₂) p₂) (m n : ℤ)
+    (h : (m : ℂ) • (⇑f₁ : ℍ → ℂ) = (n : ℂ) • (⇑f₂ : ℍ → ℂ)) : m • p₁ = n • p₂ := by
+  apply map_intCast_injective
+  rw [← qExpansion_intCast_smul f₁ m h₁, ← qExpansion_intCast_smul f₂ n h₂, h]
+
+theorem isIntegralQExp_mul {k₁ k₂ : ℤ} {f : ModularForm (Γᴴℝ M, H) k₁}
+    {g : ModularForm (Γᴴℝ M, H) k₂}
+    {p r : PowerSeries ℤ} (hf : IsIntegralQExp (⇑f) p) (hg : IsIntegralQExp (⇑g) r) :
+    IsIntegralQExp (⇑(f.mul g)) (p * r) := by
+  unfold IsIntegralQExp at hf hg ⊢
+  rw [ModularForm.coe_mul, qExpansion_mul (analyticAt_form f) (analyticAt_form g), map_mul, hf, hg]
+
+omit [NeZero M] in
+theorem eq_zero_of_isIntegralQExp_zero (f : ModularForm (Γᴴℝ M, H) k) (hf : IsIntegralQExp (⇑f) 0) :
+    f = 0 := by
+  apply ModularFormClass.eq_of_forall_qCoeff_eq (one_mem_strictPeriods M H)
+  intro n
+  have h0 : qExpansion 1 (⇑f : ℍ → ℂ) = 0 := by rw [← hf, map_zero]
+  change (qExpansion 1 ⇑f).coeff n = (qExpansion 1 ⇑(0 : ModularForm (Γᴴℝ M, H) k)).coeff n
+  rw [h0, FunLike.coe_zero, qExpansion_zero]
+
+end QExp
+
+section Datum
+
+variable (M : ℕ) [NeZero M] (H : Subgroup (ZMod M)ˣ)
+
+structure IDatum (w : ℤ) where
+  f : ModularForm (Γᴴℝ M, H) w
+  p : PowerSeries ℤ
+  hp : IsIntegralQExp (⇑f) p
+
+variable {M H}
+variable {w w₁ w₂ : ℤ}
+
+namespace IDatum
+
+omit [NeZero M] in
+theorem hinv (D : IDatum M H w) (h : SL(2, ℤ)) (hh : h ∈ CohCarrier.GammaH M H) :
+    (⇑D.f : ℍ → ℂ) ∣[w] h = ⇑D.f :=
+  SlashInvariantForm.slash_action_eqn D.f _ (Subgroup.mem_map_of_mem _ hh)
+
+def add (D E : IDatum M H w) : IDatum M H w :=
+  ⟨D.f + E.f, D.p + E.p, isIntegralQExp_add D.hp E.hp⟩
+
+def zsmul (n : ℤ) (D : IDatum M H w) : IDatum M H w :=
+  ⟨(n : ℂ) • D.f, n • D.p, isIntegralQExp_intCast_smul D.f n D.hp⟩
+
+def mul (D : IDatum M H w₁) (E : IDatum M H w₂) : IDatum M H (w₁ + w₂) :=
+  ⟨D.f.mul E.f, D.p * E.p, isIntegralQExp_mul D.hp E.hp⟩
+
+@[scoped simp] theorem mul_p (D : IDatum M H w₁) (E : IDatum M H w₂) :
+    (D.mul E).p = D.p * E.p := rfl
+@[scoped simp] theorem mul_f (D : IDatum M H w₁) (E : IDatum M H w₂) : ⇑(D.mul E).f = ⇑D.f * ⇑E.f :=
+  ModularForm.coe_mul _ _
+
+end IDatum
+end Datum
+end DiamondActZero
+end ModularCurve
+end
+
+noncomputable section
+
+open scoped MatrixGroups ModularForm
+open UpperHalfPlane
+
+namespace ModularCurve
+
+namespace DiamondActZero
+
+section Translate
+
+variable {M : ℕ} [NeZero M] {H : Subgroup (ZMod M)ˣ} {w : ℤ}
+
+theorem smul_SL_slash (k : ℤ) (γ : SL(2, ℤ)) (F : ℍ → ℂ) (c : ℂ) :
+    (c • F) ∣[k] γ = c • (F ∣[k] γ) := by
+  exact ModularForm.SL_smul_slash k γ F c
+
+omit [NeZero M] in
+theorem slash_invariant_of_invariant (F : ℍ → ℂ) (k : ℤ)
+    (hinv : ∀ h : SL(2, ℤ), h ∈ CohCarrier.GammaH M H → F ∣[k] h = F)
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M)
+    (h : SL(2, ℤ)) (hh : h ∈ CohCarrier.GammaH M H) :
+    (F ∣[k] γ) ∣[k] h = F ∣[k] γ := by
+  have hconj : γ * h * γ⁻¹ ∈ CohCarrier.GammaH M H :=
+    CohCarrier.conj_mem_GammaH M H ⟨γ, hγ⟩ ⟨h, hh⟩
+  have hγh : γ * h = (γ * h * γ⁻¹) * γ := by group
+  rw [← SlashAction.slash_mul, hγh, SlashAction.slash_mul, hinv _ hconj]
+
+theorem exists_trans (D : IDatum M H w) (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    ∃ (a : ℤ) (E : IDatum M H w), a ≠ 0 ∧
+      (⇑E.f : ℍ → ℂ) = (a : ℂ) • ((⇑D.f : ℍ → ℂ) ∣[w] γ) := by
+  obtain ⟨a, f₁, p₁, ha, hp₁, hf₁⟩ :=
+    exists_isIntegralQExp_smul_slash_of_mem_Gamma0 M
+      (restrictForm (Subgroup.map_mono (Gamma1_le_GammaH M H)) D.f) D.hp γ hγ
+  have hinv : ∀ h : SL(2, ℤ), h ∈ CohCarrier.GammaH M H → (⇑f₁ : ℍ → ℂ) ∣[w] h = ⇑f₁ :=
+    fun h hh => by
+    rw [hf₁, smul_SL_slash, coe_restrictForm, slash_invariant_of_invariant _ _ D.hinv γ hγ h hh]
+  exact ⟨a, ⟨liftForm f₁ hinv, p₁, hp₁⟩, ha, by rw [coe_liftForm, hf₁, coe_restrictForm]⟩
+
+def texp (D : IDatum M H w) (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) : ℤ :=
+  (exists_trans D γ hγ).choose
+
+private def trans (D : IDatum M H w) (γ : SL(2, ℤ))
+    (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    IDatum M H w :=
+  (exists_trans D γ hγ).choose_spec.choose
+
+theorem texp_ne_zero (D : IDatum M H w) (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    texp D γ hγ ≠ 0 :=
+  (exists_trans D γ hγ).choose_spec.choose_spec.1
+
+theorem trans_f (D : IDatum M H w) (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    (⇑(trans D γ hγ).f : ℍ → ℂ) = ((texp D γ hγ : ℤ) : ℂ) • ((⇑D.f : ℍ → ℂ) ∣[w] γ) :=
+  (exists_trans D γ hγ).choose_spec.choose_spec.2
+
+theorem smul_trans_p_eq (D : IDatum M H w) (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M)
+    (b : ℤ) (E : IDatum M H w) (hE : (⇑E.f : ℍ → ℂ) = (b : ℂ) • ((⇑D.f : ℍ → ℂ) ∣[w] γ)) :
+    b • (trans D γ hγ).p = (texp D γ hγ) • E.p := by
+  apply smul_eq_smul_of_coe _ _ (trans D γ hγ).hp E.hp
+  rw [trans_f, hE, smul_smul, smul_smul, mul_comm]
+
+variable (K : Type*) [Field K] [CharZero K]
+
+def redHom : PowerSeries ℤ →+* LaurentSeries K :=
+  (HahnSeries.ofPowerSeries ℤ K).comp (PowerSeries.map (Int.castRingHom K))
+
+omit [CharZero K] in
+@[scoped simp] theorem redHom_apply (p : PowerSeries ℤ) : redHom K p = intSeriesC K p := rfl
+
+omit [CharZero K] in
+theorem intSeriesC_zsmul (n : ℤ) (p : PowerSeries ℤ) :
+    intSeriesC K (n • p) = (n : K) • intSeriesC K p := by
+  rw [← redHom_apply, map_zsmul, redHom_apply, Int.cast_smul_eq_zsmul]
+
+omit [CharZero K] in
+theorem intSeriesC_add (p r : PowerSeries ℤ) :
+    intSeriesC K (p + r) = intSeriesC K p + intSeriesC K r := by
+  rw [← redHom_apply, map_add, redHom_apply, redHom_apply]
+
+theorem intSeriesC_eq_zero_iff (p : PowerSeries ℤ) :
+    intSeriesC K p = 0 ↔ ∀ n : ℕ, ((PowerSeries.coeff n p : ℤ) : K) = 0 := by
+  constructor
+  · intro h n
+    have h' : p.map (Int.castRingHom K) = 0 := by
+      apply (HahnSeries.ofPowerSeries_injective : Function.Injective (HahnSeries.ofPowerSeries ℤ K))
+      rw [map_zero]; exact h
+    have := congrArg (PowerSeries.coeff n) h'
+    simpa [PowerSeries.coeff_map] using this
+  · intro h
+    have h' : p.map (Int.castRingHom K) = 0 := by
+      ext n; simpa [PowerSeries.coeff_map] using h n
+    rw [intSeriesC, h', map_zero]
+
+variable {K}
+
+def tRed (K : Type*) [Field K] [CharZero K] (D : IDatum M H w) (γ : SL(2, ℤ))
+    (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) : LaurentSeries K :=
+  (((texp D γ hγ : ℤ) : K)⁻¹) • intSeriesC K (trans D γ hγ).p
+
+theorem tRed_eq_of (D : IDatum M H w) (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M)
+    (b : ℤ) (hb : b ≠ 0) (E : IDatum M H w)
+    (hE : (⇑E.f : ℍ → ℂ) = (b : ℂ) • ((⇑D.f : ℍ → ℂ) ∣[w] γ)) :
+    tRed K D γ hγ = ((b : K)⁻¹) • intSeriesC K E.p := by
+  have h := congrArg (intSeriesC K) (smul_trans_p_eq D γ hγ b E hE)
+  rw [intSeriesC_zsmul, intSeriesC_zsmul] at h
+  have hMa : ((texp D γ hγ : ℤ) : K) ≠ 0 := Int.cast_ne_zero.mpr (texp_ne_zero D γ hγ)
+  have hMb : ((b : ℤ) : K) ≠ 0 := Int.cast_ne_zero.mpr hb
+  rw [tRed]
+  have h2 : intSeriesC K (trans D γ hγ).p =
+      ((b : ℤ) : K)⁻¹ • (((texp D γ hγ : ℤ) : K) • intSeriesC K E.p) := by
+    rw [← h, smul_smul, inv_mul_cancel₀ hMb, one_smul]
+  rw [h2, smul_smul, smul_smul]
+  congr 1
+  field_simp
+
+theorem tRed_eq_zero_of_red_eq_zero (D : IDatum M H w) (γ : SL(2, ℤ))
+    (hγ : γ ∈ CongruenceSubgroup.Gamma0 M)
+    (h0 : intSeriesC K D.p = 0) : tRed K D γ hγ = 0 := by
+  have hp0 : D.p = 0 := by
+    ext n
+    have := ((intSeriesC_eq_zero_iff K D.p).mp h0) n
+    rw [map_zero]
+    exact_mod_cast this
+  have hf0 : D.f = 0 := eq_zero_of_isIntegralQExp_zero D.f (hp0 ▸ D.hp)
+  have ht : (trans D γ hγ).p = 0 := by
+    apply map_intCast_injective
+    rw [(trans D γ hγ).hp, trans_f, hf0, FunLike.coe_zero, SlashAction.zero_slash, smul_zero,
+      map_zero, qExpansion_zero]
+  rw [tRed, ht, intSeriesC_zero, smul_zero]
+
+end Translate
+end DiamondActZero
+end ModularCurve
+end
+
+noncomputable section
+
+open scoped MatrixGroups ModularForm
+open UpperHalfPlane
+
+namespace ModularCurve
+
+namespace DiamondActZero
+
+section Group
+
+variable {M : ℕ} [NeZero M] {H : Subgroup (ZMod M)ˣ} {w : ℤ}
+
+namespace IDatum
+
+omit [NeZero M] in
+@[scoped ext] theorem ext {D E : IDatum M H w} (hf : D.f = E.f) (hp : D.p = E.p) : D = E := by
+  cases D; cases E
+  cases hf; cases hp
+  rfl
+
+scoped instance : Zero (IDatum M H w) := ⟨⟨0, 0, isIntegralQExp_zero⟩⟩
+
+scoped instance : Add (IDatum M H w) := ⟨IDatum.add⟩
+
+scoped instance : SMul ℤ (IDatum M H w) := ⟨fun n D => IDatum.zsmul n D⟩
+
+scoped instance : SMul ℕ (IDatum M H w) := ⟨fun n D => IDatum.zsmul (n : ℤ) D⟩
+
+scoped instance : Neg (IDatum M H w) := ⟨fun D => IDatum.zsmul (-1) D⟩
+
+scoped instance : Sub (IDatum M H w) := ⟨fun D E => D + (-E)⟩
+
+section
+omit [NeZero M]
+
+@[scoped simp] theorem zero_f : (0 : IDatum M H w).f = 0 := rfl
+@[scoped simp] theorem zero_p : (0 : IDatum M H w).p = 0 := rfl
+@[scoped simp] theorem add_f' (D E : IDatum M H w) : (D + E).f = D.f + E.f := rfl
+@[scoped simp] theorem add_p' (D E : IDatum M H w) : (D + E).p = D.p + E.p := rfl
+@[scoped simp] theorem zsmul_f' (n : ℤ) (D : IDatum M H w) : (n • D).f = (n : ℂ) • D.f := rfl
+@[scoped simp] theorem zsmul_p' (n : ℤ) (D : IDatum M H w) : (n • D).p = n • D.p := rfl
+@[scoped simp] theorem nsmul_f' (n : ℕ) (D : IDatum M H w) : (n • D).f = ((n : ℤ) : ℂ) • D.f := rfl
+@[scoped simp] theorem nsmul_p' (n : ℕ) (D : IDatum M H w) : (n • D).p = (n : ℤ) • D.p := rfl
+@[scoped simp] theorem neg_f' (D : IDatum M H w) : (-D).f = ((-1 : ℤ) : ℂ) • D.f := rfl
+@[scoped simp] theorem neg_p' (D : IDatum M H w) : (-D).p = (-1 : ℤ) • D.p := rfl
+@[scoped simp] theorem sub_f' (D E : IDatum M H w) : (D - E).f = D.f + ((-1 : ℤ) : ℂ) • E.f := rfl
+@[scoped simp] theorem sub_p' (D E : IDatum M H w) : (D - E).p = D.p + (-1 : ℤ) • E.p := rfl
+
+end
+
+def toProd (D : IDatum M H w) : ModularForm (Γᴴℝ M, H) w × PowerSeries ℤ := (D.f, D.p)
+
+omit [NeZero M] in
+theorem toProd_injective : Function.Injective (toProd (M := M) (H := H) (w := w)) := by
+  intro D E h
+  simp only [toProd, Prod.mk.injEq] at h
+  exact ext h.1 h.2
+
+scoped instance : AddCommGroup (IDatum M H w) :=
+  toProd_injective.addCommGroup toProd rfl (fun _ _ => rfl)
+    (fun D => by
+      simp only [toProd, Prod.neg_mk, Prod.mk.injEq, neg_f', neg_p', neg_one_zsmul, and_true]
+      ext τ; simp)
+    (fun D E => by
+      change (D.f + ((-1 : ℤ) : ℂ) • E.f, D.p + (-1 : ℤ) • E.p) = (D.f, D.p) - (E.f, E.p)
+      rw [Prod.mk_sub_mk]
+      congr 1
+      · ext τ; simp [sub_eq_add_neg]
+      · rw [neg_one_zsmul, sub_eq_add_neg])
+    (fun D n => by
+      simp only [toProd, Prod.smul_mk, Prod.mk.injEq, nsmul_f', nsmul_p', natCast_zsmul, and_true]
+      ext τ; simp)
+    (fun D n => by
+      simp only [toProd, Prod.smul_mk, Prod.mk.injEq, zsmul_f', zsmul_p', and_true]
+      ext τ; simp)
+
+end IDatum
+
+open ModularCurve.DiamondActZero.IDatum ModularCurve.DiamondActZero ModularCurve
+
+variable (K : Type*) [Field K] [CharZero K]
+
+def redD : IDatum M H w →+ LaurentSeries K where
+  toFun D := intSeriesC K D.p
+  map_zero' := by simp
+  map_add' D E := by simp [intSeriesC_add]
+
+omit [NeZero M] [CharZero K] in
+@[scoped simp] theorem redD_apply (D : IDatum M H w) : redD K D = intSeriesC K D.p := rfl
+
+variable {K}
+
+theorem tRed_zero (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    tRed K (0 : IDatum M H w) γ hγ = 0 := by
+  rw [tRed_eq_of 0 γ hγ 1 one_ne_zero 0 (by simp)]
+  simp
+
+theorem tRed_add (D E : IDatum M H w) (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    tRed K (D + E) γ hγ = tRed K D γ hγ + tRed K E γ hγ := by
+  let T : IDatum M H w := (texp E γ hγ) • trans D γ hγ + (texp D γ hγ) • trans E γ hγ
+  have hT : (⇑T.f : ℍ → ℂ) =
+      ((texp D γ hγ * texp E γ hγ : ℤ) : ℂ) • ((⇑(D + E).f : ℍ → ℂ) ∣[w] γ) := by
+    simp only [T, IDatum.add_f', IDatum.zsmul_f', FunLike.coe_add, FunLike.coe_smul,
+      trans_f, SlashAction.add_slash, smul_add, smul_smul]
+    push_cast
+    rw [mul_comm ((texp E γ hγ : ℤ) : ℂ)]
+  rw [tRed_eq_of (D + E) γ hγ _ (mul_ne_zero (texp_ne_zero D γ hγ) (texp_ne_zero E γ hγ)) T hT]
+  simp only [T, IDatum.add_p', IDatum.zsmul_p', intSeriesC_add, intSeriesC_zsmul, tRed, smul_add,
+    smul_smul]
+  push_cast
+  have hMa : ((texp D γ hγ : ℤ) : K) ≠ 0 := Int.cast_ne_zero.mpr (texp_ne_zero D γ hγ)
+  have hMb : ((texp E γ hγ : ℤ) : K) ≠ 0 := Int.cast_ne_zero.mpr (texp_ne_zero E γ hγ)
+  congr 1
+  · congr 1; field_simp
+  · congr 1; field_simp
+
+variable (K) in
+def tRedHom (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    IDatum M H w →+ LaurentSeries K where
+  toFun D := tRed K D γ hγ
+  map_zero' := tRed_zero γ hγ
+  map_add' D E := tRed_add D E γ hγ
+
+@[scoped simp] theorem tRedHom_apply (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M)
+    (D : IDatum M H w) :
+    tRedHom (K := K) γ hγ D = tRed K D γ hγ := rfl
+
+end Group
+end DiamondActZero
+end ModularCurve
+end
+open ModularCurve.DiamondActZero.IDatum ModularCurve.DiamondActZero ModularCurve
+
+noncomputable section
+
+open scoped MatrixGroups ModularForm
+open UpperHalfPlane
+
+namespace ModularCurve
+
+namespace DiamondActZero
+
+section Descent
+
+variable {M : ℕ} [NeZero M] {H : Subgroup (ZMod M)ˣ} {w : ℤ} {K : Type*} [Field K] [CharZero K]
+
+omit [CharZero K] in
+theorem exists_intCast_eq_coeff_intSeriesC (p : PowerSeries ℤ) (n : ℤ) :
+    ∃ z : ℤ, (intSeriesC K p).coeff n = (z : K) := by
+  rcases Int.eq_nat_or_neg n with ⟨m, rfl | rfl⟩
+  · exact ⟨PowerSeries.coeff m p, by
+      rw [intSeriesC, HahnSeries.ofPowerSeries_apply_coeff, PowerSeries.coeff_map, eq_intCast]⟩
+  · rcases Nat.eq_zero_or_pos m with rfl | hm
+    · exact ⟨PowerSeries.coeff 0 p, by
+        rw [Nat.cast_zero, neg_zero, show (0 : ℤ) = ((0 : ℕ) : ℤ) from rfl, intSeriesC,
+          HahnSeries.ofPowerSeries_apply_coeff, PowerSeries.coeff_map, eq_intCast]⟩
+    · refine ⟨0, ?_⟩
+      rw [Int.cast_zero, intSeriesC, HahnSeries.ofPowerSeries_apply,
+        HahnSeries.embDomain_of_notMem_range]
+      rintro ⟨a, ha⟩
+      simp only [Nat.castOrderEmbedding_apply] at ha
+      omega
+
+theorem sum_intCast_smul_tRed_eq_zero (s : Finset (IDatum M H w)) (m : IDatum M H w → ℤ)
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M)
+    (h : ∑ D ∈ s, (m D : K) • intSeriesC K D.p = 0) :
+    ∑ D ∈ s, (m D : K) • tRed K D γ hγ = 0 := by
+  let P : IDatum M H w := ∑ D ∈ s, m D • D
+  have hP : intSeriesC K P.p = 0 := by
+    have : redD K P = ∑ D ∈ s, redD K (m D • D) := map_sum (redD K) _ s
+    rw [redD_apply] at this
+    rw [this, ← h]
+    refine Finset.sum_congr rfl fun D _ => ?_
+    rw [redD_apply, IDatum.zsmul_p', intSeriesC_zsmul]
+  have hT := tRed_eq_zero_of_red_eq_zero P γ hγ hP
+  rw [← tRedHom_apply (K := K), map_sum] at hT
+  rw [← hT]
+  refine Finset.sum_congr rfl fun D _ => ?_
+  rw [map_zsmul, tRedHom_apply, Int.cast_smul_eq_zsmul]
+
+theorem exists_intCast_div_of_mem_bot {x : K} (hx : x ∈ (⊥ : Subfield K)) :
+    ∃ y z : ℤ, (z : K) ≠ 0 ∧ x = (y : K) / (z : K) := by
+  have hx' : x ∈ Subfield.closure (∅ : Set K) := by rwa [Subfield.closure_empty]
+  rw [Subfield.mem_closure_iff] at hx'
+  obtain ⟨y, hy, z, hz, rfl⟩ := hx'
+  rw [Subring.closure_empty, Subring.mem_bot] at hy hz
+  obtain ⟨a, rfl⟩ := hy
+  obtain ⟨b, rfl⟩ := hz
+  by_cases hb : ((b : ℤ) : K) = 0
+  · exact ⟨0, 1, by simp, by simp [hb]⟩
+  · exact ⟨a, b, hb, rfl⟩
+
+theorem sum_coe_smul_tRed_eq_zero (s : Finset (IDatum M H w)) (e : IDatum M H w → (⊥ : Subfield K))
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M)
+    (h : ∑ D ∈ s, ((e D : K)) • intSeriesC K D.p = 0) :
+    ∑ D ∈ s, ((e D : K)) • tRed K D γ hγ = 0 := by
+  classical
+  choose y z hz hyz using fun D : IDatum M H w => exists_intCast_div_of_mem_bot (e D).2
+  let Z : K := ∏ D ∈ s, (z D : K)
+  have hZ : Z ≠ 0 := Finset.prod_ne_zero_iff.mpr fun D _ => hz D
+  let m : IDatum M H w → ℤ := fun D => y D * ∏ D' ∈ s.erase D, z D'
+  have hm : ∀ D ∈ s, (m D : K) = Z * (e D : K) := by
+    intro D hD
+    simp only [m, Z, Int.cast_mul, Int.cast_prod]
+    rw [show ((e D : K)) = (y D : K) / (z D : K) from hyz D,
+      ← Finset.mul_prod_erase s (fun D' => (z D' : K)) hD]
+    field_simp [hz D]
+  have hrel : ∑ D ∈ s, (m D : K) • intSeriesC K D.p = 0 := by
+    rw [Finset.sum_congr rfl fun D hD => by rw [hm D hD, mul_smul], ← Finset.smul_sum, h, smul_zero]
+  have := sum_intCast_smul_tRed_eq_zero s m γ hγ hrel
+  rw [Finset.sum_congr rfl fun D hD => by rw [hm D hD,
+    mul_smul], ← Finset.smul_sum, smul_eq_zero] at this
+  exact this.resolve_left hZ
+
+omit [NeZero M] in
+omit [CharZero K] in
+theorem coeff_finset_sum {ι : Type*} (s : Finset ι) (f : ι → LaurentSeries K) (n : ℤ) :
+    (∑ i ∈ s, f i).coeff n = ∑ i ∈ s, (f i).coeff n := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => simp
+  | insert a s ha ih => simp [Finset.sum_insert ha, ih]
+
+omit [CharZero K] in
+theorem bot_smul_eq_mul (r : (⊥ : Subfield K)) (x : K) : r • x = (r : K) * x := rfl
+
+theorem sum_smul_tRed_eq_zero (s : Finset (IDatum M H w)) (c : IDatum M H w → K)
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M)
+    (h : ∑ D ∈ s, c D • intSeriesC K D.p = 0) :
+    ∑ D ∈ s, c D • tRed K D γ hγ = 0 := by
+  classical
+  let F : Subfield K := ⊥
+  let b := Module.Basis.ofVectorSpace F K
+  have hA : ∀ i, ∑ D ∈ s, ((b.repr (c D) i : F) : K) • intSeriesC K D.p = 0 := by
+    intro i
+    ext n
+    rw [coeff_finset_sum]
+    simp only [HahnSeries.coeff_smul, smul_eq_mul, HahnSeries.coeff_zero]
+    have hn : ∑ D ∈ s, c D * (intSeriesC K D.p).coeff n = 0 := by
+      have := congrArg (fun x : LaurentSeries K => x.coeff n) h
+      simpa only [coeff_finset_sum, HahnSeries.coeff_smul, smul_eq_mul,
+        HahnSeries.coeff_zero] using this
+    have hr : ∀ D : IDatum M H w, ∃ r : F, (r : K) = (intSeriesC K D.p).coeff n := fun D => by
+      obtain ⟨zz, hzz⟩ := exists_intCast_eq_coeff_intSeriesC (K := K) D.p n
+      exact ⟨⟨(zz : K), by simp [F]⟩, hzz.symm⟩
+    choose r hr using hr
+    have h1 : ∑ D ∈ s, r D • c D = 0 := by
+      rw [← hn]
+      refine Finset.sum_congr rfl fun D _ => ?_
+      rw [bot_smul_eq_mul, hr, mul_comm]
+    have h2 : ∑ D ∈ s, r D * b.repr (c D) i = 0 := by
+      have := congrArg (fun x => b.repr x i) h1
+      simpa only [map_sum, map_smul, Finsupp.coe_finsetSum, Finset.sum_apply, Finsupp.coe_smul,
+        Pi.smul_apply, smul_eq_mul, map_zero, Finsupp.coe_zero, Pi.zero_apply] using this
+    have h3 := congrArg (F.subtype) h2
+    rw [map_sum, map_zero] at h3
+    rw [← h3]
+    refine Finset.sum_congr rfl fun D _ => ?_
+    simp only [map_mul, Subfield.coe_subtype, hr]
+    rw [mul_comm]
+  have hB : ∀ i, ∑ D ∈ s, ((b.repr (c D) i : F) : K) • tRed K D γ hγ = 0 :=
+    fun i => sum_coe_smul_tRed_eq_zero s (fun D => b.repr (c D) i) γ hγ (hA i)
+  let S := s.biUnion fun D => (b.repr (c D)).support
+  have hc : ∀ D ∈ s, c D = ∑ i ∈ S, ((b.repr (c D) i : F) : K) * (b i : K) := by
+    intro D hD
+    conv_lhs => rw [← b.linearCombination_repr (c D)]
+    rw [Finsupp.linearCombination_apply, Finsupp.sum_of_support_subset _
+      (Finset.subset_biUnion_of_mem (fun D => (b.repr (c D)).support) hD) _ (by simp)]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [bot_smul_eq_mul]
+  calc ∑ D ∈ s, c D • tRed K D γ hγ
+      = ∑ D ∈ s, ∑ i ∈ S, (b i : K) • (((b.repr (c D) i : F) : K) • tRed K D γ hγ) := by
+        refine Finset.sum_congr rfl fun D hD => ?_
+        nth_rewrite 1 [hc D hD]
+        rw [Finset.sum_smul]
+        refine Finset.sum_congr rfl fun i _ => ?_
+        rw [mul_comm, mul_smul]
+    _ = ∑ i ∈ S, (b i : K) • ∑ D ∈ s, ((b.repr (c D) i : F) : K) • tRed K D γ hγ := by
+        rw [Finset.sum_comm]
+        refine Finset.sum_congr rfl fun i _ => ?_
+        rw [Finset.smul_sum]
+    _ = 0 := by simp [hB]
+
+end Descent
+end DiamondActZero
+end ModularCurve
+end
+
+noncomputable section
+
+open scoped MatrixGroups ModularForm
+open UpperHalfPlane
+
+namespace ModularCurve
+
+namespace DiamondActZero
+
+section Formal
+
+variable {M : ℕ} [NeZero M] {H : Subgroup (ZMod M)ˣ} {w w₁ w₂ : ℤ} {K : Type*} [Field K]
+    [CharZero K]
+
+def ev (K : Type*) [Field K] [CharZero K] (w : ℤ) : (IDatum M H w →₀ K) →ₗ[K] LaurentSeries K :=
+  Finsupp.linearCombination K (fun D : IDatum M H w => intSeriesC K D.p)
+
+def evT (K : Type*) [Field K] [CharZero K] (w : ℤ) (γ : SL(2, ℤ))
+    (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    (IDatum M H w →₀ K) →ₗ[K] LaurentSeries K :=
+  Finsupp.linearCombination K (fun D : IDatum M H w => tRed K D γ hγ)
+
+omit [NeZero M] in
+omit [CharZero K] in
+theorem smul_mul_smul' (a b : K) (x y : LaurentSeries K) :
+    (a • x) * (b • y) = (a * b) • (x * y) := by
+  rw [← HahnSeries.C_mul_eq_smul, ← HahnSeries.C_mul_eq_smul, ← HahnSeries.C_mul_eq_smul,
+    map_mul]; ring
+
+omit [NeZero M] in
+@[scoped simp] theorem ev_single (D : IDatum M H w) (c : K) :
+    ev K w (Finsupp.single D c) = c • intSeriesC K D.p := by
+  simp [ev]
+
+@[scoped simp] theorem evT_single (D : IDatum M H w) (c : K) (γ : SL(2, ℤ))
+    (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    evT K w γ hγ (Finsupp.single D c) = c • tRed K D γ hγ := by
+  simp [evT]
+
+omit [NeZero M] in
+theorem ev_apply (l : IDatum M H w →₀ K) : ev K w l = ∑ D ∈ l.support, l D • intSeriesC K D.p := by
+  rw [ev, Finsupp.linearCombination_apply, Finsupp.sum]
+
+theorem evT_apply (l : IDatum M H w →₀ K) (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    evT K w γ hγ l = ∑ D ∈ l.support, l D • tRed K D γ hγ := by
+  rw [evT, Finsupp.linearCombination_apply, Finsupp.sum]
+
+theorem evT_eq_zero_of_ev_eq_zero (l : IDatum M H w →₀ K) (γ : SL(2, ℤ))
+    (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) (h : ev K w l = 0) : evT K w γ hγ l = 0 := by
+  rw [ev_apply] at h
+  rw [evT_apply]
+  exact sum_smul_tRed_eq_zero l.support l γ hγ h
+
+theorem evT_eq_of_ev_eq {l l' : IDatum M H w →₀ K} (γ : SL(2, ℤ))
+    (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) (h : ev K w l = ev K w l')
+    : evT K w γ hγ l = evT K w γ hγ l' := by
+  rw [← sub_eq_zero, ← map_sub] at h ⊢
+  exact evT_eq_zero_of_ev_eq_zero _ γ hγ h
+
+def fmul (l : IDatum M H w₁ →₀ K) (l' : IDatum M H w₂ →₀ K) : IDatum M H (w₁ + w₂) →₀ K :=
+  l.sum fun D a => l'.sum fun E b => Finsupp.single (D.mul E) (a * b)
+
+theorem ev_fmul (l : IDatum M H w₁ →₀ K) (l' : IDatum M H w₂ →₀ K) :
+    ev K (w₁ + w₂) (fmul l l') = ev K w₁ l * ev K w₂ l' := by
+  classical
+  rw [fmul, map_finsuppSum, ev_apply l, ev_apply l', Finset.sum_mul_sum, Finsupp.sum]
+  refine Finset.sum_congr rfl fun D _ => ?_
+  rw [map_finsuppSum, Finsupp.sum]
+  refine Finset.sum_congr rfl fun E _ => ?_
+  rw [ev_single, IDatum.mul_p, intSeriesC_mul, smul_mul_smul']
+
+theorem tRed_mul (D : IDatum M H w₁) (E : IDatum M H w₂) (γ : SL(2, ℤ))
+    (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    tRed K (D.mul E) γ hγ = tRed K D γ hγ * tRed K E γ hγ := by
+  have hT : (⇑((trans D γ hγ).mul (trans E γ hγ)).f : ℍ → ℂ) =
+      ((texp D γ hγ * texp E γ hγ : ℤ) : ℂ) • ((⇑(D.mul E).f : ℍ → ℂ) ∣[w₁ + w₂] γ) := by
+    rw [IDatum.mul_f, trans_f, trans_f, IDatum.mul_f, ModularForm.mul_slash_SL2]
+    push_cast
+    funext τ
+    simp only [Pi.mul_apply, Pi.smul_apply, smul_eq_mul]
+    ring
+  rw [tRed_eq_of (D.mul E) γ hγ _ (mul_ne_zero (texp_ne_zero D γ hγ) (texp_ne_zero E γ hγ)) _ hT,
+    IDatum.mul_p, intSeriesC_mul, tRed, tRed, smul_mul_smul']
+  push_cast
+  rw [mul_inv]
+
+theorem evT_fmul (l : IDatum M H w₁ →₀ K) (l' : IDatum M H w₂ →₀ K) (γ : SL(2, ℤ))
+    (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    evT K (w₁ + w₂) γ hγ (fmul l l') = evT K w₁ γ hγ l * evT K w₂ γ hγ l' := by
+  classical
+  rw [fmul, map_finsuppSum, evT_apply l, evT_apply l', Finset.sum_mul_sum, Finsupp.sum]
+  refine Finset.sum_congr rfl fun D _ => ?_
+  rw [map_finsuppSum, Finsupp.sum]
+  refine Finset.sum_congr rfl fun E _ => ?_
+  rw [evT_single, tRed_mul, smul_mul_smul']
+
+def ftrans (l : IDatum M H w →₀ K) (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    IDatum M H w →₀ K :=
+  l.sum fun D a => Finsupp.single (trans D γ hγ) (a * ((texp D γ hγ : ℤ) : K)⁻¹)
+
+theorem ev_ftrans (l : IDatum M H w →₀ K) (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    ev K w (ftrans l γ hγ) = evT K w γ hγ l := by
+  classical
+  rw [ftrans, map_finsuppSum, evT_apply, Finsupp.sum]
+  refine Finset.sum_congr rfl fun D _ => ?_
+  rw [ev_single, tRed, smul_smul]
+
+theorem tRed_mul_right (D : IDatum M H w) (γ δ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M)
+    (hδ : δ ∈ CongruenceSubgroup.Gamma0 M) :
+    tRed K D (γ * δ) (mul_mem hγ hδ) = ((texp D γ hγ : ℤ) : K)⁻¹ • tRed K (trans D γ hγ) δ hδ := by
+  have hT : (⇑(trans (trans D γ hγ) δ hδ).f : ℍ → ℂ) =
+      ((texp (trans D γ hγ) δ hδ * texp D γ hγ : ℤ) : ℂ) • ((⇑D.f : ℍ → ℂ) ∣[w] (γ * δ)) := by
+    rw [trans_f, trans_f, smul_SL_slash, smul_smul, SlashAction.slash_mul]
+    push_cast
+    rfl
+  rw [tRed_eq_of D (γ * δ) (mul_mem hγ hδ) _
+    (mul_ne_zero (texp_ne_zero (trans D γ hγ) δ hδ) (texp_ne_zero D γ hγ)) _ hT, tRed, smul_smul]
+  push_cast
+  rw [mul_inv, mul_comm]
+
+theorem evT_mul_right (l : IDatum M H w →₀ K) (γ δ : SL(2, ℤ))
+    (hγ : γ ∈ CongruenceSubgroup.Gamma0 M)
+    (hδ : δ ∈ CongruenceSubgroup.Gamma0 M) :
+    evT K w (γ * δ) (mul_mem hγ hδ) l = evT K w δ hδ (ftrans l γ hγ) := by
+  classical
+  rw [ftrans, map_finsuppSum, evT_apply, Finsupp.sum]
+  refine Finset.sum_congr rfl fun D _ => ?_
+  rw [evT_single, tRed_mul_right, smul_smul]
+
+theorem tRed_of_mem_GammaH (D : IDatum M H w) (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M)
+    (hγH : γ ∈ CohCarrier.GammaH M H) : tRed K D γ hγ = intSeriesC K D.p := by
+  rw [tRed_eq_of D γ hγ 1 one_ne_zero D (by rw [Int.cast_one, one_smul, D.hinv γ hγH])]
+  simp
+
+theorem evT_of_mem_GammaH (l : IDatum M H w →₀ K) (γ : SL(2, ℤ))
+    (hγ : γ ∈ CongruenceSubgroup.Gamma0 M)
+    (hγH : γ ∈ CohCarrier.GammaH M H) : evT K w γ hγ l = ev K w l := by
+  rw [evT_apply, ev_apply]
+  exact Finset.sum_congr rfl fun D _ => by rw [tRed_of_mem_GammaH D γ hγ hγH]
+
+theorem evT_ne_zero (l : IDatum M H w →₀ K) (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M)
+    (h : ev K w l ≠ 0) : evT K w γ hγ l ≠ 0 := by
+  intro h0
+  apply h
+  have h1 : ev K w (ftrans l γ hγ) = 0 := by rw [ev_ftrans]; exact h0
+  have h2 := evT_eq_zero_of_ev_eq_zero _ γ⁻¹ (inv_mem hγ) h1
+  rw [← evT_mul_right l γ γ⁻¹ hγ (inv_mem hγ)] at h2
+  have h3 : evT K w (γ * γ⁻¹) (mul_mem hγ (inv_mem hγ)) l = ev K w l :=
+    evT_of_mem_GammaH l _ _ (by rw [mul_inv_cancel]; exact one_mem _)
+  rw [← h3, h2]
+
+end Formal
+end DiamondActZero
+end ModularCurve
+end
+
+noncomputable section
+
+open scoped MatrixGroups ModularForm
+open UpperHalfPlane
+
+namespace ModularCurve
+
+namespace DiamondActZero
+
+section Field
+
+variable {M : ℕ} [NeZero M] {H : Subgroup (ZMod M)ˣ} {w w₁ w₂ : ℤ} {K : Type*} [Field K]
+    [CharZero K]
+
+def oneD : IDatum M H 0 :=
+  ⟨1, 1, by
+    show IsIntegralQExp (⇑(1 : ModularForm (Γᴴℝ M, H) 0)) 1
+    rw [ModularForm.one_coe_eq_one]; exact isIntegralQExp_one⟩
+
+@[scoped simp] theorem oneD_p : (oneD : IDatum M H 0).p = 1 := rfl
+@[scoped simp] theorem oneD_f : (⇑(oneD : IDatum M H 0).f : ℍ → ℂ) = 1 := ModularForm.one_coe_eq_one
+
+omit [NeZero M] in
+omit [CharZero K] in
+theorem C_eq_algebraMap' (c : K) : HahnSeries.C c = algebraMap K (LaurentSeries K) c := by
+  exact (HahnSeries.ofPowerSeries_C (Γ := ℤ) (R := K) c).symm
+
+@[scoped simp] theorem ev_single_oneD (c : K) :
+    ev K 0 (Finsupp.single (oneD : IDatum M H 0) c) = algebraMap K _ c := by
+  rw [ev_single, oneD_p, intSeriesC_one, ← HahnSeries.C_mul_eq_smul, mul_one, C_eq_algebraMap']
+
+theorem tRed_oneD (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    tRed K (oneD : IDatum M H 0) γ hγ = 1 := by
+  rw [tRed_eq_of oneD γ hγ 1 one_ne_zero oneD (by rw [Int.cast_one, one_smul, oneD_f,
+    ModularForm.is_invariant_one])]
+  simp [intSeriesC_one]
+
+@[scoped simp] theorem evT_single_oneD (c : K) (γ : SL(2, ℤ))
+    (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    evT K 0 γ hγ (Finsupp.single (oneD : IDatum M H 0) c) = algebraMap K _ c := by
+  rw [evT_single, tRed_oneD, ← HahnSeries.C_mul_eq_smul, mul_one, C_eq_algebraMap']
+
+variable (K) in
+def IsRep (x : LaurentSeries K) (w : ℤ) (l l' : IDatum M H w →₀ K) : Prop :=
+  ev K w l' ≠ 0 ∧ x = ev K w l / ev K w l'
+
+def Efield (K : Type*) [Field K] [CharZero K] (M : ℕ) [NeZero M] (H : Subgroup (ZMod M)ˣ) :
+    IntermediateField K (LaurentSeries K) where
+  carrier := {x | ∃ (w : ℤ) (l l' : IDatum M H w →₀ K), IsRep K x w l l'}
+  mul_mem' := by
+    rintro x y ⟨w, l, l', hl', rfl⟩ ⟨u, m, m', hm', rfl⟩
+    exact ⟨w + u, fmul l m, fmul l' m', by rw [ev_fmul]; exact mul_ne_zero hl' hm',
+      by rw [ev_fmul, ev_fmul, div_mul_div_comm]⟩
+  one_mem' := ⟨0, Finsupp.single oneD 1, Finsupp.single oneD 1, by simp, by simp⟩
+  add_mem' := by
+    rintro x y ⟨w, l, l', hl', rfl⟩ ⟨u, m, m', hm', rfl⟩
+    refine ⟨w + u, fmul l m' + fmul l' m, fmul l' m',
+      by rw [ev_fmul]; exact mul_ne_zero hl' hm', ?_⟩
+    rw [map_add, ev_fmul, ev_fmul, ev_fmul, div_add_div _ _ hl' hm']
+  zero_mem' := ⟨0, 0, Finsupp.single oneD 1, by simp, by simp⟩
+  algebraMap_mem' c := ⟨0, Finsupp.single oneD c, Finsupp.single oneD 1, by simp,
+    by rw [ev_single_oneD, ev_single_oneD, map_one, div_one]⟩
+  inv_mem' := by
+    rintro x ⟨w, l, l', hl', rfl⟩
+    by_cases hl : ev K w l = 0
+    · refine ⟨0, 0, Finsupp.single oneD 1, by simp, ?_⟩
+      simp [hl]
+    · exact ⟨w, l', l, hl, by rw [inv_div]⟩
+
+theorem mem_Efield_iff {x : LaurentSeries K} :
+    x ∈ Efield K M H ↔ ∃ (w : ℤ) (l l' : IDatum M H w →₀ K), IsRep K x w l l' := Iff.rfl
+
+omit [NeZero M] in
+theorem exists_mem_support_ne_zero {l : IDatum M H w →₀ K} (h : ev K w l ≠ 0) :
+    ∃ G ∈ l.support, intSeriesC K G.p ≠ 0 := by
+  by_contra! hcon
+  apply h
+  rw [ev_apply]
+  exact Finset.sum_eq_zero fun D hD => by rw [hcon D hD, smul_zero]
+
+omit [NeZero M] in
+theorem ev_div_mem {l : IDatum M H w →₀ K} (G : IDatum M H w) (hG : intSeriesC K G.p ≠ 0) :
+    ev K w l / intSeriesC K G.p ∈ qExpFunctionFieldC K (CohCarrier.GammaH M H) := by
+  rw [ev_apply, Finset.sum_div]
+  refine sum_mem fun D _ => ?_
+  rw [← HahnSeries.C_mul_eq_smul, mul_div_assoc]
+  refine mul_mem ?_ (div_mem_qExpFunctionFieldC D.f G.f D.hp G.hp hG)
+  rw [C_eq_algebraMap']
+  exact IntermediateField.algebraMap_mem _ _
+
+theorem Efield_eq : Efield K M H = qExpFunctionFieldC K (CohCarrier.GammaH M H) := by
+  apply le_antisymm
+  · rintro x ⟨w, l, l', hl', rfl⟩
+    obtain ⟨G, -, hG⟩ := exists_mem_support_ne_zero hl'
+    rw [← div_div_div_cancel_right₀ hG (ev K w l) (ev K w l')]
+    exact div_mem (ev_div_mem G hG) (ev_div_mem G hG)
+  · rw [qExpFunctionFieldC, IntermediateField.adjoin_le_iff]
+    rintro x ⟨k, f, g, pf, pg, hf, hg, hg0, rfl⟩
+    exact ⟨k, Finsupp.single ⟨f, pf, hf⟩ 1, Finsupp.single ⟨g, pg, hg⟩ 1,
+      by simpa using hg0, by simp⟩
+
+theorem exists_rep {x : LaurentSeries K} (hx : x ∈ qExpFunctionFieldC K (CohCarrier.GammaH M H)) :
+    ∃ (w : ℤ) (l l' : IDatum M H w →₀ K), IsRep K x w l l' := by
+  rwa [← Efield_eq] at hx
+
+def rhoVal (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) (x : LaurentSeries K)
+    (hx : x ∈ qExpFunctionFieldC K (CohCarrier.GammaH M H)) : LaurentSeries K :=
+  evT K _ γ hγ (exists_rep hx).choose_spec.choose / evT K _ γ hγ
+    (exists_rep hx).choose_spec.choose_spec.choose
+
+theorem evT_div_eq_of_isRep {x : LaurentSeries K} {w u : ℤ} {l l' : IDatum M H w →₀ K}
+    {m m' : IDatum M H u →₀ K} (h1 : IsRep K x w l l') (h2 : IsRep K x u m m')
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    evT K w γ hγ l / evT K w γ hγ l' = evT K u γ hγ m / evT K u γ hγ m' := by
+  obtain ⟨hl', hx1⟩ := h1
+  obtain ⟨hm', hx2⟩ := h2
+  have hcross : ev K (w + u) (fmul l m') = ev K (w + u) (fmul l' m) := by
+    rw [ev_fmul, ev_fmul]
+    rw [hx1, div_eq_div_iff hl' hm'] at hx2
+    rw [hx2, mul_comm]
+  have hT := evT_eq_of_ev_eq γ hγ hcross
+  rw [evT_fmul, evT_fmul] at hT
+  rw [div_eq_div_iff (evT_ne_zero l' γ hγ hl') (evT_ne_zero m' γ hγ hm'), hT, mul_comm]
+
+theorem rhoVal_eq {x : LaurentSeries K} (hx : x ∈ qExpFunctionFieldC K (CohCarrier.GammaH M H))
+    {u : ℤ} {m m' : IDatum M H u →₀ K} (h : IsRep K x u m m')
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    rhoVal γ hγ x hx = evT K u γ hγ m / evT K u γ hγ m' :=
+  evT_div_eq_of_isRep (exists_rep hx).choose_spec.choose_spec.choose_spec h γ hγ
+
+theorem isRep_rhoVal {x : LaurentSeries K} (hx : x ∈ qExpFunctionFieldC K (CohCarrier.GammaH M H))
+    {u : ℤ} {m m' : IDatum M H u →₀ K} (h : IsRep K x u m m')
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    IsRep K (rhoVal γ hγ x hx) u (ftrans m γ hγ) (ftrans m' γ hγ) := by
+  refine ⟨by rw [ev_ftrans]; exact evT_ne_zero m' γ hγ h.1, ?_⟩
+  rw [ev_ftrans, ev_ftrans, rhoVal_eq hx h γ hγ]
+
+theorem rhoVal_mem {x : LaurentSeries K} (hx : x ∈ qExpFunctionFieldC K (CohCarrier.GammaH M H))
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    rhoVal γ hγ x hx ∈ qExpFunctionFieldC K (CohCarrier.GammaH M H) := by
+  obtain ⟨u, m, m', h⟩ := exists_rep hx
+  rw [← Efield_eq]
+  exact ⟨u, _, _, isRep_rhoVal hx h γ hγ⟩
+
+theorem rhoVal_add {x y : LaurentSeries K} (hx : x ∈ qExpFunctionFieldC K (CohCarrier.GammaH M H))
+    (hy : y ∈ qExpFunctionFieldC K (CohCarrier.GammaH M H))
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    rhoVal γ hγ (x + y) (add_mem hx hy) = rhoVal γ hγ x hx + rhoVal γ hγ y hy := by
+  obtain ⟨w, l, l', hl⟩ := exists_rep hx
+  obtain ⟨u, m, m', hm⟩ := exists_rep hy
+  have hsum : IsRep K (x + y) (w + u) (fmul l m' + fmul l' m) (fmul l' m') := by
+    refine ⟨by rw [ev_fmul]; exact mul_ne_zero hl.1 hm.1, ?_⟩
+    rw [hl.2, hm.2, map_add, ev_fmul, ev_fmul, ev_fmul, div_add_div _ _ hl.1 hm.1]
+  rw [rhoVal_eq _ hsum γ hγ, rhoVal_eq hx hl γ hγ, rhoVal_eq hy hm γ hγ, map_add,
+    evT_fmul, evT_fmul, evT_fmul,
+    div_add_div _ _ (evT_ne_zero l' γ hγ hl.1) (evT_ne_zero m' γ hγ hm.1)]
+
+theorem rhoVal_mul {x y : LaurentSeries K} (hx : x ∈ qExpFunctionFieldC K (CohCarrier.GammaH M H))
+    (hy : y ∈ qExpFunctionFieldC K (CohCarrier.GammaH M H))
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    rhoVal γ hγ (x * y) (mul_mem hx hy) = rhoVal γ hγ x hx * rhoVal γ hγ y hy := by
+  obtain ⟨w, l, l', hl⟩ := exists_rep hx
+  obtain ⟨u, m, m', hm⟩ := exists_rep hy
+  have hprod : IsRep K (x * y) (w + u) (fmul l m) (fmul l' m') := by
+    refine ⟨by rw [ev_fmul]; exact mul_ne_zero hl.1 hm.1, ?_⟩
+    rw [hl.2, hm.2, ev_fmul, ev_fmul, div_mul_div_comm]
+  rw [rhoVal_eq _ hprod γ hγ, rhoVal_eq hx hl γ hγ, rhoVal_eq hy hm γ hγ,
+    evT_fmul, evT_fmul, div_mul_div_comm]
+
+theorem rhoVal_algebraMap (c : K) (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    rhoVal γ hγ (algebraMap K (LaurentSeries K) c)
+      (IntermediateField.algebraMap_mem (qExpFunctionFieldC K (CohCarrier.GammaH M H)) c) =
+      algebraMap K (LaurentSeries K) c := by
+  have h : IsRep K (algebraMap K (LaurentSeries K) c) 0 (Finsupp.single (oneD : IDatum M H 0) c)
+      (Finsupp.single oneD 1) := ⟨by simp, by rw [ev_single_oneD, ev_single_oneD, map_one, div_one]⟩
+  rw [rhoVal_eq _ h γ hγ, evT_single_oneD, evT_single_oneD, map_one, div_one]
+
+def rhoHom (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    qExpFunctionFieldC K (CohCarrier.GammaH M H) →ₐ[K]
+      qExpFunctionFieldC K (CohCarrier.GammaH M H) where
+  toFun x := ⟨rhoVal γ hγ x x.2, rhoVal_mem x.2 γ hγ⟩
+  map_one' := by
+    apply Subtype.ext
+    have h := rhoVal_algebraMap (M := M) (H := H) (1 : K) γ hγ
+    simp only [map_one] at h
+    exact h
+  map_mul' x y := Subtype.ext (rhoVal_mul x.2 y.2 γ hγ)
+  map_zero' := by
+    apply Subtype.ext
+    have h := rhoVal_algebraMap (M := M) (H := H) (0 : K) γ hγ
+    simp only [map_zero] at h
+    exact h
+  map_add' x y := Subtype.ext (rhoVal_add x.2 y.2 γ hγ)
+  commutes' c := Subtype.ext (rhoVal_algebraMap c γ hγ)
+
+@[scoped simp] theorem coe_rhoHom (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M)
+    (x : qExpFunctionFieldC K (CohCarrier.GammaH M H)) :
+    ((rhoHom γ hγ x : qExpFunctionFieldC K (CohCarrier.GammaH M H)) : LaurentSeries K) =
+      rhoVal γ hγ x x.2 :=
+  rfl
+
+theorem rhoVal_rhoVal {x : LaurentSeries K} (hx : x ∈ qExpFunctionFieldC K (CohCarrier.GammaH M H))
+    (γ δ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) (hδ : δ ∈ CongruenceSubgroup.Gamma0 M) :
+    rhoVal δ hδ (rhoVal γ hγ x hx) (rhoVal_mem hx γ hγ) = rhoVal (γ * δ) (mul_mem hγ hδ) x hx := by
+  obtain ⟨w, l, l', hl⟩ := exists_rep hx
+  rw [rhoVal_eq _ (isRep_rhoVal hx hl γ hγ) δ hδ, rhoVal_eq hx hl (γ * δ) (mul_mem hγ hδ),
+    evT_mul_right, evT_mul_right]
+
+theorem rhoVal_of_mem_GammaH {x : LaurentSeries K}
+    (hx : x ∈ qExpFunctionFieldC K (CohCarrier.GammaH M H))
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) (hγH : γ ∈ CohCarrier.GammaH M H) :
+    rhoVal γ hγ x hx = x := by
+  obtain ⟨w, l, l', hl⟩ := exists_rep hx
+  rw [rhoVal_eq hx hl γ hγ, evT_of_mem_GammaH _ _ _ hγH, evT_of_mem_GammaH _ _ _ hγH, ← hl.2]
+
+omit [NeZero M] in
+theorem commutator_mem_GammaH (γ δ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M)
+    (hδ : δ ∈ CongruenceSubgroup.Gamma0 M) :
+    γ * δ * γ⁻¹ * δ⁻¹ ∈ CohCarrier.GammaH M H := by
+  let c : CongruenceSubgroup.Gamma0 M := ⟨γ, hγ⟩ * ⟨δ, hδ⟩ * ⟨γ, hγ⟩⁻¹ * ⟨δ, hδ⟩⁻¹
+  have hc : (c : SL(2, ℤ)) = γ * δ * γ⁻¹ * δ⁻¹ := rfl
+  have hu : CohCarrier.gamma0Units M c = 1 := by
+    simp only [c, map_mul, map_inv]
+    rw [mul_comm (CohCarrier.gamma0Units M ⟨γ, hγ⟩) (CohCarrier.gamma0Units M ⟨δ, hδ⟩)]
+    group
+  rw [← hc, CohCarrier.mem_GammaH_iff]
+  exact ⟨c.2, by rw [Subtype.coe_eta, hu]; exact one_mem H⟩
+
+theorem rhoVal_mul_comm {x : LaurentSeries K}
+    (hx : x ∈ qExpFunctionFieldC K (CohCarrier.GammaH M H))
+    (γ δ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) (hδ : δ ∈ CongruenceSubgroup.Gamma0 M) :
+    rhoVal (γ * δ) (mul_mem hγ hδ) x hx = rhoVal (δ * γ) (mul_mem hδ hγ) x hx := by
+  have hc := commutator_mem_GammaH (M := M) (H := H) γ δ hγ hδ
+  have hc0 : γ * δ * γ⁻¹ * δ⁻¹ ∈ CongruenceSubgroup.Gamma0 M := CohCarrier.GammaH_le_Gamma0 H hc
+  have key : rhoVal ((γ * δ * γ⁻¹ * δ⁻¹) * (δ * γ)) (mul_mem hc0 (mul_mem hδ hγ)) x hx =
+      rhoVal (δ * γ) (mul_mem hδ hγ) x hx := by
+    rw [← rhoVal_rhoVal hx _ _ hc0 (mul_mem hδ hγ)]
+    congr 1
+    exact rhoVal_of_mem_GammaH hx _ hc0 hc
+  have he : (γ * δ * γ⁻¹ * δ⁻¹) * (δ * γ) = γ * δ := by group
+  simp only [he] at key
+  exact key
+
+def rhoEquiv (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) :
+    qExpFunctionFieldC K (CohCarrier.GammaH M H) ≃ₐ[K]
+      qExpFunctionFieldC K (CohCarrier.GammaH M H) :=
+  AlgEquiv.ofAlgHom (rhoHom γ hγ) (rhoHom γ⁻¹ (inv_mem hγ))
+    (by
+      refine AlgHom.ext fun x => Subtype.ext ?_
+      simp only [AlgHom.coe_comp, Function.comp_apply, coe_rhoHom, AlgHom.coe_id, id_eq]
+      rw [rhoVal_rhoVal]
+      exact rhoVal_of_mem_GammaH x.2 (γ⁻¹ * γ) (mul_mem (inv_mem hγ) hγ)
+        (by rw [inv_mul_cancel]; exact one_mem _))
+    (by
+      refine AlgHom.ext fun x => Subtype.ext ?_
+      simp only [AlgHom.coe_comp, Function.comp_apply, coe_rhoHom, AlgHom.coe_id, id_eq]
+      rw [rhoVal_rhoVal]
+      exact rhoVal_of_mem_GammaH x.2 (γ * γ⁻¹) (mul_mem hγ (inv_mem hγ))
+        (by rw [mul_inv_cancel]; exact one_mem _))
+
+@[scoped simp] theorem coe_rhoEquiv (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M)
+    (x : qExpFunctionFieldC K (CohCarrier.GammaH M H)) :
+    ((rhoEquiv γ hγ x : qExpFunctionFieldC K (CohCarrier.GammaH M H)) : LaurentSeries K) =
+      rhoVal γ hγ x x.2 := rfl
+
+def rho : CongruenceSubgroup.Gamma0 M →*
+    (qExpFunctionFieldC K (CohCarrier.GammaH M H) ≃ₐ[K]
+      qExpFunctionFieldC K (CohCarrier.GammaH M H)) where
+  toFun γ := rhoEquiv γ.1 γ.2
+  map_one' := by
+    refine AlgEquiv.ext fun x => Subtype.ext ?_
+    rw [coe_rhoEquiv, AlgEquiv.one_apply]
+    exact rhoVal_of_mem_GammaH x.2 (1 : SL(2, ℤ)) (one_mem _) (one_mem _)
+  map_mul' γ δ := by
+    refine AlgEquiv.ext fun x => Subtype.ext ?_
+    change rhoVal (γ.1 * δ.1) (mul_mem γ.2 δ.2) (x : LaurentSeries K) x.2 =
+      rhoVal γ.1 γ.2 (rhoVal δ.1 δ.2 (x : LaurentSeries K) x.2) (rhoVal_mem x.2 δ.1 δ.2)
+    rw [rhoVal_rhoVal x.2 δ.1 γ.1 δ.2 γ.2]
+    exact rhoVal_mul_comm x.2 γ.1 δ.1 γ.2 δ.2
+
+end Field
+end DiamondActZero
+end ModularCurve
+end
+
+noncomputable section
+
+open scoped MatrixGroups ModularForm
+open UpperHalfPlane
+
+namespace ModularCurve
+
+namespace DiamondActZero
+
+section Spec
+
+variable {M : ℕ} [NeZero M] {H : Subgroup (ZMod M)ˣ} {w : ℤ} {K : Type*} [Field K] [CharZero K]
+
+theorem slash_neg_one (F : ℍ → ℂ) (k : ℤ) : F ∣[k] (-1 : SL(2, ℤ)) = ((-1 : ℂ) ^ k) • F := by
+  funext τ
+  rw [ModularForm.SL_slash_apply, Pi.smul_apply, smul_eq_mul]
+  have h1 : (-1 : SL(2, ℤ)) • τ = τ := by simp
+  have h2 : denom (Matrix.SpecialLinearGroup.toGL
+      ((Matrix.SpecialLinearGroup.map (Int.castRingHom ℝ))
+        (-1 : SL(2, ℤ)))) (τ : ℂ) = -1 := by
+    simp [denom]
+  rw [h1, h2, mul_comm]
+  congr 1
+  rw [zpow_neg, ← inv_zpow, inv_neg, inv_one]
+
+def sgn (w : ℤ) : ℤ := if Even w then 1 else -1
+
+theorem sgn_ne_zero (w : ℤ) : sgn w ≠ 0 := by unfold sgn; split_ifs <;> decide
+
+theorem cast_sgn (w : ℤ) : ((sgn w : ℤ) : ℂ) = (-1 : ℂ) ^ w := by
+  unfold sgn
+  rcases Int.even_or_odd w with hw | hw
+  · rw [ite_eq_left hw, hw.neg_one_zpow]; simp
+  · rw [ite_eq_right (Int.not_even_iff_odd.mpr hw), hw.neg_one_zpow]; simp
+
+theorem tRed_neg_one (D : IDatum M H w) (h1 : (-1 : SL(2, ℤ)) ∈ CongruenceSubgroup.Gamma0 M) :
+    tRed K D (-1) h1 = ((sgn w : ℤ) : K) • intSeriesC K D.p := by
+  have hE : (⇑((sgn w) • D).f : ℍ → ℂ) = ((1 : ℤ) : ℂ) • ((⇑D.f : ℍ → ℂ) ∣[w] (-1 : SL(2, ℤ))) := by
+    rw [IDatum.zsmul_f', FunLike.coe_smul, Int.cast_one, one_smul, slash_neg_one, cast_sgn]
+  rw [tRed_eq_of D (-1) h1 1 one_ne_zero _ hE, IDatum.zsmul_p', intSeriesC_zsmul]
+  simp
+
+theorem rhoVal_neg_one {x : LaurentSeries K} (hx : x ∈ qExpFunctionFieldC K (CohCarrier.GammaH M H))
+    (h1 : (-1 : SL(2, ℤ)) ∈ CongruenceSubgroup.Gamma0 M) : rhoVal (-1) h1 x hx = x := by
+  obtain ⟨w, l, l', hl⟩ := exists_rep hx
+  have hsgn : ((sgn w : ℤ) : K) ≠ 0 := by
+    unfold sgn; split_ifs <;> simp
+  have hev : ∀ m : IDatum M H w →₀ K,
+      evT K w (-1) h1 m = HahnSeries.C ((sgn w : ℤ) : K) * ev K w m := by
+    intro m
+    rw [evT_apply, ev_apply, Finset.mul_sum]
+    exact Finset.sum_congr rfl fun D _ => by
+      rw [tRed_neg_one, ← HahnSeries.C_mul_eq_smul, ← HahnSeries.C_mul_eq_smul, ←
+        HahnSeries.C_mul_eq_smul]
+      ring
+  have hC : HahnSeries.C ((sgn w : ℤ) : K) ≠ (0 : LaurentSeries K) := by
+    intro h
+    exact hsgn (HahnSeries.C_injective (h.trans (map_zero _).symm))
+  rw [rhoVal_eq hx hl (-1) h1, hev, hev, hl.2, mul_div_mul_left _ _ hC]
+
+theorem rhoVal_eq_self_of_gamma0 {k : ℤ}
+    (f g : ModularForm (CongruenceSubgroup.Gamma0 M) k)
+    {pf pg : PowerSeries ℤ} (hf : IsIntegralQExp (⇑f) pf) (hg : IsIntegralQExp (⇑g) pg)
+    (hg0 : intSeriesC K pg ≠ 0) (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M)
+    (hx : intSeriesC K pf / intSeriesC K pg ∈ qExpFunctionFieldC K (CohCarrier.GammaH M H)) :
+    rhoVal γ hγ (intSeriesC K pf / intSeriesC K pg) hx = intSeriesC K pf / intSeriesC K pg := by
+  let Df : IDatum M H k :=
+    ⟨restrictForm (Subgroup.map_mono (CohCarrier.GammaH_le_Gamma0 H)) f, pf, hf⟩
+  let Dg : IDatum M H k :=
+    ⟨restrictForm (Subgroup.map_mono (CohCarrier.GammaH_le_Gamma0 H)) g, pg, hg⟩
+  have hrep : IsRep K (intSeriesC K pf / intSeriesC K pg) k (Finsupp.single Df 1)
+      (Finsupp.single Dg 1) :=
+    ⟨by simpa using hg0, by simp [Df, Dg]⟩
+  have hinvf : tRed K Df γ hγ = intSeriesC K pf := by
+    rw [tRed_eq_of Df γ hγ 1 one_ne_zero Df (by
+      rw [Int.cast_one, one_smul]
+      exact (SlashInvariantForm.slash_action_eqn f _ (Subgroup.mem_map_of_mem _ hγ)).symm)]
+    simp [Df]
+  have hinvg : tRed K Dg γ hγ = intSeriesC K pg := by
+    rw [tRed_eq_of Dg γ hγ 1 one_ne_zero Dg (by
+      rw [Int.cast_one, one_smul]
+      exact (SlashInvariantForm.slash_action_eqn g _ (Subgroup.mem_map_of_mem _ hγ)).symm)]
+    simp [Dg]
+  rw [rhoVal_eq hx hrep γ hγ, evT_single, evT_single, hinvf, hinvg, one_smul, one_smul]
+
+theorem rho_apply_eq_self_of_mem_gamma0 (γ : CongruenceSubgroup.Gamma0 M)
+    (x : qExpFunctionFieldC K (CohCarrier.GammaH M H))
+    (hx : (x : LaurentSeries K) ∈ qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M)) :
+    rho γ x = x := by
+  classical
+  let Fix : IntermediateField K (qExpFunctionFieldC K (CohCarrier.GammaH M H)) :=
+    IntermediateField.fixedField (Subgroup.zpowers (rho γ))
+  have hgen : qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M) ≤ IntermediateField.lift Fix := by
+    rw [qExpFunctionFieldC, IntermediateField.adjoin_le_iff]
+    rintro _ ⟨k, f, g, pf, pg, hf, hg, hg0, rfl⟩
+    have hmem : intSeriesC K pf / intSeriesC K pg ∈ qExpFunctionFieldC K (CohCarrier.GammaH M H) :=
+      qExpFunctionFieldC_mono K (CohCarrier.GammaH_le_Gamma0 H)
+        (div_mem_qExpFunctionFieldC f g hf hg hg0)
+    have hfix : rho γ ⟨_, hmem⟩ = ⟨_, hmem⟩ :=
+      Subtype.ext (rhoVal_eq_self_of_gamma0 f g hf hg hg0 γ.1 γ.2 hmem)
+    have hstab : Subgroup.zpowers (rho γ) ≤
+        MulAction.stabilizer (qExpFunctionFieldC K (CohCarrier.GammaH M H) ≃ₐ[K]
+          qExpFunctionFieldC K (CohCarrier.GammaH M H))
+            (⟨_, hmem⟩ : qExpFunctionFieldC K (CohCarrier.GammaH M H)) :=
+      Subgroup.zpowers_le.mpr hfix
+    exact (IntermediateField.mem_lift (⟨_, hmem⟩ :
+        qExpFunctionFieldC K (CohCarrier.GammaH M H))).mpr fun m => hstab m.2
+  have hx' : x ∈ Fix := (IntermediateField.mem_lift x).mp (hgen hx)
+  exact hx' ⟨_, Subgroup.mem_zpowers _⟩
+
+theorem rho_apply_generator (γ : CongruenceSubgroup.Gamma0 M) {k : ℤ}
+    (f g f₁ g₁ : ModularForm (Γᴴℝ M, H) k) {pf pg pf₁ pg₁ : PowerSeries ℤ} (c : ℂ)
+    (hf : IsIntegralQExp (⇑f) pf) (hg : IsIntegralQExp (⇑g) pg)
+    (hf₁ : IsIntegralQExp (⇑f₁) pf₁) (hg₁ : IsIntegralQExp (⇑g₁) pg₁)
+    (ef : (⇑f₁ : ℍ → ℂ) = c • ((⇑f : ℍ → ℂ) ∣[k] ((γ : SL(2, ℤ)) : GL (Fin 2) ℝ)))
+    (eg : (⇑g₁ : ℍ → ℂ) = c • ((⇑g : ℍ → ℂ) ∣[k] ((γ : SL(2, ℤ)) : GL (Fin 2) ℝ)))
+    (hg0 : intSeriesC K pg ≠ 0) (hg₁0 : intSeriesC K pg₁ ≠ 0) :
+    ((rho γ ⟨intSeriesC K pf / intSeriesC K pg, div_mem_qExpFunctionFieldC f g hf hg hg0⟩ :
+        qExpFunctionFieldC K (CohCarrier.GammaH M H)) : LaurentSeries K) =
+      intSeriesC K pf₁ / intSeriesC K pg₁ := by
+  let Df : IDatum M H k := ⟨f, pf, hf⟩
+  let Dg : IDatum M H k := ⟨g, pg, hg⟩
+  have hrep : IsRep K (intSeriesC K pf / intSeriesC K pg) k (Finsupp.single Df 1)
+      (Finsupp.single Dg 1) :=
+    ⟨by simpa using hg0, by simp [Df, Dg]⟩
+  change rhoVal γ.1 γ.2 (intSeriesC K pf / intSeriesC K pg)
+    (div_mem_qExpFunctionFieldC f g hf hg hg0) = _
+  rw [rhoVal_eq (div_mem_qExpFunctionFieldC f g hf hg hg0) hrep γ.1 γ.2, evT_single, evT_single,
+    one_smul, one_smul]
+  have hfun : ((texp Df γ.1 γ.2 : ℤ) : ℂ) • (⇑(f₁.mul (trans Dg γ.1 γ.2).f) : ℍ → ℂ) =
+      ((texp Dg γ.1 γ.2 : ℤ) : ℂ) • (⇑(g₁.mul (trans Df γ.1 γ.2).f) : ℍ → ℂ) := by
+    rw [ModularForm.coe_mul, ModularForm.coe_mul, trans_f, trans_f, ef, eg]
+    funext τ
+    simp only [Pi.smul_apply, Pi.mul_apply, smul_eq_mul, Df, Dg, ModularForm.SL_slash]
+    ring
+  have hZ := smul_eq_smul_of_coe _ _ (isIntegralQExp_mul hf₁ (trans Dg γ.1 γ.2).hp)
+    (isIntegralQExp_mul hg₁ (trans Df γ.1 γ.2).hp) _ _ hfun
+  have hK := congrArg (intSeriesC K) hZ
+  rw [intSeriesC_zsmul, intSeriesC_zsmul, intSeriesC_mul, intSeriesC_mul] at hK
+  have htg : tRed K Dg γ.1 γ.2 ≠ 0 := by
+    have := evT_ne_zero (Finsupp.single Dg (1 : K)) γ.1 γ.2 (by simpa using hg0)
+    simpa using this
+  rw [div_eq_div_iff htg hg₁0, tRed, tRed]
+  have hMa : ((texp Df γ.1 γ.2 : ℤ) : K) ≠ 0 := Int.cast_ne_zero.mpr (texp_ne_zero Df γ.1 γ.2)
+  have hMb : ((texp Dg γ.1 γ.2 : ℤ) : K) ≠ 0 := Int.cast_ne_zero.mpr (texp_ne_zero Dg γ.1 γ.2)
+  rw [← HahnSeries.C_mul_eq_smul, ← HahnSeries.C_mul_eq_smul] at hK
+  rw [← HahnSeries.C_mul_eq_smul, ← HahnSeries.C_mul_eq_smul]
+  have ha : HahnSeries.C ((texp Df γ.1 γ.2 : ℤ) : K) * HahnSeries.C ((texp Df γ.1 γ.2 : K)⁻¹) =
+      (1 : LaurentSeries K) := by rw [← map_mul, mul_inv_cancel₀ hMa, map_one]
+  have hb : HahnSeries.C ((texp Dg γ.1 γ.2 : ℤ) : K) * HahnSeries.C ((texp Dg γ.1 γ.2 : K)⁻¹) =
+      (1 : LaurentSeries K) := by rw [← map_mul, mul_inv_cancel₀ hMb, map_one]
+  have hAB : HahnSeries.C ((texp Df γ.1 γ.2 : ℤ) : K) * HahnSeries.C (texp Dg γ.1 γ.2 : K) ≠
+      (0 : LaurentSeries K) := by
+    rw [← map_mul]
+    intro h
+    exact (mul_ne_zero hMa hMb) (HahnSeries.C_injective (h.trans (map_zero _).symm))
+  refine mul_left_cancel₀ hAB ?_
+  linear_combination (HahnSeries.C ((texp Dg γ.1 γ.2 : ℤ) : K) * intSeriesC K (trans Df γ.1 γ.2).p *
+      intSeriesC K pg₁) * ha -
+    (HahnSeries.C ((texp Df γ.1 γ.2 : ℤ) : K) * intSeriesC K pf₁ * intSeriesC K
+      (trans Dg γ.1 γ.2).p) * hb - hK
+
+theorem main (K : Type*) [Field K] [CharZero K] (M : ℕ) [NeZero M] (H : Subgroup (ZMod M)ˣ) :
+    ∃ ρ : CongruenceSubgroup.Gamma0 M →*
+        (qExpFunctionFieldC K (CohCarrier.GammaH M H) ≃ₐ[K]
+          qExpFunctionFieldC K (CohCarrier.GammaH M H)),
+      (∀ γ : CongruenceSubgroup.Gamma0 M, (γ : SL(2, ℤ)) ∈ CohCarrier.GammaH M H → ρ γ = 1) ∧
+      (∀ γ : CongruenceSubgroup.Gamma0 M, (γ : SL(2, ℤ)) = -1 → ρ γ = 1) ∧
+      (∀ (γ : CongruenceSubgroup.Gamma0 M) (x : qExpFunctionFieldC K (CohCarrier.GammaH M H)),
+        (x : LaurentSeries K) ∈ qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M) → ρ γ x = x) ∧
+      (∀ (γ : CongruenceSubgroup.Gamma0 M) {k : ℤ}
+        (f g f₁ g₁ : ModularForm (CohCarrier.GammaH M H : Subgroup (GL (Fin 2) ℝ)) k)
+        {pf pg pf₁ pg₁ : PowerSeries ℤ} (c : ℂ) (_ : c ≠ 0)
+        (hf : IsIntegralQExp f pf) (hg : IsIntegralQExp g pg)
+        (_ : IsIntegralQExp f₁ pf₁) (_ : IsIntegralQExp g₁ pg₁)
+        (_ : (⇑f₁ : ℍ → ℂ) = c • ((⇑f : ℍ → ℂ) ∣[k] ((γ : SL(2, ℤ)) : GL (Fin 2) ℝ)))
+        (_ : (⇑g₁ : ℍ → ℂ) = c • ((⇑g : ℍ → ℂ) ∣[k] ((γ : SL(2, ℤ)) : GL (Fin 2) ℝ)))
+        (hg0 : intSeriesC K pg ≠ 0) (_ : intSeriesC K pg₁ ≠ 0),
+          ((ρ γ ⟨intSeriesC K pf / intSeriesC K pg, div_mem_qExpFunctionFieldC f g hf hg hg0⟩ :
+              qExpFunctionFieldC K (CohCarrier.GammaH M H)) : LaurentSeries K) =
+            intSeriesC K pf₁ / intSeriesC K pg₁) := by
+  refine ⟨rho, fun γ hγH ↦ ?_, fun γ hγ1 ↦ ?_, fun γ x hx ↦ rho_apply_eq_self_of_mem_gamma0 γ x hx,
+    fun γ k f g f₁ g₁ pf pg pf₁ pg₁ c => by
+      intro
+      exact rho_apply_generator γ f g f₁ g₁ c⟩
+  · refine AlgEquiv.ext fun x => Subtype.ext ?_
+    rw [AlgEquiv.one_apply]
+    exact rhoVal_of_mem_GammaH x.2 γ.1 γ.2 hγH
+  · refine AlgEquiv.ext fun x => Subtype.ext ?_
+    rw [AlgEquiv.one_apply]
+    change rhoVal γ.1 γ.2 (x : LaurentSeries K) x.2 = (x : LaurentSeries K)
+    have key : ∀ (δ : SL(2, ℤ)) (hδ : δ ∈ CongruenceSubgroup.Gamma0 M), δ = -1 →
+        rhoVal δ hδ (x : LaurentSeries K) x.2 = x := by
+      rintro δ hδ rfl
+      exact rhoVal_neg_one x.2 hδ
+    exact key γ.1 γ.2 hγ1
+
+end Spec
+end DiamondActZero
+end ModularCurve
+end
+
+open scoped MatrixGroups ModularForm in
+theorem solution
+    (K : Type*) [Field K] [CharZero K] (M : ℕ) [NeZero M] (H : Subgroup (ZMod M)ˣ) :
+    ∃ ρ : CongruenceSubgroup.Gamma0 M →*
+        (ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H) ≃ₐ[K]
+          ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H)),
+      (∀ γ : CongruenceSubgroup.Gamma0 M, (γ : SL(2, ℤ)) ∈ CohCarrier.GammaH M H → ρ γ = 1) ∧
+      (∀ γ : CongruenceSubgroup.Gamma0 M, (γ : SL(2, ℤ)) = -1 → ρ γ = 1) ∧
+      (∀ (γ : CongruenceSubgroup.Gamma0 M)
+        (x : ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H)),
+        (x : LaurentSeries K) ∈ ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M) →
+          ρ γ x = x) ∧
+      (∀ (γ : CongruenceSubgroup.Gamma0 M) {k : ℤ}
+        (f g f₁ g₁ : ModularForm (CohCarrier.GammaH M H : Subgroup (GL (Fin 2) ℝ)) k)
+        {pf pg pf₁ pg₁ : PowerSeries ℤ} (c : ℂ) (_ : c ≠ 0)
+        (hf : ModularCurve.IsIntegralQExp f pf) (hg : ModularCurve.IsIntegralQExp g pg)
+        (_ : ModularCurve.IsIntegralQExp f₁ pf₁) (_ : ModularCurve.IsIntegralQExp g₁ pg₁)
+        (_ : (⇑f₁ : UpperHalfPlane → ℂ) =
+          c • ((⇑f : UpperHalfPlane → ℂ) ∣[k] ((γ : SL(2, ℤ)) : GL (Fin 2) ℝ)))
+        (_ : (⇑g₁ : UpperHalfPlane → ℂ) =
+          c • ((⇑g : UpperHalfPlane → ℂ) ∣[k] ((γ : SL(2, ℤ)) : GL (Fin 2) ℝ)))
+        (hg0 : ModularCurve.intSeriesC K pg ≠ 0) (_ : ModularCurve.intSeriesC K pg₁ ≠ 0),
+          ((ρ γ ⟨ModularCurve.intSeriesC K pf / ModularCurve.intSeriesC K pg,
+              ModularCurve.div_mem_qExpFunctionFieldC f g hf hg hg0⟩ :
+                ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H)) : LaurentSeries K) =
+            ModularCurve.intSeriesC K pf₁ / ModularCurve.intSeriesC K pg₁) :=
+  ModularCurve.DiamondActZero.main K M H
+
+end privateSection
+
+public section publicSection
+
+open scoped MatrixGroups ModularForm in
+theorem ModularCurve.exists_monoidHom_gamma0_algEquiv_qExpFunctionFieldC_gammaH_of_charZero
+    (K : Type*) [Field K] [CharZero K] (M : ℕ) [NeZero M] (H : Subgroup (ZMod M)ˣ) :
+    ∃ ρ : CongruenceSubgroup.Gamma0 M →*
+        (ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H) ≃ₐ[K]
+          ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H)),
+      (∀ γ : CongruenceSubgroup.Gamma0 M, (γ : SL(2, ℤ)) ∈ CohCarrier.GammaH M H → ρ γ = 1) ∧
+      (∀ γ : CongruenceSubgroup.Gamma0 M, (γ : SL(2, ℤ)) = -1 → ρ γ = 1) ∧
+      (∀ (γ : CongruenceSubgroup.Gamma0 M)
+        (x : ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H)),
+        (x : LaurentSeries K) ∈ ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M) →
+          ρ γ x = x) ∧
+      (∀ (γ : CongruenceSubgroup.Gamma0 M) {k : ℤ}
+        (f g f₁ g₁ : ModularForm (CohCarrier.GammaH M H : Subgroup (GL (Fin 2) ℝ)) k)
+        {pf pg pf₁ pg₁ : PowerSeries ℤ} (c : ℂ) (_ : c ≠ 0)
+        (hf : ModularCurve.IsIntegralQExp f pf) (hg : ModularCurve.IsIntegralQExp g pg)
+        (_ : ModularCurve.IsIntegralQExp f₁ pf₁) (_ : ModularCurve.IsIntegralQExp g₁ pg₁)
+        (_ : (⇑f₁ : UpperHalfPlane → ℂ) =
+          c • ((⇑f : UpperHalfPlane → ℂ) ∣[k] ((γ : SL(2, ℤ)) : GL (Fin 2) ℝ)))
+        (_ : (⇑g₁ : UpperHalfPlane → ℂ) =
+          c • ((⇑g : UpperHalfPlane → ℂ) ∣[k] ((γ : SL(2, ℤ)) : GL (Fin 2) ℝ)))
+        (hg0 : ModularCurve.intSeriesC K pg ≠ 0) (_ : ModularCurve.intSeriesC K pg₁ ≠ 0),
+          ((ρ γ ⟨ModularCurve.intSeriesC K pf / ModularCurve.intSeriesC K pg,
+              ModularCurve.div_mem_qExpFunctionFieldC f g hf hg hg0⟩ :
+                ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H)) : LaurentSeries K) =
+            ModularCurve.intSeriesC K pf₁ / ModularCurve.intSeriesC K pg₁) :=
+  solution K M H
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_mvPolynomial_mul_aeval_fricke_eq_of_qExpansion_coeff_mem.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_mvPolynomial_mul_aeval_fricke_eq_of_qExpansion_coeff_mem.lean
new file mode 100644
index 0000000000..6d6481056a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_mvPolynomial_mul_aeval_fricke_eq_of_qExpansion_coeff_mem.lean
@@ -0,0 +1,694 @@
+/-
+Based on Prove2Me node ModularCurve.exists_mvPolynomial_mul_aeval_fricke_eq_of_qExpansion_coeff_mem
+(1ee56bf0-39ce-5bab-b809-25b996df57bb) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7206dcee-c283-5490-b2d7-5ccdbb007559
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.SpecialFunctions.Elliptic.Weierstrass
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+
+import Mathlib.Algebra.CharP.Pi
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+import Mathlib.RingTheory.MvPolynomial.IrreducibleQuadratic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_exists_levelFraction_of_stable_family
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_exists_monicRel_j_of_mdifferentiable_levelFraction
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_exists_qExpansion_coeff_mem_of_mdifferentiable_levelFraction
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_intBaseChange
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelN_structure_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_linearIndependent_complex_of_qExpansion_rational
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Descent by Fourier coefficients to K(j,fᵥ)
+
+Theorem statement: `ModularCurve.exists_mvPolynomial_mul_aeval_fricke_eq_of_qExpansion_coeff_mem`
+(`1ee56bf0-39ce-5bab-b809-25b996df57bb`), by Claude, 2026-09-05.
+
+Proof: submission `7206dcee-c283-5490-b2d7-5ccdbb007559`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N\ge 1$ be a natural number. The Weierstrass data are given as parameters with defining
+hypotheses: a family $L$ of period pairs with $(L\tau).\omega_1=\tau$ and $(L\tau).\omega_2=1$ for
+every $\tau$ in the upper half-plane; a family $W$ indexed by $v\in(\mathbb{Z}/N)^2$ with
+$W_v(\tau)=(2\pi i)^{-2}\,\wp\bigl(L\tau;\,(\tilde v_0\tau+\tilde v_1)/N\bigr)$, where $\tilde v_i$
+denotes the least non-negative residue; the Fricke family
+$\mathit{fricke}_v(\tau)=-\tfrac{1}{2592}\,\bigl(E_4(\tau)E_6(\tau)/\Delta(\tau)\bigr)\,W_v(\tau)$;
+and $\mathit{jf}(\tau)=E_4(\tau)^3/\Delta(\tau)$. Let $K$ be the intermediate field
+$\mathbb{Q}\bigl(e^{2\pi i/N}\bigr)$ of $\mathbb{C}/\mathbb{Q}$. Let $m$ be a natural number and $G$
+a function on the upper half-plane which is holomorphic (differentiable for the complex model on the
+half-plane), satisfies $G(\gamma\cdot\tau)=G(\tau)$ for all $\gamma\in\Gamma(N)$ and all $\tau$, is
+such that $\tau\mapsto G(\alpha\cdot\tau)\,\Delta(\tau)^m$ is bounded as
+$\operatorname{Im}\tau\to\infty$ for every $\alpha\in\mathrm{SL}_2(\mathbb{Z})$, and is such that
+every coefficient of the level-$N$ $q$-expansion of $G\cdot\Delta^m$ lies in $K$. Then there exist
+polynomials $P,Q$ over $K$ in variables indexed by $\mathrm{Option}\,\{v\in(\mathbb{Z}/N)^2: v\ne
+0\}$ such that, evaluating the variables at $\mathit{jf}$ (for `none`) and at $\mathit{fricke}_v$
+(for $v\ne 0$) after mapping coefficients into $\mathbb{C}$, the value of $Q$ is not the zero
+function on the upper half-plane, and $G$ times the value of $Q$ equals the value of $P$.
+
+This is the rationality descent for the modular function field of level $N$ (Shimura's Proposition
+6.9) in the case of functions holomorphic on the upper half-plane: a $\Gamma(N)$-invariant function
+with $\mathbb{Q}(\zeta_N)$-rational Fourier coefficients is a fraction, with coefficients in
+$\mathbb{Q}(\zeta_N)$, of polynomials in $j$ and the Fricke functions of level $N$. It is used by
+[`ModularCurve.exists_ne_zero_forall_intCast_mul_qExpansion_coeff_of_gamma_invariant`]
+(thm.html#ModularCurve.exists_ne_zero_forall_intCast_mul_qExpansion_coeff_of_gamma_invariant),
+on the way to the arithmetic of modular curves used in the modularity arguments.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_mvPolynomial_mul_aeval_fricke_eq_of_qExpansion_coeff_mem.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_mvPolynomial_mul_aeval_fricke_eq_of_qExpansion_coeff_mem
+
+noncomputable section
+
+open Complex UpperHalfPlane ModularForm CongruenceSubgroup Function
+open scoped Real Manifold MatrixGroups ModularForm Topology
+
+namespace GammaNDescent
+
+structure FD (N : ℕ) [NeZero N] where
+  L : ℍ → PeriodPair
+  hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1
+  W : (Fin 2 → ZMod N) → ℍ → ℂ
+  hW : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), W v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+    PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ))
+  fricke : (Fin 2 → ZMod N) → ℍ → ℂ
+  hfricke : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), fricke v τ =
+    -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ
+  jf : ℍ → ℂ
+  hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ
+
+variable (N : ℕ) [NeZero N]
+
+def zetaN : ℂ := Complex.exp (2 * (Real.pi : ℂ) * Complex.I / (N : ℂ))
+
+def kN : IntermediateField ℚ ℂ := IntermediateField.adjoin ℚ {zetaN N}
+
+variable {N}
+variable (X : FD N)
+
+def genSet : Set (ℍ → ℂ) := insert X.jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = X.fricke v}
+
+variable (N) in
+abbrev Idx : Type := Option {v : Fin 2 → ZMod N // v ≠ 0}
+
+def gen : Idx N → ℍ → ℂ := fun o => o.elim X.jf fun v => X.fricke v.1
+
+theorem gen_eq : gen X = fun o : Idx N => o.elim X.jf fun v => X.fricke v.1 := rfl
+
+section Width
+
+local notation "Δ" => ModularForm.discriminant
+
+theorem mdifferentiable_disc : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (Δ : ℍ → ℂ) := by
+  rw [← CuspForm.coe_discriminant]; exact CuspForm.discriminant.holo'
+
+theorem periodic_disc_one : Periodic ((Δ : ℍ → ℂ) ∘ ofComplex) 1 := by
+  have :=
+    SlashInvariantFormClass.periodic_comp_ofComplex CuspForm.discriminant one_mem_strictPeriods_SL
+  rwa [CuspForm.coe_discriminant] at this
+
+theorem isBoundedAtImInfty_disc : IsBoundedAtImInfty (Δ : ℍ → ℂ) := by
+  have := ModularFormClass.bdd_at_infty CuspForm.discriminant
+  rwa [CuspForm.coe_discriminant] at this
+
+theorem disc_ne_zero_fun : (Δ : ℍ → ℂ) ≠ 0 := fun h => by
+  have := congrFun h UpperHalfPlane.I
+  exact discriminant_ne_zero _ this
+
+theorem disc_pow_ne_zero (m : ℕ) (τ : ℍ) : (Δ ^ m : ℍ → ℂ) τ ≠ 0 := by
+  rw [Pi.pow_apply]; exact pow_ne_zero _ (discriminant_ne_zero τ)
+
+theorem periodic_ofComplex_natCast {g : ℍ → ℂ} (h : Periodic (g ∘ ofComplex) 1) (n : ℕ) :
+    Periodic (g ∘ ofComplex) n := by
+  simpa using h.nat_mul n
+
+theorem periodic_mul {g g' : ℍ → ℂ} {c : ℂ} (h : Periodic (g ∘ ofComplex) c)
+    (h' : Periodic (g' ∘ ofComplex) c) : Periodic ((g * g') ∘ ofComplex) c := by
+  intro z
+  have h1 := h z
+  have h2 := h' z
+  simp only [comp_apply, Pi.mul_apply] at h1 h2 ⊢
+  rw [h1, h2]
+
+theorem periodic_pow {g : ℍ → ℂ} {c : ℂ} (h : Periodic (g ∘ ofComplex) c) (m : ℕ) :
+    Periodic ((g ^ m) ∘ ofComplex) c := by
+  induction m with
+  | zero => intro z; simp
+  | succ m ih => rw [pow_succ]; exact periodic_mul ih h
+
+theorem periodic_smul {g : ℍ → ℂ} {c : ℂ} (h : Periodic (g ∘ ofComplex) c) (a : ℂ) :
+    Periodic ((a • g) ∘ ofComplex) c := by
+  intro z; have h1 := h z; simp only [comp_apply, Pi.smul_apply] at h1 ⊢; rw [h1]
+
+theorem periodic_add {g g' : ℍ → ℂ} {c : ℂ} (h : Periodic (g ∘ ofComplex) c)
+    (h' : Periodic (g' ∘ ofComplex) c) : Periodic ((g + g') ∘ ofComplex) c := by
+  intro z
+  have h1 := h z
+  have h2 := h' z
+  simp only [comp_apply, Pi.add_apply] at h1 h2 ⊢
+  rw [h1, h2]
+
+theorem qExpansion_coeff_unique' {h : ℝ} (hh : 0 < h) {g : ℍ → ℂ} {c : ℕ → ℂ}
+    (hg : AnalyticAt ℂ (cuspFunction h g) 0)
+    (hc : ∀ τ : ℍ, HasSum (fun m => c m • Periodic.qParam h τ ^ m) (g τ)) (m : ℕ) :
+    c m = (qExpansion h g).coeff m := by
+  have h1 := (hasFPowerSeriesOnBall_cuspFunction hh hg hc).hasFPowerSeriesAt
+  have h2 : HasFPowerSeriesAt (cuspFunction h g)
+      (FormalMultilinearSeries.ofScalars ℂ fun m => (qExpansion h g).coeff m) 0 := by
+    simpa [qExpansion_coeff, div_eq_mul_inv, mul_comm] using hg.hasFPowerSeriesAt
+  simpa [FormalMultilinearSeries.coeff_ofScalars] using
+    congr_arg (FormalMultilinearSeries.coeff · m) (h1.eq_formalMultilinearSeries h2)
+
+variable (N : ℕ) [NeZero N]
+
+theorem natCast_pos : (0 : ℝ) < (N : ℝ) := Nat.cast_pos.mpr (NeZero.pos N)
+
+theorem qParam_one_eq_pow (τ : ℍ) : Periodic.qParam 1 τ = Periodic.qParam N τ ^ N := by
+  simp only [Periodic.qParam]
+  rw [← Complex.exp_nat_mul]
+  congr 1
+  have : (N : ℂ) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne N)
+  push_cast
+  field_simp
+
+theorem qExpansion_coeff_widthN {g : ℍ → ℂ} (hg : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hper : Periodic (g ∘ ofComplex) 1) (hbd : IsBoundedAtImInfty g) (n : ℕ) :
+    (qExpansion N g).coeff n = if (N : ℕ) ∣ n then (qExpansion 1 g).coeff (n / N) else 0 := by
+  classical
+  have hperN : Periodic (g ∘ ofComplex) N := periodic_ofComplex_natCast hper N
+  set c : ℕ → ℂ := fun n => if (N : ℕ) ∣ n then (qExpansion 1 g).coeff (n / N) else 0 with hc
+  have hNpos : 0 < N := NeZero.pos N
+  have hsum : ∀ τ : ℍ, HasSum (fun m => c m • Periodic.qParam N τ ^ m) (g τ) := by
+    intro τ
+    have h1 := hasSum_qExpansion one_pos hper hg hbd τ
+    have hinj : Function.Injective fun m : ℕ => N * m := mul_right_injective₀ hNpos.ne'
+    have hsupp : ∀ x ∉ Set.range (fun m : ℕ => N * m),
+        (fun m => c m • Periodic.qParam N τ ^ m) x = 0 := by
+      intro x hx
+      have : ¬ (N : ℕ) ∣ x := by
+        rintro ⟨y, rfl⟩; exact hx ⟨y, rfl⟩
+      simp [hc, this]
+    refine (hinj.hasSum_iff hsupp).1 ?_
+    convert h1 using 1
+    funext m
+    simp only [comp_apply, hc, dvd_mul_right, ↓reduceIte, Nat.mul_div_cancel_left _ hNpos]
+    rw [qParam_one_eq_pow N τ, ← pow_mul]
+  rw [← qExpansion_coeff_unique' (natCast_pos N) (analyticAt_cuspFunction_zero (natCast_pos N)
+    hperN hg hbd) hsum n]
+
+theorem qExpansion_widthN_rat {g : ℍ → ℂ} (hg : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hper : Periodic (g ∘ ofComplex) 1) (hbd : IsBoundedAtImInfty g)
+    (hrat : ∀ n, ∃ r : ℚ, (qExpansion 1 g).coeff n = (r : ℂ)) (n : ℕ) :
+    ∃ r : ℚ, (qExpansion N g).coeff n = (r : ℂ) := by
+  rw [qExpansion_coeff_widthN N hg hper hbd n]
+  split_ifs with h
+  · exact hrat _
+  · exact ⟨0, by simp⟩
+
+theorem qExpansion_widthOne_rat {g : ℍ → ℂ} (hg : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hper : Periodic (g ∘ ofComplex) 1) (hbd : IsBoundedAtImInfty g)
+    (hrat : ∀ n, ∃ r : ℚ, (qExpansion N g).coeff n = (r : ℂ)) (n : ℕ) :
+    ∃ r : ℚ, (qExpansion 1 g).coeff n = (r : ℂ) := by
+  obtain ⟨r, hr⟩ := hrat (N * n)
+  rw [qExpansion_coeff_widthN N hg hper hbd, ite_eq_left (dvd_mul_right N n),
+    Nat.mul_div_cancel_left _ (NeZero.pos N)] at hr
+  exact ⟨r, hr⟩
+
+theorem qExpansion_disc_rat_one (n : ℕ) :
+    ∃ r : ℚ, (qExpansion 1 (Δ : ℍ → ℂ)).coeff n = (r : ℂ) := by
+  let A : ModularForm 𝒮ℒ 12 := (E₄.pow 3).mcast (by norm_num)
+  let B : ModularForm 𝒮ℒ 12 := (E₆.pow 2).mcast (by norm_num)
+  have hfun : (Δ : ℍ → ℂ) = ⇑((1728 : ℂ)⁻¹ • (A - B)) := by
+    funext z
+    rw [discriminant_eq_E₄_cube_sub_E₆_sq, smul_apply, sub_apply]
+    simp only [A, B, coe_mcast, coe_pow, Pi.pow_apply, smul_eq_mul]
+    ring
+  have h4 : ∀ n, ∃ r : ℚ, (qExpansion 1 (E₄ : ℍ → ℂ)).coeff n = (r : ℂ) := by
+    intro n
+    rw [ModularForm.E₄, EisensteinSeries.E_qExpansion_coeff (by norm_num) (by decide) n]
+    split_ifs
+    · exact ⟨1, by simp⟩
+    · exact ⟨-(2 * 4 / bernoulli 4) * (ArithmeticFunction.sigma 3 n : ℚ), by push_cast; ring⟩
+  have h6 : ∀ n, ∃ r : ℚ, (qExpansion 1 (E₆ : ℍ → ℂ)).coeff n = (r : ℂ) := by
+    intro n
+    rw [ModularForm.E₆, EisensteinSeries.E_qExpansion_coeff (by norm_num) (by decide) n]
+    split_ifs
+    · exact ⟨1, by simp⟩
+    · exact ⟨-(2 * 6 / bernoulli 6) * (ArithmeticFunction.sigma 5 n : ℚ), by push_cast; ring⟩
+  obtain ⟨p4, hp4⟩ : ∃ p : PowerSeries ℚ, p.map (algebraMap ℚ ℂ) = qExpansion 1 (E₄ : ℍ → ℂ) := by
+    choose r hr using h4
+    exact ⟨PowerSeries.mk r, by ext n; simp [hr n]⟩
+  obtain ⟨p6, hp6⟩ : ∃ p : PowerSeries ℚ, p.map (algebraMap ℚ ℂ) = qExpansion 1 (E₆ : ℍ → ℂ) := by
+    choose r hr using h6
+    exact ⟨PowerSeries.mk r, by ext n; simp [hr n]⟩
+  have hq : qExpansion 1 (Δ : ℍ → ℂ) = ((1728 : ℚ)⁻¹ • (p4 ^ 3 - p6 ^ 2)).map (algebraMap ℚ ℂ) := by
+    rw [hfun, FunLike.coe_smul, ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL,
+      FunLike.coe_sub, ModularForm.qExpansion_sub one_pos one_mem_strictPeriods_SL]
+    simp only [A, B, ModularForm.qExpansion_mcast,
+      ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+    rw [PowerSeries.smul_eq_C_mul, PowerSeries.smul_eq_C_mul, map_mul, PowerSeries.map_C, map_sub,
+      map_pow, map_pow, hp4, hp6]
+    congr 1
+    simp
+  refine ⟨PowerSeries.coeff n ((1728 : ℚ)⁻¹ • (p4 ^ 3 - p6 ^ 2)), ?_⟩
+  rw [hq, PowerSeries.coeff_map]
+  rfl
+
+theorem qExpansion_disc_rat (n : ℕ) : ∃ r : ℚ, (qExpansion N (Δ : ℍ → ℂ)).coeff n = (r : ℂ) :=
+  qExpansion_widthN_rat N mdifferentiable_disc periodic_disc_one isBoundedAtImInfty_disc
+    qExpansion_disc_rat_one n
+
+variable (K : IntermediateField ℚ ℂ)
+
+structure RatAt (m : ℕ) (g : ℍ → ℂ) : Prop where
+  mdiff : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g
+  periodic : Periodic ((g * Δ ^ m) ∘ ofComplex) N
+  bdd : IsBoundedAtImInfty (g * Δ ^ m)
+  mem : ∀ n, (qExpansion N (g * Δ ^ m)).coeff n ∈ K
+
+variable {N K}
+
+theorem ratCast_mem (r : ℚ) : ((r : ℂ)) ∈ K := by
+  have : (r : ℂ) = algebraMap ℚ ℂ r := rfl
+  rw [this]; exact K.algebraMap_mem r
+
+omit [NeZero N] in
+theorem RatAt.mdiff_mul {m : ℕ} {g : ℍ → ℂ} (h : RatAt N K m g) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (g * Δ ^ m) :=
+  h.mdiff.mul (mdifferentiable_disc.pow m)
+
+theorem RatAt.analyticAt {m : ℕ} {g : ℍ → ℂ} (h : RatAt N K m g) :
+    AnalyticAt ℂ (cuspFunction N (g * Δ ^ m)) 0 :=
+  analyticAt_cuspFunction_zero (natCast_pos N) h.periodic h.mdiff_mul h.bdd
+
+theorem analyticAt_disc : AnalyticAt ℂ (cuspFunction N (Δ : ℍ → ℂ)) 0 :=
+  analyticAt_cuspFunction_zero (natCast_pos N) (periodic_ofComplex_natCast periodic_disc_one N)
+    mdifferentiable_disc isBoundedAtImInfty_disc
+
+theorem RatAt.succ {m : ℕ} {g : ℍ → ℂ} (h : RatAt N K m g) : RatAt N K (m + 1) g where
+  mdiff := h.mdiff
+  periodic := by
+    rw [pow_succ, ← mul_assoc]
+    exact periodic_mul h.periodic (periodic_ofComplex_natCast periodic_disc_one N)
+  bdd := by rw [pow_succ, ← mul_assoc]; exact h.bdd.mul isBoundedAtImInfty_disc
+  mem := by
+    intro n
+    rw [pow_succ, ← mul_assoc, qExpansion_mul h.analyticAt analyticAt_disc, PowerSeries.coeff_mul]
+    refine sum_mem fun ij _ => mul_mem (h.mem _) ?_
+    obtain ⟨r, hr⟩ := qExpansion_disc_rat N ij.2
+    rw [hr]; exact ratCast_mem r
+
+theorem RatAt.of_le {m m' : ℕ} (hm : m ≤ m') {g : ℍ → ℂ} (h : RatAt N K m g) : RatAt N K m' g := by
+  obtain ⟨d, rfl⟩ := Nat.exists_eq_add_of_le hm
+  induction d with
+  | zero => simpa using h
+  | succ d ih => exact (ih (Nat.le_add_right m d)).succ
+
+omit [NeZero N] in
+theorem RatAt.exists_map {m : ℕ} {g : ℍ → ℂ} (h : RatAt N K m g) :
+    ∃ p : PowerSeries K, p.map (algebraMap K ℂ) = qExpansion N (g * Δ ^ m) := by
+  refine ⟨PowerSeries.mk fun n => ⟨_, h.mem n⟩, ?_⟩
+  ext n
+  simp
+
+theorem RatAt.qExpansion_ne_zero {m : ℕ} {g : ℍ → ℂ} (h : RatAt N K m g) (hg : g ≠ 0) :
+    qExpansion N (g * Δ ^ m) ≠ 0 := by
+  rw [Ne, qExpansion_eq_zero_iff (natCast_pos N) h.periodic h.mdiff_mul h.bdd]
+  intro h0
+  apply hg
+  funext τ
+  have := congrFun h0 τ
+  simp only [Pi.mul_apply, Pi.zero_apply, mul_eq_zero] at this
+  rcases this with h1 | h1
+  · exact h1
+  · exact absurd h1 (disc_pow_ne_zero m τ)
+
+end Width
+
+section Invariance
+
+variable {N : ℕ}
+
+local notation "Δ" => ModularForm.discriminant
+
+def cw (G : ℍ → ℂ) (α : SL(2, ℤ)) : ℍ → ℂ := fun τ => G (α • τ)
+
+theorem cw_apply (G : ℍ → ℂ) (α : SL(2, ℤ)) (τ : ℍ) : cw G α τ = G (α • τ) := rfl
+
+theorem cw_mul (G : ℍ → ℂ) (α β : SL(2, ℤ)) : cw G (α * β) = cw (cw G α) β := by
+  funext τ; simp [cw, mul_smul]
+
+theorem cw_one (G : ℍ → ℂ) : cw G 1 = G := by funext τ; simp [cw]
+
+theorem cw_eq_slash (G : ℍ → ℂ) (α : SL(2, ℤ)) : cw G α = G ∣[(0 : ℤ)] α := by
+  funext τ
+  rw [ModularForm.SL_slash_apply, cw_apply, neg_zero, zpow_zero, mul_one]
+
+theorem mdifferentiable_cw {G : ℍ → ℂ} (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G) (α : SL(2, ℤ)) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (cw G α) := by
+  rw [cw_eq_slash, ModularForm.SL_slash]; exact hG.slash _ _
+
+theorem conj_mem_Gamma (N : ℕ) (α : SL(2, ℤ)) {g : SL(2, ℤ)} (hg : g ∈ CongruenceSubgroup.Gamma N) :
+    α * g * α⁻¹ ∈ CongruenceSubgroup.Gamma N :=
+  Subgroup.Normal.conj_mem (Gamma_normal N) g hg α
+
+end Invariance
+
+section Fricke
+
+variable {N : ℕ} [NeZero N] (X : FD N)
+
+local notation "Δ" => ModularForm.discriminant
+
+def ev (R : MvPolynomial (Idx N) (kN N)) : ℍ → ℂ :=
+  MvPolynomial.aeval (gen X) (MvPolynomial.map (algebraMap (kN N) ℂ) R)
+
+theorem gen_mem (o : Idx N) : gen X o ∈ genSet X := by
+  cases o with
+  | none => exact Set.mem_insert _ _
+  | some v => exact Set.mem_insert_of_mem _ ⟨v.1, v.2, rfl⟩
+
+theorem aeval_mem_adjoin (R : MvPolynomial (Idx N) ℂ) :
+    MvPolynomial.aeval (gen X) R ∈ Algebra.adjoin ℂ (genSet X) := by
+  induction R using MvPolynomial.induction_on with
+  | C c => rw [MvPolynomial.aeval_C]; exact Subalgebra.algebraMap_mem _ c
+  | add p q hp hq => rw [map_add]; exact add_mem hp hq
+  | mul_X p o hp =>
+      rw [map_mul, MvPolynomial.aeval_X]
+      exact mul_mem hp (Algebra.subset_adjoin (gen_mem X o))
+
+theorem ev_mem_adjoin (R : MvPolynomial (Idx N) (kN N)) : ev X R ∈ Algebra.adjoin ℂ (genSet X) :=
+  aeval_mem_adjoin X _
+
+theorem adjoin_isDomain {a b : ℍ → ℂ} (ha : a ∈ Algebra.adjoin ℂ (genSet X))
+    (hb : b ∈ Algebra.adjoin ℂ (genSet X)) (hab : a * b = 0) : a = 0 ∨ b = 0 := by
+  obtain ⟨-, -, -, -, -, h6⟩ := WLight.levelN_structure_package N X.L X.hL X.W X.hW
+    X.fricke X.hfricke X.jf X.hjf
+  exact h6 a b ha hb hab
+
+theorem ev_prod_ne_zero {ι : Type*} (s : Finset ι) (Q : ι → MvPolynomial (Idx N) (kN N))
+    (hQ : ∀ i ∈ s, ev X (Q i) ≠ 0) : ev X (∏ i ∈ s, Q i) ≠ 0 := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => simp [ev]
+  | insert a s ha ih =>
+      rw [Finset.prod_insert ha]
+      intro h0
+      have h0' : ev X (Q a) * ev X (∏ i ∈ s, Q i) = 0 := by
+        rw [← h0]; simp [ev, map_mul]
+      rcases adjoin_isDomain X (ev_mem_adjoin X _) (ev_mem_adjoin X _) h0' with h | h
+      · exact hQ a (Finset.mem_insert_self a s) h
+      · exact ih (fun i hi => hQ i (Finset.mem_insert_of_mem hi)) h
+
+end Fricke
+
+section Descent
+
+variable {N : ℕ} [NeZero N] (X : FD N)
+
+local notation "Δ" => ModularForm.discriminant
+
+theorem smul_eq_coe_smul (K : IntermediateField ℚ ℂ) (κ : K) (f : ℍ → ℂ) :
+    κ • f = (κ : ℂ) • f := rfl
+
+theorem exists_rat_combination (K : IntermediateField ℚ ℂ) {n M : ℕ} {Gi : Fin n → ℍ → ℂ}
+    {G : ℍ → ℂ} (hGi : ∀ i, RatAt N K M (Gi i)) (hG : RatAt N K M G)
+    (hmem : G ∈ Submodule.span ℂ (Set.range Gi)) :
+    ∃ κ : Fin n → K, G = ∑ i, (κ i : ℂ) • Gi i := by
+  classical
+  by_cases hW : G ∈ Submodule.span K (Set.range Gi)
+  · obtain ⟨c, hc⟩ := (Submodule.mem_span_range_iff_exists_fun K).mp hW
+    exact ⟨c, by rw [← hc]; rfl⟩
+  exfalso
+  obtain ⟨b, hb_sub, hb_span, hb_ind⟩ := exists_linearIndependent K (Set.range Gi)
+  have hbfin : b.Finite := (Set.finite_range Gi).subset hb_sub
+  have hGb : G ∉ b := fun h => hW (hb_span ▸ Submodule.subset_span h)
+  have hGspan : G ∉ Submodule.span K b := by rwa [hb_span]
+  have hins : LinearIndepOn K id (insert G b) := LinearIndepOn.id_insert hb_ind hGspan
+  set sF : Finset (ℍ → ℂ) := (hbfin.insert G).toFinset with hsF
+  have hcoe : (↑sF : Set (ℍ → ℂ)) = insert G b := Set.Finite.coe_toFinset _
+  have hdata : ∀ f ∈ sF, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f ∧
+      Function.Periodic ((f * ModularForm.discriminant ^ M) ∘ UpperHalfPlane.ofComplex) N ∧
+      IsBoundedAtImInfty (f * ModularForm.discriminant ^ M) ∧
+      ∀ n : ℕ, (UpperHalfPlane.qExpansion N (f * ModularForm.discriminant ^ M)).coeff n ∈ K := by
+    intro f hf
+    have hf' : f ∈ insert G b := by rwa [← hcoe, Finset.mem_coe]
+    rcases hf' with rfl | hf'
+    · exact ⟨hG.mdiff, hG.periodic, hG.bdd, hG.mem⟩
+    · obtain ⟨i, rfl⟩ := hb_sub hf'
+      exact ⟨(hGi i).mdiff, (hGi i).periodic, (hGi i).bdd, (hGi i).mem⟩
+  have hind : LinearIndependent K (fun w : ↥(↑sF : Set (ℍ → ℂ)) => (w : ℍ → ℂ)) := by
+    rw [hcoe]; exact hins
+  have hC := WLight.linearIndependent_complex_of_qExpansion_rational N K sF M hdata hind
+  rw [hcoe] at hC
+  have hC' : LinearIndepOn ℂ id (insert G b) := hC
+  have hnot := hC'.notMem_span_of_insert hGb
+  rw [Set.image_id] at hnot
+  apply hnot
+  have hle : Submodule.span ℂ (Set.range Gi) ≤ Submodule.span ℂ b := by
+    rw [Submodule.span_le]
+    intro x hx
+    have hxK : x ∈ Submodule.span K b := by rw [hb_span]; exact Submodule.subset_span hx
+    exact Submodule.span_subset_span K ℂ b hxK
+  exact hle hmem
+
+theorem exists_ev_of_mem_adjoin {x : ℍ → ℂ} (hx : x ∈ Algebra.adjoin (kN N) (genSet X)) :
+    ∃ R : MvPolynomial (Idx N) (kN N), ev X R = x := by
+  classical
+  rw [Algebra.adjoin_eq_range] at hx
+  obtain ⟨R₀, rfl⟩ := hx
+  have hsec : ∀ y : genSet X, ∃ o : Idx N, gen X o = y := by
+    rintro ⟨y, hy⟩
+    rcases hy with rfl | ⟨v, hv, rfl⟩
+    · exact ⟨none, rfl⟩
+    · exact ⟨some ⟨v, hv⟩, rfl⟩
+  choose sec hsec using hsec
+  refine ⟨MvPolynomial.rename sec R₀, ?_⟩
+  rw [ev, MvPolynomial.aeval_map_algebraMap, MvPolynomial.aeval_rename]
+  have : (gen X ∘ sec) = Subtype.val := funext hsec
+  rw [this]
+  rfl
+
+omit [NeZero N] in
+theorem coeff_map_mem (R : MvPolynomial (Idx N) (kN N)) (m : Idx N →₀ ℕ) :
+    (MvPolynomial.map (algebraMap (kN N) ℂ) R).coeff m ∈ kN N := by
+  rw [MvPolynomial.coeff_map]; exact (R.coeff m).2
+
+theorem descent {m : ℕ} {G : ℍ → ℂ} (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (hinv : ∀ g ∈ CongruenceSubgroup.Gamma N, ∀ τ : ℍ, G (g • τ) = G τ)
+    (hpb : ∀ α : SL(2, ℤ), IsBoundedAtImInfty (cw G α * Δ ^ m))
+    (hrat : RatAt N (kN N) m G) :
+    ∃ P Q : MvPolynomial (Idx N) (kN N), ev X Q ≠ 0 ∧ G * ev X Q = ev X P := by
+  classical
+  set S : Set (ℍ → ℂ) := {F | ∃ α : SL(2, ℤ), F = cw G α} with hS
+  have hGS : G ∈ S := ⟨1, (cw_one G).symm⟩
+  have hhol : ∀ F ∈ S, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F := by
+    rintro F ⟨α, rfl⟩; exact mdifferentiable_cw hG α
+  have hpb' : ∀ F ∈ S, ∃ m : ℕ, IsBoundedAtImInfty (F * ModularForm.discriminant ^ m) := by
+    rintro F ⟨α, rfl⟩; exact ⟨m, hpb α⟩
+  have hst : ∀ γ : SL(2, ℤ), ∀ F ∈ S, (F ∘ (γ • ·)) ∈ S := by
+    rintro γ F ⟨α, rfl⟩
+    exact ⟨α * γ, by rw [cw_mul]; rfl⟩
+  have hinvS : ∀ F ∈ S, ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : ℍ, F (γ • τ) = F τ := by
+    rintro F ⟨α, rfl⟩ γ hγ τ
+    simp only [cw_apply]
+    have : α • γ • τ = (α * γ * α⁻¹) • α • τ := by
+      simp only [mul_smul, inv_smul_smul]
+    rw [this]
+    exact hinv _ (conj_mem_Gamma N α hγ) _
+  obtain ⟨a, b, ha, hb, hb0, hGb⟩ := WLight.exists_levelFraction_of_stable_family N X.L X.hL
+    X.W X.hW X.fricke X.hfricke X.jf X.hjf S hhol hpb' hst hinvS hGS
+  have hpbG : ∀ γ : SL(2, ℤ), ∃ m : ℕ, IsBoundedAtImInfty ((G ∘ (γ • ·)) * ModularForm.discriminant
+    ^ m) :=
+    fun γ => ⟨m, hpb γ⟩
+  obtain ⟨d, p, hprel⟩ := WLight.exists_monicRel_j_of_mdifferentiable_levelFraction N X.L X.hL
+    X.W X.hW X.fricke X.hfricke X.jf X.hjf ha hb hb0 hG hGb hpbG
+  obtain ⟨n, lam, Gi, Pi, Qi, di, pi, hGsum, hGimd, hPQ, hpiK, hGirel⟩ :=
+    WLight.frickeFunction_intBaseChange N X.L X.hL X.W X.hW X.fricke
+      X.hfricke X.jf X.hjf hG ha hb hb0 hGb p hprel
+  have hPi : ∀ i, ∃ R : MvPolynomial (Idx N) (kN N), ev X R = Pi i := fun i =>
+    exists_ev_of_mem_adjoin X (hPQ i).1
+  have hQi : ∀ i, ∃ R : MvPolynomial (Idx N) (kN N), ev X R = Qi i := fun i =>
+    exists_ev_of_mem_adjoin X (hPQ i).2.1
+  choose Ph hPh using hPi
+  choose Qh hQh using hQi
+  have hrati : ∀ i, ∃ mi : ℕ, RatAt N (kN N) mi (Gi i) := by
+    intro i
+    obtain ⟨mi, h1, h2, h3⟩ := WLight.exists_qExpansion_coeff_mem_of_mdifferentiable_levelFraction N
+      X.L X.hL X.W X.hW X.fricke X.hfricke X.jf X.hjf (kN N) rfl
+      (hGimd i) (MvPolynomial.map (algebraMap (kN N) ℂ) (Ph i))
+      (MvPolynomial.map (algebraMap (kN N) ℂ) (Qh i)) (coeff_map_mem _) (coeff_map_mem _)
+      (by
+        have := (hPQ i).2.2.1
+        rwa [← hQh i] at this)
+      (by
+        have := (hPQ i).2.2.2
+        rw [← hQh i, ← hPh i] at this
+        exact this)
+      ⟨di i, pi i, hpiK i, hGirel i⟩
+    exact ⟨mi, (hGimd i), h1, h2, h3⟩
+  choose mi hmi using hrati
+  set M : ℕ := m + ∑ i, mi i with hM
+  have hGM : RatAt N (kN N) M G := hrat.of_le (Nat.le_add_right _ _)
+  have hGiM : ∀ i, RatAt N (kN N) M (Gi i) := fun i =>
+    (hmi i).of_le (le_trans (Finset.single_le_sum (fun j _ => Nat.zero_le (mi j)) (Finset.mem_univ
+      i))
+      (Nat.le_add_left _ _))
+  have hmem : G ∈ Submodule.span ℂ (Set.range Gi) := by
+    rw [hGsum]
+    exact Submodule.sum_mem _ fun i _ => Submodule.smul_mem _ _ (Submodule.subset_span ⟨i, rfl⟩)
+  obtain ⟨κ, hκ⟩ := exists_rat_combination (kN N) hGiM hGM hmem
+  refine ⟨∑ i, MvPolynomial.C (κ i) * Ph i * ∏ j ∈ Finset.univ.erase i, Qh j, ∏ i, Qh i, ?_, ?_⟩
+  · exact ev_prod_ne_zero X Finset.univ Qh fun i _ => by rw [hQh i]; exact (hPQ i).2.2.1
+  · have hev_prod : ∀ (s : Finset (Fin n)), ev X (∏ j ∈ s, Qh j) = ∏ j ∈ s, Qi j := by
+      intro s; simp only [ev, map_prod]; exact Finset.prod_congr rfl fun j _ => hQh j
+    rw [hκ, hev_prod, Finset.sum_mul]
+    simp only [ev, map_sum, map_mul, MvPolynomial.map_C, MvPolynomial.aeval_C, map_prod]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    have h1 : (MvPolynomial.aeval (gen X)) (MvPolynomial.map (algebraMap (kN N) ℂ) (Ph i)) = Pi i :=
+      hPh i
+    have h2 : ∀ j, (MvPolynomial.aeval (gen X)) (MvPolynomial.map (algebraMap (kN N) ℂ) (Qh j)) = Qi
+      j :=
+      hQh
+    simp only [h1, h2]
+    rw [← Finset.mul_prod_erase Finset.univ Qi (Finset.mem_univ i), ← (hPQ i).2.2.2]
+    simp only [Algebra.algebraMap_eq_smul_one, smul_mul_assoc, one_mul]
+    rw [smul_one_smul, mul_assoc]
+    rfl
+
+end Descent
+
+theorem main (N : ℕ) [NeZero N] (X : FD N) (K : IntermediateField ℚ ℂ) (hK : K = kN N)
+    (m : ℕ) (G : ℍ → ℂ) (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (hinv : ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : ℍ, G (γ • τ) = G τ)
+    (hbd : ∀ α : SL(2, ℤ), IsBoundedAtImInfty ((fun τ : ℍ => G (α • τ)) * ModularForm.discriminant ^
+      m))
+    (hcoeff : ∀ n : ℕ, (qExpansion N (G * ModularForm.discriminant ^ m)).coeff n ∈ K) :
+    ∃ P Q : MvPolynomial (Idx N) K,
+      MvPolynomial.aeval (fun o : Idx N => o.elim X.jf fun v => X.fricke v.1) (Q.map (algebraMap K
+        ℂ)) ≠ 0 ∧
+      G * MvPolynomial.aeval (fun o : Idx N => o.elim X.jf fun v => X.fricke v.1) (Q.map (algebraMap
+        K ℂ)) =
+        MvPolynomial.aeval (fun o : Idx N => o.elim X.jf fun v => X.fricke v.1) (P.map (algebraMap K
+          ℂ)) := by
+  subst hK
+  have hT : ModularGroup.T ^ (N : ℤ) ∈ CongruenceSubgroup.Gamma N := by
+    rw [Gamma_mem, ModularGroup.coe_T_zpow]
+    simp
+  have hperG : Periodic (G ∘ ofComplex) N := by
+    intro w
+    by_cases hw : 0 < im w
+    · have this : 0 < im (w + N) := by simp [hw]
+      simp only [comp_apply, ofComplex_apply_of_im_pos this, ofComplex_apply_of_im_pos hw]
+      have := hinv _ hT ⟨w, hw⟩
+      convert this using 2
+      ext
+      rw [UpperHalfPlane.modular_T_zpow_smul]
+      simp [add_comm, UpperHalfPlane.coe_vadd]
+    · push Not at hw
+      have : im (w + N) ≤ 0 := by simpa using hw
+      simp [ofComplex_apply_of_im_nonpos this, ofComplex_apply_of_im_nonpos hw]
+  have hrat : RatAt N (kN N) m G :=
+    { mdiff := hG
+      periodic := periodic_mul hperG (periodic_pow (periodic_ofComplex_natCast periodic_disc_one N)
+        m)
+      bdd := by simpa [cw] using hbd 1
+      mem := hcoeff }
+  obtain ⟨P, Q, hQ, hGQ⟩ := descent X hG hinv (fun α => hbd α) hrat
+  exact ⟨P, Q, hQ, hGQ⟩
+
+end GammaNDescent
+
+end
+
+open scoped MatrixGroups Manifold in
+theorem solution
+    (N : ℕ) [NeZero N]
+    (L : UpperHalfPlane → PeriodPair)
+    (hL : ∀ τ : UpperHalfPlane, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → UpperHalfPlane → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : UpperHalfPlane), W v τ =
+      ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+        PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → UpperHalfPlane → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : UpperHalfPlane), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (jf : UpperHalfPlane → ℂ)
+    (hjf : ∀ τ : UpperHalfPlane, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    (K : IntermediateField ℚ ℂ)
+    (hK : K = IntermediateField.adjoin ℚ
+      {Complex.exp (2 * (Real.pi : ℂ) * Complex.I / (N : ℂ))})
+    (m : ℕ) (G : UpperHalfPlane → ℂ) (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (hinv : ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : UpperHalfPlane, G (γ • τ) = G τ)
+    (hbd : ∀ α : SL(2, ℤ), UpperHalfPlane.IsBoundedAtImInfty
+      ((fun τ : UpperHalfPlane => G (α • τ)) * ModularForm.discriminant ^ m))
+    (hcoeff : ∀ n : ℕ,
+      (UpperHalfPlane.qExpansion N (G * ModularForm.discriminant ^ m)).coeff n ∈ K) :
+    ∃ P Q : MvPolynomial (Option {v : Fin 2 → ZMod N // v ≠ 0}) ↥K,
+      MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+        o.elim jf fun v => fricke v.1) (Q.map (algebraMap ↥K ℂ)) ≠ 0 ∧
+      G * MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+          o.elim jf fun v => fricke v.1) (Q.map (algebraMap ↥K ℂ)) =
+        MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+          o.elim jf fun v => fricke v.1) (P.map (algebraMap ↥K ℂ)) :=
+  GammaNDescent.main N ⟨L, hL, W, hW, fricke, hfricke, jf, hjf⟩ K hK m G hG hinv hbd hcoeff
+
+end S_ModularCurve_exists_mvPolynomial_mul_aeval_fricke_eq_of_qExpansion_coeff_mem
+end P2MW
+export P2MW.S_ModularCurve_exists_mvPolynomial_mul_aeval_fricke_eq_of_qExpansion_coeff_mem
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups Manifold in
+theorem ModularCurve.exists_mvPolynomial_mul_aeval_fricke_eq_of_qExpansion_coeff_mem
+    (N : ℕ) [NeZero N]
+    (L : UpperHalfPlane → PeriodPair)
+    (hL : ∀ τ : UpperHalfPlane, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → UpperHalfPlane → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : UpperHalfPlane), W v τ =
+      ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+        PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → UpperHalfPlane → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : UpperHalfPlane), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (jf : UpperHalfPlane → ℂ)
+    (hjf : ∀ τ : UpperHalfPlane, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    (K : IntermediateField ℚ ℂ)
+    (hK : K = IntermediateField.adjoin ℚ
+      {Complex.exp (2 * (Real.pi : ℂ) * Complex.I / (N : ℂ))})
+    (m : ℕ) (G : UpperHalfPlane → ℂ) (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (hinv : ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : UpperHalfPlane, G (γ • τ) = G τ)
+    (hbd : ∀ α : SL(2, ℤ), UpperHalfPlane.IsBoundedAtImInfty
+      ((fun τ : UpperHalfPlane => G (α • τ)) * ModularForm.discriminant ^ m))
+    (hcoeff : ∀ n : ℕ,
+      (UpperHalfPlane.qExpansion N (G * ModularForm.discriminant ^ m)).coeff n ∈ K) :
+    ∃ P Q : MvPolynomial (Option {v : Fin 2 → ZMod N // v ≠ 0}) ↥K,
+      MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+        o.elim jf fun v => fricke v.1) (Q.map (algebraMap ↥K ℂ)) ≠ 0 ∧
+      G * MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+          o.elim jf fun v => fricke v.1) (Q.map (algebraMap ↥K ℂ)) =
+        MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+          o.elim jf fun v => fricke v.1) (P.map (algebraMap ↥K ℂ)) :=
+  solution N L hL W hW fricke hfricke jf hjf K hK m G hG hinv hbd hcoeff
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_natCard_quot_samePlace_eq_natCard_quot_sameOrbit_of_EMD.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_natCard_quot_samePlace_eq_natCard_quot_sameOrbit_of_EMD.lean
new file mode 100644
index 0000000000..930fe14fc4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_natCard_quot_samePlace_eq_natCard_quot_sameOrbit_of_EMD.lean
@@ -0,0 +1,96 @@
+/-
+Based on Prove2Me node ModularCurve.exists_natCard_quot_samePlace_eq_natCard_quot_sameOrbit_of_EMD
+(0a563c37-7a87-58af-8b6c-686de94c8c62) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission de6f1cf3-b152-5a7d-9b8b-7b1df2142275
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EMD
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Class counts agree under the embedding–moduli dictionary at j₀
+
+Theorem statement: `ModularCurve.exists_natCard_quot_samePlace_eq_natCard_quot_sameOrbit_of_EMD`
+(`0a563c37-7a87-58af-8b6c-686de94c8c62`), by Claude, 2026-09-05.
+
+Proof: submission `de6f1cf3-b152-5a7d-9b8b-7b1df2142275`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and let $j_0 \in \overline{\mathbb{Q}}$, and assume the
+predicate [`ModularCurve.EMD N j₀`](def/ModularCurve_EMD.html#L46), i.e. that there is a Weierstrass
+curve $E_0$ over $\overline{\mathbb{Q}}$ which is elliptic, has $j$-invariant $j_0$, and admits a
+bijection $\Phi$ from [`ModularCurve.Emb N j₀`](def/ModularCurve_EMD.html#L22) onto
+[`ModularCurve.CycSub E₀ N`](def/ModularCurve_EMD.html#L36) such that two embeddings satisfy
+[`ModularCurve.SamePlace`](def/ModularCurve_EMD.html#L31) exactly when their images satisfy
+[`ModularCurve.SameOrbit`](def/ModularCurve_EMD.html#L40). Here `Emb N j₀` consists of the
+$\overline{\mathbb{Q}}$-algebra homomorphisms $\psi$ from the base-changed modular function field
+`modularFunctionFieldBar N` into the Hahn series
+$\mathrm{HahnSeries}\,\mathbb{Q}\,\overline{\mathbb{Q}}$ normalised by $\psi(\bar\jmath) = j_0 + t$;
+`SamePlace ψ ψ'` asserts the existence of one place $w$ of the field (a valuation subring, proper,
+containing the constants, a principal ideal ring) which both $\psi$ and $\psi'$ induce, in the sense
+that for each of them some positive rational $g$ satisfies $w.\mathrm{ord}(x)\cdot g =
+\mathrm{order}(\psi x)$ for all $x$; `CycSub E₀ N` consists of the additive subgroups of the affine
+point group of $E_0$ of the form $\mathbb{Z}g$ with $g$ of additive order $N$; and `SameOrbit E₀ H
+H'` asserts that $H = \mathbb{Z}g$, $H' = \mathbb{Z}g'$ with $g'$ the image of $g$ under
+`Point.vcInvFun` for some variable change $\gamma$ fixing $E_0$. The conclusion asserts the
+existence of an elliptic Weierstrass curve $E_0$ over $\overline{\mathbb{Q}}$ with $j(E_0) = j_0$
+for which the quotient of `Emb N j₀` by the relation `SamePlace` and the quotient of `CycSub E₀ N`
+by the relation `SameOrbit` have equal `Nat.card`.
+
+This is the numerical consequence extracted from the embedding–moduli dictionary at a fixed
+$j$-invariant: the moduli interpretation of level-$N$ structures identifies normalised embeddings of
+the modular function field modulo the place they induce with cyclic subgroups of order $N$ on an
+elliptic curve with that $j$-invariant, modulo the automorphisms of the curve. It is used by
+[`ModularCurve.card_eq_natCard_moduliPoint_j_eq_of_EMD`]
+(thm.html#ModularCurve.card_eq_natCard_moduliPoint_j_eq_of_EMD)
+to count the points of the modular curve lying over a given $j$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_natCard_quot_samePlace_eq_natCard_quot_sameOrbit_of_EMD.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_natCard_quot_samePlace_eq_natCard_quot_sameOrbit_of_EMD
+
+theorem solution (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ) (hEMD : ModularCurve.EMD N j₀) :
+    ∃ (E₀ : WeierstrassCurve (AlgebraicClosure ℚ)) (_ : E₀.IsElliptic), E₀.j = j₀ ∧
+      Nat.card (Quot (fun ψ ψ' : ModularCurve.Emb N j₀ => ModularCurve.SamePlace ψ.1 ψ'.1))
+        = Nat.card (Quot (fun H H' : ModularCurve.CycSub E₀ N => ModularCurve.SameOrbit E₀ H.1
+          H'.1)) := by
+  obtain ⟨E₀, hE₀, hj, Φ, hΦ⟩ := hEMD
+  exact ⟨E₀, hE₀, hj, Nat.card_congr (Quot.congr Φ (fun ψ ψ' => hΦ ψ ψ'))⟩
+
+end S_ModularCurve_exists_natCard_quot_samePlace_eq_natCard_quot_sameOrbit_of_EMD
+end P2MW
+export P2MW.S_ModularCurve_exists_natCard_quot_samePlace_eq_natCard_quot_sameOrbit_of_EMD (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.exists_natCard_quot_samePlace_eq_natCard_quot_sameOrbit_of_EMD (N : ℕ)
+    [NeZero N]
+    (j₀ : AlgebraicClosure ℚ) (hEMD : ModularCurve.EMD N j₀) :
+    ∃ (E₀ : WeierstrassCurve (AlgebraicClosure ℚ)) (_ : E₀.IsElliptic), E₀.j = j₀ ∧
+      Nat.card (Quot (fun ψ ψ' : ModularCurve.Emb N j₀ => ModularCurve.SamePlace ψ.1 ψ'.1))
+        = Nat.card (Quot (fun H H' : ModularCurve.CycSub E₀ N => ModularCurve.SameOrbit E₀ H.1
+          H'.1)) :=
+  solution N j₀ hEMD
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_ne_zero_forall_intCast_mul_qExpansion_coeff_of_gamma_invariant.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_ne_zero_forall_intCast_mul_qExpansion_coeff_of_gamma_invariant.lean
new file mode 100644
index 0000000000..a1c185a280
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_ne_zero_forall_intCast_mul_qExpansion_coeff_of_gamma_invariant.lean
@@ -0,0 +1,1475 @@
+/-
+Based on Prove2Me node
+ModularCurve.exists_ne_zero_forall_intCast_mul_qExpansion_coeff_of_gamma_invariant
+(8697798b-0a6c-5d34-8d44-8c488094cc1d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission aa1ea372-f0ac-5d2f-9a08-e32b1a5639c5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+
+import Mathlib.NumberTheory.Cyclotomic.Gal
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_mvPolynomial_mul_aeval_fricke_eq_of_qExpansion_coeff_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_ne_zero_forall_mul_qExpansion_coeff_fricke_mem_adjoin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PowerSeries_mem_range_map_of_monic_of_mul_mem_range
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_exists_monicRel_j_K_of_mdifferentiable_frickeQuotient
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_modularity_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_linearIndependent_complex_of_qExpansion_rational
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Bounded denominators for rational q-expansions of level N
+
+Theorem statement:
+`ModularCurve.exists_ne_zero_forall_intCast_mul_qExpansion_coeff_of_gamma_invariant`
+(`8697798b-0a6c-5d34-8d44-8c488094cc1d`), by Claude, 2026-09-05.
+
+Proof: submission `aa1ea372-f0ac-5d2f-9a08-e32b1a5639c5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a positive integer, $m$ a natural number, and let $G\colon \mathfrak H \to \mathbb C$ be
+a function on the upper half-plane that is holomorphic in the sense of being `MDifferentiable` for
+the standard complex-manifold charts on $\mathfrak H$ and on $\mathbb C$. Assume: (i) $G$ is
+invariant under the principal congruence subgroup, i.e. $G(\gamma \cdot \tau) = G(\tau)$ for every
+$\gamma$ in `CongruenceSubgroup.Gamma N` and every $\tau \in \mathfrak H$; (ii) for every $\alpha
+\in \mathrm{SL}_2(\mathbb Z)$ the product of $\tau \mapsto G(\alpha \cdot \tau)$ with the $m$-th
+power of the discriminant cusp form `ModularForm.discriminant` is bounded as $\operatorname{Im}\tau
+\to \infty$ (`UpperHalfPlane.IsBoundedAtImInfty`); and (iii) every coefficient of the level-$N$
+$q$-expansion `UpperHalfPlane.qExpansion N` of $G \cdot \Delta^m$, i.e. the expansion in $q_N =
+e^{2\pi i \tau / N}$, is the image in $\mathbb C$ of a rational number. The conclusion is that these
+coefficients have bounded denominators: there exists a nonzero integer $D$ such that for every $n
+\in \mathbb N$ the product of $D$ with the $n$-th coefficient of the $q$-expansion of $G \cdot
+\Delta^m$ is the image in $\mathbb C$ of some integer.
+
+This is the bounded-denominator assertion of the classical theory of the modular function field of
+level $N$ (the relevant clause of Shimura's Theorem 3.52), here in the form applying to weight-zero
+quotients $G = F/\Delta^m$ for $\Gamma(N)$. It feeds
+[`ModularCurve.exists_isIntegralQExp_smul_of_ratCast_qExpansion`]
+(thm.html#ModularCurve.exists_isIntegralQExp_smul_of_ratCast_qExpansion),
+where a rational $q$-expansion is rescaled to an integral one.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_ne_zero_forall_intCast_mul_qExpansion_coeff_of_gamma_invariant.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_ModularCurve_exists_ne_zero_forall_intCast_mul_qExpansion_coeff_of_gamma_invariant
+
+noncomputable section
+
+open Complex UpperHalfPlane ModularForm CongruenceSubgroup Function
+open scoped Real Manifold MatrixGroups ModularForm Topology
+
+namespace GammaNBounded
+
+def tauPair (τ : ℍ) : PeriodPair where
+  ω₁ := (τ : ℂ)
+  ω₂ := 1
+  indep := by
+    rw [LinearIndependent.pair_iff]
+    intro s t h
+    have h1 := congrArg Complex.im h
+    have h2 := congrArg Complex.re h
+    simp at h1 h2
+    have hs : s = 0 := by grind [τ.im_pos]
+    grind
+
+theorem tauPair_spec (τ : ℍ) : (tauPair τ).ω₁ = (τ : ℂ) ∧ (tauPair τ).ω₂ = 1 := ⟨rfl, rfl⟩
+
+variable (N : ℕ)
+
+def WW (v : Fin 2 → ZMod N) (τ : ℍ) : ℂ :=
+  ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+    PeriodPair.weierstrassP (tauPair τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ))
+
+def fricke (v : Fin 2 → ZMod N) (τ : ℍ) : ℂ :=
+  -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * WW N v τ
+
+def jf (τ : ℍ) : ℂ := ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ
+
+theorem WW_spec (v : Fin 2 → ZMod N) (τ : ℍ) : WW N v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+    PeriodPair.weierstrassP (tauPair τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)) :=
+  rfl
+
+theorem fricke_spec (v : Fin 2 → ZMod N) (τ : ℍ) : fricke N v τ =
+    -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * WW N v τ := rfl
+
+theorem jf_spec (τ : ℍ) : jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ := rfl
+
+def zetaN : ℂ := Complex.exp (2 * (Real.pi : ℂ) * Complex.I / (N : ℂ))
+
+def kN : IntermediateField ℚ ℂ := IntermediateField.adjoin ℚ {zetaN N}
+
+def AZ : Subalgebra ℤ ℂ := Algebra.adjoin ℤ {zetaN N}
+
+abbrev Idx : Type := Option {v : Fin 2 → ZMod N // v ≠ 0}
+
+def gen : Idx N → ℍ → ℂ := fun o => o.elim jf fun v => fricke N v.1
+
+def ev (R : MvPolynomial (Idx N) (kN N)) : ℍ → ℂ :=
+  MvPolynomial.aeval (gen N) (MvPolynomial.map (algebraMap (kN N) ℂ) R)
+
+section Cyclo
+
+variable [NeZero N]
+
+theorem isPrimitiveRoot_zetaN : IsPrimitiveRoot (zetaN N) N :=
+  Complex.isPrimitiveRoot_exp N (NeZero.ne N)
+
+scoped instance instIsCyclotomic : IsCyclotomicExtension {N} ℚ (kN N) := by
+  have hζ := isPrimitiveRoot_zetaN N
+  change IsCyclotomicExtension {N} ℚ (IntermediateField.adjoin ℚ {zetaN N}).toSubalgebra
+  rw [IntermediateField.adjoin_simple_toSubalgebra_of_isAlgebraic
+    (hζ.isIntegral (NeZero.pos N)).tower_top.isAlgebraic]
+  exact hζ.adjoin_isCyclotomicExtension ℚ
+
+scoped instance instIsGalois : IsGalois ℚ (kN N) := IsCyclotomicExtension.isGalois {N} ℚ (kN N)
+
+scoped instance instFiniteDimensional : FiniteDimensional ℚ (kN N) :=
+  IsCyclotomicExtension.finiteDimensional {N} ℚ (kN N)
+
+scoped instance instFintypeAut : Fintype ((kN N) ≃ₐ[ℚ] (kN N)) := AlgEquiv.fintype ℚ (kN N)
+
+def zetaK : kN N := ⟨zetaN N, IntermediateField.subset_adjoin ℚ _ (Set.mem_singleton _)⟩
+
+omit [NeZero N] in
+@[scoped simp] theorem coe_zetaK : ((zetaK N : kN N) : ℂ) = zetaN N := rfl
+
+theorem isPrimitiveRoot_zetaK : IsPrimitiveRoot (zetaK N) N := by
+  have h := isPrimitiveRoot_zetaN N
+  rw [← coe_zetaK] at h
+  exact IsPrimitiveRoot.coe_submonoidClass_iff.mp h
+
+theorem exists_pow_of_aut (σ : (kN N) ≃ₐ[ℚ] (kN N)) : ∃ s : ℕ, σ (zetaK N) = zetaK N ^ s := by
+  have hμ := isPrimitiveRoot_zetaK N
+  exact ⟨((hμ.autToPow ℚ σ : (ZMod N)ˣ) : ZMod N).val, by rw [hμ.autToPow_spec ℚ σ]⟩
+
+theorem exists_rat_of_fixed (x : kN N) (hx : ∀ σ : (kN N) ≃ₐ[ℚ] (kN N), σ x = x) :
+    ∃ r : ℚ, x = algebraMap ℚ (kN N) r := by
+  have := (IsGalois.mem_bot_iff_fixed x).2 hx
+  grind [IntermediateField.mem_bot]
+
+theorem ratCast_mem (K : IntermediateField ℚ ℂ) (r : ℚ) : ((r : ℂ)) ∈ K := by
+  have : (r : ℂ) = algebraMap ℚ ℂ r := rfl
+  rw [this]; exact K.algebraMap_mem r
+
+omit [NeZero N] in
+theorem mem_AZ_iff (x : ℂ) : x ∈ AZ N ↔ ∃ p : Polynomial ℤ, x = Polynomial.aeval (zetaN N) p := by
+  rw [AZ, Algebra.adjoin_singleton_eq_range_aeval]
+  constructor
+  · rintro ⟨p, hp⟩; exact ⟨p, hp.symm⟩
+  · rintro ⟨p, hp⟩; exact ⟨p, hp.symm⟩
+
+omit [NeZero N] in
+theorem zetaN_mem_AZ : zetaN N ∈ AZ N := Algebra.subset_adjoin (Set.mem_singleton _)
+
+omit [NeZero N] in
+theorem AZ_le_kN : ∀ x ∈ AZ N, x ∈ kN N := by
+  intro x hx
+  rw [mem_AZ_iff] at hx
+  obtain ⟨p, rfl⟩ := hx
+  rw [Polynomial.aeval_eq_sum_range]
+  refine sum_mem fun i _ => ?_
+  rw [zsmul_eq_mul]
+  refine mul_mem ?_ (pow_mem (IntermediateField.subset_adjoin ℚ _ (Set.mem_singleton _)) _)
+  exact_mod_cast ratCast_mem (kN N) (p.coeff i : ℚ)
+
+theorem aut_mem_AZ (σ : (kN N) ≃ₐ[ℚ] (kN N)) (x : kN N) (hx : (x : ℂ) ∈ AZ N) :
+    ((σ x : kN N) : ℂ) ∈ AZ N := by
+  rw [mem_AZ_iff] at hx
+  obtain ⟨p, hp⟩ := hx
+  obtain ⟨s, hs⟩ := exists_pow_of_aut N σ
+  rw [Polynomial.aeval_eq_sum_range] at hp
+  set y : kN N := ∑ i ∈ Finset.range (p.natDegree + 1), (p.coeff i : kN N) * zetaK N ^ i with hy
+  have hcoe : ∀ z : kN N, (z : ℂ) = algebraMap (kN N) ℂ z := fun z => rfl
+  have hyc : (y : ℂ) = ∑ i ∈ Finset.range (p.natDegree + 1), (p.coeff i : ℂ) * zetaN N ^ i := by
+    rw [hcoe, hy, map_sum]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [map_mul, map_pow, map_intCast, ← hcoe, coe_zetaK]
+  have hxK : x = y := by grind
+  have hσy : σ y = ∑ i ∈ Finset.range (p.natDegree + 1), (p.coeff i : kN N) * (zetaK N ^ s) ^ i :=
+    by
+    rw [hy, map_sum]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [map_mul, map_pow, map_intCast, hs]
+  have hσc : ((σ x : kN N) : ℂ) = ∑ i ∈ Finset.range (p.natDegree + 1), (p.coeff i : ℂ) * (zetaN N ^
+    s) ^ i :=
+    by
+    rw [hxK, hσy, hcoe, map_sum]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [map_mul, map_pow, map_pow, map_intCast, ← hcoe, coe_zetaK]
+  rw [hσc]
+  refine sum_mem fun i _ => ?_
+  refine mul_mem (by
+    exact_mod_cast (AZ N).algebraMap_mem (p.coeff i)) (pow_mem (pow_mem (zetaN_mem_AZ N) s) _)
+
+theorem exists_int_of_mem_AZ_of_rat (r : ℚ) (hr : ((r : ℂ)) ∈ AZ N) :
+    ∃ z : ℤ, (r : ℂ) = (z : ℂ) := by
+  have hint : IsIntegral ℤ ((r : ℂ)) := by
+    have hle : AZ N ≤ integralClosure ℤ ℂ := by
+      rw [AZ, Algebra.adjoin_le_iff, Set.singleton_subset_iff]
+      exact (isPrimitiveRoot_zetaN N).isIntegral (NeZero.pos N)
+    exact hle hr
+  have hint' : IsIntegral ℤ r := by
+    have hint2 : IsIntegral ℤ (algebraMap ℚ ℂ r) := hint
+    exact (isIntegral_algebraMap_iff (A := ℚ) (B := ℂ)).mp hint2
+  obtain ⟨z, hz⟩ := IsIntegrallyClosed.algebraMap_eq_of_integral hint'
+  refine ⟨z, ?_⟩
+  rw [← hz]
+  simp
+
+theorem exists_nat_mul_mem_AZ (x : ℂ) (hx : x ∈ kN N) : ∃ D : ℕ, D ≠ 0 ∧ (D : ℂ) * x ∈ AZ N := by
+  have hint : IsIntegral ℚ (zetaN N) :=
+    ((isPrimitiveRoot_zetaN N).isIntegral (NeZero.pos N)).tower_top
+  have hx' : x ∈ (Algebra.adjoin ℚ {zetaN N} : Subalgebra ℚ ℂ) := by
+    have := IntermediateField.adjoin_simple_toSubalgebra_of_isAlgebraic hint.isAlgebraic
+    rw [← this]
+    exact hx
+  rw [Algebra.adjoin_singleton_eq_range_aeval] at hx'
+  obtain ⟨p, rfl⟩ := hx'
+  refine ⟨∏ i ∈ Finset.range (p.natDegree + 1), (p.coeff i).den, ?_, ?_⟩
+  · exact Finset.prod_ne_zero_iff.mpr fun i _ => (p.coeff i).den_nz
+  · change ((∏ i ∈ Finset.range (p.natDegree + 1), (p.coeff i).den : ℕ) : ℂ) * Polynomial.aeval
+      (zetaN N) p ∈ AZ N
+    rw [Polynomial.aeval_eq_sum_range, Finset.mul_sum]
+    refine sum_mem fun i hi => ?_
+    rw [Algebra.smul_def, ← mul_assoc]
+    refine mul_mem ?_ (pow_mem (zetaN_mem_AZ N) _)
+    have hdvd : ((p.coeff i).den : ℤ) ∣ ∏ j ∈ Finset.range (p.natDegree + 1), ((p.coeff j).den : ℤ)
+      :=
+      Finset.dvd_prod_of_mem _ hi
+    obtain ⟨c, hc⟩ := hdvd
+    have hq : ((∏ j ∈ Finset.range (p.natDegree + 1), (p.coeff j).den : ℕ) : ℚ) * p.coeff i
+        = ((c * (p.coeff i).num : ℤ) : ℚ) := by
+      have h1 : ((∏ j ∈ Finset.range (p.natDegree + 1), (p.coeff j).den : ℕ) : ℚ)
+          = ((p.coeff i).den : ℚ) * (c : ℚ) := by exact_mod_cast hc
+      rw [h1, mul_comm ((p.coeff i).den : ℚ), mul_assoc, Rat.den_mul_eq_num]
+      grind
+    have : ((∏ j ∈ Finset.range (p.natDegree + 1), (p.coeff j).den : ℕ) : ℂ) * (algebraMap ℚ ℂ)
+      (p.coeff i)
+        = ((c * (p.coeff i).num : ℤ) : ℂ) := by
+      have := congrArg (algebraMap ℚ ℂ) hq
+      simpa using this
+    rw [this]
+    exact_mod_cast (AZ N).algebraMap_mem (c * (p.coeff i).num)
+
+end Cyclo
+
+section Nice
+
+variable [NeZero N]
+
+local notation "Δ" => ModularForm.discriminant
+
+theorem natCast_pos : (0 : ℝ) < (N : ℝ) := Nat.cast_pos.mpr (NeZero.pos N)
+
+def nice : Subalgebra ℂ (ℍ → ℂ) where
+  carrier := {g | MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g ∧ Periodic (g ∘ ofComplex) N ∧ IsBoundedAtImInfty g}
+  mul_mem' := by
+    rintro a b ⟨ha1, ha2, ha3⟩ ⟨hb1, hb2, hb3⟩
+    refine ⟨ha1.mul hb1, ?_, ha3.mul hb3⟩
+    intro z; have h1 := ha2 z; have h2 := hb2 z
+    simp only [comp_apply, Pi.mul_apply] at h1 h2 ⊢; rw [h1, h2]
+  add_mem' := by
+    rintro a b ⟨ha1, ha2, ha3⟩ ⟨hb1, hb2, hb3⟩
+    refine ⟨ha1.add hb1, ?_, ha3.add hb3⟩
+    intro z; have h1 := ha2 z; have h2 := hb2 z
+    simp only [comp_apply, Pi.add_apply] at h1 h2 ⊢; rw [h1, h2]
+  algebraMap_mem' c := by
+    refine ⟨mdifferentiable_const, fun z => rfl, ?_⟩
+    exact Filter.const_boundedAtFilter _ _
+
+variable {N}
+
+omit [NeZero N] in
+theorem mem_nice {g : ℍ → ℂ} :
+    g ∈ nice N ↔ MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g ∧ Periodic (g ∘ ofComplex) N ∧ IsBoundedAtImInfty g :=
+      Iff.rfl
+
+theorem analyticAt_of_mem {g : ℍ → ℂ} (hg : g ∈ nice N) : AnalyticAt ℂ (cuspFunction N g) 0 :=
+  analyticAt_cuspFunction_zero (natCast_pos N) hg.2.1 hg.1 hg.2.2
+
+variable (N) in
+def qE : nice N →ₐ[ℂ] PowerSeries ℂ where
+  toFun g := qExpansion N (g : ℍ → ℂ)
+  map_one' := qExpansion_one _
+  map_mul' a b := qExpansion_mul (analyticAt_of_mem a.2) (analyticAt_of_mem b.2)
+  map_zero' := qExpansion_zero _
+  map_add' a b := qExpansion_add (analyticAt_of_mem a.2) (analyticAt_of_mem b.2)
+  commutes' c := by
+    change qExpansion N ((algebraMap ℂ (ℍ → ℂ)) c) = PowerSeries.C c
+    have h1 : (algebraMap ℂ (ℍ → ℂ)) c = c • (1 : ℍ → ℂ) := by
+      funext τ; simp []
+    rw [h1, qExpansion_smul (analyticAt_of_mem (nice N).one_mem), qExpansion_one,
+      PowerSeries.smul_eq_C_mul,
+      mul_one]
+
+theorem qE_apply (g : nice N) : qE N g = qExpansion N (g : ℍ → ℂ) := rfl
+
+theorem qE_eq_zero_iff (g : nice N) : qE N g = 0 ↔ (g : ℍ → ℂ) = 0 :=
+  qExpansion_eq_zero_iff (natCast_pos N) g.2.2.1 g.2.1 g.2.2.2
+
+theorem mdifferentiable_disc : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (Δ : ℍ → ℂ) := by
+  rw [← CuspForm.coe_discriminant]; exact CuspForm.discriminant.holo'
+
+theorem periodic_ofComplex_natCast {g : ℍ → ℂ} (h : Periodic (g ∘ ofComplex) 1) (n : ℕ) :
+    Periodic (g ∘ ofComplex) n := by
+  simpa using h.nat_mul n
+
+omit [NeZero N] in
+theorem levelOne_mem {k : ℤ} (f : ModularForm 𝒮ℒ k) : (⇑f : ℍ → ℂ) ∈ nice N :=
+  ⟨f.holo', periodic_ofComplex_natCast (SlashInvariantFormClass.periodic_comp_ofComplex f
+    one_mem_strictPeriods_SL) N, ModularFormClass.bdd_at_infty f⟩
+
+omit [NeZero N] in
+theorem disc_mem : (Δ : ℍ → ℂ) ∈ nice N := by
+  have := levelOne_mem (N := N) (CuspForm.discriminant : ModularForm 𝒮ℒ 12)
+  exact this
+
+def dN : nice N := ⟨Δ, disc_mem⟩
+
+omit [NeZero N] in
+@[scoped simp] theorem coe_dN : ((dN : nice N) : ℍ → ℂ) = Δ := rfl
+
+def E4cube : ModularForm 𝒮ℒ 12 := (E₄.pow 3).mcast (by norm_num)
+
+theorem coe_E4cube : (⇑E4cube : ℍ → ℂ) = (E₄ : ℍ → ℂ) ^ 3 := by
+  rw [E4cube, coe_mcast, coe_pow]
+
+theorem jf_mul_disc : jf * Δ = ⇑E4cube := by
+  funext τ
+  rw [coe_E4cube]
+  simp only [Pi.mul_apply, Pi.pow_apply, jf]
+  field_simp [discriminant_ne_zero τ]
+
+omit [NeZero N] in
+theorem jf_disc_mem : jf * Δ ∈ nice N := by rw [jf_mul_disc]; exact levelOne_mem _
+
+theorem fricke_disc_mem {v : Fin 2 → ZMod N} (hv : v ≠ 0) : fricke N v * Δ ∈ nice N := by
+  obtain ⟨-, -, h3, h4, h5, -⟩ := WLight.frickeFunction_modularity_package N tauPair tauPair_spec
+  exact ⟨(h3 v hv).mul mdifferentiable_disc, (h5 v hv).1, h4 v hv⟩
+
+theorem mdifferentiable_fricke {v : Fin 2 → ZMod N} (hv : v ≠ 0) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fricke N v) := by
+  obtain ⟨-, -, h3, -⟩ := WLight.frickeFunction_modularity_package N tauPair tauPair_spec
+  exact h3 v hv
+
+theorem gen_disc_mem (o : Idx N) : gen N o * Δ ∈ nice N := by
+  cases o with
+  | none => exact jf_disc_mem
+  | some v => exact fricke_disc_mem v.2
+
+theorem mdifferentiable_gen (o : Idx N) : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (gen N o) := by
+  cases o with
+  | none =>
+      intro τ
+      have h1 : MDifferentiableAt 𝓘(ℂ) 𝓘(ℂ) (fun τ => E₄ τ ^ 3) τ := (E₄.holo' τ).pow 3
+      exact h1.div (mdifferentiable_disc τ) (discriminant_ne_zero τ)
+  | some v => exact mdifferentiable_fricke v.2
+
+end Nice
+
+section Bdd
+
+variable [NeZero N]
+
+def IsRat (φ : PowerSeries ℂ) : Prop := ∃ p : PowerSeries ℚ, p.map (algebraMap ℚ ℂ) = φ
+
+def BddA (φ : PowerSeries ℂ) : Prop := ∃ D : ℕ, D ≠ 0 ∧ ∀ n, (D : ℂ) * φ.coeff n ∈ AZ N
+
+variable {N}
+
+theorem isRat_iff {φ : PowerSeries ℂ} : IsRat φ ↔ ∀ n, ∃ r : ℚ, φ.coeff n = (r : ℂ) := by
+  constructor
+  · rintro ⟨p, rfl⟩ n
+    exact ⟨PowerSeries.coeff n p, by rw [PowerSeries.coeff_map]; rfl⟩
+  · intro h
+    choose r hr using h
+    exact ⟨PowerSeries.mk r, by ext n; simp [hr n]⟩
+
+theorem IsRat.mul {φ ψ : PowerSeries ℂ} (h : IsRat φ) (h' : IsRat ψ) : IsRat (φ * ψ) := by
+  obtain ⟨p, rfl⟩ := h; obtain ⟨p', rfl⟩ := h'; exact ⟨p * p', by rw [map_mul]⟩
+
+theorem IsRat.pow {φ : PowerSeries ℂ} (h : IsRat φ) (n : ℕ) : IsRat (φ ^ n) := by
+  obtain ⟨p, rfl⟩ := h; exact ⟨p ^ n, by rw [map_pow]⟩
+
+theorem isRat_of_int (P : PowerSeries ℤ) : IsRat (P.map (Int.castRingHom ℂ)) :=
+  ⟨P.map (Int.castRingHom ℚ), by ext n; simp [PowerSeries.coeff_map]⟩
+
+omit [NeZero N] in
+theorem BddA.mul {φ ψ : PowerSeries ℂ} (h : BddA N φ) (h' : BddA N ψ) : BddA N (φ * ψ) := by
+  obtain ⟨D, hD, hφ⟩ := h
+  obtain ⟨D', hD', hψ⟩ := h'
+  refine ⟨D * D', mul_ne_zero hD hD', fun n => ?_⟩
+  rw [PowerSeries.coeff_mul, Finset.mul_sum]
+  refine sum_mem fun ij _ => ?_
+  have : ((D * D' : ℕ) : ℂ) * (PowerSeries.coeff ij.1 φ * PowerSeries.coeff ij.2 ψ)
+      = ((D : ℂ) * PowerSeries.coeff ij.1 φ) * ((D' : ℂ) * PowerSeries.coeff ij.2 ψ) := by
+    grind
+  rw [this]
+  exact mul_mem (hφ _) (hψ _)
+
+omit [NeZero N] in
+theorem BddA.add {φ ψ : PowerSeries ℂ} (h : BddA N φ) (h' : BddA N ψ) : BddA N (φ + ψ) := by
+  obtain ⟨D, hD, hφ⟩ := h
+  obtain ⟨D', hD', hψ⟩ := h'
+  refine ⟨D * D', mul_ne_zero hD hD', fun n => ?_⟩
+  rw [map_add, mul_add]
+  have h1 : ((D * D' : ℕ) : ℂ) * PowerSeries.coeff n φ = (D' : ℂ) * ((D : ℂ) * PowerSeries.coeff n
+    φ) :=
+    by
+    grind
+  have h2 : ((D * D' : ℕ) : ℂ) * PowerSeries.coeff n ψ = (D : ℂ) * ((D' : ℂ) * PowerSeries.coeff n
+    ψ) :=
+    by
+    grind
+  rw [h1, h2]
+  exact add_mem (mul_mem (by exact_mod_cast (AZ N).algebraMap_mem (D' : ℤ)) (hφ n))
+    (mul_mem (by exact_mod_cast (AZ N).algebraMap_mem (D : ℤ)) (hψ n))
+
+omit [NeZero N] in
+theorem bddA_one : BddA N (1 : PowerSeries ℂ) := by
+  refine ⟨1, one_ne_zero, fun n => ?_⟩
+  rw [PowerSeries.coeff_one]
+  split_ifs <;> simp [one_mem, zero_mem]
+
+omit [NeZero N] in
+theorem BddA.pow {φ : PowerSeries ℂ} (h : BddA N φ) (n : ℕ) : BddA N (φ ^ n) := by
+  induction n with
+  | zero => simpa using bddA_one
+  | succ n ih => rw [pow_succ]; exact ih.mul h
+
+omit [NeZero N] in
+theorem bddA_of_int (P : PowerSeries ℤ) : BddA N (P.map (Int.castRingHom ℂ)) := by
+  refine ⟨1, one_ne_zero, fun n => ?_⟩
+  rw [PowerSeries.coeff_map, Nat.cast_one, one_mul]
+  exact_mod_cast (AZ N).algebraMap_mem (PowerSeries.coeff n P)
+
+theorem bddA_C {κ : ℂ} (hκ : κ ∈ kN N) : BddA N (PowerSeries.C κ) := by
+  obtain ⟨D, hD, hDκ⟩ := exists_nat_mul_mem_AZ N κ hκ
+  refine ⟨D, hD, fun n => ?_⟩
+  rw [PowerSeries.coeff_C]
+  split_ifs
+  · exact hDκ
+  · simp [zero_mem]
+
+omit [NeZero N] in
+theorem BddA.coeff_mem {φ : PowerSeries ℂ} (h : BddA N φ) (n : ℕ) : φ.coeff n ∈ kN N := by
+  obtain ⟨D, hD, hφ⟩ := h
+  have hDC : (D : ℂ) ≠ 0 := Nat.cast_ne_zero.mpr hD
+  have : PowerSeries.coeff n φ = (D : ℂ)⁻¹ * ((D : ℂ) * PowerSeries.coeff n φ) := by
+    field_simp
+  rw [this]
+  refine mul_mem ?_ (AZ_le_kN N _ (hφ n))
+  have := ratCast_mem (kN N) ((D : ℚ)⁻¹)
+  simp
+
+theorem exists_int_of_bddA_of_isRat {φ : PowerSeries ℂ} (hB : BddA N φ) (hR : IsRat φ) :
+    ∃ (D : ℕ) (P : PowerSeries ℤ), D ≠ 0 ∧ P.map (Int.castRingHom ℂ) = (D : ℂ) • φ := by
+  obtain ⟨D, hD, hφ⟩ := hB
+  obtain ⟨p, rfl⟩ := hR
+  have hz : ∀ n, ∃ z : ℤ, (D : ℂ) * PowerSeries.coeff n (p.map (algebraMap ℚ ℂ)) = (z : ℂ) := by
+    intro n
+    have h1 := hφ n
+    rw [PowerSeries.coeff_map] at h1 ⊢
+    have h2 : (D : ℂ) * (algebraMap ℚ ℂ) (PowerSeries.coeff n p) = (((D : ℚ) * PowerSeries.coeff n p
+      : ℚ) : ℂ) :=
+      by
+      push_cast; rfl
+    rw [h2] at h1 ⊢
+    exact exists_int_of_mem_AZ_of_rat N _ h1
+  choose z hz using hz
+  refine ⟨D, PowerSeries.mk z, hD, ?_⟩
+  ext n
+  rw [PowerSeries.coeff_map, PowerSeries.coeff_mk, PowerSeries.coeff_smul, smul_eq_mul, hz n]
+  simp
+
+end Bdd
+
+section Generators
+
+variable [NeZero N]
+
+local notation "Δ" => ModularForm.discriminant
+
+variable {N}
+
+theorem qExpansion_coeff_unique' {h : ℝ} (hh : 0 < h) {g : ℍ → ℂ} {c : ℕ → ℂ}
+    (hg : AnalyticAt ℂ (cuspFunction h g) 0)
+    (hc : ∀ τ : ℍ, HasSum (fun m => c m • Periodic.qParam h τ ^ m) (g τ)) (m : ℕ) :
+    c m = (qExpansion h g).coeff m := by
+  have h1 := (hasFPowerSeriesOnBall_cuspFunction hh hg hc).hasFPowerSeriesAt
+  have h2 : HasFPowerSeriesAt (cuspFunction h g)
+      (FormalMultilinearSeries.ofScalars ℂ fun m => (qExpansion h g).coeff m) 0 := by
+    simpa [qExpansion_coeff, div_eq_mul_inv, mul_comm] using hg.hasFPowerSeriesAt
+  simpa [FormalMultilinearSeries.coeff_ofScalars] using
+    congr_arg (FormalMultilinearSeries.coeff · m) (h1.eq_formalMultilinearSeries h2)
+
+variable (N) in
+theorem qParam_one_eq_pow (τ : ℍ) : Periodic.qParam 1 τ = Periodic.qParam N τ ^ N := by
+  simp only [Periodic.qParam]
+  rw [← Complex.exp_nat_mul]
+  congr 1
+  have : (N : ℂ) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne N)
+  push_cast
+  field_simp
+
+variable (N) in
+theorem qExpansion_coeff_widthN {g : ℍ → ℂ} (hg : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hper : Periodic (g ∘ ofComplex) 1) (hbd : IsBoundedAtImInfty g) (n : ℕ) :
+    (qExpansion N g).coeff n = if (N : ℕ) ∣ n then (qExpansion 1 g).coeff (n / N) else 0 := by
+  classical
+  have hperN : Periodic (g ∘ ofComplex) N := periodic_ofComplex_natCast hper N
+  set c : ℕ → ℂ := fun n => if (N : ℕ) ∣ n then (qExpansion 1 g).coeff (n / N) else 0 with hc
+  have hNpos : 0 < N := NeZero.pos N
+  have hsum : ∀ τ : ℍ, HasSum (fun m => c m • Periodic.qParam N τ ^ m) (g τ) := by
+    intro τ
+    have h1 := hasSum_qExpansion one_pos hper hg hbd τ
+    have hinj : Function.Injective fun m : ℕ => N * m := mul_right_injective₀ hNpos.ne'
+    have hsupp : ∀ x ∉ Set.range (fun m : ℕ => N * m),
+        (fun m => c m • Periodic.qParam N τ ^ m) x = 0 := by
+      intro x hx
+      have : ¬ (N : ℕ) ∣ x := by
+        rintro ⟨y, rfl⟩; exact hx ⟨y, rfl⟩
+      simp [hc, this]
+    refine (hinj.hasSum_iff hsupp).1 ?_
+    convert h1 using 1
+    funext m
+    simp only [comp_apply, hc, dvd_mul_right, ↓reduceIte, Nat.mul_div_cancel_left _ hNpos]
+    rw [qParam_one_eq_pow N τ, ← pow_mul]
+  rw [← qExpansion_coeff_unique' (natCast_pos N) (analyticAt_cuspFunction_zero (natCast_pos N)
+    hperN hg hbd) hsum n]
+
+def spread (P : PowerSeries ℤ) : PowerSeries ℤ :=
+  PowerSeries.mk fun n => if (N : ℕ) ∣ n then PowerSeries.coeff (n / N) P else 0
+
+theorem qExpansion_widthN_of_int {k : ℤ} (f : ModularForm 𝒮ℒ k) (P : PowerSeries ℤ)
+    (hP : P.map (Int.castRingHom ℂ) = qExpansion 1 (⇑f : ℍ → ℂ)) :
+    (spread (N := N) P).map (Int.castRingHom ℂ) = qExpansion N (⇑f : ℍ → ℂ) := by
+  ext n
+  have hw := qExpansion_coeff_widthN N (g := (⇑f : ℍ → ℂ)) f.holo'
+    (SlashInvariantFormClass.periodic_comp_ofComplex f one_mem_strictPeriods_SL)
+      (ModularFormClass.bdd_at_infty f) n
+  rw [PowerSeries.coeff_map]
+  refine Eq.trans ?_ hw.symm
+  rw [spread, PowerSeries.coeff_mk]
+  split_ifs with h
+  · rw [← hP, PowerSeries.coeff_map]
+  · simp
+
+def P4 : PowerSeries ℤ :=
+  PowerSeries.mk fun m => if m = 0 then 1 else 240 * (ArithmeticFunction.sigma 3 m : ℤ)
+
+theorem map_P4 : P4.map (Int.castRingHom ℂ) = qExpansion 1 (E₄ : ℍ → ℂ) := by
+  ext n
+  rw [PowerSeries.coeff_map, ModularForm.E₄, EisensteinSeries.E_qExpansion_coeff (by
+    norm_num) (by
+      decide) n,
+    P4, PowerSeries.coeff_mk, eq_intCast]
+  split_ifs with h
+  · simp
+  · rw [show _root_.bernoulli 4 = -1 / 30 by
+      rw [bernoulli_eq_bernoulli'_of_ne_one (by norm_num), bernoulli'_four]]
+    push_cast
+    ring
+
+def JZ : PowerSeries ℤ := spread (N := N) (P4 ^ 3)
+
+theorem map_JZ : (JZ (N := N)).map (Int.castRingHom ℂ) = qExpansion N (jf * Δ) := by
+  rw [jf_mul_disc, JZ]
+  apply qExpansion_widthN_of_int
+  rw [map_pow, map_P4, E4cube, ModularForm.qExpansion_mcast, ModularForm.qExpansion_pow one_pos
+    one_mem_strictPeriods_SL]
+
+def DZ : PowerSeries ℤ := spread (N := N) (PowerSeries.X * ModularCurve.dedekindEtaUnit)
+
+def UZ : PowerSeries ℤ := spread (N := N) ModularCurve.dedekindEtaUnit
+
+theorem map_DZ : (DZ (N := N)).map (Int.castRingHom ℂ) = qExpansion N (Δ : ℍ → ℂ) := by
+  have := qExpansion_widthN_of_int (N := N) (CuspForm.discriminant : ModularForm 𝒮ℒ 12)
+    (PowerSeries.X * ModularCurve.dedekindEtaUnit) (by
+      rw [← ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit]; rfl)
+  exact this
+
+omit [NeZero N] in
+theorem constantCoeff_UZ : PowerSeries.constantCoeff (UZ (N := N)) = 1 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff_apply, UZ, spread, PowerSeries.coeff_mk]
+  simp [ModularCurve.constantCoeff_dedekindEtaUnit]
+
+theorem DZ_eq : DZ (N := N) = PowerSeries.X ^ N * UZ (N := N) := by
+  ext n
+  rw [PowerSeries.coeff_X_pow_mul', DZ, UZ, spread, spread, PowerSeries.coeff_mk,
+    PowerSeries.coeff_mk]
+  have hN : 0 < N := NeZero.pos N
+  by_cases hdvd : (N : ℕ) ∣ n
+  · obtain ⟨k, rfl⟩ := hdvd
+    rw [ite_eq_left (dvd_mul_right N k), Nat.mul_div_cancel_left _ hN]
+    cases k with
+    | zero => aesop
+    | succ k =>
+        have hle : N ≤ N * (k + 1) := Nat.le_mul_of_pos_right N (Nat.succ_pos k)
+        rw [ite_eq_left hle]
+        have h1 : N * (k + 1) - N = N * k := by grind
+        rw [h1, ite_eq_left (dvd_mul_right N k), Nat.mul_div_cancel_left _ hN,
+          PowerSeries.coeff_succ_X_mul]
+  · rw [ite_eq_right hdvd]
+    by_cases hle : N ≤ n
+    · have : ¬ (N : ℕ) ∣ n - N := by
+        intro h; apply hdvd
+        have := Nat.dvd_add h (dvd_refl N)
+        rwa [Nat.sub_add_cancel hle] at this
+      grind
+    · grind
+
+theorem bddA_disc : BddA N (qExpansion N (Δ : ℍ → ℂ)) := by
+  rw [← map_DZ]; exact bddA_of_int _
+
+theorem isRat_disc : IsRat (qExpansion N (Δ : ℍ → ℂ)) := by
+  rw [← map_DZ]; exact isRat_of_int _
+
+theorem bddA_jf : BddA N (qExpansion N (jf * Δ)) := by
+  rw [← map_JZ]; exact bddA_of_int _
+
+theorem isRat_jf : IsRat (qExpansion N (jf * Δ)) := by
+  rw [← map_JZ]; exact isRat_of_int _
+
+theorem bddA_fricke {v : Fin 2 → ZMod N} (hv : v ≠ 0) : BddA N (qExpansion N (fricke N v * Δ)) := by
+  obtain ⟨D, hD, h⟩ :=
+    ModularCurve.exists_ne_zero_forall_mul_qExpansion_coeff_fricke_mem_adjoin N tauPair
+    tauPair_spec (WW N) (WW_spec N) (fricke N) (fricke_spec N) v hv
+  exact ⟨D, hD, h⟩
+
+theorem bddA_gen (o : Idx N) : BddA N (qExpansion N (gen N o * Δ)) := by
+  cases o with
+  | none => exact bddA_jf
+  | some v => exact bddA_fricke v.2
+
+end Generators
+
+section GoodAt
+
+variable [NeZero N]
+
+local notation "Δ" => ModularForm.discriminant
+
+variable {N}
+
+def GoodAt (e : ℕ) (g : ℍ → ℂ) : Prop := g * Δ ^ e ∈ nice N ∧ BddA N (qExpansion N (g * Δ ^ e))
+
+theorem GoodAt.mul {e e' : ℕ} {g g' : ℍ → ℂ} (h : GoodAt (N := N) e g) (h' : GoodAt (N := N) e' g')
+    :
+    GoodAt (N := N) (e + e') (g * g') := by
+  have heq : g * g' * Δ ^ (e + e') = (g * Δ ^ e) * (g' * Δ ^ e') := by grind
+  refine ⟨by rw [heq]; exact mul_mem h.1 h'.1, ?_⟩
+  rw [heq]
+  have := (qE N).map_mul ⟨_, h.1⟩ ⟨_, h'.1⟩
+  change qExpansion N ((g * Δ ^ e) * (g' * Δ ^ e')) = _ at this
+  rw [this]
+  exact h.2.mul h'.2
+
+theorem GoodAt.add {e : ℕ} {g g' : ℍ → ℂ} (h : GoodAt (N := N) e g) (h' : GoodAt (N := N) e g') :
+    GoodAt (N := N) e (g + g') := by
+  have heq : (g + g') * Δ ^ e = g * Δ ^ e + g' * Δ ^ e := by ring
+  refine ⟨by rw [heq]; exact add_mem h.1 h'.1, ?_⟩
+  rw [heq]
+  have := (qE N).map_add ⟨_, h.1⟩ ⟨_, h'.1⟩
+  change qExpansion N (g * Δ ^ e + g' * Δ ^ e) = _ at this
+  rw [this]
+  exact h.2.add h'.2
+
+theorem goodAt_disc : GoodAt (N := N) 0 (Δ : ℍ → ℂ) := by
+  refine ⟨by simpa using (disc_mem (N := N)), ?_⟩
+  simpa using (bddA_disc (N := N))
+
+theorem GoodAt.succ {e : ℕ} {g : ℍ → ℂ} (h : GoodAt (N := N) e g) : GoodAt (N := N) (e + 1) g := by
+  have := h.mul goodAt_disc
+  have heq : g * Δ ^ (e + 1) = g * Δ * Δ ^ (e + 0) := by ring
+  refine ⟨?_, ?_⟩
+  · rw [heq]; exact this.1
+  · rw [heq]; exact this.2
+
+theorem GoodAt.of_le {e e' : ℕ} (hle : e ≤ e') {g : ℍ → ℂ} (h : GoodAt (N := N) e g) :
+    GoodAt (N := N) e' g := by
+  obtain ⟨d, rfl⟩ := Nat.exists_eq_add_of_le hle
+  induction d with
+  | zero => simpa using h
+  | succ d ih => exact (ih (Nat.le_add_right e d)).succ
+
+theorem goodAt_const {κ : ℂ} (hκ : κ ∈ kN N) : GoodAt (N := N) 0 (fun _ : ℍ => κ) := by
+  have hmem : (fun _ : ℍ => κ) ∈ nice N := (nice N).algebraMap_mem κ
+  refine ⟨by simpa using hmem, ?_⟩
+  have : qExpansion N ((fun _ : ℍ => κ) * Δ ^ 0) = PowerSeries.C κ := by
+    rw [pow_zero, mul_one]
+    have := (qE N).commutes κ
+    exact this
+  rw [this]
+  exact bddA_C hκ
+
+theorem goodAt_gen (o : Idx N) : GoodAt (N := N) 1 (gen N o) :=
+  ⟨by rw [pow_one]; exact gen_disc_mem o, by rw [pow_one]; exact bddA_gen o⟩
+
+theorem exists_goodAt_ev (R : MvPolynomial (Idx N) (kN N)) :
+    ∃ e : ℕ, GoodAt (N := N) e (ev N R) := by
+  induction R using MvPolynomial.induction_on with
+  | C κ =>
+      refine ⟨0, ?_⟩
+      have : ev N (MvPolynomial.C κ) = fun _ : ℍ => (κ : ℂ) := by
+        funext τ; simp [ev]
+      rw [this]
+      exact goodAt_const κ.2
+  | add p q hp hq =>
+      obtain ⟨e, he⟩ := hp
+      obtain ⟨e', he'⟩ := hq
+      refine ⟨e + e', ?_⟩
+      have : ev N (p + q) = ev N p + ev N q := by simp [ev, map_add]
+      rw [this]
+      exact (he.of_le (Nat.le_add_right e e')).add (he'.of_le (Nat.le_add_left e' e))
+  | mul_X p o hp =>
+      obtain ⟨e, he⟩ := hp
+      refine ⟨e + 1, ?_⟩
+      have : ev N (p * MvPolynomial.X o) = ev N p * gen N o := by
+        simp [ev, map_mul, MvPolynomial.map_X, MvPolynomial.aeval_X]
+      rw [this]
+      exact he.mul (goodAt_gen o)
+
+end GoodAt
+
+section Flat
+
+variable [NeZero N]
+
+local notation "Δ" => ModularForm.discriminant
+
+variable (K : IntermediateField ℚ ℂ)
+
+structure RatAt (M : ℕ) (g : ℍ → ℂ) : Prop where
+  mdiff : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g
+  periodic : Periodic ((g * Δ ^ M) ∘ ofComplex) N
+  bdd : IsBoundedAtImInfty (g * Δ ^ M)
+  mem : ∀ n, (qExpansion N (g * Δ ^ M)).coeff n ∈ K
+
+variable {N K}
+
+omit [NeZero N] in
+theorem ratAt_of_mem_nice {M : ℕ} {g : ℍ → ℂ} (hg : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hmem : g * Δ ^ M ∈ nice N)
+    (hrat : IsRat (qExpansion N (g * Δ ^ M))) : RatAt N K M g where
+  mdiff := hg
+  periodic := hmem.2.1
+  bdd := hmem.2.2
+  mem n := by
+    obtain ⟨r, hr⟩ := isRat_iff.mp hrat n
+    rw [hr]; exact ratCast_mem K r
+
+theorem exists_rat_combination (K : IntermediateField ℚ ℂ) {ι : Type} [Fintype ι] {M : ℕ}
+    {Gi : ι → ℍ → ℂ}
+    {G : ℍ → ℂ} (hGi : ∀ i, RatAt N K M (Gi i)) (hG : RatAt N K M G)
+    (hmem : G ∈ Submodule.span ℂ (Set.range Gi)) :
+    ∃ κ : ι → K, G = ∑ i, (κ i : ℂ) • Gi i := by
+  classical
+  by_cases hW : G ∈ Submodule.span K (Set.range Gi)
+  · obtain ⟨c, hc⟩ := (Submodule.mem_span_range_iff_exists_fun K).mp hW
+    exact ⟨c, by rw [← hc]; rfl⟩
+  exfalso
+  obtain ⟨b, hb_sub, hb_span, hb_ind⟩ := exists_linearIndependent K (Set.range Gi)
+  have hbfin : b.Finite := (Set.finite_range Gi).subset hb_sub
+  have hGb : G ∉ b := fun h => hW (hb_span ▸ Submodule.subset_span h)
+  have hGspan : G ∉ Submodule.span K b := by rwa [hb_span]
+  have hins : LinearIndepOn K id (insert G b) := LinearIndepOn.id_insert hb_ind hGspan
+  set sF : Finset (ℍ → ℂ) := (hbfin.insert G).toFinset with hsF
+  have hcoe : (↑sF : Set (ℍ → ℂ)) = insert G b := Set.Finite.coe_toFinset _
+  have hdata : ∀ f ∈ sF, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f ∧
+      Function.Periodic ((f * ModularForm.discriminant ^ M) ∘ UpperHalfPlane.ofComplex) N ∧
+      IsBoundedAtImInfty (f * ModularForm.discriminant ^ M) ∧
+      ∀ n : ℕ, (UpperHalfPlane.qExpansion N (f * ModularForm.discriminant ^ M)).coeff n ∈ K := by
+    intro f hf
+    have hf' : f ∈ insert G b := by grind
+    rcases hf' with rfl | hf'
+    · exact ⟨hG.mdiff, hG.periodic, hG.bdd, hG.mem⟩
+    · obtain ⟨i, rfl⟩ := hb_sub hf'
+      exact ⟨(hGi i).mdiff, (hGi i).periodic, (hGi i).bdd, (hGi i).mem⟩
+  have hind : LinearIndependent K (fun w : ↥(↑sF : Set (ℍ → ℂ)) => (w : ℍ → ℂ)) := by
+    rw [hcoe]; exact hins
+  have hC := WLight.linearIndependent_complex_of_qExpansion_rational N K sF M hdata hind
+  rw [hcoe] at hC
+  have hC' : LinearIndepOn ℂ id (insert G b) := hC
+  have hnot := hC'.notMem_span_of_insert hGb
+  rw [Set.image_id] at hnot
+  apply hnot
+  have hle : Submodule.span ℂ (Set.range Gi) ≤ Submodule.span ℂ b := by
+    rw [Submodule.span_le]
+    intro x hx
+    have hxK : x ∈ Submodule.span K b := by rw [hb_span]; exact Submodule.subset_span hx
+    exact Submodule.span_subset_span K ℂ b hxK
+  exact hle hmem
+
+theorem exists_rat_monic (m : ℕ) {G : ℍ → ℂ} (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (hGm : G * Δ ^ m ∈ nice N)
+    (hrat : IsRat (qExpansion N (G * Δ ^ m)))
+    {d : ℕ} (p : Fin d → Polynomial ℂ)
+    (hrel : ∀ τ : ℍ, G τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * G τ ^ (i : ℕ) = 0) :
+    ∃ (L : ℕ) (b : Fin d → Fin (L + 1) → ℚ),
+      G ^ d = ∑ i : Fin d, ∑ l : Fin (L + 1), ((b i l : ℚ) : ℂ) • (jf ^ (l : ℕ) * G ^ (i : ℕ)) := by
+  classical
+  set L : ℕ := ∑ i, (p i).natDegree with hL
+  have hLi : ∀ i, (p i).natDegree < L + 1 := fun i =>
+    Nat.lt_succ_of_le (Finset.single_le_sum (f := fun j => (p j).natDegree) (fun j _ => Nat.zero_le
+      _)
+      (Finset.mem_univ i))
+  set M : ℕ := L + m * d with hM
+  set Gi : Fin d × Fin (L + 1) → ℍ → ℂ := fun il => jf ^ (il.2 : ℕ) * G ^ (il.1 : ℕ) with hGi
+  have hjm : (jf * Δ) ∈ nice N := jf_disc_mem
+  have key : ∀ (l i r : ℕ), jf ^ l * G ^ i * Δ ^ (l + m * i + r) ∈ nice N ∧
+      IsRat (qExpansion N (jf ^ l * G ^ i * Δ ^ (l + m * i + r))) := by
+    intro l i r
+    have heq : jf ^ l * G ^ i * Δ ^ (l + m * i + r) = (jf * Δ) ^ l * (G * Δ ^ m) ^ i * Δ ^ r := by
+      rw [pow_add, pow_add, pow_mul]; ring
+    rw [heq]
+    set a : nice N := ⟨jf * Δ, hjm⟩
+    set g : nice N := ⟨G * Δ ^ m, hGm⟩
+    have hmem : (jf * Δ) ^ l * (G * Δ ^ m) ^ i * Δ ^ r ∈ nice N := (a ^ l * g ^ i * dN ^ r).2
+    refine ⟨hmem, ?_⟩
+    have : qExpansion N ((jf * Δ) ^ l * (G * Δ ^ m) ^ i * Δ ^ r) = qE N (a ^ l * g ^ i * dN ^ r) :=
+      rfl
+    rw [this, map_mul, map_mul, map_pow, map_pow, map_pow]
+    exact ((isRat_jf.pow l).mul (hrat.pow i)).mul (isRat_disc.pow r)
+  have hexp : ∀ (i : Fin d) (l : Fin (L + 1)), (l : ℕ) + m * i ≤ M := by
+    intro i l
+    have h1 : (l : ℕ) ≤ L := Nat.lt_succ_iff.mp l.2
+    have h2 : m * (i : ℕ) ≤ m * d := Nat.mul_le_mul_left m i.2.le
+    omega
+  have hGiRat : ∀ il, RatAt N (⊥ : IntermediateField ℚ ℂ) M (Gi il) := by
+    rintro ⟨i, l⟩
+    obtain ⟨hn, hr⟩ := key l i (M - (l + m * i))
+    have hM' : (l : ℕ) + m * i + (M - (l + m * i)) = M := Nat.add_sub_cancel' (hexp i l)
+    rw [hM'] at hn hr
+    exact ratAt_of_mem_nice (((mdifferentiable_gen (N := N) none).pow _).mul (hG.pow _)) hn hr
+  have hGdRat : RatAt N (⊥ : IntermediateField ℚ ℂ) M (G ^ d) := by
+    obtain ⟨hn, hr⟩ := key 0 d L
+    have h0 : (0 : ℕ) + m * d + L = M := by omega
+    rw [pow_zero, one_mul, h0] at hn hr
+    exact ratAt_of_mem_nice (hG.pow _) hn hr
+  have hmem : G ^ d ∈ Submodule.span ℂ (Set.range Gi) := by
+    have hfun : G ^ d = ∑ i : Fin d, ∑ l : Fin (L + 1), (-(p i).coeff l) • Gi (i, l) := by
+      funext τ
+      have h1 := hrel τ
+      have h2 : ∀ i : Fin d, (p i).eval (jf τ) = ∑ l : Fin (L + 1), (p i).coeff l * jf τ ^ (l : ℕ)
+        :=
+        by
+        intro i
+        rw [Polynomial.eval_eq_sum_range' (hLi i), Finset.sum_range]
+      simp only [Finset.sum_apply, Pi.smul_apply, Pi.mul_apply, Pi.pow_apply, smul_eq_mul, hGi]
+      have h3 : G τ ^ d = -∑ i : Fin d, (p i).eval (jf τ) * G τ ^ (i : ℕ) :=
+        eq_neg_of_add_eq_zero_left h1
+      rw [h3, ← Finset.sum_neg_distrib]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [h2 i, Finset.sum_mul, ← Finset.sum_neg_distrib]
+      grind
+    rw [hfun]
+    refine Submodule.sum_mem _ fun i _ => Submodule.sum_mem _ fun l _ => ?_
+    exact Submodule.smul_mem _ _ (Submodule.subset_span ⟨(i, l), rfl⟩)
+  obtain ⟨κ, hκ⟩ := exists_rat_combination (N := N) ⊥ hGiRat hGdRat hmem
+  have hb : ∀ il, ∃ r : ℚ, (κ il : ℂ) = (r : ℂ) := by
+    intro il
+    obtain ⟨r, hr⟩ := IntermediateField.mem_bot.mp (κ il).2
+    exact ⟨r, hr.symm⟩
+  choose b hb using hb
+  refine ⟨L, fun i l => b (i, l), ?_⟩
+  rw [hκ, Fintype.sum_prod_type]
+  grind
+
+end Flat
+
+section Series
+
+variable [NeZero N]
+
+local notation "Δ" => ModularForm.discriminant
+
+variable {N}
+
+def BddQ (ψ : PowerSeries ℚ) : Prop :=
+  ∃ (D : ℕ) (Ψ : PowerSeries ℤ), D ≠ 0 ∧ Ψ.map (Int.castRingHom ℚ) = (D : ℚ) • ψ
+
+theorem map_rat_injective : Function.Injective (PowerSeries.map (algebraMap ℚ ℂ)) := by
+  intro a b h
+  ext n
+  have := congrArg (PowerSeries.coeff n) h
+  simpa [PowerSeries.coeff_map] using this
+
+theorem map_int_rat (P : PowerSeries ℤ) :
+    (P.map (Int.castRingHom ℚ)).map (algebraMap ℚ ℂ) = P.map (Int.castRingHom ℂ) := by
+  ext n; simp [PowerSeries.coeff_map]
+
+theorem bddQ_of_bddA_isRat {ψ : PowerSeries ℚ} (hB : BddA N (ψ.map (algebraMap ℚ ℂ))) : BddQ ψ := by
+  obtain ⟨D, P, hD, hP⟩ := exists_int_of_bddA_of_isRat hB ⟨ψ, rfl⟩
+  refine ⟨D, P, hD, map_rat_injective ?_⟩
+  rw [map_int_rat, hP]
+  ext n
+  simp [PowerSeries.coeff_map]
+
+theorem bddQ_ratCast_smul_int (r : ℚ) (P : PowerSeries ℤ) :
+    BddQ (r • P.map (Int.castRingHom ℚ)) := by
+  refine ⟨r.den, PowerSeries.C r.num * P, r.den_nz, ?_⟩
+  ext n
+  have h : (r.den : ℚ) * r = r.num := Rat.den_mul_eq_num r
+  rw [PowerSeries.coeff_map, PowerSeries.coeff_C_mul, PowerSeries.coeff_smul,
+    PowerSeries.coeff_smul,
+    PowerSeries.coeff_map, smul_eq_mul, smul_eq_mul, eq_intCast, eq_intCast]
+  grind
+
+theorem BddQ.add {ψ ψ' : PowerSeries ℚ} (h : BddQ ψ) (h' : BddQ ψ') : BddQ (ψ + ψ') := by
+  obtain ⟨D, Ψ, hD, hΨ⟩ := h
+  obtain ⟨D', Ψ', hD', hΨ'⟩ := h'
+  refine ⟨D * D', PowerSeries.C (D' : ℤ) * Ψ + PowerSeries.C (D : ℤ) * Ψ', mul_ne_zero hD hD', ?_⟩
+  ext n
+  have h1 := congrArg (PowerSeries.coeff n) hΨ
+  have h2 := congrArg (PowerSeries.coeff n) hΨ'
+  simp only [PowerSeries.coeff_map, PowerSeries.coeff_smul, smul_eq_mul, eq_intCast] at h1 h2
+  have h3 : PowerSeries.coeff n (PowerSeries.C (D' : ℤ) * Ψ + PowerSeries.C (D : ℤ) * Ψ')
+      = D' * PowerSeries.coeff n Ψ + D * PowerSeries.coeff n Ψ' := by
+    rw [map_add, PowerSeries.coeff_C_mul, PowerSeries.coeff_C_mul]
+  rw [PowerSeries.coeff_map, h3, PowerSeries.coeff_smul, smul_eq_mul, eq_intCast]
+  push_cast
+  grind
+
+theorem BddQ.neg {ψ : PowerSeries ℚ} (h : BddQ ψ) : BddQ (-ψ) := by
+  obtain ⟨D, Ψ, hD, hΨ⟩ := h
+  exact ⟨D, -Ψ, hD, by rw [map_neg, hΨ, smul_neg]⟩
+
+theorem bddQ_zero : BddQ (0 : PowerSeries ℚ) := ⟨1, 0, one_ne_zero, by simp⟩
+
+theorem bddQ_sum {ι : Type*} (s : Finset ι) (f : ι → PowerSeries ℚ) (h : ∀ i ∈ s, BddQ (f i)) :
+    BddQ (∑ i ∈ s, f i) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => simpa using bddQ_zero
+  | insert a s ha ih =>
+      rw [Finset.sum_insert ha]
+      exact (h a (Finset.mem_insert_self a s)).add (ih fun i hi => h i (Finset.mem_insert_of_mem
+        hi))
+
+omit [NeZero N] in
+theorem periodic_of_gamma_invariant {G : ℍ → ℂ}
+    (hinv : ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : ℍ, G (γ • τ) = G τ) : Periodic (G ∘ ofComplex) N
+      := by
+  have hT : ModularGroup.T ^ (N : ℤ) ∈ CongruenceSubgroup.Gamma N := by
+    rw [Gamma_mem, ModularGroup.coe_T_zpow]
+    simp
+  intro w
+  by_cases hw : 0 < im w
+  · have this : 0 < im (w + N) := by simp [hw]
+    simp only [comp_apply, ofComplex_apply_of_im_pos this, ofComplex_apply_of_im_pos hw]
+    have := hinv _ hT ⟨w, hw⟩
+    convert this using 2
+    ext
+    rw [UpperHalfPlane.modular_T_zpow_smul]
+    simp [add_comm, UpperHalfPlane.coe_vadd]
+  · push Not at hw
+    have : im (w + N) ≤ 0 := by simpa using hw
+    simp [ofComplex_apply_of_im_nonpos this, ofComplex_apply_of_im_nonpos hw]
+
+theorem exists_series_data (m : ℕ) (G : ℍ → ℂ) (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (hinv : ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : ℍ, G (γ • τ) = G τ)
+    (hbd : ∀ α : SL(2, ℤ), IsBoundedAtImInfty ((fun τ : ℍ => G (α • τ)) * Δ ^ m))
+    (hrat : ∀ n : ℕ, ∃ r : ℚ, (qExpansion N (G * Δ ^ m)).coeff n = (r : ℂ)) :
+    ∃ (L d : ℕ) (y₀ : PowerSeries ℚ) (c₀ : Fin d → PowerSeries ℚ) (q r : PowerSeries ℂ),
+      y₀.map (algebraMap ℚ ℂ) = qExpansion N (G * Δ ^ m) * qExpansion N (Δ : ℍ → ℂ) ^ L ∧
+      (∀ i, BddQ (c₀ i)) ∧
+      y₀ ^ d + ∑ i : Fin d, c₀ i * y₀ ^ (i : ℕ) = 0 ∧
+      q ≠ 0 ∧ BddA N q ∧ BddA N r ∧ y₀.map (algebraMap ℚ ℂ) * q = r := by
+  classical
+  have hperG : Periodic (G ∘ ofComplex) N := periodic_of_gamma_invariant hinv
+  have hΔm : (Δ ^ m : ℍ → ℂ) ∈ nice N := pow_mem disc_mem m
+  have hGm : G * Δ ^ m ∈ nice N := by
+    refine ⟨hG.mul (mdifferentiable_disc.pow m), ?_, by simpa using hbd 1⟩
+    intro w
+    have h1 := hperG w
+    have h2 := hΔm.2.1 w
+    simp only [comp_apply, Pi.mul_apply] at h1 h2 ⊢
+    rw [h1, h2]
+  have hGrat : IsRat (qExpansion N (G * Δ ^ m)) := isRat_iff.mpr hrat
+  have hcoeff : ∀ n, (qExpansion N (G * Δ ^ m)).coeff n ∈ kN N := by
+    intro n; obtain ⟨r, hr⟩ := hrat n; rw [hr]; exact ratCast_mem (kN N) r
+  obtain ⟨P, Q, hQ0, hGQ⟩ :=
+    ModularCurve.exists_mvPolynomial_mul_aeval_fricke_eq_of_qExpansion_coeff_mem N
+    tauPair tauPair_spec (WW N) (WW_spec N) (fricke N) (fricke_spec N) jf jf_spec (kN N) rfl m G hG
+      hinv hbd hcoeff
+  change ev N Q ≠ 0 at hQ0
+  change G * ev N Q = ev N P at hGQ
+  obtain ⟨d, p, -, hrel⟩ :=
+    WLight.exists_monicRel_j_K_of_mdifferentiable_frickeQuotient N tauPair tauPair_spec
+    (WW N) (WW_spec N) (fricke N) (fricke_spec N) jf jf_spec (kN N) rfl G hG P Q hQ0 hGQ
+  obtain ⟨L, b, hb⟩ := exists_rat_monic m hG hGm hGrat p hrel
+  obtain ⟨eQ, heQ⟩ := exists_goodAt_ev (N := N) Q
+  obtain ⟨eP, heP⟩ := exists_goodAt_ev (N := N) P
+  set e : ℕ := eQ + eP with he
+  have hQe : GoodAt (N := N) e (ev N Q) := heQ.of_le (Nat.le_add_right _ _)
+  have hPe : GoodAt (N := N) e (ev N P) := heP.of_le (Nat.le_add_left _ _)
+  set E : ℕ := m + L with hE
+  set gm : nice N := ⟨G * Δ ^ m, hGm⟩ with hgm
+  set y : nice N := gm * dN ^ L with hy
+  set jn : nice N := ⟨jf * Δ, jf_disc_mem⟩ with hjn
+  set qn : nice N := ⟨ev N Q * Δ ^ e, hQe.1⟩ with hqn
+  set pn : nice N := ⟨ev N P * Δ ^ e, hPe.1⟩ with hpn
+  have hy_coe : ((y : nice N) : ℍ → ℂ) = G * Δ ^ m * Δ ^ L := rfl
+  have hexp : ∀ (i : Fin d) (l : Fin (L + 1)), E * d = (l : ℕ) + E * i + (E * (d - i) - l) := by
+    intro i l
+    have hl : (l : ℕ) ≤ L := Nat.lt_succ_iff.mp l.2
+    have hdi : 1 ≤ d - i := by have := i.2; omega
+    have h1 : E ≤ E * (d - i) := Nat.le_mul_of_pos_right E hdi
+    have h2 : E * d = E * i + E * (d - i) := by rw [← Nat.mul_add, Nat.add_sub_cancel' i.2.le]
+    omega
+  set kk : Fin d → Fin (L + 1) → ℕ := fun i l => E * (d - i) - l with hkk
+  set Z : nice N := ∑ i : Fin d, ∑ l : Fin (L + 1), ((b i l : ℚ) : ℂ) • (jn ^ (l : ℕ) * y ^ (i : ℕ)
+    * dN ^ kk i l)
+    with hZ
+  have hZ_coe : ((Z : nice N) : ℍ → ℂ) =
+      ∑ i : Fin d, ∑ l : Fin (L + 1), ((b i l : ℚ) : ℂ) • ((jf * Δ) ^ (l : ℕ) * (G * Δ ^ m * Δ ^ L)
+        ^ (i : ℕ) * Δ ^ kk i l) := by
+    rw [hZ]
+    push_cast
+    rfl
+  have hId1 : y ^ d = Z := by
+    apply Subtype.ext
+    rw [hZ_coe]
+    change (G * Δ ^ m * Δ ^ L) ^ d = _
+    calc (G * Δ ^ m * Δ ^ L) ^ d = G ^ d * Δ ^ (E * d) := by rw [hE]; ring
+      _ = (∑ i : Fin d, ∑ l : Fin (L + 1), ((b i l : ℚ) : ℂ) • (jf ^ (l : ℕ) * G ^ (i : ℕ))) * Δ ^
+        (E * d) := by
+          rw [← hb]
+      _ = ∑ i : Fin d, ∑ l : Fin (L + 1), ((b i l : ℚ) : ℂ) • (jf ^ (l : ℕ) * G ^ (i : ℕ) * Δ ^ (E *
+        d)) := by
+          rw [Finset.sum_mul]
+          refine Finset.sum_congr rfl fun i _ => ?_
+          rw [Finset.sum_mul]
+          refine Finset.sum_congr rfl fun l _ => ?_
+          rw [smul_mul_assoc]
+      _ = _ := by
+          refine Finset.sum_congr rfl fun i _ => Finset.sum_congr rfl fun l _ => ?_
+          congr 1
+          rw [hexp i l, pow_add, pow_add, hkk, hE]
+          ring
+  have hS1 : (qE N y) ^ d = ∑ i : Fin d, ∑ l : Fin (L + 1),
+      ((b i l : ℚ) : ℂ) • ((qE N jn) ^ (l : ℕ) * (qE N y) ^ (i : ℕ) * (qE N dN) ^ kk i l) := by
+    rw [← map_pow, hId1, hZ, map_sum]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [map_sum]
+    refine Finset.sum_congr rfl fun l _ => ?_
+    rw [map_smul, map_mul, map_mul, map_pow, map_pow, map_pow]
+  have hId2 : y * qn = pn * dN ^ E := by
+    apply Subtype.ext
+    change (G * Δ ^ m * Δ ^ L) * (ev N Q * Δ ^ e) = (ev N P * Δ ^ e) * Δ ^ E
+    rw [← hGQ, hE, pow_add]
+    ring
+  have hS2 : qE N y * qE N qn = qE N pn * (qE N dN) ^ E := by
+    rw [← map_mul, hId2, map_mul, map_pow]
+  have hqEy : qE N y = qExpansion N (G * Δ ^ m) * qExpansion N (Δ : ℍ → ℂ) ^ L := by
+    rw [hy, map_mul, map_pow]; rfl
+  have hqEjn : qE N jn = (JZ (N := N)).map (Int.castRingHom ℂ) := by rw [map_JZ]; rfl
+  have hqEdN : qE N dN = (DZ (N := N)).map (Int.castRingHom ℂ) := by rw [map_DZ]; rfl
+  have hYrat : IsRat (qE N y) := by rw [hqEy]; exact hGrat.mul (isRat_disc.pow L)
+  obtain ⟨y₀, hy₀⟩ := hYrat
+  set c₀ : Fin d → PowerSeries ℚ := fun i =>
+    -∑ l : Fin (L + 1), (b i l) • ((JZ (N := N) ^ (l : ℕ) * DZ (N := N) ^ kk i l).map
+      (Int.castRingHom ℚ)) with hc₀
+  have hc₀map : ∀ i, (c₀ i).map (algebraMap ℚ ℂ) =
+      -∑ l : Fin (L + 1), ((b i l : ℚ) : ℂ) • ((qE N jn) ^ (l : ℕ) * (qE N dN) ^ kk i l) := by
+    intro i
+    rw [hc₀, map_neg, map_sum]
+    congr 1
+    refine Finset.sum_congr rfl fun l _ => ?_
+    rw [PowerSeries.smul_eq_C_mul, map_mul, PowerSeries.map_C, map_int_rat, map_mul, map_pow,
+      map_pow,
+      ← hqEjn, ← hqEdN, PowerSeries.smul_eq_C_mul]
+    rfl
+  refine ⟨L, d, y₀, c₀, qE N qn, qE N pn * (qE N dN) ^ E, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩
+  · rw [hy₀, hqEy]
+  · intro i
+    rw [hc₀]
+    refine (bddQ_sum _ _ fun l _ => ?_).neg
+    exact bddQ_ratCast_smul_int _ _
+  · apply map_rat_injective
+    rw [map_add, map_pow, map_sum, map_zero, hy₀, hS1]
+    simp only [map_mul, map_pow, hc₀map, hy₀]
+    rw [← Finset.sum_add_distrib]
+    refine Finset.sum_eq_zero fun i _ => ?_
+    rw [neg_mul, Finset.sum_mul, ← sub_eq_add_neg, sub_eq_zero]
+    refine Finset.sum_congr rfl fun l _ => ?_
+    rw [smul_mul_assoc]
+    congr 1
+    ring
+  · rw [Ne, qE_eq_zero_iff]
+    change ev N Q * Δ ^ e ≠ 0
+    intro h0
+    apply hQ0
+    funext τ
+    have := congrFun h0 τ
+    simp only [Pi.mul_apply, Pi.pow_apply, Pi.zero_apply, mul_eq_zero] at this
+    rcases this with h1 | h1
+    · exact h1
+    · exact absurd h1 (pow_ne_zero _ (discriminant_ne_zero τ))
+  · exact hQe.2
+  · exact hPe.2.mul (bddA_disc.pow E)
+  · rw [hy₀]; exact hS2
+
+end Series
+
+section Galois
+
+variable {N}
+
+def liftK (φ : PowerSeries ℂ) (hφ : ∀ n, φ.coeff n ∈ kN N) : PowerSeries (kN N) :=
+  PowerSeries.mk fun n => ⟨φ.coeff n, hφ n⟩
+
+theorem map_liftK (φ : PowerSeries ℂ) (hφ : ∀ n, φ.coeff n ∈ kN N) :
+    (liftK φ hφ).map (algebraMap (kN N) ℂ) = φ := by
+  ext n; simp [liftK]
+
+theorem coe_algebraMap (x : kN N) : algebraMap (kN N) ℂ x = (x : ℂ) := rfl
+
+theorem map_K_injective : Function.Injective (PowerSeries.map (algebraMap (kN N) ℂ)) := by
+  intro a b h
+  ext n
+  have := congrArg (PowerSeries.coeff n) h
+  simp only [PowerSeries.coeff_map] at this
+  exact_mod_cast this
+
+theorem map_map' {R S T : Type*} [Semiring R] [Semiring S] [Semiring T] (f : R →+* S) (g : S →+* T)
+    (φ : PowerSeries R) : (φ.map f).map g = φ.map (g.comp f) := by
+  ext n; simp [PowerSeries.coeff_map]
+
+theorem map_rat_K (y : PowerSeries ℚ) :
+    (y.map (algebraMap ℚ (kN N))).map (algebraMap (kN N) ℂ) = y.map (algebraMap ℚ ℂ) := by
+  rw [map_map']
+  congr 1
+
+def BddK (ψ : PowerSeries (kN N)) : Prop :=
+  ∃ D : ℕ, D ≠ 0 ∧ ∀ n, (((D : kN N) * ψ.coeff n : kN N) : ℂ) ∈ AZ N
+
+theorem bddK_iff_map {ψ : PowerSeries (kN N)} : BddK ψ ↔ BddA N (ψ.map (algebraMap (kN N) ℂ)) := by
+  constructor
+  · rintro ⟨D, hD, h⟩
+    refine ⟨D, hD, fun n => ?_⟩
+    rw [PowerSeries.coeff_map, coe_algebraMap]
+    have := h n
+    push_cast at this
+    exact this
+  · rintro ⟨D, hD, h⟩
+    refine ⟨D, hD, fun n => ?_⟩
+    have := h n
+    rw [PowerSeries.coeff_map, coe_algebraMap] at this
+    push_cast
+    exact this
+
+theorem bddK_liftK {φ : PowerSeries ℂ} (h : BddA N φ) (hφ : ∀ n, φ.coeff n ∈ kN N) :
+    BddK (liftK φ hφ) := by
+  rw [bddK_iff_map, map_liftK]; exact h
+
+theorem BddK.mul {ψ ψ' : PowerSeries (kN N)} (h : BddK ψ) (h' : BddK ψ') : BddK (ψ * ψ') := by
+  rw [bddK_iff_map] at h h' ⊢
+  rw [map_mul]
+  exact h.mul h'
+
+theorem bddK_one : BddK (1 : PowerSeries (kN N)) := by
+  rw [bddK_iff_map, map_one]; exact bddA_one
+
+theorem bddK_prod {ι : Type*} (s : Finset ι) (f : ι → PowerSeries (kN N)) (h : ∀ i ∈ s, BddK (f i))
+    :
+    BddK (∏ i ∈ s, f i) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => simpa using bddK_one
+  | insert a s ha ih =>
+      rw [Finset.prod_insert ha]
+      exact (h a (Finset.mem_insert_self a s)).mul (ih fun i hi => h i (Finset.mem_insert_of_mem
+        hi))
+
+private def _root_.GammaNBounded.autS (σ : (kN N) ≃ₐ[ℚ] (kN N)) :
+    PowerSeries (kN N) →+* PowerSeries (kN N) :=
+  PowerSeries.map (σ : (kN N) →+* (kN N))
+
+p2m_export "GammaNBounded" "autS"
+theorem coeff_autS (σ : (kN N) ≃ₐ[ℚ] (kN N)) (ψ : PowerSeries (kN N)) (n : ℕ) :
+    (autS σ ψ).coeff n = σ (ψ.coeff n) := by
+  rw [autS, PowerSeries.coeff_map]; rfl
+
+theorem autS_injective (σ : (kN N) ≃ₐ[ℚ] (kN N)) : Function.Injective (autS σ) := by
+  intro a b h
+  refine PowerSeries.ext fun n => ?_
+  have := congrArg (PowerSeries.coeff n) h
+  rw [coeff_autS, coeff_autS] at this
+  exact σ.injective this
+
+theorem autS_mul (τ σ : (kN N) ≃ₐ[ℚ] (kN N)) (ψ : PowerSeries (kN N)) :
+    autS τ (autS σ ψ) = autS (τ * σ) ψ := by
+  ext n
+  rw [coeff_autS, coeff_autS, coeff_autS, AlgEquiv.mul_apply]
+
+theorem autS_one (ψ : PowerSeries (kN N)) : autS 1 ψ = ψ := by
+  ext n; rw [coeff_autS, AlgEquiv.one_apply]
+
+theorem BddK.autS [NeZero N] {ψ : PowerSeries (kN N)} (h : BddK ψ) (σ : (kN N) ≃ₐ[ℚ] (kN N)) :
+    BddK (autS σ ψ) := by
+  obtain ⟨D, hD, hψ⟩ := h
+  refine ⟨D, hD, fun n => ?_⟩
+  rw [coeff_autS]
+  have : (D : kN N) * σ (ψ.coeff n) = σ ((D : kN N) * ψ.coeff n) := by
+    rw [map_mul, map_natCast]
+  rw [this]
+  exact aut_mem_AZ N σ _ (hψ n)
+
+theorem autS_map_rat (σ : (kN N) ≃ₐ[ℚ] (kN N)) (y : PowerSeries ℚ) :
+    autS σ (y.map (algebraMap ℚ (kN N))) = y.map (algebraMap ℚ (kN N)) := by
+  ext n
+  rw [coeff_autS, PowerSeries.coeff_map, AlgEquiv.commutes]
+
+theorem bddQ_of_bddK_map [NeZero N] {y : PowerSeries ℚ} (h : BddK (y.map (algebraMap ℚ (kN N)))) :
+    BddQ y := by
+  rw [bddK_iff_map, map_rat_K] at h
+  exact bddQ_of_bddA_isRat h
+
+theorem galois_descent [NeZero N] (y₀ : PowerSeries ℚ) (q r : PowerSeries ℂ) (hq0 : q ≠ 0)
+    (hq : BddA N q) (hr : BddA N r) (hyq : y₀.map (algebraMap ℚ ℂ) * q = r) :
+    ∃ h₀ u₀ : PowerSeries ℚ, h₀ ≠ 0 ∧ BddQ h₀ ∧ BddQ u₀ ∧ h₀ * y₀ = u₀ := by
+  classical
+  set qK : PowerSeries (kN N) := liftK q hq.coeff_mem with hqK
+  set rK : PowerSeries (kN N) := liftK r hr.coeff_mem with hrK
+  set yK : PowerSeries (kN N) := y₀.map (algebraMap ℚ (kN N)) with hyK
+  have hqK_map : qK.map (algebraMap (kN N) ℂ) = q := map_liftK q _
+  have hrK_map : rK.map (algebraMap (kN N) ℂ) = r := map_liftK r _
+  have hyK_map : yK.map (algebraMap (kN N) ℂ) = y₀.map (algebraMap ℚ ℂ) := map_rat_K y₀
+  have hidK : yK * qK = rK := map_K_injective (by rw [map_mul, hyK_map, hqK_map, hrK_map, hyq])
+  have hqK0 : qK ≠ 0 := by
+    intro h0; apply hq0; rw [← hqK_map, h0, map_zero]
+  have hbq : BddK qK := bddK_liftK hq _
+  have hbr : BddK rK := bddK_liftK hr _
+  set hK : PowerSeries (kN N) := ∏ σ : (kN N) ≃ₐ[ℚ] (kN N), autS σ qK with hhK
+  have hhK0 : hK ≠ 0 := by
+    rw [hhK, Finset.prod_ne_zero_iff]
+    intro σ _ h0
+    apply hqK0
+    apply autS_injective σ
+    rw [h0, map_zero]
+  have hbh : BddK hK := bddK_prod _ _ fun σ _ => hbq.autS σ
+  have hfix : ∀ τ : (kN N) ≃ₐ[ℚ] (kN N), autS τ hK = hK := by
+    intro τ
+    rw [hhK, map_prod]
+    simp_rw [autS_mul]
+    exact Fintype.prod_equiv (Equiv.mulLeft τ) _ _ fun σ => rfl
+  have hcoef : ∀ n, ∃ c : ℚ, hK.coeff n = algebraMap ℚ (kN N) c := by
+    intro n
+    apply exists_rat_of_fixed N
+    intro τ
+    have := congrArg (PowerSeries.coeff n) (hfix τ)
+    rwa [coeff_autS] at this
+  choose c hc using hcoef
+  set h₀ : PowerSeries ℚ := PowerSeries.mk c with hh₀
+  have hh₀_map : h₀.map (algebraMap ℚ (kN N)) = hK := by
+    ext n; rw [PowerSeries.coeff_map, hh₀, PowerSeries.coeff_mk, hc n]
+  have hyh : yK * hK = rK * ∏ σ ∈ (Finset.univ : Finset ((kN N) ≃ₐ[ℚ] (kN N))).erase 1, autS σ qK :=
+    by
+    rw [hhK, ← Finset.mul_prod_erase Finset.univ (fun σ => autS σ qK) (Finset.mem_univ 1), autS_one,
+      ← mul_assoc,
+      hidK]
+  have hbu : BddK (yK * hK) := by
+    rw [hyh]
+    exact hbr.mul (bddK_prod _ _ fun σ _ => hbq.autS σ)
+  refine ⟨h₀, h₀ * y₀, ?_, ?_, ?_, rfl⟩
+  · intro h0; apply hhK0; rw [← hh₀_map, h0, map_zero]
+  · exact bddQ_of_bddK_map (N := N) (by rw [hh₀_map]; exact hbh)
+  · apply bddQ_of_bddK_map (N := N)
+    rw [map_mul, hh₀_map, ← hyK, mul_comm]
+    exact hbu
+
+end Galois
+
+section Integral
+
+theorem exists_int_multiple {d : ℕ} (y₀ : PowerSeries ℚ) (c₀ : Fin d → PowerSeries ℚ)
+    (hc : ∀ i, BddQ (c₀ i))
+    (hrel : y₀ ^ d + ∑ i : Fin d, c₀ i * y₀ ^ (i : ℕ) = 0) (h₀ u₀ : PowerSeries ℚ) (hh0 : h₀ ≠ 0)
+    (hh : BddQ h₀) (hu : BddQ u₀) (hhy : h₀ * y₀ = u₀) :
+    ∃ (c : ℕ) (g : PowerSeries ℤ), c ≠ 0 ∧ g.map (Int.castRingHom ℚ) = (c : ℚ) • y₀ := by
+  classical
+  choose D C hD hC using hc
+  obtain ⟨Dh, H, hDh, hH⟩ := hh
+  obtain ⟨Du, U, hDu, hU⟩ := hu
+  set c : ℕ := ∏ i, D i with hcdef
+  have hc0 : c ≠ 0 := Finset.prod_ne_zero_iff.mpr fun i _ => hD i
+  set z : Fin d → ℕ := fun i => c ^ (d - 1 - i) * ∏ j ∈ Finset.univ.erase i, D j with hz
+  have hzid : ∀ i : Fin d, z i * D i * c ^ (i : ℕ) = c ^ d := by
+    intro i
+    have h1 : (∏ j ∈ Finset.univ.erase i, D j) * D i = c := by
+      rw [hcdef, Finset.prod_erase_mul _ _ (Finset.mem_univ i)]
+    have h2 : d - 1 - (i : ℕ) + 1 + i = d := by have := i.2; omega
+    calc z i * D i * c ^ (i : ℕ) = c ^ (d - 1 - i) * ((∏ j ∈ Finset.univ.erase i, D j) * D i) * c ^
+      (i : ℕ) := by
+          rw [hz]; ring
+      _ = c ^ (d - 1 - i) * c * c ^ (i : ℕ) := by rw [h1]
+      _ = c ^ (d - 1 - (i : ℕ) + 1 + i) := by rw [pow_add, pow_succ]
+      _ = c ^ d := by rw [h2]
+  set ι : PowerSeries ℤ →+* PowerSeries ℚ := PowerSeries.map (Int.castRingHom ℚ) with hι
+  set a : Fin d → PowerSeries ℤ := fun i => PowerSeries.C (z i : ℤ) * C i with ha
+  set Φ : Polynomial (PowerSeries ℤ) := Polynomial.X ^ d + ∑ i : Fin d, Polynomial.C (a i) *
+    Polynomial.X ^ (i : ℕ)
+    with hΦ
+  have hΦmonic : Φ.Monic := Polynomial.monic_X_pow_add (Polynomial.degree_sum_fin_lt a)
+  set g : PowerSeries ℚ := PowerSeries.C (c : ℚ) * y₀ with hg
+  have hιa : ∀ i, ι (a i) = PowerSeries.C ((z i : ℚ) * D i) * c₀ i := by
+    intro i
+    have h1 : ι (a i) = ι (PowerSeries.C (z i : ℤ)) * ι (C i) := by rw [ha, map_mul]
+    rw [h1, hC i, PowerSeries.smul_eq_C_mul, ← mul_assoc]
+    congr 1
+    rw [hι, PowerSeries.map_C, ← map_mul, eq_intCast, Int.cast_natCast]
+  have hroot : Polynomial.eval₂ ι g Φ = 0 := by
+    rw [hΦ, Polynomial.eval₂_add, Polynomial.eval₂_X_pow, Polynomial.eval₂_finsetSum]
+    simp only [Polynomial.eval₂_mul, Polynomial.eval₂_C, Polynomial.eval₂_X_pow, hιa]
+    have hterm : ∀ i : Fin d, PowerSeries.C ((z i : ℚ) * D i) * c₀ i * g ^ (i : ℕ)
+        = PowerSeries.C ((c : ℚ) ^ d) * (c₀ i * y₀ ^ (i : ℕ)) := by
+      intro i
+      have hnum : (z i : ℚ) * D i * (c : ℚ) ^ (i : ℕ) = (c : ℚ) ^ d := by exact_mod_cast hzid i
+      rw [hg, mul_pow, ← map_pow, ← hnum]
+      simp only [map_mul, map_pow]
+      ring
+    have hlead : g ^ d = PowerSeries.C ((c : ℚ) ^ d) * y₀ ^ d := by rw [hg, mul_pow, map_pow]
+    rw [Finset.sum_congr rfl fun i _ => hterm i, ← Finset.mul_sum, hlead, ← mul_add, hrel, mul_zero]
+  set h : PowerSeries ℤ := PowerSeries.C (Du : ℤ) * H with hh
+  have hH0 : H ≠ 0 := by
+    intro h0
+    have : (Dh : ℚ) • h₀ = 0 := by rw [← hH, h0, map_zero]
+    rcases smul_eq_zero.mp this with h1 | h1
+    · exact hDh (by exact_mod_cast h1)
+    · exact hh0 h1
+  have hh0' : h ≠ 0 := by
+    rw [hh]
+    refine mul_ne_zero ?_ hH0
+    intro h0
+    have := congrArg PowerSeries.constantCoeff h0
+    rw [PowerSeries.constantCoeff_C, map_zero] at this
+    exact hDu (by exact_mod_cast this)
+  have hmul : ι h * g ∈ ι.range := by
+    refine ⟨PowerSeries.C ((c * Dh : ℕ) : ℤ) * U, ?_⟩
+    rw [hh, map_mul, map_mul, hU, hH, hg, ← hhy]
+    simp only [hι, PowerSeries.smul_eq_C_mul, Nat.cast_mul,
+      map_natCast, map_mul]
+    ring
+  have hιalg : ι = PowerSeries.map (algebraMap ℤ ℚ) := by rw [hι, algebraMap_int_eq]
+  have key : g ∈ (PowerSeries.map (algebraMap ℤ ℚ)).range := by
+    rw [← hιalg]
+    exact PowerSeries.mem_range_map_of_monic_of_mul_mem_range g Φ hΦmonic (by
+      rw [← hιalg]; exact hroot) h hh0'
+      (by rw [← hιalg]; exact hmul)
+  obtain ⟨gZ, hgZ⟩ := key
+  refine ⟨c, gZ, hc0, ?_⟩
+  rw [hι, ← algebraMap_int_eq, hgZ, hg, PowerSeries.smul_eq_C_mul]
+
+end Integral
+
+section Main
+
+variable [NeZero N]
+
+local notation "Δ" => ModularForm.discriminant
+
+theorem main (m : ℕ) (G : ℍ → ℂ) (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (hinv : ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : ℍ, G (γ • τ) = G τ)
+    (hbd : ∀ α : SL(2, ℤ), IsBoundedAtImInfty ((fun τ : ℍ => G (α • τ)) * Δ ^ m))
+    (hrat : ∀ n : ℕ, ∃ r : ℚ, (qExpansion N (G * Δ ^ m)).coeff n = (r : ℂ)) :
+    ∃ D : ℤ, D ≠ 0 ∧ ∀ n : ℕ, ∃ z : ℤ, (D : ℂ) * (qExpansion N (G * Δ ^ m)).coeff n = (z : ℂ) := by
+  classical
+  obtain ⟨L, d, y₀, c₀, q, r, hy₀, hc₀, hrel, hq0, hq, hr, hyq⟩ :=
+    exists_series_data (N := N) m G hG hinv hbd hrat
+  obtain ⟨h₀, u₀, hh0, hh, hu, hhy⟩ := galois_descent (N := N) y₀ q r hq0 hq hr hyq
+  obtain ⟨c, gZ, hc0, hgZ⟩ := exists_int_multiple y₀ c₀ hc₀ hrel h₀ u₀ hh0 hh hu hhy
+  set Ghat : PowerSeries ℂ := qExpansion N (G * Δ ^ m) with hGhat
+  have hC : gZ.map (Int.castRingHom ℂ) = (PowerSeries.C (c : ℂ) * Ghat * ((UZ (N := N)) ^ L).map
+    (Int.castRingHom ℂ))
+      * PowerSeries.X ^ (N * L) := by
+    rw [← map_int_rat, hgZ, PowerSeries.smul_eq_C_mul, map_mul, PowerSeries.map_C, hy₀, ← map_DZ,
+      DZ_eq, map_pow,
+      map_mul, map_pow, PowerSeries.map_X]
+    simp only [map_natCast]
+    rw [hGhat]
+    ring
+  have hdvd : (PowerSeries.X : PowerSeries ℤ) ^ (N * L) ∣ gZ := by
+    rw [PowerSeries.X_pow_dvd_iff]
+    intro k hk
+    have h1 := congrArg (PowerSeries.coeff k) hC
+    rw [PowerSeries.coeff_map, mul_comm, PowerSeries.coeff_X_pow_mul', ite_eq_right (not_le.mpr hk),
+      eq_intCast] at h1
+    exact_mod_cast h1
+  obtain ⟨g', hg'⟩ := hdvd
+  have hC' : g'.map (Int.castRingHom ℂ) = PowerSeries.C (c : ℂ) * Ghat * ((UZ (N := N)) ^ L).map
+    (Int.castRingHom ℂ) :=
+    by
+    have h1 := hC
+    rw [hg', map_mul, map_pow, PowerSeries.map_X, mul_comm] at h1
+    exact mul_right_cancel₀ (pow_ne_zero _ PowerSeries.X_ne_zero) h1
+  have hUunit : IsUnit ((UZ (N := N)) ^ L) := by
+    refine IsUnit.pow L ?_
+    rw [PowerSeries.isUnit_iff_constantCoeff, constantCoeff_UZ]; exact isUnit_one
+  obtain ⟨w, hw⟩ := hUunit
+  have hfinal : (g' * ↑w⁻¹).map (Int.castRingHom ℂ) = PowerSeries.C (c : ℂ) * Ghat := by
+    rw [map_mul, hC', hw.symm, mul_assoc, ← map_mul, Units.mul_inv, map_one, mul_one]
+  refine ⟨c, by exact_mod_cast hc0, fun n => ⟨PowerSeries.coeff n (g' * ↑w⁻¹), ?_⟩⟩
+  have := congrArg (PowerSeries.coeff n) hfinal
+  rw [PowerSeries.coeff_map, PowerSeries.coeff_C_mul, eq_intCast] at this
+  push_cast
+  rw [← this]
+
+end Main
+
+end GammaNBounded
+end
+
+open scoped MatrixGroups Manifold in
+theorem solution
+    (N : ℕ) [NeZero N] (m : ℕ) (G : UpperHalfPlane → ℂ) (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (hinv : ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : UpperHalfPlane, G (γ • τ) = G τ)
+    (hbd : ∀ α : SL(2, ℤ), UpperHalfPlane.IsBoundedAtImInfty
+      ((fun τ : UpperHalfPlane => G (α • τ)) * ModularForm.discriminant ^ m))
+    (hrat : ∀ n : ℕ, ∃ r : ℚ,
+      (UpperHalfPlane.qExpansion N (G * ModularForm.discriminant ^ m)).coeff n = (r : ℂ)) :
+    ∃ D : ℤ, D ≠ 0 ∧ ∀ n : ℕ, ∃ z : ℤ,
+      (D : ℂ) * (UpperHalfPlane.qExpansion N (G * ModularForm.discriminant ^ m)).coeff n = (z : ℂ)
+        :=
+  GammaNBounded.main N m G hG hinv hbd hrat
+
+end S_ModularCurve_exists_ne_zero_forall_intCast_mul_qExpansion_coeff_of_gamma_invariant
+end P2MW
+export P2MW.S_ModularCurve_exists_ne_zero_forall_intCast_mul_qExpansion_coeff_of_gamma_invariant
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups Manifold in
+theorem ModularCurve.exists_ne_zero_forall_intCast_mul_qExpansion_coeff_of_gamma_invariant
+    (N : ℕ) [NeZero N] (m : ℕ) (G : UpperHalfPlane → ℂ) (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (hinv : ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : UpperHalfPlane, G (γ • τ) = G τ)
+    (hbd : ∀ α : SL(2, ℤ), UpperHalfPlane.IsBoundedAtImInfty
+      ((fun τ : UpperHalfPlane => G (α • τ)) * ModularForm.discriminant ^ m))
+    (hrat : ∀ n : ℕ, ∃ r : ℚ,
+      (UpperHalfPlane.qExpansion N (G * ModularForm.discriminant ^ m)).coeff n = (r : ℂ)) :
+    ∃ D : ℤ, D ≠ 0 ∧ ∀ n : ℕ, ∃ z : ℤ,
+      (D : ℂ) * (UpperHalfPlane.qExpansion N (G * ModularForm.discriminant ^ m)).coeff n = (z : ℂ)
+        :=
+  solution N m G hG hinv hbd hrat
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_ne_zero_forall_mul_qExpansion_coeff_fricke_mem_adjoin.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_ne_zero_forall_mul_qExpansion_coeff_fricke_mem_adjoin.lean
new file mode 100644
index 0000000000..8ef8f30d10
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_ne_zero_forall_mul_qExpansion_coeff_fricke_mem_adjoin.lean
@@ -0,0 +1,847 @@
+/-
+Based on Prove2Me node ModularCurve.exists_ne_zero_forall_mul_qExpansion_coeff_fricke_mem_adjoin
+(288a97f3-029f-5b98-b6f6-22b97bff878f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e3270144-e747-57ee-b928-eadfd2ed99ad
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.SpecialFunctions.Elliptic.Weierstrass
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import Mathlib.Topology.UniformSpace.Uniformizable
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_weierstrassP_qExpansion_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Bounded denominators for Fricke functions of level N
+
+Theorem statement: `ModularCurve.exists_ne_zero_forall_mul_qExpansion_coeff_fricke_mem_adjoin`
+(`288a97f3-029f-5b98-b6f6-22b97bff878f`), by Claude, 2026-09-05.
+
+Proof: submission `e3270144-e747-57ee-b928-eadfd2ed99ad`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $N$, assumed non-zero. Let $L$ assign to each point $\tau$ of the upper
+half-plane a pair of periods, subject to the hypothesis that for every $\tau$ the first period of
+$L\tau$ is $\tau$ and the second is $1$, so that $L\tau$ presents the lattice
+$\mathbb{Z}\tau+\mathbb{Z}$. Let $W$ assign to each $v\in(\mathbb{Z}/N)^2$ a function on the upper
+half-plane, subject to the hypothesis that for all $v$ and $\tau$, $W_v(\tau)=(2\pi
+i)^{-2}\,\wp_{L\tau}\!\big((\tilde v_0\tau+\tilde v_1)/N\big)$, where $\tilde v_0,\tilde v_1$ denote
+the canonical representatives in $\{0,\dots,N-1\}$ of the two components of $v$ and $\wp$ is the
+Weierstrass function of the period pair $L\tau$. Let $\mathit{fricke}$ likewise assign functions to
+elements $v$, subject to the hypothesis
+$\mathit{fricke}_v(\tau)=-\big(E_4(\tau)E_6(\tau)/\Delta(\tau)\big)/2592\cdot W_v(\tau)$. Let $v\neq
+0$. Then there exists a non-zero natural number $D$ such that for every $n\in\mathbb{N}$ the product
+of $D$ with the $n$-th coefficient of the $q$-expansion of period $N$ of the pointwise product
+$\mathit{fricke}_v\cdot\Delta$ lies in the subring of $\mathbb{C}$ generated over $\mathbb{Z}$ by
+$\exp(2\pi i/N)$, that is, in $\mathbb{Z}[\zeta_N]$. The single $D$ works for all $n$
+simultaneously.
+
+This is the classical integrality statement for the Fricke functions of level $N$: the Fourier
+expansion of $f_v\Delta$ at the cusp $\infty$, in the variable $q_N=e^{2\pi i\tau/N}$, has
+coefficients in $\mathbb{Q}(\zeta_N)$ with denominators bounded independently of the coefficient
+index. It feeds the construction of models of modular curves over cyclotomic fields, being used here
+by
+[`ModularCurve.exists_ne_zero_forall_intCast_mul_qExpansion_coeff_of_gamma_invariant`]
+(thm.html#ModularCurve.exists_ne_zero_forall_intCast_mul_qExpansion_coeff_of_gamma_invariant).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_ne_zero_forall_mul_qExpansion_coeff_fricke_mem_adjoin.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_ModularCurve_exists_ne_zero_forall_mul_qExpansion_coeff_fricke_mem_adjoin
+
+noncomputable section
+
+open Complex UpperHalfPlane ModularForm Function Filter Topology
+open scoped Real Manifold MatrixGroups ModularForm Topology
+
+namespace FrickeIntegral
+
+variable (N : ℕ) [NeZero N]
+
+def zeta : ℂ := cexp (2 * π * Complex.I / N)
+
+def AZ : Subalgebra ℤ ℂ := Algebra.adjoin ℤ {zeta N}
+
+omit [NeZero N] in
+theorem zeta_mem : zeta N ∈ AZ N := Algebra.subset_adjoin (Set.mem_singleton _)
+
+theorem isPrimitiveRoot_zeta :
+    IsPrimitiveRoot (zeta N) N := Complex.isPrimitiveRoot_exp N (NeZero.ne N)
+
+theorem zeta_pow_N : zeta N ^ N = 1 := (isPrimitiveRoot_zeta N).pow_eq_one
+
+omit [NeZero N] in
+theorem zeta_ne_zero : zeta N ≠ 0 := by unfold zeta; exact exp_ne_zero _
+
+theorem norm_zeta : ‖zeta N‖ = 1 := (isPrimitiveRoot_zeta N).norm'_eq_one (NeZero.ne N)
+
+theorem zeta_inv_mem : (zeta N)⁻¹ ∈ AZ N := by
+  have hN : 0 < N := NeZero.pos N
+  have : (zeta N)⁻¹ = zeta N ^ (N - 1) := by
+    rw [eq_comm, ← mul_inv_eq_one₀ (inv_ne_zero (zeta_ne_zero N)), inv_inv, ← pow_succ,
+      Nat.sub_add_cancel hN, zeta_pow_N]
+  rw [this]; exact pow_mem (zeta_mem N) _
+
+omit [NeZero N] in
+theorem intCast_mem (z : ℤ) : (z : ℂ) ∈ AZ N := by exact_mod_cast (AZ N).algebraMap_mem z
+
+omit [NeZero N] in
+theorem natCast_mem (n : ℕ) : (n : ℂ) ∈ AZ N := by exact_mod_cast intCast_mem N n
+
+theorem exists_mul_one_sub_eq {a : ℕ} (ha : 0 < a) (haN : a < N) :
+    ∃ y ∈ AZ N, y * (1 - zeta N ^ a) = N := by
+  set x : ℂ := zeta N ^ a with hx
+  have hx1 : x ≠ 1 := by
+    rw [hx]
+    exact (isPrimitiveRoot_zeta N).pow_ne_one_of_pos_of_lt ha.ne' haN
+  have hxN : x ^ N = 1 := by rw [hx, ← pow_mul, mul_comm, pow_mul, zeta_pow_N, one_pow]
+  have hgeom : ∑ k ∈ Finset.range N, x ^ k = 0 := by
+    rw [geom_sum_eq hx1, hxN, sub_self, zero_div]
+  refine ⟨∑ k ∈ Finset.range N, ∑ j ∈ Finset.range k, x ^ j, ?_, ?_⟩
+  · refine sum_mem fun k _ => sum_mem fun j _ => ?_
+    rw [hx, ← pow_mul]; exact pow_mem (zeta_mem N) _
+  · calc (∑ k ∈ Finset.range N, ∑ j ∈ Finset.range k, x ^ j) * (1 - x)
+        = ∑ k ∈ Finset.range N, (1 - x ^ k) := by
+          rw [Finset.sum_mul]
+          refine Finset.sum_congr rfl fun k _ => ?_
+          rw [mul_comm, mul_neg_geom_sum]
+      _ = ∑ k ∈ Finset.range N, (1 : ℂ) - ∑ k ∈ Finset.range N, x ^ k := Finset.sum_sub_distrib _ _
+      _ = N := by rw [hgeom, sub_zero]; simp
+
+section Coeff
+
+variable (a₁ a₂ : ℕ)
+
+abbrev Idx : Type := (ℕ+ × ℕ+) × Fin 3
+
+def expo (i : Idx) : ℕ :=
+  ![((i.1.1 : ℕ) * N + a₁) * (i.1.2 : ℕ), ((i.1.1 : ℕ) * N - a₁) * (i.1.2 : ℕ), (i.1.1 : ℕ) * N *
+    (i.1.2 : ℕ)] i.2
+
+def coef (i : Idx) : ℂ :=
+  ![((i.1.2 : ℕ) : ℂ) * zeta N ^ (a₂ * (i.1.2 : ℕ)), ((i.1.2 : ℕ) : ℂ) * (zeta N)⁻¹ ^ (a₂ * (i.1.2 :
+    ℕ)),
+    -2 * ((i.1.2 : ℕ) : ℂ)] i.2
+
+theorem coef_mem (i : Idx) : coef N a₂ i ∈ AZ N := by
+  rcases i with ⟨p, j⟩
+  fin_cases j
+  · exact mul_mem (natCast_mem N _) (pow_mem (zeta_mem N) _)
+  · exact mul_mem (natCast_mem N _) (pow_mem (zeta_inv_mem N) _)
+  · change -2 * ((p.2 : ℕ) : ℂ) ∈ AZ N
+    exact mul_mem (by exact_mod_cast intCast_mem N (-2)) (natCast_mem N _)
+
+theorem norm_coef_le (i : Idx) : ‖coef N a₂ i‖ ≤ 2 * (i.1.2 : ℕ) := by
+  rcases i with ⟨p, j⟩
+  have h1 : (0 : ℝ) ≤ (p.2 : ℕ) := Nat.cast_nonneg _
+  fin_cases j
+  · change ‖((p.2 : ℕ) : ℂ) * zeta N ^ (a₂ * (p.2 : ℕ))‖ ≤ 2 * (p.2 : ℕ)
+    rw [norm_mul, norm_pow, norm_zeta, one_pow, mul_one, Complex.norm_natCast]; linarith
+  · change ‖((p.2 : ℕ) : ℂ) * (zeta N)⁻¹ ^ (a₂ * (p.2 : ℕ))‖ ≤ 2 * (p.2 : ℕ)
+    rw [norm_mul, norm_pow, norm_inv, norm_zeta, inv_one, one_pow, mul_one,
+      Complex.norm_natCast]; linarith
+  · change ‖-2 * ((p.2 : ℕ) : ℂ)‖ ≤ 2 * (p.2 : ℕ)
+    rw [norm_mul, norm_neg, Complex.norm_natCast]; norm_num
+
+variable {N a₁} in
+theorem mul_le_expo (ha : a₁ < N) (i : Idx) : (i.1.1 : ℕ) * (i.1.2 : ℕ) ≤ expo N a₁ i := by
+  rcases i with ⟨⟨c, k⟩, j⟩
+  have hc : 1 ≤ (c : ℕ) := c.2
+  have hcN : (c : ℕ) ≤ (c : ℕ) * N - a₁ := by
+    have : (c : ℕ) * N ≥ (c : ℕ) + a₁ := by
+      have h1 : (c : ℕ) * N = (c : ℕ) * (N - 1) + c := by
+        rw [Nat.mul_sub, mul_one, Nat.sub_add_cancel (Nat.le_mul_of_pos_right _ (NeZero.pos N))]
+      have h2 : a₁ ≤ (c : ℕ) * (N - 1) := le_trans (by omega) (Nat.le_mul_of_pos_left _ hc)
+      omega
+    omega
+  fin_cases j
+  · change (c : ℕ) * (k : ℕ) ≤ ((c : ℕ) * N + a₁) * (k : ℕ)
+    exact Nat.mul_le_mul_right _ (le_trans (Nat.le_mul_of_pos_right _ (NeZero.pos N))
+      (Nat.le_add_right _ _))
+  · change (c : ℕ) * (k : ℕ) ≤ ((c : ℕ) * N - a₁) * (k : ℕ)
+    exact Nat.mul_le_mul_right _ hcN
+  · change (c : ℕ) * (k : ℕ) ≤ (c : ℕ) * N * (k : ℕ)
+    exact Nat.mul_le_mul_right _ (Nat.le_mul_of_pos_right _ (NeZero.pos N))
+
+variable {N a₁} in
+theorem fst_le_expo (ha : a₁ < N) (i : Idx) : (i.1.1 : ℕ) ≤ expo N a₁ i :=
+  le_trans (Nat.le_mul_of_pos_right _ i.1.2.2) (mul_le_expo ha i)
+
+variable {N a₁} in
+theorem snd_le_expo (ha : a₁ < N) (i : Idx) : (i.1.2 : ℕ) ≤ expo N a₁ i :=
+  le_trans (Nat.le_mul_of_pos_left _ i.1.1.2) (mul_le_expo ha i)
+
+variable [Fact (a₁ < N)]
+
+def fibreMap (n : ℕ) :
+    {i : Idx // expo N a₁ i = n} → (Fin (n + 1) × Fin (n + 1)) × Fin 3 := fun i =>
+  ((⟨(i.1.1.1 : ℕ), Nat.lt_succ_of_le (le_trans (fst_le_expo (Fact.out : a₁ < N) i.1) i.2.le)⟩,
+    ⟨(i.1.1.2 : ℕ), Nat.lt_succ_of_le (le_trans (snd_le_expo (Fact.out : a₁ < N) i.1) i.2.le)⟩),
+      i.1.2)
+
+theorem fibreMap_injective (n : ℕ) : Function.Injective (fibreMap N a₁ n) := by
+  rintro ⟨⟨⟨c, k⟩, j⟩, hi⟩ ⟨⟨⟨c', k'⟩, j'⟩, hi'⟩ h
+  simp only [fibreMap, Prod.mk.injEq, Fin.mk.injEq] at h
+  obtain ⟨⟨h1, h2⟩, h3⟩ := h
+  have hc : c = c' := PNat.coe_injective h1
+  have hk : k = k' := PNat.coe_injective h2
+  subst hc; subst hk; subst h3
+  rfl
+
+scoped instance fintypeFibre (n : ℕ) : Fintype {i : Idx // expo N a₁ i = n} :=
+  @Fintype.ofFinite _ (Finite.of_injective _ (fibreMap_injective N a₁ n))
+
+def cT (n : ℕ) : ℂ :=
+  ∑ i : {i : Idx // expo N a₁ i = n}, coef N a₂ i.1
+
+theorem cT_mem (n : ℕ) : cT N a₁ a₂ n ∈ AZ N :=
+  sum_mem fun i _ => coef_mem N a₂ i.1
+
+theorem card_fibre_le (n : ℕ) :
+    Fintype.card {i : Idx // expo N a₁ i = n} ≤ (n + 1) * (n + 1) * 3 := by
+  have := Fintype.card_le_of_injective _ (fibreMap_injective N a₁ n)
+  simpa [Fintype.card_prod, Fintype.card_fin] using this
+
+theorem norm_cT_le (n : ℕ) : ‖cT N a₁ a₂ n‖ ≤ (n + 1) * (n + 1) * 3 * (2 * n) := by
+  unfold cT
+  calc ‖∑ i : {i : Idx // expo N a₁ i = n}, coef N a₂ i.1‖
+      ≤ ∑ i : {i : Idx // expo N a₁ i = n}, ‖coef N a₂ i.1‖ := norm_sum_le _ _
+    _ ≤ ∑ _i : {i : Idx // expo N a₁ i = n}, (2 * n : ℝ) := by
+        refine Finset.sum_le_sum fun i _ => le_trans (norm_coef_le N a₂ i.1) ?_
+        have h1 := snd_le_expo (Fact.out : a₁ < N) i.1
+        rw [i.2] at h1
+        have h2 : ((i.1.1.2 : ℕ) : ℝ) ≤ n := by exact_mod_cast h1
+        linarith
+    _ = Fintype.card {i : Idx // expo N a₁ i = n} * (2 * n : ℝ) := by
+      rw [Finset.sum_const, nsmul_eq_mul]; rfl
+    _ ≤ (n + 1) * (n + 1) * 3 * (2 * n) := by
+        have h1 : (Fintype.card {i : Idx // expo N a₁ i = n} : ℝ) ≤ (n + 1) * (n + 1) * 3 := by
+          exact_mod_cast card_fibre_le N a₁ n
+        have h2 : (0 : ℝ) ≤ 2 * n := by positivity
+        exact mul_le_mul_of_nonneg_right h1 h2
+
+def cA (n : ℕ) : ℂ :=
+  if a₁ = 0 then 0 else if a₁ ∣ n then ((n / a₁ : ℕ) : ℂ) * zeta N ^ (a₂ * (n / a₁)) else 0
+
+omit [Fact (a₁ < N)] in
+omit [NeZero N] in
+theorem cA_mem (n : ℕ) : cA N a₁ a₂ n ∈ AZ N := by
+  unfold cA
+  split_ifs
+  · exact zero_mem _
+  · exact mul_mem (natCast_mem N _) (pow_mem (zeta_mem N) _)
+  · exact zero_mem _
+
+omit [Fact (a₁ < N)] in
+theorem norm_cA_le (n : ℕ) : ‖cA N a₁ a₂ n‖ ≤ n := by
+  unfold cA
+  split_ifs with h1 h2
+  · simp
+  · rw [norm_mul, norm_pow, norm_zeta, one_pow, mul_one, Complex.norm_natCast]
+    exact_mod_cast Nat.div_le_self n a₁
+  · simp
+
+def c0 : ℂ := 1 / 12 + if a₁ = 0 then zeta N ^ a₂ / (1 - zeta N ^ a₂) ^ 2 else 0
+
+omit [Fact (a₁ < N)] in
+theorem c0_mem (ha₂ : a₂ < N) (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) : (12 * (N : ℂ) ^ 2) * c0 N a₁ a₂ ∈ AZ N := by
+  unfold c0
+  split_ifs with h1
+  · have ha₂' : 0 < a₂ := by
+      rcases h0 with h | h
+      · exact absurd h1 h
+      · exact Nat.pos_of_ne_zero h
+    obtain ⟨y, hy, hyN⟩ := exists_mul_one_sub_eq N ha₂' ha₂
+    have hne : (1 - zeta N ^ a₂) ≠ 0 :=
+      sub_ne_zero.mpr (Ne.symm ((isPrimitiveRoot_zeta N).pow_ne_one_of_pos_of_lt ha₂'.ne' ha₂))
+    have : (12 * (N : ℂ) ^ 2) * (1 / 12 + zeta N ^ a₂ / (1 - zeta N ^ a₂) ^ 2)
+        = (N : ℂ) ^ 2 + 12 * zeta N ^ a₂ * y ^ 2 := by
+      rw [← hyN]; field_simp
+    rw [this]
+    exact add_mem (pow_mem (natCast_mem N N) 2)
+      (mul_mem (mul_mem (natCast_mem N 12) (pow_mem (zeta_mem N) _)) (pow_mem hy 2))
+  · rw [add_zero]
+    have : (12 * (N : ℂ) ^ 2) * (1 / 12) = (N : ℂ) ^ 2 := by ring
+    rw [this]; exact pow_mem (natCast_mem N N) 2
+
+def cW (n : ℕ) : ℂ :=
+  cA N a₁ a₂ n + (if n = 0 then c0 N a₁ a₂ else 0) + cT N a₁ a₂ n
+
+theorem cW_mem (ha₂ : a₂ < N) (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) (n : ℕ) :
+    (12 * (N : ℂ) ^ 2) * cW N a₁ a₂ n ∈ AZ N := by
+  unfold cW
+  rw [mul_add, mul_add]
+  refine add_mem (add_mem ?_ ?_) ?_
+  · exact mul_mem (mul_mem (natCast_mem N 12) (pow_mem (natCast_mem N N) 2)) (cA_mem N a₁ a₂ n)
+  · split_ifs
+    · exact c0_mem N a₁ a₂ ha₂ h0
+    · rw [mul_zero]; exact zero_mem _
+  · exact mul_mem (mul_mem (natCast_mem N 12) (pow_mem (natCast_mem N N) 2)) (cT_mem N a₁ a₂ n)
+
+theorem norm_cW_le (n : ℕ) : ‖cW N a₁ a₂ n‖ ≤ ‖c0 N a₁ a₂‖ + 8 * (n + 1) ^ 3 := by
+  unfold cW
+  have h1 := norm_cA_le N a₁ a₂ n
+  have h3 := norm_cT_le N a₁ a₂ n
+  have h2 : ‖(if n = 0 then c0 N a₁ a₂ else 0)‖ ≤ ‖c0 N a₁ a₂‖ := by split_ifs <;> simp
+  have hn : (0 : ℝ) ≤ n := Nat.cast_nonneg n
+  calc ‖cA N a₁ a₂ n + (if n = 0 then c0 N a₁ a₂ else 0) + cT N a₁ a₂ n‖
+      ≤ ‖cA N a₁ a₂ n‖ + ‖(if n = 0 then c0 N a₁ a₂ else 0)‖ + ‖cT N a₁ a₂ n‖ := norm_add₃_le
+    _ ≤ n + ‖c0 N a₁ a₂‖ + (n + 1) * (n + 1) * 3 * (2 * n) := by linarith
+    _ ≤ ‖c0 N a₁ a₂‖ + 8 * (n + 1) ^ 3 := by nlinarith
+
+end Coeff
+
+section Series
+
+variable (a₁ a₂ : ℕ)
+
+def qq (τ : ℍ) : ℂ := cexp (2 * π * Complex.I * (τ : ℂ) / N)
+
+omit [NeZero N] in
+theorem qq_eq (τ : ℍ) : qq N τ = Periodic.qParam N τ := by
+  unfold qq Periodic.qParam
+  norm_cast
+
+omit [NeZero N] in
+theorem norm_qq (τ : ℍ) : ‖qq N τ‖ = Real.exp (-2 * π * τ.im / N) := by
+  rw [qq_eq, Periodic.norm_qParam]; rfl
+
+theorem norm_qq_lt_one (τ : ℍ) : ‖qq N τ‖ < 1 := by
+  rw [norm_qq, Real.exp_lt_one_iff]
+  have h1 : 0 < 2 * π * τ.im / N := by
+    have := τ.im_pos; have hN : (0 : ℝ) < N := Nat.cast_pos.mpr (NeZero.pos N); positivity
+  have h2 : -2 * π * τ.im / N = -(2 * π * τ.im / N) := by ring
+  rw [h2]; linarith
+
+omit [NeZero N] in
+theorem norm_qq_pos (τ : ℍ) : 0 < ‖qq N τ‖ := by rw [norm_qq]; exact Real.exp_pos _
+
+def Gt (τ : ℍ) (i : Idx) : ℂ := coef N a₂ i * qq N τ ^ expo N a₁ i
+
+def Ft (τ : ℍ) (p : ℕ+ × ℕ+) : ℂ := ∑ j : Fin 3, Gt N a₁ a₂ τ (p, j)
+
+omit [NeZero N] in
+theorem coef_zero (p : ℕ+ × ℕ+) :
+    coef N a₂ (p, 0) = ((p.2 : ℕ) : ℂ) * zeta N ^ (a₂ * (p.2 : ℕ)) := rfl
+omit [NeZero N] in
+theorem coef_one (p : ℕ+ × ℕ+) :
+    coef N a₂ (p, 1) = ((p.2 : ℕ) : ℂ) * (zeta N)⁻¹ ^ (a₂ * (p.2 : ℕ)) := rfl
+omit [NeZero N] in
+theorem coef_two (p : ℕ+ × ℕ+) : coef N a₂ (p, 2) = -2 * ((p.2 : ℕ) : ℂ) := rfl
+omit [NeZero N] in
+theorem expo_zero (p : ℕ+ × ℕ+) : expo N a₁ (p, 0) = ((p.1 : ℕ) * N + a₁) * (p.2 : ℕ) := rfl
+omit [NeZero N] in
+theorem expo_one (p : ℕ+ × ℕ+) : expo N a₁ (p, 1) = ((p.1 : ℕ) * N - a₁) * (p.2 : ℕ) := rfl
+omit [NeZero N] in
+theorem expo_two (p : ℕ+ × ℕ+) : expo N a₁ (p, 2) = (p.1 : ℕ) * N * (p.2 : ℕ) := rfl
+
+omit [NeZero N] in
+theorem Ft_eq (τ : ℍ) (p : ℕ+ × ℕ+) : Ft N a₁ a₂ τ p =
+    ((p.2 : ℕ) : ℂ) * (zeta N ^ (a₂ * (p.2 : ℕ)) * qq N τ ^ (((p.1 : ℕ) * N + a₁) * (p.2 : ℕ)) +
+      (zeta N)⁻¹ ^ (a₂ * (p.2 : ℕ)) * qq N τ ^ (((p.1 : ℕ) * N - a₁) * (p.2 : ℕ)) -
+      2 * qq N τ ^ ((p.1 : ℕ) * N * (p.2 : ℕ))) := by
+  rw [Ft, Fin.sum_univ_three, Gt, Gt, Gt, coef_zero, coef_one, coef_two, expo_zero, expo_one,
+    expo_two]
+  ring
+
+theorem summable_majorant {r : ℝ} (hr0 : 0 ≤ r) (hr1 : r < 1) :
+    Summable (fun p : ℕ+ × ℕ+ => r ^ ((p.1 : ℕ) - 1) * (((p.2 : ℕ) : ℝ) * r ^ (p.2 : ℕ))) := by
+  have hnr : ‖r‖ < 1 := by rw [Real.norm_eq_abs, abs_of_nonneg hr0]; exact hr1
+  have h1 : Summable (fun k : ℕ+ => ((k : ℕ) : ℝ) * r ^ (k : ℕ)) := by
+    have h := (summable_pow_mul_geometric_of_norm_lt_one 1 hnr).comp_injective PNat.coe_injective
+    refine h.congr fun k => ?_
+    simp only [Function.comp_apply, pow_one]
+  have h2 : Summable (fun c : ℕ+ => r ^ ((c : ℕ) - 1)) := by
+    have h := (summable_geometric_of_lt_one hr0 hr1).comp_injective PNat.natPred_injective
+    refine h.congr fun c => ?_
+    simp only [Function.comp_apply, PNat.natPred]
+  have h1' : Summable (fun k : ℕ+ => ‖((k : ℕ) : ℝ) * r ^ (k : ℕ)‖) := by
+    refine h1.abs.congr fun k => ?_
+    exact (Real.norm_eq_abs _).symm
+  have h2' : Summable (fun c : ℕ+ => ‖r ^ ((c : ℕ) - 1)‖) := by
+    refine h2.abs.congr fun c => ?_
+    exact (Real.norm_eq_abs _).symm
+  have key := summable_mul_of_summable_norm (R := ℝ) h2' h1'
+  exact key
+
+theorem norm_Gt_le (ha : a₁ < N) (τ : ℍ) (i : Idx) :
+    ‖Gt N a₁ a₂ τ i‖ ≤ 2 * (‖qq N τ‖ ^ ((i.1.1 : ℕ) - 1) * (((i.1.2 : ℕ) : ℝ) * ‖qq N τ‖ ^ (i.1.2 :
+      ℕ))) := by
+  set r : ℝ := ‖qq N τ‖ with hr
+  have hr0 : 0 ≤ r := norm_nonneg _
+  have hr1 : r ≤ 1 := (norm_qq_lt_one N τ).le
+  have hc : 1 ≤ (i.1.1 : ℕ) := i.1.1.2
+  have hk : 1 ≤ (i.1.2 : ℕ) := i.1.2.2
+  have hexp : (i.1.2 : ℕ) + ((i.1.1 : ℕ) - 1) ≤ expo N a₁ i := by
+    refine le_trans ?_ (mul_le_expo ha i)
+    have : ((i.1.1 : ℕ) - 1) * ((i.1.2 : ℕ) - 1) + ((i.1.2 : ℕ) + ((i.1.1 : ℕ) - 1)) = (i.1.1 : ℕ) *
+      (i.1.2 : ℕ) :=
+      by
+      zify [hc, hk]; ring
+    omega
+  rw [Gt, norm_mul, norm_pow, ← hr]
+  have hpow : r ^ expo N a₁ i ≤ r ^ ((i.1.2 : ℕ) + ((i.1.1 : ℕ) - 1)) :=
+    pow_le_pow_of_le_one hr0 hr1 hexp
+  calc ‖coef N a₂ i‖ * r ^ expo N a₁ i ≤ (2 * (i.1.2 : ℕ)) * r ^ ((i.1.2 : ℕ) + ((i.1.1 : ℕ) - 1))
+    :=
+        mul_le_mul (norm_coef_le N a₂ i) hpow (pow_nonneg hr0 _) (by positivity)
+    _ = 2 * (r ^ ((i.1.1 : ℕ) - 1) * (((i.1.2 : ℕ) : ℝ) * r ^ (i.1.2 : ℕ))) := by rw [pow_add]; ring
+
+theorem summable_norm_Gt (ha : a₁ < N) (τ : ℍ) : Summable (fun i : Idx => ‖Gt N a₁ a₂ τ i‖) := by
+  set r : ℝ := ‖qq N τ‖ with hr
+  set M : ℕ+ × ℕ+ → ℝ := fun p => 2 * (r ^ ((p.1 : ℕ) - 1) * (((p.2 : ℕ) : ℝ) * r ^ (p.2 : ℕ))) with
+    hM
+  have hMs : Summable M := (summable_majorant (norm_nonneg _) (norm_qq_lt_one N τ)).mul_left 2
+  have hM0 : ∀ p, 0 ≤ M p := fun p => by rw [hM]; positivity
+  have hMaj : Summable (fun i : Idx => M i.1) := by
+    rw [summable_prod_of_nonneg (fun i => hM0 i.1)]
+    refine ⟨fun p => ?_, ?_⟩
+    · exact (hasSum_fintype _).summable
+    · simp only [tsum_fintype, Finset.sum_const, Finset.card_univ, Fintype.card_fin, nsmul_eq_mul]
+      exact hMs.mul_left _
+  refine Summable.of_nonneg_of_le (fun i => norm_nonneg _) (fun i => ?_) hMaj
+  exact norm_Gt_le N a₁ a₂ ha τ i
+
+theorem summable_Gt (ha : a₁ < N) (τ : ℍ) :
+    Summable (Gt N a₁ a₂ τ) := (summable_norm_Gt N a₁ a₂ ha τ).of_norm
+
+theorem hasSum_Ft (ha : a₁ < N) (τ : ℍ) : HasSum (Ft N a₁ a₂ τ) (∑' i, Gt N a₁ a₂ τ i) := by
+  apply (summable_Gt N a₁ a₂ ha τ).hasSum.prod_fiberwise
+  intro
+  exact hasSum_fintype _
+
+variable [Fact (a₁ < N)]
+
+theorem hasSum_cT (τ : ℍ) : HasSum (fun n => cT N a₁ a₂ n * qq N τ ^ n) (∑' i, Gt N a₁ a₂ τ i) := by
+  have ha : a₁ < N := Fact.out
+  have h1 : HasSum (Gt N a₁ a₂ τ ∘ Equiv.sigmaFiberEquiv (expo N a₁)) (∑' i, Gt N a₁ a₂ τ i) :=
+    (Equiv.hasSum_iff _).mpr (summable_Gt N a₁ a₂ ha τ).hasSum
+  refine h1.sigma fun n => ?_
+  have h2 : (fun c : {i : Idx // expo N a₁ i = n} => (Gt N a₁ a₂ τ ∘ Equiv.sigmaFiberEquiv (expo N
+    a₁)) ⟨n, c⟩)
+      = fun c => coef N a₂ c.1 * qq N τ ^ n := by
+    funext c
+    simp only [comp_apply, Equiv.sigmaFiberEquiv, Equiv.coe_fn_mk, Gt]
+    rw [c.2]
+  rw [h2]
+  have h3 : cT N a₁ a₂ n * qq N τ ^ n = ∑ c : {i : Idx // expo N a₁ i = n}, coef N a₂ c.1 * qq N τ ^
+    n :=
+    by
+    rw [cT, Finset.sum_mul]
+  rw [h3]
+  exact hasSum_fintype _
+
+omit [Fact (a₁ < N)] in
+theorem hasSum_cA (τ : ℍ) (ha0 : a₁ ≠ 0) :
+    HasSum (fun n => cA N a₁ a₂ n * qq N τ ^ n)
+      (zeta N ^ a₂ * qq N τ ^ a₁ / (1 - zeta N ^ a₂ * qq N τ ^ a₁) ^ 2) := by
+  set x : ℂ := zeta N ^ a₂ * qq N τ ^ a₁ with hx
+  have hxn : ‖x‖ < 1 := by
+    rw [hx, norm_mul, norm_pow, norm_zeta, one_pow, one_mul, norm_pow]
+    exact pow_lt_one₀ (norm_nonneg _) (norm_qq_lt_one N τ) ha0
+  have h1 := hasSum_coe_mul_geometric_of_norm_lt_one hxn
+  have hinj : Function.Injective fun k : ℕ => a₁ * k := mul_right_injective₀ ha0
+  have hsupp : ∀ n ∉ Set.range (fun k : ℕ => a₁ * k), cA N a₁ a₂ n * qq N τ ^ n = 0 := by
+    intro n hn
+    have : ¬ a₁ ∣ n := by rintro ⟨k, rfl⟩; exact hn ⟨k, rfl⟩
+    simp [cA, ha0, this]
+  refine (hinj.hasSum_iff hsupp).1 ?_
+  convert h1 using 1
+  funext k
+  simp only [comp_apply, cA, ha0, ↓reduceIte, dvd_mul_right, Nat.mul_div_cancel_left _
+    (Nat.pos_of_ne_zero ha0), hx]
+  rw [mul_pow, ← pow_mul, ← pow_mul]
+  ring
+
+theorem hasSum_cW (X : ℍ → ℂ) (τ : ℍ)
+    (hX : X τ = zeta N ^ a₂ * qq N τ ^ a₁ / (1 - zeta N ^ a₂ * qq N τ ^ a₁) ^ 2 + 1 / 12 +
+      ∑' p : ℕ+ × ℕ+, Ft N a₁ a₂ τ p) :
+    HasSum (fun n => cW N a₁ a₂ n * qq N τ ^ n) (X τ) := by
+  have ha : a₁ < N := Fact.out
+  have hT := hasSum_cT N a₁ a₂ τ
+  have htsum : ∑' p : ℕ+ × ℕ+, Ft N a₁ a₂ τ p = ∑' i, Gt N a₁ a₂ τ i :=
+    (hasSum_Ft N a₁ a₂ ha τ).tsum_eq
+  have h0 : HasSum (fun n => (if n = 0 then c0 N a₁ a₂ else 0) * qq N τ ^ n) (c0 N a₁ a₂) := by
+    have := hasSum_single (f := fun n => (if n = 0 then c0 N a₁ a₂ else 0) * qq N τ ^ n) 0
+      (fun n hn => by simp [hn])
+    simpa using this
+  have hfun : (fun n => cW N a₁ a₂ n * qq N τ ^ n) = fun n =>
+      cA N a₁ a₂ n * qq N τ ^ n + (if n = 0 then c0 N a₁ a₂ else 0) * qq N τ ^ n + cT N a₁ a₂ n * qq
+        N τ ^ n := by
+    funext n; rw [cW]; ring
+  rw [hfun, hX, htsum]
+  by_cases ha0 : a₁ = 0
+  · have hA : HasSum (fun n => cA N a₁ a₂ n * qq N τ ^ n) 0 := by
+      have : (fun n => cA N a₁ a₂ n * qq N τ ^ n) = 0 := by funext n; simp [cA, ha0]
+      rw [this]; exact hasSum_zero
+    have := (hA.add h0).add hT
+    convert this using 1
+    simp [c0, ha0]
+    ring
+  · have hA := hasSum_cA N a₁ a₂ τ ha0
+    have := (hA.add h0).add hT
+    convert this using 1
+    simp [c0, ha0]
+
+end Series
+
+section QExp
+
+variable (a₁ a₂ : ℕ) [Fact (a₁ < N)]
+
+theorem natCast_pos : (0 : ℝ) < (N : ℝ) := Nat.cast_pos.mpr (NeZero.pos N)
+
+theorem qExpansion_coeff_unique' {h : ℝ} (hh : 0 < h) {g : ℍ → ℂ} {c : ℕ → ℂ}
+    (hg : AnalyticAt ℂ (cuspFunction h g) 0)
+    (hc : ∀ τ : ℍ, HasSum (fun m => c m • Periodic.qParam h τ ^ m) (g τ)) (m : ℕ) :
+    c m = (qExpansion h g).coeff m := by
+  have h1 := (hasFPowerSeriesOnBall_cuspFunction hh hg hc).hasFPowerSeriesAt
+  have h2 : HasFPowerSeriesAt (cuspFunction h g)
+      (FormalMultilinearSeries.ofScalars ℂ fun m => (qExpansion h g).coeff m) 0 := by
+    simpa [qExpansion_coeff, div_eq_mul_inv, mul_comm] using hg.hasFPowerSeriesAt
+  simpa [FormalMultilinearSeries.coeff_ofScalars] using
+    congr_arg (FormalMultilinearSeries.coeff · m) (h1.eq_formalMultilinearSeries h2)
+
+omit [NeZero N] [Fact (a₁ < N)] in
+theorem summable_bound {r : ℝ} (hr0 : 0 ≤ r) (hr1 : r < 1) :
+    Summable (fun n : ℕ => (‖c0 N a₁ a₂‖ + 8 * ((n : ℝ) + 1) ^ 3) * r ^ n) := by
+  have hnr : ‖r‖ < 1 := by rw [Real.norm_eq_abs, abs_of_nonneg hr0]; exact hr1
+  have h1 : Summable (fun n : ℕ => ‖c0 N a₁ a₂‖ * r ^ n) :=
+    (summable_geometric_of_lt_one hr0 hr1).mul_left _
+  have h2 : Summable (fun n : ℕ => ((n : ℝ) + 1) ^ 3 * r ^ n) := by
+    have h3 := (summable_pow_mul_geometric_of_norm_lt_one 3 hnr).comp_injective Nat.succ_injective
+    have h4 : Summable (fun n : ℕ => (((n + 1 : ℕ) : ℝ) ^ 3 * r ^ (n + 1)) * r⁻¹) := h3.mul_right _
+    by_cases hr : r = 0
+    · subst hr
+      refine summable_of_ne_finset_zero (s := {0}) fun n hn => ?_
+      have : n ≠ 0 := by simpa using hn
+      simp [zero_pow this]
+    · refine h4.congr fun n => ?_
+      push_cast
+      field_simp
+      ring
+  have := h1.add (h2.mul_left 8)
+  refine this.congr fun n => ?_
+  ring
+
+theorem qExpansion_eq_of_hasSum (X : ℍ → ℂ) (hmd : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) X)
+    (hsum : ∀ τ : ℍ, HasSum (fun n => cW N a₁ a₂ n * qq N τ ^ n) (X τ)) :
+    Periodic (X ∘ ofComplex) N ∧ IsBoundedAtImInfty X ∧
+      ∀ n, (qExpansion N X).coeff n = cW N a₁ a₂ n := by
+  have hper : Periodic (X ∘ ofComplex) N := by
+    intro w
+    by_cases hw : 0 < im w
+    · have hw' : 0 < im (w + N) := by simp [hw]
+      simp only [comp_apply, ofComplex_apply_of_im_pos hw', ofComplex_apply_of_im_pos hw]
+      have hq : qq N ⟨w + N, hw'⟩ = qq N ⟨w, hw⟩ := by
+        simp only [qq]
+        have hN : (N : ℂ) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne N)
+        rw [show 2 * (π : ℂ) * Complex.I * (w + N) / N = 2 * π * Complex.I * w / N + 2 * π *
+          Complex.I by
+          field_simp, Complex.exp_add, Complex.exp_two_pi_mul_I, mul_one]
+      have h1 := hsum ⟨w + N, hw'⟩
+      rw [hq] at h1
+      exact h1.unique (hsum ⟨w, hw⟩)
+    · push Not at hw
+      have : im (w + N) ≤ 0 := by simpa using hw
+      simp [ofComplex_apply_of_im_nonpos this, ofComplex_apply_of_im_nonpos hw]
+  have hbd : IsBoundedAtImInfty X := by
+    rw [isBoundedAtImInfty_iff]
+    set r₀ : ℝ := Real.exp (-2 * π / N) with hr₀
+    have hr₀0 : 0 ≤ r₀ := (Real.exp_pos _).le
+    have hr₀1 : r₀ < 1 := by
+      rw [hr₀, Real.exp_lt_one_iff]
+      have : 0 < 2 * π / N := by have := natCast_pos N; positivity
+      have h2 : -2 * π / N = -(2 * π / N) := by ring
+      rw [h2]; linarith
+    refine ⟨∑' n : ℕ, (‖c0 N a₁ a₂‖ + 8 * ((n : ℝ) + 1) ^ 3) * r₀ ^ n, 1, fun τ hτ => ?_⟩
+    have hr : ‖qq N τ‖ ≤ r₀ := by
+      rw [norm_qq, hr₀, Real.exp_le_exp]
+      have hN := natCast_pos N
+      have : 2 * π * 1 / N ≤ 2 * π * τ.im / N := by gcongr
+      have h2 : -2 * π * τ.im / N = -(2 * π * τ.im / N) := by ring
+      have h3 : -2 * π / N = -(2 * π * 1 / N) := by ring
+      rw [h2, h3]; linarith
+    have hs1 : Summable (fun n => ‖cW N a₁ a₂ n * qq N τ ^ n‖) := by
+      refine Summable.of_nonneg_of_le (fun n => norm_nonneg _) (fun n => ?_) (summable_bound N a₁ a₂
+        hr₀0 hr₀1)
+      rw [norm_mul, norm_pow]
+      exact mul_le_mul (norm_cW_le N a₁ a₂ n) (pow_le_pow_left₀ (norm_nonneg _) hr n) (pow_nonneg
+        (norm_nonneg _) _)
+        (by positivity)
+    rw [← (hsum τ).tsum_eq]
+    refine le_trans (norm_tsum_le_tsum_norm hs1) ?_
+    refine Summable.tsum_le_tsum (fun n => ?_) hs1 (summable_bound N a₁ a₂ hr₀0 hr₀1)
+    rw [norm_mul, norm_pow]
+    exact mul_le_mul (norm_cW_le N a₁ a₂ n) (pow_le_pow_left₀ (norm_nonneg _) hr n) (pow_nonneg
+      (norm_nonneg _) _)
+      (by positivity)
+  refine ⟨hper, hbd, fun n => ?_⟩
+  symm
+  refine qExpansion_coeff_unique' (natCast_pos N) (analyticAt_cuspFunction_zero (natCast_pos N) hper
+    hmd hbd)
+    (fun τ => ?_) n
+  have := hsum τ
+  simpa only [smul_eq_mul, qq_eq] using this
+
+end QExp
+
+section Main
+
+local notation "Δ" => ModularForm.discriminant
+
+theorem periodic_ofComplex_natCast {g : ℍ → ℂ} (h : Periodic (g ∘ ofComplex) 1) (n : ℕ) :
+    Periodic (g ∘ ofComplex) n := by
+  simpa using h.nat_mul n
+
+theorem qParam_one_eq_pow (τ : ℍ) : Periodic.qParam 1 τ = Periodic.qParam N τ ^ N := by
+  simp only [Periodic.qParam]
+  rw [← Complex.exp_nat_mul]
+  congr 1
+  have : (N : ℂ) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne N)
+  push_cast
+  field_simp
+
+theorem qExpansion_coeff_widthN {g : ℍ → ℂ} (hg : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hper : Periodic (g ∘ ofComplex) 1) (hbd : IsBoundedAtImInfty g) (n : ℕ) :
+    (qExpansion N g).coeff n = if (N : ℕ) ∣ n then (qExpansion 1 g).coeff (n / N) else 0 := by
+  classical
+  have hperN : Periodic (g ∘ ofComplex) N := periodic_ofComplex_natCast hper N
+  set c : ℕ → ℂ := fun n => if (N : ℕ) ∣ n then (qExpansion 1 g).coeff (n / N) else 0 with hc
+  have hNpos : 0 < N := NeZero.pos N
+  have hsum : ∀ τ : ℍ, HasSum (fun m => c m • Periodic.qParam N τ ^ m) (g τ) := by
+    intro τ
+    have h1 := hasSum_qExpansion one_pos hper hg hbd τ
+    have hinj : Function.Injective fun m : ℕ => N * m := mul_right_injective₀ hNpos.ne'
+    have hsupp : ∀ x ∉ Set.range (fun m : ℕ => N * m),
+        (fun m => c m • Periodic.qParam N τ ^ m) x = 0 := by
+      intro x hx
+      have : ¬ (N : ℕ) ∣ x := by
+        rintro ⟨y, rfl⟩; exact hx ⟨y, rfl⟩
+      simp [hc, this]
+    refine (hinj.hasSum_iff hsupp).1 ?_
+    convert h1 using 1
+    funext m
+    simp only [comp_apply, hc, dvd_mul_right, ↓reduceIte, Nat.mul_div_cancel_left _ hNpos]
+    rw [qParam_one_eq_pow N τ, ← pow_mul]
+  rw [← qExpansion_coeff_unique' (natCast_pos N) (analyticAt_cuspFunction_zero (natCast_pos N)
+    hperN hg hbd) hsum n]
+
+def spread (P : PowerSeries ℤ) : PowerSeries ℤ :=
+  PowerSeries.mk fun n => if (N : ℕ) ∣ n then PowerSeries.coeff (n / N) P else 0
+
+theorem qExpansion_widthN_of_int {k : ℤ} (f : ModularForm 𝒮ℒ k) (P : PowerSeries ℤ)
+    (hP : P.map (Int.castRingHom ℂ) = qExpansion 1 (⇑f : ℍ → ℂ)) :
+    (spread N P).map (Int.castRingHom ℂ) = qExpansion N (⇑f : ℍ → ℂ) := by
+  ext n
+  have hw := qExpansion_coeff_widthN N (g := (⇑f : ℍ → ℂ)) f.holo'
+    (SlashInvariantFormClass.periodic_comp_ofComplex f one_mem_strictPeriods_SL)
+      (ModularFormClass.bdd_at_infty f) n
+  rw [PowerSeries.coeff_map]
+  refine Eq.trans ?_ hw.symm
+  rw [spread, PowerSeries.coeff_mk]
+  split_ifs with h
+  · rw [← hP, PowerSeries.coeff_map]
+  · simp
+
+def P4 : PowerSeries ℤ :=
+  PowerSeries.mk fun m => if m = 0 then 1 else 240 * (ArithmeticFunction.sigma 3 m : ℤ)
+
+def P6 : PowerSeries ℤ :=
+  PowerSeries.mk fun m => if m = 0 then 1 else -504 * (ArithmeticFunction.sigma 5 m : ℤ)
+
+theorem map_P4 : P4.map (Int.castRingHom ℂ) = qExpansion 1 (E₄ : ℍ → ℂ) := by
+  ext n
+  rw [PowerSeries.coeff_map, ModularForm.E₄, EisensteinSeries.E_qExpansion_coeff (by
+    norm_num) (by
+      decide) n,
+    P4, PowerSeries.coeff_mk, eq_intCast]
+  split_ifs with h
+  · simp
+  · rw [show _root_.bernoulli 4 = -1 / 30 by
+      rw [bernoulli_eq_bernoulli'_of_ne_one (by norm_num), bernoulli'_four]]
+    push_cast
+    ring
+
+theorem bernoulli'_six : bernoulli' 6 = 1 / 42 := by
+  rw [bernoulli'_def]
+  norm_num [Finset.sum_range_succ, bernoulli'_zero, bernoulli'_one, bernoulli'_two,
+    bernoulli'_three,
+    bernoulli'_four, Nat.choose]
+  have h5 : bernoulli' 5 = 0 := bernoulli'_eq_zero_of_odd (by decide) (by norm_num)
+  rw [h5]
+  norm_num
+
+theorem map_P6 : P6.map (Int.castRingHom ℂ) = qExpansion 1 (E₆ : ℍ → ℂ) := by
+  ext n
+  rw [PowerSeries.coeff_map, ModularForm.E₆, EisensteinSeries.E_qExpansion_coeff (by
+    norm_num) (by
+      decide) n,
+    P6, PowerSeries.coeff_mk, eq_intCast]
+  split_ifs with h
+  · simp
+  · rw [show _root_.bernoulli 6 = 1 / 42 by
+      rw [bernoulli_eq_bernoulli'_of_ne_one (by norm_num), bernoulli'_six]]
+    push_cast
+    ring
+
+def E46 : ModularForm 𝒮ℒ 10 := (E₄.mul E₆).mcast (by norm_num)
+
+theorem coe_E46 : (⇑E46 : ℍ → ℂ) = (E₄ : ℍ → ℂ) * E₆ := by rw [E46, coe_mcast, coe_mul]
+
+theorem map_E46 : (spread N (P4 * P6)).map (Int.castRingHom ℂ) = qExpansion N (⇑E46 : ℍ → ℂ) := by
+  apply qExpansion_widthN_of_int
+  rw [map_mul, map_P4, map_P6, E46, ModularForm.qExpansion_mcast, ModularForm.coe_mul,
+    ModularForm.qExpansion_mul_coe one_pos one_mem_strictPeriods_SL]
+
+structure FD where
+  L : ℍ → PeriodPair
+  hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1
+  W : (Fin 2 → ZMod N) → ℍ → ℂ
+  hW : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), W v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+    PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ))
+  fricke : (Fin 2 → ZMod N) → ℍ → ℂ
+  hfricke : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), fricke v τ =
+    -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ
+
+variable {N}
+
+theorem main (X : FD N) (v : Fin 2 → ZMod N) (hv : v ≠ 0) :
+    ∃ D : ℕ, D ≠ 0 ∧ ∀ n : ℕ,
+      (D : ℂ) * (qExpansion N (X.fricke v * Δ)).coeff n ∈ AZ N := by
+  classical
+  set a₁ : ℕ := (v 0).val with ha₁
+  set a₂ : ℕ := (v 1).val with ha₂
+  have ha₁N : a₁ < N := ZMod.val_lt _
+  have ha₂N : a₂ < N := ZMod.val_lt _
+  have : Fact (a₁ < N) := ⟨ha₁N⟩
+  have h0 : a₁ ≠ 0 ∨ a₂ ≠ 0 := by
+    by_contra h
+    push Not at h
+    apply hv
+    funext i
+    fin_cases i
+    · exact (ZMod.val_eq_zero (v 0)).mp h.1
+    · exact (ZMod.val_eq_zero (v 1)).mp h.2
+  obtain ⟨-, -, -, hpkg, -⟩ := WLight.weierstrassP_qExpansion_package
+  obtain ⟨hseries, hmdP⟩ := hpkg X.L X.hL N a₁ a₂ ha₁N ha₂N h0
+  set Wv : ℍ → ℂ := X.W v with hWv
+  have h2pi : ((2 * (π : ℂ) * Complex.I) ^ 2) ≠ 0 := by
+    apply pow_ne_zero; simp [Real.pi_ne_zero, Complex.I_ne_zero]
+  have hWτ : ∀ τ : ℍ, Wv τ = zeta N ^ a₂ * qq N τ ^ a₁ / (1 - zeta N ^ a₂ * qq N τ ^ a₁) ^ 2 + 1 /
+    12 +
+      ∑' p : ℕ+ × ℕ+, Ft N a₁ a₂ τ p := by
+    intro τ
+    rw [hWv, X.hW v τ, ← ha₁, ← ha₂, hseries τ, inv_mul_cancel_left₀ h2pi]
+    simp only [Ft_eq, zeta, qq]
+  have hsum : ∀ τ, HasSum (fun n => cW N a₁ a₂ n * qq N τ ^ n) (Wv τ) := fun τ =>
+    hasSum_cW N a₁ a₂ Wv τ (hWτ τ)
+  have hmdW : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) Wv := by
+    have : Wv = fun τ => ((2 * (π : ℂ) * Complex.I) ^ 2)⁻¹ *
+        PeriodPair.weierstrassP (X.L τ) (((a₁ : ℂ) * τ + a₂) / N) := by
+      funext τ; rw [hWv, X.hW v τ]
+    rw [this]
+    exact mdifferentiable_const.mul hmdP
+  obtain ⟨hperW, hbdW, hcoefW⟩ := qExpansion_eq_of_hasSum N a₁ a₂ Wv hmdW hsum
+  have hfun : X.fricke v * Δ = (-(1 / 2592 : ℂ)) • ((⇑E46 : ℍ → ℂ) * Wv) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.smul_apply, smul_eq_mul, coe_E46, hWv, X.hfricke v τ]
+    field_simp [discriminant_ne_zero τ]
+  have hE : (⇑E46 : ℍ → ℂ) = ⇑E46 := rfl
+  have hperE : Periodic ((⇑E46 : ℍ → ℂ) ∘ ofComplex) N :=
+    periodic_ofComplex_natCast (SlashInvariantFormClass.periodic_comp_ofComplex E46
+      one_mem_strictPeriods_SL) N
+  have haE : AnalyticAt ℂ (cuspFunction N (⇑E46 : ℍ → ℂ)) 0 :=
+    analyticAt_cuspFunction_zero (natCast_pos N) hperE E46.holo' (ModularFormClass.bdd_at_infty E46)
+  have haW : AnalyticAt ℂ (cuspFunction N Wv) 0 :=
+    analyticAt_cuspFunction_zero (natCast_pos N) hperW hmdW hbdW
+  have hperEW : Periodic (((⇑E46 : ℍ → ℂ) * Wv) ∘ ofComplex) N := by
+    intro w; have h1 := hperE w; have h2 := hperW w
+    simp only [comp_apply, Pi.mul_apply] at h1 h2 ⊢; rw [h1, h2]
+  have haEW : AnalyticAt ℂ (cuspFunction N ((⇑E46 : ℍ → ℂ) * Wv)) 0 :=
+    analyticAt_cuspFunction_zero (natCast_pos N) hperEW (E46.holo'.mul hmdW)
+      ((ModularFormClass.bdd_at_infty E46).mul hbdW)
+  have hq : qExpansion N (X.fricke v * Δ) =
+      (-(1 / 2592 : ℂ)) • ((spread N (P4 * P6)).map (Int.castRingHom ℂ) * qExpansion N Wv) := by
+    rw [hfun, qExpansion_smul haEW, qExpansion_mul haE haW, map_E46]
+  refine ⟨2592 * 12 * N ^ 2, mul_ne_zero (by norm_num) (pow_ne_zero 2 (NeZero.ne N)), fun n => ?_⟩
+  rw [hq, PowerSeries.coeff_smul, PowerSeries.coeff_mul, smul_eq_mul]
+  have hc : ((2592 * 12 * N ^ 2 : ℕ) : ℂ) * (-(1 / 2592) *
+      ∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, PowerSeries.coeff ij.1 ((spread N (P4 * P6)).map
+        (Int.castRingHom ℂ)) *
+        PowerSeries.coeff ij.2 (qExpansion N Wv))
+      = ∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, -(PowerSeries.coeff ij.1 ((spread N (P4 *
+        P6)).map (Int.castRingHom ℂ)) *
+        ((12 * (N : ℂ) ^ 2) * PowerSeries.coeff ij.2 (qExpansion N Wv))) := by
+    rw [Finset.mul_sum, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun ij _ => ?_
+    push_cast
+    ring
+  rw [hc]
+  refine sum_mem fun ij _ => neg_mem (mul_mem ?_ ?_)
+  · rw [PowerSeries.coeff_map]; exact intCast_mem N _
+  · rw [hcoefW]; exact cW_mem N a₁ a₂ ha₂N h0 _
+
+end Main
+
+end FrickeIntegral
+end
+
+theorem solution
+    (N : ℕ) [NeZero N]
+    (L : UpperHalfPlane → PeriodPair)
+    (hL : ∀ τ : UpperHalfPlane, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → UpperHalfPlane → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : UpperHalfPlane), W v τ =
+      ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+        PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → UpperHalfPlane → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : UpperHalfPlane), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (v : Fin 2 → ZMod N) (hv : v ≠ 0) :
+    ∃ D : ℕ, D ≠ 0 ∧ ∀ n : ℕ,
+      (D : ℂ) * (UpperHalfPlane.qExpansion N (fricke v * ModularForm.discriminant)).coeff n ∈
+        Algebra.adjoin ℤ ({Complex.exp (2 * (Real.pi : ℂ) * Complex.I / (N : ℂ))} : Set ℂ) :=
+  FrickeIntegral.main ⟨L, hL, W, hW, fricke, hfricke⟩ v hv
+
+end S_ModularCurve_exists_ne_zero_forall_mul_qExpansion_coeff_fricke_mem_adjoin
+end P2MW
+export P2MW.S_ModularCurve_exists_ne_zero_forall_mul_qExpansion_coeff_fricke_mem_adjoin (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.exists_ne_zero_forall_mul_qExpansion_coeff_fricke_mem_adjoin
+    (N : ℕ) [NeZero N]
+    (L : UpperHalfPlane → PeriodPair)
+    (hL : ∀ τ : UpperHalfPlane, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → UpperHalfPlane → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : UpperHalfPlane), W v τ =
+      ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+        PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → UpperHalfPlane → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : UpperHalfPlane), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (v : Fin 2 → ZMod N) (hv : v ≠ 0) :
+    ∃ D : ℕ, D ≠ 0 ∧ ∀ n : ℕ,
+      (D : ℂ) * (UpperHalfPlane.qExpansion N (fricke v * ModularForm.discriminant)).coeff n ∈
+        Algebra.adjoin ℤ ({Complex.exp (2 * (Real.pi : ℂ) * Complex.I / (N : ℂ))} : Set ℂ) :=
+  solution N L hL W hW fricke hfricke v hv
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_perm_gamma0_cosetReps.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_perm_gamma0_cosetReps.lean
new file mode 100644
index 0000000000..f10adf4e31
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_perm_gamma0_cosetReps.lean
@@ -0,0 +1,209 @@
+/-
+Based on Prove2Me node ModularCurve.exists_perm_gamma0_cosetReps
+(c0035975-cdc5-5e46-956b-99de3884fa8f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 91a1abbb-ecdf-5819-b19b-67129df4548e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+
+import Mathlib.Algebra.Field.ZMod
+import Mathlib.Tactic.Group
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Right multiplication permutes the Γ₀(ℓ) coset slots
+
+Theorem statement: `ModularCurve.exists_perm_gamma0_cosetReps`
+(`c0035975-cdc5-5e46-956b-99de3884fa8f`), by Claude, 2026-09-05.
+
+Proof: submission `91a1abbb-ecdf-5819-b19b-67129df4548e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a prime number and let $\gamma \in \mathrm{SL}_2(\mathbb{Z})$. Consider the family of
+matrices indexed by `Fin (ℓ + 1)` given by `Fin.cases`: the value at $0$ is the identity, and the
+value at $b+1$, for $b \in$ `Fin ℓ`, is $S\,T^{b}$, where $S$ and $T$ are the standard generators
+`ModularGroup.S` and `ModularGroup.T` of $\mathrm{SL}_2(\mathbb{Z})$ and $b$ is used as a
+natural-number exponent. Writing $r_i$ for the $i$-th member of this family, the assertion is that
+there exists a permutation $e$ of `Fin (ℓ + 1)` such that for every index $i$ one has
+$r_i\,\gamma\,r_{e(i)}^{-1} \in \Gamma_0(\ell)$, that is, the lower-left entry of this product is
+divisible by $\ell$ (in Mathlib's `CongruenceSubgroup.Gamma0` this is the condition that the $(1,0)$
+entry reduces to $0$ in $\mathbb{Z}/\ell$). No restriction such as $\ell > 2$ is imposed.
+
+The family $1, S T^{b}$ ($b < \ell$) is the classical complete set of representatives for the right
+cosets $\Gamma_0(\ell)\backslash\mathrm{SL}_2(\mathbb{Z})$, whose bottom rows realise the $\ell+1$
+points of $\mathbb{P}^1(\mathbb{F}_\ell)$; the statement records that right translation by any
+$\gamma$ permutes these cosets. It is used in the treatment of $\Gamma_0(\ell)$-invariant
+$q$-expansions and of the function field of the modular curve, for instance in the integrality and
+Fricke-involution statements for $j(q)$, $j(q^{\ell})$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_perm_gamma0_cosetReps.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_perm_gamma0_cosetReps
+
+noncomputable section
+
+open CongruenceSubgroup
+open scoped MatrixGroups
+
+namespace ModularCurve
+
+namespace QexpN
+
+private def rep (ℓ : ℕ) (i : Fin (ℓ + 1)) : SL(2, ℤ) :=
+  Fin.cases 1 (fun b : Fin ℓ => ModularGroup.S * ModularGroup.T ^ (b : ℕ)) i
+
+private theorem rep_zero (ℓ : ℕ) : rep ℓ 0 = 1 := by simp [rep]
+
+private theorem rep_succ (ℓ : ℕ) (b : Fin ℓ) :
+    rep ℓ b.succ = ModularGroup.S * ModularGroup.T ^ (b : ℕ) := by simp [rep]
+
+private theorem val_mk {n v : ℕ} (h : v < n) : ((⟨v, h⟩ : Fin n) : ℕ) = v := rfl
+
+private theorem coe_S_mul_T_pow (b : ℕ) :
+    ((ModularGroup.S * ModularGroup.T ^ b : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)
+      = !![0, -1; 1, (b : ℤ)] := by
+  rw [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_S, ← zpow_natCast,
+    ModularGroup.coe_T_zpow, Matrix.mul_fin_two]
+  norm_num
+
+private theorem coe_S_mul_T_pow_inv (b : ℕ) :
+    (((ModularGroup.S * ModularGroup.T ^ b)⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)
+      = !![(b : ℤ), 1; -1, 0] := by
+  rw [Matrix.SpecialLinearGroup.coe_inv, coe_S_mul_T_pow, Matrix.adjugate_fin_two]
+  norm_num
+
+private theorem S_T_apply_one_zero (v : ℕ) :
+    (ModularGroup.S * ModularGroup.T ^ v : SL(2, ℤ)) 1 0 = 1 :=
+  (congrFun (congrFun (coe_S_mul_T_pow v) 1) 0).trans rfl
+
+private theorem S_T_apply_one_one (v : ℕ) :
+    (ModularGroup.S * ModularGroup.T ^ v : SL(2, ℤ)) 1 1 = (v : ℤ) :=
+  (congrFun (congrFun (coe_S_mul_T_pow v) 1) 1).trans rfl
+
+private theorem S_T_inv_apply_zero_zero (v : ℕ) :
+    ((ModularGroup.S * ModularGroup.T ^ v)⁻¹ : SL(2, ℤ)) 0 0 = (v : ℤ) :=
+  (congrFun (congrFun (coe_S_mul_T_pow_inv v) 0) 0).trans rfl
+
+private theorem S_T_inv_apply_one_zero (v : ℕ) :
+    ((ModularGroup.S * ModularGroup.T ^ v)⁻¹ : SL(2, ℤ)) 1 0 = -1 :=
+  (congrFun (congrFun (coe_S_mul_T_pow_inv v) 1) 0).trans rfl
+
+private theorem mul_apply_one_zero (A B : SL(2, ℤ)) :
+    (A * B) 1 0 = A 1 0 * B 0 0 + A 1 1 * B 1 0 := by
+  rw [congrFun (congrFun (Matrix.SpecialLinearGroup.coe_mul A B) 1) 0, Matrix.mul_apply,
+    Fin.sum_univ_two]
+
+private def slot (ℓ : ℕ) [NeZero ℓ] [Fact (Nat.Prime ℓ)] (δ : SL(2, ℤ)) : Fin (ℓ + 1) :=
+  if ((δ 1 0 : ℤ) : ZMod ℓ) = 0 then 0
+  else Fin.succ ⟨(((δ 1 1 : ℤ) : ZMod ℓ) / ((δ 1 0 : ℤ) : ZMod ℓ)).val, ZMod.val_lt _⟩
+
+private theorem mul_rep_slot_inv_mem (ℓ : ℕ) [NeZero ℓ] [Fact (Nat.Prime ℓ)] (δ : SL(2, ℤ)) :
+    δ * (rep ℓ (slot ℓ δ))⁻¹ ∈ Gamma0 ℓ := by
+  unfold slot
+  split_ifs with hc
+  · rw [rep_zero, inv_one, mul_one, Gamma0_mem]
+    exact hc
+  · set y : ZMod ℓ := ((δ 1 1 : ℤ) : ZMod ℓ) / ((δ 1 0 : ℤ) : ZMod ℓ) with hy
+    have hcy : ((δ 1 0 : ℤ) : ZMod ℓ) * y = ((δ 1 1 : ℤ) : ZMod ℓ) := by
+      rw [hy]; exact mul_div_cancel₀ _ hc
+    rw [rep_succ, Gamma0_mem, mul_apply_one_zero, S_T_inv_apply_zero_zero,
+      S_T_inv_apply_one_zero, val_mk]
+    push_cast
+    rw [ZMod.natCast_zmod_val]
+    linear_combination hcy
+
+private theorem eq_of_mul_inv_mem (ℓ : ℕ) [NeZero ℓ] [Fact (Nat.Prime ℓ)] {i k : Fin (ℓ + 1)}
+    (h : rep ℓ i * (rep ℓ k)⁻¹ ∈ Gamma0 ℓ) : i = k := by
+  induction i using Fin.cases with
+  | zero =>
+    induction k using Fin.cases with
+    | zero => rfl
+    | succ b' =>
+      exfalso
+      rw [rep_zero, rep_succ, one_mul, Gamma0_mem, S_T_inv_apply_one_zero] at h
+      rw [Int.cast_neg, Int.cast_one, neg_eq_zero] at h
+      exact one_ne_zero h
+  | succ b =>
+    induction k using Fin.cases with
+    | zero =>
+      exfalso
+      rw [rep_succ, rep_zero, inv_one, mul_one, Gamma0_mem, S_T_apply_one_zero] at h
+      rw [Int.cast_one] at h
+      exact one_ne_zero h
+    | succ b' =>
+      rw [rep_succ, rep_succ, Gamma0_mem, mul_apply_one_zero, S_T_apply_one_zero,
+        S_T_apply_one_one, S_T_inv_apply_zero_zero, S_T_inv_apply_one_zero] at h
+      push_cast at h
+      have hb : ((b' : ℕ) : ZMod ℓ) = ((b : ℕ) : ZMod ℓ) := by linear_combination h
+      have hval := congrArg ZMod.val hb
+      rw [ZMod.val_cast_of_lt b'.isLt, ZMod.val_cast_of_lt b.isLt] at hval
+      exact congrArg Fin.succ (Fin.ext hval.symm)
+
+private theorem exists_perm (ℓ : ℕ) [NeZero ℓ] [Fact (Nat.Prime ℓ)]
+    (γ : SL(2, ℤ)) :
+    ∃ e : Equiv.Perm (Fin (ℓ + 1)), ∀ i : Fin (ℓ + 1),
+      rep ℓ i * γ * (rep ℓ (e i))⁻¹ ∈ Gamma0 ℓ := by
+  have hinj : Function.Injective fun i : Fin (ℓ + 1) => slot ℓ (rep ℓ i * γ) := by
+    intro i k hik
+    have hi := mul_rep_slot_inv_mem ℓ (rep ℓ i * γ)
+    have hk := mul_rep_slot_inv_mem ℓ (rep ℓ k * γ)
+    rw [show slot ℓ (rep ℓ i * γ) = slot ℓ (rep ℓ k * γ) from hik] at hi
+    have hmem := (Gamma0 ℓ).mul_mem hi ((Gamma0 ℓ).inv_mem hk)
+    have hgrp : rep ℓ i * γ * (rep ℓ (slot ℓ (rep ℓ k * γ)))⁻¹
+        * (rep ℓ k * γ * (rep ℓ (slot ℓ (rep ℓ k * γ)))⁻¹)⁻¹ = rep ℓ i * (rep ℓ k)⁻¹ := by
+      group
+    rw [hgrp] at hmem
+    exact eq_of_mul_inv_mem ℓ hmem
+  exact ⟨Equiv.ofBijective _ (Finite.injective_iff_bijective.mp hinj),
+    fun i => mul_rep_slot_inv_mem ℓ (rep ℓ i * γ)⟩
+
+end QexpN
+
+end ModularCurve
+
+end
+
+theorem solution (ℓ : ℕ) [Fact (Nat.Prime ℓ)] (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) :
+    ∃ e : Equiv.Perm (Fin (ℓ + 1)), ∀ i : Fin (ℓ + 1), (Fin.cases (1 : Matrix.SpecialLinearGroup
+      (Fin 2) ℤ) (fun b : Fin ℓ => ModularGroup.S * ModularGroup.T ^ (b : ℕ)) i :
+      Matrix.SpecialLinearGroup (Fin 2) ℤ) * γ * (Fin.cases (1 : Matrix.SpecialLinearGroup (Fin 2)
+      ℤ) (fun b : Fin ℓ => ModularGroup.S * ModularGroup.T ^ (b : ℕ)) (e i) :
+      Matrix.SpecialLinearGroup (Fin 2) ℤ)⁻¹ ∈ CongruenceSubgroup.Gamma0 ℓ := by
+  have : NeZero ℓ := ⟨(Fact.out : ℓ.Prime).ne_zero⟩
+  exact ModularCurve.QexpN.exists_perm ℓ γ
+
+end S_ModularCurve_exists_perm_gamma0_cosetReps
+end P2MW
+export P2MW.S_ModularCurve_exists_perm_gamma0_cosetReps (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.exists_perm_gamma0_cosetReps (ℓ : ℕ) [Fact (Nat.Prime ℓ)]
+    (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) :
+    ∃ e : Equiv.Perm (Fin (ℓ + 1)), ∀ i : Fin (ℓ + 1), (Fin.cases (1 : Matrix.SpecialLinearGroup
+      (Fin 2) ℤ) (fun b : Fin ℓ => ModularGroup.S * ModularGroup.T ^ (b : ℕ)) i :
+      Matrix.SpecialLinearGroup (Fin 2) ℤ) * γ * (Fin.cases (1 : Matrix.SpecialLinearGroup (Fin 2)
+      ℤ) (fun b : Fin ℓ => ModularGroup.S * ModularGroup.T ^ (b : ℕ)) (e i) :
+      Matrix.SpecialLinearGroup (Fin 2) ℤ)⁻¹ ∈ CongruenceSubgroup.Gamma0 ℓ :=
+  solution ℓ γ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_phiIrreducible.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_phiIrreducible.lean
new file mode 100644
index 0000000000..5564ee73af
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_phiIrreducible.lean
@@ -0,0 +1,815 @@
+/-
+Based on Prove2Me node ModularCurve.exists_phiIrreducible
+(85c90cda-9166-5cf9-a245-c0442a624673) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 25e72fb1-74d8-5410-94ca-a5536b5cd327
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_minpoly_jqN_map_eq_prod_slots
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqN_prime_not_mem_full
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqN_pow_not_mem_adjoin_full
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_full_eq_adjoin_full_div_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_eq_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqN_div_mem_modularFunctionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularFunctionField_eq_full_of
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_modularFunctionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_mul_of_coprime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime_pow
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_of_finrank_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration_iff_full_eq
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.FieldTheory.Relrank
+import Mathlib.Data.Nat.Factorization.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of an irreducible modular polynomial at every level
+
+Theorem statement: `ModularCurve.exists_phiIrreducible` (`85c90cda-9166-5cf9-a245-c0442a624673`), by
+Claude, 2026-09-05.
+
+Proof: submission `25e72fb1-74d8-5410-94ca-a5536b5cd327`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+For every natural number $N$ carrying a `NeZero` instance (so $N \ge 1$), there exists a datum `data
+: ModularPolynomialData N` satisfying `PhiIrreducible data`. Unfolding the structure, this asserts
+the existence of a polynomial $\Phi \in (\mathbb{Z}[X])[Y]$, i.e. a one-variable polynomial over the
+ring $\mathbb{Z}[X]$, with the following three properties: $\Phi$ is monic in $Y$; its degree in $Y$
+equals `dedekindPsi N`, defined as $\sum_{d \mid N,\ d \text{ squarefree}} N/d$ (the Dedekind
+$\psi$-function $\psi(N) = N\prod_{p \mid N}(1+1/p)$); and $\Phi$ vanishes at the pair of
+$q$-expansions, in the sense that evaluating $\Phi$ by applying the ring homomorphism `evalAtJ :
+Polynomial ℤ →+* LaurentSeries ℚ` (substitution of the $j$-expansion `jq` for $X$) to the
+coefficients and substituting `jqN N`, the expansion of $j(q^N)$, for $Y$ gives $0$ in the Laurent
+series field $\mathbb{Q}((q))$. The extra condition `PhiIrreducible data` says that `data.toAdjoin`,
+the image $\Phi$ under the coefficientwise map `evalAtJGen` into the intermediate field
+$\mathbb{Q}\langle jq\rangle = \mathbb{Q}(j(q)) \subseteq \mathbb{Q}((q))$, is an irreducible
+element of the polynomial ring over that field. Thus $\Phi$ is, up to the identification of
+$\mathbb{Z}[X]$-coefficients with elements of $\mathbb{Q}(j)$, the minimal polynomial of $j(q^N)$
+over $\mathbb{Q}(j)$, of degree $\psi(N)$ and with integral coefficients.
+
+This is the classical statement that the modular equation of level $N$ exists with integer
+coefficients, is monic of degree $\psi(N)$ in the second variable, and is irreducible over
+$\mathbb{Q}(j)$, equivalently that $[\mathbb{Q}(j,j_N):\mathbb{Q}(j)] = \psi(N)$ for the function
+field of $X_0(N)$. It supplies the defining equation used downstream to build models of $X_0(N)$ and
+charts near the cusps, including the fibre models in characteristic $p$ and the Igusa-type
+constructions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_phiIrreducible.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_phiIrreducible
+
+noncomputable section
+
+p2m_open "ModularCurve~coeffEmb_qExpand P2MW.S_ModularCurve_exists_phiIrreducible.ModularCurve \
+  ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+
+
+
+
+
+
+
+
+
+
+theorem coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb K (qExpand ℚ n x) = qExpand K n (coeffEmb K x) :=
+  coeffMap_qExpand (algebraMap ℚ K) n x
+
+theorem iota_jqN (N d : ℕ) [NeZero N] [NeZero d] :
+    coeffEmb K (qExpand ℚ N (jqN d)) = TS K (N * d) 1 := by
+  rw [jqN, coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem iota_jq (N : ℕ) [NeZero N] : coeffEmb K (qExpand ℚ N jq) = TS K N 1 := by
+  rw [coeffEmb_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_zero_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    conj p ζ (0 : Fin (p + 1)) = TS K (p * p) 1 := by
+  rw [conj_zero, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_succ_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) (b : Fin p) :
+    conj p ζ b.succ = TS K 1 (ζ ^ (b : ℕ)) := by
+  rw [conj_succ, TS_eq_coeffEmb, qExpand_one_apply]
+
+theorem qTwist_iota_of_pow_eq_one (N : ℕ) [NeZero N] (v : Kˣ) (hv : v ^ N = 1) (x : LaurentSeries ℚ)
+    :
+    qTwist v (coeffEmb K (qExpand ℚ N x)) = coeffEmb K (qExpand ℚ N x) := by
+  rw [coeffEmb_qExpand, qTwist_qExpand]
+  have : v ^ (N : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+omit [Algebra ℚ K] in
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+omit [Algebra ℚ K] in
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+omit [Algebra ℚ K] in
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem phiProd_conj_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    phiProd p (conj p ζ) = (Polynomial.X - Polynomial.C (TS K (p * p) 1)) *
+      ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) := by
+  rw [phiProd, Fin.prod_univ_succ, conj_zero_eq]
+  congr 1
+  rw [← Fin.prod_univ_eq_prod_range (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) p]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [conj_succ_eq]
+
+theorem roots_phiProd_conj (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    (phiProd p (conj p ζ)).roots = TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^
+      b)) := by
+  classical
+  rw [phiProd_conj_eq]
+  have h1 : (Polynomial.X - Polynomial.C (TS K (p * p) 1) : Polynomial (LaurentSeries K)) ≠ 0 :=
+    Polynomial.X_sub_C_ne_zero _
+  have h2 : (∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b)))) ≠ 0 :=
+    Finset.prod_ne_zero_iff.mpr fun b _ => Polynomial.X_sub_C_ne_zero _
+  rw [Polynomial.roots_mul (mul_ne_zero h1 h2), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod,
+    Finset.range_val]
+  have hm : (Multiset.map (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) (Multiset.range
+    p)) =
+      ((Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).map (fun a => Polynomial.X - Polynomial.C
+        a) := by
+    rw [Multiset.map_map]; rfl
+  rw [hm, Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+omit [Algebra ℚ K] in
+theorem roots_phiProd_conj_nodup (p : ℕ) [hp : Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).Nodup := by
+  refine Multiset.nodup_cons.mpr ⟨?_, ?_⟩
+  · intro hmem
+    obtain ⟨b, -, hb⟩ := Multiset.mem_map.mp hmem
+    have := (TS_injective hb).1
+    have h2 := hp.out.two_le
+    nlinarith
+  · refine (Multiset.nodup_range p).map_on fun b hb b' hb' hbb' => ?_
+    rw [Multiset.mem_range] at hb hb'
+    have hu := (TS_injective hbb').2
+    have hζu : IsPrimitiveRoot ζ p := IsPrimitiveRoot.coe_units_iff.mp hζ
+    exact hζu.pow_inj hb hb' hu
+
+theorem exists_isPrimitiveRoot_cyclotomicField (N : ℕ) [NeZero N] :
+    ∃ z : CyclotomicField N ℚ, IsPrimitiveRoot z N := by
+  have : NeZero ((N : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr (NeZero.ne N)⟩
+  have : IsCyclotomicExtension {N} ℚ (CyclotomicField N ℚ) :=
+    CyclotomicField.isCyclotomicExtension N ℚ
+  exact IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField N ℚ) (Set.mem_singleton N)
+    (NeZero.ne N)
+
+def cycUnit (N : ℕ) [NeZero N] : (CyclotomicField N ℚ)ˣ :=
+  ((exists_isPrimitiveRoot_cyclotomicField N).choose_spec.isUnit (NeZero.ne N)).unit
+
+theorem cycUnit_spec (N : ℕ) [NeZero N] :
+    IsPrimitiveRoot ((cycUnit N : (CyclotomicField N ℚ)ˣ) : CyclotomicField N ℚ) N := by
+  rw [cycUnit, IsUnit.unit_spec]
+  exact (exists_isPrimitiveRoot_cyclotomicField N).choose_spec
+
+theorem cycUnit_pow (N : ℕ) [NeZero N] : cycUnit N ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, (cycUnit_spec N).pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem prod_form_ne_zero (N : ℕ) (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e]
+    (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K
+            jq)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+          (Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u,
+    Polynomial.roots_mul (prod_form_ne_zero N ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p)))
+    (coeffEmb K jq))))
+        = ((Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+        (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+        (Multiset.range p).map
+          (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).Nodup := by
+  have hζp : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := isPrimitiveRoot_pow_div hζ hpN
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h := (TS_injective (K := K) (e := e) (e' := p * (p * e))
+      (u := u * ζ ^ (b * (N / p))) (u' := u ^ (p * p))
+      (by simpa only [TS_eq_coeffEmb] using heq)).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e)
+      (u := u * ζ ^ (b * (N / p))) (u' := u * ζ ^ (b' * (N / p)))
+      (by simpa only [TS_eq_coeffEmb] using heq)).2
+    have h2 : ζ ^ (b * (N / p)) = ζ ^ (b' * (N / p)) := mul_left_cancel h
+    have h3 : (ζ ^ (N / p)) ^ b = (ζ ^ (N / p)) ^ b' := by
+      rw [← pow_mul, ← pow_mul, Nat.mul_comm (N / p) b, Nat.mul_comm (N / p) b']
+      exact h2
+    have h4 : ((ζ ^ (N / p) : Kˣ) : K) ^ b = ((ζ ^ (N / p) : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h3]
+    exact hζp.pow_inj hb hb' h4
+
+theorem roots_prime_at_slot_roots_nodup (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots.Nodup := by
+  rw [roots_prime_at_slot N ζ hζ p hpN data e u]
+  exact roots_prime_at_slot_nodup N ζ hζ p hpN e u
+
+theorem isRoot_prime_at_slot_iff (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u]
+    exact prod_form_ne_zero N ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot N ζ hζ p hpN data e u,
+    Multiset.mem_cons, Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+
+
+
+
+theorem phiAtSeed_jq_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) :
+    (phiAtSeed data jq).eval (jqN n) = 0 := by
+  have h := data.eval_eq_zero
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp [evalAtJ_X]
+
+
+theorem phiAtSeed_jqN_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN M)).eval (jqN (M * n)) = 0 := by
+  have h := phiAtSeed_eval_map data jq (jqN n) (qExpand ℚ M) (phiAtSeed_jq_eval n data)
+  rwa [jqN, qExpand_qExpand] at h
+
+theorem phiAtSeed_iota_eval {K : Type*} [Field K] [Algebra ℚ K] (A : ℕ) [NeZero A] (n : ℕ)
+    [NeZero n]
+    (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (coeffEmb K (qExpand ℚ A (jqN M)))).eval (coeffEmb K (qExpand ℚ A (jqN (M *
+      n)))) = 0 :=
+  phiAtSeed_eval_map data _ _ ((coeffEmb K).comp (qExpand ℚ A)) (phiAtSeed_jqN_eval n data M)
+
+end ModularCurve.W1
+
+open scoped IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+section Final
+
+private abbrev Tight (d : ℕ) [NeZero d] : Prop :=
+  Module.finrank ℚ⟮jq⟯ (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN d} : Set (LaurentSeries ℚ))) =
+    dedekindPsi d
+
+private abbrev Gen (d : ℕ) [NeZero d] : Prop := modularFunctionField d = modularFunctionFieldFull d
+
+private abbrev Hall (N : ℕ) : Prop := ∀ d : ℕ, d ∣ N → ∀ [NeZero d], Tight d ∧ Gen d
+
+private theorem jqN_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) : jqN n = jqN m := by
+  subst h; rfl
+
+private theorem full_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) :
+    modularFunctionFieldFull n = modularFunctionFieldFull m := by
+  subst h; rfl
+
+private theorem mff_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) :
+    modularFunctionField n = modularFunctionField m := by
+  subst h; rfl
+
+private theorem qExpand_congr' {R : Type*} [CommRing R] {n m : ℕ} [NeZero n] [NeZero m]
+    (h : n = m) (x : LaurentSeries R) : qExpand R n x = qExpand R m x := by
+  subst h
+  rfl
+
+private theorem dedekindPsi_prime' (p : ℕ) (hp : p.Prime) : dedekindPsi p = p + 1 := by
+  have h := ModularCurve.dedekindPsi_prime_pow p 1 hp one_ne_zero
+  rwa [pow_one, Nat.sub_self, pow_zero] at h
+
+private theorem dedekindPsi_mul_prime_not_dvd {m p : ℕ} (hp : p.Prime) (hpm : ¬ p ∣ m) :
+    dedekindPsi (m * p) = dedekindPsi m * (p + 1) := by
+  have hco : Nat.Coprime m p := ((Nat.Prime.coprime_iff_not_dvd hp).mpr hpm).symm
+  rw [ModularCurve.dedekindPsi_mul_of_coprime m p hco, dedekindPsi_prime' p hp]
+
+private theorem dedekindPsi_mul_prime_dvd {m p : ℕ} (hm : m ≠ 0) (hp : p.Prime)
+    (hpm : p ∣ m) : dedekindPsi (m * p) = dedekindPsi m * p := by
+  obtain ⟨k, u, hpu, hmu⟩ := Nat.exists_eq_pow_mul_and_not_dvd hm p hp.ne_one
+  obtain ⟨k', rfl⟩ : ∃ k', k = k' + 1 := by
+    rcases k with - | k'
+    · exfalso
+      rw [hmu, pow_zero, one_mul] at hpm
+      exact hpu hpm
+    · exact ⟨k', rfl⟩
+  subst hmu
+  have hcou : ∀ j : ℕ, j ≠ 0 → Nat.Coprime (p ^ j) u :=
+    fun j _ => Nat.Coprime.pow_left j ((Nat.Prime.coprime_iff_not_dvd hp).mpr hpu)
+  have h1 : p ^ (k' + 1) * u * p = p ^ (k' + 2) * u := by ring
+  rw [h1, ModularCurve.dedekindPsi_mul_of_coprime _ u (hcou _ (Nat.succ_ne_zero _)),
+    ModularCurve.dedekindPsi_mul_of_coprime _ u (hcou _ (Nat.succ_ne_zero _)),
+    ModularCurve.dedekindPsi_prime_pow p (k' + 2) hp (Nat.succ_ne_zero _),
+    ModularCurve.dedekindPsi_prime_pow p (k' + 1) hp (Nat.succ_ne_zero _)]
+  have h2 : k' + 2 - 1 = k' + 1 := rfl
+  have h3 : k' + 1 - 1 = k' := rfl
+  rw [h2, h3]
+  ring
+
+private theorem tight_one : Tight 1 := by
+  unfold Tight
+  have h1 : jqN 1 = jq := by rw [jqN, qExpand_one_apply]
+  rw [h1, ModularCurve.dedekindPsi_one]
+  have h2 : IntermediateField.adjoin ℚ⟮jq⟯ ({jq} : Set (LaurentSeries ℚ))
+      = (⊥ : IntermediateField ℚ⟮jq⟯ (LaurentSeries ℚ)) := by
+    rw [IntermediateField.adjoin_simple_eq_bot_iff, IntermediateField.mem_bot]
+    exact ⟨jGen, rfl⟩
+  rw [h2]
+  exact IntermediateField.finrank_bot
+
+private theorem gen_one : Gen 1 := by
+  unfold Gen
+  refine le_antisymm (modularFunctionField_le_full 1) ?_
+  rw [modularFunctionFieldFull, IntermediateField.adjoin_le_iff]
+  rintro x ⟨d, hne, hdvd, rfl⟩
+  have := hne
+  have hd1 : d = 1 := Nat.dvd_one.mp hdvd
+  subst hd1
+  rw [qExpand_one_apply]
+  exact jq_mem 1
+
+private theorem relfinrank_full_of (N : ℕ) [NeZero N] (ht : Tight N) (hg : Gen N) :
+    IntermediateField.relfinrank ℚ⟮jq⟯ (modularFunctionFieldFull N) = dedekindPsi N := by
+  unfold Gen at hg
+  unfold Tight at ht
+  rw [← hg, ModularCurve.relfinrank_modularFunctionField N, ht]
+
+private theorem F0_le_full (N : ℕ) [NeZero N] : ℚ⟮jq⟯ ≤ modularFunctionFieldFull N := by
+  rw [IntermediateField.adjoin_le_iff, Set.singleton_subset_iff]
+  have h := jqd_mem_full N (one_dvd N)
+  rw [qExpand_one_apply] at h
+  exact h
+
+private theorem full_le_adjoin_chain (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (hpM : ¬ p ∣ M) : ∀ a : ℕ,
+    modularFunctionFieldFull (M * p ^ a) ≤ IntermediateField.adjoin ℚ
+      ((modularFunctionFieldFull M : Set (LaurentSeries ℚ))
+        ∪ {x : LaurentSeries ℚ | ∃ i : ℕ, i ≤ a ∧ x = jqN (p ^ i)}) := by
+  intro a
+  induction a with
+  | zero =>
+      rw [full_congr (show M * p ^ 0 = M by rw [pow_zero, mul_one])]
+      exact fun x hx => IntermediateField.subset_adjoin ℚ _ (Set.mem_union_left _ hx)
+  | succ k ih =>
+      rw [ModularCurve.full_eq_adjoin_full_div_prime M p k hpM, IntermediateField.adjoin_le_iff,
+        Set.insert_subset_iff]
+      refine ⟨IntermediateField.subset_adjoin ℚ _ (Set.mem_union_right _
+        (show jqN (p ^ (k + 1)) ∈ {x : LaurentSeries ℚ | ∃ i : ℕ, i ≤ k + 1 ∧ x = jqN (p ^ i)} from
+          ⟨k + 1, le_rfl, rfl⟩)), ?_⟩
+      intro x hx
+      have hx' := ih hx
+      refine IntermediateField.adjoin.mono ℚ _ _ (Set.union_subset_union le_rfl ?_) hx'
+      intro y hy
+      obtain ⟨i, hi, hy⟩ := hy
+      exact ⟨i, Nat.le_succ_of_le hi, hy⟩
+
+private theorem jqN_pow_not_mem_full (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (hpM : ¬ p ∣ M) (hallM : Hall M) (a : ℕ) :
+    jqN (p ^ (a + 1)) ∉ modularFunctionFieldFull (M * p ^ a) := by
+  have h0 : jqN p ∉ modularFunctionFieldFull M :=
+    ModularCurve.jqN_prime_not_mem_full M p hpM (fun d hd _ => hallM d hd)
+  rcases a with - | k
+  · rw [jqN_congr (show p ^ (0 + 1) = p by rw [zero_add, pow_one]),
+      full_congr (show M * p ^ 0 = M by rw [pow_zero, mul_one])]
+    exact h0
+  · intro hmem
+    have h1 := ModularCurve.jqN_pow_not_mem_adjoin_full M p k h0
+    exact h1 (full_le_adjoin_chain M p hpM (k + 1) hmem)
+
+section Shapes
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem root_shape (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) M) (hallM : Hall M) (y : LaurentSeries K)
+    (hy : Polynomial.eval y ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M *
+      p))).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))) = 0) :
+    ∃ a : ℕ, ∃ _ : NeZero a, a ∣ M ∧ ∃ b : ℕ, b < M / a ∧ y = TS K (p * (a * a)) (ζ ^ (b * a)) := by
+  have hid := ModularCurve.minpoly_jqN_map_eq_prod_slots (K := K) M ζ hζ (fun d hd _ => hallM d hd)
+  have hcomp : (qExpand K p).comp (((coeffEmb K).comp (qExpand ℚ M)).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))
+      = ((coeffEmb K).comp (qExpand ℚ (M * p))).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) := by
+    refine RingHom.ext fun z => ?_
+    simp only [RingHom.comp_apply]
+    rw [coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand]
+    exact qExpand_congr' (mul_comm p M) _
+  rw [← hcomp, ← Polynomial.map_map, hid, Polynomial.eval_map, Polynomial.eval₂_finsetProd] at hy
+  obtain ⟨a, ha, hy⟩ := Finset.prod_eq_zero_iff.mp hy
+  rw [Polynomial.eval₂_finsetProd] at hy
+  obtain ⟨b, hb, hy⟩ := Finset.prod_eq_zero_iff.mp hy
+  rw [Polynomial.eval₂_sub, Polynomial.eval₂_X, Polynomial.eval₂_C, sub_eq_zero] at hy
+  have ha0 : a ≠ 0 := Nat.ne_of_gt (Nat.pos_of_mem_divisors ha)
+  rw [dite_eq_right ha0] at hy
+  have : NeZero a := ⟨ha0⟩
+  refine ⟨a, ⟨ha0⟩, Nat.dvd_of_mem_divisors ha, b, (Finset.mem_range.mp (Finset.mem_filter.mp
+    hb).1), ?_⟩
+  rw [hy]
+  rw [← TS_eq_coeffEmb, qExpand_TS]
+
+private theorem htw_of (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) M) (hallM : Hall M) (y : LaurentSeries K)
+    (hy : Polynomial.eval y ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M *
+      p))).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))) = 0)
+    (w : Kˣ) (hw : y = qExpand K (M * p * M) (qTwist w (coeffEmb K jq))) : w = 1 := by
+  obtain ⟨a, _, haM, b, hb, rfl⟩ := root_shape M p ζ hζ hallM y hy
+  rw [← TS_eq_coeffEmb] at hw
+  obtain ⟨he, hu⟩ := TS_injective hw
+  have haM' : a = M := by
+    have h2 : a * a = M * M := by
+      have hp0 : 0 < p := hp.out.pos
+      have : p * (a * a) = p * (M * M) := by rw [he]; ring
+      exact Nat.eq_of_mul_eq_mul_left hp0 this
+    exact Nat.mul_self_inj.mp h2
+  subst haM'
+  have hb0 : b = 0 := by
+    rw [Nat.div_self (Nat.pos_of_ne_zero (NeZero.ne a))] at hb
+    omega
+  subst hb0
+  rw [zero_mul, pow_zero] at hu
+  exact hu.symm
+
+private theorem hsp_of (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) M) (hallM : Hall M) (y : LaurentSeries K)
+    (hy : Polynomial.eval y ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M *
+      p))).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))) = 0) :
+    y ≠ coeffEmb K (qExpand ℚ (M * p) (jqN (M * p * p))) := by
+  obtain ⟨a, _, haM, b, _, rfl⟩ := root_shape M p ζ hζ hallM y hy
+  rw [iota_jqN]
+  intro h
+  obtain ⟨he, _⟩ := TS_injective h
+  have hp2 : 2 ≤ p := hp.out.two_le
+  have hM : 0 < M := Nat.pos_of_ne_zero (NeZero.ne M)
+  have ha : a ≤ M := Nat.le_of_dvd hM haM
+  have h1 : a * a = (M * p) * (M * p) := by
+    have : p * (a * a) = p * ((M * p) * (M * p)) := by rw [he]; ring
+    exact Nat.eq_of_mul_eq_mul_left hp.out.pos this
+  have h2 : a = M * p := Nat.mul_self_inj.mp h1
+  have : M * p ≤ M := h2 ▸ ha
+  have : M * 2 ≤ M * p := Nat.mul_le_mul_left M hp2
+  omega
+
+end Shapes
+
+private theorem hall_all : ∀ N : ℕ, N ≠ 0 → Hall N := by
+  intro N
+  induction N using Nat.strong_induction_on with
+  | _ N ih =>
+  intro hN d hdN hd
+  by_cases hdlt : d < N
+  · exact ih d hdlt (NeZero.ne d) d dvd_rfl
+  have hdN' : d = N := le_antisymm (Nat.le_of_dvd (Nat.pos_of_ne_zero hN) hdN) (not_lt.mp hdlt)
+  subst hdN'
+  have hprop : ∀ m : ℕ, m ∣ d → m < d → Hall m := fun m _ hlt => ih m hlt (by
+    rintro rfl; exact absurd hlt (by have := Nat.pos_of_ne_zero hN; omega))
+  by_cases h1 : d = 1
+  · subst h1; exact ⟨tight_one, gen_one⟩
+  have hgen : Gen d := by
+    unfold Gen
+    refine ModularCurve.modularFunctionField_eq_full_of d ?_ ?_
+    · intro M _ p hp hMp
+      have : Fact (Nat.Prime p) := ⟨hp⟩
+      have hMlt : M < d := by
+        rw [← hMp]; exact lt_mul_of_one_lt_right (Nat.pos_of_ne_zero (NeZero.ne M)) hp.one_lt
+      have hallM : Hall M := hprop M ⟨p, hMp.symm⟩ hMlt
+      have hmem :=
+        ModularCurve.jqN_div_mem_modularFunctionField M p (K := CyclotomicField (M * p) ℚ)
+        (cycUnit (M * p)) (cycUnit_spec (M * p))
+        (fun y hy w hw => htw_of M p (cycUnit (M * p) ^ (M * p / M))
+          (isPrimitiveRoot_pow_div (cycUnit_spec (M * p)) ⟨p, rfl⟩) hallM y hy w hw)
+        (fun y hy => hsp_of M p (cycUnit (M * p) ^ (M * p / M))
+          (isPrimitiveRoot_pow_div (cycUnit_spec (M * p)) ⟨p, rfl⟩) hallM y hy)
+      rw [mff_congr hMp] at hmem
+      exact hmem
+    · intro M _ p hp hMp
+      have hMlt : M < d := by
+        rw [← hMp]; exact lt_mul_of_one_lt_right (Nat.pos_of_ne_zero (NeZero.ne M)) hp.one_lt
+      exact (hprop M ⟨p, hMp.symm⟩ hMlt M dvd_rfl).2
+  refine ⟨?_, hgen⟩
+  unfold Tight
+  set p := d.minFac with hpdef
+  have hp : p.Prime := Nat.minFac_prime h1
+  have : Fact (Nat.Prime p) := ⟨hp⟩
+  obtain ⟨k, M, hpM, hdM⟩ := Nat.exists_eq_pow_mul_and_not_dvd hN p hp.ne_one
+  have hM0 : M ≠ 0 := by rintro rfl; rw [mul_zero] at hdM; exact hN hdM
+  have : NeZero M := ⟨hM0⟩
+  obtain ⟨a, rfl⟩ : ∃ a, k = a + 1 := by
+    rcases k with - | a
+    · exfalso
+      have : p ∣ d := Nat.minFac_dvd d
+      rw [hdM, pow_zero, one_mul] at this
+      exact hpM this
+    · exact ⟨a, rfl⟩
+  have hdM' : d = M * p ^ (a + 1) := by rw [hdM, mul_comm]
+  have hlow_dvd : M * p ^ a ∣ d := ⟨p, by rw [hdM', pow_succ, mul_assoc]⟩
+  have hlow_lt : M * p ^ a < d := by
+    rw [hdM', pow_succ, ← mul_assoc]
+    exact lt_mul_of_one_lt_right (Nat.pos_of_ne_zero (mul_ne_zero hM0 (pow_ne_zero _ hp.ne_zero)))
+      hp.one_lt
+  have hall_low : Hall (M * p ^ a) := hprop _ hlow_dvd hlow_lt
+  have hallM : Hall M := fun e he _ => hall_low e (he.trans ⟨p ^ a, rfl⟩)
+  have hlowdeg : IntermediateField.relfinrank ℚ⟮jq⟯ (modularFunctionFieldFull (M * p ^ a))
+      = dedekindPsi (M * p ^ a) := by
+    have h := hall_low (M * p ^ a) dvd_rfl
+    exact relfinrank_full_of _ h.1 h.2
+  have hstep := ModularCurve.relfinrank_full_eq_mul M p a
+    (ModularCurve.full_eq_adjoin_full_div_prime M p a hpM) (jqN_pow_not_mem_full M p hpM hallM a)
+  have htower := IntermediateField.relfinrank_mul_relfinrank (F0_le_full (M * p ^ a))
+    (full_degeneracy_le (N := M * p ^ a) (M := M * p ^ (a + 1)) ⟨p, by rw [pow_succ, mul_assoc]⟩)
+  rw [← ModularCurve.relfinrank_modularFunctionField d]
+  unfold Gen at hgen
+  rw [hgen, full_congr hdM', ← htower, hlowdeg, hstep]
+  have hpsi : dedekindPsi d = dedekindPsi (M * p ^ a) * (if a = 0 then p + 1 else p) := by
+    rw [hdM']
+    split_ifs with ha
+    · subst ha
+      rw [pow_zero, mul_one, zero_add, pow_one]
+      exact dedekindPsi_mul_prime_not_dvd hp hpM
+    · have h2 : M * p ^ (a + 1) = M * p ^ a * p := by rw [pow_succ, mul_assoc]
+      rw [h2]
+      refine dedekindPsi_mul_prime_dvd (mul_ne_zero hM0 (pow_ne_zero _ hp.ne_zero)) hp ⟨M * p ^ (a -
+        1), ?_⟩
+      obtain ⟨a', rfl⟩ := Nat.exists_eq_succ_of_ne_zero ha
+      rw [Nat.succ_sub_one, pow_succ]; ring
+  rw [hpsi]
+
+end Final
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi (N : ℕ) [NeZero N] :
+    Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+        ({jqN N} : Set (LaurentSeries ℚ))) = dedekindPsi N :=
+  (ModularCurve.W1.hall_all N (NeZero.ne N) N dvd_rfl).1
+
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.modularFunctionField_eq_full (N : ℕ) [NeZero N] :
+    modularFunctionField N = modularFunctionFieldFull N :=
+  (ModularCurve.W1.hall_all N (NeZero.ne N) N dvd_rfl).2
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.functionFieldGeneration (N : ℕ) [NeZero N] :
+    FunctionFieldGeneration N :=
+  (ModularCurve.functionFieldGeneration_iff_full_eq N).mpr
+    (ModularCurve.modularFunctionField_eq_full N).symm
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.exists_phiIrreducible (N : ℕ) [NeZero N] :
+    ∃ data : ModularPolynomialData N, PhiIrreducible data :=
+  ModularCurve.exists_phiIrreducible_of_finrank_eq N (ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi
+    N)
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.relfinrank_full_eq_dedekindPsi (N : ℕ) [NeZero N] :
+    IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (modularFunctionFieldFull N) = dedekindPsi N := by
+  rw [← ModularCurve.modularFunctionField_eq_full N, ModularCurve.relfinrank_modularFunctionField N]
+  exact ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi N
+
+end
+
+p2m_open "ModularCurve~coeffEmb_qExpand\
+  " in
+open _root_.P2MW.S_ModularCurve_exists_phiIrreducible.ModularCurve ModularCurve.PhiGen in
+theorem solution (N : ℕ) [NeZero N] : ∃ data : ModularPolynomialData N, PhiIrreducible data :=
+  ModularCurve.exists_phiIrreducible N
+
+end S_ModularCurve_exists_phiIrreducible
+end P2MW
+export P2MW.S_ModularCurve_exists_phiIrreducible (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.exists_phiIrreducible (N : ℕ) [NeZero N] :
+    ∃ data : ModularPolynomialData N, PhiIrreducible data :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_phiIrreducible_evalSymm.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_phiIrreducible_evalSymm.lean
new file mode 100644
index 0000000000..a2c4369174
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_phiIrreducible_evalSymm.lean
@@ -0,0 +1,138 @@
+/-
+Based on Prove2Me node ModularCurve.exists_phiIrreducible_evalSymm
+(66befd22-55d2-533d-a261-ddb7399e4802) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d69154cc-2187-5d53-8545-df3b03f29595
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_exists_phiGenDescends
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_PhiGenDescends_intCoeffs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_mem_adjoin_jq_of_phiGenDescends
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_exists_modularPolynomialData_coeff_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_evalSymm_of_coeff_evalAtJ_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_of_coeff_evalAtJ_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_phiIrreducible_of_splits
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of an irreducible symmetric modular polynomial Φ_ℓ
+
+Theorem statement: `ModularCurve.exists_phiIrreducible_evalSymm`
+(`66befd22-55d2-533d-a261-ddb7399e4802`), by Claude, 2026-09-05.
+
+Proof: submission `d69154cc-2187-5d53-8545-df3b03f29595`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a prime. The assertion is that there exists a term `data` of the structure
+`ModularPolynomialData ℓ`, that is, a polynomial $\Phi =$ `data.Φ` in $(\mathbb{Z}[X])[Y]$ which is
+monic, whose degree in $Y$ equals `dedekindPsi ℓ`, the sum of $\ell/d$ over the squarefree divisors
+$d$ of $\ell$ (so $\ell+1$), and which satisfies $\Phi.\mathrm{eval}_2(\mathrm{evalAtJ},
+\mathrm{jqN}\ \ell) = 0$, where `evalAtJ` is the ring homomorphism $\mathbb{Z}[X] \to$
+`LaurentSeries ℚ` evaluating a coefficient polynomial at the Laurent series `jq`, and `jqN ℓ` is the
+Laurent series of that name; and such that this same packet has both of the following two
+properties. First, `PhiIrreducible data`: the polynomial `data.toAdjoin`, obtained from $\Phi$ by
+mapping its coefficients through `evalAtJGen` into the intermediate field
+$\mathbb{Q}\langle\mathrm{jq}\rangle$ generated by `jq`, is irreducible over that field. Second,
+`EvalSymm data.Φ`: for all Laurent series $x, y$ over $\mathbb{Q}$, evaluating $\Phi$ by
+substituting $x$ into the coefficient polynomials and $y$ into the outer variable gives the same
+result as substituting $y$ into the coefficients and $x$ into the outer variable.
+
+This is the existence, for each prime $\ell$, of the classical modular polynomial $\Phi_\ell(X,Y)$
+relating $j(q)$ and $j(q^\ell)$, in the strong form in which irreducibility over $\mathbb{Q}(j)$ and
+the symmetry $\Phi_\ell(X,Y)=\Phi_\ell(Y,X)$ hold for one and the same packet; the pair of
+properties is what pins the packet down. It feeds the uniqueness statement
+[`ModularCurve.ModularPolynomialData.eq_of_prime`]
+(thm.html#ModularCurve.ModularPolynomialData.eq_of_prime),
+the construction of the Fricke involution
+[`ModularCurve.exists_isFrickeAut`](thm.html#ModularCurve.exists_isFrickeAut), and the existence of
+a monic relation
+[`ModularCurve.exists_monic_evalAtJ_jqN_eq_zero`]
+(thm.html#ModularCurve.exists_monic_evalAtJ_jqN_eq_zero).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_phiIrreducible_evalSymm.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_phiIrreducible_evalSymm
+
+noncomputable section
+
+open Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jq ModularPolynomialData EvalSymm PhiIrreducible PhiGen.IntCoeffs \
+  PhiGen.exists_phiGenDescends PhiGen.mem_adjoin_jq_of_phiGenDescends \
+  PhiGen.exists_modularPolynomialData_coeff_eq PhiGen.evalSymm_of_coeff_evalAtJ_eq \
+  PhiGen.splits_of_coeff_evalAtJ_eq PhiGen.phiIrreducible_of_splits"
+p2m_open "ModularCurve"
+
+private theorem exists_phiIrreducible_evalSymm (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] :
+    ∃ data : ModularPolynomialData ℓ, PhiIrreducible data ∧ EvalSymm data.Φ := by
+  have : NeZero ((ℓ : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr hℓ.out.ne_zero⟩
+  have hcyc : IsCyclotomicExtension {ℓ} ℚ (CyclotomicField ℓ ℚ) :=
+    CyclotomicField.isCyclotomicExtension (n := ℓ) (K := ℚ)
+  have : FiniteDimensional ℚ (CyclotomicField ℓ ℚ) :=
+    IsCyclotomicExtension.finiteDimensional {ℓ} ℚ (CyclotomicField ℓ ℚ)
+  have : IsGalois ℚ (CyclotomicField ℓ ℚ) :=
+    IsCyclotomicExtension.isGalois (S := {ℓ}) (K := ℚ) (L := CyclotomicField ℓ ℚ)
+  obtain ⟨z, hz⟩ := IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField ℓ ℚ)
+    (Set.mem_singleton ℓ) hℓ.out.ne_zero
+  have hzu : IsUnit z := hz.isUnit hℓ.out.ne_zero
+  have hζ : IsPrimitiveRoot ((hzu.unit : (CyclotomicField ℓ ℚ)ˣ) : CyclotomicField ℓ ℚ) ℓ := by
+    rw [hzu.unit_spec]; exact hz
+  have hζ1 : hzu.unit ^ ℓ = 1 := by
+    refine Units.ext ?_
+    rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one]
+  obtain ⟨c, hc⟩ := PhiGen.exists_phiGenDescends ℓ hzu.unit hζ
+  have hint : ∀ k, PhiGen.IntCoeffs (c k) := fun k => hc.intCoeffs hζ1 k
+  have hmem : ∀ k, c k ∈ Algebra.adjoin ℚ {jq} :=
+    fun k => PhiGen.mem_adjoin_jq_of_phiGenDescends ℓ hzu.unit hζ c hc k
+  obtain ⟨data, hcoeff⟩ := PhiGen.exists_modularPolynomialData_coeff_eq hc hint hmem
+  exact ⟨data,
+    PhiGen.phiIrreducible_of_splits ℓ hzu.unit hζ data (PhiGen.splits_of_coeff_evalAtJ_eq hzu.unit
+      hc data hcoeff),
+    PhiGen.evalSymm_of_coeff_evalAtJ_eq hζ hc data hcoeff⟩
+
+end ModularCurve
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_exists_phiIrreducible_evalSymm.ModularCurve
+  ModularCurve.PhiGen in
+theorem solution (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] :
+    ∃ data : ModularPolynomialData ℓ, PhiIrreducible data ∧ EvalSymm data.Φ :=
+  ModularCurve.exists_phiIrreducible_evalSymm ℓ
+
+end S_ModularCurve_exists_phiIrreducible_evalSymm
+end P2MW
+export P2MW.S_ModularCurve_exists_phiIrreducible_evalSymm (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.exists_phiIrreducible_evalSymm (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] :
+    ∃ data : ModularPolynomialData ℓ, PhiIrreducible data ∧ EvalSymm data.Φ :=
+  solution ℓ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_phiIrreducible_of_finrank_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_phiIrreducible_of_finrank_eq.lean
new file mode 100644
index 0000000000..d7ee07ad39
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_phiIrreducible_of_finrank_eq.lean
@@ -0,0 +1,242 @@
+/-
+Based on Prove2Me node ModularCurve.exists_phiIrreducible_of_finrank_eq
+(e71af2d3-396a-597b-a0df-2a757b4696b3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8828da09-8db7-553d-af8e-5ef441f6d129
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_monic_evalAtJ_jqN_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_evalAtJ_injective
+import Mathlib.FieldTheory.Minpoly.IsIntegrallyClosed
+import Mathlib.RingTheory.Localization.Integral
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Irreducible modular polynomial datum from degree ψ(N)
+
+Theorem statement: `ModularCurve.exists_phiIrreducible_of_finrank_eq`
+(`e71af2d3-396a-597b-a0df-2a757b4696b3`), by Claude, 2026-09-05.
+
+Proof: submission `8828da09-8db7-553d-af8e-5ef441f6d129`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, nonzero as a typeclass hypothesis. Inside the field of Laurent series
+$\mathrm{LaurentSeries}\,\mathbb{Q}$ (Hahn series over $\mathbb{Q}$ with integer exponents) consider
+the element `jq` $= q^{-1}\cdot j_{\mathrm{num}}$, the product of the Hahn monomial $q^{-1}$ with
+the image over $\mathbb{Q}$ of the integral power series `jNum`, and its $N$-th substitution `jqN
+N`, the image of `jq` under the ring homomorphism `qExpand` induced by $q \mapsto q^{N}$ (embedding
+of exponents along multiplication by $N$ on $\mathbb{Z}$). The hypothesis is that the intermediate
+field $\mathbb{Q}(jq)(jqN\,N)$, generated over the subfield $\mathbb{Q}(jq)$ by `jqN N`, has finite
+rank exactly `dedekindPsi N` $=\sum_{d\mid N,\ d\ \text{squarefree}} N/d$ as a module over
+$\mathbb{Q}(jq)$. The conclusion asserts the existence of a `ModularPolynomialData N`, that is a
+polynomial $\Phi \in \mathbb{Z}[X][Y]$ which is monic in $Y$, has $Y$-degree equal to `dedekindPsi
+N`, and satisfies $\Phi = 0$ after substituting `jqN N` for $Y$ and applying to the coefficients the
+ring homomorphism `evalAtJ : ℤ[X] → LaurentSeries ℚ` sending $X$ to `jq`, together with the property
+`PhiIrreducible`: the polynomial obtained from $\Phi$ by mapping its coefficients along `evalAtJGen`
+into $\mathbb{Q}(jq)$ is irreducible in $\mathbb{Q}(jq)[Y]$.
+
+This is the existence of the classical modular equation of level $N$: an irreducible modular
+polynomial $\Phi_N$ with integral coefficients, monic and of degree $\psi(N)$ in the second
+variable, vanishing at $(j(q), j(q^N))$ — obtained here from the degree equality
+$[\mathbb{Q}(j)(j(q^N)):\mathbb{Q}(j)] = \psi(N)$, which is established separately level by level.
+It feeds the unconditional existence statement
+[`ModularCurve.exists_phiIrreducible`](thm.html#ModularCurve.exists_phiIrreducible), the computation
+[`ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi`]
+(thm.html#ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi),
+and the generation of the function field of $X_0(N)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_phiIrreducible_of_finrank_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_phiIrreducible_of_finrank_eq
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jq jqN dedekindPsi evalAtJ ModularPolynomialData evalAtJGen \
+  algebraMap_comp_evalAtJGen PhiIrreducible exists_monic_evalAtJ_jqN_eq_zero \
+  PhiGen.evalAtJ_injective"
+namespace W1
+p2m_open "ModularCurve"
+
+open Polynomial IntermediateField
+
+theorem coe_evalAtJGen (g : Polynomial ℤ) :
+    ((evalAtJGen g : ℚ⟮jq⟯) : LaurentSeries ℚ) = evalAtJ g :=
+  RingHom.congr_fun algebraMap_comp_evalAtJGen g
+
+theorem aeval_map_intCast (g : Polynomial ℤ) :
+    Polynomial.aeval jq (g.map (algebraMap ℤ ℚ)) = evalAtJ g := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_map]
+  congr 1
+  exact RingHom.ext_int _ _
+
+theorem evalAtJ_C (b : ℤ) : evalAtJ (Polynomial.C b) = (b : LaurentSeries ℚ) := by
+  simp [evalAtJ]
+
+theorem evalAtJGen_injective : Function.Injective evalAtJGen := by
+  have h : Function.Injective ((algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) ∘ evalAtJGen) := by
+    rw [← RingHom.coe_comp, algebraMap_comp_evalAtJGen]
+    exact ModularCurve.PhiGen.evalAtJ_injective
+  exact h.of_comp
+
+end ModularCurve.W1
+
+open IntermediateField Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jq jqN dedekindPsi evalAtJ ModularPolynomialData evalAtJGen \
+  algebraMap_comp_evalAtJGen PhiIrreducible exists_monic_evalAtJ_jqN_eq_zero \
+  PhiGen.evalAtJ_injective"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.exists_phiIrreducible_of_finrank_eq (N : ℕ) [NeZero N]
+    (h : Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+        ({jqN N} : Set (LaurentSeries ℚ))) = dedekindPsi N) :
+    ∃ data : ModularPolynomialData N, PhiIrreducible data := by
+  let : Algebra (Polynomial ℤ) ℚ⟮jq⟯ := evalAtJGen.toAlgebra
+  let : Algebra (Polynomial ℤ) (LaurentSeries ℚ) := evalAtJ.toAlgebra
+  have tower : IsScalarTower (Polynomial ℤ) ℚ⟮jq⟯ (LaurentSeries ℚ) :=
+    IsScalarTower.of_algebraMap_eq fun x =>
+      (RingHom.congr_fun algebraMap_comp_evalAtJGen x).symm
+  have : IsFractionRing (Polynomial ℤ) ℚ⟮jq⟯ := by
+    refine { map_units := ?_, surj := ?_, exists_of_eq := ?_ }
+    · rintro ⟨y, hy⟩
+      rw [mem_nonZeroDivisors_iff_ne_zero] at hy
+      refine isUnit_iff_ne_zero.mpr fun h0 => hy (W1.evalAtJGen_injective ?_)
+      rw [map_zero]
+      exact h0
+    · intro z
+      by_cases hz : (z : LaurentSeries ℚ) = 0
+      · refine ⟨(0, 1), ?_⟩
+        have hz0 : z = 0 := Subtype.ext hz
+        rw [hz0]
+        simp
+      · obtain ⟨r, s, hrs⟩ :=
+          (IntermediateField.mem_adjoin_simple_iff ℚ (z : LaurentSeries ℚ)).mp z.2
+        have hs0 : Polynomial.aeval jq s ≠ 0 := by
+          intro h0
+          apply hz
+          rw [hrs, h0, div_zero]
+        have hzs : (z : LaurentSeries ℚ) * Polynomial.aeval jq s = Polynomial.aeval jq r := by
+          rw [hrs, div_mul_cancel₀ _ hs0]
+        obtain ⟨br, hbr, hrn⟩ := IsLocalization.integerNormalization_spec (nonZeroDivisors ℤ) r
+        obtain ⟨bs, hbs, hsn⟩ := IsLocalization.integerNormalization_spec (nonZeroDivisors ℤ) s
+        rw [mem_nonZeroDivisors_iff_ne_zero] at hbr hbs
+        have hrval : evalAtJ (IsLocalization.integerNormalization (nonZeroDivisors ℤ) r) =
+            br • Polynomial.aeval jq r := by
+          rw [← W1.aeval_map_intCast, hrn]
+          exact map_zsmul _ br r
+        have hsval : evalAtJ (IsLocalization.integerNormalization (nonZeroDivisors ℤ) s) =
+            bs • Polynomial.aeval jq s := by
+          rw [← W1.aeval_map_intCast, hsn]
+          exact map_zsmul _ bs s
+        have hs'0 : IsLocalization.integerNormalization (nonZeroDivisors ℤ) s ≠ 0 := by
+          intro h0
+          have h1 : evalAtJ (IsLocalization.integerNormalization (nonZeroDivisors ℤ) s) = 0 := by
+            rw [h0, map_zero]
+          rw [hsval] at h1
+          have h2 : (bs : LaurentSeries ℚ) * Polynomial.aeval jq s = 0 :=
+            (zsmul_eq_mul (Polynomial.aeval jq s) bs).symm.trans h1
+          rcases mul_eq_zero.mp h2 with hb | hss
+          · apply hbs
+            have h3 : algebraMap ℚ (LaurentSeries ℚ) ((bs : ℚ)) =
+                algebraMap ℚ (LaurentSeries ℚ) 0 := by
+              rw [map_intCast, map_zero]
+              exact hb
+            have h4 : (bs : ℚ) = 0 := (algebraMap ℚ (LaurentSeries ℚ)).injective h3
+            exact_mod_cast h4
+          · exact hs0 hss
+        have hcoe : ∀ g : Polynomial ℤ,
+            ((algebraMap (Polynomial ℤ) ℚ⟮jq⟯ g : ℚ⟮jq⟯) : LaurentSeries ℚ) = evalAtJ g :=
+          fun g => RingHom.congr_fun algebraMap_comp_evalAtJGen g
+        have key : (z : LaurentSeries ℚ) *
+            evalAtJ (Polynomial.C br * IsLocalization.integerNormalization (nonZeroDivisors ℤ) s) =
+            evalAtJ (Polynomial.C bs * IsLocalization.integerNormalization (nonZeroDivisors ℤ) r)
+              := by
+          rw [map_mul, map_mul, W1.evalAtJ_C, W1.evalAtJ_C, hrval, hsval, zsmul_eq_mul,
+            zsmul_eq_mul, ← hzs]
+          ring
+        refine ⟨(Polynomial.C bs * IsLocalization.integerNormalization (nonZeroDivisors ℤ) r,
+          ⟨Polynomial.C br * IsLocalization.integerNormalization (nonZeroDivisors ℤ) s,
+            mem_nonZeroDivisors_of_ne_zero
+              (mul_ne_zero (Polynomial.C_ne_zero.mpr hbr) hs'0)⟩), Subtype.ext ?_⟩
+        change ((z * algebraMap (Polynomial ℤ) ℚ⟮jq⟯
+            (Polynomial.C br * IsLocalization.integerNormalization (nonZeroDivisors ℤ) s) :
+              ℚ⟮jq⟯) : LaurentSeries ℚ) =
+          ((algebraMap (Polynomial ℤ) ℚ⟮jq⟯
+            (Polynomial.C bs * IsLocalization.integerNormalization (nonZeroDivisors ℤ) r) :
+              ℚ⟮jq⟯) : LaurentSeries ℚ)
+        rw [MulMemClass.coe_mul, hcoe, hcoe]
+        exact key
+    · intro x y hxy
+      exact ⟨1, by rw [W1.evalAtJGen_injective hxy]⟩
+  have hx : IsIntegral (Polynomial ℤ) (jqN N) := by
+    obtain ⟨P, hP, hval⟩ := ModularCurve.exists_monic_evalAtJ_jqN_eq_zero N
+    exact ⟨P, hP, hval⟩
+  have hxQ : IsIntegral ℚ⟮jq⟯ (jqN N) := hx.tower_top
+  have hmin := minpoly.isIntegrallyClosed_eq_field_fractions' ℚ⟮jq⟯ hx
+  rw [IntermediateField.adjoin.finrank hxQ] at h
+  have hΦm : (minpoly (Polynomial ℤ) (jqN N)).Monic := minpoly.monic hx
+  have hdeg : (minpoly (Polynomial ℤ) (jqN N)).natDegree = dedekindPsi N := by
+    rw [← hΦm.natDegree_map (algebraMap (Polynomial ℤ) ℚ⟮jq⟯), ← hmin]
+    exact h
+  have heval : (minpoly (Polynomial ℤ) (jqN N)).eval₂ evalAtJ (jqN N) = 0 := by
+    have ha := minpoly.aeval (Polynomial ℤ) (jqN N)
+    rw [Polynomial.aeval_def] at ha
+    exact ha
+  refine ⟨⟨minpoly (Polynomial ℤ) (jqN N), hΦm, hdeg, heval⟩, ?_⟩
+  change Irreducible (Polynomial.map evalAtJGen (minpoly (Polynomial ℤ) (jqN N)))
+  have hmap : Polynomial.map evalAtJGen (minpoly (Polynomial ℤ) (jqN N)) =
+      minpoly ℚ⟮jq⟯ (jqN N) := hmin.symm
+  rw [hmap]
+  exact minpoly.irreducible hxQ
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_exists_phiIrreducible_of_finrank_eq.ModularCurve
+  ModularCurve.PhiGen in
+theorem solution (N : ℕ) [NeZero N] (h : Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set
+  (LaurentSeries ℚ))) (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set
+  (LaurentSeries ℚ))) ({jqN N} : Set (LaurentSeries ℚ))) = dedekindPsi N) :
+    ∃ data : ModularPolynomialData N, PhiIrreducible data :=
+  ModularCurve.exists_phiIrreducible_of_finrank_eq N h
+
+end S_ModularCurve_exists_phiIrreducible_of_finrank_eq
+end P2MW
+export P2MW.S_ModularCurve_exists_phiIrreducible_of_finrank_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.exists_phiIrreducible_of_finrank_eq (N : ℕ) [NeZero N] (h : Module.finrank
+  (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (IntermediateField.adjoin
+  (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) ({jqN N} : Set (LaurentSeries ℚ))) =
+  dedekindPsi N) :
+    ∃ data : ModularPolynomialData N, PhiIrreducible data :=
+  solution N h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_place_algebraicClosure_ord_comp_eq_of_laurentBaseChange.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_place_algebraicClosure_ord_comp_eq_of_laurentBaseChange.lean
new file mode 100644
index 0000000000..5dde464441
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_place_algebraicClosure_ord_comp_eq_of_laurentBaseChange.lean
@@ -0,0 +1,302 @@
+/-
+Based on Prove2Me node ModularCurve.exists_place_algebraicClosure_ord_comp_eq_of_laurentBaseChange
+(f75c7e66-2f67-5579-a0cf-8fd32f6b5493) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9e204ab1-42d0-5306-a73d-987999a5db75
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_comap_algebraMap_eq_of_constantFieldExtension
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_transcendental_of_perfectField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_JOneES_exists_transcendental_finiteDimensional_laurentBaseChange
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap_ringHom
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Places descend along constant field extension of q-expansion fields
+
+Theorem statement: `ModularCurve.exists_place_algebraicClosure_ord_comp_eq_of_laurentBaseChange`
+(`f75c7e66-2f67-5579-a0cf-8fd32f6b5493`), by Claude, 2026-09-05.
+
+Proof: submission `9e204ab1-42d0-5306-a73d-987999a5db75`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field equipped with a $\mathbb{Q}$-algebra structure, let $\Gamma
+\le \mathrm{SL}_2(\mathbb{Z})$ be a subgroup of finite index containing $T =
+\begin{pmatrix}1&1\\0&1\end{pmatrix}$, and let $F(\Gamma) =$ `qExpFunctionFieldC ℚ Γ` be the
+subfield of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by the quotients $\mathrm{intSeriesC}\,p_f
+/ \mathrm{intSeriesC}\,p_g$, where $f,g$ are modular forms of some weight $k$ for $\Gamma$ (viewed
+inside $\mathrm{GL}_2(\mathbb{R})$) with integral $q$-expansions $p_f, p_g \in \mathbb{Z}[[q]]$ and
+$\mathrm{intSeriesC}\,p_g \ne 0$. For a field $L$ over $\mathbb{Q}$ write $L\cdot F(\Gamma)$ for
+`laurentBaseChange L (qExpFunctionFieldC ℚ Γ)`, the subfield of $L((q))$ generated over $L$ by the
+image of $F(\Gamma)$ under coefficientwise application of $\mathbb{Q} \to L$. Let $\tau \colon
+\overline{\mathbb{Q}} \to K$ be a $\mathbb{Q}$-algebra embedding and let $\Psi \colon
+\overline{\mathbb{Q}}\cdot F(\Gamma) \to K\cdot F(\Gamma)$ be a ring homomorphism which, on
+underlying Laurent series, acts by applying $\tau$ to each coefficient. Let $P$ be a place of
+$K\cdot F(\Gamma)$ over $K$ — that is, a valuation subring of $K\cdot F(\Gamma)$ containing the
+image of $K$, distinct from the whole field and a principal ideal ring — and suppose
+$\mathrm{ord}_P(\Psi f) \ne 0$ for at least one $f$, where $\mathrm{ord}$ denotes the negative
+logarithm of the associated height-one adic valuation. Then there exists a place $P_0$ of
+$\overline{\mathbb{Q}}\cdot F(\Gamma)$ over $\overline{\mathbb{Q}}$ with $\mathrm{ord}_P(\Psi f) =
+\mathrm{ord}_{P_0}(f)$ for every $f \in \overline{\mathbb{Q}}\cdot F(\Gamma)$.
+
+This is the invariance of orders under a constant field extension of a one-variable function field
+with algebraically closed constant field, in the form needed for the function fields of modular
+curves: a nontrivial place upstairs restricts along the coefficientwise embedding to a place
+downstairs with identical order function, no ramification occurring. It is used in the computations
+of orders of functions at places of the base-changed $q$-expansion fields for $\Gamma_0(N)$ and
+$\Gamma_1(N)$, and in the counting of places by double cosets.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_place_algebraicClosure_ord_comp_eq_of_laurentBaseChange.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_place_algebraicClosure_ord_comp_eq_of_laurentBaseChange
+
+noncomputable section
+
+p2m_open "AlgebraicCurve ModularCurve \
+  P2MW.S_ModularCurve_exists_place_algebraicClosure_ord_comp_eq_of_laurentBaseChange.ModularCurve"
+open scoped MatrixGroups
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpFunctionFieldC coeffMap coeffMap_single coeffMap_coeffMap \
+  coeffMap_congr algebraMap_laurentSeries_eq_single coeffEmb laurentBaseChange \
+  coeffEmb_mem_laurentBaseChange mem_laurentBaseChange_iff \
+  JOneES.exists_transcendental_finiteDimensional_laurentBaseChange"
+namespace T1Aux
+p2m_open "ModularCurve"
+
+section CoeffLift
+
+variable {L : Type*} [Field L] {Ω : Type*} [Field Ω] [Algebra ℚ L] [Algebra ℚ Ω] (τ : L →ₐ[ℚ] Ω)
+  (F₀ : IntermediateField ℚ (LaurentSeries ℚ))
+
+theorem coeffMap_coeffEmb' (x : LaurentSeries ℚ) :
+    coeffMap τ.toRingHom (coeffEmb L x) = coeffEmb Ω x := by
+  change coeffMap _ (coeffMap _ x) = coeffMap _ x
+  rw [coeffMap_coeffMap]
+  exact coeffMap_congr (RingHom.ext_rat _ _) x
+
+theorem coeffMap_algebraMap' (c : L) :
+    coeffMap τ.toRingHom (algebraMap L (LaurentSeries L) c) = algebraMap Ω (LaurentSeries Ω) (τ c)
+      := by
+  rw [algebraMap_laurentSeries_eq_single, algebraMap_laurentSeries_eq_single, coeffMap_single]
+  rfl
+
+theorem coeffMap_mem_laurentBaseChange' {x : LaurentSeries L} (hx : x ∈ laurentBaseChange L F₀) :
+    coeffMap τ.toRingHom x ∈ laurentBaseChange Ω F₀ := by
+  rw [mem_laurentBaseChange_iff] at hx
+  induction hx using Subfield.closure_induction with
+  | mem y hy =>
+      rcases hy with ⟨a, rfl⟩ | ⟨z, hz, rfl⟩
+      · rw [coeffMap_algebraMap']
+        exact (laurentBaseChange Ω F₀).algebraMap_mem _
+      · rw [coeffMap_coeffEmb']
+        exact coeffEmb_mem_laurentBaseChange Ω hz
+  | one => simp
+  | add _ _ _ _ hx hy => simpa using add_mem hx hy
+  | neg _ _ hx => simpa using neg_mem hx
+  | inv _ _ hx => simpa using inv_mem hx
+  | mul _ _ _ _ hx hy => simpa using mul_mem hx hy
+
+@[reducible] def algebraOfLift : Algebra L ↥(laurentBaseChange Ω F₀) :=
+  ((algebraMap Ω ↥(laurentBaseChange Ω F₀)).comp τ.toRingHom).toAlgebra
+
+def liftRingHom : ↥(laurentBaseChange L F₀) →+* ↥(laurentBaseChange Ω F₀) :=
+  ((coeffMap τ.toRingHom).comp (laurentBaseChange L F₀).toSubring.subtype).codRestrict
+    (laurentBaseChange Ω F₀).toSubring (fun x => coeffMap_mem_laurentBaseChange' τ F₀ x.2)
+
+theorem coe_liftRingHom (x : ↥(laurentBaseChange L F₀)) :
+    ((liftRingHom τ F₀ x : ↥(laurentBaseChange Ω F₀)) : LaurentSeries Ω) = coeffMap τ.toRingHom x :=
+  rfl
+
+def liftHom :
+    letI := algebraOfLift τ F₀; ↥(laurentBaseChange L F₀) →ₐ[L] ↥(laurentBaseChange Ω F₀) :=
+  letI := algebraOfLift τ F₀
+  { liftRingHom τ F₀ with
+    commutes' := fun c => Subtype.ext (by
+      change coeffMap τ.toRingHom (algebraMap L (LaurentSeries L) c) = algebraMap Ω (LaurentSeries
+        Ω) (τ c)
+      exact coeffMap_algebraMap' τ c) }
+
+theorem coe_liftHom (x : ↥(laurentBaseChange L F₀)) :
+    letI := algebraOfLift τ F₀; ((liftHom τ F₀ x : ↥(laurentBaseChange Ω F₀)) : LaurentSeries Ω) =
+      coeffMap τ.toRingHom x :=
+  rfl
+
+theorem liftHom_toRingHom :
+    letI := algebraOfLift τ F₀; (liftHom τ F₀).toRingHom = liftRingHom τ F₀ := rfl
+
+set_option synthInstance.maxHeartbeats 1600000 in
+theorem adjoin_range_liftRingHom_eq_top :
+    IntermediateField.adjoin Ω (Set.range (liftRingHom τ F₀)) = ⊤ := by
+  rw [eq_top_iff]
+  intro z _
+  let T : IntermediateField Ω ↥(laurentBaseChange Ω F₀) :=
+    IntermediateField.adjoin Ω (Set.range (liftRingHom τ F₀))
+  let T' : Subfield (LaurentSeries Ω) := T.toSubfield.map (laurentBaseChange Ω F₀).val.toRingHom
+  have hgens : Set.range (algebraMap Ω (LaurentSeries Ω)) ∪ (⇑(coeffEmb Ω) '' (F₀ : Set
+    (LaurentSeries ℚ))) ⊆ T' :=
+    by
+    rintro w (⟨a, rfl⟩ | ⟨x, hx, rfl⟩)
+    · exact ⟨algebraMap Ω ↥(laurentBaseChange Ω F₀) a, T.algebraMap_mem a, rfl⟩
+    · refine ⟨liftRingHom τ F₀ ⟨coeffEmb L x, coeffEmb_mem_laurentBaseChange L hx⟩,
+        IntermediateField.subset_adjoin Ω _ ⟨_, rfl⟩, ?_⟩
+      change coeffMap τ.toRingHom (coeffEmb L x) = coeffEmb Ω x
+      exact coeffMap_coeffEmb' τ x
+  have hle : Subfield.closure (Set.range (algebraMap Ω (LaurentSeries Ω)) ∪
+      (⇑(coeffEmb Ω) '' (F₀ : Set (LaurentSeries ℚ)))) ≤ T' := Subfield.closure_le.mpr hgens
+  obtain ⟨w, hw, hwz⟩ := hle (mem_laurentBaseChange_iff.mp z.2)
+  have : w = z := Subtype.ext hwz
+  rw [← this]
+  exact hw
+
+end CoeffLift
+
+end ModularCurve.T1Aux
+
+set_option synthInstance.maxHeartbeats 1600000 in
+open ModularCurve.T1Aux in
+theorem solution
+    (K : Type*) [Field K] [Algebra ℚ K] [IsAlgClosed K]
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) (hT : ModularGroup.T ∈ Γ) [Γ.FiniteIndex]
+    (τ : AlgebraicClosure ℚ →ₐ[ℚ] K)
+    (Ψ : ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+      Γ)) →+*
+           ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ Γ)))
+    (hΨ : ∀ f, ((Ψ f : ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ Γ))) :
+      LaurentSeries K)
+             = ModularCurve.coeffMap τ.toRingHom (f : LaurentSeries (AlgebraicClosure ℚ)))
+    (P : AlgebraicCurve.Place K ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC
+      ℚ Γ)))
+    (hP : ∃ f, P.ord (Ψ f) ≠ 0) :
+    ∃ P₀ : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+        ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+          Γ)),
+      ∀ f, P.ord (Ψ f) = P₀.ord f := by
+  classical
+  have hΨeq : Ψ = liftRingHom τ (ModularCurve.qExpFunctionFieldC ℚ Γ) := by
+    refine RingHom.ext fun f => Subtype.ext ?_
+    rw [hΨ, coe_liftRingHom]
+  let algQK : Algebra (AlgebraicClosure ℚ) K := τ.toRingHom.toAlgebra
+  let algQF : Algebra (AlgebraicClosure ℚ) ↥(laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ
+    Γ)) :=
+    algebraOfLift τ (ModularCurve.qExpFunctionFieldC ℚ Γ)
+  have : IsScalarTower (AlgebraicClosure ℚ) K ↥(laurentBaseChange K (ModularCurve.qExpFunctionFieldC
+    ℚ Γ)) :=
+    IsScalarTower.of_algebraMap_eq fun _ => rfl
+  let algFF : Algebra ↥(laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+    Γ)) ↥(laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ Γ)) :=
+    Ψ.toAlgebra
+  have : IsScalarTower (AlgebraicClosure ℚ) ↥(laurentBaseChange (AlgebraicClosure ℚ)
+    (ModularCurve.qExpFunctionFieldC ℚ Γ)) ↥(laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ
+    Γ)) :=
+    by
+    refine IsScalarTower.of_algebraMap_eq fun c => ?_
+    change _ = Ψ (algebraMap (AlgebraicClosure ℚ) ↥(laurentBaseChange (AlgebraicClosure ℚ)
+      (ModularCurve.qExpFunctionFieldC ℚ Γ)) c)
+    rw [hΨeq]
+    exact ((liftHom τ (ModularCurve.qExpFunctionFieldC ℚ Γ)).commutes c).symm
+  obtain ⟨x₀, hx₀tr, hx₀fd⟩ :=
+    ModularCurve.JOneES.exists_transcendental_finiteDimensional_laurentBaseChange (AlgebraicClosure
+      ℚ) Γ hT
+  have := hx₀fd
+  have : IsCurveOver (AlgebraicClosure ℚ) ↥(laurentBaseChange (AlgebraicClosure ℚ)
+    (ModularCurve.qExpFunctionFieldC ℚ Γ)) :=
+    isCurveOver_of_transcendental_of_perfectField hx₀tr hx₀fd
+  obtain ⟨x₁, hx₁tr, hx₁fd⟩ :=
+    ModularCurve.JOneES.exists_transcendental_finiteDimensional_laurentBaseChange K Γ hT
+  have hgen : IntermediateField.adjoin K (Set.range (algebraMap ↥(laurentBaseChange
+    (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ Γ)) ↥(laurentBaseChange K
+    (ModularCurve.qExpFunctionFieldC ℚ Γ)))) = ⊤ :=
+    by
+    change IntermediateField.adjoin K (Set.range Ψ) = ⊤
+    rw [hΨeq]
+    exact adjoin_range_liftRingHom_eq_top τ (ModularCurve.qExpFunctionFieldC ℚ Γ)
+  have hwK : ∀ a : AlgebraicClosure ℚ, Ψ (algebraMap (AlgebraicClosure ℚ) ↥(laurentBaseChange
+    (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ Γ)) a) ∈ P.toValuationSubring :=
+    by
+    intro a
+    have : Ψ (algebraMap (AlgebraicClosure ℚ) ↥(laurentBaseChange (AlgebraicClosure ℚ)
+      (ModularCurve.qExpFunctionFieldC ℚ Γ)) a) = algebraMap K ↥(laurentBaseChange K
+      (ModularCurve.qExpFunctionFieldC ℚ Γ)) (τ a) :=
+      by
+      rw [hΨeq]
+      exact (liftHom τ (ModularCurve.qExpFunctionFieldC ℚ Γ)).commutes a
+    rw [this]
+    exact P.algebraMap_mem' (τ a)
+  have hwx : ∃ y : ↥(laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ Γ)),
+    Ψ y ∉ P.toValuationSubring :=
+    by
+    obtain ⟨f, hf⟩ := hP
+    by_contra hall
+    push Not at hall
+    apply hf
+    have hf0 : Ψ f ≠ 0 := by
+      intro h0; apply hf; rw [h0, Place.ord_zero]
+    have h1 : Ψ f ∈ P.toValuationSubring := hall f
+    have h2 : (Ψ f)⁻¹ ∈ P.toValuationSubring := by rw [← map_inv₀]; exact hall f⁻¹
+    let u : (↥P.toValuationSubring)ˣ :=
+      ⟨⟨Ψ f, h1⟩, ⟨(Ψ f)⁻¹, h2⟩, Subtype.ext (mul_inv_cancel₀ hf0), Subtype.ext (inv_mul_cancel₀
+        hf0)⟩
+    exact P.ord_coe_unit u
+  obtain ⟨P₀, hP₀⟩ :=
+    Place.exists_toValuationSubring_eq_comap_ringHom (K := AlgebraicClosure ℚ) x₀ Ψ
+    P.toValuationSubring hwK hwx
+  obtain ⟨P', -, hP'ord, huniq⟩ := Place.exists_comap_algebraMap_eq_of_constantFieldExtension
+    (AlgebraicClosure ℚ) ↥(laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+      Γ)) K ↥(laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ Γ))
+    ⟨x₀, hx₀tr, hx₀fd⟩ ⟨x₁, hx₁tr, hx₁fd⟩ hgen P₀
+  have hPP' : P = P' := huniq P (by rw [hP₀]; rfl)
+  refine ⟨P₀, fun f => ?_⟩
+  rw [hPP']
+  exact hP'ord f
+
+end
+
+end S_ModularCurve_exists_place_algebraicClosure_ord_comp_eq_of_laurentBaseChange
+end P2MW
+export P2MW.S_ModularCurve_exists_place_algebraicClosure_ord_comp_eq_of_laurentBaseChange (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem ModularCurve.exists_place_algebraicClosure_ord_comp_eq_of_laurentBaseChange
+    (K : Type*) [Field K] [Algebra ℚ K] [IsAlgClosed K]
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) (hT : ModularGroup.T ∈ Γ) [Γ.FiniteIndex]
+    (τ : AlgebraicClosure ℚ →ₐ[ℚ] K)
+    (Ψ : ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+      Γ)) →+*
+           ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ Γ)))
+    (hΨ : ∀ f, ((Ψ f : ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ Γ))) :
+      LaurentSeries K)
+             = ModularCurve.coeffMap τ.toRingHom (f : LaurentSeries (AlgebraicClosure ℚ)))
+    (P : AlgebraicCurve.Place K ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC
+      ℚ Γ)))
+    (hP : ∃ f, P.ord (Ψ f) ≠ 0) :
+    ∃ P₀ : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+        ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+          Γ)),
+      ∀ f, P.ord (Ψ f) = P₀.ord f :=
+  solution K Γ hT τ Ψ hΨ P hP
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_place_of_emb.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_place_of_emb.lean
new file mode 100644
index 0000000000..e6ac5d62ce
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_place_of_emb.lean
@@ -0,0 +1,305 @@
+/-
+Based on Prove2Me node ModularCurve.exists_place_of_emb
+(78e864be-091d-51f3-b418-323cd2bbb50e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission aa026c6d-f9d9-5692-a82a-9066f00dedf5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EMD
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_MazurStepThreeInputs
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_RamificationBound
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_hasRamBound
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_hasRamBound_natDegree_factorial_of_isRoot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_mem_puiseuxRamSubfield_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_adjoin_jBar_jNBar_eq_top
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_modularPolynomialData
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Normalised Hahn-series embeddings induce places of F_N
+
+Theorem statement: `ModularCurve.exists_place_of_emb` (`78e864be-091d-51f3-b418-323cd2bbb50e`), by
+Claude, 2026-09-05.
+
+Proof: submission `aa026c6d-f9d9-5692-a82a-9066f00dedf5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a non-zero natural number and let $j_0$ be an element of $\overline{\mathbb{Q}}$
+(realised as `AlgebraicClosure ℚ`). Write $\overline{F_N}$ for `modularFunctionFieldBar N`, the
+intermediate field of the Laurent series field $\overline{\mathbb{Q}}((q))$ over
+$\overline{\mathbb{Q}}$ generated by the image, under the coefficient-extension embedding
+`coeffEmb`, of `modularFunctionFieldFull N`, itself the subfield of $\mathbb{Q}((q))$ generated over
+$\mathbb{Q}$ by the family `divisorExpansions N`. Let $\psi$ be an element of `Emb N j₀`, that is, a
+pair consisting of an $\overline{\mathbb{Q}}$-algebra homomorphism $\psi_1$ from $\overline{F_N}$
+into the field `HahnSeries ℚ (AlgebraicClosure ℚ)` of Hahn series with rational exponents and
+coefficients in $\overline{\mathbb{Q}}$, together with the normalisation that $\psi_1$ sends `jBar
+N` (the image of the $q$-expansion of $j$) to $j_0 + q$, i.e. to the constant series $j_0$ plus the
+monomial of exponent $1$ and coefficient $1$. The assertion is that there exist a place $w$ of
+$\overline{F_N}$ over $\overline{\mathbb{Q}}$ — a valuation subring of $\overline{F_N}$ containing
+$\overline{\mathbb{Q}}$, distinct from the whole field, and a principal ideal ring — and a rational
+number $g > 0$ such that for every $x \in \overline{F_N}$ one has $(\operatorname{ord}_w x)\, g =
+\operatorname{order}(\psi_1 x)$, where $\operatorname{ord}_w x$ is the integer $-\log$ of the adic
+valuation of $x$ at $w$ and $\operatorname{order}$ is the exponent of the leading term of a Hahn
+series.
+
+This is the step that converts a normalised Hahn-series expansion of the level $N$ modular function
+field at $j_0$ into a genuine place of that field, with the orders of vanishing matching up to a
+single positive rational factor (the reciprocal of the ramification index over $j_0$). It is used in
+the counting of places where `jBar` has order one, in
+[`ModularCurve.card_filter_ord_jBar_eq_one_eq_nuThree`]
+(thm.html#ModularCurve.card_filter_ord_jBar_eq_one_eq_nuThree)
+and
+[`ModularCurve.card_filter_ord_jBar_sub_1728_eq_one_eq_nuTwo`]
+(thm.html#ModularCurve.card_filter_ord_jBar_sub_1728_eq_one_eq_nuTwo),
+and in [`ModularCurve.emd_holds`](thm.html#ModularCurve.emd_holds).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_place_of_emb.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_place_of_emb
+
+
+noncomputable section
+
+open ModularCurve AlgebraicCurve IntermediateField Polynomial
+
+namespace S12P
+
+variable (N : ℕ) [NeZero N]
+
+abbrev jb : ↥(modularFunctionFieldBar N) :=
+  ⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+    (jq_mem_full N)⟩
+
+abbrev jNb : ↥(modularFunctionFieldBar N) :=
+  ⟨coeffEmb (AlgebraicClosure ℚ) (qExpand ℚ N jq),
+    coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jqd_mem_full N (dvd_refl N))⟩
+
+theorem eval₂_Phi_jb_jNb (data : ModularPolynomialData N) :
+    data.Φ.eval₂ (Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N)) (jb N))
+      (jNb N)
+      = 0 := by
+  apply Subtype.ext
+  have hval : ((modularFunctionFieldBar N).toSubfield.subtype).comp
+      (Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N)) (jb N))
+      = (coeffEmb (AlgebraicClosure ℚ)).comp evalAtJ := by
+    refine Polynomial.ringHom_ext (fun z => by simp) ?_
+    change ((Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N)) (jb N) X :
+        ↥(modularFunctionFieldBar N)) : LaurentSeries (AlgebraicClosure ℚ)) = coeffEmb
+          (AlgebraicClosure ℚ) (evalAtJ X)
+    rw [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X, evalAtJ_X]
+  have h0 := congrArg (coeffEmb (AlgebraicClosure ℚ)) data.eval_eq_zero
+  rw [map_zero, Polynomial.hom_eval₂, ← hval] at h0
+  rw [ZeroMemClass.coe_zero, ← h0]
+  change ((modularFunctionFieldBar N).toSubfield.subtype) _ = _
+  rw [Polynomial.hom_eval₂]
+  rfl
+
+section Hahn
+
+variable {e : ℕ}
+
+theorem hasRamBound_of_one (he : 0 < e) {y : HahnSeries ℚ (AlgebraicClosure ℚ)}
+    (hy : HahnSeries.HasRamBound 1 y) : HahnSeries.HasRamBound e y := by
+  intro g hg
+  obtain ⟨k, hk⟩ := hy hg
+  refine ⟨k * e, ?_⟩
+  simp only [Nat.cast_one, div_one] at hk
+  have he' : (e : ℚ) ≠ 0 := Nat.cast_ne_zero.mpr he.ne'
+  rw [← hk]; push_cast; field_simp
+
+theorem hasRamBound_C (a : AlgebraicClosure ℚ) :
+    HahnSeries.HasRamBound 1 (HahnSeries.C a : HahnSeries ℚ (AlgebraicClosure ℚ)) := by
+  intro g hg
+  have : g ∈ ({0} : Set ℚ) := HahnSeries.support_single_subset (a := (0 : ℚ)) (r := a) hg
+  rw [Set.mem_singleton_iff] at this
+  exact ⟨0, by simp [this]⟩
+
+theorem hasRamBound_C_add_single (a : AlgebraicClosure ℚ) :
+    HahnSeries.HasRamBound 1
+      (HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)) := by
+  intro g hg
+  rcases (HahnSeries.support_add_subset (x := HahnSeries.C a)
+      (y := HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ))) hg with h | h
+  · exact hasRamBound_C a h
+  · have : g ∈ ({1} : Set ℚ) :=
+      HahnSeries.support_single_subset (a := (1 : ℚ)) (r := (1 : AlgebraicClosure ℚ)) h
+    rw [Set.mem_singleton_iff] at this
+    exact ⟨1, by simp [this]⟩
+
+theorem algebraMap_hahn_eq_C (a : AlgebraicClosure ℚ) :
+    algebraMap (AlgebraicClosure ℚ) (HahnSeries ℚ (AlgebraicClosure ℚ)) a = HahnSeries.C a := by
+  rw [HahnSeries.algebraMap_apply']; simp
+
+theorem eval₂RingHom_mem_puiseuxRamSubfield_one (y : HahnSeries ℚ (AlgebraicClosure ℚ))
+    (hy : HahnSeries.HasRamBound 1 y) (q : Polynomial ℤ) :
+    Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ))) y q
+      ∈ HahnSeries.puiseuxRamSubfield (AlgebraicClosure ℚ) (e := 1) one_pos := by
+  rw [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_eq_sum_range]
+  refine Subfield.sum_mem _ (fun i _ => Subfield.mul_mem _ ?_ (Subfield.pow_mem _ ?_ _))
+  · exact intCast_mem _ _
+  · exact (HahnSeries.mem_puiseuxRamSubfield_iff one_pos).mpr hy
+
+end Hahn
+
+theorem exists_forall_hasRamBound (j₀ : AlgebraicClosure ℚ)
+    (ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ] HahnSeries ℚ (AlgebraicClosure ℚ))
+    (hψ : ψ (jb N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)) :
+    ∃ e : ℕ, 0 < e ∧ ∀ z, HahnSeries.HasRamBound e (ψ z) := by
+  obtain ⟨data⟩ := ModularCurve.nonempty_modularPolynomialData N
+  set P : Polynomial (HahnSeries ℚ (AlgebraicClosure ℚ)) :=
+    data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ)))
+      (HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ))) with hPdef
+  have hPmonic : P.Monic := data.monic.map _
+  have hP0 : P ≠ 0 := hPmonic.ne_zero
+  have hcoeff : ∀ i : ℕ, HahnSeries.HasRamBound 1 (P.coeff i) := by
+    intro i
+    rw [hPdef, Polynomial.coeff_map]
+    exact (HahnSeries.mem_puiseuxRamSubfield_iff one_pos).mp
+      (eval₂RingHom_mem_puiseuxRamSubfield_one _ (hasRamBound_C_add_single j₀) _)
+  have hroot : P.IsRoot (ψ (jNb N)) := by
+    rw [Polynomial.IsRoot, hPdef, Polynomial.eval_map, ← hψ]
+    have hcomp : Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ))) (ψ
+      (jb N))
+        = (ψ.toRingHom).comp (Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N))
+          (jb N)) := by
+      refine Polynomial.ringHom_ext (fun z => by simp) ?_
+      simp
+    rw [hcomp]
+    have h := (Polynomial.hom_eval₂ data.Φ
+      (Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N)) (jb N)) ψ.toRingHom
+        (jNb N)).symm
+    rw [eval₂_Phi_jb_jNb N data, map_zero] at h
+    simpa using h
+  have hbN := HahnSeries.hasRamBound_natDegree_factorial_of_isRoot hP0 hcoeff hroot
+  set e := P.natDegree.factorial with hedef
+  have he : 0 < e := Nat.factorial_pos _
+  refine ⟨e, he, ?_⟩
+  let S := HahnSeries.puiseuxRamSubfield (AlgebraicClosure ℚ) (e := e) he
+  have hS : ∀ y, y ∈ S ↔ HahnSeries.HasRamBound e y :=
+    fun y => HahnSeries.mem_puiseuxRamSubfield_iff he
+  let T : IntermediateField (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+    (S.comap ψ.toRingHom).toIntermediateField (fun a => by
+      change ψ (algebraMap (AlgebraicClosure ℚ) _ a) ∈ S
+      rw [ψ.commutes, hS, algebraMap_hahn_eq_C]
+      exact hasRamBound_of_one he (hasRamBound_C a))
+  have hjb : jb N ∈ T := by
+    change ψ (jb N) ∈ S
+    rw [hψ, hS]
+    exact hasRamBound_of_one he (hasRamBound_C_add_single j₀)
+  have hjNb : jNb N ∈ T := by
+    change ψ (jNb N) ∈ S
+    rw [hS]; exact hbN
+  have htop := ModularCurve.adjoin_jBar_jNBar_eq_top (AlgebraicClosure ℚ) N
+  have hle : (⊤ : IntermediateField (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)) ≤ T := by
+    rw [← htop, IntermediateField.adjoin_le_iff]
+    intro z hz
+    rcases hz with rfl | rfl
+    · exact hjb
+    · exact hjNb
+  intro z
+  exact (hS _).mp (hle IntermediateField.mem_top)
+
+omit [NeZero N] in
+theorem mem_iff_ord_nonneg (w : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N))
+    {x : ↥(modularFunctionFieldBar N)} (hx : x ≠ 0) :
+    x ∈ w.toValuationSubring ↔ 0 ≤ w.ord x := by
+  rw [Place.mem_iff_adicValuation_le_one, Place.ord, neg_nonneg,
+    WithZero.log_le_iff_le_exp (w.adicValuation_ne_zero hx), WithZero.exp_zero]
+
+theorem induces_unique
+    {ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ] HahnSeries ℚ (AlgebraicClosure ℚ)}
+    {w w' : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)}
+    (hw : Induces ψ w) (hw' : Induces ψ w') : w = w' := by
+  obtain ⟨g, hg, h⟩ := hw
+  obtain ⟨g', hg', h'⟩ := hw'
+  have key : ∀ x, 0 ≤ w.ord x ↔ 0 ≤ w'.ord x := by
+    intro x
+    have hx := h x
+    rw [← h' x] at hx
+    constructor
+    · intro h0
+      have : 0 ≤ (w'.ord x : ℚ) * g' := by rw [← hx]; positivity
+      exact_mod_cast nonneg_of_mul_nonneg_left this hg'
+    · intro h0
+      have : 0 ≤ (w.ord x : ℚ) * g := by rw [hx]; positivity
+      exact_mod_cast nonneg_of_mul_nonneg_left this hg
+  apply Place.ext
+  ext x
+  rcases eq_or_ne x 0 with rfl | hx
+  · simp [zero_mem]
+  · rw [mem_iff_ord_nonneg N w hx, mem_iff_ord_nonneg N w' hx, key]
+
+theorem pos_ord_of_induces (j₀ : AlgebraicClosure ℚ) (ψ : Emb N j₀)
+    {w : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)} (hw : Induces ψ.1 w) :
+    0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) j₀) := by
+  obtain ⟨g, hg, h⟩ := hw
+  have hx := h (jBar N - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) j₀)
+  rw [map_sub, ψ.2, AlgHom.commutes, algebraMap_hahn_eq_C, add_sub_cancel_left,
+    HahnSeries.order_single (one_ne_zero)] at hx
+  have : (0 : ℚ) < (w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) j₀)
+    : ℚ) * g :=
+    by
+    rw [hx]; exact_mod_cast one_pos
+  exact_mod_cast pos_of_mul_pos_left this hg.le
+
+theorem exists_induces (j₀ : AlgebraicClosure ℚ) (ψ : Emb N j₀) :
+    ∃ w : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N), Induces ψ.1 w := by
+  obtain ⟨e, he, hall⟩ := exists_forall_hasRamBound N j₀ ψ.1 ψ.2
+  have hnt : ∃ x : ↥(modularFunctionFieldBar N), (ψ.1 x).order ≠ 0 := by
+    refine ⟨jBar N - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) j₀, ?_⟩
+    rw [map_sub, ψ.2, AlgHom.commutes, algebraMap_hahn_eq_C, add_sub_cancel_left,
+      HahnSeries.order_single (one_ne_zero)]
+    exact one_ne_zero
+  obtain ⟨w, g, hg, h⟩ :=
+    AlgebraicCurve.Place.exists_ord_mul_eq_order_of_hasRamBound ψ.1 he hall hnt
+  exact ⟨w, g, hg, h⟩
+
+end S12P
+
+end
+
+open ModularCurve AlgebraicCurve in
+theorem solution (N : ℕ) [NeZero N] (j₀ : AlgebraicClosure ℚ)
+    (ψ : Emb N j₀) :
+    ∃ (w : AlgebraicCurve.Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)) (g : ℚ), 0 < g ∧
+      ∀ x : ↥(modularFunctionFieldBar N), (w.ord x : ℚ) * g = (ψ.1 x).order := by
+  obtain ⟨w, g, hg, h⟩ := S12P.exists_induces N j₀ ψ
+  exact ⟨w, g, hg, h⟩
+
+end S_ModularCurve_exists_place_of_emb
+end P2MW
+export P2MW.S_ModularCurve_exists_place_of_emb (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Polynomial
+theorem ModularCurve.exists_place_of_emb (N : ℕ) [NeZero N] (j₀ : AlgebraicClosure ℚ)
+    (ψ : Emb N j₀) :
+    ∃ (w : AlgebraicCurve.Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)) (g : ℚ), 0 < g ∧
+      ∀ x : ↥(modularFunctionFieldBar N), (w.ord x : ℚ) * g = (ψ.1 x).order :=
+  solution N j₀ ψ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_ratCast_qExpansion_comp_smul_of_mem_Gamma0.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_ratCast_qExpansion_comp_smul_of_mem_Gamma0.lean
new file mode 100644
index 0000000000..9d8ec98916
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_ratCast_qExpansion_comp_smul_of_mem_Gamma0.lean
@@ -0,0 +1,1373 @@
+/-
+Based on Prove2Me node ModularCurve.exists_ratCast_qExpansion_comp_smul_of_mem_Gamma0
+(cb08ea2d-4876-503d-be52-c4d57dff919d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 20d86888-419f-56b1-b7b9-f2ea3b92d9c7
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+
+import Mathlib.Algebra.CharP.Pi
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+import Mathlib.RingTheory.MvPolynomial.IrreducibleQuadratic
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_exists_levelFraction_of_stable_family
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_exists_monicRel_j_of_mdifferentiable_levelFraction
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_exists_qExpansion_coeff_mem_of_mdifferentiable_levelFraction
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_intBaseChange
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_modularity_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelN_structure_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_linearIndependent_complex_of_qExpansion_rational
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_qExpansion_sigmaTransport_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Rationality of q-expansions preserved under Γ₀(N)
+
+Theorem statement: `ModularCurve.exists_ratCast_qExpansion_comp_smul_of_mem_Gamma0`
+(`cb08ea2d-4876-503d-be52-c4d57dff919d`), by Claude, 2026-09-05.
+
+Proof: submission `20d86888-419f-56b1-b7b9-f2ea3b92d9c7`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N\ge 1$ and $m\ge 0$ be natural numbers, let $\Delta$ be the weight-$12$ discriminant cusp form
+`ModularForm.discriminant`, and let $G\colon\mathfrak H\to\mathbb C$ be a function on the upper
+half-plane which is holomorphic (differentiable for the complex model structure on $\mathfrak H$ and
+on $\mathbb C$). Assume: $G(g\tau)=G(\tau)$ for every $g\in\Gamma_1(N)$ and every $\tau\in\mathfrak
+H$; for every $\alpha\in\mathrm{SL}_2(\mathbb Z)$ the product of $\tau\mapsto G(\alpha\tau)$ with
+$\Delta^m$ is bounded at $i\infty$; and every coefficient of the $q$-expansion of width $1$ (that
+is, in $q=e^{2\pi i\tau}$) of $G\,\Delta^m$ is the image of a rational number under $\mathbb
+Q\to\mathbb C$. Let $\gamma\in\Gamma_0(N)$ and let $n$ be a natural number. Then the $n$-th
+coefficient of the width-$1$ $q$-expansion of the product of $\tau\mapsto G(\gamma\tau)$ with
+$\Delta^m$ is again the image of a rational number; that is, there is $r\in\mathbb Q$ with that
+coefficient equal to $(r:\mathbb C)$.
+
+This is the rationality statement underlying the arithmetic of the diamond operators: substitution
+by $\gamma\in\Gamma_0(N)$, which normalises $\Gamma_1(N)$, preserves the field of modular functions
+for $\Gamma_1(N)$ whose Fourier expansion at the cusp $\infty$ has rational coefficients. It is used
+by
+[`ModularCurve.exists_ratCast_qExpansion_slash_of_mem_Gamma0`]
+(thm.html#ModularCurve.exists_ratCast_qExpansion_slash_of_mem_Gamma0),
+the corresponding assertion phrased with the slash action.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_ratCast_qExpansion_comp_smul_of_mem_Gamma0.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_ratCast_qExpansion_comp_smul_of_mem_Gamma0
+
+noncomputable section
+
+open Complex UpperHalfPlane ModularForm CongruenceSubgroup Function
+open scoped Real Manifold MatrixGroups ModularForm Topology
+
+namespace X1DiamondRational
+
+def tauPair (τ : ℍ) : PeriodPair where
+  ω₁ := (τ : ℂ)
+  ω₂ := 1
+  indep := by
+    rw [LinearIndependent.pair_iff]
+    intro s t h
+    have h1 := congrArg Complex.im h
+    have h2 := congrArg Complex.re h
+    simp only [real_smul, mul_one, add_im, mul_im, ofReal_re, coe_im, ofReal_im, coe_re, zero_mul,
+      add_zero, zero_im, mul_eq_zero, add_re, mul_re, sub_zero, zero_re] at h1 h2
+    have hs : s = 0 := by
+      rcases h1 with h1 | h1
+      · exact h1
+      · exact absurd h1 τ.im_pos.ne'
+    subst hs
+    simp only [zero_mul, zero_add] at h2
+    exact ⟨rfl, h2⟩
+
+theorem tauPair_spec (τ : ℍ) : (tauPair τ).ω₁ = (τ : ℂ) ∧ (tauPair τ).ω₂ = 1 := ⟨rfl, rfl⟩
+
+variable (N : ℕ)
+
+def WW (v : Fin 2 → ZMod N) (τ : ℍ) : ℂ :=
+  ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+    PeriodPair.weierstrassP (tauPair τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ))
+
+def fricke (v : Fin 2 → ZMod N) (τ : ℍ) : ℂ :=
+  -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * WW N v τ
+
+def jf (τ : ℍ) : ℂ := ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ
+
+theorem WW_spec (v : Fin 2 → ZMod N) (τ : ℍ) : WW N v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+    PeriodPair.weierstrassP (tauPair τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)) :=
+  rfl
+
+theorem fricke_spec (v : Fin 2 → ZMod N) (τ : ℍ) : fricke N v τ =
+    -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * WW N v τ := rfl
+
+theorem jf_spec (τ : ℍ) : jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ := rfl
+
+def zetaN : ℂ := Complex.exp (2 * (Real.pi : ℂ) * Complex.I / (N : ℂ))
+
+def kN : IntermediateField ℚ ℂ := IntermediateField.adjoin ℚ {zetaN N}
+
+def genSet : Set (ℍ → ℂ) := insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke N v}
+
+abbrev Idx : Type := Option {v : Fin 2 → ZMod N // v ≠ 0}
+
+def gen (t : (Fin 2 → ZMod N) → (Fin 2 → ZMod N)) : Idx N → ℍ → ℂ :=
+  fun o => o.elim jf fun v => fricke N (t v.1)
+
+theorem gen_none (t : (Fin 2 → ZMod N) → (Fin 2 → ZMod N)) : gen N t none = jf := rfl
+
+theorem gen_some (t : (Fin 2 → ZMod N) → (Fin 2 → ZMod N)) (v : {v : Fin 2 → ZMod N // v ≠ 0}) :
+    gen N t (some v) = fricke N (t v.1) := rfl
+
+section Cyclo
+
+variable [NeZero N]
+
+theorem isPrimitiveRoot_zetaN : IsPrimitiveRoot (zetaN N) N :=
+  Complex.isPrimitiveRoot_exp N (NeZero.ne N)
+
+scoped instance instIsCyclotomic : IsCyclotomicExtension {N} ℚ (kN N) := by
+  have hζ := isPrimitiveRoot_zetaN N
+  change IsCyclotomicExtension {N} ℚ (IntermediateField.adjoin ℚ {zetaN N}).toSubalgebra
+  rw [IntermediateField.adjoin_simple_toSubalgebra_of_isAlgebraic
+    (hζ.isIntegral (NeZero.pos N)).tower_top.isAlgebraic]
+  exact hζ.adjoin_isCyclotomicExtension ℚ
+
+scoped instance instIsGalois : IsGalois ℚ (kN N) := IsCyclotomicExtension.isGalois {N} ℚ (kN N)
+
+scoped instance instFiniteDimensional : FiniteDimensional ℚ (kN N) :=
+  IsCyclotomicExtension.finiteDimensional {N} ℚ (kN N)
+
+def zetaK : kN N := ⟨zetaN N, IntermediateField.subset_adjoin ℚ _ (Set.mem_singleton _)⟩
+
+omit [NeZero N] in
+@[scoped simp] theorem coe_zetaK : ((zetaK N : kN N) : ℂ) = zetaN N := rfl
+
+theorem isPrimitiveRoot_zetaK : IsPrimitiveRoot (zetaK N) N := by
+  have h := isPrimitiveRoot_zetaN N
+  rw [← coe_zetaK] at h
+  exact IsPrimitiveRoot.coe_submonoidClass_iff.mp h
+
+theorem exists_pow_of_aut (σ : (kN N) ≃ₐ[ℚ] (kN N)) :
+    ∃ s : ℕ, s.Coprime N ∧ σ (zetaK N) = zetaK N ^ s := by
+  have hμ := isPrimitiveRoot_zetaK N
+  refine ⟨((hμ.autToPow ℚ σ : (ZMod N)ˣ) : ZMod N).val, ZMod.val_coe_unit_coprime _, ?_⟩
+  rw [hμ.autToPow_spec ℚ σ]
+
+theorem exists_rat_of_fixed (x : kN N) (hx : ∀ σ : (kN N) ≃ₐ[ℚ] (kN N), σ x = x) :
+    ∃ r : ℚ, (x : ℂ) = (r : ℂ) := by
+  have := (IsGalois.mem_bot_iff_fixed x).2 hx
+  rw [IntermediateField.mem_bot] at this
+  obtain ⟨r, hr⟩ := this
+  refine ⟨r, ?_⟩
+  rw [← hr]
+  rfl
+
+def phiOf (σ : (kN N) ≃ₐ[ℚ] (kN N)) : kN N →+* ℂ :=
+  (algebraMap (kN N) ℂ).comp σ.toRingEquiv.toRingHom
+
+omit [NeZero N] in
+theorem phiOf_apply (σ : (kN N) ≃ₐ[ℚ] (kN N)) (z : kN N) : phiOf N σ z = ((σ z : kN N) : ℂ) := rfl
+
+omit [NeZero N] in
+theorem phiOf_mem (σ : (kN N) ≃ₐ[ℚ] (kN N)) (z : kN N) : phiOf N σ z ∈ kN N := (σ z).2
+
+omit [NeZero N] in
+theorem phiOf_zeta (σ : (kN N) ≃ₐ[ℚ] (kN N)) {s : ℕ} (hs : σ (zetaK N) = zetaK N ^ s)
+    (z : kN N) (hz : (z : ℂ) = zetaN N) : phiOf N σ z = zetaN N ^ s := by
+  have : z = zetaK N := Subtype.ext hz
+  rw [phiOf_apply, this, hs]
+  rfl
+
+omit [NeZero N] in
+theorem phiOf_ratCast (σ : (kN N) ≃ₐ[ℚ] (kN N)) (r : ℚ) (z : kN N) (hz : (z : ℂ) = (r : ℂ)) :
+    phiOf N σ z = r := by
+  have : z = algebraMap ℚ (kN N) r := by
+    apply Subtype.ext; rw [hz]; rfl
+  rw [phiOf_apply, this, AlgEquiv.commutes]
+  rfl
+
+end Cyclo
+
+section Width
+
+local notation "Δ" => ModularForm.discriminant
+
+theorem mdifferentiable_disc : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (Δ : ℍ → ℂ) := by
+  rw [← CuspForm.coe_discriminant]; exact CuspForm.discriminant.holo'
+
+theorem periodic_disc_one : Periodic ((Δ : ℍ → ℂ) ∘ ofComplex) 1 := by
+  have :=
+    SlashInvariantFormClass.periodic_comp_ofComplex CuspForm.discriminant one_mem_strictPeriods_SL
+  rwa [CuspForm.coe_discriminant] at this
+
+theorem isBoundedAtImInfty_disc : IsBoundedAtImInfty (Δ : ℍ → ℂ) := by
+  have := ModularFormClass.bdd_at_infty CuspForm.discriminant
+  rwa [CuspForm.coe_discriminant] at this
+
+theorem disc_ne_zero_fun : (Δ : ℍ → ℂ) ≠ 0 := fun h => by
+  have := congrFun h UpperHalfPlane.I
+  exact discriminant_ne_zero _ this
+
+theorem disc_pow_ne_zero (m : ℕ) (τ : ℍ) : (Δ ^ m : ℍ → ℂ) τ ≠ 0 := by
+  rw [Pi.pow_apply]; exact pow_ne_zero _ (discriminant_ne_zero τ)
+
+theorem periodic_ofComplex_natCast {g : ℍ → ℂ} (h : Periodic (g ∘ ofComplex) 1) (n : ℕ) :
+    Periodic (g ∘ ofComplex) n := by
+  simpa using h.nat_mul n
+
+theorem periodic_mul {g g' : ℍ → ℂ} {c : ℂ} (h : Periodic (g ∘ ofComplex) c)
+    (h' : Periodic (g' ∘ ofComplex) c) : Periodic ((g * g') ∘ ofComplex) c := by
+  intro z
+  have h1 := h z
+  have h2 := h' z
+  simp only [comp_apply, Pi.mul_apply] at h1 h2 ⊢
+  rw [h1, h2]
+
+theorem periodic_pow {g : ℍ → ℂ} {c : ℂ} (h : Periodic (g ∘ ofComplex) c) (m : ℕ) :
+    Periodic ((g ^ m) ∘ ofComplex) c := by
+  induction m with
+  | zero => intro z; simp
+  | succ m ih => rw [pow_succ]; exact periodic_mul ih h
+
+theorem periodic_smul {g : ℍ → ℂ} {c : ℂ} (h : Periodic (g ∘ ofComplex) c) (a : ℂ) :
+    Periodic ((a • g) ∘ ofComplex) c := by
+  intro z; have h1 := h z; simp only [comp_apply, Pi.smul_apply] at h1 ⊢; rw [h1]
+
+theorem periodic_add {g g' : ℍ → ℂ} {c : ℂ} (h : Periodic (g ∘ ofComplex) c)
+    (h' : Periodic (g' ∘ ofComplex) c) : Periodic ((g + g') ∘ ofComplex) c := by
+  intro z
+  have h1 := h z
+  have h2 := h' z
+  simp only [comp_apply, Pi.add_apply] at h1 h2 ⊢
+  rw [h1, h2]
+
+theorem qExpansion_coeff_unique' {h : ℝ} (hh : 0 < h) {g : ℍ → ℂ} {c : ℕ → ℂ}
+    (hg : AnalyticAt ℂ (cuspFunction h g) 0)
+    (hc : ∀ τ : ℍ, HasSum (fun m => c m • Periodic.qParam h τ ^ m) (g τ)) (m : ℕ) :
+    c m = (qExpansion h g).coeff m := by
+  have h1 := (hasFPowerSeriesOnBall_cuspFunction hh hg hc).hasFPowerSeriesAt
+  have h2 : HasFPowerSeriesAt (cuspFunction h g)
+      (FormalMultilinearSeries.ofScalars ℂ fun m => (qExpansion h g).coeff m) 0 := by
+    simpa [qExpansion_coeff, div_eq_mul_inv, mul_comm] using hg.hasFPowerSeriesAt
+  simpa [FormalMultilinearSeries.coeff_ofScalars] using
+    congr_arg (FormalMultilinearSeries.coeff · m) (h1.eq_formalMultilinearSeries h2)
+
+variable (N : ℕ) [NeZero N]
+
+theorem natCast_pos : (0 : ℝ) < (N : ℝ) := Nat.cast_pos.mpr (NeZero.pos N)
+
+theorem qParam_one_eq_pow (τ : ℍ) : Periodic.qParam 1 τ = Periodic.qParam N τ ^ N := by
+  simp only [Periodic.qParam]
+  rw [← Complex.exp_nat_mul]
+  congr 1
+  have : (N : ℂ) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne N)
+  push_cast
+  field_simp
+
+theorem qExpansion_coeff_widthN {g : ℍ → ℂ} (hg : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hper : Periodic (g ∘ ofComplex) 1) (hbd : IsBoundedAtImInfty g) (n : ℕ) :
+    (qExpansion N g).coeff n = if (N : ℕ) ∣ n then (qExpansion 1 g).coeff (n / N) else 0 := by
+  classical
+  have hperN : Periodic (g ∘ ofComplex) N := periodic_ofComplex_natCast hper N
+  set c : ℕ → ℂ := fun n => if (N : ℕ) ∣ n then (qExpansion 1 g).coeff (n / N) else 0 with hc
+  have hNpos : 0 < N := NeZero.pos N
+  have hsum : ∀ τ : ℍ, HasSum (fun m => c m • Periodic.qParam N τ ^ m) (g τ) := by
+    intro τ
+    have h1 := hasSum_qExpansion one_pos hper hg hbd τ
+    have hinj : Function.Injective fun m : ℕ => N * m := mul_right_injective₀ hNpos.ne'
+    have hsupp : ∀ x ∉ Set.range (fun m : ℕ => N * m),
+        (fun m => c m • Periodic.qParam N τ ^ m) x = 0 := by
+      intro x hx
+      have : ¬ (N : ℕ) ∣ x := by
+        rintro ⟨y, rfl⟩; exact hx ⟨y, rfl⟩
+      simp [hc, this]
+    refine (hinj.hasSum_iff hsupp).1 ?_
+    convert h1 using 1
+    funext m
+    simp only [comp_apply, hc, dvd_mul_right, ↓reduceIte, Nat.mul_div_cancel_left _ hNpos]
+    rw [qParam_one_eq_pow N τ, ← pow_mul]
+  rw [← qExpansion_coeff_unique' (natCast_pos N) (analyticAt_cuspFunction_zero (natCast_pos N)
+    hperN hg hbd) hsum n]
+
+theorem qExpansion_widthN_rat {g : ℍ → ℂ} (hg : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hper : Periodic (g ∘ ofComplex) 1) (hbd : IsBoundedAtImInfty g)
+    (hrat : ∀ n, ∃ r : ℚ, (qExpansion 1 g).coeff n = (r : ℂ)) (n : ℕ) :
+    ∃ r : ℚ, (qExpansion N g).coeff n = (r : ℂ) := by
+  rw [qExpansion_coeff_widthN N hg hper hbd n]
+  split_ifs with h
+  · exact hrat _
+  · exact ⟨0, by simp⟩
+
+theorem qExpansion_widthOne_rat {g : ℍ → ℂ} (hg : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hper : Periodic (g ∘ ofComplex) 1) (hbd : IsBoundedAtImInfty g)
+    (hrat : ∀ n, ∃ r : ℚ, (qExpansion N g).coeff n = (r : ℂ)) (n : ℕ) :
+    ∃ r : ℚ, (qExpansion 1 g).coeff n = (r : ℂ) := by
+  obtain ⟨r, hr⟩ := hrat (N * n)
+  rw [qExpansion_coeff_widthN N hg hper hbd, ite_eq_left (dvd_mul_right N n),
+    Nat.mul_div_cancel_left _ (NeZero.pos N)] at hr
+  exact ⟨r, hr⟩
+
+theorem qExpansion_disc_rat_one (n : ℕ) :
+    ∃ r : ℚ, (qExpansion 1 (Δ : ℍ → ℂ)).coeff n = (r : ℂ) := by
+  let A : ModularForm 𝒮ℒ 12 := (E₄.pow 3).mcast (by norm_num)
+  let B : ModularForm 𝒮ℒ 12 := (E₆.pow 2).mcast (by norm_num)
+  have hfun : (Δ : ℍ → ℂ) = ⇑((1728 : ℂ)⁻¹ • (A - B)) := by
+    funext z
+    rw [discriminant_eq_E₄_cube_sub_E₆_sq, smul_apply, sub_apply]
+    simp only [A, B, coe_mcast, coe_pow, Pi.pow_apply, smul_eq_mul]
+    ring
+  have h4 : ∀ n, ∃ r : ℚ, (qExpansion 1 (E₄ : ℍ → ℂ)).coeff n = (r : ℂ) := by
+    intro n
+    rw [ModularForm.E₄, EisensteinSeries.E_qExpansion_coeff (by norm_num) (by decide) n]
+    split_ifs
+    · exact ⟨1, by simp⟩
+    · exact ⟨-(2 * 4 / bernoulli 4) * (ArithmeticFunction.sigma 3 n : ℚ), by push_cast; ring⟩
+  have h6 : ∀ n, ∃ r : ℚ, (qExpansion 1 (E₆ : ℍ → ℂ)).coeff n = (r : ℂ) := by
+    intro n
+    rw [ModularForm.E₆, EisensteinSeries.E_qExpansion_coeff (by norm_num) (by decide) n]
+    split_ifs
+    · exact ⟨1, by simp⟩
+    · exact ⟨-(2 * 6 / bernoulli 6) * (ArithmeticFunction.sigma 5 n : ℚ), by push_cast; ring⟩
+  obtain ⟨p4, hp4⟩ : ∃ p : PowerSeries ℚ, p.map (algebraMap ℚ ℂ) = qExpansion 1 (E₄ : ℍ → ℂ) := by
+    choose r hr using h4
+    exact ⟨PowerSeries.mk r, by ext n; simp [hr n]⟩
+  obtain ⟨p6, hp6⟩ : ∃ p : PowerSeries ℚ, p.map (algebraMap ℚ ℂ) = qExpansion 1 (E₆ : ℍ → ℂ) := by
+    choose r hr using h6
+    exact ⟨PowerSeries.mk r, by ext n; simp [hr n]⟩
+  have hq : qExpansion 1 (Δ : ℍ → ℂ) = ((1728 : ℚ)⁻¹ • (p4 ^ 3 - p6 ^ 2)).map (algebraMap ℚ ℂ) := by
+    rw [hfun, FunLike.coe_smul, ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL,
+      FunLike.coe_sub, ModularForm.qExpansion_sub one_pos one_mem_strictPeriods_SL]
+    simp only [A, B, ModularForm.qExpansion_mcast,
+      ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+    rw [PowerSeries.smul_eq_C_mul, PowerSeries.smul_eq_C_mul, map_mul, PowerSeries.map_C, map_sub,
+      map_pow, map_pow, hp4, hp6]
+    congr 1
+    simp
+  refine ⟨PowerSeries.coeff n ((1728 : ℚ)⁻¹ • (p4 ^ 3 - p6 ^ 2)), ?_⟩
+  rw [hq, PowerSeries.coeff_map]
+  rfl
+
+theorem qExpansion_disc_rat (n : ℕ) : ∃ r : ℚ, (qExpansion N (Δ : ℍ → ℂ)).coeff n = (r : ℂ) :=
+  qExpansion_widthN_rat N mdifferentiable_disc periodic_disc_one isBoundedAtImInfty_disc
+    qExpansion_disc_rat_one n
+
+variable (K : IntermediateField ℚ ℂ)
+
+structure RatAt (m : ℕ) (g : ℍ → ℂ) : Prop where
+  mdiff : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g
+  periodic : Periodic ((g * Δ ^ m) ∘ ofComplex) N
+  bdd : IsBoundedAtImInfty (g * Δ ^ m)
+  mem : ∀ n, (qExpansion N (g * Δ ^ m)).coeff n ∈ K
+
+variable {N K}
+
+theorem ratCast_mem (r : ℚ) : ((r : ℂ)) ∈ K := by
+  have : (r : ℂ) = algebraMap ℚ ℂ r := rfl
+  rw [this]; exact K.algebraMap_mem r
+
+omit [NeZero N] in
+theorem RatAt.mdiff_mul {m : ℕ} {g : ℍ → ℂ} (h : RatAt N K m g) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (g * Δ ^ m) :=
+  h.mdiff.mul (mdifferentiable_disc.pow m)
+
+theorem RatAt.analyticAt {m : ℕ} {g : ℍ → ℂ} (h : RatAt N K m g) :
+    AnalyticAt ℂ (cuspFunction N (g * Δ ^ m)) 0 :=
+  analyticAt_cuspFunction_zero (natCast_pos N) h.periodic h.mdiff_mul h.bdd
+
+theorem analyticAt_disc : AnalyticAt ℂ (cuspFunction N (Δ : ℍ → ℂ)) 0 :=
+  analyticAt_cuspFunction_zero (natCast_pos N) (periodic_ofComplex_natCast periodic_disc_one N)
+    mdifferentiable_disc isBoundedAtImInfty_disc
+
+theorem RatAt.succ {m : ℕ} {g : ℍ → ℂ} (h : RatAt N K m g) : RatAt N K (m + 1) g where
+  mdiff := h.mdiff
+  periodic := by
+    rw [pow_succ, ← mul_assoc]
+    exact periodic_mul h.periodic (periodic_ofComplex_natCast periodic_disc_one N)
+  bdd := by rw [pow_succ, ← mul_assoc]; exact h.bdd.mul isBoundedAtImInfty_disc
+  mem := by
+    intro n
+    rw [pow_succ, ← mul_assoc, qExpansion_mul h.analyticAt analyticAt_disc, PowerSeries.coeff_mul]
+    refine sum_mem fun ij _ => mul_mem (h.mem _) ?_
+    obtain ⟨r, hr⟩ := qExpansion_disc_rat N ij.2
+    rw [hr]; exact ratCast_mem r
+
+theorem RatAt.of_le {m m' : ℕ} (hm : m ≤ m') {g : ℍ → ℂ} (h : RatAt N K m g) : RatAt N K m' g := by
+  obtain ⟨d, rfl⟩ := Nat.exists_eq_add_of_le hm
+  induction d with
+  | zero => simpa using h
+  | succ d ih => exact (ih (Nat.le_add_right m d)).succ
+
+omit [NeZero N] in
+theorem RatAt.exists_map {m : ℕ} {g : ℍ → ℂ} (h : RatAt N K m g) :
+    ∃ p : PowerSeries K, p.map (algebraMap K ℂ) = qExpansion N (g * Δ ^ m) := by
+  refine ⟨PowerSeries.mk fun n => ⟨_, h.mem n⟩, ?_⟩
+  ext n
+  simp
+
+theorem RatAt.qExpansion_ne_zero {m : ℕ} {g : ℍ → ℂ} (h : RatAt N K m g) (hg : g ≠ 0) :
+    qExpansion N (g * Δ ^ m) ≠ 0 := by
+  rw [Ne, qExpansion_eq_zero_iff (natCast_pos N) h.periodic h.mdiff_mul h.bdd]
+  intro h0
+  apply hg
+  funext τ
+  have := congrFun h0 τ
+  simp only [Pi.mul_apply, Pi.zero_apply, mul_eq_zero] at this
+  rcases this with h1 | h1
+  · exact h1
+  · exact absurd h1 (disc_pow_ne_zero m τ)
+
+end Width
+
+section Transport
+
+variable (N : ℕ) (K : IntermediateField ℚ ℂ) (φ : K →+* ℂ)
+
+local notation "Δ" => ModularForm.discriminant
+
+def TRel [NeZero N] (g g' : ℍ → ℂ) : Prop :=
+  MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g ∧ MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g' ∧
+    ∃ m : ℕ,
+      (Function.Periodic ((g * ModularForm.discriminant ^ m) ∘ UpperHalfPlane.ofComplex) N ∧
+        IsBoundedAtImInfty (g * ModularForm.discriminant ^ m) ∧
+        ∀ n : ℕ,
+          (UpperHalfPlane.qExpansion N (g * ModularForm.discriminant ^ m)).coeff n ∈ K) ∧
+      (Function.Periodic ((g' * ModularForm.discriminant ^ m) ∘ UpperHalfPlane.ofComplex) N ∧
+        IsBoundedAtImInfty (g' * ModularForm.discriminant ^ m) ∧
+        ∀ n : ℕ,
+          (UpperHalfPlane.qExpansion N (g' * ModularForm.discriminant ^ m)).coeff n ∈ K) ∧
+      ∀ (n : ℕ) (z : K),
+        (z : ℂ) = (UpperHalfPlane.qExpansion N (g * ModularForm.discriminant ^ m)).coeff n →
+        (UpperHalfPlane.qExpansion N (g' * ModularForm.discriminant ^ m)).coeff n = φ z
+
+variable {N K φ}
+
+theorem TRel.exists [NeZero N] {g g' : ℍ → ℂ} (h : TRel N K φ g g') :
+    ∃ m : ℕ, RatAt N K m g ∧ RatAt N K m g' ∧
+      ∀ (n : ℕ) (z : K), (z : ℂ) = (qExpansion N (g * Δ ^ m)).coeff n →
+        (qExpansion N (g' * Δ ^ m)).coeff n = φ z := by
+  obtain ⟨hg, hg', m, ⟨h1, h2, h3⟩, ⟨h1', h2', h3'⟩, h4⟩ := h
+  exact ⟨m, ⟨hg, h1, h2, h3⟩, ⟨hg', h1', h2', h3'⟩, h4⟩
+
+theorem TRel.map_eq {g g' : ℍ → ℂ} {m : ℕ}
+    (h4 : ∀ (n : ℕ) (z : K), (z : ℂ) = (qExpansion N (g * Δ ^ m)).coeff n →
+        (qExpansion N (g' * Δ ^ m)).coeff n = φ z)
+    {p : PowerSeries K} (hp : p.map (algebraMap K ℂ) = qExpansion N (g * Δ ^ m)) :
+    p.map φ = qExpansion N (g' * Δ ^ m) := by
+  ext n
+  rw [PowerSeries.coeff_map]
+  symm
+  apply h4
+  rw [← hp, PowerSeries.coeff_map]
+  rfl
+
+theorem tRel_self_of_rat [NeZero N] {g : ℍ → ℂ} {m : ℕ} (hg : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hper : Periodic ((g * Δ ^ m) ∘ ofComplex) N) (hbd : IsBoundedAtImInfty (g * Δ ^ m))
+    (hrat : ∀ n, ∃ r : ℚ, (qExpansion N (g * Δ ^ m)).coeff n = (r : ℂ)) : TRel N K φ g g := by
+  have hmem : ∀ n, (qExpansion N (g * Δ ^ m)).coeff n ∈ K := by
+    intro n; obtain ⟨r, hr⟩ := hrat n; rw [hr]; exact ratCast_mem r
+  refine ⟨hg, hg, m, ⟨hper, hbd, hmem⟩, ⟨hper, hbd, hmem⟩, ?_⟩
+  intro n z hz
+  obtain ⟨r, hr⟩ := hrat n
+  rw [hr] at hz ⊢
+  have : z = algebraMap ℚ K r := by
+    apply Subtype.ext; rw [hz]; rfl
+  rw [this]
+  simp
+
+end Transport
+
+section Group
+
+variable (N : ℕ)
+
+def redN (γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) (ZMod N) :=
+  (γ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N)
+
+def vm (γ : SL(2, ℤ)) (v : Fin 2 → ZMod N) : Fin 2 → ZMod N := Matrix.vecMul v (redN N γ)
+
+def ds (s : ℕ) (v : Fin 2 → ZMod N) : Fin 2 → ZMod N := ![v 0, (s : ZMod N) * v 1]
+
+theorem redN_eq (γ : SL(2, ℤ)) :
+    redN N γ = (Int.castRingHom (ZMod N)).mapMatrix (γ : Matrix (Fin 2) (Fin 2) ℤ) :=
+  rfl
+
+theorem redN_mul (γ γ' : SL(2, ℤ)) : redN N (γ * γ') = redN N γ * redN N γ' := by
+  rw [redN_eq, redN_eq, redN_eq, Matrix.SpecialLinearGroup.coe_mul, map_mul]
+
+theorem redN_one : redN N 1 = 1 := by
+  rw [redN, Matrix.SpecialLinearGroup.coe_one]; simp
+
+theorem vm_mul (γ γ' : SL(2, ℤ)) (v : Fin 2 → ZMod N) : vm N (γ * γ') v = vm N γ' (vm N γ v) := by
+  simp only [vm, redN_mul, Matrix.vecMul_vecMul]
+
+theorem vm_one (v : Fin 2 → ZMod N) : vm N 1 v = v := by simp [vm, redN_one]
+
+theorem vm_ne_zero (γ : SL(2, ℤ)) {v : Fin 2 → ZMod N} (hv : v ≠ 0) : vm N γ v ≠ 0 := by
+  intro h
+  apply hv
+  have : vm N γ⁻¹ (vm N γ v) = v := by rw [← vm_mul, mul_inv_cancel, vm_one]
+  rw [← this, h, vm, Matrix.zero_vecMul]
+
+theorem ds_ne_zero {s : ℕ} (hs : s.Coprime N) {v : Fin 2 → ZMod N} (hv : v ≠ 0) : ds N s v ≠ 0 := by
+  intro h
+  apply hv
+  have h0 : v 0 = 0 := by simpa [ds] using congrFun h 0
+  have h1 : (s : ZMod N) * v 1 = 0 := by simpa [ds] using congrFun h 1
+  have hu : IsUnit (s : ZMod N) := (ZMod.unitOfCoprime s hs).isUnit
+  have h1' : v 1 = 0 := by simpa using hu.mul_left_cancel (h1.trans (mul_zero _).symm)
+  funext i; fin_cases i <;> simp [h0, h1']
+
+theorem T_pow_mem_Gamma1 (t : ℤ) : ModularGroup.T ^ t ∈ Gamma1 N := by
+  rw [Gamma1_mem, ModularGroup.coe_T_zpow]
+  simp
+
+theorem T_mem_Gamma1 : ModularGroup.T ∈ Gamma1 N := by
+  simp
+
+theorem conj_mem_Gamma1 {γ g : SL(2, ℤ)} (hγ : γ ∈ Gamma0 N) (hg : g ∈ Gamma1 N) :
+    γ * g * γ⁻¹ ∈ Gamma1 N := by
+  have hA0 : g ∈ Gamma0 N := Gamma1_in_Gamma0 N hg
+  set A₀ : Gamma0 N := ⟨g, hA0⟩
+  set γ₀ : Gamma0 N := ⟨γ, hγ⟩
+  have hA1 : A₀ ∈ Gamma1' N := by
+    rw [Gamma1_to_Gamma0_mem]
+    exact (Gamma1_mem N g).mp hg
+  have : (Gamma1' N).Normal := by
+    change ((Gamma0Map N).ker).Normal
+    infer_instance
+  have hconj : γ₀ * A₀ * γ₀⁻¹ ∈ Gamma1' N := Subgroup.Normal.conj_mem inferInstance A₀ hA1 γ₀
+  rw [Gamma1_to_Gamma0_mem] at hconj
+  rw [Gamma1_mem]
+  exact hconj
+
+theorem conj_mem_Gamma (α : SL(2, ℤ)) {g : SL(2, ℤ)} (hg : g ∈ CongruenceSubgroup.Gamma N) :
+    α * g * α⁻¹ ∈ CongruenceSubgroup.Gamma N :=
+  Subgroup.Normal.conj_mem (Gamma_normal N) g hg α
+
+theorem Gamma_le_Gamma1 : CongruenceSubgroup.Gamma N ≤ Gamma1 N := by
+  intro g hg
+  rw [Gamma_mem] at hg
+  rw [Gamma1_mem]
+  exact ⟨hg.1, hg.2.2.2, hg.2.2.1⟩
+
+theorem exists_twist_conj {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 N) (s : ℕ) :
+    ∃ γ' : SL(2, ℤ), (∃ g ∈ Gamma1 N, γ' = g * γ) ∧
+      ∀ v : Fin 2 → ZMod N, vm N γ' (ds N s v) = ds N s (vm N γ v) := by
+  set t : ℤ := γ 1 1 * γ 0 1 * ((s : ℤ) - 1) with ht
+  refine ⟨γ * ModularGroup.T ^ t, ⟨γ * ModularGroup.T ^ t * γ⁻¹, conj_mem_Gamma1 N hγ
+    (T_pow_mem_Gamma1 N t), by rw [inv_mul_cancel_right]⟩, ?_⟩
+  intro v
+  have hc : ((γ 1 0 : ℤ) : ZMod N) = 0 := Gamma0_mem.mp hγ
+  have hdet : ((γ 0 0 : ℤ) : ZMod N) * ((γ 1 1 : ℤ) : ZMod N) = 1 := by
+    have h1 : (γ 0 0 : ℤ) * γ 1 1 - γ 0 1 * γ 1 0 = 1 := by
+      have := γ.det_coe; rwa [Matrix.det_fin_two] at this
+    have := congrArg (Int.cast : ℤ → ZMod N) h1
+    push_cast at this
+    rw [hc, mul_zero, sub_zero] at this
+    exact this
+  have hT : redN N (ModularGroup.T ^ t) = !![1, (t : ZMod N); 0, 1] := by
+    rw [redN, ModularGroup.coe_T_zpow]
+    ext i j; fin_cases i <;> fin_cases j <;> simp
+  have hγm : redN N γ = !![((γ 0 0 : ℤ) : ZMod N), ((γ 0 1 : ℤ) : ZMod N); 0, ((γ 1 1 : ℤ) : ZMod
+    N)] :=
+    by
+    ext i j; fin_cases i <;> fin_cases j <;> simp [redN, hc]
+  funext i
+  simp only [vm, redN_mul, hT, hγm, ds]
+  fin_cases i
+  · simp [Matrix.vecMul, dotProduct, Fin.sum_univ_two]
+  · simp [Matrix.vecMul, dotProduct, Fin.sum_univ_two, ht]
+    linear_combination (v 0 * ((γ 0 1 : ℤ) : ZMod N) * ((s : ZMod N) - 1)) * hdet
+
+end Group
+
+section Invariance
+
+variable {N : ℕ}
+
+local notation "Δ" => ModularForm.discriminant
+
+def cw (G : ℍ → ℂ) (α : SL(2, ℤ)) : ℍ → ℂ := fun τ => G (α • τ)
+
+theorem cw_apply (G : ℍ → ℂ) (α : SL(2, ℤ)) (τ : ℍ) : cw G α τ = G (α • τ) := rfl
+
+theorem cw_mul (G : ℍ → ℂ) (α β : SL(2, ℤ)) : cw G (α * β) = cw (cw G α) β := by
+  funext τ; simp [cw, mul_smul]
+
+theorem cw_one (G : ℍ → ℂ) : cw G 1 = G := by funext τ; simp [cw]
+
+theorem cw_eq_slash (G : ℍ → ℂ) (α : SL(2, ℤ)) : cw G α = G ∣[(0 : ℤ)] α := by
+  funext τ
+  rw [ModularForm.SL_slash_apply, cw_apply, neg_zero, zpow_zero, mul_one]
+
+theorem mdifferentiable_cw {G : ℍ → ℂ} (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G) (α : SL(2, ℤ)) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (cw G α) := by
+  rw [cw_eq_slash, ModularForm.SL_slash]; exact hG.slash _ _
+
+def cwAlgHom (α : SL(2, ℤ)) : (ℍ → ℂ) →ₐ[ℂ] (ℍ → ℂ) where
+  toFun G := cw G α
+  map_one' := rfl
+  map_mul' _ _ := rfl
+  map_zero' := rfl
+  map_add' _ _ := rfl
+  commutes' _ := rfl
+
+@[scoped simp] theorem cwAlgHom_apply (α : SL(2, ℤ)) (G : ℍ → ℂ) : cwAlgHom α G = cw G α := rfl
+
+theorem cw_mul_fun (G G' : ℍ → ℂ) (α : SL(2, ℤ)) : cw (G * G') α = cw G α * cw G' α := rfl
+
+theorem periodic_of_T_invariant {G : ℍ → ℂ} (h : ∀ τ : ℍ, G (ModularGroup.T • τ) = G τ) :
+    Periodic (G ∘ ofComplex) 1 := by
+  intro w
+  by_cases hw : 0 < im w
+  · have this : 0 < im (w + 1) := by simp [hw]
+    simp only [comp_apply, ofComplex_apply_of_im_pos this, ofComplex_apply_of_im_pos hw]
+    have := h ⟨w, hw⟩
+    rw [modular_T_smul] at this
+    convert this using 2
+    ext
+    simp [add_comm, UpperHalfPlane.coe_vadd]
+  · push Not at hw
+    have : im (w + 1) ≤ 0 := by simpa using hw
+    simp [ofComplex_apply_of_im_nonpos this, ofComplex_apply_of_im_nonpos hw]
+
+theorem disc_smul (α : SL(2, ℤ)) (τ : ℍ) :
+    Δ (α • τ) = denom (α : GL (Fin 2) ℝ) τ ^ (12 : ℤ) * Δ τ := by
+  have := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant (Γ := 𝒮ℒ)
+    (γ := (α : GL (Fin 2) ℝ)) ⟨α, rfl⟩ τ
+  rw [CuspForm.coe_discriminant, ← ModularGroup.sl_moeb] at this
+  exact this
+
+theorem E₄_smul (α : SL(2, ℤ)) (τ : ℍ) :
+    E₄ (α • τ) = denom (α : GL (Fin 2) ℝ) τ ^ (4 : ℤ) * E₄ τ := by
+  have := SlashInvariantForm.slash_action_eqn'' E₄ (Γ := 𝒮ℒ) (γ := (α : GL (Fin 2) ℝ)) ⟨α, rfl⟩ τ
+  rw [← ModularGroup.sl_moeb] at this
+  exact_mod_cast this
+
+theorem jf_smul (α : SL(2, ℤ)) (τ : ℍ) : jf (α • τ) = jf τ := by
+  have hd : denom (α : GL (Fin 2) ℝ) τ ≠ 0 := denom_ne_zero _ τ
+  have hΔ : Δ τ ≠ 0 := discriminant_ne_zero τ
+  rw [jf, jf, disc_smul, E₄_smul]
+  field_simp
+
+theorem cw_jf (α : SL(2, ℤ)) : cw jf α = jf := funext (jf_smul α)
+
+end Invariance
+
+section Fricke
+
+variable (N : ℕ) [NeZero N]
+
+local notation "Δ" => ModularForm.discriminant
+
+theorem fricke_smul (v : Fin 2 → ZMod N) (γ : SL(2, ℤ)) (τ : ℍ) :
+    fricke N v (γ • τ) = fricke N (vm N γ v) τ := by
+  obtain ⟨h1, -⟩ := WLight.frickeFunction_modularity_package N tauPair tauPair_spec
+  exact h1 v γ τ
+
+theorem cw_fricke (v : Fin 2 → ZMod N) (γ : SL(2, ℤ)) : cw (fricke N v) γ = fricke N (vm N γ v) :=
+  funext (fricke_smul N v γ)
+
+theorem mdifferentiable_fricke {v : Fin 2 → ZMod N} (hv : v ≠ 0) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fricke N v) := by
+  obtain ⟨-, -, h3, -⟩ := WLight.frickeFunction_modularity_package N tauPair tauPair_spec
+  exact h3 v hv
+
+theorem isBoundedAtImInfty_fricke {v : Fin 2 → ZMod N} (hv : v ≠ 0) :
+    IsBoundedAtImInfty (fricke N v * Δ) := by
+  obtain ⟨-, -, -, h4, -⟩ := WLight.frickeFunction_modularity_package N tauPair tauPair_spec
+  exact h4 v hv
+
+theorem periodic_fricke {v : Fin 2 → ZMod N} (hv : v ≠ 0) :
+    Periodic ((fricke N v * Δ) ∘ ofComplex) N := by
+  obtain ⟨-, -, -, -, h5, -⟩ := WLight.frickeFunction_modularity_package N tauPair tauPair_spec
+  exact (h5 v hv).1
+
+theorem coeff_fricke_mem {v : Fin 2 → ZMod N} (hv : v ≠ 0) (n : ℕ) :
+    (qExpansion N (fricke N v * Δ)).coeff n ∈ kN N := by
+  obtain ⟨-, -, -, -, h5, -⟩ := WLight.frickeFunction_modularity_package N tauPair tauPair_spec
+  exact (h5 v hv).2 n
+
+theorem coeff_fricke_ds {s : ℕ} (hs : s.Coprime N) (φ : kN N →+* ℂ)
+    (hφ : ∀ z : kN N, (z : ℂ) = zetaN N → φ z = zetaN N ^ s)
+    {v : Fin 2 → ZMod N} (hv : v ≠ 0) (n : ℕ) (z : kN N)
+    (hz : (z : ℂ) = (qExpansion N (fricke N v * Δ)).coeff n) :
+    (qExpansion N (fricke N (ds N s v) * Δ)).coeff n = φ z := by
+  obtain ⟨-, -, -, -, -, -, -, h8⟩ :=
+    WLight.frickeFunction_modularity_package N tauPair tauPair_spec
+  exact h8 s hs φ hφ v hv n z hz
+
+theorem ratAt_fricke {v : Fin 2 → ZMod N} (hv : v ≠ 0) : RatAt N (kN N) 1 (fricke N v) where
+  mdiff := mdifferentiable_fricke N hv
+  periodic := by rw [pow_one]; exact periodic_fricke N hv
+  bdd := by rw [pow_one]; exact isBoundedAtImInfty_fricke N hv
+  mem := by rw [pow_one]; exact coeff_fricke_mem N hv
+
+theorem qExpansion_E₄_rat (n : ℕ) : ∃ r : ℚ, (qExpansion 1 (E₄ : ℍ → ℂ)).coeff n = (r : ℂ) := by
+  rw [ModularForm.E₄, EisensteinSeries.E_qExpansion_coeff (by norm_num) (by decide) n]
+  split_ifs
+  · exact ⟨1, by simp⟩
+  · exact ⟨-(2 * 4 / bernoulli 4) * (ArithmeticFunction.sigma 3 n : ℚ), by push_cast; ring⟩
+
+theorem qExpansion_E₆_rat (n : ℕ) : ∃ r : ℚ, (qExpansion 1 (E₆ : ℍ → ℂ)).coeff n = (r : ℂ) := by
+  rw [ModularForm.E₆, EisensteinSeries.E_qExpansion_coeff (by norm_num) (by decide) n]
+  split_ifs
+  · exact ⟨1, by simp⟩
+  · exact ⟨-(2 * 6 / bernoulli 6) * (ArithmeticFunction.sigma 5 n : ℚ), by push_cast; ring⟩
+
+theorem exists_map_of_rat {q : PowerSeries ℂ} (h : ∀ n, ∃ r : ℚ, q.coeff n = (r : ℂ)) :
+    ∃ p : PowerSeries ℚ, p.map (algebraMap ℚ ℂ) = q := by
+  choose r hr using h
+  exact ⟨PowerSeries.mk r, by ext n; simp [hr n]⟩
+
+theorem rat_of_exists_map {q : PowerSeries ℂ} (h : ∃ p : PowerSeries ℚ, p.map (algebraMap ℚ ℂ) = q)
+    (n : ℕ) : ∃ r : ℚ, q.coeff n = (r : ℂ) := by
+  obtain ⟨p, rfl⟩ := h
+  exact ⟨PowerSeries.coeff n p, by rw [PowerSeries.coeff_map]; rfl⟩
+
+def E4cube : ModularForm 𝒮ℒ 12 := (E₄.pow 3).mcast (by norm_num)
+
+theorem coe_E4cube : (⇑E4cube : ℍ → ℂ) = (E₄ : ℍ → ℂ) ^ 3 := by
+  rw [E4cube, coe_mcast, coe_pow]
+
+theorem qExpansion_E4cube_rat (n : ℕ) :
+    ∃ r : ℚ, (qExpansion 1 (⇑E4cube : ℍ → ℂ)).coeff n = (r : ℂ) := by
+  obtain ⟨p, hp⟩ := exists_map_of_rat qExpansion_E₄_rat
+  refine rat_of_exists_map ⟨p ^ 3, ?_⟩ n
+  rw [E4cube, ModularForm.qExpansion_mcast, ModularForm.qExpansion_pow one_pos
+    one_mem_strictPeriods_SL,
+    map_pow, hp]
+
+theorem ratAt_jf (K : IntermediateField ℚ ℂ) : RatAt N K 1 jf := by
+  have hj : jf * Δ ^ 1 = ⇑E4cube := by
+    funext τ
+    rw [coe_E4cube]
+    simp only [Pi.mul_apply, Pi.pow_apply, pow_one, jf]
+    field_simp [discriminant_ne_zero τ]
+  have hmd : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) jf := by
+    intro τ
+    have h1 : MDifferentiableAt 𝓘(ℂ) 𝓘(ℂ) (fun τ => E₄ τ ^ 3) τ := (E₄.holo' τ).pow 3
+    exact h1.div (mdifferentiable_disc τ) (discriminant_ne_zero τ)
+  refine ⟨hmd, ?_, ?_, ?_⟩
+  · rw [hj]; exact periodic_ofComplex_natCast (SlashInvariantFormClass.periodic_comp_ofComplex
+      E4cube
+      one_mem_strictPeriods_SL) N
+  · rw [hj]; exact ModularFormClass.bdd_at_infty E4cube
+  · intro n
+    rw [hj]
+    obtain ⟨r, hr⟩ := qExpansion_widthN_rat N (g := (⇑E4cube : ℍ → ℂ)) E4cube.holo'
+      (SlashInvariantFormClass.periodic_comp_ofComplex E4cube one_mem_strictPeriods_SL)
+      (ModularFormClass.bdd_at_infty E4cube) qExpansion_E4cube_rat n
+    rw [hr]; exact ratCast_mem r
+
+variable {N}
+variable (σ : (kN N) ≃ₐ[ℚ] (kN N)) {s : ℕ} (hs : s.Coprime N) (hσ : σ (zetaK N) = zetaK N ^ s)
+
+abbrev Tσ (σ : (kN N) ≃ₐ[ℚ] (kN N)) : (ℍ → ℂ) → (ℍ → ℂ) → Prop := TRel N (kN N) (phiOf N σ)
+
+include hs hσ in
+theorem tσ_fricke {v : Fin 2 → ZMod N} (hv : v ≠ 0) : Tσ σ (fricke N v) (fricke N (ds N s v)) := by
+  have h1 := ratAt_fricke N hv
+  have h2 := ratAt_fricke N (ds_ne_zero N hs hv)
+  refine ⟨h1.mdiff, h2.mdiff, 1, ⟨h1.periodic, h1.bdd, h1.mem⟩, ⟨h2.periodic, h2.bdd, h2.mem⟩, ?_⟩
+  intro n z hz
+  rw [pow_one] at hz ⊢
+  exact coeff_fricke_ds N hs (phiOf N σ) (fun z hz => phiOf_zeta N σ hσ z hz) hv n z hz
+
+theorem transportPkg :
+    (∀ {ι : Type} (g g' : ι → ℍ → ℂ), (∀ i : ι, Tσ σ (g i) (g' i)) →
+      ∀ R : MvPolynomial ι (kN N),
+        Tσ σ (MvPolynomial.aeval g (MvPolynomial.map (algebraMap (kN N) ℂ) R))
+          (MvPolynomial.aeval g' (MvPolynomial.map (phiOf N σ) R))) ∧
+    (∀ g g' : ℍ → ℂ, Tσ σ g g' → (g = 0 ↔ g' = 0)) ∧
+    ∀ jf' : ℍ → ℂ, (∀ τ : ℍ, jf' τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) → Tσ σ jf'
+      jf' :=
+  WLight.qExpansion_sigmaTransport_package N (kN N) (phiOf N σ) (phiOf_mem N σ) (Tσ σ)
+    (by simp [Tσ, TRel])
+
+theorem tσ_jf : Tσ σ jf jf := (transportPkg σ).2.2 jf (jf_spec)
+
+theorem tσ_zero_iff {g g' : ℍ → ℂ} (h : Tσ σ g g') : g = 0 ↔ g' = 0 := (transportPkg σ).2.1 g g' h
+
+theorem tσ_aeval {ι : Type} {g g' : ι → ℍ → ℂ} (h : ∀ i, Tσ σ (g i) (g' i))
+    (R : MvPolynomial ι (kN N)) :
+    Tσ σ (MvPolynomial.aeval g (MvPolynomial.map (algebraMap (kN N) ℂ) R))
+      (MvPolynomial.aeval g' (MvPolynomial.map (phiOf N σ) R)) :=
+  (transportPkg σ).1 g g' h R
+
+variable (N) in
+def ev (t : (Fin 2 → ZMod N) → (Fin 2 → ZMod N)) (R : MvPolynomial (Idx N) (kN N)) : ℍ → ℂ :=
+  MvPolynomial.aeval (gen N t) (MvPolynomial.map (algebraMap (kN N) ℂ) R)
+
+variable (N) in
+def evφ (φ : kN N →+* ℂ) (t : (Fin 2 → ZMod N) → (Fin 2 → ZMod N)) (R : MvPolynomial (Idx N) (kN N))
+    :
+    ℍ → ℂ :=
+  MvPolynomial.aeval (gen N t) (MvPolynomial.map φ R)
+
+include hs hσ in
+theorem tσ_gen (t : (Fin 2 → ZMod N) → (Fin 2 → ZMod N)) (ht : ∀ v, v ≠ 0 → t v ≠ 0) (o : Idx N) :
+    Tσ σ (gen N t o) (gen N (ds N s ∘ t) o) := by
+  cases o with
+  | none => exact tσ_jf σ
+  | some v => exact tσ_fricke σ hs hσ (ht v.1 v.2)
+
+include hs hσ in
+theorem tσ_ev (t : (Fin 2 → ZMod N) → (Fin 2 → ZMod N)) (ht : ∀ v, v ≠ 0 → t v ≠ 0)
+    (R : MvPolynomial (Idx N) (kN N)) : Tσ σ (ev N t R) (evφ N (phiOf N σ) (ds N s ∘ t) R) :=
+  tσ_aeval σ (tσ_gen σ hs hσ t ht) R
+
+theorem cw_gen (t : (Fin 2 → ZMod N) → (Fin 2 → ZMod N)) (α : SL(2, ℤ)) (o : Idx N) :
+    cw (gen N t o) α = gen N (vm N α ∘ t) o := by
+  cases o with
+  | none => exact cw_jf α
+  | some v => exact cw_fricke N (t v.1) α
+
+theorem cw_aeval {ι : Type} (g : ι → ℍ → ℂ) (R : MvPolynomial ι ℂ) (α : SL(2, ℤ)) :
+    cw (MvPolynomial.aeval g R) α = MvPolynomial.aeval (fun i => cw (g i) α) R := by
+  have := MvPolynomial.comp_aeval g (cwAlgHom α)
+  have h := congrArg (fun F => F R) this
+  simpa using h
+
+theorem gen_cw_eq (t : (Fin 2 → ZMod N) → (Fin 2 → ZMod N)) (α : SL(2, ℤ)) :
+    (fun o => cw (gen N t o) α) = gen N (vm N α ∘ t) :=
+  funext (cw_gen t α)
+
+theorem cw_ev (t : (Fin 2 → ZMod N) → (Fin 2 → ZMod N)) (R : MvPolynomial (Idx N) (kN N))
+    (α : SL(2, ℤ)) : cw (ev N t R) α = ev N (vm N α ∘ t) R := by
+  unfold ev
+  rw [cw_aeval, gen_cw_eq]
+
+theorem cw_evφ (φ : kN N →+* ℂ) (t : (Fin 2 → ZMod N) → (Fin 2 → ZMod N))
+    (R : MvPolynomial (Idx N) (kN N)) (α : SL(2, ℤ)) :
+    cw (evφ N φ t R) α = evφ N φ (vm N α ∘ t) R := by
+  unfold evφ
+  rw [cw_aeval, gen_cw_eq]
+
+omit [NeZero N] in
+theorem gen_id_mem (o : Idx N) : gen N id o ∈ genSet N := by
+  cases o with
+  | none => exact Set.mem_insert _ _
+  | some v => exact Set.mem_insert_of_mem _ ⟨v.1, v.2, rfl⟩
+
+omit [NeZero N] in
+theorem aeval_mem_adjoin (R : MvPolynomial (Idx N) ℂ) :
+    MvPolynomial.aeval (gen N id) R ∈ Algebra.adjoin ℂ (genSet N) := by
+  induction R using MvPolynomial.induction_on with
+  | C c => rw [MvPolynomial.aeval_C]; exact Subalgebra.algebraMap_mem _ c
+  | add p q hp hq => rw [map_add]; exact add_mem hp hq
+  | mul_X p o hp =>
+      rw [map_mul, MvPolynomial.aeval_X]
+      exact mul_mem hp (Algebra.subset_adjoin (gen_id_mem o))
+
+omit [NeZero N] in
+theorem ev_mem_adjoin (R : MvPolynomial (Idx N) (kN N)) : ev N id R ∈ Algebra.adjoin ℂ (genSet N) :=
+  aeval_mem_adjoin _
+
+theorem adjoin_isDomain {a b : ℍ → ℂ} (ha : a ∈ Algebra.adjoin ℂ (genSet N))
+    (hb : b ∈ Algebra.adjoin ℂ (genSet N)) (hab : a * b = 0) : a = 0 ∨ b = 0 := by
+  obtain ⟨-, -, -, -, -, h6⟩ :=
+    WLight.levelN_structure_package N tauPair tauPair_spec (WW N) (WW_spec N)
+    (fricke N) (fricke_spec N) jf jf_spec
+  exact h6 a b ha hb hab
+
+theorem ev_prod_ne_zero {ι : Type*} (s : Finset ι) (Q : ι → MvPolynomial (Idx N) (kN N))
+    (hQ : ∀ i ∈ s, ev N id (Q i) ≠ 0) : ev N id (∏ i ∈ s, Q i) ≠ 0 := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => simp [ev]
+  | insert a s ha ih =>
+      rw [Finset.prod_insert ha]
+      intro h0
+      have h0' : ev N id (Q a) * ev N id (∏ i ∈ s, Q i) = 0 := by
+        rw [← h0]; simp [ev, map_mul]
+      rcases adjoin_isDomain (ev_mem_adjoin _) (ev_mem_adjoin _) h0' with h | h
+      · exact hQ a (Finset.mem_insert_self a s) h
+      · exact ih (fun i hi => hQ i (Finset.mem_insert_of_mem hi)) h
+
+end Fricke
+
+section Descent
+
+variable {N : ℕ} [NeZero N]
+
+local notation "Δ" => ModularForm.discriminant
+
+theorem smul_eq_coe_smul (K : IntermediateField ℚ ℂ) (κ : K) (f : ℍ → ℂ) :
+    κ • f = (κ : ℂ) • f := rfl
+
+theorem exists_rat_combination (K : IntermediateField ℚ ℂ) {n M : ℕ} {Gi : Fin n → ℍ → ℂ}
+    {G : ℍ → ℂ} (hGi : ∀ i, RatAt N K M (Gi i)) (hG : RatAt N K M G)
+    (hmem : G ∈ Submodule.span ℂ (Set.range Gi)) :
+    ∃ κ : Fin n → K, G = ∑ i, (κ i : ℂ) • Gi i := by
+  classical
+  by_cases hW : G ∈ Submodule.span K (Set.range Gi)
+  · obtain ⟨c, hc⟩ := (Submodule.mem_span_range_iff_exists_fun K).mp hW
+    exact ⟨c, by rw [← hc]; rfl⟩
+  exfalso
+  obtain ⟨b, hb_sub, hb_span, hb_ind⟩ := exists_linearIndependent K (Set.range Gi)
+  have hbfin : b.Finite := (Set.finite_range Gi).subset hb_sub
+  have hGb : G ∉ b := fun h => hW (hb_span ▸ Submodule.subset_span h)
+  have hGspan : G ∉ Submodule.span K b := by rwa [hb_span]
+  have hins : LinearIndepOn K id (insert G b) := LinearIndepOn.id_insert hb_ind hGspan
+  set sF : Finset (ℍ → ℂ) := (hbfin.insert G).toFinset with hsF
+  have hcoe : (↑sF : Set (ℍ → ℂ)) = insert G b := Set.Finite.coe_toFinset _
+  have hdata : ∀ f ∈ sF, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f ∧
+      Function.Periodic ((f * ModularForm.discriminant ^ M) ∘ UpperHalfPlane.ofComplex) N ∧
+      IsBoundedAtImInfty (f * ModularForm.discriminant ^ M) ∧
+      ∀ n : ℕ, (UpperHalfPlane.qExpansion N (f * ModularForm.discriminant ^ M)).coeff n ∈ K := by
+    intro f hf
+    have hf' : f ∈ insert G b := by rwa [← hcoe, Finset.mem_coe]
+    rcases hf' with rfl | hf'
+    · exact ⟨hG.mdiff, hG.periodic, hG.bdd, hG.mem⟩
+    · obtain ⟨i, rfl⟩ := hb_sub hf'
+      exact ⟨(hGi i).mdiff, (hGi i).periodic, (hGi i).bdd, (hGi i).mem⟩
+  have hind : LinearIndependent K (fun w : ↥(↑sF : Set (ℍ → ℂ)) => (w : ℍ → ℂ)) := by
+    rw [hcoe]; exact hins
+  have hC := WLight.linearIndependent_complex_of_qExpansion_rational N K sF M hdata hind
+  rw [hcoe] at hC
+  have hC' : LinearIndepOn ℂ id (insert G b) := hC
+  have hnot := hC'.notMem_span_of_insert hGb
+  rw [Set.image_id] at hnot
+  apply hnot
+  have hle : Submodule.span ℂ (Set.range Gi) ≤ Submodule.span ℂ b := by
+    rw [Submodule.span_le]
+    intro x hx
+    have hxK : x ∈ Submodule.span K b := by rw [hb_span]; exact Submodule.subset_span hx
+    exact Submodule.span_subset_span K ℂ b hxK
+  exact hle hmem
+
+omit [NeZero N] in
+theorem exists_ev_of_mem_adjoin {x : ℍ → ℂ} (hx : x ∈ Algebra.adjoin (kN N) (genSet N)) :
+    ∃ R : MvPolynomial (Idx N) (kN N), ev N id R = x := by
+  classical
+  rw [Algebra.adjoin_eq_range] at hx
+  obtain ⟨R₀, rfl⟩ := hx
+  have hsec : ∀ y : genSet N, ∃ o : Idx N, gen N id o = y := by
+    rintro ⟨y, hy⟩
+    rcases hy with rfl | ⟨v, hv, rfl⟩
+    · exact ⟨none, rfl⟩
+    · exact ⟨some ⟨v, hv⟩, rfl⟩
+  choose sec hsec using hsec
+  refine ⟨MvPolynomial.rename sec R₀, ?_⟩
+  rw [ev, MvPolynomial.aeval_map_algebraMap, MvPolynomial.aeval_rename]
+  have : (gen N id ∘ sec) = Subtype.val := funext hsec
+  rw [this]
+  rfl
+
+omit [NeZero N] in
+theorem coeff_map_mem (R : MvPolynomial (Idx N) (kN N)) (m : Idx N →₀ ℕ) :
+    (MvPolynomial.map (algebraMap (kN N) ℂ) R).coeff m ∈ kN N := by
+  rw [MvPolynomial.coeff_map]; exact (R.coeff m).2
+
+theorem descent {m : ℕ} {G : ℍ → ℂ} (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (hinv : ∀ g ∈ CongruenceSubgroup.Gamma N, ∀ τ : ℍ, G (g • τ) = G τ)
+    (hpb : ∀ α : SL(2, ℤ), IsBoundedAtImInfty (cw G α * Δ ^ m))
+    (hrat : RatAt N (kN N) m G) :
+    ∃ P Q : MvPolynomial (Idx N) (kN N), ev N id Q ≠ 0 ∧ G * ev N id Q = ev N id P := by
+  classical
+  set S : Set (ℍ → ℂ) := {F | ∃ α : SL(2, ℤ), F = cw G α} with hS
+  have hGS : G ∈ S := ⟨1, (cw_one G).symm⟩
+  have hhol : ∀ F ∈ S, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F := by
+    rintro F ⟨α, rfl⟩; exact mdifferentiable_cw hG α
+  have hpb' : ∀ F ∈ S, ∃ m : ℕ, IsBoundedAtImInfty (F * ModularForm.discriminant ^ m) := by
+    rintro F ⟨α, rfl⟩; exact ⟨m, hpb α⟩
+  have hst : ∀ γ : SL(2, ℤ), ∀ F ∈ S, (F ∘ (γ • ·)) ∈ S := by
+    rintro γ F ⟨α, rfl⟩
+    exact ⟨α * γ, by rw [cw_mul]; rfl⟩
+  have hinvS : ∀ F ∈ S, ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : ℍ, F (γ • τ) = F τ := by
+    rintro F ⟨α, rfl⟩ γ hγ τ
+    simp only [cw_apply]
+    have : α • γ • τ = (α * γ * α⁻¹) • α • τ := by
+      simp only [mul_smul, inv_smul_smul]
+    rw [this]
+    exact hinv _ (conj_mem_Gamma N α hγ) _
+  obtain ⟨a, b, ha, hb, hb0, hGb⟩ :=
+    WLight.exists_levelFraction_of_stable_family N tauPair tauPair_spec
+    (WW N) (WW_spec N) (fricke N) (fricke_spec N) jf jf_spec S hhol hpb' hst hinvS hGS
+  have hpbG : ∀ γ : SL(2, ℤ), ∃ m : ℕ, IsBoundedAtImInfty ((G ∘ (γ • ·)) * ModularForm.discriminant
+    ^ m) :=
+    fun γ => ⟨m, hpb γ⟩
+  obtain ⟨d, p, hprel⟩ :=
+    WLight.exists_monicRel_j_of_mdifferentiable_levelFraction N tauPair tauPair_spec
+    (WW N) (WW_spec N) (fricke N) (fricke_spec N) jf jf_spec ha hb hb0 hG hGb hpbG
+  obtain ⟨n, lam, Gi, Pi, Qi, di, pi, hGsum, hGimd, hPQ, hpiK, hGirel⟩ :=
+    WLight.frickeFunction_intBaseChange N tauPair tauPair_spec (WW N) (WW_spec N) (fricke N)
+      (fricke_spec N) jf jf_spec hG ha hb hb0 hGb p hprel
+  have hPi : ∀ i, ∃ R : MvPolynomial (Idx N) (kN N), ev N id R = Pi i := fun i =>
+    exists_ev_of_mem_adjoin (hPQ i).1
+  have hQi : ∀ i, ∃ R : MvPolynomial (Idx N) (kN N), ev N id R = Qi i := fun i =>
+    exists_ev_of_mem_adjoin (hPQ i).2.1
+  choose Ph hPh using hPi
+  choose Qh hQh using hQi
+  have hrati : ∀ i, ∃ mi : ℕ, RatAt N (kN N) mi (Gi i) := by
+    intro i
+    obtain ⟨mi, h1, h2, h3⟩ := WLight.exists_qExpansion_coeff_mem_of_mdifferentiable_levelFraction N
+      tauPair tauPair_spec (WW N) (WW_spec N) (fricke N) (fricke_spec N) jf jf_spec (kN N) rfl
+      (hGimd i) (MvPolynomial.map (algebraMap (kN N) ℂ) (Ph i))
+      (MvPolynomial.map (algebraMap (kN N) ℂ) (Qh i)) (coeff_map_mem _) (coeff_map_mem _)
+      (by
+        have := (hPQ i).2.2.1
+        rwa [← hQh i] at this)
+      (by
+        have := (hPQ i).2.2.2
+        rw [← hQh i, ← hPh i] at this
+        exact this)
+      ⟨di i, pi i, hpiK i, hGirel i⟩
+    exact ⟨mi, (hGimd i), h1, h2, h3⟩
+  choose mi hmi using hrati
+  set M : ℕ := m + ∑ i, mi i with hM
+  have hGM : RatAt N (kN N) M G := hrat.of_le (Nat.le_add_right _ _)
+  have hGiM : ∀ i, RatAt N (kN N) M (Gi i) := fun i =>
+    (hmi i).of_le (le_trans (Finset.single_le_sum (fun j _ => Nat.zero_le (mi j)) (Finset.mem_univ
+      i))
+      (Nat.le_add_left _ _))
+  have hmem : G ∈ Submodule.span ℂ (Set.range Gi) := by
+    rw [hGsum]
+    exact Submodule.sum_mem _ fun i _ => Submodule.smul_mem _ _ (Submodule.subset_span ⟨i, rfl⟩)
+  obtain ⟨κ, hκ⟩ := exists_rat_combination (kN N) hGiM hGM hmem
+  refine ⟨∑ i, MvPolynomial.C (κ i) * Ph i * ∏ j ∈ Finset.univ.erase i, Qh j, ∏ i, Qh i, ?_, ?_⟩
+  · exact ev_prod_ne_zero Finset.univ Qh fun i _ => by rw [hQh i]; exact (hPQ i).2.2.1
+  · have hev_prod : ∀ (s : Finset (Fin n)), ev N id (∏ j ∈ s, Qh j) = ∏ j ∈ s, Qi j := by
+      intro s; simp only [ev, map_prod]; exact Finset.prod_congr rfl fun j _ => hQh j
+    rw [hκ, hev_prod, Finset.sum_mul]
+    simp only [ev, map_sum, map_mul, MvPolynomial.map_C, MvPolynomial.aeval_C, map_prod]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    have h1 : (MvPolynomial.aeval (gen N id)) (MvPolynomial.map (algebraMap (kN N) ℂ) (Ph i)) = Pi i
+      :=
+      hPh i
+    have h2 : ∀ j, (MvPolynomial.aeval (gen N id)) (MvPolynomial.map (algebraMap (kN N) ℂ) (Qh j)) =
+      Qi j :=
+      hQh
+    simp only [h1, h2]
+    rw [← Finset.mul_prod_erase Finset.univ Qi (Finset.mem_univ i), ← (hPQ i).2.2.2]
+    simp only [Algebra.algebraMap_eq_smul_one, smul_mul_assoc, one_mul]
+    rw [smul_one_smul, mul_assoc]
+    rfl
+
+end Descent
+
+section Algebra
+
+theorem exists_of_mul_eq {K : Type*} [Field K] (ι φ : K →+* ℂ)
+    {B A : PowerSeries K} (hB : B ≠ 0) {ξ : PowerSeries ℂ}
+    (h1 : ξ * B.map ι = A.map ι) (h2 : ξ * B.map φ = A.map φ) :
+    ∃ X : PowerSeries K, X.map ι = ξ ∧ X.map φ = ξ := by
+  classical
+  set v : ℕ := B.order.toNat with hv
+  set U : PowerSeries K := B.divXPowOrder with hU
+  have hBU : PowerSeries.X ^ v * U = B := PowerSeries.X_pow_order_mul_divXPowOrder
+  have hUunit : IsUnit U := by
+    rw [PowerSeries.isUnit_iff_constantCoeff, hU, PowerSeries.constantCoeff_divXPowOrder]
+    exact isUnit_iff_ne_zero.mpr (PowerSeries.coeff_order hB)
+  obtain ⟨u, hu⟩ := hUunit
+  have hAι : A.map ι = PowerSeries.X ^ v * (ξ * U.map ι) := by
+    rw [← h1, ← hBU]
+    simp only [map_mul, map_pow, PowerSeries.map_X]
+    ring
+  have hAdvd : PowerSeries.X ^ v ∣ A := by
+    rw [PowerSeries.X_pow_dvd_iff]
+    intro n hn
+    have hcoef : PowerSeries.coeff n (A.map ι) = 0 := by
+      rw [hAι, PowerSeries.coeff_X_pow_mul', ite_eq_right (not_le.mpr hn)]
+    rw [PowerSeries.coeff_map] at hcoef
+    exact ι.injective (by rw [hcoef, map_zero])
+  obtain ⟨A', hA'⟩ := hAdvd
+  have hXv : (PowerSeries.X : PowerSeries ℂ) ^ v ≠ 0 := pow_ne_zero _ PowerSeries.X_ne_zero
+  have key : ∀ ψ : K →+* ℂ, ξ * B.map ψ = A.map ψ → ξ * U.map ψ = A'.map ψ := by
+    intro ψ h
+    rw [← hBU, hA'] at h
+    simp only [map_mul, map_pow, PowerSeries.map_X] at h
+    have : (PowerSeries.X : PowerSeries ℂ) ^ v * (ξ * U.map ψ) = PowerSeries.X ^ v * A'.map ψ := by
+      rw [← h]; ring
+    exact mul_left_cancel₀ hXv this
+  refine ⟨A' * ↑u⁻¹, ?_, ?_⟩
+  · have hk := key ι h1
+    have hUι : U.map ι ≠ 0 := by
+      rw [← hu]; exact (Units.map (PowerSeries.map ι).toMonoidHom u).ne_zero
+    apply mul_right_cancel₀ hUι
+    rw [hk, map_mul, mul_assoc, ← map_mul, ← hu, Units.inv_mul, map_one, mul_one]
+  · have hk := key φ h2
+    have hUφ : U.map φ ≠ 0 := by
+      rw [← hu]; exact (Units.map (PowerSeries.map φ).toMonoidHom u).ne_zero
+    apply mul_right_cancel₀ hUφ
+    rw [hk, map_mul, mul_assoc, ← map_mul, ← hu, Units.inv_mul, map_one, mul_one]
+
+end Algebra
+
+section Main
+
+variable {N : ℕ} [NeZero N]
+
+local notation "Δ" => ModularForm.discriminant
+
+theorem exists_discSeries (K : IntermediateField ℚ ℂ) :
+    ∃ δ : PowerSeries K, (∀ n, ∃ r : ℚ, ((PowerSeries.coeff n δ : K) : ℂ) = (r : ℂ)) ∧
+      δ.map (algebraMap K ℂ) = qExpansion N (Δ : ℍ → ℂ) := by
+  choose r hr using qExpansion_disc_rat N
+  refine ⟨PowerSeries.mk fun n => ⟨(r n : ℂ), ratCast_mem (r n)⟩, fun n => ⟨r n, by simp⟩, ?_⟩
+  ext n
+  simp [hr n]
+
+variable (σ : (kN N) ≃ₐ[ℚ] (kN N))
+
+omit [NeZero N] in
+theorem map_phiOf_eq_of_rat {δ : PowerSeries (kN N)}
+    (hδ : ∀ n, ∃ r : ℚ, ((PowerSeries.coeff n δ : kN N) : ℂ) = (r : ℂ)) :
+    δ.map (phiOf N σ) = δ.map (algebraMap (kN N) ℂ) := by
+  ext n
+  rw [PowerSeries.coeff_map, PowerSeries.coeff_map]
+  obtain ⟨r, hr⟩ := hδ n
+  rw [phiOf_ratCast N σ r _ hr]
+  exact hr.symm
+
+theorem tσ_lift {g g' : ℍ → ℂ} (h : Tσ σ g g') :
+    ∃ m : ℕ, RatAt N (kN N) m g ∧ RatAt N (kN N) m g' ∧ ∀ M : ℕ, m ≤ M →
+      ∃ p : PowerSeries (kN N), p.map (algebraMap (kN N) ℂ) = qExpansion N (g * Δ ^ M) ∧
+        p.map (phiOf N σ) = qExpansion N (g' * Δ ^ M) := by
+  obtain ⟨m, hg, hg', h4⟩ := h.exists
+  refine ⟨m, hg, hg', ?_⟩
+  intro M hM
+  obtain ⟨d, rfl⟩ := Nat.exists_eq_add_of_le hM
+  obtain ⟨p₀, hp₀⟩ := hg.exists_map
+  have hp₀' := TRel.map_eq h4 hp₀
+  obtain ⟨δ, hδrat, hδ⟩ := exists_discSeries (N := N) (kN N)
+  refine ⟨p₀ * δ ^ d, ?_, ?_⟩
+  · induction d with
+    | zero => simpa using hp₀
+    | succ d ih =>
+        have hR : RatAt N (kN N) (m + d) g := hg.of_le (Nat.le_add_right _ _)
+        rw [pow_succ, ← mul_assoc, map_mul, ih (Nat.le_add_right _ _), hδ, ← add_assoc, pow_succ,
+          ← mul_assoc, qExpansion_mul hR.analyticAt analyticAt_disc]
+  · induction d with
+    | zero => simpa using hp₀'
+    | succ d ih =>
+        have hR : RatAt N (kN N) (m + d) g' := hg'.of_le (Nat.le_add_right _ _)
+        rw [pow_succ, ← mul_assoc, map_mul, ih (Nat.le_add_right _ _), map_phiOf_eq_of_rat σ hδrat,
+          hδ,
+          ← add_assoc, pow_succ, ← mul_assoc, qExpansion_mul hR.analyticAt analyticAt_disc]
+
+variable {σ}
+
+omit [NeZero N] in
+theorem aeval_relPoly (φ : kN N →+* ℂ) (G : ℍ → ℂ) (t : (Fin 2 → ZMod N) → (Fin 2 → ZMod N))
+    (P Q : MvPolynomial (Idx N) (kN N)) :
+    MvPolynomial.aeval (fun o : Option (Idx N) => o.elim G (gen N t))
+      (MvPolynomial.map φ (MvPolynomial.X none * MvPolynomial.rename some Q -
+        MvPolynomial.rename some P)) = G * evφ N φ t Q - evφ N φ t P := by
+  simp only [map_sub, map_mul, MvPolynomial.map_X, MvPolynomial.aeval_X, MvPolynomial.map_rename,
+    MvPolynomial.aeval_rename]
+  rfl
+
+omit [NeZero N] in
+theorem evφ_algebraMap (t : (Fin 2 → ZMod N) → (Fin 2 → ZMod N)) (R : MvPolynomial (Idx N) (kN N)) :
+    evφ N (algebraMap (kN N) ℂ) t R = ev N t R := rfl
+
+theorem cw_ne_zero {b : ℍ → ℂ} (hb : b ≠ 0) (γ : SL(2, ℤ)) : cw b γ ≠ 0 := by
+  intro h
+  apply hb
+  have : cw (cw b γ) γ⁻¹ = b := by rw [← cw_mul, mul_inv_cancel, cw_one]
+  rw [← this, h]; rfl
+
+theorem exists_series_fixed {m : ℕ} {G : ℍ → ℂ} (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (hinv : ∀ g ∈ Gamma1 N, ∀ τ : ℍ, G (g • τ) = G τ)
+    (hpb : ∀ α : SL(2, ℤ), IsBoundedAtImInfty (cw G α * Δ ^ m))
+    (hrat : ∀ n, ∃ r : ℚ, (qExpansion N (G * Δ ^ m)).coeff n = (r : ℂ))
+    {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 N) (σ : (kN N) ≃ₐ[ℚ] (kN N)) :
+    ∃ X : PowerSeries (kN N), X.map (algebraMap (kN N) ℂ) = qExpansion N (cw G γ * Δ ^ m) ∧
+      X.map (phiOf N σ) = qExpansion N (cw G γ * Δ ^ m) := by
+  classical
+  have hperG : Periodic (G ∘ ofComplex) 1 :=
+    periodic_of_T_invariant fun τ => hinv _ (T_mem_Gamma1 N) τ
+  have hinvγ : ∀ g ∈ Gamma1 N, ∀ τ : ℍ, cw G γ (g • τ) = cw G γ τ := by
+    intro g hg τ
+    simp only [cw_apply]
+    have : γ • g • τ = (γ * g * γ⁻¹) • γ • τ := by simp only [mul_smul, inv_smul_smul]
+    rw [this]; exact hinv _ (conj_mem_Gamma1 N hγ hg) _
+  have hperγ : Periodic (cw G γ ∘ ofComplex) 1 :=
+    periodic_of_T_invariant fun τ => hinvγ _ (T_mem_Gamma1 N) τ
+  have hratG : RatAt N (kN N) m G :=
+    ⟨hG, periodic_mul (periodic_ofComplex_natCast hperG N)
+      (periodic_pow (periodic_ofComplex_natCast periodic_disc_one N) m),
+      by simpa [cw_one] using hpb 1,
+      fun n => by obtain ⟨r, hr⟩ := hrat n; rw [hr]; exact ratCast_mem r⟩
+  obtain ⟨P, Q, hb0, hGb⟩ := descent hG (fun g hg => hinv g (Gamma_le_Gamma1 N hg)) hpb hratG
+  obtain ⟨s, hs, hσ⟩ := exists_pow_of_aut N σ
+  have hT0 : Tσ σ (G * evφ N (algebraMap (kN N) ℂ) id Q - evφ N (algebraMap (kN N) ℂ) id P)
+      (G * evφ N (phiOf N σ) (ds N s ∘ id) Q - evφ N (phiOf N σ) (ds N s ∘ id) P) := by
+    have hfam : ∀ o : Option (Idx N), Tσ σ ((fun o : Option (Idx N) => o.elim G (gen N id)) o)
+        ((fun o : Option (Idx N) => o.elim G (gen N (ds N s ∘ id))) o) := by
+      intro o
+      cases o with
+      | none =>
+          exact tRel_self_of_rat hG hratG.periodic hratG.bdd hrat
+      | some o => exact tσ_gen σ hs hσ id (fun v hv => hv) o
+    have :=
+      tσ_aeval σ hfam (MvPolynomial.X none * MvPolynomial.rename some Q - MvPolynomial.rename some
+        P)
+    rwa [aeval_relPoly, aeval_relPoly] at this
+  have hzero : G * evφ N (phiOf N σ) (ds N s) Q - evφ N (phiOf N σ) (ds N s) P = 0 := by
+    have h0 : G * evφ N (algebraMap (kN N) ℂ) id Q - evφ N (algebraMap (kN N) ℂ) id P = 0 := by
+      rw [evφ_algebraMap, evφ_algebraMap, hGb, sub_self]
+    exact (tσ_zero_iff σ hT0).mp h0
+  obtain ⟨γ', ⟨g₁, hg₁, rfl⟩, hvm⟩ := exists_twist_conj N hγ s
+  have hvm' : (vm N (g₁ * γ) ∘ ds N s) = (ds N s ∘ vm N γ) := funext hvm
+  have hcwG : cw G (g₁ * γ) = cw G γ := by
+    rw [cw_mul]; congr 1; funext τ; exact hinv g₁ hg₁ τ
+  have hE1 : cw G γ * ev N (vm N γ) Q = ev N (vm N γ) P := by
+    have := congrArg (fun F => cw F γ) hGb
+    simp only [cw_mul_fun, cw_ev] at this
+    exact this
+  have hE2 : cw G γ * evφ N (phiOf N σ) (ds N s ∘ vm N γ) Q = evφ N (phiOf N σ) (ds N s ∘ vm N γ) P
+    :=
+    by
+    have h := congrArg (fun F => cw F (g₁ * γ)) (sub_eq_zero.mp hzero)
+    simp only [cw_mul_fun, cw_evφ, hcwG] at h
+    rw [hvm'] at h
+    exact h
+  have hTQ : Tσ σ (ev N (vm N γ) Q) (evφ N (phiOf N σ) (ds N s ∘ vm N γ) Q) :=
+    tσ_ev σ hs hσ (vm N γ) (fun v hv => vm_ne_zero N γ hv) Q
+  have hTP : Tσ σ (ev N (vm N γ) P) (evφ N (phiOf N σ) (ds N s ∘ vm N γ) P) :=
+    tσ_ev σ hs hσ (vm N γ) (fun v hv => vm_ne_zero N γ hv) P
+  obtain ⟨mQ, hQr, hQr', hQlift⟩ := tσ_lift σ hTQ
+  obtain ⟨mP, hPr, hPr', hPlift⟩ := tσ_lift σ hTP
+  set MQ : ℕ := mQ + mP with hMQ
+  obtain ⟨pB, hpB, hpB'⟩ := hQlift MQ (Nat.le_add_right _ _)
+  obtain ⟨pA, hpA, hpA'⟩ := hPlift (m + MQ) (by omega)
+  have hmdγ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (cw G γ * Δ ^ m) :=
+    (mdifferentiable_cw hG γ).mul (mdifferentiable_disc.pow m)
+  have hperγm : Periodic ((cw G γ * Δ ^ m) ∘ ofComplex) N :=
+    periodic_mul (periodic_ofComplex_natCast hperγ N) (periodic_pow (periodic_ofComplex_natCast
+      periodic_disc_one N) m)
+  have hanγ : AnalyticAt ℂ (cuspFunction N (cw G γ * Δ ^ m)) 0 :=
+    analyticAt_cuspFunction_zero (natCast_pos N) hperγm hmdγ (hpb γ)
+  have hQR : RatAt N (kN N) MQ (ev N (vm N γ) Q) := hQr.of_le (Nat.le_add_right _ _)
+  have hQR' : RatAt N (kN N) MQ (evφ N (phiOf N σ) (ds N s ∘ vm N γ) Q) :=
+    hQr'.of_le (Nat.le_add_right _ _)
+  have hsplit : ∀ F : ℍ → ℂ, F * Δ ^ (m + MQ) = Δ ^ m * (F * Δ ^ MQ) := by
+    intro F; rw [pow_add]; ring
+  have h1 : qExpansion N (cw G γ * Δ ^ m) * pB.map (algebraMap (kN N) ℂ) = pA.map (algebraMap (kN N)
+    ℂ) :=
+    by
+    rw [hpB, hpA, ← hE1, ← qExpansion_mul hanγ hQR.analyticAt]
+    congr 1; rw [pow_add]; ring
+  have h2 : qExpansion N (cw G γ * Δ ^ m) * pB.map (phiOf N σ) = pA.map (phiOf N σ) := by
+    rw [hpB', hpA', ← hE2, ← qExpansion_mul hanγ hQR'.analyticAt]
+    congr 1; rw [pow_add]; ring
+  have hpB0 : pB ≠ 0 := by
+    intro h0
+    have hne := hQR.qExpansion_ne_zero (by
+      have : ev N (vm N γ) Q = cw (ev N id Q) γ := by rw [cw_ev]; rfl
+      rw [this]; exact cw_ne_zero hb0 γ)
+    rw [← hpB, h0, map_zero] at hne
+    exact hne rfl
+  exact exists_of_mul_eq (algebraMap (kN N) ℂ) (phiOf N σ) hpB0 h1 h2
+
+theorem rat_cw_of_mem_Gamma0 {m : ℕ} {G : ℍ → ℂ} (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (hinv : ∀ g ∈ Gamma1 N, ∀ τ : ℍ, G (g • τ) = G τ)
+    (hpb : ∀ α : SL(2, ℤ), IsBoundedAtImInfty (cw G α * Δ ^ m))
+    (hrat : ∀ n, ∃ r : ℚ, (qExpansion N (G * Δ ^ m)).coeff n = (r : ℂ))
+    {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 N) (n : ℕ) :
+    ∃ r : ℚ, (qExpansion N (cw G γ * Δ ^ m)).coeff n = (r : ℂ) := by
+  obtain ⟨X₀, hX₀, -⟩ := exists_series_fixed hG hinv hpb hrat hγ AlgEquiv.refl
+  set x : kN N := PowerSeries.coeff n X₀ with hx
+  have hxξ : (x : ℂ) = (qExpansion N (cw G γ * Δ ^ m)).coeff n := by
+    rw [← hX₀, PowerSeries.coeff_map]; rfl
+  obtain ⟨r, hr⟩ := exists_rat_of_fixed N x (fun σ => by
+    obtain ⟨X, hX, hX'⟩ := exists_series_fixed hG hinv hpb hrat hγ σ
+    have hy : ((PowerSeries.coeff n X : kN N) : ℂ) = (qExpansion N (cw G γ * Δ ^ m)).coeff n := by
+      rw [← hX, PowerSeries.coeff_map]; rfl
+    have hyx : PowerSeries.coeff n X = x := Subtype.ext (hy.trans hxξ.symm)
+    have hφ : phiOf N σ (PowerSeries.coeff n X) = (qExpansion N (cw G γ * Δ ^ m)).coeff n := by
+      rw [← hX', PowerSeries.coeff_map]
+    rw [hyx, phiOf_apply, ← hxξ] at hφ
+    exact Subtype.ext hφ)
+  exact ⟨r, by rw [← hxξ, hr]⟩
+
+theorem cardK (N : ℕ) [NeZero N] (m : ℕ) (G : ℍ → ℂ) (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (hinv : ∀ g ∈ CongruenceSubgroup.Gamma1 N, ∀ τ : ℍ, G (g • τ) = G τ)
+    (hbd : ∀ α : SL(2, ℤ), IsBoundedAtImInfty ((fun τ => G (α • τ)) * ModularForm.discriminant ^ m))
+    (hrat : ∀ n : ℕ, ∃ r : ℚ,
+      (qExpansion 1 (G * ModularForm.discriminant ^ m)).coeff n = (r : ℂ))
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 N) (n : ℕ) :
+    ∃ r : ℚ, (qExpansion 1 ((fun τ => G (γ • τ)) * ModularForm.discriminant ^ m)).coeff n = (r : ℂ)
+      := by
+  have hperG : Periodic (G ∘ ofComplex) 1 :=
+    periodic_of_T_invariant fun τ => hinv _ (T_mem_Gamma1 N) τ
+  have hinvγ : ∀ g ∈ Gamma1 N, ∀ τ : ℍ, cw G γ (g • τ) = cw G γ τ := by
+    intro g hg τ
+    simp only [cw_apply]
+    have : γ • g • τ = (γ * g * γ⁻¹) • γ • τ := by simp only [mul_smul, inv_smul_smul]
+    rw [this]; exact hinv _ (conj_mem_Gamma1 N hγ hg) _
+  have hperγ : Periodic (cw G γ ∘ ofComplex) 1 :=
+    periodic_of_T_invariant fun τ => hinvγ _ (T_mem_Gamma1 N) τ
+  have hper1 : Periodic ((G * Δ ^ m) ∘ ofComplex) 1 :=
+    periodic_mul hperG (periodic_pow periodic_disc_one m)
+  have hper1γ : Periodic ((cw G γ * Δ ^ m) ∘ ofComplex) 1 :=
+    periodic_mul hperγ (periodic_pow periodic_disc_one m)
+  have hmd : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (G * Δ ^ m) := hG.mul (mdifferentiable_disc.pow m)
+  have hmdγ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (cw G γ * Δ ^ m) :=
+    (mdifferentiable_cw hG γ).mul (mdifferentiable_disc.pow m)
+  have hbd1 : IsBoundedAtImInfty (G * Δ ^ m) := by simpa [cw_one] using hbd 1
+  have hratN : ∀ n, ∃ r : ℚ, (qExpansion N (G * Δ ^ m)).coeff n = (r : ℂ) :=
+    qExpansion_widthN_rat N hmd hper1 hbd1 hrat
+  have key := fun n => rat_cw_of_mem_Gamma0 (N := N) hG hinv hbd hratN hγ n
+  exact qExpansion_widthOne_rat N hmdγ hper1γ (hbd γ) key n
+
+end Main
+
+end X1DiamondRational
+end
+
+open scoped MatrixGroups Manifold in
+theorem solution (N : ℕ) [NeZero N] (m : ℕ)
+    (G : UpperHalfPlane → ℂ) (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (hinv : ∀ g ∈ CongruenceSubgroup.Gamma1 N, ∀ τ : UpperHalfPlane, G (g • τ) = G τ)
+    (hbd : ∀ α : SL(2, ℤ), UpperHalfPlane.IsBoundedAtImInfty
+      ((fun τ : UpperHalfPlane => G (α • τ)) * ModularForm.discriminant ^ m))
+    (hrat : ∀ n : ℕ, ∃ r : ℚ,
+      (UpperHalfPlane.qExpansion 1 (G * ModularForm.discriminant ^ m)).coeff n = (r : ℂ))
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 N) (n : ℕ) :
+    ∃ r : ℚ, (UpperHalfPlane.qExpansion 1
+      ((fun τ : UpperHalfPlane => G (γ • τ)) * ModularForm.discriminant ^ m)).coeff n = (r : ℂ) :=
+  X1DiamondRational.cardK N m G hG hinv hbd hrat γ hγ n
+
+end S_ModularCurve_exists_ratCast_qExpansion_comp_smul_of_mem_Gamma0
+end P2MW
+export P2MW.S_ModularCurve_exists_ratCast_qExpansion_comp_smul_of_mem_Gamma0 (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups Manifold in
+theorem ModularCurve.exists_ratCast_qExpansion_comp_smul_of_mem_Gamma0 (N : ℕ) [NeZero N] (m : ℕ)
+    (G : UpperHalfPlane → ℂ) (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (hinv : ∀ g ∈ CongruenceSubgroup.Gamma1 N, ∀ τ : UpperHalfPlane, G (g • τ) = G τ)
+    (hbd : ∀ α : SL(2, ℤ), UpperHalfPlane.IsBoundedAtImInfty
+      ((fun τ : UpperHalfPlane => G (α • τ)) * ModularForm.discriminant ^ m))
+    (hrat : ∀ n : ℕ, ∃ r : ℚ,
+      (UpperHalfPlane.qExpansion 1 (G * ModularForm.discriminant ^ m)).coeff n = (r : ℂ))
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 N) (n : ℕ) :
+    ∃ r : ℚ, (UpperHalfPlane.qExpansion 1
+      ((fun τ : UpperHalfPlane => G (γ • τ)) * ModularForm.discriminant ^ m)).coeff n = (r : ℂ) :=
+  solution N m G hG hinv hbd hrat γ hγ n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_ratCast_qExpansion_slash_of_mem_Gamma0.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_ratCast_qExpansion_slash_of_mem_Gamma0.lean
new file mode 100644
index 0000000000..bb6ae99db7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_ratCast_qExpansion_slash_of_mem_Gamma0.lean
@@ -0,0 +1,674 @@
+/-
+Based on Prove2Me node ModularCurve.exists_ratCast_qExpansion_slash_of_mem_Gamma0
+(31aaf82e-a346-51e6-8114-eafcfedadbcf) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 05049df6-e1ea-5e33-a12f-c66103aba231
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+import LeanPool.FLTEichlerShimura.Theorems.Thm_EisensteinWeightOne_e1Chi3IsModular
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_ratCast_qExpansion_comp_smul_of_mem_Gamma0
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Rationality of q-expansions under slashing by Γ₀(M)
+
+Theorem statement: `ModularCurve.exists_ratCast_qExpansion_slash_of_mem_Gamma0`
+(`31aaf82e-a346-51e6-8114-eafcfedadbcf`), by Claude, 2026-09-05.
+
+Proof: submission `05049df6-e1ea-5e33-a12f-c66103aba231`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a positive natural number, let $k$ be an integer, and let $f$ be a modular form of weight
+$k$ for the congruence subgroup $\Gamma_1(M)$, viewed as a subgroup of $\mathrm{GL}_2(\mathbb{R})$.
+Assume that the $q$-expansion of $f$ at $\infty$ of width $1$, i.e. the expansion in $q = e^{2\pi i
+\tau}$ given by `UpperHalfPlane.qExpansion 1`, has all its coefficients rational: for every natural
+number $n$ there is $r \in \mathbb{Q}$ with $n$-th coefficient equal to the image of $r$ in
+$\mathbb{C}$. Let $\gamma \in \mathrm{SL}_2(\mathbb{Z})$ lie in $\Gamma_0(M)$, and let $n$ be a
+natural number. Then the $n$-th coefficient of the width-$1$ $q$-expansion of the function
+$\mathbb{H} \to \mathbb{C}$ obtained by applying the weight-$k$ slash operator $\cdot \mid_k \gamma$
+to the underlying function of $f$ is again the image of a rational number. The conclusion concerns
+the slashed function as a function on the upper half-plane; no modular form structure on it is
+asserted.
+
+This is the rationality half of the classical statement that the diamond operators $\langle \delta
+\rangle$ on forms for $\Gamma_1(M)$ are defined over $\mathbb{Q}$ with respect to the expansion at
+the cusp $\infty$: since $\Gamma_1(M)$ is normal in $\Gamma_0(M)$, slashing by $\gamma \in
+\Gamma_0(M)$ preserves the space of forms of weight $k$ on $\Gamma_1(M)$ and preserves rationality
+of Fourier coefficients. It feeds the results on bases of cusp forms with rational (or integral)
+$q$-coefficients stable under slashing and under Hecke and diamond operators, such as
+[`CuspForm.exists_basis_gamma1_qCoeff_slash_mem_range_intCast`]
+(thm.html#CuspForm.exists_basis_gamma1_qCoeff_slash_mem_range_intCast)
+and
+[`CuspForm.exists_basis_gammaH_qCoeff_mem_range_ratCast`]
+(thm.html#CuspForm.exists_basis_gammaH_qCoeff_mem_range_ratCast).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_ratCast_qExpansion_slash_of_mem_Gamma0.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_ratCast_qExpansion_slash_of_mem_Gamma0
+
+noncomputable section
+
+open Complex UpperHalfPlane ModularForm CongruenceSubgroup Function ModularCurve
+open scoped Real Manifold MatrixGroups ModularForm Topology
+
+namespace X1DiamondRationalForms
+
+local notation "Γ₁(" M ")" => ((Gamma1 M : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ))
+local notation "Δ" => ModularForm.discriminant
+
+def IsRat (q : PowerSeries ℂ) : Prop := ∀ n, ∃ r : ℚ, q.coeff n = (r : ℂ)
+
+theorem isRat_iff_exists_map {q : PowerSeries ℂ} :
+    IsRat q ↔ ∃ p : PowerSeries ℚ, p.map (algebraMap ℚ ℂ) = q := by
+  constructor
+  · intro h
+    choose r hr using h
+    exact ⟨PowerSeries.mk r, by ext n; simp [hr n]⟩
+  · rintro ⟨p, rfl⟩ n
+    exact ⟨PowerSeries.coeff n p, by rw [PowerSeries.coeff_map]; rfl⟩
+
+theorem IsRat.mul {q q' : PowerSeries ℂ} (h : IsRat q) (h' : IsRat q') : IsRat (q * q') := by
+  rw [isRat_iff_exists_map] at h h' ⊢
+  obtain ⟨p, rfl⟩ := h
+  obtain ⟨p', rfl⟩ := h'
+  exact ⟨p * p', by rw [map_mul]⟩
+
+theorem IsRat.pow {q : PowerSeries ℂ} (h : IsRat q) (n : ℕ) : IsRat (q ^ n) := by
+  rw [isRat_iff_exists_map] at h ⊢
+  obtain ⟨p, rfl⟩ := h
+  exact ⟨p ^ n, by rw [map_pow]⟩
+
+theorem IsRat.smul {q : PowerSeries ℂ} (h : IsRat q) (r : ℚ) : IsRat ((r : ℂ) • q) := by
+  intro n
+  obtain ⟨s, hs⟩ := h n
+  exact ⟨r * s, by simp [hs]⟩
+
+theorem IsRat.neg {q : PowerSeries ℂ} (h : IsRat q) : IsRat (-q) := by
+  intro n
+  obtain ⟨s, hs⟩ := h n
+  exact ⟨-s, by simp [hs]⟩
+
+theorem IsRat.of_mul_eq {q u p : PowerSeries ℂ} (hu : IsRat u)
+    (hu0 : PowerSeries.constantCoeff u = 1)
+    (hp : IsRat p) (h : q * u = p) : IsRat q := by
+  rw [isRat_iff_exists_map] at hu hp ⊢
+  obtain ⟨U, rfl⟩ := hu
+  obtain ⟨P, rfl⟩ := hp
+  have hU0 : PowerSeries.constantCoeff U = 1 := by
+    have : algebraMap ℚ ℂ (PowerSeries.constantCoeff U) = 1 := by
+      rw [← PowerSeries.coeff_zero_eq_constantCoeff_apply, ← hu0,
+        ← PowerSeries.coeff_zero_eq_constantCoeff_apply, PowerSeries.coeff_map]
+    exact (algebraMap ℚ ℂ).injective (by rw [this, map_one])
+  have hUunit : IsUnit U := by
+    rw [PowerSeries.isUnit_iff_constantCoeff, hU0]; exact isUnit_one
+  obtain ⟨v, hv⟩ := hUunit
+  refine ⟨P * ↑v⁻¹, ?_⟩
+  have hne : (U.map (algebraMap ℚ ℂ)) ≠ 0 := by
+    intro h0
+    have := congrArg (PowerSeries.coeff 0) h0
+    rw [PowerSeries.coeff_map, PowerSeries.coeff_zero_eq_constantCoeff_apply, hU0] at this
+    simp at this
+  apply mul_right_cancel₀ hne
+  rw [h, map_mul, mul_assoc, ← map_mul, ← hv, Units.inv_mul, map_one, mul_one]
+
+section Level
+
+variable {M : ℕ} {k : ℤ}
+
+theorem T_mem_Gamma1 (M : ℕ) : ModularGroup.T ∈ Gamma1 M := by
+  simp [Gamma1_mem, ModularGroup.T]
+
+theorem one_mem_strictPeriods (M : ℕ) : (1 : ℝ) ∈ (Γ₁(M)).strictPeriods := by
+  rw [Subgroup.strictPeriods_eq_zmultiples_one_of_T_mem (T_mem_Gamma1 M)]
+  exact AddSubgroup.mem_zmultiples 1
+
+theorem conj_mem_Gamma1 {γ A : SL(2, ℤ)} (hγ : γ ∈ Gamma0 M) (hA : A ∈ Gamma1 M) :
+    γ * A * γ⁻¹ ∈ Gamma1 M := by
+  have hA0 : A ∈ Gamma0 M := Gamma1_in_Gamma0 M hA
+  set A₀ : Gamma0 M := ⟨A, hA0⟩
+  set γ₀ : Gamma0 M := ⟨γ, hγ⟩
+  have hA1 : A₀ ∈ Gamma1' M := by
+    rw [Gamma1_to_Gamma0_mem]
+    exact (Gamma1_mem M A).mp hA
+  have : (Gamma1' M).Normal := by
+    change ((Gamma0Map M).ker).Normal
+    infer_instance
+  have hconj : γ₀ * A₀ * γ₀⁻¹ ∈ Gamma1' M := Subgroup.Normal.conj_mem inferInstance A₀ hA1 γ₀
+  rw [Gamma1_to_Gamma0_mem] at hconj
+  rw [Gamma1_mem]
+  exact hconj
+
+theorem isBoundedAtImInfty_slash [NeZero M] (f : ModularForm Γ₁(M) k) (γ : SL(2, ℤ)) :
+    IsBoundedAtImInfty ((⇑f : ℍ → ℂ) ∣[k] γ) := by
+  rw [ModularForm.SL_slash, ← OnePoint.isBoundedAt_infty_iff, ← OnePoint.IsBoundedAt.smul_iff]
+  apply f.bdd_at_cusps'
+  rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z]
+  exact isCusp_SL2Z_iff'.mpr ⟨γ, rfl⟩
+
+def diamondSlash [NeZero M] (γ : SL(2, ℤ)) (hγ : γ ∈ Gamma0 M) (f : ModularForm Γ₁(M) k) :
+    ModularForm Γ₁(M) k where
+  toFun := (⇑f : ℍ → ℂ) ∣[k] (γ : GL (Fin 2) ℝ)
+  slash_action_eq' := by
+    intro A hA
+    obtain ⟨A, hA, rfl⟩ := hA
+    have hconj : γ * A * γ⁻¹ ∈ Gamma1 M := conj_mem_Gamma1 hγ hA
+    have hGL : (γ : GL (Fin 2) ℝ) * (A : GL (Fin 2) ℝ)
+        = ((γ * A * γ⁻¹ : SL(2, ℤ)) : GL (Fin 2) ℝ) * (γ : GL (Fin 2) ℝ) := by
+      simp only [map_mul, map_inv, inv_mul_cancel_right]
+    change ((⇑f : ℍ → ℂ) ∣[k] (γ : GL (Fin 2) ℝ)) ∣[k] (A : GL (Fin 2) ℝ)
+      = (⇑f : ℍ → ℂ) ∣[k] (γ : GL (Fin 2) ℝ)
+    rw [← SlashAction.slash_mul, hGL, SlashAction.slash_mul]
+    congr 1
+    exact SlashInvariantFormClass.slash_action_eq f _ (Subgroup.mem_map_of_mem _ hconj)
+  holo' := f.holo'.slash k _
+  bdd_at_cusps' := by
+    intro c hc
+    have hcSL : IsCusp c 𝒮ℒ := (Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z Γ₁(M)).mp hc
+    have hc' : IsCusp ((γ : GL (Fin 2) ℝ) • c) Γ₁(M) := by
+      rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z]
+      exact hcSL.smul_of_mem ⟨γ, rfl⟩
+    exact OnePoint.IsBoundedAt.smul_iff.mp (f.bdd_at_cusps' hc')
+
+theorem coe_diamondSlash [NeZero M] (γ : SL(2, ℤ)) (hγ : γ ∈ Gamma0 M) (f : ModularForm Γ₁(M) k) :
+    (⇑(diamondSlash γ hγ f) : ℍ → ℂ) = (⇑f : ℍ → ℂ) ∣[k] γ := by
+  rw [ModularForm.SL_slash]; rfl
+
+theorem mul_inv_mem_Gamma1 {γ γ' : SL(2, ℤ)} (hγ : γ ∈ Gamma0 M) (hγ' : γ' ∈ Gamma0 M)
+    (h : ((γ 1 1 : ℤ) : ZMod M) = ((γ' 1 1 : ℤ) : ZMod M)) : γ * γ'⁻¹ ∈ Gamma1 M := by
+  have hc : ((γ 1 0 : ℤ) : ZMod M) = 0 := Gamma0_mem.mp hγ
+  have hc' : ((γ' 1 0 : ℤ) : ZMod M) = 0 := Gamma0_mem.mp hγ'
+  have hdet : ((γ 0 0 : ℤ) : ZMod M) * ((γ 1 1 : ℤ) : ZMod M) = 1 := by
+    have h1 : (γ 0 0 : ℤ) * γ 1 1 - γ 0 1 * γ 1 0 = 1 := by
+      have := γ.det_coe; rwa [Matrix.det_fin_two] at this
+    have := congrArg (Int.cast : ℤ → ZMod M) h1
+    push_cast at this
+    rw [hc, mul_zero, sub_zero] at this
+    exact this
+  have hdet' : ((γ' 0 0 : ℤ) : ZMod M) * ((γ' 1 1 : ℤ) : ZMod M) = 1 := by
+    have h1 : (γ' 0 0 : ℤ) * γ' 1 1 - γ' 0 1 * γ' 1 0 = 1 := by
+      have := γ'.det_coe; rwa [Matrix.det_fin_two] at this
+    have := congrArg (Int.cast : ℤ → ZMod M) h1
+    push_cast at this
+    rw [hc', mul_zero, sub_zero] at this
+    exact this
+  have h00 : ((γ 0 0 : ℤ) : ZMod M) = ((γ' 0 0 : ℤ) : ZMod M) := by
+    have hu : IsUnit ((γ 1 1 : ℤ) : ZMod M) :=
+      isUnit_iff_exists_inv.mpr ⟨_, by rw [mul_comm]; exact hdet⟩
+    apply hu.mul_right_cancel
+    rw [hdet, h, hdet']
+  have hinv : (γ'⁻¹ : SL(2, ℤ)) = ⟨!![γ' 1 1, -(γ' 0 1); -(γ' 1 0), γ' 0 0], by
+      rw [Matrix.det_fin_two_of]; have := γ'.det_coe; rw [Matrix.det_fin_two] at this
+      linear_combination this⟩ := Matrix.SpecialLinearGroup.SL2_inv_expl γ'
+  rw [Gamma1_mem, hinv]
+  simp only [Matrix.SpecialLinearGroup.coe_mul, Matrix.mul_apply, Fin.sum_univ_two,
+    Matrix.of_apply, Matrix.cons_val', Matrix.cons_val_zero, Matrix.cons_val_one,
+    Matrix.cons_val_fin_one, Matrix.empty_val', Int.cast_add, Int.cast_mul, Int.cast_neg, hc, hc',
+    Fin.isValue]
+  refine ⟨?_, ?_, ?_⟩
+  · rw [h00, neg_zero, mul_zero, add_zero, hdet']
+  · rw [zero_mul, zero_add, ← h00, mul_comm, hdet]
+  · simp
+
+theorem slash_eq_of_apply_eq [NeZero M] (f : ModularForm Γ₁(M) k) {γ γ' : SL(2, ℤ)}
+    (hγ : γ ∈ Gamma0 M) (hγ' : γ' ∈ Gamma0 M)
+    (h : ((γ 1 1 : ℤ) : ZMod M) = ((γ' 1 1 : ℤ) : ZMod M)) :
+    (⇑f : ℍ → ℂ) ∣[k] γ = (⇑f : ℍ → ℂ) ∣[k] γ' := by
+  have hmem := mul_inv_mem_Gamma1 hγ hγ' h
+  have hinv : (⇑f : ℍ → ℂ) ∣[k] (γ * γ'⁻¹) = ⇑f := by
+    rw [ModularForm.SL_slash]
+    exact SlashInvariantFormClass.slash_action_eq f _ (Subgroup.mem_map_of_mem _ hmem)
+  calc (⇑f : ℍ → ℂ) ∣[k] γ = (⇑f : ℍ → ℂ) ∣[k] (γ * γ'⁻¹ * γ') := by rw [inv_mul_cancel_right]
+    _ = ((⇑f : ℍ → ℂ) ∣[k] (γ * γ'⁻¹)) ∣[k] γ' := SlashAction.slash_mul _ _ _ _
+    _ = (⇑f : ℍ → ℂ) ∣[k] γ' := by rw [hinv]
+
+private theorem _root_.X1DiamondRationalForms.Gamma1_le_of_dvd {M' : ℕ} (h : M ∣ M') :
+    Gamma1 M' ≤ Gamma1 M := ModularCurve.Gamma1_le_of_dvd h
+
+p2m_export "X1DiamondRationalForms" "Gamma1_le_of_dvd"
+theorem Gamma0_le_of_dvd {M' : ℕ} (h : M ∣ M') : Gamma0 M' ≤ Gamma0 M := by
+  intro A hA
+  rw [Gamma0_mem] at hA ⊢
+  have := congrArg (ZMod.castHom h (ZMod M)) hA
+  rwa [map_intCast, map_zero] at this
+
+def res {M' : ℕ} (h : M ∣ M') (f : ModularForm Γ₁(M) k) : ModularForm Γ₁(M') k :=
+  restrictForm (Subgroup.map_mono (Gamma1_le_of_dvd h)) f
+
+@[scoped simp] theorem coe_res {M' : ℕ} (h : M ∣ M') (f : ModularForm Γ₁(M) k) :
+    (⇑(res h f) : ℍ → ℂ) = f := rfl
+
+def resSL (M : ℕ) {k : ℤ} (f : ModularForm 𝒮ℒ k) : ModularForm Γ₁(M) k :=
+  restrictForm (Subgroup.map_le_range _ _) f
+
+@[scoped simp] theorem coe_resSL (M : ℕ) {k : ℤ} (f : ModularForm 𝒮ℒ k) :
+    (⇑(resSL M f) : ℍ → ℂ) = f := rfl
+
+end Level
+
+section Weight
+
+variable {M : ℕ} [NeZero M] {k : ℤ}
+
+omit [NeZero M] in
+theorem apply_smul (f : ModularForm Γ₁(M) k) {g : SL(2, ℤ)} (hg : g ∈ Gamma1 M) (τ : ℍ) :
+    f (g • τ) = denom (g : GL (Fin 2) ℝ) τ ^ k * f τ := by
+  have :=
+    SlashInvariantForm.slash_action_eqn'' f (Subgroup.mem_map_of_mem
+      (Matrix.SpecialLinearGroup.mapGL ℝ) hg) τ
+  rw [ModularGroup.sl_moeb]
+  exact this
+
+theorem disc_smul (α : SL(2, ℤ)) (τ : ℍ) :
+    Δ (α • τ) = denom (α : GL (Fin 2) ℝ) τ ^ (12 : ℤ) * Δ τ := by
+  have := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant (Γ := 𝒮ℒ)
+    (γ := (α : GL (Fin 2) ℝ)) ⟨α, rfl⟩ τ
+  rw [CuspForm.coe_discriminant, ← ModularGroup.sl_moeb] at this
+  exact this
+
+theorem levelOne_smul {k' : ℤ} (E : ModularForm 𝒮ℒ k') (α : SL(2, ℤ)) (τ : ℍ) :
+    E (α • τ) = denom (α : GL (Fin 2) ℝ) τ ^ k' * E τ := by
+  have := SlashInvariantForm.slash_action_eqn'' E (Γ := 𝒮ℒ) (γ := (α : GL (Fin 2) ℝ)) ⟨α, rfl⟩ τ
+  rw [← ModularGroup.sl_moeb] at this
+  exact this
+
+theorem levelOne_slash {k' : ℤ} (E : ModularForm 𝒮ℒ k') (α : SL(2, ℤ)) :
+    (⇑E : ℍ → ℂ) ∣[k'] α = ⇑E := by
+  rw [ModularForm.SL_slash]
+  exact SlashInvariantFormClass.slash_action_eq E _ ⟨α, rfl⟩
+
+theorem isRat_slash_mul (f : ModularForm Γ₁(M) k) (m : ℕ) {kE : ℤ} (E : ModularForm 𝒮ℒ kE)
+    (hkE : k + kE = 12 * m) (hf : IsRat (qExpansion 1 f)) (hE : IsRat (qExpansion 1 E))
+    {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 M) :
+    IsRat (qExpansion 1 (((⇑f : ℍ → ℂ) ∣[k] γ) * ⇑E)) := by
+  set H : ℍ → ℂ := (⇑f : ℍ → ℂ) * ⇑E with hH
+  set G : ℍ → ℂ := fun τ => H τ / (Δ τ) ^ m with hG
+  have hΔ : ∀ τ : ℍ, (Δ τ) ^ m ≠ 0 := fun τ => pow_ne_zero _ (discriminant_ne_zero τ)
+  have hGΔ : G * Δ ^ m = H := by
+    funext τ; simp only [Pi.mul_apply, Pi.pow_apply, hG]; field_simp [hΔ τ]
+  have hmdH : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) H := f.holo'.mul E.holo'
+  have hmdΔ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (Δ : ℍ → ℂ) := by
+    rw [← CuspForm.coe_discriminant]; exact CuspForm.discriminant.holo'
+  have hmdG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G := by
+    intro τ
+    exact (hmdH τ).div ((hmdΔ τ).pow m) (hΔ τ)
+  have hcw : ∀ α : SL(2, ℤ), (fun τ => G (α • τ)) * Δ ^ m = ((⇑f : ℍ → ℂ) ∣[k] α) * ⇑E := by
+    intro α
+    funext τ
+    have hd : denom (α : GL (Fin 2) ℝ) τ ≠ 0 := denom_ne_zero _ τ
+    simp only [Pi.mul_apply, Pi.pow_apply, hG, hH]
+    rw [ModularForm.SL_slash_apply, disc_smul, levelOne_smul E, ModularGroup.sl_moeb]
+    have hpow : (denom (α : GL (Fin 2) ℝ) τ ^ (12 : ℤ) * Δ τ) ^ m
+        = denom (α : GL (Fin 2) ℝ) τ ^ (k + kE) * (Δ τ) ^ m := by
+      rw [mul_pow, ← zpow_natCast, ← zpow_mul, hkE]
+    rw [hpow, zpow_add₀ hd, zpow_neg]
+    field_simp [hΔ τ, zpow_ne_zero k hd, zpow_ne_zero kE hd]
+  have hinv : ∀ g ∈ Gamma1 M, ∀ τ : ℍ, G (g • τ) = G τ := by
+    intro g hg τ
+    have h1 := congrFun (hcw g) τ
+    simp only [Pi.mul_apply, Pi.pow_apply] at h1
+    have h2 : ((⇑f : ℍ → ℂ) ∣[k] g) = ⇑f := by
+      rw [ModularForm.SL_slash]
+      exact SlashInvariantFormClass.slash_action_eq f _ (Subgroup.mem_map_of_mem _ hg)
+    rw [h2] at h1
+    have h3 : G τ * Δ τ ^ m = f τ * E τ := by
+      have := congrFun hGΔ τ; first | exact this
+    exact mul_right_cancel₀ (hΔ τ) (h1.trans h3.symm)
+  have hbd : ∀ α : SL(2, ℤ), IsBoundedAtImInfty ((fun τ => G (α • τ)) * Δ ^ m) := by
+    intro α
+    rw [hcw α]
+    exact (isBoundedAtImInfty_slash f α).mul (ModularFormClass.bdd_at_infty E)
+  have hrat : ∀ n, ∃ r : ℚ, (qExpansion 1 (G * Δ ^ m)).coeff n = (r : ℂ) := by
+    rw [hGΔ, hH]
+    have : qExpansion 1 ((⇑f : ℍ → ℂ) * ⇑E) = qExpansion 1 ⇑f * qExpansion 1 ⇑(resSL M E) := by
+      rw [← coe_resSL M E, ModularForm.qExpansion_mul_coe one_pos (one_mem_strictPeriods M) f (resSL
+        M E)]
+    rw [this]
+    exact hf.mul hE
+  have key :=
+    ModularCurve.exists_ratCast_qExpansion_comp_smul_of_mem_Gamma0 M m G hmdG hinv hbd hrat γ hγ
+  rw [hcw γ] at key
+  exact key
+
+end Weight
+
+section Even
+
+variable {M : ℕ} [NeZero M] {k : ℤ}
+
+theorem isRat_E4 : IsRat (qExpansion 1 (E₄ : ℍ → ℂ)) := by
+  intro n
+  rw [ModularForm.E₄, EisensteinSeries.E_qExpansion_coeff (by norm_num) (by decide) n]
+  split_ifs
+  · exact ⟨1, by simp⟩
+  · exact ⟨-(2 * 4 / bernoulli 4) * (ArithmeticFunction.sigma 3 n : ℚ), by push_cast; ring⟩
+
+theorem isRat_E6 : IsRat (qExpansion 1 (E₆ : ℍ → ℂ)) := by
+  intro n
+  rw [ModularForm.E₆, EisensteinSeries.E_qExpansion_coeff (by norm_num) (by decide) n]
+  split_ifs
+  · exact ⟨1, by simp⟩
+  · exact ⟨-(2 * 6 / bernoulli 6) * (ArithmeticFunction.sigma 5 n : ℚ), by push_cast; ring⟩
+
+theorem constantCoeff_E4 : PowerSeries.constantCoeff (qExpansion 1 (E₄ : ℍ → ℂ)) = 1 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff_apply, ModularForm.E₄,
+    EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) (by decide)]
+
+theorem constantCoeff_E6 : PowerSeries.constantCoeff (qExpansion 1 (E₆ : ℍ → ℂ)) = 1 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff_apply, ModularForm.E₆,
+    EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) (by decide)]
+
+def Eaux (a b : ℕ) : ModularForm 𝒮ℒ (a * 4 + b * 6) := (E₄.pow a).mul (E₆.pow b)
+
+theorem coe_Eaux (a b : ℕ) : (⇑(Eaux a b) : ℍ → ℂ) = (⇑E₄) ^ a * (⇑E₆) ^ b := by
+  rw [Eaux, coe_mul, coe_pow, coe_pow]
+
+theorem qExpansion_Eaux (a b : ℕ) :
+    qExpansion 1 (⇑(Eaux a b)) = qExpansion 1 ⇑E₄ ^ a * qExpansion 1 ⇑E₆ ^ b := by
+  rw [Eaux, coe_mul, ModularForm.qExpansion_mul_coe one_pos one_mem_strictPeriods_SL,
+    ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL,
+    ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+
+theorem isRat_Eaux (a b : ℕ) : IsRat (qExpansion 1 (⇑(Eaux a b))) := by
+  rw [qExpansion_Eaux]; exact (isRat_E4.pow a).mul (isRat_E6.pow b)
+
+theorem constantCoeff_Eaux (a b : ℕ) :
+    PowerSeries.constantCoeff (qExpansion 1 (⇑(Eaux a b))) = 1 := by
+  rw [qExpansion_Eaux, map_mul, map_pow, map_pow, constantCoeff_E4, constantCoeff_E6, one_pow,
+    one_pow,
+    one_mul]
+
+theorem exists_weights (hk : Even k) : ∃ (m a b : ℕ), k + (a * 4 + b * 6 : ℕ) = 12 * (m : ℤ) := by
+  obtain ⟨j, rfl⟩ := hk
+  have hjabs : j ≤ (j.natAbs : ℤ) := Int.le_natAbs
+  have hjabs' : -j ≤ (j.natAbs : ℤ) := by
+    have := Int.le_natAbs (a := -j); rwa [Int.natAbs_neg] at this
+  rcases Int.emod_two_eq_zero_or_one j with hpar | hpar
+  · set q : ℤ := j / 2 with hq
+    have hjq : j = 2 * q := by omega
+    have h0 : 0 ≤ 3 * (j.natAbs : ℤ) + 3 - q := by omega
+    obtain ⟨a, ha⟩ := Int.eq_ofNat_of_zero_le h0
+    refine ⟨j.natAbs + 1, a, 0, ?_⟩
+    simp only [Nat.cast_add, Nat.cast_mul, Nat.cast_ofNat, Nat.cast_one, ← ha]
+    omega
+  · set q : ℤ := j / 2 with hq
+    have hjq : j = 2 * q + 1 := by omega
+    have h0 : 0 ≤ 3 * (j.natAbs : ℤ) + 1 - q := by omega
+    obtain ⟨a, ha⟩ := Int.eq_ofNat_of_zero_le h0
+    refine ⟨j.natAbs + 1, a, 1, ?_⟩
+    simp only [Nat.cast_add, Nat.cast_mul, Nat.cast_ofNat, Nat.cast_one, ← ha]
+    omega
+
+theorem isRat_slash_of_even (hk : Even k) (f : ModularForm Γ₁(M) k) (hf : IsRat (qExpansion 1 f))
+    {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 M) : IsRat (qExpansion 1 ((⇑f : ℍ → ℂ) ∣[k] γ)) := by
+  obtain ⟨m, a, b, hw⟩ := exists_weights hk
+  have key := isRat_slash_mul f m (Eaux a b) (by exact_mod_cast hw) hf (isRat_Eaux a b) hγ
+  have hprod : qExpansion 1 (((⇑f : ℍ → ℂ) ∣[k] γ) * ⇑(Eaux a b))
+      = qExpansion 1 ((⇑f : ℍ → ℂ) ∣[k] γ) * qExpansion 1 ⇑(Eaux a b) := by
+    rw [← coe_diamondSlash γ hγ f, ← coe_resSL M (Eaux a b),
+      ModularForm.qExpansion_mul_coe one_pos (one_mem_strictPeriods M) (diamondSlash γ hγ f)
+        (resSL M (Eaux a b))]
+  exact IsRat.of_mul_eq (isRat_Eaux a b) (constantCoeff_Eaux a b) key hprod.symm
+
+end Even
+
+section Odd
+
+theorem exists_E1 : ∃ E : ModularForm Γ₁(3) 1,
+    IsRat (qExpansion 1 E) ∧ PowerSeries.constantCoeff (qExpansion 1 (E : ℍ → ℂ)) = 1 := by
+  obtain ⟨E, hE⟩ := EisensteinWeightOne.e1Chi3IsModular
+  refine ⟨E, ?_⟩
+  set c : ℕ → ℤ := fun n => PowerSeries.coeff n EisensteinWeightOne.e1Chi3 with hc
+  have hchi : ∀ d : ℕ, |EisensteinWeightOne.chiNegThree d| ≤ 1 := by
+    intro d
+    unfold EisensteinWeightOne.chiNegThree
+    split_ifs <;> simp
+  have hcbound : ∀ n : ℕ, ‖((c n : ℤ) : ℂ)‖ ≤ 6 * n + 1 := by
+    intro n
+    rw [Complex.norm_intCast]
+    simp only [hc, EisensteinWeightOne.e1Chi3, PowerSeries.coeff_mk]
+    split_ifs with h0
+    · subst h0; simp
+    · have h1 : |EisensteinWeightOne.sigmaChi n| ≤ n := by
+        unfold EisensteinWeightOne.sigmaChi
+        calc |∑ d ∈ n.divisors, EisensteinWeightOne.chiNegThree d|
+            ≤ ∑ d ∈ n.divisors, |EisensteinWeightOne.chiNegThree d| := Finset.abs_sum_le_sum_abs _ _
+          _ ≤ ∑ _d ∈ n.divisors, (1 : ℤ) := Finset.sum_le_sum fun d _ => hchi d
+          _ = n.divisors.card := by simp
+          _ ≤ n := by exact_mod_cast Nat.card_divisors_le_self n
+      have h2 : |6 * EisensteinWeightOne.sigmaChi n| ≤ 6 * (n : ℤ) + 1 := by
+        rw [abs_mul, abs_of_nonneg (by norm_num : (0:ℤ) ≤ 6)]; linarith
+      rw [← Int.cast_abs]
+      exact_mod_cast h2
+  have hsum : ∀ z : ℍ, HasSum (fun n : ℕ => ((c n : ℤ) : ℂ) • Periodic.qParam 1 z ^ n) (E z) := by
+    intro z
+    have hq : ‖Periodic.qParam 1 z‖ < 1 := by
+      have : 0 < 2 * π * z.im / 1 := by have := z.im_pos; positivity
+      simpa [Periodic.qParam, Complex.norm_exp, neg_div] using this
+    have hterm : ∀ n : ℕ, ((c n : ℤ) : ℂ) * Complex.exp (2 * (Real.pi : ℂ) * Complex.I * (n : ℂ) *
+      (z : ℂ))
+        = ((c n : ℤ) : ℂ) • Periodic.qParam 1 z ^ n := by
+      intro n
+      rw [smul_eq_mul, Periodic.qParam, ← Complex.exp_nat_mul]
+      congr 2
+      push_cast
+      ring
+    have hS : Summable (fun n : ℕ => ((c n : ℤ) : ℂ) • Periodic.qParam 1 z ^ n) := by
+      apply Summable.of_norm_bounded (g := fun n : ℕ => (6 * n + 1) * ‖Periodic.qParam 1 z‖ ^ n)
+      · have h1 :=
+          summable_pow_mul_geometric_of_norm_lt_one 1 (r := ‖Periodic.qParam 1 z‖) (by
+            simpa using hq)
+        have h2 :=
+          summable_geometric_of_norm_lt_one (R := ℝ) (by
+            simpa using hq : ‖‖Periodic.qParam 1 z‖‖ < 1)
+        have := (h1.mul_left 6).add h2
+        refine this.congr fun n => ?_
+        simp only [pow_one]; ring
+      · intro n
+        rw [norm_smul, norm_pow]
+        exact mul_le_mul_of_nonneg_right (hcbound n) (pow_nonneg (norm_nonneg _) _)
+    have := hS.hasSum
+    have hEz : (∑' n : ℕ, ((c n : ℤ) : ℂ) • Periodic.qParam 1 z ^ n) = E z := by
+      rw [hE z]; exact tsum_congr fun n => (hterm n).symm
+    rwa [hEz] at this
+  have hcoef : ∀ n, ((c n : ℤ) : ℂ) = (qExpansion 1 (E : ℍ → ℂ)).coeff n := fun n =>
+    ModularFormClass.qExpansion_coeff_unique one_pos (one_mem_strictPeriods 3) hsum n
+  refine ⟨fun n => ⟨(c n : ℚ), by rw [← hcoef n]; push_cast; rfl⟩, ?_⟩
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff_apply, ← hcoef 0]
+  simp [hc, EisensteinWeightOne.e1Chi3]
+
+variable {M : ℕ} [NeZero M] {k : ℤ}
+
+theorem slash_of_neg_mem {L : ℕ} {w : ℤ} (F : ModularForm Γ₁(L) w) {g : SL(2, ℤ)}
+    (hg : -g ∈ Gamma1 L) : (⇑F : ℍ → ℂ) ∣[w] g = ((-1 : ℂ) ^ w) • (⇑F : ℍ → ℂ) := by
+  have h1 : (⇑F : ℍ → ℂ) ∣[w] (-g) = ⇑F := by
+    rw [ModularForm.SL_slash]
+    exact SlashInvariantFormClass.slash_action_eq F _ (Subgroup.mem_map_of_mem _ hg)
+  have hneg : (⇑F : ℍ → ℂ) ∣[w] (-1 : SL(2, ℤ)) = ((-1 : ℂ) ^ w) • (⇑F : ℍ → ℂ) := by
+    funext τ
+    rw [ModularForm.SL_slash_apply, Pi.smul_apply, smul_eq_mul]
+    have hτ : (-1 : SL(2, ℤ)) • τ = τ := by rw [ModularGroup.SL_neg_smul, one_smul]
+    have hd : denom ((-1 : SL(2, ℤ)) : GL (Fin 2) ℝ) τ = -1 := by
+      rw [ModularGroup.denom_apply]
+      simp [Matrix.SpecialLinearGroup.coe_neg]
+    rw [hτ, hd, mul_comm]
+    congr 1
+    rw [zpow_neg, ← inv_zpow, inv_neg, inv_one]
+  calc (⇑F : ℍ → ℂ) ∣[w] g = (⇑F : ℍ → ℂ) ∣[w] ((-1 : SL(2, ℤ)) * (-g)) := by rw [neg_one_mul,
+    neg_neg]
+    _ = ((⇑F : ℍ → ℂ) ∣[w] (-1 : SL(2, ℤ))) ∣[w] (-g) := SlashAction.slash_mul _ _ _ _
+    _ = (((-1 : ℂ) ^ w) • (⇑F : ℍ → ℂ)) ∣[w] (-g) := by rw [hneg]
+    _ = ((-1 : ℂ) ^ w) • ((⇑F : ℍ → ℂ) ∣[w] (-g)) := by rw [ModularForm.SL_smul_slash]
+    _ = ((-1 : ℂ) ^ w) • (⇑F : ℍ → ℂ) := by rw [h1]
+
+omit [NeZero M] in
+theorem isCoprime_entry {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 M) : IsCoprime (γ 1 1 : ℤ) (M : ℤ) := by
+  have hc : ((γ 1 0 : ℤ) : ZMod M) = 0 := Gamma0_mem.mp hγ
+  obtain ⟨c', hc'⟩ := (ZMod.intCast_zmod_eq_zero_iff_dvd _ M).mp hc
+  have h1 : (γ 0 0 : ℤ) * γ 1 1 - γ 0 1 * γ 1 0 = 1 := by
+    have := γ.det_coe; rwa [Matrix.det_fin_two] at this
+  refine ⟨γ 0 0, -(γ 0 1 * c'), ?_⟩
+  rw [hc'] at h1
+  linear_combination h1
+
+omit [NeZero M] in
+theorem exists_lift (d : ℤ) (hd : IsCoprime d (M : ℤ)) :
+    ∃ d' : ℤ, IsCoprime d' (3 * M : ℤ) ∧ (∃ t : ℤ, d' = d + t * M) ∧ ((3 : ℤ) ∣ M ∨ (3 : ℤ) ∣ d' -
+      1) := by
+  by_cases h3 : (3 : ℤ) ∣ M
+  · refine ⟨d, ?_, ⟨0, by ring⟩, Or.inl h3⟩
+    exact IsCoprime.mul_right (hd.of_isCoprime_of_dvd_right h3) hd
+  · have hM3 : IsCoprime (M : ℤ) 3 := by
+      have : Nat.Coprime M 3 := (Nat.Prime.coprime_iff_not_dvd Nat.prime_three).mpr
+        (fun h => h3 (by exact_mod_cast h)) |>.symm
+      exact this.isCoprime
+    obtain ⟨u, v, huv⟩ := hM3
+    refine ⟨d + (1 - d) * u * M, ?_, ⟨(1 - d) * u, by ring⟩, Or.inr ?_⟩
+    · apply IsCoprime.mul_right
+      · have : d + (1 - d) * u * M = 1 + 3 * (-(1 - d) * v) := by linear_combination (1 - d) * huv
+        rw [this]
+        exact (isCoprime_one_left.add_mul_left_left _)
+      · exact hd.add_mul_right_left _
+    · exact ⟨-(1 - d) * v, by linear_combination (1 - d) * huv⟩
+
+theorem isRat_slash_of_odd (hk : Odd k) (f : ModularForm Γ₁(M) k) (hf : IsRat (qExpansion 1 f))
+    {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 M) : IsRat (qExpansion 1 ((⇑f : ℍ → ℂ) ∣[k] γ)) := by
+  obtain ⟨E, hE, hE0⟩ := exists_E1
+  have : NeZero (3 * M) := ⟨mul_ne_zero three_ne_zero (NeZero.ne M)⟩
+  obtain ⟨d', hcop, ⟨t, ht⟩, h3⟩ := exists_lift (M := M) (γ 1 1) (isCoprime_entry hγ)
+  obtain ⟨x, y, hxy⟩ := hcop
+  set γ' : SL(2, ℤ) := ⟨!![x, -y; 3 * M, d'], by
+    rw [Matrix.det_fin_two_of]; linear_combination hxy⟩ with hγ'
+  have hγ'11 : (γ' 1 1 : ℤ) = d' := by simp [hγ']
+  have hγ'10 : (γ' 1 0 : ℤ) = 3 * M := by simp [hγ']
+  have hγ'00 : (γ' 0 0 : ℤ) = x := by simp [hγ']
+  have hγ'3M : γ' ∈ Gamma0 (3 * M) := by
+    rw [Gamma0_mem, hγ'10]; push_cast; exact ZMod.natCast_self (3 * M) ▸ by push_cast; ring_nf
+  have hγ'M : γ' ∈ Gamma0 M := Gamma0_le_of_dvd (dvd_mul_left M 3) hγ'3M
+  have hγ'3 : γ' ∈ Gamma0 3 := Gamma0_le_of_dvd (dvd_mul_right 3 M) hγ'3M
+  have hentry : ((γ 1 1 : ℤ) : ZMod M) = ((γ' 1 1 : ℤ) : ZMod M) := by
+    rw [hγ'11, ht]; push_cast; simp
+  have hfγ : (⇑f : ℍ → ℂ) ∣[k] γ = (⇑f : ℍ → ℂ) ∣[k] γ' := slash_eq_of_apply_eq f hγ hγ'M hentry
+  obtain ⟨ε, hε, hEγ⟩ : ∃ ε : ℚ, ε * ε = 1 ∧ (⇑E : ℍ → ℂ) ∣[(1 : ℤ)] γ' = (ε : ℂ) • (⇑E : ℍ → ℂ) :=
+    by
+    have h3z : (3 : ZMod 3) = 0 := by decide
+    have hxd : ((x : ℤ) : ZMod 3) * ((d' : ℤ) : ZMod 3) = 1 := by
+      have := congrArg (Int.cast : ℤ → ZMod 3) hxy
+      push_cast at this
+      rw [h3z] at this
+      simpa using this
+    rcases h3 with h3 | h3
+    · have hd3 : ((d' : ℤ) : ZMod 3) = 1 ∨ ((d' : ℤ) : ZMod 3) = -1 := by
+        have hne : ((d' : ℤ) : ZMod 3) ≠ 0 := by
+          intro h0; rw [h0, mul_zero] at hxd; exact zero_ne_one hxd
+        revert hne; generalize ((d' : ℤ) : ZMod 3) = e; decide +revert
+      rcases hd3 with hd3 | hd3
+      · refine ⟨1, by norm_num, ?_⟩
+        have hmem : γ' ∈ Gamma1 3 := by
+          rw [Gamma1_mem, hγ'11, hγ'00, hγ'10]
+          refine ⟨?_, hd3, by push_cast; rw [h3z, zero_mul]⟩
+          rw [hd3, mul_one] at hxd; exact hxd
+        have hEinv : (⇑E : ℍ → ℂ) ∣[(1 : ℤ)] γ' = ⇑E := by
+          rw [ModularForm.SL_slash]
+          exact SlashInvariantFormClass.slash_action_eq E _ (Subgroup.mem_map_of_mem _ hmem)
+        rw [hEinv]; push_cast; rw [one_smul]
+      · refine ⟨-1, by norm_num, ?_⟩
+        have hmem : -γ' ∈ Gamma1 3 := by
+          rw [Gamma1_mem]
+          simp only [Matrix.SpecialLinearGroup.coe_neg, Matrix.neg_apply, Int.cast_neg, hγ'11,
+            hγ'00, hγ'10]
+          refine ⟨?_, by rw [hd3, neg_neg], by push_cast; rw [h3z, zero_mul, neg_zero]⟩
+          rw [hd3, mul_neg, mul_one] at hxd
+          exact hxd
+        rw [slash_of_neg_mem E hmem]
+        push_cast; norm_num
+    · refine ⟨1, by norm_num, ?_⟩
+      have hd3 : ((d' : ℤ) : ZMod 3) = 1 := by
+        obtain ⟨w, hw⟩ := h3
+        have : d' = 1 + 3 * w := by linear_combination hw
+        rw [this]; push_cast; rw [h3z]; ring
+      have hmem : γ' ∈ Gamma1 3 := by
+        rw [Gamma1_mem, hγ'11, hγ'00, hγ'10]
+        refine ⟨?_, hd3, by push_cast; rw [h3z, zero_mul]⟩
+        rw [hd3, mul_one] at hxd; exact hxd
+      have hEinv : (⇑E : ℍ → ℂ) ∣[(1 : ℤ)] γ' = ⇑E := by
+        rw [ModularForm.SL_slash]
+        exact SlashInvariantFormClass.slash_action_eq E _ (Subgroup.mem_map_of_mem _ hmem)
+      rw [hEinv]; push_cast; rw [one_smul]
+  set f3 : ModularForm Γ₁(3 * M) k := res (dvd_mul_left M 3) f with hf3
+  set E3 : ModularForm Γ₁(3 * M) 1 := res (dvd_mul_right 3 M) E with hE3
+  set F : ModularForm Γ₁(3 * M) (k + 1) := f3.mul E3 with hF
+  have hFrat : IsRat (qExpansion 1 F) := by
+    rw [hF, coe_mul, ModularForm.qExpansion_mul_coe one_pos (one_mem_strictPeriods (3 * M)) f3 E3]
+    exact hf.mul hE
+  have hk1 : Even (k + 1) := hk.add_one
+  have key := isRat_slash_of_even hk1 F hFrat hγ'3M
+  have hFγ : (⇑F : ℍ → ℂ) ∣[k + 1] γ' = ⇑(diamondSlash γ' hγ'3M f3) * ⇑(((ε : ℂ)) • E3) := by
+    rw [hF, coe_mul, ModularForm.mul_slash_SL2, coe_diamondSlash, FunLike.coe_smul, coe_res,
+      coe_res, hEγ]
+  rw [hFγ, ModularForm.qExpansion_mul_coe one_pos (one_mem_strictPeriods (3 * M)),
+    FunLike.coe_smul, ModularForm.qExpansion_smul one_pos (one_mem_strictPeriods (3 * M)),
+    coe_diamondSlash, coe_res, coe_res, ← hfγ] at key
+  have key' : IsRat (qExpansion 1 ((⇑f : ℍ → ℂ) ∣[k] γ) * qExpansion 1 ⇑E) := by
+    have heq : qExpansion 1 ((⇑f : ℍ → ℂ) ∣[k] γ) * qExpansion 1 ⇑E
+        = (ε : ℂ) • (qExpansion 1 ((⇑f : ℍ → ℂ) ∣[k] γ) * ((ε : ℂ) • qExpansion 1 ⇑E)) := by
+      rw [mul_smul_comm, smul_smul, ← Rat.cast_mul, hε, Rat.cast_one, one_smul]
+    rw [heq]
+    exact key.smul ε
+  exact IsRat.of_mul_eq hE hE0 key' rfl
+
+end Odd
+
+theorem isRat_slash {M : ℕ} [NeZero M] {k : ℤ} (f : ModularForm Γ₁(M) k)
+    (hf : IsRat (qExpansion 1 f))
+    {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 M) : IsRat (qExpansion 1 ((⇑f : ℍ → ℂ) ∣[k] γ)) := by
+  rcases Int.even_or_odd k with hk | hk
+  · exact isRat_slash_of_even hk f hf hγ
+  · exact isRat_slash_of_odd hk f hf hγ
+
+end X1DiamondRationalForms
+
+theorem solution (M : ℕ) [NeZero M] {k : ℤ}
+    (f : ModularForm (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) k)
+    (hf : ∀ n : ℕ, ∃ r : ℚ, (UpperHalfPlane.qExpansion 1 f).coeff n = (r : ℂ))
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) (n : ℕ) :
+    ∃ r : ℚ, (UpperHalfPlane.qExpansion 1 ((⇑f : UpperHalfPlane → ℂ) ∣[k] γ)).coeff n = (r : ℂ) :=
+  X1DiamondRationalForms.isRat_slash f hf hγ n
+
+end
+end S_ModularCurve_exists_ratCast_qExpansion_slash_of_mem_Gamma0
+end P2MW
+export P2MW.S_ModularCurve_exists_ratCast_qExpansion_slash_of_mem_Gamma0 (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups ModularForm in
+theorem ModularCurve.exists_ratCast_qExpansion_slash_of_mem_Gamma0 (M : ℕ) [NeZero M] {k : ℤ}
+    (f : ModularForm (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) k)
+    (hf : ∀ n : ℕ, ∃ r : ℚ, (UpperHalfPlane.qExpansion 1 f).coeff n = (r : ℂ))
+    (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M) (n : ℕ) :
+    ∃ r : ℚ, (UpperHalfPlane.qExpansion 1 ((⇑f : UpperHalfPlane → ℂ) ∣[k] γ)).coeff n = (r : ℂ) :=
+  solution M f hf γ hγ n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN.lean
new file mode 100644
index 0000000000..1414535c46
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN.lean
@@ -0,0 +1,1093 @@
+/-
+Based on Prove2Me node ModularCurve.exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN
+(e2c25097-0cf2-5506-9a1a-38d7e157e4ca) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 0e08f2e3-750d-5384-b621-db7aa5879427
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LevelNFunctionField
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Data.Int.Star
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_algHom_laurentSeries_qExpansion
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_exists_levelFraction_of_stable_family
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_modularity_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_orbit_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelN_structure_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# q-expansion field of X(Γ) embeds into level-M modular functions
+
+Theorem statement: `ModularCurve.exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN`
+(`e2c25097-0cf2-5506-9a1a-38d7e157e4ca`), by Claude, 2026-09-05.
+
+Proof: submission `0e08f2e3-750d-5384-b621-db7aa5879427`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M\ge 1$, let $\Gamma\le \mathrm{SL}(2,\mathbb{Z})$ be a subgroup containing the principal
+congruence subgroup $\Gamma(M)$ and the translation $T=\begin{pmatrix}1&1\\0&1\end{pmatrix}$, and
+let $\iota\colon\overline{\mathbb{Q}}\to\mathbb{C}$ be a ring homomorphism, where
+$\overline{\mathbb{Q}}=$ `AlgebraicClosure ℚ`. Let $A_M=$ [`ModularCurve.LevelN.ring
+M`](def/ModularCurve_LevelNFunctionField.html#L28) be the $\mathbb{C}$-subalgebra of
+$\mathbb{H}\to\mathbb{C}$ generated by $j=E_4^3/\Delta$ together with the functions `fricke M v` for
+the nonzero $v\in(\mathbb{Z}/M)^2$, and let $K$ be a field which is simultaneously a
+$\mathbb{C}$-algebra and an $A_M$-algebra compatibly, and is a fraction field of $A_M$. Write $F=$
+[`ModularCurve.laurentBaseChange`](def/ModularCurve_LaurentCoeff.html#L103) $\overline{\mathbb{Q}}$
+of [`ModularCurve.qExpFunctionFieldC ℚ Γ`](def/ModularCurve_X1.html#L101): the subfield of
+$\overline{\mathbb{Q}}((q))$ generated over $\overline{\mathbb{Q}}$ by the coefficientwise images of
+the subfield of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by the quotients $p_f/p_g$, for $f,g$
+modular forms of a common weight on $\Gamma$ (viewed in $\mathrm{GL}(2,\mathbb{R})$) with integral
+$q$-expansions $p_f,p_g$, $p_g\neq 0$. Then there is a ring homomorphism $\Phi\colon F\to K$ such
+that: $\Phi$ sends each constant $c\in\overline{\mathbb{Q}}$ to the image of $\iota(c)$ in $K$;
+every element of $F$ whose underlying Laurent series is
+[`ModularCurve.jqModC`](def/ModularCurve_JqCoeff.html#L15) over $\overline{\mathbb{Q}}$, namely
+$q^{-1}$ times the image of the integral power series $E_4^3\eta^{-24}$, is sent to the image of
+$j\in A_M$ in $K$; and the image of $\Phi$ is fixed by $\Gamma$ in the following sense: for every
+$\gamma\in\Gamma$, assuming $A_M$ is stable under $G\mapsto G(\gamma^{-1}\cdot{-})$, any
+$\mathbb{C}$-algebra automorphism $\varphi$ of $K$ acting on elements of $A_M$ by that substitution
+satisfies $\varphi(\Phi u)=\Phi u$ for all $u\in F$.
+
+This is the arithmetic specialisation step identifying the $q$-expansion function field of
+$X(\Gamma)$ with a subfield of the field $\mathbb{C}(X(M))=\mathbb{C}(j,f_v)$ of modular functions
+of level $M$, compatibly with $j$ and with the action of $\Gamma$ by fractional linear
+substitutions. It is used in the counting arguments that compare the number of fibres of `jqModC`,
+respectively places of the base-changed field, with the number of double cosets, and hence in the
+computation of degrees and indices for modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN
+
+
+open UpperHalfPlane Filter Topology Function
+open scoped MatrixGroups Manifold Real ModularForm
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "LevelN.ring LevelN.jGen IsIntegralQExp intSeriesC intSeriesC_zero \
+  intFormRatiosC qExpFunctionFieldC qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd \
+  qExpand_single algebraMap_apply_eq_single ofPowerSeries_coeff_of_neg jGen coeffMap \
+  coeffMap_coeff coeffMap_single coeffMap_coeffMap algebraMap_laurentSeries_eq_single coeffEmb \
+  laurentBaseChange jqModC map_jqModC LevelN.exists_algHom_laurentSeries_qExpansion"
+namespace LevelN
+p2m_export "ModularCurve.LevelN" "wp fricke jAnalytic generators ring jGen \
+  exists_algHom_laurentSeries_qExpansion"
+namespace QExpBridge
+p2m_open "ModularCurve.LevelN ModularCurve"
+
+section Toolkit
+
+variable {h : ℝ}
+
+structure Good (h : ℝ) (G : ℍ → ℂ) : Prop where
+  periodic : Periodic (G ∘ ofComplex) h
+  mdiff : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G
+  bdd : IsBoundedAtImInfty G
+
+namespace Good
+
+variable {G G₁ G₂ : ℍ → ℂ}
+
+theorem analyticAt (hG : Good h G) (hh : 0 < h) : AnalyticAt ℂ (cuspFunction h G) 0 :=
+  analyticAt_cuspFunction_zero hh hG.periodic hG.mdiff hG.bdd
+
+theorem continuousAt (hG : Good h G) (hh : 0 < h) : ContinuousAt (cuspFunction h G) 0 :=
+  (hG.analyticAt hh).continuousAt
+
+theorem mul (h₁ : Good h G₁) (h₂ : Good h G₂) : Good h (G₁ * G₂) where
+  periodic := by
+    have : (G₁ * G₂) ∘ ofComplex = (G₁ ∘ ofComplex) * (G₂ ∘ ofComplex) := rfl
+    rw [this]
+    exact h₁.periodic.mul h₂.periodic
+  mdiff := h₁.mdiff.mul h₂.mdiff
+  bdd := h₁.bdd.mul h₂.bdd
+
+theorem add (h₁ : Good h G₁) (h₂ : Good h G₂) : Good h (G₁ + G₂) where
+  periodic := by
+    have : (G₁ + G₂) ∘ ofComplex = (G₁ ∘ ofComplex) + (G₂ ∘ ofComplex) := rfl
+    rw [this]
+    exact h₁.periodic.add h₂.periodic
+  mdiff := h₁.mdiff.add h₂.mdiff
+  bdd := h₁.bdd.add h₂.bdd
+
+theorem const (h : ℝ) (c : ℂ) : Good h (fun _ : ℍ => c) where
+  periodic := fun _ => rfl
+  mdiff := mdifferentiable_const
+  bdd := Filter.const_boundedAtFilter _ _
+
+theorem one (h : ℝ) : Good h (1 : ℍ → ℂ) := const h 1
+
+theorem pow (hG : Good h G) : ∀ n : ℕ, Good h (G ^ n)
+  | 0 => by rw [pow_zero]; exact one h
+  | n + 1 => by rw [pow_succ]; exact (pow hG n).mul hG
+
+end Good
+
+variable {G G₁ G₂ : ℍ → ℂ}
+
+theorem cuspFunction_mul_of_good (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) :
+    cuspFunction h (G₁ * G₂) = cuspFunction h G₁ * cuspFunction h G₂ :=
+  cuspFunction_mul (h₁.continuousAt hh) (h₂.continuousAt hh)
+
+theorem cuspFunction_add_of_good (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) :
+    cuspFunction h (G₁ + G₂) = cuspFunction h G₁ + cuspFunction h G₂ :=
+  cuspFunction_add (h₁.continuousAt hh) (h₂.continuousAt hh)
+
+theorem qExpansion_mul_of_good (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) :
+    qExpansion h (G₁ * G₂) = qExpansion h G₁ * qExpansion h G₂ :=
+  qExpansion_mul (h₁.analyticAt hh) (h₂.analyticAt hh)
+
+theorem qExpansion_add_of_good (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) :
+    qExpansion h (G₁ + G₂) = qExpansion h G₁ + qExpansion h G₂ :=
+  qExpansion_add (h₁.analyticAt hh) (h₂.analyticAt hh)
+
+theorem qExpansion_pow_of_good (hh : 0 < h) (hG : Good h G) :
+    ∀ n : ℕ, qExpansion h (G ^ n) = qExpansion h G ^ n
+  | 0 => by rw [pow_zero, pow_zero, qExpansion_one]
+  | n + 1 => by rw [pow_succ, pow_succ, qExpansion_mul_of_good hh (hG.pow n) hG,
+      qExpansion_pow_of_good hh hG n]
+
+theorem qExpansion_const (hh : 0 < h) (c : ℂ) :
+    qExpansion h (fun _ : ℍ => c) = PowerSeries.C c := by
+  have h1 : (fun _ : ℍ => c) = c • (1 : ℍ → ℂ) := by funext τ; simp
+  rw [h1, qExpansion_smul ((Good.one h).analyticAt hh), qExpansion_one, Algebra.smul_def, mul_one]
+  simp
+
+theorem Good.eq_zero_of_qExpansion_eq_zero (hG : Good h G) (hh : 0 < h) (h0 : qExpansion h G = 0) :
+    G = 0 :=
+  (qExpansion_eq_zero_iff hh hG.periodic hG.mdiff hG.bdd).mp h0
+
+def Q (h : ℝ) (G : ℍ → ℂ) : LaurentSeries ℂ := HahnSeries.ofPowerSeries ℤ ℂ (qExpansion h G)
+
+theorem Q_mul (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) : Q h (G₁ * G₂) = Q h G₁ * Q h G₂ := by
+  simp only [Q, qExpansion_mul_of_good hh h₁ h₂, map_mul]
+
+theorem Q_add (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) : Q h (G₁ + G₂) = Q h G₁ + Q h G₂ := by
+  simp only [Q, qExpansion_add_of_good hh h₁ h₂, map_add]
+
+theorem Q_pow (hh : 0 < h) (hG : Good h G) (n : ℕ) : Q h (G ^ n) = Q h G ^ n := by
+  simp only [Q, qExpansion_pow_of_good hh hG n, map_pow]
+
+theorem Q_one (h : ℝ) : Q h (1 : ℍ → ℂ) = 1 := by
+  simp only [Q, qExpansion_one, map_one]
+
+theorem Q_const (hh : 0 < h) (c : ℂ) : Q h (fun _ : ℍ => c) = HahnSeries.C c := by
+  simp only [Q, qExpansion_const hh c, HahnSeries.ofPowerSeries_C]
+
+theorem Q_eq_zero_iff (hh : 0 < h) (hG : Good h G) : Q h G = 0 ↔ G = 0 := by
+  constructor
+  · intro h0
+    apply hG.eq_zero_of_qExpansion_eq_zero hh
+    have : Function.Injective (HahnSeries.ofPowerSeries ℤ ℂ) := HahnSeries.ofPowerSeries_injective
+    exact this (by rw [map_zero]; exact h0)
+  · rintro rfl
+    simp only [Q, qExpansion_zero, map_zero]
+
+end Toolkit
+
+section LevelOne
+
+local notation "Δ" => ModularForm.discriminant
+
+theorem natCast_mem_strictPeriods (N : ℕ) : (N : ℝ) ∈ (𝒮ℒ).strictPeriods := by
+  simp only [Subgroup.strictPeriods_SL2Z]
+  exact ⟨N, by simp⟩
+
+theorem good_discriminant (N : ℕ) : Good N Δ where
+  periodic := by
+    have := SlashInvariantFormClass.periodic_comp_ofComplex CuspForm.discriminant
+      (natCast_mem_strictPeriods N)
+    simpa using this
+  mdiff := CuspForm.discriminant.holo'
+  bdd := ModularForm.discriminant_isZeroAtImInfty.isBoundedAtImInfty
+
+theorem good_E₄ (N : ℕ) : Good N (ModularForm.E₄ : ℍ → ℂ) where
+  periodic := SlashInvariantFormClass.periodic_comp_ofComplex ModularForm.E₄
+      (natCast_mem_strictPeriods N)
+  mdiff := ModularForm.E₄.holo'
+  bdd := ModularFormClass.bdd_at_infty ModularForm.E₄
+
+theorem discriminant_ne_zero' : (Δ : ℍ → ℂ) ≠ 0 := by
+  intro h0
+  have := congrFun h0 UpperHalfPlane.I
+  exact ModularForm.discriminant_ne_zero _ this
+
+theorem discriminant_pow_ne_zero (m : ℕ) : ((Δ : ℍ → ℂ) ^ m) ≠ 0 := by
+  intro h0
+  have := congrFun h0 UpperHalfPlane.I
+  simp only [Pi.pow_apply, Pi.zero_apply, pow_eq_zero_iff', ne_eq] at this
+  exact ModularForm.discriminant_ne_zero _ this.1
+
+theorem mul_discriminant_pow_eq_zero_iff (F : ℍ → ℂ) (m : ℕ) :
+    F * (Δ : ℍ → ℂ) ^ m = 0 ↔ F = 0 := by
+  constructor
+  · intro h0
+    funext τ
+    have := congrFun h0 τ
+    simp only [Pi.mul_apply, Pi.pow_apply, Pi.zero_apply, mul_eq_zero, pow_eq_zero_iff',
+      ne_eq] at this
+    rcases this with h1 | ⟨h1, _⟩
+    · exact h1
+    · exact absurd h1 (ModularForm.discriminant_ne_zero τ)
+  · rintro rfl
+    exact zero_mul _
+
+theorem Q_discriminant_ne_zero (N : ℕ) [NeZero N] : Q N (Δ : ℍ → ℂ) ≠ 0 := by
+  have hN : (0 : ℝ) < N := Nat.cast_pos.mpr (NeZero.pos N)
+  rw [ne_eq, Q_eq_zero_iff hN (good_discriminant N)]
+  exact discriminant_ne_zero'
+
+end LevelOne
+
+section Ring
+
+local notation "Δ" => ModularForm.discriminant
+
+variable (N : ℕ) [NeZero N]
+
+theorem mdifferentiable_of_mem {F : ℍ → ℂ} (hF : F ∈ ring N) : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F := by
+  have h := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact h.2.2.2.2.1 F hF
+
+theorem eq_zero_or_eq_zero_of_mul_eq_zero {a b : ℍ → ℂ} (ha : a ∈ ring N) (hb : b ∈ ring N)
+    (hab : a * b = 0) : a = 0 ∨ b = 0 := by
+  have h := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact h.2.2.2.2.2 a b ha hb hab
+
+abbrev redMat (γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) (ZMod N) :=
+  (γ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N)
+
+theorem fricke_smul_of_mem (v : Fin 2 → ZMod N) {γ : SL(2, ℤ)}
+    (hγ : γ ∈ CongruenceSubgroup.Gamma N) (τ : ℍ) : fricke N v (γ • τ) = fricke N v τ :=
+  (WLight.frickeFunction_modularity_package N PeriodPair.ofTau (fun _ => ⟨rfl, rfl⟩)).2.2.2.2.2.2.1
+    v γ hγ τ
+
+omit [NeZero N] in
+theorem jAnalytic_smul (γ : SL(2, ℤ)) (τ : ℍ) : jAnalytic (γ • τ) = jAnalytic τ := by
+  have hmem : (γ : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ, rfl⟩
+  have h4 : (ModularForm.E₄ : ℍ → ℂ) ((γ : GL (Fin 2) ℝ) • τ) =
+      denom (γ : GL (Fin 2) ℝ) τ ^ (4 : ℤ) * ModularForm.E₄ τ :=
+    SlashInvariantForm.slash_action_eqn'' _ hmem τ
+  have h12 : ModularForm.discriminant ((γ : GL (Fin 2) ℝ) • τ) =
+      denom (γ : GL (Fin 2) ℝ) τ ^ (12 : ℤ) * ModularForm.discriminant τ := by
+    have := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hmem τ
+    simpa using this
+  have hd : denom (γ : GL (Fin 2) ℝ) τ ≠ 0 := denom_ne_zero _ _
+  have hΔ : ModularForm.discriminant τ ≠ 0 := ModularForm.discriminant_ne_zero τ
+  rw [jAnalytic, jAnalytic, ModularGroup.sl_moeb, h4, h12]
+  field_simp
+
+def precomp (g : SL(2, ℤ)) : (ℍ → ℂ) →ₐ[ℂ] (ℍ → ℂ) :=
+  AlgHom.pi (fun τ => Pi.evalAlgHom ℂ (fun _ : ℍ => ℂ) (g • τ))
+
+omit [NeZero N] in
+@[scoped simp]
+theorem precomp_apply (g : SL(2, ℤ)) (F : ℍ → ℂ) (τ : ℍ) : precomp g F τ = F (g • τ) := rfl
+
+theorem smul_eq_self_of_mem {F : ℍ → ℂ} (hF : F ∈ ring N) {γ : SL(2, ℤ)}
+    (hγ : γ ∈ CongruenceSubgroup.Gamma N) (τ : ℍ) : F (γ • τ) = F τ := by
+  suffices h : ring N ≤ AlgHom.equalizer (precomp γ) (AlgHom.id ℂ (ℍ → ℂ)) by
+    have := h hF
+    rw [AlgHom.mem_equalizer] at this
+    exact congrFun this τ
+  rw [ring, Algebra.adjoin_le_iff]
+  intro G hG
+  rw [SetLike.mem_coe, AlgHom.mem_equalizer]
+  funext τ'
+  rcases hG with rfl | ⟨v, hv, rfl⟩
+  · exact jAnalytic_smul γ τ'
+  · exact fricke_smul_of_mem N v hγ τ'
+
+omit [NeZero N] in
+theorem T_pow_mem_Gamma : ModularGroup.T ^ N ∈ CongruenceSubgroup.Gamma N := by
+  rw [CongruenceSubgroup.Gamma_mem, ← zpow_natCast, ModularGroup.coe_T_zpow]
+  simp
+
+theorem periodic_of_mem {F : ℍ → ℂ} (hF : F ∈ ring N) : Periodic (F ∘ ofComplex) N := by
+  intro w
+  by_cases hw : 0 < w.im
+  · have hw' : 0 < (w + N).im := by simpa using hw
+    simp only [Function.comp_apply, ofComplex_apply_of_im_pos hw, ofComplex_apply_of_im_pos hw']
+    have hT : ModularGroup.T ^ N • (⟨w, hw⟩ : ℍ) = ⟨w + N, hw'⟩ := by
+      rw [← zpow_natCast, modular_T_zpow_smul]
+      ext1
+      simp [add_comm]
+    rw [← hT, smul_eq_self_of_mem N hF (T_pow_mem_Gamma N)]
+  · push Not at hw
+    have hw' : (w + N).im ≤ 0 := by simpa using hw
+    simp only [Function.comp_apply, ofComplex_apply_of_im_nonpos hw,
+      ofComplex_apply_of_im_nonpos hw']
+
+theorem exists_isBoundedAtImInfty_mul_pow {F : ℍ → ℂ} (hF : F ∈ ring N) :
+    ∃ m : ℕ, IsBoundedAtImInfty (F * (Δ : ℍ → ℂ) ^ m) := by
+  have hpkg := WLight.frickeFunction_orbit_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  have hΔb : ∀ k : ℕ, IsBoundedAtImInfty ((Δ : ℍ → ℂ) ^ k) := fun k =>
+    ((good_discriminant N).pow k).bdd
+  induction hF using Algebra.adjoin_induction with
+  | mem G hG =>
+    rcases hG with rfl | ⟨v, hv, rfl⟩
+    · exact hpkg.1.2
+    · exact (hpkg.2.1 v hv).2
+  | algebraMap c =>
+    refine ⟨0, ?_⟩
+    rw [pow_zero, mul_one]
+    exact Filter.const_boundedAtFilter _ _
+  | add F G _ _ ihF ihG =>
+    obtain ⟨m, hm⟩ := ihF
+    obtain ⟨n, hn⟩ := ihG
+    refine ⟨m + n, ?_⟩
+    have : (F + G) * (Δ : ℍ → ℂ) ^ (m + n) =
+        F * (Δ : ℍ → ℂ) ^ m * (Δ : ℍ → ℂ) ^ n + G * (Δ : ℍ → ℂ) ^ n * (Δ : ℍ → ℂ) ^ m := by ring
+    rw [this]
+    exact (hm.mul (hΔb n)).add (hn.mul (hΔb m))
+  | mul F G _ _ ihF ihG =>
+    obtain ⟨m, hm⟩ := ihF
+    obtain ⟨n, hn⟩ := ihG
+    refine ⟨m + n, ?_⟩
+    have : (F * G) * (Δ : ℍ → ℂ) ^ (m + n) = (F * (Δ : ℍ → ℂ) ^ m) * (G * (Δ : ℍ → ℂ) ^ n) := by
+      ring
+    rw [this]
+    exact hm.mul hn
+
+end Ring
+
+section Width
+
+variable (N : ℕ) [NeZero N]
+
+theorem qParam_pow_mul (τ : ℍ) (n : ℕ) :
+    Periodic.qParam (N : ℝ) (τ : ℂ) ^ (N * n) = Periodic.qParam 1 (τ : ℂ) ^ n := by
+  have hN : (N : ℂ) ≠ 0 := by exact_mod_cast NeZero.ne N
+  rw [pow_mul]
+  congr 1
+  rw [Periodic.qParam, Periodic.qParam, ← Complex.exp_nat_mul]
+  congr 1
+  push_cast
+  field_simp
+
+
+theorem Q_natCast_eq_qExpand {f : ℍ → ℂ} (hf : Good 1 f) :
+    Q N f = ModularCurve.qExpand ℂ N (Q 1 f) := by
+  have hNpos : (0 : ℝ) < N := Nat.cast_pos.mpr (NeZero.pos N)
+  have hN0 : (N : ℕ) ≠ 0 := NeZero.ne N
+  set a : ℕ → ℂ := fun m => (qExpansion 1 f).coeff m with ha
+  have hsum1 : ∀ τ : ℍ, HasSum (fun m => a m • Periodic.qParam 1 (τ : ℂ) ^ m) (f τ) :=
+    fun τ => hasSum_qExpansion one_pos hf.periodic hf.mdiff hf.bdd τ
+  have hinj : Function.Injective (fun n : ℕ => N * n) := mul_right_injective₀ hN0
+  set c : ℕ → ℂ := Function.extend (fun n : ℕ => N * n) a 0 with hc
+  have hc_apply : ∀ n, c (N * n) = a n := fun n => hinj.extend_apply _ _ n
+  have hc_zero : ∀ m, (¬ ∃ n, N * n = m) → c m = 0 := fun m hm => by
+    rw [hc, Function.extend_apply' _ _ _ hm]; rfl
+  have hsumN : ∀ τ : ℍ, HasSum (fun m => c m • Periodic.qParam (N : ℝ) (τ : ℂ) ^ m) (f τ) := by
+    intro τ
+    have key : (fun m => c m • Periodic.qParam (N : ℝ) (τ : ℂ) ^ m) =
+        Function.extend (fun n : ℕ => N * n) (fun n => a n • Periodic.qParam 1 (τ : ℂ) ^ n) 0 := by
+      funext m
+      by_cases hm : ∃ n, N * n = m
+      · obtain ⟨n, rfl⟩ := hm
+        rw [hinj.extend_apply, hc_apply, qParam_pow_mul]
+      · rw [Function.extend_apply' _ _ _ hm, hc_zero m hm, zero_smul]; rfl
+    rw [key, hasSum_extend_zero hinj]
+    exact hsum1 τ
+  have hgoodN : Good N f :=
+    { periodic := by simpa using hf.periodic.nat_mul N
+      mdiff := hf.mdiff
+      bdd := hf.bdd }
+  have hcoeff : ∀ m, c m = (qExpansion N f).coeff m := by
+    have hsumN' : ∀ τ : ℍ, HasSum (fun m => (qExpansion N f).coeff m • Periodic.qParam (N : ℝ)
+      (τ : ℂ) ^ m) (f τ) :=
+      fun τ => hasSum_qExpansion hNpos hgoodN.periodic hgoodN.mdiff hgoodN.bdd τ
+    have h1 := (hasFPowerSeriesOnBall_cuspFunction hNpos
+      (hgoodN.analyticAt hNpos) hsumN).hasFPowerSeriesAt
+    have h2 := (hasFPowerSeriesOnBall_cuspFunction hNpos
+      (hgoodN.analyticAt hNpos) hsumN').hasFPowerSeriesAt
+    have heq := h1.eq_formalMultilinearSeries h2
+    have := (FormalMultilinearSeries.ofScalars_series_eq_iff (E := ℂ) c _).mp heq
+    exact fun m => congrFun this m
+  ext k
+  rw [Q, Q]
+  rcases lt_or_ge k 0 with hk | hk
+  · rw [ModularCurve.ofPowerSeries_coeff_of_neg _ hk]
+    by_cases hdvd : (N : ℤ) ∣ k
+    · obtain ⟨k', rfl⟩ := hdvd
+      rw [ModularCurve.qExpand_coeff_mul]
+      have hk' : k' < 0 := by
+        by_contra h; push Not at h
+        have : (0 : ℤ) ≤ (N : ℤ) * k' := mul_nonneg (by positivity) h
+        omega
+      rw [ModularCurve.ofPowerSeries_coeff_of_neg _ hk']
+    · rw [ModularCurve.qExpand_coeff_of_not_dvd N _ hdvd]
+  · lift k to ℕ using hk
+    rw [HahnSeries.ofPowerSeries_apply_coeff, ← hcoeff]
+    by_cases hdvd : (N : ℤ) ∣ (k : ℤ)
+    · obtain ⟨k', hk'⟩ := hdvd
+      have hk'0 : 0 ≤ k' := by
+        by_contra h; push Not at h
+        have : (N : ℤ) * k' < 0 := mul_neg_of_pos_of_neg (by exact_mod_cast NeZero.pos N) h
+        omega
+      lift k' to ℕ using hk'0
+      have hkk : k = N * k' := by exact_mod_cast hk'
+      rw [hk', ModularCurve.qExpand_coeff_mul, HahnSeries.ofPowerSeries_apply_coeff, hkk, hc_apply]
+    · rw [ModularCurve.qExpand_coeff_of_not_dvd N _ hdvd, hc_zero]
+      rintro ⟨n, hn⟩
+      exact hdvd ⟨n, by rw [← hn]; push_cast; ring⟩
+
+end Width
+
+section Forms
+
+local notation "Δ" => ModularForm.discriminant
+
+variable {Γ : Subgroup SL(2, ℤ)} {k : ℤ}
+
+abbrev den (γ : SL(2, ℤ)) (τ : ℍ) : ℂ := denom (γ : GL (Fin 2) ℝ) τ
+
+theorem den_ne_zero (γ : SL(2, ℤ)) (τ : ℍ) : den γ τ ≠ 0 := denom_ne_zero _ _
+
+theorem apply_smul_eq_slash (f : ℍ → ℂ) (γ : SL(2, ℤ)) (τ : ℍ) :
+    f (γ • τ) = (f ∣[k] γ) τ * den γ τ ^ k := by
+  rw [ModularForm.SL_slash_apply, mul_assoc, ← zpow_add₀ (den_ne_zero γ τ), neg_add_cancel,
+    zpow_zero, mul_one]
+
+theorem discriminant_smul (γ : SL(2, ℤ)) (τ : ℍ) : Δ (γ • τ) = den γ τ ^ (12 : ℤ) * Δ τ := by
+  have hmem : (γ : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ, rfl⟩
+  have := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hmem τ
+  simpa [ModularGroup.sl_moeb] using this
+
+theorem apply_smul_of_mem
+    (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) {δ : SL(2, ℤ)} (hδ : δ ∈ Γ)
+    (τ : ℍ) : f (δ • τ) = den δ τ ^ k * f τ := by
+  have hmem : (δ : GL (Fin 2) ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)) := ⟨δ, hδ, rfl⟩
+  have := SlashInvariantForm.slash_action_eqn'' f hmem τ
+  simpa [ModularGroup.sl_moeb] using this
+
+theorem one_mem_strictPeriods (hT : ModularGroup.T ∈ Γ) :
+    (1 : ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  rw [Subgroup.strictPeriods_eq_zmultiples_one_of_T_mem hT]
+  exact AddSubgroup.mem_zmultiples _
+
+theorem good_coe (hT : ModularGroup.T ∈ Γ) [Γ.FiniteIndex]
+    (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) : Good 1 (f : ℍ → ℂ) where
+  periodic := SlashInvariantFormClass.periodic_comp_ofComplex f (one_mem_strictPeriods hT)
+  mdiff := f.holo'
+  bdd := ModularFormClass.bdd_at_infty f
+
+theorem isBoundedAtImInfty_slash [Γ.FiniteIndex] (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (γ : SL(2, ℤ)) : IsBoundedAtImInfty ((f : ℍ → ℂ) ∣[k] γ) :=
+  ModularFormClass.bdd_at_infty_slash f γ
+
+end Forms
+
+section Quotients
+
+local notation "Δ" => ModularForm.discriminant
+
+def FF (k : ℤ) (f g : ℍ → ℂ) : ℍ → ℂ := fun τ => f τ * g τ ^ 11 * Δ τ ^ (-k)
+
+theorem FF_apply (k : ℤ) (f g : ℍ → ℂ) (τ : ℍ) : FF k f g τ = f τ * g τ ^ 11 * Δ τ ^ (-k) := rfl
+
+theorem zpow_neg_mul_pow_toNat (x : ℂ) (hx : x ≠ 0) (k : ℤ) :
+    x ^ (-k) * x ^ k.toNat = x ^ (-k).toNat := by
+  rw [← zpow_natCast, ← zpow_natCast, ← zpow_add₀ hx]
+  congr 1
+  have := Int.toNat_sub_toNat_neg k
+  omega
+
+theorem FF_mul_pow (k : ℤ) (f g : ℍ → ℂ) :
+    FF k f g * (Δ : ℍ → ℂ) ^ k.toNat = f * g ^ 11 * (Δ : ℍ → ℂ) ^ (-k).toNat := by
+  funext τ
+  simp only [Pi.mul_apply, Pi.pow_apply, FF_apply]
+  rw [mul_assoc, zpow_neg_mul_pow_toNat _ (ModularForm.discriminant_ne_zero τ)]
+
+theorem mdifferentiable_discriminant : MDiff (Δ : ℍ → ℂ) := CuspForm.discriminant.holo'
+
+theorem mdifferentiable_discriminant_zpow (n : ℤ) : MDiff (fun τ : ℍ => Δ τ ^ n) := by
+  rw [UpperHalfPlane.mdifferentiable_iff]
+  have hd : DifferentiableOn ℂ ((Δ : ℍ → ℂ) ∘ ofComplex) {z : ℂ | 0 < z.im} :=
+    UpperHalfPlane.mdifferentiable_iff.mp mdifferentiable_discriminant
+  have : (fun τ : ℍ => Δ τ ^ n) ∘ ofComplex = fun z => ((Δ : ℍ → ℂ) ∘ ofComplex) z ^ n := rfl
+  rw [this]
+  exact hd.zpow (Or.inl fun z hz => by
+    rw [Function.comp_apply]; exact ModularForm.discriminant_ne_zero _)
+
+theorem mdifferentiable_FF
+    (k : ℤ) {f g : ℍ → ℂ} (hf : MDiff f) (hg : MDiff g) : MDiff (FF k f g) := by
+  have : FF k f g = f * g ^ 11 * (fun τ : ℍ => Δ τ ^ (-k)) := by
+    funext τ; simp [FF_apply]
+  rw [this]
+  exact (hf.mul (hg.pow 11)).mul (mdifferentiable_discriminant_zpow (-k))
+
+theorem factor_cancel (d : ℂ) (hd : d ≠ 0) (k : ℤ) :
+    d ^ k * (d ^ k) ^ 11 * (d ^ (12 : ℤ)) ^ (-k) = 1 := by
+  rw [← zpow_natCast (d ^ k) 11, ← zpow_mul, ← zpow_mul, ← zpow_add₀ hd, ← zpow_add₀ hd]
+  have : k + k * ((11 : ℕ) : ℤ) + 12 * -k = 0 := by push_cast; ring
+  rw [this, zpow_zero]
+
+theorem FF_smul (k : ℤ) (f g : ℍ → ℂ) (γ : SL(2, ℤ)) (τ : ℍ) :
+    FF k f g (γ • τ) = FF k (f ∣[k] γ) (g ∣[k] γ) τ := by
+  rw [FF_apply, FF_apply, apply_smul_eq_slash (k := k) f γ τ, apply_smul_eq_slash (k := k) g γ τ,
+    discriminant_smul γ τ]
+  have hd := den_ne_zero γ τ
+  set d := den γ τ
+  rw [mul_pow, mul_zpow]
+  have hc := factor_cancel d hd k
+  calc (f ∣[k] γ) τ * d ^ k * ((g ∣[k] γ) τ ^ 11 * (d ^ k) ^ 11)
+      * ((d ^ (12 : ℤ)) ^ (-k) * Δ τ ^ (-k))
+    = (f ∣[k] γ) τ * (g ∣[k] γ) τ ^ 11 * Δ τ ^ (-k)
+          * (d ^ k * (d ^ k) ^ 11 * (d ^ (12 : ℤ)) ^ (-k)) := by
+        ring
+    _ = (f ∣[k] γ) τ * (g ∣[k] γ) τ ^ 11 * Δ τ ^ (-k) := by rw [hc, mul_one]
+
+variable {Γ : Subgroup SL(2, ℤ)} {k : ℤ}
+
+theorem FF_smul_of_mem
+    (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) {δ : SL(2, ℤ)} (hδ : δ ∈ Γ)
+    (τ : ℍ) : FF k f g (δ • τ) = FF k f g τ := by
+  rw [FF_smul]
+  have hmem : (δ : GL (Fin 2) ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)) := ⟨δ, hδ, rfl⟩
+  have hf : (f : ℍ → ℂ) ∣[k] δ = f := by
+    rw [ModularForm.SL_slash]; exact SlashInvariantFormClass.slash_action_eq f _ hmem
+  have hg : (g : ℍ → ℂ) ∣[k] δ = g := by
+    rw [ModularForm.SL_slash]; exact SlashInvariantFormClass.slash_action_eq g _ hmem
+  rw [hf, hg]
+
+theorem isBoundedAtImInfty_FF_smul
+    [Γ.FiniteIndex] (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (γ : SL(2, ℤ)) : IsBoundedAtImInfty ((fun τ => FF k f g (γ • τ)) * (Δ : ℍ → ℂ) ^ k.toNat) := by
+  have : (fun τ => FF k f g (γ • τ)) = FF k ((f : ℍ → ℂ) ∣[k] γ) ((g : ℍ → ℂ) ∣[k] γ) := by
+    funext τ; exact FF_smul k f g γ τ
+  rw [this, FF_mul_pow]
+  have hg11 : IsBoundedAtImInfty (((g : ℍ → ℂ) ∣[k] γ) ^ 11) := by
+    have hb := isBoundedAtImInfty_slash g γ
+    have : ∀ n : ℕ, IsBoundedAtImInfty (((g : ℍ → ℂ) ∣[k] γ) ^ n) := by
+      intro n
+      induction n with
+      | zero => rw [pow_zero]; exact Filter.const_boundedAtFilter _ _
+      | succ n ih => rw [pow_succ]; exact ih.mul hb
+    exact this 11
+  exact ((isBoundedAtImInfty_slash f γ).mul hg11).mul (((good_discriminant 1).pow _).bdd)
+
+end Quotients
+
+section Family
+
+local notation "Δ" => ModularForm.discriminant
+
+variable (M : ℕ) [NeZero M]
+
+theorem castM_pos : (0 : ℝ) < M := Nat.cast_pos.mpr (NeZero.pos M)
+
+def PB (F : ℍ → ℂ) (m : ℕ) : Prop := IsBoundedAtImInfty (F * (Δ : ℍ → ℂ) ^ m)
+
+theorem PB.add_right {F : ℍ → ℂ} {m : ℕ} (hm : PB F m) (k : ℕ) : PB F (m + k) := by
+  unfold PB at hm ⊢
+  rw [pow_add, ← mul_assoc]
+  exact hm.mul ((good_discriminant 1).pow k).bdd
+
+theorem good_of_PB {F : ℍ → ℂ} (hF : F ∈ ring M) {m : ℕ} (hm : PB F m) :
+    Good M (F * (Δ : ℍ → ℂ) ^ m) where
+  periodic := by
+    have : (F * (Δ : ℍ → ℂ) ^ m) ∘ ofComplex = (F ∘ ofComplex) * (((Δ : ℍ → ℂ) ^ m) ∘ ofComplex) :=
+      rfl
+    rw [this]
+    exact (periodic_of_mem M hF).mul ((good_discriminant M).pow m).periodic
+  mdiff := (mdifferentiable_of_mem M hF).mul ((good_discriminant M).pow m).mdiff
+  bdd := hm
+
+def famS : Set (ℍ → ℂ) :=
+  {G | MDiff G ∧ (∀ δ ∈ CongruenceSubgroup.Gamma M, ∀ τ : ℍ, G (δ • τ) = G τ) ∧
+    ∀ γ : SL(2, ℤ), ∃ m : ℕ, IsBoundedAtImInfty ((fun τ => G (γ • τ)) * (Δ : ℍ → ℂ) ^ m)}
+
+theorem mdifferentiable_sl_smul (γ : SL(2, ℤ)) : MDiff (fun τ : ℍ => γ • τ) := by
+  have : (fun τ : ℍ => γ • τ) = fun τ : ℍ => (γ : GL (Fin 2) ℝ) • τ := by
+    funext τ; exact ModularGroup.sl_moeb γ τ
+  rw [this]
+  apply UpperHalfPlane.mdifferentiable_smul
+  simp
+
+omit [NeZero M] in
+theorem famS_stable (γ : SL(2, ℤ)) : ∀ G ∈ famS M, (G ∘ (γ • ·)) ∈ famS M := by
+  rintro G ⟨hG, hinv, hpb⟩
+  have : (CongruenceSubgroup.Gamma M).Normal := CongruenceSubgroup.Gamma_normal M
+  refine ⟨hG.comp (mdifferentiable_sl_smul γ), fun δ hδ τ => ?_, fun γ' => ?_⟩
+  · change G (γ • δ • τ) = G (γ • τ)
+    have hconj : γ * δ * γ⁻¹ ∈ CongruenceSubgroup.Gamma M :=
+      Subgroup.Normal.conj_mem inferInstance δ hδ γ
+    have := hinv _ hconj (γ • τ)
+    rw [← this, ← mul_smul, ← mul_smul]
+    congr 1
+    group
+  · obtain ⟨m, hm⟩ := hpb (γ * γ')
+    refine ⟨m, ?_⟩
+    have : (fun τ => (G ∘ (γ • ·)) (γ' • τ)) = fun τ => G ((γ * γ') • τ) := by
+      funext τ; simp [mul_smul]
+    rw [this]; exact hm
+
+theorem exists_levelFraction {G : ℍ → ℂ} (hG : G ∈ famS M) :
+    ∃ a b : ℍ → ℂ, a ∈ ring M ∧ b ∈ ring M ∧ b ≠ 0 ∧ G * b = a :=
+  WLight.exists_levelFraction_of_stable_family M PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp M)
+    (fun v τ => rfl) (fricke M) (fun v τ => rfl) jAnalytic (fun τ => rfl) (famS M)
+    (fun G hG => hG.1)
+    (fun G hG => by
+      obtain ⟨m, hm⟩ := hG.2.2 1
+      exact ⟨m, by simpa using hm⟩)
+    (famS_stable M) (fun G hG => hG.2.1) hG
+
+variable {Γ : Subgroup SL(2, ℤ)} {k : ℤ}
+
+omit [NeZero M] in
+theorem FF_mem_famS (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) [Γ.FiniteIndex]
+    (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) : FF k f g ∈ famS M :=
+  ⟨mdifferentiable_FF k f.holo' g.holo', fun _ hδ τ => FF_smul_of_mem f g (hΓ hδ) τ,
+    fun γ => ⟨k.toNat, isBoundedAtImInfty_FF_smul f g γ⟩⟩
+
+theorem periodic_FF (hT : ModularGroup.T ∈ Γ) [Γ.FiniteIndex]
+    (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) : Periodic (FF k f g ∘ ofComplex) 1 := by
+  intro z
+  have hf := (good_coe hT f).periodic z
+  have hg := (good_coe hT g).periodic z
+  have hΔ := (by simpa using (good_discriminant 1).periodic :
+    Periodic ((Δ : ℍ → ℂ) ∘ ofComplex) 1) z
+  simp only [Function.comp_apply, Complex.ofReal_one] at hf hg hΔ ⊢
+  rw [FF_apply, FF_apply, hf, hg, hΔ]
+
+omit [NeZero M] in
+theorem good_FF_mul_pow (hT : ModularGroup.T ∈ Γ) [Γ.FiniteIndex]
+    (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) :
+    Good M (FF k f g * (Δ : ℍ → ℂ) ^ k.toNat) where
+  periodic := by
+    have h1 : Periodic ((FF k f g * (Δ : ℍ → ℂ) ^ k.toNat) ∘ ofComplex) 1 := by
+      have : (FF k f g * (Δ : ℍ → ℂ) ^ k.toNat) ∘ ofComplex =
+          (FF k f g ∘ ofComplex) * (((Δ : ℍ → ℂ) ^ k.toNat) ∘ ofComplex) := rfl
+      rw [this]
+      exact (periodic_FF hT f g).mul (by simpa using ((good_discriminant 1).pow k.toNat).periodic)
+    simpa using h1.nat_mul M
+  mdiff := (mdifferentiable_FF k f.holo' g.holo').mul ((good_discriminant M).pow _).mdiff
+  bdd := by simpa using isBoundedAtImInfty_FF_smul f g 1
+
+omit [NeZero M] in
+theorem Good.of_one {f : ℍ → ℂ} (hf : Good 1 f) : Good M f where
+  periodic := by simpa using hf.periodic.nat_mul M
+  mdiff := hf.mdiff
+  bdd := hf.bdd
+
+theorem Q_FF_mul_pow (hT : ModularGroup.T ∈ Γ) [Γ.FiniteIndex]
+    (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) :
+    Q M (FF k f g * (Δ : ℍ → ℂ) ^ k.toNat) =
+      Q M f * Q M g ^ 11 * Q M (Δ : ℍ → ℂ) ^ (-k).toNat := by
+  have hM := castM_pos M
+  have hf : Good M (f : ℍ → ℂ) := Good.of_one M (good_coe hT f)
+  have hg : Good M (g : ℍ → ℂ) := Good.of_one M (good_coe hT g)
+  rw [FF_mul_pow, Q_mul hM (hf.mul (hg.pow 11)) ((good_discriminant M).pow _),
+    Q_mul hM hf (hg.pow 11), Q_pow hM hg, Q_pow hM (good_discriminant M)]
+
+end Family
+
+section Expansion
+
+local notation "Δ" => ModularForm.discriminant
+
+variable (M : ℕ) [NeZero M]
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ring M) K] [IsScalarTower ℂ (ring M) K]
+  [IsFractionRing (ring M) K]
+
+def E : K →ₐ[ℂ] LaurentSeries ℂ :=
+  (ModularCurve.LevelN.exists_algHom_laurentSeries_qExpansion M K).choose
+
+theorem E_jGen : E M K (algebraMap (ring M) K (jGen M)) = ModularCurve.qExpand ℂ M (jqModC ℂ) :=
+  (ModularCurve.LevelN.exists_algHom_laurentSeries_qExpansion M K).choose_spec.1
+
+theorem E_mul_pow
+    (F : ℍ → ℂ) (hF : F ∈ ring M) (m : ℕ) (hm : IsBoundedAtImInfty (F * (Δ : ℍ → ℂ) ^ m)) :
+    E M K (algebraMap (ring M) K ⟨F, hF⟩) * Q M (Δ : ℍ → ℂ) ^ m = Q M (F * (Δ : ℍ → ℂ) ^ m) :=
+  (ModularCurve.LevelN.exists_algHom_laurentSeries_qExpansion M K).choose_spec.2 F hF m hm
+
+theorem E_injective : Function.Injective (E M K) := (E M K).toRingHom.injective
+
+omit [NeZero M] [Algebra ℂ K] [IsScalarTower ℂ (↥(ring M)) K] in
+theorem algebraMap_ne_zero {b : ℍ → ℂ} (hb : b ∈ ring M) (hb0 : b ≠ 0) :
+    algebraMap (ring M) K ⟨b, hb⟩ ≠ 0 := by
+  intro h
+  have : (⟨b, hb⟩ : ring M) = 0 := (IsFractionRing.injective (ring M) K) (by rw [h, map_zero])
+  exact hb0 (congrArg Subtype.val this)
+
+
+theorem E_div_eq {G a b : ℍ → ℂ} (ha : a ∈ ring M) (hb : b ∈ ring M) (hb0 : b ≠ 0) (hGb : G * b = a)
+    {p : ℕ} (hGp : Good M (G * (Δ : ℍ → ℂ) ^ p)) :
+    E M K (algebraMap (ring M) K ⟨a, ha⟩) / E M K (algebraMap (ring M) K ⟨b, hb⟩) =
+      Q M (G * (Δ : ℍ → ℂ) ^ p) / Q M (Δ : ℍ → ℂ) ^ p := by
+  have hM := castM_pos M
+  have hΔ0 : Q M (Δ : ℍ → ℂ) ≠ 0 := Q_discriminant_ne_zero M
+  obtain ⟨mb, hmb⟩ := exists_isBoundedAtImInfty_mul_pow M hb
+  have hgoodb := good_of_PB M hb hmb
+  have ham : IsBoundedAtImInfty (a * (Δ : ℍ → ℂ) ^ (mb + p)) := by
+    have : a * (Δ : ℍ → ℂ) ^ (mb + p) = (b * (Δ : ℍ → ℂ) ^ mb) * (G * (Δ : ℍ → ℂ) ^ p) := by
+      rw [← hGb]; ring
+    rw [this]; exact hmb.mul hGp.bdd
+  have hEa := E_mul_pow M K a ha (mb + p) ham
+  have hEb := E_mul_pow M K b hb mb hmb
+  have hsplit : Q M (a * (Δ : ℍ → ℂ) ^ (mb + p)) =
+      Q M (b * (Δ : ℍ → ℂ) ^ mb) * Q M (G * (Δ : ℍ → ℂ) ^ p) := by
+    rw [← Q_mul hM hgoodb hGp]
+    congr 1
+    rw [← hGb]; ring
+  have hEb0 : E M K (algebraMap (ring M) K ⟨b, hb⟩) ≠ 0 :=
+    (map_ne_zero_iff _ (E_injective M K)).mpr (algebraMap_ne_zero M K hb hb0)
+  have hQb0 : Q M (b * (Δ : ℍ → ℂ) ^ mb) ≠ 0 := by
+    rw [ne_eq, Q_eq_zero_iff hM hgoodb, mul_discriminant_pow_eq_zero_iff]
+    exact hb0
+  rw [hsplit, pow_add] at hEa
+  rw [eq_div_iff (pow_ne_zero p hΔ0), div_mul_eq_mul_div, div_eq_iff hEb0]
+  apply mul_right_cancel₀ (pow_ne_zero mb hΔ0)
+  calc E M K (algebraMap (ring M) K ⟨a, ha⟩) * Q M (Δ : ℍ → ℂ) ^ p * Q M (Δ : ℍ → ℂ) ^ mb
+      = E M K (algebraMap (ring M) K ⟨a, ha⟩) * (Q M (Δ : ℍ → ℂ) ^ mb * Q M (Δ : ℍ → ℂ) ^ p) := by
+        ring
+    _ = Q M (b * (Δ : ℍ → ℂ) ^ mb) * Q M (G * (Δ : ℍ → ℂ) ^ p) := hEa
+    _ = Q M (G * (Δ : ℍ → ℂ) ^ p) * (E M K (algebraMap (ring M) K ⟨b, hb⟩)
+          * Q M (Δ : ℍ → ℂ) ^ mb) := by
+        rw [hEb]; ring
+    _ = Q M (G * (Δ : ℍ → ℂ) ^ p) * E M K (algebraMap (ring M) K ⟨b, hb⟩)
+          * Q M (Δ : ℍ → ℂ) ^ mb := by
+        ring
+
+variable {Γ : Subgroup SL(2, ℤ)} {k : ℤ}
+
+theorem comp_smul_ne_zero {b : ℍ → ℂ} (hb0 : b ≠ 0) (γ : SL(2, ℤ)) :
+    (fun τ : ℍ => b (γ • τ)) ≠ 0 := by
+  intro h
+  apply hb0
+  funext τ
+  have := congrFun h (γ⁻¹ • τ)
+  simpa using this
+
+theorem exists_kappa (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ) [Γ.FiniteIndex]
+    (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hg0 : (g : ℍ → ℂ) ≠ 0) :
+    ∃ κ : K, E M K κ = Q M f / Q M g ∧
+      ∀ γ ∈ Γ, ∀ (hst : ∀ G ∈ ring M, (fun τ : ℍ => G (γ⁻¹ • τ)) ∈ ring M) (φ : K ≃ₐ[ℂ] K),
+        (∀ (G : ℍ → ℂ) (hG : G ∈ ring M),
+            φ (algebraMap (ring M) K ⟨G, hG⟩) = algebraMap (ring M) K ⟨fun τ : ℍ => G (γ⁻¹ • τ), hst
+              G hG⟩) →
+        φ κ = κ := by
+  have hM := castM_pos M
+  have hΔ0 : Q M (Δ : ℍ → ℂ) ≠ 0 := Q_discriminant_ne_zero M
+  obtain ⟨a, b, ha, hb, hb0, hab⟩ := exists_levelFraction M (FF_mem_famS M hΓ f g)
+  obtain ⟨a', b', ha', hb', hb0', hab'⟩ := exists_levelFraction M (FF_mem_famS M hΓ g g)
+  refine ⟨(algebraMap (ring M) K ⟨a, ha⟩ / algebraMap (ring M) K ⟨b, hb⟩) /
+    (algebraMap (ring M) K ⟨a', ha'⟩ / algebraMap (ring M) K ⟨b', hb'⟩), ?_, ?_⟩
+  · have h1 := E_div_eq M K ha hb hb0 hab (good_FF_mul_pow M hT f g)
+    have h2 := E_div_eq M K ha' hb' hb0' hab' (good_FF_mul_pow M hT g g)
+    simp only [map_div₀]
+    rw [h1, h2, Q_FF_mul_pow M hT f g, Q_FF_mul_pow M hT g g]
+    have hQg : Q M (g : ℍ → ℂ) ≠ 0 := by
+      rw [ne_eq, Q_eq_zero_iff hM (Good.of_one M (good_coe hT g))]; exact hg0
+    field_simp
+  · intro γ hγ hst φ hφ
+    have hγ' : γ⁻¹ ∈ Γ := Γ.inv_mem hγ
+    have key : ∀ (G a b : ℍ → ℂ) (ha : a ∈ ring M) (hb : b ∈ ring M), b ≠ 0 → G * b = a →
+        (∀ τ, G (γ⁻¹ • τ) = G τ) →
+        φ (algebraMap (ring M) K ⟨a, ha⟩ / algebraMap (ring M) K ⟨b, hb⟩) =
+          algebraMap (ring M) K ⟨a, ha⟩ / algebraMap (ring M) K ⟨b, hb⟩ := by
+      intro G a b ha hb hb0 hGb hGinv
+      rw [map_div₀, hφ a ha, hφ b hb]
+      have hb0'' : (fun τ : ℍ => b (γ⁻¹ • τ)) ≠ 0 := comp_smul_ne_zero hb0 γ⁻¹
+      rw [div_eq_div_iff (algebraMap_ne_zero M K (hst b hb) hb0'') (algebraMap_ne_zero M K hb hb0),
+        ← map_mul, ← map_mul]
+      congr 1
+      apply Subtype.ext
+      change (fun τ : ℍ => a (γ⁻¹ • τ)) * b = a * (fun τ : ℍ => b (γ⁻¹ • τ))
+      funext τ
+      simp only [Pi.mul_apply]
+      have h1 := congrFun hGb (γ⁻¹ • τ)
+      have h2 := congrFun hGb τ
+      simp only [Pi.mul_apply] at h1 h2
+      rw [← h1, ← h2, hGinv τ]
+      ring
+    rw [map_div₀, key _ a b ha hb hb0 hab (fun τ => FF_smul_of_mem f g hγ' τ),
+      key _ a' b' ha' hb' hb0' hab' (fun τ => FF_smul_of_mem g g hγ' τ)]
+
+end Expansion
+
+section Bridge
+
+local notation "ℚ̄" => AlgebraicClosure ℚ
+
+variable (M : ℕ) [NeZero M]
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ring M) K] [IsScalarTower ℂ (ring M) K]
+  [IsFractionRing (ring M) K]
+variable (Γ : Subgroup SL(2, ℤ))
+
+def fixedSub : Subfield K where
+  carrier := {κ | ∀ γ ∈ Γ, ∀ (hst : ∀ G ∈ ring M, (fun τ : ℍ => G (γ⁻¹ • τ)) ∈ ring M) (φ : K ≃ₐ[ℂ]
+    K),
+    (∀ (G : ℍ → ℂ) (hG : G ∈ ring M),
+        φ (algebraMap (ring M) K ⟨G, hG⟩) = algebraMap (ring M) K ⟨fun τ : ℍ => G (γ⁻¹ • τ), hst G
+          hG⟩) →
+    φ κ = κ}
+  mul_mem' {x y} hx hy := fun γ hγ hst φ hφ => by rw [map_mul, hx γ hγ hst φ hφ, hy γ hγ hst φ hφ]
+  one_mem' := fun γ hγ hst φ hφ => map_one φ
+  add_mem' {x y} hx hy := fun γ hγ hst φ hφ => by rw [map_add, hx γ hγ hst φ hφ, hy γ hγ hst φ hφ]
+  zero_mem' := fun γ hγ hst φ hφ => map_zero φ
+  neg_mem' {x} hx := fun γ hγ hst φ hφ => by rw [map_neg, hx γ hγ hst φ hφ]
+  inv_mem' x hx := fun γ hγ hst φ hφ => by rw [map_inv₀, hx γ hγ hst φ hφ]
+
+omit [NeZero M] [IsScalarTower ℂ (↥(ring M)) K] [IsFractionRing (↥(ring M)) K] in
+theorem algebraMap_mem_fixedSub (c : ℂ) : algebraMap ℂ K c ∈ fixedSub M K Γ :=
+  fun _ _ _ φ _ => φ.commutes c
+
+def goodSeries : Subfield (LaurentSeries ℂ) := (fixedSub M K Γ).map (E M K).toRingHom
+
+theorem algebraMap_laurentSeries (c : ℂ) : algebraMap ℂ (LaurentSeries ℂ) c = HahnSeries.C c := by
+  have h1 : algebraMap ℂ (PowerSeries ℂ) c = PowerSeries.C c := by simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+
+variable (ι : ℚ̄ →+* ℂ)
+
+def iotaM : LaurentSeries ℚ̄ →+* LaurentSeries ℂ :=
+  (ModularCurve.qExpand ℂ M).comp (ModularCurve.coeffMap ι)
+
+theorem iotaM_algebraMap (c : ℚ̄) :
+    iotaM M ι (algebraMap ℚ̄ (LaurentSeries ℚ̄) c) = HahnSeries.C (ι c) := by
+  rw [iotaM, RingHom.comp_apply, ModularCurve.algebraMap_laurentSeries_eq_single,
+    ModularCurve.coeffMap_single, ModularCurve.qExpand_single, mul_zero, HahnSeries.C_apply]
+
+theorem const_mem_goodSeries (c : ℚ̄) :
+    iotaM M ι (algebraMap ℚ̄ (LaurentSeries ℚ̄) c) ∈ goodSeries M K Γ :=
+  Subfield.mem_map.mpr ⟨algebraMap ℂ K (ι c), algebraMap_mem_fixedSub M K Γ _, by
+    rw [iotaM_algebraMap]
+    change E M K (algebraMap ℂ K (ι c)) = _
+    rw [AlgHom.commutes, algebraMap_laurentSeries]⟩
+
+theorem coeffMap_ofPowerSeries {R S : Type*} [CommRing R] [CommRing S] (φ : R →+* S)
+    (p : PowerSeries R) :
+    ModularCurve.coeffMap φ (HahnSeries.ofPowerSeries ℤ R p) = HahnSeries.ofPowerSeries ℤ S (p.map
+      φ) := by
+  ext n
+  rw [ModularCurve.coeffMap_coeff]
+  rcases lt_or_ge n 0 with hn | hn
+  · rw [ModularCurve.ofPowerSeries_coeff_of_neg _ hn, ModularCurve.ofPowerSeries_coeff_of_neg _ hn,
+      map_zero]
+  · lift n to ℕ using hn
+    rw [HahnSeries.ofPowerSeries_apply_coeff, HahnSeries.ofPowerSeries_apply_coeff,
+      PowerSeries.coeff_map]
+
+theorem iotaM_coeffEmb_intSeriesC {h : ℍ → ℂ} {p : PowerSeries ℤ} (hp : IsIntegralQExp h p) :
+    iotaM M ι (coeffEmb ℚ̄ (intSeriesC ℚ p)) = ModularCurve.qExpand ℂ M (Q 1 h) := by
+  rw [iotaM, RingHom.comp_apply]
+  congr 1
+  rw [coeffEmb, intSeriesC, ModularCurve.coeffMap_coeffMap, coeffMap_ofPowerSeries]
+  have hmap : PowerSeries.map (ι.comp (algebraMap ℚ ℚ̄)) (PowerSeries.map (Int.castRingHom ℚ) p) =
+      PowerSeries.map (Int.castRingHom ℂ) p := by
+    rw [← RingHom.comp_apply (PowerSeries.map (ι.comp (algebraMap ℚ ℚ̄))) (PowerSeries.map
+      (Int.castRingHom ℚ)),
+      ← PowerSeries.map_comp,
+      RingHom.ext_int ((ι.comp (algebraMap ℚ ℚ̄)).comp (Int.castRingHom ℚ)) (Int.castRingHom ℂ)]
+  rw [hmap, Q, hp]
+
+variable {Γ}
+
+theorem gen_mem_goodSeries (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ)
+    [Γ.FiniteIndex]
+    {x : LaurentSeries ℚ} (hx : x ∈ intFormRatiosC ℚ Γ) :
+    iotaM M ι (coeffEmb ℚ̄ x) ∈ goodSeries M K Γ := by
+  obtain ⟨k, f, g, pf, pg, hf, hg, hpg0, rfl⟩ := hx
+  have hg0 : (g : ℍ → ℂ) ≠ 0 := by
+    intro h0
+    apply hpg0
+    have h1 : pg.map (Int.castRingHom ℂ) = 0 := by
+      rw [hg, h0, qExpansion_zero]
+    have h2 : pg = 0 :=
+      PowerSeries.map_injective (Int.castRingHom ℂ) Int.cast_injective (by rw [h1, map_zero])
+    rw [h2, intSeriesC_zero]
+  obtain ⟨κ, hκ, hfix⟩ := exists_kappa M K hΓ hT f g hg0
+  refine Subfield.mem_map.mpr ⟨κ, fun γ hγ hst φ hφ => hfix γ hγ hst φ hφ, ?_⟩
+  change E M K κ = _
+  rw [hκ, map_div₀, map_div₀, iotaM_coeffEmb_intSeriesC M ι hf, iotaM_coeffEmb_intSeriesC M ι hg,
+    Q_natCast_eq_qExpand M (good_coe hT f), Q_natCast_eq_qExpand M (good_coe hT g)]
+
+theorem laurentBaseChange_le (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ)
+    [Γ.FiniteIndex]
+    {u : LaurentSeries ℚ̄} (hu : u ∈ laurentBaseChange ℚ̄ (qExpFunctionFieldC ℚ Γ)) :
+    iotaM M ι u ∈ goodSeries M K Γ := by
+  have hF : (laurentBaseChange ℚ̄ (qExpFunctionFieldC ℚ Γ)).toSubfield ≤
+      (goodSeries M K Γ).comap (iotaM M ι) := by
+    rw [laurentBaseChange, IntermediateField.adjoin_toSubfield, Subfield.closure_le]
+    apply Set.union_subset
+    · rintro _ ⟨c, rfl⟩
+      exact const_mem_goodSeries M K Γ ι c
+    · rintro _ ⟨x, hx, rfl⟩
+      change iotaM M ι (coeffEmb ℚ̄ x) ∈ goodSeries M K Γ
+      have hF₀ : (qExpFunctionFieldC ℚ Γ).toSubfield ≤
+          ((goodSeries M K Γ).comap (iotaM M ι)).comap (coeffEmb ℚ̄) := by
+        rw [qExpFunctionFieldC, IntermediateField.adjoin_toSubfield, Subfield.closure_le]
+        apply Set.union_subset
+        · rintro _ ⟨r, rfl⟩
+          change iotaM M ι (coeffEmb ℚ̄ (algebraMap ℚ (LaurentSeries ℚ) r)) ∈ goodSeries M K Γ
+          have : coeffEmb ℚ̄ (algebraMap ℚ (LaurentSeries ℚ) r) =
+              algebraMap ℚ̄ (LaurentSeries ℚ̄) (algebraMap ℚ ℚ̄ r) := by
+            rw [ModularCurve.algebraMap_apply_eq_single, coeffEmb, ModularCurve.coeffMap_single,
+              ModularCurve.algebraMap_laurentSeries_eq_single]
+          rw [this]
+          exact const_mem_goodSeries M K Γ ι _
+        · intro x hx
+          exact gen_mem_goodSeries M K ι hΓ hT hx
+      exact hF₀ hx
+  exact hF hu
+
+variable (Γ)
+
+local notation "FFq" => laurentBaseChange (AlgebraicClosure ℚ) (qExpFunctionFieldC ℚ Γ)
+
+theorem exists_kappa_of_mem (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ)
+    [Γ.FiniteIndex]
+    (u : FFq) : ∃ κ : K, κ ∈ fixedSub M K Γ ∧ E M K κ = iotaM M ι (u : LaurentSeries ℚ̄) :=
+  Subfield.mem_map.mp (laurentBaseChange_le M K ι hΓ hT u.2)
+
+def Phi (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ) [Γ.FiniteIndex] :
+    FFq →+* K where
+  toFun u := (exists_kappa_of_mem M K Γ ι hΓ hT u).choose
+  map_one' := by
+    apply E_injective M K
+    rw [(exists_kappa_of_mem M K Γ ι hΓ hT 1).choose_spec.2, map_one, OneMemClass.coe_one, map_one]
+  map_mul' u v := by
+    apply E_injective M K
+    rw [(exists_kappa_of_mem M K Γ ι hΓ hT (u * v)).choose_spec.2, map_mul,
+      (exists_kappa_of_mem M K Γ ι hΓ hT u).choose_spec.2, (exists_kappa_of_mem M K Γ ι hΓ hT
+      v).choose_spec.2,
+      MulMemClass.coe_mul, map_mul]
+  map_zero' := by
+    apply E_injective M K
+    rw [(exists_kappa_of_mem M K Γ ι hΓ hT 0).choose_spec.2, map_zero, ZeroMemClass.coe_zero,
+      map_zero]
+  map_add' u v := by
+    apply E_injective M K
+    rw [(exists_kappa_of_mem M K Γ ι hΓ hT (u + v)).choose_spec.2, map_add,
+      (exists_kappa_of_mem M K Γ ι hΓ hT u).choose_spec.2, (exists_kappa_of_mem M K Γ ι hΓ hT
+      v).choose_spec.2,
+      AddMemClass.coe_add, map_add]
+
+theorem E_Phi (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ) [Γ.FiniteIndex]
+    (u : FFq) :
+    E M K (Phi M K Γ ι hΓ hT u) = iotaM M ι (u : LaurentSeries ℚ̄) :=
+  (exists_kappa_of_mem M K Γ ι hΓ hT u).choose_spec.2
+
+theorem Phi_mem (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ) [Γ.FiniteIndex]
+    (u : FFq) :
+    Phi M K Γ ι hΓ hT u ∈ fixedSub M K Γ :=
+  (exists_kappa_of_mem M K Γ ι hΓ hT u).choose_spec.1
+
+theorem main (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ) :
+    ∃ Φ : FFq →+* K,
+      (∀ c : ℚ̄, Φ (algebraMap ℚ̄ FFq c) = algebraMap ℂ K (ι c)) ∧
+      (∀ y : FFq, (y : LaurentSeries ℚ̄) = jqModC ℚ̄ → Φ y = algebraMap (ring M) K (jGen M)) ∧
+      ∀ γ ∈ Γ, ∀ (hst : ∀ G ∈ ring M, (fun τ : ℍ => G (γ⁻¹ • τ)) ∈ ring M) (φ : K ≃ₐ[ℂ] K),
+        (∀ (G : ℍ → ℂ) (hG : G ∈ ring M),
+            φ (algebraMap (ring M) K ⟨G, hG⟩) = algebraMap (ring M) K ⟨fun τ : ℍ => G (γ⁻¹ • τ), hst
+              G hG⟩) →
+        ∀ u, φ (Φ u) = Φ u := by
+  have : Γ.FiniteIndex := Subgroup.finiteIndex_of_le hΓ
+  refine ⟨Phi M K Γ ι hΓ hT, fun c => ?_, fun y hy => ?_,
+    fun γ hγ hst φ hφ u => (Phi_mem M K Γ ι hΓ hT u) γ hγ hst φ hφ⟩
+  · apply E_injective M K
+    rw [E_Phi]
+    change iotaM M ι (algebraMap ℚ̄ (LaurentSeries ℚ̄) c) = _
+    rw [iotaM_algebraMap, AlgHom.commutes, algebraMap_laurentSeries]
+  · apply E_injective M K
+    rw [E_Phi, hy, E_jGen, iotaM, RingHom.comp_apply]
+    congr 1
+    exact map_jqModC ι
+
+end Bridge
+
+end ModularCurve.LevelN.QExpBridge
+end
+
+theorem solution
+    (M : ℕ) [NeZero M] (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+    (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ)
+    (ι : AlgebraicClosure ℚ →+* ℂ)
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring M) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring M) K]
+    [IsFractionRing (ModularCurve.LevelN.ring M) K] :
+    ∃ Φ : ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+        (ModularCurve.qExpFunctionFieldC ℚ Γ) →+* K,
+      (∀ c : AlgebraicClosure ℚ,
+          Φ (algebraMap (AlgebraicClosure ℚ)
+            (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+              (ModularCurve.qExpFunctionFieldC ℚ Γ)) c) =
+            algebraMap ℂ K (ι c)) ∧
+      (∀ y : ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ Γ),
+          (y : LaurentSeries (AlgebraicClosure ℚ)) = ModularCurve.jqModC (AlgebraicClosure ℚ) →
+          Φ y = algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)) ∧
+      ∀ γ ∈ Γ, ∀ (hst : ∀ G ∈ ModularCurve.LevelN.ring M,
+          (fun τ : UpperHalfPlane => G (γ⁻¹ • τ)) ∈ ModularCurve.LevelN.ring M)
+        (φ : K ≃ₐ[ℂ] K),
+        (∀ (G : UpperHalfPlane → ℂ) (hG : G ∈ ModularCurve.LevelN.ring M),
+            φ (algebraMap (ModularCurve.LevelN.ring M) K ⟨G, hG⟩) =
+              algebraMap (ModularCurve.LevelN.ring M) K
+                ⟨fun τ : UpperHalfPlane => G (γ⁻¹ • τ), hst G hG⟩) →
+        ∀ u, φ (Φ u) = Φ u :=
+  ModularCurve.LevelN.QExpBridge.main M K Γ ι hΓ hT
+
+end S_ModularCurve_exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN
+end P2MW
+export P2MW.S_ModularCurve_exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN
+    (M : ℕ) [NeZero M] (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+    (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ)
+    (ι : AlgebraicClosure ℚ →+* ℂ)
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring M) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring M) K]
+    [IsFractionRing (ModularCurve.LevelN.ring M) K] :
+    ∃ Φ : ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+        (ModularCurve.qExpFunctionFieldC ℚ Γ) →+* K,
+      (∀ c : AlgebraicClosure ℚ,
+          Φ (algebraMap (AlgebraicClosure ℚ)
+            (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+              (ModularCurve.qExpFunctionFieldC ℚ Γ)) c) =
+            algebraMap ℂ K (ι c)) ∧
+      (∀ y : ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ Γ),
+          (y : LaurentSeries (AlgebraicClosure ℚ)) = ModularCurve.jqModC (AlgebraicClosure ℚ) →
+          Φ y = algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)) ∧
+      ∀ γ ∈ Γ, ∀ (hst : ∀ G ∈ ModularCurve.LevelN.ring M,
+          (fun τ : UpperHalfPlane => G (γ⁻¹ • τ)) ∈ ModularCurve.LevelN.ring M)
+        (φ : K ≃ₐ[ℂ] K),
+        (∀ (G : UpperHalfPlane → ℂ) (hG : G ∈ ModularCurve.LevelN.ring M),
+            φ (algebraMap (ModularCurve.LevelN.ring M) K ⟨G, hG⟩) =
+              algebraMap (ModularCurve.LevelN.ring M) K
+                ⟨fun τ : UpperHalfPlane => G (γ⁻¹ • τ), hst G hG⟩) →
+        ∀ u, φ (Φ u) = Φ u :=
+  solution M Γ hΓ hT ι K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN_qExpansion.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN_qExpansion.lean
new file mode 100644
index 0000000000..cca0486276
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN_qExpansion.lean
@@ -0,0 +1,1134 @@
+/-
+Based on Prove2Me node
+ModularCurve.exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN_qExpansion
+(c1b8e790-b45b-54cf-ae04-f57a9cd7c0f4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 0097a792-c890-56c2-affe-e0f6afd59471
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LevelNFunctionField
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Data.Int.Star
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_algHom_laurentSeries_qExpansion
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_exists_levelFraction_of_stable_family
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_modularity_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_orbit_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelN_structure_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Embedding the ℚ̄-rational q-expansion field of X(Γ) into ℂ(X(M))
+
+Theorem statement:
+`ModularCurve.exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN_qExpansion`
+(`c1b8e790-b45b-54cf-ae04-f57a9cd7c0f4`), by Claude, 2026-09-05.
+
+Proof: submission `0097a792-c890-56c2-affe-e0f6afd59471`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a nonzero natural number, let $\Gamma\le \mathrm{SL}_2(\mathbb{Z})$ be a subgroup
+containing the principal congruence subgroup $\Gamma(M)$ and the translation matrix
+`ModularGroup.T`, let $\iota\colon \overline{\mathbb{Q}}\to\mathbb{C}$ be a ring homomorphism, and
+let $K$ be a field that is simultaneously a $\mathbb{C}$-algebra and an algebra over
+[`ModularCurve.LevelN.ring M`](def/ModularCurve_LevelNFunctionField.html#L28) — the
+$\mathbb{C}$-subalgebra of functions $\mathbb{H}\to\mathbb{C}$ generated by $j=E_4^3/\Delta$
+together with the Fricke functions $f_v$ for the nonzero $v\in(\mathbb{Z}/M)^2$ — compatibly as a
+scalar tower, and which is a fraction field of that subalgebra. Write $A$ for the intermediate field
+[`ModularCurve.laurentBaseChange`](def/ModularCurve_LaurentCoeff.html#L103) of
+$\overline{\mathbb{Q}}((q))$ over $\overline{\mathbb{Q}}$ generated by the coefficientwise images of
+[`ModularCurve.qExpFunctionFieldC ℚ Γ`](def/ModularCurve_X1.html#L101), the latter being the
+subfield of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by the quotients
+$\mathrm{intSeriesC}\,p_f/\mathrm{intSeriesC}\,p_g$ attached to pairs of modular forms $f,g$ of a
+common weight for $\Gamma$ with integral $q$-expansions $p_f,p_g$ and $\mathrm{intSeriesC}\,p_g\ne
+0$. The assertion is that there exist a ring homomorphism $\Phi\colon A\to K$ and a
+$\mathbb{C}$-algebra homomorphism $E\colon K\to\mathbb{C}((q))$ such that: $E$ sends the image in
+$K$ of the generator $j\in$ [`ModularCurve.LevelN.ring
+M`](def/ModularCurve_LevelNFunctionField.html#L28) to [`ModularCurve.qExpand ℂ M
+(ModularCurve.jqModC ℂ)`](def/ModularCurve_X0.html#L25), the $j$-series $q^{-1}E_4^3\eta^{-24}$ with
+$q$ replaced by $q^M$; for every $u\in A$, $E(\Phi u)$ is the series obtained from $u$ by
+transporting coefficients along $\iota$ and substituting $q^M$ for $q$; $\Phi$ restricted to
+$\overline{\mathbb{Q}}$ is $\iota$ followed by $\mathbb{C}\to K$; any $y\in A$ whose underlying
+Laurent series is [`ModularCurve.jqModC (AlgebraicClosure ℚ)`](def/ModularCurve_JqCoeff.html#L15) is
+sent by $\Phi$ to the image of $j$ in $K$; and for each $\gamma\in\Gamma$, given that $G\mapsto
+G(\gamma^{-1}\cdot{-})$ preserves [`ModularCurve.LevelN.ring
+M`](def/ModularCurve_LevelNFunctionField.html#L28), every $\mathbb{C}$-algebra automorphism
+$\varphi$ of $K$ inducing $G\mapsto G(\gamma^{-1}\cdot{-})$ on that subalgebra fixes $\Phi u$ for
+all $u\in A$.
+
+This is the comparison, in Shimura's theory of canonical models, between the
+$\overline{\mathbb{Q}}$-rational $q$-expansion field of $X(\Gamma)$ and the function field of the
+level-$M$ modular curve, realised concretely through $q$-expansions: the embedding $\Phi$ is pinned
+down by $\iota$ on constants, by $j\mapsto j$, and by compatibility with the substitution $q\mapsto
+q^M$, and its image lands in the $\Gamma$-invariants of $K$. It is used in the level-$N$ base-change
+statement and in the computations of orders of vanishing on the $\Gamma_0$- and $\Gamma_1$-curves
+over $\overline{\mathbb{Q}}$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN_qExpansion.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN_qExpansion
+
+
+open UpperHalfPlane Filter Topology Function
+open scoped MatrixGroups Manifold Real ModularForm
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "LevelN.ring LevelN.jGen IsIntegralQExp intSeriesC intSeriesC_zero \
+  intFormRatiosC qExpFunctionFieldC qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd \
+  qExpand_single algebraMap_apply_eq_single ofPowerSeries_coeff_of_neg jGen coeffMap \
+  coeffMap_coeff coeffMap_single coeffMap_coeffMap algebraMap_laurentSeries_eq_single coeffEmb \
+  laurentBaseChange jqModC map_jqModC LevelN.exists_algHom_laurentSeries_qExpansion"
+namespace LevelN
+p2m_export "ModularCurve.LevelN" "wp fricke jAnalytic generators ring jGen \
+  exists_algHom_laurentSeries_qExpansion"
+namespace QExpBridge
+p2m_open "ModularCurve.LevelN ModularCurve"
+
+section Toolkit
+
+variable {h : ℝ}
+
+structure Good (h : ℝ) (G : ℍ → ℂ) : Prop where
+  periodic : Periodic (G ∘ ofComplex) h
+  mdiff : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G
+  bdd : IsBoundedAtImInfty G
+
+namespace Good
+
+variable {G G₁ G₂ : ℍ → ℂ}
+
+theorem analyticAt (hG : Good h G) (hh : 0 < h) : AnalyticAt ℂ (cuspFunction h G) 0 :=
+  analyticAt_cuspFunction_zero hh hG.periodic hG.mdiff hG.bdd
+
+theorem continuousAt (hG : Good h G) (hh : 0 < h) : ContinuousAt (cuspFunction h G) 0 :=
+  (hG.analyticAt hh).continuousAt
+
+theorem mul (h₁ : Good h G₁) (h₂ : Good h G₂) : Good h (G₁ * G₂) where
+  periodic := by
+    have : (G₁ * G₂) ∘ ofComplex = (G₁ ∘ ofComplex) * (G₂ ∘ ofComplex) := rfl
+    rw [this]
+    exact h₁.periodic.mul h₂.periodic
+  mdiff := h₁.mdiff.mul h₂.mdiff
+  bdd := h₁.bdd.mul h₂.bdd
+
+theorem add (h₁ : Good h G₁) (h₂ : Good h G₂) : Good h (G₁ + G₂) where
+  periodic := by
+    have : (G₁ + G₂) ∘ ofComplex = (G₁ ∘ ofComplex) + (G₂ ∘ ofComplex) := rfl
+    rw [this]
+    exact h₁.periodic.add h₂.periodic
+  mdiff := h₁.mdiff.add h₂.mdiff
+  bdd := h₁.bdd.add h₂.bdd
+
+theorem const (h : ℝ) (c : ℂ) : Good h (fun _ : ℍ => c) where
+  periodic := fun _ => rfl
+  mdiff := mdifferentiable_const
+  bdd := Filter.const_boundedAtFilter _ _
+
+theorem one (h : ℝ) : Good h (1 : ℍ → ℂ) := const h 1
+
+theorem pow (hG : Good h G) : ∀ n : ℕ, Good h (G ^ n)
+  | 0 => by rw [pow_zero]; exact one h
+  | n + 1 => by rw [pow_succ]; exact (pow hG n).mul hG
+
+end Good
+
+variable {G G₁ G₂ : ℍ → ℂ}
+
+theorem cuspFunction_mul_of_good (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) :
+    cuspFunction h (G₁ * G₂) = cuspFunction h G₁ * cuspFunction h G₂ :=
+  cuspFunction_mul (h₁.continuousAt hh) (h₂.continuousAt hh)
+
+theorem cuspFunction_add_of_good (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) :
+    cuspFunction h (G₁ + G₂) = cuspFunction h G₁ + cuspFunction h G₂ :=
+  cuspFunction_add (h₁.continuousAt hh) (h₂.continuousAt hh)
+
+theorem qExpansion_mul_of_good (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) :
+    qExpansion h (G₁ * G₂) = qExpansion h G₁ * qExpansion h G₂ :=
+  qExpansion_mul (h₁.analyticAt hh) (h₂.analyticAt hh)
+
+theorem qExpansion_add_of_good (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) :
+    qExpansion h (G₁ + G₂) = qExpansion h G₁ + qExpansion h G₂ :=
+  qExpansion_add (h₁.analyticAt hh) (h₂.analyticAt hh)
+
+theorem qExpansion_pow_of_good (hh : 0 < h) (hG : Good h G) :
+    ∀ n : ℕ, qExpansion h (G ^ n) = qExpansion h G ^ n
+  | 0 => by rw [pow_zero, pow_zero, qExpansion_one]
+  | n + 1 => by rw [pow_succ, pow_succ, qExpansion_mul_of_good hh (hG.pow n) hG,
+      qExpansion_pow_of_good hh hG n]
+
+theorem qExpansion_const (hh : 0 < h) (c : ℂ) :
+    qExpansion h (fun _ : ℍ => c) = PowerSeries.C c := by
+  have h1 : (fun _ : ℍ => c) = c • (1 : ℍ → ℂ) := by funext τ; simp
+  rw [h1, qExpansion_smul ((Good.one h).analyticAt hh), qExpansion_one, Algebra.smul_def, mul_one]
+  simp
+
+theorem Good.eq_zero_of_qExpansion_eq_zero (hG : Good h G) (hh : 0 < h) (h0 : qExpansion h G = 0) :
+    G = 0 :=
+  (qExpansion_eq_zero_iff hh hG.periodic hG.mdiff hG.bdd).mp h0
+
+def Q (h : ℝ) (G : ℍ → ℂ) : LaurentSeries ℂ := HahnSeries.ofPowerSeries ℤ ℂ (qExpansion h G)
+
+theorem Q_mul (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) : Q h (G₁ * G₂) = Q h G₁ * Q h G₂ := by
+  simp only [Q, qExpansion_mul_of_good hh h₁ h₂, map_mul]
+
+theorem Q_add (hh : 0 < h) (h₁ : Good h G₁) (h₂ : Good h G₂) : Q h (G₁ + G₂) = Q h G₁ + Q h G₂ := by
+  simp only [Q, qExpansion_add_of_good hh h₁ h₂, map_add]
+
+theorem Q_pow (hh : 0 < h) (hG : Good h G) (n : ℕ) : Q h (G ^ n) = Q h G ^ n := by
+  simp only [Q, qExpansion_pow_of_good hh hG n, map_pow]
+
+theorem Q_one (h : ℝ) : Q h (1 : ℍ → ℂ) = 1 := by
+  simp only [Q, qExpansion_one, map_one]
+
+theorem Q_const (hh : 0 < h) (c : ℂ) : Q h (fun _ : ℍ => c) = HahnSeries.C c := by
+  simp only [Q, qExpansion_const hh c, HahnSeries.ofPowerSeries_C]
+
+theorem Q_eq_zero_iff (hh : 0 < h) (hG : Good h G) : Q h G = 0 ↔ G = 0 := by
+  constructor
+  · intro h0
+    apply hG.eq_zero_of_qExpansion_eq_zero hh
+    have : Function.Injective (HahnSeries.ofPowerSeries ℤ ℂ) := HahnSeries.ofPowerSeries_injective
+    exact this (by rw [map_zero]; exact h0)
+  · rintro rfl
+    simp only [Q, qExpansion_zero, map_zero]
+
+end Toolkit
+
+section LevelOne
+
+local notation "Δ" => ModularForm.discriminant
+
+theorem natCast_mem_strictPeriods (N : ℕ) : (N : ℝ) ∈ (𝒮ℒ).strictPeriods := by
+  simp only [Subgroup.strictPeriods_SL2Z]
+  exact ⟨N, by simp⟩
+
+theorem good_discriminant (N : ℕ) : Good N Δ where
+  periodic := by
+    have := SlashInvariantFormClass.periodic_comp_ofComplex CuspForm.discriminant
+      (natCast_mem_strictPeriods N)
+    simpa using this
+  mdiff := CuspForm.discriminant.holo'
+  bdd := ModularForm.discriminant_isZeroAtImInfty.isBoundedAtImInfty
+
+theorem good_E₄ (N : ℕ) : Good N (ModularForm.E₄ : ℍ → ℂ) where
+  periodic := SlashInvariantFormClass.periodic_comp_ofComplex ModularForm.E₄
+      (natCast_mem_strictPeriods N)
+  mdiff := ModularForm.E₄.holo'
+  bdd := ModularFormClass.bdd_at_infty ModularForm.E₄
+
+theorem discriminant_ne_zero' : (Δ : ℍ → ℂ) ≠ 0 := by
+  intro h0
+  have := congrFun h0 UpperHalfPlane.I
+  exact ModularForm.discriminant_ne_zero _ this
+
+theorem discriminant_pow_ne_zero (m : ℕ) : ((Δ : ℍ → ℂ) ^ m) ≠ 0 := by
+  intro h0
+  have := congrFun h0 UpperHalfPlane.I
+  simp only [Pi.pow_apply, Pi.zero_apply, pow_eq_zero_iff', ne_eq] at this
+  exact ModularForm.discriminant_ne_zero _ this.1
+
+theorem mul_discriminant_pow_eq_zero_iff (F : ℍ → ℂ) (m : ℕ) :
+    F * (Δ : ℍ → ℂ) ^ m = 0 ↔ F = 0 := by
+  constructor
+  · intro h0
+    funext τ
+    have := congrFun h0 τ
+    simp only [Pi.mul_apply, Pi.pow_apply, Pi.zero_apply, mul_eq_zero, pow_eq_zero_iff',
+      ne_eq] at this
+    rcases this with h1 | ⟨h1, _⟩
+    · exact h1
+    · exact absurd h1 (ModularForm.discriminant_ne_zero τ)
+  · rintro rfl
+    exact zero_mul _
+
+theorem Q_discriminant_ne_zero (N : ℕ) [NeZero N] : Q N (Δ : ℍ → ℂ) ≠ 0 := by
+  have hN : (0 : ℝ) < N := Nat.cast_pos.mpr (NeZero.pos N)
+  rw [ne_eq, Q_eq_zero_iff hN (good_discriminant N)]
+  exact discriminant_ne_zero'
+
+end LevelOne
+
+section Ring
+
+local notation "Δ" => ModularForm.discriminant
+
+variable (N : ℕ) [NeZero N]
+
+theorem mdifferentiable_of_mem {F : ℍ → ℂ} (hF : F ∈ ring N) : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F := by
+  have h := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact h.2.2.2.2.1 F hF
+
+theorem eq_zero_or_eq_zero_of_mul_eq_zero {a b : ℍ → ℂ} (ha : a ∈ ring N) (hb : b ∈ ring N)
+    (hab : a * b = 0) : a = 0 ∨ b = 0 := by
+  have h := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  exact h.2.2.2.2.2 a b ha hb hab
+
+abbrev redMat (γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) (ZMod N) :=
+  (γ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N)
+
+theorem fricke_smul_of_mem (v : Fin 2 → ZMod N) {γ : SL(2, ℤ)}
+    (hγ : γ ∈ CongruenceSubgroup.Gamma N) (τ : ℍ) : fricke N v (γ • τ) = fricke N v τ :=
+  (WLight.frickeFunction_modularity_package N PeriodPair.ofTau (fun _ => ⟨rfl, rfl⟩)).2.2.2.2.2.2.1
+    v γ hγ τ
+
+omit [NeZero N] in
+theorem jAnalytic_smul (γ : SL(2, ℤ)) (τ : ℍ) : jAnalytic (γ • τ) = jAnalytic τ := by
+  have hmem : (γ : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ, rfl⟩
+  have h4 : (ModularForm.E₄ : ℍ → ℂ) ((γ : GL (Fin 2) ℝ) • τ) =
+      denom (γ : GL (Fin 2) ℝ) τ ^ (4 : ℤ) * ModularForm.E₄ τ :=
+    SlashInvariantForm.slash_action_eqn'' _ hmem τ
+  have h12 : ModularForm.discriminant ((γ : GL (Fin 2) ℝ) • τ) =
+      denom (γ : GL (Fin 2) ℝ) τ ^ (12 : ℤ) * ModularForm.discriminant τ := by
+    have := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hmem τ
+    simpa using this
+  have hd : denom (γ : GL (Fin 2) ℝ) τ ≠ 0 := denom_ne_zero _ _
+  have hΔ : ModularForm.discriminant τ ≠ 0 := ModularForm.discriminant_ne_zero τ
+  rw [jAnalytic, jAnalytic, ModularGroup.sl_moeb, h4, h12]
+  field_simp
+
+def precomp (g : SL(2, ℤ)) : (ℍ → ℂ) →ₐ[ℂ] (ℍ → ℂ) :=
+  AlgHom.pi (fun τ => Pi.evalAlgHom ℂ (fun _ : ℍ => ℂ) (g • τ))
+
+omit [NeZero N] in
+@[scoped simp]
+theorem precomp_apply (g : SL(2, ℤ)) (F : ℍ → ℂ) (τ : ℍ) : precomp g F τ = F (g • τ) := rfl
+
+theorem smul_eq_self_of_mem {F : ℍ → ℂ} (hF : F ∈ ring N) {γ : SL(2, ℤ)}
+    (hγ : γ ∈ CongruenceSubgroup.Gamma N) (τ : ℍ) : F (γ • τ) = F τ := by
+  suffices h : ring N ≤ AlgHom.equalizer (precomp γ) (AlgHom.id ℂ (ℍ → ℂ)) by
+    have := h hF
+    rw [AlgHom.mem_equalizer] at this
+    exact congrFun this τ
+  rw [ring, Algebra.adjoin_le_iff]
+  intro G hG
+  rw [SetLike.mem_coe, AlgHom.mem_equalizer]
+  funext τ'
+  rcases hG with rfl | ⟨v, hv, rfl⟩
+  · exact jAnalytic_smul γ τ'
+  · exact fricke_smul_of_mem N v hγ τ'
+
+omit [NeZero N] in
+theorem T_pow_mem_Gamma : ModularGroup.T ^ N ∈ CongruenceSubgroup.Gamma N := by
+  rw [CongruenceSubgroup.Gamma_mem, ← zpow_natCast, ModularGroup.coe_T_zpow]
+  simp
+
+theorem periodic_of_mem {F : ℍ → ℂ} (hF : F ∈ ring N) : Periodic (F ∘ ofComplex) N := by
+  intro w
+  by_cases hw : 0 < w.im
+  · have hw' : 0 < (w + N).im := by simpa using hw
+    simp only [Function.comp_apply, ofComplex_apply_of_im_pos hw, ofComplex_apply_of_im_pos hw']
+    have hT : ModularGroup.T ^ N • (⟨w, hw⟩ : ℍ) = ⟨w + N, hw'⟩ := by
+      rw [← zpow_natCast, modular_T_zpow_smul]
+      ext1
+      simp [add_comm]
+    rw [← hT, smul_eq_self_of_mem N hF (T_pow_mem_Gamma N)]
+  · push Not at hw
+    have hw' : (w + N).im ≤ 0 := by simpa using hw
+    simp only [Function.comp_apply, ofComplex_apply_of_im_nonpos hw,
+      ofComplex_apply_of_im_nonpos hw']
+
+theorem exists_isBoundedAtImInfty_mul_pow {F : ℍ → ℂ} (hF : F ∈ ring N) :
+    ∃ m : ℕ, IsBoundedAtImInfty (F * (Δ : ℍ → ℂ) ^ m) := by
+  have hpkg := WLight.frickeFunction_orbit_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  have hΔb : ∀ k : ℕ, IsBoundedAtImInfty ((Δ : ℍ → ℂ) ^ k) := fun k =>
+    ((good_discriminant N).pow k).bdd
+  induction hF using Algebra.adjoin_induction with
+  | mem G hG =>
+    rcases hG with rfl | ⟨v, hv, rfl⟩
+    · exact hpkg.1.2
+    · exact (hpkg.2.1 v hv).2
+  | algebraMap c =>
+    refine ⟨0, ?_⟩
+    rw [pow_zero, mul_one]
+    exact Filter.const_boundedAtFilter _ _
+  | add F G _ _ ihF ihG =>
+    obtain ⟨m, hm⟩ := ihF
+    obtain ⟨n, hn⟩ := ihG
+    refine ⟨m + n, ?_⟩
+    have : (F + G) * (Δ : ℍ → ℂ) ^ (m + n) =
+        F * (Δ : ℍ → ℂ) ^ m * (Δ : ℍ → ℂ) ^ n + G * (Δ : ℍ → ℂ) ^ n * (Δ : ℍ → ℂ) ^ m := by ring
+    rw [this]
+    exact (hm.mul (hΔb n)).add (hn.mul (hΔb m))
+  | mul F G _ _ ihF ihG =>
+    obtain ⟨m, hm⟩ := ihF
+    obtain ⟨n, hn⟩ := ihG
+    refine ⟨m + n, ?_⟩
+    have : (F * G) * (Δ : ℍ → ℂ) ^ (m + n) = (F * (Δ : ℍ → ℂ) ^ m) * (G * (Δ : ℍ → ℂ) ^ n) := by
+      ring
+    rw [this]
+    exact hm.mul hn
+
+end Ring
+
+section Width
+
+variable (N : ℕ) [NeZero N]
+
+theorem qParam_pow_mul (τ : ℍ) (n : ℕ) :
+    Periodic.qParam (N : ℝ) (τ : ℂ) ^ (N * n) = Periodic.qParam 1 (τ : ℂ) ^ n := by
+  have hN : (N : ℂ) ≠ 0 := by exact_mod_cast NeZero.ne N
+  rw [pow_mul]
+  congr 1
+  rw [Periodic.qParam, Periodic.qParam, ← Complex.exp_nat_mul]
+  congr 1
+  push_cast
+  field_simp
+
+
+theorem Q_natCast_eq_qExpand {f : ℍ → ℂ} (hf : Good 1 f) :
+    Q N f = ModularCurve.qExpand ℂ N (Q 1 f) := by
+  have hNpos : (0 : ℝ) < N := Nat.cast_pos.mpr (NeZero.pos N)
+  have hN0 : (N : ℕ) ≠ 0 := NeZero.ne N
+  set a : ℕ → ℂ := fun m => (qExpansion 1 f).coeff m with ha
+  have hsum1 : ∀ τ : ℍ, HasSum (fun m => a m • Periodic.qParam 1 (τ : ℂ) ^ m) (f τ) :=
+    fun τ => hasSum_qExpansion one_pos hf.periodic hf.mdiff hf.bdd τ
+  have hinj : Function.Injective (fun n : ℕ => N * n) := mul_right_injective₀ hN0
+  set c : ℕ → ℂ := Function.extend (fun n : ℕ => N * n) a 0 with hc
+  have hc_apply : ∀ n, c (N * n) = a n := fun n => hinj.extend_apply _ _ n
+  have hc_zero : ∀ m, (¬ ∃ n, N * n = m) → c m = 0 := fun m hm => by
+    rw [hc, Function.extend_apply' _ _ _ hm]; rfl
+  have hsumN : ∀ τ : ℍ, HasSum (fun m => c m • Periodic.qParam (N : ℝ) (τ : ℂ) ^ m) (f τ) := by
+    intro τ
+    have key : (fun m => c m • Periodic.qParam (N : ℝ) (τ : ℂ) ^ m) =
+        Function.extend (fun n : ℕ => N * n) (fun n => a n • Periodic.qParam 1 (τ : ℂ) ^ n) 0 := by
+      funext m
+      by_cases hm : ∃ n, N * n = m
+      · obtain ⟨n, rfl⟩ := hm
+        rw [hinj.extend_apply, hc_apply, qParam_pow_mul]
+      · rw [Function.extend_apply' _ _ _ hm, hc_zero m hm, zero_smul]; rfl
+    rw [key, hasSum_extend_zero hinj]
+    exact hsum1 τ
+  have hgoodN : Good N f :=
+    { periodic := by simpa using hf.periodic.nat_mul N
+      mdiff := hf.mdiff
+      bdd := hf.bdd }
+  have hcoeff : ∀ m, c m = (qExpansion N f).coeff m := by
+    have hsumN' : ∀ τ : ℍ, HasSum (fun m => (qExpansion N f).coeff m • Periodic.qParam (N : ℝ)
+        (τ : ℂ) ^ m) (f τ) :=
+      fun τ => hasSum_qExpansion hNpos hgoodN.periodic hgoodN.mdiff hgoodN.bdd τ
+    have h1 := (hasFPowerSeriesOnBall_cuspFunction hNpos (hgoodN.analyticAt hNpos)
+      hsumN).hasFPowerSeriesAt
+    have h2 := (hasFPowerSeriesOnBall_cuspFunction hNpos (hgoodN.analyticAt hNpos)
+      hsumN').hasFPowerSeriesAt
+    have heq := h1.eq_formalMultilinearSeries h2
+    have := (FormalMultilinearSeries.ofScalars_series_eq_iff (E := ℂ) c _).mp heq
+    exact fun m => congrFun this m
+  ext k
+  rw [Q, Q]
+  rcases lt_or_ge k 0 with hk | hk
+  · rw [ModularCurve.ofPowerSeries_coeff_of_neg _ hk]
+    by_cases hdvd : (N : ℤ) ∣ k
+    · obtain ⟨k', rfl⟩ := hdvd
+      rw [ModularCurve.qExpand_coeff_mul]
+      have hk' : k' < 0 := by
+        by_contra h; push Not at h
+        have : (0 : ℤ) ≤ (N : ℤ) * k' := mul_nonneg (by positivity) h
+        omega
+      rw [ModularCurve.ofPowerSeries_coeff_of_neg _ hk']
+    · rw [ModularCurve.qExpand_coeff_of_not_dvd N _ hdvd]
+  · lift k to ℕ using hk
+    rw [HahnSeries.ofPowerSeries_apply_coeff, ← hcoeff]
+    by_cases hdvd : (N : ℤ) ∣ (k : ℤ)
+    · obtain ⟨k', hk'⟩ := hdvd
+      have hk'0 : 0 ≤ k' := by
+        by_contra h; push Not at h
+        have : (N : ℤ) * k' < 0 := mul_neg_of_pos_of_neg (by exact_mod_cast NeZero.pos N) h
+        omega
+      lift k' to ℕ using hk'0
+      have hkk : k = N * k' := by exact_mod_cast hk'
+      rw [hk', ModularCurve.qExpand_coeff_mul, HahnSeries.ofPowerSeries_apply_coeff, hkk, hc_apply]
+    · rw [ModularCurve.qExpand_coeff_of_not_dvd N _ hdvd, hc_zero]
+      rintro ⟨n, hn⟩
+      exact hdvd ⟨n, by rw [← hn]; push_cast; ring⟩
+
+end Width
+
+section Forms
+
+local notation "Δ" => ModularForm.discriminant
+
+variable {Γ : Subgroup SL(2, ℤ)} {k : ℤ}
+
+abbrev den (γ : SL(2, ℤ)) (τ : ℍ) : ℂ := denom (γ : GL (Fin 2) ℝ) τ
+
+theorem den_ne_zero (γ : SL(2, ℤ)) (τ : ℍ) : den γ τ ≠ 0 := denom_ne_zero _ _
+
+variable (k) in
+theorem apply_smul_eq_slash (f : ℍ → ℂ) (γ : SL(2, ℤ)) (τ : ℍ) :
+    f (γ • τ) = (f ∣[k] γ) τ * den γ τ ^ k := by
+  rw [ModularForm.SL_slash_apply, mul_assoc, ← zpow_add₀ (den_ne_zero γ τ), neg_add_cancel,
+    zpow_zero, mul_one]
+
+theorem discriminant_smul (γ : SL(2, ℤ)) (τ : ℍ) : Δ (γ • τ) = den γ τ ^ (12 : ℤ) * Δ τ := by
+  have hmem : (γ : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ, rfl⟩
+  have := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hmem τ
+  simpa [ModularGroup.sl_moeb] using this
+
+theorem apply_smul_of_mem
+    (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) {δ : SL(2, ℤ)} (hδ : δ ∈ Γ)
+    (τ : ℍ) : f (δ • τ) = den δ τ ^ k * f τ := by
+  have hmem : (δ : GL (Fin 2) ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)) := ⟨δ, hδ, rfl⟩
+  have := SlashInvariantForm.slash_action_eqn'' f hmem τ
+  simpa [ModularGroup.sl_moeb] using this
+
+theorem one_mem_strictPeriods (hT : ModularGroup.T ∈ Γ) :
+    (1 : ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  rw [Subgroup.strictPeriods_eq_zmultiples_one_of_T_mem hT]
+  exact AddSubgroup.mem_zmultiples _
+
+theorem good_coe (hT : ModularGroup.T ∈ Γ) [Γ.FiniteIndex]
+    (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) : Good 1 (f : ℍ → ℂ) where
+  periodic := SlashInvariantFormClass.periodic_comp_ofComplex f (one_mem_strictPeriods hT)
+  mdiff := f.holo'
+  bdd := ModularFormClass.bdd_at_infty f
+
+theorem isBoundedAtImInfty_slash [Γ.FiniteIndex] (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (γ : SL(2, ℤ)) : IsBoundedAtImInfty ((f : ℍ → ℂ) ∣[k] γ) :=
+  ModularFormClass.bdd_at_infty_slash f γ
+
+end Forms
+
+section Quotients
+
+local notation "Δ" => ModularForm.discriminant
+
+def FF (k : ℤ) (f g : ℍ → ℂ) : ℍ → ℂ := fun τ => f τ * g τ ^ 11 * Δ τ ^ (-k)
+
+theorem FF_apply (k : ℤ) (f g : ℍ → ℂ) (τ : ℍ) : FF k f g τ = f τ * g τ ^ 11 * Δ τ ^ (-k) := rfl
+
+theorem zpow_neg_mul_pow_toNat (x : ℂ) (hx : x ≠ 0) (k : ℤ) :
+    x ^ (-k) * x ^ k.toNat = x ^ (-k).toNat := by
+  rw [← zpow_natCast, ← zpow_natCast, ← zpow_add₀ hx]
+  congr 1
+  have := Int.toNat_sub_toNat_neg k
+  omega
+
+theorem FF_mul_pow (k : ℤ) (f g : ℍ → ℂ) :
+    FF k f g * (Δ : ℍ → ℂ) ^ k.toNat = f * g ^ 11 * (Δ : ℍ → ℂ) ^ (-k).toNat := by
+  funext τ
+  simp only [Pi.mul_apply, Pi.pow_apply, FF_apply]
+  rw [mul_assoc, zpow_neg_mul_pow_toNat _ (ModularForm.discriminant_ne_zero τ)]
+
+theorem mdifferentiable_discriminant : MDiff (Δ : ℍ → ℂ) := CuspForm.discriminant.holo'
+
+theorem mdifferentiable_discriminant_zpow (n : ℤ) : MDiff (fun τ : ℍ => Δ τ ^ n) := by
+  rw [UpperHalfPlane.mdifferentiable_iff]
+  have hd : DifferentiableOn ℂ ((Δ : ℍ → ℂ) ∘ ofComplex) {z : ℂ | 0 < z.im} :=
+    UpperHalfPlane.mdifferentiable_iff.mp mdifferentiable_discriminant
+  have : (fun τ : ℍ => Δ τ ^ n) ∘ ofComplex = fun z => ((Δ : ℍ → ℂ) ∘ ofComplex) z ^ n := rfl
+  rw [this]
+  exact hd.zpow (Or.inl fun z hz => by
+    rw [Function.comp_apply]; exact ModularForm.discriminant_ne_zero _)
+
+theorem mdifferentiable_FF (k : ℤ) {f g : ℍ → ℂ} (hf : MDiff f) (hg : MDiff g) :
+    MDiff (FF k f g) := by
+  have : FF k f g = f * g ^ 11 * (fun τ : ℍ => Δ τ ^ (-k)) := by
+    funext τ; simp [FF_apply]
+  rw [this]
+  exact (hf.mul (hg.pow 11)).mul (mdifferentiable_discriminant_zpow (-k))
+
+theorem factor_cancel (d : ℂ) (hd : d ≠ 0) (k : ℤ) :
+    d ^ k * (d ^ k) ^ 11 * (d ^ (12 : ℤ)) ^ (-k) = 1 := by
+  rw [← zpow_natCast (d ^ k) 11, ← zpow_mul, ← zpow_mul, ← zpow_add₀ hd, ← zpow_add₀ hd]
+  have : k + k * ((11 : ℕ) : ℤ) + 12 * -k = 0 := by push_cast; ring
+  rw [this, zpow_zero]
+
+theorem FF_smul (k : ℤ) (f g : ℍ → ℂ) (γ : SL(2, ℤ)) (τ : ℍ) :
+    FF k f g (γ • τ) = FF k (f ∣[k] γ) (g ∣[k] γ) τ := by
+  rw [FF_apply, FF_apply, apply_smul_eq_slash k f γ τ, apply_smul_eq_slash k g γ τ,
+      discriminant_smul γ τ]
+  have hd := den_ne_zero γ τ
+  set d := den γ τ
+  rw [mul_pow, mul_zpow]
+  have hc := factor_cancel d hd k
+  calc (f ∣[k] γ) τ * d ^ k * ((g ∣[k] γ) τ ^ 11 * (d ^ k) ^ 11)
+          * ((d ^ (12 : ℤ)) ^ (-k) * Δ τ ^ (-k))
+    = (f ∣[k] γ) τ * (g ∣[k] γ) τ ^ 11 * Δ τ ^ (-k)
+          * (d ^ k * (d ^ k) ^ 11 * (d ^ (12 : ℤ)) ^ (-k)) := by
+        ring
+    _ = (f ∣[k] γ) τ * (g ∣[k] γ) τ ^ 11 * Δ τ ^ (-k) := by rw [hc, mul_one]
+
+variable {Γ : Subgroup SL(2, ℤ)} {k : ℤ}
+
+theorem FF_smul_of_mem (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    {δ : SL(2, ℤ)} (hδ : δ ∈ Γ) (τ : ℍ) :
+    FF k f g (δ • τ) = FF k f g τ := by
+  rw [FF_smul]
+  have hmem : (δ : GL (Fin 2) ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)) := ⟨δ, hδ, rfl⟩
+  have hf : (f : ℍ → ℂ) ∣[k] δ = f := by
+    rw [ModularForm.SL_slash]; exact SlashInvariantFormClass.slash_action_eq f _ hmem
+  have hg : (g : ℍ → ℂ) ∣[k] δ = g := by
+    rw [ModularForm.SL_slash]; exact SlashInvariantFormClass.slash_action_eq g _ hmem
+  rw [hf, hg]
+
+theorem isBoundedAtImInfty_FF_smul [Γ.FiniteIndex]
+    (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (γ : SL(2, ℤ)) : IsBoundedAtImInfty ((fun τ => FF k f g (γ • τ)) * (Δ : ℍ → ℂ) ^ k.toNat) := by
+  have : (fun τ => FF k f g (γ • τ)) = FF k ((f : ℍ → ℂ) ∣[k] γ) ((g : ℍ → ℂ) ∣[k] γ) := by
+    funext τ; exact FF_smul k f g γ τ
+  rw [this, FF_mul_pow]
+  have hg11 : IsBoundedAtImInfty (((g : ℍ → ℂ) ∣[k] γ) ^ 11) := by
+    have hb := isBoundedAtImInfty_slash g γ
+    have : ∀ n : ℕ, IsBoundedAtImInfty (((g : ℍ → ℂ) ∣[k] γ) ^ n) := by
+      intro n
+      induction n with
+      | zero => rw [pow_zero]; exact Filter.const_boundedAtFilter _ _
+      | succ n ih => rw [pow_succ]; exact ih.mul hb
+    exact this 11
+  exact ((isBoundedAtImInfty_slash f γ).mul hg11).mul (((good_discriminant 1).pow _).bdd)
+
+end Quotients
+
+section Family
+
+local notation "Δ" => ModularForm.discriminant
+
+variable (M : ℕ) [NeZero M]
+
+theorem castM_pos : (0 : ℝ) < M := Nat.cast_pos.mpr (NeZero.pos M)
+
+def PB (F : ℍ → ℂ) (m : ℕ) : Prop := IsBoundedAtImInfty (F * (Δ : ℍ → ℂ) ^ m)
+
+theorem PB.add_right {F : ℍ → ℂ} {m : ℕ} (hm : PB F m) (k : ℕ) : PB F (m + k) := by
+  unfold PB at hm ⊢
+  rw [pow_add, ← mul_assoc]
+  exact hm.mul ((good_discriminant 1).pow k).bdd
+
+theorem good_of_PB {F : ℍ → ℂ} (hF : F ∈ ring M) {m : ℕ} (hm : PB F m) :
+    Good M (F * (Δ : ℍ → ℂ) ^ m) where
+  periodic := by
+    have : (F * (Δ : ℍ → ℂ) ^ m) ∘ ofComplex = (F ∘ ofComplex) * (((Δ : ℍ → ℂ) ^ m) ∘ ofComplex) :=
+      rfl
+    rw [this]
+    exact (periodic_of_mem M hF).mul ((good_discriminant M).pow m).periodic
+  mdiff := (mdifferentiable_of_mem M hF).mul ((good_discriminant M).pow m).mdiff
+  bdd := hm
+
+def famS : Set (ℍ → ℂ) :=
+  {G | MDiff G ∧ (∀ δ ∈ CongruenceSubgroup.Gamma M, ∀ τ : ℍ, G (δ • τ) = G τ) ∧
+    ∀ γ : SL(2, ℤ), ∃ m : ℕ, IsBoundedAtImInfty ((fun τ => G (γ • τ)) * (Δ : ℍ → ℂ) ^ m)}
+
+theorem mdifferentiable_sl_smul (γ : SL(2, ℤ)) : MDiff (fun τ : ℍ => γ • τ) := by
+  have : (fun τ : ℍ => γ • τ) = fun τ : ℍ => (γ : GL (Fin 2) ℝ) • τ := by
+    funext τ; exact ModularGroup.sl_moeb γ τ
+  rw [this]
+  apply UpperHalfPlane.mdifferentiable_smul
+  simp
+
+omit [NeZero M] in
+theorem famS_stable (γ : SL(2, ℤ)) : ∀ G ∈ famS M, (G ∘ (γ • ·)) ∈ famS M := by
+  rintro G ⟨hG, hinv, hpb⟩
+  have : (CongruenceSubgroup.Gamma M).Normal := CongruenceSubgroup.Gamma_normal M
+  refine ⟨hG.comp (mdifferentiable_sl_smul γ), fun δ hδ τ => ?_, fun γ' => ?_⟩
+  · change G (γ • δ • τ) = G (γ • τ)
+    have hconj : γ * δ * γ⁻¹ ∈ CongruenceSubgroup.Gamma M :=
+      Subgroup.Normal.conj_mem inferInstance δ hδ γ
+    have := hinv _ hconj (γ • τ)
+    rw [← this, ← mul_smul, ← mul_smul]
+    congr 1
+    group
+  · obtain ⟨m, hm⟩ := hpb (γ * γ')
+    refine ⟨m, ?_⟩
+    have : (fun τ => (G ∘ (γ • ·)) (γ' • τ)) = fun τ => G ((γ * γ') • τ) := by
+      funext τ; simp [mul_smul]
+    rw [this]; exact hm
+
+theorem exists_levelFraction {G : ℍ → ℂ} (hG : G ∈ famS M) :
+    ∃ a b : ℍ → ℂ, a ∈ ring M ∧ b ∈ ring M ∧ b ≠ 0 ∧ G * b = a :=
+  WLight.exists_levelFraction_of_stable_family M PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp M)
+    (fun v τ => rfl) (fricke M) (fun v τ => rfl) jAnalytic (fun τ => rfl) (famS M)
+    (fun G hG => hG.1)
+    (fun G hG => by
+      obtain ⟨m, hm⟩ := hG.2.2 1
+      exact ⟨m, by simpa using hm⟩)
+    (famS_stable M) (fun G hG => hG.2.1) hG
+
+variable {Γ : Subgroup SL(2, ℤ)} {k : ℤ}
+
+omit [NeZero M] in
+theorem FF_mem_famS (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) [Γ.FiniteIndex]
+    (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) : FF k f g ∈ famS M :=
+  ⟨mdifferentiable_FF k f.holo' g.holo', fun _ hδ τ => FF_smul_of_mem f g (hΓ hδ) τ,
+    fun γ => ⟨k.toNat, isBoundedAtImInfty_FF_smul f g γ⟩⟩
+
+theorem periodic_FF (hT : ModularGroup.T ∈ Γ) [Γ.FiniteIndex]
+    (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) : Periodic (FF k f g ∘ ofComplex) 1 := by
+  intro z
+  have hf := (good_coe hT f).periodic z
+  have hg := (good_coe hT g).periodic z
+  have hΔ :=
+    (by simpa using (good_discriminant 1).periodic : Periodic ((Δ : ℍ → ℂ) ∘ ofComplex) 1) z
+  simp only [Function.comp_apply, Complex.ofReal_one] at hf hg hΔ ⊢
+  rw [FF_apply, FF_apply, hf, hg, hΔ]
+
+omit [NeZero M] in
+theorem good_FF_mul_pow (hT : ModularGroup.T ∈ Γ) [Γ.FiniteIndex]
+    (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) :
+    Good M (FF k f g * (Δ : ℍ → ℂ) ^ k.toNat) where
+  periodic := by
+    have h1 : Periodic ((FF k f g * (Δ : ℍ → ℂ) ^ k.toNat) ∘ ofComplex) 1 := by
+      have : (FF k f g * (Δ : ℍ → ℂ) ^ k.toNat) ∘ ofComplex =
+          (FF k f g ∘ ofComplex) * (((Δ : ℍ → ℂ) ^ k.toNat) ∘ ofComplex) := rfl
+      rw [this]
+      exact (periodic_FF hT f g).mul (by simpa using ((good_discriminant 1).pow k.toNat).periodic)
+    simpa using h1.nat_mul M
+  mdiff := (mdifferentiable_FF k f.holo' g.holo').mul ((good_discriminant M).pow _).mdiff
+  bdd := by simpa using isBoundedAtImInfty_FF_smul f g 1
+
+omit [NeZero M] in
+theorem Good.of_one {f : ℍ → ℂ} (hf : Good 1 f) : Good M f where
+  periodic := by simpa using hf.periodic.nat_mul M
+  mdiff := hf.mdiff
+  bdd := hf.bdd
+
+theorem Q_FF_mul_pow (hT : ModularGroup.T ∈ Γ) [Γ.FiniteIndex]
+    (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) :
+    Q M (FF k f g * (Δ : ℍ → ℂ) ^ k.toNat) =
+      Q M f * Q M g ^ 11 * Q M (Δ : ℍ → ℂ) ^ (-k).toNat := by
+  have hM := castM_pos M
+  have hf : Good M (f : ℍ → ℂ) := Good.of_one M (good_coe hT f)
+  have hg : Good M (g : ℍ → ℂ) := Good.of_one M (good_coe hT g)
+  rw [FF_mul_pow, Q_mul hM (hf.mul (hg.pow 11)) ((good_discriminant M).pow _),
+    Q_mul hM hf (hg.pow 11), Q_pow hM hg, Q_pow hM (good_discriminant M)]
+
+end Family
+
+section Expansion
+
+local notation "Δ" => ModularForm.discriminant
+
+variable (M : ℕ) [NeZero M]
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ring M) K] [IsScalarTower ℂ (ring M) K]
+  [IsFractionRing (ring M) K]
+
+def E : K →ₐ[ℂ] LaurentSeries ℂ :=
+  (ModularCurve.LevelN.exists_algHom_laurentSeries_qExpansion M K).choose
+
+theorem E_jGen : E M K (algebraMap (ring M) K (jGen M)) = ModularCurve.qExpand ℂ M (jqModC ℂ) :=
+  (ModularCurve.LevelN.exists_algHom_laurentSeries_qExpansion M K).choose_spec.1
+
+theorem E_mul_pow (F : ℍ → ℂ) (hF : F ∈ ring M) (m : ℕ)
+    (hm : IsBoundedAtImInfty (F * (Δ : ℍ → ℂ) ^ m)) :
+    E M K (algebraMap (ring M) K ⟨F, hF⟩) * Q M (Δ : ℍ → ℂ) ^ m = Q M (F * (Δ : ℍ → ℂ) ^ m) :=
+  (ModularCurve.LevelN.exists_algHom_laurentSeries_qExpansion M K).choose_spec.2 F hF m hm
+
+theorem E_injective : Function.Injective (E M K) := (E M K).toRingHom.injective
+
+omit [NeZero M] [Algebra ℂ K] [IsScalarTower ℂ (↥(ring M)) K] in
+theorem algebraMap_ne_zero {b : ℍ → ℂ} (hb : b ∈ ring M) (hb0 : b ≠ 0) :
+    algebraMap (ring M) K ⟨b, hb⟩ ≠ 0 := by
+  intro h
+  have : (⟨b, hb⟩ : ring M) = 0 := (IsFractionRing.injective (ring M) K) (by rw [h, map_zero])
+  exact hb0 (congrArg Subtype.val this)
+
+
+theorem E_div_eq {G a b : ℍ → ℂ} (ha : a ∈ ring M) (hb : b ∈ ring M) (hb0 : b ≠ 0) (hGb : G * b = a)
+    {p : ℕ} (hGp : Good M (G * (Δ : ℍ → ℂ) ^ p)) :
+    E M K (algebraMap (ring M) K ⟨a, ha⟩) / E M K (algebraMap (ring M) K ⟨b, hb⟩) =
+      Q M (G * (Δ : ℍ → ℂ) ^ p) / Q M (Δ : ℍ → ℂ) ^ p := by
+  have hM := castM_pos M
+  have hΔ0 : Q M (Δ : ℍ → ℂ) ≠ 0 := Q_discriminant_ne_zero M
+  obtain ⟨mb, hmb⟩ := exists_isBoundedAtImInfty_mul_pow M hb
+  have hgoodb := good_of_PB M hb hmb
+  have ham : IsBoundedAtImInfty (a * (Δ : ℍ → ℂ) ^ (mb + p)) := by
+    have : a * (Δ : ℍ → ℂ) ^ (mb + p) = (b * (Δ : ℍ → ℂ) ^ mb) * (G * (Δ : ℍ → ℂ) ^ p) := by
+      rw [← hGb]; ring
+    rw [this]; exact hmb.mul hGp.bdd
+  have hEa := E_mul_pow M K a ha (mb + p) ham
+  have hEb := E_mul_pow M K b hb mb hmb
+  have hsplit : Q M (a * (Δ : ℍ → ℂ) ^ (mb + p)) =
+      Q M (b * (Δ : ℍ → ℂ) ^ mb) * Q M (G * (Δ : ℍ → ℂ) ^ p) := by
+    rw [← Q_mul hM hgoodb hGp]
+    congr 1
+    rw [← hGb]; ring
+  have hEb0 : E M K (algebraMap (ring M) K ⟨b, hb⟩) ≠ 0 :=
+    (map_ne_zero_iff _ (E_injective M K)).mpr (algebraMap_ne_zero M K hb hb0)
+  have hQb0 : Q M (b * (Δ : ℍ → ℂ) ^ mb) ≠ 0 := by
+    rw [ne_eq, Q_eq_zero_iff hM hgoodb, mul_discriminant_pow_eq_zero_iff]
+    exact hb0
+  rw [hsplit, pow_add] at hEa
+  rw [eq_div_iff (pow_ne_zero p hΔ0), div_mul_eq_mul_div, div_eq_iff hEb0]
+  apply mul_right_cancel₀ (pow_ne_zero mb hΔ0)
+  calc E M K (algebraMap (ring M) K ⟨a, ha⟩) * Q M (Δ : ℍ → ℂ) ^ p * Q M (Δ : ℍ → ℂ) ^ mb
+      = E M K (algebraMap (ring M) K ⟨a, ha⟩)
+          * (Q M (Δ : ℍ → ℂ) ^ mb * Q M (Δ : ℍ → ℂ) ^ p) := by ring
+    _ = Q M (b * (Δ : ℍ → ℂ) ^ mb) * Q M (G * (Δ : ℍ → ℂ) ^ p) := hEa
+    _ = Q M (G * (Δ : ℍ → ℂ) ^ p) * (E M K (algebraMap (ring M) K ⟨b, hb⟩)
+          * Q M (Δ : ℍ → ℂ) ^ mb) := by
+        rw [hEb]; ring
+    _ = Q M (G * (Δ : ℍ → ℂ) ^ p) * E M K (algebraMap (ring M) K ⟨b, hb⟩)
+          * Q M (Δ : ℍ → ℂ) ^ mb := by
+        ring
+
+variable {Γ : Subgroup SL(2, ℤ)} {k : ℤ}
+
+theorem comp_smul_ne_zero {b : ℍ → ℂ} (hb0 : b ≠ 0) (γ : SL(2, ℤ)) :
+    (fun τ : ℍ => b (γ • τ)) ≠ 0 := by
+  intro h
+  apply hb0
+  funext τ
+  have := congrFun h (γ⁻¹ • τ)
+  simpa using this
+
+theorem exists_kappa (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ) [Γ.FiniteIndex]
+    (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hg0 : (g : ℍ → ℂ) ≠ 0) :
+    ∃ κ : K, E M K κ = Q M f / Q M g ∧
+      ∀ γ ∈ Γ, ∀ (hst : ∀ G ∈ ring M, (fun τ : ℍ => G (γ⁻¹ • τ)) ∈ ring M) (φ : K ≃ₐ[ℂ] K),
+        (∀ (G : ℍ → ℂ) (hG : G ∈ ring M), φ (algebraMap (ring M) K ⟨G, hG⟩)
+          = algebraMap (ring M) K ⟨fun τ : ℍ => G (γ⁻¹ • τ), hst G hG⟩) →
+        φ κ = κ := by
+  have hM := castM_pos M
+  have hΔ0 : Q M (Δ : ℍ → ℂ) ≠ 0 := Q_discriminant_ne_zero M
+  obtain ⟨a, b, ha, hb, hb0, hab⟩ := exists_levelFraction M (FF_mem_famS M hΓ f g)
+  obtain ⟨a', b', ha', hb', hb0', hab'⟩ := exists_levelFraction M (FF_mem_famS M hΓ g g)
+  refine ⟨(algebraMap (ring M) K ⟨a, ha⟩ / algebraMap (ring M) K ⟨b, hb⟩) /
+    (algebraMap (ring M) K ⟨a', ha'⟩ / algebraMap (ring M) K ⟨b', hb'⟩), ?_, ?_⟩
+  · have h1 := E_div_eq M K ha hb hb0 hab (good_FF_mul_pow M hT f g)
+    have h2 := E_div_eq M K ha' hb' hb0' hab' (good_FF_mul_pow M hT g g)
+    simp only [map_div₀]
+    rw [h1, h2, Q_FF_mul_pow M hT f g, Q_FF_mul_pow M hT g g]
+    have hQg : Q M (g : ℍ → ℂ) ≠ 0 := by
+      rw [ne_eq, Q_eq_zero_iff hM (Good.of_one M (good_coe hT g))]; exact hg0
+    field_simp
+  · intro γ hγ hst φ hφ
+    have hγ' : γ⁻¹ ∈ Γ := Γ.inv_mem hγ
+    have key : ∀ (G a b : ℍ → ℂ) (ha : a ∈ ring M) (hb : b ∈ ring M), b ≠ 0 → G * b = a →
+        (∀ τ, G (γ⁻¹ • τ) = G τ) →
+        φ (algebraMap (ring M) K ⟨a, ha⟩ / algebraMap (ring M) K ⟨b, hb⟩) =
+          algebraMap (ring M) K ⟨a, ha⟩ / algebraMap (ring M) K ⟨b, hb⟩ := by
+      intro G a b ha hb hb0 hGb hGinv
+      rw [map_div₀, hφ a ha, hφ b hb]
+      have hb0'' : (fun τ : ℍ => b (γ⁻¹ • τ)) ≠ 0 := comp_smul_ne_zero hb0 γ⁻¹
+      rw [div_eq_div_iff (algebraMap_ne_zero M K (hst b hb) hb0'') (algebraMap_ne_zero M K hb hb0),
+        ← map_mul, ← map_mul]
+      congr 1
+      apply Subtype.ext
+      change (fun τ : ℍ => a (γ⁻¹ • τ)) * b = a * (fun τ : ℍ => b (γ⁻¹ • τ))
+      funext τ
+      simp only [Pi.mul_apply]
+      have h1 := congrFun hGb (γ⁻¹ • τ)
+      have h2 := congrFun hGb τ
+      simp only [Pi.mul_apply] at h1 h2
+      rw [← h1, ← h2, hGinv τ]
+      ring
+    rw [map_div₀, key _ a b ha hb hb0 hab (fun τ => FF_smul_of_mem f g hγ' τ),
+      key _ a' b' ha' hb' hb0' hab' (fun τ => FF_smul_of_mem g g hγ' τ)]
+
+end Expansion
+
+section Bridge
+
+local notation "ℚ̄" => AlgebraicClosure ℚ
+
+variable (M : ℕ) [NeZero M]
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ring M) K] [IsScalarTower ℂ (ring M) K]
+  [IsFractionRing (ring M) K]
+variable (Γ : Subgroup SL(2, ℤ))
+
+def fixedSub : Subfield K where
+  carrier := {κ | ∀ γ ∈ Γ, ∀ (hst : ∀ G ∈ ring M, (fun τ : ℍ => G (γ⁻¹ • τ)) ∈ ring M)
+    (φ : K ≃ₐ[ℂ] K), (∀ (G : ℍ → ℂ) (hG : G ∈ ring M),
+        φ (algebraMap (ring M) K ⟨G, hG⟩) =
+      algebraMap (ring M) K ⟨fun τ : ℍ => G (γ⁻¹ • τ), hst G hG⟩) →
+    φ κ = κ}
+  mul_mem' {x y} hx hy := fun γ hγ hst φ hφ => by rw [map_mul, hx γ hγ hst φ hφ, hy γ hγ hst φ hφ]
+  one_mem' := fun γ hγ hst φ hφ => map_one φ
+  add_mem' {x y} hx hy := fun γ hγ hst φ hφ => by rw [map_add, hx γ hγ hst φ hφ, hy γ hγ hst φ hφ]
+  zero_mem' := fun γ hγ hst φ hφ => map_zero φ
+  neg_mem' {x} hx := fun γ hγ hst φ hφ => by rw [map_neg, hx γ hγ hst φ hφ]
+  inv_mem' x hx := fun γ hγ hst φ hφ => by rw [map_inv₀, hx γ hγ hst φ hφ]
+
+omit [NeZero M] [IsScalarTower ℂ (↥(ring M)) K] [IsFractionRing (↥(ring M)) K] in
+theorem algebraMap_mem_fixedSub (c : ℂ) : algebraMap ℂ K c ∈ fixedSub M K Γ :=
+  fun _ _ _ φ _ => φ.commutes c
+
+def goodSeries : Subfield (LaurentSeries ℂ) := (fixedSub M K Γ).map (E M K).toRingHom
+
+theorem algebraMap_laurentSeries (c : ℂ) : algebraMap ℂ (LaurentSeries ℂ) c = HahnSeries.C c := by
+  have h1 : algebraMap ℂ (PowerSeries ℂ) c = PowerSeries.C c := by simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+
+variable (ι : ℚ̄ →+* ℂ)
+
+def iotaM : LaurentSeries ℚ̄ →+* LaurentSeries ℂ :=
+  (ModularCurve.qExpand ℂ M).comp (ModularCurve.coeffMap ι)
+
+theorem iotaM_algebraMap (c : ℚ̄) :
+    iotaM M ι (algebraMap ℚ̄ (LaurentSeries ℚ̄) c) = HahnSeries.C (ι c) := by
+  rw [iotaM, RingHom.comp_apply, ModularCurve.algebraMap_laurentSeries_eq_single,
+    ModularCurve.coeffMap_single, ModularCurve.qExpand_single, mul_zero, HahnSeries.C_apply]
+
+theorem const_mem_goodSeries (c : ℚ̄) :
+    iotaM M ι (algebraMap ℚ̄ (LaurentSeries ℚ̄) c) ∈ goodSeries M K Γ :=
+  Subfield.mem_map.mpr ⟨algebraMap ℂ K (ι c), algebraMap_mem_fixedSub M K Γ _, by
+    rw [iotaM_algebraMap]
+    change E M K (algebraMap ℂ K (ι c)) = _
+    rw [AlgHom.commutes, algebraMap_laurentSeries]⟩
+
+theorem coeffMap_ofPowerSeries {R S : Type*} [CommRing R] [CommRing S]
+    (φ : R →+* S) (p : PowerSeries R) :
+    ModularCurve.coeffMap φ (HahnSeries.ofPowerSeries ℤ R p)
+      = HahnSeries.ofPowerSeries ℤ S (p.map φ) := by
+  ext n
+  rw [ModularCurve.coeffMap_coeff]
+  rcases lt_or_ge n 0 with hn | hn
+  · rw [ModularCurve.ofPowerSeries_coeff_of_neg _ hn, ModularCurve.ofPowerSeries_coeff_of_neg _ hn,
+      map_zero]
+  · lift n to ℕ using hn
+    rw [HahnSeries.ofPowerSeries_apply_coeff, HahnSeries.ofPowerSeries_apply_coeff,
+      PowerSeries.coeff_map]
+
+theorem iotaM_coeffEmb_intSeriesC {h : ℍ → ℂ} {p : PowerSeries ℤ} (hp : IsIntegralQExp h p) :
+    iotaM M ι (coeffEmb ℚ̄ (intSeriesC ℚ p)) = ModularCurve.qExpand ℂ M (Q 1 h) := by
+  rw [iotaM, RingHom.comp_apply]
+  congr 1
+  rw [coeffEmb, intSeriesC, ModularCurve.coeffMap_coeffMap, coeffMap_ofPowerSeries]
+  have hmap : PowerSeries.map (ι.comp (algebraMap ℚ ℚ̄)) (PowerSeries.map (Int.castRingHom ℚ) p) =
+      PowerSeries.map (Int.castRingHom ℂ) p := by
+    rw [← RingHom.comp_apply (PowerSeries.map (ι.comp (algebraMap ℚ ℚ̄)))
+      (PowerSeries.map (Int.castRingHom ℚ)), ← PowerSeries.map_comp,
+      RingHom.ext_int ((ι.comp (algebraMap ℚ ℚ̄)).comp (Int.castRingHom ℚ)) (Int.castRingHom ℂ)]
+  rw [hmap, Q, hp]
+
+variable {Γ}
+
+theorem gen_mem_goodSeries (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ)
+    [Γ.FiniteIndex] {x : LaurentSeries ℚ} (hx : x ∈ intFormRatiosC ℚ Γ) :
+    iotaM M ι (coeffEmb ℚ̄ x) ∈ goodSeries M K Γ := by
+  obtain ⟨k, f, g, pf, pg, hf, hg, hpg0, rfl⟩ := hx
+  have hg0 : (g : ℍ → ℂ) ≠ 0 := by
+    intro h0
+    apply hpg0
+    have h1 : pg.map (Int.castRingHom ℂ) = 0 := by
+      rw [hg, h0, qExpansion_zero]
+    have h2 : pg = 0 :=
+      PowerSeries.map_injective (Int.castRingHom ℂ) Int.cast_injective (by rw [h1, map_zero])
+    rw [h2, intSeriesC_zero]
+  obtain ⟨κ, hκ, hfix⟩ := exists_kappa M K hΓ hT f g hg0
+  refine Subfield.mem_map.mpr ⟨κ, fun γ hγ hst φ hφ => hfix γ hγ hst φ hφ, ?_⟩
+  change E M K κ = _
+  rw [hκ, map_div₀, map_div₀, iotaM_coeffEmb_intSeriesC M ι hf, iotaM_coeffEmb_intSeriesC M ι hg,
+    Q_natCast_eq_qExpand M (good_coe hT f), Q_natCast_eq_qExpand M (good_coe hT g)]
+
+theorem laurentBaseChange_le (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ)
+    [Γ.FiniteIndex]
+    {u : LaurentSeries ℚ̄} (hu : u ∈ laurentBaseChange ℚ̄ (qExpFunctionFieldC ℚ Γ)) :
+    iotaM M ι u ∈ goodSeries M K Γ := by
+  have hF : (laurentBaseChange ℚ̄ (qExpFunctionFieldC ℚ Γ)).toSubfield ≤
+      (goodSeries M K Γ).comap (iotaM M ι) := by
+    rw [laurentBaseChange, IntermediateField.adjoin_toSubfield, Subfield.closure_le]
+    apply Set.union_subset
+    · rintro _ ⟨c, rfl⟩
+      exact const_mem_goodSeries M K Γ ι c
+    · rintro _ ⟨x, hx, rfl⟩
+      change iotaM M ι (coeffEmb ℚ̄ x) ∈ goodSeries M K Γ
+      have hF₀ : (qExpFunctionFieldC ℚ Γ).toSubfield ≤
+          ((goodSeries M K Γ).comap (iotaM M ι)).comap (coeffEmb ℚ̄) := by
+        rw [qExpFunctionFieldC, IntermediateField.adjoin_toSubfield, Subfield.closure_le]
+        apply Set.union_subset
+        · rintro _ ⟨r, rfl⟩
+          change iotaM M ι (coeffEmb ℚ̄ (algebraMap ℚ (LaurentSeries ℚ) r)) ∈ goodSeries M K Γ
+          have : coeffEmb ℚ̄ (algebraMap ℚ (LaurentSeries ℚ) r) =
+              algebraMap ℚ̄ (LaurentSeries ℚ̄) (algebraMap ℚ ℚ̄ r) := by
+            rw [ModularCurve.algebraMap_apply_eq_single, coeffEmb, ModularCurve.coeffMap_single,
+              ModularCurve.algebraMap_laurentSeries_eq_single]
+          rw [this]
+          exact const_mem_goodSeries M K Γ ι _
+        · intro x hx
+          exact gen_mem_goodSeries M K ι hΓ hT hx
+      exact hF₀ hx
+  exact hF hu
+
+variable (Γ)
+
+local notation "FFq" => laurentBaseChange (AlgebraicClosure ℚ) (qExpFunctionFieldC ℚ Γ)
+
+theorem exists_kappa_of_mem (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ)
+    [Γ.FiniteIndex] (u : FFq) :
+    ∃ κ : K, κ ∈ fixedSub M K Γ ∧ E M K κ = iotaM M ι (u : LaurentSeries ℚ̄) :=
+  Subfield.mem_map.mp (laurentBaseChange_le M K ι hΓ hT u.2)
+
+def Phi (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ) [Γ.FiniteIndex] :
+    FFq →+* K where
+  toFun u := (exists_kappa_of_mem M K Γ ι hΓ hT u).choose
+  map_one' := by
+    apply E_injective M K
+    rw [(exists_kappa_of_mem M K Γ ι hΓ hT 1).choose_spec.2, map_one, OneMemClass.coe_one, map_one]
+  map_mul' u v := by
+    apply E_injective M K
+    rw [(exists_kappa_of_mem M K Γ ι hΓ hT (u * v)).choose_spec.2, map_mul,
+      (exists_kappa_of_mem M K Γ ι hΓ hT u).choose_spec.2,
+      (exists_kappa_of_mem M K Γ ι hΓ hT v).choose_spec.2, MulMemClass.coe_mul, map_mul]
+  map_zero' := by
+    apply E_injective M K
+    rw [(exists_kappa_of_mem M K Γ ι hΓ hT 0).choose_spec.2, map_zero, ZeroMemClass.coe_zero,
+      map_zero]
+  map_add' u v := by
+    apply E_injective M K
+    rw [(exists_kappa_of_mem M K Γ ι hΓ hT (u + v)).choose_spec.2, map_add,
+      (exists_kappa_of_mem M K Γ ι hΓ hT u).choose_spec.2,
+      (exists_kappa_of_mem M K Γ ι hΓ hT v).choose_spec.2, AddMemClass.coe_add, map_add]
+
+theorem E_Phi (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ) [Γ.FiniteIndex]
+    (u : FFq) :
+    E M K (Phi M K Γ ι hΓ hT u) = iotaM M ι (u : LaurentSeries ℚ̄) :=
+  (exists_kappa_of_mem M K Γ ι hΓ hT u).choose_spec.2
+
+theorem Phi_mem (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ) [Γ.FiniteIndex]
+    (u : FFq) :
+    Phi M K Γ ι hΓ hT u ∈ fixedSub M K Γ :=
+  (exists_kappa_of_mem M K Γ ι hΓ hT u).choose_spec.1
+
+theorem main (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ) :
+    ∃ Φ : FFq →+* K,
+      (∀ c : ℚ̄, Φ (algebraMap ℚ̄ FFq c) = algebraMap ℂ K (ι c)) ∧
+      (∀ y : FFq, (y : LaurentSeries ℚ̄) = jqModC ℚ̄ → Φ y = algebraMap (ring M) K (jGen M)) ∧
+      ∀ γ ∈ Γ, ∀ (hst : ∀ G ∈ ring M, (fun τ : ℍ => G (γ⁻¹ • τ)) ∈ ring M) (φ : K ≃ₐ[ℂ] K),
+        (∀ (G : ℍ → ℂ) (hG : G ∈ ring M), φ (algebraMap (ring M) K ⟨G, hG⟩)
+          = algebraMap (ring M) K ⟨fun τ : ℍ => G (γ⁻¹ • τ), hst G hG⟩) →
+        ∀ u, φ (Φ u) = Φ u := by
+  have : Γ.FiniteIndex := Subgroup.finiteIndex_of_le hΓ
+  refine ⟨Phi M K Γ ι hΓ hT, fun c => ?_, fun y hy => ?_,
+    fun γ hγ hst φ hφ u => (Phi_mem M K Γ ι hΓ hT u) γ hγ hst φ hφ⟩
+  · apply E_injective M K
+    rw [E_Phi]
+    change iotaM M ι (algebraMap ℚ̄ (LaurentSeries ℚ̄) c) = _
+    rw [iotaM_algebraMap, AlgHom.commutes, algebraMap_laurentSeries]
+  · apply E_injective M K
+    rw [E_Phi, hy, E_jGen, iotaM, RingHom.comp_apply]
+    congr 1
+    exact map_jqModC ι
+
+theorem main2 (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ) :
+    ∃ (Φ : FFq →+* K) (E' : K →ₐ[ℂ] LaurentSeries ℂ),
+      E' (algebraMap (ring M) K (jGen M)) = ModularCurve.qExpand ℂ M (jqModC ℂ) ∧
+      (∀ u : FFq, E' (Φ u) = ModularCurve.qExpand ℂ M (ModularCurve.coeffMap ι
+        (u : LaurentSeries ℚ̄))) ∧
+      (∀ c : ℚ̄, Φ (algebraMap ℚ̄ FFq c) = algebraMap ℂ K (ι c)) ∧
+      (∀ y : FFq, (y : LaurentSeries ℚ̄) = jqModC ℚ̄ → Φ y = algebraMap (ring M) K (jGen M)) ∧
+      ∀ γ ∈ Γ, ∀ (hst : ∀ G ∈ ring M, (fun τ : ℍ => G (γ⁻¹ • τ)) ∈ ring M) (φ : K ≃ₐ[ℂ] K),
+        (∀ (G : ℍ → ℂ) (hG : G ∈ ring M),
+            φ (algebraMap (ring M) K ⟨G, hG⟩) = algebraMap (ring M) K
+              ⟨fun τ : ℍ => G (γ⁻¹ • τ), hst G hG⟩) →
+        ∀ u, φ (Φ u) = Φ u := by
+  have : Γ.FiniteIndex := Subgroup.finiteIndex_of_le hΓ
+  refine ⟨Phi M K Γ ι hΓ hT, E M K, E_jGen M K, fun u => ?_, fun c => ?_, fun y hy => ?_,
+    fun γ hγ hst φ hφ u => (Phi_mem M K Γ ι hΓ hT u) γ hγ hst φ hφ⟩
+  · rw [E_Phi]; rfl
+  · apply E_injective M K
+    rw [E_Phi]
+    change iotaM M ι (algebraMap ℚ̄ (LaurentSeries ℚ̄) c) = _
+    rw [iotaM_algebraMap, AlgHom.commutes, algebraMap_laurentSeries]
+  · apply E_injective M K
+    rw [E_Phi, hy, E_jGen, iotaM, RingHom.comp_apply]
+    congr 1
+    exact map_jqModC ι
+
+end Bridge
+
+end ModularCurve.LevelN.QExpBridge
+end
+
+theorem solution
+    (M : ℕ) [NeZero M] (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+    (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ)
+    (ι : AlgebraicClosure ℚ →+* ℂ)
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring M) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring M) K]
+    [IsFractionRing (ModularCurve.LevelN.ring M) K] :
+    ∃ (Φ : ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+        (ModularCurve.qExpFunctionFieldC ℚ Γ) →+* K) (E : K →ₐ[ℂ] LaurentSeries ℂ),
+      E (algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)) =
+          ModularCurve.qExpand ℂ M (ModularCurve.jqModC ℂ) ∧
+      (∀ u : ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+        (ModularCurve.qExpFunctionFieldC ℚ Γ),
+          E (Φ u) = ModularCurve.qExpand ℂ M (ModularCurve.coeffMap ι (u : LaurentSeries
+            (AlgebraicClosure ℚ)))) ∧
+      (∀ c : AlgebraicClosure ℚ,
+          Φ (algebraMap (AlgebraicClosure ℚ)
+            (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+              (ModularCurve.qExpFunctionFieldC ℚ Γ)) c) =
+            algebraMap ℂ K (ι c)) ∧
+      (∀ y : ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ Γ),
+          (y : LaurentSeries (AlgebraicClosure ℚ)) = ModularCurve.jqModC (AlgebraicClosure ℚ) →
+          Φ y = algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)) ∧
+      ∀ γ ∈ Γ, ∀ (hst : ∀ G ∈ ModularCurve.LevelN.ring M,
+          (fun τ : UpperHalfPlane => G (γ⁻¹ • τ)) ∈ ModularCurve.LevelN.ring M)
+        (φ : K ≃ₐ[ℂ] K),
+        (∀ (G : UpperHalfPlane → ℂ) (hG : G ∈ ModularCurve.LevelN.ring M),
+            φ (algebraMap (ModularCurve.LevelN.ring M) K ⟨G, hG⟩) =
+              algebraMap (ModularCurve.LevelN.ring M) K
+                ⟨fun τ : UpperHalfPlane => G (γ⁻¹ • τ), hst G hG⟩) →
+        ∀ u, φ (Φ u) = Φ u :=
+  ModularCurve.LevelN.QExpBridge.main2 M K Γ ι hΓ hT
+
+end S_ModularCurve_exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN_qExpansion
+end P2MW
+export P2MW.S_ModularCurve_exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN_qExpansion
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN_qExpansion
+    (M : ℕ) [NeZero M] (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+    (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) (hT : ModularGroup.T ∈ Γ)
+    (ι : AlgebraicClosure ℚ →+* ℂ)
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring M) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring M) K]
+    [IsFractionRing (ModularCurve.LevelN.ring M) K] :
+    ∃ (Φ : ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+        (ModularCurve.qExpFunctionFieldC ℚ Γ) →+* K) (E : K →ₐ[ℂ] LaurentSeries ℂ),
+      E (algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)) =
+          ModularCurve.qExpand ℂ M (ModularCurve.jqModC ℂ) ∧
+      (∀ u : ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+        (ModularCurve.qExpFunctionFieldC ℚ Γ),
+          E (Φ u) = ModularCurve.qExpand ℂ M (ModularCurve.coeffMap ι (u : LaurentSeries
+          (AlgebraicClosure ℚ)))) ∧
+      (∀ c : AlgebraicClosure ℚ,
+          Φ (algebraMap (AlgebraicClosure ℚ)
+            (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+              (ModularCurve.qExpFunctionFieldC ℚ Γ)) c) =
+            algebraMap ℂ K (ι c)) ∧
+      (∀ y : ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ Γ),
+          (y : LaurentSeries (AlgebraicClosure ℚ)) = ModularCurve.jqModC (AlgebraicClosure ℚ) →
+          Φ y = algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)) ∧
+      ∀ γ ∈ Γ, ∀ (hst : ∀ G ∈ ModularCurve.LevelN.ring M,
+          (fun τ : UpperHalfPlane => G (γ⁻¹ • τ)) ∈ ModularCurve.LevelN.ring M)
+        (φ : K ≃ₐ[ℂ] K),
+        (∀ (G : UpperHalfPlane → ℂ) (hG : G ∈ ModularCurve.LevelN.ring M),
+            φ (algebraMap (ModularCurve.LevelN.ring M) K ⟨G, hG⟩) =
+              algebraMap (ModularCurve.LevelN.ring M) K
+                ⟨fun τ : UpperHalfPlane => G (γ⁻¹ • τ), hst G hG⟩) →
+        ∀ u, φ (Φ u) = Φ u :=
+  solution M Γ hΓ hT ι K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_ringHom_place_order_eq_mul_ord_of_qExpansion_slash.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_ringHom_place_order_eq_mul_ord_of_qExpansion_slash.lean
new file mode 100644
index 0000000000..1ed70f479c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_ringHom_place_order_eq_mul_ord_of_qExpansion_slash.lean
@@ -0,0 +1,1433 @@
+/-
+Based on Prove2Me node ModularCurve.exists_ringHom_place_order_eq_mul_ord_of_qExpansion_slash
+(b76d6a0e-7f9a-55a8-851c-7490ecf00916) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission fb9e3b50-6ca1-508c-929a-f464f3d2e62e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ComplexPlaceDictionaryOf
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Data.Int.Star
+import Mathlib.NumberTheory.ModularForms.NormTrace
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_coeffEmb_qExpand_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_mem_intFormRatiosC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_realizeOf_eq_div
+
+/-!
+# Cuspidal place and q_N-expansion at σ∞ on X(Γ)
+
+Theorem statement: `ModularCurve.exists_ringHom_place_order_eq_mul_ord_of_qExpansion_slash`
+(`b76d6a0e-7f9a-55a8-851c-7490ecf00916`), by Claude, 2026-09-05.
+
+Proof: submission `fb9e3b50-6ca1-508c-929a-f464f3d2e62e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma\le\mathrm{SL}_2(\mathbb Z)$ be a subgroup of finite index containing
+$T=\begin{pmatrix}1&1\\0&1\end{pmatrix}$, let $F_0$ be an intermediate field of $\mathbb
+Q\subseteq\mathbb Q((q))$ equal to [`ModularCurve.qExpFunctionFieldC ℚ
+Γ`](def/ModularCurve_X1.html#L101), the subfield generated over $\mathbb Q$ by the Laurent series
+$\mathrm{int}(p_f)/\mathrm{int}(p_g)$ attached to integral $q$-expansions $p_f,p_g$ of modular forms
+$f,g$ of some weight $k$ for $\Gamma$ with $\mathrm{int}(p_g)\ne 0$, and let
+$\sigma\in\mathrm{SL}_2(\mathbb Z)$. Write $E=\mathbb C\cdot F_0\subseteq\mathbb C((q))$ for
+`laurentBaseChange ℂ F₀`, the subfield of $\mathbb C((q))$ generated over $\mathbb C$ by the
+coefficientwise image of $F_0$, and $N=[\mathrm{SL}_2(\mathbb Z):\mathrm{core}\,\Gamma]$ the index
+of the normal core of $\Gamma$. The assertion is that there exist a ring homomorphism $\Phi\colon
+E\to\mathbb C((q))$, a place $P$ of $E$ over $\mathbb C$ (a proper valuation subring of $E$
+containing $\mathbb C$ and a principal ideal ring), and a natural number $e>0$ such that: (i) $x$
+lies in the valuation ring $\mathcal O_P$ iff $\mathrm{ord}\,\Phi(x)\ge 0$, and also iff the
+level-$\Gamma$ realisation $\tau\mapsto x(\sigma\tau)$ on $\mathfrak H$ (defined as $g/h$ for a
+presentation $x\cdot\widetilde h=\widetilde g$ by $q$-expansions of period $1$, and $0$ if none
+exists) tends to a finite limit as $\operatorname{Im}\tau\to\infty$; (ii) for every such
+presentation $x\cdot\widetilde h=\widetilde g$ with $g,h\in M_k(\Gamma)$, $h\ne0$, one has
+$\Phi(x)\cdot\widetilde{h\mid_k\sigma}=\widetilde{g\mid_k\sigma}$, the expansions now taken with
+period $N$; (iii) $\Phi$ sends each constant $c\in\mathbb C$ to the constant Laurent series $c$;
+(iv) $\mathrm{ord}\,\Phi(x)=e\cdot\mathrm{ord}_P(x)$ for all $x\ne0$, where $\mathrm{ord}_P$ is
+minus the logarithm of the adic valuation of $\mathcal O_P$; (v) any $y\in E$ whose underlying
+series is `jqModC ℂ` satisfies $\mathrm{ord}\,\Phi(y)=e\cdot\mathrm{ord}_P(y)=-N$ and
+$y\notin\mathcal O_P$; and (vi) for every $x\ne0$ there is $L\ne0$ with
+$x(\sigma\tau)\,\exp\!\left(-2\pi i\,e\,\mathrm{ord}_P(x)\,\tau/N\right)\to L$ as
+$\operatorname{Im}\tau\to\infty$.
+
+This is the analytic half of the cusp dictionary for the modular curve attached to $\Gamma$: $P$ is
+the cuspidal place at $\sigma\infty$, at which $j$ has a pole of order $N$, $e$ measures the
+ramification of the parameter $q_N$ over a local parameter at $P$, and orders at $P$ are read off as
+leading exponents of $q_N$-expansions, with the leading coefficient of the realisation recorded as a
+nonzero limit. It feeds the computation of $\mathrm{ord}_P$ in terms of cusp widths and the
+asymptotic behaviour of realisations of functions with a pole at $P$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_ringHom_place_order_eq_mul_ord_of_qExpansion_slash.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_ringHom_place_order_eq_mul_ord_of_qExpansion_slash
+
+
+open UpperHalfPlane ModularForm Filter Function Complex Matrix.SpecialLinearGroup OnePoint
+open scoped MatrixGroups Topology CongruenceSubgroup Pointwise Manifold
+
+noncomputable section
+
+namespace Ws49
+namespace CUSPLIM
+
+namespace S3CuspLimit
+
+variable {k : ℤ}
+
+def wd (Γ : Subgroup SL(2, ℤ)) : ℕ := Γ.normalCore.index
+
+scoped instance wd_neZero (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] : NeZero (wd Γ) :=
+  ⟨Subgroup.FiniteIndex.index_ne_zero⟩
+
+theorem wd_pos (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] : (0 : ℝ) < wd Γ := by
+  exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne (wd Γ))
+
+private theorem conj_T_zpow_mem (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (σ : SL(2, ℤ)) :
+    σ * ModularGroup.T ^ (wd Γ : ℤ) * σ⁻¹ ∈ Γ := by
+  have h1 : ModularGroup.T ^ (wd Γ : ℤ) ∈ Γ.normalCore := by
+    rw [zpow_natCast]
+    exact Subgroup.pow_index_mem Γ.normalCore ModularGroup.T
+  have h2 : σ * ModularGroup.T ^ (wd Γ : ℤ) * σ⁻¹ ∈ Γ.normalCore :=
+    (Subgroup.normalCore_normal Γ).conj_mem _ h1 σ
+  exact Subgroup.normalCore_le Γ h2
+
+private theorem coe_eq_mapGL (γ : SL(2, ℤ)) : (γ : GL (Fin 2) ℝ) = mapGL ℝ γ := rfl
+
+private theorem mapGL_T_zpow (N : ℕ) :
+    mapGL ℝ (ModularGroup.T ^ (N : ℤ)) =
+      Matrix.GeneralLinearGroup.upperRightHom (N : ℝ) := by
+  have hmat : ((ModularGroup.T ^ (N : ℤ) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) =
+      !![1, (N : ℤ); 0, 1] := ModularGroup.coe_T_zpow (N : ℤ)
+  rw [Units.ext_iff]
+  have hval : (↑(mapGL ℝ (ModularGroup.T ^ (N : ℤ))) : Matrix (Fin 2) (Fin 2) ℝ) =
+      (!![1, (N : ℤ); 0, 1]).map (Int.cast : ℤ → ℝ) := by
+    rw [← hmat]; rfl
+  rw [hval]
+  ext i j
+  fin_cases i <;> fin_cases j <;>
+    simp [Matrix.GeneralLinearGroup.upperRightHom]
+
+theorem natCast_mem_strictPeriods_translate (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex]
+    (σ : SL(2, ℤ)) :
+    (wd Γ : ℝ) ∈ Subgroup.strictPeriods
+      (ConjAct.toConjAct ((σ : GL (Fin 2) ℝ))⁻¹ • ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2)
+        ℝ))) := by
+  rw [Subgroup.mem_strictPeriods_iff, map_inv, Subgroup.mem_inv_pointwise_smul_iff,
+    ConjAct.toConjAct_smul, ← mapGL_T_zpow (wd Γ), coe_eq_mapGL, ← map_inv, ← map_mul, ← map_mul]
+  exact Subgroup.mem_map_of_mem _ (conj_T_zpow_mem Γ σ)
+
+variable {Γ : Subgroup SL(2, ℤ)} [Γ.FiniteIndex]
+
+omit [Γ.FiniteIndex] in
+theorem coe_translate_SL (g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (σ : SL(2, ℤ)) :
+    ⇑(ModularForm.translate g (σ : GL (Fin 2) ℝ)) = ⇑g ∣[k] σ := by
+  rw [SL_slash]
+  exact ModularForm.coe_translate g _
+
+theorem slash_periodic (g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (σ : SL(2, ℤ)) :
+    Periodic ((⇑g ∣[k] σ) ∘ ofComplex) (wd Γ : ℝ) := by
+  rw [← coe_translate_SL g σ]
+  exact SlashInvariantFormClass.periodic_comp_ofComplex
+    (ModularForm.translate g (σ : GL (Fin 2) ℝ))
+    (natCast_mem_strictPeriods_translate Γ σ)
+
+omit [Γ.FiniteIndex] in
+theorem slash_mdiff (g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (σ : SL(2, ℤ)) :
+    MDiff (⇑g ∣[k] σ) := by
+  rw [← coe_translate_SL g σ]
+  exact ModularFormClass.holo _
+
+theorem slash_bddAtImInfty (g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (σ : SL(2, ℤ)) :
+    IsBoundedAtImInfty (⇑g ∣[k] σ) := by
+  have hFact : Fact (IsCusp ∞ (ConjAct.toConjAct ((σ : GL (Fin 2) ℝ))⁻¹ •
+      ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)))) :=
+    ⟨Subgroup.isCusp_of_mem_strictPeriods (wd_pos Γ) (natCast_mem_strictPeriods_translate Γ σ)⟩
+  have h := ModularFormClass.bdd_at_infty
+    (f := ModularForm.translate g (σ : GL (Fin 2) ℝ))
+  rwa [coe_translate_SL] at h
+
+private theorem exists_chart {N : ℕ} [NeZero N] {F : ℍ → ℂ}
+    (pF : Periodic (F ∘ ofComplex) N) (dF : MDiff F) (bF : IsBoundedAtImInfty F)
+    (hF0 : qExpansion N F ≠ 0) :
+    ∃ u : ℂ → ℂ, ContinuousAt u 0 ∧
+      u 0 = (qExpansion N F).coeff ((qExpansion N F).order.toNat) ∧ u 0 ≠ 0 ∧
+      ∀ τ : ℍ, F τ = Periodic.qParam N τ ^ ((qExpansion N F).order.toNat) *
+        u (Periodic.qParam N τ) := by
+  have hN : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  set P := qExpansion N F with hP
+  have hsummN : Summable fun n : ℕ => ‖P.coeff n‖ * (1 / 2 : ℝ) ^ n := by
+    let : FiniteDimensional ℝ ℂ := basisOneI.finiteDimensional_of_finite
+    have h1 : HasSum (fun n : ℕ => P.coeff n • ((1 / 2 : ℝ) : ℂ) ^ n)
+        (cuspFunction N F ((1 / 2 : ℝ) : ℂ)) :=
+      hasSum_qExpansion_of_norm_lt hN pF dF bF (by
+        rw [Complex.norm_real]
+        norm_num)
+    refine (summable_norm_iff.mpr h1.summable).congr fun n => ?_
+    rw [norm_smul, norm_pow, Complex.norm_real]
+    norm_num
+  have hsummShift : Summable fun j : ℕ => ‖P.coeff ((P.order.toNat) + j)‖ * (1 / 2 : ℝ) ^ j := by
+    have h1 : Summable fun j : ℕ =>
+        ‖P.coeff (j + P.order.toNat)‖ * (1 / 2 : ℝ) ^ (j + P.order.toNat) :=
+      (summable_nat_add_iff (f := fun n : ℕ => ‖P.coeff n‖ * (1 / 2 : ℝ) ^ n)
+        (P.order.toNat)).mpr hsummN
+    have h2 := h1.mul_right ((2 : ℝ) ^ P.order.toNat)
+    refine h2.congr fun j => ?_
+    have hpow : ((1 : ℝ) / 2) ^ P.order.toNat * (2 : ℝ) ^ P.order.toNat = 1 := by
+      rw [← mul_pow]
+      norm_num
+    rw [pow_add, add_comm j P.order.toNat]
+    linear_combination ‖P.coeff (P.order.toNat + j)‖ * ((1 : ℝ) / 2) ^ j * hpow
+  set u : ℂ → ℂ := fun z => ∑' j : ℕ, P.coeff (P.order.toNat + j) * z ^ j with hu
+  have hucont : ContinuousOn u (Metric.ball (0 : ℂ) (1 / 2)) := by
+    refine continuousOn_tsum (fun j => ?_) hsummShift fun j z hz => ?_
+    · exact (continuous_const.mul (continuous_pow j)).continuousOn
+    · rw [norm_mul, norm_pow]
+      gcongr
+      exact le_of_lt (by simpa [Metric.mem_ball, dist_zero_right] using hz)
+  have huCA : ContinuousAt u 0 :=
+    hucont.continuousAt (Metric.ball_mem_nhds _ (by norm_num))
+  have hu0 : u 0 = P.coeff (P.order.toNat) := by
+    have hval : u 0 = ∑' j : ℕ, P.coeff (P.order.toNat + j) * (0 : ℂ) ^ j := rfl
+    rw [hval, tsum_eq_single 0 fun j hj => by simp [zero_pow hj]]
+    simp
+  have hum : P.coeff (P.order.toNat) ≠ 0 := PowerSeries.coeff_order hF0
+  refine ⟨u, huCA, hu0, by rw [hu0]; exact hum, fun τ => ?_⟩
+  set z := Periodic.qParam (N : ℝ) (τ : ℂ) with hz
+  have hz1 : ‖z‖ < 1 := UpperHalfPlane.norm_qParam_lt_one N τ
+  have hz0 : z ≠ 0 := Complex.exp_ne_zero _
+  have hsum : HasSum (fun n : ℕ => P.coeff n • z ^ n) (F τ) :=
+    hasSum_qExpansion hN pF dF bF τ
+  have hshift : HasSum (fun j : ℕ => P.coeff (j + P.order.toNat) • z ^ (j + P.order.toNat))
+      (F τ) := by
+    have hvan : ∑ i ∈ Finset.range (P.order.toNat), P.coeff i • z ^ i = 0 := by
+      refine Finset.sum_eq_zero fun i hi => ?_
+      rw [PowerSeries.coeff_of_lt_order_toNat i (Finset.mem_range.mp hi), zero_smul]
+    have h4 := (hasSum_nat_add_iff' (P.order.toNat)).mpr hsum
+    rwa [hvan, sub_zero] at h4
+  have husum : HasSum (fun j : ℕ => P.coeff (P.order.toNat + j) * z ^ j)
+      (F τ / z ^ P.order.toNat) := by
+    have h2 : HasSum (fun j : ℕ => (P.coeff (P.order.toNat + j) * z ^ j) * z ^ P.order.toNat)
+        (F τ) := by
+      have heq : (fun j : ℕ => (P.coeff (P.order.toNat + j) * z ^ j) * z ^ P.order.toNat) =
+          fun j : ℕ => P.coeff (j + P.order.toNat) • z ^ (j + P.order.toNat) := by
+        funext j
+        rw [smul_eq_mul, pow_add, add_comm j (P.order.toNat)]
+        ring
+      rw [heq]
+      exact hshift
+    have h3 := h2.div_const (z ^ P.order.toNat)
+    have heq2 : (fun j : ℕ => P.coeff (P.order.toNat + j) * z ^ j * z ^ P.order.toNat /
+        z ^ P.order.toNat) = fun j : ℕ => P.coeff (P.order.toNat + j) * z ^ j := by
+      funext j
+      rw [mul_div_assoc, div_self (pow_ne_zero _ hz0), mul_one]
+    rwa [heq2] at h3
+  have huz : u z = F τ / z ^ P.order.toNat := husum.tsum_eq
+  rw [huz, mul_div_cancel₀ _ (pow_ne_zero _ hz0)]
+
+private theorem eventually_ne_zero_atImInfty {N : ℕ} [NeZero N] {F : ℍ → ℂ}
+    (pF : Periodic (F ∘ ofComplex) N) (dF : MDiff F) (bF : IsBoundedAtImInfty F)
+    (hF0 : qExpansion N F ≠ 0) : ∀ᶠ τ : ℍ in atImInfty, F τ ≠ 0 := by
+  have hN : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  obtain ⟨u, hu, -, hu0, hid⟩ := exists_chart pF dF bF hF0
+  have h1 : Tendsto (fun τ : ℍ => u (Periodic.qParam N τ)) atImInfty (𝓝 (u 0)) :=
+    hu.tendsto.comp (qParam_tendsto_atImInfty hN)
+  filter_upwards [h1.eventually_ne hu0] with τ hτ
+  rw [hid τ]
+  exact mul_ne_zero (pow_ne_zero _ (Complex.exp_ne_zero _)) hτ
+
+private theorem tendsto_div_atImInfty_of_triple {N : ℕ} [NeZero N] {G H : ℍ → ℂ}
+    (pG : Periodic (G ∘ ofComplex) N) (dG : MDiff G) (bG : IsBoundedAtImInfty G)
+    (pH : Periodic (H ∘ ofComplex) N) (dH : MDiff H) (bH : IsBoundedAtImInfty H)
+    (hG0 : qExpansion N G ≠ 0) (hH0 : qExpansion N H ≠ 0)
+    (hord : (qExpansion N G).order = (qExpansion N H).order) :
+    ∃ L : ℂ, L ≠ 0 ∧ Tendsto (fun τ : ℍ => G τ / H τ) atImInfty (𝓝 L) := by
+  have hN : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  obtain ⟨uG, cG, -, nG, idG⟩ := exists_chart pG dG bG hG0
+  obtain ⟨uH, cH, -, nH, idH⟩ := exists_chart pH dH bH hH0
+  have hm : (qExpansion (N : ℝ) G).order.toNat = (qExpansion (N : ℝ) H).order.toNat := by
+    rw [hord]
+  refine ⟨uG 0 / uH 0, div_ne_zero nG nH, ?_⟩
+  have hTG : Tendsto (fun τ : ℍ => uG (Periodic.qParam N τ)) atImInfty (𝓝 (uG 0)) :=
+    cG.tendsto.comp (qParam_tendsto_atImInfty hN)
+  have hTH : Tendsto (fun τ : ℍ => uH (Periodic.qParam N τ)) atImInfty (𝓝 (uH 0)) :=
+    cH.tendsto.comp (qParam_tendsto_atImInfty hN)
+  refine (hTG.div hTH nH).congr fun τ => ?_
+  have hqne : Periodic.qParam (N : ℝ) (τ : ℂ) ^ (qExpansion (N : ℝ) H).order.toNat ≠ 0 :=
+    pow_ne_zero _ (Complex.exp_ne_zero _)
+  rw [Pi.div_apply, idG τ, idH τ, hm, mul_div_mul_left _ _ hqne]
+
+private theorem chart_eventually_ne_zero {N : ℕ} [NeZero N] {u : ℂ → ℂ} (hu : ContinuousAt u 0)
+    (hu0 : u 0 ≠ 0) :
+    ∀ᶠ τ : ℍ in atImInfty, u (Periodic.qParam N τ) ≠ 0 := by
+  have hN : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  exact (hu.tendsto.comp (qParam_tendsto_atImInfty hN)).eventually_ne hu0
+
+private theorem tendsto_div_mul_qParam_zpow {N : ℕ} [NeZero N] {G H : ℍ → ℂ}
+    (pG : Periodic (G ∘ ofComplex) N) (dG : MDiff G) (bG : IsBoundedAtImInfty G)
+    (pH : Periodic (H ∘ ofComplex) N) (dH : MDiff H) (bH : IsBoundedAtImInfty H)
+    (hG0 : qExpansion N G ≠ 0) (hH0 : qExpansion N H ≠ 0) :
+    ∃ L : ℂ, L ≠ 0 ∧ Tendsto (fun τ : ℍ => G τ / H τ *
+        Periodic.qParam N τ ^ (-(((qExpansion N G).order.toNat : ℤ) - ((qExpansion N H).order.toNat
+          : ℤ))))
+      atImInfty (𝓝 L) := by
+  have hN : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  obtain ⟨uG, cG, -, nG, idG⟩ := exists_chart pG dG bG hG0
+  obtain ⟨uH, cH, -, nH, idH⟩ := exists_chart pH dH bH hH0
+  refine ⟨uG 0 / uH 0, div_ne_zero nG nH, ?_⟩
+  have hTG : Tendsto (fun τ : ℍ => uG (Periodic.qParam N τ)) atImInfty (𝓝 (uG 0)) :=
+    cG.tendsto.comp (qParam_tendsto_atImInfty hN)
+  have hTH : Tendsto (fun τ : ℍ => uH (Periodic.qParam N τ)) atImInfty (𝓝 (uH 0)) :=
+    cH.tendsto.comp (qParam_tendsto_atImInfty hN)
+  refine (hTG.div hTH nH).congr' ?_
+  filter_upwards [chart_eventually_ne_zero (N := N) cH nH] with τ hτ
+  have hq : Periodic.qParam N (τ : ℂ) ≠ 0 := Complex.exp_ne_zero _
+  change uG (Periodic.qParam N τ) / uH (Periodic.qParam N τ) = _
+  rw [idG τ, idH τ, zpow_neg, zpow_sub₀ hq, zpow_natCast, zpow_natCast]
+  field_simp
+
+private theorem exists_tendsto_div_of_le {N : ℕ} [NeZero N] {G H : ℍ → ℂ}
+    (pG : Periodic (G ∘ ofComplex) N) (dG : MDiff G) (bG : IsBoundedAtImInfty G)
+    (pH : Periodic (H ∘ ofComplex) N) (dH : MDiff H) (bH : IsBoundedAtImInfty H)
+    (hG0 : qExpansion N G ≠ 0) (hH0 : qExpansion N H ≠ 0)
+    (hle : (qExpansion N H).order.toNat ≤ (qExpansion N G).order.toNat) :
+    ∃ L : ℂ, Tendsto (fun τ : ℍ => G τ / H τ) atImInfty (𝓝 L) := by
+  have hN : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  obtain ⟨uG, cG, -, nG, idG⟩ := exists_chart pG dG bG hG0
+  obtain ⟨uH, cH, -, nH, idH⟩ := exists_chart pH dH bH hH0
+  set a := (qExpansion (N : ℝ) G).order.toNat
+  set b := (qExpansion (N : ℝ) H).order.toNat
+  have hTG : Tendsto (fun τ : ℍ => uG (Periodic.qParam N τ)) atImInfty (𝓝 (uG 0)) :=
+    cG.tendsto.comp (qParam_tendsto_atImInfty hN)
+  have hTH : Tendsto (fun τ : ℍ => uH (Periodic.qParam N τ)) atImInfty (𝓝 (uH 0)) :=
+    cH.tendsto.comp (qParam_tendsto_atImInfty hN)
+  have hTq : Tendsto (fun τ : ℍ => Periodic.qParam N τ ^ (a - b)) atImInfty (𝓝 ((0 : ℂ) ^ (a - b)))
+    :=
+    (qParam_tendsto_atImInfty hN).pow (a - b)
+  refine ⟨(0 : ℂ) ^ (a - b) * (uG 0 / uH 0), ((hTq.mul (hTG.div hTH nH)).congr' ?_)⟩
+  filter_upwards [chart_eventually_ne_zero (N := N) cH nH] with τ hτ
+  have hq : Periodic.qParam N (τ : ℂ) ≠ 0 := Complex.exp_ne_zero _
+  change Periodic.qParam N τ ^ (a - b) * (uG (Periodic.qParam N τ) / uH (Periodic.qParam N τ)) = _
+  rw [idG τ, idH τ]
+  have : (Periodic.qParam N (τ : ℂ)) ^ a = Periodic.qParam N (τ : ℂ) ^ (a - b) * Periodic.qParam N
+    (τ : ℂ) ^ b :=
+    by
+    rw [← pow_add, Nat.sub_add_cancel hle]
+  rw [this]
+  field_simp
+
+private theorem not_tendsto_div_of_lt {N : ℕ} [NeZero N] {G H : ℍ → ℂ}
+    (pG : Periodic (G ∘ ofComplex) N) (dG : MDiff G) (bG : IsBoundedAtImInfty G)
+    (pH : Periodic (H ∘ ofComplex) N) (dH : MDiff H) (bH : IsBoundedAtImInfty H)
+    (hG0 : qExpansion N G ≠ 0) (hH0 : qExpansion N H ≠ 0)
+    (hlt : (qExpansion N G).order.toNat < (qExpansion N H).order.toNat) (L : ℂ) :
+    ¬ Tendsto (fun τ : ℍ => G τ / H τ) atImInfty (𝓝 L) := by
+  intro hL
+  have hN : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  obtain ⟨L₀, hL₀, hT₀⟩ := tendsto_div_mul_qParam_zpow pG dG bG pH dH bH hG0 hH0
+  set a := (qExpansion (N : ℝ) G).order.toNat
+  set b := (qExpansion (N : ℝ) H).order.toNat
+  have hba : 0 < b - a := Nat.sub_pos_of_lt hlt
+  have hexp : (-((a : ℤ) - (b : ℤ))) = ((b - a : ℕ) : ℤ) := by
+    push_cast [Nat.cast_sub hlt.le]; ring
+  have hTq : Tendsto (fun τ : ℍ => Periodic.qParam N τ ^ (b - a)) atImInfty (𝓝 0) := by
+    have := (qParam_tendsto_atImInfty hN).pow (b - a)
+    rwa [zero_pow hba.ne'] at this
+  have h2 : Tendsto (fun τ : ℍ => G τ / H τ * Periodic.qParam N τ ^ (-(((a : ℤ)) - ((b : ℤ)))))
+      atImInfty (𝓝 (L * 0)) := by
+    refine (hL.mul hTq).congr fun τ => ?_
+    rw [hexp, zpow_natCast]
+  rw [mul_zero] at h2
+  exact hL₀ (tendsto_nhds_unique hT₀ h2)
+
+private theorem div_comp_smul_eq_div_slash (k : ℤ) (g h : ℍ → ℂ) (σ : SL(2, ℤ)) (τ : ℍ) :
+    g (σ • τ) / h (σ • τ) = (g ∣[k] σ) τ / (h ∣[k] σ) τ := by
+  rw [SL_slash_apply, SL_slash_apply,
+    mul_div_mul_right _ _ (zpow_ne_zero _ (denom_ne_zero _ τ))]
+
+theorem qExpansion_slash_ne_zero
+    (h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (σ : SL(2, ℤ)) (hh : h ≠ 0) :
+    qExpansion (wd Γ) (⇑h ∣[k] σ) ≠ 0 := by
+  rw [Ne, qExpansion_eq_zero_iff (wd_pos Γ) (slash_periodic h σ) (slash_mdiff h σ)
+    (slash_bddAtImInfty h σ)]
+  intro h0
+  apply hh
+  have h1 : ⇑h = (0 : ℍ → ℂ) := by
+    have h2 := congrArg (· ∣[k] (σ⁻¹ : SL(2, ℤ))) h0
+    simpa only [SL_slash, ← SlashAction.slash_mul, ← map_mul, mul_inv_cancel, map_one,
+      SlashAction.slash_one, SlashAction.zero_slash] using h2
+  ext τ
+  rw [h1]
+  rfl
+
+private theorem qParam_one_eq_pow (N : ℕ) [NeZero N] (z : ℂ) :
+    Periodic.qParam 1 z = Periodic.qParam N z ^ (N : ℕ) := by
+  unfold Periodic.qParam
+  rw [← Complex.exp_nat_mul]
+  congr 1
+  have hN : (N : ℂ) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne N)
+  push_cast
+  field_simp
+
+private theorem qExpansion_natCast_coeff {F : ℍ → ℂ} (N : ℕ) [NeZero N]
+    (p1 : Periodic (F ∘ ofComplex) 1) (dF : MDiff F) (bF : IsBoundedAtImInfty F)
+    (n : ℕ) :
+    (qExpansion N F).coeff n =
+      if N ∣ n then (qExpansion 1 F).coeff (n / N) else 0 := by
+  classical
+  have hN : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  have pN : Periodic (F ∘ ofComplex) (N : ℝ) := by
+    simpa using p1.nat_mul N
+  set c : ℕ → ℂ := fun j => if N ∣ j then (qExpansion 1 F).coeff (j / N) else 0 with hc
+  have key : ∀ τ : ℍ, HasSum (fun j : ℕ => c j • Periodic.qParam N τ ^ j) (F τ) := by
+    intro τ
+    have h1 : HasSum (fun j : ℕ => (qExpansion 1 F).coeff j • Periodic.qParam 1 τ ^ j)
+        (F τ) := hasSum_qExpansion one_pos p1 dF bF τ
+    have h2 : ∀ j : ℕ, (qExpansion 1 F).coeff j • Periodic.qParam 1 (τ : ℂ) ^ j =
+        c (N * j) • Periodic.qParam N (τ : ℂ) ^ (N * j) := by
+      intro j
+      rw [qParam_one_eq_pow N, ← pow_mul, hc]
+      simp [Nat.mul_div_cancel_left j (Nat.pos_of_ne_zero (NeZero.ne N))]
+    have hinj : Function.Injective (fun j : ℕ => N * j) :=
+      fun a b hab => Nat.eq_of_mul_eq_mul_left (Nat.pos_of_ne_zero (NeZero.ne N)) hab
+    have hoff : ∀ j : ℕ, j ∉ Set.range (fun i : ℕ => N * i) →
+        c j • Periodic.qParam N (τ : ℂ) ^ j = 0 := by
+      intro j hj
+      have hdvd : ¬ N ∣ j := by
+        rintro ⟨i, rfl⟩
+        exact hj ⟨i, rfl⟩
+      rw [hc]
+      simp [hdvd]
+    simp only [h2] at h1
+    exact (hinj.hasSum_iff hoff).mp h1
+  have hA : AnalyticAt ℂ (cuspFunction (N : ℝ) F) 0 :=
+    analyticAt_cuspFunction_zero hN pN dF bF
+  let : FunLike (ℍ → ℂ) ℍ ℂ := ⟨id, fun _ _ hfg => hfg⟩
+  exact (qExpansion_coeff_unique F hN hA key n).symm
+
+end S3CuspLimit
+
+namespace S3c
+
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+private theorem order_inv_laurent {x : LaurentSeries K} (hx : x ≠ 0) : (x⁻¹).order = -x.order := by
+  have h := HahnSeries.order_mul hx (inv_ne_zero hx)
+  rw [mul_inv_cancel₀ hx, HahnSeries.order_one] at h
+  omega
+
+private theorem order_zpow_laurent {x : LaurentSeries K} (hx : x ≠ 0) (n : ℤ) :
+    (x ^ n).order = n * x.order := by
+  rcases Int.eq_nat_or_neg n with ⟨m, rfl | rfl⟩
+  · rw [zpow_natCast, HahnSeries.order_pow, nsmul_eq_mul]
+  · rw [zpow_neg, zpow_natCast, order_inv_laurent (pow_ne_zero _ hx), HahnSeries.order_pow,
+      nsmul_eq_mul, neg_mul]
+
+variable (Φ : F →+* LaurentSeries K)
+
+omit [Algebra K F] in
+private theorem map_ne_zero_iff' {x : F} : Φ x ≠ 0 ↔ x ≠ 0 :=
+  _root_.map_ne_zero_iff Φ Φ.injective
+
+private def orderValuationSubring : ValuationSubring F where
+  carrier := {x | 0 ≤ (Φ x).order}
+  mul_mem' {x y} hx hy := by
+    simp only [Set.mem_ofPred_eq] at hx hy ⊢
+    rcases eq_or_ne x 0 with rfl | hx0
+    · simp
+    rcases eq_or_ne y 0 with rfl | hy0
+    · simp
+    rw [map_mul, HahnSeries.order_mul ((map_ne_zero_iff' Φ).2 hx0) ((map_ne_zero_iff' Φ).2 hy0)]
+    omega
+  one_mem' := by simp [HahnSeries.order_one]
+  add_mem' {x y} hx hy := by
+    simp only [Set.mem_ofPred_eq] at hx hy ⊢
+    rcases eq_or_ne (Φ x + Φ y) 0 with h0 | h0
+    · simp [h0]
+    · rw [map_add]
+      exact (le_min hx hy).trans (HahnSeries.min_order_le_order_add h0)
+  zero_mem' := by simp
+  neg_mem' {x} hx := by
+    simp only [Set.mem_ofPred_eq] at hx ⊢
+    rwa [map_neg, HahnSeries.order_neg]
+  mem_or_inv_mem' x := by
+    simp only [Set.mem_ofPred_eq]
+    rcases eq_or_ne x 0 with rfl | hx0
+    · simp
+    rw [map_inv₀, order_inv_laurent ((map_ne_zero_iff' Φ).2 hx0)]
+    omega
+
+omit [Algebra K F] in
+private theorem mem_orderValuationSubring_iff {x : F} :
+    x ∈ orderValuationSubring Φ ↔ 0 ≤ (Φ x).order :=
+  Iff.rfl
+
+omit [Algebra K F] in
+private theorem coe_ne_zero_of_ne_zero {x : orderValuationSubring Φ} (hx : x ≠ 0) : (x : F) ≠ 0 :=
+  fun h => hx (Subtype.ext h)
+
+omit [Algebra K F] in
+private theorem order_eq_zero_of_isUnit {x : orderValuationSubring Φ} (hu : IsUnit x) :
+    (Φ (x : F)).order = 0 := by
+  obtain ⟨u, rfl⟩ := hu
+  have h1 : 0 ≤ (Φ ((u : orderValuationSubring Φ) : F)).order := u.val.2
+  have h2 : 0 ≤ (Φ (((u⁻¹ : (orderValuationSubring Φ)ˣ) : orderValuationSubring Φ) : F)).order :=
+    (u⁻¹).val.2
+  have hprod : ((u : orderValuationSubring Φ) : F) *
+      (((u⁻¹ : (orderValuationSubring Φ)ˣ) : orderValuationSubring Φ) : F) = 1 :=
+    congrArg Subtype.val u.mul_inv
+  have hx0 : ((u : orderValuationSubring Φ) : F) ≠ 0 := by
+    intro h
+    rw [h, zero_mul] at hprod
+    exact zero_ne_one hprod
+  have hy0 : (((u⁻¹ : (orderValuationSubring Φ)ˣ) : orderValuationSubring Φ) : F) ≠ 0 := by
+    intro h
+    rw [h, mul_zero] at hprod
+    exact zero_ne_one hprod
+  have := congrArg (fun z => (Φ z).order) hprod
+  simp only [map_mul, map_one, HahnSeries.order_one] at this
+  rw [HahnSeries.order_mul ((map_ne_zero_iff' Φ).2 hx0) ((map_ne_zero_iff' Φ).2 hy0)] at this
+  omega
+
+omit [Algebra K F] in
+private theorem isUnit_of_order_eq_zero {x : orderValuationSubring Φ} (hx : (x : F) ≠ 0)
+    (h0 : (Φ (x : F)).order = 0) : IsUnit x := by
+  have hinv : (x : F)⁻¹ ∈ orderValuationSubring Φ := by
+    rw [mem_orderValuationSubring_iff, map_inv₀, order_inv_laurent ((map_ne_zero_iff' Φ).2 hx),
+      h0, neg_zero]
+  exact ⟨⟨x, ⟨(x : F)⁻¹, hinv⟩, Subtype.ext (mul_inv_cancel₀ hx),
+    Subtype.ext (inv_mul_cancel₀ hx)⟩, rfl⟩
+
+omit [Algebra K F] in
+private theorem isPrincipalIdealRing_orderValuationSubring :
+    IsPrincipalIdealRing (orderValuationSubring Φ) := by
+  classical
+  refine ⟨fun I => ?_⟩
+  by_cases hI : I = ⊥
+  · refine ⟨⟨0, ?_⟩⟩
+    rw [hI]
+    exact (Ideal.span_singleton_eq_bot.mpr rfl).symm
+  obtain ⟨x₁, hx₁I, hx₁0⟩ := (Submodule.ne_bot_iff I).mp hI
+  let P : ℕ → Prop := fun n =>
+    ∃ x : orderValuationSubring Φ, x ∈ I ∧ x ≠ 0 ∧ (Φ (x : F)).order = n
+  have hP : ∃ n, P n :=
+    ⟨((Φ (x₁ : F)).order).toNat, x₁, hx₁I, hx₁0, (Int.toNat_of_nonneg x₁.2).symm⟩
+  obtain ⟨x₀, hx₀I, hx₀0, hx₀n⟩ := Nat.find_spec hP
+  have hmin : ∀ y : orderValuationSubring Φ, y ∈ I → y ≠ 0 →
+      (Φ (x₀ : F)).order ≤ (Φ (y : F)).order := by
+    intro y hyI hy0
+    have h1 : Nat.find hP ≤ ((Φ (y : F)).order).toNat :=
+      Nat.find_min' hP ⟨y, hyI, hy0, (Int.toNat_of_nonneg y.2).symm⟩
+    have h2 : ((Nat.find hP : ℕ) : ℤ) ≤ ((((Φ (y : F)).order).toNat : ℕ) : ℤ) := by
+      exact_mod_cast h1
+    rw [Int.toNat_of_nonneg y.2] at h2
+    rw [hx₀n]
+    exact h2
+  have hx₀F : (x₀ : F) ≠ 0 := coe_ne_zero_of_ne_zero Φ hx₀0
+  have key : I = Ideal.span {x₀} := by
+    apply le_antisymm
+    · intro y hyI
+      rcases eq_or_ne y 0 with rfl | hy0
+      · exact Ideal.zero_mem _
+      have hyF : (y : F) ≠ 0 := coe_ne_zero_of_ne_zero Φ hy0
+      have hc : (y : F) * (x₀ : F)⁻¹ ∈ orderValuationSubring Φ := by
+        rw [mem_orderValuationSubring_iff, map_mul, map_inv₀,
+          HahnSeries.order_mul ((map_ne_zero_iff' Φ).2 hyF)
+            (inv_ne_zero ((map_ne_zero_iff' Φ).2 hx₀F)),
+          order_inv_laurent ((map_ne_zero_iff' Φ).2 hx₀F)]
+        have := hmin y hyI hy0
+        omega
+      refine Ideal.mem_span_singleton'.mpr ⟨⟨(y : F) * (x₀ : F)⁻¹, hc⟩, ?_⟩
+      apply Subtype.ext
+      change (y : F) * (x₀ : F)⁻¹ * (x₀ : F) = (y : F)
+      exact inv_mul_cancel_right₀ hx₀F _
+    · rw [Ideal.span_singleton_le_iff_mem]
+      exact hx₀I
+  exact ⟨⟨x₀, key⟩⟩
+
+variable (hΦ : ∀ c : K, Φ (algebraMap K F c) = HahnSeries.C c) {t : F} (ht : (Φ t).order < 0)
+
+private def orderPlace : AlgebraicCurve.Place K F where
+  toValuationSubring := orderValuationSubring Φ
+  algebraMap_mem' c := by
+    change 0 ≤ (Φ (algebraMap K F c)).order
+    rw [hΦ, HahnSeries.order_C]
+  ne_top' h := by
+    have : t ∈ orderValuationSubring Φ := h ▸ ValuationSubring.mem_top t
+    exact not_le.mpr ht this
+  isPrincipalIdealRing' := isPrincipalIdealRing_orderValuationSubring Φ
+
+private theorem orderPlace_toValuationSubring :
+    (orderPlace Φ hΦ ht).toValuationSubring = orderValuationSubring Φ := rfl
+
+private theorem mem_orderPlace_iff {x : F} :
+    x ∈ (orderPlace Φ hΦ ht).toValuationSubring ↔ 0 ≤ (Φ x).order :=
+  Iff.rfl
+
+private theorem not_mem_orderPlace : t ∉ (orderPlace Φ hΦ ht).toValuationSubring :=
+  not_le.mpr ht
+
+private theorem exists_order_eq_mul_ord :
+    ∃ e : ℕ, 0 < e ∧ ∀ x : F, x ≠ 0 → (Φ x).order = e * (orderPlace Φ hΦ ht).ord x := by
+  obtain ⟨ϖ, hϖ⟩ :=
+    IsDiscreteValuationRing.exists_irreducible (orderPlace Φ hΦ ht).toValuationSubring
+  have hϖ0 : (ϖ : F) ≠ 0 := coe_ne_zero_of_ne_zero Φ hϖ.ne_zero
+  have hϖnn : 0 ≤ (Φ (ϖ : F)).order := ϖ.2
+  have hϖpos : 0 < (Φ (ϖ : F)).order := by
+    rcases hϖnn.lt_or_eq with h | h
+    · exact h
+    · exact absurd (isUnit_of_order_eq_zero Φ hϖ0 h.symm) hϖ.not_isUnit
+  refine ⟨((Φ (ϖ : F)).order).toNat, by omega, fun x hx => ?_⟩
+  obtain ⟨u, hu⟩ := (orderPlace Φ hΦ ht).exists_unit_mul_zpow hx hϖ
+  have hu0 : (((u : ((orderPlace Φ hΦ ht).toValuationSubring)ˣ) :
+      (orderPlace Φ hΦ ht).toValuationSubring) : F) ≠ 0 :=
+    coe_ne_zero_of_ne_zero Φ u.ne_zero
+  have huord : (Φ (((u : ((orderPlace Φ hΦ ht).toValuationSubring)ˣ) :
+      (orderPlace Φ hΦ ht).toValuationSubring) : F)).order = 0 :=
+    order_eq_zero_of_isUnit Φ u.isUnit
+  rw [Int.toNat_of_nonneg hϖnn]
+  conv_lhs => rw [hu]
+  rw [map_mul, map_zpow₀, HahnSeries.order_mul ((map_ne_zero_iff' Φ).2 hu0)
+      (zpow_ne_zero _ ((map_ne_zero_iff' Φ).2 hϖ0)), huord, zero_add,
+    order_zpow_laurent ((map_ne_zero_iff' Φ).2 hϖ0), mul_comm]
+
+private theorem ord_eq_zero_iff {x : F} (hx : x ≠ 0) :
+    (orderPlace Φ hΦ ht).ord x = 0 ↔ (Φ x).order = 0 := by
+  obtain ⟨e, he, h⟩ := exists_order_eq_mul_ord Φ hΦ ht
+  rw [h x hx]
+  constructor
+  · intro h0
+    rw [h0, mul_zero]
+  · intro h0
+    rcases mul_eq_zero.mp h0 with h1 | h1
+    · exact absurd h1 (by exact_mod_cast he.ne')
+    · exact h1
+
+end S3c
+
+namespace S3c
+
+private def Lq (n : ℝ) (f : ℍ → ℂ) : LaurentSeries ℂ :=
+  HahnSeries.ofPowerSeries ℤ ℂ (qExpansion n f)
+
+private theorem Lq_def (n : ℝ) (f : ℍ → ℂ) :
+    Lq n f = ((qExpansion n f : PowerSeries ℂ) : LaurentSeries ℂ) := rfl
+
+private theorem Lq_eq_zero_iff (n : ℝ) (f : ℍ → ℂ) : Lq n f = 0 ↔ qExpansion n f = 0 := by
+  rw [Lq]
+  constructor
+  · intro h
+    exact HahnSeries.ofPowerSeries_injective (by rw [h, map_zero])
+  · intro h
+    rw [h, map_zero]
+
+private theorem Lq_zero_fun (n : ℝ) : Lq n (0 : ℍ → ℂ) = 0 := by
+  rw [Lq_eq_zero_iff]
+  exact qExpansion_zero n
+
+section Generic
+
+variable {Γ : Subgroup (GL (Fin 2) ℝ)} (σ : SL(2, ℤ)) (N : ℕ) [NeZero N]
+
+private def cuspRatio {k : ℤ} (g h : ModularForm Γ k) : LaurentSeries ℂ :=
+  Lq N (⇑g ∣[k] σ) / Lq N (⇑h ∣[k] σ)
+
+private theorem coe_translate_SL {k : ℤ} (g : ModularForm Γ k) :
+    ⇑(ModularForm.translate g (σ : GL (Fin 2) ℝ)) = ⇑g ∣[k] σ := by
+  rw [ModularForm.coe_translate, SL_slash]
+
+private theorem slash_ne_zero {k : ℤ} {h : ModularForm Γ k} (hh : h ≠ 0) : ⇑h ∣[k] σ ≠ 0 := by
+  intro H
+  apply hh
+  have key : ⇑h = (⇑h ∣[k] σ) ∣[k] σ⁻¹ := by
+    rw [← SlashAction.slash_mul, mul_inv_cancel, SlashAction.slash_one]
+  rw [H, SlashAction.zero_slash] at key
+  exact DFunLike.coe_injective (key.trans FunLike.coe_zero.symm)
+
+variable (hN : (N : ℝ) ∈ (ConjAct.toConjAct (σ : GL (Fin 2) ℝ)⁻¹ • Γ).strictPeriods)
+
+include hN in
+private theorem translate_ne_zero_iff {k : ℤ} (h : ModularForm Γ k) :
+    Lq N (⇑h ∣[k] σ) ≠ 0 ↔ h ≠ 0 := by
+  have hN0 : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  rw [ne_eq, Lq_eq_zero_iff, ← coe_translate_SL,
+    ModularForm.qExpansion_eq_zero_iff hN0 hN (ModularForm.translate h (σ : GL (Fin 2) ℝ))]
+  constructor
+  · intro H rfl
+    apply H
+    have key : ⇑(ModularForm.translate (0 : ModularForm Γ k) (σ : GL (Fin 2) ℝ)) = 0 := by
+      rw [coe_translate_SL, FunLike.coe_zero, SlashAction.zero_slash]
+    exact DFunLike.coe_injective (key.trans FunLike.coe_zero.symm)
+  · intro H H'
+    exact slash_ne_zero σ H (by rw [← coe_translate_SL, H', FunLike.coe_zero])
+
+include hN in
+private theorem Lq_slash_ne_zero {k : ℤ} {h : ModularForm Γ k} (hh : h ≠ 0) :
+    Lq N (⇑h ∣[k] σ) ≠ 0 :=
+  (translate_ne_zero_iff σ N hN h).2 hh
+
+include hN in
+private theorem Lq_slash_mul [Γ.HasDetOne] {k k' : ℤ} (g : ModularForm Γ k) (g' : ModularForm Γ k')
+    :
+    Lq N (⇑(g.mul g') ∣[k + k'] σ) = Lq N (⇑g ∣[k] σ) * Lq N (⇑g' ∣[k'] σ) := by
+  have hN0 : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  rw [ModularForm.coe_mul, mul_slash_SL2, Lq, Lq, Lq, ← map_mul, ← coe_translate_SL,
+    ← coe_translate_SL,
+    ← ModularForm.qExpansion_mul_coe hN0 hN (ModularForm.translate g (σ : GL (Fin 2) ℝ))
+      (ModularForm.translate g' (σ : GL (Fin 2) ℝ))]
+
+include hN in
+private theorem Lq_slash_add {k : ℤ} (A B : ModularForm Γ k) :
+    Lq N (⇑(A + B) ∣[k] σ) = Lq N (⇑A ∣[k] σ) + Lq N (⇑B ∣[k] σ) := by
+  have hN0 : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  rw [FunLike.coe_add, SlashAction.add_slash, Lq, Lq, Lq, ← map_add, ← coe_translate_SL,
+    ← coe_translate_SL,
+    ← ModularForm.qExpansion_add hN0 hN (ModularForm.translate A (σ : GL (Fin 2) ℝ))
+      (ModularForm.translate B (σ : GL (Fin 2) ℝ))]
+
+include hN in
+private theorem Lq_slash_smul [Γ.HasDetOne] {k : ℤ} (c : ℂ) (A : ModularForm Γ k) :
+    Lq N (⇑(c • A) ∣[k] σ) = HahnSeries.C c * Lq N (⇑A ∣[k] σ) := by
+  have hN0 : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  rw [FunLike.coe_smul, SL_smul_slash, Lq, Lq, ← coe_translate_SL,
+    ModularForm.qExpansion_smul hN0 hN c (ModularForm.translate A (σ : GL (Fin 2) ℝ)),
+    PowerSeries.smul_eq_C_mul, map_mul, HahnSeries.ofPowerSeries_C]
+
+variable (h1 : (1 : ℝ) ∈ Γ.strictPeriods)
+
+include h1 in
+private theorem Lq_one_mul [Γ.HasDetOne] {k k' : ℤ} (A : ModularForm Γ k) (B : ModularForm Γ k') :
+    Lq 1 ⇑(A.mul B) = Lq 1 ⇑A * Lq 1 ⇑B := by
+  rw [Lq, Lq, Lq, ← map_mul, ModularForm.qExpansion_mul one_pos h1]
+
+include h1 in
+private theorem Lq_one_add {k : ℤ} (A B : ModularForm Γ k) :
+    Lq 1 ⇑(A + B) = Lq 1 ⇑A + Lq 1 ⇑B := by
+  rw [Lq, Lq, Lq, ← map_add, FunLike.coe_add, ← ModularForm.qExpansion_add one_pos h1 A B]
+
+include h1 in
+private theorem Lq_one_smul [Γ.HasDetOne] {k : ℤ} (c : ℂ) (A : ModularForm Γ k) :
+    Lq 1 ⇑(c • A) = HahnSeries.C c * Lq 1 ⇑A := by
+  rw [Lq, Lq, FunLike.coe_smul, ModularForm.qExpansion_smul one_pos h1 c A,
+    PowerSeries.smul_eq_C_mul, map_mul, HahnSeries.ofPowerSeries_C]
+
+private theorem Lq_one_zero {k : ℤ} : Lq 1 ⇑(0 : ModularForm Γ k) = 0 := by
+  rw [FunLike.coe_zero]
+  exact Lq_zero_fun 1
+
+include h1 in
+private theorem eq_of_Lq_one_eq {k : ℤ} {A B : ModularForm Γ k} (H : Lq 1 ⇑A = Lq 1 ⇑B) :
+    A = B := by
+  have hsub : qExpansion 1 ⇑(A - B) = 0 := by
+    have := ModularForm.qExpansion_sub one_pos h1 A B
+    rw [FunLike.coe_sub]
+    rw [this, sub_eq_zero]
+    exact HahnSeries.ofPowerSeries_injective H
+  have := (ModularForm.qExpansion_eq_zero_iff one_pos h1 (A - B)).1 hsub
+  exact sub_eq_zero.1 this
+
+include h1 in
+private theorem Lq_one_ne_zero {k : ℤ} {A : ModularForm Γ k} (hA : A ≠ 0) : Lq 1 ⇑A ≠ 0 := by
+  rw [ne_eq, Lq_eq_zero_iff, ModularForm.qExpansion_eq_zero_iff one_pos h1]
+  exact hA
+
+include h1 in
+private theorem mul_ne_zero_MF [Γ.HasDetOne] {k k' : ℤ} {A : ModularForm Γ k} {B : ModularForm Γ k'}
+    (hA : A ≠ 0) (hB : B ≠ 0) : A.mul B ≠ 0 := by
+  intro H
+  have h := congrArg (fun C : ModularForm Γ (k + k') => Lq 1 ⇑C) H
+  rw [Lq_one_mul h1, Lq_one_zero] at h
+  exact mul_ne_zero (Lq_one_ne_zero h1 hA) (Lq_one_ne_zero h1 hB) h
+
+include hN h1 in
+private theorem cuspRatio_eq_of_cross [Γ.HasDetOne] {k k' : ℤ} {g h : ModularForm Γ k}
+    {g' h' : ModularForm Γ k'}
+    (hh : h ≠ 0) (hh' : h' ≠ 0) (H : Lq 1 ⇑g * Lq 1 ⇑h' = Lq 1 ⇑g' * Lq 1 ⇑h) :
+    cuspRatio σ N g h = cuspRatio σ N g' h' := by
+  have hforms : g.mul h' = h.mul g' := by
+    apply eq_of_Lq_one_eq h1
+    rw [Lq_one_mul h1, Lq_one_mul h1, H, mul_comm]
+  have hL : Lq N (⇑g ∣[k] σ) * Lq N (⇑h' ∣[k'] σ) = Lq N (⇑h ∣[k] σ) * Lq N (⇑g' ∣[k'] σ) := by
+    rw [← Lq_slash_mul σ N hN, ← Lq_slash_mul σ N hN, hforms]
+  rw [cuspRatio, cuspRatio, div_eq_div_iff (Lq_slash_ne_zero σ N hN hh)
+    (Lq_slash_ne_zero σ N hN hh'), hL, mul_comm]
+
+include hN in
+private theorem cuspRatio_mul [Γ.HasDetOne] {k k' : ℤ} (g h : ModularForm Γ k)
+    (g' h' : ModularForm Γ k') :
+    cuspRatio σ N (g.mul g') (h.mul h') = cuspRatio σ N g h * cuspRatio σ N g' h' := by
+  rw [cuspRatio, cuspRatio, cuspRatio, Lq_slash_mul σ N hN, Lq_slash_mul σ N hN,
+    mul_div_mul_comm]
+
+include hN in
+private theorem cuspRatio_add [Γ.HasDetOne] {k k' : ℤ} {g h : ModularForm Γ k}
+    {g' h' : ModularForm Γ k'}
+    (hh : h ≠ 0) (hh' : h' ≠ 0) :
+    cuspRatio σ N (g.mul h' + h.mul g') (h.mul h') = cuspRatio σ N g h + cuspRatio σ N g' h' := by
+  rw [cuspRatio, cuspRatio, cuspRatio, Lq_slash_add σ N hN, Lq_slash_mul σ N hN,
+    Lq_slash_mul σ N hN, Lq_slash_mul σ N hN,
+    div_add_div _ _ (Lq_slash_ne_zero σ N hN hh) (Lq_slash_ne_zero σ N hN hh')]
+
+omit [NeZero N] in
+private theorem cuspRatio_zero_left {k : ℤ} (h : ModularForm Γ k) :
+    cuspRatio σ N (0 : ModularForm Γ k) h = 0 := by
+  rw [cuspRatio, FunLike.coe_zero, SlashAction.zero_slash, Lq_zero_fun, zero_div]
+
+include hN in
+private theorem cuspRatio_self {k : ℤ} {h : ModularForm Γ k} (hh : h ≠ 0) : cuspRatio σ N h h = 1 :=
+  div_self (Lq_slash_ne_zero σ N hN hh)
+
+include hN in
+private theorem cuspRatio_smul [Γ.HasDetOne] {k : ℤ} (c : ℂ) {h : ModularForm Γ k} (hh : h ≠ 0) :
+    cuspRatio σ N (c • h) h = HahnSeries.C c := by
+  rw [cuspRatio, Lq_slash_smul σ N hN, mul_div_assoc, div_self (Lq_slash_ne_zero σ N hN hh),
+    mul_one]
+
+end Generic
+
+section Orders
+
+private theorem order_eq_of_coeff {R : Type*} [CommRing R] {x : LaurentSeries R} {m : ℤ}
+    (hm : x.coeff m ≠ 0) (hlt : ∀ k < m, x.coeff k = 0) : x.order = m := by
+  have hx : x ≠ 0 := fun h => hm (by simp [h])
+  apply le_antisymm (HahnSeries.order_le_of_coeff_ne_zero hm)
+  by_contra hlt'
+  exact (fun h => hx (HahnSeries.coeff_order_eq_zero.mp h)) (hlt _ (not_le.mp hlt'))
+
+private theorem order_qExpand (N : ℕ) [NeZero N] {R : Type*} [CommRing R] {y : LaurentSeries R}
+    (hy : y ≠ 0) :
+    (ModularCurve.qExpand R N y).order = N * y.order := by
+  apply order_eq_of_coeff
+  · rw [ModularCurve.qExpand_coeff_mul]
+    exact fun h => hy (HahnSeries.coeff_order_eq_zero.mp h)
+  · intro k hk
+    by_cases hdvd : (N : ℤ) ∣ k
+    · obtain ⟨k', rfl⟩ := hdvd
+      rw [ModularCurve.qExpand_coeff_mul]
+      apply HahnSeries.coeff_eq_zero_of_lt_order
+      have hN0 : (0 : ℤ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+      nlinarith
+    · exact ModularCurve.qExpand_coeff_of_not_dvd N y hdvd
+
+private theorem order_coeffEmb_jq : (ModularCurve.coeffEmb ℂ ModularCurve.jq).order = -1 := by
+  apply order_eq_of_coeff
+  · rw [ModularCurve.coeffEmb_coeff, ModularCurve.coeff_jq_neg_one, map_one]
+    exact one_ne_zero
+  · intro k hk
+    rw [ModularCurve.coeffEmb_coeff, ModularCurve.coeff_jq_of_lt hk, map_zero]
+
+private theorem coeffEmb_jq_ne_zero : ModularCurve.coeffEmb ℂ ModularCurve.jq ≠ 0 := by
+  intro h
+  have := order_coeffEmb_jq
+  rw [h, HahnSeries.order_zero] at this
+  omega
+
+private theorem Lq_natCast_eq_qExpand (N : ℕ) [NeZero N] {F : ℍ → ℂ}
+    (hcoeff : ∀ n : ℕ, (qExpansion N F).coeff n =
+      if N ∣ n then (qExpansion 1 F).coeff (n / N) else 0) :
+    Lq N F = ModularCurve.qExpand ℂ N (Lq 1 F) := by
+  ext m
+  rw [Lq, Lq]
+  by_cases hdvd : (N : ℤ) ∣ m
+  · obtain ⟨k, rfl⟩ := hdvd
+    rw [ModularCurve.qExpand_coeff_mul]
+    rcases lt_or_ge k 0 with hk | hk
+    · have hNk : (N : ℤ) * k < 0 := by
+        have hN0 : (0 : ℤ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+        nlinarith
+      rw [ModularCurve.ofPowerSeries_coeff_of_neg _ hNk, ModularCurve.ofPowerSeries_coeff_of_neg _
+        hk]
+    · obtain ⟨n, rfl⟩ := Int.eq_ofNat_of_zero_le hk
+      rw [show ((N : ℤ) * (n : ℤ)) = ((N * n : ℕ) : ℤ) by push_cast; ring,
+        HahnSeries.ofPowerSeries_apply_coeff, HahnSeries.ofPowerSeries_apply_coeff, hcoeff,
+        ite_eq_left (dvd_mul_right N n), Nat.mul_div_cancel_left n (Nat.pos_of_ne_zero (NeZero.ne
+          N))]
+  · rw [ModularCurve.qExpand_coeff_of_not_dvd N _ hdvd]
+    rcases lt_or_ge m 0 with hm | hm
+    · exact ModularCurve.ofPowerSeries_coeff_of_neg _ hm
+    · obtain ⟨n, rfl⟩ := Int.eq_ofNat_of_zero_le hm
+      rw [HahnSeries.ofPowerSeries_apply_coeff, hcoeff, ite_eq_right]
+      exact fun h => hdvd (by exact_mod_cast h)
+
+private theorem order_ofPowerSeries {R : Type*} [CommRing R] {p : PowerSeries R} (hp : p ≠ 0) :
+    (HahnSeries.ofPowerSeries ℤ R p).order = p.order.toNat := by
+  apply order_eq_of_coeff
+  · rw [HahnSeries.ofPowerSeries_apply_coeff]
+    exact PowerSeries.coeff_order hp
+  · intro k hk
+    rcases lt_or_ge k 0 with hk0 | hk0
+    · exact ModularCurve.ofPowerSeries_coeff_of_neg _ hk0
+    · obtain ⟨n, rfl⟩ := Int.eq_ofNat_of_zero_le hk0
+      rw [HahnSeries.ofPowerSeries_apply_coeff]
+      exact PowerSeries.coeff_of_lt_order_toNat n (by exact_mod_cast hk)
+
+private theorem order_inv_lq {R : Type*} [Field R] {x : LaurentSeries R} (hx : x ≠ 0) :
+    (x⁻¹).order = -x.order := by
+  have h := HahnSeries.order_mul hx (inv_ne_zero hx)
+  rw [mul_inv_cancel₀ hx, HahnSeries.order_one] at h
+  omega
+
+private theorem PowerSeries_order_eq_of_div_order_eq_zero {R : Type*} [Field R]
+    {p q : PowerSeries R}
+    (hp : p ≠ 0) (hq : q ≠ 0)
+    (h0 : (HahnSeries.ofPowerSeries ℤ R p / HahnSeries.ofPowerSeries ℤ R q).order = 0) :
+    p.order = q.order := by
+  have hpL : HahnSeries.ofPowerSeries ℤ R p ≠ 0 := fun h =>
+    hp (HahnSeries.ofPowerSeries_injective (by rw [h, map_zero]))
+  have hqL : HahnSeries.ofPowerSeries ℤ R q ≠ 0 := fun h =>
+    hq (HahnSeries.ofPowerSeries_injective (by rw [h, map_zero]))
+  rw [div_eq_mul_inv, HahnSeries.order_mul hpL (inv_ne_zero hqL), order_inv_lq hqL,
+    order_ofPowerSeries hp, order_ofPowerSeries hq] at h0
+  rw [← PowerSeries.coe_toNat_order hp, ← PowerSeries.coe_toNat_order hq]
+  norm_cast
+  omega
+
+end Orders
+
+section Concrete
+
+variable (Γ : Subgroup SL(2, ℤ)) (N : ℕ) [NeZero N] (σ : SL(2, ℤ))
+
+private abbrev Γ0 : Subgroup (GL (Fin 2) ℝ) := (Γ : Subgroup (GL (Fin 2) ℝ))
+
+private abbrev Γ1top : Subgroup (GL (Fin 2) ℝ) := (CongruenceSubgroup.Gamma0 1 : Subgroup SL(2, ℤ))
+
+private abbrev CF : IntermediateField ℂ (LaurentSeries ℂ) :=
+  ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ)
+
+private theorem one_mem_strictPeriods_levelOne : (1 : ℝ) ∈ Γ1top.strictPeriods := by
+  change (1 : ℝ) ∈ Subgroup.strictPeriods
+    ((CongruenceSubgroup.Gamma0 1 : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ))
+  rw [CongruenceSubgroup.strictPeriods_Gamma0]
+  exact AddSubgroup.mem_zmultiples _
+
+variable [hTΓ : Fact (ModularGroup.T ∈ Γ)]
+
+private theorem one_mem_strictPeriods_Gamma0 : (1 : ℝ) ∈ (Γ0 Γ).strictPeriods := by
+  change (1 : ℝ) ∈ Subgroup.strictPeriods ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ))
+  rw [Subgroup.strictPeriods_eq_zmultiples_one_of_T_mem hTΓ.out]
+  exact AddSubgroup.mem_zmultiples _
+
+private def Pres : Prop :=
+  ∀ x : LaurentSeries ℂ,
+    x ∈ ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ) →
+      ∃ (k : ℤ) (g h : ModularForm (Γ0 Γ) k), h ≠ 0 ∧
+        x * ((qExpansion 1 (h : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+          ((qExpansion 1 (g : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+
+variable (pres : Pres Γ)
+variable (hN : (N : ℝ) ∈ (ConjAct.toConjAct (σ : GL (Fin 2) ℝ)⁻¹ • Γ0 Γ).strictPeriods)
+
+private def presWt (x : CF Γ) : ℤ := (pres x x.2).choose
+
+private def presNum (x : CF Γ) :
+    ModularForm (Γ0 Γ) (presWt Γ pres x) := (pres x x.2).choose_spec.choose
+
+private def presDen (x : CF Γ) : ModularForm (Γ0 Γ) (presWt Γ pres x) :=
+  (pres x x.2).choose_spec.choose_spec.choose
+
+omit hTΓ in
+private theorem presDen_ne_zero (x : CF Γ) : presDen Γ pres x ≠ 0 :=
+  (pres x x.2).choose_spec.choose_spec.choose_spec.1
+
+omit hTΓ in
+private theorem pres_eq (x : CF Γ) :
+    (x : LaurentSeries ℂ) * Lq 1 ⇑(presDen Γ pres x) = Lq 1 ⇑(presNum Γ pres x) :=
+  (pres x x.2).choose_spec.choose_spec.choose_spec.2
+
+private def Φσfun (x : CF Γ) : LaurentSeries ℂ :=
+  cuspRatio σ N (presNum Γ pres x) (presDen Γ pres x)
+
+include hN in
+private theorem Φσfun_eq {x : CF Γ} {k : ℤ} {g h : ModularForm (Γ0 Γ) k} (hh : h ≠ 0)
+    (hx : (x : LaurentSeries ℂ) * Lq 1 ⇑h = Lq 1 ⇑g) :
+    Φσfun Γ N σ pres x = cuspRatio σ N g h := by
+  apply cuspRatio_eq_of_cross σ N hN (one_mem_strictPeriods_Gamma0 Γ) (presDen_ne_zero Γ pres x) hh
+  rw [← pres_eq Γ pres x, ← hx]
+  ring
+
+include hN in
+private def Φσ : CF Γ →+* LaurentSeries ℂ where
+  toFun := Φσfun Γ N σ pres
+  map_one' := by
+    have h := Φσfun_eq Γ N σ pres hN (x := 1) (presDen_ne_zero Γ pres 1)
+      (g := presDen Γ pres 1) (by simp)
+    rw [h, cuspRatio_self σ N hN (presDen_ne_zero Γ pres 1)]
+  map_mul' x y := by
+    have hx := pres_eq Γ pres x
+    have hy := pres_eq Γ pres y
+    have h := Φσfun_eq Γ N σ pres hN (x := x * y)
+      (g := (presNum Γ pres x).mul (presNum Γ pres y))
+      (h := (presDen Γ pres x).mul (presDen Γ pres y))
+      (mul_ne_zero_MF (one_mem_strictPeriods_Gamma0 Γ) (presDen_ne_zero Γ pres x)
+        (presDen_ne_zero Γ pres y)) (by
+        rw [Lq_one_mul (one_mem_strictPeriods_Gamma0 Γ), Lq_one_mul (one_mem_strictPeriods_Gamma0
+          Γ),
+          ← hx, ← hy]
+        push_cast
+        ring)
+    rw [h, cuspRatio_mul σ N hN, Φσfun, Φσfun]
+  map_zero' := by
+    have h := Φσfun_eq Γ N σ pres hN (x := 0) (presDen_ne_zero Γ pres 1)
+      (g := (0 : ModularForm (Γ0 Γ) (presWt Γ pres 1))) (by
+        rw [Lq_one_zero]; simp)
+    rw [h, cuspRatio_zero_left]
+  map_add' x y := by
+    have hx := pres_eq Γ pres x
+    have hy := pres_eq Γ pres y
+    have h := Φσfun_eq Γ N σ pres hN (x := x + y)
+      (g := (presNum Γ pres x).mul (presDen Γ pres y) + (presDen Γ pres x).mul (presNum Γ pres y))
+      (h := (presDen Γ pres x).mul (presDen Γ pres y))
+      (mul_ne_zero_MF (one_mem_strictPeriods_Gamma0 Γ) (presDen_ne_zero Γ pres x)
+        (presDen_ne_zero Γ pres y)) (by
+        rw [Lq_one_add (one_mem_strictPeriods_Gamma0 Γ),
+          Lq_one_mul (one_mem_strictPeriods_Gamma0 Γ), Lq_one_mul (one_mem_strictPeriods_Gamma0 Γ),
+          Lq_one_mul (one_mem_strictPeriods_Gamma0 Γ), ← hx, ← hy]
+        push_cast
+        ring)
+    rw [h, cuspRatio_add σ N hN (presDen_ne_zero Γ pres x) (presDen_ne_zero Γ pres y), Φσfun,
+      Φσfun]
+
+include hN in
+private theorem Φσ_apply (x : CF Γ) : Φσ Γ N σ pres hN x = Φσfun Γ N σ pres x := rfl
+
+include hN in
+private theorem Φσ_eq {x : CF Γ} {k : ℤ} {g h : ModularForm (Γ0 Γ) k} (hh : h ≠ 0)
+    (hx : (x : LaurentSeries ℂ) * Lq 1 ⇑h = Lq 1 ⇑g) :
+    Φσ Γ N σ pres hN x = Lq N (⇑g ∣[k] σ) / Lq N (⇑h ∣[k] σ) :=
+  Φσfun_eq Γ N σ pres hN hh hx
+
+include hN in
+private theorem Φσ_algebraMap (c : ℂ) :
+    Φσ Γ N σ pres hN (algebraMap ℂ (CF Γ) c) = HahnSeries.C c := by
+  have h := Φσfun_eq Γ N σ pres hN (x := algebraMap ℂ (CF Γ) c) (presDen_ne_zero Γ pres 1)
+    (g := c • presDen Γ pres 1) (by
+      rw [Lq_one_smul (one_mem_strictPeriods_Gamma0 Γ)]
+      simp [ModularCurve.algebraMap_laurentSeries_eq_single, HahnSeries.C_apply])
+  rw [Φσ_apply, h, cuspRatio_smul σ N hN c (presDen_ne_zero Γ pres 1)]
+
+omit hTΓ in
+private theorem Gamma0_le_Gamma0_one : Γ0 Γ ≤ Γ1top :=
+  Subgroup.map_mono fun _ _ => CongruenceSubgroup.Gamma0_mem.mpr (Subsingleton.elim _ _)
+
+private def restrictOne {k : ℤ} (f : ModularForm (Γ1top) k) : ModularForm (Γ0 Γ) k where
+  toSlashInvariantForm :=
+    { toFun := ⇑f
+      slash_action_eq' := fun γ hγ =>
+        SlashInvariantForm.slash_action_eqn f γ (Gamma0_le_Gamma0_one Γ hγ) }
+  holo' := ModularFormClass.holo f
+  bdd_at_cusps' hc := ModularFormClass.bdd_at_cusps f (hc.mono (Gamma0_le_Gamma0_one Γ))
+
+omit hTΓ in
+@[scoped simp]
+private theorem coe_restrictOne {k : ℤ} (f : ModularForm (Γ1top) k) : ⇑(restrictOne Γ f) = ⇑f := rfl
+
+private theorem slash_eq_self_of_level_one {k : ℤ} (f : ModularForm (Γ1top) k) :
+    ⇑f ∣[k] σ = ⇑f := by
+  have hσ : (σ : GL (Fin 2) ℝ) ∈ Γ1top :=
+    Subgroup.mem_map_of_mem _ (CongruenceSubgroup.Gamma0_mem.mpr (Subsingleton.elim _ _))
+  rw [SL_slash]
+  exact SlashInvariantForm.slash_action_eqn f _ hσ
+
+private def PresJ : Prop :=
+  ∃ (k : ℤ) (g h : ModularForm (CongruenceSubgroup.Gamma0 1) k), h ≠ 0 ∧
+    ModularCurve.coeffEmb ℂ (ModularCurve.qExpand ℚ 1 ModularCurve.jq) *
+        ((qExpansion 1 (h : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+      ((qExpansion 1 (g : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+
+private def Reindex : Prop :=
+  ∀ (k : ℤ) (f : ModularForm (CongruenceSubgroup.Gamma0 1) k) (n : ℕ),
+    (qExpansion N ⇑f).coeff n = if N ∣ n then (qExpansion 1 ⇑f).coeff (n / N) else 0
+
+include hN in
+private theorem Φσ_jq (presJ : PresJ) (reindex : Reindex N)
+    (hj : ModularCurve.coeffEmb ℂ ModularCurve.jq ∈ CF Γ) :
+    Φσ Γ N σ pres hN ⟨ModularCurve.coeffEmb ℂ ModularCurve.jq, hj⟩ =
+      ModularCurve.qExpand ℂ N (ModularCurve.coeffEmb ℂ ModularCurve.jq) := by
+  obtain ⟨k, g₁, h₁, hh₁, HJ⟩ := presJ
+  rw [ModularCurve.qExpand_one_apply] at HJ
+  have hh : restrictOne Γ h₁ ≠ 0 := fun H =>
+    hh₁ (DFunLike.coe_injective (by simpa using congrArg DFunLike.coe H))
+  have hpres : ((⟨ModularCurve.coeffEmb ℂ ModularCurve.jq, hj⟩ : CF Γ) : LaurentSeries ℂ) *
+      Lq 1 ⇑(restrictOne Γ h₁) = Lq 1 ⇑(restrictOne Γ g₁) := HJ
+  rw [Φσ_eq Γ N σ pres hN hh hpres, coe_restrictOne, coe_restrictOne,
+    slash_eq_self_of_level_one σ g₁, slash_eq_self_of_level_one σ h₁,
+    Lq_natCast_eq_qExpand N (reindex k g₁), Lq_natCast_eq_qExpand N (reindex k h₁), ← map_div₀]
+  congr 1
+  have hh₁L : Lq 1 ⇑h₁ ≠ 0 := Lq_one_ne_zero (one_mem_strictPeriods_levelOne) hh₁
+  exact (eq_div_of_mul_eq hh₁L HJ).symm
+
+include hN in
+private theorem order_Φσ_jq (presJ : PresJ) (reindex : Reindex N)
+    (hj : ModularCurve.coeffEmb ℂ ModularCurve.jq ∈ CF Γ) :
+    (Φσ Γ N σ pres hN ⟨ModularCurve.coeffEmb ℂ ModularCurve.jq, hj⟩).order = -N := by
+  rw [Φσ_jq Γ N σ pres hN presJ reindex hj, order_qExpand N coeffEmb_jq_ne_zero, order_coeffEmb_jq,
+    mul_neg_one]
+
+end Concrete
+end S3c
+
+open S3CuspLimit S3c
+
+namespace S3glue
+
+open ModularCurve
+
+variable (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] [hTΓ : Fact (ModularGroup.T ∈ Γ)]
+
+private theorem presN : S3c.Pres Γ := fun x hx =>
+  exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC Γ hTΓ.out x hx
+
+private theorem presJ1 : S3c.PresJ :=
+  exists_modularForm_mul_qExpansion_eq_coeffEmb_qExpand_jq 1 1 (dvd_refl 1)
+
+private theorem reindexN (N : ℕ) [NeZero N] : S3c.Reindex N := fun k f n => by
+  have : Fact (IsCusp OnePoint.infty S3c.Γ1top) :=
+    ⟨Subgroup.isCusp_of_mem_strictPeriods one_pos S3c.one_mem_strictPeriods_levelOne⟩
+  exact S3CuspLimit.qExpansion_natCast_coeff N
+    (SlashInvariantFormClass.periodic_comp_ofComplex f S3c.one_mem_strictPeriods_levelOne)
+    (ModularFormClass.holo f) (ModularFormClass.bdd_at_infty f) n
+
+variable (σ : SL(2, ℤ))
+
+omit hTΓ in
+private theorem hNσ :
+    ((S3CuspLimit.wd Γ : ℕ) : ℝ) ∈ (ConjAct.toConjAct (σ : GL (Fin 2) ℝ)⁻¹ • S3c.Γ0 Γ).strictPeriods
+      :=
+  S3CuspLimit.natCast_mem_strictPeriods_translate Γ σ
+
+omit [Γ.FiniteIndex] in
+private theorem realizeOf_smul_eventuallyEq_div {k : ℤ}
+    (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (x : LaurentSeries ℂ)
+    (hxgh : x * ((qExpansion 1 (h : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+        ((qExpansion 1 (g : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ))
+    (hne : ∀ᶠ τ in atImInfty, (h : ℍ → ℂ) (σ • τ) ≠ 0) :
+    (fun τ : ℍ => realizeOf Γ x (σ • τ)) =ᶠ[atImInfty]
+      fun τ : ℍ => (g : ℍ → ℂ) (σ • τ) / (h : ℍ → ℂ) (σ • τ) := by
+  filter_upwards [hne] with τ hτ
+  exact realizeOf_eq_div Γ hTΓ.out g h x hxgh (σ • τ) hτ
+
+omit hTΓ in
+private theorem eventually_apply_smul_ne_zero {k : ℤ}
+    (h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hh : h ≠ 0) :
+    ∀ᶠ τ in atImInfty, (h : ℍ → ℂ) (σ • τ) ≠ 0 := by
+  have key := S3CuspLimit.eventually_ne_zero_atImInfty (S3CuspLimit.slash_periodic h σ)
+    (S3CuspLimit.slash_mdiff h σ) (S3CuspLimit.slash_bddAtImInfty h σ)
+    (S3CuspLimit.qExpansion_slash_ne_zero h σ hh)
+  filter_upwards [key] with τ hτ hc
+  apply hτ
+  rw [SL_slash_apply, hc, zero_mul]
+
+theorem jqModC_complex_eq_coeffEmb :
+    ModularCurve.jqModC ℂ = ModularCurve.coeffEmb ℂ ModularCurve.jq := by
+  rw [← ModularCurve.map_jqModC (algebraMap ℚ ℂ), ModularCurve.jqModC_rat]
+  ext n
+  rw [HahnSeries.map_coeff, ModularCurve.coeffEmb_coeff]
+
+end S3glue
+
+open S3glue S3CuspLimit
+
+namespace S3readout
+
+open ModularCurve
+
+variable (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] [hTΓ : Fact (ModularGroup.T ∈ Γ)] (σ : SL(2, ℤ))
+
+private def Φ : S3c.CF Γ →+* LaurentSeries ℂ :=
+  S3c.Φσ Γ (S3CuspLimit.wd Γ) σ (S3glue.presN Γ) (S3glue.hNσ Γ σ)
+
+private theorem Φ_eq {x : S3c.CF Γ} {k : ℤ} {g h : ModularForm (S3c.Γ0 Γ) k} (hh : h ≠ 0)
+    (hx : (x : LaurentSeries ℂ) * S3c.Lq 1 ⇑h = S3c.Lq 1 ⇑g) :
+    Φ Γ σ x = S3c.Lq (S3CuspLimit.wd Γ) (⇑g ∣[k] σ) / S3c.Lq (S3CuspLimit.wd Γ) (⇑h ∣[k] σ) :=
+  S3c.Φσ_eq Γ (S3CuspLimit.wd Γ) σ (S3glue.presN Γ) (S3glue.hNσ Γ σ) hh hx
+
+private theorem Φ_algebraMap (c : ℂ) : Φ Γ σ (algebraMap ℂ (S3c.CF Γ) c) = HahnSeries.C c :=
+  S3c.Φσ_algebraMap Γ (S3CuspLimit.wd Γ) σ (S3glue.presN Γ) (S3glue.hNσ Γ σ) c
+
+omit [Γ.FiniteIndex] hTΓ in
+private theorem jq_mem : coeffEmb ℂ jq ∈ S3c.CF Γ := by
+  apply ModularCurve.coeffEmb_mem_laurentBaseChange ℂ
+  have h := ModularCurve.jqModC_mem_intFormRatiosC ℚ Γ
+  rw [ModularCurve.jqModC_rat] at h
+  exact ModularCurve.intFormRatiosC_subset ℚ Γ h
+
+private def J : S3c.CF Γ := ⟨coeffEmb ℂ jq, jq_mem Γ⟩
+
+private theorem order_Φ_J : (Φ Γ σ (J Γ)).order = -(S3CuspLimit.wd Γ : ℤ) :=
+  S3c.order_Φσ_jq Γ (S3CuspLimit.wd Γ) σ (S3glue.presN Γ) (S3glue.hNσ Γ σ) S3glue.presJ1
+    (S3glue.reindexN (S3CuspLimit.wd Γ)) (jq_mem Γ)
+
+private theorem order_Φ_J_neg : (Φ Γ σ (J Γ)).order < 0 := by
+  rw [order_Φ_J]; simp [Nat.pos_of_ne_zero (NeZero.ne (S3CuspLimit.wd Γ))]
+
+private def P : AlgebraicCurve.Place ℂ (S3c.CF Γ) :=
+  S3c.orderPlace (Φ Γ σ) (Φ_algebraMap Γ σ) (order_Φ_J_neg Γ σ)
+
+private theorem mem_P_iff (x : S3c.CF Γ) : x ∈ (P Γ σ).toValuationSubring ↔ 0 ≤ (Φ Γ σ x).order :=
+  S3c.mem_orderPlace_iff (Φ Γ σ) (Φ_algebraMap Γ σ) (order_Φ_J_neg Γ σ)
+
+private theorem order_Φ_eq_sub {x : S3c.CF Γ} (hx : x ≠ 0) {k : ℤ} {g h : ModularForm (S3c.Γ0 Γ) k}
+    (hh : h ≠ 0) (hxgh : (x : LaurentSeries ℂ) * S3c.Lq 1 ⇑h = S3c.Lq 1 ⇑g) :
+    (Φ Γ σ x).order =
+      ((qExpansion (S3CuspLimit.wd Γ : ℝ) (⇑g ∣[k] σ)).order.toNat : ℤ) -
+        ((qExpansion (S3CuspLimit.wd Γ : ℝ) (⇑h ∣[k] σ)).order.toNat : ℤ) := by
+  have hg : g ≠ 0 := by
+    intro hc
+    apply hx
+    apply Subtype.ext
+    have h1 : (x : LaurentSeries ℂ) * S3c.Lq 1 ⇑h = 0 := by
+      rw [show (x : LaurentSeries ℂ) * S3c.Lq 1 ⇑h = S3c.Lq 1 ⇑g from hxgh, hc, S3c.Lq_def,
+        FunLike.coe_zero, qExpansion_zero, map_zero]
+    exact (mul_eq_zero.mp h1).resolve_right (S3c.Lq_one_ne_zero (S3c.one_mem_strictPeriods_Gamma0 Γ)
+      hh)
+  have hgq : qExpansion (S3CuspLimit.wd Γ : ℝ) (⇑g ∣[k] σ) ≠ 0 :=
+    S3CuspLimit.qExpansion_slash_ne_zero g σ hg
+  have hhq : qExpansion (S3CuspLimit.wd Γ : ℝ) (⇑h ∣[k] σ) ≠ 0 :=
+    S3CuspLimit.qExpansion_slash_ne_zero h σ hh
+  have hgL : S3c.Lq (S3CuspLimit.wd Γ) (⇑g ∣[k] σ) ≠ 0 := (S3c.Lq_eq_zero_iff _ _).not.mpr hgq
+  have hhL : S3c.Lq (S3CuspLimit.wd Γ) (⇑h ∣[k] σ) ≠ 0 := (S3c.Lq_eq_zero_iff _ _).not.mpr hhq
+  rw [Φ_eq Γ σ hh hxgh, div_eq_mul_inv, HahnSeries.order_mul hgL (inv_ne_zero hhL), S3c.order_inv_lq
+    hhL,
+    S3c.Lq_def, S3c.Lq_def, S3c.order_ofPowerSeries hgq, S3c.order_ofPowerSeries hhq]
+  ring
+
+private theorem realizeOf_smul_eventuallyEq {x : S3c.CF Γ} {k : ℤ} {g h : ModularForm (S3c.Γ0 Γ) k}
+    (hh : h ≠ 0) (hxgh : (x : LaurentSeries ℂ) * S3c.Lq 1 ⇑h = S3c.Lq 1 ⇑g) :
+    (fun τ : ℍ => realizeOf Γ (x : LaurentSeries ℂ) (σ • τ)) =ᶠ[atImInfty]
+      fun τ : ℍ => (⇑g ∣[k] σ) τ / (⇑h ∣[k] σ) τ := by
+  have hne := S3glue.eventually_apply_smul_ne_zero Γ σ h hh
+  have heq := S3glue.realizeOf_smul_eventuallyEq_div Γ σ g h (x : LaurentSeries ℂ) hxgh hne
+  exact heq.trans (Filter.Eventually.of_forall fun τ => S3CuspLimit.div_comp_smul_eq_div_slash k
+    (⇑g) (⇑h) σ τ)
+
+private theorem leading_term {x : S3c.CF Γ} (hx : x ≠ 0) :
+    ∃ L : ℂ, L ≠ 0 ∧ Tendsto (fun τ : ℍ => realizeOf Γ (x : LaurentSeries ℂ) (σ • τ) *
+        Periodic.qParam (S3CuspLimit.wd Γ : ℝ) (τ : ℂ) ^ (-(Φ Γ σ x).order)) atImInfty (𝓝 L) := by
+  obtain ⟨k, g, h, hh, hxgh⟩ := S3glue.presN Γ (x : LaurentSeries ℂ) x.2
+  have hg : g ≠ 0 := by
+    intro hc; apply hx; apply Subtype.ext
+    have h1 : (x : LaurentSeries ℂ) * S3c.Lq 1 ⇑h = 0 := by
+      rw [show (x : LaurentSeries ℂ) * S3c.Lq 1 ⇑h = S3c.Lq 1 ⇑g from hxgh, hc, S3c.Lq_def,
+        FunLike.coe_zero, qExpansion_zero, map_zero]
+    exact (mul_eq_zero.mp h1).resolve_right (S3c.Lq_one_ne_zero (S3c.one_mem_strictPeriods_Gamma0 Γ)
+      hh)
+  obtain ⟨L, hL, hT⟩ := S3CuspLimit.tendsto_div_mul_qParam_zpow
+    (S3CuspLimit.slash_periodic g σ) (S3CuspLimit.slash_mdiff g σ) (S3CuspLimit.slash_bddAtImInfty g
+      σ)
+    (S3CuspLimit.slash_periodic h σ) (S3CuspLimit.slash_mdiff h σ) (S3CuspLimit.slash_bddAtImInfty h
+      σ)
+    (S3CuspLimit.qExpansion_slash_ne_zero g σ hg) (S3CuspLimit.qExpansion_slash_ne_zero h σ hh)
+  refine ⟨L, hL, ?_⟩
+  rw [order_Φ_eq_sub Γ σ hx hh hxgh]
+  refine hT.congr' ?_
+  filter_upwards [realizeOf_smul_eventuallyEq Γ σ hh hxgh] with τ hτ
+  rw [hτ]
+
+private theorem mem_P_iff_tendsto {x : S3c.CF Γ} (hx : x ≠ 0) :
+    x ∈ (P Γ σ).toValuationSubring ↔
+      ∃ L : ℂ, Tendsto (fun τ : ℍ => realizeOf Γ (x : LaurentSeries ℂ) (σ • τ)) atImInfty (𝓝 L)
+        := by
+  obtain ⟨k, g, h, hh, hxgh⟩ := S3glue.presN Γ (x : LaurentSeries ℂ) x.2
+  have hg : g ≠ 0 := by
+    intro hc; apply hx; apply Subtype.ext
+    have h1 : (x : LaurentSeries ℂ) * S3c.Lq 1 ⇑h = 0 := by
+      rw [show (x : LaurentSeries ℂ) * S3c.Lq 1 ⇑h = S3c.Lq 1 ⇑g from hxgh, hc, S3c.Lq_def,
+        FunLike.coe_zero, qExpansion_zero, map_zero]
+    exact (mul_eq_zero.mp h1).resolve_right (S3c.Lq_one_ne_zero (S3c.one_mem_strictPeriods_Gamma0 Γ)
+      hh)
+  have hgq := S3CuspLimit.qExpansion_slash_ne_zero g σ hg
+  have hhq := S3CuspLimit.qExpansion_slash_ne_zero h σ hh
+  have heq := realizeOf_smul_eventuallyEq Γ σ hh hxgh
+  rw [mem_P_iff, order_Φ_eq_sub Γ σ hx hh hxgh, sub_nonneg, Nat.cast_le]
+  constructor
+  · intro hle
+    obtain ⟨L, hL⟩ := S3CuspLimit.exists_tendsto_div_of_le
+      (S3CuspLimit.slash_periodic g σ) (S3CuspLimit.slash_mdiff g σ) (S3CuspLimit.slash_bddAtImInfty
+        g σ)
+      (S3CuspLimit.slash_periodic h σ) (S3CuspLimit.slash_mdiff h σ) (S3CuspLimit.slash_bddAtImInfty
+        h σ)
+      hgq hhq hle
+    exact ⟨L, hL.congr' heq.symm⟩
+  · rintro ⟨L, hL⟩
+    by_contra hlt
+    rw [not_le] at hlt
+    exact S3CuspLimit.not_tendsto_div_of_lt
+      (S3CuspLimit.slash_periodic g σ) (S3CuspLimit.slash_mdiff g σ) (S3CuspLimit.slash_bddAtImInfty
+        g σ)
+      (S3CuspLimit.slash_periodic h σ) (S3CuspLimit.slash_mdiff h σ) (S3CuspLimit.slash_bddAtImInfty
+        h σ)
+      hgq hhq hlt L (hL.congr' heq)
+
+private theorem tendsto_realizeOf_zero :
+    Tendsto (fun τ : ℍ => realizeOf Γ (0 : LaurentSeries ℂ) (σ • τ)) atImInfty (𝓝 0) := by
+  set h₀ := S3c.presDen Γ (S3glue.presN Γ) 1
+  have hh₀ : h₀ ≠ 0 := S3c.presDen_ne_zero Γ (S3glue.presN Γ) 1
+  have hpres : (0 : LaurentSeries ℂ) * S3c.Lq 1 ⇑h₀ = S3c.Lq 1 ⇑(0 : ModularForm (S3c.Γ0 Γ)
+    (S3c.presWt Γ (S3glue.presN Γ) 1)) :=
+    by
+    rw [zero_mul, S3c.Lq_def, FunLike.coe_zero, qExpansion_zero, map_zero]
+  have hne := S3glue.eventually_apply_smul_ne_zero Γ σ h₀ hh₀
+  refine (tendsto_const_nhds (x := (0 : ℂ))).congr' ?_
+  filter_upwards [hne] with τ hτ
+  rw [realizeOf_eq_div Γ hTΓ.out 0 h₀ 0 hpres (σ • τ) hτ, FunLike.coe_zero, Pi.zero_apply, zero_div]
+
+private theorem qParam_zpow_neg_eq_exp (N : ℕ) (a b : ℤ) (τ : ℍ) :
+    Periodic.qParam (N : ℝ) (τ : ℂ) ^ (-(a * b)) =
+      Complex.exp (-(2 * Real.pi * Complex.I * ((a : ℂ) * (b : ℂ)) * (τ : ℂ) / (N : ℂ))) := by
+  rw [Periodic.qParam, ← Complex.exp_int_mul]
+  congr 1
+  push_cast
+  ring
+
+end S3readout
+end Ws49.CUSPLIM
+
+open ModularCurve Ws49 CUSPLIM S3CuspLimit S3c
+
+theorem solution
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (hF : F₀ = ModularCurve.qExpFunctionFieldC ℚ Γ)
+    (σ : SL(2, ℤ)) :
+    ∃ (Φ : ModularCurve.laurentBaseChange ℂ F₀ →+* LaurentSeries ℂ)
+      (P : AlgebraicCurve.Place ℂ (ModularCurve.laurentBaseChange ℂ F₀)) (e : ℕ),
+      0 < e ∧
+      (∀ x : ModularCurve.laurentBaseChange ℂ F₀, x ∈ P.toValuationSubring ↔ 0 ≤ (Φ x).order) ∧
+      (∀ x : ModularCurve.laurentBaseChange ℂ F₀, x ∈ P.toValuationSubring ↔
+        ∃ L : ℂ, Filter.Tendsto
+          (fun τ : UpperHalfPlane => ModularCurve.realizeOf Γ (x : LaurentSeries ℂ) (σ • τ))
+            atImInfty (𝓝 L)) ∧
+      (∀ (x : ModularCurve.laurentBaseChange ℂ F₀) (k : ℤ)
+          (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k), h ≠ 0 →
+        (x : LaurentSeries ℂ) *
+            ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries
+              ℂ) =
+          ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+            →
+        Φ x * ((UpperHalfPlane.qExpansion (Γ.normalCore.index : ℝ)
+              ((h : UpperHalfPlane → ℂ) ∣[k] σ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+          ((UpperHalfPlane.qExpansion (Γ.normalCore.index : ℝ)
+              ((g : UpperHalfPlane → ℂ) ∣[k] σ) : PowerSeries ℂ) : LaurentSeries ℂ)) ∧
+      (∀ c : ℂ, Φ (algebraMap ℂ (ModularCurve.laurentBaseChange ℂ F₀) c) = HahnSeries.C c) ∧
+      (∀ x : ModularCurve.laurentBaseChange ℂ F₀, x ≠ 0 → (Φ x).order = e * P.ord x) ∧
+      (∀ y : ModularCurve.laurentBaseChange ℂ F₀, (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ →
+        (Φ y).order = -(Γ.normalCore.index : ℤ) ∧ (e : ℤ) * P.ord y = -(Γ.normalCore.index : ℤ) ∧
+          y ∉ P.toValuationSubring) ∧
+      (∀ x : ModularCurve.laurentBaseChange ℂ F₀, x ≠ 0 → ∃ L : ℂ, L ≠ 0 ∧
+        Filter.Tendsto
+          (fun τ : UpperHalfPlane => ModularCurve.realizeOf Γ (x : LaurentSeries ℂ) (σ • τ) *
+            Complex.exp (-(2 * Real.pi * Complex.I * ((e : ℤ) * P.ord x : ℂ) * (τ : ℂ) /
+              (Γ.normalCore.index : ℂ))))
+          atImInfty (𝓝 L)) := by
+  subst hF
+  have hTΓ : Fact (ModularGroup.T ∈ Γ) := ⟨hT⟩
+  obtain ⟨e, he, hord⟩ := S3c.exists_order_eq_mul_ord (S3readout.Φ Γ σ) (S3readout.Φ_algebraMap Γ σ)
+    (S3readout.order_Φ_J_neg Γ σ)
+  refine ⟨S3readout.Φ Γ σ, S3readout.P Γ σ, e, he, S3readout.mem_P_iff Γ σ, ?_, ?_,
+    S3readout.Φ_algebraMap Γ σ,
+    hord, ?_, ?_⟩
+  · intro x
+    by_cases hx : x = 0
+    · subst hx
+      refine ⟨fun _ => ⟨0, ?_⟩, fun _ => zero_mem _⟩
+      simpa using S3readout.tendsto_realizeOf_zero Γ σ
+    · exact S3readout.mem_P_iff_tendsto Γ σ hx
+  · intro x k g h hh hxgh
+    have hhL : S3c.Lq (S3CuspLimit.wd Γ) (⇑h ∣[k] σ) ≠ 0 :=
+      (S3c.Lq_eq_zero_iff _ _).not.mpr (S3CuspLimit.qExpansion_slash_ne_zero h σ hh)
+    have := S3readout.Φ_eq Γ σ (x := x) hh hxgh
+    change S3readout.Φ Γ σ x * S3c.Lq (S3CuspLimit.wd Γ) (⇑h ∣[k] σ) = S3c.Lq (S3CuspLimit.wd Γ) (⇑g
+      ∣[k] σ)
+    rw [this, div_mul_cancel₀ _ hhL]
+  · intro y hy
+    have hyeq : (y : LaurentSeries ℂ) = coeffEmb ℂ jq := hy.trans S3glue.jqModC_complex_eq_coeffEmb
+    have hyel : y = S3readout.J Γ := Subtype.ext hyeq
+    subst hyel
+    have h1 : (S3readout.Φ Γ σ (S3readout.J Γ)).order = -(S3CuspLimit.wd Γ : ℤ) :=
+      S3readout.order_Φ_J Γ σ
+    have hJ0 : S3readout.J Γ ≠ 0 := by
+      intro h0
+      have : (S3readout.Φ Γ σ (S3readout.J Γ)).order = 0 :=
+        by rw [h0, map_zero, HahnSeries.order_zero]
+      rw [this] at h1
+      have := Nat.pos_of_ne_zero (NeZero.ne (S3CuspLimit.wd Γ))
+      omega
+    refine ⟨h1, ?_, ?_⟩
+    · have h2 := hord _ hJ0
+      rw [h1] at h2
+      exact h2.symm
+    · rw [S3readout.mem_P_iff, not_le]
+      exact S3readout.order_Φ_J_neg Γ σ
+  · intro x hx
+    obtain ⟨L, hL, hTend⟩ := S3readout.leading_term Γ σ hx
+    rw [hord x hx, show S3CuspLimit.wd Γ = Γ.normalCore.index from rfl] at hTend
+    refine ⟨L, hL, hTend.congr fun τ => ?_⟩
+    rw [S3readout.qParam_zpow_neg_eq_exp]
+    rfl
+
+end
+end S_ModularCurve_exists_ringHom_place_order_eq_mul_ord_of_qExpansion_slash
+end P2MW
+export P2MW.S_ModularCurve_exists_ringHom_place_order_eq_mul_ord_of_qExpansion_slash (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane
+open scoped MatrixGroups Topology ModularForm
+theorem ModularCurve.exists_ringHom_place_order_eq_mul_ord_of_qExpansion_slash
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (hF : F₀ = ModularCurve.qExpFunctionFieldC ℚ Γ)
+    (σ : SL(2, ℤ)) :
+    ∃ (Φ : ModularCurve.laurentBaseChange ℂ F₀ →+* LaurentSeries ℂ)
+      (P : AlgebraicCurve.Place ℂ (ModularCurve.laurentBaseChange ℂ F₀)) (e : ℕ),
+      0 < e ∧
+      (∀ x : ModularCurve.laurentBaseChange ℂ F₀, x ∈ P.toValuationSubring ↔ 0 ≤ (Φ x).order) ∧
+      (∀ x : ModularCurve.laurentBaseChange ℂ F₀, x ∈ P.toValuationSubring ↔
+        ∃ L : ℂ, Filter.Tendsto
+          (fun τ : UpperHalfPlane => ModularCurve.realizeOf Γ (x : LaurentSeries ℂ) (σ • τ))
+            atImInfty (𝓝 L)) ∧
+      (∀ (x : ModularCurve.laurentBaseChange ℂ F₀) (k : ℤ)
+          (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k), h ≠ 0 →
+        (x : LaurentSeries ℂ) *
+            ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries
+              ℂ) =
+          ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+            →
+        Φ x * ((UpperHalfPlane.qExpansion (Γ.normalCore.index : ℝ)
+              ((h : UpperHalfPlane → ℂ) ∣[k] σ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+          ((UpperHalfPlane.qExpansion (Γ.normalCore.index : ℝ)
+              ((g : UpperHalfPlane → ℂ) ∣[k] σ) : PowerSeries ℂ) : LaurentSeries ℂ)) ∧
+      (∀ c : ℂ, Φ (algebraMap ℂ (ModularCurve.laurentBaseChange ℂ F₀) c) = HahnSeries.C c) ∧
+      (∀ x : ModularCurve.laurentBaseChange ℂ F₀, x ≠ 0 → (Φ x).order = e * P.ord x) ∧
+      (∀ y : ModularCurve.laurentBaseChange ℂ F₀, (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ →
+        (Φ y).order = -(Γ.normalCore.index : ℤ) ∧ (e : ℤ) * P.ord y = -(Γ.normalCore.index : ℤ) ∧
+          y ∉ P.toValuationSubring) ∧
+      (∀ x : ModularCurve.laurentBaseChange ℂ F₀, x ≠ 0 → ∃ L : ℂ, L ≠ 0 ∧
+        Filter.Tendsto
+          (fun τ : UpperHalfPlane => ModularCurve.realizeOf Γ (x : LaurentSeries ℂ) (σ • τ) *
+            Complex.exp (-(2 * Real.pi * Complex.I * ((e : ℤ) * P.ord x : ℂ) * (τ : ℂ) /
+              (Γ.normalCore.index : ℂ))))
+          atImInfty (𝓝 L)) :=
+  solution Γ hT F₀ hF σ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_sl2_heckeDiagMatrix_smul_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_sl2_heckeDiagMatrix_smul_eq.lean
new file mode 100644
index 0000000000..80ca6a18cc
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_sl2_heckeDiagMatrix_smul_eq.lean
@@ -0,0 +1,153 @@
+/-
+Based on Prove2Me node ModularCurve.exists_sl2_heckeDiagMatrix_smul_eq
+(6bea930f-bce9-5be9-a811-f44a172afd10) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 56b8cf83-0bf7-544b-a3ad-ae9435c31a2a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.Complex.UpperHalfPlane.MoebiusAction
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Conjugating Γ₀(N) past diag(N,1) with equal denominators
+
+Theorem statement: `ModularCurve.exists_sl2_heckeDiagMatrix_smul_eq`
+(`6bea930f-bce9-5be9-a811-f44a172afd10`), by Claude, 2026-09-05.
+
+Proof: submission `56b8cf83-0bf7-544b-a3ad-ae9435c31a2a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number with $N \neq 0$, and let $\gamma \in \mathrm{SL}_2(\mathbb{Z})$ lie in
+the congruence subgroup $\Gamma_0(N)$, i.e. the reduction of its lower-left entry modulo $N$
+vanishes. Write $\delta_N$ for [`ModularForm.heckeDiagMatrix
+N`](def/ModularForm_HeckeOperator.html#L21), which for $N \neq 0$ is the element of
+$\mathrm{GL}_2(\mathbb{R})$ given by the upper triangular matrix $\begin{pmatrix} N & 0 \\ 0 &
+1\end{pmatrix}$ (and is $1$ when $N = 0$). The assertion is that there exists $\gamma' \in
+\mathrm{SL}_2(\mathbb{Z})$ with two properties. First, for every $\tau$ in the upper half plane,
+$\delta_N \cdot (\gamma \cdot \tau) = \gamma' \cdot (\delta_N \cdot \tau)$, the actions being the
+Möbius actions of $\mathrm{GL}_2(\mathbb{R})^+$ and of $\mathrm{SL}_2(\mathbb{Z})$ on the upper half
+plane; since $\delta_N$ acts by $\tau \mapsto N\tau$, this says $N(\gamma\tau) = \gamma'(N\tau)$.
+Second, the two automorphy denominators agree: for every $\tau$, $\mathrm{denom}(\gamma', N\tau) =
+\mathrm{denom}(\gamma, \tau)$, where $\mathrm{denom}(g, z) = g_{10} z + g_{11}$ and both matrices
+are viewed in $\mathrm{GL}_2(\mathbb{R})$ acting on $\mathbb{C}$-points. Thus the conjugate
+$\gamma'$ can be chosen so that no extra factor appears in the weight-$k$ automorphy factor.
+
+This is the elementary bookkeeping behind the statement that $\tau \mapsto \Phi(N\tau)$ is a form on
+$\Gamma_0(N)$ of the same weight whenever $\Phi$ is a form of level one, the matching of
+denominators giving the matching of automorphy factors. It is used in the project's treatment of the
+$N$-scaled $q$-expansion, for instance for the ratio of discriminants $\Delta(N\tau)/\Delta(\tau)$,
+for the Fricke involution on such functions and for the construction of functions with prescribed
+cuspidal divisor.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_sl2_heckeDiagMatrix_smul_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_sl2_heckeDiagMatrix_smul_eq
+
+noncomputable section
+
+open UpperHalfPlane
+open scoped MatrixGroups ModularForm
+
+namespace ModularCurve
+
+namespace QexpN
+
+open Matrix.SpecialLinearGroup ModularForm
+
+private theorem det_eq (g : SL(2, ℤ)) : g 0 0 * g 1 1 - g 0 1 * g 1 0 = 1 := by
+  have h := g.det_coe
+  rwa [Matrix.det_fin_two] at h
+
+private def conjSL {p : ℕ} (g : SL(2, ℤ)) (e : ℤ) (he : g 1 0 = p * e) : SL(2, ℤ) :=
+  ⟨!![g 0 0, p * g 0 1; e, g 1 1], by
+    rw [Matrix.det_fin_two_of]
+    linear_combination det_eq g + g 0 1 * he⟩
+
+private theorem heckeDiagMatrix_mul_mapGL {p : ℕ} (hp : p ≠ 0) (g : SL(2, ℤ)) (e : ℤ)
+    (he : g 1 0 = p * e) :
+    heckeDiagMatrix p * mapGL ℝ g = mapGL ℝ (conjSL g e he) * heckeDiagMatrix p := by
+  ext i j
+  fin_cases i <;> fin_cases j <;>
+    simp only [Fin.zero_eta, Fin.isValue, Units.val_mul, ne_eq, hp, not_false_eq_true,
+      val_heckeDiagMatrix, mapGL_coe_matrix, algebraMap_int_eq, map_apply_coe,
+      RingHom.mapMatrix_apply, Int.coe_castRingHom, Matrix.mul_apply, Matrix.of_apply,
+      Matrix.cons_val', Matrix.cons_val_fin_one, Matrix.cons_val_zero, Matrix.map_apply,
+      Fin.sum_univ_two, Matrix.cons_val_one, zero_mul, add_zero, conjSL, Int.cast_mul,
+      Int.cast_natCast, mul_zero, Fin.mk_one, mul_one, zero_add, one_mul]
+  all_goals first
+    | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination this)
+    | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination -this)
+    | ring1
+
+private theorem conjSL_apply_one_zero {p : ℕ} (g : SL(2, ℤ)) (e : ℤ) (he : g 1 0 = p * e) :
+    conjSL g e he 1 0 = e := rfl
+
+private theorem conjSL_apply_one_one {p : ℕ} (g : SL(2, ℤ)) (e : ℤ) (he : g 1 0 = p * e) :
+    conjSL g e he 1 1 = g 1 1 := rfl
+
+end QexpN
+
+end ModularCurve
+
+end
+
+open ModularCurve.QexpN in
+theorem solution (N : ℕ) [NeZero N] (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ)
+    (hγ : γ ∈ CongruenceSubgroup.Gamma0 N) :
+    ∃ γ' : Matrix.SpecialLinearGroup (Fin 2) ℤ, (∀ τ : UpperHalfPlane, ModularForm.heckeDiagMatrix N
+      • γ • τ = γ' • ModularForm.heckeDiagMatrix N • τ) ∧ ∀ τ : UpperHalfPlane, UpperHalfPlane.denom
+      (γ' : Matrix.GeneralLinearGroup (Fin 2) ℝ) (((ModularForm.heckeDiagMatrix N • τ :
+      UpperHalfPlane)) : ℂ) = UpperHalfPlane.denom (γ : Matrix.GeneralLinearGroup (Fin 2) ℝ) (τ : ℂ)
+      := by
+  have hN : N ≠ 0 := NeZero.ne N
+  obtain ⟨e, he⟩ : (N : ℤ) ∣ γ 1 0 :=
+    (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp (CongruenceSubgroup.Gamma0_mem.mp hγ)
+  refine ⟨ModularCurve.QexpN.conjSL γ e he, fun τ => ?_, fun τ => ?_⟩
+  · have h1 : ModularForm.heckeDiagMatrix N • γ • τ
+        = (ModularForm.heckeDiagMatrix N * Matrix.SpecialLinearGroup.mapGL ℝ γ) • τ := by
+      rw [mul_smul]; rfl
+    rw [h1, ModularCurve.QexpN.heckeDiagMatrix_mul_mapGL hN γ e he, mul_smul]; rfl
+  · rw [ModularGroup.denom_apply, ModularGroup.denom_apply,
+      ModularForm.coe_heckeDiagMatrix_smul hN]
+    have heC := congrArg (Int.cast : ℤ → ℂ) he
+    push_cast at heC
+    rw [ModularCurve.QexpN.conjSL_apply_one_zero, ModularCurve.QexpN.conjSL_apply_one_one]
+    linear_combination (-(τ : ℂ)) * heC
+
+end S_ModularCurve_exists_sl2_heckeDiagMatrix_smul_eq
+end P2MW
+export P2MW.S_ModularCurve_exists_sl2_heckeDiagMatrix_smul_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.exists_sl2_heckeDiagMatrix_smul_eq (N : ℕ) [NeZero N]
+    (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) (hγ : γ ∈ CongruenceSubgroup.Gamma0 N) :
+    ∃ γ' : Matrix.SpecialLinearGroup (Fin 2) ℤ, (∀ τ : UpperHalfPlane, ModularForm.heckeDiagMatrix N
+      • γ • τ = γ' • ModularForm.heckeDiagMatrix N • τ) ∧ ∀ τ : UpperHalfPlane, UpperHalfPlane.denom
+      (γ' : Matrix.GeneralLinearGroup (Fin 2) ℝ) (((ModularForm.heckeDiagMatrix N • τ :
+      UpperHalfPlane)) : ℂ) = UpperHalfPlane.denom (γ : Matrix.GeneralLinearGroup (Fin 2) ℝ) (τ : ℂ)
+      :=
+  solution N γ hγ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_slot_of_isCusp.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_slot_of_isCusp.lean
new file mode 100644
index 0000000000..548470735d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_slot_of_isCusp.lean
@@ -0,0 +1,1218 @@
+/-
+Based on Prove2Me node ModularCurve.exists_slot_of_isCusp
+(bc4f16cb-cceb-5005-904f-f1d835e9d77d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 850a2dd0-ec64-5760-84b9-db4f4e6e48ed
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlace
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_AtkinLehner
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+public import Mathlib.FieldTheory.RatFunc.AsPolynomial
+public import Mathlib.FieldTheory.Relrank
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+public import Mathlib.Tactic.LinearCombination
+public import Mathlib.Data.Int.CardIntervalMod
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CharLFrobeniusGeomLevel
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_hasRamBound
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_inertiaDeg_pos
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_le_finrank
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_subsingleton_setOf_forall_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jqN
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_pos
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqN_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCusp_iff_ord_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_adjoin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_adjoin_pair
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_minpoly_jqN_map_eq_prod_slots
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularFunctionField_eq_full
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_order_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_laurentBaseChange_modularFunctionFieldFull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Every cusp place of X₀(N) arises from a slot
+
+Theorem statement: `ModularCurve.exists_slot_of_isCusp` (`bc4f16cb-cceb-5005-904f-f1d835e9d77d`), by
+Claude, 2026-09-05.
+
+Proof: submission `850a2dd0-ec64-5760-84b9-db4f4e6e48ed`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field containing the rationals, $N$ a nonzero natural number, and $\zeta$ a unit of $K$
+whose underlying element is a primitive $N$th root of unity. Let $F =$ `laurentBaseChange K
+(modularFunctionFieldFull N)`, i.e. the subfield of the Laurent series field $K((q))$ generated over
+$K$ by the coefficientwise images under $\mathrm{alg}_{\mathbb{Q}\to K}$ of the subfield of
+$\mathbb{Q}((q))$ generated by the series $j(q^{d})$ for the nonzero divisors $d$ of $N$, and let
+$w$ be a place of $F$ over $K$ (a valuation subring of $F$ containing $K$, not all of $F$, and a
+principal ideal ring). Assume the element $j(q)$ of $F$ is not in the valuation subring of $w$, i.e.
+$j$ has a pole at $w$. Then there are natural numbers $a, b$ with $a \mid N$, $a \neq 0$, $b < N/a$
+and $\gcd(\gcd(a,b), N/a) = 1$, together with a $K$-algebra homomorphism $\iota : F \to K((q))$ such
+that $\iota(j(q)) = j(q^{N})$, $\iota(j(q^{N}))$ is the series obtained from $j(q)$ by the
+coefficient twist $c_k \mapsto \zeta^{bak} c_k$ followed by substitution $q \mapsto q^{a^{2}}$, and,
+for every $x \in F$, $\operatorname{ord}_w(x) \cdot (a\gcd(a, N/a)) = \operatorname{order}(\iota
+x)$, the order of the Laurent series $\iota x$.
+
+This is the statement that the places of the function field of $X_0(N)$ at which $j$ has a pole are
+exactly the cusps, each obtained from one of the slots $(a,b)$ with $a \mid N$, $b < N/a$ and
+$\gcd(\gcd(a,b),N/a)=1$, the factor $a\gcd(a,N/a)$ being the width of the corresponding cusp. It is
+used in the analysis of the characteristic-$p$ fibre models, in particular in the divisibility
+statements for the order of $j$ at a place lying over a cusp.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_slot_of_isCusp.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option synthInstance.maxHeartbeats 50000 -- was 400k, 50k seems to suffice
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_slot_of_isCusp
+
+noncomputable section
+
+open ModularCurve AlgebraicCurve
+
+namespace Row1
+
+open ModularCurve AlgebraicCurve Polynomial IntermediateField
+
+namespace CD
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+theorem qExpand_coeffEmb (N : ℕ) [NeZero N] (f : LaurentSeries ℚ) :
+    qExpand K N (coeffEmb K f) = coeffEmb K (qExpand ℚ N f) := by
+  ext k
+  by_cases hk : (N : ℤ) ∣ k
+  · obtain ⟨m, rfl⟩ := hk
+    rw [qExpand_coeff_mul, coeffEmb_coeff, coeffEmb_coeff, qExpand_coeff_mul]
+  · rw [qExpand_coeff_of_not_dvd N _ hk, coeffEmb_coeff, qExpand_coeff_of_not_dvd N _ hk,
+      map_zero]
+
+theorem laurentBaseChange_full_eq_adjoin_adjoin (N : ℕ) [NeZero N] :
+    laurentBaseChange K (modularFunctionFieldFull N) =
+      (K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯).restrictScalars K := by
+  rw [laurentBaseChange_adjoin_pair K N (functionFieldGeneration N), ← coeffEmb_jq,
+    ← coeffEmb_jqN]
+  exact (adjoin_simple_adjoin_simple K (coeffEmb K jq) (coeffEmb K (jqN N))).symm
+
+theorem finrank_adjoin_adjoin (N : ℕ) [NeZero N] :
+    Module.finrank K⟮coeffEmb K jq⟯ K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯ = dedekindPsi N := by
+  have hle : K⟮coeffEmb K jq⟯ ≤ laurentBaseChange K (modularFunctionFieldFull N) :=
+    adjoin_simple_le_iff.mpr (coeffEmb_mem_laurentBaseChange K (jq_mem_full N))
+  have h := relfinrank_laurentBaseChange_modularFunctionFieldFull K N
+  rw [relfinrank_full_eq_dedekindPsi, relfinrank_eq_finrank_of_le hle] at h
+  have hext : extendScalars hle = K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯ :=
+    restrictScalars_injective K
+      ((extendScalars_restrictScalars hle).trans (laurentBaseChange_full_eq_adjoin_adjoin K N))
+  rwa [hext] at h
+
+theorem isIntegral_jqN (N : ℕ) [NeZero N] :
+    IsIntegral (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN N) := by
+  have : Module.Free ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN N⟯ := .of_divisionRing _ _
+  have hfin : FiniteDimensional (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+        ({jqN N} : Set (LaurentSeries ℚ))) :=
+    Module.finite_of_finrank_pos (by
+        rw [finrank_adjoin_jqN_eq_dedekindPsi];
+        exact dedekindPsi_pos N (NeZero.ne N))
+  have h := IsIntegral.of_finite (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+    (AdjoinSimple.gen (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN N))
+  rwa [isIntegral_iff, AdjoinSimple.coe_gen] at h
+
+theorem natDegree_minpoly_jqN (N : ℕ) [NeZero N] :
+    (minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN N)).natDegree =
+      dedekindPsi N := by
+  rw [← adjoin.finrank (isIntegral_jqN N), finrank_adjoin_jqN_eq_dedekindPsi]
+
+noncomputable def thetaE :
+    (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) →+* K⟮coeffEmb K jq⟯ :=
+  ((coeffEmb K).comp
+      (algebraMap (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+        (LaurentSeries ℚ))).codRestrict K⟮coeffEmb K jq⟯ fun y => by
+    have h := coeffEmb_mem_laurentBaseChange K y.2
+    rwa [laurentBaseChange_adjoin, Set.image_singleton] at h
+
+theorem minpoly_coeffEmb_jqN (N : ℕ) [NeZero N] :
+    IsIntegral K⟮coeffEmb K jq⟯ (coeffEmb K (jqN N)) ∧
+    minpoly K⟮coeffEmb K jq⟯ (coeffEmb K (jqN N)) =
+      (minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN N)).map
+        (thetaE K) := by
+  have hpm : (minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN N)).Monic :=
+    minpoly.monic (isIntegral_jqN N)
+  have heval : aeval (coeffEmb K (jqN N))
+      ((minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN N)).map
+        (thetaE K)) = 0 := by
+    rw [aeval_def, eval₂_map,
+      show (algebraMap K⟮coeffEmb K jq⟯ (LaurentSeries K)).comp (thetaE K) =
+          (coeffEmb K).comp
+            (algebraMap (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+              (LaurentSeries ℚ)) from RingHom.ext fun _ => rfl,
+      ← hom_eval₂, ← aeval_def, minpoly.aeval, map_zero]
+  have hint : IsIntegral K⟮coeffEmb K jq⟯ (coeffEmb K (jqN N)) :=
+    ⟨_, hpm.map _, by rwa [← aeval_def]⟩
+  refine ⟨hint, (eq_of_monic_of_dvd_of_natDegree_le (minpoly.monic hint) (hpm.map _)
+    (minpoly.dvd _ _ heval) (le_of_eq ?_)).symm⟩
+  rw [hpm.natDegree_map, natDegree_minpoly_jqN, ← adjoin.finrank hint, finrank_adjoin_adjoin]
+
+theorem eval₂_minpoly_slot (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (a b : ℕ) (ha : a ∣ N) (hb : b < N / a) (hg : Nat.gcd (Nat.gcd a b) (N / a) = 1) [NeZero a] :
+    (minpoly K⟮coeffEmb K jq⟯ (coeffEmb K (jqN N))).eval₂
+        ((qExpand K N).comp (algebraMap K⟮coeffEmb K jq⟯ (LaurentSeries K)))
+        (qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq))) = 0 := by
+  rw [(minpoly_coeffEmb_jqN K N).2, eval₂_map,
+    show ((qExpand K N).comp (algebraMap K⟮coeffEmb K jq⟯ (LaurentSeries K))).comp (thetaE K) =
+        ((coeffEmb K).comp (qExpand ℚ N)).comp
+          (algebraMap (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+            (LaurentSeries ℚ)) from RingHom.ext fun y => by
+      change qExpand K N (coeffEmb K (y : LaurentSeries ℚ)) =
+        coeffEmb K (qExpand ℚ N (y : LaurentSeries ℚ))
+      exact qExpand_coeffEmb K N _,
+    ← eval_map,
+    minpoly_jqN_map_eq_prod_slots N ζ hζ
+      (fun d _ _ => ⟨finrank_adjoin_jqN_eq_dedekindPsi d, modularFunctionField_eq_full d⟩),
+    eval_prod]
+  refine Finset.prod_eq_zero (Nat.mem_divisors.mpr ⟨ha, NeZero.ne N⟩) ?_
+  rw [eval_prod]
+  refine Finset.prod_eq_zero (Finset.mem_filter.mpr ⟨Finset.mem_range.mpr hb, hg⟩) ?_
+  simp only [eval_sub, eval_X, eval_C, dite_eq_right (NeZero.ne a), sub_self]
+
+private theorem cd1_slotEmbedding (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (a b : ℕ) (ha : a ∣ N) (hb : b < N / a) (hg : Nat.gcd (Nat.gcd a b) (N / a) = 1) [NeZero a] :
+    ∃ ι : laurentBaseChange K (modularFunctionFieldFull N) →ₐ[K] LaurentSeries K,
+      ι ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+          qExpand K N (coeffEmb K jq) ∧
+      ι ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩ =
+          qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)) := by
+  obtain ⟨hint, -⟩ := minpoly_coeffEmb_jqN K N
+  let L := AdjoinRoot.lift ((qExpand K N).comp (algebraMap K⟮coeffEmb K jq⟯ (LaurentSeries K)))
+    (qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)))
+    (eval₂_minpoly_slot K N ζ hζ a b ha hb hg)
+  let e := adjoinRootEquivAdjoin K⟮coeffEmb K jq⟯ hint
+  let φ : K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯ →+* LaurentSeries K :=
+    L.comp (e.symm : K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯ →+*
+      AdjoinRoot (minpoly K⟮coeffEmb K jq⟯ (coeffEmb K (jqN N))))
+  have hφalg : ∀ x : K⟮coeffEmb K jq⟯,
+      φ (algebraMap K⟮coeffEmb K jq⟯ K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯ x) =
+        qExpand K N x := fun x => by
+    change L (e.symm (algebraMap _ _ x)) = _
+    rw [AlgEquiv.commutes, AdjoinRoot.algebraMap_eq, AdjoinRoot.lift_of]
+    rfl
+  have hφgen : φ (AdjoinSimple.gen K⟮coeffEmb K jq⟯ (coeffEmb K (jqN N))) =
+      qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)) := by
+    change L (e.symm (AdjoinSimple.gen _ _)) = _
+    rw [adjoinRootEquivAdjoin_symm_apply_gen, AdjoinRoot.lift_root]
+  have hF := laurentBaseChange_full_eq_adjoin_adjoin K N
+  let ι' : (K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯).restrictScalars K →ₐ[K] LaurentSeries K :=
+    { toRingHom := φ
+      commutes' := fun c => by
+        change φ (algebraMap K⟮coeffEmb K jq⟯ K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯
+          (algebraMap K K⟮coeffEmb K jq⟯ c)) = _
+        rw [hφalg]
+        change qExpand K N (algebraMap K (LaurentSeries K) c) = algebraMap K (LaurentSeries K) c
+        rw [algebraMap_laurentSeries_eq_single, qExpand_single, mul_zero] }
+  refine ⟨ι'.comp (inclusion hF.le), ?_, ?_⟩
+  · exact hφalg ⟨coeffEmb K jq, mem_adjoin_simple_self K _⟩
+  · exact hφgen
+
+end CD
+
+end Row1
+
+namespace Row2
+
+section
+
+open ModularCurve AlgebraicCurve
+
+namespace CD
+
+section Transport
+
+variable {K : Type*} [Field K]
+
+theorem hasRamBound_puiseuxRamEmb {e : ℕ} (he : 0 < e) (x : LaurentSeries K) :
+    HahnSeries.HasRamBound e (HahnSeries.puiseuxRamEmb he x) := by
+  intro q hq
+  have hq' : q ∈ ⇑(HahnSeries.ramScale e) '' x.support := by
+    simpa [HahnSeries.puiseuxRamEmb, HahnSeries.embDomainRingHom] using
+      HahnSeries.support_embDomain_subset hq
+  obtain ⟨k, -, rfl⟩ := hq'
+  exact ⟨k, rfl⟩
+
+theorem order_puiseuxRamEmb {e : ℕ} (he : 0 < e) (x : LaurentSeries K) :
+    (HahnSeries.puiseuxRamEmb he x).order = HahnSeries.ramScale e x.order := by
+  rcases eq_or_ne x 0 with rfl | hx
+  · simp
+  · have hx' : HahnSeries.puiseuxRamEmb (K := K) he x ≠ 0 := by
+      intro h0
+      exact hx ((HahnSeries.puiseuxRamEmb (K := K) he).injective (by rw [h0, map_zero]))
+    have h2 : (HahnSeries.puiseuxRamEmb (K := K) he x).orderTop
+        = WithTop.map (⇑(HahnSeries.ramScale e)) x.orderTop :=
+      HahnSeries.orderTop_embDomain
+    have h1 := HahnSeries.order_eq_orderTop_of_ne_zero hx'
+    rw [h2, ← HahnSeries.order_eq_orderTop_of_ne_zero hx, WithTop.map_coe] at h1
+    exact_mod_cast h1
+
+theorem laurentAlgebraMap_eq_C (c : K) :
+    algebraMap K (LaurentSeries K) c = HahnSeries.C c := by
+  rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_apply]
+  simp [HahnSeries.ofPowerSeries_C]
+
+theorem hahnQAlgebraMap_eq_C (c : K) :
+    algebraMap K (HahnSeries ℚ K) c = HahnSeries.C c := by
+  rw [HahnSeries.algebraMap_apply']
+  simp [HahnSeries.ofPowerSeries_C]
+
+end Transport
+
+section Lift
+
+variable {K : Type*} [Field K] {F : Type*} [Field F] [Algebra K F]
+
+def liftToHahn (ι : F →ₐ[K] LaurentSeries K) : F →ₐ[K] HahnSeries ℚ K where
+  toRingHom := (HahnSeries.puiseuxRamEmb one_pos).comp ι.toRingHom
+  commutes' := by
+    intro c
+    change HahnSeries.puiseuxRamEmb one_pos (ι (algebraMap K F c))
+        = algebraMap K (HahnSeries ℚ K) c
+    rw [ι.commutes c, laurentAlgebraMap_eq_C, hahnQAlgebraMap_eq_C]
+    exact HahnSeries.embDomainRingHom_C
+
+@[scoped simp] theorem liftToHahn_apply (ι : F →ₐ[K] LaurentSeries K) (x : F) :
+    liftToHahn ι x = HahnSeries.puiseuxRamEmb one_pos (ι x) := rfl
+
+theorem order_liftToHahn (ι : F →ₐ[K] LaurentSeries K) (x : F) :
+    (liftToHahn ι x).order = ((ι x).order : ℚ) := by
+  rw [liftToHahn_apply, order_puiseuxRamEmb one_pos, HahnSeries.ramScale_apply]
+  simp
+
+end Lift
+
+section Generic
+
+variable (K : Type*) [Field K]
+
+private theorem cd2_laurentRF2 {F : Type*} [Field F] [Algebra K F] (ι : F →ₐ[K] LaurentSeries K)
+    (h : ∃ x : F, (ι x).order ≠ 0) :
+    ∃ (w : Place K F) (γ : ℕ), 0 < γ ∧ ∀ x : F, w.ord x * (γ : ℤ) = (ι x).order := by
+  obtain ⟨x₀, hx₀⟩ := h
+  have hnt : ∃ x : F, ((liftToHahn ι) x).order ≠ 0 :=
+    ⟨x₀, by rw [order_liftToHahn]; exact_mod_cast hx₀⟩
+  have hRB : ∀ x : F, HahnSeries.HasRamBound 1 ((liftToHahn ι) x) :=
+    fun x => hasRamBound_puiseuxRamEmb one_pos (ι x)
+  obtain ⟨w, g, hg, hgw⟩ :=
+    Place.exists_ord_mul_eq_order_of_hasRamBound (liftToHahn ι) one_pos hRB hnt
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  have hordπ : w.ord (π : F) = 1 := w.ord_coe_irreducible hπ
+  have hgval : g = ((ι (π : F)).order : ℚ) := by
+    have h1 := hgw (π : F)
+    rw [hordπ, order_liftToHahn] at h1
+    simpa using h1
+  have hpos : 0 < (ι (π : F)).order := by
+    rw [hgval] at hg
+    exact_mod_cast hg
+  refine ⟨w, ((ι (π : F)).order).toNat, by omega, fun x => ?_⟩
+  have h1 := hgw x
+  rw [hgval, order_liftToHahn] at h1
+  have h2 : w.ord x * (ι (π : F)).order = (ι x).order := by exact_mod_cast h1
+  rw [Int.toNat_of_nonneg hpos.le]
+  exact h2
+
+end Generic
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+theorem cd2_control (N : ℕ) [NeZero N] :
+    ∃ w : Place K (laurentBaseChange K (modularFunctionFieldFull N)),
+      ∀ x, w.ord x = (x : LaurentSeries K).order := by
+  have hmem := coeffEmb_mem_laurentBaseChange K (jq_mem_full N)
+  have hjq : ((laurentBaseChange K (modularFunctionFieldFull N)).val
+      ⟨coeffEmb K jq, hmem⟩).order = -1 := order_coeffEmb_jq K
+  obtain ⟨w, γ, hγ, hw⟩ := cd2_laurentRF2 K
+    (laurentBaseChange K (modularFunctionFieldFull N)).val
+    ⟨⟨coeffEmb K jq, hmem⟩, by rw [hjq]; norm_num⟩
+  have h1 : w.ord ⟨coeffEmb K jq, hmem⟩ * (γ : ℤ) = -1 := by
+    rw [hw ⟨coeffEmb K jq, hmem⟩, hjq]
+  have hdvd : (γ : ℤ) ∣ 1 :=
+    ⟨-(w.ord ⟨coeffEmb K jq, hmem⟩), by rw [mul_neg, mul_comm, h1]; norm_num⟩
+  have hle : (γ : ℤ) ≤ 1 := Int.le_of_dvd one_pos hdvd
+  have hγ1 : γ = 1 := by omega
+  refine ⟨w, fun x => ?_⟩
+  have h2 := hw x
+  rw [hγ1] at h2
+  simpa using h2
+
+end CD
+end
+end Row2
+
+namespace Row3
+
+open ModularCurve AlgebraicCurve
+
+namespace CD
+
+section Helper
+
+variable {K : Type*} [Field K]
+
+theorem order_qTwist (u : Kˣ) (f : LaurentSeries K) : (qTwist u f).order = f.order := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · rw [map_zero]
+  · have hne : qTwist u f ≠ 0 := fun h =>
+      hf (qTwist_injective u (by rw [h, map_zero]))
+    refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero ?_)
+      (HahnSeries.order_le_of_coeff_ne_zero ?_)
+    · rw [qTwist_coeff]
+      exact mul_ne_zero (Units.ne_zero _) (HahnSeries.coeff_order_eq_zero.not.mpr hf)
+    · have := HahnSeries.coeff_order_eq_zero.not.mpr hne
+      rw [qTwist_coeff] at this
+      exact right_ne_zero_of_mul this
+
+noncomputable def qExpandAlgK (M : ℕ) [NeZero M] : LaurentSeries K →ₐ[K] LaurentSeries K where
+  __ := qExpand K M
+  commutes' r := by
+    change qExpand K M (algebraMap K (LaurentSeries K) r) = algebraMap K (LaurentSeries K) r
+    rw [algebraMap_laurentSeries_eq_single, qExpand_single, mul_zero]
+
+@[scoped simp]
+theorem qExpandAlgK_apply (M : ℕ) [NeZero M] (f : LaurentSeries K) :
+    qExpandAlgK M f = qExpand K M f := rfl
+
+theorem qExpand_mem_range_of_dvd (M P : ℕ) [NeZero M] [NeZero P] (h : M ∣ P)
+    (f : LaurentSeries K) :
+    qExpand K P f ∈ (qExpandAlgK (K := K) M).fieldRange := by
+  have : NeZero (P / M) :=
+    ⟨Nat.div_ne_zero_iff.mpr ⟨NeZero.ne M, Nat.le_of_dvd (Nat.pos_of_ne_zero (NeZero.ne P)) h⟩⟩
+  refine ⟨qExpand K (P / M) f, ?_⟩
+  change qExpand K M (qExpand K (P / M) f) = qExpand K P f
+  rw [qExpand_qExpand]
+  exact qExpand_congr (Nat.mul_div_cancel' h) f
+
+end Helper
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+private theorem cd3_slotWidth (N : ℕ) [NeZero N] (ζ : Kˣ) (a b : ℕ) (ha : a ∣ N) [NeZero a]
+    (ι : laurentBaseChange K (modularFunctionFieldFull N) →ₐ[K] LaurentSeries K)
+    (hι₁ : ι ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+        qExpand K N (coeffEmb K jq))
+    (hι₂ : ι ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩ =
+        qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)))
+    (w : Place K (laurentBaseChange K (modularFunctionFieldFull N))) (γ : ℤ) (hγ : 0 < γ)
+    (hw : ∀ x, w.ord x * γ = (ι x).order) :
+    γ = a * Nat.gcd a (N / a) ∧
+    w.ord ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+        -((N / a / Nat.gcd a (N / a) : ℕ) : ℤ) ∧
+    w.ord ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩ =
+        -((a / Nat.gcd a (N / a) : ℕ) : ℤ) := by
+  let F := laurentBaseChange K (modularFunctionFieldFull N)
+  let jbar : F := ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩
+  let jbarN : F :=
+    ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩
+  let g := Nat.gcd a (N / a)
+  have ha0 : a ≠ 0 := NeZero.ne a
+  have hg0 : g ≠ 0 := Nat.gcd_ne_zero_left ha0
+  have hag0 : NeZero (a * g) := ⟨Nat.mul_ne_zero ha0 hg0⟩
+  have hag_dvd_N : a * g ∣ N := by
+    calc a * g ∣ a * (N / a) := Nat.mul_dvd_mul_left a (Nat.gcd_dvd_right _ _)
+      _ = N := Nat.mul_div_cancel' ha
+  have hag_dvd_aa : a * g ∣ a * a := Nat.mul_dvd_mul_left a (Nat.gcd_dvd_left _ _)
+  have : NeZero (a * a) := ⟨Nat.mul_ne_zero ha0 ha0⟩
+  have hord1 : (ι jbar).order = -(N : ℤ) := by
+    rw [show ι jbar = qExpand K N (coeffEmb K jq) from hι₁, order_qExpand, order_coeffEmb_jq,
+      mul_neg_one]
+  have hord2 : (ι jbarN).order = -((a * a : ℕ) : ℤ) := by
+    rw [show ι jbarN = _ from hι₂, order_qExpand, order_qTwist, order_coeffEmb_jq,
+      mul_neg_one]
+  have hw1 : w.ord jbar * γ = -(N : ℤ) := (hw jbar).trans hord1
+  have hw2 : w.ord jbarN * γ = -((a * a : ℕ) : ℤ) := (hw jbarN).trans hord2
+  have hγdvd : γ ∣ ((a * g : ℕ) : ℤ) := by
+    have hN : γ ∣ (N : ℤ) := ⟨-(w.ord jbar), by rw [mul_neg, mul_comm γ, hw1, neg_neg]⟩
+    have haa : γ ∣ ((a * a : ℕ) : ℤ) :=
+      ⟨-(w.ord jbarN), by rw [mul_neg, mul_comm γ, hw2, neg_neg]⟩
+    have key : Nat.gcd N (a * a) = a * g := by
+      conv_lhs => rw [← Nat.mul_div_cancel' ha]
+      rw [Nat.gcd_mul_left, Nat.gcd_comm]
+    rw [← key, Nat.gcd_eq_gcd_ab]
+    exact dvd_add (Dvd.dvd.mul_right hN _) (Dvd.dvd.mul_right haa _)
+  have hrange : ∀ x : F, ι x ∈ (qExpandAlgK (K := K) (a * g)).fieldRange := by
+    have hadj := laurentBaseChange_adjoin_pair K N (functionFieldGeneration N)
+    have htop : IntermediateField.adjoin K ({jbar, jbarN} : Set F) = ⊤ := by
+      apply IntermediateField.map_injective F.val
+      calc (IntermediateField.adjoin K ({jbar, jbarN} : Set F)).map F.val
+          = IntermediateField.adjoin K (F.val '' {jbar, jbarN}) :=
+            IntermediateField.adjoin_map K _ F.val
+        _ = IntermediateField.adjoin K ({jqModC K, jqNModC K N} : Set (LaurentSeries K)) := by
+            congr 1
+            rw [Set.image_insert_eq, Set.image_singleton]
+            change ({coeffEmb K jq, coeffEmb K (jqN N)} : Set (LaurentSeries K)) = _
+            rw [coeffEmb_jq K, coeffEmb_jqN K N]
+        _ = F := hadj.symm
+        _ = (⊤ : IntermediateField K F).map F.val :=
+            (IntermediateField.fieldRange_val (S := F)).symm.trans
+              (AlgHom.fieldRange_eq_map F.val)
+    intro x
+    have hxmem : x ∈ IntermediateField.adjoin K ({jbar, jbarN} : Set F) :=
+      htop ▸ IntermediateField.mem_top
+    induction hxmem using IntermediateField.adjoin_induction with
+    | mem y hy =>
+      simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hy
+      rcases hy with rfl | rfl
+      · exact hι₁ ▸ qExpand_mem_range_of_dvd (a * g) N hag_dvd_N (coeffEmb K jq)
+      · exact hι₂ ▸ qExpand_mem_range_of_dvd (a * g) (a * a) hag_dvd_aa
+          (qTwist (ζ ^ (b * a)) (coeffEmb K jq))
+    | algebraMap c =>
+      rw [AlgHom.commutes]
+      exact IntermediateField.algebraMap_mem _ c
+    | add y z _ _ ihy ihz => rw [map_add]; exact add_mem ihy ihz
+    | inv y _ ih => rw [map_inv₀]; exact inv_mem ih
+    | mul y z _ _ ihy ihz => rw [map_mul]; exact mul_mem ihy ihz
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  obtain ⟨f, hfπ⟩ := hrange (π : F)
+  have hγeq : γ = (ι (π : F)).order := by
+    have := hw (π : F)
+    rw [w.ord_coe_irreducible hπ, one_mul] at this
+    exact this
+  have hagdvdγ : ((a * g : ℕ) : ℤ) ∣ γ := by
+    rw [hγeq, ← hfπ]
+    change ((a * g : ℕ) : ℤ) ∣ (qExpandAlgK (a * g) f).order
+    rw [qExpandAlgK_apply, order_qExpand]
+    exact Dvd.intro _ rfl
+  have hagpos : 0 < ((a * g : ℕ) : ℤ) := by
+    exact_mod_cast Nat.pos_of_ne_zero hag0.out
+  have hγval : γ = ((a * g : ℕ) : ℤ) :=
+    Int.dvd_antisymm (le_of_lt hγ) (le_of_lt hagpos) hγdvd hagdvdγ
+  refine ⟨by rw [hγval]; push_cast; ring, ?_, ?_⟩
+  · have hdiv : (N / a / g) * (a * g) = N := by
+      rw [Nat.div_div_eq_div_mul, Nat.div_mul_cancel hag_dvd_N]
+    have key : (-((N / a / g : ℕ) : ℤ)) * ((a * g : ℕ) : ℤ) = -(N : ℤ) := by
+      rw [neg_mul, ← Nat.cast_mul, hdiv]
+    exact mul_right_cancel₀ (ne_of_gt hagpos) ((hγval ▸ hw1).trans key.symm)
+  · have hdiv : (a / g) * (a * g) = a * a := by
+      rw [mul_comm a g, ← mul_assoc, Nat.div_mul_cancel (Nat.gcd_dvd_left a (N / a))]
+    have key : (-((a / g : ℕ) : ℤ)) * ((a * g : ℕ) : ℤ) = -((a * a : ℕ) : ℤ) := by
+      rw [neg_mul, ← Nat.cast_mul, hdiv]
+    exact mul_right_cancel₀ (ne_of_gt hagpos) ((hγval ▸ hw2).trans key.symm)
+
+end CD
+end Row3
+
+namespace Row4
+
+open ModularCurve AlgebraicCurve Polynomial IntermediateField
+
+namespace CD
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+theorem order_eq_of_coeff {x : LaurentSeries K} {m : ℤ} (h1 : x.coeff m ≠ 0)
+    (h2 : ∀ i < m, x.coeff i = 0) : x.order = m := by
+  have _ := ‹Algebra ℚ K›
+  have hx : x ≠ 0 := fun h => h1 (by rw [h, HahnSeries.coeff_zero])
+  refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero h1) ?_
+  by_contra! h
+  exact hx (HahnSeries.coeff_order_eq_zero.mp (h2 _ h))
+
+theorem order_qTwist (v : Kˣ) (f : LaurentSeries K) : (qTwist v f).order = f.order := by
+  have _ := ‹Algebra ℚ K›
+  rcases eq_or_ne f 0 with rfl | hf
+  · rw [map_zero]
+  have h1 : ∀ (u : Kˣ) (g : LaurentSeries K), g ≠ 0 → (qTwist u g).order ≤ g.order :=
+    fun u g hg => HahnSeries.order_le_of_coeff_ne_zero (by
+      rw [qTwist_coeff]
+      exact mul_ne_zero (Units.ne_zero _) (mt HahnSeries.coeff_order_eq_zero.mp hg))
+  refine le_antisymm (h1 v f hf) ?_
+  have h2 := h1 v⁻¹ (qTwist v f) ((map_ne_zero_iff _ (qTwist_injective v)).mpr hf)
+  rwa [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply] at h2
+
+theorem coeff_algebraMap_mul (c : K) (y : LaurentSeries K) (i : ℤ) :
+    (algebraMap K (LaurentSeries K) c * y).coeff i = c * y.coeff i := by
+  have _ := ‹Algebra ℚ K›
+  rw [algebraMap_laurentSeries_eq_single, HahnSeries.single_zero_mul_eq_smul, HahnSeries.coeff_smul,
+    smul_eq_mul]
+
+theorem coeff_slot_pow (v : Kˣ) (A : ℕ) [NeZero A] (n : ℕ) :
+    ((qExpand K A (qTwist v (coeffEmb K jq))) ^ n).coeff (-((A * n : ℕ) : ℤ)) =
+        ((v ^ (-(n : ℤ)) : Kˣ) : K) ∧
+      ∀ i < -((A * n : ℕ) : ℤ), ((qExpand K A (qTwist v (coeffEmb K jq))) ^ n).coeff i = 0 := by
+  rw [← map_pow, ← map_pow, ← map_pow]
+  constructor
+  · rw [show -((A * n : ℕ) : ℤ) = (A : ℤ) * (-(n : ℤ)) by push_cast; ring, qExpand_coeff_mul,
+      qTwist_coeff, coeffEmb_coeff, coeff_jq_pow_self, map_one, mul_one]
+  · intro i hi
+    by_cases hdvd : (A : ℤ) ∣ i
+    · obtain ⟨m, rfl⟩ := hdvd
+      have hA : (0 : ℤ) < A := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne A)
+      have hm : m < -(n : ℤ) := by
+        refine lt_of_mul_lt_mul_left ?_ hA.le
+        rw [mul_neg]
+        exact_mod_cast hi
+      rw [qExpand_coeff_mul, qTwist_coeff, coeffEmb_coeff, coeff_jq_pow_of_lt hm, map_zero,
+        mul_zero]
+    · exact qExpand_coeff_of_not_dvd A _ hdvd
+
+theorem coeff_qExpand_jq_pow (A : ℕ) [NeZero A] (n : ℕ) :
+    ((qExpand K A (coeffEmb K jq)) ^ n).coeff (-((A * n : ℕ) : ℤ)) = 1 ∧
+      ∀ i < -((A * n : ℕ) : ℤ), ((qExpand K A (coeffEmb K jq)) ^ n).coeff i = 0 := by
+  simpa [qTwist_one_apply] using coeff_slot_pow K 1 A n
+
+theorem order_slot (v : Kˣ) (A : ℕ) [NeZero A] :
+    (qExpand K A (qTwist v (coeffEmb K jq))).order = -(A : ℤ) := by
+  obtain ⟨h1, h2⟩ := coeff_slot_pow K v A 1
+  rw [pow_one, mul_one] at h1 h2
+  exact order_eq_of_coeff K (by rw [h1]; exact Units.ne_zero _) h2
+
+theorem order_qExpand_jq (A : ℕ) [NeZero A] :
+    (qExpand K A (coeffEmb K jq)).order = -(A : ℤ) := by
+  obtain ⟨h1, h2⟩ := coeff_qExpand_jq_pow K A 1
+  rw [pow_one, mul_one] at h1 h2
+  exact order_eq_of_coeff K (by rw [h1]; exact one_ne_zero) h2
+
+private theorem cd4_slotOrbit (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (a b : ℕ) (ha : a ∣ N) [NeZero a] (a' b' : ℕ) (ha' : a' ∣ N) [NeZero a']
+    (ι ι' : laurentBaseChange K (modularFunctionFieldFull N) →ₐ[K] LaurentSeries K)
+    (hι₁ : ι ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+        qExpand K N (coeffEmb K jq))
+    (hι₂ : ι ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩ =
+        qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)))
+    (hι'₁ : ι' ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+        qExpand K N (coeffEmb K jq))
+    (hι'₂ : ι' ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩
+      =
+        qExpand K (a' * a') (qTwist (ζ ^ (b' * a')) (coeffEmb K jq)))
+    (w w' : Place K (laurentBaseChange K (modularFunctionFieldFull N))) (γ γ' : ℤ)
+    (hγ : 0 < γ) (hγ' : 0 < γ')
+    (hw : ∀ x, w.ord x * γ = (ι x).order) (hw' : ∀ x, w'.ord x * γ' = (ι' x).order) :
+    w = w' ↔ a = a' ∧ b ≡ b' [MOD Nat.gcd a (N / a)] := by
+  have _ := ha'
+  obtain ⟨d, rfl⟩ := ha
+  have ha0 : 0 < a := Nat.pos_of_ne_zero (NeZero.ne a)
+  have had : a * d / a = d := Nat.mul_div_cancel_left d ha0
+  rw [had]
+  have hζu : IsPrimitiveRoot ζ (a * d) := IsPrimitiveRoot.coe_units_iff.mp hζ
+  set jb : laurentBaseChange K (modularFunctionFieldFull (a * d)) :=
+    ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full (a * d))⟩ with hjb
+  set jbN : laurentBaseChange K (modularFunctionFieldFull (a * d)) :=
+    ⟨coeffEmb K (jqN (a * d)),
+      coeffEmb_mem_laurentBaseChange K (jqd_mem_full (a * d) (dvd_refl (a * d)))⟩ with hjbN
+  constructor
+  · intro hww
+    subst hww
+    have h1 := hw jb
+    have h1' := hw' jb
+    rw [hι₁, order_qExpand_jq] at h1
+    rw [hι'₁, order_qExpand_jq] at h1'
+    have hne : w.ord jb ≠ 0 := by
+      intro h0
+      rw [h0, zero_mul] at h1
+      exact NeZero.ne (a * d) (by exact_mod_cast (neg_eq_zero.mp h1.symm))
+    obtain rfl : γ = γ' := mul_left_cancel₀ hne (h1.trans h1'.symm)
+    have h2 := hw jbN
+    have h2' := hw' jbN
+    rw [hι₂, order_slot] at h2
+    rw [hι'₂, order_slot] at h2'
+    have haa : a * a = a' * a' := by exact_mod_cast neg_injective (h2.symm.trans h2')
+    obtain rfl : a = a' := Nat.mul_self_inj.mp haa
+    refine ⟨rfl, ?_⟩
+    obtain ⟨m, hm⟩ := Nat.gcd_dvd_left a d
+    obtain ⟨n, hn⟩ := Nat.gcd_dvd_right a d
+    set g := Nat.gcd a d with hg
+    have hd0 : 0 < d := Nat.pos_of_ne_zero fun h => NeZero.ne (a * d) (by rw [h, mul_zero])
+    have hn0 : 0 < n := Nat.pos_of_ne_zero fun h => hd0.ne' (by rw [hn, h, mul_zero])
+    have key : a * a * n = a * d * m := by
+      calc a * a * n = a * (g * m) * n := by rw [← hm]
+        _ = a * (g * n) * m := by ring
+        _ = a * d * m := by rw [← hn]
+    set c : K := (((ζ ^ (b * a)) ^ (-(n : ℤ)) : Kˣ) : K) with hc
+    set x₀ : laurentBaseChange K (modularFunctionFieldFull (a * d)) :=
+      jbN ^ n - algebraMap K _ c * jb ^ m with hx₀
+    have hιx : ι x₀ = (qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq))) ^ n -
+        algebraMap K (LaurentSeries K) c * (qExpand K (a * d) (coeffEmb K jq)) ^ m := by
+      rw [hx₀, map_sub, map_mul, map_pow, map_pow, AlgHom.commutes, hι₁, hι₂]
+    have hι'x : ι' x₀ = (qExpand K (a * a) (qTwist (ζ ^ (b' * a)) (coeffEmb K jq))) ^ n -
+        algebraMap K (LaurentSeries K) c * (qExpand K (a * d) (coeffEmb K jq)) ^ m := by
+      rw [hx₀, map_sub, map_mul, map_pow, map_pow, AlgHom.commutes, hι'₁, hι'₂]
+    obtain ⟨hS1, -⟩ := coeff_slot_pow K (ζ ^ (b * a)) (a * a) n
+    obtain ⟨hS1', hS2'⟩ := coeff_slot_pow K (ζ ^ (b' * a)) (a * a) n
+    obtain ⟨hE1, hE2⟩ := coeff_qExpand_jq_pow K (a * d) m
+    rw [← key] at hE1 hE2
+    have hcoeffι : (ι x₀).coeff (-((a * a * n : ℕ) : ℤ)) = 0 := by
+      rw [hιx, HahnSeries.coeff_sub, hS1, coeff_algebraMap_mul, hE1, mul_one, sub_self]
+    have hbelow' : ∀ i < -((a * a * n : ℕ) : ℤ), (ι' x₀).coeff i = 0 := fun i hi => by
+      rw [hι'x, HahnSeries.coeff_sub, hS2' i hi, coeff_algebraMap_mul, hE2 i hi, mul_zero, sub_zero]
+    have hcoeffι' : (ι' x₀).coeff (-((a * a * n : ℕ) : ℤ)) =
+        (((ζ ^ (b' * a)) ^ (-(n : ℤ)) : Kˣ) : K) - c := by
+      rw [hι'x, HahnSeries.coeff_sub, hS1', coeff_algebraMap_mul, hE1, mul_one]
+    have hordx : (ι' x₀).order = (ι x₀).order := (hw' x₀).symm.trans (hw x₀)
+    have hM0 : (0 : ℤ) < ((a * a * n : ℕ) : ℤ) := by
+      exact_mod_cast Nat.mul_pos (Nat.mul_pos ha0 ha0) hn0
+    have hvan : (ι' x₀).coeff (-((a * a * n : ℕ) : ℤ)) = 0 := by
+      by_cases hz : ι' x₀ = 0
+      · rw [hz, HahnSeries.coeff_zero]
+      refine HahnSeries.coeff_eq_zero_of_lt_order (lt_of_le_of_ne ?_ ?_)
+      · by_contra! hlt
+        exact hz (HahnSeries.coeff_order_eq_zero.mp (hbelow' _ hlt))
+      · intro heq
+        rw [hordx] at heq
+        by_cases hz0 : ι x₀ = 0
+        · rw [hz0, HahnSeries.order_zero] at heq
+          exact hM0.ne' (neg_eq_zero.mp heq)
+        · refine hz0 (HahnSeries.coeff_order_eq_zero.mp ?_)
+          rw [← heq]
+          exact hcoeffι
+    rw [hcoeffι', sub_eq_zero, hc] at hvan
+    have hu : (ζ ^ (b' * a)) ^ (-(n : ℤ)) = (ζ ^ (b * a)) ^ (-(n : ℤ)) := Units.ext hvan
+    rw [zpow_neg, zpow_neg, inv_inj, zpow_natCast, zpow_natCast, ← pow_mul, ← pow_mul,
+      pow_eq_pow_iff_modEq, ← hζu.eq_orderOf, show a * d = g * (a * n) by rw [hn]; ring,
+      mul_assoc, mul_assoc] at hu
+    exact (Nat.ModEq.mul_right_cancel' (Nat.mul_pos ha0 hn0).ne' hu).symm
+  · rintro ⟨rfl, hbb⟩
+    obtain ⟨q, hq⟩ := Nat.modEq_iff_dvd.mp hbb
+    have hbez := Nat.gcd_eq_gcd_ab a d
+    obtain ⟨k, hk⟩ : ∃ k : ℤ, (ζ ^ k) ^ ((a * a : ℕ) : ℤ) * ζ ^ (b * a) = ζ ^ (b' * a) := by
+      refine ⟨Nat.gcdA a d * q, ?_⟩
+      rw [← zpow_natCast ζ (b * a), ← zpow_natCast ζ (b' * a), ← zpow_mul, ← zpow_add,
+        ← mul_inv_eq_one, ← zpow_sub, hζu.zpow_eq_one_iff_dvd]
+      refine ⟨-(Nat.gcdB a d * q), ?_⟩
+      push_cast
+      linear_combination (-(a : ℤ)) * hq + (-(a : ℤ) * q) * hbez
+    let T : LaurentSeries K →ₐ[K] LaurentSeries K :=
+      { toRingHom := qTwist (ζ ^ k)
+        commutes' := fun c => by
+          change qTwist (ζ ^ k) (algebraMap K (LaurentSeries K) c) = algebraMap K (LaurentSeries K)
+            c
+          rw [algebraMap_laurentSeries_eq_single, qTwist_single, zpow_zero, Units.val_one,
+            one_mul] }
+    have hFeq : laurentBaseChange K (modularFunctionFieldFull (a * d)) =
+        IntermediateField.adjoin K {coeffEmb K jq, coeffEmb K (jqN (a * d))} := by
+      rw [laurentBaseChange_adjoin_pair K (a * d) (functionFieldGeneration (a * d)), ← coeffEmb_jq,
+        ← coeffEmb_jqN]
+    have hT : ι' = T.comp ι := by
+      refine algHom_ext_of_eq_adjoin K hFeq fun x hx => ?_
+      rcases hx with rfl | rfl
+      · change ι' jb = qTwist (ζ ^ k) (ι jb)
+        rw [hι'₁, hι₁, qTwist_qExpand, ← zpow_mul, zpow_mul', zpow_natCast, hζu.pow_eq_one,
+          one_zpow,
+          qTwist_one_apply]
+      · change ι' jbN = qTwist (ζ ^ k) (ι jbN)
+        rw [hι'₂, hι₂, qTwist_qExpand, qTwist_qTwist, hk]
+    have hordeq : ∀ x, (ι' x).order = (ι x).order := fun x => by
+      rw [hT]
+      exact order_qTwist K (ζ ^ k) (ι x)
+    apply Place.ext
+    ext f
+    rcases eq_or_ne f 0 with rfl | hf
+    · exact ⟨fun _ => zero_mem _, fun _ => zero_mem _⟩
+    rw [Place.mem_iff_ord_nonneg w hf, Place.mem_iff_ord_nonneg w' hf]
+    have e1 := mul_nonneg_iff_of_pos_right (b := w.ord f) hγ
+    have e2 := mul_nonneg_iff_of_pos_right (b := w'.ord f) hγ'
+    rw [hw] at e1
+    rw [hw', hordeq] at e2
+    exact e1.symm.trans e2
+
+end CD
+end Row4
+
+namespace CD
+
+def slotFinset (N : ℕ) : Finset ((_ : ℕ) × ℕ) :=
+  N.divisors.sigma fun a =>
+    (Finset.range (N / a)).filter fun b => Nat.gcd (Nat.gcd a b) (N / a) = 1
+
+theorem mem_slotFinset {N : ℕ} {s : (_ : ℕ) × ℕ} :
+    s ∈ slotFinset N ↔
+      s.1 ∈ N.divisors ∧ s.2 < N / s.1 ∧ Nat.gcd (Nat.gcd s.1 s.2) (N / s.1) = 1 := by
+  cases s with
+  | mk a b =>
+    simp [slotFinset, Finset.mem_sigma, Finset.mem_filter, Finset.mem_range, and_assoc]
+
+theorem slot_cond_iff (a b d : ℕ) :
+    Nat.gcd (Nat.gcd a b) d = 1 ↔ Nat.gcd (Nat.gcd a d) b = 1 := by
+  rw [Nat.gcd_assoc, Nat.gcd_comm b d, ← Nat.gcd_assoc]
+
+theorem slot_cond_congr {a b b' d : ℕ} (h : b ≡ b' [MOD Nat.gcd a d]) :
+    (Nat.gcd (Nat.gcd a b) d = 1 ↔ Nat.gcd (Nat.gcd a b') d = 1) := by
+  rw [slot_cond_iff, slot_cond_iff a b' d]
+  have hg : Nat.gcd (Nat.gcd a d) b = Nat.gcd (Nat.gcd a d) b' := by
+    rw [Nat.gcd_rec (Nat.gcd a d) b, Nat.gcd_rec (Nat.gcd a d) b',
+      show b % Nat.gcd a d = b' % Nat.gcd a d from h]
+  rw [hg]
+
+theorem card_range_filter_modEq {d g b : ℕ} (hg : 0 < g) (hgd : g ∣ d) :
+    ((Finset.range d).filter (· ≡ b [MOD g])).card = d / g := by
+  obtain ⟨c, rfl⟩ := hgd
+  have h := Nat.count_modEq_card (b := g * c) (r := g) hg b
+  rw [Nat.count_eq_card_filter_range] at h
+  rw [Nat.mul_mod_right] at h
+  simpa using h
+
+section SlotsAux1
+open Polynomial IntermediateField
+
+theorem slots_isIntegral_jqN (N : ℕ) [NeZero N] :
+    IsIntegral (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN N) := by
+  have hfin : FiniteDimensional (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+        ({jqN N} : Set (LaurentSeries ℚ))) :=
+    Module.finite_of_finrank_pos
+      (by rw [finrank_adjoin_jqN_eq_dedekindPsi]; exact dedekindPsi_pos N (NeZero.ne N))
+  have h := IsIntegral.of_finite (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+    (AdjoinSimple.gen (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN N))
+  rwa [isIntegral_iff, AdjoinSimple.coe_gen] at h
+
+theorem slots_natDegree_minpoly_jqN (N : ℕ) [NeZero N] :
+    (minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN N)).natDegree =
+      dedekindPsi N := by
+  rw [← adjoin.finrank (slots_isIntegral_jqN N), finrank_adjoin_jqN_eq_dedekindPsi]
+
+theorem card_slotFinset (K : Type*) [Field K] [Algebra ℚ K] (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N) :
+    (slotFinset N).card = dedekindPsi N := by
+  have h := congrArg Polynomial.natDegree (minpoly_jqN_map_eq_prod_slots N ζ hζ
+    (fun d _ _ => ⟨finrank_adjoin_jqN_eq_dedekindPsi d, modularFunctionField_eq_full d⟩))
+  rw [(minpoly.monic (slots_isIntegral_jqN N)).natDegree_map, slots_natDegree_minpoly_jqN,
+    natDegree_prod_of_monic _ _ fun a _ => monic_prod_of_monic _ _ fun b _ => monic_X_sub_C _] at h
+  rw [slotFinset, Finset.card_sigma, h]
+  refine Finset.sum_congr rfl fun a _ => ?_
+  rw [natDegree_prod_of_monic _ _ fun b _ => monic_X_sub_C _]
+  simp only [natDegree_X_sub_C, Finset.sum_const, smul_eq_mul, mul_one]
+
+end SlotsAux1
+
+theorem card_slotFibre (N : ℕ) [NeZero N] {α : Type*} [DecidableEq α] (P : (_ : ℕ) × ℕ → α)
+    (hP : ∀ s ∈ slotFinset N, ∀ s' ∈ slotFinset N,
+      (P s = P s' ↔ s.1 = s'.1 ∧ s.2 ≡ s'.2 [MOD Nat.gcd s.1 (N / s.1)]))
+    (s₀ : (_ : ℕ) × ℕ) (hs₀ : s₀ ∈ slotFinset N) :
+    ((slotFinset N).filter (fun s => P s = P s₀)).card
+      = (N / s₀.1) / Nat.gcd s₀.1 (N / s₀.1) := by
+  obtain ⟨ha₀, hb₀, hg₀⟩ := mem_slotFinset.mp hs₀
+  have ha₀ne : s₀.1 ≠ 0 := (Nat.pos_of_mem_divisors ha₀).ne'
+  have hg₀pos : 0 < Nat.gcd s₀.1 (N / s₀.1) := Nat.pos_of_ne_zero (Nat.gcd_ne_zero_left ha₀ne)
+  have hg₀dvd : Nat.gcd s₀.1 (N / s₀.1) ∣ N / s₀.1 := Nat.gcd_dvd_right _ _
+  refine (Finset.card_nbij (fun b => (⟨s₀.1, b⟩ : (_ : ℕ) × ℕ))
+    (s := (Finset.range (N / s₀.1)).filter (· ≡ s₀.2 [MOD Nat.gcd s₀.1 (N / s₀.1)]))
+    (t := (slotFinset N).filter (fun s => P s = P s₀))
+    ?_ ?_ ?_).symm.trans (card_range_filter_modEq hg₀pos hg₀dvd)
+  · intro b hb
+    rw [Finset.mem_coe, Finset.mem_filter, Finset.mem_range] at hb
+    obtain ⟨hblt, hbeq⟩ := hb
+    have hslot : (⟨s₀.1, b⟩ : (_ : ℕ) × ℕ) ∈ slotFinset N :=
+      mem_slotFinset.mpr ⟨ha₀, hblt, (slot_cond_congr hbeq).mpr hg₀⟩
+    refine Finset.mem_filter.mpr ⟨hslot, ?_⟩
+    exact (hP ⟨s₀.1, b⟩ hslot s₀ hs₀).mpr ⟨rfl, hbeq⟩
+  · intro b _ b' _ h
+    exact congrArg Sigma.snd h
+  · intro s hs
+    simp only [Finset.coe_filter, Set.mem_ofPred_eq] at hs
+    obtain ⟨hsmem, hsP⟩ := hs
+    obtain ⟨_, hsb, _⟩ := mem_slotFinset.mp hsmem
+    obtain ⟨hfst, hsnd⟩ := (hP s hsmem s₀ hs₀).mp hsP
+    refine ⟨s.2, ?_, Sigma.ext hfst.symm (heq_of_eq rfl)⟩
+    rw [Finset.mem_coe, Finset.mem_filter, Finset.mem_range]
+    rw [hfst] at hsb hsnd
+    exact ⟨hsb, hsnd⟩
+
+section Tower
+
+open IntermediateField
+
+variable (K : Type*) [Field K] [Algebra ℚ K] (N : ℕ) [NeZero N]
+
+theorem transcendental_coeffEmb_jq_ambient : Transcendental K (coeffEmb K jq) := by
+  rw [coeffEmb_jq]; exact transcendental_jqModC K
+
+noncomputable def jbar : laurentBaseChange K (modularFunctionFieldFull N) :=
+  ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩
+
+theorem coe_jbar : (jbar K N : LaurentSeries K) = coeffEmb K jq := rfl
+
+noncomputable def sigmaA : RatFunc K ≃ₐ[K] K⟮coeffEmb K jq⟯ :=
+  RatFunc.algEquivOfTranscendental _ (transcendental_coeffEmb_jq_ambient K)
+
+theorem coe_sigmaA_X :
+    ((sigmaA K (RatFunc.X : RatFunc K) : K⟮coeffEmb K jq⟯) : LaurentSeries K) = coeffEmb K jq :=
+  RatFunc.algEquivOfTranscendental_X _ _
+
+theorem mem_full_iff (x : LaurentSeries K) :
+    x ∈ laurentBaseChange K (modularFunctionFieldFull N) ↔
+      x ∈ K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯ := by
+  rw [Row1.CD.laurentBaseChange_full_eq_adjoin_adjoin K N, mem_restrictScalars]
+
+noncomputable def jTr :
+    K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯ ≃+* laurentBaseChange K (modularFunctionFieldFull N) where
+  toFun x := ⟨x, (mem_full_iff K N _).mpr x.2⟩
+  invFun y := ⟨y, (mem_full_iff K N _).mp y.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  map_mul' _ _ := rfl
+  map_add' _ _ := rfl
+
+theorem coe_jTr (x : K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯) :
+    ((jTr K N x : laurentBaseChange K (modularFunctionFieldFull N)) : LaurentSeries K) = x := by
+  ext
+  rfl
+
+noncomputable def phiRF : RatFunc K →+* laurentBaseChange K (modularFunctionFieldFull N) :=
+  (jTr K N).toRingHom.comp
+    ((algebraMap (K⟮coeffEmb K jq⟯) (K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯)).comp
+      (sigmaA K).toRingEquiv.toRingHom)
+
+theorem phiRF_apply (x : RatFunc K) :
+    phiRF K N x =
+      jTr K N (algebraMap (K⟮coeffEmb K jq⟯) (K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯)
+        (sigmaA K x)) := rfl
+
+theorem coe_algebraMap_tower (y : K⟮coeffEmb K jq⟯) :
+    ((algebraMap (K⟮coeffEmb K jq⟯) (K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯) y :
+        K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯) : LaurentSeries K) = y := by
+  rw [IntermediateField.coe_algebraMap_apply]
+  rfl
+
+theorem coe_phiRF (x : RatFunc K) :
+    ((phiRF K N x : laurentBaseChange K (modularFunctionFieldFull N)) : LaurentSeries K) =
+      (sigmaA K x : LaurentSeries K) := by
+  rw [phiRF_apply, coe_jTr, coe_algebraMap_tower]
+
+theorem phiRF_algebraMap (k : K) :
+    phiRF K N (algebraMap K (RatFunc K) k) =
+      algebraMap K (laurentBaseChange K (modularFunctionFieldFull N)) k := by
+  ext
+  rw [coe_phiRF, AlgEquiv.commutes]
+  rfl
+
+theorem phiRF_X : phiRF K N (RatFunc.X : RatFunc K) = jbar K N := by
+  apply Subtype.ext
+  rw [coe_phiRF, coe_jbar, coe_sigmaA_X]
+
+noncomputable abbrev algRatFunc :
+    Algebra (RatFunc K) (laurentBaseChange K (modularFunctionFieldFull N)) :=
+  (phiRF K N).toAlgebra
+
+attribute [local instance] algRatFunc
+
+theorem algebraMap_ratFunc_eq :
+    algebraMap (RatFunc K) (laurentBaseChange K (modularFunctionFieldFull N)) = phiRF K N := rfl
+
+theorem isScalarTower_ratFunc :
+    IsScalarTower K (RatFunc K) (laurentBaseChange K (modularFunctionFieldFull N)) :=
+  IsScalarTower.of_algebraMap_eq fun k => (phiRF_algebraMap K N k).symm
+
+attribute [local instance] isScalarTower_ratFunc
+
+theorem he_compat :
+    (algebraMap (RatFunc K) (laurentBaseChange K (modularFunctionFieldFull N))).comp
+        ((sigmaA K).symm.toRingEquiv : K⟮coeffEmb K jq⟯ ≃+* RatFunc K).toRingHom
+      = (jTr K N).toRingHom.comp
+          (algebraMap (K⟮coeffEmb K jq⟯) (K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯)) := by
+  apply RingHom.ext
+  intro y
+  change phiRF K N ((sigmaA K).symm y) = jTr K N (algebraMap _ _ y)
+  rw [phiRF_apply, AlgEquiv.apply_symm_apply]
+
+theorem finite_ratFunc :
+    Module.Finite (RatFunc K) (laurentBaseChange K (modularFunctionFieldFull N)) := by
+  have : Module.Free (K⟮coeffEmb K jq⟯) (K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯) :=
+    Module.Free.of_divisionRing _ _ -- not needed but gives considerable speedup
+  have : FiniteDimensional (K⟮coeffEmb K jq⟯) (K⟮coeffEmb K jq⟯⟮coeffEmb K (jqN N)⟯) :=
+    Module.finite_of_finrank_pos
+      (by rw [Row1.CD.finrank_adjoin_adjoin K N]; exact dedekindPsi_pos N (NeZero.ne N))
+  exact Module.Finite.of_equiv_equiv
+    ((sigmaA K).symm.toRingEquiv : K⟮coeffEmb K jq⟯ ≃+* RatFunc K) (jTr K N) (he_compat K N)
+
+attribute [local instance] finite_ratFunc
+
+theorem finrank_ratFunc :
+    Module.finrank (RatFunc K) (laurentBaseChange K (modularFunctionFieldFull N)) =
+      dedekindPsi N := by
+  rw [← Algebra.finrank_eq_of_equiv_equiv
+    ((sigmaA K).symm.toRingEquiv : K⟮coeffEmb K jq⟯ ≃+* RatFunc K) (jTr K N) (he_compat K N)]
+  exact Row1.CD.finrank_adjoin_adjoin K N
+
+theorem isSeparable_ratFunc :
+    Algebra.IsSeparable (RatFunc K) (laurentBaseChange K (modularFunctionFieldFull N)) := by
+  have : CharZero K := charZero_of_injective_algebraMap (algebraMap ℚ K).injective
+  have : CharZero (RatFunc K) :=
+    charZero_of_injective_algebraMap (algebraMap K (RatFunc K)).injective
+  exact Algebra.IsAlgebraic.isSeparable_of_perfectField
+
+attribute [local instance] isSeparable_ratFunc
+
+theorem restrict_eq_of_isCusp_pair
+    (u u' : Place K (laurentBaseChange K (modularFunctionFieldFull N)))
+    (hu : IsCusp (jbar K N) u) (hu' : IsCusp (jbar K N) u') :
+    u.restrict (RatFunc K) = u'.restrict (RatFunc K) := by
+  have key : ∀ u₀ : Place K (laurentBaseChange K (modularFunctionFieldFull N)),
+      IsCusp (jbar K N) u₀ →
+      ∀ p : IsDedekindDomain.HeightOneSpectrum (Polynomial K),
+        u₀.restrict (RatFunc K) ≠ Place.ofHeightOneSpectrum p := by
+    intro u₀ hu₀ p heq
+    apply hu₀
+    have hX : (RatFunc.X : RatFunc K) ∈ (u₀.restrict (RatFunc K)).toValuationSubring := by
+      rw [heq, Place.ofHeightOneSpectrum_toValuationSubring, Valuation.mem_valuationSubring_iff,
+        ← RatFunc.algebraMap_X]
+      exact p.valuation_le_one _
+    rw [Place.mem_restrict_iff, algebraMap_ratFunc_eq, phiRF_X] at hX
+    exact hX
+  exact RationalFunctionField.subsingleton_setOf_forall_ne_ofHeightOneSpectrum
+    (key u hu) (key u' hu')
+
+theorem exists_refCusp :
+    ∃ w₀ : Place K (laurentBaseChange K (modularFunctionFieldFull N)),
+      IsCusp (jbar K N) w₀ ∧ w₀.ord (jbar K N) = -1 := by
+  obtain ⟨w₀, hw₀⟩ := Row2.CD.cd2_control K N
+  have hord : w₀.ord (jbar K N) = -1 := by
+    rw [hw₀]
+    exact order_coeffEmb_jq K
+  exact ⟨w₀, (isCusp_iff_ord_neg _ _).mpr (by omega), hord⟩
+
+theorem ramificationIndex_eq_neg_ord_of_isCusp
+    (u : Place K (laurentBaseChange K (modularFunctionFieldFull N)))
+    (hu : IsCusp (jbar K N) u) :
+    (u.ramificationIndex (RatFunc K) : ℤ) = -(u.ord (jbar K N)) := by
+  obtain ⟨w₀, hc₀, h₀⟩ := exists_refCusp K N
+  have h1 := w₀.ord_restrict (F := RatFunc K) (RatFunc.X)
+  rw [algebraMap_ratFunc_eq, phiRF_X, h₀] at h1
+  have hepos₀ : (0 : ℤ) < (w₀.ramificationIndex (RatFunc K) : ℤ) := by
+    exact_mod_cast w₀.ramificationIndex_pos (F := RatFunc K)
+  have he₀ : ((w₀.ramificationIndex (RatFunc K) : ℤ)) = 1 := by
+    refine Int.eq_one_of_mul_eq_one_right hepos₀.le (b := -(w₀.restrict (RatFunc K)).ord RatFunc.X)
+      ?_
+    linarith [h1]
+  have hX : (w₀.restrict (RatFunc K)).ord RatFunc.X = -1 := by
+    rw [he₀, one_mul] at h1
+    linarith
+  have h2 := u.ord_restrict (F := RatFunc K) (RatFunc.X)
+  rw [algebraMap_ratFunc_eq, phiRF_X, restrict_eq_of_isCusp_pair K N u w₀ hu hc₀, hX] at h2
+  omega
+
+theorem exists_slotData (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N) :
+    ∀ s : (_ : ℕ) × ℕ, s ∈ slotFinset N →
+      ∃ (_ : NeZero s.1)
+        (ι : laurentBaseChange K (modularFunctionFieldFull N) →ₐ[K] LaurentSeries K)
+        (u : Place K (laurentBaseChange K (modularFunctionFieldFull N))),
+        (ι ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+            qExpand K N (coeffEmb K jq)) ∧
+        (ι ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩ =
+            qExpand K (s.1 * s.1) (qTwist (ζ ^ (s.2 * s.1)) (coeffEmb K jq))) ∧
+        (∀ x, u.ord x * ((s.1 * Nat.gcd s.1 (N / s.1) : ℕ) : ℤ) = (ι x).order) ∧
+        u.ord (jbar K N) = -((N / s.1 / Nat.gcd s.1 (N / s.1) : ℕ) : ℤ) := by
+  rintro ⟨a, b⟩ hs
+  rw [mem_slotFinset] at hs
+  obtain ⟨hadiv, hblt, hgcd⟩ := hs
+  have haN : a ∣ N := (Nat.mem_divisors.mp hadiv).1
+  have ha0 : a ≠ 0 := (Nat.pos_of_mem_divisors hadiv).ne'
+  have : NeZero a := ⟨ha0⟩
+  obtain ⟨ι, hι₁, hι₂⟩ := Row1.CD.cd1_slotEmbedding K N ζ hζ a b haN hblt hgcd
+  have hordj : (ι ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩).order =
+      (N : ℤ) * (-1) := by
+    rw [hι₁, order_qExpand, order_coeffEmb_jq]
+  obtain ⟨u, γn, hγn, hwn⟩ := Row2.CD.cd2_laurentRF2 K ι
+    ⟨⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩, by
+      rw [hordj]; simp [NeZero.ne N]⟩
+  obtain ⟨hγeq, hoj, -⟩ := Row3.CD.cd3_slotWidth K N ζ a b haN ι hι₁ hι₂ u (γn : ℤ)
+    (by exact_mod_cast hγn) hwn
+  refine ⟨‹NeZero a›, ι, u, hι₁, hι₂, ?_, ?_⟩
+  · intro x
+    have := hwn x
+    rwa [hγeq, ← Nat.cast_mul] at this
+  · exact hoj
+
+theorem main_exhaustion (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (w : Place K (laurentBaseChange K (modularFunctionFieldFull N)))
+    (hc : IsCusp (jbar K N) w) :
+    ∃ a b : ℕ, a ∣ N ∧ b < N / a ∧ Nat.gcd (Nat.gcd a b) (N / a) = 1 ∧
+      ∃ (_ : NeZero a)
+        (ι : laurentBaseChange K (modularFunctionFieldFull N) →ₐ[K] LaurentSeries K),
+        ι ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+            qExpand K N (coeffEmb K jq) ∧
+        ι ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩ =
+            qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)) ∧
+        ∀ x, w.ord x * ((a * Nat.gcd a (N / a) : ℕ) : ℤ) = (ι x).order := by
+  classical
+  choose nz ι place hι₁ hι₂ hword hordj using exists_slotData K N ζ hζ
+  set f : (_ : ℕ) × ℕ → Place K (laurentBaseChange K (modularFunctionFieldFull N)) :=
+    fun s => if hs : s ∈ slotFinset N then place s hs else w with hf
+  have hf_mem : ∀ s (hs : s ∈ slotFinset N), f s = place s hs := fun s hs => by
+    simp [hf, hs]
+  have hcusp : ∀ s (hs : s ∈ slotFinset N), IsCusp (jbar K N) (place s hs) := by
+    intro s hs
+    have h1 : 0 < N / s.1 := Nat.div_pos
+      (Nat.le_of_dvd (Nat.pos_of_ne_zero (NeZero.ne N)) (Nat.mem_divisors.mp ((mem_slotFinset.mp
+        hs).1)).1)
+      (Nat.pos_of_mem_divisors ((mem_slotFinset.mp hs).1))
+    have h2 : 0 < N / s.1 / Nat.gcd s.1 (N / s.1) := Nat.div_pos
+      (Nat.le_of_dvd h1 (Nat.gcd_dvd_right s.1 (N / s.1)))
+      (Nat.gcd_pos_of_pos_right s.1 h1)
+    refine (isCusp_iff_ord_neg _ _).mpr ?_
+    rw [hordj s hs]
+    omega
+  have hexists : ∃ s : (_ : ℕ) × ℕ, ∃ hs : s ∈ slotFinset N, w = place s hs := by
+    by_contra hno
+    push Not at hno
+    set PS : Finset (Place K (laurentBaseChange K (modularFunctionFieldFull N))) :=
+      (slotFinset N).image f with hPS
+    have hwPS : w ∉ PS := by
+      rw [hPS]
+      simp only [Finset.mem_image, not_exists, not_and]
+      intro s hs heq
+      exact hno s hs (by rw [← hf_mem s hs, heq])
+    have hS : ∀ u ∈ insert w PS, u.restrict (RatFunc K) = w.restrict (RatFunc K) := by
+      intro u hu
+      rcases Finset.mem_insert.mp hu with rfl | hu
+      · rfl
+      · obtain ⟨s, hs, rfl⟩ := Finset.mem_image.mp hu
+        rw [hf_mem s hs]
+        exact restrict_eq_of_isCusp_pair K N _ w (hcusp s hs) hc
+    have hsum := Place.sum_ramificationIndex_mul_inertiaDeg_le_finrank
+      (w.restrict (RatFunc K)) (insert w PS) hS
+    rw [finrank_ratFunc] at hsum
+    have hfib : ∀ u ∈ PS, ∃ (s₀ : (_ : ℕ) × ℕ) (hs₀ : s₀ ∈ slotFinset N), u = place s₀ hs₀ := by
+      intro u hu
+      obtain ⟨s₀, hs₀, rfl⟩ := Finset.mem_image.mp hu
+      exact ⟨s₀, hs₀, (hf_mem s₀ hs₀)⟩
+    have hP : ∀ s ∈ slotFinset N, ∀ s' ∈ slotFinset N,
+        (f s = f s' ↔ s.1 = s'.1 ∧ s.2 ≡ s'.2 [MOD Nat.gcd s.1 (N / s.1)]) := by
+      intro s hs s' hs'
+      have h1 := (mem_slotFinset.mp hs); have h2 := (mem_slotFinset.mp hs')
+      have : NeZero s.1 := ⟨(Nat.pos_of_mem_divisors h1.1).ne'⟩
+      have : NeZero s'.1 := ⟨(Nat.pos_of_mem_divisors h2.1).ne'⟩
+      have hpos1 : (0 : ℤ) < ((s.1 * Nat.gcd s.1 (N / s.1) : ℕ) : ℤ) := by
+        exact_mod_cast Nat.mul_pos (Nat.pos_of_mem_divisors h1.1)
+          (Nat.gcd_pos_of_pos_left _ (Nat.pos_of_mem_divisors h1.1))
+      have hpos2 : (0 : ℤ) < ((s'.1 * Nat.gcd s'.1 (N / s'.1) : ℕ) : ℤ) := by
+        exact_mod_cast Nat.mul_pos (Nat.pos_of_mem_divisors h2.1)
+          (Nat.gcd_pos_of_pos_left _ (Nat.pos_of_mem_divisors h2.1))
+      rw [hf_mem s hs, hf_mem s' hs']
+      exact Row4.CD.cd4_slotOrbit K N ζ hζ s.1 s.2 (Nat.mem_divisors.mp h1.1).1 s'.1 s'.2
+        (Nat.mem_divisors.mp h2.1).1 (ι s hs) (ι s' hs') (hι₁ s hs) (hι₂ s hs) (hι₁ s' hs')
+        (hι₂ s' hs') (place s hs) (place s' hs')
+        ((s.1 * Nat.gcd s.1 (N / s.1) : ℕ) : ℤ) ((s'.1 * Nat.gcd s'.1 (N / s'.1) : ℕ) : ℤ)
+        hpos1 hpos2 (hword s hs) (hword s' hs')
+    have hcount0 : (slotFinset N).card =
+        ∑ u ∈ PS, ((slotFinset N).filter (fun s => f s = u)).card :=
+      Finset.card_eq_sum_card_fiberwise (fun s hs => Finset.mem_image_of_mem f hs)
+    have hperu : ∀ u ∈ PS, (((slotFinset N).filter (fun s => f s = u)).card : ℤ)
+        ≤ (u.ramificationIndex (RatFunc K) : ℤ) * (u.inertiaDeg (RatFunc K) : ℤ) := by
+      intro u hu
+      obtain ⟨s₀, hs₀, rfl⟩ := hfib u hu
+      have hcard : ((slotFinset N).filter (fun s => f s = place s₀ hs₀)).card =
+          N / s₀.1 / Nat.gcd s₀.1 (N / s₀.1) := by
+        rw [← hf_mem s₀ hs₀]
+        exact card_slotFibre N f hP s₀ hs₀
+      have he := ramificationIndex_eq_neg_ord_of_isCusp K N (place s₀ hs₀) (hcusp s₀ hs₀)
+      rw [hordj s₀ hs₀, neg_neg] at he
+      have hf1 : (1 : ℤ) ≤ ((place s₀ hs₀).inertiaDeg (RatFunc K) : ℤ) := by
+        exact_mod_cast Place.inertiaDeg_pos (F := RatFunc K) (place s₀ hs₀)
+      have hepos : (0 : ℤ) ≤ ((place s₀ hs₀).ramificationIndex (RatFunc K) : ℤ) := by positivity
+      calc (((slotFinset N).filter (fun s => f s = place s₀ hs₀)).card : ℤ)
+          = ((N / s₀.1 / Nat.gcd s₀.1 (N / s₀.1) : ℕ) : ℤ) := by exact_mod_cast hcard
+        _ = ((place s₀ hs₀).ramificationIndex (RatFunc K) : ℤ) := he.symm
+        _ ≤ _ := le_mul_of_one_le_right hepos hf1
+    have hge : (dedekindPsi N : ℤ) ≤
+        ∑ u ∈ PS, (u.ramificationIndex (RatFunc K) : ℤ) * (u.inertiaDeg (RatFunc K) : ℤ) := by
+      calc (dedekindPsi N : ℤ) = ((slotFinset N).card : ℤ) := by
+            rw [card_slotFinset K N ζ hζ]
+        _ = ∑ u ∈ PS, (((slotFinset N).filter (fun s => f s = u)).card : ℤ) := by
+            rw [hcount0]; push_cast; rfl
+        _ ≤ _ := Finset.sum_le_sum hperu
+    have hw1 : (1 : ℤ) ≤ (w.ramificationIndex (RatFunc K) : ℤ) * (w.inertiaDeg (RatFunc K) : ℤ) :=
+      by
+      have e1 : (1 : ℤ) ≤ (w.ramificationIndex (RatFunc K) : ℤ) := by
+        exact_mod_cast w.ramificationIndex_pos (F := RatFunc K)
+      have f1 : (1 : ℤ) ≤ (w.inertiaDeg (RatFunc K) : ℤ) := by
+        exact_mod_cast Place.inertiaDeg_pos (F := RatFunc K) w
+      have := mul_le_mul e1 f1 zero_le_one (le_trans zero_le_one e1)
+      simpa using this
+    rw [Finset.sum_insert hwPS] at hsum
+    linarith
+  obtain ⟨⟨a, b⟩, hs, rfl⟩ := hexists
+  have hmem := mem_slotFinset.mp hs
+  have : NeZero a := ⟨(Nat.pos_of_mem_divisors hmem.1).ne'⟩
+  exact ⟨a, b, (Nat.mem_divisors.mp hmem.1).1, hmem.2.1, hmem.2.2,
+    ⟨‹NeZero a›, ι ⟨a, b⟩ hs, hι₁ ⟨a, b⟩ hs, hι₂ ⟨a, b⟩ hs, hword ⟨a, b⟩ hs⟩⟩
+
+end Tower
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+private theorem _root_.ModularCurve.exists_slot_of_isCusp' (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N)
+    (w : Place K (laurentBaseChange K (modularFunctionFieldFull N)))
+    (hc : IsCusp (⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ :
+        laurentBaseChange K (modularFunctionFieldFull N)) w) :
+    ∃ a b : ℕ, a ∣ N ∧ b < N / a ∧ Nat.gcd (Nat.gcd a b) (N / a) = 1 ∧
+      ∃ (_ : NeZero a) (ι : laurentBaseChange K (modularFunctionFieldFull N) →ₐ[K] LaurentSeries K),
+        ι ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+            qExpand K N (coeffEmb K jq) ∧
+        ι ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩ =
+            qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)) ∧
+        ∀ x, w.ord x * ((a * Nat.gcd a (N / a) : ℕ) : ℤ) = (ι x).order :=
+  main_exhaustion K N ζ hζ w hc
+
+end CD
+
+
+open ModularCurve AlgebraicCurve in
+theorem solution (K : Type*) [Field K] [Algebra ℚ K] (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N)
+    (w : Place K (laurentBaseChange K (modularFunctionFieldFull N)))
+    (hc : IsCusp (⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ :
+        laurentBaseChange K (modularFunctionFieldFull N)) w) :
+    ∃ a b : ℕ, a ∣ N ∧ b < N / a ∧ Nat.gcd (Nat.gcd a b) (N / a) = 1 ∧
+      ∃ (_ : NeZero a) (ι : laurentBaseChange K (modularFunctionFieldFull N) →ₐ[K] LaurentSeries K),
+        ι ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+            qExpand K N (coeffEmb K jq) ∧
+        ι ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩ =
+            qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)) ∧
+        ∀ x, w.ord x * ((a * Nat.gcd a (N / a) : ℕ) : ℤ) = (ι x).order :=
+  ModularCurve.exists_slot_of_isCusp' K N ζ hζ w hc
+
+end
+end S_ModularCurve_exists_slot_of_isCusp
+end P2MW
+export P2MW.S_ModularCurve_exists_slot_of_isCusp (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.exists_slot_of_isCusp (K : Type*) [Field K] [Algebra ℚ K] (N : ℕ) [NeZero N]
+    (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (w : Place K (laurentBaseChange K (modularFunctionFieldFull N)))
+    (hc : IsCusp (⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ :
+        laurentBaseChange K (modularFunctionFieldFull N)) w) :
+    ∃ a b : ℕ, a ∣ N ∧ b < N / a ∧ Nat.gcd (Nat.gcd a b) (N / a) = 1 ∧
+      ∃ (_ : NeZero a) (ι : laurentBaseChange K (modularFunctionFieldFull N) →ₐ[K] LaurentSeries K),
+        ι ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+            qExpand K N (coeffEmb K jq) ∧
+        ι ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩ =
+            qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)) ∧
+        ∀ x, w.ord x * ((a * Nat.gcd a (N / a) : ℕ) : ℤ) = (ι x).order :=
+  solution K N ζ hζ w hc
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_smul_eq_of_E4_cube_div_discriminant_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_smul_eq_of_E4_cube_div_discriminant_eq.lean
new file mode 100644
index 0000000000..ac1f19b5c4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_smul_eq_of_E4_cube_div_discriminant_eq.lean
@@ -0,0 +1,328 @@
+/-
+Based on Prove2Me node ModularCurve.exists_smul_eq_of_E4_cube_div_discriminant_eq
+(7effcae8-9a2b-5bc7-ac68-988dfd729842) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1309f89b-2929-5cec-a9fb-f1717db78496
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+
+import Mathlib.Data.Int.Star
+import Mathlib.NumberTheory.LSeries.Nonvanishing
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+import LeanPool.FLTEichlerShimura.Definitions.Def_PeriodPair_Uniformization
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_lattice_eq_of_g2_eq_of_g3_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# E₄³/Δ separates SL₂(ℤ)-orbits on H
+
+Theorem statement: `ModularCurve.exists_smul_eq_of_E4_cube_div_discriminant_eq`
+(`7effcae8-9a2b-5bc7-ac68-988dfd729842`), by Claude, 2026-09-05.
+
+Proof: submission `1309f89b-2929-5cec-a9fb-f1717db78496`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\tau$ and $\tau'$ be points of the upper half plane $\mathfrak H$, and consider the function
+$\tau \mapsto E_4(\tau)^3/\Delta(\tau)$ built from Mathlib's level-one weight-four Eisenstein series
+`ModularForm.E₄`, evaluated through its coercion to a function $\mathfrak H \to \mathbb C$, and
+Mathlib's modular discriminant `ModularForm.discriminant`; the quotient is the usual quotient of
+complex numbers. The hypothesis is that this function takes the same value at $\tau$ and at $\tau'$,
+i.e. $E_4(\tau)^3/\Delta(\tau) = E_4(\tau')^3/\Delta(\tau')$. The conclusion asserts the existence
+of a matrix $\gamma \in \mathrm{SL}_2(\mathbb Z)$ with $\gamma \cdot \tau = \tau'$, the action being
+the Möbius action of $\mathrm{SL}_2(\mathbb Z)$ on $\mathfrak H$ by fractional linear
+transformations. Thus $\tau$ and $\tau'$ lie in the same orbit. Only the injectivity direction is
+asserted: no statement is made about surjectivity of the function onto $\mathbb C$, nor about the
+converse implication that the function is $\mathrm{SL}_2(\mathbb Z)$-invariant.
+
+This is the injectivity half of the classical fact that the $j$-invariant, here in the normalisation
+$E_4^3/\Delta$, induces a bijection from $\mathrm{SL}_2(\mathbb Z)\backslash\mathfrak H$ onto
+$\mathbb C$. The proof passes through the determination of a lattice in $\mathbb C$ by its
+Weierstrass invariants $g_2$ and $g_3$
+([`PeriodPair.lattice_eq_of_g2_eq_of_g3_eq`](thm.html#PeriodPair.lattice_eq_of_g2_eq_of_g3_eq)), and
+the result is used in the analysis of the modular curve at the level of stabilisers and
+ramification, by
+[`ModularCurve.ComplexPlaceDictionaryOf.two_mul_ramification_eq_card_stabilizer`]
+(thm.html#ModularCurve.ComplexPlaceDictionaryOf.two_mul_ramification_eq_card_stabilizer)
+and
+[`ModularCurve.meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two`]
+(thm.html#ModularCurve.meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_smul_eq_of_E4_cube_div_discriminant_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_smul_eq_of_E4_cube_div_discriminant_eq
+
+noncomputable section
+
+open UpperHalfPlane ModularForm EisensteinSeries Complex
+open scoped MatrixGroups Real Topology
+
+namespace ModularCurve
+namespace JSeparatesOrbits
+
+private lemma pow_four_six_of_sq {t x : ℂ} (h : t ^ 2 = x) : t ^ 4 = x ^ 2 ∧ t ^ 6 = x ^ 3 := by
+  constructor <;> [rw [show (4:ℕ) = 2 * 2 from rfl]; rw [show (6:ℕ) = 2 * 3 from rfl]] <;>
+    rw [pow_mul, h]
+
+theorem exists_scalar {a₁ b₁ a₂ b₂ : ℂ}
+    (h₁ : a₁ ^ 3 - b₁ ^ 2 ≠ 0) (h₂ : a₂ ^ 3 - b₂ ^ 2 ≠ 0)
+    (R1 : a₁ ^ 3 * b₂ ^ 2 = a₂ ^ 3 * b₁ ^ 2) :
+    ∃ w : ℂ, w ≠ 0 ∧ a₂ = w ^ 4 * a₁ ∧ b₂ = w ^ 6 * b₁ := by
+  by_cases ha₁ : a₁ = 0
+  · subst ha₁
+    have hb₁ : b₁ ≠ 0 := by rintro rfl; exact h₁ (by ring)
+    have ha₂ : a₂ = 0 := by
+      have : a₂ ^ 3 * b₁ ^ 2 = 0 := by rw [← R1]; ring
+      simpa [hb₁] using this
+    subst ha₂
+    have hb₂ : b₂ ≠ 0 := by rintro rfl; exact h₂ (by ring)
+    obtain ⟨t, ht⟩ := IsAlgClosed.exists_pow_nat_eq (b₂ / b₁) (by norm_num : 0 < 6)
+    have ht0 : t ≠ 0 := by
+      rintro rfl
+      rw [zero_pow (by norm_num), eq_comm, div_eq_zero_iff] at ht
+      exact ht.elim hb₂ hb₁
+    exact ⟨t, ht0, by simp, by rw [ht]; field_simp⟩
+  · have ha₂ : a₂ ≠ 0 := by
+      intro ha₂; subst ha₂
+      have hb₂ : b₂ = 0 := by
+        have : a₁ ^ 3 * b₂ ^ 2 = 0 := by rw [R1]; ring
+        simpa [ha₁] using this
+      exact h₂ (by rw [hb₂]; ring)
+    by_cases hb₁ : b₁ = 0
+    · subst hb₁
+      have hb₂ : b₂ = 0 := by
+        have : a₁ ^ 3 * b₂ ^ 2 = 0 := by rw [R1]; ring
+        simpa [ha₁] using this
+      subst hb₂
+      obtain ⟨t, ht⟩ := IsAlgClosed.exists_pow_nat_eq (a₂ / a₁) (by norm_num : 0 < 4)
+      have ht0 : t ≠ 0 := by
+        rintro rfl
+        rw [zero_pow (by norm_num), eq_comm, div_eq_zero_iff] at ht
+        exact ht.elim ha₂ ha₁
+      exact ⟨t, ht0, by rw [ht]; field_simp, by simp⟩
+    · have hb₂ : b₂ ≠ 0 := by
+        intro hb₂
+        have : a₂ ^ 3 * b₁ ^ 2 = 0 := by rw [← R1, hb₂]; ring
+        simp [ha₂, hb₁] at this
+      obtain ⟨t, ht⟩ := IsAlgClosed.exists_pow_nat_eq (a₁ * b₂ / (a₂ * b₁)) (by norm_num : 0 < 2)
+      have ht0 : t ≠ 0 := by
+        rintro rfl
+        rw [zero_pow (by norm_num), eq_comm, div_eq_zero_iff, mul_eq_zero, mul_eq_zero] at ht
+        rcases ht with (h | h) | (h | h) <;> contradiction
+      obtain ⟨ht4, ht6⟩ := pow_four_six_of_sq ht
+      have ha : a₂ = t ^ 4 * a₁ := by
+        rw [ht4, div_pow, div_mul_eq_mul_div,
+          eq_div_iff (pow_ne_zero _ (mul_ne_zero ha₂ hb₁))]
+        linear_combination -R1
+      have hb : b₂ = t ^ 6 * b₁ := by
+        rw [ht6, div_pow, div_mul_eq_mul_div,
+          eq_div_iff (pow_ne_zero _ (mul_ne_zero ha₂ hb₁))]
+        linear_combination -(b₁ * b₂) * R1
+      exact ⟨t, ht0, ha, hb⟩
+
+lemma int_indep (τ : ℍ) {m n m' n' : ℤ}
+    (h : (m : ℂ) * τ + n = m' * τ + n') : m = m' ∧ n = n' := by
+  have him := congrArg Complex.im h
+  simp only [add_im, mul_im, intCast_re, intCast_im, zero_mul, add_zero, coe_im,
+    coe_re] at him
+  have hm : m = m' := by
+    have : ((m : ℝ) - m') * τ.im = 0 := by linarith
+    rcases mul_eq_zero.1 this with h0 | h0
+    · exact_mod_cast sub_eq_zero.1 h0
+    · exact absurd h0 τ.im_pos.ne'
+  subst hm
+  refine ⟨rfl, ?_⟩
+  have := add_left_cancel h
+  exact_mod_cast this
+
+theorem exists_sl2z_of_lattice_rel (τ₁ τ₂ : ℍ) {u : ℂ} (hu : u ≠ 0)
+    {a b c d p q r s : ℤ}
+    (h1 : u * (a * τ₁ + b) = τ₂) (h2 : u * (c * τ₁ + d) = 1)
+    (h3 : p * (τ₂ : ℂ) + q = u * τ₁) (h4 : r * (τ₂ : ℂ) + s = u) :
+    ∃ γ : SL(2, ℤ), γ • τ₁ = τ₂ := by
+  have hrow₁ : p * a + q * c = 1 ∧ p * b + q * d = 0 := by
+    refine int_indep τ₁ (mul_left_cancel₀ hu ?_)
+    push_cast
+    linear_combination p * h1 + q * h2 + h3
+  have hrow₂ : r * a + s * c = 0 ∧ r * b + s * d = 1 := by
+    refine int_indep τ₁ (mul_left_cancel₀ hu ?_)
+    push_cast
+    linear_combination r * h1 + s * h2 + h4
+  have hdet : (a * d - b * c) * (p * s - q * r) = 1 := by
+    linear_combination (r * b + s * d) * hrow₁.1 - (r * a + s * c) * hrow₁.2 + hrow₂.2
+  have hz : (c : ℂ) * τ₁ + d ≠ 0 := by
+    intro h0; rw [h0, mul_zero] at h2; exact zero_ne_one h2
+  have hτ₂ : (τ₂ : ℂ) * (c * τ₁ + d) = a * τ₁ + b := by
+    linear_combination -((c : ℂ) * τ₁ + d) * h1 + ((a : ℂ) * τ₁ + b) * h2
+  have him : τ₂.im * Complex.normSq (c * τ₁ + d) = (a * d - b * c) * τ₁.im := by
+    have h := congrArg Complex.im
+      (show (τ₂ : ℂ) * (Complex.normSq ((c : ℂ) * τ₁ + d) : ℂ) =
+          (a * τ₁ + b) * (starRingEnd ℂ) (c * τ₁ + d) by
+        rw [← Complex.mul_conj, ← mul_assoc, hτ₂])
+    simp only [mul_im, ofReal_re, ofReal_im, mul_zero, add_zero, add_im, add_re, mul_re,
+      intCast_re, intCast_im, zero_mul, sub_zero, Complex.conj_re, Complex.conj_im, coe_re,
+      coe_im] at h
+    rw [zero_add] at h
+    rw [h]
+    ring
+  have hdet1 : a * d - b * c = 1 := by
+    rcases Int.eq_one_or_neg_one_of_mul_eq_one hdet with h | h
+    · exact h
+    · exfalso
+      have hpos : 0 < τ₂.im * Complex.normSq (c * τ₁ + d) :=
+        mul_pos τ₂.im_pos (Complex.normSq_pos.2 hz)
+      rw [him] at hpos
+      have : ((a * d - b * c : ℤ) : ℝ) = -1 := by exact_mod_cast h
+      push_cast at this
+      rw [this] at hpos
+      linarith [τ₁.im_pos]
+  let γ : SL(2, ℤ) := ⟨!![a, b; c, d], by rw [Matrix.det_fin_two_of]; linarith⟩
+  refine ⟨γ, ?_⟩
+  apply UpperHalfPlane.ext
+  rw [coe_specialLinearGroup_apply]
+  simp only [γ, algebraMap_int_eq, eq_intCast, ofReal_intCast, Matrix.of_apply,
+    Matrix.cons_val', Matrix.cons_val_zero, Matrix.cons_val_one, Matrix.cons_val_fin_one,
+    Matrix.empty_val']
+  rw [div_eq_iff hz, hτ₂]
+
+section Bridge
+open PeriodPair
+
+theorem G_ofTau_eq {k : ℕ} (hk : 3 ≤ k) (τ : ℍ) :
+    (ofTau τ).G k = 2 * riemannZeta k * ModularForm.E hk τ := by
+  rw [PeriodPair.G, ← (ofTau τ).latticeEquivProd.symm.toEquiv.tsum_eq]
+  simp only [LinearEquiv.coe_toEquiv, latticeEquiv_symm_apply, ofTau_ω₁, ofTau_ω₂, mul_one]
+  have hstep : ∀ p : ℤ × ℤ,
+      ((↑p.1 * (τ : ℂ) + ↑p.2) ^ k)⁻¹ = eisSummand k ((finTwoArrowEquiv ℤ).symm p) τ := by
+    intro p
+    simp only [eisSummand, finTwoArrowEquiv_symm_apply, Matrix.cons_val_zero,
+      Matrix.cons_val_one, Matrix.cons_val_fin_one, zpow_neg, zpow_natCast]
+  simp only [hstep]
+  rw [(finTwoArrowEquiv ℤ).symm.tsum_eq (f := fun v => eisSummand (k : ℤ) v τ),
+    tsum_eisSummand_eq_riemannZeta_mul_eisensteinSeries hk τ,
+    show E hk τ = (1 / 2 : ℂ) • eisensteinSeriesSIF (N := 1) 0 k τ from rfl,
+    eisensteinSeriesSIF_apply, smul_eq_mul]
+  ring
+
+theorem G_scale (L : PeriodPair) (α : ℂˣ) (k : ℕ) :
+    (L.scale α).G k = ((α : ℂ) ^ k)⁻¹ * L.G k := by
+  rw [PeriodPair.G, PeriodPair.G, ← (L.scale α).latticeEquivProd.symm.toEquiv.tsum_eq,
+    ← L.latticeEquivProd.symm.toEquiv.tsum_eq, ← tsum_mul_left]
+  congr 1 with p
+  simp only [LinearEquiv.coe_toEquiv, latticeEquiv_symm_apply, scale_ω₁, scale_ω₂]
+  rw [show (p.1 : ℂ) * (α * L.ω₁) + p.2 * (α * L.ω₂) = α * (p.1 * L.ω₁ + p.2 * L.ω₂) by ring,
+    mul_pow, mul_inv]
+
+theorem g₂_scale (L : PeriodPair) (α : ℂˣ) : (L.scale α).g₂ = ((α : ℂ) ^ 4)⁻¹ * L.g₂ := by
+  rw [PeriodPair.g₂, PeriodPair.g₂, G_scale]; ring
+
+theorem g₃_scale (L : PeriodPair) (α : ℂˣ) : (L.scale α).g₃ = ((α : ℂ) ^ 6)⁻¹ * L.g₃ := by
+  rw [PeriodPair.g₃, PeriodPair.g₃, G_scale]; ring
+
+theorem g₂_ofTau (τ : ℍ) : (ofTau τ).g₂ = (120 * riemannZeta 4) * E₄ τ := by
+  rw [PeriodPair.g₂, G_ofTau_eq (by norm_num : 3 ≤ 4)]; push_cast; ring
+
+theorem g₃_ofTau (τ : ℍ) : (ofTau τ).g₃ = (280 * riemannZeta 6) * E₆ τ := by
+  rw [PeriodPair.g₃, G_ofTau_eq (by norm_num : 3 ≤ 6)]; push_cast; ring
+
+theorem mem_scale_lattice (L : PeriodPair) (α : ℂˣ) (x : ℂ) :
+    x ∈ (L.scale α).lattice ↔ ∃ m n : ℤ, (α : ℂ) * (m * L.ω₁ + n * L.ω₂) = x := by
+  rw [mem_lattice]
+  simp only [scale_ω₁, scale_ω₂]
+  constructor
+  · rintro ⟨m, n, rfl⟩; exact ⟨m, n, by ring⟩
+  · rintro ⟨m, n, rfl⟩; exact ⟨m, n, by ring⟩
+
+theorem C₄_ne_zero : (120 * riemannZeta 4 : ℂ) ≠ 0 :=
+  mul_ne_zero (by norm_num) (riemannZeta_ne_zero_of_one_le_re (by norm_num))
+
+theorem C₆_ne_zero : (280 * riemannZeta 6 : ℂ) ≠ 0 :=
+  mul_ne_zero (by norm_num) (riemannZeta_ne_zero_of_one_le_re (by norm_num))
+
+end Bridge
+
+theorem E₄_cube_sub_E₆_sq_ne_zero (z : ℍ) : E₄ z ^ 3 - E₆ z ^ 2 ≠ 0 := fun h0 => by
+  have h := ModularForm.discriminant_eq_E₄_cube_sub_E₆_sq z
+  rw [h0, zero_div] at h
+  exact ModularForm.discriminant_ne_zero z h
+
+end ModularCurve.JSeparatesOrbits
+
+open ModularCurve.JSeparatesOrbits in
+theorem solution (τ τ' : ℍ)
+    (h : (ModularForm.E₄ : ℍ → ℂ) τ ^ 3 / ModularForm.discriminant τ =
+      (ModularForm.E₄ : ℍ → ℂ) τ' ^ 3 / ModularForm.discriminant τ') :
+    ∃ γ : SL(2, ℤ), γ • τ = τ' := by
+  have R1 : E₄ τ ^ 3 * E₆ τ' ^ 2 = E₄ τ' ^ 3 * E₆ τ ^ 2 := by
+    rw [ModularForm.discriminant_eq_E₄_cube_sub_E₆_sq,
+      ModularForm.discriminant_eq_E₄_cube_sub_E₆_sq,
+      div_eq_div_iff (by simpa using E₄_cube_sub_E₆_sq_ne_zero τ)
+        (by simpa using E₄_cube_sub_E₆_sq_ne_zero τ')] at h
+    change E₄ τ ^ 3 * ((E₄ τ' ^ 3 - E₆ τ' ^ 2) / 1728) =
+      E₄ τ' ^ 3 * ((E₄ τ ^ 3 - E₆ τ ^ 2) / 1728) at h
+    linear_combination -1728 * h
+  obtain ⟨w, hw, hwa, hwb⟩ := exists_scalar (E₄_cube_sub_E₆_sq_ne_zero τ)
+    (E₄_cube_sub_E₆_sq_ne_zero τ') R1
+  set uU : ℂˣ := (Units.mk0 w hw)⁻¹ with huU
+  set u : ℂ := (uU : ℂ) with huc
+  have hu : u ≠ 0 := uU.ne_zero
+  have hwu : w = u⁻¹ := by simp [huc, huU]
+  have hΛ : (PeriodPair.ofTau τ').lattice = ((PeriodPair.ofTau τ).scale uU).lattice := by
+    apply PeriodPair.lattice_eq_of_g2_eq_of_g3_eq
+    · rw [g₂_scale, g₂_ofTau, g₂_ofTau, hwa, ← huc, hwu, inv_pow]; ring
+    · rw [g₃_scale, g₃_ofTau, g₃_ofTau, hwb, ← huc, hwu, inv_pow]; ring
+  obtain ⟨a, b, h1⟩ : ∃ a b : ℤ, u * (a * τ + b) = τ' := by
+    have h := (PeriodPair.ofTau τ').ω₁_mem_lattice
+    rw [hΛ, mem_scale_lattice] at h
+    simpa only [PeriodPair.ofTau_ω₁, PeriodPair.ofTau_ω₂, mul_one, huc] using h
+  obtain ⟨c, d, h2⟩ : ∃ c d : ℤ, u * (c * τ + d) = 1 := by
+    have h := (PeriodPair.ofTau τ').ω₂_mem_lattice
+    rw [hΛ, mem_scale_lattice] at h
+    simpa only [PeriodPair.ofTau_ω₁, PeriodPair.ofTau_ω₂, mul_one, huc] using h
+  obtain ⟨p, q, h3⟩ : ∃ p q : ℤ, p * (τ' : ℂ) + q = u * τ := by
+    have h := ((PeriodPair.ofTau τ).scale uU).ω₁_mem_lattice
+    rw [← hΛ, PeriodPair.mem_lattice] at h
+    simpa only [PeriodPair.ofTau_ω₁, PeriodPair.ofTau_ω₂, PeriodPair.scale_ω₁, mul_one,
+      huc] using h
+  obtain ⟨r, s, h4⟩ : ∃ r s : ℤ, r * (τ' : ℂ) + s = u := by
+    have h := ((PeriodPair.ofTau τ).scale uU).ω₂_mem_lattice
+    rw [← hΛ, PeriodPair.mem_lattice] at h
+    simpa only [PeriodPair.ofTau_ω₁, PeriodPair.ofTau_ω₂, PeriodPair.scale_ω₂, mul_one,
+      huc] using h
+  exact exists_sl2z_of_lattice_rel τ τ' hu h1 h2 h3 h4
+
+end
+end S_ModularCurve_exists_smul_eq_of_E4_cube_div_discriminant_eq
+end P2MW
+export P2MW.S_ModularCurve_exists_smul_eq_of_E4_cube_div_discriminant_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane
+open scoped MatrixGroups
+theorem ModularCurve.exists_smul_eq_of_E4_cube_div_discriminant_eq (τ τ' : ℍ)
+    (h : (ModularForm.E₄ : ℍ → ℂ) τ ^ 3 / ModularForm.discriminant τ =
+      (ModularForm.E₄ : ℍ → ℂ) τ' ^ 3 / ModularForm.discriminant τ') :
+    ∃ γ : SL(2, ℤ), γ • τ = τ' :=
+  solution τ τ' h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_tendsto_div_smul_of_eventuallyEq_realizeOf_of_tendsto.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_tendsto_div_smul_of_eventuallyEq_realizeOf_of_tendsto.lean
new file mode 100644
index 0000000000..ab3828abfa
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_tendsto_div_smul_of_eventuallyEq_realizeOf_of_tendsto.lean
@@ -0,0 +1,396 @@
+/-
+Based on Prove2Me node ModularCurve.exists_tendsto_div_smul_of_eventuallyEq_realizeOf_of_tendsto
+(7370d638-21ce-5968-a661-67c17745520c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9df7f04e-bfd6-5262-9ad6-4bc63c106f8e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ComplexPlaceDictionaryOf
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_realizeOf_eq_div
+import Mathlib.NumberTheory.ModularForms.NormTrace
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cusp limits transfer from F to the ratio g/h
+
+Theorem statement: `ModularCurve.exists_tendsto_div_smul_of_eventuallyEq_realizeOf_of_tendsto`
+(`7370d638-21ce-5968-a661-67c17745520c`), by Claude, 2026-09-05.
+
+Proof: submission `9df7f04e-bfd6-5262-9ad6-4bc63c106f8e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a finite-index subgroup of $\mathrm{SL}_2(\mathbb{Z})$ containing the translation
+matrix $T$, and let $g,h$ be modular forms of one and the same integer weight $k$ for the image of
+$\Gamma$ in $\mathrm{GL}_2(\mathbb{R})$, with $h \neq 0$. Let $x$ be a Laurent series over
+$\mathbb{C}$ whose product with the $q$-expansion of $h$ of period $1$, viewed as a Laurent series,
+equals the $q$-expansion of $g$ of period $1$. Let $F : \mathfrak{H} \to \mathbb{C}$ be a function
+such that for every $\tau \in \mathfrak{H}$ the functions $z \mapsto F(\mathrm{ofComplex}\, z)$ and
+$z \mapsto \mathrm{realizeOf}\,\Gamma\,x\,(\mathrm{ofComplex}\, z)$ agree on a punctured
+neighbourhood of $\tau$ in $\mathbb{C}$; here $\mathrm{realizeOf}\,\Gamma\,x\,\tau$ is
+$g_0(\tau)/h_0(\tau)$ for some choice of weight $k_0$ and modular forms $g_0,h_0$ of weight $k_0$
+for $\Gamma$ with $h_0(\tau) \neq 0$ and $x$ times the $q$-expansion of $h_0$ equal to that of
+$g_0$, if such data exist, and $0$ otherwise. Assume furthermore that for every $\sigma \in
+\mathrm{SL}_2(\mathbb{Z})$ the function $\tau \mapsto F(\sigma \cdot \tau)$ tends to some non-zero
+limit as $\operatorname{Im} \tau \to \infty$. Then for each given $\sigma \in
+\mathrm{SL}_2(\mathbb{Z})$ there is $L \neq 0$ with $g(\sigma \cdot \tau)/h(\sigma \cdot \tau) \to
+L$ as $\operatorname{Im}\tau \to \infty$.
+
+This is the transfer of cusp behaviour from a function $F$ that agrees off a discrete set with the
+level-$\Gamma$ realization of a Laurent series to the honest ratio $g/h$ of modular forms
+representing that series: finite non-zero limits towards $i\infty$ in every
+$\mathrm{SL}_2(\mathbb{Z})$-translate persist. It is used in the computation of orders of vanishing
+of such realizations, via
+[`ModularCurve.ord_eq_zero_of_not_mem_of_realizeOf_tendsto`]
+(thm.html#ModularCurve.ord_eq_zero_of_not_mem_of_realizeOf_tendsto),
+and rests on the identification
+[`ModularCurve.realizeOf_eq_div`](thm.html#ModularCurve.realizeOf_eq_div) of the realization with
+$g/h$ away from the zeros of $h$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_tendsto_div_smul_of_eventuallyEq_realizeOf_of_tendsto.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_tendsto_div_smul_of_eventuallyEq_realizeOf_of_tendsto
+
+
+p2m_open "UpperHalfPlane ModularForm Filter Function Complex Function.Complex \
+  Matrix.SpecialLinearGroup OnePoint"
+open scoped MatrixGroups Topology CongruenceSubgroup Pointwise Manifold
+
+noncomputable section
+
+namespace Ws49
+namespace LIMTR
+
+namespace S3CuspLimit
+
+variable {k : ℤ}
+
+def wd (Γ : Subgroup SL(2, ℤ)) : ℕ := Γ.normalCore.index
+
+scoped instance wd_neZero (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] : NeZero (wd Γ) :=
+  ⟨Subgroup.FiniteIndex.index_ne_zero⟩
+
+theorem wd_pos (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] : (0 : ℝ) < wd Γ := by
+  exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne (wd Γ))
+
+private theorem conj_T_zpow_mem (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (σ : SL(2, ℤ)) :
+    σ * ModularGroup.T ^ (wd Γ : ℤ) * σ⁻¹ ∈ Γ := by
+  have h1 : ModularGroup.T ^ (wd Γ : ℤ) ∈ Γ.normalCore := by
+    rw [zpow_natCast]
+    exact Subgroup.pow_index_mem Γ.normalCore ModularGroup.T
+  have h2 : σ * ModularGroup.T ^ (wd Γ : ℤ) * σ⁻¹ ∈ Γ.normalCore :=
+    (Subgroup.normalCore_normal Γ).conj_mem _ h1 σ
+  exact Subgroup.normalCore_le Γ h2
+
+private theorem coe_eq_mapGL (γ : SL(2, ℤ)) : (γ : GL (Fin 2) ℝ) = mapGL ℝ γ := rfl
+
+private theorem mapGL_T_zpow (N : ℕ) :
+    mapGL ℝ (ModularGroup.T ^ (N : ℤ)) =
+      Matrix.GeneralLinearGroup.upperRightHom (N : ℝ) := by
+  have hmat : ((ModularGroup.T ^ (N : ℤ) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) =
+      !![1, (N : ℤ); 0, 1] := ModularGroup.coe_T_zpow (N : ℤ)
+  rw [Units.ext_iff]
+  have hval : (↑(mapGL ℝ (ModularGroup.T ^ (N : ℤ))) : Matrix (Fin 2) (Fin 2) ℝ) =
+      (!![1, (N : ℤ); 0, 1]).map (Int.cast : ℤ → ℝ) := by
+    rw [← hmat]; rfl
+  rw [hval]
+  ext i j
+  fin_cases i <;> fin_cases j <;>
+    simp [Matrix.GeneralLinearGroup.upperRightHom]
+
+theorem natCast_mem_strictPeriods_translate (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex]
+    (σ : SL(2, ℤ)) :
+    (wd Γ : ℝ) ∈ Subgroup.strictPeriods
+      (ConjAct.toConjAct ((σ : GL (Fin 2) ℝ))⁻¹ • ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2)
+        ℝ))) := by
+  rw [Subgroup.mem_strictPeriods_iff, map_inv, Subgroup.mem_inv_pointwise_smul_iff,
+    ConjAct.toConjAct_smul, ← mapGL_T_zpow (wd Γ), coe_eq_mapGL, ← map_inv, ← map_mul, ← map_mul]
+  exact Subgroup.mem_map_of_mem _ (conj_T_zpow_mem Γ σ)
+
+variable {Γ : Subgroup SL(2, ℤ)} [Γ.FiniteIndex]
+
+omit [Γ.FiniteIndex] in
+theorem coe_translate_SL (g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (σ : SL(2, ℤ)) :
+    ⇑(ModularForm.translate g (σ : GL (Fin 2) ℝ)) = ⇑g ∣[k] σ := by
+  rw [SL_slash]
+  exact ModularForm.coe_translate g _
+
+theorem slash_periodic (g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (σ : SL(2, ℤ)) :
+    Periodic ((⇑g ∣[k] σ) ∘ ofComplex) (wd Γ : ℝ) := by
+  rw [← coe_translate_SL g σ]
+  exact SlashInvariantFormClass.periodic_comp_ofComplex
+    (ModularForm.translate g (σ : GL (Fin 2) ℝ))
+    (natCast_mem_strictPeriods_translate Γ σ)
+
+omit [Γ.FiniteIndex] in
+theorem slash_mdiff (g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (σ : SL(2, ℤ)) :
+    MDiff (⇑g ∣[k] σ) := by
+  rw [← coe_translate_SL g σ]
+  exact ModularFormClass.holo _
+
+theorem slash_bddAtImInfty (g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (σ : SL(2, ℤ)) :
+    IsBoundedAtImInfty (⇑g ∣[k] σ) := by
+  have hFact : Fact (IsCusp ∞ (ConjAct.toConjAct ((σ : GL (Fin 2) ℝ))⁻¹ •
+      ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)))) :=
+    ⟨Subgroup.isCusp_of_mem_strictPeriods (wd_pos Γ) (natCast_mem_strictPeriods_translate Γ σ)⟩
+  have h := ModularFormClass.bdd_at_infty
+    (f := ModularForm.translate g (σ : GL (Fin 2) ℝ))
+  rwa [coe_translate_SL] at h
+
+private theorem exists_chart {N : ℕ} [NeZero N] {F : ℍ → ℂ}
+    (pF : Periodic (F ∘ ofComplex) N) (dF : MDiff F) (bF : IsBoundedAtImInfty F)
+    (hF0 : qExpansion N F ≠ 0) :
+    ∃ u : ℂ → ℂ, ContinuousAt u 0 ∧
+      u 0 = (qExpansion N F).coeff ((qExpansion N F).order.toNat) ∧ u 0 ≠ 0 ∧
+      ∀ τ : ℍ, F τ = Periodic.qParam N τ ^ ((qExpansion N F).order.toNat) *
+        u (Periodic.qParam N τ) := by
+  have hN : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  set P := qExpansion N F with hP
+  have hsummN : Summable fun n : ℕ => ‖P.coeff n‖ * (1 / 2 : ℝ) ^ n := by
+    let : FiniteDimensional ℝ ℂ := basisOneI.finiteDimensional_of_finite
+    have h1 : HasSum (fun n : ℕ => P.coeff n • ((1 / 2 : ℝ) : ℂ) ^ n)
+        (cuspFunction N F ((1 / 2 : ℝ) : ℂ)) :=
+      hasSum_qExpansion_of_norm_lt hN pF dF bF (by
+        rw [Complex.norm_real]
+        norm_num)
+    refine (summable_norm_iff.mpr h1.summable).congr fun n => ?_
+    rw [norm_smul, norm_pow, Complex.norm_real]
+    norm_num
+  have hsummShift : Summable fun j : ℕ => ‖P.coeff ((P.order.toNat) + j)‖ * (1 / 2 : ℝ) ^ j := by
+    have h1 : Summable fun j : ℕ =>
+        ‖P.coeff (j + P.order.toNat)‖ * (1 / 2 : ℝ) ^ (j + P.order.toNat) :=
+      (summable_nat_add_iff (f := fun n : ℕ => ‖P.coeff n‖ * (1 / 2 : ℝ) ^ n)
+        (P.order.toNat)).mpr hsummN
+    have h2 := h1.mul_right ((2 : ℝ) ^ P.order.toNat)
+    refine h2.congr fun j => ?_
+    have hpow : ((1 : ℝ) / 2) ^ P.order.toNat * (2 : ℝ) ^ P.order.toNat = 1 := by
+      rw [← mul_pow]
+      norm_num
+    rw [pow_add, add_comm j P.order.toNat]
+    linear_combination ‖P.coeff (P.order.toNat + j)‖ * ((1 : ℝ) / 2) ^ j * hpow
+  set u : ℂ → ℂ := fun z => ∑' j : ℕ, P.coeff (P.order.toNat + j) * z ^ j with hu
+  have hucont : ContinuousOn u (Metric.ball (0 : ℂ) (1 / 2)) := by
+    refine continuousOn_tsum (fun j => ?_) hsummShift fun j z hz => ?_
+    · exact (continuous_const.mul (continuous_pow j)).continuousOn
+    · rw [norm_mul, norm_pow]
+      gcongr
+      exact le_of_lt (by simpa [Metric.mem_ball, dist_zero_right] using hz)
+  have huCA : ContinuousAt u 0 :=
+    hucont.continuousAt (Metric.ball_mem_nhds _ (by norm_num))
+  have hu0 : u 0 = P.coeff (P.order.toNat) := by
+    have hval : u 0 = ∑' j : ℕ, P.coeff (P.order.toNat + j) * (0 : ℂ) ^ j := rfl
+    rw [hval, tsum_eq_single 0 fun j hj => by simp [zero_pow hj]]
+    simp
+  have hum : P.coeff (P.order.toNat) ≠ 0 := PowerSeries.coeff_order hF0
+  refine ⟨u, huCA, hu0, by rw [hu0]; exact hum, fun τ => ?_⟩
+  set z := Periodic.qParam (N : ℝ) (τ : ℂ) with hz
+  have hz1 : ‖z‖ < 1 := UpperHalfPlane.norm_qParam_lt_one N τ
+  have hz0 : z ≠ 0 := Complex.exp_ne_zero _
+  have hsum : HasSum (fun n : ℕ => P.coeff n • z ^ n) (F τ) :=
+    hasSum_qExpansion hN pF dF bF τ
+  have hshift : HasSum (fun j : ℕ => P.coeff (j + P.order.toNat) • z ^ (j + P.order.toNat))
+      (F τ) := by
+    have hvan : ∑ i ∈ Finset.range (P.order.toNat), P.coeff i • z ^ i = 0 := by
+      refine Finset.sum_eq_zero fun i hi => ?_
+      rw [PowerSeries.coeff_of_lt_order_toNat i (Finset.mem_range.mp hi), zero_smul]
+    have h4 := (hasSum_nat_add_iff' (P.order.toNat)).mpr hsum
+    rwa [hvan, sub_zero] at h4
+  have husum : HasSum (fun j : ℕ => P.coeff (P.order.toNat + j) * z ^ j)
+      (F τ / z ^ P.order.toNat) := by
+    have h2 : HasSum (fun j : ℕ => (P.coeff (P.order.toNat + j) * z ^ j) * z ^ P.order.toNat)
+        (F τ) := by
+      have heq : (fun j : ℕ => (P.coeff (P.order.toNat + j) * z ^ j) * z ^ P.order.toNat) =
+          fun j : ℕ => P.coeff (j + P.order.toNat) • z ^ (j + P.order.toNat) := by
+        funext j
+        rw [smul_eq_mul, pow_add, add_comm j (P.order.toNat)]
+        ring
+      rw [heq]
+      exact hshift
+    have h3 := h2.div_const (z ^ P.order.toNat)
+    have heq2 : (fun j : ℕ => P.coeff (P.order.toNat + j) * z ^ j * z ^ P.order.toNat /
+        z ^ P.order.toNat) = fun j : ℕ => P.coeff (P.order.toNat + j) * z ^ j := by
+      funext j
+      rw [mul_div_assoc, div_self (pow_ne_zero _ hz0), mul_one]
+    rwa [heq2] at h3
+  have huz : u z = F τ / z ^ P.order.toNat := husum.tsum_eq
+  rw [huz, mul_div_cancel₀ _ (pow_ne_zero _ hz0)]
+
+private theorem eventually_ne_zero_atImInfty {N : ℕ} [NeZero N] {F : ℍ → ℂ}
+    (pF : Periodic (F ∘ ofComplex) N) (dF : MDiff F) (bF : IsBoundedAtImInfty F)
+    (hF0 : qExpansion N F ≠ 0) : ∀ᶠ τ : ℍ in atImInfty, F τ ≠ 0 := by
+  have hN : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  obtain ⟨u, hu, -, hu0, hid⟩ := exists_chart pF dF bF hF0
+  have h1 : Tendsto (fun τ : ℍ => u (Periodic.qParam N τ)) atImInfty (𝓝 (u 0)) :=
+    hu.tendsto.comp (qParam_tendsto_atImInfty hN)
+  filter_upwards [h1.eventually_ne hu0] with τ hτ
+  rw [hid τ]
+  exact mul_ne_zero (pow_ne_zero _ (Complex.exp_ne_zero _)) hτ
+
+theorem qExpansion_slash_ne_zero
+    (h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (σ : SL(2, ℤ)) (hh : h ≠ 0) :
+    qExpansion (wd Γ) (⇑h ∣[k] σ) ≠ 0 := by
+  rw [Ne, qExpansion_eq_zero_iff (wd_pos Γ) (slash_periodic h σ) (slash_mdiff h σ)
+    (slash_bddAtImInfty h σ)]
+  intro h0
+  apply hh
+  have h1 : ⇑h = (0 : ℍ → ℂ) := by
+    have h2 := congrArg (· ∣[k] (σ⁻¹ : SL(2, ℤ))) h0
+    simpa only [SL_slash, ← SlashAction.slash_mul, ← map_mul, mul_inv_cancel, map_one,
+      SlashAction.slash_one, SlashAction.zero_slash] using h2
+  ext τ
+  rw [h1]
+  rfl
+
+end S3CuspLimit
+
+open S3CuspLimit
+
+namespace Glue
+
+open ModularCurve
+
+variable (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (σ : SL(2, ℤ))
+
+theorem eventually_apply_smul_ne_zero {k : ℤ}
+    (h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hh : h ≠ 0) :
+    ∀ᶠ τ in atImInfty, (h : ℍ → ℂ) (σ • τ) ≠ 0 := by
+  have key := S3CuspLimit.eventually_ne_zero_atImInfty (S3CuspLimit.slash_periodic h σ)
+    (S3CuspLimit.slash_mdiff h σ) (S3CuspLimit.slash_bddAtImInfty h σ)
+    (S3CuspLimit.qExpansion_slash_ne_zero h σ hh)
+  filter_upwards [key] with τ hτ hc
+  apply hτ
+  rw [SL_slash_apply, hc, zero_mul]
+
+theorem continuous_sl_smul : Continuous fun τ : ℍ => σ • τ := by
+  change Continuous fun τ : ℍ => ((σ : GL (Fin 2) ℝ) • τ)
+  exact continuous_const_smul _
+
+theorem punctured_nhds_neBot (τ : ℍ) : (𝓝[≠] τ).NeBot := by
+  rw [← not_not (a := (𝓝[≠] τ).NeBot), Filter.not_neBot, ← isOpen_singleton_iff_punctured_nhds]
+  intro hopen
+  have h1 : IsOpen ({(τ : ℂ)} : Set ℂ) := by
+    have := UpperHalfPlane.isOpenEmbedding_coe.isOpenMap _ hopen
+    simpa using this
+  rw [isOpen_singleton_iff_punctured_nhds] at h1
+  exact (inferInstance : (𝓝[≠] (τ : ℂ)).NeBot).ne h1
+
+theorem tendsto_coe_smul_punctured (τ : ℍ) :
+    Tendsto (fun w : ℍ => ((σ • w : ℍ) : ℂ)) (𝓝[≠] τ) (𝓝[≠] ((σ • τ : ℍ) : ℂ)) := by
+  have hc : Continuous fun w : ℍ => ((σ • w : ℍ) : ℂ) :=
+    UpperHalfPlane.continuous_coe.comp (continuous_sl_smul σ)
+  refine tendsto_nhdsWithin_iff.mpr ⟨hc.continuousAt.tendsto.mono_left nhdsWithin_le_nhds, ?_⟩
+  filter_upwards [self_mem_nhdsWithin] with w hw
+  intro hw'
+  apply hw
+  have h1 : σ • w = σ • τ := UpperHalfPlane.ext (Set.mem_singleton_iff.mp hw')
+  simpa using congrArg (fun z => σ⁻¹ • z) h1
+
+end Glue
+end Ws49.LIMTR
+end
+
+open Ws49.LIMTR in
+theorem solution
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ) {k : ℤ}
+    (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hh : h ≠ 0) (x : LaurentSeries ℂ)
+    (hx : x * ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) =
+      ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ))
+    (F : UpperHalfPlane → ℂ)
+    (hFx : ∀ τ : UpperHalfPlane, (fun z : ℂ => F (ofComplex z)) =ᶠ[𝓝[≠] (τ : ℂ)]
+      fun z : ℂ => ModularCurve.realizeOf Γ x (ofComplex z))
+    (hcusp : ∀ σ : SL(2, ℤ), ∃ L : ℂ, L ≠ 0 ∧
+      Filter.Tendsto (fun τ : UpperHalfPlane => F (σ • τ)) atImInfty (𝓝 L))
+    (σ : SL(2, ℤ)) :
+    ∃ L : ℂ, L ≠ 0 ∧
+      Filter.Tendsto (fun τ : UpperHalfPlane => (g : UpperHalfPlane → ℂ) (σ • τ) / (h :
+        UpperHalfPlane → ℂ) (σ • τ))
+        atImInfty (𝓝 L) := by
+  obtain ⟨L, hL, hF⟩ := hcusp σ
+  refine ⟨L, hL, ?_⟩
+  set G : UpperHalfPlane → ℂ := fun τ => (g : ℍ → ℂ) (σ • τ) / (h : ℍ → ℂ) (σ • τ) with hGdef
+  have hne : ∀ᶠ τ in atImInfty, (h : ℍ → ℂ) (σ • τ) ≠ 0 :=
+    Glue.eventually_apply_smul_ne_zero Γ σ h hh
+  have hloc : ∀ τ : ℍ, ∀ᶠ w in 𝓝[≠] τ, F (σ • w) = ModularCurve.realizeOf Γ x (σ • w) := by
+    intro τ
+    have h1 := (Glue.tendsto_coe_smul_punctured σ τ).eventually (hFx (σ • τ))
+    filter_upwards [h1] with w hw
+    simpa only [ofComplex_apply] using hw
+  rw [Metric.tendsto_nhds]
+  intro ε hε
+  have hFε : ∀ᶠ τ in atImInfty, dist (F (σ • τ)) L < ε / 2 :=
+    Metric.tendsto_nhds.mp hF (ε / 2) (half_pos hε)
+  obtain ⟨A, hA⟩ := (atImInfty_mem _).mp (hFε.and hne)
+  have hmem : {τ : ℍ | dist (G τ) L < ε} ∈ atImInfty := by
+    rw [atImInfty_mem]
+    refine ⟨A + 1, fun τ hτ => ?_⟩
+    have hτA : A < τ.im := by linarith
+    have hU : {w : ℍ | A < w.im} ∈ 𝓝 τ :=
+      (isOpen_lt continuous_const UpperHalfPlane.continuous_im).mem_nhds hτA
+    have hhτ : (h : ℍ → ℂ) (σ • τ) ≠ 0 := (hA τ hτA.le).2
+    have hcg : Continuous fun w : ℍ => (g : ℍ → ℂ) (σ • w) :=
+      (ModularFormClass.holo g).continuous.comp (Glue.continuous_sl_smul σ)
+    have hch : Continuous fun w : ℍ => (h : ℍ → ℂ) (σ • w) :=
+      (ModularFormClass.holo h).continuous.comp (Glue.continuous_sl_smul σ)
+    have hGcont : ContinuousAt G τ := (hcg.continuousAt).div (hch.continuousAt) hhτ
+    have hFG : ∀ᶠ w in 𝓝[≠] τ, F (σ • w) = G w := by
+      filter_upwards [hloc τ, mem_nhdsWithin_of_mem_nhds hU] with w h1 h2
+      rw [h1, hGdef]
+      exact ModularCurve.realizeOf_eq_div Γ hT g h x hx (σ • w) (hA w (le_of_lt h2)).2
+    have ht : Tendsto (fun w : ℍ => F (σ • w)) (𝓝[≠] τ) (𝓝 (G τ)) :=
+      (hGcont.tendsto.mono_left nhdsWithin_le_nhds).congr' (hFG.mono fun w hw => hw.symm)
+    have hev : ∀ᶠ w in 𝓝[≠] τ, dist (F (σ • w)) L ≤ ε / 2 := by
+      filter_upwards [mem_nhdsWithin_of_mem_nhds hU] with w hw
+      exact (hA w (le_of_lt hw)).1.le
+    have := Glue.punctured_nhds_neBot τ
+    have hle : dist (G τ) L ≤ ε / 2 := le_of_tendsto (ht.dist tendsto_const_nhds) hev
+    change dist (G τ) L < ε
+    linarith
+  exact hmem
+
+end S_ModularCurve_exists_tendsto_div_smul_of_eventuallyEq_realizeOf_of_tendsto
+end P2MW
+export P2MW.S_ModularCurve_exists_tendsto_div_smul_of_eventuallyEq_realizeOf_of_tendsto (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane
+open scoped MatrixGroups Topology
+theorem ModularCurve.exists_tendsto_div_smul_of_eventuallyEq_realizeOf_of_tendsto
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ) {k : ℤ}
+    (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hh : h ≠ 0) (x : LaurentSeries ℂ)
+    (hx : x * ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) =
+      ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ))
+    (F : UpperHalfPlane → ℂ)
+    (hFx : ∀ τ : UpperHalfPlane, (fun z : ℂ => F (ofComplex z)) =ᶠ[𝓝[≠] (τ : ℂ)]
+      fun z : ℂ => ModularCurve.realizeOf Γ x (ofComplex z))
+    (hcusp : ∀ σ : SL(2, ℤ), ∃ L : ℂ, L ≠ 0 ∧
+      Filter.Tendsto (fun τ : UpperHalfPlane => F (σ • τ)) atImInfty (𝓝 L))
+    (σ : SL(2, ℤ)) :
+    ∃ L : ℂ, L ≠ 0 ∧
+      Filter.Tendsto (fun τ : UpperHalfPlane => (g : UpperHalfPlane → ℂ) (σ • τ) / (h :
+        UpperHalfPlane → ℂ) (σ • τ))
+        atImInfty (𝓝 L) :=
+  solution Γ hT g h hh x hx F hFx hcusp σ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_tendsto_realizeOf_mul_exp_of_not_mem_toValuationSubring.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_tendsto_realizeOf_mul_exp_of_not_mem_toValuationSubring.lean
new file mode 100644
index 0000000000..e9650d2e97
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_tendsto_realizeOf_mul_exp_of_not_mem_toValuationSubring.lean
@@ -0,0 +1,232 @@
+/-
+Based on Prove2Me node ModularCurve.exists_tendsto_realizeOf_mul_exp_of_not_mem_toValuationSubring
+(8ab946e0-e067-54ac-b90a-97407421e88b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f4b0bffd-d4ec-55bc-8f9e-788e88be4f3d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ComplexPlaceDictionaryOf
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_apply_eq_of_forall_ord_eq_zero_tendsto_realizeOf
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_ringHom_place_order_eq_mul_ord_of_qExpansion_slash
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_eq_neg_width_of_order_eq_mul_ord_of_qExpansion_slash
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_realizeOf_eq_div
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cusp places of X(Γ): width, ord_P y = -h, and limits
+
+Theorem statement: `ModularCurve.exists_tendsto_realizeOf_mul_exp_of_not_mem_toValuationSubring`
+(`8ab946e0-e067-54ac-b90a-97407421e88b`), by Claude, 2026-09-05.
+
+Proof: submission `f4b0bffd-d4ec-55bc-8f9e-788e88be4f3d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma \le \mathrm{SL}_2(\mathbb{Z})$ be of finite index, containing the translation matrix
+`ModularGroup.T`, and satisfying the predicate `CongruenceSubgroup.IsCongruenceSubgroup`. Let $F_0$
+be an intermediate field of $\mathbb{Q} \subset \mathbb{Q}((q))$ equal to `qExpFunctionFieldC ℚ Γ`,
+the subfield generated over $\mathbb{Q}$ by the quotients $p_f/p_g$ of integral $q$-expansions of
+pairs of modular forms of a common weight for $\Gamma$ (with $p_g \neq 0$), and let $F =$
+`laurentBaseChange ℂ F₀` be the subfield of $\mathbb{C}((q))$ generated over $\mathbb{C}$ by the
+image of $F_0$ under the coefficientwise map induced by $\mathbb{Q} \to \mathbb{C}$. Let $y \in F$
+have underlying Laurent series `jqModC ℂ`, namely $q^{-1}$ times the power series $E_4^3 \cdot
+\eta^{-24}$-type numerator `jNum` with coefficients mapped into $\mathbb{C}$, and assume the degree
+guard that $F$ has rank over $\mathbb{C}(y)$ equal to the index of $\Gamma \sqcup \langle -1\rangle$
+in $\mathrm{SL}_2(\mathbb{Z})$. Finally let $P$ be a place of $F$ over $\mathbb{C}$, i.e. a proper
+valuation subring of $F$ containing $\mathbb{C}$ and a principal ideal ring, with $y \notin P$'s
+valuation subring. Then there exist $\sigma \in \mathrm{SL}_2(\mathbb{Z})$ and $h \in \mathbb{N}$
+with $h > 0$ such that $\sigma T^h \sigma^{-1} \in \Gamma \sqcup \langle -1 \rangle$,
+$\operatorname{ord}_P(y) = -h$ (where $\operatorname{ord}_P$ is minus the logarithm of the adic
+valuation attached to $P$), and for every nonzero $x \in F$ there is $L \neq 0$ with
+$\operatorname{realizeOf}_\Gamma(x)(\sigma \cdot \tau)\, \exp(-2\pi i \operatorname{ord}_P(x) \tau /
+h) \to L$ as $\operatorname{Im} \tau \to \infty$; here $\operatorname{realizeOf}_\Gamma(x)$ is the
+function on $\mathbb{H}$ given by $g/h'$ for some pair of weight-$k$ forms $g,h'$ for $\Gamma$ with
+$x \cdot q\text{-exp}(h') = q\text{-exp}(g)$ and $h'$ nonvanishing at the point, and $0$ if no such
+pair exists.
+
+This is the dictionary between places of the function field of $X(\Gamma)$ lying over the cusps and
+the cusps $\sigma\infty$ of $\mathbb{H}^*$: such a place is read off at some $\sigma \in
+\mathrm{SL}_2(\mathbb{Z})$, its width $h$ is the least positive exponent with $\sigma T^h\sigma^{-1}
+\in \pm\Gamma$, the order of $j$ at it is $-h$, and $\operatorname{ord}_P$ computes the leading
+exponent in the $q^{1/h}$-expansion of $x|\sigma$. It feeds the parity statement
+[`ModularCurve.even_ord_add_ord_of_not_mem_toValuationSubring_laurentBaseChange_gamma1`]
+(thm.html#ModularCurve.even_ord_add_ord_of_not_mem_toValuationSubring_laurentBaseChange_gamma1)
+about orders at cusp places of $X_1(M)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_tendsto_realizeOf_mul_exp_of_not_mem_toValuationSubring.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_exists_tendsto_realizeOf_mul_exp_of_not_mem_toValuationSubring
+
+open CongruenceSubgroup ModularCurve UpperHalfPlane
+open scoped MatrixGroups ModularForm Topology
+
+namespace L2aGlue
+
+theorem realizeOf_smul (Γ : Subgroup SL(2, ℤ)) (hT : ModularGroup.T ∈ Γ) (x : LaurentSeries ℂ)
+    {γ : SL(2, ℤ)} (hγ : γ ∈ Γ) (τ : ℍ) :
+    realizeOf Γ x (γ • τ) = realizeOf Γ x τ := by
+  classical
+  have hden : ∀ (k : ℤ) (h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k),
+      (h : ℍ → ℂ) (γ • τ) = (denom (γ : GL (Fin 2) ℝ) τ) ^ k * (h : ℍ → ℂ) τ :=
+    fun k h => SlashInvariantForm.slash_action_eqn_SL'' h hγ τ
+  have hd0 : denom (γ : GL (Fin 2) ℝ) τ ≠ 0 := denom_ne_zero _ _
+  by_cases H : ∃ p : (k : ℤ) × (ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k × ModularForm (Γ :
+    Subgroup (GL (Fin 2) ℝ)) k),
+      (p.2.2 : ℍ → ℂ) τ ≠ 0 ∧
+        x * ((qExpansion 1 (p.2.2 : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+          ((qExpansion 1 (p.2.1 : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+  · obtain ⟨⟨k, g, h⟩, hτ, hx⟩ := H
+    have hγτ : (h : ℍ → ℂ) (γ • τ) ≠ 0 := by
+      rw [hden k h]; exact mul_ne_zero (zpow_ne_zero _ hd0) hτ
+    rw [realizeOf_eq_div Γ hT g h x hx (γ • τ) hγτ, realizeOf_eq_div Γ hT g h x hx τ hτ, hden k g,
+      hden k h,
+      mul_div_mul_left _ _ (zpow_ne_zero _ hd0)]
+  · have H' : ¬ ∃ p : (k : ℤ) × (ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k × ModularForm (Γ :
+      Subgroup (GL (Fin 2) ℝ)) k),
+        (p.2.2 : ℍ → ℂ) (γ • τ) ≠ 0 ∧
+          x * ((qExpansion 1 (p.2.2 : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+            ((qExpansion 1 (p.2.1 : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) := by
+      rintro ⟨⟨k, g, h⟩, hγτ, hx⟩
+      refine H ⟨⟨k, g, h⟩, ?_, hx⟩
+      intro h0
+      apply hγτ
+      change (h : ℍ → ℂ) (γ • τ) = 0
+      rw [hden k h, h0, mul_zero]
+    rw [realizeOf_def, realizeOf_def, dite_eq_right H, dite_eq_right H']
+
+end L2aGlue
+
+open L2aGlue in
+theorem solution
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    (hΓ : CongruenceSubgroup.IsCongruenceSubgroup Γ)
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (hF : F₀ = ModularCurve.qExpFunctionFieldC ℚ Γ)
+    (y : ↥(ModularCurve.laurentBaseChange ℂ F₀))
+    (hy : (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ)
+    (hdeg : Module.finrank
+        ↥(IntermediateField.adjoin ℂ ({y} : Set ↥(ModularCurve.laurentBaseChange ℂ F₀)))
+        ↥(ModularCurve.laurentBaseChange ℂ F₀) =
+      (Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index)
+    (P : AlgebraicCurve.Place ℂ ↥(ModularCurve.laurentBaseChange ℂ F₀))
+    (hP : y ∉ P.toValuationSubring) :
+    ∃ (σ : SL(2, ℤ)) (h : ℕ), 0 < h ∧
+      σ * ModularGroup.T ^ h * σ⁻¹ ∈ Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) ∧
+      P.ord y = -(h : ℤ) ∧
+      ∀ x : ↥(ModularCurve.laurentBaseChange ℂ F₀), x ≠ 0 → ∃ L : ℂ, L ≠ 0 ∧
+        Filter.Tendsto
+          (fun τ : UpperHalfPlane => ModularCurve.realizeOf Γ (x : LaurentSeries ℂ) (σ • τ) *
+            Complex.exp (-(2 * Real.pi * Complex.I * (P.ord x : ℂ) * (τ : ℂ) / (h : ℂ))))
+          UpperHalfPlane.atImInfty (nhds L) := by
+  classical
+  have : Γ.normalCore.FiniteIndex := inferInstance
+  have hR := fun σ : SL(2, ℤ) =>
+    ModularCurve.exists_ringHom_place_order_eq_mul_ord_of_qExpansion_slash Γ hT F₀ hF σ
+  choose Φ Pl e he hE2 hE3 hpres hconst hord hyc hE1 using hR
+  have hΓPl : ∀ γ ∈ Γ, ∀ σ : SL(2, ℤ), Pl (γ * σ) = Pl σ := by
+    intro γ hγ σ
+    apply AlgebraicCurve.Place.ext
+    ext x
+    rw [hE3 (γ * σ) x, hE3 σ x]
+    simp only [mul_smul, realizeOf_smul Γ hT _ hγ]
+  have hlim : ∀ (σ : SL(2, ℤ)) (x : ↥(ModularCurve.laurentBaseChange ℂ F₀)), x ≠ 0 → (Pl σ).ord x =
+    0 →
+      ∃ L : ℂ, L ≠ 0 ∧
+        Filter.Tendsto (fun τ : ℍ => ModularCurve.realizeOf Γ (x : LaurentSeries ℂ) (σ • τ))
+          atImInfty (𝓝 L) := by
+    intro σ x hx h0
+    obtain ⟨L, hL, ht⟩ := hE1 σ x hx
+    refine ⟨L, hL, ht.congr fun τ => ?_⟩
+    rw [h0]
+    simp
+  obtain ⟨σ, hσ⟩ :=
+    ModularCurve.exists_apply_eq_of_forall_ord_eq_zero_tendsto_realizeOf Γ hT hΓ F₀ hF y hy
+    Pl hΓPl hlim P hP
+  subst hσ
+  have hN : σ * ModularGroup.T ^ Γ.normalCore.index * σ⁻¹ ∈ Γ := by
+    have h1 : (σ * ModularGroup.T * σ⁻¹) ^ Γ.normalCore.index ∈ Γ.normalCore :=
+      Subgroup.pow_index_mem _ _
+    rw [conj_pow] at h1
+    exact Γ.normalCore_le h1
+  have hNpos : 0 < Γ.normalCore.index := Nat.pos_of_ne_zero Subgroup.FiniteIndex.index_ne_zero
+  have hex : ∃ k : ℕ, 0 < k ∧ σ * ModularGroup.T ^ k * σ⁻¹ ∈ Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) :=
+    ⟨_, hNpos, Subgroup.mem_sup_left hN⟩
+  set h := Nat.find hex with hh_def
+  have hh : 0 < h := (Nat.find_spec hex).1
+  have hmem : σ * ModularGroup.T ^ h * σ⁻¹ ∈ Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) :=
+    (Nat.find_spec hex).2
+  have hmin : ∀ k : ℕ, 0 < k → σ * ModularGroup.T ^ k * σ⁻¹ ∈ Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) →
+    h ≤ k :=
+    fun k hk hk' => Nat.find_min' hex ⟨hk, hk'⟩
+  have hyN : (e σ : ℤ) * (Pl σ).ord y = -(Γ.normalCore.index : ℤ) := (hyc σ y hy).2.1
+  have hyh : (Pl σ).ord y = -(h : ℤ) :=
+    ModularCurve.ord_eq_neg_width_of_order_eq_mul_ord_of_qExpansion_slash Γ hT hΓ F₀ hF y hy σ (Φ σ)
+      (Pl σ) (e σ)
+      (he σ) (hpres σ) (hord σ) (hyc σ y hy).1 hdeg h hh hmem hmin
+  have heh : ((e σ : ℕ) : ℂ) * (h : ℂ) = (Γ.normalCore.index : ℂ) := by
+    have h1 : (e σ : ℤ) * (h : ℤ) = (Γ.normalCore.index : ℤ) := by rw [hyh] at hyN; linarith
+    exact_mod_cast h1
+  refine ⟨σ, h, hh, hmem, hyh, fun x hx => ?_⟩
+  obtain ⟨L, hL, ht⟩ := hE1 σ x hx
+  refine ⟨L, hL, ht.congr fun τ => ?_⟩
+  have hhC : (h : ℂ) ≠ 0 := by exact_mod_cast hh.ne'
+  have hNC : (Γ.normalCore.index : ℂ) ≠ 0 := by exact_mod_cast hNpos.ne'
+  have heC : ((e σ : ℕ) : ℂ) ≠ 0 := by exact_mod_cast (he σ).ne'
+  congr 2
+  rw [← heh]
+  push_cast
+  field_simp
+
+end S_ModularCurve_exists_tendsto_realizeOf_mul_exp_of_not_mem_toValuationSubring
+end P2MW
+export P2MW.S_ModularCurve_exists_tendsto_realizeOf_mul_exp_of_not_mem_toValuationSubring (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open CongruenceSubgroup ModularCurve
+open scoped MatrixGroups ModularForm
+theorem ModularCurve.exists_tendsto_realizeOf_mul_exp_of_not_mem_toValuationSubring
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    (hΓ : CongruenceSubgroup.IsCongruenceSubgroup Γ)
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (hF : F₀ = ModularCurve.qExpFunctionFieldC ℚ Γ)
+    (y : ↥(ModularCurve.laurentBaseChange ℂ F₀))
+    (hy : (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ)
+    (hdeg : Module.finrank
+        ↥(IntermediateField.adjoin ℂ ({y} : Set ↥(ModularCurve.laurentBaseChange ℂ F₀)))
+        ↥(ModularCurve.laurentBaseChange ℂ F₀) =
+      (Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index)
+    (P : AlgebraicCurve.Place ℂ ↥(ModularCurve.laurentBaseChange ℂ F₀))
+    (hP : y ∉ P.toValuationSubring) :
+    ∃ (σ : SL(2, ℤ)) (h : ℕ), 0 < h ∧
+      σ * ModularGroup.T ^ h * σ⁻¹ ∈ Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) ∧
+      P.ord y = -(h : ℤ) ∧
+      ∀ x : ↥(ModularCurve.laurentBaseChange ℂ F₀), x ≠ 0 → ∃ L : ℂ, L ≠ 0 ∧
+        Filter.Tendsto
+          (fun τ : UpperHalfPlane => ModularCurve.realizeOf Γ (x : LaurentSeries ℂ) (σ • τ) *
+            Complex.exp (-(2 * Real.pi * Complex.I * (P.ord x : ℂ) * (τ : ℂ) / (h : ℂ))))
+          UpperHalfPlane.atImInfty (nhds L) :=
+  solution Γ hT hΓ F₀ hF y hy hdeg P hP
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_transcendental_finiteDimensional_qExpFunctionFieldC_residueField.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_transcendental_finiteDimensional_qExpFunctionFieldC_residueField.lean
new file mode 100644
index 0000000000..cb1a8325cb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_exists_transcendental_finiteDimensional_qExpFunctionFieldC_residueField.lean
@@ -0,0 +1,1125 @@
+/-
+Based on Prove2Me node
+ModularCurve.exists_transcendental_finiteDimensional_qExpFunctionFieldC_residueField
+(7fabc00c-6c36-50e8-b2c2-880239cc5eb8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e8a85cf3-1184-556b-9641-b0edb52dd92f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Data.Finset.Functor
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0ModL
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_JOneES_exists_transcendental_finiteDimensional_laurentBaseChange
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_mem_intFormRatiosC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Deuring's inequality for reduced q-expansion function fields
+
+Theorem statement:
+`ModularCurve.exists_transcendental_finiteDimensional_qExpFunctionFieldC_residueField`
+(`7fabc00c-6c36-50e8-b2c2-880239cc5eb8`), by Claude, 2026-09-05.
+
+Proof: submission `e8a85cf3-1184-556b-9641-b0edb52dd92f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbb{Q}$-algebra structure, let $A \subseteq L$ be a
+valuation subring, write $k =$ `IsLocalRing.ResidueField A` for its residue field, and let $\Gamma
+\le \mathrm{SL}_2(\mathbb{Z})$ be a subgroup of finite index with $T =
+\begin{pmatrix}1&1\\0&1\end{pmatrix} \in \Gamma$. For a field $K$, [`ModularCurve.qExpFunctionFieldC
+K Γ`](def/ModularCurve_X1.html#L101) denotes the intermediate field of $K((q))$ generated over $K$
+by the ratios $\mathrm{intSeriesC}\,K\,p_f / \mathrm{intSeriesC}\,K\,p_g$, where $f,g$ are modular
+forms of one and the same weight on $\Gamma$ (viewed inside $\mathrm{GL}_2(\mathbb{R})$) with
+integral $q$-expansions $p_f,p_g$ in the sense of `IsIntegralQExp`, and $\mathrm{intSeriesC}\,K\,p_g
+\ne 0$; and [`ModularCurve.jqModC K`](def/ModularCurve_JqCoeff.html#L15) is the Laurent series
+$q^{-1}$ times the image in $K$ of $\mathrm{jNum} = E_4^3 \cdot \mathrm{dedekindEtaUnitInv} \in
+\mathbb{Z}[[q]]$. The assertion is that there is an element $x$ of [`ModularCurve.qExpFunctionFieldC
+k Γ`](def/ModularCurve_X1.html#L101) whose underlying Laurent series is [`ModularCurve.jqModC
+k`](def/ModularCurve_JqCoeff.html#L15), such that $x$ is transcendental over $k$, such that
+[`ModularCurve.qExpFunctionFieldC k Γ`](def/ModularCurve_X1.html#L101) is finite-dimensional over
+the subfield $k(x)$, and such that for every element $y$ of [`ModularCurve.laurentBaseChange L
+(ModularCurve.qExpFunctionFieldC ℚ Γ)`](def/ModularCurve_LaurentCoeff.html#L103) — the subfield of
+$L((q))$ generated over $L$ by the coefficientwise image of [`ModularCurve.qExpFunctionFieldC ℚ
+Γ`](def/ModularCurve_X1.html#L101) — whose underlying Laurent series is [`ModularCurve.jqModC
+L`](def/ModularCurve_JqCoeff.html#L15), one has $[\,$`qExpFunctionFieldC k Γ`$: k(x)] \le
+[\,$`laurentBaseChange L (qExpFunctionFieldC ℚ Γ)`$: L(y)]$.
+
+This is Deuring's inequality for the reduction of the $q$-expansion function field of $X(\Gamma)$ at
+an arbitrary place of the field of constants: the reduced field is again an algebraic function field
+of one variable over the residue field, finite over $k(\bar\jmath)$ of degree at most the generic
+degree, with no restriction on the residue characteristic relative to the level. It supplies the
+one-variable function field structure on the special fibre used throughout the specialisation and
+prolongation arguments that produce models of the modular curves and of their Hecke correspondences.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_exists_transcendental_finiteDimensional_qExpFunctionFieldC_residueField.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_560e3206
+
+
+noncomputable section
+
+open scoped Classical
+open IntermediateField ModularCurve Polynomial
+
+namespace QExpDeuring
+
+section Coeff
+
+variable {L : Type*} [Field L] (A : ValuationSubring L)
+
+abbrev ι : LaurentSeries A →+* LaurentSeries L := coeffMap A.subtype
+
+abbrev ϖ : LaurentSeries A →+* LaurentSeries (IsLocalRing.ResidueField A) :=
+  coeffMap (IsLocalRing.residue A)
+
+theorem ι_injective : Function.Injective (ι A) := by
+  intro x y h
+  ext n
+  have h1 := congrArg (fun s : LaurentSeries L => s.coeff n) h
+  simp only [coeffMap_coeff] at h1
+  exact h1
+
+theorem ι_eq_zero_iff (x : LaurentSeries A) : ι A x = 0 ↔ x = 0 := by
+  rw [← map_zero (ι A)]; exact (ι_injective A).eq_iff
+
+theorem ϖ_eq_zero_iff (y : LaurentSeries A) :
+    ϖ A y = 0 ↔ ∀ n, y.coeff n ∈ IsLocalRing.maximalIdeal A := by
+  constructor
+  · intro h n
+    have h1 := congrArg (fun s : LaurentSeries (IsLocalRing.ResidueField A) => s.coeff n) h
+    simp only [coeffMap_coeff, HahnSeries.coeff_zero] at h1
+    exact (IsLocalRing.residue_eq_zero_iff _).mp h1
+  · intro h
+    ext n
+    simp only [coeffMap_coeff, HahnSeries.coeff_zero]
+    exact (IsLocalRing.residue_eq_zero_iff _).mpr (h n)
+
+theorem ι_C (a : A) : ι A (HahnSeries.C a) = algebraMap L (LaurentSeries L) (a : L) := by
+  rw [HahnSeries.C_apply, coeffMap_single, algebraMap_laurentSeries_eq_single]; rfl
+
+theorem ϖ_C (a : A) : ϖ A (HahnSeries.C a) =
+    algebraMap (IsLocalRing.ResidueField A) (LaurentSeries (IsLocalRing.ResidueField A))
+      (IsLocalRing.residue A a) := by
+  rw [HahnSeries.C_apply, coeffMap_single, algebraMap_laurentSeries_eq_single]
+
+def intSeriesA (p : PowerSeries ℤ) : LaurentSeries A :=
+  HahnSeries.ofPowerSeries ℤ A (p.map (Int.castRingHom A))
+
+theorem coeffMap_intSeries {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S) (p : PowerSeries ℤ)
+    :
+    coeffMap f (HahnSeries.ofPowerSeries ℤ R (p.map (Int.castRingHom R))) =
+      HahnSeries.ofPowerSeries ℤ S (p.map (Int.castRingHom S)) := by
+  rw [coeffMap_ofPowerSeries]
+  congr 1
+  ext n
+  simp [PowerSeries.coeff_map]
+
+theorem ι_intSeriesA (p : PowerSeries ℤ) : ι A (intSeriesA A p) = intSeriesC L p :=
+  coeffMap_intSeries _ p
+
+theorem ϖ_intSeriesA (p : PowerSeries ℤ) :
+    ϖ A (intSeriesA A p) = intSeriesC (IsLocalRing.ResidueField A) p :=
+  coeffMap_intSeries _ p
+
+theorem coeffEmb_intSeriesC [Algebra ℚ L] (p : PowerSeries ℤ) :
+    coeffEmb L (intSeriesC ℚ p) = intSeriesC L p :=
+  coeffMap_intSeries _ p
+
+def IsInt (f : LaurentSeries L) : Prop :=
+  ∃ x y : LaurentSeries A, ϖ A y ≠ 0 ∧ f * ι A y = ι A x
+
+variable {A}
+
+theorem ϖ_ne_zero_ne_zero {y : LaurentSeries A} (hy : ϖ A y ≠ 0) : y ≠ 0 := by
+  rintro rfl; exact hy (map_zero _)
+
+theorem IsInt.zero : IsInt A (0 : LaurentSeries L) := ⟨0, 1, by simp, by simp⟩
+
+theorem IsInt.one : IsInt A (1 : LaurentSeries L) := ⟨1, 1, by simp, by simp⟩
+
+theorem IsInt.mul {f g : LaurentSeries L} (hf : IsInt A f) (hg : IsInt A g) : IsInt A (f * g) := by
+  obtain ⟨x, y, hy, h⟩ := hf
+  obtain ⟨x', y', hy', h'⟩ := hg
+  refine ⟨x * x', y * y', by rw [map_mul]; exact mul_ne_zero hy hy', ?_⟩
+  rw [map_mul, map_mul, ← h, ← h']; ring
+
+theorem IsInt.add {f g : LaurentSeries L} (hf : IsInt A f) (hg : IsInt A g) : IsInt A (f + g) := by
+  obtain ⟨x, y, hy, h⟩ := hf
+  obtain ⟨x', y', hy', h'⟩ := hg
+  refine ⟨x * y' + x' * y, y * y', by rw [map_mul]; exact mul_ne_zero hy hy', ?_⟩
+  rw [map_mul, map_add, map_mul, map_mul, ← h, ← h']; ring
+
+theorem IsInt.neg {f : LaurentSeries L} (hf : IsInt A f) : IsInt A (-f) := by
+  obtain ⟨x, y, hy, h⟩ := hf
+  exact ⟨-x, y, hy, by rw [map_neg, ← h]; ring⟩
+
+theorem IsInt.cross {f : LaurentSeries L} {x y x' y' : LaurentSeries A}
+    (h : f * ι A y = ι A x) (h' : f * ι A y' = ι A x') : x * y' = x' * y := by
+  apply ι_injective A
+  rw [map_mul, map_mul, ← h, ← h']; ring
+
+theorem IsInt.inv_of {f : LaurentSeries L} {x y : LaurentSeries A} (hx : ϖ A x ≠ 0)
+    (h : f * ι A y = ι A x) : f⁻¹ * ι A x = ι A y := by
+  have hf : f ≠ 0 := by
+    rintro rfl
+    rw [zero_mul, eq_comm, ι_eq_zero_iff] at h
+    exact hx (by rw [h, map_zero])
+  rw [← h, ← mul_assoc, inv_mul_cancel₀ hf, one_mul]
+
+end Coeff
+
+section Scaling
+
+variable {L : Type*} [Field L] (A : ValuationSubring L)
+
+theorem exists_coeffMap_subtype_eq (x : LaurentSeries L) (hx : ∀ n, x.coeff n ∈ A) :
+    ∃ y : LaurentSeries A, ι A y = x := by
+  refine ⟨⟨fun n => ⟨x.coeff n, hx n⟩, ?_⟩, ?_⟩
+  · convert x.isPWO_support' using 1
+    ext n
+    simp only [Function.mem_support, ne_eq, Subtype.ext_iff, ZeroMemClass.coe_zero]
+  · ext n
+    rfl
+
+theorem valuation_le_of_mem_span (T : Finset L) (c : L)
+    (hc : ∀ t ∈ T, A.valuation t ≤ A.valuation c)
+    {x : L} (hx : x ∈ Submodule.span ℤ (T : Set L)) : A.valuation x ≤ A.valuation c := by
+  induction hx using Submodule.span_induction with
+  | mem x h => exact hc x h
+  | zero => simp
+  | add x y _ _ hx hy => exact (Valuation.map_add _ _ _).trans (max_le hx hy)
+  | smul m x _ hx =>
+      rw [zsmul_eq_mul, map_mul]
+      calc A.valuation (m : L) * A.valuation x ≤ 1 * A.valuation c :=
+            mul_le_mul' ((A.valuation_le_one_iff _).mpr (intCast_mem A m)) hx
+        _ = A.valuation c := one_mul _
+
+theorem exists_primitive_scaling {x : LaurentSeries L} (hx : x ≠ 0) (M : Submodule ℤ L) (hM : M.FG)
+    (hxM : ∀ n, x.coeff n ∈ M) :
+    ∃ c : L, c ≠ 0 ∧ (∀ n, c⁻¹ * x.coeff n ∈ A) ∧ ∃ n₀, c⁻¹ * x.coeff n₀ = 1 := by
+  set N' : Submodule ℤ L := Submodule.span ℤ (Set.range x.coeff) with hN'
+  have hle : N' ≤ M := Submodule.span_le.mpr (by rintro _ ⟨n, rfl⟩; exact hxM n)
+  have hfg : N'.FG := (isNoetherian_submodule.mp (isNoetherian_of_fg_of_noetherian M hM)) N' hle
+  obtain ⟨T, hTsub, hTspan⟩ : ∃ T : Finset L, (↑T ⊆ Set.range x.coeff) ∧
+      Submodule.span ℤ (T : Set L) = N' := by
+    obtain ⟨S, hS⟩ := hfg
+    have hmem : ∀ s ∈ S, ∃ T : Finset L, ↑T ⊆ Set.range x.coeff ∧
+        s ∈ Submodule.span ℤ (T : Set L) := fun s hs =>
+      Submodule.mem_span_finite_of_mem_span (by rw [← hN', ← hS]; exact Submodule.subset_span hs)
+    choose! Tf hTf₁ hTf₂ using hmem
+    refine ⟨S.biUnion Tf, ?_, le_antisymm ?_ ?_⟩
+    · simp only [Finset.coe_biUnion, Set.iUnion_subset_iff]
+      exact fun s hs => hTf₁ s hs
+    · exact Submodule.span_le.mpr fun t ht => by
+        obtain ⟨s, hs, hts⟩ := Finset.mem_biUnion.mp ht
+        exact Submodule.subset_span (hTf₁ s hs hts)
+    · rw [← hS]
+      refine Submodule.span_le.mpr fun s hs => ?_
+      have h := hTf₂ s hs
+      exact Submodule.span_mono (by
+        intro t ht
+        exact Finset.mem_biUnion.mpr ⟨s, hs, ht⟩) h
+  obtain ⟨n₁, hn₁⟩ : ∃ n, x.coeff n ≠ 0 := by
+    by_contra h
+    push Not at h
+    exact hx (by ext n; simpa using h n)
+  have hcoeffN' : ∀ n, x.coeff n ∈ Submodule.span ℤ (T : Set L) := fun n => by
+    rw [hTspan]; exact Submodule.subset_span ⟨n, rfl⟩
+  have hTne : T.Nonempty := by
+    rw [Finset.nonempty_iff_ne_empty]
+    rintro rfl
+    apply hn₁
+    simpa using hcoeffN' n₁
+  obtain ⟨c, hcT, hcmax⟩ := Finset.exists_max_image T A.valuation hTne
+  have hvx : ∀ n, A.valuation (x.coeff n) ≤ A.valuation c := fun n =>
+    valuation_le_of_mem_span A T c hcmax (hcoeffN' n)
+  have hc0 : c ≠ 0 := by
+    intro hc
+    have h := hvx n₁
+    rw [hc, map_zero, le_zero_iff, map_eq_zero] at h
+    exact hn₁ h
+  obtain ⟨n₀, hn₀⟩ := hTsub hcT
+  refine ⟨c, hc0, fun n => ?_, n₀, by rw [hn₀, inv_mul_cancel₀ hc0]⟩
+  rw [← A.valuation_le_one_iff, map_mul, map_inv₀]
+  have hc' : A.valuation c ≠ 0 := by simpa using hc0
+  rw [inv_mul_le_one₀ (zero_lt_iff.mpr hc')]
+  exact hvx n
+
+theorem exists_primitive_form {x : LaurentSeries L} (hx : x ≠ 0) (M : Submodule ℤ L) (hM : M.FG)
+    (hxM : ∀ n, x.coeff n ∈ M) :
+    ∃ c : L, c ≠ 0 ∧ ∃ x₀ : LaurentSeries A, ϖ A x₀ ≠ 0 ∧
+      x = algebraMap L (LaurentSeries L) c * ι A x₀ := by
+  obtain ⟨c, hc0, hcA, n₀, hn₀⟩ := exists_primitive_scaling A hx M hM hxM
+  have hcoeff : ∀ n, (algebraMap L (LaurentSeries L) c⁻¹ * x).coeff n = c⁻¹ * x.coeff n :=
+    fun n => by
+    rw [algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_zero_mul]
+  obtain ⟨y, hy⟩ :=
+    exists_coeffMap_subtype_eq A (algebraMap L (LaurentSeries L) c⁻¹ * x) fun n => by
+    rw [hcoeff]; exact hcA n
+  refine ⟨c, hc0, y, ?_, ?_⟩
+  · intro h
+    have h1 := congrArg (fun s : LaurentSeries (IsLocalRing.ResidueField A) => s.coeff n₀) h
+    simp only [coeffMap_coeff, HahnSeries.coeff_zero] at h1
+    have h2 : (y.coeff n₀ : L) = 1 := by
+      have := congrArg (fun s : LaurentSeries L => s.coeff n₀) hy
+      simp only [coeffMap_coeff, hcoeff] at this
+      rw [← hn₀]; exact this
+    have h3 : y.coeff n₀ = 1 := Subtype.ext (by simpa using h2)
+    rw [h3, map_one] at h1
+    exact one_ne_zero h1
+  · rw [hy, ← mul_assoc, ← map_mul, mul_inv_cancel₀ hc0, map_one, one_mul]
+
+end Scaling
+
+section Generators
+
+variable (L : Type*) [Field L] [Algebra ℚ L] (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+
+local notation "FF" => laurentBaseChange L (qExpFunctionFieldC ℚ Γ)
+
+def gensZ : Set (LaurentSeries L) :=
+  {x | ∃ (k : ℤ) (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (p : PowerSeries ℤ),
+    IsIntegralQExp f p ∧ x = intSeriesC L p}
+
+theorem laurentBaseChange_le_adjoin_gensZ : FF ≤ adjoin L (gensZ L Γ) := by
+  change adjoin L _ ≤ adjoin L (gensZ L Γ)
+  rw [adjoin_le_iff]
+  rintro _ ⟨x, hx, rfl⟩
+  have hx' : x ∈ Subfield.closure (Set.range (algebraMap ℚ (LaurentSeries ℚ)) ∪ intFormRatiosC ℚ Γ)
+    :=
+    hx
+  have hmap : coeffEmb L x ∈ (Subfield.closure
+      (Set.range (algebraMap ℚ (LaurentSeries ℚ)) ∪ intFormRatiosC ℚ Γ)).map (coeffEmb L) :=
+    ⟨x, hx', rfl⟩
+  rw [RingHom.map_field_closure] at hmap
+  refine (Subfield.closure_le.mpr ?_) hmap
+  rintro _ ⟨z, hz | hz, rfl⟩
+  · obtain ⟨c, rfl⟩ := hz
+    rw [algebraMap_apply_eq_single]
+    change coeffMap (algebraMap ℚ L) (HahnSeries.single 0 c) ∈ adjoin L (gensZ L Γ)
+    rw [coeffMap_single, ← algebraMap_laurentSeries_eq_single]
+    exact (adjoin L (gensZ L Γ)).algebraMap_mem _
+  · obtain ⟨k, f, g, pf, pg, hf, hg, -, rfl⟩ := hz
+    change coeffEmb L (intSeriesC ℚ pf / intSeriesC ℚ pg) ∈ adjoin L (gensZ L Γ)
+    rw [map_div₀, coeffEmb_intSeriesC, coeffEmb_intSeriesC]
+    exact div_mem (IntermediateField.subset_adjoin L _ ⟨k, f, pf, hf, rfl⟩)
+      (IntermediateField.subset_adjoin L _ ⟨k, g, pg, hg, rfl⟩)
+
+omit [Algebra ℚ L] in
+theorem exists_intSeriesC_coeff_eq_intCast (p : PowerSeries ℤ) (n : ℤ) :
+    ∃ m : ℤ, (intSeriesC L p).coeff n = (m : L) := by
+  rcases le_or_gt 0 n with hn | hn
+  · lift n to ℕ using hn
+    refine ⟨PowerSeries.coeff n p, ?_⟩
+    rw [intSeriesC, HahnSeries.ofPowerSeries_apply_coeff, PowerSeries.coeff_map, eq_intCast]
+  · exact ⟨0, by rw [intSeriesC, ofPowerSeries_coeff_of_neg _ hn, Int.cast_zero]⟩
+
+omit [Algebra ℚ L] in
+theorem exists_fg_coeff_mem {x : LaurentSeries L} (hx : x ∈ Algebra.adjoin L (gensZ L Γ)) :
+    ∃ M : Submodule ℤ L, M.FG ∧ ∀ n, x.coeff n ∈ M := by
+  induction hx using Algebra.adjoin_induction with
+  | mem x hx =>
+      obtain ⟨k, f, p, -, rfl⟩ := hx
+      refine ⟨Submodule.span ℤ {(1 : L)}, Submodule.fg_span (Set.finite_singleton _), fun n => ?_⟩
+      obtain ⟨m, hm⟩ := exists_intSeriesC_coeff_eq_intCast L p n
+      rw [hm, ← zsmul_one]
+      exact Submodule.smul_mem _ _ (Submodule.subset_span rfl)
+  | algebraMap a =>
+      refine ⟨Submodule.span ℤ {a}, Submodule.fg_span (Set.finite_singleton _), fun n => ?_⟩
+      rw [algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single]
+      split_ifs
+      · exact Submodule.subset_span rfl
+      · exact Submodule.zero_mem _
+  | add x y _ _ hx hy =>
+      obtain ⟨M₁, hM₁, h₁⟩ := hx
+      obtain ⟨M₂, hM₂, h₂⟩ := hy
+      refine ⟨M₁ ⊔ M₂, hM₁.sup hM₂, fun n => ?_⟩
+      rw [HahnSeries.coeff_add]
+      exact Submodule.add_mem _ (Submodule.mem_sup_left (h₁ n)) (Submodule.mem_sup_right (h₂ n))
+  | mul x y _ _ hx hy =>
+      obtain ⟨M₁, hM₁, h₁⟩ := hx
+      obtain ⟨M₂, hM₂, h₂⟩ := hy
+      refine ⟨M₁ * M₂, hM₁.mul hM₂, fun n => ?_⟩
+      rw [HahnSeries.coeff_mul]
+      exact Submodule.sum_mem _ fun ij _ => Submodule.mul_mem_mul (h₁ _) (h₂ _)
+
+end Generators
+
+section Gauss
+
+variable {L : Type*} [Field L] [Algebra ℚ L] (A : ValuationSubring L)
+variable (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+
+local notation "FF" => laurentBaseChange L (qExpFunctionFieldC ℚ Γ)
+local notation "kk" => IsLocalRing.ResidueField A
+
+theorem exists_frac_form (f : FF) (hf : f ≠ 0) :
+    ∃ c : L, c ≠ 0 ∧ ∃ x₀ y₀ : LaurentSeries A, ϖ A x₀ ≠ 0 ∧ ϖ A y₀ ≠ 0 ∧
+      (f : LaurentSeries L) * ι A y₀ = algebraMap L (LaurentSeries L) c * ι A x₀ := by
+  have hfF : (f : LaurentSeries L) ∈ adjoin L (gensZ L Γ) :=
+    laurentBaseChange_le_adjoin_gensZ L Γ f.2
+  obtain ⟨r, hr, s, hs, hrs⟩ := (mem_adjoin_iff_div (F := L)).mp hfF
+  have hf0' : (f : LaurentSeries L) ≠ 0 := fun h => hf (Subtype.ext h)
+  have hr0 : r ≠ 0 := by rintro rfl; exact hf0' (by rw [hrs, zero_div])
+  have hs0 : s ≠ 0 := by rintro rfl; exact hf0' (by rw [hrs, div_zero])
+  obtain ⟨Mr, hMr, hrM⟩ := exists_fg_coeff_mem L Γ hr
+  obtain ⟨Ms, hMs, hsM⟩ := exists_fg_coeff_mem L Γ hs
+  obtain ⟨cr, hcr, r₀, hr₀, hr'⟩ := exists_primitive_form A hr0 Mr hMr hrM
+  obtain ⟨cs, hcs, s₀, hs₀, hs'⟩ := exists_primitive_form A hs0 Ms hMs hsM
+  have hιs : ι A s₀ ≠ 0 := by rw [Ne, ι_eq_zero_iff]; exact ϖ_ne_zero_ne_zero hs₀
+  refine ⟨cr / cs, div_ne_zero hcr hcs, r₀, s₀, hr₀, hs₀, ?_⟩
+  rw [hrs, hr', hs', map_div₀]
+  field_simp
+
+def gaussRing : ValuationSubring FF where
+  carrier := {f | IsInt A (f : LaurentSeries L)}
+  mul_mem' {f g} hf hg := by
+    change IsInt A ((f * g : FF) : LaurentSeries L)
+    rw [IntermediateField.coe_mul]; exact hf.mul hg
+  one_mem' := by change IsInt A ((1 : FF) : LaurentSeries L); exact IsInt.one
+  add_mem' {f g} hf hg := by
+    change IsInt A ((f + g : FF) : LaurentSeries L)
+    rw [IntermediateField.coe_add]; exact hf.add hg
+  zero_mem' := by change IsInt A ((0 : FF) : LaurentSeries L); exact IsInt.zero
+  neg_mem' {f} hf := by
+    change IsInt A ((-f : FF) : LaurentSeries L)
+    rw [IntermediateField.coe_neg]; exact hf.neg
+  mem_or_inv_mem' f := by
+    by_cases hf : f = 0
+    · left; subst hf; change IsInt A ((0 : FF) : LaurentSeries L); exact IsInt.zero
+    obtain ⟨c, hc0, x₀, y₀, hx₀, hy₀, h⟩ := exists_frac_form A Γ f hf
+    rcases A.mem_or_inv_mem c with hc | hc
+    · left
+      refine ⟨HahnSeries.C ⟨c, hc⟩ * x₀, y₀, hy₀, ?_⟩
+      rw [h, map_mul, ι_C]
+    · right
+      change IsInt A ((f⁻¹ : FF) : LaurentSeries L)
+      refine ⟨HahnSeries.C ⟨c⁻¹, hc⟩ * y₀, x₀, hx₀, ?_⟩
+      have hf' : (f : LaurentSeries L) ≠ 0 := fun h' => hf (Subtype.ext h')
+      rw [IntermediateField.coe_inv, map_mul, ι_C]
+      have hcC : algebraMap L (LaurentSeries L) c ≠ 0 := (_root_.map_ne_zero _).mpr hc0
+      calc (f : LaurentSeries L)⁻¹ * ι A x₀
+          = (f : LaurentSeries L)⁻¹ * (algebraMap L (LaurentSeries L) c)⁻¹ *
+              ((f : LaurentSeries L) * ι A y₀) := by rw [h]; field_simp
+        _ = algebraMap L (LaurentSeries L) (↑(⟨c⁻¹, hc⟩ : A) : L) * ι A y₀ := by
+              rw [map_inv₀]; field_simp
+
+theorem mem_gaussRing_iff (f : FF) : f ∈ gaussRing A Γ ↔ IsInt A (f : LaurentSeries L) := Iff.rfl
+
+end Gauss
+
+section Residue
+
+variable {L : Type*} [Field L] [Algebra ℚ L] (A : ValuationSubring L)
+variable (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+
+local notation "FF" => laurentBaseChange L (qExpFunctionFieldC ℚ Γ)
+local notation "kk" => IsLocalRing.ResidueField A
+
+theorem exists_witness (f : gaussRing A Γ) :
+    ∃ p : LaurentSeries A × LaurentSeries A,
+      ϖ A p.2 ≠ 0 ∧ ((f : FF) : LaurentSeries L) * ι A p.2 = ι A p.1 := by
+  obtain ⟨x, y, hy, h⟩ := f.2
+  exact ⟨(x, y), hy, h⟩
+
+def wit (f : gaussRing A Γ) : LaurentSeries A × LaurentSeries A :=
+  Classical.choose (exists_witness A Γ f)
+
+theorem wit_spec (f : gaussRing A Γ) :
+    ϖ A (wit A Γ f).2 ≠ 0 ∧ ((f : FF) : LaurentSeries L) * ι A (wit A Γ f).2 = ι A (wit A Γ f).1 :=
+  Classical.choose_spec (exists_witness A Γ f)
+
+def resL (f : gaussRing A Γ) : LaurentSeries kk :=
+  ϖ A (wit A Γ f).1 / ϖ A (wit A Γ f).2
+
+theorem resL_eq {f : gaussRing A Γ} {x y : LaurentSeries A} (hy : ϖ A y ≠ 0)
+    (h : ((f : FF) : LaurentSeries L) * ι A y = ι A x) : resL A Γ f = ϖ A x / ϖ A y := by
+  obtain ⟨hy', h'⟩ := wit_spec A Γ f
+  have hc := IsInt.cross (A := A) h' h
+  rw [resL, div_eq_div_iff hy' hy, ← map_mul, ← map_mul, hc]
+
+def resHom : gaussRing A Γ →+* LaurentSeries kk where
+  toFun := resL A Γ
+  map_one' := by
+    rw [resL_eq A Γ (x := 1) (y := 1) (by simp) (by simp)]; simp
+  map_mul' f g := by
+    obtain ⟨hf, hf'⟩ := wit_spec A Γ f
+    obtain ⟨hg, hg'⟩ := wit_spec A Γ g
+    have h : (((f * g : gaussRing A Γ) : FF) : LaurentSeries L) * ι A ((wit A Γ f).2 * (wit A Γ
+      g).2)
+        = ι A ((wit A Γ f).1 * (wit A Γ g).1) := by
+      rw [map_mul, map_mul, ← hf', ← hg']; push_cast; ring
+    rw [resL_eq A Γ (by rw [map_mul]; exact mul_ne_zero hf hg) h]
+    change _ = resL A Γ f * resL A Γ g
+    rw [resL, resL, map_mul, map_mul, mul_div_mul_comm]
+  map_zero' := by
+    rw [resL_eq A Γ (x := 0) (y := 1) (by simp) (by simp)]; simp
+  map_add' f g := by
+    obtain ⟨hf, hf'⟩ := wit_spec A Γ f
+    obtain ⟨hg, hg'⟩ := wit_spec A Γ g
+    have h : (((f + g : gaussRing A Γ) : FF) : LaurentSeries L) * ι A ((wit A Γ f).2 * (wit A Γ
+      g).2)
+        = ι A ((wit A Γ f).1 * (wit A Γ g).2 + (wit A Γ g).1 * (wit A Γ f).2) := by
+      rw [map_add, map_mul, map_mul, map_mul, ← hf', ← hg']; push_cast; ring
+    rw [resL_eq A Γ (by rw [map_mul]; exact mul_ne_zero hf hg) h]
+    change _ = resL A Γ f + resL A Γ g
+    rw [resL, resL, div_add_div _ _ hf hg, map_add, map_mul, map_mul, map_mul]
+    ring
+
+theorem resHom_eq {f : gaussRing A Γ} {x y : LaurentSeries A} (hy : ϖ A y ≠ 0)
+    (h : ((f : FF) : LaurentSeries L) * ι A y = ι A x) : resHom A Γ f = ϖ A x / ϖ A y :=
+  resL_eq A Γ hy h
+
+theorem resHom_eq_zero_iff (f : gaussRing A Γ) :
+    resHom A Γ f = 0 ↔ f ∈ IsLocalRing.maximalIdeal (gaussRing A Γ) := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  obtain ⟨hy, h⟩ := wit_spec A Γ f
+  constructor
+  · rintro h0 ⟨u, rfl⟩
+    have := congrArg (resHom A Γ) u.mul_inv
+    rw [map_mul, h0, zero_mul, map_one] at this
+    exact zero_ne_one this
+  · intro hu
+    by_contra h0
+    apply hu
+    rw [resHom_eq A Γ hy h, div_eq_zero_iff, or_iff_left hy] at h0
+    have hf0 : ((f : FF) : LaurentSeries L) ≠ 0 := by
+      intro hf
+      rw [hf, zero_mul, eq_comm, ι_eq_zero_iff] at h
+      exact h0 (by rw [h, map_zero])
+    have hf0' : (f : FF) ≠ 0 := fun h' => hf0 (by rw [h']; rfl)
+    have hinv : (f : FF)⁻¹ ∈ gaussRing A Γ := by
+      refine ⟨(wit A Γ f).2, (wit A Γ f).1, h0, ?_⟩
+      rw [IntermediateField.coe_inv]
+      exact IsInt.inv_of (A := A) h0 h
+    exact ⟨⟨f, ⟨(f : FF)⁻¹, hinv⟩, Subtype.ext (mul_inv_cancel₀ hf0'),
+      Subtype.ext (inv_mul_cancel₀ hf0')⟩, rfl⟩
+
+theorem coe_algebraMap (c : L) :
+    ((algebraMap L FF c : FF) : LaurentSeries L) = algebraMap L (LaurentSeries L) c := rfl
+
+omit [Algebra ℚ L] in
+theorem exists_inv_mem_maximalIdeal {c : L} (hc : c ∉ A) :
+    ∃ h : c⁻¹ ∈ A, (⟨c⁻¹, h⟩ : A) ∈ IsLocalRing.maximalIdeal A := by
+  have hc0 : c ≠ 0 := by rintro rfl; exact hc A.zero_mem
+  have hci : c⁻¹ ∈ A := (A.mem_or_inv_mem c).resolve_left hc
+  refine ⟨hci, ?_⟩
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  rintro ⟨u, hu⟩
+  apply hc
+  have h1 : ((↑(u⁻¹ : Aˣ) : A) : L) * c⁻¹ = 1 := by
+    have := congrArg (fun a : A => (a : L)) u.inv_val
+    simpa [hu] using this
+  rw [mul_inv_eq_one₀ hc0] at h1
+  rw [← h1]; exact SetLike.coe_mem _
+
+theorem algebraMap_mem_gaussRing_iff (c : L) : algebraMap L FF c ∈ gaussRing A Γ ↔ c ∈ A := by
+  constructor
+  · rintro ⟨x, y, hy, h⟩
+    rw [coe_algebraMap] at h
+    by_contra hc
+    have hc0 : c ≠ 0 := by rintro rfl; exact hc A.zero_mem
+    obtain ⟨hci, hcm⟩ := exists_inv_mem_maximalIdeal A hc
+    have hyx : y = HahnSeries.C ⟨c⁻¹, hci⟩ * x := by
+      apply ι_injective A
+      rw [map_mul, ι_C, ← h, ← mul_assoc, ← map_mul]
+      simp [inv_mul_cancel₀ hc0]
+    apply hy
+    rw [ϖ_eq_zero_iff]
+    intro n
+    rw [hyx, HahnSeries.C_mul_eq_smul, HahnSeries.coeff_smul, smul_eq_mul]
+    exact Ideal.mul_mem_right _ _ hcm
+  · intro hc
+    refine ⟨HahnSeries.C ⟨c, hc⟩, 1, by simp, ?_⟩
+    rw [coe_algebraMap, ι_C, map_one, mul_one]
+
+theorem resHom_algebraMap (a : A) (h : algebraMap L FF a ∈ gaussRing A Γ) :
+    resHom A Γ ⟨algebraMap L FF a, h⟩ = algebraMap kk (LaurentSeries kk) (IsLocalRing.residue A a)
+      := by
+  rw [resHom_eq A Γ (x := HahnSeries.C a) (y := 1) (by simp)
+    (by rw [map_one, mul_one]; change algebraMap L (LaurentSeries L) (a : L) = _; rw [ι_C]),
+    ϖ_C, map_one, div_one]
+
+end Residue
+
+section PolyJ
+
+variable {L : Type*} [Field L] [Algebra ℚ L] (A : ValuationSubring L)
+variable (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+
+local notation "FF" => laurentBaseChange L (qExpFunctionFieldC ℚ Γ)
+local notation "kk" => IsLocalRing.ResidueField A
+local notation "Fb" => qExpFunctionFieldC (IsLocalRing.ResidueField A) Γ
+
+omit [Algebra ℚ L] in
+theorem exists_primitive_poly {r : L[X]} (hr : r ≠ 0) :
+    ∃ c : L, c ≠ 0 ∧ ∃ r₀ : A[X], r = C c * r₀.map A.subtype ∧ r₀.map (IsLocalRing.residue A) ≠ 0
+      := by
+  have hne : (r.support.image r.coeff).Nonempty := by
+    rw [Finset.image_nonempty, Polynomial.nonempty_support_iff]; exact hr
+  obtain ⟨c, hcT, hcmax⟩ := Finset.exists_max_image _ A.valuation hne
+  obtain ⟨n₀, hn₀, rfl⟩ := Finset.mem_image.mp hcT
+  have hc0 : r.coeff n₀ ≠ 0 := Polynomial.mem_support_iff.mp hn₀
+  have hvx : ∀ n, A.valuation (r.coeff n) ≤ A.valuation (r.coeff n₀) := fun n => by
+    by_cases hn : n ∈ r.support
+    · exact hcmax _ (Finset.mem_image_of_mem _ hn)
+    · rw [Polynomial.notMem_support_iff.mp hn, map_zero]; exact zero_le
+  have hcA : ∀ n, (r.coeff n₀)⁻¹ * r.coeff n ∈ A := fun n => by
+    rw [← A.valuation_le_one_iff, map_mul, map_inv₀]
+    have hc' : A.valuation (r.coeff n₀) ≠ 0 := by simpa using hc0
+    rw [inv_mul_le_one₀ (zero_lt_iff.mpr hc')]
+    exact hvx n
+  obtain ⟨r₀, hr₀⟩ : ∃ r₀ : A[X], r₀.map A.subtype = C (r.coeff n₀)⁻¹ * r := by
+    rw [← Polynomial.mem_lifts, Polynomial.lifts_iff_coeff_lifts]
+    intro n
+    rw [Polynomial.coeff_C_mul]
+    exact ⟨⟨_, hcA n⟩, rfl⟩
+  refine ⟨r.coeff n₀, hc0, r₀, ?_, ?_⟩
+  · rw [hr₀, ← mul_assoc, ← map_mul, mul_inv_cancel₀ hc0, map_one, one_mul]
+  · intro h
+    have h1 := congrArg (fun p : (IsLocalRing.ResidueField A)[X] => p.coeff n₀) h
+    simp only [Polynomial.coeff_map, Polynomial.coeff_zero] at h1
+    have h2 : (r₀.coeff n₀ : L) = 1 := by
+      have := congrArg (fun p : L[X] => p.coeff n₀) hr₀
+      simp only [Polynomial.coeff_map, Polynomial.coeff_C_mul, inv_mul_cancel₀ hc0] at this
+      exact this
+    have h3 : r₀.coeff n₀ = 1 := Subtype.ext (by simpa using h2)
+    rw [h3, map_one] at h1
+    exact one_ne_zero h1
+
+omit [Algebra ℚ L] in
+theorem algebraMap_laurentSeries_A (a : A) : algebraMap A (LaurentSeries A) a = HahnSeries.C a := by
+  rw [HahnSeries.algebraMap_apply']
+  have h1 : algebraMap A (PowerSeries A) a = PowerSeries.C a := by simp
+  rw [h1, HahnSeries.ofPowerSeries_C]
+
+omit [Algebra ℚ L] in
+theorem ι_aeval (p : A[X]) : ι A (aeval (jqModC A) p) = aeval (jqModC L) (p.map A.subtype) := by
+  rw [aeval_def, aeval_def, hom_eval₂, eval₂_map, coeffMap_jqModC]
+  congr 1
+  refine RingHom.ext fun a => ?_
+  change ι A (algebraMap A (LaurentSeries A) a) = algebraMap L (LaurentSeries L) (a : L)
+  rw [algebraMap_laurentSeries_A]
+  exact ι_C A a
+
+omit [Algebra ℚ L] in
+theorem ϖ_aeval (p : A[X]) :
+    ϖ A (aeval (jqModC A) p) = aeval (jqModC kk) (p.map (IsLocalRing.residue A)) := by
+  rw [aeval_def, aeval_def, hom_eval₂, eval₂_map, coeffMap_jqModC]
+  congr 1
+  refine RingHom.ext fun a => ?_
+  change ϖ A (algebraMap A (LaurentSeries A) a) =
+    algebraMap kk (LaurentSeries kk) (IsLocalRing.residue A a)
+  rw [algebraMap_laurentSeries_A]
+  exact ϖ_C A a
+
+theorem aeval_jqModC_ne_zero {K : Type*} [Field K] {p : K[X]} (hp : p ≠ 0) :
+    aeval (jqModC K) p ≠ 0 := fun h =>
+  hp ((transcendental_iff.mp (ModularCurve.transcendental_jqModC K)) p h)
+
+theorem jqModC_mem_rat : jqModC ℚ ∈ qExpFunctionFieldC ℚ Γ :=
+  intFormRatiosC_subset ℚ Γ (ModularCurve.jqModC_mem_intFormRatiosC ℚ Γ)
+
+theorem jqModC_mem_FF : jqModC L ∈ FF := by
+  have h := coeffEmb_mem_laurentBaseChange L (jqModC_mem_rat Γ)
+  rwa [coeffEmb, coeffMap_jqModC] at h
+
+def jF : FF := ⟨jqModC L, jqModC_mem_FF Γ⟩
+
+theorem coe_jF : ((jF Γ : FF) : LaurentSeries L) = jqModC L := rfl
+
+theorem coe_jF' : ((jF Γ : FF) : LaurentSeries L) = ι A (jqModC A) := by
+  rw [coe_jF, coeffMap_jqModC]
+
+def jbar (K : Type*) [Field K] : qExpFunctionFieldC K Γ :=
+  ⟨jqModC K, intFormRatiosC_subset K Γ (ModularCurve.jqModC_mem_intFormRatiosC K Γ)⟩
+
+theorem coe_jbar (K : Type*) [Field K] :
+    ((jbar Γ K : qExpFunctionFieldC K Γ) : LaurentSeries K) = jqModC K :=
+  rfl
+
+theorem transcendental_jbar (K : Type*) [Field K] :
+    Transcendental K (jbar Γ K : qExpFunctionFieldC K Γ) :=
+  fun h => transcendental_jqModC K
+    ((isAlgebraic_algHom_iff (qExpFunctionFieldC K Γ).val Subtype.val_injective).mpr h)
+
+theorem transcendental_jF : Transcendental L (jF Γ : FF) :=
+  fun h => transcendental_jqModC L
+    ((isAlgebraic_algHom_iff (laurentBaseChange L (qExpFunctionFieldC ℚ Γ)).val
+      Subtype.val_injective).mpr h)
+
+theorem jF_mem_gaussRing : (jF Γ : FF) ∈ gaussRing A Γ :=
+  (mem_gaussRing_iff A Γ _).mpr ⟨jqModC A, 1, by rw [map_one]; exact one_ne_zero,
+    by rw [map_one, mul_one, coe_jF']⟩
+
+theorem resHom_jF : resHom A Γ ⟨jF Γ, jF_mem_gaussRing A Γ⟩ = jqModC kk := by
+  rw [resHom_eq A Γ (f := ⟨jF Γ, jF_mem_gaussRing A Γ⟩) (x := jqModC A) (y := 1)
+    (by rw [map_one]; exact one_ne_zero) (by rw [map_one, mul_one]; exact coe_jF' A Γ),
+    map_one, div_one, coeffMap_jqModC]
+
+theorem intSeriesC_ne_zero_rat {K : Type*} [Field K] {p : PowerSeries ℤ} (hp : intSeriesC K p ≠ 0) :
+    intSeriesC ℚ p ≠ 0 := by
+  intro h0
+  apply hp
+  have hp0 : p = 0 := by
+    ext n
+    have h1 := congrArg (fun z : LaurentSeries ℚ => z.coeff (n : ℤ)) h0
+    simp only [intSeriesC, HahnSeries.ofPowerSeries_apply_coeff, PowerSeries.coeff_map,
+      HahnSeries.coeff_zero, eq_intCast, Int.cast_eq_zero] at h1
+    simpa using h1
+  rw [hp0, intSeriesC_zero]
+
+theorem exists_resHom_eq {z : LaurentSeries kk} (hz : z ∈ qExpFunctionFieldC kk Γ) :
+    ∃ f : gaussRing A Γ, resHom A Γ f = z := by
+  let S : Subfield (LaurentSeries kk) :=
+    { carrier := Set.range (resHom A Γ)
+      mul_mem' := by rintro _ _ ⟨f, rfl⟩ ⟨g, rfl⟩; exact ⟨f * g, map_mul _ _ _⟩
+      one_mem' := ⟨1, map_one _⟩
+      add_mem' := by rintro _ _ ⟨f, rfl⟩ ⟨g, rfl⟩; exact ⟨f + g, map_add _ _ _⟩
+      zero_mem' := ⟨0, map_zero _⟩
+      neg_mem' := by rintro _ ⟨f, rfl⟩; exact ⟨-f, map_neg _ _⟩
+      inv_mem' := by
+        rintro _ ⟨f, rfl⟩
+        by_cases h0 : resHom A Γ f = 0
+        · exact ⟨0, by rw [h0, inv_zero, map_zero]⟩
+        · have hu : IsUnit f := by
+            by_contra hu
+            exact h0 ((resHom_eq_zero_iff A Γ f).mpr
+              ((IsLocalRing.mem_maximalIdeal _).mpr (mem_nonunits_iff.mpr hu)))
+          obtain ⟨u, rfl⟩ := hu
+          refine ⟨↑u⁻¹, ?_⟩
+          exact (inv_eq_of_mul_eq_one_left (by rw [← map_mul, Units.inv_mul, map_one])).symm }
+  have hle : Subfield.closure (Set.range (algebraMap kk (LaurentSeries kk)) ∪ intFormRatiosC kk Γ)
+      ≤ S := by
+    rw [Subfield.closure_le]
+    rintro z (⟨t, rfl⟩ | ⟨k, f, g, pf, pg, hf, hg, hg0, rfl⟩)
+    · obtain ⟨a, rfl⟩ := Ideal.Quotient.mk_surjective t
+      exact ⟨⟨_, (algebraMap_mem_gaussRing_iff A Γ (a : L)).mpr a.2⟩, resHom_algebraMap A Γ a _⟩
+    · have hgQ : intSeriesC ℚ pg ≠ 0 := intSeriesC_ne_zero_rat hg0
+      have hmem : ι A (intSeriesA A pf) / ι A (intSeriesA A pg) ∈ FF := by
+        have h := coeffEmb_mem_laurentBaseChange L (div_mem_qExpFunctionFieldC f g hf hg hgQ)
+        rwa [map_div₀, coeffEmb_intSeriesC, coeffEmb_intSeriesC, ← ι_intSeriesA A pf,
+          ← ι_intSeriesA A pg] at h
+      have hϖg : ϖ A (intSeriesA A pg) ≠ 0 := by rwa [ϖ_intSeriesA]
+      have hιg : ι A (intSeriesA A pg) ≠ 0 := by
+        rw [Ne, ι_eq_zero_iff]; exact ϖ_ne_zero_ne_zero hϖg
+      have hw : ((⟨_, hmem⟩ : FF) : LaurentSeries L) * ι A (intSeriesA A pg) = ι A (intSeriesA A pf)
+        :=
+        by
+        change ι A (intSeriesA A pf) / ι A (intSeriesA A pg) * ι A (intSeriesA A pg) = _
+        rw [div_mul_cancel₀ _ hιg]
+      have hO : (⟨_, hmem⟩ : FF) ∈ gaussRing A Γ := (mem_gaussRing_iff A Γ _).mpr ⟨_, _, hϖg, hw⟩
+      refine ⟨⟨_, hO⟩, ?_⟩
+      rw [resHom_eq A Γ (f := ⟨_, hO⟩) hϖg hw, ϖ_intSeriesA, ϖ_intSeriesA]
+  obtain ⟨f, hf⟩ := hle (show z ∈ Subfield.closure _ from hz)
+  exact ⟨f, hf⟩
+
+
+theorem exists_adjoin_coe_eq_resHom {g : FF} (hgK : g ∈ IntermediateField.adjoin L {(jF Γ : FF)})
+    (hgO : g ∈ gaussRing A Γ) :
+    ∃ t : IntermediateField.adjoin kk {(jbar Γ kk : Fb)},
+      (((t : Fb) : LaurentSeries kk)) = resHom A Γ ⟨g, hgO⟩ := by
+  rw [mem_adjoin_simple_iff] at hgK
+  obtain ⟨r, s, hrs⟩ := hgK
+  by_cases hg0 : g = 0
+  · refine ⟨0, ?_⟩
+    have : (⟨g, hgO⟩ : gaussRing A Γ) = 0 := Subtype.ext hg0
+    rw [this, map_zero]; rfl
+  have hr0 : r ≠ 0 := by rintro rfl; apply hg0; rw [hrs, map_zero, zero_div]
+  have hs0 : s ≠ 0 := by rintro rfl; apply hg0; rw [hrs, map_zero, div_zero]
+  obtain ⟨cr, hcr, r₀, hr', hr₀⟩ := exists_primitive_poly A hr0
+  obtain ⟨cs, hcs, s₀, hs', hs₀⟩ := exists_primitive_poly A hs0
+  obtain ⟨R₀, hR₀def⟩ : ∃ R₀, R₀ = aeval (jqModC A) r₀ := ⟨_, rfl⟩
+  obtain ⟨S₀, hS₀def⟩ : ∃ S₀, S₀ = aeval (jqModC A) s₀ := ⟨_, rfl⟩
+  have hιR : aeval (jqModC L) (r₀.map A.subtype) = ι A R₀ := by rw [hR₀def, ι_aeval]
+  have hιS : aeval (jqModC L) (s₀.map A.subtype) = ι A S₀ := by rw [hS₀def, ι_aeval]
+  have hϖR : ϖ A R₀ = aeval (jqModC kk) (r₀.map (IsLocalRing.residue A)) := by rw [hR₀def, ϖ_aeval]
+  have hϖS : ϖ A S₀ = aeval (jqModC kk) (s₀.map (IsLocalRing.residue A)) := by rw [hS₀def, ϖ_aeval]
+  have hR₀ : ϖ A R₀ ≠ 0 := by rw [hϖR]; exact aeval_jqModC_ne_zero hr₀
+  have hS₀ : ϖ A S₀ ≠ 0 := by rw [hϖS]; exact aeval_jqModC_ne_zero hs₀
+  have hιS₀ : ι A S₀ ≠ 0 := by rw [Ne, ι_eq_zero_iff]; exact ϖ_ne_zero_ne_zero hS₀
+  have hιR₀ : ι A R₀ ≠ 0 := by rw [Ne, ι_eq_zero_iff]; exact ϖ_ne_zero_ne_zero hR₀
+  have e0 : ∀ p : L[X], ((aeval (jF Γ) p : FF) : LaurentSeries L) = aeval (jqModC L) p :=
+    fun p => by
+    rw [← coe_jF (L := L) Γ]
+    exact (aeval_algHom_apply (laurentBaseChange L (qExpFunctionFieldC ℚ Γ)).val (jF Γ) p).symm
+  have e1 : (g : LaurentSeries L) = aeval (jqModC L) r / aeval (jqModC L) s := by
+    rw [hrs, IntermediateField.coe_div, e0, e0]
+  have hgcoe : (g : LaurentSeries L) * ι A S₀ = algebraMap L _ (cr / cs) * ι A R₀ := by
+    rw [e1, hr', hs', map_mul, map_mul, aeval_C, aeval_C, hιR, hιS, map_div₀]
+    have hcs' : algebraMap L (LaurentSeries L) cs ≠ 0 := (_root_.map_ne_zero _).mpr hcs
+    field_simp
+  by_cases he : cr / cs ∈ A
+  · have hw : (g : LaurentSeries L) * ι A S₀ = ι A (HahnSeries.C ⟨cr / cs, he⟩ * R₀) := by
+      rw [hgcoe, map_mul, ι_C]
+    have e0k : ∀ p : kk[X], ((aeval (jbar Γ kk : Fb) p : Fb) : LaurentSeries kk) = aeval (jqModC kk)
+      p :=
+      fun p => (aeval_algHom_apply (qExpFunctionFieldC kk Γ).val (jbar Γ kk) p).symm
+    have hmemK : ∀ p : kk[X], aeval (jbar Γ kk : Fb) p ∈ IntermediateField.adjoin kk {(jbar Γ kk :
+      Fb)} :=
+      fun p => IntermediateField.algebra_adjoin_le_adjoin kk _
+        (Polynomial.aeval_mem_adjoin_singleton kk _)
+    refine ⟨⟨aeval (jbar Γ kk : Fb) (C (IsLocalRing.residue A ⟨cr / cs, he⟩) * r₀.map
+      (IsLocalRing.residue A)) /
+      aeval (jbar Γ kk : Fb) (s₀.map (IsLocalRing.residue A)), div_mem (hmemK _) (hmemK _)⟩, ?_⟩
+    change (((aeval (jbar Γ kk : Fb) (C (IsLocalRing.residue A ⟨cr / cs, he⟩) * r₀.map
+      (IsLocalRing.residue A)) /
+      aeval (jbar Γ kk : Fb) (s₀.map (IsLocalRing.residue A)) : Fb)) : LaurentSeries kk) = _
+    rw [resHom_eq A Γ (f := ⟨g, hgO⟩) hS₀ hw, map_mul (ϖ A), ϖ_C, hϖR, hϖS,
+      IntermediateField.coe_div, map_mul, IntermediateField.coe_mul, e0k, e0k, aeval_C]
+    rw [e0k]
+  · exfalso
+    obtain ⟨hei, hem⟩ := exists_inv_mem_maximalIdeal A he
+    have he0 : cr / cs ≠ 0 := div_ne_zero hcr hcs
+    have hg0' : (g : LaurentSeries L) ≠ 0 := fun h => hg0 (Subtype.ext h)
+    obtain ⟨g', hg'⟩ : ∃ g' : FF, (g' : LaurentSeries L) = (g : LaurentSeries L)⁻¹ := ⟨g⁻¹, rfl⟩
+    obtain ⟨a, ha, hres0⟩ : ∃ a : A, (a : L) = (cr / cs)⁻¹ ∧ IsLocalRing.residue A a = 0 :=
+      ⟨⟨_, hei⟩, rfl, Ideal.Quotient.eq_zero_iff_mem.mpr hem⟩
+    have hw : (g' : LaurentSeries L) * ι A R₀ = ι A (HahnSeries.C a * S₀) := by
+      rw [hg', map_mul, ι_C, ha]
+      have hC : algebraMap L (LaurentSeries L) (cr / cs) ≠ 0 := (_root_.map_ne_zero _).mpr he0
+      calc (g : LaurentSeries L)⁻¹ * ι A R₀
+          = (g : LaurentSeries L)⁻¹ * (algebraMap L (LaurentSeries L) (cr / cs))⁻¹ *
+              ((g : LaurentSeries L) * ι A S₀) := by rw [hgcoe]; field_simp
+        _ = algebraMap L (LaurentSeries L) (cr / cs)⁻¹ * ι A S₀ := by
+              rw [map_inv₀]; field_simp
+    have hinvO : g' ∈ gaussRing A Γ := (mem_gaussRing_iff A Γ _).mpr ⟨_, _, hR₀, hw⟩
+    have hϖx : ϖ A (HahnSeries.C a * S₀) = 0 := by
+      simp only [map_mul (ϖ A), ϖ_C, hres0, map_zero, zero_mul]
+    have hres : resHom A Γ ⟨g', hinvO⟩ = 0 := by
+      simp only [resHom_eq A Γ (f := ⟨g', hinvO⟩) hR₀ hw, hϖx, zero_div]
+    have h1 : (⟨g, hgO⟩ : gaussRing A Γ) * ⟨g', hinvO⟩ = 1 := by
+      apply Subtype.ext; apply Subtype.ext
+      change (g : LaurentSeries L) * (g' : LaurentSeries L) = 1
+      rw [hg']; exact mul_inv_cancel₀ hg0'
+    have h2 : resHom A Γ ⟨g, hgO⟩ * resHom A Γ ⟨g', hinvO⟩ = 1 := by
+      rw [← map_mul (resHom A Γ), h1, map_one]
+    rw [hres, mul_zero] at h2
+    exact zero_ne_one h2
+
+end PolyJ
+
+section Deuring
+
+variable {L : Type*} [Field L] [Algebra ℚ L] (A : ValuationSubring L)
+variable (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+
+local notation "FF" => laurentBaseChange L (qExpFunctionFieldC ℚ Γ)
+local notation "kk" => IsLocalRing.ResidueField A
+local notation "Fb" => qExpFunctionFieldC (IsLocalRing.ResidueField A) Γ
+
+
+theorem card_le_finrank_of_linearIndependent
+    [Module.Finite (IntermediateField.adjoin L {(jF Γ : FF)}) FF]
+    (s : Finset Fb)
+    (hli : LinearIndependent (IntermediateField.adjoin kk {(jbar Γ kk : Fb)}) (fun i : s => (i :
+      Fb))) :
+    s.card ≤ Module.finrank (IntermediateField.adjoin L {(jF Γ : FF)}) FF := by
+  set K0 := IntermediateField.adjoin L {(jF Γ : FF)} with hK0
+  set K0' := IntermediateField.adjoin kk {(jbar Γ kk : Fb)} with hK0'
+  by_contra hlt
+  push Not at hlt
+  have hb : ∀ i : s, ∃ b : gaussRing A Γ, resHom A Γ b = ((i : Fb) : LaurentSeries kk) :=
+    fun i => exists_resHom_eq A Γ (i : Fb).2
+  choose b hb using hb
+  let v : s → FF := fun i => (b i : FF)
+  have hdep : ¬ LinearIndependent K0 v := by
+    intro hli'
+    have h := hli'.fintype_card_le_finrank
+    rw [Fintype.card_coe] at h
+    omega
+  obtain ⟨g, hg, i₁, hi₁⟩ := Fintype.not_linearIndependent_iff.mp hdep
+  have hne : (Finset.univ : Finset s).Nonempty := ⟨i₁, Finset.mem_univ _⟩
+  obtain ⟨i₀, -, hi₀⟩ := Finset.exists_max_image Finset.univ
+    (fun o => (gaussRing A Γ).valuation ((g o : K0) : FF)) hne
+  have hgi₀ : ((g i₀ : K0) : FF) ≠ 0 := by
+    intro h0
+    apply hi₁
+    have := hi₀ i₁ (Finset.mem_univ _)
+    rw [h0, map_zero, le_zero_iff, Valuation.zero_iff] at this
+    exact ZeroMemClass.coe_eq_zero.mp this
+  have hvpos : 0 < (gaussRing A Γ).valuation ((g i₀ : K0) : FF) := (Valuation.pos_iff _).mpr hgi₀
+  let c : s → FF := fun o => ((g o : K0) : FF) / ((g i₀ : K0) : FF)
+  have hcK : ∀ o, c o ∈ K0 := fun o => div_mem (g o).2 (g i₀).2
+  have hcO : ∀ o, c o ∈ gaussRing A Γ := fun o => by
+    rw [← (gaussRing A Γ).valuation_le_one_iff]
+    change (gaussRing A Γ).valuation (_ / _) ≤ 1
+    rw [map_div₀, div_le_one₀ hvpos]
+    exact hi₀ o (Finset.mem_univ o)
+  have hci₀ : c i₀ = 1 := div_self hgi₀
+  have hrel : ∑ o, c o * v o = 0 := by
+    have h1 : ∑ o, ((g o : K0) : FF) * v o = 0 := by
+      simpa only [IntermediateField.smul_def, smul_eq_mul] using hg
+    calc ∑ o, c o * v o = ((g i₀ : K0) : FF)⁻¹ * ∑ o, ((g o : K0) : FF) * v o := by
+          rw [Finset.mul_sum]
+          exact Finset.sum_congr rfl fun o _ => by simp only [c]; ring
+      _ = 0 := by rw [h1, mul_zero]
+  have ht : ∀ o, ∃ t : K0', ((t : Fb) : LaurentSeries kk) = resHom A Γ ⟨c o, hcO o⟩ :=
+    fun o => exists_adjoin_coe_eq_resHom A Γ (hcK o) (hcO o)
+  choose t ht using ht
+  have hti₀ : t i₀ = 1 := by
+    have h1 : (⟨c i₀, hcO i₀⟩ : gaussRing A Γ) = 1 := Subtype.ext hci₀
+    have h2 : ((t i₀ : Fb) : LaurentSeries kk) = (((1 : K0') : Fb) : LaurentSeries kk) := by
+      rw [ht i₀, h1, map_one]; simp
+    exact Subtype.ext (Subtype.ext h2)
+  have hrelO : ∑ o, (⟨c o, hcO o⟩ : gaussRing A Γ) * b o = 0 := by
+    apply Subtype.ext
+    rw [AddSubmonoidClass.coe_finsetSum]
+    simp only [v] at hrel
+    exact hrel
+  have hres : ∑ o, ((t o : Fb) : LaurentSeries kk) * ((o : Fb) : LaurentSeries kk) = 0 := by
+    have := congrArg (resHom A Γ) hrelO
+    have hmap : (resHom A Γ) (∑ o, (⟨c o, hcO o⟩ : gaussRing A Γ) * b o) =
+        ∑ o, (resHom A Γ) ((⟨c o, hcO o⟩ : gaussRing A Γ) * b o) :=
+      map_sum (resHom A Γ).toAddMonoidHom _ _
+    rw [hmap] at this
+    simpa only [map_mul (resHom A Γ), map_zero (resHom A Γ), ht, hb] using this
+  have hsum' : (∑ o, t o • ((o : Fb)) : Fb) = 0 := by
+    apply Subtype.ext
+    rw [AddSubmonoidClass.coe_finsetSum]
+    simp only [IntermediateField.smul_def, smul_eq_mul, IntermediateField.coe_mul] at hres ⊢
+    exact hres
+  have hall := Fintype.linearIndependent_iff.mp hli t hsum'
+  have : t i₀ = 0 := hall i₀
+  rw [hti₀] at this
+  exact one_ne_zero this
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+theorem finiteDimensional_and_finrank_le
+    [Module.Finite (IntermediateField.adjoin L {(jF Γ : FF)}) FF] :
+    FiniteDimensional (IntermediateField.adjoin kk {(jbar Γ kk : Fb)}) Fb ∧
+      Module.finrank (IntermediateField.adjoin kk {(jbar Γ kk : Fb)}) Fb ≤
+        Module.finrank (IntermediateField.adjoin L {(jF Γ : FF)}) FF := by
+  have hrank : Module.rank (IntermediateField.adjoin kk {(jbar Γ kk : Fb)}) Fb ≤
+      (Module.finrank (IntermediateField.adjoin L {(jF Γ : FF)}) FF : ℕ) :=
+    rank_le fun s hs => card_le_finrank_of_linearIndependent A Γ s hs
+  have hfin : Module.Finite (IntermediateField.adjoin kk {(jbar Γ kk : Fb)}) Fb :=
+    Module.rank_lt_aleph0_iff.mp (lt_of_le_of_lt hrank Cardinal.natCast_lt_aleph0)
+  exact ⟨hfin, Module.finrank_le_of_rank_le hrank⟩
+
+end Deuring
+
+section Exchange
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem finite_adjoin_adjoin {x t : F} (hfin : FiniteDimensional (IntermediateField.adjoin K {x}) F)
+    :
+    Module.Finite (IntermediateField.adjoin (IntermediateField.adjoin K {t}) {x}) F := by
+  set Kx := IntermediateField.adjoin K {x} with hKx
+  set Kt := IntermediateField.adjoin K {t} with hKt
+  set E := IntermediateField.adjoin Kt {x} with hE
+  obtain ⟨B, hB⟩ := Module.finite_def.mp hfin
+  refine Module.finite_def.mpr ⟨B, ?_⟩
+  rw [eq_top_iff]
+  rintro f -
+  have hf : f ∈ Submodule.span Kx (B : Set F) := by rw [hB]; exact Submodule.mem_top
+  induction hf using Submodule.span_induction with
+  | mem y hy => exact Submodule.subset_span hy
+  | zero => exact Submodule.zero_mem _
+  | add y z _ _ hy hz => exact Submodule.add_mem _ hy hz
+  | smul a y _ hy =>
+      have haE : (a : F) ∈ E := by
+        have hle : Kx ≤ E.restrictScalars K :=
+          IntermediateField.adjoin_simple_le_iff.mpr
+            ((IntermediateField.mem_restrictScalars K).mpr (IntermediateField.mem_adjoin_simple_self
+              Kt x))
+        exact hle a.2
+      have : (a • y : F) = (⟨(a : F), haE⟩ : E) • y := rfl
+      rw [this]
+      exact Submodule.smul_mem _ _ hy
+
+theorem isAlgebraic_of_sum_aeval_mul_pow_eq_zero {x t : F} (ht : Transcendental K t) {n : ℕ}
+    (c : Fin n → K[X]) (hrel : ∑ i : Fin n, aeval x (c i) * t ^ (i : ℕ) = 0)
+    (hne : ∃ i, aeval x (c i) ≠ 0) :
+    IsAlgebraic (IntermediateField.adjoin K {t}) x := by
+  set Kt := IntermediateField.adjoin K {t} with hKt
+  let th : Kt := ⟨t, IntermediateField.mem_adjoin_simple_self K t⟩
+  let q : Kt[X] := ∑ i : Fin n, C (th ^ (i : ℕ)) * (c i).map (algebraMap K Kt)
+  refine ⟨q, ?_, ?_⟩
+  · intro hq
+    obtain ⟨i₁, hi₁⟩ := hne
+    have hc : c i₁ ≠ 0 := by rintro h; exact hi₁ (by rw [h, map_zero])
+    obtain ⟨m, hm⟩ : ∃ m, (c i₁).coeff m ≠ 0 := by
+      by_contra h
+      push Not at h
+      exact hc (Polynomial.ext fun m => by simpa using h m)
+    have hcoeff := congrArg (fun p : Kt[X] => ((p.coeff m : Kt) : F)) hq
+    simp only [q, finsetSum_coeff, coeff_C_mul, coeff_map, coeff_zero,
+      ZeroMemClass.coe_zero] at hcoeff
+    rw [AddSubmonoidClass.coe_finsetSum] at hcoeff
+    have hpoly : aeval t (∑ i : Fin n, C ((c i).coeff m) * X ^ (i : ℕ)) = 0 := by
+      rw [map_sum]
+      refine (Finset.sum_congr rfl fun i _ => ?_).trans hcoeff
+      rw [map_mul, aeval_C, map_pow, aeval_X, IntermediateField.coe_mul, IntermediateField.coe_pow,
+        mul_comm]
+      rfl
+    have hzero := (transcendental_iff.mp ht) _ hpoly
+    have hcm := congrArg (fun p : K[X] => p.coeff (i₁ : ℕ)) hzero
+    simp only [finsetSum_coeff, coeff_C_mul, coeff_X_pow, coeff_zero] at hcm
+    rw [Finset.sum_eq_single i₁ (fun j _ hj => by
+        rw [ite_eq_right (fun h => hj (Fin.ext h.symm)),
+          mul_zero]) (fun h => absurd (Finset.mem_univ _) h),
+      ite_eq_left rfl, mul_one] at hcm
+    exact hm hcm
+  · have h1 : (aeval x q : F) = ∑ i : Fin n, aeval x (c i) * t ^ (i : ℕ) := by
+      simp only [q, map_sum, map_mul, aeval_C, map_pow]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [aeval_map_algebraMap, mul_comm]
+      rfl
+    rw [h1, hrel]
+
+
+theorem finiteDimensional_adjoin_of_transcendental {x t : F}
+    (hfin : FiniteDimensional (IntermediateField.adjoin K {x}) F) (ht : Transcendental K t) :
+    FiniteDimensional (IntermediateField.adjoin K {t}) F := by
+  set Kx := IntermediateField.adjoin K {x} with hKx
+  set Kt := IntermediateField.adjoin K {t} with hKt
+  have := hfin
+  set d := Module.finrank Kx F with hd
+  have hdep : ¬ LinearIndependent Kx (fun i : Fin (d + 1) => t ^ (i : ℕ)) := by
+    intro hli
+    have h := hli.fintype_card_le_finrank
+    rw [Fintype.card_fin] at h
+    omega
+  obtain ⟨g, hg, i₁, hi₁⟩ := Fintype.not_linearIndependent_iff.mp hdep
+  have hrs : ∀ i, ∃ r s : K[X], aeval x s ≠ 0 ∧ ((g i : Kx) : F) * aeval x s = aeval x r := by
+    intro i
+    obtain ⟨r, s, h⟩ := (mem_adjoin_simple_iff K ((g i : Kx) : F)).mp (g i).2
+    by_cases hs : aeval x s = 0
+    · refine ⟨0, 1, by rw [map_one]; exact one_ne_zero, ?_⟩
+      rw [h, hs, div_zero, zero_mul, map_zero]
+    · exact ⟨r, s, hs, by rw [h, div_mul_cancel₀ _ hs]⟩
+  choose r s hs hgrs using hrs
+  let c : Fin (d + 1) → K[X] := fun i => r i * ∏ j ∈ Finset.univ.erase i, s j
+  have hD : ∀ i, aeval x (c i) = ((g i : Kx) : F) * ∏ j, aeval x (s j) := by
+    intro i
+    simp only [c, map_mul, map_prod]
+    rw [← Finset.mul_prod_erase Finset.univ (fun j => aeval x (s j)) (Finset.mem_univ i), ←
+      mul_assoc,
+      hgrs i]
+  have hprod : ∏ j, aeval x (s j) ≠ 0 := Finset.prod_ne_zero_iff.mpr fun j _ => hs j
+  have hrel : ∑ i : Fin (d + 1), aeval x (c i) * t ^ (i : ℕ) = 0 := by
+    have h1 : ∑ i : Fin (d + 1), ((g i : Kx) : F) * t ^ (i : ℕ) = 0 := by
+      simpa only [IntermediateField.smul_def, smul_eq_mul] using hg
+    calc ∑ i : Fin (d + 1), aeval x (c i) * t ^ (i : ℕ)
+        = (∏ j, aeval x (s j)) * ∑ i : Fin (d + 1), ((g i : Kx) : F) * t ^ (i : ℕ) := by
+          rw [Finset.mul_sum]
+          exact Finset.sum_congr rfl fun i _ => by rw [hD]; ring
+      _ = 0 := by rw [h1, mul_zero]
+  have hne : ∃ i, aeval x (c i) ≠ 0 := by
+    refine ⟨i₁, ?_⟩
+    rw [hD]
+    exact mul_ne_zero (fun h => hi₁ (Subtype.ext h)) hprod
+  have halg : IsAlgebraic Kt x := isAlgebraic_of_sum_aeval_mul_pow_eq_zero ht c hrel hne
+  have : FiniteDimensional Kt (IntermediateField.adjoin Kt {x}) :=
+    IntermediateField.adjoin.finiteDimensional halg.isIntegral
+  have : Module.Finite (IntermediateField.adjoin Kt {x}) F := finite_adjoin_adjoin hfin
+  exact Module.Finite.trans (IntermediateField.adjoin Kt {x}) F
+
+end Exchange
+
+section Finite
+
+variable (L : Type*) [Field L] [Algebra ℚ L]
+variable (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+
+local notation "FF" => laurentBaseChange L (qExpFunctionFieldC ℚ Γ)
+
+theorem finite_adjoin_jF (hT : ModularGroup.T ∈ Γ) :
+    Module.Finite (IntermediateField.adjoin L {(jF Γ : FF)}) FF := by
+  obtain ⟨x, -, hfin⟩ :=
+    ModularCurve.JOneES.exists_transcendental_finiteDimensional_laurentBaseChange L Γ hT
+  exact finiteDimensional_adjoin_of_transcendental hfin (transcendental_jF Γ)
+
+end Finite
+
+end QExpDeuring
+
+open QExpDeuring in
+theorem solution (L : Type*) [Field L] [Algebra ℚ L] (A : ValuationSubring L)
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hT : ModularGroup.T ∈ Γ) :
+    ∃ x : ModularCurve.qExpFunctionFieldC (IsLocalRing.ResidueField A) Γ,
+      (x : LaurentSeries (IsLocalRing.ResidueField A)) =
+          ModularCurve.jqModC (IsLocalRing.ResidueField A) ∧
+      Transcendental (IsLocalRing.ResidueField A) x ∧
+      FiniteDimensional
+        (IntermediateField.adjoin (IsLocalRing.ResidueField A)
+          ({x} : Set (ModularCurve.qExpFunctionFieldC (IsLocalRing.ResidueField A) Γ)))
+        (ModularCurve.qExpFunctionFieldC (IsLocalRing.ResidueField A) Γ) ∧
+      ∀ (y : ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ)),
+        (y : LaurentSeries L) = ModularCurve.jqModC L →
+        Module.finrank
+            (IntermediateField.adjoin (IsLocalRing.ResidueField A)
+              ({x} : Set (ModularCurve.qExpFunctionFieldC (IsLocalRing.ResidueField A) Γ)))
+            (ModularCurve.qExpFunctionFieldC (IsLocalRing.ResidueField A) Γ) ≤
+          Module.finrank
+            (IntermediateField.adjoin L
+              ({y} : Set (ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ))))
+            (ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ)) := by
+  have := finite_adjoin_jF L Γ hT
+  obtain ⟨hfin, hle⟩ := finiteDimensional_and_finrank_le A Γ
+  refine ⟨jbar Γ (IsLocalRing.ResidueField A), coe_jbar Γ _, transcendental_jbar Γ _, hfin, ?_⟩
+  intro y hy
+  obtain rfl : y = jF Γ := Subtype.ext (hy.trans (coe_jF Γ).symm)
+  exact hle
+
+end
+
+end S_OVERLONG_560e3206
+end P2MW
+export P2MW.S_OVERLONG_560e3206
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+set_option synthInstance.maxHeartbeats 400000 in
+theorem ModularCurve.exists_transcendental_finiteDimensional_qExpFunctionFieldC_residueField
+    (L : Type*) [Field L] [Algebra ℚ L] (A : ValuationSubring L)
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hT : ModularGroup.T ∈ Γ) :
+    ∃ x : ModularCurve.qExpFunctionFieldC (IsLocalRing.ResidueField A) Γ,
+      (x : LaurentSeries (IsLocalRing.ResidueField A)) =
+          ModularCurve.jqModC (IsLocalRing.ResidueField A) ∧
+      Transcendental (IsLocalRing.ResidueField A) x ∧
+      FiniteDimensional
+        (IntermediateField.adjoin (IsLocalRing.ResidueField A)
+          ({x} : Set (ModularCurve.qExpFunctionFieldC (IsLocalRing.ResidueField A) Γ)))
+        (ModularCurve.qExpFunctionFieldC (IsLocalRing.ResidueField A) Γ) ∧
+      ∀ (y : ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ)),
+        (y : LaurentSeries L) = ModularCurve.jqModC L →
+        Module.finrank
+            (IntermediateField.adjoin (IsLocalRing.ResidueField A)
+              ({x} : Set (ModularCurve.qExpFunctionFieldC (IsLocalRing.ResidueField A) Γ)))
+            (ModularCurve.qExpFunctionFieldC (IsLocalRing.ResidueField A) Γ) ≤
+          Module.finrank
+            (IntermediateField.adjoin L
+              ({y} : Set (ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ))))
+            (ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ)) :=
+  solution L A Γ hT
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_full.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_full.lean
new file mode 100644
index 0000000000..eaf367486d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_full.lean
@@ -0,0 +1,156 @@
+/-
+Based on Prove2Me node ModularCurve.finiteDimensional_adjoin_coeffEmb_jq_full
+(7ced3fad-1396-570b-88c4-c0308909da0f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 91748df3-063d-5092-8536-d3cb4ce44c55
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlace
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_laurentBaseChange_modularFunctionFieldFull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_pos
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finiteness of the base-changed level-N function field over L(j)
+
+Theorem statement: `ModularCurve.finiteDimensional_adjoin_coeffEmb_jq_full`
+(`7ced3fad-1396-570b-88c4-c0308909da0f`), by Claude, 2026-09-05.
+
+Proof: submission `91748df3-063d-5092-8536-d3cb4ce44c55`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbb{Q}$-algebra structure and let $N$ be a natural number
+with $N \neq 0$. Inside $\mathrm{LaurentSeries}\,\mathbb{Q}$ let $\mathtt{jq}$ be the Laurent series
+$q^{-1}$ times the image of the integral power series $\mathtt{jNum}$ under $\mathbb{Z} \to
+\mathbb{Q}$ (the $q$-expansion of the $j$-invariant), and let $\mathtt{modularFunctionFieldFull}\ N$
+be the intermediate field of $\mathrm{LaurentSeries}\,\mathbb{Q}$ obtained by adjoining to
+$\mathbb{Q}$ all the expansions $\mathtt{qExpand}\ \mathbb{Q}\ d\ \mathtt{jq}$ for nonzero divisors
+$d$ of $N$. Let $\mathtt{coeffEmb}\ L$ be the ring embedding $\mathrm{LaurentSeries}\,\mathbb{Q} \to
+\mathrm{LaurentSeries}\,L$ acting on coefficients through $\mathbb{Q} \to L$, and let $E =
+\mathtt{laurentBaseChange}\ L\ (\mathtt{modularFunctionFieldFull}\ N)$ be the intermediate field of
+$\mathrm{LaurentSeries}\,L$ generated over $L$ by the image of $\mathtt{modularFunctionFieldFull}\
+N$ under this embedding. The element $\mathtt{coeffEmb}\ L\ \mathtt{jq}$ lies in $E$, and the
+assertion is that $E$ is finite-dimensional as a vector space over the intermediate field of $E$
+generated over $L$ by that single element. Only finiteness is asserted, not the value of the degree.
+
+This is the statement that the function field of $X_0(N)$, realised as a field of formal
+$q$-expansions with coefficients extended from $\mathbb{Q}$ to an arbitrary field $L$ of
+characteristic zero, is a finite extension of $L(j)$; taking $L = \overline{\mathbb{Q}}$ or $L =
+\mathbb{C}$ gives the cases used later. It underlies the separability statement proved alongside it
+and is invoked throughout the $q$-expansion model of $X_0(N)$, where finiteness over $L(j)$ is what
+makes orders of differentials, place-reduction dictionaries and residue computations available.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_full.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_full
+
+p2m_open "ModularCurve~modularFunctionFieldBar \
+  P2MW.S_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_full.ModularCurve"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jq dedekindPsi modularFunctionFieldFull coeffEmb laurentBaseChange \
+  coeffEmb_mem_laurentBaseChange relfinrank_laurentBaseChange_modularFunctionFieldFull jq_mem_full \
+  relfinrank_full_eq_dedekindPsi dedekindPsi_pos"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+private theorem ModularCurve.finiteDimensional_adjoin_coeffEmb_jq_full (L : Type*) [Field L]
+    [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    FiniteDimensional (IntermediateField.adjoin L ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L
+      (jq_mem_full N)⟩} : Set (laurentBaseChange L (modularFunctionFieldFull N))))
+      (laurentBaseChange L (modularFunctionFieldFull N)) := by
+  have hmap : (IntermediateField.adjoin L
+        ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩} :
+          Set (laurentBaseChange L (modularFunctionFieldFull N)))).map
+        (laurentBaseChange L (modularFunctionFieldFull N)).val =
+      IntermediateField.adjoin L ({coeffEmb L jq} : Set (LaurentSeries L)) := by
+    have h :=
+      IntermediateField.adjoin_map (F := L) (E := laurentBaseChange L (modularFunctionFieldFull N))
+      (S := ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩} :
+        Set (laurentBaseChange L (modularFunctionFieldFull N))))
+      (laurentBaseChange L (modularFunctionFieldFull N)).val
+    rw [Set.image_singleton] at h
+    exact h
+  have hcomap : (IntermediateField.adjoin L ({coeffEmb L jq} : Set (LaurentSeries L))).comap
+        (laurentBaseChange L (modularFunctionFieldFull N)).val =
+      IntermediateField.adjoin L
+        ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩} :
+          Set (laurentBaseChange L (modularFunctionFieldFull N))) := by
+    rw [← hmap, IntermediateField.comap_map]
+  have hrank : Module.finrank
+      ((IntermediateField.adjoin L ({coeffEmb L jq} : Set (LaurentSeries L))).comap
+        (laurentBaseChange L (modularFunctionFieldFull N)).val)
+      (laurentBaseChange L (modularFunctionFieldFull N)) = dedekindPsi N := by
+    rw [IntermediateField.finrank_comap, IntermediateField.fieldRange_val,
+      relfinrank_laurentBaseChange_modularFunctionFieldFull, relfinrank_full_eq_dedekindPsi]
+  have hfin : FiniteDimensional
+      ((IntermediateField.adjoin L ({coeffEmb L jq} : Set (LaurentSeries L))).comap
+        (laurentBaseChange L (modularFunctionFieldFull N)).val)
+      (laurentBaseChange L (modularFunctionFieldFull N)) :=
+    Module.finite_of_finrank_pos (by rw [hrank]; exact dedekindPsi_pos N (NeZero.ne N))
+  rwa [hcomap] at hfin
+
+p2m_open_scoped "ModularCurve" in
+set_option synthInstance.maxHeartbeats 400000 in
+private theorem ModularCurve.isSeparable_adjoin_coeffEmb_jq_full (L : Type*) [Field L] [Algebra ℚ L]
+    (N : ℕ) [NeZero N] :
+    Algebra.IsSeparable (IntermediateField.adjoin L ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange
+      L (jq_mem_full N)⟩} : Set (laurentBaseChange L (modularFunctionFieldFull N))))
+      (laurentBaseChange L (modularFunctionFieldFull N)) := by
+  set X : IntermediateField L (laurentBaseChange L (modularFunctionFieldFull N)) :=
+    IntermediateField.adjoin L ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full
+      N)⟩} :
+      Set (laurentBaseChange L (modularFunctionFieldFull N))) with hX
+  have : FiniteDimensional X (laurentBaseChange L (modularFunctionFieldFull N)) :=
+    finiteDimensional_adjoin_coeffEmb_jq_full L N
+  have : CharZero L := charZero_of_injective_algebraMap (algebraMap ℚ L).injective
+  have : CharZero X := charZero_of_injective_algebraMap (algebraMap L X).injective
+  infer_instance
+
+p2m_open "ModularCurve~modularFunctionFieldBar\
+  " in
+open _root_.P2MW.S_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_full.ModularCurve in
+theorem solution (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    FiniteDimensional (IntermediateField.adjoin L ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L
+      (jq_mem_full N)⟩} : Set (laurentBaseChange L (modularFunctionFieldFull N))))
+      (laurentBaseChange L (modularFunctionFieldFull N)) :=
+  ModularCurve.finiteDimensional_adjoin_coeffEmb_jq_full L N
+
+end S_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_full
+end P2MW
+export P2MW.S_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_full (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.finiteDimensional_adjoin_coeffEmb_jq_full (L : Type*) [Field L] [Algebra ℚ L]
+    (N : ℕ) [NeZero N] :
+    FiniteDimensional (IntermediateField.adjoin L ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L
+      (jq_mem_full N)⟩} : Set (laurentBaseChange L (modularFunctionFieldFull N))))
+      (laurentBaseChange L (modularFunctionFieldFull N)) :=
+  solution L N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_of_neZero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_of_neZero.lean
new file mode 100644
index 0000000000..48c71cc8f6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_of_neZero.lean
@@ -0,0 +1,227 @@
+/-
+Based on Prove2Me node ModularCurve.finiteDimensional_adjoin_coeffEmb_jq_of_neZero
+(5a36e624-935b-5204-9d3e-4d7a975d19a0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 09f1c3b1-7ff5-5a17-9b4d-f17ae83253d0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CuspidalClass
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ArithmeticGalois
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlace
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_modularPolynomialData
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finiteness of the level-M modular function field over ℚ̄(j)
+
+Theorem statement: `ModularCurve.finiteDimensional_adjoin_coeffEmb_jq_of_neZero`
+(`5a36e624-935b-5204-9d3e-4d7a975d19a0`), by Claude, 2026-09-05.
+
+Proof: submission `09f1c3b1-7ff5-5a17-9b4d-f17ae83253d0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a nonzero natural number. Write $\bar{\mathbb{Q}}$ for `AlgebraicClosure ℚ`, and let
+`coeffEmb` $\bar{\mathbb{Q}}$ denote the ring homomorphism $\mathrm{LaurentSeries}(\mathbb{Q}) \to
+\mathrm{LaurentSeries}(\bar{\mathbb{Q}})$ obtained by applying the structure map $\mathbb{Q} \to
+\bar{\mathbb{Q}}$ to each coefficient of a Hahn series. The field `modularFunctionFieldBar M` is the
+intermediate field of $\mathrm{LaurentSeries}(\bar{\mathbb{Q}})/\bar{\mathbb{Q}}$ generated over
+$\bar{\mathbb{Q}}$ by the image under this coefficientwise embedding of `modularFunctionFieldFull
+M`, the intermediate field of $\mathrm{LaurentSeries}(\mathbb{Q})/\mathbb{Q}$ generated by the set
+`divisorExpansions M`. Inside it sits the element determined by `coeffEmb` $\bar{\mathbb{Q}}$
+applied to `jq`, the Laurent series $q^{-1}\cdot(\text{ofPowerSeries of } \mathtt{jNumQ})$ over
+$\mathbb{Q}$, i.e. the $q$-expansion of the modular invariant $j$; its membership in
+`modularFunctionFieldBar M` comes from `jq_mem_full M` together with
+`coeffEmb_mem_laurentBaseChange`. The assertion is that `modularFunctionFieldBar M` is
+finite-dimensional as a vector space over the intermediate field $\bar{\mathbb{Q}}(j)$ obtained by
+adjoining this single element to $\bar{\mathbb{Q}}$ inside `modularFunctionFieldBar M`.
+
+This is the statement that the modular function field of level $M$, after base change to
+$\bar{\mathbb{Q}}$ and realised inside Laurent series in $q$, is a finite extension of the rational
+function field generated by the $j$-expansion — the algebraic counterpart of the finiteness of the
+covering $X(M) \to X(1)$ in the $j$-line. It is the general-level form of the prime-level finiteness
+statement and underlies the construction of the function field of the modular curve used in the
+Deligne–Rapoport model packages later in the development.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_of_neZero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_of_neZero
+
+open ModularCurve
+
+namespace BFall
+
+open IntermediateField Polynomial
+
+theorem coeffEmb_algebraMap (L : Type*) [Field L] [Algebra ℚ L] (r : ℚ) :
+    coeffEmb L (algebraMap ℚ (LaurentSeries ℚ) r) =
+      algebraMap L (LaurentSeries L) (algebraMap ℚ L r) := by
+  rw [ModularCurve.algebraMap_apply_eq_single, algebraMap_laurentSeries_eq_single, coeffEmb,
+    coeffMap_single]
+
+theorem laurentBaseChange_full_eq_adjoin (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) :
+    laurentBaseChange L (modularFunctionFieldFull N) =
+      IntermediateField.adjoin L (⇑(coeffEmb L) '' divisorExpansions N) := by
+  apply le_antisymm
+  · rw [laurentBaseChange, adjoin_le_iff]
+    rintro _ ⟨x, hx, rfl⟩
+    have hx' : x ∈ (modularFunctionFieldFull N).toSubfield := hx
+    rw [modularFunctionFieldFull, adjoin_toSubfield] at hx'
+    have hmem : coeffEmb L x ∈ (Subfield.closure
+        (Set.range (algebraMap ℚ (LaurentSeries ℚ)) ∪ divisorExpansions N)).map (coeffEmb L) :=
+      ⟨x, hx', rfl⟩
+    rw [RingHom.map_field_closure] at hmem
+    refine (Subfield.closure_le.2 ?_) hmem
+    rintro _ ⟨y, hy, rfl⟩
+    rcases hy with ⟨r, rfl⟩ | hy
+    · rw [coeffEmb_algebraMap]
+      exact (IntermediateField.adjoin L _).algebraMap_mem _
+    · exact IntermediateField.subset_adjoin L _ ⟨y, hy, rfl⟩
+  · rw [adjoin_le_iff]
+    rintro _ ⟨y, hy, rfl⟩
+    exact coeffEmb_mem_laurentBaseChange L (IntermediateField.subset_adjoin ℚ _ hy)
+
+set_option synthInstance.maxHeartbeats 1600000 in
+theorem finiteDimensional_adjoin_coeffEmb_jq (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N]
+    (hjq : jq ∈ modularFunctionFieldFull N) :
+    FiniteDimensional
+      (IntermediateField.adjoin L
+        ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L hjq⟩} :
+          Set (laurentBaseChange L (modularFunctionFieldFull N))))
+      (laurentBaseChange L (modularFunctionFieldFull N)) := by
+  classical
+  let ι : Type := {d : ℕ // d ∣ N ∧ d ≠ 0}
+  have : Finite ι := by
+    refine Finite.of_injective (fun d : ι => (⟨d.1, ?_⟩ : Fin (N + 1))) ?_
+    · exact Nat.lt_succ_of_le (Nat.le_of_dvd (Nat.pos_of_ne_zero (NeZero.ne N)) d.2.1)
+    · intro d d' h
+      exact Subtype.ext (by simpa using congrArg Fin.val h)
+  let g : ι → laurentBaseChange L (modularFunctionFieldFull N) := fun d =>
+    haveI : NeZero d.1 := ⟨d.2.2⟩
+    ⟨coeffEmb L (qExpand ℚ d.1 jq), coeffEmb_mem_laurentBaseChange L (jqd_mem_full N d.2.1)⟩
+  have hgval : ∀ d : ι, ((g d : laurentBaseChange L (modularFunctionFieldFull N)) : LaurentSeries L)
+    =
+      haveI : NeZero d.1 := ⟨d.2.2⟩; coeffEmb L (qExpand ℚ d.1 jq) := fun d => rfl
+  let J : laurentBaseChange L (modularFunctionFieldFull N) :=
+    ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L hjq⟩
+  have hint : ∀ d : ι, IsIntegral
+      (IntermediateField.adjoin L ({J} : Set (laurentBaseChange L (modularFunctionFieldFull N)))) (g
+        d) := by
+    rintro ⟨d, hdvd, hd0⟩
+    have : NeZero d := ⟨hd0⟩
+    obtain ⟨data⟩ := ModularCurve.nonempty_modularPolynomialData d
+    let J' : IntermediateField.adjoin L ({J} : Set (laurentBaseChange L (modularFunctionFieldFull
+      N))) :=
+      ⟨J, IntermediateField.mem_adjoin_simple_self L J⟩
+    let ψ : Polynomial ℤ →+*
+        IntermediateField.adjoin L ({J} : Set (laurentBaseChange L (modularFunctionFieldFull N))) :=
+      Polynomial.eval₂RingHom (Int.castRingHom _) J'
+    refine ⟨data.Φ.map ψ, data.monic.map ψ, ?_⟩
+    have hv : Function.Injective
+        (algebraMap (laurentBaseChange L (modularFunctionFieldFull N)) (LaurentSeries L)) :=
+      (algebraMap (laurentBaseChange L (modularFunctionFieldFull N)) (LaurentSeries L)).injective
+    apply hv
+    have hcomp : ((algebraMap (laurentBaseChange L (modularFunctionFieldFull N)) (LaurentSeries
+      L)).comp
+        (algebraMap (IntermediateField.adjoin L ({J} : Set (laurentBaseChange L
+          (modularFunctionFieldFull N))))
+          (laurentBaseChange L (modularFunctionFieldFull N)))).comp ψ =
+        (coeffEmb L).comp evalAtJ := by
+      refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+      rw [RingHom.comp_apply, RingHom.comp_apply, RingHom.comp_apply, evalAtJ_X]
+      change (algebraMap _ (LaurentSeries L)) (algebraMap _ _ (Polynomial.eval₂ (Int.castRingHom _)
+        J' X)) =
+        coeffEmb L jq
+      rw [Polynomial.eval₂_X]
+      rfl
+    rw [map_zero, Polynomial.hom_eval₂, Polynomial.eval₂_map, hcomp]
+    change Polynomial.eval₂ ((coeffEmb L).comp evalAtJ) (coeffEmb L (qExpand ℚ d jq)) data.Φ = 0
+    rw [← Polynomial.hom_eval₂]
+    have h0 : Polynomial.eval₂ evalAtJ (qExpand ℚ d jq) data.Φ = 0 := data.eval_eq_zero
+    rw [h0, map_zero]
+  have hgen : IntermediateField.adjoin
+      (IntermediateField.adjoin L ({J} : Set (laurentBaseChange L (modularFunctionFieldFull N))))
+      (Set.range g) = ⊤ := by
+    apply IntermediateField.restrictScalars_injective L
+    rw [IntermediateField.restrictScalars_top, IntermediateField.adjoin_adjoin_left]
+    apply IntermediateField.lift_injective
+    erw [IntermediateField.lift_adjoin, IntermediateField.lift_top]
+    apply le_antisymm
+    · rw [adjoin_le_iff]
+      rintro _ ⟨y, _, rfl⟩
+      exact y.2
+    · conv_lhs => rw [laurentBaseChange_full_eq_adjoin]
+      rw [adjoin_le_iff]
+      rintro _ ⟨x, ⟨d, hd0, hdvd, rfl⟩, rfl⟩
+      apply IntermediateField.subset_adjoin
+      refine ⟨g ⟨d, hdvd, hd0.ne⟩, Or.inr ⟨⟨d, hdvd, hd0.ne⟩, rfl⟩, ?_⟩
+      rfl
+  have hfin : FiniteDimensional
+      (IntermediateField.adjoin L ({J} : Set (laurentBaseChange L (modularFunctionFieldFull N))))
+      (IntermediateField.adjoin
+        (IntermediateField.adjoin L ({J} : Set (laurentBaseChange L (modularFunctionFieldFull N))))
+        (Set.range g)) :=
+    IntermediateField.finiteDimensional_adjoin fun y hy => by
+      obtain ⟨d, rfl⟩ := hy
+      exact hint d
+  rw [hgen] at hfin
+  exact LinearEquiv.finiteDimensional
+    (IntermediateField.topEquiv :
+      (⊤ : IntermediateField
+        (IntermediateField.adjoin L ({J} : Set (laurentBaseChange L (modularFunctionFieldFull N))))
+        (laurentBaseChange L (modularFunctionFieldFull N))) ≃ₐ[_]
+        laurentBaseChange L (modularFunctionFieldFull N)).toLinearEquiv
+
+end BFall
+
+open ModularCurve AlgebraicCurve
+
+theorem solution (M : ℕ) [NeZero M] :
+    FiniteDimensional
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({⟨coeffEmb (AlgebraicClosure ℚ) jq,
+            coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full M)⟩}
+          : Set (modularFunctionFieldBar M)))
+      (modularFunctionFieldBar M) :=
+  BFall.finiteDimensional_adjoin_coeffEmb_jq (AlgebraicClosure ℚ) M (jq_mem_full M)
+
+end S_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_of_neZero
+end P2MW
+export P2MW.S_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_of_neZero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.finiteDimensional_adjoin_coeffEmb_jq_of_neZero (M : ℕ) [NeZero M] :
+    FiniteDimensional
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({⟨coeffEmb (AlgebraicClosure ℚ) jq,
+            coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full M)⟩}
+          : Set (modularFunctionFieldBar M)))
+      (modularFunctionFieldBar M) :=
+  solution M
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finiteDimensional_adjoin_jqNModC.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finiteDimensional_adjoin_jqNModC.lean
new file mode 100644
index 0000000000..221720acb1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finiteDimensional_adjoin_jqNModC.lean
@@ -0,0 +1,197 @@
+/-
+Based on Prove2Me node ModularCurve.finiteDimensional_adjoin_jqNModC
+(1d670ead-b8cc-5c2d-af54-25ba60e516ed) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 65a1d61a-f000-59bd-848f-83776e8c0c57
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_injective
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finiteness of K(j)bigl(j(q^N)bigr) over K(j)
+
+Theorem statement: `ModularCurve.finiteDimensional_adjoin_jqNModC`
+(`1d670ead-b8cc-5c2d-af54-25ba60e516ed`), by Claude, 2026-09-05.
+
+Proof: submission `65a1d61a-f000-59bd-848f-83776e8c0c57`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, let $N$ be a natural number with $N \neq 0$, and let `data` be a
+`ModularPolynomialData N`, that is: a polynomial $\Phi \in \mathbb{Z}[X][Y]$ which is monic in $Y$,
+whose degree in $Y$ equals $\psi(N) = \sum_{d \mid N,\ d \text{ squarefree}} N/d$, and which
+satisfies $\Phi(j, j_N) = 0$ in $\mathrm{LaurentSeries}(\mathbb{Q})$, where the coefficients in
+$\mathbb{Z}[X]$ are evaluated at the rational $q$-expansion $j$ via `evalAtJ` and the outer variable
+at `jqN N`. Inside the Laurent series field $\mathrm{LaurentSeries}(K)$ consider the element
+$\mathrm{jqModC}\,K = q^{-1} \cdot (E_4^3 \cdot \eta\text{-unit-inverse})$, the $q$-expansion of the
+modular invariant with coefficients pushed from $\mathbb{Z}$ to $K$, and $\mathrm{jqNModC}\,K\,N$,
+its image under the ring homomorphism `qExpand` of $\mathrm{LaurentSeries}(K)$ which multiplies all
+exponents by $N$ (substitution $q \mapsto q^N$). The assertion is that the intermediate field
+obtained by adjoining $\mathrm{jqNModC}\,K\,N$ to $E = K(\mathrm{jqModC}\,K)$ is finite-dimensional
+over $E$. Only finiteness is asserted; no numerical bound on the degree appears in the conclusion.
+
+This is the statement that $j(q^N)$ is algebraic over the field generated by $j$ over $K$, the
+finiteness underlying the description of the function field of $X_0(N)$ as a finite extension of
+$K(j)$. It is used by the places-and-degrees computations for that function field, for instance in
+the cuspidal divisor class and local-chart statements that compute sums of $e \cdot f$ over $K(j)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finiteDimensional_adjoin_jqNModC.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_finiteDimensional_adjoin_jqNModC
+
+noncomputable section
+
+open Polynomial IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqN dedekindPsi evalAtJ evalAtJ_X ModularPolynomialData coeffMap jqModC \
+  jqNModC jqModC_rat map_jqModC coeffMap_qExpand coeffMap_injective"
+p2m_open "ModularCurve"
+
+section Transport
+
+variable (R : Type*) [CommRing R] (N : ℕ) [NeZero N]
+
+private def phiAt (Φ : Polynomial (Polynomial ℤ)) : LaurentSeries R :=
+  Φ.eval₂ (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries R)) (jqModC R)) (jqNModC R N)
+
+private theorem coeffMap_eq_map {S : Type*} [CommRing S] (f : R →+* S) (x : LaurentSeries R) :
+    coeffMap f x = x.map f := rfl
+
+private theorem coeffMap_phiAt {S : Type*} [CommRing S] (f : R →+* S)
+    (Φ : Polynomial (Polynomial ℤ)) :
+    coeffMap f (phiAt R N Φ) = phiAt S N Φ := by
+  unfold phiAt
+  rw [Polynomial.hom_eval₂]
+  have hj : coeffMap f (jqModC R) = jqModC S := by rw [coeffMap_eq_map, map_jqModC]
+  have hjN : coeffMap f (jqNModC R N) = jqNModC S N := by
+    rw [jqNModC, jqNModC, coeffMap_qExpand, hj]
+  rw [hjN]
+  congr 1
+  refine Polynomial.ringHom_ext (fun a => ?_) ?_
+  · simp
+  · simp [hj]
+
+end Transport
+
+section OverQ
+
+variable (N : ℕ) [NeZero N]
+
+private theorem phiAt_rat (Φ : Polynomial (Polynomial ℤ)) :
+    phiAt ℚ N Φ = Φ.eval₂ evalAtJ (jqN N) := by
+  unfold phiAt
+  have hN : jqNModC ℚ N = jqN N := rfl
+  rw [hN]
+  congr 1
+  refine Polynomial.ringHom_ext (fun a => ?_) ?_
+  · simp [evalAtJ]
+  · rw [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X, evalAtJ_X, jqModC_rat]
+
+private theorem phiAt_eq_zero (K : Type*) [Field K] (data : ModularPolynomialData N) :
+    phiAt K N data.Φ = 0 := by
+  have hZ : phiAt ℤ N data.Φ = 0 := by
+    apply coeffMap_injective (f := Int.castRingHom ℚ) (RingHom.injective_int (Int.castRingHom ℚ))
+    rw [coeffMap_phiAt, map_zero, phiAt_rat, data.eval_eq_zero]
+  rw [← coeffMap_phiAt ℤ N (Int.castRingHom K), hZ, map_zero]
+
+end OverQ
+
+section Degree
+
+variable (K : Type*) [Field K] {N : ℕ} [NeZero N]
+
+private def phiOver (Φ : Polynomial (Polynomial ℤ)) :
+    Polynomial (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) :=
+  Φ.map (Polynomial.eval₂RingHom (Int.castRingHom _)
+    (⟨jqModC K, IntermediateField.subset_adjoin K _ (Set.mem_singleton _)⟩ :
+      IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))))
+
+private theorem aeval_phiOver (Φ : Polynomial (Polynomial ℤ)) :
+    Polynomial.aeval (jqNModC K N) (phiOver K Φ) = phiAt K N Φ := by
+  rw [Polynomial.aeval_def, phiOver, Polynomial.eval₂_map]
+  unfold phiAt
+  congr 1
+  refine Polynomial.ringHom_ext (fun a => ?_) ?_
+  · simp
+  · simp only [RingHom.coe_comp, Function.comp_apply, Polynomial.coe_eval₂RingHom,
+      Polynomial.eval₂_X]
+    rfl
+
+theorem finrank_adjoin_jqNModC_le (data : ModularPolynomialData N) :
+    Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+        ({jqNModC K N} : Set (LaurentSeries K))) ≤ dedekindPsi N := by
+  set E := IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))
+  have hmonic : (phiOver K data.Φ).Monic := data.monic.map _
+  have hroot : Polynomial.aeval (jqNModC K N) (phiOver K data.Φ) = 0 := by
+    rw [aeval_phiOver, phiAt_eq_zero]
+  have hint : IsIntegral E (jqNModC K N) :=
+    ⟨phiOver K data.Φ, hmonic, by rwa [← Polynomial.aeval_def]⟩
+  rw [IntermediateField.adjoin.finrank hint, ← data.natDegree_eq, ← (data.monic.natDegree_map _ :
+    (phiOver K data.Φ).natDegree = _)]
+  exact Polynomial.natDegree_le_of_dvd (minpoly.dvd E _ hroot) hmonic.ne_zero
+
+private theorem finiteDimensional_adjoin_jqNModC (data : ModularPolynomialData N) :
+    FiniteDimensional (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+        ({jqNModC K N} : Set (LaurentSeries K))) := by
+  have hmonic : (phiOver K data.Φ).Monic := data.monic.map _
+  have hroot : Polynomial.aeval (jqNModC K N) (phiOver K data.Φ) = 0 := by
+    rw [aeval_phiOver, phiAt_eq_zero]
+  exact IntermediateField.adjoin.finiteDimensional ⟨phiOver K data.Φ, hmonic, by rwa [←
+    Polynomial.aeval_def]⟩
+
+end Degree
+
+end ModularCurve
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_finiteDimensional_adjoin_jqNModC.ModularCurve in
+theorem solution (K : Type*) [Field K] {N : ℕ} [NeZero N] (data : ModularPolynomialData N) :
+    FiniteDimensional (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      ({jqNModC K N} : Set (LaurentSeries K))) :=
+  ModularCurve.finiteDimensional_adjoin_jqNModC K data
+
+end S_ModularCurve_finiteDimensional_adjoin_jqNModC
+end P2MW
+export P2MW.S_ModularCurve_finiteDimensional_adjoin_jqNModC (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.finiteDimensional_adjoin_jqNModC (K : Type*) [Field K] {N : ℕ} [NeZero N]
+    (data : ModularPolynomialData N) :
+    FiniteDimensional (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      ({jqNModC K N} : Set (LaurentSeries K))) :=
+  solution K data
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finiteDimensional_and_finrank_adjoin_jqModC_qExpFunctionFieldC_le_index.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finiteDimensional_and_finrank_adjoin_jqModC_qExpFunctionFieldC_le_index.lean
new file mode 100644
index 0000000000..6ccb4450f0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finiteDimensional_and_finrank_adjoin_jqModC_qExpFunctionFieldC_le_index.lean
@@ -0,0 +1,509 @@
+/-
+Based on Prove2Me node
+ModularCurve.finiteDimensional_and_finrank_adjoin_jqModC_qExpFunctionFieldC_le_index
+(da6f3bde-beb3-5d0b-b5b9-58f863f595fa) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d37a3798-d506-5900-a157-8796984b00d1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Algebra.Algebra.ZMod
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_ReductionMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_transcendental_finiteDimensional_qExpFunctionFieldC_residueField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_and_finrank_adjoin_le_of_eq_coeffMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_le_index
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_mem_intFormRatiosC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ValuationSubring_exists_liesOverPrime_algebraicClosure_rat
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0ModL
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree of the q-expansion function field over the j-line
+
+Theorem statement:
+`ModularCurve.finiteDimensional_and_finrank_adjoin_jqModC_qExpFunctionFieldC_le_index`
+(`da6f3bde-beb3-5d0b-b5b9-58f863f595fa`), by Claude, 2026-09-05.
+
+Proof: submission `d37a3798-d506-5900-a157-8796984b00d1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, let $\Gamma \le \mathrm{SL}(2,\mathbb{Z})$ be a subgroup of finite index
+containing the translation matrix `ModularGroup.T`, and let $\Gamma' \le \mathrm{SL}(2,\mathbb{Z})$
+be a subgroup with $\Gamma \le \Gamma'$ such that every $\gamma \in \Gamma'$ satisfies $\gamma \in
+\Gamma$ or $-\gamma \in \Gamma$ (so $\Gamma'$ lies between $\Gamma$ and $\pm\Gamma$). Write $F =$
+[`ModularCurve.qExpFunctionFieldC K Γ`](def/ModularCurve_X1.html#L101) for the intermediate field of
+the Laurent series field $K((q))$ generated over $K$ by the set `intFormRatiosC K Γ`, namely by all
+quotients `intSeriesC K pf / intSeriesC K pg` where $k \in \mathbb{Z}$, $f$ and $g$ are modular
+forms of weight $k$ for the image of $\Gamma$ in $\mathrm{GL}(2,\mathbb{R})$, and $p_f, p_g$ are
+power series over $\mathbb{Z}$ satisfying the predicate `IsIntegralQExp` for $f$ and for $g$
+respectively, with `intSeriesC K pg ≠ 0`. Let $x \in F$ be an element whose underlying Laurent
+series is [`ModularCurve.jqModC K`](def/ModularCurve_JqCoeff.html#L15), that is $q^{-1}$ times the
+image over $K$ of the integral power series `jNum` $=$ `eisenstein4 ^ 3 * dedekindEtaUnitInv`. Then
+$F$ is finite-dimensional over the subfield $K(x)$ obtained by adjoining $x$ to $K$, and $[F : K(x)]
+\le [\mathrm{SL}(2,\mathbb{Z}) : \Gamma']$.
+
+This is the field-independent form of the classical upper bound for the degree of the modular curve
+$X(\Gamma)$ over the $j$-line, with the bound given by the index of a subgroup between $\Gamma$ and
+$\pm\Gamma$ rather than of $\Gamma$ itself. It underlies the computations of degrees and of function
+fields of modular curves over arbitrary base fields used later in the formalisation, and is cited by
+the index computations for $\Gamma_0(N)$ and by the study of the Igusa models at level $N$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finiteDimensional_and_finrank_adjoin_jqModC_qExpFunctionFieldC_le_index.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 6400000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_55825ce2
+
+
+noncomputable section
+
+namespace P2MKcQExpDeg
+
+open ModularCurve IntermediateField Polynomial
+
+section Transfer
+
+variable {κ k : Type*} [Field κ] [Field k] (φ : κ →+* k)
+
+abbrev Φ : LaurentSeries κ →+* LaurentSeries k := coeffMap φ
+
+theorem Φ_injective : Function.Injective (Φ φ) := by
+  intro x y h
+  ext n
+  have h1 := congrArg (fun s : LaurentSeries k => s.coeff n) h
+  simp only [coeffMap_coeff] at h1
+  exact φ.injective h1
+
+theorem Φ_ne_zero_iff (x : LaurentSeries κ) : Φ φ x ≠ 0 ↔ x ≠ 0 := by
+  rw [Ne, ← map_zero (Φ φ), (Φ_injective φ).eq_iff]
+
+theorem Φ_intSeriesC (p : PowerSeries ℤ) : Φ φ (intSeriesC κ p) = intSeriesC k p := by
+  rw [intSeriesC, intSeriesC, coeffMap_ofPowerSeries]
+  congr 1
+  ext n
+  simp [PowerSeries.coeff_map]
+
+theorem algebraMap_laurentSeries_eq_C {K : Type*} [Field K] (a : K) :
+    algebraMap K (LaurentSeries K) a = HahnSeries.C a := by
+  rw [HahnSeries.algebraMap_apply']
+  have h1 : algebraMap K (PowerSeries K) a = PowerSeries.C a := by simp
+  rw [h1, HahnSeries.ofPowerSeries_C]
+
+theorem Φ_algebraMap (a : κ) :
+    Φ φ (algebraMap κ (LaurentSeries κ) a) = algebraMap k (LaurentSeries k) (φ a) := by
+  rw [algebraMap_laurentSeries_eq_C, algebraMap_laurentSeries_eq_C, HahnSeries.C_apply,
+    HahnSeries.C_apply,
+    coeffMap_single]
+
+theorem coe_mem_adjoin_of_mem_adjoin {K L : Type*} [Field K] [Field L] [Algebra K L]
+    (F : IntermediateField K L) (x : F) {y : F} (hy : y ∈ adjoin K ({x} : Set F)) :
+    (y : L) ∈ adjoin K ({(x : L)} : Set L) := by
+  have h : (y : L) ∈ (adjoin K ({x} : Set F)).map F.val := ⟨y, hy, rfl⟩
+  rwa [adjoin_map, Set.image_singleton] at h
+
+variable (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+
+theorem image_intFormRatiosC : (Φ φ) '' intFormRatiosC κ Γ = intFormRatiosC k Γ := by
+  ext z
+  constructor
+  · rintro ⟨y, ⟨w, f, g, pf, pg, hf, hg, hg0, rfl⟩, rfl⟩
+    refine ⟨w, f, g, pf, pg, hf, hg, ?_, ?_⟩
+    · rw [← Φ_intSeriesC φ]; exact (Φ_ne_zero_iff φ _).mpr hg0
+    · rw [map_div₀, Φ_intSeriesC, Φ_intSeriesC]
+  · rintro ⟨w, f, g, pf, pg, hf, hg, hg0, rfl⟩
+    refine ⟨intSeriesC κ pf / intSeriesC κ pg, ⟨w, f, g, pf, pg, hf, hg, ?_, rfl⟩, ?_⟩
+    · rw [← Φ_ne_zero_iff φ, Φ_intSeriesC]; exact hg0
+    · rw [map_div₀, Φ_intSeriesC, Φ_intSeriesC]
+
+variable {Γ}
+
+theorem map_mem_adjoin {S : Set (LaurentSeries κ)} {y : LaurentSeries κ} (hy : y ∈ adjoin κ S) :
+    Φ φ y ∈ adjoin k ((Φ φ) '' S) := by
+  have hy' : y ∈ (adjoin κ S).toSubfield := hy
+  rw [adjoin_toSubfield] at hy'
+  have hle : Subfield.closure (Set.range (algebraMap κ (LaurentSeries κ)) ∪ S) ≤
+      (adjoin k ((Φ φ) '' S)).toSubfield.comap (Φ φ) := by
+    rw [Subfield.closure_le]
+    rintro z (⟨a, rfl⟩ | hz)
+    · change Φ φ (algebraMap κ (LaurentSeries κ) a) ∈ adjoin k ((Φ φ) '' S)
+      rw [Φ_algebraMap]
+      exact IntermediateField.algebraMap_mem _ _
+    · change Φ φ z ∈ adjoin k ((Φ φ) '' S)
+      exact subset_adjoin k _ ⟨z, hz, rfl⟩
+  exact hle hy'
+
+theorem map_mem_qExpFunctionFieldC {y : LaurentSeries κ} (hy : y ∈ qExpFunctionFieldC κ Γ) :
+    Φ φ y ∈ qExpFunctionFieldC k Γ := by
+  have h := map_mem_adjoin φ hy
+  rwa [image_intFormRatiosC] at h
+
+variable (Γ)
+
+local notation "Fκ" => qExpFunctionFieldC κ Γ
+local notation "Fk" => qExpFunctionFieldC k Γ
+
+include φ in
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+theorem transfer (x : Fκ) (hx : (x : LaurentSeries κ) = jqModC κ)
+    (x' : Fk) (hx' : (x' : LaurentSeries k) = jqModC k)
+    (hfd : FiniteDimensional (adjoin κ ({x} : Set Fκ)) Fκ) :
+    FiniteDimensional (adjoin k ({x'} : Set Fk)) Fk ∧
+      Module.finrank (adjoin k ({x'} : Set Fk)) Fk ≤ Module.finrank (adjoin κ ({x} : Set Fκ)) Fκ
+        := by
+  classical
+  have hjk : jqModC k ∈ Fk := intFormRatiosC_subset k Γ (ModularCurve.jqModC_mem_intFormRatiosC k Γ)
+  have hΦx : Φ φ (x : LaurentSeries κ) = jqModC k := by rw [hx, coeffMap_jqModC]
+  set Lκ : IntermediateField κ Fκ := adjoin κ ({x} : Set Fκ) with hLκ
+  set K₀ : IntermediateField k Fk := adjoin k ({x'} : Set Fk) with hK₀
+  set K₁ : IntermediateField k (LaurentSeries k) := adjoin k ({jqModC k} : Set (LaurentSeries k))
+    with hK₁
+  have : FiniteDimensional Lκ Fκ := hfd
+  let ψ₀ : Lκ →+* LaurentSeries k :=
+    (Φ φ).comp (((qExpFunctionFieldC κ Γ).val : Fκ →+* LaurentSeries κ).comp (algebraMap Lκ Fκ))
+  have hψ₀ : ∀ a : Lκ, ψ₀ a = Φ φ ((a : Fκ) : LaurentSeries κ) := fun a => rfl
+  have hLκmap : ∀ a : Lκ, ((a : Fκ) : LaurentSeries κ) ∈
+      adjoin κ ({(x : LaurentSeries κ)} : Set (LaurentSeries κ)) :=
+    fun a => coe_mem_adjoin_of_mem_adjoin (qExpFunctionFieldC κ Γ) x a.2
+  have hψ₀mem : ∀ a : Lκ, ψ₀ a ∈ K₁ := by
+    intro a
+    rw [hψ₀]
+    have h := map_mem_adjoin φ (hLκmap a)
+    rwa [Set.image_singleton, hΦx] at h
+  let ψ : Lκ →+* K₁ := ψ₀.codRestrict K₁ hψ₀mem
+  have hψval : ∀ a : Lκ, ((ψ a : K₁) : LaurentSeries k) = Φ φ ((a : Fκ) : LaurentSeries κ) :=
+    fun a => rfl
+  set n := Module.finrank Lκ Fκ with hn
+  let v := Module.finBasis Lκ Fκ
+  let w : Fin n → LaurentSeries k := fun i => Φ φ ((v i : Fκ) : LaurentSeries κ)
+  set S : Submodule K₁ (LaurentSeries k) := Submodule.span K₁ (Set.range w) with hS
+  have hSfin : Module.Finite K₁ S := Module.Finite.span_of_finite K₁ (Set.finite_range w)
+  have hSrank : Module.finrank K₁ S ≤ n := (finrank_range_le_card w).trans (by simp)
+  have hsub : ∀ y : LaurentSeries κ, y ∈ Fκ → Φ φ y ∈ S := by
+    intro y hy
+    obtain ⟨c, hc⟩ := (Submodule.mem_span_range_iff_exists_fun Lκ).mp
+      (show (⟨y, hy⟩ : Fκ) ∈ Submodule.span Lκ (Set.range v) by rw [v.span_eq]; trivial)
+    have hy' : y = ∑ i, ((c i : Fκ) : LaurentSeries κ) * ((v i : Fκ) : LaurentSeries κ) := by
+      have h := congrArg (fun z : Fκ => (z : LaurentSeries κ)) hc
+      simp only at h
+      rw [← h, AddSubmonoidClass.coe_finsetSum]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [IntermediateField.smul_def, smul_eq_mul, MulMemClass.coe_mul]
+    rw [hy', map_sum]
+    refine Submodule.sum_mem _ fun i _ => ?_
+    rw [map_mul]
+    have : Φ φ ((c i : Fκ) : LaurentSeries κ) * w i = (ψ (c i)) • w i := by
+      rw [IntermediateField.smul_def, smul_eq_mul, hψval]
+    rw [this]
+    exact Submodule.smul_mem _ _ (Submodule.subset_span ⟨i, rfl⟩)
+  have hone : (1 : LaurentSeries k) ∈ S := by
+    have h := hsub 1 (one_mem _)
+    rwa [map_one] at h
+  have hww : ∀ i j, w i * w j ∈ S := by
+    intro i j
+    have h := hsub (((v i : Fκ) : LaurentSeries κ) * ((v j : Fκ) : LaurentSeries κ))
+      (mul_mem (v i).2 (v j).2)
+    rwa [map_mul] at h
+  have hmul : ∀ a b : LaurentSeries k, a ∈ S → b ∈ S → a * b ∈ S := by
+    intro a b ha hb
+    induction ha using Submodule.span_induction with
+    | mem t ht =>
+      obtain ⟨i, rfl⟩ := ht
+      induction hb using Submodule.span_induction with
+      | mem t' ht' => obtain ⟨j, rfl⟩ := ht'; exact hww i j
+      | zero => rw [mul_zero]; exact zero_mem _
+      | add b₁ b₂ _ _ h₁ h₂ => rw [mul_add]; exact add_mem h₁ h₂
+      | smul r b _ h => rw [mul_smul_comm]; exact Submodule.smul_mem _ _ h
+    | zero => rw [zero_mul]; exact zero_mem _
+    | add a₁ a₂ _ _ h₁ h₂ => rw [add_mul]; exact add_mem h₁ h₂
+    | smul r a _ h => rw [smul_mul_assoc]; exact Submodule.smul_mem _ _ h
+  have hinv : ∀ a : LaurentSeries k, a ∈ S → a⁻¹ ∈ S := by
+    intro a ha
+    by_cases ha0 : a = 0
+    · rw [ha0, inv_zero]; exact zero_mem _
+    let μ : S →ₗ[K₁] S :=
+      { toFun := fun s => ⟨a * s, hmul a s ha s.2⟩
+        map_add' := fun s t => by apply Subtype.ext; simp [mul_add]
+        map_smul' := fun r s => by
+          apply Subtype.ext
+          simp only [SetLike.val_smul, RingHom.id_apply]
+          rw [mul_smul_comm] }
+    have hμinj : Function.Injective μ := by
+      intro s t h
+      have h' := congrArg Subtype.val h
+      simp only [μ, LinearMap.coe_mk, AddHom.coe_mk] at h'
+      exact Subtype.ext (mul_left_cancel₀ ha0 h')
+    have hμsurj : Function.Surjective μ := LinearMap.injective_iff_surjective.mp hμinj
+    obtain ⟨t, ht⟩ := hμsurj ⟨1, hone⟩
+    have ht' : a * (t : LaurentSeries k) = 1 := congrArg Subtype.val ht
+    have : a⁻¹ = t := by rw [inv_eq_of_mul_eq_one_right ht']
+    rw [this]; exact t.2
+  let SF : IntermediateField k (LaurentSeries k) :=
+    { carrier := S
+      mul_mem' := fun {a b} ha hb => hmul a b ha hb
+      one_mem' := hone
+      add_mem' := fun {a b} ha hb => add_mem ha hb
+      zero_mem' := zero_mem _
+      algebraMap_mem' := fun r => by
+        change algebraMap k (LaurentSeries k) r ∈ S
+        rw [IsScalarTower.algebraMap_apply k K₁ (LaurentSeries k) r, Algebra.algebraMap_eq_smul_one]
+        exact Submodule.smul_mem _ _ hone
+      inv_mem' := fun a ha => hinv a ha }
+  have hFkS : Fk ≤ SF := by
+    change adjoin k (intFormRatiosC k Γ) ≤ SF
+    rw [adjoin_le_iff, ← image_intFormRatiosC φ Γ]
+    rintro _ ⟨y, hy, rfl⟩
+    exact hsub y (intFormRatiosC_subset κ Γ hy)
+  have hK₁F : K₁ ≤ Fk := by
+    rw [hK₁, adjoin_le_iff, Set.singleton_subset_iff]
+    exact hjk
+  let N₁ : IntermediateField K₁ (LaurentSeries k) := extendScalars hK₁F
+  have hN₁S : Subalgebra.toSubmodule N₁.toSubalgebra ≤ S := by
+    intro z hz
+    have hz' : z ∈ Fk := hz
+    exact hFkS hz'
+  have hfdN : FiniteDimensional K₁ N₁ :=
+    Module.Finite.of_injective (Submodule.inclusion hN₁S) (Submodule.inclusion_injective hN₁S)
+  have hrankN : Module.finrank K₁ N₁ ≤ n := by
+    have h1 : Module.finrank K₁ (Subalgebra.toSubmodule N₁.toSubalgebra) ≤ Module.finrank K₁ S :=
+      Submodule.finrank_mono hN₁S
+    exact h1.trans hSrank
+  have hmap : K₀.map (qExpFunctionFieldC k Γ).val = K₁ := by
+    have h := adjoin_map k ({x'} : Set Fk) (qExpFunctionFieldC k Γ).val
+    rw [Set.image_singleton] at h
+    rw [show (qExpFunctionFieldC k Γ).val x' = jqModC k from hx'] at h
+    exact h
+  let e₀ : K₀ ≃ₐ[k] K₁ := (K₀.equivMap (qExpFunctionFieldC k Γ).val).trans (equivOfEq hmap)
+  have he₀ : ∀ b : K₀, ((e₀ b : K₁) : LaurentSeries k) = ((b : Fk) : LaurentSeries k) := by
+    intro b
+    rfl
+  let e₂ : N₁ ≃+* Fk := RingEquiv.refl Fk
+  have hcomm : (algebraMap K₀ Fk).comp e₀.symm.toRingEquiv.toRingHom =
+      e₂.toRingHom.comp (algebraMap K₁ N₁) := by
+    refine RingHom.ext fun a => ?_
+    apply Subtype.ext
+    change (((e₀.symm a : K₀) : Fk) : LaurentSeries k) = (a : LaurentSeries k)
+    rw [← he₀ (e₀.symm a), AlgEquiv.apply_symm_apply]
+  refine ⟨Module.Finite.of_equiv_equiv (A₁ := K₁) (B₁ := N₁) (A₂ := K₀) (B₂ := Fk)
+    e₀.symm.toRingEquiv e₂ hcomm, ?_⟩
+  rw [← Algebra.finrank_eq_of_equiv_equiv (R₀ := K₁) (S₀ := N₁) (R₁ := K₀) (S₁ := Fk)
+    e₀.symm.toRingEquiv e₂ hcomm]
+  exact hrankN
+
+end Transfer
+
+section Residue
+
+variable (p : ℕ) [Fact p.Prime] (A : ValuationSubring (AlgebraicClosure ℚ)) (hA : A.LiesOverPrime p)
+
+include hA in
+theorem isAlgebraic_residueField :
+    letI : CharP (IsLocalRing.ResidueField A) p :=
+      ValuationSubring.charP_residueField_of_liesOverPrime_def
+      (Fact.out : p.Prime) hA
+    letI := ZMod.algebra (IsLocalRing.ResidueField A) p
+    Algebra.IsAlgebraic (ZMod p) (IsLocalRing.ResidueField A) := by
+  let : CharP (IsLocalRing.ResidueField A) p :=
+    ValuationSubring.charP_residueField_of_liesOverPrime_def
+    (Fact.out : p.Prime) hA
+  let := ZMod.algebra (IsLocalRing.ResidueField A) p
+  have hp : p.Prime := Fact.out
+  refine ⟨fun ybar => ?_⟩
+  obtain ⟨y, rfl⟩ := IsLocalRing.residue_surjective ybar
+  have hyQ : IsAlgebraic ℚ (y : AlgebraicClosure ℚ) := by
+    have h := (AlgebraicClosure.isAlgebraic ℚ).isAlgebraic (y : AlgebraicClosure ℚ)
+    convert h using 2
+  have hyalg : IsAlgebraic ℤ (y : AlgebraicClosure ℚ) :=
+    (IsFractionRing.isAlgebraic_iff ℤ ℚ (AlgebraicClosure ℚ)).mpr hyQ
+  obtain ⟨P, hP0, hPy⟩ := hyalg
+  set Q := P.primPart with hQ
+  have hc0 : P.content ≠ 0 := fun h => hP0 (content_eq_zero_iff.mp h)
+  have hQy : aeval (y : AlgebraicClosure ℚ) Q = 0 := by
+    have h1 : aeval (y : AlgebraicClosure ℚ) (C P.content * Q) = 0 := by
+      rw [← eq_C_content_mul_primPart]; exact hPy
+    rw [map_mul, aeval_C, mul_eq_zero] at h1
+    exact h1.resolve_left ((map_ne_zero_iff _ (RingHom.injective_int _)).mpr hc0)
+  have hQyA : eval₂ (Int.castRingHom A) y Q = 0 := by
+    have hinj : Function.Injective A.subtype := Subtype.val_injective
+    apply hinj
+    rw [hom_eval₂, map_zero]
+    have h2 : (A.subtype.comp (Int.castRingHom A)) = algebraMap ℤ (AlgebraicClosure ℚ) :=
+      RingHom.ext_int _ _
+    rw [h2]
+    exact hQy
+  set Qbar := Q.map (Int.castRingHom (ZMod p)) with hQbar
+  have hQbar0 : Qbar ≠ 0 := by
+    intro h0
+    have hdvd : ∀ i, (p : ℤ) ∣ Q.coeff i := by
+      intro i
+      have hi := congrArg (fun R : (ZMod p)[X] => R.coeff i) h0
+      simp only [hQbar, coeff_map, coeff_zero, eq_intCast] at hi
+      exact (ZMod.intCast_zmod_eq_zero_iff_dvd _ p).mp hi
+    have hunit : IsUnit (p : ℤ) :=
+      (isPrimitive_primPart P) (p : ℤ) ((C_dvd_iff_dvd_coeff _ _).mpr hdvd)
+    rw [Int.isUnit_iff_natAbs_eq, Int.natAbs_natCast] at hunit
+    exact hp.one_lt.ne' hunit
+  refine ⟨Qbar, hQbar0, ?_⟩
+  rw [aeval_def, hQbar, eval₂_map]
+  have h3 : (algebraMap (ZMod p) (IsLocalRing.ResidueField A)).comp (Int.castRingHom (ZMod p)) =
+      (IsLocalRing.residue A).comp (Int.castRingHom A) := RingHom.ext_int _ _
+  rw [h3, ← hom_eval₂, hQyA, map_zero]
+
+end Residue
+
+section CharZero
+
+variable (K : Type*) [Field K]
+
+theorem coe_eq_zero_of_mem_maximalIdeal_top {a : (⊤ : ValuationSubring K)}
+    (ha : a ∈ IsLocalRing.maximalIdeal (⊤ : ValuationSubring K)) : (a : K) = 0 := by
+  by_contra h
+  apply (IsLocalRing.mem_maximalIdeal _).mp ha
+  refine ⟨⟨a, ⟨(a : K)⁻¹, trivial⟩, ?_, ?_⟩, rfl⟩
+  · exact Subtype.ext (mul_inv_cancel₀ h)
+  · exact Subtype.ext (inv_mul_cancel₀ h)
+
+def residueTopHom : IsLocalRing.ResidueField (⊤ : ValuationSubring K) →+* K :=
+  Ideal.Quotient.lift (IsLocalRing.maximalIdeal (⊤ : ValuationSubring K)) (⊤ : ValuationSubring
+    K).subtype
+    fun _ ha => coe_eq_zero_of_mem_maximalIdeal_top K ha
+
+end CharZero
+
+section Bound
+
+open ModularCurve IntermediateField
+
+variable (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+  (hT : ModularGroup.T ∈ Γ)
+  (Γ' : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) (hΓ' : Γ ≤ Γ')
+  (hneg : ∀ γ ∈ Γ', γ ∈ Γ ∨ -γ ∈ Γ)
+
+include hT hΓ' hneg in
+theorem bound_of_isAlgClosed (K' : Type*) [Field K'] [IsAlgClosed K']
+    (x' : qExpFunctionFieldC K' Γ) (hx' : (x' : LaurentSeries K') = jqModC K') :
+    FiniteDimensional (adjoin K' ({x'} : Set (qExpFunctionFieldC K' Γ))) (qExpFunctionFieldC K' Γ) ∧
+      Module.finrank (adjoin K' ({x'} : Set (qExpFunctionFieldC K' Γ)))
+        (qExpFunctionFieldC K' Γ) ≤ Γ'.index := by
+  classical
+  obtain ⟨p, hchar⟩ := CharP.exists K'
+  rcases CharP.char_is_prime_or_zero K' p with hp | rfl
+  · have : Fact p.Prime := ⟨hp⟩
+    obtain ⟨A, hA⟩ := ValuationSubring.exists_liesOverPrime_algebraicClosure_rat ⟨p, hp⟩
+    have : CharP (IsLocalRing.ResidueField A) p :=
+      ValuationSubring.charP_residueField_of_liesOverPrime_def hp hA
+    let := ZMod.algebra (IsLocalRing.ResidueField A) p
+    let := ZMod.algebra K' p
+    have : Algebra.IsAlgebraic (ZMod p) (IsLocalRing.ResidueField A) :=
+      isAlgebraic_residueField p A hA
+    let φ : IsLocalRing.ResidueField A →+* K' :=
+      (IsAlgClosed.lift (R := ZMod p) (S := IsLocalRing.ResidueField A) (M := K')).toRingHom
+    obtain ⟨xκ, hxκ, -, hfd, hle⟩ :=
+      ModularCurve.exists_transcendental_finiteDimensional_qExpFunctionFieldC_residueField
+        (AlgebraicClosure ℚ) A Γ hT
+    have hy : jqModC (AlgebraicClosure ℚ) ∈
+        laurentBaseChange (AlgebraicClosure ℚ) (qExpFunctionFieldC ℚ Γ) := by
+      have h := coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (F₀ := qExpFunctionFieldC ℚ Γ)
+        (intFormRatiosC_subset ℚ Γ (ModularCurve.jqModC_mem_intFormRatiosC ℚ Γ))
+      rwa [coeffEmb, coeffMap_jqModC] at h
+    have hb := hle ⟨_, hy⟩ rfl
+    have hidx := ModularCurve.finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_le_index
+      (AlgebraicClosure ℚ) Γ hT Γ' hΓ' hneg ⟨_, hy⟩ rfl
+    obtain ⟨hfd', hle'⟩ := transfer φ Γ xκ hxκ x' hx' hfd
+    exact ⟨hfd', hle'.trans (hb.trans hidx)⟩
+  · have : CharZero K' := CharP.charP_to_charZero K'
+    obtain ⟨xκ, hxκ, -, hfd, hle⟩ :=
+      ModularCurve.exists_transcendental_finiteDimensional_qExpFunctionFieldC_residueField
+        K' (⊤ : ValuationSubring K') Γ hT
+    have hy : jqModC K' ∈ laurentBaseChange K' (qExpFunctionFieldC ℚ Γ) := by
+      have h := coeffEmb_mem_laurentBaseChange K' (F₀ := qExpFunctionFieldC ℚ Γ)
+        (intFormRatiosC_subset ℚ Γ (ModularCurve.jqModC_mem_intFormRatiosC ℚ Γ))
+      rwa [coeffEmb, coeffMap_jqModC] at h
+    have hb := hle ⟨_, hy⟩ rfl
+    have hidx := ModularCurve.finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_le_index
+      K' Γ hT Γ' hΓ' hneg ⟨_, hy⟩ rfl
+    obtain ⟨hfd', hle'⟩ := transfer (residueTopHom K') Γ xκ hxκ x' hx' hfd
+    exact ⟨hfd', hle'.trans (hb.trans hidx)⟩
+
+end Bound
+
+end P2MKcQExpDeg
+
+end
+
+open P2MKcQExpDeg ModularCurve IntermediateField in
+theorem solution
+    (K : Type*) [Field K]
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hT : ModularGroup.T ∈ Γ)
+    (Γ' : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) (hΓ' : Γ ≤ Γ')
+    (hneg : ∀ γ ∈ Γ', γ ∈ Γ ∨ -γ ∈ Γ)
+    (x : ModularCurve.qExpFunctionFieldC K Γ)
+    (hx : (x : LaurentSeries K) = ModularCurve.jqModC K) :
+    FiniteDimensional
+        (IntermediateField.adjoin K ({x} : Set (ModularCurve.qExpFunctionFieldC K Γ)))
+        (ModularCurve.qExpFunctionFieldC K Γ) ∧
+      Module.finrank
+          (IntermediateField.adjoin K ({x} : Set (ModularCurve.qExpFunctionFieldC K Γ)))
+          (ModularCurve.qExpFunctionFieldC K Γ) ≤ Γ'.index := by
+  classical
+  have hjK' : jqModC (AlgebraicClosure K) ∈ qExpFunctionFieldC (AlgebraicClosure K) Γ :=
+    intFormRatiosC_subset (AlgebraicClosure K) Γ
+      (ModularCurve.jqModC_mem_intFormRatiosC (AlgebraicClosure K) Γ)
+  obtain ⟨hfd', hle'⟩ := bound_of_isAlgClosed Γ hT Γ' hΓ' hneg (AlgebraicClosure K) ⟨_, hjK'⟩ rfl
+  have := hfd'
+  have hxt : Transcendental K (x : LaurentSeries K) := by rw [hx]; exact transcendental_jqModC K
+  have hxx' : ((⟨_, hjK'⟩ : qExpFunctionFieldC (AlgebraicClosure K) Γ) :
+      LaurentSeries (AlgebraicClosure K)) =
+      coeffMap (algebraMap K (AlgebraicClosure K)) (x : LaurentSeries K) := by
+    rw [hx, coeffMap_jqModC]
+  obtain ⟨hfdK, hleK⟩ :=
+    ModularCurve.finiteDimensional_and_finrank_adjoin_le_of_eq_coeffMap
+      (algebraMap K (AlgebraicClosure K)) Γ x ⟨_, hjK'⟩ hxt hxx'
+  exact ⟨hfdK, hleK.trans hle'⟩
+
+end S_OVERLONG_55825ce2
+end P2MW
+export P2MW.S_OVERLONG_55825ce2
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.finiteDimensional_and_finrank_adjoin_jqModC_qExpFunctionFieldC_le_index
+    (K : Type*) [Field K]
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hT : ModularGroup.T ∈ Γ)
+    (Γ' : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) (hΓ' : Γ ≤ Γ')
+    (hneg : ∀ γ ∈ Γ', γ ∈ Γ ∨ -γ ∈ Γ)
+    (x : ModularCurve.qExpFunctionFieldC K Γ)
+    (hx : (x : LaurentSeries K) = ModularCurve.jqModC K) :
+    FiniteDimensional
+        (IntermediateField.adjoin K ({x} : Set (ModularCurve.qExpFunctionFieldC K Γ)))
+        (ModularCurve.qExpFunctionFieldC K Γ) ∧
+      Module.finrank
+          (IntermediateField.adjoin K ({x} : Set (ModularCurve.qExpFunctionFieldC K Γ)))
+          (ModularCurve.qExpFunctionFieldC K Γ) ≤ Γ'.index :=
+  solution K Γ hT Γ' hΓ' hneg x hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finiteDimensional_and_finrank_adjoin_le_of_eq_coeffMap.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finiteDimensional_and_finrank_adjoin_le_of_eq_coeffMap.lean
new file mode 100644
index 0000000000..75238eb2d2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finiteDimensional_and_finrank_adjoin_le_of_eq_coeffMap.lean
@@ -0,0 +1,391 @@
+/-
+Based on Prove2Me node ModularCurve.finiteDimensional_and_finrank_adjoin_le_of_eq_coeffMap
+(79b963aa-eada-592a-846b-a690dd73f1d7) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission dc78e285-f6a2-511c-b921-94f50248da88
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.RingTheory.Flat.TorsionFree
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0ModL
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finiteness and degree bound descend under coefficientwise field maps
+
+Theorem statement: `ModularCurve.finiteDimensional_and_finrank_adjoin_le_of_eq_coeffMap`
+(`79b963aa-eada-592a-846b-a690dd73f1d7`), by Claude, 2026-09-05.
+
+Proof: submission `dc78e285-f6a2-511c-b921-94f50248da88`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K_0$ and $K$ be fields, $\varphi\colon K_0\to K$ a ring homomorphism, and $\Gamma$ a subgroup
+of $\mathrm{SL}_2(\mathbb{Z})$. For a field $L$ write $F_L$ for [`ModularCurve.qExpFunctionFieldC L
+Γ`](def/ModularCurve_X1.html#L101), the intermediate field of $L((q))$ generated over $L$ by the set
+of quotients $\iota_L(p_f)/\iota_L(p_g)$, where $f,g$ are modular forms of one and the same weight
+$k$ for the image of $\Gamma$ in $\mathrm{GL}_2(\mathbb{R})$, $p_f,p_g$ are integral power series
+realising their $q$-expansions (the project's `IsIntegralQExp`), $\iota_L$ denotes coefficientwise
+reduction of an integral series into $L((q))$, and the denominator $\iota_L(p_g)$ is nonzero. Let
+$x_0\in F_{K_0}$ and $x\in F_K$ be such that $x_0$ is transcendental over $K_0$ as an element of
+$K_0((q))$, and such that $x$ equals the image of $x_0$ under [`ModularCurve.coeffMap
+φ`](def/ModularCurve_LaurentCoeff.html#L16), the coefficientwise application of $\varphi$ from
+$K_0((q))$ to $K((q))$. Assume $F_K$ is finite-dimensional over the simple extension $K(x)$ inside
+$F_K$. Then $F_{K_0}$ is finite-dimensional over $K_0(x_0)$, and $[F_{K_0}:K_0(x_0)]\le[F_K:K(x)]$.
+
+This is the elementary half of the comparison of degrees of function fields under extension of the
+field of constants, realised concretely for subfields of formal Laurent series fields, where it
+rests on the linear disjointness of the constant field from Laurent series with coefficients in the
+image of $\varphi$. It is used in the project to transfer degree bounds for $q$-expansion function
+fields over a base field to a larger coefficient field, and feeds the estimates relating the index
+of $\Gamma_H$ to the degree of the extension generated by the modular function $j$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finiteDimensional_and_finrank_adjoin_le_of_eq_coeffMap.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 1600000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_finiteDimensional_and_finrank_adjoin_le_of_eq_coeffMap
+
+
+noncomputable section
+
+open ModularCurve IntermediateField Polynomial HahnSeries
+open scoped MatrixGroups
+
+namespace QExpDegTransfer
+
+attribute [local instance 2000] Algebra.toSMul Algebra.toModule
+
+variable {K₀ K : Type*} [Field K₀] [Field K] (φ : K₀ →+* K) (Γ : Subgroup SL(2, ℤ))
+
+theorem coeff_smul' {L : Type*} [Field L] (r : L) (x : LaurentSeries L) (n : ℤ) :
+    (r • x).coeff n = r * x.coeff n := by
+  rw [Algebra.smul_def, algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_zero_mul]
+
+theorem coeffMap_intSeriesC (p : PowerSeries ℤ) :
+    coeffMap φ (intSeriesC K₀ p) = intSeriesC K p := by
+  rw [intSeriesC, intSeriesC, coeffMap_ofPowerSeries, ← RingHom.comp_apply (PowerSeries.map φ),
+    ← PowerSeries.map_comp, RingHom.ext_int (φ.comp (Int.castRingHom K₀)) (Int.castRingHom K)]
+
+theorem coeffMap_injective : Function.Injective (coeffMap φ) := by
+  intro x y h
+  ext n
+  have := congrArg (fun z : LaurentSeries K => z.coeff n) h
+  simp only [coeffMap_coeff] at this
+  exact φ.injective this
+
+theorem coeffMap_mem {x : LaurentSeries K₀} (hx : x ∈ qExpFunctionFieldC K₀ Γ) :
+    coeffMap φ x ∈ qExpFunctionFieldC K Γ := by
+  let T : Subfield (LaurentSeries K₀) := (qExpFunctionFieldC K Γ).toSubfield.comap (coeffMap φ)
+  have hgen : intFormRatiosC K₀ Γ ⊆ (T : Set (LaurentSeries K₀)) := by
+    rintro y ⟨k, f, g, pf, pg, hf, hg, hg0, rfl⟩
+    change coeffMap φ (intSeriesC K₀ pf / intSeriesC K₀ pg) ∈ qExpFunctionFieldC K Γ
+    rw [map_div₀, coeffMap_intSeriesC, coeffMap_intSeriesC]
+    refine div_mem_qExpFunctionFieldC f g hf hg ?_
+    rw [← coeffMap_intSeriesC φ]
+    exact fun h => hg0 (coeffMap_injective φ (h.trans (map_zero _).symm))
+  have hconst : Set.range (algebraMap K₀ (LaurentSeries K₀)) ⊆ (T : Set (LaurentSeries K₀)) := by
+    rintro y ⟨c, rfl⟩
+    change coeffMap φ (algebraMap K₀ (LaurentSeries K₀) c) ∈ qExpFunctionFieldC K Γ
+    rw [algebraMap_laurentSeries_eq_single, coeffMap_single, ← algebraMap_laurentSeries_eq_single]
+    exact (qExpFunctionFieldC K Γ).algebraMap_mem _
+  have hle : (qExpFunctionFieldC K₀ Γ).toSubfield ≤ T := by
+    rw [qExpFunctionFieldC, IntermediateField.adjoin_toSubfield]
+    exact Subfield.closure_le.mpr (Set.union_subset hconst hgen)
+  exact hle hx
+
+def iota : qExpFunctionFieldC K₀ Γ →+* qExpFunctionFieldC K Γ where
+  toFun y := ⟨coeffMap φ y, coeffMap_mem φ Γ y.2⟩
+  map_one' := Subtype.ext (map_one _)
+  map_mul' _ _ := Subtype.ext (map_mul _ _ _)
+  map_zero' := Subtype.ext (map_zero _)
+  map_add' _ _ := Subtype.ext (map_add _ _ _)
+
+@[scoped simp] theorem coe_iota (y : qExpFunctionFieldC K₀ Γ) :
+    ((iota φ Γ y : qExpFunctionFieldC K Γ) : LaurentSeries K) = coeffMap φ y := rfl
+
+theorem linearIndependent_coeffMap {ι : Type*} {v : ι → LaurentSeries K₀}
+    (hv : LinearIndependent K₀ v) :
+    LinearIndependent K (fun i => coeffMap φ (v i)) := by
+  classical
+  let : Algebra K₀ K := φ.toAlgebra
+  have hφ : ∀ c : K₀, algebraMap K₀ K c = φ c := fun _ => rfl
+  rw [linearIndependent_iff']
+  intro s c hsum i hi
+  let W : Submodule K₀ K := Submodule.span K₀ (Set.range fun j : s => c j)
+  have : Module.Finite K₀ W := Module.Finite.span_of_finite K₀ (Set.finite_range _)
+  let b := Module.finBasis K₀ W
+  have hcW : ∀ j : s, c j ∈ W := fun j => Submodule.subset_span ⟨j, rfl⟩
+  let a : s → Fin (Module.finrank K₀ W) → K₀ := fun j l => b.repr ⟨c j, hcW j⟩ l
+  have hca : ∀ j : s, c j = ∑ l, a j l • (b l : K) := by
+    intro j
+    have h1 := b.sum_repr ⟨c j, hcW j⟩
+    have h2 := congrArg (Submodule.subtype W) h1
+    rw [map_sum] at h2
+    simp only [Submodule.subtype_apply, Submodule.coe_smul] at h2
+    exact h2.symm
+  have hcoeff : ∀ n : ℤ, ∑ j ∈ s, c j * φ ((v j).coeff n) = 0 := by
+    intro n
+    have := congrArg (fun x : LaurentSeries K => x.coeff n) hsum
+    simpa [HahnSeries.coeff_sum, coeff_smul', coeffMap_coeff] using this
+  have hbi : LinearIndependent K₀ (fun l' => (b l' : K)) :=
+    b.linearIndependent.map' W.subtype (Submodule.ker_subtype W)
+  have hv' : LinearIndependent K₀ (fun j : s => v j) := hv.comp _ Subtype.val_injective
+  have hrel : ∀ l, ∑ j : s, a j l • v j = 0 := by
+    intro l
+    ext n
+    have h1 : ∑ l', (∑ j : s, a j l' * (v j).coeff n) • (b l' : K) = 0 := by
+      have h0 := hcoeff n
+      rw [← Finset.sum_coe_sort] at h0
+      simp_rw [hca, Finset.sum_mul] at h0
+      rw [Finset.sum_comm] at h0
+      rw [← h0]
+      refine Finset.sum_congr rfl fun l' _ => ?_
+      rw [Finset.sum_smul]
+      refine Finset.sum_congr rfl fun j _ => ?_
+      rw [Algebra.smul_def, Algebra.smul_def, map_mul, hφ, hφ]; ring
+    have := Fintype.linearIndependent_iff.mp hbi (fun l' => ∑ j : s, a j l' * (v j).coeff n) h1 l
+    rw [HahnSeries.coeff_sum]
+    simpa [coeff_smul'] using this
+  have ha : ∀ (j : s) l, a j l = 0 := fun j l =>
+    Fintype.linearIndependent_iff.mp hv' (fun j => a j l) (hrel l) j
+  rw [show c i = c (⟨i, hi⟩ : s) from rfl, hca]
+  simp [ha]
+
+section Transfer
+
+variable {φ Γ}
+variable (x₀ : qExpFunctionFieldC K₀ Γ) (x : qExpFunctionFieldC K Γ)
+  (hx₀ : Transcendental K₀ (x₀ : LaurentSeries K₀))
+  (hx : (x : LaurentSeries K) = coeffMap φ (x₀ : LaurentSeries K₀))
+
+local notation "E₀" => (qExpFunctionFieldC K₀ Γ)
+local notation "E" => (qExpFunctionFieldC K Γ)
+
+include hx₀ in
+theorem linearIndependent_pow_smul {ι : Type*} [Finite ι] (v : ι → E₀)
+    (hv : LinearIndependent (IntermediateField.adjoin K₀ ({x₀} : Set E₀)) v) (N : ℕ) :
+    LinearIndependent K₀ (fun p : ι × Fin N => (x₀ : E₀) ^ (p.2 : ℕ) * v p.1) := by
+  classical
+  let := Fintype.ofFinite ι
+  rw [Fintype.linearIndependent_iff]
+  intro a ha
+  let A : ι → IntermediateField.adjoin K₀ ({x₀} : Set E₀) := fun i =>
+    ⟨∑ m : Fin N, a (i, m) • (x₀ : E₀) ^ (m : ℕ), by
+      refine sum_mem fun m _ => IntermediateField.smul_mem _ ?_
+      exact pow_mem (IntermediateField.mem_adjoin_simple_self K₀ x₀) _⟩
+  have hsum : ∑ i, A i • v i = 0 := by
+    have : ∑ i, A i • v i = ∑ p : ι × Fin N, a p • ((x₀ : E₀) ^ (p.2 : ℕ) * v p.1) := by
+      rw [Fintype.sum_prod_type]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      change (∑ m : Fin N, a (i, m) • (x₀ : E₀) ^ (m : ℕ)) * v i = _
+      rw [Finset.sum_mul]
+      refine Finset.sum_congr rfl fun m _ => ?_
+      rw [smul_mul_assoc]
+    rw [this]; exact ha
+  have hA : ∀ i, A i = 0 := Fintype.linearIndependent_iff.mp hv A hsum
+  intro p
+  obtain ⟨i, m⟩ := p
+  have hAi : ∑ m : Fin N, a (i, m) • ((x₀ : E₀) : LaurentSeries K₀) ^ (m : ℕ) = 0 := by
+    have h1 : ((A i : E₀) : LaurentSeries K₀) = 0 := by rw [hA i]; rfl
+    have h2 : ((A i : E₀) : LaurentSeries K₀)
+        = ∑ m : Fin N, a (i, m) • ((x₀ : E₀) : LaurentSeries K₀) ^ (m : ℕ) := by
+      change ((∑ m : Fin N, a (i, m) • (x₀ : E₀) ^ (m : ℕ) : E₀) : LaurentSeries K₀) = _
+      rw [AddSubmonoidClass.coe_finsetSum]
+      refine Finset.sum_congr rfl fun m _ => ?_
+      rw [IntermediateField.coe_smul, SubmonoidClass.coe_pow]
+    rw [← h2]; exact h1
+  let P : K₀[X] := ∑ m : Fin N, Polynomial.monomial (m : ℕ) (a (i, m))
+  have hP : Polynomial.aeval ((x₀ : E₀) : LaurentSeries K₀) P = 0 := by
+    rw [map_sum, ← hAi]
+    refine Finset.sum_congr rfl fun m _ => ?_
+    rw [Polynomial.aeval_monomial, Algebra.smul_def]
+  have hP0 : P = 0 := by
+    by_contra hne
+    exact hx₀ ⟨P, hne, hP⟩
+  have := congrArg (fun Q : K₀[X] => Q.coeff (m : ℕ)) hP0
+  simp only [P, Polynomial.finsetSum_coeff, Polynomial.coeff_monomial,
+    Polynomial.coeff_zero] at this
+  rw [Finset.sum_eq_single m] at this
+  · simpa using this
+  · intro m' _ hm'
+    rw [ite_eq_right]
+    exact fun h => hm' (Fin.ext h)
+  · intro h; exact absurd (Finset.mem_univ m) h
+
+include hx₀ hx in
+theorem linearIndependent_iota {ι : Type*} [Finite ι] (v : ι → E₀)
+    (hv : LinearIndependent (IntermediateField.adjoin K₀ ({x₀} : Set E₀)) v) :
+    LinearIndependent (IntermediateField.adjoin K ({x} : Set E)) (fun i => iota φ Γ (v i)) := by
+  classical
+  let := Fintype.ofFinite ι
+  rw [Fintype.linearIndependent_iff]
+  intro c hc
+  by_contra hne
+  push Not at hne
+  obtain ⟨i₀, hi₀⟩ := hne
+  have hrep : ∀ i, ∃ r s : K[X], (c i : E) = Polynomial.aeval (x : E) r / Polynomial.aeval (x : E) s
+    :=
+    by
+    intro i
+    exact (IntermediateField.mem_adjoin_simple_iff (F := K) (α := x) (c i : E)).mp (c i).2
+  choose r s hrs using hrep
+  let s' : ι → K[X] := fun i => if Polynomial.aeval (x : E) (s i) = 0 then 1 else s i
+  have hs' : ∀ i, Polynomial.aeval (x : E) (s' i) ≠ 0 := by
+    intro i
+    simp only [s']
+    split_ifs with h
+    · rw [map_one]; exact one_ne_zero
+    · exact h
+  let r' : ι → K[X] := fun i => if Polynomial.aeval (x : E) (s i) = 0 then 0 else r i
+  have hrs' : ∀ i, (c i : E) * Polynomial.aeval (x : E) (s' i) = Polynomial.aeval (x : E) (r' i) :=
+    by
+    intro i
+    simp only [s', r']
+    split_ifs with h
+    · rw [hrs i, h, div_zero, zero_mul, map_zero]
+    · rw [hrs i, div_mul_cancel₀ _ h]
+  let D : K[X] := ∏ i, s' i
+  have hD : Polynomial.aeval (x : E) D ≠ 0 := by
+    rw [map_prod]
+    exact Finset.prod_ne_zero_iff.mpr fun i _ => hs' i
+  let P : ι → K[X] := fun i => r' i * ∏ j ∈ Finset.univ.erase i, s' j
+  have hPc : ∀ i, Polynomial.aeval (x : E) (P i) = (c i : E) * Polynomial.aeval (x : E) D := by
+    intro i
+    simp only [P, D]
+    rw [map_mul, ← hrs', mul_assoc, ← map_mul, Finset.mul_prod_erase _ _ (Finset.mem_univ i)]
+  have hrel : ∑ i, Polynomial.aeval (x : E) (P i) • (iota φ Γ (v i) : E) = 0 := by
+    have : ∑ i, Polynomial.aeval (x : E) (P i) • (iota φ Γ (v i) : E)
+        = Polynomial.aeval (x : E) D * ∑ i, (c i : E) • (iota φ Γ (v i) : E) := by
+      rw [Finset.mul_sum]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [hPc, smul_eq_mul, smul_eq_mul]; ring
+    rw [this]
+    have h0 : ∑ i, (c i : E) • (iota φ Γ (v i) : E) = 0 := by
+      have := hc
+      simpa only [IntermediateField.smul_def] using this
+    rw [h0, mul_zero]
+  have hPi₀ : P i₀ ≠ 0 := by
+    intro h
+    have := hPc i₀
+    rw [h, map_zero] at this
+    exact mul_ne_zero (fun h0 => hi₀ (ZeroMemClass.coe_eq_zero.mp h0)) hD this.symm
+  let N : ℕ := (Finset.univ.sup fun i => (P i).natDegree) + 1
+  have hdeg : ∀ i, (P i).natDegree < N := fun i =>
+    Nat.lt_succ_of_le (Finset.le_sup (f := fun i => (P i).natDegree) (Finset.mem_univ i))
+  have hind₀ := linearIndependent_pow_smul x₀ hx₀ v hv N
+  have hind₀' : LinearIndependent K₀
+      (fun p : ι × Fin N => (((x₀ : E₀) ^ (p.2 : ℕ) * v p.1 : E₀) : LaurentSeries K₀)) :=
+    hind₀.map' (IntermediateField.val E₀).toLinearMap
+      (LinearMap.ker_eq_bot_of_injective Subtype.val_injective)
+  have hindK := linearIndependent_coeffMap φ hind₀'
+  have hexp : ∑ p : ι × Fin N, (P p.1).coeff (p.2 : ℕ) •
+      coeffMap φ (((x₀ : E₀) ^ ((p.2 : ℕ)) * v p.1 : E₀) : LaurentSeries K₀) = 0 := by
+    have e1 : ∀ i, Polynomial.aeval (x : E) (P i) =
+      ∑ m : Fin N, (P i).coeff (m : ℕ) • (x : E) ^ (m : ℕ) := by
+      intro i
+      rw [Polynomial.aeval_eq_sum_range' (hdeg i), Finset.sum_range]
+    have := congrArg (fun z : E => (z : LaurentSeries K)) hrel
+    simp only [IntermediateField.coe_sum, ZeroMemClass.coe_zero] at this
+    rw [← this, Fintype.sum_prod_type]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [e1, Finset.sum_smul, IntermediateField.coe_sum]
+    refine Finset.sum_congr rfl fun m _ => ?_
+    rw [MulMemClass.coe_mul, SubmonoidClass.coe_pow, map_mul, map_pow, ← hx, smul_eq_mul,
+      MulMemClass.coe_mul, IntermediateField.coe_smul, SubmonoidClass.coe_pow, coe_iota,
+      smul_mul_assoc]
+  have hzero := Fintype.linearIndependent_iff.mp hindK (fun p => (P p.1).coeff (p.2 : ℕ)) hexp
+  apply hPi₀
+  ext m
+  rw [Polynomial.coeff_zero]
+  by_cases hm : m < N
+  · exact hzero (i₀, ⟨m, hm⟩)
+  · exact Polynomial.coeff_eq_zero_of_natDegree_lt (lt_of_lt_of_le (hdeg i₀) (not_lt.mp hm))
+
+end Transfer
+
+end QExpDegTransfer
+
+open QExpDegTransfer in
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+theorem solution
+    {K₀ K : Type*} [Field K₀] [Field K] (φ : K₀ →+* K) (Γ : Subgroup SL(2, ℤ))
+    (x₀ : ModularCurve.qExpFunctionFieldC K₀ Γ) (x : ModularCurve.qExpFunctionFieldC K Γ)
+    (hx₀ : Transcendental K₀ (x₀ : LaurentSeries K₀))
+    (hx : (x : LaurentSeries K) = ModularCurve.coeffMap φ (x₀ : LaurentSeries K₀))
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set (ModularCurve.qExpFunctionFieldC K
+      Γ)))
+      (ModularCurve.qExpFunctionFieldC K Γ)] :
+    FiniteDimensional (IntermediateField.adjoin K₀ ({x₀} : Set (ModularCurve.qExpFunctionFieldC K₀
+      Γ)))
+        (ModularCurve.qExpFunctionFieldC K₀ Γ) ∧
+      Module.finrank (IntermediateField.adjoin K₀ ({x₀} : Set (ModularCurve.qExpFunctionFieldC K₀
+        Γ)))
+          (ModularCurve.qExpFunctionFieldC K₀ Γ) ≤
+        Module.finrank (IntermediateField.adjoin K ({x} : Set (ModularCurve.qExpFunctionFieldC K
+          Γ)))
+          (ModularCurve.qExpFunctionFieldC K Γ) := by
+  classical
+  set n : ℕ := Module.finrank (IntermediateField.adjoin K ({x} : Set (qExpFunctionFieldC K Γ)))
+    (qExpFunctionFieldC K Γ) with hn
+  have hbound : ∀ s : Finset (qExpFunctionFieldC K₀ Γ),
+      LinearIndependent (IntermediateField.adjoin K₀ ({x₀} : Set (qExpFunctionFieldC K₀ Γ)))
+        (fun i : s => (i : qExpFunctionFieldC K₀ Γ)) → s.card ≤ n := by
+    intro s hs
+    have h := linearIndependent_iota x₀ x hx₀ hx (fun i : s => (i : qExpFunctionFieldC K₀ Γ)) hs
+    have := h.fintype_card_le_finrank
+    rwa [Fintype.card_coe] at this
+  have hrank : Module.rank (IntermediateField.adjoin K₀ ({x₀} : Set (qExpFunctionFieldC K₀ Γ)))
+      (qExpFunctionFieldC K₀ Γ) ≤ n := rank_le hbound
+  have hfin : FiniteDimensional (IntermediateField.adjoin K₀ ({x₀} : Set (qExpFunctionFieldC K₀ Γ)))
+      (qExpFunctionFieldC K₀ Γ) :=
+    Module.rank_lt_aleph0_iff.mp (lt_of_le_of_lt hrank (Cardinal.natCast_lt_aleph0 (n := n)))
+  exact ⟨hfin, Module.finrank_le_of_rank_le hrank⟩
+
+end
+end S_ModularCurve_finiteDimensional_and_finrank_adjoin_le_of_eq_coeffMap
+end P2MW
+export P2MW.S_ModularCurve_finiteDimensional_and_finrank_adjoin_le_of_eq_coeffMap (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups in
+theorem ModularCurve.finiteDimensional_and_finrank_adjoin_le_of_eq_coeffMap
+    {K₀ K : Type*} [Field K₀] [Field K] (φ : K₀ →+* K) (Γ : Subgroup SL(2, ℤ))
+    (x₀ : ModularCurve.qExpFunctionFieldC K₀ Γ) (x : ModularCurve.qExpFunctionFieldC K Γ)
+    (hx₀ : Transcendental K₀ (x₀ : LaurentSeries K₀))
+    (hx : (x : LaurentSeries K) = ModularCurve.coeffMap φ (x₀ : LaurentSeries K₀))
+    [FiniteDimensional (IntermediateField.adjoin K ({x} : Set (ModularCurve.qExpFunctionFieldC K
+      Γ)))
+      (ModularCurve.qExpFunctionFieldC K Γ)] :
+    FiniteDimensional (IntermediateField.adjoin K₀ ({x₀} : Set (ModularCurve.qExpFunctionFieldC K₀
+      Γ)))
+        (ModularCurve.qExpFunctionFieldC K₀ Γ) ∧
+      Module.finrank (IntermediateField.adjoin K₀ ({x₀} : Set (ModularCurve.qExpFunctionFieldC K₀
+        Γ)))
+          (ModularCurve.qExpFunctionFieldC K₀ Γ) ≤
+        Module.finrank (IntermediateField.adjoin K ({x} : Set (ModularCurve.qExpFunctionFieldC K
+          Γ)))
+          (ModularCurve.qExpFunctionFieldC K Γ) :=
+  solution φ Γ x₀ x hx₀ hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finiteDimensional_riemannRochSpace_laurentBaseChange_qExpFunctionFieldC_gamma1.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finiteDimensional_riemannRochSpace_laurentBaseChange_qExpFunctionFieldC_gamma1.lean
new file mode 100644
index 0000000000..edd50269c1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finiteDimensional_riemannRochSpace_laurentBaseChange_qExpFunctionFieldC_gamma1.lean
@@ -0,0 +1,125 @@
+/-
+Based on Prove2Me node
+ModularCurve.finiteDimensional_riemannRochSpace_laurentBaseChange_qExpFunctionFieldC_gamma1
+(d56581c0-5133-56e9-8c0e-d24c21066309) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 59b6839b-4777-5db0-8277-3c5fc6216fcd
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Repartitions
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_essFiniteType_of_transcendental_of_finiteDimensional
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteDimensional_lSpace
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteDimensional_lSpace_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_nonempty_place_of_transcendental_of_finiteDimensional
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_JOneES_exists_transcendental_finiteDimensional_laurentBaseChange
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCurveOver_laurentBaseChange_qExpFunctionFieldC_gamma1
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Riemann–Roch spaces of K·ℚ(X₁(M)) are finite-dimensional
+
+Theorem statement:
+`ModularCurve.finiteDimensional_riemannRochSpace_laurentBaseChange_qExpFunctionFieldC_gamma1`
+(`d56581c0-5133-56e9-8c0e-d24c21066309`), by Claude, 2026-09-05.
+
+Proof: submission `59b6839b-4777-5db0-8277-3c5fc6216fcd`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field equipped with a $\mathbb{Q}$-algebra structure, and let $M$
+be a nonzero natural number. Write $F_\mathbb{Q}$ for `qExpFunctionFieldC ℚ (Gamma1 M)`, the
+intermediate field of the field $\mathbb{Q}((q))$ of Laurent series over $\mathbb{Q}$ generated over
+$\mathbb{Q}$ by all quotients $\iota(p_f)/\iota(p_g)$ of Laurent series attached to integral
+$q$-expansions $p_f,p_g\in\mathbb{Z}[[q]]$ of modular forms $f,g$ of some weight $k$ for
+$\Gamma_1(M)$ (with $\iota(p_g)\neq 0$), and let $F_K$ be `laurentBaseChange K F_\mathbb{Q}`, the
+intermediate field of $K((q))$ generated over $K$ by the image of $F_\mathbb{Q}$ under the
+coefficientwise map $\mathbb{Q}((q))\to K((q))$ induced by $\mathbb{Q}\to K$. Let $D$ be a divisor
+of $F_K$ over $K$, i.e. a finitely supported $\mathbb{Z}$-valued function on the set of places of
+$F_K/K$, a place being a valuation subring of $F_K$ that contains the image of $K$, is not all of
+$F_K$, and is a principal ideal ring. Then the Riemann–Roch space $L(D)$, the $K$-submodule of those
+$f\in F_K$ with $v(f)\le \exp(D(v))$ in $\mathbb{Z}^{m0}$ for every place $v$, where $v$ denotes the
+associated adic valuation, is finite-dimensional over $K$.
+
+This is the finiteness half of the Riemann–Roch theory for the function field
+$K\cdot\mathbb{Q}(X_1(M))$ of the modular curve $X_1(M)$ over an algebraically closed field of
+characteristic zero. It supplies the finite-dimensionality needed to extract a basis of $L(D)$ when
+lower bounds for $\dim_K M_{2m}(\Gamma_1(M))$ are proved, and is cited in both the even and odd
+weight cases of the dimension estimate for modular forms on $\Gamma_1(M)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finiteDimensional_riemannRochSpace_laurentBaseChange_qExpFunctionFieldC_gamma1.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_c0856186
+
+
+open ModularCurve CongruenceSubgroup AlgebraicCurve
+open scoped MatrixGroups
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+theorem solution
+    (K : Type*) [Field K] [Algebra ℚ K] [IsAlgClosed K] (M : ℕ) [NeZero M]
+    (D : AlgebraicCurve.Divisor K ↥(ModularCurve.laurentBaseChange K
+      (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))) :
+    FiniteDimensional K ↥(AlgebraicCurve.riemannRochSpace D) := by
+  obtain ⟨x, htr, hfd⟩ : ∃ x : ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ
+    (CongruenceSubgroup.Gamma1 M))),
+      Transcendental K x ∧ FiniteDimensional ↥(IntermediateField.adjoin K ({x} : Set _)) _ :=
+    ModularCurve.JOneES.exists_transcendental_finiteDimensional_laurentBaseChange
+      K (CongruenceSubgroup.Gamma1 M) (by rw [CongruenceSubgroup.Gamma1_mem]; simp [ModularGroup.T])
+  have := hfd
+  have : CharZero K := charZero_of_injective_algebraMap (algebraMap ℚ K).injective
+  have : Algebra.IsAlgebraic ↥(IntermediateField.adjoin K ({x} : Set _))
+      ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ
+        (CongruenceSubgroup.Gamma1 M))) :=
+    Algebra.IsAlgebraic.of_finite _ _
+  have : Algebra.IsSeparable ↥(IntermediateField.adjoin K ({x} : Set _))
+      ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ
+        (CongruenceSubgroup.Gamma1 M))) :=
+    Algebra.IsAlgebraic.isSeparable_of_perfectField
+  have := AlgebraicCurve.nonempty_place_of_transcendental_of_finiteDimensional K x htr hfd
+  have := ModularCurve.isCurveOver_laurentBaseChange_qExpFunctionFieldC_gamma1 K M
+  have := AlgebraicCurve.essFiniteType_of_transcendental_of_finiteDimensional htr hfd
+  have := AlgebraicCurve.finiteDimensional_lSpace_zero K
+    ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1
+      M)))
+  exact AlgebraicCurve.finiteDimensional_lSpace D
+
+end S_OVERLONG_c0856186
+end P2MW
+export
+  P2MW.S_OVERLONG_c0856186
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve CongruenceSubgroup
+open AlgebraicCurve
+open scoped MatrixGroups
+theorem ModularCurve.finiteDimensional_riemannRochSpace_laurentBaseChange_qExpFunctionFieldC_gamma1
+    (K : Type*) [Field K] [Algebra ℚ K] [IsAlgClosed K] (M : ℕ) [NeZero M]
+    (D : AlgebraicCurve.Divisor K ↥(ModularCurve.laurentBaseChange K
+      (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))) :
+    FiniteDimensional K ↥(AlgebraicCurve.riemannRochSpace D) :=
+  solution K M D
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finite_cycSub.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finite_cycSub.lean
new file mode 100644
index 0000000000..c529c05928
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finite_cycSub.lean
@@ -0,0 +1,110 @@
+/-
+Based on Prove2Me node ModularCurve.finite_cycSub
+(302f0eb2-7bf8-57ad-a76f-8404e468e290) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5b1059e7-4873-5081-bfd1-c12f5c9a60bb
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EMD
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_finite_torsionBy_of_natCast_ne_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finitely many cyclic subgroups of order N on an elliptic curve over ℚ̄
+
+Theorem statement: `ModularCurve.finite_cycSub` (`302f0eb2-7bf8-57ad-a76f-8404e468e290`), by Claude,
+2026-09-05.
+
+Proof: submission `5b1059e7-4873-5081-bfd1-c12f5c9a60bb`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number that is nonzero, and let $E_0$ be a Weierstrass curve over an algebraic
+closure of $\mathbb{Q}$ which is elliptic (its discriminant is a unit). Write $E_0^{\mathrm{aff}}$
+for the associated affine curve and $E_0^{\mathrm{aff}}(\overline{\mathbb{Q}})$ for its group of
+points, in the sense of `WeierstrassCurve.Affine.Point`. The type `CycSub E₀ N` is defined as the
+subtype consisting of those additive subgroups $H$ of $E_0^{\mathrm{aff}}(\overline{\mathbb{Q}})$
+for which there exists a point $g$ whose additive order is exactly $N$ and such that $H$ is the
+subgroup $\mathbb{Z}g$ of integer multiples of $g$; thus its elements are the cyclic subgroups of
+order exactly $N$, each recorded together with the existence of a generator of order $N$. The
+assertion is that this type is finite, i.e. there are only finitely many such subgroups.
+
+This is the finiteness of the set of cyclic subgroups of order $N$ on a fixed elliptic curve over
+$\overline{\mathbb{Q}}$, the finiteness underlying the fact that a point of the modular curve of
+level $N$ has only finitely many level structures above a given $j$-invariant. It is used in the
+counting of elliptic points, in
+[`ModularCurve.card_filter_ord_jBar_eq_one_eq_nuThree`]
+(thm.html#ModularCurve.card_filter_ord_jBar_eq_one_eq_nuThree)
+and
+[`ModularCurve.card_filter_ord_jBar_sub_1728_eq_one_eq_nuTwo`]
+(thm.html#ModularCurve.card_filter_ord_jBar_sub_1728_eq_one_eq_nuTwo),
+and in [`ModularCurve.emd_holds`](thm.html#ModularCurve.emd_holds).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finite_cycSub.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_finite_cycSub
+
+
+open ModularCurve WeierstrassCurve
+
+theorem solution (N : ℕ) [NeZero N] (E₀ : WeierstrassCurve (AlgebraicClosure ℚ)) [E₀.IsElliptic] :
+    Finite (CycSub E₀ N) := by
+  classical
+  have hN : ((N : ℕ) : AlgebraicClosure ℚ) ≠ 0 := by exact_mod_cast (NeZero.ne N)
+  have : Finite (Submodule.torsionBy ℤ E₀.toAffine.Point N) :=
+    WeierstrassCurve.finite_torsionBy_of_natCast_ne_zero (AlgebraicClosure ℚ) E₀ N hN
+  have hle : ∀ H : CycSub E₀ N, ∀ x : E₀.toAffine.Point, x ∈ H.1 →
+      x ∈ Submodule.torsionBy ℤ E₀.toAffine.Point N := by
+    rintro ⟨H, g, hg, rfl⟩ x hx
+    rw [Submodule.mem_torsionBy_iff]
+    obtain ⟨k, rfl⟩ := AddSubgroup.mem_zmultiples_iff.mp hx
+    change (N : ℤ) • (k • g) = 0
+    rw [smul_comm, ← hg, natCast_zsmul, addOrderOf_nsmul_eq_zero, smul_zero]
+  let f : CycSub E₀ N → Set (Submodule.torsionBy ℤ E₀.toAffine.Point N) :=
+    fun H => {x | (x : E₀.toAffine.Point) ∈ H.1}
+  refine Finite.of_injective f fun H H' hHH' => ?_
+  apply Subtype.ext
+  ext x
+  constructor
+  · intro hx
+    have hx' : (⟨x, hle H x hx⟩ : Submodule.torsionBy ℤ E₀.toAffine.Point N) ∈ f H := hx
+    rw [hHH'] at hx'
+    exact hx'
+  · intro hx
+    have hx' : (⟨x, hle H' x hx⟩ : Submodule.torsionBy ℤ E₀.toAffine.Point N) ∈ f H' := hx
+    rw [← hHH'] at hx'
+    exact hx'
+
+end S_ModularCurve_finite_cycSub
+end P2MW
+export P2MW.S_ModularCurve_finite_cycSub (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.finite_cycSub (N : ℕ) [NeZero N] (E₀ : WeierstrassCurve (AlgebraicClosure ℚ))
+    [E₀.IsElliptic] :
+    Finite (CycSub E₀ N) :=
+  solution N E₀
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index.lean
new file mode 100644
index 0000000000..b728aee0dd
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index.lean
@@ -0,0 +1,379 @@
+/-
+Based on Prove2Me node
+ModularCurve.finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index
+(10bf7192-830c-515d-a576-c2de34f51a07) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1ed43547-5e10-5194-8d5a-c402bf558c71
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0ModL
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_XH
+import LeanPool.FLTEichlerShimura.Theorems.Thm_CohCarrier_index_gammaH_eq_index_gamma0_mul_index
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_Gamma0_index
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_le_finrank_adjoin_qExpFunctionFieldC_gamma0
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_le_index
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqModC_qExpFunctionFieldC_le_index_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_index_le_relfinrank_qExpFunctionFieldC_gamma0_gammaH_of_charZero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_mem_intFormRatiosC
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree of the j-cover of X₁(M) equals [SL₂(ℤ):±Γ₁(M)]
+
+Theorem statement:
+`ModularCurve.finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index`
+(`10bf7192-830c-515d-a576-c2de34f51a07`), by Claude, 2026-09-05.
+
+Proof: submission `1ed43547-5e10-5194-8d5a-c402bf558c71`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field equipped with an algebra structure over $\mathbb{Q}$, and
+let $M$ be a nonzero natural number. Inside $\mathbb{Q}((q))$ consider the intermediate field $F_0
+=$ [`ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1
+M)`](def/ModularCurve_X1.html#L101), generated over $\mathbb{Q}$ by the set of all quotients
+$\mathrm{intSeriesC}\,p_f/\mathrm{intSeriesC}\,p_g$ arising from a weight $k$ and two modular forms
+$f,g$ for the image of $\Gamma_1(M)$ in $\mathrm{GL}_2(\mathbb{R})$ whose $q$-expansions are given
+by integral power series $p_f,p_g$ with $\mathrm{intSeriesC}\,p_g \neq 0$. Let $F =$
+[`ModularCurve.laurentBaseChange K F₀`](def/ModularCurve_LaurentCoeff.html#L103) be the intermediate
+field of $K((q))$ generated over $K$ by the image of $F_0$ under the coefficientwise embedding
+$\mathbb{Q}((q)) \to K((q))$ induced by $\mathbb{Q}\to K$. Let $y \in F$ be an element whose
+underlying Laurent series is [`ModularCurve.jqModC K`](def/ModularCurve_JqCoeff.html#L15), namely
+$q^{-1}$ times the image in $K$ of the integral power series $E_4^3 \cdot \eta^{-\mathrm{unit}}$
+(the $q$-expansion of $j$). Then the degree of $F$ over the intermediate field $K(y)$ generated by
+$y$ over $K$ is finite and equals the index in $\mathrm{SL}(2,\mathbb{Z})$ of the subgroup generated
+by $\Gamma_1(M)$ together with $-1$.
+
+This is the classical computation of the degree of the $j$-line cover $X_1(M) \to X(1)$, here in the
+form of an equality of field degrees for the $q$-expansion model of the function field of $X_1(M)$
+over an algebraically closed field of characteristic zero; the upper bound holds for general levels,
+and the matching lower bound comes from the tower $K(j) \subseteq K\cdot F(\Gamma_0(M)) \subseteq K
+\cdot F(\Gamma_1(M))$ combined with the index identity $[\mathrm{SL}_2(\mathbb{Z}):\pm\Gamma_1(M)] =
+\psi(M)\,[(\mathbb{Z}/M)^\times : \{\pm 1\}]$. It feeds the later analysis of places and valuations
+of this field, including the counting of points in a fibre by double cosets and the descent
+arguments for level $N$ structures.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_b0db17b1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "intSeriesC intFormRatiosC qExpFunctionFieldC intFormRatiosC_subset \
+  qExpFunctionFieldC_mono dedekindPsi coeffMap_single coeffEmb coeffEmb_coeff laurentBaseChange \
+  jqModC translation_mem_GammaH Gamma1_le_GammaH GammaH_bot GammaH_mono coeffMap_ofPowerSeries \
+  finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_le_index \
+  index_le_relfinrank_qExpFunctionFieldC_gamma0_gammaH_of_charZero \
+  dedekindPsi_le_finrank_adjoin_qExpFunctionFieldC_gamma0 \
+  finrank_adjoin_jqModC_qExpFunctionFieldC_le_index_of_isAlgClosed Gamma0_index \
+  jqModC_mem_intFormRatiosC"
+namespace FullnessGamma1
+p2m_open "ModularCurve~coeffEmb_injective"
+
+p2m_open "ModularCurve~coeffEmb_injective \
+  P2MW.S_OVERLONG_b0db17b1.Mo\
+  dularCurve IntermediateField"
+
+theorem finrank_adjoin_eq_relfinrank {K E : Type*} [Field K] [Field E] [Algebra K E]
+    (F : IntermediateField K E) (x : F) :
+    Module.finrank (IntermediateField.adjoin K ({x} : Set F)) F =
+      (IntermediateField.adjoin K ({(x : E)} : Set E)).relfinrank F := by
+  have hlift : IntermediateField.lift (IntermediateField.adjoin K ({x} : Set F)) =
+      IntermediateField.adjoin K ({(x : E)} : Set E) := by
+    rw [IntermediateField.lift_adjoin]; simp
+  have hle : IntermediateField.adjoin K ({(x : E)} : Set E) ≤ F := by
+    rw [← hlift]; exact IntermediateField.lift_le _
+  rw [IntermediateField.relfinrank_eq_finrank_of_le hle]
+  let i : (IntermediateField.adjoin K ({x} : Set F)) ≃+*
+      (IntermediateField.adjoin K ({(x : E)} : Set E)) :=
+    ((IntermediateField.liftAlgEquiv (IntermediateField.adjoin K ({x} : Set F))).trans
+      (IntermediateField.equivOfEq hlift)).toRingEquiv
+  let j : F ≃+* (IntermediateField.extendScalars hle) := RingEquiv.refl _
+  refine Algebra.finrank_eq_of_equiv_equiv i j ?_
+  ext a
+  rfl
+
+section BaseChange
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+theorem coeffEmb_injective : Function.Injective (coeffEmb K) := by
+  intro x y h
+  ext n
+  have h1 := congrArg (fun s : LaurentSeries K => s.coeff n) h
+  simp only [coeffEmb_coeff] at h1
+  exact (algebraMap ℚ K).injective h1
+
+theorem coeffEmb_ne_zero_iff (x : LaurentSeries ℚ) : coeffEmb K x ≠ 0 ↔ x ≠ 0 := by
+  rw [Ne, ← map_zero (coeffEmb K), (coeffEmb_injective K).eq_iff]
+
+theorem coeffEmb_intSeriesC (p : PowerSeries ℤ) : coeffEmb K (intSeriesC ℚ p) = intSeriesC K p := by
+  rw [coeffEmb, intSeriesC, intSeriesC, coeffMap_ofPowerSeries]
+  congr 1
+  ext n
+  simp [PowerSeries.coeff_map]
+
+theorem algebraMap_laurentSeries_eq_C {L : Type*} [Field L] (a : L) :
+    algebraMap L (LaurentSeries L) a = HahnSeries.C a := by
+  rw [HahnSeries.algebraMap_apply']
+  have h1 : algebraMap L (PowerSeries L) a = PowerSeries.C a := by simp
+  rw [h1, HahnSeries.ofPowerSeries_C]
+
+theorem coeffEmb_algebraMap (a : ℚ) :
+    coeffEmb K (algebraMap ℚ (LaurentSeries ℚ) a) = algebraMap K (LaurentSeries K) (algebraMap ℚ K
+      a) := by
+  rw [algebraMap_laurentSeries_eq_C, algebraMap_laurentSeries_eq_C, HahnSeries.C_apply,
+    HahnSeries.C_apply,
+    coeffEmb, coeffMap_single]
+
+variable (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+
+theorem image_intFormRatiosC : (coeffEmb K) '' intFormRatiosC ℚ Γ = intFormRatiosC K Γ := by
+  ext z
+  constructor
+  · rintro ⟨y, ⟨w, f, g, pf, pg, hf, hg, hg0, rfl⟩, rfl⟩
+    refine ⟨w, f, g, pf, pg, hf, hg, ?_, ?_⟩
+    · rw [← coeffEmb_intSeriesC K]; exact (coeffEmb_ne_zero_iff K _).mpr hg0
+    · rw [map_div₀, coeffEmb_intSeriesC, coeffEmb_intSeriesC]
+  · rintro ⟨w, f, g, pf, pg, hf, hg, hg0, rfl⟩
+    refine ⟨intSeriesC ℚ pf / intSeriesC ℚ pg, ⟨w, f, g, pf, pg, hf, hg, ?_, rfl⟩, ?_⟩
+    · rw [← coeffEmb_ne_zero_iff K, coeffEmb_intSeriesC]; exact hg0
+    · rw [map_div₀, coeffEmb_intSeriesC, coeffEmb_intSeriesC]
+
+variable {Γ}
+
+theorem coeffEmb_mem_adjoin {S : Set (LaurentSeries ℚ)} {y : LaurentSeries ℚ} (hy : y ∈ adjoin ℚ S)
+    :
+    coeffEmb K y ∈ adjoin K ((coeffEmb K) '' S) := by
+  have hy' : y ∈ (adjoin ℚ S).toSubfield := hy
+  rw [adjoin_toSubfield] at hy'
+  have hle : Subfield.closure (Set.range (algebraMap ℚ (LaurentSeries ℚ)) ∪ S) ≤
+      (adjoin K ((coeffEmb K) '' S)).toSubfield.comap (coeffEmb K) := by
+    rw [Subfield.closure_le]
+    rintro z (⟨a, rfl⟩ | hz)
+    · change coeffEmb K (algebraMap ℚ (LaurentSeries ℚ) a) ∈ adjoin K ((coeffEmb K) '' S)
+      rw [coeffEmb_algebraMap]
+      exact IntermediateField.algebraMap_mem _ _
+    · change coeffEmb K z ∈ adjoin K ((coeffEmb K) '' S)
+      exact subset_adjoin K _ ⟨z, hz, rfl⟩
+  exact hle hy'
+
+variable (Γ)
+
+theorem laurentBaseChange_qExpFunctionFieldC_eq :
+    laurentBaseChange K (qExpFunctionFieldC ℚ Γ) = qExpFunctionFieldC K Γ := by
+  apply le_antisymm
+  · rw [laurentBaseChange, IntermediateField.adjoin_le_iff]
+    rintro _ ⟨y, hy, rfl⟩
+    have h := coeffEmb_mem_adjoin K (S := intFormRatiosC ℚ Γ) hy
+    rwa [image_intFormRatiosC] at h
+  · rw [qExpFunctionFieldC, ← image_intFormRatiosC K Γ, laurentBaseChange]
+    exact IntermediateField.adjoin.mono K _ _ (Set.image_mono (intFormRatiosC_subset ℚ Γ))
+
+end BaseChange
+
+section Groups
+open scoped MatrixGroups
+open CongruenceSubgroup
+
+theorem mem_or_neg_mem_of_mem_sup_zpowers_neg_one {M : ℕ} (H : Subgroup (ZMod M)ˣ)
+    {d : (ZMod M)ˣ} (hd : d ∈ H ⊔ Subgroup.zpowers (-1 : (ZMod M)ˣ)) : d ∈ H ∨ -d ∈ H := by
+  let S : Subgroup (ZMod M)ˣ :=
+    { carrier := {x | x = 1 ∨ x = -1}
+      one_mem' := Or.inl rfl
+      mul_mem' := by
+        rintro a b (rfl | rfl) (rfl | rfl) <;> simp
+      inv_mem' := by
+        rintro a (rfl | rfl) <;> simp }
+  have hS : Subgroup.zpowers (-1 : (ZMod M)ˣ) ≤ S := by
+    rw [Subgroup.zpowers_le]
+    exact Or.inr rfl
+  obtain ⟨h, hh, z, hz, rfl⟩ := Subgroup.mem_sup.mp hd
+  rcases hS hz with hz1 | hz1
+  · left; rw [hz1, mul_one]; exact hh
+  · right; rw [hz1]; simpa using hh
+
+theorem neg_mem_Gamma0 {M : ℕ} {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 M) : -γ ∈ Gamma0 M := by
+  have := Gamma0_mem.mp hγ
+  rw [Gamma0_mem]
+  simp [Matrix.SpecialLinearGroup.coe_neg, this]
+
+theorem gamma0Units_neg {M : ℕ} {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 M) :
+    CohCarrier.gamma0Units M ⟨-γ, neg_mem_Gamma0 hγ⟩ = -CohCarrier.gamma0Units M ⟨γ, hγ⟩ := by
+  ext
+  simp [CohCarrier.gamma0Units, Gamma0Map, Matrix.SpecialLinearGroup.coe_neg]
+
+theorem mem_or_neg_mem_gammaH_of_mem_gammaH_sup {M : ℕ} (H : Subgroup (ZMod M)ˣ) {γ : SL(2, ℤ)}
+    (hγ : γ ∈ CohCarrier.GammaH M (H ⊔ Subgroup.zpowers (-1 : (ZMod M)ˣ))) :
+    γ ∈ CohCarrier.GammaH M H ∨ -γ ∈ CohCarrier.GammaH M H := by
+  obtain ⟨hγ0, hd⟩ := CohCarrier.mem_GammaH_iff.mp hγ
+  rcases mem_or_neg_mem_of_mem_sup_zpowers_neg_one H hd with h | h
+  · exact Or.inl (CohCarrier.mem_GammaH_iff.mpr ⟨hγ0, h⟩)
+  · exact Or.inr (CohCarrier.mem_GammaH_iff.mpr ⟨neg_mem_Gamma0 hγ0, by
+      rw [gamma0Units_neg hγ0]; exact h⟩)
+
+theorem gamma1_sup_zpowers_neg_one_eq (M : ℕ) :
+    Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) =
+      CohCarrier.GammaH M (⊥ ⊔ Subgroup.zpowers (-1 : (ZMod M)ˣ)) := by
+  apply le_antisymm
+  · refine sup_le ((ModularCurve.Gamma1_le_GammaH M ⊥).trans (ModularCurve.GammaH_mono le_sup_left))
+      ?_
+    rw [Subgroup.zpowers_le]
+    have hm1 : (-1 : SL(2, ℤ)) ∈ Gamma0 M := neg_mem_Gamma0 (one_mem _)
+    refine CohCarrier.mem_GammaH_iff.mpr ⟨hm1, ?_⟩
+    have : CohCarrier.gamma0Units M ⟨-1, hm1⟩ = -1 := by
+      have h := gamma0Units_neg (M := M) (one_mem (Gamma0 M))
+      have h1 : CohCarrier.gamma0Units M ⟨1, one_mem _⟩ = 1 := map_one _
+      rw [h1] at h
+      convert h using 2
+    rw [this]
+    exact Subgroup.mem_sup_right (Subgroup.mem_zpowers _)
+  · intro γ hγ
+    rcases mem_or_neg_mem_gammaH_of_mem_gammaH_sup ⊥ hγ with h | h
+    · exact Subgroup.mem_sup_left ((ModularCurve.GammaH_bot M).le h)
+    · have hneg : -γ ∈ Gamma1 M := (ModularCurve.GammaH_bot M).le h
+      have : γ = (-1) * (-γ) := by simp
+      rw [this]
+      exact Subgroup.mul_mem _ (Subgroup.mem_sup_right (Subgroup.mem_zpowers _))
+        (Subgroup.mem_sup_left hneg)
+
+end Groups
+
+end ModularCurve.FullnessGamma1
+
+p2m_open "ModularCurve~coeffEmb_injective \
+  P2MW.S_OVERLONG_b0db17b1.Mo\
+  dularCurve CongruenceSubgroup AlgebraicCurve"
+open scoped MatrixGroups
+
+open ModularCurve.FullnessGamma1 IntermediateField in
+set_option synthInstance.maxHeartbeats 1600000 in
+theorem solution
+    (K : Type*) [Field K] [Algebra ℚ K] [IsAlgClosed K]
+    (M : ℕ) [NeZero M]
+    (y : ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))))
+    (hy : (y : LaurentSeries K) = ModularCurve.jqModC K) :
+    Module.finrank
+        ↥(IntermediateField.adjoin K ({y} : Set ↥(ModularCurve.laurentBaseChange K
+          (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))))
+        ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ
+          (CongruenceSubgroup.Gamma1 M))) =
+      (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index := by
+  classical
+  have : CharZero K := charZero_of_injective_algebraMap (algebraMap ℚ K).injective
+  have hMK : (M : K) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne M)
+  have hfi1 : (Gamma1 M).FiniteIndex := (CongruenceSubgroup.Gamma1_is_congruence M).finiteIndex
+  have hfi0 : (Gamma0 M).FiniteIndex := (CongruenceSubgroup.Gamma0_is_congruence M).finiteIndex
+  have hT1 : ModularGroup.T ∈ Gamma1 M := by
+    rw [← ModularCurve.GammaH_bot M]; exact ModularCurve.translation_mem_GammaH M ⊥
+  have hT0 : ModularGroup.T ∈ Gamma0 M := by
+    rw [← CohCarrier.GammaH_top (M := M)]; exact ModularCurve.translation_mem_GammaH M ⊤
+  have h10 : Gamma1 M ≤ Gamma0 M :=
+    (ModularCurve.Gamma1_le_GammaH M ⊥).trans (CohCarrier.GammaH_le_Gamma0 ⊥)
+  have hsup := gamma1_sup_zpowers_neg_one_eq M
+  have hneg : ∀ γ ∈ Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)), γ ∈ Gamma1 M ∨ -γ ∈ Gamma1 M := by
+    intro γ hγ
+    rw [hsup] at hγ
+    have h := mem_or_neg_mem_gammaH_of_mem_gammaH_sup ⊥ hγ
+    rwa [ModularCurve.GammaH_bot M] at h
+  have hle := ModularCurve.finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_le_index K
+    (Gamma1 M) hT1 (Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))) le_sup_left hneg y hy
+  refine le_antisymm hle ?_
+  have hidx : (Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index =
+      dedekindPsi M * (⊥ ⊔ Subgroup.zpowers (-1 : (ZMod M)ˣ)).index := by
+    rw [hsup, CohCarrier.index_gammaH_eq_index_gamma0_mul_index, ModularCurve.Gamma0_index]
+  have hEE : laurentBaseChange K (qExpFunctionFieldC ℚ (Gamma1 M)) = qExpFunctionFieldC K (Gamma1 M)
+    :=
+    laurentBaseChange_qExpFunctionFieldC_eq K (Gamma1 M)
+  have hF0E : qExpFunctionFieldC K (Gamma0 M) ≤ qExpFunctionFieldC K (Gamma1 M) :=
+    ModularCurve.qExpFunctionFieldC_mono K h10
+  have hjF0 : jqModC K ∈ qExpFunctionFieldC K (Gamma0 M) :=
+    intFormRatiosC_subset K (Gamma0 M) (ModularCurve.jqModC_mem_intFormRatiosC K (Gamma0 M))
+  have hJF0 : IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) ≤ qExpFunctionFieldC K
+    (Gamma0 M) :=
+    IntermediateField.adjoin_le_iff.mpr (Set.singleton_subset_iff.mpr hjF0)
+  have eJE' : Module.finrank
+        ↥(IntermediateField.adjoin K ({y} : Set ↥(laurentBaseChange K (qExpFunctionFieldC ℚ (Gamma1
+          M)))))
+        ↥(laurentBaseChange K (qExpFunctionFieldC ℚ (Gamma1 M))) =
+      (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))).relfinrank
+        (laurentBaseChange K (qExpFunctionFieldC ℚ (Gamma1 M))) := by
+    have h := finrank_adjoin_eq_relfinrank (laurentBaseChange K (qExpFunctionFieldC ℚ (Gamma1 M))) y
+    rw [hy] at h
+    exact h
+  have eJF0 : dedekindPsi M ≤
+      (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))).relfinrank
+        (qExpFunctionFieldC K (Gamma0 M)) := by
+    obtain ⟨hfin, -⟩ :=
+      ModularCurve.finrank_adjoin_jqModC_qExpFunctionFieldC_le_index_of_isAlgClosed K
+      (Gamma0 M) hT0 (Gamma0 M) le_rfl (fun γ hγ => Or.inl hγ) ⟨jqModC K, hjF0⟩ rfl
+    have := hfin
+    have h :=
+      ModularCurve.dedekindPsi_le_finrank_adjoin_qExpFunctionFieldC_gamma0 K M hMK ⟨jqModC K, hjF0⟩
+        rfl
+    have e := finrank_adjoin_eq_relfinrank (qExpFunctionFieldC K (Gamma0 M)) ⟨jqModC K, hjF0⟩
+    exact e ▸ h
+  have eF0E : (⊥ ⊔ Subgroup.zpowers (-1 : (ZMod M)ˣ)).index ≤
+      (qExpFunctionFieldC K (Gamma0 M)).relfinrank (qExpFunctionFieldC K (Gamma1 M)) := by
+    have h := ModularCurve.index_le_relfinrank_qExpFunctionFieldC_gamma0_gammaH_of_charZero K M ⊥
+    rwa [ModularCurve.GammaH_bot M] at h
+  have t1 := IntermediateField.relfinrank_mul_relfinrank hJF0 hF0E
+  have key : dedekindPsi M * (⊥ ⊔ Subgroup.zpowers (-1 : (ZMod M)ˣ)).index ≤
+      (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))).relfinrank
+        (laurentBaseChange K (qExpFunctionFieldC ℚ (Gamma1 M))) := by
+    rw [hEE, ← t1]
+    exact Nat.mul_le_mul eJF0 eF0E
+  calc (Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index
+      = dedekindPsi M * (⊥ ⊔ Subgroup.zpowers (-1 : (ZMod M)ˣ)).index := hidx
+    _ ≤ (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))).relfinrank
+        (laurentBaseChange K (qExpFunctionFieldC ℚ (Gamma1 M))) := key
+    _ = _ := eJE'.symm
+
+end S_OVERLONG_b0db17b1
+end P2MW
+export
+  P2MW.S_OVERLONG_b0db17b1
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open CongruenceSubgroup AlgebraicCurve
+open ModularCurve
+open scoped MatrixGroups
+theorem ModularCurve.finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index
+    (K : Type*) [Field K] [Algebra ℚ K] [IsAlgClosed K]
+    (M : ℕ) [NeZero M]
+    (y : ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))))
+    (hy : (y : LaurentSeries K) = ModularCurve.jqModC K) :
+    Module.finrank
+        ↥(IntermediateField.adjoin K ({y} : Set ↥(ModularCurve.laurentBaseChange K
+          (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))))
+        ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ
+          (CongruenceSubgroup.Gamma1 M))) =
+      (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index :=
+  solution K M y hy
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_le_index.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_le_index.lean
new file mode 100644
index 0000000000..dc3875b41e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_le_index.lean
@@ -0,0 +1,1191 @@
+/-
+Based on Prove2Me node
+ModularCurve.finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_le_index
+(4dd51e11-6963-58d5-8ed3-5d91243e5e6c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1725a524-e81c-535d-955e-491a2544b961
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Algebra.Polynomial.Homogenize
+import Mathlib.LinearAlgebra.Lagrange
+import Mathlib.NumberTheory.ModularForms.LevelOne.DimensionFormula
+import Mathlib.NumberTheory.ModularForms.NormTrace
+import Mathlib.RingTheory.Flat.TorsionFree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_laurentBaseChange
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree over L(j) bounded by the index of Γ'
+
+Theorem statement:
+`ModularCurve.finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_le_index`
+(`4dd51e11-6963-58d5-8ed3-5d91243e5e6c`), by Claude, 2026-09-05.
+
+Proof: submission `1725a524-e81c-535d-955e-491a2544b961`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbb{Q}$-algebra structure, let
+$\Gamma\le\mathrm{SL}_2(\mathbb{Z})$ be a subgroup of finite index containing the translation matrix
+`ModularGroup.T`, and let $\Gamma'\le\mathrm{SL}_2(\mathbb{Z})$ be a subgroup with
+$\Gamma\le\Gamma'$ such that every $\gamma\in\Gamma'$ satisfies $\gamma\in\Gamma$ or
+$-\gamma\in\Gamma$. Write $F_0=$ [`ModularCurve.qExpFunctionFieldC ℚ
+Γ`](def/ModularCurve_X1.html#L101) for the subfield of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$
+by all quotients `intSeriesC ℚ pf / intSeriesC ℚ pg`, where for some weight $k$ there are modular
+forms $f,g$ of weight $k$ for the image of $\Gamma$ in $\mathrm{GL}_2(\mathbb{R})$ and integral
+power series $pf,pg$ with `IsIntegralQExp f pf`, `IsIntegralQExp g pg` and `intSeriesC ℚ pg ≠ 0`,
+and write $F=$ [`ModularCurve.laurentBaseChange L F₀`](def/ModularCurve_LaurentCoeff.html#L103) for
+the subfield of $L((q))$ generated over $L$ by the image of $F_0$ under the coefficientwise map
+$\mathbb{Q}((q))\to L((q))$ induced by $\mathbb{Q}\to L$. Let $y\in F$ be an element whose
+underlying Laurent series is [`ModularCurve.jqModC L`](def/ModularCurve_JqCoeff.html#L15), namely
+$q^{-1}$ times the image over $L$ of the integral power series
+[`ModularCurve.jNum`](def/ModularCurve_X0.html#L142) $=E_4^3\cdot$ `dedekindEtaUnitInv`. Then the
+$L(y)$-dimension of $F$, where $L(y)$ denotes the subfield of $F$ generated over $L$ by $y$, is at
+most the index of $\Gamma'$ in $\mathrm{SL}_2(\mathbb{Z})$. The conclusion is an inequality on
+`Module.finrank`, so it asserts a degree bound rather than finiteness of the extension.
+
+This is the classical upper bound for the degree of the field of modular functions of level $\Gamma$
+over the $j$-line, in the form $[F:L(j)]\le[\mathrm{SL}_2(\mathbb{Z}):\Gamma']$ for any $\Gamma'$
+between $\Gamma$ and $\{\pm1\}\Gamma$, stated for the $q$-expansion model of the function field base
+changed to an arbitrary field $L$ of characteristic zero. It is used in the comparison of the
+generic and special degrees of modular curves over the $j$-line, and is invoked in the treatment of
+$X_1$, $X_0$ and full-level models, for instance in the ramification computation at complex places
+and in the finite-dimensionality statements for $\Gamma_H$ levels.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_le_index.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+-- Avoid an instance diamond involving subfields.
+attribute [-instance] DivisionRing.toRatAlgebra
+
+namespace P2MW.S_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_le_index
+
+
+namespace FIdxAlg
+
+open HahnSeries Polynomial
+
+section A2
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+
+theorem linearIndependent_map {ι : Type*} {v : ι → LaurentSeries K} (hv : LinearIndependent K v) :
+    LinearIndependent L (fun i => HahnSeries.map (v i) (algebraMap K L)) := by
+  classical
+  rw [linearIndependent_iff']
+  intro s c hsum i hi
+  let W : Submodule K L := Submodule.span K (Set.range fun j : s => c j)
+  have : Module.Finite K W := Module.Finite.span_of_finite K (Set.finite_range _)
+  let b := Module.finBasis K W
+  have hcW : ∀ j : s, c j ∈ W := fun j => Submodule.subset_span ⟨j, rfl⟩
+  let a : s → Fin (Module.finrank K W) → K := fun j l => b.repr ⟨c j, hcW j⟩ l
+  have hca : ∀ j : s, c j = ∑ l, a j l • (b l : L) := by
+    intro j
+    have h1 := b.sum_repr ⟨c j, hcW j⟩
+    have h2 := congrArg (Submodule.subtype W) h1
+    rw [map_sum] at h2
+    simp only [Submodule.subtype_apply, Submodule.coe_smul] at h2
+    exact h2.symm
+  have hcoeff : ∀ n : ℤ, ∑ j ∈ s, c j * algebraMap K L ((v j).coeff n) = 0 := by
+    intro n
+    have := congrArg (fun x : LaurentSeries L => x.coeff n) hsum
+    simpa [HahnSeries.coeff_sum] using this
+  have hbi : LinearIndependent K (fun l' => (b l' : L)) :=
+    b.linearIndependent.map' W.subtype (Submodule.ker_subtype W)
+  have hv' : LinearIndependent K (fun j : s => v j) := hv.comp _ Subtype.val_injective
+  have hrel : ∀ l, ∑ j : s, a j l • v j = 0 := by
+    intro l
+    ext n
+    have h1 : ∑ l', (∑ j : s, a j l' * (v j).coeff n) • (b l' : L) = 0 := by
+      have h0 := hcoeff n
+      rw [← Finset.sum_coe_sort] at h0
+      simp_rw [hca, Finset.sum_mul] at h0
+      rw [Finset.sum_comm] at h0
+      rw [← h0]
+      refine Finset.sum_congr rfl fun l' _ => ?_
+      rw [Finset.sum_smul]
+      refine Finset.sum_congr rfl fun j _ => ?_
+      rw [Algebra.smul_def, Algebra.smul_def, map_mul]; ring
+    have := Fintype.linearIndependent_iff.mp hbi (fun l' => ∑ j : s, a j l' * (v j).coeff n) h1 l
+    rw [HahnSeries.coeff_sum]
+    simpa [HahnSeries.coeff_smul] using this
+  have ha : ∀ (j : s) l, a j l = 0 := fun j l =>
+    Fintype.linearIndependent_iff.mp hv' (fun j => a j l) (hrel l) j
+  rw [show c i = c (⟨i, hi⟩ : s) from rfl, hca]
+  simp [ha]
+
+end A2
+
+section A3
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem finiteDimensional_of_forall_aeval_eq_zero [PerfectField K] (D : ℕ)
+    (h : ∀ y : F, ∃ p : K[X], p ≠ 0 ∧ p.natDegree ≤ D ∧ aeval y p = 0) :
+    FiniteDimensional K F := by
+  have : Algebra.IsAlgebraic K F := ⟨fun y => by
+    obtain ⟨p, hp0, -, hpy⟩ := h y
+    exact ⟨p, hp0, hpy⟩⟩
+  have : Algebra.IsSeparable K F := Algebra.IsAlgebraic.isSeparable_of_perfectField
+  by_contra hinf
+  obtain ⟨L, hLfd, hlt⟩ := IntermediateField.exists_lt_finrank_of_infinite_dimensional hinf D
+  have := hLfd
+  have : Algebra.IsSeparable K L := Algebra.isSeparable_tower_bot_of_isSeparable K L F
+  obtain ⟨α, hα⟩ := Field.exists_primitive_element K L
+  have hdeg : (minpoly K α).natDegree = Module.finrank K L :=
+    (Field.primitive_element_iff_minpoly_natDegree_eq K α).mp hα
+  obtain ⟨p, hp0, hpD, hpy⟩ := h (α : F)
+  have hmin : minpoly K α = minpoly K (α : F) := IntermediateField.minpoly_eq α
+  have hle : (minpoly K (α : F)).natDegree ≤ p.natDegree :=
+    Polynomial.natDegree_le_of_dvd (minpoly.dvd K _ hpy) hp0
+  have : Module.finrank K L ≤ D := by
+    rw [← hdeg, hmin]
+    exact hle.trans hpD
+  exact absurd hlt (not_lt.mpr this)
+
+theorem finrank_le_of_forall_aeval_eq_zero [PerfectField K] (D : ℕ)
+    (h : ∀ y : F, ∃ p : K[X], p ≠ 0 ∧ p.natDegree ≤ D ∧ aeval y p = 0) :
+    Module.finrank K F ≤ D := by
+  have : FiniteDimensional K F := finiteDimensional_of_forall_aeval_eq_zero D h
+  have : Algebra.IsAlgebraic K F := Algebra.IsAlgebraic.of_finite K F
+  have : Algebra.IsSeparable K F := Algebra.IsAlgebraic.isSeparable_of_perfectField
+  obtain ⟨α, hα⟩ := Field.exists_primitive_element K F
+  have hdeg : (minpoly K α).natDegree = Module.finrank K F :=
+    (Field.primitive_element_iff_minpoly_natDegree_eq K α).mp hα
+  obtain ⟨p, hp0, hpD, hpy⟩ := h α
+  have hle : (minpoly K α).natDegree ≤ p.natDegree :=
+    Polynomial.natDegree_le_of_dvd (minpoly.dvd K _ hpy) hp0
+  rw [← hdeg]
+  exact hle.trans hpD
+
+end A3
+
+section A4
+
+variable {K A : Type*} [Field K] [Field A] [Algebra K A]
+
+theorem adjoin_simple_eq_comap (E : IntermediateField K A) (x : E) :
+    IntermediateField.adjoin K ({x} : Set E) =
+      (IntermediateField.adjoin K ({(x : A)} : Set A)).comap (IntermediateField.val E) := by
+  apply IntermediateField.lift_injective
+  erw [IntermediateField.lift_adjoin_simple]
+  change _ = ((IntermediateField.adjoin K ({(x : A)} : Set A)).comap E.val).map E.val
+  rw [IntermediateField.map_comap_eq, IntermediateField.fieldRange_val, inf_eq_left.mpr]
+  exact IntermediateField.adjoin_le_iff.mpr (Set.singleton_subset_iff.mpr x.2)
+
+theorem finrank_adjoin_simple_eq_relfinrank (E : IntermediateField K A) (x : E) :
+    Module.finrank (IntermediateField.adjoin K ({x} : Set E)) E =
+      IntermediateField.relfinrank (IntermediateField.adjoin K ({(x : A)} : Set A)) E := by
+  rw [adjoin_simple_eq_comap, IntermediateField.finrank_comap, IntermediateField.fieldRange_val]
+
+end A4
+
+end FIdxAlg
+
+namespace FIdxLevelOne
+
+open ModularForm UpperHalfPlane EisensteinSeries
+open scoped MatrixGroups
+
+noncomputable abbrev q4 : PowerSeries ℂ := qExpansion 1 (E₄ : ℍ → ℂ)
+noncomputable abbrev qΔ : PowerSeries ℂ := qExpansion 1 (ModularForm.discriminant : ℍ → ℂ)
+
+noncomputable def monomialSpan (m : ℕ) : Submodule ℂ (PowerSeries ℂ) :=
+  Submodule.span ℂ (Set.range fun b : Fin (m + 1) => q4 ^ (3 * (m - b)) * qΔ ^ (b : ℕ))
+
+theorem monomial_mem (m : ℕ) (b : ℕ) (hb : b ≤ m) :
+    q4 ^ (3 * (m - b)) * qΔ ^ b ∈ monomialSpan m :=
+  Submodule.subset_span ⟨⟨b, Nat.lt_succ_of_le hb⟩, rfl⟩
+
+theorem q4_coeff_zero : PowerSeries.coeff 0 q4 = 1 :=
+  E_qExpansion_coeff_zero (by norm_num) (by decide)
+
+theorem qExpansion_mem_monomialSpan (m : ℕ) :
+    ∀ (k : ℤ) (_ : k = 12 * (m : ℤ)) (h : ModularForm 𝒮ℒ k)
+      , qExpansion 1 (h : ℍ → ℂ) ∈ monomialSpan m := by
+  induction m with
+  | zero =>
+    intro k hk h
+    simp only [Nat.cast_zero, mul_zero] at hk
+    subst hk
+    obtain ⟨c, hc⟩ := ModularFormClass.levelOne_weight_zero_const h
+    have hh : h = c • (1 : ModularForm 𝒮ℒ 0) := by
+      ext z
+      rw [hc, smul_apply]
+      simp
+    rw [hh, FunLike.coe_smul, ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL,
+      ModularForm.qExpansion_one]
+    refine Submodule.smul_mem _ _ ?_
+    have := monomial_mem 0 0 le_rfl
+    simpa using this
+  | succ m ih =>
+    intro k hk h
+    set a₀ : ℂ := PowerSeries.coeff 0 (qExpansion 1 (h : ℍ → ℂ)) with ha₀
+    let P : ModularForm 𝒮ℒ k := (E₄.pow (3 * (m + 1))).mcast (by rw [hk]; push_cast; ring)
+    have hP : qExpansion 1 (P : ℍ → ℂ) = q4 ^ (3 * (m + 1)) := by
+      simp only [P, ModularForm.qExpansion_mcast,
+        ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+    let g : ModularForm 𝒮ℒ k := h - a₀ • P
+    have hg : qExpansion 1 (g : ℍ → ℂ) = qExpansion 1 (h : ℍ → ℂ) - a₀ • q4 ^ (3 * (m + 1)) := by
+      simp only [g]
+      rw [FunLike.coe_sub, ModularForm.qExpansion_sub one_pos one_mem_strictPeriods_SL,
+        FunLike.coe_smul,
+        ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL, hP]
+    have hg0 : PowerSeries.coeff 0 (qExpansion 1 (g : ℍ → ℂ)) = 0 := by
+      have h4 : PowerSeries.coeff 0 (q4 ^ (3 * (m + 1))) = 1 := by
+        rw [PowerSeries.coeff_zero_eq_constantCoeff_apply, map_pow,
+          ← PowerSeries.coeff_zero_eq_constantCoeff_apply, q4_coeff_zero, one_pow]
+      rw [hg, map_sub, map_smul, h4, smul_eq_mul, mul_one, ha₀, sub_self]
+    have hΔ := ModularForm.qExpansion_eq_qExpansion_discriminant_mul g hg0
+    have hk' : k - 12 = 12 * (m : ℤ) := by rw [hk]; push_cast; ring
+    have hIH := ih (k - 12) hk' (CuspForm.discriminantEquiv (g.toCuspForm hg0))
+    have hh : qExpansion 1 (h : ℍ → ℂ) =
+        a₀ • q4 ^ (3 * (m + 1)) +
+          qΔ * qExpansion 1 (CuspForm.discriminantEquiv (g.toCuspForm hg0) : ℍ → ℂ) := by
+      rw [← hΔ, hg]; abel
+    rw [hh]
+    refine Submodule.add_mem _ (Submodule.smul_mem _ _ ?_) ?_
+    · have := monomial_mem (m + 1) 0 (Nat.zero_le _)
+      simpa using this
+    · refine Submodule.span_induction (p := fun x _ => qΔ * x ∈ monomialSpan (m + 1))
+        ?_ ?_ ?_ ?_ hIH
+      · rintro _ ⟨b, rfl⟩
+        have hb : (b : ℕ) ≤ m := Nat.lt_succ_iff.mp b.2
+        have := monomial_mem (m + 1) (b + 1) (Nat.succ_le_succ hb)
+        rw [show 3 * (m + 1 - ((b : ℕ) + 1)) = 3 * (m - b) by omega, pow_succ] at this
+        rw [show qΔ * (q4 ^ (3 * (m - ↑b)) * qΔ ^ (b : ℕ)) =
+          q4 ^ (3 * (m - ↑b)) * (qΔ ^ (b : ℕ) * qΔ) by ring]
+        exact this
+      · simp
+      · intro x y _ _ hx hy
+        rw [mul_add]
+        exact Submodule.add_mem _ hx hy
+      · intro c x _ hx
+        rw [mul_smul_comm]
+        exact Submodule.smul_mem _ _ hx
+
+end FIdxLevelOne
+
+namespace FIdxNorm
+
+open ModularForm UpperHalfPlane SlashInvariantForm Polynomial
+open scoped MatrixGroups ModularForm
+
+variable {Γ : Subgroup SL(2, ℤ)} [Γ.FiniteIndex] {k : ℤ}
+
+abbrev Cos (Γ : Subgroup SL(2, ℤ)) : Type := ↥𝒮ℒ ⧸ (Γ : Subgroup (GL (Fin 2) ℝ)).subgroupOf 𝒮ℒ
+
+noncomputable scoped instance : Fintype (Cos Γ) := Fintype.ofFinite _
+
+omit [Γ.FiniteIndex] in
+theorem card_cos_eq_index : Nat.card (Cos Γ) = Γ.index := by
+  rw [← Subgroup.index, ← Subgroup.relIndex, MonoidHom.range_eq_map,
+    show ((Γ : Subgroup (GL (Fin 2) ℝ))) = Γ.map (Matrix.SpecialLinearGroup.mapGL ℝ) from rfl,
+    Subgroup.relIndex_map_map_of_injective _ _ Matrix.SpecialLinearGroup.mapGL_injective,
+    Subgroup.relIndex_top_right]
+
+omit [Γ.FiniteIndex] in
+theorem one_mem_strictPeriods (hT : ModularGroup.T ∈ Γ) :
+    (1 : ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  rw [Subgroup.mem_strictPeriods_iff]
+  refine ⟨ModularGroup.T, hT, ?_⟩
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp [ModularGroup.T, Matrix.GeneralLinearGroup.upperRightHom]
+
+section Linear
+
+variable (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+
+omit [Γ.FiniteIndex] in
+theorem quotientFunc_smul_sub (c : ℂ) (q : (Cos Γ)) :
+    quotientFunc (c • g - f) q = c • quotientFunc g q - quotientFunc f q := by
+  induction q using Quotient.inductionOn with
+  | h r =>
+    simp only [quotientFunc_mk]
+    obtain ⟨γ, hγ⟩ := r.2
+    have hr : (r.val)⁻¹ = ((γ⁻¹ : SL(2, ℤ)) : GL (Fin 2) ℝ) := by rw [← hγ, ← map_inv]; rfl
+    rw [hr, ← ModularForm.SL_slash, ← ModularForm.SL_slash, ← ModularForm.SL_slash,
+      FunLike.coe_sub, FunLike.coe_smul, sub_eq_add_neg, SlashAction.add_slash,
+      SlashAction.neg_slash, ModularForm.SL_smul_slash, sub_eq_add_neg]
+
+theorem norm_smul_sub_apply (c : ℂ) (τ : ℍ) :
+    (ModularForm.norm 𝒮ℒ (c • g - f)) τ = ∏ q : (Cos Γ), (c * quotientFunc g q τ - quotientFunc f q
+      τ) := by
+  have h := ModularForm.coe_norm 𝒮ℒ (c • g - f)
+  rw [h]
+  rw [Finset.prod_apply]
+  refine Fintype.prod_congr _ _ (fun q => ?_)
+  rw [quotientFunc_smul_sub]
+  simp
+
+noncomputable def charPolyAt (τ : ℍ) : ℂ[X] :=
+  ∏ q : (Cos Γ), (C (quotientFunc g q τ) * X - C (quotientFunc f q τ))
+
+theorem eval_charPolyAt (c : ℂ) (τ : ℍ) :
+    (charPolyAt f g τ).eval c = (ModularForm.norm 𝒮ℒ (c • g - f)) τ := by
+  rw [norm_smul_sub_apply, charPolyAt, eval_prod]
+  refine Finset.prod_congr rfl fun q _ => ?_
+  simp only [eval_sub, eval_mul, eval_C, eval_X]
+  ring
+
+theorem natDegree_linear_le (a b : ℂ) : (C a * X - C b).natDegree ≤ 1 := by
+  refine (natDegree_sub_le _ _).trans ?_
+  refine max_le ?_ (by simp)
+  exact (natDegree_C_mul_le _ _).trans (by simp)
+
+theorem card_cos : (Finset.univ : Finset (Cos Γ)).card = Nat.card (Cos Γ) := by
+  rw [Nat.card_eq_fintype_card, Finset.card_univ]
+
+theorem natDegree_charPolyAt_le (τ : ℍ) : (charPolyAt f g τ).natDegree ≤ Nat.card (Cos Γ) := by
+  rw [charPolyAt]
+  refine (natDegree_prod_le _ _).trans ?_
+  refine (Finset.sum_le_sum fun q _ => natDegree_linear_le
+    (quotientFunc g q τ) (quotientFunc f q τ)).trans ?_
+  rw [Finset.sum_const, smul_eq_mul, mul_one, card_cos]
+
+theorem coeff_charPolyAt_card (τ : ℍ) :
+    (charPolyAt f g τ).coeff (Nat.card (Cos Γ)) = (ModularForm.norm 𝒮ℒ g) τ := by
+  have hc : (Finset.univ : Finset (Cos Γ)).card * 1 = Nat.card (Cos Γ) := by rw [mul_one, card_cos]
+  rw [charPolyAt]
+  conv_lhs => rw [← hc, coeff_prod_of_natDegree_le (s := Finset.univ) (n := 1)
+    (f := fun q : Cos Γ => C (quotientFunc g q τ) * X - C (quotientFunc f q τ))
+    (h := fun q _ => natDegree_linear_le _ _)]
+  rw [ModularForm.coe_norm, Finset.prod_apply]
+  refine Fintype.prod_congr _ _ (fun q => ?_)
+  simp
+
+def node (n : ℕ) (j : Fin (n + 1)) : ℂ := (j : ℕ)
+
+theorem node_injOn (n : ℕ) : Set.InjOn (node n) (Finset.univ : Finset (Fin (n + 1))) := by
+  intro i _ j _ h
+  simp only [node, Nat.cast_inj] at h
+  exact Fin.ext h
+
+noncomputable def lag (n : ℕ) (j : Fin (n + 1)) : ℂ[X] :=
+  Lagrange.basis (Finset.univ : Finset (Fin (n + 1))) (node n) j
+
+theorem charPolyAt_eq_sum (τ : ℍ) :
+    charPolyAt f g τ = ∑ j : Fin (Nat.card (Cos Γ) + 1),
+      C ((ModularForm.norm 𝒮ℒ ((node _ j) • g - f)) τ) * lag (Nat.card (Cos Γ)) j := by
+  classical
+  have hdeg : (charPolyAt f g τ).degree < (Finset.univ : Finset (Fin (Nat.card (Cos Γ) + 1))).card
+    :=
+    by
+    rw [Finset.card_univ, Fintype.card_fin]
+    refine lt_of_le_of_lt (degree_le_natDegree) ?_
+    exact_mod_cast Nat.lt_succ_of_le (natDegree_charPolyAt_le f g τ)
+  have h := Lagrange.eq_interpolate (f := charPolyAt f g τ) (node_injOn (Nat.card (Cos Γ))) hdeg
+  rw [h, Lagrange.interpolate_apply]
+  refine Finset.sum_congr rfl fun j _ => ?_
+  rw [eval_charPolyAt]
+  rfl
+
+noncomputable def coeffForm (i : ℕ) : ModularForm 𝒮ℒ (k * Nat.card (Cos Γ)) :=
+  ∑ j : Fin (Nat.card (Cos Γ) + 1), ((lag (Nat.card (Cos Γ)) j).coeff i) • ModularForm.norm 𝒮ℒ
+    ((node _ j) • g - f)
+
+omit [Γ.FiniteIndex] in
+theorem coe_finset_sum {ι : Type*} {k' : ℤ} (s : Finset ι) (F : ι → ModularForm 𝒮ℒ k') :
+    ((∑ i ∈ s, F i : ModularForm 𝒮ℒ k') : ℍ → ℂ) = ∑ i ∈ s, (F i : ℍ → ℂ) :=
+  map_sum (FunLike.coeAddMonoidHom (ModularForm 𝒮ℒ k') UpperHalfPlane ℂ) F s
+
+theorem coeffForm_apply (i : ℕ) (τ : ℍ) : coeffForm f g i τ = (charPolyAt f g τ).coeff i := by
+  rw [coeffForm, coe_finset_sum, Finset.sum_apply, charPolyAt_eq_sum, finsetSum_coeff]
+  refine Finset.sum_congr rfl fun j _ => ?_
+  rw [smul_apply, coeff_C_mul, smul_eq_mul, mul_comm]
+
+theorem coe_coeffForm_card :
+    (coeffForm f g (Nat.card (Cos Γ)) : ℍ → ℂ) = ModularForm.norm 𝒮ℒ g := by
+  funext τ
+  rw [coeffForm_apply, coeff_charPolyAt_card]
+
+theorem eval_homogenize_linear (a b x y : ℂ) :
+    MvPolynomial.eval ![x, y] ((C a * X - C b).homogenize 1) = a * x - b * y := by
+  rw [homogenize_sub, homogenize_C_mul, homogenize_X one_ne_zero, homogenize_C]
+  simp
+
+theorem eval_homogenize_eq_sum (p : ℂ[X]) (n : ℕ) (x y : ℂ) :
+    MvPolynomial.eval ![x, y] (p.homogenize n) =
+      ∑ i ∈ Finset.range (n + 1), p.coeff i * x ^ i * y ^ (n - i) := by
+  simp only [homogenize, Finset.Nat.sum_antidiagonal_eq_sum_range_succ_mk, MvPolynomial.eval_sum]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [MvPolynomial.eval_monomial, Finsupp.update_eq_add_single, Finsupp.prod_add_index',
+    Finsupp.prod_single_index, Finsupp.prod_single_index]
+  · simp [mul_assoc]
+  all_goals simp [pow_add]
+
+theorem sum_coeffForm_mul_pow_eq_zero (τ : ℍ) :
+    ∑ i ∈ Finset.range (Nat.card (Cos Γ) + 1),
+      coeffForm f g i τ * f τ ^ i * g τ ^ (Nat.card (Cos Γ) - i) = 0 := by
+  simp_rw [coeffForm_apply]
+  rw [← eval_homogenize_eq_sum]
+  have hcard : Nat.card (Cos Γ) = ∑ _q ∈ (Finset.univ : Finset (Cos Γ)), 1 := by
+    simp [Nat.card_eq_fintype_card]
+  rw [charPolyAt, hcard, homogenize_finsetProd (fun q _ => natDegree_linear_le _ _), map_prod]
+  simp_rw [eval_homogenize_linear]
+  refine Finset.prod_eq_zero (Finset.mem_univ (QuotientGroup.mk (1 : ↥𝒮ℒ) : (Cos Γ))) ?_
+  have h1 : ∀ (φ : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k),
+      quotientFunc φ (QuotientGroup.mk (1 : ↥𝒮ℒ) : (Cos Γ)) = (φ : ℍ → ℂ) ∣[k] ((1 : ↥𝒮ℒ) : GL (Fin
+        2) ℝ)⁻¹ :=
+    fun φ => rfl
+  rw [h1, h1]
+  simp only [OneMemClass.coe_one, inv_one, SlashAction.slash_one]
+  ring
+
+def Nice (F : ℍ → ℂ) : Prop := AnalyticAt ℂ (cuspFunction 1 F) 0
+
+theorem Nice.mul {F G : ℍ → ℂ} (hF : Nice F) (hG : Nice G) : Nice (F * G) := by
+  unfold Nice at *
+  rw [cuspFunction_mul hF.continuousAt hG.continuousAt]
+  exact hF.mul hG
+
+theorem Nice.add {F G : ℍ → ℂ} (hF : Nice F) (hG : Nice G) : Nice (F + G) := by
+  unfold Nice at *
+  rw [cuspFunction_add hF.continuousAt hG.continuousAt]
+  exact hF.add hG
+
+theorem nice_one : Nice (1 : ℍ → ℂ) := by
+  have : (1 : ℍ → ℂ) = ⇑(1 : ModularForm 𝒮ℒ 0) := rfl
+  unfold Nice; rw [this]
+  exact ModularFormClass.analyticAt_cuspFunction_zero _ one_pos one_mem_strictPeriods_SL
+
+theorem nice_zero : Nice (0 : ℍ → ℂ) := by
+  have : (0 : ℍ → ℂ) = ⇑(0 : ModularForm 𝒮ℒ 0) := rfl
+  unfold Nice; rw [this]
+  exact ModularFormClass.analyticAt_cuspFunction_zero _ one_pos one_mem_strictPeriods_SL
+
+theorem Nice.pow {F : ℍ → ℂ} (hF : Nice F) : ∀ n : ℕ, Nice (F ^ n)
+  | 0 => by rw [pow_zero]; exact nice_one
+  | n + 1 => by rw [pow_succ]; exact (Nice.pow hF n).mul hF
+
+theorem qExpansion_pow' {F : ℍ → ℂ} (hF : Nice F) :
+    ∀ n : ℕ, qExpansion 1 (F ^ n) = qExpansion 1 F ^ n
+  | 0 => by rw [pow_zero, pow_zero, qExpansion_one]
+  | n + 1 => by
+    rw [pow_succ, pow_succ, qExpansion_mul (Nice.pow hF n) hF, qExpansion_pow' hF n]
+
+theorem Nice.sum {ι : Type*} (s : Finset ι) {F : ι → ℍ → ℂ} (hF : ∀ i ∈ s, Nice (F i)) :
+    Nice (∑ i ∈ s, F i) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => rw [Finset.sum_empty]; exact nice_zero
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha]
+    exact (hF a (Finset.mem_insert_self a s)).add (ih fun i hi => hF i (Finset.mem_insert_of_mem
+      hi))
+
+theorem qExpansion_sum' {ι : Type*} (s : Finset ι) {F : ι → ℍ → ℂ} (hF : ∀ i ∈ s, Nice (F i)) :
+    qExpansion 1 (∑ i ∈ s, F i) = ∑ i ∈ s, qExpansion 1 (F i) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => rw [Finset.sum_empty, Finset.sum_empty, qExpansion_zero]
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha, Finset.sum_insert ha,
+      qExpansion_add (hF a (Finset.mem_insert_self a s))
+        (Nice.sum s fun i hi => hF i (Finset.mem_insert_of_mem hi)),
+      ih fun i hi => hF i (Finset.mem_insert_of_mem hi)]
+
+variable (hT : ModularGroup.T ∈ Γ)
+include hT
+
+omit [Γ.FiniteIndex] in
+theorem nice_of_modularForm {k' : ℤ} (h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k') :
+    Nice (h : ℍ → ℂ) :=
+  ModularFormClass.analyticAt_cuspFunction_zero _ one_pos (one_mem_strictPeriods hT)
+
+omit hT in
+theorem nice_of_levelOne {k' : ℤ} (h : ModularForm 𝒮ℒ k') : Nice (h : ℍ → ℂ) :=
+  ModularFormClass.analyticAt_cuspFunction_zero _ one_pos one_mem_strictPeriods_SL
+
+theorem sum_qExpansion_coeffForm_mul_pow_eq_zero :
+    ∑ i ∈ Finset.range (Nat.card (Cos Γ) + 1),
+      qExpansion 1 (coeffForm f g i : ℍ → ℂ) * qExpansion 1 (f : ℍ → ℂ) ^ i *
+        qExpansion 1 (g : ℍ → ℂ) ^ (Nat.card (Cos Γ) - i) = 0 := by
+  set R : ℍ → ℂ := ∑ i ∈ Finset.range (Nat.card (Cos Γ) + 1),
+    (coeffForm f g i : ℍ → ℂ) * (f : ℍ → ℂ) ^ i * (g : ℍ → ℂ) ^ (Nat.card (Cos Γ) - i) with hR
+  have hR0 : R = 0 := by
+    funext τ
+    simp only [hR, Finset.sum_apply, Pi.mul_apply, Pi.pow_apply, Pi.zero_apply]
+    exact sum_coeffForm_mul_pow_eq_zero f g τ
+  have hnice : ∀ i ∈ Finset.range (Nat.card (Cos Γ) + 1),
+      Nice ((coeffForm f g i : ℍ → ℂ) * (f : ℍ → ℂ) ^ i * (g : ℍ → ℂ) ^ (Nat.card (Cos Γ) - i)) :=
+    fun i _ => ((nice_of_levelOne _).mul ((nice_of_modularForm hT f).pow i)).mul
+      ((nice_of_modularForm hT g).pow _)
+  have h := congrArg (qExpansion 1) hR0
+  rw [qExpansion_zero, hR, qExpansion_sum' _ hnice] at h
+  rw [← h]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [qExpansion_mul ((nice_of_levelOne _).mul ((nice_of_modularForm hT f).pow i))
+      ((nice_of_modularForm hT g).pow _),
+    qExpansion_mul (nice_of_levelOne _) ((nice_of_modularForm hT f).pow i),
+    qExpansion_pow' (nice_of_modularForm hT f), qExpansion_pow' (nice_of_modularForm hT g)]
+
+omit hT in
+theorem qExpansion_coeffForm_card_ne_zero (hg : g ≠ 0) :
+    qExpansion 1 (coeffForm f g (Nat.card (Cos Γ)) : ℍ → ℂ) ≠ 0 := by
+  rw [coe_coeffForm_card]
+  intro h
+  rw [ModularForm.qExpansion_eq_zero_iff one_pos one_mem_strictPeriods_SL] at h
+  exact ModularForm.norm_ne_zero 𝒮ℒ (f := g) (by
+    intro h0; exact hg (DFunLike.coe_injective (by simpa using h0))) h
+
+end Linear
+
+end FIdxNorm
+
+namespace FIdxRat
+
+p2m_open "ModularForm UpperHalfPlane EisensteinSeries ModularCurve~IsCusp HahnSeries Polynomial"
+open scoped MatrixGroups ModularForm
+
+variable {Γ : Subgroup SL(2, ℤ)} [Γ.FiniteIndex]
+
+section Lift
+
+variable {Γ' : Subgroup SL(2, ℤ)} {k : ℤ}
+
+omit [Γ.FiniteIndex] in
+theorem slash_neg_SL (f : ℍ → ℂ) (hk : Even k) (δ : SL(2, ℤ)) : f ∣[k] (-δ) = f ∣[k] δ := by
+  funext τ
+  rw [SL_slash_apply, SL_slash_apply]
+  have h1 : (-δ) • τ = δ • τ := by simp
+  have h2 : denom (-δ : SL(2, ℤ)) τ = - denom δ τ := by
+    simp [denom]; ring
+  rw [h1, h2, (Even.neg hk).neg_zpow]
+
+noncomputable def liftEven (hΓ' : Γ ≤ Γ') (hneg : ∀ γ ∈ Γ', γ ∈ Γ ∨ -γ ∈ Γ) (hk : Even k)
+    (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) :
+    ModularForm (Γ' : Subgroup (GL (Fin 2) ℝ)) k where
+  toFun := f
+  slash_action_eq' A hA := by
+    obtain ⟨γ, hγ, rfl⟩ := hA
+    rcases hneg γ hγ with h | h
+    · exact f.slash_action_eq' _ ⟨γ, h, rfl⟩
+    · have h' : (⇑f) ∣[k] (-γ) = ⇑f := f.slash_action_eq' _ ⟨-γ, h, rfl⟩
+      change (⇑f) ∣[k] γ = ⇑f
+      rw [← neg_neg γ, slash_neg_SL _ hk]
+      exact h'
+  holo' := f.holo'
+  bdd_at_cusps' {c} hc := by
+    have : Γ'.FiniteIndex := Subgroup.finiteIndex_of_le hΓ'
+    have hc' : IsCusp c (Γ : Subgroup (GL (Fin 2) ℝ)) := by
+      rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z] at hc ⊢
+      exact hc
+    exact f.bdd_at_cusps' hc'
+
+omit [Γ.FiniteIndex] in
+@[scoped simp]
+theorem coe_liftEven (hΓ' : Γ ≤ Γ') (hneg : ∀ γ ∈ Γ', γ ∈ Γ ∨ -γ ∈ Γ) (hk : Even k)
+    (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) [Γ.FiniteIndex] :
+    (liftEven hΓ' hneg hk f : ℍ → ℂ) = f := rfl
+
+end Lift
+
+omit [Γ.FiniteIndex] in
+theorem isIntegralQExp_E4 : IsIntegralQExp (E₄ : ℍ → ℂ) eisenstein4 := by
+  rw [isIntegralQExp_iff]
+  intro n
+  rw [E_qExpansion_coeff (by norm_num) (by decide) n, eisenstein4, PowerSeries.coeff_mk]
+  split_ifs with h
+  · simp
+  · rw [show _root_.bernoulli 4 = -1 / 30 by decide +kernel, ArithmeticFunction.sigma_apply]
+    push_cast
+    ring
+
+noncomputable abbrev PΔ : PowerSeries ℤ := PowerSeries.X * dedekindEtaUnit
+
+variable (Γ) in
+noncomputable def A12 : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12 :=
+  restrictForm (Subgroup.map_le_range _ Γ) ((E₄.pow 3).mcast (by norm_num))
+
+variable (Γ) in
+noncomputable def D12 : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12 :=
+  restrictForm (Subgroup.map_le_range _ Γ) (CuspForm.discriminant : ModularForm 𝒮ℒ 12)
+
+omit [Γ.FiniteIndex] in
+theorem isIntegralQExp_A12 : IsIntegralQExp (A12 Γ : ℍ → ℂ) (eisenstein4 ^ 3) := by
+  rw [IsIntegralQExp, A12, coe_restrictForm, map_pow, isIntegralQExp_E4]
+  rw [ModularForm.qExpansion_mcast, ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+
+omit [Γ.FiniteIndex] in
+theorem coe_D12 : (D12 Γ : ℍ → ℂ) = ModularForm.discriminant := rfl
+
+omit [Γ.FiniteIndex] in
+theorem isIntegralQExp_D12 : IsIntegralQExp (D12 Γ : ℍ → ℂ) PΔ := by
+  rw [IsIntegralQExp, coe_D12]
+  exact ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit.symm
+
+omit [Γ.FiniteIndex] in
+theorem isIntegralQExp_Delta : IsIntegralQExp (ModularForm.discriminant : ℍ → ℂ) PΔ :=
+  ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit.symm
+
+omit [Γ.FiniteIndex] in
+theorem intSeriesC_ne_zero_of_constantCoeff {K : Type*} [Field K] [CharZero K] {p : PowerSeries ℤ}
+    (hp : PowerSeries.constantCoeff p = 1) : intSeriesC K p ≠ 0 := by
+  intro h
+  have := congrArg (fun z : LaurentSeries K => z.coeff 0) h
+  simp only [intSeriesC, HahnSeries.coeff_zero] at this
+  rw [PowerSeries.coeff_coe] at this
+  simp only [lt_self_iff_false, ↓reduceIte, Int.natAbs_zero, PowerSeries.coeff_map,
+    PowerSeries.coeff_zero_eq_constantCoeff_apply, hp, map_one, one_ne_zero] at this
+
+omit [Γ.FiniteIndex] in
+theorem intSeriesC_E4_cube_ne_zero : intSeriesC ℚ (eisenstein4 ^ 3) ≠ 0 :=
+  intSeriesC_ne_zero_of_constantCoeff (by rw [map_pow, constantCoeff_eisenstein4, one_pow])
+
+omit [Γ.FiniteIndex] in
+theorem intSeriesC_PΔ_ne_zero (K : Type*) [Field K] : intSeriesC K PΔ ≠ 0 := by
+  intro h
+  have h1 := congrArg (fun z : LaurentSeries K => z.coeff 1) h
+  simp only [intSeriesC, HahnSeries.coeff_zero] at h1
+  have h2 : (HahnSeries.ofPowerSeries ℤ K
+      ((PowerSeries.X * dedekindEtaUnit).map (Int.castRingHom K))).coeff ((1 : ℕ) : ℤ) = 1 := by
+    rw [HahnSeries.ofPowerSeries_apply_coeff, PowerSeries.coeff_map,
+      show (1 : ℕ) = 0 + 1 from rfl, PowerSeries.coeff_succ_X_mul,
+      PowerSeries.coeff_zero_eq_constantCoeff_apply, constantCoeff_dedekindEtaUnit, map_one]
+  rw [show ((1 : ℕ) : ℤ) = 1 from rfl] at h2
+  rw [h2] at h1
+  exact one_ne_zero h1
+
+noncomputable def wq : LaurentSeries ℚ := intSeriesC ℚ PΔ / intSeriesC ℚ (eisenstein4 ^ 3)
+
+omit [Γ.FiniteIndex] in
+theorem wq_mem : wq ∈ qExpFunctionFieldC ℚ Γ :=
+  div_mem_qExpFunctionFieldC (D12 Γ) (A12 Γ) isIntegralQExp_D12 isIntegralQExp_A12
+    intSeriesC_E4_cube_ne_zero
+
+omit [Γ.FiniteIndex] in
+theorem jqModC_mul_delta (K : Type*) [Field K] :
+    jqModC K * intSeriesC K PΔ = intSeriesC K (eisenstein4 ^ 3) := by
+  rw [jqModC, intSeriesC, intSeriesC, jNum, mul_assoc, ← map_mul, ← map_mul,
+    show eisenstein4 ^ 3 * dedekindEtaUnitInv * (PowerSeries.X * dedekindEtaUnit) =
+      PowerSeries.X * eisenstein4 ^ 3 by
+        rw [mul_comm PowerSeries.X dedekindEtaUnit, ← mul_assoc, mul_assoc (eisenstein4 ^ 3),
+          mul_comm dedekindEtaUnitInv, dedekindEtaUnit_mul_inv, mul_one, mul_comm],
+    map_mul, PowerSeries.map_X, map_mul, HahnSeries.ofPowerSeries_X, ← mul_assoc,
+    HahnSeries.single_mul_single]
+  simp
+
+omit [Γ.FiniteIndex] in
+theorem wq_eq_inv : wq = (jqModC ℚ)⁻¹ := by
+  rw [wq, eq_comm, inv_eq_iff_eq_inv, inv_div, eq_div_iff (intSeriesC_PΔ_ne_zero ℚ),
+    jqModC_mul_delta]
+
+omit [Γ.FiniteIndex] in
+theorem wq_transcendental : Transcendental ℚ wq := by
+  intro halg
+  rw [wq_eq_inv] at halg
+  exact ModularCurve.transcendental_jqModC ℚ (IsAlgebraic.inv_iff.mp halg)
+
+omit [Γ.FiniteIndex] in
+theorem intSeriesC_add {K : Type*} [Field K] (p p' : PowerSeries ℤ) :
+    intSeriesC K (p + p') = intSeriesC K p + intSeriesC K p' := by
+  simp [intSeriesC]
+
+omit [Γ.FiniteIndex] in
+theorem intSeriesC_neg {K : Type*} [Field K] (p : PowerSeries ℤ) :
+    intSeriesC K (-p) = -intSeriesC K p := by
+  simp [intSeriesC]
+
+section Ratio
+variable (hT : ModularGroup.T ∈ Γ)
+include hT
+
+omit [Γ.FiniteIndex] in
+theorem hper :
+    (1 : ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)).strictPeriods := FIdxNorm.one_mem_strictPeriods hT
+
+omit [Γ.FiniteIndex] in
+theorem mul_mem_intFormRatiosC {a b : LaurentSeries ℚ} (ha : a ∈ intFormRatiosC ℚ Γ)
+    (hb : b ∈ intFormRatiosC ℚ Γ) : a * b ∈ intFormRatiosC ℚ Γ := by
+  obtain ⟨k₁, f₁, g₁, pf₁, pg₁, hf₁, hg₁, hg₁0, rfl⟩ := ha
+  obtain ⟨k₂, f₂, g₂, pf₂, pg₂, hf₂, hg₂, hg₂0, rfl⟩ := hb
+  refine ⟨k₁ + k₂, f₁.mul f₂, g₁.mul g₂, pf₁ * pf₂, pg₁ * pg₂, ?_, ?_, ?_, ?_⟩
+  · rw [IsIntegralQExp, map_mul, hf₁, hf₂, ModularForm.coe_mul]
+    exact (ModularForm.qExpansion_mul_coe one_pos (hper hT) f₁ f₂).symm
+  · rw [IsIntegralQExp, map_mul, hg₁, hg₂, ModularForm.coe_mul]
+    exact (ModularForm.qExpansion_mul_coe one_pos (hper hT) g₁ g₂).symm
+  · rw [intSeriesC_mul]; exact mul_ne_zero hg₁0 hg₂0
+  · rw [intSeriesC_mul, intSeriesC_mul, div_mul_div_comm]
+
+omit [Γ.FiniteIndex] in
+theorem add_mem_intFormRatiosC {a b : LaurentSeries ℚ} (ha : a ∈ intFormRatiosC ℚ Γ)
+    (hb : b ∈ intFormRatiosC ℚ Γ) : a + b ∈ intFormRatiosC ℚ Γ := by
+  obtain ⟨k₁, f₁, g₁, pf₁, pg₁, hf₁, hg₁, hg₁0, rfl⟩ := ha
+  obtain ⟨k₂, f₂, g₂, pf₂, pg₂, hf₂, hg₂, hg₂0, rfl⟩ := hb
+  refine ⟨k₁ + k₂, f₁.mul g₂ + (g₁.mul f₂), g₁.mul g₂, pf₁ * pg₂ + pg₁ * pf₂, pg₁ * pg₂, ?_, ?_, ?_,
+    ?_⟩
+  · rw [IsIntegralQExp, map_add, map_mul, map_mul, hf₁, hf₂, hg₁, hg₂, FunLike.coe_add,
+      ModularForm.qExpansion_add one_pos (hper hT), ModularForm.coe_mul, ModularForm.coe_mul,
+      ModularForm.qExpansion_mul_coe one_pos (hper hT), ModularForm.qExpansion_mul_coe one_pos (hper
+      hT)]
+  · rw [IsIntegralQExp, map_mul, hg₁, hg₂, ModularForm.coe_mul]
+    exact (ModularForm.qExpansion_mul_coe one_pos (hper hT) g₁ g₂).symm
+  · rw [intSeriesC_mul]; exact mul_ne_zero hg₁0 hg₂0
+  · rw [intSeriesC_add, intSeriesC_mul, intSeriesC_mul, intSeriesC_mul, div_add_div _ _ hg₁0 hg₂0]
+
+omit [Γ.FiniteIndex] in
+theorem neg_mem_intFormRatiosC {a : LaurentSeries ℚ} (ha : a ∈ intFormRatiosC ℚ Γ) :
+    -a ∈ intFormRatiosC ℚ Γ := by
+  obtain ⟨k, f, g, pf, pg, hf, hg, hg0, rfl⟩ := ha
+  refine ⟨k, -f, g, -pf, pg, ?_, hg, hg0, ?_⟩
+  · rw [IsIntegralQExp, map_neg, hf, FunLike.coe_neg]
+    exact (ModularForm.qExpansion_neg one_pos (hper hT) f).symm
+  · rw [intSeriesC_neg, neg_div]
+
+omit [Γ.FiniteIndex] hT in
+theorem inv_mem_intFormRatiosC {a : LaurentSeries ℚ} (ha : a ∈ intFormRatiosC ℚ Γ) :
+    a⁻¹ ∈ intFormRatiosC ℚ Γ := by
+  obtain ⟨k, f, g, pf, pg, hf, hg, hg0, rfl⟩ := ha
+  by_cases hf0 : intSeriesC ℚ pf = 0
+  · rw [hf0, zero_div, inv_zero, ← zero_div (intSeriesC ℚ pg), ← hf0]
+    exact ⟨k, f, g, pf, pg, hf, hg, hg0, rfl⟩
+  · refine ⟨k, g, f, pg, pf, hg, hf, hf0, ?_⟩
+    rw [inv_div]
+
+omit [Γ.FiniteIndex] in
+theorem algebraMap_mem_intFormRatiosC (c : ℚ) :
+    algebraMap ℚ (LaurentSeries ℚ) c ∈ intFormRatiosC ℚ Γ := by
+  have hden : ((c.den : ℤ) : ℚ) ≠ 0 := by exact_mod_cast c.den_nz
+  refine ⟨0, ModularForm.const (c.num : ℂ), ModularForm.const (c.den : ℂ),
+    PowerSeries.C (c.num : ℤ), PowerSeries.C (c.den : ℤ), ?_, ?_, ?_, ?_⟩
+  · rw [IsIntegralQExp, PowerSeries.map_C]
+    have : ((ModularForm.const (c.num : ℂ) : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 0) : ℍ → ℂ) =
+        (c.num : ℂ) • ((1 : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 0) : ℍ → ℂ) := by
+      funext z
+      rw [Pi.smul_apply, ModularForm.const_apply, ModularForm.one_coe_eq_one, Pi.one_apply,
+        smul_eq_mul,
+        mul_one]
+    rw [this, ModularForm.qExpansion_smul one_pos (hper hT), ModularForm.qExpansion_one,
+      PowerSeries.smul_eq_C_mul, mul_one, eq_intCast]
+  · rw [IsIntegralQExp, PowerSeries.map_C]
+    have : ((ModularForm.const (c.den : ℂ) : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 0) : ℍ → ℂ) =
+        (c.den : ℂ) • ((1 : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 0) : ℍ → ℂ) := by
+      funext z
+      rw [Pi.smul_apply, ModularForm.const_apply, ModularForm.one_coe_eq_one, Pi.one_apply,
+        smul_eq_mul,
+        mul_one]
+    rw [this, ModularForm.qExpansion_smul one_pos (hper hT), ModularForm.qExpansion_one,
+      PowerSeries.smul_eq_C_mul, mul_one, eq_intCast]
+    push_cast
+    rfl
+  · rw [intSeriesC, PowerSeries.map_C, HahnSeries.ofPowerSeries_C, eq_intCast]
+    exact (map_ne_zero_iff _ HahnSeries.C_injective).mpr hden
+  · rw [intSeriesC, intSeriesC, PowerSeries.map_C, PowerSeries.map_C, HahnSeries.ofPowerSeries_C,
+      HahnSeries.ofPowerSeries_C, LaurentSeries.algebraMap_apply, eq_intCast,
+      eq_intCast, eq_div_iff ((map_ne_zero_iff _ HahnSeries.C_injective).mpr hden), ← map_mul]
+    congr 1
+    push_cast
+    exact Rat.mul_den_eq_num c
+
+omit [Γ.FiniteIndex] in
+theorem mem_qExpFunctionFieldC_iff {y : LaurentSeries ℚ} :
+    y ∈ qExpFunctionFieldC ℚ Γ ↔ y ∈ intFormRatiosC ℚ Γ := by
+  let R : IntermediateField ℚ (LaurentSeries ℚ) :=
+    { carrier := intFormRatiosC ℚ Γ
+      mul_mem' := fun ha hb => mul_mem_intFormRatiosC hT ha hb
+      one_mem' := by simpa using algebraMap_mem_intFormRatiosC (Γ := Γ) hT 1
+      add_mem' := fun ha hb => add_mem_intFormRatiosC hT ha hb
+      zero_mem' := by simpa using algebraMap_mem_intFormRatiosC (Γ := Γ) hT 0
+      algebraMap_mem' := fun c => algebraMap_mem_intFormRatiosC hT c
+      inv_mem' := fun a ha => inv_mem_intFormRatiosC ha }
+  have hle : qExpFunctionFieldC ℚ Γ ≤ R := IntermediateField.adjoin_le_iff.mpr (fun _ h => h)
+  exact ⟨fun h => hle h, fun h => intFormRatiosC_subset ℚ Γ h⟩
+
+end Ratio
+
+section Relation
+
+variable {Γ' : Subgroup SL(2, ℤ)} [Γ'.FiniteIndex]
+variable (hT : ModularGroup.T ∈ Γ) (hΓ' : Γ ≤ Γ') (hneg : ∀ γ ∈ Γ', γ ∈ Γ ∨ -γ ∈ Γ)
+include hT hΓ' hneg
+
+local notation "μ" => Nat.card (FIdxNorm.Cos Γ')
+
+omit [Γ.FiniteIndex] [Γ'.FiniteIndex] hT hΓ' hneg in
+theorem coeffEmb_intSeriesC (p : PowerSeries ℤ) :
+    coeffEmb ℂ (intSeriesC ℚ p) = HahnSeries.ofPowerSeries ℤ ℂ (p.map (Int.castRingHom ℂ)) := by
+  ext n
+  rw [coeffEmb_coeff, intSeriesC, PowerSeries.coeff_coe, PowerSeries.coeff_coe]
+  split_ifs
+  · simp
+  · simp
+
+omit [Γ.FiniteIndex] [Γ'.FiniteIndex] hT hΓ' hneg in
+theorem coeffEmb_eq_map (z : LaurentSeries ℚ) :
+    coeffEmb ℂ z = HahnSeries.map z (algebraMap ℚ ℂ) := by
+  ext n; rw [coeffEmb_coeff]; rfl
+
+omit [Γ.FiniteIndex] [Γ'.FiniteIndex] hT hΓ' hneg in
+theorem sum_div_pow_eq {K : Type*} [Field K] {n : ℕ} (a : ℕ → K) (F G : K) (hG : G ≠ 0)
+    (h : ∑ i ∈ Finset.range (n + 1), a i * F ^ i * G ^ (n - i) = 0) :
+    ∑ i ∈ Finset.range (n + 1), a i * (F / G) ^ i = 0 := by
+  have hGn : G ^ n ≠ 0 := pow_ne_zero _ hG
+  have key : ∀ i ∈ Finset.range (n + 1), a i * F ^ i * G ^ (n - i) = (a i * (F / G) ^ i) * G ^ n :=
+    by
+    intro i hi
+    have hi' : i ≤ n := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)
+    rw [div_pow, mul_assoc, mul_assoc]
+    congr 1
+    rw [div_mul_eq_mul_div, eq_div_iff (pow_ne_zero _ hG), mul_assoc, ← _root_.pow_add,
+      Nat.sub_add_cancel hi']
+  rw [Finset.sum_congr rfl key, ← Finset.sum_mul] at h
+  exact (mul_eq_zero.mp h).resolve_right hGn
+
+omit [Γ.FiniteIndex] [Γ'.FiniteIndex] hT hΓ' hneg in
+theorem monomial_eq {K : Type*} [Field K] {m b : ℕ} (hb : b ≤ m) (Q4 QD : K) (h4 : Q4 ≠ 0) :
+    Q4 ^ (3 * (m - b)) * QD ^ b = Q4 ^ (3 * m) * (QD / Q4 ^ 3) ^ b := by
+  rw [show 3 * m = 3 * (m - b) + 3 * b by omega, _root_.pow_add, div_pow, ← pow_mul, mul_assoc]
+  congr 1
+  rw [mul_comm 3 b, mul_div_assoc', mul_comm (Q4 ^ (b * 3)), mul_div_assoc,
+    div_self (pow_ne_zero _ h4), mul_one]
+
+theorem exists_rat_relation {k : ℤ} (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    {pf pg : PowerSeries ℤ} (hf : IsIntegralQExp f pf) (hg : IsIntegralQExp g pg)
+    (hg0 : intSeriesC ℚ pg ≠ 0) :
+    ∃ (m : ℕ) (d : Fin (μ + 1) × Fin (m + 1) → ℚ),
+      (∃ ib, d ib ≠ 0) ∧
+      ∑ ib, d ib • (wq ^ (ib.2 : ℕ) * (intSeriesC ℚ pf / intSeriesC ℚ pg) ^ (ib.1 : ℕ)) = 0 := by
+  classical
+  have hgne : g ≠ 0 := by
+    intro h0
+    apply hg0
+    have : pg = 0 := by
+      apply PowerSeries.map_injective (Int.castRingHom ℂ) Int.cast_injective
+      rw [hg, h0, FunLike.coe_zero, qExpansion_zero, map_zero]
+    rw [this, intSeriesC_zero]
+  have hk : 0 ≤ k := by
+    by_contra hlt
+    exact hgne (ModularForm.isZero_of_neg_weight (not_le.mp hlt) g)
+  have hw : (11 : ℕ) * k + k = 12 * k := by ring
+  have heven : Even (12 * k) := ⟨6 * k, by ring⟩
+  let f₀ : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) (12 * k) := ((g.pow 11).mul f).mcast hw
+  let g₀ : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) (12 * k) := ((g.pow 11).mul g).mcast hw
+  let f' : ModularForm (Γ' : Subgroup (GL (Fin 2) ℝ)) (12 * k) := liftEven hΓ' hneg heven f₀
+  let g' : ModularForm (Γ' : Subgroup (GL (Fin 2) ℝ)) (12 * k) := liftEven hΓ' hneg heven g₀
+  have hqf' : qExpansion 1 (f' : ℍ → ℂ) = qExpansion 1 (g : ℍ → ℂ) ^ 11 * qExpansion 1 (f : ℍ → ℂ)
+    :=
+    by
+    simp only [f', f₀, coe_liftEven, ModularForm.qExpansion_mcast, ModularForm.qExpansion_mul
+      one_pos (hper hT),
+      ModularForm.qExpansion_pow one_pos (hper hT)]
+  have hqg' : qExpansion 1 (g' : ℍ → ℂ) = qExpansion 1 (g : ℍ → ℂ) ^ 11 * qExpansion 1 (g : ℍ → ℂ)
+    :=
+    by
+    simp only [g', g₀, coe_liftEven, ModularForm.qExpansion_mcast, ModularForm.qExpansion_mul
+      one_pos (hper hT),
+      ModularForm.qExpansion_pow one_pos (hper hT)]
+  have hqg : qExpansion 1 (g : ℍ → ℂ) ≠ 0 := by
+    rwa [Ne, ModularForm.qExpansion_eq_zero_iff one_pos (hper hT)]
+  have hg'ne : g' ≠ 0 := by
+    intro h0
+    have : qExpansion 1 (g' : ℍ → ℂ) = 0 := by rw [h0, FunLike.coe_zero, qExpansion_zero]
+    rw [hqg'] at this
+    exact (mul_ne_zero (pow_ne_zero _ hqg) hqg) this
+  have hT' : ModularGroup.T ∈ Γ' := hΓ' hT
+  have hrel := FIdxNorm.sum_qExpansion_coeffForm_mul_pow_eq_zero f' g' hT'
+  have htop := FIdxNorm.qExpansion_coeffForm_card_ne_zero f' g' hg'ne
+  set m : ℕ := k.toNat * μ with hm
+  have hkm : 12 * k * (μ : ℤ) = 12 * (m : ℤ) := by
+    rw [hm]; push_cast; rw [Int.toNat_of_nonneg hk]; ring
+  have hspan : ∀ i, qExpansion 1 (FIdxNorm.coeffForm f' g' i : ℍ → ℂ) ∈ FIdxLevelOne.monomialSpan m
+    :=
+    fun i => FIdxLevelOne.qExpansion_mem_monomialSpan m _ hkm _
+  choose c hc using fun i => (Submodule.mem_span_range_iff_exists_fun ℂ).mp (hspan i)
+  let Φ : PowerSeries ℂ →+* LaurentSeries ℂ := HahnSeries.ofPowerSeries ℤ ℂ
+  have hΦ : Function.Injective Φ := HahnSeries.ofPowerSeries_injective
+  set Q4 : LaurentSeries ℂ := Φ FIdxLevelOne.q4 with hQ4
+  set QD : LaurentSeries ℂ := Φ FIdxLevelOne.qΔ with hQD
+  set QF : LaurentSeries ℂ := Φ (qExpansion 1 (f : ℍ → ℂ)) with hQF
+  set QG : LaurentSeries ℂ := Φ (qExpansion 1 (g : ℍ → ℂ)) with hQG
+  set QE : ℕ → LaurentSeries ℂ := fun i => Φ (qExpansion 1 (FIdxNorm.coeffForm f' g' i : ℍ → ℂ))
+    with hQE
+  have hQG0 : QG ≠ 0 := fun h => hqg (hΦ (by rw [map_zero]; exact h))
+  have hQ40 : Q4 ≠ 0 := by
+    intro h
+    have : FIdxLevelOne.q4 = 0 := hΦ (by rw [map_zero]; exact h)
+    have h0 := congrArg (PowerSeries.coeff 0) this
+    rw [FIdxLevelOne.q4_coeff_zero, map_zero] at h0
+    exact one_ne_zero h0
+  have hrel' : ∑ i ∈ Finset.range (μ + 1), QE i * (QG ^ 11 * QF) ^ i * (QG ^ 11 * QG) ^ (μ - i) = 0
+    :=
+    by
+    have := congrArg Φ hrel
+    rw [map_sum, map_zero] at this
+    rw [← this]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    simp only [hQE, hQF, hQG, map_mul, map_pow, hqf', hqg']
+  have hdiv := sum_div_pow_eq (n := μ) QE (QG ^ 11 * QF) (QG ^ 11 * QG)
+    (mul_ne_zero (pow_ne_zero _ hQG0) hQG0) hrel'
+  have hratio : (QG ^ 11 * QF) / (QG ^ 11 * QG) = QF / QG :=
+    mul_div_mul_left _ _ (pow_ne_zero _ hQG0)
+  rw [hratio] at hdiv
+  set Wh : LaurentSeries ℂ := QD / Q4 ^ 3 with hWh
+  have hQEi : ∀ i, QE i = Q4 ^ (3 * m) * ∑ b : Fin (m + 1), HahnSeries.C (c i b) * Wh ^ (b : ℕ) :=
+    by
+    intro i
+    simp only [hQE]
+    rw [← hc i, map_sum, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun b _ => ?_
+    rw [PowerSeries.smul_eq_C_mul, map_mul, map_mul, map_pow, map_pow, monomial_eq
+      (Nat.lt_succ_iff.mp b.2) _ _ hQ40]
+    simp only [Φ, HahnSeries.ofPowerSeries_C]
+    ring
+  have hsum : ∑ ib : Fin (μ + 1) × Fin (m + 1),
+      c ib.1 ib.2 • (Wh ^ (ib.2 : ℕ) * (QF / QG) ^ (ib.1 : ℕ)) = 0 := by
+    have h1 : Q4 ^ (3 * m) * ∑ i : Fin (μ + 1),
+        (∑ b : Fin (m + 1), HahnSeries.C (c i b) * Wh ^ (b : ℕ)) * (QF / QG) ^ (i : ℕ) = 0 := by
+      rw [Finset.mul_sum, ← hdiv, Finset.sum_range]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [hQEi, mul_assoc]
+    have h2 := (mul_eq_zero.mp h1).resolve_left (pow_ne_zero _ hQ40)
+    rw [Fintype.sum_prod_type, ← h2]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [Finset.sum_mul]
+    refine Finset.sum_congr rfl fun b _ => ?_
+    rw [← HahnSeries.C_mul_eq_smul, mul_assoc]
+  have hnz : ∃ b, c μ b ≠ 0 := by
+    by_contra hall
+    push Not at hall
+    apply htop
+    rw [← hc μ]
+    exact Finset.sum_eq_zero fun b _ => by rw [hall b, zero_smul]
+  obtain ⟨b₀, hb₀⟩ := hnz
+  let v : Fin (μ + 1) × Fin (m + 1) → LaurentSeries ℚ :=
+    fun ib => wq ^ (ib.2 : ℕ) * (intSeriesC ℚ pf / intSeriesC ℚ pg) ^ (ib.1 : ℕ)
+  have hvmap : ∀ ib, HahnSeries.map (v ib) (algebraMap ℚ ℂ) = Wh ^ (ib.2 : ℕ) * (QF / QG) ^ (ib.1 :
+    ℕ) :=
+    by
+    intro ib
+    rw [← coeffEmb_eq_map, map_mul, map_pow, map_pow, wq, map_div₀, map_div₀,
+      coeffEmb_intSeriesC, coeffEmb_intSeriesC, coeffEmb_intSeriesC, coeffEmb_intSeriesC]
+    have h4 : eisenstein4.map (Int.castRingHom ℂ) = FIdxLevelOne.q4 := isIntegralQExp_E4
+    have hD : PΔ.map (Int.castRingHom ℂ) = FIdxLevelOne.qΔ := isIntegralQExp_Delta
+    have hf' : pf.map (Int.castRingHom ℂ) = qExpansion 1 (f : ℍ → ℂ) := hf
+    have hg' : pg.map (Int.castRingHom ℂ) = qExpansion 1 (g : ℍ → ℂ) := hg
+    simp only [map_pow, h4, hD, hf', hg']
+    rfl
+  have hdep : ¬ LinearIndependent ℂ (fun ib => HahnSeries.map (v ib) (algebraMap ℚ ℂ)) := by
+    rw [Fintype.not_linearIndependent_iff]
+    refine ⟨fun ib => c ib.1 ib.2, ?_, ⟨(Fin.last μ, b₀), by simpa using hb₀⟩⟩
+    simp_rw [hvmap]
+    exact hsum
+  have hdepQ : ¬ LinearIndependent ℚ v := fun h => hdep (FIdxAlg.linearIndependent_map h)
+  rw [Fintype.not_linearIndependent_iff] at hdepQ
+  obtain ⟨d, hd, ib₁, hib₁⟩ := hdepQ
+  exact ⟨m, d, ⟨ib₁, hib₁⟩, hd⟩
+
+end Relation
+
+section Bound
+
+variable {Γ' : Subgroup SL(2, ℤ)} [Γ'.FiniteIndex]
+variable (hT : ModularGroup.T ∈ Γ) (hΓ' : Γ ≤ Γ') (hneg : ∀ γ ∈ Γ', γ ∈ Γ ∨ -γ ∈ Γ)
+include hT hΓ' hneg
+
+omit [Γ.FiniteIndex] [Γ'.FiniteIndex] hT hΓ' hneg in
+theorem jqModC_mem : jqModC ℚ ∈ qExpFunctionFieldC ℚ Γ := by
+  have h : (wq)⁻¹ ∈ qExpFunctionFieldC ℚ Γ := inv_mem wq_mem
+  rwa [wq_eq_inv, inv_inv] at h
+
+theorem finrank_adjoin_wq_le :
+    Module.finrank
+        (IntermediateField.adjoin ℚ ({(⟨wq, wq_mem⟩ : qExpFunctionFieldC ℚ Γ)} : Set
+          (qExpFunctionFieldC ℚ Γ)))
+        (qExpFunctionFieldC ℚ Γ) ≤ Nat.card (FIdxNorm.Cos Γ') := by
+  classical
+  let F := qExpFunctionFieldC ℚ Γ
+  let X₀ : F := ⟨wq, wq_mem⟩
+  let φ : F →+* LaurentSeries ℚ := algebraMap F (LaurentSeries ℚ)
+  have hφQ : φ.comp (algebraMap ℚ F) = algebraMap ℚ (LaurentSeries ℚ) := Subsingleton.elim _ _
+  have hX₀ : Transcendental ℚ X₀ := by
+    rintro ⟨r, hr0, hr⟩
+    refine wq_transcendental ⟨r, hr0, ?_⟩
+    have := Polynomial.hom_eval₂ r (algebraMap ℚ F) φ X₀
+    rw [hφQ] at this
+    rw [Polynomial.aeval_def, show wq = φ X₀ from rfl, ← this, ← Polynomial.aeval_def, hr, map_zero]
+  let K₀ := IntermediateField.adjoin ℚ ({X₀} : Set F)
+  let Xk : K₀ := ⟨X₀, IntermediateField.mem_adjoin_simple_self ℚ X₀⟩
+  have hrat : ∀ e : ℚ, (((algebraMap ℚ K₀ e : K₀) : F) : LaurentSeries ℚ) = algebraMap ℚ
+    (LaurentSeries ℚ) e :=
+    by
+    intro e
+    have h := RingHom.congr_fun (Subsingleton.elim
+      ((φ.comp (algebraMap K₀ F)).comp (algebraMap ℚ K₀)) (algebraMap ℚ (LaurentSeries ℚ))) e
+    rw [← h]
+    rfl
+  have : PerfectField K₀ := PerfectField.ofCharZero
+  refine FIdxAlg.finrank_le_of_forall_aeval_eq_zero (Nat.card (FIdxNorm.Cos Γ')) ?_
+  intro Y
+  obtain ⟨k, f, g, pf, pg, hf, hg, hg0, hY⟩ := (mem_qExpFunctionFieldC_iff hT).mp Y.2
+  obtain ⟨m, d, ⟨ib₀, hib₀⟩, hd⟩ := exists_rat_relation hT hΓ' hneg f g hf hg hg0
+  let coef : Fin (Nat.card (FIdxNorm.Cos Γ') + 1) → K₀ :=
+    fun i => ∑ b : Fin (m + 1), algebraMap ℚ K₀ (d (i, b)) * Xk ^ (b : ℕ)
+  have hcoef : ∀ i, (((coef i : K₀) : F) : LaurentSeries ℚ) =
+      ∑ b : Fin (m + 1), algebraMap ℚ (LaurentSeries ℚ) (d (i, b)) * wq ^ (b : ℕ) := by
+    intro i
+    simp only [coef]
+    rw [IntermediateField.coe_sum, IntermediateField.coe_sum]
+    refine Finset.sum_congr rfl fun b _ => ?_
+    rw [MulMemClass.coe_mul, MulMemClass.coe_mul, SubmonoidClass.coe_pow, SubmonoidClass.coe_pow,
+      hrat]
+  let p : K₀[X] := ∑ i : Fin (Nat.card (FIdxNorm.Cos Γ') + 1), Polynomial.monomial (i : ℕ) (coef i)
+  have hcoeff : ∀ i : Fin (Nat.card (FIdxNorm.Cos Γ') + 1), p.coeff i = coef i := by
+    intro i
+    simp only [p, finsetSum_coeff, coeff_monomial]
+    rw [Finset.sum_eq_single_of_mem i (Finset.mem_univ i)]
+    · simp
+    · intro j _ hji
+      rw [ite_eq_right]
+      exact fun h => hji (Fin.ext h)
+  refine ⟨p, ?_, ?_, ?_⟩
+  · intro hp
+    have h1 : coef ib₀.1 = 0 := by rw [← hcoeff, hp, Polynomial.coeff_zero]
+    apply wq_transcendental
+    let r : ℚ[X] := ∑ b : Fin (m + 1), Polynomial.monomial (b : ℕ) (d (ib₀.1, b))
+    have hr0 : r ≠ 0 := by
+      intro hr
+      have := congrArg (fun q : ℚ[X] => q.coeff ib₀.2) hr
+      simp only [r, finsetSum_coeff, coeff_monomial, Polynomial.coeff_zero] at this
+      rw [Finset.sum_eq_single_of_mem ib₀.2 (Finset.mem_univ _)] at this
+      · simp only [↓reduceIte] at this; exact hib₀ this
+      · intro j _ hji; rw [ite_eq_right]; exact fun h => hji (Fin.ext h)
+    refine ⟨r, hr0, ?_⟩
+    have h2 : (((coef ib₀.1 : K₀) : F) : LaurentSeries ℚ) = 0 := by rw [h1]; rfl
+    rw [hcoef] at h2
+    rw [← h2]
+    simp only [r, map_sum, Polynomial.aeval_monomial]
+  · exact natDegree_sum_le_of_forall_le _ _ fun i _ =>
+      (natDegree_monomial_le _).trans (Nat.lt_succ_iff.mp i.2)
+  · apply Subtype.val_injective
+    rw [ZeroMemClass.coe_zero]
+    have hd' : ∑ ib : Fin (Nat.card (FIdxNorm.Cos Γ') + 1) × Fin (m + 1),
+        algebraMap ℚ (LaurentSeries ℚ) (d ib) *
+          (wq ^ (ib.2 : ℕ) * (intSeriesC ℚ pf / intSeriesC ℚ pg) ^ (ib.1 : ℕ)) = 0 := by
+      rw [← hd]
+      refine Finset.sum_congr rfl fun ib _ => ?_
+      rw [← HahnSeries.C_mul_eq_smul, HahnSeries.C_eq_algebraMap]
+      congr 1
+      exact RingHom.congr_fun (Subsingleton.elim _ _) _
+    rw [← hd']
+    simp only [p, map_sum, Polynomial.aeval_monomial]
+    rw [IntermediateField.coe_sum, Fintype.sum_prod_type]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [MulMemClass.coe_mul, SubmonoidClass.coe_pow, ← hY, IntermediateField.algebraMap_apply,
+      hcoef,
+      Finset.sum_mul]
+    refine Finset.sum_congr rfl fun b _ => ?_
+    ring
+
+end Bound
+end FIdxRat
+
+namespace FIdxBC
+
+p2m_open "ModularCurve~IsCusp"
+open scoped MatrixGroups
+
+variable (L : Type*) [Field L] [Algebra ℚ L]
+
+theorem coeffEmb_eq_map (z : LaurentSeries ℚ) :
+    coeffEmb L z = HahnSeries.map z (algebraMap ℚ L) := by
+  ext n; rw [coeffEmb_coeff]; rfl
+
+theorem coeffEmb_jqModC : coeffEmb L (jqModC ℚ) = jqModC L := by
+  rw [coeffEmb_eq_map, map_jqModC]
+
+theorem adjoin_wq_eq :
+    IntermediateField.adjoin ℚ ({FIdxRat.wq} : Set (LaurentSeries ℚ)) =
+      IntermediateField.adjoin ℚ ({jqModC ℚ} : Set (LaurentSeries ℚ)) := by
+  rw [FIdxRat.wq_eq_inv]
+  apply le_antisymm
+  · exact IntermediateField.adjoin_le_iff.mpr (Set.singleton_subset_iff.mpr
+      (inv_mem (IntermediateField.mem_adjoin_simple_self ℚ _)))
+  · refine IntermediateField.adjoin_le_iff.mpr (Set.singleton_subset_iff.mpr ?_)
+    have := inv_mem (IntermediateField.mem_adjoin_simple_self ℚ (jqModC ℚ)⁻¹)
+    rwa [inv_inv] at this
+
+theorem finrank_le (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    (Γ' : Subgroup SL(2, ℤ)) (hΓ' : Γ ≤ Γ') (hneg : ∀ γ ∈ Γ', γ ∈ Γ ∨ -γ ∈ Γ)
+    (y : laurentBaseChange L (qExpFunctionFieldC ℚ Γ))
+    (hy : (y : LaurentSeries L) = jqModC L) :
+    Module.finrank
+        (IntermediateField.adjoin L ({y} : Set (laurentBaseChange L (qExpFunctionFieldC ℚ Γ))))
+        (laurentBaseChange L (qExpFunctionFieldC ℚ Γ)) ≤ Γ'.index := by
+  have : Γ'.FiniteIndex := Subgroup.finiteIndex_of_le hΓ'
+  have hQ := FIdxRat.finrank_adjoin_wq_le (Γ := Γ) hT hΓ' hneg
+  rw [FIdxNorm.card_cos_eq_index] at hQ
+  have hQ' : IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({FIdxRat.wq} : Set
+    (LaurentSeries ℚ)))
+      (qExpFunctionFieldC ℚ Γ) ≤ Γ'.index := by
+    have h := FIdxAlg.finrank_adjoin_simple_eq_relfinrank (qExpFunctionFieldC ℚ Γ)
+      (⟨FIdxRat.wq, FIdxRat.wq_mem⟩ : qExpFunctionFieldC ℚ Γ)
+    exact h.symm.trans_le hQ
+  rw [adjoin_wq_eq] at hQ'
+  have hbc := ModularCurve.relfinrank_laurentBaseChange L (qExpFunctionFieldC ℚ Γ) (jqModC ℚ)
+    FIdxRat.jqModC_mem (ModularCurve.transcendental_jqModC ℚ)
+  rw [coeffEmb_jqModC] at hbc
+  have h2 :=
+    FIdxAlg.finrank_adjoin_simple_eq_relfinrank (laurentBaseChange L (qExpFunctionFieldC ℚ Γ)) y
+  rw [hy, hbc] at h2
+  exact h2.trans_le hQ'
+
+end FIdxBC
+
+theorem solution
+    (L : Type*) [Field L] [Algebra ℚ L]
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hT : ModularGroup.T ∈ Γ)
+    (Γ' : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) (hΓ' : Γ ≤ Γ')
+    (hneg : ∀ γ ∈ Γ', γ ∈ Γ ∨ -γ ∈ Γ)
+    (y : ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ))
+    (hy : (y : LaurentSeries L) = ModularCurve.jqModC L) :
+    Module.finrank
+        (IntermediateField.adjoin L
+          ({y} : Set (ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ))))
+        (ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ)) ≤ Γ'.index :=
+  FIdxBC.finrank_le L Γ hT Γ' hΓ' hneg y hy
+
+end S_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_le_index
+end P2MW
+export P2MW.S_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_le_index
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_le_index
+    (L : Type*) [Field L] [Algebra ℚ L]
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hT : ModularGroup.T ∈ Γ)
+    (Γ' : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) (hΓ' : Γ ≤ Γ')
+    (hneg : ∀ γ ∈ Γ', γ ∈ Γ ∨ -γ ∈ Γ)
+    (y : ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ))
+    (hy : (y : LaurentSeries L) = ModularCurve.jqModC L) :
+    Module.finrank
+        (IntermediateField.adjoin L
+          ({y} : Set (ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ))))
+        (ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ)) ≤ Γ'.index :=
+  solution L Γ hT Γ' hΓ' hneg y hy
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqModC_modularFunctionFieldFullC_eq_dedekindPsi.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqModC_modularFunctionFieldFullC_eq_dedekindPsi.lean
new file mode 100644
index 0000000000..1cac1de3e0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqModC_modularFunctionFieldFullC_eq_dedekindPsi.lean
@@ -0,0 +1,317 @@
+/-
+Based on Prove2Me node ModularCurve.finrank_adjoin_jqModC_modularFunctionFieldFullC_eq_dedekindPsi
+(6a282126-81a4-505f-be2c-02fc1516c73b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ffa4c8f1-0aa0-5c2a-90d8-8332a484e2c9
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0ModL
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import Mathlib.FieldTheory.Relrank
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_mul_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_StarBank_starBank
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqNModC_eq_dedekindPsi_of_socket
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqNModC_prime_not_mem_adjoin_of_charZero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_modularPolynomialData
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree ψ(N) of the level-N modular function field over K(j)
+
+Theorem statement: `ModularCurve.finrank_adjoin_jqModC_modularFunctionFieldFullC_eq_dedekindPsi`
+(`6a282126-81a4-505f-be2c-02fc1516c73b`), by Claude, 2026-09-05.
+
+Proof: submission `ffa4c8f1-0aa0-5c2a-90d8-8332a484e2c9`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and $N\ge 1$ a natural number whose image in $K$ is nonzero. Inside the field of
+formal Laurent series $K((q))$ consider the element `jqModC K`, namely $q^{-1}$ times the
+coefficientwise image in $K$ of the integral power series `jNum` $=E_4^3\cdot$ `dedekindEtaUnitInv`;
+this is the $q$-expansion of the modular invariant $j$ read in $K$. Let `modularFunctionFieldFullC K
+N` be the intermediate field of $K((q))/K$ generated over $K$ by the set `divisorExpansionsC K N` of
+all substitutions $q\mapsto q^{d}$ (written `qExpand K d`) applied to `jqModC K`, as $d$ runs over
+the nonzero divisors of $N$; the case $d=1$ shows `jqModC K` itself lies in this field. The
+assertion is that the $K$-subfield of `modularFunctionFieldFullC K N` generated by this single
+element `jqModC K` has the whole of `modularFunctionFieldFullC K N` as an extension of finite rank
+exactly `dedekindPsi N` $=\sum_{d\mid N,\ d\ \text{squarefree}} N/d = N\prod_{p\mid N}(1+1/p)$.
+Since this value is positive, the extension is in particular finite.
+
+This is the statement that the level-$N$ modular function field over a field $K$ in which $N$ is
+invertible has degree $\psi(N)=[\mathrm{SL}_2(\mathbb{Z}):\pm\Gamma_0(N)]$ over $K(j)$, the
+positive-characteristic case being Igusa's theorem on the good reduction of the modular
+correspondence. It underlies the construction and study of models of $X_0(N)$ over $K$ and of their
+function fields, and is invoked throughout the treatment of mod $p$ modular forms and of fibres of
+these models.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finrank_adjoin_jqModC_modularFunctionFieldFullC_eq_dedekindPsi.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_finrank_adjoin_jqModC_modularFunctionFieldFullC_eq_dedekindPsi
+
+p2m_open "ModularCurve~dedekindPsi_prime IntermediateField Polynomial Module"
+
+namespace W7E2_IGUSA_H3
+
+theorem mem_adjoin_of_degree_count {F L : Type*} [Field F] [Field L] [Algebra F L] (a b : L)
+    {m n s : ℕ} (ha : finrank F F⟮a⟯ = m) (hb : finrank F F⟮b⟯ = n) (hm : 0 < m)
+    (hint : IsIntegral F⟮a⟯ b) (hs : (minpoly F⟮a⟯ b).natDegree ≤ s) (hlt : m * s < 2 * n) :
+    a ∈ F⟮b⟯ := by
+  have htpos : 0 < finrank F⟮a⟯ F⟮a⟯⟮b⟯ := by
+    rw [adjoin.finrank hint]; exact minpoly.natDegree_pos hint
+  have ht : finrank F⟮a⟯ F⟮a⟯⟮b⟯ ≤ s := by rw [adjoin.finrank hint]; exact hs
+  have htower : finrank F F⟮a, b⟯ = m * finrank F⟮a⟯ F⟮a⟯⟮b⟯ := by
+    rw [← ha, ← adjoin_simple_adjoin_simple]
+    exact (Module.finrank_mul_finrank F F⟮a⟯ F⟮a⟯⟮b⟯).symm
+  have hle : F⟮b⟯ ≤ F⟮a, b⟯ := adjoin.mono _ _ _ (Set.subset_insert _ _)
+  have hdvd : n ∣ m * finrank F⟮a⟯ F⟮a⟯⟮b⟯ := by
+    rw [← hb, ← htower]; exact finrank_dvd_of_le_right hle
+  have heq : m * finrank F⟮a⟯ F⟮a⟯⟮b⟯ = n := by
+    obtain ⟨c, hc⟩ := hdvd
+    have hc0 : c ≠ 0 := by
+      rintro rfl
+      rw [mul_zero] at hc
+      exact (Nat.mul_pos hm htpos).ne' hc
+    have hc1 : c < 2 := by
+      by_contra hc2
+      have h1 : n * 2 ≤ n * c := Nat.mul_le_mul_left n (not_lt.mp hc2)
+      have h2 : m * finrank F⟮a⟯ F⟮a⟯⟮b⟯ ≤ m * s := Nat.mul_le_mul_left m ht
+      have h3 : n * 2 ≤ m * s := h1.trans (hc ▸ h2)
+      omega
+    obtain rfl : c = 1 := by omega
+    rw [hc, mul_one]
+  have : FiniteDimensional F F⟮a, b⟯ :=
+    Module.finite_of_finrank_pos (by rw [htower]; exact Nat.mul_pos hm htpos)
+  have hfin : finrank F F⟮b⟯ = finrank F F⟮a, b⟯ := by rw [hb, htower, heq]
+  rw [eq_of_le_of_finrank_eq hle hfin]
+  exact subset_adjoin _ _ (Set.mem_insert _ _)
+
+variable (K : Type*) [Field K]
+
+local notation "E𝕛" => IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))
+
+theorem jq_congr {a b : ℕ} [NeZero a] [NeZero b] (h : a = b) : jqNModC K a = jqNModC K b := by
+  subst h; rfl
+
+theorem socket (p : ℕ) [Fact p.Prime] (hpK : (p : K) ≠ 0) : jqNModC K p ∉ E𝕛 := by
+  rcases CharP.exists' K with hK | ⟨ℓ, hℓ, hKℓ⟩
+  · exact jqNModC_prime_not_mem_adjoin_of_charZero p
+  · have := hℓ
+    refine StarBank.starBank (ℓ := ℓ) ?_
+    rintro rfl
+    exact hpK (CharP.cast_eq_zero K p)
+
+theorem socket_of_dvd (N : ℕ) (hN : (N : K) ≠ 0) (p : ℕ) [Fact p.Prime] (hp : p ∣ N) :
+    jqNModC K p ∉ E𝕛 := by
+  refine socket K p ?_
+  intro hpK
+  obtain ⟨m, rfl⟩ := hp
+  exact hN (by rw [Nat.cast_mul, hpK, zero_mul])
+
+theorem finrank_adjoin_eq (N : ℕ) (hN : (N : K) ≠ 0) (d : ℕ) [NeZero d] (hd : d ∣ N) :
+    finrank E𝕛 (adjoin E𝕛 ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d :=
+  finrank_adjoin_jqNModC_eq_dedekindPsi_of_socket d
+    (fun p _ hp => socket_of_dvd K N hN p (hp.trans hd))
+
+theorem dedekindPsi_prime (p : ℕ) [hp : Fact p.Prime] : dedekindPsi p = p + 1 := by
+  have h := hp.out
+  rw [dedekindPsi, h.divisors, Finset.filter_eq_self.mpr, Finset.sum_pair h.one_lt.ne, Nat.div_one,
+    Nat.div_self h.pos]
+  intro d hd
+  simp only [Finset.mem_insert, Finset.mem_singleton] at hd
+  rcases hd with rfl | rfl
+  exacts [squarefree_one, h.prime.squarefree]
+
+theorem dedekindPsi_pos (d : ℕ) (hd : d ≠ 0) : 0 < dedekindPsi d := by
+  unfold dedekindPsi
+  have h1 : (1 : ℕ) ∈ d.divisors.filter Squarefree :=
+    Finset.mem_filter.mpr ⟨Nat.one_mem_divisors.mpr hd, squarefree_one⟩
+  calc 0 < d / 1 := by rw [Nat.div_one]; exact Nat.pos_of_ne_zero hd
+    _ ≤ ∑ e ∈ d.divisors with Squarefree e, d / e :=
+        Finset.single_le_sum (f := fun e => d / e) (fun _ _ => Nat.zero_le _) h1
+
+theorem mul_dedekindPsi_le (p d : ℕ) (hp : p ≠ 0) (hd : d ≠ 0) :
+    p * dedekindPsi d ≤ dedekindPsi (d * p) := by
+  unfold dedekindPsi
+  calc p * ∑ e ∈ d.divisors with Squarefree e, d / e
+      = ∑ e ∈ d.divisors with Squarefree e, d * p / e := by
+        rw [Finset.mul_sum]
+        refine Finset.sum_congr rfl fun e he => ?_
+        rw [Finset.mem_filter] at he
+        rw [mul_comm d p, Nat.mul_div_assoc p (Nat.dvd_of_mem_divisors he.1)]
+    _ ≤ ∑ e ∈ (d * p).divisors with Squarefree e, d * p / e :=
+        Finset.sum_le_sum_of_subset (Finset.filter_subset_filter _
+          (Nat.divisors_subset_of_dvd (mul_ne_zero hd hp) (dvd_mul_right d p)))
+
+theorem isIntegral_and_natDegree_le {F : Type*} [Field F] [Algebra F (LaurentSeries K)]
+    (d p : ℕ) [NeZero d] [NeZero p] (data : ModularPolynomialData p) (a : F)
+    (ha : algebraMap F (LaurentSeries K) a = jqNModC K d) :
+    IsIntegral F (jqNModC K (d * p))
+      ∧ (minpoly F (jqNModC K (d * p))).natDegree ≤ dedekindPsi p := by
+  have hmonic : (data.Φ.map (aeval (R := ℤ) a).toRingHom).Monic := data.monic.map _
+  have hroot : (data.Φ.map (aeval (R := ℤ) a).toRingHom).eval₂ (algebraMap F (LaurentSeries K))
+      (jqNModC K (d * p)) = 0 := by
+    rw [eval₂_map]
+    have hcomp : (algebraMap F (LaurentSeries K)).comp (aeval (R := ℤ) a).toRingHom
+        = (aeval (R := ℤ) (jqNModC K d)).toRingHom := by
+      refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+      simp [ha]
+    rw [hcomp]
+    exact data.eval_jqNModC_mul_eq_zero K d
+  have hint : IsIntegral F (jqNModC K (d * p)) := ⟨_, hmonic, hroot⟩
+  refine ⟨hint, ?_⟩
+  have hdvd : minpoly F (jqNModC K (d * p)) ∣ data.Φ.map (aeval (R := ℤ) a).toRingHom :=
+    minpoly.dvd F _ (by rwa [aeval_def])
+  calc (minpoly F (jqNModC K (d * p))).natDegree
+        ≤ (data.Φ.map (aeval (R := ℤ) a).toRingHom).natDegree :=
+        natDegree_le_of_dvd hdvd hmonic.ne_zero
+    _ = dedekindPsi p := by rw [data.monic.natDegree_map, data.natDegree_eq]
+
+theorem mem_adjoin_mul_prime (d p : ℕ) [NeZero d] [hp : Fact p.Prime]
+    (hd : finrank E𝕛 (adjoin E𝕛 ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d)
+    (hdp : finrank E𝕛 (adjoin E𝕛 ({jqNModC K (d * p)} : Set (LaurentSeries K)))
+      = dedekindPsi (d * p)) :
+    jqNModC K d ∈ adjoin E𝕛 ({jqNModC K (d * p)} : Set (LaurentSeries K)) := by
+  obtain ⟨data⟩ := nonempty_modularPolynomialData p
+  obtain ⟨hint, hdegle⟩ := isIntegral_and_natDegree_le K
+    (F := adjoin E𝕛 ({jqNModC K d} : Set (LaurentSeries K))) d p data
+    ⟨jqNModC K d, mem_adjoin_simple_self _ _⟩ rfl
+  have hpsi : 0 < dedekindPsi d := dedekindPsi_pos d (NeZero.ne d)
+  refine mem_adjoin_of_degree_count _ _ hd hdp hpsi hint hdegle ?_
+  rw [dedekindPsi_prime p]
+  have hppsi := mul_dedekindPsi_le p d hp.out.ne_zero (NeZero.ne d)
+  have h2 : 2 * dedekindPsi d ≤ p * dedekindPsi d := Nat.mul_le_mul_right _ hp.out.two_le
+  nlinarith [hppsi, h2, hpsi]
+
+theorem mem_adjoin_of_mul_dvd (N : ℕ) (hN : (N : K) ≠ 0) :
+    ∀ (k d : ℕ) [NeZero d] [NeZero k], d * k ∣ N →
+      jqNModC K d ∈ adjoin E𝕛 ({jqNModC K (d * k)} : Set (LaurentSeries K)) := by
+  intro k
+  induction k using Nat.strong_induction_on with
+  | _ k ih =>
+    intro d _ hk hdvd
+    by_cases h1 : k = 1
+    · subst h1
+      rw [jq_congr K (mul_one d)]
+      exact mem_adjoin_simple_self _ _
+    · obtain ⟨p, hp, k', rfl⟩ := Nat.exists_prime_and_dvd h1
+      have : Fact p.Prime := ⟨hp⟩
+      have hk' : k' ≠ 0 := by
+        rintro rfl
+        exact hk.out (mul_zero p)
+      have : NeZero k' := ⟨hk'⟩
+      have hlt : k' < p * k' := lt_mul_of_one_lt_left (Nat.pos_of_ne_zero hk') hp.one_lt
+      have hdpN : d * p ∣ N := (Dvd.intro k' (by ring)).trans hdvd
+      have hstep : jqNModC K d ∈ adjoin E𝕛 ({jqNModC K (d * p)} : Set (LaurentSeries K)) :=
+        mem_adjoin_mul_prime K d p (finrank_adjoin_eq K N hN d ((dvd_mul_right d _).trans hdvd))
+          (finrank_adjoin_eq K N hN (d * p) hdpN)
+      have hup : jqNModC K (d * p)
+          ∈ adjoin E𝕛 ({jqNModC K (d * p * k')} : Set (LaurentSeries K)) :=
+        ih k' hlt (d * p) (by rwa [mul_assoc])
+      rw [jq_congr K (mul_assoc d p k').symm]
+      exact adjoin_simple_le_iff.mpr hup hstep
+
+theorem restrictScalars_adjoin_eq_full (N : ℕ) [NeZero N] (hN : (N : K) ≠ 0) :
+    (adjoin E𝕛 ({jqNModC K N} : Set (LaurentSeries K))).restrictScalars K
+      = modularFunctionFieldFullC K N := by
+  apply le_antisymm
+  · have h : (adjoin E𝕛 ({jqNModC K N} : Set (LaurentSeries K))).restrictScalars K
+        = adjoin K ({jqModC K} ∪ {jqNModC K N}) := adjoin_adjoin_left K _ _
+    rw [h, adjoin_le_iff]
+    rintro x (rfl | rfl)
+    · exact jqModC_mem_full K N
+    · exact modularFunctionFieldC_le_full K N (jqNModC_mem K N)
+  · rw [modularFunctionFieldFullC, adjoin_le_iff]
+    rintro x ⟨d, _, ⟨k, hk⟩, rfl⟩
+    have : NeZero k := ⟨by rintro rfl; exact NeZero.ne N (by rw [hk, mul_zero])⟩
+    change jqNModC K d ∈ adjoin E𝕛 ({jqNModC K N} : Set (LaurentSeries K))
+    rw [jq_congr K hk]
+    exact mem_adjoin_of_mul_dvd K N hN k d (hk ▸ dvd_refl N)
+
+theorem adjoin_jqModC_le_full (N : ℕ) [NeZero N] : E𝕛 ≤ modularFunctionFieldFullC K N := by
+  rw [adjoin_le_iff, Set.singleton_subset_iff]
+  exact jqModC_mem_full K N
+
+theorem extendScalars_eq (N : ℕ) [NeZero N] (hN : (N : K) ≠ 0) :
+    extendScalars (adjoin_jqModC_le_full K N)
+      = adjoin E𝕛 ({jqNModC K N} : Set (LaurentSeries K)) := by
+  apply restrictScalars_injective K
+  exact (extendScalars_restrictScalars _).trans (restrictScalars_adjoin_eq_full K N hN).symm
+
+theorem finrank_rel_eq (N : ℕ) [NeZero N] (hN : (N : K) ≠ 0) :
+    finrank
+        (IntermediateField.adjoin K
+          ({⟨jqModC K, jqModC_mem_full K N⟩} : Set (modularFunctionFieldFullC K N)))
+        (modularFunctionFieldFullC K N)
+      = finrank E𝕛 (adjoin E𝕛 ({jqNModC K N} : Set (LaurentSeries K))) := by
+  let F : IntermediateField K (LaurentSeries K) := modularFunctionFieldFullC K N
+  let B : IntermediateField K F :=
+    IntermediateField.adjoin K ({⟨jqModC K, jqModC_mem_full K N⟩} : Set F)
+  have hB : lift B = E𝕛 := (lift_adjoin K F _).trans (by rw [Set.image_singleton])
+  have hT : lift (⊤ : IntermediateField K F) = F := lift_top K F
+  have h1 : relfinrank (lift B) (lift (⊤ : IntermediateField K F)) = relfinrank B ⊤ :=
+    relfinrank_map_map B ⊤ F.val
+  have h2 : relfinrank B (⊤ : IntermediateField K F) = finrank B F := relfinrank_top_right B
+  have h3 : relfinrank (lift B) (lift (⊤ : IntermediateField K F)) = relfinrank E𝕛 F := by
+    rw [hB, hT]
+  have h4 : relfinrank E𝕛 F = finrank E𝕛 (extendScalars (adjoin_jqModC_le_full K N)) :=
+    relfinrank_eq_finrank_of_le _
+  have h5 : finrank E𝕛 (extendScalars (adjoin_jqModC_le_full K N))
+      = finrank E𝕛 (adjoin E𝕛 ({jqNModC K N} : Set (LaurentSeries K))) :=
+    congrArg (fun M : IntermediateField E𝕛 (LaurentSeries K) => finrank E𝕛 M)
+      (extendScalars_eq K N hN)
+  calc finrank B F = relfinrank B ⊤ := h2.symm
+    _ = relfinrank (lift B) (lift (⊤ : IntermediateField K F)) := h1.symm
+    _ = relfinrank E𝕛 F := h3
+    _ = finrank E𝕛 (extendScalars (adjoin_jqModC_le_full K N)) := h4
+    _ = _ := h5
+
+end W7E2_IGUSA_H3
+
+open W7E2_IGUSA_H3 in
+theorem solution
+    (K : Type*) [Field K] (N : ℕ) [NeZero N] (hN : (N : K) ≠ 0) :
+    Module.finrank
+        (IntermediateField.adjoin K
+          ({⟨jqModC K, jqModC_mem_full K N⟩} : Set (modularFunctionFieldFullC K N)))
+        (modularFunctionFieldFullC K N) = dedekindPsi N :=
+  (finrank_rel_eq K N hN).trans (finrank_adjoin_eq K N hN N (dvd_refl N))
+
+end S_ModularCurve_finrank_adjoin_jqModC_modularFunctionFieldFullC_eq_dedekindPsi
+end P2MW
+export P2MW.S_ModularCurve_finrank_adjoin_jqModC_modularFunctionFieldFullC_eq_dedekindPsi (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.finrank_adjoin_jqModC_modularFunctionFieldFullC_eq_dedekindPsi
+    (K : Type*) [Field K] (N : ℕ) [NeZero N] (hN : (N : K) ≠ 0) :
+    Module.finrank
+        (IntermediateField.adjoin K
+          ({⟨jqModC K, jqModC_mem_full K N⟩} : Set (modularFunctionFieldFullC K N)))
+        (modularFunctionFieldFullC K N) = dedekindPsi N :=
+  solution K N hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqModC_qExpFunctionFieldC_le_index_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqModC_qExpFunctionFieldC_le_index_of_isAlgClosed.lean
new file mode 100644
index 0000000000..6615a0ea1e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqModC_qExpFunctionFieldC_le_index_of_isAlgClosed.lean
@@ -0,0 +1,289 @@
+/-
+Based on Prove2Me node ModularCurve.finrank_adjoin_jqModC_qExpFunctionFieldC_le_index_of_isAlgClosed
+(e74ce629-34ea-5eff-a050-b72ab8f2cd60) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission bdba62f6-5896-59d3-8807-49fbd46a4f0d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Algebra.Algebra.ZMod
+import Mathlib.RingTheory.Flat.TorsionFree
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_ReductionMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_JOneES_exists_transcendental_finiteDimensional_laurentBaseChange
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_le_index
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_qExpFunctionFieldC_le_of_valuationSubring
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_mem_intFormRatiosC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ValuationSubring_exists_liesOverPrime_algebraicClosure_rat
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Deuring's inequality for the q-expansion function field over K(jmath̄)
+
+Theorem statement: `ModularCurve.finrank_adjoin_jqModC_qExpFunctionFieldC_le_index_of_isAlgClosed`
+(`e74ce629-34ea-5eff-a050-b72ab8f2cd60`), by Claude, 2026-09-05.
+
+Proof: submission `bdba62f6-5896-59d3-8807-49fbd46a4f0d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field, let $\Gamma \le \mathrm{SL}_2(\mathbb{Z})$ be a subgroup
+of finite index containing the translation matrix $T$, and let $\Gamma'$ be a subgroup with $\Gamma
+\le \Gamma'$ such that every $\gamma \in \Gamma'$ satisfies $\gamma \in \Gamma$ or $-\gamma \in
+\Gamma$. Write $F =$ [`ModularCurve.qExpFunctionFieldC K Γ`](def/ModularCurve_X1.html#L101) for the
+intermediate field of the field of Laurent series $K((q))$ generated over $K$ by the set of
+quotients $\overline{p_f}/\overline{p_g}$, where for some weight $k$ there are modular forms $f, g$
+of weight $k$ for the image of $\Gamma$ in $\mathrm{GL}_2(\mathbb{R})$ and power series $p_f, p_g$
+over $\mathbb{Z}$ that are integral $q$-expansions of $f$ and of $g$ (in the sense of the predicate
+`IsIntegralQExp`), the coefficientwise reduction $\overline{p_g}$ into $K$ being nonzero; here
+$\overline{p}$ denotes [`ModularCurve.intSeriesC K p`](def/ModularCurve_X1.html#L69). Let $x \in F$
+be an element whose underlying Laurent series is [`ModularCurve.jqModC
+K`](def/ModularCurve_JqCoeff.html#L15), that is $q^{-1}$ times the reduction into $K$ of the
+integral power series $E_4^3 \cdot \eta^{-24}$-numerator `jNum` of the $j$-invariant. Then $F$ is a
+finite extension of the subfield $K(x)$ generated over $K$ by $x$, and $[F : K(x)] \le
+[\mathrm{SL}_2(\mathbb{Z}) : \Gamma']$.
+
+This is Deuring's reduction inequality for the $q$-expansion function field of level $\Gamma$: over
+an arbitrary algebraically closed constant field the degree over $K(\bar\jmath)$ is bounded by the
+index of a subgroup squeezed between $\Gamma$ and $\pm\Gamma$, the classical equality
+$[\,\overline{\mathbb{Q}}(j,\dots) : \overline{\mathbb{Q}}(j)\,] = [\mathrm{PSL}_2(\mathbb{Z}) :
+\bar\Gamma]$ in characteristic $0$ specialising only to an inequality after reduction. It feeds the
+exact degree computations for $\Gamma_0(N)$ and $\Gamma_1(N)$ and the criterion for membership in
+the full modular function field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finrank_adjoin_jqModC_qExpFunctionFieldC_le_index_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_finrank_adjoin_jqModC_qExpFunctionFieldC_le_index_of_isAlgClosed
+
+noncomputable section
+
+open Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "intSeriesC qExpFunctionFieldC intFormRatiosC_subset jNum coeffEmb \
+  laurentBaseChange coeffEmb_mem_laurentBaseChange jqModC map_jqModC \
+  finrank_adjoin_qExpFunctionFieldC_le_of_valuationSubring \
+  finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_le_index \
+  JOneES.exists_transcendental_finiteDimensional_laurentBaseChange transcendental_jqModC \
+  jqModC_mem_intFormRatiosC"
+namespace DegKDeuring
+p2m_open "ModularCurve"
+
+section Residue
+
+variable (p : ℕ) [Fact p.Prime] (A : ValuationSubring (AlgebraicClosure ℚ)) (hA : A.LiesOverPrime p)
+
+include hA in
+theorem isAlgebraic_residueField :
+    letI : CharP (IsLocalRing.ResidueField A) p :=
+      ValuationSubring.charP_residueField_of_liesOverPrime_def
+      (Fact.out : p.Prime) hA
+    letI := ZMod.algebra (IsLocalRing.ResidueField A) p
+    Algebra.IsAlgebraic (ZMod p) (IsLocalRing.ResidueField A) := by
+  let : CharP (IsLocalRing.ResidueField A) p :=
+    ValuationSubring.charP_residueField_of_liesOverPrime_def
+    (Fact.out : p.Prime) hA
+  let := ZMod.algebra (IsLocalRing.ResidueField A) p
+  have hp : p.Prime := Fact.out
+  refine ⟨fun ybar => ?_⟩
+  obtain ⟨y, rfl⟩ := IsLocalRing.residue_surjective ybar
+  have hyQ : IsAlgebraic ℚ (y : AlgebraicClosure ℚ) := by
+    have h := (AlgebraicClosure.isAlgebraic ℚ).isAlgebraic (y : AlgebraicClosure ℚ)
+    convert h using 2
+  have hyalg : IsAlgebraic ℤ (y : AlgebraicClosure ℚ) :=
+    (IsFractionRing.isAlgebraic_iff ℤ ℚ (AlgebraicClosure ℚ)).mpr hyQ
+  obtain ⟨P, hP0, hPy⟩ := hyalg
+  set Q := P.primPart with hQ
+  have hc0 : P.content ≠ 0 := fun h => hP0 (content_eq_zero_iff.mp h)
+  have hQy : aeval (y : AlgebraicClosure ℚ) Q = 0 := by
+    have h1 : aeval (y : AlgebraicClosure ℚ) (C P.content * Q) = 0 := by
+      rw [← eq_C_content_mul_primPart]; exact hPy
+    rw [map_mul, aeval_C, mul_eq_zero] at h1
+    exact h1.resolve_left ((map_ne_zero_iff _ (RingHom.injective_int _)).mpr hc0)
+  have hQyA : eval₂ (Int.castRingHom A) y Q = 0 := by
+    have hinj : Function.Injective A.subtype := Subtype.val_injective
+    apply hinj
+    rw [hom_eval₂, map_zero]
+    have h2 : (A.subtype.comp (Int.castRingHom A)) = algebraMap ℤ (AlgebraicClosure ℚ) :=
+      RingHom.ext_int _ _
+    rw [h2]
+    exact hQy
+  set Qbar := Q.map (Int.castRingHom (ZMod p)) with hQbar
+  have hQbar0 : Qbar ≠ 0 := by
+    intro h0
+    have hdvd : ∀ i, (p : ℤ) ∣ Q.coeff i := by
+      intro i
+      have hi := congrArg (fun R : (ZMod p)[X] => R.coeff i) h0
+      simp only [hQbar, coeff_map, coeff_zero, eq_intCast] at hi
+      exact (ZMod.intCast_zmod_eq_zero_iff_dvd _ p).mp hi
+    have hunit : IsUnit (p : ℤ) :=
+      (isPrimitive_primPart P) (p : ℤ) ((C_dvd_iff_dvd_coeff _ _).mpr hdvd)
+    rw [Int.isUnit_iff_natAbs_eq, Int.natAbs_natCast] at hunit
+    exact hp.one_lt.ne' hunit
+  refine ⟨Qbar, hQbar0, ?_⟩
+  rw [aeval_def, hQbar, eval₂_map]
+  have h3 : (algebraMap (ZMod p) (IsLocalRing.ResidueField A)).comp (Int.castRingHom (ZMod p)) =
+      (IsLocalRing.residue A).comp (Int.castRingHom A) := RingHom.ext_int _ _
+  rw [h3, ← hom_eval₂, hQyA, map_zero]
+
+end Residue
+
+section CharZero
+
+variable (K : Type*) [Field K]
+
+theorem coe_eq_zero_of_mem_maximalIdeal_top {a : (⊤ : ValuationSubring K)}
+    (ha : a ∈ IsLocalRing.maximalIdeal (⊤ : ValuationSubring K)) : (a : K) = 0 := by
+  by_contra h
+  apply (IsLocalRing.mem_maximalIdeal _).mp ha
+  refine ⟨⟨a, ⟨(a : K)⁻¹, trivial⟩, ?_, ?_⟩, rfl⟩
+  · exact Subtype.ext (mul_inv_cancel₀ h)
+  · exact Subtype.ext (inv_mul_cancel₀ h)
+
+def residueTopHom : IsLocalRing.ResidueField (⊤ : ValuationSubring K) →+* K :=
+  Ideal.Quotient.lift (IsLocalRing.maximalIdeal (⊤ : ValuationSubring K)) (⊤ : ValuationSubring
+    K).subtype
+    fun _ ha => coe_eq_zero_of_mem_maximalIdeal_top K ha
+
+end CharZero
+
+theorem jqModC_eq_div (K : Type*) [Field K] :
+    ModularCurve.jqModC K = ModularCurve.intSeriesC K ModularCurve.jNum / ModularCurve.intSeriesC K
+      PowerSeries.X := by
+  have hX : ModularCurve.intSeriesC K PowerSeries.X = HahnSeries.single 1 1 := by
+    simp [ModularCurve.intSeriesC, PowerSeries.map_X, HahnSeries.ofPowerSeries_X]
+  have hne : (HahnSeries.single (1 : ℤ) (1 : K) : LaurentSeries K) ≠ 0 := by simp
+  rw [hX, eq_div_iff hne, ModularCurve.jqModC, mul_comm (HahnSeries.single (-1 : ℤ) (1 : K)),
+    mul_assoc,
+    HahnSeries.single_mul_single]
+  simp [ModularCurve.intSeriesC]
+
+theorem jqModC_mem_laurentBaseChange (L : Type*) [Field L] [Algebra ℚ L]
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) :
+    ModularCurve.jqModC L ∈ ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ)
+      := by
+  have h : ModularCurve.jqModC ℚ ∈ ModularCurve.qExpFunctionFieldC ℚ Γ :=
+    ModularCurve.intFormRatiosC_subset ℚ Γ (ModularCurve.jqModC_mem_intFormRatiosC ℚ Γ)
+  have e : ModularCurve.coeffEmb L (ModularCurve.jqModC ℚ) = ModularCurve.jqModC L :=
+    ModularCurve.map_jqModC (algebraMap ℚ L)
+  exact e ▸ ModularCurve.coeffEmb_mem_laurentBaseChange L h
+
+theorem bound_of_place (K : Type*) [Field K]
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    (Γ' : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) (hΓ' : Γ ≤ Γ')
+    (hneg : ∀ γ ∈ Γ', γ ∈ Γ ∨ -γ ∈ Γ)
+    (x : ModularCurve.qExpFunctionFieldC K Γ) (hx : (x : LaurentSeries K) = ModularCurve.jqModC K)
+    (L : Type*) [Field L] [Algebra ℚ L] (A : ValuationSubring L) (π : A →+* K) :
+    FiniteDimensional
+        (IntermediateField.adjoin K ({x} : Set (ModularCurve.qExpFunctionFieldC K Γ)))
+        (ModularCurve.qExpFunctionFieldC K Γ) ∧
+      Module.finrank
+          (IntermediateField.adjoin K ({x} : Set (ModularCurve.qExpFunctionFieldC K Γ)))
+          (ModularCurve.qExpFunctionFieldC K Γ) ≤ Γ'.index := by
+  classical
+  have hF := ModularCurve.JOneES.exists_transcendental_finiteDimensional_laurentBaseChange L Γ hT
+  set X : ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ) :=
+    ⟨ModularCurve.jqModC L, jqModC_mem_laurentBaseChange L Γ⟩ with hXdef
+  have hXab : (X : LaurentSeries L) =
+      ModularCurve.intSeriesC L ModularCurve.jNum / ModularCurve.intSeriesC L PowerSeries.X :=
+        jqModC_eq_div L
+  have hxab : (x : LaurentSeries K) =
+      ModularCurve.intSeriesC K ModularCurve.jNum / ModularCurve.intSeriesC K PowerSeries.X :=
+    hx.trans (jqModC_eq_div K)
+  have htr : Transcendental K x := by
+    have hinj : Function.Injective (algebraMap (ModularCurve.qExpFunctionFieldC K Γ) (LaurentSeries
+      K)) :=
+      (algebraMap (ModularCurve.qExpFunctionFieldC K Γ) (LaurentSeries K)).injective
+    rw [← transcendental_algebraMap_iff hinj]
+    change Transcendental K (x : LaurentSeries K)
+    rw [hx]
+    exact ModularCurve.transcendental_jqModC K
+  obtain ⟨hfin, hle⟩ :=
+    ModularCurve.finrank_adjoin_qExpFunctionFieldC_le_of_valuationSubring A π Γ hF
+    ModularCurve.jNum PowerSeries.X X hXab x hxab htr
+  exact ⟨hfin, hle.trans
+    (ModularCurve.finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_le_index
+    L Γ hT Γ' hΓ' hneg X rfl)⟩
+
+end ModularCurve.DegKDeuring
+
+end
+
+open ModularCurve.DegKDeuring in
+theorem solution
+    (K : Type*) [Field K] [IsAlgClosed K]
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hT : ModularGroup.T ∈ Γ)
+    (Γ' : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) (hΓ' : Γ ≤ Γ')
+    (hneg : ∀ γ ∈ Γ', γ ∈ Γ ∨ -γ ∈ Γ)
+    (x : ModularCurve.qExpFunctionFieldC K Γ)
+    (hx : (x : LaurentSeries K) = ModularCurve.jqModC K) :
+    FiniteDimensional
+        (IntermediateField.adjoin K ({x} : Set (ModularCurve.qExpFunctionFieldC K Γ)))
+        (ModularCurve.qExpFunctionFieldC K Γ) ∧
+      Module.finrank
+          (IntermediateField.adjoin K ({x} : Set (ModularCurve.qExpFunctionFieldC K Γ)))
+          (ModularCurve.qExpFunctionFieldC K Γ) ≤ Γ'.index := by
+  classical
+  obtain ⟨p, hchar⟩ := CharP.exists K
+  rcases CharP.char_is_prime_or_zero K p with hp | rfl
+  · have : Fact p.Prime := ⟨hp⟩
+    obtain ⟨A, hA⟩ := ValuationSubring.exists_liesOverPrime_algebraicClosure_rat ⟨p, hp⟩
+    have : CharP (IsLocalRing.ResidueField A) p :=
+      ValuationSubring.charP_residueField_of_liesOverPrime_def hp hA
+    let := ZMod.algebra (IsLocalRing.ResidueField A) p
+    let := ZMod.algebra K p
+    have : Algebra.IsAlgebraic (ZMod p) (IsLocalRing.ResidueField A) :=
+      isAlgebraic_residueField p A hA
+    let φ : IsLocalRing.ResidueField A →+* K :=
+      (IsAlgClosed.lift (R := ZMod p) (S := IsLocalRing.ResidueField A) (M := K)).toRingHom
+    exact bound_of_place K Γ hT Γ' hΓ' hneg x hx (AlgebraicClosure ℚ) A (φ.comp (IsLocalRing.residue
+      A))
+  · have : CharZero K := CharP.charP_to_charZero K
+    exact bound_of_place K Γ hT Γ' hΓ' hneg x hx K (⊤ : ValuationSubring K) (⊤ : ValuationSubring
+      K).subtype
+
+end S_ModularCurve_finrank_adjoin_jqModC_qExpFunctionFieldC_le_index_of_isAlgClosed
+end P2MW
+export P2MW.S_ModularCurve_finrank_adjoin_jqModC_qExpFunctionFieldC_le_index_of_isAlgClosed
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem ModularCurve.finrank_adjoin_jqModC_qExpFunctionFieldC_le_index_of_isAlgClosed
+    (K : Type*) [Field K] [IsAlgClosed K]
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex]
+    (hT : ModularGroup.T ∈ Γ)
+    (Γ' : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) (hΓ' : Γ ≤ Γ')
+    (hneg : ∀ γ ∈ Γ', γ ∈ Γ ∨ -γ ∈ Γ)
+    (x : ModularCurve.qExpFunctionFieldC K Γ)
+    (hx : (x : LaurentSeries K) = ModularCurve.jqModC K) :
+    FiniteDimensional
+        (IntermediateField.adjoin K ({x} : Set (ModularCurve.qExpFunctionFieldC K Γ)))
+        (ModularCurve.qExpFunctionFieldC K Γ) ∧
+      Module.finrank
+          (IntermediateField.adjoin K ({x} : Set (ModularCurve.qExpFunctionFieldC K Γ)))
+          (ModularCurve.qExpFunctionFieldC K Γ) ≤ Γ'.index :=
+  solution K Γ hT Γ' hΓ' hneg x hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqNModC_eq_dedekindPsi_of_socket.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqNModC_eq_dedekindPsi_of_socket.lean
new file mode 100644
index 0000000000..87c447a58e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqNModC_eq_dedekindPsi_of_socket.lean
@@ -0,0 +1,592 @@
+/-
+Based on Prove2Me node ModularCurve.finrank_adjoin_jqNModC_eq_dedekindPsi_of_socket
+(585d8569-aad1-55d5-ba47-e87b88094ae0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 62304a93-a6ce-5661-827f-4bf71576065b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_neg_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_order_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_mul_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_of_mul_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_pow_of_lt
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_pow_self
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_injective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpand_jqModC_eq_pow_unconditional
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_jqNModC_of_modularPolynomialData
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqNModC_prime_not_mem_adjoin_of_charZero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_package_of_socket
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.RingTheory.RootsOfUnity.AlgebraicallyClosed
+import Mathlib.Algebra.Polynomial.Eval.Irreducible
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree [K(j)(j(qᵈ)):K(j)]=ψ(d) over any field
+
+Theorem statement: `ModularCurve.finrank_adjoin_jqNModC_eq_dedekindPsi_of_socket`
+(`585d8569-aad1-55d5-ba47-e87b88094ae0`), by Claude, 2026-09-05.
+
+Proof: submission `62304a93-a6ce-5661-827f-4bf71576065b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $d$ be a nonzero natural number. Inside the field $K((q))$ of formal
+Laurent series over $K$, write $j =$ `jqModC K` for the series $q^{-1}$ times the image in $K$ of
+the integral power series `jNum` $= E_4^3 \cdot \eta^{-24}$ (the $q$-expansion of the $j$-invariant
+with its integer coefficients read in $K$), and for $N \ge 1$ write $j(q^N) =$ `jqNModC K N` for the
+image of $j$ under the ring endomorphism `qExpand K N` of $K((q))$ that multiplies all exponents by
+$N$, i.e. substitutes $q^N$ for $q$. Let $K(j)$ denote the intermediate field of $K((q))/K$
+generated by $j$. Assume that for every prime $p$ dividing $d$ the series $j(q^p)$ does not lie in
+$K(j)$. Then the intermediate field of $K((q))/K(j)$ generated by $j(q^d)$ has finite rank over
+$K(j)$ equal to `dedekindPsi d`, defined as $\sum_{e \mid d,\ e \text{ squarefree}} d/e$, which is
+Dedekind's $\psi(d) = d\prod_{p \mid d}(1 + 1/p)$.
+
+This is the classical degree computation for the modular equation, $[K(j(q),j(q^d)) : K(j(q))] =
+\psi(d)$, here in the purely formal $q$-expansion model and over an arbitrary field, the hypothesis
+on primes dividing $d$ excluding in particular the characteristic $p$ case where $j(q^p) = j(q)^p$
+lies in $K(j)$. It feeds the irreducibility of the modular polynomial $\Phi_N$ over $K(j)$ and the
+count of poles of $j$ on the function field model of $X_0(N)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finrank_adjoin_jqNModC_eq_dedekindPsi_of_socket.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_finrank_adjoin_jqNModC_eq_dedekindPsi_of_socket
+
+noncomputable section
+
+p2m_open "ModularCurve \
+  P2MW.S_ModularCurve_finrank_adjoin_jqNModC_eq_dedekindPsi_of_socket.ModularCurve \
+  ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand dedekindPsi ModularPolynomialData coeffMap coeffMap_coeff coeffMap_single \
+  algebraMap_laurentSeries_eq_single qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one map_jqModC coeffMap_qExpand \
+  coeff_jqModC_neg_one order_jqModC coeff_jqModC_pow_of_lt coeff_jqModC_pow_self \
+  coeffMap_injective qExpand_jqModC_eq_pow_unconditional exists_phiIrreducible \
+  isIntegral_jqNModC_of_modularPolynomialData jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne \
+  jqNModC_prime_not_mem_adjoin_of_charZero package_of_socket"
+namespace W1
+p2m_open "ModularCurve"
+
+variable {K : Type*} [Field K]
+
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+theorem jqModC_eq_TS : jqModC K = TS K 1 1 := by
+  rw [TS, qTwist_one_apply, qExpand_one_apply]
+
+theorem jqNModC_eq_TS (d : ℕ) [NeZero d] : jqNModC K d = TS K d 1 := by
+  rw [jqNModC, TS, qTwist_one_apply]
+
+theorem qExpand_jqNModC (A d : ℕ) [NeZero A] [NeZero d] :
+    qExpand K A (jqNModC K d) = TS K (A * d) 1 := by
+  rw [jqNModC_eq_TS, qExpand_TS]
+
+theorem qExpand_jqModC_eq_TS (A : ℕ) [NeZero A] : qExpand K A (jqModC K) = TS K A 1 := by
+  rw [TS, qTwist_one_apply]
+
+theorem qTwist_qExpand_of_pow_eq_one (A : ℕ) [NeZero A] (v : Kˣ) (hv : v ^ A = 1)
+    (x : LaurentSeries K) :
+    qTwist v (qExpand K A x) = qExpand K A x := by
+  rw [qTwist_qExpand]
+  have : v ^ (A : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand dedekindPsi ModularPolynomialData coeffMap coeffMap_coeff coeffMap_single \
+  algebraMap_laurentSeries_eq_single qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one map_jqModC coeffMap_qExpand \
+  coeff_jqModC_neg_one order_jqModC coeff_jqModC_pow_of_lt coeff_jqModC_pow_self \
+  coeffMap_injective qExpand_jqModC_eq_pow_unconditional exists_phiIrreducible \
+  isIntegral_jqNModC_of_modularPolynomialData jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne \
+  jqNModC_prime_not_mem_adjoin_of_charZero package_of_socket"
+namespace W1
+p2m_open "ModularCurve"
+
+section transport
+
+variable {R S : Type*} [CommRing R] [CommRing S]
+
+theorem coeffMap_qTwist (σ : R →+* S) (u : Rˣ) (f : LaurentSeries R) :
+    coeffMap σ (qTwist u f) = qTwist (Units.map σ.toMonoidHom u) (coeffMap σ f) := by
+  ext k
+  simp only [coeffMap_coeff, qTwist_coeff, map_mul]
+  congr 1
+  rw [← map_zpow, Units.coe_map]
+  rfl
+
+end transport
+
+variable {K : Type*} [Field K]
+
+theorem coeffMap_TS {L : Type*} [Field L] (σ : L →+* K) (e : ℕ) [NeZero e] (u : Lˣ) :
+    coeffMap σ (TS L e u) = TS K e (Units.map σ.toMonoidHom u) := by
+  rw [TS, TS, coeffMap_qExpand, coeffMap_qTwist]
+  exact congrArg (fun z => qExpand K e (qTwist (Units.map σ.toMonoidHom u) z)) (map_jqModC σ)
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem units_pow_eq_one_of_isPrimitiveRoot {N : ℕ} {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N) :
+    ζ ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand dedekindPsi ModularPolynomialData coeffMap coeffMap_coeff coeffMap_single \
+  algebraMap_laurentSeries_eq_single qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one map_jqModC coeffMap_qExpand \
+  coeff_jqModC_neg_one order_jqModC coeff_jqModC_pow_of_lt coeff_jqModC_pow_self \
+  coeffMap_injective qExpand_jqModC_eq_pow_unconditional exists_phiIrreducible \
+  isIntegral_jqNModC_of_modularPolynomialData jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne \
+  jqNModC_prime_not_mem_adjoin_of_charZero package_of_socket"
+namespace W1
+p2m_open "ModularCurve"
+
+
+
+
+
+
+theorem phiAtSeed_jqNModC_eval {R : Type*} [CommRing R] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n)
+    (d : ℕ) [NeZero d] : (phiAtSeed data (jqNModC R d)).eval (jqNModC R (d * n)) = 0 := by
+  have h := data.eval_jqNModC_mul_eq_zero R d
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  exact Polynomial.ringHom_ext' (RingHom.ext_int _ _) (by simp)
+
+theorem phiAtSeed_jqNModC_eval_symm {R : Type*} [CommRing R] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n)
+    (hsymm : EvalSymm data.Φ) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (jqNModC R (d * n))).eval (jqNModC R d) = 0 := by
+  have h := data.eval_jqNModC_of_mul_eq_zero hsymm R d
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  exact Polynomial.ringHom_ext' (RingHom.ext_int _ _) (by simp)
+
+theorem phiAtSeed_TS_eval {K : Type*} [Field K] (A : ℕ) [NeZero A] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (TS K (A * d) 1)).eval (TS K (A * (d * n)) 1) = 0 := by
+  have h := phiAtSeed_eval_map data _ _ (qExpand K A) (phiAtSeed_jqNModC_eval (R := K) n data d)
+  rwa [qExpand_jqNModC, qExpand_jqNModC] at h
+
+theorem phiAtSeed_TS_eval_symm {K : Type*} [Field K] (A : ℕ) [NeZero A] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n) (hsymm : EvalSymm data.Φ) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (TS K (A * (d * n)) 1)).eval (TS K (A * d) 1) = 0 := by
+  have h :=
+    phiAtSeed_eval_map data _ _ (qExpand K A) (phiAtSeed_jqNModC_eval_symm (R := K) n data hsymm d)
+  rwa [qExpand_jqNModC, qExpand_jqNModC] at h
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand dedekindPsi ModularPolynomialData coeffMap coeffMap_coeff coeffMap_single \
+  algebraMap_laurentSeries_eq_single qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one map_jqModC coeffMap_qExpand \
+  coeff_jqModC_neg_one order_jqModC coeff_jqModC_pow_of_lt coeff_jqModC_pow_self \
+  coeffMap_injective qExpand_jqModC_eq_pow_unconditional exists_phiIrreducible \
+  isIntegral_jqNModC_of_modularPolynomialData jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne \
+  jqNModC_prime_not_mem_adjoin_of_charZero package_of_socket"
+namespace W1
+p2m_open "ModularCurve"
+
+variable {K : Type*} [Field K]
+
+private theorem jqNModC_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) :
+    jqNModC K n = jqNModC K m := by
+  subst h; rfl
+
+def jA (F : Type*) [Field F] : IntermediateField.adjoin F ({jqModC F} : Set (LaurentSeries F)) :=
+  ⟨jqModC F, IntermediateField.subset_adjoin F _ rfl⟩
+
+theorem aeval_jqNModC_phiAtSeed_jA (F : Type*) [Field F] (d : ℕ) [NeZero d]
+    (data : ModularPolynomialData d) :
+    Polynomial.aeval (jqNModC F d) (phiAtSeed data (jA F)) = 0 := by
+  rw [← Polynomial.eval_map_algebraMap, phiAtSeed_map]
+  have h := phiAtSeed_jqNModC_eval (R := F) d data 1
+  rw [jqNModC_one, jqNModC_congr (Nat.one_mul d)] at h
+  exact h
+
+section PoleOrder
+
+private theorem coeff_algebraMap_mul (c : K) (x : LaurentSeries K) (k : ℤ) :
+    (algebraMap K (LaurentSeries K) c * x).coeff k = c * x.coeff k := by
+  rw [algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_zero_mul]
+
+theorem coeff_aeval_jqModC_neg_natDegree (P : Polynomial K) :
+    (Polynomial.aeval (jqModC K) P).coeff (-(P.natDegree : ℤ)) = P.coeff P.natDegree := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+    Finset.sum_eq_single P.natDegree]
+  · rw [coeff_algebraMap_mul, ModularCurve.coeff_jqModC_pow_self K P.natDegree, mul_one]
+  · intro i hi hin
+    have hilt : i < P.natDegree := lt_of_le_of_ne (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hin
+    rw [coeff_algebraMap_mul, ModularCurve.coeff_jqModC_pow_of_lt K (b := i) (m := -(P.natDegree :
+      ℤ)) (by
+      omega),
+      mul_zero]
+  · intro hn
+    exact absurd (Finset.self_mem_range_succ P.natDegree) hn
+
+end PoleOrder
+
+section Transport
+
+variable {K' : Type*} [Field K'] (σ : K →+* K')
+
+theorem coeffMap_algebraMap_eq (c : K) :
+    coeffMap σ (algebraMap K (LaurentSeries K) c) = algebraMap K' (LaurentSeries K') (σ c) := by
+  rw [algebraMap_laurentSeries_eq_single, algebraMap_laurentSeries_eq_single, coeffMap_single]
+
+theorem coeffMap_jqModC_eq : coeffMap σ (jqModC K) = jqModC K' := map_jqModC σ
+
+theorem coeffMap_jqNModC_eq (n : ℕ) [NeZero n] : coeffMap σ (jqNModC K n) = jqNModC K' n := by
+  rw [jqNModC, jqNModC, ModularCurve.coeffMap_qExpand, coeffMap_jqModC_eq]
+
+theorem coeffMap_aeval_jqModC_eq (P : Polynomial K) :
+    coeffMap σ (Polynomial.aeval (jqModC K) P) = Polynomial.aeval (jqModC K') (P.map σ) := by
+  rw [Polynomial.aeval_def, Polynomial.aeval_def, Polynomial.hom_eval₂, Polynomial.eval₂_map]
+  have hcomp : (coeffMap σ).comp (algebraMap K (LaurentSeries K)) = (algebraMap K' (LaurentSeries
+    K')).comp σ :=
+    RingHom.ext fun c => coeffMap_algebraMap_eq σ c
+  rw [hcomp, coeffMap_jqModC_eq]
+
+theorem exists_map_eq_of_aeval_eq_coeffMap (P : Polynomial K')
+    (hP : ∃ y : LaurentSeries K, coeffMap σ y = Polynomial.aeval (jqModC K') P) : ∃ Q : Polynomial
+      K, Q.map σ = P := by
+  generalize hn : P.natDegree = n
+  induction n using Nat.strong_induction_on generalizing P with
+  | _ n ih =>
+    obtain ⟨y, hy⟩ := hP
+    have hlead : P.leadingCoeff = σ (y.coeff (-(P.natDegree : ℤ))) := by
+      have h1 := coeff_aeval_jqModC_neg_natDegree (K := K') P
+      rw [← hy, coeffMap_coeff] at h1
+      exact h1.symm
+    have hP' : ∃ y' : LaurentSeries K, coeffMap σ y' = Polynomial.aeval (jqModC K') P.eraseLead :=
+      by
+      refine ⟨y - algebraMap K (LaurentSeries K) (y.coeff (-(P.natDegree : ℤ))) * jqModC K ^
+        P.natDegree, ?_⟩
+      have h2 := congrArg (Polynomial.aeval (jqModC K')) (Polynomial.eraseLead_add_C_mul_X_pow P)
+      rw [map_add, map_mul, Polynomial.aeval_C, map_pow, Polynomial.aeval_X] at h2
+      rw [map_sub, map_mul, map_pow, coeffMap_algebraMap_eq, coeffMap_jqModC_eq, hy, ← hlead, ← h2,
+        add_sub_cancel_right]
+    have hQ' : ∃ Q' : Polynomial K, Q'.map σ = P.eraseLead := by
+      rcases Polynomial.eraseLead_natDegree_lt_or_eraseLead_eq_zero P with hlt | h0
+      · exact ih _ (hn ▸ hlt) P.eraseLead hP' rfl
+      · exact ⟨0, by rw [Polynomial.map_zero, h0]⟩
+    obtain ⟨Q', hQ'⟩ := hQ'
+    refine ⟨Q' + Polynomial.C (y.coeff (-(P.natDegree : ℤ))) * Polynomial.X ^ P.natDegree, ?_⟩
+    rw [Polynomial.map_add, Polynomial.map_mul, Polynomial.map_C, Polynomial.map_pow,
+      Polynomial.map_X, hQ', ← hlead,
+      Polynomial.eraseLead_add_C_mul_X_pow]
+
+include σ in
+theorem jqNModC_not_mem_adjoin_of_not_mem_adjoin (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (h : jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) :
+    jqNModC K' p ∉ IntermediateField.adjoin K' ({jqModC K'} : Set (LaurentSeries K')) := by
+  intro hmem
+  have hpoly : ∃ P : Polynomial K', Polynomial.aeval (jqModC K') P = jqNModC K' p := by
+    by_contra hcon
+    exact ModularCurve.jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne p (fun P hP => hcon ⟨P, hP⟩)
+      hmem
+  obtain ⟨P, hP⟩ := hpoly
+  obtain ⟨Q, hQ⟩ :=
+    exists_map_eq_of_aeval_eq_coeffMap σ P ⟨jqNModC K p, by rw [coeffMap_jqNModC_eq, hP]⟩
+  apply h
+  have hinj : Function.Injective (coeffMap σ) := ModularCurve.coeffMap_injective σ.injective
+  have hval : Polynomial.aeval (jqModC K) Q = jqNModC K p := by
+    apply hinj
+    rw [coeffMap_aeval_jqModC_eq, hQ, hP, coeffMap_jqNModC_eq]
+  have h3 : Polynomial.aeval (jqModC K) Q
+      = algebraMap (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) (LaurentSeries
+        K)
+          (Polynomial.aeval (jA K) Q) :=
+    Polynomial.aeval_algebraMap_apply (LaurentSeries K) (jA K) Q
+  rw [← hval, h3]
+  exact (Polynomial.aeval (jA K) Q).2
+
+theorem coeffMap_mem_adjoin {x : LaurentSeries K}
+    (hx : x ∈ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) :
+    coeffMap σ x ∈ IntermediateField.adjoin K' ({jqModC K'} : Set (LaurentSeries K')) := by
+  let E : IntermediateField K (LaurentSeries K) :=
+    { (IntermediateField.adjoin K' ({jqModC K'} : Set (LaurentSeries K'))).toSubfield.comap
+      (coeffMap σ) with
+      algebraMap_mem' := fun c => by
+        change coeffMap σ (algebraMap K (LaurentSeries K) c)
+          ∈ IntermediateField.adjoin K' ({jqModC K'} : Set (LaurentSeries K'))
+        rw [coeffMap_algebraMap_eq]
+        exact (IntermediateField.adjoin K' _).algebraMap_mem (σ c) }
+  have hle : IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) ≤ E := by
+    rw [IntermediateField.adjoin_le_iff]
+    rintro _ rfl
+    change coeffMap σ (jqModC K) ∈ IntermediateField.adjoin K' ({jqModC K'} : Set (LaurentSeries
+      K'))
+    rw [coeffMap_jqModC_eq]
+    exact IntermediateField.subset_adjoin K' _ rfl
+  exact hle hx
+
+def tauAdjoin : (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+    →+* (IntermediateField.adjoin K' ({jqModC K'} : Set (LaurentSeries K'))) where
+  toFun x := ⟨coeffMap σ (x : LaurentSeries K), coeffMap_mem_adjoin σ x.2⟩
+  map_one' := Subtype.ext (by simp)
+  map_mul' _ _ := Subtype.ext (by simp)
+  map_zero' := Subtype.ext (by simp)
+  map_add' _ _ := Subtype.ext (by simp)
+
+theorem tauAdjoin_jA : tauAdjoin σ (jA K) = jA K' :=
+  Subtype.ext (coeffMap_jqModC_eq σ)
+
+include σ in
+theorem finrank_adjoin_jqNModC_eq_of_map (d : ℕ) [NeZero d] (data : ModularPolynomialData d)
+    (htight : Module.finrank (IntermediateField.adjoin K' ({jqModC K'} : Set (LaurentSeries K')))
+        (IntermediateField.adjoin (IntermediateField.adjoin K' ({jqModC K'} : Set (LaurentSeries
+          K')))
+          ({jqNModC K' d} : Set (LaurentSeries K'))) = dedekindPsi d) :
+    Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+        (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+          ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d := by
+  have hint' : IsIntegral (IntermediateField.adjoin K' ({jqModC K'} : Set (LaurentSeries K')))
+    (jqNModC K' d) :=
+    ModularCurve.isIntegral_jqNModC_of_modularPolynomialData K' data
+  have hmin' : (minpoly (IntermediateField.adjoin K' ({jqModC K'} : Set (LaurentSeries K')))
+    (jqNModC K' d)).natDegree
+      = dedekindPsi d := by
+    rw [← IntermediateField.adjoin.finrank hint']
+    exact htight
+  have hΦ' : phiAtSeed data (jA K')
+      = minpoly (IntermediateField.adjoin K' ({jqModC K'} : Set (LaurentSeries K'))) (jqNModC K' d)
+        :=
+    Polynomial.eq_of_monic_of_dvd_of_natDegree_le (minpoly.monic hint') (phiAtSeed_monic data _)
+      (minpoly.dvd _ _ (aeval_jqNModC_phiAtSeed_jA K' d data))
+      (le_of_eq ((phiAtSeed_natDegree data _).trans hmin'.symm))
+  have hirr' : Irreducible (phiAtSeed data (jA K')) := by
+    rw [hΦ']
+    exact minpoly.irreducible hint'
+  have hmapΦ : (phiAtSeed data (jA K)).map (tauAdjoin σ) = phiAtSeed data (jA K') := by
+    rw [phiAtSeed_map, tauAdjoin_jA]
+  have hirr : Irreducible (phiAtSeed data (jA K)) := by
+    refine Polynomial.Monic.irreducible_of_irreducible_map (tauAdjoin σ) _ (phiAtSeed_monic data _)
+      ?_
+    rw [hmapΦ]
+    exact hirr'
+  have hint : IsIntegral (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) (jqNModC
+    K d) :=
+    ModularCurve.isIntegral_jqNModC_of_modularPolynomialData K data
+  have hmin : phiAtSeed data (jA K)
+      = minpoly (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) (jqNModC K d) :=
+    minpoly.eq_of_irreducible_of_monic hirr (aeval_jqNModC_phiAtSeed_jA K d data) (phiAtSeed_monic
+      data _)
+  rw [IntermediateField.adjoin.finrank hint, ← hmin, phiAtSeed_natDegree]
+
+end Transport
+
+theorem natCast_ne_zero_of_socket (d : ℕ) [NeZero d]
+    (hbase : ∀ (p : ℕ) [Fact (Nat.Prime p)], p ∣ d →
+      jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) :
+    (d : K) ≠ 0 := by
+  intro hd
+  have hdvd : ringChar K ∣ d := ringChar.dvd hd
+  have h0 : ringChar K ≠ 0 := fun h => NeZero.ne d (Nat.eq_zero_of_zero_dvd (h ▸ hdvd))
+  have : Fact (Nat.Prime (ringChar K)) := ⟨CharP.char_prime_of_ne_zero K h0⟩
+  have hfrob : jqNModC K (ringChar K) = jqModC K ^ ringChar K :=
+    ModularCurve.qExpand_jqModC_eq_pow_unconditional K
+  have hmem : jqModC K ^ ringChar K ∈ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries
+    K)) :=
+    (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))).pow_mem
+      (IntermediateField.subset_adjoin K _ rfl)
+      (ringChar K)
+  rw [← hfrob] at hmem
+  exact hbase (ringChar K) hdvd hmem
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand dedekindPsi ModularPolynomialData coeffMap coeffMap_coeff coeffMap_single \
+  algebraMap_laurentSeries_eq_single qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one map_jqModC coeffMap_qExpand \
+  coeff_jqModC_neg_one order_jqModC coeff_jqModC_pow_of_lt coeff_jqModC_pow_self \
+  coeffMap_injective qExpand_jqModC_eq_pow_unconditional exists_phiIrreducible \
+  isIntegral_jqNModC_of_modularPolynomialData jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne \
+  jqNModC_prime_not_mem_adjoin_of_charZero package_of_socket"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.jqNModC_prime_not_mem_adjoin_of_ringHom {K K' : Type*} [Field K]
+    [Field K'] (σ : K →+* K') (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (h : jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) :
+    jqNModC K' p ∉ IntermediateField.adjoin K' ({jqModC K'} : Set (LaurentSeries K')) :=
+  jqNModC_not_mem_adjoin_of_not_mem_adjoin σ p h
+
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.finrank_adjoin_jqNModC_eq_dedekindPsi_of_socket {K : Type*} [Field K]
+  (d : ℕ) [NeZero d] (hbase : ∀ (p : ℕ) [Fact (Nat.Prime p)], p ∣ d → jqNModC K p ∉
+  IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) :
+    Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d := by
+  have hd : (d : K) ≠ 0 := natCast_ne_zero_of_socket d hbase
+  have : NeZero ((d : ℕ) : K) := ⟨hd⟩
+  obtain ⟨z, hz⟩ := HasEnoughRootsOfUnity.exists_primitiveRoot (AlgebraicClosure K) d
+  have hzu : IsUnit z := hz.isUnit (NeZero.ne d)
+  have hζ : IsPrimitiveRoot ((hzu.unit : (AlgebraicClosure K)ˣ) : AlgebraicClosure K) d := by
+    rw [IsUnit.unit_spec]
+    exact hz
+  have hbase' : ∀ (p : ℕ) [Fact (Nat.Prime p)], p ∣ d → jqNModC (AlgebraicClosure K) p ∉
+      IntermediateField.adjoin (AlgebraicClosure K) ({jqModC (AlgebraicClosure K)} : Set
+        (LaurentSeries (AlgebraicClosure K))) :=
+    fun (p : ℕ) [Fact (Nat.Prime p)] hp =>
+      jqNModC_not_mem_adjoin_of_not_mem_adjoin (algebraMap K (AlgebraicClosure K)) p (hbase p hp)
+  have htight' := (ModularCurve.package_of_socket d _ hζ hbase' d dvd_rfl).1
+  obtain ⟨data, -⟩ := ModularCurve.exists_phiIrreducible d
+  exact finrank_adjoin_jqNModC_eq_of_map (algebraMap K (AlgebraicClosure K)) d data htight'
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.finrank_adjoin_jqNModC_eq_dedekindPsi_of_charZero {K : Type*} [Field K]
+    [CharZero K] (d : ℕ) [NeZero d] :
+    Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d :=
+  ModularCurve.finrank_adjoin_jqNModC_eq_dedekindPsi_of_socket d
+    fun (p : ℕ) [Fact (Nat.Prime p)] _ => ModularCurve.jqNModC_prime_not_mem_adjoin_of_charZero p
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.finrank_adjoin_jqNModC_sq_eq_of_socket {K : Type*} [Field K] (p : ℕ)
+    [hp : Fact (Nat.Prime p)]
+    (hbase : jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) :
+    Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      ({jqNModC K (p * p)} : Set (LaurentSeries K))) = dedekindPsi (p * p) :=
+  ModularCurve.finrank_adjoin_jqNModC_eq_dedekindPsi_of_socket (p * p) fun (q : ℕ) [hq : Fact
+    (Nat.Prime q)] hqd => by
+    have hqp : q = p :=
+      (Nat.prime_dvd_prime_iff_eq hq.out hp.out).mp (((Nat.Prime.dvd_mul hq.out).mp hqd).elim id id)
+    subst hqp
+    exact hbase
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.finrank_adjoin_jqNModC_sq_mul_prime_eq_of_socket {K : Type*} [Field K]
+    (p ℓ : ℕ) [hp : Fact (Nat.Prime p)] [hl : Fact (Nat.Prime ℓ)]
+    (hbase : jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+    (hbaseℓ : jqNModC K ℓ ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) :
+    Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      ({jqNModC K (p * p * ℓ)} : Set (LaurentSeries K))) = dedekindPsi (p * p * ℓ) :=
+  ModularCurve.finrank_adjoin_jqNModC_eq_dedekindPsi_of_socket (p * p * ℓ) fun (q : ℕ) [hq : Fact
+    (Nat.Prime q)] hqd => by
+    rcases (Nat.Prime.dvd_mul hq.out).mp hqd with hqpp | hql
+    · have hqp : q = p :=
+        (Nat.prime_dvd_prime_iff_eq hq.out hp.out).mp (((Nat.Prime.dvd_mul hq.out).mp hqpp).elim id
+          id)
+      subst hqp
+      exact hbase
+    · have hql' : q = ℓ := (Nat.prime_dvd_prime_iff_eq hq.out hl.out).mp hql
+      subst hql'
+      exact hbaseℓ
+
+end
+
+open _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_finrank_adjoin_jqNModC_eq_dedekindPsi_of_socket.ModularCurve
+  ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] (d : ℕ) [NeZero d] (hbase : ∀ (p : ℕ) [Fact (Nat.Prime p)], p
+  ∣ d → jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) :
+    Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d :=
+  ModularCurve.finrank_adjoin_jqNModC_eq_dedekindPsi_of_socket d hbase
+
+end S_ModularCurve_finrank_adjoin_jqNModC_eq_dedekindPsi_of_socket
+end P2MW
+export P2MW.S_ModularCurve_finrank_adjoin_jqNModC_eq_dedekindPsi_of_socket (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.finrank_adjoin_jqNModC_eq_dedekindPsi_of_socket {K : Type*} [Field K] (d : ℕ)
+  [NeZero d] (hbase : ∀ (p : ℕ) [Fact (Nat.Prime p)], p ∣ d → jqNModC K p ∉ IntermediateField.adjoin
+  K ({jqModC K} : Set (LaurentSeries K))) :
+    Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d :=
+  solution d hbase
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqNModC_eq_of_prime.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqNModC_eq_of_prime.lean
new file mode 100644
index 0000000000..48d63f8903
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqNModC_eq_of_prime.lean
@@ -0,0 +1,359 @@
+/-
+Based on Prove2Me node ModularCurve.finrank_adjoin_jqNModC_eq_of_prime
+(0cd99cd6-73f2-5733-8f0b-9fd5addc7f94) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4bff9e4f-2764-54ff-b1f2-57e340373296
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CuspidalClass
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_le_finrank
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_inertiaDeg_pos
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_subsingleton_setOf_forall_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_modularFunctionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_full_eq_of_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_modularPolynomialData_of_squarefree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqNModC_le
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_adjoin_jqNModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_cuspInftyBar_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_cuspZeroBar_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_cuspZeroBar_ne_cuspInftyBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCusp_cuspZeroBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCusp_cuspInftyBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isFrickeAutFull_frickeInvolutionFull_prime
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Geometric degree of X₀(ℓ)→ X(1) is ℓ+1
+
+Theorem statement: `ModularCurve.finrank_adjoin_jqNModC_eq_of_prime`
+(`0cd99cd6-73f2-5733-8f0b-9fd5addc7f94`), by Claude, 2026-09-05.
+
+Proof: submission `4bff9e4f-2764-54ff-b1f2-57e340373296`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a prime and let $\bar{\mathbb{Q}}$ denote `AlgebraicClosure ℚ`. Work inside the field
+$\bar{\mathbb{Q}}((q))$ of Laurent series, and consider the element $j_q :=$ `jqModC`
+$\bar{\mathbb{Q}}$, defined as the product of the Hahn series $q^{-1}$ (the single term $1$ in
+degree $-1$) with the image in $\bar{\mathbb{Q}}((q))$ of the integral power series `jNum` $=$
+`eisenstein4`$^3\cdot$`dedekindEtaUnitInv`, i.e. the $q$-expansion of the modular invariant $j$; and
+the element $j_{q,\ell} :=$ `jqNModC` $\bar{\mathbb{Q}}\,\ell$, obtained from $j_q$ by the ring
+homomorphism `qExpand` which multiplies all Hahn-series exponents by $\ell$, that is the
+substitution $q \mapsto q^{\ell}$, so $j_{q,\ell}$ is the $q$-expansion of $j(q^{\ell})$. Form the
+intermediate field $F := \bar{\mathbb{Q}}(j_q)$ generated over $\bar{\mathbb{Q}}$ by $j_q$ inside
+$\bar{\mathbb{Q}}((q))$, and then the intermediate field $F(j_{q,\ell})$ generated over $F$ by
+$j_{q,\ell}$. The assertion is that $F(j_{q,\ell})$ has dimension exactly $\ell+1$ as an $F$-vector
+space.
+
+This is the geometric irreducibility of the modular equation at prime level: the modular polynomial
+$\Phi_\ell(j_q, Y)$ stays irreducible over $\bar{\mathbb{Q}}(j_q)$, equivalently the covering
+$X_0(\ell) \to X(1)$ has degree $\psi(\ell) = \ell+1$ after base change to an algebraically closed
+field of characteristic zero. It is used in the identification of places of the function field of
+$X_0(\ell)$ over $\bar{\mathbb{Q}}$ through roots of the modular polynomial, and in computing
+relative degrees under base change of the modular function field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finrank_adjoin_jqNModC_eq_of_prime.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_finrank_adjoin_jqNModC_eq_of_prime
+
+p2m_open "ModularCurve~dedekindPsi_prime AlgebraicCurve IntermediateField"
+open scoped Polynomial
+
+noncomputable section
+
+namespace DegAux
+
+local notation "𝕂" => AlgebraicClosure ℚ
+
+variable (ℓ : ℕ) [Fact ℓ.Prime]
+
+theorem prime' : ℓ.Prime := Fact.out
+
+theorem dedekindPsi_prime : dedekindPsi ℓ = ℓ + 1 := by
+  have hℓ : ℓ.Prime := Fact.out
+  rw [dedekindPsi, hℓ.divisors, Finset.filter_true_of_mem, Finset.sum_pair hℓ.one_lt.ne,
+    Nat.div_one,
+    Nat.div_self hℓ.pos, add_comm]
+  intro d hd
+  simp only [Finset.mem_insert, Finset.mem_singleton] at hd
+  rcases hd with rfl | rfl
+  · exact squarefree_one
+  · exact hℓ.squarefree
+
+def jb :
+    modularFunctionFieldBar ℓ := ⟨coeffEmb 𝕂 jq, coeffEmb_mem_laurentBaseChange 𝕂 (jq_mem_full ℓ)⟩
+
+theorem coe_jb : (jb ℓ : LaurentSeries 𝕂) = jqModC 𝕂 := coeffEmb_jq 𝕂
+
+theorem bar_eq_restrictScalars :
+    modularFunctionFieldBar ℓ = (𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯).restrictScalars 𝕂 := by
+  have hℓ : ℓ.Prime := Fact.out
+  change laurentBaseChange 𝕂 (modularFunctionFieldFull ℓ) = _
+  rw [full_eq_of_prime hℓ, laurentBaseChange_modularFunctionField]
+  exact (adjoin_simple_adjoin_simple 𝕂 (jqModC 𝕂) (jqNModC 𝕂 ℓ)).symm
+
+def σa : RatFunc 𝕂 ≃ₐ[𝕂] 𝕂⟮jqModC 𝕂⟯ :=
+  RatFunc.algEquivOfTranscendental (jqModC 𝕂) (transcendental_jqModC 𝕂)
+
+theorem coe_σa_X : ((σa (RatFunc.X : RatFunc 𝕂) : 𝕂⟮jqModC 𝕂⟯) : LaurentSeries 𝕂) = jqModC 𝕂 :=
+  RatFunc.algEquivOfTranscendental_X (jqModC 𝕂) (transcendental_jqModC 𝕂)
+
+theorem mem_bar_iff (x : LaurentSeries 𝕂) :
+    x ∈ modularFunctionFieldBar ℓ ↔ x ∈ 𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯ := by
+  rw [bar_eq_restrictScalars ℓ, mem_restrictScalars]
+
+def jTr : (𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯) ≃+* modularFunctionFieldBar ℓ where
+  toFun x := ⟨x, (mem_bar_iff ℓ _).mpr x.2⟩
+  invFun y := ⟨y, (mem_bar_iff ℓ _).mp y.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  map_mul' _ _ := rfl
+  map_add' _ _ := rfl
+
+theorem coe_jTr (x : 𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯) :
+    ((jTr ℓ x : modularFunctionFieldBar ℓ) : LaurentSeries 𝕂) = x := by
+  ext; rfl
+
+def φ : RatFunc 𝕂 →+* modularFunctionFieldBar ℓ :=
+  (jTr ℓ).toRingHom.comp
+    ((algebraMap (𝕂⟮jqModC 𝕂⟯) (𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯)).comp (σa).toRingEquiv.toRingHom)
+
+theorem φ_apply (x : RatFunc 𝕂) :
+    φ ℓ x = jTr ℓ (algebraMap (𝕂⟮jqModC 𝕂⟯) (𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯) (σa x)) := rfl
+
+theorem coe_algebraMap_tower (y : 𝕂⟮jqModC 𝕂⟯) :
+    ((algebraMap (𝕂⟮jqModC 𝕂⟯) (𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯) y : 𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯) :
+      LaurentSeries 𝕂) = y := by
+  ext; rfl
+
+theorem coe_φ (x : RatFunc 𝕂) :
+    ((φ ℓ x : modularFunctionFieldBar ℓ) : LaurentSeries 𝕂) = (σa x : LaurentSeries 𝕂) := by
+  rw [φ_apply, coe_jTr, coe_algebraMap_tower]
+
+theorem φ_algebraMap (k : 𝕂) :
+    φ ℓ (algebraMap 𝕂 (RatFunc 𝕂) k) = algebraMap 𝕂 (modularFunctionFieldBar ℓ) k := by
+  ext
+  rw [coe_φ, AlgEquiv.commutes]
+  rfl
+
+theorem φ_X : φ ℓ (RatFunc.X : RatFunc 𝕂) = jb ℓ := by
+  apply Subtype.ext
+  rw [coe_φ, coe_jb, coe_σa_X]
+
+abbrev algRatFunc : Algebra (RatFunc 𝕂) (modularFunctionFieldBar ℓ) := (φ ℓ).toAlgebra
+
+attribute [local instance] algRatFunc
+
+theorem algebraMap_eq : algebraMap (RatFunc 𝕂) (modularFunctionFieldBar ℓ) = φ ℓ := rfl
+
+theorem isScalarTower_ratFunc : IsScalarTower 𝕂 (RatFunc 𝕂) (modularFunctionFieldBar ℓ) :=
+  IsScalarTower.of_algebraMap_eq fun k => (φ_algebraMap ℓ k).symm
+
+attribute [local instance] isScalarTower_ratFunc
+
+theorem he_compat :
+    (algebraMap (RatFunc 𝕂) (modularFunctionFieldBar ℓ)).comp
+        (σa.symm.toRingEquiv : 𝕂⟮jqModC 𝕂⟯ ≃+* RatFunc 𝕂).toRingHom
+      = (jTr ℓ).toRingHom.comp (algebraMap (𝕂⟮jqModC 𝕂⟯) (𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯)) := by
+  apply RingHom.ext
+  intro y
+  change φ ℓ (σa.symm y) = jTr ℓ (algebraMap _ _ y)
+  rw [φ_apply, AlgEquiv.apply_symm_apply]
+
+theorem finite_ratFunc : Module.Finite (RatFunc 𝕂) (modularFunctionFieldBar ℓ) := by
+  have hℓ : ℓ.Prime := Fact.out
+  obtain ⟨data⟩ := nonempty_modularPolynomialData_of_squarefree ℓ hℓ.squarefree hℓ.one_lt
+  have := finiteDimensional_adjoin_jqNModC 𝕂 data
+  exact Module.Finite.of_equiv_equiv (σa.symm.toRingEquiv : 𝕂⟮jqModC 𝕂⟯ ≃+* RatFunc 𝕂) (jTr ℓ)
+    (he_compat ℓ)
+
+attribute [local instance] finite_ratFunc
+
+theorem finrank_le : Module.finrank (RatFunc 𝕂) (modularFunctionFieldBar ℓ) ≤ ℓ + 1 := by
+  have hℓ : ℓ.Prime := Fact.out
+  obtain ⟨data⟩ := nonempty_modularPolynomialData_of_squarefree ℓ hℓ.squarefree hℓ.one_lt
+  rw [← Algebra.finrank_eq_of_equiv_equiv (σa.symm.toRingEquiv : 𝕂⟮jqModC 𝕂⟯ ≃+* RatFunc 𝕂) (jTr ℓ)
+    (he_compat ℓ), ← dedekindPsi_prime ℓ]
+  exact finrank_adjoin_jqNModC_le 𝕂 data
+
+theorem isSeparable_ratFunc : Algebra.IsSeparable (RatFunc 𝕂) (modularFunctionFieldBar ℓ) :=
+  Algebra.IsAlgebraic.isSeparable_of_perfectField
+
+attribute [local instance] isSeparable_ratFunc
+
+theorem restrict_eq_of_isCusp (u : Place 𝕂 (modularFunctionFieldBar ℓ)) (hu : IsCusp (jb ℓ) u) :
+    u.restrict (RatFunc 𝕂) = (cuspInftyBar ℓ).restrict (RatFunc 𝕂) := by
+  have key : ∀ u' : Place 𝕂 (modularFunctionFieldBar ℓ), IsCusp (jb ℓ) u' →
+      ∀ p : IsDedekindDomain.HeightOneSpectrum 𝕂[X],
+        u'.restrict (RatFunc 𝕂) ≠ Place.ofHeightOneSpectrum p := by
+    intro u' hu' p heq
+    apply hu'
+    have hX : (RatFunc.X : RatFunc 𝕂) ∈ (u'.restrict (RatFunc 𝕂)).toValuationSubring := by
+      rw [heq, Place.ofHeightOneSpectrum_toValuationSubring, Valuation.mem_valuationSubring_iff,
+        ← RatFunc.algebraMap_X]
+      exact p.valuation_le_one _
+    rw [Place.mem_restrict_iff, algebraMap_eq, φ_X] at hX
+    exact hX
+  exact RationalFunctionField.subsingleton_setOf_forall_ne_ofHeightOneSpectrum (key u hu)
+    (key _ (isCusp_cuspInftyBar ℓ))
+
+theorem e_infty : ((cuspInftyBar ℓ).ramificationIndex (RatFunc 𝕂) : ℤ) = 1 ∧
+    ((cuspInftyBar ℓ).restrict (RatFunc 𝕂)).ord RatFunc.X = -1 := by
+  have h := (cuspInftyBar ℓ).ord_restrict (F := RatFunc 𝕂) RatFunc.X
+  rw [algebraMap_eq, φ_X] at h
+  have hj : (cuspInftyBar ℓ).ord (jb ℓ) = -1 := ord_cuspInftyBar_coeffEmb_jq ℓ
+  rw [hj] at h
+  have epos : (0 : ℤ) < (cuspInftyBar ℓ).ramificationIndex (RatFunc 𝕂) := by
+    exact_mod_cast (cuspInftyBar ℓ).ramificationIndex_pos (F := RatFunc 𝕂)
+  have h1 : ((cuspInftyBar ℓ).ramificationIndex (RatFunc 𝕂) : ℤ) *
+      (-((cuspInftyBar ℓ).restrict (RatFunc 𝕂)).ord RatFunc.X) = 1 := by linarith
+  have he := Int.eq_one_of_mul_eq_one_right epos.le h1
+  refine ⟨he, ?_⟩
+  rw [he, one_mul] at h1
+  linarith
+
+theorem e_zero (hw : IsFrickeAutFull ℓ (frickeInvolutionFull ℓ)) :
+    ((cuspZeroBar ℓ).ramificationIndex (RatFunc 𝕂) : ℤ) = ℓ := by
+  have h := (cuspZeroBar ℓ).ord_restrict (F := RatFunc 𝕂) RatFunc.X
+  rw [algebraMap_eq, φ_X, restrict_eq_of_isCusp ℓ _ (isCusp_cuspZeroBar ℓ hw), (e_infty ℓ).2] at h
+  have hj : (cuspZeroBar ℓ).ord (jb ℓ) = -ℓ := ord_cuspZeroBar_coeffEmb_jq ℓ hw
+  rw [hj] at h
+  linarith
+
+theorem eq_cuspInftyBar_or_eq_cuspZeroBar (hw : IsFrickeAutFull ℓ (frickeInvolutionFull ℓ))
+    (w : Place 𝕂 (modularFunctionFieldBar ℓ)) (hc : IsCusp (jb ℓ) w) :
+    w = cuspInftyBar ℓ ∨ w = cuspZeroBar ℓ := by
+  classical
+  by_contra hnot
+  have h1 : w ≠ cuspInftyBar ℓ := fun h => hnot (Or.inl h)
+  have h2 : w ≠ cuspZeroBar ℓ := fun h => hnot (Or.inr h)
+  have hℓ : ℓ.Prime := Fact.out
+  have hne : cuspZeroBar ℓ ≠ cuspInftyBar ℓ := cuspZeroBar_ne_cuspInftyBar ℓ hw hℓ.one_lt
+  have r0 := restrict_eq_of_isCusp ℓ _ (isCusp_cuspZeroBar ℓ hw)
+  have rw' := restrict_eq_of_isCusp ℓ _ hc
+  have hS : ∀ u ∈ ({cuspInftyBar ℓ, cuspZeroBar ℓ, w} : Finset (Place 𝕂 (modularFunctionFieldBar
+    ℓ))),
+      u.restrict (RatFunc 𝕂) = (cuspInftyBar ℓ).restrict (RatFunc 𝕂) := by
+    intro u hu
+    simp only [Finset.mem_insert, Finset.mem_singleton] at hu
+    rcases hu with rfl | rfl | rfl
+    · rfl
+    · exact r0
+    · exact rw'
+  have hsum := Place.sum_ramificationIndex_mul_inertiaDeg_le_finrank _ _ hS
+  rw [Finset.sum_insert (by simp [hne.symm, Ne.symm h1]), Finset.sum_insert (by simp [Ne.symm h2]),
+    Finset.sum_singleton] at hsum
+  have hrank : (Module.finrank (RatFunc 𝕂) (modularFunctionFieldBar ℓ) : ℤ) ≤ ℓ + 1 := by
+    exact_mod_cast finrank_le ℓ
+  have e1 := (e_infty ℓ).1
+  have e0 := e_zero ℓ hw
+  have ew : (1 : ℤ) ≤ w.ramificationIndex (RatFunc 𝕂) := by
+    exact_mod_cast w.ramificationIndex_pos (F := RatFunc 𝕂)
+  have f1 : (1 : ℤ) ≤ (cuspInftyBar ℓ).inertiaDeg (RatFunc 𝕂) := by
+    exact_mod_cast Place.inertiaDeg_pos (F := RatFunc 𝕂) (cuspInftyBar ℓ)
+  have f0 : (1 : ℤ) ≤ (cuspZeroBar ℓ).inertiaDeg (RatFunc 𝕂) := by
+    exact_mod_cast Place.inertiaDeg_pos (F := RatFunc 𝕂) (cuspZeroBar ℓ)
+  have fw : (1 : ℤ) ≤ w.inertiaDeg (RatFunc 𝕂) := by
+    exact_mod_cast Place.inertiaDeg_pos (F := RatFunc 𝕂) w
+  have p0 : (ℓ : ℤ) ≤ ((cuspZeroBar ℓ).ramificationIndex (RatFunc 𝕂) : ℤ) *
+      ((cuspZeroBar ℓ).inertiaDeg (RatFunc 𝕂) : ℤ) := by
+    rw [e0]; nlinarith
+  have pw : (1 : ℤ) ≤ (w.ramificationIndex (RatFunc 𝕂) : ℤ) * (w.inertiaDeg (RatFunc 𝕂) : ℤ) :=
+    one_le_mul_of_one_le_of_one_le ew fw
+  rw [e1, one_mul] at hsum
+  linarith
+
+theorem le_finrank : ℓ + 1 ≤ Module.finrank (RatFunc 𝕂) (modularFunctionFieldBar ℓ) := by
+  classical
+  have hw := isFrickeAutFull_frickeInvolutionFull_prime ℓ
+  have hℓ : ℓ.Prime := Fact.out
+  have hne : cuspZeroBar ℓ ≠ cuspInftyBar ℓ := cuspZeroBar_ne_cuspInftyBar ℓ hw hℓ.one_lt
+  have r0 := restrict_eq_of_isCusp ℓ _ (isCusp_cuspZeroBar ℓ hw)
+  have hS : ∀ u ∈ ({cuspInftyBar ℓ, cuspZeroBar ℓ} : Finset (Place 𝕂 (modularFunctionFieldBar ℓ))),
+      u.restrict (RatFunc 𝕂) = (cuspInftyBar ℓ).restrict (RatFunc 𝕂) := by
+    intro u hu
+    simp only [Finset.mem_insert, Finset.mem_singleton] at hu
+    rcases hu with rfl | rfl
+    · rfl
+    · exact r0
+  have hsum := Place.sum_ramificationIndex_mul_inertiaDeg_le_finrank _ _ hS
+  rw [Finset.sum_insert (by simp [hne.symm]), Finset.sum_singleton] at hsum
+  have e1 := (e_infty ℓ).1
+  have e0 := e_zero ℓ hw
+  have f1 : (1 : ℤ) ≤ (cuspInftyBar ℓ).inertiaDeg (RatFunc 𝕂) := by
+    exact_mod_cast Place.inertiaDeg_pos (F := RatFunc 𝕂) (cuspInftyBar ℓ)
+  have f0 : (1 : ℤ) ≤ (cuspZeroBar ℓ).inertiaDeg (RatFunc 𝕂) := by
+    exact_mod_cast Place.inertiaDeg_pos (F := RatFunc 𝕂) (cuspZeroBar ℓ)
+  have p0 : (ℓ : ℤ) ≤ ((cuspZeroBar ℓ).ramificationIndex (RatFunc 𝕂) : ℤ) *
+      ((cuspZeroBar ℓ).inertiaDeg (RatFunc 𝕂) : ℤ) := by
+    rw [e0]; nlinarith
+  rw [e1, one_mul] at hsum
+  have : ((ℓ + 1 : ℕ) : ℤ) ≤ (Module.finrank (RatFunc 𝕂) (modularFunctionFieldBar ℓ) : ℤ) := by
+    push_cast; linarith
+  exact_mod_cast this
+
+theorem finrank_tower_eq : Module.finrank (𝕂⟮jqModC 𝕂⟯) (𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯) =
+    Module.finrank (RatFunc 𝕂) (modularFunctionFieldBar ℓ) :=
+  Algebra.finrank_eq_of_equiv_equiv (σa.symm.toRingEquiv : 𝕂⟮jqModC 𝕂⟯ ≃+* RatFunc 𝕂) (jTr ℓ)
+    (he_compat ℓ)
+
+end DegAux
+
+open DegAux in
+theorem solution (ℓ : ℕ) [Fact ℓ.Prime] :
+    Module.finrank (IntermediateField.adjoin (AlgebraicClosure ℚ) ({jqModC (AlgebraicClosure ℚ)} :
+      Set (LaurentSeries (AlgebraicClosure ℚ)))) (IntermediateField.adjoin (IntermediateField.adjoin
+      (AlgebraicClosure ℚ) ({jqModC (AlgebraicClosure ℚ)} : Set (LaurentSeries (AlgebraicClosure
+      ℚ)))) ({jqNModC (AlgebraicClosure ℚ) ℓ} : Set (LaurentSeries (AlgebraicClosure ℚ)))) = ℓ + 1
+      := by
+  apply le_antisymm
+  · have hℓ : ℓ.Prime := Fact.out
+    obtain ⟨data⟩ := nonempty_modularPolynomialData_of_squarefree ℓ hℓ.squarefree hℓ.one_lt
+    simpa [DegAux.dedekindPsi_prime ℓ] using finrank_adjoin_jqNModC_le (AlgebraicClosure ℚ) data
+  · have h := DegAux.le_finrank ℓ
+    rw [← DegAux.finrank_tower_eq ℓ] at h
+    exact h
+
+end
+end S_ModularCurve_finrank_adjoin_jqNModC_eq_of_prime
+end P2MW
+export P2MW.S_ModularCurve_finrank_adjoin_jqNModC_eq_of_prime (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.finrank_adjoin_jqNModC_eq_of_prime (ℓ : ℕ) [Fact ℓ.Prime] :
+    Module.finrank (IntermediateField.adjoin (AlgebraicClosure ℚ) ({jqModC (AlgebraicClosure ℚ)} :
+      Set (LaurentSeries (AlgebraicClosure ℚ)))) (IntermediateField.adjoin (IntermediateField.adjoin
+      (AlgebraicClosure ℚ) ({jqModC (AlgebraicClosure ℚ)} : Set (LaurentSeries (AlgebraicClosure
+      ℚ)))) ({jqNModC (AlgebraicClosure ℚ) ℓ} : Set (LaurentSeries (AlgebraicClosure ℚ)))) = ℓ + 1
+      :=
+  solution ℓ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqNModC_le.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqNModC_le.lean
new file mode 100644
index 0000000000..ea14a6b118
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqNModC_le.lean
@@ -0,0 +1,205 @@
+/-
+Based on Prove2Me node ModularCurve.finrank_adjoin_jqNModC_le
+(d940315e-95eb-54d9-9321-fd3a6ae7fd67) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6fc43d69-badd-5fd4-88bf-28fb58a070c6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_injective
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree bound ψ(N) for K(j)(j(q^N)) over K(j)
+
+Theorem statement: `ModularCurve.finrank_adjoin_jqNModC_le`
+(`d940315e-95eb-54d9-9321-fd3a6ae7fd67`), by Claude, 2026-09-05.
+
+Proof: submission `6fc43d69-badd-5fd4-88bf-28fb58a070c6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $N$ be a nonzero natural number. Inside the field of Laurent series
+$K((q))$ consider the two elements $j =$ `jqModC K`, namely $q^{-1}$ times the image in $K$ of the
+integral power series `jNum` $= E_4^3\cdot$`dedekindEtaUnitInv`, and $j_N =$ `jqNModC K N`, the
+image of $j$ under the ring homomorphism `qExpand K N` which multiplies all Hahn-series exponents by
+$N$ (substitution $q \mapsto q^N$). Assume given a term `data` of the structure
+`ModularPolynomialData N`, that is, a polynomial $\Phi \in (\mathbb{Z}[X])[Y]$ which is monic in
+$Y$, has $Y$-degree equal to $\psi(N) = \sum_{d \mid N,\ d \text{ squarefree}} N/d$, and satisfies
+$\Phi = 0$ after evaluating its coefficients by `evalAtJ` (the $\mathbb{Z}$-algebra map
+$\mathbb{Z}[X] \to \mathbb{Q}((q))$ sending $X$ to the rational $q$-expansion of $j$) and
+substituting $Y \mapsto$ `jqN N`. The conclusion is the inequality $$[E(j_N) : E] \le \psi(N),$$
+where $E = K(j)$ is the intermediate field of $K((q))$ generated over $K$ by $j$ and $E(j_N)$ is the
+intermediate field of $K((q))$ generated over $E$ by $j_N$, the left-hand side being
+`Module.finrank`.
+
+This is the upper bound $[K(j)(j(q^N)) : K(j)] \le \psi(N)$ for the modular function field of
+$X_0(N)$ over an arbitrary field $K$, obtained from a modular polynomial packet by specialisation of
+coefficients; no irreducibility of $\Phi$ and no hypothesis on the characteristic of $K$ enter.
+Since `Module.finrank` vanishes for infinite-dimensional extensions, the inequality is read together
+with the companion statement
+[`ModularCurve.finiteDimensional_adjoin_jqNModC`]
+(thm.html#ModularCurve.finiteDimensional_adjoin_jqNModC);
+both feed the analysis of the function field of $X_0(N)$ and of its cusps, e.g.
+[`ModularCurve.coeffMap_mem_modularFunctionFieldC`]
+(thm.html#ModularCurve.coeffMap_mem_modularFunctionFieldC)
+and the uniqueness statements for the places at the cusps.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finrank_adjoin_jqNModC_le.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_finrank_adjoin_jqNModC_le
+
+noncomputable section
+
+open Polynomial IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqN dedekindPsi evalAtJ evalAtJ_X ModularPolynomialData coeffMap jqModC \
+  jqNModC jqModC_rat map_jqModC coeffMap_qExpand coeffMap_injective"
+p2m_open "ModularCurve"
+
+section Transport
+
+variable (R : Type*) [CommRing R] (N : ℕ) [NeZero N]
+
+private def phiAt (Φ : Polynomial (Polynomial ℤ)) : LaurentSeries R :=
+  Φ.eval₂ (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries R)) (jqModC R)) (jqNModC R N)
+
+private theorem coeffMap_eq_map {S : Type*} [CommRing S] (f : R →+* S) (x : LaurentSeries R) :
+    coeffMap f x = x.map f := rfl
+
+private theorem coeffMap_phiAt {S : Type*} [CommRing S] (f : R →+* S)
+    (Φ : Polynomial (Polynomial ℤ)) :
+    coeffMap f (phiAt R N Φ) = phiAt S N Φ := by
+  unfold phiAt
+  rw [Polynomial.hom_eval₂]
+  have hj : coeffMap f (jqModC R) = jqModC S := by rw [coeffMap_eq_map, map_jqModC]
+  have hjN : coeffMap f (jqNModC R N) = jqNModC S N := by
+    rw [jqNModC, jqNModC, coeffMap_qExpand, hj]
+  rw [hjN]
+  congr 1
+  refine Polynomial.ringHom_ext (fun a => ?_) ?_
+  · simp
+  · simp [hj]
+
+end Transport
+
+section OverQ
+
+variable (N : ℕ) [NeZero N]
+
+private theorem phiAt_rat (Φ : Polynomial (Polynomial ℤ)) :
+    phiAt ℚ N Φ = Φ.eval₂ evalAtJ (jqN N) := by
+  unfold phiAt
+  have hN : jqNModC ℚ N = jqN N := rfl
+  rw [hN]
+  congr 1
+  refine Polynomial.ringHom_ext (fun a => ?_) ?_
+  · simp [evalAtJ]
+  · rw [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X, evalAtJ_X, jqModC_rat]
+
+private theorem phiAt_eq_zero (K : Type*) [Field K] (data : ModularPolynomialData N) :
+    phiAt K N data.Φ = 0 := by
+  have hZ : phiAt ℤ N data.Φ = 0 := by
+    apply coeffMap_injective (f := Int.castRingHom ℚ) (RingHom.injective_int (Int.castRingHom ℚ))
+    rw [coeffMap_phiAt, map_zero, phiAt_rat, data.eval_eq_zero]
+  rw [← coeffMap_phiAt ℤ N (Int.castRingHom K), hZ, map_zero]
+
+end OverQ
+
+section Degree
+
+variable (K : Type*) [Field K] {N : ℕ} [NeZero N]
+
+private def phiOver (Φ : Polynomial (Polynomial ℤ)) :
+    Polynomial (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) :=
+  Φ.map (Polynomial.eval₂RingHom (Int.castRingHom _)
+    (⟨jqModC K, IntermediateField.subset_adjoin K _ (Set.mem_singleton _)⟩ :
+      IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))))
+
+private theorem aeval_phiOver (Φ : Polynomial (Polynomial ℤ)) :
+    Polynomial.aeval (jqNModC K N) (phiOver K Φ) = phiAt K N Φ := by
+  rw [Polynomial.aeval_def, phiOver, Polynomial.eval₂_map]
+  unfold phiAt
+  congr 1
+  refine Polynomial.ringHom_ext (fun a => ?_) ?_
+  · simp
+  · simp only [RingHom.coe_comp, Function.comp_apply, Polynomial.coe_eval₂RingHom,
+      Polynomial.eval₂_X]
+    rfl
+
+private theorem finrank_adjoin_jqNModC_le (data : ModularPolynomialData N) :
+    Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+        ({jqNModC K N} : Set (LaurentSeries K))) ≤ dedekindPsi N := by
+  set E := IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))
+  have hmonic : (phiOver K data.Φ).Monic := data.monic.map _
+  have hroot : Polynomial.aeval (jqNModC K N) (phiOver K data.Φ) = 0 := by
+    rw [aeval_phiOver, phiAt_eq_zero]
+  have hint : IsIntegral E (jqNModC K N) :=
+    ⟨phiOver K data.Φ, hmonic, by rwa [← Polynomial.aeval_def]⟩
+  rw [IntermediateField.adjoin.finrank hint, ← data.natDegree_eq, ← (data.monic.natDegree_map _ :
+    (phiOver K data.Φ).natDegree = _)]
+  exact Polynomial.natDegree_le_of_dvd (minpoly.dvd E _ hroot) hmonic.ne_zero
+
+theorem finiteDimensional_adjoin_jqNModC (data : ModularPolynomialData N) :
+    FiniteDimensional (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+        ({jqNModC K N} : Set (LaurentSeries K))) := by
+  have hmonic : (phiOver K data.Φ).Monic := data.monic.map _
+  have hroot : Polynomial.aeval (jqNModC K N) (phiOver K data.Φ) = 0 := by
+    rw [aeval_phiOver, phiAt_eq_zero]
+  exact IntermediateField.adjoin.finiteDimensional ⟨phiOver K data.Φ, hmonic, by rwa [←
+    Polynomial.aeval_def]⟩
+
+end Degree
+
+end ModularCurve
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_finrank_adjoin_jqNModC_le.ModularCurve in
+theorem solution (K : Type*) [Field K] {N : ℕ} [NeZero N] (data : ModularPolynomialData N) :
+    Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      ({jqNModC K N} : Set (LaurentSeries K))) ≤ dedekindPsi N :=
+  ModularCurve.finrank_adjoin_jqNModC_le K data
+
+end S_ModularCurve_finrank_adjoin_jqNModC_le
+end P2MW
+export P2MW.S_ModularCurve_finrank_adjoin_jqNModC_le (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.finrank_adjoin_jqNModC_le (K : Type*) [Field K] {N : ℕ} [NeZero N]
+    (data : ModularPolynomialData N) :
+    Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      ({jqNModC K N} : Set (LaurentSeries K))) ≤ dedekindPsi N :=
+  solution K data
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqN_eq_dedekindPsi.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqN_eq_dedekindPsi.lean
new file mode 100644
index 0000000000..146623e282
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqN_eq_dedekindPsi.lean
@@ -0,0 +1,817 @@
+/-
+Based on Prove2Me node ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi
+(a2a544d4-cdf3-5f52-85e6-e7cad02bbb85) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission bc1fbb42-5164-5882-8d1d-46474d39ee87
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_minpoly_jqN_map_eq_prod_slots
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqN_prime_not_mem_full
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqN_pow_not_mem_adjoin_full
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_full_eq_adjoin_full_div_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_eq_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqN_div_mem_modularFunctionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularFunctionField_eq_full_of
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_modularFunctionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_mul_of_coprime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime_pow
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_of_finrank_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration_iff_full_eq
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.FieldTheory.Relrank
+import Mathlib.Data.Nat.Factorization.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree of ℚ(j)(j(q^N)) over ℚ(j) is ψ(N)
+
+Theorem statement: `ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi`
+(`a2a544d4-cdf3-5f52-85e6-e7cad02bbb85`), by Claude, 2026-09-05.
+
+Proof: submission `bc1fbb42-5164-5882-8d1d-46474d39ee87`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number. Work inside the field $\mathrm{LaurentSeries}\ \mathbb{Q}$ of
+formal Laurent series over $\mathbb{Q}$, and let `jq` denote the element $q^{-1}\cdot
+\mathrm{jNumQ}$, that is, the Hahn series supported at $-1$ with coefficient $1$ multiplied by the
+image under $\mathbb{Z}\to\mathbb{Q}$ of the integral power series `jNum`; this is the $q$-expansion
+of the modular invariant $j$. For $N$ as above, `jqN N` is the image of `jq` under the ring
+homomorphism `qExpand ℚ N`, which rescales exponents by the injective, order-preserving map
+$g\mapsto Ng$ on $\mathbb{Z}$, i.e. the substitution $q\mapsto q^{N}$. Let
+$F=\mathbb{Q}(\,$`jq`$\,)$ be the intermediate field of $\mathrm{LaurentSeries}\ \mathbb{Q}$
+generated over $\mathbb{Q}$ by `jq`. The assertion is that the $F$-dimension of the intermediate
+field obtained by adjoining `jqN N` to $F$ inside $\mathrm{LaurentSeries}\ \mathbb{Q}$ equals
+`dedekindPsi N`, defined as $\sum_{d\mid N,\ d\ \text{squarefree}} N/d$ (the Dedekind
+$\psi$-function $N\prod_{p\mid N}(1+p^{-1})$). In particular, since $\psi(N)\ge 1$, the extension
+$F(j(q^{N}))/F$ is finite of exactly that degree.
+
+This is the classical statement that the modular equation $\Phi_N(X,Y)$ is irreducible over
+$\mathbb{Q}(j)$ with $\deg_Y\Phi_N=\psi(N)$, equivalently that the function field of $X_0(N)$ has
+degree $\psi(N)$ over $\mathbb{Q}(j)$. It is used in the development of the level-$N$ modular
+function field and its Hecke theory, including the determination of the modular polynomial data at
+all levels and the computations with Hecke divisors on the reductions of the modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finrank_adjoin_jqN_eq_dedekindPsi.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_finrank_adjoin_jqN_eq_dedekindPsi
+
+noncomputable section
+
+p2m_open "ModularCurve~coeffEmb_qExpand \
+  P2MW.S_ModularCurve_finrank_adjoin_jqN_eq_dedekindPsi.ModularCurve ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+
+
+
+
+
+
+
+
+
+
+theorem coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb K (qExpand ℚ n x) = qExpand K n (coeffEmb K x) :=
+  coeffMap_qExpand (algebraMap ℚ K) n x
+
+theorem iota_jqN (N d : ℕ) [NeZero N] [NeZero d] :
+    coeffEmb K (qExpand ℚ N (jqN d)) = TS K (N * d) 1 := by
+  rw [jqN, coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem iota_jq (N : ℕ) [NeZero N] : coeffEmb K (qExpand ℚ N jq) = TS K N 1 := by
+  rw [coeffEmb_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_zero_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    conj p ζ (0 : Fin (p + 1)) = TS K (p * p) 1 := by
+  rw [conj_zero, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_succ_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) (b : Fin p) :
+    conj p ζ b.succ = TS K 1 (ζ ^ (b : ℕ)) := by
+  rw [conj_succ, TS_eq_coeffEmb, qExpand_one_apply]
+
+theorem qTwist_iota_of_pow_eq_one (N : ℕ) [NeZero N] (v : Kˣ) (hv : v ^ N = 1) (x : LaurentSeries ℚ)
+    :
+    qTwist v (coeffEmb K (qExpand ℚ N x)) = coeffEmb K (qExpand ℚ N x) := by
+  rw [coeffEmb_qExpand, qTwist_qExpand]
+  have : v ^ (N : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+omit [Algebra ℚ K] in
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+omit [Algebra ℚ K] in
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+omit [Algebra ℚ K] in
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem phiProd_conj_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    phiProd p (conj p ζ) = (Polynomial.X - Polynomial.C (TS K (p * p) 1)) *
+      ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) := by
+  rw [phiProd, Fin.prod_univ_succ, conj_zero_eq]
+  congr 1
+  rw [← Fin.prod_univ_eq_prod_range (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) p]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [conj_succ_eq]
+
+theorem roots_phiProd_conj (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    (phiProd p (conj p ζ)).roots = TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^
+      b)) := by
+  classical
+  rw [phiProd_conj_eq]
+  have h1 : (Polynomial.X - Polynomial.C (TS K (p * p) 1) : Polynomial (LaurentSeries K)) ≠ 0 :=
+    Polynomial.X_sub_C_ne_zero _
+  have h2 : (∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b)))) ≠ 0 :=
+    Finset.prod_ne_zero_iff.mpr fun b _ => Polynomial.X_sub_C_ne_zero _
+  rw [Polynomial.roots_mul (mul_ne_zero h1 h2), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod,
+    Finset.range_val]
+  have hm : (Multiset.map (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) (Multiset.range
+    p)) =
+      ((Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).map (fun a => Polynomial.X - Polynomial.C
+        a) := by
+    rw [Multiset.map_map]; rfl
+  rw [hm, Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+omit [Algebra ℚ K] in
+theorem roots_phiProd_conj_nodup (p : ℕ) [hp : Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).Nodup := by
+  refine Multiset.nodup_cons.mpr ⟨?_, ?_⟩
+  · intro hmem
+    obtain ⟨b, -, hb⟩ := Multiset.mem_map.mp hmem
+    have := (TS_injective hb).1
+    have h2 := hp.out.two_le
+    nlinarith
+  · refine (Multiset.nodup_range p).map_on fun b hb b' hb' hbb' => ?_
+    rw [Multiset.mem_range] at hb hb'
+    have hu := (TS_injective hbb').2
+    have hζu : IsPrimitiveRoot ζ p := IsPrimitiveRoot.coe_units_iff.mp hζ
+    exact hζu.pow_inj hb hb' hu
+
+theorem exists_isPrimitiveRoot_cyclotomicField (N : ℕ) [NeZero N] :
+    ∃ z : CyclotomicField N ℚ, IsPrimitiveRoot z N := by
+  have : NeZero ((N : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr (NeZero.ne N)⟩
+  have : IsCyclotomicExtension {N} ℚ (CyclotomicField N ℚ) :=
+    CyclotomicField.isCyclotomicExtension N ℚ
+  exact IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField N ℚ) (Set.mem_singleton N)
+    (NeZero.ne N)
+
+def cycUnit (N : ℕ) [NeZero N] : (CyclotomicField N ℚ)ˣ :=
+  ((exists_isPrimitiveRoot_cyclotomicField N).choose_spec.isUnit (NeZero.ne N)).unit
+
+theorem cycUnit_spec (N : ℕ) [NeZero N] :
+    IsPrimitiveRoot ((cycUnit N : (CyclotomicField N ℚ)ˣ) : CyclotomicField N ℚ) N := by
+  rw [cycUnit, IsUnit.unit_spec]
+  exact (exists_isPrimitiveRoot_cyclotomicField N).choose_spec
+
+theorem cycUnit_pow (N : ℕ) [NeZero N] : cycUnit N ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, (cycUnit_spec N).pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem prod_form_ne_zero (N : ℕ) (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e]
+    (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K
+            jq)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+          (Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u,
+    Polynomial.roots_mul (prod_form_ne_zero N ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p)))
+    (coeffEmb K jq))))
+        = ((Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+        (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+        (Multiset.range p).map
+          (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).Nodup := by
+  have hζp : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := isPrimitiveRoot_pow_div hζ hpN
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h := (TS_injective (K := K) (e := e) (e' := p * (p * e))
+      (u := u * ζ ^ (b * (N / p))) (u' := u ^ (p * p))
+      (by simpa only [TS_eq_coeffEmb] using heq)).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e)
+      (u := u * ζ ^ (b * (N / p))) (u' := u * ζ ^ (b' * (N / p)))
+      (by simpa only [TS_eq_coeffEmb] using heq)).2
+    have h2 : ζ ^ (b * (N / p)) = ζ ^ (b' * (N / p)) := mul_left_cancel h
+    have h3 : (ζ ^ (N / p)) ^ b = (ζ ^ (N / p)) ^ b' := by
+      rw [← pow_mul, ← pow_mul, Nat.mul_comm (N / p) b, Nat.mul_comm (N / p) b']
+      exact h2
+    have h4 : ((ζ ^ (N / p) : Kˣ) : K) ^ b = ((ζ ^ (N / p) : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h3]
+    exact hζp.pow_inj hb hb' h4
+
+theorem roots_prime_at_slot_roots_nodup (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots.Nodup := by
+  rw [roots_prime_at_slot N ζ hζ p hpN data e u]
+  exact roots_prime_at_slot_nodup N ζ hζ p hpN e u
+
+theorem isRoot_prime_at_slot_iff (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u]
+    exact prod_form_ne_zero N ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot N ζ hζ p hpN data e u,
+    Multiset.mem_cons, Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+
+
+
+
+theorem phiAtSeed_jq_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) :
+    (phiAtSeed data jq).eval (jqN n) = 0 := by
+  have h := data.eval_eq_zero
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp [evalAtJ_X]
+
+
+theorem phiAtSeed_jqN_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN M)).eval (jqN (M * n)) = 0 := by
+  have h := phiAtSeed_eval_map data jq (jqN n) (qExpand ℚ M) (phiAtSeed_jq_eval n data)
+  rwa [jqN, qExpand_qExpand] at h
+
+theorem phiAtSeed_iota_eval {K : Type*} [Field K] [Algebra ℚ K] (A : ℕ) [NeZero A] (n : ℕ)
+    [NeZero n]
+    (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (coeffEmb K (qExpand ℚ A (jqN M)))).eval (coeffEmb K (qExpand ℚ A (jqN (M *
+      n)))) = 0 :=
+  phiAtSeed_eval_map data _ _ ((coeffEmb K).comp (qExpand ℚ A)) (phiAtSeed_jqN_eval n data M)
+
+end ModularCurve.W1
+
+open scoped IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+section Final
+
+private abbrev Tight (d : ℕ) [NeZero d] : Prop :=
+  Module.finrank ℚ⟮jq⟯ (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN d} : Set (LaurentSeries ℚ))) =
+    dedekindPsi d
+
+private abbrev Gen (d : ℕ) [NeZero d] : Prop := modularFunctionField d = modularFunctionFieldFull d
+
+private abbrev Hall (N : ℕ) : Prop := ∀ d : ℕ, d ∣ N → ∀ [NeZero d], Tight d ∧ Gen d
+
+private theorem jqN_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) : jqN n = jqN m := by
+  subst h; rfl
+
+private theorem full_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) :
+    modularFunctionFieldFull n = modularFunctionFieldFull m := by
+  subst h; rfl
+
+private theorem mff_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) :
+    modularFunctionField n = modularFunctionField m := by
+  subst h; rfl
+
+private theorem qExpand_congr' {R : Type*} [CommRing R] {n m : ℕ} [NeZero n] [NeZero m]
+    (h : n = m) (x : LaurentSeries R) : qExpand R n x = qExpand R m x := by
+  subst h
+  rfl
+
+private theorem dedekindPsi_prime' (p : ℕ) (hp : p.Prime) : dedekindPsi p = p + 1 := by
+  have h := ModularCurve.dedekindPsi_prime_pow p 1 hp one_ne_zero
+  rwa [pow_one, Nat.sub_self, pow_zero] at h
+
+private theorem dedekindPsi_mul_prime_not_dvd {m p : ℕ} (hp : p.Prime) (hpm : ¬ p ∣ m) :
+    dedekindPsi (m * p) = dedekindPsi m * (p + 1) := by
+  have hco : Nat.Coprime m p := ((Nat.Prime.coprime_iff_not_dvd hp).mpr hpm).symm
+  rw [ModularCurve.dedekindPsi_mul_of_coprime m p hco, dedekindPsi_prime' p hp]
+
+private theorem dedekindPsi_mul_prime_dvd {m p : ℕ} (hm : m ≠ 0) (hp : p.Prime)
+    (hpm : p ∣ m) : dedekindPsi (m * p) = dedekindPsi m * p := by
+  obtain ⟨k, u, hpu, hmu⟩ := Nat.exists_eq_pow_mul_and_not_dvd hm p hp.ne_one
+  obtain ⟨k', rfl⟩ : ∃ k', k = k' + 1 := by
+    rcases k with - | k'
+    · exfalso
+      rw [hmu, pow_zero, one_mul] at hpm
+      exact hpu hpm
+    · exact ⟨k', rfl⟩
+  subst hmu
+  have hcou : ∀ j : ℕ, j ≠ 0 → Nat.Coprime (p ^ j) u :=
+    fun j _ => Nat.Coprime.pow_left j ((Nat.Prime.coprime_iff_not_dvd hp).mpr hpu)
+  have h1 : p ^ (k' + 1) * u * p = p ^ (k' + 2) * u := by ring
+  rw [h1, ModularCurve.dedekindPsi_mul_of_coprime _ u (hcou _ (Nat.succ_ne_zero _)),
+    ModularCurve.dedekindPsi_mul_of_coprime _ u (hcou _ (Nat.succ_ne_zero _)),
+    ModularCurve.dedekindPsi_prime_pow p (k' + 2) hp (Nat.succ_ne_zero _),
+    ModularCurve.dedekindPsi_prime_pow p (k' + 1) hp (Nat.succ_ne_zero _)]
+  have h2 : k' + 2 - 1 = k' + 1 := rfl
+  have h3 : k' + 1 - 1 = k' := rfl
+  rw [h2, h3]
+  ring
+
+private theorem tight_one : Tight 1 := by
+  unfold Tight
+  have h1 : jqN 1 = jq := by rw [jqN, qExpand_one_apply]
+  rw [h1, ModularCurve.dedekindPsi_one]
+  have h2 : IntermediateField.adjoin ℚ⟮jq⟯ ({jq} : Set (LaurentSeries ℚ))
+      = (⊥ : IntermediateField ℚ⟮jq⟯ (LaurentSeries ℚ)) := by
+    rw [IntermediateField.adjoin_simple_eq_bot_iff, IntermediateField.mem_bot]
+    exact ⟨jGen, rfl⟩
+  rw [h2]
+  exact IntermediateField.finrank_bot
+
+private theorem gen_one : Gen 1 := by
+  unfold Gen
+  refine le_antisymm (modularFunctionField_le_full 1) ?_
+  rw [modularFunctionFieldFull, IntermediateField.adjoin_le_iff]
+  rintro x ⟨d, hne, hdvd, rfl⟩
+  have := hne
+  have hd1 : d = 1 := Nat.dvd_one.mp hdvd
+  subst hd1
+  rw [qExpand_one_apply]
+  exact jq_mem 1
+
+private theorem relfinrank_full_of (N : ℕ) [NeZero N] (ht : Tight N) (hg : Gen N) :
+    IntermediateField.relfinrank ℚ⟮jq⟯ (modularFunctionFieldFull N) = dedekindPsi N := by
+  unfold Gen at hg
+  unfold Tight at ht
+  rw [← hg, ModularCurve.relfinrank_modularFunctionField N, ht]
+
+private theorem F0_le_full (N : ℕ) [NeZero N] : ℚ⟮jq⟯ ≤ modularFunctionFieldFull N := by
+  rw [IntermediateField.adjoin_le_iff, Set.singleton_subset_iff]
+  have h := jqd_mem_full N (one_dvd N)
+  rw [qExpand_one_apply] at h
+  exact h
+
+private theorem full_le_adjoin_chain (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (hpM : ¬ p ∣ M) : ∀ a : ℕ,
+    modularFunctionFieldFull (M * p ^ a) ≤ IntermediateField.adjoin ℚ
+      ((modularFunctionFieldFull M : Set (LaurentSeries ℚ))
+        ∪ {x : LaurentSeries ℚ | ∃ i : ℕ, i ≤ a ∧ x = jqN (p ^ i)}) := by
+  intro a
+  induction a with
+  | zero =>
+      rw [full_congr (show M * p ^ 0 = M by rw [pow_zero, mul_one])]
+      exact fun x hx => IntermediateField.subset_adjoin ℚ _ (Set.mem_union_left _ hx)
+  | succ k ih =>
+      rw [ModularCurve.full_eq_adjoin_full_div_prime M p k hpM, IntermediateField.adjoin_le_iff,
+        Set.insert_subset_iff]
+      refine ⟨IntermediateField.subset_adjoin ℚ _ (Set.mem_union_right _
+        (show jqN (p ^ (k + 1)) ∈ {x : LaurentSeries ℚ | ∃ i : ℕ, i ≤ k + 1 ∧ x = jqN (p ^ i)} from
+          ⟨k + 1, le_rfl, rfl⟩)), ?_⟩
+      intro x hx
+      have hx' := ih hx
+      refine IntermediateField.adjoin.mono ℚ _ _ (Set.union_subset_union le_rfl ?_) hx'
+      intro y hy
+      obtain ⟨i, hi, hy⟩ := hy
+      exact ⟨i, Nat.le_succ_of_le hi, hy⟩
+
+private theorem jqN_pow_not_mem_full (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (hpM : ¬ p ∣ M) (hallM : Hall M) (a : ℕ) :
+    jqN (p ^ (a + 1)) ∉ modularFunctionFieldFull (M * p ^ a) := by
+  have h0 : jqN p ∉ modularFunctionFieldFull M :=
+    ModularCurve.jqN_prime_not_mem_full M p hpM (fun d hd _ => hallM d hd)
+  rcases a with - | k
+  · rw [jqN_congr (show p ^ (0 + 1) = p by rw [zero_add, pow_one]),
+      full_congr (show M * p ^ 0 = M by rw [pow_zero, mul_one])]
+    exact h0
+  · intro hmem
+    have h1 := ModularCurve.jqN_pow_not_mem_adjoin_full M p k h0
+    exact h1 (full_le_adjoin_chain M p hpM (k + 1) hmem)
+
+section Shapes
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem root_shape (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) M) (hallM : Hall M) (y : LaurentSeries K)
+    (hy : Polynomial.eval y ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M *
+      p))).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))) = 0) :
+    ∃ a : ℕ, ∃ _ : NeZero a, a ∣ M ∧ ∃ b : ℕ, b < M / a ∧ y = TS K (p * (a * a)) (ζ ^ (b * a)) := by
+  have hid := ModularCurve.minpoly_jqN_map_eq_prod_slots (K := K) M ζ hζ (fun d hd _ => hallM d hd)
+  have hcomp : (qExpand K p).comp (((coeffEmb K).comp (qExpand ℚ M)).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))
+      = ((coeffEmb K).comp (qExpand ℚ (M * p))).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) := by
+    refine RingHom.ext fun z => ?_
+    simp only [RingHom.comp_apply]
+    rw [coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand]
+    exact qExpand_congr' (mul_comm p M) _
+  rw [← hcomp, ← Polynomial.map_map, hid, Polynomial.eval_map, Polynomial.eval₂_finsetProd] at hy
+  obtain ⟨a, ha, hy⟩ := Finset.prod_eq_zero_iff.mp hy
+  rw [Polynomial.eval₂_finsetProd] at hy
+  obtain ⟨b, hb, hy⟩ := Finset.prod_eq_zero_iff.mp hy
+  rw [Polynomial.eval₂_sub, Polynomial.eval₂_X, Polynomial.eval₂_C, sub_eq_zero] at hy
+  have ha0 : a ≠ 0 := Nat.ne_of_gt (Nat.pos_of_mem_divisors ha)
+  rw [dite_eq_right ha0] at hy
+  have : NeZero a := ⟨ha0⟩
+  refine ⟨a, ⟨ha0⟩, Nat.dvd_of_mem_divisors ha, b, (Finset.mem_range.mp (Finset.mem_filter.mp
+    hb).1), ?_⟩
+  rw [hy]
+  rw [← TS_eq_coeffEmb, qExpand_TS]
+
+private theorem htw_of (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) M) (hallM : Hall M) (y : LaurentSeries K)
+    (hy : Polynomial.eval y ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M *
+      p))).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))) = 0)
+    (w : Kˣ) (hw : y = qExpand K (M * p * M) (qTwist w (coeffEmb K jq))) : w = 1 := by
+  obtain ⟨a, _, haM, b, hb, rfl⟩ := root_shape M p ζ hζ hallM y hy
+  rw [← TS_eq_coeffEmb] at hw
+  obtain ⟨he, hu⟩ := TS_injective hw
+  have haM' : a = M := by
+    have h2 : a * a = M * M := by
+      have hp0 : 0 < p := hp.out.pos
+      have : p * (a * a) = p * (M * M) := by rw [he]; ring
+      exact Nat.eq_of_mul_eq_mul_left hp0 this
+    exact Nat.mul_self_inj.mp h2
+  subst haM'
+  have hb0 : b = 0 := by
+    rw [Nat.div_self (Nat.pos_of_ne_zero (NeZero.ne a))] at hb
+    omega
+  subst hb0
+  rw [zero_mul, pow_zero] at hu
+  exact hu.symm
+
+private theorem hsp_of (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) M) (hallM : Hall M) (y : LaurentSeries K)
+    (hy : Polynomial.eval y ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M *
+      p))).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))) = 0) :
+    y ≠ coeffEmb K (qExpand ℚ (M * p) (jqN (M * p * p))) := by
+  obtain ⟨a, _, haM, b, _, rfl⟩ := root_shape M p ζ hζ hallM y hy
+  rw [iota_jqN]
+  intro h
+  obtain ⟨he, _⟩ := TS_injective h
+  have hp2 : 2 ≤ p := hp.out.two_le
+  have hM : 0 < M := Nat.pos_of_ne_zero (NeZero.ne M)
+  have ha : a ≤ M := Nat.le_of_dvd hM haM
+  have h1 : a * a = (M * p) * (M * p) := by
+    have : p * (a * a) = p * ((M * p) * (M * p)) := by rw [he]; ring
+    exact Nat.eq_of_mul_eq_mul_left hp.out.pos this
+  have h2 : a = M * p := Nat.mul_self_inj.mp h1
+  have : M * p ≤ M := h2 ▸ ha
+  have : M * 2 ≤ M * p := Nat.mul_le_mul_left M hp2
+  omega
+
+end Shapes
+
+private theorem hall_all : ∀ N : ℕ, N ≠ 0 → Hall N := by
+  intro N
+  induction N using Nat.strong_induction_on with
+  | _ N ih =>
+  intro hN d hdN hd
+  by_cases hdlt : d < N
+  · exact ih d hdlt (NeZero.ne d) d dvd_rfl
+  have hdN' : d = N := le_antisymm (Nat.le_of_dvd (Nat.pos_of_ne_zero hN) hdN) (not_lt.mp hdlt)
+  subst hdN'
+  have hprop : ∀ m : ℕ, m ∣ d → m < d → Hall m := fun m _ hlt => ih m hlt (by
+    rintro rfl; exact absurd hlt (by have := Nat.pos_of_ne_zero hN; omega))
+  by_cases h1 : d = 1
+  · subst h1; exact ⟨tight_one, gen_one⟩
+  have hgen : Gen d := by
+    unfold Gen
+    refine ModularCurve.modularFunctionField_eq_full_of d ?_ ?_
+    · intro M _ p hp hMp
+      have : Fact (Nat.Prime p) := ⟨hp⟩
+      have hMlt : M < d := by
+        rw [← hMp]; exact lt_mul_of_one_lt_right (Nat.pos_of_ne_zero (NeZero.ne M)) hp.one_lt
+      have hallM : Hall M := hprop M ⟨p, hMp.symm⟩ hMlt
+      have hmem :=
+        ModularCurve.jqN_div_mem_modularFunctionField M p (K := CyclotomicField (M * p) ℚ)
+        (cycUnit (M * p)) (cycUnit_spec (M * p))
+        (fun y hy w hw => htw_of M p (cycUnit (M * p) ^ (M * p / M))
+          (isPrimitiveRoot_pow_div (cycUnit_spec (M * p)) ⟨p, rfl⟩) hallM y hy w hw)
+        (fun y hy => hsp_of M p (cycUnit (M * p) ^ (M * p / M))
+          (isPrimitiveRoot_pow_div (cycUnit_spec (M * p)) ⟨p, rfl⟩) hallM y hy)
+      rw [mff_congr hMp] at hmem
+      exact hmem
+    · intro M _ p hp hMp
+      have hMlt : M < d := by
+        rw [← hMp]; exact lt_mul_of_one_lt_right (Nat.pos_of_ne_zero (NeZero.ne M)) hp.one_lt
+      exact (hprop M ⟨p, hMp.symm⟩ hMlt M dvd_rfl).2
+  refine ⟨?_, hgen⟩
+  unfold Tight
+  set p := d.minFac with hpdef
+  have hp : p.Prime := Nat.minFac_prime h1
+  have : Fact (Nat.Prime p) := ⟨hp⟩
+  obtain ⟨k, M, hpM, hdM⟩ := Nat.exists_eq_pow_mul_and_not_dvd hN p hp.ne_one
+  have hM0 : M ≠ 0 := by rintro rfl; rw [mul_zero] at hdM; exact hN hdM
+  have : NeZero M := ⟨hM0⟩
+  obtain ⟨a, rfl⟩ : ∃ a, k = a + 1 := by
+    rcases k with - | a
+    · exfalso
+      have : p ∣ d := Nat.minFac_dvd d
+      rw [hdM, pow_zero, one_mul] at this
+      exact hpM this
+    · exact ⟨a, rfl⟩
+  have hdM' : d = M * p ^ (a + 1) := by rw [hdM, mul_comm]
+  have hlow_dvd : M * p ^ a ∣ d := ⟨p, by rw [hdM', pow_succ, mul_assoc]⟩
+  have hlow_lt : M * p ^ a < d := by
+    rw [hdM', pow_succ, ← mul_assoc]
+    exact lt_mul_of_one_lt_right (Nat.pos_of_ne_zero (mul_ne_zero hM0 (pow_ne_zero _ hp.ne_zero)))
+      hp.one_lt
+  have hall_low : Hall (M * p ^ a) := hprop _ hlow_dvd hlow_lt
+  have hallM : Hall M := fun e he _ => hall_low e (he.trans ⟨p ^ a, rfl⟩)
+  have hlowdeg : IntermediateField.relfinrank ℚ⟮jq⟯ (modularFunctionFieldFull (M * p ^ a))
+      = dedekindPsi (M * p ^ a) := by
+    have h := hall_low (M * p ^ a) dvd_rfl
+    exact relfinrank_full_of _ h.1 h.2
+  have hstep := ModularCurve.relfinrank_full_eq_mul M p a
+    (ModularCurve.full_eq_adjoin_full_div_prime M p a hpM) (jqN_pow_not_mem_full M p hpM hallM a)
+  have htower := IntermediateField.relfinrank_mul_relfinrank (F0_le_full (M * p ^ a))
+    (full_degeneracy_le (N := M * p ^ a) (M := M * p ^ (a + 1)) ⟨p, by rw [pow_succ, mul_assoc]⟩)
+  rw [← ModularCurve.relfinrank_modularFunctionField d]
+  unfold Gen at hgen
+  rw [hgen, full_congr hdM', ← htower, hlowdeg, hstep]
+  have hpsi : dedekindPsi d = dedekindPsi (M * p ^ a) * (if a = 0 then p + 1 else p) := by
+    rw [hdM']
+    split_ifs with ha
+    · subst ha
+      rw [pow_zero, mul_one, zero_add, pow_one]
+      exact dedekindPsi_mul_prime_not_dvd hp hpM
+    · have h2 : M * p ^ (a + 1) = M * p ^ a * p := by rw [pow_succ, mul_assoc]
+      rw [h2]
+      refine dedekindPsi_mul_prime_dvd (mul_ne_zero hM0 (pow_ne_zero _ hp.ne_zero)) hp ⟨M * p ^ (a -
+        1), ?_⟩
+      obtain ⟨a', rfl⟩ := Nat.exists_eq_succ_of_ne_zero ha
+      rw [Nat.succ_sub_one, pow_succ]; ring
+  rw [hpsi]
+
+end Final
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi (N : ℕ) [NeZero N] :
+    Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+        ({jqN N} : Set (LaurentSeries ℚ))) = dedekindPsi N :=
+  (ModularCurve.W1.hall_all N (NeZero.ne N) N dvd_rfl).1
+
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.modularFunctionField_eq_full (N : ℕ) [NeZero N] :
+    modularFunctionField N = modularFunctionFieldFull N :=
+  (ModularCurve.W1.hall_all N (NeZero.ne N) N dvd_rfl).2
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.functionFieldGeneration (N : ℕ) [NeZero N] :
+    FunctionFieldGeneration N :=
+  (ModularCurve.functionFieldGeneration_iff_full_eq N).mpr
+    (ModularCurve.modularFunctionField_eq_full N).symm
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.exists_phiIrreducible (N : ℕ) [NeZero N] :
+    ∃ data : ModularPolynomialData N, PhiIrreducible data :=
+  ModularCurve.exists_phiIrreducible_of_finrank_eq N (ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi
+    N)
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.relfinrank_full_eq_dedekindPsi (N : ℕ) [NeZero N] :
+    IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (modularFunctionFieldFull N) = dedekindPsi N := by
+  rw [← ModularCurve.modularFunctionField_eq_full N, ModularCurve.relfinrank_modularFunctionField N]
+  exact ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi N
+
+end
+
+p2m_open "ModularCurve~coeffEmb_qExpand\
+  " in
+open _root_.P2MW.S_ModularCurve_finrank_adjoin_jqN_eq_dedekindPsi.ModularCurve in
+theorem solution (N : ℕ) [NeZero N] :
+    Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) ({jqN N}
+      : Set (LaurentSeries ℚ))) = dedekindPsi N :=
+  ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi N
+
+end S_ModularCurve_finrank_adjoin_jqN_eq_dedekindPsi
+end P2MW
+export P2MW.S_ModularCurve_finrank_adjoin_jqN_eq_dedekindPsi (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi (N : ℕ) [NeZero N] :
+    Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) ({jqN N}
+      : Set (LaurentSeries ℚ))) = dedekindPsi N :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqN_eq_of_prime.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqN_eq_of_prime.lean
new file mode 100644
index 0000000000..a84be1eafd
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqN_eq_of_prime.lean
@@ -0,0 +1,133 @@
+/-
+Based on Prove2Me node ModularCurve.finrank_adjoin_jqN_eq_of_prime
+(84c5c5ad-28b6-53a0-a4d2-ce13b65bf109) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a94f03ef-1f7f-5dc3-8145-9941af50c335
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree ℓ+1 of ℚ(j)(j(q^ℓ)) over ℚ(j)
+
+Theorem statement: `ModularCurve.finrank_adjoin_jqN_eq_of_prime`
+(`84c5c5ad-28b6-53a0-a4d2-ce13b65bf109`), by Claude, 2026-09-05.
+
+Proof: submission `a94f03ef-1f7f-5dc3-8145-9941af50c335`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Work inside the field $\mathbb{Q}((q))$ of Laurent series over $\mathbb{Q}$ (formalised as
+`LaurentSeries ℚ`, Hahn series with integer exponents). Let `jq` be the element $q^{-1}\cdot
+\mathrm{jNumQ}(q)$, the product of the monomial $q^{-1}$ with the Laurent series attached to the
+power series `jNumQ`, obtained from the integral power series `jNum` by the coefficient map
+$\mathbb{Z}\to\mathbb{Q}$; this is the $q$-expansion of the modular invariant $j$. For $N\ge 1$,
+`qExpand ℚ N` is the ring endomorphism of $\mathbb{Q}((q))$ that substitutes $q\mapsto q^{N}$,
+realised as the embedding of Hahn-series domains along multiplication by $N$ on the exponent group
+$\mathbb{Z}$, and `jqN N` is its value at `jq`, i.e. $j(q^{N})$. The theorem asserts: for every
+prime $\ell$, the intermediate field $\mathbb{Q}\langle jq\rangle$ of
+$\mathbb{Q}\subseteq\mathbb{Q}((q))$ generated by `jq` over $\mathbb{Q}$, and the intermediate field
+generated over it by $j(q^{\ell})$ inside $\mathbb{Q}((q))$, satisfy $$[\mathbb{Q}\langle
+jq\rangle\langle jq_{\ell}\rangle:\mathbb{Q}\langle jq\rangle]=\ell+1$$ as a `Module.finrank`. There
+are no hypotheses beyond the primality of $\ell$.
+
+This is the classical degree computation for the modular equation of prime level: the modular
+polynomial $\Phi_\ell(X,Y)$ has $Y$-degree $\psi(\ell)=\ell+1$, and $j(q^{\ell})$ generates an
+extension of that degree over $\mathbb{Q}(j)$, here carried out entirely with $q$-expansions in
+$\mathbb{Q}((q))$. It feeds the level-$\ell$ facts used downstream, among them the uniqueness
+statement
+[`ModularCurve.ModularPolynomialData.eq_of_prime`]
+(thm.html#ModularCurve.ModularPolynomialData.eq_of_prime),
+the squarefree-level degree formula
+[`ModularCurve.finrank_adjoin_jqN_eq_of_squarefree`]
+(thm.html#ModularCurve.finrank_adjoin_jqN_eq_of_squarefree),
+and [`ModularCurve.jqN_prime_not_mem_adjoin`](thm.html#ModularCurve.jqN_prime_not_mem_adjoin).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finrank_adjoin_jqN_eq_of_prime.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_finrank_adjoin_jqN_eq_of_prime
+
+noncomputable section
+
+open Polynomial IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jq jqN dedekindPsi ModularPolynomialData algebraMap_comp_evalAtJGen \
+  ModularPolynomialData.toAdjoin PhiIrreducible exists_phiIrreducible_evalSymm dedekindPsi_prime"
+p2m_open "ModularCurve"
+
+variable {N : ℕ} [NeZero N]
+
+theorem aeval_jqN_toAdjoin (data : ModularPolynomialData N) :
+    Polynomial.aeval (jqN N) data.toAdjoin = 0 := by
+  rw [ModularPolynomialData.toAdjoin, Polynomial.aeval_def, Polynomial.eval₂_map,
+    algebraMap_comp_evalAtJGen]
+  exact data.eval_eq_zero
+
+theorem minpoly_jqN_eq_toAdjoin (data : ModularPolynomialData N) (h : PhiIrreducible data) :
+    minpoly ℚ⟮jq⟯ (jqN N) = data.toAdjoin :=
+  (minpoly.eq_of_irreducible_of_monic h (aeval_jqN_toAdjoin data) data.toAdjoin_monic).symm
+
+theorem finrank_adjoin_jqN_eq (data : ModularPolynomialData N) (h : PhiIrreducible data) :
+    Module.finrank ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN N⟯ = dedekindPsi N := by
+  have hint : IsIntegral ℚ⟮jq⟯ (jqN N) := ⟨data.toAdjoin, data.toAdjoin_monic, by
+    rw [← Polynomial.aeval_def]; exact aeval_jqN_toAdjoin data⟩
+  rw [IntermediateField.adjoin.finrank hint, minpoly_jqN_eq_toAdjoin data h,
+    ModularPolynomialData.toAdjoin,
+    data.monic.natDegree_map, data.natDegree_eq]
+
+private theorem finrank_adjoin_jqN_eq_of_prime (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] :
+    Module.finrank ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN ℓ⟯ = ℓ + 1 := by
+  obtain ⟨data, hirr, -⟩ := exists_phiIrreducible_evalSymm ℓ
+  rw [finrank_adjoin_jqN_eq data hirr, dedekindPsi_prime hℓ.out]
+
+end ModularCurve
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_finrank_adjoin_jqN_eq_of_prime.ModularCurve
+  ModularCurve.PhiGen in
+theorem solution (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] :
+    Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) ({jqN ℓ}
+      : Set (LaurentSeries ℚ))) = ℓ + 1 :=
+  ModularCurve.finrank_adjoin_jqN_eq_of_prime ℓ
+
+end S_ModularCurve_finrank_adjoin_jqN_eq_of_prime
+end P2MW
+export P2MW.S_ModularCurve_finrank_adjoin_jqN_eq_of_prime (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.finrank_adjoin_jqN_eq_of_prime (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] :
+    Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) ({jqN ℓ}
+      : Set (LaurentSeries ℚ))) = ℓ + 1 :=
+  solution ℓ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqN_eq_of_squarefree.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqN_eq_of_squarefree.lean
new file mode 100644
index 0000000000..4b53422a30
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqN_eq_of_squarefree.lean
@@ -0,0 +1,937 @@
+/-
+Based on Prove2Me node ModularCurve.finrank_adjoin_jqN_eq_of_squarefree
+(1100f59a-254e-5df0-8408-1a35288cfc17) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4aea15e1-b601-5c8e-874b-994c8036d00a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_full_eq_adjoin_primes
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_of_squarefree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqN_eq_of_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_of_squarefree
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.RingTheory.Coprime.Lemmas
+import Mathlib.Data.Nat.ModEq
+import Mathlib.FieldTheory.PrimitiveElement
+import Mathlib.FieldTheory.Relrank
+import Mathlib.Data.Nat.Factorization.Induction
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Relative degree [ℚ(j)(j_N):ℚ(j)]=ψ(N) at squarefree level
+
+Theorem statement: `ModularCurve.finrank_adjoin_jqN_eq_of_squarefree`
+(`1100f59a-254e-5df0-8408-1a35288cfc17`), by Claude, 2026-09-05.
+
+Proof: submission `4aea15e1-b601-5c8e-874b-994c8036d00a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number which is squarefree. Work inside the field of Laurent series
+$\mathrm{LaurentSeries}\ \mathbb{Q}=\mathbb{Q}((q))$ (Hahn series over $\mathbb{Q}$ with integer
+exponents). Here `jq` is the element $q^{-1}$ times the image in $\mathbb{Q}((q))$ of the power
+series `jNum` under the coefficient map $\mathbb{Z}\to\mathbb{Q}$, i.e. the formal $q$-expansion of
+the modular invariant $j$, and `jqN N` is its image under `qExpand ℚ N`, the ring homomorphism of
+$\mathbb{Q}((q))$ that multiplies all exponents by $N$, that is the substitution $q\mapsto q^{N}$
+giving $j(q^{N})$. Let $K=\mathbb{Q}(\mathtt{jq})$ be the intermediate field of
+$\mathbb{Q}((q))/\mathbb{Q}$ generated by `jq`, and let $L$ be the intermediate field of
+$\mathbb{Q}((q))/K$ generated over $K$ by `jqN N`. The assertion is that the $K$-dimension of $L$
+equals `dedekindPsi N`, defined as $\sum_{d\mid N,\ d\ \text{squarefree}} N/d$; for squarefree $N$
+this is the usual $\psi(N)=\prod_{p\mid N}(p+1)$. In particular the dimension is finite.
+
+This is the statement that the modular equation of squarefree level $N$ has degree $\psi(N)$ over
+$\mathbb{Q}(j)$, equivalently that the modular polynomial $\Phi_N(X,Y)$ is irreducible over
+$\mathbb{Q}(j)$, formulated for the formal $q$-expansion model of the function field of $X_0(N)$
+inside $\mathbb{Q}((q))$. It is used by
+[`ModularCurve.functionFieldGeneration_of_squarefree`]
+(thm.html#ModularCurve.functionFieldGeneration_of_squarefree),
+which identifies that function field as $\mathbb{Q}(j,j_N)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finrank_adjoin_jqN_eq_of_squarefree.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_finrank_adjoin_jqN_eq_of_squarefree
+
+noncomputable section
+
+p2m_open "ModularCurve~coeffEmb_qExpand \
+  P2MW.S_ModularCurve_finrank_adjoin_jqN_eq_of_squarefree.ModularCurve ModularCurve.PhiGen"
+open scoped IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData jGen modularFunctionFieldFull jqd_mem_full coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot full_eq_adjoin_primes relfinrank_full_of_squarefree \
+  finrank_adjoin_jqN_eq_of_prime dedekindPsi_prime exists_phiIrreducible_evalSymm \
+  dedekindPsi_of_squarefree"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+
+
+
+
+
+
+
+
+
+
+theorem coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb K (qExpand ℚ n x) = qExpand K n (coeffEmb K x) :=
+  coeffMap_qExpand (algebraMap ℚ K) n x
+
+theorem iota_jqN (N d : ℕ) [NeZero N] [NeZero d] :
+    coeffEmb K (qExpand ℚ N (jqN d)) = TS K (N * d) 1 := by
+  rw [jqN, coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem iota_jq (N : ℕ) [NeZero N] : coeffEmb K (qExpand ℚ N jq) = TS K N 1 := by
+  rw [coeffEmb_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_zero_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    conj p ζ (0 : Fin (p + 1)) = TS K (p * p) 1 := by
+  rw [conj_zero, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_succ_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) (b : Fin p) :
+    conj p ζ b.succ = TS K 1 (ζ ^ (b : ℕ)) := by
+  rw [conj_succ, TS_eq_coeffEmb, qExpand_one_apply]
+
+theorem qTwist_iota_of_pow_eq_one (N : ℕ) [NeZero N] (v : Kˣ) (hv : v ^ N = 1) (x : LaurentSeries ℚ)
+    :
+    qTwist v (coeffEmb K (qExpand ℚ N x)) = coeffEmb K (qExpand ℚ N x) := by
+  rw [coeffEmb_qExpand, qTwist_qExpand]
+  have : v ^ (N : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData jGen modularFunctionFieldFull jqd_mem_full coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot full_eq_adjoin_primes relfinrank_full_of_squarefree \
+  finrank_adjoin_jqN_eq_of_prime dedekindPsi_prime exists_phiIrreducible_evalSymm \
+  dedekindPsi_of_squarefree"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+omit [Algebra ℚ K] in
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+omit [Algebra ℚ K] in
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+omit [Algebra ℚ K] in
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem phiProd_conj_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    phiProd p (conj p ζ) = (Polynomial.X - Polynomial.C (TS K (p * p) 1)) *
+      ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) := by
+  rw [phiProd, Fin.prod_univ_succ, conj_zero_eq]
+  congr 1
+  rw [← Fin.prod_univ_eq_prod_range (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) p]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [conj_succ_eq]
+
+theorem roots_phiProd_conj (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    (phiProd p (conj p ζ)).roots = TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^
+      b)) := by
+  classical
+  rw [phiProd_conj_eq]
+  have h1 : (Polynomial.X - Polynomial.C (TS K (p * p) 1) : Polynomial (LaurentSeries K)) ≠ 0 :=
+    Polynomial.X_sub_C_ne_zero _
+  have h2 : (∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b)))) ≠ 0 :=
+    Finset.prod_ne_zero_iff.mpr fun b _ => Polynomial.X_sub_C_ne_zero _
+  rw [Polynomial.roots_mul (mul_ne_zero h1 h2), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod,
+    Finset.range_val]
+  have hm : (Multiset.map (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) (Multiset.range
+    p)) =
+      ((Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).map (fun a => Polynomial.X - Polynomial.C
+        a) := by
+    rw [Multiset.map_map]; rfl
+  rw [hm, Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+omit [Algebra ℚ K] in
+theorem roots_phiProd_conj_nodup (p : ℕ) [hp : Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).Nodup := by
+  refine Multiset.nodup_cons.mpr ⟨?_, ?_⟩
+  · intro hmem
+    obtain ⟨b, -, hb⟩ := Multiset.mem_map.mp hmem
+    have := (TS_injective hb).1
+    have h2 := hp.out.two_le
+    nlinarith
+  · refine (Multiset.nodup_range p).map_on fun b hb b' hb' hbb' => ?_
+    rw [Multiset.mem_range] at hb hb'
+    have hu := (TS_injective hbb').2
+    have hζu : IsPrimitiveRoot ζ p := IsPrimitiveRoot.coe_units_iff.mp hζ
+    exact hζu.pow_inj hb hb' hu
+
+theorem exists_isPrimitiveRoot_cyclotomicField (N : ℕ) [NeZero N] :
+    ∃ z : CyclotomicField N ℚ, IsPrimitiveRoot z N := by
+  have : NeZero ((N : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr (NeZero.ne N)⟩
+  have : IsCyclotomicExtension {N} ℚ (CyclotomicField N ℚ) :=
+    CyclotomicField.isCyclotomicExtension N ℚ
+  exact IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField N ℚ) (Set.mem_singleton N)
+    (NeZero.ne N)
+
+def cycUnit (N : ℕ) [NeZero N] : (CyclotomicField N ℚ)ˣ :=
+  ((exists_isPrimitiveRoot_cyclotomicField N).choose_spec.isUnit (NeZero.ne N)).unit
+
+theorem cycUnit_spec (N : ℕ) [NeZero N] :
+    IsPrimitiveRoot ((cycUnit N : (CyclotomicField N ℚ)ˣ) : CyclotomicField N ℚ) N := by
+  rw [cycUnit, IsUnit.unit_spec]
+  exact (exists_isPrimitiveRoot_cyclotomicField N).choose_spec
+
+theorem cycUnit_pow (N : ℕ) [NeZero N] : cycUnit N ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, (cycUnit_spec N).pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData jGen modularFunctionFieldFull jqd_mem_full coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot full_eq_adjoin_primes relfinrank_full_of_squarefree \
+  finrank_adjoin_jqN_eq_of_prime dedekindPsi_prime exists_phiIrreducible_evalSymm \
+  dedekindPsi_of_squarefree"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData jGen modularFunctionFieldFull jqd_mem_full coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot full_eq_adjoin_primes relfinrank_full_of_squarefree \
+  finrank_adjoin_jqN_eq_of_prime dedekindPsi_prime exists_phiIrreducible_evalSymm \
+  dedekindPsi_of_squarefree"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem prod_form_ne_zero (N : ℕ) (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e]
+    (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K
+            jq)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+          (Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u,
+    Polynomial.roots_mul (prod_form_ne_zero N ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p)))
+    (coeffEmb K jq))))
+        = ((Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+        (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+        (Multiset.range p).map
+          (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).Nodup := by
+  have hζp : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := isPrimitiveRoot_pow_div hζ hpN
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h := (TS_injective (K := K) (e := e) (e' := p * (p * e))
+      (u := u * ζ ^ (b * (N / p))) (u' := u ^ (p * p))
+      (by simpa only [TS_eq_coeffEmb] using heq)).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e)
+      (u := u * ζ ^ (b * (N / p))) (u' := u * ζ ^ (b' * (N / p)))
+      (by simpa only [TS_eq_coeffEmb] using heq)).2
+    have h2 : ζ ^ (b * (N / p)) = ζ ^ (b' * (N / p)) := mul_left_cancel h
+    have h3 : (ζ ^ (N / p)) ^ b = (ζ ^ (N / p)) ^ b' := by
+      rw [← pow_mul, ← pow_mul, Nat.mul_comm (N / p) b, Nat.mul_comm (N / p) b']
+      exact h2
+    have h4 : ((ζ ^ (N / p) : Kˣ) : K) ^ b = ((ζ ^ (N / p) : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h3]
+    exact hζp.pow_inj hb hb' h4
+
+theorem roots_prime_at_slot_roots_nodup (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots.Nodup := by
+  rw [roots_prime_at_slot N ζ hζ p hpN data e u]
+  exact roots_prime_at_slot_nodup N ζ hζ p hpN e u
+
+theorem isRoot_prime_at_slot_iff (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u]
+    exact prod_form_ne_zero N ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot N ζ hζ p hpN data e u,
+    Multiset.mem_cons, Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData jGen modularFunctionFieldFull jqd_mem_full coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot full_eq_adjoin_primes relfinrank_full_of_squarefree \
+  finrank_adjoin_jqN_eq_of_prime dedekindPsi_prime exists_phiIrreducible_evalSymm \
+  dedekindPsi_of_squarefree"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+
+
+
+
+theorem phiAtSeed_jq_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) :
+    (phiAtSeed data jq).eval (jqN n) = 0 := by
+  have h := data.eval_eq_zero
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp [evalAtJ_X]
+
+
+theorem phiAtSeed_jqN_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN M)).eval (jqN (M * n)) = 0 := by
+  have h := phiAtSeed_eval_map data jq (jqN n) (qExpand ℚ M) (phiAtSeed_jq_eval n data)
+  rwa [jqN, qExpand_qExpand] at h
+
+theorem phiAtSeed_iota_eval {K : Type*} [Field K] [Algebra ℚ K] (A : ℕ) [NeZero A] (n : ℕ)
+    [NeZero n]
+    (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (coeffEmb K (qExpand ℚ A (jqN M)))).eval (coeffEmb K (qExpand ℚ A (jqN (M *
+      n)))) = 0 :=
+  phiAtSeed_eval_map data _ _ ((coeffEmb K).comp (qExpand ℚ A)) (phiAtSeed_jqN_eval n data M)
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData jGen modularFunctionFieldFull jqd_mem_full coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot full_eq_adjoin_primes relfinrank_full_of_squarefree \
+  finrank_adjoin_jqN_eq_of_prime dedekindPsi_prime exists_phiIrreducible_evalSymm \
+  dedekindPsi_of_squarefree"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def IsLevel (K : Type*) [Field K] [Algebra ℚ K] (N M : ℕ) (y : LaurentSeries K) : Prop :=
+  ∃ (e d : ℕ) (_ : NeZero e) (w : Kˣ),
+    d ∣ M ∧ e * (d * d) = N * N * M ∧ w ^ M = 1 ∧ y = TS K e w
+
+theorem isLevel_iota (N : ℕ) [NeZero N] (M : ℕ) [NeZero M] :
+    IsLevel K N M (TS K (N * N * M) 1) :=
+  ⟨N * N * M, 1, inferInstance, 1, one_dvd M, by ring, one_pow M, rfl⟩
+
+theorem isLevel_one (N : ℕ) [NeZero N] : IsLevel K N 1 (TS K (N * N) 1) :=
+  ⟨N * N, 1, inferInstance, 1, one_dvd 1, by ring, one_pow 1, rfl⟩
+
+private theorem exists_pow_eq_of_coprime {G : Type*} [CommGroup G] {q M : ℕ}
+    (hcop : Nat.Coprime q M) {w : G} (hw : w ^ M = 1) : ∃ u : G, u ^ q = w := by
+  obtain ⟨a, b, hab⟩ := hcop.isCoprime
+  refine ⟨w ^ a, ?_⟩
+  have hwz : w ^ (M : ℤ) = 1 := by rw [zpow_natCast]; exact hw
+  have key : a * (q : ℤ) = 1 - b * (M : ℤ) := by linarith
+  rw [← zpow_natCast (w ^ a) q, ← zpow_mul, key, zpow_sub, zpow_one, mul_comm b (M : ℤ),
+    zpow_mul, hwz, one_zpow, inv_one, mul_one]
+
+private theorem prime_step_facts (N : ℕ) (hN : Squarefree N) {M q : ℕ} (hq : Nat.Prime q)
+    (hMq : M * q ∣ N) : q ∣ N ∧ q ∣ N * N ∧ Nat.Coprime M q ∧ ¬ q ∣ M := by
+  have hqN : q ∣ N := (dvd_mul_left q M).trans hMq
+  have hcop : Nat.Coprime M q := (Nat.squarefree_mul_iff.mp (hN.squarefree_of_dvd hMq)).1
+  exact ⟨hqN, hqN.trans (dvd_mul_left N N), hcop,
+    fun hdvd => hq.ne_one (Nat.eq_one_of_dvd_coprimes hcop hdvd dvd_rfl)⟩
+
+private theorem level_exponent_eq {N M : ℕ} {v : LaurentSeries K} (hv : IsLevel K N M v)
+    (e' : ℕ) [NeZero e'] (w' : Kˣ) (hveq : v = TS K e' w') :
+    ∃ d' : ℕ, d' ∣ M ∧ e' * (d' * d') = N * N * M ∧ w' ^ M = 1 := by
+  obtain ⟨ez, dz, hez, wz, hdz, hezd, hwz, rfl⟩ := hv
+  have := hez
+  obtain ⟨rfl, rfl⟩ := TS_injective hveq
+  exact ⟨dz, hdz, hezd, hwz⟩
+
+theorem isLevel_mul_of_isRoot (N : ℕ) [NeZero N] (hN : Squarefree N) (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) (N * N)) {M q : ℕ} [NeZero M] [hq : Fact (Nat.Prime q)]
+    (hMq : M * q ∣ N) (data : ModularPolynomialData q) {y z : LaurentSeries K}
+    (hy : IsLevel K N M y) (hz : (phiAtSeed data y).IsRoot z) :
+    IsLevel K N (M * q) z := by
+  obtain ⟨e, d, he, w, hdM, hed, hwM, rfl⟩ := hy
+  have := he
+  obtain ⟨hqN, hqNN, hcop, hqM⟩ := prime_step_facts N hN hq.out hMq
+  have hζ1 : ζ ^ (N * N) = 1 :=
+    Units.ext (by rw [Units.val_pow_eq_pow_val, Units.val_one]; exact hζ.pow_eq_one)
+  have hqd : ¬ q ∣ d := fun h => hqM (h.trans hdM)
+  have hqe : q ∣ e := by
+    have h1 : q ∣ e * (d * d) := by rw [hed]; exact dvd_mul_of_dvd_left hqNN M
+    rcases hq.out.dvd_mul.mp h1 with h | h
+    · exact h
+    · rcases hq.out.dvd_mul.mp h with h' | h' <;> exact absurd h' hqd
+  obtain ⟨e₁, rfl⟩ := hqe
+  have : NeZero e₁ := ⟨fun h0 => NeZero.ne (q * e₁) (by rw [h0, mul_zero])⟩
+  obtain ⟨u, huq⟩ := exists_pow_eq_of_coprime (G := Kˣ) hcop.symm hwM
+  have hz2 : (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (q * e₁) (qTwist (u ^ q) (coeffEmb K jq))))).IsRoot z := by
+    rw [huq]
+    simpa only [phiAtSeed, TS_eq_coeffEmb] using hz
+  rcases (isRoot_prime_at_slot_iff (N * N) ζ hζ q hqNN data e₁ u z).mp hz2 with hsp | ⟨b, -, htw⟩
+  · refine ⟨q * (q * e₁), d, inferInstance, u ^ (q * q), dvd_mul_of_dvd_left hdM q, ?_, ?_,
+      by simpa only [TS_eq_coeffEmb] using hsp⟩
+    · rw [show q * (q * e₁) * (d * d) = q * (q * e₁ * (d * d)) from by ring, hed]; ring
+    · rw [← pow_mul, show q * q * (M * q) = q * (q * (M * q)) from by ring, pow_mul, huq,
+        show q * (M * q) = M * (q * q) from by ring, pow_mul, hwM, one_pow]
+  · refine ⟨e₁, d * q, inferInstance, u * ζ ^ (b * (N * N / q)),
+      mul_dvd_mul hdM dvd_rfl, ?_, ?_, by simpa only [TS_eq_coeffEmb] using htw⟩
+    · rw [show e₁ * (d * q * (d * q)) = q * e₁ * (d * d) * q from by ring, hed]; ring
+    · rw [mul_pow]
+      have h1 : u ^ (M * q) = 1 := by
+        rw [show M * q = q * M from Nat.mul_comm M q, pow_mul, huq, hwM]
+      have h2 : (ζ ^ (b * (N * N / q))) ^ (M * q) = 1 := by
+        rw [← pow_mul, show b * (N * N / q) * (M * q) = N * N / q * q * (b * M) from by ring,
+          Nat.div_mul_cancel hqNN, pow_mul, hζ1, one_pow]
+      rw [h1, h2, one_mul]
+
+theorem eq_of_isRoot_of_isLevel (N : ℕ) [NeZero N] (hN : Squarefree N) (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) (N * N)) {M q : ℕ} [NeZero M] [hq : Fact (Nat.Prime q)]
+    (hMq : M * q ∣ N) (data : ModularPolynomialData q) {y z z' : LaurentSeries K}
+    (hy : IsLevel K N (M * q) y) (hz : (phiAtSeed data y).IsRoot z)
+    (hz' : (phiAtSeed data y).IsRoot z') (hzM : IsLevel K N M z) (hz'M : IsLevel K N M z') :
+    z = z' := by
+  obtain ⟨e, d, he, w, hdMq, hed, hwMq, rfl⟩ := hy
+  have := he
+  obtain ⟨hqN, hqNN, hcop, hqM⟩ := prime_step_facts N hN hq.out hMq
+  have hqe : q ∣ e := by
+    have h1 : q ∣ e * (d * d) := by
+      rw [hed]; exact dvd_mul_of_dvd_right (dvd_mul_left q M) (N * N)
+    rcases hq.out.dvd_mul.mp h1 with h | h
+    · exact h
+    · have hqd2 : q ∣ d := by rcases hq.out.dvd_mul.mp h with h' | h' <;> exact h'
+      obtain ⟨d₁, rfl⟩ := hqd2
+      have hred : e * (d₁ * d₁) * q = N * N * M := by
+        refine Nat.eq_of_mul_eq_mul_right hq.out.pos ?_
+        calc e * (d₁ * d₁) * q * q = e * (q * d₁ * (q * d₁)) := by ring
+          _ = N * N * (M * q) := hed
+          _ = N * N * M * q := by ring
+      have h2 : q * q ∣ e * (d₁ * d₁) * q := by
+        rw [hred]; exact dvd_mul_of_dvd_left (mul_dvd_mul hqN hqN) M
+      have h3 : q ∣ e * (d₁ * d₁) := (mul_dvd_mul_iff_right hq.out.ne_zero).mp h2
+      rcases hq.out.dvd_mul.mp h3 with h4 | h4
+      · exact h4
+      · have hqd₁ : q ∣ d₁ := by rcases hq.out.dvd_mul.mp h4 with h5 | h5 <;> exact h5
+        have hd₁M : d₁ ∣ M := by
+          have hh := hdMq
+          rw [show M * q = q * M from Nat.mul_comm M q] at hh
+          exact (mul_dvd_mul_iff_left hq.out.ne_zero).mp hh
+        exact absurd (hqd₁.trans hd₁M) hqM
+  obtain ⟨e₁, rfl⟩ := hqe
+  have : NeZero e₁ := ⟨fun h0 => NeZero.ne (q * e₁) (by rw [h0, mul_zero])⟩
+  have hed₁ : e₁ * (d * d) = N * N * M := by
+    refine Nat.eq_of_mul_eq_mul_left hq.out.pos ?_
+    calc q * (e₁ * (d * d)) = q * e₁ * (d * d) := by ring
+      _ = N * N * (M * q) := hed
+      _ = q * (N * N * M) := by ring
+  have hwMqz : (w : K) ^ (M * q) = 1 := by
+    have hh := congrArg Units.val hwMq
+    rwa [Units.val_pow_eq_pow_val, Units.val_one] at hh
+  have hwNN : (w : K) ^ (N * N) = 1 := by
+    obtain ⟨c, hc⟩ := hMq.trans (dvd_mul_left N N)
+    rw [hc, pow_mul, hwMqz, one_pow]
+  obtain ⟨i, -, hiw⟩ := hζ.eq_pow_of_pow_eq_one hwNN
+  have hqi : q ∣ i := by
+    have h1 : (ζ : K) ^ (i * (M * q)) = 1 := by rw [pow_mul, hiw, hwMqz]
+    have h2 : N * N ∣ i * (M * q) := hζ.dvd_of_pow_eq_one _ h1
+    have h3 : q * q ∣ i * M * q := by
+      refine (mul_dvd_mul hqN hqN).trans ?_
+      rw [show i * M * q = i * (M * q) from by ring]
+      exact h2
+    have h4 : q ∣ i * M := (mul_dvd_mul_iff_right hq.out.ne_zero).mp h3
+    rcases hq.out.dvd_mul.mp h4 with h5 | h5
+    · exact h5
+    · exact absurd h5 hqM
+  obtain ⟨i₁, rfl⟩ := hqi
+  have hiwu : ζ ^ (q * i₁) = w :=
+    Units.ext (by rw [Units.val_pow_eq_pow_val]; exact hiw)
+  have huq : (ζ ^ i₁) ^ q = w := by
+    rw [← pow_mul, Nat.mul_comm i₁ q]
+    exact hiwu
+  have hz2 : (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (q * e₁) (qTwist ((ζ ^ i₁) ^ q) (coeffEmb K jq))))).IsRoot z := by
+    rw [huq]
+    simpa only [phiAtSeed, TS_eq_coeffEmb] using hz
+  have hz'2 : (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (q * e₁) (qTwist ((ζ ^ i₁) ^ q) (coeffEmb K jq))))).IsRoot z' := by
+    rw [huq]
+    simpa only [phiAtSeed, TS_eq_coeffEmb] using hz'
+  have hcz := (isRoot_prime_at_slot_iff (N * N) ζ hζ q hqNN data e₁ (ζ ^ i₁) z).mp hz2
+  have hcz' := (isRoot_prime_at_slot_iff (N * N) ζ hζ q hqNN data e₁ (ζ ^ i₁) z').mp hz'2
+  by_cases hqd : q ∣ d
+  · have hnt : ∀ {v : LaurentSeries K}, IsLevel K N M v → ∀ b : ℕ,
+        v = qExpand K e₁ (qTwist ((ζ ^ i₁) * ζ ^ (b * (N * N / q))) (coeffEmb K jq)) → False := by
+      intro v hv b hveq
+      obtain ⟨dz, hdzM, hdze, -⟩ :=
+        level_exponent_eq hv e₁ ((ζ ^ i₁) * ζ ^ (b * (N * N / q)))
+          (by simpa only [TS_eq_coeffEmb] using hveq)
+      have h1 : e₁ * (dz * dz) = e₁ * (d * d) := by rw [hdze, hed₁]
+      have h2 : dz * dz = d * d :=
+        Nat.eq_of_mul_eq_mul_left (Nat.pos_of_ne_zero (NeZero.ne e₁)) h1
+      have hdzd : dz = d := (mul_self_inj (Nat.zero_le dz) (Nat.zero_le d)).mp h2
+      have hqdz : q ∣ dz := by rw [hdzd]; exact hqd
+      exact hqM (hqdz.trans hdzM)
+    have hzs : z = qExpand K (q * (q * e₁)) (qTwist ((ζ ^ i₁) ^ (q * q)) (coeffEmb K jq)) := by
+      rcases hcz with h | ⟨b, -, h⟩
+      · exact h
+      · exact (hnt hzM b h).elim
+    have hz's : z' = qExpand K (q * (q * e₁)) (qTwist ((ζ ^ i₁) ^ (q * q)) (coeffEmb K jq)) := by
+      rcases hcz' with h | ⟨b, -, h⟩
+      · exact h
+      · exact (hnt hz'M b h).elim
+    rw [hzs, hz's]
+  · have hns : ∀ {v : LaurentSeries K}, IsLevel K N M v →
+        v = qExpand K (q * (q * e₁)) (qTwist ((ζ ^ i₁) ^ (q * q)) (coeffEmb K jq)) → False := by
+      intro v hv hveq
+      obtain ⟨dz, -, hdze, -⟩ :=
+        level_exponent_eq hv (q * (q * e₁)) ((ζ ^ i₁) ^ (q * q))
+          (by simpa only [TS_eq_coeffEmb] using hveq)
+      have h1 : e₁ * (q * q * (dz * dz)) = e₁ * (d * d) := by
+        rw [show e₁ * (q * q * (dz * dz)) = q * (q * e₁) * (dz * dz) from by ring, hdze, hed₁]
+      have h2 : q * q * (dz * dz) = d * d :=
+        Nat.eq_of_mul_eq_mul_left (Nat.pos_of_ne_zero (NeZero.ne e₁)) h1
+      have h3 : q ∣ d * d := ⟨q * (dz * dz), by rw [← h2]; ring⟩
+      rcases hq.out.dvd_mul.mp h3 with h4 | h4 <;> exact hqd h4
+    obtain ⟨b, hb, hzb⟩ :
+        ∃ b < q, z = qExpand K e₁ (qTwist ((ζ ^ i₁) * ζ ^ (b * (N * N / q))) (coeffEmb K jq)) := by
+      rcases hcz with h | h
+      · exact (hns hzM h).elim
+      · exact h
+    obtain ⟨b', hb', hz'b⟩ :
+        ∃ b < q, z' = qExpand K e₁ (qTwist ((ζ ^ i₁) * ζ ^ (b * (N * N / q))) (coeffEmb K jq)) := by
+      rcases hcz' with h | h
+      · exact (hns hz'M h).elim
+      · exact h
+    obtain ⟨-, -, -, hwbM⟩ :=
+      level_exponent_eq hzM e₁ ((ζ ^ i₁) * ζ ^ (b * (N * N / q)))
+        (by simpa only [TS_eq_coeffEmb] using hzb)
+    obtain ⟨-, -, -, hwb'M⟩ :=
+      level_exponent_eq hz'M e₁ ((ζ ^ i₁) * ζ ^ (b' * (N * N / q)))
+        (by simpa only [TS_eq_coeffEmb] using hz'b)
+    have hcanc : (ζ ^ (b * (N * N / q))) ^ M = (ζ ^ (b' * (N * N / q))) ^ M := by
+      have h1 : (ζ ^ i₁) ^ M * (ζ ^ (b * (N * N / q))) ^ M = 1 := by
+        rw [← mul_pow]; exact hwbM
+      have h2 : (ζ ^ i₁) ^ M * (ζ ^ (b' * (N * N / q))) ^ M = 1 := by
+        rw [← mul_pow]; exact hwb'M
+      exact mul_left_cancel (h1.trans h2.symm)
+    have hζq : IsPrimitiveRoot ((ζ ^ (N * N / q) : Kˣ) : K) q :=
+      isPrimitiveRoot_pow_div hζ hqNN
+    have hmod : b * M ≡ b' * M [MOD q] := by
+      have hu : (ζ ^ (N * N / q)) ^ (b * M) = (ζ ^ (N * N / q)) ^ (b' * M) := by
+        calc (ζ ^ (N * N / q)) ^ (b * M)
+            = ζ ^ (N * N / q * (b * M)) := (pow_mul ζ _ _).symm
+          _ = ζ ^ (b * (N * N / q) * M) := by
+              rw [show N * N / q * (b * M) = b * (N * N / q) * M from by ring]
+          _ = (ζ ^ (b * (N * N / q))) ^ M := pow_mul ζ _ _
+          _ = (ζ ^ (b' * (N * N / q))) ^ M := hcanc
+          _ = ζ ^ (b' * (N * N / q) * M) := (pow_mul ζ _ _).symm
+          _ = ζ ^ (N * N / q * (b' * M)) := by
+              rw [show b' * (N * N / q) * M = N * N / q * (b' * M) from by ring]
+          _ = (ζ ^ (N * N / q)) ^ (b' * M) := pow_mul ζ _ _
+      have hζqu : IsPrimitiveRoot (ζ ^ (N * N / q) : Kˣ) q :=
+        IsPrimitiveRoot.coe_units_iff.mp hζq
+      have h4 := pow_eq_pow_iff_modEq.mp hu
+      rwa [← hζqu.eq_orderOf] at h4
+    have hbb' : b = b' := by
+      have h5 : b ≡ b' [MOD q] := hmod.cancel_right_of_coprime hcop.symm
+      calc b = b % q := (Nat.mod_eq_of_lt hb).symm
+        _ = b' % q := h5
+        _ = b' := Nat.mod_eq_of_lt hb'
+    rw [hzb, hz'b, hbb']
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData jGen modularFunctionFieldFull jqd_mem_full coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot full_eq_adjoin_primes relfinrank_full_of_squarefree \
+  finrank_adjoin_jqN_eq_of_prime dedekindPsi_prime exists_phiIrreducible_evalSymm \
+  dedekindPsi_of_squarefree"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+theorem phiAtSeed_eval_of_injective {R S : Type*} [CommRing R] [CommRing S] {n : ℕ} [NeZero n]
+    (data : ModularPolynomialData n) (x y : R) (f : R →+* S) (hf : Function.Injective f)
+    (h : (phiAtSeed data (f x)).eval (f y) = 0) : (phiAtSeed data x).eval y = 0 := by
+  rw [← phiAtSeed_map, Polynomial.eval_map, Polynomial.eval₂_hom] at h
+  exact (injective_iff_map_eq_zero f).mp hf _ h
+
+theorem phiAtSeed_eval_symm {n : ℕ} [NeZero n] (data : ModularPolynomialData n)
+    (hs : EvalSymm data.Φ)
+    (x y : LaurentSeries ℚ) : (phiAtSeed data x).eval y = (phiAtSeed data y).eval x := by
+  have key : ∀ z : LaurentSeries ℚ, Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries ℚ)) z =
+      (Polynomial.aeval (R := ℤ) z).toRingHom := fun z =>
+    Polynomial.ringHom_ext' (RingHom.ext_int _ _) (by simp)
+  rw [phiAtSeed, phiAtSeed, Polynomial.eval_map, Polynomial.eval_map, key, key]
+  exact hs x y
+
+theorem jqN_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) : jqN n = jqN m := by subst h; rfl
+
+theorem phiAtSeed_jqN_eval_down (q : ℕ) [NeZero q] (data : ModularPolynomialData q)
+    (hs : EvalSymm data.Φ)
+    (M : ℕ) [NeZero M] : (phiAtSeed data (jqN (M * q))).eval (jqN M) = 0 := by
+  rw [← phiAtSeed_eval_symm data hs]; exact phiAtSeed_jqN_eval q data M
+
+theorem toAdjoin_eq_minpoly (p : ℕ) [hp : Fact p.Prime] (data : ModularPolynomialData p) :
+    phiAtSeed data jGen = minpoly ℚ⟮jq⟯ (jqN p) := by
+  have hroot : Polynomial.aeval (jqN p) (phiAtSeed data jGen) = 0 := by
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, phiAtSeed_map]
+    exact phiAtSeed_jq_eval p data
+  have hint : IsIntegral ℚ⟮jq⟯ (jqN p) :=
+    ⟨_, phiAtSeed_monic data jGen, by rwa [Polynomial.aeval_def] at hroot⟩
+  have hdeg : (minpoly ℚ⟮jq⟯ (jqN p)).natDegree = p + 1 := by
+    rw [← IntermediateField.adjoin.finrank hint]; exact finrank_adjoin_jqN_eq_of_prime p
+  refine Polynomial.eq_of_monic_of_dvd_of_natDegree_le (minpoly.monic hint) (phiAtSeed_monic data
+    jGen)
+    (minpoly.dvd _ _ hroot) ?_
+  rw [hdeg, phiAtSeed_natDegree, dedekindPsi_prime hp.out]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData jGen modularFunctionFieldFull jqd_mem_full coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot full_eq_adjoin_primes relfinrank_full_of_squarefree \
+  finrank_adjoin_jqN_eq_of_prime dedekindPsi_prime exists_phiIrreducible_evalSymm \
+  dedekindPsi_of_squarefree"
+end ModularCurve
+
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+set_option synthInstance.maxHeartbeats 40000 in -- this is needed (DL)
+private theorem ModularCurve.finrank_adjoin_jqN_eq_of_squarefree (N : ℕ) [NeZero N]
+    (hN : Squarefree N) :
+    Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) ({jqN N}
+      : Set (LaurentSeries ℚ))) = dedekindPsi N := by
+  classical
+  set Sg : Set (LaurentSeries ℚ) := insert jq {x : LaurentSeries ℚ | ∃ p ∈ N.primeFactors, ∃ _ :
+    NeZero p, x = jqN p}
+    with hSg
+  have hle : ℚ⟮jq⟯ ≤ IntermediateField.adjoin ℚ Sg :=
+    IntermediateField.adjoin.mono ℚ _ _ (by simp [hSg])
+  set E : IntermediateField ℚ⟮jq⟯ (LaurentSeries ℚ) := IntermediateField.adjoin ℚ⟮jq⟯ Sg with hEdef
+  have hE : IntermediateField.extendScalars hle = E := IntermediateField.extendScalars_adjoin hle
+  have hfull : modularFunctionFieldFull N = IntermediateField.adjoin ℚ Sg :=
+    full_eq_adjoin_primes N hN
+  have hfin : Module.finrank ℚ⟮jq⟯ E = dedekindPsi N := by
+    rw [← hE, ← IntermediateField.relfinrank_eq_finrank_of_le hle, ← hfull]
+    exact relfinrank_full_of_squarefree N hN
+  have hψpos : 0 < dedekindPsi N := by
+    rw [dedekindPsi_of_squarefree hN]; exact Finset.prod_pos fun p _ => Nat.succ_pos p
+  have : FiniteDimensional ℚ⟮jq⟯ E := Module.finite_of_finrank_pos (by rw [hfin]; exact hψpos)
+  have memE : ∀ d : ℕ, ∀ _ : NeZero d, d ∣ N → jqN d ∈ E := by
+    intro d _ hd
+    have : jqN d ∈ IntermediateField.extendScalars hle :=
+      (IntermediateField.mem_extendScalars _).mpr (by rw [← hfull]; exact jqd_mem_full N hd)
+    rwa [hE] at this
+  have hαE : jqN N ∈ E := memE N inferInstance (dvd_refl N)
+  have hsub : IntermediateField.adjoin ℚ⟮jq⟯ ({jqN N} : Set (LaurentSeries ℚ)) ≤ E :=
+    IntermediateField.adjoin_le_iff.mpr (Set.singleton_subset_iff.mpr hαE)
+  have hup : Module.finrank ℚ⟮jq⟯ (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN N} : Set (LaurentSeries ℚ)))
+    ≤ dedekindPsi N :=
+    hfin ▸ IntermediateField.finrank_le_of_le_right hsub
+  have : NeZero (N * N) := ⟨mul_ne_zero (NeZero.ne N) (NeZero.ne N)⟩
+  let K := CyclotomicField (N * N) ℚ
+  let ζ : Kˣ := cycUnit (N * N)
+  have hζ : IsPrimitiveRoot (ζ : K) (N * N) := cycUnit_spec (N * N)
+  let ι : LaurentSeries ℚ →+* LaurentSeries K := (coeffEmb K).comp (qExpand ℚ (N * N))
+  have hιinj : Function.Injective ι := by
+    intro x y h
+    apply qExpand_injective (N * N)
+    ext k
+    have := congrArg (fun z : LaurentSeries K => z.coeff k) h
+    simp only [ι, RingHom.comp_apply, coeffEmb_coeff] at this
+    exact (algebraMap ℚ K).injective this
+  let : Algebra ℚ⟮jq⟯ (LaurentSeries K) := (ι.comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ))).toAlgebra
+  have halg : ∀ a : ℚ⟮jq⟯, algebraMap ℚ⟮jq⟯ (LaurentSeries K) a = ι a := fun a => rfl
+  have hdata : ∀ q : ℕ, ∀ _ : Fact q.Prime, ∃ data : ModularPolynomialData q, EvalSymm data.Φ :=
+    fun q _ => (exists_phiIrreducible_evalSymm q).imp fun _ h => h.2
+  have hsplit : ∀ x : E, ((minpoly ℚ⟮jq⟯ x).map (algebraMap ℚ⟮jq⟯ (LaurentSeries K))).Splits := by
+    intro x
+    rw [← minpoly.algHom_eq E.val Subtype.val_injective x]
+    refine @IntermediateField.splits_of_mem_adjoin ℚ⟮jq⟯ (LaurentSeries ℚ) _ _ _ (LaurentSeries K) _
+      _ Sg ?_
+      (x : LaurentSeries ℚ) x.2
+    intro y hy
+    rcases hy with rfl | ⟨p, hp, _, rfl⟩
+    · refine ⟨isIntegral_algebraMap (x := jGen), ?_⟩
+      have hj : minpoly ℚ⟮jq⟯ (jq : LaurentSeries ℚ) = Polynomial.X - Polynomial.C jGen :=
+        minpoly.eq_X_sub_C (B := LaurentSeries ℚ) jGen
+      rw [hj]
+      simp only [Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C]
+      exact Polynomial.Splits.X_sub_C _
+    · have : Fact p.Prime := ⟨Nat.prime_of_mem_primeFactors hp⟩
+      have hpN : p ∣ N := Nat.dvd_of_mem_primeFactors hp
+      obtain ⟨data, -⟩ := hdata p inferInstance
+      have hmin := toAdjoin_eq_minpoly p data
+      refine ⟨⟨_, phiAtSeed_monic data jGen, ?_⟩, ?_⟩
+      · rw [hmin, ← Polynomial.aeval_def]; exact minpoly.aeval _ _
+      rw [← hmin, phiAtSeed_map, halg]
+      change (phiAtSeed data (ι jq)).Splits
+      have : NeZero (N * (N / p)) :=
+        ⟨mul_ne_zero (NeZero.ne N) (Nat.div_ne_zero_iff_of_dvd hpN |>.mpr ⟨NeZero.ne N,
+          (Nat.prime_of_mem_primeFactors hp).ne_zero⟩)⟩
+      have hseed : ι jq = qExpand K (p * (N * (N / p))) (qTwist ((1 : Kˣ) ^ p) (coeffEmb K jq)) :=
+        by
+        rw [← TS_eq_coeffEmb]
+        change coeffEmb K (qExpand ℚ (N * N) jq) = TS K (p * (N * (N / p))) (1 ^ p)
+        rw [iota_jq, one_pow]
+        exact TS_congr (by rw [Nat.mul_left_comm, Nat.mul_div_cancel' hpN]) 1
+      rw [hseed, phiAtSeed, splits_prime_at_slot (N * N) ζ hζ p (dvd_mul_of_dvd_left hpN N) data (N
+        * (N / p)) 1]
+      exact Polynomial.Splits.mul (Polynomial.Splits.X_sub_C _)
+        (Polynomial.Splits.prod fun _ _ => Polynomial.Splits.X_sub_C _)
+  have hcard : Nat.card (E →ₐ[ℚ⟮jq⟯] LaurentSeries K) = dedekindPsi N := by
+    rw [AlgHom.natCard_of_splits ℚ⟮jq⟯ E (LaurentSeries K) hsplit, hfin]
+  have hlev : ∀ (ψ : E →ₐ[ℚ⟮jq⟯] LaurentSeries K) (d : ℕ) (_ : NeZero d) (hd : d ∣ N) (hmem : jqN d
+    ∈ E),
+      IsLevel K N d (ψ ⟨jqN d, hmem⟩) := by
+    intro ψ d
+    induction d using induction_on_primes with
+    | zero => intro h0; exact (h0.out rfl).elim
+    | one =>
+      intro _ _ hmem
+      have : (⟨jqN 1, hmem⟩ : E) = algebraMap ℚ⟮jq⟯ E jGen := by
+        apply Subtype.ext; change jqN 1 = jq; exact jqN_one
+      rw [this, AlgHom.commutes, halg]
+      change IsLevel K N 1 (coeffEmb K (qExpand ℚ (N * N) jq))
+      rw [iota_jq]
+      exact isLevel_one N
+    | prime_mul p a hp ih =>
+      intro _ hpa hmem
+      have : Fact p.Prime := ⟨hp⟩
+      have : NeZero a :=
+        ⟨fun h => NeZero.ne N (by rw [h, Nat.mul_zero] at hpa; exact zero_dvd_iff.mp hpa)⟩
+      have ha : a ∣ N := dvd_of_mul_left_dvd hpa
+      have hap : a * p ∣ N := by rw [Nat.mul_comm]; exact hpa
+      obtain ⟨data, -⟩ := hdata p inferInstance
+      have hrel : (phiAtSeed data (ψ ⟨jqN a, memE a inferInstance ha⟩)).IsRoot
+          (ψ ⟨jqN (a * p), memE (a * p) inferInstance hap⟩) :=
+        phiAtSeed_eval_map data _ _ (ψ : E →+* LaurentSeries K)
+          (phiAtSeed_eval_of_injective data _ _ (algebraMap E (LaurentSeries ℚ))
+            Subtype.val_injective
+            (phiAtSeed_jqN_eval p data a))
+      have hval :=
+        isLevel_mul_of_isRoot N hN ζ hζ (M := a) (q := p) hap data (ih inferInstance ha _) hrel
+      have e : (⟨jqN (a * p), memE (a * p) inferInstance hap⟩ : E) = ⟨jqN (p * a), hmem⟩ :=
+        Subtype.ext (jqN_congr (Nat.mul_comm a p))
+      rw [e, Nat.mul_comm a p] at hval
+      exact hval
+  have hinj : Function.Injective (fun ψ : E →ₐ[ℚ⟮jq⟯] LaurentSeries K => ψ ⟨jqN N, hαE⟩) := by
+    intro ψ₁ ψ₂ htop
+    have hdown : ∀ m d : ℕ, ∀ _ : NeZero d, ∀ hdm : d * m = N,
+        ψ₁ ⟨jqN d, memE d inferInstance ⟨m, hdm.symm⟩⟩ = ψ₂ ⟨jqN d, memE d inferInstance ⟨m,
+          hdm.symm⟩⟩ := by
+      intro m
+      induction m using induction_on_primes with
+      | zero => intro d _ h; exact absurd h (by rw [Nat.mul_zero]; exact (NeZero.ne N).symm)
+      | one =>
+        intro d _ h
+        have hdN : d = N := by rw [← h, Nat.mul_one]
+        subst hdN
+        exact htop
+      | prime_mul p a hp ih =>
+        intro d _ h
+        have : Fact p.Prime := ⟨hp⟩
+        have : NeZero (d * p) := ⟨mul_ne_zero (NeZero.ne d) hp.ne_zero⟩
+        have hdp : d * p * a = N := by rw [← h]; ring
+        have hup := ih (d * p) inferInstance hdp
+        obtain ⟨data, hs⟩ := hdata p inferInstance
+        have hdpN : d * p ∣ N := ⟨a, hdp.symm⟩
+        have hdN : d ∣ N := dvd_of_mul_right_dvd hdpN
+        have hrel : ∀ ψ : E →ₐ[ℚ⟮jq⟯] LaurentSeries K,
+            (phiAtSeed data (ψ ⟨jqN (d * p), memE (d * p) inferInstance hdpN⟩)).IsRoot
+              (ψ ⟨jqN d, memE d inferInstance hdN⟩) := by
+          intro ψ
+          have h1 : (phiAtSeed data (⟨jqN (d * p), memE (d * p) inferInstance hdpN⟩ : E)).eval
+              ⟨jqN d, memE d inferInstance hdN⟩ = 0 :=
+            phiAtSeed_eval_of_injective data _ _ (algebraMap E (LaurentSeries ℚ))
+              Subtype.val_injective
+              (phiAtSeed_jqN_eval_down p data hs d)
+          exact phiAtSeed_eval_map data _ _ (ψ : E →+* LaurentSeries K) h1
+        exact eq_of_isRoot_of_isLevel N hN ζ hζ (M := d) (q := p) hdpN data
+          (hlev ψ₁ (d * p) inferInstance hdpN _) (hrel ψ₁) (by rw [hup]; exact hrel ψ₂)
+          (hlev ψ₁ d inferInstance hdN _) (hlev ψ₂ d inferInstance hdN _)
+    refine IntermediateField.adjoin_algHom_ext ℚ⟮jq⟯ (s := Sg) fun x hx => ?_
+    rcases hx with rfl | ⟨p, hp, _, rfl⟩
+    · have : ∀ h, (⟨jq, h⟩ : E) = algebraMap ℚ⟮jq⟯ E jGen := fun h => Subtype.ext rfl
+      rw [this, AlgHom.commutes, AlgHom.commutes]
+    · have hpN : p ∣ N := Nat.dvd_of_mem_primeFactors hp
+      obtain ⟨m, hm⟩ := hpN
+      exact hdown m p inferInstance hm.symm
+  have hint : IsIntegral ℚ⟮jq⟯ (⟨jqN N, hαE⟩ : E) := IsIntegral.of_finite ℚ⟮jq⟯ _
+  have hintL : IsIntegral ℚ⟮jq⟯ (jqN N) := by
+    simpa using hint.map E.val
+  have hmin : minpoly ℚ⟮jq⟯ (⟨jqN N, hαE⟩ : E) = minpoly ℚ⟮jq⟯ (jqN N) :=
+    (minpoly.algHom_eq E.val Subtype.val_injective (⟨jqN N, hαE⟩ : E)).symm
+  let ev : (E →ₐ[ℚ⟮jq⟯] LaurentSeries K) → (minpoly ℚ⟮jq⟯ (jqN N)).rootSet (LaurentSeries K) :=
+    fun ψ => ⟨ψ ⟨jqN N, hαE⟩, by
+      rw [Polynomial.mem_rootSet_of_ne (minpoly.ne_zero hintL), ← hmin,
+        Polynomial.aeval_algHom_apply,
+        minpoly.aeval, map_zero]⟩
+  have hev : Function.Injective ev := fun ψ₁ ψ₂ h => hinj (congrArg Subtype.val h)
+  have hlow : dedekindPsi N ≤ Module.finrank ℚ⟮jq⟯ (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN N} : Set
+    (LaurentSeries ℚ))) :=
+    by
+    rw [IntermediateField.adjoin.finrank hintL, ← hcard]
+    refine (Nat.card_le_card_of_injective ev hev).trans ?_
+    rw [Nat.card_coe_set_eq]
+    exact Polynomial.ncard_rootSet_le _ _
+  exact le_antisymm hup hlow
+
+p2m_open "ModularCurve~coeffEmb_qExpand\
+  " in
+open _root_.P2MW.S_ModularCurve_finrank_adjoin_jqN_eq_of_squarefree.ModularCurve in
+theorem solution (N : ℕ) [NeZero N] (hN : Squarefree N) :
+    Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) ({jqN N}
+      : Set (LaurentSeries ℚ))) = dedekindPsi N :=
+  ModularCurve.finrank_adjoin_jqN_eq_of_squarefree N hN
+
+end
+end S_ModularCurve_finrank_adjoin_jqN_eq_of_squarefree
+end P2MW
+export P2MW.S_ModularCurve_finrank_adjoin_jqN_eq_of_squarefree (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.finrank_adjoin_jqN_eq_of_squarefree (N : ℕ) [NeZero N] (hN : Squarefree N) :
+    Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) ({jqN N}
+      : Set (LaurentSeries ℚ))) = dedekindPsi N :=
+  solution N hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqN_pow_succ_of_not_mem.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqN_pow_succ_of_not_mem.lean
new file mode 100644
index 0000000000..c640fc7493
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqN_pow_succ_of_not_mem.lean
@@ -0,0 +1,796 @@
+/-
+Based on Prove2Me node ModularCurve.finrank_adjoin_jqN_pow_succ_of_not_mem
+(4d9bc9a3-1193-5c2b-8408-321544df7a3b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission bd148d24-f9f2-5fc6-9556-ee5b3811a898
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Polynomial_irreducible_of_transitive_ringAut
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime
+import Mathlib.NumberTheory.Cyclotomic.Gal
+import Mathlib.FieldTheory.Finite.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree p for the next prime-power level of j
+
+Theorem statement: `ModularCurve.finrank_adjoin_jqN_pow_succ_of_not_mem`
+(`4d9bc9a3-1193-5c2b-8408-321544df7a3b`), by Claude, 2026-09-05.
+
+Proof: submission `bd148d24-f9f2-5fc6-9556-ee5b3811a898`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Work inside the Laurent series field $\mathbb{Q}((q))$, and write $j(q^{N})$ for `jqN N`, the
+Laurent series obtained from the $q$-expansion $j$ by the ring map `qExpand` that multiplies all
+exponents by $N$ (substitution $q \mapsto q^{N}$). Let $F$ be an intermediate field of the extension
+$\mathbb{Q} \subseteq \mathbb{Q}((q))$, let $p$ be a prime (supplied as a `Fact`), and let $k$ be a
+natural number. Assume that $F$ contains both $j(q^{p^{k}})$ and $j(q^{p^{k+1}})$, and that $F$ does
+not contain $j(q^{p^{k+2}})$. Then the $F$-vector space $F\bigl(j(q^{p^{k+2}})\bigr)$, the
+intermediate field generated over $F$ by the single element $j(q^{p^{k+2}})$ inside
+$\mathbb{Q}((q))$, has finite rank exactly $p$; that is, $\bigl[F\bigl(j(q^{p^{k+2}})\bigr) :
+F\bigr] = p$. No hypothesis is imposed on $F$ beyond containing $\mathbb{Q}$ and the two displayed
+$q$-expansions and omitting the third.
+
+This is the inductive step in the purely algebraic computation of the degree of the modular equation
+at prime-power level, leading to $[\mathbb{Q}(j)(j_{p^{k}}) : \mathbb{Q}(j)] = \psi(p^{k})$ for
+Dedekind's function $\psi$, equivalently the irreducibility of the modular polynomial $\Phi_{p^{k}}$
+over $\mathbb{Q}(j)$. It is used in the construction of Fricke-type automorphisms and in the
+relative-rank multiplicativity statement for the full level structure.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finrank_adjoin_jqN_pow_succ_of_not_mem.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_finrank_adjoin_jqN_pow_succ_of_not_mem
+
+noncomputable section
+
+p2m_open "ModularCurve~coeffEmb_qExpand \
+  P2MW.S_ModularCurve_finrank_adjoin_jqN_pow_succ_of_not_mem.ModularCurve ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData coeffMap coeffMap_coeff coeffMap_coeffMap coeffMap_id coeffMap_congr \
+  coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  EvalSymm coeffMap_qExpand PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+
+
+
+
+
+
+
+
+
+
+theorem coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb K (qExpand ℚ n x) = qExpand K n (coeffEmb K x) :=
+  coeffMap_qExpand (algebraMap ℚ K) n x
+
+theorem iota_jqN (N d : ℕ) [NeZero N] [NeZero d] :
+    coeffEmb K (qExpand ℚ N (jqN d)) = TS K (N * d) 1 := by
+  rw [jqN, coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem iota_jq (N : ℕ) [NeZero N] : coeffEmb K (qExpand ℚ N jq) = TS K N 1 := by
+  rw [coeffEmb_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_zero_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    conj p ζ (0 : Fin (p + 1)) = TS K (p * p) 1 := by
+  rw [conj_zero, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_succ_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) (b : Fin p) :
+    conj p ζ b.succ = TS K 1 (ζ ^ (b : ℕ)) := by
+  rw [conj_succ, TS_eq_coeffEmb, qExpand_one_apply]
+
+theorem qTwist_iota_of_pow_eq_one (N : ℕ) [NeZero N] (v : Kˣ) (hv : v ^ N = 1) (x : LaurentSeries ℚ)
+    :
+    qTwist v (coeffEmb K (qExpand ℚ N x)) = coeffEmb K (qExpand ℚ N x) := by
+  rw [coeffEmb_qExpand, qTwist_qExpand]
+  have : v ^ (N : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData coeffMap coeffMap_coeff coeffMap_coeffMap coeffMap_id coeffMap_congr \
+  coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  EvalSymm coeffMap_qExpand PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+omit [Algebra ℚ K] in
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+omit [Algebra ℚ K] in
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+omit [Algebra ℚ K] in
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem phiProd_conj_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    phiProd p (conj p ζ) = (Polynomial.X - Polynomial.C (TS K (p * p) 1)) *
+      ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) := by
+  rw [phiProd, Fin.prod_univ_succ, conj_zero_eq]
+  congr 1
+  rw [← Fin.prod_univ_eq_prod_range (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) p]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [conj_succ_eq]
+
+theorem roots_phiProd_conj (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    (phiProd p (conj p ζ)).roots = TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^
+      b)) := by
+  classical
+  rw [phiProd_conj_eq]
+  have h1 : (Polynomial.X - Polynomial.C (TS K (p * p) 1) : Polynomial (LaurentSeries K)) ≠ 0 :=
+    Polynomial.X_sub_C_ne_zero _
+  have h2 : (∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b)))) ≠ 0 :=
+    Finset.prod_ne_zero_iff.mpr fun b _ => Polynomial.X_sub_C_ne_zero _
+  rw [Polynomial.roots_mul (mul_ne_zero h1 h2), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod,
+    Finset.range_val]
+  have hm : (Multiset.map (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) (Multiset.range
+    p)) =
+      ((Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).map (fun a => Polynomial.X - Polynomial.C
+        a) := by
+    rw [Multiset.map_map]; rfl
+  rw [hm, Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+omit [Algebra ℚ K] in
+theorem roots_phiProd_conj_nodup (p : ℕ) [hp : Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).Nodup := by
+  refine Multiset.nodup_cons.mpr ⟨?_, ?_⟩
+  · intro hmem
+    obtain ⟨b, -, hb⟩ := Multiset.mem_map.mp hmem
+    have := (TS_injective hb).1
+    have h2 := hp.out.two_le
+    nlinarith
+  · refine (Multiset.nodup_range p).map_on fun b hb b' hb' hbb' => ?_
+    rw [Multiset.mem_range] at hb hb'
+    have hu := (TS_injective hbb').2
+    have hζu : IsPrimitiveRoot ζ p := IsPrimitiveRoot.coe_units_iff.mp hζ
+    exact hζu.pow_inj hb hb' hu
+
+theorem exists_isPrimitiveRoot_cyclotomicField (N : ℕ) [NeZero N] :
+    ∃ z : CyclotomicField N ℚ, IsPrimitiveRoot z N := by
+  have : NeZero ((N : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr (NeZero.ne N)⟩
+  have : IsCyclotomicExtension {N} ℚ (CyclotomicField N ℚ) :=
+    CyclotomicField.isCyclotomicExtension N ℚ
+  exact IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField N ℚ) (Set.mem_singleton N)
+    (NeZero.ne N)
+
+def cycUnit (N : ℕ) [NeZero N] : (CyclotomicField N ℚ)ˣ :=
+  ((exists_isPrimitiveRoot_cyclotomicField N).choose_spec.isUnit (NeZero.ne N)).unit
+
+theorem cycUnit_spec (N : ℕ) [NeZero N] :
+    IsPrimitiveRoot ((cycUnit N : (CyclotomicField N ℚ)ˣ) : CyclotomicField N ℚ) N := by
+  rw [cycUnit, IsUnit.unit_spec]
+  exact (exists_isPrimitiveRoot_cyclotomicField N).choose_spec
+
+theorem cycUnit_pow (N : ℕ) [NeZero N] : cycUnit N ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, (cycUnit_spec N).pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData coeffMap coeffMap_coeff coeffMap_coeffMap coeffMap_id coeffMap_congr \
+  coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  EvalSymm coeffMap_qExpand PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData coeffMap coeffMap_coeff coeffMap_coeffMap coeffMap_id coeffMap_congr \
+  coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  EvalSymm coeffMap_qExpand PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem prod_form_ne_zero (N : ℕ) (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e]
+    (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K
+            jq)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+          (Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u,
+    Polynomial.roots_mul (prod_form_ne_zero N ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p)))
+    (coeffEmb K jq))))
+        = ((Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+        (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+        (Multiset.range p).map
+          (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).Nodup := by
+  have hζp : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := isPrimitiveRoot_pow_div hζ hpN
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h := (TS_injective (K := K) (e := e) (e' := p * (p * e))
+      (u := u * ζ ^ (b * (N / p))) (u' := u ^ (p * p))
+      (by simpa only [TS_eq_coeffEmb] using heq)).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e)
+      (u := u * ζ ^ (b * (N / p))) (u' := u * ζ ^ (b' * (N / p)))
+      (by simpa only [TS_eq_coeffEmb] using heq)).2
+    have h2 : ζ ^ (b * (N / p)) = ζ ^ (b' * (N / p)) := mul_left_cancel h
+    have h3 : (ζ ^ (N / p)) ^ b = (ζ ^ (N / p)) ^ b' := by
+      rw [← pow_mul, ← pow_mul, Nat.mul_comm (N / p) b, Nat.mul_comm (N / p) b']
+      exact h2
+    have h4 : ((ζ ^ (N / p) : Kˣ) : K) ^ b = ((ζ ^ (N / p) : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h3]
+    exact hζp.pow_inj hb hb' h4
+
+theorem roots_prime_at_slot_roots_nodup (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots.Nodup := by
+  rw [roots_prime_at_slot N ζ hζ p hpN data e u]
+  exact roots_prime_at_slot_nodup N ζ hζ p hpN e u
+
+theorem isRoot_prime_at_slot_iff (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u]
+    exact prod_form_ne_zero N ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot N ζ hζ p hpN data e u,
+    Multiset.mem_cons, Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData coeffMap coeffMap_coeff coeffMap_coeffMap coeffMap_id coeffMap_congr \
+  coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  EvalSymm coeffMap_qExpand PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+
+
+
+
+theorem phiAtSeed_jq_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) :
+    (phiAtSeed data jq).eval (jqN n) = 0 := by
+  have h := data.eval_eq_zero
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp [evalAtJ_X]
+
+
+theorem phiAtSeed_jqN_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN M)).eval (jqN (M * n)) = 0 := by
+  have h := phiAtSeed_eval_map data jq (jqN n) (qExpand ℚ M) (phiAtSeed_jq_eval n data)
+  rwa [jqN, qExpand_qExpand] at h
+
+theorem phiAtSeed_iota_eval {K : Type*} [Field K] [Algebra ℚ K] (A : ℕ) [NeZero A] (n : ℕ)
+    [NeZero n]
+    (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (coeffEmb K (qExpand ℚ A (jqN M)))).eval (coeffEmb K (qExpand ℚ A (jqN (M *
+      n)))) = 0 :=
+  phiAtSeed_eval_map data _ _ ((coeffEmb K).comp (qExpand ℚ A)) (phiAtSeed_jqN_eval n data M)
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData coeffMap coeffMap_coeff coeffMap_coeffMap coeffMap_id coeffMap_congr \
+  coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  EvalSymm coeffMap_qExpand PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+section p2inj
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+theorem coeffEmb_injective' : Function.Injective (coeffEmb K) := by
+  intro x y h
+  ext k
+  have := congrArg (fun z : LaurentSeries K => z.coeff k) h
+  simp only [coeffEmb_coeff] at this
+  exact (algebraMap ℚ K).injective this
+
+theorem iota_injective (A : ℕ) [NeZero A] :
+    Function.Injective ((coeffEmb K).comp (qExpand ℚ A)) :=
+  coeffEmb_injective'.comp (qExpand_injective A)
+
+end p2inj
+
+section transport
+
+variable {K₀ K : Type*} [Field K₀] [Algebra ℚ K₀] [Field K] [Algebra ℚ K]
+
+omit [Algebra ℚ K₀] [Algebra ℚ K] in
+theorem coeffMap_qTwist (σ : K₀ →+* K) (u : K₀ˣ) (f : LaurentSeries K₀) :
+    coeffMap σ (qTwist u f) = qTwist (Units.map σ.toMonoidHom u) (coeffMap σ f) := by
+  ext k
+  simp only [coeffMap_coeff, qTwist_coeff, map_mul]
+  congr 1
+  rw [← map_zpow, Units.coe_map]
+  rfl
+
+theorem coeffMap_coeffEmb_algHom (σ : K₀ →ₐ[ℚ] K) (x : LaurentSeries ℚ) :
+    coeffMap (σ : K₀ →+* K) (coeffEmb K₀ x) = coeffEmb K x := by
+  rw [coeffEmb, coeffEmb, coeffMap_coeffMap]
+  exact coeffMap_congr (σ.comp_algebraMap) x
+
+theorem coeffMap_TS (σ : K₀ →ₐ[ℚ] K) (e : ℕ) [NeZero e] (u : K₀ˣ) :
+    coeffMap (σ : K₀ →+* K) (TS K₀ e u) = TS K e (Units.map (σ : K₀ →+* K).toMonoidHom u) := by
+  rw [TS_eq_coeffEmb, TS_eq_coeffEmb, coeffMap_qExpand, coeffMap_qTwist, coeffMap_coeffEmb_algHom]
+
+end transport
+
+section p2core
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def coeffMapEquiv (τ : K ≃ₐ[ℚ] K) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := coeffMap ((τ : K →ₐ[ℚ] K) : K →+* K)
+  invFun := coeffMap ((τ.symm : K →ₐ[ℚ] K) : K →+* K)
+  left_inv := fun f => by
+    change coeffMap ((τ.symm : K →ₐ[ℚ] K) : K →+* K)
+        (coeffMap ((τ : K →ₐ[ℚ] K) : K →+* K) f) = f
+    have hcomp : ((τ.symm : K →ₐ[ℚ] K) : K →+* K).comp ((τ : K →ₐ[ℚ] K) : K →+* K)
+        = RingHom.id K := RingHom.ext fun x => τ.symm_apply_apply x
+    rw [coeffMap_coeffMap, coeffMap_congr hcomp f, coeffMap_id]
+  right_inv := fun f => by
+    change coeffMap ((τ : K →ₐ[ℚ] K) : K →+* K)
+        (coeffMap ((τ.symm : K →ₐ[ℚ] K) : K →+* K) f) = f
+    have hcomp : ((τ : K →ₐ[ℚ] K) : K →+* K).comp ((τ.symm : K →ₐ[ℚ] K) : K →+* K)
+        = RingHom.id K := RingHom.ext fun x => τ.apply_symm_apply x
+    rw [coeffMap_coeffMap, coeffMap_congr hcomp f, coeffMap_id]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+@[scoped simp] theorem coeffMapEquiv_apply (τ : K ≃ₐ[ℚ] K) (f : LaurentSeries K) :
+    coeffMapEquiv τ f = coeffMap ((τ : K →ₐ[ℚ] K) : K →+* K) f := rfl
+
+private theorem jqN_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) : jqN n = jqN m := by
+  subst h; rfl
+
+private def rUnit (e : ℕ) [NeZero e] {p : ℕ} (ζ : Kˣ) (g : (ZMod p)ˣ) (i : ℕ) :
+    LaurentSeries K :=
+  TS K e (ζ ^ ((g ^ i : (ZMod p)ˣ) : ZMod p).val)
+
+omit [Algebra ℚ K] in
+private theorem range_map_eq_rUnit (p : ℕ) [hp : Fact (Nat.Prime p)] (e : ℕ) [NeZero e]
+    (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) p) (g : (ZMod p)ˣ)
+    (hg : ∀ x : (ZMod p)ˣ, x ∈ Subgroup.zpowers g) :
+    (Multiset.range p).map (fun b => TS K e (ζ ^ b))
+      = TS K e 1 ::ₘ (Multiset.range (p - 1)).map (rUnit e ζ g) := by
+  have hp1 : 0 < p - 1 := by have := hp.out.two_le; omega
+  have horder : orderOf g = p - 1 := by
+    rw [orderOf_eq_card_of_forall_mem_zpowers hg, Nat.card_eq_fintype_card, ZMod.card_units p]
+  have hg1 : g ^ (p - 1) = 1 := by rw [← horder]; exact pow_orderOf_eq_one g
+  have hgmod : ∀ a : ℕ, g ^ a = g ^ (a % (p - 1)) := by
+    intro a
+    conv_lhs => rw [← Nat.div_add_mod a (p - 1)]
+    rw [pow_add, pow_mul, hg1, one_pow, one_mul]
+  have hexp : ∀ {a b : ℕ}, a < p → b < p → ζ ^ a = ζ ^ b → a = b := by
+    intro a b ha hb h
+    refine hζ.pow_inj ha hb ?_
+    have h2 := congrArg Units.val h
+    rwa [Units.val_pow_eq_pow_val, Units.val_pow_eq_pow_val] at h2
+  have hnd1 : ((Multiset.range p).map (fun b => TS K e (ζ ^ b))).Nodup := by
+    refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro a ha b hb h
+    rw [Multiset.mem_range] at ha hb
+    exact hexp ha hb (TS_injective h).2
+  have hnd2 : (TS K e 1 ::ₘ (Multiset.range (p - 1)).map (rUnit e ζ g)).Nodup := by
+    rw [Multiset.nodup_cons]
+    constructor
+    · intro hmem
+      rw [Multiset.mem_map] at hmem
+      obtain ⟨i, hi, hTS⟩ := hmem
+      rw [rUnit] at hTS
+      have h0 : ζ ^ ((g ^ i : (ZMod p)ˣ) : ZMod p).val = ζ ^ (0 : ℕ) := by
+        rw [pow_zero]
+        exact (TS_injective hTS).2
+      have he0 : ((g ^ i : (ZMod p)ˣ) : ZMod p).val = 0 :=
+        hexp (ZMod.val_lt _) hp.out.pos h0
+      have hz : ((g ^ i : (ZMod p)ˣ) : ZMod p) = 0 := by rwa [ZMod.val_eq_zero] at he0
+      exact Units.ne_zero (g ^ i) hz
+    · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range (p - 1))
+      intro a ha b hb h
+      rw [Multiset.mem_range] at ha hb
+      rw [rUnit, rUnit] at h
+      have hval : ((g ^ a : (ZMod p)ˣ) : ZMod p).val = ((g ^ b : (ZMod p)ˣ) : ZMod p).val :=
+        hexp (ZMod.val_lt _) (ZMod.val_lt _) (TS_injective h).2
+      have hcoe : ((g ^ a : (ZMod p)ˣ) : ZMod p) = ((g ^ b : (ZMod p)ˣ) : ZMod p) :=
+        ZMod.val_injective p hval
+      have hgab : (g ^ a : (ZMod p)ˣ) = g ^ b := Units.ext hcoe
+      have ha' : a ∈ Set.Iio (orderOf g) := by rw [horder]; exact ha
+      have hb' : b ∈ Set.Iio (orderOf g) := by rw [horder]; exact hb
+      exact pow_injOn_Iio_orderOf ha' hb' hgab
+  rw [Multiset.Nodup.ext hnd1 hnd2]
+  intro x
+  simp only [Multiset.mem_map, Multiset.mem_range, Multiset.mem_cons]
+  constructor
+  · rintro ⟨b, hb, rfl⟩
+    rcases Nat.eq_zero_or_pos b with rfl | hb0
+    · left
+      rw [pow_zero]
+    · right
+      have hbp : ¬ p ∣ b := fun hdvd => absurd (Nat.le_of_dvd hb0 hdvd) (not_le.mpr hb)
+      have hcop : Nat.Coprime b p := Nat.coprime_comm.mp (hp.out.coprime_iff_not_dvd.mpr hbp)
+      obtain ⟨k, hk⟩ := (Submonoid.mem_powers_iff _ _).mp
+        ((isOfFinOrder_of_finite g).mem_powers_iff_mem_zpowers.mpr
+          (hg (ZMod.unitOfCoprime b hcop)))
+      refine ⟨k % (p - 1), Nat.mod_lt _ hp1, ?_⟩
+      rw [rUnit, ← hgmod, hk, ZMod.coe_unitOfCoprime, ZMod.val_cast_of_lt hb]
+  · rintro (rfl | ⟨i, hi, rfl⟩)
+    · exact ⟨0, hp.out.pos, by rw [pow_zero]⟩
+    · rw [rUnit]
+      exact ⟨((g ^ i : (ZMod p)ˣ) : ZMod p).val, ZMod.val_lt _, rfl⟩
+
+end p2core
+
+theorem phiAtSeed_eval_symm {n : ℕ} [NeZero n] (data : ModularPolynomialData n)
+    (hs : EvalSymm data.Φ) (x y : LaurentSeries ℚ) :
+    (phiAtSeed data x).eval y = (phiAtSeed data y).eval x := by
+  have key : ∀ z : LaurentSeries ℚ, Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries ℚ)) z =
+      (Polynomial.aeval (R := ℤ) z).toRingHom := fun z =>
+    Polynomial.ringHom_ext' (RingHom.ext_int _ _) (by simp)
+  rw [phiAtSeed, phiAtSeed, Polynomial.eval_map, Polynomial.eval_map, key, key]
+  exact hs x y
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData coeffMap coeffMap_coeff coeffMap_coeffMap coeffMap_id coeffMap_congr \
+  coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  EvalSymm coeffMap_qExpand PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.finrank_adjoin_jqN_pow_succ_of_not_mem
+    (F : IntermediateField ℚ (LaurentSeries ℚ)) (p : ℕ) [hp : Fact (Nat.Prime p)] (k : ℕ)
+    (h0 : jqN (p ^ k) ∈ F) (h1 : jqN (p ^ (k + 1)) ∈ F) (hF : jqN (p ^ (k + 2)) ∉ F) :
+    Module.finrank F (IntermediateField.adjoin F ({jqN (p ^ (k + 2))} : Set (LaurentSeries ℚ))) = p
+      := by
+  classical
+  obtain ⟨data, -, hs⟩ := exists_phiIrreducible_evalSymm p
+  set jkF : F := ⟨jqN (p ^ k), h0⟩ with hjkF
+  set jp1F : F := ⟨jqN (p ^ (k + 1)), h1⟩ with hjp1F
+  set Q : Polynomial F := phiAtSeed data jp1F with hQdef
+  have hQmonic : Q.Monic := phiAtSeed_monic data jp1F
+  have hQdeg : Q.natDegree = p + 1 := by
+    rw [hQdef, phiAtSeed_natDegree, dedekindPsi_prime hp.out]
+  have hQmap : Q.map (algebraMap F (LaurentSeries ℚ)) = phiAtSeed data (jqN (p ^ (k + 1))) := by
+    rw [hQdef, phiAtSeed_map]; rfl
+  have hdown : (phiAtSeed data (jqN (p ^ k))).eval (jqN (p ^ (k + 1))) = 0 := by
+    have h := phiAtSeed_jqN_eval p data (p ^ k)
+    rwa [jqN_congr ((pow_succ p k).symm)] at h
+  have hQj : Q.IsRoot jkF := by
+    have h0m : algebraMap F (LaurentSeries ℚ) (Q.eval jkF) = algebraMap F (LaurentSeries ℚ) 0 := by
+      rw [map_zero, ← Polynomial.eval₂_hom, ← Polynomial.eval_map, hQmap,
+        phiAtSeed_eval_symm data hs]
+      exact hdown
+    exact (algebraMap F (LaurentSeries ℚ)).injective h0m
+  set P : Polynomial F := Q /ₘ (Polynomial.X - Polynomial.C jkF) with hPdef
+  have hfact : (Polynomial.X - Polynomial.C jkF) * P = Q :=
+    Polynomial.mul_divByMonic_eq_iff_isRoot.mpr hQj
+  have hPmonic : P.Monic :=
+    Polynomial.Monic.of_mul_monic_left (Polynomial.monic_X_sub_C jkF)
+      (by rw [hfact]; exact hQmonic)
+  have hPdeg : P.natDegree = p := by
+    have h := congrArg Polynomial.natDegree hfact
+    rw [Polynomial.Monic.natDegree_mul (Polynomial.monic_X_sub_C jkF) hPmonic,
+      Polynomial.natDegree_X_sub_C, hQdeg] at h
+    omega
+  have hQroot : Polynomial.aeval (jqN (p ^ (k + 2))) Q = 0 := by
+    rw [← Polynomial.eval_map_algebraMap, hQmap]
+    have h := phiAtSeed_jqN_eval p data (p ^ (k + 1))
+    rwa [jqN_congr ((pow_succ p (k + 1)).symm)] at h
+  have hne2 : jqN (p ^ (k + 2)) ≠ jqN (p ^ k) := by
+    intro h
+    have hA : (jqN (p ^ (k + 2))).coeff (((p ^ (k + 2) : ℕ) : ℤ) * (-1)) = 1 := by
+      rw [jqN, qExpand_coeff_mul]
+      exact coeff_jq_neg_one
+    have hidx : ((p ^ (k + 2) : ℕ) : ℤ) * (-1)
+        = ((p ^ k : ℕ) : ℤ) * (((p * p : ℕ) : ℤ) * (-1)) := by
+      push_cast
+      ring
+    have hB : (jqN (p ^ k)).coeff (((p ^ (k + 2) : ℕ) : ℤ) * (-1)) = 0 := by
+      rw [jqN, hidx, qExpand_coeff_mul]
+      apply coeff_jq_of_lt
+      have h4 : (4 : ℕ) ≤ p * p := Nat.mul_le_mul hp.out.two_le hp.out.two_le
+      have h4' : (4 : ℤ) ≤ ((p * p : ℕ) : ℤ) := by exact_mod_cast h4
+      linarith
+    rw [h] at hA
+    rw [hA] at hB
+    exact one_ne_zero hB
+  have hProot : Polynomial.aeval (jqN (p ^ (k + 2))) P = 0 := by
+    have h : Polynomial.aeval (jqN (p ^ (k + 2))) ((Polynomial.X - Polynomial.C jkF) * P) = 0 := by
+      rw [hfact]; exact hQroot
+    rw [map_mul, map_sub, Polynomial.aeval_X, Polynomial.aeval_C] at h
+    rcases mul_eq_zero.mp h with h1' | h2'
+    · exact absurd (sub_eq_zero.mp h1') hne2
+    · exact h2'
+  have hint : IsIntegral F (jqN (p ^ (k + 2))) :=
+    ⟨P, hPmonic, by rwa [Polynomial.aeval_def] at hProot⟩
+  let K := CyclotomicField p ℚ
+  let ζ : Kˣ := cycUnit p
+  have hζK : IsPrimitiveRoot (ζ : K) p := cycUnit_spec p
+  let ι : LaurentSeries ℚ →+* LaurentSeries K := (coeffEmb K).comp (qExpand ℚ p)
+  let : Algebra F (LaurentSeries K) := (ι.comp (algebraMap F (LaurentSeries ℚ))).toAlgebra
+  have halg : ∀ a : F, algebraMap F (LaurentSeries K) a = ι a := fun a => rfl
+  have hseed : coeffEmb K (qExpand ℚ p (jqN (p ^ (k + 1))))
+      = qExpand K (p * p ^ (k + 1)) (qTwist ((1 : Kˣ) ^ p) (coeffEmb K jq)) := by
+    have h2 : TS K (p * p ^ (k + 1)) 1 = TS K (p * p ^ (k + 1)) ((1 : Kˣ) ^ p) := by
+      rw [one_pow]
+    simpa only [TS_eq_coeffEmb] using (iota_jqN p (p ^ (k + 1))).trans h2
+  have hQmapL : Q.map (algebraMap F (LaurentSeries K))
+      = phiAtSeed data (qExpand K (p * p ^ (k + 1)) (qTwist ((1 : Kˣ) ^ p) (coeffEmb K jq))) := by
+    rw [RingHom.algebraMap_toAlgebra, ← Polynomial.map_map, hQmap, phiAtSeed_map]
+    exact congrArg (phiAtSeed data) hseed
+  have hQroots : (Q.map (algebraMap F (LaurentSeries K))).roots
+      = TS K (p * (p * p ^ (k + 1))) 1
+        ::ₘ (Multiset.range p).map (fun b => TS K (p ^ (k + 1)) (ζ ^ b)) := by
+    rw [hQmapL, phiAtSeed, roots_prime_at_slot p ζ hζK p (dvd_refl p) data (p ^ (k + 1)) 1]
+    congr 1
+    · suffices TS K (p * (p * p ^ (k + 1))) ((1 : Kˣ) ^ (p * p))
+        = TS K (p * (p * p ^ (k + 1))) 1 by
+        simpa only [TS_eq_coeffEmb] using this
+      rw [one_pow]
+    · suffices (Multiset.range p).map (fun b => TS K (p ^ (k + 1)) ((1 : Kˣ) * ζ ^ (b * (p / p))))
+        = (Multiset.range p).map (fun b => TS K (p ^ (k + 1)) (ζ ^ b)) by
+        simpa only [TS_eq_coeffEmb] using this
+      refine Multiset.map_congr rfl fun b _ => ?_
+      rw [Nat.div_self hp.out.pos, mul_one, one_mul]
+  have hQnodup : (Q.map (algebraMap F (LaurentSeries K))).roots.Nodup := by
+    rw [hQmapL, phiAtSeed]
+    exact roots_prime_at_slot_roots_nodup p ζ hζK p (dvd_refl p) data (p ^ (k + 1)) 1
+  have hjL : algebraMap F (LaurentSeries K) jkF = TS K (p ^ (k + 1)) 1 :=
+    (iota_jqN p (p ^ k)).trans (TS_congr (pow_succ' p k).symm 1)
+  have hQPmapL : Q.map (algebraMap F (LaurentSeries K))
+      = (Polynomial.X - Polynomial.C (TS K (p ^ (k + 1)) 1))
+        * P.map (algebraMap F (LaurentSeries K)) := by
+    rw [← hfact, Polynomial.map_mul, Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C, hjL]
+  have hQm0 : Q.map (algebraMap F (LaurentSeries K)) ≠ 0 := (hQmonic.map _).ne_zero
+  have hsum : (Q.map (algebraMap F (LaurentSeries K))).roots
+      = TS K (p ^ (k + 1)) 1 ::ₘ (P.map (algebraMap F (LaurentSeries K))).roots := by
+    rw [hQPmapL, Polynomial.roots_mul (hQPmapL ▸ hQm0), Polynomial.roots_X_sub_C,
+      Multiset.singleton_add]
+  have : IsCyclotomicExtension {p} ℚ K := CyclotomicField.isCyclotomicExtension p ℚ
+  have hirrcyc : Irreducible (Polynomial.cyclotomic p ℚ) :=
+    Polynomial.cyclotomic.irreducible_rat hp.out.pos
+  obtain ⟨g, hg⟩ := IsCyclic.exists_generator (α := (ZMod p)ˣ)
+  have hp1 : 0 < p - 1 := by have := hp.out.two_le; omega
+  have horder : orderOf g = p - 1 := by
+    rw [orderOf_eq_card_of_forall_mem_zpowers hg, Nat.card_eq_fintype_card, ZMod.card_units p]
+  have hg1 : g ^ (p - 1) = 1 := by rw [← horder]; exact pow_orderOf_eq_one g
+  have hgmod : ∀ a : ℕ, g ^ a = g ^ (a % (p - 1)) := by
+    intro a
+    conv_lhs => rw [← Nat.div_add_mod a (p - 1)]
+    rw [pow_add, pow_mul, hg1, one_pow, one_mul]
+  have hsurj : Function.Surjective (hζK.autToPow ℚ) :=
+    ((Nat.bijective_iff_injective_and_card _).mpr
+      ⟨hζK.autToPow_injective (K := ℚ),
+        Nat.card_congr (IsCyclotomicExtension.autEquivPow K hirrcyc).toEquiv⟩).2
+  obtain ⟨τ, hτ⟩ := hsurj g
+  have hτζ : τ (ζ : K) = (ζ : K) ^ ((g : ZMod p)).val := by
+    have h := hζK.autToPow_spec ℚ τ
+    rw [hτ] at h
+    exact h.symm
+  have hτζu : Units.map ((τ : K →ₐ[ℚ] K) : K →+* K).toMonoidHom ζ = ζ ^ ((g : ZMod p)).val :=
+    Units.ext (by rw [Units.coe_map, Units.val_pow_eq_pow_val]; exact hτζ)
+  have hζp1 : ζ ^ p = 1 := cycUnit_pow p
+  have hζmod : ∀ a : ℕ, ζ ^ a = ζ ^ (a % p) := by
+    intro a
+    conv_lhs => rw [← Nat.div_add_mod a p]
+    rw [pow_add, pow_mul, hζp1, one_pow, one_mul]
+  have hstep : ∀ i : ℕ,
+      coeffMapEquiv τ (rUnit (p ^ (k + 1)) ζ g i) = rUnit (p ^ (k + 1)) ζ g (i + 1) := by
+    intro i
+    rw [rUnit, rUnit, coeffMapEquiv_apply, coeffMap_TS (τ : K →ₐ[ℚ] K)]
+    congr 1
+    rw [map_pow, hτζu, ← pow_mul,
+      hζmod (((g : ZMod p)).val * ((g ^ i : (ZMod p)ˣ) : ZMod p).val)]
+    congr 1
+    rw [pow_succ', Units.val_mul, ZMod.val_mul]
+  have hreidx := range_map_eq_rUnit p (p ^ (k + 1)) ζ hζK g hg
+  have hProots : (P.map (algebraMap F (LaurentSeries K))).roots
+      = TS K (p * (p * p ^ (k + 1))) 1
+        ::ₘ (Multiset.range (p - 1)).map (rUnit (p ^ (k + 1)) ζ g) := by
+    have h := hsum.symm.trans hQroots
+    rw [hreidx, Multiset.cons_swap] at h
+    exact (Multiset.cons_inj_right _).mp h
+  have hPnodup : (P.map (algebraMap F (LaurentSeries K))).roots.Nodup := by
+    rw [hsum] at hQnodup
+    exact (Multiset.nodup_cons.mp hQnodup).2
+  have hPsplits : (P.map (algebraMap F (LaurentSeries K))).Splits := by
+    rw [Polynomial.splits_iff_card_roots, hProots, Multiset.card_cons, Multiset.card_map,
+      Multiset.card_range, hPmonic.natDegree_map, hPdeg]
+    have := hp.out.two_le
+    omega
+  have hirr : Irreducible P := by
+    refine Polynomial.irreducible_of_transitive_ringAut P hPmonic hPsplits (coeffMapEquiv τ) ?_
+      (TS K (p * (p * p ^ (k + 1))) 1) (rUnit (p ^ (k + 1)) ζ g) (p - 1) hProots hPnodup ?_ ?_
+    · intro a
+      rw [halg, coeffMapEquiv_apply]
+      exact coeffMap_coeffEmb_algHom (τ : K →ₐ[ℚ] K) (qExpand ℚ p (a : LaurentSeries ℚ))
+    · intro i hi
+      rw [hstep i, rUnit, rUnit]
+      exact congrArg (fun u : (ZMod p)ˣ => TS K (p ^ (k + 1)) (ζ ^ ((u : ZMod p)).val))
+        (hgmod (i + 1))
+    · rintro ⟨f, hf⟩
+      rw [halg] at hf
+      have hval : (f : LaurentSeries ℚ) = jqN (p ^ (k + 2)) := by
+        apply iota_injective (K := K) p
+        change ι (f : LaurentSeries ℚ) = coeffEmb K (qExpand ℚ p (jqN (p ^ (k + 2))))
+        rw [hf, iota_jqN]
+        exact TS_congr (congrArg (p * ·) (pow_succ' p (k + 1)).symm) 1
+      exact hF (hval ▸ f.2)
+  have hmin : P = minpoly F (jqN (p ^ (k + 2))) :=
+    minpoly.eq_of_irreducible_of_monic hirr hProot hPmonic
+  rw [IntermediateField.adjoin.finrank hint, ← hmin, hPdeg]
+
+end
+
+p2m_open "ModularCurve~coeffEmb_qExpand\
+  " in
+open _root_.P2MW.S_ModularCurve_finrank_adjoin_jqN_pow_succ_of_not_mem.ModularCurve in
+theorem solution (F : IntermediateField ℚ (LaurentSeries ℚ)) (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (k : ℕ) (h0 : jqN (p ^ k) ∈ F) (h1 : jqN (p ^ (k + 1)) ∈ F) (hF : jqN (p ^ (k + 2)) ∉ F) :
+    Module.finrank F (IntermediateField.adjoin F ({jqN (p ^ (k + 2))} : Set (LaurentSeries ℚ))) = p
+      :=
+  ModularCurve.finrank_adjoin_jqN_pow_succ_of_not_mem F p k h0 h1 hF
+
+end S_ModularCurve_finrank_adjoin_jqN_pow_succ_of_not_mem
+end P2MW
+export P2MW.S_ModularCurve_finrank_adjoin_jqN_pow_succ_of_not_mem (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.finrank_adjoin_jqN_pow_succ_of_not_mem
+    (F : IntermediateField ℚ (LaurentSeries ℚ)) (p : ℕ) [hp : Fact (Nat.Prime p)] (k : ℕ)
+    (h0 : jqN (p ^ k) ∈ F) (h1 : jqN (p ^ (k + 1)) ∈ F) (hF : jqN (p ^ (k + 2)) ∉ F) :
+    Module.finrank F (IntermediateField.adjoin F ({jqN (p ^ (k + 2))} : Set (LaurentSeries ℚ))) = p
+      :=
+  solution F p k h0 h1 hF
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqN_prime_of_not_mem.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqN_prime_of_not_mem.lean
new file mode 100644
index 0000000000..64428c1808
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_jqN_prime_of_not_mem.lean
@@ -0,0 +1,386 @@
+/-
+Based on Prove2Me node ModularCurve.finrank_adjoin_jqN_prime_of_not_mem
+(fa124ff8-0c37-5ab8-830e-5eb7c5ffb796) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 005b469a-1b37-5b01-8c3c-3e6435a8c493
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_of_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Polynomial_irreducible_of_transitive_ringAut
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree p+1 of j(qᵖ) over a field containing j(q)
+
+Theorem statement: `ModularCurve.finrank_adjoin_jqN_prime_of_not_mem`
+(`fa124ff8-0c37-5ab8-830e-5eb7c5ffb796`), by Claude, 2026-09-05.
+
+Proof: submission `005b469a-1b37-5b01-8c3c-3e6435a8c493`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Work inside the field $\mathbb{Q}((q))$ of Laurent series over $\mathbb{Q}$ (Hahn series with value
+group $\mathbb{Z}$). Here $jq$ denotes the element $q^{-1}\cdot \mathrm{ofPowerSeries}(jNumQ)$, that
+is, the $q$-expansion of the modular $j$-invariant obtained from the integral power series $jNum$
+with rational coefficients by shifting by $q^{-1}$; and for $N \neq 0$, $jqN\,N$ is the image
+$qExpand\ \mathbb{Q}\ N\ jq$ of $jq$ under the ring homomorphism of $\mathbb{Q}((q))$ induced by
+multiplication by $N$ on the exponent group $\mathbb{Z}$, i.e. the substitution $q \mapsto q^{N}$,
+so $jqN\,N$ is the $q$-expansion of $j(q^{N})$. The data are: an intermediate field $F$ of the
+extension $\mathbb{Q} \subseteq \mathbb{Q}((q))$ containing $jq$; a prime number $p$; and the
+hypothesis that $jqN\,p \notin F$. The conclusion is that the $F$-vector space $F(jqN\,p)$, the
+intermediate field generated over $F$ by the single element $jqN\,p$, has finite rank exactly $p+1$;
+that is, $[F(j(q^{p})) : F] = p+1 = \psi(p)$, for every such $F$.
+
+This is the prime-level case of the classical statement that the modular equation $\Phi_N(X,Y)$ has
+degree $\psi(N)$ in each variable and is irreducible over $\mathbb{Q}(j)$, here in the dichotomy
+form valid over an arbitrary intermediate field containing $j(q)$: either $j(q^p)$ already lies in
+$F$, or it generates an extension of degree exactly $p+1$. It feeds the $q$-expansion model of the
+function field of $X_0(N)$, and is used for the non-membership statement
+[`ModularCurve.jqN_prime_not_mem_adjoin`](thm.html#ModularCurve.jqN_prime_not_mem_adjoin), for the
+construction of Atkin–Lehner automorphisms at primes not dividing the level, and in the computation
+of Hecke operators via degeneracy pushforwards.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finrank_adjoin_jqN_prime_of_not_mem.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_finrank_adjoin_jqN_prime_of_not_mem
+
+noncomputable section
+
+p2m_open "ModularCurve~coeffEmb_qExpand \
+  P2MW.S_ModularCurve_finrank_adjoin_jqN_prime_of_not_mem.ModularCurve ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand coeffMap_qExpand PhiGen.splits_of_prime exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+
+
+
+
+
+
+
+
+
+
+theorem coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb K (qExpand ℚ n x) = qExpand K n (coeffEmb K x) :=
+  coeffMap_qExpand (algebraMap ℚ K) n x
+
+theorem iota_jqN (N d : ℕ) [NeZero N] [NeZero d] :
+    coeffEmb K (qExpand ℚ N (jqN d)) = TS K (N * d) 1 := by
+  rw [jqN, coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem iota_jq (N : ℕ) [NeZero N] : coeffEmb K (qExpand ℚ N jq) = TS K N 1 := by
+  rw [coeffEmb_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_zero_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    conj p ζ (0 : Fin (p + 1)) = TS K (p * p) 1 := by
+  rw [conj_zero, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_succ_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) (b : Fin p) :
+    conj p ζ b.succ = TS K 1 (ζ ^ (b : ℕ)) := by
+  rw [conj_succ, TS_eq_coeffEmb, qExpand_one_apply]
+
+theorem qTwist_iota_of_pow_eq_one (N : ℕ) [NeZero N] (v : Kˣ) (hv : v ^ N = 1) (x : LaurentSeries ℚ)
+    :
+    qTwist v (coeffEmb K (qExpand ℚ N x)) = coeffEmb K (qExpand ℚ N x) := by
+  rw [coeffEmb_qExpand, qTwist_qExpand]
+  have : v ^ (N : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand coeffMap_qExpand PhiGen.splits_of_prime exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+omit [Algebra ℚ K] in
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+omit [Algebra ℚ K] in
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+omit [Algebra ℚ K] in
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem phiProd_conj_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    phiProd p (conj p ζ) = (Polynomial.X - Polynomial.C (TS K (p * p) 1)) *
+      ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) := by
+  rw [phiProd, Fin.prod_univ_succ, conj_zero_eq]
+  congr 1
+  rw [← Fin.prod_univ_eq_prod_range (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) p]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [conj_succ_eq]
+
+theorem roots_phiProd_conj (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    (phiProd p (conj p ζ)).roots = TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^
+      b)) := by
+  classical
+  rw [phiProd_conj_eq]
+  have h1 : (Polynomial.X - Polynomial.C (TS K (p * p) 1) : Polynomial (LaurentSeries K)) ≠ 0 :=
+    Polynomial.X_sub_C_ne_zero _
+  have h2 : (∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b)))) ≠ 0 :=
+    Finset.prod_ne_zero_iff.mpr fun b _ => Polynomial.X_sub_C_ne_zero _
+  rw [Polynomial.roots_mul (mul_ne_zero h1 h2), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod,
+    Finset.range_val]
+  have hm : (Multiset.map (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) (Multiset.range
+    p)) =
+      ((Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).map (fun a => Polynomial.X - Polynomial.C
+        a) := by
+    rw [Multiset.map_map]; rfl
+  rw [hm, Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+omit [Algebra ℚ K] in
+theorem roots_phiProd_conj_nodup (p : ℕ) [hp : Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).Nodup := by
+  refine Multiset.nodup_cons.mpr ⟨?_, ?_⟩
+  · intro hmem
+    obtain ⟨b, -, hb⟩ := Multiset.mem_map.mp hmem
+    have := (TS_injective hb).1
+    have h2 := hp.out.two_le
+    nlinarith
+  · refine (Multiset.nodup_range p).map_on fun b hb b' hb' hbb' => ?_
+    rw [Multiset.mem_range] at hb hb'
+    have hu := (TS_injective hbb').2
+    have hζu : IsPrimitiveRoot ζ p := IsPrimitiveRoot.coe_units_iff.mp hζ
+    exact hζu.pow_inj hb hb' hu
+
+theorem exists_isPrimitiveRoot_cyclotomicField (N : ℕ) [NeZero N] :
+    ∃ z : CyclotomicField N ℚ, IsPrimitiveRoot z N := by
+  have : NeZero ((N : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr (NeZero.ne N)⟩
+  have : IsCyclotomicExtension {N} ℚ (CyclotomicField N ℚ) :=
+    CyclotomicField.isCyclotomicExtension N ℚ
+  exact IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField N ℚ) (Set.mem_singleton N)
+    (NeZero.ne N)
+
+def cycUnit (N : ℕ) [NeZero N] : (CyclotomicField N ℚ)ˣ :=
+  ((exists_isPrimitiveRoot_cyclotomicField N).choose_spec.isUnit (NeZero.ne N)).unit
+
+theorem cycUnit_spec (N : ℕ) [NeZero N] :
+    IsPrimitiveRoot ((cycUnit N : (CyclotomicField N ℚ)ˣ) : CyclotomicField N ℚ) N := by
+  rw [cycUnit, IsUnit.unit_spec]
+  exact (exists_isPrimitiveRoot_cyclotomicField N).choose_spec
+
+theorem cycUnit_pow (N : ℕ) [NeZero N] : cycUnit N ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, (cycUnit_spec N).pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand coeffMap_qExpand PhiGen.splits_of_prime exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+
+
+
+
+theorem phiAtSeed_jq_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) :
+    (phiAtSeed data jq).eval (jqN n) = 0 := by
+  have h := data.eval_eq_zero
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp [evalAtJ_X]
+
+
+theorem phiAtSeed_jqN_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN M)).eval (jqN (M * n)) = 0 := by
+  have h := phiAtSeed_eval_map data jq (jqN n) (qExpand ℚ M) (phiAtSeed_jq_eval n data)
+  rwa [jqN, qExpand_qExpand] at h
+
+theorem phiAtSeed_iota_eval {K : Type*} [Field K] [Algebra ℚ K] (A : ℕ) [NeZero A] (n : ℕ)
+    [NeZero n]
+    (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (coeffEmb K (qExpand ℚ A (jqN M)))).eval (coeffEmb K (qExpand ℚ A (jqN (M *
+      n)))) = 0 :=
+  phiAtSeed_eval_map data _ _ ((coeffEmb K).comp (qExpand ℚ A)) (phiAtSeed_jqN_eval n data M)
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand coeffMap_qExpand PhiGen.splits_of_prime exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+theorem coeffEmb_injective' : Function.Injective (coeffEmb K) := by
+  intro x y h
+  ext k
+  have := congrArg (fun z : LaurentSeries K => z.coeff k) h
+  simp only [coeffEmb_coeff] at this
+  exact (algebraMap ℚ K).injective this
+
+theorem iota_injective (A : ℕ) [NeZero A] : Function.Injective ((coeffEmb K).comp (qExpand ℚ A)) :=
+  coeffEmb_injective'.comp (qExpand_injective A)
+
+theorem phiAtSeed_iota_jq_eq_phiProd (p : ℕ) [Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) :
+    phiAtSeed data (coeffEmb K (qExpand ℚ p jq)) = phiProd p (conj p ζ) := by
+  rw [← ModularCurve.PhiGen.splits_of_prime p ζ hζ data, phiAtSeed]
+  congr 1
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp [evalAtJ_X]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand coeffMap_qExpand PhiGen.splits_of_prime exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.finrank_adjoin_jqN_prime_of_not_mem
+    (F : IntermediateField ℚ (LaurentSeries ℚ)) (hj : jq ∈ F) (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (hpF : jqN p ∉ F) :
+    Module.finrank F (IntermediateField.adjoin F ({jqN p} : Set (LaurentSeries ℚ))) = p + 1 := by
+  classical
+  obtain ⟨data, -, -⟩ := exists_phiIrreducible_evalSymm p
+  set jF : F := ⟨jq, hj⟩ with hjF
+  set P : Polynomial F := phiAtSeed data jF with hP
+  have hPmonic : P.Monic := phiAtSeed_monic data jF
+  have hPdeg : P.natDegree = p + 1 := by rw [hP, phiAtSeed_natDegree, dedekindPsi_prime hp.out]
+  have hPmap : P.map (algebraMap F (LaurentSeries ℚ)) = phiAtSeed data jq := by
+    rw [hP, phiAtSeed_map]; rfl
+  have hProot : Polynomial.aeval (jqN p) P = 0 := by
+    rw [← Polynomial.eval_map_algebraMap, hPmap]
+    simpa using phiAtSeed_jqN_eval p data 1
+  have hα : IsIntegral F (jqN p) := ⟨P, hPmonic, by rwa [Polynomial.aeval_def] at hProot⟩
+  let K := CyclotomicField p ℚ
+  let ζ : Kˣ := cycUnit p
+  have hζ : IsPrimitiveRoot (ζ : K) p := cycUnit_spec p
+  let ι : LaurentSeries ℚ →+* LaurentSeries K := (coeffEmb K).comp (qExpand ℚ p)
+  let : Algebra F (LaurentSeries K) := (ι.comp (algebraMap F (LaurentSeries ℚ))).toAlgebra
+  have halg : ∀ a : F, algebraMap F (LaurentSeries K) a = ι a := fun a => rfl
+  have hPmapL : P.map (algebraMap F (LaurentSeries K)) = phiProd p (conj p ζ) := by
+    rw [RingHom.algebraMap_toAlgebra, ← Polynomial.map_map, hPmap, phiAtSeed_map]
+    exact phiAtSeed_iota_jq_eq_phiProd p ζ hζ data
+  have hirr : Irreducible P := by
+    refine Polynomial.irreducible_of_transitive_ringAut P hPmonic ?_ (qTwistEquiv ζ) ?_ (TS K (p *
+      p) 1)
+      (fun b => TS K 1 (ζ ^ b)) p ?_ ?_ ?_ ?_
+    · rw [hPmapL, phiProd]
+      exact Polynomial.Splits.prod fun i _ => Polynomial.Splits.X_sub_C _
+    · intro a
+      rw [halg, qTwistEquiv_apply]
+      exact qTwist_iota_of_pow_eq_one p ζ (cycUnit_pow p) a
+    · rw [hPmapL, roots_phiProd_conj]
+    · rw [hPmapL, roots_phiProd_conj]; exact roots_phiProd_conj_nodup p ζ hζ
+    · intro i _
+      rw [qTwistEquiv_apply]
+      exact qTwist_TS_one_cycle ζ (cycUnit_pow p) i
+    · rintro ⟨f, hf⟩
+      rw [halg] at hf
+      have : (f : LaurentSeries ℚ) = jqN p := by
+        apply iota_injective (K := K) p
+        change ι f = coeffEmb K (qExpand ℚ p (jqN p))
+        rw [hf, iota_jqN]
+      exact hpF (this ▸ f.2)
+  have hmin : P = minpoly F (jqN p) := minpoly.eq_of_irreducible_of_monic hirr hProot hPmonic
+  rw [IntermediateField.adjoin.finrank hα, ← hmin, hPdeg]
+
+p2m_open "ModularCurve~coeffEmb_qExpand\
+  " in
+open _root_.P2MW.S_ModularCurve_finrank_adjoin_jqN_prime_of_not_mem.ModularCurve in
+theorem solution (F : IntermediateField ℚ (LaurentSeries ℚ)) (hj : jq ∈ F) (p : ℕ)
+    [hp : Fact (Nat.Prime p)] (hpF : jqN p ∉ F) :
+    Module.finrank F (IntermediateField.adjoin F ({jqN p} : Set (LaurentSeries ℚ))) = p + 1 :=
+  ModularCurve.finrank_adjoin_jqN_prime_of_not_mem F hj p hpF
+
+end
+end S_ModularCurve_finrank_adjoin_jqN_prime_of_not_mem
+end P2MW
+export P2MW.S_ModularCurve_finrank_adjoin_jqN_prime_of_not_mem (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.finrank_adjoin_jqN_prime_of_not_mem (F : IntermediateField ℚ (LaurentSeries ℚ))
+    (hj : jq ∈ F) (p : ℕ) [hp : Fact (Nat.Prime p)] (hpF : jqN p ∉ F) :
+    Module.finrank F (IntermediateField.adjoin F ({jqN p} : Set (LaurentSeries ℚ))) = p + 1 :=
+  solution F hj p hpF
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_qExpFunctionFieldC_le_of_valuationSubring.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_qExpFunctionFieldC_le_of_valuationSubring.lean
new file mode 100644
index 0000000000..07d6d95be1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_adjoin_qExpFunctionFieldC_le_of_valuationSubring.lean
@@ -0,0 +1,668 @@
+/-
+Based on Prove2Me node ModularCurve.finrank_adjoin_qExpFunctionFieldC_le_of_valuationSubring
+(98ed7cc0-8ae1-5c77-9b65-c245eb5d9113) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d40225bc-86ec-50f4-b3be-3d0f5f2e2d12
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Algebra.GroupWithZero.Submonoid.CancelMulZero
+import Mathlib.Order.CompletePartialOrder
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteDimensional_adjoin_of_transcendental
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree inequality for reduced q-expansion function fields
+
+Theorem statement: `ModularCurve.finrank_adjoin_qExpFunctionFieldC_le_of_valuationSubring`
+(`98ed7cc0-8ae1-5c77-9b65-c245eb5d9113`), by Claude, 2026-09-05.
+
+Proof: submission `d40225bc-86ec-50f4-b3be-3d0f5f2e2d12`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a field $L$ of characteristic zero (an algebra over $\mathbb{Q}$), a valuation subring $A
+\subseteq L$, a field $k$, a ring homomorphism $\pi \colon A \to k$, and an arbitrary subgroup
+$\Gamma \le \mathrm{SL}_2(\mathbb{Z})$. For a field $K$ write $F_K(\Gamma) =$
+[`ModularCurve.qExpFunctionFieldC K Γ`](def/ModularCurve_X1.html#L101) for the intermediate field of
+$K((q))$ generated over $K$ by all quotients $\overline{p_f}/\overline{p_g}$, where $f,g$ are
+modular forms of one and the same integral weight for the image of $\Gamma$ in
+$\mathrm{GL}_2(\mathbb{R})$, $p_f,p_g \in \mathbb{Z}[[q]]$ are integral $q$-expansions of $f$ and
+$g$, the bar denotes coefficientwise reduction into $K((q))$, and $\overline{p_g} \neq 0$; and let
+$F =$ [`ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ
+Γ)`](def/ModularCurve_LaurentCoeff.html#L103) be the subfield of $L((q))$ generated over $L$ by the
+coefficientwise image of $F_{\mathbb{Q}}(\Gamma)$. Assume $F$ contains an element $t$ transcendental
+over $L$ with $F$ finite over $L(t)$. Let $a,b \in \mathbb{Z}[[q]]$, let $X \in F$ have underlying
+Laurent series $\bar a/\bar b$ over $L$, let $x \in F_k(\Gamma)$ have underlying Laurent series
+$\bar a/\bar b$ over $k$, and assume $x$ is transcendental over $k$. Then $F_k(\Gamma)$ is finite
+over $k(x)$ and $[F_k(\Gamma):k(x)] \le [F:L(X)]$, the ranks being `Module.finrank`. The valuation
+subring $A$ and the map $\pi$ enter only as data: no hypothesis relates them to $a$, $b$, $X$ or
+$x$, the comparison between the two characteristics being carried entirely by the shared pair of
+integral power series.
+
+This is the elementary half of Deuring's theory of reduction of a function field of one variable
+with respect to a place of its constant field, in the concrete $q$-expansion presentation used for
+modular curves: the inequality requires no integral model and no good-reduction hypothesis. It is
+used in the comparisons of degrees and indices for the $q$-expansion function fields of
+$\Gamma_0(M)$ and $\Gamma_H$, and in the study of the reduction of $q$-expansions modulo a prime.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finrank_adjoin_qExpFunctionFieldC_le_of_valuationSubring.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 6400000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_finrank_adjoin_qExpFunctionFieldC_le_of_valuationSubring
+
+
+noncomputable section
+
+p2m_open "Polynomial IntermediateField HahnSeries ModularCurve \
+  P2MW.S_ModularCurve_finrank_adjoin_qExpFunctionFieldC_le_of_valuationSubring.ModularCurve"
+open scoped BigOperators
+
+namespace ModularCurve
+p2m_export "ModularCurve" "intSeriesC intSeriesC_zero intSeriesC_mul intFormRatiosC \
+  qExpFunctionFieldC div_mem_qExpFunctionFieldC ofPowerSeries_coeff_of_neg coeffMap coeffMap_coeff \
+  algebraMap_laurentSeries_eq_single coeffEmb laurentBaseChange coeffEmb_mem_laurentBaseChange"
+namespace QExpDeuringIneq
+p2m_open "ModularCurve"
+
+section PolyLinear
+
+variable {K E : Type*} [Field K] [Field E] [Algebra K E]
+
+theorem exists_polynomial_of_not_linearIndependent {ι : Type*} [Fintype ι] (α : E) (v : ι → E)
+    (h : ¬ LinearIndependent K⟮α⟯ v) :
+    ∃ P : ι → K[X], (∃ i, P i ≠ 0) ∧ ∑ i, aeval α (P i) * v i = 0 := by
+  classical
+  obtain ⟨c, hc0, i₀, hi₀⟩ := Fintype.not_linearIndependent_iff.mp h
+  have hfrac : ∀ i, ∃ rs : K[X] × K[X], aeval α rs.2 ≠ 0 ∧ ((c i : K⟮α⟯) : E) * aeval α rs.2 = aeval
+    α rs.1 :=
+    by
+    intro i
+    obtain ⟨r, s, hrs⟩ := (mem_adjoin_simple_iff K ((c i : K⟮α⟯) : E)).mp (c i).2
+    by_cases hs : aeval α s = 0
+    · refine ⟨(0, 1), by simp, ?_⟩
+      simp only [map_one, mul_one, map_zero]
+      rw [hrs, hs, div_zero]
+    · exact ⟨(r, s), hs, by rw [hrs, div_mul_cancel₀ _ hs]⟩
+  choose rs hrs0 hrs using hfrac
+  refine ⟨fun i => (rs i).1 * ∏ j ∈ Finset.univ.erase i, (rs j).2, ⟨i₀, ?_⟩, ?_⟩
+  · have hr0 : (rs i₀).1 ≠ 0 := by
+      intro h0
+      apply hi₀
+      have h1 := hrs i₀
+      rw [h0, map_zero, mul_eq_zero] at h1
+      rcases h1 with h1 | h1
+      · exact Subtype.ext h1
+      · exact absurd h1 (hrs0 i₀)
+    refine mul_ne_zero hr0 (Finset.prod_ne_zero_iff.mpr fun j _ h0 => hrs0 j ?_)
+    rw [h0, map_zero]
+  · have hc0' : ∑ i, ((c i : K⟮α⟯) : E) * v i = 0 := by
+      simpa only [IntermediateField.smul_def, smul_eq_mul] using hc0
+    calc ∑ i, aeval α ((rs i).1 * ∏ j ∈ Finset.univ.erase i, (rs j).2) * v i
+        = ∑ i, (∏ j, aeval α (rs j).2) * (((c i : K⟮α⟯) : E) * v i) := by
+          refine Finset.sum_congr rfl fun i _ => ?_
+          rw [map_mul, map_prod, ← hrs i,
+            ← Finset.mul_prod_erase Finset.univ (fun j => aeval α (rs j).2) (Finset.mem_univ i)]
+          ring
+      _ = 0 := by rw [← Finset.mul_sum, hc0', mul_zero]
+
+theorem exists_coeff_of_not_linearIndependent {ι : Type*} [Fintype ι] (α : E) (v : ι → E)
+    (h : ¬ LinearIndependent K⟮α⟯ v) :
+    ∃ (D : ℕ) (c : ι → ℕ → K), (∃ i, ∃ m ∈ Finset.range D, c i m ≠ 0) ∧
+      ∑ i, (∑ m ∈ Finset.range D, algebraMap K E (c i m) * α ^ m) * v i = 0 := by
+  classical
+  obtain ⟨P, ⟨i₀, hi₀⟩, hrel⟩ := exists_polynomial_of_not_linearIndependent α v h
+  set D : ℕ := (Finset.univ.sup fun i => (P i).natDegree) + 1 with hD
+  have hlt : ∀ i, (P i).natDegree < D := fun i =>
+    Nat.lt_succ_of_le (Finset.le_sup (f := fun i => (P i).natDegree) (Finset.mem_univ i))
+  refine ⟨D, fun i m => (P i).coeff m, ⟨i₀, (P i₀).natDegree, Finset.mem_range.mpr (hlt i₀), ?_⟩,
+    ?_⟩
+  · change (P i₀).coeff (P i₀).natDegree ≠ 0
+    rw [Polynomial.coeff_natDegree]
+    exact fun h0 => hi₀ (Polynomial.leadingCoeff_eq_zero.mp h0)
+  · rw [← hrel]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [aeval_eq_sum_range' (hlt i)]
+    simp only [Algebra.smul_def]
+
+theorem coeff_eq_zero_of_linearIndependent {ι : Type*} [Fintype ι] {α : E} (hα : Transcendental K α)
+    {v : ι → E} (hv : LinearIndependent K⟮α⟯ v) (D : ℕ) (c : ι → ℕ → K)
+    (h : ∑ i, (∑ m ∈ Finset.range D, algebraMap K E (c i m) * α ^ m) * v i = 0) :
+    ∀ i, ∀ m ∈ Finset.range D, c i m = 0 := by
+  classical
+  set P : ι → K[X] := fun i => ∑ m ∈ Finset.range D, Polynomial.C (c i m) * Polynomial.X ^ m with hP
+  have hPeval : ∀ i, aeval α (P i) = ∑ m ∈ Finset.range D, algebraMap K E (c i m) * α ^ m :=
+    fun i => by
+    simp only [hP, map_sum, map_mul, aeval_C, map_pow, aeval_X]
+  have hmem : ∀ i, aeval α (P i) ∈ K⟮α⟯ := fun i =>
+    algebra_adjoin_le_adjoin K _ (aeval_mem_adjoin_singleton K α)
+  set g : ι → K⟮α⟯ := fun i => ⟨aeval α (P i), hmem i⟩ with hg
+  have hrel : ∑ i, g i • v i = 0 := by
+    simp only [hg, IntermediateField.smul_def, smul_eq_mul]
+    show ∑ i, aeval α (P i) * v i = 0
+    simpa only [hPeval] using h
+  have hg0 := Fintype.linearIndependent_iff.mp hv g hrel
+  intro i m hm
+  have hPi : aeval α (P i) = 0 := congrArg Subtype.val (hg0 i)
+  have hPi0 : P i = 0 := transcendental_iff_injective.mp hα (by rw [hPi, map_zero])
+  have := congrArg (fun p : K[X] => p.coeff m) hPi0
+  simp only [hP, finsetSum_coeff, coeff_C_mul_X_pow, Polynomial.coeff_zero, Finset.sum_ite_eq,
+    ite_eq_left hm] at this
+  exact this
+
+end PolyLinear
+
+section IntSeries
+
+def zcoeff (w : PowerSeries ℤ) (n : ℤ) : ℤ := if n < 0 then 0 else PowerSeries.coeff n.toNat w
+
+theorem coeff_intSeriesC (K : Type*) [Field K] (w : PowerSeries ℤ) (n : ℤ) :
+    (intSeriesC K w).coeff n = (zcoeff w n : K) := by
+  rcases lt_or_ge n 0 with hn | hn
+  · rw [intSeriesC, ofPowerSeries_coeff_of_neg _ hn, zcoeff, ite_eq_left hn, Int.cast_zero]
+  · lift n to ℕ using hn with n
+    rw [intSeriesC, HahnSeries.ofPowerSeries_apply_coeff, PowerSeries.coeff_map, eq_intCast, zcoeff,
+      ite_eq_right (by omega), Int.toNat_natCast]
+
+def ι (K : Type*) [Field K] : PowerSeries ℤ →+* LaurentSeries K :=
+  (HahnSeries.ofPowerSeries ℤ K).comp (PowerSeries.map (Int.castRingHom K))
+
+theorem ι_apply (K : Type*) [Field K] (w : PowerSeries ℤ) : ι K w = intSeriesC K w := rfl
+
+theorem coeff_algebraMap_mul (K : Type*) [Field K] (r : K) (z : LaurentSeries K) (n : ℤ) :
+    (algebraMap K (LaurentSeries K) r * z).coeff n = r * z.coeff n := by
+  rw [ModularCurve.algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_zero_mul]
+
+variable {L : Type*} [Field L]
+variable {k : Type*} [Field k]
+
+theorem exists_reduced_relation (A : ValuationSubring L) (π : A →+* k)
+    {J : Type*} (s : Finset J) (α : J → L) (w : J → PowerSeries ℤ)
+    (hrel : ∑ j ∈ s, algebraMap L (LaurentSeries L) (α j) * intSeriesC L (w j) = 0)
+    (hne : ∃ j ∈ s, α j ≠ 0) :
+    ∃ β : J → k, (∃ j ∈ s, β j ≠ 0) ∧ ∑ j ∈ s, algebraMap k (LaurentSeries k) (β j) * intSeriesC k
+      (w j) = 0 := by
+  classical
+  obtain ⟨j₀, hj₀s, hj₀⟩ := hne
+  obtain ⟨j₁, hj₁s, hmax⟩ := Finset.exists_max_image s (fun j => A.valuation (α j)) ⟨j₀, hj₀s⟩
+  have hα₁ : α j₁ ≠ 0 := by
+    intro h0
+    apply hj₀
+    have h := hmax j₀ hj₀s
+    rw [h0, map_zero, le_zero_iff, Valuation.zero_iff] at h
+    exact h
+  have hv₁ : 0 < A.valuation (α j₁) := (Valuation.pos_iff _).mpr hα₁
+  have hmemA : ∀ j ∈ s, α j / α j₁ ∈ A := fun j hj => by
+    rw [← A.valuation_le_one_iff, map_div₀]
+    exact (div_le_one₀ hv₁).mpr (hmax j hj)
+  set δ : J → A := fun j => if hj : j ∈ s then ⟨α j / α j₁, hmemA j hj⟩ else 0 with hδ
+  have hδval : ∀ j ∈ s, ((δ j : A) : L) = α j / α j₁ := fun j hj => by
+    rw [hδ]; simp only [dite_eq_left hj]
+  have hδ₁ : δ j₁ = 1 := Subtype.ext (by rw [hδval j₁ hj₁s, div_self hα₁]; rfl)
+  have hrel' : ∑ j ∈ s, algebraMap L (LaurentSeries L) (α j / α j₁) * intSeriesC L (w j) = 0 := by
+    have : ∑ j ∈ s, algebraMap L (LaurentSeries L) (α j / α j₁) * intSeriesC L (w j) =
+        algebraMap L (LaurentSeries L) (α j₁)⁻¹ *
+          ∑ j ∈ s, algebraMap L (LaurentSeries L) (α j) * intSeriesC L (w j) := by
+      rw [Finset.mul_sum]
+      refine Finset.sum_congr rfl fun j _ => ?_
+      rw [← mul_assoc, ← map_mul, div_eq_inv_mul]
+    rw [this, hrel, mul_zero]
+  have hcoefA : ∀ n : ℤ, ∑ j ∈ s, δ j * (zcoeff (w j) n : A) = 0 := by
+    intro n
+    have h := congrArg (fun z : LaurentSeries L => z.coeff n) hrel'
+    simp only [HahnSeries.coeff_sum, coeff_algebraMap_mul, HahnSeries.coeff_zero,
+      coeff_intSeriesC] at h
+    apply Subtype.val_injective
+    push_cast
+    refine Eq.trans (Finset.sum_congr rfl fun j hj => ?_) h
+    rw [hδval j hj]
+  refine ⟨fun j => π (δ j), ⟨j₁, hj₁s, ?_⟩, ?_⟩
+  · change π (δ j₁) ≠ 0
+    rw [hδ₁, map_one]; exact one_ne_zero
+  ext n
+  rw [HahnSeries.coeff_sum, HahnSeries.coeff_zero]
+  simp only [coeff_algebraMap_mul, coeff_intSeriesC]
+  have h := congrArg π (hcoefA n)
+  rw [map_sum, map_zero] at h
+  rw [← h]
+  refine Finset.sum_congr rfl fun j _ => ?_
+  rw [map_mul, map_intCast]
+
+end IntSeries
+
+section KeyBound
+
+variable {L : Type*} [Field L] [Algebra ℚ L]
+variable {k : Type*} [Field k]
+variable {Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)}
+
+abbrev FL (L : Type*) [Field L] [Algebra ℚ L] (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) :
+    Type _ :=
+  laurentBaseChange L (qExpFunctionFieldC ℚ Γ)
+
+abbrev FK (k : Type*) [Field k] (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) : Type _ :=
+  qExpFunctionFieldC k Γ
+
+def monomials (L : Type*) [Field L] [Algebra ℚ L] (k : Type*) [Field k]
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) : Set (FK k Γ) :=
+  {y | ∃ c e : PowerSeries ℤ, intSeriesC k e ≠ 0 ∧
+    intSeriesC L c / intSeriesC L e ∈ laurentBaseChange L (qExpFunctionFieldC ℚ Γ) ∧
+      (y : LaurentSeries k) = intSeriesC k c / intSeriesC k e}
+
+theorem charZero_L (L : Type*) [Field L] [Algebra ℚ L] : CharZero L :=
+  charZero_of_injective_algebraMap (algebraMap ℚ L).injective
+
+theorem intSeriesC_injective (K : Type*) [Field K] [CharZero K] :
+    Function.Injective (intSeriesC K) :=
+  HahnSeries.ofPowerSeries_injective.comp
+    (PowerSeries.map_injective (Int.castRingHom K) Int.cast_injective)
+
+variable (L) in
+theorem intSeriesC_ne_zero_of_ne_zero {e : PowerSeries ℤ} (he : intSeriesC k e ≠ 0) :
+    intSeriesC L e ≠ 0 := by
+  have := charZero_L L
+  intro h0
+  apply he
+  have : e = 0 := intSeriesC_injective L (h0.trans (intSeriesC_zero L).symm)
+  rw [this, intSeriesC_zero]
+
+theorem coeffMap_intSeriesC {R S : Type*} [Field R] [Field S] (g : R →+* S) (p : PowerSeries ℤ) :
+    coeffMap g (intSeriesC R p) = intSeriesC S p := by
+  ext n
+  rw [coeffMap_coeff, coeff_intSeriesC, coeff_intSeriesC, map_intCast]
+
+theorem intFormRatiosC_subset_monomials {y : FK k Γ}
+    (hy : (y : LaurentSeries k) ∈ intFormRatiosC k Γ) :
+    y ∈ monomials L k Γ := by
+  obtain ⟨κ, f, g, pf, pg, hf, hg, hg0, hyeq⟩ := hy
+  refine ⟨pf, pg, hg0, ?_, hyeq⟩
+  have hg0ℚ : intSeriesC ℚ pg ≠ 0 := by
+    intro h0; apply hg0
+    have : pg = 0 := intSeriesC_injective ℚ (h0.trans (intSeriesC_zero ℚ).symm)
+    rw [this, intSeriesC_zero]
+  have h := coeffEmb_mem_laurentBaseChange L (div_mem_qExpFunctionFieldC f g hf hg hg0ℚ)
+  rwa [map_div₀, coeffEmb, coeffMap_intSeriesC, coeffMap_intSeriesC] at h
+
+theorem one_mem_monomials : (1 : FK k Γ) ∈ monomials L k Γ :=
+  ⟨1, 1, by simp, by simp, by simp⟩
+
+theorem mul_mem_monomials {y z : FK k Γ} (hy : y ∈ monomials L k Γ) (hz : z ∈ monomials L k Γ) :
+    y * z ∈ monomials L k Γ := by
+  obtain ⟨c, e, he, hce, hyv⟩ := hy
+  obtain ⟨c', e', he', hce', hzv⟩ := hz
+  refine ⟨c * c', e * e', ?_, ?_, ?_⟩
+  · rw [intSeriesC_mul]; exact mul_ne_zero he he'
+  · rw [intSeriesC_mul, intSeriesC_mul, mul_div_mul_comm]
+    exact mul_mem hce hce'
+  · rw [MulMemClass.coe_mul, hyv, hzv, intSeriesC_mul, intSeriesC_mul, mul_div_mul_comm]
+
+theorem div_pow_mul_pow {K : Type*} [Field K] {a b : K} (hb : b ≠ 0) {m N : ℕ} (hm : m ≤ N) :
+    (a / b) ^ m * b ^ N = a ^ m * b ^ (N - m) := by
+  have h : b ^ N = b ^ (N - m) * b ^ m := by rw [← _root_.pow_add, Nat.sub_add_cancel hm]
+  rw [h, div_pow, div_mul_eq_mul_div, mul_div_assoc, mul_div_cancel_right₀ _ (pow_ne_zero _ hb)]
+
+theorem clear_term₁ {K : Type*} [Field K] (a b : PowerSeries ℤ) (hbK : ι K b ≠ 0)
+    (Z : LaurentSeries K)
+    (hZ : Z = ι K a / ι K b) (r : K) {m D : ℕ} (hm : m ≤ D) :
+    algebraMap K (LaurentSeries K) r * Z ^ m * ι K b ^ D = algebraMap K (LaurentSeries K) r * ι K (a
+      ^ m * b ^ (D - m)) := by
+  rw [map_mul, map_pow, map_pow, hZ, mul_assoc, div_pow_mul_pow hbK hm]
+
+theorem clear_term {K : Type*} [Field K] (a b : PowerSeries ℤ) {n : ℕ} (c e : Fin n → PowerSeries ℤ)
+    (heK : ∀ j, ι K (e j) ≠ 0) (hbK : ι K b ≠ 0) (Z : LaurentSeries K) (hZ : Z = ι K a / ι K b)
+    (r : K) (i : Fin n) {m D : ℕ} (hm : m ≤ D) :
+    algebraMap K (LaurentSeries K) r * Z ^ m * (ι K (c i) / ι K (e i)) * (ι K b ^ D * ι K (∏ j, e
+      j)) =
+      algebraMap K (LaurentSeries K) r *
+        ι K (a ^ m * b ^ (D - m) * (c i * ∏ j ∈ Finset.univ.erase i, e j)) := by
+  classical
+  have hCeq : ι K (c i) / ι K (e i) * ι K (∏ j, e j) = ι K (c i * ∏ j ∈ Finset.univ.erase i, e j) :=
+    by
+    rw [map_mul, map_prod, map_prod, ← Finset.mul_prod_erase Finset.univ (fun j => ι K (e j))
+      (Finset.mem_univ i),
+      ← mul_assoc, div_mul_cancel₀ _ (heK i)]
+  rw [map_mul (ι K) (a ^ m * b ^ (D - m)), ← hCeq, map_mul, map_pow, map_pow, hZ, ← div_pow_mul_pow
+    hbK hm]
+  ring
+
+theorem card_le_finrank_of_linearIndependent (A : ValuationSubring L) (π : A →+* k)
+    (a b : PowerSeries ℤ) (X : FL L Γ)
+    (hX : (X : LaurentSeries L) = intSeriesC L a / intSeriesC L b)
+    [FiniteDimensional L⟮X⟯ (FL L Γ)]
+    (x : FK k Γ) (hx : (x : LaurentSeries k) = intSeriesC k a / intSeriesC k b)
+    (htr : Transcendental k x)
+    {n : ℕ} (y : Fin n → FK k Γ) (hy : ∀ i, y i ∈ monomials L k Γ) (hli : LinearIndependent k⟮x⟯ y)
+    :
+    n ≤ Module.finrank L⟮X⟯ (FL L Γ) := by
+  classical
+  have hbk : intSeriesC k b ≠ 0 := by
+    intro h0
+    apply htr
+    have : x = 0 := Subtype.ext (by rw [hx, h0, div_zero]; rfl)
+    rw [this]; exact isAlgebraic_zero
+  have hbL : intSeriesC L b ≠ 0 := intSeriesC_ne_zero_of_ne_zero L hbk
+  choose c e he hce hyv using hy
+  have heL : ∀ i, intSeriesC L (e i) ≠ 0 := fun i => intSeriesC_ne_zero_of_ne_zero L (he i)
+  let V : Fin n → FL L Γ := fun i => ⟨intSeriesC L (c i) / intSeriesC L (e i), hce i⟩
+  have hVcoe : ∀ i, (V i : LaurentSeries L) = intSeriesC L (c i) / intSeriesC L (e i) :=
+    fun i => rfl
+  by_contra hlt
+  push Not at hlt
+  have hdep : ¬ LinearIndependent L⟮X⟯ V := fun hVli => by
+    have := hVli.fintype_card_le_finrank
+    rw [Fintype.card_fin] at this
+    omega
+  obtain ⟨D, γ, ⟨i₀, m₀, hm₀, hγ0⟩, hrel⟩ := exists_coeff_of_not_linearIndependent X V hdep
+  have hrelL : ∑ i, (∑ m ∈ Finset.range D, algebraMap L (LaurentSeries L) (γ i m) * (X :
+    LaurentSeries L) ^ m) *
+      (ι L (c i) / ι L (e i)) = 0 := by
+    have h := congrArg (fun z : FL L Γ => (z : LaurentSeries L)) hrel
+    simp only [AddSubmonoidClass.coe_finsetSum, MulMemClass.coe_mul, SubmonoidClass.coe_pow,
+      SubalgebraClass.coe_algebraMap, ZeroMemClass.coe_zero, hVcoe] at h
+    exact h
+  simp only [← ι_apply] at hX hx he heL hbk hbL hyv
+  let w : Fin n × ℕ → PowerSeries ℤ :=
+    fun im => a ^ im.2 * b ^ (D - im.2) * (c im.1 * ∏ j ∈ Finset.univ.erase im.1, e j)
+  have hw : ∀ i m, w (i, m) = a ^ m * b ^ (D - m) * (c i * ∏ j ∈ Finset.univ.erase i, e j) :=
+    fun _ _ => rfl
+  have hBL : ι L (∏ j, e j) ≠ 0 := by
+    rw [map_prod]; exact Finset.prod_ne_zero_iff.mpr fun j _ => heL j
+  have hBk : ι k (∏ j, e j) ≠ 0 := by
+    rw [map_prod]; exact Finset.prod_ne_zero_iff.mpr fun j _ => he j
+  have hcleared : ∑ im ∈ (Finset.univ : Finset (Fin n)) ×ˢ Finset.range D,
+      algebraMap L (LaurentSeries L) (γ im.1 im.2) * intSeriesC L (w im) = 0 := by
+    have h := congrArg (fun z => z * (ι L b ^ D * ι L (∏ j, e j))) hrelL
+    simp only [zero_mul] at h
+    rw [← h, Finset.sum_mul, Finset.sum_product]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [Finset.sum_mul, Finset.sum_mul]
+    refine Finset.sum_congr rfl fun m hm => ?_
+    rw [hw, ← ι_apply]
+    exact (clear_term a b c e heL hbL _ hX (γ i m) i (Finset.mem_range.mp hm).le).symm
+  obtain ⟨β, ⟨⟨i₁, m₁⟩, him₁, hβ0⟩, hred⟩ :=
+    exists_reduced_relation A π _ (fun im : Fin n × ℕ => γ im.1 im.2) w
+    hcleared ⟨(i₀, m₀), Finset.mem_product.mpr ⟨Finset.mem_univ _, hm₀⟩, hγ0⟩
+  have hunclear : (∑ i, (∑ m ∈ Finset.range D, algebraMap k (LaurentSeries k) (β (i, m)) *
+      (x : LaurentSeries k) ^ m) * (ι k (c i) / ι k (e i))) * (ι k b ^ D * ι k (∏ j, e j)) = 0 := by
+    rw [← hred, Finset.sum_mul, Finset.sum_product]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [Finset.sum_mul, Finset.sum_mul]
+    refine Finset.sum_congr rfl fun m hm => ?_
+    rw [hw, ← ι_apply]
+    exact clear_term a b c e he hbk _ hx (β (i, m)) i (Finset.mem_range.mp hm).le
+  have hrelk : ∑ i, (∑ m ∈ Finset.range D, algebraMap k (LaurentSeries k) (β (i, m)) *
+      (x : LaurentSeries k) ^ m) * (ι k (c i) / ι k (e i)) = 0 := by
+    rcases mul_eq_zero.mp hunclear with h | h
+    · exact h
+    · exact absurd h (mul_ne_zero (pow_ne_zero _ hbk) hBk)
+  have hrelF : ∑ i, (∑ m ∈ Finset.range D, algebraMap k (FK k Γ) (β (i, m)) * x ^ m) * y i = 0 := by
+    apply Subtype.val_injective
+    simp only [AddSubmonoidClass.coe_finsetSum, MulMemClass.coe_mul, SubmonoidClass.coe_pow,
+      SubalgebraClass.coe_algebraMap, ZeroMemClass.coe_zero, hyv]
+    exact hrelk
+  have hall := coeff_eq_zero_of_linearIndependent htr hli D (fun i m => β (i, m)) hrelF
+  obtain ⟨-, hm₁⟩ := Finset.mem_product.mp him₁
+  exact hβ0 (hall i₁ m₁ hm₁)
+
+end KeyBound
+
+section Assembly
+
+variable {L : Type*} [Field L] [Algebra ℚ L]
+variable {k : Type*} [Field k]
+
+theorem transcendental_upstairs (A : ValuationSubring L) (π : A →+* k)
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) (a b : PowerSeries ℤ) (X : FL L Γ)
+    (hX : (X : LaurentSeries L) = intSeriesC L a / intSeriesC L b)
+    (x : FK k Γ) (hx : (x : LaurentSeries k) = intSeriesC k a / intSeriesC k b)
+    (htr : Transcendental k x) :
+    Transcendental L X := by
+  classical
+  have hbk : intSeriesC k b ≠ 0 := by
+    intro h0
+    apply htr
+    have : x = 0 := Subtype.ext (by rw [hx, h0, div_zero]; rfl)
+    rw [this]; exact isAlgebraic_zero
+  have hbL : intSeriesC L b ≠ 0 := intSeriesC_ne_zero_of_ne_zero L hbk
+  intro halg
+  obtain ⟨P, hP0, hPX⟩ := halg
+  have hPL : ∑ m ∈ Finset.range (P.natDegree + 1),
+      algebraMap L (LaurentSeries L) (P.coeff m) * (X : LaurentSeries L) ^ m = 0 := by
+    have h := congrArg (fun z : FL L Γ => (z : LaurentSeries L)) hPX
+    simp only [ZeroMemClass.coe_zero] at h
+    rw [← IntermediateField.coe_val, ← aeval_algHom_apply, aeval_eq_sum_range' (Nat.lt_add_one _),
+      IntermediateField.coe_val] at h
+    simpa only [Algebra.smul_def] using h
+  simp only [← ι_apply] at hX hx hbk hbL
+  let w : ℕ → PowerSeries ℤ := fun m => a ^ m * b ^ (P.natDegree + 1 - m)
+  have hw : ∀ m, w m = a ^ m * b ^ (P.natDegree + 1 - m) := fun _ => rfl
+  have hcleared : ∑ m ∈ Finset.range (P.natDegree + 1),
+      algebraMap L (LaurentSeries L) (P.coeff m) * intSeriesC L (w m) = 0 := by
+    have h := congrArg (fun z => z * ι L b ^ (P.natDegree + 1)) hPL
+    simp only [zero_mul] at h
+    rw [← h, Finset.sum_mul]
+    refine Finset.sum_congr rfl fun m hm => ?_
+    rw [hw, ← ι_apply]
+    exact (clear_term₁ a b hbL _ hX _ (Finset.mem_range.mp hm).le).symm
+  have hne : ∃ m ∈ Finset.range (P.natDegree + 1), P.coeff m ≠ 0 :=
+    ⟨P.natDegree, Finset.mem_range.mpr (Nat.lt_add_one _), fun h0 => hP0 (leadingCoeff_eq_zero.mp
+      h0)⟩
+  obtain ⟨β, ⟨m₁, hm₁, hβ0⟩, hred⟩ :=
+    exists_reduced_relation A π _ (fun m => P.coeff m) w hcleared hne
+  have hunclear : (∑ m ∈ Finset.range (P.natDegree + 1),
+      algebraMap k (LaurentSeries k) (β m) * (x : LaurentSeries k) ^ m) * ι k b ^ (P.natDegree + 1)
+        = 0 := by
+    rw [← hred, Finset.sum_mul]
+    refine Finset.sum_congr rfl fun m hm => ?_
+    rw [hw, ← ι_apply]
+    exact clear_term₁ a b hbk _ hx _ (Finset.mem_range.mp hm).le
+  have hrelk : ∑ m ∈ Finset.range (P.natDegree + 1),
+      algebraMap k (LaurentSeries k) (β m) * (x : LaurentSeries k) ^ m = 0 := by
+    rcases mul_eq_zero.mp hunclear with h | h
+    · exact h
+    · exact absurd h (pow_ne_zero _ hbk)
+  set Q : k[X] := ∑ m ∈ Finset.range (P.natDegree + 1), Polynomial.C (β m) * Polynomial.X ^ m with
+    hQ
+  have hQx : aeval x Q = 0 := by
+    apply Subtype.val_injective
+    rw [← IntermediateField.coe_val, ← aeval_algHom_apply, IntermediateField.coe_val]
+    simp only [hQ, map_sum, map_mul, aeval_C, map_pow, aeval_X, ZeroMemClass.coe_zero]
+    exact hrelk
+  have hQ0 : Q = 0 := transcendental_iff_injective.mp htr (by rw [hQx, map_zero])
+  apply hβ0
+  have := congrArg (fun p : k[X] => p.coeff m₁) hQ0
+  simp only [hQ, finsetSum_coeff, coeff_C_mul_X_pow, Polynomial.coeff_zero, Finset.sum_ite_eq,
+    ite_eq_left hm₁] at this
+  exact this
+
+set_option synthInstance.maxHeartbeats 1600000 in
+theorem main (A : ValuationSubring L) (π : A →+* k)
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+    (hF : ∃ t : FL L Γ, Transcendental L t ∧ FiniteDimensional L⟮t⟯ (FL L Γ))
+    (a b : PowerSeries ℤ) (X : FL L Γ)
+    (hX : (X : LaurentSeries L) = intSeriesC L a / intSeriesC L b)
+    (x : FK k Γ) (hx : (x : LaurentSeries k) = intSeriesC k a / intSeriesC k b)
+    (htr : Transcendental k x) :
+    FiniteDimensional k⟮x⟯ (FK k Γ) ∧ Module.finrank k⟮x⟯ (FK k Γ) ≤ Module.finrank L⟮X⟯ (FL L Γ) :=
+      by
+  classical
+  obtain ⟨t, ht, hfdt⟩ := hF
+  have := hfdt
+  have hXtr : Transcendental L X := transcendental_upstairs A π Γ a b X hX x hx htr
+  have : FiniteDimensional L⟮X⟯ (FL L Γ) :=
+    AlgebraicCurve.finiteDimensional_adjoin_of_transcendental t hXtr
+  set d : ℕ := Module.finrank L⟮X⟯ (FL L Γ) with hd
+  have hbound : ∀ T : Finset (FK k Γ), (↑T : Set (FK k Γ)) ⊆ monomials L k Γ →
+      LinearIndependent k⟮x⟯ (Subtype.val : (↑T : Set (FK k Γ)) → FK k Γ) → T.card ≤ d := by
+    intro T hT hli
+    have hli' : LinearIndependent k⟮x⟯
+        (fun i : Fin T.card => ((T.equivFin.symm i : (↑T : Set (FK k Γ))) : FK k Γ)) :=
+      hli.comp (fun i => T.equivFin.symm i) (T.equivFin.symm.injective)
+    exact card_le_finrank_of_linearIndependent A π a b X hX x hx htr _ (fun i => hT (T.equivFin.symm
+      i).2) hli'
+  obtain ⟨B, hBsub, hspan, hBli⟩ := exists_linearIndependent k⟮x⟯ (monomials L k Γ)
+  have hBfin : B.Finite := by
+    by_contra hinf
+    obtain ⟨T, hTB, hTcard⟩ := Set.Infinite.exists_subset_card_eq hinf (d + 1)
+    have hliT : LinearIndependent k⟮x⟯ (Subtype.val : (↑T : Set (FK k Γ)) → FK k Γ) :=
+      hBli.comp (Set.inclusion hTB) (Set.inclusion_injective hTB)
+    have := hbound T (hTB.trans hBsub) hliT
+    omega
+  have hBcard : hBfin.toFinset.card ≤ d := by
+    refine hbound _ (by rw [Set.Finite.coe_toFinset]; exact hBsub) ?_
+    have hsub : (↑hBfin.toFinset : Set (FK k Γ)) ⊆ B := by rw [Set.Finite.coe_toFinset]
+    exact hBli.comp (Set.inclusion hsub) (Set.inclusion_injective hsub)
+  set V : Submodule k⟮x⟯ (FK k Γ) := Submodule.span k⟮x⟯ (monomials L k Γ) with hV
+  have hVfd : FiniteDimensional k⟮x⟯ V := by
+    rw [← hspan]; exact FiniteDimensional.span_of_finite _ hBfin
+  have hmul : ∀ u ∈ V, ∀ v ∈ V, u * v ∈ V := by
+    intro u hu v hv
+    induction hu using Submodule.span_induction generalizing v with
+    | mem u hu =>
+      induction hv using Submodule.span_induction with
+      | mem v hv => exact Submodule.subset_span (mul_mem_monomials hu hv)
+      | zero => rw [mul_zero]; exact V.zero_mem
+      | add v v' _ _ h h' => rw [mul_add]; exact V.add_mem h h'
+      | smul r v _ h => rw [mul_smul_comm]; exact V.smul_mem r h
+    | zero => rw [zero_mul]; exact V.zero_mem
+    | add u u' _ _ h h' => rw [add_mul]; exact V.add_mem (h v hv) (h' v hv)
+    | smul r u _ h => rw [smul_mul_assoc]; exact V.smul_mem r (h v hv)
+  have hone : (1 : FK k Γ) ∈ V := Submodule.subset_span one_mem_monomials
+  have hinv : ∀ u ∈ V, u⁻¹ ∈ V := by
+    intro u hu
+    rcases eq_or_ne u 0 with rfl | hu0
+    · rw [inv_zero]; exact V.zero_mem
+    let μ : V →ₗ[k⟮x⟯] V :=
+      { toFun := fun v => ⟨u * v, hmul u hu v v.2⟩
+        map_add' := fun v v' => Subtype.ext (mul_add _ _ _)
+        map_smul' := fun r v => Subtype.ext (mul_smul_comm _ _ _) }
+    have hμinj : Function.Injective μ := fun v v' h =>
+      Subtype.ext (mul_left_cancel₀ hu0 (congrArg Subtype.val h :))
+    have := hVfd
+    obtain ⟨v, hv⟩ := (LinearMap.injective_iff_surjective.mp hμinj) ⟨1, hone⟩
+    have huv : u * v = 1 := congrArg Subtype.val hv
+    rw [inv_eq_of_mul_eq_one_right huv]
+    exact v.2
+  have htop : ∀ z : FK k Γ, z ∈ V := by
+    rintro ⟨z, hz⟩
+    have hz' : z ∈ IntermediateField.adjoin k (intFormRatiosC k Γ) := hz
+    have key : ∀ hz'' : z ∈ qExpFunctionFieldC k Γ, (⟨z, hz''⟩ : FK k Γ) ∈ V := by
+      clear hz
+      induction hz' using IntermediateField.adjoin_induction with
+      | mem w hw =>
+        intro hw''
+        exact Submodule.subset_span (intFormRatiosC_subset_monomials (y := ⟨w, hw''⟩) hw)
+      | algebraMap c =>
+        intro hc''
+        have : (⟨algebraMap k (LaurentSeries k) c, hc''⟩ : FK k Γ) = (algebraMap k k⟮x⟯ c) • (1 : FK
+          k Γ) :=
+          by
+          apply Subtype.ext
+          rw [IntermediateField.smul_def, smul_eq_mul, mul_one]
+          rfl
+        rw [this]; exact V.smul_mem _ hone
+      | add w w' hw hw' h h' =>
+        intro _
+        exact V.add_mem (h hw) (h' hw')
+      | inv w hw h =>
+        intro _
+        exact hinv (⟨w, hw⟩ : FK k Γ) (h hw)
+      | mul w w' hw hw' h h' =>
+        intro _
+        exact hmul (⟨w, hw⟩ : FK k Γ) (h hw) (⟨w', hw'⟩ : FK k Γ) (h' hw')
+    exact key hz
+  have hVtop : V = ⊤ := Submodule.eq_top_iff'.mpr htop
+  have hspanB : Submodule.span k⟮x⟯ (↑hBfin.toFinset : Set (FK k Γ)) = ⊤ := by
+    rw [Set.Finite.coe_toFinset, hspan, hVtop]
+  refine ⟨?_, ?_⟩
+  · exact Module.Finite.of_fg_top (hspanB ▸ Submodule.fg_span (Finset.finite_toSet _))
+  · calc Module.finrank k⟮x⟯ (FK k Γ) = Module.finrank k⟮x⟯ (⊤ : Submodule k⟮x⟯ (FK k Γ)) :=
+      (finrank_top _ _).symm
+      _ = Set.finrank k⟮x⟯ (↑hBfin.toFinset : Set (FK k Γ)) := by rw [Set.finrank, hspanB]
+      _ ≤ hBfin.toFinset.card := finrank_span_finset_le_card _
+      _ ≤ d := hBcard
+
+end Assembly
+
+end ModularCurve.QExpDeuringIneq
+
+end
+
+theorem solution
+    {L : Type*} [Field L] [Algebra ℚ L] (A : ValuationSubring L)
+    {k : Type*} [Field k] (π : A →+* k)
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+    (hF : ∃ t : ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ),
+      Transcendental L t ∧
+        FiniteDimensional
+          (IntermediateField.adjoin L
+            ({t} : Set (ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ))))
+          (ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ)))
+    (a b : PowerSeries ℤ)
+    (X : ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ))
+    (hX : (X : LaurentSeries L) = ModularCurve.intSeriesC L a / ModularCurve.intSeriesC L b)
+    (x : ModularCurve.qExpFunctionFieldC k Γ)
+    (hx : (x : LaurentSeries k) = ModularCurve.intSeriesC k a / ModularCurve.intSeriesC k b)
+    (htr : Transcendental k x) :
+    FiniteDimensional (IntermediateField.adjoin k ({x} : Set (ModularCurve.qExpFunctionFieldC k Γ)))
+        (ModularCurve.qExpFunctionFieldC k Γ) ∧
+      Module.finrank (IntermediateField.adjoin k ({x} : Set (ModularCurve.qExpFunctionFieldC k Γ)))
+          (ModularCurve.qExpFunctionFieldC k Γ) ≤
+        Module.finrank
+          (IntermediateField.adjoin L
+            ({X} : Set (ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ))))
+          (ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ)) :=
+  ModularCurve.QExpDeuringIneq.main A π Γ hF a b X hX x hx htr
+
+end S_ModularCurve_finrank_adjoin_qExpFunctionFieldC_le_of_valuationSubring
+end P2MW
+export P2MW.S_ModularCurve_finrank_adjoin_qExpFunctionFieldC_le_of_valuationSubring (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.finrank_adjoin_qExpFunctionFieldC_le_of_valuationSubring
+    {L : Type*} [Field L] [Algebra ℚ L] (A : ValuationSubring L)
+    {k : Type*} [Field k] (π : A →+* k)
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+    (hF : ∃ t : ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ),
+      Transcendental L t ∧
+        FiniteDimensional
+          (IntermediateField.adjoin L
+            ({t} : Set (ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ))))
+          (ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ)))
+    (a b : PowerSeries ℤ)
+    (X : ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ))
+    (hX : (X : LaurentSeries L) = ModularCurve.intSeriesC L a / ModularCurve.intSeriesC L b)
+    (x : ModularCurve.qExpFunctionFieldC k Γ)
+    (hx : (x : LaurentSeries k) = ModularCurve.intSeriesC k a / ModularCurve.intSeriesC k b)
+    (htr : Transcendental k x) :
+    FiniteDimensional (IntermediateField.adjoin k ({x} : Set (ModularCurve.qExpFunctionFieldC k Γ)))
+        (ModularCurve.qExpFunctionFieldC k Γ) ∧
+      Module.finrank (IntermediateField.adjoin k ({x} : Set (ModularCurve.qExpFunctionFieldC k Γ)))
+          (ModularCurve.qExpFunctionFieldC k Γ) ≤
+        Module.finrank
+          (IntermediateField.adjoin L
+            ({X} : Set (ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ))))
+          (ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ)) :=
+  solution A π Γ hF a b X hX x hx htr
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_jAdjoin_modularFunctionField_eq_dedekindPsi.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_jAdjoin_modularFunctionField_eq_dedekindPsi.lean
new file mode 100644
index 0000000000..3dcd360933
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_jAdjoin_modularFunctionField_eq_dedekindPsi.lean
@@ -0,0 +1,143 @@
+/-
+Based on Prove2Me node ModularCurve.finrank_jAdjoin_modularFunctionField_eq_dedekindPsi
+(4443c3af-710f-594c-9835-cd013ef175e1) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a3867f15-63bb-590f-aef2-a879d84c52d0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JLinePlaces
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqN_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree ψ(N) of the j-cover on function fields
+
+Theorem statement: `ModularCurve.finrank_jAdjoin_modularFunctionField_eq_dedekindPsi`
+(`4443c3af-710f-594c-9835-cd013ef175e1`), by Claude, 2026-09-05.
+
+Proof: submission `a3867f15-63bb-590f-aef2-a879d84c52d0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, non-zero. Inside the field $\mathbb{Q}((q))$ of Laurent series
+(`LaurentSeries ℚ`, Hahn series over $\mathbb{Q}$ with integer exponents) put $jq = q^{-1}\cdot
+jNumQ$, where $jNumQ$ is the power series `jNum` with its coefficients mapped into $\mathbb{Q}$;
+thus $jq$ is the $q$-expansion of $j$. Let `qExpand ℚ N` be the ring endomorphism of
+$\mathbb{Q}((q))$ obtained by reindexing exponents along multiplication by $N$, so that `qExpand ℚ N
+jq` is $j(q^N)$. Let `modularFunctionField N` be the intermediate field $\mathbb{Q}(jq,\,j(q^N))$ of
+$\mathbb{Q}((q))$ over $\mathbb{Q}$, and let $\mathbb{Q}\langle jq\rangle = \mathbb{Q}(jq)$ be the
+simple subextension generated by $jq$, acting on `modularFunctionField N` through the algebra
+structure `jAdjoinAlgebra N` induced by the inclusion ring homomorphism $x \mapsto x$ of
+$\mathbb{Q}(jq)$ into $\mathbb{Q}(jq, j(q^N))$. The assertion is that the rank of
+`modularFunctionField N` as a module over $\mathbb{Q}(jq)$ for this structure equals `dedekindPsi
+N`, defined as $\sum_{d \mid N,\ d\ \text{squarefree}} N/d$, i.e. $N\prod_{p \mid N}(1+1/p)$.
+
+This is the degree of the $j$-cover $X_0(N) \to X(1)$ in its function-field form,
+$[\mathbb{Q}(j(q),j(q^N)) : \mathbb{Q}(j)] = \psi(N) = [\mathrm{SL}_2(\mathbb{Z}) : \Gamma_0(N)]$,
+stated here for the absolute presentation of the modular function field as $\mathbb{Q}(jq, j(q^N))$
+rather than as the relative extension $\mathbb{Q}(jq)(j(q^N))$. It is used in the computations of
+the ramification of this cover over the points $j = 0$ and $j = 1728$, namely in
+[`ModularCurve.natCard_ord_jBar_eq_one_eq_nuThree`]
+(thm.html#ModularCurve.natCard_ord_jBar_eq_one_eq_nuThree)
+and
+[`ModularCurve.natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo`]
+(thm.html#ModularCurve.natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finrank_jAdjoin_modularFunctionField_eq_dedekindPsi.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_finrank_jAdjoin_modularFunctionField_eq_dedekindPsi
+
+
+open IntermediateField
+
+noncomputable section
+
+namespace S12H3
+
+variable (N : ℕ) [NeZero N]
+
+local notation "𝔽" => (ModularCurve.modularFunctionField N : Type)
+local notation "𝕃" => (ℚ⟮ModularCurve.jq⟯ : Type)
+
+attribute [local instance] ModularCurve.jAdjoinAlgebra
+
+theorem finrank_jAdjoin : Module.finrank 𝕃 𝔽 = ModularCurve.dedekindPsi N := by
+  have hmem : ∀ x : LaurentSeries ℚ, x ∈ ModularCurve.modularFunctionField N ↔
+      x ∈ IntermediateField.adjoin 𝕃 ({ModularCurve.jqN N} : Set (LaurentSeries ℚ)) := by
+    intro x
+    constructor
+    · intro hx
+      have hx' : x ∈ (ModularCurve.modularFunctionField N).toSubfield := hx
+      rw [ModularCurve.modularFunctionField, IntermediateField.adjoin_toSubfield] at hx'
+      refine (Subfield.closure_le.mpr ?_) hx'
+      rintro y (⟨r, rfl⟩ | hy)
+      · rw [eq_ratCast]
+        exact SubfieldClass.ratCast_mem _ r
+      · rcases hy with rfl | rfl
+        · exact (IntermediateField.adjoin 𝕃 ({ModularCurve.jqN N} : Set (LaurentSeries
+            ℚ))).algebraMap_mem
+            ⟨ModularCurve.jq, IntermediateField.mem_adjoin_simple_self ℚ ModularCurve.jq⟩
+        · exact IntermediateField.mem_adjoin_simple_self _ (ModularCurve.jqN N)
+    · intro hx
+      have hx' : x ∈ (IntermediateField.adjoin 𝕃 ({ModularCurve.jqN N} : Set (LaurentSeries
+        ℚ))).toSubfield :=
+        hx
+      rw [IntermediateField.adjoin_toSubfield] at hx'
+      refine (Subfield.closure_le.mpr ?_) hx'
+      rintro y (⟨z, rfl⟩ | rfl)
+      · exact ModularCurve.adjoin_jq_le N z.2
+      · exact ModularCurve.jqN_mem N
+  let e : (IntermediateField.adjoin 𝕃 ({ModularCurve.jqN N} : Set (LaurentSeries ℚ))) ≃+* 𝔽 :=
+    { toFun := fun x => ⟨(x : LaurentSeries ℚ), (hmem _).mpr x.2⟩
+      invFun := fun y => ⟨(y : LaurentSeries ℚ), (hmem _).mp y.2⟩
+      left_inv := fun _ => rfl
+      right_inv := fun _ => rfl
+      map_mul' := fun _ _ => rfl
+      map_add' := fun _ _ => rfl }
+  let eₐ : (IntermediateField.adjoin 𝕃 ({ModularCurve.jqN N} : Set (LaurentSeries ℚ))) ≃ₐ[𝕃] 𝔽 :=
+    AlgEquiv.ofRingEquiv (f := e) fun _ => Subtype.ext rfl
+  rw [← eₐ.toLinearEquiv.finrank_eq]
+  exact ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi N
+
+end S12H3
+
+end
+
+theorem solution (N : ℕ) [NeZero N] :
+    @Module.finrank ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N) _ _
+      (ModularCurve.jAdjoinAlgebra N).toModule = ModularCurve.dedekindPsi N := by
+  exact S12H3.finrank_jAdjoin N
+
+end S_ModularCurve_finrank_jAdjoin_modularFunctionField_eq_dedekindPsi
+end P2MW
+export P2MW.S_ModularCurve_finrank_jAdjoin_modularFunctionField_eq_dedekindPsi (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open IntermediateField AlgebraicCurve
+theorem ModularCurve.finrank_jAdjoin_modularFunctionField_eq_dedekindPsi (N : ℕ) [NeZero N] :
+    @Module.finrank ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N) _ _
+      (ModularCurve.jAdjoinAlgebra N).toModule = ModularCurve.dedekindPsi N :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_parabolicHoms_Gamma_le_two_mul_finrank_cuspForm.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_parabolicHoms_Gamma_le_two_mul_finrank_cuspForm.lean
new file mode 100644
index 0000000000..1b8c26a7bd
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_parabolicHoms_Gamma_le_two_mul_finrank_cuspForm.lean
@@ -0,0 +1,197 @@
+/-
+Based on Prove2Me node ModularCurve.finrank_parabolicHoms_Gamma_le_two_mul_finrank_cuspForm
+(a7cf4047-296d-5cea-b157-7b0a64c09e9c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 344cfb7a-28fe-57ca-a0a8-baeadda53067
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodMap
+
+import Mathlib.LinearAlgebra.Matrix.FixedDetMatrices
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_six_mul_level_mul_finrank_parabolicHoms_Gamma_add_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_twelve_mul_add_mul_index_le_finrank_cuspForm_Gamma
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Rank of parabolic homomorphisms of Γ(N) bounded by 2dim S₂
+
+Theorem statement: `ModularCurve.finrank_parabolicHoms_Gamma_le_two_mul_finrank_cuspForm`
+(`a7cf4047-296d-5cea-b157-7b0a64c09e9c`), by Claude, 2026-09-05.
+
+Proof: submission `344cfb7a-28fe-57ca-a0a8-baeadda53067`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, assumed nonzero. Inside the additive group of group homomorphisms
+$\mathrm{Additive}(\Gamma(N)) \to \mathbb{Z}$, where $\Gamma(N) \le \mathrm{SL}_2(\mathbb{Z})$ is
+the principal congruence subgroup of level $N$ and $\mathrm{Additive}$ turns its multiplicative
+group structure into an additive one, consider the $\mathbb{Z}$-submodule
+[`ModularCurve.Period.parabolicHoms`](def/ModularCurve_PeriodMap.html#L62) consisting of those
+$\varphi$ that satisfy the predicate `IsParabolicHom`: $\varphi(\gamma) = 0$ for every $\gamma \in
+\Gamma(N)$ whose underlying $2 \times 2$ integer matrix has trace with square equal to $4$, i.e.
+trace $\pm 2$. The theorem asserts the inequality of natural numbers
+$$\operatorname{finrank}_{\mathbb{Z}}
+\big(\mathrm{parabolicHoms}\,\mathbb{Z}\,\Gamma(N)\,\mathbb{Z}\big) \le 2 \cdot
+\operatorname{finrank}_{\mathbb{C}} \mathrm{CuspForm}(\Gamma(N), 2),$$ where the right-hand side is
+twice the complex dimension of the space of weight-$2$ cusp forms for $\Gamma(N)$. Both ranks are
+the Mathlib `Module.finrank`, hence natural numbers, and the inequality is one of natural numbers.
+
+This is the inequality expressing the surjectivity half of the Eichler–Shimura relation at principal
+level: the rank of the group of parabolic (trace $\pm 2$ killing) homomorphisms $\Gamma(N) \to
+\mathbb{Z}$ is at most twice $\dim_{\mathbb{C}} S_2(\Gamma(N))$. It is the input from which the
+corresponding bound for an arbitrary congruence subgroup is obtained by descent, in
+[`ModularCurve.finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_isCongruenceSubgroup`]
+(thm.html#ModularCurve.finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_isCongruenceSubgroup).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finrank_parabolicHoms_Gamma_le_two_mul_finrank_cuspForm.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_finrank_parabolicHoms_Gamma_le_two_mul_finrank_cuspForm
+
+open scoped MatrixGroups
+
+namespace ModularCurve
+p2m_export "ModularCurve" "Period.parabolicHoms \
+  six_mul_level_mul_finrank_parabolicHoms_Gamma_add_eq \
+  twelve_mul_add_mul_index_le_finrank_cuspForm_Gamma"
+namespace ESPrincipalAssembly
+p2m_open "ModularCurve"
+
+open ModularCurve.Period CongruenceSubgroup
+
+theorem trace_T_sq : ((ModularGroup.T : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace ^ 2 = 4 := by
+  rw [Matrix.trace_fin_two]
+  simp [ModularGroup.T]
+
+theorem trace_neg_one_sq : ((-1 : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace ^ 2 = 4 := by
+  rw [Matrix.trace_fin_two]
+  simp
+
+theorem S_mul_S : (ModularGroup.S : SL(2, ℤ)) * ModularGroup.S = -1 := by
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp [ModularGroup.S, Matrix.mul_apply, Fin.sum_univ_two]
+
+def toGammaOne (g : SL(2, ℤ)) : Gamma 1 :=
+  ⟨g, by simp [CongruenceSubgroup.Gamma_one_top]⟩
+
+@[scoped simp]
+theorem coe_toGammaOne (g : SL(2, ℤ)) : ((toGammaOne g : Gamma 1) : SL(2, ℤ)) = g := rfl
+
+theorem toGammaOne_mul (g h : SL(2, ℤ)) : toGammaOne (g * h) = toGammaOne g * toGammaOne h := rfl
+
+theorem toGammaOne_one : toGammaOne 1 = 1 := rfl
+
+theorem toGammaOne_inv (g : SL(2, ℤ)) : toGammaOne g⁻¹ = (toGammaOne g)⁻¹ := rfl
+
+theorem toGammaOne_coe (γ : Gamma 1) : toGammaOne (γ : SL(2, ℤ)) = γ := by
+  ext; rfl
+
+theorem eq_zero_of_mem_parabolicHoms_gamma_one (φ : Additive (Gamma 1) →+ ℤ)
+    (hφ : φ ∈ parabolicHoms ℤ (Gamma 1) ℤ) : φ = 0 := by
+  rw [mem_parabolicHoms_iff] at hφ
+  let ψ : SL(2, ℤ) → ℤ := fun g => φ (Additive.ofMul (toGammaOne g))
+  have hψ_mul : ∀ g h, ψ (g * h) = ψ g + ψ h := by
+    intro g h
+    simp only [ψ, toGammaOne_mul, ofMul_mul, map_add]
+  have hψ_one : ψ 1 = 0 := by
+    simp only [ψ, toGammaOne_one, ofMul_one, map_zero]
+  have hψ_inv : ∀ g, ψ g⁻¹ = -ψ g := by
+    intro g
+    have h := hψ_mul g g⁻¹
+    rw [mul_inv_cancel, hψ_one] at h
+    omega
+  have hT : ψ ModularGroup.T = 0 := hφ (toGammaOne ModularGroup.T) trace_T_sq
+  have hneg : ψ (-1) = 0 := hφ (toGammaOne (-1)) trace_neg_one_sq
+  have hS : ψ ModularGroup.S = 0 := by
+    have h := hψ_mul ModularGroup.S ModularGroup.S
+    rw [S_mul_S, hneg] at h
+    omega
+  have hall : ∀ g : SL(2, ℤ), ψ g = 0 := by
+    intro g
+    have hg : g ∈ Subgroup.closure ({ModularGroup.S, ModularGroup.T} : Set SL(2, ℤ)) := by
+      rw [SpecialLinearGroup.SL2Z_generators]; exact Subgroup.mem_top g
+    induction hg using Subgroup.closure_induction with
+    | mem x hx =>
+        rcases hx with rfl | rfl
+        · exact hS
+        · exact hT
+    | one => exact hψ_one
+    | mul x y _ _ hx hy => rw [hψ_mul, hx, hy, add_zero]
+    | inv x _ hx => rw [hψ_inv, hx, neg_zero]
+  ext γ
+  have h := hall (Additive.toMul γ : Gamma 1)
+  simp only [ψ, toGammaOne_coe, ofMul_toMul] at h
+  simp only [AddMonoidHom.toMultiplicativeRight_apply_apply, toAdd_ofAdd, AddMonoidHom.zero_apply,
+    ofAdd_zero, toAdd_one] at h ⊢
+  exact h
+
+theorem parabolicHoms_gamma_one_eq_bot : parabolicHoms ℤ (Gamma 1) ℤ = ⊥ := by
+  rw [eq_bot_iff]
+  intro φ hφ
+  rw [Submodule.mem_bot]
+  exact eq_zero_of_mem_parabolicHoms_gamma_one φ hφ
+
+theorem finrank_parabolicHoms_gamma_one : Module.finrank ℤ (parabolicHoms ℤ (Gamma 1) ℤ) = 0 := by
+  rw [parabolicHoms_gamma_one_eq_bot, finrank_bot]
+
+theorem main_of_two_le (N : ℕ) (hN : 2 ≤ N) :
+    Module.finrank ℤ (parabolicHoms ℤ (Gamma N) ℤ) ≤ 2 * Module.finrank ℂ (CuspForm (Gamma N) 2)
+      := by
+  have hA := ModularCurve.six_mul_level_mul_finrank_parabolicHoms_Gamma_add_eq N hN
+  have hG := ModularCurve.twelve_mul_add_mul_index_le_finrank_cuspForm_Gamma N hN
+  set r := Module.finrank ℤ (parabolicHoms ℤ (Gamma N) ℤ)
+  set d := Module.finrank ℂ (CuspForm (Gamma N) 2)
+  set μ := (Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index
+  have h1 : 6 * N * r + 6 * μ ≤ 12 * N * d + 6 * μ := hA ▸ hG
+  have h2 : 6 * N * r ≤ 6 * N * (2 * d) := by
+    have h3 : 6 * N * r ≤ 12 * N * d := Nat.le_of_add_le_add_right h1
+    calc 6 * N * r ≤ 12 * N * d := h3
+      _ = 6 * N * (2 * d) := by ring
+  have hpos : 0 < 6 * N := by omega
+  exact Nat.le_of_mul_le_mul_left h2 hpos
+
+end ModularCurve.ESPrincipalAssembly
+
+open ModularCurve.ESPrincipalAssembly in
+theorem solution (N : ℕ) [NeZero N] :
+    Module.finrank ℤ (ModularCurve.Period.parabolicHoms ℤ (CongruenceSubgroup.Gamma N) ℤ) ≤
+      2 * Module.finrank ℂ (CuspForm (CongruenceSubgroup.Gamma N) 2) := by
+  rcases Nat.lt_or_ge N 2 with h | h
+  · obtain rfl : N = 1 := by
+      have h0 : N ≠ 0 := NeZero.ne N
+      omega
+    rw [finrank_parabolicHoms_gamma_one]
+    exact Nat.zero_le _
+  · exact main_of_two_le N h
+
+end S_ModularCurve_finrank_parabolicHoms_Gamma_le_two_mul_finrank_cuspForm
+end P2MW
+export P2MW.S_ModularCurve_finrank_parabolicHoms_Gamma_le_two_mul_finrank_cuspForm (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.finrank_parabolicHoms_Gamma_le_two_mul_finrank_cuspForm (N : ℕ) [NeZero N] :
+    Module.finrank ℤ (ModularCurve.Period.parabolicHoms ℤ (CongruenceSubgroup.Gamma N) ℤ) ≤
+      2 * Module.finrank ℂ (CuspForm (CongruenceSubgroup.Gamma N) 2) :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_isCongruenceSubgroup.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_isCongruenceSubgroup.lean
new file mode 100644
index 0000000000..212fe56025
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_isCongruenceSubgroup.lean
@@ -0,0 +1,111 @@
+/-
+Based on Prove2Me node
+ModularCurve.finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_isCongruenceSubgroup
+(0ecd14cb-bbeb-5b1a-98cb-394f76c9069f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 09ede4ab-19ee-54df-ac68-c9f7b3ab0b3e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodMap
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_parabolicHoms_Gamma_le_two_mul_finrank_cuspForm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_le_of_normal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Eichler–Shimura rank bound for congruence subgroups
+
+Theorem statement:
+`ModularCurve.finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_isCongruenceSubgroup`
+(`0ecd14cb-bbeb-5b1a-98cb-394f76c9069f`), by Claude, 2026-09-05.
+
+Proof: submission `09ede4ab-19ee-54df-ac68-c9f7b3ab0b3e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of $\mathrm{SL}_2(\mathbb{Z})$ which is a congruence subgroup, i.e. there
+is an $N$ with $N \neq 0$ and $\Gamma(N) \le \Gamma$, where $\Gamma(N)$ is the principal congruence
+subgroup of level $N$. Consider the $\mathbb{Z}$-module [`ModularCurve.Period.parabolicHoms ℤ Γ
+ℤ`](def/ModularCurve_PeriodMap.html#L62) of parabolic homomorphisms: the submodule of the additive
+group of all additive maps $\varphi$ from $\Gamma$, written additively via `Additive`, to
+$\mathbb{Z}$ consisting of those $\varphi$ that satisfy $\varphi(\gamma) = 0$ for every $\gamma \in
+\Gamma$ whose underlying integral $2 \times 2$ matrix has $(\operatorname{tr}\gamma)^2 = 4$, that
+is, trace $\pm 2$. The assertion is the inequality
+$$\operatorname{rank}_{\mathbb{Z}}\bigl(\text{parabolic homomorphisms } \Gamma \to \mathbb{Z}\bigr)
+\le 2 \dim_{\mathbb{C}} S_2(\Gamma),$$
+where the left side is the $\mathbb{Z}$-rank (`Module.finrank`) of that submodule and the right side
+is twice the $\mathbb{C}$-dimension of the space `CuspForm Γ 2` of weight-$2$ cusp forms for
+$\Gamma$; both dimensions are taken in Mathlib's `Module.finrank` convention, which returns $0$ for
+modules that are not finitely generated of finite rank.
+
+This is the surjectivity half of the Eichler–Shimura relation in weight $2$, in the form
+$\operatorname{rank} H^1_{\mathrm{par}}(\Gamma,\mathbb{Z}) \le 2\dim_{\mathbb{C}} S_2(\Gamma)$,
+equivalently the inequality $\dim S_2(\Gamma) \ge g(X_\Gamma)$, stated here for an arbitrary
+congruence subgroup. It feeds the construction of the period map and the Eichler–Shimura comparison
+for $\Gamma_H$-level structures used later in the development.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_isCongruenceSubgroup.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_4773a672
+
+open scoped MatrixGroups
+
+namespace ModularCurve
+p2m_export "ModularCurve" "Period.parabolicHoms \
+  finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_le_of_normal \
+  finrank_parabolicHoms_Gamma_le_two_mul_finrank_cuspForm"
+namespace ESSurjCongruence
+p2m_open "ModularCurve"
+
+theorem main (Γ : Subgroup SL(2, ℤ)) (hΓ : CongruenceSubgroup.IsCongruenceSubgroup Γ) :
+    Module.finrank ℤ (ModularCurve.Period.parabolicHoms ℤ Γ ℤ) ≤
+      2 * Module.finrank ℂ (CuspForm Γ 2) := by
+  obtain ⟨N, hN, hle⟩ := hΓ
+  have : NeZero N := ⟨hN⟩
+  have : (CongruenceSubgroup.Gamma N).Normal := CongruenceSubgroup.Gamma_normal N
+  have : ((CongruenceSubgroup.Gamma N).subgroupOf Γ).Normal := inferInstance
+  exact ModularCurve.finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_le_of_normal
+    (CongruenceSubgroup.Gamma N) Γ hle inferInstance
+    (ModularCurve.finrank_parabolicHoms_Gamma_le_two_mul_finrank_cuspForm N)
+
+end ModularCurve.ESSurjCongruence
+
+theorem solution (Γ : Subgroup SL(2, ℤ)) (hΓ : CongruenceSubgroup.IsCongruenceSubgroup Γ) :
+    Module.finrank ℤ (ModularCurve.Period.parabolicHoms ℤ Γ ℤ) ≤
+      2 * Module.finrank ℂ (CuspForm Γ 2) :=
+  ModularCurve.ESSurjCongruence.main Γ hΓ
+
+end S_OVERLONG_4773a672
+end P2MW
+export P2MW.S_OVERLONG_4773a672
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_isCongruenceSubgroup
+    (Γ : Subgroup SL(2, ℤ)) (hΓ : CongruenceSubgroup.IsCongruenceSubgroup Γ) :
+    Module.finrank ℤ (ModularCurve.Period.parabolicHoms ℤ Γ ℤ) ≤
+      2 * Module.finrank ℂ (CuspForm Γ 2) :=
+  solution Γ hΓ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_le_of_normal.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_le_of_normal.lean
new file mode 100644
index 0000000000..9cedb0e57b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_le_of_normal.lean
@@ -0,0 +1,494 @@
+/-
+Based on Prove2Me node
+ModularCurve.finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_le_of_normal
+(9f210cd5-40c4-5b4c-94fc-ba0db5fd5d19) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4235979a-285c-5ece-8f92-aabb78a04442
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodMap
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_finiteDimensional_of_isArithmetic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_Period_exists_basis_parabolicHoms_of_isAddTorsionFree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_eq_zero_of_forall_re_periodOf_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_hasEquivariantPrimitiveOf
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_periodMapOf_apply_eq_periodOf
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_periodMapOf_mem_parabolicHoms
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_periodOf_apply_eq_sub_of_hasEquivariantPrimitiveOf
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Descent of the parabolic rank bound along a normal subgroup
+
+Theorem statement: `ModularCurve.finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_le_of_normal`
+(`9f210cd5-40c4-5b4c-94fc-ba0db5fd5d19`), by Claude, 2026-09-05.
+
+Proof: submission `4235979a-285c-5ece-8f92-aabb78a04442`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma'$ and $\Gamma$ be subgroups of $\mathrm{SL}_2(\mathbb Z)$, with $\Gamma'$ of finite
+index in $\mathrm{SL}_2(\mathbb Z)$, $\Gamma' \le \Gamma$, and $\Gamma'$, viewed as a subgroup of
+$\Gamma$, normal in $\Gamma$. For a subgroup $\Delta \le \mathrm{SL}_2(\mathbb Z)$ and a commutative
+coefficient ring, [`ModularCurve.Period.parabolicHoms`](def/ModularCurve_PeriodMap.html#L62) denotes
+the submodule of those additive homomorphisms from the additive group $\mathrm{Additive}\,\Delta$ to
+the coefficient module that vanish on every $\gamma \in \Delta$ whose matrix trace satisfies
+$\mathrm{tr}(\gamma)^2 = 4$, i.e. $\mathrm{tr}(\gamma) = \pm 2$; here it is taken with coefficients
+$\mathbb Z$, so `parabolicHoms ℤ Δ ℤ` is the group of homomorphisms $\Delta \to \mathbb Z$ killing
+all elements of trace $\pm 2$. The hypothesis is the inequality $\operatorname{finrank}_{\mathbb
+Z}\,(\mathtt{parabolicHoms}\ \mathbb Z\ \Gamma'\ \mathbb Z) \le 2\,\dim_{\mathbb C}
+\mathrm{CuspForm}\,\Gamma'\,2$, where $\mathrm{CuspForm}\,\Delta\,2$ is the space of weight-$2$ cusp
+forms for $\Delta$. The conclusion is the same inequality with $\Gamma'$ replaced by $\Gamma$:
+$\operatorname{finrank}_{\mathbb Z}\,(\mathtt{parabolicHoms}\ \mathbb Z\ \Gamma\ \mathbb Z) \le
+2\,\dim_{\mathbb C} \mathrm{CuspForm}\,\Gamma\,2$. Finite index is assumed only for $\Gamma'$; that
+of $\Gamma$ follows from $\Gamma' \le \Gamma$.
+
+This is the descent step for the surjectivity half of the Eichler–Shimura relation in weight $2$:
+the bound comparing the rank of the parabolic character group with twice the dimension of the space
+of cusp forms passes from a finite-index subgroup normal in $\Gamma$ up to $\Gamma$ itself, the
+mechanism being that the real period map is injective for every finite-index subgroup and
+equivariant for the action of $\Gamma$ on the data for $\Gamma'$. It is used to deduce the
+corresponding bound for an arbitrary congruence subgroup, in
+[`ModularCurve.finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_isCongruenceSubgroup`]
+(thm.html#ModularCurve.finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_isCongruenceSubgroup),
+from the case of a suitable normal subgroup.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_le_of_normal.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_le_of_normal
+
+
+open scoped MatrixGroups ModularForm
+
+open UpperHalfPlane Filter Topology
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "Period.IsEquivariantPrimitive Period.IsParabolicHom \
+  Period.parabolicHoms periodOf HasEquivariantPrimitiveOf periodMapOf period \
+  Period.exists_basis_parabolicHoms_of_isAddTorsionFree eq_zero_of_forall_re_periodOf_eq_zero \
+  periodMapOf_mem_parabolicHoms periodMapOf_apply_eq_periodOf exists_hasEquivariantPrimitiveOf \
+  periodOf_apply_eq_sub_of_hasEquivariantPrimitiveOf"
+namespace ESDescent
+p2m_open "ModularCurve"
+
+section RealPeriodMap
+
+variable (Δ : Subgroup SL(2, ℤ)) [Δ.FiniteIndex]
+
+def rePeriod (f : CuspForm Δ 2) : Additive Δ →+ ℝ :=
+  Complex.reLm.toAddMonoidHom.comp (ModularCurve.periodMapOf Δ f)
+
+theorem rePeriod_apply (f : CuspForm Δ 2) (γ : Δ) :
+    rePeriod Δ f (Additive.ofMul γ) = (ModularCurve.periodOf Δ γ f).re := by
+  simp only [rePeriod, AddMonoidHom.coe_comp, Function.comp_apply, LinearMap.toAddMonoidHom_coe,
+    Complex.reLm_coe]
+  rw [ModularCurve.periodMapOf_apply_eq_periodOf]
+
+theorem rePeriod_apply' (f : CuspForm Δ 2) (a : Additive Δ) :
+    rePeriod Δ f a = (ModularCurve.periodOf Δ (Additive.toMul a) f).re :=
+  rePeriod_apply Δ f (Additive.toMul a)
+
+omit [Δ.FiniteIndex] in
+theorem rePeriod_isParabolicHom (f : CuspForm Δ 2) :
+    ModularCurve.Period.IsParabolicHom Δ (rePeriod Δ f) := by
+  intro γ hγ
+  have h := ModularCurve.periodMapOf_mem_parabolicHoms Δ f
+  have h0 : ModularCurve.periodMapOf Δ f (Additive.ofMul γ) = 0 := h γ hγ
+  simp only [rePeriod, AddMonoidHom.coe_comp, Function.comp_apply, LinearMap.toAddMonoidHom_coe,
+    Complex.reLm_coe, h0, Complex.zero_re]
+
+theorem rePeriod_add (f g : CuspForm Δ 2) : rePeriod Δ (f + g) = rePeriod Δ f + rePeriod Δ g := by
+  refine AddMonoidHom.ext fun a => ?_
+  rw [AddMonoidHom.add_apply, rePeriod_apply', rePeriod_apply', rePeriod_apply', map_add,
+    Complex.add_re]
+
+theorem rePeriod_smul (c : ℝ) (f : CuspForm Δ 2) : rePeriod Δ (c • f) = c • rePeriod Δ f := by
+  refine AddMonoidHom.ext fun a => ?_
+  have hc : (c • f : CuspForm Δ 2) = (c : ℂ) • f := rfl
+  rw [AddMonoidHom.smul_apply, rePeriod_apply', rePeriod_apply', hc, map_smul, smul_eq_mul,
+    Complex.re_ofReal_mul, smul_eq_mul]
+
+def realPeriodMap : CuspForm Δ 2 →ₗ[ℝ] ModularCurve.Period.parabolicHoms ℝ Δ ℝ where
+  toFun f := ⟨rePeriod Δ f, rePeriod_isParabolicHom Δ f⟩
+  map_add' f g := by
+    apply Subtype.ext
+    simp only [Submodule.coe_add, rePeriod_add]
+  map_smul' c f := by
+    apply Subtype.ext
+    simp only [RingHom.id_apply, Submodule.coe_smul, rePeriod_smul]
+
+theorem realPeriodMap_apply (f : CuspForm Δ 2) (γ : Δ) :
+    (realPeriodMap Δ f : Additive Δ →+ ℝ) (Additive.ofMul γ) = (ModularCurve.periodOf Δ γ f).re :=
+  rePeriod_apply Δ f γ
+
+theorem realPeriodMap_injective : Function.Injective (realPeriodMap Δ) := by
+  intro f g hfg
+  rw [← sub_eq_zero]
+  apply ModularCurve.eq_zero_of_forall_re_periodOf_eq_zero Δ (f - g)
+  intro γ
+  have h := congrArg (fun φ : ModularCurve.Period.parabolicHoms ℝ Δ ℝ =>
+    (φ : Additive Δ →+ ℝ) (Additive.ofMul γ)) hfg
+  simp only [realPeriodMap_apply] at h
+  rw [map_sub, Complex.sub_re, h, sub_self]
+
+theorem finite_and_finrank_parabolicHoms_real_eq :
+    Module.Finite ℝ (ModularCurve.Period.parabolicHoms ℝ Δ ℝ) ∧
+      Module.finrank ℝ (ModularCurve.Period.parabolicHoms ℝ Δ ℝ) =
+        Module.finrank ℤ (ModularCurve.Period.parabolicHoms ℤ Δ ℤ) := by
+  obtain ⟨n, b, hb⟩ := ModularCurve.Period.exists_basis_parabolicHoms_of_isAddTorsionFree Δ
+  obtain ⟨bR, -⟩ := hb ℝ
+  refine ⟨Module.Finite.of_basis bR, ?_⟩
+  rw [Module.finrank_eq_card_basis bR, Module.finrank_eq_card_basis b]
+
+scoped instance finiteDimensional_cuspForm : FiniteDimensional ℂ (CuspForm Δ 2) :=
+  CuspForm.finiteDimensional_of_isArithmetic (Δ : Subgroup (GL (Fin 2) ℝ)) 2
+
+omit [Δ.FiniteIndex] in
+theorem finrank_real_cuspForm :
+    Module.finrank ℝ (CuspForm Δ 2) = 2 * Module.finrank ℂ (CuspForm Δ 2) :=
+  finrank_real_of_complex (CuspForm Δ 2)
+
+theorem realPeriodMap_bijective_of_le
+    (h : Module.finrank ℤ (ModularCurve.Period.parabolicHoms ℤ Δ ℤ) ≤
+      2 * Module.finrank ℂ (CuspForm Δ 2)) :
+    Function.Bijective (realPeriodMap Δ) := by
+  obtain ⟨hfin, heq⟩ := finite_and_finrank_parabolicHoms_real_eq Δ
+  have := hfin
+  have hinj := realPeriodMap_injective Δ
+  have h1 : Module.finrank ℝ (CuspForm Δ 2) ≤
+      Module.finrank ℝ (ModularCurve.Period.parabolicHoms ℝ Δ ℝ) :=
+    LinearMap.finrank_le_finrank_of_injective hinj
+  have h2 : Module.finrank ℝ (ModularCurve.Period.parabolicHoms ℝ Δ ℝ) ≤
+      Module.finrank ℝ (CuspForm Δ 2) := by
+    rw [heq, finrank_real_cuspForm]; exact h
+  have hdim : Module.finrank ℝ (CuspForm Δ 2) =
+      Module.finrank ℝ (ModularCurve.Period.parabolicHoms ℝ Δ ℝ) := le_antisymm h1 h2
+  exact ⟨hinj, (LinearMap.injective_iff_surjective_of_finrank_eq_finrank hdim).mp hinj⟩
+
+end RealPeriodMap
+
+section Lower
+
+variable {Γ' Γ : Subgroup SL(2, ℤ)}
+
+theorem map_mono_GL (hle : Γ' ≤ Γ) :
+    (Γ' : Subgroup (GL (Fin 2) ℝ)) ≤ (Γ : Subgroup (GL (Fin 2) ℝ)) :=
+  Subgroup.map_mono hle
+
+def lower (hle : Γ' ≤ Γ) (f : CuspForm Γ 2) : CuspForm Γ' 2 where
+  toFun := f
+  slash_action_eq' A hA := SlashInvariantFormClass.slash_action_eq f A (map_mono_GL hle hA)
+  holo' := f.holo'
+  zero_at_cusps' hc := CuspFormClass.zero_at_cusps f (hc.mono (map_mono_GL hle))
+
+@[scoped simp] theorem lower_apply (hle : Γ' ≤ Γ) (f : CuspForm Γ 2) (z : ℍ) :
+    lower hle f z = f z := rfl
+
+theorem coe_lower (hle : Γ' ≤ Γ) (f : CuspForm Γ 2) :
+    ((lower hle f : CuspForm Γ' 2) : ℍ → ℂ) = f := rfl
+
+theorem periodOf_lower (hle : Γ' ≤ Γ) (f : CuspForm Γ 2) (γ : Γ') :
+    ModularCurve.periodOf Γ' γ (lower hle f) = ModularCurve.periodOf Γ ⟨γ, hle γ.2⟩ f := rfl
+
+def res (hle : Γ' ≤ Γ) :
+    ModularCurve.Period.parabolicHoms ℝ Γ ℝ →ₗ[ℝ] ModularCurve.Period.parabolicHoms ℝ Γ' ℝ where
+  toFun x := ⟨(x : Additive Γ →+ ℝ).comp (MonoidHom.toAdditive (Subgroup.inclusion hle)),
+    fun γ hγ => x.2 (Subgroup.inclusion hle γ) hγ⟩
+  map_add' _ _ := rfl
+  map_smul' _ _ := rfl
+
+theorem res_apply (hle : Γ' ≤ Γ) (x : ModularCurve.Period.parabolicHoms ℝ Γ ℝ) (γ : Γ') :
+    (res hle x : Additive Γ' →+ ℝ) (Additive.ofMul γ) =
+      (x : Additive Γ →+ ℝ) (Additive.ofMul ⟨(γ : SL(2, ℤ)), hle γ.2⟩) := rfl
+
+theorem res_injective [Γ'.FiniteIndex] (hle : Γ' ≤ Γ) : Function.Injective (res hle) := by
+  intro x y hxy
+  rw [← sub_eq_zero]
+  set w := x - y with hw
+  have hw0 : res hle w = 0 := by rw [hw, map_sub, hxy, sub_self]
+  apply Subtype.ext
+  refine AddMonoidHom.ext fun a => ?_
+  obtain ⟨n, hn, -, hmem⟩ :=
+    Subgroup.exists_pow_mem_of_index_ne_zero (Subgroup.FiniteIndex.index_ne_zero (H := Γ'))
+      ((Additive.toMul a : Γ) : SL(2, ℤ))
+  have hpow : ((Additive.toMul a ^ n : Γ) : SL(2, ℤ)) = ((Additive.toMul a : Γ) : SL(2, ℤ)) ^ n :=
+    by
+    simp
+  have hval : (w : Additive Γ →+ ℝ) (Additive.ofMul (Additive.toMul a ^ n)) = 0 := by
+    have := congrArg (fun φ : ModularCurve.Period.parabolicHoms ℝ Γ' ℝ =>
+      (φ : Additive Γ' →+ ℝ) (Additive.ofMul ⟨((Additive.toMul a : Γ) : SL(2, ℤ)) ^ n, hmem⟩)) hw0
+    simp only [res_apply, Submodule.coe_zero, AddMonoidHom.zero_apply] at this
+    convert this using 3
+  rw [ofMul_pow, map_nsmul, nsmul_eq_mul, mul_eq_zero] at hval
+  have hn' : (n : ℝ) ≠ 0 := by exact_mod_cast hn.ne'
+  have h0 : (w : Additive Γ →+ ℝ) a = 0 := by
+    rcases hval with h | h
+    · exact absurd h hn'
+    · simpa using h
+  simpa using h0
+
+theorem res_realPeriodMap [Γ'.FiniteIndex] [Γ.FiniteIndex] (hle : Γ' ≤ Γ) (f : CuspForm Γ 2) :
+    res hle (realPeriodMap Γ f) = realPeriodMap Γ' (lower hle f) := by
+  apply Subtype.ext
+  refine AddMonoidHom.ext fun a => ?_
+  rw [← ofMul_toMul a, res_apply, realPeriodMap_apply, realPeriodMap_apply, periodOf_lower]
+
+end Lower
+
+section Action
+
+variable {Γ' Γ : Subgroup SL(2, ℤ)} (hle : Γ' ≤ Γ) (hn : (Γ'.subgroupOf Γ).Normal)
+
+include hle hn in
+theorem conj_mem {γ : SL(2, ℤ)} (hγ : γ ∈ Γ') (δ : Γ) :
+    (δ : SL(2, ℤ)) * γ * (δ : SL(2, ℤ))⁻¹ ∈ Γ' :=
+  (Subgroup.normal_subgroupOf_iff hle).mp hn γ δ hγ δ.2
+
+include hle hn in
+theorem conj_mem' {γ : SL(2, ℤ)} (hγ : γ ∈ Γ') (δ : Γ) :
+    (δ : SL(2, ℤ))⁻¹ * γ * (δ : SL(2, ℤ)) ∈ Γ' := by
+  have := conj_mem hle hn hγ δ⁻¹
+  simpa using this
+
+open scoped Pointwise in
+include hle hn in
+theorem smul_coe_eq (δ : Γ) :
+    ConjAct.toConjAct (Matrix.SpecialLinearGroup.mapGL ℝ (δ : SL(2, ℤ)))⁻¹ •
+      (Γ' : Subgroup (GL (Fin 2) ℝ)) = (Γ' : Subgroup (GL (Fin 2) ℝ)) := by
+  ext A
+  rw [Subgroup.mem_pointwise_smul_iff_inv_smul_mem, ← map_inv, inv_inv, ConjAct.smul_def,
+    ConjAct.ofConjAct_toConjAct]
+  constructor
+  · rintro ⟨γ, hγ, hA⟩
+    refine ⟨(δ : SL(2, ℤ))⁻¹ * γ * (δ : SL(2, ℤ)), conj_mem' hle hn hγ δ, ?_⟩
+    have hA' : A = (Matrix.SpecialLinearGroup.mapGL ℝ (δ : SL(2, ℤ)))⁻¹ *
+        Matrix.SpecialLinearGroup.mapGL ℝ γ * Matrix.SpecialLinearGroup.mapGL ℝ (δ : SL(2, ℤ)) := by
+      rw [hA]; group
+    rw [hA', map_mul, map_mul, map_inv]
+  · rintro ⟨γ, hγ, rfl⟩
+    refine ⟨(δ : SL(2, ℤ)) * γ * (δ : SL(2, ℤ))⁻¹, conj_mem hle hn hγ δ, ?_⟩
+    rw [map_mul, map_mul, map_inv]
+
+def act (δ : Γ) (g : CuspForm Γ' 2) : CuspForm Γ' 2 :=
+  (CuspForm.translate g (Matrix.SpecialLinearGroup.mapGL ℝ (δ : SL(2, ℤ)))).copy
+    ((g : ℍ → ℂ) ∣[(2 : ℤ)] (δ : SL(2, ℤ))) rfl (smul_coe_eq hle hn δ).symm
+
+theorem coe_act (δ : Γ) (g : CuspForm Γ' 2) :
+    ((act hle hn δ g : CuspForm Γ' 2) : ℍ → ℂ) = (g : ℍ → ℂ) ∣[(2 : ℤ)] (δ : SL(2, ℤ)) := rfl
+
+theorem act_apply (δ : Γ) (g : CuspForm Γ' 2) (z : ℍ) :
+    act hle hn δ g z = ((g : ℍ → ℂ) ∣[(2 : ℤ)] (δ : SL(2, ℤ))) z := rfl
+
+theorem hasDerivAt_smul_ofComplex (γ : SL(2, ℤ)) (τ : ℍ) :
+    HasDerivAt (fun z : ℂ => ((γ • ofComplex z : ℍ) : ℂ))
+      (denom (Matrix.SpecialLinearGroup.mapGL ℝ γ) ↑τ ^ (-2 : ℤ)) ↑τ := by
+  set G : GL (Fin 2) ℝ := Matrix.SpecialLinearGroup.mapGL ℝ γ with hG
+  have hdet : (G : Matrix (Fin 2) (Fin 2) ℝ).det = 1 := by
+    rw [← Matrix.GeneralLinearGroup.val_det_apply, hG, Matrix.SpecialLinearGroup.det_mapGL,
+      Units.val_one]
+  have hpos : (0:ℝ) < (G : Matrix (Fin 2) (Fin 2) ℝ).det := by rw [hdet]; norm_num
+  have h1 := (UpperHalfPlane.hasStrictDerivAt_smul hpos τ).hasDerivAt
+  have h2 : (fun z : ℂ => ((G • ofComplex z : ℍ) : ℂ))
+      = fun z : ℂ => ((γ • ofComplex z : ℍ) : ℂ) := by
+    funext z
+    rw [MulAction.compHom_smul_def]
+  rw [h2] at h1
+  convert h1 using 1
+  rw [hdet]
+  push_cast
+  rw [zpow_neg, one_div]
+  norm_cast
+
+theorem hasDerivAt_comp_smul {G : ℍ → ℂ} {g : ℍ → ℂ}
+    (hG : ∀ τ : ℍ, HasDerivAt (G ∘ ofComplex) (g τ) ↑τ) (γ : SL(2, ℤ)) (τ : ℍ) :
+    HasDerivAt (fun z : ℂ => G (γ • ofComplex z)) ((g ∣[(2:ℤ)] γ) τ) ↑τ := by
+  have hfun : (fun z : ℂ => G (γ • ofComplex z))
+      = (G ∘ ofComplex) ∘ (fun z : ℂ => ((γ • ofComplex z : ℍ) : ℂ)) := by
+    funext z
+    simp only [Function.comp_apply, ofComplex_apply]
+  have houter : HasDerivAt (G ∘ ofComplex) (g (γ • τ))
+      ((fun z : ℂ => ((γ • ofComplex z : ℍ) : ℂ)) ↑τ) := by
+    simpa only [ofComplex_apply] using hG (γ • τ)
+  have hcomp := houter.comp (↑τ : ℂ) (hasDerivAt_smul_ofComplex γ τ)
+  rw [← hfun] at hcomp
+  convert hcomp using 1
+  exact ModularForm.SL_slash_apply (g : ℍ → ℂ) γ τ
+
+theorem hasEquivariantPrimitiveOf_act (δ : Γ) (g : CuspForm Γ' 2) {G : ℍ → ℂ}
+    (hG : ModularCurve.HasEquivariantPrimitiveOf Γ' g G) :
+    ∃ L : ℂ, ModularCurve.HasEquivariantPrimitiveOf Γ' (act hle hn δ g)
+      (fun z => G ((δ : SL(2, ℤ)) • z) - L) := by
+  obtain ⟨hder, _, hequiv, hlim⟩ := hG
+  obtain ⟨L, hL⟩ := hlim (δ : SL(2, ℤ))
+  refine ⟨L, ?_, ?_, ?_, ?_⟩
+  · intro τ
+    have h := (hasDerivAt_comp_smul (G := G) (g := (g : ℍ → ℂ)) hder (δ : SL(2, ℤ)) τ).sub_const L
+    exact h
+  · have : Tendsto (fun w : ℍ => G ((δ : SL(2, ℤ)) • w) - L) atImInfty (𝓝 (L - L)) :=
+      hL.sub_const L
+    rwa [sub_self] at this
+  · intro γ
+    refine ⟨hequiv.period ⟨(δ : SL(2, ℤ)) * γ * (δ : SL(2, ℤ))⁻¹, conj_mem hle hn γ.2 δ⟩, fun z =>
+      ?_⟩
+    have hz : (δ : SL(2, ℤ)) • ((γ : SL(2, ℤ)) • z) =
+        ((δ : SL(2, ℤ)) * γ * (δ : SL(2, ℤ))⁻¹) • ((δ : SL(2, ℤ)) • z) := by
+      rw [← mul_smul, ← mul_smul]
+      congr 1
+      group
+    change G ((δ : SL(2, ℤ)) • ((γ : SL(2, ℤ)) • z)) - L - (G ((δ : SL(2, ℤ)) • z) - L) = _
+    rw [hz, sub_sub_sub_cancel_right]
+    exact hequiv.sub_eq_period ⟨_, conj_mem hle hn γ.2 δ⟩ ((δ : SL(2, ℤ)) • z)
+  · intro δ₁
+    obtain ⟨L₁, hL₁⟩ := hlim ((δ : SL(2, ℤ)) * δ₁)
+    refine ⟨L₁ - L, ?_⟩
+    have : (fun w : ℍ => G ((δ : SL(2, ℤ)) • (δ₁ • w)) - L) =
+        fun w : ℍ => G (((δ : SL(2, ℤ)) * δ₁) • w) - L := by
+      funext w; rw [mul_smul]
+    rw [this]
+    exact hL₁.sub_const L
+
+theorem periodOf_act [Γ'.FiniteIndex] (δ : Γ) (g : CuspForm Γ' 2) (γ : Γ') :
+    ModularCurve.periodOf Γ' γ (act hle hn δ g) =
+      ModularCurve.periodOf Γ' ⟨(δ : SL(2, ℤ)) * γ * (δ : SL(2, ℤ))⁻¹, conj_mem hle hn γ.2 δ⟩ g
+        := by
+  obtain ⟨G, hG⟩ := ModularCurve.exists_hasEquivariantPrimitiveOf Γ' g
+  obtain ⟨L, hG'⟩ := hasEquivariantPrimitiveOf_act hle hn δ g hG
+  rw [ModularCurve.periodOf_apply_eq_sub_of_hasEquivariantPrimitiveOf Γ' _ hG' γ,
+    ModularCurve.periodOf_apply_eq_sub_of_hasEquivariantPrimitiveOf Γ' _ hG _]
+  have hequiv : ModularCurve.Period.IsEquivariantPrimitive Γ' G := hG.2.2.1
+  set ε : Γ' := ⟨(δ : SL(2, ℤ)) * γ * (δ : SL(2, ℤ))⁻¹, conj_mem hle hn γ.2 δ⟩ with hε
+  have hz : (δ : SL(2, ℤ)) • ((γ : SL(2, ℤ)) • UpperHalfPlane.I) =
+      (ε : SL(2, ℤ)) • ((δ : SL(2, ℤ)) • UpperHalfPlane.I) := by
+    rw [← mul_smul, ← mul_smul, hε]
+    congr 1
+    group
+  simp only [sub_sub_sub_cancel_right]
+  rw [hz]
+  have h1 := hequiv.sub_eq_period ε ((δ : SL(2, ℤ)) • UpperHalfPlane.I)
+  have h2 := hequiv.sub_eq_period ε UpperHalfPlane.I
+  rw [h1, ← h2]
+
+end Action
+
+section Descent
+
+variable {Γ' Γ : Subgroup SL(2, ℤ)} [Γ'.FiniteIndex]
+
+private theorem _root_.ModularCurve.ESDescent.finiteIndex_of_le (hle : Γ' ≤ Γ) :
+    Γ.FiniteIndex := Subgroup.finiteIndex_of_le hle
+
+p2m_export "ModularCurve.ESDescent" "finiteIndex_of_le"
+
+theorem isCusp_iff [Γ.FiniteIndex] {c : OnePoint ℝ} :
+    IsCusp c (Γ : Subgroup (GL (Fin 2) ℝ)) ↔ IsCusp c (Γ' : Subgroup (GL (Fin 2) ℝ)) := by
+  rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z (Γ : Subgroup (GL (Fin 2) ℝ)),
+    Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z (Γ' : Subgroup (GL (Fin 2) ℝ))]
+
+def lift [Γ.FiniteIndex] (g : CuspForm Γ' 2)
+    (hg : ∀ δ : Γ, ((g : ℍ → ℂ) ∣[(2 : ℤ)] (δ : SL(2, ℤ))) = g) : CuspForm Γ 2 where
+  toFun := g
+  slash_action_eq' A hA := by
+    obtain ⟨δ, hδ, rfl⟩ := hA
+    exact hg ⟨δ, hδ⟩
+  holo' := g.holo'
+  zero_at_cusps' hc := CuspFormClass.zero_at_cusps g ((isCusp_iff (Γ' := Γ') (Γ := Γ)).mp hc)
+
+theorem lower_lift [Γ.FiniteIndex] (hle : Γ' ≤ Γ) (g : CuspForm Γ' 2)
+    (hg : ∀ δ : Γ, ((g : ℍ → ℂ) ∣[(2 : ℤ)] (δ : SL(2, ℤ))) = g) :
+    lower hle (lift (Γ' := Γ') g hg) = g := by
+  ext z; rfl
+
+theorem realPeriodMap_surjective [Γ.FiniteIndex] (hle : Γ' ≤ Γ) (hn : (Γ'.subgroupOf Γ).Normal)
+    (hbij : Function.Bijective (realPeriodMap Γ')) :
+    Function.Surjective (realPeriodMap Γ) := by
+  intro x
+  obtain ⟨g, hg⟩ := hbij.2 (res hle x)
+  have hinv : ∀ δ : Γ, act hle hn δ g = g := by
+    intro δ
+    apply hbij.1
+    apply Subtype.ext
+    refine AddMonoidHom.ext fun a => ?_
+    rw [← ofMul_toMul a, realPeriodMap_apply, realPeriodMap_apply, periodOf_act hle hn δ g]
+    set γ : Γ' := Additive.toMul a
+    have h1 := congrArg (fun φ : ModularCurve.Period.parabolicHoms ℝ Γ' ℝ =>
+      (φ : Additive Γ' →+ ℝ) (Additive.ofMul
+        (⟨(δ : SL(2, ℤ)) * γ * (δ : SL(2, ℤ))⁻¹, conj_mem hle hn γ.2 δ⟩ : Γ'))) hg
+    have h2 := congrArg (fun φ : ModularCurve.Period.parabolicHoms ℝ Γ' ℝ =>
+      (φ : Additive Γ' →+ ℝ) (Additive.ofMul γ)) hg
+    simp only [realPeriodMap_apply, res_apply] at h1 h2
+    rw [h1, h2]
+    have hconj : (⟨(δ : SL(2, ℤ)) * γ * (δ : SL(2, ℤ))⁻¹, hle (conj_mem hle hn γ.2 δ)⟩ : Γ) =
+        δ * ⟨(γ : SL(2, ℤ)), hle γ.2⟩ * δ⁻¹ := rfl
+    rw [hconj, ofMul_mul, ofMul_mul, ofMul_inv, map_add, map_add, map_neg]
+    ring
+  have hinv' : ∀ δ : Γ, ((g : ℍ → ℂ) ∣[(2 : ℤ)] (δ : SL(2, ℤ))) = g := fun δ => by
+    have := congrArg (fun F : CuspForm Γ' 2 => (F : ℍ → ℂ)) (hinv δ)
+    simpa only [coe_act] using this
+  refine ⟨lift (Γ' := Γ') g hinv', ?_⟩
+  apply res_injective hle
+  rw [res_realPeriodMap hle, lower_lift hle g hinv', hg]
+
+theorem main (hle : Γ' ≤ Γ) (hn : (Γ'.subgroupOf Γ).Normal)
+    (h : Module.finrank ℤ (ModularCurve.Period.parabolicHoms ℤ Γ' ℤ) ≤
+      2 * Module.finrank ℂ (CuspForm Γ' 2)) :
+    Module.finrank ℤ (ModularCurve.Period.parabolicHoms ℤ Γ ℤ) ≤
+      2 * Module.finrank ℂ (CuspForm Γ 2) := by
+  have : Γ.FiniteIndex := finiteIndex_of_le hle
+  have hbij := realPeriodMap_bijective_of_le Γ' h
+  have hsurj := realPeriodMap_surjective hle hn hbij
+  obtain ⟨hfin, heq⟩ := finite_and_finrank_parabolicHoms_real_eq Γ
+  have := hfin
+  rw [← heq, ← finrank_real_cuspForm]
+  exact LinearMap.finrank_le_finrank_of_surjective hsurj
+
+end Descent
+
+end ModularCurve.ESDescent
+end
+
+theorem solution
+    (Γ' Γ : Subgroup SL(2, ℤ)) [Γ'.FiniteIndex] (hle : Γ' ≤ Γ) (hn : (Γ'.subgroupOf Γ).Normal)
+    (h : Module.finrank ℤ (ModularCurve.Period.parabolicHoms ℤ Γ' ℤ) ≤
+      2 * Module.finrank ℂ (CuspForm Γ' 2)) :
+    Module.finrank ℤ (ModularCurve.Period.parabolicHoms ℤ Γ ℤ) ≤
+      2 * Module.finrank ℂ (CuspForm Γ 2) :=
+  ModularCurve.ESDescent.main hle hn h
+
+end S_ModularCurve_finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_le_of_normal
+end P2MW
+export P2MW.S_ModularCurve_finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_le_of_normal
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.finrank_parabolicHoms_le_two_mul_finrank_cuspForm_of_le_of_normal
+    (Γ' Γ : Subgroup SL(2, ℤ)) [Γ'.FiniteIndex] (hle : Γ' ≤ Γ) (hn : (Γ'.subgroupOf Γ).Normal)
+    (h : Module.finrank ℤ (ModularCurve.Period.parabolicHoms ℤ Γ' ℤ) ≤
+      2 * Module.finrank ℂ (CuspForm Γ' 2)) :
+    Module.finrank ℤ (ModularCurve.Period.parabolicHoms ℤ Γ ℤ) ≤
+      2 * Module.finrank ℂ (CuspForm Γ 2) :=
+  solution Γ' Γ hle hn h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_parabolicHoms_le_two_mul_genusFormula.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_parabolicHoms_le_two_mul_genusFormula.lean
new file mode 100644
index 0000000000..ff2cf2ab93
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_finrank_parabolicHoms_le_two_mul_genusFormula.lean
@@ -0,0 +1,102 @@
+/-
+Based on Prove2Me node ModularCurve.finrank_parabolicHoms_le_two_mul_genusFormula
+(9f17692d-cfb8-560d-b46e-cc581ff77365) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1c1c96df-f2de-5249-b01b-3b1ff32f017f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodMap
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Rat.Star
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_CuspSpace_card_cuspSpace_eq_cuspCount
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_Gamma0_index
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_Period_six_mul_finrank_parabolicHoms_add_le_index
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_fixedPoints_ST_cosets_Gamma0_eq_nuThree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_fixedPoints_S_cosets_Gamma0_eq_nuTwo
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# dim_K H¹ₚₐᵣ(Γ₀(N),K) ≤ 2g(N)
+
+Theorem statement: `ModularCurve.finrank_parabolicHoms_le_two_mul_genusFormula`
+(`9f17692d-cfb8-560d-b46e-cc581ff77365`), by Claude, 2026-09-05.
+
+Proof: submission `1c1c96df-f2de-5249-b01b-3b1ff32f017f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and let $K$ be a field of characteristic zero. Write
+$\Gamma_0(N) \le \mathrm{SL}_2(\mathbb{Z})$ for the usual congruence subgroup and let
+$\mathrm{Period.parabolicHoms}$ denote the $K$-submodule of the additive homomorphisms $\varphi$
+from the abelianisation-free additive group $\mathrm{Additive}\,\Gamma_0(N)$ to $K$ consisting of
+those $\varphi$ satisfying the predicate `IsParabolicHom`, i.e. $\varphi(\gamma) = 0$ for every
+$\gamma \in \Gamma_0(N)$ whose underlying integral $2\times 2$ matrix has
+$(\operatorname{tr}\gamma)^2 = 4$ (so $\varphi$ kills $\pm 1$ and all parabolic elements). The
+assertion is that the $K$-dimension of this space, taken as `Module.finrank` and cast into
+$\mathbb{Q}$, satisfies $$\dim_K \mathrm{parabolicHoms} \;\le\; 2\left(1 + \frac{\psi(N)}{12} -
+\frac{\nu_2(N)}{4} - \frac{\nu_3(N)}{3} - \frac{\nu_\infty(N)}{2}\right),$$ where the right-hand
+side is twice [`ModularCurve.genusFormula N`](def/ModularCurve_GenusNumerics.html#L20), with
+$\psi(N) = \sum_{d \mid N,\ d \text{ squarefree}} N/d$, $\nu_2(N) = \#\{x \in \mathbb{Z}/N : x^2+1 =
+0\}$, $\nu_3(N) = \#\{x \in \mathbb{Z}/N : x^2+x+1 = 0\}$ and $\nu_\infty(N) = \sum_{d \mid N}
+\varphi(\gcd(d, N/d))$. Only the inequality is asserted, not the classical equality.
+
+This is the group-theoretic half of the Eichler–Shimura dimension count: classically the space of
+parabolic characters of $\Gamma_0(N)$ with values in a characteristic-zero field has dimension
+exactly $2g(X_0(N))$, and here the upper bound by twice the rational genus formula is recorded. It
+feeds the comparison of parabolic cohomology with cusp forms and the Eichler–Shimura dimension
+statement, and thence the Hecke-equivariant period computations.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_finrank_parabolicHoms_le_two_mul_genusFormula.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_finrank_parabolicHoms_le_two_mul_genusFormula
+
+theorem solution (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [CharZero K] :
+    (Module.finrank K (ModularCurve.Period.parabolicHoms K (CongruenceSubgroup.Gamma0 N) K) : ℚ) ≤
+      2 * ModularCurve.genusFormula N := by
+  have hE := ModularCurve.Period.six_mul_finrank_parabolicHoms_add_le_index N K
+  rw [ModularCurve.natCard_fixedPoints_S_cosets_Gamma0_eq_nuTwo N,
+    ModularCurve.natCard_fixedPoints_ST_cosets_Gamma0_eq_nuThree N,
+    ModularCurve.Gamma0_index N,
+    ModularCurve.CuspSpace.card_cuspSpace_eq_cuspCount (NeZero.ne N)] at hE
+  have hQ : (6 * Module.finrank K
+        (ModularCurve.Period.parabolicHoms K (CongruenceSubgroup.Gamma0 N) K)
+      + 6 * ModularCurve.cuspCount N + 3 * ModularCurve.nuTwo N + 4 * ModularCurve.nuThree N : ℚ)
+      ≤ 12 + ModularCurve.dedekindPsi N := by
+    exact_mod_cast hE
+  unfold ModularCurve.genusFormula
+  linarith
+
+end S_ModularCurve_finrank_parabolicHoms_le_two_mul_genusFormula
+end P2MW
+export P2MW.S_ModularCurve_finrank_parabolicHoms_le_two_mul_genusFormula (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.finrank_parabolicHoms_le_two_mul_genusFormula (N : ℕ) [NeZero N]
+    (K : Type*) [Field K] [CharZero K] :
+    (Module.finrank K (ModularCurve.Period.parabolicHoms K (CongruenceSubgroup.Gamma0 N) K) : ℚ) ≤
+      2 * ModularCurve.genusFormula N :=
+  solution N K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_frickeInvolutionBar_coeffEmb_qExpand.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_frickeInvolutionBar_coeffEmb_qExpand.lean
new file mode 100644
index 0000000000..51de267058
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_frickeInvolutionBar_coeffEmb_qExpand.lean
@@ -0,0 +1,98 @@
+/-
+Based on Prove2Me node ModularCurve.frickeInvolutionBar_coeffEmb_qExpand
+(05415233-8d55-57c1-b642-f13d86be225b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d9f5a616-a9e0-5b6f-9df3-20d8c9a8705f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CuspidalClass
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Fricke involution over ℚ̄ exchanges j(qᵃ) and j(qᵇ)
+
+Theorem statement: `ModularCurve.frickeInvolutionBar_coeffEmb_qExpand`
+(`05415233-8d55-57c1-b642-f13d86be225b`), by Claude, 2026-09-05.
+
+Proof: submission `d9f5a616-a9e0-5b6f-9df3-20d8c9a8705f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a positive natural number and suppose the canonically chosen automorphism
+`frickeInvolutionFull N` of the modular function field $F_N =$ `modularFunctionFieldFull N` — the
+intermediate field of $\mathbb{Q} \subseteq \mathbb{Q}((q))$ generated over $\mathbb{Q}$ by
+`divisorExpansions N` — satisfies `IsFrickeAutFull N`, i.e. for every factorisation $a'b' = N$ into
+positive naturals it carries the element $j(q^{a'})$, namely the image of the $q$-expansion `jq` $=
+q^{-1}\cdot$`jNumQ` under the substitution $q \mapsto q^{a'}$ (`qExpand ℚ a'`), to $j(q^{b'})$;
+membership of these elements in $F_N$ is provided by `jqd_mem_full`. Let $a, b$ be positive naturals
+with $a \cdot b = N$. Then the base-changed automorphism `frickeInvolutionBar N`, the image of
+`frickeInvolutionFull N` under `geomAut` and hence an $\bar{\mathbb{Q}}$-algebra automorphism of
+`modularFunctionFieldBar N` $=$ `laurentBaseChange (AlgebraicClosure ℚ)`$F_N$ inside
+$\bar{\mathbb{Q}}((q))$, sends the element with underlying series the coefficientwise image
+`coeffEmb` of $j(q^{a})$ along $\mathbb{Q} \to \bar{\mathbb{Q}}$ to the element with underlying
+series the coefficientwise image of $j(q^{b})$.
+
+This transports the defining exchange property of the Fricke involution $w_N$ on the function field
+of $X_0(N)$ over $\mathbb{Q}$ to the geometric function field over $\bar{\mathbb{Q}}$, where the
+geometric theory of $X_0(N)$, its cusps and its cuspidal divisor classes is developed. It is used
+throughout that development, for instance in identifying the $w_N$-image of the generator
+$j(q^{\,\cdot})$ and in the analysis of charts and centredness conditions on the geometric curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_frickeInvolutionBar_coeffEmb_qExpand.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_frickeInvolutionBar_coeffEmb_qExpand
+
+open ModularCurve AlgebraicCurve
+open scoped Pointwise
+
+theorem solution (N : ℕ) [NeZero N] (h : IsFrickeAutFull N (frickeInvolutionFull N)) (a b : ℕ)
+    (hab : a * b = N) [NeZero a] [NeZero b] :
+    frickeInvolutionBar N ⟨coeffEmb (AlgebraicClosure ℚ) (qExpand ℚ a jq),
+      coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jqd_mem_full N (Dvd.intro b hab))⟩ =
+      ⟨coeffEmb (AlgebraicClosure ℚ) (qExpand ℚ b jq), coeffEmb_mem_laurentBaseChange
+      (AlgebraicClosure ℚ) (jqd_mem_full N (Dvd.intro_left a hab))⟩ := by
+  rw [frickeInvolutionBar_def]
+  refine (geomAut_coeffEmb (AlgebraicClosure ℚ) (modularFunctionFieldFull N) (frickeInvolutionFull
+    N)
+    ⟨qExpand ℚ a jq, jqd_mem_full N (Dvd.intro b hab)⟩).trans (Subtype.ext ?_)
+  change coeffEmb (AlgebraicClosure ℚ) ((frickeInvolutionFull N ⟨qExpand ℚ a jq, _⟩ :
+    modularFunctionFieldFull N) :
+    LaurentSeries ℚ) = coeffEmb (AlgebraicClosure ℚ) (qExpand ℚ b jq)
+  rw [h a b hab ‹NeZero a› ‹NeZero b›]
+
+end S_ModularCurve_frickeInvolutionBar_coeffEmb_qExpand
+end P2MW
+export P2MW.S_ModularCurve_frickeInvolutionBar_coeffEmb_qExpand (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.frickeInvolutionBar_coeffEmb_qExpand (N : ℕ) [NeZero N]
+    (h : IsFrickeAutFull N (frickeInvolutionFull N)) (a b : ℕ) (hab : a * b = N) [NeZero a]
+    [NeZero b] :
+    frickeInvolutionBar N ⟨coeffEmb (AlgebraicClosure ℚ) (qExpand ℚ a jq),
+      coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jqd_mem_full N (Dvd.intro b hab))⟩ =
+      ⟨coeffEmb (AlgebraicClosure ℚ) (qExpand ℚ b jq), coeffEmb_mem_laurentBaseChange
+      (AlgebraicClosure ℚ) (jqd_mem_full N (Dvd.intro_left a hab))⟩ :=
+  solution N h a b hab
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_frobenius_identity_geom_unconditional.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_frobenius_identity_geom_unconditional.lean
new file mode 100644
index 0000000000..e3e444abbf
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_frobenius_identity_geom_unconditional.lean
@@ -0,0 +1,184 @@
+/-
+Based on Prove2Me node ModularCurve.frobenius_identity_geom_unconditional
+(b7d6f194-b12c-527c-90f4-f5fb00002353) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5de33f91-2c1c-5423-a8da-36b51a7e7d10
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_map_intCast_pow_char_eq_qExpand
+import Mathlib.RingTheory.Algebraic.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Frobenius identity j(q^ℓ)=j(q)^ℓ in characteristic ℓ
+
+Theorem statement: `ModularCurve.frobenius_identity_geom_unconditional`
+(`b7d6f194-b12c-527c-90f4-f5fb00002353`), by Claude, 2026-09-05.
+
+Proof: submission `5de33f91-2c1c-5423-a8da-36b51a7e7d10`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a commutative ring and let $\ell$ be a prime with $K$ of characteristic $\ell$. Write
+$\bar j =$ `jqModC K` for the $q$-expansion of the modular invariant with coefficients in $K$: the
+Laurent series $q^{-1}\cdot \iota(\mathrm{jNum}_K)$, where $\mathrm{jNum} = E_4^3\cdot
+\eta^{-1}$-type integral power series `jNum` is reduced along $\mathbb{Z}\to K$ and embedded into
+`LaurentSeries K`, and $q^{-1}$ is the Hahn-series monomial `single (-1) 1`. For $N \neq 0$,
+`jqNModC K N` is the image of $\bar j$ under the ring homomorphism `qExpand K N` of `LaurentSeries
+K`, which reindexes exponents by multiplication by $N$ on $\mathbb{Z}$, i.e. performs the
+substitution $q \mapsto q^{N}$. The assertion is the equality in `LaurentSeries K`
+$$\bar j(q^{\ell}) = \bar j(q)^{\ell},$$ that is, `jqNModC K ℓ = (jqModC K) ^ ℓ`. No field or
+integral-domain hypothesis on $K$ is imposed; only that it is a commutative ring of characteristic
+$\ell$.
+
+This is the $q$-expansion form of the Frobenius (Kronecker) congruence for the modular invariant in
+characteristic $\ell$: substituting $q^{\ell}$ for $q$ agrees with raising to the $\ell$-th power,
+because the expansion of $j$ has integral coefficients. It serves as the level-$\ell$ input for the
+characteristic-$\ell$ analysis of the modular curves in this development, and is used by the
+statements about places and supersingular points on $X(1)$ and $X_0(\ell)$ that depend on the
+reduced $q$-expansions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_frobenius_identity_geom_unconditional.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_frobenius_identity_geom_unconditional
+
+noncomputable section
+open HahnSeries
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC jqNModC jqModC_eq_map_intCast qExpand qExpand_congr \
+  qExpand_qExpand jNum constantCoeff_jNum ofPowerSeries_coeff_of_neg jq_pow \
+  map_intCast_pow_char_eq_qExpand"
+p2m_open "ModularCurve"
+namespace CharLRows
+
+variable (K : Type*) [CommRing K]
+
+theorem jqModC_pow (n : ℕ) :
+    (jqModC K) ^ n = HahnSeries.single (-(n : ℤ)) 1 *
+      HahnSeries.ofPowerSeries ℤ K ((jNum.map (Int.castRingHom K)) ^ n) := by
+  have h : n • (-1 : ℤ) = -(n : ℤ) := by simp
+  rw [jqModC, mul_pow, HahnSeries.single_pow, one_pow, h, ← map_pow]
+
+theorem constantCoeff_jNum_map : PowerSeries.constantCoeff (jNum.map (Int.castRingHom K)) = 1 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff, PowerSeries.coeff_map,
+    PowerSeries.coeff_zero_eq_constantCoeff,
+    constantCoeff_jNum, map_one]
+
+theorem coeff_jqModC_pow_self (n : ℕ) : ((jqModC K) ^ n).coeff (-(n : ℤ)) = 1 := by
+  rw [jqModC_pow, HahnSeries.coeff_single_mul, one_mul, sub_neg_eq_add, neg_add_cancel,
+    show (0 : ℤ) = ((0 : ℕ) : ℤ) from rfl, HahnSeries.ofPowerSeries_apply_coeff,
+    PowerSeries.coeff_zero_eq_constantCoeff, map_pow, constantCoeff_jNum_map, one_pow]
+
+theorem coeff_jqModC_pow_of_lt {n : ℕ} {m : ℤ} (hm : m < -(n : ℤ)) :
+    ((jqModC K) ^ n).coeff m = 0 := by
+  rw [jqModC_pow, HahnSeries.coeff_single_mul, one_mul]
+  exact ofPowerSeries_coeff_of_neg _ (by omega)
+
+theorem coeff_jqModC_neg_one : (jqModC K).coeff (-1 : ℤ) = 1 := by
+  simpa using coeff_jqModC_pow_self K 1
+
+theorem algebraMap_laurentSeries_eq_single (c : K) :
+    algebraMap K (LaurentSeries K) c = HahnSeries.single 0 c := by
+  have h1 : algebraMap K (PowerSeries K) c = PowerSeries.C c := by simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+  rfl
+
+theorem aeval_jqModC_eq_zero {p : Polynomial K} (hp : Polynomial.aeval (jqModC K) p = 0) :
+    p = 0 := by
+  by_contra hp0
+  set n := p.natDegree with hn
+  have hcoeff : (Polynomial.aeval (jqModC K) p).coeff (-(n : ℤ)) = p.coeff n := by
+    rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+      Finset.sum_eq_single n]
+    · rw [algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_zero_mul,
+        coeff_jqModC_pow_self, mul_one]
+    · intro i hi hin
+      have hilt : i < n := lt_of_le_of_ne (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hin
+      rw [algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_zero_mul,
+        coeff_jqModC_pow_of_lt, mul_zero]
+      omega
+    · intro hn'
+      exact absurd (Finset.self_mem_range_succ n) hn'
+  rw [hp] at hcoeff
+  simp only [HahnSeries.coeff_zero] at hcoeff
+  exact hp0 (Polynomial.leadingCoeff_eq_zero.mp hcoeff.symm)
+
+theorem transcendental_jqModC : Transcendental K (jqModC K) :=
+  transcendental_iff.mpr fun _ hp => aeval_jqModC_eq_zero K hp
+
+theorem jqModC_ne_zero [Nontrivial K] : jqModC K ≠ 0 := by
+  intro h
+  have h1 : (jqModC K).coeff (-1 : ℤ) = 1 := coeff_jqModC_neg_one K
+  rw [h, HahnSeries.coeff_zero] at h1
+  exact zero_ne_one h1
+
+theorem order_jqModC [Nontrivial K] : (jqModC K).order = -1 := by
+  refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero ?_) ?_
+  · rw [coeff_jqModC_neg_one]
+    exact one_ne_zero
+  · by_contra hlt
+    rw [not_le] at hlt
+    refine HahnSeries.coeff_order_eq_zero.not.mpr (jqModC_ne_zero K) ?_
+    have h := coeff_jqModC_pow_of_lt K (n := 1) (m := (jqModC K).order)
+      (by simpa using hlt)
+    simpa using h
+
+theorem qExpand_jqModC_eq_pow (ℓ : ℕ) [Fact ℓ.Prime] [CharP K ℓ] :
+    qExpand K ℓ (jqModC K) = (jqModC K) ^ ℓ := by
+  rw [jqModC_eq_map_intCast K]
+  exact (map_intCast_pow_char_eq_qExpand ℓ _).symm
+
+theorem qExpand_jqNModC_eq_pow (N : ℕ) [NeZero N] (ℓ : ℕ) [Fact ℓ.Prime] [CharP K ℓ] :
+    qExpand K ℓ (jqNModC K N) = (jqNModC K N) ^ ℓ := by
+  rw [jqNModC, qExpand_qExpand, qExpand_congr (mul_comm ℓ N), ← qExpand_qExpand,
+    qExpand_jqModC_eq_pow K ℓ, map_pow]
+
+theorem frobenius_identity_geom (ℓ : ℕ) [Fact ℓ.Prime] [CharP K ℓ] :
+    jqNModC K ℓ = (jqModC K) ^ ℓ := by
+  rw [jqNModC]; exact qExpand_jqModC_eq_pow K ℓ
+
+end CharLRows
+
+end ModularCurve
+end
+
+open _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_frobenius_identity_geom_unconditional.ModularCurve in
+theorem solution (K : Type*) [CommRing K] {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ] :
+    jqNModC K ℓ = (jqModC K) ^ ℓ :=
+  CharLRows.frobenius_identity_geom K ℓ
+
+end S_ModularCurve_frobenius_identity_geom_unconditional
+end P2MW
+export P2MW.S_ModularCurve_frobenius_identity_geom_unconditional (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.frobenius_identity_geom_unconditional (K : Type*) [CommRing K] {ℓ : ℕ}
+    [Fact ℓ.Prime] [CharP K ℓ] :
+    jqNModC K ℓ = (jqModC K) ^ ℓ :=
+  solution K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_full_eq_adjoin_full_div_prime.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_full_eq_adjoin_full_div_prime.lean
new file mode 100644
index 0000000000..733ed6e409
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_full_eq_adjoin_full_div_prime.lean
@@ -0,0 +1,653 @@
+/-
+Based on Prove2Me node ModularCurve.full_eq_adjoin_full_div_prime
+(c10721c8-dc8c-5368-ac90-71ad4bf26f14) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ea291b57-3d28-5a2b-acf9-18f4e6485c63
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Polynomial_mem_range_of_unique_common_root
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_injective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Level Mpᵃ⁺¹ divisor-expansion field is generated by j(q^pᵃ⁺¹)
+
+Theorem statement: `ModularCurve.full_eq_adjoin_full_div_prime`
+(`c10721c8-dc8c-5368-ac90-71ad4bf26f14`), by Claude, 2026-09-05.
+
+Proof: submission `ea291b57-3d28-5a2b-acf9-18f4e6485c63`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a nonzero natural number, $p$ a prime, $a$ a natural number, and suppose $p \nmid M$.
+Work inside the Laurent series field $\mathrm{LaurentSeries}\,\mathbb{Q}$, and for a nonzero natural
+number $N$ write $\mathrm{jqN}(N) = \mathrm{qExpand}\,\mathbb{Q}\,N\,\mathrm{jq}$, the image of the
+$j$-expansion $\mathrm{jq}$ under the ring homomorphism that multiplies all Hahn-series exponents by
+$N$ (substitution $q \mapsto q^{N}$). For such $N$, `modularFunctionFieldFull N` is the intermediate
+field of $\mathrm{LaurentSeries}\,\mathbb{Q}$ over $\mathbb{Q}$ generated by the set of all
+$\mathrm{qExpand}\,\mathbb{Q}\,d\,\mathrm{jq}$ with $d$ a nonzero divisor of $N$. The assertion is
+the equality of intermediate fields $$\mathrm{modularFunctionFieldFull}(M p^{a+1}) =
+\mathbb{Q}\bigl(\{\mathrm{jqN}(p^{a+1})\} \cup \mathrm{modularFunctionFieldFull}(M p^{a})\bigr),$$
+where on the right the element $\mathrm{jqN}(p^{a+1})$ is inserted into the carrier set of the
+level-$Mp^{a}$ field and the ℚ-adjoin of the resulting set is taken; that is, adjoining the single
+new expansion $j(q^{p^{a+1}})$ to the level-$Mp^{a}$ field already produces every $j(q^{d})$ with $d
+\mid M p^{a+1}$.
+
+This is an induction step in the generation theory for the $q$-expansion model of the function field
+of $X_0(N)$ over $\mathbb{Q}$: it reduces the divisor-expansion field at level $Mp^{a+1}$ to the
+level $Mp^{a}$ field together with the top $p$-power expansion. It is used in the construction of
+irreducible modular-polynomial data, in the production of Atkin–Lehner type automorphisms at primes
+not dividing the level, and in the computation of degeneracy and Hecke operators.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_full_eq_adjoin_full_div_prime.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_full_eq_adjoin_full_div_prime
+
+noncomputable section
+
+p2m_open "ModularCurve~coeffEmb_qExpand \
+  P2MW.S_ModularCurve_full_eq_adjoin_full_div_prime.ModularCurve ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionFieldFull jqd_mem_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+
+
+
+
+
+
+
+
+
+
+theorem coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb K (qExpand ℚ n x) = qExpand K n (coeffEmb K x) :=
+  coeffMap_qExpand (algebraMap ℚ K) n x
+
+theorem iota_jqN (N d : ℕ) [NeZero N] [NeZero d] :
+    coeffEmb K (qExpand ℚ N (jqN d)) = TS K (N * d) 1 := by
+  rw [jqN, coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem iota_jq (N : ℕ) [NeZero N] : coeffEmb K (qExpand ℚ N jq) = TS K N 1 := by
+  rw [coeffEmb_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_zero_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    conj p ζ (0 : Fin (p + 1)) = TS K (p * p) 1 := by
+  rw [conj_zero, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_succ_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) (b : Fin p) :
+    conj p ζ b.succ = TS K 1 (ζ ^ (b : ℕ)) := by
+  rw [conj_succ, TS_eq_coeffEmb, qExpand_one_apply]
+
+theorem qTwist_iota_of_pow_eq_one (N : ℕ) [NeZero N] (v : Kˣ) (hv : v ^ N = 1) (x : LaurentSeries ℚ)
+    :
+    qTwist v (coeffEmb K (qExpand ℚ N x)) = coeffEmb K (qExpand ℚ N x) := by
+  rw [coeffEmb_qExpand, qTwist_qExpand]
+  have : v ^ (N : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionFieldFull jqd_mem_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+omit [Algebra ℚ K] in
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+omit [Algebra ℚ K] in
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+omit [Algebra ℚ K] in
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem phiProd_conj_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    phiProd p (conj p ζ) = (Polynomial.X - Polynomial.C (TS K (p * p) 1)) *
+      ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) := by
+  rw [phiProd, Fin.prod_univ_succ, conj_zero_eq]
+  congr 1
+  rw [← Fin.prod_univ_eq_prod_range (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) p]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [conj_succ_eq]
+
+theorem roots_phiProd_conj (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    (phiProd p (conj p ζ)).roots = TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^
+      b)) := by
+  classical
+  rw [phiProd_conj_eq]
+  have h1 : (Polynomial.X - Polynomial.C (TS K (p * p) 1) : Polynomial (LaurentSeries K)) ≠ 0 :=
+    Polynomial.X_sub_C_ne_zero _
+  have h2 : (∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b)))) ≠ 0 :=
+    Finset.prod_ne_zero_iff.mpr fun b _ => Polynomial.X_sub_C_ne_zero _
+  rw [Polynomial.roots_mul (mul_ne_zero h1 h2), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod,
+    Finset.range_val]
+  have hm : (Multiset.map (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) (Multiset.range
+    p)) =
+      ((Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).map (fun a => Polynomial.X - Polynomial.C
+        a) := by
+    rw [Multiset.map_map]; rfl
+  rw [hm, Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+omit [Algebra ℚ K] in
+theorem roots_phiProd_conj_nodup (p : ℕ) [hp : Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).Nodup := by
+  refine Multiset.nodup_cons.mpr ⟨?_, ?_⟩
+  · intro hmem
+    obtain ⟨b, -, hb⟩ := Multiset.mem_map.mp hmem
+    have := (TS_injective hb).1
+    have h2 := hp.out.two_le
+    nlinarith
+  · refine (Multiset.nodup_range p).map_on fun b hb b' hb' hbb' => ?_
+    rw [Multiset.mem_range] at hb hb'
+    have hu := (TS_injective hbb').2
+    have hζu : IsPrimitiveRoot ζ p := IsPrimitiveRoot.coe_units_iff.mp hζ
+    exact hζu.pow_inj hb hb' hu
+
+theorem exists_isPrimitiveRoot_cyclotomicField (N : ℕ) [NeZero N] :
+    ∃ z : CyclotomicField N ℚ, IsPrimitiveRoot z N := by
+  have : NeZero ((N : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr (NeZero.ne N)⟩
+  have : IsCyclotomicExtension {N} ℚ (CyclotomicField N ℚ) :=
+    CyclotomicField.isCyclotomicExtension N ℚ
+  exact IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField N ℚ) (Set.mem_singleton N)
+    (NeZero.ne N)
+
+def cycUnit (N : ℕ) [NeZero N] : (CyclotomicField N ℚ)ˣ :=
+  ((exists_isPrimitiveRoot_cyclotomicField N).choose_spec.isUnit (NeZero.ne N)).unit
+
+theorem cycUnit_spec (N : ℕ) [NeZero N] :
+    IsPrimitiveRoot ((cycUnit N : (CyclotomicField N ℚ)ˣ) : CyclotomicField N ℚ) N := by
+  rw [cycUnit, IsUnit.unit_spec]
+  exact (exists_isPrimitiveRoot_cyclotomicField N).choose_spec
+
+theorem cycUnit_pow (N : ℕ) [NeZero N] : cycUnit N ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, (cycUnit_spec N).pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionFieldFull jqd_mem_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionFieldFull jqd_mem_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem prod_form_ne_zero (N : ℕ) (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e]
+    (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K
+            jq)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+          (Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u,
+    Polynomial.roots_mul (prod_form_ne_zero N ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p)))
+    (coeffEmb K jq))))
+        = ((Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+        (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+        (Multiset.range p).map
+          (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).Nodup := by
+  have hζp : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := isPrimitiveRoot_pow_div hζ hpN
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h := (TS_injective (K := K) (e := e) (e' := p * (p * e))
+      (u := u * ζ ^ (b * (N / p))) (u' := u ^ (p * p))
+      (by simpa only [TS_eq_coeffEmb] using heq)).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e)
+      (u := u * ζ ^ (b * (N / p))) (u' := u * ζ ^ (b' * (N / p)))
+      (by simpa only [TS_eq_coeffEmb] using heq)).2
+    have h2 : ζ ^ (b * (N / p)) = ζ ^ (b' * (N / p)) := mul_left_cancel h
+    have h3 : (ζ ^ (N / p)) ^ b = (ζ ^ (N / p)) ^ b' := by
+      rw [← pow_mul, ← pow_mul, Nat.mul_comm (N / p) b, Nat.mul_comm (N / p) b']
+      exact h2
+    have h4 : ((ζ ^ (N / p) : Kˣ) : K) ^ b = ((ζ ^ (N / p) : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h3]
+    exact hζp.pow_inj hb hb' h4
+
+theorem roots_prime_at_slot_roots_nodup (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots.Nodup := by
+  rw [roots_prime_at_slot N ζ hζ p hpN data e u]
+  exact roots_prime_at_slot_nodup N ζ hζ p hpN e u
+
+theorem isRoot_prime_at_slot_iff (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u]
+    exact prod_form_ne_zero N ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot N ζ hζ p hpN data e u,
+    Multiset.mem_cons, Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionFieldFull jqd_mem_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+
+
+
+
+theorem phiAtSeed_jq_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) :
+    (phiAtSeed data jq).eval (jqN n) = 0 := by
+  have h := data.eval_eq_zero
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp [evalAtJ_X]
+
+
+theorem phiAtSeed_jqN_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN M)).eval (jqN (M * n)) = 0 := by
+  have h := phiAtSeed_eval_map data jq (jqN n) (qExpand ℚ M) (phiAtSeed_jq_eval n data)
+  rwa [jqN, qExpand_qExpand] at h
+
+theorem phiAtSeed_iota_eval {K : Type*} [Field K] [Algebra ℚ K] (A : ℕ) [NeZero A] (n : ℕ)
+    [NeZero n]
+    (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (coeffEmb K (qExpand ℚ A (jqN M)))).eval (coeffEmb K (qExpand ℚ A (jqN (M *
+      n)))) = 0 :=
+  phiAtSeed_eval_map data _ _ ((coeffEmb K).comp (qExpand ℚ A)) (phiAtSeed_jqN_eval n data M)
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionFieldFull jqd_mem_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+private theorem jqN_mem_of_div_primes {K : Type*} [Field K] [Algebra ℚ K]
+    {N : ℕ} [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    {F : IntermediateField ℚ (LaurentSeries ℚ)}
+    {d : ℕ} [NeZero d] (hdN : d ∣ N)
+    {p q : ℕ} (pp : Nat.Prime p) (qq : Nat.Prime q) (hpq : p ≠ q)
+    (hpd : p ∣ d) (hqd : q ∣ d) [NeZero (d / p)] [NeZero (d / q)]
+    (hmp : jqN (d / p) ∈ F) (hmq : jqN (d / q) ∈ F) :
+    jqN d ∈ F := by
+  have : Fact (Nat.Prime p) := ⟨pp⟩
+  have : Fact (Nat.Prime q) := ⟨qq⟩
+  have : NeZero p := ⟨pp.ne_zero⟩
+  have : NeZero q := ⟨qq.ne_zero⟩
+  have hpN : p ∣ N := hpd.trans hdN
+  have hqN : q ∣ N := hqd.trans hdN
+  have hNp0 : N / p ≠ 0 := fun h0 => NeZero.ne N (by rw [← Nat.div_mul_cancel hpN, h0, zero_mul])
+  have hNq0 : N / q ≠ 0 := fun h0 => NeZero.ne N (by rw [← Nat.div_mul_cancel hqN, h0, zero_mul])
+  have : NeZero (N / p) := ⟨hNp0⟩
+  have : NeZero (N / q) := ⟨hNq0⟩
+  have hpe : p * (N / p * (d / p)) = N * (d / p) := by
+    rw [← mul_assoc, Nat.mul_div_cancel' hpN]
+  have hqe : q * (N / q * (d / q)) = N * (d / q) := by
+    rw [← mul_assoc, Nat.mul_div_cancel' hqN]
+  have hpe2 : p * (p * (N / p * (d / p))) = N * d := by
+    rw [hpe, mul_left_comm, Nat.mul_div_cancel' hpd]
+  have hqe2 : q * (q * (N / q * (d / q))) = N * d := by
+    rw [hqe, mul_left_comm, Nat.mul_div_cancel' hqd]
+  have data_p : ModularPolynomialData p := (ModularCurve.exists_phiIrreducible_evalSymm p).choose
+  have data_q : ModularPolynomialData q := (ModularCurve.exists_phiIrreducible_evalSymm q).choose
+  let : Algebra F (LaurentSeries K) :=
+    (((coeffEmb K).comp (qExpand ℚ N)).comp (algebraMap F (LaurentSeries ℚ))).toAlgebra
+  have hmapA : (phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)).map (algebraMap F (LaurentSeries K))
+      = phiAtSeed data_p (coeffEmb K (qExpand ℚ N (jqN (d / p)))) :=
+    phiAtSeed_map data_p _ _
+  have hmapB : (phiAtSeed data_q (⟨jqN (d / q), hmq⟩ : F)).map (algebraMap F (LaurentSeries K))
+      = phiAtSeed data_q (coeffEmb K (qExpand ℚ N (jqN (d / q)))) :=
+    phiAtSeed_map data_q _ _
+  have hseed_p : coeffEmb K (qExpand ℚ N (jqN (d / p)))
+      = qExpand K (p * (N / p * (d / p))) (qTwist ((1 : Kˣ) ^ p) (coeffEmb K jq)) := by
+    have h2 : TS K (N * (d / p)) 1 = TS K (p * (N / p * (d / p))) ((1 : Kˣ) ^ p) := by
+      rw [one_pow]
+      exact TS_congr hpe.symm 1
+    simpa only [TS_eq_coeffEmb] using (iota_jqN N (d / p)).trans h2
+  have hseed_q : coeffEmb K (qExpand ℚ N (jqN (d / q)))
+      = qExpand K (q * (N / q * (d / q))) (qTwist ((1 : Kˣ) ^ q) (coeffEmb K jq)) := by
+    have h2 : TS K (N * (d / q)) 1 = TS K (q * (N / q * (d / q))) ((1 : Kˣ) ^ q) := by
+      rw [one_pow]
+      exact TS_congr hqe.symm 1
+    simpa only [TS_eq_coeffEmb] using (iota_jqN N (d / q)).trans h2
+  have hdist_p : coeffEmb K (qExpand ℚ N (jqN d))
+      = qExpand K (p * (p * (N / p * (d / p)))) (qTwist ((1 : Kˣ) ^ (p * p)) (coeffEmb K jq)) := by
+    have h2 : TS K (N * d) 1 = TS K (p * (p * (N / p * (d / p)))) ((1 : Kˣ) ^ (p * p)) := by
+      rw [one_pow]
+      exact TS_congr hpe2.symm 1
+    simpa only [TS_eq_coeffEmb] using (iota_jqN N d).trans h2
+  have hdist_q : coeffEmb K (qExpand ℚ N (jqN d))
+      = qExpand K (q * (q * (N / q * (d / q)))) (qTwist ((1 : Kˣ) ^ (q * q)) (coeffEmb K jq)) := by
+    have h2 : TS K (N * d) 1 = TS K (q * (q * (N / q * (d / q)))) ((1 : Kˣ) ^ (q * q)) := by
+      rw [one_pow]
+      exact TS_congr hqe2.symm 1
+    simpa only [TS_eq_coeffEmb] using (iota_jqN N d).trans h2
+  have hrootA : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)) = 0 ↔
+        (y = qExpand K (p * (p * (N / p * (d / p)))) (qTwist ((1 : Kˣ) ^ (p * p)) (coeffEmb K jq)) ∨
+          ∃ b < p, y = qExpand K (N / p * (d / p)) (qTwist (1 * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+            := by
+    intro y
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hmapA, hseed_p]
+    exact isRoot_prime_at_slot_iff N ζ hζ p hpN data_p (N / p * (d / p)) 1 y
+  have hrootB : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_q (⟨jqN (d / q), hmq⟩ : F)) = 0 ↔
+        (y = qExpand K (q * (q * (N / q * (d / q)))) (qTwist ((1 : Kˣ) ^ (q * q)) (coeffEmb K jq)) ∨
+          ∃ c < q, y = qExpand K (N / q * (d / q)) (qTwist (1 * ζ ^ (c * (N / q))) (coeffEmb K jq)))
+            := by
+    intro y
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hmapB, hseed_q]
+    exact isRoot_prime_at_slot_iff N ζ hζ q hqN data_q (N / q * (d / q)) 1 y
+  have hA0 : phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F) ≠ 0 := (phiAtSeed_monic data_p _).ne_zero
+  have hAs : ((phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)).map
+      (algebraMap F (LaurentSeries K))).Splits := by
+    rw [hmapA, hseed_p, phiAtSeed,
+      ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data_p (N / p * (d / p)) 1]
+    exact (Polynomial.Splits.X_sub_C _).mul
+      (Polynomial.Splits.prod fun b _ => Polynomial.Splits.X_sub_C _)
+  have hAnd : ((phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)).map
+      (algebraMap F (LaurentSeries K))).roots.Nodup := by
+    rw [hmapA, hseed_p, phiAtSeed]
+    exact roots_prime_at_slot_roots_nodup N ζ hζ p hpN data_p (N / p * (d / p)) 1
+  have hxA : Polynomial.aeval (coeffEmb K (qExpand ℚ N (jqN d)))
+      (phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)) = 0 :=
+    (hrootA _).mpr (Or.inl hdist_p)
+  have hxB : Polynomial.aeval (coeffEmb K (qExpand ℚ N (jqN d)))
+      (phiAtSeed data_q (⟨jqN (d / q), hmq⟩ : F)) = 0 :=
+    (hrootB _).mpr (Or.inl hdist_q)
+  have huniq : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)) = 0 →
+      Polynomial.aeval y (phiAtSeed data_q (⟨jqN (d / q), hmq⟩ : F)) = 0 →
+      y = coeffEmb K (qExpand ℚ N (jqN d)) := by
+    intro y hyA hyB
+    rcases (hrootA y).mp hyA with hy1 | ⟨b, hb, hy1⟩
+    · exact hy1.trans hdist_p.symm
+    · rcases (hrootB y).mp hyB with hy2 | ⟨c, hc, hy2⟩
+      · exact hy2.trans hdist_q.symm
+      · exfalso
+        have hTS : TS K (N / p * (d / p)) (1 * ζ ^ (b * (N / p)))
+            = TS K (N / q * (d / q)) (1 * ζ ^ (c * (N / q))) := by
+              simpa only [TS_eq_coeffEmb] using hy1.symm.trans hy2
+        have he : N / p * (d / p) = N / q * (d / q) := (TS_injective hTS).1
+        have h1 : p * p * (N / p * (d / p)) = q * q * (N / p * (d / p)) := by
+          rw [mul_assoc, hpe2, mul_assoc, he, hqe2]
+        have h2 : p * p = q * q :=
+          Nat.eq_of_mul_eq_mul_right (Nat.pos_of_ne_zero (NeZero.ne (N / p * (d / p)))) h1
+        have h3 : q ∣ p * p := by rw [h2]; exact dvd_mul_right q q
+        have h4 : q ∣ p := ((Nat.Prime.dvd_mul qq).mp h3).elim id id
+        exact hpq (((Nat.prime_dvd_prime_iff_eq qq pp).mp h4).symm)
+  have hrange := Polynomial.mem_range_of_unique_common_root
+    (phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)) (phiAtSeed data_q (⟨jqN (d / q), hmq⟩ : F))
+    hA0 hAs hAnd (coeffEmb K (qExpand ℚ N (jqN d))) hxA hxB huniq
+  obtain ⟨f, hf⟩ := RingHom.mem_range.mp hrange
+  have hf' : coeffEmb K (qExpand ℚ N ((f : LaurentSeries ℚ)))
+      = coeffEmb K (qExpand ℚ N (jqN d)) := hf
+  have hemb : Function.Injective (coeffEmb K) :=
+    ModularCurve.coeffMap_injective ((algebraMap ℚ K).injective)
+  have hval : (f : LaurentSeries ℚ) = jqN d := qExpand_injective N (hemb hf')
+  rw [← hval]
+  exact f.2
+
+private theorem jqN_congr' {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) : jqN n = jqN m := by
+  subst h; rfl
+
+private theorem w1_jqN_mem_adjoin_top_insert (M : ℕ) [NeZero M] (p : ℕ)
+    [hp : Fact (Nat.Prime p)] (a : ℕ) (hpM : ¬ p ∣ M) :
+    ∀ (d : ℕ) [NeZero d], d ∣ M * p ^ (a + 1) →
+      jqN d ∈ IntermediateField.adjoin ℚ
+        (insert (jqN (p ^ (a + 1))) (modularFunctionFieldFull (M * p ^ a) :
+          Set (LaurentSeries ℚ))) := by
+  intro d
+  induction d using Nat.strong_induction_on with
+  | _ d ih =>
+    intro hd0 hdN
+    by_cases hbase : d ∣ M * p ^ a
+    · exact IntermediateField.subset_adjoin ℚ _
+        (Set.mem_insert_of_mem _ (jqd_mem_full (M * p ^ a) hbase))
+    · have hcop : Nat.Coprime M (p ^ (a + 1)) :=
+        (Nat.Coprime.pow_right _ (((Nat.Prime.coprime_iff_not_dvd hp.out).mpr hpM).symm))
+      have hsplit : Nat.gcd d M * Nat.gcd d (p ^ (a + 1)) = d :=
+        (Nat.gcd_mul_gcd_eq_iff_dvd_mul_of_coprime hcop).mpr hdN
+      set m := Nat.gcd d M with hmdef
+      have hmM : m ∣ M := Nat.gcd_dvd_right d M
+      have hm0 : m ≠ 0 := fun h0 => NeZero.ne M (Nat.eq_zero_of_zero_dvd (h0 ▸ hmM))
+      obtain ⟨j, hj, hpj⟩ := (Nat.dvd_prime_pow hp.out).mp (Nat.gcd_dvd_right d (p ^ (a + 1)))
+      have hd : d = m * p ^ j := by rw [← hsplit, hpj]
+      have hja : j = a + 1 := by
+        by_contra hja
+        exact hbase (hd ▸ mul_dvd_mul hmM (pow_dvd_pow p (by omega)))
+      rw [hja] at hd
+      rcases eq_or_ne m 1 with hm1 | hm1
+      · rw [jqN_congr' (show d = p ^ (a + 1) by rw [hd, hm1, one_mul])]
+        exact IntermediateField.subset_adjoin ℚ _ (Set.mem_insert _ _)
+      · set q := m.minFac with hqdef
+        have hq : q.Prime := Nat.minFac_prime hm1
+        have hqm : q ∣ m := Nat.minFac_dvd m
+        have hqp : p ≠ q := fun h => hpM ((h ▸ hqm).trans hmM)
+        have hpd : p ∣ d := hd ▸ Dvd.dvd.mul_left (dvd_pow_self p (Nat.succ_ne_zero a)) m
+        have hqd : q ∣ d := hd ▸ (hqm.trans (dvd_mul_right m (p ^ (a + 1))))
+        obtain ⟨m', hm'⟩ := hqm
+        have hm'0 : m' ≠ 0 := fun h0 => hm0 (by rw [hm', h0, Nat.mul_zero])
+        have hdp : d / p = m * p ^ a := by
+          rw [hd, pow_succ, ← Nat.mul_assoc, Nat.mul_div_cancel _ hp.out.pos]
+        have hdq : d / q = m' * p ^ (a + 1) := by
+          rw [hd, hm', Nat.mul_assoc, Nat.mul_div_cancel_left _ hq.pos]
+        have : NeZero (d / p) :=
+          ⟨by rw [hdp]; exact Nat.mul_ne_zero hm0 (pow_ne_zero _ hp.out.ne_zero)⟩
+        have : NeZero (d / q) :=
+          ⟨by rw [hdq]; exact Nat.mul_ne_zero hm'0 (pow_ne_zero _ hp.out.ne_zero)⟩
+        have hmem_p : jqN (d / p) ∈ IntermediateField.adjoin ℚ
+            (insert (jqN (p ^ (a + 1))) (modularFunctionFieldFull (M * p ^ a) :
+              Set (LaurentSeries ℚ))) := by
+          refine IntermediateField.subset_adjoin ℚ _ (Set.mem_insert_of_mem _
+            (jqd_mem_full (M * p ^ a) ?_))
+          rw [hdp]
+          exact mul_dvd_mul hmM dvd_rfl
+        have hmem_q : jqN (d / q) ∈ IntermediateField.adjoin ℚ
+            (insert (jqN (p ^ (a + 1))) (modularFunctionFieldFull (M * p ^ a) :
+              Set (LaurentSeries ℚ))) := by
+          refine ih (d / q) (Nat.div_lt_self (Nat.pos_of_ne_zero hd0.out) hq.one_lt) ?_
+          exact (Nat.div_dvd_of_dvd hqd).trans hdN
+        exact jqN_mem_of_div_primes (cycUnit (M * p ^ (a + 1)))
+          (cycUnit_spec (M * p ^ (a + 1))) hdN hp.out hq hqp hpd hqd hmem_p hmem_q
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionFieldFull jqd_mem_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot coeffMap_injective exists_phiIrreducible_evalSymm"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.full_eq_adjoin_full_div_prime (M : ℕ) [NeZero M] (p : ℕ)
+    [hp : Fact (Nat.Prime p)] (a : ℕ) (hpM : ¬ p ∣ M) :
+    modularFunctionFieldFull (M * p ^ (a + 1)) =
+      IntermediateField.adjoin ℚ
+        (insert (jqN (p ^ (a + 1))) (modularFunctionFieldFull (M * p ^ a) :
+          Set (LaurentSeries ℚ))) := by
+  refine le_antisymm ?_ ?_
+  · rw [modularFunctionFieldFull, IntermediateField.adjoin_le_iff]
+    rintro x ⟨d, hd0, hdN, rfl⟩
+    exact ModularCurve.W1.w1_jqN_mem_adjoin_top_insert M p a hpM d hdN
+  · rw [IntermediateField.adjoin_le_iff]
+    rintro x (rfl | hx)
+    · exact jqd_mem_full (M * p ^ (a + 1)) (dvd_mul_left _ _)
+    · exact full_degeneracy_le (mul_dvd_mul_left M (pow_dvd_pow p (Nat.le_succ a))) hx
+
+end
+
+p2m_open "ModularCurve~coeffEmb_qExpand\
+  " in
+open _root_.P2MW.S_ModularCurve_full_eq_adjoin_full_div_prime.ModularCurve in
+theorem solution (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (a : ℕ) (hpM : ¬ p ∣ M) :
+    modularFunctionFieldFull (M * p ^ (a + 1)) = IntermediateField.adjoin ℚ (insert (jqN (p ^ (a +
+      1))) (modularFunctionFieldFull (M * p ^ a) : Set (LaurentSeries ℚ))) :=
+  ModularCurve.full_eq_adjoin_full_div_prime M p a hpM
+
+end S_ModularCurve_full_eq_adjoin_full_div_prime
+end P2MW
+export P2MW.S_ModularCurve_full_eq_adjoin_full_div_prime (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.full_eq_adjoin_full_div_prime (M : ℕ) [NeZero M] (p : ℕ)
+    [hp : Fact (Nat.Prime p)] (a : ℕ) (hpM : ¬ p ∣ M) :
+    modularFunctionFieldFull (M * p ^ (a + 1)) = IntermediateField.adjoin ℚ (insert (jqN (p ^ (a +
+      1))) (modularFunctionFieldFull (M * p ^ a) : Set (LaurentSeries ℚ))) :=
+  solution M p a hpM
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_full_eq_adjoin_primes.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_full_eq_adjoin_primes.lean
new file mode 100644
index 0000000000..1a3946b3b1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_full_eq_adjoin_primes.lean
@@ -0,0 +1,631 @@
+/-
+Based on Prove2Me node ModularCurve.full_eq_adjoin_primes
+(8842403e-a8ed-525d-bc7f-84e1e01e224e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1599ae03-e0bf-5c5e-bed5-29f4271973fb
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Polynomial_mem_range_of_unique_common_root
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_injective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# At squarefree level, divisor expansions are generated by prime ones
+
+Theorem statement: `ModularCurve.full_eq_adjoin_primes` (`8842403e-a8ed-525d-bc7f-84e1e01e224e`), by
+Claude, 2026-09-05.
+
+Proof: submission `1599ae03-e0bf-5c5e-bed5-29f4271973fb`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, nonzero as a typeclass hypothesis, and assume $N$ is squarefree. Work
+inside the field $\mathbb{Q}((q))$ of Laurent series over $\mathbb{Q}$, in which `jq` denotes the
+Laurent series $q^{-1}$ times the rational power series `jNumQ` (the $q$-expansion of the
+$j$-invariant), and in which `qExpand ℚ n` is the ring endomorphism substituting $q \mapsto q^{n}$,
+obtained by multiplying exponents by $n$; thus `jqN p` $=$ `qExpand ℚ p jq` is the expansion of
+$j(q^{p})$. The assertion is an equality of intermediate fields of $\mathbb{Q}((q))$ over
+$\mathbb{Q}$: the field `modularFunctionFieldFull N`, defined as the subfield generated over
+$\mathbb{Q}$ by all the series `qExpand ℚ d jq` for nonzero divisors $d$ of $N$, coincides with the
+subfield generated over $\mathbb{Q}$ by `jq` together with the series `jqN p` for $p$ ranging over
+the prime factors of $N$ (the nonzero condition on $p$ being automatic there).
+
+This identifies, at squarefree level, the formal $q$-expansion model of the compositum of the
+function fields of the curves $X_0(d)$, $d \mid N$, with the field generated by the prime-level
+expansions alone: $\mathbb{Q}(j(q^{d}) : d \mid N) = \mathbb{Q}(j, j(q^{p}) : p \mid N)$. It is used
+in the degree computations for the fields $\mathbb{Q}(j)(j(q^{N}))$, in particular by
+[`ModularCurve.finrank_adjoin_jqN_eq_of_squarefree`]
+(thm.html#ModularCurve.finrank_adjoin_jqN_eq_of_squarefree),
+[`ModularCurve.relfinrank_adjoin_primes`](thm.html#ModularCurve.relfinrank_adjoin_primes) and
+[`ModularCurve.relfinrank_full_mul_prime`](thm.html#ModularCurve.relfinrank_full_mul_prime), which
+together give the degree $\psi(N)$ of the modular equation of level $N$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_full_eq_adjoin_primes.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_full_eq_adjoin_primes
+
+noncomputable section
+
+p2m_open "ModularCurve~coeffEmb_qExpand P2MW.S_ModularCurve_full_eq_adjoin_primes.ModularCurve \
+  ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData modularFunctionFieldFull jqd_mem_full coeffEmb coeffEmb_coeff \
+  qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+
+
+
+
+
+
+
+
+
+
+theorem coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb K (qExpand ℚ n x) = qExpand K n (coeffEmb K x) :=
+  coeffMap_qExpand (algebraMap ℚ K) n x
+
+theorem iota_jqN (N d : ℕ) [NeZero N] [NeZero d] :
+    coeffEmb K (qExpand ℚ N (jqN d)) = TS K (N * d) 1 := by
+  rw [jqN, coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem iota_jq (N : ℕ) [NeZero N] : coeffEmb K (qExpand ℚ N jq) = TS K N 1 := by
+  rw [coeffEmb_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_zero_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    conj p ζ (0 : Fin (p + 1)) = TS K (p * p) 1 := by
+  rw [conj_zero, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_succ_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) (b : Fin p) :
+    conj p ζ b.succ = TS K 1 (ζ ^ (b : ℕ)) := by
+  rw [conj_succ, TS_eq_coeffEmb, qExpand_one_apply]
+
+theorem qTwist_iota_of_pow_eq_one (N : ℕ) [NeZero N] (v : Kˣ) (hv : v ^ N = 1) (x : LaurentSeries ℚ)
+    :
+    qTwist v (coeffEmb K (qExpand ℚ N x)) = coeffEmb K (qExpand ℚ N x) := by
+  rw [coeffEmb_qExpand, qTwist_qExpand]
+  have : v ^ (N : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData modularFunctionFieldFull jqd_mem_full coeffEmb coeffEmb_coeff \
+  qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+omit [Algebra ℚ K] in
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+omit [Algebra ℚ K] in
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+omit [Algebra ℚ K] in
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem phiProd_conj_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    phiProd p (conj p ζ) = (Polynomial.X - Polynomial.C (TS K (p * p) 1)) *
+      ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) := by
+  rw [phiProd, Fin.prod_univ_succ, conj_zero_eq]
+  congr 1
+  rw [← Fin.prod_univ_eq_prod_range (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) p]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [conj_succ_eq]
+
+theorem roots_phiProd_conj (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    (phiProd p (conj p ζ)).roots = TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^
+      b)) := by
+  classical
+  rw [phiProd_conj_eq]
+  have h1 : (Polynomial.X - Polynomial.C (TS K (p * p) 1) : Polynomial (LaurentSeries K)) ≠ 0 :=
+    Polynomial.X_sub_C_ne_zero _
+  have h2 : (∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b)))) ≠ 0 :=
+    Finset.prod_ne_zero_iff.mpr fun b _ => Polynomial.X_sub_C_ne_zero _
+  rw [Polynomial.roots_mul (mul_ne_zero h1 h2), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod,
+    Finset.range_val]
+  have hm : (Multiset.map (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) (Multiset.range
+    p)) =
+      ((Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).map (fun a => Polynomial.X - Polynomial.C
+        a) := by
+    rw [Multiset.map_map]; rfl
+  rw [hm, Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+omit [Algebra ℚ K] in
+theorem roots_phiProd_conj_nodup (p : ℕ) [hp : Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).Nodup := by
+  refine Multiset.nodup_cons.mpr ⟨?_, ?_⟩
+  · intro hmem
+    obtain ⟨b, -, hb⟩ := Multiset.mem_map.mp hmem
+    have := (TS_injective hb).1
+    have h2 := hp.out.two_le
+    nlinarith
+  · refine (Multiset.nodup_range p).map_on fun b hb b' hb' hbb' => ?_
+    rw [Multiset.mem_range] at hb hb'
+    have hu := (TS_injective hbb').2
+    have hζu : IsPrimitiveRoot ζ p := IsPrimitiveRoot.coe_units_iff.mp hζ
+    exact hζu.pow_inj hb hb' hu
+
+theorem exists_isPrimitiveRoot_cyclotomicField (N : ℕ) [NeZero N] :
+    ∃ z : CyclotomicField N ℚ, IsPrimitiveRoot z N := by
+  have : NeZero ((N : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr (NeZero.ne N)⟩
+  have : IsCyclotomicExtension {N} ℚ (CyclotomicField N ℚ) :=
+    CyclotomicField.isCyclotomicExtension N ℚ
+  exact IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField N ℚ) (Set.mem_singleton N)
+    (NeZero.ne N)
+
+def cycUnit (N : ℕ) [NeZero N] : (CyclotomicField N ℚ)ˣ :=
+  ((exists_isPrimitiveRoot_cyclotomicField N).choose_spec.isUnit (NeZero.ne N)).unit
+
+theorem cycUnit_spec (N : ℕ) [NeZero N] :
+    IsPrimitiveRoot ((cycUnit N : (CyclotomicField N ℚ)ˣ) : CyclotomicField N ℚ) N := by
+  rw [cycUnit, IsUnit.unit_spec]
+  exact (exists_isPrimitiveRoot_cyclotomicField N).choose_spec
+
+theorem cycUnit_pow (N : ℕ) [NeZero N] : cycUnit N ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, (cycUnit_spec N).pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData modularFunctionFieldFull jqd_mem_full coeffEmb coeffEmb_coeff \
+  qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData modularFunctionFieldFull jqd_mem_full coeffEmb coeffEmb_coeff \
+  qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem prod_form_ne_zero (N : ℕ) (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e]
+    (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K
+            jq)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+          (Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u,
+    Polynomial.roots_mul (prod_form_ne_zero N ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p)))
+    (coeffEmb K jq))))
+        = ((Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+        (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+        (Multiset.range p).map
+          (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).Nodup := by
+  have hζp : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := isPrimitiveRoot_pow_div hζ hpN
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h := (TS_injective (K := K) (e := e) (e' := p * (p * e))
+      (u := u * ζ ^ (b * (N / p))) (u' := u ^ (p * p))
+      (by simpa only [TS_eq_coeffEmb] using heq)).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e)
+      (u := u * ζ ^ (b * (N / p))) (u' := u * ζ ^ (b' * (N / p)))
+      (by simpa only [TS_eq_coeffEmb] using heq)).2
+    have h2 : ζ ^ (b * (N / p)) = ζ ^ (b' * (N / p)) := mul_left_cancel h
+    have h3 : (ζ ^ (N / p)) ^ b = (ζ ^ (N / p)) ^ b' := by
+      rw [← pow_mul, ← pow_mul, Nat.mul_comm (N / p) b, Nat.mul_comm (N / p) b']
+      exact h2
+    have h4 : ((ζ ^ (N / p) : Kˣ) : K) ^ b = ((ζ ^ (N / p) : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h3]
+    exact hζp.pow_inj hb hb' h4
+
+theorem roots_prime_at_slot_roots_nodup (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots.Nodup := by
+  rw [roots_prime_at_slot N ζ hζ p hpN data e u]
+  exact roots_prime_at_slot_nodup N ζ hζ p hpN e u
+
+theorem isRoot_prime_at_slot_iff (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u]
+    exact prod_form_ne_zero N ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot N ζ hζ p hpN data e u,
+    Multiset.mem_cons, Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData modularFunctionFieldFull jqd_mem_full coeffEmb coeffEmb_coeff \
+  qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+
+
+
+
+theorem phiAtSeed_jq_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) :
+    (phiAtSeed data jq).eval (jqN n) = 0 := by
+  have h := data.eval_eq_zero
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp [evalAtJ_X]
+
+
+theorem phiAtSeed_jqN_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN M)).eval (jqN (M * n)) = 0 := by
+  have h := phiAtSeed_eval_map data jq (jqN n) (qExpand ℚ M) (phiAtSeed_jq_eval n data)
+  rwa [jqN, qExpand_qExpand] at h
+
+theorem phiAtSeed_iota_eval {K : Type*} [Field K] [Algebra ℚ K] (A : ℕ) [NeZero A] (n : ℕ)
+    [NeZero n]
+    (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (coeffEmb K (qExpand ℚ A (jqN M)))).eval (coeffEmb K (qExpand ℚ A (jqN (M *
+      n)))) = 0 :=
+  phiAtSeed_eval_map data _ _ ((coeffEmb K).comp (qExpand ℚ A)) (phiAtSeed_jqN_eval n data M)
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData modularFunctionFieldFull jqd_mem_full coeffEmb coeffEmb_coeff \
+  qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+private theorem jqN_mem_of_div_primes {K : Type*} [Field K] [Algebra ℚ K]
+    {N : ℕ} [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    {F : IntermediateField ℚ (LaurentSeries ℚ)}
+    {d : ℕ} [NeZero d] (hdN : d ∣ N)
+    {p q : ℕ} (pp : Nat.Prime p) (qq : Nat.Prime q) (hpq : p ≠ q)
+    (hpd : p ∣ d) (hqd : q ∣ d) [NeZero (d / p)] [NeZero (d / q)]
+    (hmp : jqN (d / p) ∈ F) (hmq : jqN (d / q) ∈ F) :
+    jqN d ∈ F := by
+  have : Fact (Nat.Prime p) := ⟨pp⟩
+  have : Fact (Nat.Prime q) := ⟨qq⟩
+  have : NeZero p := ⟨pp.ne_zero⟩
+  have : NeZero q := ⟨qq.ne_zero⟩
+  have hpN : p ∣ N := hpd.trans hdN
+  have hqN : q ∣ N := hqd.trans hdN
+  have hNp0 : N / p ≠ 0 := fun h0 => NeZero.ne N (by rw [← Nat.div_mul_cancel hpN, h0, zero_mul])
+  have hNq0 : N / q ≠ 0 := fun h0 => NeZero.ne N (by rw [← Nat.div_mul_cancel hqN, h0, zero_mul])
+  have : NeZero (N / p) := ⟨hNp0⟩
+  have : NeZero (N / q) := ⟨hNq0⟩
+  have hpe : p * (N / p * (d / p)) = N * (d / p) := by
+    rw [← mul_assoc, Nat.mul_div_cancel' hpN]
+  have hqe : q * (N / q * (d / q)) = N * (d / q) := by
+    rw [← mul_assoc, Nat.mul_div_cancel' hqN]
+  have hpe2 : p * (p * (N / p * (d / p))) = N * d := by
+    rw [hpe, mul_left_comm, Nat.mul_div_cancel' hpd]
+  have hqe2 : q * (q * (N / q * (d / q))) = N * d := by
+    rw [hqe, mul_left_comm, Nat.mul_div_cancel' hqd]
+  have data_p : ModularPolynomialData p := (ModularCurve.exists_phiIrreducible_evalSymm p).choose
+  have data_q : ModularPolynomialData q := (ModularCurve.exists_phiIrreducible_evalSymm q).choose
+  let : Algebra F (LaurentSeries K) :=
+    (((coeffEmb K).comp (qExpand ℚ N)).comp (algebraMap F (LaurentSeries ℚ))).toAlgebra
+  have hmapA : (phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)).map (algebraMap F (LaurentSeries K))
+      = phiAtSeed data_p (coeffEmb K (qExpand ℚ N (jqN (d / p)))) :=
+    phiAtSeed_map data_p _ _
+  have hmapB : (phiAtSeed data_q (⟨jqN (d / q), hmq⟩ : F)).map (algebraMap F (LaurentSeries K))
+      = phiAtSeed data_q (coeffEmb K (qExpand ℚ N (jqN (d / q)))) :=
+    phiAtSeed_map data_q _ _
+  have hseed_p : coeffEmb K (qExpand ℚ N (jqN (d / p)))
+      = qExpand K (p * (N / p * (d / p))) (qTwist ((1 : Kˣ) ^ p) (coeffEmb K jq)) := by
+    have h2 : TS K (N * (d / p)) 1 = TS K (p * (N / p * (d / p))) ((1 : Kˣ) ^ p) := by
+      rw [one_pow]
+      exact TS_congr hpe.symm 1
+    simpa only [TS_eq_coeffEmb] using (iota_jqN N (d / p)).trans h2
+  have hseed_q : coeffEmb K (qExpand ℚ N (jqN (d / q)))
+      = qExpand K (q * (N / q * (d / q))) (qTwist ((1 : Kˣ) ^ q) (coeffEmb K jq)) := by
+    have h2 : TS K (N * (d / q)) 1 = TS K (q * (N / q * (d / q))) ((1 : Kˣ) ^ q) := by
+      rw [one_pow]
+      exact TS_congr hqe.symm 1
+    simpa only [TS_eq_coeffEmb] using (iota_jqN N (d / q)).trans h2
+  have hdist_p : coeffEmb K (qExpand ℚ N (jqN d))
+      = qExpand K (p * (p * (N / p * (d / p)))) (qTwist ((1 : Kˣ) ^ (p * p)) (coeffEmb K jq)) := by
+    have h2 : TS K (N * d) 1 = TS K (p * (p * (N / p * (d / p)))) ((1 : Kˣ) ^ (p * p)) := by
+      rw [one_pow]
+      exact TS_congr hpe2.symm 1
+    simpa only [TS_eq_coeffEmb] using (iota_jqN N d).trans h2
+  have hdist_q : coeffEmb K (qExpand ℚ N (jqN d))
+      = qExpand K (q * (q * (N / q * (d / q)))) (qTwist ((1 : Kˣ) ^ (q * q)) (coeffEmb K jq)) := by
+    have h2 : TS K (N * d) 1 = TS K (q * (q * (N / q * (d / q)))) ((1 : Kˣ) ^ (q * q)) := by
+      rw [one_pow]
+      exact TS_congr hqe2.symm 1
+    simpa only [TS_eq_coeffEmb] using (iota_jqN N d).trans h2
+  have hrootA : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)) = 0 ↔
+        (y = qExpand K (p * (p * (N / p * (d / p)))) (qTwist ((1 : Kˣ) ^ (p * p)) (coeffEmb K jq)) ∨
+          ∃ b < p, y = qExpand K (N / p * (d / p)) (qTwist (1 * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+            := by
+    intro y
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hmapA, hseed_p]
+    exact isRoot_prime_at_slot_iff N ζ hζ p hpN data_p (N / p * (d / p)) 1 y
+  have hrootB : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_q (⟨jqN (d / q), hmq⟩ : F)) = 0 ↔
+        (y = qExpand K (q * (q * (N / q * (d / q)))) (qTwist ((1 : Kˣ) ^ (q * q)) (coeffEmb K jq)) ∨
+          ∃ c < q, y = qExpand K (N / q * (d / q)) (qTwist (1 * ζ ^ (c * (N / q))) (coeffEmb K jq)))
+            := by
+    intro y
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hmapB, hseed_q]
+    exact isRoot_prime_at_slot_iff N ζ hζ q hqN data_q (N / q * (d / q)) 1 y
+  have hA0 : phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F) ≠ 0 := (phiAtSeed_monic data_p _).ne_zero
+  have hAs : ((phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)).map
+      (algebraMap F (LaurentSeries K))).Splits := by
+    rw [hmapA, hseed_p, phiAtSeed,
+      ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data_p (N / p * (d / p)) 1]
+    exact (Polynomial.Splits.X_sub_C _).mul
+      (Polynomial.Splits.prod fun b _ => Polynomial.Splits.X_sub_C _)
+  have hAnd : ((phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)).map
+      (algebraMap F (LaurentSeries K))).roots.Nodup := by
+    rw [hmapA, hseed_p, phiAtSeed]
+    exact roots_prime_at_slot_roots_nodup N ζ hζ p hpN data_p (N / p * (d / p)) 1
+  have hxA : Polynomial.aeval (coeffEmb K (qExpand ℚ N (jqN d)))
+      (phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)) = 0 :=
+    (hrootA _).mpr (Or.inl hdist_p)
+  have hxB : Polynomial.aeval (coeffEmb K (qExpand ℚ N (jqN d)))
+      (phiAtSeed data_q (⟨jqN (d / q), hmq⟩ : F)) = 0 :=
+    (hrootB _).mpr (Or.inl hdist_q)
+  have huniq : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)) = 0 →
+      Polynomial.aeval y (phiAtSeed data_q (⟨jqN (d / q), hmq⟩ : F)) = 0 →
+      y = coeffEmb K (qExpand ℚ N (jqN d)) := by
+    intro y hyA hyB
+    rcases (hrootA y).mp hyA with hy1 | ⟨b, hb, hy1⟩
+    · exact hy1.trans hdist_p.symm
+    · rcases (hrootB y).mp hyB with hy2 | ⟨c, hc, hy2⟩
+      · exact hy2.trans hdist_q.symm
+      · exfalso
+        have hTS : TS K (N / p * (d / p)) (1 * ζ ^ (b * (N / p)))
+            = TS K (N / q * (d / q)) (1 * ζ ^ (c * (N / q))) := by
+              simpa only [TS_eq_coeffEmb] using hy1.symm.trans hy2
+        have he : N / p * (d / p) = N / q * (d / q) := (TS_injective hTS).1
+        have h1 : p * p * (N / p * (d / p)) = q * q * (N / p * (d / p)) := by
+          rw [mul_assoc, hpe2, mul_assoc, he, hqe2]
+        have h2 : p * p = q * q :=
+          Nat.eq_of_mul_eq_mul_right (Nat.pos_of_ne_zero (NeZero.ne (N / p * (d / p)))) h1
+        have h3 : q ∣ p * p := by rw [h2]; exact dvd_mul_right q q
+        have h4 : q ∣ p := ((Nat.Prime.dvd_mul qq).mp h3).elim id id
+        exact hpq (((Nat.prime_dvd_prime_iff_eq qq pp).mp h4).symm)
+  have hrange := Polynomial.mem_range_of_unique_common_root
+    (phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)) (phiAtSeed data_q (⟨jqN (d / q), hmq⟩ : F))
+    hA0 hAs hAnd (coeffEmb K (qExpand ℚ N (jqN d))) hxA hxB huniq
+  obtain ⟨f, hf⟩ := RingHom.mem_range.mp hrange
+  have hf' : coeffEmb K (qExpand ℚ N ((f : LaurentSeries ℚ)))
+      = coeffEmb K (qExpand ℚ N (jqN d)) := hf
+  have hemb : Function.Injective (coeffEmb K) :=
+    ModularCurve.coeffMap_injective ((algebraMap ℚ K).injective)
+  have hval : (f : LaurentSeries ℚ) = jqN d := qExpand_injective N (hemb hf')
+  rw [← hval]
+  exact f.2
+
+private theorem w1_jqN_mem_adjoin_primeFactors (N : ℕ) [NeZero N] (hN : Squarefree N) :
+    ∀ (d : ℕ) [NeZero d], d ∣ N →
+      jqN d ∈ IntermediateField.adjoin ℚ
+        (insert jq {x : LaurentSeries ℚ | ∃ p ∈ N.primeFactors, ∃ _ : NeZero p, x = jqN p}) := by
+  intro d
+  induction d using Nat.strong_induction_on with
+  | _ d ih =>
+    intro hd0 hdN
+    have hd0' : d ≠ 0 := hd0.out
+    rcases eq_or_ne d 1 with rfl | hd1
+    · rw [jqN_one]
+      exact IntermediateField.subset_adjoin ℚ _ (Set.mem_insert _ _)
+    · by_cases hdprime : Nat.Prime d
+      · exact IntermediateField.subset_adjoin ℚ _ (Set.mem_insert_of_mem _
+          ⟨d, Nat.mem_primeFactors.mpr ⟨hdprime, hdN, NeZero.ne N⟩, hd0, rfl⟩)
+      · obtain ⟨p, pp, hpd⟩ := Nat.exists_prime_and_dvd hd1
+        have hdp0 : d / p ≠ 0 := fun h0 => hd0' (by rw [← Nat.div_mul_cancel hpd, h0, zero_mul])
+        have hdp1 : d / p ≠ 1 := by
+          intro h1
+          apply hdprime
+          have h := Nat.div_mul_cancel hpd
+          rw [h1, one_mul] at h
+          rwa [← h]
+        obtain ⟨q, qq, hqdp⟩ := Nat.exists_prime_and_dvd hdp1
+        have hqd : q ∣ d := hqdp.trans (Nat.div_dvd_of_dvd hpd)
+        have hdq0 : d / q ≠ 0 := fun h0 => hd0' (by rw [← Nat.div_mul_cancel hqd, h0, zero_mul])
+        have hpq : p ≠ q := by
+          rintro rfl
+          have hsq : Squarefree d := hN.squarefree_of_dvd hdN
+          have hpp_dvd : p * p ∣ d := by
+            have h2 : p * p ∣ p * (d / p) := mul_dvd_mul_left p hqdp
+            rwa [Nat.mul_div_cancel' hpd] at h2
+          exact pp.ne_one (Nat.isUnit_iff.mp (hsq p hpp_dvd))
+        have : NeZero (d / p) := ⟨hdp0⟩
+        have : NeZero (d / q) := ⟨hdq0⟩
+        have hmem_p := ih (d / p) (Nat.div_lt_self (Nat.pos_of_ne_zero hd0') pp.one_lt)
+          ((Nat.div_dvd_of_dvd hpd).trans hdN)
+        have hmem_q := ih (d / q) (Nat.div_lt_self (Nat.pos_of_ne_zero hd0') qq.one_lt)
+          ((Nat.div_dvd_of_dvd hqd).trans hdN)
+        exact jqN_mem_of_div_primes (cycUnit N) (cycUnit_spec N) hdN pp qq hpq hpd hqd
+          hmem_p hmem_q
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData modularFunctionFieldFull jqd_mem_full coeffEmb coeffEmb_coeff \
+  qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot coeffMap_injective exists_phiIrreducible_evalSymm"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.full_eq_adjoin_primes (N : ℕ) [NeZero N] (hN : Squarefree N) :
+    modularFunctionFieldFull N = IntermediateField.adjoin ℚ (insert jq {x : LaurentSeries ℚ | ∃ p ∈
+      N.primeFactors, ∃ _ : NeZero p, x = jqN p}) := by
+  refine le_antisymm ?_ ?_
+  · rw [modularFunctionFieldFull, IntermediateField.adjoin_le_iff]
+    rintro x ⟨d, hne, hdvd, rfl⟩
+    exact ModularCurve.W1.w1_jqN_mem_adjoin_primeFactors N hN d hdvd
+  · rw [IntermediateField.adjoin_le_iff]
+    rintro x (rfl | ⟨p, hpm, hne, rfl⟩)
+    · have h := jqd_mem_full N (one_dvd N)
+      rwa [qExpand_one_apply] at h
+    · exact jqd_mem_full N (Nat.dvd_of_mem_primeFactors hpm)
+
+end
+
+p2m_open "ModularCurve~coeffEmb_qExpand\
+  " in
+open _root_.P2MW.S_ModularCurve_full_eq_adjoin_primes.ModularCurve in
+theorem solution (N : ℕ) [NeZero N] (hN : Squarefree N) :
+    modularFunctionFieldFull N = IntermediateField.adjoin ℚ (insert jq {x : LaurentSeries ℚ | ∃ p ∈
+      N.primeFactors, ∃ _ : NeZero p, x = jqN p}) :=
+  ModularCurve.full_eq_adjoin_primes N hN
+
+end S_ModularCurve_full_eq_adjoin_primes
+end P2MW
+export P2MW.S_ModularCurve_full_eq_adjoin_primes (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.full_eq_adjoin_primes (N : ℕ) [NeZero N] (hN : Squarefree N) :
+    modularFunctionFieldFull N = IntermediateField.adjoin ℚ (insert jq {x : LaurentSeries ℚ | ∃ p ∈
+      N.primeFactors, ∃ _ : NeZero p, x = jqN p}) :=
+  solution N hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_full_eq_of_prime.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_full_eq_of_prime.lean
new file mode 100644
index 0000000000..10f1840f50
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_full_eq_of_prime.lean
@@ -0,0 +1,86 @@
+/-
+Based on Prove2Me node ModularCurve.full_eq_of_prime
+(31fa1d0a-3ebe-5b18-9f60-eed47b096057) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9007ec45-94a4-5fac-9485-85a3184b90ba
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration_iff_full_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration_of_prime
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# At prime level the two modular function fields agree
+
+Theorem statement: `ModularCurve.full_eq_of_prime` (`31fa1d0a-3ebe-5b18-9f60-eed47b096057`), by
+Claude, 2026-09-05.
+
+Proof: submission `9007ec45-94a4-5fac-9485-85a3184b90ba`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a natural number, nonzero, and assume $\ell$ is prime. Two intermediate fields of
+$\mathbb{Q}$ inside the field of Laurent series $\mathrm{LaurentSeries}\,\mathbb{Q}$ are compared.
+Here `qExpand ℚ N` denotes the ring endomorphism of Laurent series obtained by transporting along
+multiplication by $N$ on the exponent group $\mathbb{Z}$, that is, the substitution $q \mapsto
+q^{N}$, and `jq` is the Laurent series serving as the $q$-expansion of $j$. The field
+`modularFunctionFieldFull ℓ` is the subfield of $\mathrm{LaurentSeries}\,\mathbb{Q}$ generated over
+$\mathbb{Q}$ by the set `divisorExpansions ℓ` of all series `qExpand ℚ d jq` with $d$ a nonzero
+natural number dividing $\ell$, while `modularFunctionField ℓ` is the subfield generated over
+$\mathbb{Q}$ by the two elements `jq` and `qExpand ℚ ℓ jq`. The theorem asserts that for prime
+$\ell$ these two intermediate fields are equal: adjoining the $q$-expansions $j(q^{d})$ for all
+divisors $d$ of $\ell$ yields nothing beyond $\mathbb{Q}(j(q), j(q^{\ell}))$.
+
+This identifies, at prime level, the "all divisors" presentation of the function field attached to
+$X_0(\ell)$ with the two-generator presentation $\mathbb{Q}(j(q), j(q^{\ell}))$, so that results
+stated for the two-generator field may be applied to the full field. It is used throughout the
+algebraic development of $X_0(\ell)$ in this project, for instance in the analysis of the cuspidal
+classes and of the Fricke involution.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_full_eq_of_prime.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_full_eq_of_prime
+
+open ModularCurve IntermediateField
+
+noncomputable section
+
+theorem solution {ℓ : ℕ} [NeZero ℓ] (hℓ : ℓ.Prime) :
+    modularFunctionFieldFull ℓ = modularFunctionField ℓ :=
+  (ModularCurve.functionFieldGeneration_iff_full_eq ℓ).mp
+    (ModularCurve.functionFieldGeneration_of_prime hℓ)
+
+end
+
+end S_ModularCurve_full_eq_of_prime
+end P2MW
+export P2MW.S_ModularCurve_full_eq_of_prime (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve IntermediateField
+theorem ModularCurve.full_eq_of_prime {ℓ : ℕ} [NeZero ℓ] (hℓ : ℓ.Prime) :
+    modularFunctionFieldFull ℓ = modularFunctionField ℓ :=
+  solution hℓ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_functionFieldGeneration.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_functionFieldGeneration.lean
new file mode 100644
index 0000000000..3392eb4f79
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_functionFieldGeneration.lean
@@ -0,0 +1,811 @@
+/-
+Based on Prove2Me node ModularCurve.functionFieldGeneration
+(02270e4f-19ed-5999-a205-8c9846a63f39) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c5150d0c-9f33-5f71-a2c2-876f889509b7
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_minpoly_jqN_map_eq_prod_slots
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqN_prime_not_mem_full
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqN_pow_not_mem_adjoin_full
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_full_eq_adjoin_full_div_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_eq_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqN_div_mem_modularFunctionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularFunctionField_eq_full_of
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_modularFunctionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_mul_of_coprime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime_pow
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_of_finrank_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration_iff_full_eq
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.FieldTheory.Relrank
+import Mathlib.Data.Nat.Factorization.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Generation of j(qᵈ) by j(q) and j(q^N)
+
+Theorem statement: `ModularCurve.functionFieldGeneration` (`02270e4f-19ed-5999-a205-8c9846a63f39`),
+by Claude, 2026-09-05.
+
+Proof: submission `c5150d0c-9f33-5f71-a2c2-876f889509b7`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, assumed nonzero (as a `NeZero` instance). The assertion is the
+predicate `FunctionFieldGeneration N`, which unfolds as follows. For a nonzero natural $n$, `qExpand
+R n` denotes the ring endomorphism of the Laurent series field `LaurentSeries R` obtained by
+multiplying all exponents by $n$ — that is, the substitution $q \mapsto q^{n}$, which is well
+defined because multiplication by $n$ on $\mathbb{Z}$ is injective and order preserving. Writing
+`jq` for the element of `LaurentSeries ℚ` given by the $q$-expansion of the modular $j$-invariant,
+the theorem states: for every natural number $d$ dividing $N$, and for every `NeZero d` instance,
+the series `qExpand ℚ d jq`, i.e. $j(q^{d})$, belongs to the intermediate field
+`IntermediateField.adjoin ℚ {jq, qExpand ℚ N jq}`, the subfield of `LaurentSeries ℚ` generated over
+$\mathbb{Q}$ by $j(q)$ and $j(q^{N})$. No further hypotheses are imposed: the conclusion holds
+unconditionally at every level $N \ge 1$.
+
+This is the $q$-expansion form of the classical statement that the function field of $X_0(N)$ over
+$\mathbb{Q}$ is $\mathbb{Q}(j, j_N)$, so that the intermediate levels $j(q^d)$ for $d \mid N$
+require no extra generators. It discharges the generation hypothesis used throughout the development
+of the level-$N$ function field — degeneracy maps between levels, the Hecke correspondence, and the
+characteristic-$p$ models of the modular curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_functionFieldGeneration.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_functionFieldGeneration
+
+noncomputable section
+
+p2m_open "ModularCurve~coeffEmb_qExpand P2MW.S_ModularCurve_functionFieldGeneration.ModularCurve \
+  ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+
+
+
+
+
+
+
+
+
+
+theorem coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb K (qExpand ℚ n x) = qExpand K n (coeffEmb K x) :=
+  coeffMap_qExpand (algebraMap ℚ K) n x
+
+theorem iota_jqN (N d : ℕ) [NeZero N] [NeZero d] :
+    coeffEmb K (qExpand ℚ N (jqN d)) = TS K (N * d) 1 := by
+  rw [jqN, coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem iota_jq (N : ℕ) [NeZero N] : coeffEmb K (qExpand ℚ N jq) = TS K N 1 := by
+  rw [coeffEmb_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_zero_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    conj p ζ (0 : Fin (p + 1)) = TS K (p * p) 1 := by
+  rw [conj_zero, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_succ_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) (b : Fin p) :
+    conj p ζ b.succ = TS K 1 (ζ ^ (b : ℕ)) := by
+  rw [conj_succ, TS_eq_coeffEmb, qExpand_one_apply]
+
+theorem qTwist_iota_of_pow_eq_one (N : ℕ) [NeZero N] (v : Kˣ) (hv : v ^ N = 1) (x : LaurentSeries ℚ)
+    :
+    qTwist v (coeffEmb K (qExpand ℚ N x)) = coeffEmb K (qExpand ℚ N x) := by
+  rw [coeffEmb_qExpand, qTwist_qExpand]
+  have : v ^ (N : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+omit [Algebra ℚ K] in
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+omit [Algebra ℚ K] in
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+omit [Algebra ℚ K] in
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem phiProd_conj_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    phiProd p (conj p ζ) = (Polynomial.X - Polynomial.C (TS K (p * p) 1)) *
+      ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) := by
+  rw [phiProd, Fin.prod_univ_succ, conj_zero_eq]
+  congr 1
+  rw [← Fin.prod_univ_eq_prod_range (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) p]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [conj_succ_eq]
+
+theorem roots_phiProd_conj (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    (phiProd p (conj p ζ)).roots = TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^
+      b)) := by
+  classical
+  rw [phiProd_conj_eq]
+  have h1 : (Polynomial.X - Polynomial.C (TS K (p * p) 1) : Polynomial (LaurentSeries K)) ≠ 0 :=
+    Polynomial.X_sub_C_ne_zero _
+  have h2 : (∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b)))) ≠ 0 :=
+    Finset.prod_ne_zero_iff.mpr fun b _ => Polynomial.X_sub_C_ne_zero _
+  rw [Polynomial.roots_mul (mul_ne_zero h1 h2), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod,
+    Finset.range_val]
+  have hm : (Multiset.map (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) (Multiset.range
+    p)) =
+      ((Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).map (fun a => Polynomial.X - Polynomial.C
+        a) := by
+    rw [Multiset.map_map]; rfl
+  rw [hm, Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+omit [Algebra ℚ K] in
+theorem roots_phiProd_conj_nodup (p : ℕ) [hp : Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).Nodup := by
+  refine Multiset.nodup_cons.mpr ⟨?_, ?_⟩
+  · intro hmem
+    obtain ⟨b, -, hb⟩ := Multiset.mem_map.mp hmem
+    have := (TS_injective hb).1
+    have h2 := hp.out.two_le
+    nlinarith
+  · refine (Multiset.nodup_range p).map_on fun b hb b' hb' hbb' => ?_
+    rw [Multiset.mem_range] at hb hb'
+    have hu := (TS_injective hbb').2
+    have hζu : IsPrimitiveRoot ζ p := IsPrimitiveRoot.coe_units_iff.mp hζ
+    exact hζu.pow_inj hb hb' hu
+
+theorem exists_isPrimitiveRoot_cyclotomicField (N : ℕ) [NeZero N] :
+    ∃ z : CyclotomicField N ℚ, IsPrimitiveRoot z N := by
+  have : NeZero ((N : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr (NeZero.ne N)⟩
+  have : IsCyclotomicExtension {N} ℚ (CyclotomicField N ℚ) :=
+    CyclotomicField.isCyclotomicExtension N ℚ
+  exact IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField N ℚ) (Set.mem_singleton N)
+    (NeZero.ne N)
+
+def cycUnit (N : ℕ) [NeZero N] : (CyclotomicField N ℚ)ˣ :=
+  ((exists_isPrimitiveRoot_cyclotomicField N).choose_spec.isUnit (NeZero.ne N)).unit
+
+theorem cycUnit_spec (N : ℕ) [NeZero N] :
+    IsPrimitiveRoot ((cycUnit N : (CyclotomicField N ℚ)ˣ) : CyclotomicField N ℚ) N := by
+  rw [cycUnit, IsUnit.unit_spec]
+  exact (exists_isPrimitiveRoot_cyclotomicField N).choose_spec
+
+theorem cycUnit_pow (N : ℕ) [NeZero N] : cycUnit N ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, (cycUnit_spec N).pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem prod_form_ne_zero (N : ℕ) (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e]
+    (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K
+            jq)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+          (Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u,
+    Polynomial.roots_mul (prod_form_ne_zero N ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p)))
+    (coeffEmb K jq))))
+        = ((Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+        (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+        (Multiset.range p).map
+          (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).Nodup := by
+  have hζp : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := isPrimitiveRoot_pow_div hζ hpN
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h := (TS_injective (K := K) (e := e) (e' := p * (p * e))
+      (u := u * ζ ^ (b * (N / p))) (u' := u ^ (p * p))
+      (by simpa only [TS_eq_coeffEmb] using heq)).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e)
+      (u := u * ζ ^ (b * (N / p))) (u' := u * ζ ^ (b' * (N / p)))
+      (by simpa only [TS_eq_coeffEmb] using heq)).2
+    have h2 : ζ ^ (b * (N / p)) = ζ ^ (b' * (N / p)) := mul_left_cancel h
+    have h3 : (ζ ^ (N / p)) ^ b = (ζ ^ (N / p)) ^ b' := by
+      rw [← pow_mul, ← pow_mul, Nat.mul_comm (N / p) b, Nat.mul_comm (N / p) b']
+      exact h2
+    have h4 : ((ζ ^ (N / p) : Kˣ) : K) ^ b = ((ζ ^ (N / p) : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h3]
+    exact hζp.pow_inj hb hb' h4
+
+theorem roots_prime_at_slot_roots_nodup (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots.Nodup := by
+  rw [roots_prime_at_slot N ζ hζ p hpN data e u]
+  exact roots_prime_at_slot_nodup N ζ hζ p hpN e u
+
+theorem isRoot_prime_at_slot_iff (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u]
+    exact prod_form_ne_zero N ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot N ζ hζ p hpN data e u,
+    Multiset.mem_cons, Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+
+
+
+
+theorem phiAtSeed_jq_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) :
+    (phiAtSeed data jq).eval (jqN n) = 0 := by
+  have h := data.eval_eq_zero
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' ?_ ?_
+  · exact RingHom.ext_int _ _
+  · simp [evalAtJ_X]
+
+
+theorem phiAtSeed_jqN_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN M)).eval (jqN (M * n)) = 0 := by
+  have h := phiAtSeed_eval_map data jq (jqN n) (qExpand ℚ M) (phiAtSeed_jq_eval n data)
+  rwa [jqN, qExpand_qExpand] at h
+
+theorem phiAtSeed_iota_eval {K : Type*} [Field K] [Algebra ℚ K] (A : ℕ) [NeZero A] (n : ℕ)
+    [NeZero n]
+    (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (coeffEmb K (qExpand ℚ A (jqN M)))).eval (coeffEmb K (qExpand ℚ A (jqN (M *
+      n)))) = 0 :=
+  phiAtSeed_eval_map data _ _ ((coeffEmb K).comp (qExpand ℚ A)) (phiAtSeed_jqN_eval n data M)
+
+end ModularCurve.W1
+
+open scoped IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+section Final
+
+private abbrev Tight (d : ℕ) [NeZero d] : Prop :=
+  Module.finrank ℚ⟮jq⟯ (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN d} : Set (LaurentSeries ℚ))) =
+    dedekindPsi d
+
+private abbrev Gen (d : ℕ) [NeZero d] : Prop := modularFunctionField d = modularFunctionFieldFull d
+
+private abbrev Hall (N : ℕ) : Prop := ∀ d : ℕ, d ∣ N → ∀ [NeZero d], Tight d ∧ Gen d
+
+private theorem jqN_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) : jqN n = jqN m := by
+  subst h; rfl
+
+private theorem full_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) :
+    modularFunctionFieldFull n = modularFunctionFieldFull m := by
+  subst h; rfl
+
+private theorem mff_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) :
+    modularFunctionField n = modularFunctionField m := by
+  subst h; rfl
+
+private theorem qExpand_congr' {R : Type*} [CommRing R] {n m : ℕ} [NeZero n] [NeZero m]
+    (h : n = m) (x : LaurentSeries R) : qExpand R n x = qExpand R m x := by
+  subst h
+  rfl
+
+private theorem dedekindPsi_prime' (p : ℕ) (hp : p.Prime) : dedekindPsi p = p + 1 := by
+  have h := ModularCurve.dedekindPsi_prime_pow p 1 hp one_ne_zero
+  rwa [pow_one, Nat.sub_self, pow_zero] at h
+
+private theorem dedekindPsi_mul_prime_not_dvd {m p : ℕ} (hp : p.Prime) (hpm : ¬ p ∣ m) :
+    dedekindPsi (m * p) = dedekindPsi m * (p + 1) := by
+  have hco : Nat.Coprime m p := ((Nat.Prime.coprime_iff_not_dvd hp).mpr hpm).symm
+  rw [ModularCurve.dedekindPsi_mul_of_coprime m p hco, dedekindPsi_prime' p hp]
+
+private theorem dedekindPsi_mul_prime_dvd {m p : ℕ} (hm : m ≠ 0) (hp : p.Prime)
+    (hpm : p ∣ m) : dedekindPsi (m * p) = dedekindPsi m * p := by
+  obtain ⟨k, u, hpu, hmu⟩ := Nat.exists_eq_pow_mul_and_not_dvd hm p hp.ne_one
+  obtain ⟨k', rfl⟩ : ∃ k', k = k' + 1 := by
+    rcases k with - | k'
+    · exfalso
+      rw [hmu, pow_zero, one_mul] at hpm
+      exact hpu hpm
+    · exact ⟨k', rfl⟩
+  subst hmu
+  have hcou : ∀ j : ℕ, j ≠ 0 → Nat.Coprime (p ^ j) u :=
+    fun j _ => Nat.Coprime.pow_left j ((Nat.Prime.coprime_iff_not_dvd hp).mpr hpu)
+  have h1 : p ^ (k' + 1) * u * p = p ^ (k' + 2) * u := by ring
+  rw [h1, ModularCurve.dedekindPsi_mul_of_coprime _ u (hcou _ (Nat.succ_ne_zero _)),
+    ModularCurve.dedekindPsi_mul_of_coprime _ u (hcou _ (Nat.succ_ne_zero _)),
+    ModularCurve.dedekindPsi_prime_pow p (k' + 2) hp (Nat.succ_ne_zero _),
+    ModularCurve.dedekindPsi_prime_pow p (k' + 1) hp (Nat.succ_ne_zero _)]
+  have h2 : k' + 2 - 1 = k' + 1 := rfl
+  have h3 : k' + 1 - 1 = k' := rfl
+  rw [h2, h3]
+  ring
+
+private theorem tight_one : Tight 1 := by
+  unfold Tight
+  have h1 : jqN 1 = jq := by rw [jqN, qExpand_one_apply]
+  rw [h1, ModularCurve.dedekindPsi_one]
+  have h2 : IntermediateField.adjoin ℚ⟮jq⟯ ({jq} : Set (LaurentSeries ℚ))
+      = (⊥ : IntermediateField ℚ⟮jq⟯ (LaurentSeries ℚ)) := by
+    rw [IntermediateField.adjoin_simple_eq_bot_iff, IntermediateField.mem_bot]
+    exact ⟨jGen, rfl⟩
+  rw [h2]
+  exact IntermediateField.finrank_bot
+
+private theorem gen_one : Gen 1 := by
+  unfold Gen
+  refine le_antisymm (modularFunctionField_le_full 1) ?_
+  rw [modularFunctionFieldFull, IntermediateField.adjoin_le_iff]
+  rintro x ⟨d, hne, hdvd, rfl⟩
+  have := hne
+  have hd1 : d = 1 := Nat.dvd_one.mp hdvd
+  subst hd1
+  rw [qExpand_one_apply]
+  exact jq_mem 1
+
+private theorem relfinrank_full_of (N : ℕ) [NeZero N] (ht : Tight N) (hg : Gen N) :
+    IntermediateField.relfinrank ℚ⟮jq⟯ (modularFunctionFieldFull N) = dedekindPsi N := by
+  unfold Gen at hg
+  unfold Tight at ht
+  rw [← hg, ModularCurve.relfinrank_modularFunctionField N, ht]
+
+private theorem F0_le_full (N : ℕ) [NeZero N] : ℚ⟮jq⟯ ≤ modularFunctionFieldFull N := by
+  rw [IntermediateField.adjoin_le_iff, Set.singleton_subset_iff]
+  have h := jqd_mem_full N (one_dvd N)
+  rw [qExpand_one_apply] at h
+  exact h
+
+private theorem full_le_adjoin_chain (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (hpM : ¬ p ∣ M) : ∀ a : ℕ,
+    modularFunctionFieldFull (M * p ^ a) ≤ IntermediateField.adjoin ℚ
+      ((modularFunctionFieldFull M : Set (LaurentSeries ℚ))
+        ∪ {x : LaurentSeries ℚ | ∃ i : ℕ, i ≤ a ∧ x = jqN (p ^ i)}) := by
+  intro a
+  induction a with
+  | zero =>
+      rw [full_congr (show M * p ^ 0 = M by rw [pow_zero, mul_one])]
+      exact fun x hx => IntermediateField.subset_adjoin ℚ _ (Set.mem_union_left _ hx)
+  | succ k ih =>
+      rw [ModularCurve.full_eq_adjoin_full_div_prime M p k hpM, IntermediateField.adjoin_le_iff,
+        Set.insert_subset_iff]
+      refine ⟨IntermediateField.subset_adjoin ℚ _ (Set.mem_union_right _
+        (show jqN (p ^ (k + 1)) ∈ {x : LaurentSeries ℚ | ∃ i : ℕ, i ≤ k + 1 ∧ x = jqN (p ^ i)} from
+          ⟨k + 1, le_rfl, rfl⟩)), ?_⟩
+      intro x hx
+      have hx' := ih hx
+      refine IntermediateField.adjoin.mono ℚ _ _ (Set.union_subset_union le_rfl ?_) hx'
+      intro y hy
+      obtain ⟨i, hi, hy⟩ := hy
+      exact ⟨i, Nat.le_succ_of_le hi, hy⟩
+
+private theorem jqN_pow_not_mem_full (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (hpM : ¬ p ∣ M) (hallM : Hall M) (a : ℕ) :
+    jqN (p ^ (a + 1)) ∉ modularFunctionFieldFull (M * p ^ a) := by
+  have h0 : jqN p ∉ modularFunctionFieldFull M :=
+    ModularCurve.jqN_prime_not_mem_full M p hpM (fun d hd _ => hallM d hd)
+  rcases a with - | k
+  · rw [jqN_congr (show p ^ (0 + 1) = p by rw [zero_add, pow_one]),
+      full_congr (show M * p ^ 0 = M by rw [pow_zero, mul_one])]
+    exact h0
+  · intro hmem
+    have h1 := ModularCurve.jqN_pow_not_mem_adjoin_full M p k h0
+    exact h1 (full_le_adjoin_chain M p hpM (k + 1) hmem)
+
+section Shapes
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem root_shape (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) M) (hallM : Hall M) (y : LaurentSeries K)
+    (hy : Polynomial.eval y ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M *
+      p))).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))) = 0) :
+    ∃ a : ℕ, ∃ _ : NeZero a, a ∣ M ∧ ∃ b : ℕ, b < M / a ∧ y = TS K (p * (a * a)) (ζ ^ (b * a)) := by
+  have hid := ModularCurve.minpoly_jqN_map_eq_prod_slots (K := K) M ζ hζ (fun d hd _ => hallM d hd)
+  have hcomp : (qExpand K p).comp (((coeffEmb K).comp (qExpand ℚ M)).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))
+      = ((coeffEmb K).comp (qExpand ℚ (M * p))).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) := by
+    refine RingHom.ext fun z => ?_
+    simp only [RingHom.comp_apply]
+    rw [coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand]
+    exact qExpand_congr' (mul_comm p M) _
+  rw [← hcomp, ← Polynomial.map_map, hid, Polynomial.eval_map, Polynomial.eval₂_finsetProd] at hy
+  obtain ⟨a, ha, hy⟩ := Finset.prod_eq_zero_iff.mp hy
+  rw [Polynomial.eval₂_finsetProd] at hy
+  obtain ⟨b, hb, hy⟩ := Finset.prod_eq_zero_iff.mp hy
+  rw [Polynomial.eval₂_sub, Polynomial.eval₂_X, Polynomial.eval₂_C, sub_eq_zero] at hy
+  have ha0 : a ≠ 0 := Nat.ne_of_gt (Nat.pos_of_mem_divisors ha)
+  rw [dite_eq_right ha0] at hy
+  have : NeZero a := ⟨ha0⟩
+  refine ⟨a, ⟨ha0⟩, Nat.dvd_of_mem_divisors ha, b, (Finset.mem_range.mp (Finset.mem_filter.mp
+    hb).1), ?_⟩
+  rw [hy]
+  rw [← TS_eq_coeffEmb, qExpand_TS]
+
+private theorem htw_of (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) M) (hallM : Hall M) (y : LaurentSeries K)
+    (hy : Polynomial.eval y ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M *
+      p))).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))) = 0)
+    (w : Kˣ) (hw : y = qExpand K (M * p * M) (qTwist w (coeffEmb K jq))) : w = 1 := by
+  obtain ⟨a, _, haM, b, hb, rfl⟩ := root_shape M p ζ hζ hallM y hy
+  rw [← TS_eq_coeffEmb] at hw
+  obtain ⟨he, hu⟩ := TS_injective hw
+  have haM' : a = M := by
+    have h2 : a * a = M * M := by
+      have hp0 : 0 < p := hp.out.pos
+      have : p * (a * a) = p * (M * M) := by rw [he]; ring
+      exact Nat.eq_of_mul_eq_mul_left hp0 this
+    exact Nat.mul_self_inj.mp h2
+  subst haM'
+  have hb0 : b = 0 := by
+    rw [Nat.div_self (Nat.pos_of_ne_zero (NeZero.ne a))] at hb
+    omega
+  subst hb0
+  rw [zero_mul, pow_zero] at hu
+  exact hu.symm
+
+private theorem hsp_of (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) M) (hallM : Hall M) (y : LaurentSeries K)
+    (hy : Polynomial.eval y ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M *
+      p))).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))) = 0) :
+    y ≠ coeffEmb K (qExpand ℚ (M * p) (jqN (M * p * p))) := by
+  obtain ⟨a, _, haM, b, _, rfl⟩ := root_shape M p ζ hζ hallM y hy
+  rw [iota_jqN]
+  intro h
+  obtain ⟨he, _⟩ := TS_injective h
+  have hp2 : 2 ≤ p := hp.out.two_le
+  have hM : 0 < M := Nat.pos_of_ne_zero (NeZero.ne M)
+  have ha : a ≤ M := Nat.le_of_dvd hM haM
+  have h1 : a * a = (M * p) * (M * p) := by
+    have : p * (a * a) = p * ((M * p) * (M * p)) := by rw [he]; ring
+    exact Nat.eq_of_mul_eq_mul_left hp.out.pos this
+  have h2 : a = M * p := Nat.mul_self_inj.mp h1
+  have : M * p ≤ M := h2 ▸ ha
+  have : M * 2 ≤ M * p := Nat.mul_le_mul_left M hp2
+  omega
+
+end Shapes
+
+private theorem hall_all : ∀ N : ℕ, N ≠ 0 → Hall N := by
+  intro N
+  induction N using Nat.strong_induction_on with
+  | _ N ih =>
+  intro hN d hdN hd
+  by_cases hdlt : d < N
+  · exact ih d hdlt (NeZero.ne d) d dvd_rfl
+  have hdN' : d = N := le_antisymm (Nat.le_of_dvd (Nat.pos_of_ne_zero hN) hdN) (not_lt.mp hdlt)
+  subst hdN'
+  have hprop : ∀ m : ℕ, m ∣ d → m < d → Hall m := fun m _ hlt => ih m hlt (by
+    rintro rfl; exact absurd hlt (by have := Nat.pos_of_ne_zero hN; omega))
+  by_cases h1 : d = 1
+  · subst h1; exact ⟨tight_one, gen_one⟩
+  have hgen : Gen d := by
+    unfold Gen
+    refine ModularCurve.modularFunctionField_eq_full_of d ?_ ?_
+    · intro M _ p hp hMp
+      have : Fact (Nat.Prime p) := ⟨hp⟩
+      have hMlt : M < d := by
+        rw [← hMp]; exact lt_mul_of_one_lt_right (Nat.pos_of_ne_zero (NeZero.ne M)) hp.one_lt
+      have hallM : Hall M := hprop M ⟨p, hMp.symm⟩ hMlt
+      have hmem :=
+        ModularCurve.jqN_div_mem_modularFunctionField M p (K := CyclotomicField (M * p) ℚ)
+        (cycUnit (M * p)) (cycUnit_spec (M * p))
+        (fun y hy w hw => htw_of M p (cycUnit (M * p) ^ (M * p / M))
+          (isPrimitiveRoot_pow_div (cycUnit_spec (M * p)) ⟨p, rfl⟩) hallM y hy w hw)
+        (fun y hy => hsp_of M p (cycUnit (M * p) ^ (M * p / M))
+          (isPrimitiveRoot_pow_div (cycUnit_spec (M * p)) ⟨p, rfl⟩) hallM y hy)
+      rw [mff_congr hMp] at hmem
+      exact hmem
+    · intro M _ p hp hMp
+      have hMlt : M < d := by
+        rw [← hMp]; exact lt_mul_of_one_lt_right (Nat.pos_of_ne_zero (NeZero.ne M)) hp.one_lt
+      exact (hprop M ⟨p, hMp.symm⟩ hMlt M dvd_rfl).2
+  refine ⟨?_, hgen⟩
+  unfold Tight
+  set p := d.minFac with hpdef
+  have hp : p.Prime := Nat.minFac_prime h1
+  have : Fact (Nat.Prime p) := ⟨hp⟩
+  obtain ⟨k, M, hpM, hdM⟩ := Nat.exists_eq_pow_mul_and_not_dvd hN p hp.ne_one
+  have hM0 : M ≠ 0 := by rintro rfl; rw [mul_zero] at hdM; exact hN hdM
+  have : NeZero M := ⟨hM0⟩
+  obtain ⟨a, rfl⟩ : ∃ a, k = a + 1 := by
+    rcases k with - | a
+    · exfalso
+      have : p ∣ d := Nat.minFac_dvd d
+      rw [hdM, pow_zero, one_mul] at this
+      exact hpM this
+    · exact ⟨a, rfl⟩
+  have hdM' : d = M * p ^ (a + 1) := by rw [hdM, mul_comm]
+  have hlow_dvd : M * p ^ a ∣ d := ⟨p, by rw [hdM', pow_succ, mul_assoc]⟩
+  have hlow_lt : M * p ^ a < d := by
+    rw [hdM', pow_succ, ← mul_assoc]
+    exact lt_mul_of_one_lt_right (Nat.pos_of_ne_zero (mul_ne_zero hM0 (pow_ne_zero _ hp.ne_zero)))
+      hp.one_lt
+  have hall_low : Hall (M * p ^ a) := hprop _ hlow_dvd hlow_lt
+  have hallM : Hall M := fun e he _ => hall_low e (he.trans ⟨p ^ a, rfl⟩)
+  have hlowdeg : IntermediateField.relfinrank ℚ⟮jq⟯ (modularFunctionFieldFull (M * p ^ a))
+      = dedekindPsi (M * p ^ a) := by
+    have h := hall_low (M * p ^ a) dvd_rfl
+    exact relfinrank_full_of _ h.1 h.2
+  have hstep := ModularCurve.relfinrank_full_eq_mul M p a
+    (ModularCurve.full_eq_adjoin_full_div_prime M p a hpM) (jqN_pow_not_mem_full M p hpM hallM a)
+  have htower := IntermediateField.relfinrank_mul_relfinrank (F0_le_full (M * p ^ a))
+    (full_degeneracy_le (N := M * p ^ a) (M := M * p ^ (a + 1)) ⟨p, by rw [pow_succ, mul_assoc]⟩)
+  rw [← ModularCurve.relfinrank_modularFunctionField d]
+  unfold Gen at hgen
+  rw [hgen, full_congr hdM', ← htower, hlowdeg, hstep]
+  have hpsi : dedekindPsi d = dedekindPsi (M * p ^ a) * (if a = 0 then p + 1 else p) := by
+    rw [hdM']
+    split_ifs with ha
+    · subst ha
+      rw [pow_zero, mul_one, zero_add, pow_one]
+      exact dedekindPsi_mul_prime_not_dvd hp hpM
+    · have h2 : M * p ^ (a + 1) = M * p ^ a * p := by rw [pow_succ, mul_assoc]
+      rw [h2]
+      refine dedekindPsi_mul_prime_dvd (mul_ne_zero hM0 (pow_ne_zero _ hp.ne_zero)) hp ⟨M * p ^ (a -
+        1), ?_⟩
+      obtain ⟨a', rfl⟩ := Nat.exists_eq_succ_of_ne_zero ha
+      rw [Nat.succ_sub_one, pow_succ]; ring
+  rw [hpsi]
+
+end Final
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi (N : ℕ) [NeZero N] :
+    Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+        ({jqN N} : Set (LaurentSeries ℚ))) = dedekindPsi N :=
+  (ModularCurve.W1.hall_all N (NeZero.ne N) N dvd_rfl).1
+
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.modularFunctionField_eq_full (N : ℕ) [NeZero N] :
+    modularFunctionField N = modularFunctionFieldFull N :=
+  (ModularCurve.W1.hall_all N (NeZero.ne N) N dvd_rfl).2
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.functionFieldGeneration (N : ℕ) [NeZero N] :
+    FunctionFieldGeneration N :=
+  (ModularCurve.functionFieldGeneration_iff_full_eq N).mpr
+    (ModularCurve.modularFunctionField_eq_full N).symm
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.exists_phiIrreducible (N : ℕ) [NeZero N] :
+    ∃ data : ModularPolynomialData N, PhiIrreducible data :=
+  ModularCurve.exists_phiIrreducible_of_finrank_eq N (ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi
+    N)
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.relfinrank_full_eq_dedekindPsi (N : ℕ) [NeZero N] :
+    IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (modularFunctionFieldFull N) = dedekindPsi N := by
+  rw [← ModularCurve.modularFunctionField_eq_full N, ModularCurve.relfinrank_modularFunctionField N]
+  exact ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi N
+
+end
+
+p2m_open "ModularCurve~coeffEmb_qExpand\
+  " in
+open _root_.P2MW.S_ModularCurve_functionFieldGeneration.ModularCurve in
+theorem solution (N : ℕ) [NeZero N] : FunctionFieldGeneration N :=
+  ModularCurve.functionFieldGeneration N
+
+end S_ModularCurve_functionFieldGeneration
+end P2MW
+export P2MW.S_ModularCurve_functionFieldGeneration (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.functionFieldGeneration (N : ℕ) [NeZero N] :
+    FunctionFieldGeneration N :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_functionFieldGeneration_iff_full_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_functionFieldGeneration_iff_full_eq.lean
new file mode 100644
index 0000000000..fda752e06e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_functionFieldGeneration_iff_full_eq.lean
@@ -0,0 +1,95 @@
+/-
+Based on Prove2Me node ModularCurve.functionFieldGeneration_iff_full_eq
+(54a1aaea-51d1-590e-9b77-ef68e90744c9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2189201b-8c28-5b12-a277-f014e2d7be3d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Generation property equals collapse of the full modular function field
+
+Theorem statement: `ModularCurve.functionFieldGeneration_iff_full_eq`
+(`54a1aaea-51d1-590e-9b77-ef68e90744c9`), by Claude, 2026-09-05.
+
+Proof: submission `2189201b-8c28-5b12-a277-f014e2d7be3d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number. Inside the field $\mathrm{LaurentSeries}\,\mathbb{Q}$ of
+Laurent series over $\mathbb{Q}$, write `qExpand ℚ d` for the ring endomorphism obtained by
+multiplying all exponents by $d$ (the embedding of the support along $n \mapsto dn$ on $\mathbb{Z}$,
+i.e. substitution $q \mapsto q^{d}$), and let `jq` be the distinguished Laurent series of the
+module. The theorem asserts the equivalence of two statements. The first is the predicate
+`FunctionFieldGeneration N`: for every natural number $d$ dividing $N$ and nonzero, the series
+`qExpand ℚ d jq` lies in the intermediate field $\mathbb{Q}(\,$`jq`$,\,$`qExpand ℚ N jq`$\,)$
+generated over $\mathbb{Q}$ by the two elements `jq` and `qExpand ℚ N jq`. The second is the
+equality of intermediate fields `modularFunctionFieldFull N = modularFunctionField N`, where the
+left-hand side is the subfield of $\mathrm{LaurentSeries}\,\mathbb{Q}$ generated over $\mathbb{Q}$
+by the set of all `qExpand ℚ d jq` with $d$ nonzero and $d \mid N$, and the right-hand side is the
+subfield generated over $\mathbb{Q}$ by the two elements `jq` and `qExpand ℚ N jq`.
+
+This records that the two candidate models of the function field of $X_0(N)$ over $\mathbb{Q}$ built
+from $q$-expansions — the two-generator field $\mathbb{Q}(j(q), j(q^N))$ and the field generated by
+$j(q^d)$ for all divisors $d$ of $N$ — coincide exactly when each $j(q^d)$ is already expressible in
+the two generators. It serves as the interface between the two descriptions and is used throughout
+the curve layer, for instance in the membership statements for the Igusa scheme and in the treatment
+of the Atkin–Lehner involution on modular unit series.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_functionFieldGeneration_iff_full_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_functionFieldGeneration_iff_full_eq
+
+open ModularCurve IntermediateField
+
+noncomputable section
+
+theorem solution (N : ℕ) [NeZero N] :
+    FunctionFieldGeneration N ↔ modularFunctionFieldFull N = modularFunctionField N :=by
+  constructor
+  · intro hgen
+    refine le_antisymm ?_ (modularFunctionField_le_full N)
+    rw [modularFunctionFieldFull, adjoin_le_iff]
+    rintro x ⟨d, hne, hdvd, rfl⟩
+    exact hgen d hdvd hne
+  · intro heq d hdvd hne
+    have := hne
+    change qExpand ℚ d jq ∈ modularFunctionField N
+    rw [← heq]
+    exact jqd_mem_full N hdvd
+
+end
+
+end S_ModularCurve_functionFieldGeneration_iff_full_eq
+end P2MW
+export P2MW.S_ModularCurve_functionFieldGeneration_iff_full_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve IntermediateField
+theorem ModularCurve.functionFieldGeneration_iff_full_eq (N : ℕ) [NeZero N] :
+    FunctionFieldGeneration N ↔ modularFunctionFieldFull N = modularFunctionField N :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_functionFieldGeneration_of_prime.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_functionFieldGeneration_of_prime.lean
new file mode 100644
index 0000000000..261c13a9c9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_functionFieldGeneration_of_prime.lean
@@ -0,0 +1,91 @@
+/-
+Based on Prove2Me node ModularCurve.functionFieldGeneration_of_prime
+(2cc5d6b3-de60-5d55-aac9-721826fd0e9a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7a079f9e-bd2a-5642-9fa5-7766ff31fd78
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Function field generation at prime level
+
+Theorem statement: `ModularCurve.functionFieldGeneration_of_prime`
+(`2cc5d6b3-de60-5d55-aac9-721826fd0e9a`), by Claude, 2026-09-05.
+
+Proof: submission `7a079f9e-bd2a-5642-9fa5-7766ff31fd78`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a natural number, nonzero, and assume $\ell$ is prime. The assertion is the predicate
+`FunctionFieldGeneration ℓ`, which unfolds as follows: for every natural number $d$ dividing $\ell$
+and nonzero, the Laurent series $\mathrm{qExpand}\,\mathbb{Q}\,d\,\mathrm{jq}$ lies in the
+intermediate field $\mathbb{Q}(\mathrm{jq},\ \mathrm{qExpand}\,\mathbb{Q}\,\ell\,\mathrm{jq})$, that
+is, in the subfield of the field of rational Laurent series generated over $\mathbb{Q}$ by the
+two-element set consisting of the series `jq` and of
+$\mathrm{qExpand}\,\mathbb{Q}\,\ell\,\mathrm{jq}$. Here, for a nonzero $N$,
+$\mathrm{qExpand}\,\mathbb{Q}\,N$ is the ring endomorphism of $\mathbb{Q}$-Laurent series obtained
+by pushing the support forward along multiplication by $N$ on the exponent group $\mathbb{Z}$ (an
+injective, order-preserving map, since $N>0$); thus it is the substitution $q \mapsto q^{N}$, and
+`jq` is the project's Laurent series attached to the modular invariant $j$. So the conclusion states
+that all the series $j(q^{d})$ for $d \mid \ell$ lie in the field generated by $j(q)$ and
+$j(q^{\ell})$.
+
+This is the generation statement, at prime level, for the function field of the algebraic model of
+$X_0(N)$: the full field $\mathbb{Q}(j(q^{d}) : d \mid N)$ coincides with the field generated by the
+two distinguished elements $j(q)$ and $j(q^{N})$. It is used in the curve layer of the $X_0(\ell)$
+construction, being cited by
+[`ModularCurve.full_eq_of_prime`](thm.html#ModularCurve.full_eq_of_prime) and by
+[`ModularCurve.NodeLocalized.place_eq_of_forall_hasValue_iff_of_mem_fieldOver`]
+(thm.html#ModularCurve.NodeLocalized.place_eq_of_forall_hasValue_iff_of_mem_fieldOver).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_functionFieldGeneration_of_prime.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_functionFieldGeneration_of_prime
+
+open ModularCurve IntermediateField
+
+noncomputable section
+
+theorem solution {ℓ : ℕ} [NeZero ℓ] (hℓ : ℓ.Prime) : FunctionFieldGeneration ℓ :=by
+  intro d hd hne
+  have := hne
+  rcases (Nat.dvd_prime hℓ).mp hd with rfl | rfl
+  · rw [qExpand_one_apply]
+    exact subset_adjoin ℚ _ (Set.mem_insert _ _)
+  · exact subset_adjoin ℚ _ (Set.mem_insert_of_mem _ rfl)
+
+end
+
+end S_ModularCurve_functionFieldGeneration_of_prime
+end P2MW
+export P2MW.S_ModularCurve_functionFieldGeneration_of_prime (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve IntermediateField
+theorem ModularCurve.functionFieldGeneration_of_prime {ℓ : ℕ} [NeZero ℓ] (hℓ : ℓ.Prime) :
+    FunctionFieldGeneration ℓ :=
+  solution hℓ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_functionFieldGeneration_of_squarefree.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_functionFieldGeneration_of_squarefree.lean
new file mode 100644
index 0000000000..a9371b7e72
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_functionFieldGeneration_of_squarefree.lean
@@ -0,0 +1,138 @@
+/-
+Based on Prove2Me node ModularCurve.functionFieldGeneration_of_squarefree
+(3024c339-8925-59b6-9af7-09c343513ffd) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 42bcbf2e-1dcb-55d8-8c93-45f2c31520f7
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqN_eq_of_squarefree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_of_squarefree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_modularFunctionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration_iff_full_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_of_squarefree
+import Mathlib.FieldTheory.Relrank
+import Mathlib.FieldTheory.Minpoly.Field
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Function field generation at squarefree level
+
+Theorem statement: `ModularCurve.functionFieldGeneration_of_squarefree`
+(`3024c339-8925-59b6-9af7-09c343513ffd`), by Claude, 2026-09-05.
+
+Proof: submission `42bcbf2e-1dcb-55d8-8c93-45f2c31520f7`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number which is nonzero and squarefree. The conclusion is the predicate
+`FunctionFieldGeneration N`, which asserts: for every natural number $d$ dividing $N$ and nonzero,
+the Laurent series `qExpand ℚ d jq` belongs to the intermediate field $\mathbb{Q}(\mathtt{jq},\
+\mathtt{qExpand}\ \mathbb{Q}\ N\ \mathtt{jq})$, i.e. to `IntermediateField.adjoin ℚ {jq, qExpand ℚ N
+jq}` inside the field `LaurentSeries ℚ` of Laurent series over $\mathbb{Q}$. Here `jq` is the
+distinguished element of `LaurentSeries ℚ` serving as the $q$-expansion of the modular invariant
+$j$, and for a nonzero $m$ the map `qExpand ℚ m` is the ring endomorphism of `LaurentSeries ℚ`
+obtained by transporting the Hahn-series support along multiplication by $m$ on exponents, that is,
+the substitution $q \mapsto q^{m}$. Thus for squarefree $N$ each $j(q^{d})$ with $d \mid N$ lies in
+the subfield of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by $j(q)$ and $j(q^{N})$.
+
+This is the statement that, at squarefree level, the field generated by all $j(q^{d})$ for $d \mid
+N$ collapses to the two-generator field $\mathbb{Q}(j(q), j(q^{N}))$, the $q$-expansion model of the
+function field of $X_0(N)$ over $\mathbb{Q}$. It is used in the purely algebraic determination of
+$[\mathbb{Q}(j)(j_N):\mathbb{Q}(j)] = \psi(N)$ and the irreducibility of the modular polynomial, and
+is cited by [`ModularCurve.jqN_prime_not_mem_full`](thm.html#ModularCurve.jqN_prime_not_mem_full)
+and
+[`ModularCurve.minpoly_jqN_map_eq_prod_slots`](thm.html#ModularCurve.minpoly_jqN_map_eq_prod_slots).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_functionFieldGeneration_of_squarefree.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_functionFieldGeneration_of_squarefree
+
+noncomputable section
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_functionFieldGeneration_of_squarefree.ModularCurve \
+  ModularCurve.PhiGen"
+open scoped IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jq jqN dedekindPsi ModularPolynomialData FunctionFieldGeneration \
+  modularFunctionField adjoin_jq_le algebraMap_comp_evalAtJGen ModularPolynomialData.toAdjoin \
+  modularFunctionFieldFull modularFunctionField_le_full PhiIrreducible \
+  finrank_adjoin_jqN_eq_of_squarefree relfinrank_full_of_squarefree \
+  relfinrank_modularFunctionField functionFieldGeneration_iff_full_eq dedekindPsi_of_squarefree"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.functionFieldGeneration_of_squarefree (N : ℕ) [NeZero N]
+    (hN : Squarefree N) :
+    FunctionFieldGeneration N := by
+  rw [functionFieldGeneration_iff_full_eq]
+  refine le_antisymm ?_ (modularFunctionField_le_full N)
+  have hψ : 0 < dedekindPsi N := by
+    rw [dedekindPsi_of_squarefree hN]; exact Finset.prod_pos fun p _ => Nat.succ_pos p
+  have h1 : IntermediateField.relfinrank ℚ⟮jq⟯ (modularFunctionField N) = dedekindPsi N := by
+    rw [relfinrank_modularFunctionField, finrank_adjoin_jqN_eq_of_squarefree N hN]
+  have hmul :=
+    IntermediateField.relfinrank_mul_relfinrank (adjoin_jq_le N) (modularFunctionField_le_full N)
+  rw [h1, relfinrank_full_of_squarefree N hN] at hmul
+  have hone : IntermediateField.relfinrank (modularFunctionField N) (modularFunctionFieldFull N) = 1
+    :=
+    (Nat.eq_of_mul_eq_mul_left hψ (hmul.trans (Nat.mul_one _).symm))
+  exact IntermediateField.relfinrank_eq_one_iff.mp hone
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.phiIrreducible_of_squarefree (N : ℕ) [NeZero N] (hN : Squarefree N)
+    (data : ModularPolynomialData N) :
+    PhiIrreducible data := by
+  have hroot : Polynomial.aeval (jqN N) data.toAdjoin = 0 := by
+    rw [ModularPolynomialData.toAdjoin, Polynomial.aeval_def, Polynomial.eval₂_map,
+      algebraMap_comp_evalAtJGen]
+    exact data.eval_eq_zero
+  have hint : IsIntegral ℚ⟮jq⟯ (jqN N) :=
+    ⟨_, data.toAdjoin_monic, by rwa [Polynomial.aeval_def] at hroot⟩
+  have hdeg : (minpoly ℚ⟮jq⟯ (jqN N)).natDegree = dedekindPsi N := by
+    rw [← IntermediateField.adjoin.finrank hint]; exact finrank_adjoin_jqN_eq_of_squarefree N hN
+  have heq : data.toAdjoin = minpoly ℚ⟮jq⟯ (jqN N) := by
+    refine Polynomial.eq_of_monic_of_dvd_of_natDegree_le (minpoly.monic hint) data.toAdjoin_monic
+      (minpoly.dvd _ _ hroot) ?_
+    rw [hdeg, ModularPolynomialData.toAdjoin, data.monic.natDegree_map, data.natDegree_eq]
+  rw [PhiIrreducible, heq]
+  exact minpoly.irreducible hint
+
+open _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_functionFieldGeneration_of_squarefree.ModularCurve in
+theorem solution (N : ℕ) [NeZero N] (hN : Squarefree N) : FunctionFieldGeneration N :=
+  ModularCurve.functionFieldGeneration_of_squarefree N hN
+
+end
+end S_ModularCurve_functionFieldGeneration_of_squarefree
+end P2MW
+export P2MW.S_ModularCurve_functionFieldGeneration_of_squarefree (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.functionFieldGeneration_of_squarefree (N : ℕ) [NeZero N] (hN : Squarefree N) :
+    FunctionFieldGeneration N :=
+  solution N hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_functionFieldRiemannRoch_modularFunctionFieldBar.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_functionFieldRiemannRoch_modularFunctionFieldBar.lean
new file mode 100644
index 0000000000..3a469da475
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_functionFieldRiemannRoch_modularFunctionFieldBar.lean
@@ -0,0 +1,226 @@
+/-
+Based on Prove2Me node ModularCurve.functionFieldRiemannRoch_modularFunctionFieldBar
+(041d4842-09cb-52b9-9b24-820ceca70f48) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3b199469-0472-5cf4-aa63-3893f2e6bf8e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ArithmeticGalois
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RiemannRochRows
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_CanonicalLocalResidueInstanceV2
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_dCoordGenerates_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_instIsCurveOverRatFunc
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_essFiniteType_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasCanonicalDivisor_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCurveOver_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_jqNModC_all
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_adjoin_pair
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+
+/-!
+# Riemann–Roch for the modular function field over ℚ̄
+
+Theorem statement: `ModularCurve.functionFieldRiemannRoch_modularFunctionFieldBar`
+(`041d4842-09cb-52b9-9b24-820ceca70f48`), by Claude, 2026-09-05.
+
+Proof: submission `3b199469-0472-5cf4-aa63-3893f2e6bf8e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number, let $K = \overline{\mathbb{Q}}$ be the algebraic closure of
+$\mathbb{Q}$, and let $F =$ `modularFunctionFieldBar N` be the intermediate field of $K((q))$ over
+$K$ obtained by base change: it is the $K$-subfield of $K((q))$ generated by the image, under the
+coefficientwise embedding of $\mathbb{Q}((q))$ into $K((q))$, of `modularFunctionFieldFull N`,
+itself the subfield of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by the expansions
+`divisorExpansions N`. The assertion is `FunctionFieldRiemannRoch K F`, that is: assuming $F$ is a
+curve over $K$ (principal divisors exist, every place has residue field finite over $K$, and
+$\Omega[F/K]$ is free of rank one over $F$), that canonical divisors exist (every nonzero $\omega
+\in \Omega[F/K]$ has a divisor whose value at each place $v$ is $\mathrm{ord}_v$ of the differential
+$\omega$), and that at every place the element $v.\mathrm{dCoord}$ spans $\Omega[F/K]$ over $F$,
+then for every nonzero $\omega \in \Omega[F/K]$ and every divisor $D$ (a finitely supported
+$\mathbb{Z}$-valued function on the places of $F$ over $K$, places being proper valuation subrings
+of $F$ containing $K$ that are principal ideal rings),
+$$\ell(D) - \ell\big((\omega) - D\big) = \deg D + 1 - g,$$
+where $(\omega)$ is the canonical divisor attached to $\omega$, $\deg$ weights each place by its
+degree, and $g$ is the genus of $F/K$, defined as $(\deg(\omega') + 2)/2$ for a chosen nonzero
+differential $\omega'$.
+
+This is the Riemann–Roch theorem for the function field of the modular curve $X_0(N)$ with
+algebraically closed constant field $\overline{\mathbb{Q}}$, obtained by specialising the general
+Riemann–Roch theorem over an algebraically closed base field to this field, whose relevant
+structural hypotheses (curve over $\overline{\mathbb{Q}}$, essential finite type, generation by $j$
+and $j_N$ with $j$ transcendental and $j_N$ integral over $\overline{\mathbb{Q}}(j)$) are supplied
+by the cited results. It underlies the subsequent computations of genus, of degrees of canonical
+divisors and of dimensions of Riemann–Roch spaces on $X_0(N)$, and of height estimates made with
+functions in such spaces.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_functionFieldRiemannRoch_modularFunctionFieldBar.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+noncomputable section
+
+open IntermediateField
+
+namespace AlgebraicCurve
+
+namespace RDOCK
+
+variable (K : Type*) [Field K] {LF : Type*} [Field LF] [Algebra K LF]
+
+private theorem exists_transcendental_finiteDimensional (x : LF) (hx : Transcendental K x)
+    (T : Finset LF) (hT : ∀ t ∈ T, IsIntegral K⟮x⟯ t) :
+    ∃ x' : IntermediateField.adjoin K (insert x (T : Set LF)), Transcendental K x' ∧
+      FiniteDimensional K⟮x'⟯ (IntermediateField.adjoin K (insert x (T : Set LF))) := by
+  set F : IntermediateField K LF := IntermediateField.adjoin K (insert x (T : Set LF)) with hF
+  have hxF : x ∈ F := subset_adjoin K _ (Set.mem_insert x _)
+  have hTF : ∀ t ∈ T, t ∈ F := fun t ht => subset_adjoin K _ (Set.mem_insert_of_mem x ht)
+  set x' : F := ⟨x, hxF⟩ with hx'
+  have hx't : Transcendental K x' :=
+    (transcendental_algebraMap_iff (R := K) (S := F) (A := LF) Subtype.val_injective).mp hx
+  set A : IntermediateField K F := IntermediateField.adjoin K ({x'} : Set F) with hA
+  have hliftA : lift A = K⟮x⟯ := by
+    rw [hA, lift_adjoin_simple]
+  let e : A ≃ₐ[K] K⟮x⟯ := (liftAlgEquiv A).trans (equivOfEq hliftA)
+  have he : ∀ a : A, ((e a : K⟮x⟯) : LF) = ((a : F) : LF) := by
+    intro a; rfl
+  have hcomp' : (algebraMap A LF).comp (e.symm : K⟮x⟯ →+* A)
+      = (RingHom.id LF).comp (algebraMap K⟮x⟯ LF) := by
+    ext b
+    change (((e.symm b : A) : F) : LF) = ((b : K⟮x⟯) : LF)
+    rw [← he (e.symm b), AlgEquiv.apply_symm_apply]
+  have hint : ∀ t (ht : t ∈ T), IsIntegral A (⟨t, hTF t ht⟩ : F) := by
+    intro t ht
+    have h1 : IsIntegral A (t : LF) :=
+      (hT t ht).map_of_comp_eq (R := K⟮x⟯) (S := LF) (T := A) (U := LF)
+        (e.symm : K⟮x⟯ →+* A) (RingHom.id LF) hcomp'
+    exact (isIntegral_algHom_iff (IsScalarTower.toAlgHom A F LF) Subtype.val_injective).mp h1
+  have hfd : FiniteDimensional A F := by
+    set T' : Set F := (fun t : T => (⟨(t : LF), hTF t t.2⟩ : F)) '' Set.univ with hT'
+    have : Finite T' := Set.Finite.to_subtype ((Set.finite_univ).image _)
+    have hT'int : ∀ y ∈ T', IsIntegral A y := by
+      rintro _ ⟨t, -, rfl⟩; exact hint t t.2
+    have : FiniteDimensional A (IntermediateField.adjoin A T') := finiteDimensional_adjoin hT'int
+    have htop : IntermediateField.adjoin A T' = ⊤ := by
+      apply restrictScalars_injective K
+      rw [restrictScalars_adjoin, restrictScalars_top]
+      apply lift_injective
+      rw [lift_top, lift_adjoin]
+      apply le_antisymm (adjoin_le_iff.mpr ?_) ?_
+      · rintro _ ⟨y, hy, rfl⟩; exact y.2
+      · change IntermediateField.adjoin K (insert x (T : Set LF)) ≤ _
+        apply adjoin.mono
+        intro z hz
+        rcases hz with rfl | hz
+        · exact ⟨x', Or.inl (subset_adjoin K _ (Set.mem_singleton _)), rfl⟩
+        · exact ⟨⟨z, hTF z hz⟩, Or.inr ⟨⟨z, hz⟩, Set.mem_univ _, rfl⟩, rfl⟩
+    rw [htop] at this
+    exact LinearEquiv.finiteDimensional (IntermediateField.topEquiv (F := A) (E := F)).toLinearEquiv
+  exact ⟨x', hx't, hfd⟩
+
+end RDOCK
+
+end AlgebraicCurve
+
+end
+
+open ModularCurve AlgebraicCurve
+
+theorem solution (N : ℕ) [NeZero N] :
+    FunctionFieldRiemannRoch (AlgebraicClosure ℚ) (modularFunctionFieldBar N) := by
+  have hpair : laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)
+      = IntermediateField.adjoin (AlgebraicClosure ℚ)
+      {jqModC (AlgebraicClosure ℚ), jqNModC (AlgebraicClosure ℚ) N} :=
+    laurentBaseChange_adjoin_pair (AlgebraicClosure ℚ) N (functionFieldGeneration N)
+  have h : ∀ E : IntermediateField (AlgebraicClosure ℚ) (LaurentSeries (AlgebraicClosure ℚ)),
+      E = IntermediateField.adjoin (AlgebraicClosure ℚ)
+        (insert (jqModC (AlgebraicClosure ℚ)) ((({jqNModC (AlgebraicClosure ℚ) N} : Finset
+          (LaurentSeries (AlgebraicClosure ℚ))) : Set (LaurentSeries (AlgebraicClosure ℚ))))) →
+      ∃ x' : E, Transcendental (AlgebraicClosure ℚ) x' ∧ FiniteDimensional (IntermediateField.adjoin
+        (AlgebraicClosure ℚ) ({x'} : Set E)) E := by
+    rintro E rfl
+    refine AlgebraicCurve.RDOCK.exists_transcendental_finiteDimensional (AlgebraicClosure ℚ) (jqModC
+      (AlgebraicClosure ℚ))
+      (transcendental_jqModC (AlgebraicClosure ℚ)) {jqNModC (AlgebraicClosure ℚ) N} ?_
+    intro t ht
+    rw [Finset.mem_singleton] at ht
+    subst ht
+    exact isIntegral_jqNModC_all (AlgebraicClosure ℚ) N
+  obtain ⟨x', hx', hfd⟩ := h (modularFunctionFieldBar N) (by rw [Finset.coe_singleton]; exact hpair)
+  let e := RatFunc.algEquivOfTranscendental x' hx'
+  let : Algebra (RatFunc (AlgebraicClosure ℚ)) (IntermediateField.adjoin (AlgebraicClosure ℚ) ({x'}
+    : Set (modularFunctionFieldBar N))) :=
+    e.toAlgHom.toRingHom.toAlgebra
+  let : Algebra (RatFunc (AlgebraicClosure ℚ)) (modularFunctionFieldBar N) :=
+    ((algebraMap (IntermediateField.adjoin (AlgebraicClosure ℚ) ({x'} : Set (modularFunctionFieldBar
+      N))) (modularFunctionFieldBar N)).comp e.toAlgHom.toRingHom).toAlgebra
+  have : IsScalarTower (RatFunc (AlgebraicClosure ℚ)) (IntermediateField.adjoin (AlgebraicClosure ℚ)
+    ({x'} : Set (modularFunctionFieldBar N))) (modularFunctionFieldBar N) :=
+    IsScalarTower.of_algebraMap_eq fun q => rfl
+  have : IsScalarTower (AlgebraicClosure ℚ) (RatFunc (AlgebraicClosure ℚ)) (modularFunctionFieldBar
+    N) :=
+    IsScalarTower.of_algebraMap_eq fun r => by
+      change algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) r = algebraMap
+        (IntermediateField.adjoin (AlgebraicClosure ℚ) ({x'} : Set (modularFunctionFieldBar N)))
+        (modularFunctionFieldBar N) (e (algebraMap (AlgebraicClosure ℚ) (RatFunc (AlgebraicClosure
+        ℚ)) r))
+      rw [AlgEquiv.commutes]
+      exact IsScalarTower.algebraMap_apply (AlgebraicClosure ℚ) (IntermediateField.adjoin
+        (AlgebraicClosure ℚ) ({x'} : Set (modularFunctionFieldBar N))) (modularFunctionFieldBar N) r
+  have : Module.Finite (RatFunc (AlgebraicClosure ℚ)) (IntermediateField.adjoin (AlgebraicClosure ℚ)
+    ({x'} : Set (modularFunctionFieldBar N))) :=
+    Module.Finite.of_surjective (Algebra.linearMap (RatFunc (AlgebraicClosure ℚ))
+      (IntermediateField.adjoin (AlgebraicClosure ℚ) ({x'} : Set (modularFunctionFieldBar N))))
+      e.surjective
+  have : Module.Finite (RatFunc (AlgebraicClosure ℚ)) (modularFunctionFieldBar N) :=
+    Module.Finite.trans (IntermediateField.adjoin (AlgebraicClosure ℚ) ({x'} : Set
+      (modularFunctionFieldBar N))) (modularFunctionFieldBar N)
+  have : Algebra.IsIntegral (RatFunc (AlgebraicClosure ℚ)) (modularFunctionFieldBar N) :=
+    Algebra.IsIntegral.of_finite (RatFunc (AlgebraicClosure ℚ)) (modularFunctionFieldBar N)
+  have : CharZero (RatFunc (AlgebraicClosure ℚ)) :=
+    charZero_of_injective_algebraMap (algebraMap (AlgebraicClosure ℚ) (RatFunc (AlgebraicClosure
+      ℚ))).injective
+  have : PerfectField (RatFunc (AlgebraicClosure ℚ)) := PerfectField.ofCharZero
+  have := isCurveOver_modularFunctionFieldBar N
+  have := hasCanonicalDivisor_modularFunctionFieldBar N
+  have := essFiniteType_modularFunctionFieldBar N
+  have : ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), w.DCoordGenerates :=
+    dCoordGenerates_of_isCurveOver
+  have := AlgebraicCurve.instIsCurveOverRatFunc (AlgebraicClosure ℚ)
+  have : Algebra.EssFiniteType (Polynomial (AlgebraicClosure ℚ)) (RatFunc (AlgebraicClosure ℚ)) :=
+    Algebra.EssFiniteType.of_isLocalization (RatFunc (AlgebraicClosure ℚ)) (nonZeroDivisors
+      (Polynomial (AlgebraicClosure ℚ)))
+  have : Algebra.EssFiniteType (AlgebraicClosure ℚ) (RatFunc (AlgebraicClosure ℚ)) :=
+    Algebra.EssFiniteType.comp (AlgebraicClosure ℚ) (Polynomial (AlgebraicClosure ℚ)) (RatFunc
+      (AlgebraicClosure ℚ))
+  have : ∀ v : Place (AlgebraicClosure ℚ) (RatFunc (AlgebraicClosure ℚ)), v.DCoordGenerates :=
+    dCoordGenerates_of_isCurveOver
+  exact @functionFieldRiemannRoch_of_isAlgClosed (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+    _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.functionFieldRiemannRoch_modularFunctionFieldBar (N : ℕ) [NeZero N] :
+    FunctionFieldRiemannRoch (AlgebraicClosure ℚ) (modularFunctionFieldBar N) :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_gammaFundamentalSet_boundary_sidePairing_of_slash_eq_add.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_gammaFundamentalSet_boundary_sidePairing_of_slash_eq_add.lean
new file mode 100644
index 0000000000..64c97ba928
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_gammaFundamentalSet_boundary_sidePairing_of_slash_eq_add.lean
@@ -0,0 +1,381 @@
+/-
+Based on Prove2Me node ModularCurve.gammaFundamentalSet_boundary_sidePairing_of_slash_eq_add
+(16fe51ac-3e7c-534d-becf-3576fba25b56) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d927ab98-aa3f-565a-acf1-3d5dca60f83c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.CStarAlgebra.Classes
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Topology
+public import Mathlib.MeasureTheory.Integral.IntervalIntegral.Basic
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Side pairing on the boundary of a tiled fundamental set
+
+Theorem statement: `ModularCurve.gammaFundamentalSet_boundary_sidePairing_of_slash_eq_add`
+(`16fe51ac-3e7c-534d-becf-3576fba25b56`), by Claude, 2026-09-05.
+
+Proof: submission `d927ab98-aa3f-565a-acf1-3d5dca60f83c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of $\mathrm{SL}_2(\mathbb{Z})$ of finite index, and for each coset $q \in
+\mathrm{SL}_2(\mathbb{Z})/\Gamma$ write $R_q :=$ `Quotient.out q` for the chosen representative. Let
+$\varphi, \psi : \mathbb{H} \to \mathbb{C}$ and $c : \mathrm{SL}_2(\mathbb{Z}) \to \mathbb{C}$
+satisfy the twisted weight-two transformation law $\varphi(\gamma\tau)/\mathrm{denom}(\gamma,\tau)^2
+= \varphi(\tau) + c(\gamma)\,\psi(\tau)$ for all $\gamma \in \Gamma$ and $\tau \in \mathbb{H}$,
+where $\mathrm{denom}$ is taken for the image of $\gamma$ in $\mathrm{GL}_2(\mathbb{R})$. Let $\Phi,
+\Psi : \mathrm{SL}_2(\mathbb{Z}) \to \mathbb{C} \to \mathbb{C}$ be given by $\Phi_\sigma(z) =
+\varphi(\sigma \cdot \mathrm{ofComplex}\,z)/\mathrm{denom}(\sigma, \mathrm{ofComplex}\,z)^2$ and the
+same formula for $\Psi$ with $\psi$. Let $s \subseteq (0,\infty)$ be measurable, assume that for
+every $q$ the functions $y \mapsto \Phi_{R_q^{-1}}(-\tfrac12 + iy)$ and $y \mapsto
+\Psi_{R_q^{-1}}(-\tfrac12 + iy)$ are integrable on $s$, and that $\theta \mapsto
+\Phi_{R_q^{-1}}(e^{i\theta})\, i e^{i\theta}$ and $\theta \mapsto \Psi_{R_q^{-1}}(e^{i\theta})\, i
+e^{i\theta}$ are interval-integrable on $[\pi/3, 2\pi/3]$. Then two identities hold simultaneously:
+first, $\sum_q \int_s \Phi_{R_q^{-1}}(\tfrac12 + iy)\,dy = \sum_q \int_s \Phi_{R_q^{-1}}(-\tfrac12 +
+iy)\,dy + \sum_q c(R_{Tq}^{-1} T R_q) \int_s \Psi_{R_q^{-1}}(-\tfrac12 + iy)\,dy$, with $T =$
+`ModularGroup.T` acting on the coset space; second, $2\sum_q \int_{\pi/3}^{2\pi/3}
+\Phi_{R_q^{-1}}(e^{i\theta})\, i e^{i\theta}\,d\theta = -\sum_q c(R_{Sq}^{-1} S R_q)
+\int_{\pi/3}^{2\pi/3} \Psi_{R_q^{-1}}(e^{i\theta})\, i e^{i\theta}\,d\theta$, with $S =$
+`ModularGroup.S`.
+
+This is the side-pairing, or unfolding, step for contour integration over the fundamental polygon of
+$\Gamma$ tiled by the translates $R_q^{-1}\mathcal{D}$ of the standard fundamental domain of
+$\mathrm{SL}_2(\mathbb{Z})$: the vertical edges are paired by $T$ and the two halves of the
+unit-circle arc by $S$, so that the corresponding boundary integrals cancel up to the twist $c$
+evaluated at the side-pairing elements $R_{gq}^{-1} g R_q \in \Gamma$. It is used in the boundary
+evaluations behind the Eichler–Shimura and Petersson pairing computations for the fundamental set of
+$\Gamma$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_gammaFundamentalSet_boundary_sidePairing_of_slash_eq_add.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_gammaFundamentalSet_boundary_sidePairing_of_slash_eq_add
+
+noncomputable section
+
+open scoped MatrixGroups UpperHalfPlane
+open UpperHalfPlane Complex MeasureTheory
+
+namespace ModularCurve
+namespace GammaSidePairing
+
+variable {Γ : Subgroup SL(2, ℤ)}
+
+structure IsSection (Γ : Subgroup SL(2, ℤ)) (R : SL(2, ℤ) ⧸ Γ → SL(2, ℤ)) : Prop where
+  mk_eq : ∀ q, (QuotientGroup.mk (R q) : SL(2, ℤ) ⧸ Γ) = q
+
+theorem isSection_out (Γ : Subgroup SL(2, ℤ)) : IsSection Γ Quotient.out :=
+  ⟨fun q => QuotientGroup.out_eq' q⟩
+
+variable {R : SL(2, ℤ) ⧸ Γ → SL(2, ℤ)}
+
+def pairElt (R : SL(2, ℤ) ⧸ Γ → SL(2, ℤ)) (g : SL(2, ℤ)) (q : SL(2, ℤ) ⧸ Γ) : SL(2, ℤ) :=
+  (R (g • q))⁻¹ * g * R q
+
+theorem pairElt_mem (hR : IsSection Γ R) (g : SL(2, ℤ)) (q : SL(2, ℤ) ⧸ Γ) :
+    pairElt R g q ∈ Γ := by
+  have h : (QuotientGroup.mk (R (g • q)) : SL(2, ℤ) ⧸ Γ) = QuotientGroup.mk (g * R q) := by
+    rw [hR.mk_eq]
+    conv_lhs => rw [← hR.mk_eq q]
+    rfl
+  rw [pairElt, mul_assoc]
+  exact QuotientGroup.eq.mp h
+
+theorem inv_mul_eq_pairElt (g : SL(2, ℤ)) (q : SL(2, ℤ) ⧸ Γ) :
+    (R (g • q))⁻¹ * g = pairElt R g q * (R q)⁻¹ := by
+  simp [pairElt, mul_assoc]
+
+theorem sum_comp_smul [Fintype (SL(2, ℤ) ⧸ Γ)] {M : Type*} [AddCommMonoid M]
+    (g : SL(2, ℤ)) (f : SL(2, ℤ) ⧸ Γ → M) : ∑ q, f (g • q) = ∑ q, f q :=
+  Fintype.sum_equiv (MulAction.toPerm g) _ _ fun _ => rfl
+
+def D (σ : SL(2, ℤ)) (z : ℂ) : ℂ := 1 / (denom (σ : GL (Fin 2) ℝ) z) ^ 2
+
+theorem σ_sl (τ : SL(2, ℤ)) (z : ℂ) : σ (τ : GL (Fin 2) ℝ) z = z := by simp [σ]
+
+theorem D_mul (σ τ : SL(2, ℤ)) (w : ℍ) : D (σ * τ) w = D σ ((τ • w : ℍ) : ℂ) * D τ w := by
+  unfold D
+  have := denom_cocycle' (σ : GL (Fin 2) ℝ) (τ : GL (Fin 2) ℝ) w
+  rw [σ_sl] at this
+  have e : ((σ : GL (Fin 2) ℝ) * (τ : GL (Fin 2) ℝ)) = ((σ * τ : SL(2, ℤ)) : GL (Fin 2) ℝ) := by
+    simp only [map_mul]
+  rw [e] at this
+  rw [ModularGroup.sl_moeb, this]
+  change _ = 1 / denom _ (↑((τ : GL (Fin 2) ℝ) • w)) ^ 2 * _
+  rw [UpperHalfPlane.smulAux, mul_pow, one_div_mul_one_div]; rfl
+
+def slash2 (φ : ℍ → ℂ) (σ : SL(2, ℤ)) (w : ℍ) : ℂ := φ (σ • w) * D σ w
+
+theorem slash2_mul (φ : ℍ → ℂ) (σ τ : SL(2, ℤ)) :
+    slash2 φ (σ * τ) = slash2 (slash2 φ σ) τ := by
+  funext w; simp only [slash2, mul_smul, D_mul]; ring
+
+theorem slash2_tile_pair (φ : ℍ → ℂ) (g : SL(2, ℤ)) (q : SL(2, ℤ) ⧸ Γ) :
+    slash2 (slash2 φ (R (g • q))⁻¹) g = slash2 (slash2 φ (pairElt R g q)) (R q)⁻¹ := by
+  rw [← slash2_mul, ← slash2_mul, inv_mul_eq_pairElt]
+
+def tilePull (φ : ℍ → ℂ) (σ : SL(2, ℤ)) (z : ℂ) : ℂ := slash2 φ σ (ofComplex z)
+
+theorem D_T (z : ℂ) : D ModularGroup.T z = 1 := by simp [D, ModularGroup.T, denom]
+
+theorem D_S (z : ℂ) : D ModularGroup.S z = 1 / z ^ 2 := by simp [D, ModularGroup.S, denom]
+
+theorem T_smul_coe (w : ℍ) : ((ModularGroup.T • w : ℍ) : ℂ) = (w : ℂ) + 1 := by
+  rw [UpperHalfPlane.modular_T_smul]; simp [UpperHalfPlane.coe_vadd, add_comm]
+
+theorem S_smul_coe (w : ℍ) : ((ModularGroup.S • w : ℍ) : ℂ) = -((w : ℂ))⁻¹ := by
+  rw [UpperHalfPlane.modular_S_smul]; simp [inv_neg]
+
+theorem ray_pt_im (x y : ℝ) : ((x : ℂ) + y * Complex.I).im = y := by simp
+
+theorem T_smul_leftRay {y : ℝ} (hy : 0 < y) :
+    ModularGroup.T • ofComplex (-(1 / 2) + y * Complex.I) = ofComplex (1 / 2 + y * Complex.I) := by
+  have h1 : (0 : ℝ) < (-(1 / 2 : ℂ) + y * Complex.I).im := by simpa using hy
+  have h2 : (0 : ℝ) < ((1 / 2 : ℂ) + y * Complex.I).im := by simpa using hy
+  apply UpperHalfPlane.ext
+  rw [T_smul_coe, ofComplex_apply_of_im_pos h1, ofComplex_apply_of_im_pos h2]
+  push_cast; ring
+
+theorem tilePull_T_pt (φ : ℍ → ℂ) (q : SL(2, ℤ) ⧸ Γ) {y : ℝ} (hy : 0 < y) :
+    tilePull φ (R (ModularGroup.T • q))⁻¹ (1 / 2 + y * Complex.I) =
+      tilePull (slash2 φ (pairElt R ModularGroup.T q)) (R q)⁻¹ (-(1 / 2) + y * Complex.I) := by
+  have := congrFun (slash2_tile_pair (R := R) φ ModularGroup.T q)
+    (ofComplex (-(1 / 2) + y * Complex.I))
+  simp only [slash2, D_T, mul_one, T_smul_leftRay hy] at this
+  simpa only [tilePull, slash2] using this
+
+theorem sum_integral_rightRay [Fintype (SL(2, ℤ) ⧸ Γ)] (φ : ℍ → ℂ) {s : Set ℝ}
+    (hs : MeasurableSet s) (hs0 : s ⊆ Set.Ioi 0) :
+    ∑ q : SL(2, ℤ) ⧸ Γ, ∫ y in s, tilePull φ (R q)⁻¹ (1 / 2 + y * Complex.I) =
+      ∑ q : SL(2, ℤ) ⧸ Γ, ∫ y in s,
+        tilePull (slash2 φ (pairElt R ModularGroup.T q)) (R q)⁻¹ (-(1 / 2) + y * Complex.I) := by
+  rw [← sum_comp_smul ModularGroup.T]
+  refine Finset.sum_congr rfl fun q _ => setIntegral_congr_fun hs fun y hy => ?_
+  exact tilePull_T_pt φ q (hs0 hy)
+
+theorem exp_arc_im_pos {θ : ℝ} (h1 : 0 < θ) (h2 : θ < Real.pi) :
+    0 < (Complex.exp (θ * Complex.I)).im := by
+  rw [Complex.exp_im, Complex.mul_I_im, Complex.mul_I_re]
+  simp only [Complex.ofReal_re, Complex.ofReal_im, neg_zero, Real.exp_zero, one_mul]
+  exact Real.sin_pos_of_pos_of_lt_pi h1 h2
+
+theorem S_smul_arc {θ : ℝ} (h1 : 0 < θ) (h2 : θ < Real.pi) :
+    ModularGroup.S • ofComplex (Complex.exp (θ * Complex.I)) =
+      ofComplex (Complex.exp (↑(Real.pi - θ) * Complex.I)) := by
+  have h1' : 0 < Real.pi - θ := by linarith
+  have h2' : Real.pi - θ < Real.pi := by linarith
+  apply UpperHalfPlane.ext
+  rw [S_smul_coe, ofComplex_apply_of_im_pos (exp_arc_im_pos h1 h2),
+    ofComplex_apply_of_im_pos (exp_arc_im_pos h1' h2')]
+  push_cast
+  rw [sub_mul, Complex.exp_sub, Complex.exp_pi_mul_I, ← Complex.exp_neg]
+  field_simp
+  rw [← Complex.exp_add, neg_add_cancel, Complex.exp_zero]
+
+theorem tilePull_S_pt (φ : ℍ → ℂ) (q : SL(2, ℤ) ⧸ Γ) {θ : ℝ} (h1 : 0 < θ) (h2 : θ < Real.pi) :
+    tilePull φ (R (ModularGroup.S • q))⁻¹ (Complex.exp (↑(Real.pi - θ) * Complex.I)) =
+      tilePull (slash2 φ (pairElt R ModularGroup.S q)) (R q)⁻¹ (Complex.exp (θ * Complex.I)) *
+        Complex.exp (θ * Complex.I) ^ 2 := by
+  have := congrFun (slash2_tile_pair (R := R) φ ModularGroup.S q)
+    (ofComplex (Complex.exp (θ * Complex.I)))
+  change slash2 φ (R (ModularGroup.S • q))⁻¹ (ModularGroup.S • _) * D ModularGroup.S _ =
+    tilePull (slash2 φ (pairElt R ModularGroup.S q)) (R q)⁻¹ (Complex.exp (θ * Complex.I)) at this
+  rw [S_smul_arc h1 h2, ofComplex_apply_of_im_pos (exp_arc_im_pos h1 h2), coe_mk, D_S] at this
+  change tilePull φ (R (ModularGroup.S • q))⁻¹ (Complex.exp (↑(Real.pi - θ) * Complex.I)) * _ = _
+    at this
+  rw [← this]
+  have hne : Complex.exp (θ * Complex.I) ≠ 0 := Complex.exp_ne_zero _
+  field_simp
+
+theorem sum_integral_arc [Fintype (SL(2, ℤ) ⧸ Γ)] (φ : ℍ → ℂ) :
+    ∑ q : SL(2, ℤ) ⧸ Γ, ∫ θ in (Real.pi / 3)..(2 * Real.pi / 3),
+        tilePull φ (R q)⁻¹ (Complex.exp (θ * Complex.I)) *
+          (Complex.I * Complex.exp (θ * Complex.I)) =
+      -∑ q : SL(2, ℤ) ⧸ Γ, ∫ θ in (Real.pi / 3)..(2 * Real.pi / 3),
+        tilePull (slash2 φ (pairElt R ModularGroup.S q)) (R q)⁻¹ (Complex.exp (θ * Complex.I)) *
+          (Complex.I * Complex.exp (θ * Complex.I)) := by
+  rw [← sum_comp_smul ModularGroup.S, ← Finset.sum_neg_distrib]
+  refine Finset.sum_congr rfl fun q _ => ?_
+  have hrefl := intervalIntegral.integral_comp_sub_left
+    (fun θ : ℝ => tilePull φ (R (ModularGroup.S • q))⁻¹ (Complex.exp (θ * Complex.I)) *
+      (Complex.I * Complex.exp (θ * Complex.I)))
+    (a := Real.pi / 3) (b := 2 * Real.pi / 3) Real.pi
+  have e1 : Real.pi - 2 * Real.pi / 3 = Real.pi / 3 := by ring
+  have e2 : Real.pi - Real.pi / 3 = 2 * Real.pi / 3 := by ring
+  rw [e1, e2] at hrefl
+  rw [← hrefl, ← intervalIntegral.integral_neg]
+  refine intervalIntegral.integral_congr fun θ hθ => ?_
+  have hpi := Real.pi_pos
+  rw [Set.uIcc_of_le (by linarith)] at hθ
+  have h1 : 0 < θ := by linarith [hθ.1]
+  have h2 : θ < Real.pi := by linarith [hθ.2]
+  rw [tilePull_S_pt φ q h1 h2]
+  push_cast
+  rw [sub_mul, Complex.exp_sub, Complex.exp_pi_mul_I]
+  have hne : Complex.exp (θ * Complex.I) ≠ 0 := Complex.exp_ne_zero _
+  field_simp
+
+theorem tilePull_eq_div (φ : ℍ → ℂ) (σ : SL(2, ℤ)) (z : ℂ) :
+    tilePull φ σ z = φ (σ • ofComplex z) / denom (σ : GL (Fin 2) ℝ) (ofComplex z) ^ 2 := by
+  rw [tilePull, slash2, D, ← div_eq_mul_one_div]
+
+theorem tilePull_add_mul (φ ψ : ℍ → ℂ) (a : ℂ) (σ : SL(2, ℤ)) (z : ℂ) :
+    tilePull (fun w => φ w + a * ψ w) σ z = tilePull φ σ z + a * tilePull ψ σ z := by
+  simp only [tilePull, slash2]; ring
+
+theorem slash2_eq_of_twist {φ ψ : ℍ → ℂ} {c : SL(2, ℤ) → ℂ}
+    (hφ : ∀ γ ∈ Γ, ∀ τ : ℍ, φ (γ • τ) / denom (γ : GL (Fin 2) ℝ) τ ^ 2 = φ τ + c γ * ψ τ)
+    {γ : SL(2, ℤ)} (hγ : γ ∈ Γ) : slash2 φ γ = fun w => φ w + c γ * ψ w := by
+  funext w
+  rw [← hφ γ hγ w, slash2, D, ← div_eq_mul_one_div]
+
+end ModularCurve.GammaSidePairing
+
+open ModularCurve.GammaSidePairing in
+theorem solution
+    (Γ : Subgroup SL(2, ℤ)) [Fintype (SL(2, ℤ) ⧸ Γ)]
+    (φ ψ : ℍ → ℂ) (c : SL(2, ℤ) → ℂ)
+    (hφ : ∀ γ ∈ Γ, ∀ τ : ℍ,
+      φ (γ • τ) / denom (γ : GL (Fin 2) ℝ) τ ^ 2 = φ τ + c γ * ψ τ)
+    (Φ Ψ : SL(2, ℤ) → ℂ → ℂ)
+    (hΦ : ∀ (σ : SL(2, ℤ)) (z : ℂ),
+      Φ σ z = φ (σ • ofComplex z) / denom (σ : GL (Fin 2) ℝ) (ofComplex z) ^ 2)
+    (hΨ : ∀ (σ : SL(2, ℤ)) (z : ℂ),
+      Ψ σ z = ψ (σ • ofComplex z) / denom (σ : GL (Fin 2) ℝ) (ofComplex z) ^ 2)
+    (s : Set ℝ) (hs : MeasurableSet s) (hs0 : s ⊆ Set.Ioi 0)
+    (hΦs : ∀ q : SL(2, ℤ) ⧸ Γ,
+      IntegrableOn (fun y : ℝ => Φ (Quotient.out q)⁻¹ (-(1 / 2) + y * Complex.I)) s)
+    (hΨs : ∀ q : SL(2, ℤ) ⧸ Γ,
+      IntegrableOn (fun y : ℝ => Ψ (Quotient.out q)⁻¹ (-(1 / 2) + y * Complex.I)) s)
+    (hΦarc : ∀ q : SL(2, ℤ) ⧸ Γ, IntervalIntegrable (fun θ : ℝ =>
+      Φ (Quotient.out q)⁻¹ (Complex.exp (θ * Complex.I)) * (Complex.I * Complex.exp (θ *
+        Complex.I)))
+      volume (Real.pi / 3) (2 * Real.pi / 3))
+    (hΨarc : ∀ q : SL(2, ℤ) ⧸ Γ, IntervalIntegrable (fun θ : ℝ =>
+      Ψ (Quotient.out q)⁻¹ (Complex.exp (θ * Complex.I)) * (Complex.I * Complex.exp (θ *
+        Complex.I)))
+      volume (Real.pi / 3) (2 * Real.pi / 3)) :
+    (∑ q : SL(2, ℤ) ⧸ Γ, ∫ y in s, Φ (Quotient.out q)⁻¹ (1 / 2 + y * Complex.I)) =
+        (∑ q : SL(2, ℤ) ⧸ Γ, ∫ y in s, Φ (Quotient.out q)⁻¹ (-(1 / 2) + y * Complex.I)) +
+          ∑ q : SL(2, ℤ) ⧸ Γ,
+            c ((Quotient.out (ModularGroup.T • q))⁻¹ * ModularGroup.T * Quotient.out q) *
+              ∫ y in s, Ψ (Quotient.out q)⁻¹ (-(1 / 2) + y * Complex.I) ∧
+      2 * (∑ q : SL(2, ℤ) ⧸ Γ, ∫ θ in (Real.pi / 3)..(2 * Real.pi / 3),
+          Φ (Quotient.out q)⁻¹ (Complex.exp (θ * Complex.I)) *
+            (Complex.I * Complex.exp (θ * Complex.I))) =
+        -∑ q : SL(2, ℤ) ⧸ Γ,
+          c ((Quotient.out (ModularGroup.S • q))⁻¹ * ModularGroup.S * Quotient.out q) *
+            ∫ θ in (Real.pi / 3)..(2 * Real.pi / 3),
+              Ψ (Quotient.out q)⁻¹ (Complex.exp (θ * Complex.I)) *
+                (Complex.I * Complex.exp (θ * Complex.I)) := by
+  have eΦ : Φ = tilePull φ := by funext σ z; rw [hΦ, tilePull_eq_div]
+  have eΨ : Ψ = tilePull ψ := by funext σ z; rw [hΨ, tilePull_eq_div]
+  subst eΦ eΨ
+  have hsec := isSection_out Γ
+  have key : ∀ (g : SL(2, ℤ)) (q : SL(2, ℤ) ⧸ Γ) (z : ℂ),
+      tilePull (slash2 φ (pairElt Quotient.out g q)) (Quotient.out q)⁻¹ z =
+        tilePull φ (Quotient.out q)⁻¹ z + c (pairElt Quotient.out g q) * tilePull ψ (Quotient.out
+          q)⁻¹ z := by
+    intro g q z
+    rw [slash2_eq_of_twist hφ (pairElt_mem hsec g q), tilePull_add_mul]
+  refine ⟨?_, ?_⟩
+  · rw [sum_integral_rightRay (R := Quotient.out) φ hs hs0, ← Finset.sum_add_distrib]
+    refine Finset.sum_congr rfl fun q _ => ?_
+    simp_rw [key]
+    rw [integral_add (hΦs q) ((hΨs q).const_mul _), integral_const_mul]
+    rfl
+  · have harc := sum_integral_arc (R := Quotient.out) (Γ := Γ) φ
+    simp_rw [key, add_mul] at harc
+    have hsplit : ∀ q : SL(2, ℤ) ⧸ Γ,
+        ∫ θ in (Real.pi / 3)..(2 * Real.pi / 3),
+          (tilePull φ (Quotient.out q)⁻¹ (Complex.exp (θ * Complex.I)) *
+              (Complex.I * Complex.exp (θ * Complex.I)) +
+            c (pairElt Quotient.out ModularGroup.S q) *
+              tilePull ψ (Quotient.out q)⁻¹ (Complex.exp (θ * Complex.I)) *
+              (Complex.I * Complex.exp (θ * Complex.I))) =
+        (∫ θ in (Real.pi / 3)..(2 * Real.pi / 3),
+          tilePull φ (Quotient.out q)⁻¹ (Complex.exp (θ * Complex.I)) *
+              (Complex.I * Complex.exp (θ * Complex.I))) +
+          c (pairElt Quotient.out ModularGroup.S q) *
+            ∫ θ in (Real.pi / 3)..(2 * Real.pi / 3),
+              tilePull ψ (Quotient.out q)⁻¹ (Complex.exp (θ * Complex.I)) *
+                (Complex.I * Complex.exp (θ * Complex.I)) := by
+      intro q
+      have hΨ' : IntervalIntegrable (fun θ : ℝ => c (pairElt Quotient.out ModularGroup.S q) *
+          tilePull ψ (Quotient.out q)⁻¹ (Complex.exp (θ * Complex.I)) *
+            (Complex.I * Complex.exp (θ * Complex.I))) volume (Real.pi / 3) (2 * Real.pi / 3) := by
+        simp_rw [mul_assoc]; exact (hΨarc q).const_mul _
+      rw [intervalIntegral.integral_add (hΦarc q) hΨ', ← intervalIntegral.integral_const_mul]
+      simp_rw [mul_assoc]
+    simp_rw [hsplit, Finset.sum_add_distrib] at harc
+    change _ = -∑ q, c (pairElt Quotient.out ModularGroup.S q) * _
+    linear_combination harc
+
+end
+end S_ModularCurve_gammaFundamentalSet_boundary_sidePairing_of_slash_eq_add
+end P2MW
+export P2MW.S_ModularCurve_gammaFundamentalSet_boundary_sidePairing_of_slash_eq_add (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane MeasureTheory
+open scoped MatrixGroups
+theorem ModularCurve.gammaFundamentalSet_boundary_sidePairing_of_slash_eq_add
+    (Γ : Subgroup SL(2, ℤ)) [Fintype (SL(2, ℤ) ⧸ Γ)]
+    (φ ψ : ℍ → ℂ) (c : SL(2, ℤ) → ℂ)
+    (hφ : ∀ γ ∈ Γ, ∀ τ : ℍ,
+      φ (γ • τ) / denom (γ : GL (Fin 2) ℝ) τ ^ 2 = φ τ + c γ * ψ τ)
+    (Φ Ψ : SL(2, ℤ) → ℂ → ℂ)
+    (hΦ : ∀ (σ : SL(2, ℤ)) (z : ℂ),
+      Φ σ z = φ (σ • ofComplex z) / denom (σ : GL (Fin 2) ℝ) (ofComplex z) ^ 2)
+    (hΨ : ∀ (σ : SL(2, ℤ)) (z : ℂ),
+      Ψ σ z = ψ (σ • ofComplex z) / denom (σ : GL (Fin 2) ℝ) (ofComplex z) ^ 2)
+    (s : Set ℝ) (hs : MeasurableSet s) (hs0 : s ⊆ Set.Ioi 0)
+    (hΦs : ∀ q : SL(2, ℤ) ⧸ Γ,
+      IntegrableOn (fun y : ℝ => Φ (Quotient.out q)⁻¹ (-(1 / 2) + y * Complex.I)) s)
+    (hΨs : ∀ q : SL(2, ℤ) ⧸ Γ,
+      IntegrableOn (fun y : ℝ => Ψ (Quotient.out q)⁻¹ (-(1 / 2) + y * Complex.I)) s)
+    (hΦarc : ∀ q : SL(2, ℤ) ⧸ Γ, IntervalIntegrable (fun θ : ℝ =>
+      Φ (Quotient.out q)⁻¹ (Complex.exp (θ * Complex.I)) * (Complex.I * Complex.exp (θ *
+        Complex.I)))
+      volume (Real.pi / 3) (2 * Real.pi / 3))
+    (hΨarc : ∀ q : SL(2, ℤ) ⧸ Γ, IntervalIntegrable (fun θ : ℝ =>
+      Ψ (Quotient.out q)⁻¹ (Complex.exp (θ * Complex.I)) * (Complex.I * Complex.exp (θ *
+        Complex.I)))
+      volume (Real.pi / 3) (2 * Real.pi / 3)) :
+    (∑ q : SL(2, ℤ) ⧸ Γ, ∫ y in s, Φ (Quotient.out q)⁻¹ (1 / 2 + y * Complex.I)) =
+        (∑ q : SL(2, ℤ) ⧸ Γ, ∫ y in s, Φ (Quotient.out q)⁻¹ (-(1 / 2) + y * Complex.I)) +
+          ∑ q : SL(2, ℤ) ⧸ Γ,
+            c ((Quotient.out (ModularGroup.T • q))⁻¹ * ModularGroup.T * Quotient.out q) *
+              ∫ y in s, Ψ (Quotient.out q)⁻¹ (-(1 / 2) + y * Complex.I) ∧
+      2 * (∑ q : SL(2, ℤ) ⧸ Γ, ∫ θ in (Real.pi / 3)..(2 * Real.pi / 3),
+          Φ (Quotient.out q)⁻¹ (Complex.exp (θ * Complex.I)) *
+            (Complex.I * Complex.exp (θ * Complex.I))) =
+        -∑ q : SL(2, ℤ) ⧸ Γ,
+          c ((Quotient.out (ModularGroup.S • q))⁻¹ * ModularGroup.S * Quotient.out q) *
+            ∫ θ in (Real.pi / 3)..(2 * Real.pi / 3),
+              Ψ (Quotient.out q)⁻¹ (Complex.exp (θ * Complex.I)) *
+                (Complex.I * Complex.exp (θ * Complex.I)) :=
+  solution Γ φ ψ c hφ Φ Ψ hΦ hΨ s hs hs0 hΦs hΨs hΦarc hΨarc
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_genus_eq_genusFF_modularFunctionFieldBar.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_genus_eq_genusFF_modularFunctionFieldBar.lean
new file mode 100644
index 0000000000..ef0a777940
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_genus_eq_genusFF_modularFunctionFieldBar.lean
@@ -0,0 +1,162 @@
+/-
+Based on Prove2Me node ModularCurve.genus_eq_genusFF_modularFunctionFieldBar
+(34fcd940-c8db-50b2-83fd-2d1ae55dc024) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 40baa773-98d8-5ffe-bc71-0a9ed2a9a872
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_CanonicalDivisor
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Repartitions
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ArithmeticGalois
+
+import Mathlib.RingTheory.Finiteness.ModuleFinitePresentation
+import Mathlib.RingTheory.PicardGroup
+import Mathlib.RingTheory.TotallySplit
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_CanonicalLocalResidueInstanceV2
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JLinePlacesBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_constantsAreBase_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_dCoordGenerates_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_genus_eq_genusFF
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_instIsCurveOverRatFunc
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_weilDualityAdelic_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_essFiniteType_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_of_neZero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCurveOver_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Canonical-divisor genus equals adelic genus for X₀(N) over ℚ̄
+
+Theorem statement: `ModularCurve.genus_eq_genusFF_modularFunctionFieldBar`
+(`34fcd940-c8db-50b2-83fd-2d1ae55dc024`), by Claude, 2026-09-05.
+
+Proof: submission `40baa773-98d8-5ffe-bc71-0a9ed2a9a872`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $N$ with $N \neq 0$, and write $K = \overline{\mathbb{Q}}$ (the
+`AlgebraicClosure` of $\mathbb{Q}$) and $F =$ `modularFunctionFieldBar N`, the intermediate field of
+the Laurent series field $K(\!(q)\!)$ obtained by adjoining to $K$ the image under the coefficient
+embedding of `modularFunctionFieldFull N`, itself the subfield of $\mathbb{Q}(\!(q)\!)$ generated
+over $\mathbb{Q}$ by the divisor expansions `divisorExpansions N`. Assume the class
+`HasCanonicalDivisor` holds for this pair, i.e. for every nonzero Kähler differential $\omega \in
+\Omega[F/K]$ there is a finitely supported function $D$ on the places of $F/K$ (places being
+valuation subrings of $F$ containing $K$, proper in $F$, and principal ideal rings) with $D(v) =
+v.\mathrm{ordDifferential}\,\omega$, the valuation at $v$ of the differential coefficient of
+$\omega$, for every place $v$. Then the two genus invariants of $F/K$ coincide:
+[`AlgebraicCurve.genus`](def/AlgebraicCurve_CanonicalDivisor.html#L33), defined as $(\deg D + 2)/2$
+(truncated to $\mathbb{N}$) for the canonical divisor $D$ attached to some chosen nonzero
+differential, and $0$ if $\Omega[F/K]$ vanishes, equals
+[`AlgebraicCurve.genusFF`](def/AlgebraicCurve_Repartitions.html#L145), the $K$-dimension of $H^1$ of
+the zero divisor.
+
+The degree-theoretic genus of the modular function field of level $N$ over $\overline{\mathbb{Q}}$,
+computed from a canonical divisor, agrees with its adelic (repartition-cohomological) genus. This
+identification is used throughout the genus computations for modular curves, for instance in
+bounding dimensions of spaces of cusp forms for $\Gamma_0(N)$ and in the level-$N$ full-level genus
+comparisons.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_genus_eq_genusFF_modularFunctionFieldBar.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_genus_eq_genusFF_modularFunctionFieldBar
+
+
+open ModularCurve AlgebraicCurve IntermediateField
+
+attribute [local instance] ModularCurve.instDecidableEqRatFuncAlgebraicClosure
+
+theorem solution (N : ℕ) [NeZero N]
+    [AlgebraicCurve.HasCanonicalDivisor (K := AlgebraicClosure ℚ) (F :=
+      ↥(ModularCurve.modularFunctionFieldBar N))] :
+    AlgebraicCurve.genus (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar N)
+      = AlgebraicCurve.genusFF (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar N) := by
+  have : IsCurveOver (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+    isCurveOver_modularFunctionFieldBar N
+  have : HasPrincipalDivisors (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+    IsCurveOver.hasPrincipalDivisors
+  have : Algebra.EssFiniteType (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+    essFiniteType_modularFunctionFieldBar N
+  have hDCG : ∀ w : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N), w.DCoordGenerates :=
+    AlgebraicCurve.dCoordGenerates_of_isCurveOver
+  let algRE : Algebra (RatFunc (AlgebraicClosure ℚ)) ↥(jLineBar N) :=
+    (jLineBarRingEquiv N).toRingHom.toAlgebra
+  let algRF : Algebra (RatFunc (AlgebraicClosure ℚ)) ↥(modularFunctionFieldBar N) :=
+    ((algebraMap ↥(jLineBar N) ↥(modularFunctionFieldBar N)).comp (jLineBarRingEquiv
+      N).toRingHom).toAlgebra
+  have : IsScalarTower (RatFunc (AlgebraicClosure ℚ)) ↥(jLineBar N) ↥(modularFunctionFieldBar N) :=
+    IsScalarTower.of_algebraMap_eq (fun _ => rfl)
+  have : IsScalarTower (AlgebraicClosure ℚ) (RatFunc (AlgebraicClosure ℚ)) ↥(modularFunctionFieldBar
+    N) :=
+    by
+    refine IsScalarTower.of_algebraMap_eq (fun a => ?_)
+    change algebraMap _ _ a = algebraMap ↥(jLineBar N) ↥(modularFunctionFieldBar N)
+      (jLineBarRingEquiv N (algebraMap _ _ a))
+    rw [jLineBarRingEquiv_algebraMap]
+    rfl
+  have : Module.Finite (RatFunc (AlgebraicClosure ℚ)) ↥(jLineBar N) :=
+    Module.Finite.of_surjective (Algebra.linearMap (RatFunc (AlgebraicClosure ℚ)) ↥(jLineBar N))
+      (jLineBarRingEquiv N).surjective
+  have : FiniteDimensional ↥(jLineBar N) ↥(modularFunctionFieldBar N) :=
+    finiteDimensional_adjoin_coeffEmb_jq_of_neZero N
+  have hfinRF : Module.Finite (RatFunc (AlgebraicClosure ℚ)) ↥(modularFunctionFieldBar N) :=
+    Module.Finite.trans ↥(jLineBar N) ↥(modularFunctionFieldBar N)
+  have : Algebra.IsIntegral (RatFunc (AlgebraicClosure ℚ)) ↥(modularFunctionFieldBar N) :=
+    Algebra.IsIntegral.of_finite _ _
+  have : CharZero ↥(modularFunctionFieldBar N) :=
+    charZero_of_injective_algebraMap (algebraMap (AlgebraicClosure ℚ) _).injective
+  have : PerfectField (RatFunc (AlgebraicClosure ℚ)) := PerfectField.ofCharZero
+  have : Algebra.IsSeparable (RatFunc (AlgebraicClosure ℚ)) ↥(modularFunctionFieldBar N) :=
+    Algebra.IsSeparable.of_integral _ _
+  have : IsCurveOver (AlgebraicClosure ℚ) (RatFunc (AlgebraicClosure ℚ)) :=
+    AlgebraicCurve.instIsCurveOverRatFunc (AlgebraicClosure ℚ)
+  have : Algebra.EssFiniteType (Polynomial (AlgebraicClosure ℚ)) (RatFunc (AlgebraicClosure ℚ)) :=
+    Algebra.EssFiniteType.of_isLocalization _ (nonZeroDivisors (Polynomial (AlgebraicClosure ℚ)))
+  have : Algebra.EssFiniteType (AlgebraicClosure ℚ) (RatFunc (AlgebraicClosure ℚ)) :=
+    Algebra.EssFiniteType.comp (AlgebraicClosure ℚ) (Polynomial (AlgebraicClosure ℚ)) (RatFunc
+      (AlgebraicClosure ℚ))
+  have hDCGR : ∀ v : Place (AlgebraicClosure ℚ) (RatFunc (AlgebraicClosure ℚ)), v.DCoordGenerates :=
+    AlgebraicCurve.dCoordGenerates_of_isCurveOver
+  have : HasCanonicalLocalResidueKStar (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+    inferInstance
+  have : HasSeparableResidue (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) := inferInstance
+  have hRR : FunctionFieldRiemannRoch (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+    AlgebraicCurve.functionFieldRiemannRoch_of_isAlgClosed
+  have hWDA : WeilDualityAdelic (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+    AlgebraicCurve.weilDualityAdelic_of_isAlgClosed
+  have hC : ConstantsAreBase (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+    AlgebraicCurve.constantsAreBase_of_isAlgClosed _ _
+  exact AlgebraicCurve.genus_eq_genusFF hRR hWDA hC
+
+end S_ModularCurve_genus_eq_genusFF_modularFunctionFieldBar
+end P2MW
+export P2MW.S_ModularCurve_genus_eq_genusFF_modularFunctionFieldBar (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.genus_eq_genusFF_modularFunctionFieldBar (N : ℕ) [NeZero N]
+    [AlgebraicCurve.HasCanonicalDivisor (K := AlgebraicClosure ℚ) (F :=
+      ↥(ModularCurve.modularFunctionFieldBar N))] :
+    AlgebraicCurve.genus (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar N)
+      = AlgebraicCurve.genusFF (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar N) :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_genus_modularFunctionFieldBar_eq_genusFormula.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_genus_modularFunctionFieldBar_eq_genusFormula.lean
new file mode 100644
index 0000000000..834fbfb724
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_genus_modularFunctionFieldBar_eq_genusFormula.lean
@@ -0,0 +1,306 @@
+/-
+Based on Prove2Me node ModularCurve.genus_modularFunctionFieldBar_eq_genusFormula
+(db11f309-8d92-554c-9c92-76fbdde0c34f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1e0413be-2860-50e9-8736-e2fdfd92fd40
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_CanonicalDivisor
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ArithmeticGalois
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Rat.Star
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ordDiff_D_eq_ord_sub_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ordDiff_eq_ordDifferential
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_twelve_mul_eq_of_sum_ordDiff_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_KaehlerDifferential_D_ne_zero_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_card_eq_cuspCount_of_forall_mem_iff_ord_jBar_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_card_eq_natCard_moduliPoint_j_eq_of_EMD
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_deg_eq_one_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_degree_canonicalDivisorOf_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_emd_holds
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_essFiniteType_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_of_neZero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCurveOver_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jCoordinate_spec_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_ord_jBar_eq_one_eq_nuThree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_jBar_dvd_three
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_jBar_sub_1728_dvd_two
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_jBar_sub_eq_one_of_ne_zero_of_ne
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_sum_neg_ord_jBar_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_sum_ord_jBar_sub_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Genus of the modular function field equals 1+ψ/12-ν₂/4-ν₃/3-c_∞/2
+
+Theorem statement: `ModularCurve.genus_modularFunctionFieldBar_eq_genusFormula`
+(`db11f309-8d92-554c-9c92-76fbdde0c34f`), by Claude, 2026-09-05.
+
+Proof: submission `1e0413be-2860-50e9-8736-e2fdfd92fd40`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and let $F_N$ denote the field
+[`ModularCurve.modularFunctionFieldBar N`](def/ModularCurve_ArithmeticGalois.html#L111), that is the
+intermediate field of $\overline{\mathbb Q}((q))$ generated over $K = \overline{\mathbb Q} =$
+`AlgebraicClosure ℚ` by the image, under the coefficient embedding of $\mathbb Q((q))$ into
+$\overline{\mathbb Q}((q))$, of the field `modularFunctionFieldFull N` obtained by adjoining to
+$\mathbb Q$ inside $\mathbb Q((q))$ the family `divisorExpansions N`. Assume `HasCanonicalDivisor`
+for the extension $K \subseteq F_N$: for every nonzero Kähler differential $\omega \in
+\Omega_{F_N/K}$ the function $v \mapsto v.\mathrm{ordDifferential}\,\omega$ on the places of $F_N$
+over $K$ is finitely supported, hence is a divisor. Then the natural number
+[`AlgebraicCurve.genus`](def/AlgebraicCurve_CanonicalDivisor.html#L33) of $K \subseteq F_N$ —
+computed as $(\deg D + 2).\mathrm{toNat}$ divided by $2$ in $\mathbb N$, for $D$ the canonical
+divisor attached to some nonzero differential, and $0$ if none exists — equals, after casting to
+$\mathbb Q$, the rational number $$1 + \frac{\psi(N)}{12} - \frac{\nu_2(N)}{4} - \frac{\nu_3(N)}{3}
+- \frac{c_\infty(N)}{2},$$ where $\psi(N) = \sum_{d \mid N,\ d \text{ squarefree}} N/d$, $\nu_2(N) =
+\#\{x \in \mathbb Z/N : x^2+1 = 0\}$, $\nu_3(N) = \#\{x \in \mathbb Z/N : x^2+x+1 = 0\}$ and
+$c_\infty(N) = \sum_{d \mid N} \varphi(\gcd(d, N/d))$. In particular this rational number is a
+nonnegative integer.
+
+This is the classical genus formula for the modular curve $X_0(N)$, here expressed through the
+divisor-theoretic genus of its function field over $\overline{\mathbb Q}$, with $\psi(N) =
+[\mathrm{SL}_2(\mathbb Z):\Gamma_0(N)]$, $\nu_2$ and $\nu_3$ counting elliptic points of orders $2$
+and $3$, and $c_\infty$ the number of cusps. It feeds the comparison between the genus and the
+dimension of the space of weight-two cusp forms for $\Gamma_0(N)$, used in
+[`CuspForm.dimFormula_le_finrank_gamma0`](thm.html#CuspForm.dimFormula_le_finrank_gamma0) and
+[`CuspForm.genusFormula_le_finrank_gamma0_weight_two`]
+(thm.html#CuspForm.genusFormula_le_finrank_gamma0_weight_two).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_genus_modularFunctionFieldBar_eq_genusFormula.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 6400000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_genus_modularFunctionFieldBar_eq_genusFormula
+
+
+open ModularCurve AlgebraicCurve IntermediateField
+
+theorem solution (N : ℕ) [NeZero N]
+    [AlgebraicCurve.HasCanonicalDivisor (K := AlgebraicClosure ℚ) (F :=
+      ↥(ModularCurve.modularFunctionFieldBar N))] :
+    (AlgebraicCurve.genus (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar N) : ℚ)
+      = ModularCurve.genusFormula N := by
+  classical
+  set F := ↥(modularFunctionFieldBar N) with hF
+  set j : ↥(modularFunctionFieldBar N) := jBar N with hj
+  have hjdef : j = (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+      coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+        ↥(modularFunctionFieldBar N)) := rfl
+  have h1728 : (j - 1728 : ↥(modularFunctionFieldBar N))
+      = j - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) 1728 := by
+    rw [map_ofNat]
+  have : CharZero ↥(modularFunctionFieldBar N) :=
+    charZero_of_injective_algebraMap (algebraMap (AlgebraicClosure ℚ) _).injective
+  have : IsCurveOver (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+    isCurveOver_modularFunctionFieldBar N
+  have : HasPrincipalDivisors (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+    IsCurveOver.hasPrincipalDivisors
+  have : Algebra.EssFiniteType (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+    essFiniteType_modularFunctionFieldBar N
+  have hfd : FiniteDimensional ↥(IntermediateField.adjoin (AlgebraicClosure ℚ) ({j} : Set
+    ↥(modularFunctionFieldBar N)))
+      ↥(modularFunctionFieldBar N) := finiteDimensional_adjoin_coeffEmb_jq_of_neZero N
+  have : CharZero ↥(IntermediateField.adjoin (AlgebraicClosure ℚ) ({j} : Set
+    ↥(modularFunctionFieldBar N))) :=
+    charZero_of_injective_algebraMap (algebraMap (AlgebraicClosure ℚ) _).injective
+  have : PerfectField ↥(IntermediateField.adjoin (AlgebraicClosure ℚ) ({j} : Set
+    ↥(modularFunctionFieldBar N))) :=
+    PerfectField.ofCharZero
+  have : Algebra.IsIntegral ↥(IntermediateField.adjoin (AlgebraicClosure ℚ) ({j} : Set
+    ↥(modularFunctionFieldBar N)))
+      ↥(modularFunctionFieldBar N) := Algebra.IsIntegral.of_finite _ _
+  have : Algebra.IsSeparable ↥(IntermediateField.adjoin (AlgebraicClosure ℚ) ({j} : Set
+    ↥(modularFunctionFieldBar N)))
+      ↥(modularFunctionFieldBar N) := Algebra.IsSeparable.of_integral _ _
+  have htr : Transcendental (AlgebraicClosure ℚ) j :=
+    transcendental_coeffEmb_jq (AlgebraicClosure ℚ) N
+  have hdeg : ∀ w : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N), w.deg = 1 :=
+    deg_eq_one_modularFunctionFieldBar N
+  obtain ⟨hval, hfinc, hfinI⟩ := jCoordinate_spec_modularFunctionFieldBar N
+  set S0 : Finset (Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)) := (hfinc 0).toFinset
+    with hS0def
+  set S1 : Finset (Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)) := (hfinc 1728).toFinset
+    with hS1def
+  set Sinf : Finset (Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)) := hfinI.toFinset with
+    hSIdef
+  have hS0 : ∀ v, v ∈ S0 ↔ 0 < v.ord j := fun v => by
+    rw [hS0def, Set.Finite.mem_toFinset, Set.mem_ofPred_eq, map_zero, sub_zero]
+  have hS1 : ∀ v, v ∈ S1 ↔ 0 < v.ord (j - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar
+    N) 1728) :=
+    fun v => by rw [hS1def, Set.Finite.mem_toFinset, Set.mem_ofPred_eq]
+  have hSI : ∀ v, v ∈ Sinf ↔ v.ord j < 0 := fun v => by
+    rw [hSIdef, Set.Finite.mem_toFinset, Set.mem_ofPred_eq]
+  have hDj1728 : KaehlerDifferential.D (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) j
+      = KaehlerDifferential.D (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)
+          (j - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) 1728) := by
+    rw [map_sub, Derivation.map_algebraMap, sub_zero]
+  have h₀ : ∀ v ∈ S0, v.ordDiff (KaehlerDifferential.D (AlgebraicClosure ℚ)
+    ↥(modularFunctionFieldBar N) j) = v.ord j - 1
+      ∧ 0 < v.ord j ∧ v.ord j ∣ 3 := fun v hv => by
+    have hpos := (hS0 v).1 hv
+    exact ⟨AlgebraicCurve.Place.ordDiff_D_eq_ord_sub_one j v hpos.ne', hpos, ord_jBar_dvd_three N v
+      hpos⟩
+  have h₁ : ∀ v ∈ S1,
+      v.ordDiff (KaehlerDifferential.D (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) j)
+        = v.ord (j - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) 1728) - 1
+      ∧ 0 < v.ord (j - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) 1728)
+      ∧ v.ord (j - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) 1728) ∣ 2 := fun v
+        hv => by
+    have hpos := (hS1 v).1 hv
+    refine ⟨?_, hpos, ord_jBar_sub_1728_dvd_two N v hpos⟩
+    rw [hDj1728]
+    exact AlgebraicCurve.Place.ordDiff_D_eq_ord_sub_one j v hpos.ne'
+  have hinf : ∀ v ∈ Sinf, v.ordDiff (KaehlerDifferential.D (AlgebraicClosure ℚ)
+    ↥(modularFunctionFieldBar N) j) = v.ord j - 1
+      ∧ v.ord j < 0 := fun v hv => by
+    have hneg := (hSI v).1 hv
+    exact ⟨AlgebraicCurve.Place.ordDiff_D_eq_ord_sub_one j v hneg.ne, hneg⟩
+  have hψ₀ : ∑ v ∈ S0, v.ord j = (dedekindPsi N : ℤ) := by
+    have h := sum_ord_jBar_sub_eq_dedekindPsi N 0 hdeg S0 (fun v => by rw [hS0, map_zero, sub_zero])
+    simpa [map_zero, sub_zero] using h
+  have hψ₁ : ∑ v ∈ S1, v.ord (j - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) 1728)
+    = (dedekindPsi N : ℤ) :=
+    sum_ord_jBar_sub_eq_dedekindPsi N 1728 hdeg S1 hS1
+  have hψinf : ∑ v ∈ Sinf, -v.ord j = (dedekindPsi N : ℤ) :=
+    sum_neg_ord_jBar_eq_dedekindPsi N Sinf hSI
+  set S := S0 ∪ S1 ∪ Sinf with hSdef
+  have hS : ∀ v, v ∈ S ↔ v ∈ S0 ∨ v ∈ S1 ∨ v ∈ Sinf := fun v => by
+    simp only [hSdef, Finset.mem_union, or_assoc]
+  have hDj : KaehlerDifferential.D (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) j ≠ 0 :=
+    KaehlerDifferential.D_ne_zero_of_transcendental (AlgebraicClosure ℚ) j htr
+  have hoff : ∀ v, v ∉ S → v.ordDiff (KaehlerDifferential.D (AlgebraicClosure ℚ)
+    ↥(modularFunctionFieldBar N) j) = 0 :=
+    by
+    intro v hv
+    rw [hS] at hv
+    push Not at hv
+    obtain ⟨hv0, hv1, hvI⟩ := hv
+    have hnonneg : 0 ≤ v.ord j := by
+      by_contra h
+      exact hvI ((hSI v).2 (lt_of_not_ge h))
+    obtain ⟨c, hcpos, -⟩ := hval v hnonneg
+    have hc0 : c ≠ 0 := by
+      rintro rfl
+      apply hv0
+      rw [hS0]
+      simpa [map_zero, sub_zero] using hcpos
+    have hc1728 : c ≠ 1728 := by
+      rintro rfl
+      exact hv1 ((hS1 v).2 hcpos)
+    have hone := ord_jBar_sub_eq_one_of_ne_zero_of_ne N v c hc0 hc1728 hcpos
+    have hD : KaehlerDifferential.D (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) j
+        = KaehlerDifferential.D (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)
+            (j - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) c) := by
+      rw [map_sub, Derivation.map_algebraMap, sub_zero]
+    rw [hD, AlgebraicCurve.Place.ordDiff_D_eq_ord_sub_one j v (by
+      rw [hone]; exact one_ne_zero), hone]
+    norm_num
+  have hcan : ∑ v ∈ S, v.ordDiff (KaehlerDifferential.D (AlgebraicClosure ℚ)
+    ↥(modularFunctionFieldBar N) j)
+      = 2 * (genus (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) : ℤ) - 2 := by
+    rw [← degree_canonicalDivisorOf_modularFunctionFieldBar N hDj]
+    set Kd := canonicalDivisorOf hDj with hKd
+    have hseam : ∀ v : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N),
+        v.ordDiff (KaehlerDifferential.D (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) j) = Kd v
+          := fun v => by
+      rw [hKd, canonicalDivisorOf_apply, AlgebraicCurve.Place.ordDiff_eq_ordDifferential]
+    have hsupp : Kd.support ⊆ S := by
+      intro v hv
+      by_contra hvS
+      rw [Finsupp.mem_support_iff] at hv
+      exact hv ((hseam v).symm.trans (hoff v hvS))
+    have hdegsum : Divisor.degree Kd = ∑ v ∈ Kd.support, Kd v := by
+      rw [Divisor.degree, Finsupp.liftAddHom_apply, Finsupp.sum]
+      refine Finset.sum_congr rfl (fun v _ => ?_)
+      rw [AddMonoidHom.mulRight_apply, hdeg v, Nat.cast_one, mul_one]
+    rw [hdegsum, Finset.sum_subset hsupp (fun v _ hv => by
+      simpa [Finsupp.mem_support_iff] using hv)]
+    exact Finset.sum_congr rfl (fun v _ => hseam v)
+  have hHE := AlgebraicCurve.twelve_mul_eq_of_sum_ordDiff_eq j S0 S1 Sinf (dedekindPsi N)
+    (genus (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) : ℤ) h₀ h₁ hinf hψ₀ hψ₁ hψinf S hS hcan
+  have hNC : ∀ (P : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) → Prop)
+      (T : Finset (Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N))),
+      (∀ v, v ∈ T ↔ P v) → Nat.card {v // P v} = T.card := by
+    intro P T hT
+    rw [Nat.card_congr (Equiv.subtypeEquivRight (fun v => (hT v).symm) : {v // P v} ≃ {v // v ∈ T}),
+      Nat.card_eq_fintype_card, Fintype.card_coe]
+  have hε₂ : (S1.filter fun v => v.ord (j - algebraMap (AlgebraicClosure ℚ)
+    ↥(modularFunctionFieldBar N) 1728) = 1).card
+      = nuTwo N := by
+    have h2 : ∀ v : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N),
+        0 < v.ord (jBar N - 1728) → v.ord (jBar N - 1728) ∣ 2 := fun v hv => by
+      rw [← hj, h1728] at hv ⊢
+      exact ord_jBar_sub_1728_dvd_two N v hv
+    have hcount : Nat.card {v : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) // 0 < v.ord
+      (jBar N - 1728)}
+        = Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) // ModuliPoint.j x = (1728 :
+          AlgebraicClosure ℚ)} := by
+      rw [← card_eq_natCard_moduliPoint_j_eq_of_EMD N 1728 (emd_holds N 1728) S1 hS1]
+      exact hNC _ S1 (fun v => by rw [hS1, ← hj, h1728])
+    have h := natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo N h2 hcount
+    rwa [hNC _ (S1.filter fun v => v.ord (j - algebraMap (AlgebraicClosure ℚ)
+      ↥(modularFunctionFieldBar N) 1728) = 1)
+      (fun v => by
+        rw [Finset.mem_filter, hS1, ← hj, h1728]
+        exact ⟨fun hv => hv.2, fun hv => ⟨by rw [hv]; exact one_pos, hv⟩⟩)] at h
+  have hε₃ : (S0.filter fun v => v.ord j = 1).card = nuThree N := by
+    have h3 : ∀ v : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N),
+        0 < v.ord (jBar N) → v.ord (jBar N) ∣ 3 := fun v hv => ord_jBar_dvd_three N v hv
+    have hcount : Nat.card {v : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) // 0 < v.ord
+      (jBar N)}
+        = Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) // ModuliPoint.j x = (0 :
+          AlgebraicClosure ℚ)} := by
+      rw [← card_eq_natCard_moduliPoint_j_eq_of_EMD N 0 (emd_holds N 0) S0 (fun v => by rw [hS0, hj,
+        map_zero, sub_zero])]
+      exact hNC _ S0 (fun v => by rw [hS0, hj])
+    have h := natCard_ord_jBar_eq_one_eq_nuThree N h3 hcount
+    rwa [hNC _ (S0.filter fun v => v.ord j = 1)
+      (fun v => by
+        rw [Finset.mem_filter, hS0, hj]
+        exact ⟨fun hv => hv.2, fun hv => ⟨by rw [hv]; exact one_pos, hv⟩⟩)] at h
+  have hcard : Sinf.card = cuspCount N :=
+    card_eq_cuspCount_of_forall_mem_iff_ord_jBar_neg N Sinf hSI
+  rw [hε₂, hε₃, hcard] at hHE
+  have key : (12 : ℚ) * (genus (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) : ℚ)
+      = 12 + (dedekindPsi N : ℚ) - 3 * (nuTwo N : ℚ) - 4 * (nuThree N : ℚ) - 6 * (cuspCount N : ℚ)
+        := by
+    exact_mod_cast hHE
+  unfold genusFormula
+  linarith [key]
+
+end S_ModularCurve_genus_modularFunctionFieldBar_eq_genusFormula
+end P2MW
+export P2MW.S_ModularCurve_genus_modularFunctionFieldBar_eq_genusFormula (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.genus_modularFunctionFieldBar_eq_genusFormula (N : ℕ) [NeZero N]
+    [AlgebraicCurve.HasCanonicalDivisor (K := AlgebraicClosure ℚ) (F :=
+      ↥(ModularCurve.modularFunctionFieldBar N))] :
+    (AlgebraicCurve.genus (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar N) : ℚ)
+      = ModularCurve.genusFormula N :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasCanonicalDivisor_modularFunctionFieldBar.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasCanonicalDivisor_modularFunctionFieldBar.lean
new file mode 100644
index 0000000000..4c75ad1d6a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasCanonicalDivisor_modularFunctionFieldBar.lean
@@ -0,0 +1,91 @@
+/-
+Based on Prove2Me node ModularCurve.hasCanonicalDivisor_modularFunctionFieldBar
+(5847be70-ca4e-52d8-a56f-ec77557f05a0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 02e086bc-d823-5e1c-b86b-47fa70c19ae6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_CanonicalDivisor
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ArithmeticGalois
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_hasCanonicalDivisor_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_essFiniteType_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCurveOver_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Canonical divisors exist for X₀(N) over ℚ̄
+
+Theorem statement: `ModularCurve.hasCanonicalDivisor_modularFunctionFieldBar`
+(`5847be70-ca4e-52d8-a56f-ec77557f05a0`), by Claude, 2026-09-05.
+
+Proof: submission `02e086bc-d823-5e1c-b86b-47fa70c19ae6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, assumed nonzero, and let $K = \overline{\mathbb Q}$ be the algebraic
+closure of $\mathbb Q$. Let $F =$ `modularFunctionFieldBar N` be the intermediate field of $K((t))$
+over $K$ obtained as `laurentBaseChange`, i.e. the subfield of the Laurent series field over $K$
+generated over $K$ by the image, under the coefficientwise embedding `coeffEmb` of $\mathbb Q((t))$
+into $K((t))$, of `modularFunctionFieldFull N`, which is itself the subfield of $\mathbb{Q}((t))$
+generated over $\mathbb Q$ by the family `divisorExpansions N`. The assertion is the class
+`HasCanonicalDivisor` for this pair $(K, F)$: for every Kähler differential $\omega \in
+\Omega_{F/K}$ with $\omega \neq 0$ there is a divisor $D$, that is, a finitely supported function
+from the places of $F$ over $K$ to $\mathbb Z$, such that $D(v) =
+v.\mathrm{ordDifferential}\,\omega$ for every place $v$, where $\mathrm{ordDifferential}\,\omega$ is
+the order $v.\mathrm{ord}$ of the coefficient $v.\mathrm{differentialCoeff}\,\omega$. Here a `Place`
+of $F$ over $K$ is a valuation subring of $F$ containing the image of $K$, different from $F$
+itself, and whose underlying ring is a principal ideal ring. Since the defining equation determines
+$D$ pointwise, the content of the statement is that $v \mapsto v.\mathrm{ordDifferential}\,\omega$
+has finite support.
+
+This is the existence of the canonical divisor $(\omega)$ of a nonzero differential on a
+one-variable function field, specialised to the function field of $X_0(N)$ over $\overline{\mathbb
+Q}$. It is the hypothesis under which the genus of this function field (through $\deg(\omega) =
+2g-2$) and the associated Riemann–Roch machinery are available, and it is used by the genus
+computations for $X_0(N)$ and by the dimension bounds for spaces of cusp forms of weight two.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_hasCanonicalDivisor_modularFunctionFieldBar.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_hasCanonicalDivisor_modularFunctionFieldBar
+
+
+open AlgebraicCurve ModularCurve
+
+theorem solution (N : ℕ) [NeZero N] :
+    HasCanonicalDivisor (K := AlgebraicClosure ℚ) (F := modularFunctionFieldBar N) := by
+  have := ModularCurve.isCurveOver_modularFunctionFieldBar N
+  have := ModularCurve.essFiniteType_modularFunctionFieldBar N
+  exact AlgebraicCurve.hasCanonicalDivisor_of_isCurveOver
+
+end S_ModularCurve_hasCanonicalDivisor_modularFunctionFieldBar
+end P2MW
+export P2MW.S_ModularCurve_hasCanonicalDivisor_modularFunctionFieldBar (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve ModularCurve
+theorem ModularCurve.hasCanonicalDivisor_modularFunctionFieldBar (N : ℕ) [NeZero N] :
+    HasCanonicalDivisor (K := AlgebraicClosure ℚ) (F := modularFunctionFieldBar N) :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull.lean
new file mode 100644
index 0000000000..5722deacc5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull.lean
@@ -0,0 +1,144 @@
+/-
+Based on Prove2Me node ModularCurve.hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull
+(8ebe6701-822e-59da-ada6-f1e842929172) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4482b742-e52e-5fc5-a0f0-53e2ebb1b589
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ArithmeticGalois
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_hasPrincipalDivisors_adjoin_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_jqNModC_all_of_modularPolynomialFamily
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_modularFunctionFieldFull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Principal divisors on the level-N modular function field over L
+
+Theorem statement: `ModularCurve.hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull`
+(`8ebe6701-822e-59da-ada6-f1e842929172`), by Claude, 2026-09-05.
+
+Proof: submission `4482b742-e52e-5fc5-a0f0-53e2ebb1b589`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbb{Q}$-algebra structure, let $N \geq 1$ be a natural
+number, and assume `ModularPolynomialFamily`: for every prime $\ell$ there is a
+`ModularPolynomialData` $\ell$, that is a monic $\Phi \in \mathbb{Z}[X][Y]$ with $\Phi$ of degree
+`dedekindPsi` $\ell$ in its outer variable and $\Phi$ vanishing at `evalAtJ` and `jqN` $\ell$, whose
+$\Phi$ in addition satisfies `EvalSymm`, i.e. for all Laurent series $x, y$ over $\mathbb{Q}$ the
+two evaluations $\Phi(x,y)$ and $\Phi(y,x)$ obtained by substituting into inner and outer variable
+agree. Consider the intermediate field `laurentBaseChange L (modularFunctionFieldFull N)`: the
+$L$-subfield of $L((q))$ generated by the image, under the coefficientwise map induced by
+$\mathbb{Q} \to L$, of the $\mathbb{Q}$-subfield of $\mathbb{Q}((q))$ generated by the expansions
+$\mathrm{qExpand}\,\mathbb{Q}\,d\,(jq)$ for the nonzero divisors $d$ of $N$. The conclusion is that
+this field $F$ has `HasPrincipalDivisors` over $L$: for every $f \in F$ with $f \neq 0$ there is a
+finitely supported function $D$ from the places of $F/L$ (valuation subrings of $F$ containing the
+image of $L$, distinct from $F$ itself, and principal ideal rings) to $\mathbb{Z}$ with $D(v) =
+v.\mathrm{ord}(f)$ at every place $v$ and with $\sum_v D(v)\,\deg(v) = 0$.
+
+This is the statement that a nonzero function in the function field of $X_0(N)$ over $L$, realised
+through $q$-expansions, has a divisor of degree zero, with only finitely many zeros and poles. It
+supplies the principal-divisors hypothesis required by the divisor class group of this field, and is
+used by the unconditional form of the same assertion and by the corresponding statement for
+`modularFunctionFieldBar`.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull
+
+noncomputable section
+open IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "modularFunctionFieldFull laurentBaseChange jqModC jqNModC jqNModC_one \
+  ModularPolynomialFamily isIntegral_jqNModC_all_of_modularPolynomialFamily \
+  laurentBaseChange_modularFunctionFieldFull transcendental_jqModC"
+p2m_open "ModularCurve"
+namespace R8
+
+def gens (L : Type*) [Field L] (N : ℕ) : Finset (LaurentSeries L) := by
+  classical
+  exact Finset.univ.image fun d : {d // d ∈ N.divisors} =>
+    @jqNModC L _ d.1 ⟨Nat.ne_of_gt (Nat.pos_of_mem_divisors d.2)⟩
+
+theorem mem_gens_iff (L : Type*) [Field L] (N : ℕ) [NeZero N] (x : LaurentSeries L) :
+    x ∈ gens L N ↔ ∃ (d : ℕ) (_ : NeZero d), d ∣ N ∧ x = jqNModC L d := by
+  classical
+  unfold gens
+  constructor
+  · intro hx
+    obtain ⟨d, -, rfl⟩ := Finset.mem_image.mp hx
+    exact ⟨d.1, ⟨Nat.ne_of_gt (Nat.pos_of_mem_divisors d.2)⟩, Nat.dvd_of_mem_divisors d.2, rfl⟩
+  · rintro ⟨d, hd, hdN, rfl⟩
+    exact Finset.mem_image.mpr ⟨⟨d, Nat.mem_divisors.mpr ⟨hdN, NeZero.ne N⟩⟩, Finset.mem_univ _,
+      rfl⟩
+
+theorem insert_gens (L : Type*) [Field L] (N : ℕ) [NeZero N] :
+    insert (jqModC L) (gens L N : Set (LaurentSeries L)) = {x | ∃ (d : ℕ) (_ : NeZero d), d ∣ N ∧ x
+      = jqNModC L d} := by
+  ext x
+  simp only [Set.mem_insert_iff, Finset.mem_coe, mem_gens_iff, Set.mem_ofPred_eq]
+  constructor
+  · rintro (rfl | h)
+    · exact ⟨1, inferInstance, one_dvd N, (jqNModC_one L).symm⟩
+    · exact h
+  · exact Or.inr
+
+end R8
+end ModularCurve
+
+p2m_open "ModularCurve \
+  P2MW.S_ModularCurve_hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull.ModularCurve \
+  AlgebraicCurve"
+
+theorem solution (L : Type*) [Field L] [Algebra ℚ L]
+    (hΦ : ModularPolynomialFamily) (N : ℕ) [NeZero N] :
+    HasPrincipalDivisors L (laurentBaseChange L (modularFunctionFieldFull N)) := by
+  have : CharZero L := charZero_of_injective_algebraMap (algebraMap ℚ L).injective
+  rw [laurentBaseChange_modularFunctionFieldFull, ← ModularCurve.R8.insert_gens]
+  refine AlgebraicCurve.hasPrincipalDivisors_adjoin_of_transcendental L (jqModC L)
+    (transcendental_jqModC L)
+    (ModularCurve.R8.gens L N) ?_
+  intro t ht
+  obtain ⟨d, hd, -, rfl⟩ := (ModularCurve.R8.mem_gens_iff L N t).mp ht
+  exact isIntegral_jqNModC_all_of_modularPolynomialFamily L hΦ d
+
+end
+
+end S_ModularCurve_hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull
+end P2MW
+export P2MW.S_ModularCurve_hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull (L : Type*)
+    [Field L] [Algebra ℚ L]
+    (hΦ : ModularPolynomialFamily) (N : ℕ) [NeZero N] :
+    HasPrincipalDivisors L (laurentBaseChange L (modularFunctionFieldFull N)) :=
+  solution L hΦ N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull_unconditional.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull_unconditional.lean
new file mode 100644
index 0000000000..9fa90afb57
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull_unconditional.lean
@@ -0,0 +1,91 @@
+/-
+Based on Prove2Me node
+ModularCurve.hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull_unconditional
+(4c0c6588-cadd-583f-ab34-2e414ed26ca5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2214a693-0c80-5319-88ed-bc647d42ffff
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ArithmeticGalois
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularPolynomialFamily
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Principal divisors of degree zero on L· F_N^{full}
+
+Theorem statement:
+`ModularCurve.hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull_unconditional`
+(`4c0c6588-cadd-583f-ab34-2e414ed26ca5`), by Claude, 2026-09-05.
+
+Proof: submission `2214a693-0c80-5319-88ed-bc647d42ffff`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbb{Q}$-algebra structure (so of characteristic zero), and
+let $N$ be a natural number with $N \neq 0$. Consider the field $F =$ `laurentBaseChange L
+(modularFunctionFieldFull N)`: inside $\mathbb{Q}$-Laurent series one first forms
+`modularFunctionFieldFull N`, the intermediate field of $\mathbb{Q}((q))$ generated over
+$\mathbb{Q}$ by the set of series `qExpand ℚ d jq` for the nonzero divisors $d$ of $N$; one then
+applies `coeffEmb L`, the ring map $\mathbb{Q}((q)) \to L((q))$ obtained by applying $\mathbb{Q} \to
+L$ to each coefficient, and takes the intermediate field of $L((q))$ generated over $L$ by the image
+of that set of series. The assertion is `HasPrincipalDivisors L F`: for every $f \in F$ with $f \neq
+0$ there is a finitely supported function $D$ from the places of $F$ over $L$ to $\mathbb{Z}$ — a
+place being a valuation subring of $F$ that contains the image of $L$, is not the whole of $F$, and
+is a principal ideal ring — such that $D(v) = v.\mathrm{ord}(f)$ for every place $v$, and such that
+$\sum_v D(v)\,\deg(v) = 0$.
+
+This is the degree-zero theorem for principal divisors on the modular curve of level $N$ realised as
+an algebraic function field of one variable over $L$ via $q$-expansions, here in unconditional form:
+no hypothesis is carried beyond $N \neq 0$ and the $\mathbb{Q}$-algebra structure on $L$. It is the
+form used downstream, for instance by the identification of the constants of `laurentBaseChange L
+(modularFunctionFieldFull N)` and of the reduction `modularFunctionFieldBar` with the base field,
+and in the analysis of places on fibres in characteristic $p$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull_unconditional.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_b19fcf9a
+
+open ModularCurve AlgebraicCurve
+
+theorem solution (L : Type*) [Field L] [Algebra ℚ L]
+    (N : ℕ) [NeZero N]
+    : HasPrincipalDivisors L (laurentBaseChange L (modularFunctionFieldFull N)) :=
+  hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull L modularPolynomialFamily N
+
+end S_OVERLONG_b19fcf9a
+end P2MW
+export
+  P2MW.S_OVERLONG_b19fcf9a
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull_unconditional
+    (L : Type*) [Field L] [Algebra ℚ L]
+    (N : ℕ) [NeZero N]
+    : HasPrincipalDivisors L (laurentBaseChange L (modularFunctionFieldFull N)) :=
+  solution L N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasPrincipalDivisors_modularFunctionFieldBar.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasPrincipalDivisors_modularFunctionFieldBar.lean
new file mode 100644
index 0000000000..aa1d905bd0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasPrincipalDivisors_modularFunctionFieldBar.lean
@@ -0,0 +1,92 @@
+/-
+Based on Prove2Me node ModularCurve.hasPrincipalDivisors_modularFunctionFieldBar
+(203f466e-501a-57ea-b9c6-211b1bfca7d2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 528ef3a1-b8f8-5b9e-b204-2d42ff3375ce
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ArithmeticGalois
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Principal divisors on the function field of X₀(N) over ℚ̄
+
+Theorem statement: `ModularCurve.hasPrincipalDivisors_modularFunctionFieldBar`
+(`203f466e-501a-57ea-b9c6-211b1bfca7d2`), by Claude, 2026-09-05.
+
+Proof: submission `528ef3a1-b8f8-5b9e-b204-2d42ff3375ce`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $N$ with $N \neq 0$, and assume `ModularPolynomialFamily`: for every prime
+$\ell$ (nonzero) there is a datum consisting of a polynomial $\Phi \in \mathbb{Z}[X][Y]$ that is
+monic, has degree equal to `dedekindPsi` $\ell$, satisfies $\Phi(j, j_\ell) = 0$ when evaluated by
+`evalAtJ` on the coefficients and at the Laurent series `jqN` $\ell$, and is symmetric in the sense
+that for all Laurent series $x, y$ over $\mathbb{Q}$ the two evaluations of $\Phi$ obtained by
+substituting $x$ into the coefficients and $y$ into the outer variable, and vice versa, agree. The
+conclusion is `HasPrincipalDivisors` for the field extension $\overline{\mathbb{Q}} \subseteq$
+`modularFunctionFieldBar` $N$, the latter being the subfield of $\overline{\mathbb{Q}}((q))$
+generated over $\overline{\mathbb{Q}}$ by the coefficientwise image of `modularFunctionFieldFull`
+$N$, itself the subfield of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by `divisorExpansions`
+$N$. Concretely: for every nonzero $f$ in that field there is a finitely supported integer-valued
+function $D$ on the places of the extension (valuation subrings of the Laurent series field
+containing $\overline{\mathbb{Q}}$, proper, and principal ideal rings) with $D(v) =
+\operatorname{ord}_v(f)$ for every place $v$, and with $\sum_v D(v) \deg(v) = 0$.
+
+This is the statement that the divisor of a nonzero function on $X_0(N)$ over
+$\overline{\mathbb{Q}}$ is a well-defined finitely supported divisor of degree zero — the classical
+degree-zero theorem for principal divisors in an algebraic function field, here for the
+$q$-expansion model $\overline{\mathbb{Q}}(j(q^d) : d \mid N)$ whose degree-zero divisor class group
+plays the role of $J_0(N)(\overline{\mathbb{Q}})$. It supplies the `HasPrincipalDivisors` instance
+assumed by the statements about places, specialisations and Hecke correspondences on this function
+field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_hasPrincipalDivisors_modularFunctionFieldBar.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_hasPrincipalDivisors_modularFunctionFieldBar
+
+noncomputable section
+open IntermediateField
+
+open ModularCurve AlgebraicCurve
+
+theorem solution (hΦ : ModularPolynomialFamily) (N : ℕ) [NeZero N] :
+    HasPrincipalDivisors (AlgebraicClosure ℚ) (modularFunctionFieldBar N) :=
+  hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull (AlgebraicClosure ℚ) hΦ N
+
+end
+
+end S_ModularCurve_hasPrincipalDivisors_modularFunctionFieldBar
+end P2MW
+export P2MW.S_ModularCurve_hasPrincipalDivisors_modularFunctionFieldBar (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.hasPrincipalDivisors_modularFunctionFieldBar (hΦ : ModularPolynomialFamily)
+    (N : ℕ) [NeZero N] :
+    HasPrincipalDivisors (AlgebraicClosure ℚ) (modularFunctionFieldBar N) :=
+  solution hΦ N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasPrincipalDivisors_modularFunctionFieldBar_unconditional.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasPrincipalDivisors_modularFunctionFieldBar_unconditional.lean
new file mode 100644
index 0000000000..bc543580d2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasPrincipalDivisors_modularFunctionFieldBar_unconditional.lean
@@ -0,0 +1,85 @@
+/-
+Based on Prove2Me node ModularCurve.hasPrincipalDivisors_modularFunctionFieldBar_unconditional
+(40b3b606-783f-5e60-aab1-b951a2e6ec77) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission aea74966-fcd9-50d1-bc1c-bcf730c6bbd1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ArithmeticGalois
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasPrincipalDivisors_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularPolynomialFamily
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Unconditional principal divisors on ℚ̄-modular function fields
+
+Theorem statement: `ModularCurve.hasPrincipalDivisors_modularFunctionFieldBar_unconditional`
+(`40b3b606-783f-5e60-aab1-b951a2e6ec77`), by Claude, 2026-09-05.
+
+Proof: submission `aea74966-fcd9-50d1-bc1c-bcf730c6bbd1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a natural number, assumed nonzero. Consider the field $F = \overline{\mathbb{Q}}((q))$ of
+Laurent series over an algebraic closure of $\mathbb{Q}$ and inside it the intermediate field
+$\overline{\mathbb{Q}}$-generated by the image, under the coefficientwise embedding $\mathbb{Q}((q))
+\to \overline{\mathbb{Q}}((q))$, of the field `modularFunctionFieldFull M`, the subfield of
+$\mathbb{Q}((q))$ obtained by adjoining to $\mathbb{Q}$ the family of Laurent series
+`divisorExpansions M`; this intermediate field is `modularFunctionFieldBar M`. The assertion is that
+the pair $(\overline{\mathbb{Q}}, \mathtt{modularFunctionFieldBar } M)$ satisfies
+`HasPrincipalDivisors`: for every nonzero element $f$ of `modularFunctionFieldBar M` there is a
+finitely supported function $D$ from the places of this field over $\overline{\mathbb{Q}}$ to
+$\mathbb{Z}$ — a place being a valuation subring, different from the whole field, which contains the
+image of $\overline{\mathbb{Q}}$ and is a principal ideal ring — such that $D(v) =
+\operatorname{ord}_v(f)$ for every place $v$, and such that $\sum_v D(v)\cdot \deg v = 0$. In
+particular $f$ has only finitely many zeros and poles, and its divisor has degree zero. There are no
+hypotheses beyond $M \neq 0$.
+
+This is the function-field statement that a principal divisor is well defined and has degree zero,
+in the form needed for the modular function fields of level $M$ realised as $q$-expansion fields
+over $\overline{\mathbb{Q}}$. It is the hypothesis-free version of the corresponding conditional
+result, and serves as the principal-divisors input to the constructions of places, divisor class
+groups and Hecke operators on modular curves further along in the development.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_hasPrincipalDivisors_modularFunctionFieldBar_unconditional.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_hasPrincipalDivisors_modularFunctionFieldBar_unconditional
+
+open ModularCurve AlgebraicCurve
+
+theorem solution (M : ℕ) [NeZero M] :
+    HasPrincipalDivisors (AlgebraicClosure ℚ) (modularFunctionFieldBar M) :=
+  hasPrincipalDivisors_modularFunctionFieldBar modularPolynomialFamily M
+
+end S_ModularCurve_hasPrincipalDivisors_modularFunctionFieldBar_unconditional
+end P2MW
+export P2MW.S_ModularCurve_hasPrincipalDivisors_modularFunctionFieldBar_unconditional (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.hasPrincipalDivisors_modularFunctionFieldBar_unconditional (M : ℕ) [NeZero M] :
+    HasPrincipalDivisors (AlgebraicClosure ℚ) (modularFunctionFieldBar M) :=
+  solution M
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_jNum_qParam.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_jNum_qParam.lean
new file mode 100644
index 0000000000..c5720accdb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_jNum_qParam.lean
@@ -0,0 +1,317 @@
+/-
+Based on Prove2Me node ModularCurve.hasSum_jNum_qParam
+(cd5ffe10-f230-5070-bdc4-240385126b4a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 54a502c0-7588-5c5a-bfb8-37404724e9d1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import Mathlib.NumberTheory.ModularForms.EisensteinSeries.Basic
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_E4_eq_map_eisenstein4
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# qE₄³/Δ is the sum of its q-series
+
+Theorem statement: `ModularCurve.hasSum_jNum_qParam` (`cd5ffe10-f230-5070-bdc4-240385126b4a`), by
+Claude, 2026-09-05.
+
+Proof: submission `54a502c0-7588-5c5a-bfb8-37404724e9d1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\tau$ be a point of the upper half-plane and write $q =$ `Function.Periodic.qParam 1 (τ : ℂ)`,
+that is $q = e^{2\pi i\tau}$. Let [`ModularCurve.eisenstein4`](def/ModularCurve_X0.html#L111) be the
+formal power series over $\mathbb{Z}$ whose $n$-th coefficient is $1$ for $n = 0$ and $240\sum_{d
+\mid n} d^{3}$ for $n \ge 1$, let [`ModularCurve.dedekindEtaUnitInv`](def/ModularCurve_X0.html#L132)
+be the formal inverse `dedekindEtaUnit.invOfUnit 1` of the power series
+[`ModularCurve.dedekindEtaUnit`](def/ModularCurve_X0.html#L127) (the inverse taken with respect to
+the constant term $1$), and let [`ModularCurve.jNum`](def/ModularCurve_X0.html#L142) be the product
+`eisenstein4 ^ 3 * dedekindEtaUnitInv` in $\mathbb{Z}[[q]]$. The assertion is that the family
+indexed by $m \in \mathbb{N}$ whose $m$-th term is the integer coefficient
+$\mathrm{coeff}_m(\mathtt{jNum})$, cast into $\mathbb{C}$, multiplied by $q^{m}$, is summable with
+sum
+$$\sum_{m \ge 0} \mathrm{coeff}_m(\mathtt{jNum})\, q^{m} \;=\;
+q\cdot\frac{E_4(\tau)^{3}}{\Delta(\tau)},$$
+where $E_4$ is `ModularForm.E₄` and $\Delta$ is `ModularForm.discriminant`. Since `HasSum` over
+$\mathbb{C}$ is unconditional summability, this includes the convergence of the series.
+
+This identifies the formal integer power series $\mathtt{jNum} = 1 + 744q + 196884q^{2} + \cdots$,
+the numerator of the modular invariant $j$ in the $q$-variable, with the analytic function
+$q\,E_4^{3}/\Delta$ on the upper half-plane; the proof combines the $q$-expansions of $E_4$ and
+$\Delta$, the latter in the form $q$ times a power series with constant term $1$, so that the formal
+inverse of the eta factor matches the analytic reciprocal. It feeds the corresponding statement for
+$j$ itself, [`ModularCurve.hasSum_jq_qParam`](thm.html#ModularCurve.hasSum_jq_qParam).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_hasSum_jNum_qParam.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_hasSum_jNum_qParam
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology
+open scoped MatrixGroups PowerSeries.WithPiTopology
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+p2m_export "ModularCurve" "eisenstein4 dedekindEtaUnit dedekindEtaUnitInv dedekindEtaUnit_mul_inv \
+  jNum qExpansion_E4_eq_map_eisenstein4 qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit"
+p2m_open "ModularCurve"
+
+private def gfun (q : ℂ) : ℂ := ∏' n : ℕ, (1 - q ^ (n + 1)) ^ 24
+
+private lemma differentiableOn_gfun : DifferentiableOn ℂ gfun (Metric.ball (0 : ℂ) 1) :=
+  ModularForm.differentiableOn_tprod_one_sub_pow_pow 24
+
+private lemma discriminant_eq_qParam_mul_gfun (τ : ℍ) :
+    ModularForm.discriminant τ = 𝕢 1 (τ : ℂ) * gfun (𝕢 1 (τ : ℂ)) := by
+  rw [ModularForm.discriminant_eq_q_prod, gfun]
+
+private def qJ (τ : ℍ) : ℂ := 𝕢 1 (τ : ℂ) * (ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+
+private def Dq (τ : ℍ) : ℂ := ModularForm.discriminant τ / 𝕢 1 (τ : ℂ)
+
+private lemma Dq_eq (τ : ℍ) : Dq τ = gfun (𝕢 1 (τ : ℂ)) := by
+  rw [Dq, discriminant_eq_qParam_mul_gfun, mul_div_cancel_left₀ _ (Function.Periodic.qParam_ne_zero
+    _)]
+
+private lemma gfun_ne_zero {q : ℂ} (hq : ‖q‖ < 1) : gfun q ≠ 0 := by
+  rw [gfun, (ModularForm.multipliable_one_sub_pow hq).tprod_pow]
+  refine pow_ne_zero _ (tprod_one_add_ne_zero_of_summable (f := fun n => -q ^ (n + 1)) ?_ ?_)
+  · intro i
+    have : ‖q ^ (i + 1)‖ < 1 := by
+      rw [norm_pow]; exact pow_lt_one₀ (norm_nonneg _) hq (Nat.succ_ne_zero i)
+    intro h
+    rw [add_neg_eq_zero] at h
+    rw [← h, norm_one] at this
+    exact lt_irrefl _ this
+  · simpa [summable_nat_add_iff 1] using summable_geometric_of_lt_one (norm_nonneg _) hq
+
+private lemma continuousAt_gfun {q : ℂ} (hq : ‖q‖ < 1) : ContinuousAt gfun q :=
+  (differentiableOn_gfun.differentiableAt (Metric.isOpen_ball.mem_nhds (by
+    simpa using hq))).continuousAt
+
+private lemma qJ_eq (τ : ℍ) : qJ τ = ModularForm.E₄ τ ^ 3 / gfun (𝕢 1 (τ : ℂ)) := by
+  have hq : 𝕢 1 (τ : ℂ) ≠ 0 := Function.Periodic.qParam_ne_zero _
+  rw [qJ, discriminant_eq_qParam_mul_gfun]
+  field_simp
+
+private lemma qJ_mul_Dq : qJ * Dq = fun τ => ModularForm.E₄ τ ^ 3 := by
+  funext τ
+  have hq : 𝕢 1 (τ : ℂ) ≠ 0 := Function.Periodic.qParam_ne_zero _
+  have hΔ : ModularForm.discriminant τ ≠ 0 := ModularForm.discriminant_ne_zero τ
+  simp only [Pi.mul_apply, qJ, Dq]
+  field_simp
+
+private lemma cuspFunction_eqOn {f : ℍ → ℂ} {g : ℂ → ℂ} (hg : ContinuousAt g 0)
+    (hfg : ∀ τ : ℍ, f τ = g (𝕢 1 (τ : ℂ))) : Set.EqOn (cuspFunction 1 f) g (Metric.ball 0 1) := by
+  have hne : ∀ q : ℂ, ‖q‖ < 1 → q ≠ 0 → cuspFunction 1 f q = g q := by
+    intro q hq hq0
+    have him := Function.Periodic.im_invQParam_pos_of_norm_lt_one Real.zero_lt_one hq hq0
+    rw [cuspFunction, Function.Periodic.cuspFunction_eq_of_nonzero _ _ hq0, Function.comp_apply,
+      hfg, ofComplex_apply_of_im_pos him, Function.Periodic.qParam_right_inv one_ne_zero hq0]
+  intro q hq
+  rw [Metric.mem_ball, dist_zero_right] at hq
+  rcases eq_or_ne q 0 with rfl | hq0
+  · rw [cuspFunction, Function.Periodic.cuspFunction_zero_eq_limUnder_nhds_ne]
+    refine Tendsto.limUnder_eq ?_
+    have hball : ∀ᶠ q : ℂ in 𝓝 (0 : ℂ), ‖q‖ < 1 :=
+      Filter.eventually_of_mem (Metric.ball_mem_nhds (0 : ℂ) one_pos) fun q hq => by
+        simpa using hq
+    have h1 : ∀ᶠ q : ℂ in 𝓝[≠] (0 : ℂ), ‖q‖ < 1 ∧ q ≠ 0 :=
+      (hball.filter_mono nhdsWithin_le_nhds).and self_mem_nhdsWithin
+    have hev : g =ᶠ[𝓝[≠] (0 : ℂ)] Function.Periodic.cuspFunction 1 (f ∘ ofComplex) := by
+      filter_upwards [h1] with q hq'
+      exact (hne q hq'.1 hq'.2).symm
+    exact (hg.tendsto.mono_left nhdsWithin_le_nhds).congr' hev
+  · exact hne q hq hq0
+
+private lemma cuspFunction_Dq : Set.EqOn (cuspFunction 1 Dq) gfun (Metric.ball 0 1) :=
+  cuspFunction_eqOn (continuousAt_gfun (by simp)) Dq_eq
+
+private lemma cuspFunction_qJ : Set.EqOn (cuspFunction 1 qJ)
+    (fun q => cuspFunction 1 ⇑ModularForm.E₄ q ^ 3 / gfun q) (Metric.ball 0 1) := by
+  refine cuspFunction_eqOn ?_ fun τ => ?_
+  · have hE : ContinuousAt (cuspFunction 1 ⇑ModularForm.E₄) 0 :=
+      (ModularFormClass.analyticAt_cuspFunction_zero ModularForm.E₄ one_pos
+        one_mem_strictPeriods_SL).continuousAt
+    exact (hE.pow 3).div (continuousAt_gfun (by simp)) (gfun_ne_zero (by simp))
+  · show qJ τ = cuspFunction 1 ⇑ModularForm.E₄ (𝕢 1 (τ : ℂ)) ^ 3 / gfun (𝕢 1 (τ : ℂ))
+    rw [qJ_eq, SlashInvariantFormClass.eq_cuspFunction ModularForm.E₄ τ one_mem_strictPeriods_SL
+      one_ne_zero]
+
+private lemma analyticAt_cuspFunction_Dq : AnalyticAt ℂ (cuspFunction 1 Dq) 0 := by
+  have h : AnalyticAt ℂ gfun 0 :=
+    differentiableOn_gfun.analyticAt (Metric.isOpen_ball.mem_nhds (by simp))
+  exact h.congr (Filter.eventuallyEq_of_mem (Metric.isOpen_ball.mem_nhds (by simp))
+    fun q hq => (cuspFunction_Dq hq).symm)
+
+private lemma analyticAt_cuspFunction_qJ : AnalyticAt ℂ (cuspFunction 1 qJ) 0 := by
+  have hE : AnalyticAt ℂ (cuspFunction 1 ⇑ModularForm.E₄) 0 :=
+    ModularFormClass.analyticAt_cuspFunction_zero ModularForm.E₄ one_pos one_mem_strictPeriods_SL
+  have hg : AnalyticAt ℂ gfun 0 :=
+    differentiableOn_gfun.analyticAt (Metric.isOpen_ball.mem_nhds (by simp))
+  have h : AnalyticAt ℂ (fun q => cuspFunction 1 ⇑ModularForm.E₄ q ^ 3 / gfun q) 0 :=
+    (hE.pow 3).div hg (gfun_ne_zero (by simp))
+  exact h.congr (Filter.eventuallyEq_of_mem (Metric.isOpen_ball.mem_nhds (by simp))
+    fun q hq => (cuspFunction_qJ hq).symm)
+
+private lemma qExpansion_qParam_fun : qExpansion 1 (fun τ : ℍ => 𝕢 1 (τ : ℂ)) = PowerSeries.X := by
+  have hcusp : Set.EqOn (cuspFunction 1 (fun τ : ℍ => 𝕢 1 (τ : ℂ))) id (Metric.ball 0 1) :=
+    cuspFunction_eqOn continuousAt_id fun τ => rfl
+  have hev : cuspFunction 1 (fun τ : ℍ => 𝕢 1 (τ : ℂ)) =ᶠ[𝓝 0] id :=
+    Filter.eventuallyEq_of_mem (Metric.isOpen_ball.mem_nhds (by simp)) hcusp
+  ext m
+  rw [qExpansion_coeff, hev.iteratedDeriv_eq, PowerSeries.coeff_X]
+  cases m with
+  | zero => simp
+  | succ m =>
+    rw [iteratedDeriv_succ']
+    have hd : deriv (id : ℂ → ℂ) = fun _ => (1 : ℂ) := by funext x; exact deriv_id x
+    rw [hd, iteratedDeriv_const]
+    by_cases hm : m = 0
+    · subst hm; simp
+    · simp [hm]
+
+private lemma qExpansion_Dq' : qExpansion 1 Dq = dedekindEtaUnit.map (Int.castRingHom ℂ) := by
+  have han : AnalyticAt ℂ (cuspFunction 1 (fun τ : ℍ => 𝕢 1 (τ : ℂ))) 0 := by
+    have hcusp : Set.EqOn (cuspFunction 1 (fun τ : ℍ => 𝕢 1 (τ : ℂ))) id (Metric.ball 0 1) :=
+      cuspFunction_eqOn continuousAt_id fun τ => rfl
+    exact analyticAt_id.congr (Filter.eventuallyEq_of_mem (Metric.isOpen_ball.mem_nhds (by simp))
+      fun q hq => (hcusp hq).symm)
+  have hmul := qExpansion_mul han analyticAt_cuspFunction_Dq
+  have hfun : ((fun τ : ℍ => 𝕢 1 (τ : ℂ)) * Dq) = ModularForm.discriminant := by
+    funext τ
+    simp only [Pi.mul_apply, Dq]
+    rw [mul_div_cancel₀ _ (Function.Periodic.qParam_ne_zero _)]
+  rw [hfun, qExpansion_qParam_fun, qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit, map_mul,
+    PowerSeries.map_X] at hmul
+  exact (mul_left_cancel₀ PowerSeries.X_ne_zero hmul).symm
+
+private lemma qExpansion_qJ : qExpansion 1 qJ = jNum.map (Int.castRingHom ℂ) := by
+  have hmul := qExpansion_mul analyticAt_cuspFunction_qJ analyticAt_cuspFunction_Dq
+  rw [qJ_mul_Dq, qExpansion_Dq'] at hmul
+  have hE3 : qExpansion 1 (fun τ => ModularForm.E₄ τ ^ 3) = (eisenstein4.map (Int.castRingHom ℂ)) ^
+    3 :=
+    by
+    rw [← qExpansion_E4_eq_map_eisenstein4,
+      ← ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL ModularForm.E₄ 3,
+      ModularForm.coe_pow]
+    rfl
+  rw [hE3] at hmul
+  have hinv : dedekindEtaUnit.map (Int.castRingHom ℂ) * dedekindEtaUnitInv.map (Int.castRingHom ℂ) =
+    1 :=
+    by
+    rw [← map_mul, dedekindEtaUnit_mul_inv, map_one]
+  calc qExpansion 1 qJ
+      = qExpansion 1 qJ * (dedekindEtaUnit.map (Int.castRingHom ℂ) *
+          dedekindEtaUnitInv.map (Int.castRingHom ℂ)) := by rw [hinv, mul_one]
+    _ = (eisenstein4.map (Int.castRingHom ℂ)) ^ 3 * dedekindEtaUnitInv.map (Int.castRingHom ℂ) := by
+          rw [← mul_assoc, ← hmul]
+    _ = jNum.map (Int.castRingHom ℂ) := by rw [jNum, map_mul, map_pow]
+
+private lemma periodic_qJ : Function.Periodic (qJ ∘ ofComplex) 1 := by
+  intro w
+  by_cases hw : 0 < w.im
+  · have hw' : 0 < (w + 1).im := by simpa using hw
+    have hE := SlashInvariantFormClass.periodic_comp_ofComplex (h := 1) ModularForm.E₄
+      one_mem_strictPeriods_SL w
+    have hΔ := SlashInvariantFormClass.periodic_comp_ofComplex (h := 1) CuspForm.discriminant
+      one_mem_strictPeriods_SL w
+    simp only [Function.comp_apply, CuspForm.coe_discriminant, Complex.ofReal_one] at hE hΔ
+    rw [ofComplex_apply_of_im_pos hw, ofComplex_apply_of_im_pos hw'] at hE hΔ
+    have hq : 𝕢 1 (w + 1) = 𝕢 1 w := by
+      simp only [Function.Periodic.qParam, Complex.ofReal_one, div_one, mul_add, mul_one,
+        Complex.exp_add, Complex.exp_two_pi_mul_I]
+    simp only [Function.comp_apply, qJ, hE, hΔ, ofComplex_apply_of_im_pos hw,
+      ofComplex_apply_of_im_pos hw', UpperHalfPlane.coe_mk, hq]
+  · push Not at hw
+    have hw' : (w + 1).im ≤ 0 := by simpa using hw
+    simp only [Function.comp_apply, ofComplex_apply_eq_of_im_nonpos hw' hw]
+
+private lemma gfun_zero : gfun 0 = 1 := by
+  simp [gfun]
+
+private lemma mdiff_qJ :
+    MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) qJ := by
+  rw [UpperHalfPlane.mdifferentiable_iff]
+  have hE : DifferentiableOn ℂ (⇑ModularForm.E₄ ∘ ofComplex) {z : ℂ | 0 < z.im} :=
+    UpperHalfPlane.mdifferentiable_iff.mp (ModularFormClass.holo ModularForm.E₄)
+  have hΔ : DifferentiableOn ℂ (ModularForm.discriminant ∘ ofComplex) {z : ℂ | 0 < z.im} := by
+    have h := UpperHalfPlane.mdifferentiable_iff.mp (ModularFormClass.holo CuspForm.discriminant)
+    simpa only [CuspForm.coe_discriminant] using h
+  have hq : DifferentiableOn ℂ (fun z : ℂ => 𝕢 1 ((ofComplex z : ℍ) : ℂ)) {z : ℂ | 0 < z.im} :=
+    (Function.Periodic.differentiable_qParam (h := (1 : ℝ))).differentiableOn.congr
+      fun z hz => by simp only [ofComplex_apply_of_im_pos hz, UpperHalfPlane.coe_mk]
+  have h : DifferentiableOn ℂ (fun z : ℂ => 𝕢 1 ((ofComplex z : ℍ) : ℂ) *
+      ((⇑ModularForm.E₄ ∘ ofComplex) z ^ 3 / (ModularForm.discriminant ∘ ofComplex) z))
+      {z : ℂ | 0 < z.im} :=
+    hq.mul ((hE.pow 3).div hΔ fun z _ => ModularForm.discriminant_ne_zero _)
+  exact h.congr fun z _ => by simp only [Function.comp_apply, qJ]
+
+private lemma tendsto_gfun_qParam : Tendsto (fun τ : ℍ => gfun (𝕢 1 (τ : ℂ))) atImInfty (𝓝 1) := by
+  have h := (continuousAt_gfun (q := 0) (by simp)).tendsto.comp (qParam_tendsto_atImInfty one_pos)
+  rwa [gfun_zero] at h
+
+private lemma isBoundedAtImInfty_qJ : IsBoundedAtImInfty qJ := by
+  have hE : IsBoundedAtImInfty ⇑ModularForm.E₄ := ModularFormClass.bdd_at_infty ModularForm.E₄
+  have hE3 : BoundedAtFilter atImInfty (fun τ : ℍ => ModularForm.E₄ τ ^ 3) := by
+    have h := (hE.mul hE).mul hE
+    refine (show (fun τ : ℍ => ModularForm.E₄ τ ^ 3) = ⇑ModularForm.E₄ * ⇑ModularForm.E₄ *
+      ⇑ModularForm.E₄ from ?_) ▸ h
+    funext τ; simp only [Pi.mul_apply]; ring
+  have hg : BoundedAtFilter atImInfty (fun τ : ℍ => (gfun (𝕢 1 (τ : ℂ)))⁻¹) :=
+    (tendsto_gfun_qParam.inv₀ one_ne_zero).isBigO_one ℝ
+  have h := hE3.mul hg
+  refine (show qJ = (fun τ : ℍ => ModularForm.E₄ τ ^ 3) * fun τ : ℍ => (gfun (𝕢 1 (τ : ℂ)))⁻¹
+    from ?_) ▸ h
+  funext τ
+  simp only [Pi.mul_apply, qJ_eq, div_eq_mul_inv]
+
+end ModularCurve
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_hasSum_jNum_qParam.ModularCurve in
+theorem solution (τ : UpperHalfPlane) :
+    HasSum (fun m : ℕ => ((PowerSeries.coeff m ModularCurve.jNum : ℤ) : ℂ) *
+      Function.Periodic.qParam 1 (τ : ℂ) ^ m) (Function.Periodic.qParam 1 (τ : ℂ) * (ModularForm.E₄
+      τ ^ 3 / ModularForm.discriminant τ)) := by
+  have h := hasSum_qExpansion one_pos periodic_qJ mdiff_qJ isBoundedAtImInfty_qJ τ
+  rw [qExpansion_qJ] at h
+  refine h.congr_fun fun m => ?_
+  rw [PowerSeries.coeff_map, smul_eq_mul, eq_intCast]
+end
+
+end S_ModularCurve_hasSum_jNum_qParam
+end P2MW
+export P2MW.S_ModularCurve_hasSum_jNum_qParam (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.hasSum_jNum_qParam (τ : UpperHalfPlane) :
+    HasSum (fun m : ℕ => ((PowerSeries.coeff m ModularCurve.jNum : ℤ) : ℂ) *
+      Function.Periodic.qParam 1 (τ : ℂ) ^ m) (Function.Periodic.qParam 1 (τ : ℂ) * (ModularForm.E₄
+      τ ^ 3 / ModularForm.discriminant τ)) :=
+  solution τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_jq_qParam.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_jq_qParam.lean
new file mode 100644
index 0000000000..62de5a1e30
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_jq_qParam.lean
@@ -0,0 +1,114 @@
+/-
+Based on Prove2Me node ModularCurve.hasSum_jq_qParam
+(9f608b0d-9ccf-5c4d-ab82-4ee1d23f0ee0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a8d22e74-b1ce-52d5-87c7-d3ea8fc3b069
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import Mathlib.NumberTheory.ModularForms.EisensteinSeries.Basic
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_jNum_qParam
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Formal q-series j(q) sums to E₄³/Δ
+
+Theorem statement: `ModularCurve.hasSum_jq_qParam` (`9f608b0d-9ccf-5c4d-ab82-4ee1d23f0ee0`), by
+Claude, 2026-09-05.
+
+Proof: submission `a8d22e74-b1ce-52d5-87c7-d3ea8fc3b069`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\tau$ be a point of the upper half-plane, and let $q = \mathbb{q}(1,\tau) = e^{2\pi i \tau}$ be
+the value of Mathlib's $q$-parameter `Function.Periodic.qParam` with period $1$ at $\tau$. Consider
+the family indexed by $m \in \mathbb{Z}$ whose $m$-th term is the image in $\mathbb{C}$ of the
+rational number `ModularCurve.jq.coeff m`, the $m$-th coefficient of the formal Laurent series
+[`ModularCurve.jq`](def/ModularCurve_X0.html#L157) over $\mathbb{Q}$, multiplied by the integer
+power $q^{m}$. The assertion is that this family is unconditionally summable over $\mathbb{Z}$, in
+the sense of `HasSum`, with sum $E_4(\tau)^3 / \Delta(\tau)$, where $E_4$ is Mathlib's normalised
+weight-$4$ Eisenstein series `ModularForm.E₄` and $\Delta$ is the modular discriminant
+`ModularForm.discriminant` for $\mathrm{SL}_2(\mathbb{Z})$. Thus the coefficients of the formal
+series [`ModularCurve.jq`](def/ModularCurve_X0.html#L157) are exactly the $q$-expansion coefficients
+of the analytic modular function $E_4^3/\Delta$ at $\tau$; only the indices $m \ge -1$ contribute,
+the coefficients of [`ModularCurve.jq`](def/ModularCurve_X0.html#L157) in degrees below $-1$ being
+zero.
+
+This is the identification of the formal $q$-series used to define the function field of level one
+with the classical analytic $j$-invariant in the normalisation $j = E_4^3/\Delta$, and so serves as
+the bridge between the purely formal ($q$-series) construction of $X_0(N)$ and modular polynomials
+and the analytic theory of modular functions. It is used by the results on hyperplane sections and
+secant values attached to the divisor of $j$ and by the computation of coefficients of coset
+polynomials in the `PhiGen` development.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_hasSum_jq_qParam.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_hasSum_jq_qParam
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology
+open scoped MatrixGroups PowerSeries.WithPiTopology
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jNumQ jq coeff_jq_of_lt hasSum_jNum_qParam"
+end ModularCurve
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_hasSum_jq_qParam.ModularCurve in
+theorem solution (τ : UpperHalfPlane) :
+    HasSum (fun m : ℤ => ((ModularCurve.jq.coeff m : ℚ) : ℂ) * Function.Periodic.qParam 1 (τ : ℂ) ^
+      m) (ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) := by
+  set q : ℂ := 𝕢 1 (τ : ℂ) with hqdef
+  have hq : q ≠ 0 := Function.Periodic.qParam_ne_zero _
+  have h := (hasSum_jNum_qParam τ).mul_left q⁻¹
+  rw [← hqdef, inv_mul_cancel_left₀ hq] at h
+  have hinj : Function.Injective fun n : ℕ => (n : ℤ) - 1 := fun a b hab => by
+    simpa using hab
+  rw [← hinj.hasSum_iff]
+  · refine h.congr_fun fun n => ?_
+    simp only [Function.comp_apply]
+    rw [jq, HahnSeries.coeff_single_mul, one_mul, sub_neg_eq_add, sub_add_cancel, jNumQ,
+      HahnSeries.ofPowerSeries_apply_coeff, PowerSeries.coeff_map, eq_intCast, Rat.cast_intCast,
+      zpow_sub_one₀ hq, zpow_natCast]
+    ring
+  · intro m hm
+    have hm' : m < -1 := by
+      by_contra hge
+      push Not at hge
+      exact hm ⟨(m + 1).toNat, by simp; omega⟩
+    rw [coeff_jq_of_lt hm', Rat.cast_zero, zero_mul]
+end
+
+end S_ModularCurve_hasSum_jq_qParam
+end P2MW
+export P2MW.S_ModularCurve_hasSum_jq_qParam (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.hasSum_jq_qParam (τ : UpperHalfPlane) :
+    HasSum (fun m : ℤ => ((ModularCurve.jq.coeff m : ℚ) : ℂ) * Function.Periodic.qParam 1 (τ : ℂ) ^
+      m) (ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) :=
+  solution τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_modularUnitSeries_inv_qParam.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_modularUnitSeries_inv_qParam.lean
new file mode 100644
index 0000000000..57ea84b142
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_modularUnitSeries_inv_qParam.lean
@@ -0,0 +1,349 @@
+/-
+Based on Prove2Me node ModularCurve.hasSum_modularUnitSeries_inv_qParam
+(e24eecd1-3402-5bd9-9259-9c738c5d3f11) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f9629ac6-6abf-5917-9fe2-360cbd0c5e44
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ModularUnit
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+
+import Mathlib.NumberTheory.ModularForms.QExpansion
+import Mathlib.NumberTheory.ModularForms.LevelOne.Basic
+import Mathlib.Analysis.Complex.TaylorSeries
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_mul_laurent
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurent_qParam_coeff_unique
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# q-expansion of Δ(Nτ)/Δ(τ) realised at period one
+
+Theorem statement: `ModularCurve.hasSum_modularUnitSeries_inv_qParam`
+(`e24eecd1-3402-5bd9-9259-9c738c5d3f11`), by Claude, 2026-09-05.
+
+Proof: submission `f9629ac6-6abf-5917-9fe2-360cbd0c5e44`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and let $\tau$ lie in the upper half-plane. Consider the formal
+Laurent series over $\mathbb{Q}$ given by [`ModularCurve.modularUnitSeries
+N`](def/ModularCurve_ModularUnit.html#L127), namely the product of `deltaSeries` $=
+q\cdot\mathrm{dedekindEtaUnitQ}(q)$ (the Hahn series $q$ times the power series
+[`ModularCurve.dedekindEtaUnitQ`](def/ModularCurve_ModularUnit.html#L99)) with the inverse of its
+$N$-fold $q$-substitution `deltaSeriesN N` $=$ `qExpand ℚ N deltaSeries`; informally
+$\Delta(q)/\Delta(q^{N})$. The assertion concerns the inverse of this series in the field of formal
+Laurent series over $\mathbb{Q}$, whose $m$-th coefficients $v_m$ are rational numbers, viewed in
+$\mathbb{C}$. The conclusion is that the family indexed by $m \in \mathbb{Z}$ whose $m$-th term is
+$v_m\,q^{m}$, where $q =$ `Function.Periodic.qParam 1 τ` $= e^{2\pi i \tau}$ and $q^m$ is the
+integral power, is summable with sum equal to the quotient of Mathlib's discriminant modular form
+`ModularForm.discriminant` evaluated at [`ModularForm.heckeDiagMatrix N •
+τ`](def/ModularForm_HeckeOperator.html#L21) — the Möbius action on $\tau$ of the upper triangular
+matrix $\begin{pmatrix} N & 0\\ 0 & 1\end{pmatrix}$, i.e. at $N\tau$ — by its value at $\tau$. Thus
+$\sum_{m \in \mathbb{Z}} v_m e^{2\pi i m \tau} = \Delta(N\tau)/\Delta(\tau)$, as an unconditional
+`HasSum` statement valid at every point of the upper half-plane.
+
+This identifies the analytic function realised at period $1$ by the inverse of the modular unit
+series, namely the $q$-expansion at $\infty$ of $\Delta(N\tau)/\Delta(\tau)$, the reciprocal of
+Ogg's unit on $X_0(N)$. It is used in the proofs that both the modular unit series and its inverse
+are integral over $\mathbb{Q}[j]$, and in the descent of the $q$-expansion of the relevant product
+to $\mathbb{Q}(j, j_N)$; the corresponding statement for $1/F$ does not follow formally from the one
+for $F$, whence the separate result.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_hasSum_modularUnitSeries_inv_qParam.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_hasSum_modularUnitSeries_inv_qParam
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology Function HahnSeries
+open scoped MatrixGroups ModularForm
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+p2m_export "ModularCurve" "dedekindEtaUnitQ deltaSeries isMonicOfOrder_deltaSeries \
+  deltaSeries_ne_zero deltaSeriesN isMonicOfOrder_deltaSeriesN modularUnitSeries qExpand_coeff_mul \
+  qExpand_coeff_of_not_dvd dedekindEtaUnit ofPowerSeries_coeff_of_neg \
+  qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit hasSum_qParam_mul_laurent \
+  laurent_qParam_coeff_unique"
+p2m_open "ModularCurve"
+
+namespace QexpN
+
+private def ratNRH : ℚ →ₙ+* ℂ := (Rat.castHom ℂ).toNonUnitalRingHom
+
+private def theta (x : LaurentSeries ℚ) : LaurentSeries ℂ := x.map ratNRH
+
+private theorem theta_coeff (x : LaurentSeries ℚ) (m : ℤ) :
+    (theta x).coeff m = ((x.coeff m : ℚ) : ℂ) := rfl
+
+private theorem theta_mul (x y : LaurentSeries ℚ) : theta (x * y) = theta x * theta y :=
+  HahnSeries.map_mul ratNRH
+
+private def gfun (q : ℂ) : ℂ := ∏' n : ℕ, (1 - q ^ (n + 1)) ^ 24
+
+private lemma differentiableOn_gfun : DifferentiableOn ℂ gfun (Metric.ball (0 : ℂ) 1) :=
+  ModularForm.differentiableOn_tprod_one_sub_pow_pow 24
+
+private lemma gfun_ne_zero {q : ℂ} (hq : ‖q‖ < 1) : gfun q ≠ 0 := by
+  rw [gfun, (ModularForm.multipliable_one_sub_pow hq).tprod_pow]
+  refine pow_ne_zero _ (tprod_one_add_ne_zero_of_summable (f := fun n => -q ^ (n + 1)) ?_ ?_)
+  · intro i
+    have h1 : ‖q ^ (i + 1)‖ < 1 := by
+      rw [norm_pow]; exact pow_lt_one₀ (norm_nonneg _) hq (Nat.succ_ne_zero i)
+    intro h
+    rw [add_neg_eq_zero] at h
+    rw [← h, norm_one] at h1
+    exact lt_irrefl _ h1
+  · simpa [summable_nat_add_iff 1] using summable_geometric_of_lt_one (norm_nonneg _) hq
+
+private lemma discriminant_eq_qParam_mul_gfun (τ : ℍ) :
+    ModularForm.discriminant τ = 𝕢 1 (τ : ℂ) * gfun (𝕢 1 (τ : ℂ)) := by
+  rw [ModularForm.discriminant_eq_q_prod, gfun]
+
+private theorem hasSum_single_mul_coe_iff (k : ℤ) (P : PowerSeries ℂ) {q : ℂ} (hq : q ≠ 0) (t : ℂ) :
+    HasSum (fun m : ℤ => (HahnSeries.single k (1 : ℂ) * (P : LaurentSeries ℂ)).coeff m * q ^ m) (t *
+      q ^ k) ↔
+      HasSum (fun n : ℕ => PowerSeries.coeff n P * q ^ n) t := by
+  have hinj : Function.Injective (fun n : ℕ => (n : ℤ) + k) := fun a b hab => by simpa using hab
+  rw [← hinj.hasSum_iff]
+  · have hfg : (fun m : ℤ => (HahnSeries.single k (1 : ℂ) * (P : LaurentSeries ℂ)).coeff m * q ^ m)
+      ∘
+        (fun n : ℕ => (n : ℤ) + k) = fun n : ℕ => (PowerSeries.coeff n P * q ^ n) * q ^ k := by
+      funext n
+      simp only [Function.comp_apply]
+      rw [HahnSeries.coeff_single_mul_add, one_mul, LaurentSeries.coeff_coe_powerSeries, zpow_add₀
+        hq,
+        zpow_natCast]
+      ring
+    rw [hfg]
+    exact hasSum_mul_right_iff (zpow_ne_zero k hq)
+  · intro m hm
+    have hmk : m - k < 0 := by
+      by_contra hge
+      push Not at hge
+      exact hm ⟨(m - k).toNat, by simp only; omega⟩
+    rw [← sub_add_cancel m k, HahnSeries.coeff_single_mul_add, one_mul, PowerSeries.coeff_coe,
+      ite_eq_left hmk,
+      zero_mul]
+
+private theorem hasSum_theta_deltaSeries (τ : ℍ) :
+    HasSum (fun m : ℤ => (theta deltaSeries).coeff m * 𝕢 1 (τ : ℂ) ^ m)
+      (ModularForm.discriminant τ) := by
+  have hper : Function.Periodic (ModularForm.discriminant ∘ UpperHalfPlane.ofComplex) 1 :=
+    SlashInvariantFormClass.periodic_comp_ofComplex CuspForm.discriminant one_mem_strictPeriods_SL
+  have hmdiff := ModularFormClass.holo CuspForm.discriminant
+  have hbdd : IsBoundedAtImInfty ModularForm.discriminant :=
+    ModularForm.discriminant_isZeroAtImInfty.boundedAtFilter
+  have h := hasSum_qExpansion one_pos hper hmdiff hbdd τ
+  rw [ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit] at h
+  have hinj : Function.Injective ((↑) : ℕ → ℤ) := fun a b hab => by exact_mod_cast hab
+  rw [← hinj.hasSum_iff]
+  · refine h.congr_fun fun n => ?_
+    simp only [Function.comp_apply, theta_coeff, smul_eq_mul]
+    rcases n with - | k
+    · rw [show ((0 : ℕ) : ℤ) = (0 : ℤ) from rfl, deltaSeries, HahnSeries.coeff_single_mul, one_mul,
+        ModularCurve.ofPowerSeries_coeff_of_neg _ (by norm_num), PowerSeries.coeff_map,
+        PowerSeries.coeff_zero_X_mul]
+      norm_num
+    · rw [deltaSeries, HahnSeries.coeff_single_mul, one_mul,
+        show ((k + 1 : ℕ) : ℤ) - 1 = ((k : ℕ) : ℤ) by push_cast; ring,
+        HahnSeries.ofPowerSeries_apply_coeff, dedekindEtaUnitQ, PowerSeries.coeff_map,
+        PowerSeries.coeff_map, PowerSeries.coeff_succ_X_mul, zpow_natCast, eq_intCast,
+        eq_intCast, Rat.cast_intCast]
+  · intro m hm
+    have hm' : m < 0 := by
+      by_contra hge
+      push Not at hge
+      exact hm ⟨m.toNat, by simp; omega⟩
+    rw [theta_coeff, ModularCurve.isMonicOfOrder_deltaSeries.coeff_of_lt (by omega),
+      Rat.cast_zero, zero_mul]
+
+private theorem qParam_heckeDiagMatrix_smul {N : ℕ} (hN : N ≠ 0) (τ : ℍ) :
+    𝕢 1 ((ModularForm.heckeDiagMatrix N • τ : ℍ) : ℂ) = 𝕢 1 (τ : ℂ) ^ N := by
+  rw [ModularForm.coe_heckeDiagMatrix_smul hN, Periodic.qParam, Periodic.qParam,
+    ← Complex.exp_nat_mul]
+  congr 1
+  push_cast
+  ring
+
+private theorem hasSum_theta_deltaSeriesN (N : ℕ) [NeZero N] (τ : ℍ) :
+    HasSum (fun m : ℤ => (theta (deltaSeriesN N)).coeff m * 𝕢 1 (τ : ℂ) ^ m)
+      (ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)) := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hNZ : ((N : ℕ) : ℤ) ≠ 0 := by exact_mod_cast hN
+  have h := hasSum_theta_deltaSeries (ModularForm.heckeDiagMatrix N • τ)
+  have e : 𝕢 1 ((ModularForm.heckeDiagMatrix N • τ : ℍ) : ℂ) = 𝕢 1 (τ : ℂ) ^ ((N : ℕ) : ℤ) := by
+    rw [qParam_heckeDiagMatrix_smul hN, zpow_natCast]
+  have hinj : Function.Injective (fun m : ℤ => ((N : ℕ) : ℤ) * m) := mul_right_injective₀ hNZ
+  rw [← hinj.hasSum_iff]
+  · have hfg : (fun m : ℤ => (theta (deltaSeriesN N)).coeff m * 𝕢 1 (τ : ℂ) ^ m) ∘
+        (fun m : ℤ => ((N : ℕ) : ℤ) * m)
+        = fun m : ℤ => (theta deltaSeries).coeff m * 𝕢 1 ((ModularForm.heckeDiagMatrix N • τ : ℍ) :
+          ℂ) ^ m := by
+      funext m
+      simp only [Function.comp_apply, theta_coeff, deltaSeriesN]
+      rw [ModularCurve.qExpand_coeff_mul, e, ← zpow_mul]
+    rw [hfg]
+    exact h
+  · intro m hm
+    rw [theta_coeff, deltaSeriesN,
+      ModularCurve.qExpand_coeff_of_not_dvd N deltaSeries (fun ⟨c, hc⟩ => hm ⟨c, hc.symm⟩),
+      Rat.cast_zero, zero_mul]
+
+private theorem theta_deltaSeriesN_ne_zero (N : ℕ) [NeZero N] : theta (deltaSeriesN N) ≠ 0 := by
+  have h1 : (theta (deltaSeriesN N)).coeff ((N : ℕ) : ℤ) = 1 := by
+    rw [theta_coeff, (ModularCurve.isMonicOfOrder_deltaSeriesN N).coeff_self, Rat.cast_one]
+  exact HahnSeries.ne_zero_of_coeff_ne_zero (h1 ▸ one_ne_zero)
+
+private theorem theta_deltaSeries_ne_zero : theta deltaSeries ≠ 0 := by
+  have h1 : (theta deltaSeries).coeff (1 : ℤ) = 1 := by
+    rw [theta_coeff, ModularCurve.isMonicOfOrder_deltaSeries.coeff_self, Rat.cast_one]
+  exact HahnSeries.ne_zero_of_coeff_ne_zero (h1 ▸ one_ne_zero)
+
+private def phiFun (N : ℕ) : ℂ → ℂ := fun w => gfun w / gfun (w ^ N)
+
+private def psiFun (N : ℕ) : ℂ → ℂ := fun w => gfun (w ^ N) / gfun w
+
+private lemma pow_mem_ball {N : ℕ} [NeZero N] {w : ℂ} (hw : w ∈ Metric.ball (0 : ℂ) 1) :
+    w ^ N ∈ Metric.ball (0 : ℂ) 1 := by
+  rw [Metric.mem_ball, dist_zero_right] at hw ⊢
+  rw [norm_pow]
+  exact pow_lt_one₀ (norm_nonneg _) hw (NeZero.ne N)
+
+private lemma differentiableOn_gfun_pow (N : ℕ) [NeZero N] :
+    DifferentiableOn ℂ (fun w : ℂ => gfun (w ^ N)) (Metric.ball (0 : ℂ) 1) :=
+  differentiableOn_gfun.comp ((differentiable_pow N).differentiableOn)
+    fun _ hw => pow_mem_ball hw
+
+private lemma differentiableOn_phiFun (N : ℕ) [NeZero N] :
+    DifferentiableOn ℂ (phiFun N) (Metric.ball (0 : ℂ) 1) := by
+  refine DifferentiableOn.div differentiableOn_gfun (differentiableOn_gfun_pow N)
+    fun w hw => gfun_ne_zero ?_
+  have := pow_mem_ball (N := N) hw
+  rwa [Metric.mem_ball, dist_zero_right] at this
+
+private lemma differentiableOn_psiFun (N : ℕ) [NeZero N] :
+    DifferentiableOn ℂ (psiFun N) (Metric.ball (0 : ℂ) 1) := by
+  refine DifferentiableOn.div (differentiableOn_gfun_pow N) differentiableOn_gfun
+    fun w hw => gfun_ne_zero ?_
+  rwa [Metric.mem_ball, dist_zero_right] at hw
+
+private def taylorCoeff (f : ℂ → ℂ) (n : ℕ) : ℂ := ((n.factorial : ℂ))⁻¹ * iteratedDeriv n f 0
+
+private lemma hasSum_taylorCoeff {f : ℂ → ℂ}
+    (hf : DifferentiableOn ℂ f (Metric.ball (0 : ℂ) 1)) {q : ℂ} (hq : ‖q‖ < 1) :
+    HasSum (fun n : ℕ => taylorCoeff f n * q ^ n) (f q) := by
+  have h := Complex.hasSum_taylorSeries_on_ball hf
+    (show q ∈ Metric.ball (0 : ℂ) 1 by rwa [Metric.mem_ball, dist_zero_right])
+  refine h.congr_fun fun n => ?_
+  rw [taylorCoeff, sub_zero, smul_eq_mul, smul_eq_mul]
+  ring
+
+private theorem modularUnitSeries_inv_mul (N : ℕ) [NeZero N] :
+    (ModularCurve.modularUnitSeries N)⁻¹ * deltaSeries = deltaSeriesN N := by
+  rw [ModularCurve.modularUnitSeries, mul_inv_rev, inv_inv, mul_assoc,
+    inv_mul_cancel₀ ModularCurve.deltaSeries_ne_zero, mul_one]
+
+private theorem hasSum_modularUnitInv (N : ℕ) [NeZero N] (τ₀ : ℍ) :
+    HasSum (fun m : ℤ => ((((ModularCurve.modularUnitSeries N)⁻¹).coeff m : ℚ) : ℂ)
+        * 𝕢 1 (τ₀ : ℂ) ^ m)
+      (ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ₀)
+        / ModularForm.discriminant τ₀) := by
+  have hq0 : ∀ τ : ℍ, 𝕢 1 (τ : ℂ) ≠ 0 := fun τ => Periodic.qParam_ne_zero _
+  have hqlt : ∀ τ : ℍ, ‖𝕢 1 (τ : ℂ)‖ < 1 := fun τ => by
+    exact_mod_cast UpperHalfPlane.norm_qParam_lt_one 1 τ
+  set B : LaurentSeries ℂ := HahnSeries.single ((N : ℤ) - 1) 1
+    * ((PowerSeries.mk (taylorCoeff (psiFun N)) : PowerSeries ℂ) : LaurentSeries ℂ) with hB
+  have hval : ∀ τ : ℍ,
+      ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ) / ModularForm.discriminant τ
+      = psiFun N (𝕢 1 (τ : ℂ)) * 𝕢 1 (τ : ℂ) ^ ((N : ℤ) - 1) := by
+    intro τ
+    have hq := hq0 τ
+    have hgq : gfun (𝕢 1 (τ : ℂ)) ≠ 0 := gfun_ne_zero (hqlt τ)
+    have hgN : gfun (𝕢 1 (τ : ℂ) ^ N) ≠ 0 := gfun_ne_zero (by
+      rw [norm_pow]; exact pow_lt_one₀ (norm_nonneg _) (hqlt τ) (NeZero.ne N))
+    have hqN : 𝕢 1 (τ : ℂ) ^ N ≠ 0 := pow_ne_zero _ hq
+    rw [discriminant_eq_qParam_mul_gfun τ,
+      discriminant_eq_qParam_mul_gfun (ModularForm.heckeDiagMatrix N • τ),
+      qParam_heckeDiagMatrix_smul (NeZero.ne N), psiFun, zpow_sub₀ hq, zpow_one, zpow_natCast]
+    field_simp
+  have hBsum : ∀ τ : ℍ, HasSum (fun m : ℤ => B.coeff m * 𝕢 1 (τ : ℂ) ^ m)
+      (ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)
+        / ModularForm.discriminant τ) := by
+    intro τ
+    rw [hval τ, hB]
+    refine (hasSum_single_mul_coe_iff ((N : ℤ) - 1) _ (hq0 τ) _).mpr ?_
+    refine (hasSum_taylorCoeff (differentiableOn_psiFun N) (hqlt τ)).congr_fun fun n => ?_
+    rw [PowerSeries.coeff_mk]
+  have hprod : ∀ τ : ℍ, HasSum
+      (fun m : ℤ => (B * theta deltaSeries).coeff m * 𝕢 1 (τ : ℂ) ^ m)
+      (ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)) := by
+    intro τ
+    have h := ModularCurve.hasSum_qParam_mul_laurent 1 one_pos B (theta deltaSeries)
+      (fun τ => ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)
+        / ModularForm.discriminant τ)
+      (fun τ => ModularForm.discriminant τ)
+      hBsum hasSum_theta_deltaSeries τ
+    have h2 : HasSum (fun m : ℤ => (B * theta deltaSeries).coeff m * 𝕢 1 (τ : ℂ) ^ m)
+        (ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)
+            / ModularForm.discriminant τ * ModularForm.discriminant τ) := h
+    rwa [div_mul_cancel₀ _ (ModularForm.discriminant_ne_zero _)] at h2
+  have huniq : B * theta deltaSeries = theta (deltaSeriesN N) :=
+    ModularCurve.laurent_qParam_coeff_unique 1 one_pos
+      (fun τ => ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)) _ _ hprod
+      (hasSum_theta_deltaSeriesN N)
+  have hTheta : theta ((ModularCurve.modularUnitSeries N)⁻¹) * theta deltaSeries
+      = theta (deltaSeriesN N) := by
+    rw [← theta_mul, modularUnitSeries_inv_mul]
+  have hBu : B = theta ((ModularCurve.modularUnitSeries N)⁻¹) :=
+    mul_right_cancel₀ theta_deltaSeries_ne_zero (huniq.trans hTheta.symm)
+  have h := hBsum τ₀
+  rw [hBu] at h
+  refine h.congr_fun fun m => ?_
+  rw [theta_coeff]
+
+end QexpN
+
+end ModularCurve
+
+end
+
+theorem solution (N : ℕ) [NeZero N] (τ : UpperHalfPlane) :
+    HasSum (fun m : ℤ => ((((ModularCurve.modularUnitSeries N)⁻¹).coeff m : ℚ) : ℂ) *
+      Function.Periodic.qParam 1 (τ : ℂ) ^ m) (ModularForm.discriminant (ModularForm.heckeDiagMatrix
+      N • τ) / ModularForm.discriminant τ) :=
+  ModularCurve.QexpN.hasSum_modularUnitInv N τ
+
+end S_ModularCurve_hasSum_modularUnitSeries_inv_qParam
+end P2MW
+export P2MW.S_ModularCurve_hasSum_modularUnitSeries_inv_qParam (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.hasSum_modularUnitSeries_inv_qParam (N : ℕ) [NeZero N] (τ : UpperHalfPlane) :
+    HasSum (fun m : ℤ => ((((ModularCurve.modularUnitSeries N)⁻¹).coeff m : ℚ) : ℂ) *
+      Function.Periodic.qParam 1 (τ : ℂ) ^ m) (ModularForm.discriminant (ModularForm.heckeDiagMatrix
+      N • τ) / ModularForm.discriminant τ) :=
+  solution N τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_modularUnitSeries_qParam.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_modularUnitSeries_qParam.lean
new file mode 100644
index 0000000000..1a5f6f3900
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_modularUnitSeries_qParam.lean
@@ -0,0 +1,342 @@
+/-
+Based on Prove2Me node ModularCurve.hasSum_modularUnitSeries_qParam
+(d56465a1-e65d-5b62-b228-0badbdd944c2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission fa5c4c51-c0ac-56b9-ac7f-8fce506223d4
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ModularUnit
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+
+import Mathlib.NumberTheory.ModularForms.QExpansion
+import Mathlib.NumberTheory.ModularForms.LevelOne.Basic
+import Mathlib.Analysis.Complex.TaylorSeries
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_mul_laurent
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurent_qParam_coeff_unique
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# q-expansion of Δ(τ)/Δ(Nτ) at the cusp ∞
+
+Theorem statement: `ModularCurve.hasSum_modularUnitSeries_qParam`
+(`d56465a1-e65d-5b62-b228-0badbdd944c2`), by Claude, 2026-09-05.
+
+Proof: submission `fa5c4c51-c0ac-56b9-ac7f-8fce506223d4`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a positive natural number and let $\tau$ lie in the upper half-plane. Write $u =$
+[`ModularCurve.modularUnitSeries N`](def/ModularCurve_ModularUnit.html#L127) for the element $\delta
+\cdot (\mathrm{qExpand}_{\mathbb Q,N}\,\delta)^{-1}$ of the field $\mathbb Q((q))$ of formal Laurent
+series over $\mathbb Q$, where $\delta =$
+[`ModularCurve.deltaSeries`](def/ModularCurve_ModularUnit.html#L107) is $q$ times the power series
+`dedekindEtaUnitQ` with its coefficients viewed in $\mathbb Q$, and $\mathrm{qExpand}_{\mathbb Q,N}$
+is the substitution $q \mapsto q^N$; thus $u$ is the formal quotient $\Delta(q)/\Delta(q^N)$. The
+assertion is that the family indexed by $m \in \mathbb Z$ whose $m$-th term is the complex number
+$u_m \, \mathfrak q^m$, with $u_m \in \mathbb Q$ the $m$-th coefficient of $u$ cast into $\mathbb C$
+and $\mathfrak q =$ `Function.Periodic.qParam 1 (τ : ℂ)` $= e^{2\pi i \tau}$ (integer powers being
+taken in $\mathbb C$), is summable with sum
+$$\frac{\Delta(\tau)}{\Delta\big(\mathrm{heckeDiagMatrix}(N) \cdot \tau\big)},$$
+where $\Delta$ is Mathlib's discriminant cusp form and $\mathrm{heckeDiagMatrix}(N)$ is the element
+$\begin{pmatrix} N & 0 \\ 0 & 1\end{pmatrix}$ of $\mathrm{GL}_2(\mathbb R)$, acting on the upper
+half-plane by Möbius transformation, so that the denominator is $\Delta(N\tau)$.
+
+This identifies the formal Laurent series $\Delta(q)/\Delta(q^N)$ with the analytic modular unit
+$\tau \mapsto \Delta(\tau)/\Delta(N\tau)$ on $X_0(N)$, Ogg's unit, realised at period $1$ at the
+cusp $\infty$; no primality of $N$ is required. It is the bridge between the formal and analytic
+descriptions used in the computation of the Fricke involution on this unit and in the descent
+placing the relevant functions in $\mathbb Q(j, j_N)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_hasSum_modularUnitSeries_qParam.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_hasSum_modularUnitSeries_qParam
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology Function HahnSeries
+open scoped MatrixGroups ModularForm
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+p2m_export "ModularCurve" "dedekindEtaUnitQ deltaSeries isMonicOfOrder_deltaSeries deltaSeriesN \
+  isMonicOfOrder_deltaSeriesN modularUnitSeries modularUnitSeries_mul_deltaSeriesN \
+  qExpand_coeff_mul qExpand_coeff_of_not_dvd dedekindEtaUnit ofPowerSeries_coeff_of_neg \
+  qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit hasSum_qParam_mul_laurent \
+  laurent_qParam_coeff_unique"
+p2m_open "ModularCurve"
+
+namespace QexpN
+
+private def ratNRH : ℚ →ₙ+* ℂ := (Rat.castHom ℂ).toNonUnitalRingHom
+
+private def theta (x : LaurentSeries ℚ) : LaurentSeries ℂ := x.map ratNRH
+
+private theorem theta_coeff (x : LaurentSeries ℚ) (m : ℤ) :
+    (theta x).coeff m = ((x.coeff m : ℚ) : ℂ) := rfl
+
+private theorem theta_mul (x y : LaurentSeries ℚ) : theta (x * y) = theta x * theta y :=
+  HahnSeries.map_mul ratNRH
+
+private def gfun (q : ℂ) : ℂ := ∏' n : ℕ, (1 - q ^ (n + 1)) ^ 24
+
+private lemma differentiableOn_gfun : DifferentiableOn ℂ gfun (Metric.ball (0 : ℂ) 1) :=
+  ModularForm.differentiableOn_tprod_one_sub_pow_pow 24
+
+private lemma gfun_ne_zero {q : ℂ} (hq : ‖q‖ < 1) : gfun q ≠ 0 := by
+  rw [gfun, (ModularForm.multipliable_one_sub_pow hq).tprod_pow]
+  refine pow_ne_zero _ (tprod_one_add_ne_zero_of_summable (f := fun n => -q ^ (n + 1)) ?_ ?_)
+  · intro i
+    have h1 : ‖q ^ (i + 1)‖ < 1 := by
+      rw [norm_pow]; exact pow_lt_one₀ (norm_nonneg _) hq (Nat.succ_ne_zero i)
+    intro h
+    rw [add_neg_eq_zero] at h
+    rw [← h, norm_one] at h1
+    exact lt_irrefl _ h1
+  · simpa [summable_nat_add_iff 1] using summable_geometric_of_lt_one (norm_nonneg _) hq
+
+private lemma discriminant_eq_qParam_mul_gfun (τ : ℍ) :
+    ModularForm.discriminant τ = 𝕢 1 (τ : ℂ) * gfun (𝕢 1 (τ : ℂ)) := by
+  rw [ModularForm.discriminant_eq_q_prod, gfun]
+
+private theorem hasSum_single_mul_coe_iff (k : ℤ) (P : PowerSeries ℂ) {q : ℂ} (hq : q ≠ 0) (t : ℂ) :
+    HasSum (fun m : ℤ => (HahnSeries.single k (1 : ℂ) * (P : LaurentSeries ℂ)).coeff m * q ^ m) (t *
+      q ^ k) ↔
+      HasSum (fun n : ℕ => PowerSeries.coeff n P * q ^ n) t := by
+  have hinj : Function.Injective (fun n : ℕ => (n : ℤ) + k) := fun a b hab => by simpa using hab
+  rw [← hinj.hasSum_iff]
+  · have hfg : (fun m : ℤ => (HahnSeries.single k (1 : ℂ) * (P : LaurentSeries ℂ)).coeff m * q ^ m)
+      ∘
+        (fun n : ℕ => (n : ℤ) + k) = fun n : ℕ => (PowerSeries.coeff n P * q ^ n) * q ^ k := by
+      funext n
+      simp only [Function.comp_apply]
+      rw [HahnSeries.coeff_single_mul_add, one_mul, LaurentSeries.coeff_coe_powerSeries, zpow_add₀
+        hq,
+        zpow_natCast]
+      ring
+    rw [hfg]
+    exact hasSum_mul_right_iff (zpow_ne_zero k hq)
+  · intro m hm
+    have hmk : m - k < 0 := by
+      by_contra hge
+      push Not at hge
+      exact hm ⟨(m - k).toNat, by simp only; omega⟩
+    rw [← sub_add_cancel m k, HahnSeries.coeff_single_mul_add, one_mul, PowerSeries.coeff_coe,
+      ite_eq_left hmk,
+      zero_mul]
+
+private theorem hasSum_theta_deltaSeries (τ : ℍ) :
+    HasSum (fun m : ℤ => (theta deltaSeries).coeff m * 𝕢 1 (τ : ℂ) ^ m)
+      (ModularForm.discriminant τ) := by
+  have hper : Function.Periodic (ModularForm.discriminant ∘ UpperHalfPlane.ofComplex) 1 :=
+    SlashInvariantFormClass.periodic_comp_ofComplex CuspForm.discriminant one_mem_strictPeriods_SL
+  have hmdiff := ModularFormClass.holo CuspForm.discriminant
+  have hbdd : IsBoundedAtImInfty ModularForm.discriminant :=
+    ModularForm.discriminant_isZeroAtImInfty.boundedAtFilter
+  have h := hasSum_qExpansion one_pos hper hmdiff hbdd τ
+  rw [ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit] at h
+  have hinj : Function.Injective ((↑) : ℕ → ℤ) := fun a b hab => by exact_mod_cast hab
+  rw [← hinj.hasSum_iff]
+  · refine h.congr_fun fun n => ?_
+    simp only [Function.comp_apply, theta_coeff, smul_eq_mul]
+    rcases n with - | k
+    · rw [show ((0 : ℕ) : ℤ) = (0 : ℤ) from rfl, deltaSeries, HahnSeries.coeff_single_mul, one_mul,
+        ModularCurve.ofPowerSeries_coeff_of_neg _ (by norm_num), PowerSeries.coeff_map,
+        PowerSeries.coeff_zero_X_mul]
+      norm_num
+    · rw [deltaSeries, HahnSeries.coeff_single_mul, one_mul,
+        show ((k + 1 : ℕ) : ℤ) - 1 = ((k : ℕ) : ℤ) by push_cast; ring,
+        HahnSeries.ofPowerSeries_apply_coeff, dedekindEtaUnitQ, PowerSeries.coeff_map,
+        PowerSeries.coeff_map, PowerSeries.coeff_succ_X_mul, zpow_natCast, eq_intCast,
+        eq_intCast, Rat.cast_intCast]
+  · intro m hm
+    have hm' : m < 0 := by
+      by_contra hge
+      push Not at hge
+      exact hm ⟨m.toNat, by simp; omega⟩
+    rw [theta_coeff, ModularCurve.isMonicOfOrder_deltaSeries.coeff_of_lt (by omega),
+      Rat.cast_zero, zero_mul]
+
+private theorem qParam_heckeDiagMatrix_smul {N : ℕ} (hN : N ≠ 0) (τ : ℍ) :
+    𝕢 1 ((ModularForm.heckeDiagMatrix N • τ : ℍ) : ℂ) = 𝕢 1 (τ : ℂ) ^ N := by
+  rw [ModularForm.coe_heckeDiagMatrix_smul hN, Periodic.qParam, Periodic.qParam,
+    ← Complex.exp_nat_mul]
+  congr 1
+  push_cast
+  ring
+
+private theorem hasSum_theta_deltaSeriesN (N : ℕ) [NeZero N] (τ : ℍ) :
+    HasSum (fun m : ℤ => (theta (deltaSeriesN N)).coeff m * 𝕢 1 (τ : ℂ) ^ m)
+      (ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)) := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hNZ : ((N : ℕ) : ℤ) ≠ 0 := by exact_mod_cast hN
+  have h := hasSum_theta_deltaSeries (ModularForm.heckeDiagMatrix N • τ)
+  have e : 𝕢 1 ((ModularForm.heckeDiagMatrix N • τ : ℍ) : ℂ) = 𝕢 1 (τ : ℂ) ^ ((N : ℕ) : ℤ) := by
+    rw [qParam_heckeDiagMatrix_smul hN, zpow_natCast]
+  have hinj : Function.Injective (fun m : ℤ => ((N : ℕ) : ℤ) * m) := mul_right_injective₀ hNZ
+  rw [← hinj.hasSum_iff]
+  · have hfg : (fun m : ℤ => (theta (deltaSeriesN N)).coeff m * 𝕢 1 (τ : ℂ) ^ m) ∘
+        (fun m : ℤ => ((N : ℕ) : ℤ) * m)
+        = fun m : ℤ => (theta deltaSeries).coeff m * 𝕢 1 ((ModularForm.heckeDiagMatrix N • τ : ℍ) :
+          ℂ) ^ m := by
+      funext m
+      simp only [Function.comp_apply, theta_coeff, deltaSeriesN]
+      rw [ModularCurve.qExpand_coeff_mul, e, ← zpow_mul]
+    rw [hfg]
+    exact h
+  · intro m hm
+    rw [theta_coeff, deltaSeriesN,
+      ModularCurve.qExpand_coeff_of_not_dvd N deltaSeries (fun ⟨c, hc⟩ => hm ⟨c, hc.symm⟩),
+      Rat.cast_zero, zero_mul]
+
+private theorem theta_deltaSeriesN_ne_zero (N : ℕ) [NeZero N] : theta (deltaSeriesN N) ≠ 0 := by
+  have h1 : (theta (deltaSeriesN N)).coeff ((N : ℕ) : ℤ) = 1 := by
+    rw [theta_coeff, (ModularCurve.isMonicOfOrder_deltaSeriesN N).coeff_self, Rat.cast_one]
+  exact HahnSeries.ne_zero_of_coeff_ne_zero (h1 ▸ one_ne_zero)
+
+private theorem theta_deltaSeries_ne_zero : theta deltaSeries ≠ 0 := by
+  have h1 : (theta deltaSeries).coeff (1 : ℤ) = 1 := by
+    rw [theta_coeff, ModularCurve.isMonicOfOrder_deltaSeries.coeff_self, Rat.cast_one]
+  exact HahnSeries.ne_zero_of_coeff_ne_zero (h1 ▸ one_ne_zero)
+
+private def phiFun (N : ℕ) : ℂ → ℂ := fun w => gfun w / gfun (w ^ N)
+
+private def psiFun (N : ℕ) : ℂ → ℂ := fun w => gfun (w ^ N) / gfun w
+
+private lemma pow_mem_ball {N : ℕ} [NeZero N] {w : ℂ} (hw : w ∈ Metric.ball (0 : ℂ) 1) :
+    w ^ N ∈ Metric.ball (0 : ℂ) 1 := by
+  rw [Metric.mem_ball, dist_zero_right] at hw ⊢
+  rw [norm_pow]
+  exact pow_lt_one₀ (norm_nonneg _) hw (NeZero.ne N)
+
+private lemma differentiableOn_gfun_pow (N : ℕ) [NeZero N] :
+    DifferentiableOn ℂ (fun w : ℂ => gfun (w ^ N)) (Metric.ball (0 : ℂ) 1) :=
+  differentiableOn_gfun.comp ((differentiable_pow N).differentiableOn)
+    fun _ hw => pow_mem_ball hw
+
+private lemma differentiableOn_phiFun (N : ℕ) [NeZero N] :
+    DifferentiableOn ℂ (phiFun N) (Metric.ball (0 : ℂ) 1) := by
+  refine DifferentiableOn.div differentiableOn_gfun (differentiableOn_gfun_pow N)
+    fun w hw => gfun_ne_zero ?_
+  have := pow_mem_ball (N := N) hw
+  rwa [Metric.mem_ball, dist_zero_right] at this
+
+private lemma differentiableOn_psiFun (N : ℕ) [NeZero N] :
+    DifferentiableOn ℂ (psiFun N) (Metric.ball (0 : ℂ) 1) := by
+  refine DifferentiableOn.div (differentiableOn_gfun_pow N) differentiableOn_gfun
+    fun w hw => gfun_ne_zero ?_
+  rwa [Metric.mem_ball, dist_zero_right] at hw
+
+private def taylorCoeff (f : ℂ → ℂ) (n : ℕ) : ℂ := ((n.factorial : ℂ))⁻¹ * iteratedDeriv n f 0
+
+private lemma hasSum_taylorCoeff {f : ℂ → ℂ}
+    (hf : DifferentiableOn ℂ f (Metric.ball (0 : ℂ) 1)) {q : ℂ} (hq : ‖q‖ < 1) :
+    HasSum (fun n : ℕ => taylorCoeff f n * q ^ n) (f q) := by
+  have h := Complex.hasSum_taylorSeries_on_ball hf
+    (show q ∈ Metric.ball (0 : ℂ) 1 by rwa [Metric.mem_ball, dist_zero_right])
+  refine h.congr_fun fun n => ?_
+  rw [taylorCoeff, sub_zero, smul_eq_mul, smul_eq_mul]
+  ring
+
+private theorem hasSum_modularUnit (N : ℕ) [NeZero N] (τ₀ : ℍ) :
+    HasSum (fun m : ℤ => (((ModularCurve.modularUnitSeries N).coeff m : ℚ) : ℂ)
+        * 𝕢 1 (τ₀ : ℂ) ^ m)
+      (ModularForm.discriminant τ₀
+        / ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ₀)) := by
+  have hq0 : ∀ τ : ℍ, 𝕢 1 (τ : ℂ) ≠ 0 := fun τ => Periodic.qParam_ne_zero _
+  have hqlt : ∀ τ : ℍ, ‖𝕢 1 (τ : ℂ)‖ < 1 := fun τ => by
+    exact_mod_cast UpperHalfPlane.norm_qParam_lt_one 1 τ
+  set A : LaurentSeries ℂ := HahnSeries.single ((1 : ℤ) - N) 1
+    * ((PowerSeries.mk (taylorCoeff (phiFun N)) : PowerSeries ℂ) : LaurentSeries ℂ) with hA
+  have hval : ∀ τ : ℍ, ModularForm.discriminant τ
+      / ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)
+      = phiFun N (𝕢 1 (τ : ℂ)) * 𝕢 1 (τ : ℂ) ^ ((1 : ℤ) - N) := by
+    intro τ
+    have hq := hq0 τ
+    have hgq : gfun (𝕢 1 (τ : ℂ)) ≠ 0 := gfun_ne_zero (hqlt τ)
+    have hgN : gfun (𝕢 1 (τ : ℂ) ^ N) ≠ 0 := gfun_ne_zero (by
+      rw [norm_pow]; exact pow_lt_one₀ (norm_nonneg _) (hqlt τ) (NeZero.ne N))
+    have hqN : 𝕢 1 (τ : ℂ) ^ N ≠ 0 := pow_ne_zero _ hq
+    rw [discriminant_eq_qParam_mul_gfun τ,
+      discriminant_eq_qParam_mul_gfun (ModularForm.heckeDiagMatrix N • τ),
+      qParam_heckeDiagMatrix_smul (NeZero.ne N), phiFun, zpow_sub₀ hq, zpow_one, zpow_natCast]
+    field_simp
+  have hAsum : ∀ τ : ℍ, HasSum (fun m : ℤ => A.coeff m * 𝕢 1 (τ : ℂ) ^ m)
+      (ModularForm.discriminant τ
+        / ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)) := by
+    intro τ
+    rw [hval τ, hA]
+    refine (hasSum_single_mul_coe_iff ((1 : ℤ) - N) _ (hq0 τ) _).mpr ?_
+    refine (hasSum_taylorCoeff (differentiableOn_phiFun N) (hqlt τ)).congr_fun fun n => ?_
+    rw [PowerSeries.coeff_mk]
+  have hprod : ∀ τ : ℍ, HasSum
+      (fun m : ℤ => (A * theta (deltaSeriesN N)).coeff m * 𝕢 1 (τ : ℂ) ^ m)
+      (ModularForm.discriminant τ) := by
+    intro τ
+    have h := ModularCurve.hasSum_qParam_mul_laurent 1 one_pos A (theta (deltaSeriesN N))
+      (fun τ => ModularForm.discriminant τ
+        / ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ))
+      (fun τ => ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ))
+      hAsum (hasSum_theta_deltaSeriesN N) τ
+    have h2 : HasSum (fun m : ℤ => (A * theta (deltaSeriesN N)).coeff m * 𝕢 1 (τ : ℂ) ^ m)
+        (ModularForm.discriminant τ
+            / ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)
+          * ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)) := h
+    rwa [div_mul_cancel₀ _ (ModularForm.discriminant_ne_zero _)] at h2
+  have huniq : A * theta (deltaSeriesN N) = theta deltaSeries :=
+    ModularCurve.laurent_qParam_coeff_unique 1 one_pos ModularForm.discriminant _ _ hprod
+      hasSum_theta_deltaSeries
+  have hTheta : theta (ModularCurve.modularUnitSeries N) * theta (deltaSeriesN N)
+      = theta deltaSeries := by
+    rw [← theta_mul, ModularCurve.modularUnitSeries_mul_deltaSeriesN]
+  have hAu : A = theta (ModularCurve.modularUnitSeries N) :=
+    mul_right_cancel₀ (theta_deltaSeriesN_ne_zero N) (huniq.trans hTheta.symm)
+  have h := hAsum τ₀
+  rw [hAu] at h
+  refine h.congr_fun fun m => ?_
+  rw [theta_coeff]
+
+end QexpN
+
+end ModularCurve
+
+end
+
+theorem solution (N : ℕ) [NeZero N] (τ : UpperHalfPlane) :
+    HasSum (fun m : ℤ => (((ModularCurve.modularUnitSeries N).coeff m : ℚ) : ℂ) *
+      Function.Periodic.qParam 1 (τ : ℂ) ^ m) (ModularForm.discriminant τ / ModularForm.discriminant
+      (ModularForm.heckeDiagMatrix N • τ)) :=
+  ModularCurve.QexpN.hasSum_modularUnit N τ
+
+end S_ModularCurve_hasSum_modularUnitSeries_qParam
+end P2MW
+export P2MW.S_ModularCurve_hasSum_modularUnitSeries_qParam (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.hasSum_modularUnitSeries_qParam (N : ℕ) [NeZero N] (τ : UpperHalfPlane) :
+    HasSum (fun m : ℤ => (((ModularCurve.modularUnitSeries N).coeff m : ℚ) : ℂ) *
+      Function.Periodic.qParam 1 (τ : ℂ) ^ m) (ModularForm.discriminant τ / ModularForm.discriminant
+      (ModularForm.heckeDiagMatrix N • τ)) :=
+  solution N τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_qParam_heckeDiagMatrix_smul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_qParam_heckeDiagMatrix_smul.lean
new file mode 100644
index 0000000000..26cf80f161
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_qParam_heckeDiagMatrix_smul.lean
@@ -0,0 +1,135 @@
+/-
+Based on Prove2Me node ModularCurve.hasSum_qParam_heckeDiagMatrix_smul
+(2911f1d3-670a-54c1-928f-273cc0b88142) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 78f52dc0-cdfc-5749-9bf6-e15962a2e055
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Exp
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# q_ℓ-expansion of F(ℓτ) is A(q^{ℓ^2})
+
+Theorem statement: `ModularCurve.hasSum_qParam_heckeDiagMatrix_smul`
+(`2911f1d3-670a-54c1-928f-273cc0b88142`), by Claude, 2026-09-05.
+
+Proof: submission `78f52dc0-cdfc-5749-9bf6-e15962a2e055`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a nonzero natural number, let $A$ be a formal Laurent series over $\mathbb{C}$ (a Hahn
+series indexed by $\mathbb{Z}$), let $F\colon\mathfrak{H}\to\mathbb{C}$ be a function on the upper
+half-plane, and assume that for every $\tau\in\mathfrak{H}$ the family $m\mapsto
+A.\mathrm{coeff}\,m\cdot q_1(\tau)^m$, indexed by $m\in\mathbb{Z}$, is summable with sum $F(\tau)$,
+where $q_h(\tau)=\mathrm{e}^{2\pi\mathrm{i}\tau/h}$ is `Function.Periodic.qParam h` and the powers
+are integer powers. Then for every $\tau\in\mathfrak{H}$ the family
+$m\mapsto(\mathrm{qExpand}_{\mathbb{C}}(\ell\cdot\ell)\,A).\mathrm{coeff}\,m\cdot q_\ell(\tau)^m$,
+indexed by $m\in\mathbb{Z}$, is summable with sum $F(\mathrm{heckeDiagMatrix}\,\ell\cdot\tau)$. Here
+[`ModularCurve.qExpand N`](def/ModularCurve_X0.html#L25) is the ring endomorphism of Laurent series
+obtained by pushing the index set forward along the injective, order-preserving map $m\mapsto N\,m$
+of $\mathbb{Z}$, i.e. the substitution $q\mapsto q^{N}$: its coefficient at $N\,m$ is
+$A.\mathrm{coeff}\,m$ and its coefficient at an index not divisible by $N$ is $0$; and
+[`ModularForm.heckeDiagMatrix ℓ`](def/ModularForm_HeckeOperator.html#L21) is, for $\ell\neq 0$, the
+element $\begin{pmatrix}\ell&0\\0&1\end{pmatrix}$ of $\mathrm{GL}_2(\mathbb{R})$ (and $1$ if
+$\ell=0$), acting on $\mathfrak{H}$ by Möbius transformations, so that the right-hand side is
+$F(\ell\tau)$.
+
+This is the statement that a function whose $q$-expansion at period $1$ is $A(q)$ has
+$q_\ell$-expansion $A(q^{\ell^2})$ after composition with $\tau\mapsto\ell\tau$, i.e. the expansion
+attached to the coset representative $\begin{pmatrix}\ell&0\\0&1\end{pmatrix}$ among the matrices of
+determinant $\ell$. Together with the expansions of $\tau\mapsto F((\tau+b)/\ell)$ it supplies the
+$q_\ell$-expansions of all $\ell+1$ Hecke coset transforms used in the construction of the modular
+polynomial; it is cited in the treatment of the generated modular polynomial, of the Fricke
+involution and of integrality of $j(q)$-adjunctions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_hasSum_qParam_heckeDiagMatrix_smul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_hasSum_qParam_heckeDiagMatrix_smul
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology Function
+open scoped MatrixGroups
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd"
+p2m_open "ModularCurve"
+
+namespace Realized
+
+theorem hasSum_qParam_heckeDiagMatrix_smul' (ℓ : ℕ) [NeZero ℓ] (A : LaurentSeries ℂ) (F : ℍ → ℂ)
+    (hA : ∀ τ : ℍ, HasSum (fun m : ℤ => A.coeff m * 𝕢 1 (τ : ℂ) ^ m) (F τ)) (τ : ℍ) :
+    HasSum (fun m : ℤ => (ModularCurve.qExpand ℂ (ℓ * ℓ) A).coeff m * 𝕢 ℓ (τ : ℂ) ^ m)
+      (F (ModularForm.heckeDiagMatrix ℓ • τ)) := by
+  have hℓ : ℓ ≠ 0 := NeZero.ne ℓ
+  have hℓ' : (ℓ : ℂ) ≠ 0 := Nat.cast_ne_zero.mpr hℓ
+  have hN : ((ℓ * ℓ : ℕ) : ℤ) ≠ 0 := by exact_mod_cast (NeZero.ne (ℓ * ℓ))
+  have e : 𝕢 1 ((ModularForm.heckeDiagMatrix ℓ • τ : ℍ) : ℂ) = 𝕢 ℓ (τ : ℂ) ^ ((ℓ * ℓ : ℕ) : ℤ) := by
+    rw [ModularForm.coe_heckeDiagMatrix_smul hℓ, Periodic.qParam, Periodic.qParam, zpow_natCast,
+      ← Complex.exp_nat_mul]
+    congr 1
+    push_cast
+    field_simp
+  have hinj : Function.Injective (fun m : ℤ => ((ℓ * ℓ : ℕ) : ℤ) * m) := mul_right_injective₀ hN
+  rw [← hinj.hasSum_iff]
+  · have hfg : (fun m : ℤ => (ModularCurve.qExpand ℂ (ℓ * ℓ) A).coeff m * 𝕢 ℓ (τ : ℂ) ^ m) ∘
+        (fun m : ℤ => ((ℓ * ℓ : ℕ) : ℤ) * m)
+        = fun m : ℤ => A.coeff m * 𝕢 1 ((ModularForm.heckeDiagMatrix ℓ • τ : ℍ) : ℂ) ^ m := by
+      funext m
+      simp only [Function.comp_apply]
+      rw [ModularCurve.qExpand_coeff_mul, e, ← zpow_mul]
+    rw [hfg]
+    exact hA _
+  · intro m hm
+    rw [ModularCurve.qExpand_coeff_of_not_dvd (ℓ * ℓ) A (fun ⟨c, hc⟩ => hm ⟨c, hc.symm⟩), zero_mul]
+
+end Realized
+
+end ModularCurve
+
+end
+
+theorem solution (ℓ : ℕ) [NeZero ℓ] (A : LaurentSeries ℂ) (F : UpperHalfPlane → ℂ) (hA : ∀ τ :
+  UpperHalfPlane, HasSum (fun m : ℤ => A.coeff m * Function.Periodic.qParam 1 (τ : ℂ) ^ m) (F τ)) (τ
+  : UpperHalfPlane) :
+    HasSum (fun m : ℤ => (ModularCurve.qExpand ℂ (ℓ * ℓ) A).coeff m * Function.Periodic.qParam ℓ (τ
+      : ℂ) ^ m) (F (ModularForm.heckeDiagMatrix ℓ • τ)) :=
+  ModularCurve.Realized.hasSum_qParam_heckeDiagMatrix_smul' ℓ A F hA τ
+
+end S_ModularCurve_hasSum_qParam_heckeDiagMatrix_smul
+end P2MW
+export P2MW.S_ModularCurve_hasSum_qParam_heckeDiagMatrix_smul (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.hasSum_qParam_heckeDiagMatrix_smul (ℓ : ℕ) [NeZero ℓ] (A : LaurentSeries ℂ) (F
+  : UpperHalfPlane → ℂ) (hA : ∀ τ : UpperHalfPlane, HasSum (fun m : ℤ => A.coeff m *
+  Function.Periodic.qParam 1 (τ : ℂ) ^ m) (F τ)) (τ : UpperHalfPlane) :
+    HasSum (fun m : ℤ => (ModularCurve.qExpand ℂ (ℓ * ℓ) A).coeff m * Function.Periodic.qParam ℓ (τ
+      : ℂ) ^ m) (F (ModularForm.heckeDiagMatrix ℓ • τ)) :=
+  solution ℓ A F hA τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_qParam_heckeMatrix_smul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_qParam_heckeMatrix_smul.lean
new file mode 100644
index 0000000000..9977d1a5fd
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_qParam_heckeMatrix_smul.lean
@@ -0,0 +1,132 @@
+/-
+Based on Prove2Me node ModularCurve.hasSum_qParam_heckeMatrix_smul
+(9a719889-e00c-5d0a-a633-1a21b039407e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 12ffb1d3-8081-5d76-b098-f42f76f0fd3a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Exp
+public import Mathlib.RingTheory.LaurentSeries
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Twisted q-expansion at period ℓ under τ↦(τ+b)/ℓ
+
+Theorem statement: `ModularCurve.hasSum_qParam_heckeMatrix_smul`
+(`9a719889-e00c-5d0a-a633-1a21b039407e`), by Claude, 2026-09-05.
+
+Proof: submission `12ffb1d3-8081-5d76-b098-f42f76f0fd3a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a natural number that is nonzero, $b$ a natural number, $A$ a formal Laurent series
+with complex coefficients (so $A$ has coefficients $A.\mathrm{coeff}\,m$ indexed by $m\in\mathbb
+Z$), and $F$ a complex-valued function on the upper half-plane. Assume that $F$ is expanded at
+period $1$ by $A$, in the sense that for every $\tau$ in the upper half-plane the family $m\mapsto
+A.\mathrm{coeff}\,m\cdot q_1(\tau)^m$, indexed by $m\in\mathbb Z$ with integer powers, is summable
+with sum $F(\tau)$; here $q_h(\tau)=\exp(2\pi i\tau/h)$ is Mathlib's `Function.Periodic.qParam`.
+Then for every $\tau$ in the upper half-plane the family $$m\mapsto\bigl(\exp(2\pi
+i\,b\,m/\ell)\cdot A.\mathrm{coeff}\,m\bigr)\cdot q_\ell(\tau)^m,\qquad m\in\mathbb Z,$$ is summable
+with sum $F(g\cdot\tau)$, where $g=\mathrm{ModularForm.heckeMatrix}\,\ell\,b$ is the invertible real
+matrix $\begin{pmatrix}1&b\\0&\ell\end{pmatrix}$ (the definition returns $1$ when $\ell=0$, a case
+excluded here) acting on the upper half-plane by Möbius transformations, so that
+$g\cdot\tau=(\tau+b)/\ell$. Thus $\tau\mapsto F((\tau+b)/\ell)$ is expanded at period $\ell$ by the
+series whose $m$-th coefficient is $\zeta_\ell^{bm}A.\mathrm{coeff}\,m$, $\zeta_\ell=e^{2\pi
+i/\ell}$.
+
+This is the standard effect on $q$-expansions of the upper-triangular coset representatives
+$\begin{pmatrix}1&b\\0&\ell\end{pmatrix}$ used to define the Hecke operators $T_\ell$, $U_\ell$ and
+the modular polynomial $\Phi_\ell$: the coefficients are twisted by $\ell$-th roots of unity and the
+period changes from $1$ to $\ell$. It is used in the treatment of the $q$-expansions of the coset
+transforms entering $\Phi_\ell$ and of Fricke-type involutions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_hasSum_qParam_heckeMatrix_smul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_hasSum_qParam_heckeMatrix_smul
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology Function
+open scoped MatrixGroups
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+
+namespace Realized
+
+theorem hasSum_qParam_heckeMatrix_smul' (ℓ : ℕ) [NeZero ℓ] (b : ℕ) (A : LaurentSeries ℂ) (F : ℍ → ℂ)
+    (hA : ∀ τ : ℍ, HasSum (fun m : ℤ => A.coeff m * 𝕢 1 (τ : ℂ) ^ m) (F τ)) (τ : ℍ) :
+    HasSum (fun m : ℤ => (Complex.exp (2 * Real.pi * Complex.I * b * m / ℓ) * A.coeff m) * 𝕢 ℓ (τ :
+      ℂ) ^ m)
+      (F (ModularForm.heckeMatrix ℓ b • τ)) := by
+  have hℓ : ℓ ≠ 0 := NeZero.ne ℓ
+  have hℓ' : (ℓ : ℂ) ≠ 0 := Nat.cast_ne_zero.mpr hℓ
+  have e : 𝕢 1 ((ModularForm.heckeMatrix ℓ b • τ : ℍ) : ℂ)
+      = Complex.exp (2 * Real.pi * Complex.I * b / ℓ) * 𝕢 ℓ (τ : ℂ) := by
+    rw [ModularForm.coe_heckeMatrix_smul hℓ, Periodic.qParam, Periodic.qParam, ← Complex.exp_add]
+    congr 1
+    push_cast
+    field_simp
+    ring
+  have e2 : ∀ m : ℤ, Complex.exp (2 * Real.pi * Complex.I * b / ℓ) ^ m
+      = Complex.exp (2 * Real.pi * Complex.I * b * m / ℓ) := by
+    intro m
+    rw [← Complex.exp_int_mul]
+    congr 1
+    ring
+  have hfg : (fun m : ℤ => (Complex.exp (2 * Real.pi * Complex.I * b * m / ℓ) * A.coeff m) * 𝕢 ℓ (τ
+    : ℂ) ^ m)
+      = fun m : ℤ => A.coeff m * 𝕢 1 ((ModularForm.heckeMatrix ℓ b • τ : ℍ) : ℂ) ^ m := by
+    funext m
+    rw [e, mul_zpow, e2]
+    ring
+  rw [hfg]
+  exact hA _
+
+end Realized
+
+end ModularCurve
+
+end
+
+theorem solution (ℓ : ℕ) [NeZero ℓ] (b : ℕ) (A : LaurentSeries ℂ) (F : UpperHalfPlane → ℂ) (hA : ∀ τ
+  : UpperHalfPlane, HasSum (fun m : ℤ => A.coeff m * Function.Periodic.qParam 1 (τ : ℂ) ^ m) (F τ))
+  (τ : UpperHalfPlane) :
+    HasSum (fun m : ℤ => (Complex.exp (2 * Real.pi * Complex.I * b * m / ℓ) * A.coeff m) *
+      Function.Periodic.qParam ℓ (τ : ℂ) ^ m) (F (ModularForm.heckeMatrix ℓ b • τ)) :=
+  ModularCurve.Realized.hasSum_qParam_heckeMatrix_smul' ℓ b A F hA τ
+
+end S_ModularCurve_hasSum_qParam_heckeMatrix_smul
+end P2MW
+export P2MW.S_ModularCurve_hasSum_qParam_heckeMatrix_smul (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.hasSum_qParam_heckeMatrix_smul (ℓ : ℕ) [NeZero ℓ] (b : ℕ) (A : LaurentSeries ℂ)
+  (F : UpperHalfPlane → ℂ) (hA : ∀ τ : UpperHalfPlane, HasSum (fun m : ℤ => A.coeff m *
+  Function.Periodic.qParam 1 (τ : ℂ) ^ m) (F τ)) (τ : UpperHalfPlane) :
+    HasSum (fun m : ℤ => (Complex.exp (2 * Real.pi * Complex.I * b * m / ℓ) * A.coeff m) *
+      Function.Periodic.qParam ℓ (τ : ℂ) ^ m) (F (ModularForm.heckeMatrix ℓ b • τ)) :=
+  solution ℓ b A F hA τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_qParam_mul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_qParam_mul.lean
new file mode 100644
index 0000000000..34e0e0b8d9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_qParam_mul.lean
@@ -0,0 +1,158 @@
+/-
+Based on Prove2Me node ModularCurve.hasSum_qParam_mul
+(80018164-7c58-5a39-86ee-244003282ffa) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 16c9c185-5ee9-57f9-b0aa-618fdd739fcd
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Exp
+public import Mathlib.RingTheory.PowerSeries.Basic
+
+import Mathlib.NumberTheory.ModularForms.QExpansion
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Products of convergent q-expansions on H
+
+Theorem statement: `ModularCurve.hasSum_qParam_mul` (`80018164-7c58-5a39-86ee-244003282ffa`), by
+Claude, 2026-09-05.
+
+Proof: submission `16c9c185-5ee9-57f9-b0aa-618fdd739fcd`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $h$ be a real number with $0 < h$, let $A, B \in \mathbb{C}[[q]]$ be formal power series over
+$\mathbb{C}$, and let $F, G \colon \mathfrak{H} \to \mathbb{C}$ be arbitrary functions on the upper
+half-plane. Assume that for every $\tau \in \mathfrak{H}$ the family $m \mapsto a_m\,
+\mathbf{q}_h(\tau)^m$, indexed by $m \in \mathbb{N}$, where $a_m$ is the $m$-th coefficient of $A$
+and $\mathbf{q}_h(\tau) = \exp(2\pi i \tau / h)$ is Mathlib's `Function.Periodic.qParam h (τ : ℂ)`,
+is summable with sum $F(\tau)$; and likewise that for every $\tau \in \mathfrak{H}$ the family $m
+\mapsto b_m\, \mathbf{q}_h(\tau)^m$ built from the coefficients of $B$ is summable with sum
+$G(\tau)$. Then for each $\tau \in \mathfrak{H}$ the family $m \mapsto c_m\, \mathbf{q}_h(\tau)^m$,
+where $c_m = \sum_{i+j=m} a_i b_j$ is the $m$-th coefficient of the product power series $A \cdot
+B$, is summable with sum $F(\tau) G(\tau)$. Note that the hypotheses are required at every point of
+$\mathfrak H$, while the conclusion is asserted at the single given point $\tau$.
+
+This is the statement that functions realised on the upper half-plane by convergent $q$-expansions
+at a fixed period $h$ are closed under multiplication, with the Cauchy product of the coefficient
+series computing the product function. It underlies the construction of integral $q$-expansions of
+Siegel units and of the associated modular forms for $\Gamma_1(N)$, which invoke it when multiplying
+$q$-expansions and taking powers.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_hasSum_qParam_mul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_hasSum_qParam_mul
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology Function
+open scoped MatrixGroups
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+
+namespace Realized
+
+theorem norm_qParam_lt_one_of_pos {h : ℝ} (hh : 0 < h) (τ : ℍ) : ‖𝕢 h (τ : ℂ)‖ < 1 := by
+  have := (Periodic.norm_qParam_lt_iff hh 0 (τ : ℂ)).mpr (by simpa using τ.im_pos)
+  simpa using this
+
+theorem summable_norm_of_hasSum_qParam {h : ℝ} (hh : 0 < h) {a : ℕ → ℂ} {F : ℍ → ℂ}
+    (hA : ∀ τ : ℍ, HasSum (fun m : ℕ => a m * 𝕢 h (τ : ℂ) ^ m) (F τ)) {q : ℂ} (hq : ‖q‖ < 1) :
+    Summable (fun m : ℕ => ‖a m * q ^ m‖) := by
+  obtain ⟨r, hqr, hr1⟩ := exists_between hq
+  have hr0 : 0 < r := (norm_nonneg q).trans_lt hqr
+  have hr1' : ‖(r : ℂ)‖ < 1 := by rwa [Complex.norm_real, Real.norm_of_nonneg hr0.le]
+  have hrne : (r : ℂ) ≠ 0 := ofReal_ne_zero.mpr hr0.ne'
+  let τ' : ℍ := ⟨Periodic.invQParam h r, Periodic.im_invQParam_pos_of_norm_lt_one hh hr1' hrne⟩
+  have hq' : 𝕢 h (τ' : ℂ) = r := Periodic.qParam_right_inv hh.ne' hrne
+  have hs : Summable (fun m : ℕ => a m * (r : ℂ) ^ m) := by
+    have := (hA τ').summable
+    rwa [hq'] at this
+  have hev : ∀ᶠ m : ℕ in cofinite, ‖a m * (r : ℂ) ^ m‖ < 1 :=
+    NormedAddGroup.tendsto_nhds_zero.mp hs.tendsto_cofinite_zero 1 one_pos
+  refine Summable.of_norm_bounded_eventually (g := fun m : ℕ => (‖q‖ / r) ^ m)
+    (summable_geometric_of_lt_one (by positivity) ((div_lt_one hr0).mpr hqr)) ?_
+  filter_upwards [hev] with m hm
+  rw [norm_norm, norm_mul, norm_pow, div_pow, le_div_iff₀ (pow_pos hr0 m)]
+  rw [norm_mul, norm_pow, Complex.norm_real, Real.norm_of_nonneg hr0.le] at hm
+  calc ‖a m‖ * ‖q‖ ^ m * r ^ m = (‖a m‖ * r ^ m) * ‖q‖ ^ m := by ring
+    _ ≤ 1 * ‖q‖ ^ m := by gcongr
+    _ = ‖q‖ ^ m := one_mul _
+
+theorem hasSum_qParam_mul' (h : ℝ) (hh : 0 < h) (A B : PowerSeries ℂ) (F G : ℍ → ℂ)
+    (hA : ∀ τ : ℍ, HasSum (fun m : ℕ => PowerSeries.coeff m A * 𝕢 h (τ : ℂ) ^ m) (F τ))
+    (hB : ∀ τ : ℍ, HasSum (fun m : ℕ => PowerSeries.coeff m B * 𝕢 h (τ : ℂ) ^ m) (G τ)) (τ : ℍ) :
+    HasSum (fun m : ℕ => PowerSeries.coeff m (A * B) * 𝕢 h (τ : ℂ) ^ m) (F τ * G τ) := by
+  set q : ℂ := 𝕢 h (τ : ℂ) with hqdef
+  have hq : ‖q‖ < 1 := norm_qParam_lt_one_of_pos hh τ
+  have hsA := summable_norm_of_hasSum_qParam hh hA hq
+  have hsB := summable_norm_of_hasSum_qParam hh hB hq
+  have key := tsum_mul_tsum_eq_tsum_sum_antidiagonal_of_summable_norm hsA hsB
+  have hsum : Summable (fun n : ℕ => ∑ kl ∈ Finset.HasAntidiagonal.antidiagonal n,
+      (PowerSeries.coeff kl.1 A * q ^ kl.1) * (PowerSeries.coeff kl.2 B * q ^ kl.2)) :=
+    (summable_norm_sum_mul_antidiagonal_of_summable_norm hsA hsB).of_norm
+  have H : HasSum (fun n : ℕ => ∑ kl ∈ Finset.HasAntidiagonal.antidiagonal n,
+      (PowerSeries.coeff kl.1 A * q ^ kl.1) * (PowerSeries.coeff kl.2 B * q ^ kl.2)) (F τ * G τ) :=
+        by
+    rw [← (hA τ).tsum_eq, ← (hB τ).tsum_eq, ← hqdef, key]
+    exact hsum.hasSum
+  have hfg : (fun m : ℕ => PowerSeries.coeff m (A * B) * q ^ m) = (fun n : ℕ => ∑ kl ∈
+    Finset.HasAntidiagonal.antidiagonal n,
+      (PowerSeries.coeff kl.1 A * q ^ kl.1) * (PowerSeries.coeff kl.2 B * q ^ kl.2)) := by
+    funext n
+    rw [PowerSeries.coeff_mul, Finset.sum_mul]
+    refine Finset.sum_congr rfl fun kl hkl => ?_
+    rw [Finset.HasAntidiagonal.mem_antidiagonal] at hkl
+    rw [← hkl, pow_add]
+    ring
+  rw [hfg]
+  exact H
+
+end Realized
+
+end ModularCurve
+
+end
+
+theorem solution (h : ℝ) (hh : 0 < h) (A B : PowerSeries ℂ) (F G : UpperHalfPlane → ℂ) (hA : ∀ τ :
+  UpperHalfPlane, HasSum (fun m : ℕ => PowerSeries.coeff m A * Function.Periodic.qParam h (τ : ℂ) ^
+  m) (F τ)) (hB : ∀ τ : UpperHalfPlane, HasSum (fun m : ℕ => PowerSeries.coeff m B *
+  Function.Periodic.qParam h (τ : ℂ) ^ m) (G τ)) (τ : UpperHalfPlane) :
+    HasSum (fun m : ℕ => PowerSeries.coeff m (A * B) * Function.Periodic.qParam h (τ : ℂ) ^ m) (F τ
+      * G τ) :=
+  ModularCurve.Realized.hasSum_qParam_mul' h hh A B F G hA hB τ
+
+end S_ModularCurve_hasSum_qParam_mul
+end P2MW
+export P2MW.S_ModularCurve_hasSum_qParam_mul (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.hasSum_qParam_mul (h : ℝ) (hh : 0 < h) (A B : PowerSeries ℂ) (F G :
+  UpperHalfPlane → ℂ) (hA : ∀ τ : UpperHalfPlane, HasSum (fun m : ℕ => PowerSeries.coeff m A *
+  Function.Periodic.qParam h (τ : ℂ) ^ m) (F τ)) (hB : ∀ τ : UpperHalfPlane, HasSum (fun m : ℕ =>
+  PowerSeries.coeff m B * Function.Periodic.qParam h (τ : ℂ) ^ m) (G τ)) (τ : UpperHalfPlane) :
+    HasSum (fun m : ℕ => PowerSeries.coeff m (A * B) * Function.Periodic.qParam h (τ : ℂ) ^ m) (F τ
+      * G τ) :=
+  solution h hh A B F G hA hB τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_qParam_mul_laurent.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_qParam_mul_laurent.lean
new file mode 100644
index 0000000000..426040731c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_qParam_mul_laurent.lean
@@ -0,0 +1,167 @@
+/-
+Based on Prove2Me node ModularCurve.hasSum_qParam_mul_laurent
+(5ca5ba5d-c794-56a8-8914-c255b7154dab) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a9766698-ae24-544f-a1b8-8ad57358ce4a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Exp
+public import Mathlib.RingTheory.LaurentSeries
+
+import Mathlib.NumberTheory.ModularForms.QExpansion
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_mul
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cauchy product of Laurent q-expansions on H
+
+Theorem statement: `ModularCurve.hasSum_qParam_mul_laurent`
+(`5ca5ba5d-c794-56a8-8914-c255b7154dab`), by Claude, 2026-09-05.
+
+Proof: submission `a9766698-ae24-544f-a1b8-8ad57358ce4a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $h$ be a real number with $0 < h$, let $A, B \in \mathbb{C}(\!(q)\!)$ be formal Laurent series
+over $\mathbb{C}$ (elements of `LaurentSeries ℂ`, i.e. Hahn series indexed by $\mathbb{Z}$), and let
+$F, G \colon \mathfrak H \to \mathbb{C}$ be arbitrary functions on the upper half-plane. Assume that
+for every $\tau \in \mathfrak H$ the family $m \mapsto A_m\, q_h(\tau)^m$, indexed by $m \in
+\mathbb{Z}$, is summable with sum $F(\tau)$, where $A_m$ denotes the coefficient of $A$ in degree
+$m$, $q_h(\tau) = \exp(2\pi i \tau / h)$ is the Mathlib nome `Function.Periodic.qParam h (τ : ℂ)`,
+and the power is an integer power; assume likewise that for every $\tau$ the family $m \mapsto B_m\,
+q_h(\tau)^m$ is summable with sum $G(\tau)$. Then for any prescribed $\tau \in \mathfrak H$ the
+family $m \mapsto (AB)_m\, q_h(\tau)^m$, $m \in \mathbb{Z}$, is summable with sum
+$F(\tau)\,G(\tau)$, the coefficients $(AB)_m$ being those of the product of $A$ and $B$ in the ring
+of formal Laurent series. Summability is unconditional summability of a family (`HasSum`), not
+convergence of a symmetric partial-sum limit.
+
+This is the Cauchy-product rule for $q$-expansions in the Laurent (meromorphic-at-the-cusp) setting,
+as needed for modular functions such as $j = q^{-1} + 744 + \cdots$ whose expansions have a pole at
+$\infty$. It is used throughout the project whenever a product of two functions given by convergent
+Laurent $q$-expansions is identified with the $q$-expansion of the product series, for instance in
+the work with hyperplane sections and coset polynomials on modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_hasSum_qParam_mul_laurent.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_hasSum_qParam_mul_laurent
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology Function
+open scoped MatrixGroups
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+p2m_export "ModularCurve" "hasSum_qParam_mul"
+p2m_open "ModularCurve"
+
+namespace Realized
+
+theorem hasSum_single_mul_coe_iff (k : ℤ) (P : PowerSeries ℂ) {q : ℂ} (hq : q ≠ 0) (t : ℂ) :
+    HasSum (fun m : ℤ => (HahnSeries.single k (1 : ℂ) * (P : LaurentSeries ℂ)).coeff m * q ^ m) (t *
+      q ^ k) ↔
+      HasSum (fun n : ℕ => PowerSeries.coeff n P * q ^ n) t := by
+  have hinj : Function.Injective (fun n : ℕ => (n : ℤ) + k) := fun a b hab => by simpa using hab
+  rw [← hinj.hasSum_iff]
+  · have hfg : (fun m : ℤ => (HahnSeries.single k (1 : ℂ) * (P : LaurentSeries ℂ)).coeff m * q ^ m)
+      ∘
+        (fun n : ℕ => (n : ℤ) + k) = fun n : ℕ => (PowerSeries.coeff n P * q ^ n) * q ^ k := by
+      funext n
+      simp only [Function.comp_apply]
+      rw [HahnSeries.coeff_single_mul_add, one_mul, LaurentSeries.coeff_coe_powerSeries, zpow_add₀
+        hq,
+        zpow_natCast]
+      ring
+    rw [hfg]
+    exact hasSum_mul_right_iff (zpow_ne_zero k hq)
+  · intro m hm
+    have hmk : m - k < 0 := by
+      by_contra hge
+      push Not at hge
+      exact hm ⟨(m - k).toNat, by simp only; omega⟩
+    rw [← sub_add_cancel m k, HahnSeries.coeff_single_mul_add, one_mul, PowerSeries.coeff_coe,
+      ite_eq_left hmk,
+      zero_mul]
+
+theorem hasSum_qParam_mul_laurent' (h : ℝ) (hh : 0 < h) (A B : LaurentSeries ℂ) (F G : ℍ → ℂ)
+    (hA : ∀ τ : ℍ, HasSum (fun m : ℤ => A.coeff m * 𝕢 h (τ : ℂ) ^ m) (F τ))
+    (hB : ∀ τ : ℍ, HasSum (fun m : ℤ => B.coeff m * 𝕢 h (τ : ℂ) ^ m) (G τ)) (τ : ℍ) :
+    HasSum (fun m : ℤ => (A * B).coeff m * 𝕢 h (τ : ℂ) ^ m) (F τ * G τ) := by
+  have hq0 : ∀ τ : ℍ, 𝕢 h (τ : ℂ) ≠ 0 := fun τ => Periodic.qParam_ne_zero _
+  set F' : ℍ → ℂ := fun τ => F τ * (𝕢 h (τ : ℂ) ^ A.order)⁻¹ with hF'
+  set G' : ℍ → ℂ := fun τ => G τ * (𝕢 h (τ : ℂ) ^ B.order)⁻¹ with hG'
+  have hA' : ∀ τ : ℍ, HasSum (fun n : ℕ => PowerSeries.coeff n A.powerSeriesPart * 𝕢 h (τ : ℂ) ^ n)
+    (F' τ) :=
+    by
+    intro τ
+    rw [← hasSum_single_mul_coe_iff A.order A.powerSeriesPart (hq0 τ),
+      A.single_order_mul_powerSeriesPart,
+      hF', inv_mul_cancel_right₀ (zpow_ne_zero _ (hq0 τ))]
+    exact hA τ
+  have hB' : ∀ τ : ℍ, HasSum (fun n : ℕ => PowerSeries.coeff n B.powerSeriesPart * 𝕢 h (τ : ℂ) ^ n)
+    (G' τ) :=
+    by
+    intro τ
+    rw [← hasSum_single_mul_coe_iff B.order B.powerSeriesPart (hq0 τ),
+      B.single_order_mul_powerSeriesPart,
+      hG', inv_mul_cancel_right₀ (zpow_ne_zero _ (hq0 τ))]
+    exact hB τ
+  have H := ModularCurve.hasSum_qParam_mul h hh A.powerSeriesPart B.powerSeriesPart F' G' hA' hB' τ
+  have hAB : HahnSeries.single (A.order + B.order) (1 : ℂ) *
+      ((A.powerSeriesPart * B.powerSeriesPart : PowerSeries ℂ) : LaurentSeries ℂ) = A * B := by
+    conv_rhs => rw [← A.single_order_mul_powerSeriesPart, ← B.single_order_mul_powerSeriesPart]
+    rw [PowerSeries.coe_mul, ← one_mul (1 : ℂ), ← HahnSeries.single_mul_single, one_mul]
+    ring
+  have hFG : F τ * G τ = F' τ * G' τ * 𝕢 h (τ : ℂ) ^ (A.order + B.order) := by
+    have hqτ := hq0 τ
+    simp only [hF', hG']
+    rw [zpow_add₀ hqτ]
+    field_simp
+  rw [← hAB, hFG]
+  exact (hasSum_single_mul_coe_iff _ _ (hq0 τ) _).mpr H
+
+end Realized
+
+end ModularCurve
+
+end
+
+theorem solution (h : ℝ) (hh : 0 < h) (A B : LaurentSeries ℂ) (F G : UpperHalfPlane → ℂ) (hA : ∀ τ :
+  UpperHalfPlane, HasSum (fun m : ℤ => A.coeff m * Function.Periodic.qParam h (τ : ℂ) ^ m) (F τ))
+  (hB : ∀ τ : UpperHalfPlane, HasSum (fun m : ℤ => B.coeff m * Function.Periodic.qParam h (τ : ℂ) ^
+  m) (G τ)) (τ : UpperHalfPlane) :
+    HasSum (fun m : ℤ => (A * B).coeff m * Function.Periodic.qParam h (τ : ℂ) ^ m) (F τ * G τ) :=
+  ModularCurve.Realized.hasSum_qParam_mul_laurent' h hh A B F G hA hB τ
+
+end S_ModularCurve_hasSum_qParam_mul_laurent
+end P2MW
+export P2MW.S_ModularCurve_hasSum_qParam_mul_laurent (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.hasSum_qParam_mul_laurent (h : ℝ) (hh : 0 < h) (A B : LaurentSeries ℂ) (F G :
+  UpperHalfPlane → ℂ) (hA : ∀ τ : UpperHalfPlane, HasSum (fun m : ℤ => A.coeff m *
+  Function.Periodic.qParam h (τ : ℂ) ^ m) (F τ)) (hB : ∀ τ : UpperHalfPlane, HasSum (fun m : ℤ =>
+  B.coeff m * Function.Periodic.qParam h (τ : ℂ) ^ m) (G τ)) (τ : UpperHalfPlane) :
+    HasSum (fun m : ℤ => (A * B).coeff m * Function.Periodic.qParam h (τ : ℂ) ^ m) (F τ * G τ) :=
+  solution h hh A B F G hA hB τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_smul_modularUnitSeries_inv_qParam.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_smul_modularUnitSeries_inv_qParam.lean
new file mode 100644
index 0000000000..53e68ad38e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_smul_modularUnitSeries_inv_qParam.lean
@@ -0,0 +1,421 @@
+/-
+Based on Prove2Me node ModularCurve.hasSum_smul_modularUnitSeries_inv_qParam
+(8d6b4a79-8c6a-527a-a302-f2da8aa65ed2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b8a89a2b-aa5c-507a-93e6-80021855654c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ModularUnit
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+
+import Mathlib.NumberTheory.ModularForms.QExpansion
+import Mathlib.NumberTheory.ModularForms.LevelOne.Basic
+import Mathlib.Analysis.Complex.TaylorSeries
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_mul_laurent
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurent_qParam_coeff_unique
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# q-expansion of Ogg's unit at the cusp 0
+
+Theorem statement: `ModularCurve.hasSum_smul_modularUnitSeries_inv_qParam`
+(`8d6b4a79-8c6a-527a-a302-f2da8aa65ed2`), by Claude, 2026-09-05.
+
+Proof: submission `b8a89a2b-aa5c-507a-93e6-80021855654c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a non-zero natural number and let $\tau$ lie in the upper half plane $\mathfrak H$.
+Consider the formal Laurent series over $\mathbb Q$ (Hahn series with value group $\mathbb Z$) given
+by [`ModularCurve.modularUnitSeries N`](def/ModularCurve_ModularUnit.html#L127) $=$ `deltaSeries`
+$\cdot$ `deltaSeriesN N`$^{-1}$, where `deltaSeries` is $q$ times the power series
+`dedekindEtaUnitQ` — that is, the $q$-expansion $q\prod_{n\ge1}(1-q^n)^{24}$ of the discriminant
+form, the integral model of whose unit factor satisfies
+[`ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit`]
+(thm.html#ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit)
+— and `deltaSeriesN N` is its image under $q\mapsto q^N$ (`qExpand`); thus `modularUnitSeries N`
+$=\Delta(q)/\Delta(q^N)$. The theorem asserts that, for the Laurent series
+$N^{12}\cdot(\mathtt{modularUnitSeries }N)^{-1}$, with the scalar $N^{12}\in\mathbb Q$ acting
+coefficientwise and the inverse taken in the field of formal Laurent series, the family indexed by
+$m\in\mathbb Z$ whose $m$-th term is the complex image of the $m$-th coefficient multiplied by
+$q_N(\tau)^m$, where $q_N(\tau)=$ `Function.Periodic.qParam N` $(\tau)=e^{2\pi i\tau/N}$, is
+summable with sum
+$$\frac{\Delta(S\tau)}{\Delta(N\,S\tau)},$$
+where $\Delta$ is `ModularForm.discriminant`, $S$ is the standard element of the modular group
+acting by $\tau\mapsto-1/\tau$, and multiplication by $N$ is the action of
+[`ModularForm.heckeDiagMatrix N`](def/ModularForm_HeckeOperator.html#L21), the matrix
+$\begin{pmatrix}N&0\\0&1\end{pmatrix}$. Summability is unconditional over all integers $m$ and is
+asserted for every $\tau$, with no primality assumption on $N$.
+
+This identifies the $q$-expansion, in the local parameter $e^{2\pi i\tau/N}$ at the width-$N$ cusp
+$0$, of Ogg's modular unit $\Delta(\tau)/\Delta(N\tau)$ on $X_0(N)$, the factor $N^{12}$ arising
+from applying $\Delta(-1/\tau)=\tau^{12}\Delta(\tau)$ at the two arguments. It feeds the computation
+of the Fricke involution on the unit
+([`ModularCurve.coe_frickeInvolutionFull_modularUnitSeries`]
+(thm.html#ModularCurve.coe_frickeInvolutionFull_modularUnitSeries)
+and its variant under a non-vanishing hypothesis) and the integrality of the unit over $\mathbb
+Q[j]$
+([`ModularCurve.isIntegral_adjoin_jq_modularUnitSeries`]
+(thm.html#ModularCurve.isIntegral_adjoin_jq_modularUnitSeries)).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_hasSum_smul_modularUnitSeries_inv_qParam.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_hasSum_smul_modularUnitSeries_inv_qParam
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology Function HahnSeries
+open scoped MatrixGroups ModularForm
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+p2m_export "ModularCurve" "dedekindEtaUnitQ deltaSeries isMonicOfOrder_deltaSeries \
+  deltaSeries_ne_zero deltaSeriesN isMonicOfOrder_deltaSeriesN modularUnitSeries qExpand_coeff_mul \
+  qExpand_coeff_of_not_dvd dedekindEtaUnit ofPowerSeries_coeff_of_neg \
+  qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit hasSum_qParam_mul_laurent \
+  laurent_qParam_coeff_unique"
+p2m_open "ModularCurve"
+
+namespace QexpN
+
+private def ratNRH : ℚ →ₙ+* ℂ := (Rat.castHom ℂ).toNonUnitalRingHom
+
+private def theta (x : LaurentSeries ℚ) : LaurentSeries ℂ := x.map ratNRH
+
+private theorem theta_coeff (x : LaurentSeries ℚ) (m : ℤ) :
+    (theta x).coeff m = ((x.coeff m : ℚ) : ℂ) := rfl
+
+private theorem theta_mul (x y : LaurentSeries ℚ) : theta (x * y) = theta x * theta y :=
+  HahnSeries.map_mul ratNRH
+
+private def gfun (q : ℂ) : ℂ := ∏' n : ℕ, (1 - q ^ (n + 1)) ^ 24
+
+private lemma differentiableOn_gfun : DifferentiableOn ℂ gfun (Metric.ball (0 : ℂ) 1) :=
+  ModularForm.differentiableOn_tprod_one_sub_pow_pow 24
+
+private lemma gfun_ne_zero {q : ℂ} (hq : ‖q‖ < 1) : gfun q ≠ 0 := by
+  rw [gfun, (ModularForm.multipliable_one_sub_pow hq).tprod_pow]
+  refine pow_ne_zero _ (tprod_one_add_ne_zero_of_summable (f := fun n => -q ^ (n + 1)) ?_ ?_)
+  · intro i
+    have h1 : ‖q ^ (i + 1)‖ < 1 := by
+      rw [norm_pow]; exact pow_lt_one₀ (norm_nonneg _) hq (Nat.succ_ne_zero i)
+    intro h
+    rw [add_neg_eq_zero] at h
+    rw [← h, norm_one] at h1
+    exact lt_irrefl _ h1
+  · simpa [summable_nat_add_iff 1] using summable_geometric_of_lt_one (norm_nonneg _) hq
+
+private lemma discriminant_eq_qParam_mul_gfun (τ : ℍ) :
+    ModularForm.discriminant τ = 𝕢 1 (τ : ℂ) * gfun (𝕢 1 (τ : ℂ)) := by
+  rw [ModularForm.discriminant_eq_q_prod, gfun]
+
+private theorem hasSum_single_mul_coe_iff (k : ℤ) (P : PowerSeries ℂ) {q : ℂ} (hq : q ≠ 0) (t : ℂ) :
+    HasSum (fun m : ℤ => (HahnSeries.single k (1 : ℂ) * (P : LaurentSeries ℂ)).coeff m * q ^ m) (t *
+      q ^ k) ↔
+      HasSum (fun n : ℕ => PowerSeries.coeff n P * q ^ n) t := by
+  have hinj : Function.Injective (fun n : ℕ => (n : ℤ) + k) := fun a b hab => by simpa using hab
+  rw [← hinj.hasSum_iff]
+  · have hfg : (fun m : ℤ => (HahnSeries.single k (1 : ℂ) * (P : LaurentSeries ℂ)).coeff m * q ^ m)
+      ∘
+        (fun n : ℕ => (n : ℤ) + k) = fun n : ℕ => (PowerSeries.coeff n P * q ^ n) * q ^ k := by
+      funext n
+      simp only [Function.comp_apply]
+      rw [HahnSeries.coeff_single_mul_add, one_mul, LaurentSeries.coeff_coe_powerSeries, zpow_add₀
+        hq,
+        zpow_natCast]
+      ring
+    rw [hfg]
+    exact hasSum_mul_right_iff (zpow_ne_zero k hq)
+  · intro m hm
+    have hmk : m - k < 0 := by
+      by_contra hge
+      push Not at hge
+      exact hm ⟨(m - k).toNat, by simp only; omega⟩
+    rw [← sub_add_cancel m k, HahnSeries.coeff_single_mul_add, one_mul, PowerSeries.coeff_coe,
+      ite_eq_left hmk,
+      zero_mul]
+
+private theorem hasSum_theta_deltaSeries (τ : ℍ) :
+    HasSum (fun m : ℤ => (theta deltaSeries).coeff m * 𝕢 1 (τ : ℂ) ^ m)
+      (ModularForm.discriminant τ) := by
+  have hper : Function.Periodic (ModularForm.discriminant ∘ UpperHalfPlane.ofComplex) 1 :=
+    SlashInvariantFormClass.periodic_comp_ofComplex CuspForm.discriminant one_mem_strictPeriods_SL
+  have hmdiff := ModularFormClass.holo CuspForm.discriminant
+  have hbdd : IsBoundedAtImInfty ModularForm.discriminant :=
+    ModularForm.discriminant_isZeroAtImInfty.boundedAtFilter
+  have h := hasSum_qExpansion one_pos hper hmdiff hbdd τ
+  rw [ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit] at h
+  have hinj : Function.Injective ((↑) : ℕ → ℤ) := fun a b hab => by exact_mod_cast hab
+  rw [← hinj.hasSum_iff]
+  · refine h.congr_fun fun n => ?_
+    simp only [Function.comp_apply, theta_coeff, smul_eq_mul]
+    rcases n with - | k
+    · rw [show ((0 : ℕ) : ℤ) = (0 : ℤ) from rfl, deltaSeries, HahnSeries.coeff_single_mul, one_mul,
+        ModularCurve.ofPowerSeries_coeff_of_neg _ (by norm_num), PowerSeries.coeff_map,
+        PowerSeries.coeff_zero_X_mul]
+      norm_num
+    · rw [deltaSeries, HahnSeries.coeff_single_mul, one_mul,
+        show ((k + 1 : ℕ) : ℤ) - 1 = ((k : ℕ) : ℤ) by push_cast; ring,
+        HahnSeries.ofPowerSeries_apply_coeff, dedekindEtaUnitQ, PowerSeries.coeff_map,
+        PowerSeries.coeff_map, PowerSeries.coeff_succ_X_mul, zpow_natCast, eq_intCast,
+        eq_intCast, Rat.cast_intCast]
+  · intro m hm
+    have hm' : m < 0 := by
+      by_contra hge
+      push Not at hge
+      exact hm ⟨m.toNat, by simp; omega⟩
+    rw [theta_coeff, ModularCurve.isMonicOfOrder_deltaSeries.coeff_of_lt (by omega),
+      Rat.cast_zero, zero_mul]
+
+private theorem qParam_heckeDiagMatrix_smul {N : ℕ} (hN : N ≠ 0) (τ : ℍ) :
+    𝕢 1 ((ModularForm.heckeDiagMatrix N • τ : ℍ) : ℂ) = 𝕢 1 (τ : ℂ) ^ N := by
+  rw [ModularForm.coe_heckeDiagMatrix_smul hN, Periodic.qParam, Periodic.qParam,
+    ← Complex.exp_nat_mul]
+  congr 1
+  push_cast
+  ring
+
+private theorem hasSum_theta_deltaSeriesN (N : ℕ) [NeZero N] (τ : ℍ) :
+    HasSum (fun m : ℤ => (theta (deltaSeriesN N)).coeff m * 𝕢 1 (τ : ℂ) ^ m)
+      (ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)) := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hNZ : ((N : ℕ) : ℤ) ≠ 0 := by exact_mod_cast hN
+  have h := hasSum_theta_deltaSeries (ModularForm.heckeDiagMatrix N • τ)
+  have e : 𝕢 1 ((ModularForm.heckeDiagMatrix N • τ : ℍ) : ℂ) = 𝕢 1 (τ : ℂ) ^ ((N : ℕ) : ℤ) := by
+    rw [qParam_heckeDiagMatrix_smul hN, zpow_natCast]
+  have hinj : Function.Injective (fun m : ℤ => ((N : ℕ) : ℤ) * m) := mul_right_injective₀ hNZ
+  rw [← hinj.hasSum_iff]
+  · have hfg : (fun m : ℤ => (theta (deltaSeriesN N)).coeff m * 𝕢 1 (τ : ℂ) ^ m) ∘
+        (fun m : ℤ => ((N : ℕ) : ℤ) * m)
+        = fun m : ℤ => (theta deltaSeries).coeff m * 𝕢 1 ((ModularForm.heckeDiagMatrix N • τ : ℍ) :
+          ℂ) ^ m := by
+      funext m
+      simp only [Function.comp_apply, theta_coeff, deltaSeriesN]
+      rw [ModularCurve.qExpand_coeff_mul, e, ← zpow_mul]
+    rw [hfg]
+    exact h
+  · intro m hm
+    rw [theta_coeff, deltaSeriesN,
+      ModularCurve.qExpand_coeff_of_not_dvd N deltaSeries (fun ⟨c, hc⟩ => hm ⟨c, hc.symm⟩),
+      Rat.cast_zero, zero_mul]
+
+private theorem theta_deltaSeriesN_ne_zero (N : ℕ) [NeZero N] : theta (deltaSeriesN N) ≠ 0 := by
+  have h1 : (theta (deltaSeriesN N)).coeff ((N : ℕ) : ℤ) = 1 := by
+    rw [theta_coeff, (ModularCurve.isMonicOfOrder_deltaSeriesN N).coeff_self, Rat.cast_one]
+  exact HahnSeries.ne_zero_of_coeff_ne_zero (h1 ▸ one_ne_zero)
+
+private theorem theta_deltaSeries_ne_zero : theta deltaSeries ≠ 0 := by
+  have h1 : (theta deltaSeries).coeff (1 : ℤ) = 1 := by
+    rw [theta_coeff, ModularCurve.isMonicOfOrder_deltaSeries.coeff_self, Rat.cast_one]
+  exact HahnSeries.ne_zero_of_coeff_ne_zero (h1 ▸ one_ne_zero)
+
+private def phiFun (N : ℕ) : ℂ → ℂ := fun w => gfun w / gfun (w ^ N)
+
+private def psiFun (N : ℕ) : ℂ → ℂ := fun w => gfun (w ^ N) / gfun w
+
+private lemma pow_mem_ball {N : ℕ} [NeZero N] {w : ℂ} (hw : w ∈ Metric.ball (0 : ℂ) 1) :
+    w ^ N ∈ Metric.ball (0 : ℂ) 1 := by
+  rw [Metric.mem_ball, dist_zero_right] at hw ⊢
+  rw [norm_pow]
+  exact pow_lt_one₀ (norm_nonneg _) hw (NeZero.ne N)
+
+private lemma differentiableOn_gfun_pow (N : ℕ) [NeZero N] :
+    DifferentiableOn ℂ (fun w : ℂ => gfun (w ^ N)) (Metric.ball (0 : ℂ) 1) :=
+  differentiableOn_gfun.comp ((differentiable_pow N).differentiableOn)
+    fun _ hw => pow_mem_ball hw
+
+private lemma differentiableOn_phiFun (N : ℕ) [NeZero N] :
+    DifferentiableOn ℂ (phiFun N) (Metric.ball (0 : ℂ) 1) := by
+  refine DifferentiableOn.div differentiableOn_gfun (differentiableOn_gfun_pow N)
+    fun w hw => gfun_ne_zero ?_
+  have := pow_mem_ball (N := N) hw
+  rwa [Metric.mem_ball, dist_zero_right] at this
+
+private lemma differentiableOn_psiFun (N : ℕ) [NeZero N] :
+    DifferentiableOn ℂ (psiFun N) (Metric.ball (0 : ℂ) 1) := by
+  refine DifferentiableOn.div (differentiableOn_gfun_pow N) differentiableOn_gfun
+    fun w hw => gfun_ne_zero ?_
+  rwa [Metric.mem_ball, dist_zero_right] at hw
+
+private def taylorCoeff (f : ℂ → ℂ) (n : ℕ) : ℂ := ((n.factorial : ℂ))⁻¹ * iteratedDeriv n f 0
+
+private lemma hasSum_taylorCoeff {f : ℂ → ℂ}
+    (hf : DifferentiableOn ℂ f (Metric.ball (0 : ℂ) 1)) {q : ℂ} (hq : ‖q‖ < 1) :
+    HasSum (fun n : ℕ => taylorCoeff f n * q ^ n) (f q) := by
+  have h := Complex.hasSum_taylorSeries_on_ball hf
+    (show q ∈ Metric.ball (0 : ℂ) 1 by rwa [Metric.mem_ball, dist_zero_right])
+  refine h.congr_fun fun n => ?_
+  rw [taylorCoeff, sub_zero, smul_eq_mul, smul_eq_mul]
+  ring
+
+private theorem modularUnitSeries_inv_mul (N : ℕ) [NeZero N] :
+    (ModularCurve.modularUnitSeries N)⁻¹ * deltaSeries = deltaSeriesN N := by
+  rw [ModularCurve.modularUnitSeries, mul_inv_rev, inv_inv, mul_assoc,
+    inv_mul_cancel₀ ModularCurve.deltaSeries_ne_zero, mul_one]
+
+private theorem hasSum_modularUnitInv (N : ℕ) [NeZero N] (τ₀ : ℍ) :
+    HasSum (fun m : ℤ => ((((ModularCurve.modularUnitSeries N)⁻¹).coeff m : ℚ) : ℂ)
+        * 𝕢 1 (τ₀ : ℂ) ^ m)
+      (ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ₀)
+        / ModularForm.discriminant τ₀) := by
+  have hq0 : ∀ τ : ℍ, 𝕢 1 (τ : ℂ) ≠ 0 := fun τ => Periodic.qParam_ne_zero _
+  have hqlt : ∀ τ : ℍ, ‖𝕢 1 (τ : ℂ)‖ < 1 := fun τ => by
+    exact_mod_cast UpperHalfPlane.norm_qParam_lt_one 1 τ
+  set B : LaurentSeries ℂ := HahnSeries.single ((N : ℤ) - 1) 1
+    * ((PowerSeries.mk (taylorCoeff (psiFun N)) : PowerSeries ℂ) : LaurentSeries ℂ) with hB
+  have hval : ∀ τ : ℍ,
+      ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ) / ModularForm.discriminant τ
+      = psiFun N (𝕢 1 (τ : ℂ)) * 𝕢 1 (τ : ℂ) ^ ((N : ℤ) - 1) := by
+    intro τ
+    have hq := hq0 τ
+    have hgq : gfun (𝕢 1 (τ : ℂ)) ≠ 0 := gfun_ne_zero (hqlt τ)
+    have hgN : gfun (𝕢 1 (τ : ℂ) ^ N) ≠ 0 := gfun_ne_zero (by
+      rw [norm_pow]; exact pow_lt_one₀ (norm_nonneg _) (hqlt τ) (NeZero.ne N))
+    have hqN : 𝕢 1 (τ : ℂ) ^ N ≠ 0 := pow_ne_zero _ hq
+    rw [discriminant_eq_qParam_mul_gfun τ,
+      discriminant_eq_qParam_mul_gfun (ModularForm.heckeDiagMatrix N • τ),
+      qParam_heckeDiagMatrix_smul (NeZero.ne N), psiFun, zpow_sub₀ hq, zpow_one, zpow_natCast]
+    field_simp
+  have hBsum : ∀ τ : ℍ, HasSum (fun m : ℤ => B.coeff m * 𝕢 1 (τ : ℂ) ^ m)
+      (ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)
+        / ModularForm.discriminant τ) := by
+    intro τ
+    rw [hval τ, hB]
+    refine (hasSum_single_mul_coe_iff ((N : ℤ) - 1) _ (hq0 τ) _).mpr ?_
+    refine (hasSum_taylorCoeff (differentiableOn_psiFun N) (hqlt τ)).congr_fun fun n => ?_
+    rw [PowerSeries.coeff_mk]
+  have hprod : ∀ τ : ℍ, HasSum
+      (fun m : ℤ => (B * theta deltaSeries).coeff m * 𝕢 1 (τ : ℂ) ^ m)
+      (ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)) := by
+    intro τ
+    have h := ModularCurve.hasSum_qParam_mul_laurent 1 one_pos B (theta deltaSeries)
+      (fun τ => ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)
+        / ModularForm.discriminant τ)
+      (fun τ => ModularForm.discriminant τ)
+      hBsum hasSum_theta_deltaSeries τ
+    have h2 : HasSum (fun m : ℤ => (B * theta deltaSeries).coeff m * 𝕢 1 (τ : ℂ) ^ m)
+        (ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)
+            / ModularForm.discriminant τ * ModularForm.discriminant τ) := h
+    rwa [div_mul_cancel₀ _ (ModularForm.discriminant_ne_zero _)] at h2
+  have huniq : B * theta deltaSeries = theta (deltaSeriesN N) :=
+    ModularCurve.laurent_qParam_coeff_unique 1 one_pos
+      (fun τ => ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)) _ _ hprod
+      (hasSum_theta_deltaSeriesN N)
+  have hTheta : theta ((ModularCurve.modularUnitSeries N)⁻¹) * theta deltaSeries
+      = theta (deltaSeriesN N) := by
+    rw [← theta_mul, modularUnitSeries_inv_mul]
+  have hBu : B = theta ((ModularCurve.modularUnitSeries N)⁻¹) :=
+    mul_right_cancel₀ theta_deltaSeries_ne_zero (huniq.trans hTheta.symm)
+  have h := hBsum τ₀
+  rw [hBu] at h
+  refine h.congr_fun fun m => ?_
+  rw [theta_coeff]
+
+private theorem discriminant_S_smul (z : ℍ) :
+    ModularForm.discriminant (ModularGroup.S • z)
+      = (z : ℂ) ^ (12 : ℕ) * ModularForm.discriminant z := by
+  have hS : (Matrix.SpecialLinearGroup.mapGL ℝ ModularGroup.S : GL (Fin 2) ℝ) ∈ 𝒮ℒ :=
+    ⟨ModularGroup.S, rfl⟩
+  have h1 : ModularForm.discriminant (ModularGroup.S • z)
+      = UpperHalfPlane.denom (Matrix.SpecialLinearGroup.mapGL ℝ ModularGroup.S) (z : ℂ) ^ (12 : ℤ)
+        * ModularForm.discriminant z := by
+    have h__af := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hS z
+    simp only [CuspForm.coe_discriminant, zpow_ofNat] at h__af
+    exact h__af
+  rw [show UpperHalfPlane.denom (Matrix.SpecialLinearGroup.mapGL ℝ ModularGroup.S) (z : ℂ)
+      = (z : ℂ) from ModularGroup.denom_S z,
+    show ((12 : ℤ)) = ((12 : ℕ) : ℤ) by norm_num, zpow_natCast] at h1
+  exact h1
+
+private theorem hasSum_smul_inv (N : ℕ) [NeZero N] (τ : ℍ) :
+    HasSum (fun m : ℤ => ((((N : ℚ) ^ 12 • (ModularCurve.modularUnitSeries N)⁻¹).coeff m : ℚ) : ℂ)
+        * 𝕢 (N : ℝ) (τ : ℂ) ^ m)
+      (ModularForm.discriminant (ModularGroup.S • τ)
+        / ModularForm.discriminant (ModularForm.heckeDiagMatrix N • ModularGroup.S • τ)) := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hN0 : (N : ℂ) ≠ 0 := Nat.cast_ne_zero.mpr hN
+  have hNR : (0 : ℝ) < (N : ℝ) := by exact_mod_cast Nat.pos_of_ne_zero hN
+  have him : 0 < ((τ : ℂ) / (N : ℂ)).im := by
+    rw [show ((N : ℂ)) = (((N : ℝ)) : ℂ) by push_cast; rfl, Complex.div_ofReal_im]
+    exact div_pos (by rw [UpperHalfPlane.coe_im]; exact τ.im_pos) hNR
+  set w : ℍ := ⟨(τ : ℂ) / (N : ℂ), him⟩ with hwdef
+  have hwcoe : (w : ℂ) = (τ : ℂ) / (N : ℂ) := rfl
+  have hτ0 : (τ : ℂ) ≠ 0 := UpperHalfPlane.ne_zero τ
+  have hΔw : ModularForm.discriminant w ≠ 0 := ModularForm.discriminant_ne_zero w
+  have hqlink : 𝕢 (N : ℝ) (τ : ℂ) = 𝕢 1 (w : ℂ) := by
+    rw [Periodic.qParam, Periodic.qParam, hwcoe]
+    congr 1
+    push_cast
+    field_simp
+  have hNw : ModularForm.heckeDiagMatrix N • w = τ := by
+    refine UpperHalfPlane.ext ?_
+    rw [ModularForm.coe_heckeDiagMatrix_smul hN, hwcoe]
+    field_simp
+  have hSτcoe : ((ModularGroup.S • τ : ℍ) : ℂ) = (-(τ : ℂ))⁻¹ := by
+    rw [UpperHalfPlane.modular_S_smul, UpperHalfPlane.coe_mk]
+  have hSwcoe : ((ModularGroup.S • w : ℍ) : ℂ) = (-(w : ℂ))⁻¹ := by
+    rw [UpperHalfPlane.modular_S_smul, UpperHalfPlane.coe_mk]
+  have hSw : ModularForm.heckeDiagMatrix N • ModularGroup.S • τ = ModularGroup.S • w := by
+    refine UpperHalfPlane.ext ?_
+    rw [ModularForm.coe_heckeDiagMatrix_smul hN, hSτcoe, hSwcoe, hwcoe]
+    field_simp
+  have hvalue : ModularForm.discriminant (ModularGroup.S • τ)
+      / ModularForm.discriminant (ModularForm.heckeDiagMatrix N • ModularGroup.S • τ)
+      = (N : ℂ) ^ (12 : ℕ)
+        * (ModularForm.discriminant (ModularForm.heckeDiagMatrix N • w)
+          / ModularForm.discriminant w) := by
+    rw [hSw, discriminant_S_smul τ, discriminant_S_smul w, hNw, hwcoe]
+    field_simp
+  have h := (hasSum_modularUnitInv N w).mul_left ((N : ℂ) ^ (12 : ℕ))
+  rw [hvalue]
+  refine h.congr_fun fun m => ?_
+  rw [HahnSeries.coeff_smul, smul_eq_mul, hqlink]
+  push_cast
+  ring
+
+end QexpN
+
+end ModularCurve
+
+end
+
+theorem solution (N : ℕ) [NeZero N] (τ : UpperHalfPlane) :
+    HasSum (fun m : ℤ => ((((N : ℚ) ^ 12 • (ModularCurve.modularUnitSeries N)⁻¹).coeff m : ℚ) : ℂ) *
+      Function.Periodic.qParam N (τ : ℂ) ^ m) (ModularForm.discriminant (ModularGroup.S • τ) /
+      ModularForm.discriminant (ModularForm.heckeDiagMatrix N • ModularGroup.S • τ)) :=
+  ModularCurve.QexpN.hasSum_smul_inv N τ
+
+end S_ModularCurve_hasSum_smul_modularUnitSeries_inv_qParam
+end P2MW
+export P2MW.S_ModularCurve_hasSum_smul_modularUnitSeries_inv_qParam (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.hasSum_smul_modularUnitSeries_inv_qParam (N : ℕ) [NeZero N]
+    (τ : UpperHalfPlane) :
+    HasSum (fun m : ℤ => ((((N : ℚ) ^ 12 • (ModularCurve.modularUnitSeries N)⁻¹).coeff m : ℚ) : ℂ) *
+      Function.Periodic.qParam N (τ : ℂ) ^ m) (ModularForm.discriminant (ModularGroup.S • τ) /
+      ModularForm.discriminant (ModularForm.heckeDiagMatrix N • ModularGroup.S • τ)) :=
+  solution N τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_smul_modularUnitSeries_qParam.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_smul_modularUnitSeries_qParam.lean
new file mode 100644
index 0000000000..a3c81fdf44
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_hasSum_smul_modularUnitSeries_qParam.lean
@@ -0,0 +1,407 @@
+/-
+Based on Prove2Me node ModularCurve.hasSum_smul_modularUnitSeries_qParam
+(e3d1ec42-892a-5646-8975-aea50d1a8e12) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1a386e13-c93d-512e-8caf-9e0d07a38984
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ModularUnit
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+
+import Mathlib.NumberTheory.ModularForms.QExpansion
+import Mathlib.NumberTheory.ModularForms.LevelOne.Basic
+import Mathlib.Analysis.Complex.TaylorSeries
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_mul_laurent
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurent_qParam_coeff_unique
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# q_N-expansion of Ogg's unit at the cusp 0
+
+Theorem statement: `ModularCurve.hasSum_smul_modularUnitSeries_qParam`
+(`e3d1ec42-892a-5646-8975-aea50d1a8e12`), by Claude, 2026-09-05.
+
+Proof: submission `1a386e13-c93d-512e-8caf-9e0d07a38984`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and let $\tau$ lie in the upper half plane. Write $\Delta$ for
+Mathlib's `ModularForm.discriminant`, $S$ for the matrix $\begin{pmatrix}0&-1\\1&0\end{pmatrix}$
+acting as $\tau\mapsto-1/\tau$ (`ModularGroup.S`), and [`ModularForm.heckeDiagMatrix
+N`](def/ModularForm_HeckeOperator.html#L21) for the element of $\mathrm{GL}_2(\mathbb{R})$ given by
+$\begin{pmatrix}N&0\\0&1\end{pmatrix}$, whose action sends $\tau$ to $N\tau$. On the formal side,
+[`ModularCurve.deltaSeries`](def/ModularCurve_ModularUnit.html#L107) is the Laurent series over
+$\mathbb{Q}$ equal to $q$ times the power series `dedekindEtaUnitQ` (the rational $\eta$-product
+unit $\prod_{n\ge1}(1-q^n)^{24}$, whose integral form appears in the $q$-expansion of $\Delta$),
+`deltaSeriesN N` is its image under the substitution $q\mapsto q^{N}$ (`qExpand ℚ N`), and
+[`ModularCurve.modularUnitSeries N`](def/ModularCurve_ModularUnit.html#L127) is the quotient
+$\mathrm{deltaSeries}\cdot(\mathrm{deltaSeriesN}\,N)^{-1}$, i.e.
+$q^{1-N}\prod_{n\ge1}(1-q^{n})^{24}(1-q^{Nn})^{-24}$ in $\mathbb{Q}((q))$. The assertion is that,
+with $a_m\in\mathbb{Q}$ the $m$-th coefficient ($m\in\mathbb{Z}$) of the rational rescaling
+$(N^{12})^{-1}\cdot\mathrm{modularUnitSeries}\,N$, the family $m\mapsto a_m\,q_N^{\,m}$, where
+$q_N=\mathtt{qParam}\,N\,\tau=e^{2\pi i\tau/N}$, is summable with sum $\Delta(N\cdot
+S\tau)/\Delta(S\tau)$; the convergence statement is `HasSum` over all of $\mathbb{Z}$ and holds for
+every $\tau$ in the upper half plane.
+
+This identifies the formal Laurent series $N^{-12}\,\Delta(q)/\Delta(q^{N})$, read in the parameter
+$q_N=e^{2\pi i\tau/N}$, as the expansion at the cusp $0$ of the modular unit on $X_0(N)$ attached to
+$\Delta(N\tau)/\Delta(\tau)$ (Ogg's unit), the cusp-$0$ counterpart of its expansion at $\infty$. It
+feeds the proofs that [`ModularCurve.modularUnitSeries`](def/ModularCurve_ModularUnit.html#L127)
+lies in the modular function field and that it and its inverse are integral over $\mathbb{Q}[j]$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_hasSum_smul_modularUnitSeries_qParam.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_hasSum_smul_modularUnitSeries_qParam
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology Function HahnSeries
+open scoped MatrixGroups ModularForm
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+p2m_export "ModularCurve" "dedekindEtaUnitQ deltaSeries isMonicOfOrder_deltaSeries deltaSeriesN \
+  isMonicOfOrder_deltaSeriesN modularUnitSeries modularUnitSeries_mul_deltaSeriesN \
+  qExpand_coeff_mul qExpand_coeff_of_not_dvd dedekindEtaUnit ofPowerSeries_coeff_of_neg \
+  qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit hasSum_qParam_mul_laurent \
+  laurent_qParam_coeff_unique"
+p2m_open "ModularCurve"
+
+namespace QexpN
+
+private def ratNRH : ℚ →ₙ+* ℂ := (Rat.castHom ℂ).toNonUnitalRingHom
+
+private def theta (x : LaurentSeries ℚ) : LaurentSeries ℂ := x.map ratNRH
+
+private theorem theta_coeff (x : LaurentSeries ℚ) (m : ℤ) :
+    (theta x).coeff m = ((x.coeff m : ℚ) : ℂ) := rfl
+
+private theorem theta_mul (x y : LaurentSeries ℚ) : theta (x * y) = theta x * theta y :=
+  HahnSeries.map_mul ratNRH
+
+private def gfun (q : ℂ) : ℂ := ∏' n : ℕ, (1 - q ^ (n + 1)) ^ 24
+
+private lemma differentiableOn_gfun : DifferentiableOn ℂ gfun (Metric.ball (0 : ℂ) 1) :=
+  ModularForm.differentiableOn_tprod_one_sub_pow_pow 24
+
+private lemma gfun_ne_zero {q : ℂ} (hq : ‖q‖ < 1) : gfun q ≠ 0 := by
+  rw [gfun, (ModularForm.multipliable_one_sub_pow hq).tprod_pow]
+  refine pow_ne_zero _ (tprod_one_add_ne_zero_of_summable (f := fun n => -q ^ (n + 1)) ?_ ?_)
+  · intro i
+    have h1 : ‖q ^ (i + 1)‖ < 1 := by
+      rw [norm_pow]; exact pow_lt_one₀ (norm_nonneg _) hq (Nat.succ_ne_zero i)
+    intro h
+    rw [add_neg_eq_zero] at h
+    rw [← h, norm_one] at h1
+    exact lt_irrefl _ h1
+  · simpa [summable_nat_add_iff 1] using summable_geometric_of_lt_one (norm_nonneg _) hq
+
+private lemma discriminant_eq_qParam_mul_gfun (τ : ℍ) :
+    ModularForm.discriminant τ = 𝕢 1 (τ : ℂ) * gfun (𝕢 1 (τ : ℂ)) := by
+  rw [ModularForm.discriminant_eq_q_prod, gfun]
+
+private theorem hasSum_single_mul_coe_iff (k : ℤ) (P : PowerSeries ℂ) {q : ℂ} (hq : q ≠ 0) (t : ℂ) :
+    HasSum (fun m : ℤ => (HahnSeries.single k (1 : ℂ) * (P : LaurentSeries ℂ)).coeff m * q ^ m) (t *
+      q ^ k) ↔
+      HasSum (fun n : ℕ => PowerSeries.coeff n P * q ^ n) t := by
+  have hinj : Function.Injective (fun n : ℕ => (n : ℤ) + k) := fun a b hab => by simpa using hab
+  rw [← hinj.hasSum_iff]
+  · have hfg : (fun m : ℤ => (HahnSeries.single k (1 : ℂ) * (P : LaurentSeries ℂ)).coeff m * q ^ m)
+      ∘
+        (fun n : ℕ => (n : ℤ) + k) = fun n : ℕ => (PowerSeries.coeff n P * q ^ n) * q ^ k := by
+      funext n
+      simp only [Function.comp_apply]
+      rw [HahnSeries.coeff_single_mul_add, one_mul, LaurentSeries.coeff_coe_powerSeries, zpow_add₀
+        hq,
+        zpow_natCast]
+      ring
+    rw [hfg]
+    exact hasSum_mul_right_iff (zpow_ne_zero k hq)
+  · intro m hm
+    have hmk : m - k < 0 := by
+      by_contra hge
+      push Not at hge
+      exact hm ⟨(m - k).toNat, by simp only; omega⟩
+    rw [← sub_add_cancel m k, HahnSeries.coeff_single_mul_add, one_mul, PowerSeries.coeff_coe,
+      ite_eq_left hmk,
+      zero_mul]
+
+private theorem hasSum_theta_deltaSeries (τ : ℍ) :
+    HasSum (fun m : ℤ => (theta deltaSeries).coeff m * 𝕢 1 (τ : ℂ) ^ m)
+      (ModularForm.discriminant τ) := by
+  have hper : Function.Periodic (ModularForm.discriminant ∘ UpperHalfPlane.ofComplex) 1 :=
+    SlashInvariantFormClass.periodic_comp_ofComplex CuspForm.discriminant one_mem_strictPeriods_SL
+  have hmdiff := ModularFormClass.holo CuspForm.discriminant
+  have hbdd : IsBoundedAtImInfty ModularForm.discriminant :=
+    ModularForm.discriminant_isZeroAtImInfty.boundedAtFilter
+  have h := hasSum_qExpansion one_pos hper hmdiff hbdd τ
+  rw [ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit] at h
+  have hinj : Function.Injective ((↑) : ℕ → ℤ) := fun a b hab => by exact_mod_cast hab
+  rw [← hinj.hasSum_iff]
+  · refine h.congr_fun fun n => ?_
+    simp only [Function.comp_apply, theta_coeff, smul_eq_mul]
+    rcases n with - | k
+    · rw [show ((0 : ℕ) : ℤ) = (0 : ℤ) from rfl, deltaSeries, HahnSeries.coeff_single_mul, one_mul,
+        ModularCurve.ofPowerSeries_coeff_of_neg _ (by norm_num), PowerSeries.coeff_map,
+        PowerSeries.coeff_zero_X_mul]
+      norm_num
+    · rw [deltaSeries, HahnSeries.coeff_single_mul, one_mul,
+        show ((k + 1 : ℕ) : ℤ) - 1 = ((k : ℕ) : ℤ) by push_cast; ring,
+        HahnSeries.ofPowerSeries_apply_coeff, dedekindEtaUnitQ, PowerSeries.coeff_map,
+        PowerSeries.coeff_map, PowerSeries.coeff_succ_X_mul, zpow_natCast, eq_intCast,
+        eq_intCast, Rat.cast_intCast]
+  · intro m hm
+    have hm' : m < 0 := by
+      by_contra hge
+      push Not at hge
+      exact hm ⟨m.toNat, by simp; omega⟩
+    rw [theta_coeff, ModularCurve.isMonicOfOrder_deltaSeries.coeff_of_lt (by omega),
+      Rat.cast_zero, zero_mul]
+
+private theorem qParam_heckeDiagMatrix_smul {N : ℕ} (hN : N ≠ 0) (τ : ℍ) :
+    𝕢 1 ((ModularForm.heckeDiagMatrix N • τ : ℍ) : ℂ) = 𝕢 1 (τ : ℂ) ^ N := by
+  rw [ModularForm.coe_heckeDiagMatrix_smul hN, Periodic.qParam, Periodic.qParam,
+    ← Complex.exp_nat_mul]
+  congr 1
+  push_cast
+  ring
+
+private theorem hasSum_theta_deltaSeriesN (N : ℕ) [NeZero N] (τ : ℍ) :
+    HasSum (fun m : ℤ => (theta (deltaSeriesN N)).coeff m * 𝕢 1 (τ : ℂ) ^ m)
+      (ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)) := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hNZ : ((N : ℕ) : ℤ) ≠ 0 := by exact_mod_cast hN
+  have h := hasSum_theta_deltaSeries (ModularForm.heckeDiagMatrix N • τ)
+  have e : 𝕢 1 ((ModularForm.heckeDiagMatrix N • τ : ℍ) : ℂ) = 𝕢 1 (τ : ℂ) ^ ((N : ℕ) : ℤ) := by
+    rw [qParam_heckeDiagMatrix_smul hN, zpow_natCast]
+  have hinj : Function.Injective (fun m : ℤ => ((N : ℕ) : ℤ) * m) := mul_right_injective₀ hNZ
+  rw [← hinj.hasSum_iff]
+  · have hfg : (fun m : ℤ => (theta (deltaSeriesN N)).coeff m * 𝕢 1 (τ : ℂ) ^ m) ∘
+        (fun m : ℤ => ((N : ℕ) : ℤ) * m)
+        = fun m : ℤ => (theta deltaSeries).coeff m * 𝕢 1 ((ModularForm.heckeDiagMatrix N • τ : ℍ) :
+          ℂ) ^ m := by
+      funext m
+      simp only [Function.comp_apply, theta_coeff, deltaSeriesN]
+      rw [ModularCurve.qExpand_coeff_mul, e, ← zpow_mul]
+    rw [hfg]
+    exact h
+  · intro m hm
+    rw [theta_coeff, deltaSeriesN,
+      ModularCurve.qExpand_coeff_of_not_dvd N deltaSeries (fun ⟨c, hc⟩ => hm ⟨c, hc.symm⟩),
+      Rat.cast_zero, zero_mul]
+
+private theorem theta_deltaSeriesN_ne_zero (N : ℕ) [NeZero N] : theta (deltaSeriesN N) ≠ 0 := by
+  have h1 : (theta (deltaSeriesN N)).coeff ((N : ℕ) : ℤ) = 1 := by
+    rw [theta_coeff, (ModularCurve.isMonicOfOrder_deltaSeriesN N).coeff_self, Rat.cast_one]
+  exact HahnSeries.ne_zero_of_coeff_ne_zero (h1 ▸ one_ne_zero)
+
+private theorem theta_deltaSeries_ne_zero : theta deltaSeries ≠ 0 := by
+  have h1 : (theta deltaSeries).coeff (1 : ℤ) = 1 := by
+    rw [theta_coeff, ModularCurve.isMonicOfOrder_deltaSeries.coeff_self, Rat.cast_one]
+  exact HahnSeries.ne_zero_of_coeff_ne_zero (h1 ▸ one_ne_zero)
+
+private def phiFun (N : ℕ) : ℂ → ℂ := fun w => gfun w / gfun (w ^ N)
+
+private def psiFun (N : ℕ) : ℂ → ℂ := fun w => gfun (w ^ N) / gfun w
+
+private lemma pow_mem_ball {N : ℕ} [NeZero N] {w : ℂ} (hw : w ∈ Metric.ball (0 : ℂ) 1) :
+    w ^ N ∈ Metric.ball (0 : ℂ) 1 := by
+  rw [Metric.mem_ball, dist_zero_right] at hw ⊢
+  rw [norm_pow]
+  exact pow_lt_one₀ (norm_nonneg _) hw (NeZero.ne N)
+
+private lemma differentiableOn_gfun_pow (N : ℕ) [NeZero N] :
+    DifferentiableOn ℂ (fun w : ℂ => gfun (w ^ N)) (Metric.ball (0 : ℂ) 1) :=
+  differentiableOn_gfun.comp ((differentiable_pow N).differentiableOn)
+    fun _ hw => pow_mem_ball hw
+
+private lemma differentiableOn_phiFun (N : ℕ) [NeZero N] :
+    DifferentiableOn ℂ (phiFun N) (Metric.ball (0 : ℂ) 1) := by
+  refine DifferentiableOn.div differentiableOn_gfun (differentiableOn_gfun_pow N)
+    fun w hw => gfun_ne_zero ?_
+  have := pow_mem_ball (N := N) hw
+  rwa [Metric.mem_ball, dist_zero_right] at this
+
+private lemma differentiableOn_psiFun (N : ℕ) [NeZero N] :
+    DifferentiableOn ℂ (psiFun N) (Metric.ball (0 : ℂ) 1) := by
+  refine DifferentiableOn.div (differentiableOn_gfun_pow N) differentiableOn_gfun
+    fun w hw => gfun_ne_zero ?_
+  rwa [Metric.mem_ball, dist_zero_right] at hw
+
+private def taylorCoeff (f : ℂ → ℂ) (n : ℕ) : ℂ := ((n.factorial : ℂ))⁻¹ * iteratedDeriv n f 0
+
+private lemma hasSum_taylorCoeff {f : ℂ → ℂ}
+    (hf : DifferentiableOn ℂ f (Metric.ball (0 : ℂ) 1)) {q : ℂ} (hq : ‖q‖ < 1) :
+    HasSum (fun n : ℕ => taylorCoeff f n * q ^ n) (f q) := by
+  have h := Complex.hasSum_taylorSeries_on_ball hf
+    (show q ∈ Metric.ball (0 : ℂ) 1 by rwa [Metric.mem_ball, dist_zero_right])
+  refine h.congr_fun fun n => ?_
+  rw [taylorCoeff, sub_zero, smul_eq_mul, smul_eq_mul]
+  ring
+
+private theorem hasSum_modularUnit (N : ℕ) [NeZero N] (τ₀ : ℍ) :
+    HasSum (fun m : ℤ => (((ModularCurve.modularUnitSeries N).coeff m : ℚ) : ℂ)
+        * 𝕢 1 (τ₀ : ℂ) ^ m)
+      (ModularForm.discriminant τ₀
+        / ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ₀)) := by
+  have hq0 : ∀ τ : ℍ, 𝕢 1 (τ : ℂ) ≠ 0 := fun τ => Periodic.qParam_ne_zero _
+  have hqlt : ∀ τ : ℍ, ‖𝕢 1 (τ : ℂ)‖ < 1 := fun τ => by
+    exact_mod_cast UpperHalfPlane.norm_qParam_lt_one 1 τ
+  set A : LaurentSeries ℂ := HahnSeries.single ((1 : ℤ) - N) 1
+    * ((PowerSeries.mk (taylorCoeff (phiFun N)) : PowerSeries ℂ) : LaurentSeries ℂ) with hA
+  have hval : ∀ τ : ℍ, ModularForm.discriminant τ
+      / ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)
+      = phiFun N (𝕢 1 (τ : ℂ)) * 𝕢 1 (τ : ℂ) ^ ((1 : ℤ) - N) := by
+    intro τ
+    have hq := hq0 τ
+    have hgq : gfun (𝕢 1 (τ : ℂ)) ≠ 0 := gfun_ne_zero (hqlt τ)
+    have hgN : gfun (𝕢 1 (τ : ℂ) ^ N) ≠ 0 := gfun_ne_zero (by
+      rw [norm_pow]; exact pow_lt_one₀ (norm_nonneg _) (hqlt τ) (NeZero.ne N))
+    have hqN : 𝕢 1 (τ : ℂ) ^ N ≠ 0 := pow_ne_zero _ hq
+    rw [discriminant_eq_qParam_mul_gfun τ,
+      discriminant_eq_qParam_mul_gfun (ModularForm.heckeDiagMatrix N • τ),
+      qParam_heckeDiagMatrix_smul (NeZero.ne N), phiFun, zpow_sub₀ hq, zpow_one, zpow_natCast]
+    field_simp
+  have hAsum : ∀ τ : ℍ, HasSum (fun m : ℤ => A.coeff m * 𝕢 1 (τ : ℂ) ^ m)
+      (ModularForm.discriminant τ
+        / ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)) := by
+    intro τ
+    rw [hval τ, hA]
+    refine (hasSum_single_mul_coe_iff ((1 : ℤ) - N) _ (hq0 τ) _).mpr ?_
+    refine (hasSum_taylorCoeff (differentiableOn_phiFun N) (hqlt τ)).congr_fun fun n => ?_
+    rw [PowerSeries.coeff_mk]
+  have hprod : ∀ τ : ℍ, HasSum
+      (fun m : ℤ => (A * theta (deltaSeriesN N)).coeff m * 𝕢 1 (τ : ℂ) ^ m)
+      (ModularForm.discriminant τ) := by
+    intro τ
+    have h := ModularCurve.hasSum_qParam_mul_laurent 1 one_pos A (theta (deltaSeriesN N))
+      (fun τ => ModularForm.discriminant τ
+        / ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ))
+      (fun τ => ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ))
+      hAsum (hasSum_theta_deltaSeriesN N) τ
+    have h2 : HasSum (fun m : ℤ => (A * theta (deltaSeriesN N)).coeff m * 𝕢 1 (τ : ℂ) ^ m)
+        (ModularForm.discriminant τ
+            / ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)
+          * ModularForm.discriminant (ModularForm.heckeDiagMatrix N • τ)) := h
+    rwa [div_mul_cancel₀ _ (ModularForm.discriminant_ne_zero _)] at h2
+  have huniq : A * theta (deltaSeriesN N) = theta deltaSeries :=
+    ModularCurve.laurent_qParam_coeff_unique 1 one_pos ModularForm.discriminant _ _ hprod
+      hasSum_theta_deltaSeries
+  have hTheta : theta (ModularCurve.modularUnitSeries N) * theta (deltaSeriesN N)
+      = theta deltaSeries := by
+    rw [← theta_mul, ModularCurve.modularUnitSeries_mul_deltaSeriesN]
+  have hAu : A = theta (ModularCurve.modularUnitSeries N) :=
+    mul_right_cancel₀ (theta_deltaSeriesN_ne_zero N) (huniq.trans hTheta.symm)
+  have h := hAsum τ₀
+  rw [hAu] at h
+  refine h.congr_fun fun m => ?_
+  rw [theta_coeff]
+
+private theorem discriminant_S_smul (z : ℍ) :
+    ModularForm.discriminant (ModularGroup.S • z)
+      = (z : ℂ) ^ (12 : ℕ) * ModularForm.discriminant z := by
+  have hS : (Matrix.SpecialLinearGroup.mapGL ℝ ModularGroup.S : GL (Fin 2) ℝ) ∈ 𝒮ℒ :=
+    ⟨ModularGroup.S, rfl⟩
+  have h1 : ModularForm.discriminant (ModularGroup.S • z)
+      = UpperHalfPlane.denom (Matrix.SpecialLinearGroup.mapGL ℝ ModularGroup.S) (z : ℂ) ^ (12 : ℤ)
+        * ModularForm.discriminant z := by
+    have h__af := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hS z
+    simp only [CuspForm.coe_discriminant, zpow_ofNat] at h__af
+    exact h__af
+  rw [show UpperHalfPlane.denom (Matrix.SpecialLinearGroup.mapGL ℝ ModularGroup.S) (z : ℂ)
+      = (z : ℂ) from ModularGroup.denom_S z,
+    show ((12 : ℤ)) = ((12 : ℕ) : ℤ) by norm_num, zpow_natCast] at h1
+  exact h1
+
+private theorem hasSum_smul (N : ℕ) [NeZero N] (τ : ℍ) :
+    HasSum (fun m : ℤ => (((((N : ℚ) ^ 12)⁻¹ • ModularCurve.modularUnitSeries N).coeff m : ℚ) : ℂ)
+        * 𝕢 (N : ℝ) (τ : ℂ) ^ m)
+      (ModularForm.discriminant (ModularForm.heckeDiagMatrix N • ModularGroup.S • τ)
+        / ModularForm.discriminant (ModularGroup.S • τ)) := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hN0 : (N : ℂ) ≠ 0 := Nat.cast_ne_zero.mpr hN
+  have hNR : (0 : ℝ) < (N : ℝ) := by exact_mod_cast Nat.pos_of_ne_zero hN
+  have him : 0 < ((τ : ℂ) / (N : ℂ)).im := by
+    rw [show ((N : ℂ)) = (((N : ℝ)) : ℂ) by push_cast; rfl, Complex.div_ofReal_im]
+    exact div_pos (by rw [UpperHalfPlane.coe_im]; exact τ.im_pos) hNR
+  set w : ℍ := ⟨(τ : ℂ) / (N : ℂ), him⟩ with hwdef
+  have hwcoe : (w : ℂ) = (τ : ℂ) / (N : ℂ) := rfl
+  have hτ0 : (τ : ℂ) ≠ 0 := UpperHalfPlane.ne_zero τ
+  have hΔw : ModularForm.discriminant w ≠ 0 := ModularForm.discriminant_ne_zero w
+  have hqlink : 𝕢 (N : ℝ) (τ : ℂ) = 𝕢 1 (w : ℂ) := by
+    rw [Periodic.qParam, Periodic.qParam, hwcoe]
+    congr 1
+    push_cast
+    field_simp
+  have hNw : ModularForm.heckeDiagMatrix N • w = τ := by
+    refine UpperHalfPlane.ext ?_
+    rw [ModularForm.coe_heckeDiagMatrix_smul hN, hwcoe]
+    field_simp
+  have hSτcoe : ((ModularGroup.S • τ : ℍ) : ℂ) = (-(τ : ℂ))⁻¹ := by
+    rw [UpperHalfPlane.modular_S_smul, UpperHalfPlane.coe_mk]
+  have hSwcoe : ((ModularGroup.S • w : ℍ) : ℂ) = (-(w : ℂ))⁻¹ := by
+    rw [UpperHalfPlane.modular_S_smul, UpperHalfPlane.coe_mk]
+  have hSw : ModularForm.heckeDiagMatrix N • ModularGroup.S • τ = ModularGroup.S • w := by
+    refine UpperHalfPlane.ext ?_
+    rw [ModularForm.coe_heckeDiagMatrix_smul hN, hSτcoe, hSwcoe, hwcoe]
+    field_simp
+  have hvalue : ModularForm.discriminant (ModularForm.heckeDiagMatrix N • ModularGroup.S • τ)
+      / ModularForm.discriminant (ModularGroup.S • τ)
+      = ((N : ℂ) ^ (12 : ℕ))⁻¹
+        * (ModularForm.discriminant w
+          / ModularForm.discriminant (ModularForm.heckeDiagMatrix N • w)) := by
+    rw [hSw, discriminant_S_smul τ, discriminant_S_smul w, hNw, hwcoe]
+    have hΔτ : ModularForm.discriminant τ ≠ 0 := ModularForm.discriminant_ne_zero τ
+    field_simp
+  have h := (hasSum_modularUnit N w).mul_left (((N : ℂ) ^ (12 : ℕ))⁻¹)
+  rw [hvalue]
+  refine h.congr_fun fun m => ?_
+  rw [HahnSeries.coeff_smul, smul_eq_mul, hqlink]
+  push_cast
+  ring
+
+end QexpN
+
+end ModularCurve
+
+end
+
+theorem solution (N : ℕ) [NeZero N] (τ : UpperHalfPlane) :
+    HasSum (fun m : ℤ => (((((N : ℚ) ^ 12)⁻¹ • ModularCurve.modularUnitSeries N).coeff m : ℚ) : ℂ) *
+      Function.Periodic.qParam N (τ : ℂ) ^ m) (ModularForm.discriminant (ModularForm.heckeDiagMatrix
+      N • ModularGroup.S • τ) / ModularForm.discriminant (ModularGroup.S • τ)) :=
+  ModularCurve.QexpN.hasSum_smul N τ
+
+end S_ModularCurve_hasSum_smul_modularUnitSeries_qParam
+end P2MW
+export P2MW.S_ModularCurve_hasSum_smul_modularUnitSeries_qParam (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.hasSum_smul_modularUnitSeries_qParam (N : ℕ) [NeZero N] (τ : UpperHalfPlane) :
+    HasSum (fun m : ℤ => (((((N : ℚ) ^ 12)⁻¹ • ModularCurve.modularUnitSeries N).coeff m : ℚ) : ℂ) *
+      Function.Periodic.qParam N (τ : ℂ) ^ m) (ModularForm.discriminant (ModularForm.heckeDiagMatrix
+      N • ModularGroup.S • τ) / ModularForm.discriminant (ModularGroup.S • τ)) :=
+  solution N τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_index_le_relfinrank_qExpFunctionFieldC_gamma0_gammaH_of_charZero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_index_le_relfinrank_qExpFunctionFieldC_gamma0_gammaH_of_charZero.lean
new file mode 100644
index 0000000000..14611c7fc6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_index_le_relfinrank_qExpFunctionFieldC_gamma0_gammaH_of_charZero.lean
@@ -0,0 +1,367 @@
+/-
+Based on Prove2Me node ModularCurve.index_le_relfinrank_qExpFunctionFieldC_gamma0_gammaH_of_charZero
+(d475989e-5646-55ed-a9b9-0cde5226514d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 01eea290-07d9-510d-9b0a-1f0c9c29b20f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.Relrank
+public import LeanPool.FLTEichlerShimura.Definitions.Def_CohCarrier_Level
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Data.Int.Star
+import Mathlib.RingTheory.Flat.TorsionFree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_JOneES_exists_transcendental_finiteDimensional_laurentBaseChange
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_intSeriesC_mul_ne_of_gamma0Units_not_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_monoidHom_gamma0_algEquiv_qExpFunctionFieldC_gammaH_of_charZero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_qExpFunctionFieldC_le_of_valuationSubring
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_mem_intFormRatiosC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Index of H{±1} bounds the degree of F_H/F₀
+
+Theorem statement: `ModularCurve.index_le_relfinrank_qExpFunctionFieldC_gamma0_gammaH_of_charZero`
+(`d475989e-5646-55ed-a9b9-0cde5226514d`), by Claude, 2026-09-05.
+
+Proof: submission `01eea290-07d9-510d-9b0a-1f0c9c29b20f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field of characteristic zero, let $M$ be a nonzero natural number and let $H$ be a
+subgroup of $(\mathbb{Z}/M)^\times$. For a subgroup $\Gamma \le \mathrm{SL}_2(\mathbb{Z})$ write
+$F(\Gamma) =$ [`ModularCurve.qExpFunctionFieldC K`](def/ModularCurve_X1.html#L101) $\Gamma$ for the
+intermediate field of $K((q))$ (Laurent series over $K$) generated over $K$ by the set
+`intFormRatiosC K` $\Gamma$, that is, by all quotients $\mathrm{intSeriesC}\,K\,p_f /
+\mathrm{intSeriesC}\,K\,p_g$ where $k$ is an integer, $f,g$ are modular forms of weight $k$ for the
+image of $\Gamma$ in $\mathrm{GL}_2(\mathbb{R})$, $p_f,p_g$ are integral power series that are
+$q$-expansions of $f$ resp. $g$ in the sense of `IsIntegralQExp`, and the Laurent series attached to
+$p_g$ over $K$ is nonzero. Here [`CohCarrier.GammaH M H`](def/CohCarrier_Level.html#L133) is the
+subgroup of $\mathrm{SL}_2(\mathbb{Z})$ obtained by pushing forward along $\Gamma_0(M)
+\hookrightarrow \mathrm{SL}_2(\mathbb{Z})$ the preimage of $H$ under the homomorphism $\Gamma_0(M)
+\to (\mathbb{Z}/M)^\times$ sending $\gamma$ to the reduction modulo $M$ of its lower-right entry; so
+it is $\{\gamma \in \Gamma_0(M) : d(\gamma) \bmod M \in H\}$. The assertion is the inequality of
+natural numbers $$[(\mathbb{Z}/M)^\times : H \cdot \{\pm 1\}] \le [\,F(\Gamma_H(M)) :
+F(\Gamma_0(M))\,],$$ the left side being the index of the subgroup generated by $H$ and $-1$, and
+the right side the relative finite rank of $F(\Gamma_0(M))$ inside $F(\Gamma_H(M))$, a quantity
+which vanishes when the extension is infinite; since $(\mathbb{Z}/M)^\times$ is finite the
+inequality in particular forces that rank to be positive.
+
+This is the characteristic-zero lower bound for the degree of the covering $X_H(M) \to X_0(M)$ of
+modular curves, realised on $q$-expansion function fields, the diamond operators indexed by
+$(\mathbb{Z}/M)^\times / H\{\pm1\}$ supplying the required automorphisms. It is used to obtain the
+matching equality
+[`ModularCurve.relfinrank_qExpFunctionFieldC_gamma0_gammaH_eq_index_of_charZero`]
+(thm.html#ModularCurve.relfinrank_qExpFunctionFieldC_gamma0_gammaH_eq_index_of_charZero)
+and, through it, the computation of the degree of $F(\Gamma_H(M))$ resp. $F(\Gamma_1(M))$ over the
+field generated by the $j$-series after base change.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_index_le_relfinrank_qExpFunctionFieldC_gamma0_gammaH_of_charZero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_e39f7e7d
+
+namespace ModularCurve
+p2m_export "ModularCurve" "intSeriesC qExpFunctionFieldC intFormRatiosC_subset \
+  qExpFunctionFieldC_mono coeffMap coeffEmb laurentBaseChange coeffEmb_mem_laurentBaseChange \
+  jqModC map_jqModC exists_monoidHom_gamma0_algEquiv_qExpFunctionFieldC_gammaH_of_charZero \
+  exists_intSeriesC_mul_ne_of_gamma0Units_not_mem \
+  finrank_adjoin_qExpFunctionFieldC_le_of_valuationSubring \
+  JOneES.exists_transcendental_finiteDimensional_laurentBaseChange transcendental_jqModC \
+  jqModC_mem_intFormRatiosC"
+namespace IgusaGammaH
+p2m_open "ModularCurve"
+
+open IntermediateField
+
+theorem finrank_adjoin_eq_relfinrank {K E : Type*} [Field K] [Field E] [Algebra K E]
+    (F : IntermediateField K E) (x : F) :
+    Module.finrank (IntermediateField.adjoin K ({x} : Set F)) F =
+      (IntermediateField.adjoin K ({(x : E)} : Set E)).relfinrank F := by
+  have hlift : IntermediateField.lift (IntermediateField.adjoin K ({x} : Set F)) =
+      IntermediateField.adjoin K ({(x : E)} : Set E) := by
+    rw [IntermediateField.lift_adjoin]; simp
+  have hle : IntermediateField.adjoin K ({(x : E)} : Set E) ≤ F := by
+    rw [← hlift]; exact IntermediateField.lift_le _
+  rw [IntermediateField.relfinrank_eq_finrank_of_le hle]
+  let i : (IntermediateField.adjoin K ({x} : Set F)) ≃+*
+      (IntermediateField.adjoin K ({(x : E)} : Set E)) :=
+    ((IntermediateField.liftAlgEquiv (IntermediateField.adjoin K ({x} : Set F))).trans
+      (IntermediateField.equivOfEq hlift)).toRingEquiv
+  let j : F ≃+* (IntermediateField.extendScalars hle) := RingEquiv.refl _
+  refine Algebra.finrank_eq_of_equiv_equiv i j ?_
+  ext a
+  rfl
+
+theorem relfinrank_lift_eq_finrank {K E : Type*} [Field K] [Field E] [Algebra K E]
+    (F : IntermediateField K E) (L : IntermediateField K F) :
+    (IntermediateField.lift L).relfinrank F = Module.finrank L F := by
+  rw [IntermediateField.relfinrank_eq_finrank_of_le (IntermediateField.lift_le L)]
+  let i : L ≃+* (IntermediateField.lift L) := (IntermediateField.liftAlgEquiv L).toRingEquiv
+  let j : F ≃+* (IntermediateField.extendScalars (IntermediateField.lift_le L)) := RingEquiv.refl _
+  refine (Algebra.finrank_eq_of_equiv_equiv i j ?_).symm
+  ext a
+  rfl
+
+end ModularCurve.IgusaGammaH
+
+namespace CohCarrier
+p2m_export "CohCarrier" "gamma0Units GammaH mem_GammaH_iff GammaH_le_Gamma0"
+p2m_open "CohCarrier"
+open CongruenceSubgroup
+open scoped MatrixGroups
+
+theorem gamma0Units_surjective' (M : ℕ) [NeZero M] : Function.Surjective (gamma0Units M) := by
+  intro u
+  have hAD : (((((u⁻¹ : (ZMod M)ˣ) : ZMod M).val : ℤ) * ((u : ZMod M).val : ℤ) - 1 : ℤ) : ZMod M) =
+    0 :=
+    by
+    simp
+  obtain ⟨k, hk⟩ := (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp hAD
+  let γ : SL(2, ℤ) :=
+    ⟨!![(((u⁻¹ : (ZMod M)ˣ) : ZMod M).val : ℤ), k; (M : ℤ), ((u : ZMod M).val : ℤ)], by
+    rw [Matrix.det_fin_two_of]
+    linarith⟩
+  have hγ0 : γ ∈ Gamma0 M := by
+    rw [Gamma0_mem]
+    simp [γ]
+  refine ⟨⟨γ, hγ0⟩, Units.ext ?_⟩
+  simp only [gamma0Units, MonoidHom.coe_mk, OneHom.coe_mk, Gamma0Map]
+  simp [γ]
+
+theorem Gamma1_le_GammaH' (M : ℕ) (H : Subgroup (ZMod M)ˣ) : Gamma1 M ≤ CohCarrier.GammaH M H := by
+  intro A hA
+  rw [Gamma1_mem] at hA
+  obtain ⟨_, h11, h10⟩ := hA
+  rw [CohCarrier.mem_GammaH_iff]
+  have hA0 : A ∈ Gamma0 M := Gamma0_mem.mpr h10
+  refine ⟨hA0, ?_⟩
+  have : CohCarrier.gamma0Units M ⟨A, hA0⟩ = 1 := by
+    ext
+    simp only [CohCarrier.gamma0Units, MonoidHom.coe_mk, OneHom.coe_mk, Units.val_one, Gamma0Map]
+    exact h11
+  rw [this]
+  exact one_mem H
+
+theorem translation_mem_GammaH' (M : ℕ) (H : Subgroup (ZMod M)ˣ) :
+    ModularGroup.T ∈ CohCarrier.GammaH M H := by
+  rw [CohCarrier.mem_GammaH_iff]
+  have hT0 : ModularGroup.T ∈ Gamma0 M := by
+    rw [Gamma0_mem]
+    simp [ModularGroup.T]
+  refine ⟨hT0, ?_⟩
+  have : CohCarrier.gamma0Units M ⟨ModularGroup.T, hT0⟩ = 1 := by
+    ext
+    simp [CohCarrier.gamma0Units, Gamma0Map, ModularGroup.T]
+  rw [this]
+  exact one_mem H
+
+theorem mem_or_neg_mem_of_mem_sup_zpowers_neg_one {M : ℕ} (H : Subgroup (ZMod M)ˣ)
+    {d : (ZMod M)ˣ} (hd : d ∈ H ⊔ Subgroup.zpowers (-1 : (ZMod M)ˣ)) : d ∈ H ∨ -d ∈ H := by
+  let S : Subgroup (ZMod M)ˣ :=
+    { carrier := {x | x = 1 ∨ x = -1}
+      one_mem' := Or.inl rfl
+      mul_mem' := by
+        rintro a b (rfl | rfl) (rfl | rfl) <;> simp
+      inv_mem' := by
+        rintro a (rfl | rfl) <;> simp }
+  have hS : Subgroup.zpowers (-1 : (ZMod M)ˣ) ≤ S := by
+    rw [Subgroup.zpowers_le]
+    exact Or.inr rfl
+  obtain ⟨h, hh, z, hz, rfl⟩ := Subgroup.mem_sup.mp hd
+  rcases hS hz with hz1 | hz1
+  · left; rw [hz1, mul_one]; exact hh
+  · right; rw [hz1]; simpa using hh
+
+end CohCarrier
+
+open scoped MatrixGroups in
+open _root_.ModularCurve
+  _root_.P2MW.S_OVERLONG_e39f7e7d.ModularCurve
+  ModularCurve.IgusaGammaH IntermediateField in
+set_option synthInstance.maxHeartbeats 1600000 in
+theorem solution
+    (K : Type*) [Field K] [CharZero K] (M : ℕ) [NeZero M] (H : Subgroup (ZMod M)ˣ) :
+    (H ⊔ Subgroup.zpowers (-1 : (ZMod M)ˣ)).index ≤
+      (ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M)).relfinrank
+        (ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H)) := by
+  classical
+  have hMk : (M : K) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne M)
+  have hΓ : CohCarrier.GammaH M H ≤ CongruenceSubgroup.Gamma0 M := CohCarrier.GammaH_le_Gamma0 H
+  have hb0H : (ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M)) ≤
+    (ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H)) :=
+    ModularCurve.qExpFunctionFieldC_mono K hΓ
+  obtain ⟨ρ, hρH, hρneg, hρfix, hρslash⟩ :=
+    ModularCurve.exists_monoidHom_gamma0_algEquiv_qExpFunctionFieldC_gammaH_of_charZero K M H
+  have hker : ρ.ker = (H ⊔ Subgroup.zpowers (-1 : (ZMod M)ˣ)).comap (CohCarrier.gamma0Units M) := by
+    ext γ
+    rw [MonoidHom.mem_ker, Subgroup.mem_comap]
+    constructor
+    · intro hγ
+      by_contra hd
+      obtain ⟨k, f, g, f₁, g₁, pf, pg, pf₁, pg₁, c, hc, hf, hg, hf₁, hg₁, ef, eg, hg0, hg₁0, hne⟩ :=
+        ModularCurve.exists_intSeriesC_mul_ne_of_gamma0Units_not_mem K M hMk H γ.1 γ.2 hd
+      have key := hρslash γ f g f₁ g₁ c hc hf hg hf₁ hg₁ ef eg hg0 hg₁0
+      rw [hγ, AlgEquiv.one_apply] at key
+      change ModularCurve.intSeriesC K pf / ModularCurve.intSeriesC K pg =
+        ModularCurve.intSeriesC K pf₁ / ModularCurve.intSeriesC K pg₁ at key
+      rw [div_eq_div_iff hg0 hg₁0] at key
+      exact hne (key.trans (mul_comm _ _))
+    · intro hd
+      rcases CohCarrier.mem_or_neg_mem_of_mem_sup_zpowers_neg_one H hd with h | h
+      · exact hρH γ (CohCarrier.mem_GammaH_iff.mpr ⟨γ.2, h⟩)
+      · have hneg0 : (-(γ : SL(2, ℤ))) ∈ CongruenceSubgroup.Gamma0 M := by
+          have := CongruenceSubgroup.Gamma0_mem.mp γ.2
+          rw [CongruenceSubgroup.Gamma0_mem]
+          simp [Matrix.SpecialLinearGroup.coe_neg, this]
+        have hunits : CohCarrier.gamma0Units M ⟨-(γ : SL(2, ℤ)), hneg0⟩ =
+            -CohCarrier.gamma0Units M γ := by
+          ext
+          simp [CohCarrier.gamma0Units, CongruenceSubgroup.Gamma0Map,
+            Matrix.SpecialLinearGroup.coe_neg]
+        have hnegH : (-(γ : SL(2, ℤ))) ∈ CohCarrier.GammaH M H :=
+          CohCarrier.mem_GammaH_iff.mpr ⟨hneg0, by rw [hunits]; exact h⟩
+        have hm1 : (-1 : SL(2, ℤ)) ∈ CongruenceSubgroup.Gamma0 M := by
+          rw [CongruenceSubgroup.Gamma0_mem]; simp [Matrix.SpecialLinearGroup.coe_neg]
+        have e1 : γ = ⟨-1, hm1⟩ * ⟨-(γ : SL(2, ℤ)), hneg0⟩ := by
+          ext1; simp
+        rw [e1, map_mul, hρneg ⟨-1, hm1⟩ rfl, hρH ⟨-(γ : SL(2, ℤ)), hneg0⟩ hnegH, mul_one]
+  have hidx : ρ.ker.index = (H ⊔ Subgroup.zpowers (-1 : (ZMod M)ˣ)).index := by
+    rw [hker]; exact Subgroup.index_comap_of_surjective _ (CohCarrier.gamma0Units_surjective' M)
+  have : (H ⊔ Subgroup.zpowers (-1 : (ZMod M)ˣ)).FiniteIndex := inferInstance
+  have : ρ.ker.FiniteIndex := ⟨by rw [hidx]; exact Subgroup.FiniteIndex.index_ne_zero⟩
+  have : Finite (↥(CongruenceSubgroup.Gamma0 M) ⧸ ρ.ker) := Subgroup.finite_quotient_of_finiteIndex
+  have : Finite ρ.range := Finite.of_equiv _ (QuotientGroup.quotientKerEquivRange ρ).toEquiv
+  have : Fintype ρ.range := Fintype.ofFinite _
+  have hcard : Fintype.card ρ.range = (H ⊔ Subgroup.zpowers (-1 : (ZMod M)ˣ)).index := by
+    rw [Fintype.card_eq_nat_card, ← Nat.card_congr (QuotientGroup.quotientKerEquivRange ρ).toEquiv,
+      ← Subgroup.index_eq_card, hidx]
+  have hartin : Module.finrank (IntermediateField.fixedField ρ.range)
+    (ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H)) =
+      Fintype.card ρ.range := FixedPoints.finrank_eq_card _ _
+  have hL : IntermediateField.lift (IntermediateField.fixedField ρ.range) ≤
+    (ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H)) :=
+    IntermediateField.lift_le _
+  have h0L : (ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M)) ≤
+    IntermediateField.lift (IntermediateField.fixedField ρ.range) :=
+    by
+    intro x hx
+    have hxH : x ∈ (ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H)) := hb0H hx
+    have hfx : (⟨x, hxH⟩ : (ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H))) ∈
+      IntermediateField.fixedField ρ.range :=
+      by
+      rw [IntermediateField.mem_fixedField_iff]
+      rintro _ ⟨γ, rfl⟩
+      exact hρfix γ ⟨x, hxH⟩ hx
+    exact (IntermediateField.mem_lift ⟨x, hxH⟩).mpr hfx
+  have eP : (IntermediateField.lift (IntermediateField.fixedField ρ.range)).relfinrank
+    (ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H)) =
+      (H ⊔ Subgroup.zpowers (-1 : (ZMod M)ˣ)).index := by
+    exact (relfinrank_lift_eq_finrank _ _).trans (hartin.trans hcard)
+  have : (CongruenceSubgroup.Gamma1 M).FiniteIndex :=
+    (CongruenceSubgroup.Gamma1_is_congruence M).finiteIndex
+  have : (CohCarrier.GammaH M H).FiniteIndex :=
+    Subgroup.finiteIndex_of_le (CohCarrier.Gamma1_le_GammaH' M H)
+  have hjH : ModularCurve.jqModC K ∈ ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H) :=
+    ModularCurve.intFormRatiosC_subset K _ (ModularCurve.jqModC_mem_intFormRatiosC K _)
+  obtain ⟨x0, hx0⟩ : ∃ x0 : ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H),
+      (x0 : LaurentSeries K) = ModularCurve.jqModC K := ⟨⟨_, hjH⟩, rfl⟩
+  have hfin : FiniteDimensional
+      (IntermediateField.adjoin K ({x0} : Set (ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH
+        M H))))
+      (ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H)) := by
+    obtain ⟨w, fj, gj, a, b, ha, hb, hb0, hj⟩ :=
+      ModularCurve.jqModC_mem_intFormRatiosC K (CohCarrier.GammaH M H)
+    have hjQ : ModularCurve.jqModC ℚ ∈ ModularCurve.qExpFunctionFieldC ℚ (CohCarrier.GammaH M H) :=
+      ModularCurve.intFormRatiosC_subset ℚ _ (ModularCurve.jqModC_mem_intFormRatiosC ℚ _)
+    have hXmem : ModularCurve.jqModC K ∈
+        ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ (CohCarrier.GammaH M H))
+          := by
+      have := ModularCurve.coeffEmb_mem_laurentBaseChange K hjQ
+      rwa [ModularCurve.coeffEmb, show ModularCurve.coeffMap (algebraMap ℚ K) (ModularCurve.jqModC
+        ℚ) =
+        ModularCurve.jqModC K from ModularCurve.map_jqModC (algebraMap ℚ K)] at this
+    have htr : Transcendental K x0 := by
+      intro halg
+      apply ModularCurve.transcendental_jqModC K
+      rw [← hx0]
+      exact IntermediateField.isAlgebraic_iff.mp halg
+    have hF := ModularCurve.JOneES.exists_transcendental_finiteDimensional_laurentBaseChange K
+      (CohCarrier.GammaH M H) (CohCarrier.translation_mem_GammaH' M H)
+    exact (ModularCurve.finrank_adjoin_qExpFunctionFieldC_le_of_valuationSubring
+      (⊤ : ValuationSubring K) ((⊤ : ValuationSubring K).subtype) (CohCarrier.GammaH M H) hF a b
+      ⟨ModularCurve.jqModC K, hXmem⟩ (by simpa using hj) x0 (by rw [hx0]; exact hj) htr).1
+  have hJH : 0 < (IntermediateField.adjoin K ({ModularCurve.jqModC K} : Set (LaurentSeries
+    K))).relfinrank (ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H)) :=
+    by
+    have : Module.Finite
+        (IntermediateField.adjoin K ({x0} : Set (ModularCurve.qExpFunctionFieldC K
+          (CohCarrier.GammaH M H)))) (ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H)) :=
+          hfin
+    have hpos : 0 < Module.finrank (IntermediateField.adjoin K ({x0} : Set
+      (ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H)))) (ModularCurve.qExpFunctionFieldC
+      K (CohCarrier.GammaH M H)) :=
+      Module.finrank_pos
+    have e :=
+      finrank_adjoin_eq_relfinrank (ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H)) x0
+    rw [hx0] at e
+    exact e ▸ hpos
+  have hjb0 : ModularCurve.jqModC K ∈ (ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0
+    M)) :=
+    ModularCurve.intFormRatiosC_subset K _ (ModularCurve.jqModC_mem_intFormRatiosC K _)
+  have hJ0 : (IntermediateField.adjoin K ({ModularCurve.jqModC K} : Set (LaurentSeries K))) ≤
+    (ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M)) :=
+    IntermediateField.adjoin_le_iff.mpr (Set.singleton_subset_iff.mpr hjb0)
+  have t1 := IntermediateField.relfinrank_mul_relfinrank hJ0 hb0H
+  have t2 := IntermediateField.relfinrank_mul_relfinrank h0L hL
+  have hne : ((ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M))).relfinrank
+    (ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H)) ≠ 0 :=
+    by
+    intro h; rw [h, mul_zero] at t1; omega
+  have hne2 : ((ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M))).relfinrank
+      (IntermediateField.lift (IntermediateField.fixedField ρ.range)) ≠ 0 := by
+    intro h; rw [h, zero_mul] at t2; exact hne t2.symm
+  calc (H ⊔ Subgroup.zpowers (-1 : (ZMod M)ˣ)).index
+      = (IntermediateField.lift (IntermediateField.fixedField ρ.range)).relfinrank
+        (ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H)) := eP.symm
+    _ ≤ ((ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M))).relfinrank
+      (IntermediateField.lift (IntermediateField.fixedField ρ.range)) *
+          (IntermediateField.lift (IntermediateField.fixedField ρ.range)).relfinrank
+            (ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H)) :=
+        Nat.le_mul_of_pos_left _ (Nat.pos_of_ne_zero hne2)
+    _ = _ := t2
+
+end S_OVERLONG_e39f7e7d
+end P2MW
+export P2MW.S_OVERLONG_e39f7e7d
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem ModularCurve.index_le_relfinrank_qExpFunctionFieldC_gamma0_gammaH_of_charZero
+    (K : Type*) [Field K] [CharZero K] (M : ℕ) [NeZero M] (H : Subgroup (ZMod M)ˣ) :
+    (H ⊔ Subgroup.zpowers (-1 : (ZMod M)ˣ)).index ≤
+      (ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M)).relfinrank
+        (ModularCurve.qExpFunctionFieldC K (CohCarrier.GammaH M H)) :=
+  solution K M H
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isCurveOver_laurentBaseChange_qExpFunctionFieldC_gamma1.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isCurveOver_laurentBaseChange_qExpFunctionFieldC_gamma1.lean
new file mode 100644
index 0000000000..50c7303e3c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isCurveOver_laurentBaseChange_qExpFunctionFieldC_gamma1.lean
@@ -0,0 +1,96 @@
+/-
+Based on Prove2Me node ModularCurve.isCurveOver_laurentBaseChange_qExpFunctionFieldC_gamma1
+(b51596c5-4aed-52ae-9d37-c0c2d6a8e142) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 570ba626-8652-5ec1-bdbd-fd4a3a226839
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_transcendental_of_perfectField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_JOneES_exists_transcendental_finiteDimensional_laurentBaseChange
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# K·ℚ(X₁(M)) is a curve over K
+
+Theorem statement: `ModularCurve.isCurveOver_laurentBaseChange_qExpFunctionFieldC_gamma1`
+(`b51596c5-4aed-52ae-9d37-c0c2d6a8e142`), by Claude, 2026-09-05.
+
+Proof: submission `570ba626-8652-5ec1-bdbd-fd4a3a226839`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field of characteristic zero (an algebra over $\mathbb{Q}$) that is algebraically
+closed, and let $M$ be a positive natural number. Consider first the intermediate field $\mathbb{Q}
+\subseteq \mathtt{qExpFunctionFieldC}\ \mathbb{Q}\ \Gamma_1(M) \subseteq \mathbb{Q}((q))$ obtained
+by adjoining to $\mathbb{Q}$ the set of all Laurent series of the form
+$\mathrm{intSeriesC}\,\mathbb{Q}\,p_f / \mathrm{intSeriesC}\,\mathbb{Q}\,p_g$, where $f,g$ are
+modular forms of some common weight $k$ for the image of $\Gamma_1(M)$ in
+$\mathrm{GL}_2(\mathbb{R})$ whose $q$-expansions are given by integral power series $p_f,p_g$ (in
+the sense of `IsIntegralQExp`) with $\mathrm{intSeriesC}\,\mathbb{Q}\,p_g \neq 0$. Let $F_K :=
+\mathtt{laurentBaseChange}\,K$ of this field, namely the intermediate field of $K((q))$ generated
+over $K$ by the image of that field under the coefficientwise ring homomorphism $\mathbb{Q}((q)) \to
+K((q))$ induced by $\mathbb{Q} \to K$. The assertion is that $F_K$ satisfies
+[`AlgebraicCurve.IsCurveOver K`](def/AlgebraicCurve_IsCurveOver.html#L15), i.e.: every nonzero $f
+\in F_K$ admits a divisor $D$ with $D(v) = \mathrm{ord}_v(f)$ at every place $v$ of $F_K/K$ (a
+proper valuation subring of $F_K$ containing $K$ which is a principal ideal ring) and with $\deg D =
+0$; each such place has residue field finite-dimensional over $K$; and the module of Kähler
+differentials $\Omega_{F_K/K}$ is free of rank $1$ over $F_K$.
+
+This identifies the base-changed $q$-expansion function field of $X_1(M)$ as a curve in the
+project's axiomatic sense, the setting in which places, divisors, degrees and differentials of
+$X_1(M)$ over an algebraically closed field of characteristic zero are manipulated. It is the input
+to the finiteness of Riemann–Roch spaces for $F_K$, to the construction of the divisor attached to
+the weight floor, and to the description of points of $X_1(p)$ in terms of the divisor class group.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_isCurveOver_laurentBaseChange_qExpFunctionFieldC_gamma1.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_isCurveOver_laurentBaseChange_qExpFunctionFieldC_gamma1
+
+open ModularCurve CongruenceSubgroup AlgebraicCurve
+open scoped MatrixGroups
+
+theorem solution
+    (K : Type*) [Field K] [Algebra ℚ K] [IsAlgClosed K] (M : ℕ) [NeZero M] :
+    AlgebraicCurve.IsCurveOver K ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC
+      ℚ (CongruenceSubgroup.Gamma1 M))) := by
+  obtain ⟨x, htr, hfd⟩ :=
+    ModularCurve.JOneES.exists_transcendental_finiteDimensional_laurentBaseChange
+    K (CongruenceSubgroup.Gamma1 M) (by rw [CongruenceSubgroup.Gamma1_mem]; simp [ModularGroup.T])
+  exact AlgebraicCurve.isCurveOver_of_transcendental_of_perfectField htr hfd
+
+end S_ModularCurve_isCurveOver_laurentBaseChange_qExpFunctionFieldC_gamma1
+end P2MW
+export P2MW.S_ModularCurve_isCurveOver_laurentBaseChange_qExpFunctionFieldC_gamma1 (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve CongruenceSubgroup AlgebraicCurve
+open scoped MatrixGroups
+theorem ModularCurve.isCurveOver_laurentBaseChange_qExpFunctionFieldC_gamma1
+    (K : Type*) [Field K] [Algebra ℚ K] [IsAlgClosed K] (M : ℕ) [NeZero M] :
+    AlgebraicCurve.IsCurveOver K ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC
+      ℚ (CongruenceSubgroup.Gamma1 M))) :=
+  solution K M
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isCurveOver_modularFunctionFieldBar.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isCurveOver_modularFunctionFieldBar.lean
new file mode 100644
index 0000000000..d3544304e4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isCurveOver_modularFunctionFieldBar.lean
@@ -0,0 +1,223 @@
+/-
+Based on Prove2Me node ModularCurve.isCurveOver_modularFunctionFieldBar
+(2e2cf9ee-44f8-5551-9fdf-12ba1a6daa47) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 26e6e141-f721-5372-8792-f19f2cbb2ed1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_IsCurveOver
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ArithmeticGalois
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull_unconditional
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_adjoin_pair
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_deg_ne_zero_modularFunctionFieldC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_jqNModC_all
+import LeanPool.FLTEichlerShimura.Theorems.Thm_KaehlerDifferential_D_ne_zero_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_KaehlerDifferential_span_D_eq_top_of_transcendental
+import Mathlib.FieldTheory.Perfect
+import Mathlib.Algebra.CharP.Algebra
+import Mathlib.LinearAlgebra.FiniteDimensional.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The modular function field over ℚ̄ is a curve field
+
+Theorem statement: `ModularCurve.isCurveOver_modularFunctionFieldBar`
+(`2e2cf9ee-44f8-5551-9fdf-12ba1a6daa47`), by Claude, 2026-09-05.
+
+Proof: submission `26e6e141-f721-5372-8792-f19f2cbb2ed1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number, and let $F = \mathtt{modularFunctionFieldBar}\,N$ be the
+intermediate field of $\mathrm{LaurentSeries}(\overline{\mathbb Q})$ over $K = \overline{\mathbb Q}
+=$ `AlgebraicClosure ℚ` obtained as `laurentBaseChange` of `modularFunctionFieldFull N`, i.e. the
+subfield generated over $\overline{\mathbb Q}$ by the image, under the coefficientwise embedding
+$\mathrm{LaurentSeries}(\mathbb Q) \to \mathrm{LaurentSeries}(\overline{\mathbb Q})$, of the
+subfield of $\mathrm{LaurentSeries}(\mathbb Q)$ generated over $\mathbb Q$ by the divisor expansions
+attached to $N$. The assertion is that the pair $(K, F)$ satisfies `IsCurveOver`, which bundles
+three things: (i) `HasPrincipalDivisors`, that every $f \in F$ with $f \neq 0$ admits a divisor $D$
+over $K$ whose value at each place $v$ (a valuation subring of $F$, not all of $F$, containing the
+image of $K$ and a principal ideal ring) is $v.\mathrm{ord}\, f$, and with $\deg D = 0$; (ii) for
+every such place $v$, the residue field of $v$ is a finite $K$-module; and (iii) the module of
+Kähler differentials $\Omega[F/K]$ is free over $F$ of rank $1$.
+
+This is the statement that the function field of $X_0(N)$ over $\overline{\mathbb Q}$ is a function
+field of a curve in the sense used throughout the project, the classical fact for a finitely
+generated extension of transcendence degree one of a perfect field. It is the standing hypothesis
+for the divisor-theoretic and differential-theoretic machinery on $X_0(N)$, and is invoked widely
+downstream, for instance in the genus computation for weight-two forms on $\Gamma_0(N)$ and in the
+work with reductions of places in characteristic $p$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_isCurveOver_modularFunctionFieldBar.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_isCurveOver_modularFunctionFieldBar
+
+noncomputable section
+
+open IntermediateField
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place IsCurveOver"
+p2m_open "AlgebraicCurve"
+
+namespace R0
+
+private theorem kaehler_free_rank_one (K : Type*) [Field K] {F : Type*} [Field F] [Algebra K F]
+    (x : F) (hx : Transcendental K x) [Algebra.IsSeparable K⟮x⟯ F] :
+    Module.Free F (KaehlerDifferential K F) ∧ Module.finrank F (KaehlerDifferential K F) = 1 := by
+  refine ⟨inferInstance, ?_⟩
+  have h1 :=
+    finrank_span_singleton (K := F) (KaehlerDifferential.D_ne_zero_of_transcendental K x hx)
+  rwa [KaehlerDifferential.span_D_eq_top_of_transcendental K x hx, finrank_top] at h1
+
+section Adjoin
+
+variable (K : Type*) [Field K] {LF : Type*} [Field LF] [Algebra K LF]
+
+private theorem kaehler_free_rank_one_adjoin (x : LF) (hx : Transcendental K x) (T : Finset LF)
+    (hT : ∀ t ∈ T, IsIntegral K⟮x⟯ t)
+    (hsep : ∀ y : LF, IsIntegral K⟮x⟯ y → IsSeparable K⟮x⟯ y) :
+    Module.Free (IntermediateField.adjoin K (insert x (T : Set LF)))
+        (KaehlerDifferential K (IntermediateField.adjoin K (insert x (T : Set LF))))
+      ∧ Module.finrank (IntermediateField.adjoin K (insert x (T : Set LF)))
+        (KaehlerDifferential K (IntermediateField.adjoin K (insert x (T : Set LF)))) = 1 := by
+  set F : IntermediateField K LF := IntermediateField.adjoin K (insert x (T : Set LF)) with hF
+  have hxF : x ∈ F := subset_adjoin K _ (Set.mem_insert x _)
+  have hTF : ∀ t ∈ T, t ∈ F := fun t ht => subset_adjoin K _ (Set.mem_insert_of_mem x ht)
+  set x' : F := ⟨x, hxF⟩ with hx'
+  have hx't : Transcendental K x' :=
+    (transcendental_algebraMap_iff (R := K) (S := F) (A := LF) Subtype.val_injective).mp hx
+  set A : IntermediateField K F := IntermediateField.adjoin K ({x'} : Set F) with hA
+  have hliftA : lift A = K⟮x⟯ := by
+    rw [hA, lift_adjoin_simple]
+  let e : A ≃ₐ[K] K⟮x⟯ := (liftAlgEquiv A).trans (equivOfEq hliftA)
+  have he : ∀ a : A, ((e a : K⟮x⟯) : LF) = ((a : F) : LF) := by
+    intro a; rfl
+  have hcomp : (algebraMap K⟮x⟯ LF).comp (e : A →+* K⟮x⟯) = (RingHom.id LF).comp (algebraMap A LF)
+    :=
+    RingHom.ext fun a => he a
+  have hcomp' : (algebraMap A LF).comp (e.symm : K⟮x⟯ →+* A)
+      = (RingHom.id LF).comp (algebraMap K⟮x⟯ LF) := by
+    ext b
+    change (((e.symm b : A) : F) : LF) = ((b : K⟮x⟯) : LF)
+    rw [← he (e.symm b), AlgEquiv.apply_symm_apply]
+  have hint : ∀ t (ht : t ∈ T), IsIntegral A (⟨t, hTF t ht⟩ : F) := by
+    intro t ht
+    have h1 : IsIntegral A (t : LF) :=
+      (hT t ht).map_of_comp_eq (R := K⟮x⟯) (S := LF) (T := A) (U := LF)
+        (e.symm : K⟮x⟯ →+* A) (RingHom.id LF) hcomp'
+    exact (isIntegral_algHom_iff (IsScalarTower.toAlgHom A F LF) Subtype.val_injective).mp h1
+  have : FiniteDimensional A F := by
+    set T' : Set F := (fun t : T => (⟨(t : LF), hTF t t.2⟩ : F)) '' Set.univ with hT'
+    have : Finite T' := Set.Finite.to_subtype ((Set.finite_univ).image _)
+    have hT'int : ∀ y ∈ T', IsIntegral A y := by
+      rintro _ ⟨t, -, rfl⟩; exact hint t t.2
+    have : FiniteDimensional A (IntermediateField.adjoin A T') := finiteDimensional_adjoin hT'int
+    have htop : IntermediateField.adjoin A T' = ⊤ := by
+      apply restrictScalars_injective K
+      rw [restrictScalars_adjoin, restrictScalars_top]
+      apply lift_injective
+      rw [lift_top, lift_adjoin]
+      apply le_antisymm (adjoin_le_iff.mpr ?_) ?_
+      · rintro _ ⟨y, hy, rfl⟩; exact y.2
+      · change IntermediateField.adjoin K (insert x (T : Set LF)) ≤ _
+        apply adjoin.mono
+        intro z hz
+        rcases hz with rfl | hz
+        · exact ⟨x', Or.inl (subset_adjoin K _ (Set.mem_singleton _)), rfl⟩
+        · exact ⟨⟨z, hTF z hz⟩, Or.inr ⟨⟨z, hz⟩, Set.mem_univ _, rfl⟩, rfl⟩
+    rw [htop] at this
+    exact LinearEquiv.finiteDimensional (IntermediateField.topEquiv (F := A) (E := F)).toLinearEquiv
+  have : Algebra.IsSeparable A F := ⟨fun z => by
+    have hzLF : IsIntegral K⟮x⟯ ((z : F) : LF) :=
+      ((IsIntegral.of_finite A z).map (IsScalarTower.toAlgHom A F LF)).map_of_comp_eq
+        (R := A) (S := LF) (T := K⟮x⟯) (U := LF) (e : A →+* K⟮x⟯) (RingHom.id LF) hcomp
+    have h2 : IsSeparable A ((z : F) : LF) :=
+      IsSeparable.of_equiv_equiv (e.symm : K⟮x⟯ ≃+* A) (RingEquiv.refl LF) hcomp' (hsep _ hzLF)
+    exact _root_.IsSeparable.of_algHom A (IsScalarTower.toAlgHom A F LF) h2⟩
+  exact kaehler_free_rank_one K x' hx't
+
+end Adjoin
+
+set_option synthInstance.maxHeartbeats 1600000 in
+open ModularCurve in
+private theorem isCurveOver_laurentBaseChange (L : Type*) [Field L] {instQL : Algebra ℚ L} (N : ℕ)
+    [NeZero N] : IsCurveOver L (laurentBaseChange L (modularFunctionFieldFull N)) := by
+  have hpair : laurentBaseChange L (modularFunctionFieldFull N)
+      = IntermediateField.adjoin L {jqModC L, jqNModC L N} :=
+    laurentBaseChange_adjoin_pair L N (functionFieldGeneration N)
+  have hfin : ∀ E : IntermediateField L (LaurentSeries L), E = modularFunctionFieldC L N →
+      ∀ w : Place L E, Module.Finite L w.ResidueField := by
+    rintro E rfl w
+    exact Module.finite_of_finrank_pos (Nat.pos_of_ne_zero (deg_ne_zero_modularFunctionFieldC L N
+      w))
+  have hkae : ∀ E : IntermediateField L (LaurentSeries L),
+      E = IntermediateField.adjoin L
+        (insert (jqModC L) ((({jqNModC L N} : Finset (LaurentSeries L)) : Set (LaurentSeries L)))) →
+      Module.Free E (KaehlerDifferential L E) ∧ Module.finrank E (KaehlerDifferential L E) = 1 := by
+    rintro E rfl
+    have : CharZero L := charZero_of_injective_algebraMap (algebraMap ℚ L).injective
+    refine kaehler_free_rank_one_adjoin L (jqModC L) (transcendental_jqModC L) {jqNModC L N} ?_ ?_
+    · intro t ht
+      rw [Finset.mem_singleton] at ht
+      subst ht
+      exact isIntegral_jqNModC_all L N
+    · intro y hy
+      have : CharZero L⟮jqModC L⟯ :=
+        charZero_of_injective_algebraMap (algebraMap L L⟮jqModC L⟯).injective
+      exact PerfectField.separable_of_irreducible (minpoly.irreducible hy)
+  exact { hasPrincipalDivisors_laurentBaseChange_modularFunctionFieldFull_unconditional L N with
+    finiteResidue := hfin _ hpair
+    kaehler_free_rank_one := hkae _ (by rw [Finset.coe_singleton]; exact hpair) }
+
+end R0
+
+end AlgebraicCurve
+
+end
+
+p2m_open "ModularCurve AlgebraicCurve \
+  P2MW.S_ModularCurve_isCurveOver_modularFunctionFieldBar.AlgebraicCurve"
+
+theorem solution (N : ℕ) [NeZero N] :
+    IsCurveOver (AlgebraicClosure ℚ) (modularFunctionFieldBar N) :=
+  AlgebraicCurve.R0.isCurveOver_laurentBaseChange (AlgebraicClosure ℚ) N
+
+example :
+    ∀ (N : ℕ) [NeZero N], IsCurveOver (AlgebraicClosure ℚ) (modularFunctionFieldBar N) := @solution
+
+end S_ModularCurve_isCurveOver_modularFunctionFieldBar
+end P2MW
+export P2MW.S_ModularCurve_isCurveOver_modularFunctionFieldBar (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve ModularCurve
+theorem ModularCurve.isCurveOver_modularFunctionFieldBar (N : ℕ) [NeZero N] :
+    IsCurveOver (AlgebraicClosure ℚ) (modularFunctionFieldBar N) :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isCusp_cuspInftyBar.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isCusp_cuspInftyBar.lean
new file mode 100644
index 0000000000..1b454c5fbb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isCusp_cuspInftyBar.lean
@@ -0,0 +1,87 @@
+/-
+Based on Prove2Me node ModularCurve.isCusp_cuspInftyBar
+(4313767f-f0d3-562b-83e0-50a9b85632e4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c812c284-5eaf-5d3e-8abe-d2aef99aed17
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_AtkinLehner
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCusp_iff_ord_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_cuspInftyBar_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The place at infinity is a cusp for j
+
+Theorem statement: `ModularCurve.isCusp_cuspInftyBar` (`4313767f-f0d3-562b-83e0-50a9b85632e4`), by
+Claude, 2026-09-05.
+
+Proof: submission `c812c284-5eaf-5d3e-8abe-d2aef99aed17`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number with $N \neq 0$. Consider the field $F_N$ of modular functions of level
+$N$ obtained by base change of coefficients: starting from `modularFunctionFieldFull N`, the
+subfield of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by the divisor expansions
+`divisorExpansions N`, one forms `modularFunctionFieldBar N`, the subfield of
+$\overline{\mathbb{Q}}((q))$ generated over $\overline{\mathbb{Q}}$ by the image of
+`modularFunctionFieldFull N` under the coefficientwise ring map `coeffEmb` induced by $\mathbb{Q}
+\hookrightarrow \overline{\mathbb{Q}}$. Let $j$ denote the distinguished element of
+`modularFunctionFieldBar N` given by the image of the $q$-expansion `jq` under `coeffEmb`, together
+with the membership witness coming from the fact that `jq` lies in `modularFunctionFieldFull N`. Let
+`cuspInftyBar N` be the place of `modularFunctionFieldBar N` over $\overline{\mathbb{Q}}$ defined as
+`qInftyPlaceBar` for this field, whose valuation subring is `qIntegersBar` and whose construction is
+witnessed by the fact that the $q$-series order of $j$ is $-1$. The conclusion is that $j$ satisfies
+the project's predicate `IsCusp` at this place, that is, $j$ does not belong to the valuation
+subring of `cuspInftyBar N`.
+
+This records that the place $q = 0$ of the function field of the modular curve of level $N$ over
+$\overline{\mathbb{Q}}$ is a pole of the modular invariant $j$, so that it is a cusp in the
+project's sense. It is used throughout the later treatment of $X_0(N)$, for instance in the analysis
+of charts and residues near the cusp at infinity and in height estimates on the $j$-line.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_isCusp_cuspInftyBar.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_isCusp_cuspInftyBar
+
+open ModularCurve AlgebraicCurve
+open scoped Pointwise
+
+theorem solution (N : ℕ) [NeZero N] :
+    IsCusp (⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+      (jq_mem_full N)⟩ : modularFunctionFieldBar N) (cuspInftyBar N) := by
+  rw [ModularCurve.isCusp_iff_ord_neg, ModularCurve.ord_cuspInftyBar_coeffEmb_jq]
+  norm_num
+
+end S_ModularCurve_isCusp_cuspInftyBar
+end P2MW
+export P2MW.S_ModularCurve_isCusp_cuspInftyBar (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.isCusp_cuspInftyBar (N : ℕ) [NeZero N] :
+    IsCusp (⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+      (jq_mem_full N)⟩ : modularFunctionFieldBar N) (cuspInftyBar N) :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isCusp_cuspZeroBar.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isCusp_cuspZeroBar.lean
new file mode 100644
index 0000000000..54addb9b85
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isCusp_cuspZeroBar.lean
@@ -0,0 +1,88 @@
+/-
+Based on Prove2Me node ModularCurve.isCusp_cuspZeroBar
+(14c85480-1094-50db-b52c-f16742b635c1) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 005d631d-1a84-5a2f-b31b-d6da3887bbb5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CuspidalClass
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCusp_iff_ord_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_cuspZeroBar_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The cusp ̄ 0 is a pole of j
+
+Theorem statement: `ModularCurve.isCusp_cuspZeroBar` (`14c85480-1094-50db-b52c-f16742b635c1`), by
+Claude, 2026-09-05.
+
+Proof: submission `005d631d-1a84-5a2f-b31b-d6da3887bbb5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number with $N \neq 0$, and let $h$ be the hypothesis that the distinguished
+automorphism `frickeInvolutionFull N` of the field $F_N$ = `modularFunctionFieldFull N` (the
+subfield of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by `divisorExpansions N`) satisfies
+`IsFrickeAutFull N`, i.e. for every factorisation $N = ab$ into nonzero natural numbers it carries
+the element $\mathrm{qExpand}\,a\,(jq)$, the series obtained from $jq = q^{-1}\cdot jNumQ$ by $q
+\mapsto q^a$, to $\mathrm{qExpand}\,b\,(jq)$. Work in $\bar F_N$ = `modularFunctionFieldBar N`, the
+subfield of $\overline{\mathbb{Q}}((q))$ generated over $\overline{\mathbb{Q}}$ by the image of
+$F_N$ under the coefficientwise map `coeffEmb`. The assertion is that the element of $\bar F_N$
+given by `coeffEmb` applied to $jq$ (its membership being furnished by the base-change membership
+lemma) is a cusp for the place `cuspZeroBar N`, that is, for the translate of the $q$-adic place at
+infinity `cuspInftyBar N` by the geometric extension `frickeInvolutionBar N` of
+`frickeInvolutionFull N`; here `IsCusp j v` means precisely that $j$ does not lie in the valuation
+subring underlying the place $v$.
+
+This records that $j$ has a pole at the cusp $\bar 0$ of the modular curve attached to level $N$,
+the Fricke-transform of the cusp $\bar\infty$; it is the basic qualitative input on the behaviour of
+$j$ at $0$. It is used throughout the subsequent analysis of places of the modular function field,
+in particular in the specialisation and prolongation arguments for places over level one.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_isCusp_cuspZeroBar.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_isCusp_cuspZeroBar
+
+open ModularCurve AlgebraicCurve
+open scoped Pointwise
+
+theorem solution (N : ℕ) [NeZero N] (h : IsFrickeAutFull N (frickeInvolutionFull N)) :
+    IsCusp (⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+      (jq_mem_full N)⟩ : modularFunctionFieldBar N) (cuspZeroBar N) := by
+  rw [ModularCurve.isCusp_iff_ord_neg, ModularCurve.ord_cuspZeroBar_coeffEmb_jq N h, neg_lt_zero,
+    Nat.cast_pos]
+  exact Nat.pos_of_ne_zero (NeZero.ne N)
+
+end S_ModularCurve_isCusp_cuspZeroBar
+end P2MW
+export P2MW.S_ModularCurve_isCusp_cuspZeroBar (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.isCusp_cuspZeroBar (N : ℕ) [NeZero N]
+    (h : IsFrickeAutFull N (frickeInvolutionFull N)) :
+    IsCusp (⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+      (jq_mem_full N)⟩ : modularFunctionFieldBar N) (cuspZeroBar N) :=
+  solution N h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isCusp_iff_ord_neg.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isCusp_iff_ord_neg.lean
new file mode 100644
index 0000000000..0b1b950d41
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isCusp_iff_ord_neg.lean
@@ -0,0 +1,84 @@
+/-
+Based on Prove2Me node ModularCurve.isCusp_iff_ord_neg
+(6a851602-4ebf-5f58-93a9-0ac000883613) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e5d24137-559b-5691-8303-d98724b09a66
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlace
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_iff_ord_nonneg
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cusps are the places where j has negative order
+
+Theorem statement: `ModularCurve.isCusp_iff_ord_neg` (`6a851602-4ebf-5f58-93a9-0ac000883613`), by
+Claude, 2026-09-05.
+
+Proof: submission `e5d24137-559b-5691-8303-d98724b09a66`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $E$ be fields with $E$ a $K$-algebra, let $j \in E$, and let $v$ be a place of $E$ over
+$K$, that is, a valuation subring `v.toValuationSubring` of $E$ which contains the image of $K$
+under the structure map, is not all of $E$, and is a principal ideal ring. The assertion is the
+equivalence of two conditions on $j$: the predicate `IsCusp j v`, which by definition says that $j$
+does not belong to `v.toValuationSubring`, holds if and only if $v.\mathrm{ord}(j) < 0$, where
+$\mathrm{ord}$ is the integer-valued order function attached to $v$, namely $\mathrm{ord}(f) =
+-\log$ of the value of $f$ under the adic valuation of the height-one prime of
+`v.toValuationSubring` determined by $v$ (with values in $\mathbb{Z}^{m0}$). Thus being a cusp for
+$j$ in the sense of this development is exactly the condition that $j$ has a pole at $v$. In
+particular, for $j = 0$ both sides fail, since $0$ lies in every valuation subring and
+$\mathrm{ord}(0) = 0$ by convention.
+
+This is the translation between the membership formulation of a cusp, as a place at which the
+modular function $j$ fails to be integral, and the numerical formulation in terms of the order of
+vanishing, so that cusps can be handled by divisor-theoretic computations. It is used throughout the
+treatment of places of modular curves, for instance in the estimates on $\mathrm{ord}$ of $j$ in
+characteristic $p$ models and in the specialisation and height computations for the $j$-line.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_isCusp_iff_ord_neg.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_isCusp_iff_ord_neg
+
+open ModularCurve AlgebraicCurve
+
+theorem solution {K : Type*} {E : Type*} [Field K] [Field E] [Algebra K E] (j : E) (v : Place K E) :
+    IsCusp j v ↔ v.ord j < 0 := by
+  rcases eq_or_ne j 0 with rfl | hj
+  · rw [isCusp_iff, Place.ord_zero]
+    exact ⟨fun h => (h (zero_mem _)).elim, fun h => (lt_irrefl _ h).elim⟩
+  · rw [isCusp_iff, v.mem_iff_ord_nonneg hj, not_le]
+
+end S_ModularCurve_isCusp_iff_ord_neg
+end P2MW
+export P2MW.S_ModularCurve_isCusp_iff_ord_neg (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.isCusp_iff_ord_neg {K : Type*} {E : Type*} [Field K] [Field E] [Algebra K E]
+    (j : E) (v : Place K E) :
+    IsCusp j v ↔ v.ord j < 0 :=
+  solution j v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isFrickeAutFull_frickeInvolutionFull_prime.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isFrickeAutFull_frickeInvolutionFull_prime.lean
new file mode 100644
index 0000000000..9ba8e58e66
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isFrickeAutFull_frickeInvolutionFull_prime.lean
@@ -0,0 +1,87 @@
+/-
+Based on Prove2Me node ModularCurve.isFrickeAutFull_frickeInvolutionFull_prime
+(dc634f62-6717-5ea6-a5b1-6f2778b739a0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 84751bc4-45fd-550b-8675-c055afc54c58
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_AtkinLehner
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_isFrickeAutFull
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# At prime level `frickeInvolutionFull` is a Fricke automorphism
+
+Theorem statement: `ModularCurve.isFrickeAutFull_frickeInvolutionFull_prime`
+(`dc634f62-6717-5ea6-a5b1-6f2778b739a0`), by Claude, 2026-09-05.
+
+Proof: submission `84751bc4-45fd-550b-8675-c055afc54c58`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a prime. The field $F^{\mathrm{full}}_{\ell}$ = `modularFunctionFieldFull ℓ` is the
+intermediate field of $\mathbb{Q} \subseteq \mathbb{Q}((q))$ (Laurent series) generated over
+$\mathbb{Q}$ by the set `divisorExpansions ℓ`, and `frickeInvolutionFull ℓ` is the
+$\mathbb{Q}$-algebra automorphism of this field defined by classical choice: a witness $\sigma$
+satisfying `IsFrickeAutFull ℓ σ` if one exists, and the identity otherwise. The theorem asserts
+`IsFrickeAutFull ℓ (frickeInvolutionFull ℓ)`, that is: for every pair of nonzero naturals $a, b$
+with $ab = \ell$, the automorphism `frickeInvolutionFull ℓ` carries the element of
+$F^{\mathrm{full}}_{\ell}$ given by $\mathrm{qExpand}_{\mathbb{Q}}^{a}(j)$, the image of the
+$q$-expansion `jq` under the ring homomorphism of Laurent series that multiplies all exponents by
+$a$ (so, $j(q^{a})$), to the element $\mathrm{qExpand}_{\mathbb{Q}}^{b}(j) = j(q^{b})$, each taken
+with its membership witness `jqd_mem_full` coming from the corresponding divisibility relation. For
+$\ell$ prime the only such factorisations are $(a,b) = (1,\ell)$ and $(\ell,1)$, so the content is
+that $j(q) \mapsto j(q^{\ell})$ and $j(q^{\ell}) \mapsto j(q)$.
+
+This identifies the totally defined automorphism `frickeInvolutionFull ℓ` with the Fricke
+(Atkin–Lehner) involution $w_\ell$ of $X_0(\ell)$ at the level of function fields, where it
+interchanges the two generators $j(q)$ and $j(q^{\ell})$. It is the form in which the Fricke
+automorphism is consumed downstream, for instance in the analysis of the cusp $0$ of $X_0(\ell)$, of
+local rings at nodes, and of prolongation data on charts.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_isFrickeAutFull_frickeInvolutionFull_prime.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_isFrickeAutFull_frickeInvolutionFull_prime
+
+open ModularCurve AlgebraicCurve IntermediateField
+
+noncomputable section
+
+theorem solution (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] :
+    IsFrickeAutFull ℓ (frickeInvolutionFull ℓ) := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  exact ModularCurve.isFrickeAutFull_frickeInvolutionFull ℓ (ModularCurve.exists_isFrickeAutFull ℓ)
+
+end
+
+end S_ModularCurve_isFrickeAutFull_frickeInvolutionFull_prime
+end P2MW
+export P2MW.S_ModularCurve_isFrickeAutFull_frickeInvolutionFull_prime (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve IntermediateField
+theorem ModularCurve.isFrickeAutFull_frickeInvolutionFull_prime (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] :
+    IsFrickeAutFull ℓ (frickeInvolutionFull ℓ) :=
+  solution ℓ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder.lean
new file mode 100644
index 0000000000..c05cbfb5c2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder.lean
@@ -0,0 +1,627 @@
+/-
+Based on Prove2Me node ModularCurve.isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder
+(d1a01c5c-fdce-56e2-82d2-e708c74ac026) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f03e086e-0d42-561f-b250-529ebd47f804
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_isIntegral_adjoin_qExpansion_div_discriminant_pow_of_isArithmetic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Ratios of forms are integral over ℂ[j]
+
+Theorem statement: `ModularCurve.isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder`
+(`d1a01c5c-fdce-56e2-82d2-e708c74ac026`), by Claude, 2026-09-05.
+
+Proof: submission `f03e086e-0d42-561f-b250-529ebd47f804`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M\ge 1$ be a natural number, let $\Gamma$ be a subgroup of $\mathrm{SL}_2(\mathbb{Z})$
+containing the congruence subgroup $\Gamma_1(M)$, and let $k$ be an integer. Let $g$ and $h$ be
+modular forms of weight $k$ for the image of $\Gamma$ in $\mathrm{GL}_2(\mathbb{R})$, with $h\neq
+0$. Assume that for every point $\tau$ of the upper half-plane the function $z\mapsto \|g(z)/h(z)\|$
+is bounded above along the filter of punctured neighbourhoods of $\tau$, i.e. $g/h$ is locally
+bounded near each point of $\mathbb{H}$ (punctures allowed). Form the $q$-expansions of $g$ and of
+$h$ with respect to the width $1$, viewed as Laurent series over $\mathbb{C}$ via the inclusion of
+power series into `LaurentSeries ℂ`, and let $j$ denote the Laurent series
+$\mathrm{jqModC}\,\mathbb{C}$, namely $q^{-1}$ times the base change to $\mathbb{C}$ of the integral
+power series $\mathrm{jNum}=E_4^{3}\cdot(\text{the unit inverse of the Dedekind }\eta\text{
+factor})$; by the cited identity this is $(\text{$q$-expansion of }E_4)^3/(\text{$q$-expansion of
+}\Delta)$. The conclusion is that the quotient of the $q$-expansion of $g$ by that of $h$, an
+element of $\mathbb{C}((q))$, is integral over the $\mathbb{C}$-subalgebra $\mathbb{C}[j]$ of
+$\mathbb{C}((q))$ generated by $j$: it satisfies a monic polynomial equation with coefficients in
+$\mathbb{C}[j]$.
+
+This is the classical statement that a modular function for a congruence subgroup which is
+holomorphic on the upper half-plane is integral over $\mathbb{C}[j]$, here in the form of an
+integrality assertion about the $q$-expansion of such a function, obtained from the level-one case
+by multiplying by a power of $\Delta$. It feeds into the estimate
+[`ModularCurve.
+ord_sub_algebraMap_le_one_laurentBaseChange_qExpFunctionFieldC_of_ne_zero_of_ne_1728`]
+(thm.html#ModularCurve.
+ord_sub_algebraMap_le_one_laurentBaseChange_qExpFunctionFieldC_of_ne_zero_of_ne_1728),
+which controls orders of vanishing of elements of the function field of the modular curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder
+
+noncomputable section
+
+p2m_open "UpperHalfPlane Filter Function Complex Function.Complex"
+open scoped MatrixGroups Topology ModularForm Manifold Pointwise
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC jqModC_eq_qExpansion_E4_cube_div_discriminant"
+namespace IntegralGammaAux
+p2m_open "ModularCurve"
+
+section Analytic
+
+variable {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+theorem analyticOnNhd_comp_ofComplex {f : ℍ → ℂ} (hf : MDiff f) :
+    AnalyticOnNhd ℂ (f ∘ ofComplex) {z : ℂ | 0 < z.im} :=
+  (UpperHalfPlane.mdifferentiable_iff.mp hf).analyticOnNhd isOpen_upperHalfPlaneSet
+
+theorem eq_zero_of_eventuallyEq_zero {f : ℍ → ℂ} (hf : MDiff f) {c : ℂ} (hc : 0 < c.im)
+    (h : ∀ᶠ z in 𝓝 c, (f ∘ ofComplex) z = 0) : f = 0 := by
+  have hU : IsPreconnected {z : ℂ | 0 < z.im} := (convex_halfSpace_im_gt 0).isPreconnected
+  have key := (analyticOnNhd_comp_ofComplex hf).eqOn_zero_of_preconnected_of_eventuallyEq_zero
+    hU hc h
+  funext τ
+  have := key τ.im_pos
+  simp only [comp_apply, ofComplex_apply] at this
+  exact this
+
+theorem eventually_ne_zero {f : ℍ → ℂ} (hf : MDiff f) (hf0 : f ≠ 0) {c : ℂ} (hc : 0 < c.im) :
+    ∀ᶠ z in 𝓝[≠] c, f (ofComplex z) ≠ 0 := by
+  rcases (analyticOnNhd_comp_ofComplex hf c hc).eventually_eq_zero_or_eventually_ne_zero with
+    h | h
+  · exact absurd (eq_zero_of_eventuallyEq_zero hf hc h) hf0
+  · exact h
+
+theorem continuousAt_ofComplex {c : ℂ} (hc : 0 < c.im) : ContinuousAt ofComplex c :=
+  (mdifferentiableAt_ofComplex hc).continuousAt
+
+theorem tendsto_ofComplex_nhdsNE (τ : ℍ) :
+    Tendsto ofComplex (𝓝[≠] (τ : ℂ)) (𝓝[≠] τ) := by
+  refine tendsto_nhdsWithin_iff.mpr ⟨?_, ?_⟩
+  · have h2 := (continuousAt_ofComplex τ.im_pos).tendsto
+    rw [ofComplex_apply] at h2
+    exact h2.mono_left nhdsWithin_le_nhds
+  · filter_upwards [self_mem_nhdsWithin,
+      mem_nhdsWithin_of_mem_nhds (isOpen_upperHalfPlaneSet.mem_nhds τ.im_pos)] with z hz hU
+    intro h
+    apply hz
+    have hU' : 0 < z.im := hU
+    have := congrArg UpperHalfPlane.coe (Set.mem_singleton_iff.mp h)
+    simpa [ofComplex_apply_of_im_pos hU'] using this
+
+theorem eq_of_eq_off_zeros {h u v : ℍ → ℂ}
+    (hh : ∀ c : ℂ, 0 < c.im → ∀ᶠ z in 𝓝[≠] c, h (ofComplex z) ≠ 0)
+    (hu : Continuous u) (hv : Continuous v) (huv : ∀ τ, h τ ≠ 0 → u τ = v τ) : u = v := by
+  funext τ
+  have hcu : ContinuousAt (u ∘ ofComplex) (τ : ℂ) :=
+    hu.continuousAt.comp_of_eq (continuousAt_ofComplex τ.im_pos) (ofComplex_apply τ)
+  have hcv : ContinuousAt (v ∘ ofComplex) (τ : ℂ) :=
+    hv.continuousAt.comp_of_eq (continuousAt_ofComplex τ.im_pos) (ofComplex_apply τ)
+  have hev : (u ∘ ofComplex) =ᶠ[𝓝[≠] (τ : ℂ)] (v ∘ ofComplex) :=
+    (hh τ τ.im_pos).mono fun z hz => huv _ hz
+  have := tendsto_nhds_unique_of_eventuallyEq (hcu.tendsto.mono_left nhdsWithin_le_nhds)
+    (hcv.tendsto.mono_left nhdsWithin_le_nhds) hev
+  simpa only [comp_apply, ofComplex_apply] using this
+
+theorem exists_mdifferentiable_mul_eq {g h : ℍ → ℂ} (hg : MDiff g) (hh : MDiff h)
+    (hh0 : ∀ c : ℂ, 0 < c.im → ∀ᶠ z in 𝓝[≠] c, h (ofComplex z) ≠ 0)
+    (hb : ∀ τ : ℍ, ∃ M : ℝ, ∀ᶠ z in 𝓝[≠] (τ : ℂ), ‖g (ofComplex z) / h (ofComplex z)‖ ≤ M) :
+    ∃ F₀ : ℍ → ℂ, MDiff F₀ ∧ ∀ τ, F₀ τ * h τ = g τ := by
+  set φ : ℂ → ℂ := fun z => g (ofComplex z) / h (ofComplex z) with hφ
+  set ψ : ℂ → ℂ := fun c => limUnder (𝓝[≠] c) φ with hψ
+  have hA : ∀ c : ℂ, ∀ hc : 0 < c.im, h (ofComplex c) ≠ 0 → DifferentiableAt ℂ φ c := by
+    intro c hc hne
+    have hg' : DifferentiableAt ℂ (g ∘ ofComplex) c := mdifferentiableAt_iff.mp (hg ⟨c, hc⟩)
+    have hh' : DifferentiableAt ℂ (h ∘ ofComplex) c := mdifferentiableAt_iff.mp (hh ⟨c, hc⟩)
+    exact hg'.div hh' hne
+  have hB : ∀ c : ℂ, 0 < c.im → h (ofComplex c) ≠ 0 → ψ c = φ c := fun c hc hne =>
+    ((hA c hc hne).continuousAt.tendsto.mono_left nhdsWithin_le_nhds).limUnder_eq
+  have hC : DifferentiableOn ℂ ψ {z : ℂ | 0 < z.im} := by
+    intro c hc
+    have hc' : 0 < c.im := hc
+    obtain ⟨M, hM⟩ := hb ⟨c, hc'⟩
+    have hev : ∀ᶠ z in 𝓝[≠] c, h (ofComplex z) ≠ 0 ∧ ‖φ z‖ ≤ M ∧ 0 < z.im :=
+      (hh0 c hc').and (hM.and (mem_nhdsWithin_of_mem_nhds
+        (isOpen_upperHalfPlaneSet.mem_nhds hc')))
+    rw [eventually_nhdsWithin_iff, Metric.eventually_nhds_iff_ball] at hev
+    obtain ⟨ε, hε, hball⟩ := hev
+    have hd : DifferentiableOn ℂ φ (Metric.ball c ε \ {c}) := fun z hz =>
+      (hA z (hball z hz.1 hz.2).2.2 (hball z hz.1 hz.2).1).differentiableWithinAt
+    have hbdd : BddAbove (norm ∘ φ '' (Metric.ball c ε \ {c})) := by
+      refine ⟨M, ?_⟩
+      rintro _ ⟨z, hz, rfl⟩
+      exact (hball z hz.1 hz.2).2.1
+    have R := Complex.differentiableOn_update_limUnder_of_bddAbove (Metric.ball_mem_nhds c hε)
+      hd hbdd
+    have heq : Set.EqOn ψ (update φ c (limUnder (𝓝[≠] c) φ)) (Metric.ball c ε) := by
+      intro z hz
+      by_cases hzc : z = c
+      · subst hzc; simp [hψ]
+      · rw [update_of_ne hzc]
+        exact hB z (hball z hz hzc).2.2 (hball z hz hzc).1
+    have hψs : DifferentiableOn ℂ ψ (Metric.ball c ε) := R.congr heq
+    exact (hψs.differentiableAt (Metric.isOpen_ball.mem_nhds (Metric.mem_ball_self hε)))
+      |>.differentiableWithinAt
+  refine ⟨fun τ => ψ τ, ?_, ?_⟩
+  · refine UpperHalfPlane.mdifferentiable_iff.mpr (hC.congr fun z hz => ?_)
+    have hz' : 0 < z.im := hz
+    simp only [comp_apply, ofComplex_apply_of_im_pos hz', UpperHalfPlane.coe_mk]
+  · have hF : MDiff (fun τ : ℍ => ψ τ) := by
+      refine UpperHalfPlane.mdifferentiable_iff.mpr (hC.congr fun z hz => ?_)
+      have hz' : 0 < z.im := hz
+      simp only [comp_apply, ofComplex_apply_of_im_pos hz', UpperHalfPlane.coe_mk]
+    have key := eq_of_eq_off_zeros (u := fun τ => ψ τ * h τ) (v := g) hh0
+      (hF.continuous.mul hh.continuous) hg.continuous (fun τ hτ => by
+        have h1 : h (ofComplex (τ : ℂ)) ≠ 0 := by rwa [ofComplex_apply]
+        have := hB τ τ.im_pos h1
+        simp only [this, hφ, ofComplex_apply]
+        exact div_mul_cancel₀ _ hτ)
+    exact fun τ => congrFun key τ
+
+end Analytic
+
+section CuspGrowth
+
+variable {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+theorem norm_qParam_lt_one' {h : ℝ} (hh : 0 < h) (τ : ℍ) : ‖Periodic.qParam h (τ : ℂ)‖ < 1 := by
+  have := (Periodic.norm_qParam_lt_iff hh 0 (τ : ℂ)).mpr (by simpa using τ.im_pos)
+  simpa using this
+
+theorem exists_qParam_pow_le {h : ℝ} (hh : 0 < h) (hΓ : h ∈ Γ.strictPeriods)
+    (f : ModularForm Γ k) (hf : f ≠ 0) :
+    ∃ (n : ℕ) (C : ℝ), 0 < C ∧ ∀ᶠ τ : ℍ in atImInfty,
+      C * ‖Periodic.qParam h (τ : ℂ)‖ ^ n ≤ ‖f τ‖ := by
+  have hper := SlashInvariantFormClass.periodic_comp_ofComplex f hΓ
+  have hΦ : AnalyticAt ℂ (cuspFunction h f) 0 :=
+    ModularFormClass.analyticAt_cuspFunction_zero f hh hΓ
+  have hne : ¬ (∀ᶠ q in 𝓝 (0 : ℂ), cuspFunction h f q = 0) := by
+    intro hev
+    apply hf
+    have : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods hh hΓ⟩
+    have hball : AnalyticOnNhd ℂ (cuspFunction h f) (Metric.ball 0 1) :=
+      (differentiableOn_cuspFunction_ball hh hper (ModularFormClass.holo f)
+        (ModularFormClass.bdd_at_infty f)).analyticOnNhd Metric.isOpen_ball
+    have hz := hball.eqOn_zero_of_preconnected_of_eventuallyEq_zero
+      (convex_ball (0 : ℂ) 1).isPreconnected (Metric.mem_ball_self one_pos) hev
+    ext τ
+    have hq : Periodic.qParam h (τ : ℂ) ∈ Metric.ball (0 : ℂ) 1 := by
+      simpa using norm_qParam_lt_one' hh τ
+    have := hz hq
+    rw [eq_cuspFunction τ hh.ne' hper] at this
+    simpa using this
+  obtain ⟨n, φ, hφ, hφ0, hev⟩ := hΦ.exists_eventuallyEq_pow_smul_nonzero_iff.mpr hne
+  refine ⟨n, ‖φ 0‖ / 2, by positivity, ?_⟩
+  have hlow : ∀ᶠ q in 𝓝 (0 : ℂ), ‖φ 0‖ / 2 < ‖φ q‖ :=
+    hφ.continuousAt.norm.eventually_const_lt (by simpa using hφ0)
+  have hq0 : Tendsto (fun τ : ℍ => Periodic.qParam h (τ : ℂ)) atImInfty (𝓝 0) :=
+    qParam_tendsto_atImInfty hh
+  filter_upwards [hq0.eventually hlow, hq0.eventually hev] with τ h1 h2
+  rw [← eq_cuspFunction τ hh.ne' hper, h2, norm_smul, norm_pow, mul_comm, sub_zero]
+  gcongr
+
+theorem exists_norm_discriminant_le :
+    ∃ C : ℝ, ∀ᶠ τ : ℍ in atImInfty,
+      ‖ModularForm.discriminant τ‖ ≤ C * ‖Periodic.qParam 1 (τ : ℂ)‖ := by
+  have h := CuspFormClass.exp_decay_atImInfty (h := 1) CuspForm.discriminant one_pos
+    (by simp)
+  obtain ⟨C, hC⟩ := h.bound
+  refine ⟨C, hC.mono fun τ hτ => ?_⟩
+  rw [Periodic.norm_qParam]
+  have : ‖Real.exp (-2 * Real.pi * τ.im / 1)‖ = Real.exp (-2 * Real.pi * (τ : ℂ).im / 1) := by
+    rw [Real.norm_eq_abs, abs_of_pos (Real.exp_pos _)]
+    rfl
+  rw [← this]
+  exact hτ
+
+theorem norm_qParam_one_le {N : ℝ} (hN : 1 ≤ N) (τ : ℍ) :
+    ‖Periodic.qParam 1 (τ : ℂ)‖ ≤ ‖Periodic.qParam N (τ : ℂ)‖ := by
+  rw [Periodic.norm_qParam, Periodic.norm_qParam, Real.exp_le_exp, div_one]
+  rw [le_div_iff₀ (by linarith)]
+  have h1 : 0 ≤ 2 * Real.pi * (τ : ℂ).im := by
+    have := τ.im_pos
+    have : (0 : ℝ) < (τ : ℂ).im := this
+    positivity
+  nlinarith
+
+end CuspGrowth
+
+theorem key_ineq {a b c d q q₁ C M D : ℝ} {n m : ℕ} (ha : 0 ≤ a) (hd : 0 ≤ d)
+    (hab : a * b = c) (hb : C * q ^ n ≤ b) (hc : c ≤ M) (hdq : d ≤ D * q₁) (hq₁ : q₁ ≤ q)
+    (hq1 : q ≤ 1) (hq0 : 0 < q) (hq₁0 : 0 ≤ q₁) (hC : 0 < C) (hD : 0 ≤ D) (hM : 0 ≤ M)
+    (hnm : n ≤ m) : a * d ^ m ≤ M * D ^ m / C := by
+  have h1 : a * d ^ m * C * q ^ n ≤ M * D ^ m * q ^ n :=
+    calc a * d ^ m * C * q ^ n = a * d ^ m * (C * q ^ n) := by ring
+      _ ≤ a * d ^ m * b := by gcongr
+      _ = c * d ^ m := by rw [← hab]; ring
+      _ ≤ M * d ^ m := by gcongr
+      _ ≤ M * (D * q₁) ^ m := by gcongr
+      _ ≤ M * (D * q) ^ m := by gcongr
+      _ = M * D ^ m * q ^ m := by ring
+      _ ≤ M * D ^ m * q ^ n :=
+        mul_le_mul_of_nonneg_left (pow_le_pow_of_le_one hq0.le hq1 hnm) (by positivity)
+  rw [le_div_iff₀ hC]
+  exact le_of_mul_le_mul_right h1 (pow_pos hq0 n)
+
+section Level
+
+variable (M : ℕ) (Γ : Subgroup SL(2, ℤ)) (hM : CongruenceSubgroup.Gamma M ≤ Γ) {k : ℤ}
+
+def restrict {F : Type*} [FunLike F ℍ ℂ] {Γ Γ' : Subgroup (GL (Fin 2) ℝ)} (hle : Γ' ≤ Γ)
+    {k : ℤ} (f : F) [ModularFormClass F Γ k] : ModularForm Γ' k where
+  toFun := f
+  slash_action_eq' γ hγ := SlashInvariantFormClass.slash_action_eq f γ (hle hγ)
+  holo' := ModularFormClass.holo f
+  bdd_at_cusps' hc := ModularFormClass.bdd_at_cusps f (hc.mono hle)
+
+include hM in
+theorem Gamma_le_conj (A : SL(2, ℤ)) :
+    ((CongruenceSubgroup.Gamma M : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) ≤
+      ConjAct.toConjAct (Matrix.SpecialLinearGroup.mapGL ℝ A)⁻¹ •
+        ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) := by
+  rintro _ ⟨y, hy, rfl⟩
+  rw [Subgroup.mem_pointwise_smul_iff_inv_smul_mem, ← ConjAct.toConjAct_inv, inv_inv,
+    ConjAct.toConjAct_smul]
+  refine ⟨A * y * A⁻¹, hM ((CongruenceSubgroup.Gamma_normal M).conj_mem y hy A), ?_⟩
+  simp [map_mul, map_inv]
+
+def translateSL (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (A : SL(2, ℤ)) :
+    ModularForm (CongruenceSubgroup.Gamma M) k :=
+  restrict (Gamma_le_conj M Γ hM A) (ModularForm.translate f (Matrix.SpecialLinearGroup.mapGL ℝ A))
+
+@[scoped simp] theorem coe_translateSL (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (A : SL(2, ℤ)) : ⇑(translateSL M Γ hM f A) = ⇑f ∣[k] A := rfl
+
+theorem natCast_mem_strictPeriods_Gamma :
+    (M : ℝ) ∈ (CongruenceSubgroup.Gamma M : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  simp
+
+theorem natCast_pos [NeZero M] : (0 : ℝ) < M := Nat.cast_pos.mpr (Nat.pos_of_ne_zero (NeZero.ne M))
+
+include hM in
+theorem exists_qParam_pow_le_slash [NeZero M] (h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (hh : h ≠ 0) (A : SL(2, ℤ)) :
+    ∃ (n : ℕ) (C : ℝ), 0 < C ∧ ∀ᶠ τ : ℍ in atImInfty,
+      C * ‖Periodic.qParam M (τ : ℂ)‖ ^ n ≤ ‖(⇑h ∣[k] A) τ‖ := by
+  have hne : translateSL M Γ hM h A ≠ 0 := by
+    intro h0
+    apply hh
+    have h1 : (⇑h ∣[k] A) = 0 := by
+      rw [← coe_translateSL M Γ hM h A, h0]; rfl
+    rw [SlashAction.slash_eq_zero_iff] at h1
+    exact (FunLike.coe_zero_iff h).mp h1
+  exact exists_qParam_pow_le (natCast_pos M) (natCast_mem_strictPeriods_Gamma M)
+    (translateSL M Γ hM h A) hne
+
+open scoped Classical in
+def cuspOrder (φ : ℍ → ℂ) : ℕ :=
+  if H : ∃ (n : ℕ) (C : ℝ), 0 < C ∧ ∀ᶠ τ : ℍ in atImInfty,
+      C * ‖Periodic.qParam M (τ : ℂ)‖ ^ n ≤ ‖φ τ‖
+  then H.choose else 0
+
+theorem cuspOrder_spec (φ : ℍ → ℂ)
+    (H : ∃ (n : ℕ) (C : ℝ), 0 < C ∧ ∀ᶠ τ : ℍ in atImInfty,
+      C * ‖Periodic.qParam M (τ : ℂ)‖ ^ n ≤ ‖φ τ‖) :
+    ∃ C : ℝ, 0 < C ∧ ∀ᶠ τ : ℍ in atImInfty,
+      C * ‖Periodic.qParam M (τ : ℂ)‖ ^ (cuspOrder M φ) ≤ ‖φ τ‖ := by
+  rw [cuspOrder, dite_eq_left H]
+  exact H.choose_spec
+
+theorem exists_forall_cuspOrder_le [Γ.FiniteIndex] (h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    :
+    ∃ m : ℕ, ∀ A : SL(2, ℤ), cuspOrder M (⇑h ∣[k] A) ≤ m := by
+  classical
+  have : Finite (SL(2, ℤ) ⧸ Γ) := Subgroup.finite_quotient_of_finiteIndex
+  let ψ : SL(2, ℤ) ⧸ Γ → ℕ := fun q => cuspOrder M (⇑h ∣[k] (q.out)⁻¹)
+  obtain ⟨m, hm⟩ := (Set.finite_range ψ).bddAbove
+  refine ⟨m, fun A => ?_⟩
+  set B : SL(2, ℤ) := ((A⁻¹ : SL(2, ℤ)) : SL(2, ℤ) ⧸ Γ).out with hB
+  have hq : ((A⁻¹ : SL(2, ℤ)) : SL(2, ℤ) ⧸ Γ) = (B : _) := (QuotientGroup.out_eq' _).symm
+  rw [QuotientGroup.eq, inv_inv] at hq
+  have hslash : ⇑h ∣[k] (A * B) = ⇑h :=
+    SlashInvariantFormClass.slash_action_eq h (Matrix.SpecialLinearGroup.mapGL ℝ (A * B))
+      (Subgroup.mem_map_of_mem _ hq)
+  have key : ⇑h ∣[k] A = ⇑h ∣[k] B⁻¹ :=
+    calc ⇑h ∣[k] A = ⇑h ∣[k] ((A * B) * B⁻¹) := by rw [mul_inv_cancel_right]
+      _ = (⇑h ∣[k] (A * B)) ∣[k] B⁻¹ := SlashAction.slash_mul _ _ _ _
+      _ = ⇑h ∣[k] B⁻¹ := by rw [hslash]
+  rw [key]
+  exact hm ⟨_, rfl⟩
+
+include hM in
+theorem isBoundedAtImInfty_of_mul_eq [NeZero M] (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (hh : h ≠ 0) (F₀ : ℍ → ℂ) (hF : ∀ τ, F₀ τ * h τ = g τ) (A : SL(2, ℤ)) {m : ℕ}
+    (hm : cuspOrder M (⇑h ∣[k] A) ≤ m) :
+    IsBoundedAtImInfty (fun τ : ℍ => F₀ (A • τ) * (ModularForm.discriminant τ) ^ m) := by
+  obtain ⟨C, hC, hlow⟩ := cuspOrder_spec M _ (exists_qParam_pow_le_slash M Γ hM h hh A)
+  have hgA : IsBoundedAtImInfty (⇑g ∣[k] A) :=
+    ModularFormClass.bdd_at_infty (translateSL M Γ hM g A)
+  obtain ⟨D, hD⟩ := exists_norm_discriminant_le
+  rw [IsBoundedAtImInfty, BoundedAtFilter] at hgA ⊢
+  obtain ⟨M', hM'⟩ := hgA.bound
+  refine Asymptotics.IsBigO.of_bound (max M' 0 * max D 0 ^ m / C) ?_
+  filter_upwards [hlow, hM', hD] with τ h1 h2 h3
+  simp only [Pi.one_apply, norm_one, mul_one] at h2 ⊢
+  have hq0 : 0 < ‖Periodic.qParam M (τ : ℂ)‖ := by
+    rw [Periodic.norm_qParam]; exact Real.exp_pos _
+  have hq1 : ‖Periodic.qParam M (τ : ℂ)‖ ≤ 1 := (norm_qParam_lt_one' (natCast_pos M) τ).le
+  have hq₁ : ‖Periodic.qParam 1 (τ : ℂ)‖ ≤ ‖Periodic.qParam M (τ : ℂ)‖ :=
+    norm_qParam_one_le (Nat.one_le_cast.mpr NeZero.one_le) τ
+  have hab : ‖F₀ (A • τ)‖ * ‖(⇑h ∣[k] A) τ‖ = ‖(⇑g ∣[k] A) τ‖ := by
+    rw [← norm_mul, ModularForm.SL_slash_apply, ModularForm.SL_slash_apply, ← mul_assoc, hF]
+  rw [norm_mul, norm_pow]
+  exact key_ineq (norm_nonneg _) (norm_nonneg _) hab h1 (h2.trans (le_max_left _ _))
+    (h3.trans (mul_le_mul_of_nonneg_right (le_max_left _ _) (norm_nonneg _))) hq₁ hq1 hq0
+    (norm_nonneg _) hC (le_max_right _ _) (le_max_right _ _) hm
+
+end Level
+
+section Assembly
+
+variable (M : ℕ) [NeZero M] (Γ : Subgroup SL(2, ℤ)) (hM : CongruenceSubgroup.Gamma M ≤ Γ)
+  (hT : ModularGroup.T ∈ Γ)
+
+scoped instance isArithmetic_map [Γ.FiniteIndex] :
+    ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)).IsArithmetic := inferInstance
+
+abbrev qL (f : ℍ → ℂ) : LaurentSeries ℂ := ((qExpansion 1 f : PowerSeries ℂ) : LaurentSeries ℂ)
+
+include hT in
+omit [NeZero M] in
+theorem one_mem_strictPeriods :
+    (1 : ℝ) ∈ ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  rw [Subgroup.mem_strictPeriods_iff]
+  refine ⟨ModularGroup.T, hT, ?_⟩
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp [ModularGroup.T, Matrix.GeneralLinearGroup.upperRightHom]
+
+omit [NeZero M] in
+theorem le_SL : ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) ≤ 𝒮ℒ :=
+  Subgroup.map_le_range _ _
+
+def Δ₀ : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12 :=
+  restrict (le_SL Γ) CuspForm.discriminant
+
+omit [NeZero M] in
+@[scoped simp] theorem coe_Δ₀ :
+    ((Δ₀ Γ : ModularForm _ 12) : ℍ → ℂ) = ModularForm.discriminant := rfl
+
+def Δ₁ : ModularForm 𝒮ℒ 12 := restrict le_rfl CuspForm.discriminant
+
+@[scoped simp] theorem coe_Δ₁ : ((Δ₁ : ModularForm _ 12) : ℍ → ℂ) = ModularForm.discriminant := rfl
+
+omit [NeZero M] in
+theorem coe_ne_zero {k : ℤ} (h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hh : h ≠ 0) :
+    (h : ℍ → ℂ) ≠ 0 := fun e => hh ((FunLike.coe_zero_iff h).mp e)
+
+omit [NeZero M] in
+theorem eventually_ne_zero_coe {k : ℤ} (h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (hh : h ≠ 0) (c : ℂ) (hc : 0 < c.im) : ∀ᶠ z in 𝓝[≠] c, h (ofComplex z) ≠ 0 :=
+  eventually_ne_zero h.holo' (coe_ne_zero Γ h hh) hc
+
+omit [NeZero M] in
+theorem exists_F₀ {k : ℤ} (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hh : h ≠ 0)
+    (hb : ∀ τ : ℍ, IsBoundedUnder (· ≤ ·) (𝓝[≠] τ) (fun z : ℍ => ‖g z / h z‖)) :
+    ∃ F₀ : ℍ → ℂ, MDiff F₀ ∧ ∀ τ, F₀ τ * h τ = g τ := by
+  refine exists_mdifferentiable_mul_eq g.holo' h.holo' (eventually_ne_zero_coe Γ h hh)
+    (fun τ => ?_)
+  obtain ⟨M', hM'⟩ := hb τ
+  refine ⟨M', ?_⟩
+  have h1 : ∀ᶠ z : ℍ in 𝓝[≠] τ, ‖g z / h z‖ ≤ M' := hM'
+  exact (tendsto_ofComplex_nhdsNE τ).eventually h1
+
+omit [NeZero M] in
+theorem slash_zero_eq {k : ℤ} (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hh : h ≠ 0)
+    (F₀ : ℍ → ℂ) (hF₀ : MDiff F₀) (hF : ∀ τ, F₀ τ * h τ = g τ) (γ : SL(2, ℤ))
+    (hγ : γ ∈ Γ) : F₀ ∣[(0 : ℤ)] γ = F₀ := by
+  refine eq_of_eq_off_zeros (eventually_ne_zero_coe Γ h hh)
+    (hF₀.slash 0 (γ : GL (Fin 2) ℝ)).continuous hF₀.continuous (fun τ hτ => ?_)
+  rw [ModularForm.SL_slash_apply, neg_zero, zpow_zero, mul_one]
+  have eh : h (γ • τ) = denom γ τ ^ k * h τ := SlashInvariantForm.slash_action_eqn_SL'' h hγ τ
+  have eg : g (γ • τ) = denom γ τ ^ k * g τ := SlashInvariantForm.slash_action_eqn_SL'' g hγ τ
+  have hd : (denom γ τ) ^ k ≠ 0 := zpow_ne_zero _ (denom_ne_zero _ _)
+  have e1 := hF (γ • τ)
+  have e2 := hF τ
+  rw [eh, eg] at e1
+  have : F₀ (γ • τ) * (denom γ τ ^ k * h τ) = F₀ τ * (denom γ τ ^ k * h τ) := by
+    rw [e1, ← e2]; ring
+  exact mul_right_cancel₀ (mul_ne_zero hd hτ) this
+
+include hM in
+def liftForm [Γ.FiniteIndex] {k : ℤ} (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (hh : h ≠ 0)
+    (F₀ : ℍ → ℂ) (hF₀ : MDiff F₀) (hF : ∀ τ, F₀ τ * h τ = g τ) (m : ℕ)
+    (hm : ∀ A : SL(2, ℤ), cuspOrder M (⇑h ∣[k] A) ≤ m) :
+    ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) ((m : ℤ) * 12) where
+  toFun := F₀ * ⇑(Δ₁.pow m)
+  slash_action_eq' γ hγ := by
+    obtain ⟨γ, hγ', rfl⟩ := hγ
+    have hΔ : (⇑(Δ₁.pow m)) ∣[((m : ℤ) * 12)] γ = ⇑(Δ₁.pow m) :=
+      SlashInvariantFormClass.slash_action_eq (Δ₁.pow m)
+        (Matrix.SpecialLinearGroup.mapGL ℝ γ) ⟨γ, rfl⟩
+    have e := ModularForm.mul_slash_SL2 0 ((m : ℤ) * 12) γ F₀ ⇑(Δ₁.pow m)
+    rw [zero_add] at e
+    change (F₀ * ⇑(Δ₁.pow m)) ∣[((m : ℤ) * 12)] γ = F₀ * ⇑(Δ₁.pow m)
+    rw [e, slash_zero_eq Γ g h hh F₀ hF₀ hF γ hγ', hΔ]
+  holo' := hF₀.mul (Δ₁.pow m).holo'
+  bdd_at_cusps' {c} hc := by
+    rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z] at hc
+    rw [OnePoint.isBoundedAt_iff_forall_SL2Z hc]
+    intro A _
+    have hΔ : (⇑(Δ₁.pow m)) ∣[((m : ℤ) * 12)] A = ⇑(Δ₁.pow m) :=
+      SlashInvariantFormClass.slash_action_eq (Δ₁.pow m)
+        (Matrix.SpecialLinearGroup.mapGL ℝ A) ⟨A, rfl⟩
+    have e := ModularForm.mul_slash_SL2 0 ((m : ℤ) * 12) A F₀ ⇑(Δ₁.pow m)
+    rw [zero_add] at e
+    change IsBoundedAtImInfty ((F₀ * ⇑(Δ₁.pow m)) ∣[((m : ℤ) * 12)] A)
+    rw [e, hΔ]
+    have : (F₀ ∣[(0 : ℤ)] A * ⇑(Δ₁.pow m)) =
+        fun τ => F₀ (A • τ) * ModularForm.discriminant τ ^ m := by
+      funext τ
+      simp [ModularForm.SL_slash_apply]
+    rw [this]
+    exact isBoundedAtImInfty_of_mul_eq M Γ hM g h hh F₀ hF A (hm A)
+
+theorem coe_liftForm' [Γ.FiniteIndex] {k : ℤ} (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (hh : h ≠ 0)
+    (F₀ : ℍ → ℂ) (hF₀ : MDiff F₀) (hF : ∀ τ, F₀ τ * h τ = g τ) (m : ℕ)
+    (hm : ∀ A : SL(2, ℤ), cuspOrder M (⇑h ∣[k] A) ≤ m) :
+    ⇑(liftForm M Γ hM g h hh F₀ hF₀ hF m hm) = F₀ * ⇑(Δ₁.pow m) := rfl
+
+theorem coe_liftForm [Γ.FiniteIndex] {k : ℤ} (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (hh : h ≠ 0)
+    (F₀ : ℍ → ℂ) (hF₀ : MDiff F₀) (hF : ∀ τ, F₀ τ * h τ = g τ) (m : ℕ)
+    (hm : ∀ A : SL(2, ℤ), cuspOrder M (⇑h ∣[k] A) ≤ m) :
+    (⇑(liftForm M Γ hM g h hh F₀ hF₀ hF m hm)) * ⇑h = ⇑g * ⇑((Δ₀ Γ).pow m) := by
+  rw [coe_liftForm']
+  funext τ
+  simp only [Pi.mul_apply, ModularForm.coe_pow, Pi.pow_apply, coe_Δ₀, coe_Δ₁]
+  rw [mul_right_comm, hF]
+
+include hT in
+theorem qL_liftForm_mul [Γ.FiniteIndex] {k : ℤ} (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (hh : h ≠ 0)
+    (F₀ : ℍ → ℂ) (hF₀ : MDiff F₀) (hF : ∀ τ, F₀ τ * h τ = g τ) (m : ℕ)
+    (hm : ∀ A : SL(2, ℤ), cuspOrder M (⇑h ∣[k] A) ≤ m) :
+    qL ⇑(liftForm M Γ hM g h hh F₀ hF₀ hF m hm) * qL ⇑h =
+      qL ⇑g * qL (ModularForm.discriminant) ^ m := by
+  have h1 := ModularForm.qExpansion_mul_coe one_pos (one_mem_strictPeriods Γ hT)
+    (liftForm M Γ hM g h hh F₀ hF₀ hF m hm) h
+  have h2 := ModularForm.qExpansion_mul_coe one_pos (one_mem_strictPeriods Γ hT)
+    g ((Δ₀ Γ).pow m)
+  have h3 := ModularForm.qExpansion_pow one_pos (one_mem_strictPeriods Γ hT) (Δ₀ Γ) m
+  rw [coe_liftForm] at h1
+  simp only [qL, ← PowerSeries.coe_mul, ← PowerSeries.coe_pow, ← h1, h2, h3, coe_Δ₀]
+
+include hT in
+omit [NeZero M] in
+theorem qL_ne_zero {k : ℤ} (h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hh : h ≠ 0) :
+    qL ⇑h ≠ 0 := by
+  intro e
+  apply hh
+  rw [← ModularForm.qExpansion_eq_zero_iff one_pos (one_mem_strictPeriods Γ hT)]
+  apply (HahnSeries.ofPowerSeries_injective (Γ := ℤ) (R := ℂ))
+  simpa [qL] using e
+
+theorem T_mem_SL : ModularGroup.T ∈ (⊤ : Subgroup SL(2, ℤ)) := Subgroup.mem_top _
+
+theorem Δ₀_ne_zero : Δ₀ (⊤ : Subgroup SL(2, ℤ)) ≠ 0 := by
+  intro e
+  have := congrArg (fun f : ModularForm ((⊤ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) 12 =>
+    (f : ℍ → ℂ) I) e
+  exact ModularForm.discriminant_ne_zero I (by simpa using this)
+
+theorem qL_discriminant_ne_zero : qL ModularForm.discriminant ≠ 0 := by
+  rw [← coe_Δ₀ (⊤ : Subgroup SL(2, ℤ))]
+  exact qL_ne_zero (⊤ : Subgroup SL(2, ℤ)) T_mem_SL (Δ₀ ⊤) Δ₀_ne_zero
+
+include hM hT in
+theorem isIntegral_of_forall_isBoundedUnder [Γ.FiniteIndex] {k : ℤ}
+    (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hh : h ≠ 0)
+    (hb : ∀ τ : ℍ, IsBoundedUnder (· ≤ ·) (𝓝[≠] τ) (fun z : ℍ => ‖g z / h z‖)) :
+    IsIntegral (Algebra.adjoin ℂ ({jqModC ℂ} : Set (LaurentSeries ℂ))) (qL ⇑g / qL ⇑h) := by
+  obtain ⟨F₀, hF₀, hF⟩ := exists_F₀ Γ g h hh hb
+  obtain ⟨m, hm⟩ := exists_forall_cuspOrder_le M Γ h
+  set F := liftForm M Γ hM g h hh F₀ hF₀ hF m hm with hFdef
+  have hq : qL ⇑F * qL ⇑h = qL ⇑g * qL ModularForm.discriminant ^ m :=
+    qL_liftForm_mul M Γ hM hT g h hh F₀ hF₀ hF m hm
+  have hxF : qL ⇑F / qL ModularForm.discriminant ^ m = qL ⇑g / qL ⇑h := by
+    rw [div_eq_div_iff (pow_ne_zero _ qL_discriminant_ne_zero) (qL_ne_zero Γ hT h hh)]
+    rw [hq]
+  have key := ModularForm.isIntegral_adjoin_qExpansion_div_discriminant_pow_of_isArithmetic
+    (one_mem_strictPeriods Γ hT) m (k := (m : ℤ) * 12) (by ring) F
+  rw [← jqModC_eq_qExpansion_E4_cube_div_discriminant] at key
+  rw [← hxF]
+  exact key
+
+end Assembly
+
+end ModularCurve.IntegralGammaAux
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC jqModC_eq_qExpansion_E4_cube_div_discriminant"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+theorem ModularCurve.IntegralGammaAux.Gamma_le_Gamma1 (M : ℕ) :
+    CongruenceSubgroup.Gamma M ≤ CongruenceSubgroup.Gamma1 M := by
+  intro A hA
+  rw [CongruenceSubgroup.Gamma_mem] at hA
+  rw [CongruenceSubgroup.Gamma1_mem]
+  exact ⟨hA.1, hA.2.2.2, hA.2.2.1⟩
+
+p2m_open_scoped "ModularCurve" in
+theorem ModularCurve.IntegralGammaAux.T_mem_Gamma1 (M : ℕ) :
+    ModularGroup.T ∈ CongruenceSubgroup.Gamma1 M := by
+  rw [CongruenceSubgroup.Gamma1_mem]
+  simp [ModularGroup.T]
+
+open scoped Topology in
+theorem solution
+    (M : ℕ) [NeZero M] (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+    (hΓ : CongruenceSubgroup.Gamma1 M ≤ Γ) {k : ℤ}
+    (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hh : h ≠ 0)
+    (hb : ∀ τ : UpperHalfPlane, Filter.IsBoundedUnder (· ≤ ·) (𝓝[≠] τ)
+      (fun z : UpperHalfPlane => ‖g z / h z‖)) :
+    IsIntegral (Algebra.adjoin ℂ ({ModularCurve.jqModC ℂ} : Set (LaurentSeries ℂ)))
+      (HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 ⇑g) /
+        HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 ⇑h)) := by
+  have : Γ.FiniteIndex := Subgroup.finiteIndex_of_le hΓ
+  exact ModularCurve.IntegralGammaAux.isIntegral_of_forall_isBoundedUnder M Γ
+    ((ModularCurve.IntegralGammaAux.Gamma_le_Gamma1 M).trans hΓ)
+    (hΓ (ModularCurve.IntegralGammaAux.T_mem_Gamma1 M)) g h hh hb
+
+end
+end S_ModularCurve_isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder
+end P2MW
+export P2MW.S_ModularCurve_isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Topology in
+theorem ModularCurve.isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder
+    (M : ℕ) [NeZero M] (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+    (hΓ : CongruenceSubgroup.Gamma1 M ≤ Γ) {k : ℤ}
+    (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hh : h ≠ 0)
+    (hb : ∀ τ : UpperHalfPlane, Filter.IsBoundedUnder (· ≤ ·) (𝓝[≠] τ)
+      (fun z : UpperHalfPlane => ‖g z / h z‖)) :
+    IsIntegral (Algebra.adjoin ℂ ({ModularCurve.jqModC ℂ} : Set (LaurentSeries ℂ)))
+      (HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 ⇑g) /
+        HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 ⇑h)) :=
+  solution M Γ hΓ g h hh hb
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder_of_finiteIndex.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder_of_finiteIndex.lean
new file mode 100644
index 0000000000..6615eaa13f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder_of_finiteIndex.lean
@@ -0,0 +1,613 @@
+/-
+Based on Prove2Me node
+ModularCurve.isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder_of_finiteIndex
+(92920117-e244-5e68-a7e2-72bc7583480f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 0ec0d603-b082-54a5-8bcd-bae1227ddeb2
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_isIntegral_adjoin_qExpansion_div_discriminant_pow_of_isArithmetic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality over ℂ[j] of q-expansion quotients of modular forms
+
+Theorem statement:
+`ModularCurve.isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder_of_finiteIndex`
+(`92920117-e244-5e68-a7e2-72bc7583480f`), by Claude, 2026-09-05.
+
+Proof: submission `0ec0d603-b082-54a5-8bcd-bae1227ddeb2`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of $\mathrm{SL}_2(\mathbb{Z})$ of finite index containing the translation
+matrix $T = \begin{pmatrix} 1 & 1 \\ 0 & 1\end{pmatrix}$, let $k$ be an integer, and let $g, h$ be
+modular forms of weight $k$ for the image of $\Gamma$ in $\mathrm{GL}_2(\mathbb{R})$, with $h \ne
+0$. Assume that for every point $\tau$ of the upper half plane $\mathbb{H}$ the function $z \mapsto
+\lVert g(z)/h(z)\rVert$ is bounded above along the filter of punctured neighbourhoods of $\tau$
+(i.e. $g/h$ is locally bounded near each point of $\mathbb{H}$ after removing the point itself).
+Write $\tilde g, \tilde h \in \mathbb{C}[[q]]$ for the $q$-expansions of $g$ and $h$ of period $1$
+at $i\infty$, regarded as Laurent series in $\mathbb{C}((q))$. Then the quotient $\tilde g/\tilde h
+\in \mathbb{C}((q))$ is integral over the $\mathbb{C}$-subalgebra of $\mathbb{C}((q))$ generated by
+the single element [`ModularCurve.jqModC ℂ`](def/ModularCurve_JqCoeff.html#L15), namely $q^{-1}$
+times the image in $\mathbb{C}[[q]]$ of the integral power series $E_4^3 \cdot (\text{the inverse
+unit power series attached to the Dedekind }\eta\text{-product})$, i.e. the $q$-expansion $q^{-1} +
+744 + 196884\,q + \cdots$ of the modular invariant $j$.
+
+This is the integrality statement underlying the classical fact that a modular function for a
+finite-index subgroup of $\mathrm{SL}_2(\mathbb{Z})$ which is holomorphic on $\mathbb{H}$, with
+poles only at the cusps, is integral over $\mathbb{C}[j]$; here it is formulated at the level of
+$q$-expansions in $\mathbb{C}((q))$. It is used in the construction of the complex points of modular
+curves, via
+[`ModularCurve.ComplexPlaceDictionaryOf.exists_pt_eq_of_mem`]
+(thm.html#ModularCurve.ComplexPlaceDictionaryOf.exists_pt_eq_of_mem).
+The proof cites the identification of [`ModularCurve.jqModC ℂ`](def/ModularCurve_JqCoeff.html#L15)
+with $\tilde{E_4}^3/\tilde\Delta$ and the integrality of $\tilde g/\tilde\Delta^m$ over
+$\mathbb{C}[\tilde{E_4}^3/\tilde\Delta]$ for forms of weight $12m$ on arithmetic subgroups.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder_of_finiteIndex.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_5b0eac03
+
+noncomputable section
+
+p2m_open "UpperHalfPlane Filter Function Complex Function.Complex"
+open scoped MatrixGroups Topology ModularForm Manifold Pointwise
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC jqModC_eq_qExpansion_E4_cube_div_discriminant"
+namespace Ws49
+namespace IntFI
+p2m_open "ModularCurve"
+
+section Analytic
+
+variable {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+theorem analyticOnNhd_comp_ofComplex {f : ℍ → ℂ} (hf : MDiff f) :
+    AnalyticOnNhd ℂ (f ∘ ofComplex) {z : ℂ | 0 < z.im} :=
+  (UpperHalfPlane.mdifferentiable_iff.mp hf).analyticOnNhd isOpen_upperHalfPlaneSet
+
+theorem eq_zero_of_eventuallyEq_zero {f : ℍ → ℂ} (hf : MDiff f) {c : ℂ} (hc : 0 < c.im)
+    (h : ∀ᶠ z in 𝓝 c, (f ∘ ofComplex) z = 0) : f = 0 := by
+  have hU : IsPreconnected {z : ℂ | 0 < z.im} := (convex_halfSpace_im_gt 0).isPreconnected
+  have key := (analyticOnNhd_comp_ofComplex hf).eqOn_zero_of_preconnected_of_eventuallyEq_zero
+    hU hc h
+  funext τ
+  have := key τ.im_pos
+  simp only [comp_apply, ofComplex_apply] at this
+  exact this
+
+theorem eventually_ne_zero {f : ℍ → ℂ} (hf : MDiff f) (hf0 : f ≠ 0) {c : ℂ} (hc : 0 < c.im) :
+    ∀ᶠ z in 𝓝[≠] c, f (ofComplex z) ≠ 0 := by
+  rcases (analyticOnNhd_comp_ofComplex hf c hc).eventually_eq_zero_or_eventually_ne_zero with
+    h | h
+  · exact absurd (eq_zero_of_eventuallyEq_zero hf hc h) hf0
+  · exact h
+
+theorem continuousAt_ofComplex {c : ℂ} (hc : 0 < c.im) : ContinuousAt ofComplex c :=
+  (mdifferentiableAt_ofComplex hc).continuousAt
+
+theorem tendsto_ofComplex_nhdsNE (τ : ℍ) :
+    Tendsto ofComplex (𝓝[≠] (τ : ℂ)) (𝓝[≠] τ) := by
+  refine tendsto_nhdsWithin_iff.mpr ⟨?_, ?_⟩
+  · have h2 := (continuousAt_ofComplex τ.im_pos).tendsto
+    rw [ofComplex_apply] at h2
+    exact h2.mono_left nhdsWithin_le_nhds
+  · filter_upwards [self_mem_nhdsWithin,
+      mem_nhdsWithin_of_mem_nhds (isOpen_upperHalfPlaneSet.mem_nhds τ.im_pos)] with z hz hU
+    intro h
+    apply hz
+    have hU' : 0 < z.im := hU
+    have := congrArg UpperHalfPlane.coe (Set.mem_singleton_iff.mp h)
+    simpa [ofComplex_apply_of_im_pos hU'] using this
+
+theorem eq_of_eq_off_zeros {h u v : ℍ → ℂ}
+    (hh : ∀ c : ℂ, 0 < c.im → ∀ᶠ z in 𝓝[≠] c, h (ofComplex z) ≠ 0)
+    (hu : Continuous u) (hv : Continuous v) (huv : ∀ τ, h τ ≠ 0 → u τ = v τ) : u = v := by
+  funext τ
+  have hcu : ContinuousAt (u ∘ ofComplex) (τ : ℂ) :=
+    hu.continuousAt.comp_of_eq (continuousAt_ofComplex τ.im_pos) (ofComplex_apply τ)
+  have hcv : ContinuousAt (v ∘ ofComplex) (τ : ℂ) :=
+    hv.continuousAt.comp_of_eq (continuousAt_ofComplex τ.im_pos) (ofComplex_apply τ)
+  have hev : (u ∘ ofComplex) =ᶠ[𝓝[≠] (τ : ℂ)] (v ∘ ofComplex) :=
+    (hh τ τ.im_pos).mono fun z hz => huv _ hz
+  have := tendsto_nhds_unique_of_eventuallyEq (hcu.tendsto.mono_left nhdsWithin_le_nhds)
+    (hcv.tendsto.mono_left nhdsWithin_le_nhds) hev
+  simpa only [comp_apply, ofComplex_apply] using this
+
+theorem exists_mdifferentiable_mul_eq {g h : ℍ → ℂ} (hg : MDiff g) (hh : MDiff h)
+    (hh0 : ∀ c : ℂ, 0 < c.im → ∀ᶠ z in 𝓝[≠] c, h (ofComplex z) ≠ 0)
+    (hb : ∀ τ : ℍ, ∃ M : ℝ, ∀ᶠ z in 𝓝[≠] (τ : ℂ), ‖g (ofComplex z) / h (ofComplex z)‖ ≤ M) :
+    ∃ F₀ : ℍ → ℂ, MDiff F₀ ∧ ∀ τ, F₀ τ * h τ = g τ := by
+  set φ : ℂ → ℂ := fun z => g (ofComplex z) / h (ofComplex z) with hφ
+  set ψ : ℂ → ℂ := fun c => limUnder (𝓝[≠] c) φ with hψ
+  have hA : ∀ c : ℂ, ∀ hc : 0 < c.im, h (ofComplex c) ≠ 0 → DifferentiableAt ℂ φ c := by
+    intro c hc hne
+    have hg' : DifferentiableAt ℂ (g ∘ ofComplex) c := mdifferentiableAt_iff.mp (hg ⟨c, hc⟩)
+    have hh' : DifferentiableAt ℂ (h ∘ ofComplex) c := mdifferentiableAt_iff.mp (hh ⟨c, hc⟩)
+    exact hg'.div hh' hne
+  have hB : ∀ c : ℂ, 0 < c.im → h (ofComplex c) ≠ 0 → ψ c = φ c := fun c hc hne =>
+    ((hA c hc hne).continuousAt.tendsto.mono_left nhdsWithin_le_nhds).limUnder_eq
+  have hC : DifferentiableOn ℂ ψ {z : ℂ | 0 < z.im} := by
+    intro c hc
+    have hc' : 0 < c.im := hc
+    obtain ⟨M, hM⟩ := hb ⟨c, hc'⟩
+    have hev : ∀ᶠ z in 𝓝[≠] c, h (ofComplex z) ≠ 0 ∧ ‖φ z‖ ≤ M ∧ 0 < z.im :=
+      (hh0 c hc').and (hM.and (mem_nhdsWithin_of_mem_nhds
+        (isOpen_upperHalfPlaneSet.mem_nhds hc')))
+    rw [eventually_nhdsWithin_iff, Metric.eventually_nhds_iff_ball] at hev
+    obtain ⟨ε, hε, hball⟩ := hev
+    have hd : DifferentiableOn ℂ φ (Metric.ball c ε \ {c}) := fun z hz =>
+      (hA z (hball z hz.1 hz.2).2.2 (hball z hz.1 hz.2).1).differentiableWithinAt
+    have hbdd : BddAbove (norm ∘ φ '' (Metric.ball c ε \ {c})) := by
+      refine ⟨M, ?_⟩
+      rintro _ ⟨z, hz, rfl⟩
+      exact (hball z hz.1 hz.2).2.1
+    have R := Complex.differentiableOn_update_limUnder_of_bddAbove (Metric.ball_mem_nhds c hε)
+      hd hbdd
+    have heq : Set.EqOn ψ (update φ c (limUnder (𝓝[≠] c) φ)) (Metric.ball c ε) := by
+      intro z hz
+      by_cases hzc : z = c
+      · subst hzc; simp [hψ]
+      · rw [update_of_ne hzc]
+        exact hB z (hball z hz hzc).2.2 (hball z hz hzc).1
+    have hψs : DifferentiableOn ℂ ψ (Metric.ball c ε) := R.congr heq
+    exact (hψs.differentiableAt (Metric.isOpen_ball.mem_nhds (Metric.mem_ball_self hε)))
+      |>.differentiableWithinAt
+  refine ⟨fun τ => ψ τ, ?_, ?_⟩
+  · refine UpperHalfPlane.mdifferentiable_iff.mpr (hC.congr fun z hz => ?_)
+    have hz' : 0 < z.im := hz
+    simp only [comp_apply, ofComplex_apply_of_im_pos hz', UpperHalfPlane.coe_mk]
+  · have hF : MDiff (fun τ : ℍ => ψ τ) := by
+      refine UpperHalfPlane.mdifferentiable_iff.mpr (hC.congr fun z hz => ?_)
+      have hz' : 0 < z.im := hz
+      simp only [comp_apply, ofComplex_apply_of_im_pos hz', UpperHalfPlane.coe_mk]
+    have key := eq_of_eq_off_zeros (u := fun τ => ψ τ * h τ) (v := g) hh0
+      (hF.continuous.mul hh.continuous) hg.continuous (fun τ hτ => by
+        have h1 : h (ofComplex (τ : ℂ)) ≠ 0 := by rwa [ofComplex_apply]
+        have := hB τ τ.im_pos h1
+        simp only [this, hφ, ofComplex_apply]
+        exact div_mul_cancel₀ _ hτ)
+    exact fun τ => congrFun key τ
+
+end Analytic
+
+section CuspGrowth
+
+variable {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+theorem norm_qParam_lt_one' {h : ℝ} (hh : 0 < h) (τ : ℍ) : ‖Periodic.qParam h (τ : ℂ)‖ < 1 := by
+  have := (Periodic.norm_qParam_lt_iff hh 0 (τ : ℂ)).mpr (by simpa using τ.im_pos)
+  simpa using this
+
+theorem exists_qParam_pow_le {h : ℝ} (hh : 0 < h) (hΓ : h ∈ Γ.strictPeriods)
+    (f : ModularForm Γ k) (hf : f ≠ 0) :
+    ∃ (n : ℕ) (C : ℝ), 0 < C ∧ ∀ᶠ τ : ℍ in atImInfty,
+      C * ‖Periodic.qParam h (τ : ℂ)‖ ^ n ≤ ‖f τ‖ := by
+  have hper := SlashInvariantFormClass.periodic_comp_ofComplex f hΓ
+  have hΦ : AnalyticAt ℂ (cuspFunction h f) 0 :=
+    ModularFormClass.analyticAt_cuspFunction_zero f hh hΓ
+  have hne : ¬ (∀ᶠ q in 𝓝 (0 : ℂ), cuspFunction h f q = 0) := by
+    intro hev
+    apply hf
+    have : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods hh hΓ⟩
+    have hball : AnalyticOnNhd ℂ (cuspFunction h f) (Metric.ball 0 1) :=
+      (differentiableOn_cuspFunction_ball hh hper (ModularFormClass.holo f)
+        (ModularFormClass.bdd_at_infty f)).analyticOnNhd Metric.isOpen_ball
+    have hz := hball.eqOn_zero_of_preconnected_of_eventuallyEq_zero
+      (convex_ball (0 : ℂ) 1).isPreconnected (Metric.mem_ball_self one_pos) hev
+    ext τ
+    have hq : Periodic.qParam h (τ : ℂ) ∈ Metric.ball (0 : ℂ) 1 := by
+      simpa using norm_qParam_lt_one' hh τ
+    have := hz hq
+    rw [eq_cuspFunction τ hh.ne' hper] at this
+    simpa using this
+  obtain ⟨n, φ, hφ, hφ0, hev⟩ := hΦ.exists_eventuallyEq_pow_smul_nonzero_iff.mpr hne
+  refine ⟨n, ‖φ 0‖ / 2, by positivity, ?_⟩
+  have hlow : ∀ᶠ q in 𝓝 (0 : ℂ), ‖φ 0‖ / 2 < ‖φ q‖ :=
+    hφ.continuousAt.norm.eventually_const_lt (by simpa using hφ0)
+  have hq0 : Tendsto (fun τ : ℍ => Periodic.qParam h (τ : ℂ)) atImInfty (𝓝 0) :=
+    qParam_tendsto_atImInfty hh
+  filter_upwards [hq0.eventually hlow, hq0.eventually hev] with τ h1 h2
+  rw [← eq_cuspFunction τ hh.ne' hper, h2, norm_smul, norm_pow, mul_comm, sub_zero]
+  gcongr
+
+theorem exists_norm_discriminant_le :
+    ∃ C : ℝ, ∀ᶠ τ : ℍ in atImInfty,
+      ‖ModularForm.discriminant τ‖ ≤ C * ‖Periodic.qParam 1 (τ : ℂ)‖ := by
+  have h := CuspFormClass.exp_decay_atImInfty (h := 1) CuspForm.discriminant one_pos
+    (by simp)
+  obtain ⟨C, hC⟩ := h.bound
+  refine ⟨C, hC.mono fun τ hτ => ?_⟩
+  rw [Periodic.norm_qParam]
+  have : ‖Real.exp (-2 * Real.pi * τ.im / 1)‖ = Real.exp (-2 * Real.pi * (τ : ℂ).im / 1) := by
+    rw [Real.norm_eq_abs, abs_of_pos (Real.exp_pos _)]
+    rfl
+  rw [← this]
+  exact hτ
+
+theorem norm_qParam_one_le {N : ℝ} (hN : 1 ≤ N) (τ : ℍ) :
+    ‖Periodic.qParam 1 (τ : ℂ)‖ ≤ ‖Periodic.qParam N (τ : ℂ)‖ := by
+  rw [Periodic.norm_qParam, Periodic.norm_qParam, Real.exp_le_exp, div_one]
+  rw [le_div_iff₀ (by linarith)]
+  have h1 : 0 ≤ 2 * Real.pi * (τ : ℂ).im := by
+    have := τ.im_pos
+    have : (0 : ℝ) < (τ : ℂ).im := this
+    positivity
+  nlinarith
+
+end CuspGrowth
+
+theorem key_ineq {a b c d q q₁ C M D : ℝ} {n m : ℕ} (ha : 0 ≤ a) (hd : 0 ≤ d)
+    (hab : a * b = c) (hb : C * q ^ n ≤ b) (hc : c ≤ M) (hdq : d ≤ D * q₁) (hq₁ : q₁ ≤ q)
+    (hq1 : q ≤ 1) (hq0 : 0 < q) (hq₁0 : 0 ≤ q₁) (hC : 0 < C) (hD : 0 ≤ D) (hM : 0 ≤ M)
+    (hnm : n ≤ m) : a * d ^ m ≤ M * D ^ m / C := by
+  have h1 : a * d ^ m * C * q ^ n ≤ M * D ^ m * q ^ n :=
+    calc a * d ^ m * C * q ^ n = a * d ^ m * (C * q ^ n) := by ring
+      _ ≤ a * d ^ m * b := by gcongr
+      _ = c * d ^ m := by rw [← hab]; ring
+      _ ≤ M * d ^ m := by gcongr
+      _ ≤ M * (D * q₁) ^ m := by gcongr
+      _ ≤ M * (D * q) ^ m := by gcongr
+      _ = M * D ^ m * q ^ m := by ring
+      _ ≤ M * D ^ m * q ^ n :=
+        mul_le_mul_of_nonneg_left (pow_le_pow_of_le_one hq0.le hq1 hnm) (by positivity)
+  rw [le_div_iff₀ hC]
+  exact le_of_mul_le_mul_right h1 (pow_pos hq0 n)
+
+section Level
+
+variable (Γ : Subgroup SL(2, ℤ)) {k : ℤ}
+
+def restrict {F : Type*} [FunLike F ℍ ℂ] {Γ Γ' : Subgroup (GL (Fin 2) ℝ)} (hle : Γ' ≤ Γ)
+    {k : ℤ} (f : F) [ModularFormClass F Γ k] : ModularForm Γ' k where
+  toFun := f
+  slash_action_eq' γ hγ := SlashInvariantFormClass.slash_action_eq f γ (hle hγ)
+  holo' := ModularFormClass.holo f
+  bdd_at_cusps' hc := ModularFormClass.bdd_at_cusps f (hc.mono hle)
+
+def wd : ℕ := Γ.normalCore.index
+
+theorem wd_ne_zero [Γ.FiniteIndex] : wd Γ ≠ 0 :=
+  (Subgroup.FiniteIndex.index_ne_zero : Γ.normalCore.index ≠ 0)
+
+theorem wd_pos [Γ.FiniteIndex] : (0 : ℝ) < wd Γ :=
+  Nat.cast_pos.mpr (Nat.pos_of_ne_zero (wd_ne_zero Γ))
+
+theorem one_le_wd [Γ.FiniteIndex] : (1 : ℝ) ≤ wd Γ :=
+  Nat.one_le_cast.mpr (Nat.one_le_iff_ne_zero.mpr (wd_ne_zero Γ))
+
+theorem normalCore_le_conj (A : SL(2, ℤ)) :
+    ((Γ.normalCore : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) ≤
+      ConjAct.toConjAct (Matrix.SpecialLinearGroup.mapGL ℝ A)⁻¹ •
+        ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) := by
+  rintro _ ⟨y, hy, rfl⟩
+  rw [Subgroup.mem_pointwise_smul_iff_inv_smul_mem, ← ConjAct.toConjAct_inv, inv_inv,
+    ConjAct.toConjAct_smul]
+  refine ⟨A * y * A⁻¹, Γ.normalCore_le ((Subgroup.normalCore_normal Γ).conj_mem y hy A), ?_⟩
+  simp [map_mul, map_inv]
+
+def translateSL (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (A : SL(2, ℤ)) :
+    ModularForm ((Γ.normalCore : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) k :=
+  restrict (normalCore_le_conj Γ A) (ModularForm.translate f (Matrix.SpecialLinearGroup.mapGL ℝ A))
+
+@[scoped simp] theorem coe_translateSL (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (A : SL(2, ℤ)) : ⇑(translateSL Γ f A) = ⇑f ∣[k] A := rfl
+
+theorem wd_mem_strictPeriods :
+    ((wd Γ : ℕ) : ℝ) ∈ ((Γ.normalCore : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)).strictPeriods
+      := by
+  have hmem : ModularGroup.T ^ ((wd Γ : ℕ) : ℤ) ∈ Γ.normalCore := by
+    rw [zpow_natCast]
+    exact Γ.normalCore.pow_index_mem ModularGroup.T
+  simp only [Subgroup.mem_strictPeriods_iff, Subgroup.mem_map, Units.ext_iff,
+    Matrix.SpecialLinearGroup.mapGL_coe_matrix, Matrix.SpecialLinearGroup.map_apply_coe]
+  refine ⟨ModularGroup.T ^ ((wd Γ : ℕ) : ℤ), hmem, ?_⟩
+  rw [ModularGroup.coe_T_zpow]
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp [Matrix.GeneralLinearGroup.upperRightHom]
+
+theorem exists_qParam_pow_le_slash [Γ.FiniteIndex] (h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (hh : h ≠ 0) (A : SL(2, ℤ)) :
+    ∃ (n : ℕ) (C : ℝ), 0 < C ∧ ∀ᶠ τ : ℍ in atImInfty,
+      C * ‖Periodic.qParam (wd Γ) (τ : ℂ)‖ ^ n ≤ ‖(⇑h ∣[k] A) τ‖ := by
+  have hne : translateSL Γ h A ≠ 0 := by
+    intro h0
+    apply hh
+    have h1 : (⇑h ∣[k] A) = 0 := by
+      rw [← coe_translateSL Γ h A, h0]; rfl
+    rw [SlashAction.slash_eq_zero_iff] at h1
+    exact (FunLike.coe_zero_iff h).mp h1
+  exact exists_qParam_pow_le (wd_pos Γ) (wd_mem_strictPeriods Γ)
+    (translateSL Γ h A) hne
+
+open scoped Classical in
+def cuspOrder (φ : ℍ → ℂ) : ℕ :=
+  if H : ∃ (n : ℕ) (C : ℝ), 0 < C ∧ ∀ᶠ τ : ℍ in atImInfty,
+      C * ‖Periodic.qParam (wd Γ) (τ : ℂ)‖ ^ n ≤ ‖φ τ‖
+  then H.choose else 0
+
+theorem cuspOrder_spec (φ : ℍ → ℂ)
+    (H : ∃ (n : ℕ) (C : ℝ), 0 < C ∧ ∀ᶠ τ : ℍ in atImInfty,
+      C * ‖Periodic.qParam (wd Γ) (τ : ℂ)‖ ^ n ≤ ‖φ τ‖) :
+    ∃ C : ℝ, 0 < C ∧ ∀ᶠ τ : ℍ in atImInfty,
+      C * ‖Periodic.qParam (wd Γ) (τ : ℂ)‖ ^ (cuspOrder Γ φ) ≤ ‖φ τ‖ := by
+  rw [cuspOrder, dite_eq_left H]
+  exact H.choose_spec
+
+theorem exists_forall_cuspOrder_le [Γ.FiniteIndex] (h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    :
+    ∃ m : ℕ, ∀ A : SL(2, ℤ), cuspOrder Γ (⇑h ∣[k] A) ≤ m := by
+  classical
+  have : Finite (SL(2, ℤ) ⧸ Γ) := Subgroup.finite_quotient_of_finiteIndex
+  let ψ : SL(2, ℤ) ⧸ Γ → ℕ := fun q => cuspOrder Γ (⇑h ∣[k] (q.out)⁻¹)
+  obtain ⟨m, hm⟩ := (Set.finite_range ψ).bddAbove
+  refine ⟨m, fun A => ?_⟩
+  set B : SL(2, ℤ) := ((A⁻¹ : SL(2, ℤ)) : SL(2, ℤ) ⧸ Γ).out with hB
+  have hq : ((A⁻¹ : SL(2, ℤ)) : SL(2, ℤ) ⧸ Γ) = (B : _) := (QuotientGroup.out_eq' _).symm
+  rw [QuotientGroup.eq, inv_inv] at hq
+  have hslash : ⇑h ∣[k] (A * B) = ⇑h :=
+    SlashInvariantFormClass.slash_action_eq h (Matrix.SpecialLinearGroup.mapGL ℝ (A * B))
+      (Subgroup.mem_map_of_mem _ hq)
+  have key : ⇑h ∣[k] A = ⇑h ∣[k] B⁻¹ :=
+    calc ⇑h ∣[k] A = ⇑h ∣[k] ((A * B) * B⁻¹) := by rw [mul_inv_cancel_right]
+      _ = (⇑h ∣[k] (A * B)) ∣[k] B⁻¹ := SlashAction.slash_mul _ _ _ _
+      _ = ⇑h ∣[k] B⁻¹ := by rw [hslash]
+  rw [key]
+  exact hm ⟨_, rfl⟩
+
+theorem isBoundedAtImInfty_of_mul_eq [Γ.FiniteIndex]
+    (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (hh : h ≠ 0) (F₀ : ℍ → ℂ) (hF : ∀ τ, F₀ τ * h τ = g τ) (A : SL(2, ℤ)) {m : ℕ}
+    (hm : cuspOrder Γ (⇑h ∣[k] A) ≤ m) :
+    IsBoundedAtImInfty (fun τ : ℍ => F₀ (A • τ) * (ModularForm.discriminant τ) ^ m) := by
+  obtain ⟨C, hC, hlow⟩ := cuspOrder_spec Γ _ (exists_qParam_pow_le_slash Γ h hh A)
+  have hgA : IsBoundedAtImInfty (⇑g ∣[k] A) := ModularFormClass.bdd_at_infty (translateSL Γ g A)
+  obtain ⟨D, hD⟩ := exists_norm_discriminant_le
+  rw [IsBoundedAtImInfty, BoundedAtFilter] at hgA ⊢
+  obtain ⟨M', hM'⟩ := hgA.bound
+  refine Asymptotics.IsBigO.of_bound (max M' 0 * max D 0 ^ m / C) ?_
+  filter_upwards [hlow, hM', hD] with τ h1 h2 h3
+  simp only [Pi.one_apply, norm_one, mul_one] at h2 ⊢
+  have hq0 : 0 < ‖Periodic.qParam (wd Γ) (τ : ℂ)‖ := by
+    rw [Periodic.norm_qParam]; exact Real.exp_pos _
+  have hq1 : ‖Periodic.qParam (wd Γ) (τ : ℂ)‖ ≤ 1 := (norm_qParam_lt_one' (wd_pos Γ) τ).le
+  have hq₁ : ‖Periodic.qParam 1 (τ : ℂ)‖ ≤ ‖Periodic.qParam (wd Γ) (τ : ℂ)‖ :=
+    norm_qParam_one_le (one_le_wd Γ) τ
+  have hab : ‖F₀ (A • τ)‖ * ‖(⇑h ∣[k] A) τ‖ = ‖(⇑g ∣[k] A) τ‖ := by
+    rw [← norm_mul, ModularForm.SL_slash_apply, ModularForm.SL_slash_apply, ← mul_assoc, hF]
+  rw [norm_mul, norm_pow]
+  exact key_ineq (norm_nonneg _) (norm_nonneg _) hab h1 (h2.trans (le_max_left _ _))
+    (h3.trans (mul_le_mul_of_nonneg_right (le_max_left _ _) (norm_nonneg _))) hq₁ hq1 hq0
+    (norm_nonneg _) hC (le_max_right _ _) (le_max_right _ _) hm
+
+end Level
+
+section Assembly
+
+variable (Γ : Subgroup SL(2, ℤ)) (hT : ModularGroup.T ∈ Γ)
+
+scoped instance isArithmetic_map [Γ.FiniteIndex] :
+    ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)).IsArithmetic := inferInstance
+
+abbrev qL (f : ℍ → ℂ) : LaurentSeries ℂ := ((qExpansion 1 f : PowerSeries ℂ) : LaurentSeries ℂ)
+
+include hT in
+theorem one_mem_strictPeriods :
+    (1 : ℝ) ∈ ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  rw [Subgroup.mem_strictPeriods_iff]
+  refine ⟨ModularGroup.T, hT, ?_⟩
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp [ModularGroup.T, Matrix.GeneralLinearGroup.upperRightHom]
+
+theorem le_SL : ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) ≤ 𝒮ℒ :=
+  Subgroup.map_le_range _ _
+
+def Δ₀ : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12 :=
+  restrict (le_SL Γ) CuspForm.discriminant
+
+@[scoped simp] theorem coe_Δ₀ :
+    ((Δ₀ Γ : ModularForm _ 12) : ℍ → ℂ) = ModularForm.discriminant := rfl
+
+def Δ₁ : ModularForm 𝒮ℒ 12 := restrict le_rfl CuspForm.discriminant
+
+@[scoped simp] theorem coe_Δ₁ : ((Δ₁ : ModularForm _ 12) : ℍ → ℂ) = ModularForm.discriminant := rfl
+
+theorem coe_ne_zero {k : ℤ} (h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hh : h ≠ 0) :
+    (h : ℍ → ℂ) ≠ 0 := fun e => hh ((FunLike.coe_zero_iff h).mp e)
+
+theorem eventually_ne_zero_coe {k : ℤ} (h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (hh : h ≠ 0) (c : ℂ) (hc : 0 < c.im) : ∀ᶠ z in 𝓝[≠] c, h (ofComplex z) ≠ 0 :=
+  eventually_ne_zero h.holo' (coe_ne_zero Γ h hh) hc
+
+theorem exists_F₀ {k : ℤ} (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hh : h ≠ 0)
+    (hb : ∀ τ : ℍ, IsBoundedUnder (· ≤ ·) (𝓝[≠] τ) (fun z : ℍ => ‖g z / h z‖)) :
+    ∃ F₀ : ℍ → ℂ, MDiff F₀ ∧ ∀ τ, F₀ τ * h τ = g τ := by
+  refine exists_mdifferentiable_mul_eq g.holo' h.holo' (eventually_ne_zero_coe Γ h hh)
+    (fun τ => ?_)
+  obtain ⟨M', hM'⟩ := hb τ
+  refine ⟨M', ?_⟩
+  have h1 : ∀ᶠ z : ℍ in 𝓝[≠] τ, ‖g z / h z‖ ≤ M' := hM'
+  exact (tendsto_ofComplex_nhdsNE τ).eventually h1
+
+theorem slash_zero_eq {k : ℤ} (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hh : h ≠ 0)
+    (F₀ : ℍ → ℂ) (hF₀ : MDiff F₀) (hF : ∀ τ, F₀ τ * h τ = g τ) (γ : SL(2, ℤ))
+    (hγ : γ ∈ Γ) : F₀ ∣[(0 : ℤ)] γ = F₀ := by
+  refine eq_of_eq_off_zeros (eventually_ne_zero_coe Γ h hh)
+    (hF₀.slash 0 (γ : GL (Fin 2) ℝ)).continuous hF₀.continuous (fun τ hτ => ?_)
+  rw [ModularForm.SL_slash_apply, neg_zero, zpow_zero, mul_one]
+  have eh : h (γ • τ) = denom γ τ ^ k * h τ := SlashInvariantForm.slash_action_eqn_SL'' h hγ τ
+  have eg : g (γ • τ) = denom γ τ ^ k * g τ := SlashInvariantForm.slash_action_eqn_SL'' g hγ τ
+  have hd : (denom γ τ) ^ k ≠ 0 := zpow_ne_zero _ (denom_ne_zero _ _)
+  have e1 := hF (γ • τ)
+  have e2 := hF τ
+  rw [eh, eg] at e1
+  have : F₀ (γ • τ) * (denom γ τ ^ k * h τ) = F₀ τ * (denom γ τ ^ k * h τ) := by
+    rw [e1, ← e2]; ring
+  exact mul_right_cancel₀ (mul_ne_zero hd hτ) this
+
+def liftForm [Γ.FiniteIndex] {k : ℤ} (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (hh : h ≠ 0)
+    (F₀ : ℍ → ℂ) (hF₀ : MDiff F₀) (hF : ∀ τ, F₀ τ * h τ = g τ) (m : ℕ)
+    (hm : ∀ A : SL(2, ℤ), cuspOrder Γ (⇑h ∣[k] A) ≤ m) :
+    ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) ((m : ℤ) * 12) where
+  toFun := F₀ * ⇑(Δ₁.pow m)
+  slash_action_eq' γ hγ := by
+    obtain ⟨γ, hγ', rfl⟩ := hγ
+    have hΔ : (⇑(Δ₁.pow m)) ∣[((m : ℤ) * 12)] γ = ⇑(Δ₁.pow m) :=
+      SlashInvariantFormClass.slash_action_eq (Δ₁.pow m)
+        (Matrix.SpecialLinearGroup.mapGL ℝ γ) ⟨γ, rfl⟩
+    have e := ModularForm.mul_slash_SL2 0 ((m : ℤ) * 12) γ F₀ ⇑(Δ₁.pow m)
+    rw [zero_add] at e
+    change (F₀ * ⇑(Δ₁.pow m)) ∣[((m : ℤ) * 12)] γ = F₀ * ⇑(Δ₁.pow m)
+    rw [e, slash_zero_eq Γ g h hh F₀ hF₀ hF γ hγ', hΔ]
+  holo' := hF₀.mul (Δ₁.pow m).holo'
+  bdd_at_cusps' {c} hc := by
+    rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z] at hc
+    rw [OnePoint.isBoundedAt_iff_forall_SL2Z hc]
+    intro A _
+    have hΔ : (⇑(Δ₁.pow m)) ∣[((m : ℤ) * 12)] A = ⇑(Δ₁.pow m) :=
+      SlashInvariantFormClass.slash_action_eq (Δ₁.pow m)
+        (Matrix.SpecialLinearGroup.mapGL ℝ A) ⟨A, rfl⟩
+    have e := ModularForm.mul_slash_SL2 0 ((m : ℤ) * 12) A F₀ ⇑(Δ₁.pow m)
+    rw [zero_add] at e
+    change IsBoundedAtImInfty ((F₀ * ⇑(Δ₁.pow m)) ∣[((m : ℤ) * 12)] A)
+    rw [e, hΔ]
+    have : (F₀ ∣[(0 : ℤ)] A * ⇑(Δ₁.pow m)) =
+        fun τ => F₀ (A • τ) * ModularForm.discriminant τ ^ m := by
+      funext τ
+      simp [ModularForm.SL_slash_apply]
+    rw [this]
+    exact isBoundedAtImInfty_of_mul_eq Γ g h hh F₀ hF A (hm A)
+
+theorem coe_liftForm' [Γ.FiniteIndex] {k : ℤ} (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (hh : h ≠ 0)
+    (F₀ : ℍ → ℂ) (hF₀ : MDiff F₀) (hF : ∀ τ, F₀ τ * h τ = g τ) (m : ℕ)
+    (hm : ∀ A : SL(2, ℤ), cuspOrder Γ (⇑h ∣[k] A) ≤ m) :
+    ⇑(liftForm Γ g h hh F₀ hF₀ hF m hm) = F₀ * ⇑(Δ₁.pow m) := rfl
+
+theorem coe_liftForm [Γ.FiniteIndex] {k : ℤ} (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (hh : h ≠ 0)
+    (F₀ : ℍ → ℂ) (hF₀ : MDiff F₀) (hF : ∀ τ, F₀ τ * h τ = g τ) (m : ℕ)
+    (hm : ∀ A : SL(2, ℤ), cuspOrder Γ (⇑h ∣[k] A) ≤ m) :
+    (⇑(liftForm Γ g h hh F₀ hF₀ hF m hm)) * ⇑h = ⇑g * ⇑((Δ₀ Γ).pow m) := by
+  rw [coe_liftForm']
+  funext τ
+  simp only [Pi.mul_apply, ModularForm.coe_pow, Pi.pow_apply, coe_Δ₀, coe_Δ₁]
+  rw [mul_right_comm, hF]
+
+include hT in
+theorem qL_liftForm_mul [Γ.FiniteIndex] {k : ℤ} (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (hh : h ≠ 0)
+    (F₀ : ℍ → ℂ) (hF₀ : MDiff F₀) (hF : ∀ τ, F₀ τ * h τ = g τ) (m : ℕ)
+    (hm : ∀ A : SL(2, ℤ), cuspOrder Γ (⇑h ∣[k] A) ≤ m) :
+    qL ⇑(liftForm Γ g h hh F₀ hF₀ hF m hm) * qL ⇑h =
+      qL ⇑g * qL (ModularForm.discriminant) ^ m := by
+  have h1 := ModularForm.qExpansion_mul_coe one_pos (one_mem_strictPeriods Γ hT)
+    (liftForm Γ g h hh F₀ hF₀ hF m hm) h
+  have h2 := ModularForm.qExpansion_mul_coe one_pos (one_mem_strictPeriods Γ hT)
+    g ((Δ₀ Γ).pow m)
+  have h3 := ModularForm.qExpansion_pow one_pos (one_mem_strictPeriods Γ hT) (Δ₀ Γ) m
+  rw [coe_liftForm] at h1
+  simp only [qL, ← PowerSeries.coe_mul, ← PowerSeries.coe_pow, ← h1, h2, h3, coe_Δ₀]
+
+include hT in
+theorem qL_ne_zero {k : ℤ} (h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hh : h ≠ 0) :
+    qL ⇑h ≠ 0 := by
+  intro e
+  apply hh
+  rw [← ModularForm.qExpansion_eq_zero_iff one_pos (one_mem_strictPeriods Γ hT)]
+  apply (HahnSeries.ofPowerSeries_injective (Γ := ℤ) (R := ℂ))
+  simpa [qL] using e
+
+theorem T_mem_SL : ModularGroup.T ∈ (⊤ : Subgroup SL(2, ℤ)) := Subgroup.mem_top _
+
+theorem Δ₀_ne_zero : Δ₀ (⊤ : Subgroup SL(2, ℤ)) ≠ 0 := by
+  intro e
+  have := congrArg (fun f : ModularForm ((⊤ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) 12 =>
+    (f : ℍ → ℂ) I) e
+  exact ModularForm.discriminant_ne_zero I (by simpa using this)
+
+theorem qL_discriminant_ne_zero : qL ModularForm.discriminant ≠ 0 := by
+  rw [← coe_Δ₀ (⊤ : Subgroup SL(2, ℤ))]
+  exact qL_ne_zero (⊤ : Subgroup SL(2, ℤ)) T_mem_SL (Δ₀ ⊤) Δ₀_ne_zero
+
+include hT in
+theorem isIntegral_of_forall_isBoundedUnder [Γ.FiniteIndex] {k : ℤ}
+    (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hh : h ≠ 0)
+    (hb : ∀ τ : ℍ, IsBoundedUnder (· ≤ ·) (𝓝[≠] τ) (fun z : ℍ => ‖g z / h z‖)) :
+    IsIntegral (Algebra.adjoin ℂ ({jqModC ℂ} : Set (LaurentSeries ℂ))) (qL ⇑g / qL ⇑h) := by
+  obtain ⟨F₀, hF₀, hF⟩ := exists_F₀ Γ g h hh hb
+  obtain ⟨m, hm⟩ := exists_forall_cuspOrder_le Γ h
+  set F := liftForm Γ g h hh F₀ hF₀ hF m hm with hFdef
+  have hq : qL ⇑F * qL ⇑h = qL ⇑g * qL ModularForm.discriminant ^ m :=
+    qL_liftForm_mul Γ hT g h hh F₀ hF₀ hF m hm
+  have hxF : qL ⇑F / qL ModularForm.discriminant ^ m = qL ⇑g / qL ⇑h := by
+    rw [div_eq_div_iff (pow_ne_zero _ qL_discriminant_ne_zero) (qL_ne_zero Γ hT h hh)]
+    rw [hq]
+  have key := ModularForm.isIntegral_adjoin_qExpansion_div_discriminant_pow_of_isArithmetic
+    (one_mem_strictPeriods Γ hT) m (k := (m : ℤ) * 12) (by ring) F
+  rw [← jqModC_eq_qExpansion_E4_cube_div_discriminant] at key
+  rw [← hxF]
+  exact key
+
+end Assembly
+
+end ModularCurve.Ws49.IntFI
+
+open scoped Topology in
+theorem solution
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ) {k : ℤ}
+    (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hh : h ≠ 0)
+    (hb : ∀ τ : UpperHalfPlane, Filter.IsBoundedUnder (· ≤ ·) (𝓝[≠] τ)
+      (fun z : UpperHalfPlane => ‖g z / h z‖)) :
+    IsIntegral (Algebra.adjoin ℂ ({ModularCurve.jqModC ℂ} : Set (LaurentSeries ℂ)))
+      (HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 ⇑g) /
+        HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 ⇑h)) :=
+  ModularCurve.Ws49.IntFI.isIntegral_of_forall_isBoundedUnder Γ hT g h hh hb
+
+end
+end S_OVERLONG_5b0eac03
+end P2MW
+export
+  P2MW.S_OVERLONG_5b0eac03
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups Topology
+theorem ModularCurve.isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder_of_finiteIndex
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ) {k : ℤ}
+    (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hh : h ≠ 0)
+    (hb : ∀ τ : UpperHalfPlane, Filter.IsBoundedUnder (· ≤ ·) (𝓝[≠] τ)
+      (fun z : UpperHalfPlane => ‖g z / h z‖)) :
+    IsIntegral (Algebra.adjoin ℂ ({ModularCurve.jqModC ℂ} : Set (LaurentSeries ℂ)))
+      (HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 ⇑g) /
+        HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 ⇑h)) :=
+  solution Γ hT g h hh hb
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_adjoin_jq_modularUnitSeries.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_adjoin_jq_modularUnitSeries.lean
new file mode 100644
index 0000000000..bf32f3d86a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_adjoin_jq_modularUnitSeries.lean
@@ -0,0 +1,96 @@
+/-
+Based on Prove2Me node ModularCurve.isIntegral_adjoin_jq_modularUnitSeries
+(b1bdf829-d1bb-5bb1-9a0a-29db5f98a3e4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2f81c8b9-01d9-5257-b99b-0956ff264f65
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ModularUnit
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+import Mathlib.NumberTheory.ModularForms.Discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_modularUnitSeries_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_smul_modularUnitSeries_inv_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_modularUnitSeries_inv_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_smul_modularUnitSeries_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_discriminant_div_discriminant_heckeDiagMatrix_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_adjoin_jq_of_hasSum_of_gamma0_invariant
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality of Δ(q)/Δ(q^ℓ) over ℚ[j]
+
+Theorem statement: `ModularCurve.isIntegral_adjoin_jq_modularUnitSeries`
+(`b1bdf829-d1bb-5bb1-9a0a-29db5f98a3e4`), by Claude, 2026-09-05.
+
+Proof: submission `2f81c8b9-01d9-5257-b99b-0956ff264f65`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a prime. Consider the field of formal Laurent series $\mathbb{Q}((q))$ (Lean
+`LaurentSeries ℚ`) and in it the two elements built as follows:
+[`ModularCurve.jq`](def/ModularCurve_X0.html#L157) is $q^{-1}$ times the power series `jNumQ`, the
+image under $\mathbb{Z}\to\mathbb{Q}$ of the integral power series `jNum`, so that `jq` is the
+$q$-expansion of the modular invariant $j$; and [`ModularCurve.modularUnitSeries
+ℓ`](def/ModularCurve_ModularUnit.html#L127) is the product of
+[`ModularCurve.deltaSeries`](def/ModularCurve_ModularUnit.html#L107), namely $q$ times the rational
+power series `dedekindEtaUnitQ`, with the inverse of [`ModularCurve.deltaSeriesN
+ℓ`](def/ModularCurve_ModularUnit.html#L119), the series obtained from
+[`ModularCurve.deltaSeries`](def/ModularCurve_ModularUnit.html#L107) by the substitution $q \mapsto
+q^{\ell}$ (Lean `qExpand ℚ ℓ`). Thus [`ModularCurve.modularUnitSeries
+ℓ`](def/ModularCurve_ModularUnit.html#L127) is the formal Laurent expansion of
+$\Delta(q)/\Delta(q^{\ell})$. The assertion is that this element is integral over the
+$\mathbb{Q}$-subalgebra $\mathbb{Q}[\,$`jq`$\,]$ of $\mathbb{Q}((q))$ generated by `jq`, that is, it
+is a root of a monic polynomial all of whose coefficients are polynomials in `jq` with rational
+coefficients.
+
+This is the integrality over $\mathbb{Q}[j]$ of Ogg's modular unit $u_\ell =
+\Delta(q)/\Delta(q^{\ell})$ on $X_0(\ell)$, the formal-series form of the statement that $u_\ell$ is
+a modular function for $\Gamma_0(\ell)$ holomorphic away from the cusps. It is used, together with
+the corresponding statement for $u_\ell^{-1}$, in the analysis of places of the function field of
+$X_0(\ell)$ and of specialisations at which $j$ is integral, where it forces $u_\ell$ to have order
+zero at every such place.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_isIntegral_adjoin_jq_modularUnitSeries.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_isIntegral_adjoin_jq_modularUnitSeries
+
+theorem solution (ℓ : ℕ) [Fact (Nat.Prime ℓ)] :
+    IsIntegral (Algebra.adjoin ℚ {ModularCurve.jq}) (ModularCurve.modularUnitSeries ℓ) := by
+  have : NeZero ℓ := ⟨(Fact.out : Nat.Prime ℓ).ne_zero⟩
+  exact ModularCurve.isIntegral_adjoin_jq_of_hasSum_of_gamma0_invariant ℓ
+    (ModularCurve.modularUnitSeries ℓ) ((ℓ : ℚ) ^ 12 • (ModularCurve.modularUnitSeries ℓ)⁻¹)
+    (fun τ => ModularForm.discriminant τ
+      / ModularForm.discriminant (ModularForm.heckeDiagMatrix ℓ • τ))
+    (fun τ => ModularCurve.hasSum_modularUnitSeries_qParam ℓ τ)
+    (fun τ => ModularCurve.hasSum_smul_modularUnitSeries_inv_qParam ℓ τ)
+    (fun γ hγ τ => ModularCurve.discriminant_div_discriminant_heckeDiagMatrix_smul ℓ γ hγ τ)
+
+end S_ModularCurve_isIntegral_adjoin_jq_modularUnitSeries
+end P2MW
+export P2MW.S_ModularCurve_isIntegral_adjoin_jq_modularUnitSeries (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.isIntegral_adjoin_jq_modularUnitSeries (ℓ : ℕ) [Fact (Nat.Prime ℓ)] :
+    IsIntegral (Algebra.adjoin ℚ {ModularCurve.jq}) (ModularCurve.modularUnitSeries ℓ) :=
+  solution ℓ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_adjoin_jq_modularUnitSeries_inv.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_adjoin_jq_modularUnitSeries_inv.lean
new file mode 100644
index 0000000000..c9d76cd8b4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_adjoin_jq_modularUnitSeries_inv.lean
@@ -0,0 +1,100 @@
+/-
+Based on Prove2Me node ModularCurve.isIntegral_adjoin_jq_modularUnitSeries_inv
+(f06f09ba-0b27-5658-b52c-fcdb8532c705) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8be42c8c-2ed8-5aa0-8c48-fe811d363c2b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ModularUnit
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+import Mathlib.NumberTheory.ModularForms.Discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_modularUnitSeries_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_smul_modularUnitSeries_inv_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_modularUnitSeries_inv_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_smul_modularUnitSeries_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_discriminant_div_discriminant_heckeDiagMatrix_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_adjoin_jq_of_hasSum_of_gamma0_invariant
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Inverse of Ogg's modular unit is integral over ℚ[j]
+
+Theorem statement: `ModularCurve.isIntegral_adjoin_jq_modularUnitSeries_inv`
+(`f06f09ba-0b27-5658-b52c-fcdb8532c705`), by Claude, 2026-09-05.
+
+Proof: submission `8be42c8c-2ed8-5aa0-8c48-fe811d363c2b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a prime. Inside the field $\mathbb{Q}((q))$ of rational Laurent series (Hahn series
+over $\mathbb{Q}$ with value group $\mathbb{Z}$), consider the element
+[`ModularCurve.modularUnitSeries`](def/ModularCurve_ModularUnit.html#L127) $\ell$, defined as the
+product of [`ModularCurve.deltaSeries`](def/ModularCurve_ModularUnit.html#L107) $= q \cdot
+\mathrm{dedekindEtaUnitQ}(q)$, the discriminant $q$-expansion, with the inverse of
+[`ModularCurve.deltaSeriesN`](def/ModularCurve_ModularUnit.html#L119) $\ell$, the series obtained
+from [`ModularCurve.deltaSeries`](def/ModularCurve_ModularUnit.html#L107) by the substitution $q
+\mapsto q^{\ell}$; thus it is the formal series $\Delta(q)/\Delta(q^{\ell})$. Consider further the
+$\mathbb{Q}$-subalgebra $\mathbb{Q}[j]$ of $\mathbb{Q}((q))$ generated by the single element
+[`ModularCurve.jq`](def/ModularCurve_X0.html#L157) $= q^{-1}\cdot \mathrm{jNumQ}(q)$, the
+$q$-expansion of the modular invariant (the integral power series $\mathrm{jNum}$ pushed to
+$\mathbb{Q}$). The assertion is that the multiplicative inverse $(\mathrm{modularUnitSeries}\
+\ell)^{-1} = \Delta(q^{\ell})/\Delta(q)$, taken in $\mathbb{Q}((q))$, is integral over this
+subalgebra: it is a root of some monic polynomial with coefficients in $\mathbb{Q}[\mathrm{jq}]$. No
+hypothesis beyond the primality of $\ell$ is imposed.
+
+This is the integrality, over the ring generated by the $j$-expansion, of the inverse of Ogg's
+modular unit on $X_0(\ell)$, the companion of the corresponding statement for the unit itself;
+combined, the two say that the unit has divisor supported on the cusps. It is used in the analysis
+of places of the function field of $X_0(\ell)$, where the order of the unit and of its Fricke
+transform at a place is compared with the order of $j$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_isIntegral_adjoin_jq_modularUnitSeries_inv.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_isIntegral_adjoin_jq_modularUnitSeries_inv
+
+theorem solution (ℓ : ℕ) [Fact (Nat.Prime ℓ)] :
+    IsIntegral (Algebra.adjoin ℚ {ModularCurve.jq}) (ModularCurve.modularUnitSeries ℓ)⁻¹ := by
+  have : NeZero ℓ := ⟨(Fact.out : Nat.Prime ℓ).ne_zero⟩
+  refine ModularCurve.isIntegral_adjoin_jq_of_hasSum_of_gamma0_invariant ℓ
+    (ModularCurve.modularUnitSeries ℓ)⁻¹ (((ℓ : ℚ) ^ 12)⁻¹ • ModularCurve.modularUnitSeries ℓ)
+    (fun τ => ModularForm.discriminant (ModularForm.heckeDiagMatrix ℓ • τ)
+      / ModularForm.discriminant τ)
+    (fun τ => ModularCurve.hasSum_modularUnitSeries_inv_qParam ℓ τ)
+    (fun τ => ModularCurve.hasSum_smul_modularUnitSeries_qParam ℓ τ)
+    (fun γ hγ τ => ?_)
+  show ModularForm.discriminant (ModularForm.heckeDiagMatrix ℓ • γ • τ)
+      / ModularForm.discriminant (γ • τ)
+    = ModularForm.discriminant (ModularForm.heckeDiagMatrix ℓ • τ) / ModularForm.discriminant τ
+  have h := congrArg Inv.inv
+    (ModularCurve.discriminant_div_discriminant_heckeDiagMatrix_smul ℓ γ hγ τ)
+  rwa [inv_div, inv_div] at h
+
+end S_ModularCurve_isIntegral_adjoin_jq_modularUnitSeries_inv
+end P2MW
+export P2MW.S_ModularCurve_isIntegral_adjoin_jq_modularUnitSeries_inv (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.isIntegral_adjoin_jq_modularUnitSeries_inv (ℓ : ℕ) [Fact (Nat.Prime ℓ)] :
+    IsIntegral (Algebra.adjoin ℚ {ModularCurve.jq}) (ModularCurve.modularUnitSeries ℓ)⁻¹ :=
+  solution ℓ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_adjoin_jq_of_hasSum_of_gamma0_invariant.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_adjoin_jq_of_hasSum_of_gamma0_invariant.lean
new file mode 100644
index 0000000000..e46f769345
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_adjoin_jq_of_hasSum_of_gamma0_invariant.lean
@@ -0,0 +1,982 @@
+/-
+Based on Prove2Me node ModularCurve.isIntegral_adjoin_jq_of_hasSum_of_gamma0_invariant
+(76cce1be-41db-50c0-ba9c-e56fef8597bb) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ad5d288c-5260-57bd-b1bc-e4e7197deb98
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Exp
+public import Mathlib.Analysis.Complex.UpperHalfPlane.MoebiusAction
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.NumberTheory.Cyclotomic.PrimitiveRoots
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import Mathlib.FieldTheory.Galois.Basic
+import Mathlib.GroupTheory.Perm.Fin
+import Mathlib.NumberTheory.ModularForms.EisensteinSeries.Basic
+import Mathlib.NumberTheory.ModularForms.Discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_exists_galoisPerm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_mem_range_coeffEmb_of_forall_coeffMap_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_mem_range_coeffEmb_qExpand_of_mem_inter
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_conj_injective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_mem_range_qExpand_of_qTwist_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_jq_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_E4_cube_div_discriminant_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_mul_laurent
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_heckeMatrix_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_heckeDiagMatrix_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_mem_adjoin_jq_of_hasSum_of_slash_invariant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_perm_gamma0_cosetReps
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_sl2_heckeDiagMatrix_smul_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality over ℚ[j] of a Γ₀(ℓ)-invariant q-expansion
+
+Theorem statement: `ModularCurve.isIntegral_adjoin_jq_of_hasSum_of_gamma0_invariant`
+(`76cce1be-41db-50c0-ba9c-e56fef8597bb`), by Claude, 2026-09-05.
+
+Proof: submission `ad5d288c-5260-57bd-b1bc-e4e7197deb98`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a prime, let $f,g$ be formal Laurent series over $\mathbb Q$ (elements of
+`LaurentSeries ℚ`), and let $F\colon\mathfrak H\to\mathbb C$ be a function on the upper half-plane.
+Assume: (hF) for every $\tau\in\mathfrak H$ the family $m\mapsto f_m\,q_1(\tau)^m$, indexed by
+$m\in\mathbb Z$, where $f_m\in\mathbb Q\subseteq\mathbb C$ is the $m$-th coefficient of $f$ and
+$q_h(\tau)=$ `Function.Periodic.qParam h τ` $=e^{2\pi i\tau/h}$, is summable with sum $F(\tau)$;
+(hG) for every $\tau\in\mathfrak H$ the family $m\mapsto g_m\,q_\ell(\tau)^m$ is summable with sum
+$F(S\tau)$, where $S\in\mathrm{SL}_2(\mathbb Z)$ is `ModularGroup.S` acting by Möbius
+transformation; and (hinv) $F(\gamma\tau)=F(\tau)$ for every $\gamma$ in `CongruenceSubgroup.Gamma0
+ℓ` and every $\tau\in\mathfrak H$. The conclusion is that $f$ is integral, in the sense of
+`IsIntegral`, over the $\mathbb Q$-subalgebra `Algebra.adjoin ℚ {ModularCurve.jq}` of $\mathbb
+Q((q))$ generated by [`ModularCurve.jq`](def/ModularCurve_X0.html#L157), the Laurent series
+$q^{-1}\cdot\jmath$ with $\jmath$ the image in $\mathbb Q[[q]]$ of the integral power series `jNum`;
+that is, $f$ satisfies a monic polynomial equation with coefficients polynomial in the $q$-expansion
+of $j$.
+
+This is the integrality half of the $q$-expansion principle for $X_0(\ell)$: a Laurent series that
+is the $q$-expansion at $\infty$ of a $\Gamma_0(\ell)$-invariant function, with a meromorphic
+expansion of width $\ell$ at the cusp $0$, is integral over $\mathbb Q[j]$. It is used to place the
+$q$-expansions of modular units, and their inverses, in the function field of $X_0(\ell)$ over
+$\mathbb Q$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_isIntegral_adjoin_jq_of_hasSum_of_gamma0_invariant.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_isIntegral_adjoin_jq_of_hasSum_of_gamma0_invariant
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology Function Polynomial
+open scoped MatrixGroups
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_qExpand jq jqN modularFunctionField jq_mem jqN_mem qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand PhiGen.conj PhiGen.conj_zero PhiGen.conj_succ coeffMap \
+  coeffMap_coeff coeffEmb coeffEmb_coeff coeffMap_coeffEmb coeffMap_qExpand coeffEmb_qExpand \
+  PhiGen.exists_galoisPerm PhiGen.mem_range_coeffEmb_of_forall_coeffMap_eq \
+  PhiGen.mem_range_coeffEmb_qExpand_of_mem_inter PhiGen.conj_injective \
+  mem_range_qExpand_of_qTwist_eq hasSum_jq_qParam E4_cube_div_discriminant_smul \
+  hasSum_qParam_mul_laurent hasSum_qParam_heckeMatrix_smul hasSum_qParam_heckeDiagMatrix_smul \
+  mem_adjoin_jq_of_hasSum_of_slash_invariant exists_perm_gamma0_cosetReps \
+  exists_sl2_heckeDiagMatrix_smul_eq"
+p2m_open "ModularCurve"
+
+namespace QExpN
+
+section Generic
+
+variable {L L' : Type*} [CommRing L] [CommRing L'] {n : ℕ}
+
+def interpPoly (H Y : Fin n → L) : L[X] :=
+  ∑ i, C (H i) * ∏ m ∈ Finset.univ.erase i, (X - C (Y m))
+
+def conjPoly (H : Fin n → L) : L[X] := ∏ i, (X - C (H i))
+
+omit [CommRing L'] in
+lemma prod_erase_perm (e : Equiv.Perm (Fin n)) (G : Fin n → L[X]) (i : Fin n) :
+    ∏ m ∈ Finset.univ.erase i, G (e m) = ∏ m ∈ Finset.univ.erase (e i), G m := by
+  refine Finset.prod_equiv e (fun m => ?_) (fun m _ => rfl)
+  simp [e.injective.eq_iff]
+
+lemma interpPoly_map (φ : L →+* L') (H Y : Fin n → L) :
+    (interpPoly H Y).map φ = interpPoly (φ ∘ H) (φ ∘ Y) := by
+  simp only [interpPoly, Polynomial.map_sum, Polynomial.map_mul, Polynomial.map_C,
+    Polynomial.map_prod,
+    Polynomial.map_sub, Polynomial.map_X, Function.comp_apply]
+
+lemma conjPoly_map (φ : L →+* L') (H : Fin n → L) : (conjPoly H).map φ = conjPoly (φ ∘ H) := by
+  simp only [conjPoly, Polynomial.map_prod, Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C,
+    Function.comp_apply]
+
+omit [CommRing L'] in
+lemma interpPoly_perm (e : Equiv.Perm (Fin n)) (H Y : Fin n → L) :
+    interpPoly (H ∘ e) (Y ∘ e) = interpPoly H Y := by
+  unfold interpPoly
+  simp only [Function.comp_apply]
+  rw [← Equiv.sum_comp e (fun j => C (H j) * ∏ m ∈ Finset.univ.erase j, (X - C (Y m)))]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [prod_erase_perm e (fun m => X - C (Y m)) i]
+
+omit [CommRing L'] in
+lemma conjPoly_perm (e : Equiv.Perm (Fin n)) (H : Fin n → L) : conjPoly (H ∘ e) = conjPoly H := by
+  unfold conjPoly
+  simp only [Function.comp_apply]
+  exact Equiv.prod_comp e (fun j => X - C (H j))
+
+omit [CommRing L'] in
+lemma interpPoly_eval (H Y : Fin n → L) (i₀ : Fin n) :
+    (interpPoly H Y).eval (Y i₀) = H i₀ * ∏ m ∈ Finset.univ.erase i₀, (Y i₀ - Y m) := by
+  unfold interpPoly
+  rw [Polynomial.eval_finsetSum, Finset.sum_eq_single i₀]
+  · simp [Polynomial.eval_prod]
+  · intro i _ hi
+    rw [Polynomial.eval_mul, Polynomial.eval_prod]
+    refine mul_eq_zero_of_right _ (Finset.prod_eq_zero (i := i₀) (by simp [Ne.symm hi]) ?_)
+    simp
+  · intro h; exact absurd (Finset.mem_univ i₀) h
+
+omit [CommRing L'] in
+lemma conjPoly_eval (H : Fin n → L) (i₀ : Fin n) : (conjPoly H).eval (H i₀) = 0 := by
+  unfold conjPoly
+  rw [Polynomial.eval_prod]
+  exact Finset.prod_eq_zero (Finset.mem_univ i₀) (by simp)
+
+omit [CommRing L'] in
+lemma conjPoly_monic [Nontrivial L] (H : Fin n → L) : (conjPoly H).Monic :=
+  Polynomial.monic_prod_of_monic _ _ fun i _ => Polynomial.monic_X_sub_C (H i)
+
+omit [CommRing L'] in
+lemma conjPoly_natDegree [Nontrivial L] [NoZeroDivisors L] (H : Fin n → L) :
+    (conjPoly H).natDegree = n := by
+  unfold conjPoly
+  rw [Polynomial.natDegree_prod _ _ fun i _ => Polynomial.X_sub_C_ne_zero (H i)]
+  simp
+
+lemma eval_eq_sum_coeff {p : L[X]} {N : ℕ} (hN : p.natDegree < N) (x : L) :
+    p.eval x = ∑ k ∈ Finset.range N, p.coeff k * x ^ k := by
+  rw [Polynomial.eval_eq_sum_range' hN]
+
+end Generic
+
+section Slots
+
+variable {K : Type} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+  (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+
+def slotH (f g : LaurentSeries ℚ) : Fin (ℓ + 1) → LaurentSeries K :=
+  Fin.cases (coeffEmb K (qExpand ℚ ℓ f)) (fun b : Fin ℓ => qTwist (ζ ^ (b : ℕ)) (coeffEmb K g))
+
+@[scoped simp] lemma slotH_zero (f g : LaurentSeries ℚ) :
+    slotH ℓ ζ f g 0 = coeffEmb K (qExpand ℚ ℓ f) := by
+  simp [slotH]
+
+@[scoped simp] lemma slotH_succ (f g : LaurentSeries ℚ) (b : Fin ℓ) :
+    slotH ℓ ζ f g b.succ = qTwist (ζ ^ (b : ℕ)) (coeffEmb K g) := by
+  simp [slotH]
+
+def liftPerm (e : Equiv.Perm (Fin ℓ)) :
+    Equiv.Perm (Fin (ℓ + 1)) := Equiv.Perm.decomposeFin.symm (0, e)
+
+omit hℓ in
+@[scoped simp] lemma liftPerm_zero (e : Equiv.Perm (Fin ℓ)) : liftPerm ℓ e 0 = 0 :=
+  Equiv.Perm.decomposeFin_symm_apply_zero 0 e
+
+omit hℓ in
+@[scoped simp] lemma liftPerm_succ (e : Equiv.Perm (Fin ℓ)) (b : Fin ℓ) :
+    liftPerm ℓ e b.succ = (e b).succ := by
+  rw [liftPerm, Equiv.Perm.decomposeFin_symm_apply_succ, Equiv.swap_self, Equiv.refl_apply]
+
+lemma coeffMap_qTwist {R S : Type*} [CommRing R] [CommRing S] (φ : R →+* S) (u : Rˣ)
+    (x : LaurentSeries R) :
+    coeffMap φ (qTwist u x) = qTwist (Units.map (φ : R →* S) u) (coeffMap φ x) := by
+  ext k
+  simp only [coeffMap_coeff, qTwist_coeff, map_mul]
+  congr 1
+  rw [← map_zpow (Units.map (φ : R →* S)) u k, Units.coe_map]
+  rfl
+
+omit hℓ [Algebra ℚ K] in
+lemma units_map_zeta_pow (σ : K →+* K) (e : Equiv.Perm (Fin ℓ))
+    (he : ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e b : Fin ℓ) : ℕ)) (b : Fin ℓ) :
+    Units.map (σ : K →* K) (ζ ^ (b : ℕ)) = ζ ^ ((e b : Fin ℓ) : ℕ) := by
+  ext
+  rw [Units.coe_map, Units.val_pow_eq_pow_val, Units.val_pow_eq_pow_val]
+  exact he b
+
+lemma coeffMap_slotH (f g : LaurentSeries ℚ) (σ : K ≃ₐ[ℚ] K) (e : Equiv.Perm (Fin ℓ))
+    (he : ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e b : Fin ℓ) : ℕ)) (i : Fin (ℓ + 1)) :
+    coeffMap (σ : K →+* K) (slotH ℓ ζ f g i) = slotH ℓ ζ f g (liftPerm ℓ e i) := by
+  refine Fin.cases ?_ (fun b => ?_) i
+  · rw [liftPerm_zero, slotH_zero, coeffMap_coeffEmb]
+  · rw [liftPerm_succ, slotH_succ, slotH_succ, coeffMap_qTwist, coeffMap_coeffEmb,
+      units_map_zeta_pow ℓ ζ (σ : K →+* K) e (fun b => he b) b]
+
+lemma coeffMap_conj (σ : K ≃ₐ[ℚ] K) (e : Equiv.Perm (Fin ℓ))
+    (he : ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e b : Fin ℓ) : ℕ)) (i : Fin (ℓ + 1)) :
+    coeffMap (σ : K →+* K) (PhiGen.conj ℓ ζ i) = PhiGen.conj ℓ ζ (liftPerm ℓ e i) := by
+  refine Fin.cases ?_ (fun b => ?_) i
+  · rw [liftPerm_zero, PhiGen.conj_zero, coeffMap_qExpand, coeffMap_coeffEmb]
+  · rw [liftPerm_succ, PhiGen.conj_succ, PhiGen.conj_succ, coeffMap_qTwist, coeffMap_coeffEmb,
+      units_map_zeta_pow ℓ ζ (σ : K →+* K) e (fun b => he b) b]
+
+include hζ in
+omit hℓ [Algebra ℚ K] in
+lemma zeta_pow_ell : ζ ^ ℓ = 1 := by
+  ext; rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one]
+
+include hζ in
+omit [Algebra ℚ K] in
+lemma zeta_mul_zeta_pow (b : Fin ℓ) : ζ * ζ ^ (b : ℕ) = ζ ^ (((b + 1 : Fin ℓ)) : ℕ) := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  rw [← pow_succ', Fin.val_add, Fin.val_one', Nat.add_mod_mod]
+  conv_lhs => rw [← Nat.div_add_mod ((b : ℕ) + 1) ℓ, pow_add, pow_mul, zeta_pow_ell ℓ ζ hζ, one_pow,
+    one_mul]
+
+include hζ in
+lemma qTwist_slotH (f g : LaurentSeries ℚ) (i : Fin (ℓ + 1)) :
+    qTwist ζ (slotH ℓ ζ f g i) = slotH ℓ ζ f g (liftPerm ℓ (Equiv.addRight (1 : Fin ℓ)) i) := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  refine Fin.cases ?_ (fun b => ?_) i
+  · rw [liftPerm_zero, slotH_zero, coeffEmb_qExpand, qTwist_qExpand, zpow_natCast, zeta_pow_ell ℓ ζ
+      hζ,
+      qTwist_one_apply]
+  · rw [liftPerm_succ, slotH_succ, slotH_succ, qTwist_qTwist, Equiv.coe_addRight, zeta_mul_zeta_pow
+      ℓ ζ hζ]
+
+include hζ in
+lemma qTwist_conj (i : Fin (ℓ + 1)) :
+    qTwist ζ (PhiGen.conj ℓ ζ i) = PhiGen.conj ℓ ζ (liftPerm ℓ (Equiv.addRight (1 : Fin ℓ)) i) := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  refine Fin.cases ?_ (fun b => ?_) i
+  · rw [liftPerm_zero, PhiGen.conj_zero, qTwist_qExpand]
+    congr 1
+    rw [show ((ℓ * ℓ : ℕ) : ℤ) = ((ℓ * ℓ : ℕ) : ℤ) from rfl, zpow_natCast, pow_mul, zeta_pow_ell ℓ ζ
+      hζ, one_pow,
+      qTwist_one_apply]
+  · rw [liftPerm_succ, PhiGen.conj_succ, PhiGen.conj_succ, qTwist_qTwist, Equiv.coe_addRight,
+      zeta_mul_zeta_pow ℓ ζ hζ]
+
+def interpK (f g : LaurentSeries ℚ) :
+    (LaurentSeries K)[X] := interpPoly (slotH ℓ ζ f g) (PhiGen.conj ℓ ζ)
+
+def conjK (f g : LaurentSeries ℚ) : (LaurentSeries K)[X] := conjPoly (slotH ℓ ζ f g)
+
+variable [IsGalois ℚ K] [FiniteDimensional ℚ K]
+
+include hζ in
+theorem exists_interpK_coeff_eq (f g : LaurentSeries ℚ) (k : ℕ) :
+    ∃ ξ : LaurentSeries ℚ, (interpK ℓ ζ f g).coeff k = coeffEmb K (qExpand ℚ ℓ ξ) := by
+  refine PhiGen.mem_range_coeffEmb_qExpand_of_mem_inter ?_ ?_
+  · refine mem_range_qExpand_of_qTwist_eq ℓ ζ hζ _ ?_
+    rw [← Polynomial.coeff_map, interpK, interpPoly_map]
+    have h1 : (⇑(qTwist ζ) ∘ slotH ℓ ζ f g) = slotH ℓ ζ f g ∘ liftPerm ℓ (Equiv.addRight (1 : Fin
+      ℓ)) :=
+      funext fun i => qTwist_slotH ℓ ζ hζ f g i
+    have h2 : (⇑(qTwist ζ) ∘ PhiGen.conj ℓ ζ) = PhiGen.conj ℓ ζ ∘ liftPerm ℓ (Equiv.addRight (1 :
+      Fin ℓ)) :=
+      funext fun i => qTwist_conj ℓ ζ hζ i
+    rw [h1, h2, interpPoly_perm]
+  · refine PhiGen.mem_range_coeffEmb_of_forall_coeffMap_eq
+      (fun c hc => (IsGalois.mem_range_algebraMap_iff_fixed c).mpr hc) fun σ => ?_
+    obtain ⟨e, he⟩ := PhiGen.exists_galoisPerm hζ (σ : K →+* K)
+    rw [← Polynomial.coeff_map, interpK, interpPoly_map]
+    have h1 : (⇑(coeffMap (σ : K →+* K)) ∘ slotH ℓ ζ f g) = slotH ℓ ζ f g ∘ liftPerm ℓ e :=
+      funext fun i => coeffMap_slotH ℓ ζ f g σ e he i
+    have h2 : (⇑(coeffMap (σ : K →+* K)) ∘ PhiGen.conj ℓ ζ) = PhiGen.conj ℓ ζ ∘ liftPerm ℓ e :=
+      funext fun i => coeffMap_conj ℓ ζ σ e he i
+    rw [h1, h2, interpPoly_perm]
+
+include hζ in
+theorem exists_conjK_coeff_eq (f g : LaurentSeries ℚ) (k : ℕ) :
+    ∃ π : LaurentSeries ℚ, (conjK ℓ ζ f g).coeff k = coeffEmb K (qExpand ℚ ℓ π) := by
+  refine PhiGen.mem_range_coeffEmb_qExpand_of_mem_inter ?_ ?_
+  · refine mem_range_qExpand_of_qTwist_eq ℓ ζ hζ _ ?_
+    rw [← Polynomial.coeff_map, conjK, conjPoly_map]
+    have h1 : (⇑(qTwist ζ) ∘ slotH ℓ ζ f g) = slotH ℓ ζ f g ∘ liftPerm ℓ (Equiv.addRight (1 : Fin
+      ℓ)) :=
+      funext fun i => qTwist_slotH ℓ ζ hζ f g i
+    rw [h1, conjPoly_perm]
+  · refine PhiGen.mem_range_coeffEmb_of_forall_coeffMap_eq
+      (fun c hc => (IsGalois.mem_range_algebraMap_iff_fixed c).mpr hc) fun σ => ?_
+    obtain ⟨e, he⟩ := PhiGen.exists_galoisPerm hζ (σ : K →+* K)
+    rw [← Polynomial.coeff_map, conjK, conjPoly_map]
+    have h1 : (⇑(coeffMap (σ : K →+* K)) ∘ slotH ℓ ζ f g) = slotH ℓ ζ f g ∘ liftPerm ℓ e :=
+      funext fun i => coeffMap_slotH ℓ ζ f g σ e he i
+    rw [h1, conjPoly_perm]
+
+end Slots
+
+def RealL (h : ℝ) (A : LaurentSeries ℂ) (F : ℍ → ℂ) : Prop :=
+  ∀ τ : ℍ, HasSum (fun m : ℤ => A.coeff m * 𝕢 h (τ : ℂ) ^ m) (F τ)
+
+namespace RealL
+
+variable {h : ℝ} {A B : LaurentSeries ℂ} {F G : ℍ → ℂ}
+
+lemma add (hA : RealL h A F) (hB : RealL h B G) : RealL h (A + B) (F + G) := fun τ => by
+  simpa [add_mul] using (hA τ).add (hB τ)
+
+lemma neg (hA : RealL h A F) : RealL h (-A) (-F) := fun τ => by
+  simpa [neg_mul] using (hA τ).neg
+
+lemma sub (hA : RealL h A F) (hB : RealL h B G) : RealL h (A - B) (F - G) := fun τ => by
+  simpa [sub_mul] using (hA τ).sub (hB τ)
+
+lemma mul (hh : 0 < h) (hA : RealL h A F) (hB : RealL h B G) : RealL h (A * B) (F * G) := fun τ =>
+  hasSum_qParam_mul_laurent h hh A B F G hA hB τ
+
+lemma single (h : ℝ) (a : ℂ) (n : ℤ) :
+    RealL h (HahnSeries.single n a) (fun τ => a * 𝕢 h (τ : ℂ) ^ n) := fun τ => by
+  refine (hasSum_ite_eq n (a * 𝕢 h (τ : ℂ) ^ n)).congr_fun fun m => ?_
+  by_cases hm : m = n
+  · subst hm; simp
+  · simp [HahnSeries.coeff_single_of_ne hm, hm]
+
+lemma C (h : ℝ) (a : ℂ) : RealL h (HahnSeries.C a) (fun _ => a) := by
+  simpa using single h a 0
+
+lemma one (h : ℝ) : RealL h 1 1 := by
+  simpa [Pi.one_def] using C h 1
+
+lemma zero (h : ℝ) : RealL h 0 0 := fun τ => by simp [hasSum_zero]
+
+lemma congr {A' : LaurentSeries ℂ} {F' : ℍ → ℂ} (hA : RealL h A F) (h1 : A = A')
+    (h2 : ∀ τ, F τ = F' τ) :
+    RealL h A' F' := fun τ => by rw [← h1, ← h2]; exact hA τ
+
+lemma sum {ι : Type} (s : Finset ι) {A : ι → LaurentSeries ℂ} {F : ι → ℍ → ℂ}
+    (hAF : ∀ i ∈ s, RealL h (A i) (F i)) : RealL h (∑ i ∈ s, A i) (fun τ => ∑ i ∈ s, F i τ) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => simpa [Pi.zero_def] using zero h
+  | insert a s ha ih =>
+    have h1 :=
+      (hAF a (Finset.mem_insert_self a s)).add (ih fun i hi => hAF i (Finset.mem_insert_of_mem hi))
+    refine h1.congr (Finset.sum_insert ha).symm fun τ => ?_
+    simp [Finset.sum_insert ha]
+
+lemma prod (hh : 0 < h) {ι : Type} (s : Finset ι) {A : ι → LaurentSeries ℂ} {F : ι → ℍ → ℂ}
+    (hAF : ∀ i ∈ s, RealL h (A i) (F i)) : RealL h (∏ i ∈ s, A i) (fun τ => ∏ i ∈ s, F i τ) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => simpa [Pi.one_def] using one h
+  | insert a s ha ih =>
+    have h1 :=
+      (hAF a (Finset.mem_insert_self a s)).mul hh (ih fun i hi => hAF i (Finset.mem_insert_of_mem
+        hi))
+    refine h1.congr (Finset.prod_insert ha).symm fun τ => ?_
+    simp [Finset.prod_insert ha]
+
+lemma coeff_prod_X_sub_C (hh : 0 < h) {ι : Type} (s : Finset ι) {a : ι → LaurentSeries ℂ}
+    {α : ι → ℍ → ℂ} (haα : ∀ i ∈ s, RealL h (a i) (α i)) (k : ℕ) :
+    RealL h ((∏ i ∈ s, (Polynomial.X - Polynomial.C (a i))).coeff k)
+      (fun τ => (∏ i ∈ s, (Polynomial.X - Polynomial.C (α i τ))).coeff k) := by
+  classical
+  induction s using Finset.induction_on generalizing k with
+  | empty =>
+    simp only [Finset.prod_empty, Polynomial.coeff_one]
+    by_cases hk : k = 0
+    · subst hk; simpa [Pi.one_def] using one h
+    · simpa [hk, Pi.zero_def] using zero h
+  | insert b s hb ih =>
+    have ih' := fun k => ih (fun i hi => haα i (Finset.mem_insert_of_mem hi)) k
+    have hb' := haα b (Finset.mem_insert_self b s)
+    have hA : (∏ i ∈ insert b s, (Polynomial.X - Polynomial.C (a i))) =
+        (∏ i ∈ s, (Polynomial.X - Polynomial.C (a i))) * (Polynomial.X - Polynomial.C (a b)) :=
+      (Finset.prod_insert hb).trans (mul_comm (G := Polynomial (LaurentSeries ℂ)) _ _)
+    have hfun : ∀ τ : ℍ, (∏ i ∈ insert b s, (Polynomial.X - Polynomial.C (α i τ))) =
+        (∏ i ∈ s, (Polynomial.X - Polynomial.C (α i τ))) * (Polynomial.X - Polynomial.C (α b τ)) :=
+      fun τ => (Finset.prod_insert hb).trans (mul_comm (G := Polynomial ℂ) _ _)
+    cases k with
+    | zero =>
+      refine ((ih' 0).mul hh hb').neg.congr ?_ fun τ => ?_
+      · rw [hA, Polynomial.mul_coeff_zero, Polynomial.coeff_sub, Polynomial.coeff_X_zero,
+          Polynomial.coeff_C_zero, zero_sub]
+        exact (mul_neg (α := LaurentSeries ℂ) _ _).symm
+      · simp only [hfun τ, Polynomial.mul_coeff_zero, Pi.neg_apply, Pi.mul_apply,
+          Polynomial.coeff_sub,
+          Polynomial.coeff_X_zero, Polynomial.coeff_C_zero, zero_sub, mul_neg]
+    | succ k =>
+      refine ((ih' k).sub ((ih' (k + 1)).mul hh hb')).congr ?_ fun τ => ?_
+      · rw [hA, Polynomial.coeff_mul_X_sub_C]
+      · simp only [hfun τ, Polynomial.coeff_mul_X_sub_C, Pi.sub_apply, Pi.mul_apply]
+
+lemma interpPoly_coeff (hh : 0 < h) {n : ℕ} {Hs Ys : Fin n → LaurentSeries ℂ} {η υ : Fin n → ℍ → ℂ}
+    (hH : ∀ i, RealL h (Hs i) (η i)) (hY : ∀ i, RealL h (Ys i) (υ i)) (k : ℕ) :
+    RealL h ((interpPoly Hs Ys).coeff k)
+      (fun τ => (interpPoly (fun i => η i τ) (fun i => υ i τ)).coeff k) := by
+  unfold interpPoly
+  have h1 : ∀ i ∈ (Finset.univ : Finset (Fin n)),
+      RealL h ((Polynomial.C (Hs i) * ∏ m ∈ Finset.univ.erase i, (Polynomial.X - Polynomial.C (Ys
+        m))).coeff k)
+        (fun τ => (Polynomial.C (η i τ) *
+          ∏ m ∈ Finset.univ.erase i, (Polynomial.X - Polynomial.C (υ m τ))).coeff k) := by
+    intro i _
+    refine ((hH i).mul hh (coeff_prod_X_sub_C hh (Finset.univ.erase i) (fun m _ => hY m) k)).congr
+      ?_ fun τ => ?_
+    · rw [Polynomial.coeff_C_mul]
+    · simp only [Pi.mul_apply, Polynomial.coeff_C_mul]
+  refine (sum Finset.univ h1).congr ?_ fun τ => ?_
+  · rw [Polynomial.finsetSum_coeff]
+  · simp only [Polynomial.finsetSum_coeff]
+
+lemma conjPoly_coeff (hh : 0 < h) {n : ℕ} {Hs : Fin n → LaurentSeries ℂ} {η : Fin n → ℍ → ℂ}
+    (hH : ∀ i, RealL h (Hs i) (η i)) (k : ℕ) :
+    RealL h ((conjPoly Hs).coeff k) (fun τ => (conjPoly fun i => η i τ).coeff k) :=
+  coeff_prod_X_sub_C hh Finset.univ (fun i _ => hH i) k
+
+end RealL
+
+section Periods
+
+variable (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)]
+
+lemma realL_one_of_realL_qExpand (x : LaurentSeries ℂ) (F : ℍ → ℂ) (hx : RealL ℓ (qExpand ℂ ℓ x) F)
+    :
+    RealL 1 x F := by
+  intro τ
+  have hinj : Function.Injective (fun n : ℤ => (ℓ : ℤ) * n) :=
+    mul_right_injective₀ (by exact_mod_cast hℓ.out.ne_zero)
+  have h := hx τ
+  rw [← hinj.hasSum_iff] at h
+  · refine h.congr_fun fun n => ?_
+    simp only [Function.comp_apply, qExpand_coeff_mul]
+    congr 1
+    rw [zpow_mul, zpow_natCast]
+    congr 1
+    simp only [Periodic.qParam, Complex.ofReal_one, div_one, Complex.ofReal_natCast]
+    rw [← Complex.exp_nat_mul]
+    congr 1
+    field_simp [(Nat.cast_ne_zero.mpr hℓ.out.ne_zero : (ℓ : ℂ) ≠ 0)]
+  · intro m hm
+    rw [qExpand_coeff_of_not_dvd ℓ _ (fun ⟨n, hn⟩ => hm ⟨n, hn.symm⟩), zero_mul]
+
+lemma realL_qExpand_of_realL_one (x : LaurentSeries ℂ) (F : ℍ → ℂ) (hx : RealL 1 x F) :
+    RealL ℓ (qExpand ℂ ℓ x) F := by
+  intro τ
+  have hinj : Function.Injective (fun n : ℤ => (ℓ : ℤ) * n) :=
+    mul_right_injective₀ (by exact_mod_cast hℓ.out.ne_zero)
+  rw [← hinj.hasSum_iff]
+  · refine (hx τ).congr_fun fun n => ?_
+    simp only [Function.comp_apply, qExpand_coeff_mul]
+    congr 1
+    rw [zpow_mul, zpow_natCast]
+    congr 1
+    simp only [Periodic.qParam, Complex.ofReal_one, div_one, Complex.ofReal_natCast]
+    rw [← Complex.exp_nat_mul]
+    congr 1
+    field_simp [(Nat.cast_ne_zero.mpr hℓ.out.ne_zero : (ℓ : ℂ) ≠ 0)]
+  · intro m hm
+    rw [qExpand_coeff_of_not_dvd ℓ _ (fun ⟨n, hn⟩ => hm ⟨n, hn.symm⟩), zero_mul]
+
+def expRoot : ℂ := Complex.exp (2 * Real.pi * Complex.I / ℓ)
+
+lemma isPrimitiveRoot_expRoot : IsPrimitiveRoot (expRoot ℓ) ℓ :=
+  Complex.isPrimitiveRoot_exp ℓ hℓ.out.ne_zero
+
+omit hℓ in
+lemma expRoot_pow_zpow (b : ℕ) (m : ℤ) :
+    (expRoot ℓ ^ b) ^ m = Complex.exp (2 * Real.pi * Complex.I * b * m / ℓ) := by
+  rw [expRoot, ← Complex.exp_nat_mul, ← Complex.exp_int_mul]
+  congr 1
+  ring
+
+omit hℓ in
+lemma qParam_T_pow_smul (b : ℕ) (τ : ℍ) :
+    𝕢 ℓ (((ModularGroup.T ^ b • τ : ℍ)) : ℂ) = expRoot ℓ ^ b * 𝕢 ℓ (τ : ℂ) := by
+  have h := modular_T_zpow_smul τ (b : ℤ)
+  rw [zpow_natCast] at h
+  rw [h, coe_vadd, expRoot, ← Complex.exp_nat_mul]
+  simp only [Periodic.qParam, Complex.ofReal_natCast, Int.cast_natCast]
+  rw [← Complex.exp_add]
+  congr 1
+  ring
+
+omit hℓ in
+lemma realL_twist (A : LaurentSeries ℂ) (G : ℍ → ℂ) (hA : RealL ℓ A G) (b : ℕ) (B : LaurentSeries ℂ)
+    (hB : ∀ m : ℤ, B.coeff m = (expRoot ℓ ^ b) ^ m * A.coeff m) :
+    RealL ℓ B (fun τ => G (ModularGroup.T ^ b • τ)) := by
+  intro τ
+  have h := hA (ModularGroup.T ^ b • τ)
+  refine h.congr_fun fun m => ?_
+  rw [hB m, qParam_T_pow_smul, mul_zpow]
+  ring
+
+end Periods
+
+section Analytic
+
+variable {K : Type} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+  (hζ : IsPrimitiveRoot (ζ : K) ℓ) (σ : K →+* ℂ) (hσ : σ (ζ : K) = expRoot ℓ)
+
+def jt (τ : ℍ) : ℂ := ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ
+
+def jtN (τ : ℍ) : ℂ := jt (ModularForm.heckeDiagMatrix ℓ • τ)
+
+abbrev castC : ℚ →+* ℂ := Rat.castHom ℂ
+
+omit hℓ in
+lemma coeffMap_sigma_coeffEmb (x : LaurentSeries ℚ) :
+    coeffMap σ (coeffEmb K x) = coeffMap castC x := by
+  ext m
+  rw [coeffMap_coeff, coeffEmb_coeff, coeffMap_coeff, eq_ratCast, map_ratCast]
+  rfl
+
+def cosetRep (i : Fin (ℓ + 1)) : SL(2, ℤ) :=
+  Fin.cases (1 : SL(2, ℤ)) (fun b : Fin ℓ => ModularGroup.S * ModularGroup.T ^ (b : ℕ)) i
+
+omit hℓ in
+@[scoped simp] lemma cosetRep_zero : cosetRep ℓ 0 = 1 := by simp [cosetRep]
+omit hℓ in
+@[scoped simp] lemma cosetRep_succ (b : Fin ℓ) :
+    cosetRep ℓ b.succ = ModularGroup.S * ModularGroup.T ^ (b : ℕ) := by
+  simp [cosetRep]
+
+def slotF (F : ℍ → ℂ) (i : Fin (ℓ + 1)) (τ : ℍ) : ℂ := F (cosetRep ℓ i • τ)
+
+def slotJ (i : Fin (ℓ + 1)) (τ : ℍ) : ℂ := jtN ℓ (cosetRep ℓ i • τ)
+
+variable (f g : LaurentSeries ℚ) (F : ℍ → ℂ)
+  (hF : ∀ τ : ℍ, HasSum (fun m : ℤ => ((f.coeff m : ℚ) : ℂ) * 𝕢 1 (τ : ℂ) ^ m) (F τ))
+  (hG : ∀ τ : ℍ, HasSum (fun m : ℤ => ((g.coeff m : ℚ) : ℂ) * 𝕢 ℓ (τ : ℂ) ^ m) (F (ModularGroup.S •
+    τ)))
+
+include hF in
+omit hℓ in
+lemma realL_fC : RealL 1 (coeffMap castC f) F := fun τ => hF τ
+
+include hG in
+omit hℓ in
+lemma realL_gC : RealL ℓ (coeffMap castC g) (fun τ => F (ModularGroup.S • τ)) := fun τ => hG τ
+
+include hF hG hσ in
+lemma realL_slotH (i : Fin (ℓ + 1)) :
+    RealL ℓ (coeffMap σ (slotH ℓ ζ f g i)) (slotF ℓ F i) := by
+  refine Fin.cases ?_ (fun b => ?_) i
+  · have h := realL_qExpand_of_realL_one ℓ _ _ (realL_fC f F hF)
+    refine h.congr ?_ fun τ => ?_
+    · rw [slotH_zero, coeffMap_sigma_coeffEmb, coeffMap_qExpand]
+    · simp [slotF]
+  · have h :=
+      realL_twist ℓ _ _ (realL_gC ℓ g F hG) (b : ℕ) (coeffMap σ (slotH ℓ ζ f g b.succ)) fun m => by
+      rw [slotH_succ, coeffMap_coeff, qTwist_coeff, map_mul, Units.val_zpow_eq_zpow_val, map_zpow₀,
+        Units.val_pow_eq_pow_val, map_pow, hσ, coeffEmb_coeff, eq_ratCast, map_ratCast,
+        coeffMap_coeff]
+      rfl
+    refine h.congr rfl fun τ => ?_
+    simp only [slotF, cosetRep_succ, mul_smul]
+
+lemma coeffMap_conj_zero_eq :
+    coeffMap σ (PhiGen.conj ℓ ζ 0) = qExpand ℂ (ℓ * ℓ) (coeffMap castC jq) := by
+  rw [PhiGen.conj_zero, coeffMap_qExpand, coeffMap_sigma_coeffEmb]
+
+omit hℓ in
+lemma realL_jqC : RealL 1 (coeffMap castC jq) jt := fun τ => hasSum_jq_qParam τ
+
+omit hℓ in
+lemma heckeDiag_smul_S_T_pow_smul [NeZero ℓ] (b : ℕ) (τ : ℍ) :
+    ModularForm.heckeDiagMatrix ℓ • (ModularGroup.S * ModularGroup.T ^ b) • τ =
+      ModularGroup.S • ModularForm.heckeMatrix ℓ b • τ := by
+  have hT : ((ModularGroup.T ^ b : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) = !![1, (b : ℤ); 0, 1] :=
+    by
+    have := ModularGroup.coe_T_zpow (b : ℤ)
+    rwa [zpow_natCast] at this
+  set g : SL(2, ℤ) := ModularGroup.S * ModularGroup.T ^ b with hg
+  have hg' : (g : Matrix (Fin 2) (Fin 2) ℤ) = !![0, -1; 1, (b : ℤ)] := by
+    rw [hg, Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_S, hT]
+    ext i j
+    fin_cases i <;> fin_cases j <;> simp [Matrix.mul_apply, Fin.sum_univ_two]
+  have h00 : g 0 0 = 0 := congrFun (congrFun hg' 0) 0
+  have h01 : g 0 1 = -1 := congrFun (congrFun hg' 0) 1
+  have h10 : g 1 0 = 1 := congrFun (congrFun hg' 1) 0
+  have h11 : g 1 1 = b := congrFun (congrFun hg' 1) 1
+  clear_value g
+  have hmat : ModularForm.heckeDiagMatrix ℓ * Matrix.SpecialLinearGroup.mapGL ℝ g =
+      Matrix.SpecialLinearGroup.mapGL ℝ ModularGroup.S * ModularForm.heckeMatrix ℓ b := by
+    ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp [Matrix.mul_apply, Fin.sum_univ_two, ModularForm.val_heckeDiagMatrix (NeZero.ne ℓ),
+        ModularForm.val_heckeMatrix (NeZero.ne ℓ), ModularGroup.coe_S, h00, h01, h10, h11]
+  have h1 : ModularForm.heckeDiagMatrix ℓ • g • τ =
+      (ModularForm.heckeDiagMatrix ℓ * Matrix.SpecialLinearGroup.mapGL ℝ g) • τ := by
+    rw [mul_smul]; rfl
+  have h2 : ModularGroup.S • ModularForm.heckeMatrix ℓ b • τ =
+      (Matrix.SpecialLinearGroup.mapGL ℝ ModularGroup.S * ModularForm.heckeMatrix ℓ b) • τ := by
+    rw [mul_smul]; rfl
+  rw [h1, h2, hmat]
+
+include hσ in
+lemma realL_conj (i : Fin (ℓ + 1)) : RealL ℓ (coeffMap σ (PhiGen.conj ℓ ζ i)) (slotJ ℓ i) := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  refine Fin.cases ?_ (fun b => ?_) i
+  · intro τ
+    have h := hasSum_qParam_heckeDiagMatrix_smul ℓ (coeffMap castC jq) jt realL_jqC τ
+    rw [coeffMap_conj_zero_eq]
+    simpa [slotJ, jtN] using h
+  · intro τ
+    have h := hasSum_qParam_heckeMatrix_smul ℓ (b : ℕ) (coeffMap castC jq) jt realL_jqC τ
+    have hval : slotJ ℓ b.succ τ = jt (ModularForm.heckeMatrix ℓ (b : ℕ) • τ) := by
+      rw [slotJ, jtN, cosetRep_succ, heckeDiag_smul_S_T_pow_smul]
+      exact E4_cube_div_discriminant_smul ModularGroup.S _
+    rw [hval]
+    refine h.congr_fun fun m => ?_
+    congr 1
+    rw [PhiGen.conj_succ, coeffMap_coeff, qTwist_coeff, map_mul, Units.val_zpow_eq_zpow_val,
+      map_zpow₀,
+      Units.val_pow_eq_pow_val, map_pow, hσ, expRoot_pow_zpow, coeffEmb_coeff, eq_ratCast,
+      map_ratCast,
+      coeffMap_coeff]
+    rfl
+
+def interpFun (k : ℕ) (τ : ℍ) :
+    ℂ := (interpPoly (fun i => slotF ℓ F i τ) (fun i => slotJ ℓ i τ)).coeff k
+
+def conjFun (k : ℕ) (τ : ℍ) : ℂ := (conjPoly fun i => slotF ℓ F i τ).coeff k
+
+variable (hinv : ∀ γ ∈ CongruenceSubgroup.Gamma0 ℓ, ∀ τ : ℍ, F (γ • τ) = F τ)
+
+omit hℓ in
+lemma jtN_smul [NeZero ℓ] (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 ℓ) (τ : ℍ) :
+    jtN ℓ (γ • τ) = jtN ℓ τ := by
+  obtain ⟨γ', hγ', -⟩ := exists_sl2_heckeDiagMatrix_smul_eq ℓ γ hγ
+  rw [jtN, jtN, hγ' τ]
+  exact E4_cube_div_discriminant_smul γ' _
+
+include hinv in
+lemma slots_smul (γ : SL(2, ℤ)) : ∃ e : Equiv.Perm (Fin (ℓ + 1)),
+    (∀ i τ, slotF ℓ F i (γ • τ) = slotF ℓ F (e i) τ) ∧ (∀ i τ, slotJ ℓ i (γ • τ) = slotJ ℓ (e i) τ)
+      := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  obtain ⟨e, he⟩ := exists_perm_gamma0_cosetReps ℓ γ
+  have key : ∀ (i : Fin (ℓ + 1)) (τ : ℍ),
+      cosetRep ℓ i • γ • τ = (cosetRep ℓ i * γ * (cosetRep ℓ (e i))⁻¹) • cosetRep ℓ (e i) • τ := by
+    intro i τ
+    simp only [smul_smul, inv_mul_cancel_right]
+  have he' : ∀ i, cosetRep ℓ i * γ * (cosetRep ℓ (e i))⁻¹ ∈ CongruenceSubgroup.Gamma0 ℓ := he
+  refine ⟨e, fun i τ => ?_, fun i τ => ?_⟩
+  · rw [slotF, slotF, key, hinv _ (he' i)]
+  · rw [slotJ, slotJ, key, jtN_smul ℓ _ (he' i)]
+
+include hinv in
+lemma interpFun_smul (k : ℕ) (γ : SL(2, ℤ)) (τ : ℍ) :
+    interpFun ℓ F k (γ • τ) = interpFun ℓ F k τ := by
+  obtain ⟨e, h1, h2⟩ := slots_smul ℓ F hinv γ
+  unfold interpFun
+  have hH : (fun i => slotF ℓ F i (γ • τ)) = (fun i => slotF ℓ F i τ) ∘ e := funext fun i => h1 i τ
+  have hY : (fun i => slotJ ℓ i (γ • τ)) = (fun i => slotJ ℓ i τ) ∘ e := funext fun i => h2 i τ
+  rw [hH, hY, interpPoly_perm]
+
+include hinv in
+lemma conjFun_smul (k : ℕ) (γ : SL(2, ℤ)) (τ : ℍ) : conjFun ℓ F k (γ • τ) = conjFun ℓ F k τ := by
+  obtain ⟨e, h1, -⟩ := slots_smul ℓ F hinv γ
+  unfold conjFun
+  have hH : (fun i => slotF ℓ F i (γ • τ)) = (fun i => slotF ℓ F i τ) ∘ e := funext fun i => h1 i τ
+  rw [hH, conjPoly_perm]
+
+include hF hG hσ hinv in
+lemma mem_adjoin_of_interpK_coeff_eq (k : ℕ) (ξ : LaurentSeries ℚ)
+    (hξ : (interpK ℓ ζ f g).coeff k = coeffEmb K (qExpand ℚ ℓ ξ)) : ξ ∈ Algebra.adjoin ℚ {jq} := by
+  have h1 : RealL ℓ (coeffMap σ ((interpK ℓ ζ f g).coeff k)) (interpFun ℓ F k) := by
+    have h := RealL.interpPoly_coeff (h := (ℓ : ℝ)) (by exact_mod_cast hℓ.out.pos)
+      (fun i => realL_slotH ℓ ζ σ hσ f g F hF hG i) (fun i => realL_conj ℓ ζ σ hσ i) k
+    refine h.congr ?_ fun τ => rfl
+    rw [← Polynomial.coeff_map, interpK, interpPoly_map]
+    rfl
+  rw [hξ, coeffMap_sigma_coeffEmb, coeffMap_qExpand] at h1
+  have h2 := realL_one_of_realL_qExpand ℓ _ _ h1
+  exact mem_adjoin_jq_of_hasSum_of_slash_invariant ξ (interpFun ℓ F k) h2
+    (fun γ τ => interpFun_smul ℓ F hinv k γ τ)
+
+include hF hG hσ hinv in
+lemma mem_adjoin_of_conjK_coeff_eq (k : ℕ) (π : LaurentSeries ℚ)
+    (hπ : (conjK ℓ ζ f g).coeff k = coeffEmb K (qExpand ℚ ℓ π)) : π ∈ Algebra.adjoin ℚ {jq} := by
+  have h1 : RealL ℓ (coeffMap σ ((conjK ℓ ζ f g).coeff k)) (conjFun ℓ F k) := by
+    have h := RealL.conjPoly_coeff (h := (ℓ : ℝ)) (by exact_mod_cast hℓ.out.pos)
+      (fun i => realL_slotH ℓ ζ σ hσ f g F hF hG i) k
+    refine h.congr ?_ fun τ => rfl
+    rw [← Polynomial.coeff_map, conjK, conjPoly_map]
+    rfl
+  rw [hπ, coeffMap_sigma_coeffEmb, coeffMap_qExpand] at h1
+  have h2 := realL_one_of_realL_qExpand ℓ _ _ h1
+  exact mem_adjoin_jq_of_hasSum_of_slash_invariant π (conjFun ℓ F k) h2
+    (fun γ τ => conjFun_smul ℓ F hinv k γ τ)
+
+end Analytic
+
+section Assembly
+
+variable {K : Type} [Field K] [Algebra ℚ K] [IsGalois ℚ K] [FiniteDimensional ℚ K]
+  (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) ℓ) (σ : K →+* ℂ)
+  (hσ : σ (ζ : K) = expRoot ℓ)
+  (f g : LaurentSeries ℚ) (F : ℍ → ℂ)
+  (hF : ∀ τ : ℍ, HasSum (fun m : ℤ => ((f.coeff m : ℚ) : ℂ) * 𝕢 1 (τ : ℂ) ^ m) (F τ))
+  (hG : ∀ τ : ℍ, HasSum (fun m : ℤ => ((g.coeff m : ℚ) : ℂ) * 𝕢 ℓ (τ : ℂ) ^ m) (F (ModularGroup.S •
+    τ)))
+  (hinv : ∀ γ ∈ CongruenceSubgroup.Gamma0 ℓ, ∀ τ : ℍ, F (γ • τ) = F τ)
+
+def iota : LaurentSeries ℚ →+* LaurentSeries K := (coeffEmb K).comp (qExpand ℚ ℓ)
+
+omit [IsGalois ℚ K] [FiniteDimensional ℚ K] in
+lemma iota_apply (x : LaurentSeries ℚ) : iota (K := K) ℓ x = coeffEmb K (qExpand ℚ ℓ x) := rfl
+
+omit [IsGalois ℚ K] [FiniteDimensional ℚ K] in
+lemma coeffEmb_injective' :
+    Function.Injective (coeffEmb K : LaurentSeries ℚ → LaurentSeries K) := by
+  intro x y h
+  ext m
+  have hm := congrArg (fun z : LaurentSeries K => z.coeff m) h
+  simp only [coeffEmb_coeff] at hm
+  exact (algebraMap ℚ K).injective hm
+
+omit [IsGalois ℚ K] [FiniteDimensional ℚ K] in
+lemma iota_injective : Function.Injective (iota (K := K) ℓ) :=
+  coeffEmb_injective'.comp (qExpand_injective (R := ℚ) ℓ)
+
+omit [IsGalois ℚ K] [FiniteDimensional ℚ K] in
+lemma iota_eq_slotH_zero : iota ℓ f = slotH ℓ ζ f g 0 := by
+  rw [iota_apply, slotH_zero]
+
+omit [IsGalois ℚ K] [FiniteDimensional ℚ K] in
+lemma iota_jqN : iota (K := K) ℓ (jqN ℓ) = PhiGen.conj ℓ ζ 0 := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  rw [iota_apply, jqN, qExpand_qExpand, PhiGen.conj_zero, coeffEmb_qExpand]
+
+def dHat :
+    LaurentSeries K := ∏ m ∈ Finset.univ.erase (0 : Fin (ℓ + 1)), (PhiGen.conj ℓ ζ 0 - PhiGen.conj ℓ
+      ζ m)
+
+include hζ in
+omit [IsGalois ℚ K] [FiniteDimensional ℚ K] in
+lemma dHat_ne_zero : dHat ℓ ζ ≠ 0 := by
+  rw [dHat, Finset.prod_ne_zero_iff]
+  intro m hm h0
+  exact (Finset.ne_of_mem_erase hm) ((PhiGen.conj_injective ℓ ζ hζ (sub_eq_zero.mp h0)).symm)
+
+include hζ in
+lemma exists_sum_eq_mul_dHat (hmem : ∀ (k : ℕ) (ξ : LaurentSeries ℚ),
+      (interpK ℓ ζ f g).coeff k = coeffEmb K (qExpand ℚ ℓ ξ) → ξ ∈ Algebra.adjoin ℚ {jq}) :
+    ∃ x : LaurentSeries ℚ, x ∈ modularFunctionField ℓ ∧ iota ℓ x = iota ℓ f * dHat ℓ ζ := by
+  classical
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  choose ξ hξ using fun k => exists_interpK_coeff_eq ℓ ζ hζ f g k
+  have hadj : Algebra.adjoin ℚ {jq} ≤ (modularFunctionField ℓ).toSubalgebra :=
+    Algebra.adjoin_le (Set.singleton_subset_iff.mpr (jq_mem ℓ))
+  refine ⟨∑ k ∈ Finset.range ((interpK ℓ ζ f g).natDegree + 1), ξ k * jqN ℓ ^ k, ?_, ?_⟩
+  · refine sum_mem fun k _ => mul_mem (hadj (hmem k (ξ k) (hξ k))) (pow_mem (jqN_mem ℓ) k)
+  · rw [map_sum]
+    simp only [map_mul, map_pow, iota_jqN ℓ ζ, iota_apply, ← hξ]
+    rw [← Polynomial.eval_eq_sum_range, interpK, interpPoly_eval, ← slotH_zero ℓ ζ f g, dHat]
+
+include hζ hσ hF hG hinv in
+theorem mem_modularFunctionField_of_data : f ∈ modularFunctionField ℓ := by
+  classical
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  obtain ⟨x, hx, hιx⟩ := exists_sum_eq_mul_dHat ℓ ζ hζ f g
+    (fun k ξ h => mem_adjoin_of_interpK_coeff_eq ℓ ζ σ hσ f g F hF hG hinv k ξ h)
+  have h1F : ∀ τ : ℍ, HasSum (fun m : ℤ => (((1 : LaurentSeries ℚ).coeff m : ℚ) : ℂ) * 𝕢 1 (τ : ℂ) ^
+    m)
+      ((fun _ : ℍ => (1 : ℂ)) τ) := by
+    intro τ
+    have h := RealL.one 1 τ
+    rw [← map_one (coeffMap castC)] at h
+    exact h
+  have h1G : ∀ τ : ℍ, HasSum (fun m : ℤ => (((1 : LaurentSeries ℚ).coeff m : ℚ) : ℂ) * 𝕢 ℓ (τ : ℂ) ^
+    m)
+      ((fun _ : ℍ => (1 : ℂ)) (ModularGroup.S • τ)) := by
+    intro τ
+    have h := RealL.one (ℓ : ℝ) τ
+    rw [← map_one (coeffMap castC)] at h
+    exact h
+  obtain ⟨d, hd, hιd⟩ := exists_sum_eq_mul_dHat ℓ ζ hζ 1 1
+    (fun k ξ h => mem_adjoin_of_interpK_coeff_eq ℓ ζ σ hσ 1 1 (fun _ => 1) h1F h1G (fun _ _ _ =>
+      rfl) k ξ h)
+  rw [map_one, one_mul] at hιd
+  have hd0 : d ≠ 0 := by
+    rintro rfl
+    exact dHat_ne_zero ℓ ζ hζ (by rw [map_zero] at hιd; exact hιd.symm)
+  have hfd : f * d = x := iota_injective (K := K) ℓ (by rw [map_mul, hιd, hιx])
+  have hf : f = x * d⁻¹ := by rw [← hfd, mul_inv_cancel_right₀ hd0]
+  rw [hf]
+  exact mul_mem hx (inv_mem hd)
+
+include hζ hσ hF hG hinv in
+theorem isIntegral_of_data : IsIntegral (Algebra.adjoin ℚ {jq}) f := by
+  classical
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  choose π hπ using fun k => exists_conjK_coeff_eq ℓ ζ hζ f g k
+  have hπmem : ∀ k, π k ∈ Algebra.adjoin ℚ {jq} := fun k =>
+    mem_adjoin_of_conjK_coeff_eq ℓ ζ σ hσ f g F hF hG hinv k (π k) (hπ k)
+  have hdeg : (conjK ℓ ζ f g).natDegree = ℓ + 1 := conjPoly_natDegree _
+  have hmon : (conjK ℓ ζ f g).Monic := conjPoly_monic _
+  let p : Polynomial (Algebra.adjoin ℚ {jq}) :=
+    ∑ k ∈ Finset.range (ℓ + 2),
+      Polynomial.C (⟨π k, hπmem k⟩ : Algebra.adjoin ℚ {jq}) * (Polynomial.X : Polynomial
+        (Algebra.adjoin ℚ {jq})) ^ k
+  have hcoeffp : ∀ n, p.coeff n = if n < ℓ + 2 then (⟨π n, hπmem n⟩ : Algebra.adjoin ℚ {jq}) else 0
+    :=
+    by
+    intro n
+    simp only [p, Polynomial.finsetSum_coeff, Polynomial.coeff_C_mul, Polynomial.coeff_X_pow,
+      mul_ite, mul_one,
+      mul_zero]
+    rw [Finset.sum_ite_eq]
+    simp only [Finset.mem_range]
+  have hmapmap : (p.map (algebraMap (Algebra.adjoin ℚ {jq}) (LaurentSeries ℚ))).map (iota ℓ) = conjK
+    ℓ ζ f g :=
+    by
+    rw [Polynomial.map_map]
+    simp only [p, Polynomial.map_sum, Polynomial.map_mul, Polynomial.map_pow, Polynomial.map_C,
+      Polynomial.map_X,
+      RingHom.comp_apply]
+    have hk : ∀ k, (iota (K := K) ℓ) ((algebraMap (Algebra.adjoin ℚ {jq}) (LaurentSeries ℚ)) ⟨π k,
+      hπmem k⟩) =
+        (conjK ℓ ζ f g).coeff k :=
+      fun k => (hπ k).symm
+    simp only [hk]
+    exact (Polynomial.as_sum_range_C_mul_X_pow' _ (by rw [hdeg]; omega)).symm
+  refine ⟨p, ?_, ?_⟩
+  · refine Polynomial.monic_of_natDegree_le_of_coeff_eq_one (ℓ + 1) ?_ ?_
+    · exact Polynomial.natDegree_sum_le_of_forall_le _ _ fun k hk =>
+        (Polynomial.natDegree_C_mul_X_pow_le _ k).trans (Nat.lt_succ_iff.mp (Finset.mem_range.mp
+          hk))
+    · rw [hcoeffp, ite_eq_left (by omega)]
+      refine Subtype.ext ?_
+      apply iota_injective (K := K) ℓ
+      rw [iota_apply, ← hπ (ℓ + 1), ← hdeg, hmon.coeff_natDegree]
+      exact (map_one (iota (K := K) ℓ)).symm
+  · rw [Polynomial.eval₂_eq_eval_map]
+    apply iota_injective (K := K) ℓ
+    rw [map_zero]
+    change (iota ℓ) (Polynomial.eval₂ (RingHom.id _) f
+      ((p.map (algebraMap (Algebra.adjoin ℚ {jq}) (LaurentSeries ℚ))))) = 0
+    rw [Polynomial.hom_eval₂, Polynomial.eval₂_eq_eval_map, ← Polynomial.map_map, Polynomial.map_id,
+      hmapmap,
+      iota_eq_slotH_zero ℓ ζ f g, conjK]
+    exact conjPoly_eval _ 0
+
+end Assembly
+
+section Main
+
+variable (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)]
+
+def sigma (ζ : (CyclotomicField ℓ ℚ)ˣ) (hζ : IsPrimitiveRoot (ζ : CyclotomicField ℓ ℚ) ℓ) :
+    CyclotomicField ℓ ℚ →+* ℂ :=
+  letI : Algebra ℚ (CyclotomicField ℓ ℚ) := CyclotomicField.algebra ℓ ℚ
+  haveI : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  haveI := CyclotomicField.isCyclotomicExtension ℓ ℚ
+  ((hζ.embeddingsEquivPrimitiveRoots ℂ (Polynomial.cyclotomic.irreducible_rat hℓ.out.pos)).symm
+    ⟨expRoot ℓ, (mem_primitiveRoots hℓ.out.pos).mpr (isPrimitiveRoot_expRoot ℓ)⟩).toRingHom
+
+lemma sigma_zeta (ζ : (CyclotomicField ℓ ℚ)ˣ) (hζ : IsPrimitiveRoot (ζ : CyclotomicField ℓ ℚ) ℓ) :
+    sigma ℓ ζ hζ (ζ : CyclotomicField ℓ ℚ) = expRoot ℓ := by
+  let : Algebra ℚ (CyclotomicField ℓ ℚ) := CyclotomicField.algebra ℓ ℚ
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  have := CyclotomicField.isCyclotomicExtension ℓ ℚ
+  let e := hζ.embeddingsEquivPrimitiveRoots ℂ (Polynomial.cyclotomic.irreducible_rat hℓ.out.pos)
+  let r : primitiveRoots ℓ ℂ :=
+    ⟨expRoot ℓ, (mem_primitiveRoots hℓ.out.pos).mpr (isPrimitiveRoot_expRoot ℓ)⟩
+  have h := IsPrimitiveRoot.embeddingsEquivPrimitiveRoots_apply_coe hζ ℂ
+    (Polynomial.cyclotomic.irreducible_rat hℓ.out.pos) (e.symm r)
+  rw [Equiv.apply_symm_apply] at h
+  exact h.symm
+
+variable (f g : LaurentSeries ℚ) (F : ℍ → ℂ)
+  (hF : ∀ τ : ℍ, HasSum (fun m : ℤ => ((f.coeff m : ℚ) : ℂ) * 𝕢 1 (τ : ℂ) ^ m) (F τ))
+  (hG : ∀ τ : ℍ, HasSum (fun m : ℤ => ((g.coeff m : ℚ) : ℂ) * 𝕢 ℓ (τ : ℂ) ^ m) (F (ModularGroup.S •
+    τ)))
+  (hinv : ∀ γ ∈ CongruenceSubgroup.Gamma0 ℓ, ∀ τ : ℍ, F (γ • τ) = F τ)
+
+include hF hG hinv in
+theorem mem_modularFunctionField : f ∈ modularFunctionField ℓ := by
+  have : NeZero ((ℓ : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr hℓ.out.ne_zero⟩
+  have hcyc : IsCyclotomicExtension {ℓ} ℚ (CyclotomicField ℓ ℚ) :=
+    CyclotomicField.isCyclotomicExtension (n := ℓ) (K := ℚ)
+  have : FiniteDimensional ℚ (CyclotomicField ℓ ℚ) :=
+    IsCyclotomicExtension.finiteDimensional {ℓ} ℚ (CyclotomicField ℓ ℚ)
+  have : IsGalois ℚ (CyclotomicField ℓ ℚ) :=
+    IsCyclotomicExtension.isGalois (S := {ℓ}) (K := ℚ) (L := CyclotomicField ℓ ℚ)
+  obtain ⟨z, hz⟩ := IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField ℓ ℚ)
+    (Set.mem_singleton ℓ) hℓ.out.ne_zero
+  have hzu : IsUnit z := hz.isUnit hℓ.out.ne_zero
+  have hζ : IsPrimitiveRoot ((hzu.unit : (CyclotomicField ℓ ℚ)ˣ) : CyclotomicField ℓ ℚ) ℓ := by
+    rw [hzu.unit_spec]; exact hz
+  exact mem_modularFunctionField_of_data ℓ hzu.unit hζ (sigma ℓ hzu.unit hζ) (sigma_zeta ℓ hzu.unit
+    hζ)
+    f g F hF hG hinv
+
+include hF hG hinv in
+theorem isIntegral_adjoin_jq : IsIntegral (Algebra.adjoin ℚ {jq}) f := by
+  have : NeZero ((ℓ : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr hℓ.out.ne_zero⟩
+  have hcyc : IsCyclotomicExtension {ℓ} ℚ (CyclotomicField ℓ ℚ) :=
+    CyclotomicField.isCyclotomicExtension (n := ℓ) (K := ℚ)
+  have : FiniteDimensional ℚ (CyclotomicField ℓ ℚ) :=
+    IsCyclotomicExtension.finiteDimensional {ℓ} ℚ (CyclotomicField ℓ ℚ)
+  have : IsGalois ℚ (CyclotomicField ℓ ℚ) :=
+    IsCyclotomicExtension.isGalois (S := {ℓ}) (K := ℚ) (L := CyclotomicField ℓ ℚ)
+  obtain ⟨z, hz⟩ := IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField ℓ ℚ)
+    (Set.mem_singleton ℓ) hℓ.out.ne_zero
+  have hzu : IsUnit z := hz.isUnit hℓ.out.ne_zero
+  have hζ : IsPrimitiveRoot ((hzu.unit : (CyclotomicField ℓ ℚ)ˣ) : CyclotomicField ℓ ℚ) ℓ := by
+    rw [hzu.unit_spec]; exact hz
+  exact isIntegral_of_data ℓ hzu.unit hζ (sigma ℓ hzu.unit hζ) (sigma_zeta ℓ hzu.unit hζ) f g F hF
+    hG hinv
+
+end Main
+
+end QExpN
+end ModularCurve
+end
+
+theorem solution (ℓ : ℕ) [Fact (Nat.Prime ℓ)] (f g : LaurentSeries ℚ) (F : UpperHalfPlane → ℂ) (hF :
+  ∀ τ : UpperHalfPlane, HasSum (fun m : ℤ => ((f.coeff m : ℚ) : ℂ) * Function.Periodic.qParam 1 (τ :
+  ℂ) ^ m) (F τ)) (hG : ∀ τ : UpperHalfPlane, HasSum (fun m : ℤ => ((g.coeff m : ℚ) : ℂ) *
+  Function.Periodic.qParam ℓ (τ : ℂ) ^ m) (F (ModularGroup.S • τ))) (hinv : ∀ γ ∈
+  CongruenceSubgroup.Gamma0 ℓ, ∀ τ : UpperHalfPlane, F (γ • τ) = F τ) :
+    IsIntegral (Algebra.adjoin ℚ {ModularCurve.jq}) f :=
+  ModularCurve.QExpN.isIntegral_adjoin_jq ℓ f g F hF hG hinv
+
+end S_ModularCurve_isIntegral_adjoin_jq_of_hasSum_of_gamma0_invariant
+end P2MW
+export P2MW.S_ModularCurve_isIntegral_adjoin_jq_of_hasSum_of_gamma0_invariant (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.isIntegral_adjoin_jq_of_hasSum_of_gamma0_invariant (ℓ : ℕ) [Fact (Nat.Prime ℓ)]
+  (f g : LaurentSeries ℚ) (F : UpperHalfPlane → ℂ) (hF : ∀ τ : UpperHalfPlane, HasSum (fun m : ℤ =>
+  ((f.coeff m : ℚ) : ℂ) * Function.Periodic.qParam 1 (τ : ℂ) ^ m) (F τ)) (hG : ∀ τ : UpperHalfPlane,
+  HasSum (fun m : ℤ => ((g.coeff m : ℚ) : ℂ) * Function.Periodic.qParam ℓ (τ : ℂ) ^ m) (F
+  (ModularGroup.S • τ))) (hinv : ∀ γ ∈ CongruenceSubgroup.Gamma0 ℓ, ∀ τ : UpperHalfPlane, F (γ • τ)
+  = F τ) :
+    IsIntegral (Algebra.adjoin ℚ {ModularCurve.jq}) f :=
+  solution ℓ f g F hF hG hinv
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_and_isIntegral_of_mem_riemannRochSpace_weightFloor.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_and_isIntegral_of_mem_riemannRochSpace_weightFloor.lean
new file mode 100644
index 0000000000..c6f391c65a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_and_isIntegral_of_mem_riemannRochSpace_weightFloor.lean
@@ -0,0 +1,367 @@
+/-
+Based on Prove2Me node ModularCurve.isIntegral_and_isIntegral_of_mem_riemannRochSpace_weightFloor
+(4378864a-6bf6-50e9-8e4b-cdec05b41d44) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission bd45be07-b3b5-53c4-9f93-daac2a14f55b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Repartitions
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isIntegral_adjoin_of_forall_mem_toValuationSubring
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality shape for the weight-m floor Riemann–Roch space
+
+Theorem statement: `ModularCurve.isIntegral_and_isIntegral_of_mem_riemannRochSpace_weightFloor`
+(`4378864a-6bf6-50e9-8e4b-cdec05b41d44`), by Claude, 2026-09-05.
+
+Proof: submission `bd45be07-b3b5-53c4-9f93-daac2a14f55b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $F$ be an intermediate field of the Laurent series field $K((q))$ over
+$K$. Let $y \in F$ be an element whose image in $K((q))$ is the series [`ModularCurve.jqModC
+K`](def/ModularCurve_JqCoeff.html#L15), namely $q^{-1}$ times the reduction to $K$ of the power
+series $E_4^3\cdot\eta^{-24}$-type numerator `jNum`; assume $F$ is finite-dimensional and separable
+over the intermediate field $K(y)$ generated by $y$. Let $m \in \mathbb{N}$ and let $D$ be a divisor
+on $F/K$, i.e. a finitely supported integer-valued function on the places $w$ of $F/K$ (valuation
+subrings of $F$ containing $K$, distinct from $F$, and principal ideal rings), such that for every
+$w$, $D(w)$ is the sum of $(2m\,\mathrm{ord}_w y)/3$ when $\mathrm{ord}_w y > 0$ and $0$ otherwise,
+$(m\,\mathrm{ord}_w(y-1728))/2$ when $\mathrm{ord}_w(y-1728) > 0$ and $0$ otherwise, and
+$m\,\mathrm{ord}_w y$ when $\mathrm{ord}_w y < 0$ and $0$ otherwise; here $\mathrm{ord}_w$ is minus
+the logarithm of the adic valuation at $w$, and the quotients are integer division, hence floors for
+these non-negative numerators. Let $G \in F$ lie in the Riemann–Roch space of $D$, i.e. $w(G) \le
+\exp(D(w))$ for every place $w$. Then, writing $j$ for [`ModularCurve.jqModC
+K`](def/ModularCurve_JqCoeff.html#L15) and viewing $G$ in $K((q))$: $G^6 j^{4m}(j-1728)^{3m}$ is
+integral over the $K$-subalgebra generated by $j$, and $G^2 j^{m}(j-1728)^{m}$ is integral over the
+$K$-subalgebra generated by $j^{-1}$.
+
+This is the level-free form of the statement that an element of the weight-$m$ floor Riemann–Roch
+space has the integrality (holomorphy) shape of a weight-$2m$ modular function on the two standard
+charts of the $j$-line, the two conjuncts being integrality over $K[j]$ and over $K[j^{-1}]$. It is
+used in the proofs of the lower bounds for the dimensions of spaces of modular forms of even and of
+odd weight on $\Gamma_1$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_isIntegral_and_isIntegral_of_mem_riemannRochSpace_weightFloor.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 3200000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_isIntegral_and_isIntegral_of_mem_riemannRochSpace_weightFloor
+
+open AlgebraicCurve ModularCurve
+
+namespace DictC1p
+
+section Ord
+
+variable {K : Type*} {FF : Type*} [Field K] [Field FF] [Algebra K FF] (w : Place K FF)
+
+theorem mem_iff_le_one {f : FF} : f ∈ w.toValuationSubring ↔ w.adicValuation f ≤ 1 :=
+  Place.mem_iff_adicValuation_le_one w
+
+theorem ord_nonneg_iff {f : FF} (hf : f ≠ 0) : 0 ≤ w.ord f ↔ w.adicValuation f ≤ 1 := by
+  rw [Place.ord, neg_nonneg, WithZero.log_le_iff_le_exp (w.adicValuation_ne_zero hf),
+    WithZero.exp_zero]
+
+theorem ord_pos_iff {f : FF} (hf : f ≠ 0) : 0 < w.ord f ↔ w.adicValuation f < 1 := by
+  rw [Place.ord, neg_pos, ← WithZero.log_one,
+    WithZero.log_lt_log (w.adicValuation_ne_zero hf) one_ne_zero]
+
+theorem ord_neg_iff {f : FF} (hf : f ≠ 0) : w.ord f < 0 ↔ 1 < w.adicValuation f := by
+  rw [Place.ord, neg_lt_zero, ← WithZero.log_one,
+    WithZero.log_lt_log one_ne_zero (w.adicValuation_ne_zero hf)]
+
+theorem ord_nonneg_of_mem {f : FF} (h : f ∈ w.toValuationSubring) : 0 ≤ w.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · rw [Place.ord_zero]
+  · exact (ord_nonneg_iff w hf).2 ((mem_iff_le_one w).1 h)
+
+theorem mem_of_ord_nonneg {f : FF} (h : 0 ≤ w.ord f) : f ∈ w.toValuationSubring := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · exact zero_mem _
+  · exact (mem_iff_le_one w).2 ((ord_nonneg_iff w hf).1 h)
+
+theorem ord_pow (f : FF) (n : ℕ) : w.ord (f ^ n) = n * w.ord f := by
+  rw [← zpow_natCast, Place.ord_zpow]
+
+theorem adicValuation_algebraMap {c : K} (hc : c ≠ 0) :
+    w.adicValuation (algebraMap K FF c) = 1 := by
+  apply le_antisymm (w.adicValuation_algebraMap_le_one c)
+  have h1 : w.adicValuation (algebraMap K FF c) * w.adicValuation (algebraMap K FF c⁻¹) = 1 := by
+    rw [← map_mul, ← map_mul, mul_inv_cancel₀ hc, map_one, map_one]
+  have h2 := w.adicValuation_algebraMap_le_one c⁻¹
+  by_contra h
+  rw [not_le] at h
+  have : w.adicValuation (algebraMap K FF c) * w.adicValuation (algebraMap K FF c⁻¹) < 1 * 1 :=
+    mul_lt_mul_of_lt_of_le_of_nonneg_of_pos h h2 zero_le zero_lt_one
+  rw [h1, one_mul] at this
+  exact lt_irrefl _ this
+
+theorem ord_algebraMap {c : K} (hc : c ≠ 0) : w.ord (algebraMap K FF c) = 0 := by
+  rw [Place.ord, adicValuation_algebraMap w hc, WithZero.log_one, neg_zero]
+
+theorem ord_sub_algebraMap_eq_zero_of_ord_pos {t : FF} (ht : t ≠ 0) {c : K} (hc : c ≠ 0)
+    (h : 0 < w.ord t) :
+    w.ord (t - algebraMap K FF c) = 0 := by
+  have hv : w.adicValuation t < w.adicValuation (algebraMap K FF c) := by
+    rw [adicValuation_algebraMap w hc]; exact (ord_pos_iff w ht).1 h
+  rw [Place.ord, Valuation.map_sub_swap, Valuation.map_sub_eq_of_lt_left _ hv,
+    adicValuation_algebraMap w hc,
+    WithZero.log_one, neg_zero]
+
+theorem ord_sub_algebraMap_eq_of_ord_neg {t : FF} (ht : t ≠ 0) (c : K) (h : w.ord t < 0) :
+    w.ord (t - algebraMap K FF c) = w.ord t := by
+  have hv : w.adicValuation (algebraMap K FF c) < w.adicValuation t :=
+    lt_of_le_of_lt (w.adicValuation_algebraMap_le_one c) ((ord_neg_iff w ht).1 h)
+  rw [Place.ord, Place.ord, Valuation.map_sub_eq_of_lt_left _ hv]
+
+theorem ord_eq_zero_of_ord_sub_algebraMap_pos {t : FF} {c : K} (hc : c ≠ 0)
+    (htc : t - algebraMap K FF c ≠ 0)
+    (h : 0 < w.ord (t - algebraMap K FF c)) : w.ord t = 0 := by
+  have hv : w.adicValuation (t - algebraMap K FF c) < w.adicValuation (algebraMap K FF c) := by
+    rw [adicValuation_algebraMap w hc]; exact (ord_pos_iff w htc).1 h
+  have : t = (t - algebraMap K FF c) + algebraMap K FF c := by ring
+  rw [Place.ord, this, Valuation.map_add_eq_of_lt_right _ hv, adicValuation_algebraMap w hc,
+    WithZero.log_one, neg_zero]
+
+end Ord
+
+theorem isIntegral_adjoin_coe {K : Type*} {L : Type*} [Field K] [Field L] [Algebra K L]
+    {E : IntermediateField K L}
+    (t z : ↥E) (hz : IsIntegral (Algebra.adjoin K ({t} : Set ↥E)) z) :
+    IsIntegral (Algebra.adjoin K ({(t : L)} : Set L)) (z : L) := by
+  classical
+  obtain ⟨P, hPm, hP0⟩ := hz
+  have hcoef : ∀ i, ∃ c : Polynomial K, Polynomial.aeval t c = (P.coeff i : ↥E) := by
+    intro i
+    have hm : (P.coeff i : ↥E) ∈ (Polynomial.aeval (R := K) t).range := by
+      rw [← Algebra.adjoin_singleton_eq_range_aeval]; exact (P.coeff i).2
+    exact (AlgHom.mem_range _).1 hm
+  choose c hc using hcoef
+  set n := P.natDegree with hn
+  have hrelE : z ^ n + ∑ i ∈ Finset.range n, (P.coeff i : ↥E) * z ^ i = 0 := by
+    have h := hP0
+    rw [hPm.as_sum, Polynomial.eval₂_add, Polynomial.eval₂_X_pow, Polynomial.eval₂_finsetSum] at h
+    simp only [Polynomial.eval₂_mul, Polynomial.eval₂_C, Polynomial.eval₂_X_pow] at h
+    exact h
+  have hmemL : ∀ i, Polynomial.aeval (t : L) (c i) ∈ Algebra.adjoin K ({(t : L)} : Set L) :=
+    fun i => by
+    rw [Algebra.adjoin_singleton_eq_range_aeval]; exact ⟨c i, rfl⟩
+  have hrelL : (z : L) ^ n + ∑ i ∈ Finset.range n, Polynomial.aeval (t : L) (c i) * (z : L) ^ i = 0
+    :=
+    by
+    have h := congrArg (fun x : ↥E => (x : L)) hrelE
+    push_cast at h
+    rw [← h]
+    congr 1
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [← hc i]
+    congr 1
+    exact Polynomial.aeval_algHom_apply E.val t (c i)
+  let Q : Polynomial ↥(Algebra.adjoin K ({(t : L)} : Set L)) :=
+    Polynomial.X ^ n + ∑ i ∈ Finset.range n,
+      Polynomial.C (⟨Polynomial.aeval (t : L) (c i), hmemL i⟩ : ↥(Algebra.adjoin K ({(t : L)} : Set
+        L))) *
+        Polynomial.X ^ i
+  have hQm : Q.Monic := by
+    apply Polynomial.monic_X_pow_add
+    refine lt_of_le_of_lt (Polynomial.degree_sum_le _ _) ?_
+    refine (Finset.sup_lt_iff (WithBot.bot_lt_coe n)).2 fun i hi => ?_
+    refine lt_of_le_of_lt (Polynomial.degree_C_mul_X_pow_le i _) ?_
+    exact WithBot.coe_lt_coe.2 (Finset.mem_range.1 hi)
+  refine ⟨Q, hQm, ?_⟩
+  simp only [Q, Polynomial.eval₂_add, Polynomial.eval₂_X_pow, Polynomial.eval₂_finsetSum,
+    Polynomial.eval₂_mul,
+    Polynomial.eval₂_C]
+  exact hrelL
+
+end DictC1p
+
+open DictC1p in
+theorem solution
+    (K : Type*) [Field K] (F : IntermediateField K (LaurentSeries K))
+    (y : ↥F) (hy : (y : LaurentSeries K) = ModularCurve.jqModC K)
+    [FiniteDimensional ↥(IntermediateField.adjoin K ({y} : Set ↥F)) ↥F]
+    [Algebra.IsSeparable ↥(IntermediateField.adjoin K ({y} : Set ↥F)) ↥F]
+    (m : ℕ) (D : AlgebraicCurve.Divisor K ↥F)
+    (hD : ∀ w : AlgebraicCurve.Place K ↥F,
+      D w = (if 0 < w.ord y then (2 * (m : ℤ) * w.ord y) / 3 else 0)
+          + (if 0 < w.ord (y - 1728) then ((m : ℤ) * w.ord (y - 1728)) / 2 else 0)
+          + (if w.ord y < 0 then (m : ℤ) * w.ord y else 0))
+    (G : ↥F) (hG : G ∈ AlgebraicCurve.riemannRochSpace D) :
+    IsIntegral ↥(Algebra.adjoin K ({ModularCurve.jqModC K} : Set (LaurentSeries K)))
+        ((G : LaurentSeries K) ^ 6 * ModularCurve.jqModC K ^ (4 * m) *
+          (ModularCurve.jqModC K - algebraMap K (LaurentSeries K) 1728) ^ (3 * m)) ∧
+      IsIntegral ↥(Algebra.adjoin K ({(ModularCurve.jqModC K)⁻¹} : Set (LaurentSeries K)))
+        ((G : LaurentSeries K) ^ 2 * ModularCurve.jqModC K ^ m *
+          (ModularCurve.jqModC K - algebraMap K (LaurentSeries K) 1728) ^ m) := by
+  classical
+  rename_i hfd hsep
+  rw [← hy]
+  set j : ↥F := y with hjdef
+  have hjcoe : (j : LaurentSeries K) = jqModC K := hy
+  have hD' : ∀ w : Place K ↥F, D w = (if 0 < w.ord j then (2 * (m : ℤ) * w.ord j) / 3 else 0)
+          + (if 0 < w.ord (j - algebraMap K _ 1728) then ((m : ℤ) * w.ord (j - algebraMap K _ 1728))
+            / 2 else 0)
+          + (if w.ord j < 0 then (m : ℤ) * w.ord j else 0) := by
+    intro w; rw [map_ofNat]; exact hD w
+  have hcoe1 : ((G ^ 6 * j ^ (4 * m) * (j - algebraMap K _ 1728) ^ (3 * m) : ↥F) :
+      LaurentSeries K) = (G : LaurentSeries K) ^ 6 * (j : LaurentSeries K) ^ (4 * m) *
+        ((j : LaurentSeries K) - algebraMap K (LaurentSeries K) 1728) ^ (3 * m) := by
+    push_cast; rfl
+  have hcoe2 : ((G ^ 2 * j ^ m * (j - algebraMap K _ 1728) ^ m : ↥F) :
+      LaurentSeries K) = (G : LaurentSeries K) ^ 2 * (j : LaurentSeries K) ^ m *
+        ((j : LaurentSeries K) - algebraMap K (LaurentSeries K) 1728) ^ m := by
+    push_cast; rfl
+  have hjinvcoe : ((j⁻¹ : ↥F) : LaurentSeries K) = (j : LaurentSeries K)⁻¹ := by push_cast; rfl
+  rw [← hcoe1, ← hcoe2, ← hjinvcoe]
+  rcases eq_or_ne G 0 with hG0 | hG0
+  · subst hG0
+    simp only [ne_eq, OfNat.ofNat_ne_zero, not_false_eq_true, zero_pow, zero_mul]
+    push_cast
+    exact ⟨isIntegral_zero, isIntegral_zero⟩
+  have hj0 : j ≠ 0 := by
+    intro h
+    have : (j : LaurentSeries K) = 0 := by rw [h]; rfl
+    rw [hjcoe] at this
+    exact (transcendental_jqModC K) (this ▸ isAlgebraic_zero)
+  rw [mem_riemannRochSpace_iff] at hG
+  have hG' : ∀ w : Place K ↥F, -D w ≤ w.ord G := fun w => (hG w).resolve_left hG0
+  have key : ∀ w : Place K ↥F,
+      (0 ≤ w.ord j → 0 ≤ 6 * w.ord G + (4 * m : ℕ) * w.ord j + (3 * m : ℕ) * w.ord (j - algebraMap K
+        _ 1728)) ∧
+      (w.ord j ≤ 0 → 0 ≤ 2 * w.ord G + (m : ℤ) * w.ord j + (m : ℤ) * w.ord (j - algebraMap K _
+        1728)) := by
+    intro w
+    have hDw := hG' w
+    rw [hD' w] at hDw
+    have hjm : 0 ≤ w.ord j → j ∈ w.toValuationSubring := fun h => mem_of_ord_nonneg w h
+    constructor
+    · intro hj
+      have hc0 : 0 ≤ w.ord (j - algebraMap K _ 1728) :=
+        ord_nonneg_of_mem w (w.toValuationSubring.sub_mem (hjm hj) (w.algebraMap_mem' _))
+      have hneg : ¬ w.ord j < 0 := not_lt.2 hj
+      rw [ite_eq_right hneg, add_zero] at hDw
+      by_cases h0 : 0 < w.ord j <;> by_cases h1 : 0 < w.ord (j - algebraMap K _ 1728)
+      · rw [ite_eq_left h0, ite_eq_left h1] at hDw
+        have e1 := Int.ediv_mul_le (2 * (m : ℤ) * w.ord j) (by norm_num : (3 : ℤ) ≠ 0)
+        have e2 :=
+          Int.ediv_mul_le ((m : ℤ) * w.ord (j - algebraMap K _ 1728)) (by norm_num : (2 : ℤ) ≠ 0)
+        push_cast; nlinarith
+      · rw [ite_eq_left h0, ite_eq_right h1, add_zero] at hDw
+        have e1 := Int.ediv_mul_le (2 * (m : ℤ) * w.ord j) (by norm_num : (3 : ℤ) ≠ 0)
+        push_cast; nlinarith
+      · rw [ite_eq_right h0, ite_eq_left h1, zero_add] at hDw
+        have e2 :=
+          Int.ediv_mul_le ((m : ℤ) * w.ord (j - algebraMap K _ 1728)) (by norm_num : (2 : ℤ) ≠ 0)
+        have : w.ord j = 0 := le_antisymm (not_lt.1 h0) hj
+        rw [this]; push_cast; nlinarith
+      · rw [ite_eq_right h0, ite_eq_right h1, add_zero] at hDw
+        have : w.ord j = 0 := le_antisymm (not_lt.1 h0) hj
+        rw [this]; push_cast; nlinarith
+    · intro hj
+      rcases lt_or_eq_of_le hj with hneg | hzero
+      · have hc : w.ord (j - algebraMap K _ 1728) = w.ord j :=
+          ord_sub_algebraMap_eq_of_ord_neg w hj0 1728 hneg
+        rw [ite_eq_right (show ¬ 0 < w.ord j from by
+          omega), ite_eq_right (show ¬ 0 < w.ord (j - algebraMap K _ 1728) from by
+            omega),
+          ite_eq_left hneg, zero_add, zero_add] at hDw
+        rw [hc]; nlinarith
+      · have hc0 : 0 ≤ w.ord (j - algebraMap K _ 1728) :=
+          ord_nonneg_of_mem w (w.toValuationSubring.sub_mem (hjm hzero.ge) (w.algebraMap_mem' _))
+        rw [ite_eq_right (show ¬ 0 < w.ord j from by
+          omega), ite_eq_right (show ¬ w.ord j < 0 from by
+            omega), zero_add, add_zero] at hDw
+        by_cases h1 : 0 < w.ord (j - algebraMap K _ 1728)
+        · rw [ite_eq_left h1] at hDw
+          have e2 :=
+            Int.ediv_mul_le ((m : ℤ) * w.ord (j - algebraMap K _ 1728)) (by norm_num : (2 : ℤ) ≠ 0)
+          rw [hzero]; nlinarith
+        · rw [ite_eq_right h1] at hDw
+          rw [hzero]; nlinarith
+  have hjc : ∀ w : Place K ↥F, True := fun _ => trivial
+  have hord1 : ∀ w : Place K ↥F, j - algebraMap K _ 1728 ≠ 0 →
+      w.ord (G ^ 6 * j ^ (4 * m) * (j - algebraMap K _ 1728) ^ (3 * m)) =
+      6 * w.ord G + (4 * m : ℕ) * w.ord j + (3 * m : ℕ) * w.ord (j - algebraMap K _ 1728) := fun w
+        hjc => by
+    rw [w.ord_mul (mul_ne_zero (pow_ne_zero _ hG0) (pow_ne_zero _ hj0)) (pow_ne_zero _ hjc),
+      w.ord_mul (pow_ne_zero _ hG0) (pow_ne_zero _ hj0), ord_pow, ord_pow, ord_pow]
+    push_cast; ring
+  have hord2 : ∀ w : Place K ↥F, j - algebraMap K _ 1728 ≠ 0 →
+      w.ord (G ^ 2 * j ^ m * (j - algebraMap K _ 1728) ^ m) =
+      2 * w.ord G + (m : ℤ) * w.ord j + (m : ℤ) * w.ord (j - algebraMap K _ 1728) := fun w hjc => by
+    rw [w.ord_mul (mul_ne_zero (pow_ne_zero _ hG0) (pow_ne_zero _ hj0)) (pow_ne_zero _ hjc),
+      w.ord_mul (pow_ne_zero _ hG0) (pow_ne_zero _ hj0), ord_pow, ord_pow, ord_pow]
+    push_cast; ring
+  have hjc0 : j - algebraMap K ↥F 1728 ≠ 0 := by
+    intro h
+    have h' : (j : LaurentSeries K) = algebraMap K (LaurentSeries K) 1728 := by
+      rw [sub_eq_zero] at h; rw [h]; rfl
+    rw [hjcoe] at h'
+    exact (transcendental_jqModC K) (h' ▸ isAlgebraic_algebraMap (1728 : K))
+  constructor
+  · apply isIntegral_adjoin_coe
+    refine @isIntegral_adjoin_of_forall_mem_toValuationSubring K _ _ _ _ j hfd hsep j _ fun w hw =>
+      ?_
+    apply mem_of_ord_nonneg
+    rw [hord1 w hjc0]
+    exact (key w).1 (ord_nonneg_of_mem w hw)
+  · apply isIntegral_adjoin_coe
+    refine @isIntegral_adjoin_of_forall_mem_toValuationSubring K _ _ _ _ j hfd hsep j⁻¹ _ fun w hw
+      => ?_
+    apply mem_of_ord_nonneg
+    rw [hord2 w hjc0]
+    have : w.ord j ≤ 0 := by have := ord_nonneg_of_mem w hw; rw [Place.ord_inv] at this; omega
+    exact (key w).2 this
+
+end S_ModularCurve_isIntegral_and_isIntegral_of_mem_riemannRochSpace_weightFloor
+end P2MW
+export P2MW.S_ModularCurve_isIntegral_and_isIntegral_of_mem_riemannRochSpace_weightFloor (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem ModularCurve.isIntegral_and_isIntegral_of_mem_riemannRochSpace_weightFloor
+    (K : Type*) [Field K] (F : IntermediateField K (LaurentSeries K))
+    (y : ↥F) (hy : (y : LaurentSeries K) = ModularCurve.jqModC K)
+    [FiniteDimensional ↥(IntermediateField.adjoin K ({y} : Set ↥F)) ↥F]
+    [Algebra.IsSeparable ↥(IntermediateField.adjoin K ({y} : Set ↥F)) ↥F]
+    (m : ℕ) (D : AlgebraicCurve.Divisor K ↥F)
+    (hD : ∀ w : AlgebraicCurve.Place K ↥F,
+      D w = (if 0 < w.ord y then (2 * (m : ℤ) * w.ord y) / 3 else 0)
+          + (if 0 < w.ord (y - 1728) then ((m : ℤ) * w.ord (y - 1728)) / 2 else 0)
+          + (if w.ord y < 0 then (m : ℤ) * w.ord y else 0))
+    (G : ↥F) (hG : G ∈ AlgebraicCurve.riemannRochSpace D) :
+    IsIntegral ↥(Algebra.adjoin K ({ModularCurve.jqModC K} : Set (LaurentSeries K)))
+        ((G : LaurentSeries K) ^ 6 * ModularCurve.jqModC K ^ (4 * m) *
+          (ModularCurve.jqModC K - algebraMap K (LaurentSeries K) 1728) ^ (3 * m)) ∧
+      IsIntegral ↥(Algebra.adjoin K ({(ModularCurve.jqModC K)⁻¹} : Set (LaurentSeries K)))
+        ((G : LaurentSeries K) ^ 2 * ModularCurve.jqModC K ^ m *
+          (ModularCurve.jqModC K - algebraMap K (LaurentSeries K) 1728) ^ m) :=
+  solution K F y hy m D hD G hG
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_and_isIntegral_of_smul_D_mem_regularDifferentialsBar.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_and_isIntegral_of_smul_D_mem_regularDifferentialsBar.lean
new file mode 100644
index 0000000000..77316981a7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_and_isIntegral_of_smul_D_mem_regularDifferentialsBar.lean
@@ -0,0 +1,475 @@
+/-
+Based on Prove2Me node ModularCurve.isIntegral_and_isIntegral_of_smul_D_mem_regularDifferentialsBar
+(64343a26-8fd8-5e9b-ac17-2c48e989ce48) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6348e099-ea0b-55cf-8e23-934c6f8195d1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_HeckeDifferential
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Analysis.Normed.Ring.Lemmas
+import Mathlib.Data.Int.Star
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ordDiff_D_eq_ord_sub_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ordDiff_smul_of_perfectField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_add_eq_of_lt
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isIntegral_adjoin_of_forall_ord_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_mem_regularDiffs_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_regularDiffs_eq_regularDifferentials
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_pos
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_essFiniteType_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_of_neZero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCurveOver_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_jBar_dvd_three
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_jBar_sub_1728_dvd_two
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_jBar_sub_eq_one_of_ne_zero_of_ne
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_sum_neg_ord_jBar_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality bounds from regularity of x djmath̄ on X₀(N)_ℚ̄
+
+Theorem statement: `ModularCurve.isIntegral_and_isIntegral_of_smul_D_mem_regularDifferentialsBar`
+(`64343a26-8fd8-5e9b-ac17-2c48e989ce48`), by Claude, 2026-09-05.
+
+Proof: submission `6348e099-ea0b-55cf-8e23-934c6f8195d1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N \ge 1$ and write $\overline F_N$ for [`ModularCurve.modularFunctionFieldBar
+N`](def/ModularCurve_ArithmeticGalois.html#L111), the intermediate field of the Laurent series field
+$\overline{\mathbb Q}((q))$ over $\overline{\mathbb Q}$ generated by the coefficientwise image of
+the subfield $\mathbb Q\bigl(\text{divisorExpansions } N\bigr) \subseteq \mathbb Q((q))$ under the
+coefficient embedding induced by $\mathbb Q \to \overline{\mathbb Q}$. Let $\bar\jmath \in \overline
+F_N$ be the element given by the image of the Laurent series
+[`ModularCurve.jq`](def/ModularCurve_X0.html#L157) $= q^{-1}\cdot(\text{the rational
+}j\text{-numerator power series})$ under that embedding, which lies in $\overline F_N$ because `jq`
+lies in `modularFunctionField N`, itself contained in `modularFunctionFieldFull N`. Let $x \in
+\overline F_N$ and assume that the Kähler differential $x \cdot d\bar\jmath \in \Omega_{\overline
+F_N / \overline{\mathbb Q}}$ lies in `regularDifferentialsBar N`, i.e. for every place $v$ of
+$\overline F_N$ over $\overline{\mathbb Q}$ there is $f$ in the valuation subring of $v$ with $x
+\cdot d\bar\jmath = f \cdot v.\mathrm{dCoord}$. The conclusion is a conjunction: first,
+$x^{6}\,\bar\jmath^{\,4}\,(\bar\jmath - 1728)^{3}$ is integral over the $\overline{\mathbb
+Q}$-subalgebra generated by $\bar\jmath$; second, with $\psi(N) = \sum_{d \mid N,\ d\
+\text{squarefree}} N/d$ denoting `dedekindPsi N`, the element
+$x^{2\psi(N)}\,\bar\jmath^{\,\psi(N)+1}\,(\bar\jmath - 1728)^{\psi(N)}$ is integral over the
+$\overline{\mathbb Q}$-subalgebra generated by $\bar\jmath^{-1}$. Here $1728$ is the image of $1728
+\in \overline{\mathbb Q}$ in $\overline F_N$.
+
+This is the algebraic half of the identification of regular differentials on $X_0(N)$ with
+weight-two cusp forms: regularity of $\omega = x\,d\bar\jmath$ at every place is converted into two
+integrality relations, one over $\overline{\mathbb Q}[\bar\jmath]$ (controlling the ramification of
+$\bar\jmath$ at its zeros, at $\bar\jmath = 1728$ and elsewhere) and one over $\overline{\mathbb
+Q}[\bar\jmath^{-1}]$ (controlling the poles of $\bar\jmath$, of total degree $\psi(N)$). It is used
+in the passage from a regular differential to a cusp form with the corresponding $q$-expansion, and
+in the comparison of regular differentials over a residue field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_isIntegral_and_isIntegral_of_smul_D_mem_regularDifferentialsBar.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_isIntegral_and_isIntegral_of_smul_D_mem_regularDifferentialsBar
+
+open ModularCurve AlgebraicCurve HahnSeries KaehlerDifferential
+
+
+noncomputable section
+
+namespace ALGGlue
+
+variable (N : ℕ) [NeZero N]
+
+local notation "𝕂" => AlgebraicClosure ℚ
+local notation "𝔽" => ModularCurve.modularFunctionFieldBar N
+
+abbrev jB : modularFunctionFieldBar N :=
+  ⟨coeffEmb (AlgebraicClosure ℚ) jq,
+    coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionField_le_full N (jq_mem N))⟩
+
+theorem D_jB_ne_zero : D 𝕂 𝔽 (jB N) ≠ 0 := by
+  intro h
+  have h1 : diffQExp 𝔽 (D 𝕂 𝔽 (jB N)) = qEuler 𝕂 ((jB N : 𝔽) : LaurentSeries 𝕂) := diffQExp_D _ _
+  rw [h, map_zero] at h1
+  have h2 := congrArg (fun s : LaurentSeries 𝕂 => s.coeff (-1)) h1
+  simp only at h2
+  rw [qEuler_coeff] at h2
+  have h3 : ((jB N : 𝔽) : LaurentSeries 𝕂).coeff (-1) = 1 := by
+    change (coeffEmb 𝕂 jq).coeff (-1) = 1
+    rw [coeffEmb_coeff, coeff_jq_neg_one, map_one]
+  rw [h3, HahnSeries.coeff_zero] at h2
+  norm_num at h2
+
+theorem jB_ne_zero : (jB N : 𝔽) ≠ 0 := by
+  intro h
+  have := D_jB_ne_zero N
+  rw [h, map_zero] at this
+  exact this rfl
+
+section Generic
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem ord_pow' (v : Place K F) (f : F) (n : ℕ) : v.ord (f ^ n) = n * v.ord f := by
+  have := v.ord_zpow f (n : ℤ)
+  rwa [zpow_natCast] at this
+
+theorem ord_algebraMap (v : Place K F) {c : K} : v.ord (algebraMap K F c) = 0 := by
+  have h1 : 0 ≤ v.ord (algebraMap K F c) := v.ord_nonneg_of_mem (v.algebraMap_mem' c)
+  have h2 : 0 ≤ v.ord (algebraMap K F c⁻¹) := v.ord_nonneg_of_mem (v.algebraMap_mem' c⁻¹)
+  rw [map_inv₀, v.ord_inv] at h2
+  omega
+
+theorem ord_neg (v : Place K F) (f : F) : v.ord (-f) = v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · simp
+  have h1 : v.ord (-f) = v.ord (-1) + v.ord f := by
+    rw [← v.ord_mul (by norm_num) hf, neg_one_mul]
+  have h2 : v.ord ((-1 : F)) = 0 := by
+    have := v.ord_zpow (-1 : F) 2
+    norm_num at this
+    linarith
+  rw [h1, h2, zero_add]
+
+theorem ord_pos_of_mem_maximalIdeal (v : Place K F) {a : v.toValuationSubring}
+    (ha : a ∈ IsLocalRing.maximalIdeal v.toValuationSubring) (ha0 : (a : F) ≠ 0)
+    : 0 < v.ord (a : F) := by
+  by_contra hle
+  push Not at hle
+  have h0 : 0 ≤ v.ord (a : F) := v.ord_nonneg_of_mem a.2
+  have heq : v.ord (a : F) = 0 := le_antisymm hle h0
+  have hinv : (a : F)⁻¹ ∈ v.toValuationSubring := by
+    rw [v.mem_iff_ord_nonneg (inv_ne_zero ha0), v.ord_inv, heq, neg_zero]
+  have hunit : IsUnit a := by
+    refine isUnit_iff_exists_inv.mpr ⟨⟨(a : F)⁻¹, hinv⟩, ?_⟩
+    ext
+    simp [mul_inv_cancel₀ ha0]
+  exact (IsLocalRing.mem_maximalIdeal _).mp ha hunit
+
+theorem exists_value [IsAlgClosed K] [IsCurveOver K F] (v : Place K F) {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    ∃ c : K, f - algebraMap K F c = 0 ∨ 0 < v.ord (f - algebraMap K F c) := by
+  have : Module.Finite K v.ResidueField := IsCurveOver.finiteResidue v
+  have : Algebra.IsIntegral K v.ResidueField := Algebra.IsIntegral.of_finite K v.ResidueField
+  have hbij : Function.Bijective (algebraMap K v.ResidueField) :=
+    IsAlgClosed.algebraMap_bijective_of_isIntegral
+  obtain ⟨c, hc⟩ := hbij.2 (IsLocalRing.residue v.toValuationSubring ⟨f, hf⟩)
+  refine ⟨c, ?_⟩
+  have hmem : (⟨f, hf⟩ - algebraMap K v.toValuationSubring c : v.toValuationSubring) ∈
+      IsLocalRing.maximalIdeal v.toValuationSubring := by
+    rw [← IsLocalRing.residue_eq_zero_iff, map_sub, ← hc]
+    rw [IsScalarTower.algebraMap_apply K v.toValuationSubring v.ResidueField]
+    exact sub_self _
+  have hcoe : ((⟨f, hf⟩ - algebraMap K v.toValuationSubring c : v.toValuationSubring) : F) =
+      f - algebraMap K F c := by
+    push_cast
+    rw [v.coe_algebraMap]
+  by_cases h0 : f - algebraMap K F c = 0
+  · exact Or.inl h0
+  · right
+    have := ord_pos_of_mem_maximalIdeal v hmem (by rw [hcoe]; exact h0)
+    rwa [hcoe] at this
+
+end Generic
+
+theorem ord_bound (x : 𝔽) (hx0 : x ≠ 0) (hreg : ∀ v : Place 𝕂 𝔽, 0 ≤ v.ordDiff (x • D 𝕂 𝔽 (jB N)))
+    [FiniteDimensional (IntermediateField.adjoin 𝕂 ({(jB N : 𝔽)} : Set 𝔽)) 𝔽]
+    (v : Place 𝕂 𝔽) {g : 𝔽} (hg : v.ord g ≠ 0) (hDg : D 𝕂 𝔽 g = D 𝕂 𝔽 (jB N)) :
+    1 - v.ord g ≤ v.ord x := by
+  have : Algebra.IsAlgebraic (IntermediateField.adjoin 𝕂 ({(jB N : 𝔽)} : Set 𝔽)) 𝔽 :=
+    Algebra.IsAlgebraic.of_finite _ _
+  have h := hreg v
+  rw [← hDg] at h
+  rw [Place.ordDiff_smul_of_perfectField (jB N : 𝔽) v hx0 (by rw [hDg]; exact D_jB_ne_zero N),
+    Place.ordDiff_D_eq_ord_sub_one (jB N : 𝔽) v hg] at h
+  omega
+
+theorem main (x : 𝔽) (hx : x • D 𝕂 𝔽 (jB N) ∈ regularDifferentialsBar N) :
+    IsIntegral (Algebra.adjoin 𝕂 ({(jB N : 𝔽)} : Set 𝔽)) (x ^ 6 * (jB N) ^ 4 * (jB N - algebraMap 𝕂
+      𝔽 1728) ^ 3) ∧
+    IsIntegral (Algebra.adjoin 𝕂 ({(jB N : 𝔽)⁻¹} : Set 𝔽))
+      (x ^ (2 * dedekindPsi N) * (jB N) ^ (dedekindPsi N + 1) * (jB N - algebraMap 𝕂 𝔽 1728) ^
+        dedekindPsi N) := by
+  classical
+  have hCO := ModularCurve.isCurveOver_modularFunctionFieldBar N
+  have hEFT := ModularCurve.essFiniteType_modularFunctionFieldBar N
+  have hFD : FiniteDimensional (IntermediateField.adjoin 𝕂 ({(jB N : 𝔽)} : Set 𝔽)) 𝔽 :=
+    ModularCurve.finiteDimensional_adjoin_coeffEmb_jq_of_neZero N
+  have hALG : Algebra.IsAlgebraic (IntermediateField.adjoin 𝕂 ({(jB N : 𝔽)} : Set 𝔽)) 𝔽 :=
+    Algebra.IsAlgebraic.of_finite _ _
+  have hPD : HasPrincipalDivisors 𝕂 𝔽 := IsCurveOver.hasPrincipalDivisors
+  set J : 𝔽 := jB N with hJdef
+  set ψ : ℕ := dedekindPsi N with hψdef
+  have hψpos : 0 < ψ := ModularCurve.dedekindPsi_pos N (NeZero.ne N)
+  have hJ0 : J ≠ 0 := jB_ne_zero N
+  by_cases hx0 : x = 0
+  · subst hx0
+    refine ⟨?_, ?_⟩
+    · rw [zero_pow (by norm_num), zero_mul, zero_mul]; exact isIntegral_zero
+    · rw [zero_pow (by omega), zero_mul, zero_mul]; exact isIntegral_zero
+  have hreg : ∀ v : Place 𝕂 𝔽, 0 ≤ v.ordDiff (x • D 𝕂 𝔽 J) := by
+    have h1 : x • D 𝕂 𝔽 J ∈ regularDiffs 𝕂 𝔽 := by
+      rw [AlgebraicCurve.regularDiffs_eq_regularDifferentials]; exact hx
+    exact (AlgebraicCurve.mem_regularDiffs_iff (J : 𝔽) _).mp h1
+  obtain ⟨Dv, hDv, -⟩ := HasPrincipalDivisors.exists_divisor (K := 𝕂) (F := 𝔽) J hJ0
+  let S : Finset (Place 𝕂 𝔽) := Dv.support.filter (fun v => v.ord J < 0)
+  have hS : ∀ v, v ∈ S ↔ v.ord J < 0 := by
+    intro v
+    simp only [S, Finset.mem_filter, Finsupp.mem_support_iff, and_iff_right_iff_imp]
+    intro hv
+    rw [hDv v]
+    exact hv.ne
+  have hsum : ∑ v ∈ S, -v.ord J = (ψ : ℤ) := by
+    have := ModularCurve.sum_neg_ord_jBar_eq_dedekindPsi N S hS
+    exact_mod_cast this
+  have hwidth : ∀ v : Place 𝕂 𝔽, v.ord J < 0 → -v.ord J ≤ (ψ : ℤ) := by
+    intro v hv
+    rw [← hsum]
+    exact Finset.single_le_sum (f := fun w => -w.ord J)
+      (fun w hw => by have := (hS w).mp hw; change (0 : ℤ) ≤ -w.ord J; omega) ((hS v).mpr hv)
+  have hpole : ∃ v₀ : Place 𝕂 𝔽, v₀.ord J < 0 := by
+    by_contra hno
+    push Not at hno
+    have hSe : S = ∅ := by
+      ext v
+      simp only [Finset.notMem_empty, iff_false]
+      intro hv
+      exact absurd ((hS v).mp hv) (not_lt.mpr (hno v))
+    rw [hSe, Finset.sum_empty] at hsum
+    have h' : (ψ : ℤ) = 0 := hsum.symm
+    omega
+  obtain ⟨v₀, hv₀⟩ := hpole
+  have htr : Transcendental 𝕂 J := by
+    intro halg
+    have hint : IsIntegral 𝕂 J := halg.isIntegral
+    have hint' : IsIntegral v₀.toValuationSubring J := hint.tower_top
+    have hmem : J ∈ v₀.toValuationSubring := by
+      obtain ⟨y, hy⟩ :=
+        (IsIntegrallyClosed.isIntegral_iff (R := v₀.toValuationSubring) (K := 𝔽)).mp hint'
+      rw [← hy]
+      exact y.2
+    have := v₀.ord_nonneg_of_mem hmem
+    omega
+  have hJne1728 : J - algebraMap 𝕂 𝔽 1728 ≠ 0 := by
+    intro h
+    rw [sub_eq_zero] at h
+    have := ord_algebraMap v₀ (c := (1728 : 𝕂))
+    rw [← h] at this
+    omega
+  have h1728_0 : v₀.ord (algebraMap 𝕂 𝔽 1728) = 0 := ord_algebraMap v₀
+  have hordJsub_of_pos : ∀ v : Place 𝕂 𝔽, 0 < v.ord J → v.ord (J - algebraMap 𝕂 𝔽 1728) = 0 := by
+    intro v hv
+    have hc : v.ord (-(algebraMap 𝕂 𝔽 1728)) = 0 := by rw [ord_neg]; exact ord_algebraMap v
+    have := v.ord_add_eq_of_lt (f := -(algebraMap 𝕂 𝔽 1728)) (g := J)
+      (neg_ne_zero.mpr (by rw [Ne, map_eq_zero]; norm_num)) hJ0 (by rw [hc]; exact hv)
+    rw [hc] at this
+    rwa [sub_eq_add_neg, add_comm]
+  have hordJsub_of_neg : ∀ v : Place 𝕂 𝔽, v.ord J < 0 → v.ord (J - algebraMap 𝕂 𝔽 1728) = v.ord J :=
+    by
+    intro v hv
+    have hc : v.ord (-(algebraMap 𝕂 𝔽 1728)) = 0 := by rw [ord_neg]; exact ord_algebraMap v
+    have := v.ord_add_eq_of_lt (f := J) (g := -(algebraMap 𝕂 𝔽 1728)) hJ0
+      (neg_ne_zero.mpr (by rw [Ne, map_eq_zero]; norm_num)) (by rw [hc]; exact hv)
+    rwa [← sub_eq_add_neg] at this
+  have hordJ_of_sub_pos : ∀ (v : Place 𝕂 𝔽) (c : 𝕂), c ≠ 0 → 0 < v.ord (J - algebraMap 𝕂 𝔽 c) →
+      v.ord J = 0 := by
+    intro v c hc hv
+    have h1 : v.ord (algebraMap 𝕂 𝔽 c) = 0 := ord_algebraMap v
+    have hne : J - algebraMap 𝕂 𝔽 c ≠ 0 := by
+      intro h; rw [h, v.ord_zero] at hv; exact lt_irrefl _ hv
+    have := v.ord_add_eq_of_lt (f := algebraMap 𝕂 𝔽 c) (g := J - algebraMap 𝕂 𝔽 c)
+      (by rw [Ne, map_eq_zero]; exact hc) hne (by rw [h1]; exact hv)
+    rw [h1, add_sub_cancel] at this
+    exact this
+  have hDsub : ∀ c : 𝕂, D 𝕂 𝔽 (J - algebraMap 𝕂 𝔽 c) = D 𝕂 𝔽 J := by
+    intro c
+    rw [map_sub, Derivation.map_algebraMap, sub_zero]
+  have hfinite : ∀ v : Place 𝕂 𝔽, v.ord J = 0 →
+      (0 ≤ v.ord x ∧ v.ord (J - algebraMap 𝕂 𝔽 1728) = 0) ∨
+      (∃ a : ℤ, 0 < a ∧ a ≤ 2 ∧ v.ord (J - algebraMap 𝕂 𝔽 1728) = a ∧ 1 - a ≤ v.ord x) := by
+    intro v hvJ
+    have hJmem : J ∈ v.toValuationSubring := by rw [v.mem_iff_ord_nonneg hJ0, hvJ]
+    obtain ⟨c, hc⟩ := exists_value v hJmem
+    have hcpos : 0 < v.ord (J - algebraMap 𝕂 𝔽 c) := by
+      rcases hc with hc | hc
+      · exfalso
+        rw [sub_eq_zero] at hc
+        have := ord_algebraMap v₀ (c := c)
+        rw [← hc] at this
+        omega
+      · exact hc
+    have hc0 : c ≠ 0 := by
+      rintro rfl
+      rw [map_zero, sub_zero] at hcpos
+      omega
+    by_cases hc1728 : c = 1728
+    · subst hc1728
+      right
+      refine ⟨v.ord (J - algebraMap 𝕂 𝔽 1728), hcpos, ?_, rfl, ?_⟩
+      · have hd := ModularCurve.ord_jBar_sub_1728_dvd_two N v hcpos
+        exact Int.le_of_dvd (by norm_num) hd
+      · exact ord_bound N x hx0 hreg v hcpos.ne' (hDsub 1728)
+    · left
+      have h1 : v.ord (J - algebraMap 𝕂 𝔽 c) = 1 :=
+        ModularCurve.ord_jBar_sub_eq_one_of_ne_zero_of_ne N v c hc0 hc1728 hcpos
+      have hb :=
+        ord_bound N x hx0 hreg v (g := J - algebraMap 𝕂 𝔽 c) (by rw [h1]; norm_num) (hDsub c)
+      rw [h1] at hb
+      refine ⟨by omega, ?_⟩
+      have hcc : v.ord (algebraMap 𝕂 𝔽 (c - 1728)) = 0 := ord_algebraMap v
+      have := v.ord_add_eq_of_lt (f := algebraMap 𝕂 𝔽 (c - 1728)) (g := J - algebraMap 𝕂 𝔽 c)
+        (by rw [Ne, map_eq_zero]; exact sub_ne_zero.mpr hc1728)
+        (by intro h; rw [h,
+          v.ord_zero] at hcpos; exact lt_irrefl _ hcpos) (by rw [hcc]; exact hcpos)
+      rw [hcc] at this
+      rw [← this, map_sub]
+      congr 1
+      ring
+  refine ⟨?_, ?_⟩
+  · refine AlgebraicCurve.isIntegral_adjoin_of_forall_ord_nonneg (K := 𝕂) (F := 𝔽) J _ ?_
+    intro v hvJ
+    have hne : x ^ 6 * J ^ 4 * (J - algebraMap 𝕂 𝔽 1728) ^ 3 ≠ 0 :=
+      mul_ne_zero (mul_ne_zero (pow_ne_zero _ hx0) (pow_ne_zero _ hJ0)) (pow_ne_zero _ hJne1728)
+    rw [v.ord_mul (mul_ne_zero (pow_ne_zero _ hx0) (pow_ne_zero _ hJ0)) (pow_ne_zero _ hJne1728),
+      v.ord_mul (pow_ne_zero _ hx0) (pow_ne_zero _ hJ0), ord_pow', ord_pow', ord_pow']
+    rcases hvJ.lt_or_eq with hpos | hzero
+    · have hd := ModularCurve.ord_jBar_dvd_three N v hpos
+      have ha3 : v.ord J ≤ 3 := Int.le_of_dvd (by norm_num) hd
+      have hb := ord_bound N x hx0 hreg v hpos.ne' rfl
+      rw [hordJsub_of_pos v hpos]
+      push_cast
+      nlinarith
+    · rcases hfinite v hzero.symm with ⟨hx', h1728'⟩ | ⟨a, ha0, ha2, h1728', hb⟩
+      · rw [← hzero, h1728']; push_cast; nlinarith
+      · rw [← hzero, h1728']; push_cast; nlinarith
+  · have htr' : Transcendental 𝕂 J⁻¹ := by
+      intro halg
+      exact htr (by simpa using halg.inv)
+    have hadj : IntermediateField.adjoin 𝕂 ({J⁻¹} : Set 𝔽) = IntermediateField.adjoin 𝕂 ({J} : Set
+      𝔽) :=
+      by
+      apply le_antisymm
+      · rw [IntermediateField.adjoin_simple_le_iff]
+        exact inv_mem (IntermediateField.mem_adjoin_simple_self 𝕂 J)
+      · rw [IntermediateField.adjoin_simple_le_iff]
+        have h1 := IntermediateField.mem_adjoin_simple_self 𝕂 (J⁻¹)
+        have h2 : (J⁻¹)⁻¹ ∈ IntermediateField.adjoin 𝕂 ({J⁻¹} : Set 𝔽) := inv_mem h1
+        rwa [inv_inv] at h2
+    have : FiniteDimensional (IntermediateField.adjoin 𝕂 ({J⁻¹} : Set 𝔽)) 𝔽 := by
+      rw [hadj]; exact hFD
+    refine AlgebraicCurve.isIntegral_adjoin_of_forall_ord_nonneg (K := 𝕂) (F := 𝔽) J⁻¹ _ ?_
+    intro v hvJinv
+    rw [v.ord_inv] at hvJinv
+    have hvJ : v.ord J ≤ 0 := by omega
+    rw [v.ord_mul (mul_ne_zero (pow_ne_zero _ hx0) (pow_ne_zero _ hJ0)) (pow_ne_zero _ hJne1728),
+      v.ord_mul (pow_ne_zero _ hx0) (pow_ne_zero _ hJ0), ord_pow', ord_pow', ord_pow']
+    rcases hvJ.lt_or_eq with hneg | hzero
+    · have hw := hwidth v hneg
+      have hb := ord_bound N x hx0 hreg v hneg.ne rfl
+      rw [hordJsub_of_neg v hneg]
+      push_cast
+      nlinarith
+    · rcases hfinite v hzero with ⟨hx', h1728'⟩ | ⟨a, ha0, ha2, h1728', hb⟩
+      · rw [hzero, h1728']; push_cast; nlinarith
+      · rw [hzero, h1728']; push_cast; nlinarith
+
+end ALGGlue
+
+theorem solution (N : ℕ) [NeZero N]
+    (x : ModularCurve.modularFunctionFieldBar N)
+    (hx : x • KaehlerDifferential.D (AlgebraicClosure ℚ) (ModularCurve.modularFunctionFieldBar N)
+        (⟨ModularCurve.coeffEmb (AlgebraicClosure ℚ) ModularCurve.jq,
+          ModularCurve.coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.modularFunctionField_le_full N (ModularCurve.jq_mem N))⟩ :
+          ModularCurve.modularFunctionFieldBar N) ∈ ModularCurve.regularDifferentialsBar N) :
+    IsIntegral (Algebra.adjoin (AlgebraicClosure ℚ) ({(⟨ModularCurve.coeffEmb (AlgebraicClosure ℚ)
+      ModularCurve.jq, ModularCurve.coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+      (ModularCurve.modularFunctionField_le_full N (ModularCurve.jq_mem N))⟩ :
+      ModularCurve.modularFunctionFieldBar N)} : Set (ModularCurve.modularFunctionFieldBar N)))
+        (x ^ 6 * (⟨ModularCurve.coeffEmb (AlgebraicClosure ℚ) ModularCurve.jq,
+          ModularCurve.coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.modularFunctionField_le_full N (ModularCurve.jq_mem N))⟩ :
+          ModularCurve.modularFunctionFieldBar N) ^ 4 * ((⟨ModularCurve.coeffEmb (AlgebraicClosure
+          ℚ) ModularCurve.jq, ModularCurve.coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.modularFunctionField_le_full N (ModularCurve.jq_mem N))⟩ :
+          ModularCurve.modularFunctionFieldBar N) - algebraMap (AlgebraicClosure ℚ)
+          (ModularCurve.modularFunctionFieldBar N) 1728) ^ 3) ∧
+      IsIntegral (Algebra.adjoin (AlgebraicClosure ℚ) ({(⟨ModularCurve.coeffEmb (AlgebraicClosure ℚ)
+        ModularCurve.jq, ModularCurve.coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+        (ModularCurve.modularFunctionField_le_full N (ModularCurve.jq_mem N))⟩ :
+        ModularCurve.modularFunctionFieldBar N)⁻¹} : Set (ModularCurve.modularFunctionFieldBar N)))
+        (x ^ (2 * ModularCurve.dedekindPsi N) * (⟨ModularCurve.coeffEmb (AlgebraicClosure ℚ)
+          ModularCurve.jq, ModularCurve.coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.modularFunctionField_le_full N (ModularCurve.jq_mem N))⟩ :
+          ModularCurve.modularFunctionFieldBar N) ^ (ModularCurve.dedekindPsi N + 1) *
+          ((⟨ModularCurve.coeffEmb (AlgebraicClosure ℚ) ModularCurve.jq,
+            ModularCurve.coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+            (ModularCurve.modularFunctionField_le_full N (ModularCurve.jq_mem N))⟩ :
+            ModularCurve.modularFunctionFieldBar N) - algebraMap (AlgebraicClosure ℚ)
+            (ModularCurve.modularFunctionFieldBar N) 1728) ^ ModularCurve.dedekindPsi N) :=
+  ALGGlue.main N x hx
+
+end
+
+end S_ModularCurve_isIntegral_and_isIntegral_of_smul_D_mem_regularDifferentialsBar
+end P2MW
+export P2MW.S_ModularCurve_isIntegral_and_isIntegral_of_smul_D_mem_regularDifferentialsBar
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.isIntegral_and_isIntegral_of_smul_D_mem_regularDifferentialsBar (N : ℕ)
+    [NeZero N]
+    (x : ModularCurve.modularFunctionFieldBar N)
+    (hx : x • KaehlerDifferential.D (AlgebraicClosure ℚ) (ModularCurve.modularFunctionFieldBar N)
+        (⟨ModularCurve.coeffEmb (AlgebraicClosure ℚ) ModularCurve.jq,
+          ModularCurve.coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.modularFunctionField_le_full N (ModularCurve.jq_mem N))⟩ :
+          ModularCurve.modularFunctionFieldBar N) ∈ ModularCurve.regularDifferentialsBar N) :
+    IsIntegral (Algebra.adjoin (AlgebraicClosure ℚ) ({(⟨ModularCurve.coeffEmb (AlgebraicClosure ℚ)
+      ModularCurve.jq, ModularCurve.coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+      (ModularCurve.modularFunctionField_le_full N (ModularCurve.jq_mem N))⟩ :
+      ModularCurve.modularFunctionFieldBar N)} : Set (ModularCurve.modularFunctionFieldBar N)))
+        (x ^ 6 * (⟨ModularCurve.coeffEmb (AlgebraicClosure ℚ) ModularCurve.jq,
+          ModularCurve.coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.modularFunctionField_le_full N (ModularCurve.jq_mem N))⟩ :
+          ModularCurve.modularFunctionFieldBar N) ^ 4 * ((⟨ModularCurve.coeffEmb (AlgebraicClosure
+          ℚ) ModularCurve.jq, ModularCurve.coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.modularFunctionField_le_full N (ModularCurve.jq_mem N))⟩ :
+          ModularCurve.modularFunctionFieldBar N) - algebraMap (AlgebraicClosure ℚ)
+          (ModularCurve.modularFunctionFieldBar N) 1728) ^ 3) ∧
+      IsIntegral (Algebra.adjoin (AlgebraicClosure ℚ) ({(⟨ModularCurve.coeffEmb (AlgebraicClosure ℚ)
+        ModularCurve.jq, ModularCurve.coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+        (ModularCurve.modularFunctionField_le_full N (ModularCurve.jq_mem N))⟩ :
+        ModularCurve.modularFunctionFieldBar N)⁻¹} : Set (ModularCurve.modularFunctionFieldBar N)))
+        (x ^ (2 * ModularCurve.dedekindPsi N) * (⟨ModularCurve.coeffEmb (AlgebraicClosure ℚ)
+          ModularCurve.jq, ModularCurve.coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.modularFunctionField_le_full N (ModularCurve.jq_mem N))⟩ :
+          ModularCurve.modularFunctionFieldBar N) ^ (ModularCurve.dedekindPsi N + 1) *
+          ((⟨ModularCurve.coeffEmb (AlgebraicClosure ℚ) ModularCurve.jq,
+            ModularCurve.coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+            (ModularCurve.modularFunctionField_le_full N (ModularCurve.jq_mem N))⟩ :
+            ModularCurve.modularFunctionFieldBar N) - algebraMap (AlgebraicClosure ℚ)
+            (ModularCurve.modularFunctionFieldBar N) 1728) ^ ModularCurve.dedekindPsi N) :=
+  solution N x hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_jqNModC_all.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_jqNModC_all.lean
new file mode 100644
index 0000000000..b57ba6ee89
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_jqNModC_all.lean
@@ -0,0 +1,82 @@
+/-
+Based on Prove2Me node ModularCurve.isIntegral_jqNModC_all
+(7b602140-edbb-5016-8c95-50c78314d067) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2514932a-9210-58ac-b027-81358136b2f5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_jqNModC_all_of_modularPolynomialFamily
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularPolynomialFamily
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality of ̄ j(q^N) over K(̄ j(q))
+
+Theorem statement: `ModularCurve.isIntegral_jqNModC_all` (`7b602140-edbb-5016-8c95-50c78314d067`),
+by Claude, 2026-09-05.
+
+Proof: submission `2514932a-9210-58ac-b027-81358136b2f5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $N$ be a natural number with $N \neq 0$. Inside the field of Laurent
+series $K((q))$ (`LaurentSeries K`, Hahn series over $K$ with integer exponents) consider the
+element $\bar j =$ `jqModC K`, defined as the monomial $q^{-1}$ times the image in $K[[q]]$ of the
+integral power series `jNum` $=$ `eisenstein4`$^3 \cdot$ `dedekindEtaUnitInv` under the
+coefficientwise map $\mathbb{Z} \to K$; this is the $q$-expansion of the modular invariant $j$ read
+in $K$. Let $\bar j_N =$ `jqNModC K N` be its image under `qExpand K N`, the ring homomorphism of
+$K((q))$ obtained by pushing exponents forward along multiplication by $N$ on $\mathbb{Z}$, that is,
+the substitution $q \mapsto q^N$. The assertion is that $\bar j_N$ is integral over the intermediate
+field `IntermediateField.adjoin K {jqModC K}` of $K((q))$, i.e. over $K(\bar j)$: it satisfies a
+monic polynomial equation with coefficients in $K(\bar j)$. No hypothesis on $K$ (characteristic,
+size) or on $N$ beyond $N \neq 0$ is imposed.
+
+This is the $q$-expansion form, valid over an arbitrary field of coefficients, of the classical
+integrality of $j(N\tau)$ over $\mathbb{Z}[j(\tau)]$ furnished by the modular polynomial $\Phi_N$.
+It is the unconditional input to the construction of models of the modular curves $X_0(N)$ and their
+Hecke correspondences used later, and is cited throughout the work on place specialisations and
+prolongation tuples.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_isIntegral_jqNModC_all.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_isIntegral_jqNModC_all
+
+open ModularCurve
+
+theorem solution (K : Type*) [Field K] (N : ℕ) [NeZero N] :
+    IsIntegral (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) (jqNModC K N) :=
+  isIntegral_jqNModC_all_of_modularPolynomialFamily K modularPolynomialFamily N
+
+end S_ModularCurve_isIntegral_jqNModC_all
+end P2MW
+export P2MW.S_ModularCurve_isIntegral_jqNModC_all (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.isIntegral_jqNModC_all (K : Type*) [Field K] (N : ℕ) [NeZero N] :
+    IsIntegral (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) (jqNModC K N) :=
+  solution K N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_jqNModC_all_of_modularPolynomialFamily.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_jqNModC_all_of_modularPolynomialFamily.lean
new file mode 100644
index 0000000000..8cc148f946
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_jqNModC_all_of_modularPolynomialFamily.lean
@@ -0,0 +1,155 @@
+/-
+Based on Prove2Me node ModularCurve.isIntegral_jqNModC_all_of_modularPolynomialFamily
+(c459801e-9abd-5df6-a5d9-10ab816f97aa) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 598effe4-7604-5a3a-a963-fcc64b10e571
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_jqNModC_mul
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality of j(q^N) over K(j(q)) at all levels
+
+Theorem statement: `ModularCurve.isIntegral_jqNModC_all_of_modularPolynomialFamily`
+(`c459801e-9abd-5df6-a5d9-10ab816f97aa`), by Claude, 2026-09-05.
+
+Proof: submission `598effe4-7604-5a3a-a963-fcc64b10e571`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $N\ge 1$ be a natural number (given by a `NeZero` hypothesis). Inside the
+Laurent series field `LaurentSeries K`, write $\bar\jmath =$ `jqModC K` for the Hahn series
+$q^{-1}\cdot\mathrm{ofPowerSeries}(\mathtt{jNum})$, where `jNum` $=$
+`eisenstein4`$^3\cdot$`dedekindEtaUnitInv` is the integral power series whose coefficients are
+mapped into $K$; thus $\bar\jmath$ is the $q$-expansion of the $j$-invariant with coefficients in
+$K$. For $N\ge 1$, `jqNModC K N` is the image of $\bar\jmath$ under the ring homomorphism `qExpand K
+N`, which multiplies all exponents of a Laurent series by $N$, i.e. substitutes $q\mapsto q^N$. The
+hypothesis `ModularPolynomialFamily` asserts that for every prime $\ell$ there exist a monic
+polynomial $\Phi\in\mathbb{Z}[X][Y]$ of degree `dedekindPsi` $\ell$ in $Y$ satisfying the vanishing
+relation `Φ.eval₂ evalAtJ (jqN ℓ) = 0` on $q$-expansions (the data packaged by
+`ModularPolynomialData ℓ`), together with the symmetry property `EvalSymm Φ`, namely
+$\Phi(x,y)=\Phi(y,x)$ for all $x,y$ in `LaurentSeries ℚ`. The conclusion is that `jqNModC K N` is
+integral over the intermediate field `IntermediateField.adjoin K {jqModC K}` of $K((q))$ generated
+by $\bar\jmath$ over $K$. The proof uses only the existence of the data at each prime, not the
+symmetry clause `EvalSymm`.
+
+This is the $q$-expansion form of the classical fact that $j(N\tau)$ is integral (indeed algebraic)
+over the ring generated by $j(\tau)$, here deduced at all levels from the prime-level modular
+equations taken as a hypothesis. It supplies the finiteness input for the modular function fields at
+composite level, and is used for
+[`ModularCurve.isIntegral_jqNModC_all`](thm.html#ModularCurve.isIntegral_jqNModC_all) and for the
+construction of principal divisors on the Laurent base change of the full modular function field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_isIntegral_jqNModC_all_of_modularPolynomialFamily.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_isIntegral_jqNModC_all_of_modularPolynomialFamily
+
+noncomputable section
+open IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC jqNModC qExpand_one_apply ModularPolynomialData \
+  ModularPolynomialFamily isIntegral_jqNModC_mul"
+p2m_open "ModularCurve"
+namespace AllLevels
+
+variable (K : Type*) [Field K]
+
+local notation "L" => LaurentSeries K
+local notation "F₀" => IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))
+
+theorem step {ℓ : ℕ} [NeZero ℓ] (data : ModularPolynomialData ℓ) (d : ℕ) [NeZero d]
+    (hd : IsIntegral F₀ (jqNModC K d)) : IsIntegral F₀ (jqNModC K (d * ℓ)) := by
+  set E : IntermediateField F₀ L := IntermediateField.adjoin F₀ ({jqNModC K d} : Set L) with hE
+  have : FiniteDimensional F₀ E := IntermediateField.adjoin.finiteDimensional hd
+  have hmem : jqNModC K d ∈ E.restrictScalars K := by
+    rw [IntermediateField.mem_restrictScalars]; exact IntermediateField.mem_adjoin_simple_self _ _
+  have h1 : IsIntegral (E.restrictScalars K) (jqNModC K (d * ℓ)) :=
+    isIntegral_jqNModC_mul _ data d hmem
+  have h2 : IsIntegral E (jqNModC K (d * ℓ)) := h1
+  have : Algebra.IsIntegral F₀ E := Algebra.IsIntegral.of_finite F₀ E
+  exact isIntegral_trans _ h2
+
+theorem base : IsIntegral F₀ (jqModC K) :=
+  isIntegral_algebraMap (x := (⟨jqModC K, mem_adjoin_simple_self K (jqModC K)⟩ : F₀))
+
+theorem jqNModC_congr {M N : ℕ} [NeZero M] [NeZero N] (h : M = N) : jqNModC K M = jqNModC K N := by
+  subst h; rfl
+
+theorem isIntegral_jqNModC_all (hΦ : ModularPolynomialFamily) :
+    ∀ (N : ℕ) [NeZero N], IsIntegral F₀ (jqNModC K N) := by
+  intro N
+  induction N using Nat.strong_induction_on with
+  | _ N ih =>
+  intro hN
+  rcases le_or_gt N 1 with hle | hlt
+  · obtain rfl : N = 1 := le_antisymm hle (Nat.one_le_iff_ne_zero.mpr (NeZero.ne N))
+    rw [show jqNModC K 1 = jqModC K from qExpand_one_apply _]
+    exact base K
+  · have hp : N.minFac.Prime := Nat.minFac_prime (by omega)
+    obtain ⟨d, hd⟩ := Nat.minFac_dvd N
+    have hd0 : d ≠ 0 := by
+      rintro rfl
+      rw [mul_zero] at hd
+      exact absurd hd (by omega)
+    have : NeZero d := ⟨hd0⟩
+    have : NeZero N.minFac := ⟨hp.ne_zero⟩
+    have hN' : N = d * N.minFac := hd.trans (mul_comm _ _)
+    have hdlt : d < N := by
+      have h2 : 2 ≤ N.minFac := hp.two_le
+      have : d * 2 ≤ d * N.minFac := Nat.mul_le_mul_left d h2
+      omega
+    obtain ⟨data, -⟩ := hΦ N.minFac hp
+    have hstepd : IsIntegral F₀ (jqNModC K (d * N.minFac)) := step K data d (ih d hdlt)
+    rwa [jqNModC_congr K hN']
+
+end AllLevels
+
+end ModularCurve
+
+p2m_open "ModularCurve \
+  P2MW.S_ModularCurve_isIntegral_jqNModC_all_of_modularPolynomialFamily.ModularCurve"
+
+theorem solution (K : Type*) [Field K] (hΦ : ModularPolynomialFamily)
+    (N : ℕ) [NeZero N] :
+    IsIntegral (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) (jqNModC K N) :=
+  ModularCurve.AllLevels.isIntegral_jqNModC_all K hΦ N
+
+end
+
+end S_ModularCurve_isIntegral_jqNModC_all_of_modularPolynomialFamily
+end P2MW
+export P2MW.S_ModularCurve_isIntegral_jqNModC_all_of_modularPolynomialFamily (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.isIntegral_jqNModC_all_of_modularPolynomialFamily (K : Type*) [Field K]
+    (hΦ : ModularPolynomialFamily)
+    (N : ℕ) [NeZero N] :
+    IsIntegral (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) (jqNModC K N) :=
+  solution K hΦ N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_jqNModC_mul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_jqNModC_mul.lean
new file mode 100644
index 0000000000..b5950531f9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_jqNModC_mul.lean
@@ -0,0 +1,101 @@
+/-
+Based on Prove2Me node ModularCurve.isIntegral_jqNModC_mul
+(96f96f04-8e46-51b3-a977-a0fcc82d4859) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 69d9ec3f-d995-5184-b1f0-86051bdc2692
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_mul_eq_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality of j(q^{dℓ}) over fields containing j(qᵈ)
+
+Theorem statement: `ModularCurve.isIntegral_jqNModC_mul` (`96f96f04-8e46-51b3-a977-a0fcc82d4859`),
+by Claude, 2026-09-05.
+
+Proof: submission `69d9ec3f-d995-5184-b1f0-86051bdc2692`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $F$ be an intermediate field of the extension $K((q))/K$, where $K((q))$
+is the field `LaurentSeries K` of formal Laurent series. Let $\ell$ and $d$ be nonzero natural
+numbers, and let `data` be a modular-polynomial datum of level $\ell$: a polynomial $\Phi \in
+(\mathbb{Z}[X])[Y]$ which is monic in $Y$, whose degree in $Y$ equals the Dedekind $\psi$-value
+$\sum_{e \mid \ell,\ e\ \text{squarefree}} \ell/e$, and which satisfies $\Phi(j(q), j(q^{\ell})) =
+0$ in $\mathbb{Q}((q))$, the substitution of $j(q)$ for $X$ being `evalAtJ` and $j(q^{\ell})$ the
+series `jqN ℓ`. Here, for a nonzero natural number $N$, the element `jqNModC K N` of $K((q))$ is
+obtained from the $q$-expansion $q^{-1}\cdot(\text{numerator series of } j)$ with coefficients
+reduced into $K$ by substituting $q \mapsto q^{N}$, i.e. by the ring embedding `qExpand` which
+multiplies all exponents by $N$. Assume `jqNModC K d` lies in $F$. Then `jqNModC K (d * ℓ)` is
+integral over $F$.
+
+This is the classical statement that $j(q^{d\ell})$ satisfies a monic equation over any field of
+Laurent series containing $j(q^{d})$, obtained from the modular equation $\Phi_{\ell}(X,Y)$ being
+monic in $Y$. It is one of the integrality inputs for the degeneracy maps used in the construction
+of the Hecke correspondence, and is cited in the finiteness and field-degree statements for the
+relevant adjunctions of $q$-expansions, such as
+[`ModularCurve.finiteAlong_heckeAlphaBar_of_modularPolynomialData`]
+(thm.html#ModularCurve.finiteAlong_heckeAlphaBar_of_modularPolynomialData)
+and
+[`ModularCurve.finrank_adjoin_jqNModC_igusaFunctionFieldX1C_eq`]
+(thm.html#ModularCurve.finrank_adjoin_jqNModC_igusaFunctionFieldX1C_eq).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_isIntegral_jqNModC_mul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_isIntegral_jqNModC_mul
+
+open ModularCurve IntermediateField Polynomial
+
+private theorem isIntegral_of_eval₂_eq_zero {L : Type*} [Field L]
+    (F : IntermediateField L (LaurentSeries L))
+    {Φ : Polynomial (Polynomial ℤ)} (hΦ : Φ.Monic) {a b : LaurentSeries L} (ha : a ∈ F)
+    (h : Φ.eval₂ (aeval (R := ℤ) a).toRingHom b = 0) : IsIntegral F b := by
+  set ev : Polynomial ℤ →+* F := (aeval (R := ℤ) (⟨a, ha⟩ : F)).toRingHom with hev
+  have hcomp : (algebraMap F (LaurentSeries L)).comp ev = (aeval (R := ℤ) a).toRingHom := by
+    refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+    simp [hev]
+  refine ⟨Φ.map ev, hΦ.map ev, ?_⟩
+  rw [Polynomial.eval₂_map, hcomp]
+  exact h
+
+theorem solution {K : Type*} [Field K] (F : IntermediateField K (LaurentSeries K)) {ℓ : ℕ}
+    [NeZero ℓ] (data : ModularCurve.ModularPolynomialData ℓ) (d : ℕ) [NeZero d]
+    (hd : ModularCurve.jqNModC K d ∈ F) :
+    IsIntegral F (ModularCurve.jqNModC K (d * ℓ)) :=
+  isIntegral_of_eval₂_eq_zero F data.monic hd (data.eval_jqNModC_mul_eq_zero K d)
+
+end S_ModularCurve_isIntegral_jqNModC_mul
+end P2MW
+export P2MW.S_ModularCurve_isIntegral_jqNModC_mul (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.isIntegral_jqNModC_mul {K : Type*} [Field K]
+    (F : IntermediateField K (LaurentSeries K)) {ℓ : ℕ} [NeZero ℓ]
+    (data : ModularCurve.ModularPolynomialData ℓ) (d : ℕ) [NeZero d]
+    (hd : ModularCurve.jqNModC K d ∈ F) :
+    IsIntegral F (ModularCurve.jqNModC K (d * ℓ)) :=
+  solution F data d hd
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_jqNModC_of_modularPolynomialData.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_jqNModC_of_modularPolynomialData.lean
new file mode 100644
index 0000000000..4eb16ce69e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isIntegral_jqNModC_of_modularPolynomialData.lean
@@ -0,0 +1,348 @@
+/-
+Based on Prove2Me node ModularCurve.isIntegral_jqNModC_of_modularPolynomialData
+(304132bd-0186-56a2-ab84-233c89872e13) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 57c215e0-6b47-59e6-8771-8b6a898b15fe
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_neg_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.Algebra.Polynomial.Bivariate
+import Mathlib.FieldTheory.Separable
+import Mathlib.RingTheory.RootsOfUnity.AlgebraicallyClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality of ̄ j(q^N) over K(̄ j(q))
+
+Theorem statement: `ModularCurve.isIntegral_jqNModC_of_modularPolynomialData`
+(`304132bd-0186-56a2-ab84-233c89872e13`), by Claude, 2026-09-05.
+
+Proof: submission `57c215e0-6b47-59e6-8771-8b6a898b15fe`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, let $N$ be a natural number that is nonzero, and let `data` be a
+modular-polynomial datum of level $N$: a polynomial $\Phi \in \mathbb{Z}[X][Y]$ which is monic as a
+polynomial in $Y$, whose degree in $Y$ equals $\psi(N) = \sum_{d \mid N,\ d \text{ squarefree}}
+N/d$, and which satisfies $\Phi(j(q), j(q^N)) = 0$ in $\mathbb{Q}((q))$, the substitution of $j(q)$
+for $X$ in the coefficients being the ring homomorphism $\mathbb{Z}[X] \to \mathbb{Q}((q))$ given by
+`evalAtJ`. Here $\bar j(q) =$ `jqModC K` is the Laurent series $q^{-1}$ times the image in $K[[q]]$
+of the integral power series $E_4^3 \eta^{-24}$ under the coefficientwise map $\mathbb{Z} \to K$,
+and $\bar j(q^N) =$ `jqNModC K N` is its image under `qExpand K N`, the ring endomorphism of
+$K((q))$ multiplying all exponents by $N$, that is, the substitution $q \mapsto q^N$. The conclusion
+is that $\bar j(q^N)$ is integral over the intermediate field of $K((q))$ over $K$ generated by
+$\bar j(q)$, namely $K(\bar j(q))$.
+
+This is the integrality half of the classical statement that $\bar j(q^N)$ generates a finite
+extension of $K(\bar j(q))$ inside $K((q))$, obtained by transferring the modular equation
+$\Phi_N(j(q), j(q^N)) = 0$ from characteristic zero to an arbitrary field $K$ along the coefficient
+map $\mathbb{Z} \to K$ and using monicity in the second variable. It feeds the irreducibility and
+degree computations for $K(\bar j(q))(\bar j(q^N))$, in particular the statement that this extension
+has degree $\psi(N)$ in characteristic zero, and the construction of places attached to a vanishing
+modular polynomial.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_isIntegral_jqNModC_of_modularPolynomialData.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_isIntegral_jqNModC_of_modularPolynomialData
+
+noncomputable section
+open HahnSeries Polynomial IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC jqNModC jqModC_rat map_jqModC qExpand qExpand_coeff_of_not_dvd \
+  jq ModularPolynomialData qTwist qTwist_coeff qTwist_one_apply qTwist_qExpand evalAtJ_def \
+  EvalSymm coeffMap coeffMap_coeff coeffEmb coeff_jqModC_neg_one coeffMap_qExpand dedekindPsi_prime"
+p2m_open "ModularCurve"
+namespace SepFibre
+
+section eval
+variable {A B : Type*} [CommRing A] [CommRing B]
+
+def ev (Φ : Polynomial (Polynomial ℤ)) (x y : A) :
+    A := Φ.eval₂ (eval₂RingHom (Int.castRingHom A) x) y
+
+theorem aeval_toRingHom_eq [Algebra ℤ A] (x : A) :
+    (Polynomial.aeval (R := ℤ) x).toRingHom = eval₂RingHom (Int.castRingHom A) x :=
+  Polynomial.ringHom_ext' (RingHom.ext_int _ _) (by simp)
+
+theorem ev_eq_evalEval (Φ : Polynomial (Polynomial ℤ)) (x y : A) :
+    ev Φ x y = (Φ.map (mapRingHom (Int.castRingHom A))).evalEval x y := by
+  rw [ev, ← eval₂_eval₂RingHom_apply]
+
+theorem map_ev (φ : A →+* B) (Φ : Polynomial (Polynomial ℤ)) (x y : A) :
+    φ (ev Φ x y) = ev Φ (φ x) (φ y) := by
+  rw [ev_eq_evalEval, ev_eq_evalEval, ← map_mapRingHom_evalEval φ, Polynomial.map_map,
+    mapRingHom_comp,
+    RingHom.ext_int (φ.comp (Int.castRingHom A)) (Int.castRingHom B)]
+
+theorem ev_eq_aevalAeval (Φ : Polynomial (Polynomial ℤ)) (x y : A) :
+    ev Φ x y = aevalAeval x y Φ := by
+  have h : eval₂RingHom (eval₂RingHom (Int.castRingHom A) x) y = (aevalAeval (R := ℤ) x y).toRingHom
+    :=
+    by
+    refine Polynomial.ringHom_ext' (Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_) ?_
+    · simp
+    · simp
+  exact RingHom.congr_fun h Φ
+
+theorem ev_swap (Φ : Polynomial (Polynomial ℤ)) (x y : A) :
+    ev (Bivariate.swap Φ) x y = ev Φ y x := by
+  rw [ev_eq_aevalAeval, ev_eq_aevalAeval, Bivariate.aevalAeval_swap]
+
+theorem ev_int (Φ : Polynomial (Polynomial ℤ)) (a b : ℤ) : ev Φ a b = Φ.evalEval a b := by
+  rw [ev_eq_evalEval]
+  congr 1
+  have h : mapRingHom (Int.castRingHom ℤ) = RingHom.id (Polynomial ℤ) := by
+    rw [RingHom.ext_int (Int.castRingHom ℤ) (RingHom.id ℤ)]; exact mapRingHom_id
+  rw [h]; exact Polynomial.map_id
+
+theorem ev_sub (Φ Ψ : Polynomial (Polynomial ℤ)) (x y : A) :
+    ev (Φ - Ψ) x y = ev Φ x y - ev Ψ x y := by
+  rw [ev_eq_aevalAeval, map_sub, ← ev_eq_aevalAeval, ← ev_eq_aevalAeval]
+
+end eval
+
+theorem swap_eq_of_evalSymm {Φ : Polynomial (Polynomial ℤ)} (h : EvalSymm Φ) :
+    Bivariate.swap Φ = Φ := by
+  set G : Polynomial (Polynomial ℤ) := Bivariate.swap Φ - Φ with hG
+  have hL : ∀ x y : LaurentSeries ℚ, ev G x y = 0 := fun x y => by
+    have hxy := h x y
+    rw [aeval_toRingHom_eq, aeval_toRingHom_eq] at hxy
+    rw [hG, ev_sub, ev_swap, sub_eq_zero]; exact hxy.symm
+  let ι : ℤ →+* LaurentSeries ℚ := (algebraMap ℚ (LaurentSeries ℚ)).comp (Int.castRingHom ℚ)
+  have hι : Function.Injective ι :=
+    (algebraMap ℚ (LaurentSeries ℚ)).injective.comp Int.cast_injective
+  have hZ : ∀ a b : ℤ, G.evalEval a b = 0 := fun a b => hι (by rw [← ev_int, map_ev, hL, map_zero])
+  have h1 : ∀ b : ℤ, G.eval (Polynomial.C b) = 0 := fun b =>
+    Polynomial.eq_zero_of_infinite_isRoot _ (Set.infinite_of_injective_forall_mem (f := fun a : ℤ =>
+      a)
+      (fun _ _ h => h) fun a => hZ a b)
+  have h2 : G = 0 :=
+    Polynomial.eq_zero_of_infinite_isRoot _ (Set.infinite_of_injective_forall_mem
+      (f := fun b : ℤ => Polynomial.C b) (fun _ _ h => Polynomial.C_injective h) fun b => h1 b)
+  exact sub_eq_zero.mp h2
+
+theorem ev_comm_of_evalSymm {Φ : Polynomial (Polynomial ℤ)} (h : EvalSymm Φ) {A : Type*}
+    [CommRing A] (x y : A) :
+    ev Φ x y = ev Φ y x := by
+  rw [← ev_swap, swap_eq_of_evalSymm h]
+
+section rel
+variable {N : ℕ} [NeZero N] (data : ModularPolynomialData N)
+
+theorem coeffMap_injective {R S : Type*} [CommRing R] [CommRing S] {f : R →+* S}
+    (hf : Function.Injective f) :
+    Function.Injective (coeffMap f) := fun x y h => by
+  ext k
+  exact hf (by rw [← coeffMap_coeff, ← coeffMap_coeff, h])
+
+theorem coeffMap_jqModC {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S) :
+    coeffMap f (jqModC R) = jqModC S :=
+  map_jqModC f
+
+theorem coeffMap_jqNModC {R S : Type*} [CommRing R] [CommRing S] (f : R →+* S) (N : ℕ) [NeZero N] :
+    coeffMap f (jqNModC R N) = jqNModC S N := by
+  rw [jqNModC, coeffMap_qExpand, coeffMap_jqModC, jqNModC]
+
+theorem ev_jq_int : ev data.Φ (jqModC ℤ) (jqNModC ℤ N) = 0 := by
+  apply coeffMap_injective (f := Int.castRingHom ℚ) Int.cast_injective
+  rw [map_ev, coeffMap_jqModC, coeffMap_jqNModC, map_zero, jqModC_rat, jqNModC, jqModC_rat]
+  have h0 := data.eval_eq_zero
+  rw [evalAtJ_def, aeval_toRingHom_eq] at h0
+  exact h0
+
+theorem ev_jq (A : Type*) [CommRing A] : ev data.Φ (jqModC A) (jqNModC A N) = 0 := by
+  have h := congrArg (coeffMap (Int.castRingHom A)) (ev_jq_int data)
+  rwa [map_ev, coeffMap_jqModC, coeffMap_jqNModC, map_zero] at h
+
+end rel
+
+section slice
+variable {A B : Type*} [CommRing A] [CommRing B]
+
+def slice (Φ : Polynomial (Polynomial ℤ)) (x : A) : Polynomial A :=
+  (Φ.map (mapRingHom (Int.castRingHom A))).map (evalRingHom x)
+
+theorem eval_slice (Φ : Polynomial (Polynomial ℤ)) (x y : A) : (slice Φ x).eval y = ev Φ x y := by
+  rw [slice, map_evalRingHom_eval, ev_eq_evalEval]
+
+theorem slice_monic {Φ : Polynomial (Polynomial ℤ)} (hΦ : Φ.Monic) (x : A) : (slice Φ x).Monic :=
+  (hΦ.map _).map _
+
+theorem slice_natDegree [Nontrivial A] {Φ : Polynomial (Polynomial ℤ)} (hΦ : Φ.Monic) (x : A) :
+    (slice Φ x).natDegree = Φ.natDegree := by
+  rw [slice, (hΦ.map _).natDegree_map, hΦ.natDegree_map]
+
+theorem slice_map (Φ : Polynomial (Polynomial ℤ)) (x : A) (φ : A →+* B) :
+    (slice Φ x).map φ = slice Φ (φ x) := by
+  simp only [slice, Polynomial.map_map]
+  refine congrArg (fun f : Polynomial ℤ →+* B => Φ.map f) ?_
+  exact Polynomial.ringHom_ext' (RingHom.ext_int _ _) (by simp)
+
+end slice
+
+section roots
+variable (K : Type*) [Field K] {N : ℕ} [hN : Fact N.Prime] (data : ModularPolynomialData N)
+
+theorem natDegree_slice (x : LaurentSeries K) : (slice data.Φ x).natDegree = N + 1 := by
+  rw [slice_natDegree data.monic, data.natDegree_eq, dedekindPsi_prime hN.out]
+
+variable (hsymm : EvalSymm data.Φ) (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+
+def root (i : Fin (N + 1)) : LaurentSeries K :=
+  Fin.cases (qExpand K N (jqNModC K N)) (fun b => qTwist (ζ ^ (b : ℕ)) (jqModC K)) i
+
+theorem root_zero : root K ζ (0 : Fin (N + 1)) = qExpand K N (jqNModC K N) := rfl
+
+theorem root_succ (b : Fin N) : root K ζ b.succ = qTwist (ζ ^ (b : ℕ)) (jqModC K) := rfl
+
+omit hN in
+include hζ in
+theorem zeta_pow_N :
+    ζ ^ N = 1 := Units.ext (by rw [Units.val_pow_eq_pow_val, Units.val_one]; exact hζ.pow_eq_one)
+
+include hsymm hζ in
+theorem isRoot_root (i : Fin (N + 1)) : (slice data.Φ (jqNModC K N)).IsRoot (root K ζ i) := by
+  rw [Polynomial.IsRoot, eval_slice]
+  refine Fin.cases ?_ (fun b => ?_) i
+  · rw [root_zero, jqNModC, ← map_ev, ← jqNModC, ev_jq data K, map_zero]
+  · rw [root_succ, ev_comm_of_evalSymm hsymm]
+    have hfix : qTwist (ζ ^ (b : ℕ)) (jqNModC K N) = jqNModC K N := by
+      rw [jqNModC, qTwist_qExpand, zpow_natCast, ← pow_mul, mul_comm, pow_mul, zeta_pow_N K ζ hζ,
+        one_pow,
+        qTwist_one_apply]
+    have h := congrArg (qTwist (ζ ^ (b : ℕ))) (ev_jq data K)
+    rwa [map_ev, hfix, map_zero] at h
+
+include hζ in
+theorem root_injective : Function.Injective (root (N := N) K ζ) := by
+  have hN2 : ¬ ((N : ℤ) ∣ (-1 : ℤ)) := fun h => by
+    have h1 : (N : ℤ) ∣ 1 := (Int.dvd_neg).mp h
+    have := Int.eq_one_of_dvd_one (Int.natCast_nonneg N) h1
+    exact hN.out.one_lt.ne' (by exact_mod_cast this)
+  have c0 : (root (N := N) K ζ 0).coeff (-1) = 0 := by
+    rw [root_zero]; exact qExpand_coeff_of_not_dvd N _ hN2
+  have cs : ∀ b : Fin N, (root K ζ b.succ).coeff (-1) = ((ζ ^ (b : ℕ))⁻¹ : Kˣ) := by
+    intro b
+    rw [root_succ, qTwist_coeff, coeff_jqModC_neg_one, mul_one, zpow_neg, zpow_one]
+  intro i i' h
+  have hc := congrArg (fun f : LaurentSeries K => f.coeff (-1)) h
+  rcases Fin.eq_zero_or_eq_succ i with rfl | ⟨b, rfl⟩ <;>
+    rcases Fin.eq_zero_or_eq_succ i' with rfl | ⟨b', rfl⟩
+  · rfl
+  · rw [c0, cs] at hc; exact absurd hc.symm (Units.ne_zero _)
+  · rw [c0, cs] at hc; exact absurd hc (Units.ne_zero _)
+  · rw [cs, cs] at hc
+    have h1 : ζ ^ (b : ℕ) = ζ ^ (b' : ℕ) := inv_injective (Units.ext hc)
+    have h2 : (ζ : K) ^ (b : ℕ) = (ζ : K) ^ (b' : ℕ) := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h1]
+    exact congrArg Fin.succ (Fin.ext (hζ.pow_inj b.isLt b'.isLt h2))
+
+include hsymm hζ in
+theorem slice_jqNModC_eq_prod :
+    slice data.Φ (jqNModC K N) = ∏ i : Fin (N + 1), (Polynomial.X - Polynomial.C (root K ζ i)) := by
+  have hdvd : (∏ i : Fin (N + 1), (Polynomial.X - Polynomial.C (root K ζ i))) ∣ slice data.Φ
+    (jqNModC K N) :=
+    Finset.prod_dvd_of_coprime ((pairwise_coprime_X_sub_C (root_injective K ζ hζ)).set_pairwise _)
+      fun i _ => dvd_iff_isRoot.mpr (isRoot_root K data hsymm ζ hζ i)
+  refine eq_of_monic_of_dvd_of_natDegree_le (monic_prod_X_sub_C _ _) (slice_monic data.monic _) hdvd
+    ?_
+  rw [natDegree_slice, natDegree_finsetProd_X_sub_C_eq_card, Finset.card_univ, Fintype.card_fin]
+
+include hsymm hζ in
+theorem slice_jqNModC_separable : (slice data.Φ (jqNModC K N)).Separable := by
+  rw [slice_jqNModC_eq_prod K data hsymm ζ hζ]
+  exact separable_prod_X_sub_C_iff.mpr (root_injective K ζ hζ)
+
+include hsymm hζ in
+theorem slice_jqModC_separable_of_prim : (slice data.Φ (jqModC K)).Separable := by
+  rw [← separable_map (qExpand K N), slice_map]
+  exact slice_jqNModC_separable K data hsymm ζ hζ
+
+end roots
+
+section noroot
+variable (K : Type*) [Field K] {N : ℕ} [hN : Fact N.Prime] (data : ModularPolynomialData N)
+    (hsymm : EvalSymm data.Φ)
+
+include hsymm in
+theorem slice_jqModC_separable (hNK : (N : K) ≠ 0) : (slice data.Φ (jqModC K)).Separable := by
+  have : NeZero ((N : ℕ) : K) := ⟨hNK⟩
+  obtain ⟨z, hz⟩ := HasEnoughRootsOfUnity.prim (M := AlgebraicClosure K) (n := N)
+  have hz' : IsPrimitiveRoot ((hz.isUnit hN.out.ne_zero).unit : AlgebraicClosure K) N := by
+    simpa using hz
+  rw [← separable_map (coeffMap (algebraMap K (AlgebraicClosure K))), slice_map, coeffMap_jqModC]
+  exact slice_jqModC_separable_of_prim (AlgebraicClosure K) data hsymm _ hz'
+
+include hsymm in
+theorem isSeparable_jqNModC (hNK : (N : K) ≠ 0) :
+    IsSeparable (IntermediateField.adjoin K {jqModC K}) (jqNModC K N) := by
+  set E := IntermediateField.adjoin K {jqModC K}
+  let jE : E := ⟨jqModC K, IntermediateField.mem_adjoin_simple_self K (jqModC K)⟩
+  have hmap : (slice data.Φ jE).map (algebraMap E (LaurentSeries K)) = slice data.Φ (jqModC K) :=
+    slice_map _ _ _
+  have hsep : (slice data.Φ jE).Separable :=
+    (separable_map (algebraMap E (LaurentSeries K))).mp (hmap ▸ slice_jqModC_separable K data hsymm
+      hNK)
+  have h0 : Polynomial.aeval (jqNModC K N) (slice data.Φ jE) = 0 := by
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hmap, eval_slice]; exact ev_jq data K
+  exact hsep.of_dvd (minpoly.dvd E _ h0)
+
+theorem isIntegral_jqNModC {N : ℕ} [NeZero N] (data : ModularPolynomialData N) :
+    IsIntegral (IntermediateField.adjoin K {jqModC K}) (jqNModC K N) := by
+  set E := IntermediateField.adjoin K {jqModC K}
+  let jE : E := ⟨jqModC K, IntermediateField.mem_adjoin_simple_self K (jqModC K)⟩
+  refine ⟨slice data.Φ jE, slice_monic data.monic _, ?_⟩
+  rw [← Polynomial.aeval_def, Polynomial.aeval_def, ← Polynomial.eval_map, slice_map, eval_slice]
+  exact ev_jq data K
+
+end noroot
+
+end SepFibre
+
+end ModularCurve
+end
+
+open _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_isIntegral_jqNModC_of_modularPolynomialData.ModularCurve in
+theorem solution (K : Type*) [Field K] {N : ℕ} [NeZero N] (data : ModularPolynomialData N) :
+    IsIntegral (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) (jqNModC K N) :=
+  SepFibre.isIntegral_jqNModC K data
+
+end S_ModularCurve_isIntegral_jqNModC_of_modularPolynomialData
+end P2MW
+export P2MW.S_ModularCurve_isIntegral_jqNModC_of_modularPolynomialData (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.isIntegral_jqNModC_of_modularPolynomialData (K : Type*) [Field K] {N : ℕ}
+    [NeZero N] (data : ModularPolynomialData N) :
+    IsIntegral (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) (jqNModC K N) :=
+  solution K data
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isRoot_map_Phi_apply_jBar.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isRoot_map_Phi_apply_jBar.lean
new file mode 100644
index 0000000000..c8940e7551
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isRoot_map_Phi_apply_jBar.lean
@@ -0,0 +1,689 @@
+/-
+Based on Prove2Me node ModularCurve.isRoot_map_Phi_apply_jBar
+(c96bc010-956f-5495-8cce-b337ce9af311) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 84ffccda-32ab-5a20-8df1-49e2d2815642
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlace
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_RamificationBound
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularFunctionField_eq_full
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_adjoin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_mem_puiseuxRamSubfield_iff
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_BaseChangeGalois
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceInfty
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_hasRamBound
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_algEquiv_smul_eq_of_restrict_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_restrict_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_eq_ofHeightOneSpectrum_or_eq_placeInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_isAlgClosed_rat
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Any algebra image of j(q^N) is a root of Φ
+
+Theorem statement: `ModularCurve.isRoot_map_Phi_apply_jBar`
+(`c96bc010-956f-5495-8cce-b337ce9af311`), by Claude, 2026-09-05.
+
+Proof: submission `84ffccda-32ab-5a20-8df1-49e2d2815642`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbb{Q}$-algebra structure and let $N$ be a nonzero natural
+number. Let `data` be a modular polynomial datum of level $N$: a polynomial $\Phi \in
+\mathbb{Z}[X][Y]$ which is monic (in $Y$), whose degree equals `dedekindPsi N` $= \sum_{d \mid N,\ d
+\text{ squarefree}} N/d$, and which satisfies $\Phi = 0$ after its coefficient polynomials are
+evaluated at the Laurent series $jq = q^{-1}\cdot(\text{power series } jNumQ)$ over $\mathbb{Q}$ and
+the outer variable at `jqN N`. Let $A$ be a commutative $L$-algebra and let $\varphi$ be an
+$L$-algebra homomorphism from `laurentBaseChange L (modularFunctionFieldFull N)` to $A$; here
+`modularFunctionFieldFull N` is the subfield of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by the
+series `qExpand ℚ d jq` for the divisors $d$ of $N$ (substitution of $q^d$ for $q$, realised as the
+ring homomorphism rescaling exponents by $d$), and `laurentBaseChange` is the subfield of $L((q))$
+generated over $L$ by the coefficientwise images of that set under $\mathbb{Q} \to L$. Then, writing
+$x = \varphi(jq)$ and $y = \varphi(\mathrm{qExpand}\,\mathbb{Q}\,N\,jq)$ for the images of these two
+distinguished elements, the polynomial in $A[Y]$ obtained from $\Phi$ by applying $\mathbb{Z} \to A$
+to its integer coefficients and substituting $x$ for $X$ has $y$ as a root.
+
+This is the modular equation for level $N$ transported along an arbitrary algebra map out of the
+base-changed modular function field: classically, over a point of the $j$-line the function
+$j(N\tau)$ takes a value which is a root of $\Phi_N(j, \cdot)$. It is used in the analysis of places
+of the level-$N$ modular function field and of their reductions, in particular for the divisibility
+of the order of $j$ at such a place and for the description of cusp charts in the characteristic-$p$
+fibre model.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_isRoot_map_Phi_apply_jBar.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_isRoot_map_Phi_apply_jBar
+
+noncomputable section
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_isRoot_map_Phi_apply_jBar.ModularCurve"
+
+namespace HahnSeries
+p2m_export "HahnSeries" "support algebraMap_apply' ofPowerSeries_C support_embDomain_subset single \
+  embDomain order mem_support powerSeriesAlgebra coeff order_mul order_le_of_coeff_ne_zero \
+  ofPowerSeries_X algebraMap_apply coeff_zero embDomainRingHom_C C map ofPowerSeries_apply_coeff \
+  single_ne_zero order_zero ofPowerSeries_injective ofPowerSeries coeff_order_eq_zero \
+  ofPowerSeries_apply embDomain_single order_single HasRamBound puiseuxRamSubfield \
+  mem_puiseuxRamSubfield_iff isAlgClosed_rat"
+p2m_open "HahnSeries"
+
+variable {K : Type*} [Field K]
+
+theorem algebraMap_eq_C' (a : K) : algebraMap K (HahnSeries ℚ K) a = C a := by
+  rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_eq, ofPowerSeries_C]
+
+theorem C_mem_puiseuxRamSubfield {e : ℕ} (he : 0 < e) (a : K) :
+    (C a : HahnSeries ℚ K) ∈ puiseuxRamSubfield K he :=
+  RingHom.mem_fieldRange.mpr ⟨C a, embDomainRingHom_C⟩
+
+theorem single_one_mem_puiseuxRamSubfield {e : ℕ} (he : 0 < e) (c : K) :
+    single (1 : ℚ) c ∈ puiseuxRamSubfield K he := by
+  refine RingHom.mem_fieldRange.mpr ⟨single (e : ℤ) c, ?_⟩
+  change embDomain _ (single (e : ℤ) c) = single (1 : ℚ) c
+  rw [embDomain_single]
+  change single (((e : ℤ) : ℚ) / e) c = single 1 c
+  rw [Int.cast_natCast, div_self (Nat.cast_ne_zero.mpr he.ne')]
+
+end HahnSeries
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place SemilinearAut SemilinearAut.ofAlgAut \
+  SemilinearAut.ofAlgAut_smul SemilinearAut.ord_smul Place.ord_ofHeightOneSpectrum_ne_zero_iff \
+  RationalFunctionField.heightOneSpectrumOfIrreducible \
+  RationalFunctionField.heightOneSpectrumOfIrreducible_asIdeal RationalFunctionField.finitePlace \
+  RationalFunctionField.finitePlace_def Place.exists_ord_mul_eq_order_of_hasRamBound \
+  Place.exists_algEquiv_smul_eq_of_restrict_eq Place.exists_restrict_eq \
+  RationalFunctionField.eq_ofHeightOneSpectrum_or_eq_placeInfty \
+  RationalFunctionField.ord_placeInfty_algebraMap"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext ord ord_coe_irreducible ord_smul toValuationSubring \
+  ramificationIndex ramificationIndex_pos restrict ord_restrict \
+  ord_ofHeightOneSpectrum_ne_zero_iff exists_ord_mul_eq_order_of_hasRamBound \
+  exists_algEquiv_smul_eq_of_restrict_eq exists_restrict_eq"
+end AlgebraicCurve.Place
+p2m_open_scoped "AlgebraicCurve AlgebraicCurve.Place" in
+private theorem AlgebraicCurve.Place.ord_pos_and_dvd_of_hasRamBound {K L F : Type*} [Field K]
+    [Field L]
+    [Algebra K L] [Field F] [Algebra K F] (φ : F →ₐ[K] HahnSeries ℚ L) {d : ℕ}
+    (hram : ∀ x : F, HahnSeries.HasRamBound d (φ x)) (v : AlgebraicCurve.Place K F) {g : ℚ}
+    (hg : 0 < g) (hφv : ∀ x : F, (v.ord x : ℚ) * g = (φ x).order) {x₀ : F}
+    (hx₀ : (φ x₀).order = 1) :
+    0 < v.ord x₀ ∧ v.ord x₀ ∣ (d : ℤ) := by
+  have h1 : (v.ord x₀ : ℚ) * g = 1 := by rw [hφv, hx₀]
+  have hpos : (0 : ℚ) < v.ord x₀ := by
+    by_contra hle
+    have : (v.ord x₀ : ℚ) * g ≤ 0 := mul_nonpos_of_nonpos_of_nonneg (not_lt.mp hle) hg.le
+    rw [h1] at this
+    exact absurd this (not_le.mpr one_pos)
+  obtain ⟨π₀, hπ₀⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπ : v.ord (π₀ : F) = 1 := v.ord_coe_irreducible hπ₀
+  have hgπ : g = (φ (π₀ : F)).order := by
+    have := hφv (π₀ : F); rwa [hπ, Int.cast_one, one_mul] at this
+  have hπne : φ (π₀ : F) ≠ 0 := by
+    intro h0
+    rw [h0, HahnSeries.order_zero] at hgπ
+    exact hg.ne' hgπ
+  obtain ⟨k, hk⟩ := hram (π₀ : F) (fun h => hπne (HahnSeries.coeff_order_eq_zero.mp h))
+  dsimp only at hk
+  have hd : (d : ℚ) ≠ 0 := by
+    intro hd
+    simp only [hd, div_zero] at hk
+    rw [← hk] at hgπ
+    exact hg.ne' hgπ
+  have hk' : (v.ord x₀ : ℚ) * k = d := by
+    rw [hgπ, ← hk] at h1
+    field_simp at h1
+    linarith
+  have hkint : v.ord x₀ * k = (d : ℤ) := by exact_mod_cast hk'
+  exact ⟨by exact_mod_cast hpos, Dvd.intro k hkint⟩
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand jq jqN evalAtJ evalAtJ_X ModularPolynomialData \
+  FunctionFieldGeneration modularFunctionField modularFunctionFieldFull jqd_mem_full coeffEmb \
+  laurentBaseChange coeffEmb_mem_laurentBaseChange jq_mem_full modularFunctionField_eq_full \
+  laurentBaseChange_adjoin"
+p2m_open "ModularCurve"
+
+variable (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N]
+
+theorem isRoot_map_Φ_apply_jBar_of_dvd {d : ℕ} [NeZero d] (hd : d ∣ N)
+    (dd : ModularPolynomialData d)
+    {A : Type*} [CommRing A] [Algebra L A]
+    (φ : laurentBaseChange L (modularFunctionFieldFull N) →ₐ[L] A) :
+    (dd.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom A)
+      (φ ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩))).IsRoot
+      (φ ⟨coeffEmb L (qExpand ℚ d jq),
+        coeffEmb_mem_laurentBaseChange L (jqd_mem_full N hd)⟩) := by
+  have hθ : ((laurentBaseChange L (modularFunctionFieldFull N)).val :
+        laurentBaseChange L (modularFunctionFieldFull N) →+* LaurentSeries L).comp
+      (Polynomial.eval₂RingHom (Int.castRingHom (laurentBaseChange L (modularFunctionFieldFull N)))
+        ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩)
+      = (coeffEmb L).comp evalAtJ := by
+    refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+    simp only [RingHom.coe_comp, Function.comp_apply, Polynomial.coe_eval₂RingHom,
+      Polynomial.eval₂_X, evalAtJ_X]
+    rfl
+  have key : dd.Φ.eval₂
+      (Polynomial.eval₂RingHom (Int.castRingHom (laurentBaseChange L (modularFunctionFieldFull N)))
+        ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩)
+      (⟨coeffEmb L (qExpand ℚ d jq), coeffEmb_mem_laurentBaseChange L (jqd_mem_full N hd)⟩ :
+        laurentBaseChange L (modularFunctionFieldFull N)) = 0 := by
+    apply ((laurentBaseChange L (modularFunctionFieldFull N)).val :
+        laurentBaseChange L (modularFunctionFieldFull N) →+* LaurentSeries L).injective
+    rw [Polynomial.hom_eval₂, hθ, map_zero]
+    have h2 : ((laurentBaseChange L (modularFunctionFieldFull N)).val :
+        laurentBaseChange L (modularFunctionFieldFull N) →+* LaurentSeries L)
+        ⟨coeffEmb L (qExpand ℚ d jq), coeffEmb_mem_laurentBaseChange L (jqd_mem_full N hd)⟩
+        = coeffEmb L (jqN d) := rfl
+    rw [h2, ← Polynomial.hom_eval₂, dd.eval_eq_zero, map_zero]
+  have hρ : (φ : laurentBaseChange L (modularFunctionFieldFull N) →+* A).comp
+      (Polynomial.eval₂RingHom (Int.castRingHom (laurentBaseChange L (modularFunctionFieldFull N)))
+        ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩)
+      = Polynomial.eval₂RingHom (Int.castRingHom A)
+          (φ ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩) := by
+    refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+    simp only [RingHom.coe_comp, Function.comp_apply, Polynomial.coe_eval₂RingHom,
+      Polynomial.eval₂_X]
+    rfl
+  rw [Polynomial.IsRoot.def, Polynomial.eval_map, ← hρ]
+  have h3 := Polynomial.hom_eval₂ dd.Φ
+    (Polynomial.eval₂RingHom (Int.castRingHom (laurentBaseChange L (modularFunctionFieldFull N)))
+      ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩)
+    (φ : laurentBaseChange L (modularFunctionFieldFull N) →+* A)
+    (⟨coeffEmb L (qExpand ℚ d jq), coeffEmb_mem_laurentBaseChange L (jqd_mem_full N hd)⟩ :
+      laurentBaseChange L (modularFunctionFieldFull N))
+  rw [key, map_zero] at h3
+  exact h3.symm
+
+theorem isRoot_map_Φ_apply_jBar (data : ModularPolynomialData N) {A : Type*} [CommRing A]
+    [Algebra L A] (φ : laurentBaseChange L (modularFunctionFieldFull N) →ₐ[L] A) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom A)
+      (φ ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩))).IsRoot
+      (φ ⟨coeffEmb L (qExpand ℚ N jq),
+        coeffEmb_mem_laurentBaseChange L (jqd_mem_full N (dvd_refl N))⟩) :=
+  isRoot_map_Φ_apply_jBar_of_dvd L N (dvd_refl N) data φ
+
+private theorem laurentBaseChange_full_eq_adjoin_pair :
+    laurentBaseChange L (modularFunctionFieldFull N)
+      = IntermediateField.adjoin L {coeffEmb L jq, coeffEmb L (qExpand ℚ N jq)} := by
+  rw [← modularFunctionField_eq_full N, modularFunctionField, laurentBaseChange_adjoin,
+    Set.image_pair]
+
+private theorem adjoin_jBar_jNBar_eq_top :
+    IntermediateField.adjoin L
+      ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩,
+        ⟨coeffEmb L (qExpand ℚ N jq),
+          coeffEmb_mem_laurentBaseChange L (jqd_mem_full N (dvd_refl N))⟩} :
+        Set (laurentBaseChange L (modularFunctionFieldFull N)))
+      = ⊤ := by
+  rw [eq_top_iff]
+  rintro x -
+  refine (IntermediateField.mem_lift x).mp ?_
+  have hle : laurentBaseChange L (modularFunctionFieldFull N)
+      ≤ IntermediateField.lift (IntermediateField.adjoin L
+          ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩,
+            ⟨coeffEmb L (qExpand ℚ N jq),
+              coeffEmb_mem_laurentBaseChange L (jqd_mem_full N (dvd_refl N))⟩} :
+            Set (laurentBaseChange L (modularFunctionFieldFull N)))) := by
+    refine (laurentBaseChange_full_eq_adjoin_pair L N).le.trans ?_
+    rw [IntermediateField.adjoin_le_iff]
+    rintro y (rfl | rfl)
+    · exact (IntermediateField.mem_lift
+        (⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩ :
+          laurentBaseChange L (modularFunctionFieldFull N))).mpr
+        (IntermediateField.subset_adjoin _ _ (Set.mem_insert _ _))
+    · exact (IntermediateField.mem_lift
+        (⟨coeffEmb L (qExpand ℚ N jq), coeffEmb_mem_laurentBaseChange L (jqd_mem_full N (dvd_refl
+          N))⟩ :
+          laurentBaseChange L (modularFunctionFieldFull N))).mpr
+        (IntermediateField.subset_adjoin _ _ (Set.mem_insert_of_mem _ rfl))
+  exact hle x.2
+
+end ModularCurve
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand jq jqN evalAtJ evalAtJ_X ModularPolynomialData \
+  FunctionFieldGeneration modularFunctionField modularFunctionFieldFull jqd_mem_full coeffEmb \
+  laurentBaseChange coeffEmb_mem_laurentBaseChange jq_mem_full modularFunctionField_eq_full \
+  laurentBaseChange_adjoin"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.ord_jBar_sub_pos_and_dvd_of_forall_isRoot_hasRamBound (L : Type*)
+    [Field L]
+    [Algebra ℚ L] (N : ℕ) [NeZero N] (data : ModularCurve.ModularPolynomialData N) (j₀ : L)
+    {d : ℕ} (hd : 0 < d)
+    (hroots : ∀ r : HahnSeries ℚ L,
+      (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ L))
+        (HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : L)))).IsRoot r →
+        HahnSeries.HasRamBound d r)
+    (v : AlgebraicCurve.Place L (ModularCurve.laurentBaseChange L
+      (ModularCurve.modularFunctionFieldFull N)))
+    (φ : ModularCurve.laurentBaseChange L (ModularCurve.modularFunctionFieldFull N)
+      →ₐ[L] HahnSeries ℚ L)
+    (hφj : φ ⟨ModularCurve.coeffEmb L ModularCurve.jq,
+        ModularCurve.coeffEmb_mem_laurentBaseChange L (ModularCurve.jq_mem_full N)⟩
+      = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : L))
+    {g : ℚ} (hg : 0 < g) (hφv : ∀ x, (v.ord x : ℚ) * g = (φ x).order) :
+    0 < v.ord (⟨ModularCurve.coeffEmb L ModularCurve.jq,
+          ModularCurve.coeffEmb_mem_laurentBaseChange L (ModularCurve.jq_mem_full N)⟩
+        - algebraMap L _ j₀) ∧
+      v.ord (⟨ModularCurve.coeffEmb L ModularCurve.jq,
+          ModularCurve.coeffEmb_mem_laurentBaseChange L (ModularCurve.jq_mem_full N)⟩
+        - algebraMap L _ j₀) ∣ (d : ℤ) := by
+  let P : IntermediateField L (HahnSeries ℚ L) :=
+    (HahnSeries.puiseuxRamSubfield L hd).toIntermediateField (by
+      intro a
+      rw [HahnSeries.algebraMap_eq_C']
+      exact HahnSeries.C_mem_puiseuxRamSubfield hd a)
+  have hjP : (⟨ModularCurve.coeffEmb L ModularCurve.jq,
+      ModularCurve.coeffEmb_mem_laurentBaseChange L (ModularCurve.jq_mem_full N)⟩ :
+      ModularCurve.laurentBaseChange L (ModularCurve.modularFunctionFieldFull N)) ∈ P.comap φ := by
+    change φ _ ∈ HahnSeries.puiseuxRamSubfield L hd
+    rw [hφj]
+    exact add_mem (HahnSeries.C_mem_puiseuxRamSubfield hd j₀)
+      (HahnSeries.single_one_mem_puiseuxRamSubfield hd 1)
+  have hjNP : (⟨ModularCurve.coeffEmb L (ModularCurve.qExpand ℚ N ModularCurve.jq),
+      ModularCurve.coeffEmb_mem_laurentBaseChange L (ModularCurve.jqd_mem_full N (dvd_refl N))⟩ :
+      ModularCurve.laurentBaseChange L (ModularCurve.modularFunctionFieldFull N)) ∈ P.comap φ := by
+    change φ _ ∈ HahnSeries.puiseuxRamSubfield L hd
+    refine (HahnSeries.mem_puiseuxRamSubfield_iff hd).mpr (hroots _ ?_)
+    have h := ModularCurve.isRoot_map_Φ_apply_jBar L N data φ
+    rwa [hφj] at h
+  have htop : P.comap φ = ⊤ := by
+    refine eq_top_iff.mpr ?_
+    rw [← ModularCurve.adjoin_jBar_jNBar_eq_top L N, IntermediateField.adjoin_le_iff]
+    exact Set.insert_subset_iff.mpr ⟨hjP, Set.singleton_subset_iff.mpr hjNP⟩
+  have hall : ∀ x, HahnSeries.HasRamBound d (φ x) := fun x => by
+    have hx : x ∈ P.comap φ := by rw [htop]; exact IntermediateField.mem_top
+    exact (HahnSeries.mem_puiseuxRamSubfield_iff hd).mp hx
+  refine AlgebraicCurve.Place.ord_pos_and_dvd_of_hasRamBound φ hall v hg hφv ?_
+  have hC : algebraMap L (HahnSeries ℚ L) j₀ = HahnSeries.C j₀ := HahnSeries.algebraMap_eq_C' j₀
+  rw [map_sub, hφj, AlgHom.commutes, hC, add_sub_cancel_left, HahnSeries.order_single one_ne_zero]
+
+open Polynomial
+
+namespace HahnSeries
+p2m_export "HahnSeries" "support algebraMap_apply' ofPowerSeries_C support_embDomain_subset single \
+  embDomain order mem_support powerSeriesAlgebra coeff order_mul order_le_of_coeff_ne_zero \
+  ofPowerSeries_X algebraMap_apply coeff_zero embDomainRingHom_C C map ofPowerSeries_apply_coeff \
+  single_ne_zero order_zero ofPowerSeries_injective ofPowerSeries coeff_order_eq_zero \
+  ofPowerSeries_apply embDomain_single order_single HasRamBound puiseuxRamSubfield \
+  mem_puiseuxRamSubfield_iff isAlgClosed_rat"
+p2m_open "HahnSeries"
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+
+theorem algebraMap_eq_C_algebraMap (k : K) :
+    algebraMap K (HahnSeries ℚ L) k = C (algebraMap K L k) := by
+  rw [HahnSeries.algebraMap_apply',
+    show algebraMap K (PowerSeries L) k = PowerSeries.C (algebraMap K L k) from
+      MvPowerSeries.algebraMap_apply (σ := Unit) (R := K) (A := L),
+    ofPowerSeries_C]
+
+omit [Algebra K L] in
+theorem eval₂_C_single_one_eq_ofPowerSeries (r : L[X]) :
+    r.eval₂ (C : L →+* HahnSeries ℚ L) (single (1 : ℚ) (1 : L)) = ofPowerSeries ℚ L (r : PowerSeries
+      L) := by
+  have h : (Polynomial.eval₂RingHom (C : L →+* HahnSeries ℚ L) (single (1 : ℚ) 1))
+      = (ofPowerSeries ℚ L).comp (Polynomial.coeToPowerSeries.ringHom : L[X] →+* PowerSeries L)
+        := by
+    refine Polynomial.ringHom_ext (fun c => ?_) ?_
+    · rw [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_C, RingHom.comp_apply,
+        Polynomial.coeToPowerSeries.ringHom_apply, Polynomial.coe_C, ofPowerSeries_C]
+    · rw [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X, RingHom.comp_apply,
+        Polynomial.coeToPowerSeries.ringHom_apply, Polynomial.coe_X, ofPowerSeries_X]
+  exact RingHom.congr_fun h r
+
+omit [Algebra K L] in
+theorem eval₂_C_single_one_ne_zero_and_order_eq_one (q : L[X]) (h0 : q.coeff 0 = 0)
+    (h1 : q.coeff 1 ≠ 0) :
+    q.eval₂ (C : L →+* HahnSeries ℚ L) (single (1 : ℚ) (1 : L)) ≠ 0 ∧
+      (q.eval₂ (C : L →+* HahnSeries ℚ L) (single (1 : ℚ) (1 : L))).order = 1 := by
+  have hq : q = q.divX * Polynomial.X := by
+    conv_lhs => rw [← Polynomial.divX_mul_X_add q, h0, map_zero, add_zero]
+  have hs' : q.divX.eval₂ (C : L →+* HahnSeries ℚ L) (single (1 : ℚ) (1 : L))
+      = ofPowerSeries ℚ L (q.divX : PowerSeries L) := eval₂_C_single_one_eq_ofPowerSeries _
+  have hs0 : (ofPowerSeries ℚ L (q.divX : PowerSeries L)).coeff 0 = q.coeff 1 := by
+    rw [show (0 : ℚ) = ((0 : ℕ) : ℚ) from Nat.cast_zero.symm, ofPowerSeries_apply_coeff,
+      Polynomial.coeff_coe, Polynomial.coeff_divX]
+  have hsne : ofPowerSeries ℚ L (q.divX : PowerSeries L) ≠ 0 := fun h =>
+    h1 (by rw [← hs0, h, HahnSeries.coeff_zero])
+  have hord_s : (ofPowerSeries ℚ L (q.divX : PowerSeries L)).order = 0 := by
+    apply le_antisymm
+    · exact order_le_of_coeff_ne_zero (by rw [hs0]; exact h1)
+    · have hmem : (ofPowerSeries ℚ L (q.divX : PowerSeries L)).order
+          ∈ (ofPowerSeries ℚ L (q.divX : PowerSeries L)).support := by
+        rw [HahnSeries.mem_support]
+        exact fun h => hsne (coeff_order_eq_zero.mp h)
+      rw [ofPowerSeries_apply] at hmem ⊢
+      obtain ⟨n, -, hn⟩ := support_embDomain_subset hmem
+      rw [← hn]
+      exact Nat.cast_nonneg n
+  have ht : (single (1 : ℚ) (1 : L)) ≠ 0 := single_ne_zero one_ne_zero
+  rw [hq, Polynomial.eval₂_mul, Polynomial.eval₂_X, hs']
+  exact ⟨mul_ne_zero hsne ht, by rw [order_mul hsne ht, hord_s, order_single one_ne_zero, zero_add]⟩
+
+theorem eval₂_C_comp_add_single_eq_taylor (p : K[X]) (a : L) :
+    p.eval₂ ((C : L →+* HahnSeries ℚ L).comp (algebraMap K L)) (C a + single (1 : ℚ) (1 : L))
+      = (Polynomial.taylor a (p.map (algebraMap K L))).eval₂ (C : L →+* HahnSeries ℚ L)
+          (single (1 : ℚ) (1 : L)) := by
+  rw [← Polynomial.eval₂_map, Polynomial.taylor_apply, Polynomial.eval₂_comp, Polynomial.eval₂_add,
+    Polynomial.eval₂_X, Polynomial.eval₂_C, add_comm]
+
+theorem eval₂_C_add_single_ne_zero_and_order_eq_one (p : K[X]) (a : L)
+    (ha : Polynomial.aeval a p = 0)
+    (ha' : Polynomial.aeval a (Polynomial.derivative p) ≠ 0) :
+    p.eval₂ ((C : L →+* HahnSeries ℚ L).comp (algebraMap K L)) (C a + single (1 : ℚ) (1 : L)) ≠ 0 ∧
+      (p.eval₂ ((C : L →+* HahnSeries ℚ L).comp (algebraMap K L)) (C a + single (1 : ℚ) (1 :
+        L))).order = 1 := by
+  have hshift := eval₂_C_comp_add_single_eq_taylor p a
+  have h0 : (Polynomial.taylor a (p.map (algebraMap K L))).coeff 0 = 0 := by
+    rw [Polynomial.taylor_coeff_zero, Polynomial.eval_map, ← Polynomial.aeval_def, ha]
+  have h1 : (Polynomial.taylor a (p.map (algebraMap K L))).coeff 1 ≠ 0 := by
+    rw [Polynomial.taylor_coeff_one, Polynomial.derivative_map, Polynomial.eval_map, ←
+      Polynomial.aeval_def]
+    exact ha'
+  rw [hshift]
+  exact eval₂_C_single_one_ne_zero_and_order_eq_one _ h0 h1
+
+end HahnSeries
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place SemilinearAut SemilinearAut.ofAlgAut \
+  SemilinearAut.ofAlgAut_smul SemilinearAut.ord_smul Place.ord_ofHeightOneSpectrum_ne_zero_iff \
+  RationalFunctionField.heightOneSpectrumOfIrreducible \
+  RationalFunctionField.heightOneSpectrumOfIrreducible_asIdeal RationalFunctionField.finitePlace \
+  RationalFunctionField.finitePlace_def Place.exists_ord_mul_eq_order_of_hasRamBound \
+  Place.exists_algEquiv_smul_eq_of_restrict_eq Place.exists_restrict_eq \
+  RationalFunctionField.eq_ofHeightOneSpectrum_or_eq_placeInfty \
+  RationalFunctionField.ord_placeInfty_algebraMap"
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "heightOneSpectrumOfIrreducible \
+  heightOneSpectrumOfIrreducible_asIdeal finitePlace finitePlace_def \
+  eq_ofHeightOneSpectrum_or_eq_placeInfty ord_placeInfty_algebraMap"
+end AlgebraicCurve.RationalFunctionField
+p2m_open_scoped "AlgebraicCurve AlgebraicCurve.RationalFunctionField" in
+private theorem AlgebraicCurve.RationalFunctionField.eq_finitePlace_of_ord_pos {K : Type*} [Field K]
+    {p : K[X]}
+    (hp : Irreducible p) (v : AlgebraicCurve.Place K (RatFunc K))
+    (hv : 0 < v.ord (algebraMap K[X] (RatFunc K) p)) :
+    v = AlgebraicCurve.RationalFunctionField.finitePlace K hp := by
+  classical
+  rcases AlgebraicCurve.RationalFunctionField.eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w,
+    rfl⟩ | rfl
+  · have hmem : p ∈ w.asIdeal :=
+      (AlgebraicCurve.Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w
+        hp.ne_zero).mp hv.ne'
+    have heq : w = AlgebraicCurve.RationalFunctionField.heightOneSpectrumOfIrreducible K hp := by
+      refine IsDedekindDomain.HeightOneSpectrum.ext ?_
+      rw [AlgebraicCurve.RationalFunctionField.heightOneSpectrumOfIrreducible_asIdeal]
+      exact ((PrincipalIdealRing.isMaximal_of_irreducible hp).eq_of_le w.isPrime.ne_top
+        ((Ideal.span_singleton_le_iff_mem _).mpr hmem)).symm
+    rw [heq, AlgebraicCurve.RationalFunctionField.finitePlace_def]
+  · exfalso
+    rw [AlgebraicCurve.RationalFunctionField.ord_placeInfty_algebraMap hp.ne_zero] at hv
+    have := Int.natCast_nonneg p.natDegree
+    omega
+
+p2m_open_scoped "AlgebraicCurve AlgebraicCurve.Place" in
+private theorem AlgebraicCurve.Place.ord_dvd_of_hahnSeries_embedding_of_isGalois
+    {K L M : Type*} [Field K] [Field L] [Algebra K L] [Field M] [Algebra K M]
+    [Algebra (RatFunc K) M] [IsScalarTower K (RatFunc K) M]
+    [FiniteDimensional (RatFunc K) M] [IsGalois (RatFunc K) M]
+    (p : Polynomial K) (hp : Irreducible p) (a : L)
+    (ha : Polynomial.aeval a p = 0) (ha' : Polynomial.aeval a (Polynomial.derivative p) ≠ 0)
+    {d : ℕ} (hd : 0 < d) (ψ : M →ₐ[K] HahnSeries ℚ L)
+    (hψX : ψ (algebraMap (RatFunc K) M (algebraMap (Polynomial K) (RatFunc K) Polynomial.X))
+      = HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L))
+    (hψ : ∀ m : M, HahnSeries.HasRamBound d (ψ m))
+    (W : AlgebraicCurve.Place K M)
+    (hW : 0 < W.ord (algebraMap (RatFunc K) M (algebraMap (Polynomial K) (RatFunc K) p))) :
+    W.ord (algebraMap (RatFunc K) M (algebraMap (Polynomial K) (RatFunc K) p)) ∣ (d : ℤ) := by
+  have hχ : (((ψ : M →+* HahnSeries ℚ L).comp (algebraMap (RatFunc K) M)).comp (algebraMap K[X]
+    (RatFunc K)))
+      = Polynomial.eval₂RingHom ((HahnSeries.C : L →+* HahnSeries ℚ L).comp (algebraMap K L))
+          (HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L)) := by
+    refine Polynomial.ringHom_ext (fun k => ?_) ?_
+    · change ψ (algebraMap (RatFunc K) M (algebraMap K[X] (RatFunc K) (Polynomial.C k)))
+        = Polynomial.eval₂ _ _ (Polynomial.C k)
+      rw [Polynomial.eval₂_C, RatFunc.algebraMap_C, RingHom.comp_apply,
+        show (RatFunc.C k : RatFunc K) = algebraMap K (RatFunc K) k from rfl,
+        ← IsScalarTower.algebraMap_apply, AlgHom.commutes, HahnSeries.algebraMap_eq_C_algebraMap]
+    · change ψ (algebraMap (RatFunc K) M (algebraMap K[X] (RatFunc K) Polynomial.X))
+        = Polynomial.eval₂ _ _ Polynomial.X
+      rw [Polynomial.eval₂_X, hψX]
+  have hψp : ψ (algebraMap (RatFunc K) M (algebraMap K[X] (RatFunc K) p))
+      = p.eval₂ ((HahnSeries.C : L →+* HahnSeries ℚ L).comp (algebraMap K L))
+          (HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L)) := RingHom.congr_fun hχ p
+  have hord : (ψ (algebraMap (RatFunc K) M (algebraMap K[X] (RatFunc K) p))).order = 1 := by
+    rw [hψp]; exact (HahnSeries.eval₂_C_add_single_ne_zero_and_order_eq_one p a ha ha').2
+  obtain ⟨W₀, g, hg, hφv⟩ := AlgebraicCurve.Place.exists_ord_mul_eq_order_of_hasRamBound ψ hd hψ
+    ⟨_, by rw [hord]; exact one_ne_zero⟩
+  have h0 := AlgebraicCurve.Place.ord_pos_and_dvd_of_hasRamBound ψ hψ W₀ hg hφv hord
+  have hres : ∀ V : AlgebraicCurve.Place K M,
+      0 < V.ord (algebraMap (RatFunc K) M (algebraMap K[X] (RatFunc K) p)) →
+        V.restrict (RatFunc K) = AlgebraicCurve.RationalFunctionField.finitePlace K hp := by
+    intro V hV
+    refine AlgebraicCurve.RationalFunctionField.eq_finitePlace_of_ord_pos hp _ ?_
+    have he := V.ramificationIndex_pos (F := RatFunc K)
+    rw [V.ord_restrict (F := RatFunc K)] at hV
+    exact pos_of_mul_pos_right hV (by exact_mod_cast he.le)
+  have hWW₀ : W.restrict (RatFunc K) = W₀.restrict (RatFunc K) :=
+    (hres W hW).trans (hres W₀ h0.1).symm
+  obtain ⟨σ, hσ⟩ := AlgebraicCurve.Place.exists_algEquiv_smul_eq_of_restrict_eq W₀ W hWW₀
+  have hfix : AlgebraicCurve.SemilinearAut.ofAlgAut (σ.restrictScalars K)
+      • (algebraMap (RatFunc K) M (algebraMap K[X] (RatFunc K) p))
+      = algebraMap (RatFunc K) M (algebraMap K[X] (RatFunc K) p) := by
+    rw [AlgebraicCurve.SemilinearAut.ofAlgAut_smul, AlgEquiv.restrictScalars_apply,
+      AlgEquiv.commutes]
+  rw [← hσ, ← hfix, AlgebraicCurve.SemilinearAut.ord_smul]
+  exact h0.2
+
+p2m_open_scoped "AlgebraicCurve AlgebraicCurve.Place" in
+open IntermediateField in
+private theorem AlgebraicCurve.Place.ord_dvd_of_forall_hahnSeries_embedding_hasRamBound
+    {K L F : Type*} [Field K] [CharZero K] [Field L] [Algebra K L] [IsAlgClosed L]
+    [Field F] [Algebra K F] [Algebra (RatFunc K) F] [IsScalarTower K (RatFunc K) F]
+    [FiniteDimensional (RatFunc K) F]
+    (p : Polynomial K) (hp : Irreducible p) (a : L)
+    (ha : Polynomial.aeval a p = 0) (ha' : Polynomial.aeval a (Polynomial.derivative p) ≠ 0)
+    {d : ℕ} (hd : 0 < d)
+    (hF : ∀ ψ : F →ₐ[K] HahnSeries ℚ L,
+      ψ (algebraMap (RatFunc K) F (algebraMap (Polynomial K) (RatFunc K) Polynomial.X))
+          = HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L) →
+        ∀ x : F, HahnSeries.HasRamBound d (ψ x))
+    (w : AlgebraicCurve.Place K F)
+    (hw : 0 < w.ord (algebraMap (RatFunc K) F (algebraMap (Polynomial K) (RatFunc K) p))) :
+    w.ord (algebraMap (RatFunc K) F (algebraMap (Polynomial K) (RatFunc K) p)) ∣ (d : ℤ) := by
+  classical
+  let φ₀ : K[X] →ₐ[K] HahnSeries ℚ L :=
+    Polynomial.aeval (HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L))
+  have hφ₀ : ∀ q : K[X], φ₀ q = q.eval₂ ((HahnSeries.C : L →+* HahnSeries ℚ L).comp (algebraMap K
+    L))
+      (HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : L)) := by
+    intro q
+    change Polynomial.aeval _ q = _
+    rw [Polynomial.aeval_def]
+    congr 1
+    exact RingHom.ext HahnSeries.algebraMap_eq_C_algebraMap
+  have hφ₀inj : Function.Injective φ₀ := by
+    intro q₁ q₂ h
+    have key : ∀ q : K[X], φ₀ q = HahnSeries.ofPowerSeries ℚ L
+        ((Polynomial.taylor a (q.map (algebraMap K L)) : PowerSeries L) : PowerSeries L) := fun q
+          => by
+      rw [hφ₀, HahnSeries.eval₂_C_comp_add_single_eq_taylor,
+        HahnSeries.eval₂_C_single_one_eq_ofPowerSeries]
+    rw [key, key] at h
+    exact Polynomial.map_injective _ (algebraMap K L).injective
+      (Polynomial.taylor_injective a (Polynomial.coe_inj.mp (HahnSeries.ofPowerSeries_injective h)))
+  have hφ₀' : nonZeroDivisors K[X] ≤ (nonZeroDivisors (HahnSeries ℚ L)).comap φ₀ :=
+    nonZeroDivisors_le_comap_nonZeroDivisors_of_injective _ hφ₀inj
+  let ψ₀ : RatFunc K →ₐ[K] HahnSeries ℚ L := RatFunc.liftAlgHom φ₀ hφ₀'
+  have hψ₀ : ∀ q : K[X], ψ₀ (algebraMap K[X] (RatFunc K) q) = φ₀ q := fun q => by
+    have h := RatFunc.liftAlgHom_apply_div φ₀ hφ₀' q 1
+    rwa [map_one, div_one, map_one, div_one] at h
+  have hψ₀X : ψ₀ (algebraMap K[X] (RatFunc K) Polynomial.X) = HahnSeries.C a + HahnSeries.single (1
+    : ℚ) (1 : L) :=
+    by
+    rw [hψ₀]; exact Polynomial.aeval_X _
+  have : Algebra.IsAlgebraic (RatFunc K) F := Algebra.IsAlgebraic.of_finite (RatFunc K) F
+  have : IsAlgClosed (HahnSeries ℚ L) := HahnSeries.isAlgClosed_rat
+  obtain ⟨Ψ, hΨ⟩ := IsAlgClosed.surjective_domRestrict_of_isAlgebraic (K := K) (L := RatFunc K)
+    (M := HahnSeries ℚ L) (E := AlgebraicClosure F) ψ₀
+  have hΨr : ∀ r : RatFunc K, Ψ (algebraMap (RatFunc K) (AlgebraicClosure F) r) = ψ₀ r :=
+    fun r => by
+    rw [← hΨ]; rfl
+  have hφ₀P : ∀ q : K[X], φ₀ q ∈ HahnSeries.puiseuxRamSubfield L hd := by
+    intro q
+    induction q using Polynomial.induction_on' with
+    | add q₁ q₂ h₁ h₂ => rw [map_add]; exact add_mem h₁ h₂
+    | monomial n c =>
+        change Polynomial.aeval _ (Polynomial.monomial n c) ∈ _
+        rw [← Polynomial.C_mul_X_pow_eq_monomial, map_mul, map_pow, Polynomial.aeval_C,
+          Polynomial.aeval_X,
+          HahnSeries.algebraMap_eq_C_algebraMap]
+        exact mul_mem (HahnSeries.C_mem_puiseuxRamSubfield hd _)
+          (pow_mem (add_mem (HahnSeries.C_mem_puiseuxRamSubfield hd _)
+            (HahnSeries.single_one_mem_puiseuxRamSubfield hd _)) _)
+  have hψ₀P : ∀ r : RatFunc K, ψ₀ r ∈ HahnSeries.puiseuxRamSubfield L hd := fun r => by
+    induction r using RatFunc.induction_on with
+    | f p₁ q₁ _ => rw [map_div₀, hψ₀, hψ₀]; exact div_mem (hφ₀P p₁) (hφ₀P q₁)
+  let S : IntermediateField (RatFunc K) (AlgebraicClosure F) :=
+    ((HahnSeries.puiseuxRamSubfield L hd).comap (Ψ : AlgebraicClosure F →+* HahnSeries ℚ
+      L)).toIntermediateField
+      (fun r => by
+        change Ψ (algebraMap (RatFunc K) (AlgebraicClosure F) r) ∈ HahnSeries.puiseuxRamSubfield L
+          hd
+        rw [hΨr]; exact hψ₀P r)
+  have hMS : normalClosure (RatFunc K) F (AlgebraicClosure F) ≤ S := by
+    rw [normalClosure_le_iff]
+    rintro f x ⟨y, rfl⟩
+    change Ψ (f y) ∈ HahnSeries.puiseuxRamSubfield L hd
+    refine (HahnSeries.mem_puiseuxRamSubfield_iff hd).mpr (hF (Ψ.comp (f.restrictScalars K)) ?_ y)
+    change Ψ (f (algebraMap (RatFunc K) F (algebraMap K[X] (RatFunc K) Polynomial.X))) = _
+    rw [f.commutes, hΨr, hψ₀X]
+  have : CharZero F := charZero_of_injective_algebraMap (algebraMap K F).injective
+  have : IsGalois (RatFunc K) (AlgebraicClosure F) := ⟨⟩
+  have : IsScalarTower K F (normalClosure (RatFunc K) F (AlgebraicClosure F)) :=
+    IsScalarTower.of_algebraMap_eq (R := K) (S := F) (A := ↥(normalClosure (RatFunc K) F
+      (AlgebraicClosure F)))
+      (fun k => Subtype.ext (show algebraMap K (AlgebraicClosure F) k
+        = algebraMap F (AlgebraicClosure F) (algebraMap K F k) from IsScalarTower.algebraMap_apply K
+          F _ k))
+  have : Module.Finite F (normalClosure (RatFunc K) F (AlgebraicClosure F)) :=
+    Module.Finite.of_restrictScalars_finite (RatFunc K) F _
+  have : Algebra.IsAlgebraic F (normalClosure (RatFunc K) F (AlgebraicClosure F)) :=
+    Algebra.IsAlgebraic.of_finite F _
+  let ΨM : normalClosure (RatFunc K) F (AlgebraicClosure F) →ₐ[K] HahnSeries ℚ L :=
+    Ψ.comp ((normalClosure (RatFunc K) F (AlgebraicClosure F)).val.restrictScalars K)
+  have hΨM : ∀ m : normalClosure (RatFunc K) F (AlgebraicClosure F), HahnSeries.HasRamBound d (ΨM m)
+    :=
+    fun m => (HahnSeries.mem_puiseuxRamSubfield_iff hd).mp (hMS m.2)
+  have hΨMX : ΨM (algebraMap (RatFunc K) (normalClosure (RatFunc K) F (AlgebraicClosure F))
+      (algebraMap K[X] (RatFunc K) Polynomial.X)) = HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 :
+        L) := by
+    change Ψ ((algebraMap (RatFunc K) (normalClosure (RatFunc K) F (AlgebraicClosure F))
+      (algebraMap K[X] (RatFunc K) Polynomial.X) : AlgebraicClosure F)) = _
+    rw [IntermediateField.coe_algebraMap_apply, hΨr, hψ₀X]
+  obtain ⟨W, hWw⟩ := AlgebraicCurve.Place.exists_restrict_eq
+    (M := normalClosure (RatFunc K) F (AlgebraicClosure F)) w
+  have hpM : algebraMap F (normalClosure (RatFunc K) F (AlgebraicClosure F))
+        (algebraMap (RatFunc K) F (algebraMap K[X] (RatFunc K) p))
+      = algebraMap (RatFunc K) (normalClosure (RatFunc K) F (AlgebraicClosure F)) (algebraMap K[X]
+        (RatFunc K) p) :=
+    (IsScalarTower.algebraMap_apply (RatFunc K) F _ _).symm
+  have hordW : W.ord (algebraMap (RatFunc K) (normalClosure (RatFunc K) F (AlgebraicClosure F))
+        (algebraMap K[X] (RatFunc K) p))
+      = W.ramificationIndex F * w.ord (algebraMap (RatFunc K) F (algebraMap K[X] (RatFunc K) p))
+        := by
+    rw [← hpM, W.ord_restrict (F := F), hWw]
+  have he := W.ramificationIndex_pos (F := F)
+  have hWpos : 0 < W.ord (algebraMap (RatFunc K) (normalClosure (RatFunc K) F (AlgebraicClosure F))
+      (algebraMap K[X] (RatFunc K) p)) := by
+    rw [hordW]; exact mul_pos (by exact_mod_cast he) hw
+  have hdvd :=
+    AlgebraicCurve.Place.ord_dvd_of_hahnSeries_embedding_of_isGalois p hp a ha ha' hd ΨM hΨMX hΨM W
+      hWpos
+  rw [hordW] at hdvd
+  exact dvd_of_mul_left_dvd hdvd
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.isRoot_map_Phi_apply_jBar_of_dvd (L : Type*) [Field L] [Algebra ℚ L]
+    (N : ℕ) [NeZero N]
+    (d : ℕ) [NeZero d] (hd : d ∣ N) (dd : ModularPolynomialData d) (A : Type*) [CommRing A]
+    [Algebra L A]
+    (φ : laurentBaseChange L (modularFunctionFieldFull N) →ₐ[L] A) :
+    (dd.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom A)
+      (φ ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩))).IsRoot
+      (φ ⟨coeffEmb L (qExpand ℚ d jq),
+        coeffEmb_mem_laurentBaseChange L (jqd_mem_full N hd)⟩) :=
+  ModularCurve.isRoot_map_Φ_apply_jBar_of_dvd L N hd dd φ
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.isRoot_map_Phi_apply_jBar (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ)
+    [NeZero N]
+    (data : ModularPolynomialData N) (A : Type*) [CommRing A] [Algebra L A]
+    (φ : laurentBaseChange L (modularFunctionFieldFull N) →ₐ[L] A) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom A)
+      (φ ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩))).IsRoot
+      (φ ⟨coeffEmb L (qExpand ℚ N jq),
+        coeffEmb_mem_laurentBaseChange L (jqd_mem_full N (dvd_refl N))⟩) :=
+  ModularCurve.isRoot_map_Φ_apply_jBar L N data φ
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_isRoot_map_Phi_apply_jBar.ModularCurve in
+theorem solution (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N]
+    (data : ModularPolynomialData N) (A : Type*) [CommRing A] [Algebra L A]
+    (φ : laurentBaseChange L (modularFunctionFieldFull N) →ₐ[L] A) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom A)
+      (φ ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩))).IsRoot
+      (φ ⟨coeffEmb L (qExpand ℚ N jq),
+        coeffEmb_mem_laurentBaseChange L (jqd_mem_full N (dvd_refl N))⟩) :=
+  ModularCurve.isRoot_map_Phi_apply_jBar L N data A φ
+
+end S_ModularCurve_isRoot_map_Phi_apply_jBar
+end P2MW
+export P2MW.S_ModularCurve_isRoot_map_Phi_apply_jBar (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.isRoot_map_Phi_apply_jBar (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ)
+    [NeZero N]
+    (data : ModularPolynomialData N) (A : Type*) [CommRing A] [Algebra L A]
+    (φ : laurentBaseChange L (modularFunctionFieldFull N) →ₐ[L] A) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom A)
+      (φ ⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩))).IsRoot
+      (φ ⟨coeffEmb L (qExpand ℚ N jq),
+        coeffEmb_mem_laurentBaseChange L (jqd_mem_full N (dvd_refl N))⟩) :=
+  solution L N data A φ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isSeparable_adjoin_coeffEmb_jq_full.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isSeparable_adjoin_coeffEmb_jq_full.lean
new file mode 100644
index 0000000000..01260c145e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_isSeparable_adjoin_coeffEmb_jq_full.lean
@@ -0,0 +1,154 @@
+/-
+Based on Prove2Me node ModularCurve.isSeparable_adjoin_coeffEmb_jq_full
+(d0d9ec31-a391-53e5-a27c-c93ffbc9fdf0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f70ee2ba-e9e0-5c2f-8322-1ac18b4a5277
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlace
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_laurentBaseChange_modularFunctionFieldFull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_pos
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Separability of the full modular function field over L(j)
+
+Theorem statement: `ModularCurve.isSeparable_adjoin_coeffEmb_jq_full`
+(`d0d9ec31-a391-53e5-a27c-c93ffbc9fdf0`), by Claude, 2026-09-05.
+
+Proof: submission `f70ee2ba-e9e0-5c2f-8322-1ac18b4a5277`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbb{Q}$-algebra structure and let $N$ be a nonzero natural
+number. Write $jq \in \mathbb{Q}((q))$ for the Laurent series $q^{-1}$ times the power series
+`jNumQ` obtained from `jNum` by coefficientwise reduction into $\mathbb{Q}$, and let
+`modularFunctionFieldFull N` be the intermediate field of $\mathbb{Q}((q))$ generated over
+$\mathbb{Q}$ by the set `divisorExpansions N`, i.e. by the elements `qExpand ℚ d jq` for the nonzero
+divisors $d$ of $N$. Let `coeffEmb L` be the ring homomorphism $\mathbb{Q}((q)) \to L((q))$ applying
+$\mathbb{Q} \to L$ to each coefficient, and let $E =$ `laurentBaseChange L (modularFunctionFieldFull
+N)` be the intermediate field of $L((q))$ generated over $L$ by the image under `coeffEmb L` of
+`modularFunctionFieldFull N`. Since `coeffEmb L jq` lies in $E$, it determines an element of $E$,
+and one may form the intermediate field $X \subseteq E$ generated over $L$ by that single element.
+The assertion is `Algebra.IsSeparable X E`: every element of $E$ is integral over $X$ with separable
+minimal polynomial.
+
+This is the separability of the covering of the $j$-line by the modular curve of level $N$, in the
+base-changed Laurent-series model with constant field $L$ and with the ground field taken to be the
+subfield generated by the single $q$-expansion of $j$. It is the hypothesis under which $dj$
+generates the module of Kähler differentials of the modular function field, and it is used in the
+treatment of differentials and $q$-expansions on modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_isSeparable_adjoin_coeffEmb_jq_full.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_isSeparable_adjoin_coeffEmb_jq_full
+
+p2m_open "ModularCurve~modularFunctionFieldBar \
+  P2MW.S_ModularCurve_isSeparable_adjoin_coeffEmb_jq_full.ModularCurve"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jq dedekindPsi modularFunctionFieldFull coeffEmb laurentBaseChange \
+  coeffEmb_mem_laurentBaseChange relfinrank_laurentBaseChange_modularFunctionFieldFull jq_mem_full \
+  relfinrank_full_eq_dedekindPsi dedekindPsi_pos"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+private theorem ModularCurve.finiteDimensional_adjoin_coeffEmb_jq_full (L : Type*) [Field L]
+    [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    FiniteDimensional (IntermediateField.adjoin L ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L
+      (jq_mem_full N)⟩} : Set (laurentBaseChange L (modularFunctionFieldFull N))))
+      (laurentBaseChange L (modularFunctionFieldFull N)) := by
+  have hmap : (IntermediateField.adjoin L
+        ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩} :
+          Set (laurentBaseChange L (modularFunctionFieldFull N)))).map
+        (laurentBaseChange L (modularFunctionFieldFull N)).val =
+      IntermediateField.adjoin L ({coeffEmb L jq} : Set (LaurentSeries L)) := by
+    have h :=
+      IntermediateField.adjoin_map (F := L) (E := laurentBaseChange L (modularFunctionFieldFull N))
+      (S := ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩} :
+        Set (laurentBaseChange L (modularFunctionFieldFull N))))
+      (laurentBaseChange L (modularFunctionFieldFull N)).val
+    rw [Set.image_singleton] at h
+    exact h
+  have hcomap : (IntermediateField.adjoin L ({coeffEmb L jq} : Set (LaurentSeries L))).comap
+        (laurentBaseChange L (modularFunctionFieldFull N)).val =
+      IntermediateField.adjoin L
+        ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩} :
+          Set (laurentBaseChange L (modularFunctionFieldFull N))) := by
+    rw [← hmap, IntermediateField.comap_map]
+  have hrank : Module.finrank
+      ((IntermediateField.adjoin L ({coeffEmb L jq} : Set (LaurentSeries L))).comap
+        (laurentBaseChange L (modularFunctionFieldFull N)).val)
+      (laurentBaseChange L (modularFunctionFieldFull N)) = dedekindPsi N := by
+    rw [IntermediateField.finrank_comap, IntermediateField.fieldRange_val,
+      relfinrank_laurentBaseChange_modularFunctionFieldFull, relfinrank_full_eq_dedekindPsi]
+  have hfin : FiniteDimensional
+      ((IntermediateField.adjoin L ({coeffEmb L jq} : Set (LaurentSeries L))).comap
+        (laurentBaseChange L (modularFunctionFieldFull N)).val)
+      (laurentBaseChange L (modularFunctionFieldFull N)) :=
+    Module.finite_of_finrank_pos (by rw [hrank]; exact dedekindPsi_pos N (NeZero.ne N))
+  rwa [hcomap] at hfin
+
+p2m_open_scoped "ModularCurve" in
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+private theorem ModularCurve.isSeparable_adjoin_coeffEmb_jq_full (L : Type*) [Field L] [Algebra ℚ L]
+    (N : ℕ) [NeZero N] :
+    Algebra.IsSeparable (IntermediateField.adjoin L ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange
+      L (jq_mem_full N)⟩} : Set (laurentBaseChange L (modularFunctionFieldFull N))))
+      (laurentBaseChange L (modularFunctionFieldFull N)) := by
+  set X : IntermediateField L (laurentBaseChange L (modularFunctionFieldFull N)) :=
+    IntermediateField.adjoin L ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full
+      N)⟩} :
+      Set (laurentBaseChange L (modularFunctionFieldFull N))) with hX
+  have : FiniteDimensional X (laurentBaseChange L (modularFunctionFieldFull N)) :=
+    finiteDimensional_adjoin_coeffEmb_jq_full L N
+  have : CharZero L := charZero_of_injective_algebraMap (algebraMap ℚ L).injective
+  have : CharZero X := charZero_of_injective_algebraMap (algebraMap L X).injective
+  infer_instance
+
+p2m_open "ModularCurve~modularFunctionFieldBar\
+  " in
+open _root_.P2MW.S_ModularCurve_isSeparable_adjoin_coeffEmb_jq_full.ModularCurve in
+theorem solution (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    Algebra.IsSeparable (IntermediateField.adjoin L ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange
+      L (jq_mem_full N)⟩} : Set (laurentBaseChange L (modularFunctionFieldFull N))))
+      (laurentBaseChange L (modularFunctionFieldFull N)) :=
+  ModularCurve.isSeparable_adjoin_coeffEmb_jq_full L N
+
+end S_ModularCurve_isSeparable_adjoin_coeffEmb_jq_full
+end P2MW
+export P2MW.S_ModularCurve_isSeparable_adjoin_coeffEmb_jq_full (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.isSeparable_adjoin_coeffEmb_jq_full (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ)
+    [NeZero N] :
+    Algebra.IsSeparable (IntermediateField.adjoin L ({⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange
+      L (jq_mem_full N)⟩} : Set (laurentBaseChange L (modularFunctionFieldFull N))))
+      (laurentBaseChange L (modularFunctionFieldFull N)) :=
+  solution L N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jCoordinate_spec_modularFunctionFieldBar.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jCoordinate_spec_modularFunctionFieldBar.lean
new file mode 100644
index 0000000000..2f7512876a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jCoordinate_spec_modularFunctionFieldBar.lean
@@ -0,0 +1,289 @@
+/-
+Based on Prove2Me node ModularCurve.jCoordinate_spec_modularFunctionFieldBar
+(408383eb-30ec-5fbd-ae5b-f0942d44a202) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9b2a04a5-501e-5c2d-9dca-c20e8ba09f76
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_AtkinLehner
+
+import Mathlib.NumberTheory.Height.NumberField
+import Mathlib.NumberTheory.Height.Projectivization
+import Mathlib.Order.Northcott
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_full
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_toValuationSubring_eq_comap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_algebraMap_eq_mul_ord
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_eq_placeOfPoint_or_eq_placeInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_placeOfPoint_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_cuspInftyBar_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_transcendental_of_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasPrincipalDivisors_modularFunctionFieldBar_unconditional
+
+/-!
+# Values of the j-coordinate at places of X₀(N)
+
+Theorem statement: `ModularCurve.jCoordinate_spec_modularFunctionFieldBar`
+(`408383eb-30ec-5fbd-ae5b-f0942d44a202`), by Claude, 2026-09-05.
+
+Proof: submission `9b2a04a5-501e-5c2d-9dca-c20e8ba09f76`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a non-zero natural number. Let $\bar{\jmath}$ denote the element of the intermediate
+field $\overline{\mathbb{Q}} \subseteq$ `modularFunctionFieldBar N` $\subseteq
+\overline{\mathbb{Q}}((q))$ obtained by applying `coeffEmb` (coefficientwise application of
+$\mathbb{Q} \to \overline{\mathbb{Q}}$ to a Laurent series) to `jq` $= q^{-1} \cdot$ `jNumQ`, the
+$q$-expansion of the modular invariant $j$; here `modularFunctionFieldBar N` is the field generated
+over $\overline{\mathbb{Q}}$ inside $\overline{\mathbb{Q}}((q))$ by the `coeffEmb`-images of
+`modularFunctionFieldFull N` $= \mathbb{Q}(\mathrm{divisorExpansions}\ N)$, and the membership of
+$\bar{\jmath}$ is supplied by `coeffEmb_mem_laurentBaseChange` applied to `jq_mem_full N`. Places
+here are the structures `Place` $\overline{\mathbb{Q}}$ (`modularFunctionFieldBar N`): valuation
+subrings containing the constants $\overline{\mathbb{Q}}$, proper, and principal ideal rings; `ord`
+is the associated $\mathbb{Z}$-valued order function. The conclusion is the conjunction of three
+assertions: (1) for every such place $v$ with $v.\mathrm{ord}\,\bar{\jmath} \ge 0$ there is exactly
+one constant $c \in \overline{\mathbb{Q}}$ with $v.\mathrm{ord}(\bar{\jmath} - c) > 0$; (2) for
+every $c \in \overline{\mathbb{Q}}$ the set of places $v$ with $v.\mathrm{ord}(\bar{\jmath} - c) >
+0$ is finite; (3) the set of places $v$ with $v.\mathrm{ord}\,\bar{\jmath} < 0$ is finite.
+
+This is the statement that the $j$-coordinate defines a finite map from the places of the geometric
+function field of $X_0(N)$ to $\mathbb{P}^1$ over $\overline{\mathbb{Q}}$: every place at which
+$\bar{\jmath}$ is regular has a well-defined value in $\overline{\mathbb{Q}}$ (so residue fields are
+$\overline{\mathbb{Q}}$), fibres over constants are finite, and the poles, i.e. the cusps, are
+finitely many. It is used in the comparison of the naive logarithmic height of the $j$-coordinate
+with the height attached to places, and in the Northcott property for that height.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_jCoordinate_spec_modularFunctionFieldBar.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open ModularCurve AlgebraicCurve
+
+section GenericHelpers
+
+variable {K L : Type*} [Field K] [Field L] [Algebra K L]
+
+private lemma mwP2_ord_pos_iff (v : Place K L) {f : L} (hf : f ≠ 0) :
+    0 < v.ord f ↔ v.adicValuation f < 1 := by
+  have hval : v.adicValuation f ≠ 0 := v.adicValuation_ne_zero hf
+  have hdef : v.ord f = -(WithZero.log (v.adicValuation f)) := rfl
+  constructor
+  · intro h
+    have hlog : WithZero.log (v.adicValuation f) < 0 := by
+      rw [hdef] at h; omega
+    calc v.adicValuation f
+        = WithZero.exp (WithZero.log (v.adicValuation f)) := (WithZero.exp_log hval).symm
+      _ < WithZero.exp 0 := WithZero.exp_lt_exp.mpr hlog
+      _ = 1 := WithZero.exp_zero
+  · intro h
+    have h2 : WithZero.exp (WithZero.log (v.adicValuation f)) < WithZero.exp (0 : ℤ) := by
+      rw [WithZero.exp_log hval, WithZero.exp_zero]; exact h
+    have hlog := WithZero.exp_lt_exp.mp h2
+    rw [hdef]; omega
+
+private lemma mwP2_eq_of_ord_sub_pos (v : Place K L) {x : L} {a b : K}
+    (ha : 0 < v.ord (x - algebraMap K L a)) (hb : 0 < v.ord (x - algebraMap K L b)) :
+    b = a := by
+  by_contra hne
+  have ha0 : x - algebraMap K L a ≠ 0 := by
+    intro h; rw [h, Place.ord_zero] at ha; omega
+  have hb0 : x - algebraMap K L b ≠ 0 := by
+    intro h; rw [h, Place.ord_zero] at hb; omega
+  have hva : v.adicValuation (x - algebraMap K L a) < 1 := (mwP2_ord_pos_iff v ha0).mp ha
+  have hvb : v.adicValuation (x - algebraMap K L b) < 1 := (mwP2_ord_pos_iff v hb0).mp hb
+  have hδ : algebraMap K L (a - b) = (x - algebraMap K L b) - (x - algebraMap K L a) := by
+    rw [map_sub]; ring
+  have hab : a - b ≠ 0 := sub_ne_zero.mpr (Ne.symm hne)
+  have hδ0 : algebraMap K L (a - b) ≠ 0 :=
+    (map_ne_zero_iff _ (algebraMap K L).injective).mpr hab
+  have hval1 : v.adicValuation (algebraMap K L (a - b)) = 1 :=
+    (v.ord_eq_zero_iff_adicValuation_eq_one hδ0).mp (Place.ord_algebraMap v (a - b))
+  have hle : v.adicValuation (algebraMap K L (a - b)) ≤
+      max (v.adicValuation (x - algebraMap K L b)) (v.adicValuation (x - algebraMap K L a)) := by
+    rw [hδ, sub_eq_add_neg]
+    refine le_trans (v.adicValuation.map_add _ _) ?_
+    rw [Valuation.map_neg]
+  rw [hval1] at hle
+  rcases le_max_iff.mp hle with h | h
+  · exact absurd (lt_of_le_of_lt h hvb) (lt_irrefl _)
+  · exact absurd (lt_of_le_of_lt h hva) (lt_irrefl _)
+
+private lemma mwP2_finite_ord_support [HasPrincipalDivisors K L] {f : L} (hf : f ≠ 0) :
+    {v : Place K L | v.ord f ≠ 0}.Finite := by
+  obtain ⟨D, hD, -⟩ := HasPrincipalDivisors.exists_divisor (K := K) (F := L) f hf
+  refine Set.Finite.subset D.support.finite_toSet fun v hv => ?_
+  simp only [Set.mem_ofPred_eq] at hv
+  exact Finset.mem_coe.mpr (Finsupp.mem_support_iff.mpr (by rw [hD v]; exact hv))
+
+private lemma mwP2_module_finite_of_adjoin {R : Type*} [Field R] [Algebra R L]
+    (E : IntermediateField K L) (hFD : FiniteDimensional E L)
+    (hsurj : ∀ y : E, ∃ r : R, algebraMap R L r = y) :
+    Module.Finite R L := by
+  obtain ⟨s, hs⟩ := Module.finite_def.mp hFD
+  refine Module.finite_def.mpr ⟨s, ?_⟩
+  rw [eq_top_iff]
+  rintro z -
+  have hz : z ∈ Submodule.span E (↑s : Set L) := by rw [hs]; exact Submodule.mem_top
+  induction hz using Submodule.span_induction with
+  | mem y hy => exact Submodule.subset_span hy
+  | zero => exact Submodule.zero_mem _
+  | add y z' _ _ ihy ihz => exact Submodule.add_mem _ ihy ihz
+  | smul e y _ ihy =>
+      obtain ⟨r, hr⟩ := hsurj e
+      have hsm : e • y = r • y := by
+        rw [Algebra.smul_def, Algebra.smul_def, IntermediateField.algebraMap_apply, hr]
+      rw [hsm]
+      exact Submodule.smul_mem _ _ ihy
+
+private theorem mwP2_exists_unique_coord [IsAlgClosed K] {x : L}
+    (htr : Transcendental K x)
+    (hFD : FiniteDimensional (IntermediateField.adjoin K ({x} : Set L)) L)
+    (v : Place K L) (hv : 0 ≤ v.ord x) :
+    ∃! c : K, 0 < v.ord (x - algebraMap K L c) := by
+  have hinj : Function.Injective (Polynomial.aeval x : Polynomial K →ₐ[K] L) :=
+    transcendental_iff_injective.mp htr
+  have hφ0 := nonZeroDivisors_le_comap_nonZeroDivisors_of_injective _ hinj
+  let : Algebra (RatFunc K) L := (RatFunc.liftAlgHom (Polynomial.aeval x) hφ0).toRingHom.toAlgebra
+  have hψalg : ∀ p : Polynomial K,
+      algebraMap (RatFunc K) L (algebraMap (Polynomial K) (RatFunc K) p)
+        = Polynomial.aeval x p := by
+    intro p
+    have h := RatFunc.liftAlgHom_apply_div (Polynomial.aeval x) hφ0 p 1
+    simp only [map_one, div_one] at h
+    exact h
+  have : IsScalarTower K (RatFunc K) L :=
+    IsScalarTower.of_algebraMap_eq fun c =>
+      ((RatFunc.liftAlgHom (Polynomial.aeval x) hφ0).commutes c).symm
+  have : Module.Finite (RatFunc K) L := by
+    refine mwP2_module_finite_of_adjoin (IntermediateField.adjoin K ({x} : Set L)) hFD ?_
+    intro y
+    obtain ⟨p, q, hpq⟩ := (IntermediateField.mem_adjoin_simple_iff K (y : L)).mp y.2
+    refine ⟨algebraMap (Polynomial K) (RatFunc K) p / algebraMap (Polynomial K) (RatFunc K) q, ?_⟩
+    rw [map_div₀, hψalg, hψalg]
+    exact hpq.symm
+  have : Algebra.IsIntegral (RatFunc K) L := Algebra.IsIntegral.of_finite _ _
+  obtain ⟨v₀, hv₀⟩ := Place.exists_toValuationSubring_eq_comap (K := K) (F := RatFunc K) v
+  obtain ⟨e, he, hord⟩ := Place.exists_ord_algebraMap_eq_mul_ord v v₀ hv₀
+  have : DecidableEq (RatFunc K) := Classical.decEq _
+  rcases RationalFunctionField.eq_placeOfPoint_or_eq_placeInfty K v₀ with ⟨a, ha⟩ | hinf
+  · have hXa : (Polynomial.X - Polynomial.C a : Polynomial K) ≠ 0 := Polynomial.X_sub_C_ne_zero a
+    have h1 : v₀.ord (algebraMap (Polynomial K) (RatFunc K) (Polynomial.X - Polynomial.C a)) = 1 :=
+      by
+      rw [ha, RationalFunctionField.ord_placeOfPoint_algebraMap a hXa,
+        Polynomial.rootMultiplicity_X_sub_C_self]
+      simp
+    have h2 : algebraMap (RatFunc K) L
+        (algebraMap (Polynomial K) (RatFunc K) (Polynomial.X - Polynomial.C a))
+        = x - algebraMap K L a := by
+      rw [hψalg, map_sub, Polynomial.aeval_X, Polynomial.aeval_C]
+    have h3 : 0 < v.ord (x - algebraMap K L a) := by
+      rw [← h2, hord, h1, mul_one]
+      exact_mod_cast he
+    exact ⟨a, h3, fun y hy => mwP2_eq_of_ord_sub_pos v h3 hy⟩
+  · exfalso
+    have h1 : v₀.ord (algebraMap (Polynomial K) (RatFunc K) Polynomial.X) = -1 := by
+      rw [hinf, RationalFunctionField.ord_placeInfty_algebraMap Polynomial.X_ne_zero,
+        Polynomial.natDegree_X]
+      simp
+    have h2 : algebraMap (RatFunc K) L (algebraMap (Polynomial K) (RatFunc K) Polynomial.X)
+        = x := by
+      rw [hψalg, Polynomial.aeval_X]
+    have h3 : v.ord x = -(e : ℤ) := by
+      rw [← h2, hord, h1]
+      ring
+    rw [h3] at hv
+    have he' : (0 : ℤ) < (e : ℤ) := mod_cast he
+    omega
+
+end GenericHelpers
+
+theorem solution (N : ℕ) [NeZero N] :
+    (∀ (v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)),
+        0 ≤ v.ord ⟨coeffEmb (AlgebraicClosure ℚ) jq,
+          coeffEmb_mem_laurentBaseChange (L := AlgebraicClosure ℚ) (hx := jq_mem_full N)⟩ →
+        ∃! c : AlgebraicClosure ℚ,
+          0 < v.ord (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+              coeffEmb_mem_laurentBaseChange (L := AlgebraicClosure ℚ) (hx := jq_mem_full N)⟩ -
+            algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) c)) ∧
+      (∀ c : AlgebraicClosure ℚ,
+        {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) |
+          0 < v.ord (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+              coeffEmb_mem_laurentBaseChange (L := AlgebraicClosure ℚ) (hx := jq_mem_full N)⟩ -
+            algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) c)}.Finite) ∧
+      ({v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) |
+        v.ord ⟨coeffEmb (AlgebraicClosure ℚ) jq,
+          coeffEmb_mem_laurentBaseChange (L := AlgebraicClosure ℚ) (hx := jq_mem_full N)⟩ <
+            0}.Finite) := by
+  have hcusp : (cuspInftyBar N).ord
+      ⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (L := AlgebraicClosure ℚ) (hx := jq_mem_full N)⟩ = -1 :=
+    ModularCurve.ord_cuspInftyBar_coeffEmb_jq N
+  have htr : Transcendental (AlgebraicClosure ℚ)
+      (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (L := AlgebraicClosure ℚ) (hx := jq_mem_full N)⟩ :
+        modularFunctionFieldBar N) :=
+    Place.transcendental_of_ord_ne_zero (cuspInftyBar N) (by rw [hcusp]; omega)
+  have hjb0 : (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+      coeffEmb_mem_laurentBaseChange (L := AlgebraicClosure ℚ) (hx := jq_mem_full N)⟩ :
+      modularFunctionFieldBar N) ≠ 0 := by
+    intro h
+    rw [h, Place.ord_zero] at hcusp
+    omega
+  have hFD := ModularCurve.finiteDimensional_adjoin_coeffEmb_jq_full (AlgebraicClosure ℚ) N
+  have hpd : HasPrincipalDivisors (AlgebraicClosure ℚ) (modularFunctionFieldBar N) :=
+    ModularCurve.hasPrincipalDivisors_modularFunctionFieldBar_unconditional N
+  refine ⟨fun v hv => mwP2_exists_unique_coord htr hFD v hv, fun c => ?_, ?_⟩
+  · have hne : (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (L := AlgebraicClosure ℚ) (hx := jq_mem_full N)⟩ :
+        modularFunctionFieldBar N)
+        - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) c ≠ 0 := by
+      rw [sub_ne_zero]
+      intro h
+      exact htr (by rw [h]; exact isAlgebraic_algebraMap c)
+    refine Set.Finite.subset (mwP2_finite_ord_support hne) fun v hv => ?_
+    simp only [Set.mem_ofPred_eq] at hv ⊢
+    omega
+  · refine Set.Finite.subset (mwP2_finite_ord_support hjb0) fun v hv => ?_
+    simp only [Set.mem_ofPred_eq] at hv ⊢
+    omega
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.jCoordinate_spec_modularFunctionFieldBar (N : ℕ) [NeZero N] :
+    (∀ (v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)),
+        0 ≤ v.ord ⟨coeffEmb (AlgebraicClosure ℚ) jq,
+          coeffEmb_mem_laurentBaseChange (L := AlgebraicClosure ℚ) (hx := jq_mem_full N)⟩ →
+        ∃! c : AlgebraicClosure ℚ,
+          0 < v.ord (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+              coeffEmb_mem_laurentBaseChange (L := AlgebraicClosure ℚ) (hx := jq_mem_full N)⟩ -
+            algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) c)) ∧
+      (∀ c : AlgebraicClosure ℚ,
+        {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) |
+          0 < v.ord (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+              coeffEmb_mem_laurentBaseChange (L := AlgebraicClosure ℚ) (hx := jq_mem_full N)⟩ -
+            algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) c)}.Finite) ∧
+      ({v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) |
+        v.ord ⟨coeffEmb (AlgebraicClosure ℚ) jq,
+          coeffEmb_mem_laurentBaseChange (L := AlgebraicClosure ℚ) (hx := jq_mem_full N)⟩ <
+            0}.Finite) :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant.lean
new file mode 100644
index 0000000000..0219c2ca73
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant.lean
@@ -0,0 +1,180 @@
+/-
+Based on Prove2Me node ModularCurve.jqModC_eq_qExpansion_E4_cube_div_discriminant
+(6b7bf396-6702-5f9a-988d-6db3bb11ca4d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 34fee5c2-69e4-5e37-830f-b0a155cb358e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import Mathlib.NumberTheory.ModularForms.LevelOne.DimensionFormula
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_jq_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_mul_laurent
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurent_qParam_coeff_unique
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# j-series over ℂ equals E₄³/Δ in ℂ((q))
+
+Theorem statement: `ModularCurve.jqModC_eq_qExpansion_E4_cube_div_discriminant`
+(`6b7bf396-6702-5f9a-988d-6db3bb11ca4d`), by Claude, 2026-09-05.
+
+Proof: submission `34fee5c2-69e4-5e37-830f-b0a155cb358e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+The assertion is an identity between two elements of the field $\mathbb{C}((q))$ of Laurent series,
+with no variables or hypotheses. On the left stands [`ModularCurve.jqModC
+ℂ`](def/ModularCurve_JqCoeff.html#L15), i.e. the Hahn series $\mathrm{single}(-1)\,1$ (the monomial
+$q^{-1}$) multiplied by the image under `HahnSeries.ofPowerSeries` of the integral power series
+[`ModularCurve.jNum`](def/ModularCurve_X0.html#L142), which is $E_4$-series cubed times the inverse
+unit attached to the Dedekind eta product, with its integer coefficients pushed forward along
+$\mathbb{Z} \to \mathbb{C}$; thus it is the Laurent series whose coefficient in degree $m$ is the
+degree-$(m+1)$ coefficient of `jNum`, read in $\mathbb{C}$. On the right stands the quotient, taken
+in $\mathbb{C}((q))$, of the cube of the width-one $q$-expansion of the weight-four Eisenstein
+series `ModularForm.E₄`, viewed as a function $\mathbb{H} \to \mathbb{C}$ and coerced from a power
+series to a Laurent series, by the width-one $q$-expansion of `ModularForm.discriminant`, coerced
+the same way. The theorem states that these two Laurent series coincide; in particular the
+denominator is a nonzero element of the field $\mathbb{C}((q))$, so the quotient on the right is the
+genuine one.
+
+This is the classical identity $j = E_4^3/\Delta$, here in the form which identifies the
+arithmetically defined $q$-series of $j$ used on the algebraic side of the modular-curve development
+with the quotient of the analytic $q$-expansions of $E_4$ and $\Delta$. It is the bridge between the
+two descriptions of the coefficient field $\mathbb{C}(j)$ and is used throughout the later work on
+modular functions, $q$-expansions of cusp forms and the associated period and Abel–Jacobi
+statements.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant
+
+open UpperHalfPlane
+open scoped MatrixGroups
+
+namespace SolJJ1Aux
+
+private theorem hasSum_int {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} {F : Type*} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) (τ : ℍ) :
+    HasSum (fun m : ℤ =>
+      ((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ).coeff m *
+        Function.Periodic.qParam 1 (τ : ℂ) ^ m) (f τ) := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  have h0 := UpperHalfPlane.hasSum_qExpansion (f := (f : ℍ → ℂ)) one_pos
+    (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (ModularFormClass.holo f)
+    (ModularFormClass.bdd_at_infty f) τ
+  refine (Function.Injective.hasSum_iff Nat.cast_injective ?_).mp ?_
+  · intro m hm
+    rcases m with n | n
+    · exact absurd ⟨n, rfl⟩ hm
+    · rw [ModularCurve.ofPowerSeries_coeff_of_neg _ (Int.negSucc_lt_zero n), zero_mul]
+  · have hcomp : ((fun m : ℤ =>
+        ((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ).coeff m *
+          Function.Periodic.qParam 1 (τ : ℂ) ^ m) ∘ (Nat.cast : ℕ → ℤ)) =
+        fun n : ℕ => (qExpansion 1 (f : ℍ → ℂ)).coeff n •
+          Function.Periodic.qParam 1 (τ : ℂ) ^ n := by
+      funext n
+      simp only [Function.comp_apply, smul_eq_mul, zpow_natCast,
+        LaurentSeries.coeff_coe_powerSeries]
+    rw [hcomp]
+    exact h0
+
+end SolJJ1Aux
+
+theorem solution : ModularCurve.jqModC ℂ =
+    (((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) ^ 3 /
+      ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)) := by
+  have hc : ∀ m : ℤ, (ModularCurve.jqModC ℂ).coeff m = ((ModularCurve.jq.coeff m : ℚ) : ℂ) := by
+    intro m
+    rw [← ModularCurve.coeffEmb_jq, ModularCurve.coeffEmb_coeff]
+    exact eq_ratCast _ _
+  have hjq : ∀ τ : ℍ, HasSum (fun m : ℤ => (ModularCurve.jqModC ℂ).coeff m *
+      Function.Periodic.qParam 1 (τ : ℂ) ^ m)
+      (ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) := by
+    intro τ
+    have h := ModularCurve.hasSum_jq_qParam τ
+    simp only [← hc] at h
+    exact h
+  have hΔ : ∀ τ : ℍ, HasSum (fun m : ℤ =>
+      ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) :
+        LaurentSeries ℂ).coeff m *
+        Function.Periodic.qParam 1 (τ : ℂ) ^ m) (ModularForm.discriminant τ) := fun τ =>
+    SolJJ1Aux.hasSum_int CuspForm.discriminant one_mem_strictPeriods_SL τ
+  have hcube : ∀ τ : ℍ, HasSum (fun m : ℤ =>
+      (((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) : PowerSeries ℂ) :
+        LaurentSeries ℂ) ^ 3).coeff m *
+        Function.Periodic.qParam 1 (τ : ℂ) ^ m) (ModularForm.E₄ τ ^ 3) := by
+    intro τ
+    have h := SolJJ1Aux.hasSum_int (ModularForm.E₄.pow 3) one_mem_strictPeriods_SL τ
+    have h1 : qExpansion 1 ((ModularForm.E₄.pow 3) : ℍ → ℂ) =
+        (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) ^ 3 :=
+      ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL ModularForm.E₄ 3
+    have h2 : (ModularForm.E₄.pow 3) τ = ModularForm.E₄ τ ^ 3 := by
+      rw [ModularForm.coe_pow, Pi.pow_apply]
+    rw [h1, PowerSeries.coe_pow, h2] at h
+    exact h
+  have hmul : ∀ τ : ℍ, HasSum (fun m : ℤ =>
+      ((ModularCurve.jqModC ℂ *
+        ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) :
+          LaurentSeries ℂ)).coeff m) *
+        Function.Periodic.qParam 1 (τ : ℂ) ^ m) (ModularForm.E₄ τ ^ 3) := by
+    intro τ
+    have h : HasSum (fun m : ℤ =>
+        ((ModularCurve.jqModC ℂ *
+          ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) :
+            LaurentSeries ℂ)).coeff m) *
+          Function.Periodic.qParam 1 (τ : ℂ) ^ m)
+        (ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ * ModularForm.discriminant τ) :=
+      ModularCurve.hasSum_qParam_mul_laurent 1 one_pos _ _ _ _ hjq hΔ τ
+    rwa [div_mul_cancel₀ _ (ModularForm.discriminant_ne_zero τ)] at h
+  have key : ModularCurve.jqModC ℂ *
+      ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+      ((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) ^ 3 :=
+    ModularCurve.laurent_qParam_coeff_unique 1 one_pos
+      (fun τ => ModularForm.E₄ τ ^ 3) _ _ hmul hcube
+  have hΔne : ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) ≠ 0 := by
+    intro h0
+    have h1 : qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) = 0 :=
+      HahnSeries.ofPowerSeries_injective (by rw [h0, map_zero])
+    have h2 := ModularForm.discriminant_qExpansion_coeff_one
+    rw [h1] at h2
+    simp at h2
+  rw [eq_div_iff hΔne]
+  exact key
+
+end S_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant
+end P2MW
+export P2MW.S_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane
+theorem ModularCurve.jqModC_eq_qExpansion_E4_cube_div_discriminant :
+    ModularCurve.jqModC ℂ = (((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) ^ 3 / ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ)) :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqModC_mem_intFormRatiosC.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqModC_mem_intFormRatiosC.lean
new file mode 100644
index 0000000000..ebc5f42a1a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqModC_mem_intFormRatiosC.lean
@@ -0,0 +1,155 @@
+/-
+Based on Prove2Me node ModularCurve.jqModC_mem_intFormRatiosC
+(ba43d59b-e15b-5d68-810c-9c701699d584) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5306c1cb-d541-58ef-979c-6dd8b0dfe090
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# j-series lies in the integral form ratios over any K, Γ
+
+Theorem statement: `ModularCurve.jqModC_mem_intFormRatiosC`
+(`ba43d59b-e15b-5d68-810c-9c701699d584`), by Claude, 2026-09-05.
+
+Proof: submission `5306c1cb-d541-58ef-979c-6dd8b0dfe090`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $\Gamma$ be an arbitrary subgroup of $\mathrm{SL}_2(\mathbb{Z})$. Write
+$\bar\jmath =$ [`ModularCurve.jqModC K`](def/ModularCurve_JqCoeff.html#L15) for the Laurent series
+over $K$ given by $X^{-1}$ (the Hahn series `single (-1) 1`) times the image in $K[[X]]$ of the
+integral power series `jNum` $=$ `eisenstein4`$^3 \cdot$ `dedekindEtaUnitInv`, the coefficients
+being reduced along $\mathbb{Z} \to K$. The assertion is that $\bar\jmath$ belongs to
+`intFormRatiosC K Γ`, i.e. that there are an integer $k$, two modular forms $f, g$ of weight $k$ for
+the image of $\Gamma$ in $\mathrm{GL}_2(\mathbb{R})$, and two power series $p_f, p_g \in
+\mathbb{Z}[[X]]$ such that $p_f$ and $p_g$, mapped to $\mathbb{C}[[X]]$, are the $q$-expansions
+(with respect to period $1$) of $f$ and of $g$ respectively, such that the reduction of $p_g$ to a
+Laurent series over $K$ is nonzero, and such that $\bar\jmath$ equals the quotient of the reductions
+of $p_f$ and $p_g$ in $K((X))$. The witnesses are $k = 12$, $f$ the restriction to $\Gamma$ of
+$E_4^3$ and $g$ the restriction to $\Gamma$ of the discriminant, with $p_f =$ `eisenstein4`$^3$ and
+$p_g = X \cdot$ `dedekindEtaUnit`.
+
+This is the classical identity $j = E_4^3/\Delta$, recorded in the shape needed here: the formal
+$q$-expansion of the modular invariant, read over an arbitrary coefficient field, is a ratio of
+$q$-expansions of two weight-$12$ forms with integral expansions on any subgroup of
+$\mathrm{SL}_2(\mathbb{Z})$. It supplies the transcendental element inside the $q$-expansion
+function field of a modular curve over $K$, and is used throughout the treatment of modular curves
+and their function fields, including in positive characteristic.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_jqModC_mem_intFormRatiosC.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_jqModC_mem_intFormRatiosC
+
+noncomputable section
+
+namespace JqMemRatios
+
+open ModularForm UpperHalfPlane EisensteinSeries ModularCurve HahnSeries
+open scoped MatrixGroups ModularForm
+
+theorem isIntegralQExp_E4 : IsIntegralQExp (E₄ : ℍ → ℂ) eisenstein4 := by
+  rw [isIntegralQExp_iff]
+  intro n
+  rw [E_qExpansion_coeff (by norm_num) (by decide) n, eisenstein4, PowerSeries.coeff_mk]
+  split_ifs with h
+  · simp
+  · rw [show _root_.bernoulli 4 = -1 / 30 by decide +kernel, ArithmeticFunction.sigma_apply]
+    push_cast
+    ring
+
+variable (Γ : Subgroup SL(2, ℤ))
+
+def e4cube : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12 :=
+  restrictForm (Subgroup.map_le_range _ Γ) ((E₄.pow 3).mcast (by norm_num))
+
+def delta : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12 :=
+  restrictForm (Subgroup.map_le_range _ Γ) (CuspForm.discriminant : ModularForm 𝒮ℒ 12)
+
+theorem isIntegralQExp_e4cube : IsIntegralQExp (e4cube Γ : ℍ → ℂ) (eisenstein4 ^ 3) := by
+  rw [IsIntegralQExp, e4cube, coe_restrictForm, map_pow, isIntegralQExp_E4,
+    ModularForm.qExpansion_mcast, ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+
+theorem coe_delta : (delta Γ : ℍ → ℂ) = ModularForm.discriminant := rfl
+
+theorem isIntegralQExp_delta :
+    IsIntegralQExp (delta Γ : ℍ → ℂ) (PowerSeries.X * dedekindEtaUnit) := by
+  rw [IsIntegralQExp, coe_delta]
+  exact ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit.symm
+
+variable (K : Type*) [Field K]
+
+theorem intSeriesC_delta_ne_zero : intSeriesC K (PowerSeries.X * dedekindEtaUnit) ≠ 0 := by
+  intro h
+  have h1 := congrArg (fun z : LaurentSeries K => z.coeff 1) h
+  simp only [intSeriesC, HahnSeries.coeff_zero] at h1
+  have h2 : (HahnSeries.ofPowerSeries ℤ K
+      ((PowerSeries.X * dedekindEtaUnit).map (Int.castRingHom K))).coeff ((1 : ℕ) : ℤ) = 1 := by
+    rw [HahnSeries.ofPowerSeries_apply_coeff, PowerSeries.coeff_map,
+      show (1 : ℕ) = 0 + 1 from rfl, PowerSeries.coeff_succ_X_mul,
+      PowerSeries.coeff_zero_eq_constantCoeff_apply, constantCoeff_dedekindEtaUnit, map_one]
+  rw [show ((1 : ℕ) : ℤ) = 1 from rfl] at h2
+  rw [h2] at h1
+  exact one_ne_zero h1
+
+theorem jqModC_mul_delta :
+    jqModC K * intSeriesC K (PowerSeries.X * dedekindEtaUnit) = intSeriesC K (eisenstein4 ^ 3) := by
+  rw [jqModC, intSeriesC, intSeriesC, jNum, mul_assoc, ← map_mul, ← map_mul,
+    show eisenstein4 ^ 3 * dedekindEtaUnitInv * (PowerSeries.X * dedekindEtaUnit) =
+      PowerSeries.X * eisenstein4 ^ 3 by
+        rw [mul_comm PowerSeries.X dedekindEtaUnit, ← mul_assoc, mul_assoc (eisenstein4 ^ 3),
+          mul_comm dedekindEtaUnitInv, dedekindEtaUnit_mul_inv, mul_one, mul_comm],
+    map_mul, PowerSeries.map_X, map_mul, HahnSeries.ofPowerSeries_X, ← mul_assoc,
+    HahnSeries.single_mul_single]
+  simp
+
+theorem jqModC_eq_div :
+    jqModC K = intSeriesC K (eisenstein4 ^ 3) / intSeriesC K (PowerSeries.X * dedekindEtaUnit) := by
+  rw [eq_div_iff (intSeriesC_delta_ne_zero K), jqModC_mul_delta]
+
+end JqMemRatios
+
+open JqMemRatios in
+theorem solution (K : Type*) [Field K]
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) :
+    ModularCurve.jqModC K ∈ ModularCurve.intFormRatiosC K Γ :=
+  ⟨12, e4cube Γ, delta Γ, ModularCurve.eisenstein4 ^ 3, PowerSeries.X *
+    ModularCurve.dedekindEtaUnit,
+    isIntegralQExp_e4cube Γ, isIntegralQExp_delta Γ, intSeriesC_delta_ne_zero K, jqModC_eq_div K⟩
+
+end
+
+end S_ModularCurve_jqModC_mem_intFormRatiosC
+end P2MW
+export P2MW.S_ModularCurve_jqModC_mem_intFormRatiosC (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.jqModC_mem_intFormRatiosC (K : Type*) [Field K]
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) :
+    ModularCurve.jqModC K ∈ ModularCurve.intFormRatiosC K Γ :=
+  solution K Γ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqNModC_mem_modularFunctionFieldC_mul_prime.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqNModC_mem_modularFunctionFieldC_mul_prime.lean
new file mode 100644
index 0000000000..f9077402fc
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqNModC_mem_modularFunctionFieldC_mul_prime.lean
@@ -0,0 +1,585 @@
+/-
+Based on Prove2Me node ModularCurve.jqNModC_mem_modularFunctionFieldC_mul_prime
+(70fb938d-e81f-5282-94a5-913bfeb20f1e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c0a268f2-8b0d-5141-bca9-ff57618a2bb4
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_neg_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_order_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_mul_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_of_mul_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot_of_isPrimitiveRoot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Polynomial_mem_range_of_unique_common_root
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_minpoly_jqNModC_map_eq_prod_slots
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Descent: j(q^M)∈ K(j(q),j(q^{Mp}))
+
+Theorem statement: `ModularCurve.jqNModC_mem_modularFunctionFieldC_mul_prime`
+(`70fb938d-e81f-5282-94a5-913bfeb20f1e`), by Claude, 2026-09-05.
+
+Proof: submission `c0a268f2-8b0d-5141-bca9-ff57618a2bb4`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, let $M$ be a nonzero natural number, let $p$ be a prime, and let $\zeta$ be a
+unit of $K$ whose underlying element is a primitive $(Mp)$-th root of unity in $K$. Write $j =$
+`jqModC K` for the formal $j$-expansion in $K((q))$, namely $q^{-1}$ times the image in
+`LaurentSeries K` of the power series $E_4^3\cdot\eta^{-24}$ (`jNum`) under the coefficient map
+$\mathbb{Z}\to K$, and for $N\neq 0$ write `jqNModC K N` for its image under `qExpand K N`, the ring
+endomorphism of `LaurentSeries K` multiplying all exponents by $N$ (so $j(q^N)$). Assume, for every
+divisor $d$ of $M$, both that the degree $[\,K(j)(j(q^d)) : K(j)\,]$ equals $\psi(d) = \sum_{d'\mid
+d,\ d' \text{ squarefree}} d/d'$ (Dedekind's psi, `dedekindPsi`), and that `modularFunctionFieldC K
+d`, by definition the subfield of $K((q))$ generated over $K$ by $j(q)$ and $j(q^d)$, coincides with
+the subfield generated over $K$ by all $j(q^{d'})$ with $d'\mid d$, $d'\neq 0$. The conclusion is
+that $j(q^M)$ lies in `modularFunctionFieldC K (M * p)`, i.e. in the subfield of $K((q))$ generated
+over $K$ by the two elements $j(q)$ and $j(q^{Mp})$.
+
+This is the downward (descent) step in the inductive study of the formal modular function fields
+$K(j(q),j(q^N))\subset K((q))$: the level-$M$ degree and generation data, together with the presence
+of a primitive $(Mp)$-th root of unity, force $j(q^M)$ to be the unique common root of
+$\Phi_p(j(q^{Mp}),Y)$ and of its own minimal polynomial over $K(j)$, hence to be rational over
+$K(j(q),j(q^{Mp}))$. It feeds into
+[`ModularCurve.package_of_socket`](thm.html#ModularCurve.package_of_socket), where the degree and
+generation statements are propagated to all levels.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_jqNModC_mem_modularFunctionFieldC_mul_prime.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_jqNModC_mem_modularFunctionFieldC_mul_prime
+
+noncomputable section
+
+p2m_open "ModularCurve \
+  P2MW.S_ModularCurve_jqNModC_mem_modularFunctionFieldC_mul_prime.ModularCurve ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_congr qExpand_qExpand dedekindPsi ModularPolynomialData coeffMap \
+  coeffMap_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm jqModC \
+  jqNModC map_jqModC modularFunctionFieldC jqModC_mem jqNModC_mem coeffMap_qExpand \
+  coeff_jqModC_neg_one order_jqModC PhiGen.splits_prime_at_slot_of_isPrimitiveRoot \
+  exists_phiIrreducible_evalSymm minpoly_jqNModC_map_eq_prod_slots"
+namespace W1
+p2m_open "ModularCurve"
+
+variable {K : Type*} [Field K]
+
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+theorem jqModC_eq_TS : jqModC K = TS K 1 1 := by
+  rw [TS, qTwist_one_apply, qExpand_one_apply]
+
+theorem jqNModC_eq_TS (d : ℕ) [NeZero d] : jqNModC K d = TS K d 1 := by
+  rw [jqNModC, TS, qTwist_one_apply]
+
+theorem qExpand_jqNModC (A d : ℕ) [NeZero A] [NeZero d] :
+    qExpand K A (jqNModC K d) = TS K (A * d) 1 := by
+  rw [jqNModC_eq_TS, qExpand_TS]
+
+theorem qExpand_jqModC_eq_TS (A : ℕ) [NeZero A] : qExpand K A (jqModC K) = TS K A 1 := by
+  rw [TS, qTwist_one_apply]
+
+theorem qTwist_qExpand_of_pow_eq_one (A : ℕ) [NeZero A] (v : Kˣ) (hv : v ^ A = 1)
+    (x : LaurentSeries K) :
+    qTwist v (qExpand K A x) = qExpand K A x := by
+  rw [qTwist_qExpand]
+  have : v ^ (A : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_congr qExpand_qExpand dedekindPsi ModularPolynomialData coeffMap \
+  coeffMap_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm jqModC \
+  jqNModC map_jqModC modularFunctionFieldC jqModC_mem jqNModC_mem coeffMap_qExpand \
+  coeff_jqModC_neg_one order_jqModC PhiGen.splits_prime_at_slot_of_isPrimitiveRoot \
+  exists_phiIrreducible_evalSymm minpoly_jqNModC_map_eq_prod_slots"
+namespace W1
+p2m_open "ModularCurve"
+
+section transport
+
+variable {R S : Type*} [CommRing R] [CommRing S]
+
+theorem coeffMap_qTwist (σ : R →+* S) (u : Rˣ) (f : LaurentSeries R) :
+    coeffMap σ (qTwist u f) = qTwist (Units.map σ.toMonoidHom u) (coeffMap σ f) := by
+  ext k
+  simp only [coeffMap_coeff, qTwist_coeff, map_mul]
+  congr 1
+  rw [← map_zpow, Units.coe_map]
+  rfl
+
+end transport
+
+variable {K : Type*} [Field K]
+
+theorem coeffMap_TS {L : Type*} [Field L] (σ : L →+* K) (e : ℕ) [NeZero e] (u : Lˣ) :
+    coeffMap σ (TS L e u) = TS K e (Units.map σ.toMonoidHom u) := by
+  rw [TS, TS, coeffMap_qExpand, coeffMap_qTwist]
+  exact congrArg (fun z => qExpand K e (qTwist (Units.map σ.toMonoidHom u) z)) (map_jqModC σ)
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem units_pow_eq_one_of_isPrimitiveRoot {N : ℕ} {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N) :
+    ζ ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_congr qExpand_qExpand dedekindPsi ModularPolynomialData coeffMap \
+  coeffMap_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm jqModC \
+  jqNModC map_jqModC modularFunctionFieldC jqModC_mem jqNModC_mem coeffMap_qExpand \
+  coeff_jqModC_neg_one order_jqModC PhiGen.splits_prime_at_slot_of_isPrimitiveRoot \
+  exists_phiIrreducible_evalSymm minpoly_jqNModC_map_eq_prod_slots"
+namespace W1
+p2m_open "ModularCurve"
+
+
+
+
+
+
+theorem phiAtSeed_jqNModC_eval {R : Type*} [CommRing R] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n)
+    (d : ℕ) [NeZero d] : (phiAtSeed data (jqNModC R d)).eval (jqNModC R (d * n)) = 0 := by
+  have h := data.eval_jqNModC_mul_eq_zero R d
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' ?_ ?_
+  · exact RingHom.ext_int _ _
+  · simp
+
+theorem phiAtSeed_jqNModC_eval_symm {R : Type*} [CommRing R] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n)
+    (hsymm : EvalSymm data.Φ) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (jqNModC R (d * n))).eval (jqNModC R d) = 0 := by
+  have h := data.eval_jqNModC_of_mul_eq_zero hsymm R d
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' ?_ ?_
+  · exact RingHom.ext_int _ _
+  · simp
+
+theorem phiAtSeed_TS_eval {K : Type*} [Field K] (A : ℕ) [NeZero A] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (TS K (A * d) 1)).eval (TS K (A * (d * n)) 1) = 0 := by
+  have h := phiAtSeed_eval_map data _ _ (qExpand K A) (phiAtSeed_jqNModC_eval (R := K) n data d)
+  rwa [qExpand_jqNModC, qExpand_jqNModC] at h
+
+theorem phiAtSeed_TS_eval_symm {K : Type*} [Field K] (A : ℕ) [NeZero A] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n) (hsymm : EvalSymm data.Φ) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (TS K (A * (d * n)) 1)).eval (TS K (A * d) 1) = 0 := by
+  have h :=
+    phiAtSeed_eval_map data _ _ (qExpand K A) (phiAtSeed_jqNModC_eval_symm (R := K) n data hsymm d)
+  rwa [qExpand_jqNModC, qExpand_jqNModC] at h
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_congr qExpand_qExpand dedekindPsi ModularPolynomialData coeffMap \
+  coeffMap_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm jqModC \
+  jqNModC map_jqModC modularFunctionFieldC jqModC_mem jqNModC_mem coeffMap_qExpand \
+  coeff_jqModC_neg_one order_jqModC PhiGen.splits_prime_at_slot_of_isPrimitiveRoot \
+  exists_phiIrreducible_evalSymm minpoly_jqNModC_map_eq_prod_slots"
+namespace W1
+p2m_open "ModularCurve"
+
+variable {K : Type*} [Field K]
+
+private theorem prod_form_ne_zero (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e] (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ b) (jqModC K)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (jqModC K))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K))) ::ₘ
+          (Multiset.range p).map (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot p ζ hζ data e u,
+    Polynomial.roots_mul (prod_form_ne_zero ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ b) (jqModC K))))
+        = ((Multiset.range p).map (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K))) (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K))) ::ₘ
+        (Multiset.range p).map (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K)))).Nodup := by
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h :=
+      (TS_injective (K := K) (e := e) (e' := p * (p * e)) (u := u * ζ ^ b) (u' := u ^ (p * p))
+        heq).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e) (u := u * ζ ^ b) (u' := u * ζ ^ b') heq).2
+    have h2 : ζ ^ b = ζ ^ b' := mul_left_cancel h
+    have h3 : ((ζ : Kˣ) : K) ^ b = ((ζ : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h2]
+    exact hζ.pow_inj hb hb' h3
+
+theorem roots_prime_at_slot_roots_nodup (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (jqModC K))))).roots.Nodup := by
+  rw [roots_prime_at_slot p ζ hζ data e u]
+  exact roots_prime_at_slot_nodup p ζ hζ e u
+
+theorem isRoot_prime_at_slot_iff (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (jqModC K))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ b) (jqModC K)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (jqModC K)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot p ζ hζ data e u]
+    exact prod_form_ne_zero ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot p ζ hζ data e u, Multiset.mem_cons,
+    Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+theorem roots_phiAtSeed_TS (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (phiAtSeed data (TS K (p * e) (u ^ p))).roots
+      = TS K (p * (p * e)) (u ^ (p * p)) ::ₘ (Multiset.range p).map (fun b => TS K e (u * ζ ^ b)) :=
+  roots_prime_at_slot p ζ hζ data e u
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_congr qExpand_qExpand dedekindPsi ModularPolynomialData coeffMap \
+  coeffMap_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm jqModC \
+  jqNModC map_jqModC modularFunctionFieldC jqModC_mem jqNModC_mem coeffMap_qExpand \
+  coeff_jqModC_neg_one order_jqModC PhiGen.splits_prime_at_slot_of_isPrimitiveRoot \
+  exists_phiIrreducible_evalSymm minpoly_jqNModC_map_eq_prod_slots"
+namespace W1
+p2m_open "ModularCurve"
+
+variable {K : Type*} [Field K]
+
+theorem jqNModC_mem_mffC_mul_prime_of_prod (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (ζ₁ : Kˣ) (ζ₂ : Kˣ) (hζ₂ : IsPrimitiveRoot (ζ₂ : K) p)
+    (hprod : (minpoly (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) (jqNModC K
+      M)).map
+        ((qExpand K M).comp
+          (algebraMap (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+            (LaurentSeries K)))
+      = ∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+          (Polynomial.X - Polynomial.C (if h : a = 0 then 0 else
+            letI : NeZero a := ⟨h⟩
+            qExpand K (a * a) (qTwist (ζ₁ ^ (b * a)) (jqModC K))))) :
+    jqNModC K M ∈ modularFunctionFieldC K (M * p) := by
+  classical
+  obtain ⟨data, -, -⟩ := ModularCurve.exists_phiIrreducible_evalSymm p
+  have hM0 : 0 < M := Nat.pos_of_ne_zero (NeZero.ne M)
+  have hp2 : 2 ≤ p := hp.out.two_le
+  have hjNmem : jqNModC K (M * p) ∈ modularFunctionFieldC K (M * p) := jqNModC_mem K (M * p)
+  have hle : IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) ≤ modularFunctionFieldC
+    K (M * p) :=
+    IntermediateField.adjoin_le_iff.mpr (Set.singleton_subset_iff.mpr (jqModC_mem K (M * p)))
+  let : Algebra (modularFunctionFieldC K (M * p)) (LaurentSeries K) :=
+    ((qExpand K (M * p)).comp (algebraMap (modularFunctionFieldC K (M * p)) (LaurentSeries
+      K))).toAlgebra
+  set A : Polynomial (modularFunctionFieldC K (M * p)) :=
+    phiAtSeed data (⟨jqNModC K (M * p), hjNmem⟩ : modularFunctionFieldC K (M * p)) with hA
+  let ι₀ : (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) →+*
+    modularFunctionFieldC K (M * p) :=
+    { toFun := fun x => ⟨(x : LaurentSeries K), hle x.2⟩
+      map_one' := rfl
+      map_mul' := fun _ _ => rfl
+      map_zero' := rfl
+      map_add' := fun _ _ => rfl }
+  set m : Polynomial (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) :=
+    minpoly (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) (jqNModC K M) with hm
+  have hm0 : Polynomial.aeval (jqNModC K M) m = 0 := minpoly.aeval _ _
+  set B : Polynomial (modularFunctionFieldC K (M * p)) := m.map ι₀ with hB
+  have hmapA : A.map (algebraMap (modularFunctionFieldC K (M * p)) (LaurentSeries K))
+      = phiAtSeed data (qExpand K (M * p) (jqNModC K (M * p))) :=
+    phiAtSeed_map data _ _
+  have hseed : qExpand K (M * p) (jqNModC K (M * p))
+      = qExpand K (p * (M * p * M)) (qTwist ((1 : Kˣ) ^ p) (jqModC K)) := by
+    have h2 : TS K (M * p * (M * p)) 1 = TS K (p * (M * p * M)) ((1 : Kˣ) ^ p) := by
+      rw [one_pow]
+      exact TS_congr (by ring) 1
+    exact (qExpand_jqNModC (M * p) (M * p)).trans h2
+  have hdist : qExpand K (M * p) (jqNModC K M)
+      = qExpand K (M * p * M) (qTwist (1 * ζ₂ ^ 0) (jqModC K)) := by
+    rw [pow_zero, mul_one]
+    exact qExpand_jqNModC (M * p) M
+  have hrootA : ∀ y : LaurentSeries K, Polynomial.aeval y A = 0 ↔
+      (y = qExpand K (p * (p * (M * p * M))) (qTwist ((1 : Kˣ) ^ (p * p)) (jqModC K)) ∨
+        ∃ c < p, y = qExpand K (M * p * M) (qTwist (1 * ζ₂ ^ c) (jqModC K))) := by
+    intro y
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hmapA, hseed]
+    exact isRoot_prime_at_slot_iff p ζ₂ hζ₂ data (M * p * M) 1 y
+  have hcomp : (algebraMap (modularFunctionFieldC K (M * p)) (LaurentSeries K)).comp ι₀
+      = (qExpand K (M * p)).comp
+          (algebraMap (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+            (LaurentSeries K)) :=
+    RingHom.ext fun _ => rfl
+  have hbig : (qExpand K (M * p)).comp
+        (algebraMap (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) (LaurentSeries
+          K))
+      = (qExpand K p).comp ((qExpand K M).comp
+          (algebraMap (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+            (LaurentSeries K))) := by
+    refine RingHom.ext fun x => ?_
+    simp only [RingHom.comp_apply]
+    rw [qExpand_qExpand]
+    exact qExpand_congr (Nat.mul_comm M p) _
+  have hBroot : ∀ y : LaurentSeries K, Polynomial.aeval y B = 0 →
+      ∃ a : ℕ, a ∣ M ∧ ∃ b : ℕ, b < M / a ∧ ∃ (_ : NeZero a), y = TS K (p * (a * a)) (ζ₁ ^ (b * a))
+        := by
+    intro y hy
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hB, Polynomial.map_map, hcomp, hbig, ←
+      Polynomial.map_map,
+      hprod] at hy
+    simp only [Polynomial.map_prod, Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C,
+      Polynomial.eval_prod,
+      Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, Finset.prod_eq_zero_iff,
+      Finset.mem_filter,
+      Finset.mem_range, Nat.mem_divisors, sub_eq_zero] at hy
+    obtain ⟨a, ⟨haM, -⟩, b, ⟨hb, -⟩, hy⟩ := hy
+    have ha0 : a ≠ 0 := fun h0 => NeZero.ne M (Nat.eq_zero_of_zero_dvd (h0 ▸ haM))
+    have : NeZero a := ⟨ha0⟩
+    refine ⟨a, haM, b, hb, inferInstance, ?_⟩
+    rw [hy, dite_eq_right ha0]
+    change qExpand K p (qExpand K (a * a) (qTwist (ζ₁ ^ (b * a)) (jqModC K)))
+      = qExpand K (p * (a * a)) (qTwist (ζ₁ ^ (b * a)) (jqModC K))
+    rw [qExpand_qExpand]
+  have hA0 : A ≠ 0 := (phiAtSeed_monic data _).ne_zero
+  have hAs : (A.map (algebraMap (modularFunctionFieldC K (M * p)) (LaurentSeries K))).Splits := by
+    rw [hmapA, hseed, phiAtSeed,
+      ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot p ζ₂ hζ₂ data (M * p * M) 1]
+    exact (Polynomial.Splits.X_sub_C _).mul (Polynomial.Splits.prod fun b _ =>
+      Polynomial.Splits.X_sub_C _)
+  have hAnd : (A.map (algebraMap (modularFunctionFieldC K (M * p)) (LaurentSeries K))).roots.Nodup
+    :=
+    by
+    rw [hmapA, hseed, phiAtSeed]
+    exact roots_prime_at_slot_roots_nodup p ζ₂ hζ₂ data (M * p * M) 1
+  have hxA : Polynomial.aeval (qExpand K (M * p) (jqNModC K M)) A = 0 :=
+    (hrootA _).mpr (Or.inr ⟨0, hp.out.pos, hdist⟩)
+  have hxB : Polynomial.aeval (qExpand K (M * p) (jqNModC K M)) B = 0 := by
+    have hm0' := hm0
+    rw [Polynomial.aeval_def] at hm0'
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hB, Polynomial.map_map, hcomp,
+      Polynomial.eval_map,
+      ← Polynomial.hom_eval₂, hm0', map_zero]
+  have huniq : ∀ y : LaurentSeries K, Polynomial.aeval y A = 0 → Polynomial.aeval y B = 0 →
+      y = qExpand K (M * p) (jqNModC K M) := by
+    intro y hyA hyB
+    obtain ⟨a, haM, b, hb, ha, hy⟩ := hBroot y hyB
+    have haM' : a ≤ M := Nat.le_of_dvd hM0 haM
+    have h3 : a * a ≤ M * M := Nat.mul_le_mul haM' haM'
+    have hMM : 0 < M * M := Nat.mul_pos hM0 hM0
+    have h5 : M * p * M = p * (M * M) := by ring
+    rcases (hrootA y).mp hyA with hy1 | ⟨c, hc, hy1⟩
+    · exfalso
+      have hTS : TS K (p * (p * (M * p * M))) ((1 : Kˣ) ^ (p * p)) = TS K (p * (a * a)) (ζ₁ ^ (b *
+        a)) :=
+        by
+        rw [← hy]
+        exact hy1.symm
+      have he : p * (p * (M * p * M)) = p * (a * a) := (TS_injective hTS).1
+      have h6 : p * (M * p * M) = a * a := Nat.eq_of_mul_eq_mul_left hp.out.pos he
+      rw [h5] at h6
+      have h7 : 2 * (2 * (M * M)) ≤ p * (p * (M * M)) :=
+        Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+      omega
+    · have hTS : TS K (M * p * M) (1 * ζ₂ ^ c) = TS K (p * (a * a)) (ζ₁ ^ (b * a)) := by
+        rw [← hy]
+        exact hy1.symm
+      obtain ⟨he, hu⟩ := TS_injective hTS
+      rw [h5] at he
+      have h6 : M * M = a * a := Nat.eq_of_mul_eq_mul_left hp.out.pos he
+      have haM2 : a = M := (Nat.mul_self_inj.mp h6).symm
+      rw [haM2, Nat.div_self hM0] at hb
+      have hb0 : b = 0 := Nat.lt_one_iff.mp hb
+      rw [hb0, Nat.zero_mul, pow_zero, one_mul] at hu
+      have hval : ((ζ₂ : Kˣ) : K) ^ c = 1 := by
+        have h := congrArg Units.val hu
+        rwa [Units.val_pow_eq_pow_val, Units.val_one] at h
+      have hc0 : c = 0 := Nat.eq_zero_of_dvd_of_lt ((hζ₂.pow_eq_one_iff_dvd c).mp hval) hc
+      rw [hc0] at hy1
+      exact hy1.trans hdist.symm
+  have hrange := Polynomial.mem_range_of_unique_common_root A B hA0 hAs hAnd _ hxA hxB huniq
+  obtain ⟨f, hf⟩ := RingHom.mem_range.mp hrange
+  have hf' : qExpand K (M * p) (f : LaurentSeries K) = qExpand K (M * p) (jqNModC K M) := hf
+  have hval : (f : LaurentSeries K) = jqNModC K M := qExpand_injective (M * p) hf'
+  rw [← hval]
+  exact f.2
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_congr qExpand_qExpand dedekindPsi ModularPolynomialData coeffMap \
+  coeffMap_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm jqModC \
+  jqNModC map_jqModC modularFunctionFieldC jqModC_mem jqNModC_mem coeffMap_qExpand \
+  coeff_jqModC_neg_one order_jqModC PhiGen.splits_prime_at_slot_of_isPrimitiveRoot \
+  exists_phiIrreducible_evalSymm minpoly_jqNModC_map_eq_prod_slots"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.jqNModC_mem_modularFunctionFieldC_mul_prime {K : Type*} [Field K]
+    (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) (M * p))
+    (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+          (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries
+            K)))
+            ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d
+        ∧ modularFunctionFieldC K d = IntermediateField.adjoin K
+            {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ d ∧ x = jqNModC K d'}) :
+    jqNModC K M ∈ modularFunctionFieldC K (M * p) :=
+  jqNModC_mem_mffC_mul_prime_of_prod M p (ζ ^ (M * p / M)) (ζ ^ (M * p / p))
+    (isPrimitiveRoot_pow_div hζ (dvd_mul_left p M))
+    (ModularCurve.minpoly_jqNModC_map_eq_prod_slots M (ζ ^ (M * p / M)) (isPrimitiveRoot_pow_div hζ
+      (dvd_mul_right M p))
+      hall)
+
+end
+
+open _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_jqNModC_mem_modularFunctionFieldC_mul_prime.ModularCurve in
+theorem solution {K : Type*} [Field K]
+    (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) (M * p))
+    (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+          (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries
+            K)))
+            ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d
+        ∧ modularFunctionFieldC K d = IntermediateField.adjoin K
+            {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ d ∧ x = jqNModC K d'}) :
+    jqNModC K M ∈ modularFunctionFieldC K (M * p) :=
+  ModularCurve.jqNModC_mem_modularFunctionFieldC_mul_prime M p ζ hζ hall
+
+end S_ModularCurve_jqNModC_mem_modularFunctionFieldC_mul_prime
+end P2MW
+export P2MW.S_ModularCurve_jqNModC_mem_modularFunctionFieldC_mul_prime (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.jqNModC_mem_modularFunctionFieldC_mul_prime {K : Type*} [Field K]
+    (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) (M * p))
+    (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+          (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries
+            K)))
+            ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d
+        ∧ modularFunctionFieldC K d = IntermediateField.adjoin K
+            {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ d ∧ x = jqNModC K d'}) :
+    jqNModC K M ∈ modularFunctionFieldC K (M * p) :=
+  solution M p ζ hζ hall
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqNModC_prime_not_mem_adjoin_of_charZero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqNModC_prime_not_mem_adjoin_of_charZero.lean
new file mode 100644
index 0000000000..ffc645d1a1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqNModC_prime_not_mem_adjoin_of_charZero.lean
@@ -0,0 +1,632 @@
+/-
+Based on Prove2Me node ModularCurve.jqNModC_prime_not_mem_adjoin_of_charZero
+(ca045de8-930f-52f0-8f75-75daa6a97f6b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d465f458-611c-54e1-b2d5-00dae6c08af8
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_neg_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_order_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_mul_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_of_mul_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_pow_of_lt
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_pow_self
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_one_le_coeff_jq
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.RingTheory.RootsOfUnity.AlgebraicallyClosed
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Algebra
+import Mathlib.RingTheory.Polynomial.RationalRoot
+import Mathlib.Algebra.Polynomial.Roots
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# j(qᵖ) is not a rational function of j(q)
+
+Theorem statement: `ModularCurve.jqNModC_prime_not_mem_adjoin_of_charZero`
+(`ca045de8-930f-52f0-8f75-75daa6a97f6b`), by Claude, 2026-09-05.
+
+Proof: submission `d465f458-611c-54e1-b2d5-00dae6c08af8`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field of characteristic zero and let $p$ be a prime. Inside the field
+$\operatorname{LaurentSeries} K$ of formal Laurent series over $K$, the element `jqModC K` is the
+$q$-expansion of the $j$-invariant with coefficients read in $K$: it is the product of the Hahn
+series $q^{-1}$ (the single term with exponent $-1$ and coefficient $1$) with the image in Laurent
+series of the integral power series `jNum` $= E_4^3\cdot\eta^{-24}$-type numerator `eisenstein4 ^ 3
+* dedekindEtaUnitInv`, its integer coefficients pushed to $K$ along $\mathbb{Z}\to K$. For $N \neq
+0$ the ring homomorphism `qExpand K N` is the substitution $q \mapsto q^N$, realised as the
+embedding of Hahn series along multiplication by $N$ on the exponent group $\mathbb{Z}$, and
+`jqNModC K N` is `qExpand K N` applied to `jqModC K`, i.e. the series $j(q^N)$. The assertion is
+that `jqNModC K p`, the series $j(q^p)$, does not belong to the intermediate field of
+$\operatorname{LaurentSeries} K$ over $K$ generated by the single element `jqModC K`; that is,
+$j(q^p)$ is not a rational function of $j(q)$ with coefficients in $K$.
+
+This is the base case, over an arbitrary field of characteristic zero, of the statement that
+$j(q^N)$ generates a proper extension of $K(j(q))$ of degree the Dedekind $\psi$-function; the
+hypothesis of characteristic zero is essential, since in characteristic $p$ one has $j(q^p)=j(q)^p$.
+It is used in the construction of the function field of $X_0(N)$ in this $q$-expansion model, in
+particular in establishing irreducibility of the modular polynomial $\Phi_\ell$ over $K(j(q))$ and
+in the counting of poles of $j(q)$ on the resulting field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_jqNModC_prime_not_mem_adjoin_of_charZero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_jqNModC_prime_not_mem_adjoin_of_charZero
+
+noncomputable section
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_jqNModC_prime_not_mem_adjoin_of_charZero.ModularCurve \
+  ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq dedekindPsi ModularPolynomialData coeffMap coeffMap_coeff coeffMap_single \
+  algebraMap_laurentSeries_eq_single qTwist qTwist_coeff qTwist_single qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one jqModC_rat map_jqModC \
+  jqModC_eq_map_intCast coeffMap_qExpand coeff_jqModC_neg_one order_jqModC coeff_jqModC_pow_of_lt \
+  coeff_jqModC_pow_self transcendental_jqModC exists_phiIrreducible_evalSymm one_le_coeff_jq"
+namespace W1
+p2m_open "ModularCurve"
+
+variable {K : Type*} [Field K]
+
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+theorem jqModC_eq_TS : jqModC K = TS K 1 1 := by
+  rw [TS, qTwist_one_apply, qExpand_one_apply]
+
+theorem jqNModC_eq_TS (d : ℕ) [NeZero d] : jqNModC K d = TS K d 1 := by
+  rw [jqNModC, TS, qTwist_one_apply]
+
+theorem qExpand_jqNModC (A d : ℕ) [NeZero A] [NeZero d] :
+    qExpand K A (jqNModC K d) = TS K (A * d) 1 := by
+  rw [jqNModC_eq_TS, qExpand_TS]
+
+theorem qExpand_jqModC_eq_TS (A : ℕ) [NeZero A] : qExpand K A (jqModC K) = TS K A 1 := by
+  rw [TS, qTwist_one_apply]
+
+theorem qTwist_qExpand_of_pow_eq_one (A : ℕ) [NeZero A] (v : Kˣ) (hv : v ^ A = 1)
+    (x : LaurentSeries K) :
+    qTwist v (qExpand K A x) = qExpand K A x := by
+  rw [qTwist_qExpand]
+  have : v ^ (A : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq dedekindPsi ModularPolynomialData coeffMap coeffMap_coeff coeffMap_single \
+  algebraMap_laurentSeries_eq_single qTwist qTwist_coeff qTwist_single qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one jqModC_rat map_jqModC \
+  jqModC_eq_map_intCast coeffMap_qExpand coeff_jqModC_neg_one order_jqModC coeff_jqModC_pow_of_lt \
+  coeff_jqModC_pow_self transcendental_jqModC exists_phiIrreducible_evalSymm one_le_coeff_jq"
+namespace W1
+p2m_open "ModularCurve"
+
+section transport
+
+variable {R S : Type*} [CommRing R] [CommRing S]
+
+theorem coeffMap_qTwist (σ : R →+* S) (u : Rˣ) (f : LaurentSeries R) :
+    coeffMap σ (qTwist u f) = qTwist (Units.map σ.toMonoidHom u) (coeffMap σ f) := by
+  ext k
+  simp only [coeffMap_coeff, qTwist_coeff, map_mul]
+  congr 1
+  rw [← map_zpow, Units.coe_map]
+  rfl
+
+end transport
+
+variable {K : Type*} [Field K]
+
+theorem coeffMap_TS {L : Type*} [Field L] (σ : L →+* K) (e : ℕ) [NeZero e] (u : Lˣ) :
+    coeffMap σ (TS L e u) = TS K e (Units.map σ.toMonoidHom u) := by
+  rw [TS, TS, coeffMap_qExpand, coeffMap_qTwist]
+  exact congrArg (fun z => qExpand K e (qTwist (Units.map σ.toMonoidHom u) z)) (map_jqModC σ)
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem units_pow_eq_one_of_isPrimitiveRoot {N : ℕ} {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N) :
+    ζ ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq dedekindPsi ModularPolynomialData coeffMap coeffMap_coeff coeffMap_single \
+  algebraMap_laurentSeries_eq_single qTwist qTwist_coeff qTwist_single qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one jqModC_rat map_jqModC \
+  jqModC_eq_map_intCast coeffMap_qExpand coeff_jqModC_neg_one order_jqModC coeff_jqModC_pow_of_lt \
+  coeff_jqModC_pow_self transcendental_jqModC exists_phiIrreducible_evalSymm one_le_coeff_jq"
+namespace W1
+p2m_open "ModularCurve"
+
+
+
+
+
+
+theorem phiAtSeed_jqNModC_eval {R : Type*} [CommRing R] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n)
+    (d : ℕ) [NeZero d] : (phiAtSeed data (jqNModC R d)).eval (jqNModC R (d * n)) = 0 := by
+  have h := data.eval_jqNModC_mul_eq_zero R d
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  exact Polynomial.ringHom_ext' (RingHom.ext_int _ _) (by simp)
+
+theorem phiAtSeed_jqNModC_eval_symm {R : Type*} [CommRing R] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n)
+    (hsymm : EvalSymm data.Φ) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (jqNModC R (d * n))).eval (jqNModC R d) = 0 := by
+  have h := data.eval_jqNModC_of_mul_eq_zero hsymm R d
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  exact Polynomial.ringHom_ext' (RingHom.ext_int _ _) (by simp)
+
+theorem phiAtSeed_TS_eval {K : Type*} [Field K] (A : ℕ) [NeZero A] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (TS K (A * d) 1)).eval (TS K (A * (d * n)) 1) = 0 := by
+  have h := phiAtSeed_eval_map data _ _ (qExpand K A) (phiAtSeed_jqNModC_eval (R := K) n data d)
+  rwa [qExpand_jqNModC, qExpand_jqNModC] at h
+
+theorem phiAtSeed_TS_eval_symm {K : Type*} [Field K] (A : ℕ) [NeZero A] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n) (hsymm : EvalSymm data.Φ) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (TS K (A * (d * n)) 1)).eval (TS K (A * d) 1) = 0 := by
+  have h :=
+    phiAtSeed_eval_map data _ _ (qExpand K A) (phiAtSeed_jqNModC_eval_symm (R := K) n data hsymm d)
+  rwa [qExpand_jqNModC, qExpand_jqNModC] at h
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq dedekindPsi ModularPolynomialData coeffMap coeffMap_coeff coeffMap_single \
+  algebraMap_laurentSeries_eq_single qTwist qTwist_coeff qTwist_single qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one jqModC_rat map_jqModC \
+  jqModC_eq_map_intCast coeffMap_qExpand coeff_jqModC_neg_one order_jqModC coeff_jqModC_pow_of_lt \
+  coeff_jqModC_pow_self transcendental_jqModC exists_phiIrreducible_evalSymm one_le_coeff_jq"
+namespace W1
+p2m_open "ModularCurve"
+
+variable {K : Type*} [Field K]
+
+private theorem jqNModC_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) :
+    jqNModC K n = jqNModC K m := by
+  subst h; rfl
+
+section PoleOrder
+
+private theorem coeff_algebraMap_mul (c : K) (x : LaurentSeries K) (k : ℤ) :
+    (algebraMap K (LaurentSeries K) c * x).coeff k = c * x.coeff k := by
+  rw [algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_zero_mul]
+
+theorem coeff_aeval_jqModC_of_lt (P : Polynomial K) {m : ℤ} (hm : m < -(P.natDegree : ℤ)) :
+    (Polynomial.aeval (jqModC K) P).coeff m = 0 := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum]
+  refine Finset.sum_eq_zero fun i hi => ?_
+  have hi' : i ≤ P.natDegree := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)
+  rw [coeff_algebraMap_mul, ModularCurve.coeff_jqModC_pow_of_lt K (b := i) (m := m) (by
+    omega), mul_zero]
+
+theorem coeff_aeval_jqModC_neg_natDegree (P : Polynomial K) :
+    (Polynomial.aeval (jqModC K) P).coeff (-(P.natDegree : ℤ)) = P.coeff P.natDegree := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+    Finset.sum_eq_single P.natDegree]
+  · rw [coeff_algebraMap_mul, ModularCurve.coeff_jqModC_pow_self K P.natDegree, mul_one]
+  · intro i hi hin
+    have hilt : i < P.natDegree := lt_of_le_of_ne (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hin
+    rw [coeff_algebraMap_mul, ModularCurve.coeff_jqModC_pow_of_lt K (b := i) (m := -(P.natDegree :
+      ℤ)) (by
+      omega),
+      mul_zero]
+  · intro hn
+    exact absurd (Finset.self_mem_range_succ P.natDegree) hn
+
+end PoleOrder
+
+section Forcing
+
+variable (p : ℕ) [hp : Fact (Nat.Prime p)]
+
+theorem coeff_jqNModC_self : (jqNModC K p).coeff (-(p : ℤ)) = 1 := by
+  rw [jqNModC_eq_TS, TS_coeff_neg, inv_one, Units.val_one]
+
+theorem coeff_jqNModC_of_lt {m : ℤ} (hm : m < -(p : ℤ)) : (jqNModC K p).coeff m = 0 := by
+  rw [jqNModC_eq_TS]
+  exact TS_coeff_of_lt p 1 hm
+
+variable {p} {P : Polynomial K}
+
+theorem ne_zero_of_aeval_eq (h : Polynomial.aeval (jqModC K) P = jqNModC K p) : P ≠ 0 := by
+  rintro rfl
+  rw [map_zero] at h
+  have h1 := coeff_jqNModC_self (K := K) p
+  rw [← h, HahnSeries.coeff_zero] at h1
+  exact zero_ne_one h1
+
+theorem natDegree_eq_of_aeval_eq (h : Polynomial.aeval (jqModC K) P = jqNModC K p) :
+    P.natDegree = p := by
+  have hP0 : P ≠ 0 := ne_zero_of_aeval_eq h
+  by_contra hne
+  rcases lt_or_gt_of_ne hne with hlt | hgt
+  · have h1 : (Polynomial.aeval (jqModC K) P).coeff (-(p : ℤ)) = 0 :=
+      coeff_aeval_jqModC_of_lt P (by omega)
+    rw [h, coeff_jqNModC_self] at h1
+    exact one_ne_zero h1
+  · have h1 := coeff_aeval_jqModC_neg_natDegree P
+    rw [h, coeff_jqNModC_of_lt p (m := -(P.natDegree : ℤ)) (by omega)] at h1
+    exact hP0 (Polynomial.leadingCoeff_eq_zero.mp h1.symm)
+
+theorem monic_of_aeval_eq (h : Polynomial.aeval (jqModC K) P = jqNModC K p) : P.Monic := by
+  have hd := natDegree_eq_of_aeval_eq h
+  have h1 := coeff_aeval_jqModC_neg_natDegree P
+  rw [h, hd, coeff_jqNModC_self] at h1
+  change P.coeff P.natDegree = 1
+  rw [hd]
+  exact h1.symm
+
+end Forcing
+
+section Transfer
+
+theorem qTwist_algebraMap (v : Kˣ) (c : K) :
+    qTwist v (algebraMap K (LaurentSeries K) c) = algebraMap K (LaurentSeries K) c := by
+  rw [algebraMap_laurentSeries_eq_single, qTwist_single, zpow_zero, Units.val_one, one_mul]
+
+theorem qTwist_comp_algebraMap (v : Kˣ) :
+    (qTwist v).comp (algebraMap K (LaurentSeries K)) = algebraMap K (LaurentSeries K) :=
+  RingHom.ext fun c => qTwist_algebraMap v c
+
+variable {p : ℕ} [hp : Fact (Nat.Prime p)] {ζ : Kˣ} {P : Polynomial K}
+
+theorem aeval_qTwist_jqModC_eq_of_aeval_eq (hζ : IsPrimitiveRoot (ζ : K) p)
+    (h : Polynomial.aeval (jqModC K) P = jqNModC K p) (b : ℕ) :
+    Polynomial.aeval (qTwist (ζ ^ b) (jqModC K)) P = jqNModC K p := by
+  have hζp : ζ ^ p = 1 := units_pow_eq_one_of_isPrimitiveRoot hζ
+  have hvb : (ζ ^ b) ^ p = 1 := by rw [← pow_mul, Nat.mul_comm, pow_mul, hζp, one_pow]
+  have h2 := congrArg (qTwist (ζ ^ b)) h
+  rw [Polynomial.aeval_def, Polynomial.hom_eval₂, qTwist_comp_algebraMap, jqNModC,
+    qTwist_qExpand_of_pow_eq_one p (ζ ^ b) hvb] at h2
+  rw [Polynomial.aeval_def]
+  exact h2
+
+end Transfer
+
+section Vieta
+
+variable {p : ℕ} [hp : Fact (Nat.Prime p)] {ζ : Kˣ} {P : Polynomial K}
+
+private theorem qTwist_jqModC_eq_TS' (u : Kˣ) : qTwist u (jqModC K) = TS K 1 u := by
+  rw [TS, qExpand_one_apply]
+
+omit hp in
+theorem qTwist_pow_jqModC_injective (hζ : IsPrimitiveRoot (ζ : K) p) :
+    Function.Injective (fun b : Fin p => qTwist (ζ ^ (b : ℕ)) (jqModC K)) := by
+  intro b b' h
+  have h1 : qTwist (ζ ^ (b : ℕ)) (jqModC K) = qTwist (ζ ^ (b' : ℕ)) (jqModC K) := h
+  rw [qTwist_jqModC_eq_TS', qTwist_jqModC_eq_TS'] at h1
+  have h2 : ζ ^ (b : ℕ) = ζ ^ (b' : ℕ) := (TS_injective h1).2
+  have h3 : ((ζ : Kˣ) : K) ^ (b : ℕ) = ((ζ : Kˣ) : K) ^ (b' : ℕ) := by
+    rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h2]
+  exact Fin.ext (hζ.pow_inj b.isLt b'.isLt h3)
+
+theorem sum_qTwist_jqModC_eq_of_aeval_eq (hζ : IsPrimitiveRoot (ζ : K) p)
+    (h : Polynomial.aeval (jqModC K) P = jqNModC K p) :
+    ∑ b : Fin p, qTwist (ζ ^ (b : ℕ)) (jqModC K) = algebraMap K (LaurentSeries K) (-P.coeff (p - 1))
+      := by
+  have hPdeg : P.natDegree = p := natDegree_eq_of_aeval_eq h
+  have hPmonic : P.Monic := monic_of_aeval_eq h
+  set A : Polynomial (LaurentSeries K) := P.map (algebraMap K (LaurentSeries K)) with hA
+  set B : Polynomial (LaurentSeries K) :=
+    ∏ b : Fin p, (Polynomial.X - Polynomial.C (qTwist (ζ ^ (b : ℕ)) (jqModC K))) with hB
+  have hAmonic : A.Monic := hPmonic.map _
+  have hAdeg : A.natDegree = p := by rw [hA, hPmonic.natDegree_map, hPdeg]
+  have hBmonic : B.Monic := Polynomial.monic_prod_of_monic _ _ fun i _ => Polynomial.monic_X_sub_C _
+  have hBdeg : B.natDegree = p := by
+    rw [hB, Polynomial.natDegree_prod_of_monic _ _ fun i _ => Polynomial.monic_X_sub_C _]
+    simp
+  have key : A - B = Polynomial.C (jqNModC K p) := by
+    refine Polynomial.eq_of_natDegree_lt_card_of_eval_eq _ _ (qTwist_pow_jqModC_injective hζ) (fun b
+      => ?_) ?_
+    · have hAev : A.eval (qTwist (ζ ^ (b : ℕ)) (jqModC K)) = jqNModC K p := by
+        rw [hA, Polynomial.eval_map_algebraMap]
+        exact aeval_qTwist_jqModC_eq_of_aeval_eq hζ h b
+      have hBev : B.eval (qTwist (ζ ^ (b : ℕ)) (jqModC K)) = 0 := by
+        rw [hB, Polynomial.eval_prod]
+        exact Finset.prod_eq_zero (Finset.mem_univ b) (by simp)
+      simp only [Polynomial.eval_sub, Polynomial.eval_C, hAev, hBev, sub_zero]
+    · rw [Fintype.card_fin]
+      refine max_lt ?_ (by rw [Polynomial.natDegree_C]; exact hp.out.pos)
+      by_cases hAB : A = B
+      · rw [hAB, sub_self, Polynomial.natDegree_zero]
+        exact hp.out.pos
+      · refine lt_of_lt_of_eq (Polynomial.natDegree_lt_natDegree (sub_ne_zero.mpr hAB) ?_) hAdeg
+        exact Polynomial.degree_sub_lt_left
+          (by rw [Polynomial.degree_eq_natDegree hAmonic.ne_zero, Polynomial.degree_eq_natDegree
+            hBmonic.ne_zero,
+            hAdeg, hBdeg])
+          hAmonic.ne_zero (by rw [hAmonic.leadingCoeff, hBmonic.leadingCoeff])
+  have hcoeff := congrArg (fun Q : Polynomial (LaurentSeries K) => Q.coeff (p - 1)) key
+  have hp2 : 2 ≤ p := hp.out.two_le
+  simp only [Polynomial.coeff_sub, Polynomial.coeff_C, ite_eq_right (by
+    omega : ¬(p - 1 = 0))] at hcoeff
+  have hBcoeff : B.coeff (p - 1) = -∑ b : Fin p, qTwist (ζ ^ (b : ℕ)) (jqModC K) := by
+    have hv := Polynomial.prod_X_sub_C_coeff_card_pred (Finset.univ : Finset (Fin p))
+      (fun b => qTwist (ζ ^ (b : ℕ)) (jqModC K)) (by simp [hp.out.pos])
+    simpa using hv
+  have hAcoeff : A.coeff (p - 1) = algebraMap K (LaurentSeries K) (P.coeff (p - 1)) :=
+    Polynomial.coeff_map _ _
+  rw [hAcoeff, hBcoeff, sub_neg_eq_add, add_comm] at hcoeff
+  rw [map_neg]
+  exact eq_neg_of_add_eq_zero_left hcoeff
+
+end Vieta
+
+section Collapse
+
+variable {p : ℕ} [hp : Fact (Nat.Prime p)] {ζ : Kˣ}
+
+omit hp in
+theorem coeff_sum_qTwist_jqModC (hζ : IsPrimitiveRoot (ζ : K) p) (m : ℕ) :
+    (∑ b : Fin p, qTwist (ζ ^ (b : ℕ)) (jqModC K)).coeff ((p * m : ℕ) : ℤ)
+      = (p : K) * (jqModC K).coeff ((p * m : ℕ) : ℤ) := by
+  have hζp : ζ ^ p = 1 := units_pow_eq_one_of_isPrimitiveRoot hζ
+  rw [HahnSeries.coeff_sum]
+  have hterm : ∀ b : Fin p,
+      (qTwist (ζ ^ (b : ℕ)) (jqModC K)).coeff ((p * m : ℕ) : ℤ) = (jqModC K).coeff ((p * m : ℕ) : ℤ)
+        := by
+    intro b
+    rw [qTwist_coeff, zpow_natCast, ← pow_mul, Nat.mul_comm (b : ℕ), Nat.mul_assoc, pow_mul, hζp,
+      one_pow,
+      Units.val_one, one_mul]
+  rw [Finset.sum_congr rfl fun b _ => hterm b, Finset.sum_const, Finset.card_univ, Fintype.card_fin,
+    nsmul_eq_mul]
+
+theorem aeval_jqModC_ne_jqNModC_of_isPrimitiveRoot (hpK : (p : K) ≠ 0)
+    (hζ : IsPrimitiveRoot (ζ : K) p) {m : ℕ}
+    (hm : 0 < m) (hw : (jqModC K).coeff ((p * m : ℕ) : ℤ) ≠ 0) (P : Polynomial K) :
+    Polynomial.aeval (jqModC K) P ≠ jqNModC K p := by
+  intro h
+  have h1 := sum_qTwist_jqModC_eq_of_aeval_eq hζ h
+  have h2 := coeff_sum_qTwist_jqModC hζ m
+  have hne : ((p * m : ℕ) : ℤ) ≠ 0 := by exact_mod_cast Nat.mul_ne_zero hp.out.ne_zero hm.ne'
+  rw [h1, algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_of_ne hne] at h2
+  exact mul_ne_zero hpK hw h2.symm
+
+end Collapse
+
+section Ascent
+
+variable {p : ℕ} [hp : Fact (Nat.Prime p)]
+
+private theorem coeffMap_algebraMap' {K' : Type*} [Field K'] (σ : K →+* K') (c : K) :
+    coeffMap σ (algebraMap K (LaurentSeries K) c) = algebraMap K' (LaurentSeries K') (σ c) := by
+  rw [algebraMap_laurentSeries_eq_single, algebraMap_laurentSeries_eq_single, coeffMap_single]
+
+theorem coeffMap_aeval_jqModC {K' : Type*} [Field K'] (σ : K →+* K') (P : Polynomial K) :
+    coeffMap σ (Polynomial.aeval (jqModC K) P) = Polynomial.aeval (jqModC K') (P.map σ) := by
+  rw [Polynomial.aeval_def, Polynomial.aeval_def, Polynomial.hom_eval₂, Polynomial.eval₂_map]
+  have hcomp : (coeffMap σ).comp (algebraMap K (LaurentSeries K)) = (algebraMap K' (LaurentSeries
+    K')).comp σ :=
+    RingHom.ext fun c => coeffMap_algebraMap' σ c
+  rw [hcomp]
+  congr 1
+  exact map_jqModC σ
+
+theorem aeval_jqModC_ne_jqNModC (hpK : (p : K) ≠ 0) {m : ℕ} (hm : 0 < m)
+    (hw : (jqModC K).coeff ((p * m : ℕ) : ℤ) ≠ 0)
+    (P : Polynomial K) : Polynomial.aeval (jqModC K) P ≠ jqNModC K p := by
+  intro h
+  have : NeZero ((p : ℕ) : K) := ⟨hpK⟩
+  obtain ⟨z, hz⟩ := HasEnoughRootsOfUnity.exists_primitiveRoot (AlgebraicClosure K) p
+  set σ : K →+* AlgebraicClosure K := algebraMap K (AlgebraicClosure K) with hσ
+  have hzu : IsUnit z := hz.isUnit hp.out.ne_zero
+  have hζ : IsPrimitiveRoot ((hzu.unit : (AlgebraicClosure K)ˣ) : AlgebraicClosure K) p := by
+    rw [IsUnit.unit_spec]
+    exact hz
+  have hpK' : ((p : ℕ) : AlgebraicClosure K) ≠ 0 := by
+    rw [← map_natCast σ]
+    exact (map_ne_zero σ).mpr hpK
+  have hw' : (jqModC (AlgebraicClosure K)).coeff ((p * m : ℕ) : ℤ) ≠ 0 := by
+    rw [← map_jqModC σ]
+    exact (map_ne_zero σ).mpr hw
+  have h' : Polynomial.aeval (jqModC (AlgebraicClosure K)) (P.map σ) = jqNModC (AlgebraicClosure K)
+    p :=
+    by
+    rw [← coeffMap_aeval_jqModC, h, jqNModC, jqNModC, ModularCurve.coeffMap_qExpand]
+    congr 1
+    exact map_jqModC σ
+  exact aeval_jqModC_ne_jqNModC_of_isPrimitiveRoot hpK' hζ hm hw' (P.map σ) h'
+
+end Ascent
+
+section FieldLevel
+
+open scoped IntermediateField.algebraAdjoinAdjoin
+
+variable (p : ℕ) [hp : Fact (Nat.Prime p)]
+
+theorem jqNModC_not_mem_adjoin_of_forall_aeval_ne
+    (h : ∀ P : Polynomial K, Polynomial.aeval (jqModC K) P ≠ jqNModC K p) :
+    jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) := by
+  intro hmem
+  have : UniqueFactorizationMonoid (Algebra.adjoin K ({jqModC K} : Set (LaurentSeries K))) :=
+    (ModularCurve.transcendental_jqModC K).uniqueFactorizationMonoid_adjoin
+  obtain ⟨data, -, -⟩ := ModularCurve.exists_phiIrreducible_evalSymm p
+  have hrel : (phiAtSeed data (jqModC K)).eval (jqNModC K p) = 0 := by
+    have h1 := phiAtSeed_jqNModC_eval (R := K) p data 1
+    rwa [jqNModC_one, jqNModC_congr (Nat.one_mul p)] at h1
+  have hQmap : (phiAtSeed data (⟨jqModC K, Algebra.self_mem_adjoin_singleton K (jqModC K)⟩ :
+      Algebra.adjoin K ({jqModC K} : Set (LaurentSeries K)))).map
+        (algebraMap (Algebra.adjoin K ({jqModC K} : Set (LaurentSeries K))) (LaurentSeries K))
+      = phiAtSeed data (jqModC K) := by
+    rw [phiAtSeed_map]
+    rfl
+  have hroot : Polynomial.aeval (⟨jqNModC K p, hmem⟩ : IntermediateField.adjoin K ({jqModC K} : Set
+    (LaurentSeries K)))
+      (phiAtSeed data (⟨jqModC K, Algebra.self_mem_adjoin_singleton K (jqModC K)⟩ :
+        Algebra.adjoin K ({jqModC K} : Set (LaurentSeries K)))) = 0 := by
+    apply (algebraMap (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      (LaurentSeries K)).injective
+    rw [map_zero, Polynomial.aeval_def, Polynomial.hom_eval₂, ← IsScalarTower.algebraMap_eq, ←
+      Polynomial.eval_map,
+      hQmap]
+    exact hrel
+  obtain ⟨a, ha, -⟩ := exists_integer_of_is_root_of_monic (phiAtSeed_monic data _) hroot
+  have hcoe : jqNModC K p = (a : LaurentSeries K) := by
+    have h1 := congrArg
+      (fun t : IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) => (t : LaurentSeries
+        K)) ha
+    exact h1.trans (IntermediateField.algebraAdjoinAdjoin.coe_algebraMap K ({jqModC K} : Set
+      (LaurentSeries K)) a)
+  have hmemA : jqNModC K p ∈ Algebra.adjoin K ({jqModC K} : Set (LaurentSeries K)) := by
+    rw [hcoe]
+    exact a.2
+  rw [Algebra.adjoin_singleton_eq_range_aeval] at hmemA
+  obtain ⟨P, hP⟩ := (AlgHom.mem_range _).mp hmemA
+  exact h P hP
+
+end FieldLevel
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq dedekindPsi ModularPolynomialData coeffMap coeffMap_coeff coeffMap_single \
+  algebraMap_laurentSeries_eq_single qTwist qTwist_coeff qTwist_single qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one jqModC_rat map_jqModC \
+  jqModC_eq_map_intCast coeffMap_qExpand coeff_jqModC_neg_one order_jqModC coeff_jqModC_pow_of_lt \
+  coeff_jqModC_pow_self transcendental_jqModC exists_phiIrreducible_evalSymm one_le_coeff_jq"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne {K : Type*} [Field K]
+    (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (h : ∀ P : Polynomial K, Polynomial.aeval (jqModC K) P ≠ jqNModC K p) :
+    jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) :=
+  jqNModC_not_mem_adjoin_of_forall_aeval_ne p h
+
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.jqNModC_prime_not_mem_adjoin_of_coeff_ne_zero {K : Type*} [Field K]
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpK : (p : K) ≠ 0)
+    (hw : ∃ m : ℕ, 0 < m ∧ (jqModC K).coeff ((p * m : ℕ) : ℤ) ≠ 0) :
+    jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) := by
+  obtain ⟨m, hm, hw⟩ := hw
+  exact jqNModC_not_mem_adjoin_of_forall_aeval_ne p fun P => aeval_jqModC_ne_jqNModC hpK hm hw P
+
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.jqNModC_prime_not_mem_adjoin_of_charZero {K : Type*} [Field K]
+    [CharZero K] (p : ℕ) [hp : Fact (Nat.Prime p)] :
+    jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) := by
+  refine ModularCurve.jqNModC_prime_not_mem_adjoin_of_coeff_ne_zero p (Nat.cast_ne_zero.mpr
+    hp.out.ne_zero)
+    ⟨1, Nat.one_pos, ?_⟩
+  have hz : (jqModC ℤ).coeff ((p * 1 : ℕ) : ℤ) ≠ 0 := by
+    intro h0
+    have h1 := ModularCurve.one_le_coeff_jq (p * 1)
+    have h2 : jq.coeff ((p * 1 : ℕ) : ℤ) = (((jqModC ℤ).coeff ((p * 1 : ℕ) : ℤ) : ℤ) : ℚ) := by
+      rw [← jqModC_rat, jqModC_eq_map_intCast]
+      rfl
+    rw [h2, h0] at h1
+    norm_num at h1
+  have h3 : (jqModC K).coeff ((p * 1 : ℕ) : ℤ) = (((jqModC ℤ).coeff ((p * 1 : ℕ) : ℤ) : ℤ) : K) :=
+    by
+    rw [jqModC_eq_map_intCast]
+    rfl
+  rw [h3]
+  exact Int.cast_ne_zero.mpr hz
+
+end
+
+open _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_jqNModC_prime_not_mem_adjoin_of_charZero.ModularCurve in
+theorem solution {K : Type*} [Field K] [CharZero K] (p : ℕ) [hp : Fact (Nat.Prime p)] :
+    jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) :=
+  ModularCurve.jqNModC_prime_not_mem_adjoin_of_charZero p
+
+end S_ModularCurve_jqNModC_prime_not_mem_adjoin_of_charZero
+end P2MW
+export P2MW.S_ModularCurve_jqNModC_prime_not_mem_adjoin_of_charZero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.jqNModC_prime_not_mem_adjoin_of_charZero {K : Type*} [Field K] [CharZero K]
+    (p : ℕ) [hp : Fact (Nat.Prime p)] :
+    jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) :=
+  solution p
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne.lean
new file mode 100644
index 0000000000..9147aea06c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne.lean
@@ -0,0 +1,633 @@
+/-
+Based on Prove2Me node ModularCurve.jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne
+(967d8715-7437-5807-8dd3-f0c3f927fbd0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3a612994-b876-56c6-b2d8-a92d05ef2248
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_neg_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_order_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_mul_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_of_mul_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_pow_of_lt
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_pow_self
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_one_le_coeff_jq
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.RingTheory.RootsOfUnity.AlgebraicallyClosed
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Algebra
+import Mathlib.RingTheory.Polynomial.RationalRoot
+import Mathlib.Algebra.Polynomial.Roots
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Non-polynomiality of j(qᵖ) in j(q) forces non-rationality
+
+Theorem statement: `ModularCurve.jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne`
+(`967d8715-7437-5807-8dd3-f0c3f927fbd0`), by Claude, 2026-09-05.
+
+Proof: submission `3a612994-b876-56c6-b2d8-a92d05ef2248`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $p$ be a prime. Inside the field $K((q))$ of Laurent series over $K$,
+write $j(q) :=$ `jqModC K` for the element $q^{-1}\cdot\iota(\mathrm{jNum}_K)$, where $\mathrm{jNum}
+= E_4^3\cdot \eta^{-1}\!$-unit-inverse is the integral power series `jNum` with its coefficients
+mapped into $K$ along $\mathbb{Z}\to K$ and $\iota$ is the inclusion of power series into Laurent
+series; thus $j(q)$ is the $q$-expansion of the modular $j$-invariant, read in $K$. Write $j(q^p)
+:=$ `jqNModC K p` for the image of $j(q)$ under the ring homomorphism `qExpand K p` of $K((q))$
+obtained by pushing the support forward along multiplication by $p$ on $\mathbb{Z}$, i.e. by the
+substitution $q\mapsto q^p$. Assume that no polynomial $P\in K[X]$ satisfies $P(j(q)) = j(q^p)$, the
+evaluation being the $K$-algebra map $K[X]\to K((q))$ sending $X$ to $j(q)$. Then $j(q^p)$ does not
+belong to $K(j(q))$, the intermediate field of $K((q))/K$ generated over $K$ by $j(q)$.
+
+This rules out the intermediate possibility that $j(q^p)$ be a rational but non-polynomial function
+of $j(q)$: $j(q^p)$ is integral over $K[j(q)]$ through the monic modular relation
+$\Phi_p(j(q),Y)=0$, while $K[j(q)]$ is a polynomial ring, $j(q)$ being transcendental over $K$,
+hence integrally closed. The hypothesis cannot be dropped, as characteristic $p$, where
+$j(q^p)=j(q)^p$, shows. It serves as the base non-membership input for the computations of
+$[K(j(q),j(q^N)):K(j(q))] = \psi(N)$ over a general coefficient field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne
+
+noncomputable section
+
+p2m_open "ModularCurve \
+  P2MW.S_ModularCurve_jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne.ModularCurve \
+  ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq dedekindPsi ModularPolynomialData coeffMap coeffMap_coeff coeffMap_single \
+  algebraMap_laurentSeries_eq_single qTwist qTwist_coeff qTwist_single qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one jqModC_rat map_jqModC \
+  jqModC_eq_map_intCast coeffMap_qExpand coeff_jqModC_neg_one order_jqModC coeff_jqModC_pow_of_lt \
+  coeff_jqModC_pow_self transcendental_jqModC exists_phiIrreducible_evalSymm one_le_coeff_jq"
+namespace W1
+p2m_open "ModularCurve"
+
+variable {K : Type*} [Field K]
+
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+theorem jqModC_eq_TS : jqModC K = TS K 1 1 := by
+  rw [TS, qTwist_one_apply, qExpand_one_apply]
+
+theorem jqNModC_eq_TS (d : ℕ) [NeZero d] : jqNModC K d = TS K d 1 := by
+  rw [jqNModC, TS, qTwist_one_apply]
+
+theorem qExpand_jqNModC (A d : ℕ) [NeZero A] [NeZero d] :
+    qExpand K A (jqNModC K d) = TS K (A * d) 1 := by
+  rw [jqNModC_eq_TS, qExpand_TS]
+
+theorem qExpand_jqModC_eq_TS (A : ℕ) [NeZero A] : qExpand K A (jqModC K) = TS K A 1 := by
+  rw [TS, qTwist_one_apply]
+
+theorem qTwist_qExpand_of_pow_eq_one (A : ℕ) [NeZero A] (v : Kˣ) (hv : v ^ A = 1)
+    (x : LaurentSeries K) :
+    qTwist v (qExpand K A x) = qExpand K A x := by
+  rw [qTwist_qExpand]
+  have : v ^ (A : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq dedekindPsi ModularPolynomialData coeffMap coeffMap_coeff coeffMap_single \
+  algebraMap_laurentSeries_eq_single qTwist qTwist_coeff qTwist_single qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one jqModC_rat map_jqModC \
+  jqModC_eq_map_intCast coeffMap_qExpand coeff_jqModC_neg_one order_jqModC coeff_jqModC_pow_of_lt \
+  coeff_jqModC_pow_self transcendental_jqModC exists_phiIrreducible_evalSymm one_le_coeff_jq"
+namespace W1
+p2m_open "ModularCurve"
+
+section transport
+
+variable {R S : Type*} [CommRing R] [CommRing S]
+
+theorem coeffMap_qTwist (σ : R →+* S) (u : Rˣ) (f : LaurentSeries R) :
+    coeffMap σ (qTwist u f) = qTwist (Units.map σ.toMonoidHom u) (coeffMap σ f) := by
+  ext k
+  simp only [coeffMap_coeff, qTwist_coeff, map_mul]
+  congr 1
+  rw [← map_zpow, Units.coe_map]
+  rfl
+
+end transport
+
+variable {K : Type*} [Field K]
+
+theorem coeffMap_TS {L : Type*} [Field L] (σ : L →+* K) (e : ℕ) [NeZero e] (u : Lˣ) :
+    coeffMap σ (TS L e u) = TS K e (Units.map σ.toMonoidHom u) := by
+  rw [TS, TS, coeffMap_qExpand, coeffMap_qTwist]
+  exact congrArg (fun z => qExpand K e (qTwist (Units.map σ.toMonoidHom u) z)) (map_jqModC σ)
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem units_pow_eq_one_of_isPrimitiveRoot {N : ℕ} {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N) :
+    ζ ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq dedekindPsi ModularPolynomialData coeffMap coeffMap_coeff coeffMap_single \
+  algebraMap_laurentSeries_eq_single qTwist qTwist_coeff qTwist_single qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one jqModC_rat map_jqModC \
+  jqModC_eq_map_intCast coeffMap_qExpand coeff_jqModC_neg_one order_jqModC coeff_jqModC_pow_of_lt \
+  coeff_jqModC_pow_self transcendental_jqModC exists_phiIrreducible_evalSymm one_le_coeff_jq"
+namespace W1
+p2m_open "ModularCurve"
+
+
+
+
+
+
+theorem phiAtSeed_jqNModC_eval {R : Type*} [CommRing R] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n)
+    (d : ℕ) [NeZero d] : (phiAtSeed data (jqNModC R d)).eval (jqNModC R (d * n)) = 0 := by
+  have h := data.eval_jqNModC_mul_eq_zero R d
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  exact Polynomial.ringHom_ext' (RingHom.ext_int _ _) (by simp)
+
+theorem phiAtSeed_jqNModC_eval_symm {R : Type*} [CommRing R] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n)
+    (hsymm : EvalSymm data.Φ) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (jqNModC R (d * n))).eval (jqNModC R d) = 0 := by
+  have h := data.eval_jqNModC_of_mul_eq_zero hsymm R d
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  exact Polynomial.ringHom_ext' (RingHom.ext_int _ _) (by simp)
+
+theorem phiAtSeed_TS_eval {K : Type*} [Field K] (A : ℕ) [NeZero A] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (TS K (A * d) 1)).eval (TS K (A * (d * n)) 1) = 0 := by
+  have h := phiAtSeed_eval_map data _ _ (qExpand K A) (phiAtSeed_jqNModC_eval (R := K) n data d)
+  rwa [qExpand_jqNModC, qExpand_jqNModC] at h
+
+theorem phiAtSeed_TS_eval_symm {K : Type*} [Field K] (A : ℕ) [NeZero A] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n) (hsymm : EvalSymm data.Φ) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (TS K (A * (d * n)) 1)).eval (TS K (A * d) 1) = 0 := by
+  have h :=
+    phiAtSeed_eval_map data _ _ (qExpand K A) (phiAtSeed_jqNModC_eval_symm (R := K) n data hsymm d)
+  rwa [qExpand_jqNModC, qExpand_jqNModC] at h
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq dedekindPsi ModularPolynomialData coeffMap coeffMap_coeff coeffMap_single \
+  algebraMap_laurentSeries_eq_single qTwist qTwist_coeff qTwist_single qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one jqModC_rat map_jqModC \
+  jqModC_eq_map_intCast coeffMap_qExpand coeff_jqModC_neg_one order_jqModC coeff_jqModC_pow_of_lt \
+  coeff_jqModC_pow_self transcendental_jqModC exists_phiIrreducible_evalSymm one_le_coeff_jq"
+namespace W1
+p2m_open "ModularCurve"
+
+variable {K : Type*} [Field K]
+
+private theorem jqNModC_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) :
+    jqNModC K n = jqNModC K m := by
+  subst h; rfl
+
+section PoleOrder
+
+private theorem coeff_algebraMap_mul (c : K) (x : LaurentSeries K) (k : ℤ) :
+    (algebraMap K (LaurentSeries K) c * x).coeff k = c * x.coeff k := by
+  rw [algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_zero_mul]
+
+theorem coeff_aeval_jqModC_of_lt (P : Polynomial K) {m : ℤ} (hm : m < -(P.natDegree : ℤ)) :
+    (Polynomial.aeval (jqModC K) P).coeff m = 0 := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum]
+  refine Finset.sum_eq_zero fun i hi => ?_
+  have hi' : i ≤ P.natDegree := Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)
+  rw [coeff_algebraMap_mul, ModularCurve.coeff_jqModC_pow_of_lt K (b := i) (m := m) (by
+    omega), mul_zero]
+
+theorem coeff_aeval_jqModC_neg_natDegree (P : Polynomial K) :
+    (Polynomial.aeval (jqModC K) P).coeff (-(P.natDegree : ℤ)) = P.coeff P.natDegree := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+    Finset.sum_eq_single P.natDegree]
+  · rw [coeff_algebraMap_mul, ModularCurve.coeff_jqModC_pow_self K P.natDegree, mul_one]
+  · intro i hi hin
+    have hilt : i < P.natDegree := lt_of_le_of_ne (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hin
+    rw [coeff_algebraMap_mul, ModularCurve.coeff_jqModC_pow_of_lt K (b := i) (m := -(P.natDegree :
+      ℤ)) (by
+      omega),
+      mul_zero]
+  · intro hn
+    exact absurd (Finset.self_mem_range_succ P.natDegree) hn
+
+end PoleOrder
+
+section Forcing
+
+variable (p : ℕ) [hp : Fact (Nat.Prime p)]
+
+theorem coeff_jqNModC_self : (jqNModC K p).coeff (-(p : ℤ)) = 1 := by
+  rw [jqNModC_eq_TS, TS_coeff_neg, inv_one, Units.val_one]
+
+theorem coeff_jqNModC_of_lt {m : ℤ} (hm : m < -(p : ℤ)) : (jqNModC K p).coeff m = 0 := by
+  rw [jqNModC_eq_TS]
+  exact TS_coeff_of_lt p 1 hm
+
+variable {p} {P : Polynomial K}
+
+theorem ne_zero_of_aeval_eq (h : Polynomial.aeval (jqModC K) P = jqNModC K p) : P ≠ 0 := by
+  rintro rfl
+  rw [map_zero] at h
+  have h1 := coeff_jqNModC_self (K := K) p
+  rw [← h, HahnSeries.coeff_zero] at h1
+  exact zero_ne_one h1
+
+theorem natDegree_eq_of_aeval_eq (h : Polynomial.aeval (jqModC K) P = jqNModC K p) :
+    P.natDegree = p := by
+  have hP0 : P ≠ 0 := ne_zero_of_aeval_eq h
+  by_contra hne
+  rcases lt_or_gt_of_ne hne with hlt | hgt
+  · have h1 : (Polynomial.aeval (jqModC K) P).coeff (-(p : ℤ)) = 0 :=
+      coeff_aeval_jqModC_of_lt P (by omega)
+    rw [h, coeff_jqNModC_self] at h1
+    exact one_ne_zero h1
+  · have h1 := coeff_aeval_jqModC_neg_natDegree P
+    rw [h, coeff_jqNModC_of_lt p (m := -(P.natDegree : ℤ)) (by omega)] at h1
+    exact hP0 (Polynomial.leadingCoeff_eq_zero.mp h1.symm)
+
+theorem monic_of_aeval_eq (h : Polynomial.aeval (jqModC K) P = jqNModC K p) : P.Monic := by
+  have hd := natDegree_eq_of_aeval_eq h
+  have h1 := coeff_aeval_jqModC_neg_natDegree P
+  rw [h, hd, coeff_jqNModC_self] at h1
+  change P.coeff P.natDegree = 1
+  rw [hd]
+  exact h1.symm
+
+end Forcing
+
+section Transfer
+
+theorem qTwist_algebraMap (v : Kˣ) (c : K) :
+    qTwist v (algebraMap K (LaurentSeries K) c) = algebraMap K (LaurentSeries K) c := by
+  rw [algebraMap_laurentSeries_eq_single, qTwist_single, zpow_zero, Units.val_one, one_mul]
+
+theorem qTwist_comp_algebraMap (v : Kˣ) :
+    (qTwist v).comp (algebraMap K (LaurentSeries K)) = algebraMap K (LaurentSeries K) :=
+  RingHom.ext fun c => qTwist_algebraMap v c
+
+variable {p : ℕ} [hp : Fact (Nat.Prime p)] {ζ : Kˣ} {P : Polynomial K}
+
+theorem aeval_qTwist_jqModC_eq_of_aeval_eq (hζ : IsPrimitiveRoot (ζ : K) p)
+    (h : Polynomial.aeval (jqModC K) P = jqNModC K p) (b : ℕ) :
+    Polynomial.aeval (qTwist (ζ ^ b) (jqModC K)) P = jqNModC K p := by
+  have hζp : ζ ^ p = 1 := units_pow_eq_one_of_isPrimitiveRoot hζ
+  have hvb : (ζ ^ b) ^ p = 1 := by rw [← pow_mul, Nat.mul_comm, pow_mul, hζp, one_pow]
+  have h2 := congrArg (qTwist (ζ ^ b)) h
+  rw [Polynomial.aeval_def, Polynomial.hom_eval₂, qTwist_comp_algebraMap, jqNModC,
+    qTwist_qExpand_of_pow_eq_one p (ζ ^ b) hvb] at h2
+  rw [Polynomial.aeval_def]
+  exact h2
+
+end Transfer
+
+section Vieta
+
+variable {p : ℕ} [hp : Fact (Nat.Prime p)] {ζ : Kˣ} {P : Polynomial K}
+
+private theorem qTwist_jqModC_eq_TS' (u : Kˣ) : qTwist u (jqModC K) = TS K 1 u := by
+  rw [TS, qExpand_one_apply]
+
+omit hp in
+theorem qTwist_pow_jqModC_injective (hζ : IsPrimitiveRoot (ζ : K) p) :
+    Function.Injective (fun b : Fin p => qTwist (ζ ^ (b : ℕ)) (jqModC K)) := by
+  intro b b' h
+  have h1 : qTwist (ζ ^ (b : ℕ)) (jqModC K) = qTwist (ζ ^ (b' : ℕ)) (jqModC K) := h
+  rw [qTwist_jqModC_eq_TS', qTwist_jqModC_eq_TS'] at h1
+  have h2 : ζ ^ (b : ℕ) = ζ ^ (b' : ℕ) := (TS_injective h1).2
+  have h3 : ((ζ : Kˣ) : K) ^ (b : ℕ) = ((ζ : Kˣ) : K) ^ (b' : ℕ) := by
+    rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h2]
+  exact Fin.ext (hζ.pow_inj b.isLt b'.isLt h3)
+
+theorem sum_qTwist_jqModC_eq_of_aeval_eq (hζ : IsPrimitiveRoot (ζ : K) p)
+    (h : Polynomial.aeval (jqModC K) P = jqNModC K p) :
+    ∑ b : Fin p, qTwist (ζ ^ (b : ℕ)) (jqModC K) = algebraMap K (LaurentSeries K) (-P.coeff (p - 1))
+      := by
+  have hPdeg : P.natDegree = p := natDegree_eq_of_aeval_eq h
+  have hPmonic : P.Monic := monic_of_aeval_eq h
+  set A : Polynomial (LaurentSeries K) := P.map (algebraMap K (LaurentSeries K)) with hA
+  set B : Polynomial (LaurentSeries K) :=
+    ∏ b : Fin p, (Polynomial.X - Polynomial.C (qTwist (ζ ^ (b : ℕ)) (jqModC K))) with hB
+  have hAmonic : A.Monic := hPmonic.map _
+  have hAdeg : A.natDegree = p := by rw [hA, hPmonic.natDegree_map, hPdeg]
+  have hBmonic : B.Monic := Polynomial.monic_prod_of_monic _ _ fun i _ => Polynomial.monic_X_sub_C _
+  have hBdeg : B.natDegree = p := by
+    rw [hB, Polynomial.natDegree_prod_of_monic _ _ fun i _ => Polynomial.monic_X_sub_C _]
+    simp
+  have key : A - B = Polynomial.C (jqNModC K p) := by
+    refine Polynomial.eq_of_natDegree_lt_card_of_eval_eq _ _ (qTwist_pow_jqModC_injective hζ) (fun b
+      => ?_) ?_
+    · have hAev : A.eval (qTwist (ζ ^ (b : ℕ)) (jqModC K)) = jqNModC K p := by
+        rw [hA, Polynomial.eval_map_algebraMap]
+        exact aeval_qTwist_jqModC_eq_of_aeval_eq hζ h b
+      have hBev : B.eval (qTwist (ζ ^ (b : ℕ)) (jqModC K)) = 0 := by
+        rw [hB, Polynomial.eval_prod]
+        exact Finset.prod_eq_zero (Finset.mem_univ b) (by simp)
+      simp only [Polynomial.eval_sub, Polynomial.eval_C, hAev, hBev, sub_zero]
+    · rw [Fintype.card_fin]
+      refine max_lt ?_ (by rw [Polynomial.natDegree_C]; exact hp.out.pos)
+      by_cases hAB : A = B
+      · rw [hAB, sub_self, Polynomial.natDegree_zero]
+        exact hp.out.pos
+      · refine lt_of_lt_of_eq (Polynomial.natDegree_lt_natDegree (sub_ne_zero.mpr hAB) ?_) hAdeg
+        exact Polynomial.degree_sub_lt_left
+          (by rw [Polynomial.degree_eq_natDegree hAmonic.ne_zero, Polynomial.degree_eq_natDegree
+            hBmonic.ne_zero,
+            hAdeg, hBdeg])
+          hAmonic.ne_zero (by rw [hAmonic.leadingCoeff, hBmonic.leadingCoeff])
+  have hcoeff := congrArg (fun Q : Polynomial (LaurentSeries K) => Q.coeff (p - 1)) key
+  have hp2 : 2 ≤ p := hp.out.two_le
+  simp only [Polynomial.coeff_sub, Polynomial.coeff_C, ite_eq_right (by
+    omega : ¬(p - 1 = 0))] at hcoeff
+  have hBcoeff : B.coeff (p - 1) = -∑ b : Fin p, qTwist (ζ ^ (b : ℕ)) (jqModC K) := by
+    have hv := Polynomial.prod_X_sub_C_coeff_card_pred (Finset.univ : Finset (Fin p))
+      (fun b => qTwist (ζ ^ (b : ℕ)) (jqModC K)) (by simp [hp.out.pos])
+    simpa using hv
+  have hAcoeff : A.coeff (p - 1) = algebraMap K (LaurentSeries K) (P.coeff (p - 1)) :=
+    Polynomial.coeff_map _ _
+  rw [hAcoeff, hBcoeff, sub_neg_eq_add, add_comm] at hcoeff
+  rw [map_neg]
+  exact eq_neg_of_add_eq_zero_left hcoeff
+
+end Vieta
+
+section Collapse
+
+variable {p : ℕ} [hp : Fact (Nat.Prime p)] {ζ : Kˣ}
+
+omit hp in
+theorem coeff_sum_qTwist_jqModC (hζ : IsPrimitiveRoot (ζ : K) p) (m : ℕ) :
+    (∑ b : Fin p, qTwist (ζ ^ (b : ℕ)) (jqModC K)).coeff ((p * m : ℕ) : ℤ)
+      = (p : K) * (jqModC K).coeff ((p * m : ℕ) : ℤ) := by
+  have hζp : ζ ^ p = 1 := units_pow_eq_one_of_isPrimitiveRoot hζ
+  rw [HahnSeries.coeff_sum]
+  have hterm : ∀ b : Fin p,
+      (qTwist (ζ ^ (b : ℕ)) (jqModC K)).coeff ((p * m : ℕ) : ℤ) = (jqModC K).coeff ((p * m : ℕ) : ℤ)
+        := by
+    intro b
+    rw [qTwist_coeff, zpow_natCast, ← pow_mul, Nat.mul_comm (b : ℕ), Nat.mul_assoc, pow_mul, hζp,
+      one_pow,
+      Units.val_one, one_mul]
+  rw [Finset.sum_congr rfl fun b _ => hterm b, Finset.sum_const, Finset.card_univ, Fintype.card_fin,
+    nsmul_eq_mul]
+
+theorem aeval_jqModC_ne_jqNModC_of_isPrimitiveRoot (hpK : (p : K) ≠ 0)
+    (hζ : IsPrimitiveRoot (ζ : K) p) {m : ℕ}
+    (hm : 0 < m) (hw : (jqModC K).coeff ((p * m : ℕ) : ℤ) ≠ 0) (P : Polynomial K) :
+    Polynomial.aeval (jqModC K) P ≠ jqNModC K p := by
+  intro h
+  have h1 := sum_qTwist_jqModC_eq_of_aeval_eq hζ h
+  have h2 := coeff_sum_qTwist_jqModC hζ m
+  have hne : ((p * m : ℕ) : ℤ) ≠ 0 := by exact_mod_cast Nat.mul_ne_zero hp.out.ne_zero hm.ne'
+  rw [h1, algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_of_ne hne] at h2
+  exact mul_ne_zero hpK hw h2.symm
+
+end Collapse
+
+section Ascent
+
+variable {p : ℕ} [hp : Fact (Nat.Prime p)]
+
+private theorem coeffMap_algebraMap' {K' : Type*} [Field K'] (σ : K →+* K') (c : K) :
+    coeffMap σ (algebraMap K (LaurentSeries K) c) = algebraMap K' (LaurentSeries K') (σ c) := by
+  rw [algebraMap_laurentSeries_eq_single, algebraMap_laurentSeries_eq_single, coeffMap_single]
+
+theorem coeffMap_aeval_jqModC {K' : Type*} [Field K'] (σ : K →+* K') (P : Polynomial K) :
+    coeffMap σ (Polynomial.aeval (jqModC K) P) = Polynomial.aeval (jqModC K') (P.map σ) := by
+  rw [Polynomial.aeval_def, Polynomial.aeval_def, Polynomial.hom_eval₂, Polynomial.eval₂_map]
+  have hcomp : (coeffMap σ).comp (algebraMap K (LaurentSeries K)) = (algebraMap K' (LaurentSeries
+    K')).comp σ :=
+    RingHom.ext fun c => coeffMap_algebraMap' σ c
+  rw [hcomp]
+  congr 1
+  exact map_jqModC σ
+
+theorem aeval_jqModC_ne_jqNModC (hpK : (p : K) ≠ 0) {m : ℕ} (hm : 0 < m)
+    (hw : (jqModC K).coeff ((p * m : ℕ) : ℤ) ≠ 0)
+    (P : Polynomial K) : Polynomial.aeval (jqModC K) P ≠ jqNModC K p := by
+  intro h
+  have : NeZero ((p : ℕ) : K) := ⟨hpK⟩
+  obtain ⟨z, hz⟩ := HasEnoughRootsOfUnity.exists_primitiveRoot (AlgebraicClosure K) p
+  set σ : K →+* AlgebraicClosure K := algebraMap K (AlgebraicClosure K) with hσ
+  have hzu : IsUnit z := hz.isUnit hp.out.ne_zero
+  have hζ : IsPrimitiveRoot ((hzu.unit : (AlgebraicClosure K)ˣ) : AlgebraicClosure K) p := by
+    rw [IsUnit.unit_spec]
+    exact hz
+  have hpK' : ((p : ℕ) : AlgebraicClosure K) ≠ 0 := by
+    rw [← map_natCast σ]
+    exact (map_ne_zero σ).mpr hpK
+  have hw' : (jqModC (AlgebraicClosure K)).coeff ((p * m : ℕ) : ℤ) ≠ 0 := by
+    rw [← map_jqModC σ]
+    exact (map_ne_zero σ).mpr hw
+  have h' : Polynomial.aeval (jqModC (AlgebraicClosure K)) (P.map σ) = jqNModC (AlgebraicClosure K)
+    p :=
+    by
+    rw [← coeffMap_aeval_jqModC, h, jqNModC, jqNModC, ModularCurve.coeffMap_qExpand]
+    congr 1
+    exact map_jqModC σ
+  exact aeval_jqModC_ne_jqNModC_of_isPrimitiveRoot hpK' hζ hm hw' (P.map σ) h'
+
+end Ascent
+
+section FieldLevel
+
+open scoped IntermediateField.algebraAdjoinAdjoin
+
+variable (p : ℕ) [hp : Fact (Nat.Prime p)]
+
+theorem jqNModC_not_mem_adjoin_of_forall_aeval_ne
+    (h : ∀ P : Polynomial K, Polynomial.aeval (jqModC K) P ≠ jqNModC K p) :
+    jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) := by
+  intro hmem
+  have : UniqueFactorizationMonoid (Algebra.adjoin K ({jqModC K} : Set (LaurentSeries K))) :=
+    (ModularCurve.transcendental_jqModC K).uniqueFactorizationMonoid_adjoin
+  obtain ⟨data, -, -⟩ := ModularCurve.exists_phiIrreducible_evalSymm p
+  have hrel : (phiAtSeed data (jqModC K)).eval (jqNModC K p) = 0 := by
+    have h1 := phiAtSeed_jqNModC_eval (R := K) p data 1
+    rwa [jqNModC_one, jqNModC_congr (Nat.one_mul p)] at h1
+  have hQmap : (phiAtSeed data (⟨jqModC K, Algebra.self_mem_adjoin_singleton K (jqModC K)⟩ :
+      Algebra.adjoin K ({jqModC K} : Set (LaurentSeries K)))).map
+        (algebraMap (Algebra.adjoin K ({jqModC K} : Set (LaurentSeries K))) (LaurentSeries K))
+      = phiAtSeed data (jqModC K) := by
+    rw [phiAtSeed_map]
+    rfl
+  have hroot : Polynomial.aeval (⟨jqNModC K p, hmem⟩ : IntermediateField.adjoin K ({jqModC K} : Set
+    (LaurentSeries K)))
+      (phiAtSeed data (⟨jqModC K, Algebra.self_mem_adjoin_singleton K (jqModC K)⟩ :
+        Algebra.adjoin K ({jqModC K} : Set (LaurentSeries K)))) = 0 := by
+    apply (algebraMap (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      (LaurentSeries K)).injective
+    rw [map_zero, Polynomial.aeval_def, Polynomial.hom_eval₂, ← IsScalarTower.algebraMap_eq, ←
+      Polynomial.eval_map,
+      hQmap]
+    exact hrel
+  obtain ⟨a, ha, -⟩ := exists_integer_of_is_root_of_monic (phiAtSeed_monic data _) hroot
+  have hcoe : jqNModC K p = (a : LaurentSeries K) := by
+    have h1 := congrArg
+      (fun t : IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) => (t : LaurentSeries
+        K)) ha
+    exact h1.trans (IntermediateField.algebraAdjoinAdjoin.coe_algebraMap K ({jqModC K} : Set
+      (LaurentSeries K)) a)
+  have hmemA : jqNModC K p ∈ Algebra.adjoin K ({jqModC K} : Set (LaurentSeries K)) := by
+    rw [hcoe]
+    exact a.2
+  rw [Algebra.adjoin_singleton_eq_range_aeval] at hmemA
+  obtain ⟨P, hP⟩ := (AlgHom.mem_range _).mp hmemA
+  exact h P hP
+
+end FieldLevel
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq dedekindPsi ModularPolynomialData coeffMap coeffMap_coeff coeffMap_single \
+  algebraMap_laurentSeries_eq_single qTwist qTwist_coeff qTwist_single qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one jqModC_rat map_jqModC \
+  jqModC_eq_map_intCast coeffMap_qExpand coeff_jqModC_neg_one order_jqModC coeff_jqModC_pow_of_lt \
+  coeff_jqModC_pow_self transcendental_jqModC exists_phiIrreducible_evalSymm one_le_coeff_jq"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne {K : Type*} [Field K]
+    (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (h : ∀ P : Polynomial K, Polynomial.aeval (jqModC K) P ≠ jqNModC K p) :
+    jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) :=
+  jqNModC_not_mem_adjoin_of_forall_aeval_ne p h
+
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.jqNModC_prime_not_mem_adjoin_of_coeff_ne_zero {K : Type*} [Field K]
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpK : (p : K) ≠ 0)
+    (hw : ∃ m : ℕ, 0 < m ∧ (jqModC K).coeff ((p * m : ℕ) : ℤ) ≠ 0) :
+    jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) := by
+  obtain ⟨m, hm, hw⟩ := hw
+  exact jqNModC_not_mem_adjoin_of_forall_aeval_ne p fun P => aeval_jqModC_ne_jqNModC hpK hm hw P
+
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.jqNModC_prime_not_mem_adjoin_of_charZero {K : Type*} [Field K]
+    [CharZero K] (p : ℕ) [hp : Fact (Nat.Prime p)] :
+    jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) := by
+  refine ModularCurve.jqNModC_prime_not_mem_adjoin_of_coeff_ne_zero p (Nat.cast_ne_zero.mpr
+    hp.out.ne_zero)
+    ⟨1, Nat.one_pos, ?_⟩
+  have hz : (jqModC ℤ).coeff ((p * 1 : ℕ) : ℤ) ≠ 0 := by
+    intro h0
+    have h1 := ModularCurve.one_le_coeff_jq (p * 1)
+    have h2 : jq.coeff ((p * 1 : ℕ) : ℤ) = (((jqModC ℤ).coeff ((p * 1 : ℕ) : ℤ) : ℤ) : ℚ) := by
+      rw [← jqModC_rat, jqModC_eq_map_intCast]
+      rfl
+    rw [h2, h0] at h1
+    norm_num at h1
+  have h3 : (jqModC K).coeff ((p * 1 : ℕ) : ℤ) = (((jqModC ℤ).coeff ((p * 1 : ℕ) : ℤ) : ℤ) : K) :=
+    by
+    rw [jqModC_eq_map_intCast]
+    rfl
+  rw [h3]
+  exact Int.cast_ne_zero.mpr hz
+
+end
+
+open _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne.ModularCurve in
+theorem solution {K : Type*} [Field K] (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (h : ∀ P : Polynomial K, Polynomial.aeval (jqModC K) P ≠ jqNModC K p) :
+    jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) :=
+  ModularCurve.jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne p h
+
+end S_ModularCurve_jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne
+end P2MW
+export P2MW.S_ModularCurve_jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.jqNModC_prime_not_mem_adjoin_of_forall_aeval_ne {K : Type*} [Field K] (p : ℕ)
+    [hp : Fact (Nat.Prime p)] (h : ∀ P : Polynomial K, Polynomial.aeval (jqModC K) P ≠ jqNModC K p)
+    :
+    jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) :=
+  solution p h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqNModC_prime_not_mem_fullC.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqNModC_prime_not_mem_fullC.lean
new file mode 100644
index 0000000000..26f5b6d9d2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqNModC_prime_not_mem_fullC.lean
@@ -0,0 +1,1963 @@
+/-
+Based on Prove2Me node ModularCurve.jqNModC_prime_not_mem_fullC
+(20304447-457e-591b-8484-0204b5d74aef) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission cfc162c6-1055-5ff3-81e7-6e439d448f46
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_neg_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_order_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_mul_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_of_mul_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot_of_isPrimitiveRoot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime_pow
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_mul_of_coprime
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.NumberTheory.Cyclotomic.PrimitiveRoots
+import Mathlib.FieldTheory.Extension
+import Mathlib.Data.Nat.Factorization.Induction
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Non-membership of j(qᵖ) in the level-M field, p ∤ M
+
+Theorem statement: `ModularCurve.jqNModC_prime_not_mem_fullC`
+(`20304447-457e-591b-8484-0204b5d74aef`), by Claude, 2026-09-05.
+
+Proof: submission `cfc162c6-1055-5ff3-81e7-6e439d448f46`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and write $j =$ `jqModC K` for the Laurent series $q^{-1}\cdot(\text{image in } K
+\text{ of } E_4^3\,\eta^{-24}) \in K((q))$, and, for $N \ge 1$, $j(q^N) =$ `jqNModC K N` for its
+image under the ring homomorphism `qExpand K N` that multiplies all exponents by $N$. Let $M \ge 1$,
+let $p$ be a prime with $p \nmid M$, and let $\zeta$ be a unit of $K$ whose underlying element is a
+primitive $(Mp)$-th root of unity. Assume, for every divisor $d \ge 1$ of $M$, both that
+$[\,K(j)(j(q^d)) : K(j)\,] = \sum_{e \mid d,\ e \text{ squarefree}} d/e$ (Dedekind's $\psi(d)$, as
+`dedekindPsi` is defined) and that the $K$-intermediate field generated by $\{j, j(q^d)\}$ coincides
+with the $K$-intermediate field of $K((q))$ generated by all $j(q^{d'})$ with $1 \le d' \mid d$.
+Assume further that $j(q^p) \notin K(j)$. The conclusion is that $j(q^p)$ does not lie in the
+$K$-intermediate field of $K((q))$ generated by all $j(q^{d'})$ with $1 \le d' \mid M$.
+
+In the formal $q$-expansion model of the function fields of the curves $X_0(N)$, this is the
+coprime-level independence step: the degeneracy generator at a prime $p$ stays outside the field
+generated by all degeneracy generators of level prime to $p$, provided it already escapes level one.
+It is used in the assembly of the level-by-level data for these function fields,
+[`ModularCurve.package_of_socket`](thm.html#ModularCurve.package_of_socket).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_jqNModC_prime_not_mem_fullC.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 6400000
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_jqNModC_prime_not_mem_fullC
+
+noncomputable section
+
+p2m_open "ModularCurve~dedekindPsi_prime \
+  P2MW.S_ModularCurve_jqNModC_prime_not_mem_fullC.ModularCurve ModularCurve.PhiGen"
+open scoped IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData jqd_mem_full \
+  coeffMap coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one map_jqModC modularFunctionFieldC \
+  coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime"
+
+variable {K : Type*} [Field K]
+
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+theorem jqModC_eq_TS : jqModC K = TS K 1 1 := by
+  rw [TS, qTwist_one_apply, qExpand_one_apply]
+
+theorem jqNModC_eq_TS (d : ℕ) [NeZero d] : jqNModC K d = TS K d 1 := by
+  rw [jqNModC, TS, qTwist_one_apply]
+
+theorem qExpand_jqNModC (A d : ℕ) [NeZero A] [NeZero d] :
+    qExpand K A (jqNModC K d) = TS K (A * d) 1 := by
+  rw [jqNModC_eq_TS, qExpand_TS]
+
+theorem qExpand_jqModC_eq_TS (A : ℕ) [NeZero A] : qExpand K A (jqModC K) = TS K A 1 := by
+  rw [TS, qTwist_one_apply]
+
+theorem qTwist_qExpand_of_pow_eq_one (A : ℕ) [NeZero A] (v : Kˣ) (hv : v ^ A = 1)
+    (x : LaurentSeries K) :
+    qTwist v (qExpand K A x) = qExpand K A x := by
+  rw [qTwist_qExpand]
+  have : v ^ (A : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData jqd_mem_full \
+  coeffMap coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one map_jqModC modularFunctionFieldC \
+  coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime"
+
+section transport
+
+variable {R S : Type*} [CommRing R] [CommRing S]
+
+theorem coeffMap_qTwist (σ : R →+* S) (u : Rˣ) (f : LaurentSeries R) :
+    coeffMap σ (qTwist u f) = qTwist (Units.map σ.toMonoidHom u) (coeffMap σ f) := by
+  ext k
+  simp only [coeffMap_coeff, qTwist_coeff, map_mul]
+  congr 1
+  rw [← map_zpow, Units.coe_map]
+  rfl
+
+end transport
+
+variable {K : Type*} [Field K]
+
+theorem coeffMap_TS {L : Type*} [Field L] (σ : L →+* K) (e : ℕ) [NeZero e] (u : Lˣ) :
+    coeffMap σ (TS L e u) = TS K e (Units.map σ.toMonoidHom u) := by
+  rw [TS, TS, coeffMap_qExpand, coeffMap_qTwist]
+  exact congrArg (fun z => qExpand K e (qTwist (Units.map σ.toMonoidHom u) z)) (map_jqModC σ)
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem units_pow_eq_one_of_isPrimitiveRoot {N : ℕ} {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N) :
+    ζ ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData jqd_mem_full \
+  coeffMap coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one map_jqModC modularFunctionFieldC \
+  coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime"
+
+
+
+
+
+
+theorem phiAtSeed_jqNModC_eval {R : Type*} [CommRing R] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n)
+    (d : ℕ) [NeZero d] : (phiAtSeed data (jqNModC R d)).eval (jqNModC R (d * n)) = 0 := by
+  have h := data.eval_jqNModC_mul_eq_zero R d
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  exact Polynomial.ringHom_ext' (RingHom.ext_int _ _) (by simp)
+
+theorem phiAtSeed_jqNModC_eval_symm {R : Type*} [CommRing R] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n)
+    (hsymm : EvalSymm data.Φ) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (jqNModC R (d * n))).eval (jqNModC R d) = 0 := by
+  have h := data.eval_jqNModC_of_mul_eq_zero hsymm R d
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  exact Polynomial.ringHom_ext' (RingHom.ext_int _ _) (by simp)
+
+theorem phiAtSeed_TS_eval {K : Type*} [Field K] (A : ℕ) [NeZero A] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (TS K (A * d) 1)).eval (TS K (A * (d * n)) 1) = 0 := by
+  have h := phiAtSeed_eval_map data _ _ (qExpand K A) (phiAtSeed_jqNModC_eval (R := K) n data d)
+  rwa [qExpand_jqNModC, qExpand_jqNModC] at h
+
+theorem phiAtSeed_TS_eval_symm {K : Type*} [Field K] (A : ℕ) [NeZero A] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n) (hsymm : EvalSymm data.Φ) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (TS K (A * (d * n)) 1)).eval (TS K (A * d) 1) = 0 := by
+  have h :=
+    phiAtSeed_eval_map data _ _ (qExpand K A) (phiAtSeed_jqNModC_eval_symm (R := K) n data hsymm d)
+  rwa [qExpand_jqNModC, qExpand_jqNModC] at h
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData jqd_mem_full \
+  coeffMap coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one map_jqModC modularFunctionFieldC \
+  coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime"
+
+variable {K : Type*} [Field K]
+
+private theorem prod_form_ne_zero (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e] (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ b) (jqModC K)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (jqModC K))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K))) ::ₘ
+          (Multiset.range p).map (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot p ζ hζ data e u,
+    Polynomial.roots_mul (prod_form_ne_zero ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ b) (jqModC K))))
+        = ((Multiset.range p).map (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K))) (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K))) ::ₘ
+        (Multiset.range p).map (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K)))).Nodup := by
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h :=
+      (TS_injective (K := K) (e := e) (e' := p * (p * e)) (u := u * ζ ^ b) (u' := u ^ (p * p))
+        heq).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e) (u := u * ζ ^ b) (u' := u * ζ ^ b') heq).2
+    have h2 : ζ ^ b = ζ ^ b' := mul_left_cancel h
+    have h3 : ((ζ : Kˣ) : K) ^ b = ((ζ : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h2]
+    exact hζ.pow_inj hb hb' h3
+
+theorem roots_prime_at_slot_roots_nodup (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (jqModC K))))).roots.Nodup := by
+  rw [roots_prime_at_slot p ζ hζ data e u]
+  exact roots_prime_at_slot_nodup p ζ hζ e u
+
+theorem isRoot_prime_at_slot_iff (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (jqModC K))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ b) (jqModC K)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (jqModC K)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot p ζ hζ data e u]
+    exact prod_form_ne_zero ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot p ζ hζ data e u, Multiset.mem_cons,
+    Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+theorem roots_phiAtSeed_TS (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (phiAtSeed data (TS K (p * e) (u ^ p))).roots
+      = TS K (p * (p * e)) (u ^ (p * p)) ::ₘ (Multiset.range p).map (fun b => TS K e (u * ζ ^ b)) :=
+  roots_prime_at_slot p ζ hζ data e u
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData jqd_mem_full \
+  coeffMap coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one map_jqModC modularFunctionFieldC \
+  coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime"
+
+private def slotAt (n d : ℕ) : ℕ :=
+  ((Finset.range d).filter fun b => Nat.gcd (Nat.gcd (n / d) b) d = 1).card
+
+private def slots (n : ℕ) : ℕ := ∑ d ∈ n.divisors, slotAt n d
+
+private theorem slotCond_eq (x d b : ℕ) :
+    Nat.gcd (Nat.gcd x b) d = Nat.gcd (Nat.gcd x d) b := by
+  rw [Nat.gcd_assoc, Nat.gcd_comm b d, ← Nat.gcd_assoc]
+
+private theorem slotCond_iff (x d b : ℕ) :
+    Nat.gcd (Nat.gcd x b) d = 1 ↔ Nat.Coprime (Nat.gcd x d) b := by
+  rw [slotCond_eq]
+
+private theorem gcd_eq_of_modEq {a b n : ℕ} (h : a ≡ b [MOD n]) :
+    Nat.gcd n a = Nat.gcd n b := by
+  have h' : a % n = b % n := h
+  rw [Nat.gcd_rec n a, Nat.gcd_rec n b, h']
+
+private theorem slotCond_mod_iff (x d b : ℕ) :
+    Nat.Coprime (Nat.gcd x d) (b % d) ↔ Nat.Coprime (Nat.gcd x d) b := by
+  unfold Nat.Coprime
+  rw [gcd_eq_of_modEq ((Nat.mod_modEq b d).of_dvd (Nat.gcd_dvd_right x d))]
+
+private theorem slotAt_one (n : ℕ) : slotAt n 1 = 1 := by
+  unfold slotAt
+  simp [Nat.gcd_one_right]
+
+private theorem slotAt_self (n : ℕ) (hn : 0 < n) : slotAt n n = n := by
+  unfold slotAt
+  simp [Nat.div_self hn, Nat.gcd_one_left]
+
+private theorem slotAt_prime_pow_mid {p : ℕ} (hp : p.Prime) {i k : ℕ} (hi0 : 0 < i)
+    (hik : i < k) : slotAt (p ^ k) (p ^ i) = Nat.totient (p ^ i) := by
+  unfold slotAt
+  rw [Nat.totient_eq_card_coprime]
+  congr 1
+  refine Finset.filter_congr fun b _ => ?_
+  rw [slotCond_iff]
+  constructor
+  · intro h
+    have hpg : p ∣ Nat.gcd (p ^ k / p ^ i) (p ^ i) := by
+      refine Nat.dvd_gcd ?_ (dvd_pow_self p hi0.ne')
+      rw [Nat.pow_div hik.le hp.pos]
+      exact dvd_pow_self p (by omega)
+    exact Nat.Coprime.pow_left i (Nat.Coprime.coprime_dvd_left hpg h)
+  · intro h
+    exact Nat.Coprime.coprime_dvd_left (Nat.gcd_dvd_right _ _) h
+
+private theorem slots_prime_pow {p : ℕ} (hp : p.Prime) (k : ℕ) :
+    slots (p ^ (k + 1)) = p ^ (k + 1) + p ^ k := by
+  unfold slots
+  rw [Nat.sum_divisors_prime_pow hp, Finset.sum_range_succ]
+  have hrest : ∀ x ∈ Finset.range (k + 1),
+      slotAt (p ^ (k + 1)) (p ^ x) = Nat.totient (p ^ x) := by
+    intro x hx
+    rcases Nat.eq_zero_or_pos x with rfl | hx0
+    · rw [pow_zero, slotAt_one, Nat.totient_one]
+    · exact slotAt_prime_pow_mid hp hx0 (Finset.mem_range.mp hx)
+  rw [Finset.sum_congr rfl hrest, slotAt_self _ (pow_pos hp.pos _),
+    ← Nat.sum_divisors_prime_pow (f := Nat.totient) hp, Nat.sum_totient, Nat.add_comm]
+
+private theorem dedekindPsi_prime_pow' {p : ℕ} (hp : p.Prime) (k : ℕ) :
+    ModularCurve.dedekindPsi (p ^ (k + 1)) = p ^ (k + 1) + p ^ k := by
+  unfold ModularCurve.dedekindPsi
+  have hfil : Finset.filter (fun d => Squarefree d) (p ^ (k + 1)).divisors = {1, p} := by
+    ext x
+    simp only [Finset.mem_filter, Nat.mem_divisors_prime_pow hp, Finset.mem_insert,
+      Finset.mem_singleton]
+    constructor
+    · rintro ⟨⟨j, -, rfl⟩, hsq⟩
+      rcases Nat.eq_zero_or_pos j with rfl | hj0
+      · exact Or.inl (pow_zero p)
+      · have hj1 : j = 1 := ((Nat.squarefree_pow_iff hp.ne_one hj0.ne').mp hsq).2
+        subst hj1
+        exact Or.inr (pow_one p)
+    · rintro (rfl | rfl)
+      · exact ⟨⟨0, Nat.zero_le _, (pow_zero p).symm⟩, squarefree_one⟩
+      · exact ⟨⟨1, by omega, (pow_one _).symm⟩, hp.prime.squarefree⟩
+  rw [hfil, Finset.sum_pair hp.one_lt.ne, Nat.div_one, pow_succ,
+    Nat.mul_div_cancel _ hp.pos]
+
+private theorem slotAt_mul (M M' d₁ d₂ : ℕ) (hM : M ≠ 0) (hM' : M' ≠ 0)
+    (hco : Nat.Coprime M M') (hd₁ : d₁ ∣ M) (hd₂ : d₂ ∣ M') :
+    slotAt (M * M') (d₁ * d₂) = slotAt M d₁ * slotAt M' d₂ := by
+  have hd₁0 : 0 < d₁ :=
+    Nat.pos_of_ne_zero (by rintro rfl; exact hM (Nat.eq_zero_of_zero_dvd hd₁))
+  have hd₂0 : 0 < d₂ :=
+    Nat.pos_of_ne_zero (by rintro rfl; exact hM' (Nat.eq_zero_of_zero_dvd hd₂))
+  have hcod : Nat.Coprime d₁ d₂ :=
+    Nat.Coprime.coprime_dvd_left hd₁ (Nat.Coprime.coprime_dvd_right hd₂ hco)
+  have hxM : M / d₁ ∣ M := ⟨d₁, (Nat.div_mul_cancel hd₁).symm⟩
+  have hyM' : M' / d₂ ∣ M' := ⟨d₂, (Nat.div_mul_cancel hd₂).symm⟩
+  have hxy : (M * M') / (d₁ * d₂) = (M / d₁) * (M' / d₂) :=
+    (Nat.div_mul_div_comm hd₁ hd₂).symm
+  have hyd₁ : Nat.Coprime (M' / d₂) d₁ :=
+    Nat.Coprime.coprime_dvd_left hyM' (Nat.Coprime.coprime_dvd_right hd₁ hco.symm)
+  have hxd₂ : Nat.Coprime (M / d₁) d₂ :=
+    Nat.Coprime.coprime_dvd_left hxM (Nat.Coprime.coprime_dvd_right hd₂ hco)
+  have hg₁g : Nat.gcd (M / d₁) d₁ ∣ Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) := by
+    rw [hxy]
+    exact Nat.dvd_gcd ((Nat.gcd_dvd_left _ _).mul_right _) ((Nat.gcd_dvd_right _ _).mul_right _)
+  have hg₂g : Nat.gcd (M' / d₂) d₂ ∣ Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) := by
+    rw [hxy]
+    exact Nat.dvd_gcd ((Nat.gcd_dvd_left _ _).mul_left _) ((Nat.gcd_dvd_right _ _).mul_left _)
+  have hgg : Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) ∣
+      Nat.gcd (M / d₁) d₁ * Nat.gcd (M' / d₂) d₂ := by
+    have hgdd : Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) ∣ d₁ * d₂ := Nat.gcd_dvd_right _ _
+    have hgxy : Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) ∣ (M / d₁) * (M' / d₂) := by
+      rw [← hxy]
+      exact Nat.gcd_dvd_left _ _
+    have hgyx : Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) ∣ (M' / d₂) * (M / d₁) :=
+      hgxy.trans (dvd_of_eq (Nat.mul_comm (M / d₁) (M' / d₂)))
+    have hsplit : Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂)) d₁ *
+        Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂)) d₂ =
+        Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) :=
+      (Nat.gcd_mul_gcd_eq_iff_dvd_mul_of_coprime hcod).mpr hgdd
+    rw [← hsplit]
+    refine Nat.mul_dvd_mul ?_ ?_
+    · refine Nat.dvd_gcd ?_ (Nat.gcd_dvd_right _ d₁)
+      have h2 : Nat.Coprime (Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂)) d₁)
+          (M' / d₂) := Nat.Coprime.coprime_dvd_left (Nat.gcd_dvd_right _ d₁) hyd₁.symm
+      exact h2.dvd_of_dvd_mul_right ((Nat.gcd_dvd_left _ d₁).trans hgxy)
+    · refine Nat.dvd_gcd ?_ (Nat.gcd_dvd_right _ d₂)
+      have h2 : Nat.Coprime (Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂)) d₂)
+          (M / d₁) := Nat.Coprime.coprime_dvd_left (Nat.gcd_dvd_right _ d₂) hxd₂.symm
+      exact h2.dvd_of_dvd_mul_right ((Nat.gcd_dvd_left _ d₂).trans hgyx)
+  have hfwd : ∀ b : ℕ, Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) b) (d₁ * d₂) = 1 →
+      Nat.gcd (Nat.gcd (M / d₁) (b % d₁)) d₁ = 1 ∧
+        Nat.gcd (Nat.gcd (M' / d₂) (b % d₂)) d₂ = 1 := by
+    intro b hb
+    rw [slotCond_iff] at hb
+    constructor
+    · rw [slotCond_iff, slotCond_mod_iff]
+      exact Nat.Coprime.coprime_dvd_left hg₁g hb
+    · rw [slotCond_iff, slotCond_mod_iff]
+      exact Nat.Coprime.coprime_dvd_left hg₂g hb
+  have hbwd : ∀ b₁ b₂ k : ℕ, Nat.gcd (Nat.gcd (M / d₁) b₁) d₁ = 1 →
+      Nat.gcd (Nat.gcd (M' / d₂) b₂) d₂ = 1 → k ≡ b₁ [MOD d₁] → k ≡ b₂ [MOD d₂] →
+      Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) k) (d₁ * d₂) = 1 := by
+    intro b₁ b₂ k h₁ h₂ hk₁ hk₂
+    rw [slotCond_iff] at h₁ h₂ ⊢
+    have hc₁ : Nat.Coprime (Nat.gcd (M / d₁) d₁) k := by
+      unfold Nat.Coprime
+      rw [gcd_eq_of_modEq (hk₁.of_dvd (Nat.gcd_dvd_right (M / d₁) d₁))]
+      exact h₁
+    have hc₂ : Nat.Coprime (Nat.gcd (M' / d₂) d₂) k := by
+      unfold Nat.Coprime
+      rw [gcd_eq_of_modEq (hk₂.of_dvd (Nat.gcd_dvd_right (M' / d₂) d₂))]
+      exact h₂
+    exact Nat.Coprime.coprime_dvd_left hgg (Nat.coprime_mul_iff_left.mpr ⟨hc₁, hc₂⟩)
+  unfold slotAt
+  rw [← Finset.card_product]
+  refine Finset.card_bij' (fun b _ => (b % d₁, b % d₂))
+    (fun q _ => (Nat.chineseRemainder hcod q.1 q.2 : ℕ)) ?_ ?_ ?_ ?_
+  · intro b hb
+    obtain ⟨hbr, hbc⟩ := Finset.mem_filter.mp hb
+    obtain ⟨h₁, h₂⟩ := hfwd b hbc
+    exact Finset.mem_product.mpr
+      ⟨Finset.mem_filter.mpr ⟨Finset.mem_range.mpr (Nat.mod_lt b hd₁0), h₁⟩,
+        Finset.mem_filter.mpr ⟨Finset.mem_range.mpr (Nat.mod_lt b hd₂0), h₂⟩⟩
+  · intro q hq
+    obtain ⟨hq₁, hq₂⟩ := Finset.mem_product.mp hq
+    have hcrt := (Nat.chineseRemainder hcod q.1 q.2).prop
+    refine Finset.mem_filter.mpr ⟨Finset.mem_range.mpr
+      (Nat.chineseRemainder_lt_mul hcod q.1 q.2 hd₁0.ne' hd₂0.ne'), ?_⟩
+    exact hbwd q.1 q.2 _ (Finset.mem_filter.mp hq₁).2 (Finset.mem_filter.mp hq₂).2
+      hcrt.1 hcrt.2
+  · intro b hb
+    have hb' : b < d₁ * d₂ := Finset.mem_range.mp (Finset.mem_filter.mp hb).1
+    have hcrt := (Nat.chineseRemainder hcod (b % d₁) (b % d₂)).prop
+    have h₁ : (Nat.chineseRemainder hcod (b % d₁) (b % d₂) : ℕ) ≡ b [MOD d₁] :=
+      hcrt.1.trans (Nat.mod_modEq b d₁)
+    have h₂ : (Nat.chineseRemainder hcod (b % d₁) (b % d₂) : ℕ) ≡ b [MOD d₂] :=
+      hcrt.2.trans (Nat.mod_modEq b d₂)
+    exact ((Nat.modEq_and_modEq_iff_modEq_mul hcod).mp ⟨h₁, h₂⟩).eq_of_lt_of_lt
+      (Nat.chineseRemainder_lt_mul hcod _ _ hd₁0.ne' hd₂0.ne') hb'
+  · intro q hq
+    obtain ⟨hq₁, hq₂⟩ := Finset.mem_product.mp hq
+    have hb₁ : q.1 < d₁ := Finset.mem_range.mp (Finset.mem_filter.mp hq₁).1
+    have hb₂ : q.2 < d₂ := Finset.mem_range.mp (Finset.mem_filter.mp hq₂).1
+    have hcrt := (Nat.chineseRemainder hcod q.1 q.2).prop
+    have h₁ : (Nat.chineseRemainder hcod q.1 q.2 : ℕ) % d₁ = q.1 := by
+      have h' : (Nat.chineseRemainder hcod q.1 q.2 : ℕ) % d₁ = q.1 % d₁ := hcrt.1
+      rw [h', Nat.mod_eq_of_lt hb₁]
+    have h₂ : (Nat.chineseRemainder hcod q.1 q.2 : ℕ) % d₂ = q.2 := by
+      have h' : (Nat.chineseRemainder hcod q.1 q.2 : ℕ) % d₂ = q.2 % d₂ := hcrt.2
+      rw [h', Nat.mod_eq_of_lt hb₂]
+    exact Prod.ext h₁ h₂
+
+private theorem gcd_mul_left_of_dvd (M M' : ℕ) (hco : Nat.Coprime M M') {e₁ e₂ : ℕ}
+    (he₁ : e₁ ∣ M) (he₂ : e₂ ∣ M') : Nat.gcd (e₁ * e₂) M = e₁ := by
+  refine Nat.dvd_antisymm ?_ (Nat.dvd_gcd (dvd_mul_right e₁ e₂) he₁)
+  have hc : Nat.Coprime (Nat.gcd (e₁ * e₂) M) e₂ :=
+    Nat.Coprime.coprime_dvd_left (Nat.gcd_dvd_right _ _)
+      (Nat.Coprime.coprime_dvd_right he₂ hco)
+  exact hc.dvd_of_dvd_mul_right (Nat.gcd_dvd_left _ _)
+
+private theorem gcd_mul_right_of_dvd (M M' : ℕ) (hco : Nat.Coprime M M') {e₁ e₂ : ℕ}
+    (he₁ : e₁ ∣ M) (he₂ : e₂ ∣ M') : Nat.gcd (e₁ * e₂) M' = e₂ := by
+  refine Nat.dvd_antisymm ?_ (Nat.dvd_gcd (dvd_mul_left e₂ e₁) he₂)
+  have hc : Nat.Coprime (Nat.gcd (e₁ * e₂) M') e₁ :=
+    Nat.Coprime.coprime_dvd_left (Nat.gcd_dvd_right _ _)
+      (Nat.Coprime.coprime_dvd_right he₁ hco.symm)
+  have h1 : Nat.gcd (e₁ * e₂) M' ∣ e₂ * e₁ :=
+    (Nat.gcd_dvd_left (e₁ * e₂) M').trans (dvd_of_eq (Nat.mul_comm e₁ e₂))
+  exact hc.dvd_of_dvd_mul_right h1
+
+private theorem slots_mul (M M' : ℕ) (hM : M ≠ 0) (hM' : M' ≠ 0)
+    (hco : Nat.Coprime M M') : slots (M * M') = slots M * slots M' := by
+  unfold slots
+  rw [Finset.sum_mul_sum, ← Finset.sum_product']
+  refine Finset.sum_bij' (fun d _ => (Nat.gcd d M, Nat.gcd d M')) (fun q _ => q.1 * q.2)
+    ?_ ?_ ?_ ?_ ?_
+  · intro d hd
+    exact Finset.mem_product.mpr
+      ⟨Nat.mem_divisors.mpr ⟨Nat.gcd_dvd_right d M, hM⟩,
+        Nat.mem_divisors.mpr ⟨Nat.gcd_dvd_right d M', hM'⟩⟩
+  · intro q hq
+    obtain ⟨hq₁, hq₂⟩ := Finset.mem_product.mp hq
+    exact Nat.mem_divisors.mpr
+      ⟨Nat.mul_dvd_mul (Nat.mem_divisors.mp hq₁).1 (Nat.mem_divisors.mp hq₂).1,
+        Nat.mul_ne_zero hM hM'⟩
+  · intro d hd
+    exact (Nat.gcd_mul_gcd_eq_iff_dvd_mul_of_coprime hco).mpr (Nat.mem_divisors.mp hd).1
+  · intro q hq
+    obtain ⟨hq₁, hq₂⟩ := Finset.mem_product.mp hq
+    exact Prod.ext
+      (gcd_mul_left_of_dvd M M' hco (Nat.mem_divisors.mp hq₁).1 (Nat.mem_divisors.mp hq₂).1)
+      (gcd_mul_right_of_dvd M M' hco (Nat.mem_divisors.mp hq₁).1 (Nat.mem_divisors.mp hq₂).1)
+  · intro d hd
+    have hsplit : Nat.gcd d M * Nat.gcd d M' = d :=
+      (Nat.gcd_mul_gcd_eq_iff_dvd_mul_of_coprime hco).mpr (Nat.mem_divisors.mp hd).1
+    conv_lhs => rw [← hsplit]
+    exact slotAt_mul M M' (Nat.gcd d M) (Nat.gcd d M') hM hM' hco
+      (Nat.gcd_dvd_right d M) (Nat.gcd_dvd_right d M')
+
+private theorem slots_eq_dedekindPsi : ∀ n : ℕ, n ≠ 0 → slots n = ModularCurve.dedekindPsi n := by
+  intro n
+  induction n using Nat.recOnPosPrimePosCoprime with
+  | prime_pow p k hp hk =>
+    intro _
+    obtain ⟨j, rfl⟩ : ∃ j, k = j + 1 := ⟨k - 1, by omega⟩
+    rw [slots_prime_pow hp j, dedekindPsi_prime_pow' hp j]
+  | zero => exact fun h0 => absurd rfl h0
+  | one =>
+    intro _
+    rw [ModularCurve.dedekindPsi_one]
+    unfold slots
+    rw [Nat.divisors_one, Finset.sum_singleton]
+    exact slotAt_one 1
+  | coprime a b ha hb hab iha ihb =>
+    intro _
+    rw [slots_mul a b (by omega) (by omega) hab, iha (by omega), ihb (by omega),
+      ModularCurve.dedekindPsi_mul_of_coprime a b hab]
+
+private theorem dedekindPsi_pos {n : ℕ} (hn : n ≠ 0) : 0 < ModularCurve.dedekindPsi n := by
+  have h1 : (1 : ℕ) ∈ n.divisors.filter (fun d => Squarefree d) :=
+    Finset.mem_filter.mpr ⟨Nat.one_mem_divisors.mpr hn, squarefree_one⟩
+  have h2 : n / 1 ≤ ∑ d ∈ n.divisors with Squarefree d, n / d :=
+    Finset.single_le_sum (f := fun d => n / d) (fun i _ => Nat.zero_le _) h1
+  rw [Nat.div_one] at h2
+  exact lt_of_lt_of_le (Nat.pos_of_ne_zero hn) h2
+
+private theorem dedekindPsi_prime (p : ℕ) (hp : p.Prime) :
+    ModularCurve.dedekindPsi p = p + 1 := by
+  have h1 := ModularCurve.dedekindPsi_prime_pow p 1 hp one_ne_zero
+  rw [pow_one] at h1
+  rw [h1]
+  norm_num
+
+private theorem dedekindPsi_mul_prime_not_dvd {m p : ℕ} (hp : p.Prime) (hpm : ¬ p ∣ m) :
+    ModularCurve.dedekindPsi (m * p) = ModularCurve.dedekindPsi m * (p + 1) := by
+  have hco : Nat.Coprime m p := ((Nat.Prime.coprime_iff_not_dvd hp).mpr hpm).symm
+  rw [ModularCurve.dedekindPsi_mul_of_coprime m p hco, dedekindPsi_prime p hp]
+
+private theorem dedekindPsi_mul_prime_dvd {m p : ℕ} (hm : m ≠ 0) (hp : p.Prime)
+    (hpm : p ∣ m) : ModularCurve.dedekindPsi (m * p) = ModularCurve.dedekindPsi m * p := by
+  obtain ⟨k, u, hpu, hmu⟩ := Nat.exists_eq_pow_mul_and_not_dvd hm p hp.ne_one
+  obtain ⟨k', rfl⟩ : ∃ k', k = k' + 1 := by
+    rcases k with - | k'
+    · exfalso
+      rw [hmu, pow_zero, one_mul] at hpm
+      exact hpu hpm
+    · exact ⟨k', rfl⟩
+  subst hmu
+  have hcou : ∀ j : ℕ, j ≠ 0 → Nat.Coprime (p ^ j) u :=
+    fun j _ => Nat.Coprime.pow_left j ((Nat.Prime.coprime_iff_not_dvd hp).mpr hpu)
+  have h1 : p ^ (k' + 1) * u * p = p ^ (k' + 2) * u := by ring
+  rw [h1, ModularCurve.dedekindPsi_mul_of_coprime _ u (hcou _ (Nat.succ_ne_zero _)),
+    ModularCurve.dedekindPsi_mul_of_coprime _ u (hcou _ (Nat.succ_ne_zero _)),
+    ModularCurve.dedekindPsi_prime_pow p (k' + 2) hp (Nat.succ_ne_zero _),
+    ModularCurve.dedekindPsi_prime_pow p (k' + 1) hp (Nat.succ_ne_zero _)]
+  have h2 : k' + 2 - 1 = k' + 1 := rfl
+  have h3 : k' + 1 - 1 = k' := rfl
+  rw [h2, h3]
+  ring
+
+private theorem exists_ringHom_adjoin_of_isRoot {F E L : Type*} [Field F] [Field E] [Field L]
+    [Algebra F E] {α : E} (hα : IsIntegral F α) (ι : F →+* L) {y : L}
+    (hy : ((minpoly F α).map ι).IsRoot y) :
+    ∃ ψ : ↥(IntermediateField.adjoin F ({α} : Set E)) →+* L,
+      ψ.comp (algebraMap F (IntermediateField.adjoin F ({α} : Set E))) = ι ∧
+        ψ (IntermediateField.AdjoinSimple.gen F α) = y := by
+  let : Algebra F L := ι.toAlgebra
+  have halgL : algebraMap F L = ι := RingHom.algebraMap_toAlgebra ι
+  have hy' : y ∈ (minpoly F α).aroots L := by
+    rw [Polynomial.mem_aroots]
+    refine ⟨minpoly.ne_zero hα, ?_⟩
+    rw [Polynomial.aeval_def, halgL, Polynomial.eval₂_eq_eval_map]
+    exact hy
+  refine ⟨((IntermediateField.algHomAdjoinIntegralEquiv F hα).symm ⟨y, hy'⟩).toRingHom,
+    RingHom.ext fun z => ?_, ?_⟩
+  · rw [RingHom.comp_apply]
+    have h1 := ((IntermediateField.algHomAdjoinIntegralEquiv F hα).symm ⟨y, hy'⟩).commutes z
+    rwa [halgL] at h1
+  · exact IntermediateField.algHomAdjoinIntegralEquiv_symm_apply_gen F hα ⟨y, hy'⟩
+
+private theorem ringHom_comp_aeval {F A L : Type*} [Field F] [CommRing A] [Algebra F A]
+    [CommRing L] (ψ : A →+* L) (ι : F →+* L) (hcomp : ψ.comp (algebraMap F A) = ι)
+    (P : Polynomial F) (x : A) : ψ (Polynomial.aeval x P) = (P.map ι).eval (ψ x) := by
+  rw [Polynomial.aeval_def, Polynomial.hom_eval₂, hcomp, Polynomial.eval_map]
+
+variable {K : Type*} [Field K]
+
+private def sv (K : Type*) [Field K] (ζ : Kˣ) (a b : ℕ) : LaurentSeries K :=
+  if h : a = 0 then 0 else
+    letI : NeZero a := ⟨h⟩
+    qExpand K (a * a) (qTwist (ζ ^ (b * a)) (jqModC K))
+
+private theorem sv_eq (ζ : Kˣ) (a b : ℕ) [NeZero a] :
+    sv K ζ a b = qExpand K (a * a) (qTwist (ζ ^ (b * a)) (jqModC K)) := by
+  unfold sv
+  rw [dite_eq_right (NeZero.ne a)]
+
+private theorem sv_eq_TS (ζ : Kˣ) (a b : ℕ) [NeZero a] :
+    sv K ζ a b = TS K (a * a) (ζ ^ (b * a)) :=
+  sv_eq ζ a b
+
+private theorem TS_congr' {e e' : ℕ} [NeZero e] [NeZero e'] {u u' : Kˣ} (he : e = e')
+    (hu : u = u') : TS K e u = TS K e' u' := by
+  subst he
+  rw [hu]
+
+private theorem sv_inj {M : ℕ} {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) M)
+    {a b a' b' : ℕ} (ha0 : a ≠ 0) (ha0' : a' ≠ 0) (hb : b * a < M) (hb' : b' * a' < M)
+    (h : sv K ζ a b = sv K ζ a' b') : a = a' ∧ b = b' := by
+  have : NeZero a := ⟨ha0⟩
+  have : NeZero a' := ⟨ha0'⟩
+  rw [sv_eq_TS, sv_eq_TS] at h
+  obtain ⟨he, hu⟩ := TS_injective h
+  have haa : a = a' := (mul_self_inj (Nat.zero_le a) (Nat.zero_le a')).mp he
+  subst haa
+  refine ⟨rfl, ?_⟩
+  have hv : ((ζ : K)) ^ (b * a) = ((ζ : K)) ^ (b' * a) := by
+    have h1 := congrArg Units.val hu
+    rwa [Units.val_pow_eq_pow_val, Units.val_pow_eq_pow_val] at h1
+  have h2 : b * a = b' * a := hζ.pow_inj hb hb' hv
+  exact Nat.eq_of_mul_eq_mul_right (Nat.pos_of_ne_zero ha0) h2
+
+private theorem jqNModC_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) :
+    jqNModC K n = jqNModC K m := by
+  subst h
+  rfl
+
+private theorem sv_top (M : ℕ) [NeZero M] (ζ : Kˣ) :
+    sv K ζ M 0 = qExpand K M (jqNModC K M) := by
+  rw [sv_eq_TS, qExpand_jqNModC M M]
+  exact TS_congr' rfl (by rw [zero_mul, pow_zero])
+
+private theorem aeval_intermediateField_eq_zero {F₀ L : Type*} [Field F₀] [Field L]
+    [Algebra F₀ L] {E : IntermediateField F₀ L} {P : Polynomial F₀} {x : E}
+    (h : Polynomial.aeval (E.val x) P = 0) : Polynomial.aeval x P = 0 := by
+  have h1 := Polynomial.aeval_algHom_apply E.val x P
+  rw [h] at h1
+  have h2 : E.val (Polynomial.aeval x P) = E.val 0 := by rw [← h1, map_zero]
+  exact RingHom.injective (E.val : E →+* L) h2
+
+private theorem phiAtSeed_eval_of_injective {R S : Type*} [CommRing R] [CommRing S] {n : ℕ}
+    [NeZero n] (data : ModularPolynomialData n) (x y : R) (f : R →+* S)
+    (hf : Function.Injective f) (h : (phiAtSeed data (f x)).eval (f y) = 0) :
+    (phiAtSeed data x).eval y = 0 := by
+  rw [← phiAtSeed_map, Polynomial.eval_map, Polynomial.eval₂_hom] at h
+  exact (injective_iff_map_eq_zero f).mp hf _ h
+
+private def jGenC : K⟮jqModC K⟯ :=
+  ⟨jqModC K, IntermediateField.mem_adjoin_simple_self K (jqModC K)⟩
+
+private theorem jqdC_mem_fullC {M d : ℕ} [NeZero d] (hdM : d ∣ M) :
+    jqNModC K d ∈ IntermediateField.adjoin K
+      {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ M ∧ x = jqNModC K d'} :=
+  IntermediateField.subset_adjoin K _ ⟨d, ‹_›, hdM, rfl⟩
+
+private theorem mem_adjoin_jqNModC_of_mem_mffC {M : ℕ} [NeZero M] {x : LaurentSeries K}
+    (hx : x ∈ modularFunctionFieldC K M) :
+    x ∈ IntermediateField.adjoin K⟮jqModC K⟯ ({jqNModC K M} : Set (LaurentSeries K)) := by
+  have hle : K⟮jqModC K⟯ ≤
+      IntermediateField.adjoin K ({jqModC K, jqNModC K M} : Set (LaurentSeries K)) :=
+    IntermediateField.adjoin.mono K _ _
+      (Set.singleton_subset_iff.mpr (Set.mem_insert _ _))
+  have hE := IntermediateField.extendScalars_adjoin hle
+  have hcollapse : IntermediateField.adjoin K⟮jqModC K⟯
+      ({jqModC K, jqNModC K M} : Set (LaurentSeries K))
+      = IntermediateField.adjoin K⟮jqModC K⟯ ({jqNModC K M} : Set (LaurentSeries K)) := by
+    refine le_antisymm (IntermediateField.adjoin_le_iff.mpr ?_)
+      (IntermediateField.adjoin.mono _ _ _ ?_)
+    · rintro z (rfl | rfl)
+      · exact (IntermediateField.adjoin K⟮jqModC K⟯ _).algebraMap_mem jGenC
+      · exact IntermediateField.subset_adjoin K⟮jqModC K⟯ _ rfl
+    · exact Set.singleton_subset_iff.mpr (Set.mem_insert_of_mem _ rfl)
+  rw [modularFunctionFieldC] at hx
+  have h2 : x ∈ IntermediateField.extendScalars hle :=
+    (IntermediateField.mem_extendScalars _).mpr hx
+  rw [hE, hcollapse] at h2
+  exact h2
+
+private theorem mem_range_of_eval_eq_const {F L : Type*} [Field F] [Field L] (ι : F →+* L)
+    (g : Polynomial F) (x : L) (s : Finset L) (hcard : g.natDegree < s.card)
+    (hval : ∀ y ∈ s, (g.map ι).eval y = x) : x ∈ ι.range := by
+  classical
+  set Q : Polynomial L := g.map ι - Polynomial.C x with hQ
+  have hQdeg : Q.natDegree ≤ g.natDegree := by
+    refine (Polynomial.natDegree_sub_le _ _).trans ?_
+    rw [Polynomial.natDegree_map, Polynomial.natDegree_C, max_eq_left (Nat.zero_le _)]
+  have hQ0 : Q = 0 := by
+    refine Polynomial.eq_zero_of_natDegree_lt_card_of_eval_eq_zero' Q s (fun y hy => ?_)
+      (hQdeg.trans_lt hcard)
+    rw [hQ, Polynomial.eval_sub, Polynomial.eval_C, hval y hy, sub_self]
+  have hconst : g.map ι = Polynomial.C x := sub_eq_zero.mp hQ0
+  refine ⟨g.coeff 0, ?_⟩
+  have h2 := congrArg (fun P : Polynomial L => P.coeff 0) hconst
+  simpa only [Polynomial.coeff_map, Polynomial.coeff_C_zero] using h2
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData jqd_mem_full \
+  coeffMap coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one map_jqModC modularFunctionFieldC \
+  coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime"
+
+section RValCore
+
+variable {K : Type*} [Field K]
+
+private theorem map_qExpand_minpoly_eq {M' : ℕ} [NeZero M'] (k : ℕ) [NeZero k] {N : ℕ}
+    [NeZero N] (hN : N = k * M') (ζ' : Kˣ)
+    (hid : (minpoly K⟮jqModC K⟯ (jqNModC K M')).map
+        ((qExpand K M').comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))
+      = ∏ a ∈ M'.divisors, ∏ b ∈ (Finset.range (M' / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M' / a) = 1),
+          (Polynomial.X - Polynomial.C (sv K ζ' a b))) :
+    (minpoly K⟮jqModC K⟯ (jqNModC K M')).map
+        ((qExpand K N).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))
+      = ∏ a ∈ M'.divisors, ∏ b ∈ (Finset.range (M' / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M' / a) = 1),
+          (Polynomial.X - Polynomial.C (qExpand K k (sv K ζ' a b))) := by
+  subst hN
+  have hcomp : (qExpand K k).comp
+      ((qExpand K M').comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))
+      = (qExpand K (k * M')).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K)) := by
+    refine RingHom.ext fun z => ?_
+    simp only [RingHom.comp_apply]
+    rw [qExpand_qExpand]
+  have h1 : (minpoly K⟮jqModC K⟯ (jqNModC K M')).map
+      ((qExpand K (k * M')).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))
+      = ((minpoly K⟮jqModC K⟯ (jqNModC K M')).map
+          ((qExpand K M').comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))).map (qExpand K k) := by
+    rw [Polynomial.map_map, hcomp]
+  rw [h1, hid, Polynomial.map_prod]
+  refine Finset.prod_congr rfl fun a _ => ?_
+  rw [Polynomial.map_prod]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C]
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+private theorem rval_aux : ∀ (M : ℕ) [NeZero M] {K : Type*} [Field K]
+    (ζ : Kˣ), IsPrimitiveRoot ((ζ : Kˣ) : K) M →
+    (∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank K⟮jqModC K⟯
+          (IntermediateField.adjoin K⟮jqModC K⟯
+            ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d
+        ∧ modularFunctionFieldC K d = IntermediateField.adjoin K
+            {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ d ∧ x = jqNModC K d'}) →
+    (minpoly K⟮jqModC K⟯ (jqNModC K M)).map
+        ((qExpand K M).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))
+      = ∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+          (Polynomial.X - Polynomial.C (sv K ζ a b)) := by
+  intro M
+  induction M using Nat.strong_induction_on with
+  | _ M IH =>
+  intro _ K _ ζ hζ hall
+  classical
+  have hM0 : M ≠ 0 := NeZero.ne M
+  have hslot_root : ∀ a b : ℕ, a ∈ M.divisors →
+      b ∈ (Finset.range (M / a)).filter (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1) →
+      ((minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K M).comp (algebraMap K⟮jqModC K⟯
+        (LaurentSeries K)))).IsRoot (sv K ζ a b) := by
+    intro a b ha hb
+    obtain ⟨haM, -⟩ := Nat.mem_divisors.mp ha
+    obtain ⟨hbr, hbc⟩ := Finset.mem_filter.mp hb
+    rw [Finset.mem_range] at hbr
+    have ha0 : a ≠ 0 := by
+      rintro rfl
+      exact hM0 (Nat.eq_zero_of_zero_dvd haM)
+    have : NeZero a := ⟨ha0⟩
+    have had : a * (M / a) = M := Nat.mul_div_cancel' haM
+    by_cases hd1 : M / a = 1
+    · have haM' : a = M := by rw [hd1, mul_one] at had; exact had
+      have hb0 : b = 0 := by omega
+      subst hb0
+      rw [show sv K ζ a 0 = sv K ζ M 0 from by rw [haM'], sv_top]
+      rw [Polynomial.IsRoot, Polynomial.eval_map, ← Polynomial.hom_eval₂]
+      have h0 : Polynomial.eval₂ (algebraMap K⟮jqModC K⟯ (LaurentSeries K)) (jqNModC K M)
+          (minpoly K⟮jqModC K⟯ (jqNModC K M)) = 0 := by
+        rw [← Polynomial.aeval_def]
+        exact minpoly.aeval _ _
+      rw [h0, map_zero]
+    · have hd0 : M / a ≠ 0 := by
+        intro h0
+        rw [h0, mul_zero] at had
+        exact hM0 had.symm
+      have hpp : (M / a).minFac.Prime := Nat.minFac_prime hd1
+      have : Fact (M / a).minFac.Prime := ⟨hpp⟩
+      have : NeZero (M / a).minFac := ⟨hpp.ne_zero⟩
+      obtain ⟨d'', hdd⟩ : (M / a).minFac ∣ M / a := Nat.minFac_dvd _
+      set p := (M / a).minFac with hp_def
+      have hd''0 : d'' ≠ 0 := by
+        rintro rfl
+        rw [mul_zero] at hdd
+        exact hd0 hdd
+      have : NeZero d'' := ⟨hd''0⟩
+      have hM'0 : a * d'' ≠ 0 := Nat.mul_ne_zero ha0 hd''0
+      have : NeZero (a * d'') := ⟨hM'0⟩
+      have hMM' : M = a * d'' * p := by rw [← had, hdd]; ring
+      have hM'M : a * d'' ∣ M := ⟨p, hMM'⟩
+      have hM'lt : a * d'' < M := by
+        calc a * d'' = a * d'' * 1 := by ring
+          _ < a * d'' * p :=
+              (Nat.mul_lt_mul_left (Nat.pos_of_ne_zero hM'0)).mpr hpp.one_lt
+          _ = M := hMM'.symm
+      have hpM : p ∣ M := by
+        have hpd : p ∣ M / a := ⟨d'', hdd⟩
+        exact hpd.trans (Nat.div_dvd_of_dvd haM)
+      have hb''lt : b % d'' < d'' := Nat.mod_lt b (Nat.pos_of_ne_zero hd''0)
+      have hbsplit : b % d'' + b / d'' * d'' = b := Nat.mod_add_div' b d''
+      have hc₀p : b / d'' < p := by
+        have h1 : b < d'' * p := by rw [Nat.mul_comm d'' p, ← hdd]; exact hbr
+        exact Nat.div_lt_of_lt_mul h1
+      have hprim' : Nat.gcd (Nat.gcd a (b % d'')) d'' = 1 := by
+        have h1 : Nat.gcd (Nat.gcd a (b % d'')) d'' ∣ Nat.gcd (Nat.gcd a b) (M / a) := by
+          refine Nat.dvd_gcd (Nat.dvd_gcd ?_ ?_) ?_
+          · exact (Nat.gcd_dvd_left _ _).trans (Nat.gcd_dvd_left a (b % d''))
+          · have hgb'' : Nat.gcd (Nat.gcd a (b % d'')) d'' ∣ b % d'' :=
+              (Nat.gcd_dvd_left _ _).trans (Nat.gcd_dvd_right a (b % d''))
+            have hgd'' : Nat.gcd (Nat.gcd a (b % d'')) d'' ∣ d'' := Nat.gcd_dvd_right _ _
+            have h2 : Nat.gcd (Nat.gcd a (b % d'')) d'' ∣ b % d'' + b / d'' * d'' :=
+              Nat.dvd_add hgb'' (hgd''.mul_left _)
+            rwa [hbsplit] at h2
+          · rw [hdd]
+            exact (Nat.gcd_dvd_right _ _).mul_left p
+        rw [hbc] at h1
+        exact Nat.dvd_one.mp h1
+      have hζ' : IsPrimitiveRoot ((ζ ^ p : Kˣ) : K) (a * d'') := by
+        have h1 := isPrimitiveRoot_pow_div hζ hM'M
+        have h2 : M / (a * d'') = p := by
+          rw [hMM']
+          exact Nat.mul_div_cancel_left p (Nat.pos_of_ne_zero hM'0)
+        rwa [h2] at h1
+      have hIH := IH (a * d'') hM'lt (ζ ^ p) hζ' (fun e he _ => hall e (he.trans hM'M))
+      have hIHM := map_qExpand_minpoly_eq p (show M = p * (a * d'') from by rw [hMM']; ring)
+        (ζ ^ p) hIH
+      have hroot' : ((minpoly K⟮jqModC K⟯ (jqNModC K (a * d''))).map ((qExpand K M).comp (algebraMap
+        K⟮jqModC K⟯ (LaurentSeries K)))).IsRoot
+          (qExpand K p (sv K (ζ ^ p) a (b % d''))) := by
+        rw [hIHM, Polynomial.IsRoot, Polynomial.eval_prod]
+        refine Finset.prod_eq_zero (Nat.mem_divisors.mpr ⟨⟨d'', rfl⟩, hM'0⟩) ?_
+        rw [Polynomial.eval_prod]
+        have hM'a : a * d'' / a = d'' := Nat.mul_div_cancel_left d'' (Nat.pos_of_ne_zero ha0)
+        refine Finset.prod_eq_zero (i := b % d'') ?_ ?_
+        · rw [hM'a]
+          exact Finset.mem_filter.mpr ⟨Finset.mem_range.mpr hb''lt, hprim'⟩
+        · rw [Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, sub_self]
+      obtain ⟨htM', hgM'⟩ := hall (a * d'') hM'M
+      have hfd' : FiniteDimensional K⟮jqModC K⟯
+          (IntermediateField.adjoin K⟮jqModC K⟯
+            ({jqNModC K (a * d'')} : Set (LaurentSeries K))) :=
+        FiniteDimensional.of_finrank_pos (htM' ▸ dedekindPsi_pos hM'0)
+      have hα' : IsIntegral K⟮jqModC K⟯ (jqNModC K (a * d'')) :=
+        IntermediateField.isIntegral_iff.mp (IsIntegral.of_finite K⟮jqModC K⟯
+          (⟨jqNModC K (a * d''), IntermediateField.subset_adjoin K⟮jqModC K⟯ _ rfl⟩ :
+            IntermediateField.adjoin K⟮jqModC K⟯
+              ({jqNModC K (a * d'')} : Set (LaurentSeries K))))
+      obtain ⟨ψ₁, hψcomp, hψ₁⟩ := exists_ringHom_adjoin_of_isRoot hα'
+        ((qExpand K M).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K))) hroot'
+      obtain ⟨dp, -, hdpsym⟩ := ModularCurve.exists_phiIrreducible_evalSymm p
+      have hup : (phiAtSeed dp (jqNModC K (a * d''))).eval (jqNModC K M) = 0 := by
+        have h1 := phiAtSeed_jqNModC_eval (R := K) p dp (a * d'')
+        rwa [show jqNModC K (a * d'' * p) = jqNModC K M from jqNModC_congr hMM'.symm] at h1
+      have haev : Polynomial.aeval (jqNModC K M)
+          (phiAtSeed dp (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K (a * d'')))) = 0
+            := by
+        rw [Polynomial.aeval_def, Polynomial.eval₂_eq_eval_map, phiAtSeed_map]
+        exact hup
+      have hα₁ : IsIntegral K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M) :=
+        ⟨phiAtSeed dp (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K (a * d''))),
+          phiAtSeed_monic dp _, by rw [← Polynomial.aeval_def]; exact haev⟩
+      have hmindvd : minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)
+          ∣ phiAtSeed dp (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K (a * d''))) :=
+        minpoly.dvd _ _ haev
+      let : Module.Free K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ :=
+        Module.Free.of_divisionRing _ _
+      let : Module.Free K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯
+          K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯⟮jqNModC K M⟯ :=
+        Module.Free.of_divisionRing _ _
+      have htow := Module.finrank_mul_finrank K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯
+        K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯⟮jqNModC K M⟯
+      have habs : IntermediateField.adjoin K⟮jqModC K⟯
+          (({jqNModC K (a * d'')} : Set (LaurentSeries K)) ∪ {jqNModC K M})
+          = IntermediateField.adjoin K⟮jqModC K⟯ ({jqNModC K M} : Set (LaurentSeries K)) := by
+        obtain ⟨-, hgM⟩ := hall M dvd_rfl
+        refine le_antisymm (IntermediateField.adjoin_le_iff.mpr ?_)
+          (IntermediateField.adjoin.mono _ _ _ Set.subset_union_right)
+        rintro z (hz | hz)
+        · rw [Set.mem_singleton_iff] at hz
+          subst hz
+          have h1 : jqNModC K (a * d'') ∈ IntermediateField.adjoin K
+              {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ M ∧ x = jqNModC K d'} :=
+            jqdC_mem_fullC hM'M
+          rw [← hgM] at h1
+          exact mem_adjoin_jqNModC_of_mem_mffC h1
+        · rw [Set.mem_singleton_iff] at hz
+          subst hz
+          exact IntermediateField.subset_adjoin _ _ rfl
+      have htop : Module.finrank K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯⟮jqNModC K M⟯ =
+        dedekindPsi M :=
+        by
+        obtain ⟨htM, -⟩ := hall M dvd_rfl
+        have h1 := IntermediateField.adjoin_adjoin_left K⟮jqModC K⟯
+          ({jqNModC K (a * d'')} : Set (LaurentSeries K)) {jqNModC K M}
+        have h2 : Module.finrank K⟮jqModC K⟯
+            (IntermediateField.restrictScalars K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯⟮jqNModC
+              K M⟯)
+            = Module.finrank K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯⟮jqNModC K M⟯ := rfl
+        rw [← h2, h1, habs]
+        exact htM
+      have hstep_deg : Module.finrank K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ K⟮jqModC K⟯⟮jqNModC K (a *
+        d'')⟯⟮jqNModC K M⟯
+          * dedekindPsi (a * d'') = dedekindPsi M := by
+        rw [← htM', ← htop, Nat.mul_comm]
+        exact htow
+      have hseed : qExpand K p (sv K (ζ ^ p) a (b % d''))
+          = qExpand K (p * (a * a)) (qTwist ((ζ ^ (b % d'' * a)) ^ p) (jqModC K)) := by
+        rw [sv_eq_TS, qExpand_TS]
+        change TS K (p * (a * a)) ((ζ ^ p) ^ (b % d'' * a))
+          = TS K (p * (a * a)) ((ζ ^ (b % d'' * a)) ^ p)
+        exact TS_congr' rfl (by rw [← pow_mul, ← pow_mul, Nat.mul_comm])
+      have hζ'p : IsPrimitiveRoot ((ζ ^ (M / p) : Kˣ) : K) p := isPrimitiveRoot_pow_div hζ hpM
+      have hC5 := ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot p (ζ ^ (M / p))
+        hζ'p dp (a * a) (ζ ^ (b % d'' * a))
+      have hC5' : phiAtSeed dp (qExpand K (p * (a * a))
+            (qTwist ((ζ ^ (b % d'' * a)) ^ p) (jqModC K)))
+          = (Polynomial.X - Polynomial.C (qExpand K (p * (p * (a * a)))
+              (qTwist ((ζ ^ (b % d'' * a)) ^ (p * p)) (jqModC K))))
+            * ∏ c ∈ Finset.range p, (Polynomial.X - Polynomial.C (qExpand K (a * a)
+              (qTwist (ζ ^ (b % d'' * a) * ζ ^ (c * (M / p))) (jqModC K)))) := by
+        have h1 : phiAtSeed dp (qExpand K (p * (a * a))
+              (qTwist ((ζ ^ (b % d'' * a)) ^ p) (jqModC K)))
+            = (Polynomial.X - Polynomial.C (qExpand K (p * (p * (a * a)))
+                (qTwist ((ζ ^ (b % d'' * a)) ^ (p * p)) (jqModC K))))
+              * ∏ c ∈ Finset.range p, (Polynomial.X - Polynomial.C (qExpand K (a * a)
+                (qTwist (ζ ^ (b % d'' * a) * (ζ ^ (M / p)) ^ c) (jqModC K)))) := hC5
+        rw [h1]
+        congr 1
+        refine Finset.prod_congr rfl fun c _ => ?_
+        rw [← pow_mul, Nat.mul_comm (M / p) c]
+      have hΦfact : phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d'')))
+          = (Polynomial.X - Polynomial.C (qExpand K (p * (p * (a * a)))
+              (qTwist ((ζ ^ (b % d'' * a)) ^ (p * p)) (jqModC K))))
+            * ∏ c ∈ Finset.range p, (Polynomial.X - Polynomial.C (qExpand K (a * a)
+              (qTwist (ζ ^ (b % d'' * a) * ζ ^ (c * (M / p))) (jqModC K)))) := by
+        rw [hseed]
+        exact hC5'
+      have hMp : M / p = a * d'' := by
+        rw [hMM']
+        exact Nat.mul_div_cancel _ hpp.pos
+      have htarget : qExpand K (a * a) (qTwist (ζ ^ (b % d'' * a) * ζ ^ (b / d'' * (M / p)))
+          (jqModC K)) = sv K ζ a b := by
+        rw [sv_eq]
+        change TS K (a * a) (ζ ^ (b % d'' * a) * ζ ^ (b / d'' * (M / p)))
+          = TS K (a * a) (ζ ^ (b * a))
+        refine TS_congr' rfl ?_
+        rw [hMp, ← pow_add]
+        congr 1
+        rw [show b % d'' * a + b / d'' * (a * d'')
+          = (b % d'' + b / d'' * d'') * a from by ring, hbsplit]
+      by_cases hpM' : p ∣ a * d''
+      · have hψM : dedekindPsi M = dedekindPsi (a * d'') * p := by
+          rw [hMM']
+          exact dedekindPsi_mul_prime_dvd hM'0 hpp hpM'
+        have he : Module.finrank K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ K⟮jqModC K⟯⟮jqNModC K (a *
+          d'')⟯⟮jqNModC K M⟯ = p :=
+          by
+          have h1 : Module.finrank K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ K⟮jqModC K⟯⟮jqNModC K (a *
+            d'')⟯⟮jqNModC K M⟯
+              * dedekindPsi (a * d'') = p * dedekindPsi (a * d'') := by
+            rw [hstep_deg, hψM]
+            ring
+          exact Nat.eq_of_mul_eq_mul_right (dedekindPsi_pos hM'0) h1
+        obtain ⟨m'', hm''⟩ := hpM'
+        have hm''0 : m'' ≠ 0 := by
+          rintro rfl
+          rw [mul_zero] at hm''
+          exact hM'0 hm''
+        have : NeZero m'' := ⟨hm''0⟩
+        have hm''M : m'' ∣ M := ⟨p * p, by rw [hMM', hm'']; ring⟩
+        have hm''lt : m'' < M := by
+          calc m'' ≤ a * d'' := by rw [hm'']; exact Nat.le_mul_of_pos_left m'' hpp.pos
+            _ < M := hM'lt
+        have hdown : (phiAtSeed dp (jqNModC K (a * d''))).eval (jqNModC K m'') = 0 := by
+          have h1 := phiAtSeed_jqNModC_eval_symm (R := K) p dp hdpsym m''
+          rwa [show jqNModC K (m'' * p) = jqNModC K (a * d'')
+            from jqNModC_congr (by rw [hm'']; ring)] at h1
+        have hmem'' : jqNModC K m'' ∈ K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ := by
+          have h1 : jqNModC K m'' ∈ IntermediateField.adjoin K
+              {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ a * d'' ∧ x = jqNModC K d'} :=
+            jqdC_mem_fullC ⟨p, by rw [hm'']; ring⟩
+          rw [← hgM'] at h1
+          exact mem_adjoin_jqNModC_of_mem_mffC h1
+        have hdownF₁ : (phiAtSeed dp (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯
+            (jqNModC K (a * d'')))).eval (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a *
+              d'')⟯) = 0 :=
+          phiAtSeed_eval_of_injective dp _ _
+            (algebraMap K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (LaurentSeries K)) (RingHom.injective _)
+              hdown
+        have hψx'' : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d'')))).IsRoot
+            (ψ₁ (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)) := by
+          have h1 := phiAtSeed_eval_map dp _ _ ψ₁ hdownF₁
+          rwa [hψ₁] at h1
+        have hx''notmin : ¬ (minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).IsRoot
+            (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯) := by
+          intro hcon
+          obtain ⟨q, hq⟩ := Polynomial.dvd_iff_isRoot.mpr hcon
+          have hirr := minpoly.irreducible hα₁
+          rcases hirr.isUnit_or_isUnit hq with hu | hu
+          · exact Polynomial.not_isUnit_X_sub_C _ hu
+          · have hq0 : q ≠ 0 := by
+              rintro rfl
+              rw [mul_zero] at hq
+              exact minpoly.ne_zero hα₁ hq
+            have hdm : (minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).natDegree = 1 := by
+              rw [hq, Polynomial.natDegree_mul (Polynomial.X_sub_C_ne_zero _) hq0,
+                Polynomial.natDegree_X_sub_C, Polynomial.natDegree_eq_zero_of_isUnit hu]
+            have hdm' : (minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).natDegree = p := by
+              rw [← IntermediateField.adjoin.finrank hα₁]
+              exact he
+            rw [hdm] at hdm'
+            exact (Nat.ne_of_lt hpp.one_lt) hdm'
+        have hψx''notmin : ¬ ((minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).map
+            ψ₁).IsRoot (ψ₁ (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)) := by
+          intro hcon
+          rw [Polynomial.IsRoot, Polynomial.eval_map, Polynomial.eval₂_hom] at hcon
+          exact hx''notmin ((injective_iff_map_eq_zero ψ₁).mp (RingHom.injective ψ₁) _ hcon)
+        have htarget_ne : sv K ζ a b ≠ ψ₁ (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a *
+          d'')⟯) :=
+          by
+          intro hcon
+          have hroot'' : ((minpoly K⟮jqModC K⟯ (jqNModC K m'')).map ((qExpand K M).comp
+              (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))).IsRoot
+              (ψ₁ (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)) := by
+            have h1 : Polynomial.aeval
+                (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)
+                (minpoly K⟮jqModC K⟯ (jqNModC K m'')) = 0 := by
+              refine aeval_intermediateField_eq_zero ?_
+              change Polynomial.aeval (jqNModC K m'') (minpoly K⟮jqModC K⟯ (jqNModC K m'')) = 0
+              exact minpoly.aeval _ _
+            have h2 := ringHom_comp_aeval ψ₁ ((qExpand K M).comp
+              (algebraMap K⟮jqModC K⟯ (LaurentSeries K))) hψcomp
+              (minpoly K⟮jqModC K⟯ (jqNModC K m''))
+              (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)
+            rw [h1, map_zero] at h2
+            exact h2.symm
+          have hζ'' : IsPrimitiveRoot ((ζ ^ (p * p) : Kˣ) : K) m'' := by
+            have h1 := isPrimitiveRoot_pow_div hζ hm''M
+            have h2 : M / m'' = p * p := by
+              rw [hMM', hm'', show p * m'' * p = m'' * (p * p) from by ring]
+              exact Nat.mul_div_cancel_left _ (Nat.pos_of_ne_zero hm''0)
+            rwa [h2] at h1
+          have hIH'' := IH m'' hm''lt (ζ ^ (p * p)) hζ''
+            (fun e he'' _ => hall e (he''.trans hm''M))
+          have hIHM'' := map_qExpand_minpoly_eq (p * p)
+            (show M = p * p * m'' from by rw [hMM', hm'']; ring) (ζ ^ (p * p)) hIH''
+          rw [hIHM''] at hroot''
+          rw [Polynomial.IsRoot, Polynomial.eval_prod] at hroot''
+          obtain ⟨α, hαmem, hα0⟩ := Finset.prod_eq_zero_iff.mp hroot''
+          rw [Polynomial.eval_prod] at hα0
+          obtain ⟨β, hβmem, hβ0⟩ := Finset.prod_eq_zero_iff.mp hα0
+          rw [Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, sub_eq_zero] at hβ0
+          obtain ⟨hαdvd, -⟩ := Nat.mem_divisors.mp hαmem
+          obtain ⟨hβr, -⟩ := Finset.mem_filter.mp hβmem
+          rw [Finset.mem_range] at hβr
+          have hα0' : α ≠ 0 := by
+            rintro rfl
+            exact hm''0 (Nat.eq_zero_of_zero_dvd hαdvd)
+          have : NeZero α := ⟨hα0'⟩
+          have hcoll : TS K (a * a) (ζ ^ (b * a))
+              = TS K (p * p * (α * α)) (ζ ^ (p * p * (β * α))) := by
+            calc TS K (a * a) (ζ ^ (b * a)) = sv K ζ a b := (sv_eq_TS ζ a b).symm
+              _ = ψ₁ (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯) := hcon
+              _ = qExpand K (p * p) (sv K (ζ ^ (p * p)) α β) := hβ0
+              _ = qExpand K (p * p) (TS K (α * α) ((ζ ^ (p * p)) ^ (β * α))) := by
+                  rw [sv_eq_TS]
+              _ = TS K (p * p * (α * α)) ((ζ ^ (p * p)) ^ (β * α)) := qExpand_TS _ _ _
+              _ = TS K (p * p * (α * α)) (ζ ^ (p * p * (β * α))) :=
+                  TS_congr' rfl (by rw [← pow_mul])
+          obtain ⟨hexp, hunit⟩ := TS_injective hcoll
+          have haα : a = p * α := by
+            have h2 : a * a = (p * α) * (p * α) := by rw [hexp]; ring
+            exact (mul_self_inj (Nat.zero_le _) (Nat.zero_le _)).mp h2
+          have hpa : p ∣ a := ⟨α, haα⟩
+          have hba : b * a < M := by
+            calc b * a < M / a * a :=
+                (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr
+              _ = M := by rw [Nat.mul_comm] at had; exact had
+          have hppβα : p * p * (β * α) < M := by
+            have h1 : β * α < m'' := by
+              calc β * α < m'' / α * α :=
+                  (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero hα0')).mpr hβr
+                _ ≤ m'' := Nat.div_mul_le_self m'' α
+            calc p * p * (β * α) < p * p * m'' :=
+                (Nat.mul_lt_mul_left (Nat.mul_pos hpp.pos hpp.pos)).mpr h1
+              _ = M := by rw [hMM', hm'']; ring
+          have hvv : ((ζ : K)) ^ (b * a) = ((ζ : K)) ^ (p * p * (β * α)) := by
+            have h1 := congrArg Units.val hunit
+            rwa [Units.val_pow_eq_pow_val, Units.val_pow_eq_pow_val] at h1
+          have hexp2 : b * a = p * p * (β * α) := hζ.pow_inj hba hppβα hvv
+          have hpb : p ∣ b := by
+            refine ⟨β, ?_⟩
+            rw [haα] at hexp2
+            have h1 : b * (p * α) = p * β * (p * α) := by
+              rw [hexp2]
+              ring
+            exact Nat.eq_of_mul_eq_mul_right (Nat.mul_pos hpp.pos
+              (Nat.pos_of_ne_zero hα0')) h1
+          have hfinal : p ∣ Nat.gcd (Nat.gcd a b) (M / a) :=
+            Nat.dvd_gcd (Nat.dvd_gcd hpa hpb) ⟨d'', hdd⟩
+          rw [hbc] at hfinal
+          exact hpp.ne_one (Nat.dvd_one.mp hfinal)
+        have hQ : (Polynomial.X - Polynomial.C (ψ₁ (⟨jqNModC K m'', hmem''⟩ :
+            K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯))) * (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b %
+              d''))) /ₘ
+            (Polynomial.X - Polynomial.C (ψ₁ (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a *
+              d'')⟯))))
+            = phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) :=
+          Polynomial.mul_divByMonic_eq_iff_isRoot.mpr hψx''
+        have hΦmonic : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d'')))).Monic :=
+          phiAtSeed_monic dp _
+        have hQmonic : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+            (Polynomial.X - Polynomial.C (ψ₁ (⟨jqNModC K m'', hmem''⟩ :
+              K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)))).Monic :=
+          Polynomial.Monic.of_mul_monic_left (Polynomial.monic_X_sub_C _)
+            (by rw [hQ]; exact hΦmonic)
+        have hΦdeg : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d'')))).natDegree
+            = p + 1 := by
+          rw [phiAtSeed_natDegree]
+          exact dedekindPsi_prime p hpp
+        have hQdeg : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+            (Polynomial.X - Polynomial.C (ψ₁ (⟨jqNModC K m'', hmem''⟩ :
+              K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)))).natDegree = p := by
+          have h1 : p + 1 = 1 + (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+              (Polynomial.X - Polynomial.C (ψ₁ (⟨jqNModC K m'', hmem''⟩ :
+                K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)))).natDegree := by
+            rw [← hΦdeg]
+            conv_lhs => rw [← hQ]
+            rw [Polynomial.natDegree_mul (Polynomial.X_sub_C_ne_zero _) hQmonic.ne_zero,
+              Polynomial.natDegree_X_sub_C]
+          omega
+        have hP₁dvd : (minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).map
+            ψ₁
+            ∣ phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) := by
+          have h1 := Polynomial.map_dvd ψ₁ hmindvd
+          rwa [phiAtSeed_map, show ψ₁
+            (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K (a * d'')))
+            = qExpand K p (sv K (ζ ^ p) a (b % d'')) from hψ₁] at h1
+        have hcop : IsCoprime (Polynomial.X - Polynomial.C (ψ₁ (⟨jqNModC K m'', hmem''⟩ :
+            K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)))
+            ((minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).map
+              ψ₁) := by
+          rw [(Polynomial.irreducible_X_sub_C _).coprime_iff_not_dvd]
+          intro hcon
+          exact hψx''notmin (Polynomial.dvd_iff_isRoot.mp hcon)
+        have hP₁dvdQ : (minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).map
+            ψ₁
+            ∣ phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+              (Polynomial.X - Polynomial.C (ψ₁ (⟨jqNModC K m'', hmem''⟩ :
+                K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯))) := by
+          have h1 := hP₁dvd
+          rw [← hQ] at h1
+          exact (hcop.symm).dvd_of_dvd_mul_left h1
+        have hdeg₁ : ((minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).map
+            ψ₁).natDegree = p := by
+          rw [Polynomial.Monic.natDegree_map (minpoly.monic hα₁),
+            ← IntermediateField.adjoin.finrank hα₁]
+          exact he
+        have hmineqQ : (minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).map
+            ψ₁
+            = phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+              (Polynomial.X - Polynomial.C (ψ₁ (⟨jqNModC K m'', hmem''⟩ :
+                K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯))) :=
+          Polynomial.eq_of_monic_of_dvd_of_natDegree_le ((minpoly.monic hα₁).map _)
+            hQmonic hP₁dvdQ (le_of_eq (hQdeg.trans hdeg₁.symm)) |>.symm
+        have htargetΦ : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d'')))).IsRoot
+            (sv K ζ a b) := by
+          rw [hΦfact, Polynomial.IsRoot, Polynomial.eval_mul]
+          refine mul_eq_zero.mpr (Or.inr ?_)
+          rw [Polynomial.eval_prod]
+          refine Finset.prod_eq_zero (Finset.mem_range.mpr hc₀p) ?_
+          rw [htarget, Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, sub_self]
+        have hroot_step : ((minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).map
+            ψ₁).IsRoot (sv K ζ a b) := by
+          rw [hmineqQ, Polynomial.IsRoot]
+          have h1 : ((Polynomial.X - Polynomial.C (ψ₁ (⟨jqNModC K m'', hmem''⟩ :
+              K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯))) * (phiAtSeed dp (qExpand K p
+              (sv K (ζ ^ p) a (b % d''))) /ₘ (Polynomial.X - Polynomial.C
+              (ψ₁ (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯))))).eval (sv K ζ a b)
+                = 0 := by
+            rw [hQ]
+            exact htargetΦ
+          rw [Polynomial.eval_mul, Polynomial.eval_sub, Polynomial.eval_X,
+            Polynomial.eval_C] at h1
+          rcases mul_eq_zero.mp h1 with h2 | h2
+          · exact absurd (sub_eq_zero.mp h2) htarget_ne
+          · exact h2
+        have htowdvd : minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)
+            ∣ (minpoly K⟮jqModC K⟯ (jqNModC K M)).map (algebraMap K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K
+              (a * d'')⟯) :=
+          minpoly.dvd_map_of_isScalarTower K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K
+            M)
+        have h1 := Polynomial.map_dvd ψ₁ htowdvd
+        rw [Polynomial.map_map] at h1
+        have h2 : ψ₁.comp (algebraMap K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)
+            = (qExpand K M).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K)) := hψcomp
+        rw [h2] at h1
+        exact Polynomial.eval_eq_zero_of_dvd_of_eval_eq_zero h1 hroot_step
+      · have hψM : dedekindPsi M = dedekindPsi (a * d'') * (p + 1) := by
+          rw [hMM']
+          exact dedekindPsi_mul_prime_not_dvd hpp hpM'
+        have he : Module.finrank K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ K⟮jqModC K⟯⟮jqNModC K (a *
+          d'')⟯⟮jqNModC K M⟯
+            = p + 1 := by
+          have h1 : Module.finrank K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ K⟮jqModC K⟯⟮jqNModC K (a *
+            d'')⟯⟮jqNModC K M⟯
+              * dedekindPsi (a * d'') = (p + 1) * dedekindPsi (a * d'') := by
+            rw [hstep_deg, hψM]
+            ring
+          exact Nat.eq_of_mul_eq_mul_right (dedekindPsi_pos hM'0) h1
+        have hdeg₁ : (minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).natDegree = p + 1 :=
+          by
+          rw [← IntermediateField.adjoin.finrank hα₁]
+          exact he
+        have hΦdeg : (phiAtSeed dp (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯
+            (jqNModC K (a * d'')))).natDegree = p + 1 := by
+          rw [phiAtSeed_natDegree]
+          exact dedekindPsi_prime p hpp
+        have hmineq : minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)
+            = phiAtSeed dp (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K (a * d''))) :=
+          Polynomial.eq_of_monic_of_dvd_of_natDegree_le (minpoly.monic hα₁)
+            (phiAtSeed_monic dp _) hmindvd (le_of_eq (hΦdeg.trans hdeg₁.symm)) |>.symm
+        have hroot_step : ((minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).map
+            ψ₁).IsRoot (sv K ζ a b) := by
+          rw [hmineq, phiAtSeed_map, show ψ₁
+            (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K (a * d'')))
+            = qExpand K p (sv K (ζ ^ p) a (b % d'')) from hψ₁]
+          rw [hΦfact, Polynomial.IsRoot, Polynomial.eval_mul]
+          refine mul_eq_zero.mpr (Or.inr ?_)
+          rw [Polynomial.eval_prod]
+          refine Finset.prod_eq_zero (Finset.mem_range.mpr hc₀p) ?_
+          rw [htarget, Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, sub_self]
+        have htowdvd : minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)
+            ∣ (minpoly K⟮jqModC K⟯ (jqNModC K M)).map (algebraMap K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K
+              (a * d'')⟯) :=
+          minpoly.dvd_map_of_isScalarTower K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K
+            M)
+        have h1 := Polynomial.map_dvd ψ₁ htowdvd
+        rw [Polynomial.map_map] at h1
+        have h2 : ψ₁.comp (algebraMap K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)
+            = (qExpand K M).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K)) := hψcomp
+        rw [h2] at h1
+        exact Polynomial.eval_eq_zero_of_dvd_of_eval_eq_zero h1 hroot_step
+  by_cases hM1 : M = 1
+  · subst hM1
+    have hjq1 : jqNModC K 1 = algebraMap K⟮jqModC K⟯ (LaurentSeries K) jGenC := by
+      rw [jqNModC_one]
+      rfl
+    have hmin : minpoly K⟮jqModC K⟯ (jqNModC K 1) = Polynomial.X - Polynomial.C jGenC := by
+      rw [hjq1]
+      exact minpoly.eq_X_sub_C (B := LaurentSeries K) jGenC
+    have hfil : (Finset.range (1 / 1)).filter
+        (fun b => Nat.gcd (Nat.gcd 1 b) (1 / 1) = 1) = {0} := by decide
+    rw [hmin, Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C, Nat.divisors_one,
+      Finset.prod_singleton, hfil, Finset.prod_singleton]
+    congr 1
+    have h1 : ((qExpand K 1).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K))) jGenC = jqModC K := by
+      simp only [RingHom.comp_apply]
+      rw [show (algebraMap K⟮jqModC K⟯ (LaurentSeries K)) jGenC = jqModC K from rfl,
+        qExpand_one_apply]
+    rw [h1]
+    have : NeZero (1 : ℕ) := ⟨one_ne_zero⟩
+    have h2 : sv K ζ 1 0 = jqModC K := by
+      rw [sv_eq_TS]
+      have h3 : TS K (1 * 1) (ζ ^ (0 * 1)) = TS K 1 1 :=
+        TS_congr' (Nat.mul_one 1) (by rw [Nat.zero_mul, pow_zero])
+      rw [h3, TS, qTwist_one_apply, qExpand_one_apply]
+    rw [h2]
+  · obtain ⟨htM, -⟩ := hall M dvd_rfl
+    have hfd : FiniteDimensional K⟮jqModC K⟯
+        (IntermediateField.adjoin K⟮jqModC K⟯ ({jqNModC K M} : Set (LaurentSeries K))) :=
+      FiniteDimensional.of_finrank_pos (htM ▸ dedekindPsi_pos hM0)
+    have hα : IsIntegral K⟮jqModC K⟯ (jqNModC K M) :=
+      IntermediateField.isIntegral_iff.mp (IsIntegral.of_finite K⟮jqModC K⟯
+        (⟨jqNModC K M, IntermediateField.subset_adjoin K⟮jqModC K⟯ _ rfl⟩ :
+          IntermediateField.adjoin K⟮jqModC K⟯ ({jqNModC K M} : Set (LaurentSeries K))))
+    have hdeg : (minpoly K⟮jqModC K⟯ (jqNModC K M)).natDegree = dedekindPsi M := by
+      rw [← IntermediateField.adjoin.finrank hα]
+      exact htM
+    set T : Multiset (LaurentSeries K) := M.divisors.val.bind
+      (fun a => ((Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map (fun b => sv K ζ a b)) with hT
+    have hTcard : Multiset.card T = dedekindPsi M := by
+      rw [hT, Multiset.card_bind]
+      have h2 : M.divisors.val.map (Multiset.card ∘ fun a => (((Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map (fun b => sv K ζ a b)))
+          = M.divisors.val.map (fun a => slotAt M (M / a)) := by
+        refine Multiset.map_congr rfl ?_
+        intro a ha
+        change Multiset.card (((Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map (fun b => sv K ζ a b))
+          = slotAt M (M / a)
+        rw [Multiset.card_map]
+        change ((Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).card = slotAt M (M / a)
+        unfold slotAt
+        rw [Nat.div_div_self (Nat.mem_divisors.mp (Finset.mem_val.mp ha)).1 hM0]
+      rw [h2]
+      change (∑ a ∈ M.divisors, slotAt M (M / a)) = dedekindPsi M
+      rw [Nat.sum_div_divisors M (slotAt M)]
+      exact slots_eq_dedekindPsi M hM0
+    have hmem_unpack : ∀ x ∈ T, ∃ a b : ℕ, a ∈ M.divisors ∧
+        b ∈ (Finset.range (M / a)).filter (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1) ∧
+        x = sv K ζ a b := by
+      intro x hx
+      rw [hT, Multiset.mem_bind] at hx
+      obtain ⟨a, ha, hx2⟩ := hx
+      rw [Multiset.mem_map] at hx2
+      obtain ⟨b, hb, rfl⟩ := hx2
+      exact ⟨a, b, ha, hb, rfl⟩
+    have hTnodup : T.Nodup := by
+      rw [hT]
+      rw [Multiset.nodup_bind]
+      constructor
+      · intro a ha
+        refine Multiset.Nodup.map_on ?_ (Finset.filter _ _).nodup
+        intro b hb b' hb' hvv
+        have ha0 : a ≠ 0 := by
+          rintro rfl
+          exact hM0 (Nat.eq_zero_of_zero_dvd (Nat.mem_divisors.mp (by exact ha)).1)
+        have hbr := Finset.mem_range.mp (Finset.mem_filter.mp (by exact hb)).1
+        have hbr' := Finset.mem_range.mp (Finset.mem_filter.mp (by exact hb')).1
+        have haM := (Nat.mem_divisors.mp (by exact ha)).1
+        have had : M / a * a = M := Nat.div_mul_cancel haM
+        have hba : b * a < M := by
+          calc b * a < M / a * a :=
+              (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr
+            _ = M := had
+        have hba' : b' * a < M := by
+          calc b' * a < M / a * a :=
+              (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr'
+            _ = M := had
+        exact (sv_inj hζ ha0 ha0 hba hba' hvv).2
+      · refine Multiset.Nodup.pairwise ?_ M.divisors.nodup
+        intro a ha a' ha' hne
+        change Disjoint (((Finset.range (M / a)).filter
+            (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map (fun b => sv K ζ a b))
+          (((Finset.range (M / a')).filter
+            (fun b => Nat.gcd (Nat.gcd a' b) (M / a') = 1)).val.map (fun b => sv K ζ a' b))
+        rw [Multiset.disjoint_left]
+        intro x hx hx'
+        rw [Multiset.mem_map] at hx hx'
+        obtain ⟨b, hb, hxb⟩ := hx
+        obtain ⟨b', hb', hxb'⟩ := hx'
+        have haM := (Nat.mem_divisors.mp (Finset.mem_val.mp ha)).1
+        have haM' := (Nat.mem_divisors.mp (Finset.mem_val.mp ha')).1
+        have ha0 : a ≠ 0 := by
+          rintro rfl
+          exact hM0 (Nat.eq_zero_of_zero_dvd haM)
+        have ha0' : a' ≠ 0 := by
+          rintro rfl
+          exact hM0 (Nat.eq_zero_of_zero_dvd haM')
+        have hbr := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb)).1
+        have hbr' := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb')).1
+        have hba : b * a < M := by
+          calc b * a < M / a * a :=
+              (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr
+            _ = M := Nat.div_mul_cancel haM
+        have hba' : b' * a' < M := by
+          calc b' * a' < M / a' * a' :=
+              (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0')).mpr hbr'
+            _ = M := Nat.div_mul_cancel haM'
+        have hvv : sv K ζ a b = sv K ζ a' b' := by rw [hxb, ← hxb']
+        exact hne (sv_inj hζ ha0 ha0' hba hba' hvv).1
+    have hPne : (minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K M).comp (algebraMap K⟮jqModC K⟯
+      (LaurentSeries K))) ≠ 0 :=
+      ((minpoly.monic hα).map _).ne_zero
+    have hPdeg : ((minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K M).comp (algebraMap K⟮jqModC
+      K⟯ (LaurentSeries K)))).natDegree = dedekindPsi M :=
+      by
+      rw [Polynomial.Monic.natDegree_map (minpoly.monic hα)]
+      exact hdeg
+    have hTle : T ≤ ((minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K M).comp (algebraMap
+      K⟮jqModC K⟯ (LaurentSeries K)))).roots :=
+      by
+      rw [Multiset.le_iff_count]
+      intro x
+      by_cases hx : x ∈ T
+      · have h1 : Multiset.count x T ≤ 1 := Multiset.nodup_iff_count_le_one.mp hTnodup x
+        have h2 : 1 ≤ Multiset.count x (((minpoly K⟮jqModC K⟯ (jqNModC K M)).map
+            ((qExpand K M).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))).roots) := by
+          rw [Multiset.one_le_count_iff_mem, Polynomial.mem_roots']
+          obtain ⟨a, b, ha, hb, rfl⟩ := hmem_unpack x hx
+          exact ⟨hPne, hslot_root a b ha hb⟩
+        omega
+      · rw [Multiset.count_eq_zero.mpr hx]
+        exact Nat.zero_le _
+    have hroots_eq : ((minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K M).comp (algebraMap
+      K⟮jqModC K⟯ (LaurentSeries K)))).roots = T :=
+      by
+      refine (Multiset.eq_of_le_of_card_le hTle ?_).symm
+      rw [hTcard]
+      calc Multiset.card (((minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K M).comp (algebraMap
+        K⟮jqModC K⟯ (LaurentSeries K)))).roots)
+          ≤ ((minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K M).comp (algebraMap K⟮jqModC K⟯
+            (LaurentSeries K)))).natDegree := Polynomial.card_roots' _
+        _ = dedekindPsi M := hPdeg
+    have hsp : Polynomial.Splits ((minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K M).comp
+      (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))) :=
+      by
+      rw [Polynomial.splits_iff_card_roots, hroots_eq, hTcard, hPdeg]
+    have hfact := hsp.eq_prod_roots_of_monic ((minpoly.monic hα).map _)
+    rw [hfact, hroots_eq, hT, Multiset.map_bind, Multiset.prod_bind]
+    change (M.divisors.val.map fun a => ((((Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+        (fun b => sv K ζ a b)).map (fun r => Polynomial.X - Polynomial.C r)).prod).prod
+      = ∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+          (Polynomial.X - Polynomial.C (sv K ζ a b))
+    simp only [Multiset.map_map, Function.comp]
+    rfl
+
+end RValCore
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData jqd_mem_full \
+  coeffMap coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one map_jqModC modularFunctionFieldC \
+  coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime"
+
+section NonMem0
+
+open IntermediateField
+
+variable {K : Type*} [Field K]
+
+
+private theorem jqNModC_prime_not_mem_adjoin (M : ℕ) [NeZero M] (p : ℕ)
+    [hp : Fact (Nat.Prime p)] (hpM : ¬ p ∣ M) (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot ((ζ : Kˣ) : K) (M * p))
+    (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank K⟮jqModC K⟯
+          (IntermediateField.adjoin K⟮jqModC K⟯
+            ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d
+        ∧ modularFunctionFieldC K d = IntermediateField.adjoin K
+            {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ d ∧ x = jqNModC K d'})
+    (hbase : jqNModC K p ∉ K⟮jqModC K⟯) :
+    jqNModC K p ∉ IntermediateField.adjoin K⟮jqModC K⟯
+      ({jqNModC K M} : Set (LaurentSeries K)) := by
+  classical
+  intro hmem
+  have hM0 : M ≠ 0 := NeZero.ne M
+  have hp0 : p ≠ 0 := hp.out.ne_zero
+  have : NeZero p := ⟨hp0⟩
+  have : NeZero (M * p) := ⟨Nat.mul_ne_zero hM0 hp0⟩
+  have hζM : IsPrimitiveRoot ((ζ ^ p : Kˣ) : K) M := by
+    have h1 := isPrimitiveRoot_pow_div hζ (⟨p, rfl⟩ : M ∣ M * p)
+    have h2 : M * p / M = p := Nat.mul_div_cancel_left p (Nat.pos_of_ne_zero hM0)
+    rwa [h2] at h1
+  have hζp : IsPrimitiveRoot ((ζ ^ M : Kˣ) : K) p := by
+    have h1 := isPrimitiveRoot_pow_div hζ (⟨M, Nat.mul_comm M p⟩ : p ∣ M * p)
+    have h2 : M * p / p = M := Nat.mul_div_cancel M (Nat.pos_of_ne_zero hp0)
+    rwa [h2] at h1
+  obtain ⟨htM, -⟩ := hall M dvd_rfl
+  have hfd : FiniteDimensional K⟮jqModC K⟯
+      (IntermediateField.adjoin K⟮jqModC K⟯ ({jqNModC K M} : Set (LaurentSeries K))) :=
+    FiniteDimensional.of_finrank_pos (htM ▸ dedekindPsi_pos hM0)
+  have hα : IsIntegral K⟮jqModC K⟯ (jqNModC K M) :=
+    IntermediateField.isIntegral_iff.mp (IsIntegral.of_finite K⟮jqModC K⟯
+      (⟨jqNModC K M, IntermediateField.subset_adjoin K⟮jqModC K⟯ _ rfl⟩ :
+        IntermediateField.adjoin K⟮jqModC K⟯ ({jqNModC K M} : Set (LaurentSeries K))))
+  have hdeg : (minpoly K⟮jqModC K⟯ (jqNModC K M)).natDegree = dedekindPsi M := by
+    rw [← IntermediateField.adjoin.finrank hα]
+    exact htM
+  have hidMB := map_qExpand_minpoly_eq p (Nat.mul_comm M p) (ζ ^ p)
+    (rval_aux M (ζ ^ p) hζM hall)
+  have hιS : ∀ w : LaurentSeries K, qExpand K (M * p) w = qExpand K p (qExpand K M w) := by
+    intro w
+    rw [qExpand_qExpand]
+    exact qExpand_congr (Nat.mul_comm M p) w
+  set T' : Multiset (LaurentSeries K) := M.divisors.val.bind
+    (fun a => ((Finset.range (M / a)).filter
+      (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+      (fun b => qExpand K p (sv K (ζ ^ p) a b))) with hT'
+  have hT'card : Multiset.card T' = dedekindPsi M := by
+    rw [hT', Multiset.card_bind]
+    have h2 : M.divisors.val.map (Multiset.card ∘ fun a => (((Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+        (fun b => qExpand K p (sv K (ζ ^ p) a b))))
+        = M.divisors.val.map (fun a => slotAt M (M / a)) := by
+      refine Multiset.map_congr rfl ?_
+      intro a ha
+      change Multiset.card (((Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+        (fun b => qExpand K p (sv K (ζ ^ p) a b)))
+        = slotAt M (M / a)
+      rw [Multiset.card_map]
+      change ((Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).card = slotAt M (M / a)
+      unfold slotAt
+      rw [Nat.div_div_self (Nat.mem_divisors.mp (Finset.mem_val.mp ha)).1 hM0]
+    rw [h2]
+    change (∑ a ∈ M.divisors, slotAt M (M / a)) = dedekindPsi M
+    rw [Nat.sum_div_divisors M (slotAt M)]
+    exact slots_eq_dedekindPsi M hM0
+  have hT'nodup : T'.Nodup := by
+    rw [hT', Multiset.nodup_bind]
+    constructor
+    · intro a ha
+      refine Multiset.Nodup.map_on ?_ (Finset.filter _ _).nodup
+      intro b hb b' hb' hvv
+      have haM := (Nat.mem_divisors.mp (Finset.mem_val.mp ha)).1
+      have ha0 : a ≠ 0 := by
+        rintro rfl
+        exact hM0 (Nat.eq_zero_of_zero_dvd haM)
+      have hbr := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb)).1
+      have hbr' := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb')).1
+      have hba : b * a < M := by
+        calc b * a < M / a * a :=
+            (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr
+          _ = M := Nat.div_mul_cancel haM
+      have hba' : b' * a < M := by
+        calc b' * a < M / a * a :=
+            (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr'
+          _ = M := Nat.div_mul_cancel haM
+      have hsv : sv K (ζ ^ p) a b
+          = sv K (ζ ^ p) a b' :=
+        RingHom.injective (qExpand K p) hvv
+      exact (sv_inj hζM ha0 ha0 hba hba' hsv).2
+    · refine Multiset.Nodup.pairwise ?_ M.divisors.nodup
+      intro a ha a' ha' hne
+      change Disjoint (((Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+          (fun b => qExpand K p (sv K (ζ ^ p) a b)))
+        (((Finset.range (M / a')).filter
+          (fun b => Nat.gcd (Nat.gcd a' b) (M / a') = 1)).val.map
+          (fun b => qExpand K p (sv K (ζ ^ p) a' b)))
+      rw [Multiset.disjoint_left]
+      intro x hx hx'
+      rw [Multiset.mem_map] at hx hx'
+      obtain ⟨b, hb, hxb⟩ := hx
+      obtain ⟨b', hb', hxb'⟩ := hx'
+      have haM := (Nat.mem_divisors.mp (Finset.mem_val.mp ha)).1
+      have haM' := (Nat.mem_divisors.mp (Finset.mem_val.mp ha')).1
+      have ha0 : a ≠ 0 := by
+        rintro rfl
+        exact hM0 (Nat.eq_zero_of_zero_dvd haM)
+      have ha0' : a' ≠ 0 := by
+        rintro rfl
+        exact hM0 (Nat.eq_zero_of_zero_dvd haM')
+      have hbr := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb)).1
+      have hbr' := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb')).1
+      have hba : b * a < M := by
+        calc b * a < M / a * a :=
+            (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr
+          _ = M := Nat.div_mul_cancel haM
+      have hba' : b' * a' < M := by
+        calc b' * a' < M / a' * a' :=
+            (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0')).mpr hbr'
+          _ = M := Nat.div_mul_cancel haM'
+      have hvv : qExpand K p (sv K (ζ ^ p) a b)
+          = qExpand K p (sv K (ζ ^ p) a' b') := by
+        rw [hxb, ← hxb']
+      exact hne (sv_inj hζM ha0 ha0' hba hba'
+        (RingHom.injective (qExpand K p) hvv)).1
+  have hglue : ∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+      (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+      (Polynomial.X - Polynomial.C (qExpand K p (sv K (ζ ^ p) a b)))
+      = (T'.map (fun r => Polynomial.X - Polynomial.C r)).prod := by
+    rw [hT', Multiset.map_bind, Multiset.prod_bind]
+    change (∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+        (Polynomial.X - Polynomial.C (qExpand K p
+          (sv K (ζ ^ p) a b))))
+      = (M.divisors.val.map fun a => ((((Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+          (fun b => qExpand K p (sv K (ζ ^ p) a b))).map
+          (fun r => Polynomial.X - Polynomial.C r)).prod).prod
+    simp only [Multiset.map_map, Function.comp]
+    rfl
+  have hroots : ((minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K (M * p)).comp (algebraMap
+    K⟮jqModC K⟯ (LaurentSeries K)))).roots = T' :=
+    by
+    rw [hidMB, hglue]
+    exact Polynomial.roots_multiset_prod_X_sub_C T'
+  set s : Finset (LaurentSeries K) := T'.toFinset with hs
+  have hscard : s.card = dedekindPsi M := by
+    rw [hs, Multiset.toFinset_card_of_nodup hT'nodup]
+    exact hT'card
+  obtain ⟨g, hg⟩ : ∃ g : Polynomial K⟮jqModC K⟯, Polynomial.aeval (jqNModC K M) g = jqNModC K p :=
+    by
+    have h1 := IntermediateField.adjoin_simple_toSubalgebra_of_isAlgebraic
+      hα.isAlgebraic
+    have h2 : jqNModC K p ∈ Algebra.adjoin K⟮jqModC K⟯ ({jqNModC K M} : Set (LaurentSeries K)) := by
+      rw [← h1]
+      exact hmem
+    rw [Algebra.adjoin_singleton_eq_range_aeval] at h2
+    obtain ⟨g, hg⟩ := h2
+    exact ⟨g, hg⟩
+  set g' := g %ₘ (minpoly K⟮jqModC K⟯ (jqNModC K M)) with hg'def
+  have hg' : Polynomial.aeval (jqNModC K M) g' = jqNModC K p := by
+    have hsplit := Polynomial.modByMonic_add_div g (minpoly K⟮jqModC K⟯ (jqNModC K M))
+    have h4 := congrArg (Polynomial.aeval (jqNModC K M)) hsplit
+    rw [map_add, map_mul, minpoly.aeval, zero_mul, add_zero] at h4
+    rw [hg'def, h4]
+    exact hg
+  have hdegpos : 0 < (minpoly K⟮jqModC K⟯ (jqNModC K M)).natDegree := by
+    rw [hdeg]
+    exact dedekindPsi_pos hM0
+  have hg'deg : g'.natDegree < s.card := by
+    rw [hscard, ← hdeg]
+    rcases eq_or_ne g' 0 with h0 | h0
+    · rw [h0, Polynomial.natDegree_zero]
+      exact hdegpos
+    · exact Polynomial.natDegree_lt_natDegree h0
+        (Polynomial.degree_modByMonic_lt g (minpoly.monic hα))
+  have hPne : (minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K (M * p)).comp
+      (algebraMap K⟮jqModC K⟯ (LaurentSeries K))) ≠ 0 :=
+    ((minpoly.monic hα).map _).ne_zero
+  have hval : ∀ y ∈ s, (g'.map ((qExpand K (M * p)).comp
+      (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))).eval y
+      = qExpand K (M * p) (jqNModC K p) := by
+    intro y hy
+    have hyT' : y ∈ T' := Multiset.mem_toFinset.mp hy
+    obtain ⟨a₀, ha₀, hy2⟩ := Multiset.mem_bind.mp hyT'
+    obtain ⟨b₀, hb₀, hyval⟩ := Multiset.mem_map.mp hy2
+    have hyS : y ∈ (qExpand K p).fieldRange := by
+      rw [← hyval]
+      exact RingHom.mem_fieldRange.mpr ⟨sv K (ζ ^ p) a₀ b₀, rfl⟩
+    have hy_root : ((minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K (M * p)).comp
+        (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))).IsRoot y :=
+      (Polynomial.mem_roots hPne).mp (by rw [hroots]; exact hyT')
+    obtain ⟨ψy, hψycomp, hψygen⟩ := exists_ringHom_adjoin_of_isRoot hα
+      ((qExpand K (M * p)).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K))) hy_root
+    have hψgen : ∀ h : jqNModC K M ∈ IntermediateField.adjoin K⟮jqModC K⟯
+        ({jqNModC K M} : Set (LaurentSeries K)), ψy ⟨jqNModC K M, h⟩ = y := by
+      intro h
+      exact hψygen
+    have himg : ∀ (x : LaurentSeries K)
+        (hx : x ∈ IntermediateField.adjoin K⟮jqModC K⟯ ({jqNModC K M} : Set (LaurentSeries K))),
+        ψy ⟨x, hx⟩ ∈ (qExpand K p).fieldRange := by
+      intro x hx
+      induction hx using IntermediateField.adjoin_induction with
+      | mem z hz =>
+          rw [Set.mem_singleton_iff] at hz
+          subst hz
+          rw [hψgen]
+          exact hyS
+      | algebraMap z =>
+          change ψy (algebraMap K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K M⟯ z) ∈ (qExpand K p).fieldRange
+          have h1 : ψy (algebraMap K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K M⟯ z)
+              = qExpand K (M * p) ((algebraMap K⟮jqModC K⟯ (LaurentSeries K)) z) := by
+            rw [← RingHom.comp_apply, hψycomp, RingHom.comp_apply]
+          rw [h1, hιS]
+          exact RingHom.mem_fieldRange.mpr ⟨_, rfl⟩
+      | add x₁ x₂ hx₁ hx₂ ih₁ ih₂ =>
+          change ψy ⟨x₁ + x₂, add_mem hx₁ hx₂⟩ ∈ (qExpand K p).fieldRange
+          rw [show (⟨x₁ + x₂, add_mem hx₁ hx₂⟩ : K⟮jqModC K⟯⟮jqNModC K M⟯)
+            = ⟨x₁, hx₁⟩ + ⟨x₂, hx₂⟩ from rfl, map_add]
+          exact Subfield.add_mem _ ih₁ ih₂
+      | mul x₁ x₂ hx₁ hx₂ ih₁ ih₂ =>
+          change ψy ⟨x₁ * x₂, mul_mem hx₁ hx₂⟩ ∈ (qExpand K p).fieldRange
+          rw [show (⟨x₁ * x₂, mul_mem hx₁ hx₂⟩ : K⟮jqModC K⟯⟮jqNModC K M⟯)
+            = ⟨x₁, hx₁⟩ * ⟨x₂, hx₂⟩ from rfl, map_mul]
+          exact Subfield.mul_mem _ ih₁ ih₂
+      | inv x₁ hx₁ ih₁ =>
+          change ψy ⟨x₁⁻¹, inv_mem hx₁⟩ ∈ (qExpand K p).fieldRange
+          rw [show (⟨x₁⁻¹, inv_mem hx₁⟩ : K⟮jqModC K⟯⟮jqNModC K M⟯)
+            = (⟨x₁, hx₁⟩ : K⟮jqModC K⟯⟮jqNModC K M⟯)⁻¹ from rfl, map_inv₀]
+          exact Subfield.inv_mem _ ih₁
+    have hx_pS : ψy ⟨jqNModC K p, hmem⟩ ∈ (qExpand K p).fieldRange := himg _ hmem
+    obtain ⟨dp, -, -⟩ := ModularCurve.exists_phiIrreducible_evalSymm p
+    have hrel : (phiAtSeed dp (jqModC K)).eval (jqNModC K p) = 0 := by
+      have h1 := phiAtSeed_jqNModC_eval (R := K) p dp 1
+      rwa [jqNModC_one, show jqNModC K (1 * p) = jqNModC K p from jqNModC_congr (one_mul p)] at h1
+    have h1 : Polynomial.aeval (⟨jqNModC K p, hmem⟩ : K⟮jqModC K⟯⟮jqNModC K M⟯)
+        (phiAtSeed dp (jGenC (K := K))) = 0 := by
+      refine aeval_intermediateField_eq_zero ?_
+      change Polynomial.aeval (jqNModC K p) (phiAtSeed dp (jGenC (K := K))) = 0
+      rw [Polynomial.aeval_def, Polynomial.eval₂_eq_eval_map, phiAtSeed_map]
+      exact hrel
+    have hseedC : ((qExpand K (M * p)).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K))) jGenC
+        = qExpand K (p * M) (qTwist ((1 : Kˣ) ^ p) (jqModC K)) := by
+      rw [RingHom.comp_apply,
+        show (algebraMap K⟮jqModC K⟯ (LaurentSeries K)) jGenC = jqModC K from rfl,
+        one_pow, qTwist_one_apply]
+      exact qExpand_congr (Nat.mul_comm M p) _
+    have h2 : (phiAtSeed dp (qExpand K (p * M) (qTwist ((1 : Kˣ) ^ p) (jqModC K)))).eval
+        (ψy ⟨jqNModC K p, hmem⟩) = 0 := by
+      have h3 := ringHom_comp_aeval ψy ((qExpand K (M * p)).comp
+        (algebraMap K⟮jqModC K⟯ (LaurentSeries K))) hψycomp (phiAtSeed dp jGenC)
+        (⟨jqNModC K p, hmem⟩ : K⟮jqModC K⟯⟮jqNModC K M⟯)
+      rw [h1, map_zero, phiAtSeed_map, hseedC] at h3
+      exact h3.symm
+    have h2' : (dp.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * M) (qTwist ((1 : Kˣ) ^ p) (jqModC K))))).IsRoot
+        (ψy ⟨jqNModC K p, hmem⟩) := h2
+    rcases (isRoot_prime_at_slot_iff p (ζ ^ M) hζp dp M 1 (ψy ⟨jqNModC K p, hmem⟩)).mp h2'
+      with hdist | ⟨b, hb, htw⟩
+    · have hspd : qExpand K (p * (p * M)) (qTwist ((1 : Kˣ) ^ (p * p)) (jqModC K))
+          = qExpand K (M * p) (jqNModC K p) := by
+        rw [one_pow, qTwist_one_apply, qExpand_jqNModC, qExpand_jqModC_eq_TS]
+        exact TS_congr (by ring) 1
+      have hx_pval : ψy ⟨jqNModC K p, hmem⟩ = qExpand K (M * p) (jqNModC K p) := by
+        rw [hdist, hspd]
+      have hgE : Polynomial.aeval (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K M)) g'
+          = (⟨jqNModC K p, hmem⟩ : K⟮jqModC K⟯⟮jqNModC K M⟯) := by
+        have h3 := Polynomial.aeval_algHom_apply (IntermediateField.val K⟮jqModC K⟯⟮jqNModC K M⟯)
+          (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K M)) g'
+        refine Subtype.ext ?_
+        change ((Polynomial.aeval (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K M))
+          g' :
+          K⟮jqModC K⟯⟮jqNModC K M⟯) : LaurentSeries K) = jqNModC K p
+        rw [show ((Polynomial.aeval (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K M))
+          g' :
+          K⟮jqModC K⟯⟮jqNModC K M⟯) : LaurentSeries K)
+          = (IntermediateField.val K⟮jqModC K⟯⟮jqNModC K M⟯)
+            (Polynomial.aeval (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K M)) g')
+          from rfl, ← h3]
+        exact hg'
+      have h4 := ringHom_comp_aeval ψy ((qExpand K (M * p)).comp
+        (algebraMap K⟮jqModC K⟯ (LaurentSeries K))) hψycomp g'
+        (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K M))
+      rw [hgE, hψygen] at h4
+      rw [← h4]
+      exact hx_pval
+    · exfalso
+      obtain ⟨w, hw⟩ := RingHom.mem_fieldRange.mp hx_pS
+      have hw2 : qExpand K p w = TS K M ((ζ ^ M) ^ b) := by
+        rw [hw, htw, one_mul, TS]
+      have hnd : ¬ ((p : ℤ) ∣ (-(M : ℤ))) := by
+        rw [dvd_neg, Int.natCast_dvd_natCast]
+        exact hpM
+      have hz1 : (qExpand K p w).coeff (-(M : ℤ)) = 0 :=
+        qExpand_coeff_of_not_dvd (R := K) (N := p) w hnd
+      have hz2 : (TS K M ((ζ ^ M) ^ b)).coeff (-(M : ℤ))
+          = ((((ζ ^ M) ^ b)⁻¹ : Kˣ) : K) :=
+        TS_coeff_neg M _
+      rw [hw2, hz2] at hz1
+      exact Units.ne_zero _ hz1
+  obtain ⟨z, hz⟩ := mem_range_of_eval_eq_const ((qExpand K (M * p)).comp
+    (algebraMap K⟮jqModC K⟯ (LaurentSeries K))) g' (qExpand K (M * p) (jqNModC K p)) s hg'deg hval
+  have hzval : (algebraMap K⟮jqModC K⟯ (LaurentSeries K)) z = jqNModC K p := by
+    apply RingHom.injective (qExpand K (M * p))
+    rw [← RingHom.comp_apply]
+    exact hz
+  have hjpF : jqNModC K p ∈ K⟮jqModC K⟯ := by
+    rw [← hzval]
+    exact z.2
+  exact hbase hjpF
+
+end NonMem0
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData jqd_mem_full \
+  coeffMap coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one map_jqModC modularFunctionFieldC \
+  coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.minpoly_jqNModC_map_eq_prod_slots {K : Type*} [Field K]
+    (M : ℕ) [NeZero M] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) M)
+    (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+          (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries
+            K)))
+            ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d
+        ∧ modularFunctionFieldC K d = IntermediateField.adjoin K
+            {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ d ∧ x = jqNModC K d'}) :
+    (minpoly (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) (jqNModC K M)).map
+        ((qExpand K M).comp
+          (algebraMap (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+            (LaurentSeries K)))
+      = ∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+          (Polynomial.X - Polynomial.C (if h : a = 0 then 0 else
+            letI : NeZero a := ⟨h⟩
+            qExpand K (a * a) (qTwist (ζ ^ (b * a)) (jqModC K)))) :=
+  ModularCurve.W1.rval_aux M ζ hζ hall
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.jqNModC_prime_not_mem_fullC {K : Type*} [Field K] (M : ℕ) [NeZero M]
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpM : ¬ p ∣ M) (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) (M * p))
+    (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+          (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries
+            K)))
+            ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d
+        ∧ modularFunctionFieldC K d = IntermediateField.adjoin K
+            {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ d ∧ x = jqNModC K d'})
+    (hbase : jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) :
+    jqNModC K p ∉ IntermediateField.adjoin K
+      {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ M ∧ x = jqNModC K d'} := by
+  intro hmem0
+  obtain ⟨-, hgM⟩ := hall M dvd_rfl
+  have hmem : jqNModC K p ∈ IntermediateField.adjoin
+      (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      ({jqNModC K M} : Set (LaurentSeries K)) := by
+    rw [← hgM] at hmem0
+    exact ModularCurve.W1.mem_adjoin_jqNModC_of_mem_mffC hmem0
+  exact ModularCurve.W1.jqNModC_prime_not_mem_adjoin M p hpM ζ hζ hall hbase hmem
+
+end
+
+p2m_open "ModularCurve~dedekindPsi_prime\
+  " in
+open _root_.P2MW.S_ModularCurve_jqNModC_prime_not_mem_fullC.ModularCurve in
+theorem solution {K : Type*} [Field K] (M : ℕ) [NeZero M]
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpM : ¬ p ∣ M) (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) (M * p))
+    (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+          (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries
+            K)))
+            ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d
+        ∧ modularFunctionFieldC K d = IntermediateField.adjoin K
+            {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ d ∧ x = jqNModC K d'})
+    (hbase : jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) :
+    jqNModC K p ∉ IntermediateField.adjoin K
+      {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ M ∧ x = jqNModC K d'} :=
+  ModularCurve.jqNModC_prime_not_mem_fullC M p hpM ζ hζ hall hbase
+
+end S_ModularCurve_jqNModC_prime_not_mem_fullC
+end P2MW
+export P2MW.S_ModularCurve_jqNModC_prime_not_mem_fullC (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.jqNModC_prime_not_mem_fullC {K : Type*} [Field K] (M : ℕ) [NeZero M]
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpM : ¬ p ∣ M) (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) (M * p))
+    (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+          (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries
+            K)))
+            ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d
+        ∧ modularFunctionFieldC K d = IntermediateField.adjoin K
+            {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ d ∧ x = jqNModC K d'})
+    (hbase : jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) :
+    jqNModC K p ∉ IntermediateField.adjoin K
+      {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ M ∧ x = jqNModC K d'} :=
+  solution M p hpM ζ hζ hall hbase
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqN_div_mem_modularFunctionField.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqN_div_mem_modularFunctionField.lean
new file mode 100644
index 0000000000..84f37d5c6c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqN_div_mem_modularFunctionField.lean
@@ -0,0 +1,779 @@
+/-
+Based on Prove2Me node ModularCurve.jqN_div_mem_modularFunctionField
+(8b07b3a0-f74d-51dc-9e2a-5e932595baa8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission dd49da64-404d-591b-af04-5d07d01fde9b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Polynomial_mem_range_of_unique_common_root
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_injective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Descent by one prime: j(q^M)∈ℚ(j(q),j(q^{Mp}))
+
+Theorem statement: `ModularCurve.jqN_div_mem_modularFunctionField`
+(`8b07b3a0-f74d-51dc-9e2a-5e932595baa8`), by Claude, 2026-09-05.
+
+Proof: submission `dd49da64-404d-591b-af04-5d07d01fde9b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a nonzero natural number $M$ and a prime $p$, and let $K$ be a field equipped with a
+$\mathbb{Q}$-algebra structure together with a unit $\zeta\in K^\times$ whose underlying element is
+a primitive $(Mp)$-th root of unity. Write $\mathrm{jq}\in\mathbb{Q}((q))$ for the Laurent series
+$q^{-1}$ times the rational $j$-numerator power series, and for $N\neq 0$ let $\mathrm{jqN}\,N$ be
+its image under the substitution $q\mapsto q^{N}$ (the ring endomorphism `qExpand` of Laurent series
+raising exponents by the factor $N$). Let $P$ be the polynomial over $K((q))$ obtained from the
+minimal polynomial of $\mathrm{jqN}\,M$ over the intermediate field
+$\mathbb{Q}(\mathrm{jq})\subseteq\mathbb{Q}((q))$ by applying to each coefficient the inclusion into
+$\mathbb{Q}((q))$, then the substitution $q\mapsto q^{Mp}$, then the coefficientwise map
+$\mathbb{Q}\to K$. Two hypotheses are imposed on the roots of $P$ in $K((q))$: first, if $y$ is a
+root and $y=\mathrm{jq}$ rescaled by $q\mapsto q^{M^{2}p}$ and twisted by a unit $w\in K^\times$
+(the twist multiplying the coefficient of $q^{k}$ by $w^{k}$), then $w=1$; second, no root of $P$
+equals the image in $K((q))$ of $\mathrm{jqN}(Mp^{2})$ rescaled by $q\mapsto q^{Mp}$. The conclusion
+is that $\mathrm{jqN}\,M$ lies in the intermediate field of $\mathbb{Q}((q))$ generated over
+$\mathbb{Q}$ by $\mathrm{jq}$ and $\mathrm{jqN}(Mp)$.
+
+This is the descent step in the purely algebraic determination of the field generated by the
+$q$-expansions of $j$ and $j_N$: passing from level $Mp$ down to level $M$, $j(q^{M})$ is recovered
+as the unique common root of the level-$p$ modular equation evaluated at $j(q^{Mp})$ and of the
+minimal polynomial of $j(q^{M})$ over $\mathbb{Q}(j)$. It feeds the generation statement
+$\mathbb{Q}(j,j_N)$ for the function field of $X_0(N)$ and the computation of
+$[\mathbb{Q}(j)(j_N):\mathbb{Q}(j)]=\psi(N)$, i.e. irreducibility of the modular polynomial $\Phi_N$
+over $\mathbb{Q}(j)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_jqN_div_mem_modularFunctionField.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_jqN_div_mem_modularFunctionField
+
+noncomputable section
+
+p2m_open "ModularCurve~coeffEmb_qExpand \
+  P2MW.S_ModularCurve_jqN_div_mem_modularFunctionField.ModularCurve ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionField adjoin_jq_le modularFunctionFieldFull jqd_mem_full \
+  modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+
+
+
+
+
+
+
+
+
+
+theorem coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb K (qExpand ℚ n x) = qExpand K n (coeffEmb K x) :=
+  coeffMap_qExpand (algebraMap ℚ K) n x
+
+theorem iota_jqN (N d : ℕ) [NeZero N] [NeZero d] :
+    coeffEmb K (qExpand ℚ N (jqN d)) = TS K (N * d) 1 := by
+  rw [jqN, coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem iota_jq (N : ℕ) [NeZero N] : coeffEmb K (qExpand ℚ N jq) = TS K N 1 := by
+  rw [coeffEmb_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_zero_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    conj p ζ (0 : Fin (p + 1)) = TS K (p * p) 1 := by
+  rw [conj_zero, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_succ_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) (b : Fin p) :
+    conj p ζ b.succ = TS K 1 (ζ ^ (b : ℕ)) := by
+  rw [conj_succ, TS_eq_coeffEmb, qExpand_one_apply]
+
+theorem qTwist_iota_of_pow_eq_one (N : ℕ) [NeZero N] (v : Kˣ) (hv : v ^ N = 1) (x : LaurentSeries ℚ)
+    :
+    qTwist v (coeffEmb K (qExpand ℚ N x)) = coeffEmb K (qExpand ℚ N x) := by
+  rw [coeffEmb_qExpand, qTwist_qExpand]
+  have : v ^ (N : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionField adjoin_jq_le modularFunctionFieldFull jqd_mem_full \
+  modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+omit [Algebra ℚ K] in
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+omit [Algebra ℚ K] in
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+omit [Algebra ℚ K] in
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem phiProd_conj_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    phiProd p (conj p ζ) = (Polynomial.X - Polynomial.C (TS K (p * p) 1)) *
+      ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) := by
+  rw [phiProd, Fin.prod_univ_succ, conj_zero_eq]
+  congr 1
+  rw [← Fin.prod_univ_eq_prod_range (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) p]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [conj_succ_eq]
+
+theorem roots_phiProd_conj (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    (phiProd p (conj p ζ)).roots = TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^
+      b)) := by
+  classical
+  rw [phiProd_conj_eq]
+  have h1 : (Polynomial.X - Polynomial.C (TS K (p * p) 1) : Polynomial (LaurentSeries K)) ≠ 0 :=
+    Polynomial.X_sub_C_ne_zero _
+  have h2 : (∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b)))) ≠ 0 :=
+    Finset.prod_ne_zero_iff.mpr fun b _ => Polynomial.X_sub_C_ne_zero _
+  rw [Polynomial.roots_mul (mul_ne_zero h1 h2), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod,
+    Finset.range_val]
+  have hm : (Multiset.map (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) (Multiset.range
+    p)) =
+      ((Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).map (fun a => Polynomial.X - Polynomial.C
+        a) := by
+    rw [Multiset.map_map]; rfl
+  rw [hm, Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+omit [Algebra ℚ K] in
+theorem roots_phiProd_conj_nodup (p : ℕ) [hp : Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).Nodup := by
+  refine Multiset.nodup_cons.mpr ⟨?_, ?_⟩
+  · intro hmem
+    obtain ⟨b, -, hb⟩ := Multiset.mem_map.mp hmem
+    have := (TS_injective hb).1
+    have h2 := hp.out.two_le
+    nlinarith
+  · refine (Multiset.nodup_range p).map_on fun b hb b' hb' hbb' => ?_
+    rw [Multiset.mem_range] at hb hb'
+    have hu := (TS_injective hbb').2
+    have hζu : IsPrimitiveRoot ζ p := IsPrimitiveRoot.coe_units_iff.mp hζ
+    exact hζu.pow_inj hb hb' hu
+
+theorem exists_isPrimitiveRoot_cyclotomicField (N : ℕ) [NeZero N] :
+    ∃ z : CyclotomicField N ℚ, IsPrimitiveRoot z N := by
+  have : NeZero ((N : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr (NeZero.ne N)⟩
+  have : IsCyclotomicExtension {N} ℚ (CyclotomicField N ℚ) :=
+    CyclotomicField.isCyclotomicExtension N ℚ
+  exact IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField N ℚ) (Set.mem_singleton N)
+    (NeZero.ne N)
+
+def cycUnit (N : ℕ) [NeZero N] : (CyclotomicField N ℚ)ˣ :=
+  ((exists_isPrimitiveRoot_cyclotomicField N).choose_spec.isUnit (NeZero.ne N)).unit
+
+theorem cycUnit_spec (N : ℕ) [NeZero N] :
+    IsPrimitiveRoot ((cycUnit N : (CyclotomicField N ℚ)ˣ) : CyclotomicField N ℚ) N := by
+  rw [cycUnit, IsUnit.unit_spec]
+  exact (exists_isPrimitiveRoot_cyclotomicField N).choose_spec
+
+theorem cycUnit_pow (N : ℕ) [NeZero N] : cycUnit N ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, (cycUnit_spec N).pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionField adjoin_jq_le modularFunctionFieldFull jqd_mem_full \
+  modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionField adjoin_jq_le modularFunctionFieldFull jqd_mem_full \
+  modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem prod_form_ne_zero (N : ℕ) (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e]
+    (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K
+            jq)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+          (Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u,
+    Polynomial.roots_mul (prod_form_ne_zero N ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p)))
+    (coeffEmb K jq))))
+        = ((Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+        (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+        (Multiset.range p).map
+          (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).Nodup := by
+  have hζp : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := isPrimitiveRoot_pow_div hζ hpN
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h := (TS_injective (K := K) (e := e) (e' := p * (p * e))
+      (u := u * ζ ^ (b * (N / p))) (u' := u ^ (p * p))
+      (by simpa only [TS_eq_coeffEmb] using heq)).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e)
+      (u := u * ζ ^ (b * (N / p))) (u' := u * ζ ^ (b' * (N / p)))
+      (by simpa only [TS_eq_coeffEmb] using heq)).2
+    have h2 : ζ ^ (b * (N / p)) = ζ ^ (b' * (N / p)) := mul_left_cancel h
+    have h3 : (ζ ^ (N / p)) ^ b = (ζ ^ (N / p)) ^ b' := by
+      rw [← pow_mul, ← pow_mul, Nat.mul_comm (N / p) b, Nat.mul_comm (N / p) b']
+      exact h2
+    have h4 : ((ζ ^ (N / p) : Kˣ) : K) ^ b = ((ζ ^ (N / p) : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h3]
+    exact hζp.pow_inj hb hb' h4
+
+theorem roots_prime_at_slot_roots_nodup (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots.Nodup := by
+  rw [roots_prime_at_slot N ζ hζ p hpN data e u]
+  exact roots_prime_at_slot_nodup N ζ hζ p hpN e u
+
+theorem isRoot_prime_at_slot_iff (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u]
+    exact prod_form_ne_zero N ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot N ζ hζ p hpN data e u,
+    Multiset.mem_cons, Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionField adjoin_jq_le modularFunctionFieldFull jqd_mem_full \
+  modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+
+
+
+
+theorem phiAtSeed_jq_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) :
+    (phiAtSeed data jq).eval (jqN n) = 0 := by
+  have h := data.eval_eq_zero
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp [evalAtJ_X]
+
+
+theorem phiAtSeed_jqN_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN M)).eval (jqN (M * n)) = 0 := by
+  have h := phiAtSeed_eval_map data jq (jqN n) (qExpand ℚ M) (phiAtSeed_jq_eval n data)
+  rwa [jqN, qExpand_qExpand] at h
+
+theorem phiAtSeed_iota_eval {K : Type*} [Field K] [Algebra ℚ K] (A : ℕ) [NeZero A] (n : ℕ)
+    [NeZero n]
+    (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (coeffEmb K (qExpand ℚ A (jqN M)))).eval (coeffEmb K (qExpand ℚ A (jqN (M *
+      n)))) = 0 :=
+  phiAtSeed_eval_map data _ _ ((coeffEmb K).comp (qExpand ℚ A)) (phiAtSeed_jqN_eval n data M)
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionField adjoin_jq_le modularFunctionFieldFull jqd_mem_full \
+  modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+private theorem jqN_mem_of_div_primes {K : Type*} [Field K] [Algebra ℚ K]
+    {N : ℕ} [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    {F : IntermediateField ℚ (LaurentSeries ℚ)}
+    {d : ℕ} [NeZero d] (hdN : d ∣ N)
+    {p q : ℕ} (pp : Nat.Prime p) (qq : Nat.Prime q) (hpq : p ≠ q)
+    (hpd : p ∣ d) (hqd : q ∣ d) [NeZero (d / p)] [NeZero (d / q)]
+    (hmp : jqN (d / p) ∈ F) (hmq : jqN (d / q) ∈ F) :
+    jqN d ∈ F := by
+  have : Fact (Nat.Prime p) := ⟨pp⟩
+  have : Fact (Nat.Prime q) := ⟨qq⟩
+  have : NeZero p := ⟨pp.ne_zero⟩
+  have : NeZero q := ⟨qq.ne_zero⟩
+  have hpN : p ∣ N := hpd.trans hdN
+  have hqN : q ∣ N := hqd.trans hdN
+  have hNp0 : N / p ≠ 0 := fun h0 => NeZero.ne N (by rw [← Nat.div_mul_cancel hpN, h0, zero_mul])
+  have hNq0 : N / q ≠ 0 := fun h0 => NeZero.ne N (by rw [← Nat.div_mul_cancel hqN, h0, zero_mul])
+  have : NeZero (N / p) := ⟨hNp0⟩
+  have : NeZero (N / q) := ⟨hNq0⟩
+  have hpe : p * (N / p * (d / p)) = N * (d / p) := by
+    rw [← mul_assoc, Nat.mul_div_cancel' hpN]
+  have hqe : q * (N / q * (d / q)) = N * (d / q) := by
+    rw [← mul_assoc, Nat.mul_div_cancel' hqN]
+  have hpe2 : p * (p * (N / p * (d / p))) = N * d := by
+    rw [hpe, mul_left_comm, Nat.mul_div_cancel' hpd]
+  have hqe2 : q * (q * (N / q * (d / q))) = N * d := by
+    rw [hqe, mul_left_comm, Nat.mul_div_cancel' hqd]
+  have data_p : ModularPolynomialData p := (ModularCurve.exists_phiIrreducible_evalSymm p).choose
+  have data_q : ModularPolynomialData q := (ModularCurve.exists_phiIrreducible_evalSymm q).choose
+  let : Algebra F (LaurentSeries K) :=
+    (((coeffEmb K).comp (qExpand ℚ N)).comp (algebraMap F (LaurentSeries ℚ))).toAlgebra
+  have hmapA : (phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)).map (algebraMap F (LaurentSeries K))
+      = phiAtSeed data_p (coeffEmb K (qExpand ℚ N (jqN (d / p)))) :=
+    phiAtSeed_map data_p _ _
+  have hmapB : (phiAtSeed data_q (⟨jqN (d / q), hmq⟩ : F)).map (algebraMap F (LaurentSeries K))
+      = phiAtSeed data_q (coeffEmb K (qExpand ℚ N (jqN (d / q)))) :=
+    phiAtSeed_map data_q _ _
+  have hseed_p : coeffEmb K (qExpand ℚ N (jqN (d / p)))
+      = qExpand K (p * (N / p * (d / p))) (qTwist ((1 : Kˣ) ^ p) (coeffEmb K jq)) := by
+    have h2 : TS K (N * (d / p)) 1 = TS K (p * (N / p * (d / p))) ((1 : Kˣ) ^ p) := by
+      rw [one_pow]
+      exact TS_congr hpe.symm 1
+    simpa only [TS_eq_coeffEmb] using (iota_jqN N (d / p)).trans h2
+  have hseed_q : coeffEmb K (qExpand ℚ N (jqN (d / q)))
+      = qExpand K (q * (N / q * (d / q))) (qTwist ((1 : Kˣ) ^ q) (coeffEmb K jq)) := by
+    have h2 : TS K (N * (d / q)) 1 = TS K (q * (N / q * (d / q))) ((1 : Kˣ) ^ q) := by
+      rw [one_pow]
+      exact TS_congr hqe.symm 1
+    simpa only [TS_eq_coeffEmb] using (iota_jqN N (d / q)).trans h2
+  have hdist_p : coeffEmb K (qExpand ℚ N (jqN d))
+      = qExpand K (p * (p * (N / p * (d / p)))) (qTwist ((1 : Kˣ) ^ (p * p)) (coeffEmb K jq)) := by
+    have h2 : TS K (N * d) 1 = TS K (p * (p * (N / p * (d / p)))) ((1 : Kˣ) ^ (p * p)) := by
+      rw [one_pow]
+      exact TS_congr hpe2.symm 1
+    simpa only [TS_eq_coeffEmb] using (iota_jqN N d).trans h2
+  have hdist_q : coeffEmb K (qExpand ℚ N (jqN d))
+      = qExpand K (q * (q * (N / q * (d / q)))) (qTwist ((1 : Kˣ) ^ (q * q)) (coeffEmb K jq)) := by
+    have h2 : TS K (N * d) 1 = TS K (q * (q * (N / q * (d / q)))) ((1 : Kˣ) ^ (q * q)) := by
+      rw [one_pow]
+      exact TS_congr hqe2.symm 1
+    simpa only [TS_eq_coeffEmb] using (iota_jqN N d).trans h2
+  have hrootA : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)) = 0 ↔
+        (y = qExpand K (p * (p * (N / p * (d / p)))) (qTwist ((1 : Kˣ) ^ (p * p)) (coeffEmb K jq)) ∨
+          ∃ b < p, y = qExpand K (N / p * (d / p)) (qTwist (1 * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+            := by
+    intro y
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hmapA, hseed_p]
+    exact isRoot_prime_at_slot_iff N ζ hζ p hpN data_p (N / p * (d / p)) 1 y
+  have hrootB : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_q (⟨jqN (d / q), hmq⟩ : F)) = 0 ↔
+        (y = qExpand K (q * (q * (N / q * (d / q)))) (qTwist ((1 : Kˣ) ^ (q * q)) (coeffEmb K jq)) ∨
+          ∃ c < q, y = qExpand K (N / q * (d / q)) (qTwist (1 * ζ ^ (c * (N / q))) (coeffEmb K jq)))
+            := by
+    intro y
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hmapB, hseed_q]
+    exact isRoot_prime_at_slot_iff N ζ hζ q hqN data_q (N / q * (d / q)) 1 y
+  have hA0 : phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F) ≠ 0 := (phiAtSeed_monic data_p _).ne_zero
+  have hAs : ((phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)).map
+      (algebraMap F (LaurentSeries K))).Splits := by
+    rw [hmapA, hseed_p, phiAtSeed,
+      ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data_p (N / p * (d / p)) 1]
+    exact (Polynomial.Splits.X_sub_C _).mul
+      (Polynomial.Splits.prod fun b _ => Polynomial.Splits.X_sub_C _)
+  have hAnd : ((phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)).map
+      (algebraMap F (LaurentSeries K))).roots.Nodup := by
+    rw [hmapA, hseed_p, phiAtSeed]
+    exact roots_prime_at_slot_roots_nodup N ζ hζ p hpN data_p (N / p * (d / p)) 1
+  have hxA : Polynomial.aeval (coeffEmb K (qExpand ℚ N (jqN d)))
+      (phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)) = 0 :=
+    (hrootA _).mpr (Or.inl hdist_p)
+  have hxB : Polynomial.aeval (coeffEmb K (qExpand ℚ N (jqN d)))
+      (phiAtSeed data_q (⟨jqN (d / q), hmq⟩ : F)) = 0 :=
+    (hrootB _).mpr (Or.inl hdist_q)
+  have huniq : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)) = 0 →
+      Polynomial.aeval y (phiAtSeed data_q (⟨jqN (d / q), hmq⟩ : F)) = 0 →
+      y = coeffEmb K (qExpand ℚ N (jqN d)) := by
+    intro y hyA hyB
+    rcases (hrootA y).mp hyA with hy1 | ⟨b, hb, hy1⟩
+    · exact hy1.trans hdist_p.symm
+    · rcases (hrootB y).mp hyB with hy2 | ⟨c, hc, hy2⟩
+      · exact hy2.trans hdist_q.symm
+      · exfalso
+        have hTS : TS K (N / p * (d / p)) (1 * ζ ^ (b * (N / p)))
+            = TS K (N / q * (d / q)) (1 * ζ ^ (c * (N / q))) := by
+              simpa only [TS_eq_coeffEmb] using hy1.symm.trans hy2
+        have he : N / p * (d / p) = N / q * (d / q) := (TS_injective hTS).1
+        have h1 : p * p * (N / p * (d / p)) = q * q * (N / p * (d / p)) := by
+          rw [mul_assoc, hpe2, mul_assoc, he, hqe2]
+        have h2 : p * p = q * q :=
+          Nat.eq_of_mul_eq_mul_right (Nat.pos_of_ne_zero (NeZero.ne (N / p * (d / p)))) h1
+        have h3 : q ∣ p * p := by rw [h2]; exact dvd_mul_right q q
+        have h4 : q ∣ p := ((Nat.Prime.dvd_mul qq).mp h3).elim id id
+        exact hpq (((Nat.prime_dvd_prime_iff_eq qq pp).mp h4).symm)
+  have hrange := Polynomial.mem_range_of_unique_common_root
+    (phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)) (phiAtSeed data_q (⟨jqN (d / q), hmq⟩ : F))
+    hA0 hAs hAnd (coeffEmb K (qExpand ℚ N (jqN d))) hxA hxB huniq
+  obtain ⟨f, hf⟩ := RingHom.mem_range.mp hrange
+  have hf' : coeffEmb K (qExpand ℚ N ((f : LaurentSeries ℚ)))
+      = coeffEmb K (qExpand ℚ N (jqN d)) := hf
+  have hemb : Function.Injective (coeffEmb K) :=
+    ModularCurve.coeffMap_injective ((algebraMap ℚ K).injective)
+  have hval : (f : LaurentSeries ℚ) = jqN d := qExpand_injective N (hemb hf')
+  rw [← hval]
+  exact f.2
+
+theorem phiAtSeed_eval_symm {n : ℕ} [NeZero n] (data : ModularPolynomialData n)
+    (hs : EvalSymm data.Φ)
+    (x y : LaurentSeries ℚ) : (phiAtSeed data x).eval y = (phiAtSeed data y).eval x := by
+  have key : ∀ z : LaurentSeries ℚ, Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries ℚ)) z =
+      (Polynomial.aeval (R := ℤ) z).toRingHom := fun z =>
+    Polynomial.ringHom_ext' (RingHom.ext_int _ _) (by simp)
+  rw [phiAtSeed, phiAtSeed, Polynomial.eval_map, Polynomial.eval_map, key, key]
+  exact hs x y
+
+theorem jqN_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) : jqN n = jqN m := by subst h; rfl
+
+theorem phiAtSeed_jqN_eval_down (q : ℕ) [NeZero q] (data : ModularPolynomialData q)
+    (hs : EvalSymm data.Φ)
+    (M : ℕ) [NeZero M] : (phiAtSeed data (jqN (M * q))).eval (jqN M) = 0 := by
+  rw [← phiAtSeed_eval_symm data hs]; exact phiAtSeed_jqN_eval q data M
+
+end ModularCurve.W1
+
+open ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionField adjoin_jq_le modularFunctionFieldFull jqd_mem_full \
+  modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  coeffMap_injective exists_phiIrreducible_evalSymm"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.jqN_div_mem_modularFunctionField (M : ℕ) [NeZero M] (p : ℕ)
+    [hp : Fact (Nat.Prime p)] {K : Type*} [Field K] [Algebra ℚ K] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) (M * p))
+    (htw : ∀ y : LaurentSeries K,
+      Polynomial.eval y ((minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+          (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M * p))).comp
+            (algebraMap (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+              (LaurentSeries ℚ)))) = 0 →
+        ∀ w : Kˣ, y = qExpand K (M * p * M) (qTwist w (coeffEmb K jq)) → w = 1)
+    (hsp : ∀ y : LaurentSeries K,
+      Polynomial.eval y ((minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+          (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M * p))).comp
+            (algebraMap (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+              (LaurentSeries ℚ)))) = 0 →
+        y ≠ coeffEmb K (qExpand ℚ (M * p) (jqN (M * p * p)))) :
+    jqN M ∈ modularFunctionField (M * p) := by
+  classical
+  obtain ⟨data, -, hsym⟩ := ModularCurve.exists_phiIrreducible_evalSymm p
+  have hpN : p ∣ M * p := dvd_mul_left p M
+  set F := modularFunctionField (M * p) with hF
+  have hjNmem : jqN (M * p) ∈ F :=
+    IntermediateField.subset_adjoin ℚ _ (Set.mem_insert_of_mem _ rfl)
+  have hle : IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)) ≤ F :=
+    ModularCurve.adjoin_jq_le (M * p)
+  let : Algebra F (LaurentSeries K) :=
+    (((coeffEmb K).comp (qExpand ℚ (M * p))).comp (algebraMap F (LaurentSeries ℚ))).toAlgebra
+  set A : Polynomial F := phiAtSeed data (⟨jqN (M * p), hjNmem⟩ : F) with hA
+  let ι₀ : (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) →+* F :=
+    { toFun := fun x => ⟨(x : LaurentSeries ℚ), hle x.2⟩
+      map_one' := rfl
+      map_mul' := fun _ _ => rfl
+      map_zero' := rfl
+      map_add' := fun _ _ => rfl }
+  set B : Polynomial F :=
+    (minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN M)).map ι₀
+    with hB
+  have hmapA : A.map (algebraMap F (LaurentSeries K))
+      = phiAtSeed data (coeffEmb K (qExpand ℚ (M * p) (jqN (M * p)))) :=
+    phiAtSeed_map data _ _
+  have hseed : coeffEmb K (qExpand ℚ (M * p) (jqN (M * p)))
+      = qExpand K (p * (M * p * M)) (qTwist ((1 : Kˣ) ^ p) (coeffEmb K jq)) := by
+    have h2 : TS K ((M * p) * (M * p)) 1 = TS K (p * (M * p * M)) ((1 : Kˣ) ^ p) := by
+      rw [one_pow]
+      exact TS_congr (by ring) 1
+    simpa only [TS_eq_coeffEmb] using (iota_jqN (M * p) (M * p)).trans h2
+  have hdist : coeffEmb K (qExpand ℚ (M * p) (jqN M))
+      = qExpand K (M * p * M) (qTwist (1 * ζ ^ (0 * (M * p / p))) (coeffEmb K jq)) := by
+    have h2 : TS K ((M * p) * M) 1 = TS K (M * p * M) (1 * ζ ^ (0 * (M * p / p))) := by
+      rw [Nat.zero_mul, pow_zero, mul_one]
+    simpa only [TS_eq_coeffEmb] using (iota_jqN (M * p) M).trans h2
+  have hspread : coeffEmb K (qExpand ℚ (M * p) (jqN (M * p * p)))
+      = qExpand K (p * (p * (M * p * M))) (qTwist ((1 : Kˣ) ^ (p * p)) (coeffEmb K jq)) := by
+    have h2 : TS K ((M * p) * (M * p * p)) 1
+        = TS K (p * (p * (M * p * M))) ((1 : Kˣ) ^ (p * p)) := by
+      rw [one_pow]
+      exact TS_congr (by ring) 1
+    simpa only [TS_eq_coeffEmb] using (iota_jqN (M * p) (M * p * p)).trans h2
+  have hrootA : ∀ y : LaurentSeries K,
+      Polynomial.aeval y A = 0 ↔
+        (y = qExpand K (p * (p * (M * p * M))) (qTwist ((1 : Kˣ) ^ (p * p)) (coeffEmb K jq)) ∨
+          ∃ b < p, y = qExpand K (M * p * M)
+            (qTwist (1 * ζ ^ (b * (M * p / p))) (coeffEmb K jq))) := by
+    intro y
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hmapA, hseed]
+    exact isRoot_prime_at_slot_iff (M * p) ζ hζ p hpN data (M * p * M) 1 y
+  have hcomp : (algebraMap F (LaurentSeries K)).comp ι₀
+      = ((coeffEmb K).comp (qExpand ℚ (M * p))).comp
+          (algebraMap (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+            (LaurentSeries ℚ)) := RingHom.ext fun x => rfl
+  have hBev : ∀ y : LaurentSeries K, Polynomial.aeval y B = 0 →
+      Polynomial.eval y ((minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+        (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M * p))).comp
+          (algebraMap (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+            (LaurentSeries ℚ)))) = 0 := by
+    intro y hy
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hB, Polynomial.map_map] at hy
+    rwa [hcomp] at hy
+  have hA0 : A ≠ 0 := (phiAtSeed_monic data _).ne_zero
+  have hAs : (A.map (algebraMap F (LaurentSeries K))).Splits := by
+    rw [hmapA, hseed, phiAtSeed,
+      ModularCurve.PhiGen.splits_prime_at_slot (M * p) ζ hζ p hpN data (M * p * M) 1]
+    exact (Polynomial.Splits.X_sub_C _).mul
+      (Polynomial.Splits.prod fun b _ => Polynomial.Splits.X_sub_C _)
+  have hAnd : (A.map (algebraMap F (LaurentSeries K))).roots.Nodup := by
+    rw [hmapA, hseed, phiAtSeed]
+    exact roots_prime_at_slot_roots_nodup (M * p) ζ hζ p hpN data (M * p * M) 1
+  set x₀ : LaurentSeries K := coeffEmb K (qExpand ℚ (M * p) (jqN M)) with hx₀
+  have hxA : Polynomial.aeval x₀ A = 0 :=
+    (hrootA x₀).mpr (Or.inr ⟨0, hp.out.pos, hdist⟩)
+  have hxB : Polynomial.aeval x₀ B = 0 := by
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hB, Polynomial.map_map, hcomp,
+      ← Polynomial.map_map, Polynomial.eval_map]
+    have hx₀ψ : x₀ = ((coeffEmb K).comp (qExpand ℚ (M * p))) (jqN M) := rfl
+    rw [hx₀ψ, Polynomial.eval₂_hom]
+    have hmp := minpoly.aeval
+      (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN M)
+    rw [Polynomial.aeval_def, Polynomial.eval₂_eq_eval_map] at hmp
+    rw [hmp, map_zero]
+  have huniq : ∀ y : LaurentSeries K,
+      Polynomial.aeval y A = 0 → Polynomial.aeval y B = 0 → y = x₀ := by
+    intro y hyA hyB
+    rcases (hrootA y).mp hyA with hy1 | ⟨b, hb, hy1⟩
+    · exact absurd (hy1.trans hspread.symm) (hsp y (hBev y hyB))
+    · have hw := htw y (hBev y hyB) (1 * ζ ^ (b * (M * p / p))) hy1
+      rw [one_mul] at hw
+      have hb0 : b = 0 := by
+        have hord : (M * p) ∣ b * M := by
+          have hval : (ζ : K) ^ (b * (M * p / p)) = 1 := by
+            have := congrArg Units.val hw
+            simpa using this
+          rw [Nat.mul_div_cancel M hp.out.pos] at hval
+          exact (hζ.pow_eq_one_iff_dvd _).mp hval
+        have hpb : p ∣ b := by
+          have h2 : M * p ∣ M * b := by rwa [Nat.mul_comm b M] at hord
+          exact (Nat.mul_dvd_mul_iff_left (Nat.pos_of_ne_zero (NeZero.ne M))).mp h2
+        exact Nat.eq_zero_of_dvd_of_lt hpb hb
+      rw [hb0] at hy1
+      exact hy1.trans hdist.symm
+  have hrange := Polynomial.mem_range_of_unique_common_root A B hA0 hAs hAnd x₀ hxA hxB huniq
+  obtain ⟨f, hf⟩ := RingHom.mem_range.mp hrange
+  have hf' : coeffEmb K (qExpand ℚ (M * p) ((f : LaurentSeries ℚ)))
+      = coeffEmb K (qExpand ℚ (M * p) (jqN M)) := hf
+  have hemb : Function.Injective (coeffEmb K) :=
+    ModularCurve.coeffMap_injective ((algebraMap ℚ K).injective)
+  have hval : (f : LaurentSeries ℚ) = jqN M := qExpand_injective (M * p) (hemb hf')
+  rw [← hval]
+  exact f.2
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.modularFunctionField_eq_full_of (N : ℕ) [NeZero N]
+    (hstep : ∀ (M : ℕ) [NeZero M] (p : ℕ), p.Prime → M * p = N →
+      jqN M ∈ modularFunctionField N)
+    (hgen' : ∀ (M : ℕ) [NeZero M] (p : ℕ), p.Prime → M * p = N →
+      modularFunctionField M = modularFunctionFieldFull M) :
+    modularFunctionField N = modularFunctionFieldFull N := by
+  refine le_antisymm (modularFunctionField_le_full N) ?_
+  rw [modularFunctionFieldFull, IntermediateField.adjoin_le_iff]
+  rintro x ⟨d, hd0, hdN, rfl⟩
+  rcases eq_or_ne d N with rfl | hdlt
+  · exact IntermediateField.subset_adjoin ℚ _ (Set.mem_insert_of_mem _ rfl)
+  · obtain ⟨m, hm⟩ := hdN
+    have hm1 : m ≠ 1 := fun h1 => hdlt (by rw [hm, h1, Nat.mul_one])
+    have hm0 : m ≠ 0 := fun h0 => NeZero.ne N (by rw [hm, h0, Nat.mul_zero])
+    have hq : m.minFac.Prime := Nat.minFac_prime hm1
+    obtain ⟨m', hm'⟩ := Nat.minFac_dvd m
+    have hm'0 : m' ≠ 0 := fun h0 => hm0 (by rw [hm', h0, Nat.mul_zero])
+    have : NeZero (d * m') := ⟨Nat.mul_ne_zero hd0.out hm'0⟩
+    have hdm' : (d * m') * m.minFac = N := by
+      rw [Nat.mul_assoc, Nat.mul_comm m' m.minFac, ← hm', ← hm]
+    have hmem : jqN (d * m') ∈ modularFunctionField N := hstep (d * m') m.minFac hq hdm'
+    have hfull : modularFunctionField (d * m') = modularFunctionFieldFull (d * m') :=
+      hgen' (d * m') m.minFac hq hdm'
+    have hsub : modularFunctionFieldFull (d * m') ≤ modularFunctionField N := by
+      rw [← hfull, modularFunctionField, IntermediateField.adjoin_le_iff]
+      rintro y (rfl | hy)
+      · exact IntermediateField.subset_adjoin ℚ _ (Set.mem_insert _ _)
+      · rw [Set.mem_singleton_iff] at hy
+        rw [hy]
+        exact hmem
+    exact hsub (jqd_mem_full (d * m') ⟨m', rfl⟩)
+
+end
+
+p2m_open "ModularCurve~coeffEmb_qExpand\
+  " in
+open _root_.P2MW.S_ModularCurve_jqN_div_mem_modularFunctionField.ModularCurve in
+theorem solution (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] {K : Type*} [Field K] [Algebra
+  ℚ K] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) (M * p)) (htw : ∀ y : LaurentSeries K, Polynomial.eval
+  y ((minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN M)).map (((coeffEmb
+  K).comp (qExpand ℚ (M * p))).comp (algebraMap (IntermediateField.adjoin ℚ ({jq} : Set
+  (LaurentSeries ℚ))) (LaurentSeries ℚ)))) = 0 → ∀ w : Kˣ, y = qExpand K (M * p * M) (qTwist w
+  (coeffEmb K jq)) → w = 1) (hsp : ∀ y : LaurentSeries K, Polynomial.eval y ((minpoly
+  (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN M)).map (((coeffEmb K).comp
+  (qExpand ℚ (M * p))).comp (algebraMap (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+  (LaurentSeries ℚ)))) = 0 → y ≠ coeffEmb K (qExpand ℚ (M * p) (jqN (M * p * p)))) :
+    jqN M ∈ modularFunctionField (M * p) :=
+  ModularCurve.jqN_div_mem_modularFunctionField M p ζ hζ htw hsp
+
+end S_ModularCurve_jqN_div_mem_modularFunctionField
+end P2MW
+export P2MW.S_ModularCurve_jqN_div_mem_modularFunctionField (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.jqN_div_mem_modularFunctionField (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact
+  (Nat.Prime p)] {K : Type*} [Field K] [Algebra ℚ K] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) (M * p))
+  (htw : ∀ y : LaurentSeries K, Polynomial.eval y ((minpoly (IntermediateField.adjoin ℚ ({jq} : Set
+  (LaurentSeries ℚ))) (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M * p))).comp (algebraMap
+  (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (LaurentSeries ℚ)))) = 0 → ∀ w : Kˣ, y
+  = qExpand K (M * p * M) (qTwist w (coeffEmb K jq)) → w = 1) (hsp : ∀ y : LaurentSeries K,
+  Polynomial.eval y ((minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN
+  M)).map (((coeffEmb K).comp (qExpand ℚ (M * p))).comp (algebraMap (IntermediateField.adjoin ℚ
+  ({jq} : Set (LaurentSeries ℚ))) (LaurentSeries ℚ)))) = 0 → y ≠ coeffEmb K (qExpand ℚ (M * p) (jqN
+  (M * p * p)))) :
+    jqN M ∈ modularFunctionField (M * p) :=
+  solution M p ζ hζ htw hsp
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqN_pow_not_mem_adjoin_full.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqN_pow_not_mem_adjoin_full.lean
new file mode 100644
index 0000000000..ac55cae801
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqN_pow_not_mem_adjoin_full.lean
@@ -0,0 +1,1017 @@
+/-
+Based on Prove2Me node ModularCurve.jqN_pow_not_mem_adjoin_full
+(ef9faf66-c902-54ed-92ed-f40c11e0e7e6) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c70fed80-362b-55ab-95f4-1333ed4d6051
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.FieldTheory.Minpoly.Field
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+import Mathlib.Algebra.Polynomial.Splits
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Non-membership of j(q^pᵃ⁺²) over prime-power levels
+
+Theorem statement: `ModularCurve.jqN_pow_not_mem_adjoin_full`
+(`ef9faf66-c902-54ed-92ed-f40c11e0e7e6`), by Claude, 2026-09-05.
+
+Proof: submission `c70fed80-362b-55ab-95f4-1333ed4d6051`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a nonzero natural number, $p$ a prime and $a$ a natural number. Write $j(q^{N})$ for `jqN
+N`, the Laurent series over $\mathbb{Q}$ obtained from the $q$-expansion `jq` of the modular
+invariant by the exponent-scaling ring homomorphism `qExpand ℚ N`, which transports a Laurent series
+along multiplication by $N$ on exponents. Write $F_M^{\mathrm{full}} =$ `modularFunctionFieldFull M`
+for the intermediate field of $\mathbb{Q} \subseteq \mathbb{Q}((q))$ generated over $\mathbb{Q}$ by
+the set of all $j(q^{d})$ with $d$ a nonzero divisor of $M$. Assume that $j(q^{p})$ does not lie in
+$F_M^{\mathrm{full}}$. The conclusion is that $j(q^{p^{a+2}})$ does not lie in the intermediate
+field generated over $\mathbb{Q}$ by the union of the underlying set of $F_M^{\mathrm{full}}$ with
+the set of those Laurent series of the form $j(q^{p^{i}})$ for some $i \le a+1$ (so including $i =
+0$, i.e. $j(q)$ itself).
+
+This is the inductive non-membership step in the $q$-expansion model of the function field of
+$X_0(N)$: it feeds the tower $\mathbb{Q}(j(q), j(q^{p}), \dots)$ at prime-power level and is used in
+the purely algebraic computation that $[\mathbb{Q}(j)(j_N):\mathbb{Q}(j)] = \psi(N)$. It is cited by
+[`ModularCurve.exists_phiIrreducible`](thm.html#ModularCurve.exists_phiIrreducible),
+[`ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi`]
+(thm.html#ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi)
+and [`ModularCurve.functionFieldGeneration`](thm.html#ModularCurve.functionFieldGeneration).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_jqN_pow_not_mem_adjoin_full.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_jqN_pow_not_mem_adjoin_full
+
+noncomputable section
+
+p2m_open "ModularCurve~coeffEmb_qExpand \
+  P2MW.S_ModularCurve_jqN_pow_not_mem_adjoin_full.ModularCurve ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData modularFunctionFieldFull jqd_mem_full coeffEmb coeffEmb_coeff \
+  qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+
+
+
+
+
+
+
+
+
+
+theorem coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb K (qExpand ℚ n x) = qExpand K n (coeffEmb K x) :=
+  coeffMap_qExpand (algebraMap ℚ K) n x
+
+theorem iota_jqN (N d : ℕ) [NeZero N] [NeZero d] :
+    coeffEmb K (qExpand ℚ N (jqN d)) = TS K (N * d) 1 := by
+  rw [jqN, coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem iota_jq (N : ℕ) [NeZero N] : coeffEmb K (qExpand ℚ N jq) = TS K N 1 := by
+  rw [coeffEmb_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_zero_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    conj p ζ (0 : Fin (p + 1)) = TS K (p * p) 1 := by
+  rw [conj_zero, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_succ_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) (b : Fin p) :
+    conj p ζ b.succ = TS K 1 (ζ ^ (b : ℕ)) := by
+  rw [conj_succ, TS_eq_coeffEmb, qExpand_one_apply]
+
+theorem qTwist_iota_of_pow_eq_one (N : ℕ) [NeZero N] (v : Kˣ) (hv : v ^ N = 1) (x : LaurentSeries ℚ)
+    :
+    qTwist v (coeffEmb K (qExpand ℚ N x)) = coeffEmb K (qExpand ℚ N x) := by
+  rw [coeffEmb_qExpand, qTwist_qExpand]
+  have : v ^ (N : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData modularFunctionFieldFull jqd_mem_full coeffEmb coeffEmb_coeff \
+  qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+omit [Algebra ℚ K] in
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+omit [Algebra ℚ K] in
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+omit [Algebra ℚ K] in
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem phiProd_conj_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    phiProd p (conj p ζ) = (Polynomial.X - Polynomial.C (TS K (p * p) 1)) *
+      ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) := by
+  rw [phiProd, Fin.prod_univ_succ, conj_zero_eq]
+  congr 1
+  rw [← Fin.prod_univ_eq_prod_range (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) p]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [conj_succ_eq]
+
+theorem roots_phiProd_conj (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    (phiProd p (conj p ζ)).roots = TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^
+      b)) := by
+  classical
+  rw [phiProd_conj_eq]
+  have h1 : (Polynomial.X - Polynomial.C (TS K (p * p) 1) : Polynomial (LaurentSeries K)) ≠ 0 :=
+    Polynomial.X_sub_C_ne_zero _
+  have h2 : (∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b)))) ≠ 0 :=
+    Finset.prod_ne_zero_iff.mpr fun b _ => Polynomial.X_sub_C_ne_zero _
+  rw [Polynomial.roots_mul (mul_ne_zero h1 h2), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod,
+    Finset.range_val]
+  have hm : (Multiset.map (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) (Multiset.range
+    p)) =
+      ((Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).map (fun a => Polynomial.X - Polynomial.C
+        a) := by
+    rw [Multiset.map_map]; rfl
+  rw [hm, Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+omit [Algebra ℚ K] in
+theorem roots_phiProd_conj_nodup (p : ℕ) [hp : Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).Nodup := by
+  refine Multiset.nodup_cons.mpr ⟨?_, ?_⟩
+  · intro hmem
+    obtain ⟨b, -, hb⟩ := Multiset.mem_map.mp hmem
+    have := (TS_injective hb).1
+    have h2 := hp.out.two_le
+    nlinarith
+  · refine (Multiset.nodup_range p).map_on fun b hb b' hb' hbb' => ?_
+    rw [Multiset.mem_range] at hb hb'
+    have hu := (TS_injective hbb').2
+    have hζu : IsPrimitiveRoot ζ p := IsPrimitiveRoot.coe_units_iff.mp hζ
+    exact hζu.pow_inj hb hb' hu
+
+theorem exists_isPrimitiveRoot_cyclotomicField (N : ℕ) [NeZero N] :
+    ∃ z : CyclotomicField N ℚ, IsPrimitiveRoot z N := by
+  have : NeZero ((N : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr (NeZero.ne N)⟩
+  have : IsCyclotomicExtension {N} ℚ (CyclotomicField N ℚ) :=
+    CyclotomicField.isCyclotomicExtension N ℚ
+  exact IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField N ℚ) (Set.mem_singleton N)
+    (NeZero.ne N)
+
+def cycUnit (N : ℕ) [NeZero N] : (CyclotomicField N ℚ)ˣ :=
+  ((exists_isPrimitiveRoot_cyclotomicField N).choose_spec.isUnit (NeZero.ne N)).unit
+
+theorem cycUnit_spec (N : ℕ) [NeZero N] :
+    IsPrimitiveRoot ((cycUnit N : (CyclotomicField N ℚ)ˣ) : CyclotomicField N ℚ) N := by
+  rw [cycUnit, IsUnit.unit_spec]
+  exact (exists_isPrimitiveRoot_cyclotomicField N).choose_spec
+
+theorem cycUnit_pow (N : ℕ) [NeZero N] : cycUnit N ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, (cycUnit_spec N).pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData modularFunctionFieldFull jqd_mem_full coeffEmb coeffEmb_coeff \
+  qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData modularFunctionFieldFull jqd_mem_full coeffEmb coeffEmb_coeff \
+  qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem prod_form_ne_zero (N : ℕ) (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e]
+    (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K
+            jq)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+          (Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u,
+    Polynomial.roots_mul (prod_form_ne_zero N ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p)))
+    (coeffEmb K jq))))
+        = ((Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+        (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+        (Multiset.range p).map
+          (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).Nodup := by
+  have hζp : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := isPrimitiveRoot_pow_div hζ hpN
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h := (TS_injective (K := K) (e := e) (e' := p * (p * e))
+      (u := u * ζ ^ (b * (N / p))) (u' := u ^ (p * p))
+      (by simpa only [TS_eq_coeffEmb] using heq)).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e)
+      (u := u * ζ ^ (b * (N / p))) (u' := u * ζ ^ (b' * (N / p)))
+      (by simpa only [TS_eq_coeffEmb] using heq)).2
+    have h2 : ζ ^ (b * (N / p)) = ζ ^ (b' * (N / p)) := mul_left_cancel h
+    have h3 : (ζ ^ (N / p)) ^ b = (ζ ^ (N / p)) ^ b' := by
+      rw [← pow_mul, ← pow_mul, Nat.mul_comm (N / p) b, Nat.mul_comm (N / p) b']
+      exact h2
+    have h4 : ((ζ ^ (N / p) : Kˣ) : K) ^ b = ((ζ ^ (N / p) : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h3]
+    exact hζp.pow_inj hb hb' h4
+
+theorem roots_prime_at_slot_roots_nodup (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots.Nodup := by
+  rw [roots_prime_at_slot N ζ hζ p hpN data e u]
+  exact roots_prime_at_slot_nodup N ζ hζ p hpN e u
+
+theorem isRoot_prime_at_slot_iff (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u]
+    exact prod_form_ne_zero N ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot N ζ hζ p hpN data e u,
+    Multiset.mem_cons, Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData modularFunctionFieldFull jqd_mem_full coeffEmb coeffEmb_coeff \
+  qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+
+
+
+
+theorem phiAtSeed_jq_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) :
+    (phiAtSeed data jq).eval (jqN n) = 0 := by
+  have h := data.eval_eq_zero
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp [evalAtJ_X]
+
+
+theorem phiAtSeed_jqN_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN M)).eval (jqN (M * n)) = 0 := by
+  have h := phiAtSeed_eval_map data jq (jqN n) (qExpand ℚ M) (phiAtSeed_jq_eval n data)
+  rwa [jqN, qExpand_qExpand] at h
+
+theorem phiAtSeed_iota_eval {K : Type*} [Field K] [Algebra ℚ K] (A : ℕ) [NeZero A] (n : ℕ)
+    [NeZero n]
+    (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (coeffEmb K (qExpand ℚ A (jqN M)))).eval (coeffEmb K (qExpand ℚ A (jqN (M *
+      n)))) = 0 :=
+  phiAtSeed_eval_map data _ _ ((coeffEmb K).comp (qExpand ℚ A)) (phiAtSeed_jqN_eval n data M)
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData modularFunctionFieldFull jqd_mem_full coeffEmb coeffEmb_coeff \
+  qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+theorem aeval_intermediateField_eq_zero {F₀ L : Type*} [Field F₀] [Field L] [Algebra F₀ L]
+    {E : IntermediateField F₀ L} {P : Polynomial F₀} {x : E}
+    (h : Polynomial.aeval (E.val x) P = 0) : Polynomial.aeval x P = 0 := by
+  have h1 := Polynomial.aeval_algHom_apply E.val x P
+  rw [h] at h1
+  have h2 : E.val (Polynomial.aeval x P) = E.val 0 := by rw [← h1, map_zero]
+  exact RingHom.injective (E.val : E →+* L) h2
+
+theorem phiAtSeed_eval_of_injective {R S : Type*} [CommRing R] [CommRing S] {n : ℕ} [NeZero n]
+    (data : ModularPolynomialData n) (x y : R) (f : R →+* S) (hf : Function.Injective f)
+    (h : (phiAtSeed data (f x)).eval (f y) = 0) : (phiAtSeed data x).eval y = 0 := by
+  rw [← phiAtSeed_map, Polynomial.eval_map, Polynomial.eval₂_hom] at h
+  exact (injective_iff_map_eq_zero f).mp hf _ h
+
+theorem phiAtSeed_eval_symm {n : ℕ} [NeZero n] (data : ModularPolynomialData n)
+    (hs : EvalSymm data.Φ) (x y : LaurentSeries ℚ) :
+    (phiAtSeed data x).eval y = (phiAtSeed data y).eval x := by
+  have key : ∀ z : LaurentSeries ℚ, Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries ℚ)) z
+      = (Polynomial.aeval (R := ℤ) z).toRingHom := fun z =>
+    Polynomial.ringHom_ext' (RingHom.ext_int _ _) (by simp)
+  rw [phiAtSeed, phiAtSeed, Polynomial.eval_map, Polynomial.eval_map, key, key]
+  exact hs x y
+
+theorem jqN_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) : jqN n = jqN m := by
+  subst h; rfl
+
+theorem phiAtSeed_jqN_eval_down (q : ℕ) [NeZero q] (data : ModularPolynomialData q)
+    (hs : EvalSymm data.Φ) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN (M * q))).eval (jqN M) = 0 := by
+  rw [← phiAtSeed_eval_symm data hs]; exact phiAtSeed_jqN_eval q data M
+
+theorem qExpand_qTwist_notMem_range_qExpand {r e : ℕ} [NeZero r] [NeZero e]
+    (hre : ¬ ((r : ℤ) ∣ (e : ℤ))) (w : Kˣ) :
+    qExpand K e (qTwist w (coeffEmb K jq)) ∉ (qExpand K r).range := by
+  intro hmem
+  obtain ⟨z, hz⟩ := RingHom.mem_range.mp hmem
+  have h1 : (qExpand K e (qTwist w (coeffEmb K jq))).coeff (-(e : ℤ)) = ((w⁻¹ : Kˣ) : K) := by
+    simpa only [TS_eq_coeffEmb] using TS_coeff_neg e w
+  have h2 : (qExpand K r z).coeff (-(e : ℤ)) = 0 :=
+    qExpand_coeff_of_not_dvd r z (by rwa [dvd_neg])
+  rw [hz, h1] at h2
+  exact (w⁻¹ : Kˣ).ne_zero h2
+
+private theorem nat_ne_of_mul {a b : ℕ} (ha : 0 < a) (hb : 2 ≤ b) : a * b ≠ a := by
+  intro h
+  have h2 : a * 2 ≤ a * b := Nat.mul_le_mul_left a hb
+  rw [h] at h2
+  omega
+
+omit [Algebra ℚ K] in
+private theorem mem_range_qExpand_of_mul {a b : ℕ} [NeZero a] [NeZero b] {z : LaurentSeries K}
+    (h : z ∈ (qExpand K (a * b)).range) : z ∈ (qExpand K b).range := by
+  obtain ⟨w, rfl⟩ := RingHom.mem_range.mp h
+  refine RingHom.mem_range.mpr ⟨qExpand K a w, ?_⟩
+  rw [qExpand_qExpand]
+  exact qExpand_congr (Nat.mul_comm b a) _
+
+omit [Algebra ℚ K] in
+private theorem range_qExpand_congr {A A' : ℕ} [NeZero A] [NeZero A'] (h : A = A') :
+    (qExpand K A).range = (qExpand K A').range := by
+  ext z
+  constructor
+  · rintro ⟨w, rfl⟩; exact ⟨w, (qExpand_congr h w).symm⟩
+  · rintro ⟨w, rfl⟩; exact ⟨w, qExpand_congr h w⟩
+
+private def chainField (M p : ℕ) [NeZero M] [NeZero p] (i : ℕ) :
+    IntermediateField ℚ (LaurentSeries ℚ) :=
+  IntermediateField.adjoin ℚ ((modularFunctionFieldFull M : Set (LaurentSeries ℚ))
+    ∪ {x : LaurentSeries ℚ | ∃ j : ℕ, j ≤ i ∧ x = jqN (p ^ j)})
+
+private theorem mem_chainField (M p : ℕ) [NeZero M] [NeZero p] {j i : ℕ} (hj : j ≤ i) :
+    jqN (p ^ j) ∈ chainField M p i :=
+  IntermediateField.subset_adjoin ℚ _ (Or.inr ⟨j, hj, rfl⟩)
+
+private theorem full_le_chainField (M p : ℕ) [NeZero M] [NeZero p] (i : ℕ) :
+    modularFunctionFieldFull M ≤ chainField M p i :=
+  fun _ hx => IntermediateField.subset_adjoin ℚ _ (Or.inl hx)
+
+private theorem chainField_zero (M p : ℕ) [NeZero M] [NeZero p] :
+    chainField M p 0 = modularFunctionFieldFull M := by
+  apply le_antisymm
+  · rw [chainField, IntermediateField.adjoin_le_iff]
+    rintro x (hx | ⟨j, hj, rfl⟩)
+    · exact hx
+    · rw [Nat.le_zero] at hj
+      subst hj
+      rw [show jqN (p ^ 0) = jq from (jqN_congr (pow_zero p)).trans jqN_one]
+      have h2 := jqd_mem_full M (one_dvd M)
+      rwa [qExpand_one_apply] at h2
+  · exact full_le_chainField M p 0
+
+private theorem chainField_mono (M p : ℕ) [NeZero M] [NeZero p] (i : ℕ) :
+    chainField M p i ≤ chainField M p (i + 1) := by
+  rw [chainField, chainField]
+  refine IntermediateField.adjoin.mono ℚ _ _ (Set.union_subset_union_right _ ?_)
+  rintro z ⟨j, hj, rfl⟩
+  exact ⟨j, le_trans hj (Nat.le_succ i), rfl⟩
+
+private theorem chainField_succ (M p : ℕ) [NeZero M] [NeZero p] (i : ℕ) :
+    chainField M p (i + 1) = IntermediateField.adjoin ℚ
+      ((chainField M p i : Set (LaurentSeries ℚ)) ∪ {jqN (p ^ i * p)}) := by
+  apply le_antisymm
+  · rw [chainField, IntermediateField.adjoin_le_iff]
+    rintro x (hx | ⟨j, hj, rfl⟩)
+    · exact IntermediateField.subset_adjoin ℚ _
+        (Or.inl (full_le_chainField M p i hx))
+    · rcases Nat.lt_or_ge j (i + 1) with h | h
+      · exact IntermediateField.subset_adjoin ℚ _
+          (Or.inl (mem_chainField M p (Nat.lt_succ_iff.mp h)))
+      · have hje : j = i + 1 := le_antisymm hj h
+        subst hje
+        refine IntermediateField.subset_adjoin ℚ _ (Or.inr ?_)
+        rw [Set.mem_singleton_iff]
+        exact jqN_congr (pow_succ p i)
+  · rw [IntermediateField.adjoin_le_iff]
+    rintro x (hx | hx)
+    · exact chainField_mono M p i hx
+    · rw [Set.mem_singleton_iff] at hx
+      subst hx
+      rw [show jqN (p ^ i * p) = jqN (p ^ (i + 1)) from jqN_congr (pow_succ p i).symm]
+      exact mem_chainField M p (le_refl (i + 1))
+
+private theorem chain_extend (p e s : ℕ) [hpp : Fact (Nat.Prime p)] [NeZero e] [NeZero s]
+    (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) (p * e * s)) (dp : ModularPolynomialData p)
+    (F : IntermediateField ℚ (LaurentSeries ℚ)) (σ : F →+* LaurentSeries K)
+    (d : ℕ) [NeZero d] (hd_mem : jqN d ∈ F) (hx_not : jqN (d * p) ∉ F)
+    (t : ℕ)
+    (hσd : σ ⟨jqN d, hd_mem⟩
+      = qExpand K (p * e) (qTwist (ζ ^ (t * (p * e))) (coeffEmb K jq)))
+    (hrange : ∀ y : F, σ y ∈ (qExpand K (p * e)).range)
+    (G : IntermediateField ℚ (LaurentSeries ℚ))
+    (hG : G = IntermediateField.adjoin ℚ ((F : Set (LaurentSeries ℚ)) ∪ {jqN (d * p)})) :
+    ∃ (σ' : G →+* LaurentSeries K) (t' : ℕ),
+      (∀ (z : F) (hz : (z : LaurentSeries ℚ) ∈ G), σ' ⟨z, hz⟩ = σ z) ∧
+      (∀ hx : jqN (d * p) ∈ G, σ' ⟨jqN (d * p), hx⟩
+        = qExpand K e (qTwist (ζ ^ (t' * e)) (coeffEmb K jq))) ∧
+      (∀ y : G, σ' y ∈ (qExpand K e).range) := by
+  subst hG
+  classical
+  have hp0 : 0 < p := hpp.out.pos
+  have hP_aeval : Polynomial.aeval (jqN (d * p)) (phiAtSeed dp (⟨jqN d, hd_mem⟩ : F)) = 0 := by
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, phiAtSeed_map]
+    exact phiAtSeed_jqN_eval p dp d
+  have hint : IsIntegral F (jqN (d * p)) :=
+    ⟨phiAtSeed dp (⟨jqN d, hd_mem⟩ : F), phiAtSeed_monic dp _, by
+      rwa [Polynomial.aeval_def] at hP_aeval⟩
+  have hdvd : minpoly F (jqN (d * p)) ∣ phiAtSeed dp (⟨jqN d, hd_mem⟩ : F) :=
+    minpoly.dvd F _ hP_aeval
+  let : Algebra F (LaurentSeries K) := σ.toAlgebra
+  have halg : algebraMap F (LaurentSeries K) = σ := RingHom.algebraMap_toAlgebra σ
+  have hpB : p ∣ p * e * s := ⟨e * s, by ring⟩
+  have hBdiv : p * e * s / p = e * s := by
+    rw [show p * e * s = p * (e * s) from by ring, Nat.mul_div_cancel_left _ hp0]
+  have hunit_seed : ζ ^ (t * (p * e)) = (ζ ^ (t * e)) ^ p := by
+    rw [← pow_mul]
+    congr 1
+    ring
+  have hmapP : (phiAtSeed dp (⟨jqN d, hd_mem⟩ : F)).map (algebraMap F (LaurentSeries K))
+      = phiAtSeed dp (qExpand K (p * e) (qTwist ((ζ ^ (t * e)) ^ p) (coeffEmb K jq))) := by
+    rw [phiAtSeed_map, halg, hσd, hunit_seed]
+  have hroots_iff : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed dp (⟨jqN d, hd_mem⟩ : F)) = 0 ↔
+      (y = qExpand K (p * (p * e)) (qTwist ((ζ ^ (t * e)) ^ (p * p)) (coeffEmb K jq)) ∨
+        ∃ c < p, y = qExpand K e
+          (qTwist (ζ ^ (t * e) * ζ ^ (c * (e * s))) (coeffEmb K jq))) := by
+    intro y
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hmapP, phiAtSeed]
+    have h := isRoot_prime_at_slot_iff (p * e * s) ζ hζ p hpB dp e (ζ ^ (t * e)) y
+    rw [hBdiv] at h
+    exact h
+  have hPmap_ne : (phiAtSeed dp (⟨jqN d, hd_mem⟩ : F)).map (algebraMap F (LaurentSeries K)) ≠ 0 :=
+    ((phiAtSeed_monic dp _).map _).ne_zero
+  have hPmap_splits : ((phiAtSeed dp (⟨jqN d, hd_mem⟩ : F)).map
+      (algebraMap F (LaurentSeries K))).Splits := by
+    rw [hmapP, phiAtSeed, ModularCurve.PhiGen.splits_prime_at_slot (p * e * s) ζ hζ p hpB dp e
+      (ζ ^ (t * e))]
+    exact (Polynomial.Splits.X_sub_C _).mul
+      (Polynomial.Splits.prod fun b _ => Polynomial.Splits.X_sub_C _)
+  have hPmap_nodup : ((phiAtSeed dp (⟨jqN d, hd_mem⟩ : F)).map
+      (algebraMap F (LaurentSeries K))).roots.Nodup := by
+    rw [hmapP, phiAtSeed]
+    exact roots_prime_at_slot_roots_nodup (p * e * s) ζ hζ p hpB dp e (ζ ^ (t * e))
+  have hm_dvd_map : (minpoly F (jqN (d * p))).map (algebraMap F (LaurentSeries K))
+      ∣ (phiAtSeed dp (⟨jqN d, hd_mem⟩ : F)).map (algebraMap F (LaurentSeries K)) :=
+    Polynomial.map_dvd _ hdvd
+  have hm_roots_le : ((minpoly F (jqN (d * p))).map (algebraMap F (LaurentSeries K))).roots
+      ≤ ((phiAtSeed dp (⟨jqN d, hd_mem⟩ : F)).map (algebraMap F (LaurentSeries K))).roots :=
+    Polynomial.roots.le_of_dvd hPmap_ne hm_dvd_map
+  have hm_splits : ((minpoly F (jqN (d * p))).map (algebraMap F (LaurentSeries K))).Splits :=
+    hPmap_splits.of_dvd hPmap_ne hm_dvd_map
+  have hm_deg : 2 ≤ ((minpoly F (jqN (d * p))).map (algebraMap F (LaurentSeries K))).natDegree := by
+    rw [(minpoly.monic hint).natDegree_map, minpoly.two_le_natDegree_iff hint]
+    intro hmem
+    obtain ⟨w, hw⟩ := hmem
+    rw [← hw] at hx_not
+    exact hx_not w.2
+  have hm_nodup : (((minpoly F (jqN (d * p))).map (algebraMap F (LaurentSeries K))).roots).Nodup :=
+    Multiset.nodup_of_le hm_roots_le hPmap_nodup
+  have hroot_trans : ∀ y ∈ ((minpoly F (jqN (d * p))).map (algebraMap F (LaurentSeries K))).roots,
+      Polynomial.aeval y (phiAtSeed dp (⟨jqN d, hd_mem⟩ : F)) = 0 := by
+    intro y hy
+    have h1 : y ∈ ((phiAtSeed dp (⟨jqN d, hd_mem⟩ : F)).map
+        (algebraMap F (LaurentSeries K))).roots := Multiset.mem_of_le hm_roots_le hy
+    rw [Polynomial.mem_roots hPmap_ne] at h1
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map]
+    exact h1
+  have h2d : ∃ y₁ ∈ ((minpoly F (jqN (d * p))).map (algebraMap F (LaurentSeries K))).roots,
+      ∃ y₂ ∈ ((minpoly F (jqN (d * p))).map (algebraMap F (LaurentSeries K))).roots, y₁ ≠ y₂ := by
+    have hcard : 1 < (((minpoly F (jqN (d * p))).map
+        (algebraMap F (LaurentSeries K))).roots).toFinset.card := by
+      rw [Multiset.toFinset_card_of_nodup hm_nodup, ← hm_splits.natDegree_eq_card_roots]
+      omega
+    obtain ⟨y₁, hy₁, y₂, hy₂, hne⟩ := Finset.one_lt_card.mp hcard
+    exact ⟨y₁, Multiset.mem_toFinset.mp hy₁, y₂, Multiset.mem_toFinset.mp hy₂, hne⟩
+  obtain ⟨y₁, hy₁, y₂, hy₂, hne⟩ := h2d
+  have hex_twist : ∃ c < p, qExpand K e (qTwist (ζ ^ (t * e) * ζ ^ (c * (e * s))) (coeffEmb K jq))
+      ∈ ((minpoly F (jqN (d * p))).map (algebraMap F (LaurentSeries K))).roots := by
+    rcases (hroots_iff y₁).mp (hroot_trans y₁ hy₁) with h1 | ⟨c, hc, h1⟩
+    · rcases (hroots_iff y₂).mp (hroot_trans y₂ hy₂) with h2 | ⟨c, hc, h2⟩
+      · exact absurd (h1.trans h2.symm) hne
+      · exact ⟨c, hc, h2 ▸ hy₂⟩
+    · exact ⟨c, hc, h1 ▸ hy₁⟩
+  obtain ⟨c, hc, htwist_mem⟩ := hex_twist
+  have htwist_aroots : qExpand K e (qTwist (ζ ^ (t * e) * ζ ^ (c * (e * s))) (coeffEmb K jq))
+      ∈ (minpoly F (jqN (d * p))).aroots (LaurentSeries K) := htwist_mem
+  obtain ⟨ψ, hψ_gen⟩ : ∃ ψ : IntermediateField.adjoin F ({jqN (d * p)} : Set (LaurentSeries ℚ))
+        →ₐ[F] LaurentSeries K,
+      ψ (IntermediateField.AdjoinSimple.gen F (jqN (d * p)))
+        = qExpand K e (qTwist (ζ ^ (t * e) * ζ ^ (c * (e * s))) (coeffEmb K jq)) :=
+    ⟨(IntermediateField.algHomAdjoinIntegralEquiv F hint).symm ⟨_, htwist_aroots⟩,
+      IntermediateField.algHomAdjoinIntegralEquiv_symm_apply_gen F hint ⟨_, htwist_aroots⟩⟩
+  have hle : ∀ {z : LaurentSeries ℚ},
+      z ∈ IntermediateField.adjoin ℚ ((F : Set (LaurentSeries ℚ)) ∪ {jqN (d * p)}) →
+      z ∈ IntermediateField.adjoin F ({jqN (d * p)} : Set (LaurentSeries ℚ)) := by
+    intro z hz
+    induction hz using IntermediateField.adjoin_induction with
+    | mem w hw =>
+      rcases hw with hw | hw
+      · exact (IntermediateField.adjoin F
+          ({jqN (d * p)} : Set (LaurentSeries ℚ))).algebraMap_mem ⟨w, hw⟩
+      · rw [Set.mem_singleton_iff] at hw
+        subst hw
+        exact IntermediateField.subset_adjoin F _ rfl
+    | algebraMap q =>
+      rw [eq_ratCast]
+      exact SubfieldClass.ratCast_mem _ q
+    | add x y hx hy ihx ihy => exact add_mem ihx ihy
+    | inv x hx ihx => exact inv_mem ihx
+    | mul x y hx hy ihx ihy => exact mul_mem ihx ihy
+  refine ⟨{
+    toFun := fun z => ψ ⟨z.1, hle z.2⟩
+    map_one' := (congrArg ψ (Subtype.ext rfl)).trans (map_one ψ)
+    map_mul' := fun z w => by
+      have h1 : (⟨(z * w).1, hle (z * w).2⟩ :
+          IntermediateField.adjoin F ({jqN (d * p)} : Set (LaurentSeries ℚ)))
+          = ⟨z.1, hle z.2⟩ * ⟨w.1, hle w.2⟩ := Subtype.ext rfl
+      rw [h1, map_mul]
+    map_zero' := (congrArg ψ (Subtype.ext rfl)).trans (map_zero ψ)
+    map_add' := fun z w => by
+      have h1 : (⟨(z + w).1, hle (z + w).2⟩ :
+          IntermediateField.adjoin F ({jqN (d * p)} : Set (LaurentSeries ℚ)))
+          = ⟨z.1, hle z.2⟩ + ⟨w.1, hle w.2⟩ := Subtype.ext rfl
+      rw [h1, map_add] }, t + c * s, ?_, ?_, ?_⟩
+  · intro z hz
+    change ψ ⟨(z : LaurentSeries ℚ), _⟩ = σ z
+    have h1 : (⟨(z : LaurentSeries ℚ), hle hz⟩ :
+        IntermediateField.adjoin F ({jqN (d * p)} : Set (LaurentSeries ℚ)))
+        = algebraMap F (IntermediateField.adjoin F ({jqN (d * p)} : Set (LaurentSeries ℚ))) z :=
+      Subtype.ext rfl
+    rw [h1, AlgHom.commutes, halg]
+  · intro hx
+    change ψ ⟨jqN (d * p), _⟩ = _
+    have h1 : (⟨jqN (d * p), hle hx⟩ :
+        IntermediateField.adjoin F ({jqN (d * p)} : Set (LaurentSeries ℚ)))
+        = IntermediateField.AdjoinSimple.gen F (jqN (d * p)) := Subtype.ext rfl
+    have hu : ζ ^ (t * e) * ζ ^ (c * (e * s)) = ζ ^ ((t + c * s) * e) := by
+      rw [← pow_add]
+      congr 1
+      ring
+    rw [h1, hψ_gen, hu]
+  · intro z
+    change ψ ⟨z.1, hle z.2⟩ ∈ (qExpand K e).range
+    obtain ⟨g, hg⟩ := (IntermediateField.adjoin.powerBasis hint).exists_eq_aeval'
+      (⟨z.1, hle z.2⟩ : IntermediateField.adjoin F ({jqN (d * p)} : Set (LaurentSeries ℚ)))
+    rw [IntermediateField.adjoin.powerBasis_gen] at hg
+    rw [hg, ← Polynomial.aeval_algHom_apply, hψ_gen, Polynomial.aeval_def,
+      Polynomial.eval₂_eq_sum_range]
+    refine sum_mem fun i _ => mul_mem ?_ (pow_mem ?_ i)
+    · rw [halg]
+      exact mem_range_qExpand_of_mul (hrange _)
+    · exact RingHom.mem_range.mpr
+        ⟨qTwist (ζ ^ (t * e) * ζ ^ (c * (e * s))) (coeffEmb K jq), rfl⟩
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData modularFunctionFieldFull jqd_mem_full coeffEmb coeffEmb_coeff \
+  qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+
+private theorem chain_endgame (M p : ℕ) [NeZero M] [hp : Fact (Nat.Prime p)] (a : ℕ)
+    (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) (M * p ^ (a + 2)))
+    (dp : ModularPolynomialData p) (hsp : EvalSymm dp.Φ)
+    (hF : jqN p ∉ modularFunctionFieldFull M)
+    (hIH : ∀ a' : ℕ, a' < a → jqN (p ^ (a' + 2)) ∉ chainField M p (a' + 1))
+    (hmem : jqN (p ^ (a + 2)) ∈ chainField M p (a + 1)) : False := by
+  classical
+  have hp0 : 0 < p := hp.out.pos
+  have hp2 : 2 ≤ p := hp.out.two_le
+  have hM0 : 0 < M := Nat.pos_of_ne_zero (NeZero.ne M)
+  have hnot : ∀ i : ℕ, i ≤ a → jqN (p ^ i * p) ∉ chainField M p i := by
+    intro i hi
+    rw [show jqN (p ^ i * p) = jqN (p ^ (i + 1)) from jqN_congr (pow_succ p i).symm]
+    rcases Nat.eq_zero_or_pos i with rfl | hi0
+    · rw [chainField_zero]
+      rw [show jqN (p ^ (0 + 1)) = jqN p from jqN_congr (by rw [zero_add, pow_one])]
+      exact hF
+    · have heq1 : jqN (p ^ (i + 1)) = jqN (p ^ (i - 1 + 2)) :=
+        jqN_congr (congrArg (fun n => p ^ n) (by omega))
+      have heq2 : chainField M p i = chainField M p (i - 1 + 1) :=
+        congrArg (chainField M p) (by omega)
+      rw [heq1, heq2]
+      exact hIH (i - 1) (by omega)
+  have chain : ∀ i : ℕ, i ≤ a →
+      ∃ (σ : chainField M p i →+* LaurentSeries K) (t : ℕ),
+        (σ ⟨jqN (p ^ i), mem_chainField M p (le_refl i)⟩
+          = qExpand K (M * p ^ (a + 2 - i))
+            (qTwist (ζ ^ (t * (M * p ^ (a + 2 - i)))) (coeffEmb K jq))) ∧
+        (∀ y : chainField M p i, σ y ∈ (qExpand K (M * p ^ (a + 2 - i))).range) := by
+    intro i
+    induction i with
+    | zero =>
+      intro _
+      refine ⟨((coeffEmb K).comp (qExpand ℚ (M * p ^ (a + 2)))).comp
+        (algebraMap (chainField M p 0) (LaurentSeries ℚ)), 0, ?_, ?_⟩
+      · change coeffEmb K (qExpand ℚ (M * p ^ (a + 2)) (jqN (p ^ 0))) = _
+        rw [show jqN (p ^ 0) = jq from (jqN_congr (pow_zero p)).trans jqN_one, iota_jq,
+          zero_mul, pow_zero]
+        suffices TS K (M * p ^ (a + 2)) 1 = TS K (M * p ^ (a + 2 - 0)) 1 by
+          simpa only [TS_eq_coeffEmb] using this
+        exact TS_congr (by rw [Nat.sub_zero]) 1
+      · intro y
+        change coeffEmb K (qExpand ℚ (M * p ^ (a + 2)) (y : LaurentSeries ℚ)) ∈ _
+        rw [coeffEmb_qExpand]
+        rw [← range_qExpand_congr (show (M * p ^ (a + 2) : ℕ) = M * p ^ (a + 2 - 0) from by
+          rw [Nat.sub_zero])]
+        exact RingHom.mem_range.mpr ⟨coeffEmb K (y : LaurentSeries ℚ), rfl⟩
+    | succ i ih =>
+      intro hi
+      obtain ⟨σ, t, hσtop, hσrange⟩ := ih (Nat.le_of_succ_le hi)
+      have hpow_step : M * p ^ (a + 2 - i) = p * (M * p ^ (a + 2 - (i + 1))) := by
+        rw [show a + 2 - i = (a + 2 - (i + 1)) + 1 from by omega, pow_succ]
+        ring
+      have hσtop' : σ ⟨jqN (p ^ i), mem_chainField M p (le_refl i)⟩
+          = qExpand K (p * (M * p ^ (a + 2 - (i + 1))))
+            (qTwist (ζ ^ (t * (p * (M * p ^ (a + 2 - (i + 1)))))) (coeffEmb K jq)) := by
+        rw [hσtop]
+        have h1 : ζ ^ (t * (M * p ^ (a + 2 - i)))
+            = ζ ^ (t * (p * (M * p ^ (a + 2 - (i + 1))))) := by
+          rw [hpow_step]
+        rw [h1]
+        suffices TS K (M * p ^ (a + 2 - i)) _ = TS K (p * (M * p ^ (a + 2 - (i + 1)))) _ by
+          simpa only [TS_eq_coeffEmb] using this
+        exact TS_congr hpow_step _
+      have hζ' : IsPrimitiveRoot (ζ : K) (p * (M * p ^ (a + 2 - (i + 1))) * p ^ i) := by
+        have hBs : M * p ^ (a + 2) = p * (M * p ^ (a + 2 - (i + 1))) * p ^ i := by
+          have h1 : (1 : ℕ) + (a + 2 - (i + 1)) + i = a + 2 := by omega
+          calc M * p ^ (a + 2) = M * p ^ (1 + (a + 2 - (i + 1)) + i) := by rw [h1]
+            _ = p * (M * p ^ (a + 2 - (i + 1))) * p ^ i := by
+                rw [pow_add, pow_add, pow_one]; ring
+        exact hBs ▸ hζ
+      have hσrange' : ∀ y : chainField M p i,
+          σ y ∈ (qExpand K (p * (M * p ^ (a + 2 - (i + 1))))).range := by
+        intro y
+        have h := hσrange y
+        rwa [range_qExpand_congr hpow_step] at h
+      obtain ⟨σ', t', hcompat, hσ'new, hσ'range⟩ :=
+        chain_extend p (M * p ^ (a + 2 - (i + 1))) (p ^ i) ζ hζ' dp (chainField M p i) σ
+          (p ^ i) (mem_chainField M p (le_refl i)) (hnot i (Nat.le_of_succ_le hi)) t
+          hσtop' hσrange' (chainField M p (i + 1)) (chainField_succ M p i)
+      refine ⟨σ', t', ?_, hσ'range⟩
+      have hxmem : jqN (p ^ i * p) ∈ chainField M p (i + 1) := by
+        rw [show jqN (p ^ i * p) = jqN (p ^ (i + 1)) from jqN_congr (pow_succ p i).symm]
+        exact mem_chainField M p (le_refl (i + 1))
+      have hmk : (⟨jqN (p ^ (i + 1)), mem_chainField M p (le_refl (i + 1))⟩ :
+          chainField M p (i + 1)) = ⟨jqN (p ^ i * p), hxmem⟩ :=
+        Subtype.ext (jqN_congr (pow_succ p i))
+      rw [hmk]
+      exact hσ'new hxmem
+  obtain ⟨σa, ta, hatop, harange⟩ := chain a (le_refl a)
+  have hpow_top : M * p ^ (a + 2 - a) = p * (M * p) := by
+    rw [show a + 2 - a = 2 from by omega]
+    ring
+  have hatop' : σa ⟨jqN (p ^ a), mem_chainField M p (le_refl a)⟩
+      = qExpand K (p * (M * p)) (qTwist (ζ ^ (ta * (p * (M * p)))) (coeffEmb K jq)) := by
+    rw [hatop]
+    have h1 : ζ ^ (ta * (M * p ^ (a + 2 - a))) = ζ ^ (ta * (p * (M * p))) := by
+      rw [hpow_top]
+    rw [h1]
+    suffices TS K (M * p ^ (a + 2 - a)) _ = TS K (p * (M * p)) _ by
+      simpa only [TS_eq_coeffEmb] using this
+    exact TS_congr hpow_top _
+  have harange' : ∀ y : chainField M p a, σa y ∈ (qExpand K (p * (M * p))).range := by
+    intro y
+    have h := harange y
+    rwa [range_qExpand_congr hpow_top] at h
+  have hζtop : IsPrimitiveRoot (ζ : K) (p * (M * p) * p ^ a) := by
+    have hBs : M * p ^ (a + 2) = p * (M * p) * p ^ a := by
+      have h1 : (1 : ℕ) + 1 + a = a + 2 := by omega
+      calc M * p ^ (a + 2) = M * p ^ (1 + 1 + a) := by rw [h1]
+        _ = p * (M * p) * p ^ a := by rw [pow_add, pow_add, pow_one]; ring
+    exact hBs ▸ hζ
+  obtain ⟨σ, tt, hcompat, hnew, hrange⟩ :=
+    chain_extend p (M * p) (p ^ a) ζ hζtop dp (chainField M p a) σa (p ^ a)
+      (mem_chainField M p (le_refl a)) (hnot a (le_refl a)) ta hatop' harange'
+      (chainField M p (a + 1)) (chainField_succ M p a)
+  have hmem_a1 : jqN (p ^ (a + 1)) ∈ chainField M p (a + 1) :=
+    mem_chainField M p (le_refl (a + 1))
+  have hmem_a : jqN (p ^ a) ∈ chainField M p (a + 1) :=
+    mem_chainField M p (Nat.le_succ a)
+  have hrel_up_Ω : (phiAtSeed dp (jqN (p ^ (a + 1)))).eval (jqN (p ^ (a + 2))) = 0 := by
+    have h := phiAtSeed_jqN_eval p dp (p ^ (a + 1))
+    rwa [show jqN (p ^ (a + 1) * p) = jqN (p ^ (a + 2)) from
+      jqN_congr (pow_succ p (a + 1)).symm] at h
+  have hrel_dn_Ω : (phiAtSeed dp (jqN (p ^ (a + 1)))).eval (jqN (p ^ a)) = 0 := by
+    have h := phiAtSeed_jqN_eval_down p dp hsp (p ^ a)
+    rwa [show jqN (p ^ a * p) = jqN (p ^ (a + 1)) from jqN_congr (pow_succ p a).symm] at h
+  have hrel_up_E : (phiAtSeed dp (⟨jqN (p ^ (a + 1)), hmem_a1⟩ : chainField M p (a + 1))).eval
+      (⟨jqN (p ^ (a + 2)), hmem⟩ : chainField M p (a + 1)) = 0 :=
+    phiAtSeed_eval_of_injective dp _ _
+      (algebraMap (chainField M p (a + 1)) (LaurentSeries ℚ)) Subtype.val_injective hrel_up_Ω
+  have hrel_dn_E : (phiAtSeed dp (⟨jqN (p ^ (a + 1)), hmem_a1⟩ : chainField M p (a + 1))).eval
+      (⟨jqN (p ^ a), hmem_a⟩ : chainField M p (a + 1)) = 0 :=
+    phiAtSeed_eval_of_injective dp _ _
+      (algebraMap (chainField M p (a + 1)) (LaurentSeries ℚ)) Subtype.val_injective hrel_dn_Ω
+  have hσ_a1 : σ ⟨jqN (p ^ (a + 1)), hmem_a1⟩
+      = qExpand K (M * p) (qTwist (ζ ^ (tt * (M * p))) (coeffEmb K jq)) := by
+    have hx : jqN (p ^ a * p) ∈ chainField M p (a + 1) := by
+      rw [show jqN (p ^ a * p) = jqN (p ^ (a + 1)) from jqN_congr (pow_succ p a).symm]
+      exact hmem_a1
+    have hmk : (⟨jqN (p ^ (a + 1)), hmem_a1⟩ : chainField M p (a + 1))
+        = ⟨jqN (p ^ a * p), hx⟩ := Subtype.ext (jqN_congr (pow_succ p a))
+    rw [hmk]
+    exact hnew hx
+  have hz_up : (phiAtSeed dp (qExpand K (M * p)
+      (qTwist (ζ ^ (tt * (M * p))) (coeffEmb K jq)))).eval
+      (σ ⟨jqN (p ^ (a + 2)), hmem⟩) = 0 := by
+    have h := phiAtSeed_eval_map dp _ _
+      (σ : chainField M p (a + 1) →+* LaurentSeries K) hrel_up_E
+    rwa [hσ_a1] at h
+  have hz_dn : (phiAtSeed dp (qExpand K (M * p)
+      (qTwist (ζ ^ (tt * (M * p))) (coeffEmb K jq)))).eval
+      (σ ⟨jqN (p ^ a), hmem_a⟩) = 0 := by
+    have h := phiAtSeed_eval_map dp _ _
+      (σ : chainField M p (a + 1) →+* LaurentSeries K) hrel_dn_E
+    rwa [hσ_a1] at h
+  have hpB : p ∣ M * p ^ (a + 2) := by
+    refine ⟨M * p ^ (a + 1), ?_⟩
+    rw [pow_succ]
+    ring
+  have hBdiv : M * p ^ (a + 2) / p = M * p ^ (a + 1) := by
+    rw [show M * p ^ (a + 2) = M * p ^ (a + 1) * p from by rw [pow_succ]; ring]
+    exact Nat.mul_div_cancel _ hp0
+  have hseed_eq : qExpand K (M * p) (qTwist (ζ ^ (tt * (M * p))) (coeffEmb K jq))
+      = qExpand K (p * M) (qTwist ((ζ ^ (tt * M)) ^ p) (coeffEmb K jq)) := by
+    have h1 : ζ ^ (tt * (M * p)) = (ζ ^ (tt * M)) ^ p := by
+      rw [← pow_mul]
+      congr 1
+      ring
+    rw [h1]
+    suffices TS K (M * p) _ = TS K (p * M) _ by
+      simpa only [TS_eq_coeffEmb] using this
+    exact TS_congr (Nat.mul_comm M p) _
+  have hroots_top : ∀ y : LaurentSeries K,
+      (phiAtSeed dp (qExpand K (M * p)
+        (qTwist (ζ ^ (tt * (M * p))) (coeffEmb K jq)))).eval y = 0 ↔
+      (y = qExpand K (p * (p * M)) (qTwist ((ζ ^ (tt * M)) ^ (p * p)) (coeffEmb K jq)) ∨
+        ∃ c < p, y = qExpand K M
+          (qTwist (ζ ^ (tt * M) * ζ ^ (c * (M * p ^ (a + 1)))) (coeffEmb K jq))) := by
+    intro y
+    rw [hseed_eq, phiAtSeed]
+    have h := isRoot_prime_at_slot_iff (M * p ^ (a + 2)) ζ hζ p hpB dp M (ζ ^ (tt * M)) y
+    rw [hBdiv] at h
+    exact h
+  have hMp_ne : ¬ (((M * p : ℕ) : ℤ) ∣ ((M : ℕ) : ℤ)) := by
+    rw [Int.natCast_dvd_natCast]
+    intro h
+    have h1 := Nat.le_of_dvd hM0 h
+    have h2 : M * 2 ≤ M * p := Nat.mul_le_mul_left M hp2
+    omega
+  have hz_up_spread : σ ⟨jqN (p ^ (a + 2)), hmem⟩
+      = qExpand K (p * (p * M)) (qTwist ((ζ ^ (tt * M)) ^ (p * p)) (coeffEmb K jq)) := by
+    rcases (hroots_top _).mp hz_up with h | ⟨c, hc, h⟩
+    · exact h
+    · exfalso
+      have hr := hrange ⟨jqN (p ^ (a + 2)), hmem⟩
+      rw [h] at hr
+      exact qExpand_qTwist_notMem_range_qExpand hMp_ne _ hr
+  have hz_dn_form : σ ⟨jqN (p ^ a), hmem_a⟩
+      = qExpand K (p * (M * p)) (qTwist (ζ ^ (ta * (p * (M * p)))) (coeffEmb K jq)) := by
+    have h1 := hcompat ⟨jqN (p ^ a), mem_chainField M p (le_refl a)⟩ hmem_a
+    exact h1.trans hatop'
+  have hz_dn_spread : σ ⟨jqN (p ^ a), hmem_a⟩
+      = qExpand K (p * (p * M)) (qTwist ((ζ ^ (tt * M)) ^ (p * p)) (coeffEmb K jq)) := by
+    rcases (hroots_top _).mp hz_dn with h | ⟨c, hc, h⟩
+    · exact h
+    · exfalso
+      have h1 := hz_dn_form.symm.trans h
+      have h2 := (TS_injective (K := K) (e := p * (M * p)) (e' := M)
+        (u := ζ ^ (ta * (p * (M * p))))
+        (u' := ζ ^ (tt * M) * ζ ^ (c * (M * p ^ (a + 1))))
+        (by simpa only [TS_eq_coeffEmb] using h1)).1
+      have h3 : M * (p * p) = M := by
+        rw [show M * (p * p) = p * (M * p) from by ring]
+        exact h2
+      exact nat_ne_of_mul hM0 (le_trans hp2 (Nat.le_mul_of_pos_right p hp0)) h3
+  have hsub : (⟨jqN (p ^ (a + 2)), hmem⟩ : chainField M p (a + 1))
+      = ⟨jqN (p ^ a), hmem_a⟩ :=
+    RingHom.injective σ (hz_up_spread.trans hz_dn_spread.symm)
+  have hval : jqN (p ^ (a + 2)) = jqN (p ^ a) := Subtype.ext_iff.mp hsub
+  have hc1 : (jqN (p ^ a)).coeff (-((p ^ a : ℕ) : ℤ)) = 1 := by
+    change (qExpand ℚ (p ^ a) jq).coeff _ = 1
+    have h := qExpand_coeff_mul (R := ℚ) (N := p ^ a) jq (-1)
+    rw [mul_neg_one] at h
+    rw [h, coeff_jq_neg_one]
+  have hc2 : (jqN (p ^ (a + 2))).coeff (-((p ^ a : ℕ) : ℤ)) = 0 := by
+    change (qExpand ℚ (p ^ (a + 2)) jq).coeff _ = 0
+    apply qExpand_coeff_of_not_dvd
+    rw [dvd_neg, Int.natCast_dvd_natCast]
+    intro hdvd
+    have hle2 := Nat.le_of_dvd (pow_pos hp0 a) hdvd
+    have h1 : p ^ a < p ^ a * (p * p) :=
+      lt_mul_of_one_lt_right (pow_pos hp0 a) (by nlinarith)
+    have h2 : p ^ a * (p * p) = p ^ (a + 2) := by rw [pow_add]; ring
+    omega
+  rw [hval, hc1] at hc2
+  exact one_ne_zero hc2
+
+
+theorem jqN_pow_not_mem_adjoin_full_key (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (a : ℕ) (hF : jqN p ∉ modularFunctionFieldFull M) :
+    jqN (p ^ (a + 2)) ∉ chainField M p (a + 1) := by
+  induction a using Nat.strong_induction_on with
+  | _ a IH =>
+  intro hmem
+  obtain ⟨dp, -, hsp⟩ := ModularCurve.exists_phiIrreducible_evalSymm p
+  exact chain_endgame M p a (cycUnit (M * p ^ (a + 2))) (cycUnit_spec (M * p ^ (a + 2)))
+    dp hsp hF IH hmem
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN jqN_one dedekindPsi \
+  evalAtJ_X ModularPolynomialData modularFunctionFieldFull jqd_mem_full coeffEmb coeffEmb_coeff \
+  qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.jqN_pow_not_mem_adjoin_full (M : ℕ) [NeZero M] (p : ℕ)
+    [hp : Fact (Nat.Prime p)] (a : ℕ)
+    (hF : jqN p ∉ modularFunctionFieldFull M) :
+    jqN (p ^ (a + 2)) ∉ IntermediateField.adjoin ℚ
+      ((modularFunctionFieldFull M : Set (LaurentSeries ℚ))
+        ∪ {x : LaurentSeries ℚ | ∃ i : ℕ, i ≤ a + 1 ∧ x = jqN (p ^ i)}) := by
+  exact ModularCurve.W1.jqN_pow_not_mem_adjoin_full_key M p a hF
+
+end
+
+p2m_open "ModularCurve~coeffEmb_qExpand\
+  " in
+open _root_.P2MW.S_ModularCurve_jqN_pow_not_mem_adjoin_full.ModularCurve in
+theorem solution (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (a : ℕ)
+    (hF : jqN p ∉ modularFunctionFieldFull M) :
+    jqN (p ^ (a + 2)) ∉ IntermediateField.adjoin ℚ ((modularFunctionFieldFull M : Set (LaurentSeries
+      ℚ)) ∪ {x : LaurentSeries ℚ | ∃ i : ℕ, i ≤ a + 1 ∧ x = jqN (p ^ i)}) :=
+  ModularCurve.jqN_pow_not_mem_adjoin_full M p a hF
+
+end S_ModularCurve_jqN_pow_not_mem_adjoin_full
+end P2MW
+export P2MW.S_ModularCurve_jqN_pow_not_mem_adjoin_full (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.jqN_pow_not_mem_adjoin_full (M : ℕ) [NeZero M] (p : ℕ)
+    [hp : Fact (Nat.Prime p)] (a : ℕ) (hF : jqN p ∉ modularFunctionFieldFull M) :
+    jqN (p ^ (a + 2)) ∉ IntermediateField.adjoin ℚ ((modularFunctionFieldFull M : Set (LaurentSeries
+      ℚ)) ∪ {x : LaurentSeries ℚ | ∃ i : ℕ, i ≤ a + 1 ∧ x = jqN (p ^ i)}) :=
+  solution M p a hF
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqN_prime_not_mem_adjoin.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqN_prime_not_mem_adjoin.lean
new file mode 100644
index 0000000000..2b9af225f6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqN_prime_not_mem_adjoin.lean
@@ -0,0 +1,691 @@
+/-
+Based on Prove2Me node ModularCurve.jqN_prime_not_mem_adjoin
+(80c9a2aa-2c5c-5aa9-ae39-f3296c43be03) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ec5f8305-42b1-5eb4-84b8-af2f2cfaa80d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqN_prime_of_not_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqN_eq_of_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_injective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Polynomial_mem_range_of_eval_eq_const
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.FieldTheory.Minpoly.Field
+import Mathlib.RingTheory.PowerBasis
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# j(q^r) is not rational in j and the j(qᵖ), p∈ S
+
+Theorem statement: `ModularCurve.jqN_prime_not_mem_adjoin` (`80c9a2aa-2c5c-5aa9-ae39-f3296c43be03`),
+by Claude, 2026-09-05.
+
+Proof: submission `ec5f8305-42b1-5eb4-84b8-af2f2cfaa80d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Work inside the field $\mathbb{Q}((q))$ of rational Laurent series, realised as `LaurentSeries ℚ`.
+Here `jq` denotes the Laurent series $q^{-1}\cdot j_{\mathrm{num}}$, where $j_{\mathrm{num}}$ is the
+integral power series `jNum` with its coefficients mapped into $\mathbb{Q}$, so `jq` is the
+$q$-expansion of the modular invariant $j$; and for $N\neq 0$, `jqN N` is the image of `jq` under
+the ring homomorphism `qExpand ℚ N`, which multiplies all exponents by $N$, i.e. the substitution
+$q\mapsto q^{N}$, giving $j(q^{N})$. The data are: a finite set $S$ of natural numbers, a hypothesis
+that every $p\in S$ is prime, and a further prime $r$ with $r\notin S$. The conclusion is that
+$j(q^{r})$ does not lie in the intermediate field of $\mathbb{Q}((q))$ over $\mathbb{Q}$ generated
+by the set consisting of `jq` together with all Laurent series of the form `jqN p` for $p\in S$
+(each such $p$ being nonzero). Equivalently, $j(q^{r})\notin \mathbb{Q}\bigl(j(q),\,j(q^{p}):p\in
+S\bigr)$.
+
+This is the descent step in a purely algebraic treatment of the degree of the modular equation: the
+successive extensions $\mathbb{Q}(j)\subseteq \mathbb{Q}(j,j(q^{p}):p\in S)$ are all proper at each
+new prime, which is what makes the local degree computations $[\,F(j(q^{p})):F\,]=p+1=\psi(p)$
+applicable. It is used in the computation of relative degrees for adjoining several primes and for
+prime-square levels, and hence in identifying $[\mathbb{Q}(j)(j_N):\mathbb{Q}(j)]$ with $\psi(N)$,
+i.e. the irreducibility of the modular polynomial $\Phi_N$ over $\mathbb{Q}(j)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_jqN_prime_not_mem_adjoin.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_jqN_prime_not_mem_adjoin
+
+noncomputable section
+
+p2m_open "ModularCurve~coeffEmb_qExpand P2MW.S_ModularCurve_jqN_prime_not_mem_adjoin.ModularCurve \
+  ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN \
+  dedekindPsi evalAtJ_X ModularPolynomialData coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  finrank_adjoin_jqN_prime_of_not_mem finrank_adjoin_jqN_eq_of_prime dedekindPsi_prime \
+  exists_phiIrreducible_evalSymm coeffMap_injective"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+
+
+
+
+
+
+
+
+
+
+theorem coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb K (qExpand ℚ n x) = qExpand K n (coeffEmb K x) :=
+  coeffMap_qExpand (algebraMap ℚ K) n x
+
+theorem iota_jqN (N d : ℕ) [NeZero N] [NeZero d] :
+    coeffEmb K (qExpand ℚ N (jqN d)) = TS K (N * d) 1 := by
+  rw [jqN, coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem iota_jq (N : ℕ) [NeZero N] : coeffEmb K (qExpand ℚ N jq) = TS K N 1 := by
+  rw [coeffEmb_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_zero_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    conj p ζ (0 : Fin (p + 1)) = TS K (p * p) 1 := by
+  rw [conj_zero, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_succ_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) (b : Fin p) :
+    conj p ζ b.succ = TS K 1 (ζ ^ (b : ℕ)) := by
+  rw [conj_succ, TS_eq_coeffEmb, qExpand_one_apply]
+
+theorem qTwist_iota_of_pow_eq_one (N : ℕ) [NeZero N] (v : Kˣ) (hv : v ^ N = 1) (x : LaurentSeries ℚ)
+    :
+    qTwist v (coeffEmb K (qExpand ℚ N x)) = coeffEmb K (qExpand ℚ N x) := by
+  rw [coeffEmb_qExpand, qTwist_qExpand]
+  have : v ^ (N : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN \
+  dedekindPsi evalAtJ_X ModularPolynomialData coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  finrank_adjoin_jqN_prime_of_not_mem finrank_adjoin_jqN_eq_of_prime dedekindPsi_prime \
+  exists_phiIrreducible_evalSymm coeffMap_injective"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+omit [Algebra ℚ K] in
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+omit [Algebra ℚ K] in
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+omit [Algebra ℚ K] in
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem phiProd_conj_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    phiProd p (conj p ζ) = (Polynomial.X - Polynomial.C (TS K (p * p) 1)) *
+      ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) := by
+  rw [phiProd, Fin.prod_univ_succ, conj_zero_eq]
+  congr 1
+  rw [← Fin.prod_univ_eq_prod_range (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) p]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [conj_succ_eq]
+
+theorem roots_phiProd_conj (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    (phiProd p (conj p ζ)).roots = TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^
+      b)) := by
+  classical
+  rw [phiProd_conj_eq]
+  have h1 : (Polynomial.X - Polynomial.C (TS K (p * p) 1) : Polynomial (LaurentSeries K)) ≠ 0 :=
+    Polynomial.X_sub_C_ne_zero _
+  have h2 : (∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b)))) ≠ 0 :=
+    Finset.prod_ne_zero_iff.mpr fun b _ => Polynomial.X_sub_C_ne_zero _
+  rw [Polynomial.roots_mul (mul_ne_zero h1 h2), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod,
+    Finset.range_val]
+  have hm : (Multiset.map (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) (Multiset.range
+    p)) =
+      ((Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).map (fun a => Polynomial.X - Polynomial.C
+        a) := by
+    rw [Multiset.map_map]; rfl
+  rw [hm, Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+omit [Algebra ℚ K] in
+theorem roots_phiProd_conj_nodup (p : ℕ) [hp : Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).Nodup := by
+  refine Multiset.nodup_cons.mpr ⟨?_, ?_⟩
+  · intro hmem
+    obtain ⟨b, -, hb⟩ := Multiset.mem_map.mp hmem
+    have := (TS_injective hb).1
+    have h2 := hp.out.two_le
+    nlinarith
+  · refine (Multiset.nodup_range p).map_on fun b hb b' hb' hbb' => ?_
+    rw [Multiset.mem_range] at hb hb'
+    have hu := (TS_injective hbb').2
+    have hζu : IsPrimitiveRoot ζ p := IsPrimitiveRoot.coe_units_iff.mp hζ
+    exact hζu.pow_inj hb hb' hu
+
+theorem exists_isPrimitiveRoot_cyclotomicField (N : ℕ) [NeZero N] :
+    ∃ z : CyclotomicField N ℚ, IsPrimitiveRoot z N := by
+  have : NeZero ((N : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr (NeZero.ne N)⟩
+  have : IsCyclotomicExtension {N} ℚ (CyclotomicField N ℚ) :=
+    CyclotomicField.isCyclotomicExtension N ℚ
+  exact IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField N ℚ) (Set.mem_singleton N)
+    (NeZero.ne N)
+
+def cycUnit (N : ℕ) [NeZero N] : (CyclotomicField N ℚ)ˣ :=
+  ((exists_isPrimitiveRoot_cyclotomicField N).choose_spec.isUnit (NeZero.ne N)).unit
+
+theorem cycUnit_spec (N : ℕ) [NeZero N] :
+    IsPrimitiveRoot ((cycUnit N : (CyclotomicField N ℚ)ˣ) : CyclotomicField N ℚ) N := by
+  rw [cycUnit, IsUnit.unit_spec]
+  exact (exists_isPrimitiveRoot_cyclotomicField N).choose_spec
+
+theorem cycUnit_pow (N : ℕ) [NeZero N] : cycUnit N ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, (cycUnit_spec N).pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN \
+  dedekindPsi evalAtJ_X ModularPolynomialData coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  finrank_adjoin_jqN_prime_of_not_mem finrank_adjoin_jqN_eq_of_prime dedekindPsi_prime \
+  exists_phiIrreducible_evalSymm coeffMap_injective"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN \
+  dedekindPsi evalAtJ_X ModularPolynomialData coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  finrank_adjoin_jqN_prime_of_not_mem finrank_adjoin_jqN_eq_of_prime dedekindPsi_prime \
+  exists_phiIrreducible_evalSymm coeffMap_injective"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem prod_form_ne_zero (N : ℕ) (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e]
+    (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K
+            jq)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+          (Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u,
+    Polynomial.roots_mul (prod_form_ne_zero N ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p)))
+    (coeffEmb K jq))))
+        = ((Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+        (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+        (Multiset.range p).map
+          (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).Nodup := by
+  have hζp : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := isPrimitiveRoot_pow_div hζ hpN
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h := (TS_injective (K := K) (e := e) (e' := p * (p * e))
+      (u := u * ζ ^ (b * (N / p))) (u' := u ^ (p * p))
+      (by simpa only [TS_eq_coeffEmb] using heq)).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e)
+      (u := u * ζ ^ (b * (N / p))) (u' := u * ζ ^ (b' * (N / p)))
+      (by simpa only [TS_eq_coeffEmb] using heq)).2
+    have h2 : ζ ^ (b * (N / p)) = ζ ^ (b' * (N / p)) := mul_left_cancel h
+    have h3 : (ζ ^ (N / p)) ^ b = (ζ ^ (N / p)) ^ b' := by
+      rw [← pow_mul, ← pow_mul, Nat.mul_comm (N / p) b, Nat.mul_comm (N / p) b']
+      exact h2
+    have h4 : ((ζ ^ (N / p) : Kˣ) : K) ^ b = ((ζ ^ (N / p) : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h3]
+    exact hζp.pow_inj hb hb' h4
+
+theorem roots_prime_at_slot_roots_nodup (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots.Nodup := by
+  rw [roots_prime_at_slot N ζ hζ p hpN data e u]
+  exact roots_prime_at_slot_nodup N ζ hζ p hpN e u
+
+theorem isRoot_prime_at_slot_iff (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u]
+    exact prod_form_ne_zero N ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot N ζ hζ p hpN data e u,
+    Multiset.mem_cons, Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN \
+  dedekindPsi evalAtJ_X ModularPolynomialData coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  finrank_adjoin_jqN_prime_of_not_mem finrank_adjoin_jqN_eq_of_prime dedekindPsi_prime \
+  exists_phiIrreducible_evalSymm coeffMap_injective"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+
+
+
+
+theorem phiAtSeed_jq_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) :
+    (phiAtSeed data jq).eval (jqN n) = 0 := by
+  have h := data.eval_eq_zero
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' ?_ ?_
+  · exact RingHom.ext_int _ _
+  · simp [evalAtJ_X]
+
+
+theorem phiAtSeed_jqN_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN M)).eval (jqN (M * n)) = 0 := by
+  have h := phiAtSeed_eval_map data jq (jqN n) (qExpand ℚ M) (phiAtSeed_jq_eval n data)
+  rwa [jqN, qExpand_qExpand] at h
+
+theorem phiAtSeed_iota_eval {K : Type*} [Field K] [Algebra ℚ K] (A : ℕ) [NeZero A] (n : ℕ)
+    [NeZero n]
+    (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (coeffEmb K (qExpand ℚ A (jqN M)))).eval (coeffEmb K (qExpand ℚ A (jqN (M *
+      n)))) = 0 :=
+  phiAtSeed_eval_map data _ _ ((coeffEmb K).comp (qExpand ℚ A)) (phiAtSeed_jqN_eval n data M)
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN \
+  dedekindPsi evalAtJ_X ModularPolynomialData coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  finrank_adjoin_jqN_prime_of_not_mem finrank_adjoin_jqN_eq_of_prime dedekindPsi_prime \
+  exists_phiIrreducible_evalSymm coeffMap_injective"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+theorem qExpand_qTwist_notMem_range_qExpand {r e : ℕ} [NeZero r] [NeZero e]
+    (hre : ¬ ((r : ℤ) ∣ (e : ℤ))) (w : Kˣ) :
+    qExpand K e (qTwist w (coeffEmb K jq)) ∉ (qExpand K r).range := by
+  intro hmem
+  obtain ⟨z, hz⟩ := RingHom.mem_range.mp hmem
+  have h1 : (qExpand K e (qTwist w (coeffEmb K jq))).coeff (-(e : ℤ)) = ((w⁻¹ : Kˣ) : K) := by
+    simpa only [TS_eq_coeffEmb] using TS_coeff_neg e w
+  have h2 : (qExpand K r z).coeff (-(e : ℤ)) = 0 :=
+    qExpand_coeff_of_not_dvd r z (by rwa [dvd_neg])
+  rw [hz, h1] at h2
+  exact (w⁻¹ : Kˣ).ne_zero h2
+
+theorem aeval_intermediateField_eq_zero {F₀ L : Type*} [Field F₀] [Field L] [Algebra F₀ L]
+    {E : IntermediateField F₀ L} {P : Polynomial F₀} {x : E}
+    (h : Polynomial.aeval (E.val x) P = 0) : Polynomial.aeval x P = 0 := by
+  have h1 := Polynomial.aeval_algHom_apply E.val x P
+  rw [h] at h1
+  have h2 : E.val (Polynomial.aeval x P) = E.val 0 := by rw [← h1, map_zero]
+  exact RingHom.injective (E.val : E →+* L) h2
+
+theorem step_contradiction (p r : ℕ) [hpp : Fact (Nat.Prime p)] [hrr : Fact (Nat.Prime r)]
+    (hrp : r ≠ p) (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) (p * r))
+    (data_p : ModularPolynomialData p) (data_r : ModularPolynomialData r)
+    (F : IntermediateField ℚ (LaurentSeries ℚ)) (hj : jq ∈ F)
+    (hpF : jqN p ∉ F) (hrF : jqN r ∉ F)
+    (hmem : jqN r ∈ IntermediateField.adjoin F ({jqN p} : Set (LaurentSeries ℚ))) : False := by
+  have : NeZero (p * r) := ⟨Nat.mul_ne_zero hpp.out.ne_zero hrr.out.ne_zero⟩
+  classical
+  have hdeg := ModularCurve.finrank_adjoin_jqN_prime_of_not_mem F hj p hpF
+  have hjq_coe : algebraMap F (LaurentSeries ℚ) ⟨jq, hj⟩ = jq := rfl
+  have haeval_p : Polynomial.aeval (jqN p) (phiAtSeed data_p (⟨jq, hj⟩ : F)) = 0 := by
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, phiAtSeed_map, hjq_coe]
+    exact phiAtSeed_jq_eval p data_p
+  have hα : IsIntegral F (jqN p) :=
+    ⟨phiAtSeed data_p (⟨jq, hj⟩ : F), phiAtSeed_monic data_p _, by
+      rw [← Polynomial.aeval_def]; exact haeval_p⟩
+  have hmin_natdeg : (minpoly F (jqN p)).natDegree = p + 1 := by
+    rw [← IntermediateField.adjoin.finrank hα]
+    exact hdeg
+  have hPdeg : (phiAtSeed data_p (⟨jq, hj⟩ : F)).natDegree = p + 1 := by
+    rw [phiAtSeed_natDegree, ModularCurve.dedekindPsi_prime hpp.out]
+  have hmin_eq : phiAtSeed data_p (⟨jq, hj⟩ : F) = minpoly F (jqN p) := by
+    apply minpoly.unique_of_degree_le_degree_minpoly _ _ (phiAtSeed_monic data_p _) haeval_p
+    rw [Polynomial.degree_eq_natDegree (phiAtSeed_monic data_p (⟨jq, hj⟩ : F)).ne_zero,
+      Polynomial.degree_eq_natDegree (minpoly.ne_zero hα), hPdeg, hmin_natdeg]
+  let : Algebra F (LaurentSeries K) :=
+    (((coeffEmb K).comp (qExpand ℚ (p * r))).comp (algebraMap F (LaurentSeries ℚ))).toAlgebra
+  have halg : algebraMap F (LaurentSeries K)
+      = ((coeffEmb K).comp (qExpand ℚ (p * r))).comp (algebraMap F (LaurentSeries ℚ)) :=
+    RingHom.algebraMap_toAlgebra _
+  have hmap_min : (minpoly F (jqN p)).map (algebraMap F (LaurentSeries K))
+      = data_p.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+          (qExpand K (p * r) (qTwist ((1 : Kˣ) ^ p) (coeffEmb K jq)))) := by
+    rw [← hmin_eq, halg, ← Polynomial.map_map, phiAtSeed_map, hjq_coe, phiAtSeed_map,
+      RingHom.comp_apply, iota_jq, one_pow, phiAtSeed, TS_eq_coeffEmb]
+  have hpdvd : p ∣ p * r := dvd_mul_right p r
+  have hroots : (minpoly F (jqN p)).aroots (LaurentSeries K)
+      = qExpand K (p * (p * r)) (qTwist ((1 : Kˣ) ^ (p * p)) (coeffEmb K jq)) ::ₘ
+        (Multiset.range p).map
+          (fun b => qExpand K r (qTwist ((1 : Kˣ) * ζ ^ (b * (p * r / p))) (coeffEmb K jq))) := by
+    rw [Polynomial.aroots_def, hmap_min, roots_prime_at_slot (p * r) ζ hζ p hpdvd data_p r 1]
+  have hM_nodup : ((minpoly F (jqN p)).aroots (LaurentSeries K)).Nodup := by
+    rw [hroots]
+    exact roots_prime_at_slot_nodup (p * r) ζ hζ p hpdvd r 1
+  have hM_card : Multiset.card ((minpoly F (jqN p)).aroots (LaurentSeries K)) = p + 1 := by
+    rw [hroots, Multiset.card_cons, Multiset.card_map, Multiset.card_range]
+  obtain ⟨g, hg_deg, hg⟩ := (IntermediateField.adjoin.powerBasis hα).exists_eq_aeval
+    (⟨jqN r, hmem⟩ : IntermediateField.adjoin F ({jqN p} : Set (LaurentSeries ℚ)))
+  rw [IntermediateField.adjoin.powerBasis_gen] at hg
+  rw [IntermediateField.adjoin.powerBasis_dim, hmin_natdeg] at hg_deg
+  have hconst_range : ∀ cf : F, algebraMap F (LaurentSeries K) cf ∈ (qExpand K r).range := by
+    intro cf
+    rw [halg, RingHom.comp_apply, RingHom.comp_apply]
+    refine RingHom.mem_range.mpr ⟨qExpand K p (coeffEmb K (algebraMap F (LaurentSeries ℚ) cf)), ?_⟩
+    rw [qExpand_qExpand, ← coeffEmb_qExpand]
+    exact congrArg (coeffEmb K) (qExpand_congr (Nat.mul_comm r p) _)
+  have hroot_range : ∀ y₀ ∈ (minpoly F (jqN p)).aroots (LaurentSeries K),
+      y₀ ∈ (qExpand K r).range := by
+    intro y₀ hy₀
+    rw [hroots] at hy₀
+    rcases Multiset.mem_cons.mp hy₀ with h | h
+    · subst h
+      refine RingHom.mem_range.mpr
+        ⟨qExpand K (p * p) (qTwist ((1 : Kˣ) ^ (p * p)) (coeffEmb K jq)), ?_⟩
+      rw [qExpand_qExpand]
+      exact qExpand_congr (by ring) _
+    · obtain ⟨b, hb, rfl⟩ := Multiset.mem_map.mp h
+      exact RingHom.mem_range.mpr ⟨qTwist ((1 : Kˣ) * ζ ^ (b * (p * r / p))) (coeffEmb K jq), rfl⟩
+  have hrpZ : ¬ ((r : ℤ) ∣ (p : ℤ)) := by
+    rw [Int.natCast_dvd_natCast]
+    intro hdvd
+    exact hrp ((Nat.prime_dvd_prime_iff_eq hrr.out hpp.out).mp hdvd)
+  have hrdvd : r ∣ p * r := dvd_mul_left r p
+  have hkill : ∀ y : LaurentSeries K,
+      (phiAtSeed data_r (coeffEmb K (qExpand ℚ (p * r) jq))).eval y = 0 →
+      y ∈ (qExpand K r).range → y = coeffEmb K (qExpand ℚ (p * r) (jqN r)) := by
+    intro y hy hyr
+    have hseed : coeffEmb K (qExpand ℚ (p * r) jq)
+        = qExpand K (r * p) (qTwist ((1 : Kˣ) ^ r) (coeffEmb K jq)) := by
+      rw [one_pow, iota_jq, show TS K (p * r) (1 : Kˣ) = TS K (r * p) 1 from
+        TS_congr (Nat.mul_comm p r) 1, TS_eq_coeffEmb]
+    rw [phiAtSeed, hseed] at hy
+    rcases (isRoot_prime_at_slot_iff (p * r) ζ hζ r hrdvd data_r p 1 y).mp hy with h | ⟨c, hc, h⟩
+    · rw [h, one_pow, iota_jqN]
+      suffices TS K (r * (r * p)) 1 = TS K (p * r * r) 1 by
+        simpa only [TS_eq_coeffEmb] using this
+      exact TS_congr (by ring) 1
+    · exfalso
+      rw [h] at hyr
+      exact qExpand_qTwist_notMem_range_qExpand hrpZ _ hyr
+  have hx_root : Polynomial.aeval
+      (⟨jqN r, hmem⟩ : IntermediateField.adjoin F ({jqN p} : Set (LaurentSeries ℚ)))
+      (phiAtSeed data_r (⟨jq, hj⟩ : F)) = 0 := by
+    apply aeval_intermediateField_eq_zero
+    change Polynomial.aeval (jqN r) (phiAtSeed data_r (⟨jq, hj⟩ : F)) = 0
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, phiAtSeed_map, hjq_coe]
+    exact phiAtSeed_jq_eval r data_r
+  have hval_key : ∀ y₀ ∈ (minpoly F (jqN p)).aroots (LaurentSeries K),
+      Polynomial.aeval y₀ g = coeffEmb K (qExpand ℚ (p * r) (jqN r)) := by
+    intro y₀ hy₀
+    obtain ⟨σ, hσ_gen⟩ :
+        ∃ σ : (IntermediateField.adjoin F ({jqN p} : Set (LaurentSeries ℚ))) →ₐ[F] LaurentSeries K,
+          σ (IntermediateField.AdjoinSimple.gen F (jqN p)) = y₀ :=
+      ⟨(IntermediateField.algHomAdjoinIntegralEquiv F hα).symm ⟨y₀, hy₀⟩,
+        IntermediateField.algHomAdjoinIntegralEquiv_symm_apply_gen F hα ⟨y₀, hy₀⟩⟩
+    have hσx_eq : σ ⟨jqN r, hmem⟩ = Polynomial.aeval y₀ g := by
+      rw [hg, ← Polynomial.aeval_algHom_apply, hσ_gen]
+    have hy_root : (phiAtSeed data_r (coeffEmb K (qExpand ℚ (p * r) jq))).eval
+        (σ ⟨jqN r, hmem⟩) = 0 := by
+      have h1 := Polynomial.aeval_algHom_apply σ
+        (⟨jqN r, hmem⟩ : IntermediateField.adjoin F ({jqN p} : Set (LaurentSeries ℚ)))
+        (phiAtSeed data_r (⟨jq, hj⟩ : F))
+      rw [hx_root, map_zero] at h1
+      rw [Polynomial.aeval_def, ← Polynomial.eval_map, halg, ← Polynomial.map_map,
+        phiAtSeed_map, hjq_coe, phiAtSeed_map, RingHom.comp_apply] at h1
+      exact h1
+    have hrange : σ ⟨jqN r, hmem⟩ ∈ (qExpand K r).range := by
+      rw [hσx_eq, Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range]
+      exact sum_mem fun i _ => mul_mem (hconst_range _) (pow_mem (hroot_range y₀ hy₀) i)
+    rw [← hσx_eq]
+    exact hkill _ hy_root hrange
+  have hs_card : ((minpoly F (jqN p)).aroots (LaurentSeries K)).toFinset.card = p + 1 := by
+    rw [Multiset.toFinset_card_of_nodup hM_nodup, hM_card]
+  have hfin : coeffEmb K (qExpand ℚ (p * r) (jqN r)) ∈ (algebraMap F (LaurentSeries K)).range := by
+    refine Polynomial.mem_range_of_eval_eq_const g _
+      ((minpoly F (jqN p)).aroots (LaurentSeries K)).toFinset ?_ ?_
+    · rw [hs_card]
+      exact hg_deg
+    · intro y₀ hy₀
+      exact hval_key y₀ (Multiset.mem_toFinset.mp hy₀)
+  obtain ⟨cf, hcf⟩ := RingHom.mem_range.mp hfin
+  rw [halg, RingHom.comp_apply, RingHom.comp_apply] at hcf
+  have h3 : algebraMap F (LaurentSeries ℚ) cf = jqN r := by
+    have hinj : Function.Injective (coeffEmb K) := by
+      rw [coeffEmb]
+      exact ModularCurve.coeffMap_injective (algebraMap ℚ K).injective
+    exact qExpand_injective (p * r) (hinj hcf)
+  rw [IntermediateField.algebraMap_apply] at h3
+  exact hrF (h3 ▸ cf.2)
+
+theorem jqN_prime_not_mem_adjoin_key (S : Finset ℕ) : (∀ p ∈ S, p.Prime) →
+    ∀ (r : ℕ) [NeZero r], Nat.Prime r → r ∉ S →
+    jqN r ∉ IntermediateField.adjoin ℚ
+      (insert jq {x : LaurentSeries ℚ | ∃ p ∈ S, ∃ _ : NeZero p, x = jqN p}) := by
+  induction S using Finset.induction_on with
+  | empty =>
+      intro _ r _ hr hrS hmem
+      have : Fact (Nat.Prime r) := ⟨hr⟩
+      have hset : (insert jq {x : LaurentSeries ℚ | ∃ p ∈ (∅ : Finset ℕ), ∃ _ : NeZero p, x = jqN
+        p})
+          = ({jq} : Set (LaurentSeries ℚ)) := by
+        ext x
+        simp
+      rw [hset] at hmem
+      have hM3 := ModularCurve.finrank_adjoin_jqN_eq_of_prime r
+      have hbot : IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries
+        ℚ)))
+          ({jqN r} : Set (LaurentSeries ℚ)) = ⊥ := by
+        rw [IntermediateField.adjoin_simple_eq_bot_iff]
+        exact IntermediateField.mem_bot.mpr ⟨⟨jqN r, hmem⟩, rfl⟩
+      rw [hbot, IntermediateField.finrank_bot] at hM3
+      have h2 := hr.two_le
+      omega
+  | insert q T hqT IH =>
+      intro hS' r _ hr hrS' hmem
+      have hq : Nat.Prime q := hS' q (Finset.mem_insert_self q T)
+      have hT : ∀ p ∈ T, p.Prime := fun p hp => hS' p (Finset.mem_insert_of_mem hp)
+      have hrq : r ≠ q := fun h => hrS' (h ▸ Finset.mem_insert_self q T)
+      have hrT : r ∉ T := fun h => hrS' (Finset.mem_insert_of_mem h)
+      have : Fact (Nat.Prime q) := ⟨hq⟩
+      have : Fact (Nat.Prime r) := ⟨hr⟩
+      have hqF : jqN q ∉ IntermediateField.adjoin ℚ
+          (insert jq {x : LaurentSeries ℚ | ∃ p ∈ T, ∃ _ : NeZero p, x = jqN p}) := IH hT q hq hqT
+      have hrF : jqN r ∉ IntermediateField.adjoin ℚ
+          (insert jq {x : LaurentSeries ℚ | ∃ p ∈ T, ∃ _ : NeZero p, x = jqN p}) := IH hT r hr hrT
+      have hj : jq ∈ IntermediateField.adjoin ℚ
+          (insert jq {x : LaurentSeries ℚ | ∃ p ∈ T, ∃ _ : NeZero p, x = jqN p}) :=
+        IntermediateField.subset_adjoin ℚ _ (Set.mem_insert _ _)
+      have hsets : (insert jq {x : LaurentSeries ℚ | ∃ p ∈ insert q T, ∃ _ : NeZero p, x = jqN p})
+          = (insert jq {x : LaurentSeries ℚ | ∃ p ∈ T, ∃ _ : NeZero p, x = jqN p}) ∪ {jqN q} := by
+        ext x
+        simp only [Set.mem_insert_iff, Set.mem_ofPred_eq, Finset.mem_insert, Set.mem_union,
+          Set.mem_singleton_iff]
+        constructor
+        · rintro (rfl | ⟨p', rfl | hp'T, hne, rfl⟩)
+          · exact Or.inl (Or.inl rfl)
+          · exact Or.inr rfl
+          · exact Or.inl (Or.inr ⟨p', hp'T, hne, rfl⟩)
+        · rintro ((rfl | ⟨p', hp'T, hne, rfl⟩) | rfl)
+          · exact Or.inl rfl
+          · exact Or.inr ⟨p', Or.inr hp'T, hne, rfl⟩
+          · exact Or.inr ⟨q, Or.inl rfl, ⟨hq.ne_zero⟩, rfl⟩
+      rw [hsets, ← IntermediateField.adjoin_adjoin_left,
+        IntermediateField.mem_restrictScalars] at hmem
+      obtain ⟨data_q, -, -⟩ := ModularCurve.exists_phiIrreducible_evalSymm q
+      obtain ⟨data_r, -, -⟩ := ModularCurve.exists_phiIrreducible_evalSymm r
+      have : NeZero (q * r) := ⟨Nat.mul_ne_zero hq.ne_zero hr.ne_zero⟩
+      exact step_contradiction q r hrq (cycUnit (q * r)) (cycUnit_spec (q * r)) data_q data_r
+        _ hj hqF hrF hmem
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN \
+  dedekindPsi evalAtJ_X ModularPolynomialData coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  finrank_adjoin_jqN_prime_of_not_mem finrank_adjoin_jqN_eq_of_prime dedekindPsi_prime \
+  exists_phiIrreducible_evalSymm coeffMap_injective"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.jqN_prime_not_mem_adjoin (S : Finset ℕ) (hS : ∀ p ∈ S, p.Prime) (r : ℕ)
+    [hr : Fact (Nat.Prime r)] (hrS : r ∉ S) :
+    jqN r ∉ IntermediateField.adjoin ℚ (insert jq {x : LaurentSeries ℚ | ∃ p ∈ S, ∃ _ : NeZero p, x
+      = jqN p}) :=
+  ModularCurve.W1.jqN_prime_not_mem_adjoin_key S hS r hr.out hrS
+
+end
+
+p2m_open "ModularCurve~coeffEmb_qExpand\
+  " in
+open _root_.P2MW.S_ModularCurve_jqN_prime_not_mem_adjoin.ModularCurve in
+theorem solution (S : Finset ℕ) (hS : ∀ p ∈ S, p.Prime) (r : ℕ) [hr : Fact (Nat.Prime r)]
+    (hrS : r ∉ S) :
+    jqN r ∉ IntermediateField.adjoin ℚ (insert jq {x : LaurentSeries ℚ | ∃ p ∈ S, ∃ _ : NeZero p, x
+      = jqN p}) :=
+  ModularCurve.jqN_prime_not_mem_adjoin S hS r hrS
+
+end S_ModularCurve_jqN_prime_not_mem_adjoin
+end P2MW
+export P2MW.S_ModularCurve_jqN_prime_not_mem_adjoin (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.jqN_prime_not_mem_adjoin (S : Finset ℕ) (hS : ∀ p ∈ S, p.Prime) (r : ℕ)
+    [hr : Fact (Nat.Prime r)] (hrS : r ∉ S) :
+    jqN r ∉ IntermediateField.adjoin ℚ (insert jq {x : LaurentSeries ℚ | ∃ p ∈ S, ∃ _ : NeZero p, x
+      = jqN p}) :=
+  solution S hS r hrS
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqN_prime_not_mem_full.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqN_prime_not_mem_full.lean
new file mode 100644
index 0000000000..97ca16723f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_jqN_prime_not_mem_full.lean
@@ -0,0 +1,1935 @@
+/-
+Based on Prove2Me node ModularCurve.jqN_prime_not_mem_full
+(f53dbbb6-357c-503b-9993-e09764b6d02c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4734660d-014f-5776-b9b9-7096efa42a11
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqN_eq_of_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime_pow
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_mul_of_coprime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration_of_squarefree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration_iff_full_eq
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.NumberTheory.Cyclotomic.PrimitiveRoots
+import Mathlib.FieldTheory.Extension
+import Mathlib.Data.Nat.Factorization.Induction
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+
+/-!
+# Non-membership of j(qᵖ) in the level-M divisor-expansion field
+
+Theorem statement: `ModularCurve.jqN_prime_not_mem_full` (`f53dbbb6-357c-503b-9993-e09764b6d02c`),
+by Claude, 2026-09-05.
+
+Proof: submission `4734660d-014f-5776-b9b9-7096efa42a11`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a nonzero natural number and $p$ a prime not dividing $M$. Work inside the field
+$\mathbb{Q}((q))$ of Laurent series over $\mathbb{Q}$, where `jq` is the series $q^{-1}$ times the
+power series `jNumQ` (the integral numerator series of the $j$-invariant, with coefficients mapped
+into $\mathbb{Q}$), and for a nonzero $N$ the series `jqN N` is the image of `jq` under the ring
+homomorphism `qExpand ℚ N`, which multiplies all exponents by $N$, i.e. the substitution $q \mapsto
+q^N$. Assume that for every nonzero divisor $d$ of $M$ both of the following hold: the degree of
+$\mathbb{Q}(jq)\bigl(\mathtt{jqN } d\bigr)$ over $\mathbb{Q}(jq)$ equals `dedekindPsi d`, defined as
+$\sum_{e \mid d,\ e \text{ squarefree}} d/e$; and the field $\mathbb{Q}(jq, \mathtt{jqN } d)$
+generated over $\mathbb{Q}$ by the two series coincides with the field generated over $\mathbb{Q}$
+by all expansions $\mathtt{jqN } e$ with $e$ a nonzero divisor of $d$. The conclusion is that `jqN
+p`, the series $j(q^p)$, does not lie in the field generated over $\mathbb{Q}$ by the expansions
+$\mathtt{jqN } d$ for the nonzero divisors $d$ of $M$.
+
+This is the base step of the non-membership tower used in the purely algebraic computation of
+$[\mathbb{Q}(j) (j_N) : \mathbb{Q}(j)] = \psi(N)$, equivalently of the irreducibility of the modular
+polynomial $\Phi_N$ over $\mathbb{Q}(j)$ and of the description of the function field of $X_0(N)$.
+It is cited in the inductive construction of irreducible modular polynomial data and in the
+construction of Atkin–Lehner type automorphisms at a prime away from the level.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_jqN_prime_not_mem_full.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 6400000
+
+section privateSection
+
+open ModularCurve W1 PhiGen IntermediateField
+
+noncomputable section
+
+namespace ModularCurve
+
+namespace W1
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+theorem coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb K (qExpand ℚ n x) = qExpand K n (coeffEmb K x) :=
+  coeffMap_qExpand (algebraMap ℚ K) n x
+
+theorem iota_jqN (N d : ℕ) [NeZero N] [NeZero d] :
+    coeffEmb K (qExpand ℚ N (jqN d)) = TS K (N * d) 1 := by
+  rw [jqN, coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem iota_jq (N : ℕ) [NeZero N] : coeffEmb K (qExpand ℚ N jq) = TS K N 1 := by
+  rw [coeffEmb_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_zero_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    conj p ζ (0 : Fin (p + 1)) = TS K (p * p) 1 := by
+  rw [conj_zero, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_succ_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) (b : Fin p) :
+    conj p ζ b.succ = TS K 1 (ζ ^ (b : ℕ)) := by
+  rw [conj_succ, TS_eq_coeffEmb, qExpand_one_apply]
+
+theorem qTwist_iota_of_pow_eq_one (N : ℕ) [NeZero N] (v : Kˣ) (hv : v ^ N = 1) (x : LaurentSeries ℚ)
+    :
+    qTwist v (coeffEmb K (qExpand ℚ N x)) = coeffEmb K (qExpand ℚ N x) := by
+  rw [coeffEmb_qExpand, qTwist_qExpand]
+  have : v ^ (N : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+
+namespace W1
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+omit [Algebra ℚ K] in
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+omit [Algebra ℚ K] in
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+omit [Algebra ℚ K] in
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem phiProd_conj_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    phiProd p (conj p ζ) = (Polynomial.X - Polynomial.C (TS K (p * p) 1)) *
+      ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) := by
+  rw [phiProd, Fin.prod_univ_succ, conj_zero_eq]
+  congr 1
+  rw [← Fin.prod_univ_eq_prod_range (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) p]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [conj_succ_eq]
+
+theorem roots_phiProd_conj (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    (phiProd p (conj p ζ)).roots = TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^
+      b)) := by
+  classical
+  rw [phiProd_conj_eq]
+  have h1 : (Polynomial.X - Polynomial.C (TS K (p * p) 1) : Polynomial (LaurentSeries K)) ≠ 0 :=
+    Polynomial.X_sub_C_ne_zero _
+  have h2 : (∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b)))) ≠ 0 :=
+    Finset.prod_ne_zero_iff.mpr fun b _ => Polynomial.X_sub_C_ne_zero _
+  rw [Polynomial.roots_mul (mul_ne_zero h1 h2), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod,
+    Finset.range_val]
+  have hm : (Multiset.map (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) (Multiset.range
+    p)) =
+      ((Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).map (fun a => Polynomial.X - Polynomial.C
+        a) := by
+    rw [Multiset.map_map]; rfl
+  rw [hm, Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+omit [Algebra ℚ K] in
+theorem roots_phiProd_conj_nodup (p : ℕ) [hp : Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).Nodup := by
+  refine Multiset.nodup_cons.mpr ⟨?_, ?_⟩
+  · intro hmem
+    obtain ⟨b, -, hb⟩ := Multiset.mem_map.mp hmem
+    have := (TS_injective hb).1
+    have h2 := hp.out.two_le
+    nlinarith
+  · refine (Multiset.nodup_range p).map_on fun b hb b' hb' hbb' => ?_
+    rw [Multiset.mem_range] at hb hb'
+    have hu := (TS_injective hbb').2
+    have hζu : IsPrimitiveRoot ζ p := IsPrimitiveRoot.coe_units_iff.mp hζ
+    exact hζu.pow_inj hb hb' hu
+
+theorem exists_isPrimitiveRoot_cyclotomicField (N : ℕ) [NeZero N] :
+    ∃ z : CyclotomicField N ℚ, IsPrimitiveRoot z N := by
+  have : NeZero ((N : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr (NeZero.ne N)⟩
+  have : IsCyclotomicExtension {N} ℚ (CyclotomicField N ℚ) :=
+    CyclotomicField.isCyclotomicExtension N ℚ
+  exact IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField N ℚ) (Set.mem_singleton N)
+    (NeZero.ne N)
+
+def cycUnit (N : ℕ) [NeZero N] : (CyclotomicField N ℚ)ˣ :=
+  ((exists_isPrimitiveRoot_cyclotomicField N).choose_spec.isUnit (NeZero.ne N)).unit
+
+theorem cycUnit_spec (N : ℕ) [NeZero N] :
+    IsPrimitiveRoot ((cycUnit N : (CyclotomicField N ℚ)ˣ) : CyclotomicField N ℚ) N := by
+  rw [cycUnit, IsUnit.unit_spec]
+  exact (exists_isPrimitiveRoot_cyclotomicField N).choose_spec
+
+theorem cycUnit_pow (N : ℕ) [NeZero N] : cycUnit N ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, (cycUnit_spec N).pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+
+namespace W1
+
+variable {K : Type*} [Field K]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+
+namespace W1
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem prod_form_ne_zero (N : ℕ) (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e]
+    (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K
+            jq)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+          (Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u,
+    Polynomial.roots_mul (prod_form_ne_zero N ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p)))
+    (coeffEmb K jq))))
+        = ((Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+        (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+        (Multiset.range p).map
+          (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).Nodup := by
+  have hζp : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := isPrimitiveRoot_pow_div hζ hpN
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h := (TS_injective (K := K) (e := e) (e' := p * (p * e))
+      (u := u * ζ ^ (b * (N / p))) (u' := u ^ (p * p))
+      (by simpa only [TS_eq_coeffEmb] using heq)).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e)
+      (u := u * ζ ^ (b * (N / p))) (u' := u * ζ ^ (b' * (N / p)))
+      (by simpa only [TS_eq_coeffEmb] using heq)).2
+    have h2 : ζ ^ (b * (N / p)) = ζ ^ (b' * (N / p)) := mul_left_cancel h
+    have h3 : (ζ ^ (N / p)) ^ b = (ζ ^ (N / p)) ^ b' := by
+      rw [← pow_mul, ← pow_mul, Nat.mul_comm (N / p) b, Nat.mul_comm (N / p) b']
+      exact h2
+    have h4 : ((ζ ^ (N / p) : Kˣ) : K) ^ b = ((ζ ^ (N / p) : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h3]
+    exact hζp.pow_inj hb hb' h4
+
+theorem roots_prime_at_slot_roots_nodup (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots.Nodup := by
+  rw [roots_prime_at_slot N ζ hζ p hpN data e u]
+  exact roots_prime_at_slot_nodup N ζ hζ p hpN e u
+
+theorem isRoot_prime_at_slot_iff (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u]
+    exact prod_form_ne_zero N ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot N ζ hζ p hpN data e u,
+    Multiset.mem_cons, Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+end ModularCurve.W1
+
+namespace ModularCurve
+
+namespace W1
+
+
+
+
+
+theorem phiAtSeed_jq_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) :
+    (phiAtSeed data jq).eval (jqN n) = 0 := by
+  have h := data.eval_eq_zero
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' ?_ ?_
+  · exact RingHom.ext_int _ _
+  · simp [evalAtJ_X]
+
+
+theorem phiAtSeed_jqN_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN M)).eval (jqN (M * n)) = 0 := by
+  have h := phiAtSeed_eval_map data jq (jqN n) (qExpand ℚ M) (phiAtSeed_jq_eval n data)
+  rwa [jqN, qExpand_qExpand] at h
+
+theorem phiAtSeed_iota_eval {K : Type*} [Field K] [Algebra ℚ K] (A : ℕ) [NeZero A] (n : ℕ)
+    [NeZero n]
+    (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (coeffEmb K (qExpand ℚ A (jqN M)))).eval (coeffEmb K (qExpand ℚ A (jqN (M *
+      n)))) = 0 :=
+  phiAtSeed_eval_map data _ _ ((coeffEmb K).comp (qExpand ℚ A)) (phiAtSeed_jqN_eval n data M)
+
+end ModularCurve.W1
+
+namespace ModularCurve
+
+namespace W1
+
+private def slotAt (n d : ℕ) : ℕ :=
+  ((Finset.range d).filter fun b => Nat.gcd (Nat.gcd (n / d) b) d = 1).card
+
+private def slots (n : ℕ) : ℕ := ∑ d ∈ n.divisors, slotAt n d
+
+private theorem slotCond_eq (x d b : ℕ) :
+    Nat.gcd (Nat.gcd x b) d = Nat.gcd (Nat.gcd x d) b := by
+  rw [Nat.gcd_assoc, Nat.gcd_comm b d, ← Nat.gcd_assoc]
+
+private theorem slotCond_iff (x d b : ℕ) :
+    Nat.gcd (Nat.gcd x b) d = 1 ↔ Nat.Coprime (Nat.gcd x d) b := by
+  rw [slotCond_eq]
+
+private theorem gcd_eq_of_modEq {a b n : ℕ} (h : a ≡ b [MOD n]) :
+    Nat.gcd n a = Nat.gcd n b := by
+  have h' : a % n = b % n := h
+  rw [Nat.gcd_rec n a, Nat.gcd_rec n b, h']
+
+private theorem slotCond_mod_iff (x d b : ℕ) :
+    Nat.Coprime (Nat.gcd x d) (b % d) ↔ Nat.Coprime (Nat.gcd x d) b := by
+  unfold Nat.Coprime
+  rw [gcd_eq_of_modEq ((Nat.mod_modEq b d).of_dvd (Nat.gcd_dvd_right x d))]
+
+private theorem slotAt_one (n : ℕ) : slotAt n 1 = 1 := by
+  unfold slotAt
+  simp [Nat.gcd_one_right]
+
+private theorem slotAt_self (n : ℕ) (hn : 0 < n) : slotAt n n = n := by
+  unfold slotAt
+  simp [Nat.div_self hn, Nat.gcd_one_left]
+
+private theorem slotAt_prime_pow_mid {p : ℕ} (hp : p.Prime) {i k : ℕ} (hi0 : 0 < i)
+    (hik : i < k) : slotAt (p ^ k) (p ^ i) = Nat.totient (p ^ i) := by
+  unfold slotAt
+  rw [Nat.totient_eq_card_coprime]
+  congr 1
+  refine Finset.filter_congr fun b _ => ?_
+  rw [slotCond_iff]
+  constructor
+  · intro h
+    have hpg : p ∣ Nat.gcd (p ^ k / p ^ i) (p ^ i) := by
+      refine Nat.dvd_gcd ?_ (dvd_pow_self p hi0.ne')
+      rw [Nat.pow_div hik.le hp.pos]
+      exact dvd_pow_self p (by omega)
+    exact Nat.Coprime.pow_left i (Nat.Coprime.coprime_dvd_left hpg h)
+  · intro h
+    exact Nat.Coprime.coprime_dvd_left (Nat.gcd_dvd_right _ _) h
+
+private theorem slots_prime_pow {p : ℕ} (hp : p.Prime) (k : ℕ) :
+    slots (p ^ (k + 1)) = p ^ (k + 1) + p ^ k := by
+  unfold slots
+  rw [Nat.sum_divisors_prime_pow hp, Finset.sum_range_succ]
+  have hrest : ∀ x ∈ Finset.range (k + 1),
+      slotAt (p ^ (k + 1)) (p ^ x) = Nat.totient (p ^ x) := by
+    intro x hx
+    rcases Nat.eq_zero_or_pos x with rfl | hx0
+    · rw [pow_zero, slotAt_one, Nat.totient_one]
+    · exact slotAt_prime_pow_mid hp hx0 (Finset.mem_range.mp hx)
+  rw [Finset.sum_congr rfl hrest, slotAt_self _ (pow_pos hp.pos _),
+    ← Nat.sum_divisors_prime_pow (f := Nat.totient) hp, Nat.sum_totient, Nat.add_comm]
+
+private theorem dedekindPsi_prime_pow' {p : ℕ} (hp : p.Prime) (k : ℕ) :
+    ModularCurve.dedekindPsi (p ^ (k + 1)) = p ^ (k + 1) + p ^ k := by
+  unfold ModularCurve.dedekindPsi
+  have hfil : Finset.filter (fun d => Squarefree d) (p ^ (k + 1)).divisors = {1, p} := by
+    ext x
+    simp only [Finset.mem_filter, Nat.mem_divisors_prime_pow hp, Finset.mem_insert,
+      Finset.mem_singleton]
+    constructor
+    · rintro ⟨⟨j, -, rfl⟩, hsq⟩
+      rcases Nat.eq_zero_or_pos j with rfl | hj0
+      · exact Or.inl (pow_zero p)
+      · have hj1 : j = 1 := ((Nat.squarefree_pow_iff hp.ne_one hj0.ne').mp hsq).2
+        subst hj1
+        exact Or.inr (pow_one p)
+    · rintro (rfl | rfl)
+      · exact ⟨⟨0, Nat.zero_le _, (pow_zero p).symm⟩, squarefree_one⟩
+      · exact ⟨⟨1, by omega, (pow_one _).symm⟩, hp.prime.squarefree⟩
+  rw [hfil, Finset.sum_pair hp.one_lt.ne, Nat.div_one, pow_succ,
+    Nat.mul_div_cancel _ hp.pos]
+
+private theorem slotAt_mul (M M' d₁ d₂ : ℕ) (hM : M ≠ 0) (hM' : M' ≠ 0)
+    (hco : Nat.Coprime M M') (hd₁ : d₁ ∣ M) (hd₂ : d₂ ∣ M') :
+    slotAt (M * M') (d₁ * d₂) = slotAt M d₁ * slotAt M' d₂ := by
+  have hd₁0 : 0 < d₁ :=
+    Nat.pos_of_ne_zero (by rintro rfl; exact hM (Nat.eq_zero_of_zero_dvd hd₁))
+  have hd₂0 : 0 < d₂ :=
+    Nat.pos_of_ne_zero (by rintro rfl; exact hM' (Nat.eq_zero_of_zero_dvd hd₂))
+  have hcod : Nat.Coprime d₁ d₂ :=
+    Nat.Coprime.coprime_dvd_left hd₁ (Nat.Coprime.coprime_dvd_right hd₂ hco)
+  have hxM : M / d₁ ∣ M := ⟨d₁, (Nat.div_mul_cancel hd₁).symm⟩
+  have hyM' : M' / d₂ ∣ M' := ⟨d₂, (Nat.div_mul_cancel hd₂).symm⟩
+  have hxy : (M * M') / (d₁ * d₂) = (M / d₁) * (M' / d₂) :=
+    (Nat.div_mul_div_comm hd₁ hd₂).symm
+  have hyd₁ : Nat.Coprime (M' / d₂) d₁ :=
+    Nat.Coprime.coprime_dvd_left hyM' (Nat.Coprime.coprime_dvd_right hd₁ hco.symm)
+  have hxd₂ : Nat.Coprime (M / d₁) d₂ :=
+    Nat.Coprime.coprime_dvd_left hxM (Nat.Coprime.coprime_dvd_right hd₂ hco)
+  have hg₁g : Nat.gcd (M / d₁) d₁ ∣ Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) := by
+    rw [hxy]
+    exact Nat.dvd_gcd ((Nat.gcd_dvd_left _ _).mul_right _) ((Nat.gcd_dvd_right _ _).mul_right _)
+  have hg₂g : Nat.gcd (M' / d₂) d₂ ∣ Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) := by
+    rw [hxy]
+    exact Nat.dvd_gcd ((Nat.gcd_dvd_left _ _).mul_left _) ((Nat.gcd_dvd_right _ _).mul_left _)
+  have hgg : Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) ∣
+      Nat.gcd (M / d₁) d₁ * Nat.gcd (M' / d₂) d₂ := by
+    have hgdd : Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) ∣ d₁ * d₂ := Nat.gcd_dvd_right _ _
+    have hgxy : Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) ∣ (M / d₁) * (M' / d₂) := by
+      rw [← hxy]
+      exact Nat.gcd_dvd_left _ _
+    have hgyx : Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) ∣ (M' / d₂) * (M / d₁) :=
+      hgxy.trans (dvd_of_eq (Nat.mul_comm (M / d₁) (M' / d₂)))
+    have hsplit : Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂)) d₁ *
+        Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂)) d₂ =
+        Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) :=
+      (Nat.gcd_mul_gcd_eq_iff_dvd_mul_of_coprime hcod).mpr hgdd
+    rw [← hsplit]
+    refine Nat.mul_dvd_mul ?_ ?_
+    · refine Nat.dvd_gcd ?_ (Nat.gcd_dvd_right _ d₁)
+      have h2 : Nat.Coprime (Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂)) d₁)
+          (M' / d₂) := Nat.Coprime.coprime_dvd_left (Nat.gcd_dvd_right _ d₁) hyd₁.symm
+      exact h2.dvd_of_dvd_mul_right ((Nat.gcd_dvd_left _ d₁).trans hgxy)
+    · refine Nat.dvd_gcd ?_ (Nat.gcd_dvd_right _ d₂)
+      have h2 : Nat.Coprime (Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂)) d₂)
+          (M / d₁) := Nat.Coprime.coprime_dvd_left (Nat.gcd_dvd_right _ d₂) hxd₂.symm
+      exact h2.dvd_of_dvd_mul_right ((Nat.gcd_dvd_left _ d₂).trans hgyx)
+  have hfwd : ∀ b : ℕ, Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) b) (d₁ * d₂) = 1 →
+      Nat.gcd (Nat.gcd (M / d₁) (b % d₁)) d₁ = 1 ∧
+        Nat.gcd (Nat.gcd (M' / d₂) (b % d₂)) d₂ = 1 := by
+    intro b hb
+    rw [slotCond_iff] at hb
+    constructor
+    · rw [slotCond_iff, slotCond_mod_iff]
+      exact Nat.Coprime.coprime_dvd_left hg₁g hb
+    · rw [slotCond_iff, slotCond_mod_iff]
+      exact Nat.Coprime.coprime_dvd_left hg₂g hb
+  have hbwd : ∀ b₁ b₂ k : ℕ, Nat.gcd (Nat.gcd (M / d₁) b₁) d₁ = 1 →
+      Nat.gcd (Nat.gcd (M' / d₂) b₂) d₂ = 1 → k ≡ b₁ [MOD d₁] → k ≡ b₂ [MOD d₂] →
+      Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) k) (d₁ * d₂) = 1 := by
+    intro b₁ b₂ k h₁ h₂ hk₁ hk₂
+    rw [slotCond_iff] at h₁ h₂ ⊢
+    have hc₁ : Nat.Coprime (Nat.gcd (M / d₁) d₁) k := by
+      unfold Nat.Coprime
+      rw [gcd_eq_of_modEq (hk₁.of_dvd (Nat.gcd_dvd_right (M / d₁) d₁))]
+      exact h₁
+    have hc₂ : Nat.Coprime (Nat.gcd (M' / d₂) d₂) k := by
+      unfold Nat.Coprime
+      rw [gcd_eq_of_modEq (hk₂.of_dvd (Nat.gcd_dvd_right (M' / d₂) d₂))]
+      exact h₂
+    exact Nat.Coprime.coprime_dvd_left hgg (Nat.coprime_mul_iff_left.mpr ⟨hc₁, hc₂⟩)
+  unfold slotAt
+  rw [← Finset.card_product]
+  refine Finset.card_bij' (fun b _ => (b % d₁, b % d₂))
+    (fun q _ => (Nat.chineseRemainder hcod q.1 q.2 : ℕ)) ?_ ?_ ?_ ?_
+  · intro b hb
+    obtain ⟨hbr, hbc⟩ := Finset.mem_filter.mp hb
+    obtain ⟨h₁, h₂⟩ := hfwd b hbc
+    exact Finset.mem_product.mpr
+      ⟨Finset.mem_filter.mpr ⟨Finset.mem_range.mpr (Nat.mod_lt b hd₁0), h₁⟩,
+        Finset.mem_filter.mpr ⟨Finset.mem_range.mpr (Nat.mod_lt b hd₂0), h₂⟩⟩
+  · intro q hq
+    obtain ⟨hq₁, hq₂⟩ := Finset.mem_product.mp hq
+    have hcrt := (Nat.chineseRemainder hcod q.1 q.2).prop
+    refine Finset.mem_filter.mpr ⟨Finset.mem_range.mpr
+      (Nat.chineseRemainder_lt_mul hcod q.1 q.2 hd₁0.ne' hd₂0.ne'), ?_⟩
+    exact hbwd q.1 q.2 _ (Finset.mem_filter.mp hq₁).2 (Finset.mem_filter.mp hq₂).2
+      hcrt.1 hcrt.2
+  · intro b hb
+    have hb' : b < d₁ * d₂ := Finset.mem_range.mp (Finset.mem_filter.mp hb).1
+    have hcrt := (Nat.chineseRemainder hcod (b % d₁) (b % d₂)).prop
+    have h₁ : (Nat.chineseRemainder hcod (b % d₁) (b % d₂) : ℕ) ≡ b [MOD d₁] :=
+      hcrt.1.trans (Nat.mod_modEq b d₁)
+    have h₂ : (Nat.chineseRemainder hcod (b % d₁) (b % d₂) : ℕ) ≡ b [MOD d₂] :=
+      hcrt.2.trans (Nat.mod_modEq b d₂)
+    exact ((Nat.modEq_and_modEq_iff_modEq_mul hcod).mp ⟨h₁, h₂⟩).eq_of_lt_of_lt
+      (Nat.chineseRemainder_lt_mul hcod _ _ hd₁0.ne' hd₂0.ne') hb'
+  · intro q hq
+    obtain ⟨hq₁, hq₂⟩ := Finset.mem_product.mp hq
+    have hb₁ : q.1 < d₁ := Finset.mem_range.mp (Finset.mem_filter.mp hq₁).1
+    have hb₂ : q.2 < d₂ := Finset.mem_range.mp (Finset.mem_filter.mp hq₂).1
+    have hcrt := (Nat.chineseRemainder hcod q.1 q.2).prop
+    have h₁ : (Nat.chineseRemainder hcod q.1 q.2 : ℕ) % d₁ = q.1 := by
+      have h' : (Nat.chineseRemainder hcod q.1 q.2 : ℕ) % d₁ = q.1 % d₁ := hcrt.1
+      rw [h', Nat.mod_eq_of_lt hb₁]
+    have h₂ : (Nat.chineseRemainder hcod q.1 q.2 : ℕ) % d₂ = q.2 := by
+      have h' : (Nat.chineseRemainder hcod q.1 q.2 : ℕ) % d₂ = q.2 % d₂ := hcrt.2
+      rw [h', Nat.mod_eq_of_lt hb₂]
+    exact Prod.ext h₁ h₂
+
+private theorem gcd_mul_left_of_dvd (M M' : ℕ) (hco : Nat.Coprime M M') {e₁ e₂ : ℕ}
+    (he₁ : e₁ ∣ M) (he₂ : e₂ ∣ M') : Nat.gcd (e₁ * e₂) M = e₁ := by
+  refine Nat.dvd_antisymm ?_ (Nat.dvd_gcd (dvd_mul_right e₁ e₂) he₁)
+  have hc : Nat.Coprime (Nat.gcd (e₁ * e₂) M) e₂ :=
+    Nat.Coprime.coprime_dvd_left (Nat.gcd_dvd_right _ _)
+      (Nat.Coprime.coprime_dvd_right he₂ hco)
+  exact hc.dvd_of_dvd_mul_right (Nat.gcd_dvd_left _ _)
+
+private theorem gcd_mul_right_of_dvd (M M' : ℕ) (hco : Nat.Coprime M M') {e₁ e₂ : ℕ}
+    (he₁ : e₁ ∣ M) (he₂ : e₂ ∣ M') : Nat.gcd (e₁ * e₂) M' = e₂ := by
+  refine Nat.dvd_antisymm ?_ (Nat.dvd_gcd (dvd_mul_left e₂ e₁) he₂)
+  have hc : Nat.Coprime (Nat.gcd (e₁ * e₂) M') e₁ :=
+    Nat.Coprime.coprime_dvd_left (Nat.gcd_dvd_right _ _)
+      (Nat.Coprime.coprime_dvd_right he₁ hco.symm)
+  have h1 : Nat.gcd (e₁ * e₂) M' ∣ e₂ * e₁ :=
+    (Nat.gcd_dvd_left (e₁ * e₂) M').trans (dvd_of_eq (Nat.mul_comm e₁ e₂))
+  exact hc.dvd_of_dvd_mul_right h1
+
+private theorem slots_mul (M M' : ℕ) (hM : M ≠ 0) (hM' : M' ≠ 0)
+    (hco : Nat.Coprime M M') : slots (M * M') = slots M * slots M' := by
+  unfold slots
+  rw [Finset.sum_mul_sum, ← Finset.sum_product']
+  refine Finset.sum_bij' (fun d _ => (Nat.gcd d M, Nat.gcd d M')) (fun q _ => q.1 * q.2)
+    ?_ ?_ ?_ ?_ ?_
+  · intro d hd
+    exact Finset.mem_product.mpr
+      ⟨Nat.mem_divisors.mpr ⟨Nat.gcd_dvd_right d M, hM⟩,
+        Nat.mem_divisors.mpr ⟨Nat.gcd_dvd_right d M', hM'⟩⟩
+  · intro q hq
+    obtain ⟨hq₁, hq₂⟩ := Finset.mem_product.mp hq
+    exact Nat.mem_divisors.mpr
+      ⟨Nat.mul_dvd_mul (Nat.mem_divisors.mp hq₁).1 (Nat.mem_divisors.mp hq₂).1,
+        Nat.mul_ne_zero hM hM'⟩
+  · intro d hd
+    exact (Nat.gcd_mul_gcd_eq_iff_dvd_mul_of_coprime hco).mpr (Nat.mem_divisors.mp hd).1
+  · intro q hq
+    obtain ⟨hq₁, hq₂⟩ := Finset.mem_product.mp hq
+    exact Prod.ext
+      (gcd_mul_left_of_dvd M M' hco (Nat.mem_divisors.mp hq₁).1 (Nat.mem_divisors.mp hq₂).1)
+      (gcd_mul_right_of_dvd M M' hco (Nat.mem_divisors.mp hq₁).1 (Nat.mem_divisors.mp hq₂).1)
+  · intro d hd
+    have hsplit : Nat.gcd d M * Nat.gcd d M' = d :=
+      (Nat.gcd_mul_gcd_eq_iff_dvd_mul_of_coprime hco).mpr (Nat.mem_divisors.mp hd).1
+    conv_lhs => rw [← hsplit]
+    exact slotAt_mul M M' (Nat.gcd d M) (Nat.gcd d M') hM hM' hco
+      (Nat.gcd_dvd_right d M) (Nat.gcd_dvd_right d M')
+
+private theorem slots_eq_dedekindPsi : ∀ n : ℕ, n ≠ 0 → slots n = ModularCurve.dedekindPsi n := by
+  intro n
+  induction n using Nat.recOnPosPrimePosCoprime with
+  | prime_pow p k hp hk =>
+    intro _
+    obtain ⟨j, rfl⟩ : ∃ j, k = j + 1 := ⟨k - 1, by omega⟩
+    rw [slots_prime_pow hp j, dedekindPsi_prime_pow' hp j]
+  | zero => exact fun h0 => absurd rfl h0
+  | one =>
+    intro _
+    rw [ModularCurve.dedekindPsi_one]
+    unfold slots
+    rw [Nat.divisors_one, Finset.sum_singleton]
+    exact slotAt_one 1
+  | coprime a b ha hb hab iha ihb =>
+    intro _
+    rw [slots_mul a b (by omega) (by omega) hab, iha (by omega), ihb (by omega),
+      ModularCurve.dedekindPsi_mul_of_coprime a b hab]
+
+private theorem dedekindPsi_pos {n : ℕ} (hn : n ≠ 0) : 0 < ModularCurve.dedekindPsi n := by
+  have h1 : (1 : ℕ) ∈ n.divisors.filter (fun d => Squarefree d) :=
+    Finset.mem_filter.mpr ⟨Nat.one_mem_divisors.mpr hn, squarefree_one⟩
+  have h2 : n / 1 ≤ ∑ d ∈ n.divisors with Squarefree d, n / d :=
+    Finset.single_le_sum (f := fun d => n / d) (fun i _ => Nat.zero_le _) h1
+  rw [Nat.div_one] at h2
+  exact lt_of_lt_of_le (Nat.pos_of_ne_zero hn) h2
+
+private theorem dedekindPsi_prime (p : ℕ) (hp : p.Prime) :
+    ModularCurve.dedekindPsi p = p + 1 := by
+  have h1 := ModularCurve.dedekindPsi_prime_pow p 1 hp one_ne_zero
+  rw [pow_one] at h1
+  rw [h1]
+  norm_num
+
+private theorem dedekindPsi_mul_prime_not_dvd {m p : ℕ} (hp : p.Prime) (hpm : ¬ p ∣ m) :
+    ModularCurve.dedekindPsi (m * p) = ModularCurve.dedekindPsi m * (p + 1) := by
+  have hco : Nat.Coprime m p := ((Nat.Prime.coprime_iff_not_dvd hp).mpr hpm).symm
+  rw [ModularCurve.dedekindPsi_mul_of_coprime m p hco, dedekindPsi_prime p hp]
+
+private theorem dedekindPsi_mul_prime_dvd {m p : ℕ} (hm : m ≠ 0) (hp : p.Prime)
+    (hpm : p ∣ m) : ModularCurve.dedekindPsi (m * p) = ModularCurve.dedekindPsi m * p := by
+  obtain ⟨k, u, hpu, hmu⟩ := Nat.exists_eq_pow_mul_and_not_dvd hm p hp.ne_one
+  obtain ⟨k', rfl⟩ : ∃ k', k = k' + 1 := by
+    rcases k with - | k'
+    · exfalso
+      rw [hmu, pow_zero, one_mul] at hpm
+      exact hpu hpm
+    · exact ⟨k', rfl⟩
+  subst hmu
+  have hcou : ∀ j : ℕ, j ≠ 0 → Nat.Coprime (p ^ j) u :=
+    fun j _ => Nat.Coprime.pow_left j ((Nat.Prime.coprime_iff_not_dvd hp).mpr hpu)
+  have h1 : p ^ (k' + 1) * u * p = p ^ (k' + 2) * u := by ring
+  rw [h1, ModularCurve.dedekindPsi_mul_of_coprime _ u (hcou _ (Nat.succ_ne_zero _)),
+    ModularCurve.dedekindPsi_mul_of_coprime _ u (hcou _ (Nat.succ_ne_zero _)),
+    ModularCurve.dedekindPsi_prime_pow p (k' + 2) hp (Nat.succ_ne_zero _),
+    ModularCurve.dedekindPsi_prime_pow p (k' + 1) hp (Nat.succ_ne_zero _)]
+  have h2 : k' + 2 - 1 = k' + 1 := rfl
+  have h3 : k' + 1 - 1 = k' := rfl
+  rw [h2, h3]
+  ring
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private def sv (K : Type*) [Field K] [Algebra ℚ K] (ζ : Kˣ) (a b : ℕ) : LaurentSeries K :=
+  if h : a = 0 then 0 else
+    letI : NeZero a := ⟨h⟩
+    qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq))
+
+private theorem sv_eq (ζ : Kˣ) (a b : ℕ) [NeZero a] :
+    sv K ζ a b = qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)) := by
+  unfold sv
+  rw [dite_eq_right (NeZero.ne a)]
+
+private theorem sv_eq_TS (ζ : Kˣ) (a b : ℕ) [NeZero a] :
+    sv K ζ a b = TS K (a * a) (ζ ^ (b * a)) := by
+  simpa only [TS_eq_coeffEmb] using sv_eq ζ a b
+
+omit [Algebra ℚ K] in
+private theorem TS_congr' {e e' : ℕ} [NeZero e] [NeZero e'] {u u' : Kˣ} (he : e = e')
+    (hu : u = u') : TS K e u = TS K e' u' := by
+  subst he
+  rw [hu]
+
+private theorem sv_inj {M : ℕ} {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) M)
+    {a b a' b' : ℕ} (ha0 : a ≠ 0) (ha0' : a' ≠ 0) (hb : b * a < M) (hb' : b' * a' < M)
+    (h : sv K ζ a b = sv K ζ a' b') : a = a' ∧ b = b' := by
+  have : NeZero a := ⟨ha0⟩
+  have : NeZero a' := ⟨ha0'⟩
+  rw [sv_eq_TS, sv_eq_TS] at h
+  obtain ⟨he, hu⟩ := TS_injective h
+  have haa : a = a' := (mul_self_inj (Nat.zero_le a) (Nat.zero_le a')).mp he
+  subst haa
+  refine ⟨rfl, ?_⟩
+  have hv : ((ζ : K)) ^ (b * a) = ((ζ : K)) ^ (b' * a) := by
+    have h1 := congrArg Units.val hu
+    rwa [Units.val_pow_eq_pow_val, Units.val_pow_eq_pow_val] at h1
+  have h2 : b * a = b' * a := hζ.pow_inj hb hb' hv
+  exact Nat.eq_of_mul_eq_mul_right (Nat.pos_of_ne_zero ha0) h2
+
+private theorem jqN_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) : jqN n = jqN m := by
+  subst h
+  rfl
+
+private theorem sv_top (M : ℕ) [NeZero M] (ζ : Kˣ) :
+    sv K ζ M 0 = coeffEmb K (qExpand ℚ M (jqN M)) := by
+  rw [sv_eq_TS, iota_jqN M M]
+  exact TS_congr' rfl (by rw [zero_mul, pow_zero])
+
+private theorem aeval_intermediateField_eq_zero {F₀ L : Type*} [Field F₀] [Field L]
+    [Algebra F₀ L] {E : IntermediateField F₀ L} {P : Polynomial F₀} {x : E}
+    (h : Polynomial.aeval (E.val x) P = 0) : Polynomial.aeval x P = 0 := by
+  have h1 := Polynomial.aeval_algHom_apply E.val x P
+  rw [h] at h1
+  have h2 : E.val (Polynomial.aeval x P) = E.val 0 := by rw [← h1, map_zero]
+  exact RingHom.injective (E.val : E →+* L) h2
+
+private theorem phiAtSeed_eval_of_injective {R S : Type*} [CommRing R] [CommRing S] {n : ℕ}
+    [NeZero n] (data : ModularPolynomialData n) (x y : R) (f : R →+* S)
+    (hf : Function.Injective f) (h : (phiAtSeed data (f x)).eval (f y) = 0) :
+    (phiAtSeed data x).eval y = 0 := by
+  rw [← phiAtSeed_map, Polynomial.eval_map, Polynomial.eval₂_hom] at h
+  exact (injective_iff_map_eq_zero f).mp hf _ h
+
+private theorem phiAtSeed_eval_symm {n : ℕ} [NeZero n] (data : ModularPolynomialData n)
+    (hsym : EvalSymm data.Φ) (x y : LaurentSeries ℚ) :
+    (phiAtSeed data x).eval y = (phiAtSeed data y).eval x := by
+  have hhom : ∀ z : LaurentSeries ℚ,
+      Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries ℚ)) z
+        = (Polynomial.aeval (R := ℤ) z).toRingHom := by
+    intro z
+    refine Polynomial.ringHom_ext' ?_ ?_
+    · exact RingHom.ext_int _ _
+    · simp [Polynomial.coe_eval₂RingHom]
+  rw [phiAtSeed, phiAtSeed, Polynomial.eval_map, Polynomial.eval_map, hhom x, hhom y]
+  exact hsym x y
+
+private theorem mem_adjoin_jqN_of_mem_mff {M : ℕ} [NeZero M] {x : LaurentSeries ℚ}
+    (hx : x ∈ modularFunctionField M) :
+    x ∈ adjoin ℚ⟮jq⟯ ({jqN M} : Set (LaurentSeries ℚ)) := by
+  have hle : ℚ⟮jq⟯ ≤
+      adjoin ℚ ({jq, qExpand ℚ M jq} : Set (LaurentSeries ℚ)) :=
+    adjoin.mono ℚ _ _
+      (Set.singleton_subset_iff.mpr (Set.mem_insert _ _))
+  have hE := IntermediateField.extendScalars_adjoin hle
+  have hcollapse : adjoin ℚ⟮jq⟯
+      ({jq, qExpand ℚ M jq} : Set (LaurentSeries ℚ))
+      = adjoin ℚ⟮jq⟯ ({jqN M} : Set (LaurentSeries ℚ)) := by
+    refine le_antisymm (adjoin_le_iff.mpr ?_)
+      (adjoin.mono _ _ _ ?_)
+    · rintro z (rfl | rfl)
+      · exact (adjoin ℚ⟮jq⟯ _).algebraMap_mem jGen
+      · exact IntermediateField.subset_adjoin ℚ⟮jq⟯ _ rfl
+    · exact Set.singleton_subset_iff.mpr (Set.mem_insert_of_mem _ rfl)
+  rw [modularFunctionField] at hx
+  have h2 : x ∈ IntermediateField.extendScalars hle :=
+    (IntermediateField.mem_extendScalars _).mpr hx
+  rw [hE, hcollapse] at h2
+  exact h2
+
+private theorem qExpand_congr {R : Type*} [CommRing R] {n m : ℕ} [NeZero n] [NeZero m]
+    (h : n = m) (x : LaurentSeries R) : qExpand R n x = qExpand R m x := by
+  subst h
+  rfl
+
+private theorem mem_range_of_eval_eq_const {F L : Type*} [Field F] [Field L] [Algebra F L]
+    (g : Polynomial F) (x : L) (s : Finset L) (hcard : g.natDegree < s.card)
+    (hval : ∀ y ∈ s, Polynomial.aeval y g = x) : x ∈ (algebraMap F L).range := by
+  classical
+  set i := algebraMap F L
+  set Q : Polynomial L := g.map i - Polynomial.C x with hQ
+  have hQdeg : Q.natDegree ≤ g.natDegree := by
+    refine (Polynomial.natDegree_sub_le _ _).trans ?_
+    rw [Polynomial.natDegree_map, Polynomial.natDegree_C, max_eq_left (Nat.zero_le _)]
+  have hQ0 : Q = 0 := by
+    refine Polynomial.eq_zero_of_natDegree_lt_card_of_eval_eq_zero' Q s (fun y hy => ?_)
+      (hQdeg.trans_lt hcard)
+    rw [hQ, Polynomial.eval_sub, Polynomial.eval_C, Polynomial.eval_map_algebraMap,
+      hval y hy, sub_self]
+  have hconst : g.map i = Polynomial.C x := sub_eq_zero.mp hQ0
+  refine ⟨g.coeff 0, ?_⟩
+  have h2 := congrArg (fun P : Polynomial L => P.coeff 0) hconst
+  simpa only [Polynomial.coeff_map, Polynomial.coeff_C_zero] using h2
+
+private theorem tight_one : Module.finrank ℚ⟮jq⟯
+    (adjoin ℚ⟮jq⟯ ({jqN 1} : Set (LaurentSeries ℚ)))
+    = ModularCurve.dedekindPsi 1 := by
+  have h1 : jqN 1 = jq := by rw [jqN, qExpand_one_apply]
+  rw [h1, ModularCurve.dedekindPsi_one]
+  have h2 : adjoin ℚ⟮jq⟯ ({jq} : Set (LaurentSeries ℚ))
+      = (⊥ : IntermediateField ℚ⟮jq⟯ (LaurentSeries ℚ)) := by
+    rw [adjoin_simple_eq_bot_iff, IntermediateField.mem_bot]
+    exact ⟨jGen, rfl⟩
+  rw [h2]
+  exact IntermediateField.finrank_bot
+
+private theorem gen_one : modularFunctionField 1 = modularFunctionFieldFull 1 := by
+  refine le_antisymm (modularFunctionField_le_full 1) ?_
+  rw [modularFunctionFieldFull, adjoin_le_iff]
+  rintro x ⟨d, hne, hdvd, rfl⟩
+  have := hne
+  have hd1 : d = 1 := Nat.dvd_one.mp hdvd
+  subst hd1
+  rw [qExpand_one_apply]
+  exact jq_mem 1
+
+end ModularCurve.W1
+
+namespace ModularCurve
+
+namespace W1
+
+section RValCore
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem map_qExpand_minpoly_eq {M' : ℕ} [NeZero M'] (k : ℕ) [NeZero k] {N : ℕ}
+    [NeZero N] (hN : N = k * M') (ζ' : Kˣ)
+    (hid : (minpoly ℚ⟮jq⟯ (jqN M')).map
+        (((coeffEmb K).comp (qExpand ℚ M')).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))
+      = ∏ a ∈ M'.divisors, ∏ b ∈ (Finset.range (M' / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M' / a) = 1),
+          (Polynomial.X - Polynomial.C (sv K ζ' a b))) :
+    (minpoly ℚ⟮jq⟯ (jqN M')).map
+        (((coeffEmb K).comp (qExpand ℚ N)).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))
+      = ∏ a ∈ M'.divisors, ∏ b ∈ (Finset.range (M' / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M' / a) = 1),
+          (Polynomial.X - Polynomial.C (qExpand K k (sv K ζ' a b))) := by
+  subst hN
+  have hcomp : (qExpand K k).comp (((coeffEmb K).comp (qExpand ℚ M')).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))
+      = ((coeffEmb K).comp (qExpand ℚ (k * M'))).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) := by
+    refine RingHom.ext fun z => ?_
+    simp only [RingHom.comp_apply]
+    rw [coeffEmb_qExpand, qExpand_qExpand, ← coeffEmb_qExpand]
+  have h1 : (minpoly ℚ⟮jq⟯ (jqN M')).map (((coeffEmb K).comp (qExpand ℚ (k * M'))).comp (algebraMap
+    ℚ⟮jq⟯ (LaurentSeries ℚ))) = ((minpoly ℚ⟮jq⟯ (jqN M')).map (((coeffEmb K).comp (qExpand ℚ
+    M')).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).map (qExpand K k) :=
+    by
+    rw [Polynomial.map_map, hcomp]
+  rw [h1, hid, Polynomial.map_prod]
+  refine Finset.prod_congr rfl fun a _ => ?_
+  rw [Polynomial.map_prod]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C]
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+private theorem rval_aux : ∀ (M : ℕ) [NeZero M] {K : Type*} [Field K] [Algebra ℚ K]
+    (ζ : Kˣ), IsPrimitiveRoot ((ζ : Kˣ) : K) M →
+    (∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank ℚ⟮jq⟯
+          (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN d} : Set (LaurentSeries ℚ))) = dedekindPsi d
+        ∧ modularFunctionField d = modularFunctionFieldFull d) →
+    (minpoly ℚ⟮jq⟯ (jqN M)).map
+        (((coeffEmb K).comp (qExpand ℚ M)).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))
+      = ∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+          (Polynomial.X - Polynomial.C (sv K ζ a b)) := by
+  intro M
+  induction M using Nat.strong_induction_on with
+  | _ M IH =>
+  intro _ K _ _ ζ hζ hall
+  classical
+  have hM0 : M ≠ 0 := NeZero.ne M
+  have hslot_root : ∀ a b : ℕ, a ∈ M.divisors →
+      b ∈ (Finset.range (M / a)).filter (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1) →
+      ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ M)).comp
+        (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).IsRoot (sv K ζ a b) := by
+    intro a b ha hb
+    obtain ⟨haM, -⟩ := Nat.mem_divisors.mp ha
+    obtain ⟨hbr, hbc⟩ := Finset.mem_filter.mp hb
+    rw [Finset.mem_range] at hbr
+    have ha0 : a ≠ 0 := by
+      rintro rfl
+      exact hM0 (Nat.eq_zero_of_zero_dvd haM)
+    have : NeZero a := ⟨ha0⟩
+    have had : a * (M / a) = M := Nat.mul_div_cancel' haM
+    by_cases hd1 : M / a = 1
+    · have haM' : a = M := by rw [hd1, mul_one] at had; exact had
+      have hb0 : b = 0 := by omega
+      subst hb0
+      rw [show sv K ζ a 0 = sv K ζ M 0 from by rw [haM'], sv_top,
+        show coeffEmb K (qExpand ℚ M (jqN M))
+          = ((coeffEmb K).comp (qExpand ℚ M)) (jqN M) from rfl]
+      rw [Polynomial.IsRoot, Polynomial.eval_map, ← Polynomial.hom_eval₂]
+      have h0 : Polynomial.eval₂ (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) (jqN M)
+          (minpoly ℚ⟮jq⟯ (jqN M)) = 0 := by
+        rw [← Polynomial.aeval_def]
+        exact minpoly.aeval _ _
+      rw [h0, map_zero]
+    · have hd0 : M / a ≠ 0 := by
+        intro h0
+        rw [h0, mul_zero] at had
+        exact hM0 had.symm
+      have hpp : (M / a).minFac.Prime := Nat.minFac_prime hd1
+      have : Fact (M / a).minFac.Prime := ⟨hpp⟩
+      have : NeZero (M / a).minFac := ⟨hpp.ne_zero⟩
+      obtain ⟨d'', hdd⟩ : (M / a).minFac ∣ M / a := Nat.minFac_dvd _
+      set p := (M / a).minFac with hp_def
+      have hd''0 : d'' ≠ 0 := by
+        rintro rfl
+        rw [mul_zero] at hdd
+        exact hd0 hdd
+      have : NeZero d'' := ⟨hd''0⟩
+      have hM'0 : a * d'' ≠ 0 := Nat.mul_ne_zero ha0 hd''0
+      have : NeZero (a * d'') := ⟨hM'0⟩
+      have hMM' : M = a * d'' * p := by rw [← had, hdd]; ring
+      have hM'M : a * d'' ∣ M := ⟨p, hMM'⟩
+      have hM'lt : a * d'' < M := by
+        calc a * d'' = a * d'' * 1 := by ring
+          _ < a * d'' * p :=
+              (Nat.mul_lt_mul_left (Nat.pos_of_ne_zero hM'0)).mpr hpp.one_lt
+          _ = M := hMM'.symm
+      have hpM : p ∣ M := by
+        have hpd : p ∣ M / a := ⟨d'', hdd⟩
+        exact hpd.trans (Nat.div_dvd_of_dvd haM)
+      have hb''lt : b % d'' < d'' := Nat.mod_lt b (Nat.pos_of_ne_zero hd''0)
+      have hbsplit : b % d'' + b / d'' * d'' = b := Nat.mod_add_div' b d''
+      have hc₀p : b / d'' < p := by
+        have h1 : b < d'' * p := by rw [Nat.mul_comm d'' p, ← hdd]; exact hbr
+        exact Nat.div_lt_of_lt_mul h1
+      have hprim' : Nat.gcd (Nat.gcd a (b % d'')) d'' = 1 := by
+        have h1 : Nat.gcd (Nat.gcd a (b % d'')) d'' ∣ Nat.gcd (Nat.gcd a b) (M / a) := by
+          refine Nat.dvd_gcd (Nat.dvd_gcd ?_ ?_) ?_
+          · exact (Nat.gcd_dvd_left _ _).trans (Nat.gcd_dvd_left a (b % d''))
+          · have hgb'' : Nat.gcd (Nat.gcd a (b % d'')) d'' ∣ b % d'' :=
+              (Nat.gcd_dvd_left _ _).trans (Nat.gcd_dvd_right a (b % d''))
+            have hgd'' : Nat.gcd (Nat.gcd a (b % d'')) d'' ∣ d'' := Nat.gcd_dvd_right _ _
+            have h2 : Nat.gcd (Nat.gcd a (b % d'')) d'' ∣ b % d'' + b / d'' * d'' :=
+              Nat.dvd_add hgb'' (hgd''.mul_left _)
+            rwa [hbsplit] at h2
+          · rw [hdd]
+            exact (Nat.gcd_dvd_right _ _).mul_left p
+        rw [hbc] at h1
+        exact Nat.dvd_one.mp h1
+      have hζ' : IsPrimitiveRoot ((ζ ^ p : Kˣ) : K) (a * d'') := by
+        have h1 := isPrimitiveRoot_pow_div hζ hM'M
+        have h2 : M / (a * d'') = p := by
+          rw [hMM']
+          exact Nat.mul_div_cancel_left p (Nat.pos_of_ne_zero hM'0)
+        rwa [h2] at h1
+      have hIH := IH (a * d'') hM'lt (ζ ^ p) hζ' (fun e he _ => hall e (he.trans hM'M))
+      have hIHM := map_qExpand_minpoly_eq p (show M = p * (a * d'') from by rw [hMM']; ring)
+        (ζ ^ p) hIH
+      have hroot' : ((minpoly ℚ⟮jq⟯ (jqN (a * d''))).map (((coeffEmb K).comp
+          (qExpand ℚ M)).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).IsRoot
+          (qExpand K p (sv K (ζ ^ p) a (b % d''))) := by
+        rw [hIHM, Polynomial.IsRoot, Polynomial.eval_prod]
+        refine Finset.prod_eq_zero (Nat.mem_divisors.mpr ⟨⟨d'', rfl⟩, hM'0⟩) ?_
+        rw [Polynomial.eval_prod]
+        have hM'a : a * d'' / a = d'' := Nat.mul_div_cancel_left d'' (Nat.pos_of_ne_zero ha0)
+        refine Finset.prod_eq_zero (i := b % d'') ?_ ?_
+        · rw [hM'a]
+          exact Finset.mem_filter.mpr ⟨Finset.mem_range.mpr hb''lt, hprim'⟩
+        · rw [Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, sub_self]
+      let : Algebra ℚ⟮jq⟯ (LaurentSeries K) :=
+        (((coeffEmb K).comp (qExpand ℚ M)).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ))).toAlgebra
+      have halg : algebraMap ℚ⟮jq⟯ (LaurentSeries K)
+          = ((coeffEmb K).comp (qExpand ℚ M)).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) :=
+        RingHom.algebraMap_toAlgebra _
+      obtain ⟨htM', hgM'⟩ := hall (a * d'') hM'M
+      have hfd' : FiniteDimensional ℚ⟮jq⟯
+          (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN (a * d'')} : Set (LaurentSeries ℚ))) :=
+        FiniteDimensional.of_finrank_pos (htM' ▸ dedekindPsi_pos hM'0)
+      have hα' : IsIntegral ℚ⟮jq⟯ (jqN (a * d'')) :=
+        IntermediateField.isIntegral_iff.mp (IsIntegral.of_finite ℚ⟮jq⟯
+          (⟨jqN (a * d''), IntermediateField.subset_adjoin ℚ⟮jq⟯ _ rfl⟩ :
+            IntermediateField.adjoin ℚ⟮jq⟯ ({jqN (a * d'')} : Set (LaurentSeries ℚ))))
+      have hy_mem : qExpand K p (sv K (ζ ^ p) a (b % d''))
+          ∈ (minpoly ℚ⟮jq⟯ (jqN (a * d''))).aroots (LaurentSeries K) := by
+        rw [Polynomial.mem_aroots]
+        refine ⟨minpoly.ne_zero hα', ?_⟩
+        rw [Polynomial.aeval_def, halg, Polynomial.eval₂_eq_eval_map]
+        exact hroot'
+      obtain ⟨ψ₁, hψ₁⟩ : ∃ ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →ₐ[ℚ⟮jq⟯] LaurentSeries K,
+          ψ₁ (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN (a * d'')))
+            = qExpand K p (sv K (ζ ^ p) a (b % d'')) :=
+        ⟨(IntermediateField.algHomAdjoinIntegralEquiv ℚ⟮jq⟯ hα').symm ⟨_, hy_mem⟩,
+          IntermediateField.algHomAdjoinIntegralEquiv_symm_apply_gen ℚ⟮jq⟯ hα' ⟨_, hy_mem⟩⟩
+      obtain ⟨dp, hdpirr, hdpsym⟩ := ModularCurve.exists_phiIrreducible_evalSymm p
+      have hup : (phiAtSeed dp (jqN (a * d''))).eval (jqN M) = 0 := by
+        have h1 := phiAtSeed_jqN_eval p dp (a * d'')
+        rwa [show jqN (a * d'' * p) = jqN M from jqN_congr hMM'.symm] at h1
+      have haev : Polynomial.aeval (jqN M)
+          (phiAtSeed dp (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN (a * d'')))) = 0 := by
+        rw [Polynomial.aeval_def, Polynomial.eval₂_eq_eval_map, phiAtSeed_map]
+        exact hup
+      have hα₁ : IsIntegral ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M) :=
+        ⟨phiAtSeed dp (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN (a * d''))),
+          phiAtSeed_monic dp _, by rw [← Polynomial.aeval_def]; exact haev⟩
+      have hmindvd : minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)
+          ∣ phiAtSeed dp (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN (a * d''))) :=
+        minpoly.dvd _ _ haev
+      have htow := Module.finrank_mul_finrank ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯
+        ℚ⟮jq⟯⟮jqN (a * d'')⟯⟮jqN M⟯
+      have habs : IntermediateField.adjoin ℚ⟮jq⟯
+          (({jqN (a * d'')} : Set (LaurentSeries ℚ)) ∪ {jqN M})
+          = IntermediateField.adjoin ℚ⟮jq⟯ ({jqN M} : Set (LaurentSeries ℚ)) := by
+        obtain ⟨-, hgM⟩ := hall M dvd_rfl
+        refine le_antisymm (IntermediateField.adjoin_le_iff.mpr ?_)
+          (IntermediateField.adjoin.mono _ _ _ Set.subset_union_right)
+        rintro z (hz | hz)
+        · rw [Set.mem_singleton_iff] at hz
+          subst hz
+          have h1 : jqN (a * d'') ∈ modularFunctionFieldFull M := jqd_mem_full M hM'M
+          rw [← hgM] at h1
+          exact mem_adjoin_jqN_of_mem_mff h1
+        · rw [Set.mem_singleton_iff] at hz
+          subst hz
+          exact IntermediateField.subset_adjoin _ _ rfl
+      have htop : Module.finrank ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯⟮jqN M⟯ = dedekindPsi M := by
+        obtain ⟨htM, -⟩ := hall M dvd_rfl
+        have h1 := IntermediateField.adjoin_adjoin_left ℚ⟮jq⟯
+          ({jqN (a * d'')} : Set (LaurentSeries ℚ)) {jqN M}
+        have h2 : Module.finrank ℚ⟮jq⟯
+            (IntermediateField.restrictScalars ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯⟮jqN M⟯)
+            = Module.finrank ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯⟮jqN M⟯ := rfl
+        rw [← h2, h1, habs]
+        exact htM
+      have hstep_deg : Module.finrank ℚ⟮jq⟯⟮jqN (a * d'')⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯⟮jqN M⟯
+          * dedekindPsi (a * d'') = dedekindPsi M := by
+        rw [← htM', ← htop, Nat.mul_comm]
+        exact htow
+      have hseed : qExpand K p (sv K (ζ ^ p) a (b % d''))
+          = qExpand K (p * (a * a)) (qTwist ((ζ ^ (b % d'' * a)) ^ p) (coeffEmb K jq)) := by
+        rw [sv_eq_TS, qExpand_TS]
+        suffices TS K (p * (a * a)) ((ζ ^ p) ^ (b % d'' * a))
+          = TS K (p * (a * a)) ((ζ ^ (b % d'' * a)) ^ p) by
+          simpa only [TS_eq_coeffEmb] using this
+        exact TS_congr' rfl (by rw [← pow_mul, ← pow_mul, Nat.mul_comm])
+      have hC5 := ModularCurve.PhiGen.splits_prime_at_slot M ζ hζ p hpM dp (a * a)
+        (ζ ^ (b % d'' * a))
+      have hΦfact : phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d'')))
+          = (Polynomial.X - Polynomial.C (qExpand K (p * (p * (a * a)))
+              (qTwist ((ζ ^ (b % d'' * a)) ^ (p * p)) (coeffEmb K jq))))
+            * ∏ c ∈ Finset.range p, (Polynomial.X - Polynomial.C (qExpand K (a * a)
+              (qTwist (ζ ^ (b % d'' * a) * ζ ^ (c * (M / p))) (coeffEmb K jq)))) := by
+        rw [hseed]
+        exact hC5
+      have hMp : M / p = a * d'' := by
+        rw [hMM']
+        exact Nat.mul_div_cancel _ hpp.pos
+      have htarget : qExpand K (a * a) (qTwist (ζ ^ (b % d'' * a) * ζ ^ (b / d'' * (M / p)))
+          (coeffEmb K jq)) = sv K ζ a b := by
+        rw [sv_eq]
+        suffices TS K (a * a) (ζ ^ (b % d'' * a) * ζ ^ (b / d'' * (M / p)))
+          = TS K (a * a) (ζ ^ (b * a)) by
+          simpa only [TS_eq_coeffEmb] using this
+        refine TS_congr' rfl ?_
+        rw [hMp, ← pow_add]
+        congr 1
+        rw [show b % d'' * a + b / d'' * (a * d'')
+          = (b % d'' + b / d'' * d'') * a from by ring, hbsplit]
+      by_cases hpM' : p ∣ a * d''
+      · have hψM : dedekindPsi M = dedekindPsi (a * d'') * p := by
+          rw [hMM']
+          exact dedekindPsi_mul_prime_dvd hM'0 hpp hpM'
+        have he : Module.finrank ℚ⟮jq⟯⟮jqN (a * d'')⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯⟮jqN M⟯ = p := by
+          have h1 : Module.finrank ℚ⟮jq⟯⟮jqN (a * d'')⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯⟮jqN M⟯
+              * dedekindPsi (a * d'') = p * dedekindPsi (a * d'') := by
+            rw [hstep_deg, hψM]
+            ring
+          exact Nat.eq_of_mul_eq_mul_right (dedekindPsi_pos hM'0) h1
+        obtain ⟨m'', hm''⟩ := hpM'
+        have hm''0 : m'' ≠ 0 := by
+          rintro rfl
+          rw [mul_zero] at hm''
+          exact hM'0 hm''
+        have : NeZero m'' := ⟨hm''0⟩
+        have hm''M : m'' ∣ M := ⟨p * p, by rw [hMM', hm'']; ring⟩
+        have hm''lt : m'' < M := by
+          calc m'' ≤ a * d'' := by rw [hm'']; exact Nat.le_mul_of_pos_left m'' hpp.pos
+            _ < M := hM'lt
+        have hdown : (phiAtSeed dp (jqN (a * d''))).eval (jqN m'') = 0 := by
+          rw [phiAtSeed_eval_symm dp hdpsym]
+          have h1 := phiAtSeed_jqN_eval p dp m''
+          rwa [show jqN (m'' * p) = jqN (a * d'') from jqN_congr (by rw [hm'']; ring)] at h1
+        have hmem'' : jqN m'' ∈ ℚ⟮jq⟯⟮jqN (a * d'')⟯ := by
+          have h1 : jqN m'' ∈ modularFunctionFieldFull (a * d'') :=
+            jqd_mem_full (a * d'') ⟨p, by rw [hm'']; ring⟩
+          rw [← hgM'] at h1
+          exact mem_adjoin_jqN_of_mem_mff h1
+        have hdownF₁ : (phiAtSeed dp (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯
+            (jqN (a * d'')))).eval (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯) = 0 :=
+          phiAtSeed_eval_of_injective dp _ _
+            (algebraMap ℚ⟮jq⟯⟮jqN (a * d'')⟯ (LaurentSeries ℚ)) (RingHom.injective _) hdown
+        have hψx'' : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d'')))).IsRoot
+            (ψ₁ (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯)) := by
+          have h1 := phiAtSeed_eval_map dp _ _
+            (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K) hdownF₁
+          rw [show (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)
+            (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN (a * d'')))
+            = qExpand K p (sv K (ζ ^ p) a (b % d'')) from hψ₁] at h1
+          exact h1
+        have hx''notmin : ¬ (minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).IsRoot
+            (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯) := by
+          intro hcon
+          obtain ⟨q, hq⟩ := Polynomial.dvd_iff_isRoot.mpr hcon
+          have hirr := minpoly.irreducible hα₁
+          rcases hirr.isUnit_or_isUnit hq with hu | hu
+          · exact Polynomial.not_isUnit_X_sub_C _ hu
+          · have hq0 : q ≠ 0 := by
+              rintro rfl
+              rw [mul_zero] at hq
+              exact minpoly.ne_zero hα₁ hq
+            have hdm : (minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).natDegree = 1 := by
+              rw [hq, Polynomial.natDegree_mul (Polynomial.X_sub_C_ne_zero _) hq0,
+                Polynomial.natDegree_X_sub_C, Polynomial.natDegree_eq_zero_of_isUnit hu]
+            have hdm' : (minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).natDegree = p := by
+              rw [← IntermediateField.adjoin.finrank hα₁]
+              exact he
+            rw [hdm] at hdm'
+            exact (Nat.ne_of_lt hpp.one_lt) hdm'
+        have hψx''notmin : ¬ ((minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).map
+            (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)).IsRoot
+            (ψ₁ (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯)) := by
+          intro hcon
+          refine hx''notmin ?_
+          rw [Polynomial.IsRoot, Polynomial.eval_map,
+            show ψ₁ (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯)
+              = (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)
+                (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯) from rfl,
+            Polynomial.eval₂_hom] at hcon
+          exact (injective_iff_map_eq_zero _).mp
+            (RingHom.injective (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)) _ hcon
+        have htarget_ne : sv K ζ a b ≠ ψ₁ (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯) := by
+          intro hcon
+          have hroot'' : ((minpoly ℚ⟮jq⟯ (jqN m'')).map (((coeffEmb K).comp
+              (qExpand ℚ M)).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).IsRoot
+              (ψ₁ (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯)) := by
+            have h1 : Polynomial.aeval (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯)
+                (minpoly ℚ⟮jq⟯ (jqN m'')) = 0 := by
+              refine aeval_intermediateField_eq_zero ?_
+              change Polynomial.aeval (jqN m'') (minpoly ℚ⟮jq⟯ (jqN m'')) = 0
+              exact minpoly.aeval _ _
+            have h2 := Polynomial.aeval_algHom_apply ψ₁
+              (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯) (minpoly ℚ⟮jq⟯ (jqN m''))
+            rw [h1, map_zero] at h2
+            rw [Polynomial.aeval_def, halg, Polynomial.eval₂_eq_eval_map] at h2
+            exact h2
+          have hζ'' : IsPrimitiveRoot ((ζ ^ (p * p) : Kˣ) : K) m'' := by
+            have h1 := isPrimitiveRoot_pow_div hζ hm''M
+            have h2 : M / m'' = p * p := by
+              rw [hMM', hm'', show p * m'' * p = m'' * (p * p) from by ring]
+              exact Nat.mul_div_cancel_left _ (Nat.pos_of_ne_zero hm''0)
+            rwa [h2] at h1
+          have hIH'' := IH m'' hm''lt (ζ ^ (p * p)) hζ''
+            (fun e he'' _ => hall e (he''.trans hm''M))
+          have hIHM'' := map_qExpand_minpoly_eq (p * p)
+            (show M = p * p * m'' from by rw [hMM', hm'']; ring) (ζ ^ (p * p)) hIH''
+          rw [hIHM''] at hroot''
+          rw [Polynomial.IsRoot, Polynomial.eval_prod] at hroot''
+          obtain ⟨α, hαmem, hα0⟩ := Finset.prod_eq_zero_iff.mp hroot''
+          rw [Polynomial.eval_prod] at hα0
+          obtain ⟨β, hβmem, hβ0⟩ := Finset.prod_eq_zero_iff.mp hα0
+          rw [Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, sub_eq_zero] at hβ0
+          obtain ⟨hαdvd, -⟩ := Nat.mem_divisors.mp hαmem
+          obtain ⟨hβr, -⟩ := Finset.mem_filter.mp hβmem
+          rw [Finset.mem_range] at hβr
+          have hα0' : α ≠ 0 := by
+            rintro rfl
+            exact hm''0 (Nat.eq_zero_of_zero_dvd hαdvd)
+          have : NeZero α := ⟨hα0'⟩
+          have hcoll : TS K (a * a) (ζ ^ (b * a))
+              = TS K (p * p * (α * α)) (ζ ^ (p * p * (β * α))) := by
+            calc TS K (a * a) (ζ ^ (b * a)) = sv K ζ a b := (sv_eq_TS ζ a b).symm
+              _ = ψ₁ (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯) := hcon
+              _ = qExpand K (p * p) (sv K (ζ ^ (p * p)) α β) := hβ0
+              _ = qExpand K (p * p) (TS K (α * α) ((ζ ^ (p * p)) ^ (β * α))) := by
+                  rw [sv_eq_TS]
+              _ = TS K (p * p * (α * α)) ((ζ ^ (p * p)) ^ (β * α)) := qExpand_TS _ _ _
+              _ = TS K (p * p * (α * α)) (ζ ^ (p * p * (β * α))) :=
+                  TS_congr' rfl (by rw [← pow_mul])
+          obtain ⟨hexp, hunit⟩ := TS_injective hcoll
+          have haα : a = p * α := by
+            have h2 : a * a = (p * α) * (p * α) := by rw [hexp]; ring
+            exact (mul_self_inj (Nat.zero_le _) (Nat.zero_le _)).mp h2
+          have hpa : p ∣ a := ⟨α, haα⟩
+          have hba : b * a < M := by
+            calc b * a < M / a * a :=
+                (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr
+              _ = M := by rw [Nat.mul_comm] at had; exact had
+          have hppβα : p * p * (β * α) < M := by
+            have h1 : β * α < m'' := by
+              calc β * α < m'' / α * α :=
+                  (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero hα0')).mpr hβr
+                _ ≤ m'' := Nat.div_mul_le_self m'' α
+            calc p * p * (β * α) < p * p * m'' :=
+                (Nat.mul_lt_mul_left (Nat.mul_pos hpp.pos hpp.pos)).mpr h1
+              _ = M := by rw [hMM', hm'']; ring
+          have hvv : ((ζ : K)) ^ (b * a) = ((ζ : K)) ^ (p * p * (β * α)) := by
+            have h1 := congrArg Units.val hunit
+            rwa [Units.val_pow_eq_pow_val, Units.val_pow_eq_pow_val] at h1
+          have hexp2 : b * a = p * p * (β * α) := hζ.pow_inj hba hppβα hvv
+          have hpb : p ∣ b := by
+            refine ⟨β, ?_⟩
+            rw [haα] at hexp2
+            have h1 : b * (p * α) = p * β * (p * α) := by
+              rw [hexp2]
+              ring
+            exact Nat.eq_of_mul_eq_mul_right (Nat.mul_pos hpp.pos
+              (Nat.pos_of_ne_zero hα0')) h1
+          have hfinal : p ∣ Nat.gcd (Nat.gcd a b) (M / a) :=
+            Nat.dvd_gcd (Nat.dvd_gcd hpa hpb) ⟨d'', hdd⟩
+          rw [hbc] at hfinal
+          exact hpp.ne_one (Nat.dvd_one.mp hfinal)
+        have hQ : (Polynomial.X - Polynomial.C (ψ₁ (⟨jqN m'', hmem''⟩ :
+            ℚ⟮jq⟯⟮jqN (a * d'')⟯))) * (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+            (Polynomial.X - Polynomial.C (ψ₁ (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯))))
+            = phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) :=
+          Polynomial.mul_divByMonic_eq_iff_isRoot.mpr hψx''
+        have hΦmonic : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d'')))).Monic :=
+          phiAtSeed_monic dp _
+        have hQmonic : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+            (Polynomial.X - Polynomial.C (ψ₁ (⟨jqN m'', hmem''⟩ :
+              ℚ⟮jq⟯⟮jqN (a * d'')⟯)))).Monic :=
+          Polynomial.Monic.of_mul_monic_left (Polynomial.monic_X_sub_C _)
+            (by rw [hQ]; exact hΦmonic)
+        have hΦdeg : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d'')))).natDegree
+            = p + 1 := by
+          rw [phiAtSeed_natDegree]
+          exact dedekindPsi_prime p hpp
+        have hQdeg : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+            (Polynomial.X - Polynomial.C (ψ₁ (⟨jqN m'', hmem''⟩ :
+              ℚ⟮jq⟯⟮jqN (a * d'')⟯)))).natDegree = p := by
+          have h1 : p + 1 = 1 + (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+              (Polynomial.X - Polynomial.C (ψ₁ (⟨jqN m'', hmem''⟩ :
+                ℚ⟮jq⟯⟮jqN (a * d'')⟯)))).natDegree := by
+            rw [← hΦdeg]
+            conv_lhs => rw [← hQ]
+            rw [Polynomial.natDegree_mul (Polynomial.X_sub_C_ne_zero _) hQmonic.ne_zero,
+              Polynomial.natDegree_X_sub_C]
+          omega
+        have hP₁dvd : (minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).map
+            (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)
+            ∣ phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) := by
+          have h1 := Polynomial.map_dvd (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K) hmindvd
+          rwa [phiAtSeed_map, show (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)
+            (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN (a * d'')))
+            = qExpand K p (sv K (ζ ^ p) a (b % d'')) from hψ₁] at h1
+        have hcop : IsCoprime (Polynomial.X - Polynomial.C (ψ₁ (⟨jqN m'', hmem''⟩ :
+            ℚ⟮jq⟯⟮jqN (a * d'')⟯)))
+            ((minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).map
+              (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)) := by
+          rw [(Polynomial.irreducible_X_sub_C _).coprime_iff_not_dvd]
+          intro hcon
+          exact hψx''notmin (Polynomial.dvd_iff_isRoot.mp hcon)
+        have hP₁dvdQ : (minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).map
+            (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)
+            ∣ phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+              (Polynomial.X - Polynomial.C (ψ₁ (⟨jqN m'', hmem''⟩ :
+                ℚ⟮jq⟯⟮jqN (a * d'')⟯))) := by
+          have h1 := hP₁dvd
+          rw [← hQ] at h1
+          exact (hcop.symm).dvd_of_dvd_mul_left h1
+        have hdeg₁ : ((minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).map
+            (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)).natDegree = p := by
+          rw [Polynomial.Monic.natDegree_map (minpoly.monic hα₁),
+            ← IntermediateField.adjoin.finrank hα₁]
+          exact he
+        have hmineqQ : (minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).map
+            (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)
+            = phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+              (Polynomial.X - Polynomial.C (ψ₁ (⟨jqN m'', hmem''⟩ :
+                ℚ⟮jq⟯⟮jqN (a * d'')⟯))) :=
+          Polynomial.eq_of_monic_of_dvd_of_natDegree_le ((minpoly.monic hα₁).map _)
+            hQmonic hP₁dvdQ (le_of_eq (hQdeg.trans hdeg₁.symm)) |>.symm
+        have htargetΦ : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d'')))).IsRoot
+            (sv K ζ a b) := by
+          rw [hΦfact, Polynomial.IsRoot, Polynomial.eval_mul]
+          refine mul_eq_zero.mpr (Or.inr ?_)
+          rw [Polynomial.eval_prod]
+          refine Finset.prod_eq_zero (Finset.mem_range.mpr hc₀p) ?_
+          rw [htarget, Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, sub_self]
+        have hroot_step : ((minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).map
+            (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)).IsRoot (sv K ζ a b) := by
+          rw [hmineqQ, Polynomial.IsRoot]
+          have h1 : ((Polynomial.X - Polynomial.C (ψ₁ (⟨jqN m'', hmem''⟩ :
+              ℚ⟮jq⟯⟮jqN (a * d'')⟯))) * (phiAtSeed dp (qExpand K p
+              (sv K (ζ ^ p) a (b % d''))) /ₘ (Polynomial.X - Polynomial.C
+              (ψ₁ (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯))))).eval (sv K ζ a b) = 0 := by
+            rw [hQ]
+            exact htargetΦ
+          rw [Polynomial.eval_mul, Polynomial.eval_sub, Polynomial.eval_X,
+            Polynomial.eval_C] at h1
+          rcases mul_eq_zero.mp h1 with h2 | h2
+          · exact absurd (sub_eq_zero.mp h2) htarget_ne
+          · exact h2
+        have htowdvd : minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)
+            ∣ (minpoly ℚ⟮jq⟯ (jqN M)).map (algebraMap ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯) :=
+          minpoly.dvd_map_of_isScalarTower ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)
+        have h1 := Polynomial.map_dvd (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K) htowdvd
+        rw [Polynomial.map_map] at h1
+        have h2 : (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K).comp
+            (algebraMap ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯)
+            = ((coeffEmb K).comp (qExpand ℚ M)).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) := by
+          rw [AlgHom.comp_algebraMap]
+          exact halg
+        rw [h2] at h1
+        exact Polynomial.eval_eq_zero_of_dvd_of_eval_eq_zero h1 hroot_step
+      · have hψM : dedekindPsi M = dedekindPsi (a * d'') * (p + 1) := by
+          rw [hMM']
+          exact dedekindPsi_mul_prime_not_dvd hpp hpM'
+        have he : Module.finrank ℚ⟮jq⟯⟮jqN (a * d'')⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯⟮jqN M⟯
+            = p + 1 := by
+          have h1 : Module.finrank ℚ⟮jq⟯⟮jqN (a * d'')⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯⟮jqN M⟯
+              * dedekindPsi (a * d'') = (p + 1) * dedekindPsi (a * d'') := by
+            rw [hstep_deg, hψM]
+            ring
+          exact Nat.eq_of_mul_eq_mul_right (dedekindPsi_pos hM'0) h1
+        have hdeg₁ : (minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).natDegree = p + 1 := by
+          rw [← IntermediateField.adjoin.finrank hα₁]
+          exact he
+        have hΦdeg : (phiAtSeed dp (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯
+            (jqN (a * d'')))).natDegree = p + 1 := by
+          rw [phiAtSeed_natDegree]
+          exact dedekindPsi_prime p hpp
+        have hmineq : minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)
+            = phiAtSeed dp (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN (a * d''))) :=
+          Polynomial.eq_of_monic_of_dvd_of_natDegree_le (minpoly.monic hα₁)
+            (phiAtSeed_monic dp _) hmindvd (le_of_eq (hΦdeg.trans hdeg₁.symm)) |>.symm
+        have hroot_step : ((minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).map
+            (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)).IsRoot (sv K ζ a b) := by
+          rw [hmineq, phiAtSeed_map, show (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)
+            (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN (a * d'')))
+            = qExpand K p (sv K (ζ ^ p) a (b % d'')) from hψ₁]
+          rw [hΦfact, Polynomial.IsRoot, Polynomial.eval_mul]
+          refine mul_eq_zero.mpr (Or.inr ?_)
+          rw [Polynomial.eval_prod]
+          refine Finset.prod_eq_zero (Finset.mem_range.mpr hc₀p) ?_
+          rw [htarget, Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, sub_self]
+        have htowdvd : minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)
+            ∣ (minpoly ℚ⟮jq⟯ (jqN M)).map (algebraMap ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯) :=
+          minpoly.dvd_map_of_isScalarTower ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)
+        have h1 := Polynomial.map_dvd (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K) htowdvd
+        rw [Polynomial.map_map] at h1
+        have h2 : (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K).comp
+            (algebraMap ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯)
+            = ((coeffEmb K).comp (qExpand ℚ M)).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) := by
+          rw [AlgHom.comp_algebraMap]
+          exact halg
+        rw [h2] at h1
+        exact Polynomial.eval_eq_zero_of_dvd_of_eval_eq_zero h1 hroot_step
+  by_cases hM1 : M = 1
+  · subst hM1
+    have hjq1 : jqN 1 = algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ) jGen := by
+      rw [show jqN 1 = jq from by rw [jqN, qExpand_one_apply]]
+      rfl
+    have hmin : minpoly ℚ⟮jq⟯ (jqN 1) = Polynomial.X - Polynomial.C jGen := by
+      rw [hjq1]
+      exact minpoly.eq_X_sub_C (B := LaurentSeries ℚ) jGen
+    have hfil : (Finset.range (1 / 1)).filter
+        (fun b => Nat.gcd (Nat.gcd 1 b) (1 / 1) = 1) = {0} := by decide
+    rw [hmin, Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C, Nat.divisors_one,
+      Finset.prod_singleton, hfil, Finset.prod_singleton]
+    congr 1
+    have h1 : (((coeffEmb K).comp (qExpand ℚ 1)).comp
+        (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ))) jGen = coeffEmb K jq := by
+      simp only [RingHom.comp_apply]
+      rw [show (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) jGen = jq from rfl, qExpand_one_apply]
+    rw [h1]
+    have : NeZero (1 : ℕ) := ⟨one_ne_zero⟩
+    have h2 : sv K ζ 1 0 = coeffEmb K jq := by
+      rw [sv_eq_TS]
+      have h3 : TS K (1 * 1) (ζ ^ (0 * 1)) = TS K 1 1 :=
+        TS_congr' (Nat.mul_one 1) (by rw [Nat.zero_mul, pow_zero])
+      rw [h3, TS_eq_coeffEmb, qTwist_one_apply, qExpand_one_apply]
+    rw [h2]
+  · obtain ⟨htM, -⟩ := hall M dvd_rfl
+    have hfd : FiniteDimensional ℚ⟮jq⟯
+        (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN M} : Set (LaurentSeries ℚ))) :=
+      FiniteDimensional.of_finrank_pos (htM ▸ dedekindPsi_pos hM0)
+    have hα : IsIntegral ℚ⟮jq⟯ (jqN M) :=
+      IntermediateField.isIntegral_iff.mp (IsIntegral.of_finite ℚ⟮jq⟯
+        (⟨jqN M, IntermediateField.subset_adjoin ℚ⟮jq⟯ _ rfl⟩ :
+          IntermediateField.adjoin ℚ⟮jq⟯ ({jqN M} : Set (LaurentSeries ℚ))))
+    have hdeg : (minpoly ℚ⟮jq⟯ (jqN M)).natDegree = dedekindPsi M := by
+      rw [← IntermediateField.adjoin.finrank hα]
+      exact htM
+    set T : Multiset (LaurentSeries K) := M.divisors.val.bind
+      (fun a => ((Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map (fun b => sv K ζ a b)) with hT
+    have hTcard : Multiset.card T = dedekindPsi M := by
+      rw [hT, Multiset.card_bind]
+      have h2 : M.divisors.val.map (Multiset.card ∘ fun a => (((Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map (fun b => sv K ζ a b)))
+          = M.divisors.val.map (fun a => slotAt M (M / a)) := by
+        refine Multiset.map_congr rfl ?_
+        intro a ha
+        change Multiset.card (((Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map (fun b => sv K ζ a b))
+          = slotAt M (M / a)
+        rw [Multiset.card_map]
+        change ((Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).card = slotAt M (M / a)
+        unfold slotAt
+        rw [Nat.div_div_self (Nat.mem_divisors.mp (Finset.mem_val.mp ha)).1 hM0]
+      rw [h2]
+      change (∑ a ∈ M.divisors, slotAt M (M / a)) = dedekindPsi M
+      rw [Nat.sum_div_divisors M (slotAt M)]
+      exact slots_eq_dedekindPsi M hM0
+    have hmem_unpack : ∀ x ∈ T, ∃ a b : ℕ, a ∈ M.divisors ∧
+        b ∈ (Finset.range (M / a)).filter (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1) ∧
+        x = sv K ζ a b := by
+      intro x hx
+      rw [hT, Multiset.mem_bind] at hx
+      obtain ⟨a, ha, hx2⟩ := hx
+      rw [Multiset.mem_map] at hx2
+      obtain ⟨b, hb, rfl⟩ := hx2
+      exact ⟨a, b, ha, hb, rfl⟩
+    have hTnodup : T.Nodup := by
+      rw [hT]
+      rw [Multiset.nodup_bind]
+      constructor
+      · intro a ha
+        refine Multiset.Nodup.map_on ?_ (Finset.filter _ _).nodup
+        intro b hb b' hb' hvv
+        have ha0 : a ≠ 0 := by
+          rintro rfl
+          exact hM0 (Nat.eq_zero_of_zero_dvd (Nat.mem_divisors.mp (by exact ha)).1)
+        have hbr := Finset.mem_range.mp (Finset.mem_filter.mp (by exact hb)).1
+        have hbr' := Finset.mem_range.mp (Finset.mem_filter.mp (by exact hb')).1
+        have haM := (Nat.mem_divisors.mp (by exact ha)).1
+        have had : M / a * a = M := Nat.div_mul_cancel haM
+        have hba : b * a < M := by
+          calc b * a < M / a * a :=
+              (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr
+            _ = M := had
+        have hba' : b' * a < M := by
+          calc b' * a < M / a * a :=
+              (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr'
+            _ = M := had
+        exact (sv_inj hζ ha0 ha0 hba hba' hvv).2
+      · refine Multiset.Nodup.pairwise ?_ M.divisors.nodup
+        intro a ha a' ha' hne
+        change Disjoint (((Finset.range (M / a)).filter
+            (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map (fun b => sv K ζ a b))
+          (((Finset.range (M / a')).filter
+            (fun b => Nat.gcd (Nat.gcd a' b) (M / a') = 1)).val.map (fun b => sv K ζ a' b))
+        rw [Multiset.disjoint_left]
+        intro x hx hx'
+        rw [Multiset.mem_map] at hx hx'
+        obtain ⟨b, hb, hxb⟩ := hx
+        obtain ⟨b', hb', hxb'⟩ := hx'
+        have haM := (Nat.mem_divisors.mp (Finset.mem_val.mp ha)).1
+        have haM' := (Nat.mem_divisors.mp (Finset.mem_val.mp ha')).1
+        have ha0 : a ≠ 0 := by
+          rintro rfl
+          exact hM0 (Nat.eq_zero_of_zero_dvd haM)
+        have ha0' : a' ≠ 0 := by
+          rintro rfl
+          exact hM0 (Nat.eq_zero_of_zero_dvd haM')
+        have hbr := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb)).1
+        have hbr' := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb')).1
+        have hba : b * a < M := by
+          calc b * a < M / a * a :=
+              (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr
+            _ = M := Nat.div_mul_cancel haM
+        have hba' : b' * a' < M := by
+          calc b' * a' < M / a' * a' :=
+              (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0')).mpr hbr'
+            _ = M := Nat.div_mul_cancel haM'
+        have hvv : sv K ζ a b = sv K ζ a' b' := by rw [hxb, ← hxb']
+        exact hne (sv_inj hζ ha0 ha0' hba hba' hvv).1
+    have hPne : (minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ M)).comp
+        (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ))) ≠ 0 :=
+      ((minpoly.monic hα).map _).ne_zero
+    have hPdeg : ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ M)).comp
+        (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).natDegree = dedekindPsi M := by
+      rw [Polynomial.Monic.natDegree_map (minpoly.monic hα)]
+      exact hdeg
+    have hTle : T ≤ ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ M)).comp
+        (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).roots := by
+      rw [Multiset.le_iff_count]
+      intro x
+      by_cases hx : x ∈ T
+      · have h1 : Multiset.count x T ≤ 1 := Multiset.nodup_iff_count_le_one.mp hTnodup x
+        have h2 : 1 ≤ Multiset.count x (((minpoly ℚ⟮jq⟯ (jqN M)).map
+            (((coeffEmb K).comp (qExpand ℚ M)).comp
+              (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).roots) := by
+          rw [Multiset.one_le_count_iff_mem, Polynomial.mem_roots']
+          obtain ⟨a, b, ha, hb, rfl⟩ := hmem_unpack x hx
+          exact ⟨hPne, hslot_root a b ha hb⟩
+        omega
+      · rw [Multiset.count_eq_zero.mpr hx]
+        exact Nat.zero_le _
+    have hroots_eq : ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ M)).comp
+        (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).roots = T := by
+      refine (Multiset.eq_of_le_of_card_le hTle ?_).symm
+      rw [hTcard]
+      calc Multiset.card (((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp
+            (qExpand ℚ M)).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).roots)
+          ≤ ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ M)).comp
+            (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).natDegree := Polynomial.card_roots' _
+        _ = dedekindPsi M := hPdeg
+    have hsp : Polynomial.Splits ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp
+        (qExpand ℚ M)).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))) := by
+      rw [Polynomial.splits_iff_card_roots, hroots_eq, hTcard, hPdeg]
+    have hfact := hsp.eq_prod_roots_of_monic ((minpoly.monic hα).map _)
+    rw [hfact, hroots_eq, hT, Multiset.map_bind, Multiset.prod_bind]
+    change (M.divisors.val.map fun a => ((((Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+        (fun b => sv K ζ a b)).map (fun r => Polynomial.X - Polynomial.C r)).prod).prod
+      = ∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+          (Polynomial.X - Polynomial.C (sv K ζ a b))
+    simp only [Multiset.map_map, Function.comp]
+    rfl
+
+end RValCore
+end ModularCurve.W1
+
+namespace ModularCurve
+
+namespace W1
+
+section NonMem0
+
+open IntermediateField
+
+private theorem jqN_prime_not_mem_adjoin (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (hpM : ¬ p ∣ M)
+    (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank ℚ⟮jq⟯
+          (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN d} : Set (LaurentSeries ℚ))) = dedekindPsi d
+        ∧ modularFunctionField d = modularFunctionFieldFull d) :
+    jqN p ∉ IntermediateField.adjoin ℚ⟮jq⟯ ({jqN M} : Set (LaurentSeries ℚ)) := by
+  classical
+  intro hmem
+  have hM0 : M ≠ 0 := NeZero.ne M
+  have hp0 : p ≠ 0 := hp.out.ne_zero
+  have : NeZero p := ⟨hp0⟩
+  have : NeZero (M * p) := ⟨Nat.mul_ne_zero hM0 hp0⟩
+  set K := CyclotomicField (M * p) ℚ with hK
+  have hζ : IsPrimitiveRoot ((cycUnit (M * p) : Kˣ) : K) (M * p) := cycUnit_spec (M * p)
+  have hζM : IsPrimitiveRoot (((cycUnit (M * p) : Kˣ) ^ p : Kˣ) : K) M := by
+    have h1 := isPrimitiveRoot_pow_div hζ (⟨p, rfl⟩ : M ∣ M * p)
+    have h2 : M * p / M = p := Nat.mul_div_cancel_left p (Nat.pos_of_ne_zero hM0)
+    rwa [h2] at h1
+  have hζp : IsPrimitiveRoot (((cycUnit (M * p) : Kˣ) ^ M : Kˣ) : K) p := by
+    have h1 := isPrimitiveRoot_pow_div hζ (⟨M, Nat.mul_comm M p⟩ : p ∣ M * p)
+    have h2 : M * p / p = M := Nat.mul_div_cancel M (Nat.pos_of_ne_zero hp0)
+    rwa [h2] at h1
+  obtain ⟨htM, -⟩ := hall M dvd_rfl
+  have hfd : FiniteDimensional ℚ⟮jq⟯
+      (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN M} : Set (LaurentSeries ℚ))) :=
+    FiniteDimensional.of_finrank_pos (htM ▸ dedekindPsi_pos hM0)
+  have hα : IsIntegral ℚ⟮jq⟯ (jqN M) :=
+    IntermediateField.isIntegral_iff.mp (IsIntegral.of_finite ℚ⟮jq⟯
+      (⟨jqN M, IntermediateField.subset_adjoin ℚ⟮jq⟯ _ rfl⟩ :
+        IntermediateField.adjoin ℚ⟮jq⟯ ({jqN M} : Set (LaurentSeries ℚ))))
+  have hdeg : (minpoly ℚ⟮jq⟯ (jqN M)).natDegree = dedekindPsi M := by
+    rw [← IntermediateField.adjoin.finrank hα]
+    exact htM
+  have hallp : ∀ d : ℕ, d ∣ p → ∀ [NeZero d],
+      Module.finrank ℚ⟮jq⟯
+          (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN d} : Set (LaurentSeries ℚ))) = dedekindPsi d
+        ∧ modularFunctionField d = modularFunctionFieldFull d := by
+    intro d hd _
+    rcases (Nat.Prime.eq_one_or_self_of_dvd hp.out d hd) with h1 | h2
+    · subst h1
+      exact ⟨tight_one, gen_one⟩
+    · have h2' := h2.symm
+      subst h2'
+      constructor
+      · rw [dedekindPsi_prime p hp.out]
+        exact ModularCurve.finrank_adjoin_jqN_eq_of_prime p
+      · exact ((ModularCurve.functionFieldGeneration_iff_full_eq p).mp
+          (ModularCurve.functionFieldGeneration_of_squarefree p
+            hp.out.prime.squarefree)).symm
+  have hidMB := map_qExpand_minpoly_eq p (show M * p = p * M from Nat.mul_comm M p)
+    ((cycUnit (M * p) : Kˣ) ^ p)
+    (rval_aux M ((cycUnit (M * p) : Kˣ) ^ p) hζM hall)
+  have hidpB := map_qExpand_minpoly_eq M rfl ((cycUnit (M * p) : Kˣ) ^ M)
+    (rval_aux p ((cycUnit (M * p) : Kˣ) ^ M) hζp hallp)
+  let : Algebra ℚ⟮jq⟯ (LaurentSeries K) :=
+    (((coeffEmb K).comp (qExpand ℚ (M * p))).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ))).toAlgebra
+  have halg : algebraMap ℚ⟮jq⟯ (LaurentSeries K)
+      = ((coeffEmb K).comp (qExpand ℚ (M * p))).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) :=
+    RingHom.algebraMap_toAlgebra _
+  have hιS : ∀ w : LaurentSeries ℚ, coeffEmb K (qExpand ℚ (M * p) w)
+      = qExpand K p (coeffEmb K (qExpand ℚ M w)) := by
+    intro w
+    rw [← coeffEmb_qExpand, qExpand_qExpand]
+    exact congrArg (coeffEmb K) (qExpand_congr (Nat.mul_comm M p) w)
+  set T' : Multiset (LaurentSeries K) := M.divisors.val.bind
+    (fun a => ((Finset.range (M / a)).filter
+      (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+      (fun b => qExpand K p (sv K ((cycUnit (M * p) : Kˣ) ^ p) a b))) with hT'
+  have hT'card : Multiset.card T' = dedekindPsi M := by
+    rw [hT', Multiset.card_bind]
+    have h2 : M.divisors.val.map (Multiset.card ∘ fun a => (((Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+        (fun b => qExpand K p (sv K ((cycUnit (M * p) : Kˣ) ^ p) a b))))
+        = M.divisors.val.map (fun a => slotAt M (M / a)) := by
+      refine Multiset.map_congr rfl ?_
+      intro a ha
+      change Multiset.card (((Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+        (fun b => qExpand K p (sv K ((cycUnit (M * p) : Kˣ) ^ p) a b)))
+        = slotAt M (M / a)
+      rw [Multiset.card_map]
+      change ((Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).card = slotAt M (M / a)
+      unfold slotAt
+      rw [Nat.div_div_self (Nat.mem_divisors.mp (Finset.mem_val.mp ha)).1 hM0]
+    rw [h2]
+    change (∑ a ∈ M.divisors, slotAt M (M / a)) = dedekindPsi M
+    rw [Nat.sum_div_divisors M (slotAt M)]
+    exact slots_eq_dedekindPsi M hM0
+  have hT'nodup : T'.Nodup := by
+    rw [hT', Multiset.nodup_bind]
+    constructor
+    · intro a ha
+      refine Multiset.Nodup.map_on ?_ (Finset.filter _ _).nodup
+      intro b hb b' hb' hvv
+      have haM := (Nat.mem_divisors.mp (Finset.mem_val.mp ha)).1
+      have ha0 : a ≠ 0 := by
+        rintro rfl
+        exact hM0 (Nat.eq_zero_of_zero_dvd haM)
+      have hbr := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb)).1
+      have hbr' := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb')).1
+      have hba : b * a < M := by
+        calc b * a < M / a * a :=
+            (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr
+          _ = M := Nat.div_mul_cancel haM
+      have hba' : b' * a < M := by
+        calc b' * a < M / a * a :=
+            (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr'
+          _ = M := Nat.div_mul_cancel haM
+      have hsv : sv K ((cycUnit (M * p) : Kˣ) ^ p) a b
+          = sv K ((cycUnit (M * p) : Kˣ) ^ p) a b' :=
+        RingHom.injective (qExpand K p) hvv
+      exact (sv_inj hζM ha0 ha0 hba hba' hsv).2
+    · refine Multiset.Nodup.pairwise ?_ M.divisors.nodup
+      intro a ha a' ha' hne
+      change Disjoint (((Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+          (fun b => qExpand K p (sv K ((cycUnit (M * p) : Kˣ) ^ p) a b)))
+        (((Finset.range (M / a')).filter
+          (fun b => Nat.gcd (Nat.gcd a' b) (M / a') = 1)).val.map
+          (fun b => qExpand K p (sv K ((cycUnit (M * p) : Kˣ) ^ p) a' b)))
+      rw [Multiset.disjoint_left]
+      intro x hx hx'
+      rw [Multiset.mem_map] at hx hx'
+      obtain ⟨b, hb, hxb⟩ := hx
+      obtain ⟨b', hb', hxb'⟩ := hx'
+      have haM := (Nat.mem_divisors.mp (Finset.mem_val.mp ha)).1
+      have haM' := (Nat.mem_divisors.mp (Finset.mem_val.mp ha')).1
+      have ha0 : a ≠ 0 := by
+        rintro rfl
+        exact hM0 (Nat.eq_zero_of_zero_dvd haM)
+      have ha0' : a' ≠ 0 := by
+        rintro rfl
+        exact hM0 (Nat.eq_zero_of_zero_dvd haM')
+      have hbr := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb)).1
+      have hbr' := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb')).1
+      have hba : b * a < M := by
+        calc b * a < M / a * a :=
+            (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr
+          _ = M := Nat.div_mul_cancel haM
+      have hba' : b' * a' < M := by
+        calc b' * a' < M / a' * a' :=
+            (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0')).mpr hbr'
+          _ = M := Nat.div_mul_cancel haM'
+      have hvv : qExpand K p (sv K ((cycUnit (M * p) : Kˣ) ^ p) a b)
+          = qExpand K p (sv K ((cycUnit (M * p) : Kˣ) ^ p) a' b') := by
+        rw [hxb, ← hxb']
+      exact hne (sv_inj hζM ha0 ha0' hba hba'
+        (RingHom.injective (qExpand K p) hvv)).1
+  have hglue : ∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+      (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+      (Polynomial.X - Polynomial.C (qExpand K p (sv K ((cycUnit (M * p) : Kˣ) ^ p) a b)))
+      = (T'.map (fun r => Polynomial.X - Polynomial.C r)).prod := by
+    rw [hT', Multiset.map_bind, Multiset.prod_bind]
+    change (∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+        (Polynomial.X - Polynomial.C (qExpand K p
+          (sv K ((cycUnit (M * p) : Kˣ) ^ p) a b))))
+      = (M.divisors.val.map fun a => ((((Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+          (fun b => qExpand K p (sv K ((cycUnit (M * p) : Kˣ) ^ p) a b))).map
+          (fun r => Polynomial.X - Polynomial.C r)).prod).prod
+    simp only [Multiset.map_map, Function.comp]
+    rfl
+  have hroots : ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp
+      (qExpand ℚ (M * p))).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).roots = T' := by
+    rw [hidMB, hglue]
+    exact Polynomial.roots_multiset_prod_X_sub_C T'
+  set s : Finset (LaurentSeries K) := T'.toFinset with hs
+  have hscard : s.card = dedekindPsi M := by
+    rw [hs, Multiset.toFinset_card_of_nodup hT'nodup]
+    exact hT'card
+  obtain ⟨g, hg⟩ : ∃ g : Polynomial ℚ⟮jq⟯, Polynomial.aeval (jqN M) g = jqN p := by
+    have h1 := IntermediateField.adjoin_simple_toSubalgebra_of_isAlgebraic
+      hα.isAlgebraic
+    have h2 : jqN p ∈ Algebra.adjoin ℚ⟮jq⟯ ({jqN M} : Set (LaurentSeries ℚ)) := by
+      rw [← h1]
+      exact hmem
+    rw [Algebra.adjoin_singleton_eq_range_aeval] at h2
+    obtain ⟨g, hg⟩ := h2
+    exact ⟨g, hg⟩
+  set g' := g %ₘ (minpoly ℚ⟮jq⟯ (jqN M)) with hg'def
+  have hg' : Polynomial.aeval (jqN M) g' = jqN p := by
+    have hsplit := Polynomial.modByMonic_add_div g (minpoly ℚ⟮jq⟯ (jqN M))
+    have h4 := congrArg (Polynomial.aeval (jqN M)) hsplit
+    rw [map_add, map_mul, minpoly.aeval, zero_mul, add_zero] at h4
+    rw [hg'def, h4]
+    exact hg
+  have hdegpos : 0 < (minpoly ℚ⟮jq⟯ (jqN M)).natDegree := by
+    rw [hdeg]
+    exact dedekindPsi_pos hM0
+  have hg'deg : g'.natDegree < s.card := by
+    rw [hscard, ← hdeg]
+    rcases eq_or_ne g' 0 with h0 | h0
+    · rw [h0, Polynomial.natDegree_zero]
+      exact hdegpos
+    · exact Polynomial.natDegree_lt_natDegree h0
+        (Polynomial.degree_modByMonic_lt g (minpoly.monic hα))
+  have hval : ∀ y ∈ s, Polynomial.aeval y g'
+      = coeffEmb K (qExpand ℚ (M * p) (jqN p)) := by
+    intro y hy
+    have hyT' : y ∈ T' := Multiset.mem_toFinset.mp hy
+    obtain ⟨a₀, ha₀, hy2⟩ := Multiset.mem_bind.mp hyT'
+    obtain ⟨b₀, hb₀, hyval⟩ := Multiset.mem_map.mp hy2
+    have hyS : y ∈ (qExpand K p).fieldRange := by
+      rw [← hyval]
+      exact RingHom.mem_fieldRange.mpr ⟨sv K ((cycUnit (M * p) : Kˣ) ^ p) a₀ b₀, rfl⟩
+    have hy_ar : y ∈ (minpoly ℚ⟮jq⟯ (jqN M)).aroots (LaurentSeries K) := by
+      rw [Polynomial.aroots_def, halg, hroots]
+      exact hyT'
+    obtain ⟨ψy, hψy⟩ : ∃ ψy : ℚ⟮jq⟯⟮jqN M⟯ →ₐ[ℚ⟮jq⟯] LaurentSeries K,
+        ψy (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN M)) = y :=
+      ⟨(IntermediateField.algHomAdjoinIntegralEquiv ℚ⟮jq⟯ hα).symm ⟨y, hy_ar⟩,
+        IntermediateField.algHomAdjoinIntegralEquiv_symm_apply_gen ℚ⟮jq⟯ hα ⟨y, hy_ar⟩⟩
+    have hψgen : ∀ h : jqN M ∈ IntermediateField.adjoin ℚ⟮jq⟯
+        ({jqN M} : Set (LaurentSeries ℚ)), ψy ⟨jqN M, h⟩ = y := by
+      intro h
+      exact hψy
+    have himg : ∀ (x : LaurentSeries ℚ)
+        (hx : x ∈ IntermediateField.adjoin ℚ⟮jq⟯ ({jqN M} : Set (LaurentSeries ℚ))),
+        ψy ⟨x, hx⟩ ∈ (qExpand K p).fieldRange := by
+      intro x hx
+      induction hx using IntermediateField.adjoin_induction with
+      | mem z hz =>
+          rw [Set.mem_singleton_iff] at hz
+          subst hz
+          rw [hψgen]
+          exact hyS
+      | algebraMap z =>
+          change ψy (algebraMap ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN M⟯ z) ∈ (qExpand K p).fieldRange
+          rw [AlgHom.commutes, halg]
+          change coeffEmb K (qExpand ℚ (M * p)
+            ((algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) z)) ∈ (qExpand K p).fieldRange
+          rw [hιS]
+          exact RingHom.mem_fieldRange.mpr ⟨_, rfl⟩
+      | add x₁ x₂ hx₁ hx₂ ih₁ ih₂ =>
+          change ψy ⟨x₁ + x₂, add_mem hx₁ hx₂⟩ ∈ (qExpand K p).fieldRange
+          rw [show (⟨x₁ + x₂, add_mem hx₁ hx₂⟩ : ℚ⟮jq⟯⟮jqN M⟯)
+            = ⟨x₁, hx₁⟩ + ⟨x₂, hx₂⟩ from rfl, map_add]
+          exact Subfield.add_mem _ ih₁ ih₂
+      | mul x₁ x₂ hx₁ hx₂ ih₁ ih₂ =>
+          change ψy ⟨x₁ * x₂, mul_mem hx₁ hx₂⟩ ∈ (qExpand K p).fieldRange
+          rw [show (⟨x₁ * x₂, mul_mem hx₁ hx₂⟩ : ℚ⟮jq⟯⟮jqN M⟯)
+            = ⟨x₁, hx₁⟩ * ⟨x₂, hx₂⟩ from rfl, map_mul]
+          exact Subfield.mul_mem _ ih₁ ih₂
+      | inv x₁ hx₁ ih₁ =>
+          show ψy ⟨x₁⁻¹, inv_mem hx₁⟩ ∈ (qExpand K p).fieldRange
+          rw [show (⟨x₁⁻¹, inv_mem hx₁⟩ : ℚ⟮jq⟯⟮jqN M⟯)
+            = (⟨x₁, hx₁⟩ : ℚ⟮jq⟯⟮jqN M⟯)⁻¹ from rfl, map_inv₀]
+          exact Subfield.inv_mem _ ih₁
+    have hx_pS : ψy ⟨jqN p, hmem⟩ ∈ (qExpand K p).fieldRange := himg _ hmem
+    have hx_proot : ((minpoly ℚ⟮jq⟯ (jqN p)).map (((coeffEmb K).comp
+        (qExpand ℚ (M * p))).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).IsRoot
+        (ψy ⟨jqN p, hmem⟩) := by
+      have h1 : Polynomial.aeval (⟨jqN p, hmem⟩ : ℚ⟮jq⟯⟮jqN M⟯)
+          (minpoly ℚ⟮jq⟯ (jqN p)) = 0 := by
+        refine aeval_intermediateField_eq_zero ?_
+        change Polynomial.aeval (jqN p) (minpoly ℚ⟮jq⟯ (jqN p)) = 0
+        exact minpoly.aeval _ _
+      have h2 := Polynomial.aeval_algHom_apply ψy (⟨jqN p, hmem⟩ : ℚ⟮jq⟯⟮jqN M⟯)
+        (minpoly ℚ⟮jq⟯ (jqN p))
+      rw [h1, map_zero] at h2
+      rw [Polynomial.aeval_def, halg, Polynomial.eval₂_eq_eval_map] at h2
+      exact h2
+    rw [hidpB, Polynomial.IsRoot, Polynomial.eval_prod] at hx_proot
+    obtain ⟨α, hαmem, hα0⟩ := Finset.prod_eq_zero_iff.mp hx_proot
+    rw [Polynomial.eval_prod] at hα0
+    obtain ⟨β, hβmem, hβ0⟩ := Finset.prod_eq_zero_iff.mp hα0
+    rw [Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, sub_eq_zero] at hβ0
+    obtain ⟨hαdvd, -⟩ := Nat.mem_divisors.mp hαmem
+    obtain ⟨hβr, -⟩ := Finset.mem_filter.mp hβmem
+    rw [Finset.mem_range] at hβr
+    rcases (Nat.Prime.eq_one_or_self_of_dvd hp.out α hαdvd) with hα1 | hα2
+    · subst hα1
+      exfalso
+      have : NeZero (1 : ℕ) := ⟨one_ne_zero⟩
+      have hv1 : qExpand K M (sv K ((cycUnit (M * p) : Kˣ) ^ M) 1 β)
+          = TS K M (((cycUnit (M * p) : Kˣ) ^ M) ^ (β * 1)) := by
+        rw [sv_eq_TS, qExpand_TS]
+        exact TS_congr' (by ring) rfl
+      obtain ⟨w, hw⟩ := RingHom.mem_fieldRange.mp hx_pS
+      have hw2 : qExpand K p w = TS K M (((cycUnit (M * p) : Kˣ) ^ M) ^ (β * 1)) := by
+        rw [hw, hβ0, hv1]
+      have hnd : ¬ ((p : ℤ) ∣ (-(M : ℤ))) := by
+        rw [dvd_neg, Int.natCast_dvd_natCast]
+        exact hpM
+      have hz1 : (qExpand K p w).coeff (-(M : ℤ)) = 0 :=
+        qExpand_coeff_of_not_dvd (R := K) (N := p) w hnd
+      have hz2 : (TS K M (((cycUnit (M * p) : Kˣ) ^ M) ^ (β * 1))).coeff (-(M : ℤ))
+          = (((((cycUnit (M * p) : Kˣ) ^ M) ^ (β * 1))⁻¹ : Kˣ) : K) :=
+        TS_coeff_neg M _
+      rw [hw2, hz2] at hz1
+      exact Units.ne_zero _ hz1
+    · have hα2' := hα2.symm
+      subst hα2'
+      have hβ0' : β = 0 := by
+        have h3 : p / p = 1 := Nat.div_self hp.out.pos
+        omega
+      subst hβ0'
+      have hsp : qExpand K M (sv K ((cycUnit (M * p) : Kˣ) ^ M) p 0)
+          = coeffEmb K (qExpand ℚ (M * p) (jqN p)) := by
+        rw [sv_eq_TS, qExpand_TS, iota_jqN (M * p) p]
+        exact TS_congr' (by ring) (by rw [zero_mul, pow_zero])
+      have hx_pval : ψy ⟨jqN p, hmem⟩ = coeffEmb K (qExpand ℚ (M * p) (jqN p)) := by
+        rw [hβ0, hsp]
+      have hgE : Polynomial.aeval (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN M)) g'
+          = (⟨jqN p, hmem⟩ : ℚ⟮jq⟯⟮jqN M⟯) := by
+        have h3 := Polynomial.aeval_algHom_apply (IntermediateField.val ℚ⟮jq⟯⟮jqN M⟯)
+          (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN M)) g'
+        refine Subtype.ext ?_
+        change ((Polynomial.aeval (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN M)) g' :
+          ℚ⟮jq⟯⟮jqN M⟯) : LaurentSeries ℚ) = jqN p
+        rw [show ((Polynomial.aeval (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN M)) g' :
+          ℚ⟮jq⟯⟮jqN M⟯) : LaurentSeries ℚ)
+          = (IntermediateField.val ℚ⟮jq⟯⟮jqN M⟯)
+            (Polynomial.aeval (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN M)) g')
+          from rfl, ← h3]
+        exact hg'
+      rw [← hψy, Polynomial.aeval_algHom_apply, hgE, hx_pval]
+  obtain ⟨z, hz⟩ := mem_range_of_eval_eq_const g'
+    (coeffEmb K (qExpand ℚ (M * p) (jqN p))) s hg'deg hval
+  rw [halg] at hz
+  have hzval : (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) z = jqN p := by
+    apply RingHom.injective ((coeffEmb K).comp (qExpand ℚ (M * p)))
+    exact hz
+  have hjpF : jqN p ∈ ℚ⟮jq⟯ := by
+    rw [← hzval]
+    exact z.2
+  have hbot : IntermediateField.adjoin ℚ⟮jq⟯ ({jqN p} : Set (LaurentSeries ℚ))
+      = (⊥ : IntermediateField ℚ⟮jq⟯ (LaurentSeries ℚ)) := by
+    rw [IntermediateField.adjoin_simple_eq_bot_iff, IntermediateField.mem_bot]
+    exact ⟨⟨jqN p, hjpF⟩, rfl⟩
+  have h1 : Module.finrank ℚ⟮jq⟯
+      (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN p} : Set (LaurentSeries ℚ))) = 1 := by
+    rw [hbot]
+    exact IntermediateField.finrank_bot
+  have h2 := ModularCurve.finrank_adjoin_jqN_eq_of_prime p
+  rw [h1] at h2
+  have h3 := hp.out.two_le
+  omega
+
+end NonMem0
+end ModularCurve.W1
+
+private theorem ModularCurve.minpoly_jqN_map_eq_prod_slots {K : Type*} [Field K] [Algebra ℚ K]
+    (M : ℕ) [NeZero M] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) M)
+    (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+          (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+            ({jqN d} : Set (LaurentSeries ℚ))) = dedekindPsi d
+        ∧ modularFunctionField d = modularFunctionFieldFull d) :
+    (minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN M)).map
+        (((coeffEmb K).comp (qExpand ℚ M)).comp
+          (algebraMap (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+            (LaurentSeries ℚ)))
+      = ∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+          (Polynomial.X - Polynomial.C (if h : a = 0 then 0 else
+            letI : NeZero a := ⟨h⟩
+            qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)))) :=
+  ModularCurve.W1.rval_aux M ζ hζ hall
+
+private theorem ModularCurve.jqN_prime_not_mem_full' (M : ℕ) [NeZero M] (p : ℕ)
+    [hp : Fact (Nat.Prime p)] (hpM : ¬ p ∣ M)
+    (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+          (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+            ({jqN d} : Set (LaurentSeries ℚ))) = dedekindPsi d
+        ∧ modularFunctionField d = modularFunctionFieldFull d) :
+    jqN p ∉ modularFunctionFieldFull M := by
+  intro hmem0
+  obtain ⟨-, hgM⟩ := hall M dvd_rfl
+  have hmem : jqN p ∈ IntermediateField.adjoin
+      (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      ({jqN M} : Set (LaurentSeries ℚ)) := by
+    rw [← hgM] at hmem0
+    exact ModularCurve.W1.mem_adjoin_jqN_of_mem_mff hmem0
+  exact ModularCurve.W1.jqN_prime_not_mem_adjoin M p hpM hall hmem
+
+end
+
+open ModularCurve in
+theorem solution
+    (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (hpM : ¬ p ∣ M)
+    (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank (IntermediateField.adjoin ℚ {jq})
+        (IntermediateField.adjoin (IntermediateField.adjoin ℚ {jq}) {jqN d}) = dedekindPsi d ∧
+      modularFunctionField d = modularFunctionFieldFull d) :
+    jqN p ∉ modularFunctionFieldFull M :=
+  ModularCurve.jqN_prime_not_mem_full' M p hpM hall
+
+end privateSection
+
+public section publicSection
+
+open ModularCurve
+theorem ModularCurve.jqN_prime_not_mem_full
+    (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (hpM : ¬ p ∣ M)
+    (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank (IntermediateField.adjoin ℚ {jq})
+        (IntermediateField.adjoin (IntermediateField.adjoin ℚ {jq}) {jqN d}) = dedekindPsi d ∧
+      modularFunctionField d = modularFunctionFieldFull d) :
+    jqN p ∉ modularFunctionFieldFull M :=
+  solution M p hpM hall
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_laurentBaseChange_adjoin.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_laurentBaseChange_adjoin.lean
new file mode 100644
index 0000000000..ebbfd0bc99
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_laurentBaseChange_adjoin.lean
@@ -0,0 +1,103 @@
+/-
+Based on Prove2Me node ModularCurve.laurentBaseChange_adjoin
+(3207623f-def9-5013-a768-e131bf7989de) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ca4282c8-d283-5039-9ae1-cf0b341841e6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Base change of a Laurent-series subfield commutes with adjunction
+
+Theorem statement: `ModularCurve.laurentBaseChange_adjoin` (`3207623f-def9-5013-a768-e131bf7989de`),
+by Claude, 2026-09-05.
+
+Proof: submission `ca4282c8-d283-5039-9ae1-cf0b341841e6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbb{Q}$-algebra structure, and let $S$ be an arbitrary
+subset of the field $\mathbb{Q}((q))$ of formal Laurent series over $\mathbb{Q}$. Write $\iota_L =$
+[`ModularCurve.coeffEmb L`](def/ModularCurve_LaurentCoeff.html#L81) for the ring homomorphism
+$\mathbb{Q}((q)) \to L((q))$ obtained by applying the structure map $\mathbb{Q} \to L$ to each
+coefficient (the instance of [`ModularCurve.coeffMap`](def/ModularCurve_LaurentCoeff.html#L16) at
+$\mathrm{algebraMap}\ \mathbb{Q}\ L$), and recall that for an intermediate field $F_0$ of
+$\mathbb{Q}((q))/\mathbb{Q}$ the base change [`ModularCurve.laurentBaseChange L
+F₀`](def/ModularCurve_LaurentCoeff.html#L103) is by definition the intermediate field of $L((q))/L$
+generated over $L$ by the set-theoretic image $\iota_L(F_0)$. The theorem asserts the equality of
+intermediate fields of $L((q))/L$ $$\mathrm{laurentBaseChange}\ L\ \bigl(\mathbb{Q}(S)\bigr) =
+L\bigl(\iota_L(S)\bigr),$$ that is, adjoining to $L$ the coefficientwise image of the subfield of
+$\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by $S$ gives the same subfield of $L((q))$ as
+adjoining to $L$ the image $\iota_L(S)$ of the generating set itself.
+
+This is the compatibility of the coefficient-extension operation on subfields of formal Laurent
+series with field adjunction: base change may be computed on generators. It is used throughout the
+treatment of $q$-expansions of modular functions, where function fields such as $\mathbb{Q}(j(q^d) :
+d \mid M)$ are given by explicit generators and must be compared with their base changes to a larger
+field of coefficients.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_laurentBaseChange_adjoin.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_laurentBaseChange_adjoin
+
+open ModularCurve IntermediateField Polynomial
+
+theorem solution (L : Type*) [Field L] [Algebra ℚ L] (S : Set (LaurentSeries ℚ)) :
+    ModularCurve.laurentBaseChange L (IntermediateField.adjoin ℚ S) = IntermediateField.adjoin L
+      (ModularCurve.coeffEmb L '' S) := by
+  apply le_antisymm
+  · rw [laurentBaseChange, IntermediateField.adjoin_le_iff]
+    rintro _ ⟨y, hy, rfl⟩
+    have hle : (IntermediateField.adjoin ℚ S).toSubfield ≤
+        (IntermediateField.adjoin L (coeffEmb L '' S)).toSubfield.comap (coeffEmb L) := by
+      rw [IntermediateField.adjoin_toSubfield]
+      refine Subfield.closure_le.mpr ?_
+      rintro x (⟨c, rfl⟩ | hx)
+      · rw [SetLike.mem_coe, Subfield.mem_comap]
+        have : coeffEmb L (algebraMap ℚ (LaurentSeries ℚ) c)
+            = algebraMap L (LaurentSeries L) (algebraMap ℚ L c) := by
+          rw [algebraMap_apply_eq_single, coeffEmb, coeffMap_single,
+            ← algebraMap_laurentSeries_eq_single]
+        rw [this]
+        exact (IntermediateField.adjoin L (coeffEmb L '' S)).algebraMap_mem _
+      · rw [SetLike.mem_coe, Subfield.mem_comap]
+        exact IntermediateField.subset_adjoin L _ ⟨x, hx, rfl⟩
+    exact hle hy
+  · rw [IntermediateField.adjoin_le_iff]
+    rintro _ ⟨y, hy, rfl⟩
+    exact coeffEmb_mem_laurentBaseChange L (IntermediateField.subset_adjoin ℚ S hy)
+
+end S_ModularCurve_laurentBaseChange_adjoin
+end P2MW
+export P2MW.S_ModularCurve_laurentBaseChange_adjoin (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.laurentBaseChange_adjoin (L : Type*) [Field L] [Algebra ℚ L]
+    (S : Set (LaurentSeries ℚ)) :
+    ModularCurve.laurentBaseChange L (IntermediateField.adjoin ℚ S) = IntermediateField.adjoin L
+      (ModularCurve.coeffEmb L '' S) :=
+  solution L S
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_laurentBaseChange_adjoin_pair.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_laurentBaseChange_adjoin_pair.lean
new file mode 100644
index 0000000000..d89592df96
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_laurentBaseChange_adjoin_pair.lean
@@ -0,0 +1,95 @@
+/-
+Based on Prove2Me node ModularCurve.laurentBaseChange_adjoin_pair
+(c2e0ccae-2e37-5fcb-85d3-6ec8e18edfe0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission eeb9d044-5d89-5b95-8cc2-178a7f9f217b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_DegeneracyTower
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_modularFunctionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration_iff_full_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_mono
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_jqNModC_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jqN
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+
+/-!
+# Base change of the full divisor-expansion field equals L(j,j_M)
+
+Theorem statement: `ModularCurve.laurentBaseChange_adjoin_pair`
+(`c2e0ccae-2e37-5fcb-85d3-6ec8e18edfe0`), by Claude, 2026-09-05.
+
+Proof: submission `eeb9d044-5d89-5b95-8cc2-178a7f9f217b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbb{Q}$-algebra structure and let $M$ be a nonzero natural
+number. Assume `FunctionFieldGeneration M`, i.e. for every nonzero divisor $d$ of $M$ the series $q
+\mapsto$ `qExpand ℚ d jq` (the Laurent series over $\mathbb{Q}$ obtained from `jq` by the
+substitution $q \mapsto q^{d}$, formally the rescaling of the Hahn-series support by multiplication
+by $d$) lies in the intermediate field of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by `jq` and
+`qExpand ℚ M jq`. Then the base change to $L$ of `modularFunctionFieldFull M`, namely the
+intermediate field of $L((q))$ generated over $L$ by the coefficientwise image under $\mathbb{Q} \to
+L$ of the subfield $\mathbb{Q}(\{\,$`qExpand ℚ d jq` $: d \mid M,\ d \neq 0\})$ of
+$\mathbb{Q}((q))$, coincides with the intermediate field of $L((q))$ generated over $L$ by the two
+elements `jqModC L` $= q^{-1}\cdot$ (image in $L$ of the integral power series
+$E_4^{3}\cdot$`dedekindEtaUnitInv`), the $q$-expansion of $j$ with coefficients in $L$, and `jqNModC
+L M` $=$ `qExpand L M (jqModC L)`, its substitution $q \mapsto q^{M}$.
+
+This is the statement that the function field of $X_0(M)$ over a field $L$ of characteristic zero,
+modelled as a subfield of $L((q))$ spanned by all divisor expansions $j(q^{d})$ with $d \mid M$, is
+generated by the two functions $j(q)$ and $j(q^{M})$, once generation is known over $\mathbb{Q}$. It
+supplies the two-generator description of the base-changed function field used throughout the later
+analysis of places, nodes and specialisations of the $q$-expansion model of $X_0(M)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_laurentBaseChange_adjoin_pair.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+open ModularCurve W1 PhiGen
+
+private theorem ModularCurve.laurentBaseChange_adjoin_pair' (L : Type*) [Field L] [Algebra ℚ L]
+    (M : ℕ) [NeZero M] (hgenQ : FunctionFieldGeneration M) :
+    laurentBaseChange L (modularFunctionFieldFull M) =
+      IntermediateField.adjoin L {jqModC L, jqNModC L M} := by
+  rw [(functionFieldGeneration_iff_full_eq M).mp hgenQ, laurentBaseChange_modularFunctionField]
+  rfl
+
+theorem solution (L : Type*) [Field L] [Algebra ℚ L] (M : ℕ) [NeZero M]
+    (hgenQ : FunctionFieldGeneration M) :
+    laurentBaseChange L (modularFunctionFieldFull M) =
+      IntermediateField.adjoin L {jqModC L, jqNModC L M} :=
+  ModularCurve.laurentBaseChange_adjoin_pair' L M hgenQ
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.laurentBaseChange_adjoin_pair (L : Type*) [Field L] [Algebra ℚ L] (M : ℕ)
+    [NeZero M] (hgenQ : FunctionFieldGeneration M) :
+    laurentBaseChange L (modularFunctionFieldFull M) =
+      IntermediateField.adjoin L {jqModC L, jqNModC L M} :=
+  solution L M hgenQ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_laurentBaseChange_modularFunctionField.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_laurentBaseChange_modularFunctionField.lean
new file mode 100644
index 0000000000..5ae6edbd72
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_laurentBaseChange_modularFunctionField.lean
@@ -0,0 +1,113 @@
+/-
+Based on Prove2Me node ModularCurve.laurentBaseChange_modularFunctionField
+(965445f6-eb6c-557d-834d-71e1f7ea99ac) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 506d7936-d4d7-5270-83b8-310c8cb62fbb
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jqN
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Base change of the modular function field along ℚ↪ L
+
+Theorem statement: `ModularCurve.laurentBaseChange_modularFunctionField`
+(`965445f6-eb6c-557d-834d-71e1f7ea99ac`), by Claude, 2026-09-05.
+
+Proof: submission `506d7936-d4d7-5270-83b8-310c8cb62fbb`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbb{Q}$-algebra structure and let $N$ be a nonzero natural
+number. Inside the field $L((q))$ of Laurent series over $L$, consider two intermediate fields of
+$L((q))/L$. The first is `laurentBaseChange L (modularFunctionField N)`: starting from the
+intermediate field `modularFunctionField N` of $\mathbb{Q}((q))/\mathbb{Q}$ generated over
+$\mathbb{Q}$ by the two elements `jq` and `qExpand ℚ N jq`, where `qExpand R N` is the ring
+endomorphism of $R((q))$ obtained by multiplying all exponents by $N$ (substitution $q \mapsto
+q^{N}$), one takes the image of this field under the coefficient embedding `coeffEmb L : ℚ((q)) →
+L((q))` induced by $\mathbb{Q} \to L$, and adjoins that image to $L$. The second is
+`modularFunctionFieldC L N`, the subfield of $L((q))$ generated over $L$ by `jqModC L`, namely
+$q^{-1}$ times the power series `jNum` with coefficients cast into $L$, together with `jqNModC L N =
+qExpand L N (jqModC L)`. The assertion is that these two intermediate fields of $L((q))/L$ coincide.
+
+This identifies the base change to $L$ of the two-generator modular function field $\mathbb{Q}(j(q),
+j(q^{N})) \subseteq \mathbb{Q}((q))$ with the field $L(j(q), j(q^{N})) \subseteq L((q))$ generated
+by the same $q$-expansions read with coefficients in $L$; no statement is made about the field
+generated by $j(q^{d})$ for all divisors $d \mid N$. It serves as the compatibility step allowing
+arguments about $X_0(N)$ and its function field to be transported from $\mathbb{Q}$ to an arbitrary
+field of characteristic zero, and is used in the construction of fibre models on cusp charts and in
+the study of the cuspidal divisor class.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_laurentBaseChange_modularFunctionField.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_laurentBaseChange_modularFunctionField
+
+open ModularCurve IntermediateField HahnSeries
+
+theorem solution (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    ModularCurve.laurentBaseChange L (ModularCurve.modularFunctionField N) =
+      ModularCurve.modularFunctionFieldC L N := by
+  apply le_antisymm
+  · change IntermediateField.adjoin L (⇑(coeffEmb L) '' (modularFunctionField N : Set (LaurentSeries
+      ℚ)))
+      ≤ modularFunctionFieldC L N
+    rw [IntermediateField.adjoin_le_iff]
+    rintro _ ⟨x, hx, rfl⟩
+    change x ∈ IntermediateField.adjoin ℚ {jq, qExpand ℚ N jq} at hx
+    induction hx using IntermediateField.adjoin_induction with
+    | mem x hx =>
+        rcases hx with rfl | rfl
+        · rw [coeffEmb_jq]; exact jqModC_mem L N
+        · rw [show qExpand ℚ N jq = jqN N from rfl, coeffEmb_jqN]; exact jqNModC_mem L N
+    | algebraMap c =>
+        have h : (coeffEmb L).comp (algebraMap ℚ (LaurentSeries ℚ))
+            = (algebraMap L (LaurentSeries L)).comp (algebraMap ℚ L) := RingHom.ext_rat _ _
+        have hc := congrArg (fun f : ℚ →+* LaurentSeries L => f c) h
+        simp only [RingHom.coe_comp, Function.comp_apply] at hc
+        simp only [SetLike.mem_coe, hc]
+        exact (modularFunctionFieldC L N).algebraMap_mem _
+    | add x y _ _ hx hy => simpa only [SetLike.mem_coe, map_add] using add_mem hx hy
+    | inv x _ hx => simpa only [SetLike.mem_coe, map_inv₀] using inv_mem hx
+    | mul x y _ _ hx hy => simpa only [SetLike.mem_coe, map_mul] using mul_mem hx hy
+  · change IntermediateField.adjoin L {jqModC L, jqNModC L N}
+      ≤ IntermediateField.adjoin L (⇑(coeffEmb L) '' (modularFunctionField N : Set (LaurentSeries
+        ℚ)))
+    apply IntermediateField.adjoin.mono
+    rintro _ (rfl | rfl)
+    · exact ⟨jq, jq_mem N, coeffEmb_jq L⟩
+    · exact ⟨qExpand ℚ N jq, jqN_mem N, coeffEmb_jqN L N⟩
+
+end S_ModularCurve_laurentBaseChange_modularFunctionField
+end P2MW
+export P2MW.S_ModularCurve_laurentBaseChange_modularFunctionField (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.laurentBaseChange_modularFunctionField (L : Type*) [Field L] [Algebra ℚ L]
+    (N : ℕ) [NeZero N] :
+    ModularCurve.laurentBaseChange L (ModularCurve.modularFunctionField N) =
+      ModularCurve.modularFunctionFieldC L N :=
+  solution L N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_laurentBaseChange_modularFunctionFieldFull.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_laurentBaseChange_modularFunctionFieldFull.lean
new file mode 100644
index 0000000000..76dda156e5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_laurentBaseChange_modularFunctionFieldFull.lean
@@ -0,0 +1,99 @@
+/-
+Based on Prove2Me node ModularCurve.laurentBaseChange_modularFunctionFieldFull
+(46aa8042-66c4-5557-9b26-2d101ec70a03) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 361164a3-bff9-517a-b4c0-278fd2fd4bde
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_adjoin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jqN
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Base change of the full modular function field to L
+
+Theorem statement: `ModularCurve.laurentBaseChange_modularFunctionFieldFull`
+(`46aa8042-66c4-5557-9b26-2d101ec70a03`), by Claude, 2026-09-05.
+
+Proof: submission `361164a3-bff9-517a-b4c0-278fd2fd4bde`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field of characteristic zero, i.e. a field equipped with a $\mathbb{Q}$-algebra
+structure, and let $N$ be a nonzero natural number. On the $\mathbb{Q}$-side,
+[`ModularCurve.modularFunctionFieldFull N`](def/ModularCurve_X0.html#L305) is the intermediate field
+of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by the set `divisorExpansions N`, namely by the
+elements $\mathrm{qExpand}\,\mathbb{Q}\,d\,(jq)$ for all nonzero $d$ dividing $N$, where
+$\mathrm{qExpand}\,d$ is the ring endomorphism of a Laurent series field substituting $q \mapsto
+q^{d}$ (domain embedding along multiplication by $d$ on $\mathbb{Z}$). Its base change
+[`ModularCurve.laurentBaseChange L`](def/ModularCurve_LaurentCoeff.html#L103) is the intermediate
+field of $L((q))$ generated over $L$ by the image of this field under `coeffEmb L`, the
+coefficientwise ring homomorphism $\mathbb{Q}((q)) \to L((q))$ induced by $\mathbb{Q} \to L$. The
+theorem asserts that this base-changed field is equal to the intermediate field of $L((q))$
+generated over $L$ by the set of all [`ModularCurve.jqNModC L d`](def/ModularCurve_JqCoeff.html#L18)
+with $d$ nonzero and $d \mid N$, where $\mathrm{jqNModC}\,L\,d = \mathrm{qExpand}\,L\,d$ applied to
+$\mathrm{jqModC}\,L = q^{-1}\cdot(\text{the } j\text{-numerator power series with coefficients
+mapped into } L)$.
+
+This identifies the base change to $L$ of the function field $\mathbb{Q}(j(q^{d}) : d \mid N)$
+attached to $X_0(N)$-type data as the field generated over $L$ by the corresponding divisor
+expansions with $L$-coefficients, so that subsequent work with degeneracy maps, Hecke
+correspondences and $j$-charts can be carried out directly over $L$. It is used in the construction
+of integral lifts of $j$-charts, in degree computations for the generators $\bar{j}$, and in the
+comparison of $q$-expansions under slash operators.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_laurentBaseChange_modularFunctionFieldFull.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_laurentBaseChange_modularFunctionFieldFull
+
+open ModularCurve IntermediateField Polynomial
+
+theorem solution (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    ModularCurve.laurentBaseChange L (ModularCurve.modularFunctionFieldFull N) =
+      IntermediateField.adjoin L {x | ∃ (d : ℕ) (_ : NeZero d), d ∣ N ∧ x = ModularCurve.jqNModC L
+      d} := by
+  rw [modularFunctionFieldFull, laurentBaseChange_adjoin]
+  congr 1
+  ext x
+  simp only [Set.mem_image, divisorExpansions, Set.mem_ofPred_eq]
+  constructor
+  · rintro ⟨y, ⟨d, hd, hdvd, rfl⟩, rfl⟩
+    exact ⟨d, hd, hdvd, (coeffEmb_jqN L d)⟩
+  · rintro ⟨d, hd, hdvd, rfl⟩
+    exact ⟨qExpand ℚ d jq, ⟨d, hd, hdvd, rfl⟩, coeffEmb_jqN L d⟩
+
+end S_ModularCurve_laurentBaseChange_modularFunctionFieldFull
+end P2MW
+export P2MW.S_ModularCurve_laurentBaseChange_modularFunctionFieldFull (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.laurentBaseChange_modularFunctionFieldFull (L : Type*) [Field L] [Algebra ℚ L]
+    (N : ℕ) [NeZero N] :
+    ModularCurve.laurentBaseChange L (ModularCurve.modularFunctionFieldFull N) =
+      IntermediateField.adjoin L {x | ∃ (d : ℕ) (_ : NeZero d), d ∣ N ∧ x = ModularCurve.jqNModC L
+      d} :=
+  solution L N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_laurentBaseChange_mono.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_laurentBaseChange_mono.lean
new file mode 100644
index 0000000000..c28d4de719
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_laurentBaseChange_mono.lean
@@ -0,0 +1,80 @@
+/-
+Based on Prove2Me node ModularCurve.laurentBaseChange_mono
+(0923932a-1374-5869-8782-f470397673eb) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4bf38222-df92-50f9-89db-71cff8f8e801
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Monotonicity of Laurent-coefficient base change
+
+Theorem statement: `ModularCurve.laurentBaseChange_mono` (`0923932a-1374-5869-8782-f470397673eb`),
+by Claude, 2026-09-05.
+
+Proof: submission `4bf38222-df92-50f9-89db-71cff8f8e801`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbb{Q}$-algebra structure, and let $F_0 \le F_1$ be
+intermediate fields of the extension $\mathbb{Q}((q))/\mathbb{Q}$, where $\mathbb{Q}((q))$ denotes
+the field of formal Laurent series `LaurentSeries ℚ`. Write $\iota_L =$ `coeffEmb L` for the
+coefficientwise ring homomorphism $\mathbb{Q}((q)) \to L((q))$ obtained by applying `coeffMap` to
+the structure map $\mathbb{Q} \to L$, i.e. $\sum_k a_k q^k \mapsto \sum_k a_k q^k$ with coefficients
+pushed along $\mathbb{Q} \to L$. For an intermediate field $F$ of $\mathbb{Q}((q))/\mathbb{Q}$,
+`laurentBaseChange L F` is the intermediate field of $L((q))/L$ generated over $L$ by the image
+$\iota_L(F)$, that is `IntermediateField.adjoin L (ι_L '' F)`. The assertion is that this
+construction is monotone: from $F_0 \le F_1$ it follows that `laurentBaseChange L F₀ ≤
+laurentBaseChange L F₁` as intermediate fields of $L((q))/L$.
+
+This records that forming the compositum $L \cdot \iota_L(F)$ inside $L((q))$ preserves inclusions
+of subfields of $\mathbb{Q}((q))$; it is used throughout the treatment of $q$-expansion fields of
+modular curves, where inclusions between the fields attached to various levels are transported to
+inclusions between their base changes to $L$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_laurentBaseChange_mono.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_laurentBaseChange_mono
+
+open ModularCurve IntermediateField HahnSeries
+
+theorem solution (L : Type*) [Field L] [Algebra ℚ L] {F₀ F₁ : IntermediateField ℚ (LaurentSeries ℚ)}
+    (h : F₀ ≤ F₁) :
+    ModularCurve.laurentBaseChange L F₀ ≤ ModularCurve.laurentBaseChange L F₁ :=
+  by
+  rw [laurentBaseChange, IntermediateField.adjoin_le_iff]
+  rintro _ ⟨y, hy, rfl⟩
+  exact coeffEmb_mem_laurentBaseChange L (h hy)
+
+end S_ModularCurve_laurentBaseChange_mono
+end P2MW
+export P2MW.S_ModularCurve_laurentBaseChange_mono (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.laurentBaseChange_mono (L : Type*) [Field L] [Algebra ℚ L]
+    {F₀ F₁ : IntermediateField ℚ (LaurentSeries ℚ)} (h : F₀ ≤ F₁) :
+    ModularCurve.laurentBaseChange L F₀ ≤ ModularCurve.laurentBaseChange L F₁ :=
+  solution L h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_laurentBaseChange_qExpFunctionFieldC_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_laurentBaseChange_qExpFunctionFieldC_eq.lean
new file mode 100644
index 0000000000..0c2c97afac
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_laurentBaseChange_qExpFunctionFieldC_eq.lean
@@ -0,0 +1,171 @@
+/-
+Based on Prove2Me node ModularCurve.laurentBaseChange_qExpFunctionFieldC_eq
+(5920f53d-ca89-5169-bd10-9d9a0ae8a631) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9012c10f-067f-57da-a3c0-eab06f24dd7c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Base change of the q-expansion function field
+
+Theorem statement: `ModularCurve.laurentBaseChange_qExpFunctionFieldC_eq`
+(`5920f53d-ca89-5169-bd10-9d9a0ae8a631`), by Claude, 2026-09-05.
+
+Proof: submission `9012c10f-067f-57da-a3c0-eab06f24dd7c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbf{Q}$-algebra structure and let $\Gamma$ be a subgroup of
+$\mathrm{SL}_2(\mathbf{Z})$. For a field $K$ write $\mathrm{intSeriesC}\,K$ for the map sending an
+integral power series to its image in $K((q))$ (coefficients pushed along $\mathbf{Z} \to K$, then
+viewed as a Laurent series), and let [`ModularCurve.intFormRatiosC`](def/ModularCurve_X1.html#L83)
+$K\,\Gamma \subseteq K((q))$ be the set of quotients $\mathrm{intSeriesC}\,K\,p_f /
+\mathrm{intSeriesC}\,K\,p_g$ where $k$ is an integer, $f$ and $g$ are modular forms of weight $k$
+for the image of $\Gamma$ in $\mathrm{GL}_2(\mathbf{R})$, $p_f, p_g$ are power series over
+$\mathbf{Z}$ satisfying `IsIntegralQExp` for $f$ and for $g$ respectively, and
+$\mathrm{intSeriesC}\,K\,p_g \neq 0$; and let
+[`ModularCurve.qExpFunctionFieldC`](def/ModularCurve_X1.html#L101) $K\,\Gamma$ be the intermediate
+field of $K((q))/K$ generated by this set. Let
+[`ModularCurve.coeffEmb`](def/ModularCurve_LaurentCoeff.html#L81) $L$ be the ring homomorphism
+$\mathbf{Q}((q)) \to L((q))$ applying $\mathbf{Q} \to L$ to each coefficient. The assertion is that
+the intermediate field of $L((q))/L$ generated by the `coeffEmb` $L$-image of `qExpFunctionFieldC`
+$\mathbf{Q}\,\Gamma$, that is
+[`ModularCurve.laurentBaseChange`](def/ModularCurve_LaurentCoeff.html#L103) $L$ applied to it,
+coincides with `qExpFunctionFieldC` $L\,\Gamma$.
+
+This identifies the compositum $L \cdot F(\Gamma)$ inside $L((q))$ with the field $F_L(\Gamma)$
+built directly over $L$ from the same integral $q$-expansions, so that results phrased with either
+construction of the $q$-expansion function field of a modular curve may be used interchangeably. It
+is invoked by the statements about function fields of $X_1(M)$ and $X_H(M)$ over a general
+coefficient field, where the two descriptions must be matched.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_laurentBaseChange_qExpFunctionFieldC_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_laurentBaseChange_qExpFunctionFieldC_eq
+
+open scoped MatrixGroups
+p2m_open "ModularCurve P2MW.S_ModularCurve_laurentBaseChange_qExpFunctionFieldC_eq.ModularCurve"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "intSeriesC intFormRatiosC qExpFunctionFieldC intFormRatiosC_subset \
+  coeffMap coeffMap_coeff coeffMap_single algebraMap_laurentSeries_eq_single coeffEmb \
+  laurentBaseChange coeffEmb_mem_laurentBaseChange"
+namespace BCEqProof
+p2m_open "ModularCurve"
+
+theorem ofPowerSeries_coeff_int {A : Type*} [CommRing A] (x : PowerSeries A) (k : ℤ) :
+    (HahnSeries.ofPowerSeries ℤ A x).coeff k = if 0 ≤ k then PowerSeries.coeff k.toNat x else 0 :=
+      by
+  split_ifs with h
+  · obtain ⟨n, rfl⟩ := Int.eq_ofNat_of_zero_le h
+    rw [Int.toNat_natCast, HahnSeries.ofPowerSeries_apply_coeff]
+  · rw [HahnSeries.ofPowerSeries_apply, HahnSeries.embDomain_of_notMem_range]
+    rintro ⟨n, hn⟩
+    apply h
+    rw [← hn]
+    exact Int.natCast_nonneg n
+
+theorem coeffMap_intSeriesC {R S : Type*} [Field R] [Field S] (f : R →+* S) (x : PowerSeries ℤ) :
+    coeffMap f (intSeriesC R x) = intSeriesC S x := by
+  ext k
+  change (coeffMap f (HahnSeries.ofPowerSeries ℤ R (x.map (Int.castRingHom R)))).coeff k =
+    (HahnSeries.ofPowerSeries ℤ S (x.map (Int.castRingHom S))).coeff k
+  rw [coeffMap_coeff, ofPowerSeries_coeff_int, ofPowerSeries_coeff_int]
+  split_ifs
+  · rw [PowerSeries.coeff_map, PowerSeries.coeff_map, eq_intCast, eq_intCast, map_intCast]
+  · exact map_zero f
+
+variable (L : Type*) [Field L] [Algebra ℚ L] (Γ : Subgroup SL(2, ℤ))
+
+theorem coeffEmb_intSeriesC (x : PowerSeries ℤ) : coeffEmb L (intSeriesC ℚ x) = intSeriesC L x :=
+  coeffMap_intSeriesC (algebraMap ℚ L) x
+
+theorem image_intFormRatiosC : ⇑(coeffEmb L) '' intFormRatiosC ℚ Γ = intFormRatiosC L Γ := by
+  have hinj : Function.Injective (coeffEmb L) := (coeffEmb L).injective
+  ext x
+  constructor
+  · rintro ⟨y, ⟨k, f, g, pf, pg, hf, hg, hg0, rfl⟩, rfl⟩
+    refine ⟨k, f, g, pf, pg, hf, hg, ?_, ?_⟩
+    · rw [← coeffEmb_intSeriesC L]
+      exact (map_ne_zero_iff _ hinj).mpr hg0
+    · rw [map_div₀, coeffEmb_intSeriesC, coeffEmb_intSeriesC]
+  · rintro ⟨k, f, g, pf, pg, hf, hg, hg0, rfl⟩
+    refine ⟨intSeriesC ℚ pf / intSeriesC ℚ pg, ⟨k, f, g, pf, pg, hf, hg, ?_, rfl⟩, ?_⟩
+    · intro h0
+      apply hg0
+      rw [← coeffEmb_intSeriesC L, h0, map_zero]
+    · rw [map_div₀, coeffEmb_intSeriesC, coeffEmb_intSeriesC]
+
+theorem coeffEmb_mem_adjoin (S : Set (LaurentSeries ℚ)) {x : LaurentSeries ℚ}
+    (hx : x ∈ IntermediateField.adjoin ℚ S) :
+    coeffEmb L x ∈ IntermediateField.adjoin L (⇑(coeffEmb L) '' S) := by
+  induction hx using IntermediateField.adjoin_induction with
+  | mem x hx => exact IntermediateField.subset_adjoin L _ ⟨x, hx, rfl⟩
+  | algebraMap c =>
+    rw [algebraMap_laurentSeries_eq_single, show coeffEmb L (HahnSeries.single 0 c) =
+      HahnSeries.single 0 (algebraMap ℚ L c) from coeffMap_single _ _ _, ←
+      algebraMap_laurentSeries_eq_single]
+    exact IntermediateField.algebraMap_mem _ _
+  | add x y _ _ hx hy => rw [map_add]; exact add_mem hx hy
+  | inv x _ hx => rw [map_inv₀]; exact inv_mem hx
+  | mul x y _ _ hx hy => rw [map_mul]; exact mul_mem hx hy
+
+theorem main : laurentBaseChange L (qExpFunctionFieldC ℚ Γ) = qExpFunctionFieldC L Γ := by
+  apply le_antisymm
+  · change IntermediateField.adjoin L (⇑(coeffEmb L) '' (qExpFunctionFieldC ℚ Γ : Set (LaurentSeries
+      ℚ))) ≤ _
+    rw [IntermediateField.adjoin_le_iff]
+    rintro _ ⟨x, hx, rfl⟩
+    have h := coeffEmb_mem_adjoin L (intFormRatiosC ℚ Γ) hx
+    rw [image_intFormRatiosC] at h
+    exact h
+  · change IntermediateField.adjoin L (intFormRatiosC L Γ) ≤ _
+    rw [IntermediateField.adjoin_le_iff, ← image_intFormRatiosC L Γ]
+    rintro _ ⟨x, hx, rfl⟩
+    exact coeffEmb_mem_laurentBaseChange L (intFormRatiosC_subset ℚ Γ hx)
+
+end ModularCurve.BCEqProof
+
+theorem solution
+    (L : Type*) [Field L] [Algebra ℚ L] (Γ : Subgroup SL(2, ℤ)) :
+    ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ) =
+      ModularCurve.qExpFunctionFieldC L Γ :=
+  ModularCurve.BCEqProof.main L Γ
+
+end S_ModularCurve_laurentBaseChange_qExpFunctionFieldC_eq
+end P2MW
+export P2MW.S_ModularCurve_laurentBaseChange_qExpFunctionFieldC_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+open ModularCurve
+theorem ModularCurve.laurentBaseChange_qExpFunctionFieldC_eq
+    (L : Type*) [Field L] [Algebra ℚ L] (Γ : Subgroup SL(2, ℤ)) :
+    ModularCurve.laurentBaseChange L (ModularCurve.qExpFunctionFieldC ℚ Γ) =
+      ModularCurve.qExpFunctionFieldC L Γ :=
+  solution L Γ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_laurent_qParam_coeff_unique.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_laurent_qParam_coeff_unique.lean
new file mode 100644
index 0000000000..7c0bd98532
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_laurent_qParam_coeff_unique.lean
@@ -0,0 +1,143 @@
+/-
+Based on Prove2Me node ModularCurve.laurent_qParam_coeff_unique
+(e84024f0-c086-5b60-a768-d944a96ecf32) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9daf0f66-d19a-5e6f-a401-8cfe0cb07426
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Exp
+public import Mathlib.RingTheory.LaurentSeries
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qParam_coeff_unique
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Uniqueness of Laurent q-expansions at period h
+
+Theorem statement: `ModularCurve.laurent_qParam_coeff_unique`
+(`e84024f0-c086-5b60-a768-d944a96ecf32`), by Claude, 2026-09-05.
+
+Proof: submission `9daf0f66-d19a-5e6f-a401-8cfe0cb07426`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $h$ be a real number with $h>0$, let $F\colon\mathfrak H\to\mathbb C$ be an arbitrary function
+on the upper half-plane, and let $A,B$ be formal Laurent series over $\mathbb C$ (elements of
+`LaurentSeries ℂ`, i.e. Hahn series over $\mathbb Z$ with complex coefficients). Assume that for
+every $\tau\in\mathfrak H$ the family $m\mapsto A_m\,q^m$, indexed by $m\in\mathbb Z$, is summable
+with sum $F(\tau)$, where $q=\mathrm{qParam}\,h\,\tau=e^{2\pi i\tau/h}$ and $q^m$ denotes the
+integer power of the nonzero complex number $q$; assume the same for the coefficients of $B$, again
+with sum $F(\tau)$ for every $\tau\in\mathfrak H$. The conclusion is that $A=B$ as formal Laurent
+series, that is, $A_m=B_m$ for all $m\in\mathbb Z$. Note that unconditional `HasSum` over the index
+set $\mathbb Z$ is required at every point of the upper half-plane; no holomorphy, growth or
+modularity hypothesis on $F$ is imposed.
+
+This is the $q$-expansion principle in the form needed for Laurent (rather than Taylor) expansions:
+a function on $\mathfrak H$ determines at most one formal Laurent series realising it at a given
+period $h$. It is used throughout the treatment of modular functions and modular units on $X_0(N)$,
+for instance when identifying the Fricke involution on $q$-expansions and when comparing conjugates
+of modular polynomials.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_laurent_qParam_coeff_unique.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_laurent_qParam_coeff_unique
+
+noncomputable section
+
+open UpperHalfPlane Function
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qParam_coeff_unique"
+p2m_open "ModularCurve"
+
+namespace QexpN
+
+private theorem hasSum_shift (h : ℝ) (F : UpperHalfPlane → ℂ) (C : LaurentSeries ℂ) (M : ℕ)
+    (hC : ∀ τ : UpperHalfPlane, HasSum (fun m : ℤ => C.coeff m * 𝕢 h (τ : ℂ) ^ m) (F τ))
+    (hsupp : ∀ m : ℤ, m < -(M : ℤ) → C.coeff m = 0) (τ : UpperHalfPlane) :
+    HasSum (fun n : ℕ => C.coeff ((n : ℤ) - M) * 𝕢 h (τ : ℂ) ^ n)
+      (F τ * 𝕢 h (τ : ℂ) ^ (M : ℤ)) := by
+  have hq : 𝕢 h (τ : ℂ) ≠ 0 := Periodic.qParam_ne_zero _
+  have h1 := (hC τ).mul_right (𝕢 h (τ : ℂ) ^ (M : ℤ))
+  have hinj : Function.Injective fun n : ℕ => (n : ℤ) - M := fun a b hab => by simpa using hab
+  refine ((hinj.hasSum_iff ?_).mpr h1).congr_fun fun n => ?_
+  · intro m hm
+    have hm' : m < -(M : ℤ) := by
+      by_contra hge
+      push Not at hge
+      exact hm ⟨(m + M).toNat, by simp; omega⟩
+    rw [hsupp m hm', zero_mul, zero_mul]
+  · simp only [Function.comp_apply]
+    conv_rhs => rw [mul_assoc, ← zpow_add₀ hq, sub_add_cancel]
+    rw [zpow_natCast]
+
+private theorem laurent_unique (h : ℝ) (hh : 0 < h) (F : UpperHalfPlane → ℂ)
+    (A B : LaurentSeries ℂ)
+    (hA : ∀ τ : UpperHalfPlane, HasSum (fun m : ℤ => A.coeff m * 𝕢 h (τ : ℂ) ^ m) (F τ))
+    (hB : ∀ τ : UpperHalfPlane, HasSum (fun m : ℤ => B.coeff m * 𝕢 h (τ : ℂ) ^ m) (F τ)) :
+    A = B := by
+  set M : ℕ := max (-A.order).toNat (-B.order).toNat with hM
+  have hsA : ∀ m : ℤ, m < -(M : ℤ) → A.coeff m = 0 := by
+    intro m hm
+    refine HahnSeries.coeff_eq_zero_of_lt_order ?_
+    omega
+  have hsB : ∀ m : ℤ, m < -(M : ℤ) → B.coeff m = 0 := by
+    intro m hm
+    refine HahnSeries.coeff_eq_zero_of_lt_order ?_
+    omega
+  have hcd := ModularCurve.qParam_coeff_unique h hh (fun τ => F τ * 𝕢 h (τ : ℂ) ^ (M : ℤ))
+    (fun n : ℕ => A.coeff ((n : ℤ) - M)) (fun n : ℕ => B.coeff ((n : ℤ) - M))
+    (hasSum_shift h F A M hA hsA) (hasSum_shift h F B M hB hsB)
+  ext m
+  rcases lt_or_ge m (-(M : ℤ)) with hm | hm
+  · rw [hsA m hm, hsB m hm]
+  · have hm2 : m = (((m + M).toNat : ℕ) : ℤ) - M := by omega
+    rw [hm2]
+    exact congrFun hcd (m + M).toNat
+
+end QexpN
+
+end ModularCurve
+
+end
+
+theorem solution (h : ℝ) (hh : 0 < h) (F : UpperHalfPlane → ℂ) (A B : LaurentSeries ℂ) (hA : ∀ τ :
+  UpperHalfPlane, HasSum (fun m : ℤ => A.coeff m * Function.Periodic.qParam h (τ : ℂ) ^ m) (F τ))
+  (hB : ∀ τ : UpperHalfPlane, HasSum (fun m : ℤ => B.coeff m * Function.Periodic.qParam h (τ : ℂ) ^
+  m) (F τ)) :
+    A = B :=
+  ModularCurve.QexpN.laurent_unique h hh F A B hA hB
+
+end S_ModularCurve_laurent_qParam_coeff_unique
+end P2MW
+export P2MW.S_ModularCurve_laurent_qParam_coeff_unique (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.laurent_qParam_coeff_unique (h : ℝ) (hh : 0 < h) (F : UpperHalfPlane → ℂ) (A B
+  : LaurentSeries ℂ) (hA : ∀ τ : UpperHalfPlane, HasSum (fun m : ℤ => A.coeff m *
+  Function.Periodic.qParam h (τ : ℂ) ^ m) (F τ)) (hB : ∀ τ : UpperHalfPlane, HasSum (fun m : ℤ =>
+  B.coeff m * Function.Periodic.qParam h (τ : ℂ) ^ m) (F τ)) :
+    A = B :=
+  solution h hh F A B hA hB
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_le_dedekindPsi.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_le_dedekindPsi.lean
new file mode 100644
index 0000000000..2ad9a37f3b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_le_dedekindPsi.lean
@@ -0,0 +1,82 @@
+/-
+Based on Prove2Me node ModularCurve.le_dedekindPsi
+(0aa03680-9cd6-5b88-8722-f756559b369a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 93a5e260-ae19-5067-ba7f-fe49b3c9290c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import Mathlib.NumberTheory.Divisors
+import Mathlib.Data.Nat.Squarefree
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Dedekind ψ dominates its argument
+
+Theorem statement: `ModularCurve.le_dedekindPsi` (`0aa03680-9cd6-5b88-8722-f756559b369a`), by
+Claude, 2026-09-05.
+
+Proof: submission `93a5e260-ae19-5067-ba7f-fe49b3c9290c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number with $N \neq 0$. Here `dedekindPsi N` is defined as the sum $\sum N/d$,
+taken over those $d$ in the finite set of divisors of $N$ that are squarefree, the division being
+natural-number division (exact on divisors). The theorem asserts that $N \le \mathtt{dedekindPsi }
+N$, i.e. that the Dedekind $\psi$-function, presented in the form $\psi(N) = \sum_{d \mid N,\ d
+\text{ squarefree}} N/d$, is bounded below by $N$ itself. The hypothesis $N \neq 0$ is genuinely
+needed: the divisor set of $0$ is empty in this convention, so the sum defining `dedekindPsi 0` is
+$0$, and the inequality would fail for $N = 0$ as stated with natural-number subtraction-free
+comparison.
+
+This is the elementary lower bound $N \le \psi(N)$ for the Dedekind $\psi$-function, which computes
+the index $[\mathrm{SL}_2(\mathbb{Z}) : \Gamma_0(N)]$. It serves the numerical layer for the modular
+curves $X_0(N)$, and is used for the positivity statement
+[`ModularCurve.dedekindPsi_pos`](thm.html#ModularCurve.dedekindPsi_pos) and in the identification of
+a relative dimension with the index in
+[`ModularCurve.relfinrank_qExpFunctionFieldC_gamma0_gammaH_eq_index_of_charZero`]
+(thm.html#ModularCurve.relfinrank_qExpFunctionFieldC_gamma0_gammaH_eq_index_of_charZero).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_le_dedekindPsi.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_le_dedekindPsi
+
+open ModularCurve Finset
+
+theorem solution (N : ℕ) (hN : N ≠ 0) : N ≤ dedekindPsi N := by
+  rw [dedekindPsi]
+  have h1 : (1 : ℕ) ∈ {d ∈ N.divisors | Squarefree d} :=
+    Finset.mem_filter.mpr ⟨Nat.one_mem_divisors.mpr hN, squarefree_one⟩
+  simpa using Finset.single_le_sum (f := fun d => N / d) (fun d _ => Nat.zero_le _) h1
+
+end S_ModularCurve_le_dedekindPsi
+end P2MW
+export P2MW.S_ModularCurve_le_dedekindPsi (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.le_dedekindPsi (N : ℕ) (hN : N ≠ 0) :
+    N ≤ dedekindPsi N :=
+  solution N hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_map_intCast_pow_char_eq_qExpand.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_map_intCast_pow_char_eq_qExpand.lean
new file mode 100644
index 0000000000..c498c1bc92
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_map_intCast_pow_char_eq_qExpand.lean
@@ -0,0 +1,245 @@
+/-
+Based on Prove2Me node ModularCurve.map_intCast_pow_char_eq_qExpand
+(8aa4b432-53c2-56c2-b8b4-6085b22c5837) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 19534c9d-1118-5296-a6da-280704a7a573
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import Mathlib.RingTheory.PowerSeries.Expand
+import Mathlib.FieldTheory.Finite.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Frobenius on reductions of integral Laurent series: ̄ s(q)^ℓ=̄ s(q^ℓ)
+
+Theorem statement: `ModularCurve.map_intCast_pow_char_eq_qExpand`
+(`8aa4b432-53c2-56c2-b8b4-6085b22c5837`), by Claude, 2026-09-05.
+
+Proof: submission `19534c9d-1118-5296-a6da-280704a7a573`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a commutative ring, let $\ell$ be a prime natural number, and assume $K$ has
+characteristic $\ell$. Let $s$ be a formal Laurent series with integer coefficients, i.e. an element
+of `LaurentSeries ℤ` $=$ `HahnSeries ℤ ℤ`, and write $\bar s$ for its coefficientwise image `s.map
+(Int.castRingHom K)` in `LaurentSeries K` under the canonical ring homomorphism $\mathbb{Z}\to K$.
+The assertion is the identity $\bar s^{\,\ell} = \mathrm{qExpand}\,K\,\ell\,(\bar s)$ in
+`LaurentSeries K`, where the left-hand side is the $\ell$-th power in the ring of Laurent series and
+$\mathrm{qExpand}\,K\,\ell$ is the ring homomorphism of `LaurentSeries K` obtained by embedding the
+exponent group $\mathbb{Z}$ into itself along multiplication by $\ell$ (an injective, strictly
+monotone additive map), that is, the substitution $q\mapsto q^{\ell}$: the coefficient of $q^{\ell
+m}$ in $\mathrm{qExpand}\,K\,\ell\,(\bar s)$ is the coefficient of $q^{m}$ in $\bar s$, and all
+coefficients in degrees not divisible by $\ell$ vanish. Thus $\bar s(q)^{\ell}=\bar s(q^{\ell})$ for
+every Laurent series with integral coefficients reduced into a ring of characteristic $\ell$.
+
+This is the Frobenius congruence for $q$-expansions with integral coefficients: in characteristic
+$\ell$ raising a reduced integral $q$-expansion to the $\ell$-th power is the same as substituting
+$q^{\ell}$ for $q$, the identity underlying Kronecker-type congruences for modular functions such as
+$j$. It is used in the study of the modular curves of full level, in particular in the computations
+identifying the action of level automorphisms on $q$-expansions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_map_intCast_pow_char_eq_qExpand.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_map_intCast_pow_char_eq_qExpand
+
+noncomputable section
+
+open scoped PowerSeries.WithPiTopology
+open PowerSeries HahnSeries
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_single \
+  ofPowerSeries_coeff_of_neg"
+p2m_open "ModularCurve"
+
+namespace CharL
+
+section LaurentMap
+
+variable {R S T : Type*} [CommRing R] [CommRing S] [CommRing T]
+
+def laurentMap (f : R →+* S) : LaurentSeries R →+* LaurentSeries S where
+  toFun x := x.map f
+  map_one' := HahnSeries.map_one (R := R) (S := S) f.toMonoidWithZeroHom
+  map_mul' _ _ := HahnSeries.map_mul (R := R) (S := S) f.toNonUnitalRingHom
+  map_zero' := by
+    ext k
+    change f ((0 : LaurentSeries R).coeff k) = (0 : LaurentSeries S).coeff k
+    rw [HahnSeries.coeff_zero, HahnSeries.coeff_zero, map_zero]
+  map_add' x y := by
+    ext k
+    change f ((x + y).coeff k) = (x.map f + y.map f).coeff k
+    rw [HahnSeries.coeff_add, HahnSeries.coeff_add, map_add]
+    rfl
+
+theorem laurentMap_apply (f : R →+* S) (x : LaurentSeries R) : laurentMap f x = x.map f := rfl
+
+@[scoped simp]
+theorem laurentMap_coeff (f : R →+* S) (x : LaurentSeries R) (k : ℤ) :
+    (laurentMap f x).coeff k = f (x.coeff k) := rfl
+
+@[scoped simp]
+theorem laurentMap_single (f : R →+* S) (k : ℤ) (r : R) :
+    laurentMap f (HahnSeries.single k r) = HahnSeries.single k (f r) := by
+  ext g
+  rw [laurentMap_coeff, HahnSeries.coeff_single, HahnSeries.coeff_single, apply_ite f,
+    map_zero]
+
+theorem laurentMap_ofPowerSeries (f : R →+* S) (p : PowerSeries R) :
+    laurentMap f (HahnSeries.ofPowerSeries ℤ R p) =
+      HahnSeries.ofPowerSeries ℤ S (p.map f) := by
+  ext k
+  rw [laurentMap_coeff]
+  rcases le_or_gt 0 k with hk | hk
+  · lift k to ℕ using hk
+    rw [HahnSeries.ofPowerSeries_apply_coeff, HahnSeries.ofPowerSeries_apply_coeff,
+      PowerSeries.coeff_map]
+  · rw [ofPowerSeries_coeff_of_neg _ hk, ofPowerSeries_coeff_of_neg _ hk, map_zero]
+
+theorem laurentMap_qExpand (f : R →+* S) (N : ℕ) [NeZero N] (x : LaurentSeries R) :
+    laurentMap f (qExpand R N x) = qExpand S N (laurentMap f x) := by
+  ext k
+  rw [laurentMap_coeff]
+  by_cases hk : (N : ℤ) ∣ k
+  · obtain ⟨m, rfl⟩ := hk
+    rw [qExpand_coeff_mul, qExpand_coeff_mul, laurentMap_coeff]
+  · rw [qExpand_coeff_of_not_dvd N x hk, qExpand_coeff_of_not_dvd N _ hk, map_zero]
+
+end LaurentMap
+
+section ExpandSeam
+
+variable {R : Type*} [CommRing R] (p : ℕ) [NeZero p]
+
+theorem qExpand_ofPowerSeries_eq_expand (u : PowerSeries R) :
+    qExpand R p (HahnSeries.ofPowerSeries ℤ R u)
+      = HahnSeries.ofPowerSeries ℤ R (PowerSeries.expand p (NeZero.ne p) u) := by
+  have hp0 : (0 : ℤ) < p := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne p)
+  ext k
+  by_cases hpk : (p : ℤ) ∣ k
+  · obtain ⟨m, rfl⟩ := hpk
+    rw [qExpand_coeff_mul]
+    rcases lt_or_ge m 0 with hm | hm
+    · have hpm : (p : ℤ) * m < 0 := mul_neg_of_pos_of_neg hp0 hm
+      rw [ofPowerSeries_coeff_of_neg _ hm, ofPowerSeries_coeff_of_neg _ hpm]
+    · lift m to ℕ using hm with m
+      have hcast : ((p : ℤ) * (m : ℤ)) = ((p * m : ℕ) : ℤ) := by push_cast; ring
+      rw [HahnSeries.ofPowerSeries_apply_coeff, hcast, HahnSeries.ofPowerSeries_apply_coeff,
+        PowerSeries.coeff_expand_mul]
+  · rw [qExpand_coeff_of_not_dvd p _ hpk]
+    rcases lt_or_ge k 0 with hk | hk
+    · exact (ofPowerSeries_coeff_of_neg _ hk).symm
+    · lift k to ℕ using hk with k
+      rw [HahnSeries.ofPowerSeries_apply_coeff,
+        PowerSeries.coeff_expand_of_not_dvd p (NeZero.ne p) u
+          (fun ⟨m, hm⟩ => hpk ⟨m, by exact_mod_cast hm⟩)]
+
+end ExpandSeam
+
+section KeyLemma
+
+variable {R : Type*} [CommRing R] (p : ℕ) [Fact p.Prime] [CharP R p]
+
+theorem pow_char_single_one_eq (n : ℤ) :
+    (HahnSeries.single n (1 : R)) ^ p
+      = laurentMap (frobenius R p) (qExpand R p (HahnSeries.single n (1 : R))) := by
+  have : ExpChar R p := ExpChar.prime (Fact.out : p.Prime)
+  rw [HahnSeries.single_pow, one_pow, qExpand_single, laurentMap_single,
+    show frobenius R p 1 = 1 from (frobenius R p).map_one,
+    show (p • n : ℤ) = (p : ℤ) * n from nsmul_eq_mul p n]
+
+theorem pow_char_ofPowerSeries_eq (u : PowerSeries R) :
+    (HahnSeries.ofPowerSeries ℤ R u) ^ p
+      = laurentMap (frobenius R p)
+          (qExpand R p (HahnSeries.ofPowerSeries ℤ R u)) := by
+  have : ExpChar R p := ExpChar.prime (Fact.out : p.Prime)
+  rw [qExpand_ofPowerSeries_eq_expand p u, laurentMap_ofPowerSeries, ← map_pow]
+  congr 1
+  exact (MvPowerSeries.map_frobenius_expand p (NeZero.ne p) (f := u)).symm
+
+theorem pow_char_eq_laurentMap_frobenius_qExpand (s : LaurentSeries R) :
+    s ^ p = laurentMap (frobenius R p) (qExpand R p s) := by
+  conv_lhs => rw [← LaurentSeries.single_order_mul_powerSeriesPart s]
+  conv_rhs => rw [← LaurentSeries.single_order_mul_powerSeriesPart s]
+  rw [mul_pow, map_mul, map_mul, pow_char_single_one_eq p s.order]
+  congr 1
+  exact pow_char_ofPowerSeries_eq p s.powerSeriesPart
+
+theorem pow_char_eq_qExpand_of_coeff_fixed (s : LaurentSeries R)
+    (hfix : ∀ k : ℤ, (s.coeff k) ^ p = s.coeff k) :
+    s ^ p = qExpand R p s := by
+  rw [pow_char_eq_laurentMap_frobenius_qExpand p s]
+  ext k
+  rw [laurentMap_coeff, frobenius_def]
+  by_cases hpk : (p : ℤ) ∣ k
+  · obtain ⟨m, rfl⟩ := hpk
+    rw [qExpand_coeff_mul, hfix m]
+  · rw [qExpand_coeff_of_not_dvd p _ hpk, zero_pow (Fact.out : p.Prime).ne_zero]
+
+end KeyLemma
+
+section IntCastImage
+
+variable {K : Type*} [CommRing K] (ℓ : ℕ) [Fact ℓ.Prime] [CharP K ℓ]
+
+theorem intCast_pow_char_eq (n : ℤ) : ((n : K) : K) ^ ℓ = (n : K) := by
+  have : ExpChar K ℓ := ExpChar.prime (Fact.out : ℓ.Prime)
+  have h : (frobenius K ℓ).comp (Int.castRingHom K) = Int.castRingHom K :=
+    RingHom.ext_int _ _
+  calc ((n : K) : K) ^ ℓ = frobenius K ℓ (Int.castRingHom K n) := rfl
+    _ = ((frobenius K ℓ).comp (Int.castRingHom K)) n := rfl
+    _ = Int.castRingHom K n := by rw [h]
+    _ = (n : K) := rfl
+
+theorem pow_char_laurentMap_intCast_eq_qExpand (sInt : LaurentSeries ℤ) :
+    (laurentMap (Int.castRingHom K) sInt) ^ ℓ
+      = qExpand K ℓ (laurentMap (Int.castRingHom K) sInt) :=
+  pow_char_eq_qExpand_of_coeff_fixed ℓ (laurentMap (Int.castRingHom K) sInt)
+    fun k => by rw [laurentMap_coeff]; exact intCast_pow_char_eq ℓ (sInt.coeff k)
+
+end IntCastImage
+
+end CharL
+end ModularCurve
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_map_intCast_pow_char_eq_qExpand.ModularCurve in
+theorem solution {K : Type*} [CommRing K] (ℓ : ℕ) [Fact ℓ.Prime] [CharP K ℓ]
+    (s : LaurentSeries ℤ) :
+    (s.map (Int.castRingHom K)) ^ ℓ = qExpand K ℓ (s.map (Int.castRingHom K)) :=
+  ModularCurve.CharL.pow_char_laurentMap_intCast_eq_qExpand ℓ s
+
+end S_ModularCurve_map_intCast_pow_char_eq_qExpand
+end P2MW
+export P2MW.S_ModularCurve_map_intCast_pow_char_eq_qExpand (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.map_intCast_pow_char_eq_qExpand {K : Type*} [CommRing K] (ℓ : ℕ) [Fact ℓ.Prime]
+    [CharP K ℓ]
+    (s : LaurentSeries ℤ) :
+    (s.map (Int.castRingHom K)) ^ ℓ = qExpand K ℓ (s.map (Int.castRingHom K)) :=
+  solution ℓ s
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_mem_adjoin_jq_of_hasSum_of_slash_invariant.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_mem_adjoin_jq_of_hasSum_of_slash_invariant.lean
new file mode 100644
index 0000000000..ff0af82260
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_mem_adjoin_jq_of_hasSum_of_slash_invariant.lean
@@ -0,0 +1,298 @@
+/-
+Based on Prove2Me node ModularCurve.mem_adjoin_jq_of_hasSum_of_slash_invariant
+(8dc4e43d-6a5b-5cf0-b976-4b85a75a17e2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6cd85d0b-d0bb-5e15-b57d-f5d694c67ccd
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Exp
+public import Mathlib.Analysis.Complex.UpperHalfPlane.MoebiusAction
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+import Mathlib.NumberTheory.Cyclotomic.PrimitiveRoots
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import Mathlib.NumberTheory.ModularForms.EisensteinSeries.Basic
+import Mathlib.NumberTheory.ModularForms.Discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_jq_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_eq_zero_of_hasSum_of_slash_invariant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_mul_laurent
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_E4_cube_div_discriminant_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_aeval_jq_sub_holomorphicAtInfty
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# q-expansion principle at level one: invariance implies f∈ℚ[j]
+
+Theorem statement: `ModularCurve.mem_adjoin_jq_of_hasSum_of_slash_invariant`
+(`8dc4e43d-6a5b-5cf0-b976-4b85a75a17e2`), by Claude, 2026-09-05.
+
+Proof: submission `6cd85d0b-d0bb-5e15-b57d-f5d694c67ccd`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $f$ be a formal Laurent series with rational coefficients, i.e. an element of `LaurentSeries ℚ`
+$=$ `HahnSeries ℤ ℚ`, and let $F \colon \mathfrak H \to \mathbb C$ be a function on the upper
+half-plane. Assume that for every $\tau \in \mathfrak H$ the family indexed by $m \in \mathbb Z$
+whose $m$-th term is the complex number $f_m \, q^m$, where $f_m$ is the coefficient of $f$ in
+degree $m$ viewed in $\mathbb C$ and $q =$ `Function.Periodic.qParam 1 τ` $= e^{2\pi i \tau}$, is
+summable with sum $F(\tau)$; and assume that $F(\gamma \cdot \tau) = F(\tau)$ for every $\gamma \in
+\mathrm{SL}_2(\mathbb Z)$ and every $\tau \in \mathfrak H$, for the usual action of
+`Matrix.SpecialLinearGroup (Fin 2) ℤ` on the upper half-plane. Then $f$ belongs to the $\mathbb
+Q$-subalgebra `Algebra.adjoin ℚ {ModularCurve.jq}` of $\mathbb Q((q))$ generated by the single
+element [`ModularCurve.jq`](def/ModularCurve_X0.html#L157), which is by definition the product of
+the Hahn series $q^{-1}$ with the image in $\mathbb Q((q))$ of the integral power series `jNum`
+under $\mathbb Z \to \mathbb Q$, that is, the formal $q$-expansion of $E_4^3/\Delta$. In other
+words, $f = P(\mathtt{jq})$ for some polynomial $P$ over $\mathbb Q$. No bound on the pole order of
+$f$, no holomorphy of $F$ and no condition at the cusp are assumed.
+
+This is the $q$-expansion principle at level one in the form: a rational formal Laurent series that
+converges on $\mathfrak H$ to an $\mathrm{SL}_2(\mathbb Z)$-invariant function is a polynomial in
+$j$ with rational coefficients, the $q$-series counterpart of the classical statement that the field
+of level-one modular functions holomorphic on $\mathfrak H$ is generated by $j$. It is used in the
+treatment of modular curves of level $N$, for instance to identify $q$-expansions of
+$\Gamma_0(N)$-invariant functions and in the analysis of the Fricke involution and of products of
+modular units.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_mem_adjoin_jq_of_hasSum_of_slash_invariant.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_mem_adjoin_jq_of_hasSum_of_slash_invariant
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology Function Polynomial
+open scoped MatrixGroups
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jq PoleOrderLE coeffMap coeffMap_coeff coeffMap_single \
+  algebraMap_laurentSeries_eq_single hasSum_jq_qParam coeff_eq_zero_of_hasSum_of_slash_invariant \
+  hasSum_qParam_mul_laurent E4_cube_div_discriminant_smul exists_aeval_jq_sub_holomorphicAtInfty"
+p2m_open "ModularCurve"
+
+def RealL (h : ℝ) (A : LaurentSeries ℂ) (F : ℍ → ℂ) : Prop :=
+  ∀ τ : ℍ, HasSum (fun m : ℤ => A.coeff m * 𝕢 h (τ : ℂ) ^ m) (F τ)
+
+namespace RealL
+
+variable {h : ℝ} {A B : LaurentSeries ℂ} {F G : ℍ → ℂ}
+
+lemma add (hA : RealL h A F) (hB : RealL h B G) : RealL h (A + B) (F + G) := fun τ => by
+  simpa [add_mul] using (hA τ).add (hB τ)
+
+lemma neg (hA : RealL h A F) : RealL h (-A) (-F) := fun τ => by
+  simpa [neg_mul] using (hA τ).neg
+
+lemma sub (hA : RealL h A F) (hB : RealL h B G) : RealL h (A - B) (F - G) := fun τ => by
+  simpa [sub_mul] using (hA τ).sub (hB τ)
+
+lemma mul (hh : 0 < h) (hA : RealL h A F) (hB : RealL h B G) : RealL h (A * B) (F * G) := fun τ =>
+  hasSum_qParam_mul_laurent h hh A B F G hA hB τ
+
+lemma single (h : ℝ) (a : ℂ) (n : ℤ) :
+    RealL h (HahnSeries.single n a) (fun τ => a * 𝕢 h (τ : ℂ) ^ n) := fun τ => by
+  refine (hasSum_ite_eq n (a * 𝕢 h (τ : ℂ) ^ n)).congr_fun fun m => ?_
+  by_cases hm : m = n
+  · subst hm; simp
+  · simp [HahnSeries.coeff_single_of_ne hm, hm]
+
+lemma C (h : ℝ) (a : ℂ) : RealL h (HahnSeries.C a) (fun _ => a) := by
+  simpa using single h a 0
+
+lemma one (h : ℝ) : RealL h 1 1 := by
+  have h__af := C h 1
+  simp only [HahnSeries.C_apply, HahnSeries.single_zero_one] at h__af
+  exact h__af
+
+lemma zero (h : ℝ) : RealL h 0 0 := fun τ => by simp [hasSum_zero]
+
+lemma congr {A' : LaurentSeries ℂ} {F' : ℍ → ℂ} (hA : RealL h A F) (h1 : A = A')
+    (h2 : ∀ τ, F τ = F' τ) :
+    RealL h A' F' := fun τ => by rw [← h1, ← h2]; exact hA τ
+
+lemma prod (hh : 0 < h) {ι : Type} (s : Finset ι) {A : ι → LaurentSeries ℂ} {F : ι → ℍ → ℂ}
+    (hAF : ∀ i ∈ s, RealL h (A i) (F i)) : RealL h (∏ i ∈ s, A i) (fun τ => ∏ i ∈ s, F i τ) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => (have h__af := one h; simp only [Finset.prod_empty] at h__af ⊢; exact h__af)
+  | insert a s ha ih =>
+    have h1 :=
+      (hAF a (Finset.mem_insert_self a s)).mul hh (ih fun i hi => hAF i (Finset.mem_insert_of_mem
+        hi))
+    refine h1.congr (Finset.prod_insert ha).symm fun τ => ?_
+    simp [Finset.prod_insert ha]
+
+lemma coeff_prod_X_sub_C (hh : 0 < h) {ι : Type} (s : Finset ι) {a : ι → LaurentSeries ℂ}
+    {α : ι → ℍ → ℂ} (haα : ∀ i ∈ s, RealL h (a i) (α i)) (k : ℕ) :
+    RealL h ((∏ i ∈ s, (Polynomial.X - Polynomial.C (a i))).coeff k)
+      (fun τ => (∏ i ∈ s, (Polynomial.X - Polynomial.C (α i τ))).coeff k) := by
+  classical
+  induction s using Finset.induction_on generalizing k with
+  | empty =>
+    simp only [Finset.prod_empty, Polynomial.coeff_one]
+    by_cases hk : k = 0
+    · subst hk; (have h__af := one h; simp only [↓reduceIte] at h__af ⊢; exact h__af)
+    · have h__af := zero h
+      simp only [hk, ↓reduceIte] at h__af ⊢
+      exact h__af
+  | insert b s hb ih =>
+    have ih' := fun k => ih (fun i hi => haα i (Finset.mem_insert_of_mem hi)) k
+    have hb' := haα b (Finset.mem_insert_self b s)
+    have hA : (∏ i ∈ insert b s, (Polynomial.X - Polynomial.C (a i))) =
+        (∏ i ∈ s, (Polynomial.X - Polynomial.C (a i))) * (Polynomial.X - Polynomial.C (a b)) :=
+      (Finset.prod_insert hb).trans (mul_comm (G := Polynomial (LaurentSeries ℂ)) _ _)
+    have hfun : ∀ τ : ℍ, (∏ i ∈ insert b s, (Polynomial.X - Polynomial.C (α i τ))) =
+        (∏ i ∈ s, (Polynomial.X - Polynomial.C (α i τ))) * (Polynomial.X - Polynomial.C (α b τ)) :=
+      fun τ => (Finset.prod_insert hb).trans (mul_comm (G := Polynomial ℂ) _ _)
+    cases k with
+    | zero =>
+      refine ((ih' 0).mul hh hb').neg.congr ?_ fun τ => ?_
+      · rw [hA, Polynomial.mul_coeff_zero, Polynomial.coeff_sub, Polynomial.coeff_X_zero,
+          Polynomial.coeff_C_zero, zero_sub]
+        exact (mul_neg (α := LaurentSeries ℂ) _ _).symm
+      · simp only [hfun τ, Polynomial.mul_coeff_zero, Pi.neg_apply, Pi.mul_apply,
+          Polynomial.coeff_sub,
+          Polynomial.coeff_X_zero, Polynomial.coeff_C_zero, zero_sub, mul_neg]
+    | succ k =>
+      refine ((ih' k).sub ((ih' (k + 1)).mul hh hb')).congr ?_ fun τ => ?_
+      · rw [hA, Polynomial.coeff_mul_X_sub_C]
+      · simp only [hfun τ, Polynomial.coeff_mul_X_sub_C, Pi.sub_apply, Pi.mul_apply]
+
+end RealL
+
+section JT
+
+def jt (τ : ℍ) : ℂ := ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ
+
+abbrev castC : ℚ →+* ℂ := Rat.castHom ℂ
+
+def jqC : LaurentSeries ℂ := coeffMap castC jq
+
+lemma jqC_coeff (m : ℤ) : jqC.coeff m = ((jq.coeff m : ℚ) : ℂ) := rfl
+
+lemma realL_jqC : RealL 1 jqC jt := fun τ => ModularCurve.hasSum_jq_qParam τ
+
+end JT
+
+section JOut
+
+lemma jt_smul (γ : SL(2, ℤ)) (τ : ℍ) : jt (γ • τ) = jt τ :=
+  ModularCurve.E4_cube_div_discriminant_smul γ τ
+
+lemma realL_aeval_jq (P : Polynomial ℚ) :
+    RealL 1 (coeffMap castC (Polynomial.aeval jq P)) (fun τ => (P.map castC).eval (jt τ)) := by
+  induction P using Polynomial.induction_on with
+  | C a =>
+    refine (RealL.C 1 (a : ℂ)).congr ?_ fun τ => ?_
+    · rw [Polynomial.aeval_C, algebraMap_laurentSeries_eq_single, coeffMap_single]
+      rfl
+    · simp
+  | add P Q hP hQ =>
+    refine (hP.add hQ).congr ?_ fun τ => ?_
+    · rw [map_add, map_add]
+    · simp
+  | monomial n a ih =>
+    refine (ih.mul one_pos realL_jqC).congr ?_ fun τ => ?_
+    · rw [jqC, ← map_mul]
+      congr 1
+      symm
+      rw [pow_succ, ← mul_assoc, map_mul, Polynomial.aeval_X]
+    · simp [pow_succ, mul_assoc]
+
+theorem mem_adjoin_jq_of_realL_invariant (f : LaurentSeries ℚ) (F : ℍ → ℂ)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℤ => ((f.coeff m : ℚ) : ℂ) * 𝕢 1 (τ : ℂ) ^ m) (F τ))
+    (hinv : ∀ (γ : SL(2, ℤ)) (τ : ℍ), F (γ • τ) = F τ) : f ∈ Algebra.adjoin ℚ {jq} := by
+  obtain ⟨n, hn⟩ : ∃ n : ℕ, PoleOrderLE f n := by
+    by_cases hf0 : f = 0
+    · exact ⟨0, fun m _ => by simp [hf0]⟩
+    refine ⟨(-f.order).toNat, fun m hm => HahnSeries.coeff_eq_zero_of_lt_order (lt_of_lt_of_le hm
+      ?_)⟩
+    have := Int.self_le_toNat (-f.order)
+    omega
+  obtain ⟨P, -, he⟩ := ModularCurve.exists_aeval_jq_sub_holomorphicAtInfty n f hn
+  set e : LaurentSeries ℚ := f - Polynomial.aeval jq P with he_def
+  have he0 : ∀ m : ℤ, m < 0 → e.coeff m = 0 := fun m hm => he m (by simpa using hm)
+  have hfR : RealL 1 (coeffMap castC f) F := hF
+  have hE : RealL 1 (coeffMap castC e) (F - fun τ => (P.map castC).eval (jt τ)) := by
+    rw [he_def, map_sub]
+    exact hfR.sub (realL_aeval_jq P)
+  have hEinv : ∀ (γ : SL(2, ℤ)) (τ : ℍ),
+      (F - fun τ => (P.map castC).eval (jt τ)) (γ • τ) = (F - fun τ => (P.map castC).eval (jt τ)) τ
+        := by
+    intro γ τ
+    simp only [Pi.sub_apply, hinv γ τ, jt_smul γ τ]
+  have hEN : ∀ τ : ℍ, HasSum (fun n : ℕ => ((e.coeff n : ℚ) : ℂ) * 𝕢 1 (τ : ℂ) ^ n)
+      ((F - fun τ => (P.map castC).eval (jt τ)) τ) := by
+    intro τ
+    have h := hE τ
+    rw [← (Nat.cast_injective (R := ℤ)).hasSum_iff] at h
+    · exact h
+    · intro m hm
+      have hm' : m < 0 := by
+        by_contra hge
+        push Not at hge
+        exact hm ⟨m.toNat, Int.toNat_of_nonneg hge⟩
+      rw [coeffMap_coeff, he0 m hm', map_zero, zero_mul]
+  have hvan : ∀ n : ℕ, n ≠ 0 → e.coeff n = 0 := fun n hn => by
+    have := coeff_eq_zero_of_hasSum_of_slash_invariant hEN hEinv hn
+    exact_mod_cast this
+  have heconst : e = HahnSeries.single 0 (e.coeff 0) := by
+    ext m
+    rcases lt_trichotomy m 0 with hm | rfl | hm
+    · rw [he0 m hm, HahnSeries.coeff_single_of_ne hm.ne]
+    · rw [HahnSeries.coeff_single_same]
+    · obtain ⟨n, rfl⟩ := Int.eq_ofNat_of_zero_le hm.le
+      rw [HahnSeries.coeff_single_of_ne (by exact_mod_cast hm.ne')]
+      exact hvan n (by exact_mod_cast hm.ne')
+  have hck : f = algebraMap ℚ (LaurentSeries ℚ) (e.coeff 0) + Polynomial.aeval jq P := by
+    rw [algebraMap_laurentSeries_eq_single, ← heconst, he_def, sub_add_cancel]
+  rw [hck]
+  exact Subalgebra.add_mem _ (Subalgebra.algebraMap_mem _ _) (Polynomial.aeval_mem_adjoin_singleton
+    ℚ jq)
+
+end JOut
+
+end ModularCurve
+
+theorem solution (f : LaurentSeries ℚ) (F : UpperHalfPlane → ℂ) (hF : ∀ τ : UpperHalfPlane, HasSum
+  (fun m : ℤ => ((f.coeff m : ℚ) : ℂ) * Function.Periodic.qParam 1 (τ : ℂ) ^ m) (F τ)) (hinv : ∀ (γ
+  : Matrix.SpecialLinearGroup (Fin 2) ℤ) (τ : UpperHalfPlane), F (γ • τ) = F τ) :
+    f ∈ Algebra.adjoin ℚ {ModularCurve.jq} :=
+  ModularCurve.mem_adjoin_jq_of_realL_invariant f F hF hinv
+
+end
+
+end S_ModularCurve_mem_adjoin_jq_of_hasSum_of_slash_invariant
+end P2MW
+export P2MW.S_ModularCurve_mem_adjoin_jq_of_hasSum_of_slash_invariant (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.mem_adjoin_jq_of_hasSum_of_slash_invariant (f : LaurentSeries ℚ) (F :
+  UpperHalfPlane → ℂ) (hF : ∀ τ : UpperHalfPlane, HasSum (fun m : ℤ => ((f.coeff m : ℚ) : ℂ) *
+  Function.Periodic.qParam 1 (τ : ℂ) ^ m) (F τ)) (hinv : ∀ (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ)
+  (τ : UpperHalfPlane), F (γ • τ) = F τ) :
+    f ∈ Algebra.adjoin ℚ {ModularCurve.jq} :=
+  solution f F hF hinv
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_mem_modularFunctionField_of_hasSum_of_gamma0_invariant.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_mem_modularFunctionField_of_hasSum_of_gamma0_invariant.lean
new file mode 100644
index 0000000000..5cec02b651
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_mem_modularFunctionField_of_hasSum_of_gamma0_invariant.lean
@@ -0,0 +1,989 @@
+/-
+Based on Prove2Me node ModularCurve.mem_modularFunctionField_of_hasSum_of_gamma0_invariant
+(3ea17de2-905a-55cd-af34-bbc295dd6498) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 25be52d5-afc9-52fe-8521-98f2b2155fe1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Exp
+public import Mathlib.Analysis.Complex.UpperHalfPlane.MoebiusAction
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.NumberTheory.Cyclotomic.PrimitiveRoots
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import Mathlib.FieldTheory.Galois.Basic
+import Mathlib.GroupTheory.Perm.Fin
+import Mathlib.NumberTheory.ModularForms.EisensteinSeries.Basic
+import Mathlib.NumberTheory.ModularForms.Discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_exists_galoisPerm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_mem_range_coeffEmb_of_forall_coeffMap_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_mem_range_coeffEmb_qExpand_of_mem_inter
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_conj_injective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_mem_range_qExpand_of_qTwist_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_jq_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_E4_cube_div_discriminant_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_mul_laurent
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_heckeMatrix_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_qParam_heckeDiagMatrix_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_mem_adjoin_jq_of_hasSum_of_slash_invariant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_perm_gamma0_cosetReps
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_sl2_heckeDiagMatrix_smul_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# q-expansion principle for X₀(ℓ), ℓ prime
+
+Theorem statement: `ModularCurve.mem_modularFunctionField_of_hasSum_of_gamma0_invariant`
+(`3ea17de2-905a-55cd-af34-bbc295dd6498`), by Claude, 2026-09-05.
+
+Proof: submission `25be52d5-afc9-52fe-8521-98f2b2155fe1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a prime, let $f, g$ be formal Laurent series over $\mathbb{Q}$ and let $F \colon
+\mathfrak{H} \to \mathbb{C}$ be a function on the upper half-plane. Assume: (hF) for every $\tau \in
+\mathfrak{H}$ the family $m \mapsto f_m \, q_1(\tau)^m$, indexed by $m \in \mathbb{Z}$, with $f_m$
+the $m$-th coefficient of $f$ viewed in $\mathbb{C}$ and $q_h(\tau) = \exp(2\pi i \tau / h)$
+(`Function.Periodic.qParam`), is summable with sum $F(\tau)$; (hG) for every $\tau$ the family $m
+\mapsto g_m \, q_\ell(\tau)^m$ is summable with sum $F(S \cdot \tau)$, where $S = \begin{pmatrix} 0
+& -1 \\ 1 & 0\end{pmatrix}$ acts by fractional linear transformations; and (hinv) $F(\gamma \cdot
+\tau) = F(\tau)$ for every $\gamma \in \Gamma_0(\ell)$ and every $\tau$. Then $f$ lies in
+[`ModularCurve.modularFunctionField ℓ`](def/ModularCurve_X0.html#L250), the intermediate field of
+$\mathbb{Q}((q))$ over $\mathbb{Q}$ generated by the two elements
+[`ModularCurve.jq`](def/ModularCurve_X0.html#L157) and [`ModularCurve.qExpand ℚ ℓ
+ModularCurve.jq`](def/ModularCurve_X0.html#L25); here
+[`ModularCurve.jq`](def/ModularCurve_X0.html#L157) is the series whose realisation at period $1$ is
+$E_4^3/\Delta$, and [`ModularCurve.qExpand ℚ ℓ`](def/ModularCurve_X0.html#L25) is the ring
+endomorphism of $\mathbb{Q}((q))$ multiplying all exponents by $\ell$, i.e. $q \mapsto q^\ell$. Thus
+$f \in \mathbb{Q}(j(q), j(q^\ell))$.
+
+This is the $q$-expansion principle for the modular curve $X_0(\ell)$ with $\ell$ prime: a
+$\Gamma_0(\ell)$-invariant function on the upper half-plane whose expansions at the two cusps
+(period $1$ at $\infty$, period $\ell$ at $0$) have rational coefficients has its expansion at
+$\infty$ in the function field $\mathbb{Q}(j(q), j(q^\ell))$ of $X_0(\ell)$. It is used to place the
+$q$-expansions of modular units on $X_0(\ell)$ inside that field, via
+[`ModularCurve.modularUnitSeries_mem_modularFunctionField`]
+(thm.html#ModularCurve.modularUnitSeries_mem_modularFunctionField)
+and
+[`ModularCurve.sharpUnitSeries_mem_modularFunctionField`]
+(thm.html#ModularCurve.sharpUnitSeries_mem_modularFunctionField).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_mem_modularFunctionField_of_hasSum_of_gamma0_invariant.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_mem_modularFunctionField_of_hasSum_of_gamma0_invariant
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology Function Polynomial
+open scoped MatrixGroups
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_qExpand jq jqN modularFunctionField jq_mem jqN_mem qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand PhiGen.conj PhiGen.conj_zero PhiGen.conj_succ coeffMap \
+  coeffMap_coeff coeffEmb coeffEmb_coeff coeffMap_coeffEmb coeffMap_qExpand coeffEmb_qExpand \
+  PhiGen.exists_galoisPerm PhiGen.mem_range_coeffEmb_of_forall_coeffMap_eq \
+  PhiGen.mem_range_coeffEmb_qExpand_of_mem_inter PhiGen.conj_injective \
+  mem_range_qExpand_of_qTwist_eq hasSum_jq_qParam E4_cube_div_discriminant_smul \
+  hasSum_qParam_mul_laurent hasSum_qParam_heckeMatrix_smul hasSum_qParam_heckeDiagMatrix_smul \
+  mem_adjoin_jq_of_hasSum_of_slash_invariant exists_perm_gamma0_cosetReps \
+  exists_sl2_heckeDiagMatrix_smul_eq"
+p2m_open "ModularCurve"
+
+namespace QExpN
+
+section Generic
+
+variable {L L' : Type*} [CommRing L] [CommRing L'] {n : ℕ}
+
+def interpPoly (H Y : Fin n → L) : L[X] :=
+  ∑ i, C (H i) * ∏ m ∈ Finset.univ.erase i, (X - C (Y m))
+
+def conjPoly (H : Fin n → L) : L[X] := ∏ i, (X - C (H i))
+
+omit [CommRing L'] in
+lemma prod_erase_perm (e : Equiv.Perm (Fin n)) (G : Fin n → L[X]) (i : Fin n) :
+    ∏ m ∈ Finset.univ.erase i, G (e m) = ∏ m ∈ Finset.univ.erase (e i), G m := by
+  refine Finset.prod_equiv e (fun m => ?_) (fun m _ => rfl)
+  simp [e.injective.eq_iff]
+
+lemma interpPoly_map (φ : L →+* L') (H Y : Fin n → L) :
+    (interpPoly H Y).map φ = interpPoly (φ ∘ H) (φ ∘ Y) := by
+  simp only [interpPoly, Polynomial.map_sum, Polynomial.map_mul, Polynomial.map_C,
+    Polynomial.map_prod,
+    Polynomial.map_sub, Polynomial.map_X, Function.comp_apply]
+
+lemma conjPoly_map (φ : L →+* L') (H : Fin n → L) : (conjPoly H).map φ = conjPoly (φ ∘ H) := by
+  simp only [conjPoly, Polynomial.map_prod, Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C,
+    Function.comp_apply]
+
+omit [CommRing L'] in
+lemma interpPoly_perm (e : Equiv.Perm (Fin n)) (H Y : Fin n → L) :
+    interpPoly (H ∘ e) (Y ∘ e) = interpPoly H Y := by
+  unfold interpPoly
+  simp only [Function.comp_apply]
+  rw [← Equiv.sum_comp e (fun j => C (H j) * ∏ m ∈ Finset.univ.erase j, (X - C (Y m)))]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [prod_erase_perm e (fun m => X - C (Y m)) i]
+
+omit [CommRing L'] in
+lemma conjPoly_perm (e : Equiv.Perm (Fin n)) (H : Fin n → L) : conjPoly (H ∘ e) = conjPoly H := by
+  unfold conjPoly
+  simp only [Function.comp_apply]
+  exact Equiv.prod_comp e (fun j => X - C (H j))
+
+omit [CommRing L'] in
+lemma interpPoly_eval (H Y : Fin n → L) (i₀ : Fin n) :
+    (interpPoly H Y).eval (Y i₀) = H i₀ * ∏ m ∈ Finset.univ.erase i₀, (Y i₀ - Y m) := by
+  unfold interpPoly
+  rw [Polynomial.eval_finsetSum, Finset.sum_eq_single i₀]
+  · simp [Polynomial.eval_prod]
+  · intro i _ hi
+    rw [Polynomial.eval_mul, Polynomial.eval_prod]
+    refine mul_eq_zero_of_right _ (Finset.prod_eq_zero (i := i₀) (by simp [Ne.symm hi]) ?_)
+    simp
+  · intro h; exact absurd (Finset.mem_univ i₀) h
+
+omit [CommRing L'] in
+lemma conjPoly_eval (H : Fin n → L) (i₀ : Fin n) : (conjPoly H).eval (H i₀) = 0 := by
+  unfold conjPoly
+  rw [Polynomial.eval_prod]
+  exact Finset.prod_eq_zero (Finset.mem_univ i₀) (by simp)
+
+omit [CommRing L'] in
+lemma conjPoly_monic [Nontrivial L] (H : Fin n → L) : (conjPoly H).Monic :=
+  Polynomial.monic_prod_of_monic _ _ fun i _ => Polynomial.monic_X_sub_C (H i)
+
+omit [CommRing L'] in
+lemma conjPoly_natDegree [Nontrivial L] [NoZeroDivisors L] (H : Fin n → L) :
+    (conjPoly H).natDegree = n := by
+  unfold conjPoly
+  rw [Polynomial.natDegree_prod _ _ fun i _ => Polynomial.X_sub_C_ne_zero (H i)]
+  simp
+
+lemma eval_eq_sum_coeff {p : L[X]} {N : ℕ} (hN : p.natDegree < N) (x : L) :
+    p.eval x = ∑ k ∈ Finset.range N, p.coeff k * x ^ k := by
+  rw [Polynomial.eval_eq_sum_range' hN]
+
+end Generic
+
+section Slots
+
+variable {K : Type} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+  (hζ : IsPrimitiveRoot (ζ : K) ℓ)
+
+def slotH (f g : LaurentSeries ℚ) : Fin (ℓ + 1) → LaurentSeries K :=
+  Fin.cases (coeffEmb K (qExpand ℚ ℓ f)) (fun b : Fin ℓ => qTwist (ζ ^ (b : ℕ)) (coeffEmb K g))
+
+@[scoped simp] lemma slotH_zero (f g : LaurentSeries ℚ) :
+    slotH ℓ ζ f g 0 = coeffEmb K (qExpand ℚ ℓ f) := by
+  simp [slotH]
+
+@[scoped simp] lemma slotH_succ (f g : LaurentSeries ℚ) (b : Fin ℓ) :
+    slotH ℓ ζ f g b.succ = qTwist (ζ ^ (b : ℕ)) (coeffEmb K g) := by
+  simp [slotH]
+
+def liftPerm (e : Equiv.Perm (Fin ℓ)) :
+    Equiv.Perm (Fin (ℓ + 1)) := Equiv.Perm.decomposeFin.symm (0, e)
+
+omit hℓ in
+@[scoped simp] lemma liftPerm_zero (e : Equiv.Perm (Fin ℓ)) : liftPerm ℓ e 0 = 0 :=
+  Equiv.Perm.decomposeFin_symm_apply_zero 0 e
+
+omit hℓ in
+@[scoped simp] lemma liftPerm_succ (e : Equiv.Perm (Fin ℓ)) (b : Fin ℓ) :
+    liftPerm ℓ e b.succ = (e b).succ := by
+  rw [liftPerm, Equiv.Perm.decomposeFin_symm_apply_succ, Equiv.swap_self, Equiv.refl_apply]
+
+lemma coeffMap_qTwist {R S : Type*} [CommRing R] [CommRing S] (φ : R →+* S) (u : Rˣ)
+    (x : LaurentSeries R) :
+    coeffMap φ (qTwist u x) = qTwist (Units.map (φ : R →* S) u) (coeffMap φ x) := by
+  ext k
+  simp only [coeffMap_coeff, qTwist_coeff, map_mul]
+  congr 1
+  rw [← map_zpow (Units.map (φ : R →* S)) u k, Units.coe_map]
+  rfl
+
+omit hℓ [Algebra ℚ K] in
+lemma units_map_zeta_pow (σ : K →+* K) (e : Equiv.Perm (Fin ℓ))
+    (he : ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e b : Fin ℓ) : ℕ)) (b : Fin ℓ) :
+    Units.map (σ : K →* K) (ζ ^ (b : ℕ)) = ζ ^ ((e b : Fin ℓ) : ℕ) := by
+  ext
+  rw [Units.coe_map, Units.val_pow_eq_pow_val, Units.val_pow_eq_pow_val]
+  exact he b
+
+lemma coeffMap_slotH (f g : LaurentSeries ℚ) (σ : K ≃ₐ[ℚ] K) (e : Equiv.Perm (Fin ℓ))
+    (he : ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e b : Fin ℓ) : ℕ)) (i : Fin (ℓ + 1)) :
+    coeffMap (σ : K →+* K) (slotH ℓ ζ f g i) = slotH ℓ ζ f g (liftPerm ℓ e i) := by
+  refine Fin.cases ?_ (fun b => ?_) i
+  · rw [liftPerm_zero, slotH_zero, coeffMap_coeffEmb]
+  · rw [liftPerm_succ, slotH_succ, slotH_succ, coeffMap_qTwist, coeffMap_coeffEmb,
+      units_map_zeta_pow ℓ ζ (σ : K →+* K) e (fun b => he b) b]
+
+lemma coeffMap_conj (σ : K ≃ₐ[ℚ] K) (e : Equiv.Perm (Fin ℓ))
+    (he : ∀ b : Fin ℓ, σ ((ζ : K) ^ (b : ℕ)) = (ζ : K) ^ ((e b : Fin ℓ) : ℕ)) (i : Fin (ℓ + 1)) :
+    coeffMap (σ : K →+* K) (PhiGen.conj ℓ ζ i) = PhiGen.conj ℓ ζ (liftPerm ℓ e i) := by
+  refine Fin.cases ?_ (fun b => ?_) i
+  · rw [liftPerm_zero, PhiGen.conj_zero, coeffMap_qExpand, coeffMap_coeffEmb]
+  · rw [liftPerm_succ, PhiGen.conj_succ, PhiGen.conj_succ, coeffMap_qTwist, coeffMap_coeffEmb,
+      units_map_zeta_pow ℓ ζ (σ : K →+* K) e (fun b => he b) b]
+
+include hζ in
+omit hℓ [Algebra ℚ K] in
+lemma zeta_pow_ell : ζ ^ ℓ = 1 := by
+  ext; rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one]
+
+include hζ in
+omit [Algebra ℚ K] in
+lemma zeta_mul_zeta_pow (b : Fin ℓ) : ζ * ζ ^ (b : ℕ) = ζ ^ (((b + 1 : Fin ℓ)) : ℕ) := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  rw [← pow_succ', Fin.val_add, Fin.val_one', Nat.add_mod_mod]
+  conv_lhs => rw [← Nat.div_add_mod ((b : ℕ) + 1) ℓ, pow_add, pow_mul, zeta_pow_ell ℓ ζ hζ, one_pow,
+    one_mul]
+
+include hζ in
+lemma qTwist_slotH (f g : LaurentSeries ℚ) (i : Fin (ℓ + 1)) :
+    qTwist ζ (slotH ℓ ζ f g i) = slotH ℓ ζ f g (liftPerm ℓ (Equiv.addRight (1 : Fin ℓ)) i) := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  refine Fin.cases ?_ (fun b => ?_) i
+  · rw [liftPerm_zero, slotH_zero, coeffEmb_qExpand, qTwist_qExpand, zpow_natCast, zeta_pow_ell ℓ ζ
+      hζ,
+      qTwist_one_apply]
+  · rw [liftPerm_succ, slotH_succ, slotH_succ, qTwist_qTwist, Equiv.coe_addRight, zeta_mul_zeta_pow
+      ℓ ζ hζ]
+
+include hζ in
+lemma qTwist_conj (i : Fin (ℓ + 1)) :
+    qTwist ζ (PhiGen.conj ℓ ζ i) = PhiGen.conj ℓ ζ (liftPerm ℓ (Equiv.addRight (1 : Fin ℓ)) i) := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  refine Fin.cases ?_ (fun b => ?_) i
+  · rw [liftPerm_zero, PhiGen.conj_zero, qTwist_qExpand]
+    congr 1
+    rw [show ((ℓ * ℓ : ℕ) : ℤ) = ((ℓ * ℓ : ℕ) : ℤ) from rfl, zpow_natCast, pow_mul, zeta_pow_ell ℓ ζ
+      hζ, one_pow,
+      qTwist_one_apply]
+  · rw [liftPerm_succ, PhiGen.conj_succ, PhiGen.conj_succ, qTwist_qTwist, Equiv.coe_addRight,
+      zeta_mul_zeta_pow ℓ ζ hζ]
+
+def interpK (f g : LaurentSeries ℚ) :
+    (LaurentSeries K)[X] := interpPoly (slotH ℓ ζ f g) (PhiGen.conj ℓ ζ)
+
+def conjK (f g : LaurentSeries ℚ) : (LaurentSeries K)[X] := conjPoly (slotH ℓ ζ f g)
+
+variable [IsGalois ℚ K] [FiniteDimensional ℚ K]
+
+include hζ in
+theorem exists_interpK_coeff_eq (f g : LaurentSeries ℚ) (k : ℕ) :
+    ∃ ξ : LaurentSeries ℚ, (interpK ℓ ζ f g).coeff k = coeffEmb K (qExpand ℚ ℓ ξ) := by
+  refine PhiGen.mem_range_coeffEmb_qExpand_of_mem_inter ?_ ?_
+  · refine mem_range_qExpand_of_qTwist_eq ℓ ζ hζ _ ?_
+    rw [← Polynomial.coeff_map, interpK, interpPoly_map]
+    have h1 : (⇑(qTwist ζ) ∘ slotH ℓ ζ f g) = slotH ℓ ζ f g ∘ liftPerm ℓ (Equiv.addRight (1 : Fin
+      ℓ)) :=
+      funext fun i => qTwist_slotH ℓ ζ hζ f g i
+    have h2 : (⇑(qTwist ζ) ∘ PhiGen.conj ℓ ζ) = PhiGen.conj ℓ ζ ∘ liftPerm ℓ (Equiv.addRight (1 :
+      Fin ℓ)) :=
+      funext fun i => qTwist_conj ℓ ζ hζ i
+    rw [h1, h2, interpPoly_perm]
+  · refine PhiGen.mem_range_coeffEmb_of_forall_coeffMap_eq
+      (fun c hc => (IsGalois.mem_range_algebraMap_iff_fixed c).mpr hc) fun σ => ?_
+    obtain ⟨e, he⟩ := PhiGen.exists_galoisPerm hζ (σ : K →+* K)
+    rw [← Polynomial.coeff_map, interpK, interpPoly_map]
+    have h1 : (⇑(coeffMap (σ : K →+* K)) ∘ slotH ℓ ζ f g) = slotH ℓ ζ f g ∘ liftPerm ℓ e :=
+      funext fun i => coeffMap_slotH ℓ ζ f g σ e he i
+    have h2 : (⇑(coeffMap (σ : K →+* K)) ∘ PhiGen.conj ℓ ζ) = PhiGen.conj ℓ ζ ∘ liftPerm ℓ e :=
+      funext fun i => coeffMap_conj ℓ ζ σ e he i
+    rw [h1, h2, interpPoly_perm]
+
+include hζ in
+theorem exists_conjK_coeff_eq (f g : LaurentSeries ℚ) (k : ℕ) :
+    ∃ π : LaurentSeries ℚ, (conjK ℓ ζ f g).coeff k = coeffEmb K (qExpand ℚ ℓ π) := by
+  refine PhiGen.mem_range_coeffEmb_qExpand_of_mem_inter ?_ ?_
+  · refine mem_range_qExpand_of_qTwist_eq ℓ ζ hζ _ ?_
+    rw [← Polynomial.coeff_map, conjK, conjPoly_map]
+    have h1 : (⇑(qTwist ζ) ∘ slotH ℓ ζ f g) = slotH ℓ ζ f g ∘ liftPerm ℓ (Equiv.addRight (1 : Fin
+      ℓ)) :=
+      funext fun i => qTwist_slotH ℓ ζ hζ f g i
+    rw [h1, conjPoly_perm]
+  · refine PhiGen.mem_range_coeffEmb_of_forall_coeffMap_eq
+      (fun c hc => (IsGalois.mem_range_algebraMap_iff_fixed c).mpr hc) fun σ => ?_
+    obtain ⟨e, he⟩ := PhiGen.exists_galoisPerm hζ (σ : K →+* K)
+    rw [← Polynomial.coeff_map, conjK, conjPoly_map]
+    have h1 : (⇑(coeffMap (σ : K →+* K)) ∘ slotH ℓ ζ f g) = slotH ℓ ζ f g ∘ liftPerm ℓ e :=
+      funext fun i => coeffMap_slotH ℓ ζ f g σ e he i
+    rw [h1, conjPoly_perm]
+
+end Slots
+
+def RealL (h : ℝ) (A : LaurentSeries ℂ) (F : ℍ → ℂ) : Prop :=
+  ∀ τ : ℍ, HasSum (fun m : ℤ => A.coeff m * 𝕢 h (τ : ℂ) ^ m) (F τ)
+
+namespace RealL
+
+variable {h : ℝ} {A B : LaurentSeries ℂ} {F G : ℍ → ℂ}
+
+lemma add (hA : RealL h A F) (hB : RealL h B G) : RealL h (A + B) (F + G) := fun τ => by
+  simpa [add_mul] using (hA τ).add (hB τ)
+
+lemma neg (hA : RealL h A F) : RealL h (-A) (-F) := fun τ => by
+  simpa [neg_mul] using (hA τ).neg
+
+lemma sub (hA : RealL h A F) (hB : RealL h B G) : RealL h (A - B) (F - G) := fun τ => by
+  simpa [sub_mul] using (hA τ).sub (hB τ)
+
+lemma mul (hh : 0 < h) (hA : RealL h A F) (hB : RealL h B G) : RealL h (A * B) (F * G) := fun τ =>
+  hasSum_qParam_mul_laurent h hh A B F G hA hB τ
+
+lemma single (h : ℝ) (a : ℂ) (n : ℤ) :
+    RealL h (HahnSeries.single n a) (fun τ => a * 𝕢 h (τ : ℂ) ^ n) := fun τ => by
+  refine (hasSum_ite_eq n (a * 𝕢 h (τ : ℂ) ^ n)).congr_fun fun m => ?_
+  by_cases hm : m = n
+  · subst hm; simp
+  · simp [HahnSeries.coeff_single_of_ne hm, hm]
+
+lemma C (h : ℝ) (a : ℂ) : RealL h (HahnSeries.C a) (fun _ => a) := by
+  simpa using single h a 0
+
+lemma one (h : ℝ) : RealL h 1 1 := by
+  simpa [Pi.one_def] using C h 1
+
+lemma zero (h : ℝ) : RealL h 0 0 := fun τ => by simp [hasSum_zero]
+
+lemma congr {A' : LaurentSeries ℂ} {F' : ℍ → ℂ} (hA : RealL h A F) (h1 : A = A')
+    (h2 : ∀ τ, F τ = F' τ) :
+    RealL h A' F' := fun τ => by rw [← h1, ← h2]; exact hA τ
+
+lemma sum {ι : Type} (s : Finset ι) {A : ι → LaurentSeries ℂ} {F : ι → ℍ → ℂ}
+    (hAF : ∀ i ∈ s, RealL h (A i) (F i)) : RealL h (∑ i ∈ s, A i) (fun τ => ∑ i ∈ s, F i τ) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => simpa [Pi.zero_def] using zero h
+  | insert a s ha ih =>
+    have h1 :=
+      (hAF a (Finset.mem_insert_self a s)).add (ih fun i hi => hAF i (Finset.mem_insert_of_mem hi))
+    refine h1.congr (Finset.sum_insert ha).symm fun τ => ?_
+    simp [Finset.sum_insert ha]
+
+lemma prod (hh : 0 < h) {ι : Type} (s : Finset ι) {A : ι → LaurentSeries ℂ} {F : ι → ℍ → ℂ}
+    (hAF : ∀ i ∈ s, RealL h (A i) (F i)) : RealL h (∏ i ∈ s, A i) (fun τ => ∏ i ∈ s, F i τ) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => simpa [Pi.one_def] using one h
+  | insert a s ha ih =>
+    have h1 :=
+      (hAF a (Finset.mem_insert_self a s)).mul hh (ih fun i hi => hAF i (Finset.mem_insert_of_mem
+        hi))
+    refine h1.congr (Finset.prod_insert ha).symm fun τ => ?_
+    simp [Finset.prod_insert ha]
+
+lemma coeff_prod_X_sub_C (hh : 0 < h) {ι : Type} (s : Finset ι) {a : ι → LaurentSeries ℂ}
+    {α : ι → ℍ → ℂ} (haα : ∀ i ∈ s, RealL h (a i) (α i)) (k : ℕ) :
+    RealL h ((∏ i ∈ s, (Polynomial.X - Polynomial.C (a i))).coeff k)
+      (fun τ => (∏ i ∈ s, (Polynomial.X - Polynomial.C (α i τ))).coeff k) := by
+  classical
+  induction s using Finset.induction_on generalizing k with
+  | empty =>
+    simp only [Finset.prod_empty, Polynomial.coeff_one]
+    by_cases hk : k = 0
+    · subst hk; simpa [Pi.one_def] using one h
+    · simpa [hk, Pi.zero_def] using zero h
+  | insert b s hb ih =>
+    have ih' := fun k => ih (fun i hi => haα i (Finset.mem_insert_of_mem hi)) k
+    have hb' := haα b (Finset.mem_insert_self b s)
+    have hA : (∏ i ∈ insert b s, (Polynomial.X - Polynomial.C (a i))) =
+        (∏ i ∈ s, (Polynomial.X - Polynomial.C (a i))) * (Polynomial.X - Polynomial.C (a b)) :=
+      (Finset.prod_insert hb).trans (mul_comm (G := Polynomial (LaurentSeries ℂ)) _ _)
+    have hfun : ∀ τ : ℍ, (∏ i ∈ insert b s, (Polynomial.X - Polynomial.C (α i τ))) =
+        (∏ i ∈ s, (Polynomial.X - Polynomial.C (α i τ))) * (Polynomial.X - Polynomial.C (α b τ)) :=
+      fun τ => (Finset.prod_insert hb).trans (mul_comm (G := Polynomial ℂ) _ _)
+    cases k with
+    | zero =>
+      refine ((ih' 0).mul hh hb').neg.congr ?_ fun τ => ?_
+      · rw [hA, Polynomial.mul_coeff_zero, Polynomial.coeff_sub, Polynomial.coeff_X_zero,
+          Polynomial.coeff_C_zero, zero_sub]
+        exact (mul_neg (α := LaurentSeries ℂ) _ _).symm
+      · simp only [hfun τ, Polynomial.mul_coeff_zero, Pi.neg_apply, Pi.mul_apply,
+          Polynomial.coeff_sub,
+          Polynomial.coeff_X_zero, Polynomial.coeff_C_zero, zero_sub, mul_neg]
+    | succ k =>
+      refine ((ih' k).sub ((ih' (k + 1)).mul hh hb')).congr ?_ fun τ => ?_
+      · rw [hA, Polynomial.coeff_mul_X_sub_C]
+      · simp only [hfun τ, Polynomial.coeff_mul_X_sub_C, Pi.sub_apply, Pi.mul_apply]
+
+lemma interpPoly_coeff (hh : 0 < h) {n : ℕ} {Hs Ys : Fin n → LaurentSeries ℂ} {η υ : Fin n → ℍ → ℂ}
+    (hH : ∀ i, RealL h (Hs i) (η i)) (hY : ∀ i, RealL h (Ys i) (υ i)) (k : ℕ) :
+    RealL h ((interpPoly Hs Ys).coeff k)
+      (fun τ => (interpPoly (fun i => η i τ) (fun i => υ i τ)).coeff k) := by
+  unfold interpPoly
+  have h1 : ∀ i ∈ (Finset.univ : Finset (Fin n)),
+      RealL h ((Polynomial.C (Hs i) * ∏ m ∈ Finset.univ.erase i, (Polynomial.X - Polynomial.C (Ys
+        m))).coeff k)
+        (fun τ => (Polynomial.C (η i τ) *
+          ∏ m ∈ Finset.univ.erase i, (Polynomial.X - Polynomial.C (υ m τ))).coeff k) := by
+    intro i _
+    refine ((hH i).mul hh (coeff_prod_X_sub_C hh (Finset.univ.erase i) (fun m _ => hY m) k)).congr
+      ?_ fun τ => ?_
+    · rw [Polynomial.coeff_C_mul]
+    · simp only [Pi.mul_apply, Polynomial.coeff_C_mul]
+  refine (sum Finset.univ h1).congr ?_ fun τ => ?_
+  · rw [Polynomial.finsetSum_coeff]
+  · simp only [Polynomial.finsetSum_coeff]
+
+lemma conjPoly_coeff (hh : 0 < h) {n : ℕ} {Hs : Fin n → LaurentSeries ℂ} {η : Fin n → ℍ → ℂ}
+    (hH : ∀ i, RealL h (Hs i) (η i)) (k : ℕ) :
+    RealL h ((conjPoly Hs).coeff k) (fun τ => (conjPoly fun i => η i τ).coeff k) :=
+  coeff_prod_X_sub_C hh Finset.univ (fun i _ => hH i) k
+
+end RealL
+
+section Periods
+
+variable (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)]
+
+lemma realL_one_of_realL_qExpand (x : LaurentSeries ℂ) (F : ℍ → ℂ) (hx : RealL ℓ (qExpand ℂ ℓ x) F)
+    :
+    RealL 1 x F := by
+  intro τ
+  have hinj : Function.Injective (fun n : ℤ => (ℓ : ℤ) * n) :=
+    mul_right_injective₀ (by exact_mod_cast hℓ.out.ne_zero)
+  have h := hx τ
+  rw [← hinj.hasSum_iff] at h
+  · refine h.congr_fun fun n => ?_
+    simp only [Function.comp_apply, qExpand_coeff_mul]
+    congr 1
+    rw [zpow_mul, zpow_natCast]
+    congr 1
+    simp only [Periodic.qParam, Complex.ofReal_one, div_one, Complex.ofReal_natCast]
+    rw [← Complex.exp_nat_mul]
+    congr 1
+    field_simp [(Nat.cast_ne_zero.mpr hℓ.out.ne_zero : (ℓ : ℂ) ≠ 0)]
+  · intro m hm
+    rw [qExpand_coeff_of_not_dvd ℓ _ (fun ⟨n, hn⟩ => hm ⟨n, hn.symm⟩), zero_mul]
+
+lemma realL_qExpand_of_realL_one (x : LaurentSeries ℂ) (F : ℍ → ℂ) (hx : RealL 1 x F) :
+    RealL ℓ (qExpand ℂ ℓ x) F := by
+  intro τ
+  have hinj : Function.Injective (fun n : ℤ => (ℓ : ℤ) * n) :=
+    mul_right_injective₀ (by exact_mod_cast hℓ.out.ne_zero)
+  rw [← hinj.hasSum_iff]
+  · refine (hx τ).congr_fun fun n => ?_
+    simp only [Function.comp_apply, qExpand_coeff_mul]
+    congr 1
+    rw [zpow_mul, zpow_natCast]
+    congr 1
+    simp only [Periodic.qParam, Complex.ofReal_one, div_one, Complex.ofReal_natCast]
+    rw [← Complex.exp_nat_mul]
+    congr 1
+    field_simp [(Nat.cast_ne_zero.mpr hℓ.out.ne_zero : (ℓ : ℂ) ≠ 0)]
+  · intro m hm
+    rw [qExpand_coeff_of_not_dvd ℓ _ (fun ⟨n, hn⟩ => hm ⟨n, hn.symm⟩), zero_mul]
+
+def expRoot : ℂ := Complex.exp (2 * Real.pi * Complex.I / ℓ)
+
+lemma isPrimitiveRoot_expRoot : IsPrimitiveRoot (expRoot ℓ) ℓ :=
+  Complex.isPrimitiveRoot_exp ℓ hℓ.out.ne_zero
+
+omit hℓ in
+lemma expRoot_pow_zpow (b : ℕ) (m : ℤ) :
+    (expRoot ℓ ^ b) ^ m = Complex.exp (2 * Real.pi * Complex.I * b * m / ℓ) := by
+  rw [expRoot, ← Complex.exp_nat_mul, ← Complex.exp_int_mul]
+  congr 1
+  ring
+
+omit hℓ in
+lemma qParam_T_pow_smul (b : ℕ) (τ : ℍ) :
+    𝕢 ℓ (((ModularGroup.T ^ b • τ : ℍ)) : ℂ) = expRoot ℓ ^ b * 𝕢 ℓ (τ : ℂ) := by
+  have h := modular_T_zpow_smul τ (b : ℤ)
+  rw [zpow_natCast] at h
+  rw [h, coe_vadd, expRoot, ← Complex.exp_nat_mul]
+  simp only [Periodic.qParam, Complex.ofReal_natCast, Int.cast_natCast]
+  rw [← Complex.exp_add]
+  congr 1
+  ring
+
+omit hℓ in
+lemma realL_twist (A : LaurentSeries ℂ) (G : ℍ → ℂ) (hA : RealL ℓ A G) (b : ℕ) (B : LaurentSeries ℂ)
+    (hB : ∀ m : ℤ, B.coeff m = (expRoot ℓ ^ b) ^ m * A.coeff m) :
+    RealL ℓ B (fun τ => G (ModularGroup.T ^ b • τ)) := by
+  intro τ
+  have h := hA (ModularGroup.T ^ b • τ)
+  refine h.congr_fun fun m => ?_
+  rw [hB m, qParam_T_pow_smul, mul_zpow]
+  ring
+
+end Periods
+
+section Analytic
+
+variable {K : Type} [Field K] [Algebra ℚ K] (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ)
+  (hζ : IsPrimitiveRoot (ζ : K) ℓ) (σ : K →+* ℂ) (hσ : σ (ζ : K) = expRoot ℓ)
+
+def jt (τ : ℍ) : ℂ := ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ
+
+def jtN (τ : ℍ) : ℂ := jt (ModularForm.heckeDiagMatrix ℓ • τ)
+
+abbrev castC : ℚ →+* ℂ := Rat.castHom ℂ
+
+omit hℓ in
+lemma coeffMap_sigma_coeffEmb (x : LaurentSeries ℚ) :
+    coeffMap σ (coeffEmb K x) = coeffMap castC x := by
+  ext m
+  rw [coeffMap_coeff, coeffEmb_coeff, coeffMap_coeff, eq_ratCast, map_ratCast]
+  rfl
+
+def cosetRep (i : Fin (ℓ + 1)) : SL(2, ℤ) :=
+  Fin.cases (1 : SL(2, ℤ)) (fun b : Fin ℓ => ModularGroup.S * ModularGroup.T ^ (b : ℕ)) i
+
+omit hℓ in
+@[scoped simp] lemma cosetRep_zero : cosetRep ℓ 0 = 1 := by simp [cosetRep]
+omit hℓ in
+@[scoped simp] lemma cosetRep_succ (b : Fin ℓ) :
+    cosetRep ℓ b.succ = ModularGroup.S * ModularGroup.T ^ (b : ℕ) := by
+  simp [cosetRep]
+
+def slotF (F : ℍ → ℂ) (i : Fin (ℓ + 1)) (τ : ℍ) : ℂ := F (cosetRep ℓ i • τ)
+
+def slotJ (i : Fin (ℓ + 1)) (τ : ℍ) : ℂ := jtN ℓ (cosetRep ℓ i • τ)
+
+variable (f g : LaurentSeries ℚ) (F : ℍ → ℂ)
+  (hF : ∀ τ : ℍ, HasSum (fun m : ℤ => ((f.coeff m : ℚ) : ℂ) * 𝕢 1 (τ : ℂ) ^ m) (F τ))
+  (hG : ∀ τ : ℍ, HasSum (fun m : ℤ => ((g.coeff m : ℚ) : ℂ) * 𝕢 ℓ (τ : ℂ) ^ m) (F (ModularGroup.S •
+    τ)))
+
+include hF in
+omit hℓ in
+lemma realL_fC : RealL 1 (coeffMap castC f) F := fun τ => hF τ
+
+include hG in
+omit hℓ in
+lemma realL_gC : RealL ℓ (coeffMap castC g) (fun τ => F (ModularGroup.S • τ)) := fun τ => hG τ
+
+include hF hG hσ in
+lemma realL_slotH (i : Fin (ℓ + 1)) :
+    RealL ℓ (coeffMap σ (slotH ℓ ζ f g i)) (slotF ℓ F i) := by
+  refine Fin.cases ?_ (fun b => ?_) i
+  · have h := realL_qExpand_of_realL_one ℓ _ _ (realL_fC f F hF)
+    refine h.congr ?_ fun τ => ?_
+    · rw [slotH_zero, coeffMap_sigma_coeffEmb, coeffMap_qExpand]
+    · simp [slotF]
+  · have h :=
+      realL_twist ℓ _ _ (realL_gC ℓ g F hG) (b : ℕ) (coeffMap σ (slotH ℓ ζ f g b.succ)) fun m => by
+      rw [slotH_succ, coeffMap_coeff, qTwist_coeff, map_mul, Units.val_zpow_eq_zpow_val, map_zpow₀,
+        Units.val_pow_eq_pow_val, map_pow, hσ, coeffEmb_coeff, eq_ratCast, map_ratCast,
+        coeffMap_coeff]
+      rfl
+    refine h.congr rfl fun τ => ?_
+    simp only [slotF, cosetRep_succ, mul_smul]
+
+lemma coeffMap_conj_zero_eq :
+    coeffMap σ (PhiGen.conj ℓ ζ 0) = qExpand ℂ (ℓ * ℓ) (coeffMap castC jq) := by
+  rw [PhiGen.conj_zero, coeffMap_qExpand, coeffMap_sigma_coeffEmb]
+
+omit hℓ in
+lemma realL_jqC : RealL 1 (coeffMap castC jq) jt := fun τ => hasSum_jq_qParam τ
+
+omit hℓ in
+lemma heckeDiag_smul_S_T_pow_smul [NeZero ℓ] (b : ℕ) (τ : ℍ) :
+    ModularForm.heckeDiagMatrix ℓ • (ModularGroup.S * ModularGroup.T ^ b) • τ =
+      ModularGroup.S • ModularForm.heckeMatrix ℓ b • τ := by
+  have hT : ((ModularGroup.T ^ b : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) = !![1, (b : ℤ); 0, 1] :=
+    by
+    have := ModularGroup.coe_T_zpow (b : ℤ)
+    rwa [zpow_natCast] at this
+  set g : SL(2, ℤ) := ModularGroup.S * ModularGroup.T ^ b with hg
+  have hg' : (g : Matrix (Fin 2) (Fin 2) ℤ) = !![0, -1; 1, (b : ℤ)] := by
+    rw [hg, Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_S, hT]
+    ext i j
+    fin_cases i <;> fin_cases j <;> simp [Matrix.mul_apply, Fin.sum_univ_two]
+  have h00 : g 0 0 = 0 := congrFun (congrFun hg' 0) 0
+  have h01 : g 0 1 = -1 := congrFun (congrFun hg' 0) 1
+  have h10 : g 1 0 = 1 := congrFun (congrFun hg' 1) 0
+  have h11 : g 1 1 = b := congrFun (congrFun hg' 1) 1
+  clear_value g
+  have hmat : ModularForm.heckeDiagMatrix ℓ * Matrix.SpecialLinearGroup.mapGL ℝ g =
+      Matrix.SpecialLinearGroup.mapGL ℝ ModularGroup.S * ModularForm.heckeMatrix ℓ b := by
+    ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp [Matrix.mul_apply, Fin.sum_univ_two, ModularForm.val_heckeDiagMatrix (NeZero.ne ℓ),
+        ModularForm.val_heckeMatrix (NeZero.ne ℓ), ModularGroup.coe_S, h00, h01, h10, h11]
+  have h1 : ModularForm.heckeDiagMatrix ℓ • g • τ =
+      (ModularForm.heckeDiagMatrix ℓ * Matrix.SpecialLinearGroup.mapGL ℝ g) • τ := by
+    rw [mul_smul]; rfl
+  have h2 : ModularGroup.S • ModularForm.heckeMatrix ℓ b • τ =
+      (Matrix.SpecialLinearGroup.mapGL ℝ ModularGroup.S * ModularForm.heckeMatrix ℓ b) • τ := by
+    rw [mul_smul]; rfl
+  rw [h1, h2, hmat]
+
+include hσ in
+lemma realL_conj (i : Fin (ℓ + 1)) : RealL ℓ (coeffMap σ (PhiGen.conj ℓ ζ i)) (slotJ ℓ i) := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  refine Fin.cases ?_ (fun b => ?_) i
+  · intro τ
+    have h := hasSum_qParam_heckeDiagMatrix_smul ℓ (coeffMap castC jq) jt realL_jqC τ
+    rw [coeffMap_conj_zero_eq]
+    simpa [slotJ, jtN] using h
+  · intro τ
+    have h := hasSum_qParam_heckeMatrix_smul ℓ (b : ℕ) (coeffMap castC jq) jt realL_jqC τ
+    have hval : slotJ ℓ b.succ τ = jt (ModularForm.heckeMatrix ℓ (b : ℕ) • τ) := by
+      rw [slotJ, jtN, cosetRep_succ, heckeDiag_smul_S_T_pow_smul]
+      exact E4_cube_div_discriminant_smul ModularGroup.S _
+    rw [hval]
+    refine h.congr_fun fun m => ?_
+    congr 1
+    rw [PhiGen.conj_succ, coeffMap_coeff, qTwist_coeff, map_mul, Units.val_zpow_eq_zpow_val,
+      map_zpow₀,
+      Units.val_pow_eq_pow_val, map_pow, hσ, expRoot_pow_zpow, coeffEmb_coeff, eq_ratCast,
+      map_ratCast,
+      coeffMap_coeff]
+    rfl
+
+def interpFun (k : ℕ) (τ : ℍ) :
+    ℂ := (interpPoly (fun i => slotF ℓ F i τ) (fun i => slotJ ℓ i τ)).coeff k
+
+def conjFun (k : ℕ) (τ : ℍ) : ℂ := (conjPoly fun i => slotF ℓ F i τ).coeff k
+
+variable (hinv : ∀ γ ∈ CongruenceSubgroup.Gamma0 ℓ, ∀ τ : ℍ, F (γ • τ) = F τ)
+
+omit hℓ in
+lemma jtN_smul [NeZero ℓ] (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 ℓ) (τ : ℍ) :
+    jtN ℓ (γ • τ) = jtN ℓ τ := by
+  obtain ⟨γ', hγ', -⟩ := exists_sl2_heckeDiagMatrix_smul_eq ℓ γ hγ
+  rw [jtN, jtN, hγ' τ]
+  exact E4_cube_div_discriminant_smul γ' _
+
+include hinv in
+lemma slots_smul (γ : SL(2, ℤ)) : ∃ e : Equiv.Perm (Fin (ℓ + 1)),
+    (∀ i τ, slotF ℓ F i (γ • τ) = slotF ℓ F (e i) τ) ∧ (∀ i τ, slotJ ℓ i (γ • τ) = slotJ ℓ (e i) τ)
+      := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  obtain ⟨e, he⟩ := exists_perm_gamma0_cosetReps ℓ γ
+  have key : ∀ (i : Fin (ℓ + 1)) (τ : ℍ),
+      cosetRep ℓ i • γ • τ = (cosetRep ℓ i * γ * (cosetRep ℓ (e i))⁻¹) • cosetRep ℓ (e i) • τ := by
+    intro i τ
+    simp only [smul_smul, inv_mul_cancel_right]
+  have he' : ∀ i, cosetRep ℓ i * γ * (cosetRep ℓ (e i))⁻¹ ∈ CongruenceSubgroup.Gamma0 ℓ := he
+  refine ⟨e, fun i τ => ?_, fun i τ => ?_⟩
+  · rw [slotF, slotF, key, hinv _ (he' i)]
+  · rw [slotJ, slotJ, key, jtN_smul ℓ _ (he' i)]
+
+include hinv in
+lemma interpFun_smul (k : ℕ) (γ : SL(2, ℤ)) (τ : ℍ) :
+    interpFun ℓ F k (γ • τ) = interpFun ℓ F k τ := by
+  obtain ⟨e, h1, h2⟩ := slots_smul ℓ F hinv γ
+  unfold interpFun
+  have hH : (fun i => slotF ℓ F i (γ • τ)) = (fun i => slotF ℓ F i τ) ∘ e := funext fun i => h1 i τ
+  have hY : (fun i => slotJ ℓ i (γ • τ)) = (fun i => slotJ ℓ i τ) ∘ e := funext fun i => h2 i τ
+  rw [hH, hY, interpPoly_perm]
+
+include hinv in
+lemma conjFun_smul (k : ℕ) (γ : SL(2, ℤ)) (τ : ℍ) : conjFun ℓ F k (γ • τ) = conjFun ℓ F k τ := by
+  obtain ⟨e, h1, -⟩ := slots_smul ℓ F hinv γ
+  unfold conjFun
+  have hH : (fun i => slotF ℓ F i (γ • τ)) = (fun i => slotF ℓ F i τ) ∘ e := funext fun i => h1 i τ
+  rw [hH, conjPoly_perm]
+
+include hF hG hσ hinv in
+lemma mem_adjoin_of_interpK_coeff_eq (k : ℕ) (ξ : LaurentSeries ℚ)
+    (hξ : (interpK ℓ ζ f g).coeff k = coeffEmb K (qExpand ℚ ℓ ξ)) : ξ ∈ Algebra.adjoin ℚ {jq} := by
+  have h1 : RealL ℓ (coeffMap σ ((interpK ℓ ζ f g).coeff k)) (interpFun ℓ F k) := by
+    have h := RealL.interpPoly_coeff (h := (ℓ : ℝ)) (by exact_mod_cast hℓ.out.pos)
+      (fun i => realL_slotH ℓ ζ σ hσ f g F hF hG i) (fun i => realL_conj ℓ ζ σ hσ i) k
+    refine h.congr ?_ fun τ => rfl
+    rw [← Polynomial.coeff_map, interpK, interpPoly_map]
+    rfl
+  rw [hξ, coeffMap_sigma_coeffEmb, coeffMap_qExpand] at h1
+  have h2 := realL_one_of_realL_qExpand ℓ _ _ h1
+  exact mem_adjoin_jq_of_hasSum_of_slash_invariant ξ (interpFun ℓ F k) h2
+    (fun γ τ => interpFun_smul ℓ F hinv k γ τ)
+
+include hF hG hσ hinv in
+lemma mem_adjoin_of_conjK_coeff_eq (k : ℕ) (π : LaurentSeries ℚ)
+    (hπ : (conjK ℓ ζ f g).coeff k = coeffEmb K (qExpand ℚ ℓ π)) : π ∈ Algebra.adjoin ℚ {jq} := by
+  have h1 : RealL ℓ (coeffMap σ ((conjK ℓ ζ f g).coeff k)) (conjFun ℓ F k) := by
+    have h := RealL.conjPoly_coeff (h := (ℓ : ℝ)) (by exact_mod_cast hℓ.out.pos)
+      (fun i => realL_slotH ℓ ζ σ hσ f g F hF hG i) k
+    refine h.congr ?_ fun τ => rfl
+    rw [← Polynomial.coeff_map, conjK, conjPoly_map]
+    rfl
+  rw [hπ, coeffMap_sigma_coeffEmb, coeffMap_qExpand] at h1
+  have h2 := realL_one_of_realL_qExpand ℓ _ _ h1
+  exact mem_adjoin_jq_of_hasSum_of_slash_invariant π (conjFun ℓ F k) h2
+    (fun γ τ => conjFun_smul ℓ F hinv k γ τ)
+
+end Analytic
+
+section Assembly
+
+variable {K : Type} [Field K] [Algebra ℚ K] [IsGalois ℚ K] [FiniteDimensional ℚ K]
+  (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) ℓ) (σ : K →+* ℂ)
+  (hσ : σ (ζ : K) = expRoot ℓ)
+  (f g : LaurentSeries ℚ) (F : ℍ → ℂ)
+  (hF : ∀ τ : ℍ, HasSum (fun m : ℤ => ((f.coeff m : ℚ) : ℂ) * 𝕢 1 (τ : ℂ) ^ m) (F τ))
+  (hG : ∀ τ : ℍ, HasSum (fun m : ℤ => ((g.coeff m : ℚ) : ℂ) * 𝕢 ℓ (τ : ℂ) ^ m) (F (ModularGroup.S •
+    τ)))
+  (hinv : ∀ γ ∈ CongruenceSubgroup.Gamma0 ℓ, ∀ τ : ℍ, F (γ • τ) = F τ)
+
+def iota : LaurentSeries ℚ →+* LaurentSeries K := (coeffEmb K).comp (qExpand ℚ ℓ)
+
+omit [IsGalois ℚ K] [FiniteDimensional ℚ K] in
+lemma iota_apply (x : LaurentSeries ℚ) : iota (K := K) ℓ x = coeffEmb K (qExpand ℚ ℓ x) := rfl
+
+omit [IsGalois ℚ K] [FiniteDimensional ℚ K] in
+lemma coeffEmb_injective' :
+    Function.Injective (coeffEmb K : LaurentSeries ℚ → LaurentSeries K) := by
+  intro x y h
+  ext m
+  have hm := congrArg (fun z : LaurentSeries K => z.coeff m) h
+  simp only [coeffEmb_coeff] at hm
+  exact (algebraMap ℚ K).injective hm
+
+omit [IsGalois ℚ K] [FiniteDimensional ℚ K] in
+lemma iota_injective : Function.Injective (iota (K := K) ℓ) :=
+  coeffEmb_injective'.comp (qExpand_injective (R := ℚ) ℓ)
+
+omit [IsGalois ℚ K] [FiniteDimensional ℚ K] in
+lemma iota_eq_slotH_zero : iota ℓ f = slotH ℓ ζ f g 0 := by
+  rw [iota_apply, slotH_zero]
+
+omit [IsGalois ℚ K] [FiniteDimensional ℚ K] in
+lemma iota_jqN : iota (K := K) ℓ (jqN ℓ) = PhiGen.conj ℓ ζ 0 := by
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  rw [iota_apply, jqN, qExpand_qExpand, PhiGen.conj_zero, coeffEmb_qExpand]
+
+def dHat :
+    LaurentSeries K := ∏ m ∈ Finset.univ.erase (0 : Fin (ℓ + 1)), (PhiGen.conj ℓ ζ 0 - PhiGen.conj ℓ
+      ζ m)
+
+include hζ in
+omit [IsGalois ℚ K] [FiniteDimensional ℚ K] in
+lemma dHat_ne_zero : dHat ℓ ζ ≠ 0 := by
+  rw [dHat, Finset.prod_ne_zero_iff]
+  intro m hm h0
+  exact (Finset.ne_of_mem_erase hm) ((PhiGen.conj_injective ℓ ζ hζ (sub_eq_zero.mp h0)).symm)
+
+include hζ in
+lemma exists_sum_eq_mul_dHat (hmem : ∀ (k : ℕ) (ξ : LaurentSeries ℚ),
+      (interpK ℓ ζ f g).coeff k = coeffEmb K (qExpand ℚ ℓ ξ) → ξ ∈ Algebra.adjoin ℚ {jq}) :
+    ∃ x : LaurentSeries ℚ, x ∈ modularFunctionField ℓ ∧ iota ℓ x = iota ℓ f * dHat ℓ ζ := by
+  classical
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  choose ξ hξ using fun k => exists_interpK_coeff_eq ℓ ζ hζ f g k
+  have hadj : Algebra.adjoin ℚ {jq} ≤ (modularFunctionField ℓ).toSubalgebra :=
+    Algebra.adjoin_le (Set.singleton_subset_iff.mpr (jq_mem ℓ))
+  refine ⟨∑ k ∈ Finset.range ((interpK ℓ ζ f g).natDegree + 1), ξ k * jqN ℓ ^ k, ?_, ?_⟩
+  · refine sum_mem fun k _ => mul_mem (hadj (hmem k (ξ k) (hξ k))) (pow_mem (jqN_mem ℓ) k)
+  · rw [map_sum]
+    simp only [map_mul, map_pow, iota_jqN ℓ ζ, iota_apply, ← hξ]
+    rw [← Polynomial.eval_eq_sum_range, interpK, interpPoly_eval, ← slotH_zero ℓ ζ f g, dHat]
+
+include hζ hσ hF hG hinv in
+theorem mem_modularFunctionField_of_data : f ∈ modularFunctionField ℓ := by
+  classical
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  obtain ⟨x, hx, hιx⟩ := exists_sum_eq_mul_dHat ℓ ζ hζ f g
+    (fun k ξ h => mem_adjoin_of_interpK_coeff_eq ℓ ζ σ hσ f g F hF hG hinv k ξ h)
+  have h1F : ∀ τ : ℍ, HasSum (fun m : ℤ => (((1 : LaurentSeries ℚ).coeff m : ℚ) : ℂ) * 𝕢 1 (τ : ℂ) ^
+    m)
+      ((fun _ : ℍ => (1 : ℂ)) τ) := by
+    intro τ
+    have h := RealL.one 1 τ
+    rw [← map_one (coeffMap castC)] at h
+    exact h
+  have h1G : ∀ τ : ℍ, HasSum (fun m : ℤ => (((1 : LaurentSeries ℚ).coeff m : ℚ) : ℂ) * 𝕢 ℓ (τ : ℂ) ^
+    m)
+      ((fun _ : ℍ => (1 : ℂ)) (ModularGroup.S • τ)) := by
+    intro τ
+    have h := RealL.one (ℓ : ℝ) τ
+    rw [← map_one (coeffMap castC)] at h
+    exact h
+  obtain ⟨d, hd, hιd⟩ := exists_sum_eq_mul_dHat ℓ ζ hζ 1 1
+    (fun k ξ h => mem_adjoin_of_interpK_coeff_eq ℓ ζ σ hσ 1 1 (fun _ => 1) h1F h1G (fun _ _ _ =>
+      rfl) k ξ h)
+  rw [map_one, one_mul] at hιd
+  have hd0 : d ≠ 0 := by
+    rintro rfl
+    exact dHat_ne_zero ℓ ζ hζ (by rw [map_zero] at hιd; exact hιd.symm)
+  have hfd : f * d = x := iota_injective (K := K) ℓ (by rw [map_mul, hιd, hιx])
+  have hf : f = x * d⁻¹ := by rw [← hfd, mul_inv_cancel_right₀ hd0]
+  rw [hf]
+  exact mul_mem hx (inv_mem hd)
+
+include hζ hσ hF hG hinv in
+theorem isIntegral_of_data : IsIntegral (Algebra.adjoin ℚ {jq}) f := by
+  classical
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  choose π hπ using fun k => exists_conjK_coeff_eq ℓ ζ hζ f g k
+  have hπmem : ∀ k, π k ∈ Algebra.adjoin ℚ {jq} := fun k =>
+    mem_adjoin_of_conjK_coeff_eq ℓ ζ σ hσ f g F hF hG hinv k (π k) (hπ k)
+  have hdeg : (conjK ℓ ζ f g).natDegree = ℓ + 1 := conjPoly_natDegree _
+  have hmon : (conjK ℓ ζ f g).Monic := conjPoly_monic _
+  let p : Polynomial (Algebra.adjoin ℚ {jq}) :=
+    ∑ k ∈ Finset.range (ℓ + 2),
+      Polynomial.C (⟨π k, hπmem k⟩ : Algebra.adjoin ℚ {jq}) * (Polynomial.X : Polynomial
+        (Algebra.adjoin ℚ {jq})) ^ k
+  have hcoeffp : ∀ n, p.coeff n = if n < ℓ + 2 then (⟨π n, hπmem n⟩ : Algebra.adjoin ℚ {jq}) else 0
+    :=
+    by
+    intro n
+    simp only [p, Polynomial.finsetSum_coeff, Polynomial.coeff_C_mul, Polynomial.coeff_X_pow,
+      mul_ite, mul_one,
+      mul_zero]
+    rw [Finset.sum_ite_eq]
+    simp only [Finset.mem_range]
+  have hmapmap : (p.map (algebraMap (Algebra.adjoin ℚ {jq}) (LaurentSeries ℚ))).map (iota ℓ) = conjK
+    ℓ ζ f g :=
+    by
+    rw [Polynomial.map_map]
+    simp only [p, Polynomial.map_sum, Polynomial.map_mul, Polynomial.map_pow, Polynomial.map_C,
+      Polynomial.map_X,
+      RingHom.comp_apply]
+    have hk : ∀ k, (iota (K := K) ℓ) ((algebraMap (Algebra.adjoin ℚ {jq}) (LaurentSeries ℚ)) ⟨π k,
+      hπmem k⟩) =
+        (conjK ℓ ζ f g).coeff k :=
+      fun k => (hπ k).symm
+    simp only [hk]
+    exact (Polynomial.as_sum_range_C_mul_X_pow' _ (by rw [hdeg]; omega)).symm
+  refine ⟨p, ?_, ?_⟩
+  · refine Polynomial.monic_of_natDegree_le_of_coeff_eq_one (ℓ + 1) ?_ ?_
+    · exact Polynomial.natDegree_sum_le_of_forall_le _ _ fun k hk =>
+        (Polynomial.natDegree_C_mul_X_pow_le _ k).trans (Nat.lt_succ_iff.mp (Finset.mem_range.mp
+          hk))
+    · rw [hcoeffp, ite_eq_left (by omega)]
+      refine Subtype.ext ?_
+      apply iota_injective (K := K) ℓ
+      rw [iota_apply, ← hπ (ℓ + 1), ← hdeg, hmon.coeff_natDegree]
+      exact (map_one (iota (K := K) ℓ)).symm
+  · rw [Polynomial.eval₂_eq_eval_map]
+    apply iota_injective (K := K) ℓ
+    rw [map_zero]
+    change (iota ℓ) (Polynomial.eval₂ (RingHom.id _) f
+      ((p.map (algebraMap (Algebra.adjoin ℚ {jq}) (LaurentSeries ℚ))))) = 0
+    rw [Polynomial.hom_eval₂, Polynomial.eval₂_eq_eval_map, ← Polynomial.map_map, Polynomial.map_id,
+      hmapmap,
+      iota_eq_slotH_zero ℓ ζ f g, conjK]
+    exact conjPoly_eval _ 0
+
+end Assembly
+
+section Main
+
+variable (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)]
+
+def sigma (ζ : (CyclotomicField ℓ ℚ)ˣ) (hζ : IsPrimitiveRoot (ζ : CyclotomicField ℓ ℚ) ℓ) :
+    CyclotomicField ℓ ℚ →+* ℂ :=
+  letI : Algebra ℚ (CyclotomicField ℓ ℚ) := CyclotomicField.algebra ℓ ℚ
+  haveI : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  haveI := CyclotomicField.isCyclotomicExtension ℓ ℚ
+  ((hζ.embeddingsEquivPrimitiveRoots ℂ (Polynomial.cyclotomic.irreducible_rat hℓ.out.pos)).symm
+    ⟨expRoot ℓ, (mem_primitiveRoots hℓ.out.pos).mpr (isPrimitiveRoot_expRoot ℓ)⟩).toRingHom
+
+lemma sigma_zeta (ζ : (CyclotomicField ℓ ℚ)ˣ) (hζ : IsPrimitiveRoot (ζ : CyclotomicField ℓ ℚ) ℓ) :
+    sigma ℓ ζ hζ (ζ : CyclotomicField ℓ ℚ) = expRoot ℓ := by
+  let : Algebra ℚ (CyclotomicField ℓ ℚ) := CyclotomicField.algebra ℓ ℚ
+  have : NeZero ℓ := ⟨hℓ.out.ne_zero⟩
+  have := CyclotomicField.isCyclotomicExtension ℓ ℚ
+  let e := hζ.embeddingsEquivPrimitiveRoots ℂ (Polynomial.cyclotomic.irreducible_rat hℓ.out.pos)
+  let r : primitiveRoots ℓ ℂ :=
+    ⟨expRoot ℓ, (mem_primitiveRoots hℓ.out.pos).mpr (isPrimitiveRoot_expRoot ℓ)⟩
+  have h := IsPrimitiveRoot.embeddingsEquivPrimitiveRoots_apply_coe hζ ℂ
+    (Polynomial.cyclotomic.irreducible_rat hℓ.out.pos) (e.symm r)
+  rw [Equiv.apply_symm_apply] at h
+  exact h.symm
+
+variable (f g : LaurentSeries ℚ) (F : ℍ → ℂ)
+  (hF : ∀ τ : ℍ, HasSum (fun m : ℤ => ((f.coeff m : ℚ) : ℂ) * 𝕢 1 (τ : ℂ) ^ m) (F τ))
+  (hG : ∀ τ : ℍ, HasSum (fun m : ℤ => ((g.coeff m : ℚ) : ℂ) * 𝕢 ℓ (τ : ℂ) ^ m) (F (ModularGroup.S •
+    τ)))
+  (hinv : ∀ γ ∈ CongruenceSubgroup.Gamma0 ℓ, ∀ τ : ℍ, F (γ • τ) = F τ)
+
+include hF hG hinv in
+theorem mem_modularFunctionField : f ∈ modularFunctionField ℓ := by
+  have : NeZero ((ℓ : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr hℓ.out.ne_zero⟩
+  have hcyc : IsCyclotomicExtension {ℓ} ℚ (CyclotomicField ℓ ℚ) :=
+    CyclotomicField.isCyclotomicExtension (n := ℓ) (K := ℚ)
+  have : FiniteDimensional ℚ (CyclotomicField ℓ ℚ) :=
+    IsCyclotomicExtension.finiteDimensional {ℓ} ℚ (CyclotomicField ℓ ℚ)
+  have : IsGalois ℚ (CyclotomicField ℓ ℚ) :=
+    IsCyclotomicExtension.isGalois (S := {ℓ}) (K := ℚ) (L := CyclotomicField ℓ ℚ)
+  obtain ⟨z, hz⟩ := IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField ℓ ℚ)
+    (Set.mem_singleton ℓ) hℓ.out.ne_zero
+  have hzu : IsUnit z := hz.isUnit hℓ.out.ne_zero
+  have hζ : IsPrimitiveRoot ((hzu.unit : (CyclotomicField ℓ ℚ)ˣ) : CyclotomicField ℓ ℚ) ℓ := by
+    rw [hzu.unit_spec]; exact hz
+  exact mem_modularFunctionField_of_data ℓ hzu.unit hζ (sigma ℓ hzu.unit hζ) (sigma_zeta ℓ hzu.unit
+    hζ)
+    f g F hF hG hinv
+
+include hF hG hinv in
+theorem isIntegral_adjoin_jq : IsIntegral (Algebra.adjoin ℚ {jq}) f := by
+  have : NeZero ((ℓ : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr hℓ.out.ne_zero⟩
+  have hcyc : IsCyclotomicExtension {ℓ} ℚ (CyclotomicField ℓ ℚ) :=
+    CyclotomicField.isCyclotomicExtension (n := ℓ) (K := ℚ)
+  have : FiniteDimensional ℚ (CyclotomicField ℓ ℚ) :=
+    IsCyclotomicExtension.finiteDimensional {ℓ} ℚ (CyclotomicField ℓ ℚ)
+  have : IsGalois ℚ (CyclotomicField ℓ ℚ) :=
+    IsCyclotomicExtension.isGalois (S := {ℓ}) (K := ℚ) (L := CyclotomicField ℓ ℚ)
+  obtain ⟨z, hz⟩ := IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField ℓ ℚ)
+    (Set.mem_singleton ℓ) hℓ.out.ne_zero
+  have hzu : IsUnit z := hz.isUnit hℓ.out.ne_zero
+  have hζ : IsPrimitiveRoot ((hzu.unit : (CyclotomicField ℓ ℚ)ˣ) : CyclotomicField ℓ ℚ) ℓ := by
+    rw [hzu.unit_spec]; exact hz
+  exact isIntegral_of_data ℓ hzu.unit hζ (sigma ℓ hzu.unit hζ) (sigma_zeta ℓ hzu.unit hζ) f g F hF
+    hG hinv
+
+end Main
+
+end QExpN
+end ModularCurve
+end
+
+theorem solution (ℓ : ℕ) [Fact (Nat.Prime ℓ)] (f g : LaurentSeries ℚ) (F : UpperHalfPlane → ℂ) (hF :
+  ∀ τ : UpperHalfPlane, HasSum (fun m : ℤ => ((f.coeff m : ℚ) : ℂ) * Function.Periodic.qParam 1 (τ :
+  ℂ) ^ m) (F τ)) (hG : ∀ τ : UpperHalfPlane, HasSum (fun m : ℤ => ((g.coeff m : ℚ) : ℂ) *
+  Function.Periodic.qParam ℓ (τ : ℂ) ^ m) (F (ModularGroup.S • τ))) (hinv : ∀ γ ∈
+  CongruenceSubgroup.Gamma0 ℓ, ∀ τ : UpperHalfPlane, F (γ • τ) = F τ) :
+    f ∈ ModularCurve.modularFunctionField ℓ :=
+  ModularCurve.QExpN.mem_modularFunctionField ℓ f g F hF hG hinv
+
+end S_ModularCurve_mem_modularFunctionField_of_hasSum_of_gamma0_invariant
+end P2MW
+export P2MW.S_ModularCurve_mem_modularFunctionField_of_hasSum_of_gamma0_invariant (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.mem_modularFunctionField_of_hasSum_of_gamma0_invariant (ℓ : ℕ) [Fact (Nat.Prime
+  ℓ)] (f g : LaurentSeries ℚ) (F : UpperHalfPlane → ℂ) (hF : ∀ τ : UpperHalfPlane, HasSum (fun m : ℤ
+  => ((f.coeff m : ℚ) : ℂ) * Function.Periodic.qParam 1 (τ : ℂ) ^ m) (F τ)) (hG : ∀ τ :
+  UpperHalfPlane, HasSum (fun m : ℤ => ((g.coeff m : ℚ) : ℂ) * Function.Periodic.qParam ℓ (τ : ℂ) ^
+  m) (F (ModularGroup.S • τ))) (hinv : ∀ γ ∈ CongruenceSubgroup.Gamma0 ℓ, ∀ τ : UpperHalfPlane, F (γ
+  • τ) = F τ) :
+    f ∈ ModularCurve.modularFunctionField ℓ :=
+  solution ℓ f g F hF hG hinv
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_mem_range_qExpand_of_qTwist_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_mem_range_qExpand_of_qTwist_eq.lean
new file mode 100644
index 0000000000..dcaf25c75e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_mem_range_qExpand_of_qTwist_eq.lean
@@ -0,0 +1,120 @@
+/-
+Based on Prove2Me node ModularCurve.mem_range_qExpand_of_qTwist_eq
+(7fedb95c-f8b8-58c3-b4bc-f9bacad7fd66) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 02127009-d1a2-5111-a936-4f369b3b759b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Laurent series fixed by q↦ζ q lie in K((qⁿ))
+
+Theorem statement: `ModularCurve.mem_range_qExpand_of_qTwist_eq`
+(`7fedb95c-f8b8-58c3-b4bc-f9bacad7fd66`), by Claude, 2026-09-05.
+
+Proof: submission `02127009-d1a2-5111-a936-4f369b3b759b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, let $n$ be a nonzero natural number, and let $\zeta$ be a unit of $K$ whose
+underlying element is a primitive $n$-th root of unity in $K$ (in the sense of Mathlib's
+`IsPrimitiveRoot`). Let $f$ be a formal Laurent series over $K$, i.e. an element of `LaurentSeries
+K` = `HahnSeries ℤ K`, a function $k\mapsto f.\mathrm{coeff}\,k$ on $\mathbb{Z}$ whose support is
+partially well ordered, hence bounded below. Assume $f$ is fixed by the twist by $\zeta$:
+[`ModularCurve.qTwist ζ`](def/ModularCurve_PhiGen.html#L35) is the ring endomorphism of
+`LaurentSeries K` sending $f$ to the series with $k$-th coefficient $\zeta^{k} f.\mathrm{coeff}\,k$
+(integer powers of the unit $\zeta$), the substitution $q\mapsto\zeta q$, and the hypothesis is
+`qTwist ζ f = f`. The conclusion is that $f$ belongs to the set-theoretic range of the ring
+homomorphism [`ModularCurve.qExpand K n`](def/ModularCurve_X0.html#L25), which is the Hahn-series
+embedding along the order-preserving injective additive map $m\mapsto n\,m$ of $\mathbb{Z}$, i.e.
+the substitution $q\mapsto q^{n}$: thus $f=g(q^{n})$ for some Laurent series $g$ over $K$. Only
+membership in the range is asserted; no preimage is named, and $n$ is not assumed prime.
+
+This is the coefficientwise form of the standard observation that a $q$-expansion invariant under
+$q\mapsto\zeta q$ for a primitive $n$-th root of unity $\zeta$ is a series in $q^{n}$, the algebraic
+mechanism behind passing between expansions at the cusp in the variable $q$ and in $q^{N}$. It is
+used in the treatment of the modular curve $X_0(N)$, for instance in the integrality statements for
+$j(q)$ and $j(q^{N})$ over $\Gamma_0(N)$-invariant expansions, in the relations satisfied by modular
+units, and in the identification of the Fricke involution.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_mem_range_qExpand_of_qTwist_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_mem_range_qExpand_of_qTwist_eq
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qTwist qTwist_coeff qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd"
+p2m_open "ModularCurve"
+
+theorem coeff_eq_zero_of_qTwist_eq {K : Type*} [Field K] (n : ℕ) [NeZero n] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) n) (f : LaurentSeries K) (h : qTwist ζ f = f) {k : ℤ}
+    (hk : ¬ (n : ℤ) ∣ k) : f.coeff k = 0 := by
+  have hc := congrArg (fun g : LaurentSeries K => g.coeff k) h
+  simp only [qTwist_coeff] at hc
+  have hne : ((ζ ^ k : Kˣ) : K) ≠ 1 := by
+    rw [Units.val_zpow_eq_zpow_val]
+    exact fun h1 => hk ((hζ.zpow_eq_one_iff_dvd k).mp h1)
+  have : (((ζ ^ k : Kˣ) : K) - 1) * f.coeff k = 0 := by rw [sub_mul, one_mul, hc, sub_self]
+  rcases mul_eq_zero.mp this with h0 | h0
+  · exact absurd (sub_eq_zero.mp h0) hne
+  · exact h0
+
+theorem mem_range_qExpand_of_qTwist_eq' {K : Type*} [Field K] (n : ℕ) [NeZero n] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) n) (f : LaurentSeries K) (h : qTwist ζ f = f) :
+    f ∈ Set.range (qExpand K n) := by
+  have hn : (0 : ℤ) < n := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne n)
+  have hbdd : BddBelow (Function.support fun m : ℤ => f.coeff ((n : ℤ) * m)) := by
+    refine ⟨min f.order 0, fun m hm => ?_⟩
+    have hm' : f.coeff ((n : ℤ) * m) ≠ 0 := hm
+    have hord : f.order ≤ (n : ℤ) * m := HahnSeries.order_le_of_coeff_ne_zero hm'
+    rcases le_or_gt 0 m with h0 | h0
+    · exact (min_le_right _ _).trans h0
+    · have : (n : ℤ) * m ≤ m := by nlinarith
+      exact (min_le_left _ _).trans (hord.trans this)
+  refine ⟨HahnSeries.ofSuppBddBelow _ hbdd, ?_⟩
+  ext k
+  by_cases hk : (n : ℤ) ∣ k
+  · obtain ⟨m, rfl⟩ := hk
+    rw [qExpand_coeff_mul, HahnSeries.coeff_ofSuppBddBelow]
+  · rw [qExpand_coeff_of_not_dvd n _ hk, coeff_eq_zero_of_qTwist_eq n ζ hζ f h hk]
+
+end ModularCurve
+
+theorem solution {K : Type*} [Field K] (n : ℕ) [NeZero n] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) n)
+    (f : LaurentSeries K) (h : ModularCurve.qTwist ζ f = f) :
+    f ∈ Set.range (ModularCurve.qExpand K n) :=
+  ModularCurve.mem_range_qExpand_of_qTwist_eq' n ζ hζ f h
+
+end S_ModularCurve_mem_range_qExpand_of_qTwist_eq
+end P2MW
+export P2MW.S_ModularCurve_mem_range_qExpand_of_qTwist_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.mem_range_qExpand_of_qTwist_eq {K : Type*} [Field K] (n : ℕ) [NeZero n]
+    (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) n) (f : LaurentSeries K)
+    (h : ModularCurve.qTwist ζ f = f) :
+    f ∈ Set.range (ModularCurve.qExpand K n) :=
+  solution n ζ hζ f h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two.lean
new file mode 100644
index 0000000000..196f29474d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two.lean
@@ -0,0 +1,685 @@
+/-
+Based on Prove2Me node
+ModularCurve.meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two
+(416a532b-c720-58ab-9911-d53629fcd33d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 863ff352-71e6-598d-a5e1-d6ea6e67a454
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+
+import Mathlib.Analysis.Real.Pi.Bounds
+import Mathlib.Analysis.Complex.Liouville
+import Mathlib.NumberTheory.ModularForms.Derivative
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_smul_eq_of_E4_cube_div_discriminant_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order of j-j(τ) equals half the stabiliser order
+
+Theorem statement:
+`ModularCurve.meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two`
+(`416a532b-c720-58ab-9911-d53629fcd33d`), by Claude, 2026-09-05.
+
+Proof: submission `863ff352-71e6-598d-a5e1-d6ea6e67a454`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\tau$ be a point of the upper half-plane $\mathbb{H}$. Consider the function of a complex
+variable $z$ given by $E_4(\mathrm{ofComplex}\,z)^3/\Delta(\mathrm{ofComplex}\,z) -
+E_4(\tau)^3/\Delta(\tau)$, where $E_4$ is the normalised weight-$4$ Eisenstein series
+`ModularForm.E₄` for $\mathrm{SL}_2(\mathbb{Z})$, $\Delta$ is `ModularForm.discriminant`, and
+`ofComplex` is the map $\mathbb{C}\to\mathbb{H}$ which is the identity on the upper half-plane (and
+constant off it); thus near $\tau$ the function is $j(z)-j(\tau)$ for the modular invariant
+$j=E_4^3/\Delta$. The assertion is that the meromorphic order of this function at the point $\tau$,
+viewed in $\mathbb{C}$, equals the integer obtained from the natural number
+$\#\mathrm{Stab}_{\mathrm{SL}_2(\mathbb{Z})}(\tau)/2$, the quotient being natural-number division of
+the cardinality of the stabiliser of $\tau$ for the action of $\mathrm{SL}_2(\mathbb{Z})$ on
+$\mathbb{H}$. Since `meromorphicOrderAt` takes values in $\mathbb{Z}\cup\{\infty\}$, the equality
+with a finite value also records that $j-j(\tau)$ does not vanish identically near $\tau$. As the
+stabiliser contains $\pm 1$ and has order $2$, $4$ or $6$, the right-hand side is $1$, $2$ or $3$,
+namely $1$ away from the elliptic points and $2$, resp. $3$, at points equivalent to $i$, resp. to
+$e^{2\pi i/3}$.
+
+This is the classical computation of the multiplicity with which the modular invariant $j$ attains
+the value $j(\tau)$, the multiplicity being the ramification index $e_\tau$ of
+$\mathbb{H}\to\mathbb{H}/\mathrm{SL}_2(\mathbb{Z})$ at $\tau$. It feeds the identification of
+ramification indices of maps of modular curves, used in the results relating ramification to
+stabiliser orders for $\mathrm{SL}_2(\mathbb{Z})$ and for $\Gamma_1$-level structures.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_4bffc378
+
+noncomputable section
+
+open UpperHalfPlane ModularForm Complex SlashInvariantForm Derivative Filter ModularGroup
+open scoped MatrixGroups Real Topology ModularForm Manifold Derivative Modular
+
+namespace ModularCurve
+p2m_export "ModularCurve" "exists_smul_eq_of_E4_cube_div_discriminant_eq"
+namespace JMultiplicity
+p2m_open "ModularCurve"
+
+local notation "Δ" => ModularForm.discriminant
+
+def jf : ℍ → ℂ := fun τ => (E₄ : ℍ → ℂ) τ ^ 3 / ModularForm.discriminant τ
+
+lemma E₄_smul (γ : SL(2, ℤ)) (τ : ℍ) : E₄ (γ • τ) = denom γ τ ^ (4 : ℤ) * E₄ τ := by
+  have h := slash_action_eqn'' (Γ := 𝒮ℒ) (k := (4 : ℤ)) E₄ (γ := (γ : GL (Fin 2) ℝ)) ⟨γ, rfl⟩ τ
+  simpa [ModularGroup.sl_moeb] using h
+
+lemma Δ_smul (γ : SL(2, ℤ)) (τ : ℍ) :
+    ModularForm.discriminant (γ • τ) = denom γ τ ^ (12 : ℤ) * ModularForm.discriminant τ := by
+  have h := slash_action_eqn'' (Γ := 𝒮ℒ) (k := (12 : ℤ)) CuspForm.discriminant
+    (γ := (γ : GL (Fin 2) ℝ)) ⟨γ, rfl⟩ τ
+  simpa [ModularGroup.sl_moeb, CuspForm.coe_discriminant] using h
+
+lemma jf_smul (γ : SL(2, ℤ)) (τ : ℍ) : jf (γ • τ) = jf τ := by
+  simp only [jf]
+  rw [E₄_smul, Δ_smul]
+  have hd : denom (γ : GL (Fin 2) ℝ) τ ≠ 0 := denom_ne_zero _ _
+  have hΔ := discriminant_ne_zero τ
+  field_simp
+
+lemma mdifferentiable_jf : MDiff jf :=
+  (E₄.holo'.pow 3).div CuspForm.discriminant.holo' discriminant_ne_zero
+
+lemma D_smul {F : ℍ → ℂ} (hF : MDiff F) (hinv : ∀ (γ : SL(2, ℤ)) (τ : ℍ), F (γ • τ) = F τ)
+    (γ : SL(2, ℤ)) (τ : ℍ) : D F (γ • τ) = denom γ τ ^ 2 * D F τ := by
+  have hdet1 : ((γ : GL (Fin 2) ℝ)).val.det = 1 := Matrix.SpecialLinearGroup.det_coe _
+  have hdet : 0 < ((γ : GL (Fin 2) ℝ)).val.det := by rw [hdet1]; exact one_pos
+  have h1 : HasDerivAt (fun z : ℂ => (↑((γ : GL (Fin 2) ℝ) • ofComplex z) : ℂ))
+      (((γ : GL (Fin 2) ℝ)).val.det / denom (γ : GL (Fin 2) ℝ) τ ^ 2) (τ : ℂ) :=
+    (UpperHalfPlane.hasStrictDerivAt_smul hdet τ).hasDerivAt
+  have hdiff : DifferentiableAt ℂ (F ∘ ofComplex) (↑(γ • τ) : ℂ) := by
+    have := (hF (γ • τ))
+    rwa [UpperHalfPlane.mdifferentiableAt_iff] at this
+  have h2 : HasDerivAt (F ∘ ofComplex) (deriv (F ∘ ofComplex) (↑(γ • τ) : ℂ)) (↑(γ • τ) : ℂ) :=
+    hdiff.hasDerivAt
+  have h3 := h2.scomp_of_eq (τ : ℂ) h1 (by simp [ModularGroup.sl_moeb])
+  have h4 : (F ∘ ofComplex) ∘ (fun z : ℂ => (↑((γ : GL (Fin 2) ℝ) • ofComplex z) : ℂ))
+      =ᶠ[𝓝 (τ : ℂ)] F ∘ ofComplex := by
+    filter_upwards [isOpen_upperHalfPlaneSet.mem_nhds τ.im_pos] with z hz
+    simp only [Function.comp_apply, ofComplex_apply_of_im_pos hz, UpperHalfPlane.ofComplex_apply]
+    rw [← ModularGroup.sl_moeb, hinv]
+  have h5 : deriv (F ∘ ofComplex) τ =
+      ((((γ : GL (Fin 2) ℝ)).val.det : ℂ) / denom (γ : GL (Fin 2) ℝ) τ ^ 2) •
+        deriv (F ∘ ofComplex) (↑(γ • τ) : ℂ) := (h3.congr_of_eventuallyEq h4.symm).deriv
+  have hd : denom (γ : GL (Fin 2) ℝ) τ ≠ 0 := denom_ne_zero _ _
+  simp only [normalizedDerivOfComplex]
+  rw [ModularGroup.sl_moeb, h5, hdet1]
+  simp only [smul_eq_mul, Complex.ofReal_one]
+  field_simp
+  rfl
+
+lemma mdiff_E₄ : MDiff (E₄ : ℍ → ℂ) := E₄.holo'
+lemma mdiff_E₆ : MDiff (E₆ : ℍ → ℂ) := E₆.holo'
+lemma mdiff_Δ : MDiff (ModularForm.discriminant : ℍ → ℂ) := CuspForm.discriminant.holo'
+
+lemma E₆_smul (γ : SL(2, ℤ)) (τ : ℍ) : E₆ (γ • τ) = denom γ τ ^ (6 : ℤ) * E₆ τ := by
+  have h := slash_action_eqn'' (Γ := 𝒮ℒ) (k := (6 : ℤ)) E₆ (γ := (γ : GL (Fin 2) ℝ)) ⟨γ, rfl⟩ τ
+  simpa [ModularGroup.sl_moeb] using h
+
+lemma S_smul_I : ModularGroup.S • UpperHalfPlane.I = UpperHalfPlane.I :=
+  ModularGroup.stabilizer_I.mpr (by simp)
+
+lemma TinvS_smul_ρ : (ModularGroup.T⁻¹ * ModularGroup.S) • ρ = ρ :=
+  ModularGroup.stabilizer_ρ.mpr (by simp)
+
+lemma E₆_I : E₆ UpperHalfPlane.I = 0 := by
+  have h := E₆_smul ModularGroup.S UpperHalfPlane.I
+  rw [S_smul_I, ModularGroup.denom_S, UpperHalfPlane.coe_I] at h
+  have hI6 : Complex.I ^ (6 : ℤ) = -1 := by
+    rw [show (6 : ℤ) = ((6 : ℕ) : ℤ) from rfl, zpow_natCast]
+    calc Complex.I ^ 6 = (Complex.I ^ 2) ^ 3 := by ring
+      _ = -1 := by rw [Complex.I_sq]; norm_num
+  rw [hI6] at h
+  linear_combination h / 2
+
+lemma denom_TinvS_ρ : denom (↑(ModularGroup.T⁻¹ * ModularGroup.S) : GL (Fin 2) ℝ) ρ = (ρ : ℂ) := by
+  rw [ModularGroup.denom_apply]
+  have h10 : (ModularGroup.T⁻¹ * ModularGroup.S) 1 0 = 1 := by
+    rw [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_T_inv, ModularGroup.coe_S]
+    simp
+  have h11 : (ModularGroup.T⁻¹ * ModularGroup.S) 1 1 = 0 := by
+    rw [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_T_inv, ModularGroup.coe_S]
+    simp
+  rw [h10, h11]
+  simp
+
+lemma ρ_ne_one : (ρ : ℂ) ≠ 1 := by
+  intro h
+  have := congrArg Complex.im h
+  rw [UpperHalfPlane.coe_im] at this
+  simp only [one_im] at this
+  exact ρ.im_pos.ne' this
+
+lemma E₄_ρ : E₄ ρ = 0 := by
+  have h := E₄_smul (ModularGroup.T⁻¹ * ModularGroup.S) ρ
+  rw [TinvS_smul_ρ, denom_TinvS_ρ] at h
+  have hρ4 : (ρ : ℂ) ^ (4 : ℤ) = (ρ : ℂ) := by
+    rw [show (4 : ℤ) = ((4 : ℕ) : ℤ) from rfl, zpow_natCast]
+    linear_combination ((ρ : ℂ) ^ 2 - ρ) * ρ_sq
+  rw [hρ4] at h
+  have : ((ρ : ℂ) - 1) * E₄ ρ = 0 := by linear_combination -h
+  rcases mul_eq_zero.mp this with h1 | h1
+  · exact absurd (sub_eq_zero.mp h1) ρ_ne_one
+  · exact h1
+
+lemma E₄_I_ne_zero : E₄ UpperHalfPlane.I ≠ 0 := by
+  intro h
+  have hΔ := discriminant_ne_zero UpperHalfPlane.I
+  rw [discriminant_eq_E₄_cube_sub_E₆_sq, h, E₆_I] at hΔ
+  norm_num at hΔ
+
+lemma E₆_ρ_ne_zero : E₆ ρ ≠ 0 := by
+  intro h
+  have hΔ := discriminant_ne_zero ρ
+  rw [discriminant_eq_E₄_cube_sub_E₆_sq, h, E₄_ρ] at hΔ
+  norm_num at hΔ
+
+lemma jf_ρ : jf ρ = 0 := by simp [jf, E₄_ρ]
+
+lemma jf_I_ne_zero : jf UpperHalfPlane.I ≠ 0 :=
+  div_ne_zero (pow_ne_zero _ E₄_I_ne_zero) (discriminant_ne_zero _)
+
+lemma E₄_smul_eq_zero_iff (γ : SL(2, ℤ)) (τ : ℍ) : E₄ (γ • τ) = 0 ↔ E₄ τ = 0 := by
+  rw [E₄_smul, mul_eq_zero, or_iff_right]
+  exact zpow_ne_zero _ (denom_ne_zero _ _)
+
+lemma E₆_smul_eq_zero_iff (γ : SL(2, ℤ)) (τ : ℍ) : E₆ (γ • τ) = 0 ↔ E₆ τ = 0 := by
+  rw [E₆_smul, mul_eq_zero, or_iff_right]
+  exact zpow_ne_zero _ (denom_ne_zero _ _)
+
+lemma natCard_stabilizer_I : Nat.card (MulAction.stabilizer SL(2, ℤ) UpperHalfPlane.I) = 4 := by
+  rw [Nat.card_congr (Equiv.subtypeEquivRight
+    (q := fun g => g ∈ ({1, -1, ModularGroup.S, -ModularGroup.S} : Finset SL(2, ℤ)))
+    (fun g => (MulAction.mem_stabilizer_iff).trans ModularGroup.stabilizer_I)),
+    Nat.card_eq_finsetCard]
+  decide
+
+lemma natCard_stabilizer_ρ : Nat.card (MulAction.stabilizer SL(2, ℤ) ρ) = 6 := by
+  rw [Nat.card_congr (Equiv.subtypeEquivRight
+    (q := fun g => g ∈ ({1, -1, ModularGroup.S * ModularGroup.T, -(ModularGroup.S * ModularGroup.T),
+      ModularGroup.T⁻¹ * ModularGroup.S, -(ModularGroup.T⁻¹ * ModularGroup.S)} : Finset SL(2, ℤ)))
+    (fun g => (MulAction.mem_stabilizer_iff).trans ModularGroup.stabilizer_ρ)),
+    Nat.card_eq_finsetCard]
+  decide
+
+lemma natCard_stabilizer_smul (γ : SL(2, ℤ)) (τ : ℍ) :
+    Nat.card (MulAction.stabilizer SL(2, ℤ) (γ • τ)) =
+      Nat.card (MulAction.stabilizer SL(2, ℤ) τ) :=
+  (Nat.card_congr (MulAction.stabilizerEquivStabilizer (rfl : γ • τ = γ • τ)).toEquiv).symm
+
+lemma orbit_trichotomy (τ : ℍ) :
+    (∃ γ : SL(2, ℤ), τ = γ • UpperHalfPlane.I) ∨ (∃ γ : SL(2, ℤ), τ = γ • ρ) ∨
+      (∀ g : SL(2, ℤ), g • τ = τ → g = 1 ∨ g = -1) := by
+  obtain ⟨g₀, hg₀⟩ := ModularGroup.exists_smul_mem_fd τ
+  by_cases hI : g₀ • τ = UpperHalfPlane.I
+  · exact Or.inl ⟨g₀⁻¹, by rw [← hI, inv_smul_smul]⟩
+  by_cases hρ : g₀ • τ = ρ
+  · exact Or.inr (Or.inl ⟨g₀⁻¹, by rw [← hρ, inv_smul_smul]⟩)
+  by_cases hρ' : g₀ • τ = (1 : ℝ) +ᵥ ρ
+  · refine Or.inr (Or.inl ⟨g₀⁻¹ * ModularGroup.T, ?_⟩)
+    rw [mul_smul, UpperHalfPlane.modular_T_smul, ← hρ', inv_smul_smul]
+  refine Or.inr (Or.inr fun g hg => ?_)
+  have h : (g₀ * g * g₀⁻¹) • (g₀ • τ) = g₀ • τ := by
+    rw [mul_smul, mul_smul, inv_smul_smul, hg]
+  rcases ModularGroup.stabilizer_of_ne hg₀ h hI hρ hρ' with h1 | h1
+  · left
+    have := congrArg (fun x => g₀⁻¹ * x * g₀) h1
+    simpa [mul_assoc] using this
+  · right
+    have := congrArg (fun x => g₀⁻¹ * x * g₀) h1
+    simpa [mul_assoc] using this
+
+lemma natCard_stabilizer_eq_two {τ : ℍ} (h : ∀ g : SL(2, ℤ), g • τ = τ → g = 1 ∨ g = -1) :
+    Nat.card (MulAction.stabilizer SL(2, ℤ) τ) = 2 := by
+  have hiff : ∀ g : SL(2, ℤ), g ∈ MulAction.stabilizer SL(2, ℤ) τ ↔
+      g ∈ ({1, -1} : Finset SL(2, ℤ)) := by
+    intro g
+    rw [MulAction.mem_stabilizer_iff, Finset.mem_insert, Finset.mem_singleton]
+    refine ⟨h g, ?_⟩
+    rintro (rfl | rfl)
+    · exact one_smul _ _
+    · rw [ModularGroup.SL_neg_smul, one_smul]
+  rw [Nat.card_congr (Equiv.subtypeEquivRight
+    (q := fun g => g ∈ ({1, -1} : Finset SL(2, ℤ))) hiff), Nat.card_eq_finsetCard]
+  decide
+
+lemma norm_deriv_le {G : ℍ → ℂ} (hG : MDiff G) {M A : ℝ}
+    (hM : ∀ z : ℍ, A ≤ z.im → ‖G z‖ ≤ M) (z : ℍ) (hz : max A 0 + 1 < z.im) :
+    ‖deriv (G ∘ ofComplex) z‖ ≤ M := by
+  have him : ∀ w : ℂ, dist w (z : ℂ) ≤ 1 → z.im - 1 ≤ w.im := by
+    intro w hw
+    have h1 : |(w - z).im| ≤ ‖w - (z : ℂ)‖ := Complex.abs_im_le_norm _
+    rw [dist_eq_norm] at hw
+    rw [Complex.sub_im, UpperHalfPlane.coe_im] at h1
+    have := (abs_le.mp (h1.trans hw)).1
+    linarith
+  have hsub : Metric.closedBall (z : ℂ) 1 ⊆ {w : ℂ | 0 < w.im} := by
+    intro w hw
+    have := him w (Metric.mem_closedBall.mp hw)
+    simp only [Set.mem_ofPred_eq]
+    have : (0 : ℝ) ≤ max A 0 := le_max_right _ _
+    linarith
+  have hd : DiffContOnCl ℂ (G ∘ ofComplex) (Metric.ball (z : ℂ) 1) :=
+    (UpperHalfPlane.mdifferentiable_iff.mp hG).diffContOnCl_ball hsub
+  have hC : ∀ w ∈ Metric.sphere (z : ℂ) 1, ‖(G ∘ ofComplex) w‖ ≤ M := by
+    intro w hw
+    have h1 := him w (Metric.mem_sphere.mp hw).le
+    have hw0 : 0 < w.im := by
+      have : (0 : ℝ) ≤ max A 0 := le_max_right _ _
+      linarith
+    rw [Function.comp_apply, ofComplex_apply_of_im_pos hw0]
+    apply hM
+    change A ≤ w.im
+    have : A ≤ max A 0 := le_max_left _ _
+    linarith
+  simpa using Complex.norm_deriv_le_of_forall_mem_sphere_norm_le one_pos hd hC
+
+lemma norm_D_le_norm_deriv (G : ℍ → ℂ) (z : ℍ) : ‖D G z‖ ≤ ‖deriv (G ∘ ofComplex) z‖ := by
+  rw [normalizedDerivOfComplex, norm_mul]
+  refine mul_le_of_le_one_left (norm_nonneg _) ?_
+  rw [norm_inv]
+  refine inv_le_one_of_one_le₀ ?_
+  simp only [norm_mul, Complex.norm_ofNat, Complex.norm_real, Real.norm_eq_abs,
+    abs_of_pos Real.pi_pos, Complex.norm_I, mul_one]
+  nlinarith [Real.pi_gt_three]
+
+lemma isBoundedAtImInfty_D {G : ℍ → ℂ} (hG : MDiff G) (hb : IsBoundedAtImInfty G) :
+    IsBoundedAtImInfty (D G) := by
+  rw [isBoundedAtImInfty_iff] at hb ⊢
+  obtain ⟨M, A, hM⟩ := hb
+  refine ⟨M, max A 0 + 2, fun z hz => (norm_D_le_norm_deriv G z).trans ?_⟩
+  exact norm_deriv_le hG hM z (by linarith)
+
+lemma isZeroAtImInfty_D {G : ℍ → ℂ} (hG : MDiff G) (hb : IsZeroAtImInfty G) :
+    IsZeroAtImInfty (D G) := by
+  rw [isZeroAtImInfty_iff] at hb ⊢
+  intro ε hε
+  obtain ⟨A, hA⟩ := hb ε hε
+  refine ⟨max A 0 + 2, fun z hz => (norm_D_le_norm_deriv G z).trans ?_⟩
+  exact norm_deriv_le hG hA z (by linarith)
+
+lemma D_jf_mul_Δ_sq :
+    (fun z => D jf z * Δ z ^ 2) = D ((E₄ : ℍ → ℂ) ^ 3) * Δ - (E₄ : ℍ → ℂ) ^ 3 * D Δ := by
+  have hprod : jf * Δ = (E₄ : ℍ → ℂ) ^ 3 := by
+    funext z
+    simp only [jf, Pi.mul_apply, Pi.pow_apply]
+    exact div_mul_cancel₀ _ (discriminant_ne_zero z)
+  have hD := normalizedDerivOfComplex_mul jf Δ mdifferentiable_jf CuspForm.discriminant.holo'
+  rw [hprod] at hD
+  funext z
+  have := congr_fun hD z
+  simp only [Pi.add_apply, Pi.mul_apply, Pi.sub_apply, Pi.pow_apply] at this ⊢
+  rw [this]
+  simp only [jf]
+  field_simp [discriminant_ne_zero z]
+  ring
+
+lemma isZeroAtImInfty_D_jf_mul_Δ_sq : IsZeroAtImInfty (fun z => D jf z * Δ z ^ 2) := by
+  rw [D_jf_mul_Δ_sq]
+  have hE : MDiff ((E₄ : ℍ → ℂ) ^ 3) := E₄.holo'.pow 3
+  have hEb : IsBoundedAtImInfty ((E₄ : ℍ → ℂ) ^ 3) := by
+    have h := ModularFormClass.bdd_at_infty E₄
+    have h__af := (h.mul h).mul h
+    simp only [pow_succ, pow_zero, one_mul] at h__af ⊢
+    exact h__af
+  have hΔz : IsZeroAtImInfty Δ := CuspFormClass.zero_at_infty CuspForm.discriminant
+  have h1 : IsZeroAtImInfty (D ((E₄ : ℍ → ℂ) ^ 3) * Δ) :=
+    (isBoundedAtImInfty_D hE hEb).mul_zeroAtFilter hΔz
+  have h2 : IsZeroAtImInfty ((E₄ : ℍ → ℂ) ^ 3 * D Δ) :=
+    hEb.mul_zeroAtFilter (isZeroAtImInfty_D CuspForm.discriminant.holo' hΔz)
+  have h__af := (ZeroAtFilter.add h1 h2.neg : IsZeroAtImInfty _)
+  simp only at h__af
+  exact h__af
+
+lemma D_jf_mul_Δ_sq_slash (γ : SL(2, ℤ)) :
+    (fun z => D jf z * Δ z ^ 2) ∣[(26 : ℤ)] γ = fun z => D jf z * Δ z ^ 2 := by
+  funext z
+  rw [SL_slash_apply, D_smul mdifferentiable_jf jf_smul, Δ_smul]
+  have hd : denom (γ : GL (Fin 2) ℝ) z ≠ 0 := denom_ne_zero _ _
+  rw [zpow_neg, zpow_ofNat, zpow_ofNat]
+  field_simp
+
+def h26 : CuspForm 𝒮ℒ 26 where
+  toFun z := D jf z * Δ z ^ 2
+  slash_action_eq' A hA := by
+    obtain ⟨γ, rfl⟩ := hA
+    exact D_jf_mul_Δ_sq_slash γ
+  holo' := (normalizedDerivOfComplex_mdifferentiable mdifferentiable_jf).mul
+    (CuspForm.discriminant.holo'.pow 2)
+  zero_at_cusps' hc := by
+    rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z] at hc
+    rw [OnePoint.isZeroAt_iff_forall_SL2Z hc]
+    intro γ _
+    change IsZeroAtImInfty ((fun z => D jf z * Δ z ^ 2) ∣[(26 : ℤ)] γ)
+    rw [D_jf_mul_Δ_sq_slash γ]
+    exact isZeroAtImInfty_D_jf_mul_Δ_sq
+
+lemma h26_apply (z : ℍ) : h26 z = D jf z * Δ z ^ 2 := rfl
+
+def g14 : ModularForm 𝒮ℒ ((14 : ℕ) : ℤ) :=
+  (CuspForm.discriminantEquiv h26).mcast (by norm_num)
+
+lemma g14_apply (z : ℍ) : g14 z = D jf z * Δ z := by
+  change (CuspForm.discriminantEquiv h26) z = _
+  rw [CuspForm.discriminantEquiv_apply, h26_apply, pow_two, ← mul_assoc,
+    mul_div_cancel_right₀ _ (discriminant_ne_zero z)]
+
+def e14 : ModularForm 𝒮ℒ ((14 : ℕ) : ℤ) := ((E₄.mul E₄).mul E₆).mcast (by norm_num)
+
+lemma e14_apply (z : ℍ) : e14 z = E₄ z ^ 2 * E₆ z := by
+  change (E₄ z * E₄ z) * E₆ z = _
+  rw [pow_two]
+
+lemma finrank_fourteen : Module.finrank ℂ (ModularForm 𝒮ℒ ((14 : ℕ) : ℤ)) = 1 := by
+  have h := ModularForm.dimension_level_one 14 (by decide)
+  norm_num [Nat.ModEq] at h
+  exact Module.finrank_eq_of_rank_eq h
+
+lemma isOpen_uhp : IsOpen {w : ℂ | 0 < w.im} := isOpen_upperHalfPlaneSet
+
+lemma isPreconnected_uhp : IsPreconnected {w : ℂ | 0 < w.im} :=
+  (convex_halfSpace_im_gt 0).isPreconnected
+
+lemma differentiableOn_comp {G : ℍ → ℂ} (hG : MDiff G) :
+    DifferentiableOn ℂ (G ∘ ofComplex) {w : ℂ | 0 < w.im} :=
+  UpperHalfPlane.mdifferentiable_iff.mp hG
+
+lemma analyticOnNhd_comp {G : ℍ → ℂ} (hG : MDiff G) :
+    AnalyticOnNhd ℂ (G ∘ ofComplex) {w : ℂ | 0 < w.im} :=
+  (differentiableOn_comp hG).analyticOnNhd isOpen_uhp
+
+lemma analyticAt_comp {G : ℍ → ℂ} (hG : MDiff G) (τ : ℍ) :
+    AnalyticAt ℂ (G ∘ ofComplex) (τ : ℂ) :=
+  analyticOnNhd_comp hG (τ : ℂ) τ.im_pos
+
+@[scoped simp] lemma comp_apply_coe (G : ℍ → ℂ) (τ : ℍ) : (G ∘ ofComplex) (τ : ℂ) = G τ := by
+  simp [Function.comp_apply, ofComplex_apply]
+
+lemma analyticOrderAt_ne_top {G : ℍ → ℂ} (hG : MDiff G) {z₀ : ℍ} (h0 : G z₀ ≠ 0) (τ : ℍ) :
+    analyticOrderAt (G ∘ ofComplex) (τ : ℂ) ≠ ⊤ := by
+  refine (analyticOnNhd_comp hG).analyticOrderAt_ne_top_of_isPreconnected isPreconnected_uhp
+    z₀.im_pos τ.im_pos ?_
+  rw [(analyticAt_comp hG z₀).analyticOrderAt_eq_zero.mpr (by simpa using h0)]
+  exact ENat.zero_ne_top
+
+lemma analyticOrderAt_eq_zero_of_ne_zero {G : ℍ → ℂ} (hG : MDiff G) {τ : ℍ} (h0 : G τ ≠ 0) :
+    analyticOrderAt (G ∘ ofComplex) (τ : ℂ) = 0 :=
+  (analyticAt_comp hG τ).analyticOrderAt_eq_zero.mpr (by simpa using h0)
+
+lemma deriv_jf_eq (w : ℂ) (hw : 0 < w.im) :
+    deriv (jf ∘ ofComplex) w = (2 * π * Complex.I) * D jf (ofComplex w) := by
+  rw [normalizedDerivOfComplex, ofComplex_apply_of_im_pos hw, UpperHalfPlane.coe_mk, ← mul_assoc,
+    mul_inv_cancel₀ (by simp [Real.pi_ne_zero, Complex.I_ne_zero]), one_mul]
+
+lemma g14_ne_zero : g14 ≠ 0 := by
+  intro h
+  have hD : ∀ z : ℍ, D jf z = 0 := fun z => by
+    have hz : g14 z = 0 := by rw [h]; rfl
+    rw [g14_apply] at hz
+    exact (mul_eq_zero.mp hz).resolve_right (discriminant_ne_zero z)
+  have hderiv : Set.EqOn (deriv (jf ∘ ofComplex)) 0 {w : ℂ | 0 < w.im} := fun w hw => by
+    rw [deriv_jf_eq w hw, hD, mul_zero, Pi.zero_apply]
+  have := isOpen_uhp.is_const_of_deriv_eq_zero isPreconnected_uhp
+    (differentiableOn_comp mdifferentiable_jf) hderiv ρ.im_pos UpperHalfPlane.I.im_pos
+  rw [comp_apply_coe, comp_apply_coe, jf_ρ] at this
+  exact jf_I_ne_zero this.symm
+
+lemma e14_ne_zero : e14 ≠ 0 := by
+  intro h
+  have hfun : ((E₄ : ℍ → ℂ) * (E₄ : ℍ → ℂ)) * (E₆ : ℍ → ℂ) = 0 := by
+    funext z
+    have hz : e14 z = 0 := by rw [h]; rfl
+    rw [e14_apply] at hz
+    simpa [pow_two] using hz
+  have hE4 : MDiff (E₄ : ℍ → ℂ) := E₄.holo'
+  have hE6 : MDiff (E₆ : ℍ → ℂ) := E₆.holo'
+  rw [UpperHalfPlane.mul_eq_zero_iff (hE4.mul hE4) hE6,
+    UpperHalfPlane.mul_eq_zero_iff hE4 hE4, or_self] at hfun
+  rcases hfun with h4 | h6
+  · exact E₄_I_ne_zero (by rw [h4]; rfl)
+  · exact E₆_ρ_ne_zero (by rw [h6]; rfl)
+
+lemma exists_D_jf_mul_Δ_eq :
+    ∃ c : ℂ, c ≠ 0 ∧ ∀ z : ℍ, D jf z * Δ z = c * (E₄ z ^ 2 * E₆ z) := by
+  obtain ⟨c, hc⟩ := (finrank_eq_one_iff_of_nonzero' e14 e14_ne_zero).mp finrank_fourteen g14
+  have hpt : ∀ z : ℍ, D jf z * Δ z = c * (E₄ z ^ 2 * E₆ z) := fun z => by
+    rw [← g14_apply, ← e14_apply, ← hc]
+    rfl
+  refine ⟨c, ?_, hpt⟩
+  rintro rfl
+  rw [zero_smul] at hc
+  exact g14_ne_zero hc.symm
+
+lemma deriv_jf_eventuallyEq {c : ℂ} (hc : ∀ z : ℍ, D jf z * Δ z = c * (E₄ z ^ 2 * E₆ z))
+    (τ : ℍ) :
+    deriv (jf ∘ ofComplex) =ᶠ[𝓝 (τ : ℂ)]
+      (fun _ => 2 * π * Complex.I * c) * ((E₄ : ℍ → ℂ) ∘ ofComplex) ^ 2 *
+        ((E₆ : ℍ → ℂ) ∘ ofComplex) * fun w => ((Δ ∘ ofComplex) w)⁻¹ := by
+  filter_upwards [isOpen_uhp.mem_nhds τ.im_pos] with w hw
+  rw [deriv_jf_eq w hw]
+  have hΔ := discriminant_ne_zero (ofComplex w)
+  have h := hc (ofComplex w)
+  simp only [Pi.mul_apply, Pi.pow_apply, Function.comp_apply]
+  rw [eq_div_iff hΔ |>.mpr h |> fun e => (e : D jf (ofComplex w) = _)]
+  field_simp
+
+lemma analyticOrderAt_deriv_jf {c : ℂ} (hc0 : c ≠ 0)
+    (hc : ∀ z : ℍ, D jf z * Δ z = c * (E₄ z ^ 2 * E₆ z)) (τ : ℍ) :
+    analyticOrderAt (deriv (jf ∘ ofComplex)) (τ : ℂ) =
+      2 • analyticOrderAt ((E₄ : ℍ → ℂ) ∘ ofComplex) (τ : ℂ) +
+        analyticOrderAt ((E₆ : ℍ → ℂ) ∘ ofComplex) (τ : ℂ) := by
+  rw [analyticOrderAt_congr (deriv_jf_eventuallyEq hc τ)]
+  have hK : AnalyticAt ℂ (fun _ : ℂ => 2 * π * Complex.I * c) (τ : ℂ) := analyticAt_const
+  have h4 : AnalyticAt ℂ ((E₄ : ℍ → ℂ) ∘ ofComplex) (τ : ℂ) := analyticAt_comp E₄.holo' τ
+  have h6 : AnalyticAt ℂ ((E₆ : ℍ → ℂ) ∘ ofComplex) (τ : ℂ) := analyticAt_comp E₆.holo' τ
+  have hΔa : AnalyticAt ℂ (Δ ∘ ofComplex) (τ : ℂ) := analyticAt_comp CuspForm.discriminant.holo' τ
+  have hΔi : AnalyticAt ℂ (fun w => ((Δ ∘ ofComplex) w)⁻¹) (τ : ℂ) :=
+    hΔa.inv (by simpa using discriminant_ne_zero τ)
+  rw [analyticOrderAt_mul ((hK.mul (h4.pow 2)).mul h6) hΔi,
+    analyticOrderAt_mul (hK.mul (h4.pow 2)) h6, analyticOrderAt_mul hK (h4.pow 2),
+    analyticOrderAt_pow h4,
+    hK.analyticOrderAt_eq_zero.mpr (by simp [Real.pi_ne_zero, Complex.I_ne_zero, hc0]),
+    hΔi.analyticOrderAt_eq_zero.mpr (by simpa using discriminant_ne_zero τ)]
+  simp
+
+lemma E₆_ne_zero_of_E₄_eq_zero {τ : ℍ} (h4 : E₄ τ = 0) : E₆ τ ≠ 0 := by
+  intro h6
+  have hΔ := discriminant_ne_zero τ
+  rw [discriminant_eq_E₄_cube_sub_E₆_sq, h4, h6] at hΔ
+  norm_num at hΔ
+
+lemma jf_eq_of_E₆_eq_zero {τ : ℍ} (h6 : E₆ τ = 0) : jf τ = 1728 := by
+  have hΔ := discriminant_ne_zero τ
+  have hΔ' := discriminant_eq_E₄_cube_sub_E₆_sq τ
+  rw [h6] at hΔ'
+  have h4 : E₄ τ ^ 3 ≠ 0 := by
+    intro h
+    rw [h] at hΔ'
+    norm_num at hΔ'
+    exact hΔ hΔ'
+  simp only [jf]
+  rw [div_eq_iff hΔ, hΔ']
+  ring
+
+lemma order_deriv_add_one (τ : ℍ) :
+    analyticOrderAt (deriv (jf ∘ ofComplex)) (τ : ℂ) + 1 =
+      analyticOrderAt (fun z : ℂ => jf (ofComplex z) - jf τ) (τ : ℂ) := by
+  have h := (analyticAt_comp mdifferentiable_jf τ).analyticOrderAt_deriv_add_one
+  rw [comp_apply_coe] at h
+  exact h
+
+lemma case_E₄_eq_zero {τ : ℍ} (h4 : E₄ τ = 0) :
+    analyticOrderAt (fun z : ℂ => jf (ofComplex z) - jf τ) (τ : ℂ) = (3 : ℕ) ∧
+      Nat.card (MulAction.stabilizer SL(2, ℤ) τ) = 6 := by
+  obtain ⟨c, hc0, hc⟩ := exists_D_jf_mul_Δ_eq
+  have h6 : E₆ τ ≠ 0 := E₆_ne_zero_of_E₄_eq_zero h4
+  have hjτ : jf τ = 0 := by simp [jf, h4]
+  obtain ⟨k, hk⟩ := ENat.ne_top_iff_exists.mp (analyticOrderAt_ne_top mdiff_E₄ E₄_I_ne_zero τ)
+  have hderiv := analyticOrderAt_deriv_jf hc0 hc τ
+  rw [analyticOrderAt_eq_zero_of_ne_zero mdiff_E₆ h6, add_zero, ← hk] at hderiv
+  have hF : (fun z : ℂ => jf (ofComplex z) - jf τ) =
+      ((E₄ : ℍ → ℂ) ∘ ofComplex) ^ 3 * fun w => ((Δ ∘ ofComplex) w)⁻¹ := by
+    funext z
+    rw [hjτ, sub_zero]
+    simp only [jf, Pi.mul_apply, Pi.pow_apply, Function.comp_apply, div_eq_mul_inv]
+  have hE4a : AnalyticAt ℂ ((E₄ : ℍ → ℂ) ∘ ofComplex) (τ : ℂ) := analyticAt_comp mdiff_E₄ τ
+  have hΔi : AnalyticAt ℂ (fun w => ((Δ ∘ ofComplex) w)⁻¹) (τ : ℂ) :=
+    (analyticAt_comp mdiff_Δ τ).inv (by simpa using discriminant_ne_zero τ)
+  have hordF : analyticOrderAt (fun z : ℂ => jf (ofComplex z) - jf τ) (τ : ℂ) = 3 • (k : ℕ∞) := by
+    rw [hF, analyticOrderAt_mul (hE4a.pow 3) hΔi, analyticOrderAt_pow hE4a, ← hk,
+      hΔi.analyticOrderAt_eq_zero.mpr (by simpa using discriminant_ne_zero τ), add_zero]
+  have hrel := order_deriv_add_one τ
+  rw [hderiv, hordF] at hrel
+  have hk1 : k = 1 := by
+    simp only [nsmul_eq_mul] at hrel
+    have : ((2 * k + 1 : ℕ) : ℕ∞) = ((3 * k : ℕ) : ℕ∞) := by push_cast; exact_mod_cast hrel
+    have := ENat.natCast_inj.mp this
+    omega
+  refine ⟨?_, ?_⟩
+  · rw [hordF, hk1]; rfl
+  · obtain ⟨γ, hγ⟩ := ModularCurve.exists_smul_eq_of_E4_cube_div_discriminant_eq ρ τ
+      (show jf ρ = jf τ by rw [jf_ρ, hjτ])
+    rw [← hγ, natCard_stabilizer_smul, natCard_stabilizer_ρ]
+
+lemma case_E₆_eq_zero {τ : ℍ} (h6 : E₆ τ = 0) :
+    analyticOrderAt (fun z : ℂ => jf (ofComplex z) - jf τ) (τ : ℂ) = (2 : ℕ) ∧
+      Nat.card (MulAction.stabilizer SL(2, ℤ) τ) = 4 := by
+  obtain ⟨c, hc0, hc⟩ := exists_D_jf_mul_Δ_eq
+  have h4 : E₄ τ ≠ 0 := fun h4 => E₆_ne_zero_of_E₄_eq_zero h4 h6
+  have hjτ : jf τ = 1728 := jf_eq_of_E₆_eq_zero h6
+  obtain ⟨k, hk⟩ := ENat.ne_top_iff_exists.mp (analyticOrderAt_ne_top mdiff_E₆ E₆_ρ_ne_zero τ)
+  have hderiv := analyticOrderAt_deriv_jf hc0 hc τ
+  rw [analyticOrderAt_eq_zero_of_ne_zero mdiff_E₄ h4, smul_zero, zero_add, ← hk] at hderiv
+  have hF : (fun z : ℂ => jf (ofComplex z) - jf τ) =
+      ((E₆ : ℍ → ℂ) ∘ ofComplex) ^ 2 * fun w => ((Δ ∘ ofComplex) w)⁻¹ := by
+    funext z
+    have hΔ := discriminant_ne_zero (ofComplex z)
+    have hΔ' := discriminant_eq_E₄_cube_sub_E₆_sq (ofComplex z)
+    rw [hjτ]
+    simp only [jf, Pi.mul_apply, Pi.pow_apply, Function.comp_apply]
+    rw [div_sub' hΔ, div_eq_mul_inv]
+    congr 1
+    rw [hΔ']
+    ring
+  have hE6a : AnalyticAt ℂ ((E₆ : ℍ → ℂ) ∘ ofComplex) (τ : ℂ) := analyticAt_comp mdiff_E₆ τ
+  have hΔi : AnalyticAt ℂ (fun w => ((Δ ∘ ofComplex) w)⁻¹) (τ : ℂ) :=
+    (analyticAt_comp mdiff_Δ τ).inv (by simpa using discriminant_ne_zero τ)
+  have hordF : analyticOrderAt (fun z : ℂ => jf (ofComplex z) - jf τ) (τ : ℂ) = 2 • (k : ℕ∞) := by
+    rw [hF, analyticOrderAt_mul (hE6a.pow 2) hΔi, analyticOrderAt_pow hE6a, ← hk,
+      hΔi.analyticOrderAt_eq_zero.mpr (by simpa using discriminant_ne_zero τ), add_zero]
+  have hrel := order_deriv_add_one τ
+  rw [hderiv, hordF] at hrel
+  have hk1 : k = 1 := by
+    simp only [nsmul_eq_mul] at hrel
+    have : ((k + 1 : ℕ) : ℕ∞) = ((2 * k : ℕ) : ℕ∞) := by push_cast; exact_mod_cast hrel
+    have := ENat.natCast_inj.mp this
+    omega
+  refine ⟨?_, ?_⟩
+  · rw [hordF, hk1]; rfl
+  · have hjI : jf UpperHalfPlane.I = 1728 := jf_eq_of_E₆_eq_zero E₆_I
+    obtain ⟨γ, hγ⟩ := ModularCurve.exists_smul_eq_of_E4_cube_div_discriminant_eq
+      UpperHalfPlane.I τ (show jf UpperHalfPlane.I = jf τ by rw [hjI, hjτ])
+    rw [← hγ, natCard_stabilizer_smul, natCard_stabilizer_I]
+
+lemma case_generic {τ : ℍ} (h4 : E₄ τ ≠ 0) (h6 : E₆ τ ≠ 0) :
+    analyticOrderAt (fun z : ℂ => jf (ofComplex z) - jf τ) (τ : ℂ) = (1 : ℕ) ∧
+      Nat.card (MulAction.stabilizer SL(2, ℤ) τ) = 2 := by
+  obtain ⟨c, hc0, hc⟩ := exists_D_jf_mul_Δ_eq
+  have hD : D jf τ ≠ 0 := by
+    intro h
+    have := hc τ
+    rw [h, zero_mul] at this
+    exact mul_ne_zero hc0 (mul_ne_zero (pow_ne_zero _ h4) h6) this.symm
+  have hd : deriv (jf ∘ ofComplex) (τ : ℂ) ≠ 0 := by
+    rw [deriv_jf_eq _ τ.im_pos, ofComplex_apply]
+    exact mul_ne_zero (by simp [Real.pi_ne_zero, Complex.I_ne_zero]) hD
+  refine ⟨?_, ?_⟩
+  · have h := (analyticAt_comp mdifferentiable_jf τ).analyticOrderAt_sub_eq_one_of_deriv_ne_zero hd
+    rw [comp_apply_coe] at h
+    exact h
+  · rcases orbit_trichotomy τ with ⟨γ, rfl⟩ | ⟨γ, rfl⟩ | h
+    · exact absurd ((E₆_smul_eq_zero_iff γ _).mpr E₆_I) h6
+    · exact absurd ((E₄_smul_eq_zero_iff γ _).mpr E₄_ρ) h4
+    · exact natCard_stabilizer_eq_two h
+
+lemma order_and_card (τ : ℍ) : ∃ m : ℕ,
+    analyticOrderAt (fun z : ℂ => jf (ofComplex z) - jf τ) (τ : ℂ) = m ∧
+      Nat.card (MulAction.stabilizer SL(2, ℤ) τ) = 2 * m := by
+  by_cases h4 : E₄ τ = 0
+  · exact ⟨3, case_E₄_eq_zero h4⟩
+  by_cases h6 : E₆ τ = 0
+  · exact ⟨2, case_E₆_eq_zero h6⟩
+  · exact ⟨1, case_generic h4 h6⟩
+
+theorem main (τ : ℍ) :
+    meromorphicOrderAt
+        (fun z : ℂ => (ModularForm.E₄ : ℍ → ℂ) (ofComplex z) ^ 3 /
+            ModularForm.discriminant (ofComplex z)
+          - (ModularForm.E₄ : ℍ → ℂ) τ ^ 3 / ModularForm.discriminant τ) (τ : ℂ) =
+      ((Nat.card (MulAction.stabilizer SL(2, ℤ) τ) / 2 : ℕ) : ℤ) := by
+  obtain ⟨m, hm, hcard⟩ := order_and_card τ
+  have hF : AnalyticAt ℂ (fun z : ℂ => jf (ofComplex z) - jf τ) (τ : ℂ) :=
+    (analyticAt_comp mdifferentiable_jf τ).sub analyticAt_const
+  change meromorphicOrderAt (fun z : ℂ => jf (ofComplex z) - jf τ) (τ : ℂ) = _
+  rw [hF.meromorphicOrderAt_eq, hm, hcard, Nat.mul_div_cancel_left _ two_pos]
+  rfl
+
+end ModularCurve.JMultiplicity
+end
+
+open UpperHalfPlane
+open scoped MatrixGroups
+
+theorem solution
+    (τ : ℍ) :
+    meromorphicOrderAt
+        (fun z : ℂ => (ModularForm.E₄ : ℍ → ℂ) (ofComplex z) ^ 3 /
+            ModularForm.discriminant (ofComplex z)
+          - (ModularForm.E₄ : ℍ → ℂ) τ ^ 3 / ModularForm.discriminant τ) (τ : ℂ) =
+      ((Nat.card (MulAction.stabilizer SL(2, ℤ) τ) / 2 : ℕ) : ℤ) :=
+  ModularCurve.JMultiplicity.main τ
+
+end S_OVERLONG_4bffc378
+end P2MW
+export
+  P2MW.S_OVERLONG_4bffc378
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane
+open scoped MatrixGroups
+theorem ModularCurve.meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two
+    (τ : ℍ) :
+    meromorphicOrderAt
+        (fun z : ℂ => (ModularForm.E₄ : ℍ → ℂ) (ofComplex z) ^ 3 /
+            ModularForm.discriminant (ofComplex z)
+          - (ModularForm.E₄ : ℍ → ℂ) τ ^ 3 / ModularForm.discriminant τ) (τ : ℂ) =
+      ((Nat.card (MulAction.stabilizer SL(2, ℤ) τ) / 2 : ℕ) : ℤ) :=
+  solution τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_minpoly_jqNModC_map_eq_prod_slots.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_minpoly_jqNModC_map_eq_prod_slots.lean
new file mode 100644
index 0000000000..696584724b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_minpoly_jqNModC_map_eq_prod_slots.lean
@@ -0,0 +1,1977 @@
+/-
+Based on Prove2Me node ModularCurve.minpoly_jqNModC_map_eq_prod_slots
+(096413d5-93d6-586a-94ca-a4f3a22399a5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4390b8ec-38c1-5d3d-a539-d1016edf8ff1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_neg_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_order_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_mul_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_of_mul_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot_of_isPrimitiveRoot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime_pow
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_mul_of_coprime
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.NumberTheory.Cyclotomic.PrimitiveRoots
+import Mathlib.FieldTheory.Extension
+import Mathlib.Data.Nat.Factorization.Induction
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Minimal polynomial of j(q^M) over K(j) as a slot product
+
+Theorem statement: `ModularCurve.minpoly_jqNModC_map_eq_prod_slots`
+(`096413d5-93d6-586a-94ca-a4f3a22399a5`), by Claude, 2026-09-05.
+
+Proof: submission `4390b8ec-38c1-5d3d-a539-d1016edf8ff1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, let $M$ be a nonzero natural number and let $\zeta$ be a unit of $K$ whose
+underlying element is a primitive $M$-th root of unity. Write $j =$ `jqModC K` for the Laurent
+series $q^{-1}\cdot(E_4^3\eta^{-24})$ over $K$ (the coefficients of `jNum` read in $K$), and for $d
+\ne 0$ write $j(q^d) =$ `jqNModC K d`, the image of $j$ under the exponent-scaling ring homomorphism
+`qExpand K d` ($q \mapsto q^d$). Assume that for every nonzero divisor $d$ of $M$ two things hold:
+the degree of $K(j)\bigl(j(q^d)\bigr)$ over the intermediate field $K(j)$ generated by $j$ equals
+$\psi(d) = \sum_{e \mid d,\ e \text{ squarefree}} d/e$, and the intermediate field $K\bigl(j,
+j(q^d)\bigr)$ coincides with the field generated over $K$ by all $j(q^{d'})$ with $d'$ a nonzero
+divisor of $d$. Then the minimal polynomial of $j(q^M)$ over $K(j)$, with its coefficients mapped
+into $K((q))$ and then pushed forward by `qExpand K M`, equals $$\prod_{a \mid M}\
+\prod_{\substack{0 \le b < M/a \\ \gcd(\gcd(a,b), M/a) = 1}} \Bigl(X - C\bigl(\mathrm{qExpand}\ K\
+(a\cdot a)\bigl(\mathrm{qTwist}(\zeta^{ba})\, j\bigr)\bigr)\Bigr),$$ where `qTwist u` multiplies the
+coefficient of $q^k$ by $u^k$, so that the slot value is $j(\zeta^{ab}t^{a^2})$ in the variable $t$
+with $q = t^M$; the factor for $a = 0$ is guarded by the constant $0$ and never occurs, as $M \neq
+0$.
+
+This is the classical factorisation of the modular polynomial $\Phi_M(j, Y)$ over $K(j)$ into its
+$\psi(M)$ conjugate $q$-expansion slots indexed by pairs $(a,b)$ with $a \mid M$, $0 \le b < M/a$
+and $\gcd(a,b,M/a) = 1$, here in a purely formal Laurent-series model. It supplies the slot
+decomposition used to count poles of $j$ and cusps on the modular function field, and to produce
+algebra homomorphisms out of that field taking prescribed slot values.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_minpoly_jqNModC_map_eq_prod_slots.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 6400000
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_minpoly_jqNModC_map_eq_prod_slots
+
+noncomputable section
+
+p2m_open "ModularCurve~dedekindPsi_prime \
+  P2MW.S_ModularCurve_minpoly_jqNModC_map_eq_prod_slots.ModularCurve ModularCurve.PhiGen"
+open scoped IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData jqd_mem_full \
+  coeffMap coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one map_jqModC modularFunctionFieldC \
+  coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime"
+
+variable {K : Type*} [Field K]
+
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+theorem jqModC_eq_TS : jqModC K = TS K 1 1 := by
+  rw [TS, qTwist_one_apply, qExpand_one_apply]
+
+theorem jqNModC_eq_TS (d : ℕ) [NeZero d] : jqNModC K d = TS K d 1 := by
+  rw [jqNModC, TS, qTwist_one_apply]
+
+theorem qExpand_jqNModC (A d : ℕ) [NeZero A] [NeZero d] :
+    qExpand K A (jqNModC K d) = TS K (A * d) 1 := by
+  rw [jqNModC_eq_TS, qExpand_TS]
+
+theorem qExpand_jqModC_eq_TS (A : ℕ) [NeZero A] : qExpand K A (jqModC K) = TS K A 1 := by
+  rw [TS, qTwist_one_apply]
+
+theorem qTwist_qExpand_of_pow_eq_one (A : ℕ) [NeZero A] (v : Kˣ) (hv : v ^ A = 1)
+    (x : LaurentSeries K) :
+    qTwist v (qExpand K A x) = qExpand K A x := by
+  rw [qTwist_qExpand]
+  have : v ^ (A : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData jqd_mem_full \
+  coeffMap coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one map_jqModC modularFunctionFieldC \
+  coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime"
+
+section transport
+
+variable {R S : Type*} [CommRing R] [CommRing S]
+
+theorem coeffMap_qTwist (σ : R →+* S) (u : Rˣ) (f : LaurentSeries R) :
+    coeffMap σ (qTwist u f) = qTwist (Units.map σ.toMonoidHom u) (coeffMap σ f) := by
+  ext k
+  simp only [coeffMap_coeff, qTwist_coeff, map_mul]
+  congr 1
+  rw [← map_zpow, Units.coe_map]
+  rfl
+
+end transport
+
+variable {K : Type*} [Field K]
+
+theorem coeffMap_TS {L : Type*} [Field L] (σ : L →+* K) (e : ℕ) [NeZero e] (u : Lˣ) :
+    coeffMap σ (TS L e u) = TS K e (Units.map σ.toMonoidHom u) := by
+  rw [TS, TS, coeffMap_qExpand, coeffMap_qTwist]
+  exact congrArg (fun z => qExpand K e (qTwist (Units.map σ.toMonoidHom u) z)) (map_jqModC σ)
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem units_pow_eq_one_of_isPrimitiveRoot {N : ℕ} {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N) :
+    ζ ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData jqd_mem_full \
+  coeffMap coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one map_jqModC modularFunctionFieldC \
+  coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime"
+
+
+
+
+
+
+theorem phiAtSeed_jqNModC_eval {R : Type*} [CommRing R] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n)
+    (d : ℕ) [NeZero d] : (phiAtSeed data (jqNModC R d)).eval (jqNModC R (d * n)) = 0 := by
+  have h := data.eval_jqNModC_mul_eq_zero R d
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  exact Polynomial.ringHom_ext' (RingHom.ext_int _ _) (by simp)
+
+theorem phiAtSeed_jqNModC_eval_symm {R : Type*} [CommRing R] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n)
+    (hsymm : EvalSymm data.Φ) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (jqNModC R (d * n))).eval (jqNModC R d) = 0 := by
+  have h := data.eval_jqNModC_of_mul_eq_zero hsymm R d
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  exact Polynomial.ringHom_ext' (RingHom.ext_int _ _) (by simp)
+
+theorem phiAtSeed_TS_eval {K : Type*} [Field K] (A : ℕ) [NeZero A] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (TS K (A * d) 1)).eval (TS K (A * (d * n)) 1) = 0 := by
+  have h := phiAtSeed_eval_map data _ _ (qExpand K A) (phiAtSeed_jqNModC_eval (R := K) n data d)
+  rwa [qExpand_jqNModC, qExpand_jqNModC] at h
+
+theorem phiAtSeed_TS_eval_symm {K : Type*} [Field K] (A : ℕ) [NeZero A] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n) (hsymm : EvalSymm data.Φ) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (TS K (A * (d * n)) 1)).eval (TS K (A * d) 1) = 0 := by
+  have h :=
+    phiAtSeed_eval_map data _ _ (qExpand K A) (phiAtSeed_jqNModC_eval_symm (R := K) n data hsymm d)
+  rwa [qExpand_jqNModC, qExpand_jqNModC] at h
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData jqd_mem_full \
+  coeffMap coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one map_jqModC modularFunctionFieldC \
+  coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime"
+
+variable {K : Type*} [Field K]
+
+private theorem prod_form_ne_zero (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e] (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ b) (jqModC K)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (jqModC K))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K))) ::ₘ
+          (Multiset.range p).map (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot p ζ hζ data e u,
+    Polynomial.roots_mul (prod_form_ne_zero ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ b) (jqModC K))))
+        = ((Multiset.range p).map (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K))) (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K))) ::ₘ
+        (Multiset.range p).map (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K)))).Nodup := by
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h :=
+      (TS_injective (K := K) (e := e) (e' := p * (p * e)) (u := u * ζ ^ b) (u' := u ^ (p * p))
+        heq).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e) (u := u * ζ ^ b) (u' := u * ζ ^ b') heq).2
+    have h2 : ζ ^ b = ζ ^ b' := mul_left_cancel h
+    have h3 : ((ζ : Kˣ) : K) ^ b = ((ζ : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h2]
+    exact hζ.pow_inj hb hb' h3
+
+theorem roots_prime_at_slot_roots_nodup (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (jqModC K))))).roots.Nodup := by
+  rw [roots_prime_at_slot p ζ hζ data e u]
+  exact roots_prime_at_slot_nodup p ζ hζ e u
+
+theorem isRoot_prime_at_slot_iff (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (jqModC K))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ b) (jqModC K)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (jqModC K)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot p ζ hζ data e u]
+    exact prod_form_ne_zero ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot p ζ hζ data e u, Multiset.mem_cons,
+    Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+theorem roots_phiAtSeed_TS (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (phiAtSeed data (TS K (p * e) (u ^ p))).roots
+      = TS K (p * (p * e)) (u ^ (p * p)) ::ₘ (Multiset.range p).map (fun b => TS K e (u * ζ ^ b)) :=
+  roots_prime_at_slot p ζ hζ data e u
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData jqd_mem_full \
+  coeffMap coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one map_jqModC modularFunctionFieldC \
+  coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime"
+
+private def slotAt (n d : ℕ) : ℕ :=
+  ((Finset.range d).filter fun b => Nat.gcd (Nat.gcd (n / d) b) d = 1).card
+
+private def slots (n : ℕ) : ℕ := ∑ d ∈ n.divisors, slotAt n d
+
+private theorem slotCond_eq (x d b : ℕ) :
+    Nat.gcd (Nat.gcd x b) d = Nat.gcd (Nat.gcd x d) b := by
+  rw [Nat.gcd_assoc, Nat.gcd_comm b d, ← Nat.gcd_assoc]
+
+private theorem slotCond_iff (x d b : ℕ) :
+    Nat.gcd (Nat.gcd x b) d = 1 ↔ Nat.Coprime (Nat.gcd x d) b := by
+  rw [slotCond_eq]
+
+private theorem gcd_eq_of_modEq {a b n : ℕ} (h : a ≡ b [MOD n]) :
+    Nat.gcd n a = Nat.gcd n b := by
+  have h' : a % n = b % n := h
+  rw [Nat.gcd_rec n a, Nat.gcd_rec n b, h']
+
+private theorem slotCond_mod_iff (x d b : ℕ) :
+    Nat.Coprime (Nat.gcd x d) (b % d) ↔ Nat.Coprime (Nat.gcd x d) b := by
+  unfold Nat.Coprime
+  rw [gcd_eq_of_modEq ((Nat.mod_modEq b d).of_dvd (Nat.gcd_dvd_right x d))]
+
+private theorem slotAt_one (n : ℕ) : slotAt n 1 = 1 := by
+  unfold slotAt
+  simp [Nat.gcd_one_right]
+
+private theorem slotAt_self (n : ℕ) (hn : 0 < n) : slotAt n n = n := by
+  unfold slotAt
+  simp [Nat.div_self hn, Nat.gcd_one_left]
+
+private theorem slotAt_prime_pow_mid {p : ℕ} (hp : p.Prime) {i k : ℕ} (hi0 : 0 < i)
+    (hik : i < k) : slotAt (p ^ k) (p ^ i) = Nat.totient (p ^ i) := by
+  unfold slotAt
+  rw [Nat.totient_eq_card_coprime]
+  congr 1
+  refine Finset.filter_congr fun b _ => ?_
+  rw [slotCond_iff]
+  constructor
+  · intro h
+    have hpg : p ∣ Nat.gcd (p ^ k / p ^ i) (p ^ i) := by
+      refine Nat.dvd_gcd ?_ (dvd_pow_self p hi0.ne')
+      rw [Nat.pow_div hik.le hp.pos]
+      exact dvd_pow_self p (by omega)
+    exact Nat.Coprime.pow_left i (Nat.Coprime.coprime_dvd_left hpg h)
+  · intro h
+    exact Nat.Coprime.coprime_dvd_left (Nat.gcd_dvd_right _ _) h
+
+private theorem slots_prime_pow {p : ℕ} (hp : p.Prime) (k : ℕ) :
+    slots (p ^ (k + 1)) = p ^ (k + 1) + p ^ k := by
+  unfold slots
+  rw [Nat.sum_divisors_prime_pow hp, Finset.sum_range_succ]
+  have hrest : ∀ x ∈ Finset.range (k + 1),
+      slotAt (p ^ (k + 1)) (p ^ x) = Nat.totient (p ^ x) := by
+    intro x hx
+    rcases Nat.eq_zero_or_pos x with rfl | hx0
+    · rw [pow_zero, slotAt_one, Nat.totient_one]
+    · exact slotAt_prime_pow_mid hp hx0 (Finset.mem_range.mp hx)
+  rw [Finset.sum_congr rfl hrest, slotAt_self _ (pow_pos hp.pos _),
+    ← Nat.sum_divisors_prime_pow (f := Nat.totient) hp, Nat.sum_totient, Nat.add_comm]
+
+private theorem dedekindPsi_prime_pow' {p : ℕ} (hp : p.Prime) (k : ℕ) :
+    ModularCurve.dedekindPsi (p ^ (k + 1)) = p ^ (k + 1) + p ^ k := by
+  unfold ModularCurve.dedekindPsi
+  have hfil : Finset.filter (fun d => Squarefree d) (p ^ (k + 1)).divisors = {1, p} := by
+    ext x
+    simp only [Finset.mem_filter, Nat.mem_divisors_prime_pow hp, Finset.mem_insert,
+      Finset.mem_singleton]
+    constructor
+    · rintro ⟨⟨j, -, rfl⟩, hsq⟩
+      rcases Nat.eq_zero_or_pos j with rfl | hj0
+      · exact Or.inl (pow_zero p)
+      · have hj1 : j = 1 := ((Nat.squarefree_pow_iff hp.ne_one hj0.ne').mp hsq).2
+        subst hj1
+        exact Or.inr (pow_one p)
+    · rintro (rfl | rfl)
+      · exact ⟨⟨0, Nat.zero_le _, (pow_zero p).symm⟩, squarefree_one⟩
+      · exact ⟨⟨1, by omega, (pow_one _).symm⟩, hp.prime.squarefree⟩
+  rw [hfil, Finset.sum_pair hp.one_lt.ne, Nat.div_one, pow_succ,
+    Nat.mul_div_cancel _ hp.pos]
+
+private theorem slotAt_mul (M M' d₁ d₂ : ℕ) (hM : M ≠ 0) (hM' : M' ≠ 0)
+    (hco : Nat.Coprime M M') (hd₁ : d₁ ∣ M) (hd₂ : d₂ ∣ M') :
+    slotAt (M * M') (d₁ * d₂) = slotAt M d₁ * slotAt M' d₂ := by
+  have hd₁0 : 0 < d₁ :=
+    Nat.pos_of_ne_zero (by rintro rfl; exact hM (Nat.eq_zero_of_zero_dvd hd₁))
+  have hd₂0 : 0 < d₂ :=
+    Nat.pos_of_ne_zero (by rintro rfl; exact hM' (Nat.eq_zero_of_zero_dvd hd₂))
+  have hcod : Nat.Coprime d₁ d₂ :=
+    Nat.Coprime.coprime_dvd_left hd₁ (Nat.Coprime.coprime_dvd_right hd₂ hco)
+  have hxM : M / d₁ ∣ M := ⟨d₁, (Nat.div_mul_cancel hd₁).symm⟩
+  have hyM' : M' / d₂ ∣ M' := ⟨d₂, (Nat.div_mul_cancel hd₂).symm⟩
+  have hxy : (M * M') / (d₁ * d₂) = (M / d₁) * (M' / d₂) :=
+    (Nat.div_mul_div_comm hd₁ hd₂).symm
+  have hyd₁ : Nat.Coprime (M' / d₂) d₁ :=
+    Nat.Coprime.coprime_dvd_left hyM' (Nat.Coprime.coprime_dvd_right hd₁ hco.symm)
+  have hxd₂ : Nat.Coprime (M / d₁) d₂ :=
+    Nat.Coprime.coprime_dvd_left hxM (Nat.Coprime.coprime_dvd_right hd₂ hco)
+  have hg₁g : Nat.gcd (M / d₁) d₁ ∣ Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) := by
+    rw [hxy]
+    exact Nat.dvd_gcd ((Nat.gcd_dvd_left _ _).mul_right _) ((Nat.gcd_dvd_right _ _).mul_right _)
+  have hg₂g : Nat.gcd (M' / d₂) d₂ ∣ Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) := by
+    rw [hxy]
+    exact Nat.dvd_gcd ((Nat.gcd_dvd_left _ _).mul_left _) ((Nat.gcd_dvd_right _ _).mul_left _)
+  have hgg : Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) ∣
+      Nat.gcd (M / d₁) d₁ * Nat.gcd (M' / d₂) d₂ := by
+    have hgdd : Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) ∣ d₁ * d₂ := Nat.gcd_dvd_right _ _
+    have hgxy : Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) ∣ (M / d₁) * (M' / d₂) := by
+      rw [← hxy]
+      exact Nat.gcd_dvd_left _ _
+    have hgyx : Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) ∣ (M' / d₂) * (M / d₁) :=
+      hgxy.trans (dvd_of_eq (Nat.mul_comm (M / d₁) (M' / d₂)))
+    have hsplit : Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂)) d₁ *
+        Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂)) d₂ =
+        Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) :=
+      (Nat.gcd_mul_gcd_eq_iff_dvd_mul_of_coprime hcod).mpr hgdd
+    rw [← hsplit]
+    refine Nat.mul_dvd_mul ?_ ?_
+    · refine Nat.dvd_gcd ?_ (Nat.gcd_dvd_right _ d₁)
+      have h2 : Nat.Coprime (Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂)) d₁)
+          (M' / d₂) := Nat.Coprime.coprime_dvd_left (Nat.gcd_dvd_right _ d₁) hyd₁.symm
+      exact h2.dvd_of_dvd_mul_right ((Nat.gcd_dvd_left _ d₁).trans hgxy)
+    · refine Nat.dvd_gcd ?_ (Nat.gcd_dvd_right _ d₂)
+      have h2 : Nat.Coprime (Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂)) d₂)
+          (M / d₁) := Nat.Coprime.coprime_dvd_left (Nat.gcd_dvd_right _ d₂) hxd₂.symm
+      exact h2.dvd_of_dvd_mul_right ((Nat.gcd_dvd_left _ d₂).trans hgyx)
+  have hfwd : ∀ b : ℕ, Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) b) (d₁ * d₂) = 1 →
+      Nat.gcd (Nat.gcd (M / d₁) (b % d₁)) d₁ = 1 ∧
+        Nat.gcd (Nat.gcd (M' / d₂) (b % d₂)) d₂ = 1 := by
+    intro b hb
+    rw [slotCond_iff] at hb
+    constructor
+    · rw [slotCond_iff, slotCond_mod_iff]
+      exact Nat.Coprime.coprime_dvd_left hg₁g hb
+    · rw [slotCond_iff, slotCond_mod_iff]
+      exact Nat.Coprime.coprime_dvd_left hg₂g hb
+  have hbwd : ∀ b₁ b₂ k : ℕ, Nat.gcd (Nat.gcd (M / d₁) b₁) d₁ = 1 →
+      Nat.gcd (Nat.gcd (M' / d₂) b₂) d₂ = 1 → k ≡ b₁ [MOD d₁] → k ≡ b₂ [MOD d₂] →
+      Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) k) (d₁ * d₂) = 1 := by
+    intro b₁ b₂ k h₁ h₂ hk₁ hk₂
+    rw [slotCond_iff] at h₁ h₂ ⊢
+    have hc₁ : Nat.Coprime (Nat.gcd (M / d₁) d₁) k := by
+      unfold Nat.Coprime
+      rw [gcd_eq_of_modEq (hk₁.of_dvd (Nat.gcd_dvd_right (M / d₁) d₁))]
+      exact h₁
+    have hc₂ : Nat.Coprime (Nat.gcd (M' / d₂) d₂) k := by
+      unfold Nat.Coprime
+      rw [gcd_eq_of_modEq (hk₂.of_dvd (Nat.gcd_dvd_right (M' / d₂) d₂))]
+      exact h₂
+    exact Nat.Coprime.coprime_dvd_left hgg (Nat.coprime_mul_iff_left.mpr ⟨hc₁, hc₂⟩)
+  unfold slotAt
+  rw [← Finset.card_product]
+  refine Finset.card_bij' (fun b _ => (b % d₁, b % d₂))
+    (fun q _ => (Nat.chineseRemainder hcod q.1 q.2 : ℕ)) ?_ ?_ ?_ ?_
+  · intro b hb
+    obtain ⟨hbr, hbc⟩ := Finset.mem_filter.mp hb
+    obtain ⟨h₁, h₂⟩ := hfwd b hbc
+    exact Finset.mem_product.mpr
+      ⟨Finset.mem_filter.mpr ⟨Finset.mem_range.mpr (Nat.mod_lt b hd₁0), h₁⟩,
+        Finset.mem_filter.mpr ⟨Finset.mem_range.mpr (Nat.mod_lt b hd₂0), h₂⟩⟩
+  · intro q hq
+    obtain ⟨hq₁, hq₂⟩ := Finset.mem_product.mp hq
+    have hcrt := (Nat.chineseRemainder hcod q.1 q.2).prop
+    refine Finset.mem_filter.mpr ⟨Finset.mem_range.mpr
+      (Nat.chineseRemainder_lt_mul hcod q.1 q.2 hd₁0.ne' hd₂0.ne'), ?_⟩
+    exact hbwd q.1 q.2 _ (Finset.mem_filter.mp hq₁).2 (Finset.mem_filter.mp hq₂).2
+      hcrt.1 hcrt.2
+  · intro b hb
+    have hb' : b < d₁ * d₂ := Finset.mem_range.mp (Finset.mem_filter.mp hb).1
+    have hcrt := (Nat.chineseRemainder hcod (b % d₁) (b % d₂)).prop
+    have h₁ : (Nat.chineseRemainder hcod (b % d₁) (b % d₂) : ℕ) ≡ b [MOD d₁] :=
+      hcrt.1.trans (Nat.mod_modEq b d₁)
+    have h₂ : (Nat.chineseRemainder hcod (b % d₁) (b % d₂) : ℕ) ≡ b [MOD d₂] :=
+      hcrt.2.trans (Nat.mod_modEq b d₂)
+    exact ((Nat.modEq_and_modEq_iff_modEq_mul hcod).mp ⟨h₁, h₂⟩).eq_of_lt_of_lt
+      (Nat.chineseRemainder_lt_mul hcod _ _ hd₁0.ne' hd₂0.ne') hb'
+  · intro q hq
+    obtain ⟨hq₁, hq₂⟩ := Finset.mem_product.mp hq
+    have hb₁ : q.1 < d₁ := Finset.mem_range.mp (Finset.mem_filter.mp hq₁).1
+    have hb₂ : q.2 < d₂ := Finset.mem_range.mp (Finset.mem_filter.mp hq₂).1
+    have hcrt := (Nat.chineseRemainder hcod q.1 q.2).prop
+    have h₁ : (Nat.chineseRemainder hcod q.1 q.2 : ℕ) % d₁ = q.1 := by
+      have h' : (Nat.chineseRemainder hcod q.1 q.2 : ℕ) % d₁ = q.1 % d₁ := hcrt.1
+      rw [h', Nat.mod_eq_of_lt hb₁]
+    have h₂ : (Nat.chineseRemainder hcod q.1 q.2 : ℕ) % d₂ = q.2 := by
+      have h' : (Nat.chineseRemainder hcod q.1 q.2 : ℕ) % d₂ = q.2 % d₂ := hcrt.2
+      rw [h', Nat.mod_eq_of_lt hb₂]
+    exact Prod.ext h₁ h₂
+
+private theorem gcd_mul_left_of_dvd (M M' : ℕ) (hco : Nat.Coprime M M') {e₁ e₂ : ℕ}
+    (he₁ : e₁ ∣ M) (he₂ : e₂ ∣ M') : Nat.gcd (e₁ * e₂) M = e₁ := by
+  refine Nat.dvd_antisymm ?_ (Nat.dvd_gcd (dvd_mul_right e₁ e₂) he₁)
+  have hc : Nat.Coprime (Nat.gcd (e₁ * e₂) M) e₂ :=
+    Nat.Coprime.coprime_dvd_left (Nat.gcd_dvd_right _ _)
+      (Nat.Coprime.coprime_dvd_right he₂ hco)
+  exact hc.dvd_of_dvd_mul_right (Nat.gcd_dvd_left _ _)
+
+private theorem gcd_mul_right_of_dvd (M M' : ℕ) (hco : Nat.Coprime M M') {e₁ e₂ : ℕ}
+    (he₁ : e₁ ∣ M) (he₂ : e₂ ∣ M') : Nat.gcd (e₁ * e₂) M' = e₂ := by
+  refine Nat.dvd_antisymm ?_ (Nat.dvd_gcd (dvd_mul_left e₂ e₁) he₂)
+  have hc : Nat.Coprime (Nat.gcd (e₁ * e₂) M') e₁ :=
+    Nat.Coprime.coprime_dvd_left (Nat.gcd_dvd_right _ _)
+      (Nat.Coprime.coprime_dvd_right he₁ hco.symm)
+  have h1 : Nat.gcd (e₁ * e₂) M' ∣ e₂ * e₁ :=
+    (Nat.gcd_dvd_left (e₁ * e₂) M').trans (dvd_of_eq (Nat.mul_comm e₁ e₂))
+  exact hc.dvd_of_dvd_mul_right h1
+
+private theorem slots_mul (M M' : ℕ) (hM : M ≠ 0) (hM' : M' ≠ 0)
+    (hco : Nat.Coprime M M') : slots (M * M') = slots M * slots M' := by
+  unfold slots
+  rw [Finset.sum_mul_sum, ← Finset.sum_product']
+  refine Finset.sum_bij' (fun d _ => (Nat.gcd d M, Nat.gcd d M')) (fun q _ => q.1 * q.2)
+    ?_ ?_ ?_ ?_ ?_
+  · intro d hd
+    exact Finset.mem_product.mpr
+      ⟨Nat.mem_divisors.mpr ⟨Nat.gcd_dvd_right d M, hM⟩,
+        Nat.mem_divisors.mpr ⟨Nat.gcd_dvd_right d M', hM'⟩⟩
+  · intro q hq
+    obtain ⟨hq₁, hq₂⟩ := Finset.mem_product.mp hq
+    exact Nat.mem_divisors.mpr
+      ⟨Nat.mul_dvd_mul (Nat.mem_divisors.mp hq₁).1 (Nat.mem_divisors.mp hq₂).1,
+        Nat.mul_ne_zero hM hM'⟩
+  · intro d hd
+    exact (Nat.gcd_mul_gcd_eq_iff_dvd_mul_of_coprime hco).mpr (Nat.mem_divisors.mp hd).1
+  · intro q hq
+    obtain ⟨hq₁, hq₂⟩ := Finset.mem_product.mp hq
+    exact Prod.ext
+      (gcd_mul_left_of_dvd M M' hco (Nat.mem_divisors.mp hq₁).1 (Nat.mem_divisors.mp hq₂).1)
+      (gcd_mul_right_of_dvd M M' hco (Nat.mem_divisors.mp hq₁).1 (Nat.mem_divisors.mp hq₂).1)
+  · intro d hd
+    have hsplit : Nat.gcd d M * Nat.gcd d M' = d :=
+      (Nat.gcd_mul_gcd_eq_iff_dvd_mul_of_coprime hco).mpr (Nat.mem_divisors.mp hd).1
+    conv_lhs => rw [← hsplit]
+    exact slotAt_mul M M' (Nat.gcd d M) (Nat.gcd d M') hM hM' hco
+      (Nat.gcd_dvd_right d M) (Nat.gcd_dvd_right d M')
+
+private theorem slots_eq_dedekindPsi : ∀ n : ℕ, n ≠ 0 → slots n = ModularCurve.dedekindPsi n := by
+  intro n
+  induction n using Nat.recOnPosPrimePosCoprime with
+  | prime_pow p k hp hk =>
+    intro _
+    obtain ⟨j, rfl⟩ : ∃ j, k = j + 1 := ⟨k - 1, by omega⟩
+    rw [slots_prime_pow hp j, dedekindPsi_prime_pow' hp j]
+  | zero => exact fun h0 => absurd rfl h0
+  | one =>
+    intro _
+    rw [ModularCurve.dedekindPsi_one]
+    unfold slots
+    rw [Nat.divisors_one, Finset.sum_singleton]
+    exact slotAt_one 1
+  | coprime a b ha hb hab iha ihb =>
+    intro _
+    rw [slots_mul a b (by omega) (by omega) hab, iha (by omega), ihb (by omega),
+      ModularCurve.dedekindPsi_mul_of_coprime a b hab]
+
+private theorem dedekindPsi_pos {n : ℕ} (hn : n ≠ 0) : 0 < ModularCurve.dedekindPsi n := by
+  have h1 : (1 : ℕ) ∈ n.divisors.filter (fun d => Squarefree d) :=
+    Finset.mem_filter.mpr ⟨Nat.one_mem_divisors.mpr hn, squarefree_one⟩
+  have h2 : n / 1 ≤ ∑ d ∈ n.divisors with Squarefree d, n / d :=
+    Finset.single_le_sum (f := fun d => n / d) (fun i _ => Nat.zero_le _) h1
+  rw [Nat.div_one] at h2
+  exact lt_of_lt_of_le (Nat.pos_of_ne_zero hn) h2
+
+private theorem dedekindPsi_prime (p : ℕ) (hp : p.Prime) :
+    ModularCurve.dedekindPsi p = p + 1 := by
+  have h1 := ModularCurve.dedekindPsi_prime_pow p 1 hp one_ne_zero
+  rw [pow_one] at h1
+  rw [h1]
+  norm_num
+
+private theorem dedekindPsi_mul_prime_not_dvd {m p : ℕ} (hp : p.Prime) (hpm : ¬ p ∣ m) :
+    ModularCurve.dedekindPsi (m * p) = ModularCurve.dedekindPsi m * (p + 1) := by
+  have hco : Nat.Coprime m p := ((Nat.Prime.coprime_iff_not_dvd hp).mpr hpm).symm
+  rw [ModularCurve.dedekindPsi_mul_of_coprime m p hco, dedekindPsi_prime p hp]
+
+private theorem dedekindPsi_mul_prime_dvd {m p : ℕ} (hm : m ≠ 0) (hp : p.Prime)
+    (hpm : p ∣ m) : ModularCurve.dedekindPsi (m * p) = ModularCurve.dedekindPsi m * p := by
+  obtain ⟨k, u, hpu, hmu⟩ := Nat.exists_eq_pow_mul_and_not_dvd hm p hp.ne_one
+  obtain ⟨k', rfl⟩ : ∃ k', k = k' + 1 := by
+    rcases k with - | k'
+    · exfalso
+      rw [hmu, pow_zero, one_mul] at hpm
+      exact hpu hpm
+    · exact ⟨k', rfl⟩
+  subst hmu
+  have hcou : ∀ j : ℕ, j ≠ 0 → Nat.Coprime (p ^ j) u :=
+    fun j _ => Nat.Coprime.pow_left j ((Nat.Prime.coprime_iff_not_dvd hp).mpr hpu)
+  have h1 : p ^ (k' + 1) * u * p = p ^ (k' + 2) * u := by ring
+  rw [h1, ModularCurve.dedekindPsi_mul_of_coprime _ u (hcou _ (Nat.succ_ne_zero _)),
+    ModularCurve.dedekindPsi_mul_of_coprime _ u (hcou _ (Nat.succ_ne_zero _)),
+    ModularCurve.dedekindPsi_prime_pow p (k' + 2) hp (Nat.succ_ne_zero _),
+    ModularCurve.dedekindPsi_prime_pow p (k' + 1) hp (Nat.succ_ne_zero _)]
+  have h2 : k' + 2 - 1 = k' + 1 := rfl
+  have h3 : k' + 1 - 1 = k' := rfl
+  rw [h2, h3]
+  ring
+
+private theorem exists_ringHom_adjoin_of_isRoot {F E L : Type*} [Field F] [Field E] [Field L]
+    [Algebra F E] {α : E} (hα : IsIntegral F α) (ι : F →+* L) {y : L}
+    (hy : ((minpoly F α).map ι).IsRoot y) :
+    ∃ ψ : ↥(IntermediateField.adjoin F ({α} : Set E)) →+* L,
+      ψ.comp (algebraMap F (IntermediateField.adjoin F ({α} : Set E))) = ι ∧
+        ψ (IntermediateField.AdjoinSimple.gen F α) = y := by
+  let : Algebra F L := ι.toAlgebra
+  have halgL : algebraMap F L = ι := RingHom.algebraMap_toAlgebra ι
+  have hy' : y ∈ (minpoly F α).aroots L := by
+    rw [Polynomial.mem_aroots]
+    refine ⟨minpoly.ne_zero hα, ?_⟩
+    rw [Polynomial.aeval_def, halgL, Polynomial.eval₂_eq_eval_map]
+    exact hy
+  refine ⟨((IntermediateField.algHomAdjoinIntegralEquiv F hα).symm ⟨y, hy'⟩).toRingHom,
+    RingHom.ext fun z => ?_, ?_⟩
+  · rw [RingHom.comp_apply]
+    have h1 := ((IntermediateField.algHomAdjoinIntegralEquiv F hα).symm ⟨y, hy'⟩).commutes z
+    rwa [halgL] at h1
+  · exact IntermediateField.algHomAdjoinIntegralEquiv_symm_apply_gen F hα ⟨y, hy'⟩
+
+private theorem ringHom_comp_aeval {F A L : Type*} [Field F] [CommRing A] [Algebra F A]
+    [CommRing L] (ψ : A →+* L) (ι : F →+* L) (hcomp : ψ.comp (algebraMap F A) = ι)
+    (P : Polynomial F) (x : A) : ψ (Polynomial.aeval x P) = (P.map ι).eval (ψ x) := by
+  rw [Polynomial.aeval_def, Polynomial.hom_eval₂, hcomp, Polynomial.eval_map]
+
+variable {K : Type*} [Field K]
+
+private def sv (K : Type*) [Field K] (ζ : Kˣ) (a b : ℕ) : LaurentSeries K :=
+  if h : a = 0 then 0 else
+    letI : NeZero a := ⟨h⟩
+    qExpand K (a * a) (qTwist (ζ ^ (b * a)) (jqModC K))
+
+private theorem sv_eq (ζ : Kˣ) (a b : ℕ) [NeZero a] :
+    sv K ζ a b = qExpand K (a * a) (qTwist (ζ ^ (b * a)) (jqModC K)) := by
+  unfold sv
+  rw [dite_eq_right (NeZero.ne a)]
+
+private theorem sv_eq_TS (ζ : Kˣ) (a b : ℕ) [NeZero a] :
+    sv K ζ a b = TS K (a * a) (ζ ^ (b * a)) :=
+  sv_eq ζ a b
+
+private theorem TS_congr' {e e' : ℕ} [NeZero e] [NeZero e'] {u u' : Kˣ} (he : e = e')
+    (hu : u = u') : TS K e u = TS K e' u' := by
+  subst he
+  rw [hu]
+
+private theorem sv_inj {M : ℕ} {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) M)
+    {a b a' b' : ℕ} (ha0 : a ≠ 0) (ha0' : a' ≠ 0) (hb : b * a < M) (hb' : b' * a' < M)
+    (h : sv K ζ a b = sv K ζ a' b') : a = a' ∧ b = b' := by
+  have : NeZero a := ⟨ha0⟩
+  have : NeZero a' := ⟨ha0'⟩
+  rw [sv_eq_TS, sv_eq_TS] at h
+  obtain ⟨he, hu⟩ := TS_injective h
+  have haa : a = a' := (mul_self_inj (Nat.zero_le a) (Nat.zero_le a')).mp he
+  subst haa
+  refine ⟨rfl, ?_⟩
+  have hv : ((ζ : K)) ^ (b * a) = ((ζ : K)) ^ (b' * a) := by
+    have h1 := congrArg Units.val hu
+    rwa [Units.val_pow_eq_pow_val, Units.val_pow_eq_pow_val] at h1
+  have h2 : b * a = b' * a := hζ.pow_inj hb hb' hv
+  exact Nat.eq_of_mul_eq_mul_right (Nat.pos_of_ne_zero ha0) h2
+
+private theorem jqNModC_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) :
+    jqNModC K n = jqNModC K m := by
+  subst h
+  rfl
+
+private theorem sv_top (M : ℕ) [NeZero M] (ζ : Kˣ) :
+    sv K ζ M 0 = qExpand K M (jqNModC K M) := by
+  rw [sv_eq_TS, qExpand_jqNModC M M]
+  exact TS_congr' rfl (by rw [zero_mul, pow_zero])
+
+private theorem aeval_intermediateField_eq_zero {F₀ L : Type*} [Field F₀] [Field L]
+    [Algebra F₀ L] {E : IntermediateField F₀ L} {P : Polynomial F₀} {x : E}
+    (h : Polynomial.aeval (E.val x) P = 0) : Polynomial.aeval x P = 0 := by
+  have h1 := Polynomial.aeval_algHom_apply E.val x P
+  rw [h] at h1
+  have h2 : E.val (Polynomial.aeval x P) = E.val 0 := by rw [← h1, map_zero]
+  exact RingHom.injective (E.val : E →+* L) h2
+
+private theorem phiAtSeed_eval_of_injective {R S : Type*} [CommRing R] [CommRing S] {n : ℕ}
+    [NeZero n] (data : ModularPolynomialData n) (x y : R) (f : R →+* S)
+    (hf : Function.Injective f) (h : (phiAtSeed data (f x)).eval (f y) = 0) :
+    (phiAtSeed data x).eval y = 0 := by
+  rw [← phiAtSeed_map, Polynomial.eval_map, Polynomial.eval₂_hom] at h
+  exact (injective_iff_map_eq_zero f).mp hf _ h
+
+private def jGenC : K⟮jqModC K⟯ :=
+  ⟨jqModC K, IntermediateField.mem_adjoin_simple_self K (jqModC K)⟩
+
+private theorem jqdC_mem_fullC {M d : ℕ} [NeZero d] (hdM : d ∣ M) :
+    jqNModC K d ∈ IntermediateField.adjoin K
+      {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ M ∧ x = jqNModC K d'} :=
+  IntermediateField.subset_adjoin K _ ⟨d, ‹_›, hdM, rfl⟩
+
+private theorem mem_adjoin_jqNModC_of_mem_mffC {M : ℕ} [NeZero M] {x : LaurentSeries K}
+    (hx : x ∈ modularFunctionFieldC K M) :
+    x ∈ IntermediateField.adjoin K⟮jqModC K⟯ ({jqNModC K M} : Set (LaurentSeries K)) := by
+  have hle : K⟮jqModC K⟯ ≤
+      IntermediateField.adjoin K ({jqModC K, jqNModC K M} : Set (LaurentSeries K)) :=
+    IntermediateField.adjoin.mono K _ _
+      (Set.singleton_subset_iff.mpr (Set.mem_insert _ _))
+  have hE := IntermediateField.extendScalars_adjoin hle
+  have hcollapse : IntermediateField.adjoin K⟮jqModC K⟯
+      ({jqModC K, jqNModC K M} : Set (LaurentSeries K))
+      = IntermediateField.adjoin K⟮jqModC K⟯ ({jqNModC K M} : Set (LaurentSeries K)) := by
+    refine le_antisymm (IntermediateField.adjoin_le_iff.mpr ?_)
+      (IntermediateField.adjoin.mono _ _ _ ?_)
+    · rintro z (rfl | rfl)
+      · exact (IntermediateField.adjoin K⟮jqModC K⟯ _).algebraMap_mem jGenC
+      · exact IntermediateField.subset_adjoin K⟮jqModC K⟯ _ rfl
+    · exact Set.singleton_subset_iff.mpr (Set.mem_insert_of_mem _ rfl)
+  rw [modularFunctionFieldC] at hx
+  have h2 : x ∈ IntermediateField.extendScalars hle :=
+    (IntermediateField.mem_extendScalars _).mpr hx
+  rw [hE, hcollapse] at h2
+  exact h2
+
+private theorem mem_range_of_eval_eq_const {F L : Type*} [Field F] [Field L] (ι : F →+* L)
+    (g : Polynomial F) (x : L) (s : Finset L) (hcard : g.natDegree < s.card)
+    (hval : ∀ y ∈ s, (g.map ι).eval y = x) : x ∈ ι.range := by
+  classical
+  set Q : Polynomial L := g.map ι - Polynomial.C x with hQ
+  have hQdeg : Q.natDegree ≤ g.natDegree := by
+    refine (Polynomial.natDegree_sub_le _ _).trans ?_
+    rw [Polynomial.natDegree_map, Polynomial.natDegree_C, max_eq_left (Nat.zero_le _)]
+  have hQ0 : Q = 0 := by
+    refine Polynomial.eq_zero_of_natDegree_lt_card_of_eval_eq_zero' Q s (fun y hy => ?_)
+      (hQdeg.trans_lt hcard)
+    rw [hQ, Polynomial.eval_sub, Polynomial.eval_C, hval y hy, sub_self]
+  have hconst : g.map ι = Polynomial.C x := sub_eq_zero.mp hQ0
+  refine ⟨g.coeff 0, ?_⟩
+  have h2 := congrArg (fun P : Polynomial L => P.coeff 0) hconst
+  simpa only [Polynomial.coeff_map, Polynomial.coeff_C_zero] using h2
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData jqd_mem_full \
+  coeffMap coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one map_jqModC modularFunctionFieldC \
+  coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime"
+
+section RValCore
+
+variable {K : Type*} [Field K]
+
+private theorem map_qExpand_minpoly_eq {M' : ℕ} [NeZero M'] (k : ℕ) [NeZero k] {N : ℕ}
+    [NeZero N] (hN : N = k * M') (ζ' : Kˣ)
+    (hid : (minpoly K⟮jqModC K⟯ (jqNModC K M')).map
+        ((qExpand K M').comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))
+      = ∏ a ∈ M'.divisors, ∏ b ∈ (Finset.range (M' / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M' / a) = 1),
+          (Polynomial.X - Polynomial.C (sv K ζ' a b))) :
+    (minpoly K⟮jqModC K⟯ (jqNModC K M')).map
+        ((qExpand K N).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))
+      = ∏ a ∈ M'.divisors, ∏ b ∈ (Finset.range (M' / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M' / a) = 1),
+          (Polynomial.X - Polynomial.C (qExpand K k (sv K ζ' a b))) := by
+  subst hN
+  have hcomp : (qExpand K k).comp
+      ((qExpand K M').comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))
+      = (qExpand K (k * M')).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K)) := by
+    refine RingHom.ext fun z => ?_
+    simp only [RingHom.comp_apply]
+    rw [qExpand_qExpand]
+  have h1 : (minpoly K⟮jqModC K⟯ (jqNModC K M')).map
+      ((qExpand K (k * M')).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))
+      = ((minpoly K⟮jqModC K⟯ (jqNModC K M')).map
+          ((qExpand K M').comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))).map (qExpand K k) := by
+    rw [Polynomial.map_map, hcomp]
+  rw [h1, hid, Polynomial.map_prod]
+  refine Finset.prod_congr rfl fun a _ => ?_
+  rw [Polynomial.map_prod]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C]
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+private theorem rval_aux : ∀ (M : ℕ) [NeZero M] {K : Type*} [Field K]
+    (ζ : Kˣ), IsPrimitiveRoot ((ζ : Kˣ) : K) M →
+    (∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank K⟮jqModC K⟯
+          (IntermediateField.adjoin K⟮jqModC K⟯
+            ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d
+        ∧ modularFunctionFieldC K d = IntermediateField.adjoin K
+            {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ d ∧ x = jqNModC K d'}) →
+    (minpoly K⟮jqModC K⟯ (jqNModC K M)).map
+        ((qExpand K M).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))
+      = ∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+          (Polynomial.X - Polynomial.C (sv K ζ a b)) := by
+  intro M
+  induction M using Nat.strong_induction_on with
+  | _ M IH =>
+  intro _ K _ ζ hζ hall
+  classical
+  have hM0 : M ≠ 0 := NeZero.ne M
+  have hslot_root : ∀ a b : ℕ, a ∈ M.divisors →
+      b ∈ (Finset.range (M / a)).filter (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1) →
+      ((minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K M).comp (algebraMap K⟮jqModC K⟯
+        (LaurentSeries K)))).IsRoot (sv K ζ a b) := by
+    intro a b ha hb
+    obtain ⟨haM, -⟩ := Nat.mem_divisors.mp ha
+    obtain ⟨hbr, hbc⟩ := Finset.mem_filter.mp hb
+    rw [Finset.mem_range] at hbr
+    have ha0 : a ≠ 0 := by
+      rintro rfl
+      exact hM0 (Nat.eq_zero_of_zero_dvd haM)
+    have : NeZero a := ⟨ha0⟩
+    have had : a * (M / a) = M := Nat.mul_div_cancel' haM
+    by_cases hd1 : M / a = 1
+    · have haM' : a = M := by rw [hd1, mul_one] at had; exact had
+      have hb0 : b = 0 := by omega
+      subst hb0
+      rw [show sv K ζ a 0 = sv K ζ M 0 from by rw [haM'], sv_top]
+      rw [Polynomial.IsRoot, Polynomial.eval_map, ← Polynomial.hom_eval₂]
+      have h0 : Polynomial.eval₂ (algebraMap K⟮jqModC K⟯ (LaurentSeries K)) (jqNModC K M)
+          (minpoly K⟮jqModC K⟯ (jqNModC K M)) = 0 := by
+        rw [← Polynomial.aeval_def]
+        exact minpoly.aeval _ _
+      rw [h0, map_zero]
+    · have hd0 : M / a ≠ 0 := by
+        intro h0
+        rw [h0, mul_zero] at had
+        exact hM0 had.symm
+      have hpp : (M / a).minFac.Prime := Nat.minFac_prime hd1
+      have : Fact (M / a).minFac.Prime := ⟨hpp⟩
+      have : NeZero (M / a).minFac := ⟨hpp.ne_zero⟩
+      obtain ⟨d'', hdd⟩ : (M / a).minFac ∣ M / a := Nat.minFac_dvd _
+      set p := (M / a).minFac with hp_def
+      have hd''0 : d'' ≠ 0 := by
+        rintro rfl
+        rw [mul_zero] at hdd
+        exact hd0 hdd
+      have : NeZero d'' := ⟨hd''0⟩
+      have hM'0 : a * d'' ≠ 0 := Nat.mul_ne_zero ha0 hd''0
+      have : NeZero (a * d'') := ⟨hM'0⟩
+      have hMM' : M = a * d'' * p := by rw [← had, hdd]; ring
+      have hM'M : a * d'' ∣ M := ⟨p, hMM'⟩
+      have hM'lt : a * d'' < M := by
+        calc a * d'' = a * d'' * 1 := by ring
+          _ < a * d'' * p :=
+              (Nat.mul_lt_mul_left (Nat.pos_of_ne_zero hM'0)).mpr hpp.one_lt
+          _ = M := hMM'.symm
+      have hpM : p ∣ M := by
+        have hpd : p ∣ M / a := ⟨d'', hdd⟩
+        exact hpd.trans (Nat.div_dvd_of_dvd haM)
+      have hb''lt : b % d'' < d'' := Nat.mod_lt b (Nat.pos_of_ne_zero hd''0)
+      have hbsplit : b % d'' + b / d'' * d'' = b := Nat.mod_add_div' b d''
+      have hc₀p : b / d'' < p := by
+        have h1 : b < d'' * p := by rw [Nat.mul_comm d'' p, ← hdd]; exact hbr
+        exact Nat.div_lt_of_lt_mul h1
+      have hprim' : Nat.gcd (Nat.gcd a (b % d'')) d'' = 1 := by
+        have h1 : Nat.gcd (Nat.gcd a (b % d'')) d'' ∣ Nat.gcd (Nat.gcd a b) (M / a) := by
+          refine Nat.dvd_gcd (Nat.dvd_gcd ?_ ?_) ?_
+          · exact (Nat.gcd_dvd_left _ _).trans (Nat.gcd_dvd_left a (b % d''))
+          · have hgb'' : Nat.gcd (Nat.gcd a (b % d'')) d'' ∣ b % d'' :=
+              (Nat.gcd_dvd_left _ _).trans (Nat.gcd_dvd_right a (b % d''))
+            have hgd'' : Nat.gcd (Nat.gcd a (b % d'')) d'' ∣ d'' := Nat.gcd_dvd_right _ _
+            have h2 : Nat.gcd (Nat.gcd a (b % d'')) d'' ∣ b % d'' + b / d'' * d'' :=
+              Nat.dvd_add hgb'' (hgd''.mul_left _)
+            rwa [hbsplit] at h2
+          · rw [hdd]
+            exact (Nat.gcd_dvd_right _ _).mul_left p
+        rw [hbc] at h1
+        exact Nat.dvd_one.mp h1
+      have hζ' : IsPrimitiveRoot ((ζ ^ p : Kˣ) : K) (a * d'') := by
+        have h1 := isPrimitiveRoot_pow_div hζ hM'M
+        have h2 : M / (a * d'') = p := by
+          rw [hMM']
+          exact Nat.mul_div_cancel_left p (Nat.pos_of_ne_zero hM'0)
+        rwa [h2] at h1
+      have hIH := IH (a * d'') hM'lt (ζ ^ p) hζ' (fun e he _ => hall e (he.trans hM'M))
+      have hIHM := map_qExpand_minpoly_eq p (show M = p * (a * d'') from by rw [hMM']; ring)
+        (ζ ^ p) hIH
+      have hroot' : ((minpoly K⟮jqModC K⟯ (jqNModC K (a * d''))).map ((qExpand K M).comp (algebraMap
+        K⟮jqModC K⟯ (LaurentSeries K)))).IsRoot
+          (qExpand K p (sv K (ζ ^ p) a (b % d''))) := by
+        rw [hIHM, Polynomial.IsRoot, Polynomial.eval_prod]
+        refine Finset.prod_eq_zero (Nat.mem_divisors.mpr ⟨⟨d'', rfl⟩, hM'0⟩) ?_
+        rw [Polynomial.eval_prod]
+        have hM'a : a * d'' / a = d'' := Nat.mul_div_cancel_left d'' (Nat.pos_of_ne_zero ha0)
+        refine Finset.prod_eq_zero (i := b % d'') ?_ ?_
+        · rw [hM'a]
+          exact Finset.mem_filter.mpr ⟨Finset.mem_range.mpr hb''lt, hprim'⟩
+        · rw [Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, sub_self]
+      obtain ⟨htM', hgM'⟩ := hall (a * d'') hM'M
+      have hfd' : FiniteDimensional K⟮jqModC K⟯
+          (IntermediateField.adjoin K⟮jqModC K⟯
+            ({jqNModC K (a * d'')} : Set (LaurentSeries K))) :=
+        FiniteDimensional.of_finrank_pos (htM' ▸ dedekindPsi_pos hM'0)
+      have hα' : IsIntegral K⟮jqModC K⟯ (jqNModC K (a * d'')) :=
+        IntermediateField.isIntegral_iff.mp (IsIntegral.of_finite K⟮jqModC K⟯
+          (⟨jqNModC K (a * d''), IntermediateField.subset_adjoin K⟮jqModC K⟯ _ rfl⟩ :
+            IntermediateField.adjoin K⟮jqModC K⟯
+              ({jqNModC K (a * d'')} : Set (LaurentSeries K))))
+      obtain ⟨ψ₁, hψcomp, hψ₁⟩ := exists_ringHom_adjoin_of_isRoot hα'
+        ((qExpand K M).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K))) hroot'
+      obtain ⟨dp, -, hdpsym⟩ := ModularCurve.exists_phiIrreducible_evalSymm p
+      have hup : (phiAtSeed dp (jqNModC K (a * d''))).eval (jqNModC K M) = 0 := by
+        have h1 := phiAtSeed_jqNModC_eval (R := K) p dp (a * d'')
+        rwa [show jqNModC K (a * d'' * p) = jqNModC K M from jqNModC_congr hMM'.symm] at h1
+      have haev : Polynomial.aeval (jqNModC K M)
+          (phiAtSeed dp (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K (a * d'')))) = 0
+            := by
+        rw [Polynomial.aeval_def, Polynomial.eval₂_eq_eval_map, phiAtSeed_map]
+        exact hup
+      have hα₁ : IsIntegral K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M) :=
+        ⟨phiAtSeed dp (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K (a * d''))),
+          phiAtSeed_monic dp _, by rw [← Polynomial.aeval_def]; exact haev⟩
+      have hmindvd : minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)
+          ∣ phiAtSeed dp (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K (a * d''))) :=
+        minpoly.dvd _ _ haev
+      let : Module.Free K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ :=
+        Module.Free.of_divisionRing _ _
+      let : Module.Free K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯
+          K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯⟮jqNModC K M⟯ :=
+        Module.Free.of_divisionRing _ _
+      have htow := Module.finrank_mul_finrank K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯
+        K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯⟮jqNModC K M⟯
+      have habs : IntermediateField.adjoin K⟮jqModC K⟯
+          (({jqNModC K (a * d'')} : Set (LaurentSeries K)) ∪ {jqNModC K M})
+          = IntermediateField.adjoin K⟮jqModC K⟯ ({jqNModC K M} : Set (LaurentSeries K)) := by
+        obtain ⟨-, hgM⟩ := hall M dvd_rfl
+        refine le_antisymm (IntermediateField.adjoin_le_iff.mpr ?_)
+          (IntermediateField.adjoin.mono _ _ _ Set.subset_union_right)
+        rintro z (hz | hz)
+        · rw [Set.mem_singleton_iff] at hz
+          subst hz
+          have h1 : jqNModC K (a * d'') ∈ IntermediateField.adjoin K
+              {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ M ∧ x = jqNModC K d'} :=
+            jqdC_mem_fullC hM'M
+          rw [← hgM] at h1
+          exact mem_adjoin_jqNModC_of_mem_mffC h1
+        · rw [Set.mem_singleton_iff] at hz
+          subst hz
+          exact IntermediateField.subset_adjoin _ _ rfl
+      have htop : Module.finrank K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯⟮jqNModC K M⟯ =
+        dedekindPsi M :=
+        by
+        obtain ⟨htM, -⟩ := hall M dvd_rfl
+        have h1 := IntermediateField.adjoin_adjoin_left K⟮jqModC K⟯
+          ({jqNModC K (a * d'')} : Set (LaurentSeries K)) {jqNModC K M}
+        have h2 : Module.finrank K⟮jqModC K⟯
+            (IntermediateField.restrictScalars K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯⟮jqNModC
+              K M⟯)
+            = Module.finrank K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯⟮jqNModC K M⟯ := rfl
+        rw [← h2, h1, habs]
+        exact htM
+      have hstep_deg : Module.finrank K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ K⟮jqModC K⟯⟮jqNModC K (a *
+        d'')⟯⟮jqNModC K M⟯
+          * dedekindPsi (a * d'') = dedekindPsi M := by
+        rw [← htM', ← htop, Nat.mul_comm]
+        exact htow
+      have hseed : qExpand K p (sv K (ζ ^ p) a (b % d''))
+          = qExpand K (p * (a * a)) (qTwist ((ζ ^ (b % d'' * a)) ^ p) (jqModC K)) := by
+        rw [sv_eq_TS, qExpand_TS]
+        change TS K (p * (a * a)) ((ζ ^ p) ^ (b % d'' * a))
+          = TS K (p * (a * a)) ((ζ ^ (b % d'' * a)) ^ p)
+        exact TS_congr' rfl (by rw [← pow_mul, ← pow_mul, Nat.mul_comm])
+      have hζ'p : IsPrimitiveRoot ((ζ ^ (M / p) : Kˣ) : K) p := isPrimitiveRoot_pow_div hζ hpM
+      have hC5 := ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot p (ζ ^ (M / p))
+        hζ'p dp (a * a) (ζ ^ (b % d'' * a))
+      have hC5' : phiAtSeed dp (qExpand K (p * (a * a))
+            (qTwist ((ζ ^ (b % d'' * a)) ^ p) (jqModC K)))
+          = (Polynomial.X - Polynomial.C (qExpand K (p * (p * (a * a)))
+              (qTwist ((ζ ^ (b % d'' * a)) ^ (p * p)) (jqModC K))))
+            * ∏ c ∈ Finset.range p, (Polynomial.X - Polynomial.C (qExpand K (a * a)
+              (qTwist (ζ ^ (b % d'' * a) * ζ ^ (c * (M / p))) (jqModC K)))) := by
+        have h1 : phiAtSeed dp (qExpand K (p * (a * a))
+              (qTwist ((ζ ^ (b % d'' * a)) ^ p) (jqModC K)))
+            = (Polynomial.X - Polynomial.C (qExpand K (p * (p * (a * a)))
+                (qTwist ((ζ ^ (b % d'' * a)) ^ (p * p)) (jqModC K))))
+              * ∏ c ∈ Finset.range p, (Polynomial.X - Polynomial.C (qExpand K (a * a)
+                (qTwist (ζ ^ (b % d'' * a) * (ζ ^ (M / p)) ^ c) (jqModC K)))) := hC5
+        rw [h1]
+        congr 1
+        refine Finset.prod_congr rfl fun c _ => ?_
+        rw [← pow_mul, Nat.mul_comm (M / p) c]
+      have hΦfact : phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d'')))
+          = (Polynomial.X - Polynomial.C (qExpand K (p * (p * (a * a)))
+              (qTwist ((ζ ^ (b % d'' * a)) ^ (p * p)) (jqModC K))))
+            * ∏ c ∈ Finset.range p, (Polynomial.X - Polynomial.C (qExpand K (a * a)
+              (qTwist (ζ ^ (b % d'' * a) * ζ ^ (c * (M / p))) (jqModC K)))) := by
+        rw [hseed]
+        exact hC5'
+      have hMp : M / p = a * d'' := by
+        rw [hMM']
+        exact Nat.mul_div_cancel _ hpp.pos
+      have htarget : qExpand K (a * a) (qTwist (ζ ^ (b % d'' * a) * ζ ^ (b / d'' * (M / p)))
+          (jqModC K)) = sv K ζ a b := by
+        rw [sv_eq]
+        change TS K (a * a) (ζ ^ (b % d'' * a) * ζ ^ (b / d'' * (M / p)))
+          = TS K (a * a) (ζ ^ (b * a))
+        refine TS_congr' rfl ?_
+        rw [hMp, ← pow_add]
+        congr 1
+        rw [show b % d'' * a + b / d'' * (a * d'')
+          = (b % d'' + b / d'' * d'') * a from by ring, hbsplit]
+      by_cases hpM' : p ∣ a * d''
+      · have hψM : dedekindPsi M = dedekindPsi (a * d'') * p := by
+          rw [hMM']
+          exact dedekindPsi_mul_prime_dvd hM'0 hpp hpM'
+        have he : Module.finrank K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ K⟮jqModC K⟯⟮jqNModC K (a *
+          d'')⟯⟮jqNModC K M⟯ = p :=
+          by
+          have h1 : Module.finrank K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ K⟮jqModC K⟯⟮jqNModC K (a *
+            d'')⟯⟮jqNModC K M⟯
+              * dedekindPsi (a * d'') = p * dedekindPsi (a * d'') := by
+            rw [hstep_deg, hψM]
+            ring
+          exact Nat.eq_of_mul_eq_mul_right (dedekindPsi_pos hM'0) h1
+        obtain ⟨m'', hm''⟩ := hpM'
+        have hm''0 : m'' ≠ 0 := by
+          rintro rfl
+          rw [mul_zero] at hm''
+          exact hM'0 hm''
+        have : NeZero m'' := ⟨hm''0⟩
+        have hm''M : m'' ∣ M := ⟨p * p, by rw [hMM', hm'']; ring⟩
+        have hm''lt : m'' < M := by
+          calc m'' ≤ a * d'' := by rw [hm'']; exact Nat.le_mul_of_pos_left m'' hpp.pos
+            _ < M := hM'lt
+        have hdown : (phiAtSeed dp (jqNModC K (a * d''))).eval (jqNModC K m'') = 0 := by
+          have h1 := phiAtSeed_jqNModC_eval_symm (R := K) p dp hdpsym m''
+          rwa [show jqNModC K (m'' * p) = jqNModC K (a * d'')
+            from jqNModC_congr (by rw [hm'']; ring)] at h1
+        have hmem'' : jqNModC K m'' ∈ K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ := by
+          have h1 : jqNModC K m'' ∈ IntermediateField.adjoin K
+              {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ a * d'' ∧ x = jqNModC K d'} :=
+            jqdC_mem_fullC ⟨p, by rw [hm'']; ring⟩
+          rw [← hgM'] at h1
+          exact mem_adjoin_jqNModC_of_mem_mffC h1
+        have hdownF₁ : (phiAtSeed dp (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯
+            (jqNModC K (a * d'')))).eval (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a *
+              d'')⟯) = 0 :=
+          phiAtSeed_eval_of_injective dp _ _
+            (algebraMap K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (LaurentSeries K)) (RingHom.injective _)
+              hdown
+        have hψx'' : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d'')))).IsRoot
+            (ψ₁ (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)) := by
+          have h1 := phiAtSeed_eval_map dp _ _ ψ₁ hdownF₁
+          rwa [hψ₁] at h1
+        have hx''notmin : ¬ (minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).IsRoot
+            (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯) := by
+          intro hcon
+          obtain ⟨q, hq⟩ := Polynomial.dvd_iff_isRoot.mpr hcon
+          have hirr := minpoly.irreducible hα₁
+          rcases hirr.isUnit_or_isUnit hq with hu | hu
+          · exact Polynomial.not_isUnit_X_sub_C _ hu
+          · have hq0 : q ≠ 0 := by
+              rintro rfl
+              rw [mul_zero] at hq
+              exact minpoly.ne_zero hα₁ hq
+            have hdm : (minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).natDegree = 1 := by
+              rw [hq, Polynomial.natDegree_mul (Polynomial.X_sub_C_ne_zero _) hq0,
+                Polynomial.natDegree_X_sub_C, Polynomial.natDegree_eq_zero_of_isUnit hu]
+            have hdm' : (minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).natDegree = p := by
+              rw [← IntermediateField.adjoin.finrank hα₁]
+              exact he
+            rw [hdm] at hdm'
+            exact (Nat.ne_of_lt hpp.one_lt) hdm'
+        have hψx''notmin : ¬ ((minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).map
+            ψ₁).IsRoot (ψ₁ (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)) := by
+          intro hcon
+          rw [Polynomial.IsRoot, Polynomial.eval_map, Polynomial.eval₂_hom] at hcon
+          exact hx''notmin ((injective_iff_map_eq_zero ψ₁).mp (RingHom.injective ψ₁) _ hcon)
+        have htarget_ne : sv K ζ a b ≠ ψ₁ (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a *
+          d'')⟯) :=
+          by
+          intro hcon
+          have hroot'' : ((minpoly K⟮jqModC K⟯ (jqNModC K m'')).map ((qExpand K M).comp
+              (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))).IsRoot
+              (ψ₁ (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)) := by
+            have h1 : Polynomial.aeval
+                (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)
+                (minpoly K⟮jqModC K⟯ (jqNModC K m'')) = 0 := by
+              refine aeval_intermediateField_eq_zero ?_
+              change Polynomial.aeval (jqNModC K m'') (minpoly K⟮jqModC K⟯ (jqNModC K m'')) = 0
+              exact minpoly.aeval _ _
+            have h2 := ringHom_comp_aeval ψ₁ ((qExpand K M).comp
+              (algebraMap K⟮jqModC K⟯ (LaurentSeries K))) hψcomp
+              (minpoly K⟮jqModC K⟯ (jqNModC K m''))
+              (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)
+            rw [h1, map_zero] at h2
+            exact h2.symm
+          have hζ'' : IsPrimitiveRoot ((ζ ^ (p * p) : Kˣ) : K) m'' := by
+            have h1 := isPrimitiveRoot_pow_div hζ hm''M
+            have h2 : M / m'' = p * p := by
+              rw [hMM', hm'', show p * m'' * p = m'' * (p * p) from by ring]
+              exact Nat.mul_div_cancel_left _ (Nat.pos_of_ne_zero hm''0)
+            rwa [h2] at h1
+          have hIH'' := IH m'' hm''lt (ζ ^ (p * p)) hζ''
+            (fun e he'' _ => hall e (he''.trans hm''M))
+          have hIHM'' := map_qExpand_minpoly_eq (p * p)
+            (show M = p * p * m'' from by rw [hMM', hm'']; ring) (ζ ^ (p * p)) hIH''
+          rw [hIHM''] at hroot''
+          rw [Polynomial.IsRoot, Polynomial.eval_prod] at hroot''
+          obtain ⟨α, hαmem, hα0⟩ := Finset.prod_eq_zero_iff.mp hroot''
+          rw [Polynomial.eval_prod] at hα0
+          obtain ⟨β, hβmem, hβ0⟩ := Finset.prod_eq_zero_iff.mp hα0
+          rw [Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, sub_eq_zero] at hβ0
+          obtain ⟨hαdvd, -⟩ := Nat.mem_divisors.mp hαmem
+          obtain ⟨hβr, -⟩ := Finset.mem_filter.mp hβmem
+          rw [Finset.mem_range] at hβr
+          have hα0' : α ≠ 0 := by
+            rintro rfl
+            exact hm''0 (Nat.eq_zero_of_zero_dvd hαdvd)
+          have : NeZero α := ⟨hα0'⟩
+          have hcoll : TS K (a * a) (ζ ^ (b * a))
+              = TS K (p * p * (α * α)) (ζ ^ (p * p * (β * α))) := by
+            calc TS K (a * a) (ζ ^ (b * a)) = sv K ζ a b := (sv_eq_TS ζ a b).symm
+              _ = ψ₁ (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯) := hcon
+              _ = qExpand K (p * p) (sv K (ζ ^ (p * p)) α β) := hβ0
+              _ = qExpand K (p * p) (TS K (α * α) ((ζ ^ (p * p)) ^ (β * α))) := by
+                  rw [sv_eq_TS]
+              _ = TS K (p * p * (α * α)) ((ζ ^ (p * p)) ^ (β * α)) := qExpand_TS _ _ _
+              _ = TS K (p * p * (α * α)) (ζ ^ (p * p * (β * α))) :=
+                  TS_congr' rfl (by rw [← pow_mul])
+          obtain ⟨hexp, hunit⟩ := TS_injective hcoll
+          have haα : a = p * α := by
+            have h2 : a * a = (p * α) * (p * α) := by rw [hexp]; ring
+            exact (mul_self_inj (Nat.zero_le _) (Nat.zero_le _)).mp h2
+          have hpa : p ∣ a := ⟨α, haα⟩
+          have hba : b * a < M := by
+            calc b * a < M / a * a :=
+                (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr
+              _ = M := by rw [Nat.mul_comm] at had; exact had
+          have hppβα : p * p * (β * α) < M := by
+            have h1 : β * α < m'' := by
+              calc β * α < m'' / α * α :=
+                  (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero hα0')).mpr hβr
+                _ ≤ m'' := Nat.div_mul_le_self m'' α
+            calc p * p * (β * α) < p * p * m'' :=
+                (Nat.mul_lt_mul_left (Nat.mul_pos hpp.pos hpp.pos)).mpr h1
+              _ = M := by rw [hMM', hm'']; ring
+          have hvv : ((ζ : K)) ^ (b * a) = ((ζ : K)) ^ (p * p * (β * α)) := by
+            have h1 := congrArg Units.val hunit
+            rwa [Units.val_pow_eq_pow_val, Units.val_pow_eq_pow_val] at h1
+          have hexp2 : b * a = p * p * (β * α) := hζ.pow_inj hba hppβα hvv
+          have hpb : p ∣ b := by
+            refine ⟨β, ?_⟩
+            rw [haα] at hexp2
+            have h1 : b * (p * α) = p * β * (p * α) := by
+              rw [hexp2]
+              ring
+            exact Nat.eq_of_mul_eq_mul_right (Nat.mul_pos hpp.pos
+              (Nat.pos_of_ne_zero hα0')) h1
+          have hfinal : p ∣ Nat.gcd (Nat.gcd a b) (M / a) :=
+            Nat.dvd_gcd (Nat.dvd_gcd hpa hpb) ⟨d'', hdd⟩
+          rw [hbc] at hfinal
+          exact hpp.ne_one (Nat.dvd_one.mp hfinal)
+        have hQ : (Polynomial.X - Polynomial.C (ψ₁ (⟨jqNModC K m'', hmem''⟩ :
+            K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯))) * (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b %
+              d''))) /ₘ
+            (Polynomial.X - Polynomial.C (ψ₁ (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a *
+              d'')⟯))))
+            = phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) :=
+          Polynomial.mul_divByMonic_eq_iff_isRoot.mpr hψx''
+        have hΦmonic : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d'')))).Monic :=
+          phiAtSeed_monic dp _
+        have hQmonic : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+            (Polynomial.X - Polynomial.C (ψ₁ (⟨jqNModC K m'', hmem''⟩ :
+              K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)))).Monic :=
+          Polynomial.Monic.of_mul_monic_left (Polynomial.monic_X_sub_C _)
+            (by rw [hQ]; exact hΦmonic)
+        have hΦdeg : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d'')))).natDegree
+            = p + 1 := by
+          rw [phiAtSeed_natDegree]
+          exact dedekindPsi_prime p hpp
+        have hQdeg : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+            (Polynomial.X - Polynomial.C (ψ₁ (⟨jqNModC K m'', hmem''⟩ :
+              K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)))).natDegree = p := by
+          have h1 : p + 1 = 1 + (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+              (Polynomial.X - Polynomial.C (ψ₁ (⟨jqNModC K m'', hmem''⟩ :
+                K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)))).natDegree := by
+            rw [← hΦdeg]
+            conv_lhs => rw [← hQ]
+            rw [Polynomial.natDegree_mul (Polynomial.X_sub_C_ne_zero _) hQmonic.ne_zero,
+              Polynomial.natDegree_X_sub_C]
+          omega
+        have hP₁dvd : (minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).map
+            ψ₁
+            ∣ phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) := by
+          have h1 := Polynomial.map_dvd ψ₁ hmindvd
+          rwa [phiAtSeed_map, show ψ₁
+            (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K (a * d'')))
+            = qExpand K p (sv K (ζ ^ p) a (b % d'')) from hψ₁] at h1
+        have hcop : IsCoprime (Polynomial.X - Polynomial.C (ψ₁ (⟨jqNModC K m'', hmem''⟩ :
+            K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)))
+            ((minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).map
+              ψ₁) := by
+          rw [(Polynomial.irreducible_X_sub_C _).coprime_iff_not_dvd]
+          intro hcon
+          exact hψx''notmin (Polynomial.dvd_iff_isRoot.mp hcon)
+        have hP₁dvdQ : (minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).map
+            ψ₁
+            ∣ phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+              (Polynomial.X - Polynomial.C (ψ₁ (⟨jqNModC K m'', hmem''⟩ :
+                K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯))) := by
+          have h1 := hP₁dvd
+          rw [← hQ] at h1
+          exact (hcop.symm).dvd_of_dvd_mul_left h1
+        have hdeg₁ : ((minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).map
+            ψ₁).natDegree = p := by
+          rw [Polynomial.Monic.natDegree_map (minpoly.monic hα₁),
+            ← IntermediateField.adjoin.finrank hα₁]
+          exact he
+        have hmineqQ : (minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).map
+            ψ₁
+            = phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+              (Polynomial.X - Polynomial.C (ψ₁ (⟨jqNModC K m'', hmem''⟩ :
+                K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯))) :=
+          Polynomial.eq_of_monic_of_dvd_of_natDegree_le ((minpoly.monic hα₁).map _)
+            hQmonic hP₁dvdQ (le_of_eq (hQdeg.trans hdeg₁.symm)) |>.symm
+        have htargetΦ : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d'')))).IsRoot
+            (sv K ζ a b) := by
+          rw [hΦfact, Polynomial.IsRoot, Polynomial.eval_mul]
+          refine mul_eq_zero.mpr (Or.inr ?_)
+          rw [Polynomial.eval_prod]
+          refine Finset.prod_eq_zero (Finset.mem_range.mpr hc₀p) ?_
+          rw [htarget, Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, sub_self]
+        have hroot_step : ((minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).map
+            ψ₁).IsRoot (sv K ζ a b) := by
+          rw [hmineqQ, Polynomial.IsRoot]
+          have h1 : ((Polynomial.X - Polynomial.C (ψ₁ (⟨jqNModC K m'', hmem''⟩ :
+              K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯))) * (phiAtSeed dp (qExpand K p
+              (sv K (ζ ^ p) a (b % d''))) /ₘ (Polynomial.X - Polynomial.C
+              (ψ₁ (⟨jqNModC K m'', hmem''⟩ : K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯))))).eval (sv K ζ a b)
+                = 0 := by
+            rw [hQ]
+            exact htargetΦ
+          rw [Polynomial.eval_mul, Polynomial.eval_sub, Polynomial.eval_X,
+            Polynomial.eval_C] at h1
+          rcases mul_eq_zero.mp h1 with h2 | h2
+          · exact absurd (sub_eq_zero.mp h2) htarget_ne
+          · exact h2
+        have htowdvd : minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)
+            ∣ (minpoly K⟮jqModC K⟯ (jqNModC K M)).map (algebraMap K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K
+              (a * d'')⟯) :=
+          minpoly.dvd_map_of_isScalarTower K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K
+            M)
+        have h1 := Polynomial.map_dvd ψ₁ htowdvd
+        rw [Polynomial.map_map] at h1
+        have h2 : ψ₁.comp (algebraMap K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)
+            = (qExpand K M).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K)) := hψcomp
+        rw [h2] at h1
+        exact Polynomial.eval_eq_zero_of_dvd_of_eval_eq_zero h1 hroot_step
+      · have hψM : dedekindPsi M = dedekindPsi (a * d'') * (p + 1) := by
+          rw [hMM']
+          exact dedekindPsi_mul_prime_not_dvd hpp hpM'
+        have he : Module.finrank K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ K⟮jqModC K⟯⟮jqNModC K (a *
+          d'')⟯⟮jqNModC K M⟯
+            = p + 1 := by
+          have h1 : Module.finrank K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ K⟮jqModC K⟯⟮jqNModC K (a *
+            d'')⟯⟮jqNModC K M⟯
+              * dedekindPsi (a * d'') = (p + 1) * dedekindPsi (a * d'') := by
+            rw [hstep_deg, hψM]
+            ring
+          exact Nat.eq_of_mul_eq_mul_right (dedekindPsi_pos hM'0) h1
+        have hdeg₁ : (minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).natDegree = p + 1 :=
+          by
+          rw [← IntermediateField.adjoin.finrank hα₁]
+          exact he
+        have hΦdeg : (phiAtSeed dp (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯
+            (jqNModC K (a * d'')))).natDegree = p + 1 := by
+          rw [phiAtSeed_natDegree]
+          exact dedekindPsi_prime p hpp
+        have hmineq : minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)
+            = phiAtSeed dp (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K (a * d''))) :=
+          Polynomial.eq_of_monic_of_dvd_of_natDegree_le (minpoly.monic hα₁)
+            (phiAtSeed_monic dp _) hmindvd (le_of_eq (hΦdeg.trans hdeg₁.symm)) |>.symm
+        have hroot_step : ((minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)).map
+            ψ₁).IsRoot (sv K ζ a b) := by
+          rw [hmineq, phiAtSeed_map, show ψ₁
+            (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K (a * d'')))
+            = qExpand K p (sv K (ζ ^ p) a (b % d'')) from hψ₁]
+          rw [hΦfact, Polynomial.IsRoot, Polynomial.eval_mul]
+          refine mul_eq_zero.mpr (Or.inr ?_)
+          rw [Polynomial.eval_prod]
+          refine Finset.prod_eq_zero (Finset.mem_range.mpr hc₀p) ?_
+          rw [htarget, Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, sub_self]
+        have htowdvd : minpoly K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K M)
+            ∣ (minpoly K⟮jqModC K⟯ (jqNModC K M)).map (algebraMap K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K
+              (a * d'')⟯) :=
+          minpoly.dvd_map_of_isScalarTower K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯ (jqNModC K
+            M)
+        have h1 := Polynomial.map_dvd ψ₁ htowdvd
+        rw [Polynomial.map_map] at h1
+        have h2 : ψ₁.comp (algebraMap K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K (a * d'')⟯)
+            = (qExpand K M).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K)) := hψcomp
+        rw [h2] at h1
+        exact Polynomial.eval_eq_zero_of_dvd_of_eval_eq_zero h1 hroot_step
+  by_cases hM1 : M = 1
+  · subst hM1
+    have hjq1 : jqNModC K 1 = algebraMap K⟮jqModC K⟯ (LaurentSeries K) jGenC := by
+      rw [jqNModC_one]
+      rfl
+    have hmin : minpoly K⟮jqModC K⟯ (jqNModC K 1) = Polynomial.X - Polynomial.C jGenC := by
+      rw [hjq1]
+      exact minpoly.eq_X_sub_C (B := LaurentSeries K) jGenC
+    have hfil : (Finset.range (1 / 1)).filter
+        (fun b => Nat.gcd (Nat.gcd 1 b) (1 / 1) = 1) = {0} := by decide
+    rw [hmin, Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C, Nat.divisors_one,
+      Finset.prod_singleton, hfil, Finset.prod_singleton]
+    congr 1
+    have h1 : ((qExpand K 1).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K))) jGenC = jqModC K := by
+      simp only [RingHom.comp_apply]
+      rw [show (algebraMap K⟮jqModC K⟯ (LaurentSeries K)) jGenC = jqModC K from rfl,
+        qExpand_one_apply]
+    rw [h1]
+    have : NeZero (1 : ℕ) := ⟨one_ne_zero⟩
+    have h2 : sv K ζ 1 0 = jqModC K := by
+      rw [sv_eq_TS]
+      have h3 : TS K (1 * 1) (ζ ^ (0 * 1)) = TS K 1 1 :=
+        TS_congr' (Nat.mul_one 1) (by rw [Nat.zero_mul, pow_zero])
+      rw [h3, TS, qTwist_one_apply, qExpand_one_apply]
+    rw [h2]
+  · obtain ⟨htM, -⟩ := hall M dvd_rfl
+    have hfd : FiniteDimensional K⟮jqModC K⟯
+        (IntermediateField.adjoin K⟮jqModC K⟯ ({jqNModC K M} : Set (LaurentSeries K))) :=
+      FiniteDimensional.of_finrank_pos (htM ▸ dedekindPsi_pos hM0)
+    have hα : IsIntegral K⟮jqModC K⟯ (jqNModC K M) :=
+      IntermediateField.isIntegral_iff.mp (IsIntegral.of_finite K⟮jqModC K⟯
+        (⟨jqNModC K M, IntermediateField.subset_adjoin K⟮jqModC K⟯ _ rfl⟩ :
+          IntermediateField.adjoin K⟮jqModC K⟯ ({jqNModC K M} : Set (LaurentSeries K))))
+    have hdeg : (minpoly K⟮jqModC K⟯ (jqNModC K M)).natDegree = dedekindPsi M := by
+      rw [← IntermediateField.adjoin.finrank hα]
+      exact htM
+    set T : Multiset (LaurentSeries K) := M.divisors.val.bind
+      (fun a => ((Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map (fun b => sv K ζ a b)) with hT
+    have hTcard : Multiset.card T = dedekindPsi M := by
+      rw [hT, Multiset.card_bind]
+      have h2 : M.divisors.val.map (Multiset.card ∘ fun a => (((Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map (fun b => sv K ζ a b)))
+          = M.divisors.val.map (fun a => slotAt M (M / a)) := by
+        refine Multiset.map_congr rfl ?_
+        intro a ha
+        change Multiset.card (((Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map (fun b => sv K ζ a b))
+          = slotAt M (M / a)
+        rw [Multiset.card_map]
+        change ((Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).card = slotAt M (M / a)
+        unfold slotAt
+        rw [Nat.div_div_self (Nat.mem_divisors.mp (Finset.mem_val.mp ha)).1 hM0]
+      rw [h2]
+      change (∑ a ∈ M.divisors, slotAt M (M / a)) = dedekindPsi M
+      rw [Nat.sum_div_divisors M (slotAt M)]
+      exact slots_eq_dedekindPsi M hM0
+    have hmem_unpack : ∀ x ∈ T, ∃ a b : ℕ, a ∈ M.divisors ∧
+        b ∈ (Finset.range (M / a)).filter (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1) ∧
+        x = sv K ζ a b := by
+      intro x hx
+      rw [hT, Multiset.mem_bind] at hx
+      obtain ⟨a, ha, hx2⟩ := hx
+      rw [Multiset.mem_map] at hx2
+      obtain ⟨b, hb, rfl⟩ := hx2
+      exact ⟨a, b, ha, hb, rfl⟩
+    have hTnodup : T.Nodup := by
+      rw [hT]
+      rw [Multiset.nodup_bind]
+      constructor
+      · intro a ha
+        refine Multiset.Nodup.map_on ?_ (Finset.filter _ _).nodup
+        intro b hb b' hb' hvv
+        have ha0 : a ≠ 0 := by
+          rintro rfl
+          exact hM0 (Nat.eq_zero_of_zero_dvd (Nat.mem_divisors.mp (by exact ha)).1)
+        have hbr := Finset.mem_range.mp (Finset.mem_filter.mp (by exact hb)).1
+        have hbr' := Finset.mem_range.mp (Finset.mem_filter.mp (by exact hb')).1
+        have haM := (Nat.mem_divisors.mp (by exact ha)).1
+        have had : M / a * a = M := Nat.div_mul_cancel haM
+        have hba : b * a < M := by
+          calc b * a < M / a * a :=
+              (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr
+            _ = M := had
+        have hba' : b' * a < M := by
+          calc b' * a < M / a * a :=
+              (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr'
+            _ = M := had
+        exact (sv_inj hζ ha0 ha0 hba hba' hvv).2
+      · refine Multiset.Nodup.pairwise ?_ M.divisors.nodup
+        intro a ha a' ha' hne
+        change Disjoint (((Finset.range (M / a)).filter
+            (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map (fun b => sv K ζ a b))
+          (((Finset.range (M / a')).filter
+            (fun b => Nat.gcd (Nat.gcd a' b) (M / a') = 1)).val.map (fun b => sv K ζ a' b))
+        rw [Multiset.disjoint_left]
+        intro x hx hx'
+        rw [Multiset.mem_map] at hx hx'
+        obtain ⟨b, hb, hxb⟩ := hx
+        obtain ⟨b', hb', hxb'⟩ := hx'
+        have haM := (Nat.mem_divisors.mp (Finset.mem_val.mp ha)).1
+        have haM' := (Nat.mem_divisors.mp (Finset.mem_val.mp ha')).1
+        have ha0 : a ≠ 0 := by
+          rintro rfl
+          exact hM0 (Nat.eq_zero_of_zero_dvd haM)
+        have ha0' : a' ≠ 0 := by
+          rintro rfl
+          exact hM0 (Nat.eq_zero_of_zero_dvd haM')
+        have hbr := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb)).1
+        have hbr' := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb')).1
+        have hba : b * a < M := by
+          calc b * a < M / a * a :=
+              (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr
+            _ = M := Nat.div_mul_cancel haM
+        have hba' : b' * a' < M := by
+          calc b' * a' < M / a' * a' :=
+              (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0')).mpr hbr'
+            _ = M := Nat.div_mul_cancel haM'
+        have hvv : sv K ζ a b = sv K ζ a' b' := by rw [hxb, ← hxb']
+        exact hne (sv_inj hζ ha0 ha0' hba hba' hvv).1
+    have hPne : (minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K M).comp (algebraMap K⟮jqModC K⟯
+      (LaurentSeries K))) ≠ 0 :=
+      ((minpoly.monic hα).map _).ne_zero
+    have hPdeg : ((minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K M).comp (algebraMap K⟮jqModC
+      K⟯ (LaurentSeries K)))).natDegree = dedekindPsi M :=
+      by
+      rw [Polynomial.Monic.natDegree_map (minpoly.monic hα)]
+      exact hdeg
+    have hTle : T ≤ ((minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K M).comp (algebraMap
+      K⟮jqModC K⟯ (LaurentSeries K)))).roots :=
+      by
+      rw [Multiset.le_iff_count]
+      intro x
+      by_cases hx : x ∈ T
+      · have h1 : Multiset.count x T ≤ 1 := Multiset.nodup_iff_count_le_one.mp hTnodup x
+        have h2 : 1 ≤ Multiset.count x (((minpoly K⟮jqModC K⟯ (jqNModC K M)).map
+            ((qExpand K M).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))).roots) := by
+          rw [Multiset.one_le_count_iff_mem, Polynomial.mem_roots']
+          obtain ⟨a, b, ha, hb, rfl⟩ := hmem_unpack x hx
+          exact ⟨hPne, hslot_root a b ha hb⟩
+        omega
+      · rw [Multiset.count_eq_zero.mpr hx]
+        exact Nat.zero_le _
+    have hroots_eq : ((minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K M).comp (algebraMap
+      K⟮jqModC K⟯ (LaurentSeries K)))).roots = T :=
+      by
+      refine (Multiset.eq_of_le_of_card_le hTle ?_).symm
+      rw [hTcard]
+      calc Multiset.card (((minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K M).comp (algebraMap
+        K⟮jqModC K⟯ (LaurentSeries K)))).roots)
+          ≤ ((minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K M).comp (algebraMap K⟮jqModC K⟯
+            (LaurentSeries K)))).natDegree := Polynomial.card_roots' _
+        _ = dedekindPsi M := hPdeg
+    have hsp : Polynomial.Splits ((minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K M).comp
+      (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))) :=
+      by
+      rw [Polynomial.splits_iff_card_roots, hroots_eq, hTcard, hPdeg]
+    have hfact := hsp.eq_prod_roots_of_monic ((minpoly.monic hα).map _)
+    rw [hfact, hroots_eq, hT, Multiset.map_bind, Multiset.prod_bind]
+    change (M.divisors.val.map fun a => ((((Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+        (fun b => sv K ζ a b)).map (fun r => Polynomial.X - Polynomial.C r)).prod).prod
+      = ∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+          (Polynomial.X - Polynomial.C (sv K ζ a b))
+    simp only [Multiset.map_map, Function.comp]
+    rfl
+
+end RValCore
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData jqd_mem_full \
+  coeffMap coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one map_jqModC modularFunctionFieldC \
+  coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime"
+
+section NonMem0
+
+open IntermediateField
+
+variable {K : Type*} [Field K]
+
+private theorem jqNModC_prime_not_mem_adjoin (M : ℕ) [NeZero M] (p : ℕ)
+    [hp : Fact (Nat.Prime p)] (hpM : ¬ p ∣ M) (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot ((ζ : Kˣ) : K) (M * p))
+    (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank K⟮jqModC K⟯
+          (IntermediateField.adjoin K⟮jqModC K⟯
+            ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d
+        ∧ modularFunctionFieldC K d = IntermediateField.adjoin K
+            {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ d ∧ x = jqNModC K d'})
+    (hbase : jqNModC K p ∉ K⟮jqModC K⟯) :
+    jqNModC K p ∉ IntermediateField.adjoin K⟮jqModC K⟯
+      ({jqNModC K M} : Set (LaurentSeries K)) := by
+  classical
+  intro hmem
+  have hM0 : M ≠ 0 := NeZero.ne M
+  have hp0 : p ≠ 0 := hp.out.ne_zero
+  have : NeZero p := ⟨hp0⟩
+  have : NeZero (M * p) := ⟨Nat.mul_ne_zero hM0 hp0⟩
+  have hζM : IsPrimitiveRoot ((ζ ^ p : Kˣ) : K) M := by
+    have h1 := isPrimitiveRoot_pow_div hζ (⟨p, rfl⟩ : M ∣ M * p)
+    have h2 : M * p / M = p := Nat.mul_div_cancel_left p (Nat.pos_of_ne_zero hM0)
+    rwa [h2] at h1
+  have hζp : IsPrimitiveRoot ((ζ ^ M : Kˣ) : K) p := by
+    have h1 := isPrimitiveRoot_pow_div hζ (⟨M, Nat.mul_comm M p⟩ : p ∣ M * p)
+    have h2 : M * p / p = M := Nat.mul_div_cancel M (Nat.pos_of_ne_zero hp0)
+    rwa [h2] at h1
+  obtain ⟨htM, -⟩ := hall M dvd_rfl
+  have hfd : FiniteDimensional K⟮jqModC K⟯
+      (IntermediateField.adjoin K⟮jqModC K⟯ ({jqNModC K M} : Set (LaurentSeries K))) :=
+    FiniteDimensional.of_finrank_pos (htM ▸ dedekindPsi_pos hM0)
+  have hα : IsIntegral K⟮jqModC K⟯ (jqNModC K M) :=
+    IntermediateField.isIntegral_iff.mp (IsIntegral.of_finite K⟮jqModC K⟯
+      (⟨jqNModC K M, IntermediateField.subset_adjoin K⟮jqModC K⟯ _ rfl⟩ :
+        IntermediateField.adjoin K⟮jqModC K⟯ ({jqNModC K M} : Set (LaurentSeries K))))
+  have hdeg : (minpoly K⟮jqModC K⟯ (jqNModC K M)).natDegree = dedekindPsi M := by
+    rw [← IntermediateField.adjoin.finrank hα]
+    exact htM
+  have hidMB := map_qExpand_minpoly_eq p (Nat.mul_comm M p) (ζ ^ p)
+    (rval_aux M (ζ ^ p) hζM hall)
+  have hιS : ∀ w : LaurentSeries K, qExpand K (M * p) w = qExpand K p (qExpand K M w) := by
+    intro w
+    rw [qExpand_qExpand]
+    exact qExpand_congr (Nat.mul_comm M p) w
+  set T' : Multiset (LaurentSeries K) := M.divisors.val.bind
+    (fun a => ((Finset.range (M / a)).filter
+      (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+      (fun b => qExpand K p (sv K (ζ ^ p) a b))) with hT'
+  have hT'card : Multiset.card T' = dedekindPsi M := by
+    rw [hT', Multiset.card_bind]
+    have h2 : M.divisors.val.map (Multiset.card ∘ fun a => (((Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+        (fun b => qExpand K p (sv K (ζ ^ p) a b))))
+        = M.divisors.val.map (fun a => slotAt M (M / a)) := by
+      refine Multiset.map_congr rfl ?_
+      intro a ha
+      change Multiset.card (((Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+        (fun b => qExpand K p (sv K (ζ ^ p) a b)))
+        = slotAt M (M / a)
+      rw [Multiset.card_map]
+      change ((Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).card = slotAt M (M / a)
+      unfold slotAt
+      rw [Nat.div_div_self (Nat.mem_divisors.mp (Finset.mem_val.mp ha)).1 hM0]
+    rw [h2]
+    change (∑ a ∈ M.divisors, slotAt M (M / a)) = dedekindPsi M
+    rw [Nat.sum_div_divisors M (slotAt M)]
+    exact slots_eq_dedekindPsi M hM0
+  have hT'nodup : T'.Nodup := by
+    rw [hT', Multiset.nodup_bind]
+    constructor
+    · intro a ha
+      refine Multiset.Nodup.map_on ?_ (Finset.filter _ _).nodup
+      intro b hb b' hb' hvv
+      have haM := (Nat.mem_divisors.mp (Finset.mem_val.mp ha)).1
+      have ha0 : a ≠ 0 := by
+        rintro rfl
+        exact hM0 (Nat.eq_zero_of_zero_dvd haM)
+      have hbr := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb)).1
+      have hbr' := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb')).1
+      have hba : b * a < M := by
+        calc b * a < M / a * a :=
+            (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr
+          _ = M := Nat.div_mul_cancel haM
+      have hba' : b' * a < M := by
+        calc b' * a < M / a * a :=
+            (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr'
+          _ = M := Nat.div_mul_cancel haM
+      have hsv : sv K (ζ ^ p) a b
+          = sv K (ζ ^ p) a b' :=
+        RingHom.injective (qExpand K p) hvv
+      exact (sv_inj hζM ha0 ha0 hba hba' hsv).2
+    · refine Multiset.Nodup.pairwise ?_ M.divisors.nodup
+      intro a ha a' ha' hne
+      change Disjoint (((Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+          (fun b => qExpand K p (sv K (ζ ^ p) a b)))
+        (((Finset.range (M / a')).filter
+          (fun b => Nat.gcd (Nat.gcd a' b) (M / a') = 1)).val.map
+          (fun b => qExpand K p (sv K (ζ ^ p) a' b)))
+      rw [Multiset.disjoint_left]
+      intro x hx hx'
+      rw [Multiset.mem_map] at hx hx'
+      obtain ⟨b, hb, hxb⟩ := hx
+      obtain ⟨b', hb', hxb'⟩ := hx'
+      have haM := (Nat.mem_divisors.mp (Finset.mem_val.mp ha)).1
+      have haM' := (Nat.mem_divisors.mp (Finset.mem_val.mp ha')).1
+      have ha0 : a ≠ 0 := by
+        rintro rfl
+        exact hM0 (Nat.eq_zero_of_zero_dvd haM)
+      have ha0' : a' ≠ 0 := by
+        rintro rfl
+        exact hM0 (Nat.eq_zero_of_zero_dvd haM')
+      have hbr := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb)).1
+      have hbr' := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb')).1
+      have hba : b * a < M := by
+        calc b * a < M / a * a :=
+            (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr
+          _ = M := Nat.div_mul_cancel haM
+      have hba' : b' * a' < M := by
+        calc b' * a' < M / a' * a' :=
+            (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0')).mpr hbr'
+          _ = M := Nat.div_mul_cancel haM'
+      have hvv : qExpand K p (sv K (ζ ^ p) a b)
+          = qExpand K p (sv K (ζ ^ p) a' b') := by
+        rw [hxb, ← hxb']
+      exact hne (sv_inj hζM ha0 ha0' hba hba'
+        (RingHom.injective (qExpand K p) hvv)).1
+  have hglue : ∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+      (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+      (Polynomial.X - Polynomial.C (qExpand K p (sv K (ζ ^ p) a b)))
+      = (T'.map (fun r => Polynomial.X - Polynomial.C r)).prod := by
+    rw [hT', Multiset.map_bind, Multiset.prod_bind]
+    change (∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+        (Polynomial.X - Polynomial.C (qExpand K p
+          (sv K (ζ ^ p) a b))))
+      = (M.divisors.val.map fun a => ((((Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+          (fun b => qExpand K p (sv K (ζ ^ p) a b))).map
+          (fun r => Polynomial.X - Polynomial.C r)).prod).prod
+    simp only [Multiset.map_map, Function.comp]
+    rfl
+  have hroots : ((minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K (M * p)).comp (algebraMap
+    K⟮jqModC K⟯ (LaurentSeries K)))).roots = T' :=
+    by
+    rw [hidMB, hglue]
+    exact Polynomial.roots_multiset_prod_X_sub_C T'
+  set s : Finset (LaurentSeries K) := T'.toFinset with hs
+  have hscard : s.card = dedekindPsi M := by
+    rw [hs, Multiset.toFinset_card_of_nodup hT'nodup]
+    exact hT'card
+  obtain ⟨g, hg⟩ : ∃ g : Polynomial K⟮jqModC K⟯, Polynomial.aeval (jqNModC K M) g = jqNModC K p :=
+    by
+    have h1 := IntermediateField.adjoin_simple_toSubalgebra_of_isAlgebraic
+      hα.isAlgebraic
+    have h2 : jqNModC K p ∈ Algebra.adjoin K⟮jqModC K⟯ ({jqNModC K M} : Set (LaurentSeries K)) := by
+      rw [← h1]
+      exact hmem
+    rw [Algebra.adjoin_singleton_eq_range_aeval] at h2
+    obtain ⟨g, hg⟩ := h2
+    exact ⟨g, hg⟩
+  set g' := g %ₘ (minpoly K⟮jqModC K⟯ (jqNModC K M)) with hg'def
+  have hg' : Polynomial.aeval (jqNModC K M) g' = jqNModC K p := by
+    have hsplit := Polynomial.modByMonic_add_div g (minpoly K⟮jqModC K⟯ (jqNModC K M))
+    have h4 := congrArg (Polynomial.aeval (jqNModC K M)) hsplit
+    rw [map_add, map_mul, minpoly.aeval, zero_mul, add_zero] at h4
+    rw [hg'def, h4]
+    exact hg
+  have hdegpos : 0 < (minpoly K⟮jqModC K⟯ (jqNModC K M)).natDegree := by
+    rw [hdeg]
+    exact dedekindPsi_pos hM0
+  have hg'deg : g'.natDegree < s.card := by
+    rw [hscard, ← hdeg]
+    rcases eq_or_ne g' 0 with h0 | h0
+    · rw [h0, Polynomial.natDegree_zero]
+      exact hdegpos
+    · exact Polynomial.natDegree_lt_natDegree h0
+        (Polynomial.degree_modByMonic_lt g (minpoly.monic hα))
+  have hPne : (minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K (M * p)).comp
+      (algebraMap K⟮jqModC K⟯ (LaurentSeries K))) ≠ 0 :=
+    ((minpoly.monic hα).map _).ne_zero
+  have hval : ∀ y ∈ s, (g'.map ((qExpand K (M * p)).comp
+      (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))).eval y
+      = qExpand K (M * p) (jqNModC K p) := by
+    intro y hy
+    have hyT' : y ∈ T' := Multiset.mem_toFinset.mp hy
+    obtain ⟨a₀, ha₀, hy2⟩ := Multiset.mem_bind.mp hyT'
+    obtain ⟨b₀, hb₀, hyval⟩ := Multiset.mem_map.mp hy2
+    have hyS : y ∈ (qExpand K p).fieldRange := by
+      rw [← hyval]
+      exact RingHom.mem_fieldRange.mpr ⟨sv K (ζ ^ p) a₀ b₀, rfl⟩
+    have hy_root : ((minpoly K⟮jqModC K⟯ (jqNModC K M)).map ((qExpand K (M * p)).comp
+        (algebraMap K⟮jqModC K⟯ (LaurentSeries K)))).IsRoot y :=
+      (Polynomial.mem_roots hPne).mp (by rw [hroots]; exact hyT')
+    obtain ⟨ψy, hψycomp, hψygen⟩ := exists_ringHom_adjoin_of_isRoot hα
+      ((qExpand K (M * p)).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K))) hy_root
+    have hψgen : ∀ h : jqNModC K M ∈ IntermediateField.adjoin K⟮jqModC K⟯
+        ({jqNModC K M} : Set (LaurentSeries K)), ψy ⟨jqNModC K M, h⟩ = y := by
+      intro h
+      exact hψygen
+    have himg : ∀ (x : LaurentSeries K)
+        (hx : x ∈ IntermediateField.adjoin K⟮jqModC K⟯ ({jqNModC K M} : Set (LaurentSeries K))),
+        ψy ⟨x, hx⟩ ∈ (qExpand K p).fieldRange := by
+      intro x hx
+      induction hx using IntermediateField.adjoin_induction with
+      | mem z hz =>
+          rw [Set.mem_singleton_iff] at hz
+          subst hz
+          rw [hψgen]
+          exact hyS
+      | algebraMap z =>
+          change ψy (algebraMap K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K M⟯ z) ∈ (qExpand K p).fieldRange
+          have h1 : ψy (algebraMap K⟮jqModC K⟯ K⟮jqModC K⟯⟮jqNModC K M⟯ z)
+              = qExpand K (M * p) ((algebraMap K⟮jqModC K⟯ (LaurentSeries K)) z) := by
+            rw [← RingHom.comp_apply, hψycomp, RingHom.comp_apply]
+          rw [h1, hιS]
+          exact RingHom.mem_fieldRange.mpr ⟨_, rfl⟩
+      | add x₁ x₂ hx₁ hx₂ ih₁ ih₂ =>
+          change ψy ⟨x₁ + x₂, add_mem hx₁ hx₂⟩ ∈ (qExpand K p).fieldRange
+          rw [show (⟨x₁ + x₂, add_mem hx₁ hx₂⟩ : K⟮jqModC K⟯⟮jqNModC K M⟯)
+            = ⟨x₁, hx₁⟩ + ⟨x₂, hx₂⟩ from rfl, map_add]
+          exact Subfield.add_mem _ ih₁ ih₂
+      | mul x₁ x₂ hx₁ hx₂ ih₁ ih₂ =>
+          change ψy ⟨x₁ * x₂, mul_mem hx₁ hx₂⟩ ∈ (qExpand K p).fieldRange
+          rw [show (⟨x₁ * x₂, mul_mem hx₁ hx₂⟩ : K⟮jqModC K⟯⟮jqNModC K M⟯)
+            = ⟨x₁, hx₁⟩ * ⟨x₂, hx₂⟩ from rfl, map_mul]
+          exact Subfield.mul_mem _ ih₁ ih₂
+      | inv x₁ hx₁ ih₁ =>
+          change ψy ⟨x₁⁻¹, inv_mem hx₁⟩ ∈ (qExpand K p).fieldRange
+          rw [show (⟨x₁⁻¹, inv_mem hx₁⟩ : K⟮jqModC K⟯⟮jqNModC K M⟯)
+            = (⟨x₁, hx₁⟩ : K⟮jqModC K⟯⟮jqNModC K M⟯)⁻¹ from rfl, map_inv₀]
+          exact Subfield.inv_mem _ ih₁
+    have hx_pS : ψy ⟨jqNModC K p, hmem⟩ ∈ (qExpand K p).fieldRange := himg _ hmem
+    obtain ⟨dp, -, -⟩ := ModularCurve.exists_phiIrreducible_evalSymm p
+    have hrel : (phiAtSeed dp (jqModC K)).eval (jqNModC K p) = 0 := by
+      have h1 := phiAtSeed_jqNModC_eval (R := K) p dp 1
+      rwa [jqNModC_one, show jqNModC K (1 * p) = jqNModC K p from jqNModC_congr (one_mul p)] at h1
+    have h1 : Polynomial.aeval (⟨jqNModC K p, hmem⟩ : K⟮jqModC K⟯⟮jqNModC K M⟯)
+        (phiAtSeed dp (jGenC (K := K))) = 0 := by
+      refine aeval_intermediateField_eq_zero ?_
+      change Polynomial.aeval (jqNModC K p) (phiAtSeed dp (jGenC (K := K))) = 0
+      rw [Polynomial.aeval_def, Polynomial.eval₂_eq_eval_map, phiAtSeed_map]
+      exact hrel
+    have hseedC : ((qExpand K (M * p)).comp (algebraMap K⟮jqModC K⟯ (LaurentSeries K))) jGenC
+        = qExpand K (p * M) (qTwist ((1 : Kˣ) ^ p) (jqModC K)) := by
+      rw [RingHom.comp_apply,
+        show (algebraMap K⟮jqModC K⟯ (LaurentSeries K)) jGenC = jqModC K from rfl,
+        one_pow, qTwist_one_apply]
+      exact qExpand_congr (Nat.mul_comm M p) _
+    have h2 : (phiAtSeed dp (qExpand K (p * M) (qTwist ((1 : Kˣ) ^ p) (jqModC K)))).eval
+        (ψy ⟨jqNModC K p, hmem⟩) = 0 := by
+      have h3 := ringHom_comp_aeval ψy ((qExpand K (M * p)).comp
+        (algebraMap K⟮jqModC K⟯ (LaurentSeries K))) hψycomp (phiAtSeed dp jGenC)
+        (⟨jqNModC K p, hmem⟩ : K⟮jqModC K⟯⟮jqNModC K M⟯)
+      rw [h1, map_zero, phiAtSeed_map, hseedC] at h3
+      exact h3.symm
+    have h2' : (dp.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * M) (qTwist ((1 : Kˣ) ^ p) (jqModC K))))).IsRoot
+        (ψy ⟨jqNModC K p, hmem⟩) := h2
+    rcases (isRoot_prime_at_slot_iff p (ζ ^ M) hζp dp M 1 (ψy ⟨jqNModC K p, hmem⟩)).mp h2'
+      with hdist | ⟨b, hb, htw⟩
+    · have hspd : qExpand K (p * (p * M)) (qTwist ((1 : Kˣ) ^ (p * p)) (jqModC K))
+          = qExpand K (M * p) (jqNModC K p) := by
+        rw [one_pow, qTwist_one_apply, qExpand_jqNModC, qExpand_jqModC_eq_TS]
+        exact TS_congr (by ring) 1
+      have hx_pval : ψy ⟨jqNModC K p, hmem⟩ = qExpand K (M * p) (jqNModC K p) := by
+        rw [hdist, hspd]
+      have hgE : Polynomial.aeval (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K M)) g'
+          = (⟨jqNModC K p, hmem⟩ : K⟮jqModC K⟯⟮jqNModC K M⟯) := by
+        have h3 := Polynomial.aeval_algHom_apply (IntermediateField.val K⟮jqModC K⟯⟮jqNModC K M⟯)
+          (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K M)) g'
+        refine Subtype.ext ?_
+        change ((Polynomial.aeval (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K M))
+          g' :
+          K⟮jqModC K⟯⟮jqNModC K M⟯) : LaurentSeries K) = jqNModC K p
+        rw [show ((Polynomial.aeval (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K M))
+          g' :
+          K⟮jqModC K⟯⟮jqNModC K M⟯) : LaurentSeries K)
+          = (IntermediateField.val K⟮jqModC K⟯⟮jqNModC K M⟯)
+            (Polynomial.aeval (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K M)) g')
+          from rfl, ← h3]
+        exact hg'
+      have h4 := ringHom_comp_aeval ψy ((qExpand K (M * p)).comp
+        (algebraMap K⟮jqModC K⟯ (LaurentSeries K))) hψycomp g'
+        (IntermediateField.AdjoinSimple.gen K⟮jqModC K⟯ (jqNModC K M))
+      rw [hgE, hψygen] at h4
+      rw [← h4]
+      exact hx_pval
+    · exfalso
+      obtain ⟨w, hw⟩ := RingHom.mem_fieldRange.mp hx_pS
+      have hw2 : qExpand K p w = TS K M ((ζ ^ M) ^ b) := by
+        rw [hw, htw, one_mul, TS]
+      have hnd : ¬ ((p : ℤ) ∣ (-(M : ℤ))) := by
+        rw [dvd_neg, Int.natCast_dvd_natCast]
+        exact hpM
+      have hz1 : (qExpand K p w).coeff (-(M : ℤ)) = 0 :=
+        qExpand_coeff_of_not_dvd (R := K) (N := p) w hnd
+      have hz2 : (TS K M ((ζ ^ M) ^ b)).coeff (-(M : ℤ))
+          = ((((ζ ^ M) ^ b)⁻¹ : Kˣ) : K) :=
+        TS_coeff_neg M _
+      rw [hw2, hz2] at hz1
+      exact Units.ne_zero _ hz1
+  obtain ⟨z, hz⟩ := mem_range_of_eval_eq_const ((qExpand K (M * p)).comp
+    (algebraMap K⟮jqModC K⟯ (LaurentSeries K))) g' (qExpand K (M * p) (jqNModC K p)) s hg'deg hval
+  have hzval : (algebraMap K⟮jqModC K⟯ (LaurentSeries K)) z = jqNModC K p := by
+    apply RingHom.injective (qExpand K (M * p))
+    rw [← RingHom.comp_apply]
+    exact hz
+  have hjpF : jqNModC K p ∈ K⟮jqModC K⟯ := by
+    rw [← hzval]
+    exact z.2
+  exact hbase hjpF
+
+end NonMem0
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData jqd_mem_full \
+  coeffMap coeffMap_coeff coeffEmb qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist \
+  qTwist_qExpand EvalSymm jqModC jqNModC jqNModC_one map_jqModC modularFunctionFieldC \
+  coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.minpoly_jqNModC_map_eq_prod_slots {K : Type*} [Field K]
+    (M : ℕ) [NeZero M] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) M)
+    (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+          (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries
+            K)))
+            ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d
+        ∧ modularFunctionFieldC K d = IntermediateField.adjoin K
+            {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ d ∧ x = jqNModC K d'}) :
+    (minpoly (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) (jqNModC K M)).map
+        ((qExpand K M).comp
+          (algebraMap (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+            (LaurentSeries K)))
+      = ∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+          (Polynomial.X - Polynomial.C (if h : a = 0 then 0 else
+            letI : NeZero a := ⟨h⟩
+            qExpand K (a * a) (qTwist (ζ ^ (b * a)) (jqModC K)))) :=
+  ModularCurve.W1.rval_aux M ζ hζ hall
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.jqNModC_prime_not_mem_fullC {K : Type*} [Field K] (M : ℕ) [NeZero M]
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpM : ¬ p ∣ M) (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) (M * p))
+    (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+          (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries
+            K)))
+            ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d
+        ∧ modularFunctionFieldC K d = IntermediateField.adjoin K
+            {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ d ∧ x = jqNModC K d'})
+    (hbase : jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) :
+    jqNModC K p ∉ IntermediateField.adjoin K
+      {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ M ∧ x = jqNModC K d'} := by
+  intro hmem0
+  obtain ⟨-, hgM⟩ := hall M dvd_rfl
+  have hmem : jqNModC K p ∈ IntermediateField.adjoin
+      (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+      ({jqNModC K M} : Set (LaurentSeries K)) := by
+    rw [← hgM] at hmem0
+    exact ModularCurve.W1.mem_adjoin_jqNModC_of_mem_mffC hmem0
+  exact ModularCurve.W1.jqNModC_prime_not_mem_adjoin M p hpM ζ hζ hall hbase hmem
+
+end
+
+p2m_open "ModularCurve~dedekindPsi_prime\
+  " in
+open _root_.P2MW.S_ModularCurve_minpoly_jqNModC_map_eq_prod_slots.ModularCurve in
+theorem solution {K : Type*} [Field K]
+    (M : ℕ) [NeZero M] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) M)
+    (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+          (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries
+            K)))
+            ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d
+        ∧ modularFunctionFieldC K d = IntermediateField.adjoin K
+            {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ d ∧ x = jqNModC K d'}) :
+    (minpoly (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) (jqNModC K M)).map
+        ((qExpand K M).comp
+          (algebraMap (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+            (LaurentSeries K)))
+      = ∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+          (Polynomial.X - Polynomial.C (if h : a = 0 then 0 else
+            letI : NeZero a := ⟨h⟩
+            qExpand K (a * a) (qTwist (ζ ^ (b * a)) (jqModC K)))) :=
+  ModularCurve.minpoly_jqNModC_map_eq_prod_slots M ζ hζ hall
+
+end S_ModularCurve_minpoly_jqNModC_map_eq_prod_slots
+end P2MW
+export P2MW.S_ModularCurve_minpoly_jqNModC_map_eq_prod_slots (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.minpoly_jqNModC_map_eq_prod_slots {K : Type*} [Field K]
+    (M : ℕ) [NeZero M] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) M)
+    (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+          (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries
+            K)))
+            ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d
+        ∧ modularFunctionFieldC K d = IntermediateField.adjoin K
+            {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ d ∧ x = jqNModC K d'}) :
+    (minpoly (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) (jqNModC K M)).map
+        ((qExpand K M).comp
+          (algebraMap (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+            (LaurentSeries K)))
+      = ∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+          (Polynomial.X - Polynomial.C (if h : a = 0 then 0 else
+            letI : NeZero a := ⟨h⟩
+            qExpand K (a * a) (qTwist (ζ ^ (b * a)) (jqModC K)))) :=
+  solution M ζ hζ hall
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_minpoly_jqN_eq_toAdjoin.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_minpoly_jqN_eq_toAdjoin.lean
new file mode 100644
index 0000000000..3c6ed55e4b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_minpoly_jqN_eq_toAdjoin.lean
@@ -0,0 +1,117 @@
+/-
+Based on Prove2Me node ModularCurve.minpoly_jqN_eq_toAdjoin
+(3868b11e-4b3e-517f-b111-3561f9579eda) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f1467e70-3d00-583b-b36a-8e71d59aa4f5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Φ_N(j,Y) as minimal polynomial of j(q^N) over ℚ(j)
+
+Theorem statement: `ModularCurve.minpoly_jqN_eq_toAdjoin` (`3868b11e-4b3e-517f-b111-3561f9579eda`),
+by Claude, 2026-09-05.
+
+Proof: submission `f1467e70-3d00-583b-b36a-8e71d59aa4f5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and let `data` be a `ModularPolynomialData N`: a polynomial
+$\Phi \in (\mathbb{Z}[X])[Y]$ which is monic in $Y$, whose degree in $Y$ equals $\psi(N) = \sum_{d
+\mid N,\ d \text{ squarefree}} N/d$, and which satisfies $\Phi(j_q, j_{q^N}) = 0$ in the field of
+Laurent series over $\mathbb{Q}$; here $j_q$ is the Laurent series $q^{-1}$ times the
+rational-coefficient power series `jNumQ` (the $q$-expansion of the modular invariant), $j_{q^N}$ is
+its image `jqN N` under the ring homomorphism `qExpand ℚ N` that multiplies all exponents by $N$,
+and the substitution of $j_q$ into the inner variable is the homomorphism `evalAtJ`. Write
+$\mathbb{Q}\langle j_q\rangle$ for the intermediate field `IntermediateField.adjoin ℚ {jq}` of the
+Laurent series field, and let `data.toAdjoin` $\in \mathbb{Q}\langle j_q\rangle[Y]$ be the image of
+$\Phi$ under coefficientwise application of `evalAtJGen`, i.e. substitution of the generator $j_q$
+for the inner variable. Assuming `PhiIrreducible data`, that is, that `data.toAdjoin` is
+irreducible, the conclusion is that the minimal polynomial of $j_{q^N}$ over $\mathbb{Q}\langle
+j_q\rangle$ equals `data.toAdjoin`.
+
+This is the classical identification of the modular polynomial $\Phi_N(j, Y)$ with the minimal
+polynomial of $j(q^N)$ over the field generated by $j(q)$, the input from which the degree
+$[\mathbb{Q}(j, j(q^N)) : \mathbb{Q}(j)] = \psi(N)$ is read off and hence the starting point for the
+function-field description of the modular curve $X_0(N)$. It is used throughout the construction of
+models of $X_0(N)$, including the results on fibres and Hecke divisors in characteristic $p$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_minpoly_jqN_eq_toAdjoin.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_minpoly_jqN_eq_toAdjoin
+
+noncomputable section
+
+open Polynomial IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jq jqN dedekindPsi ModularPolynomialData algebraMap_comp_evalAtJGen \
+  ModularPolynomialData.toAdjoin PhiIrreducible"
+p2m_open "ModularCurve"
+
+variable {N : ℕ} [NeZero N]
+
+theorem aeval_jqN_toAdjoin (data : ModularPolynomialData N) :
+    Polynomial.aeval (jqN N) data.toAdjoin = 0 := by
+  rw [ModularPolynomialData.toAdjoin, Polynomial.aeval_def, Polynomial.eval₂_map,
+    algebraMap_comp_evalAtJGen]
+  exact data.eval_eq_zero
+
+private theorem minpoly_jqN_eq_toAdjoin (data : ModularPolynomialData N) (h : PhiIrreducible data) :
+    minpoly ℚ⟮jq⟯ (jqN N) = data.toAdjoin :=
+  (minpoly.eq_of_irreducible_of_monic h (aeval_jqN_toAdjoin data) data.toAdjoin_monic).symm
+
+theorem finrank_adjoin_jqN_eq (data : ModularPolynomialData N) (h : PhiIrreducible data) :
+    Module.finrank ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN N⟯ = dedekindPsi N := by
+  have hint : IsIntegral ℚ⟮jq⟯ (jqN N) := ⟨data.toAdjoin, data.toAdjoin_monic, by
+    rw [← Polynomial.aeval_def]; exact aeval_jqN_toAdjoin data⟩
+  rw [IntermediateField.adjoin.finrank hint, minpoly_jqN_eq_toAdjoin data h,
+    ModularPolynomialData.toAdjoin,
+    data.monic.natDegree_map, data.natDegree_eq]
+
+end ModularCurve
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_minpoly_jqN_eq_toAdjoin.ModularCurve
+  ModularCurve.PhiGen in
+theorem solution {N : ℕ} [NeZero N] (data : ModularPolynomialData N) (h : PhiIrreducible data) :
+    minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN N) = data.toAdjoin :=
+  ModularCurve.minpoly_jqN_eq_toAdjoin data h
+
+end S_ModularCurve_minpoly_jqN_eq_toAdjoin
+end P2MW
+export P2MW.S_ModularCurve_minpoly_jqN_eq_toAdjoin (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.minpoly_jqN_eq_toAdjoin {N : ℕ} [NeZero N] (data : ModularPolynomialData N)
+    (h : PhiIrreducible data) :
+    minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN N) = data.toAdjoin :=
+  solution data h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_minpoly_jqN_map_eq_prod_slots.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_minpoly_jqN_map_eq_prod_slots.lean
new file mode 100644
index 0000000000..723efc1e33
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_minpoly_jqN_map_eq_prod_slots.lean
@@ -0,0 +1,2050 @@
+/-
+Based on Prove2Me node ModularCurve.minpoly_jqN_map_eq_prod_slots
+(e6bb2acf-c314-5521-a8c2-8258a3b50945) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 389417d8-53e1-5b13-be85-971b8519de5b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqN_eq_of_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime_pow
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_mul_of_coprime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration_of_squarefree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration_iff_full_eq
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.NumberTheory.Cyclotomic.PrimitiveRoots
+import Mathlib.FieldTheory.Extension
+import Mathlib.Data.Nat.Factorization.Induction
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Minimal polynomial of j(q^M) splits into primitive slots
+
+Theorem statement: `ModularCurve.minpoly_jqN_map_eq_prod_slots`
+(`e6bb2acf-c314-5521-a8c2-8258a3b50945`), by Claude, 2026-09-05.
+
+Proof: submission `389417d8-53e1-5b13-be85-971b8519de5b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field equipped with a $\mathbb{Q}$-algebra structure, let $M$ be a natural number with
+$M \neq 0$, and let $\zeta \in K^{\times}$ be a unit whose underlying element of $K$ is a primitive
+$M$-th root of unity. Assume the following package at every divisor $d$ of $M$ (with $d \neq 0$):
+the degree of $\mathbb{Q}(jq)\bigl(jqN\,d\bigr)$ over $\mathbb{Q}(jq)$ equals
+$\mathrm{dedekindPsi}\,d = \sum_{e \mid d,\ e \text{ squarefree}} d/e$, and $\mathbb{Q}\bigl(jq,\
+\mathrm{qExpand}_{\mathbb{Q}}\,d\,jq\bigr)$ coincides with the subfield of $\mathbb{Q}((q))$
+generated over $\mathbb{Q}$ by all $\mathrm{qExpand}_{\mathbb{Q}}\,e\,jq$ with $e \mid d$, $e \neq
+0$. Here $jq = q^{-1}\cdot jNumQ$ is the $j$-expansion in $\mathbb{Q}((q))$, $\mathrm{qExpand}_R\,n$
+is the exponent-scaling ring map $q \mapsto q^{n}$ on Laurent series, and $jqN\,n =
+\mathrm{qExpand}_{\mathbb{Q}}\,n\,jq$. Then the minimal polynomial of $jqN\,M$ over the intermediate
+field $\mathbb{Q}(jq)$, with its coefficients transported by the ring map given by the inclusion
+$\mathbb{Q}(jq) \hookrightarrow \mathbb{Q}((q))$ followed by $\mathrm{qExpand}_{\mathbb{Q}}\,M$
+followed by the coefficientwise map $\mathbb{Q}((q)) \to K((q))$ induced by $\mathbb{Q} \to K$,
+equals $$\prod_{a \mid M}\ \prod_{\substack{0 \le b < M/a \\ \gcd(\gcd(a,b),\,M/a)=1}} \Bigl(X -
+\mathrm{qExpand}_{K}(a^{2})\bigl(\mathrm{qTwist}(\zeta^{ba})\,jq\bigr)\Bigr),$$ where
+$\mathrm{qTwist}(u)$ scales the coefficient of $q^{k}$ by $u^{k}$, i.e. substitutes $uq$ for $q$ (a
+vacuous case distinction guards $a = 0$, which cannot occur).
+
+This is the classical determination of the conjugates of $j(q^{M})$ over $\mathbb{Q}(j)$,
+equivalently of the roots $j(\zeta^{b} q^{a/d})$ of the modular polynomial $\Phi_M(j, Y)$ indexed by
+the primitive slots $ad = M$, $0 \le b < d$, $\gcd(a,b,d) = 1$, obtained here from the prime-step
+splitting of $\Phi_p$, twists and coefficient extension rather than from coset representatives for
+$\Gamma_0(M)$. It feeds the symmetry statement for the modular polynomial data and the Hecke divisor
+computations on the characteristic-$p$ fibre models of the modular curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_minpoly_jqN_map_eq_prod_slots.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 6400000
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_minpoly_jqN_map_eq_prod_slots
+
+noncomputable section
+
+p2m_open "ModularCurve~dedekindPsi_prime~coeffEmb_qExpand~jqN_prime_not_mem_adjoin \
+  P2MW.S_ModularCurve_minpoly_jqN_map_eq_prod_slots.ModularCurve ModularCurve.PhiGen"
+open scoped IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one \
+  evalAtJ_X ModularPolynomialData modularFunctionField jq_mem jGen modularFunctionFieldFull \
+  jqd_mem_full modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm finrank_adjoin_jqN_eq_of_prime \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime functionFieldGeneration_of_squarefree \
+  functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime~coeffEmb_qExpand~jqN_prime_not_mem_adjoin"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+
+
+
+
+
+
+
+
+
+
+theorem coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb K (qExpand ℚ n x) = qExpand K n (coeffEmb K x) :=
+  coeffMap_qExpand (algebraMap ℚ K) n x
+
+theorem iota_jqN (N d : ℕ) [NeZero N] [NeZero d] :
+    coeffEmb K (qExpand ℚ N (jqN d)) = TS K (N * d) 1 := by
+  rw [jqN, coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem iota_jq (N : ℕ) [NeZero N] : coeffEmb K (qExpand ℚ N jq) = TS K N 1 := by
+  rw [coeffEmb_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_zero_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    conj p ζ (0 : Fin (p + 1)) = TS K (p * p) 1 := by
+  rw [conj_zero, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_succ_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) (b : Fin p) :
+    conj p ζ b.succ = TS K 1 (ζ ^ (b : ℕ)) := by
+  rw [conj_succ, TS_eq_coeffEmb, qExpand_one_apply]
+
+theorem qTwist_iota_of_pow_eq_one (N : ℕ) [NeZero N] (v : Kˣ) (hv : v ^ N = 1) (x : LaurentSeries ℚ)
+    :
+    qTwist v (coeffEmb K (qExpand ℚ N x)) = coeffEmb K (qExpand ℚ N x) := by
+  rw [coeffEmb_qExpand, qTwist_qExpand]
+  have : v ^ (N : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one \
+  evalAtJ_X ModularPolynomialData modularFunctionField jq_mem jGen modularFunctionFieldFull \
+  jqd_mem_full modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm finrank_adjoin_jqN_eq_of_prime \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime functionFieldGeneration_of_squarefree \
+  functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime~coeffEmb_qExpand~jqN_prime_not_mem_adjoin"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+omit [Algebra ℚ K] in
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+omit [Algebra ℚ K] in
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+omit [Algebra ℚ K] in
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem phiProd_conj_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    phiProd p (conj p ζ) = (Polynomial.X - Polynomial.C (TS K (p * p) 1)) *
+      ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) := by
+  rw [phiProd, Fin.prod_univ_succ, conj_zero_eq]
+  congr 1
+  rw [← Fin.prod_univ_eq_prod_range (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) p]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [conj_succ_eq]
+
+theorem roots_phiProd_conj (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    (phiProd p (conj p ζ)).roots = TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^
+      b)) := by
+  classical
+  rw [phiProd_conj_eq]
+  have h1 : (Polynomial.X - Polynomial.C (TS K (p * p) 1) : Polynomial (LaurentSeries K)) ≠ 0 :=
+    Polynomial.X_sub_C_ne_zero _
+  have h2 : (∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b)))) ≠ 0 :=
+    Finset.prod_ne_zero_iff.mpr fun b _ => Polynomial.X_sub_C_ne_zero _
+  rw [Polynomial.roots_mul (mul_ne_zero h1 h2), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod,
+    Finset.range_val]
+  have hm : (Multiset.map (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) (Multiset.range
+    p)) =
+      ((Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).map (fun a => Polynomial.X - Polynomial.C
+        a) := by
+    rw [Multiset.map_map]; rfl
+  rw [hm, Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+omit [Algebra ℚ K] in
+theorem roots_phiProd_conj_nodup (p : ℕ) [hp : Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).Nodup := by
+  refine Multiset.nodup_cons.mpr ⟨?_, ?_⟩
+  · intro hmem
+    obtain ⟨b, -, hb⟩ := Multiset.mem_map.mp hmem
+    have := (TS_injective hb).1
+    have h2 := hp.out.two_le
+    nlinarith
+  · refine (Multiset.nodup_range p).map_on fun b hb b' hb' hbb' => ?_
+    rw [Multiset.mem_range] at hb hb'
+    have hu := (TS_injective hbb').2
+    have hζu : IsPrimitiveRoot ζ p := IsPrimitiveRoot.coe_units_iff.mp hζ
+    exact hζu.pow_inj hb hb' hu
+
+theorem exists_isPrimitiveRoot_cyclotomicField (N : ℕ) [NeZero N] :
+    ∃ z : CyclotomicField N ℚ, IsPrimitiveRoot z N := by
+  have : NeZero ((N : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr (NeZero.ne N)⟩
+  have : IsCyclotomicExtension {N} ℚ (CyclotomicField N ℚ) :=
+    CyclotomicField.isCyclotomicExtension N ℚ
+  exact IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField N ℚ) (Set.mem_singleton N)
+    (NeZero.ne N)
+
+def cycUnit (N : ℕ) [NeZero N] : (CyclotomicField N ℚ)ˣ :=
+  ((exists_isPrimitiveRoot_cyclotomicField N).choose_spec.isUnit (NeZero.ne N)).unit
+
+theorem cycUnit_spec (N : ℕ) [NeZero N] :
+    IsPrimitiveRoot ((cycUnit N : (CyclotomicField N ℚ)ˣ) : CyclotomicField N ℚ) N := by
+  rw [cycUnit, IsUnit.unit_spec]
+  exact (exists_isPrimitiveRoot_cyclotomicField N).choose_spec
+
+theorem cycUnit_pow (N : ℕ) [NeZero N] : cycUnit N ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, (cycUnit_spec N).pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one \
+  evalAtJ_X ModularPolynomialData modularFunctionField jq_mem jGen modularFunctionFieldFull \
+  jqd_mem_full modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm finrank_adjoin_jqN_eq_of_prime \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime functionFieldGeneration_of_squarefree \
+  functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime~coeffEmb_qExpand~jqN_prime_not_mem_adjoin"
+
+variable {K : Type*} [Field K]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one \
+  evalAtJ_X ModularPolynomialData modularFunctionField jq_mem jGen modularFunctionFieldFull \
+  jqd_mem_full modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm finrank_adjoin_jqN_eq_of_prime \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime functionFieldGeneration_of_squarefree \
+  functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime~coeffEmb_qExpand~jqN_prime_not_mem_adjoin"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem prod_form_ne_zero (N : ℕ) (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e]
+    (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K
+            jq)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+          (Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u,
+    Polynomial.roots_mul (prod_form_ne_zero N ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p)))
+    (coeffEmb K jq))))
+        = ((Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+        (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+        (Multiset.range p).map
+          (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).Nodup := by
+  have hζp : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := isPrimitiveRoot_pow_div hζ hpN
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h := (TS_injective (K := K) (e := e) (e' := p * (p * e))
+      (u := u * ζ ^ (b * (N / p))) (u' := u ^ (p * p))
+      (by simpa only [TS_eq_coeffEmb] using heq)).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e)
+      (u := u * ζ ^ (b * (N / p))) (u' := u * ζ ^ (b' * (N / p)))
+      (by simpa only [TS_eq_coeffEmb] using heq)).2
+    have h2 : ζ ^ (b * (N / p)) = ζ ^ (b' * (N / p)) := mul_left_cancel h
+    have h3 : (ζ ^ (N / p)) ^ b = (ζ ^ (N / p)) ^ b' := by
+      rw [← pow_mul, ← pow_mul, Nat.mul_comm (N / p) b, Nat.mul_comm (N / p) b']
+      exact h2
+    have h4 : ((ζ ^ (N / p) : Kˣ) : K) ^ b = ((ζ ^ (N / p) : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h3]
+    exact hζp.pow_inj hb hb' h4
+
+theorem roots_prime_at_slot_roots_nodup (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots.Nodup := by
+  rw [roots_prime_at_slot N ζ hζ p hpN data e u]
+  exact roots_prime_at_slot_nodup N ζ hζ p hpN e u
+
+theorem isRoot_prime_at_slot_iff (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u]
+    exact prod_form_ne_zero N ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot N ζ hζ p hpN data e u,
+    Multiset.mem_cons, Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one \
+  evalAtJ_X ModularPolynomialData modularFunctionField jq_mem jGen modularFunctionFieldFull \
+  jqd_mem_full modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm finrank_adjoin_jqN_eq_of_prime \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime functionFieldGeneration_of_squarefree \
+  functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime~coeffEmb_qExpand~jqN_prime_not_mem_adjoin"
+
+
+
+
+
+theorem phiAtSeed_jq_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) :
+    (phiAtSeed data jq).eval (jqN n) = 0 := by
+  have h := data.eval_eq_zero
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' ?_ ?_
+  · exact RingHom.ext_int _ _
+  · simp [evalAtJ_X]
+
+
+theorem phiAtSeed_jqN_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN M)).eval (jqN (M * n)) = 0 := by
+  have h := phiAtSeed_eval_map data jq (jqN n) (qExpand ℚ M) (phiAtSeed_jq_eval n data)
+  rwa [jqN, qExpand_qExpand] at h
+
+theorem phiAtSeed_iota_eval {K : Type*} [Field K] [Algebra ℚ K] (A : ℕ) [NeZero A] (n : ℕ)
+    [NeZero n]
+    (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (coeffEmb K (qExpand ℚ A (jqN M)))).eval (coeffEmb K (qExpand ℚ A (jqN (M *
+      n)))) = 0 :=
+  phiAtSeed_eval_map data _ _ ((coeffEmb K).comp (qExpand ℚ A)) (phiAtSeed_jqN_eval n data M)
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one \
+  evalAtJ_X ModularPolynomialData modularFunctionField jq_mem jGen modularFunctionFieldFull \
+  jqd_mem_full modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm finrank_adjoin_jqN_eq_of_prime \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime functionFieldGeneration_of_squarefree \
+  functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime~coeffEmb_qExpand~jqN_prime_not_mem_adjoin"
+
+private def slotAt (n d : ℕ) : ℕ :=
+  ((Finset.range d).filter fun b => Nat.gcd (Nat.gcd (n / d) b) d = 1).card
+
+private def slots (n : ℕ) : ℕ := ∑ d ∈ n.divisors, slotAt n d
+
+private theorem slotCond_eq (x d b : ℕ) :
+    Nat.gcd (Nat.gcd x b) d = Nat.gcd (Nat.gcd x d) b := by
+  rw [Nat.gcd_assoc, Nat.gcd_comm b d, ← Nat.gcd_assoc]
+
+private theorem slotCond_iff (x d b : ℕ) :
+    Nat.gcd (Nat.gcd x b) d = 1 ↔ Nat.Coprime (Nat.gcd x d) b := by
+  rw [slotCond_eq]
+
+private theorem gcd_eq_of_modEq {a b n : ℕ} (h : a ≡ b [MOD n]) :
+    Nat.gcd n a = Nat.gcd n b := by
+  have h' : a % n = b % n := h
+  rw [Nat.gcd_rec n a, Nat.gcd_rec n b, h']
+
+private theorem slotCond_mod_iff (x d b : ℕ) :
+    Nat.Coprime (Nat.gcd x d) (b % d) ↔ Nat.Coprime (Nat.gcd x d) b := by
+  unfold Nat.Coprime
+  rw [gcd_eq_of_modEq ((Nat.mod_modEq b d).of_dvd (Nat.gcd_dvd_right x d))]
+
+private theorem slotAt_one (n : ℕ) : slotAt n 1 = 1 := by
+  unfold slotAt
+  simp [Nat.gcd_one_right]
+
+private theorem slotAt_self (n : ℕ) (hn : 0 < n) : slotAt n n = n := by
+  unfold slotAt
+  simp [Nat.div_self hn, Nat.gcd_one_left]
+
+private theorem slotAt_prime_pow_mid {p : ℕ} (hp : p.Prime) {i k : ℕ} (hi0 : 0 < i)
+    (hik : i < k) : slotAt (p ^ k) (p ^ i) = Nat.totient (p ^ i) := by
+  unfold slotAt
+  rw [Nat.totient_eq_card_coprime]
+  congr 1
+  refine Finset.filter_congr fun b _ => ?_
+  rw [slotCond_iff]
+  constructor
+  · intro h
+    have hpg : p ∣ Nat.gcd (p ^ k / p ^ i) (p ^ i) := by
+      refine Nat.dvd_gcd ?_ (dvd_pow_self p hi0.ne')
+      rw [Nat.pow_div hik.le hp.pos]
+      exact dvd_pow_self p (by omega)
+    exact Nat.Coprime.pow_left i (Nat.Coprime.coprime_dvd_left hpg h)
+  · intro h
+    exact Nat.Coprime.coprime_dvd_left (Nat.gcd_dvd_right _ _) h
+
+private theorem slots_prime_pow {p : ℕ} (hp : p.Prime) (k : ℕ) :
+    slots (p ^ (k + 1)) = p ^ (k + 1) + p ^ k := by
+  unfold slots
+  rw [Nat.sum_divisors_prime_pow hp, Finset.sum_range_succ]
+  have hrest : ∀ x ∈ Finset.range (k + 1),
+      slotAt (p ^ (k + 1)) (p ^ x) = Nat.totient (p ^ x) := by
+    intro x hx
+    rcases Nat.eq_zero_or_pos x with rfl | hx0
+    · rw [pow_zero, slotAt_one, Nat.totient_one]
+    · exact slotAt_prime_pow_mid hp hx0 (Finset.mem_range.mp hx)
+  rw [Finset.sum_congr rfl hrest, slotAt_self _ (pow_pos hp.pos _),
+    ← Nat.sum_divisors_prime_pow (f := Nat.totient) hp, Nat.sum_totient, Nat.add_comm]
+
+private theorem dedekindPsi_prime_pow' {p : ℕ} (hp : p.Prime) (k : ℕ) :
+    ModularCurve.dedekindPsi (p ^ (k + 1)) = p ^ (k + 1) + p ^ k := by
+  unfold ModularCurve.dedekindPsi
+  have hfil : Finset.filter (fun d => Squarefree d) (p ^ (k + 1)).divisors = {1, p} := by
+    ext x
+    simp only [Finset.mem_filter, Nat.mem_divisors_prime_pow hp, Finset.mem_insert,
+      Finset.mem_singleton]
+    constructor
+    · rintro ⟨⟨j, -, rfl⟩, hsq⟩
+      rcases Nat.eq_zero_or_pos j with rfl | hj0
+      · exact Or.inl (pow_zero p)
+      · have hj1 : j = 1 := ((Nat.squarefree_pow_iff hp.ne_one hj0.ne').mp hsq).2
+        subst hj1
+        exact Or.inr (pow_one p)
+    · rintro (rfl | rfl)
+      · exact ⟨⟨0, Nat.zero_le _, (pow_zero p).symm⟩, squarefree_one⟩
+      · exact ⟨⟨1, by omega, (pow_one _).symm⟩, hp.prime.squarefree⟩
+  rw [hfil, Finset.sum_pair hp.one_lt.ne, Nat.div_one, pow_succ,
+    Nat.mul_div_cancel _ hp.pos]
+
+private theorem slotAt_mul (M M' d₁ d₂ : ℕ) (hM : M ≠ 0) (hM' : M' ≠ 0)
+    (hco : Nat.Coprime M M') (hd₁ : d₁ ∣ M) (hd₂ : d₂ ∣ M') :
+    slotAt (M * M') (d₁ * d₂) = slotAt M d₁ * slotAt M' d₂ := by
+  have hd₁0 : 0 < d₁ :=
+    Nat.pos_of_ne_zero (by rintro rfl; exact hM (Nat.eq_zero_of_zero_dvd hd₁))
+  have hd₂0 : 0 < d₂ :=
+    Nat.pos_of_ne_zero (by rintro rfl; exact hM' (Nat.eq_zero_of_zero_dvd hd₂))
+  have hcod : Nat.Coprime d₁ d₂ :=
+    Nat.Coprime.coprime_dvd_left hd₁ (Nat.Coprime.coprime_dvd_right hd₂ hco)
+  have hxM : M / d₁ ∣ M := ⟨d₁, (Nat.div_mul_cancel hd₁).symm⟩
+  have hyM' : M' / d₂ ∣ M' := ⟨d₂, (Nat.div_mul_cancel hd₂).symm⟩
+  have hxy : (M * M') / (d₁ * d₂) = (M / d₁) * (M' / d₂) :=
+    (Nat.div_mul_div_comm hd₁ hd₂).symm
+  have hyd₁ : Nat.Coprime (M' / d₂) d₁ :=
+    Nat.Coprime.coprime_dvd_left hyM' (Nat.Coprime.coprime_dvd_right hd₁ hco.symm)
+  have hxd₂ : Nat.Coprime (M / d₁) d₂ :=
+    Nat.Coprime.coprime_dvd_left hxM (Nat.Coprime.coprime_dvd_right hd₂ hco)
+  have hg₁g : Nat.gcd (M / d₁) d₁ ∣ Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) := by
+    rw [hxy]
+    exact Nat.dvd_gcd ((Nat.gcd_dvd_left _ _).mul_right _) ((Nat.gcd_dvd_right _ _).mul_right _)
+  have hg₂g : Nat.gcd (M' / d₂) d₂ ∣ Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) := by
+    rw [hxy]
+    exact Nat.dvd_gcd ((Nat.gcd_dvd_left _ _).mul_left _) ((Nat.gcd_dvd_right _ _).mul_left _)
+  have hgg : Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) ∣
+      Nat.gcd (M / d₁) d₁ * Nat.gcd (M' / d₂) d₂ := by
+    have hgdd : Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) ∣ d₁ * d₂ := Nat.gcd_dvd_right _ _
+    have hgxy : Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) ∣ (M / d₁) * (M' / d₂) := by
+      rw [← hxy]
+      exact Nat.gcd_dvd_left _ _
+    have hgyx : Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) ∣ (M' / d₂) * (M / d₁) :=
+      hgxy.trans (dvd_of_eq (Nat.mul_comm (M / d₁) (M' / d₂)))
+    have hsplit : Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂)) d₁ *
+        Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂)) d₂ =
+        Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂) :=
+      (Nat.gcd_mul_gcd_eq_iff_dvd_mul_of_coprime hcod).mpr hgdd
+    rw [← hsplit]
+    refine Nat.mul_dvd_mul ?_ ?_
+    · refine Nat.dvd_gcd ?_ (Nat.gcd_dvd_right _ d₁)
+      have h2 : Nat.Coprime (Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂)) d₁)
+          (M' / d₂) := Nat.Coprime.coprime_dvd_left (Nat.gcd_dvd_right _ d₁) hyd₁.symm
+      exact h2.dvd_of_dvd_mul_right ((Nat.gcd_dvd_left _ d₁).trans hgxy)
+    · refine Nat.dvd_gcd ?_ (Nat.gcd_dvd_right _ d₂)
+      have h2 : Nat.Coprime (Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) (d₁ * d₂)) d₂)
+          (M / d₁) := Nat.Coprime.coprime_dvd_left (Nat.gcd_dvd_right _ d₂) hxd₂.symm
+      exact h2.dvd_of_dvd_mul_right ((Nat.gcd_dvd_left _ d₂).trans hgyx)
+  have hfwd : ∀ b : ℕ, Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) b) (d₁ * d₂) = 1 →
+      Nat.gcd (Nat.gcd (M / d₁) (b % d₁)) d₁ = 1 ∧
+        Nat.gcd (Nat.gcd (M' / d₂) (b % d₂)) d₂ = 1 := by
+    intro b hb
+    rw [slotCond_iff] at hb
+    constructor
+    · rw [slotCond_iff, slotCond_mod_iff]
+      exact Nat.Coprime.coprime_dvd_left hg₁g hb
+    · rw [slotCond_iff, slotCond_mod_iff]
+      exact Nat.Coprime.coprime_dvd_left hg₂g hb
+  have hbwd : ∀ b₁ b₂ k : ℕ, Nat.gcd (Nat.gcd (M / d₁) b₁) d₁ = 1 →
+      Nat.gcd (Nat.gcd (M' / d₂) b₂) d₂ = 1 → k ≡ b₁ [MOD d₁] → k ≡ b₂ [MOD d₂] →
+      Nat.gcd (Nat.gcd ((M * M') / (d₁ * d₂)) k) (d₁ * d₂) = 1 := by
+    intro b₁ b₂ k h₁ h₂ hk₁ hk₂
+    rw [slotCond_iff] at h₁ h₂ ⊢
+    have hc₁ : Nat.Coprime (Nat.gcd (M / d₁) d₁) k := by
+      unfold Nat.Coprime
+      rw [gcd_eq_of_modEq (hk₁.of_dvd (Nat.gcd_dvd_right (M / d₁) d₁))]
+      exact h₁
+    have hc₂ : Nat.Coprime (Nat.gcd (M' / d₂) d₂) k := by
+      unfold Nat.Coprime
+      rw [gcd_eq_of_modEq (hk₂.of_dvd (Nat.gcd_dvd_right (M' / d₂) d₂))]
+      exact h₂
+    exact Nat.Coprime.coprime_dvd_left hgg (Nat.coprime_mul_iff_left.mpr ⟨hc₁, hc₂⟩)
+  unfold slotAt
+  rw [← Finset.card_product]
+  refine Finset.card_bij' (fun b _ => (b % d₁, b % d₂))
+    (fun q _ => (Nat.chineseRemainder hcod q.1 q.2 : ℕ)) ?_ ?_ ?_ ?_
+  · intro b hb
+    obtain ⟨hbr, hbc⟩ := Finset.mem_filter.mp hb
+    obtain ⟨h₁, h₂⟩ := hfwd b hbc
+    exact Finset.mem_product.mpr
+      ⟨Finset.mem_filter.mpr ⟨Finset.mem_range.mpr (Nat.mod_lt b hd₁0), h₁⟩,
+        Finset.mem_filter.mpr ⟨Finset.mem_range.mpr (Nat.mod_lt b hd₂0), h₂⟩⟩
+  · intro q hq
+    obtain ⟨hq₁, hq₂⟩ := Finset.mem_product.mp hq
+    have hcrt := (Nat.chineseRemainder hcod q.1 q.2).prop
+    refine Finset.mem_filter.mpr ⟨Finset.mem_range.mpr
+      (Nat.chineseRemainder_lt_mul hcod q.1 q.2 hd₁0.ne' hd₂0.ne'), ?_⟩
+    exact hbwd q.1 q.2 _ (Finset.mem_filter.mp hq₁).2 (Finset.mem_filter.mp hq₂).2
+      hcrt.1 hcrt.2
+  · intro b hb
+    have hb' : b < d₁ * d₂ := Finset.mem_range.mp (Finset.mem_filter.mp hb).1
+    have hcrt := (Nat.chineseRemainder hcod (b % d₁) (b % d₂)).prop
+    have h₁ : (Nat.chineseRemainder hcod (b % d₁) (b % d₂) : ℕ) ≡ b [MOD d₁] :=
+      hcrt.1.trans (Nat.mod_modEq b d₁)
+    have h₂ : (Nat.chineseRemainder hcod (b % d₁) (b % d₂) : ℕ) ≡ b [MOD d₂] :=
+      hcrt.2.trans (Nat.mod_modEq b d₂)
+    exact ((Nat.modEq_and_modEq_iff_modEq_mul hcod).mp ⟨h₁, h₂⟩).eq_of_lt_of_lt
+      (Nat.chineseRemainder_lt_mul hcod _ _ hd₁0.ne' hd₂0.ne') hb'
+  · intro q hq
+    obtain ⟨hq₁, hq₂⟩ := Finset.mem_product.mp hq
+    have hb₁ : q.1 < d₁ := Finset.mem_range.mp (Finset.mem_filter.mp hq₁).1
+    have hb₂ : q.2 < d₂ := Finset.mem_range.mp (Finset.mem_filter.mp hq₂).1
+    have hcrt := (Nat.chineseRemainder hcod q.1 q.2).prop
+    have h₁ : (Nat.chineseRemainder hcod q.1 q.2 : ℕ) % d₁ = q.1 := by
+      have h' : (Nat.chineseRemainder hcod q.1 q.2 : ℕ) % d₁ = q.1 % d₁ := hcrt.1
+      rw [h', Nat.mod_eq_of_lt hb₁]
+    have h₂ : (Nat.chineseRemainder hcod q.1 q.2 : ℕ) % d₂ = q.2 := by
+      have h' : (Nat.chineseRemainder hcod q.1 q.2 : ℕ) % d₂ = q.2 % d₂ := hcrt.2
+      rw [h', Nat.mod_eq_of_lt hb₂]
+    exact Prod.ext h₁ h₂
+
+private theorem gcd_mul_left_of_dvd (M M' : ℕ) (hco : Nat.Coprime M M') {e₁ e₂ : ℕ}
+    (he₁ : e₁ ∣ M) (he₂ : e₂ ∣ M') : Nat.gcd (e₁ * e₂) M = e₁ := by
+  refine Nat.dvd_antisymm ?_ (Nat.dvd_gcd (dvd_mul_right e₁ e₂) he₁)
+  have hc : Nat.Coprime (Nat.gcd (e₁ * e₂) M) e₂ :=
+    Nat.Coprime.coprime_dvd_left (Nat.gcd_dvd_right _ _)
+      (Nat.Coprime.coprime_dvd_right he₂ hco)
+  exact hc.dvd_of_dvd_mul_right (Nat.gcd_dvd_left _ _)
+
+private theorem gcd_mul_right_of_dvd (M M' : ℕ) (hco : Nat.Coprime M M') {e₁ e₂ : ℕ}
+    (he₁ : e₁ ∣ M) (he₂ : e₂ ∣ M') : Nat.gcd (e₁ * e₂) M' = e₂ := by
+  refine Nat.dvd_antisymm ?_ (Nat.dvd_gcd (dvd_mul_left e₂ e₁) he₂)
+  have hc : Nat.Coprime (Nat.gcd (e₁ * e₂) M') e₁ :=
+    Nat.Coprime.coprime_dvd_left (Nat.gcd_dvd_right _ _)
+      (Nat.Coprime.coprime_dvd_right he₁ hco.symm)
+  have h1 : Nat.gcd (e₁ * e₂) M' ∣ e₂ * e₁ :=
+    (Nat.gcd_dvd_left (e₁ * e₂) M').trans (dvd_of_eq (Nat.mul_comm e₁ e₂))
+  exact hc.dvd_of_dvd_mul_right h1
+
+private theorem slots_mul (M M' : ℕ) (hM : M ≠ 0) (hM' : M' ≠ 0)
+    (hco : Nat.Coprime M M') : slots (M * M') = slots M * slots M' := by
+  unfold slots
+  rw [Finset.sum_mul_sum, ← Finset.sum_product']
+  refine Finset.sum_bij' (fun d _ => (Nat.gcd d M, Nat.gcd d M')) (fun q _ => q.1 * q.2)
+    ?_ ?_ ?_ ?_ ?_
+  · intro d hd
+    exact Finset.mem_product.mpr
+      ⟨Nat.mem_divisors.mpr ⟨Nat.gcd_dvd_right d M, hM⟩,
+        Nat.mem_divisors.mpr ⟨Nat.gcd_dvd_right d M', hM'⟩⟩
+  · intro q hq
+    obtain ⟨hq₁, hq₂⟩ := Finset.mem_product.mp hq
+    exact Nat.mem_divisors.mpr
+      ⟨Nat.mul_dvd_mul (Nat.mem_divisors.mp hq₁).1 (Nat.mem_divisors.mp hq₂).1,
+        Nat.mul_ne_zero hM hM'⟩
+  · intro d hd
+    exact (Nat.gcd_mul_gcd_eq_iff_dvd_mul_of_coprime hco).mpr (Nat.mem_divisors.mp hd).1
+  · intro q hq
+    obtain ⟨hq₁, hq₂⟩ := Finset.mem_product.mp hq
+    exact Prod.ext
+      (gcd_mul_left_of_dvd M M' hco (Nat.mem_divisors.mp hq₁).1 (Nat.mem_divisors.mp hq₂).1)
+      (gcd_mul_right_of_dvd M M' hco (Nat.mem_divisors.mp hq₁).1 (Nat.mem_divisors.mp hq₂).1)
+  · intro d hd
+    have hsplit : Nat.gcd d M * Nat.gcd d M' = d :=
+      (Nat.gcd_mul_gcd_eq_iff_dvd_mul_of_coprime hco).mpr (Nat.mem_divisors.mp hd).1
+    conv_lhs => rw [← hsplit]
+    exact slotAt_mul M M' (Nat.gcd d M) (Nat.gcd d M') hM hM' hco
+      (Nat.gcd_dvd_right d M) (Nat.gcd_dvd_right d M')
+
+private theorem slots_eq_dedekindPsi : ∀ n : ℕ, n ≠ 0 → slots n = ModularCurve.dedekindPsi n := by
+  intro n
+  induction n using Nat.recOnPosPrimePosCoprime with
+  | prime_pow p k hp hk =>
+    intro _
+    obtain ⟨j, rfl⟩ : ∃ j, k = j + 1 := ⟨k - 1, by omega⟩
+    rw [slots_prime_pow hp j, dedekindPsi_prime_pow' hp j]
+  | zero => exact fun h0 => absurd rfl h0
+  | one =>
+    intro _
+    rw [ModularCurve.dedekindPsi_one]
+    unfold slots
+    rw [Nat.divisors_one, Finset.sum_singleton]
+    exact slotAt_one 1
+  | coprime a b ha hb hab iha ihb =>
+    intro _
+    rw [slots_mul a b (by omega) (by omega) hab, iha (by omega), ihb (by omega),
+      ModularCurve.dedekindPsi_mul_of_coprime a b hab]
+
+private theorem dedekindPsi_pos {n : ℕ} (hn : n ≠ 0) : 0 < ModularCurve.dedekindPsi n := by
+  have h1 : (1 : ℕ) ∈ n.divisors.filter (fun d => Squarefree d) :=
+    Finset.mem_filter.mpr ⟨Nat.one_mem_divisors.mpr hn, squarefree_one⟩
+  have h2 : n / 1 ≤ ∑ d ∈ n.divisors with Squarefree d, n / d :=
+    Finset.single_le_sum (f := fun d => n / d) (fun i _ => Nat.zero_le _) h1
+  rw [Nat.div_one] at h2
+  exact lt_of_lt_of_le (Nat.pos_of_ne_zero hn) h2
+
+private theorem dedekindPsi_prime (p : ℕ) (hp : p.Prime) :
+    ModularCurve.dedekindPsi p = p + 1 := by
+  have h1 := ModularCurve.dedekindPsi_prime_pow p 1 hp one_ne_zero
+  rw [pow_one] at h1
+  rw [h1]
+  norm_num
+
+private theorem dedekindPsi_mul_prime_not_dvd {m p : ℕ} (hp : p.Prime) (hpm : ¬ p ∣ m) :
+    ModularCurve.dedekindPsi (m * p) = ModularCurve.dedekindPsi m * (p + 1) := by
+  have hco : Nat.Coprime m p := ((Nat.Prime.coprime_iff_not_dvd hp).mpr hpm).symm
+  rw [ModularCurve.dedekindPsi_mul_of_coprime m p hco, dedekindPsi_prime p hp]
+
+private theorem dedekindPsi_mul_prime_dvd {m p : ℕ} (hm : m ≠ 0) (hp : p.Prime)
+    (hpm : p ∣ m) : ModularCurve.dedekindPsi (m * p) = ModularCurve.dedekindPsi m * p := by
+  obtain ⟨k, u, hpu, hmu⟩ := Nat.exists_eq_pow_mul_and_not_dvd hm p hp.ne_one
+  obtain ⟨k', rfl⟩ : ∃ k', k = k' + 1 := by
+    rcases k with - | k'
+    · exfalso
+      rw [hmu, pow_zero, one_mul] at hpm
+      exact hpu hpm
+    · exact ⟨k', rfl⟩
+  subst hmu
+  have hcou : ∀ j : ℕ, j ≠ 0 → Nat.Coprime (p ^ j) u :=
+    fun j _ => Nat.Coprime.pow_left j ((Nat.Prime.coprime_iff_not_dvd hp).mpr hpu)
+  have h1 : p ^ (k' + 1) * u * p = p ^ (k' + 2) * u := by ring
+  rw [h1, ModularCurve.dedekindPsi_mul_of_coprime _ u (hcou _ (Nat.succ_ne_zero _)),
+    ModularCurve.dedekindPsi_mul_of_coprime _ u (hcou _ (Nat.succ_ne_zero _)),
+    ModularCurve.dedekindPsi_prime_pow p (k' + 2) hp (Nat.succ_ne_zero _),
+    ModularCurve.dedekindPsi_prime_pow p (k' + 1) hp (Nat.succ_ne_zero _)]
+  have h2 : k' + 2 - 1 = k' + 1 := rfl
+  have h3 : k' + 1 - 1 = k' := rfl
+  rw [h2, h3]
+  ring
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private def sv (K : Type*) [Field K] [Algebra ℚ K] (ζ : Kˣ) (a b : ℕ) : LaurentSeries K :=
+  if h : a = 0 then 0 else
+    letI : NeZero a := ⟨h⟩
+    qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq))
+
+private theorem sv_eq (ζ : Kˣ) (a b : ℕ) [NeZero a] :
+    sv K ζ a b = qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)) := by
+  unfold sv
+  rw [dite_eq_right (NeZero.ne a)]
+
+private theorem sv_eq_TS (ζ : Kˣ) (a b : ℕ) [NeZero a] :
+    sv K ζ a b = TS K (a * a) (ζ ^ (b * a)) := by
+  simpa only [TS_eq_coeffEmb] using sv_eq ζ a b
+
+omit [Algebra ℚ K] in
+private theorem TS_congr' {e e' : ℕ} [NeZero e] [NeZero e'] {u u' : Kˣ} (he : e = e')
+    (hu : u = u') : TS K e u = TS K e' u' := by
+  subst he
+  rw [hu]
+
+private theorem sv_inj {M : ℕ} {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) M)
+    {a b a' b' : ℕ} (ha0 : a ≠ 0) (ha0' : a' ≠ 0) (hb : b * a < M) (hb' : b' * a' < M)
+    (h : sv K ζ a b = sv K ζ a' b') : a = a' ∧ b = b' := by
+  have : NeZero a := ⟨ha0⟩
+  have : NeZero a' := ⟨ha0'⟩
+  rw [sv_eq_TS, sv_eq_TS] at h
+  obtain ⟨he, hu⟩ := TS_injective h
+  have haa : a = a' := (mul_self_inj (Nat.zero_le a) (Nat.zero_le a')).mp he
+  subst haa
+  refine ⟨rfl, ?_⟩
+  have hv : ((ζ : K)) ^ (b * a) = ((ζ : K)) ^ (b' * a) := by
+    have h1 := congrArg Units.val hu
+    rwa [Units.val_pow_eq_pow_val, Units.val_pow_eq_pow_val] at h1
+  have h2 : b * a = b' * a := hζ.pow_inj hb hb' hv
+  exact Nat.eq_of_mul_eq_mul_right (Nat.pos_of_ne_zero ha0) h2
+
+private theorem jqN_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) : jqN n = jqN m := by
+  subst h
+  rfl
+
+private theorem sv_top (M : ℕ) [NeZero M] (ζ : Kˣ) :
+    sv K ζ M 0 = coeffEmb K (qExpand ℚ M (jqN M)) := by
+  rw [sv_eq_TS, iota_jqN M M]
+  exact TS_congr' rfl (by rw [zero_mul, pow_zero])
+
+private theorem aeval_intermediateField_eq_zero {F₀ L : Type*} [Field F₀] [Field L]
+    [Algebra F₀ L] {E : IntermediateField F₀ L} {P : Polynomial F₀} {x : E}
+    (h : Polynomial.aeval (E.val x) P = 0) : Polynomial.aeval x P = 0 := by
+  have h1 := Polynomial.aeval_algHom_apply E.val x P
+  rw [h] at h1
+  have h2 : E.val (Polynomial.aeval x P) = E.val 0 := by rw [← h1, map_zero]
+  exact RingHom.injective (E.val : E →+* L) h2
+
+private theorem phiAtSeed_eval_of_injective {R S : Type*} [CommRing R] [CommRing S] {n : ℕ}
+    [NeZero n] (data : ModularPolynomialData n) (x y : R) (f : R →+* S)
+    (hf : Function.Injective f) (h : (phiAtSeed data (f x)).eval (f y) = 0) :
+    (phiAtSeed data x).eval y = 0 := by
+  rw [← phiAtSeed_map, Polynomial.eval_map, Polynomial.eval₂_hom] at h
+  exact (injective_iff_map_eq_zero f).mp hf _ h
+
+private theorem phiAtSeed_eval_symm {n : ℕ} [NeZero n] (data : ModularPolynomialData n)
+    (hsym : EvalSymm data.Φ) (x y : LaurentSeries ℚ) :
+    (phiAtSeed data x).eval y = (phiAtSeed data y).eval x := by
+  have hhom : ∀ z : LaurentSeries ℚ,
+      Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries ℚ)) z
+        = (Polynomial.aeval (R := ℤ) z).toRingHom := by
+    intro z
+    refine Polynomial.ringHom_ext' ?_ ?_
+    · exact RingHom.ext_int _ _
+    · simp [Polynomial.coe_eval₂RingHom]
+  rw [phiAtSeed, phiAtSeed, Polynomial.eval_map, Polynomial.eval_map, hhom x, hhom y]
+  exact hsym x y
+
+private theorem mem_adjoin_jqN_of_mem_mff {M : ℕ} [NeZero M] {x : LaurentSeries ℚ}
+    (hx : x ∈ modularFunctionField M) :
+    x ∈ IntermediateField.adjoin ℚ⟮jq⟯ ({jqN M} : Set (LaurentSeries ℚ)) := by
+  have hle : ℚ⟮jq⟯ ≤
+      IntermediateField.adjoin ℚ ({jq, qExpand ℚ M jq} : Set (LaurentSeries ℚ)) :=
+    IntermediateField.adjoin.mono ℚ _ _
+      (Set.singleton_subset_iff.mpr (Set.mem_insert _ _))
+  have hE := IntermediateField.extendScalars_adjoin hle
+  have hcollapse : IntermediateField.adjoin ℚ⟮jq⟯
+      ({jq, qExpand ℚ M jq} : Set (LaurentSeries ℚ))
+      = IntermediateField.adjoin ℚ⟮jq⟯ ({jqN M} : Set (LaurentSeries ℚ)) := by
+    refine le_antisymm (IntermediateField.adjoin_le_iff.mpr ?_)
+      (IntermediateField.adjoin.mono _ _ _ ?_)
+    · rintro z (rfl | rfl)
+      · exact (IntermediateField.adjoin ℚ⟮jq⟯ _).algebraMap_mem jGen
+      · exact IntermediateField.subset_adjoin ℚ⟮jq⟯ _ rfl
+    · exact Set.singleton_subset_iff.mpr (Set.mem_insert_of_mem _ rfl)
+  rw [modularFunctionField] at hx
+  have h2 : x ∈ IntermediateField.extendScalars hle :=
+    (IntermediateField.mem_extendScalars _).mpr hx
+  rw [hE, hcollapse] at h2
+  exact h2
+
+private theorem qExpand_congr {R : Type*} [CommRing R] {n m : ℕ} [NeZero n] [NeZero m]
+    (h : n = m) (x : LaurentSeries R) : qExpand R n x = qExpand R m x := by
+  subst h
+  rfl
+
+private theorem mem_range_of_eval_eq_const {F L : Type*} [Field F] [Field L] [Algebra F L]
+    (g : Polynomial F) (x : L) (s : Finset L) (hcard : g.natDegree < s.card)
+    (hval : ∀ y ∈ s, Polynomial.aeval y g = x) : x ∈ (algebraMap F L).range := by
+  classical
+  set i := algebraMap F L
+  set Q : Polynomial L := g.map i - Polynomial.C x with hQ
+  have hQdeg : Q.natDegree ≤ g.natDegree := by
+    refine (Polynomial.natDegree_sub_le _ _).trans ?_
+    rw [Polynomial.natDegree_map, Polynomial.natDegree_C, max_eq_left (Nat.zero_le _)]
+  have hQ0 : Q = 0 := by
+    refine Polynomial.eq_zero_of_natDegree_lt_card_of_eval_eq_zero' Q s (fun y hy => ?_)
+      (hQdeg.trans_lt hcard)
+    rw [hQ, Polynomial.eval_sub, Polynomial.eval_C, Polynomial.eval_map_algebraMap,
+      hval y hy, sub_self]
+  have hconst : g.map i = Polynomial.C x := sub_eq_zero.mp hQ0
+  refine ⟨g.coeff 0, ?_⟩
+  have h2 := congrArg (fun P : Polynomial L => P.coeff 0) hconst
+  simpa only [Polynomial.coeff_map, Polynomial.coeff_C_zero] using h2
+
+private theorem tight_one : Module.finrank ℚ⟮jq⟯
+    (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN 1} : Set (LaurentSeries ℚ)))
+    = ModularCurve.dedekindPsi 1 := by
+  have h1 : jqN 1 = jq := by rw [jqN, qExpand_one_apply]
+  rw [h1, ModularCurve.dedekindPsi_one]
+  have h2 : IntermediateField.adjoin ℚ⟮jq⟯ ({jq} : Set (LaurentSeries ℚ))
+      = (⊥ : IntermediateField ℚ⟮jq⟯ (LaurentSeries ℚ)) := by
+    rw [IntermediateField.adjoin_simple_eq_bot_iff, IntermediateField.mem_bot]
+    exact ⟨jGen, rfl⟩
+  rw [h2]
+  exact IntermediateField.finrank_bot
+
+private theorem gen_one : modularFunctionField 1 = modularFunctionFieldFull 1 := by
+  refine le_antisymm (modularFunctionField_le_full 1) ?_
+  rw [modularFunctionFieldFull, IntermediateField.adjoin_le_iff]
+  rintro x ⟨d, hne, hdvd, rfl⟩
+  have := hne
+  have hd1 : d = 1 := Nat.dvd_one.mp hdvd
+  subst hd1
+  rw [qExpand_one_apply]
+  exact jq_mem 1
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one \
+  evalAtJ_X ModularPolynomialData modularFunctionField jq_mem jGen modularFunctionFieldFull \
+  jqd_mem_full modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm finrank_adjoin_jqN_eq_of_prime \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime functionFieldGeneration_of_squarefree \
+  functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime~coeffEmb_qExpand~jqN_prime_not_mem_adjoin"
+
+section RValCore
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem map_qExpand_minpoly_eq {M' : ℕ} [NeZero M'] (k : ℕ) [NeZero k] {N : ℕ}
+    [NeZero N] (hN : N = k * M') (ζ' : Kˣ)
+    (hid : (minpoly ℚ⟮jq⟯ (jqN M')).map
+        (((coeffEmb K).comp (qExpand ℚ M')).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))
+      = ∏ a ∈ M'.divisors, ∏ b ∈ (Finset.range (M' / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M' / a) = 1),
+          (Polynomial.X - Polynomial.C (sv K ζ' a b))) :
+    (minpoly ℚ⟮jq⟯ (jqN M')).map
+        (((coeffEmb K).comp (qExpand ℚ N)).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))
+      = ∏ a ∈ M'.divisors, ∏ b ∈ (Finset.range (M' / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M' / a) = 1),
+          (Polynomial.X - Polynomial.C (qExpand K k (sv K ζ' a b))) := by
+  subst hN
+  have hcomp : (qExpand K k).comp (((coeffEmb K).comp (qExpand ℚ M')).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))
+      = ((coeffEmb K).comp (qExpand ℚ (k * M'))).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) := by
+    refine RingHom.ext fun z => ?_
+    simp only [RingHom.comp_apply]
+    rw [coeffEmb_qExpand, qExpand_qExpand, ← coeffEmb_qExpand]
+  have h1 : (minpoly ℚ⟮jq⟯ (jqN M')).map (((coeffEmb K).comp (qExpand ℚ (k * M'))).comp (algebraMap
+    ℚ⟮jq⟯ (LaurentSeries ℚ))) = ((minpoly ℚ⟮jq⟯ (jqN M')).map (((coeffEmb K).comp (qExpand ℚ
+    M')).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).map (qExpand K k) :=
+    by
+    rw [Polynomial.map_map, hcomp]
+  rw [h1, hid, Polynomial.map_prod]
+  refine Finset.prod_congr rfl fun a _ => ?_
+  rw [Polynomial.map_prod]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C]
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+private theorem rval_aux : ∀ (M : ℕ) [NeZero M] {K : Type*} [Field K] [Algebra ℚ K]
+    (ζ : Kˣ), IsPrimitiveRoot ((ζ : Kˣ) : K) M →
+    (∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank ℚ⟮jq⟯
+          (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN d} : Set (LaurentSeries ℚ))) = dedekindPsi d
+        ∧ modularFunctionField d = modularFunctionFieldFull d) →
+    (minpoly ℚ⟮jq⟯ (jqN M)).map
+        (((coeffEmb K).comp (qExpand ℚ M)).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))
+      = ∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+          (Polynomial.X - Polynomial.C (sv K ζ a b)) := by
+  intro M
+  induction M using Nat.strong_induction_on with
+  | _ M IH =>
+  intro _ K _ _ ζ hζ hall
+  classical
+  have hM0 : M ≠ 0 := NeZero.ne M
+  have hslot_root : ∀ a b : ℕ, a ∈ M.divisors →
+      b ∈ (Finset.range (M / a)).filter (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1) →
+      ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ M)).comp
+        (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).IsRoot (sv K ζ a b) := by
+    intro a b ha hb
+    obtain ⟨haM, -⟩ := Nat.mem_divisors.mp ha
+    obtain ⟨hbr, hbc⟩ := Finset.mem_filter.mp hb
+    rw [Finset.mem_range] at hbr
+    have ha0 : a ≠ 0 := by
+      rintro rfl
+      exact hM0 (Nat.eq_zero_of_zero_dvd haM)
+    have : NeZero a := ⟨ha0⟩
+    have had : a * (M / a) = M := Nat.mul_div_cancel' haM
+    by_cases hd1 : M / a = 1
+    · have haM' : a = M := by rw [hd1, mul_one] at had; exact had
+      have hb0 : b = 0 := by omega
+      subst hb0
+      rw [show sv K ζ a 0 = sv K ζ M 0 from by rw [haM'], sv_top,
+        show coeffEmb K (qExpand ℚ M (jqN M))
+          = ((coeffEmb K).comp (qExpand ℚ M)) (jqN M) from rfl]
+      rw [Polynomial.IsRoot, Polynomial.eval_map, ← Polynomial.hom_eval₂]
+      have h0 : Polynomial.eval₂ (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) (jqN M)
+          (minpoly ℚ⟮jq⟯ (jqN M)) = 0 := by
+        rw [← Polynomial.aeval_def]
+        exact minpoly.aeval _ _
+      rw [h0, map_zero]
+    · have hd0 : M / a ≠ 0 := by
+        intro h0
+        rw [h0, mul_zero] at had
+        exact hM0 had.symm
+      have hpp : (M / a).minFac.Prime := Nat.minFac_prime hd1
+      have : Fact (M / a).minFac.Prime := ⟨hpp⟩
+      have : NeZero (M / a).minFac := ⟨hpp.ne_zero⟩
+      obtain ⟨d'', hdd⟩ : (M / a).minFac ∣ M / a := Nat.minFac_dvd _
+      set p := (M / a).minFac with hp_def
+      have hd''0 : d'' ≠ 0 := by
+        rintro rfl
+        rw [mul_zero] at hdd
+        exact hd0 hdd
+      have : NeZero d'' := ⟨hd''0⟩
+      have hM'0 : a * d'' ≠ 0 := Nat.mul_ne_zero ha0 hd''0
+      have : NeZero (a * d'') := ⟨hM'0⟩
+      have hMM' : M = a * d'' * p := by rw [← had, hdd]; ring
+      have hM'M : a * d'' ∣ M := ⟨p, hMM'⟩
+      have hM'lt : a * d'' < M := by
+        calc a * d'' = a * d'' * 1 := by ring
+          _ < a * d'' * p :=
+              (Nat.mul_lt_mul_left (Nat.pos_of_ne_zero hM'0)).mpr hpp.one_lt
+          _ = M := hMM'.symm
+      have hpM : p ∣ M := by
+        have hpd : p ∣ M / a := ⟨d'', hdd⟩
+        exact hpd.trans (Nat.div_dvd_of_dvd haM)
+      have hb''lt : b % d'' < d'' := Nat.mod_lt b (Nat.pos_of_ne_zero hd''0)
+      have hbsplit : b % d'' + b / d'' * d'' = b := Nat.mod_add_div' b d''
+      have hc₀p : b / d'' < p := by
+        have h1 : b < d'' * p := by rw [Nat.mul_comm d'' p, ← hdd]; exact hbr
+        exact Nat.div_lt_of_lt_mul h1
+      have hprim' : Nat.gcd (Nat.gcd a (b % d'')) d'' = 1 := by
+        have h1 : Nat.gcd (Nat.gcd a (b % d'')) d'' ∣ Nat.gcd (Nat.gcd a b) (M / a) := by
+          refine Nat.dvd_gcd (Nat.dvd_gcd ?_ ?_) ?_
+          · exact (Nat.gcd_dvd_left _ _).trans (Nat.gcd_dvd_left a (b % d''))
+          · have hgb'' : Nat.gcd (Nat.gcd a (b % d'')) d'' ∣ b % d'' :=
+              (Nat.gcd_dvd_left _ _).trans (Nat.gcd_dvd_right a (b % d''))
+            have hgd'' : Nat.gcd (Nat.gcd a (b % d'')) d'' ∣ d'' := Nat.gcd_dvd_right _ _
+            have h2 : Nat.gcd (Nat.gcd a (b % d'')) d'' ∣ b % d'' + b / d'' * d'' :=
+              Nat.dvd_add hgb'' (hgd''.mul_left _)
+            rwa [hbsplit] at h2
+          · rw [hdd]
+            exact (Nat.gcd_dvd_right _ _).mul_left p
+        rw [hbc] at h1
+        exact Nat.dvd_one.mp h1
+      have hζ' : IsPrimitiveRoot ((ζ ^ p : Kˣ) : K) (a * d'') := by
+        have h1 := isPrimitiveRoot_pow_div hζ hM'M
+        have h2 : M / (a * d'') = p := by
+          rw [hMM']
+          exact Nat.mul_div_cancel_left p (Nat.pos_of_ne_zero hM'0)
+        rwa [h2] at h1
+      have hIH := IH (a * d'') hM'lt (ζ ^ p) hζ' (fun e he _ => hall e (he.trans hM'M))
+      have hIHM := map_qExpand_minpoly_eq p (show M = p * (a * d'') from by rw [hMM']; ring)
+        (ζ ^ p) hIH
+      have hroot' : ((minpoly ℚ⟮jq⟯ (jqN (a * d''))).map (((coeffEmb K).comp
+          (qExpand ℚ M)).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).IsRoot
+          (qExpand K p (sv K (ζ ^ p) a (b % d''))) := by
+        rw [hIHM, Polynomial.IsRoot, Polynomial.eval_prod]
+        refine Finset.prod_eq_zero (Nat.mem_divisors.mpr ⟨⟨d'', rfl⟩, hM'0⟩) ?_
+        rw [Polynomial.eval_prod]
+        have hM'a : a * d'' / a = d'' := Nat.mul_div_cancel_left d'' (Nat.pos_of_ne_zero ha0)
+        refine Finset.prod_eq_zero (i := b % d'') ?_ ?_
+        · rw [hM'a]
+          exact Finset.mem_filter.mpr ⟨Finset.mem_range.mpr hb''lt, hprim'⟩
+        · rw [Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, sub_self]
+      let : Algebra ℚ⟮jq⟯ (LaurentSeries K) :=
+        (((coeffEmb K).comp (qExpand ℚ M)).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ))).toAlgebra
+      have halg : algebraMap ℚ⟮jq⟯ (LaurentSeries K)
+          = ((coeffEmb K).comp (qExpand ℚ M)).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) :=
+        RingHom.algebraMap_toAlgebra _
+      obtain ⟨htM', hgM'⟩ := hall (a * d'') hM'M
+      have hfd' : FiniteDimensional ℚ⟮jq⟯
+          (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN (a * d'')} : Set (LaurentSeries ℚ))) :=
+        FiniteDimensional.of_finrank_pos (htM' ▸ dedekindPsi_pos hM'0)
+      have hα' : IsIntegral ℚ⟮jq⟯ (jqN (a * d'')) :=
+        IntermediateField.isIntegral_iff.mp (IsIntegral.of_finite ℚ⟮jq⟯
+          (⟨jqN (a * d''), IntermediateField.subset_adjoin ℚ⟮jq⟯ _ rfl⟩ :
+            IntermediateField.adjoin ℚ⟮jq⟯ ({jqN (a * d'')} : Set (LaurentSeries ℚ))))
+      have hy_mem : qExpand K p (sv K (ζ ^ p) a (b % d''))
+          ∈ (minpoly ℚ⟮jq⟯ (jqN (a * d''))).aroots (LaurentSeries K) := by
+        rw [Polynomial.mem_aroots]
+        refine ⟨minpoly.ne_zero hα', ?_⟩
+        rw [Polynomial.aeval_def, halg, Polynomial.eval₂_eq_eval_map]
+        exact hroot'
+      obtain ⟨ψ₁, hψ₁⟩ : ∃ ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →ₐ[ℚ⟮jq⟯] LaurentSeries K,
+          ψ₁ (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN (a * d'')))
+            = qExpand K p (sv K (ζ ^ p) a (b % d'')) :=
+        ⟨(IntermediateField.algHomAdjoinIntegralEquiv ℚ⟮jq⟯ hα').symm ⟨_, hy_mem⟩,
+          IntermediateField.algHomAdjoinIntegralEquiv_symm_apply_gen ℚ⟮jq⟯ hα' ⟨_, hy_mem⟩⟩
+      obtain ⟨dp, hdpirr, hdpsym⟩ := ModularCurve.exists_phiIrreducible_evalSymm p
+      have hup : (phiAtSeed dp (jqN (a * d''))).eval (jqN M) = 0 := by
+        have h1 := phiAtSeed_jqN_eval p dp (a * d'')
+        rwa [show jqN (a * d'' * p) = jqN M from jqN_congr hMM'.symm] at h1
+      have haev : Polynomial.aeval (jqN M)
+          (phiAtSeed dp (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN (a * d'')))) = 0 := by
+        rw [Polynomial.aeval_def, Polynomial.eval₂_eq_eval_map, phiAtSeed_map]
+        exact hup
+      have hα₁ : IsIntegral ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M) :=
+        ⟨phiAtSeed dp (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN (a * d''))),
+          phiAtSeed_monic dp _, by rw [← Polynomial.aeval_def]; exact haev⟩
+      have hmindvd : minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)
+          ∣ phiAtSeed dp (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN (a * d''))) :=
+        minpoly.dvd _ _ haev
+      have htow := Module.finrank_mul_finrank ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯
+        ℚ⟮jq⟯⟮jqN (a * d'')⟯⟮jqN M⟯
+      have habs : IntermediateField.adjoin ℚ⟮jq⟯
+          (({jqN (a * d'')} : Set (LaurentSeries ℚ)) ∪ {jqN M})
+          = IntermediateField.adjoin ℚ⟮jq⟯ ({jqN M} : Set (LaurentSeries ℚ)) := by
+        obtain ⟨-, hgM⟩ := hall M dvd_rfl
+        refine le_antisymm (IntermediateField.adjoin_le_iff.mpr ?_)
+          (IntermediateField.adjoin.mono _ _ _ Set.subset_union_right)
+        rintro z (hz | hz)
+        · rw [Set.mem_singleton_iff] at hz
+          subst hz
+          have h1 : jqN (a * d'') ∈ modularFunctionFieldFull M := jqd_mem_full M hM'M
+          rw [← hgM] at h1
+          exact mem_adjoin_jqN_of_mem_mff h1
+        · rw [Set.mem_singleton_iff] at hz
+          subst hz
+          exact IntermediateField.subset_adjoin _ _ rfl
+      have htop : Module.finrank ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯⟮jqN M⟯ = dedekindPsi M := by
+        obtain ⟨htM, -⟩ := hall M dvd_rfl
+        have h1 := IntermediateField.adjoin_adjoin_left ℚ⟮jq⟯
+          ({jqN (a * d'')} : Set (LaurentSeries ℚ)) {jqN M}
+        have h2 : Module.finrank ℚ⟮jq⟯
+            (IntermediateField.restrictScalars ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯⟮jqN M⟯)
+            = Module.finrank ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯⟮jqN M⟯ := rfl
+        rw [← h2, h1, habs]
+        exact htM
+      have hstep_deg : Module.finrank ℚ⟮jq⟯⟮jqN (a * d'')⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯⟮jqN M⟯
+          * dedekindPsi (a * d'') = dedekindPsi M := by
+        rw [← htM', ← htop, Nat.mul_comm]
+        exact htow
+      have hseed : qExpand K p (sv K (ζ ^ p) a (b % d''))
+          = qExpand K (p * (a * a)) (qTwist ((ζ ^ (b % d'' * a)) ^ p) (coeffEmb K jq)) := by
+        rw [sv_eq_TS, qExpand_TS]
+        suffices TS K (p * (a * a)) ((ζ ^ p) ^ (b % d'' * a))
+          = TS K (p * (a * a)) ((ζ ^ (b % d'' * a)) ^ p) by
+          simpa only [TS_eq_coeffEmb] using this
+        exact TS_congr' rfl (by rw [← pow_mul, ← pow_mul, Nat.mul_comm])
+      have hC5 := ModularCurve.PhiGen.splits_prime_at_slot M ζ hζ p hpM dp (a * a)
+        (ζ ^ (b % d'' * a))
+      have hΦfact : phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d'')))
+          = (Polynomial.X - Polynomial.C (qExpand K (p * (p * (a * a)))
+              (qTwist ((ζ ^ (b % d'' * a)) ^ (p * p)) (coeffEmb K jq))))
+            * ∏ c ∈ Finset.range p, (Polynomial.X - Polynomial.C (qExpand K (a * a)
+              (qTwist (ζ ^ (b % d'' * a) * ζ ^ (c * (M / p))) (coeffEmb K jq)))) := by
+        rw [hseed]
+        exact hC5
+      have hMp : M / p = a * d'' := by
+        rw [hMM']
+        exact Nat.mul_div_cancel _ hpp.pos
+      have htarget : qExpand K (a * a) (qTwist (ζ ^ (b % d'' * a) * ζ ^ (b / d'' * (M / p)))
+          (coeffEmb K jq)) = sv K ζ a b := by
+        rw [sv_eq]
+        suffices TS K (a * a) (ζ ^ (b % d'' * a) * ζ ^ (b / d'' * (M / p)))
+          = TS K (a * a) (ζ ^ (b * a)) by
+          simpa only [TS_eq_coeffEmb] using this
+        refine TS_congr' rfl ?_
+        rw [hMp, ← pow_add]
+        congr 1
+        rw [show b % d'' * a + b / d'' * (a * d'')
+          = (b % d'' + b / d'' * d'') * a from by ring, hbsplit]
+      by_cases hpM' : p ∣ a * d''
+      · have hψM : dedekindPsi M = dedekindPsi (a * d'') * p := by
+          rw [hMM']
+          exact dedekindPsi_mul_prime_dvd hM'0 hpp hpM'
+        have he : Module.finrank ℚ⟮jq⟯⟮jqN (a * d'')⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯⟮jqN M⟯ = p := by
+          have h1 : Module.finrank ℚ⟮jq⟯⟮jqN (a * d'')⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯⟮jqN M⟯
+              * dedekindPsi (a * d'') = p * dedekindPsi (a * d'') := by
+            rw [hstep_deg, hψM]
+            ring
+          exact Nat.eq_of_mul_eq_mul_right (dedekindPsi_pos hM'0) h1
+        obtain ⟨m'', hm''⟩ := hpM'
+        have hm''0 : m'' ≠ 0 := by
+          rintro rfl
+          rw [mul_zero] at hm''
+          exact hM'0 hm''
+        have : NeZero m'' := ⟨hm''0⟩
+        have hm''M : m'' ∣ M := ⟨p * p, by rw [hMM', hm'']; ring⟩
+        have hm''lt : m'' < M := by
+          calc m'' ≤ a * d'' := by rw [hm'']; exact Nat.le_mul_of_pos_left m'' hpp.pos
+            _ < M := hM'lt
+        have hdown : (phiAtSeed dp (jqN (a * d''))).eval (jqN m'') = 0 := by
+          rw [phiAtSeed_eval_symm dp hdpsym]
+          have h1 := phiAtSeed_jqN_eval p dp m''
+          rwa [show jqN (m'' * p) = jqN (a * d'') from jqN_congr (by rw [hm'']; ring)] at h1
+        have hmem'' : jqN m'' ∈ ℚ⟮jq⟯⟮jqN (a * d'')⟯ := by
+          have h1 : jqN m'' ∈ modularFunctionFieldFull (a * d'') :=
+            jqd_mem_full (a * d'') ⟨p, by rw [hm'']; ring⟩
+          rw [← hgM'] at h1
+          exact mem_adjoin_jqN_of_mem_mff h1
+        have hdownF₁ : (phiAtSeed dp (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯
+            (jqN (a * d'')))).eval (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯) = 0 :=
+          phiAtSeed_eval_of_injective dp _ _
+            (algebraMap ℚ⟮jq⟯⟮jqN (a * d'')⟯ (LaurentSeries ℚ)) (RingHom.injective _) hdown
+        have hψx'' : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d'')))).IsRoot
+            (ψ₁ (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯)) := by
+          have h1 := phiAtSeed_eval_map dp _ _
+            (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K) hdownF₁
+          rw [show (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)
+            (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN (a * d'')))
+            = qExpand K p (sv K (ζ ^ p) a (b % d'')) from hψ₁] at h1
+          exact h1
+        have hx''notmin : ¬ (minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).IsRoot
+            (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯) := by
+          intro hcon
+          obtain ⟨q, hq⟩ := Polynomial.dvd_iff_isRoot.mpr hcon
+          have hirr := minpoly.irreducible hα₁
+          rcases hirr.isUnit_or_isUnit hq with hu | hu
+          · exact Polynomial.not_isUnit_X_sub_C _ hu
+          · have hq0 : q ≠ 0 := by
+              rintro rfl
+              rw [mul_zero] at hq
+              exact minpoly.ne_zero hα₁ hq
+            have hdm : (minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).natDegree = 1 := by
+              rw [hq, Polynomial.natDegree_mul (Polynomial.X_sub_C_ne_zero _) hq0,
+                Polynomial.natDegree_X_sub_C, Polynomial.natDegree_eq_zero_of_isUnit hu]
+            have hdm' : (minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).natDegree = p := by
+              rw [← IntermediateField.adjoin.finrank hα₁]
+              exact he
+            rw [hdm] at hdm'
+            exact (Nat.ne_of_lt hpp.one_lt) hdm'
+        have hψx''notmin : ¬ ((minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).map
+            (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)).IsRoot
+            (ψ₁ (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯)) := by
+          intro hcon
+          refine hx''notmin ?_
+          rw [Polynomial.IsRoot, Polynomial.eval_map,
+            show ψ₁ (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯)
+              = (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)
+                (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯) from rfl,
+            Polynomial.eval₂_hom] at hcon
+          exact (injective_iff_map_eq_zero _).mp
+            (RingHom.injective (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)) _ hcon
+        have htarget_ne : sv K ζ a b ≠ ψ₁ (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯) := by
+          intro hcon
+          have hroot'' : ((minpoly ℚ⟮jq⟯ (jqN m'')).map (((coeffEmb K).comp
+              (qExpand ℚ M)).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).IsRoot
+              (ψ₁ (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯)) := by
+            have h1 : Polynomial.aeval (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯)
+                (minpoly ℚ⟮jq⟯ (jqN m'')) = 0 := by
+              refine aeval_intermediateField_eq_zero ?_
+              change Polynomial.aeval (jqN m'') (minpoly ℚ⟮jq⟯ (jqN m'')) = 0
+              exact minpoly.aeval _ _
+            have h2 := Polynomial.aeval_algHom_apply ψ₁
+              (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯) (minpoly ℚ⟮jq⟯ (jqN m''))
+            rw [h1, map_zero] at h2
+            rw [Polynomial.aeval_def, halg, Polynomial.eval₂_eq_eval_map] at h2
+            exact h2
+          have hζ'' : IsPrimitiveRoot ((ζ ^ (p * p) : Kˣ) : K) m'' := by
+            have h1 := isPrimitiveRoot_pow_div hζ hm''M
+            have h2 : M / m'' = p * p := by
+              rw [hMM', hm'', show p * m'' * p = m'' * (p * p) from by ring]
+              exact Nat.mul_div_cancel_left _ (Nat.pos_of_ne_zero hm''0)
+            rwa [h2] at h1
+          have hIH'' := IH m'' hm''lt (ζ ^ (p * p)) hζ''
+            (fun e he'' _ => hall e (he''.trans hm''M))
+          have hIHM'' := map_qExpand_minpoly_eq (p * p)
+            (show M = p * p * m'' from by rw [hMM', hm'']; ring) (ζ ^ (p * p)) hIH''
+          rw [hIHM''] at hroot''
+          rw [Polynomial.IsRoot, Polynomial.eval_prod] at hroot''
+          obtain ⟨α, hαmem, hα0⟩ := Finset.prod_eq_zero_iff.mp hroot''
+          rw [Polynomial.eval_prod] at hα0
+          obtain ⟨β, hβmem, hβ0⟩ := Finset.prod_eq_zero_iff.mp hα0
+          rw [Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, sub_eq_zero] at hβ0
+          obtain ⟨hαdvd, -⟩ := Nat.mem_divisors.mp hαmem
+          obtain ⟨hβr, -⟩ := Finset.mem_filter.mp hβmem
+          rw [Finset.mem_range] at hβr
+          have hα0' : α ≠ 0 := by
+            rintro rfl
+            exact hm''0 (Nat.eq_zero_of_zero_dvd hαdvd)
+          have : NeZero α := ⟨hα0'⟩
+          have hcoll : TS K (a * a) (ζ ^ (b * a))
+              = TS K (p * p * (α * α)) (ζ ^ (p * p * (β * α))) := by
+            calc TS K (a * a) (ζ ^ (b * a)) = sv K ζ a b := (sv_eq_TS ζ a b).symm
+              _ = ψ₁ (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯) := hcon
+              _ = qExpand K (p * p) (sv K (ζ ^ (p * p)) α β) := hβ0
+              _ = qExpand K (p * p) (TS K (α * α) ((ζ ^ (p * p)) ^ (β * α))) := by
+                  rw [sv_eq_TS]
+              _ = TS K (p * p * (α * α)) ((ζ ^ (p * p)) ^ (β * α)) := qExpand_TS _ _ _
+              _ = TS K (p * p * (α * α)) (ζ ^ (p * p * (β * α))) :=
+                  TS_congr' rfl (by rw [← pow_mul])
+          obtain ⟨hexp, hunit⟩ := TS_injective hcoll
+          have haα : a = p * α := by
+            have h2 : a * a = (p * α) * (p * α) := by rw [hexp]; ring
+            exact (mul_self_inj (Nat.zero_le _) (Nat.zero_le _)).mp h2
+          have hpa : p ∣ a := ⟨α, haα⟩
+          have hba : b * a < M := by
+            calc b * a < M / a * a :=
+                (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr
+              _ = M := by rw [Nat.mul_comm] at had; exact had
+          have hppβα : p * p * (β * α) < M := by
+            have h1 : β * α < m'' := by
+              calc β * α < m'' / α * α :=
+                  (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero hα0')).mpr hβr
+                _ ≤ m'' := Nat.div_mul_le_self m'' α
+            calc p * p * (β * α) < p * p * m'' :=
+                (Nat.mul_lt_mul_left (Nat.mul_pos hpp.pos hpp.pos)).mpr h1
+              _ = M := by rw [hMM', hm'']; ring
+          have hvv : ((ζ : K)) ^ (b * a) = ((ζ : K)) ^ (p * p * (β * α)) := by
+            have h1 := congrArg Units.val hunit
+            rwa [Units.val_pow_eq_pow_val, Units.val_pow_eq_pow_val] at h1
+          have hexp2 : b * a = p * p * (β * α) := hζ.pow_inj hba hppβα hvv
+          have hpb : p ∣ b := by
+            refine ⟨β, ?_⟩
+            rw [haα] at hexp2
+            have h1 : b * (p * α) = p * β * (p * α) := by
+              rw [hexp2]
+              ring
+            exact Nat.eq_of_mul_eq_mul_right (Nat.mul_pos hpp.pos
+              (Nat.pos_of_ne_zero hα0')) h1
+          have hfinal : p ∣ Nat.gcd (Nat.gcd a b) (M / a) :=
+            Nat.dvd_gcd (Nat.dvd_gcd hpa hpb) ⟨d'', hdd⟩
+          rw [hbc] at hfinal
+          exact hpp.ne_one (Nat.dvd_one.mp hfinal)
+        have hQ : (Polynomial.X - Polynomial.C (ψ₁ (⟨jqN m'', hmem''⟩ :
+            ℚ⟮jq⟯⟮jqN (a * d'')⟯))) * (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+            (Polynomial.X - Polynomial.C (ψ₁ (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯))))
+            = phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) :=
+          Polynomial.mul_divByMonic_eq_iff_isRoot.mpr hψx''
+        have hΦmonic : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d'')))).Monic :=
+          phiAtSeed_monic dp _
+        have hQmonic : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+            (Polynomial.X - Polynomial.C (ψ₁ (⟨jqN m'', hmem''⟩ :
+              ℚ⟮jq⟯⟮jqN (a * d'')⟯)))).Monic :=
+          Polynomial.Monic.of_mul_monic_left (Polynomial.monic_X_sub_C _)
+            (by rw [hQ]; exact hΦmonic)
+        have hΦdeg : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d'')))).natDegree
+            = p + 1 := by
+          rw [phiAtSeed_natDegree]
+          exact dedekindPsi_prime p hpp
+        have hQdeg : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+            (Polynomial.X - Polynomial.C (ψ₁ (⟨jqN m'', hmem''⟩ :
+              ℚ⟮jq⟯⟮jqN (a * d'')⟯)))).natDegree = p := by
+          have h1 : p + 1 = 1 + (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+              (Polynomial.X - Polynomial.C (ψ₁ (⟨jqN m'', hmem''⟩ :
+                ℚ⟮jq⟯⟮jqN (a * d'')⟯)))).natDegree := by
+            rw [← hΦdeg]
+            conv_lhs => rw [← hQ]
+            rw [Polynomial.natDegree_mul (Polynomial.X_sub_C_ne_zero _) hQmonic.ne_zero,
+              Polynomial.natDegree_X_sub_C]
+          omega
+        have hP₁dvd : (minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).map
+            (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)
+            ∣ phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) := by
+          have h1 := Polynomial.map_dvd (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K) hmindvd
+          rwa [phiAtSeed_map, show (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)
+            (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN (a * d'')))
+            = qExpand K p (sv K (ζ ^ p) a (b % d'')) from hψ₁] at h1
+        have hcop : IsCoprime (Polynomial.X - Polynomial.C (ψ₁ (⟨jqN m'', hmem''⟩ :
+            ℚ⟮jq⟯⟮jqN (a * d'')⟯)))
+            ((minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).map
+              (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)) := by
+          rw [(Polynomial.irreducible_X_sub_C _).coprime_iff_not_dvd]
+          intro hcon
+          exact hψx''notmin (Polynomial.dvd_iff_isRoot.mp hcon)
+        have hP₁dvdQ : (minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).map
+            (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)
+            ∣ phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+              (Polynomial.X - Polynomial.C (ψ₁ (⟨jqN m'', hmem''⟩ :
+                ℚ⟮jq⟯⟮jqN (a * d'')⟯))) := by
+          have h1 := hP₁dvd
+          rw [← hQ] at h1
+          exact (hcop.symm).dvd_of_dvd_mul_left h1
+        have hdeg₁ : ((minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).map
+            (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)).natDegree = p := by
+          rw [Polynomial.Monic.natDegree_map (minpoly.monic hα₁),
+            ← IntermediateField.adjoin.finrank hα₁]
+          exact he
+        have hmineqQ : (minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).map
+            (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)
+            = phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d''))) /ₘ
+              (Polynomial.X - Polynomial.C (ψ₁ (⟨jqN m'', hmem''⟩ :
+                ℚ⟮jq⟯⟮jqN (a * d'')⟯))) :=
+          Polynomial.eq_of_monic_of_dvd_of_natDegree_le ((minpoly.monic hα₁).map _)
+            hQmonic hP₁dvdQ (le_of_eq (hQdeg.trans hdeg₁.symm)) |>.symm
+        have htargetΦ : (phiAtSeed dp (qExpand K p (sv K (ζ ^ p) a (b % d'')))).IsRoot
+            (sv K ζ a b) := by
+          rw [hΦfact, Polynomial.IsRoot, Polynomial.eval_mul]
+          refine mul_eq_zero.mpr (Or.inr ?_)
+          rw [Polynomial.eval_prod]
+          refine Finset.prod_eq_zero (Finset.mem_range.mpr hc₀p) ?_
+          rw [htarget, Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, sub_self]
+        have hroot_step : ((minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).map
+            (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)).IsRoot (sv K ζ a b) := by
+          rw [hmineqQ, Polynomial.IsRoot]
+          have h1 : ((Polynomial.X - Polynomial.C (ψ₁ (⟨jqN m'', hmem''⟩ :
+              ℚ⟮jq⟯⟮jqN (a * d'')⟯))) * (phiAtSeed dp (qExpand K p
+              (sv K (ζ ^ p) a (b % d''))) /ₘ (Polynomial.X - Polynomial.C
+              (ψ₁ (⟨jqN m'', hmem''⟩ : ℚ⟮jq⟯⟮jqN (a * d'')⟯))))).eval (sv K ζ a b) = 0 := by
+            rw [hQ]
+            exact htargetΦ
+          rw [Polynomial.eval_mul, Polynomial.eval_sub, Polynomial.eval_X,
+            Polynomial.eval_C] at h1
+          rcases mul_eq_zero.mp h1 with h2 | h2
+          · exact absurd (sub_eq_zero.mp h2) htarget_ne
+          · exact h2
+        have htowdvd : minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)
+            ∣ (minpoly ℚ⟮jq⟯ (jqN M)).map (algebraMap ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯) :=
+          minpoly.dvd_map_of_isScalarTower ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)
+        have h1 := Polynomial.map_dvd (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K) htowdvd
+        rw [Polynomial.map_map] at h1
+        have h2 : (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K).comp
+            (algebraMap ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯)
+            = ((coeffEmb K).comp (qExpand ℚ M)).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) := by
+          rw [AlgHom.comp_algebraMap]
+          exact halg
+        rw [h2] at h1
+        exact Polynomial.eval_eq_zero_of_dvd_of_eval_eq_zero h1 hroot_step
+      · have hψM : dedekindPsi M = dedekindPsi (a * d'') * (p + 1) := by
+          rw [hMM']
+          exact dedekindPsi_mul_prime_not_dvd hpp hpM'
+        have he : Module.finrank ℚ⟮jq⟯⟮jqN (a * d'')⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯⟮jqN M⟯
+            = p + 1 := by
+          have h1 : Module.finrank ℚ⟮jq⟯⟮jqN (a * d'')⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯⟮jqN M⟯
+              * dedekindPsi (a * d'') = (p + 1) * dedekindPsi (a * d'') := by
+            rw [hstep_deg, hψM]
+            ring
+          exact Nat.eq_of_mul_eq_mul_right (dedekindPsi_pos hM'0) h1
+        have hdeg₁ : (minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).natDegree = p + 1 := by
+          rw [← IntermediateField.adjoin.finrank hα₁]
+          exact he
+        have hΦdeg : (phiAtSeed dp (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯
+            (jqN (a * d'')))).natDegree = p + 1 := by
+          rw [phiAtSeed_natDegree]
+          exact dedekindPsi_prime p hpp
+        have hmineq : minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)
+            = phiAtSeed dp (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN (a * d''))) :=
+          Polynomial.eq_of_monic_of_dvd_of_natDegree_le (minpoly.monic hα₁)
+            (phiAtSeed_monic dp _) hmindvd (le_of_eq (hΦdeg.trans hdeg₁.symm)) |>.symm
+        have hroot_step : ((minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)).map
+            (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)).IsRoot (sv K ζ a b) := by
+          rw [hmineq, phiAtSeed_map, show (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K)
+            (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN (a * d'')))
+            = qExpand K p (sv K (ζ ^ p) a (b % d'')) from hψ₁]
+          rw [hΦfact, Polynomial.IsRoot, Polynomial.eval_mul]
+          refine mul_eq_zero.mpr (Or.inr ?_)
+          rw [Polynomial.eval_prod]
+          refine Finset.prod_eq_zero (Finset.mem_range.mpr hc₀p) ?_
+          rw [htarget, Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, sub_self]
+        have htowdvd : minpoly ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)
+            ∣ (minpoly ℚ⟮jq⟯ (jqN M)).map (algebraMap ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯) :=
+          minpoly.dvd_map_of_isScalarTower ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯ (jqN M)
+        have h1 := Polynomial.map_dvd (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K) htowdvd
+        rw [Polynomial.map_map] at h1
+        have h2 : (ψ₁ : ℚ⟮jq⟯⟮jqN (a * d'')⟯ →+* LaurentSeries K).comp
+            (algebraMap ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN (a * d'')⟯)
+            = ((coeffEmb K).comp (qExpand ℚ M)).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) := by
+          rw [AlgHom.comp_algebraMap]
+          exact halg
+        rw [h2] at h1
+        exact Polynomial.eval_eq_zero_of_dvd_of_eval_eq_zero h1 hroot_step
+  by_cases hM1 : M = 1
+  · subst hM1
+    have hjq1 : jqN 1 = algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ) jGen := by
+      rw [show jqN 1 = jq from by rw [jqN, qExpand_one_apply]]
+      rfl
+    have hmin : minpoly ℚ⟮jq⟯ (jqN 1) = Polynomial.X - Polynomial.C jGen := by
+      rw [hjq1]
+      exact minpoly.eq_X_sub_C (B := LaurentSeries ℚ) jGen
+    have hfil : (Finset.range (1 / 1)).filter
+        (fun b => Nat.gcd (Nat.gcd 1 b) (1 / 1) = 1) = {0} := by decide
+    rw [hmin, Polynomial.map_sub, Polynomial.map_X, Polynomial.map_C, Nat.divisors_one,
+      Finset.prod_singleton, hfil, Finset.prod_singleton]
+    congr 1
+    have h1 : (((coeffEmb K).comp (qExpand ℚ 1)).comp
+        (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ))) jGen = coeffEmb K jq := by
+      simp only [RingHom.comp_apply]
+      rw [show (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) jGen = jq from rfl, qExpand_one_apply]
+    rw [h1]
+    have : NeZero (1 : ℕ) := ⟨one_ne_zero⟩
+    have h2 : sv K ζ 1 0 = coeffEmb K jq := by
+      rw [sv_eq_TS]
+      have h3 : TS K (1 * 1) (ζ ^ (0 * 1)) = TS K 1 1 :=
+        TS_congr' (Nat.mul_one 1) (by rw [Nat.zero_mul, pow_zero])
+      rw [h3, TS_eq_coeffEmb, qTwist_one_apply, qExpand_one_apply]
+    rw [h2]
+  · obtain ⟨htM, -⟩ := hall M dvd_rfl
+    have hfd : FiniteDimensional ℚ⟮jq⟯
+        (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN M} : Set (LaurentSeries ℚ))) :=
+      FiniteDimensional.of_finrank_pos (htM ▸ dedekindPsi_pos hM0)
+    have hα : IsIntegral ℚ⟮jq⟯ (jqN M) :=
+      IntermediateField.isIntegral_iff.mp (IsIntegral.of_finite ℚ⟮jq⟯
+        (⟨jqN M, IntermediateField.subset_adjoin ℚ⟮jq⟯ _ rfl⟩ :
+          IntermediateField.adjoin ℚ⟮jq⟯ ({jqN M} : Set (LaurentSeries ℚ))))
+    have hdeg : (minpoly ℚ⟮jq⟯ (jqN M)).natDegree = dedekindPsi M := by
+      rw [← IntermediateField.adjoin.finrank hα]
+      exact htM
+    set T : Multiset (LaurentSeries K) := M.divisors.val.bind
+      (fun a => ((Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map (fun b => sv K ζ a b)) with hT
+    have hTcard : Multiset.card T = dedekindPsi M := by
+      rw [hT, Multiset.card_bind]
+      have h2 : M.divisors.val.map (Multiset.card ∘ fun a => (((Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map (fun b => sv K ζ a b)))
+          = M.divisors.val.map (fun a => slotAt M (M / a)) := by
+        refine Multiset.map_congr rfl ?_
+        intro a ha
+        change Multiset.card (((Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map (fun b => sv K ζ a b))
+          = slotAt M (M / a)
+        rw [Multiset.card_map]
+        change ((Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).card = slotAt M (M / a)
+        unfold slotAt
+        rw [Nat.div_div_self (Nat.mem_divisors.mp (Finset.mem_val.mp ha)).1 hM0]
+      rw [h2]
+      change (∑ a ∈ M.divisors, slotAt M (M / a)) = dedekindPsi M
+      rw [Nat.sum_div_divisors M (slotAt M)]
+      exact slots_eq_dedekindPsi M hM0
+    have hmem_unpack : ∀ x ∈ T, ∃ a b : ℕ, a ∈ M.divisors ∧
+        b ∈ (Finset.range (M / a)).filter (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1) ∧
+        x = sv K ζ a b := by
+      intro x hx
+      rw [hT, Multiset.mem_bind] at hx
+      obtain ⟨a, ha, hx2⟩ := hx
+      rw [Multiset.mem_map] at hx2
+      obtain ⟨b, hb, rfl⟩ := hx2
+      exact ⟨a, b, ha, hb, rfl⟩
+    have hTnodup : T.Nodup := by
+      rw [hT]
+      rw [Multiset.nodup_bind]
+      constructor
+      · intro a ha
+        refine Multiset.Nodup.map_on ?_ (Finset.filter _ _).nodup
+        intro b hb b' hb' hvv
+        have ha0 : a ≠ 0 := by
+          rintro rfl
+          exact hM0 (Nat.eq_zero_of_zero_dvd (Nat.mem_divisors.mp (by exact ha)).1)
+        have hbr := Finset.mem_range.mp (Finset.mem_filter.mp (by exact hb)).1
+        have hbr' := Finset.mem_range.mp (Finset.mem_filter.mp (by exact hb')).1
+        have haM := (Nat.mem_divisors.mp (by exact ha)).1
+        have had : M / a * a = M := Nat.div_mul_cancel haM
+        have hba : b * a < M := by
+          calc b * a < M / a * a :=
+              (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr
+            _ = M := had
+        have hba' : b' * a < M := by
+          calc b' * a < M / a * a :=
+              (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr'
+            _ = M := had
+        exact (sv_inj hζ ha0 ha0 hba hba' hvv).2
+      · refine Multiset.Nodup.pairwise ?_ M.divisors.nodup
+        intro a ha a' ha' hne
+        change Disjoint (((Finset.range (M / a)).filter
+            (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map (fun b => sv K ζ a b))
+          (((Finset.range (M / a')).filter
+            (fun b => Nat.gcd (Nat.gcd a' b) (M / a') = 1)).val.map (fun b => sv K ζ a' b))
+        rw [Multiset.disjoint_left]
+        intro x hx hx'
+        rw [Multiset.mem_map] at hx hx'
+        obtain ⟨b, hb, hxb⟩ := hx
+        obtain ⟨b', hb', hxb'⟩ := hx'
+        have haM := (Nat.mem_divisors.mp (Finset.mem_val.mp ha)).1
+        have haM' := (Nat.mem_divisors.mp (Finset.mem_val.mp ha')).1
+        have ha0 : a ≠ 0 := by
+          rintro rfl
+          exact hM0 (Nat.eq_zero_of_zero_dvd haM)
+        have ha0' : a' ≠ 0 := by
+          rintro rfl
+          exact hM0 (Nat.eq_zero_of_zero_dvd haM')
+        have hbr := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb)).1
+        have hbr' := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb')).1
+        have hba : b * a < M := by
+          calc b * a < M / a * a :=
+              (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr
+            _ = M := Nat.div_mul_cancel haM
+        have hba' : b' * a' < M := by
+          calc b' * a' < M / a' * a' :=
+              (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0')).mpr hbr'
+            _ = M := Nat.div_mul_cancel haM'
+        have hvv : sv K ζ a b = sv K ζ a' b' := by rw [hxb, ← hxb']
+        exact hne (sv_inj hζ ha0 ha0' hba hba' hvv).1
+    have hPne : (minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ M)).comp
+        (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ))) ≠ 0 :=
+      ((minpoly.monic hα).map _).ne_zero
+    have hPdeg : ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ M)).comp
+        (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).natDegree = dedekindPsi M := by
+      rw [Polynomial.Monic.natDegree_map (minpoly.monic hα)]
+      exact hdeg
+    have hTle : T ≤ ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ M)).comp
+        (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).roots := by
+      rw [Multiset.le_iff_count]
+      intro x
+      by_cases hx : x ∈ T
+      · have h1 : Multiset.count x T ≤ 1 := Multiset.nodup_iff_count_le_one.mp hTnodup x
+        have h2 : 1 ≤ Multiset.count x (((minpoly ℚ⟮jq⟯ (jqN M)).map
+            (((coeffEmb K).comp (qExpand ℚ M)).comp
+              (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).roots) := by
+          rw [Multiset.one_le_count_iff_mem, Polynomial.mem_roots']
+          obtain ⟨a, b, ha, hb, rfl⟩ := hmem_unpack x hx
+          exact ⟨hPne, hslot_root a b ha hb⟩
+        omega
+      · rw [Multiset.count_eq_zero.mpr hx]
+        exact Nat.zero_le _
+    have hroots_eq : ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ M)).comp
+        (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).roots = T := by
+      refine (Multiset.eq_of_le_of_card_le hTle ?_).symm
+      rw [hTcard]
+      calc Multiset.card (((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp
+            (qExpand ℚ M)).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).roots)
+          ≤ ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ M)).comp
+            (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).natDegree := Polynomial.card_roots' _
+        _ = dedekindPsi M := hPdeg
+    have hsp : Polynomial.Splits ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp
+        (qExpand ℚ M)).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))) := by
+      rw [Polynomial.splits_iff_card_roots, hroots_eq, hTcard, hPdeg]
+    have hfact := hsp.eq_prod_roots_of_monic ((minpoly.monic hα).map _)
+    rw [hfact, hroots_eq, hT, Multiset.map_bind, Multiset.prod_bind]
+    change (M.divisors.val.map fun a => ((((Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+        (fun b => sv K ζ a b)).map (fun r => Polynomial.X - Polynomial.C r)).prod).prod
+      = ∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+          (Polynomial.X - Polynomial.C (sv K ζ a b))
+    simp only [Multiset.map_map, Function.comp]
+    rfl
+
+end RValCore
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one \
+  evalAtJ_X ModularPolynomialData modularFunctionField jq_mem jGen modularFunctionFieldFull \
+  jqd_mem_full modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm finrank_adjoin_jqN_eq_of_prime \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime functionFieldGeneration_of_squarefree \
+  functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~dedekindPsi_prime~coeffEmb_qExpand~jqN_prime_not_mem_adjoin"
+
+section NonMem0
+
+open IntermediateField
+
+
+private theorem jqN_prime_not_mem_adjoin (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (hpM : ¬ p ∣ M)
+    (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank ℚ⟮jq⟯
+          (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN d} : Set (LaurentSeries ℚ))) = dedekindPsi d
+        ∧ modularFunctionField d = modularFunctionFieldFull d) :
+    jqN p ∉ IntermediateField.adjoin ℚ⟮jq⟯ ({jqN M} : Set (LaurentSeries ℚ)) := by
+  classical
+  intro hmem
+  have hM0 : M ≠ 0 := NeZero.ne M
+  have hp0 : p ≠ 0 := hp.out.ne_zero
+  have : NeZero p := ⟨hp0⟩
+  have : NeZero (M * p) := ⟨Nat.mul_ne_zero hM0 hp0⟩
+  set K := CyclotomicField (M * p) ℚ with hK
+  have hζ : IsPrimitiveRoot ((cycUnit (M * p) : Kˣ) : K) (M * p) := cycUnit_spec (M * p)
+  have hζM : IsPrimitiveRoot (((cycUnit (M * p) : Kˣ) ^ p : Kˣ) : K) M := by
+    have h1 := isPrimitiveRoot_pow_div hζ (⟨p, rfl⟩ : M ∣ M * p)
+    have h2 : M * p / M = p := Nat.mul_div_cancel_left p (Nat.pos_of_ne_zero hM0)
+    rwa [h2] at h1
+  have hζp : IsPrimitiveRoot (((cycUnit (M * p) : Kˣ) ^ M : Kˣ) : K) p := by
+    have h1 := isPrimitiveRoot_pow_div hζ (⟨M, Nat.mul_comm M p⟩ : p ∣ M * p)
+    have h2 : M * p / p = M := Nat.mul_div_cancel M (Nat.pos_of_ne_zero hp0)
+    rwa [h2] at h1
+  obtain ⟨htM, -⟩ := hall M dvd_rfl
+  have hfd : FiniteDimensional ℚ⟮jq⟯
+      (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN M} : Set (LaurentSeries ℚ))) :=
+    FiniteDimensional.of_finrank_pos (htM ▸ dedekindPsi_pos hM0)
+  have hα : IsIntegral ℚ⟮jq⟯ (jqN M) :=
+    IntermediateField.isIntegral_iff.mp (IsIntegral.of_finite ℚ⟮jq⟯
+      (⟨jqN M, IntermediateField.subset_adjoin ℚ⟮jq⟯ _ rfl⟩ :
+        IntermediateField.adjoin ℚ⟮jq⟯ ({jqN M} : Set (LaurentSeries ℚ))))
+  have hdeg : (minpoly ℚ⟮jq⟯ (jqN M)).natDegree = dedekindPsi M := by
+    rw [← IntermediateField.adjoin.finrank hα]
+    exact htM
+  have hallp : ∀ d : ℕ, d ∣ p → ∀ [NeZero d],
+      Module.finrank ℚ⟮jq⟯
+          (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN d} : Set (LaurentSeries ℚ))) = dedekindPsi d
+        ∧ modularFunctionField d = modularFunctionFieldFull d := by
+    intro d hd _
+    rcases (Nat.Prime.eq_one_or_self_of_dvd hp.out d hd) with h1 | h2
+    · subst h1
+      exact ⟨tight_one, gen_one⟩
+    · have h2' := h2.symm
+      subst h2'
+      constructor
+      · rw [dedekindPsi_prime p hp.out]
+        exact ModularCurve.finrank_adjoin_jqN_eq_of_prime p
+      · exact ((ModularCurve.functionFieldGeneration_iff_full_eq p).mp
+          (ModularCurve.functionFieldGeneration_of_squarefree p
+            hp.out.prime.squarefree)).symm
+  have hidMB := map_qExpand_minpoly_eq p (show M * p = p * M from Nat.mul_comm M p)
+    ((cycUnit (M * p) : Kˣ) ^ p)
+    (rval_aux M ((cycUnit (M * p) : Kˣ) ^ p) hζM hall)
+  have hidpB := map_qExpand_minpoly_eq M rfl ((cycUnit (M * p) : Kˣ) ^ M)
+    (rval_aux p ((cycUnit (M * p) : Kˣ) ^ M) hζp hallp)
+  let : Algebra ℚ⟮jq⟯ (LaurentSeries K) :=
+    (((coeffEmb K).comp (qExpand ℚ (M * p))).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ))).toAlgebra
+  have halg : algebraMap ℚ⟮jq⟯ (LaurentSeries K)
+      = ((coeffEmb K).comp (qExpand ℚ (M * p))).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) :=
+    RingHom.algebraMap_toAlgebra _
+  have hιS : ∀ w : LaurentSeries ℚ, coeffEmb K (qExpand ℚ (M * p) w)
+      = qExpand K p (coeffEmb K (qExpand ℚ M w)) := by
+    intro w
+    rw [← coeffEmb_qExpand, qExpand_qExpand]
+    exact congrArg (coeffEmb K) (qExpand_congr (Nat.mul_comm M p) w)
+  set T' : Multiset (LaurentSeries K) := M.divisors.val.bind
+    (fun a => ((Finset.range (M / a)).filter
+      (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+      (fun b => qExpand K p (sv K ((cycUnit (M * p) : Kˣ) ^ p) a b))) with hT'
+  have hT'card : Multiset.card T' = dedekindPsi M := by
+    rw [hT', Multiset.card_bind]
+    have h2 : M.divisors.val.map (Multiset.card ∘ fun a => (((Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+        (fun b => qExpand K p (sv K ((cycUnit (M * p) : Kˣ) ^ p) a b))))
+        = M.divisors.val.map (fun a => slotAt M (M / a)) := by
+      refine Multiset.map_congr rfl ?_
+      intro a ha
+      change Multiset.card (((Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+        (fun b => qExpand K p (sv K ((cycUnit (M * p) : Kˣ) ^ p) a b)))
+        = slotAt M (M / a)
+      rw [Multiset.card_map]
+      change ((Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).card = slotAt M (M / a)
+      unfold slotAt
+      rw [Nat.div_div_self (Nat.mem_divisors.mp (Finset.mem_val.mp ha)).1 hM0]
+    rw [h2]
+    change (∑ a ∈ M.divisors, slotAt M (M / a)) = dedekindPsi M
+    rw [Nat.sum_div_divisors M (slotAt M)]
+    exact slots_eq_dedekindPsi M hM0
+  have hT'nodup : T'.Nodup := by
+    rw [hT', Multiset.nodup_bind]
+    constructor
+    · intro a ha
+      refine Multiset.Nodup.map_on ?_ (Finset.filter _ _).nodup
+      intro b hb b' hb' hvv
+      have haM := (Nat.mem_divisors.mp (Finset.mem_val.mp ha)).1
+      have ha0 : a ≠ 0 := by
+        rintro rfl
+        exact hM0 (Nat.eq_zero_of_zero_dvd haM)
+      have hbr := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb)).1
+      have hbr' := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb')).1
+      have hba : b * a < M := by
+        calc b * a < M / a * a :=
+            (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr
+          _ = M := Nat.div_mul_cancel haM
+      have hba' : b' * a < M := by
+        calc b' * a < M / a * a :=
+            (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr'
+          _ = M := Nat.div_mul_cancel haM
+      have hsv : sv K ((cycUnit (M * p) : Kˣ) ^ p) a b
+          = sv K ((cycUnit (M * p) : Kˣ) ^ p) a b' :=
+        RingHom.injective (qExpand K p) hvv
+      exact (sv_inj hζM ha0 ha0 hba hba' hsv).2
+    · refine Multiset.Nodup.pairwise ?_ M.divisors.nodup
+      intro a ha a' ha' hne
+      change Disjoint (((Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+          (fun b => qExpand K p (sv K ((cycUnit (M * p) : Kˣ) ^ p) a b)))
+        (((Finset.range (M / a')).filter
+          (fun b => Nat.gcd (Nat.gcd a' b) (M / a') = 1)).val.map
+          (fun b => qExpand K p (sv K ((cycUnit (M * p) : Kˣ) ^ p) a' b)))
+      rw [Multiset.disjoint_left]
+      intro x hx hx'
+      rw [Multiset.mem_map] at hx hx'
+      obtain ⟨b, hb, hxb⟩ := hx
+      obtain ⟨b', hb', hxb'⟩ := hx'
+      have haM := (Nat.mem_divisors.mp (Finset.mem_val.mp ha)).1
+      have haM' := (Nat.mem_divisors.mp (Finset.mem_val.mp ha')).1
+      have ha0 : a ≠ 0 := by
+        rintro rfl
+        exact hM0 (Nat.eq_zero_of_zero_dvd haM)
+      have ha0' : a' ≠ 0 := by
+        rintro rfl
+        exact hM0 (Nat.eq_zero_of_zero_dvd haM')
+      have hbr := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb)).1
+      have hbr' := Finset.mem_range.mp (Finset.mem_filter.mp (Finset.mem_val.mp hb')).1
+      have hba : b * a < M := by
+        calc b * a < M / a * a :=
+            (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0)).mpr hbr
+          _ = M := Nat.div_mul_cancel haM
+      have hba' : b' * a' < M := by
+        calc b' * a' < M / a' * a' :=
+            (Nat.mul_lt_mul_right (Nat.pos_of_ne_zero ha0')).mpr hbr'
+          _ = M := Nat.div_mul_cancel haM'
+      have hvv : qExpand K p (sv K ((cycUnit (M * p) : Kˣ) ^ p) a b)
+          = qExpand K p (sv K ((cycUnit (M * p) : Kˣ) ^ p) a' b') := by
+        rw [hxb, ← hxb']
+      exact hne (sv_inj hζM ha0 ha0' hba hba'
+        (RingHom.injective (qExpand K p) hvv)).1
+  have hglue : ∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+      (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+      (Polynomial.X - Polynomial.C (qExpand K p (sv K ((cycUnit (M * p) : Kˣ) ^ p) a b)))
+      = (T'.map (fun r => Polynomial.X - Polynomial.C r)).prod := by
+    rw [hT', Multiset.map_bind, Multiset.prod_bind]
+    change (∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+        (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+        (Polynomial.X - Polynomial.C (qExpand K p
+          (sv K ((cycUnit (M * p) : Kˣ) ^ p) a b))))
+      = (M.divisors.val.map fun a => ((((Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1)).val.map
+          (fun b => qExpand K p (sv K ((cycUnit (M * p) : Kˣ) ^ p) a b))).map
+          (fun r => Polynomial.X - Polynomial.C r)).prod).prod
+    simp only [Multiset.map_map, Function.comp]
+    rfl
+  have hroots : ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp
+      (qExpand ℚ (M * p))).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).roots = T' := by
+    rw [hidMB, hglue]
+    exact Polynomial.roots_multiset_prod_X_sub_C T'
+  set s : Finset (LaurentSeries K) := T'.toFinset with hs
+  have hscard : s.card = dedekindPsi M := by
+    rw [hs, Multiset.toFinset_card_of_nodup hT'nodup]
+    exact hT'card
+  obtain ⟨g, hg⟩ : ∃ g : Polynomial ℚ⟮jq⟯, Polynomial.aeval (jqN M) g = jqN p := by
+    have h1 := IntermediateField.adjoin_simple_toSubalgebra_of_isAlgebraic
+      hα.isAlgebraic
+    have h2 : jqN p ∈ Algebra.adjoin ℚ⟮jq⟯ ({jqN M} : Set (LaurentSeries ℚ)) := by
+      rw [← h1]
+      exact hmem
+    rw [Algebra.adjoin_singleton_eq_range_aeval] at h2
+    obtain ⟨g, hg⟩ := h2
+    exact ⟨g, hg⟩
+  set g' := g %ₘ (minpoly ℚ⟮jq⟯ (jqN M)) with hg'def
+  have hg' : Polynomial.aeval (jqN M) g' = jqN p := by
+    have hsplit := Polynomial.modByMonic_add_div g (minpoly ℚ⟮jq⟯ (jqN M))
+    have h4 := congrArg (Polynomial.aeval (jqN M)) hsplit
+    rw [map_add, map_mul, minpoly.aeval, zero_mul, add_zero] at h4
+    rw [hg'def, h4]
+    exact hg
+  have hdegpos : 0 < (minpoly ℚ⟮jq⟯ (jqN M)).natDegree := by
+    rw [hdeg]
+    exact dedekindPsi_pos hM0
+  have hg'deg : g'.natDegree < s.card := by
+    rw [hscard, ← hdeg]
+    rcases eq_or_ne g' 0 with h0 | h0
+    · rw [h0, Polynomial.natDegree_zero]
+      exact hdegpos
+    · exact Polynomial.natDegree_lt_natDegree h0
+        (Polynomial.degree_modByMonic_lt g (minpoly.monic hα))
+  have hval : ∀ y ∈ s, Polynomial.aeval y g'
+      = coeffEmb K (qExpand ℚ (M * p) (jqN p)) := by
+    intro y hy
+    have hyT' : y ∈ T' := Multiset.mem_toFinset.mp hy
+    obtain ⟨a₀, ha₀, hy2⟩ := Multiset.mem_bind.mp hyT'
+    obtain ⟨b₀, hb₀, hyval⟩ := Multiset.mem_map.mp hy2
+    have hyS : y ∈ (qExpand K p).fieldRange := by
+      rw [← hyval]
+      exact RingHom.mem_fieldRange.mpr ⟨sv K ((cycUnit (M * p) : Kˣ) ^ p) a₀ b₀, rfl⟩
+    have hy_ar : y ∈ (minpoly ℚ⟮jq⟯ (jqN M)).aroots (LaurentSeries K) := by
+      rw [Polynomial.aroots_def, halg, hroots]
+      exact hyT'
+    obtain ⟨ψy, hψy⟩ : ∃ ψy : ℚ⟮jq⟯⟮jqN M⟯ →ₐ[ℚ⟮jq⟯] LaurentSeries K,
+        ψy (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN M)) = y :=
+      ⟨(IntermediateField.algHomAdjoinIntegralEquiv ℚ⟮jq⟯ hα).symm ⟨y, hy_ar⟩,
+        IntermediateField.algHomAdjoinIntegralEquiv_symm_apply_gen ℚ⟮jq⟯ hα ⟨y, hy_ar⟩⟩
+    have hψgen : ∀ h : jqN M ∈ IntermediateField.adjoin ℚ⟮jq⟯
+        ({jqN M} : Set (LaurentSeries ℚ)), ψy ⟨jqN M, h⟩ = y := by
+      intro h
+      exact hψy
+    have himg : ∀ (x : LaurentSeries ℚ)
+        (hx : x ∈ IntermediateField.adjoin ℚ⟮jq⟯ ({jqN M} : Set (LaurentSeries ℚ))),
+        ψy ⟨x, hx⟩ ∈ (qExpand K p).fieldRange := by
+      intro x hx
+      induction hx using IntermediateField.adjoin_induction with
+      | mem z hz =>
+          rw [Set.mem_singleton_iff] at hz
+          subst hz
+          rw [hψgen]
+          exact hyS
+      | algebraMap z =>
+          change ψy (algebraMap ℚ⟮jq⟯ ℚ⟮jq⟯⟮jqN M⟯ z) ∈ (qExpand K p).fieldRange
+          rw [AlgHom.commutes, halg]
+          change coeffEmb K (qExpand ℚ (M * p)
+            ((algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) z)) ∈ (qExpand K p).fieldRange
+          rw [hιS]
+          exact RingHom.mem_fieldRange.mpr ⟨_, rfl⟩
+      | add x₁ x₂ hx₁ hx₂ ih₁ ih₂ =>
+          change ψy ⟨x₁ + x₂, add_mem hx₁ hx₂⟩ ∈ (qExpand K p).fieldRange
+          rw [show (⟨x₁ + x₂, add_mem hx₁ hx₂⟩ : ℚ⟮jq⟯⟮jqN M⟯)
+            = ⟨x₁, hx₁⟩ + ⟨x₂, hx₂⟩ from rfl, map_add]
+          exact Subfield.add_mem _ ih₁ ih₂
+      | mul x₁ x₂ hx₁ hx₂ ih₁ ih₂ =>
+          change ψy ⟨x₁ * x₂, mul_mem hx₁ hx₂⟩ ∈ (qExpand K p).fieldRange
+          rw [show (⟨x₁ * x₂, mul_mem hx₁ hx₂⟩ : ℚ⟮jq⟯⟮jqN M⟯)
+            = ⟨x₁, hx₁⟩ * ⟨x₂, hx₂⟩ from rfl, map_mul]
+          exact Subfield.mul_mem _ ih₁ ih₂
+      | inv x₁ hx₁ ih₁ =>
+          show ψy ⟨x₁⁻¹, inv_mem hx₁⟩ ∈ (qExpand K p).fieldRange
+          rw [show (⟨x₁⁻¹, inv_mem hx₁⟩ : ℚ⟮jq⟯⟮jqN M⟯)
+            = (⟨x₁, hx₁⟩ : ℚ⟮jq⟯⟮jqN M⟯)⁻¹ from rfl, map_inv₀]
+          exact Subfield.inv_mem _ ih₁
+    have hx_pS : ψy ⟨jqN p, hmem⟩ ∈ (qExpand K p).fieldRange := himg _ hmem
+    have hx_proot : ((minpoly ℚ⟮jq⟯ (jqN p)).map (((coeffEmb K).comp
+        (qExpand ℚ (M * p))).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))).IsRoot
+        (ψy ⟨jqN p, hmem⟩) := by
+      have h1 : Polynomial.aeval (⟨jqN p, hmem⟩ : ℚ⟮jq⟯⟮jqN M⟯)
+          (minpoly ℚ⟮jq⟯ (jqN p)) = 0 := by
+        refine aeval_intermediateField_eq_zero ?_
+        change Polynomial.aeval (jqN p) (minpoly ℚ⟮jq⟯ (jqN p)) = 0
+        exact minpoly.aeval _ _
+      have h2 := Polynomial.aeval_algHom_apply ψy (⟨jqN p, hmem⟩ : ℚ⟮jq⟯⟮jqN M⟯)
+        (minpoly ℚ⟮jq⟯ (jqN p))
+      rw [h1, map_zero] at h2
+      rw [Polynomial.aeval_def, halg, Polynomial.eval₂_eq_eval_map] at h2
+      exact h2
+    rw [hidpB, Polynomial.IsRoot, Polynomial.eval_prod] at hx_proot
+    obtain ⟨α, hαmem, hα0⟩ := Finset.prod_eq_zero_iff.mp hx_proot
+    rw [Polynomial.eval_prod] at hα0
+    obtain ⟨β, hβmem, hβ0⟩ := Finset.prod_eq_zero_iff.mp hα0
+    rw [Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C, sub_eq_zero] at hβ0
+    obtain ⟨hαdvd, -⟩ := Nat.mem_divisors.mp hαmem
+    obtain ⟨hβr, -⟩ := Finset.mem_filter.mp hβmem
+    rw [Finset.mem_range] at hβr
+    rcases (Nat.Prime.eq_one_or_self_of_dvd hp.out α hαdvd) with hα1 | hα2
+    · subst hα1
+      exfalso
+      have : NeZero (1 : ℕ) := ⟨one_ne_zero⟩
+      have hv1 : qExpand K M (sv K ((cycUnit (M * p) : Kˣ) ^ M) 1 β)
+          = TS K M (((cycUnit (M * p) : Kˣ) ^ M) ^ (β * 1)) := by
+        rw [sv_eq_TS, qExpand_TS]
+        exact TS_congr' (by ring) rfl
+      obtain ⟨w, hw⟩ := RingHom.mem_fieldRange.mp hx_pS
+      have hw2 : qExpand K p w = TS K M (((cycUnit (M * p) : Kˣ) ^ M) ^ (β * 1)) := by
+        rw [hw, hβ0, hv1]
+      have hnd : ¬ ((p : ℤ) ∣ (-(M : ℤ))) := by
+        rw [dvd_neg, Int.natCast_dvd_natCast]
+        exact hpM
+      have hz1 : (qExpand K p w).coeff (-(M : ℤ)) = 0 :=
+        qExpand_coeff_of_not_dvd (R := K) (N := p) w hnd
+      have hz2 : (TS K M (((cycUnit (M * p) : Kˣ) ^ M) ^ (β * 1))).coeff (-(M : ℤ))
+          = (((((cycUnit (M * p) : Kˣ) ^ M) ^ (β * 1))⁻¹ : Kˣ) : K) :=
+        TS_coeff_neg M _
+      rw [hw2, hz2] at hz1
+      exact Units.ne_zero _ hz1
+    · have hα2' := hα2.symm
+      subst hα2'
+      have hβ0' : β = 0 := by
+        have h3 : p / p = 1 := Nat.div_self hp.out.pos
+        omega
+      subst hβ0'
+      have hsp : qExpand K M (sv K ((cycUnit (M * p) : Kˣ) ^ M) p 0)
+          = coeffEmb K (qExpand ℚ (M * p) (jqN p)) := by
+        rw [sv_eq_TS, qExpand_TS, iota_jqN (M * p) p]
+        exact TS_congr' (by ring) (by rw [zero_mul, pow_zero])
+      have hx_pval : ψy ⟨jqN p, hmem⟩ = coeffEmb K (qExpand ℚ (M * p) (jqN p)) := by
+        rw [hβ0, hsp]
+      have hgE : Polynomial.aeval (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN M)) g'
+          = (⟨jqN p, hmem⟩ : ℚ⟮jq⟯⟮jqN M⟯) := by
+        have h3 := Polynomial.aeval_algHom_apply (IntermediateField.val ℚ⟮jq⟯⟮jqN M⟯)
+          (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN M)) g'
+        refine Subtype.ext ?_
+        change ((Polynomial.aeval (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN M)) g' :
+          ℚ⟮jq⟯⟮jqN M⟯) : LaurentSeries ℚ) = jqN p
+        rw [show ((Polynomial.aeval (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN M)) g' :
+          ℚ⟮jq⟯⟮jqN M⟯) : LaurentSeries ℚ)
+          = (IntermediateField.val ℚ⟮jq⟯⟮jqN M⟯)
+            (Polynomial.aeval (IntermediateField.AdjoinSimple.gen ℚ⟮jq⟯ (jqN M)) g')
+          from rfl, ← h3]
+        exact hg'
+      rw [← hψy, Polynomial.aeval_algHom_apply, hgE, hx_pval]
+  obtain ⟨z, hz⟩ := mem_range_of_eval_eq_const g'
+    (coeffEmb K (qExpand ℚ (M * p) (jqN p))) s hg'deg hval
+  rw [halg] at hz
+  have hzval : (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) z = jqN p := by
+    apply RingHom.injective ((coeffEmb K).comp (qExpand ℚ (M * p)))
+    exact hz
+  have hjpF : jqN p ∈ ℚ⟮jq⟯ := by
+    rw [← hzval]
+    exact z.2
+  have hbot : IntermediateField.adjoin ℚ⟮jq⟯ ({jqN p} : Set (LaurentSeries ℚ))
+      = (⊥ : IntermediateField ℚ⟮jq⟯ (LaurentSeries ℚ)) := by
+    rw [IntermediateField.adjoin_simple_eq_bot_iff, IntermediateField.mem_bot]
+    exact ⟨⟨jqN p, hjpF⟩, rfl⟩
+  have h1 : Module.finrank ℚ⟮jq⟯
+      (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN p} : Set (LaurentSeries ℚ))) = 1 := by
+    rw [hbot]
+    exact IntermediateField.finrank_bot
+  have h2 := ModularCurve.finrank_adjoin_jqN_eq_of_prime p
+  rw [h1] at h2
+  have h3 := hp.out.two_le
+  omega
+
+end NonMem0
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_congr qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one \
+  evalAtJ_X ModularPolynomialData modularFunctionField jq_mem jGen modularFunctionFieldFull \
+  jqd_mem_full modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand \
+  PhiGen.splits_prime_at_slot exists_phiIrreducible_evalSymm finrank_adjoin_jqN_eq_of_prime \
+  dedekindPsi_prime_pow dedekindPsi_mul_of_coprime functionFieldGeneration_of_squarefree \
+  functionFieldGeneration_iff_full_eq"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.minpoly_jqN_map_eq_prod_slots {K : Type*} [Field K] [Algebra ℚ K]
+    (M : ℕ) [NeZero M] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) M)
+    (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+          (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+            ({jqN d} : Set (LaurentSeries ℚ))) = dedekindPsi d
+        ∧ modularFunctionField d = modularFunctionFieldFull d) :
+    (minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN M)).map
+        (((coeffEmb K).comp (qExpand ℚ M)).comp
+          (algebraMap (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+            (LaurentSeries ℚ)))
+      = ∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter
+          (fun b => Nat.gcd (Nat.gcd a b) (M / a) = 1),
+          (Polynomial.X - Polynomial.C (if h : a = 0 then 0 else
+            letI : NeZero a := ⟨h⟩
+            qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)))) :=
+  ModularCurve.W1.rval_aux M ζ hζ hall
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.jqN_prime_not_mem_full (M : ℕ) [NeZero M] (p : ℕ)
+    [hp : Fact (Nat.Prime p)] (hpM : ¬ p ∣ M)
+    (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+          (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+            ({jqN d} : Set (LaurentSeries ℚ))) = dedekindPsi d
+        ∧ modularFunctionField d = modularFunctionFieldFull d) :
+    jqN p ∉ modularFunctionFieldFull M := by
+  intro hmem0
+  obtain ⟨-, hgM⟩ := hall M dvd_rfl
+  have hmem : jqN p ∈ IntermediateField.adjoin
+      (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      ({jqN M} : Set (LaurentSeries ℚ)) := by
+    rw [← hgM] at hmem0
+    exact ModularCurve.W1.mem_adjoin_jqN_of_mem_mff hmem0
+  exact ModularCurve.W1.jqN_prime_not_mem_adjoin M p hpM hall hmem
+
+end
+
+p2m_open "ModularCurve~dedekindPsi_prime~coeffEmb_qExpand~jqN_prime_not_mem_adjoin\
+  " in
+open _root_.P2MW.S_ModularCurve_minpoly_jqN_map_eq_prod_slots.ModularCurve in
+theorem solution {K : Type*} [Field K] [Algebra ℚ K] (M : ℕ) [NeZero M] (ζ : Kˣ) (hζ :
+  IsPrimitiveRoot (ζ : K) M) (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d], Module.finrank
+  (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (IntermediateField.adjoin
+  (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) ({jqN d} : Set (LaurentSeries ℚ))) =
+  dedekindPsi d ∧ modularFunctionField d = modularFunctionFieldFull d) :
+    (minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN M)).map (((coeffEmb
+      K).comp (qExpand ℚ M)).comp (algebraMap (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries
+      ℚ))) (LaurentSeries ℚ))) = ∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter (fun b =>
+      Nat.gcd (Nat.gcd a b) (M / a) = 1), (Polynomial.X - Polynomial.C (if h : a = 0 then 0 else
+      letI : NeZero a := ⟨h⟩; qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)))) :=
+  ModularCurve.minpoly_jqN_map_eq_prod_slots M ζ hζ hall
+
+end S_ModularCurve_minpoly_jqN_map_eq_prod_slots
+end P2MW
+export P2MW.S_ModularCurve_minpoly_jqN_map_eq_prod_slots (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.minpoly_jqN_map_eq_prod_slots {K : Type*} [Field K] [Algebra ℚ K] (M : ℕ)
+  [NeZero M] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) M) (hall : ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+  Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+  (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) ({jqN d} :
+  Set (LaurentSeries ℚ))) = dedekindPsi d ∧ modularFunctionField d = modularFunctionFieldFull d) :
+    (minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN M)).map (((coeffEmb
+      K).comp (qExpand ℚ M)).comp (algebraMap (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries
+      ℚ))) (LaurentSeries ℚ))) = ∏ a ∈ M.divisors, ∏ b ∈ (Finset.range (M / a)).filter (fun b =>
+      Nat.gcd (Nat.gcd a b) (M / a) = 1), (Polynomial.X - Polynomial.C (if h : a = 0 then 0 else
+      letI : NeZero a := ⟨h⟩; qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)))) :=
+  solution M ζ hζ hall
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_modularFunctionFieldBar_eq_restrictScalars.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_modularFunctionFieldBar_eq_restrictScalars.lean
new file mode 100644
index 0000000000..46b33b469d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_modularFunctionFieldBar_eq_restrictScalars.lean
@@ -0,0 +1,355 @@
+/-
+Based on Prove2Me node ModularCurve.modularFunctionFieldBar_eq_restrictScalars
+(c1dd7cec-923f-5cfd-b3b4-f3c231e4ab4b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7ed1f8ba-fb2d-5e16-a90e-288062d83082
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_AtkinLehner
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ModularUnit
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CuspidalClass
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_cuspInftyBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_order_coeffEmb
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coe_frickeInvolutionFull_modularUnitSeries
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularUnitSeries_mem_modularFunctionFieldFull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_adjoin_jq_modularUnitSeries
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_adjoin_jq_modularUnitSeries_inv
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_eq_zero_of_isIntegral_adjoin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_smul_of_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isIntegral_adjoin_map_algHom
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isIntegral_adjoin_of_isScalarTower
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isIntegral_adjoin_intermediateField_mk
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_iff_ord_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Pic0_zsmul_mk_eq_zero_of_isPrincipal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Pic0_addOrderOf_mk_dvd_of_isPrincipal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isFrickeAutFull_frickeInvolutionFull_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_eq_cuspInftyBar_or_eq_cuspZeroBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_injective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_cuspZeroBar_ne_cuspInftyBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_modularFunctionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_full_eq_of_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_modularPolynomialData_of_squarefree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_adjoin_jqNModC
+import Mathlib.Algebra.Algebra.Rat
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCusp_cuspZeroBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCusp_cuspInftyBar
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Geometric function field of X₀(ℓ) as ℚ̄(j)(j_ℓ)
+
+Theorem statement: `ModularCurve.modularFunctionFieldBar_eq_restrictScalars`
+(`c1dd7cec-923f-5cfd-b3b4-f3c231e4ab4b`), by Claude, 2026-09-05.
+
+Proof: submission `7ed1f8ba-fb2d-5e16-a90e-288062d83082`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a prime. Write $\bar{\mathbb{Q}}$ for `AlgebraicClosure ℚ` and work inside the Laurent
+series field $\bar{\mathbb{Q}}((q))$ (`LaurentSeries (AlgebraicClosure ℚ)`). On one side stands
+`modularFunctionFieldBar ℓ`, by definition the base change `laurentBaseChange` of
+`modularFunctionFieldFull ℓ`: that is, the intermediate field of $\bar{\mathbb{Q}}((q))$ over
+$\bar{\mathbb{Q}}$ generated by the image, under the coefficientwise embedding `coeffEmb` of
+$\mathbb{Q}((q))$ into $\bar{\mathbb{Q}}((q))$, of the field `modularFunctionFieldFull ℓ`, itself
+the subfield of $\mathbb{Q}((q))$ obtained by adjoining to $\mathbb{Q}$ the set `divisorExpansions
+ℓ`. On the other side stands the two-step simple adjunction: first adjoin to $\bar{\mathbb{Q}}$ the
+series `jqModC (AlgebraicClosure ℚ)`, namely $q^{-1}$ times the image in $\bar{\mathbb{Q}}[[q]]$ of
+the integral power series `jNum` $= E_4^3 \cdot$ `dedekindEtaUnitInv`, and then adjoin to that field
+the series `jqNModC (AlgebraicClosure ℚ) ℓ`, the image of `jqModC` under the substitution $q \mapsto
+q^{\ell}$ given by `qExpand`. The assertion is that the two intermediate fields coincide, the second
+being read as an intermediate field over $\bar{\mathbb{Q}}$ via `IntermediateField.restrictScalars`.
+
+This identifies the geometric function field of $X_0(\ell)$ with $\bar{\mathbb{Q}}(j)(j_\ell)$,
+where $j$ and $j_\ell$ are the $q$-expansions of $j(z)$ and $j(\ell z)$, thereby connecting the
+base-changed modular function field with the tower $\bar{\mathbb{Q}} \subseteq \bar{\mathbb{Q}}(j)
+\subseteq \bar{\mathbb{Q}}(j, j_\ell)$ in which degrees and modular polynomials are available. It is
+used when producing places of the function field from roots of the modular polynomial and in the
+computation of the relative rank of `laurentBaseChange`.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_modularFunctionFieldBar_eq_restrictScalars.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_modularFunctionFieldBar_eq_restrictScalars
+
+open ModularCurve AlgebraicCurve IntermediateField
+open scoped Pointwise
+
+noncomputable section
+
+namespace DivUSol
+
+local notation "𝕂" => AlgebraicClosure ℚ
+
+variable (ℓ : ℕ)
+
+section inf
+variable [NeZero ℓ]
+
+def ubar (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ) : modularFunctionFieldBar ℓ :=
+  ⟨coeffEmb 𝕂 (modularUnitSeries ℓ), coeffEmb_mem_laurentBaseChange 𝕂 hmem⟩
+
+theorem coe_ubar (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ) :
+    (ubar ℓ hmem : LaurentSeries 𝕂) = coeffEmb 𝕂 (modularUnitSeries ℓ) := rfl
+
+theorem coeffEmb_modularUnitSeries_ne_zero : coeffEmb 𝕂 (modularUnitSeries ℓ) ≠ 0 := by
+  intro h
+  exact modularUnitSeries_ne_zero ℓ (coeffEmb_injective 𝕂 (by rw [h, map_zero]))
+
+theorem ubar_ne_zero (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ) :
+    ubar ℓ hmem ≠ 0 := by
+  intro h
+  exact coeffEmb_modularUnitSeries_ne_zero ℓ (by rw [← coe_ubar ℓ hmem, h]; rfl)
+
+theorem ord_inf (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ) :
+    (cuspInftyBar ℓ).ord (ubar ℓ hmem) = 1 - (ℓ : ℤ) := by
+  rw [ord_cuspInftyBar, coe_ubar, order_coeffEmb, order_modularUnitSeries]
+
+end inf
+
+variable [Fact ℓ.Prime]
+
+theorem coeffEmb_smul (c : ℚ) (x : LaurentSeries ℚ) :
+    coeffEmb 𝕂 (c • x) = (c : 𝕂) • coeffEmb 𝕂 x := by
+  rw [← HahnSeries.C_mul_eq_smul, ← HahnSeries.C_mul_eq_smul, map_mul]
+  congr 1
+  ext k
+  simp
+
+theorem fricke_ubar (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ) :
+    ((frickeInvolutionBar ℓ (ubar ℓ hmem) : modularFunctionFieldBar ℓ) : LaurentSeries 𝕂) =
+      ((ℓ : 𝕂) ^ 12) • (coeffEmb 𝕂 (modularUnitSeries ℓ))⁻¹ := by
+  have h := coe_geomAut_coeffEmb 𝕂 (modularFunctionFieldFull ℓ) (frickeInvolutionFull ℓ)
+    ⟨modularUnitSeries ℓ, hmem⟩
+  rw [coe_frickeInvolutionFull_modularUnitSeries ℓ hmem, coeffEmb_smul, map_inv₀] at h
+  rw [frickeInvolutionBar_def]
+  push_cast at h
+  exact h
+
+theorem fricke_ubar_elt (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ) :
+    frickeInvolutionBar ℓ (ubar ℓ hmem) =
+      algebraMap 𝕂 (modularFunctionFieldBar ℓ) ((ℓ : 𝕂) ^ 12) * (ubar ℓ hmem)⁻¹ := by
+  apply Subtype.ext
+  rw [fricke_ubar, ← HahnSeries.C_mul_eq_smul, HahnSeries.C_eq_algebraMap]
+  simp [coe_ubar]
+
+theorem ell_pow_ne_zero : ((ℓ : 𝕂) ^ 12) ≠ 0 :=
+  pow_ne_zero _ (Nat.cast_ne_zero.mpr (NeZero.ne ℓ))
+
+theorem fricke_symm_ubar (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ) :
+    (frickeInvolutionBar ℓ).symm (ubar ℓ hmem) = ((((ℓ : 𝕂) ^ 12))⁻¹ • ubar ℓ hmem)⁻¹ := by
+  apply (frickeInvolutionBar ℓ).injective
+  rw [AlgEquiv.apply_symm_apply, map_inv₀, Algebra.smul_def, map_mul, AlgEquiv.commutes,
+    fricke_ubar_elt,
+    ← mul_assoc, ← map_mul, inv_mul_cancel₀ (ell_pow_ne_zero ℓ), map_one, one_mul, inv_inv]
+
+theorem ord_zero (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ) :
+    (cuspZeroBar ℓ).ord (ubar ℓ hmem) = (ℓ : ℤ) - 1 := by
+  have key : (frickeInvolutionBar ℓ • cuspInftyBar ℓ).ord (ubar ℓ hmem) =
+      (cuspInftyBar ℓ).ord ((frickeInvolutionBar ℓ).symm (ubar ℓ hmem)) := by
+    conv_lhs => rw [← (frickeInvolutionBar ℓ).apply_symm_apply (ubar ℓ hmem)]
+    exact Place.ord_smul _ _ _
+  rw [cuspZeroBar_def, key, fricke_symm_ubar, Place.ord_inv,
+    Place.ord_smul_of_ne_zero _ (inv_ne_zero (ell_pow_ne_zero ℓ)), ord_inf]
+  ring
+
+def jb :
+    modularFunctionFieldBar ℓ := ⟨coeffEmb 𝕂 jq, coeffEmb_mem_laurentBaseChange 𝕂 (jq_mem_full ℓ)⟩
+
+theorem coe_jb : (jb ℓ : LaurentSeries 𝕂) = coeffEmb 𝕂 jq := rfl
+
+theorem isCusp_inf : IsCusp (jb ℓ) (cuspInftyBar ℓ) := isCusp_cuspInftyBar ℓ
+
+theorem isCusp_zero : IsCusp (jb ℓ) (cuspZeroBar ℓ) :=
+  isCusp_cuspZeroBar ℓ (isFrickeAutFull_frickeInvolutionFull_prime ℓ)
+
+def coeffEmbₐ : LaurentSeries ℚ →ₐ[ℚ] LaurentSeries 𝕂 := (coeffEmb 𝕂).toRatAlgHom
+
+theorem coeffEmbₐ_apply (x : LaurentSeries ℚ) : coeffEmbₐ x = coeffEmb 𝕂 x := rfl
+
+theorem isScalarTower_rat :
+    @IsScalarTower ℚ 𝕂 (LaurentSeries 𝕂) Algebra.toSMul Algebra.toSMul Algebra.toSMul :=
+  IsScalarTower.of_algebraMap_eq fun r =>
+    RingHom.congr_fun (Subsingleton.elim (algebraMap ℚ (LaurentSeries 𝕂))
+      ((algebraMap 𝕂 (LaurentSeries 𝕂)).comp (algebraMap ℚ 𝕂))) r
+
+attribute [local instance] isScalarTower_rat
+
+theorem isIntegral_ubar (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ) :
+    IsIntegral (Algebra.adjoin 𝕂 {jb ℓ}) (ubar ℓ hmem) := by
+  have h1 := isIntegral_adjoin_map_algHom coeffEmbₐ (isIntegral_adjoin_jq_modularUnitSeries ℓ)
+  rw [coeffEmbₐ_apply, coeffEmbₐ_apply] at h1
+  have h2 := isIntegral_adjoin_of_isScalarTower (L := 𝕂) h1
+  exact isIntegral_adjoin_intermediateField_mk (modularFunctionFieldBar ℓ) _ _ h2
+
+theorem isIntegral_ubar_inv (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ) :
+    IsIntegral (Algebra.adjoin 𝕂 {jb ℓ}) (ubar ℓ hmem)⁻¹ := by
+  have h1 := isIntegral_adjoin_map_algHom coeffEmbₐ (isIntegral_adjoin_jq_modularUnitSeries_inv ℓ)
+  rw [coeffEmbₐ_apply, coeffEmbₐ_apply, map_inv₀] at h1
+  have h2 := isIntegral_adjoin_of_isScalarTower (L := 𝕂) h1
+  have hxi : (coeffEmb 𝕂 (modularUnitSeries ℓ))⁻¹ ∈ modularFunctionFieldBar ℓ :=
+    inv_mem (coeffEmb_mem_laurentBaseChange 𝕂 hmem)
+  have h3 := isIntegral_adjoin_intermediateField_mk (modularFunctionFieldBar ℓ) (jb ℓ).2 hxi h2
+  have e : (⟨(coeffEmb 𝕂 (modularUnitSeries ℓ))⁻¹, hxi⟩ : modularFunctionFieldBar ℓ) = (ubar ℓ
+    hmem)⁻¹ :=
+    Subtype.ext rfl
+  rw [e] at h3
+  exact h3
+
+theorem ord_of_not_isCusp (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ)
+    (w : Place 𝕂 (modularFunctionFieldBar ℓ)) (hw : ¬ IsCusp (jb ℓ) w)
+    : w.ord (ubar ℓ hmem) = 0 := by
+  rw [isCusp_iff, not_not] at hw
+  exact Place.ord_eq_zero_of_isIntegral_adjoin w hw (isIntegral_ubar ℓ hmem) (isIntegral_ubar_inv ℓ
+    hmem)
+
+theorem smul_cuspidalDivisor_apply (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ)
+    (v : Place 𝕂 (modularFunctionFieldBar ℓ)) :
+    (((ℓ : ℤ) - 1) • cuspidalDivisor ℓ) v = v.ord (ubar ℓ hmem) := by
+  classical
+  have hℓ : ℓ.Prime := Fact.out
+  have hne : cuspZeroBar ℓ ≠ cuspInftyBar ℓ :=
+    cuspZeroBar_ne_cuspInftyBar ℓ (isFrickeAutFull_frickeInvolutionFull_prime ℓ) hℓ.one_lt
+  simp only [cuspidalDivisor_def, Finsupp.smul_apply, Finsupp.sub_apply, Finsupp.single_apply,
+    smul_eq_mul]
+  by_cases hc : IsCusp (jb ℓ) v
+  · rcases eq_cuspInftyBar_or_eq_cuspZeroBar ℓ v hc with rfl | rfl
+    · rw [ite_eq_right hne, ite_eq_left rfl, ord_inf]; ring
+    · rw [ite_eq_left rfl, ite_eq_right hne.symm, ord_zero]; ring
+  · have h1 : cuspZeroBar ℓ ≠ v := fun h => hc (h ▸ isCusp_zero ℓ)
+    have h2 : cuspInftyBar ℓ ≠ v := fun h => hc (h ▸ isCusp_inf ℓ)
+    rw [ite_eq_right h1, ite_eq_right h2, ord_of_not_isCusp ℓ hmem v hc]; ring
+
+theorem isPrincipal_smul_cuspidalDivisor :
+    Divisor.IsPrincipal (((ℓ : ℤ) - 1) • cuspidalDivisor ℓ) :=
+  ⟨ubar ℓ (modularUnitSeries_mem_modularFunctionFieldFull ℓ), ubar_ne_zero ℓ _,
+    smul_cuspidalDivisor_apply ℓ _⟩
+
+theorem smul_cuspidalClass_eq_zero : ((ℓ : ℤ) - 1) • cuspidalClass ℓ = 0 := by
+  rw [cuspidalClass_def]
+  exact Pic0.zsmul_mk_eq_zero_of_isPrincipal _ _
+    (by rw [coe_cuspidalDivisor₀]; exact isPrincipal_smul_cuspidalDivisor ℓ)
+
+theorem addOrderOf_cuspidalClass_dvd : addOrderOf (cuspidalClass ℓ) ∣ ℓ - 1 := by
+  have hℓ : ℓ.Prime := Fact.out
+  rw [cuspidalClass_def]
+  refine Pic0.addOrderOf_mk_dvd_of_isPrincipal _ _ ?_
+  rw [coe_cuspidalDivisor₀, ← natCast_zsmul, Nat.cast_sub hℓ.one_le, Nat.cast_one]
+  exact isPrincipal_smul_cuspidalDivisor ℓ
+
+theorem bar_eq_restrictScalars :
+    modularFunctionFieldBar ℓ =
+      (IntermediateField.adjoin (IntermediateField.adjoin 𝕂 ({jqModC 𝕂} : Set (LaurentSeries 𝕂)))
+        ({jqNModC 𝕂 ℓ} : Set (LaurentSeries 𝕂))).restrictScalars 𝕂 := by
+  have hℓ : ℓ.Prime := Fact.out
+  change laurentBaseChange 𝕂 (modularFunctionFieldFull ℓ) = _
+  rw [full_eq_of_prime hℓ, laurentBaseChange_modularFunctionField]
+  exact (adjoin_simple_adjoin_simple 𝕂 (jqModC 𝕂) (jqNModC 𝕂 ℓ)).symm
+
+theorem mem_bar_iff (x : LaurentSeries 𝕂) :
+    x ∈ modularFunctionFieldBar ℓ ↔ x ∈ 𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯ := by
+  rw [bar_eq_restrictScalars ℓ, mem_restrictScalars]
+
+def jTr : (𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯) ≃+* modularFunctionFieldBar ℓ where
+  toFun x := ⟨x, (mem_bar_iff ℓ _).mpr x.2⟩
+  invFun y := ⟨y, (mem_bar_iff ℓ _).mp y.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  map_mul' _ _ := rfl
+  map_add' _ _ := rfl
+
+theorem coe_jTr (x : 𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯) :
+    ((jTr ℓ x : modularFunctionFieldBar ℓ) : LaurentSeries 𝕂) = x := by
+  ext
+  rfl
+
+def e₁ : (𝕂⟮jb ℓ⟯ : IntermediateField 𝕂 (modularFunctionFieldBar ℓ)) ≃ₐ[𝕂] 𝕂⟮jqModC 𝕂⟯ :=
+  (liftAlgEquiv 𝕂⟮jb ℓ⟯).trans (equivOfEq (by rw [lift_adjoin_simple, coe_jb, coeffEmb_jq]))
+
+theorem coe_e₁ (x : (𝕂⟮jb ℓ⟯ : IntermediateField 𝕂 (modularFunctionFieldBar ℓ))) :
+    ((e₁ ℓ x : 𝕂⟮jqModC 𝕂⟯) : LaurentSeries 𝕂) = ((x : modularFunctionFieldBar ℓ) : LaurentSeries 𝕂)
+      := by
+  unfold e₁; rfl
+
+theorem compat :
+    (algebraMap (𝕂⟮jb ℓ⟯ : IntermediateField 𝕂 (modularFunctionFieldBar ℓ)) (modularFunctionFieldBar
+      ℓ)).comp
+        (e₁ ℓ).symm.toRingEquiv.toRingHom =
+      (jTr ℓ).toRingHom.comp (algebraMap (𝕂⟮jqModC 𝕂⟯) (𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯)) := by
+  apply RingHom.ext
+  intro y
+  apply Subtype.ext
+  change ((((e₁ ℓ).symm y : (𝕂⟮jb ℓ⟯ : IntermediateField 𝕂 (modularFunctionFieldBar ℓ))) :
+      modularFunctionFieldBar ℓ) : LaurentSeries 𝕂) = ((jTr ℓ (algebraMap _ _ y) :
+        modularFunctionFieldBar ℓ) :
+        LaurentSeries 𝕂)
+  rw [coe_jTr, ← coe_e₁, AlgEquiv.apply_symm_apply]
+  rfl
+
+theorem finiteDimensional_adjoin_jb :
+    FiniteDimensional (IntermediateField.adjoin 𝕂 ({jb ℓ} : Set (modularFunctionFieldBar ℓ)))
+      (modularFunctionFieldBar ℓ) := by
+  have hℓ : ℓ.Prime := Fact.out
+  obtain ⟨data⟩ := nonempty_modularPolynomialData_of_squarefree ℓ hℓ.squarefree hℓ.one_lt
+  have := finiteDimensional_adjoin_jqNModC 𝕂 data
+  exact Module.Finite.of_equiv_equiv (e₁ ℓ).symm.toRingEquiv (jTr ℓ) (compat ℓ)
+
+end DivUSol
+
+namespace BridgeSol
+
+theorem transcendental_coeffEmb_jq (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    Transcendental L (⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩ :
+      laurentBaseChange L (modularFunctionFieldFull N)) := by
+  intro h
+  apply transcendental_jqModC L
+  rw [← coeffEmb_jq]
+  exact h.algebraMap (A := LaurentSeries L)
+
+end BridgeSol
+
+end
+
+open ModularCurve AlgebraicCurve in
+theorem solution (ℓ : ℕ) [Fact ℓ.Prime] :
+    modularFunctionFieldBar ℓ = (IntermediateField.adjoin (IntermediateField.adjoin
+      (AlgebraicClosure ℚ) ({jqModC (AlgebraicClosure ℚ)} : Set (LaurentSeries (AlgebraicClosure
+      ℚ)))) ({jqNModC (AlgebraicClosure ℚ) ℓ} : Set (LaurentSeries (AlgebraicClosure
+      ℚ)))).restrictScalars (AlgebraicClosure ℚ) :=
+  DivUSol.bar_eq_restrictScalars ℓ
+
+end S_ModularCurve_modularFunctionFieldBar_eq_restrictScalars
+end P2MW
+export P2MW.S_ModularCurve_modularFunctionFieldBar_eq_restrictScalars (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.modularFunctionFieldBar_eq_restrictScalars (ℓ : ℕ) [Fact ℓ.Prime] :
+    modularFunctionFieldBar ℓ = (IntermediateField.adjoin (IntermediateField.adjoin
+      (AlgebraicClosure ℚ) ({jqModC (AlgebraicClosure ℚ)} : Set (LaurentSeries (AlgebraicClosure
+      ℚ)))) ({jqNModC (AlgebraicClosure ℚ) ℓ} : Set (LaurentSeries (AlgebraicClosure
+      ℚ)))).restrictScalars (AlgebraicClosure ℚ) :=
+  solution ℓ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_modularFunctionFieldFullC_le_qExpFunctionFieldC_gamma0.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_modularFunctionFieldFullC_le_qExpFunctionFieldC_gamma0.lean
new file mode 100644
index 0000000000..7cde6ac1af
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_modularFunctionFieldFullC_le_qExpFunctionFieldC_gamma0.lean
@@ -0,0 +1,106 @@
+/-
+Based on Prove2Me node ModularCurve.modularFunctionFieldFullC_le_qExpFunctionFieldC_gamma0
+(7e38264d-3162-5273-927a-09b2aee32a0c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4a58e2b3-294f-54a9-9f1f-a5c43f23a383
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0ModL
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_mem_intFormRatiosC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpand_image_intFormRatiosC_subset
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Divisor expansions j(qᵈ) lie in the Γ₀(M) q-expansion field
+
+Theorem statement: `ModularCurve.modularFunctionFieldFullC_le_qExpFunctionFieldC_gamma0`
+(`7e38264d-3162-5273-927a-09b2aee32a0c`), by Claude, 2026-09-05.
+
+Proof: submission `4a58e2b3-294f-54a9-9f1f-a5c43f23a383`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $M$ be a positive natural number. Inside the field $K((q))$ of Laurent
+series over $K$ two intermediate fields over $K$ are compared. The first,
+[`ModularCurve.modularFunctionFieldFullC K M`](def/ModularCurve_X0ModL.html#L100), is the subfield
+generated over $K$ by the set `divisorExpansionsC K M`, namely by those Laurent series of the form
+`qExpand K d (jqModC K)` for some positive divisor $d$ of $M$, where `jqModC K` is the distinguished
+Laurent series attached to the modular invariant read over $K$ and `qExpand K d` is the $d$-th
+$q$-substitution operator on $K((q))$. The second, [`ModularCurve.qExpFunctionFieldC K
+(CongruenceSubgroup.Gamma0 M)`](def/ModularCurve_X1.html#L101), is the subfield generated over $K$
+by the set `intFormRatiosC K (CongruenceSubgroup.Gamma0 M)`, consisting of all quotients `intSeriesC
+K pf / intSeriesC K pg` arising from a weight $k \in \mathbb{Z}$, two modular forms $f,g$ of weight
+$k$ for the image of $\Gamma_0(M)$ in $\mathrm{GL}_2(\mathbb{R})$, and integral power series $pf, pg
+\in \mathbb{Z}[[q]]$ with `IsIntegralQExp f pf`, `IsIntegralQExp g pg` and `intSeriesC K pg ≠ 0`.
+The assertion is the inclusion of the first field in the second.
+
+This is the inclusion of the classical presentation of the function field of $X_0(M)$ by the divisor
+expansions $j(q^d)$, $d \mid M$, into its presentation by $q$-expansions of ratios of modular forms
+with integral coefficients, valid over an arbitrary coefficient field $K$. It is used throughout the
+treatment of modular curves at full level and of the Diamond-type comparisons built on it.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_modularFunctionFieldFullC_le_qExpFunctionFieldC_gamma0.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_modularFunctionFieldFullC_le_qExpFunctionFieldC_gamma0
+
+theorem solution
+    (K : Type*) [Field K] (M : ℕ) [NeZero M] :
+    ModularCurve.modularFunctionFieldFullC K M ≤
+      ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M) := by
+  rw [ModularCurve.modularFunctionFieldFullC, IntermediateField.adjoin_le_iff]
+  rintro x ⟨d, hd, hdM, rfl⟩
+  have := hd
+  refine ModularCurve.intFormRatiosC_subset K _ ?_
+  have hle : CongruenceSubgroup.Gamma0 M ≤ CongruenceSubgroup.Gamma0 d := by
+    intro γ hγ
+    rw [CongruenceSubgroup.Gamma0_mem, ZMod.intCast_zmod_eq_zero_iff_dvd] at hγ ⊢
+    exact (Int.natCast_dvd_natCast.mpr hdM).trans hγ
+  refine ModularCurve.intFormRatiosC_mono K hle ?_
+  refine ModularCurve.qExpand_image_intFormRatiosC_subset K (Γ := ⊤)
+    (Γ' := CongruenceSubgroup.Gamma0 d) (Subgroup.mem_top _) d ?_
+    ⟨_, ModularCurve.jqModC_mem_intFormRatiosC K ⊤, rfl⟩
+  intro γ hγ
+  rw [CongruenceSubgroup.Gamma0_mem, ZMod.intCast_zmod_eq_zero_iff_dvd] at hγ
+  obtain ⟨c, hc⟩ := hγ
+  have hdet : (γ 0 0 : ℤ) * γ 1 1 - γ 0 1 * γ 1 0 = 1 := by
+    rw [← Matrix.det_fin_two]
+    exact Matrix.SpecialLinearGroup.det_coe γ
+  rw [hc] at hdet
+  refine ⟨⟨!![γ 0 0, (d : ℤ) * γ 0 1; c, γ 1 1], ?_⟩, Subgroup.mem_top _, rfl, rfl, ?_, rfl⟩
+  · rw [Matrix.det_fin_two_of]
+    linear_combination hdet
+  · change (d : ℤ) * c = γ 1 0
+    rw [hc]
+
+end S_ModularCurve_modularFunctionFieldFullC_le_qExpFunctionFieldC_gamma0
+end P2MW
+export P2MW.S_ModularCurve_modularFunctionFieldFullC_le_qExpFunctionFieldC_gamma0 (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.modularFunctionFieldFullC_le_qExpFunctionFieldC_gamma0
+    (K : Type*) [Field K] (M : ℕ) [NeZero M] :
+    ModularCurve.modularFunctionFieldFullC K M ≤
+      ModularCurve.qExpFunctionFieldC K (CongruenceSubgroup.Gamma0 M) :=
+  solution K M
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_modularFunctionField_eq_full.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_modularFunctionField_eq_full.lean
new file mode 100644
index 0000000000..0f3527ff77
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_modularFunctionField_eq_full.lean
@@ -0,0 +1,811 @@
+/-
+Based on Prove2Me node ModularCurve.modularFunctionField_eq_full
+(5833b5b8-05ed-5781-ae18-350eff2d4858) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 45e09a77-5edd-5556-a426-3582a1f41cb7
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_minpoly_jqN_map_eq_prod_slots
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqN_prime_not_mem_full
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqN_pow_not_mem_adjoin_full
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_full_eq_adjoin_full_div_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_eq_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqN_div_mem_modularFunctionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularFunctionField_eq_full_of
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_modularFunctionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_mul_of_coprime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime_pow
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_of_finrank_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration_iff_full_eq
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.FieldTheory.Relrank
+import Mathlib.Data.Nat.Factorization.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Level-N modular function field equals its full divisor field
+
+Theorem statement: `ModularCurve.modularFunctionField_eq_full`
+(`5833b5b8-05ed-5781-ae18-350eff2d4858`), by Claude, 2026-09-05.
+
+Proof: submission `45e09a77-5edd-5556-a426-3582a1f41cb7`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, assumed non-zero (via the `NeZero N` instance). Inside the field of
+Laurent series $\mathbb{Q}((q))$, written `LaurentSeries ℚ`, write `jq` for the fixed Laurent series
+that serves as the $q$-expansion of the modular invariant $j$, and for each non-zero $d$ let
+`qExpand ℚ d` denote the ring endomorphism of `LaurentSeries ℚ` obtained by multiplying all
+Hahn-series exponents by $d$, i.e. the substitution $q \mapsto q^{d}$; thus `qExpand ℚ d jq` is the
+series $j(q^{d})$. The theorem asserts the equality of two intermediate fields of $\mathbb{Q}((q))$
+over $\mathbb{Q}$: on the one hand `modularFunctionField N`, the subfield generated over
+$\mathbb{Q}$ by the two elements `jq` and `qExpand ℚ N jq`, and on the other hand
+`modularFunctionFieldFull N`, the subfield generated over $\mathbb{Q}$ by the whole set of divisor
+expansions $\{\,$`qExpand ℚ d jq`$\,\}$, where $d$ ranges over the non-zero divisors of $N$.
+Equivalently: every $j(q^{d})$ with $d \mid N$ is a rational function of $j(q)$ and $j(q^{N})$ with
+rational coefficients, and conversely.
+
+This is the generation statement for the function field of $X_0(N)$ over $\mathbb{Q}$ in its formal
+$q$-expansion model: the field generated by $j(q)$ and $j(q^N)$ already contains all intermediate
+divisor expansions $j(q^d)$, $d \mid N$. It is used throughout the development of the $q$-expansion
+model of $X_0(N)$, in particular in the treatment of mod $p$ modular forms and of Hecke operators on
+fibre models.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_modularFunctionField_eq_full.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_modularFunctionField_eq_full
+
+noncomputable section
+
+p2m_open "ModularCurve~coeffEmb_qExpand \
+  P2MW.S_ModularCurve_modularFunctionField_eq_full.ModularCurve ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+
+
+
+
+
+
+
+
+
+
+theorem coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb K (qExpand ℚ n x) = qExpand K n (coeffEmb K x) :=
+  coeffMap_qExpand (algebraMap ℚ K) n x
+
+theorem iota_jqN (N d : ℕ) [NeZero N] [NeZero d] :
+    coeffEmb K (qExpand ℚ N (jqN d)) = TS K (N * d) 1 := by
+  rw [jqN, coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem iota_jq (N : ℕ) [NeZero N] : coeffEmb K (qExpand ℚ N jq) = TS K N 1 := by
+  rw [coeffEmb_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_zero_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    conj p ζ (0 : Fin (p + 1)) = TS K (p * p) 1 := by
+  rw [conj_zero, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_succ_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) (b : Fin p) :
+    conj p ζ b.succ = TS K 1 (ζ ^ (b : ℕ)) := by
+  rw [conj_succ, TS_eq_coeffEmb, qExpand_one_apply]
+
+theorem qTwist_iota_of_pow_eq_one (N : ℕ) [NeZero N] (v : Kˣ) (hv : v ^ N = 1) (x : LaurentSeries ℚ)
+    :
+    qTwist v (coeffEmb K (qExpand ℚ N x)) = coeffEmb K (qExpand ℚ N x) := by
+  rw [coeffEmb_qExpand, qTwist_qExpand]
+  have : v ^ (N : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+omit [Algebra ℚ K] in
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+omit [Algebra ℚ K] in
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+omit [Algebra ℚ K] in
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem phiProd_conj_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    phiProd p (conj p ζ) = (Polynomial.X - Polynomial.C (TS K (p * p) 1)) *
+      ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) := by
+  rw [phiProd, Fin.prod_univ_succ, conj_zero_eq]
+  congr 1
+  rw [← Fin.prod_univ_eq_prod_range (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) p]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [conj_succ_eq]
+
+theorem roots_phiProd_conj (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    (phiProd p (conj p ζ)).roots = TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^
+      b)) := by
+  classical
+  rw [phiProd_conj_eq]
+  have h1 : (Polynomial.X - Polynomial.C (TS K (p * p) 1) : Polynomial (LaurentSeries K)) ≠ 0 :=
+    Polynomial.X_sub_C_ne_zero _
+  have h2 : (∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b)))) ≠ 0 :=
+    Finset.prod_ne_zero_iff.mpr fun b _ => Polynomial.X_sub_C_ne_zero _
+  rw [Polynomial.roots_mul (mul_ne_zero h1 h2), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod,
+    Finset.range_val]
+  have hm : (Multiset.map (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) (Multiset.range
+    p)) =
+      ((Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).map (fun a => Polynomial.X - Polynomial.C
+        a) := by
+    rw [Multiset.map_map]; rfl
+  rw [hm, Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+omit [Algebra ℚ K] in
+theorem roots_phiProd_conj_nodup (p : ℕ) [hp : Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).Nodup := by
+  refine Multiset.nodup_cons.mpr ⟨?_, ?_⟩
+  · intro hmem
+    obtain ⟨b, -, hb⟩ := Multiset.mem_map.mp hmem
+    have := (TS_injective hb).1
+    have h2 := hp.out.two_le
+    nlinarith
+  · refine (Multiset.nodup_range p).map_on fun b hb b' hb' hbb' => ?_
+    rw [Multiset.mem_range] at hb hb'
+    have hu := (TS_injective hbb').2
+    have hζu : IsPrimitiveRoot ζ p := IsPrimitiveRoot.coe_units_iff.mp hζ
+    exact hζu.pow_inj hb hb' hu
+
+theorem exists_isPrimitiveRoot_cyclotomicField (N : ℕ) [NeZero N] :
+    ∃ z : CyclotomicField N ℚ, IsPrimitiveRoot z N := by
+  have : NeZero ((N : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr (NeZero.ne N)⟩
+  have : IsCyclotomicExtension {N} ℚ (CyclotomicField N ℚ) :=
+    CyclotomicField.isCyclotomicExtension N ℚ
+  exact IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField N ℚ) (Set.mem_singleton N)
+    (NeZero.ne N)
+
+def cycUnit (N : ℕ) [NeZero N] : (CyclotomicField N ℚ)ˣ :=
+  ((exists_isPrimitiveRoot_cyclotomicField N).choose_spec.isUnit (NeZero.ne N)).unit
+
+theorem cycUnit_spec (N : ℕ) [NeZero N] :
+    IsPrimitiveRoot ((cycUnit N : (CyclotomicField N ℚ)ˣ) : CyclotomicField N ℚ) N := by
+  rw [cycUnit, IsUnit.unit_spec]
+  exact (exists_isPrimitiveRoot_cyclotomicField N).choose_spec
+
+theorem cycUnit_pow (N : ℕ) [NeZero N] : cycUnit N ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, (cycUnit_spec N).pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem prod_form_ne_zero (N : ℕ) (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e]
+    (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K
+            jq)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+          (Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u,
+    Polynomial.roots_mul (prod_form_ne_zero N ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p)))
+    (coeffEmb K jq))))
+        = ((Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+        (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+        (Multiset.range p).map
+          (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).Nodup := by
+  have hζp : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := isPrimitiveRoot_pow_div hζ hpN
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h := (TS_injective (K := K) (e := e) (e' := p * (p * e))
+      (u := u * ζ ^ (b * (N / p))) (u' := u ^ (p * p))
+      (by simpa only [TS_eq_coeffEmb] using heq)).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e)
+      (u := u * ζ ^ (b * (N / p))) (u' := u * ζ ^ (b' * (N / p)))
+      (by simpa only [TS_eq_coeffEmb] using heq)).2
+    have h2 : ζ ^ (b * (N / p)) = ζ ^ (b' * (N / p)) := mul_left_cancel h
+    have h3 : (ζ ^ (N / p)) ^ b = (ζ ^ (N / p)) ^ b' := by
+      rw [← pow_mul, ← pow_mul, Nat.mul_comm (N / p) b, Nat.mul_comm (N / p) b']
+      exact h2
+    have h4 : ((ζ ^ (N / p) : Kˣ) : K) ^ b = ((ζ ^ (N / p) : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h3]
+    exact hζp.pow_inj hb hb' h4
+
+theorem roots_prime_at_slot_roots_nodup (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots.Nodup := by
+  rw [roots_prime_at_slot N ζ hζ p hpN data e u]
+  exact roots_prime_at_slot_nodup N ζ hζ p hpN e u
+
+theorem isRoot_prime_at_slot_iff (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u]
+    exact prod_form_ne_zero N ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot N ζ hζ p hpN data e u,
+    Multiset.mem_cons, Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+
+
+
+
+theorem phiAtSeed_jq_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) :
+    (phiAtSeed data jq).eval (jqN n) = 0 := by
+  have h := data.eval_eq_zero
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp [evalAtJ_X]
+
+
+theorem phiAtSeed_jqN_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN M)).eval (jqN (M * n)) = 0 := by
+  have h := phiAtSeed_eval_map data jq (jqN n) (qExpand ℚ M) (phiAtSeed_jq_eval n data)
+  rwa [jqN, qExpand_qExpand] at h
+
+theorem phiAtSeed_iota_eval {K : Type*} [Field K] [Algebra ℚ K] (A : ℕ) [NeZero A] (n : ℕ)
+    [NeZero n]
+    (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (coeffEmb K (qExpand ℚ A (jqN M)))).eval (coeffEmb K (qExpand ℚ A (jqN (M *
+      n)))) = 0 :=
+  phiAtSeed_eval_map data _ _ ((coeffEmb K).comp (qExpand ℚ A)) (phiAtSeed_jqN_eval n data M)
+
+end ModularCurve.W1
+
+open scoped IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+section Final
+
+private abbrev Tight (d : ℕ) [NeZero d] : Prop :=
+  Module.finrank ℚ⟮jq⟯ (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN d} : Set (LaurentSeries ℚ))) =
+    dedekindPsi d
+
+private abbrev Gen (d : ℕ) [NeZero d] : Prop := modularFunctionField d = modularFunctionFieldFull d
+
+private abbrev Hall (N : ℕ) : Prop := ∀ d : ℕ, d ∣ N → ∀ [NeZero d], Tight d ∧ Gen d
+
+private theorem jqN_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) : jqN n = jqN m := by
+  subst h; rfl
+
+private theorem full_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) :
+    modularFunctionFieldFull n = modularFunctionFieldFull m := by
+  subst h; rfl
+
+private theorem mff_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) :
+    modularFunctionField n = modularFunctionField m := by
+  subst h; rfl
+
+private theorem qExpand_congr' {R : Type*} [CommRing R] {n m : ℕ} [NeZero n] [NeZero m]
+    (h : n = m) (x : LaurentSeries R) : qExpand R n x = qExpand R m x := by
+  subst h
+  rfl
+
+private theorem dedekindPsi_prime' (p : ℕ) (hp : p.Prime) : dedekindPsi p = p + 1 := by
+  have h := ModularCurve.dedekindPsi_prime_pow p 1 hp one_ne_zero
+  rwa [pow_one, Nat.sub_self, pow_zero] at h
+
+private theorem dedekindPsi_mul_prime_not_dvd {m p : ℕ} (hp : p.Prime) (hpm : ¬ p ∣ m) :
+    dedekindPsi (m * p) = dedekindPsi m * (p + 1) := by
+  have hco : Nat.Coprime m p := ((Nat.Prime.coprime_iff_not_dvd hp).mpr hpm).symm
+  rw [ModularCurve.dedekindPsi_mul_of_coprime m p hco, dedekindPsi_prime' p hp]
+
+private theorem dedekindPsi_mul_prime_dvd {m p : ℕ} (hm : m ≠ 0) (hp : p.Prime)
+    (hpm : p ∣ m) : dedekindPsi (m * p) = dedekindPsi m * p := by
+  obtain ⟨k, u, hpu, hmu⟩ := Nat.exists_eq_pow_mul_and_not_dvd hm p hp.ne_one
+  obtain ⟨k', rfl⟩ : ∃ k', k = k' + 1 := by
+    rcases k with - | k'
+    · exfalso
+      rw [hmu, pow_zero, one_mul] at hpm
+      exact hpu hpm
+    · exact ⟨k', rfl⟩
+  subst hmu
+  have hcou : ∀ j : ℕ, j ≠ 0 → Nat.Coprime (p ^ j) u :=
+    fun j _ => Nat.Coprime.pow_left j ((Nat.Prime.coprime_iff_not_dvd hp).mpr hpu)
+  have h1 : p ^ (k' + 1) * u * p = p ^ (k' + 2) * u := by ring
+  rw [h1, ModularCurve.dedekindPsi_mul_of_coprime _ u (hcou _ (Nat.succ_ne_zero _)),
+    ModularCurve.dedekindPsi_mul_of_coprime _ u (hcou _ (Nat.succ_ne_zero _)),
+    ModularCurve.dedekindPsi_prime_pow p (k' + 2) hp (Nat.succ_ne_zero _),
+    ModularCurve.dedekindPsi_prime_pow p (k' + 1) hp (Nat.succ_ne_zero _)]
+  have h2 : k' + 2 - 1 = k' + 1 := rfl
+  have h3 : k' + 1 - 1 = k' := rfl
+  rw [h2, h3]
+  ring
+
+private theorem tight_one : Tight 1 := by
+  unfold Tight
+  have h1 : jqN 1 = jq := by rw [jqN, qExpand_one_apply]
+  rw [h1, ModularCurve.dedekindPsi_one]
+  have h2 : IntermediateField.adjoin ℚ⟮jq⟯ ({jq} : Set (LaurentSeries ℚ))
+      = (⊥ : IntermediateField ℚ⟮jq⟯ (LaurentSeries ℚ)) := by
+    rw [IntermediateField.adjoin_simple_eq_bot_iff, IntermediateField.mem_bot]
+    exact ⟨jGen, rfl⟩
+  rw [h2]
+  exact IntermediateField.finrank_bot
+
+private theorem gen_one : Gen 1 := by
+  unfold Gen
+  refine le_antisymm (modularFunctionField_le_full 1) ?_
+  rw [modularFunctionFieldFull, IntermediateField.adjoin_le_iff]
+  rintro x ⟨d, hne, hdvd, rfl⟩
+  have := hne
+  have hd1 : d = 1 := Nat.dvd_one.mp hdvd
+  subst hd1
+  rw [qExpand_one_apply]
+  exact jq_mem 1
+
+private theorem relfinrank_full_of (N : ℕ) [NeZero N] (ht : Tight N) (hg : Gen N) :
+    IntermediateField.relfinrank ℚ⟮jq⟯ (modularFunctionFieldFull N) = dedekindPsi N := by
+  unfold Gen at hg
+  unfold Tight at ht
+  rw [← hg, ModularCurve.relfinrank_modularFunctionField N, ht]
+
+private theorem F0_le_full (N : ℕ) [NeZero N] : ℚ⟮jq⟯ ≤ modularFunctionFieldFull N := by
+  rw [IntermediateField.adjoin_le_iff, Set.singleton_subset_iff]
+  have h := jqd_mem_full N (one_dvd N)
+  rw [qExpand_one_apply] at h
+  exact h
+
+private theorem full_le_adjoin_chain (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (hpM : ¬ p ∣ M) : ∀ a : ℕ,
+    modularFunctionFieldFull (M * p ^ a) ≤ IntermediateField.adjoin ℚ
+      ((modularFunctionFieldFull M : Set (LaurentSeries ℚ))
+        ∪ {x : LaurentSeries ℚ | ∃ i : ℕ, i ≤ a ∧ x = jqN (p ^ i)}) := by
+  intro a
+  induction a with
+  | zero =>
+      rw [full_congr (show M * p ^ 0 = M by rw [pow_zero, mul_one])]
+      exact fun x hx => IntermediateField.subset_adjoin ℚ _ (Set.mem_union_left _ hx)
+  | succ k ih =>
+      rw [ModularCurve.full_eq_adjoin_full_div_prime M p k hpM, IntermediateField.adjoin_le_iff,
+        Set.insert_subset_iff]
+      refine ⟨IntermediateField.subset_adjoin ℚ _ (Set.mem_union_right _
+        (show jqN (p ^ (k + 1)) ∈ {x : LaurentSeries ℚ | ∃ i : ℕ, i ≤ k + 1 ∧ x = jqN (p ^ i)} from
+          ⟨k + 1, le_rfl, rfl⟩)), ?_⟩
+      intro x hx
+      have hx' := ih hx
+      refine IntermediateField.adjoin.mono ℚ _ _ (Set.union_subset_union le_rfl ?_) hx'
+      intro y hy
+      obtain ⟨i, hi, hy⟩ := hy
+      exact ⟨i, Nat.le_succ_of_le hi, hy⟩
+
+private theorem jqN_pow_not_mem_full (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (hpM : ¬ p ∣ M) (hallM : Hall M) (a : ℕ) :
+    jqN (p ^ (a + 1)) ∉ modularFunctionFieldFull (M * p ^ a) := by
+  have h0 : jqN p ∉ modularFunctionFieldFull M :=
+    ModularCurve.jqN_prime_not_mem_full M p hpM (fun d hd _ => hallM d hd)
+  rcases a with - | k
+  · rw [jqN_congr (show p ^ (0 + 1) = p by rw [zero_add, pow_one]),
+      full_congr (show M * p ^ 0 = M by rw [pow_zero, mul_one])]
+    exact h0
+  · intro hmem
+    have h1 := ModularCurve.jqN_pow_not_mem_adjoin_full M p k h0
+    exact h1 (full_le_adjoin_chain M p hpM (k + 1) hmem)
+
+section Shapes
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem root_shape (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) M) (hallM : Hall M) (y : LaurentSeries K)
+    (hy : Polynomial.eval y ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M *
+      p))).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))) = 0) :
+    ∃ a : ℕ, ∃ _ : NeZero a, a ∣ M ∧ ∃ b : ℕ, b < M / a ∧ y = TS K (p * (a * a)) (ζ ^ (b * a)) := by
+  have hid := ModularCurve.minpoly_jqN_map_eq_prod_slots (K := K) M ζ hζ (fun d hd _ => hallM d hd)
+  have hcomp : (qExpand K p).comp (((coeffEmb K).comp (qExpand ℚ M)).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))
+      = ((coeffEmb K).comp (qExpand ℚ (M * p))).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) := by
+    refine RingHom.ext fun z => ?_
+    simp only [RingHom.comp_apply]
+    rw [coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand]
+    exact qExpand_congr' (mul_comm p M) _
+  rw [← hcomp, ← Polynomial.map_map, hid, Polynomial.eval_map, Polynomial.eval₂_finsetProd] at hy
+  obtain ⟨a, ha, hy⟩ := Finset.prod_eq_zero_iff.mp hy
+  rw [Polynomial.eval₂_finsetProd] at hy
+  obtain ⟨b, hb, hy⟩ := Finset.prod_eq_zero_iff.mp hy
+  rw [Polynomial.eval₂_sub, Polynomial.eval₂_X, Polynomial.eval₂_C, sub_eq_zero] at hy
+  have ha0 : a ≠ 0 := Nat.ne_of_gt (Nat.pos_of_mem_divisors ha)
+  rw [dite_eq_right ha0] at hy
+  have : NeZero a := ⟨ha0⟩
+  refine ⟨a, ⟨ha0⟩, Nat.dvd_of_mem_divisors ha, b, (Finset.mem_range.mp (Finset.mem_filter.mp
+    hb).1), ?_⟩
+  rw [hy]
+  rw [← TS_eq_coeffEmb, qExpand_TS]
+
+private theorem htw_of (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) M) (hallM : Hall M) (y : LaurentSeries K)
+    (hy : Polynomial.eval y ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M *
+      p))).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))) = 0)
+    (w : Kˣ) (hw : y = qExpand K (M * p * M) (qTwist w (coeffEmb K jq))) : w = 1 := by
+  obtain ⟨a, _, haM, b, hb, rfl⟩ := root_shape M p ζ hζ hallM y hy
+  rw [← TS_eq_coeffEmb] at hw
+  obtain ⟨he, hu⟩ := TS_injective hw
+  have haM' : a = M := by
+    have h2 : a * a = M * M := by
+      have hp0 : 0 < p := hp.out.pos
+      have : p * (a * a) = p * (M * M) := by rw [he]; ring
+      exact Nat.eq_of_mul_eq_mul_left hp0 this
+    exact Nat.mul_self_inj.mp h2
+  subst haM'
+  have hb0 : b = 0 := by
+    rw [Nat.div_self (Nat.pos_of_ne_zero (NeZero.ne a))] at hb
+    omega
+  subst hb0
+  rw [zero_mul, pow_zero] at hu
+  exact hu.symm
+
+private theorem hsp_of (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) M) (hallM : Hall M) (y : LaurentSeries K)
+    (hy : Polynomial.eval y ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M *
+      p))).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))) = 0) :
+    y ≠ coeffEmb K (qExpand ℚ (M * p) (jqN (M * p * p))) := by
+  obtain ⟨a, _, haM, b, _, rfl⟩ := root_shape M p ζ hζ hallM y hy
+  rw [iota_jqN]
+  intro h
+  obtain ⟨he, _⟩ := TS_injective h
+  have hp2 : 2 ≤ p := hp.out.two_le
+  have hM : 0 < M := Nat.pos_of_ne_zero (NeZero.ne M)
+  have ha : a ≤ M := Nat.le_of_dvd hM haM
+  have h1 : a * a = (M * p) * (M * p) := by
+    have : p * (a * a) = p * ((M * p) * (M * p)) := by rw [he]; ring
+    exact Nat.eq_of_mul_eq_mul_left hp.out.pos this
+  have h2 : a = M * p := Nat.mul_self_inj.mp h1
+  have : M * p ≤ M := h2 ▸ ha
+  have : M * 2 ≤ M * p := Nat.mul_le_mul_left M hp2
+  omega
+
+end Shapes
+
+private theorem hall_all : ∀ N : ℕ, N ≠ 0 → Hall N := by
+  intro N
+  induction N using Nat.strong_induction_on with
+  | _ N ih =>
+  intro hN d hdN hd
+  by_cases hdlt : d < N
+  · exact ih d hdlt (NeZero.ne d) d dvd_rfl
+  have hdN' : d = N := le_antisymm (Nat.le_of_dvd (Nat.pos_of_ne_zero hN) hdN) (not_lt.mp hdlt)
+  subst hdN'
+  have hprop : ∀ m : ℕ, m ∣ d → m < d → Hall m := fun m _ hlt => ih m hlt (by
+    rintro rfl; exact absurd hlt (by have := Nat.pos_of_ne_zero hN; omega))
+  by_cases h1 : d = 1
+  · subst h1; exact ⟨tight_one, gen_one⟩
+  have hgen : Gen d := by
+    unfold Gen
+    refine ModularCurve.modularFunctionField_eq_full_of d ?_ ?_
+    · intro M _ p hp hMp
+      have : Fact (Nat.Prime p) := ⟨hp⟩
+      have hMlt : M < d := by
+        rw [← hMp]; exact lt_mul_of_one_lt_right (Nat.pos_of_ne_zero (NeZero.ne M)) hp.one_lt
+      have hallM : Hall M := hprop M ⟨p, hMp.symm⟩ hMlt
+      have hmem :=
+        ModularCurve.jqN_div_mem_modularFunctionField M p (K := CyclotomicField (M * p) ℚ)
+        (cycUnit (M * p)) (cycUnit_spec (M * p))
+        (fun y hy w hw => htw_of M p (cycUnit (M * p) ^ (M * p / M))
+          (isPrimitiveRoot_pow_div (cycUnit_spec (M * p)) ⟨p, rfl⟩) hallM y hy w hw)
+        (fun y hy => hsp_of M p (cycUnit (M * p) ^ (M * p / M))
+          (isPrimitiveRoot_pow_div (cycUnit_spec (M * p)) ⟨p, rfl⟩) hallM y hy)
+      rw [mff_congr hMp] at hmem
+      exact hmem
+    · intro M _ p hp hMp
+      have hMlt : M < d := by
+        rw [← hMp]; exact lt_mul_of_one_lt_right (Nat.pos_of_ne_zero (NeZero.ne M)) hp.one_lt
+      exact (hprop M ⟨p, hMp.symm⟩ hMlt M dvd_rfl).2
+  refine ⟨?_, hgen⟩
+  unfold Tight
+  set p := d.minFac with hpdef
+  have hp : p.Prime := Nat.minFac_prime h1
+  have : Fact (Nat.Prime p) := ⟨hp⟩
+  obtain ⟨k, M, hpM, hdM⟩ := Nat.exists_eq_pow_mul_and_not_dvd hN p hp.ne_one
+  have hM0 : M ≠ 0 := by rintro rfl; rw [mul_zero] at hdM; exact hN hdM
+  have : NeZero M := ⟨hM0⟩
+  obtain ⟨a, rfl⟩ : ∃ a, k = a + 1 := by
+    rcases k with - | a
+    · exfalso
+      have : p ∣ d := Nat.minFac_dvd d
+      rw [hdM, pow_zero, one_mul] at this
+      exact hpM this
+    · exact ⟨a, rfl⟩
+  have hdM' : d = M * p ^ (a + 1) := by rw [hdM, mul_comm]
+  have hlow_dvd : M * p ^ a ∣ d := ⟨p, by rw [hdM', pow_succ, mul_assoc]⟩
+  have hlow_lt : M * p ^ a < d := by
+    rw [hdM', pow_succ, ← mul_assoc]
+    exact lt_mul_of_one_lt_right (Nat.pos_of_ne_zero (mul_ne_zero hM0 (pow_ne_zero _ hp.ne_zero)))
+      hp.one_lt
+  have hall_low : Hall (M * p ^ a) := hprop _ hlow_dvd hlow_lt
+  have hallM : Hall M := fun e he _ => hall_low e (he.trans ⟨p ^ a, rfl⟩)
+  have hlowdeg : IntermediateField.relfinrank ℚ⟮jq⟯ (modularFunctionFieldFull (M * p ^ a))
+      = dedekindPsi (M * p ^ a) := by
+    have h := hall_low (M * p ^ a) dvd_rfl
+    exact relfinrank_full_of _ h.1 h.2
+  have hstep := ModularCurve.relfinrank_full_eq_mul M p a
+    (ModularCurve.full_eq_adjoin_full_div_prime M p a hpM) (jqN_pow_not_mem_full M p hpM hallM a)
+  have htower := IntermediateField.relfinrank_mul_relfinrank (F0_le_full (M * p ^ a))
+    (full_degeneracy_le (N := M * p ^ a) (M := M * p ^ (a + 1)) ⟨p, by rw [pow_succ, mul_assoc]⟩)
+  rw [← ModularCurve.relfinrank_modularFunctionField d]
+  unfold Gen at hgen
+  rw [hgen, full_congr hdM', ← htower, hlowdeg, hstep]
+  have hpsi : dedekindPsi d = dedekindPsi (M * p ^ a) * (if a = 0 then p + 1 else p) := by
+    rw [hdM']
+    split_ifs with ha
+    · subst ha
+      rw [pow_zero, mul_one, zero_add, pow_one]
+      exact dedekindPsi_mul_prime_not_dvd hp hpM
+    · have h2 : M * p ^ (a + 1) = M * p ^ a * p := by rw [pow_succ, mul_assoc]
+      rw [h2]
+      refine dedekindPsi_mul_prime_dvd (mul_ne_zero hM0 (pow_ne_zero _ hp.ne_zero)) hp ⟨M * p ^ (a -
+        1), ?_⟩
+      obtain ⟨a', rfl⟩ := Nat.exists_eq_succ_of_ne_zero ha
+      rw [Nat.succ_sub_one, pow_succ]; ring
+  rw [hpsi]
+
+end Final
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi (N : ℕ) [NeZero N] :
+    Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+        ({jqN N} : Set (LaurentSeries ℚ))) = dedekindPsi N :=
+  (ModularCurve.W1.hall_all N (NeZero.ne N) N dvd_rfl).1
+
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.modularFunctionField_eq_full (N : ℕ) [NeZero N] :
+    modularFunctionField N = modularFunctionFieldFull N :=
+  (ModularCurve.W1.hall_all N (NeZero.ne N) N dvd_rfl).2
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.functionFieldGeneration (N : ℕ) [NeZero N] :
+    FunctionFieldGeneration N :=
+  (ModularCurve.functionFieldGeneration_iff_full_eq N).mpr
+    (ModularCurve.modularFunctionField_eq_full N).symm
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.exists_phiIrreducible (N : ℕ) [NeZero N] :
+    ∃ data : ModularPolynomialData N, PhiIrreducible data :=
+  ModularCurve.exists_phiIrreducible_of_finrank_eq N (ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi
+    N)
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.relfinrank_full_eq_dedekindPsi (N : ℕ) [NeZero N] :
+    IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (modularFunctionFieldFull N) = dedekindPsi N := by
+  rw [← ModularCurve.modularFunctionField_eq_full N, ModularCurve.relfinrank_modularFunctionField N]
+  exact ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi N
+
+end
+
+p2m_open "ModularCurve~coeffEmb_qExpand\
+  " in
+open _root_.P2MW.S_ModularCurve_modularFunctionField_eq_full.ModularCurve in
+theorem solution (N : ℕ) [NeZero N] : modularFunctionField N = modularFunctionFieldFull N :=
+  ModularCurve.modularFunctionField_eq_full N
+
+end S_ModularCurve_modularFunctionField_eq_full
+end P2MW
+export P2MW.S_ModularCurve_modularFunctionField_eq_full (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.modularFunctionField_eq_full (N : ℕ) [NeZero N] :
+    modularFunctionField N = modularFunctionFieldFull N :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_modularFunctionField_eq_full_of.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_modularFunctionField_eq_full_of.lean
new file mode 100644
index 0000000000..da87d0f9fb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_modularFunctionField_eq_full_of.lean
@@ -0,0 +1,763 @@
+/-
+Based on Prove2Me node ModularCurve.modularFunctionField_eq_full_of
+(4cd6f92a-c178-5239-b610-1c75c886bc3f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e37f23f1-9452-511f-a3b0-5c5c2ac408cf
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Polynomial_mem_range_of_unique_common_root
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_injective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Descent closure: F_N = F_N^{full} from one-prime steps
+
+Theorem statement: `ModularCurve.modularFunctionField_eq_full_of`
+(`4cd6f92a-c178-5239-b610-1c75c886bc3f`), by Claude, 2026-09-05.
+
+Proof: submission `e37f23f1-9452-511f-a3b0-5c5c2ac408cf`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Work inside the Laurent series field $\mathbb{Q}((q))$, where for a nonzero natural number $d$ the
+ring homomorphism [`ModularCurve.qExpand ℚ d`](def/ModularCurve_X0.html#L25) substitutes $q \mapsto
+q^{d}$ (it reindexes exponents by multiplication by $d$), `jq` is the $q$-expansion of the modular
+$j$-invariant, and `jqN d` is its image `qExpand ℚ d jq`, i.e. $j(q^{d})$. For a nonzero natural
+number $N$, `modularFunctionField N` denotes the intermediate field $\mathbb{Q}(j(q), j(q^{N}))$
+obtained by adjoining the two elements `jq` and `qExpand ℚ N jq` to $\mathbb{Q}$, while
+`modularFunctionFieldFull N` is the intermediate field obtained by adjoining the whole set of
+expansions $j(q^{d})$ for all nonzero divisors $d$ of $N$. The theorem fixes such an $N$ and assumes
+two families of hypotheses, indexed by the factorisations of $N$ as $N = M p$ with $M$ nonzero and
+$p$ prime: first, that $j(q^{M})$ lies in `modularFunctionField N`; second, that
+`modularFunctionField M = modularFunctionFieldFull M`. Its conclusion is that `modularFunctionField
+N = modularFunctionFieldFull N`, that is, $\mathbb{Q}(j(q), j(q^{N}))$ already contains $j(q^{d})$
+for every divisor $d$ of $N$.
+
+This is the assembling step of the generation theorem for the function field of $X_0(N)$ over
+$\mathbb{Q}$: it propagates, along the divisor lattice, the statement that all expansions $j(q^{d})$
+with $d \mid N$ are generated by $j(q)$ and $j(q^{N})$. It is used in the induction that yields the
+generation statement at all levels and, with it, the degree computation
+$[\mathbb{Q}(j)(j_N):\mathbb{Q}(j)] = \psi(N)$ and the irreducibility of the modular polynomial
+$\Phi_N$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_modularFunctionField_eq_full_of.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_modularFunctionField_eq_full_of
+
+noncomputable section
+
+p2m_open "ModularCurve~coeffEmb_qExpand \
+  P2MW.S_ModularCurve_modularFunctionField_eq_full_of.ModularCurve ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionField adjoin_jq_le modularFunctionFieldFull jqd_mem_full \
+  modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+
+
+
+
+
+
+
+
+
+
+theorem coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb K (qExpand ℚ n x) = qExpand K n (coeffEmb K x) :=
+  coeffMap_qExpand (algebraMap ℚ K) n x
+
+theorem iota_jqN (N d : ℕ) [NeZero N] [NeZero d] :
+    coeffEmb K (qExpand ℚ N (jqN d)) = TS K (N * d) 1 := by
+  rw [jqN, coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem iota_jq (N : ℕ) [NeZero N] : coeffEmb K (qExpand ℚ N jq) = TS K N 1 := by
+  rw [coeffEmb_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_zero_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    conj p ζ (0 : Fin (p + 1)) = TS K (p * p) 1 := by
+  rw [conj_zero, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_succ_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) (b : Fin p) :
+    conj p ζ b.succ = TS K 1 (ζ ^ (b : ℕ)) := by
+  rw [conj_succ, TS_eq_coeffEmb, qExpand_one_apply]
+
+theorem qTwist_iota_of_pow_eq_one (N : ℕ) [NeZero N] (v : Kˣ) (hv : v ^ N = 1) (x : LaurentSeries ℚ)
+    :
+    qTwist v (coeffEmb K (qExpand ℚ N x)) = coeffEmb K (qExpand ℚ N x) := by
+  rw [coeffEmb_qExpand, qTwist_qExpand]
+  have : v ^ (N : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionField adjoin_jq_le modularFunctionFieldFull jqd_mem_full \
+  modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+omit [Algebra ℚ K] in
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+omit [Algebra ℚ K] in
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+omit [Algebra ℚ K] in
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem phiProd_conj_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    phiProd p (conj p ζ) = (Polynomial.X - Polynomial.C (TS K (p * p) 1)) *
+      ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) := by
+  rw [phiProd, Fin.prod_univ_succ, conj_zero_eq]
+  congr 1
+  rw [← Fin.prod_univ_eq_prod_range (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) p]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [conj_succ_eq]
+
+theorem roots_phiProd_conj (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    (phiProd p (conj p ζ)).roots = TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^
+      b)) := by
+  classical
+  rw [phiProd_conj_eq]
+  have h1 : (Polynomial.X - Polynomial.C (TS K (p * p) 1) : Polynomial (LaurentSeries K)) ≠ 0 :=
+    Polynomial.X_sub_C_ne_zero _
+  have h2 : (∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b)))) ≠ 0 :=
+    Finset.prod_ne_zero_iff.mpr fun b _ => Polynomial.X_sub_C_ne_zero _
+  rw [Polynomial.roots_mul (mul_ne_zero h1 h2), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod,
+    Finset.range_val]
+  have hm : (Multiset.map (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) (Multiset.range
+    p)) =
+      ((Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).map (fun a => Polynomial.X - Polynomial.C
+        a) := by
+    rw [Multiset.map_map]; rfl
+  rw [hm, Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+omit [Algebra ℚ K] in
+theorem roots_phiProd_conj_nodup (p : ℕ) [hp : Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).Nodup := by
+  refine Multiset.nodup_cons.mpr ⟨?_, ?_⟩
+  · intro hmem
+    obtain ⟨b, -, hb⟩ := Multiset.mem_map.mp hmem
+    have := (TS_injective hb).1
+    have h2 := hp.out.two_le
+    nlinarith
+  · refine (Multiset.nodup_range p).map_on fun b hb b' hb' hbb' => ?_
+    rw [Multiset.mem_range] at hb hb'
+    have hu := (TS_injective hbb').2
+    have hζu : IsPrimitiveRoot ζ p := IsPrimitiveRoot.coe_units_iff.mp hζ
+    exact hζu.pow_inj hb hb' hu
+
+theorem exists_isPrimitiveRoot_cyclotomicField (N : ℕ) [NeZero N] :
+    ∃ z : CyclotomicField N ℚ, IsPrimitiveRoot z N := by
+  have : NeZero ((N : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr (NeZero.ne N)⟩
+  have : IsCyclotomicExtension {N} ℚ (CyclotomicField N ℚ) :=
+    CyclotomicField.isCyclotomicExtension N ℚ
+  exact IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField N ℚ) (Set.mem_singleton N)
+    (NeZero.ne N)
+
+def cycUnit (N : ℕ) [NeZero N] : (CyclotomicField N ℚ)ˣ :=
+  ((exists_isPrimitiveRoot_cyclotomicField N).choose_spec.isUnit (NeZero.ne N)).unit
+
+theorem cycUnit_spec (N : ℕ) [NeZero N] :
+    IsPrimitiveRoot ((cycUnit N : (CyclotomicField N ℚ)ˣ) : CyclotomicField N ℚ) N := by
+  rw [cycUnit, IsUnit.unit_spec]
+  exact (exists_isPrimitiveRoot_cyclotomicField N).choose_spec
+
+theorem cycUnit_pow (N : ℕ) [NeZero N] : cycUnit N ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, (cycUnit_spec N).pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionField adjoin_jq_le modularFunctionFieldFull jqd_mem_full \
+  modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionField adjoin_jq_le modularFunctionFieldFull jqd_mem_full \
+  modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem prod_form_ne_zero (N : ℕ) (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e]
+    (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K
+            jq)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+          (Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u,
+    Polynomial.roots_mul (prod_form_ne_zero N ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p)))
+    (coeffEmb K jq))))
+        = ((Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+        (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+        (Multiset.range p).map
+          (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).Nodup := by
+  have hζp : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := isPrimitiveRoot_pow_div hζ hpN
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h := (TS_injective (K := K) (e := e) (e' := p * (p * e))
+      (u := u * ζ ^ (b * (N / p))) (u' := u ^ (p * p))
+      (by simpa only [TS_eq_coeffEmb] using heq)).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e)
+      (u := u * ζ ^ (b * (N / p))) (u' := u * ζ ^ (b' * (N / p)))
+      (by simpa only [TS_eq_coeffEmb] using heq)).2
+    have h2 : ζ ^ (b * (N / p)) = ζ ^ (b' * (N / p)) := mul_left_cancel h
+    have h3 : (ζ ^ (N / p)) ^ b = (ζ ^ (N / p)) ^ b' := by
+      rw [← pow_mul, ← pow_mul, Nat.mul_comm (N / p) b, Nat.mul_comm (N / p) b']
+      exact h2
+    have h4 : ((ζ ^ (N / p) : Kˣ) : K) ^ b = ((ζ ^ (N / p) : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h3]
+    exact hζp.pow_inj hb hb' h4
+
+theorem roots_prime_at_slot_roots_nodup (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots.Nodup := by
+  rw [roots_prime_at_slot N ζ hζ p hpN data e u]
+  exact roots_prime_at_slot_nodup N ζ hζ p hpN e u
+
+theorem isRoot_prime_at_slot_iff (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u]
+    exact prod_form_ne_zero N ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot N ζ hζ p hpN data e u,
+    Multiset.mem_cons, Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionField adjoin_jq_le modularFunctionFieldFull jqd_mem_full \
+  modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+
+
+
+
+theorem phiAtSeed_jq_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) :
+    (phiAtSeed data jq).eval (jqN n) = 0 := by
+  have h := data.eval_eq_zero
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp [evalAtJ_X]
+
+
+theorem phiAtSeed_jqN_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN M)).eval (jqN (M * n)) = 0 := by
+  have h := phiAtSeed_eval_map data jq (jqN n) (qExpand ℚ M) (phiAtSeed_jq_eval n data)
+  rwa [jqN, qExpand_qExpand] at h
+
+theorem phiAtSeed_iota_eval {K : Type*} [Field K] [Algebra ℚ K] (A : ℕ) [NeZero A] (n : ℕ)
+    [NeZero n]
+    (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (coeffEmb K (qExpand ℚ A (jqN M)))).eval (coeffEmb K (qExpand ℚ A (jqN (M *
+      n)))) = 0 :=
+  phiAtSeed_eval_map data _ _ ((coeffEmb K).comp (qExpand ℚ A)) (phiAtSeed_jqN_eval n data M)
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionField adjoin_jq_le modularFunctionFieldFull jqd_mem_full \
+  modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  coeffMap_injective exists_phiIrreducible_evalSymm"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+private theorem jqN_mem_of_div_primes {K : Type*} [Field K] [Algebra ℚ K]
+    {N : ℕ} [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    {F : IntermediateField ℚ (LaurentSeries ℚ)}
+    {d : ℕ} [NeZero d] (hdN : d ∣ N)
+    {p q : ℕ} (pp : Nat.Prime p) (qq : Nat.Prime q) (hpq : p ≠ q)
+    (hpd : p ∣ d) (hqd : q ∣ d) [NeZero (d / p)] [NeZero (d / q)]
+    (hmp : jqN (d / p) ∈ F) (hmq : jqN (d / q) ∈ F) :
+    jqN d ∈ F := by
+  have : Fact (Nat.Prime p) := ⟨pp⟩
+  have : Fact (Nat.Prime q) := ⟨qq⟩
+  have : NeZero p := ⟨pp.ne_zero⟩
+  have : NeZero q := ⟨qq.ne_zero⟩
+  have hpN : p ∣ N := hpd.trans hdN
+  have hqN : q ∣ N := hqd.trans hdN
+  have hNp0 : N / p ≠ 0 := fun h0 => NeZero.ne N (by rw [← Nat.div_mul_cancel hpN, h0, zero_mul])
+  have hNq0 : N / q ≠ 0 := fun h0 => NeZero.ne N (by rw [← Nat.div_mul_cancel hqN, h0, zero_mul])
+  have : NeZero (N / p) := ⟨hNp0⟩
+  have : NeZero (N / q) := ⟨hNq0⟩
+  have hpe : p * (N / p * (d / p)) = N * (d / p) := by
+    rw [← mul_assoc, Nat.mul_div_cancel' hpN]
+  have hqe : q * (N / q * (d / q)) = N * (d / q) := by
+    rw [← mul_assoc, Nat.mul_div_cancel' hqN]
+  have hpe2 : p * (p * (N / p * (d / p))) = N * d := by
+    rw [hpe, mul_left_comm, Nat.mul_div_cancel' hpd]
+  have hqe2 : q * (q * (N / q * (d / q))) = N * d := by
+    rw [hqe, mul_left_comm, Nat.mul_div_cancel' hqd]
+  have data_p : ModularPolynomialData p := (ModularCurve.exists_phiIrreducible_evalSymm p).choose
+  have data_q : ModularPolynomialData q := (ModularCurve.exists_phiIrreducible_evalSymm q).choose
+  let : Algebra F (LaurentSeries K) :=
+    (((coeffEmb K).comp (qExpand ℚ N)).comp (algebraMap F (LaurentSeries ℚ))).toAlgebra
+  have hmapA : (phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)).map (algebraMap F (LaurentSeries K))
+      = phiAtSeed data_p (coeffEmb K (qExpand ℚ N (jqN (d / p)))) :=
+    phiAtSeed_map data_p _ _
+  have hmapB : (phiAtSeed data_q (⟨jqN (d / q), hmq⟩ : F)).map (algebraMap F (LaurentSeries K))
+      = phiAtSeed data_q (coeffEmb K (qExpand ℚ N (jqN (d / q)))) :=
+    phiAtSeed_map data_q _ _
+  have hseed_p : coeffEmb K (qExpand ℚ N (jqN (d / p)))
+      = qExpand K (p * (N / p * (d / p))) (qTwist ((1 : Kˣ) ^ p) (coeffEmb K jq)) := by
+    have h2 : TS K (N * (d / p)) 1 = TS K (p * (N / p * (d / p))) ((1 : Kˣ) ^ p) := by
+      rw [one_pow]
+      exact TS_congr hpe.symm 1
+    simpa only [TS_eq_coeffEmb] using (iota_jqN N (d / p)).trans h2
+  have hseed_q : coeffEmb K (qExpand ℚ N (jqN (d / q)))
+      = qExpand K (q * (N / q * (d / q))) (qTwist ((1 : Kˣ) ^ q) (coeffEmb K jq)) := by
+    have h2 : TS K (N * (d / q)) 1 = TS K (q * (N / q * (d / q))) ((1 : Kˣ) ^ q) := by
+      rw [one_pow]
+      exact TS_congr hqe.symm 1
+    simpa only [TS_eq_coeffEmb] using (iota_jqN N (d / q)).trans h2
+  have hdist_p : coeffEmb K (qExpand ℚ N (jqN d))
+      = qExpand K (p * (p * (N / p * (d / p)))) (qTwist ((1 : Kˣ) ^ (p * p)) (coeffEmb K jq)) := by
+    have h2 : TS K (N * d) 1 = TS K (p * (p * (N / p * (d / p)))) ((1 : Kˣ) ^ (p * p)) := by
+      rw [one_pow]
+      exact TS_congr hpe2.symm 1
+    simpa only [TS_eq_coeffEmb] using (iota_jqN N d).trans h2
+  have hdist_q : coeffEmb K (qExpand ℚ N (jqN d))
+      = qExpand K (q * (q * (N / q * (d / q)))) (qTwist ((1 : Kˣ) ^ (q * q)) (coeffEmb K jq)) := by
+    have h2 : TS K (N * d) 1 = TS K (q * (q * (N / q * (d / q)))) ((1 : Kˣ) ^ (q * q)) := by
+      rw [one_pow]
+      exact TS_congr hqe2.symm 1
+    simpa only [TS_eq_coeffEmb] using (iota_jqN N d).trans h2
+  have hrootA : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)) = 0 ↔
+        (y = qExpand K (p * (p * (N / p * (d / p)))) (qTwist ((1 : Kˣ) ^ (p * p)) (coeffEmb K jq)) ∨
+          ∃ b < p, y = qExpand K (N / p * (d / p)) (qTwist (1 * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+            := by
+    intro y
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hmapA, hseed_p]
+    exact isRoot_prime_at_slot_iff N ζ hζ p hpN data_p (N / p * (d / p)) 1 y
+  have hrootB : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_q (⟨jqN (d / q), hmq⟩ : F)) = 0 ↔
+        (y = qExpand K (q * (q * (N / q * (d / q)))) (qTwist ((1 : Kˣ) ^ (q * q)) (coeffEmb K jq)) ∨
+          ∃ c < q, y = qExpand K (N / q * (d / q)) (qTwist (1 * ζ ^ (c * (N / q))) (coeffEmb K jq)))
+            := by
+    intro y
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hmapB, hseed_q]
+    exact isRoot_prime_at_slot_iff N ζ hζ q hqN data_q (N / q * (d / q)) 1 y
+  have hA0 : phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F) ≠ 0 := (phiAtSeed_monic data_p _).ne_zero
+  have hAs : ((phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)).map
+      (algebraMap F (LaurentSeries K))).Splits := by
+    rw [hmapA, hseed_p, phiAtSeed,
+      ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data_p (N / p * (d / p)) 1]
+    exact (Polynomial.Splits.X_sub_C _).mul
+      (Polynomial.Splits.prod fun b _ => Polynomial.Splits.X_sub_C _)
+  have hAnd : ((phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)).map
+      (algebraMap F (LaurentSeries K))).roots.Nodup := by
+    rw [hmapA, hseed_p, phiAtSeed]
+    exact roots_prime_at_slot_roots_nodup N ζ hζ p hpN data_p (N / p * (d / p)) 1
+  have hxA : Polynomial.aeval (coeffEmb K (qExpand ℚ N (jqN d)))
+      (phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)) = 0 :=
+    (hrootA _).mpr (Or.inl hdist_p)
+  have hxB : Polynomial.aeval (coeffEmb K (qExpand ℚ N (jqN d)))
+      (phiAtSeed data_q (⟨jqN (d / q), hmq⟩ : F)) = 0 :=
+    (hrootB _).mpr (Or.inl hdist_q)
+  have huniq : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)) = 0 →
+      Polynomial.aeval y (phiAtSeed data_q (⟨jqN (d / q), hmq⟩ : F)) = 0 →
+      y = coeffEmb K (qExpand ℚ N (jqN d)) := by
+    intro y hyA hyB
+    rcases (hrootA y).mp hyA with hy1 | ⟨b, hb, hy1⟩
+    · exact hy1.trans hdist_p.symm
+    · rcases (hrootB y).mp hyB with hy2 | ⟨c, hc, hy2⟩
+      · exact hy2.trans hdist_q.symm
+      · exfalso
+        have hTS : TS K (N / p * (d / p)) (1 * ζ ^ (b * (N / p)))
+            = TS K (N / q * (d / q)) (1 * ζ ^ (c * (N / q))) := by
+              simpa only [TS_eq_coeffEmb] using hy1.symm.trans hy2
+        have he : N / p * (d / p) = N / q * (d / q) := (TS_injective hTS).1
+        have h1 : p * p * (N / p * (d / p)) = q * q * (N / p * (d / p)) := by
+          rw [mul_assoc, hpe2, mul_assoc, he, hqe2]
+        have h2 : p * p = q * q :=
+          Nat.eq_of_mul_eq_mul_right (Nat.pos_of_ne_zero (NeZero.ne (N / p * (d / p)))) h1
+        have h3 : q ∣ p * p := by rw [h2]; exact dvd_mul_right q q
+        have h4 : q ∣ p := ((Nat.Prime.dvd_mul qq).mp h3).elim id id
+        exact hpq (((Nat.prime_dvd_prime_iff_eq qq pp).mp h4).symm)
+  have hrange := Polynomial.mem_range_of_unique_common_root
+    (phiAtSeed data_p (⟨jqN (d / p), hmp⟩ : F)) (phiAtSeed data_q (⟨jqN (d / q), hmq⟩ : F))
+    hA0 hAs hAnd (coeffEmb K (qExpand ℚ N (jqN d))) hxA hxB huniq
+  obtain ⟨f, hf⟩ := RingHom.mem_range.mp hrange
+  have hf' : coeffEmb K (qExpand ℚ N ((f : LaurentSeries ℚ)))
+      = coeffEmb K (qExpand ℚ N (jqN d)) := hf
+  have hemb : Function.Injective (coeffEmb K) :=
+    ModularCurve.coeffMap_injective ((algebraMap ℚ K).injective)
+  have hval : (f : LaurentSeries ℚ) = jqN d := qExpand_injective N (hemb hf')
+  rw [← hval]
+  exact f.2
+
+theorem phiAtSeed_eval_symm {n : ℕ} [NeZero n] (data : ModularPolynomialData n)
+    (hs : EvalSymm data.Φ)
+    (x y : LaurentSeries ℚ) : (phiAtSeed data x).eval y = (phiAtSeed data y).eval x := by
+  have key : ∀ z : LaurentSeries ℚ, Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries ℚ)) z =
+      (Polynomial.aeval (R := ℤ) z).toRingHom := fun z =>
+    Polynomial.ringHom_ext' (RingHom.ext_int _ _) (by simp)
+  rw [phiAtSeed, phiAtSeed, Polynomial.eval_map, Polynomial.eval_map, key, key]
+  exact hs x y
+
+theorem jqN_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) : jqN n = jqN m := by subst h; rfl
+
+theorem phiAtSeed_jqN_eval_down (q : ℕ) [NeZero q] (data : ModularPolynomialData q)
+    (hs : EvalSymm data.Φ)
+    (M : ℕ) [NeZero M] : (phiAtSeed data (jqN (M * q))).eval (jqN M) = 0 := by
+  rw [← phiAtSeed_eval_symm data hs]; exact phiAtSeed_jqN_eval q data M
+
+end ModularCurve.W1
+
+open ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionField adjoin_jq_le modularFunctionFieldFull jqd_mem_full \
+  modularFunctionField_le_full coeffEmb coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply \
+  qTwist_qTwist qTwist_qExpand EvalSymm coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  coeffMap_injective exists_phiIrreducible_evalSymm"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.jqN_div_mem_modularFunctionField (M : ℕ) [NeZero M] (p : ℕ)
+    [hp : Fact (Nat.Prime p)] {K : Type*} [Field K] [Algebra ℚ K] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) (M * p))
+    (htw : ∀ y : LaurentSeries K,
+      Polynomial.eval y ((minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+          (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M * p))).comp
+            (algebraMap (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+              (LaurentSeries ℚ)))) = 0 →
+        ∀ w : Kˣ, y = qExpand K (M * p * M) (qTwist w (coeffEmb K jq)) → w = 1)
+    (hsp : ∀ y : LaurentSeries K,
+      Polynomial.eval y ((minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+          (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M * p))).comp
+            (algebraMap (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+              (LaurentSeries ℚ)))) = 0 →
+        y ≠ coeffEmb K (qExpand ℚ (M * p) (jqN (M * p * p)))) :
+    jqN M ∈ modularFunctionField (M * p) := by
+  classical
+  obtain ⟨data, -, hsym⟩ := ModularCurve.exists_phiIrreducible_evalSymm p
+  have hpN : p ∣ M * p := dvd_mul_left p M
+  set F := modularFunctionField (M * p) with hF
+  have hjNmem : jqN (M * p) ∈ F :=
+    IntermediateField.subset_adjoin ℚ _ (Set.mem_insert_of_mem _ rfl)
+  have hle : IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)) ≤ F :=
+    ModularCurve.adjoin_jq_le (M * p)
+  let : Algebra F (LaurentSeries K) :=
+    (((coeffEmb K).comp (qExpand ℚ (M * p))).comp (algebraMap F (LaurentSeries ℚ))).toAlgebra
+  set A : Polynomial F := phiAtSeed data (⟨jqN (M * p), hjNmem⟩ : F) with hA
+  let ι₀ : (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) →+* F :=
+    { toFun := fun x => ⟨(x : LaurentSeries ℚ), hle x.2⟩
+      map_one' := rfl
+      map_mul' := fun _ _ => rfl
+      map_zero' := rfl
+      map_add' := fun _ _ => rfl }
+  set B : Polynomial F :=
+    (minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN M)).map ι₀
+    with hB
+  have hmapA : A.map (algebraMap F (LaurentSeries K))
+      = phiAtSeed data (coeffEmb K (qExpand ℚ (M * p) (jqN (M * p)))) :=
+    phiAtSeed_map data _ _
+  have hseed : coeffEmb K (qExpand ℚ (M * p) (jqN (M * p)))
+      = qExpand K (p * (M * p * M)) (qTwist ((1 : Kˣ) ^ p) (coeffEmb K jq)) := by
+    have h2 : TS K ((M * p) * (M * p)) 1 = TS K (p * (M * p * M)) ((1 : Kˣ) ^ p) := by
+      rw [one_pow]
+      exact TS_congr (by ring) 1
+    simpa only [TS_eq_coeffEmb] using (iota_jqN (M * p) (M * p)).trans h2
+  have hdist : coeffEmb K (qExpand ℚ (M * p) (jqN M))
+      = qExpand K (M * p * M) (qTwist (1 * ζ ^ (0 * (M * p / p))) (coeffEmb K jq)) := by
+    have h2 : TS K ((M * p) * M) 1 = TS K (M * p * M) (1 * ζ ^ (0 * (M * p / p))) := by
+      rw [Nat.zero_mul, pow_zero, mul_one]
+    simpa only [TS_eq_coeffEmb] using (iota_jqN (M * p) M).trans h2
+  have hspread : coeffEmb K (qExpand ℚ (M * p) (jqN (M * p * p)))
+      = qExpand K (p * (p * (M * p * M))) (qTwist ((1 : Kˣ) ^ (p * p)) (coeffEmb K jq)) := by
+    have h2 : TS K ((M * p) * (M * p * p)) 1
+        = TS K (p * (p * (M * p * M))) ((1 : Kˣ) ^ (p * p)) := by
+      rw [one_pow]
+      exact TS_congr (by ring) 1
+    simpa only [TS_eq_coeffEmb] using (iota_jqN (M * p) (M * p * p)).trans h2
+  have hrootA : ∀ y : LaurentSeries K,
+      Polynomial.aeval y A = 0 ↔
+        (y = qExpand K (p * (p * (M * p * M))) (qTwist ((1 : Kˣ) ^ (p * p)) (coeffEmb K jq)) ∨
+          ∃ b < p, y = qExpand K (M * p * M)
+            (qTwist (1 * ζ ^ (b * (M * p / p))) (coeffEmb K jq))) := by
+    intro y
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hmapA, hseed]
+    exact isRoot_prime_at_slot_iff (M * p) ζ hζ p hpN data (M * p * M) 1 y
+  have hcomp : (algebraMap F (LaurentSeries K)).comp ι₀
+      = ((coeffEmb K).comp (qExpand ℚ (M * p))).comp
+          (algebraMap (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+            (LaurentSeries ℚ)) := RingHom.ext fun x => rfl
+  have hBev : ∀ y : LaurentSeries K, Polynomial.aeval y B = 0 →
+      Polynomial.eval y ((minpoly (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+        (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M * p))).comp
+          (algebraMap (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+            (LaurentSeries ℚ)))) = 0 := by
+    intro y hy
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hB, Polynomial.map_map] at hy
+    rwa [hcomp] at hy
+  have hA0 : A ≠ 0 := (phiAtSeed_monic data _).ne_zero
+  have hAs : (A.map (algebraMap F (LaurentSeries K))).Splits := by
+    rw [hmapA, hseed, phiAtSeed,
+      ModularCurve.PhiGen.splits_prime_at_slot (M * p) ζ hζ p hpN data (M * p * M) 1]
+    exact (Polynomial.Splits.X_sub_C _).mul
+      (Polynomial.Splits.prod fun b _ => Polynomial.Splits.X_sub_C _)
+  have hAnd : (A.map (algebraMap F (LaurentSeries K))).roots.Nodup := by
+    rw [hmapA, hseed, phiAtSeed]
+    exact roots_prime_at_slot_roots_nodup (M * p) ζ hζ p hpN data (M * p * M) 1
+  set x₀ : LaurentSeries K := coeffEmb K (qExpand ℚ (M * p) (jqN M)) with hx₀
+  have hxA : Polynomial.aeval x₀ A = 0 :=
+    (hrootA x₀).mpr (Or.inr ⟨0, hp.out.pos, hdist⟩)
+  have hxB : Polynomial.aeval x₀ B = 0 := by
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hB, Polynomial.map_map, hcomp,
+      ← Polynomial.map_map, Polynomial.eval_map]
+    have hx₀ψ : x₀ = ((coeffEmb K).comp (qExpand ℚ (M * p))) (jqN M) := rfl
+    rw [hx₀ψ, Polynomial.eval₂_hom]
+    have hmp := minpoly.aeval
+      (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (jqN M)
+    rw [Polynomial.aeval_def, Polynomial.eval₂_eq_eval_map] at hmp
+    rw [hmp, map_zero]
+  have huniq : ∀ y : LaurentSeries K,
+      Polynomial.aeval y A = 0 → Polynomial.aeval y B = 0 → y = x₀ := by
+    intro y hyA hyB
+    rcases (hrootA y).mp hyA with hy1 | ⟨b, hb, hy1⟩
+    · exact absurd (hy1.trans hspread.symm) (hsp y (hBev y hyB))
+    · have hw := htw y (hBev y hyB) (1 * ζ ^ (b * (M * p / p))) hy1
+      rw [one_mul] at hw
+      have hb0 : b = 0 := by
+        have hord : (M * p) ∣ b * M := by
+          have hval : (ζ : K) ^ (b * (M * p / p)) = 1 := by
+            have := congrArg Units.val hw
+            simpa using this
+          rw [Nat.mul_div_cancel M hp.out.pos] at hval
+          exact (hζ.pow_eq_one_iff_dvd _).mp hval
+        have hpb : p ∣ b := by
+          have h2 : M * p ∣ M * b := by rwa [Nat.mul_comm b M] at hord
+          exact (Nat.mul_dvd_mul_iff_left (Nat.pos_of_ne_zero (NeZero.ne M))).mp h2
+        exact Nat.eq_zero_of_dvd_of_lt hpb hb
+      rw [hb0] at hy1
+      exact hy1.trans hdist.symm
+  have hrange := Polynomial.mem_range_of_unique_common_root A B hA0 hAs hAnd x₀ hxA hxB huniq
+  obtain ⟨f, hf⟩ := RingHom.mem_range.mp hrange
+  have hf' : coeffEmb K (qExpand ℚ (M * p) ((f : LaurentSeries ℚ)))
+      = coeffEmb K (qExpand ℚ (M * p) (jqN M)) := hf
+  have hemb : Function.Injective (coeffEmb K) :=
+    ModularCurve.coeffMap_injective ((algebraMap ℚ K).injective)
+  have hval : (f : LaurentSeries ℚ) = jqN M := qExpand_injective (M * p) (hemb hf')
+  rw [← hval]
+  exact f.2
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.modularFunctionField_eq_full_of (N : ℕ) [NeZero N]
+    (hstep : ∀ (M : ℕ) [NeZero M] (p : ℕ), p.Prime → M * p = N →
+      jqN M ∈ modularFunctionField N)
+    (hgen' : ∀ (M : ℕ) [NeZero M] (p : ℕ), p.Prime → M * p = N →
+      modularFunctionField M = modularFunctionFieldFull M) :
+    modularFunctionField N = modularFunctionFieldFull N := by
+  refine le_antisymm (modularFunctionField_le_full N) ?_
+  rw [modularFunctionFieldFull, IntermediateField.adjoin_le_iff]
+  rintro x ⟨d, hd0, hdN, rfl⟩
+  rcases eq_or_ne d N with rfl | hdlt
+  · exact IntermediateField.subset_adjoin ℚ _ (Set.mem_insert_of_mem _ rfl)
+  · obtain ⟨m, hm⟩ := hdN
+    have hm1 : m ≠ 1 := fun h1 => hdlt (by rw [hm, h1, Nat.mul_one])
+    have hm0 : m ≠ 0 := fun h0 => NeZero.ne N (by rw [hm, h0, Nat.mul_zero])
+    have hq : m.minFac.Prime := Nat.minFac_prime hm1
+    obtain ⟨m', hm'⟩ := Nat.minFac_dvd m
+    have hm'0 : m' ≠ 0 := fun h0 => hm0 (by rw [hm', h0, Nat.mul_zero])
+    have : NeZero (d * m') := ⟨Nat.mul_ne_zero hd0.out hm'0⟩
+    have hdm' : (d * m') * m.minFac = N := by
+      rw [Nat.mul_assoc, Nat.mul_comm m' m.minFac, ← hm', ← hm]
+    have hmem : jqN (d * m') ∈ modularFunctionField N := hstep (d * m') m.minFac hq hdm'
+    have hfull : modularFunctionField (d * m') = modularFunctionFieldFull (d * m') :=
+      hgen' (d * m') m.minFac hq hdm'
+    have hsub : modularFunctionFieldFull (d * m') ≤ modularFunctionField N := by
+      rw [← hfull, modularFunctionField, IntermediateField.adjoin_le_iff]
+      rintro y (rfl | hy)
+      · exact IntermediateField.subset_adjoin ℚ _ (Set.mem_insert _ _)
+      · rw [Set.mem_singleton_iff] at hy
+        rw [hy]
+        exact hmem
+    exact hsub (jqd_mem_full (d * m') ⟨m', rfl⟩)
+
+end
+
+p2m_open "ModularCurve~coeffEmb_qExpand\
+  " in
+open _root_.P2MW.S_ModularCurve_modularFunctionField_eq_full_of.ModularCurve in
+theorem solution (N : ℕ) [NeZero N] (hstep : ∀ (M : ℕ) [NeZero M] (p : ℕ), p.Prime → M * p = N → jqN
+  M ∈ modularFunctionField N) (hgen' : ∀ (M : ℕ) [NeZero M] (p : ℕ), p.Prime → M * p = N →
+  modularFunctionField M = modularFunctionFieldFull M) :
+    modularFunctionField N = modularFunctionFieldFull N :=
+  ModularCurve.modularFunctionField_eq_full_of N hstep hgen'
+
+end S_ModularCurve_modularFunctionField_eq_full_of
+end P2MW
+export P2MW.S_ModularCurve_modularFunctionField_eq_full_of (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.modularFunctionField_eq_full_of (N : ℕ) [NeZero N] (hstep : ∀ (M : ℕ) [NeZero
+  M] (p : ℕ), p.Prime → M * p = N → jqN M ∈ modularFunctionField N) (hgen' : ∀ (M : ℕ) [NeZero M] (p
+  : ℕ), p.Prime → M * p = N → modularFunctionField M = modularFunctionFieldFull M) :
+    modularFunctionField N = modularFunctionFieldFull N :=
+  solution N hstep hgen'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_modularPolynomialFamily.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_modularPolynomialFamily.lean
new file mode 100644
index 0000000000..e53eca0020
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_modularPolynomialFamily.lean
@@ -0,0 +1,124 @@
+/-
+Based on Prove2Me node ModularCurve.modularPolynomialFamily
+(35253992-77dd-5a2c-8796-45e571533890) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission cbe4c522-7c07-5fe4-80be-ddebcda7c019
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_exists_phiGenDescends
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_PhiGenDescends_intCoeffs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_mem_adjoin_jq_of_phiGenDescends
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_exists_modularPolynomialData_coeff_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_evalSymm_of_coeff_evalAtJ_eq
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Symmetric modular polynomials Φ_ℓ exist for every prime
+
+Theorem statement: `ModularCurve.modularPolynomialFamily` (`35253992-77dd-5a2c-8796-45e571533890`),
+by Claude, 2026-09-05.
+
+Proof: submission `cbe4c522-7c07-5fe4-80be-ddebcda7c019`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+The theorem asserts the proposition `ModularPolynomialFamily`: for every natural number $\ell$ that
+is prime there exists a term `data` of the structure `ModularPolynomialData ℓ` whose underlying
+polynomial satisfies `EvalSymm`. Unfolding the structure, this says that there is a polynomial $\Phi
+\in (\mathbb{Z}[X])[Y]$, i.e. an element of `Polynomial (Polynomial ℤ)`, such that: $\Phi$ is monic
+in $Y$; its degree in $Y$ equals `dedekindPsi ℓ` (so $\ell+1$ for prime $\ell$); and $\Phi$ vanishes
+under the evaluation `Φ.eval₂ evalAtJ (jqN ℓ)`, that is, substituting the ring homomorphism
+`evalAtJ` on the coefficients in $\mathbb{Z}[X]$ and the distinguished Laurent series `jqN ℓ` for
+$Y$ gives $0$ in `LaurentSeries ℚ`. The additional property `EvalSymm Φ` is the symmetry of $\Phi$
+as a two-variable substitution operator on Laurent series over $\mathbb{Q}$: for all $x, y \in
+\mathbb{Q}((q))$, substituting $x$ into the coefficient polynomials and $y$ into the outer variable
+gives the same element as substituting $y$ into the coefficients and $x$ outside. Composite levels
+are not covered.
+
+This is the existence statement for the classical modular polynomial $\Phi_\ell(X,Y)$ of prime
+level, monic of degree $\psi(\ell)=\ell+1$, vanishing on the pair of $j$-series of level $\ell$ and
+symmetric in its two arguments. It is consumed as a standing input by the modular-curve development
+built on $X_0(\ell)$, in particular by the results on zeros of $j$ and on place specialisation that
+cite it.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_modularPolynomialFamily.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_modularPolynomialFamily
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jq ModularPolynomialData EvalSymm ModularPolynomialFamily \
+  PhiGen.IntCoeffs PhiGen.exists_phiGenDescends PhiGen.mem_adjoin_jq_of_phiGenDescends \
+  PhiGen.exists_modularPolynomialData_coeff_eq PhiGen.evalSymm_of_coeff_evalAtJ_eq"
+p2m_open "ModularCurve"
+
+theorem exists_modularPolynomialData_evalSymm' (ℓ : ℕ) [hℓ : Fact (Nat.Prime ℓ)] :
+    ∃ data : ModularPolynomialData ℓ, EvalSymm data.Φ := by
+  have : NeZero ((ℓ : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr hℓ.out.ne_zero⟩
+  have hcyc : IsCyclotomicExtension {ℓ} ℚ (CyclotomicField ℓ ℚ) :=
+    CyclotomicField.isCyclotomicExtension (n := ℓ) (K := ℚ)
+  have : FiniteDimensional ℚ (CyclotomicField ℓ ℚ) :=
+    IsCyclotomicExtension.finiteDimensional {ℓ} ℚ (CyclotomicField ℓ ℚ)
+  have : IsGalois ℚ (CyclotomicField ℓ ℚ) :=
+    IsCyclotomicExtension.isGalois (S := {ℓ}) (K := ℚ) (L := CyclotomicField ℓ ℚ)
+  obtain ⟨z, hz⟩ := IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField ℓ ℚ)
+    (Set.mem_singleton ℓ) hℓ.out.ne_zero
+  have hzu : IsUnit z := hz.isUnit hℓ.out.ne_zero
+  have hζ : IsPrimitiveRoot ((hzu.unit : (CyclotomicField ℓ ℚ)ˣ) : CyclotomicField ℓ ℚ) ℓ := by
+    rw [hzu.unit_spec]; exact hz
+  have hζ1 : hzu.unit ^ ℓ = 1 := by
+    refine Units.ext ?_
+    rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one]
+  obtain ⟨c, hc⟩ := PhiGen.exists_phiGenDescends ℓ hzu.unit hζ
+  have hint : ∀ k, PhiGen.IntCoeffs (c k) := fun k => hc.intCoeffs hζ1 k
+  have hmem : ∀ k, c k ∈ Algebra.adjoin ℚ {jq} :=
+    fun k => PhiGen.mem_adjoin_jq_of_phiGenDescends ℓ hzu.unit hζ c hc k
+  obtain ⟨data, hcoeff⟩ := PhiGen.exists_modularPolynomialData_coeff_eq hc hint hmem
+  exact ⟨data, PhiGen.evalSymm_of_coeff_evalAtJ_eq hζ hc data hcoeff⟩
+
+theorem modularPolynomialFamily' : ModularPolynomialFamily :=
+  fun ℓ _ hℓ => by
+    have : Fact (Nat.Prime ℓ) := ⟨hℓ⟩
+    exact exists_modularPolynomialData_evalSymm' ℓ
+
+end ModularCurve
+
+end
+
+theorem solution : ModularCurve.ModularPolynomialFamily := ModularCurve.modularPolynomialFamily'
+
+end S_ModularCurve_modularPolynomialFamily
+end P2MW
+export P2MW.S_ModularCurve_modularPolynomialFamily (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.modularPolynomialFamily :
+    ModularPolynomialFamily :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_modularUnitSeries_mem_modularFunctionField.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_modularUnitSeries_mem_modularFunctionField.lean
new file mode 100644
index 0000000000..e8cb49319e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_modularUnitSeries_mem_modularFunctionField.lean
@@ -0,0 +1,92 @@
+/-
+Based on Prove2Me node ModularCurve.modularUnitSeries_mem_modularFunctionField
+(cf151edf-c330-5738-a8a0-fb1350ee0fe3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e3b3885b-65b7-5b8c-9001-f09188a67cad
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ModularUnit
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+import Mathlib.NumberTheory.ModularForms.Discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_modularUnitSeries_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_smul_modularUnitSeries_inv_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_modularUnitSeries_inv_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_hasSum_smul_modularUnitSeries_qParam
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_discriminant_div_discriminant_heckeDiagMatrix_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_mem_modularFunctionField_of_hasSum_of_gamma0_invariant
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Ogg's unit Δ(q)/Δ(q^ℓ) lies in ℚ(j,j_ℓ)
+
+Theorem statement: `ModularCurve.modularUnitSeries_mem_modularFunctionField`
+(`cf151edf-c330-5738-a8a0-fb1350ee0fe3`), by Claude, 2026-09-05.
+
+Proof: submission `e3b3885b-65b7-5b8c-9001-f09188a67cad`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\ell$ be a prime. Write $\mathrm{qExpand}\,\mathbb{Q}\,\ell$ for the ring endomorphism of the
+Laurent series field $\mathbb{Q}((q))$ obtained by transporting a series along the order-preserving
+injection $m \mapsto \ell m$ of the exponent group $\mathbb{Z}$, that is, the substitution $q
+\mapsto q^{\ell}$. Let $\mathrm{deltaSeries} = q \cdot \mathrm{dedekindEtaUnitQ}$ be the Laurent
+series given by the monomial $q$ times the power series $\prod_{n\ge 1}(1-q^{n})^{24}$, and let
+$\mathrm{modularUnitSeries}\,\ell = \mathrm{deltaSeries} \cdot
+(\mathrm{qExpand}\,\mathbb{Q}\,\ell\,\mathrm{deltaSeries})^{-1}$, the formal quotient
+$\Delta(q)/\Delta(q^{\ell})$ in $\mathbb{Q}((q))$. Let $\mathrm{modularFunctionField}\,\ell$ be the
+intermediate field of $\mathbb{Q} \subseteq \mathbb{Q}((q))$ generated over $\mathbb{Q}$ by the two
+elements `jq` and $\mathrm{qExpand}\,\mathbb{Q}\,\ell\,$`jq`. The theorem asserts that
+$\mathrm{modularUnitSeries}\,\ell$ belongs to $\mathrm{modularFunctionField}\,\ell$: the Laurent
+series $\Delta(q)/\Delta(q^{\ell})$ is a rational function, with rational coefficients, of `jq` and
+of its image under $q \mapsto q^{\ell}$.
+
+This is the rationality statement for Ogg's modular unit on $X_0(\ell)$, whose divisor is supported
+on the cusps: the quotient $\Delta(\tau)/\Delta(\ell\tau)$ is a function on $X_0(\ell)$ defined over
+$\mathbb{Q}$. It is used in the construction of explicit units in the coordinate algebras of charts
+of modular curves, in particular for the chart algebras occurring in the treatment of $X_1$ and of
+the $\Gamma_H$-level curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_modularUnitSeries_mem_modularFunctionField.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_modularUnitSeries_mem_modularFunctionField
+
+theorem solution (ℓ : ℕ) [Fact (Nat.Prime ℓ)] :
+    ModularCurve.modularUnitSeries ℓ ∈ ModularCurve.modularFunctionField ℓ := by
+  have : NeZero ℓ := ⟨(Fact.out : Nat.Prime ℓ).ne_zero⟩
+  exact ModularCurve.mem_modularFunctionField_of_hasSum_of_gamma0_invariant ℓ
+    (ModularCurve.modularUnitSeries ℓ) ((ℓ : ℚ) ^ 12 • (ModularCurve.modularUnitSeries ℓ)⁻¹)
+    (fun τ => ModularForm.discriminant τ
+      / ModularForm.discriminant (ModularForm.heckeDiagMatrix ℓ • τ))
+    (fun τ => ModularCurve.hasSum_modularUnitSeries_qParam ℓ τ)
+    (fun τ => ModularCurve.hasSum_smul_modularUnitSeries_inv_qParam ℓ τ)
+    (fun γ hγ τ => ModularCurve.discriminant_div_discriminant_heckeDiagMatrix_smul ℓ γ hγ τ)
+
+end S_ModularCurve_modularUnitSeries_mem_modularFunctionField
+end P2MW
+export P2MW.S_ModularCurve_modularUnitSeries_mem_modularFunctionField (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.modularUnitSeries_mem_modularFunctionField (ℓ : ℕ) [Fact (Nat.Prime ℓ)] :
+    ModularCurve.modularUnitSeries ℓ ∈ ModularCurve.modularFunctionField ℓ :=
+  solution ℓ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_modularUnitSeries_mem_modularFunctionFieldFull.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_modularUnitSeries_mem_modularFunctionFieldFull.lean
new file mode 100644
index 0000000000..1d75f8e7fe
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_modularUnitSeries_mem_modularFunctionFieldFull.lean
@@ -0,0 +1,110 @@
+/-
+Based on Prove2Me node ModularCurve.modularUnitSeries_mem_modularFunctionFieldFull
+(55ba7334-be8a-5179-a36e-7862c943490d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission bbb00a88-70a0-5648-8976-119669fb911b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ModularUnit
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularUnitSeries_mem_modularFunctionField
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Ogg's modular unit lies in the full level-N function field
+
+Theorem statement: `ModularCurve.modularUnitSeries_mem_modularFunctionFieldFull`
+(`55ba7334-be8a-5179-a36e-7862c943490d`), by Claude, 2026-09-05.
+
+Proof: submission `bbb00a88-70a0-5648-8976-119669fb911b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number. Write $\Delta =$
+[`ModularCurve.deltaSeries`](def/ModularCurve_ModularUnit.html#L107) for the Laurent series over
+$\mathbb{Q}$ given by $q$ (the Hahn series $q^{1}$ with coefficient $1$) times the power series
+`dedekindEtaUnitQ`, and for $d \ge 1$ let `qExpand ℚ d` denote the substitution $q \mapsto q^{d}$ on
+`LaurentSeries ℚ`. The theorem asserts that the element
+[`ModularCurve.modularUnitSeries N`](def/ModularCurve_ModularUnit.html#L127) $= \Delta(q)\cdot
+\Delta(q^{N})^{-1}$, the product of $\Delta$ with the inverse of its $N$-th $q$-expansion
+`deltaSeriesN N`, belongs to [`ModularCurve.modularFunctionFieldFull
+N`](def/ModularCurve_X0.html#L305), namely the intermediate field of `LaurentSeries ℚ` over
+$\mathbb{Q}$ generated by the set of all series $\mathrm{qExpand}_{\mathbb{Q},d}(\mathtt{jq})$ for
+nonzero divisors $d$ of $N$, i.e. by the $q$-expansions $j(q^{d})$, $d \mid N$. No primality or
+other hypothesis on $N$ is imposed: the assertion is unconditional in the level.
+
+This is the statement that Ogg's modular unit $\Delta(q)/\Delta(q^{N})$ is a rational function of
+the expansions $j(q^{d})$, $d \mid N$, at arbitrary, not merely prime, level; in the formalisation
+it supplies the unit used to produce functions with prescribed divisors on the modular curve of
+level $N$. It is cited throughout the construction of Deligne–Rapoport-style models and charts at
+general level.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_modularUnitSeries_mem_modularFunctionFieldFull.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_modularUnitSeries_mem_modularFunctionFieldFull
+
+theorem solution (N : ℕ) [NeZero N] :
+    ModularCurve.modularUnitSeries N ∈ ModularCurve.modularFunctionFieldFull N := by
+  suffices H : ∀ n : ℕ, ∀ _ : NeZero n,
+      ModularCurve.modularUnitSeries n ∈ ModularCurve.modularFunctionFieldFull n from
+    H N ‹NeZero N›
+  intro n
+  induction n using Nat.strong_induction_on with
+  | _ n ih =>
+    intro hNZ
+    have := hNZ
+    have hn : n ≠ 0 := NeZero.ne n
+    rcases eq_or_ne n 1 with rfl | hn1
+    · rw [ModularCurve.modularUnitSeries_one]
+      exact one_mem _
+    · obtain ⟨p, hp, hdvd⟩ := Nat.exists_prime_and_dvd hn1
+      obtain ⟨M, rfl⟩ := hdvd
+      have hM : M ≠ 0 := by rintro rfl; exact hn (mul_zero p)
+      have hp0 : p ≠ 0 := hp.ne_zero
+      have : NeZero p := ⟨hp0⟩
+      have : NeZero M := ⟨hM⟩
+      have : NeZero (p * M) := ⟨mul_ne_zero hp0 hM⟩
+      have : Fact p.Prime := ⟨hp⟩
+      rw [ModularCurve.modularUnitSeries_mul p M]
+      refine mul_mem ?_ ?_
+      · exact ModularCurve.full_degeneracy_le (dvd_mul_right p M)
+          (ModularCurve.modularFunctionField_le_full p
+            (ModularCurve.modularUnitSeries_mem_modularFunctionField p))
+      · have hMlt : M < p * M :=
+          (lt_mul_iff_one_lt_left (Nat.pos_of_ne_zero hM)).mpr hp.one_lt
+        have hmem := ih M hMlt ⟨hM⟩
+        have h2 : ModularCurve.qExpandₐ p (ModularCurve.modularUnitSeries M)
+            ∈ (ModularCurve.modularFunctionFieldFull M).map (ModularCurve.qExpandₐ p) :=
+          ⟨_, hmem, rfl⟩
+        have h3 := ModularCurve.full_degeneracy_map_le M p h2
+        rw [ModularCurve.qExpandₐ_apply] at h3
+        exact ModularCurve.full_degeneracy_le (dvd_of_eq (mul_comm M p)) h3
+
+end S_ModularCurve_modularUnitSeries_mem_modularFunctionFieldFull
+end P2MW
+export P2MW.S_ModularCurve_modularUnitSeries_mem_modularFunctionFieldFull (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.modularUnitSeries_mem_modularFunctionFieldFull (N : ℕ) [NeZero N] :
+    ModularCurve.modularUnitSeries N ∈ ModularCurve.modularFunctionFieldFull N :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_doubleCoset_le_card_fibres_of_finrank_eq_index.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_doubleCoset_le_card_fibres_of_finrank_eq_index.lean
new file mode 100644
index 0000000000..3e6948c047
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_doubleCoset_le_card_fibres_of_finrank_eq_index.lean
@@ -0,0 +1,1221 @@
+/-
+Based on Prove2Me node ModularCurve.natCard_doubleCoset_le_card_fibres_of_finrank_eq_index
+(028fa6e7-01b7-5d70-8ba5-0d1fef0abfc1) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1154a053-82e5-590d-9478-44a39ec89606
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.GroupTheory.DoubleCoset
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Algebra.Lie.OfAssociative
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.Data.Int.Star
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_restrictAlong_eq_natCard_algHom_of_isGalois
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finrank_le_and_natCard_places_le_of_constantFieldExtension_adjoin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_transcendental_of_perfectField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_monoidHom_algEquiv_fixedField_eq_adjoin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_place_ord_jGen_le_two_three_level
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_place_ord_neg_forall_smul_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_place_ord_sub_pos_forall_smul_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelN_structure_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Lower bounds for the fibres of j over 0, 1728, ∞
+
+Theorem statement: `ModularCurve.natCard_doubleCoset_le_card_fibres_of_finrank_eq_index`
+(`028fa6e7-01b7-5d70-8ba5-0d1fef0abfc1`), by Claude, 2026-09-05.
+
+Proof: submission `1154a053-82e5-590d-9478-44a39ec89606`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a nonzero natural number and $\Gamma\le \mathrm{SL}(2,\mathbb Z)$ a subgroup with
+$\Gamma_1(M)\le\Gamma$. Write $F(\Gamma)\subseteq\mathbb Q((q))$ for the subfield generated over
+$\mathbb Q$ by all quotients $\mathrm{intSeriesC}(p_f)/\mathrm{intSeriesC}(p_g)$ with $f,g$ modular
+forms of some common weight $k$ for $\Gamma$ (regarded inside $\mathrm{GL}(2,\mathbb R)$) admitting
+integral $q$-expansions $p_f,p_g\in\mathbb Z[[q]]$ and $\mathrm{intSeriesC}(p_g)\neq 0$, and let
+$F=\mathrm{laurentBaseChange}$ be the subfield of $\overline{\mathbb Q}((q))$ generated over
+$\overline{\mathbb Q}$ by the coefficientwise image of $F(\Gamma)$. Let $y\in F$ be an element whose
+underlying Laurent series is $\mathrm{jqModC}$, namely $q^{-1}$ times the power series
+$E_4^3\cdot\eta^{-24}$ over $\overline{\mathbb Q}$, i.e. the $q$-expansion of $j$. Assume the degree
+hypothesis $[F:\overline{\mathbb Q}(y)]=[\mathrm{SL}(2,\mathbb Z):\Gamma\cdot\{\pm 1\}]$, the index
+of $\Gamma\sqcup\langle -1\rangle$. Then three inequalities hold simultaneously, where places of $F$
+over $\overline{\mathbb Q}$ are valuation subrings of $F$ containing $\overline{\mathbb Q}$, proper,
+with principal ideals, and $\mathrm{ord}$ is minus the logarithm of the associated adic valuation:
+the number of double cosets $\Gamma\backslash \mathrm{SL}(2,\mathbb Z)/\langle ST\rangle$ is at most
+the number of places $P$ with $\mathrm{ord}_P(y)>0$; the number of $\Gamma\backslash
+\mathrm{SL}(2,\mathbb Z)/\langle S\rangle$ is at most the number of places with
+$\mathrm{ord}_P(y-1728)>0$; and the number of $\Gamma\backslash \mathrm{SL}(2,\mathbb Z)/\langle
+T,-1\rangle$ is at most the number of places with $\mathrm{ord}_P(y)<0$.
+
+Classically the fibres of $j\colon X(\Gamma)\to X(1)$ over $0$, $1728$ and $\infty$ are in bijection
+with the double coset spaces $\Gamma\backslash\mathrm{SL}(2,\mathbb Z)/\langle ST\rangle$,
+$\Gamma\backslash\mathrm{SL}(2,\mathbb Z)/\langle S\rangle$ and
+$\Gamma\backslash\mathrm{SL}(2,\mathbb Z)/\langle T,-1\rangle$, the stabilisers being those of
+$\rho$, $i$ and of the cusp $\infty$; here only the inequalities in one direction are asserted, for
+the $q$-expansion model of the function field over $\overline{\mathbb Q}$. It feeds the exact count
+of these fibres and, through it, the genus comparisons used for the modular curves of the Fermat
+argument.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_natCard_doubleCoset_le_card_fibres_of_finrank_eq_index.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_natCard_doubleCoset_le_card_fibres_of_finrank_eq_index
+
+
+open UpperHalfPlane
+open scoped MatrixGroups IntermediateField Manifold
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpFunctionFieldC jGen laurentBaseChange jqModC LevelN.wp \
+  LevelN.fricke LevelN.jAnalytic LevelN.ring LevelN.jGen \
+  LevelN.exists_monoidHom_algEquiv_fixedField_eq_adjoin \
+  LevelN.exists_place_ord_sub_pos_forall_smul_eq LevelN.exists_place_ord_neg_forall_smul_eq \
+  exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN \
+  LevelN.exists_place_ord_jGen_le_two_three_level transcendental_jqModC"
+namespace SpecialFibresLB
+p2m_open "ModularCurve"
+
+theorem E₄_smul (γ : SL(2, ℤ)) (τ : ℍ) :
+    ModularForm.E₄ (γ • τ) = denom γ τ ^ (4 : ℤ) * ModularForm.E₄ τ := by
+  have h := SlashInvariantForm.slash_action_eqn'' (Γ := 𝒮ℒ) (k := (4 : ℤ)) ModularForm.E₄
+    (γ := (γ : GL (Fin 2) ℝ)) ⟨γ, rfl⟩ τ
+  simpa [ModularGroup.sl_moeb] using h
+
+theorem E₆_smul (γ : SL(2, ℤ)) (τ : ℍ) :
+    ModularForm.E₆ (γ • τ) = denom γ τ ^ (6 : ℤ) * ModularForm.E₆ τ := by
+  have h := SlashInvariantForm.slash_action_eqn'' (Γ := 𝒮ℒ) (k := (6 : ℤ)) ModularForm.E₆
+    (γ := (γ : GL (Fin 2) ℝ)) ⟨γ, rfl⟩ τ
+  simpa [ModularGroup.sl_moeb] using h
+
+theorem S_smul_I : ModularGroup.S • UpperHalfPlane.I = UpperHalfPlane.I :=
+  ModularGroup.stabilizer_I.mpr (by simp)
+
+theorem ST_smul_ρ : (ModularGroup.S * ModularGroup.T) • ρ = ρ :=
+  ModularGroup.stabilizer_ρ.mpr (by simp)
+
+theorem TinvS_smul_ρ : (ModularGroup.T⁻¹ * ModularGroup.S) • ρ = ρ :=
+  ModularGroup.stabilizer_ρ.mpr (by simp)
+
+theorem E₆_I : ModularForm.E₆ UpperHalfPlane.I = 0 := by
+  have h := E₆_smul ModularGroup.S UpperHalfPlane.I
+  rw [S_smul_I, ModularGroup.denom_S, UpperHalfPlane.coe_I] at h
+  have hI6 : Complex.I ^ (6 : ℤ) = -1 := by
+    rw [show (6 : ℤ) = ((6 : ℕ) : ℤ) from rfl, zpow_natCast]
+    calc Complex.I ^ 6 = (Complex.I ^ 2) ^ 3 := by ring
+      _ = -1 := by rw [Complex.I_sq]; norm_num
+  rw [hI6] at h
+  linear_combination h / 2
+
+theorem denom_TinvS_ρ :
+    denom (↑(ModularGroup.T⁻¹ * ModularGroup.S) : GL (Fin 2) ℝ) ρ = (ρ : ℂ) := by
+  rw [ModularGroup.denom_apply]
+  have h10 : (ModularGroup.T⁻¹ * ModularGroup.S) 1 0 = 1 := by
+    rw [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_T_inv, ModularGroup.coe_S]
+    simp
+  have h11 : (ModularGroup.T⁻¹ * ModularGroup.S) 1 1 = 0 := by
+    rw [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_T_inv, ModularGroup.coe_S]
+    simp
+  rw [h10, h11]
+  simp
+
+theorem ρ_ne_one : (ρ : ℂ) ≠ 1 := by
+  intro h
+  have := congrArg Complex.im h
+  rw [UpperHalfPlane.coe_im] at this
+  simp only [Complex.one_im] at this
+  exact ρ.im_pos.ne' this
+
+theorem E₄_ρ : ModularForm.E₄ ρ = 0 := by
+  have h := E₄_smul (ModularGroup.T⁻¹ * ModularGroup.S) ρ
+  rw [TinvS_smul_ρ, denom_TinvS_ρ] at h
+  have hρ4 : (ρ : ℂ) ^ (4 : ℤ) = (ρ : ℂ) := by
+    rw [show (4 : ℤ) = ((4 : ℕ) : ℤ) from rfl, zpow_natCast]
+    linear_combination ((ρ : ℂ) ^ 2 - ρ) * ρ_sq
+  rw [hρ4] at h
+  have : ((ρ : ℂ) - 1) * ModularForm.E₄ ρ = 0 := by linear_combination -h
+  rcases mul_eq_zero.mp this with h1 | h1
+  · exact absurd (sub_eq_zero.mp h1) ρ_ne_one
+  · exact h1
+
+theorem jAnalytic_ρ : LevelN.jAnalytic ρ = 0 := by
+  rw [LevelN.jAnalytic, E₄_ρ]
+  simp
+
+theorem jAnalytic_I : LevelN.jAnalytic UpperHalfPlane.I = 1728 := by
+  have hΔ := ModularForm.discriminant_eq_E₄_cube_sub_E₆_sq UpperHalfPlane.I
+  rw [E₆_I] at hΔ
+  have hΔ0 := ModularForm.discriminant_ne_zero UpperHalfPlane.I
+  have hE4 : ModularForm.E₄ UpperHalfPlane.I ≠ 0 := by
+    intro h
+    apply hΔ0
+    rw [hΔ, h]
+    norm_num
+  rw [LevelN.jAnalytic, hΔ]
+  field_simp
+  ring
+
+abbrev Gpm (N : ℕ) : Subgroup SL(2, ℤ) :=
+  CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))
+
+theorem mem_Gpm_imp (N : ℕ) {g : SL(2, ℤ)} (hg : g ∈ Gpm N) :
+    g ∈ CongruenceSubgroup.Gamma N ∨ -g ∈ CongruenceSubgroup.Gamma N := by
+  have : (CongruenceSubgroup.Gamma N).Normal := CongruenceSubgroup.Gamma_normal N
+  obtain ⟨y, hy, z, hz, rfl⟩ := Subgroup.mem_sup_of_normal_left.mp hg
+  obtain ⟨k, rfl⟩ := Subgroup.mem_zpowers_iff.mp hz
+  have h2 : ((-1 : SL(2, ℤ)) ^ (2 : ℤ)) = 1 := by rw [zpow_two]; simp
+  rcases Int.even_or_odd k with ⟨m, rfl⟩ | ⟨m, rfl⟩
+  · left
+    rw [← two_mul, zpow_mul, h2, one_zpow, mul_one]
+    exact hy
+  · right
+    rw [zpow_add, zpow_mul, h2, one_zpow, one_mul, zpow_one, mul_neg_one, neg_neg]
+    exact hy
+
+theorem mem_Gpm_of (N : ℕ) {g : SL(2, ℤ)}
+    (hg : g ∈ CongruenceSubgroup.Gamma N ∨ -g ∈ CongruenceSubgroup.Gamma N) : g ∈ Gpm N := by
+  rcases hg with h | h
+  · exact Subgroup.mem_sup_left h
+  · have : g = -g * (-1) := by simp
+    rw [this]
+    exact Subgroup.mul_mem _ (Subgroup.mem_sup_left h)
+      (Subgroup.mem_sup_right (Subgroup.mem_zpowers _))
+
+theorem entry_10_eq_zero_of_mem_Gpm (N : ℕ) {g : SL(2, ℤ)} (hg : g ∈ Gpm N) :
+    ((g 1 0 : ℤ) : ZMod N) = 0 := by
+  rcases mem_Gpm_imp N hg with h | h
+  · exact (CongruenceSubgroup.Gamma_mem.mp h).2.2.1
+  · have := (CongruenceSubgroup.Gamma_mem.mp h).2.2.1
+    rw [Matrix.SpecialLinearGroup.coe_neg, Matrix.neg_apply, Int.cast_neg, neg_eq_zero] at this
+    exact this
+
+theorem entry_01_eq_zero_of_mem_Gpm (N : ℕ) {g : SL(2, ℤ)} (hg : g ∈ Gpm N) :
+    ((g 0 1 : ℤ) : ZMod N) = 0 := by
+  rcases mem_Gpm_imp N hg with h | h
+  · exact (CongruenceSubgroup.Gamma_mem.mp h).2.1
+  · have := (CongruenceSubgroup.Gamma_mem.mp h).2.1
+    rw [Matrix.SpecialLinearGroup.coe_neg, Matrix.neg_apply, Int.cast_neg, neg_eq_zero] at this
+    exact this
+
+theorem dvd_of_T_pow_mem (N : ℕ) {n : ℕ} (h : ModularGroup.T ^ n ∈ Gpm N) : N ∣ n := by
+  have h01 := entry_01_eq_zero_of_mem_Gpm N h
+  rw [← zpow_natCast, ModularGroup.coe_T_zpow] at h01
+  simp only [Matrix.of_apply, Matrix.cons_val', Matrix.cons_val_one, Matrix.cons_val_fin_one,
+    Matrix.cons_val_zero, Int.cast_natCast] at h01
+  exact (ZMod.natCast_eq_zero_iff n N).mp h01
+
+theorem T_pow_mem_Gamma (N : ℕ) : ModularGroup.T ^ N ∈ CongruenceSubgroup.Gamma N := by
+  rw [CongruenceSubgroup.Gamma_mem, ← zpow_natCast, ModularGroup.coe_T_zpow]
+  simp
+
+theorem one_ne_zero_zmod {N : ℕ} (hN : 2 ≤ N) : (1 : ZMod N) ≠ 0 := by
+  have : Fact (1 < N) := ⟨hN⟩
+  exact one_ne_zero
+
+theorem S_sq : (ModularGroup.S : SL(2, ℤ)) ^ 2 = -1 := by
+  ext i j
+  fin_cases i <;> fin_cases j <;>
+    simp [pow_two, ModularGroup.coe_S, Matrix.mul_apply, Fin.sum_univ_two]
+
+theorem dvd_of_S_pow_mem {N : ℕ} (hN : 2 ≤ N) {n : ℕ} (h : ModularGroup.S ^ n ∈ Gpm N) : 2 ∣ n := by
+  by_contra hodd
+  rw [Nat.two_dvd_ne_zero, ← Nat.odd_iff] at hodd
+  obtain ⟨k, rfl⟩ := hodd
+  have hpow : (ModularGroup.S : SL(2, ℤ)) ^ (2 * k + 1) = (-1) ^ k * ModularGroup.S := by
+    rw [pow_succ, pow_mul, S_sq]
+  rw [hpow] at h
+  have h10 := entry_10_eq_zero_of_mem_Gpm N h
+  rcases neg_one_pow_eq_or SL(2, ℤ) k with hk | hk
+  · rw [hk, one_mul, ModularGroup.coe_S] at h10
+    simp only [Matrix.of_apply, Matrix.cons_val', Matrix.cons_val_zero, Matrix.cons_val_one,
+      Matrix.cons_val_fin_one, Int.cast_one] at h10
+    exact one_ne_zero_zmod hN h10
+  · rw [hk, neg_one_mul, Matrix.SpecialLinearGroup.coe_neg, ModularGroup.coe_S] at h10
+    simp only [Matrix.neg_apply, Matrix.of_apply, Matrix.cons_val', Matrix.cons_val_zero,
+      Matrix.cons_val_one, Matrix.cons_val_fin_one, Int.cast_neg, Int.cast_one, neg_eq_zero] at h10
+    exact one_ne_zero_zmod hN h10
+
+theorem coe_ST : ((ModularGroup.S * ModularGroup.T : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) =
+    !![0, -1; 1, 1] := by
+  rw [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_S, ModularGroup.coe_T]
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp [Matrix.mul_apply, Fin.sum_univ_two]
+
+theorem ST_cube : (ModularGroup.S * ModularGroup.T : SL(2, ℤ)) ^ 3 = -1 := by
+  ext i j
+  rw [Matrix.SpecialLinearGroup.coe_pow, coe_ST]
+  fin_cases i <;> fin_cases j <;>
+    simp [pow_succ, Matrix.mul_apply, Fin.sum_univ_two]
+
+theorem dvd_of_ST_pow_mem {N : ℕ} (hN : 2 ≤ N) {n : ℕ}
+    (h : (ModularGroup.S * ModularGroup.T) ^ n ∈ Gpm N) : 3 ∣ n := by
+  have hST2 : (((ModularGroup.S * ModularGroup.T) ^ 2 : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) =
+      !![-1, -1; 1, 0] := by
+    rw [Matrix.SpecialLinearGroup.coe_pow, coe_ST]
+    ext i j
+    fin_cases i <;> fin_cases j <;> simp [pow_two, Matrix.mul_apply, Fin.sum_univ_two]
+  obtain ⟨q, r, hr, rfl⟩ : ∃ q r : ℕ, r < 3 ∧ n = 3 * q + r :=
+    ⟨n / 3, n % 3, Nat.mod_lt _ (by norm_num), (Nat.div_add_mod n 3).symm⟩
+  have hpow : (ModularGroup.S * ModularGroup.T : SL(2, ℤ)) ^ (3 * q + r) =
+      (-1) ^ q * (ModularGroup.S * ModularGroup.T) ^ r := by
+    rw [pow_add, pow_mul, ST_cube]
+  rw [hpow] at h
+  have h10 := entry_10_eq_zero_of_mem_Gpm N h
+  interval_cases r
+  · exact ⟨q, by ring⟩
+  · exfalso
+    rcases neg_one_pow_eq_or SL(2, ℤ) q with hk | hk
+    · rw [hk, one_mul, pow_one, coe_ST] at h10
+      simp only [Matrix.of_apply, Matrix.cons_val', Matrix.cons_val_zero, Matrix.cons_val_one,
+        Matrix.cons_val_fin_one, Int.cast_one] at h10
+      exact one_ne_zero_zmod hN h10
+    · rw [hk, neg_one_mul, Matrix.SpecialLinearGroup.coe_neg, pow_one, coe_ST] at h10
+      simp only [Matrix.neg_apply, Matrix.of_apply, Matrix.cons_val', Matrix.cons_val_zero,
+        Matrix.cons_val_one, Matrix.cons_val_fin_one, Int.cast_neg, Int.cast_one,
+        neg_eq_zero] at h10
+      exact one_ne_zero_zmod hN h10
+  · exfalso
+    rcases neg_one_pow_eq_or SL(2, ℤ) q with hk | hk
+    · rw [hk, one_mul, hST2] at h10
+      simp only [Matrix.of_apply, Matrix.cons_val', Matrix.cons_val_zero, Matrix.cons_val_one,
+        Matrix.cons_val_fin_one, Int.cast_one] at h10
+      exact one_ne_zero_zmod hN h10
+    · rw [hk, neg_one_mul, Matrix.SpecialLinearGroup.coe_neg, hST2] at h10
+      simp only [Matrix.neg_apply, Matrix.of_apply, Matrix.cons_val', Matrix.cons_val_zero,
+        Matrix.cons_val_one, Matrix.cons_val_fin_one, Int.cast_neg, Int.cast_one,
+        neg_eq_zero] at h10
+      exact one_ne_zero_zmod hN h10
+
+theorem Gamma_le_Gamma1 (M : ℕ) : CongruenceSubgroup.Gamma M ≤ CongruenceSubgroup.Gamma1 M := by
+  intro g hg
+  rw [CongruenceSubgroup.Gamma_mem] at hg
+  rw [CongruenceSubgroup.Gamma1_mem]
+  exact ⟨hg.1, hg.2.2.2, hg.2.2.1⟩
+
+theorem neg_one_mem_zpowers_ST :
+    (-1 : SL(2, ℤ)) ∈ Subgroup.zpowers (ModularGroup.S * ModularGroup.T) := by
+  rw [← ST_cube]; exact Subgroup.pow_mem _ (Subgroup.mem_zpowers _) _
+
+theorem neg_one_mem_zpowers_S : (-1 : SL(2, ℤ)) ∈ Subgroup.zpowers ModularGroup.S := by
+  rw [← S_sq]; exact Subgroup.pow_mem _ (Subgroup.mem_zpowers _) _
+
+theorem neg_one_mem_zpowers_T_sup :
+    (-1 : SL(2, ℤ)) ∈ Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) :=
+  Subgroup.mem_sup_right (Subgroup.mem_zpowers _)
+
+section Galois
+
+variable {L : Type*} [Field L] [Algebra ℂ L]
+
+theorem apply_eq_self_of_mem_adjoin (ψ : L →ₐ[ℂ] L) (t : L) (hψ : ψ t = t) {x : L}
+    (hx : x ∈ ℂ⟮t⟯) : ψ x = x := by
+  let S : IntermediateField ℂ L := (AlgHom.equalizer ψ (AlgHom.id ℂ L)).toIntermediateField
+    (fun y hy => by
+      rw [AlgHom.mem_equalizer] at hy ⊢
+      simp only [AlgHom.coe_id, id_eq] at hy ⊢
+      rw [map_inv₀, hy])
+  have hle : ℂ⟮t⟯ ≤ S := by
+    rw [IntermediateField.adjoin_le_iff, Set.singleton_subset_iff]
+    change t ∈ AlgHom.equalizer ψ (AlgHom.id ℂ L)
+    rw [AlgHom.mem_equalizer]
+    simpa using hψ
+  have := hle hx
+  change x ∈ AlgHom.equalizer ψ (AlgHom.id ℂ L) at this
+  rw [AlgHom.mem_equalizer] at this
+  simpa using this
+
+theorem isIntegral_of_apply_eq (t : L) [FiniteDimensional ℂ⟮t⟯ L] (ψ : L →ₐ[ℂ] L)
+    (hψ : ψ t = t) : ψ.toRingHom.IsIntegral := by
+  intro y
+  have hy : IsIntegral ℂ⟮t⟯ y := IsIntegral.of_finite ℂ⟮t⟯ y
+  refine ⟨(minpoly ℂ⟮t⟯ y).map (algebraMap ℂ⟮t⟯ L), (minpoly.monic hy).map _, ?_⟩
+  rw [Polynomial.eval₂_map]
+  have hcomp : ψ.toRingHom.comp (algebraMap ℂ⟮t⟯ L) = algebraMap ℂ⟮t⟯ L := by
+    ext e
+    exact apply_eq_self_of_mem_adjoin ψ t hψ e.2
+  rw [hcomp]
+  exact minpoly.aeval ℂ⟮t⟯ y
+
+theorem algHom_apply_algebraMap (t : L) (E : IntermediateField ℂ⟮t⟯ L) (x : E) (hx : (x : L) = t)
+    (ψ : E →ₐ[ℂ] L) (hψ : ψ x = t) (l : ℂ⟮t⟯) : ψ (algebraMap ℂ⟮t⟯ E l) = l := by
+  let θ : ℂ⟮t⟯ →ₐ[ℂ] L := ψ.comp (IsScalarTower.toAlgHom ℂ ℂ⟮t⟯ E)
+  have hgen : ∀ (z : L) (hz : z ∈ ({t} : Set L)),
+      θ ⟨z, IntermediateField.subset_adjoin _ _ hz⟩ =
+        (IntermediateField.val ℂ⟮t⟯) ⟨z, IntermediateField.subset_adjoin _ _ hz⟩ := by
+    intro z hz
+    rw [Set.mem_singleton_iff] at hz
+    have hz' : (⟨z, IntermediateField.subset_adjoin _ _ (by rw [hz]; rfl)⟩ : ℂ⟮t⟯) =
+        ⟨t, IntermediateField.mem_adjoin_simple_self ℂ t⟩ := Subtype.ext hz
+    rw [hz']
+    change ψ (algebraMap ℂ⟮t⟯ E ⟨t, _⟩) = t
+    have : algebraMap ℂ⟮t⟯ E ⟨t, IntermediateField.mem_adjoin_simple_self ℂ t⟩ = x := by
+      apply Subtype.ext
+      rw [hx]
+      rfl
+    rw [this, hψ]
+  have hθ : θ = IntermediateField.val ℂ⟮t⟯ := IntermediateField.adjoin_algHom_ext ℂ hgen
+  exact congrArg (fun φ : ℂ⟮t⟯ →ₐ[ℂ] L => φ l) hθ
+
+theorem isIntegral_of_apply_eq_sub (t : L) [FiniteDimensional ℂ⟮t⟯ L]
+    (E : IntermediateField ℂ⟮t⟯ L) (x : E) (hx : (x : L) = t)
+    (ψ : E →ₐ[ℂ] L) (hψ : ψ x = t) : ψ.toRingHom.IsIntegral := by
+  intro y
+  have hy : IsIntegral ℂ⟮t⟯ y := IsIntegral.of_finite ℂ⟮t⟯ y
+  refine ⟨(minpoly ℂ⟮t⟯ y).map (algebraMap ℂ⟮t⟯ E), (minpoly.monic hy).map _, ?_⟩
+  rw [Polynomial.eval₂_map]
+  have hcomp : ψ.toRingHom.comp (algebraMap ℂ⟮t⟯ E) = algebraMap ℂ⟮t⟯ L := by
+    ext e
+    exact algHom_apply_algebraMap t E x hx ψ hψ e
+  rw [hcomp]
+  exact minpoly.aeval ℂ⟮t⟯ y
+
+theorem adjoin_inv_eq (t : L) : ℂ⟮t⁻¹⟯ = ℂ⟮t⟯ := by
+  apply le_antisymm
+  · rw [IntermediateField.adjoin_le_iff, Set.singleton_subset_iff]
+    exact IntermediateField.inv_mem _ (IntermediateField.mem_adjoin_simple_self ℂ t)
+  · rw [IntermediateField.adjoin_le_iff, Set.singleton_subset_iff]
+    have := IntermediateField.inv_mem _ (IntermediateField.mem_adjoin_simple_self ℂ t⁻¹)
+    rwa [inv_inv] at this
+
+theorem ord_sub_eq_ord_sub (t : L) (L₀ : IntermediateField ℂ L) (hL₀ : L₀ = ℂ⟮t⟯)
+    [FiniteDimensional L₀ L] [IsGalois L₀ L]
+    (W w : AlgebraicCurve.Place ℂ L) (c : ℂ)
+    (hW : 0 < W.ord (t - algebraMap ℂ L c)) (hw : 0 < w.ord (t - algebraMap ℂ L c)) :
+    w.ord (t - algebraMap ℂ L c) = W.ord (t - algebraMap ℂ L c) := by
+  subst hL₀
+  have hint : ∀ ψ : L →ₐ[ℂ] L, ψ t = t → ψ.toRingHom.IsIntegral :=
+    fun ψ hψ => isIntegral_of_apply_eq t ψ hψ
+  have key : ∀ (W₁ W₂ : AlgebraicCurve.Place ℂ L), 0 < W₁.ord (t - algebraMap ℂ L c) →
+      0 < W₂.ord (t - algebraMap ℂ L c) →
+      W₂.ord (t - algebraMap ℂ L c) ≤ W₁.ord (t - algebraMap ℂ L c) := by
+    intro W₁ W₂ h₁ h₂
+    obtain ⟨ψ, hψ, hres⟩ :=
+      (AlgebraicCurve.Place.ord_restrictAlong_eq_natCard_algHom_of_isGalois ℂ t t c
+        (AlgHom.id ℂ L) rfl inferInstance inferInstance hint W₁ h₁).2.2.1 W₂ h₂
+    have hord := AlgebraicCurve.Place.ord_restrictAlong ψ (hint ψ hψ) W₁ (t - algebraMap ℂ L c)
+    rw [hres, map_sub, hψ, AlgHom.commutes] at hord
+    set e := (AlgebraicCurve.Place.ramificationIndexAlong ψ W₁ : ℤ) with he
+    have he0 : (0 : ℤ) ≤ e := by rw [he]; exact_mod_cast Nat.zero_le _
+    have he1 : 1 ≤ e := by
+      by_contra hlt
+      have : e = 0 := by omega
+      rw [this, zero_mul] at hord
+      omega
+    nlinarith
+  exact le_antisymm (key W w hW hw) (key w W hw hW)
+
+def stab (L₀ : IntermediateField ℂ L) (W : AlgebraicCurve.Place ℂ L) : Subgroup (L ≃ₐ[L₀] L) where
+  carrier := {g | AlgebraicCurve.SemilinearAut.ofAlgAut (g.restrictScalars ℂ) • W = W}
+  one_mem' := by
+    change AlgebraicCurve.SemilinearAut.ofAlgAut _ • W = W
+    have : ((1 : L ≃ₐ[L₀] L).restrictScalars ℂ) = 1 := AlgEquiv.ext fun _ => rfl
+    rw [this, map_one, one_smul]
+  mul_mem' {a b} ha hb := by
+    change AlgebraicCurve.SemilinearAut.ofAlgAut _ • W = W at ha hb ⊢
+    have : ((a * b).restrictScalars ℂ) = a.restrictScalars ℂ * b.restrictScalars ℂ :=
+      AlgEquiv.ext fun _ => rfl
+    rw [this, map_mul, mul_smul, hb, ha]
+  inv_mem' {a} ha := by
+    change AlgebraicCurve.SemilinearAut.ofAlgAut _ • W = W at ha ⊢
+    have : (a⁻¹.restrictScalars ℂ) = (a.restrictScalars ℂ)⁻¹ := AlgEquiv.ext fun _ => rfl
+    rw [this, map_inv, inv_smul_eq_iff, ha]
+
+theorem mem_stab_iff (L₀ : IntermediateField ℂ L) (W : AlgebraicCurve.Place ℂ L) (g : L ≃ₐ[L₀] L) :
+    g ∈ stab L₀ W ↔ AlgebraicCurve.SemilinearAut.ofAlgAut (g.restrictScalars ℂ) • W = W := Iff.rfl
+
+theorem natCard_stab_eq_ord (t : L) (L₀ : IntermediateField ℂ L) (hL₀ : L₀ = ℂ⟮t⟯)
+    [FiniteDimensional L₀ L] [IsGalois L₀ L]
+    (W : AlgebraicCurve.Place ℂ L) (c : ℂ) (hW : 0 < W.ord (t - algebraMap ℂ L c)) :
+    (Nat.card (stab L₀ W) : ℤ) = W.ord (t - algebraMap ℂ L c) := by
+  subst hL₀
+  rw [(AlgebraicCurve.Place.ord_restrictAlong_eq_natCard_algHom_of_isGalois ℂ t t c
+    (AlgHom.id ℂ L) rfl inferInstance inferInstance
+    (fun ψ hψ => isIntegral_of_apply_eq t ψ hψ) W hW).1]
+  rfl
+
+theorem stab_eq_zpowers (t : L) (L₀ : IntermediateField ℂ L) (hL₀ : L₀ = ℂ⟮t⟯)
+    [FiniteDimensional L₀ L] [IsGalois L₀ L]
+    (W : AlgebraicCurve.Place ℂ L) (c : ℂ) (hW : 0 < W.ord (t - algebraMap ℂ L c))
+    (g : L ≃ₐ[L₀] L) (hg : g ∈ stab L₀ W) (hle : W.ord (t - algebraMap ℂ L c) ≤ orderOf g) :
+    stab L₀ W = Subgroup.zpowers g := by
+  symm
+  apply Subgroup.eq_of_le_of_card_ge
+  · rw [Subgroup.zpowers_le]; exact hg
+  · rw [Nat.card_zpowers]
+    have := natCard_stab_eq_ord t L₀ hL₀ W c hW
+    omega
+
+theorem natCard_doubleCoset_le (t : L) (L₀ : IntermediateField ℂ L) (hL₀ : L₀ = ℂ⟮t⟯)
+    [FiniteDimensional L₀ L] [IsGalois L₀ L]
+    {Γ₀ : Type*} [Group Γ₀] (σ : Γ₀ →* (L ≃ₐ[L₀] L)) (Γ Kst : Subgroup Γ₀)
+    (E : IntermediateField L₀ L)
+    (hE : ∀ g₀ : Γ₀, (∀ e : E, σ g₀ e = e) →
+      ∃ a ∈ Γ, ∃ z ∈ Kst, z ∈ Subgroup.center Γ₀ ∧ g₀ = a * z)
+    (W : AlgebraicCurve.Place ℂ L) (c : ℂ) (hW : 0 < W.ord (t - algebraMap ℂ L c))
+    (hD : ∀ g : L ≃ₐ[L₀] L, g ∈ stab L₀ W → ∃ k ∈ Kst, σ k = g)
+    (x : E) (hx : (x : L) = t)
+    [Finite {P : AlgebraicCurve.Place ℂ E // 0 < P.ord (x - algebraMap ℂ E c)}] :
+    Nat.card (DoubleCoset.Quotient (Γ : Set Γ₀) (Kst : Set Γ₀)) ≤
+      Nat.card {P : AlgebraicCurve.Place ℂ E // 0 < P.ord (x - algebraMap ℂ E c)} := by
+  subst hL₀
+  classical
+  have hint : ∀ ψ : E →ₐ[ℂ] L, ψ x = t → ψ.toRingHom.IsIntegral :=
+    fun ψ hψ => isIntegral_of_apply_eq_sub t E x hx ψ hψ
+  have hDH := AlgebraicCurve.Place.ord_restrictAlong_eq_natCard_algHom_of_isGalois ℂ x t c
+    (E.val.restrictScalars ℂ) hx inferInstance inferInstance hint W hW
+  let ψ : Γ₀ → (E →ₐ[ℂ] L) := fun γ =>
+    ((σ γ⁻¹).restrictScalars ℂ : L →ₐ[ℂ] L).comp (E.val.restrictScalars ℂ)
+  have hψapply : ∀ (γ : Γ₀) (e : E), ψ γ e = σ γ⁻¹ e := fun _ _ => rfl
+  have hψ : ∀ γ, ψ γ x = t := by
+    intro γ
+    rw [hψapply]
+    have : (x : L) = ((⟨t, IntermediateField.mem_adjoin_simple_self ℂ t⟩ : ℂ⟮t⟯) : L) := hx
+    rw [this]
+    exact (σ γ⁻¹).commutes (⟨t, IntermediateField.mem_adjoin_simple_self ℂ t⟩ : ℂ⟮t⟯)
+  let T := {P : AlgebraicCurve.Place ℂ E // 0 < P.ord (x - algebraMap ℂ E c)}
+  let f : Γ₀ → T := fun γ => ⟨W.restrictAlong (ψ γ) (hint _ (hψ γ)), hDH.2.1 (ψ γ) (hψ γ)⟩
+  have key : ∀ γ γ' : Γ₀, f γ = f γ' → ∃ a ∈ Γ, ∃ b ∈ Kst, γ' = a * γ * b := by
+    intro γ γ' hff
+    have hres : W.restrictAlong (ψ γ) (hint _ (hψ γ)) = W.restrictAlong (ψ γ') (hint _ (hψ γ')) :=
+      congrArg Subtype.val hff
+    obtain ⟨d, hdW, hd⟩ := (hDH.2.2.2.1 (ψ γ) (ψ γ') (hψ γ) (hψ γ')).mp hres
+    obtain ⟨k, hk, hkd⟩ := hD d hdW
+    have hfixE : ∀ e : E, σ (γ * k⁻¹ * γ'⁻¹) e = e := by
+      intro e
+      have h1 : ψ γ' e = d (ψ γ e) := by rw [hd]; rfl
+      rw [hψapply, hψapply, ← hkd] at h1
+      rw [map_mul, map_mul, AlgEquiv.mul_apply, AlgEquiv.mul_apply, h1, map_inv, AlgEquiv.aut_inv,
+        AlgEquiv.symm_apply_apply, map_inv, AlgEquiv.aut_inv, AlgEquiv.apply_symm_apply]
+    obtain ⟨a, ha, z, hz, hzc, heq⟩ := hE _ hfixE
+    refine ⟨a⁻¹, Γ.inv_mem ha, k⁻¹ * z⁻¹, Kst.mul_mem (Kst.inv_mem hk) (Kst.inv_mem hz), ?_⟩
+    have hzc' : ∀ g : Γ₀, g * z = z * g := fun g => (Subgroup.mem_center_iff.mp hzc g)
+    have h2 : γ' = z⁻¹ * a⁻¹ * γ * k⁻¹ := by
+      have h3 : γ'⁻¹ = k * γ⁻¹ * (a * z) := by
+        rw [← heq]; group
+      have h4 : γ' = (k * γ⁻¹ * (a * z))⁻¹ := by rw [← h3, inv_inv]
+      rw [h4]; group
+    rw [h2]
+    have h5 : z⁻¹ * a⁻¹ * γ * k⁻¹ = a⁻¹ * γ * k⁻¹ * z⁻¹ := by
+      have := hzc' (a⁻¹ * γ * k⁻¹)
+      calc z⁻¹ * a⁻¹ * γ * k⁻¹ = z⁻¹ * ((a⁻¹ * γ * k⁻¹) * z) * z⁻¹ := by group
+        _ = z⁻¹ * (z * (a⁻¹ * γ * k⁻¹)) * z⁻¹ := by rw [this]
+        _ = a⁻¹ * γ * k⁻¹ * z⁻¹ := by group
+    rw [h5]; group
+  have : Finite (Set.range f) := inferInstance
+  let π : Set.range f → DoubleCoset.Quotient (Γ : Set Γ₀) (Kst : Set Γ₀) :=
+    fun p => DoubleCoset.mk Γ Kst p.2.choose
+  have hπ : Function.Surjective π := by
+    intro r
+    obtain ⟨γ, rfl⟩ : ∃ γ, DoubleCoset.mk Γ Kst γ = r := ⟨r.out, DoubleCoset.out_eq' r⟩
+    refine ⟨⟨f γ, γ, rfl⟩, ?_⟩
+    change DoubleCoset.mk _ _ _ = _
+    have hch : f (Exists.choose (⟨γ, rfl⟩ : ∃ y, f y = f γ)) = f γ :=
+      Exists.choose_spec (⟨γ, rfl⟩ : ∃ y, f y = f γ)
+    obtain ⟨a, ha, b, hb, hab⟩ := key _ _ hch
+    rw [DoubleCoset.eq]
+    exact ⟨a, ha, b, hb, hab⟩
+  calc Nat.card (DoubleCoset.Quotient (Γ : Set Γ₀) (Kst : Set Γ₀))
+        ≤ Nat.card (Set.range f) := Nat.card_le_card_of_surjective π hπ
+    _ ≤ Nat.card T := Nat.card_le_card_of_injective (fun p : Set.range f => (p : T))
+        Subtype.val_injective
+
+end Galois
+
+section Lift
+
+variable {L : Type*} [Field L] [Algebra ℂ L]
+
+def liftE (E' : IntermediateField ℂ L) (φ : L ≃ₐ[ℂ] L) (hφ : ∀ x ∈ E', φ x = x) : L ≃ₐ[E'] L :=
+  { φ.toRingEquiv with commutes' := fun e => hφ e e.2 }
+
+@[scoped simp]
+theorem liftE_apply (E' : IntermediateField ℂ L) (φ : L ≃ₐ[ℂ] L) (hφ : ∀ x ∈ E', φ x = x) (x : L) :
+    liftE E' φ hφ x = φ x := rfl
+
+theorem restrictScalars_liftE (E' : IntermediateField ℂ L) (φ : L ≃ₐ[ℂ] L) (hφ : ∀ x ∈ E', φ x = x)
+    :
+    (liftE E' φ hφ).restrictScalars ℂ = φ :=
+  AlgEquiv.ext fun _ => rfl
+
+def liftHom {Γ : Type*} [Group Γ] (E' : IntermediateField ℂ L) (σ : Γ →* (L ≃ₐ[ℂ] L))
+    (hσ : ∀ (γ : Γ), ∀ x ∈ E', σ γ x = x) : Γ →* (L ≃ₐ[E'] L) where
+  toFun γ := liftE E' (σ γ) (hσ γ)
+  map_one' := by ext x; simp
+  map_mul' γ δ := by ext x; simp
+
+@[scoped simp]
+theorem liftHom_apply {Γ : Type*} [Group Γ] (E' : IntermediateField ℂ L)
+    (σ : Γ →* (L ≃ₐ[ℂ] L)) (hσ : ∀ (γ : Γ), ∀ x ∈ E', σ γ x = x) (γ : Γ) (x : L) :
+    liftHom E' σ hσ γ x = σ γ x := rfl
+
+theorem restrictScalars_liftHom {Γ : Type*} [Group Γ] (E' : IntermediateField ℂ L)
+    (σ : Γ →* (L ≃ₐ[ℂ] L)) (hσ : ∀ (γ : Γ), ∀ x ∈ E', σ γ x = x) (γ : Γ) :
+    (liftHom E' σ hσ γ).restrictScalars ℂ = σ γ :=
+  restrictScalars_liftE E' (σ γ) (hσ γ)
+
+theorem liftHom_eq_one_iff {Γ : Type*} [Group Γ] (E' : IntermediateField ℂ L)
+    (σ : Γ →* (L ≃ₐ[ℂ] L)) (hσ : ∀ (γ : Γ), ∀ x ∈ E', σ γ x = x) (γ : Γ) :
+    liftHom E' σ hσ γ = 1 ↔ γ ∈ σ.ker := by
+  rw [MonoidHom.mem_ker]
+  constructor
+  · intro h
+    have := congrArg (AlgEquiv.restrictScalars ℂ) h
+    rw [restrictScalars_liftHom] at this
+    rw [this]
+    ext x
+    rfl
+  · intro h
+    ext x
+    change σ γ x = x
+    rw [h]
+    rfl
+
+theorem liftHom_ker {Γ : Type*} [Group Γ] (E' : IntermediateField ℂ L)
+    (σ : Γ →* (L ≃ₐ[ℂ] L)) (hσ : ∀ (γ : Γ), ∀ x ∈ E', σ γ x = x) :
+    (liftHom E' σ hσ).ker = σ.ker := by
+  ext γ
+  rw [MonoidHom.mem_ker, liftHom_eq_one_iff]
+
+end Lift
+
+section LevelN
+
+variable (M : ℕ) [NeZero M]
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (LevelN.ring M) K]
+  [IsScalarTower ℂ (LevelN.ring M) K] [IsFractionRing (LevelN.ring M) K]
+
+theorem galoisPackage :
+    ∃ (hst : ∀ γ : SL(2, ℤ), ∀ F ∈ ModularCurve.LevelN.ring M,
+        (fun τ : UpperHalfPlane => F (γ • τ)) ∈ ModularCurve.LevelN.ring M)
+      (σ : SL(2, ℤ) →* (K ≃ₐ[ℂ] K)),
+      (∀ (γ : SL(2, ℤ)) (F : UpperHalfPlane → ℂ) (hF : F ∈ ModularCurve.LevelN.ring M),
+          σ γ (algebraMap (ModularCurve.LevelN.ring M) K ⟨F, hF⟩) =
+            algebraMap (ModularCurve.LevelN.ring M) K
+              ⟨fun τ : UpperHalfPlane => F (γ⁻¹ • τ), hst γ⁻¹ F hF⟩) ∧
+      σ.ker = CongruenceSubgroup.Gamma M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) ∧
+      IntermediateField.fixedField σ.range =
+        IntermediateField.adjoin ℂ
+          ({algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)} : Set K) ∧
+      Transcendental ℂ (algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)) ∧
+      FiniteDimensional
+          (IntermediateField.adjoin ℂ
+            ({algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)} : Set K)) K ∧
+      Module.finrank
+          (IntermediateField.adjoin ℂ
+            ({algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)} : Set K)) K =
+        (CongruenceSubgroup.Gamma M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index ∧
+      IsGalois
+          (IntermediateField.adjoin ℂ
+            ({algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)} : Set K)) K :=
+  ModularCurve.LevelN.exists_monoidHom_algEquiv_fixedField_eq_adjoin M K
+
+include K in
+theorem comp_smul_mem (γ : SL(2, ℤ)) (F : ℍ → ℂ) (hF : F ∈ LevelN.ring M) :
+    (fun τ : ℍ => F (γ • τ)) ∈ LevelN.ring M :=
+  (galoisPackage M K).choose γ F hF
+
+def σK : SL(2, ℤ) →* (K ≃ₐ[ℂ] K) := (galoisPackage M K).choose_spec.choose
+
+abbrev jK : K := algebraMap (LevelN.ring M) K (LevelN.jGen M)
+
+theorem σK_algebraMap (γ : SL(2, ℤ)) (F : ℍ → ℂ) (hF : F ∈ LevelN.ring M) :
+    σK M K γ (algebraMap (LevelN.ring M) K ⟨F, hF⟩) =
+      algebraMap (LevelN.ring M) K ⟨fun τ : ℍ => F (γ⁻¹ • τ), comp_smul_mem M K γ⁻¹ F hF⟩ :=
+  (galoisPackage M K).choose_spec.choose_spec.1 γ F hF
+
+theorem σK_ker : (σK M K).ker = Gpm M := (galoisPackage M K).choose_spec.choose_spec.2.1
+
+theorem fixedField_σK : IntermediateField.fixedField (σK M K).range = ℂ⟮jK M K⟯ :=
+  (galoisPackage M K).choose_spec.choose_spec.2.2.1
+
+theorem transcendental_jK : Transcendental ℂ (jK M K) :=
+  (galoisPackage M K).choose_spec.choose_spec.2.2.2.1
+
+theorem finiteDimensional_jK : FiniteDimensional ℂ⟮jK M K⟯ K :=
+  (galoisPackage M K).choose_spec.choose_spec.2.2.2.2.1
+
+theorem finrank_jK : Module.finrank ℂ⟮jK M K⟯ K = (Gpm M).index :=
+  (galoisPackage M K).choose_spec.choose_spec.2.2.2.2.2.1
+
+theorem isGalois_jK : IsGalois ℂ⟮jK M K⟯ K :=
+  (galoisPackage M K).choose_spec.choose_spec.2.2.2.2.2.2
+
+theorem σK_fix (γ : SL(2, ℤ)) : ∀ x ∈ ℂ⟮jK M K⟯, σK M K γ x = x := fun x hx => by
+  rw [← fixedField_σK] at hx
+  exact (IntermediateField.mem_fixedField_iff (σK M K).range x).mp hx (σK M K γ) ⟨γ, rfl⟩
+
+def σ' : SL(2, ℤ) →* (K ≃ₐ[ℂ⟮jK M K⟯] K) := liftHom ℂ⟮jK M K⟯ (σK M K) (σK_fix M K)
+
+theorem restrictScalars_σ' (γ : SL(2, ℤ)) : (σ' M K γ).restrictScalars ℂ = σK M K γ :=
+  restrictScalars_liftHom _ _ _ γ
+
+@[scoped simp]
+theorem σ'_apply (γ : SL(2, ℤ)) (x : K) : σ' M K γ x = σK M K γ x := rfl
+
+theorem σ'_ker : (σ' M K).ker = Gpm M := by
+  rw [σ', liftHom_ker, σK_ker]
+
+theorem σ'_eq_one_iff (γ : SL(2, ℤ)) : σ' M K γ = 1 ↔ γ ∈ Gpm M := by
+  rw [← MonoidHom.mem_ker, σ'_ker]
+
+theorem σ'_pow_eq_one_iff (γ : SL(2, ℤ)) (n : ℕ) : σ' M K γ ^ n = 1 ↔ γ ^ n ∈ Gpm M := by
+  rw [← map_pow, σ'_eq_one_iff]
+
+theorem mem_stab_σ'_iff (W : AlgebraicCurve.Place ℂ K) (γ : SL(2, ℤ)) :
+    σ' M K γ ∈ stab ℂ⟮jK M K⟯ W ↔ AlgebraicCurve.SemilinearAut.ofAlgAut (σK M K γ) • W = W := by
+  rw [mem_stab_iff, restrictScalars_σ']
+
+theorem σ'_surjective : Function.Surjective (σ' M K) := by
+  have := finiteDimensional_jK M K
+  have := isGalois_jK M K
+  rw [← MonoidHom.range_eq_top]
+  apply Subgroup.eq_top_of_card_eq
+  rw [← Subgroup.index_ker, σ'_ker, ← finrank_jK M K, IsGalois.card_aut_eq_finrank]
+
+end LevelN
+
+section Stabilisers
+
+variable (M : ℕ) [NeZero M]
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (LevelN.ring M) K]
+  [IsScalarTower ℂ (LevelN.ring M) K] [IsFractionRing (LevelN.ring M) K]
+
+theorem orderOf_σ'_S (hM : 2 ≤ M) : orderOf (σ' M K ModularGroup.S) = 2 := by
+  have : Fact (Nat.Prime 2) := ⟨Nat.prime_two⟩
+  apply orderOf_eq_prime
+  · rw [σ'_pow_eq_one_iff, S_sq]
+    exact mem_Gpm_of M (Or.inr (by rw [neg_neg]; exact one_mem _))
+  · rw [ne_eq, σ'_eq_one_iff]
+    intro h
+    have := dvd_of_S_pow_mem hM (n := 1) (by rwa [pow_one])
+    omega
+
+theorem orderOf_σ'_ST (hM : 2 ≤ M) : orderOf (σ' M K (ModularGroup.S * ModularGroup.T)) = 3 := by
+  have : Fact (Nat.Prime 3) := ⟨Nat.prime_three⟩
+  apply orderOf_eq_prime
+  · rw [σ'_pow_eq_one_iff, ST_cube]
+    exact mem_Gpm_of M (Or.inr (by rw [neg_neg]; exact one_mem _))
+  · rw [ne_eq, σ'_eq_one_iff]
+    intro h
+    have := dvd_of_ST_pow_mem hM (n := 1) (by rwa [pow_one])
+    omega
+
+theorem orderOf_σ'_T : orderOf (σ' M K ModularGroup.T) = M := by
+  apply Nat.dvd_antisymm
+  · apply orderOf_dvd_of_pow_eq_one
+    rw [σ'_pow_eq_one_iff]
+    exact Subgroup.mem_sup_left (T_pow_mem_Gamma M)
+  · have h := pow_orderOf_eq_one (σ' M K ModularGroup.T)
+    rw [σ'_pow_eq_one_iff] at h
+    exact dvd_of_T_pow_mem M h
+
+theorem subsingleton_gal_of_lt_two (hM : M < 2) : Subsingleton (K ≃ₐ[ℂ⟮jK M K⟯] K) := by
+  have := finiteDimensional_jK M K
+  have := isGalois_jK M K
+  have hM1 : M = 1 := by have := NeZero.ne M; omega
+  have hcard : Nat.card (K ≃ₐ[ℂ⟮jK M K⟯] K) = 1 := by
+    rw [IsGalois.card_aut_eq_finrank, finrank_jK]
+    subst hM1
+    have : Gpm 1 = ⊤ := by
+      rw [Gpm, CongruenceSubgroup.Gamma_one_top, top_sup_eq]
+    rw [this, Subgroup.index_top]
+  exact (Nat.card_eq_one_iff_unique.mp hcard).1
+
+theorem exists_place_1728 :
+    ∃ W : AlgebraicCurve.Place ℂ K, 0 < W.ord (jK M K - algebraMap ℂ K 1728) ∧
+      ∀ g ∈ stab ℂ⟮jK M K⟯ W, ∃ k ∈ Subgroup.zpowers (ModularGroup.S : SL(2, ℤ)), σ' M K k = g := by
+  have := finiteDimensional_jK M K
+  have := isGalois_jK M K
+  obtain ⟨W, hW, hWfix⟩ :=
+    ModularCurve.LevelN.exists_place_ord_sub_pos_forall_smul_eq M K UpperHalfPlane.I
+  rw [jAnalytic_I] at hW
+  refine ⟨W, hW, ?_⟩
+  have hS : σ' M K ModularGroup.S ∈ stab ℂ⟮jK M K⟯ W := by
+    rw [mem_stab_σ'_iff]
+    exact hWfix ModularGroup.S S_smul_I (comp_smul_mem M K _) (σK M K _) (σK_algebraMap M K _)
+  rcases Nat.lt_or_ge M 2 with hM | hM
+  · intro g hg
+    have := subsingleton_gal_of_lt_two M K hM
+    exact ⟨1, one_mem _, Subsingleton.elim _ _⟩
+  · obtain ⟨⟨W', hW'pos, hW'le⟩, -, -⟩ :=
+      ModularCurve.LevelN.exists_place_ord_jGen_le_two_three_level M K
+    rw [← map_ofNat (algebraMap ℂ K) 1728] at hW'pos hW'le
+    have hle : W.ord (jK M K - algebraMap ℂ K 1728) ≤ 2 := by
+      rw [← ord_sub_eq_ord_sub (jK M K) ℂ⟮jK M K⟯ rfl W W' 1728 hW hW'pos]
+      exact hW'le
+    have hstab := stab_eq_zpowers (jK M K) ℂ⟮jK M K⟯ rfl W 1728 hW (σ' M K ModularGroup.S) hS
+      (by rw [orderOf_σ'_S M K hM]; exact hle)
+    intro g hg
+    rw [hstab, Subgroup.mem_zpowers_iff] at hg
+    obtain ⟨i, rfl⟩ := hg
+    exact ⟨ModularGroup.S ^ i, ⟨i, rfl⟩, map_zpow _ _ _⟩
+
+theorem exists_place_zero :
+    ∃ W : AlgebraicCurve.Place ℂ K, 0 < W.ord (jK M K - algebraMap ℂ K 0) ∧
+      ∀ g ∈ stab ℂ⟮jK M K⟯ W,
+        ∃ k ∈ Subgroup.zpowers (ModularGroup.S * ModularGroup.T : SL(2, ℤ)), σ' M K k = g := by
+  have := finiteDimensional_jK M K
+  have := isGalois_jK M K
+  obtain ⟨W, hW, hWfix⟩ :=
+    ModularCurve.LevelN.exists_place_ord_sub_pos_forall_smul_eq M K ρ
+  rw [jAnalytic_ρ] at hW
+  refine ⟨W, hW, ?_⟩
+  have hS : σ' M K (ModularGroup.S * ModularGroup.T) ∈ stab ℂ⟮jK M K⟯ W := by
+    rw [mem_stab_σ'_iff]
+    exact hWfix _ ST_smul_ρ (comp_smul_mem M K _) (σK M K _) (σK_algebraMap M K _)
+  rcases Nat.lt_or_ge M 2 with hM | hM
+  · intro g hg
+    have := subsingleton_gal_of_lt_two M K hM
+    exact ⟨1, one_mem _, Subsingleton.elim _ _⟩
+  · obtain ⟨-, ⟨W', hW'pos, hW'le⟩, -⟩ :=
+      ModularCurve.LevelN.exists_place_ord_jGen_le_two_three_level M K
+    rw [← sub_zero (algebraMap (LevelN.ring M) K (LevelN.jGen M)), ← map_zero (algebraMap ℂ K)]
+      at hW'pos hW'le
+    have hle : W.ord (jK M K - algebraMap ℂ K 0) ≤ 3 := by
+      rw [← ord_sub_eq_ord_sub (jK M K) ℂ⟮jK M K⟯ rfl W W' 0 hW hW'pos]
+      exact hW'le
+    have hstab := stab_eq_zpowers (jK M K) ℂ⟮jK M K⟯ rfl W 0 hW
+      (σ' M K (ModularGroup.S * ModularGroup.T)) hS (by rw [orderOf_σ'_ST M K hM]; exact hle)
+    intro g hg
+    rw [hstab, Subgroup.mem_zpowers_iff] at hg
+    obtain ⟨i, rfl⟩ := hg
+    exact ⟨(ModularGroup.S * ModularGroup.T) ^ i, ⟨i, rfl⟩, map_zpow _ _ _⟩
+
+theorem exists_place_infty :
+    ∃ W : AlgebraicCurve.Place ℂ K, 0 < W.ord ((jK M K)⁻¹ - algebraMap ℂ K 0) ∧
+      ∀ g ∈ stab ℂ⟮jK M K⟯ W,
+        ∃ k ∈ Subgroup.zpowers (ModularGroup.T : SL(2, ℤ)) ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)),
+          σ' M K k = g := by
+  have := finiteDimensional_jK M K
+  have := isGalois_jK M K
+  obtain ⟨W, hW, hWfix⟩ :=
+    ModularCurve.LevelN.exists_place_ord_neg_forall_smul_eq M K (comp_smul_mem M K ModularGroup.T⁻¹)
+  change W.ord (jK M K) < 0 at hW
+  have hjK0 : jK M K ≠ 0 := by
+    intro h; rw [h, AlgebraicCurve.Place.ord_zero] at hW; exact lt_irrefl _ hW
+  have hW' : 0 < W.ord ((jK M K)⁻¹ - algebraMap ℂ K 0) := by
+    rw [map_zero, sub_zero, AlgebraicCurve.Place.ord_inv]; omega
+  refine ⟨W, hW', ?_⟩
+  have hT : σ' M K ModularGroup.T ∈ stab ℂ⟮jK M K⟯ W := by
+    rw [mem_stab_σ'_iff]
+    exact hWfix (σK M K _) (σK_algebraMap M K _)
+  rcases Nat.lt_or_ge M 2 with hM | hM
+  · intro g hg
+    have := subsingleton_gal_of_lt_two M K hM
+    exact ⟨1, one_mem _, Subsingleton.elim _ _⟩
+  · obtain ⟨-, -, ⟨W₁, hW₁neg, hW₁ge⟩⟩ :=
+      ModularCurve.LevelN.exists_place_ord_jGen_le_two_three_level M K
+    change W₁.ord (jK M K) < 0 at hW₁neg
+    change -(M : ℤ) ≤ W₁.ord (jK M K) at hW₁ge
+    have hW₁ : 0 < W₁.ord ((jK M K)⁻¹ - algebraMap ℂ K 0) := by
+      rw [map_zero, sub_zero, AlgebraicCurve.Place.ord_inv]; omega
+    have hle : W.ord ((jK M K)⁻¹ - algebraMap ℂ K 0) ≤ M := by
+      rw [← ord_sub_eq_ord_sub (jK M K)⁻¹ ℂ⟮jK M K⟯ (adjoin_inv_eq _).symm W W₁ 0 hW' hW₁,
+        map_zero, sub_zero, AlgebraicCurve.Place.ord_inv]
+      omega
+    have hstab := stab_eq_zpowers (jK M K)⁻¹ ℂ⟮jK M K⟯ (adjoin_inv_eq _).symm W 0 hW'
+      (σ' M K ModularGroup.T) hT (by rw [orderOf_σ'_T M K]; exact hle)
+    intro g hg
+    rw [hstab, Subgroup.mem_zpowers_iff] at hg
+    obtain ⟨i, rfl⟩ := hg
+    exact ⟨ModularGroup.T ^ i, Subgroup.mem_sup_left ⟨i, rfl⟩, map_zpow _ _ _⟩
+
+end Stabilisers
+
+section ConstantField
+
+variable {F : Type*} [Field F]
+variable {L : Type*} [Field L] [Algebra ℂ L] (t : L) (E : IntermediateField ℂ⟮t⟯ L) [Algebra F E]
+
+theorem adjoin_adjoin_subset {L : Type*} [Field L] [Algebra ℂ L] (S : Set L) (t : L)
+    (ht : t ∈ IntermediateField.adjoin ℂ S) :
+    ((IntermediateField.adjoin ℂ⟮t⟯ S : IntermediateField ℂ⟮t⟯ L) : Set L) ⊆
+      ((IntermediateField.adjoin ℂ S : IntermediateField ℂ L) : Set L) := by
+  have h1 : ((IntermediateField.adjoin ℂ⟮t⟯ S : IntermediateField ℂ⟮t⟯ L) : Set L) =
+      (IntermediateField.restrictScalars ℂ (IntermediateField.adjoin ℂ⟮t⟯ S) : Set L) := rfl
+  rw [h1, IntermediateField.restrictScalars_adjoin]
+  have hle : IntermediateField.adjoin ℂ ((ℂ⟮t⟯ : Set L) ∪ S) ≤ IntermediateField.adjoin ℂ S := by
+    rw [IntermediateField.adjoin_le_iff]
+    apply Set.union_subset
+    · have : ℂ⟮t⟯ ≤ IntermediateField.adjoin ℂ S := IntermediateField.adjoin_simple_le_iff.mpr ht
+      exact SetLike.coe_subset_coe.mpr this
+    · exact IntermediateField.subset_adjoin _ _
+  exact SetLike.coe_subset_coe.mpr hle
+
+theorem adjoin_range_eq_top
+    (hEle : (E : Set L) ⊆
+      ((IntermediateField.adjoin ℂ (Set.range fun u : F => (algebraMap F E u : L)) :
+        IntermediateField ℂ L) : Set L)) :
+    IntermediateField.adjoin ℂ (Set.range (algebraMap F E)) = ⊤ := by
+  let f : E →ₐ[ℂ] L := E.val.restrictScalars ℂ
+  set A := IntermediateField.adjoin ℂ (Set.range (algebraMap F E)) with hA
+  have hmapA : A.map f = IntermediateField.adjoin ℂ (Set.range fun u : F => (algebraMap F E u : L))
+    :=
+    by
+    rw [hA, IntermediateField.adjoin_map, ← Set.range_comp]
+    rfl
+  rw [eq_top_iff]
+  intro e _
+  have he : (e : L) ∈ A.map f := by
+    rw [hmapA]; exact hEle e.2
+  obtain ⟨a, ha, hae⟩ := (IntermediateField.mem_map A).mp he
+  have : a = e := Subtype.ext hae
+  rw [← this]; exact ha
+
+end ConstantField
+
+section Main
+
+variable (M : ℕ) [NeZero M]
+
+omit [NeZero M] in
+theorem T_mem_Gamma1 : ModularGroup.T ∈ CongruenceSubgroup.Gamma1 M := by
+  rw [CongruenceSubgroup.Gamma1_mem]
+  refine ⟨?_, ?_, ?_⟩ <;> simp [ModularGroup.coe_T]
+
+theorem neg_one_mem_center : (-1 : SL(2, ℤ)) ∈ Subgroup.center SL(2, ℤ) := by
+  rw [Subgroup.mem_center_iff]
+  intro g
+  rw [mul_neg_one, neg_one_mul]
+
+theorem isDomain_ring : IsDomain (LevelN.ring M) := by
+  have h := WLight.levelN_structure_package M PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (LevelN.wp M)
+    (fun v τ => rfl) (LevelN.fricke M) (fun v τ => rfl) LevelN.jAnalytic (fun τ => rfl)
+  have hzd := h.2.2.2.2.2
+  have hnz : NoZeroDivisors (LevelN.ring M) := ⟨fun {a b} hab => by
+    rcases hzd a b a.2 b.2 (by simpa using congrArg Subtype.val hab) with h | h
+    · exact Or.inl (Subtype.ext h)
+    · exact Or.inr (Subtype.ext h)⟩
+  have hnt : Nontrivial (LevelN.ring M) := ⟨⟨0, 1, fun h => by
+    have := congrFun (congrArg Subtype.val h) UpperHalfPlane.I
+    simp at this⟩⟩
+  exact NoZeroDivisors.to_isDomain _
+
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (LevelN.ring M) K]
+  [IsScalarTower ℂ (LevelN.ring M) K] [IsFractionRing (LevelN.ring M) K]
+
+theorem finrank_fixedField_map (Γ : Subgroup SL(2, ℤ)) (hΓ : CongruenceSubgroup.Gamma M ≤ Γ) :
+    haveI := finiteDimensional_jK M K
+    Module.finrank ℂ⟮jK M K⟯ (IntermediateField.fixedField (Γ.map (σ' M K))) =
+      (Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index := by
+  have := finiteDimensional_jK M K
+  have := isGalois_jK M K
+  set H := Γ.map (σ' M K) with hH
+  have h1 : Module.finrank (IntermediateField.fixedField H) K = Nat.card H :=
+    IntermediateField.finrank_fixedField_eq_card H
+  have h2 := Module.finrank_mul_finrank ℂ⟮jK M K⟯ (IntermediateField.fixedField H) K
+  have h3 : Module.finrank ℂ⟮jK M K⟯ K = Nat.card (K ≃ₐ[ℂ⟮jK M K⟯] K) :=
+    (IsGalois.card_aut_eq_finrank _ _).symm
+  have h4 := Subgroup.card_mul_index H
+  have hidx : H.index = (Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index := by
+    rw [hH, Subgroup.index_map, σ'_ker, MonoidHom.range_eq_top.mpr (σ'_surjective M K),
+      Subgroup.index_top, mul_one]
+    congr 1
+    apply le_antisymm
+    · exact sup_le le_sup_left (sup_le (hΓ.trans le_sup_left) le_sup_right)
+    · exact sup_le le_sup_left (le_sup_right.trans le_sup_right)
+  have hcard : 0 < Nat.card H := Nat.card_pos
+  rw [h1, h3, ← h4] at h2
+  rw [← hidx]
+  have : Module.finrank ℂ⟮jK M K⟯ (IntermediateField.fixedField H) * Nat.card H = H.index * Nat.card
+    H :=
+    by
+    rw [h2, mul_comm]
+  exact Nat.eq_of_mul_eq_mul_right hcard this
+
+variable (Γ : Subgroup SL(2, ℤ)) (hΓ : CongruenceSubgroup.Gamma1 M ≤ Γ)
+
+local notation "ℚ̄" => AlgebraicClosure ℚ
+local notation "FF" => laurentBaseChange (AlgebraicClosure ℚ) (qExpFunctionFieldC ℚ Γ)
+
+include K hΓ in
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+theorem main_K (ι : ℚ̄ →+* ℂ) (y : FF) (hy : (y : LaurentSeries ℚ̄) = jqModC ℚ̄)
+    (hfull : Module.finrank ℚ̄⟮y⟯ FF = (Γ ⊔ Subgroup.zpowers (-1)).index) :
+    Nat.card (DoubleCoset.Quotient (Γ : Set SL(2, ℤ))
+        (Subgroup.zpowers (ModularGroup.S * ModularGroup.T) : Set SL(2, ℤ))) ≤
+        Nat.card {P : AlgebraicCurve.Place ℚ̄ FF // 0 < P.ord y} ∧
+      Nat.card (DoubleCoset.Quotient (Γ : Set SL(2, ℤ))
+          (Subgroup.zpowers ModularGroup.S : Set SL(2, ℤ))) ≤
+        Nat.card {P : AlgebraicCurve.Place ℚ̄ FF // 0 < P.ord (y - 1728)} ∧
+      Nat.card (DoubleCoset.Quotient (Γ : Set SL(2, ℤ))
+          ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) :
+            Set SL(2, ℤ))) ≤
+        Nat.card {P : AlgebraicCurve.Place ℚ̄ FF // P.ord y < 0} := by
+  classical
+  have := finiteDimensional_jK M K
+  have := isGalois_jK M K
+  have hΓM : CongruenceSubgroup.Gamma M ≤ Γ := (Gamma_le_Gamma1 M).trans hΓ
+  have hT : ModularGroup.T ∈ Γ := hΓ (T_mem_Gamma1 M)
+  obtain ⟨Φ, hΦc, hΦy, hΦfix⟩ :=
+    ModularCurve.exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN M Γ hΓM hT ι K
+  set L₀ : IntermediateField ℂ K := ℂ⟮jK M K⟯ with hL₀
+  let E : IntermediateField L₀ K := IntermediateField.adjoin L₀ (Set.range Φ)
+  have hΦE : ∀ u, Φ u ∈ E := fun u => IntermediateField.subset_adjoin _ _ ⟨u, rfl⟩
+  let ΦE : FF →+* E := Φ.codRestrict E hΦE
+  let : Algebra ℚ̄ ℂ := ι.toAlgebra
+  let : Algebra FF E := ΦE.toAlgebra
+  let : Algebra ℚ̄ E := ((algebraMap ℂ E).comp ι).toAlgebra
+  have : IsScalarTower ℚ̄ ℂ E := IsScalarTower.of_algebraMap_eq (fun _ => rfl)
+  have : IsScalarTower ℚ̄ FF E := IsScalarTower.of_algebraMap_eq (fun c => by
+    apply Subtype.ext
+    change algebraMap ℂ K (ι c) = Φ (algebraMap ℚ̄ FF c)
+    rw [hΦc])
+  have hyT : Transcendental ℚ̄ y := by
+    have h := transcendental_jqModC ℚ̄
+    rw [← hy] at h
+    exact (transcendental_algebraMap_iff (R := ℚ̄) (A := LaurentSeries ℚ̄)
+      (algebraMap FF (LaurentSeries ℚ̄)).injective).mp h
+  have hΓfi : (Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).FiniteIndex :=
+    Subgroup.finiteIndex_of_le (hΓ.trans le_sup_left)
+  have hfin : FiniteDimensional ℚ̄⟮y⟯ FF := by
+    apply Module.finite_of_finrank_pos
+    rw [hfull]
+    exact Nat.pos_of_ne_zero Subgroup.FiniteIndex.index_ne_zero
+  have : AlgebraicCurve.IsCurveOver ℚ̄ FF :=
+    AlgebraicCurve.isCurveOver_of_transcendental_of_perfectField hyT hfin
+  have hjE : jK M K ∈ E :=
+    E.algebraMap_mem (⟨jK M K, IntermediateField.mem_adjoin_simple_self ℂ _⟩ : L₀)
+  let xE : E := ⟨jK M K, hjE⟩
+  have hyt : ((algebraMap FF E y : E) : K) = jK M K := hΦy y hy
+  have hΦEy : algebraMap FF E y = xE := Subtype.ext hyt
+  have : FiniteDimensional L₀ E := IntermediateField.finiteDimensional_left E
+  have hgen : IntermediateField.adjoin ℂ (Set.range (algebraMap FF E)) = ⊤ := by
+    apply adjoin_range_eq_top (jK M K) E
+    change ((IntermediateField.adjoin L₀ (Set.range Φ) : IntermediateField L₀ K) : Set K) ⊆
+      ((IntermediateField.adjoin ℂ (Set.range fun u => Φ u) : IntermediateField ℂ K) : Set K)
+    apply adjoin_adjoin_subset
+    exact IntermediateField.subset_adjoin _ _ ⟨y, hΦy y hy⟩
+  have hσE : ∀ γ ∈ Γ, ∀ e ∈ E, σ' M K γ e = e := by
+    intro γ hγ e he
+    have hle : E ≤ IntermediateField.fixedField (Subgroup.zpowers (σ' M K γ)) := by
+      apply IntermediateField.adjoin_le_iff.mpr
+      rintro _ ⟨u, rfl⟩
+      rw [SetLike.mem_coe, IntermediateField.mem_fixedField_iff]
+      intro g hg
+      have hst : σ' M K γ ∈ MulAction.stabilizer (K ≃ₐ[L₀] K) (Φ u) := by
+        rw [MulAction.mem_stabilizer_iff, AlgEquiv.smul_def, σ'_apply]
+        exact hΦfix γ hγ (comp_smul_mem M K γ⁻¹) (σK M K γ) (σK_algebraMap M K γ) u
+      have := (Subgroup.zpowers_le.mpr hst) hg
+      rwa [MulAction.mem_stabilizer_iff, AlgEquiv.smul_def] at this
+    exact (IntermediateField.mem_fixedField_iff _ e).mp (hle he) _ (Subgroup.mem_zpowers _)
+  set H := Γ.map (σ' M K) with hH
+  have hEle : E ≤ IntermediateField.fixedField H := by
+    rw [IntermediateField.le_iff_le]
+    rintro _ ⟨γ, hγ, rfl⟩
+    rw [IntermediateField.mem_fixingSubgroup_iff]
+    intro e he
+    exact hσE γ hγ e he
+  obtain ⟨hdeg, hplaces⟩ :=
+    AlgebraicCurve.finrank_le_and_natCard_places_le_of_constantFieldExtension_adjoin y hyT
+      (jK M K) (transcendental_jK M K) E hyt hgen
+  have hEeq : E = IntermediateField.fixedField H := by
+    apply IntermediateField.eq_of_le_of_finrank_le hEle
+    rw [finrank_fixedField_map M K Γ hΓM, ← hfull]
+    exact hdeg
+  have hfixers : ∀ (Kst : Subgroup SL(2, ℤ)), (-1 : SL(2, ℤ)) ∈ Kst →
+      ∀ g₀ : SL(2, ℤ), (∀ e : E, σ' M K g₀ e = e) →
+        ∃ a ∈ Γ, ∃ z ∈ Kst, z ∈ Subgroup.center SL(2, ℤ) ∧ g₀ = a * z := by
+    intro Kst hKst g₀ hg₀
+    have hmem : σ' M K g₀ ∈ E.fixingSubgroup := by
+      rw [IntermediateField.mem_fixingSubgroup_iff]
+      intro e he
+      exact hg₀ ⟨e, he⟩
+    rw [hEeq, IntermediateField.fixingSubgroup_fixedField, hH] at hmem
+    obtain ⟨a, ha, hag⟩ := Subgroup.mem_map.mp hmem
+    have hker : a⁻¹ * g₀ ∈ Gpm M := by
+      rw [← σ'_ker M K, MonoidHom.mem_ker, map_mul, map_inv, hag, inv_mul_cancel]
+    rcases mem_Gpm_imp M hker with h | h
+    · refine ⟨a * (a⁻¹ * g₀), Γ.mul_mem ha (hΓM h), 1, one_mem _, Subgroup.one_mem _, by group⟩
+    · refine ⟨a * -(a⁻¹ * g₀), Γ.mul_mem ha (hΓM h), -1, hKst, neg_one_mem_center, ?_⟩
+      simp
+  have hy0 : y ≠ 0 := fun h => by
+    rw [h] at hyT; exact hyT isAlgebraic_zero
+  have hy1728 : y - 1728 ≠ 0 := fun h => by
+    rw [sub_eq_zero] at h
+    rw [h] at hyT
+    refine hyT ?_
+    rw [show (1728 : FF) = algebraMap ℚ̄ FF 1728 from (map_ofNat (algebraMap ℚ̄ FF) 1728).symm]
+    exact isAlgebraic_algebraMap _
+  have hposE : ∀ u : FF, u ≠ 0 →
+      Finite {P : AlgebraicCurve.Place ℂ E // 0 < P.ord (algebraMap FF E u)} ∧
+        Nat.card {P : AlgebraicCurve.Place ℂ E // 0 < P.ord (algebraMap FF E u)} ≤
+          Nat.card {P : AlgebraicCurve.Place ℚ̄ FF // 0 < P.ord u} := fun u hu =>
+    (hplaces u hu).1
+  have hnegE : ∀ u : FF, u ≠ 0 →
+      Finite {P : AlgebraicCurve.Place ℂ E // P.ord (algebraMap FF E u) < 0} ∧
+        Nat.card {P : AlgebraicCurve.Place ℂ E // P.ord (algebraMap FF E u) < 0} ≤
+          Nat.card {P : AlgebraicCurve.Place ℚ̄ FF // P.ord u < 0} := fun u hu =>
+    (hplaces u hu).2
+  refine ⟨?_, ?_, ?_⟩
+  · obtain ⟨W, hW, hD⟩ := exists_place_zero M K
+    obtain ⟨hfinE, hle⟩ := hposE y hy0
+    have hset : algebraMap FF E y = xE - algebraMap ℂ E 0 := by rw [map_zero, sub_zero, hΦEy]
+    rw [hset] at hfinE hle
+    have := hfinE
+    exact (natCard_doubleCoset_le (jK M K) L₀ rfl (σ' M K) Γ
+      (Subgroup.zpowers (ModularGroup.S * ModularGroup.T)) E (hfixers _ neg_one_mem_zpowers_ST)
+      W 0 hW hD xE rfl).trans hle
+  · obtain ⟨W, hW, hD⟩ := exists_place_1728 M K
+    obtain ⟨hfinE, hle⟩ := hposE (y - 1728) hy1728
+    have hset : algebraMap FF E (y - 1728) = xE - algebraMap ℂ E 1728 := by
+      rw [map_sub, hΦEy, map_ofNat, map_ofNat]
+    rw [hset] at hfinE hle
+    have := hfinE
+    exact (natCard_doubleCoset_le (jK M K) L₀ rfl (σ' M K) Γ
+      (Subgroup.zpowers ModularGroup.S) E (hfixers _ neg_one_mem_zpowers_S)
+      W 1728 hW hD xE rfl).trans hle
+  · obtain ⟨W, hW, hD⟩ := exists_place_infty M K
+    obtain ⟨hfinE, hle⟩ := hnegE y hy0
+    have hxE0 : xE ≠ 0 := by
+      intro h
+      have := congrArg (fun e : E => (e : K)) h
+      change jK M K = 0 at this
+      exact (transcendental_jK M K) (this ▸ isAlgebraic_zero)
+    have hiff : ∀ P : AlgebraicCurve.Place ℂ E,
+        0 < P.ord (xE⁻¹ - algebraMap ℂ E 0) ↔ P.ord (algebraMap FF E y) < 0 := by
+      intro P
+      rw [map_zero, sub_zero, AlgebraicCurve.Place.ord_inv, hΦEy]
+      omega
+    let eqv : {P : AlgebraicCurve.Place ℂ E // 0 < P.ord (xE⁻¹ - algebraMap ℂ E 0)} ≃
+        {P : AlgebraicCurve.Place ℂ E // P.ord (algebraMap FF E y) < 0} :=
+      Equiv.subtypeEquivRight hiff
+    have : Finite {P : AlgebraicCurve.Place ℂ E // 0 < P.ord (xE⁻¹ - algebraMap ℂ E 0)} :=
+      Finite.of_equiv _ eqv.symm
+    have h1 := natCard_doubleCoset_le (jK M K)⁻¹ L₀ (adjoin_inv_eq _).symm (σ' M K) Γ
+      (Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))) E
+      (hfixers _ neg_one_mem_zpowers_T_sup) W 0 hW hD xE⁻¹ rfl
+    rw [Nat.card_congr eqv] at h1
+    exact h1.trans hle
+
+include hΓ in
+theorem main (y : FF) (hy : (y : LaurentSeries ℚ̄) = jqModC ℚ̄)
+    (hfull : Module.finrank ℚ̄⟮y⟯ FF = (Γ ⊔ Subgroup.zpowers (-1)).index) :
+    Nat.card (DoubleCoset.Quotient (Γ : Set SL(2, ℤ))
+        (Subgroup.zpowers (ModularGroup.S * ModularGroup.T) : Set SL(2, ℤ))) ≤
+        Nat.card {P : AlgebraicCurve.Place ℚ̄ FF // 0 < P.ord y} ∧
+      Nat.card (DoubleCoset.Quotient (Γ : Set SL(2, ℤ))
+          (Subgroup.zpowers ModularGroup.S : Set SL(2, ℤ))) ≤
+        Nat.card {P : AlgebraicCurve.Place ℚ̄ FF // 0 < P.ord (y - 1728)} ∧
+      Nat.card (DoubleCoset.Quotient (Γ : Set SL(2, ℤ))
+          ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) :
+            Set SL(2, ℤ))) ≤
+        Nat.card {P : AlgebraicCurve.Place ℚ̄ FF // P.ord y < 0} := by
+  have := isDomain_ring M
+  have : Algebra.IsAlgebraic ℚ ℚ̄ := AlgebraicClosure.isAlgebraic ℚ
+  let ι : ℚ̄ →+* ℂ := (IsAlgClosed.lift (R := ℚ) (M := ℂ) (S := ℚ̄)).toRingHom
+  exact main_K M (FractionRing (LevelN.ring M)) Γ hΓ ι y hy hfull
+
+end Main
+
+end ModularCurve.SpecialFibresLB
+end
+
+open AlgebraicCurve _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_natCard_doubleCoset_le_card_fibres_of_finrank_eq_index.ModularCurve
+  ModularCurve.SpecialFibresLB in
+theorem solution
+    (M : ℕ) [NeZero M] (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+    (hΓ : CongruenceSubgroup.Gamma1 M ≤ Γ)
+    (y : ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ Γ))
+    (hy : (y : LaurentSeries (AlgebraicClosure ℚ)) = ModularCurve.jqModC (AlgebraicClosure ℚ))
+    (hfull : Module.finrank
+          (IntermediateField.adjoin (AlgebraicClosure ℚ)
+            ({y} : Set (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+              (ModularCurve.qExpFunctionFieldC ℚ Γ))))
+          (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+            Γ)) =
+        (Γ ⊔ Subgroup.zpowers (-1)).index) :
+    Nat.card (DoubleCoset.Quotient (Γ : Set (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+        (Subgroup.zpowers (ModularGroup.S * ModularGroup.T) :
+          Set (Matrix.SpecialLinearGroup (Fin 2) ℤ))) ≤
+        Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+          (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+            Γ)) //
+            0 < P.ord y} ∧
+      Nat.card (DoubleCoset.Quotient (Γ : Set (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+          (Subgroup.zpowers ModularGroup.S : Set (Matrix.SpecialLinearGroup (Fin 2) ℤ))) ≤
+        Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+          (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+            Γ)) //
+            0 < P.ord (y - 1728)} ∧
+      Nat.card (DoubleCoset.Quotient (Γ : Set (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+          ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) :
+              Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) :
+            Set (Matrix.SpecialLinearGroup (Fin 2) ℤ))) ≤
+        Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+          (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+            Γ)) //
+            P.ord y < 0} :=
+  ModularCurve.SpecialFibresLB.main M Γ hΓ y hy hfull
+
+end S_ModularCurve_natCard_doubleCoset_le_card_fibres_of_finrank_eq_index
+end P2MW
+export P2MW.S_ModularCurve_natCard_doubleCoset_le_card_fibres_of_finrank_eq_index (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.natCard_doubleCoset_le_card_fibres_of_finrank_eq_index
+    (M : ℕ) [NeZero M] (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+    (hΓ : CongruenceSubgroup.Gamma1 M ≤ Γ)
+    (y : ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ Γ))
+    (hy : (y : LaurentSeries (AlgebraicClosure ℚ)) = ModularCurve.jqModC (AlgebraicClosure ℚ))
+    (hfull : Module.finrank
+          (IntermediateField.adjoin (AlgebraicClosure ℚ)
+            ({y} : Set (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+              (ModularCurve.qExpFunctionFieldC ℚ Γ))))
+          (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+            Γ)) =
+        (Γ ⊔ Subgroup.zpowers (-1)).index) :
+    Nat.card (DoubleCoset.Quotient (Γ : Set (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+        (Subgroup.zpowers (ModularGroup.S * ModularGroup.T) :
+          Set (Matrix.SpecialLinearGroup (Fin 2) ℤ))) ≤
+        Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+          (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+            Γ)) //
+            0 < P.ord y} ∧
+      Nat.card (DoubleCoset.Quotient (Γ : Set (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+          (Subgroup.zpowers ModularGroup.S : Set (Matrix.SpecialLinearGroup (Fin 2) ℤ))) ≤
+        Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+          (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+            Γ)) //
+            0 < P.ord (y - 1728)} ∧
+      Nat.card (DoubleCoset.Quotient (Γ : Set (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+          ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) :
+              Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) :
+            Set (Matrix.SpecialLinearGroup (Fin 2) ℤ))) ≤
+        Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+          (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+            Γ)) //
+            P.ord y < 0} :=
+  solution M Γ hΓ y hy hfull
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_fixedPoints_ST_cosets_Gamma0_eq_nuThree.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_fixedPoints_ST_cosets_Gamma0_eq_nuThree.lean
new file mode 100644
index 0000000000..2f16fd01b9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_fixedPoints_ST_cosets_Gamma0_eq_nuThree.lean
@@ -0,0 +1,207 @@
+/-
+Based on Prove2Me node ModularCurve.natCard_fixedPoints_ST_cosets_Gamma0_eq_nuThree
+(8e2177fe-4148-5154-9489-e06c363d0212) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f4f79cf9-c3b6-5b33-945e-c11168ad16b2
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cosets of Γ₀(N) fixed by ST number ν₃(N)
+
+Theorem statement: `ModularCurve.natCard_fixedPoints_ST_cosets_Gamma0_eq_nuThree`
+(`8e2177fe-4148-5154-9489-e06c363d0212`), by Claude, 2026-09-05.
+
+Proof: submission `f4f79cf9-c3b6-5b33-945e-c11168ad16b2`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, assumed nonzero. Consider the quotient
+$\mathrm{SL}_2(\mathbb{Z})/\Gamma_0(N)$ of $\mathrm{SL}_2(\mathbb{Z})$ by the congruence subgroup
+$\Gamma_0(N)$ (the set of right cosets $g\Gamma_0(N)$), on which $\mathrm{SL}_2(\mathbb{Z})$ acts by
+left multiplication, and let $S$ and $T$ be the standard generators of $\mathrm{SL}_2(\mathbb{Z})$,
+so that $ST = \begin{pmatrix} 0 & -1 \\ 1 & 1\end{pmatrix}$. The assertion is that the number of
+elements $x$ of this coset space with $(ST)\cdot x = x$, counted by `Nat.card`, equals $\nu_3(N)$,
+which is by definition the number of elements $x$ of $\mathbb{Z}/N\mathbb{Z}$ satisfying $x^2 + x +
+1 = 0$, again counted by `Nat.card`. Both sides are thus natural numbers, and no finiteness
+hypothesis is imposed beyond $N \neq 0$; the equality of cardinalities is obtained from an explicit
+bijection between the two sets.
+
+In the classical theory this is the count of $\Gamma_0(N)$-inequivalent elliptic points of order $3$
+on the modular curve $X_0(N)$, here stated in purely group-theoretic form as a count of fixed
+cosets. It feeds the genus and dimension numerics for $\Gamma_0(N)$, and is used in the computations
+of parabolic cohomology dimensions and in the analysis of elements of trace at most $4$ in absolute
+value.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_natCard_fixedPoints_ST_cosets_Gamma0_eq_nuThree.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_natCard_fixedPoints_ST_cosets_Gamma0_eq_nuThree
+
+namespace W7SF
+
+open Matrix Matrix.SpecialLinearGroup ModularGroup CongruenceSubgroup
+open scoped MatrixGroups
+
+def V (s : ℤ) : SL(2, ℤ) := ⟨!![0, -1; 1, s], by norm_num [Matrix.det_fin_two_of]⟩
+
+def gl (l : ℤ) : SL(2, ℤ) := ⟨!![l, -1; 1, 0], by norm_num [Matrix.det_fin_two_of]⟩
+
+theorem V_zero : V 0 = S := by decide
+theorem V_one : V 1 = S * T := by decide
+
+@[scoped simp] theorem V_00 (s : ℤ) : (V s) 0 0 = 0 := rfl
+@[scoped simp] theorem V_01 (s : ℤ) : (V s) 0 1 = -1 := rfl
+@[scoped simp] theorem V_10 (s : ℤ) : (V s) 1 0 = 1 := rfl
+@[scoped simp] theorem V_11 (s : ℤ) : (V s) 1 1 = s := rfl
+@[scoped simp] theorem gl_00 (l : ℤ) : (gl l) 0 0 = l := rfl
+@[scoped simp] theorem gl_01 (l : ℤ) : (gl l) 0 1 = -1 := rfl
+@[scoped simp] theorem gl_10 (l : ℤ) : (gl l) 1 0 = 1 := rfl
+@[scoped simp] theorem gl_11 (l : ℤ) : (gl l) 1 1 = 0 := rfl
+
+theorem inv_mul_lower (g h : SL(2, ℤ)) :
+    (g⁻¹ * h) 1 0 = g 0 0 * h 1 0 - g 1 0 * h 0 0 := by
+  simp [coe_mul, coe_inv, Matrix.adjugate_fin_two, Matrix.mul_apply, Fin.sum_univ_two]
+  ring
+
+theorem V_mul_00 (s : ℤ) (g : SL(2, ℤ)) : (V s * g) 0 0 = -g 1 0 := by
+  simp [coe_mul, Matrix.mul_apply, Fin.sum_univ_two]
+
+theorem V_mul_10 (s : ℤ) (g : SL(2, ℤ)) : (V s * g) 1 0 = g 0 0 + s * g 1 0 := by
+  simp [coe_mul, Matrix.mul_apply, Fin.sum_univ_two]
+
+variable (N : ℕ)
+
+abbrev X : Type := SL(2, ℤ) ⧸ Gamma0 N
+
+theorem mk_eq_mk_iff (g h : SL(2, ℤ)) :
+    ((g : X N) = (h : X N)) ↔ ((g 0 0 : ℤ) : ZMod N) * (h 1 0 : ℤ) - (g 1 0 : ℤ) * (h 0 0 : ℤ) = 0
+      := by
+  rw [QuotientGroup.eq, Gamma0_mem, inv_mul_lower]
+  push_cast
+  exact Iff.rfl
+
+theorem fixed_iff (s : ℤ) (g : SL(2, ℤ)) :
+    V s • (g : X N) = (g : X N) ↔
+      ((g 0 0 : ℤ) : ZMod N) ^ 2 + (s : ZMod N) * (g 0 0 : ℤ) * (g 1 0 : ℤ)
+        + ((g 1 0 : ℤ) : ZMod N) ^ 2 = 0 := by
+  rw [MulAction.Quotient.smul_mk, smul_eq_mul, eq_comm, mk_eq_mk_iff, V_mul_00, V_mul_10]
+  push_cast
+  constructor <;> intro h <;> linear_combination h
+
+abbrev Roots (s : ℤ) : Type := {x : ZMod N // x ^ 2 + (s : ZMod N) * x + 1 = 0}
+
+abbrev Fixed (s : ℤ) : Type := {y : X N // V s • y = y}
+
+variable [NeZero N]
+
+theorem cast_val (x : ZMod N) : (((x.val : ℕ) : ℤ) : ZMod N) = x := by
+  rw [Int.cast_natCast, ZMod.natCast_zmod_val]
+
+noncomputable def toFixed (s : ℤ) (x : Roots N s) : Fixed N s :=
+  ⟨(gl (x.1.val : ℤ) : X N), by
+    rw [fixed_iff]
+    simp only [gl_00, gl_10, cast_val, Int.cast_one, mul_one, one_pow]
+    exact x.2⟩
+
+theorem toFixed_injective (s : ℤ) : Function.Injective (toFixed N s) := by
+  rintro ⟨x, hx⟩ ⟨y, hy⟩ h
+  have h' := congr_arg (fun z : Fixed N s => z.1) h
+  simp only [toFixed] at h'
+  rw [mk_eq_mk_iff] at h'
+  simp only [gl_00, gl_10, cast_val, Int.cast_one, mul_one, one_mul] at h'
+  exact Subtype.ext (sub_eq_zero.mp h')
+
+theorem toFixed_surjective (s : ℤ) : Function.Surjective (toFixed N s) := by
+  rintro ⟨y, hy⟩
+  induction y using QuotientGroup.induction_on with
+  | H g =>
+    rw [fixed_iff] at hy
+    have hdet : ((g 0 0 : ℤ) : ZMod N) * ((g 1 1 : ℤ) : ZMod N)
+        - ((g 0 1 : ℤ) : ZMod N) * ((g 1 0 : ℤ) : ZMod N) = 1 := by
+      have h := Matrix.det_fin_two (g : Matrix (Fin 2) (Fin 2) ℤ)
+      rw [g.det_coe] at h
+      have h' := congrArg (Int.cast (R := ZMod N)) h
+      push_cast at h'
+      exact h'.symm
+    set a : ZMod N := ((g 0 0 : ℤ) : ZMod N)
+    set b : ZMod N := ((g 0 1 : ℤ) : ZMod N)
+    set c : ZMod N := ((g 1 0 : ℤ) : ZMod N)
+    set d : ZMod N := ((g 1 1 : ℤ) : ZMod N)
+    set w : ZMod N := -((s : ZMod N) * a + c) * d ^ 2 - 2 * a * b * d + b ^ 2 * c
+    have hcw : c * w = 1 := by
+      linear_combination (a * d - b * c + 1) * hdet - d ^ 2 * hy
+    refine ⟨⟨a * w, ?_⟩, ?_⟩
+    · linear_combination w ^ 2 * hy - ((s : ZMod N) * a * w + 1 + c * w) * hcw
+    · apply Subtype.ext
+      simp only [toFixed]
+      rw [mk_eq_mk_iff]
+      simp only [gl_00, gl_10, cast_val, Int.cast_one, one_mul]
+      linear_combination a * hcw
+
+theorem card_fixed_eq (s : ℤ) : Nat.card (Fixed N s) = Nat.card (Roots N s) :=
+  (Nat.card_congr (Equiv.ofBijective _ ⟨toFixed_injective N s, toFixed_surjective N s⟩)).symm
+
+theorem card_fixed_S :
+    Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N // ModularGroup.S • x = x} =
+      ModularCurve.nuTwo N := by
+  have h : Nat.card {y : X N // S • y = y} = Nat.card (Roots N 0) := by
+    rw [← V_zero]; exact card_fixed_eq N 0
+  refine h.trans ?_
+  unfold ModularCurve.nuTwo
+  exact Nat.card_congr (Equiv.subtypeEquivRight fun x => by simp)
+
+theorem card_fixed_ST :
+    Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N //
+        (ModularGroup.S * ModularGroup.T) • x = x} =
+      ModularCurve.nuThree N := by
+  have h : Nat.card {y : X N // (S * T) • y = y} = Nat.card (Roots N 1) := by
+    rw [← V_one]; exact card_fixed_eq N 1
+  refine h.trans ?_
+  unfold ModularCurve.nuThree
+  exact Nat.card_congr (Equiv.subtypeEquivRight fun x => by simp)
+
+end W7SF
+
+open scoped MatrixGroups in
+theorem solution (N : ℕ) [NeZero N] :
+    Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N //
+        (ModularGroup.S * ModularGroup.T) • x = x} =
+      ModularCurve.nuThree N :=
+  W7SF.card_fixed_ST N
+
+end S_ModularCurve_natCard_fixedPoints_ST_cosets_Gamma0_eq_nuThree
+end P2MW
+export P2MW.S_ModularCurve_natCard_fixedPoints_ST_cosets_Gamma0_eq_nuThree (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.natCard_fixedPoints_ST_cosets_Gamma0_eq_nuThree (N : ℕ) [NeZero N] :
+    Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N //
+        (ModularGroup.S * ModularGroup.T) • x = x} =
+      ModularCurve.nuThree N :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_fixedPoints_S_cosets_Gamma0_eq_nuTwo.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_fixedPoints_S_cosets_Gamma0_eq_nuTwo.lean
new file mode 100644
index 0000000000..72760d0f92
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_fixedPoints_S_cosets_Gamma0_eq_nuTwo.lean
@@ -0,0 +1,204 @@
+/-
+Based on Prove2Me node ModularCurve.natCard_fixedPoints_S_cosets_Gamma0_eq_nuTwo
+(d7290527-797b-553d-add1-b8e81079b9b9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6688dc19-10ad-5fa5-b5bf-8499bb96bf9d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cosets of Γ₀(N) fixed by S number ν₂(N)
+
+Theorem statement: `ModularCurve.natCard_fixedPoints_S_cosets_Gamma0_eq_nuTwo`
+(`d7290527-797b-553d-add1-b8e81079b9b9`), by Claude, 2026-09-05.
+
+Proof: submission `6688dc19-10ad-5fa5-b5bf-8499bb96bf9d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, assumed nonzero. Consider the left coset space
+$\mathrm{SL}_2(\mathbb{Z})/\Gamma_0(N)$, where $\Gamma_0(N)$ is Mathlib's congruence subgroup
+`CongruenceSubgroup.Gamma0 N` of matrices in $\mathrm{SL}_2(\mathbb{Z})$ whose lower-left entry is
+divisible by $N$, and let $\mathrm{SL}_2(\mathbb{Z})$ act on this space by left translation. The
+theorem asserts that the cardinality of the subtype of cosets $x$ with $S \cdot x = x$, where $S =
+\begin{pmatrix} 0 & -1 \\ 1 & 0\end{pmatrix}$ is `ModularGroup.S`, equals $\nu_2(N)$, which by
+definition is the cardinality of $\{x \in \mathbb{Z}/N\mathbb{Z} : x^2 + 1 = 0\}$. Both
+cardinalities are taken as `Nat.card`; the statement is an equality of natural numbers, no
+finiteness being assumed in advance (the equality of `Nat.card` values is what is proved, the
+underlying bijection being the content).
+
+This is the group-theoretic form of the count of $\Gamma_0(N)$-inequivalent elliptic points of order
+$2$ on the modular curve $X_0(N)$, one of the ingredients of the genus formula. It is used in the
+bounds on the dimension of spaces of parabolic cohomology classes and in the estimates entering the
+genus formula for $\Gamma_0(N)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_natCard_fixedPoints_S_cosets_Gamma0_eq_nuTwo.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_natCard_fixedPoints_S_cosets_Gamma0_eq_nuTwo
+
+namespace W7SF
+
+open Matrix Matrix.SpecialLinearGroup ModularGroup CongruenceSubgroup
+open scoped MatrixGroups
+
+def V (s : ℤ) : SL(2, ℤ) := ⟨!![0, -1; 1, s], by norm_num [Matrix.det_fin_two_of]⟩
+
+def gl (l : ℤ) : SL(2, ℤ) := ⟨!![l, -1; 1, 0], by norm_num [Matrix.det_fin_two_of]⟩
+
+theorem V_zero : V 0 = S := by decide
+theorem V_one : V 1 = S * T := by decide
+
+@[scoped simp] theorem V_00 (s : ℤ) : (V s) 0 0 = 0 := rfl
+@[scoped simp] theorem V_01 (s : ℤ) : (V s) 0 1 = -1 := rfl
+@[scoped simp] theorem V_10 (s : ℤ) : (V s) 1 0 = 1 := rfl
+@[scoped simp] theorem V_11 (s : ℤ) : (V s) 1 1 = s := rfl
+@[scoped simp] theorem gl_00 (l : ℤ) : (gl l) 0 0 = l := rfl
+@[scoped simp] theorem gl_01 (l : ℤ) : (gl l) 0 1 = -1 := rfl
+@[scoped simp] theorem gl_10 (l : ℤ) : (gl l) 1 0 = 1 := rfl
+@[scoped simp] theorem gl_11 (l : ℤ) : (gl l) 1 1 = 0 := rfl
+
+theorem inv_mul_lower (g h : SL(2, ℤ)) :
+    (g⁻¹ * h) 1 0 = g 0 0 * h 1 0 - g 1 0 * h 0 0 := by
+  simp [coe_mul, coe_inv, Matrix.adjugate_fin_two, Matrix.mul_apply, Fin.sum_univ_two]
+  ring
+
+theorem V_mul_00 (s : ℤ) (g : SL(2, ℤ)) : (V s * g) 0 0 = -g 1 0 := by
+  simp [coe_mul, Matrix.mul_apply, Fin.sum_univ_two]
+
+theorem V_mul_10 (s : ℤ) (g : SL(2, ℤ)) : (V s * g) 1 0 = g 0 0 + s * g 1 0 := by
+  simp [coe_mul, Matrix.mul_apply, Fin.sum_univ_two]
+
+variable (N : ℕ)
+
+abbrev X : Type := SL(2, ℤ) ⧸ Gamma0 N
+
+theorem mk_eq_mk_iff (g h : SL(2, ℤ)) :
+    ((g : X N) = (h : X N)) ↔ ((g 0 0 : ℤ) : ZMod N) * (h 1 0 : ℤ) - (g 1 0 : ℤ) * (h 0 0 : ℤ) = 0
+      := by
+  rw [QuotientGroup.eq, Gamma0_mem, inv_mul_lower]
+  push_cast
+  exact Iff.rfl
+
+theorem fixed_iff (s : ℤ) (g : SL(2, ℤ)) :
+    V s • (g : X N) = (g : X N) ↔
+      ((g 0 0 : ℤ) : ZMod N) ^ 2 + (s : ZMod N) * (g 0 0 : ℤ) * (g 1 0 : ℤ)
+        + ((g 1 0 : ℤ) : ZMod N) ^ 2 = 0 := by
+  rw [MulAction.Quotient.smul_mk, smul_eq_mul, eq_comm, mk_eq_mk_iff, V_mul_00, V_mul_10]
+  push_cast
+  constructor <;> intro h <;> linear_combination h
+
+abbrev Roots (s : ℤ) : Type := {x : ZMod N // x ^ 2 + (s : ZMod N) * x + 1 = 0}
+
+abbrev Fixed (s : ℤ) : Type := {y : X N // V s • y = y}
+
+variable [NeZero N]
+
+theorem cast_val (x : ZMod N) : (((x.val : ℕ) : ℤ) : ZMod N) = x := by
+  rw [Int.cast_natCast, ZMod.natCast_zmod_val]
+
+noncomputable def toFixed (s : ℤ) (x : Roots N s) : Fixed N s :=
+  ⟨(gl (x.1.val : ℤ) : X N), by
+    rw [fixed_iff]
+    simp only [gl_00, gl_10, cast_val, Int.cast_one, mul_one, one_pow]
+    exact x.2⟩
+
+theorem toFixed_injective (s : ℤ) : Function.Injective (toFixed N s) := by
+  rintro ⟨x, hx⟩ ⟨y, hy⟩ h
+  have h' := congr_arg (fun z : Fixed N s => z.1) h
+  simp only [toFixed] at h'
+  rw [mk_eq_mk_iff] at h'
+  simp only [gl_00, gl_10, cast_val, Int.cast_one, mul_one, one_mul] at h'
+  exact Subtype.ext (sub_eq_zero.mp h')
+
+theorem toFixed_surjective (s : ℤ) : Function.Surjective (toFixed N s) := by
+  rintro ⟨y, hy⟩
+  induction y using QuotientGroup.induction_on with
+  | H g =>
+    rw [fixed_iff] at hy
+    have hdet : ((g 0 0 : ℤ) : ZMod N) * ((g 1 1 : ℤ) : ZMod N)
+        - ((g 0 1 : ℤ) : ZMod N) * ((g 1 0 : ℤ) : ZMod N) = 1 := by
+      have h := Matrix.det_fin_two (g : Matrix (Fin 2) (Fin 2) ℤ)
+      rw [g.det_coe] at h
+      have h' := congrArg (Int.cast (R := ZMod N)) h
+      push_cast at h'
+      exact h'.symm
+    set a : ZMod N := ((g 0 0 : ℤ) : ZMod N)
+    set b : ZMod N := ((g 0 1 : ℤ) : ZMod N)
+    set c : ZMod N := ((g 1 0 : ℤ) : ZMod N)
+    set d : ZMod N := ((g 1 1 : ℤ) : ZMod N)
+    set w : ZMod N := -((s : ZMod N) * a + c) * d ^ 2 - 2 * a * b * d + b ^ 2 * c
+    have hcw : c * w = 1 := by
+      linear_combination (a * d - b * c + 1) * hdet - d ^ 2 * hy
+    refine ⟨⟨a * w, ?_⟩, ?_⟩
+    · linear_combination w ^ 2 * hy - ((s : ZMod N) * a * w + 1 + c * w) * hcw
+    · apply Subtype.ext
+      simp only [toFixed]
+      rw [mk_eq_mk_iff]
+      simp only [gl_00, gl_10, cast_val, Int.cast_one, one_mul]
+      linear_combination a * hcw
+
+theorem card_fixed_eq (s : ℤ) : Nat.card (Fixed N s) = Nat.card (Roots N s) :=
+  (Nat.card_congr (Equiv.ofBijective _ ⟨toFixed_injective N s, toFixed_surjective N s⟩)).symm
+
+theorem card_fixed_S :
+    Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N // ModularGroup.S • x = x} =
+      ModularCurve.nuTwo N := by
+  have h : Nat.card {y : X N // S • y = y} = Nat.card (Roots N 0) := by
+    rw [← V_zero]; exact card_fixed_eq N 0
+  refine h.trans ?_
+  unfold ModularCurve.nuTwo
+  exact Nat.card_congr (Equiv.subtypeEquivRight fun x => by simp)
+
+theorem card_fixed_ST :
+    Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N //
+        (ModularGroup.S * ModularGroup.T) • x = x} =
+      ModularCurve.nuThree N := by
+  have h : Nat.card {y : X N // (S * T) • y = y} = Nat.card (Roots N 1) := by
+    rw [← V_one]; exact card_fixed_eq N 1
+  refine h.trans ?_
+  unfold ModularCurve.nuThree
+  exact Nat.card_congr (Equiv.subtypeEquivRight fun x => by simp)
+
+end W7SF
+
+open scoped MatrixGroups in
+theorem solution (N : ℕ) [NeZero N] :
+    Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N // ModularGroup.S • x = x} =
+      ModularCurve.nuTwo N :=
+  W7SF.card_fixed_S N
+
+end S_ModularCurve_natCard_fixedPoints_S_cosets_Gamma0_eq_nuTwo
+end P2MW
+export P2MW.S_ModularCurve_natCard_fixedPoints_S_cosets_Gamma0_eq_nuTwo (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.natCard_fixedPoints_S_cosets_Gamma0_eq_nuTwo (N : ℕ) [NeZero N] :
+    Nat.card {x : SL(2, ℤ) ⧸ CongruenceSubgroup.Gamma0 N // ModularGroup.S • x = x} =
+      ModularCurve.nuTwo N :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_moduliPoint_j_eq_eq_natCard_quot_addOrderOf_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_moduliPoint_j_eq_eq_natCard_quot_addOrderOf_eq.lean
new file mode 100644
index 0000000000..6fc3782d83
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_moduliPoint_j_eq_eq_natCard_quot_addOrderOf_eq.lean
@@ -0,0 +1,305 @@
+/-
+Based on Prove2Me node ModularCurve.natCard_moduliPoint_j_eq_eq_natCard_quot_addOrderOf_eq
+(7025293f-be50-5f3e-ad11-6403910c4424) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 69f043e3-3953-58e1-9533-34522911c3af
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ModuliPoint
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_vcInvFun_add
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Fibre of Y₀(N) over j(W) as order-N points modulo Aut(W)
+
+Theorem statement: `ModularCurve.natCard_moduliPoint_j_eq_eq_natCard_quot_addOrderOf_eq`
+(`7025293f-be50-5f3e-ad11-6403910c4424`), by Claude, 2026-09-05.
+
+Proof: submission `69f043e3-3953-58e1-9533-34522911c3af`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, $L$ an algebraically closed field and $W$ a Weierstrass curve over $L$
+which is elliptic. Here `ModuliPoint N L` is the quotient `Quot` of the type `Gamma0Pair N L` of
+triples consisting of a Weierstrass curve over $L$, a proof that it is elliptic, and a point `gen`
+of its affine model whose additive order `addOrderOf` equals $N$, by the relation `Gamma0Pair.Step`
+that links $P$ to $Q$ when there are a Weierstrass variable change $\gamma$ over $L$ with $\gamma
+\bullet P.\mathrm{toCurve} = Q.\mathrm{toCurve}$ and a natural number $k$ coprime to $N$ such that
+$Q.\mathrm{gen}$ agrees (as a heterogeneous equality, the two types being identified by that curve
+equality) with $k \cdot
+\mathrm{vcInvFun}\,\gamma\,P.\mathrm{toCurve}.\mathrm{toAffine}\,P.\mathrm{gen}$, where `vcInvFun`
+is the map on affine points induced by $\gamma$, sending $0$ to $0$ and an affine point $(x,y)$ to
+$(u^{-1 2}(x-r),\, u^{-1 3}(y-t-s(x-r)))$. The assertion is an equality of cardinalities `Nat.card`:
+the number of elements $x$ of `ModuliPoint N L` with $\mathrm{ModuliPoint.j}\,x = W.j$ equals the
+number of elements of the quotient `Quot` of the type of points $T$ of the affine model of $W$ with
+$\mathrm{addOrderOf}\,T = N$ by the relation sending $T$ to $T'$ when there exist a variable change
+$\gamma$ with $\gamma \bullet W = W$ and a natural number $k$ coprime to $N$ with $T'$ equal
+(heterogeneously) to $k \cdot \mathrm{vcInvFun}\,\gamma\,W.\mathrm{toAffine}\,T$. In both cases the
+quotient is by the relation as given, not by a symmetrised version of it, and `Nat.card` takes the
+value $0$ on infinite types.
+
+This identifies the fibre of the coarse moduli set $Y_0(N)(L)$ over a fixed $j$-invariant $j(W)$
+with the set of points of exact order $N$ on $W$ modulo the action of the variable changes fixing
+$W$ (the automorphisms of $W$) together with multiplication by units modulo $N$. It is the first
+step of the count of elliptic points on $X_0(N)$, and is used downstream in the evaluation of this
+fibre in terms of the Dedekind $\psi$-function and in the comparison with places of the modular
+function field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_natCard_moduliPoint_j_eq_eq_natCard_quot_addOrderOf_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_ModularCurve_natCard_moduliPoint_j_eq_eq_natCard_quot_addOrderOf_eq
+
+open WeierstrassCurve WeierstrassCurve.Affine
+
+namespace P2MWs13
+namespace ModuliFibre
+
+variable {K : Type*} [Field K]
+
+theorem vcX_injective (C : VariableChange K) : Function.Injective (vcX C) := fun a b h => by
+  simpa using congrArg (vcXInv C) h
+
+theorem vcY_injective (C : VariableChange K) (x' : K) :
+    Function.Injective (vcY C x') := fun a b h => by
+  simpa using congrArg (vcYInv C (vcX C x')) h
+
+theorem vcX_mul (γ₁ γ₂ : VariableChange K) (x : K) :
+    vcX (γ₂ * γ₁) x = vcX γ₁ (vcX γ₂ x) := by
+  simp only [WeierstrassCurve.Affine.vcX, VariableChange.mul_def, Units.val_mul]
+  ring
+
+theorem vcY_mul (γ₁ γ₂ : VariableChange K) (x y : K) :
+    vcY (γ₂ * γ₁) x y = vcY γ₁ (vcX γ₂ x) (vcY γ₂ x y) := by
+  simp only [WeierstrassCurve.Affine.vcY, WeierstrassCurve.Affine.vcX,
+    VariableChange.mul_def, Units.val_mul]
+  ring
+
+theorem vcXInv_mul (γ₁ γ₂ : VariableChange K) (x : K) :
+    vcXInv (γ₂ * γ₁) x = vcXInv γ₂ (vcXInv γ₁ x) := by
+  refine vcX_injective (γ₂ * γ₁) ?_
+  rw [vcX_vcXInv, vcX_mul, vcX_vcXInv, vcX_vcXInv]
+
+theorem vcYInv_mul (γ₁ γ₂ : VariableChange K) (x y : K) :
+    vcYInv (γ₂ * γ₁) x y = vcYInv γ₂ (vcXInv γ₁ x) (vcYInv γ₁ x y) := by
+  refine vcY_injective (γ₂ * γ₁) (vcXInv (γ₂ * γ₁) x) ?_
+  rw [vcY_vcYInv, vcXInv_mul, vcY_mul, vcX_vcXInv, vcY_vcYInv, vcY_vcYInv]
+
+theorem vcXInv_one (x : K) : vcXInv (1 : VariableChange K) x = x := by
+  simp [WeierstrassCurve.Affine.vcXInv, VariableChange.one_def]
+
+theorem vcYInv_one (x y : K) : vcYInv (1 : VariableChange K) x y = y := by
+  simp [WeierstrassCurve.Affine.vcYInv, VariableChange.one_def]
+
+variable [DecidableEq K]
+
+omit [DecidableEq K] in
+theorem vcInvFun_some (γ : VariableChange K) (W : WeierstrassCurve.Affine K) {x y : K}
+    (h : W.Nonsingular x y) :
+    Point.vcInvFun γ W (Point.some x y h) = Point.some (vcXInv γ x) (vcYInv γ x y)
+      ((nonsingular_variableChange_iff (vcXInv γ x) (vcYInv γ x y)).mpr (by rwa [vcX_vcXInv,
+        vcY_vcYInv])) := rfl
+
+omit [DecidableEq K] in
+theorem Point.heq_vcInvFun (γ : VariableChange K) {V V' : WeierstrassCurve.Affine K}
+    (hV : V' = V) {S : V'.Point} {T : V.Point} (h : HEq S T) :
+    HEq (Point.vcInvFun γ V' S) (Point.vcInvFun γ V T) := by
+  subst hV
+  rw [eq_of_heq h]
+
+noncomputable def vcInvHom (γ : VariableChange K) (W : WeierstrassCurve.Affine K) :
+    W.Point →+ (γ • W).toAffine.Point :=
+  AddMonoidHom.mk' (Point.vcInvFun γ W) (WeierstrassCurve.Affine.Point.vcInvFun_add γ W)
+
+omit [DecidableEq K] in
+theorem vcInvFun_injective (γ : VariableChange K) (W : WeierstrassCurve.Affine K) :
+    Function.Injective (Point.vcInvFun γ W) :=
+  (Point.vcFun_rightInverse (C := γ) (W := W)).injective
+
+theorem addOrderOf_vcInvFun (γ : VariableChange K) (W : WeierstrassCurve.Affine K) (P : W.Point) :
+    addOrderOf (Point.vcInvFun γ W P) = addOrderOf P :=
+  addOrderOf_injective (vcInvHom γ W) (vcInvFun_injective γ W) P
+
+theorem vcInvFun_nsmul (γ : VariableChange K) (W : WeierstrassCurve.Affine K) (k : ℕ) (P : W.Point)
+    :
+    Point.vcInvFun γ W (k • P) = k • Point.vcInvFun γ W P :=
+  map_nsmul (vcInvHom γ W) k P
+
+omit [DecidableEq K] in
+theorem vcInvFun_mul_heq (γ₁ γ₂ : VariableChange K) (W : WeierstrassCurve.Affine K) (P : W.Point) :
+    HEq (Point.vcInvFun (γ₂ * γ₁) W P)
+      (Point.vcInvFun γ₂ ((γ₁ • W : WeierstrassCurve K).toAffine) (Point.vcInvFun γ₁ W P)) := by
+  rcases P with _ | ⟨x, y, h⟩
+  · exact ModularCurve.Point.heq_zero (mul_smul γ₂ γ₁ W)
+  · simp only [vcInvFun_some]
+    exact ModularCurve.Point.heq_some (mul_smul γ₂ γ₁ W) (vcXInv_mul γ₁ γ₂ x) (vcYInv_mul γ₁ γ₂ x y)
+
+omit [DecidableEq K] in
+theorem vcInvFun_inv_heq (γ : VariableChange K) (W : WeierstrassCurve.Affine K) (P : W.Point) :
+    HEq (Point.vcInvFun γ⁻¹ ((γ • W : WeierstrassCurve K).toAffine) (Point.vcInvFun γ W P)) P := by
+  rcases P with _ | ⟨x, y, h⟩
+  · exact ModularCurve.Point.heq_zero (inv_smul_smul γ W)
+  · simp only [vcInvFun_some]
+    refine ModularCurve.Point.heq_some (inv_smul_smul γ W) ?_ ?_
+    · rw [← vcXInv_mul, inv_mul_cancel, vcXInv_one]
+    · rw [← vcYInv_mul, inv_mul_cancel, vcYInv_one]
+
+omit [DecidableEq K] in
+theorem vcInvFun_one_heq (W : WeierstrassCurve.Affine K) (P : W.Point) :
+    HEq (Point.vcInvFun (1 : VariableChange K) W P) P := by
+  rcases P with _ | ⟨x, y, h⟩
+  · exact ModularCurve.Point.heq_zero (one_smul _ W)
+  · simp only [vcInvFun_some]
+    exact ModularCurve.Point.heq_some (one_smul _ W) (vcXInv_one x) (vcYInv_one x y)
+
+omit [DecidableEq K] in
+theorem exists_nsmul_nsmul_eq_self {M : Type*} [AddCommGroup M] {N k : ℕ}
+    (hk : k.Coprime N) {x : M} (hx : addOrderOf x = N) :
+    ∃ m : ℕ, m.Coprime N ∧ m • k • x = x := by
+  rcases Nat.eq_zero_or_pos N with hN0 | hNpos
+  · subst hN0
+    have hk1 : k = 1 := Nat.coprime_zero_right k |>.mp hk
+    exact ⟨1, Nat.coprime_one_left 0, by rw [hk1, one_nsmul, one_nsmul]⟩
+  by_cases hN1 : N = 1
+  · have hx0 : x = 0 := by
+      have h1 : addOrderOf x = 1 := by rw [hx, hN1]
+      exact AddMonoid.addOrderOf_eq_one_iff.mp h1
+    exact ⟨1, Nat.coprime_one_left N, by rw [hx0, smul_zero, smul_zero]⟩
+  · have h1N : 1 < N := by omega
+    obtain ⟨m, -, hm⟩ := Nat.exists_mul_mod_eq_one_of_coprime hk h1N
+    have hNx : N • x = 0 := by rw [← hx]; exact addOrderOf_nsmul_eq_zero x
+    have hdiv : N * (k * m / N) + 1 = k * m := by
+      have h := Nat.div_add_mod (k * m) N
+      rw [hm] at h
+      exact h
+    refine ⟨m, ?_, ?_⟩
+    · have hdm : Nat.gcd m N ∣ N * (k * m / N) + 1 := by
+        rw [hdiv]
+        exact Dvd.dvd.mul_left (Nat.gcd_dvd_left m N) k
+      have hdN : Nat.gcd m N ∣ N * (k * m / N) :=
+        Dvd.dvd.mul_right (Nat.gcd_dvd_right m N) _
+      exact Nat.dvd_one.mp ((Nat.dvd_add_right hdN).mp hdm)
+    · rw [← mul_nsmul x k m, ← hdiv, add_nsmul, mul_nsmul x N (k * m / N), hNx, smul_zero,
+        zero_add, one_nsmul]
+
+open ModularCurve
+
+variable {N : ℕ}
+
+theorem step_refl (P : Gamma0Pair N K) : Gamma0Pair.Step P P :=
+  ⟨1, one_smul _ _, 1, Nat.coprime_one_left N,
+    ((heq_of_eq (one_nsmul _)).trans (vcInvFun_one_heq P.toCurve.toAffine P.gen)).symm⟩
+
+theorem step_symm {P Q : Gamma0Pair N K} (h : Gamma0Pair.Step P Q) : Gamma0Pair.Step Q P := by
+  obtain ⟨γ, hγ, k, hk, hgen⟩ := h
+  obtain ⟨QC, Qell, Qgen, Qord⟩ := Q
+  subst hγ
+  have hg : Qgen = k • Point.vcInvFun γ P.toCurve.toAffine P.gen := eq_of_heq hgen
+  obtain ⟨m, hm, hmx⟩ := exists_nsmul_nsmul_eq_self hk P.addOrderOf_gen
+  refine ⟨γ⁻¹, inv_smul_smul γ P.toCurve, m, hm, ?_⟩
+  change HEq P.gen (m • Point.vcInvFun γ⁻¹ (γ • P.toCurve).toAffine Qgen)
+  rw [hg, vcInvFun_nsmul]
+  refine (heq_of_eq hmx.symm).trans ?_
+  exact ModularCurve.Point.heq_nsmul (inv_smul_smul γ P.toCurve).symm m
+    (ModularCurve.Point.heq_nsmul (inv_smul_smul γ P.toCurve).symm k
+      (vcInvFun_inv_heq γ P.toCurve.toAffine P.gen).symm)
+
+theorem step_trans {P Q R : Gamma0Pair N K} (hPQ : Gamma0Pair.Step P Q)
+    (hQR : Gamma0Pair.Step Q R) : Gamma0Pair.Step P R := by
+  obtain ⟨γ₁, hγ₁, k₁, hk₁, hgen₁⟩ := hPQ
+  obtain ⟨γ₂, hγ₂, k₂, hk₂, hgen₂⟩ := hQR
+  refine ⟨γ₂ * γ₁, by rw [mul_smul, hγ₁, hγ₂], k₂ * k₁,
+    Nat.coprime_mul_iff_left.mpr ⟨hk₂, hk₁⟩, ?_⟩
+  have hVQ : (γ₂ • Q.toCurve : WeierstrassCurve K) = γ₂ • (γ₁ • P.toCurve) := by rw [hγ₁]
+  have hV2 : (γ₂ • (γ₁ • P.toCurve) : WeierstrassCurve K) = (γ₂ * γ₁) • P.toCurve :=
+    (mul_smul γ₂ γ₁ P.toCurve).symm
+  refine hgen₂.trans ?_
+  refine HEq.trans (ModularCurve.Point.heq_nsmul hVQ k₂
+    ((Point.heq_vcInvFun γ₂ hγ₁.symm hgen₁).trans
+      (heq_of_eq (vcInvFun_nsmul γ₂ _ k₁ _)))) ?_
+  exact (heq_of_eq (smul_smul k₂ k₁ _)).trans
+    (ModularCurve.Point.heq_nsmul hV2 (k₂ * k₁) (vcInvFun_mul_heq γ₁ γ₂ P.toCurve.toAffine
+      P.gen).symm)
+
+theorem stepEquivalence : Equivalence (Gamma0Pair.Step (N := N) (L := K)) :=
+  ⟨step_refl, step_symm, step_trans⟩
+
+theorem mk_eq_mk_iff_step {P Q : Gamma0Pair N K} :
+    (Quot.mk _ P : ModuliPoint N K) = Quot.mk _ Q ↔ Gamma0Pair.Step P Q :=
+  Quot.eq.trans (stepEquivalence (N := N) (K := K)).eqvGen_iff
+
+end P2MWs13.ModuliFibre
+
+open P2MWs13.ModuliFibre ModularCurve in
+theorem solution
+    (N : ℕ) (L : Type*) [Field L] [DecidableEq L] [IsAlgClosed L]
+    (W : WeierstrassCurve L) [W.IsElliptic] :
+    Nat.card {x : ModuliPoint N L // ModuliPoint.j x = W.j}
+      = Nat.card (Quot (fun (T T' : {T : W.toAffine.Point // addOrderOf T = N}) =>
+          ∃ γ : VariableChange L, ∃ _ : γ • W = W, ∃ k : ℕ, k.Coprime N ∧
+            HEq T'.1 (k • Point.vcInvFun γ W.toAffine T.1))) := by
+  let mkP : {T : W.toAffine.Point // addOrderOf T = N} → Gamma0Pair N L :=
+    fun T => ⟨W, inferInstance, T.1, T.2⟩
+  have hR : ∀ T T' : {T : W.toAffine.Point // addOrderOf T = N},
+      (∃ γ : VariableChange L, ∃ _ : γ • W = W, ∃ k : ℕ, k.Coprime N ∧
+        HEq T'.1 (k • Point.vcInvFun γ W.toAffine T.1)) ↔ Gamma0Pair.Step (mkP T) (mkP T') :=
+    fun T T' => Iff.rfl
+  let f : Quot (fun (T T' : {T : W.toAffine.Point // addOrderOf T = N}) =>
+          ∃ γ : VariableChange L, ∃ _ : γ • W = W, ∃ k : ℕ, k.Coprime N ∧
+            HEq T'.1 (k • Point.vcInvFun γ W.toAffine T.1)) → {x : ModuliPoint N L // ModuliPoint.j
+              x = W.j} :=
+    Quot.lift (fun T => ⟨Quot.mk _ (mkP T), rfl⟩)
+      (fun T T' h => Subtype.ext (Quot.sound ((hR T T').mp h)))
+  refine (Nat.card_congr (Equiv.ofBijective f ⟨?_, ?_⟩)).symm
+  · intro a b
+    induction a using Quot.ind with | _ T => ?_
+    induction b using Quot.ind with | _ T' => ?_
+    intro hab
+    have h1 : (Quot.mk _ (mkP T) : ModuliPoint N L) = Quot.mk _ (mkP T') := congrArg Subtype.val hab
+    exact Quot.sound ((hR T T').mpr (mk_eq_mk_iff_step.mp h1))
+  · rintro ⟨x, hx⟩
+    induction x using Quot.ind with | _ P => ?_
+    obtain ⟨E, hE, gen, hord⟩ := P
+    have hj : E.j = W.j := hx
+    obtain ⟨γ, hγ⟩ := WeierstrassCurve.exists_variableChange_of_j_eq E W hj
+    subst hγ
+    let T : (γ • E).toAffine.Point := Point.vcInvFun γ E.toAffine gen
+    have hT : addOrderOf T = N := by rw [addOrderOf_vcInvFun]; exact hord
+    refine ⟨Quot.mk _ ⟨T, hT⟩, Subtype.ext ?_⟩
+    change (Quot.mk _ (mkP ⟨T, hT⟩) : ModuliPoint N L) = Quot.mk _ ⟨E, hE, gen, hord⟩
+    refine (Quot.sound (?_ : Gamma0Pair.Step ⟨E, hE, gen, hord⟩ (mkP ⟨T, hT⟩))).symm
+    exact ⟨γ, rfl, 1, Nat.coprime_one_left N, heq_of_eq (one_nsmul _).symm⟩
+
+end S_ModularCurve_natCard_moduliPoint_j_eq_eq_natCard_quot_addOrderOf_eq
+end P2MW
+export P2MW.S_ModularCurve_natCard_moduliPoint_j_eq_eq_natCard_quot_addOrderOf_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve WeierstrassCurve WeierstrassCurve.Affine
+theorem ModularCurve.natCard_moduliPoint_j_eq_eq_natCard_quot_addOrderOf_eq
+    (N : ℕ) (L : Type*) [Field L] [DecidableEq L] [IsAlgClosed L]
+    (W : WeierstrassCurve L) [W.IsElliptic] :
+    Nat.card {x : ModuliPoint N L // ModuliPoint.j x = W.j}
+      = Nat.card (Quot (fun (T T' : {T : W.toAffine.Point // addOrderOf T = N}) =>
+          ∃ γ : VariableChange L, ∃ _ : γ • W = W, ∃ k : ℕ, k.Coprime N ∧
+            HEq T'.1 (k • Point.vcInvFun γ W.toAffine T.1))) :=
+  solution N L W
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_normalized_algHom_hahnSeries_jBar_sub_eq_toNat_ord.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_normalized_algHom_hahnSeries_jBar_sub_eq_toNat_ord.lean
new file mode 100644
index 0000000000..f52d3ac523
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_normalized_algHom_hahnSeries_jBar_sub_eq_toNat_ord.lean
@@ -0,0 +1,638 @@
+/-
+Based on Prove2Me node ModularCurve.natCard_normalized_algHom_hahnSeries_jBar_sub_eq_toNat_ord
+(8587e1e1-f8b9-5fed-a3fd-a5ba9f328005) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7a928fd8-cc65-5982-a965-80e53ba62096
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_RamificationBound
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_MazurStepThreeInputs
+
+import Mathlib.RingTheory.Polynomial.Cyclotomic.Roots
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Normalised Hahn-series embeddings inducing a place above j₀
+
+Theorem statement: `ModularCurve.natCard_normalized_algHom_hahnSeries_jBar_sub_eq_toNat_ord`
+(`8587e1e1-f8b9-5fed-a3fd-a5ba9f328005`), by Claude, 2026-09-05.
+
+Proof: submission `7a928fd8-cc65-5982-a965-80e53ba62096`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and $j_0$ an element of $\overline{\mathbb{Q}}$. Write $F_N =
+\mathtt{modularFunctionFieldBar } N$ for the subfield of
+$\operatorname{LaurentSeries}(\overline{\mathbb{Q}})$ generated over $\overline{\mathbb{Q}}$ by the
+coefficientwise images of the field $\mathbb{Q}(\mathtt{divisorExpansions } N) \subseteq
+\operatorname{LaurentSeries}(\mathbb{Q})$, and let $\bar j = \mathtt{jBar } N \in F_N$ be the image
+of the $q$-expansion $j(q)$. A place of $F_N$ over $\overline{\mathbb{Q}}$ is a valuation subring
+containing $\overline{\mathbb{Q}}$, different from $F_N$ and a principal ideal ring, with
+$v.\mathtt{ord}$ the associated normalised integer valuation. Assume: $F_N$ is finite dimensional
+over $\overline{\mathbb{Q}}(\bar j)$; $S$ is a finite set of places consisting exactly of those $v$
+with $v.\mathtt{ord}(\bar j - j_0) > 0$; the orders $v.\mathtt{ord}(\bar j - j_0)$ for $v \in S$ sum
+to $[F_N : \overline{\mathbb{Q}}(\bar j)]$; and every place $w$ with $e_w := w.\mathtt{ord}(\bar j -
+j_0) > 0$ is realised by a $\overline{\mathbb{Q}}$-algebra map $\varphi' : F_N \to
+\operatorname{LaurentSeries}(\overline{\mathbb{Q}})$ sending $\bar j - j_0$ to the monomial
+$t^{e_w}$ and satisfying $\operatorname{order}(\varphi' x) = w.\mathtt{ord}(x)$ for all $x$.
+Conclusion: for each such $w$, the number of $\overline{\mathbb{Q}}$-algebra maps $\psi$ from $F_N$
+to the Hahn series over $\overline{\mathbb{Q}}$ with exponents in $\mathbb{Q}$ with $\psi(\bar j) =
+j_0 + t$ and such that for some rational $g > 0$ one has $\operatorname{order}(\psi x) = g \cdot
+w.\mathtt{ord}(x)$ for all $x$, equals $e_w$.
+
+This counts, place by place, the normalised fractional-exponent expansions of the modular function
+field lying over a given value $j_0$ of the $j$-line, the ramification index at a place being
+exactly the order of vanishing of $\bar j - j_0$ there. It is an input to
+[`ModularCurve.natCard_normalized_algHom_jBar_eq_toNat_ord`]
+(thm.html#ModularCurve.natCard_normalized_algHom_jBar_eq_toNat_ord)
+in the analysis of the fibres of the map to the $j$-line.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_natCard_normalized_algHom_hahnSeries_jBar_sub_eq_toNat_ord.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_natCard_normalized_algHom_hahnSeries_jBar_sub_eq_toNat_ord
+
+noncomputable section
+
+namespace B2Peo
+
+open AlgebraicCurve ModularCurve Polynomial Place
+
+section Engine
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+
+
+private theorem place_eq_of_mul_eq_order {ψ : F →ₐ[K] HahnSeries ℚ K} {w w' : Place K F}
+    {g g' : ℚ} (hg : 0 < g) (hg' : 0 < g')
+    (hord : ∀ x : F, (w.ord x : ℚ) * g = (ψ x).order)
+    (hord' : ∀ x : F, (w'.ord x : ℚ) * g' = (ψ x).order) : w = w' := by
+  have key : ∀ f : F, 0 ≤ w.ord f → 0 ≤ w'.ord f := by
+    intro f h
+    by_contra hneg
+    have hneg' : w'.ord f < 0 := lt_of_not_ge hneg
+    have hlt : ((w'.ord f : ℚ)) * g' < 0 :=
+      mul_neg_of_neg_of_pos (by exact_mod_cast hneg') hg'
+    rw [hord' f, ← hord f] at hlt
+    exact absurd hlt (not_lt.mpr (mul_nonneg (by exact_mod_cast h) hg.le))
+  have key' : ∀ f : F, 0 ≤ w'.ord f → 0 ≤ w.ord f := by
+    intro f h
+    by_contra hneg
+    have hneg' : w.ord f < 0 := lt_of_not_ge hneg
+    have hlt : ((w.ord f : ℚ)) * g < 0 :=
+      mul_neg_of_neg_of_pos (by exact_mod_cast hneg') hg
+    rw [hord f, ← hord' f] at hlt
+    exact absurd hlt (not_lt.mpr (mul_nonneg (by exact_mod_cast h) hg'.le))
+  refine Place.ext (SetLike.ext fun f => ?_)
+  rcases eq_or_ne f 0 with rfl | hf
+  · exact iff_of_true (zero_mem _) (zero_mem _)
+  · exact ⟨fun hmem => mem_of_ord_nonneg w' hf (key f (ord_nonneg_of_mem w hmem)),
+      fun hmem => mem_of_ord_nonneg w hf (key' f (ord_nonneg_of_mem w' hmem))⟩
+
+private theorem algebraMap_laurent_eq_C (r : K) :
+    algebraMap K (LaurentSeries K) r = HahnSeries.C r := by
+  rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_eq, HahnSeries.ofPowerSeries_C]
+
+private theorem algebraMap_hahn_eq_C (r : K) :
+    algebraMap K (HahnSeries ℚ K) r = HahnSeries.C r := by
+  rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_eq, HahnSeries.ofPowerSeries_C]
+
+private def puiseuxAlgEmb {e : ℕ} (he : 0 < e) : LaurentSeries K →ₐ[K] HahnSeries ℚ K where
+  toRingHom := HahnSeries.puiseuxRamEmb he
+  commutes' r := by
+    change HahnSeries.puiseuxRamEmb he (algebraMap K (LaurentSeries K) r) =
+      algebraMap K (HahnSeries ℚ K) r
+    rw [algebraMap_laurent_eq_C, algebraMap_hahn_eq_C, HahnSeries.C_apply, HahnSeries.C_apply]
+    have hsing : HahnSeries.puiseuxRamEmb (K := K) he (HahnSeries.single (0 : ℤ) r) =
+        HahnSeries.single (HahnSeries.ramScale e (0 : ℤ)) r := HahnSeries.embDomain_single
+    rw [hsing]
+    norm_num
+
+private def qTwistAlg (u : Kˣ) : LaurentSeries K →ₐ[K] LaurentSeries K where
+  toRingHom := qTwist u
+  commutes' r := by
+    change qTwist u (algebraMap K (LaurentSeries K) r) = algebraMap K (LaurentSeries K) r
+    rw [algebraMap_laurent_eq_C, HahnSeries.C_apply, qTwist_single]
+    norm_num
+
+private theorem puiseuxAlgEmb_coeff {e : ℕ} (he : 0 < e) (z : LaurentSeries K) (k : ℤ) :
+    (puiseuxAlgEmb (K := K) he z).coeff (HahnSeries.ramScale e k) = z.coeff k :=
+  HahnSeries.embDomain_coeff
+
+private theorem puiseuxAlgEmb_ne_zero {e : ℕ} (he : 0 < e) {z : LaurentSeries K}
+    (hz : z ≠ 0) : puiseuxAlgEmb (K := K) he z ≠ 0 := by
+  intro h0
+  exact hz ((map_eq_zero_iff _ (puiseuxAlgEmb (K := K) he).toRingHom.injective).mp h0)
+
+private theorem qTwist_ne_zero (u : Kˣ) {z : LaurentSeries K} (hz : z ≠ 0) :
+    qTwist u z ≠ 0 := by
+  intro h0
+  exact hz (qTwist_injective u (by rw [h0, map_zero]))
+
+private theorem order_qTwist (u : Kˣ) (z : LaurentSeries K) :
+    (qTwist u z).order = z.order := by
+  rcases eq_or_ne z 0 with rfl | hz
+  · rw [map_zero]
+  · have hqz : qTwist u z ≠ 0 := qTwist_ne_zero u hz
+    apply le_antisymm
+    · apply HahnSeries.order_le_of_coeff_ne_zero
+      rw [qTwist_coeff]
+      exact mul_ne_zero (Units.ne_zero _) (HahnSeries.coeff_order_eq_zero.not.mpr hz)
+    · apply HahnSeries.order_le_of_coeff_ne_zero
+      have h := HahnSeries.coeff_order_eq_zero.not.mpr hqz
+      rw [qTwist_coeff] at h
+      exact (mul_ne_zero_iff.mp h).2
+
+private theorem order_puiseuxAlgEmb {e : ℕ} (he : 0 < e) {z : LaurentSeries K} (hz : z ≠ 0) :
+    (puiseuxAlgEmb (K := K) he z).order = (z.order : ℚ) / e := by
+  have hpz : puiseuxAlgEmb (K := K) he z ≠ 0 := puiseuxAlgEmb_ne_zero he hz
+  have he' : (0 : ℚ) < e := by exact_mod_cast he
+  apply le_antisymm
+  · have hco : (puiseuxAlgEmb (K := K) he z).coeff (HahnSeries.ramScale e z.order) ≠ 0 := by
+      rw [puiseuxAlgEmb_coeff]
+      exact HahnSeries.coeff_order_eq_zero.not.mpr hz
+    have h := HahnSeries.order_le_of_coeff_ne_zero hco
+    rwa [HahnSeries.ramScale_apply] at h
+  · have hne := HahnSeries.coeff_order_eq_zero.not.mpr hpz
+    by_cases hmem : (puiseuxAlgEmb (K := K) he z).order ∈ Set.range (HahnSeries.ramScale e)
+    · obtain ⟨k, hk⟩ := hmem
+      have hco : z.coeff k ≠ 0 := by
+        rw [← puiseuxAlgEmb_coeff he z k, hk]
+        exact hne
+      have hle : z.order ≤ k := HahnSeries.order_le_of_coeff_ne_zero hco
+      rw [← hk, HahnSeries.ramScale_apply]
+      exact (div_le_div_iff_of_pos_right he').mpr (by exact_mod_cast hle)
+    · exfalso
+      apply hne
+      apply HahnSeries.embDomain_of_notMem_range
+      intro hcon
+      apply hmem
+      obtain ⟨k, hk⟩ := hcon
+      exact ⟨k, hk⟩
+
+section Lower
+
+
+private theorem exists_ord_eq_one (w : Place K F) : ∃ π : F, w.ord π = 1 := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  exact ⟨π, w.ord_coe_irreducible hπ⟩
+
+private theorem normEmb_spec {e : ℕ} (he : 0 < e) (u : Kˣ) (hue : u ^ e = 1)
+    (t : F) (c : K) (w : Place K F)
+    (φ' : F →ₐ[K] LaurentSeries K)
+    (hφf : φ' (t - algebraMap K F c) = HahnSeries.single ((e : ℕ) : ℤ) 1)
+    (hφord : ∀ x : F, (φ' x).order = w.ord x) :
+    ((puiseuxAlgEmb he).comp ((qTwistAlg u).comp φ')) t =
+        HahnSeries.C c + HahnSeries.single (1 : ℚ) 1 ∧
+      ∃ g : ℚ, 0 < g ∧ ∀ x,
+        (w.ord x : ℚ) * g = ((((puiseuxAlgEmb he).comp ((qTwistAlg u).comp φ'))) x).order := by
+  have he' : ((e : ℚ)) ≠ 0 := by
+    exact_mod_cast he.ne'
+  constructor
+  · have ht : t = (t - algebraMap K F c) + algebraMap K F c := by ring
+    rw [ht, map_add, AlgHom.commutes]
+    have hmain : ((puiseuxAlgEmb he).comp ((qTwistAlg u).comp φ')) (t - algebraMap K F c) =
+        HahnSeries.single (1 : ℚ) 1 := by
+      rw [AlgHom.comp_apply, AlgHom.comp_apply, hφf]
+      have hq : qTwistAlg (K := K) u (HahnSeries.single ((e : ℕ) : ℤ) 1) =
+          HahnSeries.single ((e : ℕ) : ℤ) 1 := by
+        change qTwist u (HahnSeries.single ((e : ℕ) : ℤ) 1) = HahnSeries.single ((e : ℕ) : ℤ) 1
+        rw [qTwist_single]
+        congr 1
+        rw [mul_one]
+        have : u ^ ((e : ℕ) : ℤ) = 1 := by
+          rw [zpow_natCast, hue]
+        rw [this, Units.val_one]
+      rw [hq]
+      have hsing : puiseuxAlgEmb (K := K) he (HahnSeries.single ((e : ℕ) : ℤ) 1) =
+          HahnSeries.single (HahnSeries.ramScale e ((e : ℕ) : ℤ)) 1 :=
+        HahnSeries.embDomain_single
+      have hdiv : ((((e : ℕ) : ℤ) : ℚ)) / (e : ℚ) = 1 := by
+        push_cast
+        exact div_self he'
+      rw [hsing, HahnSeries.ramScale_apply, hdiv]
+    rw [hmain, algebraMap_hahn_eq_C]
+    exact add_comm _ _
+  · refine ⟨(e : ℚ)⁻¹, by positivity, fun x => ?_⟩
+    rcases eq_or_ne x 0 with rfl | hx
+    · simp [HahnSeries.order_zero]
+    · have hφx : φ' x ≠ 0 := by
+        intro h0
+        exact hx ((map_eq_zero_iff _ φ'.toRingHom.injective).mp h0)
+      have hqx : qTwist u (φ' x) ≠ 0 := qTwist_ne_zero u hφx
+      rw [AlgHom.comp_apply, AlgHom.comp_apply,
+        show qTwistAlg (K := K) u (φ' x) = qTwist u (φ' x) from rfl,
+        order_puiseuxAlgEmb he hqx, order_qTwist, hφord, div_eq_mul_inv]
+
+private theorem normEmb_coeff_at {e : ℕ} (he : 0 < e) (u : Kˣ)
+    (φ' : F →ₐ[K] LaurentSeries K) (π : F) :
+    (((puiseuxAlgEmb he).comp ((qTwistAlg u).comp φ')) π).coeff
+        (HahnSeries.ramScale e 1) = (u : K) * (φ' π).coeff 1 := by
+  rw [AlgHom.comp_apply, AlgHom.comp_apply,
+    show qTwistAlg (K := K) u (φ' π) = qTwist u (φ' π) from rfl,
+    puiseuxAlgEmb_coeff, qTwist_coeff, zpow_one]
+
+private theorem coeff_one_ne_zero_of_ord_one (φ' : F →ₐ[K] LaurentSeries K) (w : Place K F)
+    (hφord : ∀ x : F, (φ' x).order = w.ord x) {π : F} (hπ : w.ord π = 1) :
+    (φ' π).coeff 1 ≠ 0 := by
+  have hπ0 : π ≠ 0 := by
+    intro h0
+    rw [h0, Place.ord_zero] at hπ
+    exact one_ne_zero hπ.symm
+  have hφπ : φ' π ≠ 0 := by
+    intro h0
+    exact hπ0 ((map_eq_zero_iff _ φ'.toRingHom.injective).mp h0)
+  have hord : (φ' π).order = 1 := by rw [hφord, hπ]
+  have := HahnSeries.coeff_order_eq_zero.not.mpr hφπ
+  rwa [hord] at this
+
+end Lower
+
+section Upper
+
+variable [CharZero K]
+
+private theorem finite_allNorm_and_card_le (t : F) (c : K)
+    [FiniteDimensional ↥(IntermediateField.adjoin K ({t} : Set F)) F] :
+    Finite {ψ : F →ₐ[K] HahnSeries ℚ K //
+        ψ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1} ∧
+      Nat.card {ψ : F →ₐ[K] HahnSeries ℚ K //
+        ψ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1} ≤
+      Module.finrank ↥(IntermediateField.adjoin K ({t} : Set F)) F := by
+  classical
+  rcases isEmpty_or_nonempty {ψ : F →ₐ[K] HahnSeries ℚ K //
+      ψ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1} with hE | hNE
+  · have : Fintype {ψ : F →ₐ[K] HahnSeries ℚ K //
+        ψ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1} := ⟨∅, fun a => (hE.elim a)⟩
+    exact ⟨Finite.of_fintype _, by rw [Nat.card_of_isEmpty]; exact Nat.zero_le _⟩
+  obtain ⟨⟨ψ₀, hψ₀⟩⟩ := hNE
+  set B := IntermediateField.adjoin K ({t} : Set F) with hB
+  have : CharZero ↥B := charZero_of_injective_algebraMap (algebraMap K ↥B).injective
+  obtain ⟨θ, hθ⟩ := Field.exists_primitive_element ↥B F
+  have hint : IsIntegral ↥B θ := IsIntegral.of_finite ↥B θ
+  have hagree : ∀ ψ : F →ₐ[K] HahnSeries ℚ K,
+      ψ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1 → ∀ x ∈ B, ψ x = ψ₀ x := by
+    intro ψ hψ
+    have hsub : B ≤
+        { AlgHom.equalizer ψ ψ₀ with
+          inv_mem' := by
+            intro y hy
+            have h : ψ y = ψ₀ y := hy
+            change ψ y⁻¹ = ψ₀ y⁻¹
+            rw [map_inv₀, map_inv₀, h] } := by
+      rw [hB, IntermediateField.adjoin_le_iff]
+      intro z hz
+      rw [Set.mem_singleton_iff] at hz
+      rw [hz]
+      change ψ t = ψ₀ t
+      rw [hψ, hψ₀]
+    exact fun x hx => hsub hx
+  set βr : ↥B →+* HahnSeries ℚ K := ψ₀.toRingHom.comp (algebraMap ↥B F) with hβrdef
+  have hβr : ∀ ψ : F →ₐ[K] HahnSeries ℚ K,
+      ψ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1 →
+      (ψ.toRingHom.comp (algebraMap ↥B F)) = βr := by
+    intro ψ hψ
+    refine RingHom.ext fun b => ?_
+    change ψ (algebraMap ↥B F b) = ψ₀ (algebraMap ↥B F b)
+    exact hagree ψ hψ (algebraMap ↥B F b) (by simp)
+  set mp : Polynomial ↥B := minpoly ↥B θ with hmp
+  have hmonic : mp.Monic := minpoly.monic hint
+  have hne0 : mp.map βr ≠ 0 := (hmonic.map βr).ne_zero
+  have hroot : ∀ ψ : F →ₐ[K] HahnSeries ℚ K,
+      ψ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1 →
+      (ψ θ) ∈ (mp.map βr).roots.toFinset := by
+    intro ψ hψ
+    rw [Multiset.mem_toFinset, Polynomial.mem_roots hne0]
+    have h1 : Polynomial.eval₂ (ψ.toRingHom.comp (algebraMap ↥B F)) (ψ θ) mp = 0 := by
+      have hcomm : (ψ (Polynomial.eval₂ (algebraMap ↥B F) θ mp) : HahnSeries ℚ K) =
+          Polynomial.eval₂ (ψ.toRingHom.comp (algebraMap ↥B F)) (ψ θ) mp :=
+        Polynomial.hom_eval₂ mp (algebraMap ↥B F) ψ.toRingHom θ
+      rw [← hcomm, ← Polynomial.aeval_def, minpoly.aeval, map_zero]
+    change (mp.map βr).IsRoot (ψ θ)
+    rw [Polynomial.IsRoot, Polynomial.eval_map, ← hβr ψ hψ]
+    exact h1
+  have hinj : ∀ ψ₁ ψ₂ : F →ₐ[K] HahnSeries ℚ K,
+      ψ₁ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1 →
+      ψ₂ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1 →
+      ψ₁ θ = ψ₂ θ → ψ₁ = ψ₂ := by
+    intro ψ₁ ψ₂ h₁ h₂ hθeq
+    let : Algebra ↥B (HahnSeries ℚ K) := βr.toAlgebra
+    let ψ₁' : F →ₐ[↥B] HahnSeries ℚ K :=
+      { toRingHom := ψ₁.toRingHom,
+        commutes' := fun b => RingHom.congr_fun (hβr ψ₁ h₁) b }
+    let ψ₂' : F →ₐ[↥B] HahnSeries ℚ K :=
+      { toRingHom := ψ₂.toRingHom,
+        commutes' := fun b => RingHom.congr_fun (hβr ψ₂ h₂) b }
+    have hθ' : θ ∈ AlgHom.equalizer ψ₁' ψ₂' := hθeq
+    have hadj : Algebra.adjoin ↥B ({θ} : Set F) = ⊤ := by
+      have h1 := IntermediateField.adjoin_simple_toSubalgebra_of_isAlgebraic hint.isAlgebraic
+      rw [hθ] at h1
+      exact h1.symm.trans IntermediateField.top_toSubalgebra
+    have htop : (⊤ : Subalgebra ↥B F) ≤ AlgHom.equalizer ψ₁' ψ₂' := by
+      rw [← hadj]
+      exact Algebra.adjoin_le (Set.singleton_subset_iff.mpr hθ')
+    refine AlgHom.ext fun x => ?_
+    exact htop (Algebra.mem_top)
+  have hinjF : Function.Injective
+      (fun ψp : {ψ : F →ₐ[K] HahnSeries ℚ K //
+          ψ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1} =>
+        (⟨ψp.1 θ, hroot ψp.1 ψp.2⟩ :
+          {y : HahnSeries ℚ K // y ∈ (mp.map βr).roots.toFinset})) := by
+    intro a b hab
+    have h : a.1 θ = b.1 θ := by
+      have := congrArg Subtype.val hab
+      simpa using this
+    exact Subtype.ext (hinj a.1 b.1 a.2 b.2 h)
+  refine ⟨Finite.of_injective _ hinjF, ?_⟩
+  have hcard := Nat.card_le_card_of_injective _ hinjF
+  refine hcard.trans ?_
+  have h1 : Nat.card {y : HahnSeries ℚ K // y ∈ (mp.map βr).roots.toFinset} =
+      ((mp.map βr).roots.toFinset).card := by
+    rw [Nat.card_eq_fintype_card, Fintype.card_coe]
+  rw [h1]
+  have h2 : ((mp.map βr).roots.toFinset).card ≤ (mp.map βr).roots.card :=
+    Multiset.toFinset_card_le _
+  have h3 : (mp.map βr).roots.card ≤ (mp.map βr).natDegree := Polynomial.card_roots' _
+  have h4 : (mp.map βr).natDegree = mp.natDegree := hmonic.natDegree_map βr
+  have h5 : mp.natDegree = Module.finrank ↥B F := by
+    rw [hmp, ← IntermediateField.adjoin.finrank hint, hθ]
+    exact LinearEquiv.finrank_eq IntermediateField.topEquiv.toLinearEquiv
+  omega
+
+end Upper
+
+end Engine
+
+theorem natCard_normalized_algHom_eq_toNat_ord
+    {K F : Type*} [Field K] [Field F] [Algebra K F] [IsAlgClosed K] [CharZero K]
+    (t : F) (c : K)
+    [FiniteDimensional ↥(IntermediateField.adjoin K ({t} : Set F)) F]
+    (S : Finset (Place K F))
+    (hS : ∀ w, w ∈ S ↔ 0 < w.ord (t - algebraMap K F c))
+    (hsum : ∑ w ∈ S, w.ord (t - algebraMap K F c) =
+      Module.finrank (IntermediateField.adjoin K ({t} : Set F)) F)
+    (hP1 : ∀ w : Place K F, 0 < w.ord (t - algebraMap K F c) →
+      ∃ φ' : F →ₐ[K] LaurentSeries K,
+        φ' (t - algebraMap K F c) =
+          HahnSeries.single (((w.ord (t - algebraMap K F c)).toNat : ℤ)) 1 ∧
+        ∀ x : F, (φ' x).order = w.ord x)
+    (w : Place K F) (hw : 0 < w.ord (t - algebraMap K F c)) :
+    Nat.card {ψ : F →ₐ[K] HahnSeries ℚ K //
+        ψ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1 ∧
+        ∃ g : ℚ, 0 < g ∧ ∀ x, (w.ord x : ℚ) * g = (ψ x).order} =
+      (w.ord (t - algebraMap K F c)).toNat := by
+  classical
+  obtain ⟨hfinAll, hcardAll⟩ := finite_allNorm_and_card_le t c
+  have := hfinAll
+  have hfinEmb : ∀ v : Place K F, Finite {ψ : F →ₐ[K] HahnSeries ℚ K //
+      ψ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1 ∧
+      ∃ g : ℚ, 0 < g ∧ ∀ x, (v.ord x : ℚ) * g = (ψ x).order} := by
+    intro v
+    exact Finite.of_injective
+      (fun ψp => (⟨ψp.1, ψp.2.1⟩ : {ψ : F →ₐ[K] HahnSeries ℚ K //
+        ψ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1}))
+      (fun a b hab => Subtype.ext (by
+        have := congrArg Subtype.val hab
+        simpa using this))
+  have hlow : ∀ v ∈ S, (v.ord (t - algebraMap K F c)).toNat ≤
+      Nat.card {ψ : F →ₐ[K] HahnSeries ℚ K //
+        ψ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1 ∧
+        ∃ g : ℚ, 0 < g ∧ ∀ x, (v.ord x : ℚ) * g = (ψ x).order} := by
+    intro v hv
+    have hv' := (hS v).mp hv
+    obtain ⟨φ', hφf, hφord⟩ := hP1 v hv'
+    set e : ℕ := (v.ord (t - algebraMap K F c)).toNat with he'
+    have he : 0 < e := by omega
+    have : NeZero e := ⟨he.ne'⟩
+    obtain ⟨ζ, hζroot⟩ := IsAlgClosed.exists_root (cyclotomic e K)
+      (degree_cyclotomic_pos e K he).ne'
+    have hζ : IsPrimitiveRoot ζ e := isRoot_cyclotomic_iff.mp hζroot
+    have hun : IsUnit ζ := hζ.isUnit he.ne'
+    have huζval : (hun.unit : K) = ζ := hun.unit_spec
+    have hmem : ∀ i : Fin e,
+        (((puiseuxAlgEmb (K := K) he).comp ((qTwistAlg (hun.unit ^ (i : ℕ))).comp φ')) t =
+          HahnSeries.C c + HahnSeries.single (1 : ℚ) 1 ∧
+        ∃ g : ℚ, 0 < g ∧ ∀ x, (v.ord x : ℚ) * g =
+          ((((puiseuxAlgEmb (K := K) he).comp
+            ((qTwistAlg (hun.unit ^ (i : ℕ))).comp φ'))) x).order) := by
+      intro i
+      apply normEmb_spec he (hun.unit ^ (i : ℕ)) ?_ t c v φ' hφf hφord
+      have hcomm : (hun.unit ^ (i : ℕ)) ^ e = (hun.unit ^ e) ^ (i : ℕ) := by
+        rw [← pow_mul, ← pow_mul, mul_comm]
+      rw [hcomm]
+      have hue : hun.unit ^ e = 1 := by
+        apply Units.ext
+        rw [Units.val_pow_eq_pow_val, huζval, hζ.pow_eq_one, Units.val_one]
+      rw [hue, one_pow]
+    have hinj : Function.Injective (fun i : Fin e =>
+        (⟨((puiseuxAlgEmb (K := K) he).comp ((qTwistAlg (hun.unit ^ (i : ℕ))).comp φ')),
+          hmem i⟩ : {ψ : F →ₐ[K] HahnSeries ℚ K //
+            ψ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1 ∧
+            ∃ g : ℚ, 0 < g ∧ ∀ x, (v.ord x : ℚ) * g = (ψ x).order})) := by
+      intro i j hij
+      have hval := congrArg Subtype.val hij
+      simp only at hval
+      obtain ⟨π, hπ⟩ := exists_ord_eq_one v
+      have hc := congrArg
+        (fun ψ : F →ₐ[K] HahnSeries ℚ K => (ψ π).coeff (HahnSeries.ramScale e 1)) hval
+      rw [normEmb_coeff_at he _ φ' π, normEmb_coeff_at he _ φ' π] at hc
+      have hcoe := coeff_one_ne_zero_of_ord_one φ' v hφord hπ
+      have hpow : ((hun.unit ^ (i : ℕ) : Kˣ) : K) = ((hun.unit ^ (j : ℕ) : Kˣ) : K) :=
+        mul_right_cancel₀ hcoe hc
+      have hζpow : ζ ^ (i : ℕ) = ζ ^ (j : ℕ) := by
+        rwa [Units.val_pow_eq_pow_val, Units.val_pow_eq_pow_val, huζval] at hpow
+      exact Fin.ext (hζ.pow_inj i.2 j.2 hζpow)
+    have := hfinEmb v
+    have hle := Nat.card_le_card_of_injective _ hinj
+    have hfe : Nat.card (Fin e) = e := by simp
+    rw [hfe] at hle
+    exact hle
+  have hup : ∑ v ∈ S, Nat.card {ψ : F →ₐ[K] HahnSeries ℚ K //
+      ψ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1 ∧
+      ∃ g : ℚ, 0 < g ∧ ∀ x, (v.ord x : ℚ) * g = (ψ x).order} ≤
+      Module.finrank (IntermediateField.adjoin K ({t} : Set F)) F := by
+    have : ∀ v : ↥S, Finite {ψ : F →ₐ[K] HahnSeries ℚ K //
+        ψ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1 ∧
+        ∃ g : ℚ, 0 < g ∧ ∀ x, ((v : Place K F).ord x : ℚ) * g = (ψ x).order} :=
+      fun v => hfinEmb v
+    have hsig : ∑ v ∈ S, Nat.card {ψ : F →ₐ[K] HahnSeries ℚ K //
+        ψ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1 ∧
+        ∃ g : ℚ, 0 < g ∧ ∀ x, (v.ord x : ℚ) * g = (ψ x).order} =
+        Nat.card ((v : ↥S) × {ψ : F →ₐ[K] HahnSeries ℚ K //
+          ψ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1 ∧
+          ∃ g : ℚ, 0 < g ∧ ∀ x, ((v : Place K F).ord x : ℚ) * g = (ψ x).order}) := by
+      rw [Nat.card_sigma, ← Finset.sum_coe_sort S]
+    rw [hsig]
+    have hinj2 : Function.Injective
+        (fun p : ((v : ↥S) × {ψ : F →ₐ[K] HahnSeries ℚ K //
+            ψ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1 ∧
+            ∃ g : ℚ, 0 < g ∧ ∀ x, ((v : Place K F).ord x : ℚ) * g = (ψ x).order}) =>
+          (⟨p.2.1, p.2.2.1⟩ : {ψ : F →ₐ[K] HahnSeries ℚ K //
+            ψ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1})) := by
+      rintro ⟨⟨v₁, hv₁⟩, ψ₁, hψ₁⟩ ⟨⟨v₂, hv₂⟩, ψ₂, hψ₂⟩ hab
+      have hψeq : ψ₁ = ψ₂ := by
+        have := congrArg Subtype.val hab
+        simpa using this
+      subst hψeq
+      obtain ⟨g₁, hg₁, hord₁⟩ := hψ₁.2
+      obtain ⟨g₂, hg₂, hord₂⟩ := hψ₂.2
+      have hveq : v₁ = v₂ := place_eq_of_mul_eq_order hg₁ hg₂ hord₁ hord₂
+      subst hveq
+      rfl
+    exact (Nat.card_le_card_of_injective _ hinj2).trans hcardAll
+  have hsumn : ∑ v ∈ S, (v.ord (t - algebraMap K F c)).toNat =
+      Module.finrank (IntermediateField.adjoin K ({t} : Set F)) F := by
+    have hcast : ((∑ v ∈ S, (v.ord (t - algebraMap K F c)).toNat : ℕ) : ℤ) =
+        ∑ v ∈ S, v.ord (t - algebraMap K F c) := by
+      push_cast
+      apply Finset.sum_congr rfl
+      intro v hv
+      have hpos := (hS v).mp hv
+      omega
+    have h2 : ((∑ v ∈ S, (v.ord (t - algebraMap K F c)).toNat : ℕ) : ℤ) =
+        ((Module.finrank (IntermediateField.adjoin K ({t} : Set F)) F : ℕ) : ℤ) := by
+      rw [hcast, hsum]
+    exact_mod_cast h2
+  have hforce : ∀ v ∈ S, (v.ord (t - algebraMap K F c)).toNat =
+      Nat.card {ψ : F →ₐ[K] HahnSeries ℚ K //
+        ψ t = HahnSeries.C c + HahnSeries.single (1 : ℚ) 1 ∧
+        ∃ g : ℚ, 0 < g ∧ ∀ x, (v.ord x : ℚ) * g = (ψ x).order} := by
+    apply (Finset.sum_eq_sum_iff_of_le hlow).mp
+    apply le_antisymm (Finset.sum_le_sum hlow)
+    rw [hsumn]
+    exact hup
+  exact (hforce w ((hS w).mpr hw)).symm
+
+private theorem natCard_normalized_algHom_hahnSeries_jBar_sub_eq_toNat_ord (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ)
+    [FiniteDimensional
+      ↥(IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({jBar N} : Set ↥(modularFunctionFieldBar N)))
+      ↥(modularFunctionFieldBar N)]
+    (S : Finset (Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)))
+    (hS : ∀ v, v ∈ S ↔ 0 < v.ord (jBar N -
+      algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀))
+    (hsum : ∑ v ∈ S, v.ord (jBar N -
+        algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) =
+      Module.finrank
+        (IntermediateField.adjoin (AlgebraicClosure ℚ)
+          ({jBar N} : Set ↥(modularFunctionFieldBar N)))
+        ↥(modularFunctionFieldBar N))
+    (hP1 : ∀ w : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N),
+      0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) →
+      ∃ φ' : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ]
+          LaurentSeries (AlgebraicClosure ℚ),
+        φ' (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) =
+          HahnSeries.single (((w.ord (jBar N - algebraMap (AlgebraicClosure ℚ)
+            (modularFunctionFieldBar N) j₀)).toNat : ℤ)) 1 ∧
+        ∀ x, (φ' x).order = w.ord x)
+    :
+    ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N),
+      0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) →
+      Nat.card {ψ : modularFunctionFieldBar N →ₐ[AlgebraicClosure ℚ]
+          HahnSeries ℚ (AlgebraicClosure ℚ) //
+        ψ (jBar N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ) ∧
+        ∃ g : ℚ, 0 < g ∧ ∀ x, (w.ord x : ℚ) * g = (ψ x).order} =
+      (w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)).toNat :=
+  fun w hw => natCard_normalized_algHom_eq_toNat_ord (jBar N) j₀ S hS hsum hP1 w hw
+
+end B2Peo
+
+end
+
+open AlgebraicCurve ModularCurve Polynomial in
+theorem solution (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ)
+    [FiniteDimensional
+      ↥(IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({jBar N} : Set ↥(modularFunctionFieldBar N)))
+      ↥(modularFunctionFieldBar N)]
+    (S : Finset (Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)))
+    (hS : ∀ v, v ∈ S ↔ 0 < v.ord (jBar N -
+      algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀))
+    (hsum : ∑ v ∈ S, v.ord (jBar N -
+        algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) =
+      Module.finrank
+        (IntermediateField.adjoin (AlgebraicClosure ℚ)
+          ({jBar N} : Set ↥(modularFunctionFieldBar N)))
+        ↥(modularFunctionFieldBar N))
+    (hP1 : ∀ w : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N),
+      0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) →
+      ∃ φ' : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ]
+          LaurentSeries (AlgebraicClosure ℚ),
+        φ' (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) =
+          HahnSeries.single (((w.ord (jBar N - algebraMap (AlgebraicClosure ℚ)
+            (modularFunctionFieldBar N) j₀)).toNat : ℤ)) 1 ∧
+        ∀ x, (φ' x).order = w.ord x)
+    :
+    ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N),
+      0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) →
+      Nat.card {ψ : modularFunctionFieldBar N →ₐ[AlgebraicClosure ℚ]
+          HahnSeries ℚ (AlgebraicClosure ℚ) //
+        ψ (jBar N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ) ∧
+        ∃ g : ℚ, 0 < g ∧ ∀ x, (w.ord x : ℚ) * g = (ψ x).order} =
+      (w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)).toNat :=
+  B2Peo.natCard_normalized_algHom_hahnSeries_jBar_sub_eq_toNat_ord N j₀ S hS hsum hP1
+
+end S_ModularCurve_natCard_normalized_algHom_hahnSeries_jBar_sub_eq_toNat_ord
+end P2MW
+export P2MW.S_ModularCurve_natCard_normalized_algHom_hahnSeries_jBar_sub_eq_toNat_ord (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve ModularCurve Polynomial
+theorem ModularCurve.natCard_normalized_algHom_hahnSeries_jBar_sub_eq_toNat_ord (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ)
+    [FiniteDimensional
+      ↥(IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({jBar N} : Set ↥(modularFunctionFieldBar N)))
+      ↥(modularFunctionFieldBar N)]
+    (S : Finset (Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)))
+    (hS : ∀ v, v ∈ S ↔ 0 < v.ord (jBar N -
+      algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀))
+    (hsum : ∑ v ∈ S, v.ord (jBar N -
+        algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) =
+      Module.finrank
+        (IntermediateField.adjoin (AlgebraicClosure ℚ)
+          ({jBar N} : Set ↥(modularFunctionFieldBar N)))
+        ↥(modularFunctionFieldBar N))
+    (hP1 : ∀ w : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N),
+      0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) →
+      ∃ φ' : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ]
+          LaurentSeries (AlgebraicClosure ℚ),
+        φ' (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) =
+          HahnSeries.single (((w.ord (jBar N - algebraMap (AlgebraicClosure ℚ)
+            (modularFunctionFieldBar N) j₀)).toNat : ℤ)) 1 ∧
+        ∀ x, (φ' x).order = w.ord x)
+    :
+    ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N),
+      0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) →
+      Nat.card {ψ : modularFunctionFieldBar N →ₐ[AlgebraicClosure ℚ]
+          HahnSeries ℚ (AlgebraicClosure ℚ) //
+        ψ (jBar N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ) ∧
+        ∃ g : ℚ, 0 < g ∧ ∀ x, (w.ord x : ℚ) * g = (ψ x).order} =
+      (w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)).toNat :=
+  solution N j₀ S hS hsum hP1
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_normalized_algHom_jBar_eq_toNat_ord.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_normalized_algHom_jBar_eq_toNat_ord.lean
new file mode 100644
index 0000000000..5fdcdcbb28
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_normalized_algHom_jBar_eq_toNat_ord.lean
@@ -0,0 +1,186 @@
+/-
+Based on Prove2Me node ModularCurve.natCard_normalized_algHom_jBar_eq_toNat_ord
+(c781a471-1137-5a4b-97d8-712654d43c75) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 727c0497-d736-5074-a299-2a91db87d09d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_RamificationBound
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_MazurStepThreeInputs
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_sum_ord_jBar_sub_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_finset_ord_jBar_sub_pos
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_deg_eq_one_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_pos
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_algHom_laurentSeries_order_eq_ord
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_normalized_algHom_hahnSeries_jBar_sub_eq_toNat_ord
+import LeanPool.FLTEichlerShimura.Theorems.Thm_LaurentSeries_exists_algHom_comp_map_eq_single
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_laurentBaseChange_modularFunctionFieldFull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_eq_dedekindPsi
+import Mathlib.FieldTheory.Relrank
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Algebra
+import Mathlib.RingTheory.LaurentSeries
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Normalised Hahn-series embeddings at a place above j₀
+
+Theorem statement: `ModularCurve.natCard_normalized_algHom_jBar_eq_toNat_ord`
+(`c781a471-1137-5a4b-97d8-712654d43c75`), by Claude, 2026-09-05.
+
+Proof: submission `727c0497-d736-5074-a299-2a91db87d09d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and $j_0 \in \overline{\mathbb Q}$. Write $F_N$ for
+`modularFunctionFieldBar N`, the subfield of the Laurent series field $\overline{\mathbb Q}((q))$
+generated over $\overline{\mathbb Q}$ by the coefficientwise images of the elements of
+`modularFunctionFieldFull N`, the subfield of $\mathbb Q((q))$ generated over $\mathbb Q$ by the
+expansions `divisorExpansions N`; and write $\bar j$ for `jBar N`, the element of $F_N$ given by the
+$q$-expansion of $j$ with coefficients mapped into $\overline{\mathbb Q}$. The assertion is: for
+every place $w$ of $F_N$ over $\overline{\mathbb Q}$ — that is, a valuation subring of $F_N$
+containing the image of $\overline{\mathbb Q}$, distinct from $F_N$ itself, and a principal ideal
+ring, with $\operatorname{ord}_w$ the associated normalised integer valuation — such that
+$\operatorname{ord}_w(\bar j - j_0) > 0$, the number of $\overline{\mathbb Q}$-algebra homomorphisms
+$\psi$ from $F_N$ to the field of Hahn series with rational exponents and coefficients in
+$\overline{\mathbb Q}$ which satisfy both $\psi(\bar j) = j_0 + t$, the constant series $j_0$ plus
+the single monomial of exponent $1$ with coefficient $1$, and the existence of a rational $g > 0$
+with $g \cdot \operatorname{ord}_w(x) = \operatorname{order}(\psi x)$ for all $x \in F_N$, is equal
+to the natural number $\operatorname{ord}_w(\bar j - j_0)$.
+
+This is the local count, at a single place of the function field of $X_0(N)$ lying over a point
+$j_0$ of the $j$-line, of the normalised Puiseux-type embeddings inducing that place: their number
+is the multiplicity of $j_0$ there. It is used in the computations of the fibre of $X_0(N) \to X(1)$
+over $j_0$, in particular in the determinations of the numbers $\nu_2$ and $\nu_3$ of places where
+$\bar j - 1728$, respectively $\bar j$, has order one, and in the identification of the set of such
+embeddings modulo inducing the same place.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_natCard_normalized_algHom_jBar_eq_toNat_ord.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_natCard_normalized_algHom_jBar_eq_toNat_ord
+
+p2m_open "AlgebraicCurve ModularCurve \
+  P2MW.S_ModularCurve_natCard_normalized_algHom_jBar_eq_toNat_ord.ModularCurve"
+
+private theorem finrankAdjoinJBar (N : ℕ) [NeZero N] :
+    Module.finrank
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)))
+      (modularFunctionFieldBar N) = dedekindPsi N := by
+  have hcm : IntermediateField.comap (modularFunctionFieldBar N).val
+        (IntermediateField.adjoin (AlgebraicClosure ℚ)
+          ({((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))} :
+            Set (LaurentSeries (AlgebraicClosure ℚ))))
+      = IntermediateField.adjoin (AlgebraicClosure ℚ)
+          ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)) := by
+    rw [← IntermediateField.lift_adjoin_simple]
+    exact IntermediateField.comap_map (modularFunctionFieldBar N).val _
+  have h1 := IntermediateField.finrank_comap
+    (IntermediateField.adjoin (AlgebraicClosure ℚ)
+      ({((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))} :
+        Set (LaurentSeries (AlgebraicClosure ℚ))))
+    (modularFunctionFieldBar N).val
+  rw [hcm, IntermediateField.fieldRange_val] at h1
+  have h2 : IntermediateField.relfinrank
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))} :
+          Set (LaurentSeries (AlgebraicClosure ℚ))))
+      (modularFunctionFieldBar N) = dedekindPsi N := by
+    rw [← ModularCurve.relfinrank_full_eq_dedekindPsi N,
+      ← ModularCurve.relfinrank_laurentBaseChange_modularFunctionFieldFull (AlgebraicClosure ℚ) N]
+  rw [← h2]
+  exact h1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "dedekindPsi jBar modularFunctionFieldBar \
+  sum_ord_jBar_sub_eq_dedekindPsi exists_finset_ord_jBar_sub_pos \
+  deg_eq_one_modularFunctionFieldBar dedekindPsi_pos \
+  natCard_normalized_algHom_hahnSeries_jBar_sub_eq_toNat_ord \
+  relfinrank_laurentBaseChange_modularFunctionFieldFull relfinrank_full_eq_dedekindPsi"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+private theorem ModularCurve.natCard_normalized_algHom_jBar_eq_toNat_ord (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ) :
+    ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N),
+      0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) →
+      Nat.card {ψ : modularFunctionFieldBar N →ₐ[AlgebraicClosure ℚ]
+          HahnSeries ℚ (AlgebraicClosure ℚ) //
+        ψ (jBar N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ) ∧
+        ∃ g : ℚ, 0 < g ∧ ∀ x, (w.ord x : ℚ) * g = (ψ x).order} =
+      (w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)).toNat := by
+  have : FiniteDimensional
+      ↥(IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({jBar N} : Set ↥(modularFunctionFieldBar N)))
+      ↥(modularFunctionFieldBar N) :=
+    Module.finite_of_finrank_pos (by
+      rw [finrankAdjoinJBar]
+      exact ModularCurve.dedekindPsi_pos N (NeZero.ne N))
+  have hFINRANK := finrankAdjoinJBar N
+  have hPEO2 := ModularCurve.natCard_normalized_algHom_hahnSeries_jBar_sub_eq_toNat_ord N j₀
+  obtain ⟨S, hS⟩ := ModularCurve.exists_finset_ord_jBar_sub_pos N j₀
+  have hdeg : ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), w.deg = 1 :=
+    ModularCurve.deg_eq_one_modularFunctionFieldBar N
+  have hsum := ModularCurve.sum_ord_jBar_sub_eq_dedekindPsi N j₀ hdeg S hS
+  rw [← hFINRANK] at hsum
+  exact hPEO2 S hS hsum (fun w hw => by
+    obtain ⟨φ, hφ⟩ := AlgebraicCurve.Place.exists_algHom_laurentSeries_order_eq_ord w (hdeg w)
+    have hf : 0 < (φ (jBar N -
+        algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)).order := by
+      rw [hφ]; exact hw
+    obtain ⟨φ', hφ', hφ'f⟩ := LaurentSeries.exists_algHom_comp_map_eq_single φ _ hf
+    refine ⟨φ', ?_, fun x => by rw [hφ', hφ]⟩
+    rw [hφ'f, hφ, Int.toNat_of_nonneg hw.le])
+
+open AlgebraicCurve _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_natCard_normalized_algHom_jBar_eq_toNat_ord.ModularCurve in
+theorem solution (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ) :
+    ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N),
+      0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) →
+      Nat.card {ψ : modularFunctionFieldBar N →ₐ[AlgebraicClosure ℚ]
+          HahnSeries ℚ (AlgebraicClosure ℚ) //
+        ψ (jBar N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ) ∧
+        ∃ g : ℚ, 0 < g ∧ ∀ x, (w.ord x : ℚ) * g = (ψ x).order} =
+      (w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)).toNat :=
+  ModularCurve.natCard_normalized_algHom_jBar_eq_toNat_ord N j₀
+
+end S_ModularCurve_natCard_normalized_algHom_jBar_eq_toNat_ord
+end P2MW
+export P2MW.S_ModularCurve_natCard_normalized_algHom_jBar_eq_toNat_ord (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve ModularCurve
+theorem ModularCurve.natCard_normalized_algHom_jBar_eq_toNat_ord (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ) :
+    ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N),
+      0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) →
+      Nat.card {ψ : modularFunctionFieldBar N →ₐ[AlgebraicClosure ℚ]
+          HahnSeries ℚ (AlgebraicClosure ℚ) //
+        ψ (jBar N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ) ∧
+        ∃ g : ℚ, 0 < g ∧ ∀ x, (w.ord x : ℚ) * g = (ψ x).order} =
+      (w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)).toNat :=
+  solution N j₀
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_orbitRelQuotient_zpowers_T_gamma0_eq_cuspCount.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_orbitRelQuotient_zpowers_T_gamma0_eq_cuspCount.lean
new file mode 100644
index 0000000000..0a7d209a64
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_orbitRelQuotient_zpowers_T_gamma0_eq_cuspCount.lean
@@ -0,0 +1,186 @@
+/-
+Based on Prove2Me node ModularCurve.natCard_orbitRelQuotient_zpowers_T_gamma0_eq_cuspCount
+(de8edeb5-1768-53fb-b380-0c2868f38d86) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3bddf388-35f0-5c42-82e9-fb98e3928d2b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_CuspSpace_card_cuspSpace_eq_cuspCount
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Number of ⟨ T⟩-orbits on SL₂(ℤ)/Γ₀(N)
+
+Theorem statement: `ModularCurve.natCard_orbitRelQuotient_zpowers_T_gamma0_eq_cuspCount`
+(`de8edeb5-1768-53fb-b380-0c2868f38d86`), by Claude, 2026-09-05.
+
+Proof: submission `3bddf388-35f0-5c42-82e9-fb98e3928d2b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, assumed nonzero (the `NeZero N` instance). Consider the left coset
+space $\mathrm{SL}_2(\mathbb Z)/\Gamma_0(N)$, where $\Gamma_0(N)$ is the congruence subgroup of
+matrices with lower-left entry divisible by $N$, and let the cyclic subgroup $\langle T\rangle$
+generated by $T=\begin{pmatrix}1&1\\0&1\end{pmatrix}$, realised as `Subgroup.zpowers
+ModularGroup.T`, act on this coset space by left translation. The assertion is that the number of
+orbits of this action, i.e. the cardinality (as a natural number, via `Nat.card`) of the quotient of
+$\mathrm{SL}_2(\mathbb Z)/\Gamma_0(N)$ by the orbit equivalence relation, equals
+[`ModularCurve.cuspCount N`](def/ModularCurve_GenusNumerics.html#L13), which by definition is the
+arithmetic sum $\sum_{d\mid N}\varphi(\gcd(d,N/d))$ over the positive divisors $d$ of $N$, $\varphi$
+being Euler's totient. In particular the double coset set $\langle
+T\rangle\backslash\mathrm{SL}_2(\mathbb Z)/\Gamma_0(N)$ is finite of that cardinality.
+
+This is the classical count of the cusps of the modular curve $X_0(N)$, $\nu_\infty(N)=\sum_{d\mid
+N}\varphi(\gcd(d,N/d))$, here expressed on the group-theoretic side as a count of $\langle
+T\rangle$-orbits on $\mathrm{SL}_2(\mathbb Z)/\Gamma_0(N)$, which is the shape needed when
+$\mathrm{SL}_2(\mathbb Z)$ is treated via its amalgam decomposition. It feeds the bounds on
+parabolic cohomology and on spaces of homomorphisms used for genus and dimension formulas, being
+cited by
+[`ModularCurve.finrank_parabolicHoms_gamma0_le_two_mul_genusFormula`]
+(thm.html#ModularCurve.finrank_parabolicHoms_gamma0_le_two_mul_genusFormula),
+[`HeckeEis.finrank_coeffH1par_le_two_mul_dimFormula`]
+(thm.html#HeckeEis.finrank_coeffH1par_le_two_mul_dimFormula)
+and
+[`ModularCurve.FullLevel.two_mul_natCard_doubleCoset_gammaH_levelH_zpowers_T_eq`]
+(thm.html#ModularCurve.FullLevel.two_mul_natCard_doubleCoset_gammaH_levelH_zpowers_T_eq).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_natCard_orbitRelQuotient_zpowers_T_gamma0_eq_cuspCount.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_natCard_orbitRelQuotient_zpowers_T_gamma0_eq_cuspCount
+
+open OnePoint
+open scoped MatrixGroups
+
+namespace BassSerreCuspCount
+
+open Matrix Matrix.SpecialLinearGroup CongruenceSubgroup ModularCurve ModularCurve.CuspSpace
+  MulAction
+
+theorem eq_T_zpow_or_neg (δ : SL(2, ℤ)) (h : δ 1 0 = 0) :
+    ∃ n : ℤ, δ = ModularGroup.T ^ n ∨ δ = -(ModularGroup.T ^ n) := by
+  have hdet : δ 0 0 * δ 1 1 - δ 0 1 * δ 1 0 = 1 := by
+    have := Matrix.SpecialLinearGroup.det_coe δ
+    rwa [Matrix.det_fin_two] at this
+  rw [h, mul_zero, sub_zero] at hdet
+  rcases Int.eq_one_or_neg_one_of_mul_eq_one' hdet with ⟨ha, hd⟩ | ⟨ha, hd⟩
+  · refine ⟨δ 0 1, Or.inl ?_⟩
+    ext i j
+    rw [ModularGroup.coe_T_zpow]
+    fin_cases i <;> fin_cases j <;> simp [ha, hd, h]
+  · refine ⟨-(δ 0 1), Or.inr ?_⟩
+    ext i j
+    rw [Matrix.SpecialLinearGroup.coe_neg, ModularGroup.coe_T_zpow]
+    fin_cases i <;> fin_cases j <;> simp [ha, hd, h]
+
+theorem mapGL_T_zpow_smul_infty (n : ℤ) :
+    mapGL ℚ (ModularGroup.T ^ n) • (∞ : OnePoint ℚ) = ∞ := by
+  rw [mapGL_smul_infty, ratPoint_eq_infty_iff]
+  show (↑(ModularGroup.T ^ n) : Matrix (Fin 2) (Fin 2) ℤ) 1 0 = 0
+  rw [ModularGroup.coe_T_zpow]
+  simp
+
+variable (N : ℕ)
+
+theorem neg_one_mem_Gamma0 : (-1 : SL(2, ℤ)) ∈ Gamma0 N := by
+  rw [Gamma0_mem]
+  simp
+
+theorem fromCoset_T_zpow_smul (n : ℤ) (x : SL(2, ℤ) ⧸ Gamma0 N) :
+    fromCoset N (ModularGroup.T ^ n • x) = fromCoset N x := by
+  induction x using QuotientGroup.induction_on with | H g =>
+  change fromCoset N ((ModularGroup.T ^ n * g : SL(2, ℤ)) : SL(2, ℤ) ⧸ Gamma0 N) = _
+  rw [fromCoset_mk, fromCoset_mk, _root_.mul_inv_rev, map_mul, mul_smul, ← _root_.zpow_neg,
+    mapGL_T_zpow_smul_infty]
+
+noncomputable def toCuspSpace :
+    orbitRel.Quotient (Subgroup.zpowers ModularGroup.T) (SL(2, ℤ) ⧸ Gamma0 N) → CuspSpace N :=
+  Quotient.lift (fromCoset N) fun x y hxy => by
+    obtain ⟨⟨_, n, rfl⟩, rfl⟩ := hxy
+    exact fromCoset_T_zpow_smul N n y
+
+theorem toCuspSpace_mk (x : SL(2, ℤ) ⧸ Gamma0 N) :
+    toCuspSpace N (Quotient.mk _ x) = fromCoset N x := rfl
+
+theorem toCuspSpace_surjective : Function.Surjective (toCuspSpace N) := by
+  intro c
+  obtain ⟨x, rfl⟩ := fromCoset_surjective N c
+  exact ⟨Quotient.mk _ x, rfl⟩
+
+theorem toCuspSpace_injective : Function.Injective (toCuspSpace N) := by
+  intro c c' h
+  induction c using Quotient.inductionOn with | h x =>
+  induction c' using Quotient.inductionOn with | h y =>
+  induction x using QuotientGroup.induction_on with | H g =>
+  induction y using QuotientGroup.induction_on with | H g' =>
+  change fromCoset N (g : SL(2, ℤ) ⧸ Gamma0 N) = fromCoset N (g' : SL(2, ℤ) ⧸ Gamma0 N) at h
+  rw [fromCoset_mk, fromCoset_mk, mk_eq_mk_iff] at h
+  obtain ⟨γ, hγ, hγeq⟩ := h
+  have hfix : mapGL ℚ (g * γ * g'⁻¹) • (∞ : OnePoint ℚ) = ∞ := by
+    rw [map_mul, map_mul, mul_smul, mul_smul, hγeq, ← mul_smul, ← map_mul, mul_inv_cancel,
+      map_one, one_smul]
+  have h10 : (g * γ * g'⁻¹) 1 0 = 0 := by
+    rw [mapGL_smul_infty, ratPoint_eq_infty_iff] at hfix
+    exact hfix
+  obtain ⟨n, hn⟩ := eq_T_zpow_or_neg (g * γ * g'⁻¹) h10
+  apply Quotient.sound
+  refine ⟨⟨ModularGroup.T ^ n, n, rfl⟩, ?_⟩
+  change ((ModularGroup.T ^ n * g' : SL(2, ℤ)) : SL(2, ℤ) ⧸ Gamma0 N) = (g : SL(2, ℤ) ⧸ Gamma0 N)
+  have hg : (g : SL(2, ℤ) ⧸ Gamma0 N) = ((g * γ : SL(2, ℤ)) : SL(2, ℤ) ⧸ Gamma0 N) := by
+    rw [QuotientGroup.eq, inv_mul_cancel_left]
+    exact hγ
+  rw [hg, QuotientGroup.eq]
+  rcases hn with hn | hn
+  · have : g * γ = ModularGroup.T ^ n * g' := by rw [← hn, inv_mul_cancel_right]
+    rw [this, inv_mul_cancel]
+    exact one_mem _
+  · have : g * γ = -(ModularGroup.T ^ n) * g' := by rw [← hn, inv_mul_cancel_right]
+    rw [this, neg_mul, mul_neg, inv_mul_cancel]
+    exact neg_one_mem_Gamma0 N
+
+noncomputable def orbitEquivCuspSpace :
+    orbitRel.Quotient (Subgroup.zpowers ModularGroup.T) (SL(2, ℤ) ⧸ Gamma0 N) ≃ CuspSpace N :=
+  Equiv.ofBijective (toCuspSpace N) ⟨toCuspSpace_injective N, toCuspSpace_surjective N⟩
+
+end BassSerreCuspCount
+
+theorem solution (N : ℕ) [NeZero N] :
+    Nat.card (MulAction.orbitRel.Quotient (Subgroup.zpowers ModularGroup.T)
+        (Matrix.SpecialLinearGroup (Fin 2) ℤ ⧸ CongruenceSubgroup.Gamma0 N))
+      = ModularCurve.cuspCount N := by
+  rw [Nat.card_congr (BassSerreCuspCount.orbitEquivCuspSpace N)]
+  exact ModularCurve.CuspSpace.card_cuspSpace_eq_cuspCount (NeZero.ne N)
+
+end S_ModularCurve_natCard_orbitRelQuotient_zpowers_T_gamma0_eq_cuspCount
+end P2MW
+export P2MW.S_ModularCurve_natCard_orbitRelQuotient_zpowers_T_gamma0_eq_cuspCount (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem ModularCurve.natCard_orbitRelQuotient_zpowers_T_gamma0_eq_cuspCount (N : ℕ) [NeZero N] :
+    Nat.card (MulAction.orbitRel.Quotient (Subgroup.zpowers ModularGroup.T)
+        (Matrix.SpecialLinearGroup (Fin 2) ℤ ⧸ CongruenceSubgroup.Gamma0 N))
+      = ModularCurve.cuspCount N :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_ord_jBar_eq_one_eq_nuThree.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_ord_jBar_eq_one_eq_nuThree.lean
new file mode 100644
index 0000000000..2f998b552c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_ord_jBar_eq_one_eq_nuThree.lean
@@ -0,0 +1,2402 @@
+/-
+Based on Prove2Me node ModularCurve.natCard_ord_jBar_eq_one_eq_nuThree
+(aa4b0a7b-4024-51de-9e2d-607e2b149481) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ab083c4f-caed-5aca-acfb-344f7e88c85c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_MazurStepThreeInputs
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JLinePlaces
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ModuliPoint
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_sum_ord_jBar_sub_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_finset_ord_jBar_sub_pos
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_deg_eq_one_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_equiv_place_pos_ord_algHom_integralClosure
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_jAdjoin_modularFunctionField_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_two_mul_natCard_moduliPoint_j_eq_1728_eq_dedekindPsi_add_nuTwo
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_three_mul_natCard_moduliPoint_j_eq_zero_eq_dedekindPsi_add_two_mul_nuThree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_laurentBaseChange_modularFunctionFieldFull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_pos
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_inertiaDeg_pos_of_finiteDimensional
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_restrict_eq_jLinePlace1728_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_restrict_eq_jLinePlaceZero_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_restrict_eq_jLinePlaceInfty_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ramificationIndex_eq_ord_sub_of_restrict_eq_jLinePlace1728
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ramificationIndex_eq_ord_of_restrict_eq_jLinePlaceZero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_irreducible_ramificationIndex_eq_ord_aeval_of_restrict_ne_jLinePlaces
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_deg_jLinePlace1728
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_deg_jLinePlaceZero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Simple zeros of ̄ j on level-N curve count ν₃(N)
+
+Theorem statement: `ModularCurve.natCard_ord_jBar_eq_one_eq_nuThree`
+(`aa4b0a7b-4024-51de-9e2d-607e2b149481`), by Claude, 2026-09-05.
+
+Proof: submission `ab083c4f-caed-5aca-acfb-344f7e88c85c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number. The ambient field is $\overline{F}_N :=$
+`modularFunctionFieldBar N`, the intermediate field of the Laurent series field over
+$\overline{\mathbb{Q}}$ generated over $\overline{\mathbb{Q}}$ by the coefficientwise images of the
+elements of `modularFunctionFieldFull N` (itself the subfield of $\mathbb{Q}((q))$ generated over
+$\mathbb{Q}$ by the divisor expansions at level $N$), and $\bar j :=$ `jBar N` is the element of
+$\overline{F}_N$ given by the coefficientwise image of the $q$-expansion of $j$. Places of
+$\overline{F}_N$ over $\overline{\mathbb{Q}}$ are valuation subrings of $\overline{F}_N$ containing
+$\overline{\mathbb{Q}}$, proper, and principal ideal rings, and $v.\mathrm{ord}$ is minus the
+logarithm of the associated adic valuation. Two hypotheses are assumed: first, at every place $v$
+with $\mathrm{ord}_v(\bar j) > 0$ the integer $\mathrm{ord}_v(\bar j)$ divides $3$; second, the
+number of places $v$ with $\mathrm{ord}_v(\bar j) > 0$ equals the number of elements $x$ of
+`ModuliPoint N (AlgebraicClosure ℚ)` with $j(x) = 0$, where `ModuliPoint N L` is the quotient of the
+type of pairs (an elliptic Weierstrass curve over $L$, a point of additive order exactly $N$) by the
+relation generated by a variable change together with replacing the marked point by a multiple by an
+integer coprime to $N$. The conclusion is that the number of places $v$ of $\overline{F}_N$ with
+$\mathrm{ord}_v(\bar j) = 1$ equals `nuThree N`, the number of $x \in \mathbb{Z}/N\mathbb{Z}$ with
+$x^2 + x + 1 = 0$.
+
+This is the count of the elliptic points of order three on the level-$N$ modular curve, realised
+here as the number of simple zeros of $\bar j$ on the geometric function field $\overline{F}_N$; the
+two hypotheses isolate the local input (only orders $1$ and $3$ occur above $j = 0$) and the mass
+formula comparison with the moduli count. It is used in the construction of divisors with prescribed
+degree and integrality from Riemann–Roch data and in the derivation of the genus formula for
+$\overline{F}_N$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_natCard_ord_jBar_eq_one_eq_nuThree.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_natCard_ord_jBar_eq_one_eq_nuThree
+
+noncomputable section
+
+p2m_open "AlgebraicCurve ModularCurve \
+  P2MW.S_ModularCurve_natCard_ord_jBar_eq_one_eq_nuThree.ModularCurve IsDedekindDomain IsLocalRing"
+
+section Generic
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+variable (K) in
+private abbrev DOM_normalization (t : F) : Subalgebra (Algebra.adjoin K ({t} : Set F)) F :=
+  integralClosure (Algebra.adjoin K ({t} : Set F)) F
+
+private scoped instance DOM_instIsPrincipalIdealRingAdjoinSingleton (t : F) :
+    IsPrincipalIdealRing (Algebra.adjoin K ({t} : Set F)) := by
+  have hmem : ∀ p : Polynomial K, Polynomial.aeval t p ∈ Algebra.adjoin K ({t} : Set F) := by
+    intro p
+    rw [Algebra.adjoin_singleton_eq_range_aeval]
+    exact ⟨p, rfl⟩
+  refine IsPrincipalIdealRing.of_surjective
+    ((Polynomial.aeval t).codRestrict (Algebra.adjoin K ({t} : Set F)) hmem) ?_
+  rintro ⟨a, ha⟩
+  obtain ⟨p, hp⟩ : ∃ p : Polynomial K, Polynomial.aeval t p = a := by
+    rw [Algebra.adjoin_singleton_eq_range_aeval] at ha
+    exact (AlgHom.mem_range _).mp ha
+  exact ⟨p, Subtype.ext hp⟩
+
+private def DOM_gen (t : F) : DOM_normalization K t :=
+  ⟨t, isIntegral_algebraMap (R := Algebra.adjoin K ({t} : Set F))
+    (x := (⟨t, Algebra.self_mem_adjoin_singleton K t⟩ : Algebra.adjoin K ({t} : Set F)))⟩
+
+@[scoped simp] private theorem DOM_coe_gen (t : F) :
+    ((DOM_gen (K := K) t : DOM_normalization K t) : F) = t := rfl
+
+@[scoped simp] private theorem DOM_coe_algebraMap_normalization (t : F) (c : K) :
+    ((algebraMap K (DOM_normalization K t) c : DOM_normalization K t) : F) = algebraMap K F c :=
+  (IsScalarTower.algebraMap_apply K (DOM_normalization K t) F c).symm
+
+section Dedekind
+
+open scoped IntermediateField.algebraAdjoinAdjoin
+
+variable [CharZero K] (t : F) [FiniteDimensional (IntermediateField.adjoin K ({t} : Set F)) F]
+
+private scoped instance DOM_instIsDedekindDomainNormalization :
+    IsDedekindDomain (DOM_normalization K t) := by
+  have : CharZero (IntermediateField.adjoin K ({t} : Set F)) :=
+    charZero_of_injective_algebraMap (algebraMap K _).injective
+  exact integralClosure.isDedekindDomain (Algebra.adjoin K ({t} : Set F))
+    (IntermediateField.adjoin K ({t} : Set F)) F
+
+private scoped instance DOM_instIsFractionRingNormalization :
+    IsFractionRing (DOM_normalization K t) F :=
+  integralClosure.isFractionRing_of_finite_extension
+    (IntermediateField.adjoin K ({t} : Set F)) F
+
+end Dedekind
+
+private theorem DOM_mem_of_ord_nonneg (w : Place K F) {f : F} (hf : f ≠ 0) (h : 0 ≤ w.ord f) :
+    f ∈ w.toValuationSubring := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  obtain ⟨u, hu⟩ := w.exists_unit_mul_zpow hf hπ
+  rw [hu, show w.ord f = (((w.ord f).toNat : ℕ) : ℤ) from (Int.toNat_of_nonneg h).symm,
+    zpow_natCast]
+  exact mul_mem (u : w.toValuationSubring).2 (pow_mem (π : w.toValuationSubring).2 _)
+
+private theorem DOM_mem_of_ord_sub_pos (w : Place K F) {t : F} {c : K}
+    (h : 0 < w.ord (t - algebraMap K F c)) : t ∈ w.toValuationSubring := by
+  have hne : t - algebraMap K F c ≠ 0 := by
+    intro h0
+    rw [h0, Place.ord_zero] at h
+    exact lt_irrefl _ h
+  have hmem := DOM_mem_of_ord_nonneg w hne h.le
+  have := add_mem hmem (w.algebraMap_mem' c)
+  rwa [sub_add_cancel] at this
+
+private theorem DOM_forall_mem_of_mem (t : F) (w : Place K F) (ht : t ∈ w.toValuationSubring)
+    (a : DOM_normalization K t) : (a : F) ∈ w.toValuationSubring := by
+  have hadj : ∀ x : F, x ∈ Algebra.adjoin K ({t} : Set F) → x ∈ w.toValuationSubring := by
+    intro x hx
+    refine Algebra.adjoin_induction (fun y hy => ?_) (fun c => w.algebraMap_mem' c)
+      (fun _ _ _ _ hx hy => add_mem hx hy) (fun _ _ _ _ hx hy => mul_mem hx hy) hx
+    rw [Set.mem_singleton_iff.mp hy]
+    exact ht
+  obtain ⟨P, hPmonic, hPeval⟩ : IsIntegral (Algebra.adjoin K ({t} : Set F)) (a : F) := a.2
+  refine w.mem_of_eval_monic_eq_zero (P := P.map (algebraMap _ F)) (hPmonic.map _)
+    (fun i => ?_) ?_
+  · rw [Polynomial.coeff_map]
+    exact hadj _ (P.coeff i).2
+  · rwa [Polynomial.eval_map]
+
+end Generic
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+private scoped instance DOM_finiteDimensional_adjoin_jBar (N : ℕ) [NeZero N] :
+    FiniteDimensional
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)))
+      (modularFunctionFieldBar N) := by
+  have hcm : IntermediateField.comap (modularFunctionFieldBar N).val
+        (IntermediateField.adjoin (AlgebraicClosure ℚ)
+          ({((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))} :
+            Set (LaurentSeries (AlgebraicClosure ℚ))))
+      = IntermediateField.adjoin (AlgebraicClosure ℚ)
+          ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)) := by
+    rw [← IntermediateField.lift_adjoin_simple]
+    exact IntermediateField.comap_map (modularFunctionFieldBar N).val _
+  have h1 := IntermediateField.finrank_comap
+    (IntermediateField.adjoin (AlgebraicClosure ℚ)
+      ({((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))} :
+        Set (LaurentSeries (AlgebraicClosure ℚ))))
+    (modularFunctionFieldBar N).val
+  rw [hcm, IntermediateField.fieldRange_val] at h1
+  have h2 : IntermediateField.relfinrank
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))} :
+          Set (LaurentSeries (AlgebraicClosure ℚ))))
+      (modularFunctionFieldBar N) = dedekindPsi N := by
+    rw [← ModularCurve.relfinrank_full_eq_dedekindPsi N,
+      ← ModularCurve.relfinrank_laurentBaseChange_modularFunctionFieldFull (AlgebraicClosure ℚ) N]
+  have hpos : 0 < IntermediateField.relfinrank
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))} :
+          Set (LaurentSeries (AlgebraicClosure ℚ))))
+      (modularFunctionFieldBar N) := by
+    rw [h2]
+    exact ModularCurve.dedekindPsi_pos N (NeZero.ne N)
+  rw [← h1] at hpos
+  exact Module.finite_of_finrank_pos hpos
+
+private def DOM_iota (N : ℕ) [NeZero N] :
+    modularFunctionField N →+* modularFunctionFieldBar N where
+  toFun x := ⟨coeffEmb (AlgebraicClosure ℚ) (x : LaurentSeries ℚ),
+    coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionField_le_full N x.2)⟩
+  map_one' := Subtype.ext (by push_cast; exact map_one _)
+  map_mul' x y := Subtype.ext (by push_cast; exact map_mul _ _ _)
+  map_zero' := Subtype.ext (by push_cast; exact map_zero _)
+  map_add' x y := Subtype.ext (by push_cast; exact map_add _ _ _)
+
+@[scoped simp] private theorem DOM_iota_coe (N : ℕ) [NeZero N] (x : modularFunctionField N) :
+    ((DOM_iota N x : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))
+      = coeffEmb (AlgebraicClosure ℚ) (x : LaurentSeries ℚ) := rfl
+
+private theorem DOM_iota_j (N : ℕ) [NeZero N] :
+    DOM_iota N (⟨jq, jq_mem N⟩ : modularFunctionField N) = jBar N := Subtype.ext rfl
+
+private theorem DOM_iota_injective (N : ℕ) [NeZero N] : Function.Injective (DOM_iota N) :=
+  (DOM_iota N).injective
+
+private theorem DOM_ord_nonneg_of_mem' {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) {f : F} (hf : f ∈ v.toValuationSubring) :
+    0 ≤ v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨n, u, hu⟩ :=
+    IsDiscreteValuationRing.eq_unit_mul_pow_irreducible
+      (x := (⟨f, hf⟩ : v.toValuationSubring)) (by simpa [Subtype.ext_iff] using hf0) hπ
+  have hcoe : f = ((u : v.toValuationSubring) : F) * ((π : F) ^ (n : ℤ)) := by
+    have h := congrArg (Subtype.val) hu
+    push_cast at h
+    rw [zpow_natCast]
+    exact h
+  rw [hcoe, v.ord_unit_smul_zpow u hπ (n : ℤ)]
+  exact Int.natCast_nonneg n
+
+private theorem DOM_exists_ord_comp_eq_mul {K K' F F' : Type*} [Field K] [Field K'] [Field F]
+    [Field F']
+    [Algebra K F] [Algebra K' F'] (ι : F →+* F') (w : Place K F) (v : Place K' F')
+    (h : ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v.toValuationSubring) :
+    ∃ c : ℤ, 0 < c ∧ ∀ x : F, v.ord (ι x) = c * w.ord x := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  have hπ0 : (π : F) ≠ 0 := by simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have hιne : ∀ {x : F}, x ≠ 0 → ι x ≠ 0 := fun hx => (map_ne_zero ι).mpr hx
+  have hunit : ∀ u : w.toValuationSubringˣ, v.ord (ι ((u : w.toValuationSubring) : F)) = 0 := by
+    intro u
+    have hu0 : ((u : w.toValuationSubring) : F) ≠ 0 := by
+      simp [ne_eq, ZeroMemClass.coe_eq_zero]
+    have h1 : 0 ≤ v.ord (ι ((u : w.toValuationSubring) : F)) :=
+      DOM_ord_nonneg_of_mem' v ((h _).mp (u : w.toValuationSubring).2)
+    have h2 : 0 ≤ v.ord (ι ((u : w.toValuationSubring) : F)⁻¹) := by
+      refine DOM_ord_nonneg_of_mem' v ((h _).mp (DOM_mem_of_ord_nonneg w (inv_ne_zero hu0) ?_))
+      rw [w.ord_inv, w.ord_coe_unit, neg_zero]
+    rw [map_inv₀, v.ord_inv] at h2
+    omega
+  refine ⟨v.ord (ι (π : F)), ?_, fun x => ?_⟩
+  · have h1 : 0 ≤ v.ord (ι (π : F)) := DOM_ord_nonneg_of_mem' v ((h _).mp π.2)
+    have hnot : (π : F)⁻¹ ∉ w.toValuationSubring := by
+      intro hmem
+      have h0 := DOM_ord_nonneg_of_mem' w hmem
+      rw [w.ord_inv, w.ord_coe_irreducible hπ] at h0
+      omega
+    have h2 : ¬ (0 ≤ v.ord (ι (π : F)⁻¹)) := fun hle =>
+      hnot ((h _).mpr (DOM_mem_of_ord_nonneg v (hιne (inv_ne_zero hπ0)) hle))
+    rw [map_inv₀, v.ord_inv] at h2
+    omega
+  · rcases eq_or_ne x 0 with rfl | hx0
+    · simp
+    obtain ⟨u, hu⟩ := w.exists_unit_mul_zpow hx0 hπ
+    set n := w.ord x with hn
+    have hu0 : ((u : w.toValuationSubring) : F) ≠ 0 := by
+      simp [ne_eq, ZeroMemClass.coe_eq_zero]
+    rw [hu, map_mul, map_zpow₀, v.ord_mul (hιne hu0) (zpow_ne_zero _ (hιne hπ0)), v.ord_zpow, hunit
+      u,
+      zero_add, mul_comm]
+
+section BareChart
+
+variable {K' F' : Type*} [Field K'] [Field F'] [Algebra K' F']
+variable {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R F'] [IsFractionRing R F']
+  [Algebra K' R] [IsScalarTower K' R F']
+
+private theorem DOM_exists_place_of_forall_mem (A : ValuationSubring F') (hA : A ≠ ⊤)
+    (hR : ∀ r : R, algebraMap R F' r ∈ A) :
+    ∃ v : Place K' F', v.toValuationSubring = A := by
+  let φ : R →+* A.toSubring := (algebraMap R F').codRestrict A.toSubring hR
+  let P : Ideal R := (IsLocalRing.maximalIdeal A).comap φ
+  have hP : P.IsPrime := Ideal.comap_isPrime _ _
+  have hinv : ∀ s : R, s ∉ P → (algebraMap R F' s)⁻¹ ∈ A := by
+    intro s hs
+    have hu : IsUnit (φ s) := by
+      by_contra hu
+      exact hs (Ideal.mem_comap.mpr ((IsLocalRing.mem_maximalIdeal _).mpr hu))
+    obtain ⟨u, hu⟩ := hu
+    have hcoe : ((u : A) : F') = algebraMap R F' s := by
+      rw [hu]
+      rfl
+    have h1 : (((u⁻¹ : Aˣ) : A) : F') * algebraMap R F' s = 1 := by
+      have hmul := congrArg (fun a : A => (a : F')) u.inv_mul
+      push_cast at hmul
+      rwa [hcoe] at hmul
+    rw [← eq_inv_of_mul_eq_one_left h1]
+    exact SetLike.coe_mem _
+  have hP0 : P ≠ ⊥ := by
+    intro hbot
+    apply hA
+    refine SetLike.ext fun x => ⟨fun _ => ValuationSubring.mem_top x, fun _ => ?_⟩
+    obtain ⟨a, b, hb, hx⟩ := IsFractionRing.div_surjective (A := R) x
+    rw [← hx, div_eq_mul_inv]
+    refine mul_mem (hR a) (hinv b fun hbP => ?_)
+    rw [hbot] at hbP
+    exact nonZeroDivisors.ne_zero hb (Ideal.mem_bot.mp hbP)
+  let Pv : HeightOneSpectrum R := ⟨P, hP, hP0⟩
+  have hle : HeightOneSpectrum.valuationSubringAtPrime F' Pv ≤ A := by
+    rintro x ⟨a, s, hs, rfl⟩
+    exact mul_mem (hR a) (hinv s hs)
+  have heq : HeightOneSpectrum.valuationSubringAtPrime F' Pv = A :=
+    ValuationSubring.eq_of_le_of_ne_top _ hle hA
+  refine ⟨Place.ofHeightOneSpectrum (K := K') Pv, ?_⟩
+  rw [Place.ofHeightOneSpectrum_toValuationSubring,
+    ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+  exact heq
+
+end BareChart
+
+section Chevalley
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F]
+
+private def DOM_iotaO (ι : F →+* F') (w : Place K F) : w.toValuationSubring →+* F' :=
+  ι.comp
+    { toFun := fun (z : w.toValuationSubring) => (z : F)
+      map_one' := rfl
+      map_mul' := fun _ _ => rfl
+      map_zero' := rfl
+      map_add' := fun _ _ => rfl }
+
+private theorem DOM_exists_valuationSubring_dom (ι : F →+* F') (w : Place K F) :
+    ∃ A : ValuationSubring F', A ≠ ⊤ ∧ ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ A := by
+  obtain ⟨A, hA, hloc⟩ := IsLocalRing.exists_factor_valuationRing (DOM_iotaO ι w)
+  have hmem : ∀ x : F, x ∈ w.toValuationSubring → ι x ∈ A := fun x hx => hA ⟨x, hx⟩
+  have hnu : ∀ z : w.toValuationSubring, ¬ IsUnit z →
+      ¬ IsUnit ((DOM_iotaO ι w).codRestrict A.toSubring hA z) :=
+    fun z hz hu => hz (hloc.map_nonunit z hu)
+  refine ⟨A, ?_, fun x => ⟨hmem x, fun hx => ?_⟩⟩
+  · intro htop
+    obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+    have hπ0 : (π : F) ≠ 0 := by
+      simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+    apply hnu π hπ.not_isUnit
+    have hinvmem : (ι (π : F))⁻¹ ∈ A.toSubring := by
+      change (ι (π : F))⁻¹ ∈ A
+      rw [htop]
+      exact ValuationSubring.mem_top _
+    refine IsUnit.of_mul_eq_one ⟨(ι (π : F))⁻¹, hinvmem⟩ ?_
+    apply Subtype.ext
+    change ι (π : F) * (ι (π : F))⁻¹ = 1
+    exact mul_inv_cancel₀ ((map_ne_zero ι).mpr hπ0)
+  · by_contra hxw
+    have hx0 : x ≠ 0 := by
+      rintro rfl
+      exact hxw (zero_mem _)
+    have hinv : x⁻¹ ∈ w.toValuationSubring := by
+      rcases w.toValuationSubring.mem_or_inv_mem x with h | h
+      · exact absurd h hxw
+      · exact h
+    have hnunit : ¬ IsUnit (⟨x⁻¹, hinv⟩ : w.toValuationSubring) := by
+      rintro ⟨u, hu⟩
+      apply hxw
+      have h1 : (((u⁻¹ : w.toValuationSubringˣ) : w.toValuationSubring) : F) * x⁻¹ = 1 := by
+        have hmul := congrArg (fun a : w.toValuationSubring => (a : F)) u.inv_mul
+        push_cast at hmul
+        rwa [hu] at hmul
+      rw [show x = (((u⁻¹ : w.toValuationSubringˣ) : w.toValuationSubring) : F) by
+        rw [eq_inv_of_mul_eq_one_left h1, inv_inv]]
+      exact SetLike.coe_mem _
+    apply hnu ⟨x⁻¹, hinv⟩ hnunit
+    have hxmem : ι x ∈ A.toSubring := hx
+    refine IsUnit.of_mul_eq_one ⟨ι x, hxmem⟩ ?_
+    apply Subtype.ext
+    change ι x⁻¹ * ι x = 1
+    rw [map_inv₀, inv_mul_cancel₀ ((map_ne_zero ι).mpr hx0)]
+
+private theorem DOM_mem_of_isIntegralElem (A : ValuationSubring F') {S : Type*} [CommRing S]
+    (ψ : S →+* F') (hψA : ∀ s : S, ψ s ∈ A) {b : F'} (hb : ψ.IsIntegralElem b) : b ∈ A := by
+  let ψA : S →+* A := ψ.codRestrict A.toSubring hψA
+  have hcomp : (algebraMap A F').comp ψA = ψ := RingHom.ext fun _ => rfl
+  obtain ⟨p, hp, hpb⟩ := hb
+  have hint : IsIntegral A b := by
+    refine ⟨p.map ψA, hp.map ψA, ?_⟩
+    rw [Polynomial.eval₂_map, hcomp]
+    exact hpb
+  obtain ⟨y, hy⟩ := IsIntegrallyClosed.isIntegral_iff.mp hint
+  rw [← hy]
+  exact SetLike.coe_mem _
+
+end Chevalley
+
+section Kit
+
+variable {K F K' F' : Type*} [Field K] [Field F] [Field K'] [Field F']
+  [Algebra K F] [Algebra K' F']
+
+private def DOM_twist (σ : F' ≃+* F') (σK : K' ≃+* K')
+    (hσ : ∀ a : K', σ (algebraMap K' F' a) = algebraMap K' F' (σK a)) (v : Place K' F') :
+    Place K' F' where
+  toValuationSubring := v.toValuationSubring.comap (σ.symm : F' →+* F')
+  algebraMap_mem' a := by
+    rw [ValuationSubring.mem_comap]
+    change σ.symm (algebraMap K' F' a) ∈ v.toValuationSubring
+    rw [show σ.symm (algebraMap K' F' a) = algebraMap K' F' (σK.symm a) by
+      rw [RingEquiv.symm_apply_eq, hσ, RingEquiv.apply_symm_apply]]
+    exact v.algebraMap_mem' _
+  ne_top' := fun h =>
+    v.ne_top' (SetLike.ext fun x =>
+      ⟨fun _ => ValuationSubring.mem_top x, fun _ => by
+        have hx : σ x ∈ v.toValuationSubring.comap (σ.symm : F' →+* F') := by
+          rw [h]
+          exact ValuationSubring.mem_top _
+        rw [ValuationSubring.mem_comap] at hx
+        have hx2 : σ.symm (σ x) ∈ v.toValuationSubring := hx
+        rwa [RingEquiv.symm_apply_apply] at hx2⟩)
+  isPrincipalIdealRing' :=
+    IsPrincipalIdealRing.of_surjective
+      (Place.comapSymmRingEquiv σ v.toValuationSubring : _ ≃+* _)
+      (Place.comapSymmRingEquiv σ v.toValuationSubring).surjective
+
+private theorem DOM_mem_twist_iff (σ : F' ≃+* F') (σK : K' ≃+* K')
+    (hσ : ∀ a : K', σ (algebraMap K' F' a) = algebraMap K' F' (σK a)) (v : Place K' F')
+    (x : F') :
+    x ∈ (DOM_twist σ σK hσ v).toValuationSubring ↔ σ.symm x ∈ v.toValuationSubring :=
+  ValuationSubring.mem_comap
+
+private theorem DOM_ord_twist (σ : F' ≃+* F') (σK : K' ≃+* K')
+    (hσ : ∀ a : K', σ (algebraMap K' F' a) = algebraMap K' F' (σK a)) (v : Place K' F')
+    (f : F') :
+    (DOM_twist σ σK hσ v).ord (σ f) = v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ
+  have hπ' : Irreducible (Place.comapSymmRingEquiv σ v.toValuationSubring π) :=
+    (MulEquiv.irreducible_iff (Place.comapSymmRingEquiv σ v.toValuationSubring)).mpr hπ
+  have hu' : IsUnit (Place.comapSymmRingEquiv σ v.toValuationSubring
+      (u : v.toValuationSubring)) :=
+    u.isUnit.map (Place.comapSymmRingEquiv σ v.toValuationSubring)
+  have key : σ f
+      = ((hu'.unit : (v.toValuationSubring.comap (σ.symm : F' →+* F'))) : F')
+        * (((Place.comapSymmRingEquiv σ v.toValuationSubring π :
+            (v.toValuationSubring.comap (σ.symm : F' →+* F'))) : F') ^ (v.ord f)) := by
+    rw [IsUnit.unit_spec, Place.coe_comapSymmRingEquiv_apply,
+      Place.coe_comapSymmRingEquiv_apply, ← map_zpow₀, ← map_mul, ← hu]
+  rw [key]
+  exact (DOM_twist σ σK hσ v).ord_unit_smul_zpow hu'.unit hπ' (v.ord f)
+
+private theorem DOM_mem_maximalIdeal_twist (σ : F' ≃+* F') (σK : K' ≃+* K')
+    (hσ : ∀ a : K', σ (algebraMap K' F' a) = algebraMap K' F' (σK a)) (v : Place K' F')
+    {z : F'} (hz : z ∈ v.toValuationSubring)
+    (hz' : σ z ∈ (DOM_twist σ σK hσ v).toValuationSubring)
+    (hmem : (⟨z, hz⟩ : v.toValuationSubring) ∈
+      IsLocalRing.maximalIdeal v.toValuationSubring) :
+    (⟨σ z, hz'⟩ : (DOM_twist σ σK hσ v).toValuationSubring) ∈
+      IsLocalRing.maximalIdeal (DOM_twist σ σK hσ v).toValuationSubring := by
+  rw [IsLocalRing.mem_maximalIdeal] at hmem ⊢
+  intro hu
+  apply hmem
+  have heq : (⟨σ z, hz'⟩ : (DOM_twist σ σK hσ v).toValuationSubring)
+      = Place.comapSymmRingEquiv σ v.toValuationSubring ⟨z, hz⟩ :=
+    Subtype.ext rfl
+  rw [heq] at hu
+  have h2 := hu.map (Place.comapSymmRingEquiv σ v.toValuationSubring).symm
+  convert h2 using 2
+  exact (RingEquiv.symm_apply_apply _ _).symm
+
+private def DOM_resMap (ι : F →+* F') (w : Place K F) (v : Place K' F')
+    (hdom : ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v.toValuationSubring) :
+    w.toValuationSubring →+* v.toValuationSubring :=
+  RingHom.codRestrict (ι.comp
+    { toFun := fun (z : w.toValuationSubring) => (z : F)
+      map_one' := rfl
+      map_mul' := fun _ _ => rfl
+      map_zero' := rfl
+      map_add' := fun _ _ => rfl })
+    v.toValuationSubring.toSubring
+    (fun z => (hdom z).mp z.2)
+
+private theorem DOM_resMap_coe (ι : F →+* F') (w : Place K F) (v : Place K' F')
+    (hdom : ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v.toValuationSubring)
+    (z : w.toValuationSubring) :
+    ((DOM_resMap ι w v hdom z : v.toValuationSubring) : F') = ι (z : F) := rfl
+
+private theorem DOM_residue_algebraMap (v : Place K' F') (a : K') :
+    IsLocalRing.residue v.toValuationSubring (algebraMap K' v.toValuationSubring a)
+      = algebraMap K' v.ResidueField a := rfl
+
+section Chi
+
+variable (ι : F →+* F') (w : Place K F) (v : Place K' F')
+  (hdom : ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v.toValuationSubring)
+  (hres : Function.Bijective (algebraMap K' v.ResidueField))
+
+private def DOM_chi : w.toValuationSubring →+* K' :=
+  ((RingEquiv.ofBijective (algebraMap K' v.ResidueField) hres).symm :
+      v.ResidueField →+* K').comp
+    ((IsLocalRing.residue v.toValuationSubring).comp (DOM_resMap ι w v hdom))
+
+private theorem DOM_residue_resMap (z : w.toValuationSubring) :
+    IsLocalRing.residue v.toValuationSubring (DOM_resMap ι w v hdom z)
+      = algebraMap K' v.ResidueField (DOM_chi ι w v hdom hres z) := by
+  change _ = (RingEquiv.ofBijective (algebraMap K' v.ResidueField) hres)
+    ((RingEquiv.ofBijective (algebraMap K' v.ResidueField) hres).symm _)
+  rw [RingEquiv.apply_symm_apply]
+  rfl
+
+private theorem DOM_chi_mem (z : w.toValuationSubring) :
+    DOM_resMap ι w v hdom z - algebraMap K' v.toValuationSubring (DOM_chi ι w v hdom hres z) ∈
+      IsLocalRing.maximalIdeal v.toValuationSubring := by
+  rw [← IsLocalRing.residue_eq_zero_iff, map_sub, DOM_residue_resMap ι w v hdom hres,
+    DOM_residue_algebraMap, sub_self]
+
+private theorem DOM_chi_unique {z : w.toValuationSubring} {a : K'}
+    (h : DOM_resMap ι w v hdom z - algebraMap K' v.toValuationSubring a ∈
+      IsLocalRing.maximalIdeal v.toValuationSubring) :
+    DOM_chi ι w v hdom hres z = a := by
+  rw [← IsLocalRing.residue_eq_zero_iff, map_sub, sub_eq_zero, DOM_residue_algebraMap] at h
+  apply hres.1
+  rw [← DOM_residue_resMap ι w v hdom hres]
+  exact h
+
+private theorem DOM_chi_eq_zero (z : w.toValuationSubring)
+    (hz : z ∈ IsLocalRing.maximalIdeal w.toValuationSubring) : DOM_chi ι w v hdom hres z = 0 := by
+  apply DOM_chi_unique ι w v hdom hres
+  rw [map_zero, sub_zero]
+  rcases eq_or_ne (z : F) 0 with hz0 | hz0
+  · have h0 : DOM_resMap ι w v hdom z = 0 :=
+      Subtype.ext (by rw [DOM_resMap_coe, hz0, map_zero]; rfl)
+    rw [h0]
+    exact Ideal.zero_mem _
+  · obtain ⟨c, hc, hcx⟩ := DOM_exists_ord_comp_eq_mul ι w v hdom
+    have hpos : 0 < w.ord (z : F) := (w.mem_maximalIdeal_iff_ord_pos hz0 z.2).mp hz
+    have hpos' : 0 < v.ord (ι (z : F)) := by
+      rw [hcx]
+      exact mul_pos hc hpos
+    exact (v.mem_maximalIdeal_iff_ord_pos ((map_ne_zero ι).mpr hz0) ((hdom _).mp z.2)).mpr hpos'
+
+private theorem DOM_ord_sub_chi_pos (z : w.toValuationSubring)
+    (hne : ι (z : F) - algebraMap K' F' (DOM_chi ι w v hdom hres z) ≠ 0) :
+    0 < v.ord (ι (z : F) - algebraMap K' F' (DOM_chi ι w v hdom hres z)) := by
+  have hmemF : ι (z : F) - algebraMap K' F' (DOM_chi ι w v hdom hres z) ∈ v.toValuationSubring :=
+    sub_mem ((hdom _).mp z.2) (v.algebraMap_mem' _)
+  refine (v.mem_maximalIdeal_iff_ord_pos hne hmemF).mp ?_
+  have heq : (⟨_, hmemF⟩ : v.toValuationSubring)
+      = DOM_resMap ι w v hdom z - algebraMap K' v.toValuationSubring (DOM_chi ι w v hdom hres z) :=
+    Subtype.ext rfl
+  rw [heq]
+  exact DOM_chi_mem ι w v hdom hres z
+
+private theorem DOM_chi_algebraMap [Algebra K K']
+    (hιK : ∀ a : K, ι (algebraMap K F a) = algebraMap K' F' (algebraMap K K' a)) (a : K) :
+    DOM_chi ι w v hdom hres (algebraMap K w.toValuationSubring a) = algebraMap K K' a := by
+  apply DOM_chi_unique ι w v hdom hres
+  have h : DOM_resMap ι w v hdom (algebraMap K w.toValuationSubring a)
+      = algebraMap K' v.toValuationSubring (algebraMap K K' a) :=
+    Subtype.ext (by rw [DOM_resMap_coe, Place.coe_algebraMap, Place.coe_algebraMap, hιK])
+  rw [h, sub_self]
+  exact Ideal.zero_mem _
+
+private def DOM_chiBar [Algebra K K']
+    (hιK : ∀ a : K, ι (algebraMap K F a) = algebraMap K' F' (algebraMap K K' a)) :
+    w.ResidueField →ₐ[K] K' :=
+  { Ideal.Quotient.lift (IsLocalRing.maximalIdeal w.toValuationSubring)
+      (DOM_chi ι w v hdom hres) (DOM_chi_eq_zero ι w v hdom hres) with
+    commutes' := fun a => by
+      change Ideal.Quotient.lift (IsLocalRing.maximalIdeal w.toValuationSubring)
+          (DOM_chi ι w v hdom hres) (DOM_chi_eq_zero ι w v hdom hres)
+          (Ideal.Quotient.mk _ (algebraMap K w.toValuationSubring a)) = algebraMap K K' a
+      rw [Ideal.Quotient.lift_mk]
+      exact DOM_chi_algebraMap ι w v hdom hres hιK a }
+
+private theorem DOM_chiBar_residue [Algebra K K']
+    (hιK : ∀ a : K, ι (algebraMap K F a) = algebraMap K' F' (algebraMap K K' a))
+    (z : w.toValuationSubring) :
+    DOM_chiBar ι w v hdom hres hιK (IsLocalRing.residue _ z) = DOM_chi ι w v hdom hres z :=
+  Ideal.Quotient.lift_mk _ _ _
+
+end Chi
+
+private theorem DOM_dom_twist (ι : F →+* F') (w : Place K F) (v : Place K' F')
+    (hdom : ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v.toValuationSubring)
+    (σ : F' ≃+* F') (σK : K' ≃+* K')
+    (hσ : ∀ a : K', σ (algebraMap K' F' a) = algebraMap K' F' (σK a))
+    (hσι : ∀ x : F, σ (ι x) = ι x) (x : F) :
+    x ∈ w.toValuationSubring ↔ ι x ∈ (DOM_twist σ σK hσ v).toValuationSubring := by
+  rw [DOM_mem_twist_iff, show σ.symm (ι x) = ι x by rw [RingEquiv.symm_apply_eq, hσι], hdom]
+
+private theorem DOM_chi_twist (ι : F →+* F') (w : Place K F) (v : Place K' F')
+    (hdom : ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v.toValuationSubring)
+    (hres : ∀ v' : Place K' F', Function.Bijective (algebraMap K' v'.ResidueField))
+    (σ : F' ≃+* F') (σK : K' ≃+* K')
+    (hσ : ∀ a : K', σ (algebraMap K' F' a) = algebraMap K' F' (σK a))
+    (hσι : ∀ x : F, σ (ι x) = ι x) (z : w.toValuationSubring) :
+    DOM_chi ι w (DOM_twist σ σK hσ v) (DOM_dom_twist ι w v hdom σ σK hσ hσι) (hres _) z
+      = σK (DOM_chi ι w v hdom (hres v) z) := by
+  apply DOM_chi_unique
+  have hmem := DOM_chi_mem ι w v hdom (hres v) z
+  have hzF : ι (z : F) - algebraMap K' F' (DOM_chi ι w v hdom (hres v) z) ∈ v.toValuationSubring :=
+    sub_mem ((hdom _).mp z.2) (v.algebraMap_mem' _)
+  have hz' : σ (ι (z : F) - algebraMap K' F' (DOM_chi ι w v hdom (hres v) z)) ∈
+      (DOM_twist σ σK hσ v).toValuationSubring := by
+    rw [DOM_mem_twist_iff, RingEquiv.symm_apply_apply]
+    exact hzF
+  have h := DOM_mem_maximalIdeal_twist σ σK hσ v hzF hz' hmem
+  have heq : DOM_resMap ι w (DOM_twist σ σK hσ v) (DOM_dom_twist ι w v hdom σ σK hσ hσι) z
+        - algebraMap K' (DOM_twist σ σK hσ v).toValuationSubring
+            (σK (DOM_chi ι w v hdom (hres v) z))
+      = ⟨σ (ι (z : F) - algebraMap K' F' (DOM_chi ι w v hdom (hres v) z)), hz'⟩ := by
+    apply Subtype.ext
+    change ι (z : F) - algebraMap K' F' (σK (DOM_chi ι w v hdom (hres v) z))
+      = σ (ι (z : F) - algebraMap K' F' (DOM_chi ι w v hdom (hres v) z))
+    rw [map_sub, hσι, hσ]
+  rw [heq]
+  exact h
+
+private theorem DOM_tauK_chi_eq_of_twist_eq (ι : F →+* F') (w : Place K F) (v : Place K' F')
+    (hdom : ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v.toValuationSubring)
+    (hres : ∀ v' : Place K' F', Function.Bijective (algebraMap K' v'.ResidueField))
+    {E : Type*} (τ : E → (F' ≃+* F')) (τK : E → (K' ≃+* K'))
+    (hτ : ∀ (e : E) (a : K'), τ e (algebraMap K' F' a) = algebraMap K' F' (τK e a))
+    (hτι : ∀ (e : E) (x : F), τ e (ι x) = ι x) {e₁ e₂ : E}
+    (h : DOM_twist (τ e₁) (τK e₁) (hτ e₁) v = DOM_twist (τ e₂) (τK e₂) (hτ e₂) v)
+    (z : w.toValuationSubring) :
+    τK e₁ (DOM_chi ι w v hdom (hres v) z) = τK e₂ (DOM_chi ι w v hdom (hres v) z) := by
+  rw [← DOM_chi_twist ι w v hdom hres (τ e₁) (τK e₁) (hτ e₁) (hτι e₁) z,
+    ← DOM_chi_twist ι w v hdom hres (τ e₂) (τK e₂) (hτ e₂) (hτι e₂) z]
+  have key : ∀ (v₁ v₂ : Place K' F') (h12 : v₁ = v₂)
+      (h₁ : ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v₁.toValuationSubring)
+      (h₂ : ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v₂.toValuationSubring),
+      DOM_chi ι w v₁ h₁ (hres v₁) z = DOM_chi ι w v₂ h₂ (hres v₂) z := by
+    intro v₁ v₂ h12 h₁ h₂
+    subst h12
+    rfl
+  exact key _ _ h _ _
+
+private theorem DOM_count (ι : F →+* F') (w : Place K F) (v : Place K' F')
+    (hdom : ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v.toValuationSubring)
+    (hres : ∀ v' : Place K' F', Function.Bijective (algebraMap K' v'.ResidueField))
+    {E : Type*} [Fintype E]
+    (τ : E → (F' ≃+* F')) (τK : E → (K' ≃+* K'))
+    (hτ : ∀ (e : E) (a : K'), τ e (algebraMap K' F' a) = algebraMap K' F' (τK e a))
+    (hτι : ∀ (e : E) (x : F), τ e (ι x) = ι x)
+    (hsep : ∀ e₁ e₂ : E,
+      (∀ z : w.toValuationSubring,
+        τK e₁ (DOM_chi ι w v hdom (hres v) z) = τK e₂ (DOM_chi ι w v hdom (hres v) z)) → e₁ = e₂) :
+    ∃ S : Finset (Place K' F'), Fintype.card E ≤ S.card ∧ ∀ v' ∈ S,
+      (∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v'.toValuationSubring) ∧
+      ∃ e : E, ∀ f : F', v'.ord (τ e f) = v.ord f := by
+  classical
+  refine ⟨Finset.univ.image (fun e => DOM_twist (τ e) (τK e) (hτ e) v), ?_, ?_⟩
+  · rw [Finset.card_image_of_injective _ (fun e₁ e₂ h =>
+      hsep e₁ e₂ (DOM_tauK_chi_eq_of_twist_eq ι w v hdom hres τ τK hτ hτι h)),
+      Finset.card_univ]
+  · intro v' hv'
+    obtain ⟨e, -, rfl⟩ := Finset.mem_image.mp hv'
+    exact ⟨DOM_dom_twist ι w v hdom (τ e) (τK e) (hτ e) (hτι e),
+      e, DOM_ord_twist (τ e) (τK e) (hτ e) v⟩
+
+end Kit
+
+section QBar
+
+private def DOM_fieldRangeEquiv {E : Type*} [Field E] [Algebra ℚ E]
+    (f : E →ₐ[ℚ] AlgebraicClosure ℚ) : E ≃ₐ[ℚ] f.fieldRange :=
+  AlgEquiv.ofBijective
+    (f.codRestrict f.fieldRange.toSubalgebra (fun z => f.mem_fieldRange.mpr ⟨z, rfl⟩))
+    ⟨fun a b hab => f.toRingHom.injective (congrArg Subtype.val hab),
+     fun y => by
+      obtain ⟨x, hx⟩ := f.mem_fieldRange.mp y.2
+      exact ⟨x, Subtype.ext hx⟩⟩
+
+private theorem DOM_fieldRangeEquiv_apply {E : Type*} [Field E] [Algebra ℚ E]
+    (f : E →ₐ[ℚ] AlgebraicClosure ℚ) (z : E) :
+    ((DOM_fieldRangeEquiv f z : f.fieldRange) : AlgebraicClosure ℚ) = f z := rfl
+
+set_option backward.isDefEq.respectTransparency false in
+private theorem DOM_exists_aut_comp_eq {E : Type*} [Field E] [Algebra ℚ E]
+    (χ₀ σ₀ : E →ₐ[ℚ] AlgebraicClosure ℚ) :
+    ∃ σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ, ∀ z : E, σ (χ₀ z) = σ₀ z := by
+  let e₀ : E ≃ₐ[ℚ] χ₀.fieldRange := DOM_fieldRangeEquiv χ₀
+  let e₁ : E ≃ₐ[ℚ] σ₀.fieldRange := DOM_fieldRangeEquiv σ₀
+  let φ : χ₀.fieldRange ≃ₐ[ℚ] σ₀.fieldRange := e₀.symm.trans e₁
+  refine ⟨φ.liftNormal (AlgebraicClosure ℚ), fun z => ?_⟩
+  have h1 : χ₀ z = algebraMap χ₀.fieldRange (AlgebraicClosure ℚ) (e₀ z) :=
+    (DOM_fieldRangeEquiv_apply χ₀ z).symm
+  rw [h1, AlgEquiv.liftNormal_commutes]
+  have h2 : φ (e₀ z) = e₁ z := by
+    change e₁ (e₀.symm (e₀ z)) = e₁ z
+    rw [AlgEquiv.symm_apply_apply]
+  rw [h2]
+  exact DOM_fieldRangeEquiv_apply σ₀ z
+
+end QBar
+
+section Concrete
+
+variable (N : ℕ) [NeZero N]
+
+private abbrev DOM_j : modularFunctionField N := ⟨jq, jq_mem N⟩
+
+private theorem DOM_iota_j' : DOM_iota N (DOM_j N) = jBar N := Subtype.ext rfl
+
+private theorem DOM_iota_algebraMap (c : ℚ) :
+    DOM_iota N (algebraMap ℚ (modularFunctionField N) c)
+      = algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+          (algebraMap ℚ (AlgebraicClosure ℚ) c) :=
+  RingHom.congr_fun (Subsingleton.elim
+    ((DOM_iota N).comp (algebraMap ℚ (modularFunctionField N)))
+    ((algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)).comp
+      (algebraMap ℚ (AlgebraicClosure ℚ)))) c
+
+private abbrev DOM_gAut (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) :
+    modularFunctionFieldBar N ≃+* modularFunctionFieldBar N :=
+  ModularCurve.arithmeticRingAut (modularFunctionFieldFull N) σ
+
+private theorem DOM_gAut_iota (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ)
+    (x : modularFunctionField N) : DOM_gAut N σ (DOM_iota N x) = DOM_iota N x := by
+  apply Subtype.ext
+  rw [ModularCurve.coe_arithmeticRingAut_apply]
+  exact ModularCurve.coeffMap_coeffEmb σ (x : LaurentSeries ℚ)
+
+omit [NeZero N] in
+private theorem DOM_gAut_algebraMap (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ)
+    (c : AlgebraicClosure ℚ) :
+    DOM_gAut N σ (algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) c)
+      = algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) (σ c) :=
+  ModularCurve.arithmeticRingAut_algebraMap (modularFunctionFieldFull N) σ c
+
+private theorem DOM_jBar_ne_algebraMap (j₀ : AlgebraicClosure ℚ) :
+    (jBar N : modularFunctionFieldBar N)
+      ≠ algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀ := by
+  intro heq
+  obtain ⟨S, hS⟩ := ModularCurve.exists_finset_ord_jBar_sub_pos N j₀
+  have hsum := ModularCurve.sum_ord_jBar_sub_eq_dedekindPsi N j₀
+    (ModularCurve.deg_eq_one_modularFunctionFieldBar N) S hS
+  have hempty : S = ∅ := by
+    rw [Finset.eq_empty_iff_forall_notMem]
+    intro v hv
+    have h := (hS v).mp hv
+    rw [heq, sub_self, Place.ord_zero] at h
+    exact lt_irrefl _ h
+  rw [hempty, Finset.sum_empty] at hsum
+  have hψ := ModularCurve.dedekindPsi_pos N (NeZero.ne N)
+  omega
+
+set_option backward.isDefEq.respectTransparency false in
+private theorem DOM_isIntegral_qbar (c : AlgebraicClosure ℚ) : IsIntegral ℚ c :=
+  isAlgebraic_iff_isIntegral.mp (Algebra.IsAlgebraic.isAlgebraic (R := ℚ) c)
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+private theorem DOM_residueBij (v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) :
+    Function.Bijective (algebraMap (AlgebraicClosure ℚ) v.ResidueField) := by
+  have hfin : Module.Finite (AlgebraicClosure ℚ) v.ResidueField :=
+    Module.finite_of_finrank_pos (by
+      have h1 : v.deg = 1 := ModularCurve.deg_eq_one_modularFunctionFieldBar N v
+      change 0 < Module.finrank (AlgebraicClosure ℚ) v.ResidueField
+      rw [show Module.finrank (AlgebraicClosure ℚ) v.ResidueField = v.deg from rfl, h1]
+      omega)
+  have : Algebra.IsIntegral (AlgebraicClosure ℚ) v.ResidueField :=
+    Algebra.IsIntegral.of_finite _ _
+  exact IsAlgClosed.algebraMap_bijective_of_isIntegral
+
+private theorem DOM_card_embeddings (w : Place ℚ (modularFunctionField N))
+    [FiniteDimensional ℚ w.ResidueField] :
+    Fintype.card (w.ResidueField →ₐ[ℚ] AlgebraicClosure ℚ) = w.deg := by
+  have : Algebra.IsIntegral ℚ w.ResidueField := Algebra.IsIntegral.of_finite ℚ _
+  have : Algebra.IsAlgebraic ℚ w.ResidueField := Algebra.IsAlgebraic.of_finite ℚ _
+  exact AlgHom.card ℚ w.ResidueField (AlgebraicClosure ℚ)
+
+section PerW
+
+variable (w : Place ℚ (modularFunctionField N)) (hj : DOM_j N ∈ w.toValuationSubring)
+
+private theorem DOM_algebraMap_mem_of_dom (A : ValuationSubring (modularFunctionFieldBar N))
+    (hA : ∀ x : modularFunctionField N, x ∈ w.toValuationSubring → DOM_iota N x ∈ A)
+    (c : AlgebraicClosure ℚ) :
+    algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) c ∈ A := by
+  have hψ : ∀ q : ℚ, ((algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)).comp
+      (algebraMap ℚ (AlgebraicClosure ℚ))) q ∈ A := by
+    intro q
+    rw [RingHom.comp_apply, ← DOM_iota_algebraMap]
+    exact hA _ (w.algebraMap_mem' q)
+  refine DOM_mem_of_isIntegralElem A _ hψ ?_
+  obtain ⟨p, hp, hpc⟩ := DOM_isIntegral_qbar c
+  refine ⟨p, hp, ?_⟩
+  rw [← Polynomial.hom_eval₂, hpc, map_zero]
+
+include hj in
+private theorem DOM_adjoin_mem_of_dom (A : ValuationSubring (modularFunctionFieldBar N))
+    (hA : ∀ x : modularFunctionField N, x ∈ w.toValuationSubring → DOM_iota N x ∈ A)
+    (x : modularFunctionFieldBar N)
+    (hx : x ∈ Algebra.adjoin (AlgebraicClosure ℚ)
+      ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N))) :
+    x ∈ A := by
+  refine Algebra.adjoin_induction (fun y hy => ?_) (fun c => DOM_algebraMap_mem_of_dom N w A hA c)
+    (fun _ _ _ _ hx hy => add_mem hx hy) (fun _ _ _ _ hx hy => mul_mem hx hy) hx
+  rw [Set.mem_singleton_iff.mp hy, ← DOM_iota_j']
+  exact hA _ hj
+
+include hj in
+private theorem DOM_normalization_mem_of_dom (A : ValuationSubring (modularFunctionFieldBar N))
+    (hA : ∀ x : modularFunctionField N, x ∈ w.toValuationSubring → DOM_iota N x ∈ A)
+    (b : DOM_normalization (AlgebraicClosure ℚ) (jBar N : modularFunctionFieldBar N)) :
+    algebraMap _ (modularFunctionFieldBar N) b ∈ A := by
+  have hb : IsIntegral (Algebra.adjoin (AlgebraicClosure ℚ)
+      ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)))
+      (b : modularFunctionFieldBar N) := b.2
+  exact DOM_mem_of_isIntegralElem A (algebraMap _ (modularFunctionFieldBar N))
+    (fun (s : Algebra.adjoin (AlgebraicClosure ℚ)
+        ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N))) =>
+      DOM_adjoin_mem_of_dom N w hj A hA (s : modularFunctionFieldBar N) s.2) hb
+
+include hj in
+set_option synthInstance.maxHeartbeats 1600000 in
+private theorem DOM_exists_dominating_place :
+    ∃ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N),
+      ∀ x : modularFunctionField N,
+        x ∈ w.toValuationSubring ↔ DOM_iota N x ∈ v.toValuationSubring := by
+  obtain ⟨A, hAtop, hdomA⟩ := DOM_exists_valuationSubring_dom (DOM_iota N) w
+  obtain ⟨v, hv⟩ := DOM_exists_place_of_forall_mem (K' := AlgebraicClosure ℚ)
+    (R := ↥(DOM_normalization (AlgebraicClosure ℚ) (jBar N : modularFunctionFieldBar N)))
+    A hAtop (DOM_normalization_mem_of_dom N w hj A (fun x hx => (hdomA x).mp hx))
+  exact ⟨v, fun x => by rw [hv]; exact hdomA x⟩
+
+private theorem DOM_j_mem_vsr (hw : 0 ≤ w.ord (DOM_j N)) : DOM_j N ∈ w.toValuationSubring := by
+  by_cases h0 : DOM_j N = (0 : modularFunctionField N)
+  · rw [h0]
+    exact zero_mem _
+  · exact DOM_mem_of_ord_nonneg w h0 hw
+
+end PerW
+
+section PerV
+
+variable (w : Place ℚ (modularFunctionField N)) (hj : DOM_j N ∈ w.toValuationSubring)
+  (v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N))
+  (hdom : ∀ x : modularFunctionField N,
+    x ∈ w.toValuationSubring ↔ DOM_iota N x ∈ v.toValuationSubring)
+
+private def DOM_chiBarV : w.ResidueField →ₐ[ℚ] AlgebraicClosure ℚ :=
+  DOM_chiBar (DOM_iota N) w v hdom (DOM_residueBij N v) (DOM_iota_algebraMap N)
+
+private theorem DOM_chiBarV_residue (z : w.toValuationSubring) :
+    DOM_chiBarV N w v hdom (IsLocalRing.residue _ z)
+      = DOM_chi (DOM_iota N) w v hdom (DOM_residueBij N v) z :=
+  DOM_chiBar_residue _ _ _ _ _ _ z
+
+private def DOM_sigma (ψ : w.ResidueField →ₐ[ℚ] AlgebraicClosure ℚ) :
+    AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ :=
+  (DOM_exists_aut_comp_eq (DOM_chiBarV N w v hdom) ψ).choose
+
+private theorem DOM_sigma_spec (ψ : w.ResidueField →ₐ[ℚ] AlgebraicClosure ℚ)
+    (q : w.ResidueField) :
+    DOM_sigma N w v hdom ψ (DOM_chiBarV N w v hdom q) = ψ q :=
+  (DOM_exists_aut_comp_eq (DOM_chiBarV N w v hdom) ψ).choose_spec q
+
+include hj hdom in
+private theorem DOM_main_pos [FiniteDimensional ℚ w.ResidueField] :
+    ∃ S : Finset (Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)),
+      w.deg ≤ S.card ∧ ∀ v ∈ S,
+        (∃ j₀ : AlgebraicClosure ℚ,
+          0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)) ∧
+        ∃ c : ℤ, 0 < c ∧
+          ∀ (x : modularFunctionField N) (y : modularFunctionFieldBar N),
+            (y : LaurentSeries (AlgebraicClosure ℚ))
+                = coeffEmb (AlgebraicClosure ℚ) (x : LaurentSeries ℚ) →
+              v.ord y = c * w.ord x := by
+  classical
+  obtain ⟨S, hcard, hS⟩ := DOM_count (DOM_iota N) w v hdom (DOM_residueBij N)
+    (E := w.ResidueField →ₐ[ℚ] AlgebraicClosure ℚ)
+    (fun ψ => DOM_gAut N (DOM_sigma N w v hdom ψ))
+    (fun ψ => (DOM_sigma N w v hdom ψ : AlgebraicClosure ℚ ≃+* AlgebraicClosure ℚ))
+    (fun ψ a => DOM_gAut_algebraMap N _ a) (fun ψ x => DOM_gAut_iota N _ x) (by
+      intro ψ₁ ψ₂ h
+      apply AlgHom.ext
+      intro q
+      obtain ⟨z, rfl⟩ := Ideal.Quotient.mk_surjective q
+      change ψ₁ (IsLocalRing.residue _ z) = ψ₂ (IsLocalRing.residue _ z)
+      rw [← DOM_sigma_spec N w v hdom ψ₁, ← DOM_sigma_spec N w v hdom ψ₂,
+        DOM_chiBarV_residue]
+      exact h z)
+  refine ⟨S, by rw [← DOM_card_embeddings N w]; exact hcard, fun v' hv' => ?_⟩
+  obtain ⟨hdom', ψ, hord⟩ := hS v' hv'
+  have hord' : ∀ f : modularFunctionFieldBar N,
+      v'.ord (DOM_gAut N (DOM_sigma N w v hdom ψ) f) = v.ord f := hord
+  refine ⟨?_, ?_⟩
+  · have hne : DOM_iota N (DOM_j N) - algebraMap _ _
+        (DOM_chi (DOM_iota N) w v hdom (DOM_residueBij N v) ⟨DOM_j N, hj⟩) ≠ 0 := by
+      rw [DOM_iota_j', sub_ne_zero]
+      exact DOM_jBar_ne_algebraMap N _
+    have hpos := DOM_ord_sub_chi_pos (DOM_iota N) w v hdom (DOM_residueBij N v)
+      ⟨DOM_j N, hj⟩ hne
+    refine ⟨DOM_sigma N w v hdom ψ
+      (DOM_chi (DOM_iota N) w v hdom (DOM_residueBij N v) ⟨DOM_j N, hj⟩), ?_⟩
+    have key : DOM_gAut N (DOM_sigma N w v hdom ψ)
+          (DOM_iota N (DOM_j N) - algebraMap _ _
+            (DOM_chi (DOM_iota N) w v hdom (DOM_residueBij N v) ⟨DOM_j N, hj⟩))
+        = jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+            (DOM_sigma N w v hdom ψ
+              (DOM_chi (DOM_iota N) w v hdom (DOM_residueBij N v) ⟨DOM_j N, hj⟩)) := by
+      rw [map_sub, DOM_gAut_iota, DOM_gAut_algebraMap, DOM_iota_j']
+    rw [← key, hord']
+    exact hpos
+  · obtain ⟨c, hc, hident⟩ := DOM_exists_ord_comp_eq_mul (DOM_iota N) w v' hdom'
+    refine ⟨c, hc, fun x y hy => ?_⟩
+    have hy' : y = DOM_iota N x := Subtype.ext hy
+    rw [hy']
+    exact hident x
+
+end PerV
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+private theorem DOM_main (w : Place ℚ (modularFunctionField N))
+    (hw : 0 ≤ w.ord (⟨jq, jq_mem N⟩ : modularFunctionField N)) :
+    ∃ S : Finset (Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)),
+      w.deg ≤ S.card ∧ ∀ v ∈ S,
+        (∃ j₀ : AlgebraicClosure ℚ,
+          0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)) ∧
+        ∃ c : ℤ, 0 < c ∧
+          ∀ (x : modularFunctionField N) (y : modularFunctionFieldBar N),
+            (y : LaurentSeries (AlgebraicClosure ℚ))
+                = coeffEmb (AlgebraicClosure ℚ) (x : LaurentSeries ℚ) →
+              v.ord y = c * w.ord x := by
+  classical
+  by_cases hdeg0 : w.deg = 0
+  · refine ⟨∅, ?_, ?_⟩
+    · rw [hdeg0]
+      exact Nat.zero_le _
+    · intro v hv
+      exact absurd hv (Finset.notMem_empty v)
+  · have hdpos : 0 < w.deg := Nat.pos_of_ne_zero hdeg0
+    have hj : DOM_j N ∈ w.toValuationSubring := DOM_j_mem_vsr N w hw
+    obtain ⟨v, hdom⟩ := DOM_exists_dominating_place N w hj
+    have : FiniteDimensional ℚ w.ResidueField := Module.finite_of_finrank_pos hdpos
+    exact DOM_main_pos N w hj v hdom
+
+end Concrete
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jBar arithmeticRingAut coe_arithmeticRingAut_apply \
+  arithmeticRingAut_algebraMap modularFunctionFieldBar jq dedekindPsi modularFunctionField jq_mem \
+  jGen modularFunctionFieldFull modularFunctionField_le_full coeffEmb coeffMap_coeffEmb \
+  coeffEmb_mem_laurentBaseChange sum_ord_jBar_sub_eq_dedekindPsi exists_finset_ord_jBar_sub_pos \
+  deg_eq_one_modularFunctionFieldBar jAdjoinAlgebra jLineRingEquiv jLineRingEquiv_X \
+  instDecidableEqRatFuncRat jLinePlace1728 jLinePlaceZero jLinePlaceInfty nuTwo nuThree \
+  ModuliPoint ModuliPoint.j finrank_jAdjoin_modularFunctionField_eq_dedekindPsi \
+  two_mul_natCard_moduliPoint_j_eq_1728_eq_dedekindPsi_add_nuTwo \
+  three_mul_natCard_moduliPoint_j_eq_zero_eq_dedekindPsi_add_two_mul_nuThree \
+  relfinrank_full_eq_dedekindPsi relfinrank_laurentBaseChange_modularFunctionFieldFull \
+  dedekindPsi_pos restrict_eq_jLinePlace1728_iff restrict_eq_jLinePlaceZero_iff \
+  restrict_eq_jLinePlaceInfty_iff ramificationIndex_eq_ord_sub_of_restrict_eq_jLinePlace1728 \
+  ramificationIndex_eq_ord_of_restrict_eq_jLinePlaceZero \
+  exists_irreducible_ramificationIndex_eq_ord_aeval_of_restrict_ne_jLinePlaces deg_jLinePlace1728 \
+  deg_jLinePlaceZero"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.exists_finset_place_bar_dominating_of_ord_jq_nonneg (N : ℕ) [NeZero N]
+    (w : Place ℚ (modularFunctionField N))
+    (hw : 0 ≤ w.ord (⟨jq, jq_mem N⟩ : modularFunctionField N)) :
+    ∃ S : Finset (Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)),
+      w.deg ≤ S.card ∧ ∀ v ∈ S,
+        (∃ j₀ : AlgebraicClosure ℚ,
+          0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)) ∧
+        ∃ c : ℤ, 0 < c ∧
+          ∀ (x : modularFunctionField N) (y : modularFunctionFieldBar N),
+            (y : LaurentSeries (AlgebraicClosure ℚ)) = coeffEmb (AlgebraicClosure ℚ) (x :
+              LaurentSeries ℚ) →
+              v.ord y = c * w.ord x :=
+  DOM_main N w hw
+
+end
+
+p2m_open "IntermediateField AlgebraicCurve AlgebraicCurve.RationalFunctionField ModularCurve \
+  P2MW.S_ModularCurve_natCard_ord_jBar_eq_one_eq_nuThree.ModularCurve"
+
+noncomputable section
+
+namespace CNTUnit
+
+open Polynomial IsDedekindDomain WithZero
+
+attribute [local instance 2000] RatFunc.instAlgebraOfPolynomial
+attribute [local instance] ModularCurve.instDecidableEqRatFuncRat
+attribute [local instance] ModularCurve.jAdjoinAlgebra
+
+section Generic
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+private theorem CNT_ord_nonneg_of_mem (v : Place K F) {f : F} (hf : f ∈ v.toValuationSubring) :
+    0 ≤ v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨n, u, hu⟩ :=
+    IsDiscreteValuationRing.eq_unit_mul_pow_irreducible
+      (x := (⟨f, hf⟩ : v.toValuationSubring)) (by simpa [Subtype.ext_iff] using hf0) hπ
+  have hcoe : f = ((u : v.toValuationSubring) : F) * ((π : F) ^ (n : ℤ)) := by
+    have h := congrArg (Subtype.val) hu
+    push_cast at h
+    rw [zpow_natCast]
+    exact h
+  rw [hcoe, v.ord_unit_smul_zpow u hπ (n : ℤ)]
+  exact Int.natCast_nonneg n
+
+private theorem CNT_mem_of_ord_nonneg (w : Place K F) {f : F} (hf : f ≠ 0) (h : 0 ≤ w.ord f) :
+    f ∈ w.toValuationSubring := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  obtain ⟨u, hu⟩ := w.exists_unit_mul_zpow hf hπ
+  rw [hu, show w.ord f = (((w.ord f).toNat : ℕ) : ℤ) from (Int.toNat_of_nonneg h).symm,
+    zpow_natCast]
+  exact mul_mem (u : w.toValuationSubring).2 (pow_mem (π : w.toValuationSubring).2 _)
+
+private theorem CNT_mem_of_ord_sub_pos (w : Place K F) {f : F} {c : K}
+    (h : 0 < w.ord (f - algebraMap K F c)) : f ∈ w.toValuationSubring := by
+  have hne : f - algebraMap K F c ≠ 0 := by
+    intro h0
+    rw [h0, Place.ord_zero] at h
+    exact lt_irrefl _ h
+  have := add_mem (CNT_mem_of_ord_nonneg w hne h.le) (w.algebraMap_mem' c)
+  rwa [sub_add_cancel] at this
+
+private theorem CNT_ord_eq_one_of_valuation_eq (w : Place K F) {v' : Valuation F ℤᵐ⁰}
+    (hv' : v'.valuationSubring = w.toValuationSubring) {x : F} (hx : v' x = exp (-1 : ℤ)) :
+    w.ord x = 1 := by
+  have hE := w.isEquiv_adicValuation_of_valuationSubring_eq hv'
+  have hx0 : v' x ≠ 0 := by rw [hx]; exact exp_ne_zero
+  have hu0 : w.adicValuation x ≠ 0 := (hE.eq_zero).ne.mp hx0
+  have hlt : w.adicValuation x < 1 := by
+    refine hE.lt_one_iff_lt_one.mp ?_
+    rw [hx, ← exp_zero]
+    exact exp_lt_exp.mpr (by norm_num)
+  obtain ⟨ϖ, hϖ⟩ := w.heightOneSpectrum.valuation_exists_uniformizer F
+  change w.adicValuation ϖ = exp (-1 : ℤ) at hϖ
+  have hϖ0 : w.adicValuation ϖ ≠ 0 := by rw [hϖ]; exact exp_ne_zero
+  have hϖlt : v' ϖ < 1 := by
+    refine hE.lt_one_iff_lt_one.mpr ?_
+    rw [hϖ, ← exp_zero]
+    exact exp_lt_exp.mpr (by norm_num)
+  have hϖ0' : v' ϖ ≠ 0 := (hE.eq_zero).ne.mpr hϖ0
+  have hϖle : v' ϖ ≤ v' x := by
+    rw [hx, ← log_le_iff_le_exp hϖ0']
+    have hlog : log (v' ϖ) < 0 := (log_lt_iff_lt_exp hϖ0').mpr (by rw [exp_zero]; exact hϖlt)
+    omega
+  have hge : exp (-1 : ℤ) ≤ w.adicValuation x := by
+    rw [← hϖ]
+    exact (hE ϖ x).mp hϖle
+  have hle' : log (w.adicValuation x) ≤ -1 := by
+    have hlog : log (w.adicValuation x) < 0 :=
+      (log_lt_iff_lt_exp hu0).mpr (by rw [exp_zero]; exact hlt)
+    omega
+  have hge' : -1 ≤ log (w.adicValuation x) := (le_log_iff_exp_le hu0).mpr hge
+  simp only [Place.ord]
+  omega
+
+end Generic
+
+section RatFuncLine
+
+variable {K : Type*} [Field K]
+
+private theorem CNT_algebraMap_polynomial_mem (p : Place K (RatFunc K))
+    (hX : (RatFunc.X : RatFunc K) ∈ p.toValuationSubring) (r : K[X]) :
+    algebraMap K[X] (RatFunc K) r ∈ p.toValuationSubring := by
+  induction r using Polynomial.induction_on with
+  | C a =>
+    rw [RatFunc.algebraMap_C, ← RatFunc.algebraMap_eq_C]
+    exact p.algebraMap_mem' a
+  | add r s hr hs =>
+    rw [map_add]
+    exact add_mem hr hs
+  | monomial n a h =>
+    rw [pow_succ, ← mul_assoc, map_mul, RatFunc.algebraMap_X]
+    exact mul_mem h hX
+
+private theorem CNT_ord_placeOfPoint (c : K) :
+    (placeOfPoint K c).ord ((RatFunc.X : RatFunc K) - algebraMap K (RatFunc K) c) = 1 := by
+  have hq0 : (X - C c : K[X]) ≠ 0 := X_sub_C_ne_zero c
+  have hmap : algebraMap K[X] (RatFunc K) (X - C c) =
+      (RatFunc.X : RatFunc K) - algebraMap K (RatFunc K) c := by
+    rw [map_sub, RatFunc.algebraMap_X, RatFunc.algebraMap_C, RatFunc.algebraMap_eq_C]
+  rw [← hmap, placeOfPoint_eq_ofHeightOneSpectrum]
+  refine CNT_ord_eq_one_of_valuation_eq _
+    (v' := (heightOneSpectrumOfIrreducible K (irreducible_X_sub_C c)).valuation (RatFunc K)) rfl ?_
+  rw [HeightOneSpectrum.valuation_of_algebraMap]
+  exact (heightOneSpectrumOfIrreducible K (irreducible_X_sub_C c)).intValuation_singleton hq0 rfl
+
+private theorem CNT_eq_placeOfPoint_of_ord_pos (p : Place K (RatFunc K)) (c : K)
+    (h : 0 < p.ord ((RatFunc.X : RatFunc K) - algebraMap K (RatFunc K) c)) :
+    p = placeOfPoint K c := by
+  have hX : (RatFunc.X : RatFunc K) ∈ p.toValuationSubring := CNT_mem_of_ord_sub_pos p h
+  have hw : ∀ r : K[X], algebraMap K[X] (RatFunc K) r ∈ p.toValuationSubring :=
+    CNT_algebraMap_polynomial_mem p hX
+  have hq0 : (X - C c : K[X]) ≠ 0 := X_sub_C_ne_zero c
+  have hmem : (X - C c : K[X]) ∈ Place.center K[X] p hw := by
+    rw [Place.mem_center_iff_ord_pos p hw hq0, map_sub, RatFunc.algebraMap_X, RatFunc.algebraMap_C]
+    rw [RatFunc.algebraMap_eq_C] at h
+    exact h
+  have hcenter : Place.center K[X] p hw = Ideal.span {(X - C c : K[X])} := by
+    have hmax : (Ideal.span {(X - C c : K[X])}).IsMaximal :=
+      PrincipalIdealRing.isMaximal_of_irreducible (irreducible_X_sub_C c)
+    exact (hmax.eq_of_le (Ideal.IsPrime.ne_top inferInstance)
+      ((Ideal.span_singleton_le_iff_mem _).mpr hmem)).symm
+  have hc : Place.centerHeightOneSpectrum K[X] p hw =
+      heightOneSpectrumOfIrreducible K (irreducible_X_sub_C c) :=
+    HeightOneSpectrum.ext hcenter
+  apply Place.ext
+  rw [p.toValuationSubring_eq_of_forall_mem hw, hc, placeOfPoint_eq_ofHeightOneSpectrum,
+    Place.ofHeightOneSpectrum_toValuationSubring,
+    HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+
+end RatFuncLine
+
+section JLine
+
+private def CNT_base (c : ℚ) : Place ℚ ℚ⟮jq⟯ :=
+  Place.congrRingEquiv jLineRingEquiv (RingHom.map_rat_algebraMap jLineRingEquiv.toRingHom)
+    (placeOfPoint ℚ c)
+
+private theorem CNT_jLinePlace1728_eq : jLinePlace1728 = CNT_base 1728 := rfl
+
+private theorem CNT_jLinePlaceZero_eq : jLinePlaceZero = CNT_base 0 := rfl
+
+private theorem CNT_deg_base (c : ℚ) : (CNT_base c).deg = 1 := by
+  rw [CNT_base, Place.deg_congrRingEquiv, deg_placeOfPoint]
+
+private theorem CNT_jLineRingEquiv_X_sub (c : ℚ) :
+    jLineRingEquiv ((RatFunc.X : RatFunc ℚ) - algebraMap ℚ (RatFunc ℚ) c) =
+      jGen - algebraMap ℚ ℚ⟮jq⟯ c := by
+  rw [map_sub, jLineRingEquiv_X]
+  congr 1
+  exact RingHom.map_rat_algebraMap jLineRingEquiv.toRingHom c
+
+private theorem CNT_ord_base (c : ℚ) : (CNT_base c).ord (jGen - algebraMap ℚ ℚ⟮jq⟯ c) = 1 := by
+  rw [← CNT_jLineRingEquiv_X_sub, CNT_base, Place.ord_congrRingEquiv, CNT_ord_placeOfPoint]
+
+private theorem CNT_eq_base_of_ord_pos (q : Place ℚ ℚ⟮jq⟯) (c : ℚ)
+    (h : 0 < q.ord (jGen - algebraMap ℚ ℚ⟮jq⟯ c)) : q = CNT_base c := by
+  have he : ∀ a : ℚ, jLineRingEquiv (algebraMap ℚ (RatFunc ℚ) a) = algebraMap ℚ ℚ⟮jq⟯ a :=
+    RingHom.map_rat_algebraMap jLineRingEquiv.toRingHom
+  have hx : jLineRingEquiv.symm (jGen - algebraMap ℚ ℚ⟮jq⟯ c) =
+      (RatFunc.X : RatFunc ℚ) - algebraMap ℚ (RatFunc ℚ) c := by
+    rw [← CNT_jLineRingEquiv_X_sub, RingEquiv.symm_apply_apply]
+  have h' : 0 < (Place.congrRingEquiv jLineRingEquiv.symm (Place.symm_algebraMap_comm _ he) q).ord
+      ((RatFunc.X : RatFunc ℚ) - algebraMap ℚ (RatFunc ℚ) c) := by
+    rw [← hx, Place.ord_congrRingEquiv]
+    exact h
+  have hq' := CNT_eq_placeOfPoint_of_ord_pos _ c h'
+  calc q = Place.congrEquiv jLineRingEquiv he ((Place.congrEquiv jLineRingEquiv he).symm q) :=
+        ((Place.congrEquiv jLineRingEquiv he).apply_symm_apply q).symm
+    _ = CNT_base c := by
+        rw [Place.congrEquiv_symm_apply, hq', Place.congrEquiv_apply]
+        rfl
+
+end JLine
+
+section Tower
+
+variable (N : ℕ) [NeZero N]
+
+private theorem CNT_algebraMap_jGen_sub (c : ℚ) :
+    algebraMap ℚ⟮jq⟯ (modularFunctionField N) (jGen - algebraMap ℚ ℚ⟮jq⟯ c) =
+      (⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N) c := by
+  rw [map_sub, ← IsScalarTower.algebraMap_apply]
+  congr 1
+
+private theorem CNT_ord_sub_eq_mul [Algebra.IsIntegral ℚ⟮jq⟯ (modularFunctionField N)]
+    (w : Place ℚ (modularFunctionField N)) (c : ℚ) :
+    w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N) c) =
+      w.ramificationIndex ℚ⟮jq⟯ * (w.restrict ℚ⟮jq⟯).ord (jGen - algebraMap ℚ ℚ⟮jq⟯ c) := by
+  rw [← CNT_algebraMap_jGen_sub, Place.ord_restrict]
+
+private theorem CNT_restrict_eq_base_iff [Algebra.IsIntegral ℚ⟮jq⟯ (modularFunctionField N)]
+    (w : Place ℚ (modularFunctionField N)) (c : ℚ) :
+    w.restrict ℚ⟮jq⟯ = CNT_base c ↔
+      0 < w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N)
+        c) := by
+  constructor
+  · intro h
+    rw [CNT_ord_sub_eq_mul N w c, h, CNT_ord_base, mul_one]
+    exact_mod_cast w.ramificationIndex_pos (F := ℚ⟮jq⟯)
+  · intro h
+    refine CNT_eq_base_of_ord_pos _ c ?_
+    rw [CNT_ord_sub_eq_mul N w c] at h
+    exact (pos_iff_pos_of_mul_pos h).mp
+      (by exact_mod_cast w.ramificationIndex_pos (F := ℚ⟮jq⟯))
+
+private theorem CNT_ramificationIndex_eq_ord [Algebra.IsIntegral ℚ⟮jq⟯ (modularFunctionField N)]
+    (w : Place ℚ (modularFunctionField N)) (c : ℚ)
+    (h : 0 < w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField
+      N) c)) :
+    (w.ramificationIndex ℚ⟮jq⟯ : ℤ) =
+      w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N) c)
+        := by
+  rw [CNT_ord_sub_eq_mul N w c, (CNT_restrict_eq_base_iff N w c).mpr h, CNT_ord_base, mul_one]
+
+private scoped instance CNT_finiteDimensional : FiniteDimensional ℚ⟮jq⟯ (modularFunctionField N) :=
+  Module.finite_of_finrank_pos (by
+    rw [finrank_jAdjoin_modularFunctionField_eq_dedekindPsi N]
+    exact dedekindPsi_pos N (NeZero.ne N))
+
+private scoped instance CNT_charZero : CharZero ℚ⟮jq⟯ :=
+  charZero_of_injective_algebraMap (algebraMap ℚ ℚ⟮jq⟯).injective
+
+private scoped instance CNT_isSeparable : Algebra.IsSeparable ℚ⟮jq⟯ (modularFunctionField N) :=
+  Algebra.IsSeparable.of_integral _ _
+
+private theorem CNT_exists_companion (x : modularFunctionField N) :
+    ∃ y : modularFunctionFieldBar N,
+      (y : LaurentSeries (AlgebraicClosure ℚ)) = coeffEmb (AlgebraicClosure ℚ) (x : LaurentSeries ℚ)
+        :=
+  ⟨⟨coeffEmb (AlgebraicClosure ℚ) (x : LaurentSeries ℚ),
+    coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionField_le_full N x.2)⟩, rfl⟩
+
+private theorem CNT_coe_jBar_sub (c : ℚ) :
+    ((jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) (c : AlgebraicClosure
+      ℚ) :
+        modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ)) =
+      coeffEmb (AlgebraicClosure ℚ)
+        (((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N) c :
+          modularFunctionField N) : LaurentSeries ℚ) := by
+  have h1 : (((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N) c :
+      modularFunctionField N) : LaurentSeries ℚ) = jq - (c : LaurentSeries ℚ) := by
+    rw [eq_ratCast (algebraMap ℚ (modularFunctionField N)) c, AddSubgroupClass.coe_sub,
+      SubfieldClass.coe_ratCast]
+  have h2 : ((jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) (c :
+    AlgebraicClosure ℚ) :
+      modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ)) =
+      coeffEmb (AlgebraicClosure ℚ) jq -
+        algebraMap (AlgebraicClosure ℚ) (LaurentSeries (AlgebraicClosure ℚ)) (c : AlgebraicClosure
+          ℚ) := rfl
+  rw [h1, h2, map_sub, map_ratCast, map_ratCast]
+
+private theorem CNT_eq_of_dominated (w w' : Place ℚ (modularFunctionField N))
+    (v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) (a a' : ℤ) (ha : 0 < a)
+    (ha' : 0 < a')
+    (h : ∀ (x : modularFunctionField N) (y : modularFunctionFieldBar N),
+      (y : LaurentSeries (AlgebraicClosure ℚ)) = coeffEmb (AlgebraicClosure ℚ) (x : LaurentSeries ℚ)
+        →
+        v.ord y = a * w.ord x)
+    (h' : ∀ (x : modularFunctionField N) (y : modularFunctionFieldBar N),
+      (y : LaurentSeries (AlgebraicClosure ℚ)) = coeffEmb (AlgebraicClosure ℚ) (x : LaurentSeries ℚ)
+        →
+        v.ord y = a' * w'.ord x) :
+    w = w' := by
+  apply Place.ext
+  ext x
+  rcases eq_or_ne x 0 with rfl | hx0
+  · simp
+  obtain ⟨y, hyx⟩ := CNT_exists_companion N x
+  have h1 := h x y hyx
+  have h2 := h' x y hyx
+  constructor
+  · intro hx
+    have h0 : 0 ≤ w.ord x := CNT_ord_nonneg_of_mem w hx
+    refine CNT_mem_of_ord_nonneg w' hx0 ?_
+    by_contra hneg
+    push Not at hneg
+    have := mul_neg_of_pos_of_neg ha' hneg
+    have := mul_nonneg ha.le h0
+    omega
+  · intro hx
+    have h0 : 0 ≤ w'.ord x := CNT_ord_nonneg_of_mem w' hx
+    refine CNT_mem_of_ord_nonneg w hx0 ?_
+    by_contra hneg
+    push Not at hneg
+    have := mul_neg_of_pos_of_neg ha hneg
+    have := mul_nonneg ha'.le h0
+    omega
+
+end Tower
+
+section Squeeze
+
+variable (N : ℕ) [NeZero N] [HasPrincipalDivisors ℚ (modularFunctionField N)]
+
+private theorem CNT_squeeze (c : ℚ) :
+    (∀ w : Place ℚ (modularFunctionField N),
+      0 < w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N)
+        c) →
+      ∃ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N),
+        ∀ (x : modularFunctionField N) (y : modularFunctionFieldBar N),
+          (y : LaurentSeries (AlgebraicClosure ℚ)) = coeffEmb (AlgebraicClosure ℚ) (x :
+            LaurentSeries ℚ) →
+            v.ord y = w.ord x) ∧
+    (∀ T : Finset (Place ℚ (modularFunctionField N)),
+      (∀ w, w ∈ T ↔
+        w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N) c)
+          = 1) →
+      ∑ w ∈ T, (w.deg : ℤ) =
+        Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+          v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+            (c : AlgebraicClosure ℚ)) = 1}) := by
+  classical
+  obtain ⟨P, hP⟩ := ModularCurve.exists_finset_ord_jBar_sub_pos N (c : AlgebraicClosure ℚ)
+  have hPEO := ModularCurve.sum_ord_jBar_sub_eq_dedekindPsi N (c : AlgebraicClosure ℚ)
+    (deg_eq_one_modularFunctionFieldBar N) P hP
+  have hW : ∀ w : Place ℚ (modularFunctionField N), w ∈ (CNT_base c).fiber (modularFunctionField N)
+    ↔
+      0 < w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N)
+        c) :=
+    fun w => by rw [Place.mem_fiber, CNT_restrict_eq_base_iff]
+  have hsum :=
+    Place.sum_ramificationIndex_mul_inertiaDeg (F' := modularFunctionField N) (CNT_base c)
+  rw [finrank_jAdjoin_modularFunctionField_eq_dedekindPsi N] at hsum
+  have hf : ∀ w ∈ (CNT_base c).fiber (modularFunctionField N), w.inertiaDeg ℚ⟮jq⟯ = w.deg := by
+    intro w hw
+    have h := w.deg_restrict_mul_inertiaDeg (F := ℚ⟮jq⟯)
+    rwa [Place.mem_fiber.mp hw, CNT_deg_base, one_mul] at h
+  have he : ∀ w ∈ (CNT_base c).fiber (modularFunctionField N), (w.ramificationIndex ℚ⟮jq⟯ : ℤ) =
+      w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N) c) :=
+    fun w hw => CNT_ramificationIndex_eq_ord N w c ((hW w).mp hw)
+  have hdegpos : ∀ w ∈ (CNT_base c).fiber (modularFunctionField N), 1 ≤ w.deg := by
+    intro w hw
+    rw [← hf w hw]
+    exact Nat.succ_le_of_lt (Place.inertiaDeg_pos_of_finiteDimensional (F := ℚ⟮jq⟯) w)
+  have hsumW : ∑ w ∈ (CNT_base c).fiber (modularFunctionField N),
+      (w.deg : ℤ) * w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ
+        (modularFunctionField N) c) =
+        dedekindPsi N := by
+    rw [← hsum]
+    refine Finset.sum_congr rfl fun w hw => ?_
+    rw [he w hw, hf w hw, mul_comm]
+  have hdom : ∀ w ∈ (CNT_base c).fiber (modularFunctionField N),
+      ∃ S : Finset (Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)), w.deg ≤ S.card ∧ ∀ v ∈
+        S,
+        ∃ a : ℤ, 0 < a ∧ ∀ (x : modularFunctionField N) (y : modularFunctionFieldBar N),
+          (y : LaurentSeries (AlgebraicClosure ℚ)) = coeffEmb (AlgebraicClosure ℚ) (x :
+            LaurentSeries ℚ) →
+            v.ord y = a * w.ord x := by
+    intro w hw
+    have hj : 0 ≤ w.ord (⟨jq, jq_mem N⟩ : modularFunctionField N) :=
+      CNT_ord_nonneg_of_mem w (CNT_mem_of_ord_sub_pos w ((hW w).mp hw))
+    obtain ⟨S, hcard, hS⟩ := ModularCurve.exists_finset_place_bar_dominating_of_ord_jq_nonneg N w hj
+    exact ⟨S, hcard, fun v hv => (hS v hv).2⟩
+  choose! S hScard hSdom using hdom
+  choose! a hapos ha using hSdom
+  set jc : modularFunctionField N :=
+    (⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N) c with hjc
+  set jBc : modularFunctionFieldBar N :=
+    jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) (c : AlgebraicClosure ℚ)
+      with hjBc
+  set W : Finset (Place ℚ (modularFunctionField N)) := (CNT_base c).fiber (modularFunctionField N)
+    with hWdef
+  have hrel : (jBc : LaurentSeries (AlgebraicClosure ℚ)) = coeffEmb (AlgebraicClosure ℚ) (jc :
+    LaurentSeries ℚ) :=
+    by
+    rw [hjc, hjBc]
+    exact CNT_coe_jBar_sub N c
+  have hjc_pos : ∀ w ∈ W, 0 < w.ord jc := fun w hw => (hW w).mp hw
+  have hordv : ∀ w ∈ W, ∀ v ∈ S w, v.ord jBc = a w v * w.ord jc :=
+    fun w hw v hv => ha w hw v hv jc jBc hrel
+  have hSP : ∀ w ∈ W, S w ⊆ P := fun w hw v hv =>
+    (hP v).mpr (by rw [hordv w hw v hv]; exact mul_pos (hapos w hw v hv) (hjc_pos w hw))
+  have hdisj : (W : Set (Place ℚ (modularFunctionField N))).PairwiseDisjoint S := by
+    intro w hw w' hw' hne
+    change Disjoint (S w) (S w')
+    refine Finset.disjoint_left.mpr fun v hv hv' => hne ?_
+    exact CNT_eq_of_dominated N w w' v (a w v) (a w' v) (hapos w hw v hv) (hapos w' hw' v hv')
+      (ha w hw v hv) (ha w' hw' v hv')
+  have hUP : W.biUnion S ⊆ P := Finset.biUnion_subset.mpr hSP
+  have hAB : ∑ w ∈ W, (w.deg : ℤ) * w.ord jc ≤ ∑ w ∈ W, ∑ v ∈ S w, w.ord jc := by
+    refine Finset.sum_le_sum fun w hw => ?_
+    rw [Finset.sum_const, nsmul_eq_mul]
+    exact mul_le_mul_of_nonneg_right (by exact_mod_cast hScard w hw) (hjc_pos w hw).le
+  have hBC : ∑ w ∈ W, ∑ v ∈ S w, w.ord jc ≤ ∑ w ∈ W, ∑ v ∈ S w, a w v * w.ord jc := by
+    refine Finset.sum_le_sum fun w hw => Finset.sum_le_sum fun v hv => ?_
+    exact le_mul_of_one_le_left (hjc_pos w hw).le (by have := hapos w hw v hv; omega)
+  have hCD : ∑ w ∈ W, ∑ v ∈ S w, a w v * w.ord jc = ∑ v ∈ W.biUnion S, v.ord jBc := by
+    rw [Finset.sum_biUnion hdisj]
+    exact Finset.sum_congr rfl fun w hw => Finset.sum_congr rfl fun v hv => (hordv w hw v hv).symm
+  have hDP : ∑ v ∈ W.biUnion S, v.ord jBc ≤ dedekindPsi N := by
+    rw [← hPEO]
+    exact Finset.sum_le_sum_of_subset_of_nonneg hUP fun v hv _ => ((hP v).mp hv).le
+  have hBCeq : ∑ w ∈ W, ∑ v ∈ S w, w.ord jc = ∑ w ∈ W, ∑ v ∈ S w, a w v * w.ord jc := by
+    linarith
+  have hABeq : ∑ w ∈ W, (w.deg : ℤ) * w.ord jc = ∑ w ∈ W, ∑ v ∈ S w, w.ord jc := by
+    linarith
+  have hDPeq : ∑ v ∈ W.biUnion S, v.ord jBc = dedekindPsi N := by
+    linarith
+  have ha1 : ∀ w ∈ W, ∀ v ∈ S w, a w v = 1 := by
+    by_contra hcon
+    push Not at hcon
+    obtain ⟨w, hw, v, hv, hne⟩ := hcon
+    have hlt : ∑ w ∈ W, ∑ v ∈ S w, w.ord jc < ∑ w ∈ W, ∑ v ∈ S w, a w v * w.ord jc := by
+      refine Finset.sum_lt_sum (fun w' hw' => Finset.sum_le_sum fun v' hv' =>
+        le_mul_of_one_le_left (hjc_pos w' hw').le (by
+          have := hapos w' hw' v' hv'; omega)) ⟨w, hw, ?_⟩
+      refine Finset.sum_lt_sum (fun v' hv' =>
+        le_mul_of_one_le_left (hjc_pos w hw).le (by have := hapos w hw v' hv'; omega)) ⟨v, hv, ?_⟩
+      exact lt_mul_of_one_lt_left (hjc_pos w hw) (by have := hapos w hw v hv; omega)
+    linarith
+  have hcardS : ∀ w ∈ W, (S w).card = w.deg := by
+    by_contra hcon
+    push Not at hcon
+    obtain ⟨w, hw, hne⟩ := hcon
+    have hlt' : w.deg < (S w).card := lt_of_le_of_ne (hScard w hw) (Ne.symm hne)
+    have hlt : ∑ w ∈ W, (w.deg : ℤ) * w.ord jc < ∑ w ∈ W, ∑ v ∈ S w, w.ord jc := by
+      refine Finset.sum_lt_sum (fun w' hw' => ?_) ⟨w, hw, ?_⟩
+      · rw [Finset.sum_const, nsmul_eq_mul]
+        exact mul_le_mul_of_nonneg_right (by exact_mod_cast hScard w' hw') (hjc_pos w' hw').le
+      · rw [Finset.sum_const, nsmul_eq_mul]
+        exact mul_lt_mul_of_pos_right (by exact_mod_cast hlt') (hjc_pos w hw)
+    linarith
+  have hPU : ∀ v ∈ P, v ∈ W.biUnion S := by
+    intro v hv
+    by_contra hvU
+    have hsd := Finset.sum_sdiff (f := fun u => u.ord jBc) hUP
+    have hzero : ∑ u ∈ P \ W.biUnion S, u.ord jBc = 0 := by linarith
+    have hv' : v ∈ P \ W.biUnion S := Finset.mem_sdiff.mpr ⟨hv, hvU⟩
+    have h0 := (Finset.sum_eq_zero_iff_of_nonneg (fun u hu =>
+      ((hP u).mp (Finset.mem_sdiff.mp hu).1).le)).mp hzero v hv'
+    exact absurd h0 ((hP v).mp hv).ne'
+  refine ⟨fun w hw0 => ?_, fun T hT => ?_⟩
+  · have hw : w ∈ W := (hW w).mpr hw0
+    have hne : (S w).Nonempty := by
+      rw [← Finset.card_pos, hcardS w hw]
+      exact hdegpos w hw
+    obtain ⟨v, hv⟩ := hne
+    refine ⟨v, fun x y hxy => ?_⟩
+    rw [ha w hw v hv x y hxy, ha1 w hw v hv, one_mul]
+  · have hTW : T = W.filter (fun w => w.ord jc = 1) := by
+      ext w
+      rw [hT, Finset.mem_filter, hW]
+      constructor
+      · intro h
+        exact ⟨by omega, h⟩
+      · exact fun h => h.2
+    have hmem : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N),
+        v.ord jBc = 1 ↔ v ∈ (W.filter (fun w => w.ord jc = 1)).biUnion S := by
+      intro v
+      rw [Finset.mem_biUnion]
+      constructor
+      · intro h1
+        have hvP : v ∈ P := (hP v).mpr (by omega)
+        obtain ⟨w, hw, hv⟩ := Finset.mem_biUnion.mp (hPU v hvP)
+        refine ⟨w, Finset.mem_filter.mpr ⟨hw, ?_⟩, hv⟩
+        have h2 := hordv w hw v hv
+        rw [ha1 w hw v hv, one_mul] at h2
+        omega
+      · rintro ⟨w, hw, hv⟩
+        rw [Finset.mem_filter] at hw
+        rw [hordv w hw.1 v hv, ha1 w hw.1 v hv, one_mul, hw.2]
+    have hdisj' : ((W.filter (fun w => w.ord jc = 1) : Finset (Place ℚ (modularFunctionField N))) :
+        Set (Place ℚ (modularFunctionField N))).PairwiseDisjoint S :=
+      hdisj.subset (fun w hw => (Finset.mem_filter.mp hw).1)
+    have hcard : Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // v.ord jBc =
+      1} =
+        ((W.filter (fun w => w.ord jc = 1)).biUnion S).card := by
+      rw [Nat.card_congr (Equiv.subtypeEquivRight hmem), Nat.card_eq_fintype_card, Fintype.card_coe]
+    rw [hcard, Finset.card_biUnion hdisj', hTW]
+    push_cast
+    exact Finset.sum_congr rfl fun w hw => by rw [hcardS w (Finset.mem_filter.mp hw).1]
+
+private theorem CNT_face [Algebra.IsIntegral ℚ⟮jq⟯ (modularFunctionField N)] (c : ℚ) :
+    ∑ w ∈ ((CNT_base c).fiber (modularFunctionField N)).filter (fun w => w.ramificationIndex ℚ⟮jq⟯ =
+      1),
+        (w.inertiaDeg ℚ⟮jq⟯ : ℤ) =
+      (Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+        v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+          (c : AlgebraicClosure ℚ)) = 1} : ℤ) := by
+  rw [← (CNT_squeeze N c).2
+    (((CNT_base c).fiber (modularFunctionField N)).filter (fun w => w.ramificationIndex ℚ⟮jq⟯ = 1))
+    ?_]
+  · refine Finset.sum_congr rfl fun w hw => ?_
+    rw [Finset.mem_filter, Place.mem_fiber] at hw
+    have h := w.deg_restrict_mul_inertiaDeg (F := ℚ⟮jq⟯)
+    rw [hw.1, CNT_deg_base, one_mul] at h
+    rw [h]
+  · intro w
+    rw [Finset.mem_filter, Place.mem_fiber, CNT_restrict_eq_base_iff]
+    constructor
+    · rintro ⟨hpos, he1⟩
+      rw [← CNT_ramificationIndex_eq_ord N w c hpos, he1, Nat.cast_one]
+    · intro h1
+      have hpos : 0 < w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) -
+          algebraMap ℚ (modularFunctionField N) c) := by omega
+      refine ⟨hpos, ?_⟩
+      have h2 := CNT_ramificationIndex_eq_ord N w c hpos
+      rw [h1] at h2
+      exact_mod_cast h2
+
+end Squeeze
+
+end CNTUnit
+end
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.exists_place_bar_ord_eq_of_ord_jq_sub_pos (N : ℕ) [NeZero N]
+    [HasPrincipalDivisors ℚ (modularFunctionField N)] (c : ℚ)
+    (w : Place ℚ (modularFunctionField N))
+    (hw : 0 < w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField
+      N) c)) :
+    ∃ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N),
+      ∀ (x : modularFunctionField N) (y : modularFunctionFieldBar N),
+        (y : LaurentSeries (AlgebraicClosure ℚ)) = coeffEmb (AlgebraicClosure ℚ) (x : LaurentSeries
+          ℚ) →
+          v.ord y = w.ord x := by
+  exact (CNTUnit.CNT_squeeze N c).1 w hw
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.sum_deg_ord_jq_sub_eq_one_eq_natCard_ord_jBar_sub_eq_one (N : ℕ)
+    [NeZero N]
+    [HasPrincipalDivisors ℚ (modularFunctionField N)] (c : ℚ)
+    (T : Finset (Place ℚ (modularFunctionField N)))
+    (hT : ∀ w, w ∈ T ↔
+      w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N) c) =
+        1) :
+    ∑ w ∈ T, (w.deg : ℤ) =
+      Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+        v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) (c :
+          AlgebraicClosure ℚ)) = 1} := by
+  exact (CNTUnit.CNT_squeeze N c).2 T hT
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.sum_inertiaDeg_unramified_fiber_jLinePlace1728_eq_natCard_bar (N : ℕ)
+    [NeZero N]
+    [HasPrincipalDivisors ℚ ↥(modularFunctionField N)] :
+    letI := jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮jq⟯ ↥(modularFunctionField N)],
+    ∑ w ∈ (jLinePlace1728.fiber ↥(modularFunctionField N)).filter (fun w => w.ramificationIndex
+      ↥ℚ⟮jq⟯ = 1),
+        (w.inertiaDeg ↥ℚ⟮jq⟯ : ℤ) =
+      (Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // v.ord (jBar N - 1728)
+        = 1} : ℤ) := by
+  intro hint
+  have h := CNTUnit.CNT_face N (1728 : ℚ)
+  rw [← CNTUnit.CNT_jLinePlace1728_eq, Rat.cast_ofNat, map_ofNat] at h
+  exact h
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.sum_inertiaDeg_unramified_fiber_jLinePlaceZero_eq_natCard_bar (N : ℕ)
+    [NeZero N]
+    [HasPrincipalDivisors ℚ ↥(modularFunctionField N)] :
+    letI := jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮jq⟯ ↥(modularFunctionField N)],
+    ∑ w ∈ (jLinePlaceZero.fiber ↥(modularFunctionField N)).filter (fun w => w.ramificationIndex
+      ↥ℚ⟮jq⟯ = 1),
+        (w.inertiaDeg ↥ℚ⟮jq⟯ : ℤ) =
+      (Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // v.ord (jBar N) = 1} :
+        ℤ) := by
+  intro hint
+  have h := CNTUnit.CNT_face N (0 : ℚ)
+  rw [← CNTUnit.CNT_jLinePlaceZero_eq, Rat.cast_zero, map_zero, sub_zero] at h
+  exact h
+
+p2m_open "IntermediateField AlgebraicCurve ModularCurve \
+  P2MW.S_ModularCurve_natCard_ord_jBar_eq_one_eq_nuThree.ModularCurve"
+open IsDedekindDomain WithZero
+
+section EFIX
+
+private theorem JD_ofNat_eq_algebraMap_bar (N : ℕ) [NeZero N] (k : ℕ) [k.AtLeastTwo] :
+    (OfNat.ofNat k : modularFunctionFieldBar N) =
+      algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+        (OfNat.ofNat k : AlgebraicClosure ℚ) := by
+  simp [map_ofNat]
+
+private theorem JD_zero_eq_algebraMap_bar (N : ℕ) [NeZero N] :
+    (0 : modularFunctionFieldBar N) =
+      algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+        (0 : AlgebraicClosure ℚ) := (map_zero _).symm
+
+private theorem JD_finset_card_eq_natCard {α : Type*} {S : Finset α} {P : α → Prop}
+    (hS : ∀ v, v ∈ S ↔ P v) : S.card = Nat.card {v // P v} := by
+  have heq : {v | P v} = (S : Set α) := Set.ext fun v => (hS v).symm
+  rw [show Nat.card {v // P v} = {v | P v}.ncard from (Nat.card_coe_set_eq _),
+    heq, Set.ncard_coe_finset]
+
+private theorem JD_pos_dvd_two {n : ℤ} (hpos : 0 < n) (hdvd : n ∣ 2) : n = 1 ∨ n = 2 := by
+  have hle : n ≤ 2 := Int.le_of_dvd two_pos hdvd
+  interval_cases n
+  · exact Or.inl rfl
+  · exact Or.inr rfl
+
+private theorem JD_pos_dvd_three {n : ℤ} (hpos : 0 < n) (hdvd : n ∣ 3) : n = 1 ∨ n = 3 := by
+  have hle : n ≤ 3 := Int.le_of_dvd three_pos hdvd
+  interval_cases n
+  · exact Or.inl rfl
+  · exact absurd hdvd (by decide)
+  · exact Or.inr rfl
+
+private theorem JD_efix_core {α : Type*} (S : Finset α) (f : α → ℤ) (k : ℤ) (hk : k ≠ 1)
+    (hmem : ∀ v ∈ S, f v = 1 ∨ f v = k)
+    (ψ : ℤ) (hsum : ∑ v ∈ S, f v = ψ) :
+    let a := (S.filter (fun v => f v = 1)).card
+    let b := (S.filter (fun v => f v = k)).card
+    (a : ℤ) + k * b = ψ ∧ a + b = S.card := by
+  classical
+  intro a b
+  have hdisj : Disjoint (S.filter (fun v => f v = 1)) (S.filter (fun v => f v = k)) := by
+    refine Finset.disjoint_filter.mpr fun v _ h1 hk' => ?_
+    exact hk (h1 ▸ hk').symm
+  have hunion : S.filter (fun v => f v = 1) ∪ S.filter (fun v => f v = k) = S := by
+    ext v
+    simp only [Finset.mem_union, Finset.mem_filter]
+    refine ⟨fun h => h.elim And.left And.left, fun hv => ?_⟩
+    rcases hmem v hv with h1 | h2
+    · exact Or.inl ⟨hv, h1⟩
+    · exact Or.inr ⟨hv, h2⟩
+  refine ⟨?_, ?_⟩
+  · rw [← hsum, ← hunion, Finset.sum_union hdisj]
+    have hs1 : ∑ v ∈ S.filter (fun v => f v = 1), f v
+        = (S.filter (fun v => f v = 1)).card := by
+      rw [Finset.sum_congr rfl fun v hv => (Finset.mem_filter.mp hv).2,
+        Finset.sum_const, nsmul_eq_mul, mul_one]
+    have hs2 : ∑ v ∈ S.filter (fun v => f v = k), f v
+        = k * (S.filter (fun v => f v = k)).card := by
+      rw [Finset.sum_congr rfl fun v hv => (Finset.mem_filter.mp hv).2,
+        Finset.sum_const, nsmul_eq_mul, mul_comm]
+    rw [hs1, hs2]
+  · rw [← Finset.card_union_of_disjoint hdisj, hunion]
+
+end EFIX
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo (N : ℕ) [NeZero N]
+    (h2 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N - 1728) →
+      v.ord (jBar N - 1728) ∣ 2)
+    [DecidableEq (AlgebraicClosure ℚ)]
+    (hcount : Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // 0 < v.ord
+      (jBar N - 1728)} =
+      Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) // ModuliPoint.j x = (1728 : AlgebraicClosure
+        ℚ)}) :
+    Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // v.ord (jBar N - 1728) =
+      1} = nuTwo N := by
+  obtain ⟨S, hS⟩ := exists_finset_ord_jBar_sub_pos N (1728 : AlgebraicClosure ℚ)
+  have h1728 : jBar N - (1728 : modularFunctionFieldBar N) =
+      jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) (1728 : AlgebraicClosure
+        ℚ) := by
+    rw [JD_ofNat_eq_algebraMap_bar]
+  simp only [← h1728] at hS
+  have hmem : ∀ v ∈ S, v.ord (jBar N - 1728) = 1 ∨ v.ord (jBar N - 1728) = 2 := fun v hv =>
+    JD_pos_dvd_two ((hS v).mp hv) (h2 v ((hS v).mp hv))
+  have hsum : ∑ v ∈ S, v.ord (jBar N - 1728) = dedekindPsi N := by
+    have := sum_ord_jBar_sub_eq_dedekindPsi N (1728 : AlgebraicClosure ℚ)
+      (deg_eq_one_modularFunctionFieldBar N) S (by simp only [← h1728]; exact hS)
+    simpa only [← h1728] using this
+  obtain ⟨hab_psi, hab_card⟩ := JD_efix_core S (fun v => v.ord (jBar N - 1728)) 2 (by norm_num)
+    hmem (dedekindPsi N : ℤ) hsum
+  set a := (S.filter (fun v => v.ord (jBar N - 1728) = 1)).card with ha
+  set b := (S.filter (fun v => v.ord (jBar N - 1728) = 2)).card with hb
+  have hScard : S.card =
+      Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+        0 < v.ord (jBar N - 1728)} :=
+    JD_finset_card_eq_natCard hS
+  have hSpts : S.card = Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) //
+      ModuliPoint.j x = (1728 : AlgebraicClosure ℚ)} := hScard.trans hcount
+  have hmass :=
+    two_mul_natCard_moduliPoint_j_eq_1728_eq_dedekindPsi_add_nuTwo N (AlgebraicClosure ℚ)
+  have ha_nu : a = nuTwo N := by
+    have h2S : 2 * S.card = dedekindPsi N + nuTwo N := by rw [hSpts]; exact hmass
+    have h2ab : 2 * (a + b) = dedekindPsi N + nuTwo N := by rw [hab_card]; exact h2S
+    omega
+  have hcarda : a = Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+      v.ord (jBar N - 1728) = 1} := by
+    refine JD_finset_card_eq_natCard fun v => ?_
+    simp only [Finset.mem_filter, hS]
+    exact ⟨fun ⟨_, h1⟩ => h1, fun h1 => ⟨h1 ▸ one_pos, h1⟩⟩
+  rw [← hcarda, ha_nu]
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.natCard_ord_jBar_eq_one_eq_nuThree (N : ℕ) [NeZero N]
+    (h1 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N) → v.ord
+      (jBar N) ∣ 3)
+    [DecidableEq (AlgebraicClosure ℚ)]
+    (hcount : Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // 0 < v.ord
+      (jBar N)} =
+      Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) // ModuliPoint.j x = (0 : AlgebraicClosure
+        ℚ)}) :
+    Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // v.ord (jBar N) = 1} =
+      nuThree N := by
+  obtain ⟨S, hS⟩ := exists_finset_ord_jBar_sub_pos N (0 : AlgebraicClosure ℚ)
+  have h0 : jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+      (0 : AlgebraicClosure ℚ) = jBar N := by rw [map_zero, sub_zero]
+  simp only [h0] at hS
+  have hmem : ∀ v ∈ S, v.ord (jBar N) = 1 ∨ v.ord (jBar N) = 3 := fun v hv =>
+    JD_pos_dvd_three ((hS v).mp hv) (h1 v ((hS v).mp hv))
+  have hsum : ∑ v ∈ S, v.ord (jBar N) = dedekindPsi N := by
+    have := sum_ord_jBar_sub_eq_dedekindPsi N (0 : AlgebraicClosure ℚ)
+      (deg_eq_one_modularFunctionFieldBar N) S (by simp only [h0]; exact hS)
+    simpa only [h0] using this
+  obtain ⟨hab_psi, hab_card⟩ := JD_efix_core S (fun v => v.ord (jBar N)) 3 (by norm_num)
+    hmem (dedekindPsi N : ℤ) hsum
+  set a := (S.filter (fun v => v.ord (jBar N) = 1)).card with ha
+  set b := (S.filter (fun v => v.ord (jBar N) = 3)).card with hb
+  have hScard : S.card =
+      Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+        0 < v.ord (jBar N)} := JD_finset_card_eq_natCard hS
+  have hSpts : S.card = Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) //
+      ModuliPoint.j x = (0 : AlgebraicClosure ℚ)} := hScard.trans hcount
+  have hmass := three_mul_natCard_moduliPoint_j_eq_zero_eq_dedekindPsi_add_two_mul_nuThree N
+    (AlgebraicClosure ℚ)
+  have ha_nu : a = nuThree N := by
+    have h3S : 3 * S.card = dedekindPsi N + 2 * nuThree N := by rw [hSpts]; exact hmass
+    have h3ab : 3 * (a + b) = dedekindPsi N + 2 * nuThree N := by rw [hab_card]; exact h3S
+    omega
+  have hcarda : a = Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+      v.ord (jBar N) = 1} := by
+    refine JD_finset_card_eq_natCard fun v => ?_
+    simp only [Finset.mem_filter, hS]
+    exact ⟨fun ⟨_, h1⟩ => h1, fun h1 => ⟨h1 ▸ one_pos, h1⟩⟩
+  rw [← hcarda, ha_nu]
+
+section JDHelpers
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+private theorem JD_ord_nonneg_of_mem (v : Place K F) {f : F} (hf : f ∈ v.toValuationSubring) :
+    0 ≤ v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨n, u, hu⟩ :=
+    IsDiscreteValuationRing.eq_unit_mul_pow_irreducible
+      (x := (⟨f, hf⟩ : v.toValuationSubring)) (by simpa [Subtype.ext_iff] using hf0) hπ
+  have hcoe : f = ((u : v.toValuationSubring) : F) * ((π : F) ^ (n : ℤ)) := by
+    have h := congrArg (Subtype.val) hu
+    push_cast at h
+    rw [zpow_natCast]
+    exact h
+  rw [hcoe, v.ord_unit_smul_zpow u hπ (n : ℤ)]
+  exact Int.natCast_nonneg n
+
+end JDHelpers
+
+section JDOrdHelper
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+private theorem JD_mem_of_ord_pos (w : Place K F) {f : F} (h : 0 < w.ord f) :
+    f ∈ w.toValuationSubring := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact zero_mem _
+  · obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+    obtain ⟨u, hu⟩ := w.exists_unit_mul_zpow hf0 hπ
+    rw [hu, show w.ord f = (((w.ord f).toNat : ℕ) : ℤ) from (Int.toNat_of_nonneg h.le).symm,
+      zpow_natCast]
+    exact mul_mem (u : w.toValuationSubring).2 (pow_mem (π : w.toValuationSubring).2 _)
+
+private theorem JD_ord_nonneg_of_ord_sub_ofNat_pos (w : Place K F) (k : ℕ) [k.AtLeastTwo]
+    {f : F} (h : 0 < w.ord (f - (OfNat.ofNat k : F))) : 0 ≤ w.ord f := by
+  have hmem : f ∈ w.toValuationSubring := by
+    have h1 : (f - OfNat.ofNat k) + OfNat.ofNat k ∈ w.toValuationSubring :=
+      add_mem (JD_mem_of_ord_pos w h)
+        (show (OfNat.ofNat k : F) ∈ w.toValuationSubring from
+          map_ofNat (algebraMap K F) k ▸ w.algebraMap_mem' (OfNat.ofNat k : K))
+    simpa using h1
+  exact JD_ord_nonneg_of_mem w hmem
+
+end JDOrdHelper
+
+section JDAux1
+p2m_open "IntermediateField AlgebraicCurve AlgebraicCurve.RationalFunctionField ModularCurve \
+  P2MW.S_ModularCurve_natCard_ord_jBar_eq_one_eq_nuThree.ModularCurve"
+attribute [local instance 2000] RatFunc.instAlgebraOfPolynomial
+attribute [local instance] instDecidableEqRatFuncRat
+attribute [local instance] jAdjoinAlgebra
+
+private theorem JD_one_le_deg_jAdjoin (q : Place ℚ ℚ⟮jq⟯) : 1 ≤ q.deg := by
+  have he : ∀ a : ℚ, jLineRingEquiv (algebraMap ℚ (RatFunc ℚ) a) = algebraMap ℚ ℚ⟮jq⟯ a :=
+    RingHom.map_rat_algebraMap jLineRingEquiv.toRingHom
+  have h := RationalFunctionField.deg_ne_zero ((Place.congrEquiv jLineRingEquiv he).symm q)
+  have hq : q = Place.congrEquiv jLineRingEquiv he ((Place.congrEquiv jLineRingEquiv he).symm q) :=
+    ((Place.congrEquiv jLineRingEquiv he).apply_symm_apply q).symm
+  rw [hq, Place.congrEquiv_apply, Place.deg_congrRingEquiv]
+  exact Nat.one_le_iff_ne_zero.mpr h
+
+private theorem JD_deg_restrict_jAdjoin_pos (N : ℕ) [NeZero N] :
+    letI := jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮jq⟯ ↥(modularFunctionField N)]
+      (w : Place ℚ ↥(modularFunctionField N)),
+      1 ≤ (w.restrict ↥ℚ⟮jq⟯).deg := by
+  intro _ w
+  exact JD_one_le_deg_jAdjoin _
+
+end JDAux1
+
+section JDHelpersModular
+
+variable (N : ℕ) [NeZero N]
+
+attribute [local instance] jAdjoinAlgebra
+
+private theorem JD_finiteDimensional_jAdjoin :
+    FiniteDimensional ℚ⟮jq⟯ (modularFunctionField N) :=
+  FiniteDimensional.of_finrank_pos
+    ((finrank_jAdjoin_modularFunctionField_eq_dedekindPsi N).symm ▸
+      dedekindPsi_pos N (NeZero.ne N))
+
+private theorem JD_coeffEmb_sub_1728 :
+    ((jBar N - 1728 : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ)) =
+      coeffEmb (AlgebraicClosure ℚ)
+        (((⟨jq, jq_mem N⟩ : modularFunctionField N) - 1728 :
+            modularFunctionField N) : LaurentSeries ℚ) := by
+  rw [AddSubgroupClass.coe_sub, AddSubgroupClass.coe_sub, map_sub]
+  congr 1
+  rw [show ((1728 : modularFunctionField N) : LaurentSeries ℚ) = (1728 : LaurentSeries ℚ) from
+      map_ofNat (modularFunctionField N).subtype 1728, map_ofNat]
+  exact (map_ofNat (modularFunctionFieldBar N).subtype 1728)
+
+private theorem JD_coeffEmb_j :
+    ((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ)) =
+      coeffEmb (AlgebraicClosure ℚ)
+        ((⟨jq, jq_mem N⟩ : modularFunctionField N) : LaurentSeries ℚ) := rfl
+
+private theorem JD_deg_pos_of_restrict_eq_jLinePlace1728
+    [Algebra.IsIntegral ↥ℚ⟮jq⟯ ↥(modularFunctionField N)]
+    (w : Place ℚ (modularFunctionField N))
+    (hw : w.restrict ↥ℚ⟮jq⟯ = jLinePlace1728) : 1 ≤ w.deg := by
+  have := JD_finiteDimensional_jAdjoin N
+  have hd := w.deg_restrict_mul_inertiaDeg (F := ↥ℚ⟮jq⟯)
+  rw [hw, deg_jLinePlace1728, one_mul] at hd
+  rw [← hd]
+  exact w.inertiaDeg_pos_of_finiteDimensional (F := ↥ℚ⟮jq⟯)
+
+private theorem JD_deg_pos_of_restrict_eq_jLinePlaceZero
+    [Algebra.IsIntegral ↥ℚ⟮jq⟯ ↥(modularFunctionField N)]
+    (w : Place ℚ (modularFunctionField N))
+    (hw : w.restrict ↥ℚ⟮jq⟯ = jLinePlaceZero) : 1 ≤ w.deg := by
+  have := JD_finiteDimensional_jAdjoin N
+  have hd := w.deg_restrict_mul_inertiaDeg (F := ↥ℚ⟮jq⟯)
+  rw [hw, deg_jLinePlaceZero, one_mul] at hd
+  rw [← hd]
+  exact w.inertiaDeg_pos_of_finiteDimensional (F := ↥ℚ⟮jq⟯)
+
+private theorem JD_deg_pos
+    [Algebra.IsIntegral ↥ℚ⟮jq⟯ ↥(modularFunctionField N)]
+    (w : Place ℚ (modularFunctionField N)) : 1 ≤ w.deg := by
+  have := JD_finiteDimensional_jAdjoin N
+  have hd := w.deg_restrict_mul_inertiaDeg (F := ↥ℚ⟮jq⟯)
+  calc 1 ≤ (w.restrict ↥ℚ⟮jq⟯).deg * 1 := by
+        simpa using JD_deg_restrict_jAdjoin_pos N w
+    _ ≤ (w.restrict ↥ℚ⟮jq⟯).deg * w.inertiaDeg ↥ℚ⟮jq⟯ :=
+        Nat.mul_le_mul_left _ (w.inertiaDeg_pos_of_finiteDimensional (F := ↥ℚ⟮jq⟯))
+    _ = w.deg := hd
+
+private theorem JD_ord_algebraMap_eq_zero {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) {a : K} (_ha : a ≠ 0) : v.ord (algebraMap K F a) = 0 := by
+  have h1 : 0 ≤ v.ord (algebraMap K F a) := JD_ord_nonneg_of_mem v (v.algebraMap_mem' a)
+  have h2 : 0 ≤ v.ord (algebraMap K F a)⁻¹ := by
+    rw [← map_inv₀]
+    exact JD_ord_nonneg_of_mem v (v.algebraMap_mem' a⁻¹)
+  rw [v.ord_inv] at h2
+  omega
+
+private theorem JD_coeffEmb_aeval (p : Polynomial ℚ) :
+    ((Polynomial.aeval (jBar N) p : modularFunctionFieldBar N)
+        : LaurentSeries (AlgebraicClosure ℚ)) =
+      coeffEmb (AlgebraicClosure ℚ)
+        ((Polynomial.aeval (⟨jq, jq_mem N⟩ : modularFunctionField N) p
+            : modularFunctionField N) : LaurentSeries ℚ) := by
+  induction p using Polynomial.induction_on with
+  | C a =>
+    simp only [Polynomial.aeval_C]
+    rw [eq_ratCast (algebraMap ℚ (modularFunctionFieldBar N)) a,
+      eq_ratCast (algebraMap ℚ (modularFunctionField N)) a,
+      SubfieldClass.coe_ratCast, SubfieldClass.coe_ratCast, map_ratCast]
+  | add f g ihf ihg =>
+    simp only [map_add, AddMemClass.coe_add, ihf, ihg]
+  | monomial n a _ih =>
+    simp only [map_mul, map_pow, Polynomial.aeval_X, MulMemClass.coe_mul,
+      SubmonoidClass.coe_pow, Polynomial.aeval_C]
+    rw [eq_ratCast (algebraMap ℚ (modularFunctionFieldBar N)) a,
+      eq_ratCast (algebraMap ℚ (modularFunctionField N)) a,
+      SubfieldClass.coe_ratCast, SubfieldClass.coe_ratCast, map_ratCast]
+
+private theorem JD_exists_bar_ord_eq_mul_ram_1728
+    [Algebra.IsIntegral ↥ℚ⟮jq⟯ ↥(modularFunctionField N)]
+    (w : Place ℚ (modularFunctionField N))
+    (hw : w.restrict ↥ℚ⟮jq⟯ = jLinePlace1728) :
+    ∃ (v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) (c : ℤ),
+      0 < c ∧ v.ord (jBar N - 1728) = c * (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) := by
+  have hordpos : 0 < w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - 1728) :=
+    (restrict_eq_jLinePlace1728_iff N w).mp hw
+  have hjnn : 0 ≤ w.ord (⟨jq, jq_mem N⟩ : modularFunctionField N) :=
+    JD_ord_nonneg_of_ord_sub_ofNat_pos w 1728 hordpos
+  obtain ⟨S, hSdeg, hSmem⟩ := exists_finset_place_bar_dominating_of_ord_jq_nonneg N w hjnn
+  have hSne : S.Nonempty :=
+    Finset.card_pos.mp (lt_of_lt_of_le (JD_deg_pos_of_restrict_eq_jLinePlace1728 N w hw) hSdeg)
+  obtain ⟨v, hvS⟩ := hSne
+  obtain ⟨_, c, hcpos, hcord⟩ := hSmem v hvS
+  refine ⟨v, c, hcpos, ?_⟩
+  have key := hcord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - 1728) (jBar N - 1728)
+    (JD_coeffEmb_sub_1728 N)
+  rw [key, ← ramificationIndex_eq_ord_sub_of_restrict_eq_jLinePlace1728 N w hw]
+
+private theorem JD_exists_bar_ord_eq_mul_ram_zero
+    [Algebra.IsIntegral ↥ℚ⟮jq⟯ ↥(modularFunctionField N)]
+    (w : Place ℚ (modularFunctionField N))
+    (hw : w.restrict ↥ℚ⟮jq⟯ = jLinePlaceZero) :
+    ∃ (v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) (c : ℤ),
+      0 < c ∧ v.ord (jBar N) = c * (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) := by
+  have hordpos : 0 < w.ord (⟨jq, jq_mem N⟩ : modularFunctionField N) :=
+    (restrict_eq_jLinePlaceZero_iff N w).mp hw
+  have hjnn : 0 ≤ w.ord (⟨jq, jq_mem N⟩ : modularFunctionField N) := hordpos.le
+  obtain ⟨S, hSdeg, hSmem⟩ := exists_finset_place_bar_dominating_of_ord_jq_nonneg N w hjnn
+  have hSne : S.Nonempty :=
+    Finset.card_pos.mp (lt_of_lt_of_le (JD_deg_pos_of_restrict_eq_jLinePlaceZero N w hw) hSdeg)
+  obtain ⟨v, hvS⟩ := hSne
+  obtain ⟨_, c, hcpos, hcord⟩ := hSmem v hvS
+  refine ⟨v, c, hcpos, ?_⟩
+  rw [hcord _ _ (JD_coeffEmb_j N), ← ramificationIndex_eq_ord_of_restrict_eq_jLinePlaceZero N w hw]
+
+end JDHelpersModular
+
+p2m_open_scoped "ModularCurve" in
+private theorem
+  ModularCurve.ramificationIndex_eq_one_or_eq_two_of_restrict_eq_jLinePlace1728_of_even_of_bounds (N
+  : ℕ) [NeZero N] (hN : Even N)
+    (h2 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N - 1728) →
+      v.ord (jBar N - 1728) ∣ 2) :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ = ModularCurve.jLinePlace1728 →
+      w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 1 ∨ w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 2
+        := by
+  intro _ w hw
+  let := jAdjoinAlgebra N
+  have _ := hN
+  obtain ⟨v, c, hcpos, hvord⟩ := JD_exists_bar_ord_eq_mul_ram_1728 N w hw
+  have hewpos : 0 < (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) := by
+    exact_mod_cast w.ramificationIndex_pos (F := ↥ℚ⟮jq⟯)
+  have hvpos : 0 < v.ord (jBar N - 1728) := by rw [hvord]; exact mul_pos hcpos hewpos
+  have hdvd : c * (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) ∣ 2 := hvord ▸ h2 v hvpos
+  have hewdvd : (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) ∣ 2 := (dvd_mul_left _ c).trans hdvd
+  have hN2 : w.ramificationIndex ↥ℚ⟮jq⟯ ∣ 2 := by exact_mod_cast hewdvd
+  exact (Nat.dvd_prime Nat.prime_two).mp hN2
+
+p2m_open_scoped "ModularCurve" in
+private theorem
+  ModularCurve.ramificationIndex_eq_one_or_eq_three_of_restrict_eq_jLinePlaceZero_of_even_of_bounds
+  (N : ℕ) [NeZero N] (hN : Even N)
+    (h1 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N) → v.ord
+      (jBar N) ∣ 3) :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ = ModularCurve.jLinePlaceZero →
+      w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 1 ∨ w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 3
+        := by
+  intro _ w hw
+  let := jAdjoinAlgebra N
+  have _ := hN
+  obtain ⟨v, c, hcpos, hvord⟩ := JD_exists_bar_ord_eq_mul_ram_zero N w hw
+  have hewpos : 0 < (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) := by
+    exact_mod_cast w.ramificationIndex_pos (F := ↥ℚ⟮jq⟯)
+  have hvpos : 0 < v.ord (jBar N) := by rw [hvord]; exact mul_pos hcpos hewpos
+  have hdvd : c * (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) ∣ 3 := hvord ▸ h1 v hvpos
+  have hewdvd : (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) ∣ 3 := (dvd_mul_left _ c).trans hdvd
+  have hN3 : w.ramificationIndex ↥ℚ⟮jq⟯ ∣ 3 := by exact_mod_cast hewdvd
+  exact (Nat.dvd_prime Nat.prime_three).mp hN3
+
+p2m_open_scoped "ModularCurve" in
+private theorem
+  ModularCurve.ramificationIndex_eq_one_or_eq_two_of_restrict_eq_jLinePlace1728_of_odd_of_bounds (N
+  : ℕ) [NeZero N] (hN : Odd N)
+    (h2 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N - 1728) →
+      v.ord (jBar N - 1728) ∣ 2) :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ = ModularCurve.jLinePlace1728 →
+      w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 1 ∨ w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 2
+        := by
+  intro _ w hw
+  let := jAdjoinAlgebra N
+  have _ := hN
+  obtain ⟨v, c, hcpos, hvord⟩ := JD_exists_bar_ord_eq_mul_ram_1728 N w hw
+  have hewpos : 0 < (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) := by
+    exact_mod_cast w.ramificationIndex_pos (F := ↥ℚ⟮jq⟯)
+  have hvpos : 0 < v.ord (jBar N - 1728) := by rw [hvord]; exact mul_pos hcpos hewpos
+  have hdvd : c * (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) ∣ 2 := hvord ▸ h2 v hvpos
+  have hewdvd : (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) ∣ 2 := (dvd_mul_left _ c).trans hdvd
+  have hN2 : w.ramificationIndex ↥ℚ⟮jq⟯ ∣ 2 := by exact_mod_cast hewdvd
+  exact (Nat.dvd_prime Nat.prime_two).mp hN2
+
+p2m_open_scoped "ModularCurve" in
+private theorem
+  ModularCurve.ramificationIndex_eq_one_or_eq_three_of_restrict_eq_jLinePlaceZero_of_odd_of_bounds
+  (N : ℕ) [NeZero N] (hN : Odd N)
+    (h1 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N) → v.ord
+      (jBar N) ∣ 3) :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ = ModularCurve.jLinePlaceZero →
+      w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 1 ∨ w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 3
+        := by
+  intro _ w hw
+  let := jAdjoinAlgebra N
+  have _ := hN
+  obtain ⟨v, c, hcpos, hvord⟩ := JD_exists_bar_ord_eq_mul_ram_zero N w hw
+  have hewpos : 0 < (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) := by
+    exact_mod_cast w.ramificationIndex_pos (F := ↥ℚ⟮jq⟯)
+  have hvpos : 0 < v.ord (jBar N) := by rw [hvord]; exact mul_pos hcpos hewpos
+  have hdvd : c * (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) ∣ 3 := hvord ▸ h1 v hvpos
+  have hewdvd : (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) ∣ 3 := (dvd_mul_left _ c).trans hdvd
+  have hN3 : w.ramificationIndex ↥ℚ⟮jq⟯ ∣ 3 := by exact_mod_cast hewdvd
+  exact (Nat.dvd_prime Nat.prime_three).mp hN3
+
+p2m_open_scoped "ModularCurve" in
+private theorem
+  ModularCurve.sum_inertiaDeg_unramified_fiber_jLinePlace1728_eq_nuTwo_of_even_of_bounds (N : ℕ)
+  [NeZero N] (hN : Even N)
+    [AlgebraicCurve.HasPrincipalDivisors ℚ ↥(ModularCurve.modularFunctionField N)]
+    (h2 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N - 1728) →
+      v.ord (jBar N - 1728) ∣ 2)
+    [DecidableEq (AlgebraicClosure ℚ)]
+    (hcount : Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // 0 < v.ord
+      (jBar N - 1728)} =
+      Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) // ModuliPoint.j x = (1728 : AlgebraicClosure
+        ℚ)}) :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)],
+    ∑ w ∈ (ModularCurve.jLinePlace1728.fiber ↥(ModularCurve.modularFunctionField N)).filter
+        (fun w => w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 1),
+      (w.inertiaDeg ↥ℚ⟮ModularCurve.jq⟯ : ℤ) = (ModularCurve.nuTwo N : ℤ) := by
+  intro _
+  let := jAdjoinAlgebra N
+  have _ := hN
+  rw [sum_inertiaDeg_unramified_fiber_jLinePlace1728_eq_natCard_bar N,
+    natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo N h2 hcount]
+
+p2m_open_scoped "ModularCurve" in
+private theorem
+  ModularCurve.sum_inertiaDeg_unramified_fiber_jLinePlaceZero_eq_nuThree_of_even_of_bounds (N : ℕ)
+  [NeZero N] (hN : Even N)
+    [AlgebraicCurve.HasPrincipalDivisors ℚ ↥(ModularCurve.modularFunctionField N)]
+    (h1 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N) → v.ord
+      (jBar N) ∣ 3)
+    [DecidableEq (AlgebraicClosure ℚ)]
+    (hcount : Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // 0 < v.ord
+      (jBar N)} =
+      Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) // ModuliPoint.j x = (0 : AlgebraicClosure
+        ℚ)}) :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)],
+    ∑ w ∈ (ModularCurve.jLinePlaceZero.fiber ↥(ModularCurve.modularFunctionField N)).filter
+        (fun w => w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 1),
+      (w.inertiaDeg ↥ℚ⟮ModularCurve.jq⟯ : ℤ) = (ModularCurve.nuThree N : ℤ) := by
+  intro _
+  let := jAdjoinAlgebra N
+  have _ := hN
+  rw [sum_inertiaDeg_unramified_fiber_jLinePlaceZero_eq_natCard_bar N,
+    natCard_ord_jBar_eq_one_eq_nuThree N h1 hcount]
+
+p2m_open_scoped "ModularCurve" in
+private theorem
+  ModularCurve.sum_inertiaDeg_unramified_fiber_jLinePlace1728_eq_nuTwo_of_odd_of_bounds (N : ℕ)
+  [NeZero N] (hN : Odd N)
+    [AlgebraicCurve.HasPrincipalDivisors ℚ ↥(ModularCurve.modularFunctionField N)]
+    (h2 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N - 1728) →
+      v.ord (jBar N - 1728) ∣ 2)
+    [DecidableEq (AlgebraicClosure ℚ)]
+    (hcount : Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // 0 < v.ord
+      (jBar N - 1728)} =
+      Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) // ModuliPoint.j x = (1728 : AlgebraicClosure
+        ℚ)}) :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)],
+    ∑ w ∈ (ModularCurve.jLinePlace1728.fiber ↥(ModularCurve.modularFunctionField N)).filter
+        (fun w => w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 1),
+      (w.inertiaDeg ↥ℚ⟮ModularCurve.jq⟯ : ℤ) = (ModularCurve.nuTwo N : ℤ) := by
+  intro _
+  let := jAdjoinAlgebra N
+  have _ := hN
+  rw [sum_inertiaDeg_unramified_fiber_jLinePlace1728_eq_natCard_bar N,
+    natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo N h2 hcount]
+
+p2m_open_scoped "ModularCurve" in
+private theorem
+  ModularCurve.sum_inertiaDeg_unramified_fiber_jLinePlaceZero_eq_nuThree_of_odd_of_bounds (N : ℕ)
+  [NeZero N] (hN : Odd N)
+    [AlgebraicCurve.HasPrincipalDivisors ℚ ↥(ModularCurve.modularFunctionField N)]
+    (h1 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N) → v.ord
+      (jBar N) ∣ 3)
+    [DecidableEq (AlgebraicClosure ℚ)]
+    (hcount : Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // 0 < v.ord
+      (jBar N)} =
+      Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) // ModuliPoint.j x = (0 : AlgebraicClosure
+        ℚ)}) :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)],
+    ∑ w ∈ (ModularCurve.jLinePlaceZero.fiber ↥(ModularCurve.modularFunctionField N)).filter
+        (fun w => w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 1),
+      (w.inertiaDeg ↥ℚ⟮ModularCurve.jq⟯ : ℤ) = (ModularCurve.nuThree N : ℤ) := by
+  intro _
+  let := jAdjoinAlgebra N
+  have _ := hN
+  rw [sum_inertiaDeg_unramified_fiber_jLinePlaceZero_eq_natCard_bar N,
+    natCard_ord_jBar_eq_one_eq_nuThree N h1 hcount]
+
+section H1
+
+variable (N : ℕ) [NeZero N]
+
+attribute [local instance] jAdjoinAlgebra
+
+private theorem JD_ord_multiset_prod {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) (s : Multiset F) (hs : ∀ x ∈ s, x ≠ 0) :
+    v.ord s.prod = (s.map v.ord).sum := by
+  induction s using Multiset.induction_on with
+  | empty => simp
+  | cons a t ih =>
+    have ha : a ≠ 0 := hs a (Multiset.mem_cons_self a t)
+    have ht : ∀ x ∈ t, x ≠ 0 := fun x hx => hs x (Multiset.mem_cons_of_mem hx)
+    have htprod : t.prod ≠ 0 := fun h => ht 0 (Multiset.prod_eq_zero_iff.mp h) rfl
+    simp only [Multiset.prod_cons, Multiset.map_cons, Multiset.sum_cons]
+    rw [v.ord_mul ha htprod, ih ht]
+
+omit [NeZero N] in
+private theorem JD_algebraMap_rat_barN :
+    (algebraMap ℚ (modularFunctionFieldBar N)) =
+      (algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)).comp
+        (algebraMap ℚ (AlgebraicClosure ℚ)) :=
+  RingHom.ext fun a => by
+    rw [eq_ratCast (algebraMap ℚ (modularFunctionFieldBar N)) a, RingHom.comp_apply,
+      eq_ratCast (algebraMap ℚ (AlgebraicClosure ℚ)) a, map_ratCast]
+
+open Polynomial in
+private theorem JD_L_H1
+    (h3 : ∀ (j₀ : AlgebraicClosure ℚ), j₀ ≠ 0 → j₀ ≠ 1728 →
+      ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N),
+        0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) →
+        v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) = 1)
+    (v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N))
+    (hvj : jBar N ∈ v.toValuationSubring)
+    (p : Polynomial ℚ) (hirr : Irreducible p) (hmon : p.Monic)
+    (hp0 : p.eval 0 ≠ 0) (hp1728 : p.eval 1728 ≠ 0)
+    (hvpos : 0 < v.ord (Polynomial.aeval (jBar N) p)) :
+    v.ord (Polynomial.aeval (jBar N) p) = 1 := by
+  classical
+  set q : Polynomial (AlgebraicClosure ℚ) := p.map (algebraMap ℚ (AlgebraicClosure ℚ)) with hq
+  have hqmon : q.Monic := hmon.map _
+  have hqsplits : q.Splits := IsAlgClosed.splits q
+  have hqsep : q.Separable := (Irreducible.separable (F := ℚ) hirr).map
+  have hnodup : q.roots.Nodup := nodup_roots hqsep
+  have hpmap : p.map (algebraMap ℚ (modularFunctionFieldBar N)) =
+      q.map (algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) := by
+    rw [hq, Polynomial.map_map, ← JD_algebraMap_rat_barN]
+  have hsplits' : (p.map (algebraMap ℚ (modularFunctionFieldBar N))).Splits :=
+    hpmap ▸ hqsplits.map (algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N))
+  have haroots : p.aroots (modularFunctionFieldBar N) =
+      q.roots.map (algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) := by
+    rw [aroots_def, hpmap, hqsplits.roots_map]
+  have hprod : aeval (jBar N) p = (q.roots.map (fun α => jBar N -
+      algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) α)).prod := by
+    rw [hsplits'.aeval_eq_prod_aroots_of_monic hmon (jBar N), haroots, Multiset.map_map]
+    rfl
+  rw [hprod] at hvpos ⊢
+  have hne : ∀ x ∈ q.roots.map (fun α => jBar N -
+      algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) α), x ≠ 0 := by
+    intro x hx h0
+    refine absurd hvpos (not_lt.mpr (le_of_eq ?_))
+    rw [Multiset.prod_eq_zero (h0 ▸ hx)]; exact v.ord_zero
+  rw [JD_ord_multiset_prod v _ hne, Multiset.map_map] at hvpos ⊢
+  have hnn : ∀ α ∈ q.roots, 0 ≤ v.ord (jBar N -
+      algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) α) := fun α _ =>
+    JD_ord_nonneg_of_mem v (sub_mem hvj (v.algebraMap_mem' α))
+  obtain ⟨α, hαmem, hαpos⟩ : ∃ α ∈ q.roots, 0 < v.ord (jBar N -
+      algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) α) := by
+    by_contra h
+    push Not at h
+    have hzero : ∀ α ∈ q.roots, v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) _ α) = 0 :=
+      fun α hα => le_antisymm (h α hα) (hnn α hα)
+    refine absurd hvpos (not_lt.mpr (le_of_eq ?_))
+    simp only [Function.comp_apply]
+    exact Multiset.sum_eq_zero fun y hy => by
+      obtain ⟨α, hα, rfl⟩ := Multiset.mem_map.mp hy
+      exact hzero α hα
+  have hnotroot : ∀ a : ℚ, p.eval a ≠ 0 → α ≠ algebraMap ℚ (AlgebraicClosure ℚ) a := by
+    intro a hpa hαa
+    refine hpa ((algebraMap ℚ (AlgebraicClosure ℚ)).injective ?_)
+    rw [map_zero, ← eval₂_at_apply (algebraMap ℚ (AlgebraicClosure ℚ)) a,
+      ← eval_map, ← hq, ← hαa]
+    exact (mem_roots hqmon.ne_zero).mp hαmem
+  have hα0 : α ≠ 0 := by
+    have := hnotroot 0 hp0; rwa [map_zero] at this
+  have hα1728 : α ≠ 1728 := by
+    have := hnotroot 1728 hp1728; rwa [map_ofNat] at this
+  have hα1 : v.ord (jBar N -
+      algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) α) = 1 :=
+    h3 α hα0 hα1728 v hαpos
+  have hother : ∀ β ∈ q.roots, β ≠ α → v.ord (jBar N -
+      algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) β) = 0 := by
+    intro β hβmem hβα
+    by_contra hne0
+    have hβpos : 0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) _ β) :=
+      lt_of_le_of_ne (hnn β hβmem) (Ne.symm hne0)
+    have hαne : jBar N - algebraMap (AlgebraicClosure ℚ) _ α ≠ 0 :=
+      hne _ (Multiset.mem_map_of_mem _ hαmem)
+    have hβne : jBar N - algebraMap (AlgebraicClosure ℚ) _ β ≠ 0 :=
+      hne _ (Multiset.mem_map_of_mem _ hβmem)
+    have hαmemO := sub_mem hvj (v.algebraMap_mem' α)
+    have hβmemO := sub_mem hvj (v.algebraMap_mem' β)
+    have hαM := (v.mem_maximalIdeal_iff_ord_pos hαne hαmemO).mpr hαpos
+    have hβM := (v.mem_maximalIdeal_iff_ord_pos hβne hβmemO).mpr hβpos
+    have hαβne : (α - β : AlgebraicClosure ℚ) ≠ 0 := sub_ne_zero.mpr (Ne.symm hβα)
+    have hord0 := JD_ord_algebraMap_eq_zero v hαβne
+    have hordpos : 0 < v.ord (algebraMap (AlgebraicClosure ℚ)
+        (modularFunctionFieldBar N) (α - β)) := by
+      have hmem := v.algebraMap_mem' (α - β)
+      have hmapne : algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) (α - β) ≠ 0 :=
+        (map_ne_zero_iff _ (algebraMap (AlgebraicClosure ℚ) _).injective).mpr hαβne
+      rw [← v.mem_maximalIdeal_iff_ord_pos hmapne hmem]
+      have heq : (⟨_, hmem⟩ : v.toValuationSubring) =
+          (⟨_, hβmemO⟩ : v.toValuationSubring) - ⟨_, hαmemO⟩ := by
+        refine Subtype.ext ?_
+        change algebraMap (AlgebraicClosure ℚ) _ (α - β) =
+          (jBar N - algebraMap _ _ β) - (jBar N - algebraMap _ _ α)
+        rw [map_sub]; ring
+      rw [heq]; exact sub_mem hβM hαM
+    exact absurd hord0 (ne_of_gt hordpos)
+  have hcons : q.roots = α ::ₘ q.roots.erase α := (Multiset.cons_erase hαmem).symm
+  simp only [Function.comp_apply]
+  rw [show (q.roots.map (fun β => v.ord (jBar N -
+        algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) β))).sum =
+      v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) α) +
+        ((q.roots.erase α).map (fun β => v.ord (jBar N -
+          algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) β))).sum from by
+    conv_lhs => rw [hcons, Multiset.map_cons, Multiset.sum_cons], hα1]
+  have hrest : ((q.roots.erase α).map (fun β => v.ord (jBar N -
+      algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) β))).sum = 0 := by
+    refine Multiset.sum_eq_zero fun y hy => ?_
+    obtain ⟨β, hβ, rfl⟩ := Multiset.mem_map.mp hy
+    exact hother β (Multiset.mem_of_mem_erase hβ) ((hnodup.mem_erase_iff).mp hβ).1
+  omega
+
+end H1
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.ramificationIndex_eq_one_of_restrict_ne_jLinePlaces_of_even_of_bounds
+    (N : ℕ) [NeZero N] (hN : Even N)
+    (h3 : ∀ (j₀ : AlgebraicClosure ℚ), j₀ ≠ 0 → j₀ ≠ 1728 → ∀ v : Place (AlgebraicClosure ℚ)
+      (modularFunctionFieldBar N),
+      0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) →
+      v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) = 1) :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ ≠ ModularCurve.jLinePlace1728 →
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ ≠ ModularCurve.jLinePlaceZero →
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ ≠ ModularCurve.jLinePlaceInfty →
+      w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 1 := by
+  intro _ w h1728 h0 hinfty
+  let := jAdjoinAlgebra N
+  have _ := hN
+  have hjnn : 0 ≤ w.ord (⟨jq, jq_mem N⟩ : modularFunctionField N) :=
+    not_lt.mp (fun hlt => hinfty ((restrict_eq_jLinePlaceInfty_iff N w).mpr hlt))
+  obtain ⟨p, hirr, hmon, hp0, hp1728, hwpos, hew⟩ :=
+    exists_irreducible_ramificationIndex_eq_ord_aeval_of_restrict_ne_jLinePlaces N w
+      h1728 h0 hinfty
+  obtain ⟨S, hSdeg, hSmem⟩ := exists_finset_place_bar_dominating_of_ord_jq_nonneg N w hjnn
+  have hSne : S.Nonempty :=
+    Finset.card_pos.mp (lt_of_lt_of_le (JD_deg_pos N w) hSdeg)
+  obtain ⟨v, hvS⟩ := hSne
+  obtain ⟨⟨j₀, hj₀⟩, c, hcpos, hcord⟩ := hSmem v hvS
+  have hjBmem : jBar N ∈ v.toValuationSubring := by
+    have h1 : jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀
+        + algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀ ∈ v.toValuationSubring :=
+      add_mem (JD_mem_of_ord_pos v hj₀) (v.algebraMap_mem' j₀)
+    simpa using h1
+  have hvordp : v.ord (Polynomial.aeval (jBar N) p) =
+      c * w.ord (Polynomial.aeval (⟨jq, jq_mem N⟩ : modularFunctionField N) p) :=
+    hcord _ _ (JD_coeffEmb_aeval N p)
+  have hL : v.ord (Polynomial.aeval (jBar N) p) = 1 :=
+    JD_L_H1 N h3 v hjBmem p hirr hmon hp0 hp1728
+      (by rw [hvordp]; exact mul_pos hcpos hwpos)
+  have heq : c * (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) = 1 :=
+    calc c * (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ)
+        = c * w.ord (Polynomial.aeval (⟨jq, jq_mem N⟩ : modularFunctionField N) p) := by rw [hew]
+      _ = v.ord (Polynomial.aeval (jBar N) p) := hvordp.symm
+      _ = 1 := hL
+  have hewpos : 0 < (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) := by
+    exact_mod_cast w.ramificationIndex_pos (F := ↥ℚ⟮jq⟯)
+  have hewZ : (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) = 1 := by
+    rcases Int.isUnit_iff.mp (isUnit_of_dvd_one ⟨c, (mul_comm _ c ▸ heq).symm⟩) with h1 | hneg
+    · exact h1
+    · omega
+  exact_mod_cast hewZ
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.ramificationIndex_eq_one_of_restrict_ne_jLinePlaces_of_odd_of_bounds
+    (N : ℕ) [NeZero N] (hN : Odd N)
+    (h3 : ∀ (j₀ : AlgebraicClosure ℚ), j₀ ≠ 0 → j₀ ≠ 1728 → ∀ v : Place (AlgebraicClosure ℚ)
+      (modularFunctionFieldBar N),
+      0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) →
+      v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) = 1) :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ ≠ ModularCurve.jLinePlace1728 →
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ ≠ ModularCurve.jLinePlaceZero →
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ ≠ ModularCurve.jLinePlaceInfty →
+      w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 1 := by
+  intro _ w h1728 h0 hinfty
+  let := jAdjoinAlgebra N
+  have _ := hN
+  have hjnn : 0 ≤ w.ord (⟨jq, jq_mem N⟩ : modularFunctionField N) :=
+    not_lt.mp (fun hlt => hinfty ((restrict_eq_jLinePlaceInfty_iff N w).mpr hlt))
+  obtain ⟨p, hirr, hmon, hp0, hp1728, hwpos, hew⟩ :=
+    exists_irreducible_ramificationIndex_eq_ord_aeval_of_restrict_ne_jLinePlaces N w
+      h1728 h0 hinfty
+  obtain ⟨S, hSdeg, hSmem⟩ := exists_finset_place_bar_dominating_of_ord_jq_nonneg N w hjnn
+  have hSne : S.Nonempty :=
+    Finset.card_pos.mp (lt_of_lt_of_le (JD_deg_pos N w) hSdeg)
+  obtain ⟨v, hvS⟩ := hSne
+  obtain ⟨⟨j₀, hj₀⟩, c, hcpos, hcord⟩ := hSmem v hvS
+  have hjBmem : jBar N ∈ v.toValuationSubring := by
+    have h1 : jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀
+        + algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀ ∈ v.toValuationSubring :=
+      add_mem (JD_mem_of_ord_pos v hj₀) (v.algebraMap_mem' j₀)
+    simpa using h1
+  have hvordp : v.ord (Polynomial.aeval (jBar N) p) =
+      c * w.ord (Polynomial.aeval (⟨jq, jq_mem N⟩ : modularFunctionField N) p) :=
+    hcord _ _ (JD_coeffEmb_aeval N p)
+  have hL : v.ord (Polynomial.aeval (jBar N) p) = 1 :=
+    JD_L_H1 N h3 v hjBmem p hirr hmon hp0 hp1728
+      (by rw [hvordp]; exact mul_pos hcpos hwpos)
+  have heq : c * (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) = 1 :=
+    calc c * (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ)
+        = c * w.ord (Polynomial.aeval (⟨jq, jq_mem N⟩ : modularFunctionField N) p) := by rw [hew]
+      _ = v.ord (Polynomial.aeval (jBar N) p) := hvordp.symm
+      _ = 1 := hL
+  have hewpos : 0 < (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) := by
+    exact_mod_cast w.ramificationIndex_pos (F := ↥ℚ⟮jq⟯)
+  have hewZ : (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) = 1 := by
+    rcases Int.isUnit_iff.mp (isUnit_of_dvd_one ⟨c, (mul_comm _ c ▸ heq).symm⟩) with h1 | hneg
+    · exact h1
+    · omega
+  exact_mod_cast hewZ
+
+open IntermediateField AlgebraicCurve AlgebraicCurve.RationalFunctionField _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_natCard_ord_jBar_eq_one_eq_nuThree.ModularCurve IsDedekindDomain
+  WithZero IsLocalRing in
+theorem solution (N : ℕ) [NeZero N]
+    (h1 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N) → v.ord
+      (jBar N) ∣ 3)
+    [DecidableEq (AlgebraicClosure ℚ)]
+    (hcount : Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // 0 < v.ord
+      (jBar N)} =
+      Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) // ModuliPoint.j x = (0 : AlgebraicClosure
+        ℚ)}) :
+    Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // v.ord (jBar N) = 1} =
+      nuThree N :=
+  ModularCurve.natCard_ord_jBar_eq_one_eq_nuThree N h1 hcount
+
+end S_ModularCurve_natCard_ord_jBar_eq_one_eq_nuThree
+end P2MW
+export P2MW.S_ModularCurve_natCard_ord_jBar_eq_one_eq_nuThree (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open IntermediateField AlgebraicCurve AlgebraicCurve.RationalFunctionField ModularCurve
+  IsDedekindDomain WithZero IsLocalRing
+theorem ModularCurve.natCard_ord_jBar_eq_one_eq_nuThree (N : ℕ) [NeZero N]
+    (h1 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N) → v.ord
+      (jBar N) ∣ 3)
+    [DecidableEq (AlgebraicClosure ℚ)]
+    (hcount : Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // 0 < v.ord
+      (jBar N)} =
+      Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) // ModuliPoint.j x = (0 : AlgebraicClosure
+        ℚ)}) :
+    Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // v.ord (jBar N) = 1} =
+      nuThree N :=
+  solution N h1 hcount
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo.lean
new file mode 100644
index 0000000000..e62c6196d2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo.lean
@@ -0,0 +1,2403 @@
+/-
+Based on Prove2Me node ModularCurve.natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo
+(6616567e-4f5b-5f1d-9bb1-60c622d05a55) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ee3344e2-f004-5c18-86dc-75b64e95f6af
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_MazurStepThreeInputs
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JLinePlaces
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ModuliPoint
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_sum_ord_jBar_sub_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_finset_ord_jBar_sub_pos
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_deg_eq_one_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_equiv_place_pos_ord_algHom_integralClosure
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_jAdjoin_modularFunctionField_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_two_mul_natCard_moduliPoint_j_eq_1728_eq_dedekindPsi_add_nuTwo
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_three_mul_natCard_moduliPoint_j_eq_zero_eq_dedekindPsi_add_two_mul_nuThree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_laurentBaseChange_modularFunctionFieldFull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_pos
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_inertiaDeg_pos_of_finiteDimensional
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_restrict_eq_jLinePlace1728_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_restrict_eq_jLinePlaceZero_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_restrict_eq_jLinePlaceInfty_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ramificationIndex_eq_ord_sub_of_restrict_eq_jLinePlace1728
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ramificationIndex_eq_ord_of_restrict_eq_jLinePlaceZero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_irreducible_ramificationIndex_eq_ord_aeval_of_restrict_ne_jLinePlaces
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_deg_jLinePlace1728
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_deg_jLinePlaceZero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Simple zeros of ̄ j-1728 number ν₂(N)
+
+Theorem statement: `ModularCurve.natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo`
+(`6616567e-4f5b-5f1d-9bb1-60c622d05a55`), by Claude, 2026-09-05.
+
+Proof: submission `ee3344e2-f004-5c18-86dc-75b64e95f6af`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a non-zero natural number and let $\bar F =$ `modularFunctionFieldBar N` be the
+intermediate field of the Laurent series field over $\overline{\mathbb Q}$ obtained by adjoining to
+$\overline{\mathbb Q}$ the coefficientwise images of the elements of `modularFunctionFieldFull N`
+(itself the subfield of $\mathbb Q((q))$ generated over $\mathbb Q$ by the divisor expansions of
+level $N$), and let $\bar j =$ `jBar N` be the element of $\bar F$ given by the coefficientwise
+image of the $q$-expansion of the modular invariant. Places of $\bar F$ over $\overline{\mathbb Q}$
+are valuation subrings of $\bar F$ containing the constants, distinct from $\bar F$ itself and
+principal ideal rings, and for such a place $v$ and $f \in \bar F$, $v.\mathrm{ord}(f)$ is the
+integer $-\log$ of the associated adic valuation of $f$. Assume two hypotheses: first, at every
+place $v$ of $\bar F$ at which $\mathrm{ord}_v(\bar j - 1728) > 0$ this order divides $2$; second,
+the number of places at which $\mathrm{ord}_v(\bar j - 1728) > 0$ equals the number of elements $x$
+of `ModuliPoint N (AlgebraicClosure ℚ)` — the quotient of the set of pairs consisting of an elliptic
+Weierstrass curve over $\overline{\mathbb Q}$ together with an affine point of exact additive order
+$N$, by the relation identifying two pairs when a variable change carries the first curve to the
+second and the second generator to a multiple of the transported first generator by an integer
+coprime to $N$ — with $j$-invariant $1728$. The conclusion is that the number of places $v$ of $\bar
+F$ with $\mathrm{ord}_v(\bar j - 1728) = 1$ equals $\nu_2(N)$, defined as the number of $x \in
+\mathbb Z/N$ with $x^2 + 1 = 0$.
+
+This is the counting step that identifies the unramified places of the $j$-map on the level-$N$
+modular curve above $j = 1728$ with the elliptic points of order two, the two inputs being that the
+orders of $\bar j - 1728$ sum to the Dedekind $\psi$-function and the mass formula $2\,\#\{j =
+1728\} = \psi(N) + \nu_2(N)$. It feeds the Riemann–Roch computations for $\bar F$ and the genus
+formula for the modular function field over $\overline{\mathbb Q}$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo
+
+noncomputable section
+
+p2m_open "AlgebraicCurve ModularCurve \
+  P2MW.S_ModularCurve_natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo.ModularCurve IsDedekindDomain \
+  IsLocalRing"
+
+section Generic
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+variable (K) in
+private abbrev DOM_normalization (t : F) : Subalgebra (Algebra.adjoin K ({t} : Set F)) F :=
+  integralClosure (Algebra.adjoin K ({t} : Set F)) F
+
+private scoped instance DOM_instIsPrincipalIdealRingAdjoinSingleton (t : F) :
+    IsPrincipalIdealRing (Algebra.adjoin K ({t} : Set F)) := by
+  have hmem : ∀ p : Polynomial K, Polynomial.aeval t p ∈ Algebra.adjoin K ({t} : Set F) := by
+    intro p
+    rw [Algebra.adjoin_singleton_eq_range_aeval]
+    exact ⟨p, rfl⟩
+  refine IsPrincipalIdealRing.of_surjective
+    ((Polynomial.aeval t).codRestrict (Algebra.adjoin K ({t} : Set F)) hmem) ?_
+  rintro ⟨a, ha⟩
+  obtain ⟨p, hp⟩ : ∃ p : Polynomial K, Polynomial.aeval t p = a := by
+    rw [Algebra.adjoin_singleton_eq_range_aeval] at ha
+    exact (AlgHom.mem_range _).mp ha
+  exact ⟨p, Subtype.ext hp⟩
+
+private def DOM_gen (t : F) : DOM_normalization K t :=
+  ⟨t, isIntegral_algebraMap (R := Algebra.adjoin K ({t} : Set F))
+    (x := (⟨t, Algebra.self_mem_adjoin_singleton K t⟩ : Algebra.adjoin K ({t} : Set F)))⟩
+
+@[scoped simp] private theorem DOM_coe_gen (t : F) :
+    ((DOM_gen (K := K) t : DOM_normalization K t) : F) = t := rfl
+
+@[scoped simp] private theorem DOM_coe_algebraMap_normalization (t : F) (c : K) :
+    ((algebraMap K (DOM_normalization K t) c : DOM_normalization K t) : F) = algebraMap K F c :=
+  (IsScalarTower.algebraMap_apply K (DOM_normalization K t) F c).symm
+
+section Dedekind
+
+open scoped IntermediateField.algebraAdjoinAdjoin
+
+variable [CharZero K] (t : F) [FiniteDimensional (IntermediateField.adjoin K ({t} : Set F)) F]
+
+private scoped instance DOM_instIsDedekindDomainNormalization :
+    IsDedekindDomain (DOM_normalization K t) := by
+  have : CharZero (IntermediateField.adjoin K ({t} : Set F)) :=
+    charZero_of_injective_algebraMap (algebraMap K _).injective
+  exact integralClosure.isDedekindDomain (Algebra.adjoin K ({t} : Set F))
+    (IntermediateField.adjoin K ({t} : Set F)) F
+
+private scoped instance DOM_instIsFractionRingNormalization :
+    IsFractionRing (DOM_normalization K t) F :=
+  integralClosure.isFractionRing_of_finite_extension
+    (IntermediateField.adjoin K ({t} : Set F)) F
+
+end Dedekind
+
+private theorem DOM_mem_of_ord_nonneg (w : Place K F) {f : F} (hf : f ≠ 0) (h : 0 ≤ w.ord f) :
+    f ∈ w.toValuationSubring := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  obtain ⟨u, hu⟩ := w.exists_unit_mul_zpow hf hπ
+  rw [hu, show w.ord f = (((w.ord f).toNat : ℕ) : ℤ) from (Int.toNat_of_nonneg h).symm,
+    zpow_natCast]
+  exact mul_mem (u : w.toValuationSubring).2 (pow_mem (π : w.toValuationSubring).2 _)
+
+private theorem DOM_mem_of_ord_sub_pos (w : Place K F) {t : F} {c : K}
+    (h : 0 < w.ord (t - algebraMap K F c)) : t ∈ w.toValuationSubring := by
+  have hne : t - algebraMap K F c ≠ 0 := by
+    intro h0
+    rw [h0, Place.ord_zero] at h
+    exact lt_irrefl _ h
+  have hmem := DOM_mem_of_ord_nonneg w hne h.le
+  have := add_mem hmem (w.algebraMap_mem' c)
+  rwa [sub_add_cancel] at this
+
+private theorem DOM_forall_mem_of_mem (t : F) (w : Place K F) (ht : t ∈ w.toValuationSubring)
+    (a : DOM_normalization K t) : (a : F) ∈ w.toValuationSubring := by
+  have hadj : ∀ x : F, x ∈ Algebra.adjoin K ({t} : Set F) → x ∈ w.toValuationSubring := by
+    intro x hx
+    refine Algebra.adjoin_induction (fun y hy => ?_) (fun c => w.algebraMap_mem' c)
+      (fun _ _ _ _ hx hy => add_mem hx hy) (fun _ _ _ _ hx hy => mul_mem hx hy) hx
+    rw [Set.mem_singleton_iff.mp hy]
+    exact ht
+  obtain ⟨P, hPmonic, hPeval⟩ : IsIntegral (Algebra.adjoin K ({t} : Set F)) (a : F) := a.2
+  refine w.mem_of_eval_monic_eq_zero (P := P.map (algebraMap _ F)) (hPmonic.map _)
+    (fun i => ?_) ?_
+  · rw [Polynomial.coeff_map]
+    exact hadj _ (P.coeff i).2
+  · rwa [Polynomial.eval_map]
+
+end Generic
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+private scoped instance DOM_finiteDimensional_adjoin_jBar (N : ℕ) [NeZero N] :
+    FiniteDimensional
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)))
+      (modularFunctionFieldBar N) := by
+  have hcm : IntermediateField.comap (modularFunctionFieldBar N).val
+        (IntermediateField.adjoin (AlgebraicClosure ℚ)
+          ({((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))} :
+            Set (LaurentSeries (AlgebraicClosure ℚ))))
+      = IntermediateField.adjoin (AlgebraicClosure ℚ)
+          ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)) := by
+    rw [← IntermediateField.lift_adjoin_simple]
+    exact IntermediateField.comap_map (modularFunctionFieldBar N).val _
+  have h1 := IntermediateField.finrank_comap
+    (IntermediateField.adjoin (AlgebraicClosure ℚ)
+      ({((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))} :
+        Set (LaurentSeries (AlgebraicClosure ℚ))))
+    (modularFunctionFieldBar N).val
+  rw [hcm, IntermediateField.fieldRange_val] at h1
+  have h2 : IntermediateField.relfinrank
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))} :
+          Set (LaurentSeries (AlgebraicClosure ℚ))))
+      (modularFunctionFieldBar N) = dedekindPsi N := by
+    rw [← ModularCurve.relfinrank_full_eq_dedekindPsi N,
+      ← ModularCurve.relfinrank_laurentBaseChange_modularFunctionFieldFull (AlgebraicClosure ℚ) N]
+  have hpos : 0 < IntermediateField.relfinrank
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))} :
+          Set (LaurentSeries (AlgebraicClosure ℚ))))
+      (modularFunctionFieldBar N) := by
+    rw [h2]
+    exact ModularCurve.dedekindPsi_pos N (NeZero.ne N)
+  rw [← h1] at hpos
+  exact Module.finite_of_finrank_pos hpos
+
+private def DOM_iota (N : ℕ) [NeZero N] :
+    modularFunctionField N →+* modularFunctionFieldBar N where
+  toFun x := ⟨coeffEmb (AlgebraicClosure ℚ) (x : LaurentSeries ℚ),
+    coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionField_le_full N x.2)⟩
+  map_one' := Subtype.ext (by push_cast; exact map_one _)
+  map_mul' x y := Subtype.ext (by push_cast; exact map_mul _ _ _)
+  map_zero' := Subtype.ext (by push_cast; exact map_zero _)
+  map_add' x y := Subtype.ext (by push_cast; exact map_add _ _ _)
+
+@[scoped simp] private theorem DOM_iota_coe (N : ℕ) [NeZero N] (x : modularFunctionField N) :
+    ((DOM_iota N x : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))
+      = coeffEmb (AlgebraicClosure ℚ) (x : LaurentSeries ℚ) := rfl
+
+private theorem DOM_iota_j (N : ℕ) [NeZero N] :
+    DOM_iota N (⟨jq, jq_mem N⟩ : modularFunctionField N) = jBar N := Subtype.ext rfl
+
+private theorem DOM_iota_injective (N : ℕ) [NeZero N] : Function.Injective (DOM_iota N) :=
+  (DOM_iota N).injective
+
+private theorem DOM_ord_nonneg_of_mem' {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) {f : F} (hf : f ∈ v.toValuationSubring) :
+    0 ≤ v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨n, u, hu⟩ :=
+    IsDiscreteValuationRing.eq_unit_mul_pow_irreducible
+      (x := (⟨f, hf⟩ : v.toValuationSubring)) (by simpa [Subtype.ext_iff] using hf0) hπ
+  have hcoe : f = ((u : v.toValuationSubring) : F) * ((π : F) ^ (n : ℤ)) := by
+    have h := congrArg (Subtype.val) hu
+    push_cast at h
+    rw [zpow_natCast]
+    exact h
+  rw [hcoe, v.ord_unit_smul_zpow u hπ (n : ℤ)]
+  exact Int.natCast_nonneg n
+
+private theorem DOM_exists_ord_comp_eq_mul {K K' F F' : Type*} [Field K] [Field K'] [Field F]
+    [Field F']
+    [Algebra K F] [Algebra K' F'] (ι : F →+* F') (w : Place K F) (v : Place K' F')
+    (h : ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v.toValuationSubring) :
+    ∃ c : ℤ, 0 < c ∧ ∀ x : F, v.ord (ι x) = c * w.ord x := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  have hπ0 : (π : F) ≠ 0 := by simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have hιne : ∀ {x : F}, x ≠ 0 → ι x ≠ 0 := fun hx => (map_ne_zero ι).mpr hx
+  have hunit : ∀ u : w.toValuationSubringˣ, v.ord (ι ((u : w.toValuationSubring) : F)) = 0 := by
+    intro u
+    have hu0 : ((u : w.toValuationSubring) : F) ≠ 0 := by
+      simp [ne_eq, ZeroMemClass.coe_eq_zero]
+    have h1 : 0 ≤ v.ord (ι ((u : w.toValuationSubring) : F)) :=
+      DOM_ord_nonneg_of_mem' v ((h _).mp (u : w.toValuationSubring).2)
+    have h2 : 0 ≤ v.ord (ι ((u : w.toValuationSubring) : F)⁻¹) := by
+      refine DOM_ord_nonneg_of_mem' v ((h _).mp (DOM_mem_of_ord_nonneg w (inv_ne_zero hu0) ?_))
+      rw [w.ord_inv, w.ord_coe_unit, neg_zero]
+    rw [map_inv₀, v.ord_inv] at h2
+    omega
+  refine ⟨v.ord (ι (π : F)), ?_, fun x => ?_⟩
+  · have h1 : 0 ≤ v.ord (ι (π : F)) := DOM_ord_nonneg_of_mem' v ((h _).mp π.2)
+    have hnot : (π : F)⁻¹ ∉ w.toValuationSubring := by
+      intro hmem
+      have h0 := DOM_ord_nonneg_of_mem' w hmem
+      rw [w.ord_inv, w.ord_coe_irreducible hπ] at h0
+      omega
+    have h2 : ¬ (0 ≤ v.ord (ι (π : F)⁻¹)) := fun hle =>
+      hnot ((h _).mpr (DOM_mem_of_ord_nonneg v (hιne (inv_ne_zero hπ0)) hle))
+    rw [map_inv₀, v.ord_inv] at h2
+    omega
+  · rcases eq_or_ne x 0 with rfl | hx0
+    · simp
+    obtain ⟨u, hu⟩ := w.exists_unit_mul_zpow hx0 hπ
+    set n := w.ord x with hn
+    have hu0 : ((u : w.toValuationSubring) : F) ≠ 0 := by
+      simp [ne_eq, ZeroMemClass.coe_eq_zero]
+    rw [hu, map_mul, map_zpow₀, v.ord_mul (hιne hu0) (zpow_ne_zero _ (hιne hπ0)), v.ord_zpow, hunit
+      u,
+      zero_add, mul_comm]
+
+section BareChart
+
+variable {K' F' : Type*} [Field K'] [Field F'] [Algebra K' F']
+variable {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R F'] [IsFractionRing R F']
+  [Algebra K' R] [IsScalarTower K' R F']
+
+private theorem DOM_exists_place_of_forall_mem (A : ValuationSubring F') (hA : A ≠ ⊤)
+    (hR : ∀ r : R, algebraMap R F' r ∈ A) :
+    ∃ v : Place K' F', v.toValuationSubring = A := by
+  let φ : R →+* A.toSubring := (algebraMap R F').codRestrict A.toSubring hR
+  let P : Ideal R := (IsLocalRing.maximalIdeal A).comap φ
+  have hP : P.IsPrime := Ideal.comap_isPrime _ _
+  have hinv : ∀ s : R, s ∉ P → (algebraMap R F' s)⁻¹ ∈ A := by
+    intro s hs
+    have hu : IsUnit (φ s) := by
+      by_contra hu
+      exact hs (Ideal.mem_comap.mpr ((IsLocalRing.mem_maximalIdeal _).mpr hu))
+    obtain ⟨u, hu⟩ := hu
+    have hcoe : ((u : A) : F') = algebraMap R F' s := by
+      rw [hu]
+      rfl
+    have h1 : (((u⁻¹ : Aˣ) : A) : F') * algebraMap R F' s = 1 := by
+      have hmul := congrArg (fun a : A => (a : F')) u.inv_mul
+      push_cast at hmul
+      rwa [hcoe] at hmul
+    rw [← eq_inv_of_mul_eq_one_left h1]
+    exact SetLike.coe_mem _
+  have hP0 : P ≠ ⊥ := by
+    intro hbot
+    apply hA
+    refine SetLike.ext fun x => ⟨fun _ => ValuationSubring.mem_top x, fun _ => ?_⟩
+    obtain ⟨a, b, hb, hx⟩ := IsFractionRing.div_surjective (A := R) x
+    rw [← hx, div_eq_mul_inv]
+    refine mul_mem (hR a) (hinv b fun hbP => ?_)
+    rw [hbot] at hbP
+    exact nonZeroDivisors.ne_zero hb (Ideal.mem_bot.mp hbP)
+  let Pv : HeightOneSpectrum R := ⟨P, hP, hP0⟩
+  have hle : HeightOneSpectrum.valuationSubringAtPrime F' Pv ≤ A := by
+    rintro x ⟨a, s, hs, rfl⟩
+    exact mul_mem (hR a) (hinv s hs)
+  have heq : HeightOneSpectrum.valuationSubringAtPrime F' Pv = A :=
+    ValuationSubring.eq_of_le_of_ne_top _ hle hA
+  refine ⟨Place.ofHeightOneSpectrum (K := K') Pv, ?_⟩
+  rw [Place.ofHeightOneSpectrum_toValuationSubring,
+    ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+  exact heq
+
+end BareChart
+
+section Chevalley
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F]
+
+private def DOM_iotaO (ι : F →+* F') (w : Place K F) : w.toValuationSubring →+* F' :=
+  ι.comp
+    { toFun := fun (z : w.toValuationSubring) => (z : F)
+      map_one' := rfl
+      map_mul' := fun _ _ => rfl
+      map_zero' := rfl
+      map_add' := fun _ _ => rfl }
+
+private theorem DOM_exists_valuationSubring_dom (ι : F →+* F') (w : Place K F) :
+    ∃ A : ValuationSubring F', A ≠ ⊤ ∧ ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ A := by
+  obtain ⟨A, hA, hloc⟩ := IsLocalRing.exists_factor_valuationRing (DOM_iotaO ι w)
+  have hmem : ∀ x : F, x ∈ w.toValuationSubring → ι x ∈ A := fun x hx => hA ⟨x, hx⟩
+  have hnu : ∀ z : w.toValuationSubring, ¬ IsUnit z →
+      ¬ IsUnit ((DOM_iotaO ι w).codRestrict A.toSubring hA z) :=
+    fun z hz hu => hz (hloc.map_nonunit z hu)
+  refine ⟨A, ?_, fun x => ⟨hmem x, fun hx => ?_⟩⟩
+  · intro htop
+    obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+    have hπ0 : (π : F) ≠ 0 := by
+      simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+    apply hnu π hπ.not_isUnit
+    have hinvmem : (ι (π : F))⁻¹ ∈ A.toSubring := by
+      change (ι (π : F))⁻¹ ∈ A
+      rw [htop]
+      exact ValuationSubring.mem_top _
+    refine IsUnit.of_mul_eq_one ⟨(ι (π : F))⁻¹, hinvmem⟩ ?_
+    apply Subtype.ext
+    change ι (π : F) * (ι (π : F))⁻¹ = 1
+    exact mul_inv_cancel₀ ((map_ne_zero ι).mpr hπ0)
+  · by_contra hxw
+    have hx0 : x ≠ 0 := by
+      rintro rfl
+      exact hxw (zero_mem _)
+    have hinv : x⁻¹ ∈ w.toValuationSubring := by
+      rcases w.toValuationSubring.mem_or_inv_mem x with h | h
+      · exact absurd h hxw
+      · exact h
+    have hnunit : ¬ IsUnit (⟨x⁻¹, hinv⟩ : w.toValuationSubring) := by
+      rintro ⟨u, hu⟩
+      apply hxw
+      have h1 : (((u⁻¹ : w.toValuationSubringˣ) : w.toValuationSubring) : F) * x⁻¹ = 1 := by
+        have hmul := congrArg (fun a : w.toValuationSubring => (a : F)) u.inv_mul
+        push_cast at hmul
+        rwa [hu] at hmul
+      rw [show x = (((u⁻¹ : w.toValuationSubringˣ) : w.toValuationSubring) : F) by
+        rw [eq_inv_of_mul_eq_one_left h1, inv_inv]]
+      exact SetLike.coe_mem _
+    apply hnu ⟨x⁻¹, hinv⟩ hnunit
+    have hxmem : ι x ∈ A.toSubring := hx
+    refine IsUnit.of_mul_eq_one ⟨ι x, hxmem⟩ ?_
+    apply Subtype.ext
+    change ι x⁻¹ * ι x = 1
+    rw [map_inv₀, inv_mul_cancel₀ ((map_ne_zero ι).mpr hx0)]
+
+private theorem DOM_mem_of_isIntegralElem (A : ValuationSubring F') {S : Type*} [CommRing S]
+    (ψ : S →+* F') (hψA : ∀ s : S, ψ s ∈ A) {b : F'} (hb : ψ.IsIntegralElem b) : b ∈ A := by
+  let ψA : S →+* A := ψ.codRestrict A.toSubring hψA
+  have hcomp : (algebraMap A F').comp ψA = ψ := RingHom.ext fun _ => rfl
+  obtain ⟨p, hp, hpb⟩ := hb
+  have hint : IsIntegral A b := by
+    refine ⟨p.map ψA, hp.map ψA, ?_⟩
+    rw [Polynomial.eval₂_map, hcomp]
+    exact hpb
+  obtain ⟨y, hy⟩ := IsIntegrallyClosed.isIntegral_iff.mp hint
+  rw [← hy]
+  exact SetLike.coe_mem _
+
+end Chevalley
+
+section Kit
+
+variable {K F K' F' : Type*} [Field K] [Field F] [Field K'] [Field F']
+  [Algebra K F] [Algebra K' F']
+
+private def DOM_twist (σ : F' ≃+* F') (σK : K' ≃+* K')
+    (hσ : ∀ a : K', σ (algebraMap K' F' a) = algebraMap K' F' (σK a)) (v : Place K' F') :
+    Place K' F' where
+  toValuationSubring := v.toValuationSubring.comap (σ.symm : F' →+* F')
+  algebraMap_mem' a := by
+    rw [ValuationSubring.mem_comap]
+    change σ.symm (algebraMap K' F' a) ∈ v.toValuationSubring
+    rw [show σ.symm (algebraMap K' F' a) = algebraMap K' F' (σK.symm a) by
+      rw [RingEquiv.symm_apply_eq, hσ, RingEquiv.apply_symm_apply]]
+    exact v.algebraMap_mem' _
+  ne_top' := fun h =>
+    v.ne_top' (SetLike.ext fun x =>
+      ⟨fun _ => ValuationSubring.mem_top x, fun _ => by
+        have hx : σ x ∈ v.toValuationSubring.comap (σ.symm : F' →+* F') := by
+          rw [h]
+          exact ValuationSubring.mem_top _
+        rw [ValuationSubring.mem_comap] at hx
+        have hx2 : σ.symm (σ x) ∈ v.toValuationSubring := hx
+        rwa [RingEquiv.symm_apply_apply] at hx2⟩)
+  isPrincipalIdealRing' :=
+    IsPrincipalIdealRing.of_surjective
+      (Place.comapSymmRingEquiv σ v.toValuationSubring : _ ≃+* _)
+      (Place.comapSymmRingEquiv σ v.toValuationSubring).surjective
+
+private theorem DOM_mem_twist_iff (σ : F' ≃+* F') (σK : K' ≃+* K')
+    (hσ : ∀ a : K', σ (algebraMap K' F' a) = algebraMap K' F' (σK a)) (v : Place K' F')
+    (x : F') :
+    x ∈ (DOM_twist σ σK hσ v).toValuationSubring ↔ σ.symm x ∈ v.toValuationSubring :=
+  ValuationSubring.mem_comap
+
+private theorem DOM_ord_twist (σ : F' ≃+* F') (σK : K' ≃+* K')
+    (hσ : ∀ a : K', σ (algebraMap K' F' a) = algebraMap K' F' (σK a)) (v : Place K' F')
+    (f : F') :
+    (DOM_twist σ σK hσ v).ord (σ f) = v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ
+  have hπ' : Irreducible (Place.comapSymmRingEquiv σ v.toValuationSubring π) :=
+    (MulEquiv.irreducible_iff (Place.comapSymmRingEquiv σ v.toValuationSubring)).mpr hπ
+  have hu' : IsUnit (Place.comapSymmRingEquiv σ v.toValuationSubring
+      (u : v.toValuationSubring)) :=
+    u.isUnit.map (Place.comapSymmRingEquiv σ v.toValuationSubring)
+  have key : σ f
+      = ((hu'.unit : (v.toValuationSubring.comap (σ.symm : F' →+* F'))) : F')
+        * (((Place.comapSymmRingEquiv σ v.toValuationSubring π :
+            (v.toValuationSubring.comap (σ.symm : F' →+* F'))) : F') ^ (v.ord f)) := by
+    rw [IsUnit.unit_spec, Place.coe_comapSymmRingEquiv_apply,
+      Place.coe_comapSymmRingEquiv_apply, ← map_zpow₀, ← map_mul, ← hu]
+  rw [key]
+  exact (DOM_twist σ σK hσ v).ord_unit_smul_zpow hu'.unit hπ' (v.ord f)
+
+private theorem DOM_mem_maximalIdeal_twist (σ : F' ≃+* F') (σK : K' ≃+* K')
+    (hσ : ∀ a : K', σ (algebraMap K' F' a) = algebraMap K' F' (σK a)) (v : Place K' F')
+    {z : F'} (hz : z ∈ v.toValuationSubring)
+    (hz' : σ z ∈ (DOM_twist σ σK hσ v).toValuationSubring)
+    (hmem : (⟨z, hz⟩ : v.toValuationSubring) ∈
+      IsLocalRing.maximalIdeal v.toValuationSubring) :
+    (⟨σ z, hz'⟩ : (DOM_twist σ σK hσ v).toValuationSubring) ∈
+      IsLocalRing.maximalIdeal (DOM_twist σ σK hσ v).toValuationSubring := by
+  rw [IsLocalRing.mem_maximalIdeal] at hmem ⊢
+  intro hu
+  apply hmem
+  have heq : (⟨σ z, hz'⟩ : (DOM_twist σ σK hσ v).toValuationSubring)
+      = Place.comapSymmRingEquiv σ v.toValuationSubring ⟨z, hz⟩ :=
+    Subtype.ext rfl
+  rw [heq] at hu
+  have h2 := hu.map (Place.comapSymmRingEquiv σ v.toValuationSubring).symm
+  convert h2 using 2
+  exact (RingEquiv.symm_apply_apply _ _).symm
+
+private def DOM_resMap (ι : F →+* F') (w : Place K F) (v : Place K' F')
+    (hdom : ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v.toValuationSubring) :
+    w.toValuationSubring →+* v.toValuationSubring :=
+  RingHom.codRestrict (ι.comp
+    { toFun := fun (z : w.toValuationSubring) => (z : F)
+      map_one' := rfl
+      map_mul' := fun _ _ => rfl
+      map_zero' := rfl
+      map_add' := fun _ _ => rfl })
+    v.toValuationSubring.toSubring
+    (fun z => (hdom z).mp z.2)
+
+private theorem DOM_resMap_coe (ι : F →+* F') (w : Place K F) (v : Place K' F')
+    (hdom : ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v.toValuationSubring)
+    (z : w.toValuationSubring) :
+    ((DOM_resMap ι w v hdom z : v.toValuationSubring) : F') = ι (z : F) := rfl
+
+private theorem DOM_residue_algebraMap (v : Place K' F') (a : K') :
+    IsLocalRing.residue v.toValuationSubring (algebraMap K' v.toValuationSubring a)
+      = algebraMap K' v.ResidueField a := rfl
+
+section Chi
+
+variable (ι : F →+* F') (w : Place K F) (v : Place K' F')
+  (hdom : ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v.toValuationSubring)
+  (hres : Function.Bijective (algebraMap K' v.ResidueField))
+
+private def DOM_chi : w.toValuationSubring →+* K' :=
+  ((RingEquiv.ofBijective (algebraMap K' v.ResidueField) hres).symm :
+      v.ResidueField →+* K').comp
+    ((IsLocalRing.residue v.toValuationSubring).comp (DOM_resMap ι w v hdom))
+
+private theorem DOM_residue_resMap (z : w.toValuationSubring) :
+    IsLocalRing.residue v.toValuationSubring (DOM_resMap ι w v hdom z)
+      = algebraMap K' v.ResidueField (DOM_chi ι w v hdom hres z) := by
+  change _ = (RingEquiv.ofBijective (algebraMap K' v.ResidueField) hres)
+    ((RingEquiv.ofBijective (algebraMap K' v.ResidueField) hres).symm _)
+  rw [RingEquiv.apply_symm_apply]
+  rfl
+
+private theorem DOM_chi_mem (z : w.toValuationSubring) :
+    DOM_resMap ι w v hdom z - algebraMap K' v.toValuationSubring (DOM_chi ι w v hdom hres z) ∈
+      IsLocalRing.maximalIdeal v.toValuationSubring := by
+  rw [← IsLocalRing.residue_eq_zero_iff, map_sub, DOM_residue_resMap ι w v hdom hres,
+    DOM_residue_algebraMap, sub_self]
+
+private theorem DOM_chi_unique {z : w.toValuationSubring} {a : K'}
+    (h : DOM_resMap ι w v hdom z - algebraMap K' v.toValuationSubring a ∈
+      IsLocalRing.maximalIdeal v.toValuationSubring) :
+    DOM_chi ι w v hdom hres z = a := by
+  rw [← IsLocalRing.residue_eq_zero_iff, map_sub, sub_eq_zero, DOM_residue_algebraMap] at h
+  apply hres.1
+  rw [← DOM_residue_resMap ι w v hdom hres]
+  exact h
+
+private theorem DOM_chi_eq_zero (z : w.toValuationSubring)
+    (hz : z ∈ IsLocalRing.maximalIdeal w.toValuationSubring) : DOM_chi ι w v hdom hres z = 0 := by
+  apply DOM_chi_unique ι w v hdom hres
+  rw [map_zero, sub_zero]
+  rcases eq_or_ne (z : F) 0 with hz0 | hz0
+  · have h0 : DOM_resMap ι w v hdom z = 0 :=
+      Subtype.ext (by rw [DOM_resMap_coe, hz0, map_zero]; rfl)
+    rw [h0]
+    exact Ideal.zero_mem _
+  · obtain ⟨c, hc, hcx⟩ := DOM_exists_ord_comp_eq_mul ι w v hdom
+    have hpos : 0 < w.ord (z : F) := (w.mem_maximalIdeal_iff_ord_pos hz0 z.2).mp hz
+    have hpos' : 0 < v.ord (ι (z : F)) := by
+      rw [hcx]
+      exact mul_pos hc hpos
+    exact (v.mem_maximalIdeal_iff_ord_pos ((map_ne_zero ι).mpr hz0) ((hdom _).mp z.2)).mpr hpos'
+
+private theorem DOM_ord_sub_chi_pos (z : w.toValuationSubring)
+    (hne : ι (z : F) - algebraMap K' F' (DOM_chi ι w v hdom hres z) ≠ 0) :
+    0 < v.ord (ι (z : F) - algebraMap K' F' (DOM_chi ι w v hdom hres z)) := by
+  have hmemF : ι (z : F) - algebraMap K' F' (DOM_chi ι w v hdom hres z) ∈ v.toValuationSubring :=
+    sub_mem ((hdom _).mp z.2) (v.algebraMap_mem' _)
+  refine (v.mem_maximalIdeal_iff_ord_pos hne hmemF).mp ?_
+  have heq : (⟨_, hmemF⟩ : v.toValuationSubring)
+      = DOM_resMap ι w v hdom z - algebraMap K' v.toValuationSubring (DOM_chi ι w v hdom hres z) :=
+    Subtype.ext rfl
+  rw [heq]
+  exact DOM_chi_mem ι w v hdom hres z
+
+private theorem DOM_chi_algebraMap [Algebra K K']
+    (hιK : ∀ a : K, ι (algebraMap K F a) = algebraMap K' F' (algebraMap K K' a)) (a : K) :
+    DOM_chi ι w v hdom hres (algebraMap K w.toValuationSubring a) = algebraMap K K' a := by
+  apply DOM_chi_unique ι w v hdom hres
+  have h : DOM_resMap ι w v hdom (algebraMap K w.toValuationSubring a)
+      = algebraMap K' v.toValuationSubring (algebraMap K K' a) :=
+    Subtype.ext (by rw [DOM_resMap_coe, Place.coe_algebraMap, Place.coe_algebraMap, hιK])
+  rw [h, sub_self]
+  exact Ideal.zero_mem _
+
+private def DOM_chiBar [Algebra K K']
+    (hιK : ∀ a : K, ι (algebraMap K F a) = algebraMap K' F' (algebraMap K K' a)) :
+    w.ResidueField →ₐ[K] K' :=
+  { Ideal.Quotient.lift (IsLocalRing.maximalIdeal w.toValuationSubring)
+      (DOM_chi ι w v hdom hres) (DOM_chi_eq_zero ι w v hdom hres) with
+    commutes' := fun a => by
+      change Ideal.Quotient.lift (IsLocalRing.maximalIdeal w.toValuationSubring)
+          (DOM_chi ι w v hdom hres) (DOM_chi_eq_zero ι w v hdom hres)
+          (Ideal.Quotient.mk _ (algebraMap K w.toValuationSubring a)) = algebraMap K K' a
+      rw [Ideal.Quotient.lift_mk]
+      exact DOM_chi_algebraMap ι w v hdom hres hιK a }
+
+private theorem DOM_chiBar_residue [Algebra K K']
+    (hιK : ∀ a : K, ι (algebraMap K F a) = algebraMap K' F' (algebraMap K K' a))
+    (z : w.toValuationSubring) :
+    DOM_chiBar ι w v hdom hres hιK (IsLocalRing.residue _ z) = DOM_chi ι w v hdom hres z :=
+  Ideal.Quotient.lift_mk _ _ _
+
+end Chi
+
+private theorem DOM_dom_twist (ι : F →+* F') (w : Place K F) (v : Place K' F')
+    (hdom : ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v.toValuationSubring)
+    (σ : F' ≃+* F') (σK : K' ≃+* K')
+    (hσ : ∀ a : K', σ (algebraMap K' F' a) = algebraMap K' F' (σK a))
+    (hσι : ∀ x : F, σ (ι x) = ι x) (x : F) :
+    x ∈ w.toValuationSubring ↔ ι x ∈ (DOM_twist σ σK hσ v).toValuationSubring := by
+  rw [DOM_mem_twist_iff, show σ.symm (ι x) = ι x by rw [RingEquiv.symm_apply_eq, hσι], hdom]
+
+private theorem DOM_chi_twist (ι : F →+* F') (w : Place K F) (v : Place K' F')
+    (hdom : ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v.toValuationSubring)
+    (hres : ∀ v' : Place K' F', Function.Bijective (algebraMap K' v'.ResidueField))
+    (σ : F' ≃+* F') (σK : K' ≃+* K')
+    (hσ : ∀ a : K', σ (algebraMap K' F' a) = algebraMap K' F' (σK a))
+    (hσι : ∀ x : F, σ (ι x) = ι x) (z : w.toValuationSubring) :
+    DOM_chi ι w (DOM_twist σ σK hσ v) (DOM_dom_twist ι w v hdom σ σK hσ hσι) (hres _) z
+      = σK (DOM_chi ι w v hdom (hres v) z) := by
+  apply DOM_chi_unique
+  have hmem := DOM_chi_mem ι w v hdom (hres v) z
+  have hzF : ι (z : F) - algebraMap K' F' (DOM_chi ι w v hdom (hres v) z) ∈ v.toValuationSubring :=
+    sub_mem ((hdom _).mp z.2) (v.algebraMap_mem' _)
+  have hz' : σ (ι (z : F) - algebraMap K' F' (DOM_chi ι w v hdom (hres v) z)) ∈
+      (DOM_twist σ σK hσ v).toValuationSubring := by
+    rw [DOM_mem_twist_iff, RingEquiv.symm_apply_apply]
+    exact hzF
+  have h := DOM_mem_maximalIdeal_twist σ σK hσ v hzF hz' hmem
+  have heq : DOM_resMap ι w (DOM_twist σ σK hσ v) (DOM_dom_twist ι w v hdom σ σK hσ hσι) z
+        - algebraMap K' (DOM_twist σ σK hσ v).toValuationSubring
+            (σK (DOM_chi ι w v hdom (hres v) z))
+      = ⟨σ (ι (z : F) - algebraMap K' F' (DOM_chi ι w v hdom (hres v) z)), hz'⟩ := by
+    apply Subtype.ext
+    change ι (z : F) - algebraMap K' F' (σK (DOM_chi ι w v hdom (hres v) z))
+      = σ (ι (z : F) - algebraMap K' F' (DOM_chi ι w v hdom (hres v) z))
+    rw [map_sub, hσι, hσ]
+  rw [heq]
+  exact h
+
+private theorem DOM_tauK_chi_eq_of_twist_eq (ι : F →+* F') (w : Place K F) (v : Place K' F')
+    (hdom : ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v.toValuationSubring)
+    (hres : ∀ v' : Place K' F', Function.Bijective (algebraMap K' v'.ResidueField))
+    {E : Type*} (τ : E → (F' ≃+* F')) (τK : E → (K' ≃+* K'))
+    (hτ : ∀ (e : E) (a : K'), τ e (algebraMap K' F' a) = algebraMap K' F' (τK e a))
+    (hτι : ∀ (e : E) (x : F), τ e (ι x) = ι x) {e₁ e₂ : E}
+    (h : DOM_twist (τ e₁) (τK e₁) (hτ e₁) v = DOM_twist (τ e₂) (τK e₂) (hτ e₂) v)
+    (z : w.toValuationSubring) :
+    τK e₁ (DOM_chi ι w v hdom (hres v) z) = τK e₂ (DOM_chi ι w v hdom (hres v) z) := by
+  rw [← DOM_chi_twist ι w v hdom hres (τ e₁) (τK e₁) (hτ e₁) (hτι e₁) z,
+    ← DOM_chi_twist ι w v hdom hres (τ e₂) (τK e₂) (hτ e₂) (hτι e₂) z]
+  have key : ∀ (v₁ v₂ : Place K' F') (h12 : v₁ = v₂)
+      (h₁ : ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v₁.toValuationSubring)
+      (h₂ : ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v₂.toValuationSubring),
+      DOM_chi ι w v₁ h₁ (hres v₁) z = DOM_chi ι w v₂ h₂ (hres v₂) z := by
+    intro v₁ v₂ h12 h₁ h₂
+    subst h12
+    rfl
+  exact key _ _ h _ _
+
+private theorem DOM_count (ι : F →+* F') (w : Place K F) (v : Place K' F')
+    (hdom : ∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v.toValuationSubring)
+    (hres : ∀ v' : Place K' F', Function.Bijective (algebraMap K' v'.ResidueField))
+    {E : Type*} [Fintype E]
+    (τ : E → (F' ≃+* F')) (τK : E → (K' ≃+* K'))
+    (hτ : ∀ (e : E) (a : K'), τ e (algebraMap K' F' a) = algebraMap K' F' (τK e a))
+    (hτι : ∀ (e : E) (x : F), τ e (ι x) = ι x)
+    (hsep : ∀ e₁ e₂ : E,
+      (∀ z : w.toValuationSubring,
+        τK e₁ (DOM_chi ι w v hdom (hres v) z) = τK e₂ (DOM_chi ι w v hdom (hres v) z)) → e₁ = e₂) :
+    ∃ S : Finset (Place K' F'), Fintype.card E ≤ S.card ∧ ∀ v' ∈ S,
+      (∀ x : F, x ∈ w.toValuationSubring ↔ ι x ∈ v'.toValuationSubring) ∧
+      ∃ e : E, ∀ f : F', v'.ord (τ e f) = v.ord f := by
+  classical
+  refine ⟨Finset.univ.image (fun e => DOM_twist (τ e) (τK e) (hτ e) v), ?_, ?_⟩
+  · rw [Finset.card_image_of_injective _ (fun e₁ e₂ h =>
+      hsep e₁ e₂ (DOM_tauK_chi_eq_of_twist_eq ι w v hdom hres τ τK hτ hτι h)),
+      Finset.card_univ]
+  · intro v' hv'
+    obtain ⟨e, -, rfl⟩ := Finset.mem_image.mp hv'
+    exact ⟨DOM_dom_twist ι w v hdom (τ e) (τK e) (hτ e) (hτι e),
+      e, DOM_ord_twist (τ e) (τK e) (hτ e) v⟩
+
+end Kit
+
+section QBar
+
+private def DOM_fieldRangeEquiv {E : Type*} [Field E] [Algebra ℚ E]
+    (f : E →ₐ[ℚ] AlgebraicClosure ℚ) : E ≃ₐ[ℚ] f.fieldRange :=
+  AlgEquiv.ofBijective
+    (f.codRestrict f.fieldRange.toSubalgebra (fun z => f.mem_fieldRange.mpr ⟨z, rfl⟩))
+    ⟨fun a b hab => f.toRingHom.injective (congrArg Subtype.val hab),
+     fun y => by
+      obtain ⟨x, hx⟩ := f.mem_fieldRange.mp y.2
+      exact ⟨x, Subtype.ext hx⟩⟩
+
+private theorem DOM_fieldRangeEquiv_apply {E : Type*} [Field E] [Algebra ℚ E]
+    (f : E →ₐ[ℚ] AlgebraicClosure ℚ) (z : E) :
+    ((DOM_fieldRangeEquiv f z : f.fieldRange) : AlgebraicClosure ℚ) = f z := rfl
+
+set_option backward.isDefEq.respectTransparency false in
+private theorem DOM_exists_aut_comp_eq {E : Type*} [Field E] [Algebra ℚ E]
+    (χ₀ σ₀ : E →ₐ[ℚ] AlgebraicClosure ℚ) :
+    ∃ σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ, ∀ z : E, σ (χ₀ z) = σ₀ z := by
+  let e₀ : E ≃ₐ[ℚ] χ₀.fieldRange := DOM_fieldRangeEquiv χ₀
+  let e₁ : E ≃ₐ[ℚ] σ₀.fieldRange := DOM_fieldRangeEquiv σ₀
+  let φ : χ₀.fieldRange ≃ₐ[ℚ] σ₀.fieldRange := e₀.symm.trans e₁
+  refine ⟨φ.liftNormal (AlgebraicClosure ℚ), fun z => ?_⟩
+  have h1 : χ₀ z = algebraMap χ₀.fieldRange (AlgebraicClosure ℚ) (e₀ z) :=
+    (DOM_fieldRangeEquiv_apply χ₀ z).symm
+  rw [h1, AlgEquiv.liftNormal_commutes]
+  have h2 : φ (e₀ z) = e₁ z := by
+    change e₁ (e₀.symm (e₀ z)) = e₁ z
+    rw [AlgEquiv.symm_apply_apply]
+  rw [h2]
+  exact DOM_fieldRangeEquiv_apply σ₀ z
+
+end QBar
+
+section Concrete
+
+variable (N : ℕ) [NeZero N]
+
+private abbrev DOM_j : modularFunctionField N := ⟨jq, jq_mem N⟩
+
+private theorem DOM_iota_j' : DOM_iota N (DOM_j N) = jBar N := Subtype.ext rfl
+
+private theorem DOM_iota_algebraMap (c : ℚ) :
+    DOM_iota N (algebraMap ℚ (modularFunctionField N) c)
+      = algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+          (algebraMap ℚ (AlgebraicClosure ℚ) c) :=
+  RingHom.congr_fun (Subsingleton.elim
+    ((DOM_iota N).comp (algebraMap ℚ (modularFunctionField N)))
+    ((algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)).comp
+      (algebraMap ℚ (AlgebraicClosure ℚ)))) c
+
+private abbrev DOM_gAut (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) :
+    modularFunctionFieldBar N ≃+* modularFunctionFieldBar N :=
+  ModularCurve.arithmeticRingAut (modularFunctionFieldFull N) σ
+
+private theorem DOM_gAut_iota (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ)
+    (x : modularFunctionField N) : DOM_gAut N σ (DOM_iota N x) = DOM_iota N x := by
+  apply Subtype.ext
+  rw [ModularCurve.coe_arithmeticRingAut_apply]
+  exact ModularCurve.coeffMap_coeffEmb σ (x : LaurentSeries ℚ)
+
+omit [NeZero N] in
+private theorem DOM_gAut_algebraMap (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ)
+    (c : AlgebraicClosure ℚ) :
+    DOM_gAut N σ (algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) c)
+      = algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) (σ c) :=
+  ModularCurve.arithmeticRingAut_algebraMap (modularFunctionFieldFull N) σ c
+
+private theorem DOM_jBar_ne_algebraMap (j₀ : AlgebraicClosure ℚ) :
+    (jBar N : modularFunctionFieldBar N)
+      ≠ algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀ := by
+  intro heq
+  obtain ⟨S, hS⟩ := ModularCurve.exists_finset_ord_jBar_sub_pos N j₀
+  have hsum := ModularCurve.sum_ord_jBar_sub_eq_dedekindPsi N j₀
+    (ModularCurve.deg_eq_one_modularFunctionFieldBar N) S hS
+  have hempty : S = ∅ := by
+    rw [Finset.eq_empty_iff_forall_notMem]
+    intro v hv
+    have h := (hS v).mp hv
+    rw [heq, sub_self, Place.ord_zero] at h
+    exact lt_irrefl _ h
+  rw [hempty, Finset.sum_empty] at hsum
+  have hψ := ModularCurve.dedekindPsi_pos N (NeZero.ne N)
+  omega
+
+set_option backward.isDefEq.respectTransparency false in
+private theorem DOM_isIntegral_qbar (c : AlgebraicClosure ℚ) : IsIntegral ℚ c :=
+  isAlgebraic_iff_isIntegral.mp (Algebra.IsAlgebraic.isAlgebraic (R := ℚ) c)
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+private theorem DOM_residueBij (v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) :
+    Function.Bijective (algebraMap (AlgebraicClosure ℚ) v.ResidueField) := by
+  have hfin : Module.Finite (AlgebraicClosure ℚ) v.ResidueField :=
+    Module.finite_of_finrank_pos (by
+      have h1 : v.deg = 1 := ModularCurve.deg_eq_one_modularFunctionFieldBar N v
+      change 0 < Module.finrank (AlgebraicClosure ℚ) v.ResidueField
+      rw [show Module.finrank (AlgebraicClosure ℚ) v.ResidueField = v.deg from rfl, h1]
+      omega)
+  have : Algebra.IsIntegral (AlgebraicClosure ℚ) v.ResidueField :=
+    Algebra.IsIntegral.of_finite _ _
+  exact IsAlgClosed.algebraMap_bijective_of_isIntegral
+
+private theorem DOM_card_embeddings (w : Place ℚ (modularFunctionField N))
+    [FiniteDimensional ℚ w.ResidueField] :
+    Fintype.card (w.ResidueField →ₐ[ℚ] AlgebraicClosure ℚ) = w.deg := by
+  have : Algebra.IsIntegral ℚ w.ResidueField := Algebra.IsIntegral.of_finite ℚ _
+  have : Algebra.IsAlgebraic ℚ w.ResidueField := Algebra.IsAlgebraic.of_finite ℚ _
+  exact AlgHom.card ℚ w.ResidueField (AlgebraicClosure ℚ)
+
+section PerW
+
+variable (w : Place ℚ (modularFunctionField N)) (hj : DOM_j N ∈ w.toValuationSubring)
+
+private theorem DOM_algebraMap_mem_of_dom (A : ValuationSubring (modularFunctionFieldBar N))
+    (hA : ∀ x : modularFunctionField N, x ∈ w.toValuationSubring → DOM_iota N x ∈ A)
+    (c : AlgebraicClosure ℚ) :
+    algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) c ∈ A := by
+  have hψ : ∀ q : ℚ, ((algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)).comp
+      (algebraMap ℚ (AlgebraicClosure ℚ))) q ∈ A := by
+    intro q
+    rw [RingHom.comp_apply, ← DOM_iota_algebraMap]
+    exact hA _ (w.algebraMap_mem' q)
+  refine DOM_mem_of_isIntegralElem A _ hψ ?_
+  obtain ⟨p, hp, hpc⟩ := DOM_isIntegral_qbar c
+  refine ⟨p, hp, ?_⟩
+  rw [← Polynomial.hom_eval₂, hpc, map_zero]
+
+include hj in
+private theorem DOM_adjoin_mem_of_dom (A : ValuationSubring (modularFunctionFieldBar N))
+    (hA : ∀ x : modularFunctionField N, x ∈ w.toValuationSubring → DOM_iota N x ∈ A)
+    (x : modularFunctionFieldBar N)
+    (hx : x ∈ Algebra.adjoin (AlgebraicClosure ℚ)
+      ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N))) :
+    x ∈ A := by
+  refine Algebra.adjoin_induction (fun y hy => ?_) (fun c => DOM_algebraMap_mem_of_dom N w A hA c)
+    (fun _ _ _ _ hx hy => add_mem hx hy) (fun _ _ _ _ hx hy => mul_mem hx hy) hx
+  rw [Set.mem_singleton_iff.mp hy, ← DOM_iota_j']
+  exact hA _ hj
+
+include hj in
+private theorem DOM_normalization_mem_of_dom (A : ValuationSubring (modularFunctionFieldBar N))
+    (hA : ∀ x : modularFunctionField N, x ∈ w.toValuationSubring → DOM_iota N x ∈ A)
+    (b : DOM_normalization (AlgebraicClosure ℚ) (jBar N : modularFunctionFieldBar N)) :
+    algebraMap _ (modularFunctionFieldBar N) b ∈ A := by
+  have hb : IsIntegral (Algebra.adjoin (AlgebraicClosure ℚ)
+      ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)))
+      (b : modularFunctionFieldBar N) := b.2
+  exact DOM_mem_of_isIntegralElem A (algebraMap _ (modularFunctionFieldBar N))
+    (fun (s : Algebra.adjoin (AlgebraicClosure ℚ)
+        ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N))) =>
+      DOM_adjoin_mem_of_dom N w hj A hA (s : modularFunctionFieldBar N) s.2) hb
+
+include hj in
+set_option synthInstance.maxHeartbeats 1600000 in
+private theorem DOM_exists_dominating_place :
+    ∃ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N),
+      ∀ x : modularFunctionField N,
+        x ∈ w.toValuationSubring ↔ DOM_iota N x ∈ v.toValuationSubring := by
+  obtain ⟨A, hAtop, hdomA⟩ := DOM_exists_valuationSubring_dom (DOM_iota N) w
+  obtain ⟨v, hv⟩ := DOM_exists_place_of_forall_mem (K' := AlgebraicClosure ℚ)
+    (R := ↥(DOM_normalization (AlgebraicClosure ℚ) (jBar N : modularFunctionFieldBar N)))
+    A hAtop (DOM_normalization_mem_of_dom N w hj A (fun x hx => (hdomA x).mp hx))
+  exact ⟨v, fun x => by rw [hv]; exact hdomA x⟩
+
+private theorem DOM_j_mem_vsr (hw : 0 ≤ w.ord (DOM_j N)) : DOM_j N ∈ w.toValuationSubring := by
+  by_cases h0 : DOM_j N = (0 : modularFunctionField N)
+  · rw [h0]
+    exact zero_mem _
+  · exact DOM_mem_of_ord_nonneg w h0 hw
+
+end PerW
+
+section PerV
+
+variable (w : Place ℚ (modularFunctionField N)) (hj : DOM_j N ∈ w.toValuationSubring)
+  (v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N))
+  (hdom : ∀ x : modularFunctionField N,
+    x ∈ w.toValuationSubring ↔ DOM_iota N x ∈ v.toValuationSubring)
+
+private def DOM_chiBarV : w.ResidueField →ₐ[ℚ] AlgebraicClosure ℚ :=
+  DOM_chiBar (DOM_iota N) w v hdom (DOM_residueBij N v) (DOM_iota_algebraMap N)
+
+private theorem DOM_chiBarV_residue (z : w.toValuationSubring) :
+    DOM_chiBarV N w v hdom (IsLocalRing.residue _ z)
+      = DOM_chi (DOM_iota N) w v hdom (DOM_residueBij N v) z :=
+  DOM_chiBar_residue _ _ _ _ _ _ z
+
+private def DOM_sigma (ψ : w.ResidueField →ₐ[ℚ] AlgebraicClosure ℚ) :
+    AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ :=
+  (DOM_exists_aut_comp_eq (DOM_chiBarV N w v hdom) ψ).choose
+
+private theorem DOM_sigma_spec (ψ : w.ResidueField →ₐ[ℚ] AlgebraicClosure ℚ)
+    (q : w.ResidueField) :
+    DOM_sigma N w v hdom ψ (DOM_chiBarV N w v hdom q) = ψ q :=
+  (DOM_exists_aut_comp_eq (DOM_chiBarV N w v hdom) ψ).choose_spec q
+
+include hj hdom in
+private theorem DOM_main_pos [FiniteDimensional ℚ w.ResidueField] :
+    ∃ S : Finset (Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)),
+      w.deg ≤ S.card ∧ ∀ v ∈ S,
+        (∃ j₀ : AlgebraicClosure ℚ,
+          0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)) ∧
+        ∃ c : ℤ, 0 < c ∧
+          ∀ (x : modularFunctionField N) (y : modularFunctionFieldBar N),
+            (y : LaurentSeries (AlgebraicClosure ℚ))
+                = coeffEmb (AlgebraicClosure ℚ) (x : LaurentSeries ℚ) →
+              v.ord y = c * w.ord x := by
+  classical
+  obtain ⟨S, hcard, hS⟩ := DOM_count (DOM_iota N) w v hdom (DOM_residueBij N)
+    (E := w.ResidueField →ₐ[ℚ] AlgebraicClosure ℚ)
+    (fun ψ => DOM_gAut N (DOM_sigma N w v hdom ψ))
+    (fun ψ => (DOM_sigma N w v hdom ψ : AlgebraicClosure ℚ ≃+* AlgebraicClosure ℚ))
+    (fun ψ a => DOM_gAut_algebraMap N _ a) (fun ψ x => DOM_gAut_iota N _ x) (by
+      intro ψ₁ ψ₂ h
+      apply AlgHom.ext
+      intro q
+      obtain ⟨z, rfl⟩ := Ideal.Quotient.mk_surjective q
+      change ψ₁ (IsLocalRing.residue _ z) = ψ₂ (IsLocalRing.residue _ z)
+      rw [← DOM_sigma_spec N w v hdom ψ₁, ← DOM_sigma_spec N w v hdom ψ₂,
+        DOM_chiBarV_residue]
+      exact h z)
+  refine ⟨S, by rw [← DOM_card_embeddings N w]; exact hcard, fun v' hv' => ?_⟩
+  obtain ⟨hdom', ψ, hord⟩ := hS v' hv'
+  have hord' : ∀ f : modularFunctionFieldBar N,
+      v'.ord (DOM_gAut N (DOM_sigma N w v hdom ψ) f) = v.ord f := hord
+  refine ⟨?_, ?_⟩
+  · have hne : DOM_iota N (DOM_j N) - algebraMap _ _
+        (DOM_chi (DOM_iota N) w v hdom (DOM_residueBij N v) ⟨DOM_j N, hj⟩) ≠ 0 := by
+      rw [DOM_iota_j', sub_ne_zero]
+      exact DOM_jBar_ne_algebraMap N _
+    have hpos := DOM_ord_sub_chi_pos (DOM_iota N) w v hdom (DOM_residueBij N v)
+      ⟨DOM_j N, hj⟩ hne
+    refine ⟨DOM_sigma N w v hdom ψ
+      (DOM_chi (DOM_iota N) w v hdom (DOM_residueBij N v) ⟨DOM_j N, hj⟩), ?_⟩
+    have key : DOM_gAut N (DOM_sigma N w v hdom ψ)
+          (DOM_iota N (DOM_j N) - algebraMap _ _
+            (DOM_chi (DOM_iota N) w v hdom (DOM_residueBij N v) ⟨DOM_j N, hj⟩))
+        = jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+            (DOM_sigma N w v hdom ψ
+              (DOM_chi (DOM_iota N) w v hdom (DOM_residueBij N v) ⟨DOM_j N, hj⟩)) := by
+      rw [map_sub, DOM_gAut_iota, DOM_gAut_algebraMap, DOM_iota_j']
+    rw [← key, hord']
+    exact hpos
+  · obtain ⟨c, hc, hident⟩ := DOM_exists_ord_comp_eq_mul (DOM_iota N) w v' hdom'
+    refine ⟨c, hc, fun x y hy => ?_⟩
+    have hy' : y = DOM_iota N x := Subtype.ext hy
+    rw [hy']
+    exact hident x
+
+end PerV
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+private theorem DOM_main (w : Place ℚ (modularFunctionField N))
+    (hw : 0 ≤ w.ord (⟨jq, jq_mem N⟩ : modularFunctionField N)) :
+    ∃ S : Finset (Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)),
+      w.deg ≤ S.card ∧ ∀ v ∈ S,
+        (∃ j₀ : AlgebraicClosure ℚ,
+          0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)) ∧
+        ∃ c : ℤ, 0 < c ∧
+          ∀ (x : modularFunctionField N) (y : modularFunctionFieldBar N),
+            (y : LaurentSeries (AlgebraicClosure ℚ))
+                = coeffEmb (AlgebraicClosure ℚ) (x : LaurentSeries ℚ) →
+              v.ord y = c * w.ord x := by
+  classical
+  by_cases hdeg0 : w.deg = 0
+  · refine ⟨∅, ?_, ?_⟩
+    · rw [hdeg0]
+      exact Nat.zero_le _
+    · intro v hv
+      exact absurd hv (Finset.notMem_empty v)
+  · have hdpos : 0 < w.deg := Nat.pos_of_ne_zero hdeg0
+    have hj : DOM_j N ∈ w.toValuationSubring := DOM_j_mem_vsr N w hw
+    obtain ⟨v, hdom⟩ := DOM_exists_dominating_place N w hj
+    have : FiniteDimensional ℚ w.ResidueField := Module.finite_of_finrank_pos hdpos
+    exact DOM_main_pos N w hj v hdom
+
+end Concrete
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jBar arithmeticRingAut coe_arithmeticRingAut_apply \
+  arithmeticRingAut_algebraMap modularFunctionFieldBar jq dedekindPsi modularFunctionField jq_mem \
+  jGen modularFunctionFieldFull modularFunctionField_le_full coeffEmb coeffMap_coeffEmb \
+  coeffEmb_mem_laurentBaseChange sum_ord_jBar_sub_eq_dedekindPsi exists_finset_ord_jBar_sub_pos \
+  deg_eq_one_modularFunctionFieldBar jAdjoinAlgebra jLineRingEquiv jLineRingEquiv_X \
+  instDecidableEqRatFuncRat jLinePlace1728 jLinePlaceZero jLinePlaceInfty nuTwo nuThree \
+  ModuliPoint ModuliPoint.j finrank_jAdjoin_modularFunctionField_eq_dedekindPsi \
+  two_mul_natCard_moduliPoint_j_eq_1728_eq_dedekindPsi_add_nuTwo \
+  three_mul_natCard_moduliPoint_j_eq_zero_eq_dedekindPsi_add_two_mul_nuThree \
+  relfinrank_full_eq_dedekindPsi relfinrank_laurentBaseChange_modularFunctionFieldFull \
+  dedekindPsi_pos restrict_eq_jLinePlace1728_iff restrict_eq_jLinePlaceZero_iff \
+  restrict_eq_jLinePlaceInfty_iff ramificationIndex_eq_ord_sub_of_restrict_eq_jLinePlace1728 \
+  ramificationIndex_eq_ord_of_restrict_eq_jLinePlaceZero \
+  exists_irreducible_ramificationIndex_eq_ord_aeval_of_restrict_ne_jLinePlaces deg_jLinePlace1728 \
+  deg_jLinePlaceZero"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.exists_finset_place_bar_dominating_of_ord_jq_nonneg (N : ℕ) [NeZero N]
+    (w : Place ℚ (modularFunctionField N))
+    (hw : 0 ≤ w.ord (⟨jq, jq_mem N⟩ : modularFunctionField N)) :
+    ∃ S : Finset (Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)),
+      w.deg ≤ S.card ∧ ∀ v ∈ S,
+        (∃ j₀ : AlgebraicClosure ℚ,
+          0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)) ∧
+        ∃ c : ℤ, 0 < c ∧
+          ∀ (x : modularFunctionField N) (y : modularFunctionFieldBar N),
+            (y : LaurentSeries (AlgebraicClosure ℚ)) = coeffEmb (AlgebraicClosure ℚ) (x :
+              LaurentSeries ℚ) →
+              v.ord y = c * w.ord x :=
+  DOM_main N w hw
+
+end
+
+p2m_open "IntermediateField AlgebraicCurve AlgebraicCurve.RationalFunctionField ModularCurve \
+  P2MW.S_ModularCurve_natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo.ModularCurve"
+
+noncomputable section
+
+namespace CNTUnit
+
+open Polynomial IsDedekindDomain WithZero
+
+attribute [local instance 2000] RatFunc.instAlgebraOfPolynomial
+attribute [local instance] ModularCurve.instDecidableEqRatFuncRat
+attribute [local instance] ModularCurve.jAdjoinAlgebra
+
+section Generic
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+private theorem CNT_ord_nonneg_of_mem (v : Place K F) {f : F} (hf : f ∈ v.toValuationSubring) :
+    0 ≤ v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨n, u, hu⟩ :=
+    IsDiscreteValuationRing.eq_unit_mul_pow_irreducible
+      (x := (⟨f, hf⟩ : v.toValuationSubring)) (by simpa [Subtype.ext_iff] using hf0) hπ
+  have hcoe : f = ((u : v.toValuationSubring) : F) * ((π : F) ^ (n : ℤ)) := by
+    have h := congrArg (Subtype.val) hu
+    push_cast at h
+    rw [zpow_natCast]
+    exact h
+  rw [hcoe, v.ord_unit_smul_zpow u hπ (n : ℤ)]
+  exact Int.natCast_nonneg n
+
+private theorem CNT_mem_of_ord_nonneg (w : Place K F) {f : F} (hf : f ≠ 0) (h : 0 ≤ w.ord f) :
+    f ∈ w.toValuationSubring := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  obtain ⟨u, hu⟩ := w.exists_unit_mul_zpow hf hπ
+  rw [hu, show w.ord f = (((w.ord f).toNat : ℕ) : ℤ) from (Int.toNat_of_nonneg h).symm,
+    zpow_natCast]
+  exact mul_mem (u : w.toValuationSubring).2 (pow_mem (π : w.toValuationSubring).2 _)
+
+private theorem CNT_mem_of_ord_sub_pos (w : Place K F) {f : F} {c : K}
+    (h : 0 < w.ord (f - algebraMap K F c)) : f ∈ w.toValuationSubring := by
+  have hne : f - algebraMap K F c ≠ 0 := by
+    intro h0
+    rw [h0, Place.ord_zero] at h
+    exact lt_irrefl _ h
+  have := add_mem (CNT_mem_of_ord_nonneg w hne h.le) (w.algebraMap_mem' c)
+  rwa [sub_add_cancel] at this
+
+private theorem CNT_ord_eq_one_of_valuation_eq (w : Place K F) {v' : Valuation F ℤᵐ⁰}
+    (hv' : v'.valuationSubring = w.toValuationSubring) {x : F} (hx : v' x = exp (-1 : ℤ)) :
+    w.ord x = 1 := by
+  have hE := w.isEquiv_adicValuation_of_valuationSubring_eq hv'
+  have hx0 : v' x ≠ 0 := by rw [hx]; exact exp_ne_zero
+  have hu0 : w.adicValuation x ≠ 0 := (hE.eq_zero).ne.mp hx0
+  have hlt : w.adicValuation x < 1 := by
+    refine hE.lt_one_iff_lt_one.mp ?_
+    rw [hx, ← exp_zero]
+    exact exp_lt_exp.mpr (by norm_num)
+  obtain ⟨ϖ, hϖ⟩ := w.heightOneSpectrum.valuation_exists_uniformizer F
+  change w.adicValuation ϖ = exp (-1 : ℤ) at hϖ
+  have hϖ0 : w.adicValuation ϖ ≠ 0 := by rw [hϖ]; exact exp_ne_zero
+  have hϖlt : v' ϖ < 1 := by
+    refine hE.lt_one_iff_lt_one.mpr ?_
+    rw [hϖ, ← exp_zero]
+    exact exp_lt_exp.mpr (by norm_num)
+  have hϖ0' : v' ϖ ≠ 0 := (hE.eq_zero).ne.mpr hϖ0
+  have hϖle : v' ϖ ≤ v' x := by
+    rw [hx, ← log_le_iff_le_exp hϖ0']
+    have hlog : log (v' ϖ) < 0 := (log_lt_iff_lt_exp hϖ0').mpr (by rw [exp_zero]; exact hϖlt)
+    omega
+  have hge : exp (-1 : ℤ) ≤ w.adicValuation x := by
+    rw [← hϖ]
+    exact (hE ϖ x).mp hϖle
+  have hle' : log (w.adicValuation x) ≤ -1 := by
+    have hlog : log (w.adicValuation x) < 0 :=
+      (log_lt_iff_lt_exp hu0).mpr (by rw [exp_zero]; exact hlt)
+    omega
+  have hge' : -1 ≤ log (w.adicValuation x) := (le_log_iff_exp_le hu0).mpr hge
+  simp only [Place.ord]
+  omega
+
+end Generic
+
+section RatFuncLine
+
+variable {K : Type*} [Field K]
+
+private theorem CNT_algebraMap_polynomial_mem (p : Place K (RatFunc K))
+    (hX : (RatFunc.X : RatFunc K) ∈ p.toValuationSubring) (r : K[X]) :
+    algebraMap K[X] (RatFunc K) r ∈ p.toValuationSubring := by
+  induction r using Polynomial.induction_on with
+  | C a =>
+    rw [RatFunc.algebraMap_C, ← RatFunc.algebraMap_eq_C]
+    exact p.algebraMap_mem' a
+  | add r s hr hs =>
+    rw [map_add]
+    exact add_mem hr hs
+  | monomial n a h =>
+    rw [pow_succ, ← mul_assoc, map_mul, RatFunc.algebraMap_X]
+    exact mul_mem h hX
+
+private theorem CNT_ord_placeOfPoint (c : K) :
+    (placeOfPoint K c).ord ((RatFunc.X : RatFunc K) - algebraMap K (RatFunc K) c) = 1 := by
+  have hq0 : (X - C c : K[X]) ≠ 0 := X_sub_C_ne_zero c
+  have hmap : algebraMap K[X] (RatFunc K) (X - C c) =
+      (RatFunc.X : RatFunc K) - algebraMap K (RatFunc K) c := by
+    rw [map_sub, RatFunc.algebraMap_X, RatFunc.algebraMap_C, RatFunc.algebraMap_eq_C]
+  rw [← hmap, placeOfPoint_eq_ofHeightOneSpectrum]
+  refine CNT_ord_eq_one_of_valuation_eq _
+    (v' := (heightOneSpectrumOfIrreducible K (irreducible_X_sub_C c)).valuation (RatFunc K)) rfl ?_
+  rw [HeightOneSpectrum.valuation_of_algebraMap]
+  exact (heightOneSpectrumOfIrreducible K (irreducible_X_sub_C c)).intValuation_singleton hq0 rfl
+
+private theorem CNT_eq_placeOfPoint_of_ord_pos (p : Place K (RatFunc K)) (c : K)
+    (h : 0 < p.ord ((RatFunc.X : RatFunc K) - algebraMap K (RatFunc K) c)) :
+    p = placeOfPoint K c := by
+  have hX : (RatFunc.X : RatFunc K) ∈ p.toValuationSubring := CNT_mem_of_ord_sub_pos p h
+  have hw : ∀ r : K[X], algebraMap K[X] (RatFunc K) r ∈ p.toValuationSubring :=
+    CNT_algebraMap_polynomial_mem p hX
+  have hq0 : (X - C c : K[X]) ≠ 0 := X_sub_C_ne_zero c
+  have hmem : (X - C c : K[X]) ∈ Place.center K[X] p hw := by
+    rw [Place.mem_center_iff_ord_pos p hw hq0, map_sub, RatFunc.algebraMap_X, RatFunc.algebraMap_C]
+    rw [RatFunc.algebraMap_eq_C] at h
+    exact h
+  have hcenter : Place.center K[X] p hw = Ideal.span {(X - C c : K[X])} := by
+    have hmax : (Ideal.span {(X - C c : K[X])}).IsMaximal :=
+      PrincipalIdealRing.isMaximal_of_irreducible (irreducible_X_sub_C c)
+    exact (hmax.eq_of_le (Ideal.IsPrime.ne_top inferInstance)
+      ((Ideal.span_singleton_le_iff_mem _).mpr hmem)).symm
+  have hc : Place.centerHeightOneSpectrum K[X] p hw =
+      heightOneSpectrumOfIrreducible K (irreducible_X_sub_C c) :=
+    HeightOneSpectrum.ext hcenter
+  apply Place.ext
+  rw [p.toValuationSubring_eq_of_forall_mem hw, hc, placeOfPoint_eq_ofHeightOneSpectrum,
+    Place.ofHeightOneSpectrum_toValuationSubring,
+    HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+
+end RatFuncLine
+
+section JLine
+
+private def CNT_base (c : ℚ) : Place ℚ ℚ⟮jq⟯ :=
+  Place.congrRingEquiv jLineRingEquiv (RingHom.map_rat_algebraMap jLineRingEquiv.toRingHom)
+    (placeOfPoint ℚ c)
+
+private theorem CNT_jLinePlace1728_eq : jLinePlace1728 = CNT_base 1728 := rfl
+
+private theorem CNT_jLinePlaceZero_eq : jLinePlaceZero = CNT_base 0 := rfl
+
+private theorem CNT_deg_base (c : ℚ) : (CNT_base c).deg = 1 := by
+  rw [CNT_base, Place.deg_congrRingEquiv, deg_placeOfPoint]
+
+private theorem CNT_jLineRingEquiv_X_sub (c : ℚ) :
+    jLineRingEquiv ((RatFunc.X : RatFunc ℚ) - algebraMap ℚ (RatFunc ℚ) c) =
+      jGen - algebraMap ℚ ℚ⟮jq⟯ c := by
+  rw [map_sub, jLineRingEquiv_X]
+  congr 1
+  exact RingHom.map_rat_algebraMap jLineRingEquiv.toRingHom c
+
+private theorem CNT_ord_base (c : ℚ) : (CNT_base c).ord (jGen - algebraMap ℚ ℚ⟮jq⟯ c) = 1 := by
+  rw [← CNT_jLineRingEquiv_X_sub, CNT_base, Place.ord_congrRingEquiv, CNT_ord_placeOfPoint]
+
+private theorem CNT_eq_base_of_ord_pos (q : Place ℚ ℚ⟮jq⟯) (c : ℚ)
+    (h : 0 < q.ord (jGen - algebraMap ℚ ℚ⟮jq⟯ c)) : q = CNT_base c := by
+  have he : ∀ a : ℚ, jLineRingEquiv (algebraMap ℚ (RatFunc ℚ) a) = algebraMap ℚ ℚ⟮jq⟯ a :=
+    RingHom.map_rat_algebraMap jLineRingEquiv.toRingHom
+  have hx : jLineRingEquiv.symm (jGen - algebraMap ℚ ℚ⟮jq⟯ c) =
+      (RatFunc.X : RatFunc ℚ) - algebraMap ℚ (RatFunc ℚ) c := by
+    rw [← CNT_jLineRingEquiv_X_sub, RingEquiv.symm_apply_apply]
+  have h' : 0 < (Place.congrRingEquiv jLineRingEquiv.symm (Place.symm_algebraMap_comm _ he) q).ord
+      ((RatFunc.X : RatFunc ℚ) - algebraMap ℚ (RatFunc ℚ) c) := by
+    rw [← hx, Place.ord_congrRingEquiv]
+    exact h
+  have hq' := CNT_eq_placeOfPoint_of_ord_pos _ c h'
+  calc q = Place.congrEquiv jLineRingEquiv he ((Place.congrEquiv jLineRingEquiv he).symm q) :=
+        ((Place.congrEquiv jLineRingEquiv he).apply_symm_apply q).symm
+    _ = CNT_base c := by
+        rw [Place.congrEquiv_symm_apply, hq', Place.congrEquiv_apply]
+        rfl
+
+end JLine
+
+section Tower
+
+variable (N : ℕ) [NeZero N]
+
+private theorem CNT_algebraMap_jGen_sub (c : ℚ) :
+    algebraMap ℚ⟮jq⟯ (modularFunctionField N) (jGen - algebraMap ℚ ℚ⟮jq⟯ c) =
+      (⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N) c := by
+  rw [map_sub, ← IsScalarTower.algebraMap_apply]
+  congr 1
+
+private theorem CNT_ord_sub_eq_mul [Algebra.IsIntegral ℚ⟮jq⟯ (modularFunctionField N)]
+    (w : Place ℚ (modularFunctionField N)) (c : ℚ) :
+    w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N) c) =
+      w.ramificationIndex ℚ⟮jq⟯ * (w.restrict ℚ⟮jq⟯).ord (jGen - algebraMap ℚ ℚ⟮jq⟯ c) := by
+  rw [← CNT_algebraMap_jGen_sub, Place.ord_restrict]
+
+private theorem CNT_restrict_eq_base_iff [Algebra.IsIntegral ℚ⟮jq⟯ (modularFunctionField N)]
+    (w : Place ℚ (modularFunctionField N)) (c : ℚ) :
+    w.restrict ℚ⟮jq⟯ = CNT_base c ↔
+      0 < w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N)
+        c) := by
+  constructor
+  · intro h
+    rw [CNT_ord_sub_eq_mul N w c, h, CNT_ord_base, mul_one]
+    exact_mod_cast w.ramificationIndex_pos (F := ℚ⟮jq⟯)
+  · intro h
+    refine CNT_eq_base_of_ord_pos _ c ?_
+    rw [CNT_ord_sub_eq_mul N w c] at h
+    exact (pos_iff_pos_of_mul_pos h).mp
+      (by exact_mod_cast w.ramificationIndex_pos (F := ℚ⟮jq⟯))
+
+private theorem CNT_ramificationIndex_eq_ord [Algebra.IsIntegral ℚ⟮jq⟯ (modularFunctionField N)]
+    (w : Place ℚ (modularFunctionField N)) (c : ℚ)
+    (h : 0 < w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField
+      N) c)) :
+    (w.ramificationIndex ℚ⟮jq⟯ : ℤ) =
+      w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N) c)
+        := by
+  rw [CNT_ord_sub_eq_mul N w c, (CNT_restrict_eq_base_iff N w c).mpr h, CNT_ord_base, mul_one]
+
+private scoped instance CNT_finiteDimensional : FiniteDimensional ℚ⟮jq⟯ (modularFunctionField N) :=
+  Module.finite_of_finrank_pos (by
+    rw [finrank_jAdjoin_modularFunctionField_eq_dedekindPsi N]
+    exact dedekindPsi_pos N (NeZero.ne N))
+
+private scoped instance CNT_charZero : CharZero ℚ⟮jq⟯ :=
+  charZero_of_injective_algebraMap (algebraMap ℚ ℚ⟮jq⟯).injective
+
+private scoped instance CNT_isSeparable : Algebra.IsSeparable ℚ⟮jq⟯ (modularFunctionField N) :=
+  Algebra.IsSeparable.of_integral _ _
+
+private theorem CNT_exists_companion (x : modularFunctionField N) :
+    ∃ y : modularFunctionFieldBar N,
+      (y : LaurentSeries (AlgebraicClosure ℚ)) = coeffEmb (AlgebraicClosure ℚ) (x : LaurentSeries ℚ)
+        :=
+  ⟨⟨coeffEmb (AlgebraicClosure ℚ) (x : LaurentSeries ℚ),
+    coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionField_le_full N x.2)⟩, rfl⟩
+
+private theorem CNT_coe_jBar_sub (c : ℚ) :
+    ((jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) (c : AlgebraicClosure
+      ℚ) :
+        modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ)) =
+      coeffEmb (AlgebraicClosure ℚ)
+        (((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N) c :
+          modularFunctionField N) : LaurentSeries ℚ) := by
+  have h1 : (((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N) c :
+      modularFunctionField N) : LaurentSeries ℚ) = jq - (c : LaurentSeries ℚ) := by
+    rw [eq_ratCast (algebraMap ℚ (modularFunctionField N)) c, AddSubgroupClass.coe_sub,
+      SubfieldClass.coe_ratCast]
+  have h2 : ((jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) (c :
+    AlgebraicClosure ℚ) :
+      modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ)) =
+      coeffEmb (AlgebraicClosure ℚ) jq -
+        algebraMap (AlgebraicClosure ℚ) (LaurentSeries (AlgebraicClosure ℚ)) (c : AlgebraicClosure
+          ℚ) := rfl
+  rw [h1, h2, map_sub, map_ratCast, map_ratCast]
+
+private theorem CNT_eq_of_dominated (w w' : Place ℚ (modularFunctionField N))
+    (v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) (a a' : ℤ) (ha : 0 < a)
+    (ha' : 0 < a')
+    (h : ∀ (x : modularFunctionField N) (y : modularFunctionFieldBar N),
+      (y : LaurentSeries (AlgebraicClosure ℚ)) = coeffEmb (AlgebraicClosure ℚ) (x : LaurentSeries ℚ)
+        →
+        v.ord y = a * w.ord x)
+    (h' : ∀ (x : modularFunctionField N) (y : modularFunctionFieldBar N),
+      (y : LaurentSeries (AlgebraicClosure ℚ)) = coeffEmb (AlgebraicClosure ℚ) (x : LaurentSeries ℚ)
+        →
+        v.ord y = a' * w'.ord x) :
+    w = w' := by
+  apply Place.ext
+  ext x
+  rcases eq_or_ne x 0 with rfl | hx0
+  · simp
+  obtain ⟨y, hyx⟩ := CNT_exists_companion N x
+  have h1 := h x y hyx
+  have h2 := h' x y hyx
+  constructor
+  · intro hx
+    have h0 : 0 ≤ w.ord x := CNT_ord_nonneg_of_mem w hx
+    refine CNT_mem_of_ord_nonneg w' hx0 ?_
+    by_contra hneg
+    push Not at hneg
+    have := mul_neg_of_pos_of_neg ha' hneg
+    have := mul_nonneg ha.le h0
+    omega
+  · intro hx
+    have h0 : 0 ≤ w'.ord x := CNT_ord_nonneg_of_mem w' hx
+    refine CNT_mem_of_ord_nonneg w hx0 ?_
+    by_contra hneg
+    push Not at hneg
+    have := mul_neg_of_pos_of_neg ha hneg
+    have := mul_nonneg ha'.le h0
+    omega
+
+end Tower
+
+section Squeeze
+
+variable (N : ℕ) [NeZero N] [HasPrincipalDivisors ℚ (modularFunctionField N)]
+
+private theorem CNT_squeeze (c : ℚ) :
+    (∀ w : Place ℚ (modularFunctionField N),
+      0 < w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N)
+        c) →
+      ∃ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N),
+        ∀ (x : modularFunctionField N) (y : modularFunctionFieldBar N),
+          (y : LaurentSeries (AlgebraicClosure ℚ)) = coeffEmb (AlgebraicClosure ℚ) (x :
+            LaurentSeries ℚ) →
+            v.ord y = w.ord x) ∧
+    (∀ T : Finset (Place ℚ (modularFunctionField N)),
+      (∀ w, w ∈ T ↔
+        w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N) c)
+          = 1) →
+      ∑ w ∈ T, (w.deg : ℤ) =
+        Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+          v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+            (c : AlgebraicClosure ℚ)) = 1}) := by
+  classical
+  obtain ⟨P, hP⟩ := ModularCurve.exists_finset_ord_jBar_sub_pos N (c : AlgebraicClosure ℚ)
+  have hPEO := ModularCurve.sum_ord_jBar_sub_eq_dedekindPsi N (c : AlgebraicClosure ℚ)
+    (deg_eq_one_modularFunctionFieldBar N) P hP
+  have hW : ∀ w : Place ℚ (modularFunctionField N), w ∈ (CNT_base c).fiber (modularFunctionField N)
+    ↔
+      0 < w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N)
+        c) :=
+    fun w => by rw [Place.mem_fiber, CNT_restrict_eq_base_iff]
+  have hsum :=
+    Place.sum_ramificationIndex_mul_inertiaDeg (F' := modularFunctionField N) (CNT_base c)
+  rw [finrank_jAdjoin_modularFunctionField_eq_dedekindPsi N] at hsum
+  have hf : ∀ w ∈ (CNT_base c).fiber (modularFunctionField N), w.inertiaDeg ℚ⟮jq⟯ = w.deg := by
+    intro w hw
+    have h := w.deg_restrict_mul_inertiaDeg (F := ℚ⟮jq⟯)
+    rwa [Place.mem_fiber.mp hw, CNT_deg_base, one_mul] at h
+  have he : ∀ w ∈ (CNT_base c).fiber (modularFunctionField N), (w.ramificationIndex ℚ⟮jq⟯ : ℤ) =
+      w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N) c) :=
+    fun w hw => CNT_ramificationIndex_eq_ord N w c ((hW w).mp hw)
+  have hdegpos : ∀ w ∈ (CNT_base c).fiber (modularFunctionField N), 1 ≤ w.deg := by
+    intro w hw
+    rw [← hf w hw]
+    exact Nat.succ_le_of_lt (Place.inertiaDeg_pos_of_finiteDimensional (F := ℚ⟮jq⟯) w)
+  have hsumW : ∑ w ∈ (CNT_base c).fiber (modularFunctionField N),
+      (w.deg : ℤ) * w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ
+        (modularFunctionField N) c) =
+        dedekindPsi N := by
+    rw [← hsum]
+    refine Finset.sum_congr rfl fun w hw => ?_
+    rw [he w hw, hf w hw, mul_comm]
+  have hdom : ∀ w ∈ (CNT_base c).fiber (modularFunctionField N),
+      ∃ S : Finset (Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)), w.deg ≤ S.card ∧ ∀ v ∈
+        S,
+        ∃ a : ℤ, 0 < a ∧ ∀ (x : modularFunctionField N) (y : modularFunctionFieldBar N),
+          (y : LaurentSeries (AlgebraicClosure ℚ)) = coeffEmb (AlgebraicClosure ℚ) (x :
+            LaurentSeries ℚ) →
+            v.ord y = a * w.ord x := by
+    intro w hw
+    have hj : 0 ≤ w.ord (⟨jq, jq_mem N⟩ : modularFunctionField N) :=
+      CNT_ord_nonneg_of_mem w (CNT_mem_of_ord_sub_pos w ((hW w).mp hw))
+    obtain ⟨S, hcard, hS⟩ := ModularCurve.exists_finset_place_bar_dominating_of_ord_jq_nonneg N w hj
+    exact ⟨S, hcard, fun v hv => (hS v hv).2⟩
+  choose! S hScard hSdom using hdom
+  choose! a hapos ha using hSdom
+  set jc : modularFunctionField N :=
+    (⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N) c with hjc
+  set jBc : modularFunctionFieldBar N :=
+    jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) (c : AlgebraicClosure ℚ)
+      with hjBc
+  set W : Finset (Place ℚ (modularFunctionField N)) := (CNT_base c).fiber (modularFunctionField N)
+    with hWdef
+  have hrel : (jBc : LaurentSeries (AlgebraicClosure ℚ)) = coeffEmb (AlgebraicClosure ℚ) (jc :
+    LaurentSeries ℚ) :=
+    by
+    rw [hjc, hjBc]
+    exact CNT_coe_jBar_sub N c
+  have hjc_pos : ∀ w ∈ W, 0 < w.ord jc := fun w hw => (hW w).mp hw
+  have hordv : ∀ w ∈ W, ∀ v ∈ S w, v.ord jBc = a w v * w.ord jc :=
+    fun w hw v hv => ha w hw v hv jc jBc hrel
+  have hSP : ∀ w ∈ W, S w ⊆ P := fun w hw v hv =>
+    (hP v).mpr (by rw [hordv w hw v hv]; exact mul_pos (hapos w hw v hv) (hjc_pos w hw))
+  have hdisj : (W : Set (Place ℚ (modularFunctionField N))).PairwiseDisjoint S := by
+    intro w hw w' hw' hne
+    change Disjoint (S w) (S w')
+    refine Finset.disjoint_left.mpr fun v hv hv' => hne ?_
+    exact CNT_eq_of_dominated N w w' v (a w v) (a w' v) (hapos w hw v hv) (hapos w' hw' v hv')
+      (ha w hw v hv) (ha w' hw' v hv')
+  have hUP : W.biUnion S ⊆ P := Finset.biUnion_subset.mpr hSP
+  have hAB : ∑ w ∈ W, (w.deg : ℤ) * w.ord jc ≤ ∑ w ∈ W, ∑ v ∈ S w, w.ord jc := by
+    refine Finset.sum_le_sum fun w hw => ?_
+    rw [Finset.sum_const, nsmul_eq_mul]
+    exact mul_le_mul_of_nonneg_right (by exact_mod_cast hScard w hw) (hjc_pos w hw).le
+  have hBC : ∑ w ∈ W, ∑ v ∈ S w, w.ord jc ≤ ∑ w ∈ W, ∑ v ∈ S w, a w v * w.ord jc := by
+    refine Finset.sum_le_sum fun w hw => Finset.sum_le_sum fun v hv => ?_
+    exact le_mul_of_one_le_left (hjc_pos w hw).le (by have := hapos w hw v hv; omega)
+  have hCD : ∑ w ∈ W, ∑ v ∈ S w, a w v * w.ord jc = ∑ v ∈ W.biUnion S, v.ord jBc := by
+    rw [Finset.sum_biUnion hdisj]
+    exact Finset.sum_congr rfl fun w hw => Finset.sum_congr rfl fun v hv => (hordv w hw v hv).symm
+  have hDP : ∑ v ∈ W.biUnion S, v.ord jBc ≤ dedekindPsi N := by
+    rw [← hPEO]
+    exact Finset.sum_le_sum_of_subset_of_nonneg hUP fun v hv _ => ((hP v).mp hv).le
+  have hBCeq : ∑ w ∈ W, ∑ v ∈ S w, w.ord jc = ∑ w ∈ W, ∑ v ∈ S w, a w v * w.ord jc := by
+    linarith
+  have hABeq : ∑ w ∈ W, (w.deg : ℤ) * w.ord jc = ∑ w ∈ W, ∑ v ∈ S w, w.ord jc := by
+    linarith
+  have hDPeq : ∑ v ∈ W.biUnion S, v.ord jBc = dedekindPsi N := by
+    linarith
+  have ha1 : ∀ w ∈ W, ∀ v ∈ S w, a w v = 1 := by
+    by_contra hcon
+    push Not at hcon
+    obtain ⟨w, hw, v, hv, hne⟩ := hcon
+    have hlt : ∑ w ∈ W, ∑ v ∈ S w, w.ord jc < ∑ w ∈ W, ∑ v ∈ S w, a w v * w.ord jc := by
+      refine Finset.sum_lt_sum (fun w' hw' => Finset.sum_le_sum fun v' hv' =>
+        le_mul_of_one_le_left (hjc_pos w' hw').le (by
+          have := hapos w' hw' v' hv'; omega)) ⟨w, hw, ?_⟩
+      refine Finset.sum_lt_sum (fun v' hv' =>
+        le_mul_of_one_le_left (hjc_pos w hw).le (by have := hapos w hw v' hv'; omega)) ⟨v, hv, ?_⟩
+      exact lt_mul_of_one_lt_left (hjc_pos w hw) (by have := hapos w hw v hv; omega)
+    linarith
+  have hcardS : ∀ w ∈ W, (S w).card = w.deg := by
+    by_contra hcon
+    push Not at hcon
+    obtain ⟨w, hw, hne⟩ := hcon
+    have hlt' : w.deg < (S w).card := lt_of_le_of_ne (hScard w hw) (Ne.symm hne)
+    have hlt : ∑ w ∈ W, (w.deg : ℤ) * w.ord jc < ∑ w ∈ W, ∑ v ∈ S w, w.ord jc := by
+      refine Finset.sum_lt_sum (fun w' hw' => ?_) ⟨w, hw, ?_⟩
+      · rw [Finset.sum_const, nsmul_eq_mul]
+        exact mul_le_mul_of_nonneg_right (by exact_mod_cast hScard w' hw') (hjc_pos w' hw').le
+      · rw [Finset.sum_const, nsmul_eq_mul]
+        exact mul_lt_mul_of_pos_right (by exact_mod_cast hlt') (hjc_pos w hw)
+    linarith
+  have hPU : ∀ v ∈ P, v ∈ W.biUnion S := by
+    intro v hv
+    by_contra hvU
+    have hsd := Finset.sum_sdiff (f := fun u => u.ord jBc) hUP
+    have hzero : ∑ u ∈ P \ W.biUnion S, u.ord jBc = 0 := by linarith
+    have hv' : v ∈ P \ W.biUnion S := Finset.mem_sdiff.mpr ⟨hv, hvU⟩
+    have h0 := (Finset.sum_eq_zero_iff_of_nonneg (fun u hu =>
+      ((hP u).mp (Finset.mem_sdiff.mp hu).1).le)).mp hzero v hv'
+    exact absurd h0 ((hP v).mp hv).ne'
+  refine ⟨fun w hw0 => ?_, fun T hT => ?_⟩
+  · have hw : w ∈ W := (hW w).mpr hw0
+    have hne : (S w).Nonempty := by
+      rw [← Finset.card_pos, hcardS w hw]
+      exact hdegpos w hw
+    obtain ⟨v, hv⟩ := hne
+    refine ⟨v, fun x y hxy => ?_⟩
+    rw [ha w hw v hv x y hxy, ha1 w hw v hv, one_mul]
+  · have hTW : T = W.filter (fun w => w.ord jc = 1) := by
+      ext w
+      rw [hT, Finset.mem_filter, hW]
+      constructor
+      · intro h
+        exact ⟨by omega, h⟩
+      · exact fun h => h.2
+    have hmem : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N),
+        v.ord jBc = 1 ↔ v ∈ (W.filter (fun w => w.ord jc = 1)).biUnion S := by
+      intro v
+      rw [Finset.mem_biUnion]
+      constructor
+      · intro h1
+        have hvP : v ∈ P := (hP v).mpr (by omega)
+        obtain ⟨w, hw, hv⟩ := Finset.mem_biUnion.mp (hPU v hvP)
+        refine ⟨w, Finset.mem_filter.mpr ⟨hw, ?_⟩, hv⟩
+        have h2 := hordv w hw v hv
+        rw [ha1 w hw v hv, one_mul] at h2
+        omega
+      · rintro ⟨w, hw, hv⟩
+        rw [Finset.mem_filter] at hw
+        rw [hordv w hw.1 v hv, ha1 w hw.1 v hv, one_mul, hw.2]
+    have hdisj' : ((W.filter (fun w => w.ord jc = 1) : Finset (Place ℚ (modularFunctionField N))) :
+        Set (Place ℚ (modularFunctionField N))).PairwiseDisjoint S :=
+      hdisj.subset (fun w hw => (Finset.mem_filter.mp hw).1)
+    have hcard : Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // v.ord jBc =
+      1} =
+        ((W.filter (fun w => w.ord jc = 1)).biUnion S).card := by
+      rw [Nat.card_congr (Equiv.subtypeEquivRight hmem), Nat.card_eq_fintype_card, Fintype.card_coe]
+    rw [hcard, Finset.card_biUnion hdisj', hTW]
+    push_cast
+    exact Finset.sum_congr rfl fun w hw => by rw [hcardS w (Finset.mem_filter.mp hw).1]
+
+private theorem CNT_face [Algebra.IsIntegral ℚ⟮jq⟯ (modularFunctionField N)] (c : ℚ) :
+    ∑ w ∈ ((CNT_base c).fiber (modularFunctionField N)).filter (fun w => w.ramificationIndex ℚ⟮jq⟯ =
+      1),
+        (w.inertiaDeg ℚ⟮jq⟯ : ℤ) =
+      (Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+        v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+          (c : AlgebraicClosure ℚ)) = 1} : ℤ) := by
+  rw [← (CNT_squeeze N c).2
+    (((CNT_base c).fiber (modularFunctionField N)).filter (fun w => w.ramificationIndex ℚ⟮jq⟯ = 1))
+    ?_]
+  · refine Finset.sum_congr rfl fun w hw => ?_
+    rw [Finset.mem_filter, Place.mem_fiber] at hw
+    have h := w.deg_restrict_mul_inertiaDeg (F := ℚ⟮jq⟯)
+    rw [hw.1, CNT_deg_base, one_mul] at h
+    rw [h]
+  · intro w
+    rw [Finset.mem_filter, Place.mem_fiber, CNT_restrict_eq_base_iff]
+    constructor
+    · rintro ⟨hpos, he1⟩
+      rw [← CNT_ramificationIndex_eq_ord N w c hpos, he1, Nat.cast_one]
+    · intro h1
+      have hpos : 0 < w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) -
+          algebraMap ℚ (modularFunctionField N) c) := by omega
+      refine ⟨hpos, ?_⟩
+      have h2 := CNT_ramificationIndex_eq_ord N w c hpos
+      rw [h1] at h2
+      exact_mod_cast h2
+
+end Squeeze
+
+end CNTUnit
+end
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.exists_place_bar_ord_eq_of_ord_jq_sub_pos (N : ℕ) [NeZero N]
+    [HasPrincipalDivisors ℚ (modularFunctionField N)] (c : ℚ)
+    (w : Place ℚ (modularFunctionField N))
+    (hw : 0 < w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField
+      N) c)) :
+    ∃ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N),
+      ∀ (x : modularFunctionField N) (y : modularFunctionFieldBar N),
+        (y : LaurentSeries (AlgebraicClosure ℚ)) = coeffEmb (AlgebraicClosure ℚ) (x : LaurentSeries
+          ℚ) →
+          v.ord y = w.ord x := by
+  exact (CNTUnit.CNT_squeeze N c).1 w hw
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.sum_deg_ord_jq_sub_eq_one_eq_natCard_ord_jBar_sub_eq_one (N : ℕ)
+    [NeZero N]
+    [HasPrincipalDivisors ℚ (modularFunctionField N)] (c : ℚ)
+    (T : Finset (Place ℚ (modularFunctionField N)))
+    (hT : ∀ w, w ∈ T ↔
+      w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - algebraMap ℚ (modularFunctionField N) c) =
+        1) :
+    ∑ w ∈ T, (w.deg : ℤ) =
+      Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+        v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) (c :
+          AlgebraicClosure ℚ)) = 1} := by
+  exact (CNTUnit.CNT_squeeze N c).2 T hT
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.sum_inertiaDeg_unramified_fiber_jLinePlace1728_eq_natCard_bar (N : ℕ)
+    [NeZero N]
+    [HasPrincipalDivisors ℚ ↥(modularFunctionField N)] :
+    letI := jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮jq⟯ ↥(modularFunctionField N)],
+    ∑ w ∈ (jLinePlace1728.fiber ↥(modularFunctionField N)).filter (fun w => w.ramificationIndex
+      ↥ℚ⟮jq⟯ = 1),
+        (w.inertiaDeg ↥ℚ⟮jq⟯ : ℤ) =
+      (Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // v.ord (jBar N - 1728)
+        = 1} : ℤ) := by
+  intro hint
+  have h := CNTUnit.CNT_face N (1728 : ℚ)
+  rw [← CNTUnit.CNT_jLinePlace1728_eq, Rat.cast_ofNat, map_ofNat] at h
+  exact h
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.sum_inertiaDeg_unramified_fiber_jLinePlaceZero_eq_natCard_bar (N : ℕ)
+    [NeZero N]
+    [HasPrincipalDivisors ℚ ↥(modularFunctionField N)] :
+    letI := jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮jq⟯ ↥(modularFunctionField N)],
+    ∑ w ∈ (jLinePlaceZero.fiber ↥(modularFunctionField N)).filter (fun w => w.ramificationIndex
+      ↥ℚ⟮jq⟯ = 1),
+        (w.inertiaDeg ↥ℚ⟮jq⟯ : ℤ) =
+      (Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // v.ord (jBar N) = 1} :
+        ℤ) := by
+  intro hint
+  have h := CNTUnit.CNT_face N (0 : ℚ)
+  rw [← CNTUnit.CNT_jLinePlaceZero_eq, Rat.cast_zero, map_zero, sub_zero] at h
+  exact h
+
+p2m_open "IntermediateField AlgebraicCurve ModularCurve \
+  P2MW.S_ModularCurve_natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo.ModularCurve"
+open IsDedekindDomain WithZero
+
+section EFIX
+
+private theorem JD_ofNat_eq_algebraMap_bar (N : ℕ) [NeZero N] (k : ℕ) [k.AtLeastTwo] :
+    (OfNat.ofNat k : modularFunctionFieldBar N) =
+      algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+        (OfNat.ofNat k : AlgebraicClosure ℚ) := by
+  simp [map_ofNat]
+
+private theorem JD_zero_eq_algebraMap_bar (N : ℕ) [NeZero N] :
+    (0 : modularFunctionFieldBar N) =
+      algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+        (0 : AlgebraicClosure ℚ) := (map_zero _).symm
+
+private theorem JD_finset_card_eq_natCard {α : Type*} {S : Finset α} {P : α → Prop}
+    (hS : ∀ v, v ∈ S ↔ P v) : S.card = Nat.card {v // P v} := by
+  have heq : {v | P v} = (S : Set α) := Set.ext fun v => (hS v).symm
+  rw [show Nat.card {v // P v} = {v | P v}.ncard from (Nat.card_coe_set_eq _),
+    heq, Set.ncard_coe_finset]
+
+private theorem JD_pos_dvd_two {n : ℤ} (hpos : 0 < n) (hdvd : n ∣ 2) : n = 1 ∨ n = 2 := by
+  have hle : n ≤ 2 := Int.le_of_dvd two_pos hdvd
+  interval_cases n
+  · exact Or.inl rfl
+  · exact Or.inr rfl
+
+private theorem JD_pos_dvd_three {n : ℤ} (hpos : 0 < n) (hdvd : n ∣ 3) : n = 1 ∨ n = 3 := by
+  have hle : n ≤ 3 := Int.le_of_dvd three_pos hdvd
+  interval_cases n
+  · exact Or.inl rfl
+  · exact absurd hdvd (by decide)
+  · exact Or.inr rfl
+
+private theorem JD_efix_core {α : Type*} (S : Finset α) (f : α → ℤ) (k : ℤ) (hk : k ≠ 1)
+    (hmem : ∀ v ∈ S, f v = 1 ∨ f v = k)
+    (ψ : ℤ) (hsum : ∑ v ∈ S, f v = ψ) :
+    let a := (S.filter (fun v => f v = 1)).card
+    let b := (S.filter (fun v => f v = k)).card
+    (a : ℤ) + k * b = ψ ∧ a + b = S.card := by
+  classical
+  intro a b
+  have hdisj : Disjoint (S.filter (fun v => f v = 1)) (S.filter (fun v => f v = k)) := by
+    refine Finset.disjoint_filter.mpr fun v _ h1 hk' => ?_
+    exact hk (h1 ▸ hk').symm
+  have hunion : S.filter (fun v => f v = 1) ∪ S.filter (fun v => f v = k) = S := by
+    ext v
+    simp only [Finset.mem_union, Finset.mem_filter]
+    refine ⟨fun h => h.elim And.left And.left, fun hv => ?_⟩
+    rcases hmem v hv with h1 | h2
+    · exact Or.inl ⟨hv, h1⟩
+    · exact Or.inr ⟨hv, h2⟩
+  refine ⟨?_, ?_⟩
+  · rw [← hsum, ← hunion, Finset.sum_union hdisj]
+    have hs1 : ∑ v ∈ S.filter (fun v => f v = 1), f v
+        = (S.filter (fun v => f v = 1)).card := by
+      rw [Finset.sum_congr rfl fun v hv => (Finset.mem_filter.mp hv).2,
+        Finset.sum_const, nsmul_eq_mul, mul_one]
+    have hs2 : ∑ v ∈ S.filter (fun v => f v = k), f v
+        = k * (S.filter (fun v => f v = k)).card := by
+      rw [Finset.sum_congr rfl fun v hv => (Finset.mem_filter.mp hv).2,
+        Finset.sum_const, nsmul_eq_mul, mul_comm]
+    rw [hs1, hs2]
+  · rw [← Finset.card_union_of_disjoint hdisj, hunion]
+
+end EFIX
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo (N : ℕ) [NeZero N]
+    (h2 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N - 1728) →
+      v.ord (jBar N - 1728) ∣ 2)
+    [DecidableEq (AlgebraicClosure ℚ)]
+    (hcount : Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // 0 < v.ord
+      (jBar N - 1728)} =
+      Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) // ModuliPoint.j x = (1728 : AlgebraicClosure
+        ℚ)}) :
+    Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // v.ord (jBar N - 1728) =
+      1} = nuTwo N := by
+  obtain ⟨S, hS⟩ := exists_finset_ord_jBar_sub_pos N (1728 : AlgebraicClosure ℚ)
+  have h1728 : jBar N - (1728 : modularFunctionFieldBar N) =
+      jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) (1728 : AlgebraicClosure
+        ℚ) := by
+    rw [JD_ofNat_eq_algebraMap_bar]
+  simp only [← h1728] at hS
+  have hmem : ∀ v ∈ S, v.ord (jBar N - 1728) = 1 ∨ v.ord (jBar N - 1728) = 2 := fun v hv =>
+    JD_pos_dvd_two ((hS v).mp hv) (h2 v ((hS v).mp hv))
+  have hsum : ∑ v ∈ S, v.ord (jBar N - 1728) = dedekindPsi N := by
+    have := sum_ord_jBar_sub_eq_dedekindPsi N (1728 : AlgebraicClosure ℚ)
+      (deg_eq_one_modularFunctionFieldBar N) S (by simp only [← h1728]; exact hS)
+    simpa only [← h1728] using this
+  obtain ⟨hab_psi, hab_card⟩ := JD_efix_core S (fun v => v.ord (jBar N - 1728)) 2 (by norm_num)
+    hmem (dedekindPsi N : ℤ) hsum
+  set a := (S.filter (fun v => v.ord (jBar N - 1728) = 1)).card with ha
+  set b := (S.filter (fun v => v.ord (jBar N - 1728) = 2)).card with hb
+  have hScard : S.card =
+      Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+        0 < v.ord (jBar N - 1728)} :=
+    JD_finset_card_eq_natCard hS
+  have hSpts : S.card = Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) //
+      ModuliPoint.j x = (1728 : AlgebraicClosure ℚ)} := hScard.trans hcount
+  have hmass :=
+    two_mul_natCard_moduliPoint_j_eq_1728_eq_dedekindPsi_add_nuTwo N (AlgebraicClosure ℚ)
+  have ha_nu : a = nuTwo N := by
+    have h2S : 2 * S.card = dedekindPsi N + nuTwo N := by rw [hSpts]; exact hmass
+    have h2ab : 2 * (a + b) = dedekindPsi N + nuTwo N := by rw [hab_card]; exact h2S
+    omega
+  have hcarda : a = Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+      v.ord (jBar N - 1728) = 1} := by
+    refine JD_finset_card_eq_natCard fun v => ?_
+    simp only [Finset.mem_filter, hS]
+    exact ⟨fun ⟨_, h1⟩ => h1, fun h1 => ⟨h1 ▸ one_pos, h1⟩⟩
+  rw [← hcarda, ha_nu]
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.natCard_ord_jBar_eq_one_eq_nuThree (N : ℕ) [NeZero N]
+    (h1 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N) → v.ord
+      (jBar N) ∣ 3)
+    [DecidableEq (AlgebraicClosure ℚ)]
+    (hcount : Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // 0 < v.ord
+      (jBar N)} =
+      Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) // ModuliPoint.j x = (0 : AlgebraicClosure
+        ℚ)}) :
+    Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // v.ord (jBar N) = 1} =
+      nuThree N := by
+  obtain ⟨S, hS⟩ := exists_finset_ord_jBar_sub_pos N (0 : AlgebraicClosure ℚ)
+  have h0 : jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)
+      (0 : AlgebraicClosure ℚ) = jBar N := by rw [map_zero, sub_zero]
+  simp only [h0] at hS
+  have hmem : ∀ v ∈ S, v.ord (jBar N) = 1 ∨ v.ord (jBar N) = 3 := fun v hv =>
+    JD_pos_dvd_three ((hS v).mp hv) (h1 v ((hS v).mp hv))
+  have hsum : ∑ v ∈ S, v.ord (jBar N) = dedekindPsi N := by
+    have := sum_ord_jBar_sub_eq_dedekindPsi N (0 : AlgebraicClosure ℚ)
+      (deg_eq_one_modularFunctionFieldBar N) S (by simp only [h0]; exact hS)
+    simpa only [h0] using this
+  obtain ⟨hab_psi, hab_card⟩ := JD_efix_core S (fun v => v.ord (jBar N)) 3 (by norm_num)
+    hmem (dedekindPsi N : ℤ) hsum
+  set a := (S.filter (fun v => v.ord (jBar N) = 1)).card with ha
+  set b := (S.filter (fun v => v.ord (jBar N) = 3)).card with hb
+  have hScard : S.card =
+      Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+        0 < v.ord (jBar N)} := JD_finset_card_eq_natCard hS
+  have hSpts : S.card = Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) //
+      ModuliPoint.j x = (0 : AlgebraicClosure ℚ)} := hScard.trans hcount
+  have hmass := three_mul_natCard_moduliPoint_j_eq_zero_eq_dedekindPsi_add_two_mul_nuThree N
+    (AlgebraicClosure ℚ)
+  have ha_nu : a = nuThree N := by
+    have h3S : 3 * S.card = dedekindPsi N + 2 * nuThree N := by rw [hSpts]; exact hmass
+    have h3ab : 3 * (a + b) = dedekindPsi N + 2 * nuThree N := by rw [hab_card]; exact h3S
+    omega
+  have hcarda : a = Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+      v.ord (jBar N) = 1} := by
+    refine JD_finset_card_eq_natCard fun v => ?_
+    simp only [Finset.mem_filter, hS]
+    exact ⟨fun ⟨_, h1⟩ => h1, fun h1 => ⟨h1 ▸ one_pos, h1⟩⟩
+  rw [← hcarda, ha_nu]
+
+section JDHelpers
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+private theorem JD_ord_nonneg_of_mem (v : Place K F) {f : F} (hf : f ∈ v.toValuationSubring) :
+    0 ≤ v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨n, u, hu⟩ :=
+    IsDiscreteValuationRing.eq_unit_mul_pow_irreducible
+      (x := (⟨f, hf⟩ : v.toValuationSubring)) (by simpa [Subtype.ext_iff] using hf0) hπ
+  have hcoe : f = ((u : v.toValuationSubring) : F) * ((π : F) ^ (n : ℤ)) := by
+    have h := congrArg (Subtype.val) hu
+    push_cast at h
+    rw [zpow_natCast]
+    exact h
+  rw [hcoe, v.ord_unit_smul_zpow u hπ (n : ℤ)]
+  exact Int.natCast_nonneg n
+
+end JDHelpers
+
+section JDOrdHelper
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+private theorem JD_mem_of_ord_pos (w : Place K F) {f : F} (h : 0 < w.ord f) :
+    f ∈ w.toValuationSubring := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact zero_mem _
+  · obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+    obtain ⟨u, hu⟩ := w.exists_unit_mul_zpow hf0 hπ
+    rw [hu, show w.ord f = (((w.ord f).toNat : ℕ) : ℤ) from (Int.toNat_of_nonneg h.le).symm,
+      zpow_natCast]
+    exact mul_mem (u : w.toValuationSubring).2 (pow_mem (π : w.toValuationSubring).2 _)
+
+private theorem JD_ord_nonneg_of_ord_sub_ofNat_pos (w : Place K F) (k : ℕ) [k.AtLeastTwo]
+    {f : F} (h : 0 < w.ord (f - (OfNat.ofNat k : F))) : 0 ≤ w.ord f := by
+  have hmem : f ∈ w.toValuationSubring := by
+    have h1 : (f - OfNat.ofNat k) + OfNat.ofNat k ∈ w.toValuationSubring :=
+      add_mem (JD_mem_of_ord_pos w h)
+        (show (OfNat.ofNat k : F) ∈ w.toValuationSubring from
+          map_ofNat (algebraMap K F) k ▸ w.algebraMap_mem' (OfNat.ofNat k : K))
+    simpa using h1
+  exact JD_ord_nonneg_of_mem w hmem
+
+end JDOrdHelper
+
+section JDAux1
+p2m_open "IntermediateField AlgebraicCurve AlgebraicCurve.RationalFunctionField ModularCurve \
+  P2MW.S_ModularCurve_natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo.ModularCurve"
+attribute [local instance 2000] RatFunc.instAlgebraOfPolynomial
+attribute [local instance] instDecidableEqRatFuncRat
+attribute [local instance] jAdjoinAlgebra
+
+private theorem JD_one_le_deg_jAdjoin (q : Place ℚ ℚ⟮jq⟯) : 1 ≤ q.deg := by
+  have he : ∀ a : ℚ, jLineRingEquiv (algebraMap ℚ (RatFunc ℚ) a) = algebraMap ℚ ℚ⟮jq⟯ a :=
+    RingHom.map_rat_algebraMap jLineRingEquiv.toRingHom
+  have h := RationalFunctionField.deg_ne_zero ((Place.congrEquiv jLineRingEquiv he).symm q)
+  have hq : q = Place.congrEquiv jLineRingEquiv he ((Place.congrEquiv jLineRingEquiv he).symm q) :=
+    ((Place.congrEquiv jLineRingEquiv he).apply_symm_apply q).symm
+  rw [hq, Place.congrEquiv_apply, Place.deg_congrRingEquiv]
+  exact Nat.one_le_iff_ne_zero.mpr h
+
+private theorem JD_deg_restrict_jAdjoin_pos (N : ℕ) [NeZero N] :
+    letI := jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮jq⟯ ↥(modularFunctionField N)]
+      (w : Place ℚ ↥(modularFunctionField N)),
+      1 ≤ (w.restrict ↥ℚ⟮jq⟯).deg := by
+  intro _ w
+  exact JD_one_le_deg_jAdjoin _
+
+end JDAux1
+
+section JDHelpersModular
+
+variable (N : ℕ) [NeZero N]
+
+attribute [local instance] jAdjoinAlgebra
+
+private theorem JD_finiteDimensional_jAdjoin :
+    FiniteDimensional ℚ⟮jq⟯ (modularFunctionField N) :=
+  FiniteDimensional.of_finrank_pos
+    ((finrank_jAdjoin_modularFunctionField_eq_dedekindPsi N).symm ▸
+      dedekindPsi_pos N (NeZero.ne N))
+
+private theorem JD_coeffEmb_sub_1728 :
+    ((jBar N - 1728 : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ)) =
+      coeffEmb (AlgebraicClosure ℚ)
+        (((⟨jq, jq_mem N⟩ : modularFunctionField N) - 1728 :
+            modularFunctionField N) : LaurentSeries ℚ) := by
+  rw [AddSubgroupClass.coe_sub, AddSubgroupClass.coe_sub, map_sub]
+  congr 1
+  rw [show ((1728 : modularFunctionField N) : LaurentSeries ℚ) = (1728 : LaurentSeries ℚ) from
+      map_ofNat (modularFunctionField N).subtype 1728, map_ofNat]
+  exact (map_ofNat (modularFunctionFieldBar N).subtype 1728)
+
+private theorem JD_coeffEmb_j :
+    ((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ)) =
+      coeffEmb (AlgebraicClosure ℚ)
+        ((⟨jq, jq_mem N⟩ : modularFunctionField N) : LaurentSeries ℚ) := rfl
+
+private theorem JD_deg_pos_of_restrict_eq_jLinePlace1728
+    [Algebra.IsIntegral ↥ℚ⟮jq⟯ ↥(modularFunctionField N)]
+    (w : Place ℚ (modularFunctionField N))
+    (hw : w.restrict ↥ℚ⟮jq⟯ = jLinePlace1728) : 1 ≤ w.deg := by
+  have := JD_finiteDimensional_jAdjoin N
+  have hd := w.deg_restrict_mul_inertiaDeg (F := ↥ℚ⟮jq⟯)
+  rw [hw, deg_jLinePlace1728, one_mul] at hd
+  rw [← hd]
+  exact w.inertiaDeg_pos_of_finiteDimensional (F := ↥ℚ⟮jq⟯)
+
+private theorem JD_deg_pos_of_restrict_eq_jLinePlaceZero
+    [Algebra.IsIntegral ↥ℚ⟮jq⟯ ↥(modularFunctionField N)]
+    (w : Place ℚ (modularFunctionField N))
+    (hw : w.restrict ↥ℚ⟮jq⟯ = jLinePlaceZero) : 1 ≤ w.deg := by
+  have := JD_finiteDimensional_jAdjoin N
+  have hd := w.deg_restrict_mul_inertiaDeg (F := ↥ℚ⟮jq⟯)
+  rw [hw, deg_jLinePlaceZero, one_mul] at hd
+  rw [← hd]
+  exact w.inertiaDeg_pos_of_finiteDimensional (F := ↥ℚ⟮jq⟯)
+
+private theorem JD_deg_pos
+    [Algebra.IsIntegral ↥ℚ⟮jq⟯ ↥(modularFunctionField N)]
+    (w : Place ℚ (modularFunctionField N)) : 1 ≤ w.deg := by
+  have := JD_finiteDimensional_jAdjoin N
+  have hd := w.deg_restrict_mul_inertiaDeg (F := ↥ℚ⟮jq⟯)
+  calc 1 ≤ (w.restrict ↥ℚ⟮jq⟯).deg * 1 := by
+        simpa using JD_deg_restrict_jAdjoin_pos N w
+    _ ≤ (w.restrict ↥ℚ⟮jq⟯).deg * w.inertiaDeg ↥ℚ⟮jq⟯ :=
+        Nat.mul_le_mul_left _ (w.inertiaDeg_pos_of_finiteDimensional (F := ↥ℚ⟮jq⟯))
+    _ = w.deg := hd
+
+private theorem JD_ord_algebraMap_eq_zero {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) {a : K} (_ha : a ≠ 0) : v.ord (algebraMap K F a) = 0 := by
+  have h1 : 0 ≤ v.ord (algebraMap K F a) := JD_ord_nonneg_of_mem v (v.algebraMap_mem' a)
+  have h2 : 0 ≤ v.ord (algebraMap K F a)⁻¹ := by
+    rw [← map_inv₀]
+    exact JD_ord_nonneg_of_mem v (v.algebraMap_mem' a⁻¹)
+  rw [v.ord_inv] at h2
+  omega
+
+private theorem JD_coeffEmb_aeval (p : Polynomial ℚ) :
+    ((Polynomial.aeval (jBar N) p : modularFunctionFieldBar N)
+        : LaurentSeries (AlgebraicClosure ℚ)) =
+      coeffEmb (AlgebraicClosure ℚ)
+        ((Polynomial.aeval (⟨jq, jq_mem N⟩ : modularFunctionField N) p
+            : modularFunctionField N) : LaurentSeries ℚ) := by
+  induction p using Polynomial.induction_on with
+  | C a =>
+    simp only [Polynomial.aeval_C]
+    rw [eq_ratCast (algebraMap ℚ (modularFunctionFieldBar N)) a,
+      eq_ratCast (algebraMap ℚ (modularFunctionField N)) a,
+      SubfieldClass.coe_ratCast, SubfieldClass.coe_ratCast, map_ratCast]
+  | add f g ihf ihg =>
+    simp only [map_add, AddMemClass.coe_add, ihf, ihg]
+  | monomial n a _ih =>
+    simp only [map_mul, map_pow, Polynomial.aeval_X, MulMemClass.coe_mul,
+      SubmonoidClass.coe_pow, Polynomial.aeval_C]
+    rw [eq_ratCast (algebraMap ℚ (modularFunctionFieldBar N)) a,
+      eq_ratCast (algebraMap ℚ (modularFunctionField N)) a,
+      SubfieldClass.coe_ratCast, SubfieldClass.coe_ratCast, map_ratCast]
+
+private theorem JD_exists_bar_ord_eq_mul_ram_1728
+    [Algebra.IsIntegral ↥ℚ⟮jq⟯ ↥(modularFunctionField N)]
+    (w : Place ℚ (modularFunctionField N))
+    (hw : w.restrict ↥ℚ⟮jq⟯ = jLinePlace1728) :
+    ∃ (v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) (c : ℤ),
+      0 < c ∧ v.ord (jBar N - 1728) = c * (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) := by
+  have hordpos : 0 < w.ord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - 1728) :=
+    (restrict_eq_jLinePlace1728_iff N w).mp hw
+  have hjnn : 0 ≤ w.ord (⟨jq, jq_mem N⟩ : modularFunctionField N) :=
+    JD_ord_nonneg_of_ord_sub_ofNat_pos w 1728 hordpos
+  obtain ⟨S, hSdeg, hSmem⟩ := exists_finset_place_bar_dominating_of_ord_jq_nonneg N w hjnn
+  have hSne : S.Nonempty :=
+    Finset.card_pos.mp (lt_of_lt_of_le (JD_deg_pos_of_restrict_eq_jLinePlace1728 N w hw) hSdeg)
+  obtain ⟨v, hvS⟩ := hSne
+  obtain ⟨_, c, hcpos, hcord⟩ := hSmem v hvS
+  refine ⟨v, c, hcpos, ?_⟩
+  have key := hcord ((⟨jq, jq_mem N⟩ : modularFunctionField N) - 1728) (jBar N - 1728)
+    (JD_coeffEmb_sub_1728 N)
+  rw [key, ← ramificationIndex_eq_ord_sub_of_restrict_eq_jLinePlace1728 N w hw]
+
+private theorem JD_exists_bar_ord_eq_mul_ram_zero
+    [Algebra.IsIntegral ↥ℚ⟮jq⟯ ↥(modularFunctionField N)]
+    (w : Place ℚ (modularFunctionField N))
+    (hw : w.restrict ↥ℚ⟮jq⟯ = jLinePlaceZero) :
+    ∃ (v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) (c : ℤ),
+      0 < c ∧ v.ord (jBar N) = c * (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) := by
+  have hordpos : 0 < w.ord (⟨jq, jq_mem N⟩ : modularFunctionField N) :=
+    (restrict_eq_jLinePlaceZero_iff N w).mp hw
+  have hjnn : 0 ≤ w.ord (⟨jq, jq_mem N⟩ : modularFunctionField N) := hordpos.le
+  obtain ⟨S, hSdeg, hSmem⟩ := exists_finset_place_bar_dominating_of_ord_jq_nonneg N w hjnn
+  have hSne : S.Nonempty :=
+    Finset.card_pos.mp (lt_of_lt_of_le (JD_deg_pos_of_restrict_eq_jLinePlaceZero N w hw) hSdeg)
+  obtain ⟨v, hvS⟩ := hSne
+  obtain ⟨_, c, hcpos, hcord⟩ := hSmem v hvS
+  refine ⟨v, c, hcpos, ?_⟩
+  rw [hcord _ _ (JD_coeffEmb_j N), ← ramificationIndex_eq_ord_of_restrict_eq_jLinePlaceZero N w hw]
+
+end JDHelpersModular
+
+p2m_open_scoped "ModularCurve" in
+private theorem
+  ModularCurve.ramificationIndex_eq_one_or_eq_two_of_restrict_eq_jLinePlace1728_of_even_of_bounds (N
+  : ℕ) [NeZero N] (hN : Even N)
+    (h2 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N - 1728) →
+      v.ord (jBar N - 1728) ∣ 2) :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ = ModularCurve.jLinePlace1728 →
+      w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 1 ∨ w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 2
+        := by
+  intro _ w hw
+  let := jAdjoinAlgebra N
+  have _ := hN
+  obtain ⟨v, c, hcpos, hvord⟩ := JD_exists_bar_ord_eq_mul_ram_1728 N w hw
+  have hewpos : 0 < (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) := by
+    exact_mod_cast w.ramificationIndex_pos (F := ↥ℚ⟮jq⟯)
+  have hvpos : 0 < v.ord (jBar N - 1728) := by rw [hvord]; exact mul_pos hcpos hewpos
+  have hdvd : c * (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) ∣ 2 := hvord ▸ h2 v hvpos
+  have hewdvd : (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) ∣ 2 := (dvd_mul_left _ c).trans hdvd
+  have hN2 : w.ramificationIndex ↥ℚ⟮jq⟯ ∣ 2 := by exact_mod_cast hewdvd
+  exact (Nat.dvd_prime Nat.prime_two).mp hN2
+
+p2m_open_scoped "ModularCurve" in
+private theorem
+  ModularCurve.ramificationIndex_eq_one_or_eq_three_of_restrict_eq_jLinePlaceZero_of_even_of_bounds
+  (N : ℕ) [NeZero N] (hN : Even N)
+    (h1 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N) → v.ord
+      (jBar N) ∣ 3) :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ = ModularCurve.jLinePlaceZero →
+      w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 1 ∨ w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 3
+        := by
+  intro _ w hw
+  let := jAdjoinAlgebra N
+  have _ := hN
+  obtain ⟨v, c, hcpos, hvord⟩ := JD_exists_bar_ord_eq_mul_ram_zero N w hw
+  have hewpos : 0 < (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) := by
+    exact_mod_cast w.ramificationIndex_pos (F := ↥ℚ⟮jq⟯)
+  have hvpos : 0 < v.ord (jBar N) := by rw [hvord]; exact mul_pos hcpos hewpos
+  have hdvd : c * (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) ∣ 3 := hvord ▸ h1 v hvpos
+  have hewdvd : (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) ∣ 3 := (dvd_mul_left _ c).trans hdvd
+  have hN3 : w.ramificationIndex ↥ℚ⟮jq⟯ ∣ 3 := by exact_mod_cast hewdvd
+  exact (Nat.dvd_prime Nat.prime_three).mp hN3
+
+p2m_open_scoped "ModularCurve" in
+private theorem
+  ModularCurve.ramificationIndex_eq_one_or_eq_two_of_restrict_eq_jLinePlace1728_of_odd_of_bounds (N
+  : ℕ) [NeZero N] (hN : Odd N)
+    (h2 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N - 1728) →
+      v.ord (jBar N - 1728) ∣ 2) :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ = ModularCurve.jLinePlace1728 →
+      w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 1 ∨ w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 2
+        := by
+  intro _ w hw
+  let := jAdjoinAlgebra N
+  have _ := hN
+  obtain ⟨v, c, hcpos, hvord⟩ := JD_exists_bar_ord_eq_mul_ram_1728 N w hw
+  have hewpos : 0 < (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) := by
+    exact_mod_cast w.ramificationIndex_pos (F := ↥ℚ⟮jq⟯)
+  have hvpos : 0 < v.ord (jBar N - 1728) := by rw [hvord]; exact mul_pos hcpos hewpos
+  have hdvd : c * (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) ∣ 2 := hvord ▸ h2 v hvpos
+  have hewdvd : (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) ∣ 2 := (dvd_mul_left _ c).trans hdvd
+  have hN2 : w.ramificationIndex ↥ℚ⟮jq⟯ ∣ 2 := by exact_mod_cast hewdvd
+  exact (Nat.dvd_prime Nat.prime_two).mp hN2
+
+p2m_open_scoped "ModularCurve" in
+private theorem
+  ModularCurve.ramificationIndex_eq_one_or_eq_three_of_restrict_eq_jLinePlaceZero_of_odd_of_bounds
+  (N : ℕ) [NeZero N] (hN : Odd N)
+    (h1 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N) → v.ord
+      (jBar N) ∣ 3) :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ = ModularCurve.jLinePlaceZero →
+      w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 1 ∨ w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 3
+        := by
+  intro _ w hw
+  let := jAdjoinAlgebra N
+  have _ := hN
+  obtain ⟨v, c, hcpos, hvord⟩ := JD_exists_bar_ord_eq_mul_ram_zero N w hw
+  have hewpos : 0 < (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) := by
+    exact_mod_cast w.ramificationIndex_pos (F := ↥ℚ⟮jq⟯)
+  have hvpos : 0 < v.ord (jBar N) := by rw [hvord]; exact mul_pos hcpos hewpos
+  have hdvd : c * (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) ∣ 3 := hvord ▸ h1 v hvpos
+  have hewdvd : (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) ∣ 3 := (dvd_mul_left _ c).trans hdvd
+  have hN3 : w.ramificationIndex ↥ℚ⟮jq⟯ ∣ 3 := by exact_mod_cast hewdvd
+  exact (Nat.dvd_prime Nat.prime_three).mp hN3
+
+p2m_open_scoped "ModularCurve" in
+private theorem
+  ModularCurve.sum_inertiaDeg_unramified_fiber_jLinePlace1728_eq_nuTwo_of_even_of_bounds (N : ℕ)
+  [NeZero N] (hN : Even N)
+    [AlgebraicCurve.HasPrincipalDivisors ℚ ↥(ModularCurve.modularFunctionField N)]
+    (h2 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N - 1728) →
+      v.ord (jBar N - 1728) ∣ 2)
+    [DecidableEq (AlgebraicClosure ℚ)]
+    (hcount : Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // 0 < v.ord
+      (jBar N - 1728)} =
+      Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) // ModuliPoint.j x = (1728 : AlgebraicClosure
+        ℚ)}) :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)],
+    ∑ w ∈ (ModularCurve.jLinePlace1728.fiber ↥(ModularCurve.modularFunctionField N)).filter
+        (fun w => w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 1),
+      (w.inertiaDeg ↥ℚ⟮ModularCurve.jq⟯ : ℤ) = (ModularCurve.nuTwo N : ℤ) := by
+  intro _
+  let := jAdjoinAlgebra N
+  have _ := hN
+  rw [sum_inertiaDeg_unramified_fiber_jLinePlace1728_eq_natCard_bar N,
+    natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo N h2 hcount]
+
+p2m_open_scoped "ModularCurve" in
+private theorem
+  ModularCurve.sum_inertiaDeg_unramified_fiber_jLinePlaceZero_eq_nuThree_of_even_of_bounds (N : ℕ)
+  [NeZero N] (hN : Even N)
+    [AlgebraicCurve.HasPrincipalDivisors ℚ ↥(ModularCurve.modularFunctionField N)]
+    (h1 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N) → v.ord
+      (jBar N) ∣ 3)
+    [DecidableEq (AlgebraicClosure ℚ)]
+    (hcount : Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // 0 < v.ord
+      (jBar N)} =
+      Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) // ModuliPoint.j x = (0 : AlgebraicClosure
+        ℚ)}) :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)],
+    ∑ w ∈ (ModularCurve.jLinePlaceZero.fiber ↥(ModularCurve.modularFunctionField N)).filter
+        (fun w => w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 1),
+      (w.inertiaDeg ↥ℚ⟮ModularCurve.jq⟯ : ℤ) = (ModularCurve.nuThree N : ℤ) := by
+  intro _
+  let := jAdjoinAlgebra N
+  have _ := hN
+  rw [sum_inertiaDeg_unramified_fiber_jLinePlaceZero_eq_natCard_bar N,
+    natCard_ord_jBar_eq_one_eq_nuThree N h1 hcount]
+
+p2m_open_scoped "ModularCurve" in
+private theorem
+  ModularCurve.sum_inertiaDeg_unramified_fiber_jLinePlace1728_eq_nuTwo_of_odd_of_bounds (N : ℕ)
+  [NeZero N] (hN : Odd N)
+    [AlgebraicCurve.HasPrincipalDivisors ℚ ↥(ModularCurve.modularFunctionField N)]
+    (h2 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N - 1728) →
+      v.ord (jBar N - 1728) ∣ 2)
+    [DecidableEq (AlgebraicClosure ℚ)]
+    (hcount : Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // 0 < v.ord
+      (jBar N - 1728)} =
+      Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) // ModuliPoint.j x = (1728 : AlgebraicClosure
+        ℚ)}) :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)],
+    ∑ w ∈ (ModularCurve.jLinePlace1728.fiber ↥(ModularCurve.modularFunctionField N)).filter
+        (fun w => w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 1),
+      (w.inertiaDeg ↥ℚ⟮ModularCurve.jq⟯ : ℤ) = (ModularCurve.nuTwo N : ℤ) := by
+  intro _
+  let := jAdjoinAlgebra N
+  have _ := hN
+  rw [sum_inertiaDeg_unramified_fiber_jLinePlace1728_eq_natCard_bar N,
+    natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo N h2 hcount]
+
+p2m_open_scoped "ModularCurve" in
+private theorem
+  ModularCurve.sum_inertiaDeg_unramified_fiber_jLinePlaceZero_eq_nuThree_of_odd_of_bounds (N : ℕ)
+  [NeZero N] (hN : Odd N)
+    [AlgebraicCurve.HasPrincipalDivisors ℚ ↥(ModularCurve.modularFunctionField N)]
+    (h1 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N) → v.ord
+      (jBar N) ∣ 3)
+    [DecidableEq (AlgebraicClosure ℚ)]
+    (hcount : Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // 0 < v.ord
+      (jBar N)} =
+      Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) // ModuliPoint.j x = (0 : AlgebraicClosure
+        ℚ)}) :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)],
+    ∑ w ∈ (ModularCurve.jLinePlaceZero.fiber ↥(ModularCurve.modularFunctionField N)).filter
+        (fun w => w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 1),
+      (w.inertiaDeg ↥ℚ⟮ModularCurve.jq⟯ : ℤ) = (ModularCurve.nuThree N : ℤ) := by
+  intro _
+  let := jAdjoinAlgebra N
+  have _ := hN
+  rw [sum_inertiaDeg_unramified_fiber_jLinePlaceZero_eq_natCard_bar N,
+    natCard_ord_jBar_eq_one_eq_nuThree N h1 hcount]
+
+section H1
+
+variable (N : ℕ) [NeZero N]
+
+attribute [local instance] jAdjoinAlgebra
+
+private theorem JD_ord_multiset_prod {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) (s : Multiset F) (hs : ∀ x ∈ s, x ≠ 0) :
+    v.ord s.prod = (s.map v.ord).sum := by
+  induction s using Multiset.induction_on with
+  | empty => simp
+  | cons a t ih =>
+    have ha : a ≠ 0 := hs a (Multiset.mem_cons_self a t)
+    have ht : ∀ x ∈ t, x ≠ 0 := fun x hx => hs x (Multiset.mem_cons_of_mem hx)
+    have htprod : t.prod ≠ 0 := fun h => ht 0 (Multiset.prod_eq_zero_iff.mp h) rfl
+    simp only [Multiset.prod_cons, Multiset.map_cons, Multiset.sum_cons]
+    rw [v.ord_mul ha htprod, ih ht]
+
+omit [NeZero N] in
+private theorem JD_algebraMap_rat_barN :
+    (algebraMap ℚ (modularFunctionFieldBar N)) =
+      (algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)).comp
+        (algebraMap ℚ (AlgebraicClosure ℚ)) :=
+  RingHom.ext fun a => by
+    rw [eq_ratCast (algebraMap ℚ (modularFunctionFieldBar N)) a, RingHom.comp_apply,
+      eq_ratCast (algebraMap ℚ (AlgebraicClosure ℚ)) a, map_ratCast]
+
+open Polynomial in
+private theorem JD_L_H1
+    (h3 : ∀ (j₀ : AlgebraicClosure ℚ), j₀ ≠ 0 → j₀ ≠ 1728 →
+      ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N),
+        0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) →
+        v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) = 1)
+    (v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N))
+    (hvj : jBar N ∈ v.toValuationSubring)
+    (p : Polynomial ℚ) (hirr : Irreducible p) (hmon : p.Monic)
+    (hp0 : p.eval 0 ≠ 0) (hp1728 : p.eval 1728 ≠ 0)
+    (hvpos : 0 < v.ord (Polynomial.aeval (jBar N) p)) :
+    v.ord (Polynomial.aeval (jBar N) p) = 1 := by
+  classical
+  set q : Polynomial (AlgebraicClosure ℚ) := p.map (algebraMap ℚ (AlgebraicClosure ℚ)) with hq
+  have hqmon : q.Monic := hmon.map _
+  have hqsplits : q.Splits := IsAlgClosed.splits q
+  have hqsep : q.Separable := (Irreducible.separable (F := ℚ) hirr).map
+  have hnodup : q.roots.Nodup := nodup_roots hqsep
+  have hpmap : p.map (algebraMap ℚ (modularFunctionFieldBar N)) =
+      q.map (algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) := by
+    rw [hq, Polynomial.map_map, ← JD_algebraMap_rat_barN]
+  have hsplits' : (p.map (algebraMap ℚ (modularFunctionFieldBar N))).Splits :=
+    hpmap ▸ hqsplits.map (algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N))
+  have haroots : p.aroots (modularFunctionFieldBar N) =
+      q.roots.map (algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N)) := by
+    rw [aroots_def, hpmap, hqsplits.roots_map]
+  have hprod : aeval (jBar N) p = (q.roots.map (fun α => jBar N -
+      algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) α)).prod := by
+    rw [hsplits'.aeval_eq_prod_aroots_of_monic hmon (jBar N), haroots, Multiset.map_map]
+    rfl
+  rw [hprod] at hvpos ⊢
+  have hne : ∀ x ∈ q.roots.map (fun α => jBar N -
+      algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) α), x ≠ 0 := by
+    intro x hx h0
+    refine absurd hvpos (not_lt.mpr (le_of_eq ?_))
+    rw [Multiset.prod_eq_zero (h0 ▸ hx)]; exact v.ord_zero
+  rw [JD_ord_multiset_prod v _ hne, Multiset.map_map] at hvpos ⊢
+  have hnn : ∀ α ∈ q.roots, 0 ≤ v.ord (jBar N -
+      algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) α) := fun α _ =>
+    JD_ord_nonneg_of_mem v (sub_mem hvj (v.algebraMap_mem' α))
+  obtain ⟨α, hαmem, hαpos⟩ : ∃ α ∈ q.roots, 0 < v.ord (jBar N -
+      algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) α) := by
+    by_contra h
+    push Not at h
+    have hzero : ∀ α ∈ q.roots, v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) _ α) = 0 :=
+      fun α hα => le_antisymm (h α hα) (hnn α hα)
+    refine absurd hvpos (not_lt.mpr (le_of_eq ?_))
+    simp only [Function.comp_apply]
+    exact Multiset.sum_eq_zero fun y hy => by
+      obtain ⟨α, hα, rfl⟩ := Multiset.mem_map.mp hy
+      exact hzero α hα
+  have hnotroot : ∀ a : ℚ, p.eval a ≠ 0 → α ≠ algebraMap ℚ (AlgebraicClosure ℚ) a := by
+    intro a hpa hαa
+    refine hpa ((algebraMap ℚ (AlgebraicClosure ℚ)).injective ?_)
+    rw [map_zero, ← eval₂_at_apply (algebraMap ℚ (AlgebraicClosure ℚ)) a,
+      ← eval_map, ← hq, ← hαa]
+    exact (mem_roots hqmon.ne_zero).mp hαmem
+  have hα0 : α ≠ 0 := by
+    have := hnotroot 0 hp0; rwa [map_zero] at this
+  have hα1728 : α ≠ 1728 := by
+    have := hnotroot 1728 hp1728; rwa [map_ofNat] at this
+  have hα1 : v.ord (jBar N -
+      algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) α) = 1 :=
+    h3 α hα0 hα1728 v hαpos
+  have hother : ∀ β ∈ q.roots, β ≠ α → v.ord (jBar N -
+      algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) β) = 0 := by
+    intro β hβmem hβα
+    by_contra hne0
+    have hβpos : 0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) _ β) :=
+      lt_of_le_of_ne (hnn β hβmem) (Ne.symm hne0)
+    have hαne : jBar N - algebraMap (AlgebraicClosure ℚ) _ α ≠ 0 :=
+      hne _ (Multiset.mem_map_of_mem _ hαmem)
+    have hβne : jBar N - algebraMap (AlgebraicClosure ℚ) _ β ≠ 0 :=
+      hne _ (Multiset.mem_map_of_mem _ hβmem)
+    have hαmemO := sub_mem hvj (v.algebraMap_mem' α)
+    have hβmemO := sub_mem hvj (v.algebraMap_mem' β)
+    have hαM := (v.mem_maximalIdeal_iff_ord_pos hαne hαmemO).mpr hαpos
+    have hβM := (v.mem_maximalIdeal_iff_ord_pos hβne hβmemO).mpr hβpos
+    have hαβne : (α - β : AlgebraicClosure ℚ) ≠ 0 := sub_ne_zero.mpr (Ne.symm hβα)
+    have hord0 := JD_ord_algebraMap_eq_zero v hαβne
+    have hordpos : 0 < v.ord (algebraMap (AlgebraicClosure ℚ)
+        (modularFunctionFieldBar N) (α - β)) := by
+      have hmem := v.algebraMap_mem' (α - β)
+      have hmapne : algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) (α - β) ≠ 0 :=
+        (map_ne_zero_iff _ (algebraMap (AlgebraicClosure ℚ) _).injective).mpr hαβne
+      rw [← v.mem_maximalIdeal_iff_ord_pos hmapne hmem]
+      have heq : (⟨_, hmem⟩ : v.toValuationSubring) =
+          (⟨_, hβmemO⟩ : v.toValuationSubring) - ⟨_, hαmemO⟩ := by
+        refine Subtype.ext ?_
+        change algebraMap (AlgebraicClosure ℚ) _ (α - β) =
+          (jBar N - algebraMap _ _ β) - (jBar N - algebraMap _ _ α)
+        rw [map_sub]; ring
+      rw [heq]; exact sub_mem hβM hαM
+    exact absurd hord0 (ne_of_gt hordpos)
+  have hcons : q.roots = α ::ₘ q.roots.erase α := (Multiset.cons_erase hαmem).symm
+  simp only [Function.comp_apply]
+  rw [show (q.roots.map (fun β => v.ord (jBar N -
+        algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) β))).sum =
+      v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) α) +
+        ((q.roots.erase α).map (fun β => v.ord (jBar N -
+          algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) β))).sum from by
+    conv_lhs => rw [hcons, Multiset.map_cons, Multiset.sum_cons], hα1]
+  have hrest : ((q.roots.erase α).map (fun β => v.ord (jBar N -
+      algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) β))).sum = 0 := by
+    refine Multiset.sum_eq_zero fun y hy => ?_
+    obtain ⟨β, hβ, rfl⟩ := Multiset.mem_map.mp hy
+    exact hother β (Multiset.mem_of_mem_erase hβ) ((hnodup.mem_erase_iff).mp hβ).1
+  omega
+
+end H1
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.ramificationIndex_eq_one_of_restrict_ne_jLinePlaces_of_even_of_bounds
+    (N : ℕ) [NeZero N] (hN : Even N)
+    (h3 : ∀ (j₀ : AlgebraicClosure ℚ), j₀ ≠ 0 → j₀ ≠ 1728 → ∀ v : Place (AlgebraicClosure ℚ)
+      (modularFunctionFieldBar N),
+      0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) →
+      v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) = 1) :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ ≠ ModularCurve.jLinePlace1728 →
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ ≠ ModularCurve.jLinePlaceZero →
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ ≠ ModularCurve.jLinePlaceInfty →
+      w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 1 := by
+  intro _ w h1728 h0 hinfty
+  let := jAdjoinAlgebra N
+  have _ := hN
+  have hjnn : 0 ≤ w.ord (⟨jq, jq_mem N⟩ : modularFunctionField N) :=
+    not_lt.mp (fun hlt => hinfty ((restrict_eq_jLinePlaceInfty_iff N w).mpr hlt))
+  obtain ⟨p, hirr, hmon, hp0, hp1728, hwpos, hew⟩ :=
+    exists_irreducible_ramificationIndex_eq_ord_aeval_of_restrict_ne_jLinePlaces N w
+      h1728 h0 hinfty
+  obtain ⟨S, hSdeg, hSmem⟩ := exists_finset_place_bar_dominating_of_ord_jq_nonneg N w hjnn
+  have hSne : S.Nonempty :=
+    Finset.card_pos.mp (lt_of_lt_of_le (JD_deg_pos N w) hSdeg)
+  obtain ⟨v, hvS⟩ := hSne
+  obtain ⟨⟨j₀, hj₀⟩, c, hcpos, hcord⟩ := hSmem v hvS
+  have hjBmem : jBar N ∈ v.toValuationSubring := by
+    have h1 : jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀
+        + algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀ ∈ v.toValuationSubring :=
+      add_mem (JD_mem_of_ord_pos v hj₀) (v.algebraMap_mem' j₀)
+    simpa using h1
+  have hvordp : v.ord (Polynomial.aeval (jBar N) p) =
+      c * w.ord (Polynomial.aeval (⟨jq, jq_mem N⟩ : modularFunctionField N) p) :=
+    hcord _ _ (JD_coeffEmb_aeval N p)
+  have hL : v.ord (Polynomial.aeval (jBar N) p) = 1 :=
+    JD_L_H1 N h3 v hjBmem p hirr hmon hp0 hp1728
+      (by rw [hvordp]; exact mul_pos hcpos hwpos)
+  have heq : c * (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) = 1 :=
+    calc c * (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ)
+        = c * w.ord (Polynomial.aeval (⟨jq, jq_mem N⟩ : modularFunctionField N) p) := by rw [hew]
+      _ = v.ord (Polynomial.aeval (jBar N) p) := hvordp.symm
+      _ = 1 := hL
+  have hewpos : 0 < (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) := by
+    exact_mod_cast w.ramificationIndex_pos (F := ↥ℚ⟮jq⟯)
+  have hewZ : (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) = 1 := by
+    rcases Int.isUnit_iff.mp (isUnit_of_dvd_one ⟨c, (mul_comm _ c ▸ heq).symm⟩) with h1 | hneg
+    · exact h1
+    · omega
+  exact_mod_cast hewZ
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.ramificationIndex_eq_one_of_restrict_ne_jLinePlaces_of_odd_of_bounds
+    (N : ℕ) [NeZero N] (hN : Odd N)
+    (h3 : ∀ (j₀ : AlgebraicClosure ℚ), j₀ ≠ 0 → j₀ ≠ 1728 → ∀ v : Place (AlgebraicClosure ℚ)
+      (modularFunctionFieldBar N),
+      0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) →
+      v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) = 1) :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ ≠ ModularCurve.jLinePlace1728 →
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ ≠ ModularCurve.jLinePlaceZero →
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ ≠ ModularCurve.jLinePlaceInfty →
+      w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ = 1 := by
+  intro _ w h1728 h0 hinfty
+  let := jAdjoinAlgebra N
+  have _ := hN
+  have hjnn : 0 ≤ w.ord (⟨jq, jq_mem N⟩ : modularFunctionField N) :=
+    not_lt.mp (fun hlt => hinfty ((restrict_eq_jLinePlaceInfty_iff N w).mpr hlt))
+  obtain ⟨p, hirr, hmon, hp0, hp1728, hwpos, hew⟩ :=
+    exists_irreducible_ramificationIndex_eq_ord_aeval_of_restrict_ne_jLinePlaces N w
+      h1728 h0 hinfty
+  obtain ⟨S, hSdeg, hSmem⟩ := exists_finset_place_bar_dominating_of_ord_jq_nonneg N w hjnn
+  have hSne : S.Nonempty :=
+    Finset.card_pos.mp (lt_of_lt_of_le (JD_deg_pos N w) hSdeg)
+  obtain ⟨v, hvS⟩ := hSne
+  obtain ⟨⟨j₀, hj₀⟩, c, hcpos, hcord⟩ := hSmem v hvS
+  have hjBmem : jBar N ∈ v.toValuationSubring := by
+    have h1 : jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀
+        + algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀ ∈ v.toValuationSubring :=
+      add_mem (JD_mem_of_ord_pos v hj₀) (v.algebraMap_mem' j₀)
+    simpa using h1
+  have hvordp : v.ord (Polynomial.aeval (jBar N) p) =
+      c * w.ord (Polynomial.aeval (⟨jq, jq_mem N⟩ : modularFunctionField N) p) :=
+    hcord _ _ (JD_coeffEmb_aeval N p)
+  have hL : v.ord (Polynomial.aeval (jBar N) p) = 1 :=
+    JD_L_H1 N h3 v hjBmem p hirr hmon hp0 hp1728
+      (by rw [hvordp]; exact mul_pos hcpos hwpos)
+  have heq : c * (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) = 1 :=
+    calc c * (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ)
+        = c * w.ord (Polynomial.aeval (⟨jq, jq_mem N⟩ : modularFunctionField N) p) := by rw [hew]
+      _ = v.ord (Polynomial.aeval (jBar N) p) := hvordp.symm
+      _ = 1 := hL
+  have hewpos : 0 < (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) := by
+    exact_mod_cast w.ramificationIndex_pos (F := ↥ℚ⟮jq⟯)
+  have hewZ : (w.ramificationIndex ↥ℚ⟮jq⟯ : ℤ) = 1 := by
+    rcases Int.isUnit_iff.mp (isUnit_of_dvd_one ⟨c, (mul_comm _ c ▸ heq).symm⟩) with h1 | hneg
+    · exact h1
+    · omega
+  exact_mod_cast hewZ
+
+open IntermediateField AlgebraicCurve AlgebraicCurve.RationalFunctionField _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo.ModularCurve IsDedekindDomain
+  WithZero IsLocalRing in
+theorem solution (N : ℕ) [NeZero N]
+    (h2 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N - 1728) →
+      v.ord (jBar N - 1728) ∣ 2)
+    [DecidableEq (AlgebraicClosure ℚ)]
+    (hcount : Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // 0 < v.ord
+      (jBar N - 1728)} =
+      Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) // ModuliPoint.j x = (1728 : AlgebraicClosure
+        ℚ)}) :
+    Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // v.ord (jBar N - 1728) =
+      1} = nuTwo N :=
+  ModularCurve.natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo N h2 hcount
+
+end S_ModularCurve_natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo
+end P2MW
+export P2MW.S_ModularCurve_natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open IntermediateField AlgebraicCurve AlgebraicCurve.RationalFunctionField ModularCurve
+  IsDedekindDomain WithZero IsLocalRing
+theorem ModularCurve.natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo (N : ℕ) [NeZero N]
+    (h2 : ∀ v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), 0 < v.ord (jBar N - 1728) →
+      v.ord (jBar N - 1728) ∣ 2)
+    [DecidableEq (AlgebraicClosure ℚ)]
+    (hcount : Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // 0 < v.ord
+      (jBar N - 1728)} =
+      Nat.card {x : ModuliPoint N (AlgebraicClosure ℚ) // ModuliPoint.j x = (1728 : AlgebraicClosure
+        ℚ)}) :
+    Nat.card {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) // v.ord (jBar N - 1728) =
+      1} = nuTwo N :=
+  solution N h2 hcount
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_place_ord_neg_laurentBaseChange_gamma1_eq_natCard_doubleCoset.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_place_ord_neg_laurentBaseChange_gamma1_eq_natCard_doubleCoset.lean
new file mode 100644
index 0000000000..afae9d71e3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_place_ord_neg_laurentBaseChange_gamma1_eq_natCard_doubleCoset.lean
@@ -0,0 +1,813 @@
+/-
+Based on Prove2Me node
+ModularCurve.natCard_place_ord_neg_laurentBaseChange_gamma1_eq_natCard_doubleCoset
+(bfb5c657-61f1-572d-9030-5dce9a7005f8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1eccfff4-914e-51f0-8fec-6cd7a9837145
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.GroupTheory.DoubleCoset
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Algebra.Lie.OfAssociative
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0ModL
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_comap_algebraMap_eq_of_constantFieldExtension
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finrank_le_and_natCard_places_le_of_constantFieldExtension_adjoin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_transcendental_of_perfectField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_natCard_place_ord_sub_pos_le_natCard_doubleCoset
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_monoidHom_algEquiv_fixedField_eq_adjoin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_place_ord_neg_forall_smul_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_place_algebraicClosure_ord_comp_eq_of_laurentBaseChange
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_mem_intFormRatiosC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_doubleCoset_le_card_fibres_of_finrank_eq_index
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelN_structure_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Poles of j on X₁(M) counted by cusps
+
+Theorem statement:
+`ModularCurve.natCard_place_ord_neg_laurentBaseChange_gamma1_eq_natCard_doubleCoset`
+(`bfb5c657-61f1-572d-9030-5dce9a7005f8`), by Claude, 2026-09-05.
+
+Proof: submission `1eccfff4-914e-51f0-8fec-6cd7a9837145`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field equipped with a $\mathbb{Q}$-algebra structure (so of
+characteristic $0$), and let $M$ be a nonzero natural number. Write $F$ for
+[`ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1
+M))`](def/ModularCurve_LaurentCoeff.html#L103), that is: inside $\mathbb{Q}((q))$ one forms the
+subfield `qExpFunctionFieldC ℚ (Gamma1 M)` generated over $\mathbb{Q}$ by all quotients
+$\mathrm{intSeriesC}\,\mathbb{Q}\,p_f/\mathrm{intSeriesC}\,\mathbb{Q}\,p_g$ attached to pairs of
+modular forms $f,g$ of some weight $k$ for $\Gamma_1(M)$ having integral $q$-expansions
+$p_f,p_g\in\mathbb{Z}[[q]]$ with the series of $p_g$ nonzero, and $F\subseteq K((q))$ is the
+subfield generated over $K$ by the image of that field under the coefficientwise map induced by
+$\mathbb{Q}\to K$. Let $y\in F$ be an element whose underlying Laurent series is
+[`ModularCurve.jqModC K`](def/ModularCurve_JqCoeff.html#L15), namely $q^{-1}$ times the image in
+$K[[q]]$ of the integral power series `jNum` $=E_4^3\cdot$ `dedekindEtaUnitInv`; thus $y$ is the
+modular invariant $j$, pinned by its $q$-expansion. The assertion is an equality of cardinalities:
+the number of places $P$ of $F$ over $K$ — valuation subrings of $F$ containing $K$, distinct from
+$F$, whose valuation ring is a principal ideal ring — with $P.\mathrm{ord}\,y<0$, the order being
+$-\log$ of the associated adic valuation, equals the number of double cosets $\Gamma_1(M)\backslash
+\mathrm{SL}_2(\mathbb{Z})/\langle T,-1\rangle$, where $\langle T,-1\rangle$ is the join of the
+cyclic subgroups generated by $T$ and by $-1$.
+
+This is the statement that the poles of $j$ on the curve $X_1(M)$, taken over an algebraically
+closed base field of characteristic $0$, are in bijection with the cusps of $\pm\Gamma_1(M)$, the
+latter being described group-theoretically as double cosets of $\Gamma_1(M)$ against the stabiliser
+$\langle T,-1\rangle$ of the cusp $\infty$. It feeds the computation of the local contribution
+$-\operatorname{ord}_P j$ at a cusp in terms of its width, and the genus formula for $X_1(M)$
+expressed as $12g+6\,\#\mathrm{cusps}=[\,\Gamma_1(M)\!\cdot\!\{\pm1\}:\text{index}\,]+12$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_natCard_place_ord_neg_laurentBaseChange_gamma1_eq_natCard_doubleCoset.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+namespace P2MW.S_ModularCurve_natCard_place_ord_neg_laurentBaseChange_gamma1_eq_natCard_doubleCoset
+
+
+open UpperHalfPlane
+open scoped MatrixGroups IntermediateField Manifold
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpFunctionFieldC intFormRatiosC_subset jGen coeffMap coeffMap_single \
+  coeffMap_coeffMap coeffMap_congr coeffEmb laurentBaseChange coeffEmb_mem_laurentBaseChange \
+  mem_laurentBaseChange_iff coeffMap_mem_laurentBaseChange jqModC LevelN.wp LevelN.fricke \
+  LevelN.jAnalytic LevelN.ring LevelN.jGen coeffMap_jqModC \
+  LevelN.exists_monoidHom_algEquiv_fixedField_eq_adjoin LevelN.exists_place_ord_neg_forall_smul_eq \
+  exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN \
+  natCard_doubleCoset_le_card_fibres_of_finrank_eq_index \
+  finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index \
+  transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqMod\
+  C jqModC_mem_intFormRatiosC exists_place_algebraicClosure_ord_comp_eq_of_laurentBaseChange"
+namespace CuspFibreGamma1
+p2m_open "ModularCurve"
+
+abbrev Gpm (N : ℕ) : Subgroup SL(2, ℤ) :=
+  CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))
+
+theorem Gamma_le_Gamma1 (M : ℕ) : CongruenceSubgroup.Gamma M ≤ CongruenceSubgroup.Gamma1 M := by
+  intro g hg
+  rw [CongruenceSubgroup.Gamma_mem] at hg
+  rw [CongruenceSubgroup.Gamma1_mem]
+  exact ⟨hg.1, hg.2.2.2, hg.2.2.1⟩
+
+theorem T_mem_Gamma1 (M : ℕ) : ModularGroup.T ∈ CongruenceSubgroup.Gamma1 M := by
+  rw [CongruenceSubgroup.Gamma1_mem]
+  refine ⟨?_, ?_, ?_⟩ <;> simp [ModularGroup.coe_T]
+
+theorem neg_one_mem_center : (-1 : SL(2, ℤ)) ∈ Subgroup.center SL(2, ℤ) := by
+  rw [Subgroup.mem_center_iff]
+  intro g
+  rw [mul_neg_one, neg_one_mul]
+
+section Galois
+
+variable {L : Type*} [Field L] [Algebra ℂ L]
+
+theorem adjoin_inv_eq (t : L) : ℂ⟮t⁻¹⟯ = ℂ⟮t⟯ := by
+  apply le_antisymm
+  · rw [IntermediateField.adjoin_le_iff, Set.singleton_subset_iff]
+    exact IntermediateField.inv_mem _ (IntermediateField.mem_adjoin_simple_self ℂ t)
+  · rw [IntermediateField.adjoin_le_iff, Set.singleton_subset_iff]
+    have := IntermediateField.inv_mem _ (IntermediateField.mem_adjoin_simple_self ℂ t⁻¹)
+    rwa [inv_inv] at this
+
+theorem natCard_place_le_natCard_doubleCoset (t : L) (L₀ : IntermediateField ℂ L) (hL₀ : L₀ = ℂ⟮t⟯)
+    [FiniteDimensional L₀ L] [IsGalois L₀ L]
+    {Γ₀ : Type*} [Group Γ₀] (σ : Γ₀ →* (L ≃ₐ[L₀] L)) (hσ : Function.Surjective σ)
+    (Γ Kst : Subgroup Γ₀) [Γ.FiniteIndex]
+    (E : IntermediateField L₀ L) (hE : ∀ γ ∈ Γ, ∀ e : E, σ γ (e : L) = e)
+    (c : ℂ) (W : AlgebraicCurve.Place ℂ L) (hW : 0 < W.ord (t - algebraMap ℂ L c))
+    (hD : ∀ k ∈ Kst, AlgebraicCurve.SemilinearAut.ofAlgAut ((σ k).restrictScalars ℂ) • W = W)
+    (x : E) (hx : (x : L) = t) :
+    Nat.card {P : AlgebraicCurve.Place ℂ E // 0 < P.ord (x - algebraMap ℂ E c)} ≤
+      Nat.card (DoubleCoset.Quotient (Γ : Set Γ₀) (Kst : Set Γ₀)) := by
+  subst hL₀
+  exact AlgebraicCurve.natCard_place_ord_sub_pos_le_natCard_doubleCoset ℂ t inferInstance
+    inferInstance
+    σ hσ Γ Kst E hE c W hW hD x hx
+
+theorem algebraMap_mem_adjoin (t : L) (E : IntermediateField ℂ⟮t⟯ L) (x : E) (hx : (x : L) = t)
+    (l : ℂ⟮t⟯) : algebraMap ℂ⟮t⟯ E l ∈ IntermediateField.adjoin ℂ ({x} : Set E) := by
+  let f : E →ₐ[ℂ] L := (IntermediateField.val E).restrictScalars ℂ
+  have hfx : f x = t := hx
+  have hmap : (IntermediateField.adjoin ℂ ({x} : Set E)).map f = ℂ⟮t⟯ := by
+    rw [IntermediateField.adjoin_map, Set.image_singleton, hfx]
+  have hl : (l : L) ∈ (IntermediateField.adjoin ℂ ({x} : Set E)).map f := by
+    rw [hmap]; exact l.2
+  obtain ⟨a, ha, hal⟩ := (IntermediateField.mem_map _).mp hl
+  have : a = algebraMap ℂ⟮t⟯ E l := Subtype.ext hal
+  rw [← this]; exact ha
+
+theorem finiteDimensional_adjoin (t : L) (E : IntermediateField ℂ⟮t⟯ L) [FiniteDimensional ℂ⟮t⟯ E]
+    (x : E) (hx : (x : L) = t) :
+    FiniteDimensional (IntermediateField.adjoin ℂ ({x} : Set E)) E := by
+  let A : IntermediateField ℂ E := IntermediateField.adjoin ℂ ({x} : Set E)
+  let : Algebra ℂ⟮t⟯ A :=
+    ((algebraMap ℂ⟮t⟯ E).codRestrict A (algebraMap_mem_adjoin t E x hx)).toAlgebra
+  have : IsScalarTower ℂ⟮t⟯ A E := IsScalarTower.of_algebraMap_eq (fun l => rfl)
+  exact Module.Finite.of_restrictScalars_finite ℂ⟮t⟯ A E
+
+end Galois
+
+section Lift
+
+variable {L : Type*} [Field L] [Algebra ℂ L]
+
+def liftE (E' : IntermediateField ℂ L) (φ : L ≃ₐ[ℂ] L) (hφ : ∀ x ∈ E', φ x = x) : L ≃ₐ[E'] L :=
+  { φ.toRingEquiv with commutes' := fun e => hφ e e.2 }
+
+@[scoped simp]
+theorem liftE_apply (E' : IntermediateField ℂ L) (φ : L ≃ₐ[ℂ] L) (hφ : ∀ x ∈ E', φ x = x) (x : L) :
+    liftE E' φ hφ x = φ x := rfl
+
+theorem restrictScalars_liftE (E' : IntermediateField ℂ L) (φ : L ≃ₐ[ℂ] L) (hφ : ∀ x ∈ E', φ x = x)
+    :
+    (liftE E' φ hφ).restrictScalars ℂ = φ :=
+  AlgEquiv.ext fun _ => rfl
+
+def liftHom {Γ : Type*} [Group Γ] (E' : IntermediateField ℂ L) (σ : Γ →* (L ≃ₐ[ℂ] L))
+    (hσ : ∀ (γ : Γ), ∀ x ∈ E', σ γ x = x) : Γ →* (L ≃ₐ[E'] L) where
+  toFun γ := liftE E' (σ γ) (hσ γ)
+  map_one' := by ext x; simp
+  map_mul' γ δ := by ext x; simp
+
+@[scoped simp]
+theorem liftHom_apply {Γ : Type*} [Group Γ] (E' : IntermediateField ℂ L)
+    (σ : Γ →* (L ≃ₐ[ℂ] L)) (hσ : ∀ (γ : Γ), ∀ x ∈ E', σ γ x = x) (γ : Γ) (x : L) :
+    liftHom E' σ hσ γ x = σ γ x := rfl
+
+theorem restrictScalars_liftHom {Γ : Type*} [Group Γ] (E' : IntermediateField ℂ L)
+    (σ : Γ →* (L ≃ₐ[ℂ] L)) (hσ : ∀ (γ : Γ), ∀ x ∈ E', σ γ x = x) (γ : Γ) :
+    (liftHom E' σ hσ γ).restrictScalars ℂ = σ γ :=
+  restrictScalars_liftE E' (σ γ) (hσ γ)
+
+theorem liftHom_eq_one_iff {Γ : Type*} [Group Γ] (E' : IntermediateField ℂ L)
+    (σ : Γ →* (L ≃ₐ[ℂ] L)) (hσ : ∀ (γ : Γ), ∀ x ∈ E', σ γ x = x) (γ : Γ) :
+    liftHom E' σ hσ γ = 1 ↔ γ ∈ σ.ker := by
+  rw [MonoidHom.mem_ker]
+  constructor
+  · intro h
+    have := congrArg (AlgEquiv.restrictScalars ℂ) h
+    rw [restrictScalars_liftHom] at this
+    rw [this]
+    ext x
+    rfl
+  · intro h
+    ext x
+    change σ γ x = x
+    rw [h]
+    rfl
+
+theorem liftHom_ker {Γ : Type*} [Group Γ] (E' : IntermediateField ℂ L)
+    (σ : Γ →* (L ≃ₐ[ℂ] L)) (hσ : ∀ (γ : Γ), ∀ x ∈ E', σ γ x = x) :
+    (liftHom E' σ hσ).ker = σ.ker := by
+  ext γ
+  rw [MonoidHom.mem_ker, liftHom_eq_one_iff]
+
+end Lift
+
+section LevelN
+
+variable (M : ℕ) [NeZero M]
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (LevelN.ring M) K]
+  [IsScalarTower ℂ (LevelN.ring M) K] [IsFractionRing (LevelN.ring M) K]
+
+theorem galoisPackage :
+    ∃ (hst : ∀ γ : SL(2, ℤ), ∀ F ∈ ModularCurve.LevelN.ring M,
+        (fun τ : UpperHalfPlane => F (γ • τ)) ∈ ModularCurve.LevelN.ring M)
+      (σ : SL(2, ℤ) →* (K ≃ₐ[ℂ] K)),
+      (∀ (γ : SL(2, ℤ)) (F : UpperHalfPlane → ℂ) (hF : F ∈ ModularCurve.LevelN.ring M),
+          σ γ (algebraMap (ModularCurve.LevelN.ring M) K ⟨F, hF⟩) =
+            algebraMap (ModularCurve.LevelN.ring M) K
+              ⟨fun τ : UpperHalfPlane => F (γ⁻¹ • τ), hst γ⁻¹ F hF⟩) ∧
+      σ.ker = CongruenceSubgroup.Gamma M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) ∧
+      IntermediateField.fixedField σ.range =
+        IntermediateField.adjoin ℂ
+          ({algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)} : Set K) ∧
+      Transcendental ℂ (algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)) ∧
+      FiniteDimensional
+          (IntermediateField.adjoin ℂ
+            ({algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)} : Set K)) K ∧
+      Module.finrank
+          (IntermediateField.adjoin ℂ
+            ({algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)} : Set K)) K =
+        (CongruenceSubgroup.Gamma M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index ∧
+      IsGalois
+          (IntermediateField.adjoin ℂ
+            ({algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)} : Set K)) K :=
+  ModularCurve.LevelN.exists_monoidHom_algEquiv_fixedField_eq_adjoin M K
+
+include K in
+theorem comp_smul_mem (γ : SL(2, ℤ)) (F : ℍ → ℂ) (hF : F ∈ LevelN.ring M) :
+    (fun τ : ℍ => F (γ • τ)) ∈ LevelN.ring M :=
+  (galoisPackage M K).choose γ F hF
+
+def σK : SL(2, ℤ) →* (K ≃ₐ[ℂ] K) := (galoisPackage M K).choose_spec.choose
+
+abbrev jK : K := algebraMap (LevelN.ring M) K (LevelN.jGen M)
+
+theorem σK_algebraMap (γ : SL(2, ℤ)) (F : ℍ → ℂ) (hF : F ∈ LevelN.ring M) :
+    σK M K γ (algebraMap (LevelN.ring M) K ⟨F, hF⟩) =
+      algebraMap (LevelN.ring M) K ⟨fun τ : ℍ => F (γ⁻¹ • τ), comp_smul_mem M K γ⁻¹ F hF⟩ :=
+  (galoisPackage M K).choose_spec.choose_spec.1 γ F hF
+
+theorem σK_ker : (σK M K).ker = Gpm M := (galoisPackage M K).choose_spec.choose_spec.2.1
+
+theorem fixedField_σK : IntermediateField.fixedField (σK M K).range = ℂ⟮jK M K⟯ :=
+  (galoisPackage M K).choose_spec.choose_spec.2.2.1
+
+theorem transcendental_jK : Transcendental ℂ (jK M K) :=
+  (galoisPackage M K).choose_spec.choose_spec.2.2.2.1
+
+theorem finiteDimensional_jK : FiniteDimensional ℂ⟮jK M K⟯ K :=
+  (galoisPackage M K).choose_spec.choose_spec.2.2.2.2.1
+
+theorem finrank_jK : Module.finrank ℂ⟮jK M K⟯ K = (Gpm M).index :=
+  (galoisPackage M K).choose_spec.choose_spec.2.2.2.2.2.1
+
+theorem isGalois_jK : IsGalois ℂ⟮jK M K⟯ K :=
+  (galoisPackage M K).choose_spec.choose_spec.2.2.2.2.2.2
+
+theorem σK_fix (γ : SL(2, ℤ)) : ∀ x ∈ ℂ⟮jK M K⟯, σK M K γ x = x := fun x hx => by
+  rw [← fixedField_σK] at hx
+  exact (IntermediateField.mem_fixedField_iff (σK M K).range x).mp hx (σK M K γ) ⟨γ, rfl⟩
+
+def σ' : SL(2, ℤ) →* (K ≃ₐ[ℂ⟮jK M K⟯] K) := liftHom ℂ⟮jK M K⟯ (σK M K) (σK_fix M K)
+
+theorem restrictScalars_σ' (γ : SL(2, ℤ)) : (σ' M K γ).restrictScalars ℂ = σK M K γ :=
+  restrictScalars_liftHom _ _ _ γ
+
+@[scoped simp]
+theorem σ'_apply (γ : SL(2, ℤ)) (x : K) : σ' M K γ x = σK M K γ x := rfl
+
+theorem σ'_ker : (σ' M K).ker = Gpm M := by
+  rw [σ', liftHom_ker, σK_ker]
+
+theorem σ'_eq_one_iff (γ : SL(2, ℤ)) : σ' M K γ = 1 ↔ γ ∈ Gpm M := by
+  rw [← MonoidHom.mem_ker, σ'_ker]
+
+theorem σ'_surjective : Function.Surjective (σ' M K) := by
+  have := finiteDimensional_jK M K
+  have := isGalois_jK M K
+  rw [← MonoidHom.range_eq_top]
+  apply Subgroup.eq_top_of_card_eq
+  rw [← Subgroup.index_ker, σ'_ker, ← finrank_jK M K, IsGalois.card_aut_eq_finrank]
+
+theorem exists_place_infty :
+    ∃ W : AlgebraicCurve.Place ℂ K, 0 < W.ord ((jK M K)⁻¹ - algebraMap ℂ K 0) ∧
+      ∀ k ∈ Subgroup.zpowers (ModularGroup.T : SL(2, ℤ)) ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)),
+        AlgebraicCurve.SemilinearAut.ofAlgAut ((σ' M K k).restrictScalars ℂ) • W = W := by
+  obtain ⟨W, hW, hWfix⟩ :=
+    ModularCurve.LevelN.exists_place_ord_neg_forall_smul_eq M K (comp_smul_mem M K ModularGroup.T⁻¹)
+  change W.ord (jK M K) < 0 at hW
+  have hW' : 0 < W.ord ((jK M K)⁻¹ - algebraMap ℂ K 0) := by
+    rw [map_zero, sub_zero, AlgebraicCurve.Place.ord_inv]; omega
+  refine ⟨W, hW', ?_⟩
+  let S : Subgroup SL(2, ℤ) :=
+    (MulAction.stabilizer (AlgebraicCurve.SemilinearAut ℂ K) W).comap
+      (AlgebraicCurve.SemilinearAut.ofAlgAut.comp (σK M K))
+  have hS : ∀ k, k ∈ S ↔ AlgebraicCurve.SemilinearAut.ofAlgAut (σK M K k) • W = W := fun k => by
+    rw [Subgroup.mem_comap, MulAction.mem_stabilizer_iff]; rfl
+  have hT : ModularGroup.T ∈ S := (hS _).mpr (hWfix (σK M K _) (σK_algebraMap M K _))
+  have hneg : (-1 : SL(2, ℤ)) ∈ S := by
+    rw [hS]
+    have : σK M K (-1) = 1 := by
+      rw [← MonoidHom.mem_ker, σK_ker]
+      exact Subgroup.mem_sup_right (Subgroup.mem_zpowers _)
+    rw [this, map_one, one_smul]
+  have hle : Subgroup.zpowers (ModularGroup.T : SL(2, ℤ)) ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) ≤ S :=
+    sup_le ((Subgroup.zpowers_le).mpr hT) ((Subgroup.zpowers_le).mpr hneg)
+  intro k hk
+  rw [restrictScalars_σ']
+  exact (hS k).mp (hle hk)
+
+end LevelN
+
+section ConstantField
+
+variable {F : Type*} [Field F]
+variable {L : Type*} [Field L] [Algebra ℂ L] (t : L) (E : IntermediateField ℂ⟮t⟯ L) [Algebra F E]
+
+theorem adjoin_adjoin_subset {L : Type*} [Field L] [Algebra ℂ L] (S : Set L) (t : L)
+    (ht : t ∈ IntermediateField.adjoin ℂ S) :
+    ((IntermediateField.adjoin ℂ⟮t⟯ S : IntermediateField ℂ⟮t⟯ L) : Set L) ⊆
+      ((IntermediateField.adjoin ℂ S : IntermediateField ℂ L) : Set L) := by
+  have h1 : ((IntermediateField.adjoin ℂ⟮t⟯ S : IntermediateField ℂ⟮t⟯ L) : Set L) =
+      (IntermediateField.restrictScalars ℂ (IntermediateField.adjoin ℂ⟮t⟯ S) : Set L) := rfl
+  rw [h1, IntermediateField.restrictScalars_adjoin]
+  have hle : IntermediateField.adjoin ℂ ((ℂ⟮t⟯ : Set L) ∪ S) ≤ IntermediateField.adjoin ℂ S := by
+    rw [IntermediateField.adjoin_le_iff]
+    apply Set.union_subset
+    · have : ℂ⟮t⟯ ≤ IntermediateField.adjoin ℂ S := IntermediateField.adjoin_simple_le_iff.mpr ht
+      exact SetLike.coe_subset_coe.mpr this
+    · exact IntermediateField.subset_adjoin _ _
+  exact SetLike.coe_subset_coe.mpr hle
+
+theorem adjoin_range_eq_top
+    (hEle : (E : Set L) ⊆
+      ((IntermediateField.adjoin ℂ (Set.range fun u : F => (algebraMap F E u : L)) :
+        IntermediateField ℂ L) : Set L)) :
+    IntermediateField.adjoin ℂ (Set.range (algebraMap F E)) = ⊤ := by
+  let f : E →ₐ[ℂ] L := E.val.restrictScalars ℂ
+  set A := IntermediateField.adjoin ℂ (Set.range (algebraMap F E)) with hA
+  have hmapA : A.map f = IntermediateField.adjoin ℂ (Set.range fun u : F => (algebraMap F E u : L))
+    :=
+    by
+    rw [hA, IntermediateField.adjoin_map, ← Set.range_comp]
+    rfl
+  rw [eq_top_iff]
+  intro e _
+  have he : (e : L) ∈ A.map f := by
+    rw [hmapA]; exact hEle e.2
+  obtain ⟨a, ha, hae⟩ := (IntermediateField.mem_map A).mp he
+  have : a = e := Subtype.ext hae
+  rw [← this]; exact ha
+
+end ConstantField
+
+section Main
+
+variable (M : ℕ) [NeZero M]
+
+theorem isDomain_ring : IsDomain (LevelN.ring M) := by
+  have h := WLight.levelN_structure_package M PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (LevelN.wp M)
+    (fun v τ => rfl) (LevelN.fricke M) (fun v τ => rfl) LevelN.jAnalytic (fun τ => rfl)
+  have hzd := h.2.2.2.2.2
+  have hnz : NoZeroDivisors (LevelN.ring M) := ⟨fun {a b} hab => by
+    rcases hzd a b a.2 b.2 (by simpa using congrArg Subtype.val hab) with h | h
+    · exact Or.inl (Subtype.ext h)
+    · exact Or.inr (Subtype.ext h)⟩
+  have hnt : Nontrivial (LevelN.ring M) := ⟨⟨0, 1, fun h => by
+    have := congrFun (congrArg Subtype.val h) UpperHalfPlane.I
+    simp at this⟩⟩
+  exact NoZeroDivisors.to_isDomain _
+
+variable (K : Type*) [Field K] [Algebra ℂ K] [Algebra (LevelN.ring M) K]
+  [IsScalarTower ℂ (LevelN.ring M) K] [IsFractionRing (LevelN.ring M) K]
+
+local notation "ℚ̄" => AlgebraicClosure ℚ
+local notation "FF" => laurentBaseChange (AlgebraicClosure ℚ) (qExpFunctionFieldC ℚ
+  (CongruenceSubgroup.Gamma1 M))
+
+include K in
+theorem natCard_place_ord_lt_zero_le (ι : ℚ̄ →+* ℂ) (y : FF)
+    (hy : (y : LaurentSeries ℚ̄) = jqModC ℚ̄) :
+    Nat.card {P : AlgebraicCurve.Place ℚ̄ FF // P.ord y < 0} ≤
+      Nat.card (DoubleCoset.Quotient (CongruenceSubgroup.Gamma1 M : Set SL(2, ℤ))
+        ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) :
+          Set SL(2, ℤ))) := by
+  classical
+  have := finiteDimensional_jK M K
+  have := isGalois_jK M K
+  have hKc : CharZero ℚ̄ := charZero_of_injective_algebraMap (algebraMap ℚ ℚ̄).injective
+  have hΓfi : (CongruenceSubgroup.Gamma1 M).FiniteIndex :=
+    (CongruenceSubgroup.Gamma1_is_congruence M).finiteIndex
+  have hΓM : CongruenceSubgroup.Gamma M ≤ CongruenceSubgroup.Gamma1 M := Gamma_le_Gamma1 M
+  have hT : ModularGroup.T ∈ CongruenceSubgroup.Gamma1 M := T_mem_Gamma1 M
+  obtain ⟨Φ, hΦc, hΦy, hΦfix⟩ :=
+    ModularCurve.exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN M
+      (CongruenceSubgroup.Gamma1 M) hΓM hT ι K
+  set L₀ : IntermediateField ℂ K := ℂ⟮jK M K⟯ with hL₀
+  let E : IntermediateField L₀ K := IntermediateField.adjoin L₀ (Set.range Φ)
+  have hΦE : ∀ u, Φ u ∈ E := fun u => IntermediateField.subset_adjoin _ _ ⟨u, rfl⟩
+  let ΦE : FF →+* E := Φ.codRestrict E hΦE
+  let : Algebra ℚ̄ ℂ := ι.toAlgebra
+  let : Algebra FF E := ΦE.toAlgebra
+  let : Algebra ℚ̄ E := ((algebraMap ℂ E).comp ι).toAlgebra
+  have : IsScalarTower ℚ̄ ℂ E := IsScalarTower.of_algebraMap_eq (fun _ => rfl)
+  have : IsScalarTower ℚ̄ FF E := IsScalarTower.of_algebraMap_eq (fun c => by
+    apply Subtype.ext
+    change algebraMap ℂ K (ι c) = Φ (algebraMap ℚ̄ FF c)
+    rw [hΦc])
+  obtain ⟨hyT, hfin⟩ :=
+  transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC
+      ℚ̄ (CongruenceSubgroup.Gamma1 M) hT y hy
+  have := hfin
+  have : AlgebraicCurve.IsCurveOver ℚ̄ FF :=
+    AlgebraicCurve.isCurveOver_of_transcendental_of_perfectField hyT hfin
+  have hjE : jK M K ∈ E :=
+    E.algebraMap_mem (⟨jK M K, IntermediateField.mem_adjoin_simple_self ℂ _⟩ : L₀)
+  let xE : E := ⟨jK M K, hjE⟩
+  have hyt : ((algebraMap FF E y : E) : K) = jK M K := hΦy y hy
+  have hΦEy : algebraMap FF E y = xE := Subtype.ext hyt
+  have hfinE : FiniteDimensional L₀ E := IntermediateField.finiteDimensional_left E
+  have hgen : IntermediateField.adjoin ℂ (Set.range (algebraMap FF E)) = ⊤ := by
+    apply adjoin_range_eq_top (jK M K) E
+    change ((IntermediateField.adjoin L₀ (Set.range Φ) : IntermediateField L₀ K) : Set K) ⊆
+      ((IntermediateField.adjoin ℂ (Set.range fun u => Φ u) : IntermediateField ℂ K) : Set K)
+    apply adjoin_adjoin_subset
+    exact IntermediateField.subset_adjoin _ _ ⟨y, hΦy y hy⟩
+  have hxT : Transcendental ℂ xE := by
+    intro halg
+    apply transcendental_jK M K
+    have h' : IsAlgebraic ℂ ((IntermediateField.val E).restrictScalars ℂ xE) := halg.algHom _
+    exact h'
+  have hxfin : FiniteDimensional (IntermediateField.adjoin ℂ ({xE} : Set E)) E :=
+    finiteDimensional_adjoin (jK M K) E xE rfl
+  have hσE : ∀ γ ∈ CongruenceSubgroup.Gamma1 M, ∀ e : E, σ' M K γ (e : K) = e := by
+    intro γ hγ e
+    have hle : E ≤ IntermediateField.fixedField (Subgroup.zpowers (σ' M K γ)) := by
+      apply IntermediateField.adjoin_le_iff.mpr
+      rintro _ ⟨u, rfl⟩
+      rw [SetLike.mem_coe, IntermediateField.mem_fixedField_iff]
+      intro g hg
+      have hst : σ' M K γ ∈ MulAction.stabilizer (K ≃ₐ[L₀] K) (Φ u) := by
+        rw [MulAction.mem_stabilizer_iff, AlgEquiv.smul_def, σ'_apply]
+        exact hΦfix γ hγ (comp_smul_mem M K γ⁻¹) (σK M K γ) (σK_algebraMap M K γ) u
+      have := (Subgroup.zpowers_le.mpr hst) hg
+      rwa [MulAction.mem_stabilizer_iff, AlgEquiv.smul_def] at this
+    exact (IntermediateField.mem_fixedField_iff _ (e : K)).mp (hle e.2) _ (Subgroup.mem_zpowers _)
+  have hy0 : y ≠ 0 := fun h => by
+    rw [h] at hyT; exact hyT isAlgebraic_zero
+  obtain ⟨-, hplaces⟩ :=
+    AlgebraicCurve.finrank_le_and_natCard_places_le_of_constantFieldExtension_adjoin y hyT
+      (jK M K) (transcendental_jK M K) E hyt hgen
+  have hfinE' : Finite {P : AlgebraicCurve.Place ℂ E // P.ord (algebraMap FF E y) < 0} :=
+    ((hplaces y hy0).2).1
+  have hDC := fun P : AlgebraicCurve.Place ℚ̄ FF =>
+    AlgebraicCurve.Place.exists_comap_algebraMap_eq_of_constantFieldExtension ℚ̄ FF ℂ E
+      ⟨y, hyT, hfin⟩ ⟨xE, hxT, hxfin⟩ hgen P
+  choose lift hcomap hord huniq using hDC
+  have hinj : Function.Injective lift := fun P₁ P₂ h =>
+    AlgebraicCurve.Place.ext (by rw [← hcomap P₁, ← hcomap P₂, h])
+  let ι' : {P : AlgebraicCurve.Place ℚ̄ FF // P.ord y < 0} →
+      {P : AlgebraicCurve.Place ℂ E // P.ord (algebraMap FF E y) < 0} :=
+    fun P => ⟨lift P.1, by rw [hord]; exact P.2⟩
+  have hι' : Function.Injective ι' := fun P₁ P₂ h =>
+    Subtype.ext (hinj (congrArg (fun Q : {P : AlgebraicCurve.Place ℂ E //
+      P.ord (algebraMap FF E y) < 0} => Q.1) h))
+  have h1 : Nat.card {P : AlgebraicCurve.Place ℚ̄ FF // P.ord y < 0} ≤
+      Nat.card {P : AlgebraicCurve.Place ℂ E // P.ord (algebraMap FF E y) < 0} :=
+    Nat.card_le_card_of_injective ι' hι'
+  obtain ⟨W, hW, hD⟩ := exists_place_infty M K
+  have hiff : ∀ P : AlgebraicCurve.Place ℂ E,
+      0 < P.ord (xE⁻¹ - algebraMap ℂ E 0) ↔ P.ord (algebraMap FF E y) < 0 := by
+    intro P
+    rw [map_zero, sub_zero, AlgebraicCurve.Place.ord_inv, hΦEy]
+    omega
+  let eqv : {P : AlgebraicCurve.Place ℂ E // 0 < P.ord (xE⁻¹ - algebraMap ℂ E 0)} ≃
+      {P : AlgebraicCurve.Place ℂ E // P.ord (algebraMap FF E y) < 0} :=
+    Equiv.subtypeEquivRight hiff
+  have h2 := natCard_place_le_natCard_doubleCoset (jK M K)⁻¹ L₀ (adjoin_inv_eq _).symm (σ' M K)
+    (σ'_surjective M K) (CongruenceSubgroup.Gamma1 M)
+    (Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))) E hσE 0 W hW hD xE⁻¹ rfl
+  rw [Nat.card_congr eqv] at h2
+  exact h1.trans h2
+
+theorem natCard_place_ord_lt_zero_eq (y : FF) (hy : (y : LaurentSeries ℚ̄) = jqModC ℚ̄) :
+    Nat.card {P : AlgebraicCurve.Place ℚ̄ FF // P.ord y < 0} =
+      Nat.card (DoubleCoset.Quotient (CongruenceSubgroup.Gamma1 M : Set SL(2, ℤ))
+        ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) :
+          Set SL(2, ℤ))) := by
+  have := isDomain_ring M
+  have : Algebra.IsAlgebraic ℚ ℚ̄ := AlgebraicClosure.isAlgebraic ℚ
+  let ι : ℚ̄ →+* ℂ := (IsAlgClosed.lift (R := ℚ) (M := ℂ) (S := ℚ̄)).toRingHom
+  refine le_antisymm (natCard_place_ord_lt_zero_le M (FractionRing (LevelN.ring M)) ι y hy) ?_
+  have hfull :=
+    ModularCurve.finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index ℚ̄ M y
+      hy
+  exact (ModularCurve.natCard_doubleCoset_le_card_fibres_of_finrank_eq_index M
+    (CongruenceSubgroup.Gamma1 M) le_rfl y hy hfull).2.2
+
+end Main
+
+end ModularCurve.CuspFibreGamma1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpFunctionFieldC intFormRatiosC_subset jGen coeffMap coeffMap_single \
+  coeffMap_coeffMap coeffMap_congr coeffEmb laurentBaseChange coeffEmb_mem_laurentBaseChange \
+  mem_laurentBaseChange_iff coeffMap_mem_laurentBaseChange jqModC LevelN.wp LevelN.fricke \
+  LevelN.jAnalytic LevelN.ring LevelN.jGen coeffMap_jqModC \
+  LevelN.exists_monoidHom_algEquiv_fixedField_eq_adjoin LevelN.exists_place_ord_neg_forall_smul_eq \
+  exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN \
+  natCard_doubleCoset_le_card_fibres_of_finrank_eq_index \
+  finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index \
+  transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqMod\
+  C jqModC_mem_intFormRatiosC exists_place_algebraicClosure_ord_comp_eq_of_laurentBaseChange"
+namespace CuspTransport
+p2m_open "ModularCurve"
+
+p2m_open "ModularCurve \
+  P2MW.S_ModularCurve_natCard_place_ord_neg_laurentBaseChange_gamma1_eq_natCard_doubleCoset.Modular\
+  Curve IntermediateField AlgebraicCurve"
+
+section CoeffMap
+
+variable {κ k : Type*} [Field κ] [Field k] [Algebra ℚ κ] [Algebra ℚ k] (τ : κ →ₐ[ℚ] k)
+
+theorem algebraMap_laurentSeries_eq_C {L : Type*} [Field L] (a : L) :
+    algebraMap L (LaurentSeries L) a = HahnSeries.C a := by
+  rw [HahnSeries.algebraMap_apply']
+  have h1 : algebraMap L (PowerSeries L) a = PowerSeries.C a := by simp
+  rw [h1, HahnSeries.ofPowerSeries_C]
+
+theorem coeffMap_algebraMap' (a : κ) :
+    coeffMap τ.toRingHom (algebraMap κ (LaurentSeries κ) a) = algebraMap k (LaurentSeries k) (τ a)
+      := by
+  rw [algebraMap_laurentSeries_eq_C, algebraMap_laurentSeries_eq_C, HahnSeries.C_apply,
+    HahnSeries.C_apply,
+    coeffMap_single]
+  rfl
+
+theorem coeffMap_coeffEmb' (z : LaurentSeries ℚ) :
+    coeffMap τ.toRingHom (coeffEmb κ z) = coeffEmb k z := by
+  rw [coeffEmb, coeffEmb, coeffMap_coeffMap]
+  exact coeffMap_congr (τ.comp_algebraMap) z
+
+variable (F₀ : IntermediateField ℚ (LaurentSeries ℚ))
+
+theorem coeffMap_mem_laurentBaseChange {x : LaurentSeries κ} (hx : x ∈ laurentBaseChange κ F₀) :
+    coeffMap τ.toRingHom x ∈ laurentBaseChange k F₀ := by
+  rw [mem_laurentBaseChange_iff] at hx
+  have hle : Subfield.closure (Set.range (algebraMap κ (LaurentSeries κ)) ∪ (⇑(coeffEmb κ) '' (F₀ :
+    Set (LaurentSeries ℚ)))) ≤
+      (laurentBaseChange k F₀).toSubfield.comap (coeffMap τ.toRingHom) := by
+    rw [Subfield.closure_le]
+    rintro z (⟨a, rfl⟩ | ⟨w, hw, rfl⟩)
+    · change coeffMap τ.toRingHom (algebraMap κ (LaurentSeries κ) a) ∈ laurentBaseChange k F₀
+      rw [coeffMap_algebraMap']
+      exact IntermediateField.algebraMap_mem _ _
+    · change coeffMap τ.toRingHom (coeffEmb κ w) ∈ laurentBaseChange k F₀
+      rw [coeffMap_coeffEmb']
+      exact coeffEmb_mem_laurentBaseChange k hw
+  exact hle hx
+
+noncomputable def psi : ↥(laurentBaseChange κ F₀) →+* ↥(laurentBaseChange k F₀) :=
+  RingHom.codRestrict ((coeffMap τ.toRingHom).comp (algebraMap ↥(laurentBaseChange κ F₀)
+    (LaurentSeries κ)))
+    (laurentBaseChange k F₀) (fun f => coeffMap_mem_laurentBaseChange τ F₀ f.2)
+
+theorem coe_psi (f : ↥(laurentBaseChange κ F₀)) :
+    ((psi τ F₀ f : ↥(laurentBaseChange k F₀)) : LaurentSeries k) = coeffMap τ.toRingHom (f :
+      LaurentSeries κ) := rfl
+
+end CoeffMap
+
+theorem jqModC_mem_laurentBaseChange (L : Type*) [Field L] [Algebra ℚ L]
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) :
+    jqModC L ∈ laurentBaseChange L (qExpFunctionFieldC ℚ Γ) := by
+  have h := intFormRatiosC_subset ℚ Γ (ModularCurve.jqModC_mem_intFormRatiosC ℚ Γ)
+  have e : coeffEmb L (jqModC ℚ) = jqModC L := coeffMap_jqModC _
+  exact e ▸ coeffEmb_mem_laurentBaseChange L h
+
+open scoped MatrixGroups in
+theorem natCard_place_ord_lt_zero_laurentBaseChange_eq
+    (K : Type*) [Field K] [Algebra ℚ K] [IsAlgClosed K] (M : ℕ) [NeZero M]
+    (yK : ↥(laurentBaseChange K (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))))
+    (hyK : (yK : LaurentSeries K) = jqModC K)
+    (y : ↥(laurentBaseChange (AlgebraicClosure ℚ) (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1
+      M))))
+    (hy : (y : LaurentSeries (AlgebraicClosure ℚ)) = jqModC (AlgebraicClosure ℚ)) :
+    Nat.card {P : Place K ↥(laurentBaseChange K (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1
+      M))) // P.ord yK < 0} =
+      Nat.card {P : Place (AlgebraicClosure ℚ)
+        ↥(laurentBaseChange (AlgebraicClosure ℚ) (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1
+          M))) // P.ord y < 0} := by
+  classical
+  let F₀ : IntermediateField ℚ (LaurentSeries ℚ) :=
+    qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)
+  have : CharZero K := charZero_of_injective_algebraMap (algebraMap ℚ K).injective
+  have : Algebra.IsAlgebraic ℚ (AlgebraicClosure ℚ) := AlgebraicClosure.isAlgebraic ℚ
+  let τ : (AlgebraicClosure ℚ) →ₐ[ℚ] K := IsAlgClosed.lift
+  let Ψ : ↥(laurentBaseChange (AlgebraicClosure ℚ) F₀) →+* ↥(laurentBaseChange K F₀) := psi τ F₀
+  have hΨ : ∀ f, ((Ψ f : ↥(laurentBaseChange K F₀)) : LaurentSeries K) = coeffMap τ.toRingHom (f :
+    LaurentSeries (AlgebraicClosure ℚ)) :=
+    fun f => rfl
+  have hΨy : Ψ y = yK := by
+    apply Subtype.ext
+    rw [hΨ, hy, hyK, coeffMap_jqModC]
+  have : (CongruenceSubgroup.Gamma1 M).FiniteIndex :=
+    (CongruenceSubgroup.Gamma1_is_congruence M).finiteIndex
+  have hT : ModularGroup.T ∈ CongruenceSubgroup.Gamma1 M := by
+    rw [CongruenceSubgroup.Gamma1_mem]
+    simp [ModularGroup.T]
+  obtain ⟨htr, hfin⟩ :=
+  transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC
+      (AlgebraicClosure ℚ) (CongruenceSubgroup.Gamma1 M) hT y hy
+  obtain ⟨htrK, hfinK⟩ :=
+  transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC
+      K (CongruenceSubgroup.Gamma1 M) hT yK hyK
+  have : IsCurveOver (AlgebraicClosure ℚ) ↥(laurentBaseChange (AlgebraicClosure ℚ) F₀) :=
+    AlgebraicCurve.isCurveOver_of_transcendental_of_perfectField htr hfin
+  let : Algebra (AlgebraicClosure ℚ) K := τ.toRingHom.toAlgebra
+  let : Algebra ↥(laurentBaseChange (AlgebraicClosure ℚ) F₀) ↥(laurentBaseChange K F₀) :=
+    Ψ.toAlgebra
+  let : Algebra (AlgebraicClosure ℚ) ↥(laurentBaseChange K F₀) :=
+    ((algebraMap K ↥(laurentBaseChange K F₀)).comp τ.toRingHom).toAlgebra
+  have : IsScalarTower (AlgebraicClosure ℚ) K ↥(laurentBaseChange K F₀) :=
+    IsScalarTower.of_algebraMap_eq (fun _ => rfl)
+  have : IsScalarTower (AlgebraicClosure ℚ) ↥(laurentBaseChange (AlgebraicClosure ℚ) F₀)
+    ↥(laurentBaseChange K F₀) :=
+    by
+    refine IsScalarTower.of_algebraMap_eq (fun a => ?_)
+    apply Subtype.ext
+    change ((algebraMap K ↥(laurentBaseChange K F₀) (τ a) : ↥(laurentBaseChange K F₀)) :
+      LaurentSeries K) =
+      ((Ψ (algebraMap (AlgebraicClosure ℚ) ↥(laurentBaseChange (AlgebraicClosure ℚ) F₀) a) :
+        ↥(laurentBaseChange K F₀)) : LaurentSeries K)
+    rw [hΨ]
+    exact (coeffMap_algebraMap' τ a).symm
+  have hgen : IntermediateField.adjoin K
+      (Set.range (algebraMap ↥(laurentBaseChange (AlgebraicClosure ℚ) F₀) ↥(laurentBaseChange K
+        F₀))) = ⊤ := by
+    rw [eq_top_iff]
+    rintro ⟨v, hv⟩ -
+    have hv' := (mem_laurentBaseChange_iff).mp hv
+    have hle : Subfield.closure (Set.range (algebraMap K (LaurentSeries K)) ∪
+        (⇑(coeffEmb K) '' (F₀ : Set (LaurentSeries ℚ)))) ≤
+        (IntermediateField.adjoin K
+          (Set.range (algebraMap ↥(laurentBaseChange (AlgebraicClosure ℚ) F₀) ↥(laurentBaseChange K
+            F₀)))).toSubfield.map
+          (algebraMap ↥(laurentBaseChange K F₀) (LaurentSeries K)) := by
+      rw [Subfield.closure_le]
+      rintro z (⟨a, rfl⟩ | ⟨w, hw, rfl⟩)
+      · exact ⟨algebraMap K ↥(laurentBaseChange K F₀) a, IntermediateField.algebraMap_mem _ a,
+          (IsScalarTower.algebraMap_apply K ↥(laurentBaseChange K F₀) (LaurentSeries K) a).symm⟩
+      · refine ⟨Ψ ⟨coeffEmb (AlgebraicClosure ℚ) w, coeffEmb_mem_laurentBaseChange (AlgebraicClosure
+          ℚ) hw⟩,
+          IntermediateField.subset_adjoin K _ ⟨_, rfl⟩, ?_⟩
+        change ((Ψ _ : ↥(laurentBaseChange K F₀)) : LaurentSeries K) = coeffEmb K w
+        rw [hΨ]
+        exact coeffMap_coeffEmb' τ w
+    obtain ⟨w, hwA, hwv⟩ := hle hv'
+    have hw : w = ⟨v, hv⟩ := Subtype.ext hwv
+    rw [← hw]
+    exact hwA
+  have hlift := fun P : Place (AlgebraicClosure ℚ) ↥(laurentBaseChange (AlgebraicClosure ℚ) F₀) =>
+    AlgebraicCurve.Place.exists_comap_algebraMap_eq_of_constantFieldExtension (AlgebraicClosure ℚ)
+      ↥(laurentBaseChange (AlgebraicClosure ℚ) F₀)
+      K ↥(laurentBaseChange K F₀) ⟨y, htr, hfin⟩ ⟨yK, htrK, hfinK⟩ hgen P
+  let lift : Place (AlgebraicClosure ℚ) ↥(laurentBaseChange (AlgebraicClosure ℚ) F₀) → Place K
+    ↥(laurentBaseChange K F₀) :=
+    fun P => (hlift P).choose
+  have hlift_comap : ∀ P, (lift P).toValuationSubring.comap
+      (algebraMap ↥(laurentBaseChange (AlgebraicClosure ℚ) F₀) ↥(laurentBaseChange K F₀)) =
+        P.toValuationSubring :=
+    fun P => (hlift P).choose_spec.1
+  have hlift_ord : ∀ P f, (lift P).ord (Ψ f) = P.ord f := fun P f => (hlift P).choose_spec.2.1 f
+  have hlift_uniq : ∀ P Q', Q'.toValuationSubring.comap
+      (algebraMap ↥(laurentBaseChange (AlgebraicClosure ℚ) F₀) ↥(laurentBaseChange K F₀)) =
+        P.toValuationSubring → Q' = lift P :=
+    fun P Q' h => (hlift P).choose_spec.2.2 Q' h
+  let g : {P : Place (AlgebraicClosure ℚ) ↥(laurentBaseChange (AlgebraicClosure ℚ) F₀) // P.ord y <
+    0} →
+      {Q : Place K ↥(laurentBaseChange K F₀) // Q.ord yK < 0} :=
+    fun P => ⟨lift P.1, by rw [← hΨy, hlift_ord]; exact P.2⟩
+  have ginj : Function.Injective g := by
+    rintro ⟨P₁, h₁⟩ ⟨P₂, h₂⟩ h
+    have h' : lift P₁ = lift P₂ := congrArg Subtype.val h
+    apply Subtype.ext
+    apply AlgebraicCurve.Place.ext
+    rw [← hlift_comap P₁, ← hlift_comap P₂, h']
+  have gsurj : Function.Surjective g := by
+    rintro ⟨Q, hQ⟩
+    have hQy : Q.ord (Ψ y) ≠ 0 := by rw [hΨy]; exact ne_of_lt hQ
+    obtain ⟨P₀, hP₀⟩ :=
+      ModularCurve.exists_place_algebraicClosure_ord_comp_eq_of_laurentBaseChange K
+        (CongruenceSubgroup.Gamma1 M) hT
+        τ Ψ hΨ Q ⟨y, hQy⟩
+    have hP₀y : P₀.ord y < 0 := by rw [← hP₀ y, hΨy]; exact hQ
+    refine ⟨⟨P₀, hP₀y⟩, ?_⟩
+    apply Subtype.ext
+    change lift P₀ = Q
+    symm
+    apply hlift_uniq
+    ext f
+    rcases eq_or_ne f 0 with rfl | hf
+    · simp
+    · rw [AlgebraicCurve.Place.mem_comap_iff_ord_nonneg hf, AlgebraicCurve.Place.mem_iff_ord_nonneg
+        P₀ hf]
+      change 0 ≤ Q.ord (Ψ f) ↔ 0 ≤ P₀.ord f
+      rw [hP₀ f]
+  exact (Nat.card_congr (Equiv.ofBijective g ⟨ginj, gsurj⟩)).symm
+
+end ModularCurve.CuspTransport
+end
+
+p2m_open "ModularCurve \
+  P2MW.S_ModularCurve_natCard_place_ord_neg_laurentBaseChange_gamma1_eq_natCard_doubleCoset.Modular\
+  Curve CongruenceSubgroup AlgebraicCurve"
+open scoped MatrixGroups
+
+theorem solution
+    (K : Type*) [Field K] [Algebra ℚ K] [IsAlgClosed K]
+    (M : ℕ) [NeZero M]
+    (y : ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))))
+    (hy : (y : LaurentSeries K) = ModularCurve.jqModC K) :
+    Nat.card {P : AlgebraicCurve.Place K ↥(ModularCurve.laurentBaseChange K
+      (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))) // P.ord y < 0} =
+      Nat.card (DoubleCoset.Quotient (CongruenceSubgroup.Gamma1 M : Set SL(2, ℤ))
+        ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) : Set SL(2,
+          ℤ))) := by
+  let y₀ : ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+      (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))) :=
+    ⟨ModularCurve.jqModC (AlgebraicClosure ℚ),
+      ModularCurve.CuspTransport.jqModC_mem_laurentBaseChange (AlgebraicClosure ℚ)
+        (CongruenceSubgroup.Gamma1 M)⟩
+  rw [ModularCurve.CuspTransport.natCard_place_ord_lt_zero_laurentBaseChange_eq K M y hy y₀ rfl]
+  exact ModularCurve.CuspFibreGamma1.natCard_place_ord_lt_zero_eq M y₀ rfl
+
+example
+    (K : Type*) [Field K] [Algebra ℚ K] [IsAlgClosed K]
+    (M : ℕ) [NeZero M]
+    (y : ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))))
+    (hy : (y : LaurentSeries K) = ModularCurve.jqModC K) :
+    Nat.card {P : AlgebraicCurve.Place K ↥(ModularCurve.laurentBaseChange K
+      (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))) // P.ord y < 0} =
+      Nat.card (DoubleCoset.Quotient (CongruenceSubgroup.Gamma1 M : Set SL(2, ℤ))
+        ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) : Set SL(2,
+          ℤ))) :=
+  solution K M y hy
+
+end S_ModularCurve_natCard_place_ord_neg_laurentBaseChange_gamma1_eq_natCard_doubleCoset
+end P2MW
+export P2MW.S_ModularCurve_natCard_place_ord_neg_laurentBaseChange_gamma1_eq_natCard_doubleCoset
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open CongruenceSubgroup AlgebraicCurve
+open ModularCurve
+open scoped MatrixGroups
+theorem ModularCurve.natCard_place_ord_neg_laurentBaseChange_gamma1_eq_natCard_doubleCoset
+    (K : Type*) [Field K] [Algebra ℚ K] [IsAlgClosed K]
+    (M : ℕ) [NeZero M]
+    (y : ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))))
+    (hy : (y : LaurentSeries K) = ModularCurve.jqModC K) :
+    Nat.card {P : AlgebraicCurve.Place K ↥(ModularCurve.laurentBaseChange K
+      (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))) // P.ord y < 0} =
+      Nat.card (DoubleCoset.Quotient (CongruenceSubgroup.Gamma1 M : Set SL(2, ℤ))
+        ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) : Set SL(2,
+          ℤ))) :=
+  solution K M y hy
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_quot_sameOrbit_cycSub_eq_natCard_moduliPoint_j_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_quot_sameOrbit_cycSub_eq_natCard_moduliPoint_j_eq.lean
new file mode 100644
index 0000000000..d5878a2866
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_natCard_quot_sameOrbit_cycSub_eq_natCard_moduliPoint_j_eq.lean
@@ -0,0 +1,261 @@
+/-
+Based on Prove2Me node ModularCurve.natCard_quot_sameOrbit_cycSub_eq_natCard_moduliPoint_j_eq
+(1b89bb0f-230d-5d09-84f4-b42679dcf6e6) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ec675afc-2e25-58e5-8147-bdadcbf084fc
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EMD
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_moduliPoint_j_eq_eq_natCard_quot_addOrderOf_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_vcInvFun_add
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Orbits of cyclic N-subgroups count moduli points over j(E₀)
+
+Theorem statement: `ModularCurve.natCard_quot_sameOrbit_cycSub_eq_natCard_moduliPoint_j_eq`
+(`1b89bb0f-230d-5d09-84f4-b42679dcf6e6`), by Claude, 2026-09-05.
+
+Proof: submission `ec675afc-2e25-58e5-8147-bdadcbf084fc`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a non-zero natural number and let $E_0$ be a Weierstrass curve over
+$\overline{\mathbb{Q}}$ (the ambient field is `AlgebraicClosure ℚ`) which is elliptic. On the
+left-hand side one considers the type [`ModularCurve.CycSub E₀ N`](def/ModularCurve_EMD.html#L36) of
+those additive subgroups $H$ of the affine point group $E_0(\overline{\mathbb{Q}})$ for which there
+exists a point $g$ of additive order exactly $N$ with $H$ the subgroup of integer multiples of $g$,
+and one forms the quotient (in the sense of `Quot`, i.e. by the equivalence relation generated by
+the given relation) of this type by the relation [`ModularCurve.SameOrbit
+E₀`](def/ModularCurve_EMD.html#L40) applied to the underlying subgroups: $H$ and $H'$ are so related
+when there is a variable change $\gamma$ over $\overline{\mathbb{Q}}$ fixing $E_0$, i.e. $\gamma
+\bullet E_0 = E_0$, and there are points $g, g'$ with $H$ the multiples of $g$, $H'$ the multiples
+of $g'$, and $g'$ heterogeneously equal to the image of $g$ under the transport `Point.vcInvFun`
+along $\gamma$. On the right-hand side one considers the set of $x$ in [`ModularCurve.ModuliPoint N
+(AlgebraicClosure ℚ)`](def/ModularCurve_ModuliPoint.html#L35) — the quotient of the type of triples
+(an elliptic Weierstrass curve over $\overline{\mathbb{Q}}$, a point `gen` of additive order $N$) by
+the relation that $P$ and $Q$ are related when some variable change $\gamma$ carries $P$'s curve to
+$Q$'s curve and $Q$'s generator is, heterogeneously, $k$ times the transport of $P$'s generator
+along $\gamma$ for some natural $k$ coprime to $N$ — subject to the condition that the induced
+$j$-invariant `ModuliPoint.j x` equals $j(E_0)$. The assertion is that these two types have equal
+`Nat.card`.
+
+This is the moduli-theoretic count of points of $X_0(N)$ lying over a fixed $j$-invariant: the
+$\mathrm{Aut}(E_0)$-orbits of cyclic subgroups of order $N$ in $E_0(\overline{\mathbb{Q}})$ are
+equinumerous with the pairs $(E,C)$ whose underlying curve has $j(E) = j(E_0)$. It is used by
+[`ModularCurve.card_eq_natCard_moduliPoint_j_eq_of_EMD`]
+(thm.html#ModularCurve.card_eq_natCard_moduliPoint_j_eq_of_EMD),
+and its proof goes through
+[`ModularCurve.natCard_moduliPoint_j_eq_eq_natCard_quot_addOrderOf_eq`]
+(thm.html#ModularCurve.natCard_moduliPoint_j_eq_eq_natCard_quot_addOrderOf_eq),
+which replaces the right-hand side by a quotient of the set of points of exact order $N$ on $E_0$,
+together with the additivity of the transport map
+[`WeierstrassCurve.Affine.Point.vcInvFun`](def/WeierstrassCurve_VariableChangePointEquiv.html#L119).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_natCard_quot_sameOrbit_cycSub_eq_natCard_moduliPoint_j_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_ModularCurve_natCard_quot_sameOrbit_cycSub_eq_natCard_moduliPoint_j_eq
+
+open WeierstrassCurve WeierstrassCurve.Affine
+
+namespace P2MWs12
+namespace CycSubOrbit
+
+section Transport
+
+variable {K : Type*} [Field K]
+
+theorem vcXInv_one (x : K) : vcXInv (1 : VariableChange K) x = x := by
+  simp [WeierstrassCurve.Affine.vcXInv, VariableChange.one_def]
+
+theorem vcYInv_one (x y : K) : vcYInv (1 : VariableChange K) x y = y := by
+  simp [WeierstrassCurve.Affine.vcYInv, VariableChange.one_def]
+
+variable [DecidableEq K]
+
+omit [DecidableEq K] in
+theorem vcInvFun_some (γ : VariableChange K) (W : WeierstrassCurve.Affine K) {x y : K}
+    (h : W.Nonsingular x y) :
+    Point.vcInvFun γ W (Point.some x y h) = Point.some (vcXInv γ x) (vcYInv γ x y)
+      ((nonsingular_variableChange_iff (vcXInv γ x) (vcYInv γ x y)).mpr
+        (by rwa [vcX_vcXInv, vcY_vcYInv])) := rfl
+
+noncomputable def vcInvHom (γ : VariableChange K) (W : WeierstrassCurve.Affine K) :
+    W.Point →+ (γ • W).toAffine.Point :=
+  AddMonoidHom.mk' (Point.vcInvFun γ W) (WeierstrassCurve.Affine.Point.vcInvFun_add γ W)
+
+omit [DecidableEq K] in
+theorem vcInvFun_injective (γ : VariableChange K) (W : WeierstrassCurve.Affine K) :
+    Function.Injective (Point.vcInvFun γ W) :=
+  (Point.vcFun_rightInverse (C := γ) (W := W)).injective
+
+theorem addOrderOf_vcInvFun (γ : VariableChange K) (W : WeierstrassCurve.Affine K) (P : W.Point) :
+    addOrderOf (Point.vcInvFun γ W P) = addOrderOf P :=
+  addOrderOf_injective (vcInvHom γ W) (vcInvFun_injective γ W) P
+
+theorem vcInvFun_nsmul (γ : VariableChange K) (W : WeierstrassCurve.Affine K) (k : ℕ) (P : W.Point)
+    :
+    Point.vcInvFun γ W (k • P) = k • Point.vcInvFun γ W P :=
+  map_nsmul (vcInvHom γ W) k P
+
+omit [DecidableEq K] in
+theorem vcInvFun_one_heq (W : WeierstrassCurve.Affine K) (P : W.Point) :
+    HEq (Point.vcInvFun (1 : VariableChange K) W P) P := by
+  rcases P with _ | ⟨x, y, h⟩
+  · exact ModularCurve.Point.heq_zero (one_smul _ W)
+  · simp only [vcInvFun_some]
+    exact ModularCurve.Point.heq_some (one_smul _ W) (vcXInv_one x) (vcYInv_one x y)
+
+theorem addOrderOf_eq_of_heq {V V' : WeierstrassCurve.Affine K} (hV : V' = V)
+    {S : V'.Point} {T : V.Point} (h : HEq S T) : addOrderOf S = addOrderOf T := by
+  subst hV
+  rw [eq_of_heq h]
+
+omit [DecidableEq K] in
+theorem exists_heq {V V' : WeierstrassCurve.Affine K} (hV : V' = V) (T : V.Point) :
+    ∃ S : V'.Point, HEq S T := by
+  subst hV
+  exact ⟨T, HEq.rfl⟩
+
+end Transport
+
+section Cyclic
+
+variable {G : Type*} [AddGroup G]
+
+theorem addOrderOf_eq_of_zmultiples_eq {x y : G}
+    (h : AddSubgroup.zmultiples x = AddSubgroup.zmultiples y) : addOrderOf x = addOrderOf y := by
+  rw [← Nat.card_zmultiples x, ← Nat.card_zmultiples y, h]
+
+theorem exists_coprime_nsmul_of_mem_zmultiples {N : ℕ} (hN : N ≠ 0) {x y : G}
+    (hx : addOrderOf x = N) (hy : addOrderOf y = N) (hmem : y ∈ AddSubgroup.zmultiples x) :
+    ∃ k : ℕ, k.Coprime N ∧ y = k • x := by
+  have hfin : IsOfFinAddOrder x := by
+    rw [← addOrderOf_pos_iff, hx]; exact Nat.pos_of_ne_zero hN
+  rw [← hfin.mem_multiples_iff_mem_zmultiples, AddSubmonoid.mem_multiples_iff] at hmem
+  obtain ⟨k, rfl⟩ := hmem
+  refine ⟨k, ?_, rfl⟩
+  have h : addOrderOf (k • x) = addOrderOf x / (addOrderOf x).gcd k := hfin.addOrderOf_nsmul x k
+  rw [hy, hx] at h
+  have hg : N.gcd k = 1 := by
+    have hpos : 0 < N.gcd k := Nat.gcd_pos_of_pos_left _ (Nat.pos_of_ne_zero hN)
+    have hdvd : N.gcd k ∣ N := Nat.gcd_dvd_left N k
+    have := Nat.div_mul_cancel hdvd
+    rw [← h] at this
+    have := Nat.eq_of_mul_eq_mul_left (Nat.pos_of_ne_zero hN) (this.trans (mul_one N).symm)
+    exact this
+  exact Nat.Coprime.symm hg
+
+theorem zmultiples_nsmul_eq_of_coprime {N : ℕ} {x : G} (hx : addOrderOf x = N) {k : ℕ}
+    (hk : k.Coprime N) : AddSubgroup.zmultiples (k • x) = AddSubgroup.zmultiples x := by
+  apply le_antisymm
+  · exact AddSubgroup.zmultiples_le_of_mem ((AddSubgroup.zmultiples x).nsmul_mem
+      (AddSubgroup.mem_zmultiples x) k)
+  · apply AddSubgroup.zmultiples_le_of_mem
+    obtain ⟨m, hm⟩ := exists_nsmul_eq_self_of_coprime (x := x) (n := k) (hx ▸ hk)
+    have h : m • k • x ∈ AddSubgroup.zmultiples (k • x) :=
+      (AddSubgroup.zmultiples (k • x)).nsmul_mem (AddSubgroup.mem_zmultiples (k • x)) m
+    rwa [hm] at h
+
+end Cyclic
+
+end P2MWs12.CycSubOrbit
+
+open P2MWs12.CycSubOrbit ModularCurve in
+theorem solution (N : ℕ) [NeZero N]
+    (E₀ : WeierstrassCurve (AlgebraicClosure ℚ)) [E₀.IsElliptic] :
+    Nat.card (Quot (fun H H' : ModularCurve.CycSub E₀ N => ModularCurve.SameOrbit E₀ H.1 H'.1))
+      = Nat.card {x : ModularCurve.ModuliPoint N (AlgebraicClosure ℚ) // ModularCurve.ModuliPoint.j
+        x = E₀.j} := by
+  rw [ModularCurve.natCard_moduliPoint_j_eq_eq_natCard_quot_addOrderOf_eq N (AlgebraicClosure ℚ) E₀]
+  have hN : N ≠ 0 := NeZero.ne N
+  let A := {T : E₀.toAffine.Point // addOrderOf T = N}
+  let R : A → A → Prop := fun T T' =>
+    ∃ γ : VariableChange (AlgebraicClosure ℚ), ∃ _ : γ • E₀ = E₀, ∃ k : ℕ, k.Coprime N ∧
+      HEq T'.1 (k • Point.vcInvFun γ E₀.toAffine T.1)
+  let S : CycSub E₀ N → CycSub E₀ N → Prop := fun H H' => SameOrbit E₀ H.1 H'.1
+  let toCyc : A → CycSub E₀ N := fun T => ⟨AddSubgroup.zmultiples T.1, T.1, T.2, rfl⟩
+  let gen : CycSub E₀ N → A := fun H => ⟨H.2.choose, H.2.choose_spec.1⟩
+  have hgen : ∀ H : CycSub E₀ N, H.1 = AddSubgroup.zmultiples (gen H).1 :=
+    fun H => H.2.choose_spec.2
+  have hf : ∀ T T' : A, R T T' → Quot.mk S (toCyc T) = Quot.mk S (toCyc T') := by
+    rintro T T' ⟨γ, hγ, k, hk, hheq⟩
+    obtain ⟨g', hg'⟩ := exists_heq (V' := E₀.toAffine) hγ.symm (Point.vcInvFun γ E₀.toAffine T.1)
+    have hT' : T'.1 = k • g' :=
+      eq_of_heq (hheq.trans (ModularCurve.Point.heq_nsmul hγ.symm k hg').symm)
+    have hord : addOrderOf g' = N :=
+      (addOrderOf_eq_of_heq hγ.symm hg').trans ((addOrderOf_vcInvFun γ _ T.1).trans T.2)
+    refine Quot.sound ⟨γ, hγ, T.1, g', rfl, ?_, hg'⟩
+    change AddSubgroup.zmultiples T'.1 = AddSubgroup.zmultiples g'
+    rw [hT']
+    exact zmultiples_nsmul_eq_of_coprime hord hk
+  have hg : ∀ H H' : CycSub E₀ N, S H H' → Quot.mk R (gen H) = Quot.mk R (gen H') := by
+    rintro H H' ⟨γ, hγ, a, a', hH, hH', hheq⟩
+    have ha : AddSubgroup.zmultiples a = AddSubgroup.zmultiples (gen H).1 := hH.symm.trans (hgen H)
+    have ha' : AddSubgroup.zmultiples a' = AddSubgroup.zmultiples (gen H').1 :=
+      hH'.symm.trans (hgen H')
+    have horda : addOrderOf a = N := (addOrderOf_eq_of_zmultiples_eq ha).trans (gen H).2
+    have horda' : addOrderOf a' = N := (addOrderOf_eq_of_zmultiples_eq ha').trans (gen H').2
+    obtain ⟨m, hm, hma⟩ := exists_coprime_nsmul_of_mem_zmultiples hN (gen H).2 horda
+      (ha.le (AddSubgroup.mem_zmultiples a))
+    obtain ⟨n, hn, hna⟩ := exists_coprime_nsmul_of_mem_zmultiples hN horda' (gen H').2
+      (ha'.ge (AddSubgroup.mem_zmultiples (gen H').1))
+    refine Quot.sound ⟨γ, hγ, n * m, Nat.coprime_mul_iff_left.mpr ⟨hn, hm⟩, ?_⟩
+    show HEq (gen H').1 ((n * m) • Point.vcInvFun γ E₀.toAffine (gen H).1)
+    rw [hna, ← smul_smul, ← vcInvFun_nsmul, ← hma]
+    exact ModularCurve.Point.heq_nsmul hγ.symm n hheq
+  refine Nat.card_congr
+    { toFun := Quot.lift (fun H => Quot.mk R (gen H)) hg
+      invFun := Quot.lift (fun T => Quot.mk S (toCyc T)) hf
+      left_inv := ?_
+      right_inv := ?_ }
+  · intro q
+    induction q using Quot.ind with
+    | _ H =>
+      change Quot.mk S (toCyc (gen H)) = Quot.mk S H
+      congr 1
+      exact Subtype.ext (hgen H).symm
+  · intro q
+    induction q using Quot.ind with
+    | _ T =>
+      change Quot.mk R (gen (toCyc T)) = Quot.mk R T
+      have hc : AddSubgroup.zmultiples T.1 = AddSubgroup.zmultiples (gen (toCyc T)).1 :=
+        hgen (toCyc T)
+      obtain ⟨m, hm, hmT⟩ := exists_coprime_nsmul_of_mem_zmultiples hN T.2 (gen (toCyc T)).2
+        (hc.ge (AddSubgroup.mem_zmultiples (gen (toCyc T)).1))
+      refine (Quot.sound ⟨1, one_smul _ E₀, m, hm, ?_⟩).symm
+      change HEq (gen (toCyc T)).1 (m • Point.vcInvFun 1 E₀.toAffine T.1)
+      rw [hmT]
+      exact ModularCurve.Point.heq_nsmul (one_smul _ E₀).symm m (vcInvFun_one_heq E₀.toAffine
+        T.1).symm
+
+end S_ModularCurve_natCard_quot_sameOrbit_cycSub_eq_natCard_moduliPoint_j_eq
+end P2MW
+export P2MW.S_ModularCurve_natCard_quot_sameOrbit_cycSub_eq_natCard_moduliPoint_j_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.natCard_quot_sameOrbit_cycSub_eq_natCard_moduliPoint_j_eq (N : ℕ) [NeZero N]
+    (E₀ : WeierstrassCurve (AlgebraicClosure ℚ)) [E₀.IsElliptic] :
+    Nat.card (Quot (fun H H' : ModularCurve.CycSub E₀ N => ModularCurve.SameOrbit E₀ H.1 H'.1))
+      = Nat.card {x : ModularCurve.ModuliPoint N (AlgebraicClosure ℚ) // ModularCurve.ModuliPoint.j
+        x = E₀.j} :=
+  solution N E₀
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_neg_width_le_ord_of_order_eq_mul_ord_of_qExpansion_slash.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_neg_width_le_ord_of_order_eq_mul_ord_of_qExpansion_slash.lean
new file mode 100644
index 0000000000..4cb363b59c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_neg_width_le_ord_of_order_eq_mul_ord_of_qExpansion_slash.lean
@@ -0,0 +1,449 @@
+/-
+Based on Prove2Me node ModularCurve.neg_width_le_ord_of_order_eq_mul_ord_of_qExpansion_slash
+(4093daea-d82a-5454-a50b-37a48e45b108) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c2314ac3-a44b-5672-9928-2ee3729dcb03
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import Mathlib.NumberTheory.ModularForms.NormTrace
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_forall_ord_eq_finset
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_qExpansion_coeff_mul_width
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Lower bound -h ≤ ord_P(j) at a cusp place
+
+Theorem statement: `ModularCurve.neg_width_le_ord_of_order_eq_mul_ord_of_qExpansion_slash`
+(`4093daea-d82a-5454-a50b-37a48e45b108`), by Claude, 2026-09-05.
+
+Proof: submission `c2314ac3-a44b-5672-9928-2ee3729dcb03`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a finite-index subgroup of $\mathrm{SL}_2(\mathbb Z)$ containing the translation $T$
+and satisfying `IsCongruenceSubgroup`, and write $N$ for the index of the normal core of $\Gamma$.
+Let $F_0$ be an intermediate field of $\mathbb Q \subset \mathbb Q((q))$ equal to
+[`ModularCurve.qExpFunctionFieldC ℚ Γ`](def/ModularCurve_X1.html#L101), i.e. the subfield generated
+over $\mathbb Q$ by the quotients of the integral $q$-expansion series attached to pairs of modular
+forms of one and the same weight $k$ on $\Gamma$ admitting integral $q$-expansions, with nonzero
+denominator series; let $F =$ `laurentBaseChange ℂ F₀` be the intermediate field of $\mathbb C
+\subset \mathbb C((q))$ generated by the coefficientwise image of $F_0$. Let $y \in F$ have
+underlying Laurent series `jqModC ℂ`, that is $q^{-1}$ times the image of the power series
+$E_4^3\cdot(\text{inverse }\eta\text{-unit})$. Let $\sigma \in \mathrm{SL}_2(\mathbb Z)$, let $\Phi
+\colon F \to \mathbb C((q))$ be a ring homomorphism, let $P$ be a place of $F$ over $\mathbb C$ (a
+proper valuation subring containing $\mathbb C$ whose ideals are principal), and let $e$ be a
+positive natural number. Assume: (i) compatibility of $\Phi$ with presentations by modular forms,
+namely for all $x \in F$, all $k \in \mathbb Z$ and all weight-$k$ modular forms $g,h$ on $\Gamma$
+with $h \ne 0$, if $x$ times the width-$1$ $q$-expansion of $h$ equals that of $g$, then $\Phi x$
+times the width-$N$ $q$-expansion of $h\mid_k\sigma$ equals the width-$N$ $q$-expansion of
+$g\mid_k\sigma$; (ii) $(\Phi x).\mathrm{order} = e\cdot \operatorname{ord}_P(x)$ for every $x \ne
+0$; (iii) $(\Phi y).\mathrm{order} = -N$. Then for every positive natural number $h$ with $\sigma
+T^h \sigma^{-1} \in \Gamma \sqcup \langle -1\rangle$ one has $-h \le \operatorname{ord}_P(y)$.
+
+This is one half of the computation of the order of the $j$-invariant at the place of the function
+field of $X(\Gamma)$ corresponding to the cusp $\sigma\infty$: the bound holds for any period $h$ of
+that cusp in $\pm\Gamma$, with no minimality or degree condition imposed. It is used by
+[`ModularCurve.ord_eq_neg_width_of_order_eq_mul_ord_of_qExpansion_slash`]
+(thm.html#ModularCurve.ord_eq_neg_width_of_order_eq_mul_ord_of_qExpansion_slash),
+where the matching upper bound turns it into the equality $\operatorname{ord}_P(y) = -h$ for the
+exact cusp width.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_neg_width_le_ord_of_order_eq_mul_ord_of_qExpansion_slash.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_neg_width_le_ord_of_order_eq_mul_ord_of_qExpansion_slash
+
+open CongruenceSubgroup ModularCurve
+open scoped MatrixGroups ModularForm
+
+noncomputable section
+
+namespace WidthLE
+
+p2m_open "UpperHalfPlane ModularForm Filter Function Complex Function.Complex \
+  Matrix.SpecialLinearGroup OnePoint"
+open scoped Topology Pointwise Manifold
+
+theorem coe_eq_mapGL (γ : SL(2, ℤ)) : (γ : GL (Fin 2) ℝ) = mapGL ℝ γ := rfl
+
+theorem mapGL_T_zpow (n : ℕ) :
+    mapGL ℝ (ModularGroup.T ^ (n : ℤ)) = Matrix.GeneralLinearGroup.upperRightHom (n : ℝ) := by
+  have hmat : ((ModularGroup.T ^ (n : ℤ) : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) =
+      !![1, (n : ℤ); 0, 1] := ModularGroup.coe_T_zpow (n : ℤ)
+  rw [Units.ext_iff]
+  have hval : (↑(mapGL ℝ (ModularGroup.T ^ (n : ℤ))) : Matrix (Fin 2) (Fin 2) ℝ) =
+      (!![1, (n : ℤ); 0, 1]).map (Int.cast : ℤ → ℝ) := by
+    rw [← hmat]; rfl
+  rw [hval]
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp [Matrix.GeneralLinearGroup.upperRightHom]
+
+theorem natCast_mem_strictPeriods_of_conj_mem (Δ : Subgroup SL(2, ℤ)) (σ : SL(2, ℤ)) (n : ℕ)
+    (hn : σ * ModularGroup.T ^ n * σ⁻¹ ∈ Δ) :
+    (n : ℝ) ∈ Subgroup.strictPeriods
+      (ConjAct.toConjAct ((σ : GL (Fin 2) ℝ))⁻¹ • ((Δ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2)
+        ℝ))) := by
+  rw [Subgroup.mem_strictPeriods_iff, map_inv, Subgroup.mem_inv_pointwise_smul_iff,
+    ConjAct.toConjAct_smul, ← mapGL_T_zpow n, coe_eq_mapGL, ← map_inv, ← map_mul, ← map_mul]
+  refine Subgroup.mem_map_of_mem _ ?_
+  rwa [zpow_natCast]
+
+theorem one_mem_strictPeriods (Γ : Subgroup SL(2, ℤ)) (hT : ModularGroup.T ∈ Γ) :
+    (1 : ℝ) ∈ ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  rw [Subgroup.mem_strictPeriods_iff]
+  have h1 : Matrix.GeneralLinearGroup.upperRightHom (1 : ℝ) = mapGL ℝ ModularGroup.T := by
+    rw [← Nat.cast_one, ← mapGL_T_zpow 1]; simp
+  rw [h1]
+  exact Subgroup.mem_map_of_mem _ hT
+
+theorem conj_T_pow_index_mem (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (σ : SL(2, ℤ)) :
+    σ * ModularGroup.T ^ Γ.normalCore.index * σ⁻¹ ∈ Γ := by
+  have h1 : ModularGroup.T ^ Γ.normalCore.index ∈ Γ.normalCore :=
+    Subgroup.pow_index_mem Γ.normalCore ModularGroup.T
+  exact Subgroup.normalCore_le Γ ((Subgroup.normalCore_normal Γ).conj_mem _ h1 σ)
+
+def stab (k : ℤ) (F : ℍ → ℂ) : Subgroup SL(2, ℤ) where
+  carrier := {γ | F ∣[k] γ = F}
+  mul_mem' := by
+    intro a b ha hb
+    change F ∣[k] (a * b) = F
+    rw [SlashAction.slash_mul, ha, hb]
+  one_mem' := by
+    change F ∣[k] (1 : SL(2, ℤ)) = F
+    exact SlashAction.slash_one k F
+  inv_mem' := by
+    intro a ha
+    change F ∣[k] a⁻¹ = F
+    have h := congrArg (fun G : ℍ → ℂ => G ∣[k] a⁻¹) ha
+    simpa only [← SlashAction.slash_mul, mul_inv_cancel, SlashAction.slash_one] using h.symm
+
+theorem mem_stab_iff (k : ℤ) (F : ℍ → ℂ) (γ : SL(2, ℤ)) : γ ∈ stab k F ↔ F ∣[k] γ = F := Iff.rfl
+
+variable {Γ : Subgroup SL(2, ℤ)}
+
+theorem le_stab {k : ℤ} (G : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) : Γ ≤ stab k ⇑G := by
+  intro γ hγ
+  rw [mem_stab_iff, SL_slash]
+  exact SlashInvariantForm.slash_action_eqn G _ (Subgroup.mem_map_of_mem _ hγ)
+
+theorem neg_one_mem_stab {k : ℤ} (hk : Even k) (F : ℍ → ℂ) : (-1 : SL(2, ℤ)) ∈ stab k F := by
+  rw [mem_stab_iff]
+  funext τ
+  rw [SL_slash_apply, ModularGroup.SL_neg_smul, one_smul]
+  have hd : denom (Matrix.SpecialLinearGroup.toGL ((Matrix.SpecialLinearGroup.map (Int.castRingHom
+    ℝ))
+      (-1 : SL(2, ℤ)))) (τ : ℂ) = -1 := by
+    simp [denom]
+  rw [hd, Even.neg_one_zpow (Even.neg hk), mul_one]
+
+theorem sup_le_stab {k : ℤ} (hk : Even k) (G : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) :
+    Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) ≤ stab k ⇑G :=
+  sup_le (le_stab G) ((Subgroup.zpowers_le).mpr (neg_one_mem_stab hk ⇑G))
+
+theorem slash_T_pow_eq {k : ℤ} (G : ℍ → ℂ) (σ : SL(2, ℤ)) (h : ℕ)
+    (hmem : σ * ModularGroup.T ^ h * σ⁻¹ ∈ stab k G) :
+    (G ∣[k] σ) ∣[k] (ModularGroup.T ^ h) = G ∣[k] σ := by
+  rw [mem_stab_iff] at hmem
+  have h1 : σ * ModularGroup.T ^ h = (σ * ModularGroup.T ^ h * σ⁻¹) * σ := by group
+  rw [← SlashAction.slash_mul, h1, SlashAction.slash_mul, hmem]
+
+theorem periodic_of_slash_T_pow_eq {k : ℤ} (F : ℍ → ℂ) (h : ℕ)
+    (hF : F ∣[k] (ModularGroup.T ^ h) = F) : Periodic (F ∘ ofComplex) (h : ℝ) := by
+  let Δ : Subgroup SL(2, ℤ) := Subgroup.zpowers (ModularGroup.T ^ h)
+  have hΔ : Δ ≤ stab k F := (Subgroup.zpowers_le).mpr hF
+  let S : SlashInvariantForm ((Δ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) k :=
+    SlashInvariantForm.mk F (by
+      intro γ hγ
+      obtain ⟨δ, hδ, rfl⟩ := Subgroup.mem_map.mp hγ
+      have := hΔ hδ
+      rw [mem_stab_iff, SL_slash] at this
+      exact this)
+  have hper : (h : ℝ) ∈ ((Δ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+    have := natCast_mem_strictPeriods_of_conj_mem Δ 1 h
+      (by simpa only [one_mul, inv_one, mul_one] using Subgroup.mem_zpowers (ModularGroup.T ^ h))
+    simpa using this
+  exact SlashInvariantFormClass.periodic_comp_ofComplex S hper
+
+variable [Γ.FiniteIndex]
+
+omit [Γ.FiniteIndex] in
+theorem coe_translate_SL {k : ℤ} (g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (σ : SL(2, ℤ)) :
+    ⇑(ModularForm.translate g (σ : GL (Fin 2) ℝ)) = ⇑g ∣[k] σ := by
+  rw [SL_slash]
+  exact ModularForm.coe_translate g _
+
+theorem slash_periodic_index {k : ℤ} (g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (σ : SL(2, ℤ)) :
+    Periodic ((⇑g ∣[k] σ) ∘ ofComplex) (Γ.normalCore.index : ℝ) := by
+  rw [← coe_translate_SL g σ]
+  exact SlashInvariantFormClass.periodic_comp_ofComplex
+    (ModularForm.translate g (σ : GL (Fin 2) ℝ))
+    (natCast_mem_strictPeriods_of_conj_mem Γ σ _ (conj_T_pow_index_mem Γ σ))
+
+omit [Γ.FiniteIndex] in
+theorem slash_mdiff {k : ℤ} (g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (σ : SL(2, ℤ)) :
+    MDiff (⇑g ∣[k] σ) := by
+  rw [← coe_translate_SL g σ]
+  exact ModularFormClass.holo _
+
+theorem index_pos : (0 : ℝ) < (Γ.normalCore.index : ℝ) := by
+  exact_mod_cast Nat.pos_of_ne_zero Subgroup.FiniteIndex.index_ne_zero
+
+theorem slash_bddAtImInfty {k : ℤ} (g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (σ : SL(2, ℤ))
+    :
+    IsBoundedAtImInfty (⇑g ∣[k] σ) := by
+  have hFact : Fact (IsCusp ∞ (ConjAct.toConjAct ((σ : GL (Fin 2) ℝ))⁻¹ •
+      ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)))) :=
+    ⟨Subgroup.isCusp_of_mem_strictPeriods index_pos
+      (natCast_mem_strictPeriods_of_conj_mem Γ σ _ (conj_T_pow_index_mem Γ σ))⟩
+  have h := ModularFormClass.bdd_at_infty (f := ModularForm.translate g (σ : GL (Fin 2) ℝ))
+  rwa [coe_translate_SL] at h
+
+theorem qExpansion_slash_ne_zero {k : ℤ} (h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (σ : SL(2, ℤ)) (hh : h ≠ 0) :
+    qExpansion (Γ.normalCore.index : ℝ) (⇑h ∣[k] σ) ≠ 0 := by
+  rw [Ne, qExpansion_eq_zero_iff index_pos (slash_periodic_index h σ) (slash_mdiff h σ)
+    (slash_bddAtImInfty h σ)]
+  intro h0
+  apply hh
+  have h1 : ⇑h = (0 : ℍ → ℂ) := by
+    have h2 := congrArg (· ∣[k] (σ⁻¹ : SL(2, ℤ))) h0
+    simpa only [SL_slash, ← SlashAction.slash_mul, ← map_mul, mul_inv_cancel, map_one,
+      SlashAction.slash_one, SlashAction.zero_slash] using h2
+  ext τ
+  rw [h1]
+  rfl
+
+theorem dvd_order_coe {p : PowerSeries ℂ} (hp : p ≠ 0) (m : ℕ)
+    (hcoeff : ∀ i : ℕ, ¬ m ∣ i → PowerSeries.coeff i p = 0) :
+    (m : ℤ) ∣ (p : LaurentSeries ℂ).order := by
+  have hp' : (p : LaurentSeries ℂ) ≠ 0 := by
+    intro h0
+    apply hp
+    have : ((0 : PowerSeries ℂ) : LaurentSeries ℂ) = (p : LaurentSeries ℂ) := by rw [h0]; simp
+    exact (HahnSeries.ofPowerSeries_injective this).symm
+  have hne := (HahnSeries.coeff_order_eq_zero.not.mpr) hp'
+  rw [PowerSeries.coeff_coe] at hne
+  split_ifs at hne with hneg
+  · exact absurd rfl hne
+  · have hdvd : m ∣ ((p : LaurentSeries ℂ).order).natAbs := by
+      by_contra hnd
+      exact hne (hcoeff _ hnd)
+    have h0 : 0 ≤ (p : LaurentSeries ℂ).order := not_lt.mp hneg
+    rw [← Int.natAbs_of_nonneg h0]
+    exact Int.natCast_dvd_natCast.mpr hdvd
+
+theorem dvd_order_qExpansion {F : ℍ → ℂ} {N : ℕ} (hN : 0 < N) (h : ℕ) (hh : 0 < h)
+    (pN : Periodic (F ∘ ofComplex) (N : ℝ)) (ph : Periodic (F ∘ ofComplex) (h : ℝ))
+    (dF : MDiff F) (bF : IsBoundedAtImInfty F) (hF0 : qExpansion (N : ℝ) F ≠ 0) :
+    ((N / Nat.gcd h N : ℕ) : ℤ) ∣ ((qExpansion (N : ℝ) F : PowerSeries ℂ) : LaurentSeries ℂ).order
+      := by
+  set d := Nat.gcd h N with hd
+  have hdpos : 0 < d := Nat.gcd_pos_of_pos_left N hh
+  have hdN : d ∣ N := Nat.gcd_dvd_right h N
+  set m := N / d with hm
+  have hmpos : 0 < m := Nat.div_pos (Nat.le_of_dvd hN hdN) hdpos
+  have hmd : (m : ℝ) * (d : ℝ) = (N : ℝ) := by
+    rw [← Nat.cast_mul, Nat.div_mul_cancel hdN]
+  have pd : Periodic (F ∘ ofComplex) (d : ℝ) := by
+    have p1 := (ph.int_mul (Nat.gcdA h N)).add_period (pN.int_mul (Nat.gcdB h N))
+    have hbez : ((d : ℤ) : ℂ) = ((h * Nat.gcdA h N + N * Nat.gcdB h N : ℤ) : ℂ) := by
+      have := Nat.gcd_eq_gcd_ab h N
+      rw [← hd] at this
+      exact_mod_cast congrArg (Int.cast : ℤ → ℂ) this
+    have heq : ((Nat.gcdA h N : ℤ) : ℂ) * ((h : ℝ) : ℂ) + ((Nat.gcdB h N : ℤ) : ℂ) * ((N : ℝ) : ℂ) =
+        ((d : ℝ) : ℂ) := by
+      push_cast at hbez ⊢
+      linear_combination -hbez
+    rw [heq] at p1
+    exact p1
+  apply dvd_order_coe hF0 m
+  intro i hi
+  have key :=
+    UpperHalfPlane.qExpansion_coeff_mul_width F (d : ℝ) (by exact_mod_cast hdpos) pd dF bF m hmpos i
+  rw [hmd] at key
+  rw [key, ite_eq_right hi]
+
+theorem dvd_order_qExpansion_slash {k : ℤ} (hk : Even k)
+    (G : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (σ : SL(2, ℤ))
+    (hG : qExpansion (Γ.normalCore.index : ℝ) (⇑G ∣[k] σ) ≠ 0)
+    (h : ℕ) (hh : 0 < h)
+    (hmem : σ * ModularGroup.T ^ h * σ⁻¹ ∈ Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))) :
+    ((Γ.normalCore.index / Nat.gcd h Γ.normalCore.index : ℕ) : ℤ) ∣
+      ((qExpansion (Γ.normalCore.index : ℝ) (⇑G ∣[k] σ) : PowerSeries ℂ) : LaurentSeries ℂ).order
+        := by
+  have ph : Periodic ((⇑G ∣[k] σ) ∘ ofComplex) (h : ℝ) :=
+    periodic_of_slash_T_pow_eq _ h (slash_T_pow_eq ⇑G σ h (sup_le_stab hk G hmem))
+  exact dvd_order_qExpansion (Nat.pos_of_ne_zero Subgroup.FiniteIndex.index_ne_zero) h hh
+    (slash_periodic_index G σ) ph (slash_mdiff G σ) (slash_bddAtImInfty G σ) hG
+
+end WidthLE
+
+end
+
+open WidthLE UpperHalfPlane in
+theorem solution
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (hF : F₀ = ModularCurve.qExpFunctionFieldC ℚ Γ)
+    (y : ↥(ModularCurve.laurentBaseChange ℂ F₀))
+    (σ : SL(2, ℤ))
+    (Φ : ModularCurve.laurentBaseChange ℂ F₀ →+* LaurentSeries ℂ)
+    (P : AlgebraicCurve.Place ℂ (ModularCurve.laurentBaseChange ℂ F₀)) (e : ℕ) (he : 0 < e)
+    (hpres : ∀ (x : ModularCurve.laurentBaseChange ℂ F₀) (k : ℤ)
+          (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k), h ≠ 0 →
+        (x : LaurentSeries ℂ) *
+            ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries
+              ℂ) =
+          ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+            →
+        Φ x * ((UpperHalfPlane.qExpansion (Γ.normalCore.index : ℝ)
+              ((h : UpperHalfPlane → ℂ) ∣[k] σ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+          ((UpperHalfPlane.qExpansion (Γ.normalCore.index : ℝ)
+              ((g : UpperHalfPlane → ℂ) ∣[k] σ) : PowerSeries ℂ) : LaurentSeries ℂ))
+    (hord : ∀ x : ModularCurve.laurentBaseChange ℂ F₀, x ≠ 0 → (Φ x).order = e * P.ord x)
+    (hyo : (Φ y).order = -(Γ.normalCore.index : ℤ))
+    (h : ℕ) (hh : 0 < h)
+    (hmem : σ * ModularGroup.T ^ h * σ⁻¹ ∈ Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))) :
+    -(h : ℤ) ≤ P.ord y := by
+  classical
+  set N : ℕ := Γ.normalCore.index with hNdef
+  have hNpos : 0 < N := Nat.pos_of_ne_zero Subgroup.FiniteIndex.index_ne_zero
+  set d : ℕ := Nat.gcd h N with hddef
+  have hdpos : 0 < d := Nat.gcd_pos_of_pos_left N hh
+  have hdN : d ∣ N := Nat.gcd_dvd_right h N
+  have hdh : d ≤ h := Nat.le_of_dvd hh (Nat.gcd_dvd_left h N)
+  set m : ℕ := N / d with hmdef
+  have hmpos : 0 < m := Nat.div_pos (Nat.le_of_dvd hNpos hdN) hdpos
+  have h1 : (1 : ℝ) ∈ ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)).strictPeriods :=
+    one_mem_strictPeriods Γ hT
+  have key : ∀ x : ↥(ModularCurve.laurentBaseChange ℂ F₀), x ≠ 0 → (m : ℤ) ∣ (Φ x).order := by
+    intro x hx
+    obtain ⟨k, g, h₁, hh₁, hxgh⟩ :=
+      ModularCurve.exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC
+        Γ hT
+        (x : LaurentSeries ℂ) (by rw [← hF]; exact x.2)
+    have hH : h₁.mul h₁ ≠ 0 := by
+      intro h0
+      apply hh₁
+      have hc : ⇑(h₁.mul h₁) = 0 := by rw [h0]; rfl
+      rw [ModularForm.coe_mul] at hc
+      apply DFunLike.ext
+      intro τ
+      have := congrFun hc τ
+      simp only [Pi.mul_apply, Pi.zero_apply, mul_self_eq_zero] at this
+      simpa using this
+    have hxGH : (x : LaurentSeries ℂ) *
+        ((qExpansion 1 (⇑(h₁.mul h₁)) : PowerSeries ℂ) : LaurentSeries ℂ) =
+        ((qExpansion 1 (⇑(g.mul h₁)) : PowerSeries ℂ) : LaurentSeries ℂ) := by
+      rw [ModularForm.qExpansion_mul one_pos h1, ModularForm.qExpansion_mul one_pos h1, map_mul,
+        map_mul,
+        ← mul_assoc, hxgh]
+    have e1 := hpres x (k + k) (g.mul h₁) (h₁.mul h₁) hH hxGH
+    set A := ((qExpansion (N : ℝ) (⇑(g.mul h₁) ∣[k + k] σ) : PowerSeries ℂ) : LaurentSeries ℂ) with
+      hA
+    set B := ((qExpansion (N : ℝ) (⇑(h₁.mul h₁) ∣[k + k] σ) : PowerSeries ℂ) : LaurentSeries ℂ) with
+      hB
+    have hBq : qExpansion (N : ℝ) (⇑(h₁.mul h₁) ∣[k + k] σ) ≠ 0 :=
+      qExpansion_slash_ne_zero (h₁.mul h₁) σ hH
+    have hB0 : B ≠ 0 := by
+      intro h0
+      exact hBq (HahnSeries.ofPowerSeries_injective
+        (h0.trans (map_zero (HahnSeries.ofPowerSeries ℤ ℂ)).symm))
+    have hΦx : Φ x ≠ 0 := (map_ne_zero Φ).mpr hx
+    have hA0 : A ≠ 0 := by rw [← e1]; exact mul_ne_zero hΦx hB0
+    have hAq : qExpansion (N : ℝ) (⇑(g.mul h₁) ∣[k + k] σ) ≠ 0 := by
+      intro h0
+      apply hA0
+      rw [hA, h0, map_zero]
+    have hk2 : Even (k + k) := ⟨k, rfl⟩
+    have dA : (m : ℤ) ∣ A.order := dvd_order_qExpansion_slash hk2 (g.mul h₁) σ hAq h hh hmem
+    have dB : (m : ℤ) ∣ B.order := dvd_order_qExpansion_slash hk2 (h₁.mul h₁) σ hBq h hh hmem
+    have hord' : (Φ x).order = A.order - B.order := by
+      have := HahnSeries.order_mul hΦx hB0
+      rw [e1] at this
+      linarith
+    rw [hord']
+    exact dvd_sub dA dB
+  obtain ⟨g₀, hg₀, hg₀1⟩ :=
+    AlgebraicCurve.Place.exists_forall_ord_eq_finset ({P} : Finset _) (fun _ => (1 : ℤ))
+  have hP1 : P.ord g₀ = 1 := hg₀1 P (Finset.mem_singleton_self P)
+  have dme : (m : ℤ) ∣ (e : ℤ) := by
+    have := key g₀ hg₀
+    rwa [hord g₀ hg₀, hP1, mul_one] at this
+  have hy0 : y ≠ 0 := by
+    intro h0
+    rw [h0, map_zero, HahnSeries.order_zero] at hyo
+    have : (Γ.normalCore.index : ℤ) = 0 := by linarith
+    exact Subgroup.FiniteIndex.index_ne_zero (by exact_mod_cast this)
+  have ey : (e : ℤ) * P.ord y = -(N : ℤ) := by rw [← hord y hy0, hyo]
+  obtain ⟨c, hc⟩ := dme
+  have hmdN : (m : ℤ) * (d : ℤ) = (N : ℤ) := by exact_mod_cast Nat.div_mul_cancel hdN
+  have hm0 : (m : ℤ) ≠ 0 := by exact_mod_cast hmpos.ne'
+  have hcpos : 0 < c := by
+    have he' : (0 : ℤ) < e := by exact_mod_cast he
+    rw [hc] at he'
+    exact pos_of_mul_pos_right he' (by exact_mod_cast hmpos.le)
+  have hcd : c * P.ord y = -(d : ℤ) := by
+    have : (m : ℤ) * (c * P.ord y) = (m : ℤ) * (-(d : ℤ)) := by
+      rw [← mul_assoc, ← hc, ey, ← hmdN]; ring
+    exact mul_left_cancel₀ hm0 this
+  have hdh' : (d : ℤ) ≤ (h : ℤ) := by exact_mod_cast hdh
+  nlinarith [hcd, hcpos, hdh']
+
+end S_ModularCurve_neg_width_le_ord_of_order_eq_mul_ord_of_qExpansion_slash
+end P2MW
+export P2MW.S_ModularCurve_neg_width_le_ord_of_order_eq_mul_ord_of_qExpansion_slash (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open CongruenceSubgroup ModularCurve
+open scoped MatrixGroups ModularForm
+theorem ModularCurve.neg_width_le_ord_of_order_eq_mul_ord_of_qExpansion_slash
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (hF : F₀ = ModularCurve.qExpFunctionFieldC ℚ Γ)
+    (y : ↥(ModularCurve.laurentBaseChange ℂ F₀))
+    (σ : SL(2, ℤ))
+    (Φ : ModularCurve.laurentBaseChange ℂ F₀ →+* LaurentSeries ℂ)
+    (P : AlgebraicCurve.Place ℂ (ModularCurve.laurentBaseChange ℂ F₀)) (e : ℕ) (he : 0 < e)
+    (hpres : ∀ (x : ModularCurve.laurentBaseChange ℂ F₀) (k : ℤ)
+          (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k), h ≠ 0 →
+        (x : LaurentSeries ℂ) *
+            ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries
+              ℂ) =
+          ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+            →
+        Φ x * ((UpperHalfPlane.qExpansion (Γ.normalCore.index : ℝ)
+              ((h : UpperHalfPlane → ℂ) ∣[k] σ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+          ((UpperHalfPlane.qExpansion (Γ.normalCore.index : ℝ)
+              ((g : UpperHalfPlane → ℂ) ∣[k] σ) : PowerSeries ℂ) : LaurentSeries ℂ))
+    (hord : ∀ x : ModularCurve.laurentBaseChange ℂ F₀, x ≠ 0 → (Φ x).order = e * P.ord x)
+    (hyo : (Φ y).order = -(Γ.normalCore.index : ℤ))
+    (h : ℕ) (hh : 0 < h)
+    (hmem : σ * ModularGroup.T ^ h * σ⁻¹ ∈ Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))) :
+    -(h : ℤ) ≤ P.ord y :=
+  solution Γ hT F₀ hF y σ Φ P e he hpres hord hyo h hh hmem
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_nonempty_equiv_place_pos_ord_algHom_integralClosure.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_nonempty_equiv_place_pos_ord_algHom_integralClosure.lean
new file mode 100644
index 0000000000..b11c1471c9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_nonempty_equiv_place_pos_ord_algHom_integralClosure.lean
@@ -0,0 +1,533 @@
+/-
+Based on Prove2Me node ModularCurve.nonempty_equiv_place_pos_ord_algHom_integralClosure
+(ee6735cc-15b3-56bb-8efa-bf09c992b0b5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 410eb469-afcc-58a1-8117-0aa576b00aa6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_MazurStepThreeInputs
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_laurentBaseChange_modularFunctionFieldFull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_pos
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_coeffEmb_jq
+import Mathlib.FieldTheory.Relrank
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Algebra
+import Mathlib.FieldTheory.Perfect
+import Mathlib.FieldTheory.IsAlgClosed.Basic
+import Mathlib.RingTheory.DedekindDomain.IntegralClosure
+import Mathlib.RingTheory.DedekindDomain.AdicValuation
+import Mathlib.RingTheory.Localization.Integral
+import Mathlib.RingTheory.Adjoin.Polynomial.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Places above a finite j-value as ℚ̄-points of the coordinate ring
+
+Theorem statement: `ModularCurve.nonempty_equiv_place_pos_ord_algHom_integralClosure`
+(`ee6735cc-15b3-56bb-8efa-bf09c992b0b5`), by Claude, 2026-09-05.
+
+Proof: submission `410eb469-afcc-58a1-8117-0aa576b00aa6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N \geq 1$ and write $\bar F_N$ for `modularFunctionFieldBar N`, the subextension of
+$\bar{\mathbb{Q}}((q))$ over $\bar{\mathbb{Q}}$ generated by the coefficientwise images of the
+elements of the subfield of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by the divisor expansions
+of level $N$; let $\bar\jmath =$ `jBar N` be the element of $\bar F_N$ given by the $q$-expansion of
+the $j$-function. Let $j_0 \in \bar{\mathbb{Q}}$, and assume that every place of $\bar F_N$ over
+$\bar{\mathbb{Q}}$ — a proper valuation subring of $\bar F_N$ containing $\bar{\mathbb{Q}}$ and
+which is a principal ideal ring — has degree one, i.e. its residue field has
+$\bar{\mathbb{Q}}$-dimension $1$. Let $A_N$ denote the integral closure of
+$\bar{\mathbb{Q}}[\bar\jmath] =$ `Algebra.adjoin (AlgebraicClosure ℚ) {jBar N}` in $\bar F_N$. Then
+the type of bijections between the set of places $v$ of $\bar F_N$ over $\bar{\mathbb{Q}}$ with
+$\operatorname{ord}_v(\bar\jmath - j_0) > 0$, where $\operatorname{ord}_v$ is minus the logarithm of
+the associated $\mathbb{Z}^{m0}$-valued adic valuation, and the set of $\bar{\mathbb{Q}}$-algebra
+homomorphisms $\psi : A_N \to \bar{\mathbb{Q}}$ with $\psi(\bar\jmath) = j_0$ is nonempty. Only the
+existence of such a bijection is asserted, not a particular one.
+
+This is the dictionary between the places of the affine modular curve $X_0(N)$ minus its cusps and
+the maximal ideals of its coordinate ring, restricted to the fibre over a given value $j_0$ of the
+$j$-function. It is used in the counts of the places at which $\bar\jmath$ or $\bar\jmath - 1728$
+has order exactly one, which produce the quantities $\nu_3$ and $\nu_2$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_nonempty_equiv_place_pos_ord_algHom_integralClosure.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+open AlgebraicCurve Place
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_nonempty_equiv_place_pos_ord_algHom_integralClosure
+
+
+noncomputable section
+
+p2m_open "AlgebraicCurve ModularCurve \
+  P2MW.S_ModularCurve_nonempty_equiv_place_pos_ord_algHom_integralClosure.ModularCurve \
+  IsDedekindDomain"
+
+namespace B2Places
+
+section General
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+variable (K) in
+abbrev normalization (t : F) : Subalgebra (Algebra.adjoin K ({t} : Set F)) F :=
+  integralClosure (Algebra.adjoin K ({t} : Set F)) F
+
+scoped instance instIsPrincipalIdealRingAdjoinSingleton (t : F) :
+    IsPrincipalIdealRing (Algebra.adjoin K ({t} : Set F)) := by
+  have hmem : ∀ p : Polynomial K, Polynomial.aeval t p ∈ Algebra.adjoin K ({t} : Set F) := by
+    intro p
+    rw [Algebra.adjoin_singleton_eq_range_aeval]
+    exact ⟨p, rfl⟩
+  refine IsPrincipalIdealRing.of_surjective
+    ((Polynomial.aeval t).codRestrict (Algebra.adjoin K ({t} : Set F)) hmem) ?_
+  rintro ⟨a, ha⟩
+  obtain ⟨p, hp⟩ : ∃ p : Polynomial K, Polynomial.aeval t p = a := by
+    rw [Algebra.adjoin_singleton_eq_range_aeval] at ha
+    exact (AlgHom.mem_range _).mp ha
+  exact ⟨p, Subtype.ext hp⟩
+
+def gen (t : F) : normalization K t :=
+  ⟨t, isIntegral_algebraMap (R := Algebra.adjoin K ({t} : Set F))
+    (x := (⟨t, Algebra.self_mem_adjoin_singleton K t⟩ : Algebra.adjoin K ({t} : Set F)))⟩
+
+@[scoped simp] theorem coe_gen (t : F) : ((gen (K := K) t : normalization K t) : F) = t := rfl
+
+@[scoped simp] theorem coe_algebraMap_normalization (t : F) (c : K) :
+    ((algebraMap K (normalization K t) c : normalization K t) : F) = algebraMap K F c :=
+  (IsScalarTower.algebraMap_apply K (normalization K t) F c).symm
+
+section Dedekind
+
+open scoped IntermediateField.algebraAdjoinAdjoin
+
+variable [CharZero K] (t : F) [FiniteDimensional (IntermediateField.adjoin K ({t} : Set F)) F]
+
+scoped instance instIsDedekindDomainNormalization : IsDedekindDomain (normalization K t) := by
+  have : CharZero (IntermediateField.adjoin K ({t} : Set F)) :=
+    charZero_of_injective_algebraMap (algebraMap K _).injective
+  exact integralClosure.isDedekindDomain (Algebra.adjoin K ({t} : Set F))
+    (IntermediateField.adjoin K ({t} : Set F)) F
+
+scoped instance instIsFractionRingNormalization : IsFractionRing (normalization K t) F :=
+  integralClosure.isFractionRing_of_finite_extension
+    (IntermediateField.adjoin K ({t} : Set F)) F
+
+end Dedekind
+
+
+theorem mem_of_ord_sub_pos (w : Place K F) {t : F} {c : K}
+    (h : 0 < w.ord (t - algebraMap K F c)) : t ∈ w.toValuationSubring := by
+  have hne : t - algebraMap K F c ≠ 0 := by
+    intro h0
+    rw [h0, Place.ord_zero] at h
+    exact lt_irrefl _ h
+  have hmem := mem_of_ord_nonneg w hne h.le
+  have := add_mem hmem (w.algebraMap_mem' c)
+  rwa [sub_add_cancel] at this
+
+theorem forall_mem_of_mem (t : F) (w : Place K F) (ht : t ∈ w.toValuationSubring)
+    (a : normalization K t) : (a : F) ∈ w.toValuationSubring := by
+  have hadj : ∀ x : F, x ∈ Algebra.adjoin K ({t} : Set F) → x ∈ w.toValuationSubring := by
+    intro x hx
+    refine Algebra.adjoin_induction (fun y hy => ?_) (fun c => w.algebraMap_mem' c)
+      (fun _ _ _ _ hx hy => add_mem hx hy) (fun _ _ _ _ hx hy => mul_mem hx hy) hx
+    rw [Set.mem_singleton_iff.mp hy]
+    exact ht
+  obtain ⟨P, hPmonic, hPeval⟩ : IsIntegral (Algebra.adjoin K ({t} : Set F)) (a : F) := a.2
+  refine w.mem_of_eval_monic_eq_zero (P := P.map (algebraMap _ F)) (hPmonic.map _)
+    (fun i => ?_) ?_
+  · rw [Polynomial.coeff_map]
+    exact hadj _ (P.coeff i).2
+  · rwa [Polynomial.eval_map]
+
+def evalHom (t : F) (w : Place K F) (hrat : w.IsRational) (ht : t ∈ w.toValuationSubring) :
+    normalization K t →ₐ[K] K where
+  toFun a := w.evalAt (a : F)
+  map_one' := by
+    change w.evalAt (1 : F) = 1
+    exact w.evalAt_one
+  map_mul' a b := by
+    apply w.algebraMap_residueField_injective
+    rw [map_mul, w.algebraMap_evalAt hrat (forall_mem_of_mem t w ht (a * b)),
+      w.algebraMap_evalAt hrat (forall_mem_of_mem t w ht a),
+      w.algebraMap_evalAt hrat (forall_mem_of_mem t w ht b), ← map_mul]
+    rfl
+  map_zero' := by
+    apply w.algebraMap_residueField_injective
+    rw [map_zero, w.algebraMap_evalAt hrat (forall_mem_of_mem t w ht 0)]
+    rfl
+  map_add' a b := by
+    apply w.algebraMap_residueField_injective
+    rw [map_add, w.algebraMap_evalAt hrat (forall_mem_of_mem t w ht (a + b)),
+      w.algebraMap_evalAt hrat (forall_mem_of_mem t w ht a),
+      w.algebraMap_evalAt hrat (forall_mem_of_mem t w ht b), ← map_add]
+    rfl
+  commutes' c := by
+    apply w.algebraMap_residueField_injective
+    rw [w.algebraMap_evalAt hrat (forall_mem_of_mem t w ht _)]
+    change IsLocalRing.residue w.toValuationSubring _ =
+      IsLocalRing.residue w.toValuationSubring (algebraMap K w.toValuationSubring c)
+    congr 1
+
+theorem evalHom_apply (t : F) (w : Place K F) (hrat : w.IsRational)
+    (ht : t ∈ w.toValuationSubring) (a : normalization K t) :
+    evalHom t w hrat ht a = w.evalAt (a : F) := rfl
+
+theorem evalHom_eq_iff (t : F) (w : Place K F) (hrat : w.IsRational)
+    (ht : t ∈ w.toValuationSubring) (a : normalization K t) (c : K) :
+    evalHom t w hrat ht a = c ↔
+      (⟨(a : F), forall_mem_of_mem t w ht a⟩ : w.toValuationSubring)
+          - algebraMap K w.toValuationSubring c ∈
+        IsLocalRing.maximalIdeal w.toValuationSubring := by
+  rw [← IsLocalRing.residue_eq_zero_iff, map_sub, sub_eq_zero, evalHom_apply,
+    ← w.algebraMap_evalAt hrat (forall_mem_of_mem t w ht a)]
+  constructor
+  · intro h
+    rw [h]
+    rfl
+  · intro h
+    have h' : algebraMap K w.ResidueField (w.evalAt (a : F)) = algebraMap K w.ResidueField c := h
+    exact w.algebraMap_residueField_injective h'
+
+theorem ord_pos_of_evalHom_eq (t : F) (w : Place K F) (hrat : w.IsRational)
+    (ht : t ∈ w.toValuationSubring) {a : normalization K t} {c : K}
+    (h : evalHom t w hrat ht a = c) (hne : (a : F) ≠ algebraMap K F c) :
+    0 < w.ord ((a : F) - algebraMap K F c) := by
+  have hmem : (a : F) - algebraMap K F c ∈ w.toValuationSubring :=
+    sub_mem (forall_mem_of_mem t w ht a) (w.algebraMap_mem' c)
+  rw [← w.mem_maximalIdeal_iff_ord_pos (sub_ne_zero.mpr hne) hmem]
+  have hcoe : (⟨(a : F) - algebraMap K F c, hmem⟩ : w.toValuationSubring) =
+      ⟨(a : F), forall_mem_of_mem t w ht a⟩ - algebraMap K w.toValuationSubring c :=
+    Subtype.ext (by simp)
+  rw [hcoe]
+  exact (evalHom_eq_iff t w hrat ht a c).mp h
+
+theorem evalHom_eq_of_ord_pos (t : F) (w : Place K F) (hrat : w.IsRational)
+    (ht : t ∈ w.toValuationSubring) {a : normalization K t} {c : K}
+    (h : 0 < w.ord ((a : F) - algebraMap K F c)) : evalHom t w hrat ht a = c := by
+  have hne : (a : F) - algebraMap K F c ≠ 0 := by
+    intro h0
+    rw [h0, Place.ord_zero] at h
+    exact lt_irrefl _ h
+  have hmem : (a : F) - algebraMap K F c ∈ w.toValuationSubring :=
+    sub_mem (forall_mem_of_mem t w ht a) (w.algebraMap_mem' c)
+  rw [← w.mem_maximalIdeal_iff_ord_pos hne hmem] at h
+  have hcoe : (⟨(a : F) - algebraMap K F c, hmem⟩ : w.toValuationSubring) =
+      ⟨(a : F), forall_mem_of_mem t w ht a⟩ - algebraMap K w.toValuationSubring c :=
+    Subtype.ext (by simp)
+  rw [hcoe] at h
+  exact (evalHom_eq_iff t w hrat ht a c).mpr h
+
+section Injective
+
+variable [CharZero K] (t : F) [FiniteDimensional (IntermediateField.adjoin K ({t} : Set F)) F]
+
+omit [CharZero K] [FiniteDimensional (IntermediateField.adjoin K ({t} : Set F)) F] in
+theorem mem_center_iff_evalHom_eq_zero (w : Place K F) (hrat : w.IsRational)
+    (ht : t ∈ w.toValuationSubring) (r : normalization K t) :
+    r ∈ Place.center (normalization K t) w (forall_mem_of_mem t w ht) ↔
+      evalHom t w hrat ht r = 0 := by
+  rw [Place.mem_center_iff, evalHom_eq_iff, map_zero, sub_zero]
+  rfl
+
+theorem eq_of_evalHom_eq {w₁ w₂ : Place K F} (h₁ : w₁.IsRational) (h₂ : w₂.IsRational)
+    (ht₁ : t ∈ w₁.toValuationSubring) (ht₂ : t ∈ w₂.toValuationSubring)
+    (h : evalHom t w₁ h₁ ht₁ = evalHom t w₂ h₂ ht₂) : w₁ = w₂ := by
+  have hc : Place.centerHeightOneSpectrum (normalization K t) w₁ (forall_mem_of_mem t w₁ ht₁) =
+      Place.centerHeightOneSpectrum (normalization K t) w₂ (forall_mem_of_mem t w₂ ht₂) := by
+    refine HeightOneSpectrum.ext (Ideal.ext fun r => ?_)
+    change r ∈ Place.center (normalization K t) w₁ (forall_mem_of_mem t w₁ ht₁) ↔
+      r ∈ Place.center (normalization K t) w₂ (forall_mem_of_mem t w₂ ht₂)
+    rw [mem_center_iff_evalHom_eq_zero t w₁ h₁ ht₁, mem_center_iff_evalHom_eq_zero t w₂ h₂ ht₂,
+      h]
+  apply Place.ext
+  rw [Place.toValuationSubring_eq_of_forall_mem (R := normalization K t) w₁
+      (fun a => forall_mem_of_mem t w₁ ht₁ a),
+    Place.toValuationSubring_eq_of_forall_mem (R := normalization K t) w₂
+      (fun a => forall_mem_of_mem t w₂ ht₂ a)]
+  exact congrArg (HeightOneSpectrum.valuationSubringAtPrime F) hc
+
+end Injective
+
+section Surjective
+
+variable [CharZero K] (t : F) (htr : Transcendental K t)
+  [FiniteDimensional (IntermediateField.adjoin K ({t} : Set F)) F]
+
+omit [CharZero K] [FiniteDimensional (IntermediateField.adjoin K ({t} : Set F)) F] in
+include htr in
+theorem ker_ne_bot (ψ : normalization K t →ₐ[K] K) : RingHom.ker ψ ≠ ⊥ := by
+  intro hbot
+  have hmem : gen t - algebraMap K (normalization K t) (ψ (gen t)) ∈ RingHom.ker ψ := by
+    rw [RingHom.mem_ker, map_sub, AlgHom.commutes, Algebra.algebraMap_self, RingHom.id_apply,
+      sub_self]
+  rw [hbot, Ideal.mem_bot, sub_eq_zero] at hmem
+  apply htr
+  have h1 : ((gen t : normalization K t) : F) =
+      ((algebraMap K (normalization K t) (ψ (gen t)) : normalization K t) : F) :=
+    congrArg (fun a : normalization K t => (a : F)) hmem
+  have hval : t = algebraMap K F (ψ (gen t)) :=
+    h1.trans (coe_algebraMap_normalization t _)
+  rw [hval]
+  exact isAlgebraic_algebraMap _
+
+def kerSpectrum (ψ : normalization K t →ₐ[K] K) : HeightOneSpectrum (normalization K t) :=
+  ⟨RingHom.ker ψ, RingHom.ker_isPrime ψ, ker_ne_bot t htr ψ⟩
+
+def placeOfHom (ψ : normalization K t →ₐ[K] K) : Place K F :=
+  Place.ofHeightOneSpectrum (K := K) (kerSpectrum t htr ψ)
+
+theorem coe_mem_placeOfHom (ψ : normalization K t →ₐ[K] K) (a : normalization K t) :
+    (a : F) ∈ (placeOfHom t htr ψ).toValuationSubring := by
+  change (a : F) ∈ ((kerSpectrum t htr ψ).valuation F).valuationSubring
+  rw [Valuation.mem_valuationSubring_iff]
+  exact (kerSpectrum t htr ψ).valuation_le_one a
+
+theorem mem_placeOfHom (ψ : normalization K t →ₐ[K] K) :
+    t ∈ (placeOfHom t htr ψ).toValuationSubring :=
+  coe_mem_placeOfHom t htr ψ (gen t)
+
+theorem mem_maximalIdeal_placeOfHom (ψ : normalization K t →ₐ[K] K) {r : normalization K t}
+    (hr : r ∈ RingHom.ker ψ) :
+    (⟨(r : F), coe_mem_placeOfHom t htr ψ r⟩ : (placeOfHom t htr ψ).toValuationSubring) ∈
+      IsLocalRing.maximalIdeal (placeOfHom t htr ψ).toValuationSubring := by
+  have hlt : (kerSpectrum t htr ψ).valuation F (r : F) < 1 :=
+    ((kerSpectrum t htr ψ).valuation_lt_one_iff_mem r).mpr hr
+  have hlt' :=
+    ((kerSpectrum t htr ψ).valuation F).isEquiv_valuation_valuationSubring.lt_one_iff_lt_one.mp hlt
+  exact (ValuationSubring.valuation_lt_one_iff _ _).mpr hlt'
+
+theorem evalHom_placeOfHom (ψ : normalization K t →ₐ[K] K) (hrat : (placeOfHom t htr ψ).IsRational)
+    :
+    evalHom t (placeOfHom t htr ψ) hrat (mem_placeOfHom t htr ψ) = ψ := by
+  ext a
+  rw [evalHom_eq_iff]
+  have hker : a - algebraMap K (normalization K t) (ψ a) ∈ RingHom.ker ψ := by
+    rw [RingHom.mem_ker, map_sub, AlgHom.commutes, Algebra.algebraMap_self, RingHom.id_apply,
+      sub_self]
+  have h := mem_maximalIdeal_placeOfHom t htr ψ hker
+  have hcoe : (⟨((a - algebraMap K (normalization K t) (ψ a) : normalization K t) : F),
+        coe_mem_placeOfHom t htr ψ _⟩ : (placeOfHom t htr ψ).toValuationSubring) =
+      ⟨(a : F), forall_mem_of_mem t _ (mem_placeOfHom t htr ψ) a⟩ -
+        algebraMap K (placeOfHom t htr ψ).toValuationSubring (ψ a) :=
+    Subtype.ext (by simp)
+  rwa [hcoe] at h
+
+end Surjective
+
+theorem isRational_of_deg_eq_one [IsAlgClosed K] (w : Place K F) (h : w.deg = 1) :
+    w.IsRational := by
+  have : Module.Finite K w.ResidueField := Module.finite_of_finrank_pos (by
+    change 0 < w.deg
+    omega)
+  have : Algebra.IsIntegral K w.ResidueField := Algebra.IsIntegral.of_finite K w.ResidueField
+  exact (IsAlgClosed.algebraMap_bijective_of_isIntegral (k := K) (K := w.ResidueField)).2
+
+section Dictionary
+
+variable [CharZero K] [IsAlgClosed K] (t : F) (htr : Transcendental K t)
+  [FiniteDimensional (IntermediateField.adjoin K ({t} : Set F)) F]
+  (hdeg : ∀ w : Place K F, w.deg = 1)
+
+def placesRegularEquiv :
+    {w : Place K F // t ∈ w.toValuationSubring} ≃ (normalization K t →ₐ[K] K) where
+  toFun w := evalHom t w.1 (isRational_of_deg_eq_one w.1 (hdeg w.1)) w.2
+  invFun ψ := ⟨placeOfHom t htr ψ, mem_placeOfHom t htr ψ⟩
+  left_inv w := Subtype.ext (eq_of_evalHom_eq t _ _ _ w.2
+    (evalHom_placeOfHom t htr _ (isRational_of_deg_eq_one _ (hdeg _))))
+  right_inv ψ := evalHom_placeOfHom t htr ψ _
+
+@[scoped simp] theorem placesRegularEquiv_apply (w : {w : Place K F // t ∈ w.toValuationSubring})
+    (a : normalization K t) :
+    placesRegularEquiv t htr hdeg w a = w.1.evalAt (a : F) := rfl
+
+def placesOverEquiv (c : K) :
+    {w : Place K F // 0 < w.ord (t - algebraMap K F c)} ≃
+      {ψ : normalization K t →ₐ[K] K // ψ (gen t) = c} :=
+  (Equiv.subtypeSubtypeEquivSubtype (p := fun w : Place K F => t ∈ w.toValuationSubring)
+      (q := fun w : Place K F => 0 < w.ord (t - algebraMap K F c))
+      (fun h => mem_of_ord_sub_pos _ h)).symm.trans
+    (Equiv.subtypeEquiv (placesRegularEquiv t htr hdeg) (fun w => by
+      constructor
+      · intro h
+        exact evalHom_eq_of_ord_pos t w.1 (isRational_of_deg_eq_one w.1 (hdeg w.1)) w.2
+          (a := gen t) h
+      · intro h
+        refine ord_pos_of_evalHom_eq t w.1 (isRational_of_deg_eq_one w.1 (hdeg w.1)) w.2
+          (a := gen t) h ?_
+        intro heq
+        exact htr (by rw [show t = algebraMap K F c from heq]; exact isAlgebraic_algebraMap _)))
+
+end Dictionary
+
+end General
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+scoped instance finiteDimensional_adjoin_jBar (N : ℕ) [NeZero N] :
+    FiniteDimensional
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)))
+      (modularFunctionFieldBar N) := by
+  have hcm : IntermediateField.comap (modularFunctionFieldBar N).val
+        (IntermediateField.adjoin (AlgebraicClosure ℚ)
+          ({((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))} :
+            Set (LaurentSeries (AlgebraicClosure ℚ))))
+      = IntermediateField.adjoin (AlgebraicClosure ℚ)
+          ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)) := by
+    rw [← IntermediateField.lift_adjoin_simple]
+    exact IntermediateField.comap_map (modularFunctionFieldBar N).val _
+  have h1 := IntermediateField.finrank_comap
+    (IntermediateField.adjoin (AlgebraicClosure ℚ)
+      ({((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))} :
+        Set (LaurentSeries (AlgebraicClosure ℚ))))
+    (modularFunctionFieldBar N).val
+  rw [hcm, IntermediateField.fieldRange_val] at h1
+  have h2 : IntermediateField.relfinrank
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))} :
+          Set (LaurentSeries (AlgebraicClosure ℚ))))
+      (modularFunctionFieldBar N) = dedekindPsi N := by
+    rw [← ModularCurve.relfinrank_full_eq_dedekindPsi N,
+      ← ModularCurve.relfinrank_laurentBaseChange_modularFunctionFieldFull (AlgebraicClosure ℚ) N]
+  have hpos : 0 < IntermediateField.relfinrank
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))} :
+          Set (LaurentSeries (AlgebraicClosure ℚ))))
+      (modularFunctionFieldBar N) := by
+    rw [h2]
+    exact ModularCurve.dedekindPsi_pos N (NeZero.ne N)
+  rw [← h1] at hpos
+  exact Module.finite_of_finrank_pos hpos
+
+end B2Places
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jBar modularFunctionFieldBar dedekindPsi \
+  relfinrank_laurentBaseChange_modularFunctionFieldFull relfinrank_full_eq_dedekindPsi \
+  dedekindPsi_pos transcendental_coeffEmb_jq"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+open B2Places in
+def ModularCurve.placesOverEquivAlgHom (N : ℕ) [NeZero N] (j₀ : AlgebraicClosure ℚ)
+    (hdeg : ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), w.deg = 1) :
+    {v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+        0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)} ≃
+      {ψ : normalization (AlgebraicClosure ℚ) (jBar N : modularFunctionFieldBar N)
+          →ₐ[AlgebraicClosure ℚ] AlgebraicClosure ℚ //
+        ψ (gen (jBar N : modularFunctionFieldBar N)) = j₀} :=
+  placesOverEquiv (jBar N : modularFunctionFieldBar N)
+    (ModularCurve.transcendental_coeffEmb_jq (AlgebraicClosure ℚ) N) hdeg j₀
+
+p2m_open_scoped "ModularCurve" in
+open B2Places in
+theorem ModularCurve.nonempty_equiv_place_pos_ord_algHom_normalization (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ)
+    (hdeg : ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), w.deg = 1) :
+    Nonempty ({v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+        0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)} ≃
+      {ψ : normalization (AlgebraicClosure ℚ) (jBar N : modularFunctionFieldBar N)
+          →ₐ[AlgebraicClosure ℚ] AlgebraicClosure ℚ //
+        ψ (gen (jBar N : modularFunctionFieldBar N)) = j₀}) :=
+  ⟨ModularCurve.placesOverEquivAlgHom N j₀ hdeg⟩
+
+p2m_open_scoped "ModularCurve" in
+open B2Places in
+private theorem ModularCurve.nonempty_equiv_place_pos_ord_algHom_integralClosure (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ)
+    (hdeg : ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), w.deg = 1) :
+    Nonempty ({v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+        0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)} ≃
+      {ψ : ↥(integralClosure
+            ↥(Algebra.adjoin (AlgebraicClosure ℚ)
+              ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)))
+            (modularFunctionFieldBar N)) →ₐ[AlgebraicClosure ℚ] AlgebraicClosure ℚ //
+        ψ (algebraMap
+            ↥(Algebra.adjoin (AlgebraicClosure ℚ)
+              ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)))
+            ↥(integralClosure
+              ↥(Algebra.adjoin (AlgebraicClosure ℚ)
+                ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)))
+              (modularFunctionFieldBar N))
+            ⟨jBar N, Algebra.self_mem_adjoin_singleton (AlgebraicClosure ℚ)
+              (jBar N : modularFunctionFieldBar N)⟩) = j₀}) :=
+  ⟨ModularCurve.placesOverEquivAlgHom N j₀ hdeg⟩
+
+end
+
+open AlgebraicCurve _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_nonempty_equiv_place_pos_ord_algHom_integralClosure.ModularCurve in
+theorem solution (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ)
+    (hdeg : ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), w.deg = 1) :
+    Nonempty ({v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+        0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)} ≃
+      {ψ : ↥(integralClosure
+            ↥(Algebra.adjoin (AlgebraicClosure ℚ)
+              ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)))
+            (modularFunctionFieldBar N)) →ₐ[AlgebraicClosure ℚ] AlgebraicClosure ℚ //
+        ψ (algebraMap
+            ↥(Algebra.adjoin (AlgebraicClosure ℚ)
+              ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)))
+            ↥(integralClosure
+              ↥(Algebra.adjoin (AlgebraicClosure ℚ)
+                ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)))
+              (modularFunctionFieldBar N))
+            ⟨jBar N, Algebra.self_mem_adjoin_singleton (AlgebraicClosure ℚ)
+              (jBar N : modularFunctionFieldBar N)⟩) = j₀}) :=
+  ModularCurve.nonempty_equiv_place_pos_ord_algHom_integralClosure N j₀ hdeg
+
+end S_ModularCurve_nonempty_equiv_place_pos_ord_algHom_integralClosure
+end P2MW
+export P2MW.S_ModularCurve_nonempty_equiv_place_pos_ord_algHom_integralClosure (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve ModularCurve
+set_option maxSynthPendingDepth 3
+theorem ModularCurve.nonempty_equiv_place_pos_ord_algHom_integralClosure (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ)
+    (hdeg : ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), w.deg = 1) :
+    Nonempty ({v : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N) //
+        0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)} ≃
+      {ψ : ↥(integralClosure
+            ↥(Algebra.adjoin (AlgebraicClosure ℚ)
+              ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)))
+            (modularFunctionFieldBar N)) →ₐ[AlgebraicClosure ℚ] AlgebraicClosure ℚ //
+        ψ (algebraMap
+            ↥(Algebra.adjoin (AlgebraicClosure ℚ)
+              ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)))
+            ↥(integralClosure
+              ↥(Algebra.adjoin (AlgebraicClosure ℚ)
+                ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)))
+              (modularFunctionFieldBar N))
+            ⟨jBar N, Algebra.self_mem_adjoin_singleton (AlgebraicClosure ℚ)
+              (jBar N : modularFunctionFieldBar N)⟩) = j₀}) :=
+  solution N j₀ hdeg
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_nonempty_integralWeightOneForm.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_nonempty_integralWeightOneForm.lean
new file mode 100644
index 0000000000..07dc86b7f0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_nonempty_integralWeightOneForm.lean
@@ -0,0 +1,477 @@
+/-
+Based on Prove2Me node ModularCurve.nonempty_integralWeightOneForm
+(d475c008-5442-5c2a-b515-30cc5612de51) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 69439f14-ba2f-57c2-9564-9ff65c5e1b60
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_IgusaFunctionFieldX1
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Analysis.CStarAlgebra.Classes
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.NumberTheory.DirichletCharacter.Orthogonality
+import Mathlib.RingTheory.RootsOfUnity.AlgebraicallyClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_weightOne_eisenstein_qCoeff_eq_of_isPrimitive_of_odd
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of an integral weight-one form on Γ₁(M)
+
+Theorem statement: `ModularCurve.nonempty_integralWeightOneForm`
+(`d475c008-5442-5c2a-b515-30cc5612de51`), by Claude, 2026-09-05.
+
+Proof: submission `69439f14-ba2f-57c2-9564-9ff65c5e1b60`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\kappa$ be a field and let $M$ be a natural number with $3 \le M$. The assertion is that the
+type [`ModularCurve.IntegralWeightOneForm κ M`](def/ModularCurve_IgusaFunctionFieldX1.html#L16) is
+nonempty, i.e. that there exists a triple consisting of: a modular form $f$ of weight $1$ for the
+congruence subgroup $\Gamma_1(M)$, regarded as a subgroup of $\mathrm{GL}_2(\mathbb{R})$; a power
+series $p \in \mathbb{Z}[[q]]$; and a proof that $p$ is an integral $q$-expansion for $f$, meaning
+that the coefficientwise image of $p$ under $\mathbb{Z} \to \mathbb{C}$ equals the weight-one
+$q$-expansion `qExpansion 1 f` of $f$ at the cusp $\infty$; subject to the further condition that
+the Laurent series `intSeriesC κ p` over $\kappa$, obtained by reducing the coefficients of $p$
+along $\mathbb{Z} \to \kappa$ and viewing the resulting element of $\kappa[[q]]$ as a Laurent
+series, is non-zero. Thus: for every field $\kappa$ and every level $M \ge 3$ there is a weight-one
+form on $\Gamma_1(M)$ whose $q$-expansion has integer coefficients not all of which vanish in
+$\kappa$.
+
+This inhabits the datum from which the Igusa function field over $X_1(M)_\kappa$ is constructed, and
+it is invoked throughout the study of the models of $X_1(M)$ and of $X_1(M) \to X_0(M)$ in
+characteristic $p$. Classically the witness is a weight-one Eisenstein series attached to an odd
+Dirichlet character of conductor dividing $M$, and the proof cites the construction of such
+Eisenstein series for primitive odd characters, with constant term $-\bigl(\sum_{a<L}
+a\,\chi(a)\bigr)/(2L)$ and $n$-th coefficient $\sum_{d \mid n} \chi(d)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_nonempty_integralWeightOneForm.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_nonempty_integralWeightOneForm
+
+noncomputable section
+
+open CongruenceSubgroup UpperHalfPlane
+open scoped MatrixGroups
+
+namespace ModularCurve
+p2m_export "ModularCurve" "IntegralWeightOneForm restrictForm IsIntegralQExp Gamma1_le_of_dvd"
+p2m_open "ModularCurve"
+
+namespace WeightOneEisensteinSum
+
+def divisorSignCount (L n : ℕ) : ℤ :=
+  ((n.divisors.filter fun d : ℕ => (d : ZMod L) = 1).card : ℤ) -
+    ((n.divisors.filter fun d : ℕ => (d : ZMod L) = -1).card : ℤ)
+
+def thetaLikeSeries (L m c₀ : ℕ) : PowerSeries ℤ :=
+  PowerSeries.mk fun n => if n = 0 then (c₀ : ℤ) else (m : ℤ) * divisorSignCount L n
+
+variable (L : ℕ) [NeZero L]
+
+scoped instance : HasEnoughRootsOfUnity ℂ (Monoid.exponent (ZMod L)ˣ) := by
+  have : NeZero ((Monoid.exponent (ZMod L)ˣ : ℕ) : ℂ) :=
+    ⟨Nat.cast_ne_zero.mpr Monoid.exponent_ne_zero_of_finite⟩
+  infer_instance
+
+open Classical in
+def oddCharSum (a : ZMod L) : ℂ :=
+  ∑ χ : DirichletCharacter ℂ L, if χ.Odd then χ a else 0
+
+theorem two_mul_oddCharSum (a : ZMod L) :
+    2 * oddCharSum L a =
+      (L.totient : ℂ) * ((if a = 1 then 1 else 0) - (if a = -1 then 1 else 0)) := by
+  classical
+  have h1 := DirichletCharacter.sum_characters_eq ℂ a
+  have h2 := DirichletCharacter.sum_characters_eq ℂ (-a)
+  have key : ∑ χ : DirichletCharacter ℂ L, (χ a - χ (-a)) = 2 * oddCharSum L a := by
+    rw [oddCharSum, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun χ _ => ?_
+    rcases χ.even_or_odd with hev | hodd
+    · rw [hev.eval_neg, sub_self, ite_eq_right hev.not_odd, mul_zero]
+    · rw [hodd.eval_neg, ite_eq_left hodd]; ring
+  rw [← key, Finset.sum_sub_distrib, h1, h2]
+  by_cases ha : a = 1
+  · subst ha
+    have hne : (-1 : ZMod L) ≠ 1 ∨ L ≤ 2 := by
+      by_cases hL : 2 < L
+      · exact Or.inl (by have : Fact (2 < L) := ⟨hL⟩; exact ZMod.neg_one_ne_one)
+      · exact Or.inr (not_lt.mp hL)
+    by_cases h' : (-1 : ZMod L) = 1
+    · simp [h']
+    · simp [h', show ¬ ((1 : ZMod L) = -1) from fun h => h' h.symm]
+  · by_cases hb : a = -1
+    · subst hb
+      simp [ha]
+    · have : ¬ (-a = 1) := fun h => hb (neg_eq_iff_eq_neg.mp h)
+      simp [ha, hb, this]
+
+def eisensteinOdd (χ : DirichletCharacter ℂ L) : ModularForm (Gamma1 L) 1 := by
+  classical
+  exact if h : χ.Odd ∧ χ.IsPrimitive then
+    (ModularForm.exists_weightOne_eisenstein_qCoeff_eq_of_isPrimitive_of_odd L χ h.2 h.1).choose
+  else 0
+
+def oddEisensteinSum : ModularForm (Gamma1 L) 1 :=
+  ∑ χ : DirichletCharacter ℂ L, eisensteinOdd L χ
+
+omit [NeZero L] in
+theorem one_mem_strictPeriods_Gamma1 :
+    (1 : ℝ) ∈ ((Gamma1 L : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  rw [CongruenceSubgroup.strictPeriods_Gamma1]
+  exact AddSubgroup.mem_zmultiples 1
+
+variable (hL : 2 < L) (hprim : ∀ χ : DirichletCharacter ℂ L, χ ≠ 1 → χ.IsPrimitive)
+include hL hprim
+
+omit [NeZero L] hL in
+theorem isPrimitive_of_odd {χ : DirichletCharacter ℂ L} (h : χ.Odd) : χ.IsPrimitive := by
+  refine hprim χ fun h1 => ?_
+  have : χ (-1) = 1 := by rw [h1, MulChar.one_apply (isUnit_one.neg)]
+  rw [h] at this
+  norm_num at this
+
+omit hL in
+open scoped Classical in
+theorem coeff_qExpansion_eisensteinOdd (χ : DirichletCharacter ℂ L) (n : ℕ) :
+    (qExpansion 1 ⇑(eisensteinOdd L χ)).coeff n =
+      if χ.Odd then
+        (if n = 0 then -(∑ a ∈ Finset.range L, (a : ℂ) * χ (a : ZMod L)) / (2 * L)
+         else ∑ d ∈ n.divisors, χ (d : ZMod L))
+      else 0 := by
+  classical
+  by_cases hodd : χ.Odd
+  · have hcond : χ.Odd ∧ χ.IsPrimitive := ⟨hodd, isPrimitive_of_odd L hprim hodd⟩
+    have hE := (ModularForm.exists_weightOne_eisenstein_qCoeff_eq_of_isPrimitive_of_odd L χ
+      hcond.2 hcond.1).choose_spec
+    have hdef : eisensteinOdd L χ =
+      (ModularForm.exists_weightOne_eisenstein_qCoeff_eq_of_isPrimitive_of_odd
+        L χ hcond.2 hcond.1).choose := by
+      simp only [eisensteinOdd, dite_eq_left hcond]
+    rw [ite_eq_left hodd, hdef]
+    by_cases hn : n = 0
+    · subst hn
+      rw [ite_eq_left rfl]
+      exact hE.2.1
+    · rw [ite_eq_right hn]
+      exact hE.2.2 n (Nat.pos_of_ne_zero hn)
+  · have hdef : eisensteinOdd L χ = 0 := by
+      simp only [eisensteinOdd, dite_eq_right (fun h : χ.Odd ∧ χ.IsPrimitive => hodd h.1)]
+    rw [ite_eq_right hodd, hdef, FunLike.coe_zero, qExpansion_zero, map_zero]
+
+omit hL hprim in
+theorem qExpansion_oddEisensteinSum :
+    qExpansion 1 ⇑(oddEisensteinSum L) =
+      ∑ χ : DirichletCharacter ℂ L, qExpansion 1 ⇑(eisensteinOdd L χ) := by
+  have := map_sum (ModularForm.qExpansionAddHom one_pos (one_mem_strictPeriods_Gamma1 L) 1)
+    (eisensteinOdd L) Finset.univ
+  exact this
+
+theorem coeff_zero_oddEisensteinSum :
+    (4 * L : ℂ) * (qExpansion 1 ⇑(oddEisensteinSum L)).coeff 0 = (L.totient : ℂ) * ((L : ℂ) - 2)
+      := by
+  classical
+  rw [qExpansion_oddEisensteinSum L, map_sum]
+  have hterm : ∀ χ : DirichletCharacter ℂ L, (qExpansion 1 ⇑(eisensteinOdd L χ)).coeff 0 =
+      (if χ.Odd then -(∑ a ∈ Finset.range L, (a : ℂ) * χ (a : ZMod L)) / (2 * L) else 0) := fun χ
+        => by
+    rw [coeff_qExpansion_eisensteinOdd L hprim, ite_eq_left rfl]
+  rw [Finset.sum_congr rfl (fun χ _ => hterm χ)]
+  have hswap : ∑ χ : DirichletCharacter ℂ L,
+      (if χ.Odd then -(∑ a ∈ Finset.range L, (a : ℂ) * χ (a : ZMod L)) / (2 * L) else 0) =
+      -(∑ a ∈ Finset.range L, (a : ℂ) * oddCharSum L (a : ZMod L)) / (2 * L) := by
+    have : ∀ χ : DirichletCharacter ℂ L,
+        (if χ.Odd then -(∑ a ∈ Finset.range L, (a : ℂ) * χ (a : ZMod L)) / (2 * L) else 0) =
+        -(∑ a ∈ Finset.range L, (a : ℂ) * (if χ.Odd then χ (a : ZMod L) else 0)) / (2 * L) := by
+      intro χ; split_ifs <;> simp
+    simp_rw [this]
+    rw [← Finset.sum_div]
+    congr 1
+    rw [Finset.sum_neg_distrib, Finset.sum_comm]
+    congr 1
+    refine Finset.sum_congr rfl fun a _ => ?_
+    rw [oddCharSum, Finset.mul_sum]
+  rw [hswap]
+  have hL0 : (L : ℂ) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne L)
+  have hsum : 2 * ∑ a ∈ Finset.range L, (a : ℂ) * oddCharSum L (a : ZMod L) =
+      (L.totient : ℂ) * (2 - L) := by
+    rw [Finset.mul_sum]
+    have : ∀ a ∈ Finset.range L, 2 * ((a : ℂ) * oddCharSum L (a : ZMod L)) =
+        (L.totient : ℂ) * ((if a = 1 then (a : ℂ) else 0) - (if a = L - 1 then (a : ℂ) else 0))
+          := by
+      intro a ha
+      rw [Finset.mem_range] at ha
+      rw [mul_left_comm, two_mul_oddCharSum]
+      have e1 : ((a : ZMod L) = 1) ↔ a = 1 := by
+        constructor
+        · intro h
+          have := (ZMod.natCast_eq_natCast_iff' a 1 L).mp (by simpa using h)
+          rw [Nat.mod_eq_of_lt ha, Nat.mod_eq_of_lt (by omega)] at this
+          exact this
+        · rintro rfl; simp
+      have e2 : ((a : ZMod L) = -1) ↔ a = L - 1 := by
+        have hL1 : ((L - 1 : ℕ) : ZMod L) = -1 := by
+          rw [Nat.cast_sub (by omega), Nat.cast_one, ZMod.natCast_self, zero_sub]
+        rw [← hL1]
+        constructor
+        · intro h
+          have := (ZMod.natCast_eq_natCast_iff' a (L - 1) L).mp h
+          rw [Nat.mod_eq_of_lt ha, Nat.mod_eq_of_lt (by omega)] at this
+          exact this
+        · rintro rfl; rfl
+      simp only [e1, e2]
+      split_ifs <;> ring
+    rw [Finset.sum_congr rfl this, ← Finset.mul_sum, Finset.sum_sub_distrib,
+      Finset.sum_ite_eq' (Finset.range L), Finset.sum_ite_eq' (Finset.range L),
+      ite_eq_left (Finset.mem_range.mpr (by omega)), ite_eq_left (Finset.mem_range.mpr (by omega)),
+      Nat.cast_sub (by omega)]
+    push_cast
+    ring
+  have : (4 * L : ℂ) * (-(∑ a ∈ Finset.range L, (a : ℂ) * oddCharSum L (a : ZMod L)) / (2 * L)) =
+      -(2 * ∑ a ∈ Finset.range L, (a : ℂ) * oddCharSum L (a : ZMod L)) := by
+    field_simp
+    ring
+  rw [this, hsum]
+  ring
+
+omit hL in
+theorem coeff_pos_oddEisensteinSum {n : ℕ} (hn : 0 < n) :
+    2 * (qExpansion 1 ⇑(oddEisensteinSum L)).coeff n = (L.totient : ℂ) * (divisorSignCount L n : ℂ)
+      := by
+  classical
+  rw [qExpansion_oddEisensteinSum L, map_sum]
+  simp_rw [coeff_qExpansion_eisensteinOdd L hprim, ite_eq_right (Nat.pos_iff_ne_zero.mp hn)]
+  have : ∀ χ : DirichletCharacter ℂ L,
+      (if χ.Odd then ∑ d ∈ n.divisors, χ (d : ZMod L) else 0) =
+        ∑ d ∈ n.divisors, (if χ.Odd then χ (d : ZMod L) else 0) := by
+    intro χ; split_ifs <;> simp
+  simp_rw [this]
+  rw [Finset.sum_comm, Finset.mul_sum]
+  have : ∀ d ∈ n.divisors, 2 * ∑ χ : DirichletCharacter ℂ L, (if χ.Odd then χ (d : ZMod L) else 0) =
+      (L.totient : ℂ) * ((if (d : ZMod L) = 1 then 1 else 0) - (if (d : ZMod L) = -1 then 1 else 0))
+        := by
+    intro d _
+    exact two_mul_oddCharSum L (d : ZMod L)
+  rw [Finset.sum_congr rfl this, ← Finset.mul_sum, Finset.sum_sub_distrib, Finset.sum_boole,
+    Finset.sum_boole, divisorSignCount]
+  push_cast
+  ring
+
+end WeightOneEisensteinSum
+end ModularCurve
+
+namespace ModularForm
+p2m_export "ModularForm" "mk IsGLPos.coe_smul coe_smul qExpansionAddHom ext coe_zero \
+  exists_weightOne_eisenstein_qCoeff_eq_of_isPrimitive_of_odd"
+end ModularForm
+p2m_open_scoped "ModularForm" in
+open ModularCurve.WeightOneEisensteinSum in
+theorem ModularForm.exists_weightOne_qExpansion_coeff_eq_card_filter_of_forall_isPrimitive
+    (L : ℕ) [NeZero L] (hL : 2 < L)
+    (hprim : ∀ χ : DirichletCharacter ℂ L, χ ≠ 1 → χ.IsPrimitive)
+    (m c₀ : ℕ) (hmc : c₀ * (2 * L) = m * (L - 2)) :
+    ∃ f : ModularForm (Gamma1 L) 1,
+      (qExpansion 1 f).coeff 0 = (c₀ : ℂ) ∧
+      ∀ n : ℕ, 0 < n →
+        (qExpansion 1 f).coeff n =
+          (m : ℂ) * (((n.divisors.filter fun d : ℕ => (d : ZMod L) = 1).card : ℂ) -
+            ((n.divisors.filter fun d : ℕ => (d : ZMod L) = -1).card : ℂ)) := by
+  classical
+  have hφ : (L.totient : ℂ) ≠ 0 := Nat.cast_ne_zero.mpr (Nat.totient_pos.mpr (NeZero.pos L)).ne'
+  have hL0 : (L : ℂ) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne L)
+  refine ⟨((2 * m : ℂ) / L.totient) • oddEisensteinSum L, ?_, ?_⟩
+  · rw [FunLike.coe_smul,
+      ModularForm.qExpansion_smul one_pos (one_mem_strictPeriods_Gamma1 L) _ (oddEisensteinSum L),
+      map_smul, smul_eq_mul]
+    have h0 := coeff_zero_oddEisensteinSum L hL hprim
+    have hmc' : (c₀ : ℂ) * (2 * L) = m * ((L : ℂ) - 2) := by
+      have := congrArg (Nat.cast (R := ℂ)) hmc
+      push_cast [Nat.cast_sub (le_of_lt hL)] at this
+      linear_combination this
+    have ha0 : (qExpansion 1 ⇑(oddEisensteinSum L)).coeff 0 =
+        (L.totient : ℂ) * ((L : ℂ) - 2) / (4 * L) := by
+      rw [← h0]; field_simp
+    rw [ha0]
+    have hX : (2 * (m : ℂ) / (L.totient : ℂ)) * ((L.totient : ℂ) * ((L : ℂ) - 2) / (4 * L)) =
+        (m : ℂ) * ((L : ℂ) - 2) / (2 * L) := by
+      field_simp
+      ring
+    rw [hX, div_eq_iff (mul_ne_zero two_ne_zero hL0)]
+    exact hmc'.symm
+  · intro n hn
+    rw [FunLike.coe_smul,
+      ModularForm.qExpansion_smul one_pos (one_mem_strictPeriods_Gamma1 L) _ (oddEisensteinSum L),
+      map_smul, smul_eq_mul]
+    have h1 := coeff_pos_oddEisensteinSum L hprim hn
+    have : (qExpansion 1 ⇑(oddEisensteinSum L)).coeff n =
+        (L.totient : ℂ) * (divisorSignCount L n : ℂ) / 2 := by
+      rw [← h1]; ring
+    rw [this, divisorSignCount]
+    push_cast
+    field_simp
+
+namespace ModularCurve
+p2m_export "ModularCurve" "IntegralWeightOneForm restrictForm IsIntegralQExp Gamma1_le_of_dvd"
+p2m_open "ModularCurve"
+
+namespace WeightOneEisensteinSum
+
+theorem exists_isIntegralQExp_thetaLikeSeries (L : ℕ) [NeZero L] (hL : 2 < L)
+    (hprim : ∀ χ : DirichletCharacter ℂ L, χ ≠ 1 → χ.IsPrimitive)
+    (m c₀ : ℕ) (hmc : c₀ * (2 * L) = m * (L - 2)) :
+    ∃ f : ModularForm (Gamma1 L) 1, IsIntegralQExp f (thetaLikeSeries L m c₀) := by
+  obtain ⟨f, h0, hpos⟩ :=
+    ModularForm.exists_weightOne_qExpansion_coeff_eq_card_filter_of_forall_isPrimitive L hL hprim m
+      c₀ hmc
+  refine ⟨f, ?_⟩
+  rw [IsIntegralQExp]
+  ext n
+  rw [PowerSeries.coeff_map, thetaLikeSeries, PowerSeries.coeff_mk]
+  by_cases hn : n = 0
+  · subst hn
+    rw [ite_eq_left rfl, eq_intCast, Int.cast_natCast, h0]
+  · rw [ite_eq_right hn, eq_intCast, hpos n (Nat.pos_of_ne_zero hn), divisorSignCount]
+    push_cast
+    ring
+
+end WeightOneEisensteinSum
+
+open WeightOneEisensteinSum
+
+theorem exists_dvd_four_or_odd_prime {M : ℕ} (hM : 3 ≤ M) :
+    ∃ L, L ∣ M ∧ (L = 4 ∨ (L.Prime ∧ Odd L)) := by
+  obtain ⟨k, m, hm, rfl⟩ := Nat.exists_eq_two_pow_mul_odd (by omega : M ≠ 0)
+  by_cases h1 : m = 1
+  · subst h1
+    refine ⟨4, ?_, Or.inl rfl⟩
+    have hk : 2 ≤ k := by
+      by_contra hk
+      interval_cases k <;> simp at hM
+    rw [mul_one, show (4 : ℕ) = 2 ^ 2 by norm_num]
+    exact pow_dvd_pow 2 hk
+  · exact ⟨m.minFac, (Nat.minFac_dvd m).trans (Dvd.intro_left _ rfl),
+      Or.inr ⟨Nat.minFac_prime h1, hm.of_dvd_nat (Nat.minFac_dvd m)⟩⟩
+
+theorem isPrimitive_of_ne_one_of_prime {p : ℕ} (hp : p.Prime) (χ : DirichletCharacter ℂ p)
+    (hχ : χ ≠ 1) : χ.IsPrimitive := by
+  have : NeZero p := ⟨hp.ne_zero⟩
+  rcases (Nat.dvd_prime hp).mp χ.conductor_dvd_level with h | h
+  · exact absurd (DirichletCharacter.eq_one_iff_conductor_eq_one.mpr h) hχ
+  · exact h
+
+theorem isPrimitive_of_ne_one_four (χ : DirichletCharacter ℂ 4) (hχ : χ ≠ 1) : χ.IsPrimitive := by
+  have hd : χ.conductor ∈ Nat.divisors 4 :=
+    Nat.mem_divisors.mpr ⟨χ.conductor_dvd_level, by norm_num⟩
+  have h124 : χ.conductor = 1 ∨ χ.conductor = 2 ∨ χ.conductor = 4 := by
+    have : Nat.divisors 4 = {1, 2, 4} := by decide
+    simpa [this] using hd
+  rcases h124 with h | h | h
+  · exact absurd (DirichletCharacter.eq_one_iff_conductor_eq_one.mpr h) hχ
+  · exfalso
+    have hf : χ.FactorsThrough 2 := h ▸ χ.conductor_mem_conductorSet
+    obtain ⟨hdvd, χ₀, hχ₀⟩ := hf
+    have h0 : χ₀ = 1 := by
+      rw [MulChar.eq_one_iff]
+      intro a
+      rw [Subsingleton.elim a 1]
+      exact χ₀.map_one'
+    exact hχ (by rw [hχ₀, h0, DirichletCharacter.changeLevel_one])
+  · exact h
+
+theorem nonempty_integralWeightOneForm_of_dvd (κ : Type) [Field κ] {L M : ℕ} (hLM : L ∣ M)
+    (f : ModularForm (Gamma1 L) 1) (s : PowerSeries ℤ) (hfs : IsIntegralQExp f s)
+    (n : ℕ) (hn : ((PowerSeries.coeff n s : ℤ) : κ) ≠ 0) :
+    Nonempty (ModularCurve.IntegralWeightOneForm κ M) := by
+  have hle : ((Gamma1 M : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) ≤
+      ((Gamma1 L : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) :=
+    Subgroup.map_mono (Gamma1_le_of_dvd hLM)
+  refine ⟨{ form := restrictForm hle f, series := s, isIntegralQExp := hfs, intSeriesC_ne_zero := ?_
+    }⟩
+  intro h0
+  apply hn
+  have h1 : s.map (Int.castRingHom κ) = 0 :=
+    HahnSeries.ofPowerSeries_injective (Γ := ℤ) (R := κ) (by rw [map_zero]; exact h0)
+  have := congrArg (PowerSeries.coeff n) h1
+  rwa [PowerSeries.coeff_map, map_zero, eq_intCast] at this
+
+end ModularCurve
+
+theorem solution
+    (κ : Type) [Field κ] (M : ℕ) (hM : 3 ≤ M) :
+    Nonempty (ModularCurve.IntegralWeightOneForm κ M) := by
+  classical
+  obtain ⟨L, hLM, hL⟩ := ModularCurve.exists_dvd_four_or_odd_prime hM
+  rcases hL with rfl | ⟨hp, hodd⟩
+  · obtain ⟨f, hf⟩ := ModularCurve.WeightOneEisensteinSum.exists_isIntegralQExp_thetaLikeSeries 4
+      (by norm_num) (ModularCurve.isPrimitive_of_ne_one_four) 4 1 (by norm_num)
+    refine ModularCurve.nonempty_integralWeightOneForm_of_dvd κ hLM f _ hf 0 ?_
+    simp [ModularCurve.WeightOneEisensteinSum.thetaLikeSeries, PowerSeries.coeff_mk]
+  · have : NeZero L := ⟨hp.ne_zero⟩
+    have hL2 : 2 < L :=
+      lt_of_le_of_ne hp.two_le (fun h => by rw [← h] at hodd; exact (by decide : ¬ Odd 2) hodd)
+    obtain ⟨f, hf⟩ := ModularCurve.WeightOneEisensteinSum.exists_isIntegralQExp_thetaLikeSeries L
+      hL2 (ModularCurve.isPrimitive_of_ne_one_of_prime hp) (2 * L) (L - 2) (by ring)
+    by_cases h0 : (((L - 2 : ℕ) : ℤ) : κ) ≠ 0
+    · refine ModularCurve.nonempty_integralWeightOneForm_of_dvd κ hLM f _ hf 0 ?_
+      simpa [ModularCurve.WeightOneEisensteinSum.thetaLikeSeries, PowerSeries.coeff_mk] using h0
+    · rw [not_ne_iff, Int.cast_natCast] at h0
+      refine ModularCurve.nonempty_integralWeightOneForm_of_dvd κ hLM f _ hf 1 ?_
+      have hc1 : PowerSeries.coeff 1 (ModularCurve.WeightOneEisensteinSum.thetaLikeSeries L (2 * L)
+        (L - 2)) =
+          2 * L := by
+        have : Fact (2 < L) := ⟨hL2⟩
+        have hneg : ¬ ((1 : ZMod L) = -1) := fun h => ZMod.neg_one_ne_one h.symm
+        simp [ModularCurve.WeightOneEisensteinSum.thetaLikeSeries, PowerSeries.coeff_mk,
+          ModularCurve.WeightOneEisensteinSum.divisorSignCount, Nat.divisors_one,
+          Finset.filter_singleton, hneg]
+      rw [hc1]
+      push_cast
+      obtain ⟨p, hchar⟩ := CharP.exists κ
+      have hpL2 : p ∣ L - 2 := (CharP.cast_eq_zero_iff κ p (L - 2)).mp h0
+      intro h2L
+      have h2L' : ((2 * L : ℕ) : κ) = 0 := by push_cast; exact h2L
+      have hp2L : p ∣ 2 * L := (CharP.cast_eq_zero_iff κ p (2 * L)).mp h2L'
+      rcases CharP.char_is_prime_or_zero κ p with hpp | rfl
+      · rcases (Nat.Prime.dvd_mul hpp).mp hp2L with h2 | hL'
+        · have : p = 2 := (Nat.prime_dvd_prime_iff_eq hpp Nat.prime_two).mp h2
+          subst this
+          have : 2 ∣ L := by omega
+          exact hodd.not_two_dvd_nat this
+        · have : p = L := (Nat.prime_dvd_prime_iff_eq hpp hp).mp hL'
+          subst this
+          have := Nat.le_of_dvd (by omega) hpL2
+          omega
+      · rw [zero_dvd_iff] at hpL2
+        omega
+
+end
+end S_ModularCurve_nonempty_integralWeightOneForm
+end P2MW
+export P2MW.S_ModularCurve_nonempty_integralWeightOneForm (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem ModularCurve.nonempty_integralWeightOneForm
+    (κ : Type) [Field κ] (M : ℕ) (hM : 3 ≤ M) :
+    Nonempty (ModularCurve.IntegralWeightOneForm κ M) :=
+  solution κ M hM
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_nonempty_modularPolynomialData.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_nonempty_modularPolynomialData.lean
new file mode 100644
index 0000000000..7461921ef5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_nonempty_modularPolynomialData.lean
@@ -0,0 +1,196 @@
+/-
+Based on Prove2Me node ModularCurve.nonempty_modularPolynomialData
+(43c4021c-080c-5aaf-8e3d-32ee4852f077) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e7415b42-2f40-5e49-b4de-2f97a34e95d9
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import Mathlib.Algebra.AffineMonoid.Basic
+import Mathlib.Analysis.Normed.Field.Lemmas
+import Mathlib.RingTheory.Polynomial.IsIntegral
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_RouteBCoordRing
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_evalAtJGen_injective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_monic_evalAtJ_jqN_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqN_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of a modular polynomial datum at every level N
+
+Theorem statement: `ModularCurve.nonempty_modularPolynomialData`
+(`43c4021c-080c-5aaf-8e3d-32ee4852f077`), by Claude, 2026-09-05.
+
+Proof: submission `e7415b42-2f40-5e49-b4de-2f97a34e95d9`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, assumed nonzero. The assertion is that the type
+[`ModularCurve.ModularPolynomialData N`](def/ModularCurve_X0.html#L215) is inhabited, i.e. that
+there exists a datum consisting of a polynomial $\Phi \in (\mathbb{Z}[X])[Y]$, that is an element of
+`Polynomial (Polynomial ℤ)`, together with proofs of three conditions: $\Phi$ is monic as a
+polynomial in the outer variable over the coefficient ring $\mathbb{Z}[X]$; its natural degree in
+that variable equals `dedekindPsi N`, defined as the sum $\sum_{d \mid N,\ d \text{ squarefree}}
+N/d$; and $\Phi$ vanishes when its coefficients are transported by the ring homomorphism `evalAtJ`
+and the outer variable is evaluated at `jqN N`. Here `evalAtJ : Polynomial ℤ →+* LaurentSeries ℚ` is
+the homomorphism sending $X$ to the Laurent series `jq` (the $q$-expansion of $j$) and `jqN N` is
+the Laurent series obtained from $j$ at $q^N$, so the last condition says $\Phi(j(q), j(q^N)) = 0$
+as an identity of Laurent series over $\mathbb{Q}$. No further hypotheses are imposed.
+
+This is the existence of the classical modular polynomial $\Phi_N$ relating $j(q)$ and $j(q^N)$,
+monic of degree $\psi(N)$ in the second variable with coefficients in $\mathbb{Z}[j]$; it is the
+input from which the integral model of $X_0(N)$ used throughout the project is built. It is cited
+very widely downstream, for instance in the construction of Hecke correspondences and of the models
+of $X_0(N)$ in characteristic $p$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_nonempty_modularPolynomialData.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_nonempty_modularPolynomialData
+
+noncomputable section
+
+open ModularCurve IntermediateField Polynomial
+open scoped Polynomial IntermediateField
+
+
+namespace Ws10NP
+
+abbrev K : IntermediateField ℚ (LaurentSeries ℚ) := ℚ⟮jq⟯
+abbrev LS := LaurentSeries ℚ
+
+scoped instance algIntPolyK : Algebra (Polynomial ℤ) K := evalAtJGen.toAlgebra
+scoped instance algKF (N : ℕ) [NeZero N] : Algebra K (modularFunctionField N) := (jAdjoinRingHom
+  N).toAlgebra
+attribute [local instance] ModularCurve.algebraIntPolyModularFunctionField
+scoped instance ist1 (N : ℕ) [NeZero N] : IsScalarTower (Polynomial ℤ) K (modularFunctionField N) :=
+  IsScalarTower.of_algebraMap_eq (fun _ => rfl)
+scoped instance ist2 (N : ℕ) [NeZero N] : IsScalarTower K (modularFunctionField N) LS where
+  -- Avoid expensive kernel reduction through `IsScalarTower.of_algebraMap_eq`.
+  smul_assoc x y z := by
+    change ((x : LS) * (y : LS)) * z = (x : LS) * ((y : LS) * z)
+    exact mul_assoc _ _ _
+
+theorem algebraMap_evalAtJGen (p : Polynomial ℤ) :
+    algebraMap K LS (evalAtJGen p) = Polynomial.aeval jq p := by
+  rw [← RingHom.comp_apply, algebraMap_comp_evalAtJGen]; rfl
+
+theorem aeval_jq_of_map_eq {p : Polynomial ℤ} {g : Polynomial ℚ} {d : ℤ}
+    (h : p.map (Int.castRingHom ℚ) = d • g) :
+    Polynomial.aeval jq p = (d : LS) * Polynomial.aeval jq g := by
+  have h1 : Polynomial.aeval jq (p.map (Int.castRingHom ℚ)) = Polynomial.aeval jq p := by
+    rw [Polynomial.aeval_def, Polynomial.eval₂_map, Polynomial.aeval_def]
+    congr 1
+    exact Subsingleton.elim _ _
+  rw [← h1, h, zsmul_eq_mul, map_mul, map_intCast]
+
+theorem exists_eq_div (z : K) :
+    ∃ x y : Polynomial ℤ, z = algebraMap (Polynomial ℤ) K x / algebraMap (Polynomial ℤ) K y := by
+  obtain ⟨r, s, hrs⟩ := (IntermediateField.mem_adjoin_simple_iff ℚ (α := jq) z.1).mp z.2
+  obtain ⟨dR, hdR0, hR⟩ := IsLocalization.integerNormalization_spec (nonZeroDivisors ℤ) r
+  obtain ⟨dS, hdS0, hS⟩ := IsLocalization.integerNormalization_spec (nonZeroDivisors ℤ) s
+  set R : Polynomial ℤ := IsLocalization.integerNormalization (nonZeroDivisors ℤ) r
+  set S : Polynomial ℤ := IsLocalization.integerNormalization (nonZeroDivisors ℤ) s
+  have hR' : R.map (Int.castRingHom ℚ) = dR • r := hR
+  have hS' : S.map (Int.castRingHom ℚ) = dS • s := hS
+  refine ⟨Polynomial.C dS * R, Polynomial.C dR * S, ?_⟩
+  apply Subtype.ext
+  change z.1 = algebraMap K LS (evalAtJGen (Polynomial.C dS * R) / evalAtJGen (Polynomial.C dR * S))
+  rw [map_div₀, algebraMap_evalAtJGen, algebraMap_evalAtJGen, map_mul, map_mul, Polynomial.aeval_C,
+    Polynomial.aeval_C, aeval_jq_of_map_eq hR', aeval_jq_of_map_eq hS', hrs]
+  have hinj : Function.Injective (algebraMap ℚ LS) := (algebraMap ℚ LS).injective
+  have hdS : (dS : LS) ≠ 0 := by
+    rw [← map_intCast (algebraMap ℚ LS), map_ne_zero_iff _
+      hinj]; exact_mod_cast nonZeroDivisors.ne_zero hdS0
+  have hdR : (dR : LS) ≠ 0 := by
+    rw [← map_intCast (algebraMap ℚ LS), map_ne_zero_iff _
+      hinj]; exact_mod_cast nonZeroDivisors.ne_zero hdR0
+  have hd : ((dS : LS) * (dR : LS)) ≠ 0 := mul_ne_zero hdS hdR
+  have e : ∀ X Y : LS, (dS : LS) * ((dR : LS) * X) / ((dR : LS) * ((dS : LS) * Y)) = X / Y :=
+    fun X Y => by
+    rw [← mul_assoc, ← mul_assoc, mul_comm (dR : LS) (dS : LS), mul_div_mul_left _ _ hd]
+  rw [eq_intCast, eq_intCast, e]
+
+theorem isFractionRing_intPoly_K : IsFractionRing (Polynomial ℤ) K := by
+  have : FaithfulSMul (Polynomial ℤ) K :=
+    (faithfulSMul_iff_algebraMap_injective _ _).mpr ModularCurve.evalAtJGen_injective
+  exact IsFractionRing.of_field (Polynomial ℤ) K exists_eq_div
+
+variable (N : ℕ) [NeZero N]
+
+def jN : modularFunctionField N := ⟨jqN N, jqN_mem N⟩
+
+theorem hcomp :
+    (algebraMap (modularFunctionField N) LS).comp (algebraMap (Polynomial ℤ) (modularFunctionField
+      N))
+    = evalAtJ := RingHom.ext fun P => by
+  rw [RingHom.comp_apply, ← algebraMap_comp_evalAtJGen]; rfl
+
+theorem isIntegral_jN : IsIntegral (Polynomial ℤ) (jN N) := by
+  obtain ⟨P, hPm, hP0⟩ := ModularCurve.exists_monic_evalAtJ_jqN_eq_zero N
+  refine ⟨P, hPm, ?_⟩
+  have h0 : algebraMap (modularFunctionField N) LS
+      (P.eval₂ (algebraMap (Polynomial ℤ) (modularFunctionField N)) (jN N)) = 0 := by
+    rw [Polynomial.hom_eval₂, hcomp]
+    exact hP0
+  exact (map_eq_zero_iff _ (algebraMap (modularFunctionField N) LS).injective).mp h0
+
+theorem main : Nonempty (ModularPolynomialData N) := by
+  have : IsFractionRing (Polynomial ℤ) K := isFractionRing_intPoly_K
+  have hint := isIntegral_jN N
+  refine ⟨⟨minpoly (Polynomial ℤ) (jN N), minpoly.monic hint, ?_, ?_⟩⟩
+  · have hintK : IsIntegral K (jN N) := hint.tower_top
+    have h1 : minpoly K (jN N) = (minpoly (Polynomial ℤ) (jN N)).map (algebraMap (Polynomial ℤ) K)
+      :=
+      minpoly.isIntegrallyClosed_eq_field_fractions' K hint
+    have h2 : (minpoly (Polynomial ℤ) (jN N)).natDegree = (minpoly K (jN N)).natDegree := by
+      rw [h1, (minpoly.monic hint).natDegree_map]
+    have hintK' : IsIntegral K (jqN N) :=
+      hintK.map (IsScalarTower.toAlgHom K (modularFunctionField N) LS)
+    have hmin : minpoly K (jqN N) = minpoly K (jN N) :=
+      minpoly.algHom_eq _ (IsScalarTower.toAlgHom K (modularFunctionField N) LS).toRingHom.injective
+        (jN N)
+    rw [h2, ← hmin, ← IntermediateField.adjoin.finrank hintK']
+    exact ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi N
+  · have h := minpoly.aeval (Polynomial ℤ) (jN N)
+    rw [Polynomial.aeval_def] at h
+    have := congrArg (algebraMap (modularFunctionField N) LS) h
+    rw [Polynomial.hom_eval₂, hcomp, map_zero] at this
+    exact this
+
+end Ws10NP
+end
+
+theorem solution (N : ℕ) [NeZero N] : Nonempty (ModularCurve.ModularPolynomialData N) :=
+  Ws10NP.main N
+
+end S_ModularCurve_nonempty_modularPolynomialData
+end P2MW
+export P2MW.S_ModularCurve_nonempty_modularPolynomialData (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.nonempty_modularPolynomialData (N : ℕ) [NeZero N] :
+    Nonempty (ModularCurve.ModularPolynomialData N) :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_nonempty_modularPolynomialData_of_squarefree.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_nonempty_modularPolynomialData_of_squarefree.lean
new file mode 100644
index 0000000000..c958c0b04c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_nonempty_modularPolynomialData_of_squarefree.lean
@@ -0,0 +1,568 @@
+/-
+Based on Prove2Me node ModularCurve.nonempty_modularPolynomialData_of_squarefree
+(eeb1e5fc-d301-59a3-8555-a76da6b464ce) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 83e0515e-55d8-54d2-8cbc-601b6bb56385
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularPolynomialFamily
+import Mathlib.NumberTheory.ArithmeticFunction.Misc
+import Mathlib.RingTheory.Polynomial.Resultant.Basic
+import Mathlib.FieldTheory.IsAlgClosed.Basic
+import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of modular polynomial data at squarefree levels
+
+Theorem statement: `ModularCurve.nonempty_modularPolynomialData_of_squarefree`
+(`eeb1e5fc-d301-59a3-8555-a76da6b464ce`), by Claude, 2026-09-05.
+
+Proof: submission `83e0515e-55d8-54d2-8cbc-601b6bb56385`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number with $N \neq 0$, and assume that $N$ is squarefree and $1 < N$. The
+conclusion is that the structure type `ModularPolynomialData N` is nonempty, i.e. there exists a
+quadruple consisting of a polynomial $\Phi \in (\mathbb{Z}[X])[Y]$ in one variable over
+$\mathbb{Z}[X]$ together with proofs that: $\Phi$ is monic; the degree of $\Phi$ in its outer
+variable equals `dedekindPsi N`, defined as $\sum_{d \mid N,\ d \text{ squarefree}} N/d$ (which for
+squarefree $N$ is the usual Dedekind $\psi(N) = N\prod_{\ell \mid N}(1 + 1/\ell)$, the sum being
+over all divisors); and $\Phi$ vanishes under the two-variable evaluation `Φ.eval₂ evalAtJ (jqN N)`,
+that is, substituting the Laurent series `jqN N` over $\mathbb{Q}$ for the outer variable and
+applying to each coefficient the ring homomorphism `evalAtJ : Polynomial ℤ →+* LaurentSeries ℚ`
+given by evaluation at the Laurent series `jq`, one obtains $0$ in `LaurentSeries ℚ`. Here `jq` is
+the $q$-expansion of the modular invariant $j$ and `jqN N` its level-$N$ companion obtained by
+substituting $q^N$. No claim is made for non-squarefree $N$, nor for $N = 1$.
+
+This is the existence of the classical modular equation $\Phi_N(j(q), j(q^N)) = 0$, with integral
+coefficients and monic of degree $\psi(N)$, in the squarefree levels; it supplies the polynomial
+model used throughout the treatment of the modular curve $X_0(N)$ in this development. It is
+invoked, among others, in the local analysis at the nodes of the plane model and in the computation
+of the order of the cuspidal divisor class.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_nonempty_modularPolynomialData_of_squarefree.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_nonempty_modularPolynomialData_of_squarefree
+
+noncomputable section
+
+open Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_qExpand jq jqN dedekindPsi evalAtJ evalAtJ_X \
+  ModularPolynomialData modularPolynomialFamily"
+p2m_open "ModularCurve"
+
+section DedekindPsi
+
+p2m_open "Finset Nat Finset.Nat ArithmeticFunction"
+
+private def squarefreeIndicator : ArithmeticFunction ℕ :=
+  ⟨fun n => if Squarefree n then 1 else 0, by simp [not_squarefree_zero]⟩
+
+@[scoped simp]
+private theorem squarefreeIndicator_apply {n : ℕ} :
+    squarefreeIndicator n = if Squarefree n then 1 else 0 :=
+  rfl
+
+private theorem isMultiplicative_squarefreeIndicator :
+    squarefreeIndicator.IsMultiplicative := by
+  refine ⟨by simp, fun {m n} h => ?_⟩
+  simp only [squarefreeIndicator_apply, Nat.squarefree_mul h]
+  by_cases hm : Squarefree m <;> by_cases hn : Squarefree n <;> simp [hm, hn]
+
+private theorem dedekindPsi_eq_mul_apply (N : ℕ) :
+    dedekindPsi N = (squarefreeIndicator * ArithmeticFunction.id) N :=
+  calc dedekindPsi N
+      = ∑ d ∈ N.divisors, squarefreeIndicator d * ArithmeticFunction.id (N / d) := by
+        rw [dedekindPsi, sum_filter]
+        refine Finset.sum_congr rfl fun d _ => ?_
+        by_cases hd : Squarefree d <;> simp [hd]
+    _ = ∑ x ∈ N.divisorsAntidiagonal, squarefreeIndicator x.1 * ArithmeticFunction.id x.2 :=
+        (Nat.sum_divisorsAntidiagonal fun d e =>
+          squarefreeIndicator d * ArithmeticFunction.id e).symm
+    _ = (squarefreeIndicator * ArithmeticFunction.id) N := ArithmeticFunction.mul_apply.symm
+
+private theorem isMultiplicative_squarefreeIndicator_mul_id :
+    (squarefreeIndicator * ArithmeticFunction.id).IsMultiplicative :=
+  isMultiplicative_squarefreeIndicator.mul isMultiplicative_id
+
+theorem dedekindPsi_mul_of_coprime (M N : ℕ) (h : Nat.Coprime M N) :
+    dedekindPsi (M * N) = dedekindPsi M * dedekindPsi N := by
+  simp only [dedekindPsi_eq_mul_apply]
+  exact isMultiplicative_squarefreeIndicator_mul_id.map_mul_of_coprime h
+
+private theorem le_dedekindPsi (N : ℕ) (hN : N ≠ 0) : N ≤ dedekindPsi N := by
+  rw [dedekindPsi]
+  have h1 : (1 : ℕ) ∈ {d ∈ N.divisors | Squarefree d} :=
+    Finset.mem_filter.mpr ⟨Nat.one_mem_divisors.mpr hN, squarefree_one⟩
+  simpa using Finset.single_le_sum (f := fun d => N / d) (fun d _ => Nat.zero_le _) h1
+
+private theorem dedekindPsi_pos (N : ℕ) (hN : N ≠ 0) : 0 < dedekindPsi N :=
+  lt_of_lt_of_le (Nat.pos_of_ne_zero hN) (le_dedekindPsi N hN)
+
+end DedekindPsi
+
+section FibrePoly
+
+variable {K : Type*} [Field K]
+
+private def fibrePoly (Φ : Polynomial (Polynomial ℤ)) (a : K) : Polynomial K :=
+  Φ.map (Polynomial.eval₂RingHom (Int.castRingHom K) a)
+
+private theorem monic_fibrePoly {Φ : Polynomial (Polynomial ℤ)} (hΦ : Φ.Monic) (a : K) :
+    (fibrePoly Φ a).Monic :=
+  hΦ.map _
+
+private theorem natDegree_fibrePoly {Φ : Polynomial (Polynomial ℤ)} (hΦ : Φ.Monic) (a : K) :
+    (fibrePoly Φ a).natDegree = Φ.natDegree :=
+  hΦ.natDegree_map _
+
+private theorem card_roots_fibrePoly_of_monic [IsAlgClosed K]
+    {Φ : Polynomial (Polynomial ℤ)} (hΦ : Φ.Monic) (a : K) :
+    Multiset.card (fibrePoly Φ a).roots = Φ.natDegree := by
+  rw [← (IsAlgClosed.splits (fibrePoly Φ a)).natDegree_eq_card_roots]
+  exact natDegree_fibrePoly hΦ a
+
+private def compositeFibrePoly (Φ Φ' : Polynomial (Polynomial ℤ)) (a : K) : Polynomial K :=
+  ((fibrePoly Φ a).roots.map fun b => fibrePoly Φ' b).prod
+
+private theorem compositeFibrePoly_def (Φ Φ' : Polynomial (Polynomial ℤ)) (a : K) :
+    compositeFibrePoly Φ Φ' a
+      = ((fibrePoly Φ a).roots.map fun b => fibrePoly Φ' b).prod :=
+  rfl
+
+private theorem monic_compositeFibrePoly {Φ Φ' : Polynomial (Polynomial ℤ)} (hΦ' : Φ'.Monic)
+    (a : K) : (compositeFibrePoly Φ Φ' a).Monic :=
+  monic_multiset_prod_of_monic _ _ fun _ _ => monic_fibrePoly hΦ' _
+
+end FibrePoly
+
+section Lifts
+
+private def resLiftInner (Φ : Polynomial (Polynomial ℤ)) :
+    Polynomial (Polynomial (Polynomial ℤ)) :=
+  Φ.map (Polynomial.C : Polynomial ℤ →+* Polynomial (Polynomial ℤ))
+
+private def resLiftOuter (Φ' : Polynomial (Polynomial ℤ)) :
+    Polynomial (Polynomial (Polynomial ℤ)) :=
+  Φ'.eval₂ (Polynomial.mapRingHom (Int.castRingHom (Polynomial (Polynomial ℤ))))
+    (Polynomial.C (Polynomial.X : Polynomial (Polynomial ℤ)))
+
+private def resLiftOuterK (K : Type*) [Field K] (Φ' : Polynomial (Polynomial ℤ)) :
+    Polynomial (Polynomial K) :=
+  Φ'.eval₂ (Polynomial.mapRingHom (Int.castRingHom (Polynomial K)))
+    (Polynomial.C (Polynomial.X : Polynomial K))
+
+end Lifts
+
+section Specialize
+
+variable {K : Type*} [Field K]
+
+private def specializeAt (a : K) :
+    Polynomial (Polynomial ℤ) →+* Polynomial K :=
+  Polynomial.mapRingHom (Polynomial.eval₂RingHom (Int.castRingHom K) a)
+
+private theorem specializeAt_eq_fibrePoly (a : K) (Ψ : Polynomial (Polynomial ℤ)) :
+    specializeAt a Ψ = fibrePoly Ψ a :=
+  rfl
+
+private theorem map_resLiftInner (Φ : Polynomial (Polynomial ℤ)) (a : K) :
+    (resLiftInner Φ).map (specializeAt a)
+      = (fibrePoly Φ a).map (Polynomial.C : K →+* Polynomial K) := by
+  have h : (specializeAt (K := K) a).comp
+        (Polynomial.C : Polynomial ℤ →+* Polynomial (Polynomial ℤ))
+      = (Polynomial.C : K →+* Polynomial K).comp
+          (Polynomial.eval₂RingHom (Int.castRingHom K) a) := by
+    refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+    simp [specializeAt]
+  rw [resLiftInner, Polynomial.map_map, h, ← Polynomial.map_map]
+  rfl
+
+private theorem map_resLiftOuter (Φ' : Polynomial (Polynomial ℤ)) (a : K) :
+    (resLiftOuter Φ').map (specializeAt a) = resLiftOuterK K Φ' := by
+  have hF : (Polynomial.mapRingHom (specializeAt (K := K) a)).comp
+        (Polynomial.mapRingHom (Int.castRingHom (Polynomial (Polynomial ℤ))))
+      = Polynomial.mapRingHom (Int.castRingHom (Polynomial K)) := by
+    refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+    simp [specializeAt]
+  have hX : (Polynomial.mapRingHom (specializeAt (K := K) a))
+        (Polynomial.C (Polynomial.X : Polynomial (Polynomial ℤ)))
+      = Polynomial.C (Polynomial.X : Polynomial K) := by
+    simp [specializeAt]
+  calc (resLiftOuter Φ').map (specializeAt a)
+      = (Polynomial.mapRingHom (specializeAt a))
+          (Φ'.eval₂ (Polynomial.mapRingHom
+            (Int.castRingHom (Polynomial (Polynomial ℤ))))
+            (Polynomial.C (Polynomial.X : Polynomial (Polynomial ℤ)))) := rfl
+    _ = Φ'.eval₂ ((Polynomial.mapRingHom (specializeAt a)).comp
+          (Polynomial.mapRingHom (Int.castRingHom (Polynomial (Polynomial ℤ)))))
+          ((Polynomial.mapRingHom (specializeAt a))
+            (Polynomial.C (Polynomial.X : Polynomial (Polynomial ℤ)))) :=
+        Polynomial.hom_eval₂ ..
+    _ = resLiftOuterK K Φ' := by rw [hF, hX]; rfl
+
+private theorem eval_C_resLiftOuterK (Φ' : Polynomial (Polynomial ℤ)) (b : K) :
+    (resLiftOuterK K Φ').eval (Polynomial.C b) = fibrePoly Φ' b := by
+  have hF : (Polynomial.evalRingHom (Polynomial.C b : Polynomial K)).comp
+        (Polynomial.mapRingHom (Int.castRingHom (Polynomial K)))
+      = (Polynomial.C : K →+* Polynomial K).comp
+          (Polynomial.eval₂RingHom (Int.castRingHom K) b) := by
+    refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+    simp
+  have hX : (Polynomial.evalRingHom (Polynomial.C b : Polynomial K))
+        (Polynomial.C (Polynomial.X : Polynomial K)) = Polynomial.X := by
+    simp
+  calc (resLiftOuterK K Φ').eval (Polynomial.C b)
+      = (Polynomial.evalRingHom (Polynomial.C b))
+          (Φ'.eval₂ (Polynomial.mapRingHom (Int.castRingHom (Polynomial K)))
+            (Polynomial.C (Polynomial.X : Polynomial K))) := rfl
+    _ = Φ'.eval₂ ((Polynomial.evalRingHom (Polynomial.C b)).comp
+          (Polynomial.mapRingHom (Int.castRingHom (Polynomial K))))
+          ((Polynomial.evalRingHom (Polynomial.C b))
+            (Polynomial.C (Polynomial.X : Polynomial K))) := Polynomial.hom_eval₂ ..
+    _ = fibrePoly Φ' b := by rw [hF, hX]; rfl
+
+private theorem natDegree_resLiftOuterK_le (Φ' : Polynomial (Polynomial ℤ)) (a : K) :
+    (resLiftOuterK K Φ').natDegree ≤ (resLiftOuter Φ').natDegree := by
+  rw [← map_resLiftOuter Φ' a]
+  exact Polynomial.natDegree_map_le
+
+end Specialize
+
+section BiResultant
+
+private def biResultant (Φ Φ' : Polynomial (Polynomial ℤ)) : Polynomial (Polynomial ℤ) :=
+  Polynomial.resultant (resLiftInner Φ) (resLiftOuter Φ')
+    Φ.natDegree (resLiftOuter Φ').natDegree
+
+variable {K : Type*} [Field K] [IsAlgClosed K]
+
+private theorem fibrePoly_biResultant {Φ : Polynomial (Polynomial ℤ)}
+    (Φ' : Polynomial (Polynomial ℤ)) (hΦ : Φ.Monic) (a : K) :
+    fibrePoly (biResultant Φ Φ') a = compositeFibrePoly Φ Φ' a := by
+  rw [← specializeAt_eq_fibrePoly, biResultant, ← Polynomial.resultant_map_map,
+    map_resLiftInner, map_resLiftOuter]
+  have hmono : ((fibrePoly Φ a).map (Polynomial.C : K →+* Polynomial K)).Monic :=
+    (monic_fibrePoly hΦ a).map _
+  have hdeg : ((fibrePoly Φ a).map (Polynomial.C : K →+* Polynomial K)).natDegree
+      = Φ.natDegree :=
+    ((monic_fibrePoly hΦ a).natDegree_map _).trans (hΦ.natDegree_map _)
+  have hsplit : ((fibrePoly Φ a).map (Polynomial.C : K →+* Polynomial K)).Splits :=
+    (IsAlgClosed.splits (fibrePoly Φ a)).map _
+  rw [← hdeg, Polynomial.resultant_eq_prod_eval _ _ _
+      (natDegree_resLiftOuterK_le Φ' a) hsplit, hmono.leadingCoeff, one_pow, one_mul]
+  rw [(IsAlgClosed.splits (fibrePoly Φ a)).roots_map_of_injective Polynomial.C_injective,
+    Multiset.map_map, compositeFibrePoly_def]
+  congr 1
+  exact Multiset.map_congr rfl fun b _ => eval_C_resLiftOuterK Φ' b
+
+end BiResultant
+
+section MonicDegree
+
+private theorem natDegree_compositeFibrePoly {K : Type*} [Field K] [IsAlgClosed K]
+    {Φ Φ' : Polynomial (Polynomial ℤ)} (hΦ : Φ.Monic) (hΦ' : Φ'.Monic) (a : K) :
+    (compositeFibrePoly Φ Φ' a).natDegree = Φ.natDegree * Φ'.natDegree := by
+  rw [compositeFibrePoly_def, natDegree_multiset_prod_of_monic _
+    (fun _ hb => by
+      obtain ⟨b, -, rfl⟩ := Multiset.mem_map.mp hb
+      exact monic_fibrePoly hΦ' b)]
+  rw [Multiset.map_map]
+  have hsame : ((fibrePoly Φ a).roots.map fun b => (fibrePoly Φ' b).natDegree)
+      = (fibrePoly Φ a).roots.map fun _ => Φ'.natDegree :=
+    Multiset.map_congr rfl fun b _ => natDegree_fibrePoly hΦ' b
+  rw [Function.comp_def, hsame, Multiset.map_const', Multiset.sum_replicate,
+    card_roots_fibrePoly_of_monic hΦ a, smul_eq_mul]
+
+local notation "ℚ̄" => AlgebraicClosure ℚ
+
+private theorem intPoly_eq_C_of_forall_algebraicClosure_eval (p : Polynomial ℤ) (c : ℤ)
+    (h : ∀ a : ℚ̄, p.eval₂ (Int.castRingHom ℚ̄) a = (c : ℚ̄)) :
+    p = Polynomial.C c := by
+  have hinj : Function.Injective (Int.castRingHom ℚ̄) := fun x y hxy =>
+    Int.cast_injective (α := ℚ̄) hxy
+  refine Polynomial.map_injective _ hinj ?_
+  rw [Polynomial.map_C]
+  refine Polynomial.funext fun a => ?_
+  rw [Polynomial.eval_map, Polynomial.eval_C]
+  exact h a
+
+private theorem coeff_fibrePoly {K : Type*} [Field K] (Ψ : Polynomial (Polynomial ℤ))
+    (a : K) (j : ℕ) :
+    (fibrePoly Ψ a).coeff j = (Ψ.coeff j).eval₂ (Int.castRingHom K) a := by
+  rw [fibrePoly, Polynomial.coeff_map, Polynomial.coe_eval₂RingHom]
+
+private theorem eval₂_coeff_biResultant_eq_coeff_compositeFibrePoly {K : Type*} [Field K]
+    [IsAlgClosed K] {Φ Φ' : Polynomial (Polynomial ℤ)} (hΦ : Φ.Monic) (a : K) (j : ℕ) :
+    ((biResultant Φ Φ').coeff j).eval₂ (Int.castRingHom K) a
+      = (compositeFibrePoly Φ Φ' a).coeff j := by
+  rw [← fibrePoly_biResultant Φ' hΦ a, coeff_fibrePoly]
+
+private theorem coeff_biResultant_natDegree_mul_natDegree
+    {Φ Φ' : Polynomial (Polynomial ℤ)} (hΦ : Φ.Monic) (hΦ' : Φ'.Monic) :
+    (biResultant Φ Φ').coeff (Φ.natDegree * Φ'.natDegree) = 1 := by
+  have h := intPoly_eq_C_of_forall_algebraicClosure_eval
+    ((biResultant Φ Φ').coeff (Φ.natDegree * Φ'.natDegree)) 1 ?_
+  · simpa using h
+  intro a
+  rw [eval₂_coeff_biResultant_eq_coeff_compositeFibrePoly hΦ a, Int.cast_one,
+    ← natDegree_compositeFibrePoly hΦ hΦ' a]
+  exact (monic_compositeFibrePoly hΦ' a).coeff_natDegree
+
+private theorem coeff_biResultant_eq_zero_of_natDegree_mul_lt
+    {Φ Φ' : Polynomial (Polynomial ℤ)} (hΦ : Φ.Monic) (hΦ' : Φ'.Monic) {j : ℕ}
+    (hj : Φ.natDegree * Φ'.natDegree < j) : (biResultant Φ Φ').coeff j = 0 := by
+  have h := intPoly_eq_C_of_forall_algebraicClosure_eval ((biResultant Φ Φ').coeff j) 0 ?_
+  · simpa using h
+  intro a
+  rw [eval₂_coeff_biResultant_eq_coeff_compositeFibrePoly hΦ a, Int.cast_zero]
+  exact Polynomial.coeff_eq_zero_of_natDegree_lt
+    ((natDegree_compositeFibrePoly hΦ hΦ' a).symm ▸ hj)
+
+private theorem monic_biResultant {Φ Φ' : Polynomial (Polynomial ℤ)}
+    (hΦ : Φ.Monic) (hΦ' : Φ'.Monic) : (biResultant Φ Φ').Monic :=
+  Polynomial.monic_of_natDegree_le_of_coeff_eq_one (Φ.natDegree * Φ'.natDegree)
+    (Polynomial.natDegree_le_iff_coeff_eq_zero.mpr fun _ hj =>
+      coeff_biResultant_eq_zero_of_natDegree_mul_lt hΦ hΦ' hj)
+    (coeff_biResultant_natDegree_mul_natDegree hΦ hΦ')
+
+private theorem natDegree_biResultant {Φ Φ' : Polynomial (Polynomial ℤ)}
+    (hΦ : Φ.Monic) (hΦ' : Φ'.Monic) :
+    (biResultant Φ Φ').natDegree = Φ.natDegree * Φ'.natDegree :=
+  Polynomial.natDegree_eq_of_le_of_coeff_ne_zero
+    (Polynomial.natDegree_le_iff_coeff_eq_zero.mpr fun _ hj =>
+      coeff_biResultant_eq_zero_of_natDegree_mul_lt hΦ hΦ' hj)
+    (by rw [coeff_biResultant_natDegree_mul_natDegree hΦ hΦ']; exact one_ne_zero)
+
+end MonicDegree
+
+section Engine
+
+private def evalModularPair {R : Type*} [CommRing R] (x y : R)
+    (Φ : Polynomial (Polynomial ℤ)) : R :=
+  Φ.eval₂ (Polynomial.eval₂RingHom (Int.castRingHom R) x) y
+
+private theorem evalModularPair_eq_eval_fibrePoly {K : Type*} [Field K] (a b : K)
+    (Φ : Polynomial (Polynomial ℤ)) :
+    evalModularPair a b Φ = (fibrePoly Φ a).eval b := by
+  rw [evalModularPair, fibrePoly, Polynomial.eval_map]
+
+private theorem Polynomial.resultant_eq_zero_of_isRoot_isRoot {R : Type*} [CommRing R]
+    {f g : R[X]} {b : R} (hf : f.IsRoot b) (hg : g.IsRoot b)
+    {m n : ℕ} (hfm : f.natDegree ≤ m) (hgn : g.natDegree ≤ n) (hmn : m ≠ 0 ∨ n ≠ 0) :
+    Polynomial.resultant f g m n = 0 := by
+  obtain ⟨p, q, _, _, hbez⟩ := Polynomial.exists_mul_add_mul_eq_C_resultant f g hfm hgn hmn
+  have heval := congrArg (Polynomial.eval b) hbez
+  simp only [Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C, hf.eq_zero,
+    hg.eq_zero, zero_mul, add_zero] at heval
+  exact heval.symm
+
+variable {K : Type*} [Field K]
+
+private theorem eval_map_evalRingHom_resLiftOuterK (Φ' : Polynomial (Polynomial ℤ))
+    (b c : K) :
+    ((resLiftOuterK K Φ').map (Polynomial.evalRingHom c)).eval b
+      = evalModularPair b c Φ' :=
+  calc ((resLiftOuterK K Φ').map (Polynomial.evalRingHom c)).eval b
+      = (resLiftOuterK K Φ').eval₂ (Polynomial.evalRingHom c)
+          ((Polynomial.evalRingHom c) (Polynomial.C b)) := by
+        rw [Polynomial.eval_map, Polynomial.coe_evalRingHom, Polynomial.eval_C]
+    _ = (Polynomial.evalRingHom c) ((resLiftOuterK K Φ').eval (Polynomial.C b)) :=
+        Polynomial.eval₂_hom _ _
+    _ = evalModularPair b c Φ' := by
+        rw [eval_C_resLiftOuterK, Polynomial.coe_evalRingHom,
+          evalModularPair_eq_eval_fibrePoly]
+
+private theorem evalModularPair_biResultant_eq_zero_of_common
+    {Φ Φ' : Polynomial (Polynomial ℤ)} (hΦ : Φ.Monic) (hΦpos : Φ.natDegree ≠ 0)
+    {a b c : K} (hab : evalModularPair a b Φ = 0) (hbc : evalModularPair b c Φ' = 0) :
+    evalModularPair a c (biResultant Φ Φ') = 0 := by
+  rw [evalModularPair_eq_eval_fibrePoly, ← specializeAt_eq_fibrePoly, biResultant,
+    ← Polynomial.resultant_map_map, map_resLiftInner, map_resLiftOuter,
+    show Polynomial.eval c
+        = ⇑(Polynomial.evalRingHom c : Polynomial K →+* K) from rfl,
+    ← Polynomial.resultant_map_map, Polynomial.map_map]
+  rw [show (Polynomial.evalRingHom c).comp (Polynomial.C : K →+* Polynomial K)
+        = RingHom.id K from
+      RingHom.ext fun _ => Polynomial.eval_C,
+    Polynomial.map_id]
+  refine Polynomial.resultant_eq_zero_of_isRoot_isRoot
+    (b := b)
+    ?_ ?_ (natDegree_fibrePoly hΦ a).le ?_ (Or.inl hΦpos)
+  · rw [Polynomial.IsRoot, ← evalModularPair_eq_eval_fibrePoly]
+    exact hab
+  · rw [Polynomial.IsRoot, eval_map_evalRingHom_resLiftOuterK]
+    exact hbc
+  · exact Polynomial.natDegree_map_le.trans (natDegree_resLiftOuterK_le Φ' a)
+
+end Engine
+
+section QExpansion
+
+namespace ModularPolynomialData
+p2m_export "ModularCurve.ModularPolynomialData" "monic eval_eq_zero natDegree_eq Φ"
+end ModularPolynomialData
+namespace ModularPolynomialData
+p2m_open_scoped "ModularCurve.ModularPolynomialData" in
+private theorem _root_.ModularCurve.ModularPolynomialData.eval₂_qExpand_eq_zero {N : ℕ} [NeZero N]
+    (data : ModularPolynomialData N) (ℓ : ℕ) [NeZero ℓ] :
+    data.Φ.eval₂ ((qExpand ℚ ℓ).comp evalAtJ) (jqN (ℓ * N)) = 0 := by
+  have h := congrArg (qExpand ℚ ℓ) data.eval_eq_zero
+  rw [map_zero, Polynomial.hom_eval₂] at h
+  rwa [show qExpand ℚ ℓ (jqN N) = jqN (ℓ * N) from qExpand_qExpand N ℓ jq] at h
+
+end ModularPolynomialData
+p2m_export "ModularCurve" "ModularPolynomialData.eval₂_qExpand_eq_zero"
+
+private theorem evalAtJ_eq_eval₂RingHom_intCast_jq :
+    evalAtJ = Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries ℚ)) jq := by
+  refine Polynomial.ringHom_ext' ?_ ?_
+  · exact Subsingleton.elim _ _
+  · rw [evalAtJ_X, Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X]
+
+private theorem qExpand_comp_evalAtJ_eq_eval₂RingHom (m : ℕ) [NeZero m] :
+    (qExpand ℚ m).comp evalAtJ
+      = Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries ℚ)) (jqN m) := by
+  refine Polynomial.ringHom_ext' ?_ ?_
+  · exact Subsingleton.elim _ _
+  · rw [RingHom.comp_apply, evalAtJ_X, Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X]
+    rfl
+
+namespace ModularPolynomialData
+p2m_open_scoped "ModularCurve.ModularPolynomialData" in
+private theorem _root_.ModularCurve.ModularPolynomialData.eval₂_biResultant_eq_zero {m n : ℕ}
+    [NeZero m]
+    [NeZero n] (data : ModularPolynomialData m) (data' : ModularPolynomialData n) :
+    (biResultant data.Φ data'.Φ).eval₂ evalAtJ (jqN (m * n)) = 0 := by
+  rw [evalAtJ_eq_eval₂RingHom_intCast_jq,
+    show (biResultant data.Φ data'.Φ).eval₂
+          (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries ℚ)) jq) (jqN (m * n))
+        = evalModularPair jq (jqN (m * n)) (biResultant data.Φ data'.Φ) from rfl]
+  have hmpos : data.Φ.natDegree ≠ 0 := by
+    rw [data.natDegree_eq]
+    exact (dedekindPsi_pos m (NeZero.ne m)).ne'
+  refine evalModularPair_biResultant_eq_zero_of_common data.monic hmpos
+    (b := jqN m) ?_ ?_
+  · change data.Φ.eval₂ (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries ℚ)) jq)
+        (jqN m) = 0
+    rw [← evalAtJ_eq_eval₂RingHom_intCast_jq]
+    exact data.eval_eq_zero
+  · change data'.Φ.eval₂
+        (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries ℚ)) (jqN m))
+        (jqN (m * n)) = 0
+    rw [← qExpand_comp_evalAtJ_eq_eval₂RingHom]
+    exact data'.eval₂_qExpand_eq_zero m
+
+end ModularPolynomialData
+p2m_export "ModularCurve" "ModularPolynomialData.eval₂_biResultant_eq_zero"
+end QExpansion
+
+namespace ModularPolynomialData
+p2m_open_scoped "ModularCurve.ModularPolynomialData" in
+private def _root_.ModularCurve.ModularPolynomialData.biResultantPacket {m n : ℕ} [NeZero m]
+    [NeZero n]
+    (data : ModularPolynomialData m) (data' : ModularPolynomialData n)
+    (hmn : Nat.Coprime m n) :
+    ModularPolynomialData (m * n) where
+  Φ := biResultant data.Φ data'.Φ
+  monic := monic_biResultant data.monic data'.monic
+  natDegree_eq := by
+    rw [natDegree_biResultant data.monic data'.monic, data.natDegree_eq, data'.natDegree_eq,
+      dedekindPsi_mul_of_coprime m n hmn]
+  eval_eq_zero := data.eval₂_biResultant_eq_zero data'
+
+end ModularPolynomialData
+p2m_export "ModularCurve" "ModularPolynomialData.biResultantPacket"
+
+theorem nonempty_modularPolynomialData_mul_of_coprime {m n : ℕ} [NeZero m] [NeZero n]
+    (data : ModularPolynomialData m) (data' : ModularPolynomialData n)
+    (hmn : Nat.Coprime m n) : Nonempty (ModularPolynomialData (m * n)) :=
+  ⟨data.biResultantPacket data' hmn⟩
+
+private def castModularPolynomialData {M N : ℕ} [NeZero M] [NeZero N] (h : M = N)
+    (d : ModularPolynomialData M) : ModularPolynomialData N where
+  Φ := d.Φ
+  monic := d.monic
+  natDegree_eq := h ▸ d.natDegree_eq
+  eval_eq_zero := h ▸ d.eval_eq_zero
+
+private def primePacket (p : ℕ) [NeZero p] (hp : p.Prime) : ModularPolynomialData p :=
+  (modularPolynomialFamily p hp).choose
+
+private def modularPolynomialDataSquarefree (N : ℕ) [NeZero N] (hsf : Squarefree N)
+    (hN : 1 < N) : ModularPolynomialData N :=
+  let p := N.minFac
+  have hp : p.Prime := Nat.minFac_prime (by omega)
+  have hpdvd : p ∣ N := Nat.minFac_dvd N
+  have heq : p * (N / p) = N := Nat.mul_div_cancel' hpdvd
+  haveI : NeZero p := ⟨hp.pos.ne'⟩
+  have hq_pos : 0 < N / p := Nat.div_pos (Nat.le_of_dvd (by omega) hpdvd) hp.pos
+  haveI : NeZero (N / p) := ⟨hq_pos.ne'⟩
+  have hcop : Nat.Coprime p (N / p) := by
+    rw [hp.coprime_iff_not_dvd]
+    intro hd
+    have h2 : p * p ∣ N := heq ▸ mul_dvd_mul_left p hd
+    exact hp.ne_one (Nat.isUnit_iff.mp (hsf p h2))
+  have hsf' : Squarefree (N / p) :=
+    hsf.squarefree_of_dvd ⟨p, (Nat.div_mul_cancel hpdvd).symm⟩
+  if h1 : N / p = 1 then
+    castModularPolynomialData (by rw [h1, mul_one] at heq; exact heq) (primePacket p hp)
+  else
+    have hN' : 1 < N / p := by omega
+    castModularPolynomialData heq
+      ((primePacket p hp).biResultantPacket
+        (modularPolynomialDataSquarefree (N / p) hsf' hN') hcop)
+termination_by N
+decreasing_by exact Nat.div_lt_self (by omega) hp.one_lt
+
+private theorem nonempty_modularPolynomialData_of_squarefree (N : ℕ) [NeZero N]
+    (hsf : Squarefree N) (hN : 1 < N) : Nonempty (ModularPolynomialData N) :=
+  ⟨modularPolynomialDataSquarefree N hsf hN⟩
+
+end ModularCurve
+end
+
+open _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_nonempty_modularPolynomialData_of_squarefree.ModularCurve
+  ModularCurve.PhiGen in
+theorem solution (N : ℕ) [NeZero N] (hsf : Squarefree N) (hN : 1 < N) :
+    Nonempty (ModularPolynomialData N) :=
+  ModularCurve.nonempty_modularPolynomialData_of_squarefree N hsf hN
+
+end S_ModularCurve_nonempty_modularPolynomialData_of_squarefree
+end P2MW
+export P2MW.S_ModularCurve_nonempty_modularPolynomialData_of_squarefree (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.nonempty_modularPolynomialData_of_squarefree (N : ℕ) [NeZero N]
+    (hsf : Squarefree N) (hN : 1 < N) :
+    Nonempty (ModularPolynomialData N) :=
+  solution N hsf hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_one_le_coeff_jq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_one_le_coeff_jq.lean
new file mode 100644
index 0000000000..be7b47856e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_one_le_coeff_jq.lean
@@ -0,0 +1,446 @@
+/-
+Based on Prove2Me node ModularCurve.one_le_coeff_jq
+(1a092aee-6c1c-510a-a2b0-6a3ed4219d58) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c7a99add-fe2c-5381-9052-63b26fc74c52
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import Mathlib.Algebra.Order.BigOperators.Group.Finset
+import Mathlib.Algebra.BigOperators.Intervals
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Every nonnegative q-coefficient of j is at least 1
+
+Theorem statement: `ModularCurve.one_le_coeff_jq` (`1a092aee-6c1c-510a-a2b0-6a3ed4219d58`), by
+Claude, 2026-09-05.
+
+Proof: submission `c7a99add-fe2c-5381-9052-63b26fc74c52`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $n$ be a natural number. The assertion is that the coefficient of the $q$-expansion `jq` at the
+integer index $(n : \mathbb{Z})$ is at least $1$ as a rational number, i.e. $1 \le
+\mathrm{coeff}_{n}(\mathtt{jq})$. Here `jq` is the formal $q$-expansion of the modular $j$-invariant
+as set up in the project, a series with rational coefficients indexed by $\mathbb{Z}$, whose
+coefficients at the indices $0, 1, 2, \dots$ are the classical values $744, 196884, 21493760,
+\dots$; the statement ranges only over nonnegative indices, so it says nothing about the coefficient
+at $-1$ (the leading $q^{-1}$ term) or at other negative indices, and it records only the inequality
+$\ge 1$ rather than integrality or the exact values. In particular every coefficient of `jq` in
+nonnegative degree is nonzero and positive.
+
+This positivity bound replaces the classical fact that the $q$-expansion $j(q) = q^{-1} + 744 +
+196884q + \cdots$ has positive integral coefficients, in the weak form needed downstream. It is used
+to separate $j(q^{\ell})$ from the subfield generated by $j(q)$, and thence in the irreducibility
+and splitting statements for the modular polynomial $\Phi_\ell$
+([`ModularCurve.PhiGen.evalSymm_of_splits`](thm.html#ModularCurve.PhiGen.evalSymm_of_splits),
+[`ModularCurve.PhiGen.phiIrreducible_of_splits`]
+(thm.html#ModularCurve.PhiGen.phiIrreducible_of_splits),
+[`ModularCurve.jqNModC_prime_not_mem_adjoin_of_charZero`]
+(thm.html#ModularCurve.jqNModC_prime_not_mem_adjoin_of_charZero)).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_one_le_coeff_jq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_one_le_coeff_jq
+
+noncomputable section
+
+open scoped PowerSeries.WithPiTopology
+
+open PowerSeries Finset
+
+namespace ModularCurve
+p2m_export "ModularCurve" "eisenstein4 constantCoeff_eisenstein4 etaProd dedekindEtaUnit \
+  dedekindEtaUnitInv dedekindEtaUnit_mul_inv jNum jNumQ jq"
+p2m_open "ModularCurve"
+
+private theorem coeff_one_sub_X_pow_of_lt {R : Type*} [CommRing R] {e m : ℕ} (h : m < e) :
+    PowerSeries.coeff m ((1 : PowerSeries R) - X ^ e) = if m = 0 then 1 else 0 := by
+  rw [map_sub, PowerSeries.coeff_one, PowerSeries.coeff_X_pow, ite_eq_right (Nat.ne_of_lt h),
+    sub_zero]
+
+private theorem coeff_prod_one_sub_X_pow_eq_coeff_one {R : Type*} [CommRing R]
+    {ι : Type*} {n : ℕ} (s : Finset ι) (e : ι → ℕ)
+    (he : ∀ i ∈ s, n < e i) :
+    ∀ m ≤ n, PowerSeries.coeff m (∏ i ∈ s, ((1 : PowerSeries R) - X ^ e i)) =
+      if m = 0 then 1 else 0 := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => intro m _; simp [PowerSeries.coeff_one]
+  | @insert a s ha ih =>
+    intro m hm
+    rw [Finset.prod_insert ha, PowerSeries.coeff_mul]
+    have hea : n < e a := he a (Finset.mem_insert_self a s)
+    have hsum :
+        ∀ p ∈ Finset.HasAntidiagonal.antidiagonal m,
+          PowerSeries.coeff p.1 ((1 : PowerSeries R) - X ^ e a) *
+              PowerSeries.coeff p.2 (∏ i ∈ s, ((1 : PowerSeries R) - X ^ e i)) =
+            if p.1 = 0 then
+              PowerSeries.coeff p.2 (∏ i ∈ s, ((1 : PowerSeries R) - X ^ e i)) else 0 := by
+      intro p hp
+      have hp1 : p.1 ≤ m := Finset.HasAntidiagonal.antidiagonal.fst_le hp
+      rw [coeff_one_sub_X_pow_of_lt (lt_of_le_of_lt (le_trans hp1 hm) hea)]
+      by_cases h0 : p.1 = 0
+      · rw [ite_eq_left h0, ite_eq_left h0, one_mul]
+      · rw [ite_eq_right h0, ite_eq_right h0, zero_mul]
+    rw [Finset.sum_congr rfl hsum]
+    rw [Finset.sum_eq_single_of_mem (0, m) (by simp)]
+    · rw [ite_eq_left rfl]
+      exact ih (fun i hi => he i (Finset.mem_insert_of_mem hi)) m hm
+    · rintro ⟨b₁, b₂⟩ hb hne
+      have hb' : b₁ + b₂ = m := Finset.HasAntidiagonal.mem_antidiagonal.mp hb
+      have : b₁ ≠ 0 := by
+        rintro rfl
+        exact hne (by simp [← hb'])
+      rw [ite_eq_right this]
+
+private theorem coeff_prod_one_sub_pow_le {R : Type*} [CommRing R] (k n : ℕ) (h : n ≤ k) :
+    PowerSeries.coeff n
+        (∏ i ∈ Finset.range (k + 1), ((1 : PowerSeries R) - X ^ (i + 1))) =
+      PowerSeries.coeff n
+        (∏ i ∈ Finset.range (n + 1), ((1 : PowerSeries R) - X ^ (i + 1))) := by
+  classical
+  have hsplit :
+      (∏ i ∈ Finset.range (k + 1), ((1 : PowerSeries R) - X ^ (i + 1))) =
+        (∏ i ∈ Finset.range (n + 1), ((1 : PowerSeries R) - X ^ (i + 1))) *
+          ∏ i ∈ Finset.Ico (n + 1) (k + 1), ((1 : PowerSeries R) - X ^ (i + 1)) := by
+    rw [Finset.range_eq_Ico, Finset.range_eq_Ico,
+      Finset.prod_Ico_consecutive _ (Nat.zero_le _) (Nat.succ_le_succ h)]
+  rw [hsplit, PowerSeries.coeff_mul]
+  have htail : ∀ m ≤ n,
+      PowerSeries.coeff m
+          (∏ i ∈ Finset.Ico (n + 1) (k + 1), ((1 : PowerSeries R) - X ^ (i + 1))) =
+        if m = 0 then 1 else 0 := by
+    refine coeff_prod_one_sub_X_pow_eq_coeff_one _ _ ?_
+    intro i hi
+    have : n + 1 ≤ i := (Finset.mem_Ico.mp hi).1
+    omega
+  rw [Finset.sum_eq_single_of_mem (n, 0) (by simp)]
+  · rw [htail 0 (Nat.zero_le n), ite_eq_left rfl, mul_one]
+  · rintro ⟨b₁, b₂⟩ hb hne
+    have hb' : b₁ + b₂ = n := Finset.HasAntidiagonal.mem_antidiagonal.mp hb
+    have hb₂ : b₂ ≤ n := Finset.HasAntidiagonal.antidiagonal.snd_le hb
+    have : b₂ ≠ 0 := by
+      rintro rfl
+      exact hne (by simp [← hb'])
+    rw [htail b₂ hb₂, ite_eq_right this, mul_zero]
+
+private theorem coeff_etaProd_eq_coeff_partialProd (n : ℕ) :
+    PowerSeries.coeff n etaProd =
+      PowerSeries.coeff n
+        (∏ i ∈ Finset.range (n + 1), (1 - X ^ (i + 1) : PowerSeries ℤ)) := by
+  classical
+  have hconv : Filter.Tendsto
+      (fun s : Finset ℕ =>
+        PowerSeries.coeff n (∏ i ∈ s, (1 - X ^ (i + 1) : PowerSeries ℤ)))
+      Filter.atTop (nhds (PowerSeries.coeff n etaProd)) := by
+    have h0 : Filter.Tendsto
+        (fun s : Finset ℕ => ∏ i ∈ s, (1 - X ^ (i + 1) : PowerSeries ℤ))
+        Filter.atTop (nhds etaProd) :=
+      (PowerSeries.WithPiTopology.multipliable_one_sub_X_pow ℤ).hasProd
+    exact (PowerSeries.WithPiTopology.tendsto_iff_coeff_tendsto _ _ _ _).mp h0 n
+  rw [show nhds (PowerSeries.coeff n etaProd) = pure (PowerSeries.coeff n etaProd) from
+      congrFun (nhds_discrete ℤ) _,
+    Filter.tendsto_pure] at hconv
+  obtain ⟨t₀, ht₀⟩ := Filter.eventually_atTop.mp hconv
+  rw [← ht₀ (t₀ ∪ Finset.range (n + 1)) Finset.subset_union_left]
+  rw [show t₀ ∪ Finset.range (n + 1)
+        = Finset.range (n + 1) ∪ (t₀ \ Finset.range (n + 1)) by
+      rw [Finset.union_sdiff_self_eq_union, Finset.union_comm],
+    Finset.prod_union Finset.disjoint_sdiff, PowerSeries.coeff_mul]
+  have htail : ∀ m ≤ n,
+      PowerSeries.coeff m
+          (∏ i ∈ t₀ \ Finset.range (n + 1), (1 - X ^ (i + 1) : PowerSeries ℤ)) =
+        if m = 0 then 1 else 0 := by
+    refine coeff_prod_one_sub_X_pow_eq_coeff_one _ _ (fun i hi => ?_)
+    have hi' : ¬ i < n + 1 := fun h => (Finset.mem_sdiff.mp hi).2 (Finset.mem_range.mpr h)
+    omega
+  rw [Finset.sum_eq_single_of_mem (n, 0) (by simp)]
+  · rw [htail 0 (Nat.zero_le n), ite_eq_left rfl, mul_one]
+  · rintro ⟨b₁, b₂⟩ hb hne
+    have hb' : b₁ + b₂ = n := Finset.HasAntidiagonal.mem_antidiagonal.mp hb
+    have hb₂ : b₂ ≤ n := Finset.HasAntidiagonal.antidiagonal.snd_le hb
+    have h2 : b₂ ≠ 0 := by
+      rintro rfl
+      exact hne (by simp [← hb'])
+    rw [htail b₂ hb₂, ite_eq_right h2, mul_zero]
+
+private theorem coeff_jq_eq_coeff_jNum (n : ℕ) :
+    jq.coeff ((n : ℤ) - 1) = ((PowerSeries.coeff n jNum : ℤ) : ℚ) := by
+  rw [jq, HahnSeries.coeff_single_mul, one_mul,
+    show ((n : ℤ) - 1 - (-1) : ℤ) = ((n : ℕ) : ℤ) by ring,
+    HahnSeries.ofPowerSeries_apply_coeff, jNumQ, PowerSeries.coeff_map]
+  simp
+
+private def geomSeries (d : ℕ) : PowerSeries ℤ :=
+  PowerSeries.mk fun k => if d ∣ k then 1 else 0
+
+@[scoped simp]
+private theorem coeff_geomSeries (d k : ℕ) :
+    PowerSeries.coeff k (geomSeries d) = if d ∣ k then 1 else 0 := by
+  rw [geomSeries, PowerSeries.coeff_mk]
+
+@[scoped simp]
+private theorem constantCoeff_geomSeries (d : ℕ) :
+    PowerSeries.constantCoeff (geomSeries d) = 1 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff, coeff_geomSeries, ite_eq_left (dvd_zero d)]
+
+private theorem coeff_geomSeries_nonneg (d k : ℕ) :
+    0 ≤ PowerSeries.coeff k (geomSeries d) := by
+  rw [coeff_geomSeries]
+  split <;> norm_num
+
+private theorem coeff_geomSeries_one (k : ℕ) :
+    PowerSeries.coeff k (geomSeries 1) = 1 := by
+  rw [coeff_geomSeries, ite_eq_left (one_dvd k)]
+
+private theorem one_sub_X_pow_mul_geomSeries {d : ℕ} (hd : d ≠ 0) :
+    ((1 : PowerSeries ℤ) - X ^ d) * geomSeries d = 1 := by
+  ext n
+  rw [sub_mul, one_mul, map_sub, ← mul_comm (geomSeries d) (X ^ d),
+    PowerSeries.coeff_mul_X_pow', coeff_geomSeries, PowerSeries.coeff_one]
+  by_cases hdn : d ≤ n
+  · have hn0 : ¬ (n = 0) := by omega
+    rw [ite_eq_left hdn, coeff_geomSeries, ite_eq_right hn0]
+    have hiff : d ∣ n ↔ d ∣ n - d := by
+      constructor
+      · intro h; exact Nat.dvd_sub h dvd_rfl
+      · intro h
+        have := Nat.dvd_add h (dvd_refl d)
+        rwa [Nat.sub_add_cancel hdn] at this
+    by_cases h : d ∣ n
+    · rw [ite_eq_left h, ite_eq_left (hiff.mp h), sub_self]
+    · rw [ite_eq_right h, ite_eq_right (fun hc => h (hiff.mpr hc)), sub_self]
+  · rw [ite_eq_right hdn, sub_zero]
+    by_cases hn : n = 0
+    · subst hn; rw [ite_eq_left (dvd_zero d), ite_eq_left rfl]
+    · rw [ite_eq_right hn, ite_eq_right (fun hc => hdn (Nat.le_of_dvd (Nat.pos_of_ne_zero hn) hc))]
+
+private theorem coeff_mul_nonneg {f g : PowerSeries ℤ}
+    (hf : ∀ k, 0 ≤ PowerSeries.coeff k f) (hg : ∀ k, 0 ≤ PowerSeries.coeff k g) (n : ℕ) :
+    0 ≤ PowerSeries.coeff n (f * g) := by
+  rw [PowerSeries.coeff_mul]
+  exact Finset.sum_nonneg fun p _ => mul_nonneg (hf p.1) (hg p.2)
+
+private theorem coeff_prod_nonneg {ι : Type*} (s : Finset ι) (f : ι → PowerSeries ℤ)
+    (hf : ∀ i ∈ s, ∀ k, 0 ≤ PowerSeries.coeff k (f i)) :
+    ∀ n, 0 ≤ PowerSeries.coeff n (∏ i ∈ s, f i) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty =>
+    intro n
+    rw [Finset.prod_empty, PowerSeries.coeff_one]
+    split <;> norm_num
+  | @insert a s ha ih =>
+    intro n
+    rw [Finset.prod_insert ha]
+    exact coeff_mul_nonneg (hf a (Finset.mem_insert_self a s))
+      (ih (fun i hi => hf i (Finset.mem_insert_of_mem hi))) n
+
+private theorem coeff_pow_nonneg {f : PowerSeries ℤ}
+    (hf : ∀ k, 0 ≤ PowerSeries.coeff k f) (m : ℕ) :
+    ∀ n, 0 ≤ PowerSeries.coeff n (f ^ m) := by
+  induction m with
+  | zero =>
+    intro n
+    rw [pow_zero, PowerSeries.coeff_one]
+    split <;> norm_num
+  | succ m ih =>
+    intro n
+    rw [pow_succ]
+    exact coeff_mul_nonneg ih hf n
+
+private theorem one_le_coeff_mul_of_nonneg {f g : PowerSeries ℤ}
+    (hf : ∀ k, 0 ≤ PowerSeries.coeff k f) (hf0 : PowerSeries.constantCoeff f = 1)
+    (hg : ∀ k, 1 ≤ PowerSeries.coeff k g) (n : ℕ) :
+    1 ≤ PowerSeries.coeff n (f * g) := by
+  rw [PowerSeries.coeff_mul]
+  have hmem : ((0 : ℕ), n) ∈ Finset.HasAntidiagonal.antidiagonal n := by simp
+  have hterm : (1 : ℤ) ≤ PowerSeries.coeff (0 : ℕ) f * PowerSeries.coeff n g := by
+    rw [PowerSeries.coeff_zero_eq_constantCoeff, hf0, one_mul]
+    exact hg n
+  calc (1 : ℤ) ≤ PowerSeries.coeff (0 : ℕ) f * PowerSeries.coeff n g := hterm
+    _ ≤ ∑ p ∈ Finset.HasAntidiagonal.antidiagonal n, PowerSeries.coeff p.1 f * PowerSeries.coeff p.2
+      g :=
+        Finset.single_le_sum
+          (fun p _ => mul_nonneg (hf p.1) (le_trans zero_le_one (hg p.2))) hmem
+
+private theorem one_le_coeff_mul {f g : PowerSeries ℤ}
+    (hf : ∀ k, 1 ≤ PowerSeries.coeff k f) (hg : ∀ k, 1 ≤ PowerSeries.coeff k g) (n : ℕ) :
+    1 ≤ PowerSeries.coeff n (f * g) := by
+  rw [PowerSeries.coeff_mul]
+  have hmem : ((0 : ℕ), n) ∈ Finset.HasAntidiagonal.antidiagonal n := by simp
+  calc (1 : ℤ) = 1 * 1 := (one_mul 1).symm
+    _ ≤ PowerSeries.coeff (0 : ℕ) f * PowerSeries.coeff n g :=
+        mul_le_mul (hf 0) (hg n) zero_le_one (le_trans zero_le_one (hf 0))
+    _ ≤ ∑ p ∈ Finset.HasAntidiagonal.antidiagonal n, PowerSeries.coeff p.1 f * PowerSeries.coeff p.2
+      g :=
+        Finset.single_le_sum
+          (fun p _ => mul_nonneg (le_trans zero_le_one (hf p.1))
+            (le_trans zero_le_one (hg p.2))) hmem
+
+private theorem one_le_coeff_pow {f : PowerSeries ℤ}
+    (hf : ∀ k, 1 ≤ PowerSeries.coeff k f) (m : ℕ) :
+    ∀ n, 1 ≤ PowerSeries.coeff n (f ^ (m + 1)) := by
+  induction m with
+  | zero => intro n; simpa using hf n
+  | succ m ih => intro n; rw [pow_succ]; exact one_le_coeff_mul ih hf n
+
+private theorem coeff_mul_congr {A C g : PowerSeries ℤ} {n : ℕ}
+    (h : ∀ k ≤ n, PowerSeries.coeff k A = PowerSeries.coeff k C) :
+    ∀ k ≤ n, PowerSeries.coeff k (A * g) = PowerSeries.coeff k (C * g) := by
+  intro k hk
+  rw [PowerSeries.coeff_mul, PowerSeries.coeff_mul]
+  refine Finset.sum_congr rfl fun p hp => ?_
+  have h1 : p.1 ≤ k := Finset.HasAntidiagonal.antidiagonal.fst_le hp
+  rw [h p.1 (le_trans h1 hk)]
+
+private theorem coeff_pow_congr {A C : PowerSeries ℤ} {n : ℕ}
+    (h : ∀ k ≤ n, PowerSeries.coeff k A = PowerSeries.coeff k C) (m : ℕ) :
+    ∀ k ≤ n, PowerSeries.coeff k (A ^ m) = PowerSeries.coeff k (C ^ m) := by
+  induction m with
+  | zero => intro k _; rfl
+  | succ m ih =>
+    intro k hk
+    rw [pow_succ, pow_succ, PowerSeries.coeff_mul, PowerSeries.coeff_mul]
+    refine Finset.sum_congr rfl fun p hp => ?_
+    have h1 : p.1 ≤ k := Finset.HasAntidiagonal.antidiagonal.fst_le hp
+    have h2 : p.2 ≤ k := Finset.HasAntidiagonal.antidiagonal.snd_le hp
+    rw [ih p.1 (le_trans h1 hk), h p.2 (le_trans h2 hk)]
+
+private theorem coeff_inv_congr {A B C D : PowerSeries ℤ}
+    (hAB : A * B = 1) (hCD : C * D = 1) {n : ℕ}
+    (h : ∀ k ≤ n, PowerSeries.coeff k A = PowerSeries.coeff k C) :
+    ∀ k ≤ n, PowerSeries.coeff k B = PowerSeries.coeff k D := by
+  intro k hk
+  have hCB : ∀ m ≤ n, PowerSeries.coeff m (C * B) =
+      PowerSeries.coeff m (1 : PowerSeries ℤ) := by
+    intro m hm
+    rw [← hAB]
+    exact (coeff_mul_congr (fun k hk => (h k hk).symm) m hm)
+  have key : B = D * (C * B) := by
+    rw [← mul_assoc, mul_comm D C, hCD, one_mul]
+  rw [key, PowerSeries.coeff_mul]
+  rw [Finset.sum_eq_single_of_mem (k, 0) (by simp)]
+  · rw [hCB 0 (Nat.zero_le n), PowerSeries.coeff_one, ite_eq_left rfl, mul_one]
+  · rintro ⟨b₁, b₂⟩ hb hne
+    have hb' : b₁ + b₂ = k := Finset.HasAntidiagonal.mem_antidiagonal.mp hb
+    have hb₂ : b₂ ≤ k := Finset.HasAntidiagonal.antidiagonal.snd_le hb
+    have h2 : b₂ ≠ 0 := by
+      rintro rfl
+      exact hne (by simp [← hb'])
+    rw [hCB b₂ (le_trans hb₂ hk), PowerSeries.coeff_one, ite_eq_right h2, mul_zero]
+
+private abbrev partialEta (N : ℕ) : PowerSeries ℤ :=
+  ∏ i ∈ Finset.range N, ((1 : PowerSeries ℤ) - X ^ (i + 1))
+
+private abbrev partialGeom (N : ℕ) : PowerSeries ℤ :=
+  ∏ i ∈ Finset.range N, geomSeries (i + 1)
+
+private theorem partialEta_mul_partialGeom (N : ℕ) :
+    partialEta N * partialGeom N = 1 := by
+  rw [← Finset.prod_mul_distrib]
+  rw [Finset.prod_congr rfl
+    (fun i _ => one_sub_X_pow_mul_geomSeries (Nat.succ_ne_zero i))]
+  exact Finset.prod_const_one
+
+private theorem coeff_etaProd_eq_coeff_partialEta {k n : ℕ} (hk : k ≤ n) :
+    PowerSeries.coeff k etaProd = PowerSeries.coeff k (partialEta (n + 1)) := by
+  rw [coeff_etaProd_eq_coeff_partialProd k]
+  exact (coeff_prod_one_sub_pow_le n k hk).symm
+
+private theorem coeff_dedekindEtaUnitInv_eq_coeff_partialGeom_pow (n : ℕ) :
+    ∀ k ≤ n, PowerSeries.coeff k dedekindEtaUnitInv =
+      PowerSeries.coeff k (partialGeom (n + 1) ^ 24) := by
+  have hunits : ∀ k ≤ n, PowerSeries.coeff k dedekindEtaUnit =
+      PowerSeries.coeff k (partialEta (n + 1) ^ 24) := by
+    intro k hk
+    rw [dedekindEtaUnit]
+    exact coeff_pow_congr (fun k hk => coeff_etaProd_eq_coeff_partialEta hk) 24 k hk
+  have hinv : partialEta (n + 1) ^ 24 * partialGeom (n + 1) ^ 24 = 1 := by
+    rw [← mul_pow, partialEta_mul_partialGeom, one_pow]
+  exact coeff_inv_congr dedekindEtaUnit_mul_inv hinv hunits
+
+private theorem one_le_coeff_partialGeom_pow (n k : ℕ) :
+    1 ≤ PowerSeries.coeff k (partialGeom (n + 1) ^ 24) := by
+  have hsplit : partialGeom (n + 1) =
+      (∏ i ∈ Finset.range n, geomSeries (i + 2)) * geomSeries 1 :=
+    Finset.prod_range_succ' (fun i => geomSeries (i + 1)) n
+  rw [hsplit, mul_pow]
+  have htail_nonneg : ∀ j, 0 ≤ PowerSeries.coeff j
+      ((∏ i ∈ Finset.range n, geomSeries (i + 2)) ^ 24) :=
+    coeff_pow_nonneg
+      (coeff_prod_nonneg _ _ (fun i _ k => coeff_geomSeries_nonneg (i + 2) k)) 24
+  have htail_cc : PowerSeries.constantCoeff
+      ((∏ i ∈ Finset.range n, geomSeries (i + 2)) ^ 24) = 1 := by
+    rw [map_pow, map_prod]
+    simp only [constantCoeff_geomSeries, Finset.prod_const_one, one_pow]
+  have hhead : ∀ j, 1 ≤ PowerSeries.coeff j (geomSeries 1 ^ 24) :=
+    one_le_coeff_pow (fun j => le_of_eq (coeff_geomSeries_one j).symm) 23
+  exact one_le_coeff_mul_of_nonneg htail_nonneg htail_cc hhead k
+
+private theorem one_le_coeff_dedekindEtaUnitInv (n : ℕ) :
+    1 ≤ PowerSeries.coeff n dedekindEtaUnitInv := by
+  rw [coeff_dedekindEtaUnitInv_eq_coeff_partialGeom_pow n n le_rfl]
+  exact one_le_coeff_partialGeom_pow n n
+
+private theorem coeff_eisenstein4_nonneg (n : ℕ) :
+    0 ≤ PowerSeries.coeff n eisenstein4 := by
+  rw [eisenstein4, PowerSeries.coeff_mk]
+  split
+  · norm_num
+  · refine mul_nonneg (by norm_num) (Finset.sum_nonneg fun d _ => ?_)
+    exact pow_nonneg (Int.natCast_nonneg d) 3
+
+private theorem one_le_coeff_jNum (n : ℕ) : 1 ≤ PowerSeries.coeff n jNum := by
+  rw [jNum]
+  exact one_le_coeff_mul_of_nonneg (coeff_pow_nonneg coeff_eisenstein4_nonneg 3)
+    (by rw [map_pow, constantCoeff_eisenstein4, one_pow])
+    one_le_coeff_dedekindEtaUnitInv n
+
+theorem one_le_coeff_jq' (n : ℕ) : (1 : ℚ) ≤ jq.coeff (n : ℤ) := by
+  have h : ((n : ℤ)) = ((n + 1 : ℕ) : ℤ) - 1 := by push_cast; ring
+  rw [h, coeff_jq_eq_coeff_jNum]
+  exact_mod_cast one_le_coeff_jNum (n + 1)
+
+theorem coeff_jq_ne_zero (n : ℕ) : jq.coeff (n : ℤ) ≠ 0 :=
+  ne_of_gt (lt_of_lt_of_le zero_lt_one (one_le_coeff_jq' n))
+
+end ModularCurve
+
+theorem solution (n : ℕ) : (1 : ℚ) ≤ ModularCurve.jq.coeff (n : ℤ) :=
+  ModularCurve.one_le_coeff_jq' n
+
+end
+end S_ModularCurve_one_le_coeff_jq
+end P2MW
+export P2MW.S_ModularCurve_one_le_coeff_jq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.one_le_coeff_jq (n : ℕ) :
+    (1 : ℚ) ≤ jq.coeff (n : ℤ) :=
+  solution n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_cuspInftyBar.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_cuspInftyBar.lean
new file mode 100644
index 0000000000..ff65b095e6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_cuspInftyBar.lean
@@ -0,0 +1,84 @@
+/-
+Based on Prove2Me node ModularCurve.ord_cuspInftyBar
+(f78dd74f-c083-5354-9c07-2743db46778f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 110fbe58-b8e6-5d21-9b21-574cbec2ab2f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_AtkinLehner
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_qInftyPlaceBar
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order at the cusp ∞ is the q-order
+
+Theorem statement: `ModularCurve.ord_cuspInftyBar` (`f78dd74f-c083-5354-9c07-2743db46778f`), by
+Claude, 2026-09-05.
+
+Proof: submission `110fbe58-b8e6-5d21-9b21-574cbec2ab2f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a positive natural number and let $f$ be an element of `modularFunctionFieldBar N`, the
+intermediate field $\overline{\mathbb{Q}} \subseteq \overline{\mathbb{Q}}((q))$ obtained as
+`laurentBaseChange` of `modularFunctionFieldFull N`, that is, the subfield of
+$\overline{\mathbb{Q}}((q))$ generated over $\overline{\mathbb{Q}}$ by the coefficientwise images
+under `coeffEmb` of the $\mathbb{Q}$-subfield $\mathbb{Q}(\,\mathrm{divisorExpansions}\,N\,)
+\subseteq \mathbb{Q}((q))$. On this field `cuspInftyBar N` is the place in the sense of the
+project's `Place` structure, namely a valuation subring containing the image of the base field,
+distinct from the whole field and a principal ideal ring: it is `qInftyPlaceBar` for the subring
+`qIntegersBar`, with the required witness of an element of $q$-order $-1$ given by the
+coefficientwise image of `jq`, which lies in the base change and has order $-1$. The assertion is
+that the associated order function, defined as minus the logarithm of the value of $f$ under the
+height-one-spectrum valuation attached to this valuation subring, coincides with the Hahn series
+order of $f$ regarded as an element of $\overline{\mathbb{Q}}((q))$, i.e. the $q$-adic order of
+vanishing of the Laurent expansion of $f$.
+
+This identifies the valuation attached to the cusp $\infty$ on the base-changed modular curve of
+level $N$ with the elementary order of vanishing of a $q$-expansion, so that divisors supported at
+$\infty$ can be computed directly from Fourier expansions. It is used throughout the subsequent
+analysis of places and their prolongations, for instance in the statements governing the behaviour
+of specialisations at the cusp and in the sum formulae for orders.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ord_cuspInftyBar.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ord_cuspInftyBar
+
+open ModularCurve AlgebraicCurve
+open scoped Pointwise
+
+theorem solution (N : ℕ) [NeZero N] (f : modularFunctionFieldBar N) :
+    (cuspInftyBar N).ord f = (f : LaurentSeries (AlgebraicClosure ℚ)).order :=
+  ModularCurve.ord_qInftyPlaceBar (AlgebraicClosure ℚ) _ f
+
+end S_ModularCurve_ord_cuspInftyBar
+end P2MW
+export P2MW.S_ModularCurve_ord_cuspInftyBar (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.ord_cuspInftyBar (N : ℕ) [NeZero N] (f : modularFunctionFieldBar N) :
+    (cuspInftyBar N).ord f = (f : LaurentSeries (AlgebraicClosure ℚ)).order :=
+  solution N f
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_cuspInftyBar_coeffEmb_jq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_cuspInftyBar_coeffEmb_jq.lean
new file mode 100644
index 0000000000..a8ed7bbc41
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_cuspInftyBar_coeffEmb_jq.lean
@@ -0,0 +1,88 @@
+/-
+Based on Prove2Me node ModularCurve.ord_cuspInftyBar_coeffEmb_jq
+(88bc0883-9302-5fa7-90b2-08d4d596aa3c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ba8bf1f9-5e52-5bb2-a369-47ae816fd855
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_AtkinLehner
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_cuspInftyBar
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The q-expansion of j has order -1 at ∞
+
+Theorem statement: `ModularCurve.ord_cuspInftyBar_coeffEmb_jq`
+(`88bc0883-9302-5fa7-90b2-08d4d596aa3c`), by Claude, 2026-09-05.
+
+Proof: submission `ba8bf1f9-5e52-5bb2-a369-47ae816fd855`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a non-zero natural number. Write $\bar{\mathbb{Q}}$ for `AlgebraicClosure ℚ`, and let
+`modularFunctionFieldBar N` be the intermediate field `laurentBaseChange (AlgebraicClosure ℚ)
+(modularFunctionFieldFull N)` of $\bar{\mathbb{Q}}((q))$, i.e. the base change to $\bar{\mathbb{Q}}$
+of the full-level-$N$ modular function field sitting inside $\mathbb{Q}((q))$. Let `jq` be the
+Laurent series over $\mathbb{Q}$ given by `HahnSeries.single (-1) 1` times the image of the power
+series `jNumQ` under `HahnSeries.ofPowerSeries`, that is, $q^{-1}$ times the numerator power series
+of the modular invariant $j$; applying the coefficientwise ring homomorphism `coeffEmb
+(AlgebraicClosure ℚ)`, induced by $\mathbb{Q} \to \bar{\mathbb{Q}}$, produces an element of
+$\bar{\mathbb{Q}}((q))$, which by `coeffEmb_mem_laurentBaseChange` applied to `jq_mem_full N` lies
+in `modularFunctionFieldBar N`. Let `cuspInftyBar N` be the place of `modularFunctionFieldBar N`
+over $\bar{\mathbb{Q}}$ obtained from `qInftyPlaceBar` with this element as the witness of order
+$-1$; a `Place` consists of a valuation subring containing the image of the base field, not equal to
+the whole field, whose ring is a principal ideal ring. The assertion is that the order function
+`ord` of this place — minus the `WithZero` logarithm of the adic valuation attached to the valuation
+subring — takes the value $-1$ on the above element.
+
+This records that the $q$-expansion of the modular invariant $j$ has a simple pole at the cusp
+$\infty$ of the full level-$N$ modular curve over $\bar{\mathbb{Q}}$, so that $\infty$ is unramified
+over the $j$-line. It is used throughout the treatment of divisors, residues and rationality on the
+modular curves, for instance in the analysis of poles of functions pulled back along the Fricke
+involution and in the construction of rational cusp-regular functions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ord_cuspInftyBar_coeffEmb_jq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ord_cuspInftyBar_coeffEmb_jq
+
+open ModularCurve AlgebraicCurve
+open scoped Pointwise
+
+theorem solution (N : ℕ) [NeZero N] :
+    (cuspInftyBar N).ord ⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange
+      (AlgebraicClosure ℚ) (jq_mem_full N)⟩ = -1 := by
+  rw [ModularCurve.ord_cuspInftyBar]
+  exact order_coeffEmb_jq (AlgebraicClosure ℚ)
+
+end S_ModularCurve_ord_cuspInftyBar_coeffEmb_jq
+end P2MW
+export P2MW.S_ModularCurve_ord_cuspInftyBar_coeffEmb_jq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.ord_cuspInftyBar_coeffEmb_jq (N : ℕ) [NeZero N] :
+    (cuspInftyBar N).ord ⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange
+      (AlgebraicClosure ℚ) (jq_mem_full N)⟩ = -1 :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_cuspInftyBar_coeffEmb_qExpand.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_cuspInftyBar_coeffEmb_qExpand.lean
new file mode 100644
index 0000000000..67f6a53956
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_cuspInftyBar_coeffEmb_qExpand.lean
@@ -0,0 +1,91 @@
+/-
+Based on Prove2Me node ModularCurve.ord_cuspInftyBar_coeffEmb_qExpand
+(0aa44a19-bcf8-5814-8aa4-ac1514c268ec) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8513c9db-de1b-50b9-89f5-ee4c8350f3f0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_AtkinLehner
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_cuspInftyBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_order_coeffEmb
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_order_qExpand
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order of j(qᵈ) at the cusp at infinity
+
+Theorem statement: `ModularCurve.ord_cuspInftyBar_coeffEmb_qExpand`
+(`0aa44a19-bcf8-5814-8aa4-ac1514c268ec`), by Claude, 2026-09-05.
+
+Proof: submission `8513c9db-de1b-50b9-89f5-ee4c8350f3f0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and let $d$ be a nonzero natural number dividing $N$. Consider
+the Laurent series over $\mathbb{Q}$ obtained from `jq` $= q^{-1}\cdot j_{\mathrm{Num}}$ (the
+product of the Hahn series $q^{-1}$ with the power series whose coefficients are the integral
+coefficients of the $j$-function, cast to $\mathbb{Q}$) by applying `qExpand ℚ d`, the ring
+endomorphism of `LaurentSeries ℚ` that multiplies all exponents by $d$, i.e. the substitution $q
+\mapsto q^{d}$; then push this series forward coefficientwise along $\mathbb{Q} \to
+\overline{\mathbb{Q}}$ by `coeffEmb`. The assertion is that this element, viewed as an element of
+`modularFunctionFieldBar N` (the base change to $\overline{\mathbb{Q}}$ of the full modular function
+field of level $N$ inside `LaurentSeries (AlgebraicClosure ℚ)`, the membership being supplied by
+`coeffEmb_mem_laurentBaseChange` applied to `jqd_mem_full N hd`), has order $-d$ at the place
+`cuspInftyBar N`. Here the place is `qInftyPlaceBar` for this field, whose valuation subring is
+`qIntegersBar` and which is well-defined because the $q$-series of $j$ has order $-1$, and
+`Place.ord` denotes $-\log$ of the associated adic valuation, i.e. the normalised integer order
+function at that place.
+
+This records the elementary cusp computation $\mathrm{ord}_{\infty}\, j(q^{d}) = -d$ for $d \mid N$,
+the pole order at the cusp $\infty$ of the degenerate modular function used to generate the function
+field of $X_0(N)$-type curves over $\overline{\mathbb{Q}}$. It feeds the divisor-theoretic
+bookkeeping at the cusp, being used in the analysis of prolongations of places and of integrality
+and residues of $j$ and $j(q^{d})$ along the level-one specialisation.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ord_cuspInftyBar_coeffEmb_qExpand.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ord_cuspInftyBar_coeffEmb_qExpand
+
+open ModularCurve AlgebraicCurve
+open scoped Pointwise
+
+theorem solution (N : ℕ) [NeZero N] (d : ℕ) [NeZero d] (hd : d ∣ N) :
+    (cuspInftyBar N).ord ⟨coeffEmb (AlgebraicClosure ℚ) (qExpand ℚ d jq),
+      coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jqd_mem_full N hd)⟩ = -d := by
+  rw [ModularCurve.ord_cuspInftyBar]
+  change (coeffEmb (AlgebraicClosure ℚ) (qExpand ℚ d jq)).order = _
+  rw [ModularCurve.order_coeffEmb, ModularCurve.order_qExpand, order_jq, mul_neg, mul_one]
+
+end S_ModularCurve_ord_cuspInftyBar_coeffEmb_qExpand
+end P2MW
+export P2MW.S_ModularCurve_ord_cuspInftyBar_coeffEmb_qExpand (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.ord_cuspInftyBar_coeffEmb_qExpand (N : ℕ) [NeZero N] (d : ℕ) [NeZero d]
+    (hd : d ∣ N) :
+    (cuspInftyBar N).ord ⟨coeffEmb (AlgebraicClosure ℚ) (qExpand ℚ d jq),
+      coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jqd_mem_full N hd)⟩ = -d :=
+  solution N d hd
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_cuspZeroBar_coeffEmb_jq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_cuspZeroBar_coeffEmb_jq.lean
new file mode 100644
index 0000000000..b493d2c384
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_cuspZeroBar_coeffEmb_jq.lean
@@ -0,0 +1,92 @@
+/-
+Based on Prove2Me node ModularCurve.ord_cuspZeroBar_coeffEmb_jq
+(9293ce98-c7e6-5850-ab88-a8ee43c01493) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 80e063f8-dea6-508c-baa3-cd0fb74b79f9
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CuspidalClass
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_cuspZeroBar_coeffEmb_qExpand
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order of j at the cusp 0 equals -N
+
+Theorem statement: `ModularCurve.ord_cuspZeroBar_coeffEmb_jq`
+(`9293ce98-c7e6-5850-ab88-a8ee43c01493`), by Claude, 2026-09-05.
+
+Proof: submission `80e063f8-dea6-508c-baa3-cd0fb74b79f9`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number, and assume that the chosen automorphism `frickeInvolutionFull
+N` of the level-$N$ modular function field `modularFunctionFieldFull N` — the subfield of
+$\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by the expansions `divisorExpansions N` — satisfies
+the predicate `IsFrickeAutFull N`: for all natural numbers $a,b$ nonzero with $ab=N$ it sends the
+Laurent series $j(q^a)$, i.e. `qExpand ℚ a jq`, to $j(q^b)$, where `jq` is $q^{-1}$ times the power
+series $j$-numerator over $\mathbb{Q}$. Consider the element of `modularFunctionFieldBar N`, the
+base change of `modularFunctionFieldFull N` to an intermediate field of
+$\overline{\mathbb{Q}}((q))$, obtained by applying $\mathbb{Q}\to\overline{\mathbb{Q}}$ to the
+coefficients of `jq`. The assertion is that its order at the place `cuspZeroBar N` equals $-N$ in
+$\mathbb{Z}$. Here `cuspZeroBar N` is the translate, under the geometric automorphism induced by
+`frickeInvolutionFull N`, of the $q$-adic place `cuspInftyBar N` of `modularFunctionFieldBar N`
+determined by `jq`, and the order of an element at a place is minus the logarithm of its
+$\mathbb{Z}^{m0}$-valued adic valuation.
+
+This records the classical fact that the modular function $j$ has a pole of order $N$ at the cusp
+$0$, so that $0$ is ramified of degree $N$ over the $j$-line. It is used in the construction of
+functions with prescribed divisors at the cusps, in the place-specialisation and prolongation
+arguments and in the Riemann–Roch computations of the cuspidal class group.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ord_cuspZeroBar_coeffEmb_jq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ord_cuspZeroBar_coeffEmb_jq
+
+open ModularCurve AlgebraicCurve
+open scoped Pointwise
+
+theorem solution (N : ℕ) [NeZero N] (h : IsFrickeAutFull N (frickeInvolutionFull N)) :
+    (cuspZeroBar N).ord ⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange
+      (AlgebraicClosure ℚ) (jq_mem_full N)⟩ = -N := by
+  have e := ModularCurve.ord_cuspZeroBar_coeffEmb_qExpand N h N 1 (mul_one N)
+  have hj : (⟨coeffEmb (AlgebraicClosure ℚ) (qExpand ℚ 1 jq), coeffEmb_mem_laurentBaseChange
+    (AlgebraicClosure ℚ) (jqd_mem_full N (Dvd.intro_left N (mul_one N)))⟩ : modularFunctionFieldBar
+    N) =
+      ⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+        (jq_mem_full N)⟩ :=
+    Subtype.ext (by simp only [qExpand_one_apply])
+  rwa [hj] at e
+
+end S_ModularCurve_ord_cuspZeroBar_coeffEmb_jq
+end P2MW
+export P2MW.S_ModularCurve_ord_cuspZeroBar_coeffEmb_jq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.ord_cuspZeroBar_coeffEmb_jq (N : ℕ) [NeZero N]
+    (h : IsFrickeAutFull N (frickeInvolutionFull N)) :
+    (cuspZeroBar N).ord ⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange
+      (AlgebraicClosure ℚ) (jq_mem_full N)⟩ = -N :=
+  solution N h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_cuspZeroBar_coeffEmb_qExpand.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_cuspZeroBar_coeffEmb_qExpand.lean
new file mode 100644
index 0000000000..9828b5572f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_cuspZeroBar_coeffEmb_qExpand.lean
@@ -0,0 +1,94 @@
+/-
+Based on Prove2Me node ModularCurve.ord_cuspZeroBar_coeffEmb_qExpand
+(918a55bc-1304-52e9-9b9c-eb02ca4b4cc8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2d6904dd-d459-56a3-876b-432c79d64da5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CuspidalClass
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_frickeInvolutionBar_coeffEmb_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_cuspInftyBar_coeffEmb_qExpand
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order of j(qᵇ) at the cusp ̄ 0
+
+Theorem statement: `ModularCurve.ord_cuspZeroBar_coeffEmb_qExpand`
+(`918a55bc-1304-52e9-9b9c-eb02ca4b4cc8`), by Claude, 2026-09-05.
+
+Proof: submission `2d6904dd-d459-56a3-876b-432c79d64da5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and suppose the distinguished automorphism `frickeInvolutionFull
+N` of the field $F_N :=$ `modularFunctionFieldFull N` $= \mathbb{Q}(\text{divisorExpansions } N)
+\subseteq \mathbb{Q}((q))$ satisfies `IsFrickeAutFull N`, i.e. for every factorisation $N = a'b'$
+into nonzero natural numbers it carries the element $j(q^{a'})$ of $F_N$ to $j(q^{b'})$, where
+$j(q^{d}) =$ `qExpand ℚ d jq` is obtained from the Laurent series $jq = q^{-1}\cdot(\text{power
+series } jNumQ)$ by the substitution $q \mapsto q^{d}$. Let further $a, b$ be nonzero natural
+numbers with $ab = N$. Consider the place $\bar 0 :=$ `cuspZeroBar N`, defined as the translate of
+`cuspInftyBar N` under the action of `frickeInvolutionBar N`, the
+$\overline{\mathbb{Q}}$-automorphism of $\bar F_N :=$ `modularFunctionFieldBar N` $=$
+`laurentBaseChange` of $F_N$ obtained from `frickeInvolutionFull N` by base change of coefficients;
+here a place is a valuation subring of $\bar F_N$ containing $\overline{\mathbb{Q}}$, distinct from
+$\bar F_N$, and a principal ideal ring, and `Place.ord` is the normalised additive valuation
+attached to its maximal ideal. The assertion is that the order at $\bar 0$ of the element of $\bar
+F_N$ given by the coefficientwise image `coeffEmb` of $j(q^{b})$ under $\mathbb{Q} \hookrightarrow
+\overline{\mathbb{Q}}$ equals $-a$.
+
+This records the order of vanishing of the modular function $j(q^{b})$ at the cusp $0$ of $X_0(N)$
+over $\overline{\mathbb{Q}}$, the cusp being obtained from the cusp at infinity by the Fricke
+involution $w_N$. It is used in the computation of cuspidal divisors and of Hecke operators on them,
+and in the verification that $\bar 0$ lies outside the chart at infinity.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ord_cuspZeroBar_coeffEmb_qExpand.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ord_cuspZeroBar_coeffEmb_qExpand
+
+open ModularCurve AlgebraicCurve
+open scoped Pointwise
+
+theorem solution (N : ℕ) [NeZero N] (h : IsFrickeAutFull N (frickeInvolutionFull N)) (a b : ℕ)
+    (hab : a * b = N) [NeZero a] [NeZero b] :
+    (cuspZeroBar N).ord ⟨coeffEmb (AlgebraicClosure ℚ) (qExpand ℚ b jq),
+      coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jqd_mem_full N (Dvd.intro_left a hab))⟩ =
+      -a := by
+  rw [cuspZeroBar_def, ← ModularCurve.frickeInvolutionBar_coeffEmb_qExpand N h a b hab,
+    Place.ord_smul]
+  exact ModularCurve.ord_cuspInftyBar_coeffEmb_qExpand N a (Dvd.intro b hab)
+
+end S_ModularCurve_ord_cuspZeroBar_coeffEmb_qExpand
+end P2MW
+export P2MW.S_ModularCurve_ord_cuspZeroBar_coeffEmb_qExpand (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.ord_cuspZeroBar_coeffEmb_qExpand (N : ℕ) [NeZero N]
+    (h : IsFrickeAutFull N (frickeInvolutionFull N)) (a b : ℕ) (hab : a * b = N) [NeZero a]
+    [NeZero b] :
+    (cuspZeroBar N).ord ⟨coeffEmb (AlgebraicClosure ℚ) (qExpand ℚ b jq),
+      coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jqd_mem_full N (Dvd.intro_left a hab))⟩ =
+      -a :=
+  solution N h a b hab
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_eq_neg_width_of_order_eq_mul_ord_of_qExpansion_slash.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_eq_neg_width_of_order_eq_mul_ord_of_qExpansion_slash.lean
new file mode 100644
index 0000000000..23bc7692a6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_eq_neg_width_of_order_eq_mul_ord_of_qExpansion_slash.lean
@@ -0,0 +1,1266 @@
+/-
+Based on Prove2Me node ModularCurve.ord_eq_neg_width_of_order_eq_mul_ord_of_qExpansion_slash
+(27029e69-a7fd-5070-ad3e-a711c65e1ab9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3170cc39-04c6-5e43-aa52-37e919e8b68d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.Data.Int.Star
+import Mathlib.NumberTheory.Modular
+import Mathlib.NumberTheory.ModularForms.NormTrace
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Repartitions
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_CongruenceSubgroup_conj_T_zpow_mem_Gamma1_of_mem_sup_zpowers_neg_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_apply_eq_of_forall_ord_eq_zero_tendsto_realizeOf
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_ringHom_place_order_eq_mul_ord_of_qExpansion_slash
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_place_ord_neg_laurentBaseChange_gamma1_eq_natCard_doubleCoset
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_neg_width_le_ord_of_order_eq_mul_ord_of_qExpansion_slash
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_realizeOf_eq_div
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_qExpansion_coeff_mul_width
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order of j at a cusp place equals minus its width
+
+Theorem statement: `ModularCurve.ord_eq_neg_width_of_order_eq_mul_ord_of_qExpansion_slash`
+(`27029e69-a7fd-5070-ad3e-a711c65e1ab9`), by Claude, 2026-09-05.
+
+Proof: submission `3170cc39-04c6-5e43-aa52-37e919e8b68d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma\le \mathrm{SL}_2(\mathbb Z)$ be a subgroup of finite index containing the translation
+matrix $T$ and satisfying the predicate `CongruenceSubgroup.IsCongruenceSubgroup`, and let
+$F_0\subseteq \mathbb Q((q))$ be an intermediate field of $\mathbb Q((q))/\mathbb Q$ equal to
+[`ModularCurve.qExpFunctionFieldC ℚ Γ`](def/ModularCurve_X1.html#L101), the subfield of $\mathbb
+Q((q))$ generated over $\mathbb Q$ by the ratios $\mathrm{intSeriesC}(p_f)/\mathrm{intSeriesC}(p_g)$
+of integral $q$-expansions of modular forms $f,g$ of a common weight $k$ on $\Gamma$ (with the
+denominator nonzero). Write $F$ for [`ModularCurve.laurentBaseChange ℂ
+F₀`](def/ModularCurve_LaurentCoeff.html#L103), the intermediate field of $\mathbb C((q))/\mathbb C$
+generated by the coefficientwise image of $F_0$. Let $y\in F$ have Laurent series $\mathrm{jqModC}$,
+i.e. $q^{-1}$ times the image in $\mathbb C((q))$ of the integral power series $E_4^3\,\eta^{-24}$,
+and let $\sigma\in \mathrm{SL}_2(\mathbb Z)$, $N=[\,\mathrm{SL}_2(\mathbb Z):\text{normal core of
+}\Gamma\,]$. Assume given a ring homomorphism $\Phi\colon F\to\mathbb C((q))$, a place $P$ of $F$
+over $\mathbb C$ (a valuation subring containing $\mathbb C$, proper, and a principal ideal ring)
+and an integer $e>0$ such that: whenever $x\in F$, $k\in\mathbb Z$ and $g,h$ are modular forms of
+weight $k$ on $\Gamma$ with $h\ne 0$ and $x\cdot \widetilde q_1(h)=\widetilde q_1(g)$ in $\mathbb
+C((q))$, then $\Phi(x)\cdot \widetilde q_N(h\mid_k\sigma)=\widetilde q_N(g\mid_k\sigma)$, where
+$\widetilde q_w$ denotes the $q$-expansion of period $w$ viewed in $\mathbb C((q))$;
+$\mathrm{ord}(\Phi x)=e\cdot \mathrm{ord}_P(x)$ for all $x\ne 0$; and $\mathrm{ord}(\Phi y)=-N$.
+Assume further the degree condition $[\,F:\mathbb C(y)\,]=[\,\mathrm{SL}_2(\mathbb
+Z):\Gamma\vee\langle -1\rangle\,]$, and let $h>0$ be a natural number with $\sigma
+T^{h}\sigma^{-1}\in \Gamma\vee\langle -1\rangle$ which is minimal with this property among positive
+integers. Then $\mathrm{ord}_P(y)=-h$.
+
+This identifies the order of vanishing of the modular invariant $j$ at the cusp place of the
+function field of $X(\Gamma)$ read off at $\sigma\infty$ as minus the width of that cusp for
+$\pm\Gamma$, the degree hypothesis guaranteeing that the field $F$ is the full function field. It
+feeds the analysis of the behaviour of elements of $F$ near the cusps, being used in
+[`ModularCurve.exists_tendsto_realizeOf_mul_exp_of_not_mem_toValuationSubring`]
+(thm.html#ModularCurve.exists_tendsto_realizeOf_mul_exp_of_not_mem_toValuationSubring).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ord_eq_neg_width_of_order_eq_mul_ord_of_qExpansion_slash.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ord_eq_neg_width_of_order_eq_mul_ord_of_qExpansion_slash
+
+
+open ModularCurve UpperHalfPlane ModularForm Filter Function Complex
+  Matrix.SpecialLinearGroup
+
+open scoped MatrixGroups Topology Pointwise Manifold ModularForm
+
+noncomputable section
+
+namespace WidthE100
+
+section general
+variable {G : Type*} [Group G]
+
+theorem conj_pow_eq (σ t : G) (n : ℕ) : σ * t ^ n * σ⁻¹ = (σ * t * σ⁻¹) ^ n := conj_pow.symm
+
+theorem conj_zpow_eq (σ t : G) (n : ℤ) : σ * t ^ n * σ⁻¹ = (σ * t * σ⁻¹) ^ n := conj_zpow.symm
+
+theorem exists_pos_conj_pow_mem (H : Subgroup G) [H.FiniteIndex] (σ t : G) :
+    ∃ h : ℕ, 0 < h ∧ σ * t ^ h * σ⁻¹ ∈ H := by
+  refine ⟨H.normalCore.index, Nat.pos_of_ne_zero Subgroup.FiniteIndex.index_ne_zero, ?_⟩
+  rw [conj_pow_eq]
+  exact H.normalCore_le (Subgroup.pow_index_mem H.normalCore (σ * t * σ⁻¹))
+
+open scoped Classical in
+noncomputable def width (H : Subgroup G) [H.FiniteIndex] (σ t : G) : ℕ :=
+  Nat.find (exists_pos_conj_pow_mem H σ t)
+
+open scoped Classical in
+theorem width_pos (H : Subgroup G) [H.FiniteIndex] (σ t : G) : 0 < width H σ t :=
+  (Nat.find_spec (exists_pos_conj_pow_mem H σ t)).1
+
+open scoped Classical in
+theorem conj_pow_width_mem (H : Subgroup G) [H.FiniteIndex] (σ t : G) :
+    σ * t ^ (width H σ t) * σ⁻¹ ∈ H :=
+  (Nat.find_spec (exists_pos_conj_pow_mem H σ t)).2
+
+open scoped Classical in
+theorem width_le (H : Subgroup G) [H.FiniteIndex] (σ t : G) {h : ℕ} (hh : 0 < h)
+    (hmem : σ * t ^ h * σ⁻¹ ∈ H) : width H σ t ≤ h :=
+  Nat.find_min' (exists_pos_conj_pow_mem H σ t) ⟨hh, hmem⟩
+
+theorem width_eq_of_min (H : Subgroup G) [H.FiniteIndex] (σ t : G) (h : ℕ) (hh : 0 < h)
+    (hmem : σ * t ^ h * σ⁻¹ ∈ H) (hmin : ∀ k : ℕ, 0 < k → σ * t ^ k * σ⁻¹ ∈ H → h ≤ k) :
+    width H σ t = h :=
+  le_antisymm (width_le H σ t hh hmem) (hmin _ (width_pos H σ t) (conj_pow_width_mem H σ t))
+
+theorem conj_zpow_mem_iff_dvd (H : Subgroup G) [H.FiniteIndex] (σ t : G) (m : ℤ) :
+    σ * t ^ m * σ⁻¹ ∈ H ↔ (width H σ t : ℤ) ∣ m := by
+  set w := width H σ t with hw
+  have hwpos : (0 : ℤ) < w := by exact_mod_cast width_pos H σ t
+  have hgen : σ * t ^ (w : ℤ) * σ⁻¹ ∈ H := by
+    rw [zpow_natCast]; exact conj_pow_width_mem H σ t
+  have key : ∀ n : ℤ, σ * t ^ n * σ⁻¹ = (σ * t * σ⁻¹) ^ n := conj_zpow_eq σ t
+  constructor
+  · intro hm
+    have hr0 : 0 ≤ m % w := Int.emod_nonneg _ hwpos.ne'
+    have hrw : m % w < w := Int.emod_lt_of_pos _ hwpos
+    have hdecomp : m % w = m + (w : ℤ) * (-(m / w)) := by rw [Int.emod_def]; ring
+    have hr : σ * t ^ (m % w) * σ⁻¹ ∈ H := by
+      rw [key, hdecomp, zpow_add, zpow_mul]
+      refine H.mul_mem ?_ (H.zpow_mem ?_ _)
+      · rw [← key]; exact hm
+      · rw [← key]; exact hgen
+    by_contra hndvd
+    have hrne : m % w ≠ 0 := fun h0 => hndvd (Int.dvd_of_emod_eq_zero h0)
+    obtain ⟨r, hr'⟩ := Int.eq_ofNat_of_zero_le hr0
+    rw [hr'] at hr hrne hrw
+    rw [zpow_natCast] at hr
+    have hrpos : 0 < r := by
+      rcases Nat.eq_zero_or_pos r with h0 | h0
+      · exact absurd (by simp [h0]) hrne
+      · exact h0
+    have := width_le H σ t hrpos hr
+    omega
+  · rintro ⟨c, rfl⟩
+    rw [key, zpow_mul]
+    refine H.zpow_mem ?_ _
+    rw [← key]; exact hgen
+
+end general
+
+section cusp
+
+variable (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex]
+
+abbrev pm : Subgroup SL(2, ℤ) := Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))
+
+abbrev KT : Subgroup SL(2, ℤ) := Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))
+
+scoped instance pm_finiteIndex : (pm Γ).FiniteIndex := Subgroup.finiteIndex_of_le le_sup_left
+
+omit [Γ.FiniteIndex] in
+theorem neg_one_mem_pm : (-1 : SL(2, ℤ)) ∈ pm Γ :=
+  Subgroup.mem_sup_right (Subgroup.mem_zpowers _)
+
+omit [Γ.FiniteIndex] in
+theorem neg_mem_pm {g : SL(2, ℤ)} (hg : g ∈ pm Γ) : -g ∈ pm Γ := by
+  have : -g = g * (-1) := by simp
+  rw [this]; exact (pm Γ).mul_mem hg (neg_one_mem_pm Γ)
+
+theorem neg_one_zpow_eq (k : ℤ) : (-1 : SL(2, ℤ)) ^ k = 1 ∨ (-1 : SL(2, ℤ)) ^ k = -1 := by
+  rcases Int.even_or_odd k with hk | hk
+  · exact Or.inl hk.neg_one_zpow
+  · exact Or.inr hk.neg_one_zpow
+
+scoped instance zpowers_neg_one_normal : (Subgroup.zpowers (-1 : SL(2, ℤ))).Normal := by
+  refine ⟨fun n hn g => ?_⟩
+  obtain ⟨k, rfl⟩ := Subgroup.mem_zpowers_iff.mp hn
+  rcases neg_one_zpow_eq k with h | h <;> rw [h]
+  · simp
+  · have : g * -1 * g⁻¹ = (-1 : SL(2, ℤ)) := by simp
+    rw [this]; exact Subgroup.mem_zpowers _
+
+omit [Γ.FiniteIndex] in
+theorem mem_pm_iff {g : SL(2, ℤ)} : g ∈ pm Γ ↔ g ∈ Γ ∨ -g ∈ Γ := by
+  constructor
+  · intro hg
+    have hset := Subgroup.mul_normal Γ (Subgroup.zpowers (-1 : SL(2, ℤ)))
+    have hg' : g ∈ ((Γ : Set SL(2, ℤ)) * (Subgroup.zpowers (-1 : SL(2, ℤ)) : Set SL(2, ℤ))) := by
+      rw [← hset]; exact hg
+    obtain ⟨a, ha, b, hb, rfl⟩ := Set.mem_mul.mp hg'
+    obtain ⟨k, rfl⟩ := Subgroup.mem_zpowers_iff.mp hb
+    rcases neg_one_zpow_eq k with h | h <;> rw [h]
+    · left; simpa using ha
+    · right; simpa using ha
+  · rintro (hg | hg)
+    · exact Subgroup.mem_sup_left hg
+    · have : g = -(-g) := by simp
+      rw [this]; exact neg_mem_pm Γ (Subgroup.mem_sup_left hg)
+
+theorem mem_KT_iff {k : SL(2, ℤ)} :
+    k ∈ KT ↔ ∃ m : ℤ, k = ModularGroup.T ^ m ∨ k = -ModularGroup.T ^ m := by
+  constructor
+  · intro hk
+    have hset :=
+      Subgroup.mul_normal (Subgroup.zpowers ModularGroup.T) (Subgroup.zpowers (-1 : SL(2, ℤ)))
+    have hk' : k ∈ ((Subgroup.zpowers ModularGroup.T : Set SL(2, ℤ)) *
+        (Subgroup.zpowers (-1 : SL(2, ℤ)) : Set SL(2, ℤ))) := by
+      rw [← hset]; exact hk
+    obtain ⟨a, ha, b, hb, rfl⟩ := Set.mem_mul.mp hk'
+    obtain ⟨m, rfl⟩ := Subgroup.mem_zpowers_iff.mp ha
+    obtain ⟨j, rfl⟩ := Subgroup.mem_zpowers_iff.mp hb
+    refine ⟨m, ?_⟩
+    rcases neg_one_zpow_eq j with h | h <;> rw [h]
+    · left; simp
+    · right; simp
+  · rintro ⟨m, rfl | rfl⟩
+    · exact Subgroup.mem_sup_left (Subgroup.mem_zpowers_iff.mpr ⟨m, rfl⟩)
+    · have : -ModularGroup.T ^ m = ModularGroup.T ^ m * (-1) := by simp
+      rw [this]
+      exact (KT).mul_mem (Subgroup.mem_sup_left (Subgroup.mem_zpowers_iff.mpr ⟨m, rfl⟩))
+        (Subgroup.mem_sup_right (Subgroup.mem_zpowers _))
+
+abbrev RC := Quotient (QuotientGroup.rightRel (pm Γ))
+
+abbrev Cusp := DoubleCoset.Quotient (Γ : Set SL(2, ℤ)) ((KT : Subgroup SL(2, ℤ)) : Set SL(2, ℤ))
+
+def toCusp : RC Γ → Cusp Γ :=
+  Quotient.map' id (by
+    intro a b hab
+    rw [QuotientGroup.rightRel_apply] at hab
+    rcases (mem_pm_iff Γ).mp hab with h | h
+    · exact (DoubleCoset.rel_iff).mpr ⟨b * a⁻¹, h, 1, (KT).one_mem, by simp⟩
+    · refine (DoubleCoset.rel_iff).mpr ⟨-(b * a⁻¹), h, -1, Subgroup.mem_sup_right
+        (Subgroup.mem_zpowers _), ?_⟩
+      simp)
+
+omit [Γ.FiniteIndex] in
+theorem toCusp_mk (a : SL(2, ℤ)) :
+    toCusp Γ (Quotient.mk'' a) = DoubleCoset.mk (Γ : Subgroup SL(2, ℤ)) KT a := rfl
+
+omit [Γ.FiniteIndex] in
+theorem toCusp_surjective : Function.Surjective (toCusp Γ) := by
+  intro d
+  induction d using Quotient.inductionOn' with
+  | h a => exact ⟨Quotient.mk'' a, rfl⟩
+
+noncomputable abbrev cw (σ : SL(2, ℤ)) : ℕ := width (pm Γ) σ ModularGroup.T
+
+theorem mk_mul_T_zpow_eq_iff (a : SL(2, ℤ)) (m n : ℤ) :
+    (Quotient.mk'' (a * ModularGroup.T ^ m) : RC Γ) = Quotient.mk'' (a * ModularGroup.T ^ n) ↔
+      (cw Γ a : ℤ) ∣ n - m := by
+  rw [Quotient.eq'', QuotientGroup.rightRel_apply, ← conj_zpow_mem_iff_dvd]
+  have : a * ModularGroup.T ^ n * (a * ModularGroup.T ^ m)⁻¹ = a * ModularGroup.T ^ (n - m) * a⁻¹ :=
+    by
+    rw [mul_inv_rev, zpow_sub]; group
+  rw [this]
+
+omit [Γ.FiniteIndex] in
+theorem fibre_eq_range (a : SL(2, ℤ)) :
+    {q : RC Γ | toCusp Γ q = toCusp Γ (Quotient.mk'' a)} =
+      Set.range (fun m : ℤ => (Quotient.mk'' (a * ModularGroup.T ^ m) : RC Γ)) := by
+  ext q
+  constructor
+  · intro hq
+    induction q using Quotient.inductionOn' with
+    | h b =>
+      rw [Set.mem_ofPred_eq, toCusp_mk, toCusp_mk, eq_comm, DoubleCoset.eq] at hq
+      obtain ⟨γ, hγ, k, hk, rfl⟩ := hq
+      obtain ⟨m, hm⟩ := (mem_KT_iff).mp hk
+      refine ⟨m, ?_⟩
+      apply Quotient.sound'
+      rw [QuotientGroup.rightRel_apply]
+      rcases hm with rfl | rfl
+      · have : γ * a * ModularGroup.T ^ m * (a * ModularGroup.T ^ m)⁻¹ = γ := by group
+        rw [this]; exact Subgroup.mem_sup_left hγ
+      · have : γ * a * -ModularGroup.T ^ m * (a * ModularGroup.T ^ m)⁻¹ = -γ := by
+          simp only [mul_neg, neg_mul, neg_inj]; group
+        rw [this]; exact neg_mem_pm Γ (Subgroup.mem_sup_left hγ)
+  · rintro ⟨m, rfl⟩
+    rw [Set.mem_ofPred_eq, toCusp_mk, toCusp_mk, eq_comm, DoubleCoset.eq]
+    exact ⟨1, Γ.one_mem, ModularGroup.T ^ m,
+      Subgroup.mem_sup_left (Subgroup.mem_zpowers_iff.mpr ⟨m, rfl⟩), by simp⟩
+
+theorem range_eq_range_fin (a : SL(2, ℤ)) :
+    Set.range (fun m : ℤ => (Quotient.mk'' (a * ModularGroup.T ^ m) : RC Γ)) =
+      Set.range (fun i : Fin (cw Γ a) => (Quotient.mk'' (a * ModularGroup.T ^ ((i : ℕ) : ℤ)) : RC
+        Γ)) := by
+  have hw : (0 : ℤ) < cw Γ a := by exact_mod_cast width_pos (pm Γ) a ModularGroup.T
+  ext q
+  constructor
+  · rintro ⟨m, rfl⟩
+    have h0 : 0 ≤ m % (cw Γ a : ℤ) := Int.emod_nonneg _ hw.ne'
+    have hlt : m % (cw Γ a : ℤ) < cw Γ a := Int.emod_lt_of_pos _ hw
+    refine ⟨⟨(m % (cw Γ a : ℤ)).toNat, ?_⟩, ?_⟩
+    · have := Int.toNat_of_nonneg h0; omega
+    · simp only
+      rw [Int.toNat_of_nonneg h0, mk_mul_T_zpow_eq_iff]
+      rw [Int.emod_def]
+      exact ⟨m / (cw Γ a : ℤ), by ring⟩
+  · rintro ⟨i, rfl⟩
+    exact ⟨((i : ℕ) : ℤ), rfl⟩
+
+theorem injective_fin (a : SL(2, ℤ)) :
+    Function.Injective (fun i : Fin (cw Γ a) => (Quotient.mk'' (a * ModularGroup.T ^ ((i : ℕ) : ℤ))
+      : RC Γ)) := by
+  intro i j hij
+  simp only at hij
+  rw [mk_mul_T_zpow_eq_iff] at hij
+  have h1 : |((j : ℕ) : ℤ) - ((i : ℕ) : ℤ)| < (cw Γ a : ℤ) := by
+    rw [abs_lt]; constructor <;> omega
+  have := Int.eq_zero_of_abs_lt_dvd hij h1
+  ext; omega
+
+theorem natCard_fibre (a : SL(2, ℤ)) :
+    Nat.card {q : RC Γ | toCusp Γ q = toCusp Γ (Quotient.mk'' a)} = cw Γ a := by
+  rw [fibre_eq_range, range_eq_range_fin, Nat.card_range_of_injective (injective_fin Γ a)]
+  simp
+
+scoped instance finite_RC : Finite (RC Γ) :=
+  Finite.of_equiv _ (QuotientGroup.quotientRightRelEquivQuotientLeftRel (pm Γ)).symm
+
+scoped instance finite_Cusp : Finite (Cusp Γ) :=
+  Finite.of_surjective _ (toCusp_surjective Γ)
+
+theorem index_pm_eq_sum_cw [Fintype (Cusp Γ)] :
+    (pm Γ).index = ∑ c : Cusp Γ, cw Γ c.out := by
+  classical
+  have h1 : (pm Γ).index = Nat.card (RC Γ) := by
+    rw [Subgroup.index]
+    exact Nat.card_congr (QuotientGroup.quotientRightRelEquivQuotientLeftRel (pm Γ)).symm
+  rw [h1, ← Nat.card_congr (Equiv.sigmaFiberEquiv (toCusp Γ)), Nat.card_sigma]
+  refine Finset.sum_congr rfl fun c _ => ?_
+  have hc : c = toCusp Γ (Quotient.mk'' c.out) := by
+    rw [toCusp_mk]
+    exact (DoubleCoset.out_eq' c).symm
+  conv_lhs => rw [hc]
+  exact natCard_fibre Γ c.out
+
+omit [Γ.FiniteIndex] in
+theorem check_DoubleCoset_eq (a b : SL(2, ℤ)) :
+    DoubleCoset.mk (Γ : Subgroup SL(2, ℤ)) KT a = DoubleCoset.mk (Γ : Subgroup SL(2, ℤ)) KT b ↔
+      ∃ h ∈ Γ, ∃ k ∈ KT, b = h * a * k :=
+  DoubleCoset.eq (H := Γ) (K := KT) (a := a) (b := b)
+
+end cusp
+
+section slash
+
+variable {Γ : Subgroup SL(2, ℤ)} [Γ.FiniteIndex] {k : ℤ}
+
+theorem coe_eq_mapGL (γ : SL(2, ℤ)) : (γ : GL (Fin 2) ℝ) = mapGL ℝ γ := rfl
+
+theorem mapGL_T_zpow (n : ℤ) :
+    mapGL ℝ (ModularGroup.T ^ n) = Matrix.GeneralLinearGroup.upperRightHom ((n : ℝ)) := by
+  have hmat : ((ModularGroup.T ^ n : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) = !![1, n; 0, 1] :=
+    ModularGroup.coe_T_zpow n
+  rw [Units.ext_iff]
+  have hval : (↑(mapGL ℝ (ModularGroup.T ^ n)) : Matrix (Fin 2) (Fin 2) ℝ) =
+      (!![(1 : ℤ), n; 0, 1]).map (Int.cast : ℤ → ℝ) := by
+    rw [← hmat]; rfl
+  rw [hval]
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp [Matrix.GeneralLinearGroup.upperRightHom]
+
+omit [Γ.FiniteIndex] in
+theorem mem_strictPeriods_translate (σ : SL(2, ℤ)) (h : ℤ)
+    (hmem : σ * ModularGroup.T ^ h * σ⁻¹ ∈ Γ) :
+    ((h : ℝ)) ∈ Subgroup.strictPeriods
+      (ConjAct.toConjAct ((σ : GL (Fin 2) ℝ))⁻¹ • ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2)
+        ℝ))) := by
+  rw [Subgroup.mem_strictPeriods_iff, map_inv, Subgroup.mem_inv_pointwise_smul_iff,
+    ConjAct.toConjAct_smul, show ((h : ℝ)) = ((h : ℤ) : ℝ) from rfl, ← mapGL_T_zpow h, coe_eq_mapGL,
+    ← map_inv, ← map_mul, ← map_mul]
+  exact Subgroup.mem_map_of_mem _ hmem
+
+omit [Γ.FiniteIndex] in
+theorem coe_translate_SL (g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (σ : SL(2, ℤ)) :
+    ⇑(ModularForm.translate g (σ : GL (Fin 2) ℝ)) = ⇑g ∣[k] σ := by
+  rw [SL_slash]
+  exact ModularForm.coe_translate g _
+
+omit [Γ.FiniteIndex] in
+theorem slash_periodic_of_conj_mem (g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (σ : SL(2, ℤ))
+    (h : ℤ) (hmem : σ * ModularGroup.T ^ h * σ⁻¹ ∈ Γ) :
+    Periodic ((⇑g ∣[k] σ) ∘ ofComplex) ((h : ℝ)) := by
+  rw [← coe_translate_SL g σ]
+  exact SlashInvariantFormClass.periodic_comp_ofComplex
+    (ModularForm.translate g (σ : GL (Fin 2) ℝ)) (mem_strictPeriods_translate σ h hmem)
+
+omit [Γ.FiniteIndex] in
+theorem slash_periodic_nat (g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (σ : SL(2, ℤ))
+    (h : ℕ) (hmem : σ * ModularGroup.T ^ (h : ℤ) * σ⁻¹ ∈ Γ) :
+    Periodic ((⇑g ∣[k] σ) ∘ ofComplex) ((h : ℝ)) := by
+  have := slash_periodic_of_conj_mem g σ h hmem
+  simpa using this
+
+omit [Γ.FiniteIndex] in
+theorem conj_T_zpow_index_mem (σ : SL(2, ℤ)) :
+    σ * ModularGroup.T ^ (Γ.normalCore.index : ℤ) * σ⁻¹ ∈ Γ := by
+  have h1 : ModularGroup.T ^ (Γ.normalCore.index : ℤ) ∈ Γ.normalCore := by
+    rw [zpow_natCast]; exact Subgroup.pow_index_mem Γ.normalCore ModularGroup.T
+  exact Subgroup.normalCore_le Γ ((Subgroup.normalCore_normal Γ).conj_mem _ h1 σ)
+
+omit [Γ.FiniteIndex] in
+theorem slash_mdiff (g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (σ : SL(2, ℤ)) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (⇑g ∣[k] σ) := by
+  rw [← coe_translate_SL g σ]
+  exact ModularFormClass.holo _
+
+theorem slash_bddAtImInfty (g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (σ : SL(2, ℤ)) :
+    IsBoundedAtImInfty (⇑g ∣[k] σ) := by
+  have hpos : (0 : ℝ) < ((Γ.normalCore.index : ℤ) : ℝ) := by
+    exact_mod_cast Nat.pos_of_ne_zero Subgroup.FiniteIndex.index_ne_zero
+  have hFact : Fact (IsCusp OnePoint.infty (ConjAct.toConjAct ((σ : GL (Fin 2) ℝ))⁻¹ •
+      ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)))) :=
+    ⟨Subgroup.isCusp_of_mem_strictPeriods hpos
+      (mem_strictPeriods_translate σ _ (conj_T_zpow_index_mem σ))⟩
+  have hb := ModularFormClass.bdd_at_infty (f := ModularForm.translate g (σ : GL (Fin 2) ℝ))
+  rwa [coe_translate_SL] at hb
+
+end slash
+
+section order
+
+theorem order_eq_of_coeff {R : Type*} [CommRing R] {x : LaurentSeries R} {m : ℤ}
+    (hm : x.coeff m ≠ 0) (hlt : ∀ k < m, x.coeff k = 0) : x.order = m := by
+  have hx : x ≠ 0 := fun h => hm (by simp [h])
+  apply le_antisymm (HahnSeries.order_le_of_coeff_ne_zero hm)
+  by_contra hlt'
+  exact (fun h => hx (HahnSeries.coeff_order_eq_zero.mp h)) (hlt _ (not_le.mp hlt'))
+
+theorem order_ofPowerSeries {R : Type*} [CommRing R] {p : PowerSeries R} (hp : p ≠ 0) :
+    (HahnSeries.ofPowerSeries ℤ R p).order = p.order.toNat := by
+  apply order_eq_of_coeff
+  · rw [HahnSeries.ofPowerSeries_apply_coeff]
+    exact PowerSeries.coeff_order hp
+  · intro k hk
+    rcases lt_or_ge k 0 with hk0 | hk0
+    · exact ModularCurve.ofPowerSeries_coeff_of_neg _ hk0
+    · obtain ⟨n, rfl⟩ := Int.eq_ofNat_of_zero_le hk0
+      rw [HahnSeries.ofPowerSeries_apply_coeff]
+      exact PowerSeries.coeff_of_lt_order_toNat n (by exact_mod_cast hk)
+
+abbrev Lq (n : ℝ) (f : ℍ → ℂ) : LaurentSeries ℂ :=
+  ((qExpansion n f : PowerSeries ℂ) : LaurentSeries ℂ)
+
+theorem Lq_ne_zero_iff (n : ℝ) (f : ℍ → ℂ) : Lq n f ≠ 0 ↔ qExpansion n f ≠ 0 := by
+  rw [Lq, Ne, Ne, not_iff_not]
+  constructor
+  · intro h; exact HahnSeries.ofPowerSeries_injective (by rw [h, map_zero])
+  · intro h; rw [h, map_zero]
+
+theorem dvd_order_Lq_of_periodic {f : ℍ → ℂ} (h m' : ℕ) (hh : 0 < h) (hm' : 0 < m')
+    (hper : Periodic (f ∘ ofComplex) (h : ℝ))
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) (hbdd : IsBoundedAtImInfty f)
+    (hne : Lq ((m' : ℝ) * h) f ≠ 0) :
+    (m' : ℤ) ∣ (Lq ((m' : ℝ) * h) f).order := by
+  have hne' : qExpansion ((m' : ℝ) * h) f ≠ 0 := (Lq_ne_zero_iff _ _).mp hne
+  rw [Lq, order_ofPowerSeries hne']
+  have hc := PowerSeries.coeff_order hne'
+  have h35 :=
+    UpperHalfPlane.qExpansion_coeff_mul_width f (h : ℝ) (by exact_mod_cast hh) hper hhol hbdd
+    m' hm' (qExpansion ((m' : ℝ) * h) f).order.toNat
+  by_contra hnd
+  have hnd' : ¬ m' ∣ (qExpansion ((m' : ℝ) * h) f).order.toNat := by
+    intro hd; exact hnd (by exact_mod_cast hd)
+  rw [ite_eq_right hnd'] at h35
+  exact hc h35
+
+end order
+
+section readout
+
+variable (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex]
+
+abbrev CF := ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ))
+
+theorem neg_ord_dvd_of_readout (hT : ModularGroup.T ∈ Γ) (σ : SL(2, ℤ)) (h : ℕ) (hh : 0 < h)
+    (hreg : σ * ModularGroup.T ^ (h : ℤ) * σ⁻¹ ∈ Γ) (hdvd : h ∣ Γ.normalCore.index)
+    (Φ : CF Γ →+* LaurentSeries ℂ) (P : AlgebraicCurve.Place ℂ (CF Γ)) (e : ℕ) (he : 0 < e)
+    (hpres : ∀ (x : CF Γ) (k : ℤ)
+          (g hf : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k), hf ≠ 0 →
+        (x : LaurentSeries ℂ) *
+            ((UpperHalfPlane.qExpansion 1 (hf : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries
+              ℂ) =
+          ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+            →
+        Φ x * ((UpperHalfPlane.qExpansion (Γ.normalCore.index : ℝ)
+              ((hf : UpperHalfPlane → ℂ) ∣[k] σ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+          ((UpperHalfPlane.qExpansion (Γ.normalCore.index : ℝ)
+              ((g : UpperHalfPlane → ℂ) ∣[k] σ) : PowerSeries ℂ) : LaurentSeries ℂ))
+    (hord : ∀ x : CF Γ, x ≠ 0 → (Φ x).order = e * P.ord x)
+    (y : CF Γ) (hey : (e : ℤ) * P.ord y = -(Γ.normalCore.index : ℤ)) :
+    P.ord y < 0 ∧ (-P.ord y) ∣ (h : ℤ) := by
+  set N := Γ.normalCore.index with hNdef
+  have hNpos : 0 < N := Nat.pos_of_ne_zero Subgroup.FiniteIndex.index_ne_zero
+  obtain ⟨m', hm'⟩ := hdvd
+  have hm'pos : 0 < m' := by
+    rcases Nat.eq_zero_or_pos m' with h0 | h0
+    · rw [h0, mul_zero] at hm'; omega
+    · exact h0
+  have hNreal : (N : ℝ) = (m' : ℝ) * h := by rw [hm']; push_cast; ring
+  have hD : ∀ x : CF Γ, x ≠ 0 → (m' : ℤ) ∣ (Φ x).order := by
+    intro x hx
+    obtain ⟨k, g, hf, hf0, hx'⟩ :=
+      ModularCurve.exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC
+        Γ hT (x : LaurentSeries ℂ) x.2
+    have hp := hpres x k g hf hf0 hx'
+    have hper_f := slash_periodic_nat hf σ h hreg
+    have hper_g := slash_periodic_nat g σ h hreg
+    have hperN : Periodic ((⇑hf ∣[k] σ) ∘ ofComplex) ((N : ℝ)) :=
+      slash_periodic_nat hf σ N (conj_T_zpow_index_mem σ)
+    have hLf : Lq (N : ℝ) (⇑hf ∣[k] σ) ≠ 0 := by
+      rw [Lq_ne_zero_iff, Ne, qExpansion_eq_zero_iff (by exact_mod_cast hNpos)
+        hperN (slash_mdiff hf σ) (slash_bddAtImInfty hf σ)]
+      intro h0
+      apply hf0
+      have h1 : ⇑hf = (0 : ℍ → ℂ) := by
+        have h2 := congrArg (· ∣[k] (σ⁻¹ : SL(2, ℤ))) h0
+        simpa only [SL_slash, ← SlashAction.slash_mul, ← map_mul, mul_inv_cancel, map_one,
+          SlashAction.slash_one, SlashAction.zero_slash] using h2
+      exact DFunLike.ext' h1
+    have hΦx : Φ x ≠ 0 := (map_ne_zero_iff Φ Φ.injective).mpr hx
+    have hLg : Lq (N : ℝ) (⇑g ∣[k] σ) ≠ 0 := by
+      change Φ x * Lq (N : ℝ) (⇑hf ∣[k] σ) = Lq (N : ℝ) (⇑g ∣[k] σ) at hp
+      rw [← hp]; exact mul_ne_zero hΦx hLf
+    have hordmul : (Φ x).order + (Lq (N : ℝ) (⇑hf ∣[k] σ)).order = (Lq (N : ℝ) (⇑g ∣[k] σ)).order :=
+      by
+      rw [← HahnSeries.order_mul hΦx hLf]
+      exact congrArg HahnSeries.order hp
+    have hdf : (m' : ℤ) ∣ (Lq (N : ℝ) (⇑hf ∣[k] σ)).order := by
+      rw [hNreal]
+      refine dvd_order_Lq_of_periodic h m' hh hm'pos hper_f (slash_mdiff hf σ) (slash_bddAtImInfty
+        hf σ) ?_
+      rw [← hNreal]; exact hLf
+    have hdg : (m' : ℤ) ∣ (Lq (N : ℝ) (⇑g ∣[k] σ)).order := by
+      rw [hNreal]
+      refine dvd_order_Lq_of_periodic h m' hh hm'pos hper_g (slash_mdiff g σ) (slash_bddAtImInfty g
+        σ) ?_
+      rw [← hNreal]; exact hLg
+    have : (Φ x).order = (Lq (N : ℝ) (⇑g ∣[k] σ)).order - (Lq (N : ℝ) (⇑hf ∣[k] σ)).order :=
+      by omega
+    rw [this]; exact dvd_sub hdg hdf
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible P.toValuationSubring
+  have hπ1 : P.ord (π : CF Γ) = 1 := AlgebraicCurve.Place.ord_coe_irreducible P hπ
+  have hπ0 : (π : CF Γ) ≠ 0 := by
+    intro h0; rw [h0, AlgebraicCurve.Place.ord_zero] at hπ1; exact zero_ne_one hπ1
+  have hme : (m' : ℤ) ∣ (e : ℤ) := by
+    have := hD _ hπ0
+    rwa [hord _ hπ0, hπ1, mul_one] at this
+  obtain ⟨c, hc⟩ := hme
+  have hepos : (0 : ℤ) < e := by exact_mod_cast he
+  have hm'posZ : (0 : ℤ) < m' := by exact_mod_cast hm'pos
+  have hcpos : 0 < c := by nlinarith
+  have hNZ : (N : ℤ) = (h : ℤ) * m' := by exact_mod_cast hm'
+  have hneg : P.ord y < 0 := by nlinarith
+  refine ⟨hneg, ⟨c, ?_⟩⟩
+  have h1 : (m' : ℤ) * (c * P.ord y) = (m' : ℤ) * (-(h : ℤ)) := by
+    calc (m' : ℤ) * (c * P.ord y) = (e : ℤ) * P.ord y := by rw [hc]; ring
+      _ = -(N : ℤ) := hey
+      _ = (m' : ℤ) * (-(h : ℤ)) := by rw [hNZ]; ring
+  have h2 := mul_left_cancel₀ hm'posZ.ne' h1
+  linarith
+
+end readout
+
+section inv
+
+theorem KT_cases {k : SL(2, ℤ)}
+    (hk : k ∈ Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))) :
+    ∃ m : ℤ, k = ModularGroup.T ^ m ∨ k = -ModularGroup.T ^ m := by
+  have hnorm : (Subgroup.zpowers (-1 : SL(2, ℤ))).Normal := by
+    refine ⟨fun n hn g => ?_⟩
+    obtain ⟨j, rfl⟩ := Subgroup.mem_zpowers_iff.mp hn
+    rcases Int.even_or_odd j with hj | hj
+    · rw [hj.neg_one_zpow]; simp
+    · rw [hj.neg_one_zpow]
+      have : g * -1 * g⁻¹ = (-1 : SL(2, ℤ)) := by simp
+      rw [this]; exact Subgroup.mem_zpowers _
+  have hset :=
+    Subgroup.mul_normal (Subgroup.zpowers ModularGroup.T) (Subgroup.zpowers (-1 : SL(2, ℤ)))
+  have hk' : k ∈ ((Subgroup.zpowers ModularGroup.T : Set SL(2, ℤ)) *
+      (Subgroup.zpowers (-1 : SL(2, ℤ)) : Set SL(2, ℤ))) := by
+    rw [← hset]; exact hk
+  obtain ⟨a, ha, b, hb, rfl⟩ := Set.mem_mul.mp hk'
+  obtain ⟨m, rfl⟩ := Subgroup.mem_zpowers_iff.mp ha
+  obtain ⟨j, rfl⟩ := Subgroup.mem_zpowers_iff.mp hb
+  refine ⟨m, ?_⟩
+  rcases Int.even_or_odd j with hj | hj
+  · left; rw [hj.neg_one_zpow]; simp
+  · right; rw [hj.neg_one_zpow]; simp
+
+variable (Γ : Subgroup SL(2, ℤ)) (hT : ModularGroup.T ∈ Γ)
+
+theorem modularForm_apply_smul {k : ℤ} (h : ModularForm Γ k) {γ : SL(2, ℤ)} (hγ : γ ∈ Γ) (z : ℍ) :
+    (h : ℍ → ℂ) (γ • z) = denom γ z ^ k * (h : ℍ → ℂ) z :=
+  SlashInvariantForm.slash_action_eqn_SL'' h hγ z
+
+theorem modularForm_apply_smul_ne_zero_iff {k : ℤ} (h : ModularForm Γ k) {γ : SL(2, ℤ)}
+    (hγ : γ ∈ Γ) (z : ℍ) :
+    (h : ℍ → ℂ) (γ • z) ≠ 0 ↔ (h : ℍ → ℂ) z ≠ 0 := by
+  rw [modularForm_apply_smul Γ h hγ z, mul_ne_zero_iff]
+  exact ⟨fun H => H.2, fun H => ⟨zpow_ne_zero _ (denom_ne_zero _ z), H⟩⟩
+
+include hT in
+theorem realizeOf_smul_of_mem {γ : SL(2, ℤ)} (hγ : γ ∈ Γ) (x : LaurentSeries ℂ) (z : ℍ) :
+    ModularCurve.realizeOf Γ x (γ • z) = ModularCurve.realizeOf Γ x z := by
+  by_cases H : ∃ p : (k : ℤ) × (ModularForm Γ k × ModularForm Γ k),
+        (p.2.2 : ℍ → ℂ) z ≠ 0 ∧
+          x * ((qExpansion 1 (p.2.2 : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+            ((qExpansion 1 (p.2.1 : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+  · obtain ⟨⟨k, g, h⟩, hh, hx⟩ := H
+    rw [ModularCurve.realizeOf_eq_div Γ hT g h x hx z hh,
+      ModularCurve.realizeOf_eq_div Γ hT g h x hx (γ • z)
+        ((modularForm_apply_smul_ne_zero_iff Γ h hγ z).mpr hh),
+      modularForm_apply_smul Γ g hγ z, modularForm_apply_smul Γ h hγ z,
+      mul_div_mul_left _ _ (zpow_ne_zero k (denom_ne_zero _ z))]
+  · rw [ModularCurve.realizeOf_of_not Γ x z H, ModularCurve.realizeOf_of_not Γ x (γ • z) ?_]
+    rintro ⟨p, hp, hx⟩
+    exact H ⟨p, (modularForm_apply_smul_ne_zero_iff Γ p.2.2 hγ z).mp hp, hx⟩
+
+theorem tendsto_T_zpow_smul_atImInfty (m : ℤ) :
+    Tendsto (fun τ : ℍ => ModularGroup.T ^ m • τ) atImInfty atImInfty := by
+  simp only [atImInfty, tendsto_comap_iff, Function.comp_def, ModularGroup.im_T_zpow_smul]
+  exact tendsto_comap
+
+theorem exists_tendsto_comp_T_zpow_iff (f : ℍ → ℂ) (m : ℤ) :
+    (∃ L : ℂ, Tendsto (fun τ : ℍ => f (ModularGroup.T ^ m • τ)) atImInfty (𝓝 L)) ↔
+      (∃ L : ℂ, Tendsto f atImInfty (𝓝 L)) := by
+  constructor
+  · rintro ⟨L, hL⟩
+    refine ⟨L, (hL.comp (tendsto_T_zpow_smul_atImInfty (-m))).congr fun τ => ?_⟩
+    simp only [Function.comp_apply]
+    rw [smul_smul, ← zpow_add, add_neg_cancel, zpow_zero, one_smul]
+  · rintro ⟨L, hL⟩
+    exact ⟨L, hL.comp (tendsto_T_zpow_smul_atImInfty m)⟩
+
+include hT in
+theorem place_eq_of_doubleCoset {F₀ : IntermediateField ℚ (LaurentSeries ℚ)}
+    (Pl : SL(2, ℤ) → AlgebraicCurve.Place ℂ ↥(ModularCurve.laurentBaseChange ℂ F₀))
+    (hE2 : ∀ (σ : SL(2, ℤ)) (x : ↥(ModularCurve.laurentBaseChange ℂ F₀)),
+      x ∈ (Pl σ).toValuationSubring ↔
+        ∃ L : ℂ, Tendsto (fun τ : ℍ => ModularCurve.realizeOf Γ (x : LaurentSeries ℂ) (σ • τ))
+          atImInfty (𝓝 L))
+    {σ σ' : SL(2, ℤ)}
+    (h : ∃ γ ∈ Γ, ∃ k ∈ Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)),
+      σ' = γ * σ * k) :
+    Pl σ' = Pl σ := by
+  obtain ⟨γ, hγ, k, hk, rfl⟩ := h
+  obtain ⟨m, hm⟩ := KT_cases hk
+  apply AlgebraicCurve.Place.ext
+  ext x
+  rw [hE2, hE2]
+  have key : ∀ τ : ℍ, ModularCurve.realizeOf Γ (x : LaurentSeries ℂ) ((γ * σ * k) • τ)
+      = ModularCurve.realizeOf Γ (x : LaurentSeries ℂ) (σ • (ModularGroup.T ^ m • τ)) := by
+    intro τ
+    rw [mul_smul, mul_smul, realizeOf_smul_of_mem Γ hT hγ]
+    rcases hm with rfl | rfl
+    · rfl
+    · rw [ModularGroup.SL_neg_smul]
+  simp_rw [key]
+  exact exists_tendsto_comp_T_zpow_iff
+    (fun τ => ModularCurve.realizeOf Γ (x : LaurentSeries ℂ) (σ • τ)) m
+
+end inv
+
+section squeeze
+
+variable (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex]
+
+theorem cw_mul_mul_eq {σ h k : SL(2, ℤ)} (hh : h ∈ Γ) (hk : k ∈ KT) :
+    cw Γ (h * σ * k) = cw Γ σ := by
+  obtain ⟨m, hm⟩ := mem_KT_iff.mp hk
+  have hc : ∀ n : ℕ, Commute k (ModularGroup.T ^ n) := by
+    intro n
+    rcases hm with rfl | rfl
+    · exact ((Commute.refl ModularGroup.T).zpow_left m).pow_right n
+    · exact (((Commute.refl ModularGroup.T).zpow_left m).pow_right n).neg_left
+  have hh' : h ∈ pm Γ := Subgroup.mem_sup_left hh
+  have key : ∀ n : ℕ, h * σ * k * ModularGroup.T ^ n * (h * σ * k)⁻¹ ∈ pm Γ ↔
+      σ * ModularGroup.T ^ n * σ⁻¹ ∈ pm Γ := by
+    intro n
+    have : h * σ * k * ModularGroup.T ^ n * (h * σ * k)⁻¹ =
+        h * (σ * ModularGroup.T ^ n * σ⁻¹) * h⁻¹ := by
+      rw [mul_assoc (h * σ) k, (hc n).eq, mul_inv_rev, mul_inv_rev]; group
+    rw [this, (pm Γ).mul_mem_cancel_right (inv_mem hh'), (pm Γ).mul_mem_cancel_left hh']
+  exact width_eq_of_min (pm Γ) (h * σ * k) ModularGroup.T (cw Γ σ) (width_pos _ _ _)
+    ((key _).mpr (conj_pow_width_mem _ _ _))
+    (fun n hn hmem => width_le _ _ _ hn ((key n).mp hmem))
+
+open AlgebraicCurve in
+theorem ord_eq_neg_cw_of_squeeze
+    {F : Type*} [Field F] [Algebra ℂ F]
+    (y : F) (htr : Transcendental ℂ y)
+    (hfin : FiniteDimensional ↥(IntermediateField.adjoin ℂ ({y} : Set F)) F)
+    (hfull : Module.finrank ↥(IntermediateField.adjoin ℂ ({y} : Set F)) F = (pm Γ).index)
+    (hcard : Nat.card {P : Place ℂ F // P.ord y < 0} = Nat.card (Cusp Γ))
+    (Pl : SL(2, ℤ) → Place ℂ F)
+    (hinv : ∀ σ σ' : SL(2, ℤ), (∃ γ ∈ Γ, ∃ k ∈ (KT : Subgroup SL(2, ℤ)), σ' = γ * σ * k) →
+      Pl σ' = Pl σ)
+    (hsurj : ∀ P : Place ℂ F, P.ord y < 0 → ∃ σ, Pl σ = P)
+    (hbound : ∀ σ, (Pl σ).ord y < 0 ∧ -(Pl σ).ord y ≤ (cw Γ σ : ℤ))
+    (σ : SL(2, ℤ)) : (Pl σ).ord y = -(cw Γ σ : ℤ) := by
+  classical
+  have hadj : IntermediateField.adjoin ℂ ({y⁻¹} : Set F) =
+      IntermediateField.adjoin ℂ ({y} : Set F) := by
+    apply le_antisymm
+    · rw [IntermediateField.adjoin_simple_le_iff]
+      exact inv_mem (IntermediateField.mem_adjoin_simple_self ℂ y)
+    · rw [IntermediateField.adjoin_simple_le_iff]
+      have := inv_mem (IntermediateField.mem_adjoin_simple_self ℂ y⁻¹)
+      rwa [inv_inv] at this
+  have htr' : Transcendental ℂ y⁻¹ := fun h => htr (IsAlgebraic.inv_iff.mp h)
+  have hfin' : FiniteDimensional ↥(IntermediateField.adjoin ℂ ({y⁻¹} : Set F)) F := by
+    rw [hadj]; exact hfin
+  obtain ⟨S, hS, hsum⟩ :=
+    AlgebraicCurve.exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed ℂ y⁻¹ htr'
+      hfin' 0
+  rw [hadj, hfull] at hsum
+  simp only [map_zero, sub_zero, Place.ord_inv, neg_pos] at hS hsum
+  let : Fintype {P : Place ℂ F // P.ord y < 0} := Fintype.subtype S hS
+  let : Fintype (Cusp Γ) := Fintype.ofFinite _
+  have hout : ∀ τ : SL(2, ℤ),
+      Pl (DoubleCoset.mk (Γ : Subgroup SL(2, ℤ)) KT τ : Cusp Γ).out = Pl τ := by
+    intro τ
+    obtain ⟨h, hh, k, hk, he⟩ := DoubleCoset.mk_out_eq_mul (Γ : Subgroup SL(2, ℤ)) KT τ
+    exact hinv τ _ ⟨h, hh, k, hk, he⟩
+  have hΨsurj : Function.Surjective
+      (fun c : Cusp Γ => (⟨Pl c.out, (hbound c.out).1⟩ : {P : Place ℂ F // P.ord y < 0})) := by
+    rintro ⟨P, hP⟩
+    obtain ⟨τ, rfl⟩ := hsurj P hP
+    exact ⟨DoubleCoset.mk (Γ : Subgroup SL(2, ℤ)) KT τ, Subtype.ext (hout τ)⟩
+  have hΨbij : Function.Bijective
+      (fun c : Cusp Γ => (⟨Pl c.out, (hbound c.out).1⟩ : {P : Place ℂ F // P.ord y < 0})) :=
+    (Nat.bijective_iff_surjective_and_card _).mpr ⟨hΨsurj, hcard.symm⟩
+  have hsum1 : ∑ c : Cusp Γ, (-(Pl c.out).ord y) = ((pm Γ).index : ℤ) := by
+    rw [← hsum, Finset.sum_subtype (F := inferInstance) S hS]
+    exact hΨbij.sum_comp (fun P : {P : Place ℂ F // P.ord y < 0} => -(P : Place ℂ F).ord y)
+  have hsum2 : ∑ c : Cusp Γ, (cw Γ c.out : ℤ) = ((pm Γ).index : ℤ) := by
+    rw [index_pm_eq_sum_cw Γ, Nat.cast_sum]
+  have hle : ∀ c ∈ (Finset.univ : Finset (Cusp Γ)), (-(Pl c.out).ord y) ≤ (cw Γ c.out : ℤ) :=
+    fun c _ => (hbound c.out).2
+  have heq := (Finset.sum_eq_sum_iff_of_le hle).mp (hsum1.trans hsum2.symm)
+  have h1 := heq (DoubleCoset.mk (Γ : Subgroup SL(2, ℤ)) KT σ) (Finset.mem_univ _)
+  rw [hout σ] at h1
+  obtain ⟨h, hh, k, hk, he⟩ := DoubleCoset.mk_out_eq_mul (Γ : Subgroup SL(2, ℤ)) KT σ
+  rw [he, cw_mul_mul_eq Γ hh hk] at h1
+  omega
+
+end squeeze
+
+section final
+
+open CongruenceSubgroup
+
+variable (M : ℕ) [NeZero M]
+
+omit [NeZero M] in
+theorem T_mem_Gamma1 : ModularGroup.T ∈ Gamma1 M := by
+  rw [CongruenceSubgroup.Gamma1_mem]; simp [ModularGroup.T]
+
+def Pl (σ : SL(2, ℤ)) : AlgebraicCurve.Place ℂ (CF (Gamma1 M)) :=
+  (ModularCurve.exists_ringHom_place_order_eq_mul_ord_of_qExpansion_slash (Gamma1 M) (T_mem_Gamma1
+    M)
+    (ModularCurve.qExpFunctionFieldC ℚ (Gamma1 M)) rfl σ).choose_spec.choose
+
+lemma Pl_spec (σ : SL(2, ℤ)) :
+    let Φ := Exists.choose
+      (ModularCurve.exists_ringHom_place_order_eq_mul_ord_of_qExpansion_slash
+        (Gamma1 M) (T_mem_Gamma1 M)
+        (ModularCurve.qExpFunctionFieldC ℚ (Gamma1 M)) rfl σ)
+    ∃ e : ℕ,
+      0 < e ∧
+      (∀ x : CF (Gamma1 M), x ∈ (Pl M σ).toValuationSubring ↔ 0 ≤ (Φ x).order) ∧
+      (∀ x : CF (Gamma1 M), x ∈ (Pl M σ).toValuationSubring ↔
+        ∃ L : ℂ, Filter.Tendsto
+          (fun τ : UpperHalfPlane => ModularCurve.realizeOf (Gamma1 M)
+            (x : LaurentSeries ℂ) (σ • τ)) atImInfty (𝓝 L)) ∧
+      (∀ (x : CF (Gamma1 M)) (k : ℤ)
+          (g h : ModularForm (Gamma1 M : Subgroup (GL (Fin 2) ℝ)) k), h ≠ 0 →
+        (x : LaurentSeries ℂ) *
+            ((qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+          ((qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) →
+        Φ x * ((qExpansion ((Gamma1 M).normalCore.index : ℝ)
+              ((h : UpperHalfPlane → ℂ) ∣[k] σ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+          ((qExpansion ((Gamma1 M).normalCore.index : ℝ)
+              ((g : UpperHalfPlane → ℂ) ∣[k] σ) : PowerSeries ℂ) : LaurentSeries ℂ)) ∧
+      (∀ c : ℂ, Φ (algebraMap ℂ (CF (Gamma1 M)) c) = HahnSeries.C c) ∧
+      (∀ x : CF (Gamma1 M), x ≠ 0 → (Φ x).order = e * (Pl M σ).ord x) ∧
+      (∀ y : CF (Gamma1 M), (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ →
+        (Φ y).order = -((Gamma1 M).normalCore.index : ℤ) ∧
+          (e : ℤ) * (Pl M σ).ord y = -((Gamma1 M).normalCore.index : ℤ) ∧
+          y ∉ (Pl M σ).toValuationSubring) ∧
+      (∀ x : CF (Gamma1 M), x ≠ 0 → ∃ L : ℂ, L ≠ 0 ∧
+        Filter.Tendsto
+          (fun τ : UpperHalfPlane => ModularCurve.realizeOf (Gamma1 M)
+            (x : LaurentSeries ℂ) (σ • τ) *
+            Complex.exp (-(2 * Real.pi * Complex.I *
+              ((e : ℤ) * (Pl M σ).ord x : ℂ) * (τ : ℂ) /
+                ((Gamma1 M).normalCore.index : ℂ))))
+          atImInfty (𝓝 L)) := by
+  exact (ModularCurve.exists_ringHom_place_order_eq_mul_ord_of_qExpansion_slash
+    (Gamma1 M) (T_mem_Gamma1 M) (ModularCurve.qExpFunctionFieldC ℚ (Gamma1 M))
+      rfl σ).choose_spec.choose_spec
+
+theorem not_mem_of_ord_neg {F : Type*} [Field F] [Algebra ℂ F] (P : AlgebraicCurve.Place ℂ F)
+    {x : F}
+    (hx : P.ord x < 0) : x ∉ P.toValuationSubring := fun hmem =>
+  ((P.not_adicValuation_le_one_iff).mpr hx) (P.adicValuation_le_one_of_mem hmem)
+
+omit [NeZero M] in
+theorem four_not_dvd (hM : 5 ≤ M) : ¬ M ∣ 4 := fun h => by
+  have := Nat.le_of_dvd (by norm_num) h; omega
+
+theorem ord_Pl_eq_neg_cw (hM : 5 ≤ M) (y : CF (Gamma1 M))
+    (hy : (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ) (σ : SL(2, ℤ)) :
+    (Pl M σ).ord y = -(cw (Gamma1 M) σ : ℤ) := by
+  have hT := T_mem_Gamma1 M
+  obtain ⟨htr, hfin⟩ :=
+  transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC
+      ℂ (Gamma1 M) hT y hy
+  have := hfin
+  have hfull :=
+    ModularCurve.finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index ℂ M y hy
+  have hcard :=
+    ModularCurve.natCard_place_ord_neg_laurentBaseChange_gamma1_eq_natCard_doubleCoset ℂ M y hy
+  have hE2 : ∀ (σ : SL(2, ℤ)) (x : CF (Gamma1 M)), x ∈ (Pl M σ).toValuationSubring ↔
+      ∃ L : ℂ, Tendsto (fun τ : ℍ => ModularCurve.realizeOf (Gamma1 M) (x : LaurentSeries ℂ) (σ •
+        τ))
+        atImInfty (𝓝 L) := by
+    intro σ x
+    obtain ⟨e, he, hE1, hE2, -⟩ := Pl_spec M σ
+    exact hE2 x
+  have hinv : ∀ σ σ' : SL(2, ℤ), (∃ γ ∈ Gamma1 M, ∃ k ∈ (KT : Subgroup SL(2, ℤ)), σ' = γ * σ * k) →
+      Pl M σ' = Pl M σ := fun σ σ' h => place_eq_of_doubleCoset (Gamma1 M) hT (Pl M) hE2 h
+  have hΓPl : ∀ γ ∈ Gamma1 M, ∀ σ : SL(2, ℤ), Pl M (γ * σ) = Pl M σ := fun γ hγ σ =>
+    hinv σ (γ * σ) ⟨γ, hγ, 1, Subgroup.one_mem _, by simp⟩
+  have hlim : ∀ (σ : SL(2, ℤ)) (x : CF (Gamma1 M)), x ≠ 0 → (Pl M σ).ord x = 0 →
+      ∃ L : ℂ, L ≠ 0 ∧ Tendsto (fun τ : ℍ => ModularCurve.realizeOf (Gamma1 M) (x : LaurentSeries ℂ)
+        (σ • τ))
+        atImInfty (𝓝 L) := by
+    intro σ x hx h0
+    obtain ⟨e, he, hE1, hE2', hpres, hconst, hord, hy', hlimσ⟩ := Pl_spec M σ
+    obtain ⟨L, hL, hten⟩ := hlimσ x hx
+    refine ⟨L, hL, ?_⟩
+    refine Tendsto.congr (fun τ => ?_) hten
+    rw [h0]; simp
+  have hsurj : ∀ P : AlgebraicCurve.Place ℂ (CF (Gamma1 M)), P.ord y < 0 → ∃ σ, Pl M σ = P :=
+    fun P hP => ModularCurve.exists_apply_eq_of_forall_ord_eq_zero_tendsto_realizeOf (Gamma1 M) hT
+      (Gamma1_is_congruence M) _ rfl y hy (Pl M) hΓPl hlim P (not_mem_of_ord_neg P hP)
+  have hbound : ∀ σ : SL(2, ℤ), (Pl M σ).ord y < 0 ∧ -(Pl M σ).ord y ≤ (cw (Gamma1 M) σ : ℤ) := by
+    intro σ
+    obtain ⟨e, he, hE1, hE2', hpres, hconst, hord, hy', hlimσ⟩ := Pl_spec M σ
+    obtain ⟨hΦy, hey, hynot⟩ := hy' y hy
+    have hwpos := width_pos (pm (Gamma1 M)) σ ModularGroup.T
+    have hmem_pm : σ * ModularGroup.T ^ (cw (Gamma1 M) σ : ℤ) * σ⁻¹ ∈ pm (Gamma1 M) := by
+      rw [zpow_natCast]; exact conj_pow_width_mem (pm (Gamma1 M)) σ ModularGroup.T
+    have hreg :=
+      CongruenceSubgroup.conj_T_zpow_mem_Gamma1_of_mem_sup_zpowers_neg_one M (four_not_dvd M hM) σ _
+        hmem_pm
+    have hdvd : cw (Gamma1 M) σ ∣ (Gamma1 M).normalCore.index := by
+      have h1 : σ * ModularGroup.T ^ ((Gamma1 M).normalCore.index : ℤ) * σ⁻¹ ∈ pm (Gamma1 M) :=
+        Subgroup.mem_sup_left (conj_T_zpow_index_mem σ)
+      rw [conj_zpow_mem_iff_dvd] at h1
+      exact_mod_cast h1
+    obtain ⟨hneg, hdv⟩ :=
+      neg_ord_dvd_of_readout (Gamma1 M) hT σ (cw (Gamma1 M) σ) hwpos hreg hdvd _ (Pl M σ)
+      e he hpres hord y hey
+    refine ⟨hneg, Int.le_of_dvd (by exact_mod_cast hwpos) hdv⟩
+  exact ord_eq_neg_cw_of_squeeze (Gamma1 M) y htr hfin hfull hcard (Pl M) hinv hsurj hbound σ
+
+end final
+
+section squeeze2
+
+variable (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex]
+
+open AlgebraicCurve in
+theorem ord_eq_neg_cw_of_squeeze'
+    {F : Type*} [Field F] [Algebra ℂ F]
+    (y : F) (htr : Transcendental ℂ y)
+    (hfin : FiniteDimensional ↥(IntermediateField.adjoin ℂ ({y} : Set F)) F)
+    (hfull : Module.finrank ↥(IntermediateField.adjoin ℂ ({y} : Set F)) F = (pm Γ).index)
+    (Pl : SL(2, ℤ) → Place ℂ F)
+    (hinv : ∀ σ σ' : SL(2, ℤ), (∃ γ ∈ Γ, ∃ k ∈ (KT : Subgroup SL(2, ℤ)), σ' = γ * σ * k) →
+      Pl σ' = Pl σ)
+    (hsurj : ∀ P : Place ℂ F, P.ord y < 0 → ∃ σ, Pl σ = P)
+    (hbound : ∀ σ, (Pl σ).ord y < 0 ∧ -(Pl σ).ord y ≤ (cw Γ σ : ℤ))
+    (σ : SL(2, ℤ)) : (Pl σ).ord y = -(cw Γ σ : ℤ) := by
+  classical
+  have hadj : IntermediateField.adjoin ℂ ({y⁻¹} : Set F) =
+      IntermediateField.adjoin ℂ ({y} : Set F) := by
+    apply le_antisymm
+    · rw [IntermediateField.adjoin_simple_le_iff]
+      exact inv_mem (IntermediateField.mem_adjoin_simple_self ℂ y)
+    · rw [IntermediateField.adjoin_simple_le_iff]
+      have := inv_mem (IntermediateField.mem_adjoin_simple_self ℂ y⁻¹)
+      rwa [inv_inv] at this
+  have htr' : Transcendental ℂ y⁻¹ := fun h => htr (IsAlgebraic.inv_iff.mp h)
+  have hfin' : FiniteDimensional ↥(IntermediateField.adjoin ℂ ({y⁻¹} : Set F)) F := by
+    rw [hadj]; exact hfin
+  obtain ⟨S, hS, hsum⟩ :=
+    AlgebraicCurve.exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed ℂ y⁻¹ htr'
+      hfin' 0
+  rw [hadj, hfull] at hsum
+  simp only [map_zero, sub_zero, Place.ord_inv, neg_pos] at hS hsum
+  let : Fintype (Cusp Γ) := Fintype.ofFinite _
+  have hout : ∀ τ : SL(2, ℤ),
+      Pl (DoubleCoset.mk (Γ : Subgroup SL(2, ℤ)) KT τ : Cusp Γ).out = Pl τ := by
+    intro τ
+    obtain ⟨h, hh, k, hk, he⟩ := DoubleCoset.mk_out_eq_mul (Γ : Subgroup SL(2, ℤ)) KT τ
+    exact hinv τ _ ⟨h, hh, k, hk, he⟩
+  have hS_eq : S = (Finset.univ : Finset (Cusp Γ)).image (fun c => Pl c.out) := by
+    ext P
+    rw [hS, Finset.mem_image]
+    constructor
+    · intro hP
+      obtain ⟨τ, rfl⟩ := hsurj P hP
+      exact ⟨DoubleCoset.mk (Γ : Subgroup SL(2, ℤ)) KT τ, Finset.mem_univ _, hout τ⟩
+    · rintro ⟨c, _, rfl⟩
+      exact (hbound c.out).1
+  have h1 : ((pm Γ).index : ℤ) ≤ ∑ c : Cusp Γ, (-(Pl c.out).ord y) := by
+    rw [← hsum, hS_eq]
+    refine Finset.sum_image_le_of_nonneg fun P hP => ?_
+    obtain ⟨c, _, rfl⟩ := Finset.mem_image.mp hP
+    have := (hbound c.out).1
+    omega
+  have hsum2 : ∑ c : Cusp Γ, (cw Γ c.out : ℤ) = ((pm Γ).index : ℤ) := by
+    rw [index_pm_eq_sum_cw Γ, Nat.cast_sum]
+  have hle : ∀ c ∈ (Finset.univ : Finset (Cusp Γ)), (-(Pl c.out).ord y) ≤ (cw Γ c.out : ℤ) :=
+    fun c _ => (hbound c.out).2
+  have hsum1 : ∑ c : Cusp Γ, (-(Pl c.out).ord y) = ∑ c : Cusp Γ, (cw Γ c.out : ℤ) :=
+    le_antisymm (Finset.sum_le_sum hle) (hsum2 ▸ h1)
+  have heq := (Finset.sum_eq_sum_iff_of_le hle).mp hsum1
+  have h2 := heq (DoubleCoset.mk (Γ : Subgroup SL(2, ℤ)) KT σ) (Finset.mem_univ _)
+  rw [hout σ] at h2
+  obtain ⟨h, hh, k, hk, he⟩ := DoubleCoset.mk_out_eq_mul (Γ : Subgroup SL(2, ℤ)) KT σ
+  rw [he, cw_mul_mul_eq Γ hh hk] at h2
+  omega
+
+end squeeze2
+
+section bridge
+
+theorem mem_toValuationSubring_iff_ord {F : Type*} [Field F] [Algebra ℂ F]
+    (P : AlgebraicCurve.Place ℂ F) (x : F) :
+    x ∈ P.toValuationSubring ↔ x = 0 ∨ 0 ≤ P.ord x := by
+  rw [← P.adicValuation_le_one_iff]
+  constructor
+  · exact P.adicValuation_le_one_of_mem
+  · intro hx
+    by_contra hxm
+    have hx0 : x ≠ 0 := fun h => hxm (h ▸ P.toValuationSubring.zero_mem)
+    have hxi : x⁻¹ ∈ P.toValuationSubring :=
+      (P.toValuationSubring.mem_or_inv_mem x).resolve_left hxm
+    have hnu : ¬IsUnit (⟨x⁻¹, hxi⟩ : P.toValuationSubring) := by
+      rintro ⟨u, hu⟩
+      apply hxm
+      have h1 : ((u⁻¹ : P.toValuationSubringˣ) : P.toValuationSubring) *
+          (⟨x⁻¹, hxi⟩ : P.toValuationSubring) = 1 := by
+        rw [← hu, Units.inv_mul]
+      have h2 : (((u⁻¹ : P.toValuationSubringˣ) : P.toValuationSubring) : F) * x⁻¹ = 1 := by
+        have := congrArg Subtype.val h1
+        simpa using this
+      have h3 : (((u⁻¹ : P.toValuationSubringˣ) : P.toValuationSubring) : F) = x :=
+        (mul_inv_eq_one₀ hx0).mp h2
+      rw [← h3]; exact SetLike.coe_mem _
+    have hlt : P.adicValuation x⁻¹ < 1 :=
+      lt_of_le_of_ne (P.adicValuation_le_one_of_mem hxi)
+        (fun h => hnu ((P.adicValuation_coe_eq_one_iff ⟨x⁻¹, hxi⟩).mp h))
+    have hlt' : P.adicValuation (x * x⁻¹) < 1 := by
+      rw [map_mul]
+      calc P.adicValuation x * P.adicValuation x⁻¹
+          ≤ 1 * P.adicValuation x⁻¹ := mul_le_mul_left hx _
+        _ = P.adicValuation x⁻¹ := one_mul _
+        _ < 1 := hlt
+    rw [mul_inv_cancel₀ hx0, map_one] at hlt'
+    exact lt_irrefl _ hlt'
+
+variable (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+
+include hT in
+theorem place_eq_of_readouts (σ : SL(2, ℤ))
+    (hB : ∀ (k : ℤ) (hf : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k), hf ≠ 0 →
+      ((qExpansion (Γ.normalCore.index : ℝ) ((hf : ℍ → ℂ) ∣[k] σ) : PowerSeries ℂ) :
+        LaurentSeries ℂ) ≠ 0)
+    (Φ Φ' : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ)) →+*
+      LaurentSeries ℂ)
+    (P P' : AlgebraicCurve.Place ℂ
+      ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ)))
+    (e e' : ℕ) (he : 0 < e) (he' : 0 < e')
+    (hpres : ∀ (x : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ)))
+      (k : ℤ) (g hf : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k), hf ≠ 0 →
+      (x : LaurentSeries ℂ) * ((qExpansion 1 (hf : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+        ((qExpansion 1 (g : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) →
+      Φ x * ((qExpansion (Γ.normalCore.index : ℝ) ((hf : ℍ → ℂ) ∣[k] σ) : PowerSeries ℂ) :
+          LaurentSeries ℂ) =
+        ((qExpansion (Γ.normalCore.index : ℝ) ((g : ℍ → ℂ) ∣[k] σ) : PowerSeries ℂ) :
+          LaurentSeries ℂ))
+    (hord : ∀ x : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ)),
+      x ≠ 0 → (Φ x).order = (e : ℤ) * P.ord x)
+    (hpres' : ∀ (x : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ)))
+      (k : ℤ) (g hf : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k), hf ≠ 0 →
+      (x : LaurentSeries ℂ) * ((qExpansion 1 (hf : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+        ((qExpansion 1 (g : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) →
+      Φ' x * ((qExpansion (Γ.normalCore.index : ℝ) ((hf : ℍ → ℂ) ∣[k] σ) : PowerSeries ℂ) :
+          LaurentSeries ℂ) =
+        ((qExpansion (Γ.normalCore.index : ℝ) ((g : ℍ → ℂ) ∣[k] σ) : PowerSeries ℂ) :
+          LaurentSeries ℂ))
+    (hord' : ∀ x : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ)),
+      x ≠ 0 → (Φ' x).order = (e' : ℤ) * P'.ord x) :
+    P' = P := by
+  apply AlgebraicCurve.Place.ext
+  ext x
+  rw [mem_toValuationSubring_iff_ord, mem_toValuationSubring_iff_ord]
+  rcases eq_or_ne x 0 with rfl | hx0
+  · simp
+  · have hΦ : Φ' x = Φ x := by
+      obtain ⟨k, g, hf, hf0, hxp⟩ :=
+        exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC
+          Γ hT (x : LaurentSeries ℂ) x.2
+      have h1 := hpres x k g hf hf0 hxp
+      have h2 := hpres' x k g hf hf0 hxp
+      exact mul_right_cancel₀ (hB k hf hf0) (h2.trans h1.symm)
+    have hordeq : (e' : ℤ) * P'.ord x = (e : ℤ) * P.ord x := by
+      rw [← hord x hx0, ← hord' x hx0, hΦ]
+    have he0 : (0 : ℤ) < e := by exact_mod_cast he
+    have he0' : (0 : ℤ) < e' := by exact_mod_cast he'
+    rw [or_iff_right hx0, or_iff_right hx0]
+    constructor
+    · intro h
+      by_contra hlt
+      push Not at hlt
+      have h3 := mul_neg_of_pos_of_neg he0 hlt
+      have h4 := mul_nonneg he0'.le h
+      omega
+    · intro h
+      by_contra hlt
+      push Not at hlt
+      have h3 := mul_neg_of_pos_of_neg he0' hlt
+      have h4 := mul_nonneg he0.le h
+      omega
+
+end bridge
+
+section finalG
+
+open CongruenceSubgroup
+
+variable (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+
+theorem Lq_slash_ne_zero {k : ℤ} (hf : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (σ : SL(2, ℤ))
+    (hf0 : hf ≠ 0) :
+    ((qExpansion (Γ.normalCore.index : ℝ) ((hf : ℍ → ℂ) ∣[k] σ) : PowerSeries ℂ) : LaurentSeries ℂ)
+      ≠ 0 := by
+  have hNpos : 0 < Γ.normalCore.index := Nat.pos_of_ne_zero Subgroup.FiniteIndex.index_ne_zero
+  have hperN := slash_periodic_nat hf σ _ (conj_T_zpow_index_mem σ)
+  change Lq _ _ ≠ 0
+  rw [Lq_ne_zero_iff, Ne, qExpansion_eq_zero_iff (by exact_mod_cast hNpos) hperN (slash_mdiff hf σ)
+    (slash_bddAtImInfty hf σ)]
+  intro h0
+  apply hf0
+  have h1 : ⇑hf = (0 : ℍ → ℂ) := by
+    have h2 := congrArg (· ∣[k] (σ⁻¹ : SL(2, ℤ))) h0
+    simpa only [SL_slash, ← SlashAction.slash_mul, ← map_mul, mul_inv_cancel, map_one,
+      SlashAction.slash_one, SlashAction.zero_slash] using h2
+  exact DFunLike.ext' h1
+
+def PlG (σ : SL(2, ℤ)) : AlgebraicCurve.Place ℂ (CF Γ) :=
+  (ModularCurve.exists_ringHom_place_order_eq_mul_ord_of_qExpansion_slash Γ hT
+    (ModularCurve.qExpFunctionFieldC ℚ Γ) rfl σ).choose_spec.choose
+
+lemma PlG_spec (σ : SL(2, ℤ)) :
+    let Φ := Exists.choose
+      (ModularCurve.exists_ringHom_place_order_eq_mul_ord_of_qExpansion_slash Γ hT
+        (ModularCurve.qExpFunctionFieldC ℚ Γ) rfl σ)
+    ∃ e : ℕ,
+      0 < e ∧
+      (∀ x : CF Γ, x ∈ (PlG Γ hT σ).toValuationSubring ↔ 0 ≤ (Φ x).order) ∧
+      (∀ x : CF Γ, x ∈ (PlG Γ hT σ).toValuationSubring ↔
+        ∃ L : ℂ, Filter.Tendsto
+          (fun τ : UpperHalfPlane => ModularCurve.realizeOf Γ
+            (x : LaurentSeries ℂ) (σ • τ)) atImInfty (𝓝 L)) ∧
+      (∀ (x : CF Γ) (k : ℤ) (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k),
+        h ≠ 0 →
+        (x : LaurentSeries ℂ) *
+            ((qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+          ((qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) →
+        Φ x * ((qExpansion (Γ.normalCore.index : ℝ)
+              ((h : UpperHalfPlane → ℂ) ∣[k] σ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+          ((qExpansion (Γ.normalCore.index : ℝ)
+              ((g : UpperHalfPlane → ℂ) ∣[k] σ) : PowerSeries ℂ) : LaurentSeries ℂ)) ∧
+      (∀ c : ℂ, Φ (algebraMap ℂ (CF Γ) c) = HahnSeries.C c) ∧
+      (∀ x : CF Γ, x ≠ 0 → (Φ x).order = e * (PlG Γ hT σ).ord x) ∧
+      (∀ y : CF Γ, (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ →
+        (Φ y).order = -(Γ.normalCore.index : ℤ) ∧
+          (e : ℤ) * (PlG Γ hT σ).ord y = -(Γ.normalCore.index : ℤ) ∧
+          y ∉ (PlG Γ hT σ).toValuationSubring) ∧
+      (∀ x : CF Γ, x ≠ 0 → ∃ L : ℂ, L ≠ 0 ∧
+        Filter.Tendsto
+          (fun τ : UpperHalfPlane => ModularCurve.realizeOf Γ
+            (x : LaurentSeries ℂ) (σ • τ) *
+            Complex.exp (-(2 * Real.pi * Complex.I *
+              ((e : ℤ) * (PlG Γ hT σ).ord x : ℂ) * (τ : ℂ) /
+                (Γ.normalCore.index : ℂ))))
+          atImInfty (𝓝 L)) := by
+  exact (ModularCurve.exists_ringHom_place_order_eq_mul_ord_of_qExpansion_slash Γ hT
+    (ModularCurve.qExpFunctionFieldC ℚ Γ) rfl σ).choose_spec.choose_spec
+
+theorem ord_PlG_eq_neg_cw (hΓ : CongruenceSubgroup.IsCongruenceSubgroup Γ) (y : CF Γ)
+    (hy : (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ)
+    (hdeg : Module.finrank ↥(IntermediateField.adjoin ℂ ({y} : Set (CF Γ))) (CF Γ) = (pm Γ).index)
+    (σ : SL(2, ℤ)) :
+    (PlG Γ hT σ).ord y = -(cw Γ σ : ℤ) := by
+  obtain ⟨htr, hfin⟩ :=
+  transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC
+      ℂ Γ hT y hy
+  have := hfin
+  have hE2 : ∀ (σ : SL(2, ℤ)) (x : CF Γ), x ∈ (PlG Γ hT σ).toValuationSubring ↔
+      ∃ L : ℂ, Tendsto (fun τ : ℍ => ModularCurve.realizeOf Γ (x : LaurentSeries ℂ) (σ • τ))
+        atImInfty (𝓝 L) := by
+    intro σ x
+    obtain ⟨e, he, hE1, hE2, -⟩ := PlG_spec Γ hT σ
+    exact hE2 x
+  have hinv : ∀ σ σ' : SL(2, ℤ), (∃ γ ∈ Γ, ∃ k ∈ (KT : Subgroup SL(2, ℤ)), σ' = γ * σ * k) →
+      PlG Γ hT σ' = PlG Γ hT σ := fun σ σ' h => place_eq_of_doubleCoset Γ hT (PlG Γ hT) hE2 h
+  have hΓPl : ∀ γ ∈ Γ, ∀ σ : SL(2, ℤ), PlG Γ hT (γ * σ) = PlG Γ hT σ := fun γ hγ σ =>
+    hinv σ (γ * σ) ⟨γ, hγ, 1, Subgroup.one_mem _, by simp⟩
+  have hlim : ∀ (σ : SL(2, ℤ)) (x : CF Γ), x ≠ 0 → (PlG Γ hT σ).ord x = 0 →
+      ∃ L : ℂ, L ≠ 0 ∧ Tendsto (fun τ : ℍ => ModularCurve.realizeOf Γ (x : LaurentSeries ℂ) (σ • τ))
+        atImInfty (𝓝 L) := by
+    intro σ x hx h0
+    obtain ⟨e, he, hE1, hE2', hpres, hconst, hord, hy', hlimσ⟩ := PlG_spec Γ hT σ
+    obtain ⟨L, hL, hten⟩ := hlimσ x hx
+    refine ⟨L, hL, ?_⟩
+    refine Tendsto.congr (fun τ => ?_) hten
+    rw [h0]; simp
+  have hsurj : ∀ P : AlgebraicCurve.Place ℂ (CF Γ), P.ord y < 0 → ∃ σ, PlG Γ hT σ = P :=
+    fun P hP => ModularCurve.exists_apply_eq_of_forall_ord_eq_zero_tendsto_realizeOf Γ hT
+      hΓ _ rfl y hy (PlG Γ hT) hΓPl hlim P (not_mem_of_ord_neg P hP)
+  have hbound : ∀ σ : SL(2, ℤ), (PlG Γ hT σ).ord y < 0 ∧ -(PlG Γ hT σ).ord y ≤ (cw Γ σ : ℤ) := by
+    intro σ
+    obtain ⟨e, he, hE1, hE2', hpres, hconst, hord, hy', hlimσ⟩ := PlG_spec Γ hT σ
+    obtain ⟨hΦy, hey, hynot⟩ := hy' y hy
+    have hwpos := width_pos (pm Γ) σ ModularGroup.T
+    have hmem : σ * ModularGroup.T ^ (cw Γ σ) * σ⁻¹ ∈ Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) :=
+      conj_pow_width_mem (pm Γ) σ ModularGroup.T
+    have hle := ModularCurve.neg_width_le_ord_of_order_eq_mul_ord_of_qExpansion_slash Γ hT _ rfl y σ
+      _ (PlG Γ hT σ) e he hpres hord hΦy (cw Γ σ) hwpos hmem
+    have hepos : (0 : ℤ) < e := by exact_mod_cast he
+    have hNpos : (0 : ℤ) < (Γ.normalCore.index : ℤ) := by
+      exact_mod_cast Nat.pos_of_ne_zero Subgroup.FiniteIndex.index_ne_zero
+    have hey' : (e : ℤ) * (PlG Γ hT σ).ord y = -(Γ.normalCore.index : ℤ) := hey
+    have hneg : (PlG Γ hT σ).ord y < 0 := by nlinarith
+    exact ⟨hneg, by linarith⟩
+  exact ord_eq_neg_cw_of_squeeze' Γ y htr hfin hdeg (PlG Γ hT) hinv hsurj hbound σ
+
+end finalG
+
+end WidthE100
+
+open WidthE100 in
+theorem solution
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    (hΓ : CongruenceSubgroup.IsCongruenceSubgroup Γ)
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (hF : F₀ = ModularCurve.qExpFunctionFieldC ℚ Γ)
+    (y : ↥(ModularCurve.laurentBaseChange ℂ F₀))
+    (hy : (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ)
+    (σ : SL(2, ℤ))
+    (Φ : ModularCurve.laurentBaseChange ℂ F₀ →+* LaurentSeries ℂ)
+    (P : AlgebraicCurve.Place ℂ (ModularCurve.laurentBaseChange ℂ F₀)) (e : ℕ) (he : 0 < e)
+    (hpres : ∀ (x : ModularCurve.laurentBaseChange ℂ F₀) (k : ℤ)
+          (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k), h ≠ 0 →
+        (x : LaurentSeries ℂ) *
+            ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries
+              ℂ) =
+          ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+            →
+        Φ x * ((UpperHalfPlane.qExpansion (Γ.normalCore.index : ℝ)
+              ((h : UpperHalfPlane → ℂ) ∣[k] σ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+          ((UpperHalfPlane.qExpansion (Γ.normalCore.index : ℝ)
+              ((g : UpperHalfPlane → ℂ) ∣[k] σ) : PowerSeries ℂ) : LaurentSeries ℂ))
+    (hord : ∀ x : ModularCurve.laurentBaseChange ℂ F₀, x ≠ 0 → (Φ x).order = e * P.ord x)
+    (hyo : (Φ y).order = -(Γ.normalCore.index : ℤ))
+    (hdeg : Module.finrank
+        ↥(IntermediateField.adjoin ℂ ({y} : Set ↥(ModularCurve.laurentBaseChange ℂ F₀)))
+        ↥(ModularCurve.laurentBaseChange ℂ F₀) =
+      (Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index)
+    (h : ℕ) (hh : 0 < h)
+    (hmem : σ * ModularGroup.T ^ h * σ⁻¹ ∈ Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)))
+    (hmin : ∀ k : ℕ, 0 < k → σ * ModularGroup.T ^ k * σ⁻¹ ∈ Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) → h
+      ≤ k) :
+    P.ord y = -(h : ℤ) := by
+  subst hF
+  obtain ⟨e', he', hE1', hE2', hpres', hconst', hord', -⟩ := PlG_spec Γ hT σ
+  have hP : P = PlG Γ hT σ :=
+    place_eq_of_readouts Γ hT σ (fun k hf hf0 => Lq_slash_ne_zero Γ hf σ hf0)
+      _ Φ (PlG Γ hT σ) P e' e he' he hpres' hord' hpres hord
+  have hw : cw Γ σ = h := width_eq_of_min (pm Γ) σ ModularGroup.T h hh hmem hmin
+  rw [hP, ord_PlG_eq_neg_cw Γ hT hΓ y hy hdeg σ, hw]
+
+end
+end S_ModularCurve_ord_eq_neg_width_of_order_eq_mul_ord_of_qExpansion_slash
+end P2MW
+export P2MW.S_ModularCurve_ord_eq_neg_width_of_order_eq_mul_ord_of_qExpansion_slash (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open CongruenceSubgroup ModularCurve
+open scoped MatrixGroups ModularForm
+theorem ModularCurve.ord_eq_neg_width_of_order_eq_mul_ord_of_qExpansion_slash
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    (hΓ : CongruenceSubgroup.IsCongruenceSubgroup Γ)
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (hF : F₀ = ModularCurve.qExpFunctionFieldC ℚ Γ)
+    (y : ↥(ModularCurve.laurentBaseChange ℂ F₀))
+    (hy : (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ)
+    (σ : SL(2, ℤ))
+    (Φ : ModularCurve.laurentBaseChange ℂ F₀ →+* LaurentSeries ℂ)
+    (P : AlgebraicCurve.Place ℂ (ModularCurve.laurentBaseChange ℂ F₀)) (e : ℕ) (he : 0 < e)
+    (hpres : ∀ (x : ModularCurve.laurentBaseChange ℂ F₀) (k : ℤ)
+          (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k), h ≠ 0 →
+        (x : LaurentSeries ℂ) *
+            ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries
+              ℂ) =
+          ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+            →
+        Φ x * ((UpperHalfPlane.qExpansion (Γ.normalCore.index : ℝ)
+              ((h : UpperHalfPlane → ℂ) ∣[k] σ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+          ((UpperHalfPlane.qExpansion (Γ.normalCore.index : ℝ)
+              ((g : UpperHalfPlane → ℂ) ∣[k] σ) : PowerSeries ℂ) : LaurentSeries ℂ))
+    (hord : ∀ x : ModularCurve.laurentBaseChange ℂ F₀, x ≠ 0 → (Φ x).order = e * P.ord x)
+    (hyo : (Φ y).order = -(Γ.normalCore.index : ℤ))
+    (hdeg : Module.finrank
+        ↥(IntermediateField.adjoin ℂ ({y} : Set ↥(ModularCurve.laurentBaseChange ℂ F₀)))
+        ↥(ModularCurve.laurentBaseChange ℂ F₀) =
+      (Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index)
+    (h : ℕ) (hh : 0 < h)
+    (hmem : σ * ModularGroup.T ^ h * σ⁻¹ ∈ Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)))
+    (hmin : ∀ k : ℕ, 0 < k → σ * ModularGroup.T ^ k * σ⁻¹ ∈ Γ ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) → h
+      ≤ k) :
+    P.ord y = -(h : ℤ) :=
+  solution Γ hT hΓ F₀ hF y hy σ Φ P e he hpres hord hyo hdeg h hh hmem hmin
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1.lean
new file mode 100644
index 0000000000..dc5b9c9616
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1.lean
@@ -0,0 +1,268 @@
+/-
+Based on Prove2Me node
+ModularCurve.ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1
+(6afd7dca-6a3d-5d97-874a-22a33c55b1d3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 70b9fee4-5d44-5921-a4fd-dfdc12bf344c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.RingTheory.Flat.TorsionFree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_place_algebraicClosure_ord_comp_eq_of_laurentBaseChange
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_mem_intFormRatiosC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1_algebraicClosure
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Orders of j and j-1728 on X₁(M) for M≥ 4
+
+Theorem statement:
+`ModularCurve.ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1`
+(`6afd7dca-6a3d-5d97-874a-22a33c55b1d3`), by Claude, 2026-09-05.
+
+Proof: submission `70b9fee4-5d44-5921-a4fd-dfdc12bf344c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field equipped with a $\mathbb{Q}$-algebra structure (so of
+characteristic $0$), and let $M$ be a nonzero natural number with $4 \le M$. Let $F_0 =$
+`qExpFunctionFieldC ℚ (Gamma1 M)` be the subfield of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$
+by all quotients $P_f/P_g$ of $q$-expansions, where $f$ and $g$ are modular forms of one and the
+same weight $k$ for $\Gamma_1(M)$ (regarded inside $\mathrm{GL}_2(\mathbb{R})$) whose $q$-expansions
+are given by integral power series $P_f, P_g$ with $P_g \ne 0$ in $\mathbb{Q}((q))$; and let $F =$
+`laurentBaseChange K F₀` be the subfield of $K((q))$ generated over $K$ by the image of $F_0$ under
+coefficientwise application of $\mathbb{Q} \to K$. Let $y \in F$ be an element whose underlying
+Laurent series is `jqModC K`, namely $q^{-1}$ times the image in $K[[q]]$ of the integral power
+series $E_4^3 \cdot \Delta^{-1}$, i.e. the $q$-expansion of the modular invariant $j$. The assertion
+is the conjunction of two statements about all places $P$ of $F$ over $K$, a place being a valuation
+subring of $F$ containing $K$, distinct from $F$ itself and a principal ideal ring, with
+$P.\mathrm{ord}$ the associated normalised integer valuation: first, for every such $P$, if
+$\mathrm{ord}_P(y) > 0$ then $\mathrm{ord}_P(y) = 3$; second, for every such $P$, if
+$\mathrm{ord}_P(y - 1728) > 0$ then $\mathrm{ord}_P(y - 1728) = 2$.
+
+This is the statement that $X_1(M)$ has no elliptic points for $M \ge 4$, in the form that every
+zero of $j$ on the curve has order exactly $3$ and every zero of $j-1728$ order exactly $2$: the
+covering $X_1(M) \to X(1)$ is unramified over $j = 0$ and $j = 1728$. It is used to compute
+ramification indices for $X_1(M) \to X(1)$, parities of orders of modular forms at places, and
+thereby the genus of $X_1(M)$; the case $K = \overline{\mathbb{Q}}$ is transferred to general
+algebraically closed $K$ of characteristic $0$ by comparison of places under coefficientwise base
+change.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1
+
+noncomputable section
+
+p2m_open "AlgebraicCurve ModularCurve \
+  P2MW.S_ModularCurve_ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1.ModularCu\
+  rve"
+open scoped MatrixGroups
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpFunctionFieldC intFormRatiosC_subset coeffMap coeffMap_single \
+  coeffMap_coeffMap coeffMap_congr algebraMap_laurentSeries_eq_single coeffEmb laurentBaseChange \
+  coeffEmb_mem_laurentBaseChange mem_laurentBaseChange_iff jqModC map_jqModC \
+  ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1_algebraicClosure \
+  exists_place_algebraicClosure_ord_comp_eq_of_laurentBaseChange jqModC_mem_intFormRatiosC"
+namespace NoEllK
+p2m_open "ModularCurve"
+
+section CoeffLift
+
+variable {L : Type*} [Field L] {Ω : Type*} [Field Ω] [Algebra ℚ L] [Algebra ℚ Ω] (τ : L →ₐ[ℚ] Ω)
+  (F₀ : IntermediateField ℚ (LaurentSeries ℚ))
+
+theorem coeffMap_coeffEmb' (x : LaurentSeries ℚ) :
+    coeffMap τ.toRingHom (coeffEmb L x) = coeffEmb Ω x := by
+  change coeffMap _ (coeffMap _ x) = coeffMap _ x
+  rw [coeffMap_coeffMap]
+  exact coeffMap_congr (RingHom.ext_rat _ _) x
+
+theorem coeffMap_algebraMap' (c : L) :
+    coeffMap τ.toRingHom (algebraMap L (LaurentSeries L) c) = algebraMap Ω (LaurentSeries Ω) (τ c)
+      := by
+  rw [algebraMap_laurentSeries_eq_single, algebraMap_laurentSeries_eq_single, coeffMap_single]
+  rfl
+
+theorem coeffMap_mem_laurentBaseChange' {x : LaurentSeries L} (hx : x ∈ laurentBaseChange L F₀) :
+    coeffMap τ.toRingHom x ∈ laurentBaseChange Ω F₀ := by
+  rw [mem_laurentBaseChange_iff] at hx
+  induction hx using Subfield.closure_induction with
+  | mem y hy =>
+      rcases hy with ⟨a, rfl⟩ | ⟨z, hz, rfl⟩
+      · rw [coeffMap_algebraMap']
+        exact (laurentBaseChange Ω F₀).algebraMap_mem _
+      · rw [coeffMap_coeffEmb']
+        exact coeffEmb_mem_laurentBaseChange Ω hz
+  | one => simp
+  | add _ _ _ _ hx hy => simpa using add_mem hx hy
+  | neg _ _ hx => simpa using neg_mem hx
+  | inv _ _ hx => simpa using inv_mem hx
+  | mul _ _ _ _ hx hy => simpa using mul_mem hx hy
+
+@[reducible] def algebraOfLift : Algebra L ↥(laurentBaseChange Ω F₀) :=
+  ((algebraMap Ω ↥(laurentBaseChange Ω F₀)).comp τ.toRingHom).toAlgebra
+
+def liftRingHom : ↥(laurentBaseChange L F₀) →+* ↥(laurentBaseChange Ω F₀) :=
+  ((coeffMap τ.toRingHom).comp (laurentBaseChange L F₀).toSubring.subtype).codRestrict
+    (laurentBaseChange Ω F₀).toSubring (fun x => coeffMap_mem_laurentBaseChange' τ F₀ x.2)
+
+theorem coe_liftRingHom (x : ↥(laurentBaseChange L F₀)) :
+    ((liftRingHom τ F₀ x : ↥(laurentBaseChange Ω F₀)) : LaurentSeries Ω) = coeffMap τ.toRingHom x :=
+  rfl
+
+def liftHom :
+    letI := algebraOfLift τ F₀; ↥(laurentBaseChange L F₀) →ₐ[L] ↥(laurentBaseChange Ω F₀) :=
+  letI := algebraOfLift τ F₀
+  { liftRingHom τ F₀ with
+    commutes' := fun c => Subtype.ext (by
+      change coeffMap τ.toRingHom (algebraMap L (LaurentSeries L) c) = algebraMap Ω (LaurentSeries
+        Ω) (τ c)
+      exact coeffMap_algebraMap' τ c) }
+
+theorem coe_liftHom (x : ↥(laurentBaseChange L F₀)) :
+    letI := algebraOfLift τ F₀; ((liftHom τ F₀ x : ↥(laurentBaseChange Ω F₀)) : LaurentSeries Ω) =
+      coeffMap τ.toRingHom x :=
+  rfl
+
+theorem liftHom_toRingHom :
+    letI := algebraOfLift τ F₀; (liftHom τ F₀).toRingHom = liftRingHom τ F₀ := rfl
+
+theorem adjoin_range_liftRingHom_eq_top :
+    IntermediateField.adjoin Ω (Set.range (liftRingHom τ F₀)) = ⊤ := by
+  rw [eq_top_iff]
+  intro z _
+  let T : IntermediateField Ω ↥(laurentBaseChange Ω F₀) :=
+    IntermediateField.adjoin Ω (Set.range (liftRingHom τ F₀))
+  let T' : Subfield (LaurentSeries Ω) := T.toSubfield.map (laurentBaseChange Ω F₀).val.toRingHom
+  have hgens : Set.range (algebraMap Ω (LaurentSeries Ω)) ∪ (⇑(coeffEmb Ω) '' (F₀ : Set
+    (LaurentSeries ℚ))) ⊆ T' :=
+    by
+    rintro w (⟨a, rfl⟩ | ⟨x, hx, rfl⟩)
+    · exact ⟨algebraMap Ω ↥(laurentBaseChange Ω F₀) a, T.algebraMap_mem a, rfl⟩
+    · refine ⟨liftRingHom τ F₀ ⟨coeffEmb L x, coeffEmb_mem_laurentBaseChange L hx⟩,
+        IntermediateField.subset_adjoin Ω _ ⟨_, rfl⟩, ?_⟩
+      change coeffMap τ.toRingHom (coeffEmb L x) = coeffEmb Ω x
+      exact coeffMap_coeffEmb' τ x
+  have hle : Subfield.closure (Set.range (algebraMap Ω (LaurentSeries Ω)) ∪
+      (⇑(coeffEmb Ω) '' (F₀ : Set (LaurentSeries ℚ)))) ≤ T' := Subfield.closure_le.mpr hgens
+  obtain ⟨w, hw, hwz⟩ := hle (mem_laurentBaseChange_iff.mp z.2)
+  have : w = z := Subtype.ext hwz
+  rw [← this]
+  exact hw
+
+end CoeffLift
+
+end ModularCurve.NoEllK
+
+open ModularCurve.NoEllK in
+theorem solution
+    (K : Type*) [Field K] [Algebra ℚ K] [IsAlgClosed K]
+    (M : ℕ) [NeZero M] (hM : 4 ≤ M)
+    (y : ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))))
+    (hy : (y : LaurentSeries K) = ModularCurve.jqModC K) :
+    (∀ P : AlgebraicCurve.Place K ↥(ModularCurve.laurentBaseChange K
+      (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))), 0 < P.ord y → P.ord y = 3)
+      ∧
+      (∀ P : AlgebraicCurve.Place K ↥(ModularCurve.laurentBaseChange K
+        (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))), 0 < P.ord (y - 1728) →
+        P.ord (y - 1728) = 2) := by
+  classical
+  have hQalg : Algebra.IsAlgebraic ℚ (AlgebraicClosure ℚ) := by
+    constructor
+    intro x
+    obtain ⟨p, hp0, hp⟩ := (AlgebraicClosure.isAlgebraic ℚ).isAlgebraic x
+    refine ⟨p, hp0, ?_⟩
+    rw [Polynomial.aeval_def] at hp ⊢
+    convert hp using 2
+  let τ : AlgebraicClosure ℚ →ₐ[ℚ] K := IsAlgClosed.lift
+  let F₀ : IntermediateField ℚ (LaurentSeries ℚ) :=
+    ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)
+  let Ψ := liftRingHom τ F₀
+  have hΨ : ∀ f, ((Ψ f : ↥(ModularCurve.laurentBaseChange K F₀)) : LaurentSeries K) =
+      ModularCurve.coeffMap τ.toRingHom (f : LaurentSeries (AlgebraicClosure ℚ)) := fun f => rfl
+  have hjmem : ModularCurve.coeffEmb (AlgebraicClosure ℚ) (ModularCurve.jqModC ℚ) ∈
+      ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) F₀ :=
+    ModularCurve.coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+      (ModularCurve.intFormRatiosC_subset ℚ _ (ModularCurve.jqModC_mem_intFormRatiosC ℚ
+        (CongruenceSubgroup.Gamma1 M)))
+  let y₀ : ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) F₀) := ⟨_, hjmem⟩
+  have hy₀ : (y₀ : LaurentSeries (AlgebraicClosure ℚ)) = ModularCurve.jqModC (AlgebraicClosure ℚ) :=
+    by
+    change ModularCurve.coeffEmb (AlgebraicClosure ℚ) (ModularCurve.jqModC ℚ) = _
+    exact ModularCurve.map_jqModC _
+  have hΨy : Ψ y₀ = y := by
+    apply Subtype.ext
+    rw [hΨ, hy₀, hy]
+    exact ModularCurve.map_jqModC _
+  have hT : ModularGroup.T ∈ CongruenceSubgroup.Gamma1 M := by
+    rw [CongruenceSubgroup.Gamma1_mem]; simp [ModularGroup.T]
+  refine ⟨fun P hpos => ?_, fun P hpos => ?_⟩
+  · rw [← hΨy] at hpos ⊢
+    obtain ⟨P₀, hP₀⟩ :=
+      ModularCurve.exists_place_algebraicClosure_ord_comp_eq_of_laurentBaseChange K
+      (CongruenceSubgroup.Gamma1 M) hT τ Ψ hΨ P ⟨y₀, hpos.ne'⟩
+    rw [hP₀] at hpos ⊢
+    exact
+      (ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1_algebraicClosure
+      M hM
+      y₀ hy₀ P₀).1 hpos
+  · have hsub : y - 1728 = Ψ (y₀ - 1728) := by rw [map_sub, map_ofNat, hΨy]
+    rw [hsub] at hpos ⊢
+    obtain ⟨P₀, hP₀⟩ :=
+      ModularCurve.exists_place_algebraicClosure_ord_comp_eq_of_laurentBaseChange K
+      (CongruenceSubgroup.Gamma1 M) hT τ Ψ hΨ P ⟨y₀ - 1728, hpos.ne'⟩
+    rw [hP₀] at hpos ⊢
+    exact
+      (ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1_algebraicClosure
+      M hM
+      y₀ hy₀ P₀).2 hpos
+
+end
+end S_ModularCurve_ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1
+end P2MW
+export P2MW.S_ModularCurve_ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve CongruenceSubgroup AlgebraicCurve
+open scoped MatrixGroups
+theorem ModularCurve.ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1
+    (K : Type*) [Field K] [Algebra ℚ K] [IsAlgClosed K]
+    (M : ℕ) [NeZero M] (hM : 4 ≤ M)
+    (y : ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))))
+    (hy : (y : LaurentSeries K) = ModularCurve.jqModC K) :
+    (∀ P : AlgebraicCurve.Place K ↥(ModularCurve.laurentBaseChange K
+      (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))), 0 < P.ord y → P.ord y = 3)
+      ∧
+      (∀ P : AlgebraicCurve.Place K ↥(ModularCurve.laurentBaseChange K
+        (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))), 0 < P.ord (y - 1728) →
+        P.ord (y - 1728) = 2) :=
+  solution K M hM y hy
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1_algebraicClosure.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1_algebraicClosure.lean
new file mode 100644
index 0000000000..1889e62a00
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1_algebraicClosure.lean
@@ -0,0 +1,459 @@
+/-
+Based on Prove2Me node
+ModularCurve.ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1_algebraicClosure
+(56ee15ee-939b-5cfb-be23-8ce5ba8e581b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1e109a5a-0444-59e3-8325-4799324db6be
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_comap_algebraMap_eq_of_constantFieldExtension
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_restrictAlong_eq_natCard_algHom_of_isGalois
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_transcendental_of_perfectField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_CongruenceSubgroup_eq_one_or_eq_neg_one_of_mem_Gamma1_of_smul_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_JOneES_exists_transcendental_finiteDimensional_laurentBaseChange
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_Descent_fixer_le
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_monoidHom_algEquiv_fixedField_eq_adjoin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_place_ord_jGen_eq_three_two_and_stabilizer_subset_zpowers
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN_qExpansion
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelN_structure_package
+
+/-!
+# No elliptic points on X₁(M), M ≥ 4, over ℚ̄
+
+Theorem statement:
+`ModularCurve.ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1_algebraicClosure`
+(`56ee15ee-939b-5cfb-be23-8ce5ba8e581b`), by Claude, 2026-09-05.
+
+Proof: submission `1e109a5a-0444-59e3-8325-4799324db6be`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $M \ge 4$. Let $F(\Gamma_1(M)) \subseteq \mathbb{Q}((q))$ be
+[`ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)`](def/ModularCurve_X1.html#L101),
+the subfield of the field of Laurent series over $\mathbb{Q}$ generated over $\mathbb{Q}$ by all
+quotients $p_f/p_g$ of $q$-expansions with integral coefficients of two modular forms $f, g$ of one
+and the same weight $k$ for $\Gamma_1(M)$, the denominator series being nonzero, and let $F$ be
+[`ModularCurve.laurentBaseChange`](def/ModularCurve_LaurentCoeff.html#L103) of it to
+$\overline{\mathbb{Q}} =$ `AlgebraicClosure ℚ`, namely the subfield of $\overline{\mathbb{Q}}((q))$
+generated over $\overline{\mathbb{Q}}$ by the image of $F(\Gamma_1(M))$ under the coefficientwise
+extension of $\mathbb{Q} \to \overline{\mathbb{Q}}$. Let $y \in F$ be an element whose underlying
+Laurent series is [`ModularCurve.jqModC`](def/ModularCurve_JqCoeff.html#L15), that is $q^{-1}$ times
+the power series $E_4^3 \cdot \eta^{-24}$-style numerator `jNum` mapped into
+$\overline{\mathbb{Q}}$, the $q$-expansion of the modular invariant $j$. Let $P$ be a place of $F$
+over $\overline{\mathbb{Q}}$, i.e. a valuation subring of $F$ containing $\overline{\mathbb{Q}}$,
+distinct from $F$ and a principal ideal ring, and let $\operatorname{ord}_P$ be the associated
+normalised integer-valued order function. Then $\operatorname{ord}_P(y) > 0$ implies
+$\operatorname{ord}_P(y) = 3$, and $\operatorname{ord}_P(y - 1728) > 0$ implies
+$\operatorname{ord}_P(y - 1728) = 2$.
+
+This is the statement that the covering $X_1(M) \to X(1)$ has no elliptic points for $M \ge 4$, so
+that it is ramified to order exactly $3$ above $j = 0$ and exactly $2$ above $j = 1728$, phrased for
+places of the $q$-expansion function field after base change of constants to
+$\overline{\mathbb{Q}}$. It is used to obtain the corresponding ramification statement for the
+function field over $\mathbb{Q}$ itself, in the computation of the genus and of the divisors of
+$X_1(M)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1_algebraicClosure.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 800000
+set_option synthInstance.maxHeartbeats 80000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+local notation "ℚ̄" => AlgebraicClosure ℚ
+
+open AlgebraicCurve ModularCurve IntermediateField CongruenceSubgroup
+
+open scoped MatrixGroups
+
+noncomputable section
+
+namespace ModularCurve
+
+namespace NoEllAux
+
+theorem isDomain_levelN_ring (N : ℕ) [NeZero N] : IsDomain ↥(ModularCurve.LevelN.ring N) := by
+  have h := WLight.levelN_structure_package N (fun τ => PeriodPair.ofTau τ) (fun τ => ⟨rfl, rfl⟩)
+    (LevelN.wp N) (fun v τ => rfl) (ModularCurve.LevelN.fricke N) (fun v τ => rfl)
+    ModularCurve.LevelN.jAnalytic (fun τ => rfl)
+  obtain ⟨-, -, -, -, -, hdom⟩ := h
+  have : NoZeroDivisors ↥(ModularCurve.LevelN.ring N) := ⟨fun {a b} hab => by
+    have := hdom a b a.2 b.2 (by rw [← Subalgebra.coe_mul, hab]; rfl)
+    rcases this with h0 | h0
+    · left; exact Subtype.ext h0
+    · right; exact Subtype.ext h0⟩
+  have : Nontrivial ↥(ModularCurve.LevelN.ring N) := inferInstance
+  exact NoZeroDivisors.to_isDomain _
+
+theorem mem_sup_zpowers_neg_one_iff (H : Subgroup SL(2, ℤ)) (g : SL(2, ℤ)) :
+    g ∈ H ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) ↔ g ∈ H ∨ -g ∈ H := by
+  have hN : (Subgroup.zpowers (-1 : SL(2, ℤ))).Normal := by
+    refine ⟨fun n hn g => ?_⟩
+    obtain ⟨k, rfl⟩ := Subgroup.mem_zpowers_iff.mp hn
+    have hc : Commute ((-1 : SL(2, ℤ)) ^ k) g := (Commute.neg_one_left g).zpow_left k
+    rw [← hc.eq, mul_inv_cancel_right]
+    exact Subgroup.zpow_mem_zpowers _ _
+  have hpm : ∀ n ∈ Subgroup.zpowers (-1 : SL(2, ℤ)), n = 1 ∨ n = -1 := by
+    intro n hn
+    obtain ⟨k, rfl⟩ := Subgroup.mem_zpowers_iff.mp hn
+    rcases Int.even_or_odd k with ⟨m, rfl⟩ | ⟨m, rfl⟩
+    · left
+      rw [← two_mul, zpow_mul, zpow_ofNat]
+      simp
+    · right
+      rw [zpow_add, zpow_mul, zpow_ofNat, zpow_one]
+      simp
+  constructor
+  · intro hg
+    have hg' : g ∈ ((H ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) : Subgroup SL(2, ℤ)) : Set SL(2, ℤ)) := hg
+    rw [Subgroup.mul_normal] at hg'
+    obtain ⟨h, hh, n, hn, rfl⟩ := Set.mem_mul.mp hg'
+    rcases hpm n hn with rfl | rfl
+    · left; simpa using hh
+    · right; simpa using hh
+  · rintro (hg | hg)
+    · exact Subgroup.mem_sup_left hg
+    · have : g = (-g) * (-1) := by simp
+      rw [this]
+      exact Subgroup.mul_mem _ (Subgroup.mem_sup_left hg) (Subgroup.mem_sup_right
+        (Subgroup.mem_zpowers _))
+
+theorem ST_smul_ρ : (ModularGroup.S * ModularGroup.T) • UpperHalfPlane.ρ = UpperHalfPlane.ρ :=
+  ModularGroup.stabilizer_ρ.mpr (by simp)
+
+theorem S_smul_I : ModularGroup.S • UpperHalfPlane.I = UpperHalfPlane.I :=
+  ModularGroup.stabilizer_I.mpr (by simp)
+
+end ModularCurve.NoEllAux
+
+-- Keep the Galois/ramification argument abstract: none of its instance searches needs
+-- to unfold the concrete fraction field of the level-N ring of modular functions.
+private theorem ModularCurve.NoEllAux.keyEQ
+    {K : Type*} [Field K] [Algebra ℂ K]
+    (M : ℕ) [NeZero M] (hM : 4 ≤ M) (t : K)
+    (E : IntermediateField ℂ K) (v : ↥E) (σ : SL(2, ℤ) →* (K ≃ₐ[ℂ] K))
+    (hv : E.val v = t)
+    (hfd : FiniteDimensional ℂ⟮t⟯ K)
+    (hgal : IsGalois ℂ⟮t⟯ K)
+    (hker : σ.ker = Gamma M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)))
+    (hfix : fixedField σ.range = ℂ⟮t⟯)
+    (hdeg : Module.finrank ℂ⟮t⟯ K = (Gamma M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index)
+    (hint : ∀ ψ : E →ₐ[ℂ] K, ψ v = t → ψ.toRingHom.IsIntegral)
+    (hfixer : ∀ η : SL(2, ℤ), (∀ e : ↥E, σ η (e : K) = (e : K)) →
+      η ∈ Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))) :
+    ∀ (j₀ : ℂ) (W₀ : Place ℂ K) (γ₀ : SL(2, ℤ)) (τ₀ : UpperHalfPlane), γ₀ • τ₀ = τ₀ →
+      0 < W₀.ord (t - algebraMap ℂ K j₀) →
+      (∀ g : K ≃ₐ[ℂ⟮t⟯] K,
+        SemilinearAut.ofAlgAut (g.restrictScalars ℂ) • W₀ = W₀ → ∃ k : ℕ, g.restrictScalars ℂ = σ γ₀
+          ^ k) →
+      ∀ w : Place ℂ ↥E, 0 < w.ord (v - algebraMap ℂ ↥E j₀) →
+        w.ord (v - algebraMap ℂ ↥E j₀) = W₀.ord (t - algebraMap ℂ K j₀) := by
+  classical
+  have := hfd
+  have := hgal
+  intro j₀ W₀ γ₀ τ₀ hγτ hW₀ hD w hw
+  obtain ⟨h1, -, h3, h4, h5⟩ :=
+    Place.ord_restrictAlong_eq_natCard_algHom_of_isGalois ℂ (v) t j₀ E.val hv
+    hfd hgal hint W₀ hW₀
+  obtain ⟨ψ, hψ, rfl⟩ := h3 w hw
+  rw [h5 ψ hψ, h1]
+  have htmem : t ∈ ℂ⟮t⟯ := mem_adjoin_simple_self ℂ t
+  have hσt : ∀ g : K ≃ₐ[ℂ⟮t⟯] K, g t = t := fun g =>
+    g.commutes (⟨t, htmem⟩ : ℂ⟮t⟯)
+  have hle' : ℂ⟮t⟯ ≤ E :=
+    adjoin_simple_le_iff.mpr (by rw [← hv]; exact v.2)
+  let rSH : (K ≃ₐ[ℂ⟮t⟯] K) →* (K ≃ₐ[ℂ] K) :=
+    { toFun := fun g => g.restrictScalars ℂ
+      map_one' := AlgEquiv.ext fun _ => rfl
+      map_mul' := fun _ _ => AlgEquiv.ext fun _ => rfl }
+  have hrSH : ∀ g z, rSH g z = g z := fun _ _ => rfl
+  have rSH_inj : Function.Injective rSH := fun g h hgh => AlgEquiv.ext fun z => by
+    have := congrArg (fun f : K ≃ₐ[ℂ] K => f z) hgh
+    exact this
+  have hfixL : ∀ (d : SL(2, ℤ)), ∀ z ∈ ℂ⟮t⟯, σ d z = z := fun d z hz => by
+    rw [← hfix] at hz
+    exact (mem_fixedField_iff _ z).mp hz _ ⟨d, rfl⟩
+  have hrange : σ.range = rSH.range := by
+    have hle : σ.range ≤ rSH.range := by
+      rintro _ ⟨d, rfl⟩
+      exact ⟨{ (σ d).toRingEquiv with commutes' := fun z => hfixL d z z.2 }, AlgEquiv.ext fun _ =>
+        rfl⟩
+    refine Subgroup.eq_of_le_of_card_ge hle (le_of_eq ?_)
+    show Nat.card rSH.range = Nat.card σ.range
+    rw [← Subgroup.index_ker σ, hker, ← hdeg, ← IsGalois.card_aut_eq_finrank]
+    exact (Nat.card_congr (MonoidHom.ofInjective rSH_inj).toEquiv).symm
+  let gmap : {g : K ≃ₐ[ℂ⟮t⟯] K //
+        SemilinearAut.ofAlgAut (g.restrictScalars ℂ) • W₀ = W₀} →
+      {ψ' : {ψ' : ↥E →ₐ[ℂ] K // ψ' (v) = t} //
+        W₀.restrictAlong ψ'.1 (hint ψ'.1 ψ'.2) = W₀.restrictAlong ψ (hint ψ hψ)} := fun g =>
+    have hψg : (((g.1 : K →ₐ[ℂ⟮t⟯] K).restrictScalars ℂ).comp ψ) (v) = t := by
+      rw [AlgHom.comp_apply, AlgHom.restrictScalars_apply, hψ]; exact hσt g.1
+    ⟨⟨((g.1 : K →ₐ[ℂ⟮t⟯] K).restrictScalars ℂ).comp ψ, hψg⟩,
+      ((h4 ψ _ hψ hψg).mpr ⟨g.1, g.2, rfl⟩).symm⟩
+  have hsurj : Function.Surjective gmap := by
+    rintro ⟨⟨ψ', hψ'⟩, heq⟩
+    obtain ⟨g, hg, rfl⟩ := (h4 ψ ψ' hψ hψ').mp heq.symm
+    exact ⟨⟨g, hg⟩, rfl⟩
+  have hclaim : ∀ g : K ≃ₐ[ℂ⟮t⟯] K,
+      SemilinearAut.ofAlgAut (g.restrictScalars ℂ) • W₀ = W₀ → (∀ e : ↥E, g (ψ e) = ψ e) → g = 1
+        := by
+    intro g hgW hgψ
+    obtain ⟨k, hk⟩ := hD g hgW
+    have hψfix : ∀ (z : K) (hz : z ∈ ℂ⟮t⟯), ψ ⟨z, hle' hz⟩ = z := by
+      intro z hz
+      let T : IntermediateField ℂ ↥E :=
+        (AlgHom.equalizer ψ E.val).toIntermediateField (fun x hx => by
+        rw [AlgHom.mem_equalizer] at hx ⊢
+        rw [map_inv₀, map_inv₀, hx])
+      have hTle : ℂ⟮v⟯ ≤ T := by
+        rw [adjoin_simple_le_iff]
+        change ψ (v) = E.val (v)
+        rw [hψ, hv]
+      have hzmem : (⟨z, hle' hz⟩ : E) ∈ ℂ⟮v⟯ := by
+        rw [← mem_lift (⟨z, hle' hz⟩ : E), lift_adjoin_simple]
+        have : ((v : E) : K) = t := hv
+        rwa [this]
+      exact hTle hzmem
+    let E₂ : IntermediateField ℂ⟮t⟯ K := extendScalars hle'
+    let ψ₂ : ↥E₂ →ₐ[ℂ⟮t⟯] K :=
+      { ψ.toRingHom with commutes' := fun z => hψfix z z.2 }
+    have hψ₂ : ∀ e : ↥E, ψ₂ e = ψ e := fun _ => rfl
+    let φ' : K →ₐ[ℂ⟮t⟯] K := ψ₂.liftNormal K
+    have hφ' : ∀ e : E, φ' (e : K) = ψ e := fun e => AlgHom.liftNormal_commutes ψ₂ K e
+    have : Algebra.IsAlgebraic ℂ⟮t⟯ K := Algebra.IsAlgebraic.of_finite _ _
+    let g' : K ≃ₐ[ℂ⟮t⟯] K :=
+      AlgEquiv.ofBijective φ' (Algebra.IsAlgebraic.algHom_bijective φ')
+    have hg' : ∀ e : ↥E, g' (e : K) = ψ e := hφ'
+    obtain ⟨δ', hδ'⟩ : rSH g' ∈ σ.range := by rw [hrange]; exact ⟨g', rfl⟩
+    set η : SL(2, ℤ) := δ'⁻¹ * γ₀ ^ k * δ' with hη
+    have hσg : rSH g = σ (γ₀ ^ k) := by rw [map_pow]; exact hk
+    have hση : σ η = rSH (g'⁻¹ * g * g') := by
+      rw [hη, map_mul, map_mul, map_inv, hδ', map_mul, map_mul, map_inv, hσg]
+    have hηfix : ∀ e : ↥E, σ η (e : K) = (e : K) := by
+      intro e
+      rw [hση, hrSH, AlgEquiv.mul_apply, AlgEquiv.mul_apply]
+      have h1 : g' (e : K) = ψ e := hg' e
+      rw [h1, hgψ, ← h1]
+      exact g'.symm_apply_apply _
+    have hηmem := hfixer η hηfix
+    rw [mem_sup_zpowers_neg_one_iff] at hηmem
+    have hγpow : ∀ n : ℕ, (γ₀ ^ n) • τ₀ = τ₀ := fun n => by
+      induction n with
+      | zero => rw [pow_zero, one_smul]
+      | succ n ih => rw [pow_succ, mul_smul, hγτ, ih]
+    have hηpt : η • (δ'⁻¹ • τ₀) = δ'⁻¹ • τ₀ := by
+      rw [hη, mul_smul, mul_smul, smul_inv_smul, hγpow k]
+    have hη1 :=
+      CongruenceSubgroup.eq_one_or_eq_neg_one_of_mem_Gamma1_of_smul_eq M hM η hηmem (δ'⁻¹ • τ₀) hηpt
+    have hγk1 : σ (γ₀ ^ k) = 1 := by
+      have hconj : γ₀ ^ k = δ' * η * δ'⁻¹ := by rw [hη]; group
+      have hneg1 : σ (-1) = 1 := by
+        have : (-1 : SL(2, ℤ)) ∈ σ.ker :=
+          by rw [hker]; exact Subgroup.mem_sup_right (Subgroup.mem_zpowers _)
+        exact this
+      rcases hη1 with h | h
+      · rw [hconj, h, mul_one, mul_inv_cancel, map_one]
+      · rw [hconj, h]
+        rw [show δ' * -1 * δ'⁻¹ = (-1 : SL(2, ℤ)) by simp, hneg1]
+    apply rSH_inj
+    rw [hσg, hγk1, map_one]
+  have hinj : Function.Injective gmap := by
+    rintro ⟨g₁, hg₁⟩ ⟨g₂, hg₂⟩ heq
+    have hcomp : ((g₁ : K →ₐ[ℂ⟮t⟯] K).restrictScalars ℂ).comp ψ =
+        ((g₂ : K →ₐ[ℂ⟮t⟯] K).restrictScalars ℂ).comp ψ :=
+      congrArg (fun e => e.1.1) heq
+    have hg : g₂⁻¹ * g₁ = 1 := by
+      refine hclaim (g₂⁻¹ * g₁) ?_ ?_
+      · rw [show (g₂⁻¹ * g₁).restrictScalars ℂ = (g₂.restrictScalars ℂ)⁻¹ * g₁.restrictScalars ℂ
+          from
+          AlgEquiv.ext fun _ => rfl, map_mul, map_inv, mul_smul, hg₁, inv_smul_eq_iff, hg₂]
+      · intro e
+        have h12 : g₁ (ψ e) = g₂ (ψ e) := by
+          have := congrArg (fun f : ↥E →ₐ[ℂ] K => f e) hcomp
+          exact this
+        rw [AlgEquiv.mul_apply, h12]
+        exact g₂.symm_apply_apply _
+    apply Subtype.ext
+    exact (inv_mul_eq_one.mp hg).symm
+  exact_mod_cast (Nat.card_eq_of_bijective gmap ⟨hinj, hsurj⟩).symm
+
+theorem ModularCurve.NoEllAux.main
+    (M : ℕ) [NeZero M] (hM : 4 ≤ M)
+    (y : laurentBaseChange ℚ̄ (qExpFunctionFieldC ℚ (Gamma1 M)))
+    (hy : (y : LaurentSeries ℚ̄) = ModularCurve.jqModC ℚ̄)
+    (P : Place ℚ̄ (laurentBaseChange ℚ̄ (qExpFunctionFieldC ℚ (Gamma1 M)))) :
+    (0 < P.ord y → P.ord y = 3) ∧ (0 < P.ord (y - 1728) → P.ord (y - 1728) = 2) := by
+  classical
+  have : IsDomain ↥(ModularCurve.LevelN.ring M) := isDomain_levelN_ring M
+  let K : Type := FractionRing ↥(ModularCurve.LevelN.ring M)
+  let algCK : Algebra ℂ K := inferInstance
+  have : IsScalarTower ℂ ↥(ModularCurve.LevelN.ring M) K := inferInstance
+  have hQalg : Algebra.IsAlgebraic ℚ ℚ̄ := AlgebraicClosure.isAlgebraic ℚ
+  let ιa : ℚ̄ →ₐ[ℚ] ℂ := IsAlgClosed.lift
+  let ι : ℚ̄ →+* ℂ := ιa.toRingHom
+  have hΓM : Gamma M ≤ Gamma1 M := by
+    intro γ hγ
+    rw [Gamma_mem] at hγ
+    rw [Gamma1_mem]
+    exact ⟨hγ.1, hγ.2.2.2, hγ.2.2.1⟩
+  have hT : ModularGroup.T ∈ Gamma1 M := by
+    rw [Gamma1_mem]; simp [ModularGroup.T]
+  obtain ⟨Φ, E', hE'j, hE'Φ, hΦc, hΦy, hΦfix⟩ :=
+    ModularCurve.exists_ringHom_laurentBaseChange_qExpFunctionFieldC_levelN_qExpansion M
+      (Gamma1 M) hΓM hT ι K
+  obtain ⟨hst, σ, hσ, hker, hfix, htr, hfd, hdeg, hgal⟩ :=
+    ModularCurve.LevelN.exists_monoidHom_algEquiv_fixedField_eq_adjoin M K
+  have hM2 : 2 ≤ M := by omega
+  obtain ⟨⟨W0, hW0, hD0⟩, ⟨W1728, hW1728, hD1728⟩⟩ :=
+    ModularCurve.LevelN.exists_place_ord_jGen_eq_three_two_and_stabilizer_subset_zpowers M hM2 K hst
+      σ hσ hker
+      hfix hfd hgal
+  have : (Gamma1 M).FiniteIndex := inferInstance
+  let t : K := algebraMap ↥(ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M)
+  have : FiniteDimensional ℂ⟮t⟯ K := hfd
+  have hΦy' : Φ y = t := hΦy y hy
+  let E : IntermediateField ℂ K := adjoin ℂ (Set.range Φ)
+  have hΦmem : ∀ f, Φ f ∈ E := fun f => subset_adjoin ℂ _ ⟨f, rfl⟩
+  let ΦE : ↥(laurentBaseChange ℚ̄ (qExpFunctionFieldC ℚ (Gamma1 M))) →+* ↥E := Φ.codRestrict E hΦmem
+  have hΦE : ∀ f, ((ΦE f : ↥E) : K) = Φ f := fun f => RingHom.codRestrict_apply Φ E hΦmem f
+  have hcoeC : ∀ z : ℂ, ((algebraMap ℂ ↥E z : ↥E) : K) = algebraMap ℂ K z := fun _ => rfl
+  let algFE : Algebra ↥(laurentBaseChange ℚ̄ (qExpFunctionFieldC ℚ (Gamma1 M))) ↥E := ΦE.toAlgebra
+  let algQC : Algebra ℚ̄ ℂ := ι.toAlgebra
+  let algQE : Algebra ℚ̄ ↥E := ((algebraMap ℂ ↥E).comp ι).toAlgebra
+  have : IsScalarTower ℚ̄ ℂ ↥E := IsScalarTower.of_algebraMap_eq fun _ => rfl
+  have : IsScalarTower ℚ̄ ↥(laurentBaseChange ℚ̄ (qExpFunctionFieldC ℚ (Gamma1 M))) ↥E :=
+    IsScalarTower.of_algebraMap_eq fun c =>
+    Subtype.ext (by
+      change ((algebraMap ℂ ↥E (ι c) : ↥E) : K) = ((ΦE (algebraMap ℚ̄ ↥(laurentBaseChange ℚ̄
+        (qExpFunctionFieldC ℚ (Gamma1 M))) c) : ↥E) : K)
+      rw [hcoeC, hΦE, hΦc])
+  obtain ⟨x₀, hx₀tr, hx₀fd⟩ :=
+    ModularCurve.JOneES.exists_transcendental_finiteDimensional_laurentBaseChange ℚ̄ (Gamma1 M) hT
+  have : IsCurveOver ℚ̄ ↥(laurentBaseChange ℚ̄ (qExpFunctionFieldC ℚ (Gamma1 M))) :=
+    isCurveOver_of_transcendental_of_perfectField hx₀tr hx₀fd
+  have htr' : Transcendental ℂ (ΦE y) := fun h => htr (by
+    have h' := isAlgebraic_iff.mp h
+    rwa [hΦE, hΦy'] at h')
+  have hEfd : FiniteDimensional ↥(adjoin ℂ ({ΦE y} : Set ↥E)) ↥E := by
+    have hlift : lift (adjoin ℂ ({ΦE y} : Set ↥E)) = ℂ⟮t⟯ := by
+      rw [lift_adjoin_simple, hΦE, hΦy']
+    have hle' : ℂ⟮t⟯ ≤ E := by rw [← hlift]; exact lift_le _
+    let E₂ : IntermediateField ℂ⟮t⟯ K := extendScalars hle'
+    have hE₂ : FiniteDimensional ℂ⟮t⟯ ↥E₂ := inferInstance
+    let e₁ : ↥(adjoin ℂ ({ΦE y} : Set ↥E)) ≃ₐ[ℂ] ℂ⟮t⟯ :=
+      (liftAlgEquiv _).trans (equivOfEq hlift)
+    let e₂ : ↥E₂ ≃+* ↥E := RingEquiv.refl _
+    exact Module.Finite.of_equiv_equiv e₁.symm.toRingEquiv e₂ (by
+      refine RingHom.ext fun w => Subtype.ext ?_
+      have h1 : ∀ v : ↥(adjoin ℂ ({ΦE y} : Set ↥E)), ((e₁ v : ℂ⟮t⟯) : K) = ((v : ↥E) : K) :=
+        fun v => rfl
+      have h2 := congrArg (fun u : ℂ⟮t⟯ => (u : K)) (e₁.apply_symm_apply w)
+      simp only [h1] at h2
+      exact h2)
+  have hgen : adjoin ℂ (Set.range (algebraMap ↥(laurentBaseChange ℚ̄ (qExpFunctionFieldC ℚ (Gamma1
+    M))) ↥E)) = ⊤ :=
+    by
+    apply lift_injective
+    rw [lift_adjoin, lift_top]
+    have : Subtype.val '' Set.range (algebraMap ↥(laurentBaseChange ℚ̄ (qExpFunctionFieldC ℚ (Gamma1
+      M))) ↥E) = Set.range Φ :=
+      by
+      ext w
+      constructor
+      · rintro ⟨_, ⟨f, rfl⟩, rfl⟩; exact ⟨f, (hΦE f).symm⟩
+      · rintro ⟨f, rfl⟩; exact ⟨ΦE f, ⟨f, rfl⟩, hΦE f⟩
+    rw [this]
+  obtain ⟨P', -, hP'ord, -⟩ := Place.exists_comap_algebraMap_eq_of_constantFieldExtension
+    ℚ̄ ↥(laurentBaseChange ℚ̄ (qExpFunctionFieldC ℚ (Gamma1 M))) ℂ ↥E ⟨x₀, hx₀tr, hx₀fd⟩ ⟨ΦE y,
+      htr', hEfd⟩ hgen P
+  have hvaly : E.val (ΦE y) = t := by rw [coe_val]; exact (hΦE y).trans hΦy'
+  have hint : ∀ ψ : ↥E →ₐ[ℂ] K, ψ (ΦE y) = t → ψ.toRingHom.IsIntegral := by
+    intro ψ hψ
+    let S : Subalgebra ℂ K := ψ.range
+    have hleS : ℂ⟮t⟯.toSubalgebra ≤ S := by
+      have : ℂ⟮t⟯ ≤ ψ.fieldRange :=
+        adjoin_simple_le_iff.mpr ⟨ΦE y, hψ⟩
+      intro w hw
+      exact (AlgHom.mem_fieldRange.mp (this hw))
+    let algRS : Algebra ℂ⟮t⟯ ↥S := (Subalgebra.inclusion hleS).toRingHom.toAlgebra
+    have : IsScalarTower ℂ⟮t⟯ ↥S K := IsScalarTower.of_algebraMap_eq fun _ => rfl
+    have : Module.Finite ↥S K := Module.Finite.of_restrictScalars_finite ℂ⟮t⟯ _ _
+    have : Algebra.IsIntegral ↥S K := Algebra.IsIntegral.of_finite _ _
+    have hS : (algebraMap ↥S K).IsIntegral := fun x => Algebra.IsIntegral.isIntegral (R := ↥S) x
+    let e : ↥E ≃ₐ[ℂ] ↥S := AlgEquiv.ofInjective ψ ψ.toRingHom.injective
+    have he : ψ.toRingHom = (algebraMap ↥S K).comp e.toAlgHom.toRingHom := by
+      refine RingHom.ext fun x => ?_
+      change ψ x = ((e x : ↥S) : K)
+      rw [AlgEquiv.ofInjective_apply]
+    rw [he]
+    exact RingHom.IsIntegral.trans _ _ (RingHom.isIntegral_of_surjective e.toAlgHom.toRingHom
+      e.surjective) hS
+  have hΦfixσ : ∀ γ ∈ Gamma1 M, ∀ u, σ γ (Φ u) = Φ u :=
+    fun γ hγ u => hΦfix γ hγ (hst γ⁻¹) (σ γ) (hσ γ) u
+  have hfixer : ∀ η : SL(2, ℤ), (∀ e : ↥E, σ η (e : K) = (e : K)) →
+      η ∈ Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ)) := by
+    intro η hη
+    exact ModularCurve.LevelN.Descent.fixer_le M K t σ hker hfd hgal hdeg ι Φ E'
+      hE'j hE'Φ y hy hΦy' hΦfixσ η (fun u => hη ⟨Φ u, hΦmem u⟩)
+  have keyEQ := ModularCurve.NoEllAux.keyEQ M hM t E (ΦE y) σ hvaly hfd hgal
+    hker hfix hdeg hint hfixer
+  have h0E : P'.ord (ΦE y) = P.ord y := by rw [← hP'ord y]; rfl
+  have h1728E : P'.ord (ΦE y - 1728) = P.ord (y - 1728) :=
+    by rw [← hP'ord (y - 1728), map_sub, map_ofNat]; rfl
+  refine ⟨fun hpos => ?_, fun hpos => ?_⟩
+  · have hk := keyEQ 0 W0 (ModularGroup.S * ModularGroup.T) UpperHalfPlane.ρ ST_smul_ρ
+      (by rw [map_zero, sub_zero, hW0]; norm_num) hD0 P'
+    simp only [map_zero, sub_zero] at hk
+    rw [h0E, hW0] at hk
+    exact hk hpos
+  · have hk := keyEQ 1728 W1728 ModularGroup.S UpperHalfPlane.I S_smul_I
+      (by rw [map_ofNat, hW1728]; norm_num) hD1728 P'
+    simp only [map_ofNat] at hk
+    rw [h1728E, hW1728] at hk
+    exact hk hpos
+
+theorem solution
+    (M : ℕ) [NeZero M] (hM : 4 ≤ M)
+    (y : ↥(laurentBaseChange ℚ̄ (qExpFunctionFieldC ℚ (Gamma1 M))))
+    (hy : (y : LaurentSeries ℚ̄) = ModularCurve.jqModC ℚ̄)
+    (P : Place ℚ̄
+      ↥(laurentBaseChange ℚ̄ (qExpFunctionFieldC ℚ (Gamma1 M)))) :
+    (0 < P.ord y → P.ord y = 3) ∧ (0 < P.ord (y - 1728) → P.ord (y - 1728) = 2) :=
+  ModularCurve.NoEllAux.main M hM y hy P
+
+end
+
+end privateSection
+
+public section publicSection
+
+theorem
+  ModularCurve.ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1_algebraicClosure
+    (M : ℕ) [NeZero M] (hM : 4 ≤ M)
+    (y : ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))))
+    (hy : (y : LaurentSeries (AlgebraicClosure ℚ)) = ModularCurve.jqModC (AlgebraicClosure ℚ))
+    (P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+      ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+        (CongruenceSubgroup.Gamma1 M)))) :
+    (0 < P.ord y → P.ord y = 3) ∧ (0 < P.ord (y - 1728) → P.ord (y - 1728) = 2) :=
+  solution M hM y hy P
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_eq_zero_of_not_mem_of_realizeOf_tendsto.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_eq_zero_of_not_mem_of_realizeOf_tendsto.lean
new file mode 100644
index 0000000000..851a019245
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_eq_zero_of_not_mem_of_realizeOf_tendsto.lean
@@ -0,0 +1,322 @@
+/-
+Based on Prove2Me node ModularCurve.ord_eq_zero_of_not_mem_of_realizeOf_tendsto
+(0d0fa81e-bb59-560b-af21-532b63f8b233) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5e2cfe4c-cd74-5a42-a2b1-a52aff50f427
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ComplexPlaceDictionaryOf
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_eq_zero_of_not_mem_of_eval_monic_eq_zero_of_coeff_eq_aeval_inv_div
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_algHom_laurentBaseChange_apply_eq_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_algHom_laurentSeries_qExpansion
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_monic_eval_eq_zero_coeff_eq_aeval_inv_div_of_forall_valuation_le_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_monoidHom_algEquiv_fixedField_eq_adjoin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_isDomain_ring
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_valuation_apply_smul_le_one_of_tendsto_div_smul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC_of_T_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_tendsto_div_smul_of_eventuallyEq_realizeOf_of_tendsto
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Modular functions with nonzero cusp limits are units at cuspidal places
+
+Theorem statement: `ModularCurve.ord_eq_zero_of_not_mem_of_realizeOf_tendsto`
+(`0d0fa81e-bb59-560b-af21-532b63f8b233`), by Claude, 2026-09-05.
+
+Proof: submission `5e2cfe4c-cd74-5a42-a2b1-a52aff50f427`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma \le \mathrm{SL}_2(\mathbb{Z})$ be a subgroup of finite index containing $T =
+\begin{pmatrix}1&1\\0&1\end{pmatrix}$ and satisfying `CongruenceSubgroup.IsCongruenceSubgroup`, and
+let $F_0$ be an intermediate field of $\mathbb{Q} \subseteq \mathbb{Q}((q))$ equal to
+[`ModularCurve.qExpFunctionFieldC ℚ Γ`](def/ModularCurve_X1.html#L101), the subfield of
+$\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by the quotients
+$\mathrm{intSeriesC}\,p_f/\mathrm{intSeriesC}\,p_g$ attached to integral $q$-expansions $p_f, p_g$
+of modular forms $f, g$ of a common weight $k$ for $\Gamma$ (with $\mathrm{intSeriesC}\,p_g \ne 0$).
+Let $x$ lie in [`ModularCurve.laurentBaseChange ℂ F₀`](def/ModularCurve_LaurentCoeff.html#L103), the
+subfield of $\mathbb{C}((q))$ generated over $\mathbb{C}$ by the coefficientwise image of $F_0$. Let
+$F : \mathfrak{H} \to \mathbb{C}$ be such that for every $\tau \in \mathfrak{H}$ the functions $z
+\mapsto F(\mathrm{ofComplex}\,z)$ and $z \mapsto
+\mathrm{realizeOf}\,\Gamma\,x\,(\mathrm{ofComplex}\,z)$ agree on a punctured neighbourhood of $\tau$
+in $\mathbb{C}$, where $\mathrm{realizeOf}\,\Gamma\,x\,\tau$ is $g(\tau)/h(\tau)$ for a chosen pair
+of weight-$k$ modular forms $g,h$ for $\Gamma$ with $h(\tau) \ne 0$ and $x \cdot \widehat{h} =
+\widehat{g}$ on $q$-expansions (and $0$ if no such pair exists). Assume that for every $\sigma \in
+\mathrm{SL}_2(\mathbb{Z})$ there is $L \ne 0$ with $F(\sigma \cdot \tau) \to L$ as
+$\mathrm{Im}\,\tau \to \infty$. Let $v$ be a place of this field over $\mathbb{C}$, i.e. a valuation
+subring, not the whole field, containing the image of $\mathbb{C}$ and a principal ideal ring, and
+let $y$ be the element whose Laurent series is [`ModularCurve.jqModC
+ℂ`](def/ModularCurve_JqCoeff.html#L15), namely $q^{-1}$ times the image of the power series $E_4^3
+\cdot \eta^{-24}$-type numerator `jNum`, so that $y$ is the $q$-expansion of $j$. If $y \notin
+\mathcal{O}_v$, then $\mathrm{ord}_v(x) = 0$, where $\mathrm{ord}_v$ is minus the logarithm of the
+adic valuation attached to the height-one prime of $\mathcal{O}_v$.
+
+This is the statement that a modular function for $\Gamma$ whose associated function on
+$\mathfrak{H}$ has a finite nonzero limit at every cusp is a unit at every place of the
+$q$-expansion function field lying over $j = \infty$, no identification of such places with $\Gamma
+\backslash \mathbb{P}^1(\mathbb{Q})$ being required. It feeds the computation of divisors in the
+complex place dictionary, being used in the principality criterion via the Abel–Jacobi map and in
+the construction of field elements with prescribed orders.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ord_eq_zero_of_not_mem_of_realizeOf_tendsto.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ord_eq_zero_of_not_mem_of_realizeOf_tendsto
+
+noncomputable section
+
+open UpperHalfPlane Polynomial
+open scoped MatrixGroups Topology
+
+namespace ModularCurve
+p2m_export "ModularCurve" "realizeOf laurentBaseChange qExpand jGen qExpFunctionFieldC jqModC \
+  LevelN.ring LevelN.jGen exists_tendsto_div_smul_of_eventuallyEq_realizeOf_of_tendsto \
+  LevelN.exists_algHom_laurentBaseChange_apply_eq_qExpand \
+  LevelN.exists_monic_eval_eq_zero_coeff_eq_aeval_inv_div_of_forall_valuation_le_one \
+  LevelN.valuation_apply_smul_le_one_of_tendsto_div_smul LevelN.isDomain_ring \
+  exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC_of_T_mem \
+  LevelN.exists_algHom_laurentSeries_qExpansion \
+  LevelN.exists_monoidHom_algEquiv_fixedField_eq_adjoin"
+namespace CuspPlaceGlue
+p2m_open "ModularCurve"
+
+theorem exists_monic_pullback {F K : Type*} [Field F] [Field K] [Algebra ℂ F] [Algebra ℂ K]
+    (Ψ : F →ₐ[ℂ] K) (y : F) (z : F) (P : K[X]) (hP : P.Monic) (hz : P.eval (Ψ z) = 0)
+    (hPc : ∀ i, ∃ p q : ℂ[X], q.coeff 0 ≠ 0 ∧ P.coeff i = aeval (Ψ y)⁻¹ p / aeval (Ψ y)⁻¹ q) :
+    ∃ P₀ : F[X], P₀.Monic ∧ P₀.eval z = 0 ∧
+      ∀ i, ∃ p q : ℂ[X], q.coeff 0 ≠ 0 ∧ P₀.coeff i = aeval y⁻¹ p / aeval y⁻¹ q := by
+  classical
+  have hinj : Function.Injective Ψ := Ψ.toRingHom.injective
+  choose p q hq hPq using hPc
+  set c₀ : ℕ → F := fun i => aeval y⁻¹ (p i) / aeval y⁻¹ (q i) with hc₀
+  have hΨc : ∀ i, Ψ (c₀ i) = P.coeff i := by
+    intro i
+    rw [hPq i, hc₀]
+    simp only [map_div₀, ← Polynomial.aeval_algHom_apply, map_inv₀]
+  set P₀ : F[X] := ∑ i ∈ Finset.range (P.natDegree + 1), C (c₀ i) * X ^ i with hP₀
+  have hcoeff : ∀ i, P₀.coeff i = if i < P.natDegree + 1 then c₀ i else 0 := by
+    intro i
+    rw [hP₀, Polynomial.finsetSum_coeff]
+    simp only [Polynomial.coeff_C_mul_X_pow]
+    rw [Finset.sum_ite_eq (Finset.range (P.natDegree + 1)) i c₀]
+    simp only [Finset.mem_range]
+  have hmap : P₀.map (Ψ : F →+* K) = P := by
+    ext i
+    rw [Polynomial.coeff_map, hcoeff]
+    split_ifs with hi
+    · exact hΨc i
+    · rw [map_zero, eq_comm]
+      exact Polynomial.coeff_eq_zero_of_natDegree_lt (by omega)
+  refine ⟨P₀, ?_, ?_, ?_⟩
+  · exact Polynomial.monic_of_injective (Ψ : F →+* K).injective (by rw [hmap]; exact hP)
+  · apply (Ψ : F →+* K).injective
+    rw [map_zero, ← Polynomial.eval₂_hom, ← Polynomial.eval_map, hmap]
+    exact hz
+  · intro i
+    rw [hcoeff]
+    split_ifs
+    · exact ⟨p i, q i, hq i, rfl⟩
+    · exact ⟨0, 1, by simp, by simp⟩
+
+end ModularCurve.CuspPlaceGlue
+
+namespace ModularCurve
+p2m_export "ModularCurve" "realizeOf laurentBaseChange qExpand jGen qExpFunctionFieldC jqModC \
+  LevelN.ring LevelN.jGen exists_tendsto_div_smul_of_eventuallyEq_realizeOf_of_tendsto \
+  LevelN.exists_algHom_laurentBaseChange_apply_eq_qExpand \
+  LevelN.exists_monic_eval_eq_zero_coeff_eq_aeval_inv_div_of_forall_valuation_le_one \
+  LevelN.valuation_apply_smul_le_one_of_tendsto_div_smul LevelN.isDomain_ring \
+  exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC_of_T_mem \
+  LevelN.exists_algHom_laurentSeries_qExpansion \
+  LevelN.exists_monoidHom_algEquiv_fixedField_eq_adjoin"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.CuspPlaceGlue in
+theorem ModularCurve.CuspPlaceGlue.ord_eq_zero_aux
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    (M : ℕ) [NeZero M] (hΓM : CongruenceSubgroup.Gamma M ≤ Γ)
+    (K : Type*) [Field K] [Algebra ℂ K] [Algebra (ModularCurve.LevelN.ring M) K]
+    [IsScalarTower ℂ (ModularCurve.LevelN.ring M) K]
+    [IsFractionRing (ModularCurve.LevelN.ring M) K]
+    (x : ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ))
+    (F : ℍ → ℂ)
+    (hFx : ∀ τ : ℍ, (fun z : ℂ => F (ofComplex z)) =ᶠ[𝓝[≠] (τ : ℂ)]
+      fun z : ℂ => ModularCurve.realizeOf Γ (x : LaurentSeries ℂ) (ofComplex z))
+    (hcusp : ∀ σ : SL(2, ℤ), ∃ L : ℂ, L ≠ 0 ∧
+      Filter.Tendsto (fun τ : ℍ => F (σ • τ)) atImInfty (𝓝 L))
+    (v : AlgebraicCurve.Place ℂ (ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      Γ)))
+    (y : ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ))
+    (hy : (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ)
+    (hv : y ∉ v.toValuationSubring) :
+    v.ord x = 0 := by
+  classical
+  obtain ⟨hst, σ, hσ, hker, hfixed, htr, hfin, _, hgal⟩ :=
+    ModularCurve.LevelN.exists_monoidHom_algEquiv_fixedField_eq_adjoin M K
+  obtain ⟨E, hEj, hEq⟩ := ModularCurve.LevelN.exists_algHom_laurentSeries_qExpansion M K
+  have hEinj : Function.Injective E := E.toRingHom.injective
+  obtain ⟨Ψ, hΨ⟩ :=
+    ModularCurve.LevelN.exists_algHom_laurentBaseChange_apply_eq_qExpand M K σ hker hfixed
+    E hEj Γ hΓM hT
+  have hΨinj : Function.Injective Ψ := Ψ.toRingHom.injective
+  have hΨy : Ψ y = algebraMap (ModularCurve.LevelN.ring M) K (ModularCurve.LevelN.jGen M) := by
+    apply hEinj
+    rw [hΨ, hy, hEj]
+  obtain ⟨k, g, h, hh, hxgh⟩ :=
+    exists_modularForm_mul_qExpansion_eq_of_mem_laurentBaseChange_qExpFunctionFieldC_of_T_mem
+      Γ hT (x : LaurentSeries ℂ) x.2
+  have hlim : ∀ γ : SL(2, ℤ), ∃ L : ℂ, L ≠ 0 ∧
+      Filter.Tendsto (fun τ : ℍ => (g : ℍ → ℂ) (γ • τ) / (h : ℍ → ℂ) (γ • τ)) atImInfty (𝓝 L) :=
+    ModularCurve.exists_tendsto_div_smul_of_eventuallyEq_realizeOf_of_tendsto Γ hT g h hh (x :
+      LaurentSeries ℂ)
+      hxgh F hFx hcusp
+  set z : K := Ψ x with hzdef
+  set qg : LaurentSeries ℂ := ModularCurve.qExpand ℂ M
+    ((UpperHalfPlane.qExpansion 1 (g : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) with hqg
+  set qh : LaurentSeries ℂ := ModularCurve.qExpand ℂ M
+    ((UpperHalfPlane.qExpansion 1 (h : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) with hqh
+  have hz : E z * qh = qg := by
+    rw [hzdef, hΨ, hqh, hqg, ← map_mul, hxgh]
+  have hEz : E z ≠ 0 := by
+    intro h0
+    have hqg0 : qg = 0 := by rw [← hz, h0, zero_mul]
+    have hg0 : (UpperHalfPlane.qExpansion 1 (g : ℍ → ℂ) : PowerSeries ℂ) = 0 := by
+      apply HahnSeries.ofPowerSeries_injective (Γ := ℤ) (R := ℂ)
+      apply (ModularCurve.qExpand ℂ M).injective
+      rw [map_zero, map_zero]; exact hqg0
+    have h1 : (1 : ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+      rw [Subgroup.strictPeriods_eq_zmultiples_one_of_T_mem hT]
+      exact AddSubgroup.mem_zmultiples _
+    have hg : g = 0 := (ModularForm.qExpansion_eq_zero_iff one_pos h1 g).mp hg0
+    obtain ⟨L, hL, hL'⟩ := hlim 1
+    have : Filter.Tendsto (fun τ : ℍ => (g : ℍ → ℂ) ((1 : SL(2, ℤ)) • τ) / (h : ℍ → ℂ) ((1 : SL(2,
+      ℤ)) • τ))
+        atImInfty (𝓝 0) := by
+      simp only [hg, FunLike.coe_zero, Pi.zero_apply, zero_div]
+      exact tendsto_const_nhds
+    exact hL (tendsto_nhds_unique hL' this)
+  have hz' : E z⁻¹ * qg = qh := by
+    rw [map_inv₀, ← hz, inv_mul_cancel_left₀ hEz]
+  have hpole : ∀ γ : SL(2, ℤ), Valued.v (E (σ γ z)) ≤ 1 := by
+    intro γ
+    obtain ⟨L, hL, hlimγ⟩ := hlim γ⁻¹
+    exact ModularCurve.LevelN.valuation_apply_smul_le_one_of_tendsto_div_smul M K hst σ hσ E hEq
+      Γ hT g h z hz γ L hL hlimγ
+  have hg : g ≠ 0 := by
+    intro hg0
+    apply hEz
+    have hqg0 : qg = 0 := by
+      rw [hqg, hg0]
+      have : UpperHalfPlane.qExpansion 1 ((0 : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) : ℍ → ℂ)
+        = 0 :=
+        by
+        have h1 : (1 : ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+          rw [Subgroup.strictPeriods_eq_zmultiples_one_of_T_mem hT]
+          exact AddSubgroup.mem_zmultiples _
+        exact (ModularForm.qExpansion_eq_zero_iff one_pos h1 _).mpr rfl
+      rw [this, map_zero, map_zero]
+    have hzz := hz
+    rw [hqg0] at hzz
+    have hqh0 : qh ≠ 0 := by
+      intro hqh0
+      have hh0 : (UpperHalfPlane.qExpansion 1 (h : ℍ → ℂ) : PowerSeries ℂ) = 0 := by
+        apply HahnSeries.ofPowerSeries_injective (Γ := ℤ) (R := ℂ)
+        apply (ModularCurve.qExpand ℂ M).injective
+        rw [map_zero, map_zero]; exact hqh0
+      have h1 : (1 : ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+        rw [Subgroup.strictPeriods_eq_zmultiples_one_of_T_mem hT]
+        exact AddSubgroup.mem_zmultiples _
+      exact hh ((ModularForm.qExpansion_eq_zero_iff one_pos h1 h).mp hh0)
+    exact (mul_eq_zero.mp hzz).resolve_right hqh0
+  have hpole' : ∀ γ : SL(2, ℤ), Valued.v (E (σ γ z⁻¹)) ≤ 1 := by
+    intro γ
+    obtain ⟨L, hL, hlimγ⟩ := hlim γ⁻¹
+    have hlim' : Filter.Tendsto (fun τ : ℍ => (h : ℍ → ℂ) (γ⁻¹ • τ) / (g : ℍ → ℂ) (γ⁻¹ • τ))
+        atImInfty (𝓝 L⁻¹) := by
+      have := hlimγ.inv₀ hL
+      simpa only [inv_div] using this
+    exact ModularCurve.LevelN.valuation_apply_smul_le_one_of_tendsto_div_smul M K hst σ hσ E hEq
+      Γ hT h g z⁻¹ hz' γ L⁻¹ (inv_ne_zero hL) hlim'
+  obtain ⟨P, hPm, hPz, hPc⟩ :=
+    ModularCurve.LevelN.exists_monic_eval_eq_zero_coeff_eq_aeval_inv_div_of_forall_valuation_le_one
+      M K σ hker hfixed E hEj z hpole
+  obtain ⟨Q, hQm, hQz, hQc⟩ :=
+    ModularCurve.LevelN.exists_monic_eval_eq_zero_coeff_eq_aeval_inv_div_of_forall_valuation_le_one
+      M K σ hker hfixed E hEj z⁻¹ hpole'
+  rw [← hΨy] at hPc hQc
+  obtain ⟨P₀, hP₀m, hP₀x, hP₀c⟩ :=
+    exists_monic_pullback Ψ y x P hPm (by rw [← hzdef]; exact hPz) hPc
+  obtain ⟨Q₀, hQ₀m, hQ₀x, hQ₀c⟩ :=
+    exists_monic_pullback Ψ y x⁻¹ Q hQm (by rw [map_inv₀, ← hzdef]; exact hQz) hQc
+  exact AlgebraicCurve.Place.ord_eq_zero_of_not_mem_of_eval_monic_eq_zero_of_coeff_eq_aeval_inv_div
+    v hv hP₀m hQ₀m hP₀c hQ₀c hP₀x hQ₀x
+
+open ModularCurve.CuspPlaceGlue in
+theorem solution
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    (hΓ : CongruenceSubgroup.IsCongruenceSubgroup Γ)
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (hF : F₀ = ModularCurve.qExpFunctionFieldC ℚ Γ)
+    (x : ModularCurve.laurentBaseChange ℂ F₀)
+    (F : ℍ → ℂ)
+    (hFx : ∀ τ : ℍ, (fun z : ℂ => F (ofComplex z)) =ᶠ[𝓝[≠] (τ : ℂ)]
+      fun z : ℂ => ModularCurve.realizeOf Γ (x : LaurentSeries ℂ) (ofComplex z))
+    (hcusp : ∀ σ : SL(2, ℤ), ∃ L : ℂ, L ≠ 0 ∧
+      Filter.Tendsto (fun τ : ℍ => F (σ • τ)) atImInfty (𝓝 L))
+    (v : AlgebraicCurve.Place ℂ (ModularCurve.laurentBaseChange ℂ F₀))
+    (y : ModularCurve.laurentBaseChange ℂ F₀) (hy : (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ)
+    (hv : y ∉ v.toValuationSubring) :
+    v.ord x = 0 := by
+  subst hF
+  obtain ⟨M, hM0, hΓM⟩ := hΓ
+  have : NeZero M := ⟨hM0⟩
+  have : IsDomain (ModularCurve.LevelN.ring M) := ModularCurve.LevelN.isDomain_ring M
+  exact ModularCurve.CuspPlaceGlue.ord_eq_zero_aux Γ hT M hΓM (FractionRing
+    (ModularCurve.LevelN.ring M))
+    x F hFx hcusp v y hy hv
+
+end
+end S_ModularCurve_ord_eq_zero_of_not_mem_of_realizeOf_tendsto
+end P2MW
+export P2MW.S_ModularCurve_ord_eq_zero_of_not_mem_of_realizeOf_tendsto (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane
+open scoped MatrixGroups Topology
+theorem ModularCurve.ord_eq_zero_of_not_mem_of_realizeOf_tendsto
+    (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    (hΓ : CongruenceSubgroup.IsCongruenceSubgroup Γ)
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (hF : F₀ = ModularCurve.qExpFunctionFieldC ℚ Γ)
+    (x : ModularCurve.laurentBaseChange ℂ F₀)
+    (F : ℍ → ℂ)
+    (hFx : ∀ τ : ℍ, (fun z : ℂ => F (ofComplex z)) =ᶠ[𝓝[≠] (τ : ℂ)]
+      fun z : ℂ => ModularCurve.realizeOf Γ (x : LaurentSeries ℂ) (ofComplex z))
+    (hcusp : ∀ σ : SL(2, ℤ), ∃ L : ℂ, L ≠ 0 ∧
+      Filter.Tendsto (fun τ : ℍ => F (σ • τ)) atImInfty (𝓝 L))
+    (v : AlgebraicCurve.Place ℂ (ModularCurve.laurentBaseChange ℂ F₀))
+    (y : ModularCurve.laurentBaseChange ℂ F₀) (hy : (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ)
+    (hv : y ∉ v.toValuationSubring) :
+    v.ord x = 0 :=
+  solution Γ hT hΓ F₀ hF x F hFx hcusp v y hy hv
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_jBar_dvd_three.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_jBar_dvd_three.lean
new file mode 100644
index 0000000000..49d94dffb8
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_jBar_dvd_three.lean
@@ -0,0 +1,285 @@
+/-
+Based on Prove2Me node ModularCurve.ord_jBar_dvd_three
+(aa3e7f78-314c-53bc-8afa-207c725b4220) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1821b8e1-12e3-5fb3-ada8-796f439c5e95
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_MazurStepThreeInputs
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+
+import Mathlib.Algebra.CharP.Invertible
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_mem_puiseuxRamSubfield_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_modularPolynomialData
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_isUnit_discriminant_and_c4_cube_eq_mul_X_cube_powerSeries
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_hasRamBound_one_of_nsmul_eq_zero_of_isUnit_discriminant_powerSeries
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order of jmath̄ at a zero divides 3
+
+Theorem statement: `ModularCurve.ord_jBar_dvd_three` (`aa3e7f78-314c-53bc-8afa-207c725b4220`), by
+Claude, 2026-09-05.
+
+Proof: submission `1821b8e1-12e3-5fb3-ada8-796f439c5e95`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a positive natural number. Write $F_N \subseteq \mathbb{Q}((q))$ for the intermediate
+field [`ModularCurve.modularFunctionFieldFull N`](def/ModularCurve_X0.html#L305), the subfield of
+the field of Laurent series over $\mathbb{Q}$ generated over $\mathbb{Q}$ by the family
+`divisorExpansions N`, and let $\overline{F}_N =$ [`ModularCurve.modularFunctionFieldBar
+N`](def/ModularCurve_ArithmeticGalois.html#L111) be the intermediate field of
+$\overline{\mathbb{Q}}((q))$ over $\overline{\mathbb{Q}}$ generated by the image of $F_N$ under the
+coefficientwise ring homomorphism $\mathbb{Q}((q)) \to \overline{\mathbb{Q}}((q))$ induced by
+$\mathbb{Q} \hookrightarrow \overline{\mathbb{Q}} =$ `AlgebraicClosure ℚ`. Let $v$ be a place of
+$\overline{F}_N$ over $\overline{\mathbb{Q}}$ in the sense of the project's
+[`AlgebraicCurve.Place`](def/AlgebraicCurve_DivisorClassGroup.html#L22), that is, a valuation
+subring of $\overline{F}_N$ which contains the image of $\overline{\mathbb{Q}}$, is not all of
+$\overline{F}_N$, and is a principal ideal ring; for $f \in \overline{F}_N$ the integer
+$v.\mathrm{ord}(f)$ is minus the logarithm of the value of $f$ under the adic valuation attached to
+the height-one prime of that ring. Let $\bar\jmath =$ [`ModularCurve.jBar
+N`](def/ModularCurve_MazurStepThreeInputs.html#L43) be the element of $\overline{F}_N$ given by the
+coefficientwise image of the $q$-expansion `jq` of the modular invariant. The assertion is: if
+$v.\mathrm{ord}(\bar\jmath) > 0$, then $v.\mathrm{ord}(\bar\jmath)$ divides $3$.
+
+This is the statement that the covering $X_0(N) \to X(1)$, realised here through the inclusion of
+function fields over $\overline{\mathbb{Q}}$, has ramification index dividing $3$ at every place
+lying above the zero of the modular invariant, i.e. above the elliptic point $j = 0$ of order $3$;
+no parity or other restriction on the level $N$ is imposed. It feeds the Riemann–Roch and genus
+computations for $X_0(N)$, being cited in the construction of divisors attached to elements of the
+Riemann–Roch space, in the integrality statements for regular differentials, and in the
+identification of the genus of $\overline{F}_N$ with the classical genus formula.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ord_jBar_dvd_three.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ord_jBar_dvd_three
+
+
+open HahnSeries Polynomial WeierstrassCurve
+
+local notation "ℚ̄" => AlgebraicClosure ℚ
+local notation "𝕂" => HahnSeries ℚ (AlgebraicClosure ℚ)
+
+noncomputable section
+
+namespace OrdJBarDvdThree
+
+variable {K : Type*} [Field K]
+
+def hahnExpMul (n : ℕ) (hn : 0 < n) : HahnSeries ℚ K →+* HahnSeries ℚ K :=
+  HahnSeries.embDomainRingHom (AddMonoidHom.mulRight (n : ℚ))
+    (mul_left_injective₀ (Nat.cast_ne_zero.mpr hn.ne'))
+    (fun _ _ => mul_le_mul_iff_of_pos_right (Nat.cast_pos.mpr hn))
+
+@[scoped simp] theorem hahnExpMul_single (n : ℕ) (hn : 0 < n) (q : ℚ) (c : K) :
+    hahnExpMul n hn (HahnSeries.single q c) = HahnSeries.single (q * n) c := by
+  unfold hahnExpMul
+  rw [embDomainRingHom_apply, embDomain_single]
+  rfl
+
+@[scoped simp] theorem hahnExpMul_coeff_mul (n : ℕ) (hn : 0 < n) (r : HahnSeries ℚ K) (q : ℚ) :
+    (hahnExpMul n hn r).coeff (q * n) = r.coeff q :=
+  HahnSeries.embDomain_coeff
+
+theorem hasRamBound_one_hahnExpMul_iff (n : ℕ) (hn : 0 < n) (r : HahnSeries ℚ K) :
+    HasRamBound 1 (hahnExpMul n hn r) ↔ HasRamBound n r := by
+  have hnQ : (n : ℚ) ≠ 0 := Nat.cast_ne_zero.mpr hn.ne'
+  constructor
+  · intro h q hq
+    have hnq : q * n ∈ (hahnExpMul n hn r).support := by
+      rw [HahnSeries.mem_support, hahnExpMul_coeff_mul]; exact hq
+    obtain ⟨k, hk⟩ := h hnq
+    refine ⟨k, ?_⟩
+    simp only [Nat.cast_one, div_one] at hk
+    field_simp
+    linarith
+  · intro h q hq
+    obtain ⟨p, rfl⟩ : ∃ p : ℚ, p * n = q := ⟨q / n, div_mul_cancel₀ q hnQ⟩
+    have hp : p ∈ r.support := by
+      rw [HahnSeries.mem_support, ← hahnExpMul_coeff_mul n hn]; exact hq
+    obtain ⟨k, hk⟩ := h hp
+    refine ⟨k, ?_⟩
+    simp only [Nat.cast_one, div_one]
+    field_simp at hk
+    linarith [hk]
+
+abbrev spec (Φ : Polynomial (Polynomial ℤ)) (j₀ : HahnSeries ℚ K) : Polynomial (HahnSeries ℚ K) :=
+  Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ K)) j₀)
+
+theorem hahnExpMul_comp_eval (n : ℕ) (hn : 0 < n) (j₀ : HahnSeries ℚ K) :
+    (hahnExpMul n hn).comp (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ K)) j₀)
+      = Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ K)) (hahnExpMul n hn j₀) := by
+  refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+  simp [Polynomial.eval₂RingHom]
+
+theorem spec_hahnExpMul (n : ℕ) (hn : 0 < n) (Φ : Polynomial (Polynomial ℤ))
+    (j₀ : HahnSeries ℚ K) :
+    spec Φ (hahnExpMul n hn j₀) = (spec Φ j₀).map (hahnExpMul n hn) := by
+  rw [spec, spec, Polynomial.map_map, hahnExpMul_comp_eval]
+
+theorem hasRamBound_one_ofPowerSeries (p : PowerSeries K) :
+    HasRamBound 1 (HahnSeries.ofPowerSeries ℚ K p) := by
+  intro q hq
+  have hq' : q ∈ Set.range ((↑) : ℕ → ℚ) := by
+    by_contra h
+    rw [HahnSeries.mem_support, HahnSeries.ofPowerSeries_apply] at hq
+    exact hq (HahnSeries.embDomain_of_notMem_range (by simpa using h))
+  obtain ⟨m, rfl⟩ := hq'
+  exact ⟨(m : ℤ), by push_cast; ring⟩
+
+theorem algebraMap_eq_C (a : K) : algebraMap K (HahnSeries ℚ K) a = HahnSeries.C a := by
+  have h1 : algebraMap K (PowerSeries K) a = PowerSeries.C a := by simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+
+theorem transcendental_single_one : Transcendental K (HahnSeries.single (1 : ℚ) (1 : K)) := by
+  rw [transcendental_iff_injective]
+  have heq : (Polynomial.aeval (R := K) (HahnSeries.single (1:ℚ) (1:K))).toRingHom
+      = (HahnSeries.ofPowerSeries ℚ K).comp (Polynomial.coeToPowerSeries.ringHom (R := K)) := by
+    refine Polynomial.ringHom_ext (fun a => ?_) ?_
+    · change Polynomial.aeval (R := K) (HahnSeries.single (1:ℚ) (1:K)) (Polynomial.C a) = _
+      rw [Polynomial.aeval_C, algebraMap_eq_C,
+        RingHom.coe_comp, Function.comp_apply, Polynomial.coeToPowerSeries.ringHom_apply,
+        Polynomial.coe_C, HahnSeries.ofPowerSeries_C]
+    · change Polynomial.aeval (R := K) (HahnSeries.single (1:ℚ) (1:K)) Polynomial.X = _
+      rw [Polynomial.aeval_X, RingHom.coe_comp, Function.comp_apply,
+        Polynomial.coeToPowerSeries.ringHom_apply, Polynomial.coe_X, HahnSeries.ofPowerSeries_X]
+  intro p q hpq
+  have hpq' : (HahnSeries.ofPowerSeries ℚ K) (p : PowerSeries K)
+      = (HahnSeries.ofPowerSeries ℚ K) (q : PowerSeries K) := by
+    have hp := congrFun (congrArg DFunLike.coe heq) p
+    have hq := congrFun (congrArg DFunLike.coe heq) q
+    simp only [AlgHom.toRingHom_eq_coe, RingHom.coe_coe, RingHom.coe_comp,
+      Function.comp_apply, Polynomial.coeToPowerSeries.ringHom_apply] at hp hq
+    rw [← hp, ← hq]; exact hpq
+  exact Polynomial.coe_injective K (HahnSeries.ofPowerSeries_injective hpq')
+
+theorem transcendental_rat_of_qbar (x : 𝕂) (h : Transcendental ℚ̄ x) : Transcendental ℚ x := by
+  rintro ⟨p, hp0, hpx⟩
+  refine h ⟨p.map (algebraMap ℚ ℚ̄),
+    (Polynomial.map_ne_zero_iff (algebraMap ℚ ℚ̄).injective).mpr hp0, ?_⟩
+  rw [Polynomial.aeval_def, Polynomial.eval₂_map,
+    Subsingleton.elim ((algebraMap ℚ̄ 𝕂).comp (algebraMap ℚ ℚ̄)) (algebraMap ℚ 𝕂),
+    ← Polynomial.aeval_def]
+  exact hpx
+
+theorem transcendental_single_three :
+    Transcendental ℚ (HahnSeries.single (3 : ℚ) (1 : ℚ̄) : 𝕂) := by
+  refine transcendental_rat_of_qbar _ (fun halg => ?_)
+  refine transcendental_single_one (K := ℚ̄) (IsAlgebraic.of_pow (n := 3) (by norm_num) ?_)
+  rw [HahnSeries.single_pow, one_pow]
+  have h3 : (3 : ℕ) • (1 : ℚ) = 3 := by norm_num
+  rwa [h3]
+
+theorem j_eq_single_three_one (𝓔 : WeierstrassCurve (PowerSeries K)) (hΔ : IsUnit 𝓔.Δ)
+    (hc4 : 𝓔.c₄ ^ 3 = 𝓔.Δ * PowerSeries.X ^ 3) :
+    haveI : 𝓔.IsElliptic := ⟨hΔ⟩
+    (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).j = HahnSeries.single (3 : ℚ) (1 : K) := by
+  have : 𝓔.IsElliptic := ⟨hΔ⟩
+  have hWΔ : IsUnit (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).Δ := by
+    rw [WeierstrassCurve.map_Δ]; exact hΔ.map _
+  have hΔj : (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).Δ *
+      (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).j
+      = (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).c₄ ^ 3 := by
+    rw [WeierstrassCurve.j, ← WeierstrassCurve.coe_Δ', ← mul_assoc, ← Units.val_mul,
+      mul_inv_cancel, Units.val_one, one_mul]
+  have hc4' : (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).c₄ ^ 3
+      = (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).Δ * HahnSeries.single (3 : ℚ) (1 : K) := by
+    rw [WeierstrassCurve.map_c₄, ← map_pow, hc4, map_mul, map_pow, HahnSeries.ofPowerSeries_X,
+      HahnSeries.single_pow, one_pow, WeierstrassCurve.map_Δ]
+    congr 2
+    simp [nsmul_eq_mul]
+  exact hWΔ.mul_left_cancel (hΔj.trans hc4')
+
+theorem hasRamBound_three_of_isRoot_at_zero
+    {N : ℕ} [NeZero N] (data : ModularCurve.ModularPolynomialData N)
+    (r : 𝕂)
+    (hroot : (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom 𝕂)
+      (HahnSeries.single (1 : ℚ) (1 : ℚ̄)))).IsRoot r) :
+    HahnSeries.HasRamBound 3 r := by
+  classical
+  obtain ⟨𝓔, hΔ, hc⟩ :=
+    WeierstrassCurve.exists_isUnit_discriminant_and_c4_cube_eq_mul_X_cube_powerSeries
+      ℚ̄ two_ne_zero three_ne_zero
+  have h𝓔E : 𝓔.IsElliptic := ⟨hΔ⟩
+  have hjW : (𝓔.map (HahnSeries.ofPowerSeries ℚ ℚ̄)).j = HahnSeries.single (3 : ℚ) (1 : ℚ̄) :=
+    j_eq_single_three_one 𝓔 hΔ hc
+  have ht : Transcendental ℚ (𝓔.map (HahnSeries.ofPowerSeries ℚ ℚ̄)).j := by
+    rw [hjW]; exact transcendental_single_three
+  have hτj : hahnExpMul 3 (by norm_num) (HahnSeries.single (1 : ℚ) (1 : ℚ̄))
+      = (𝓔.map (HahnSeries.ofPowerSeries ℚ ℚ̄)).j := by
+    rw [hahnExpMul_single, one_mul, hjW]
+    norm_num
+  have hτroot : (spec data.Φ (𝓔.map (HahnSeries.ofPowerSeries ℚ ℚ̄)).j).IsRoot
+      (hahnExpMul 3 (by norm_num) r) := by
+    rw [← hτj, spec_hahnExpMul]
+    change Polynomial.eval _ _ = 0
+    rw [Polynomial.eval_map, Polynomial.eval₂_hom,
+      show Polynomial.eval r (spec data.Φ _) = 0 from hroot, map_zero]
+  have hmemL : ∀ y : 𝕂, y ∈ HahnSeries.puiseuxRamSubfield ℚ̄ Nat.one_pos ↔ HasRamBound 1 y :=
+    fun y => HahnSeries.mem_puiseuxRamSubfield_iff Nat.one_pos
+  have hτrL : hahnExpMul 3 (by norm_num) r ∈ HahnSeries.puiseuxRamSubfield ℚ̄ Nat.one_pos := by
+    refine ModularCurve.ModularPolynomialData.mem_of_isRoot_map_j_of_transcendental data
+      (𝓔.map (HahnSeries.ofPowerSeries ℚ ℚ̄)) ht (HahnSeries.puiseuxRamSubfield ℚ̄ Nat.one_pos)
+      ?_ ?_ ?_ ?_ ?_ ?_ _ hτroot
+    · rw [WeierstrassCurve.map_a₁, hmemL]; exact hasRamBound_one_ofPowerSeries _
+    · rw [WeierstrassCurve.map_a₂, hmemL]; exact hasRamBound_one_ofPowerSeries _
+    · rw [WeierstrassCurve.map_a₃, hmemL]; exact hasRamBound_one_ofPowerSeries _
+    · rw [WeierstrassCurve.map_a₄, hmemL]; exact hasRamBound_one_ofPowerSeries _
+    · rw [WeierstrassCurve.map_a₆, hmemL]; exact hasRamBound_one_ofPowerSeries _
+    · intro x y hns hd
+      have h := WeierstrassCurve.hasRamBound_one_of_nsmul_eq_zero_of_isUnit_discriminant_powerSeries
+        𝓔 hΔ (Nat.pos_of_ne_zero (NeZero.ne N)) x y hns hd
+      exact ⟨(hmemL x).mpr h.1, (hmemL y).mpr h.2⟩
+  exact (hasRamBound_one_hahnExpMul_iff 3 (by norm_num) r).mp ((hmemL _).mp hτrL)
+
+end OrdJBarDvdThree
+end
+
+open ModularCurve AlgebraicCurve
+
+theorem solution (N : ℕ) [NeZero N]
+    (v : AlgebraicCurve.Place (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar N))
+    (hpos : 0 < v.ord (ModularCurve.jBar N)) :
+    v.ord (ModularCurve.jBar N) ∣ 3 := by
+  obtain ⟨data⟩ := ModularCurve.nonempty_modularPolynomialData N
+  exact ModularCurve.ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound N data
+    (fun r hr => OrdJBarDvdThree.hasRamBound_three_of_isRoot_at_zero data r hr) v hpos
+
+end S_ModularCurve_ord_jBar_dvd_three
+end P2MW
+export P2MW.S_ModularCurve_ord_jBar_dvd_three (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.ord_jBar_dvd_three (N : ℕ) [NeZero N]
+    (v : AlgebraicCurve.Place (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar N))
+    (hpos : 0 < v.ord (ModularCurve.jBar N)) :
+    v.ord (ModularCurve.jBar N) ∣ 3 :=
+  solution N v hpos
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound.lean
new file mode 100644
index 0000000000..ece62e4736
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound.lean
@@ -0,0 +1,429 @@
+/-
+Based on Prove2Me node ModularCurve.ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound
+(dad57c49-c8dc-5825-8dbc-8d3f730c3378) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission bc8c131f-e3f0-5881-a2f4-af2e3d95c365
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlace
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_RamificationBound
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_dvd_of_forall_hahnSeries_embedding_hasRamBound
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_HasRamBound_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_hasRamBound_C
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_hasRamBound_single_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_mem_puiseuxRamSubfield_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_hasRamBound_three_of_isRoot_at_zero_of_odd
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_hasRamBound_two_of_isRoot_at_1728_of_odd
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_adjoin_jBar_jNBar_eq_top
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_full
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isRoot_map_Phi_apply_jBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_modularPolynomialData
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order of jmath̄ at its zeros divides three, under a branch bound
+
+Theorem statement: `ModularCurve.ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound`
+(`dad57c49-c8dc-5825-8dbc-8d3f730c3378`), by Claude, 2026-09-05.
+
+Proof: submission `bc8c131f-e3f0-5881-a2f4-af2e3d95c365`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and let `data` be a modular polynomial datum of level $N$: a
+polynomial $\Phi \in \mathbb{Z}[x][y]$ which is monic in $y$, of degree in $y$ equal to $\sum_{d
+\mid N,\ d \text{ squarefree}} N/d$, and which satisfies $\Phi(\jmath(q), \jmath(q^N)) = 0$, where
+$\jmath(q) = q^{-1}\cdot(1 + \cdots)$ is the Laurent series `jq` over $\mathbb{Q}$ and the
+substitution of $\jmath(q)$ into integer polynomials is `evalAtJ`. Assume the hypothesis `htrio`:
+for every Hahn series $r$ with rational exponents and coefficients in $\overline{\mathbb{Q}}$ which
+is a root of the one-variable polynomial obtained from $\Phi$ by casting integer coefficients into
+$\mathrm{HahnSeries}\,\mathbb{Q}\,\overline{\mathbb{Q}}$ and evaluating the first variable at the
+monomial $q$ (the Hahn series `single 1 1`), the support of $r$ is contained in $\{k/3 : k \in
+\mathbb{Z}\}$. Let $F$ be the $\overline{\mathbb{Q}}$-subfield of
+$\mathrm{LaurentSeries}\,\overline{\mathbb{Q}}$ generated by the coefficientwise images of the
+$\mathbb{Q}$-subfield of $\mathrm{LaurentSeries}\,\mathbb{Q}$ generated by the expansions
+$\jmath(q^d)$ for the nonzero divisors $d$ of $N$, and let $v$ be a place of $F$ over
+$\overline{\mathbb{Q}}$, that is, a valuation subring of $F$ containing $\overline{\mathbb{Q}}$,
+distinct from $F$ and a principal ideal ring. Write $\bar\jmath \in F$ for the image of $\jmath(q)$
+under the coefficient embedding. If $v.\mathrm{ord}(\bar\jmath) > 0$, then
+$v.\mathrm{ord}(\bar\jmath)$ divides $3$ in $\mathbb{Z}$, where $\mathrm{ord}$ is minus the
+logarithm of the associated adic valuation.
+
+This is the local shape of the covering of the $j$-line by the level $N$ modular curve above the
+elliptic point of order three: the positivity hypothesis selects the places at which $\bar\jmath$
+vanishes, and the assumed denominator bound on the Newton–Puiseux branches of $\Phi(q,y) = 0$ bounds
+the ramification indices there. It is the conditional form of
+[`ModularCurve.ord_jBar_dvd_three`](thm.html#ModularCurve.ord_jBar_dvd_three), which cites it.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound
+
+noncomputable section
+
+open HahnSeries Polynomial
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand jq ModularPolynomialData FunctionFieldGeneration \
+  modularFunctionFieldFull jqd_mem_full coeffEmb laurentBaseChange coeffEmb_mem_laurentBaseChange \
+  jq_mem_full transcendental_coeffEmb_jq finiteDimensional_adjoin_coeffEmb_jq_full \
+  isRoot_map_Phi_apply_jBar adjoin_jBar_jNBar_eq_top nonempty_modularPolynomialData"
+p2m_open "ModularCurve"
+
+private lemma algebraMap_hahnSeries_eq_C (a : AlgebraicClosure ℚ) :
+    algebraMap (AlgebraicClosure ℚ) (HahnSeries ℚ (AlgebraicClosure ℚ)) a = HahnSeries.C a := by
+  rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_eq, HahnSeries.ofPowerSeries_C]
+
+private lemma forall_hasRamBound_of_embedding (N : ℕ) [NeZero N]
+    (data : ModularPolynomialData N) (s : HahnSeries ℚ (AlgebraicClosure ℚ)) {d : ℕ} (hd : 0 < d)
+    (hs : HasRamBound d s)
+    (htrio : ∀ r : HahnSeries ℚ (AlgebraicClosure ℚ),
+      (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ)))
+        s)).IsRoot r → HasRamBound d r)
+    (ψ : ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) →ₐ[AlgebraicClosure
+      ℚ]
+      HahnSeries ℚ (AlgebraicClosure ℚ))
+    (hψj : ψ (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+      coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+        laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) = s)
+    (x : ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N))) :
+    HasRamBound d (ψ x) := by
+  classical
+  have halg : ∀ a : AlgebraicClosure ℚ,
+      algebraMap (AlgebraicClosure ℚ)
+        ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) a ∈
+        (puiseuxRamSubfield (AlgebraicClosure ℚ) hd).comap
+          (ψ : ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) →+*
+            HahnSeries ℚ (AlgebraicClosure ℚ)) := by
+    intro a
+    rw [Subfield.mem_comap]
+    change ψ (algebraMap _ _ a) ∈ _
+    rw [AlgHom.commutes, algebraMap_hahnSeries_eq_C]
+    exact (mem_puiseuxRamSubfield_iff hd).mpr (HahnSeries.hasRamBound_C a)
+  have hmemS : ∀ z : ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)),
+      z ∈ ((puiseuxRamSubfield (AlgebraicClosure ℚ) hd).comap
+          (ψ : ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) →+*
+            HahnSeries ℚ (AlgebraicClosure ℚ))).toIntermediateField halg ↔
+        HasRamBound d (ψ z) := by
+    intro z
+    constructor
+    · intro h
+      exact (mem_puiseuxRamSubfield_iff hd).mp (Subfield.mem_comap.mp h)
+    · intro h
+      exact Subfield.mem_comap.mpr ((mem_puiseuxRamSubfield_iff hd).mpr h)
+  have htop : IntermediateField.adjoin (AlgebraicClosure ℚ)
+      ({⟨coeffEmb (AlgebraicClosure ℚ) jq,
+          coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩,
+        ⟨coeffEmb (AlgebraicClosure ℚ) (qExpand ℚ N jq),
+          coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jqd_mem_full N (dvd_refl N))⟩} :
+        Set ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N))) ≤
+      ((puiseuxRamSubfield (AlgebraicClosure ℚ) hd).comap
+        (ψ : ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) →+*
+          HahnSeries ℚ (AlgebraicClosure ℚ))).toIntermediateField halg := by
+    rw [IntermediateField.adjoin_le_iff]
+    rintro z (rfl | rfl)
+    · rw [SetLike.mem_coe, hmemS, hψj]
+      exact hs
+    · rw [SetLike.mem_coe, hmemS]
+      refine htrio _ ?_
+      have h2 := isRoot_map_Phi_apply_jBar (AlgebraicClosure ℚ) N data
+        (HahnSeries ℚ (AlgebraicClosure ℚ)) ψ
+      rwa [hψj] at h2
+  rw [adjoin_jBar_jNBar_eq_top (AlgebraicClosure ℚ) N] at htop
+  exact (hmemS x).mp (htop IntermediateField.mem_top)
+
+end ModularCurve
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand jq ModularPolynomialData FunctionFieldGeneration \
+  modularFunctionFieldFull jqd_mem_full coeffEmb laurentBaseChange coeffEmb_mem_laurentBaseChange \
+  jq_mem_full transcendental_coeffEmb_jq finiteDimensional_adjoin_coeffEmb_jq_full \
+  isRoot_map_Phi_apply_jBar adjoin_jBar_jNBar_eq_top nonempty_modularPolynomialData"
+p2m_open "ModularCurve"
+
+set_option synthInstance.maxHeartbeats 1600000 in
+private theorem engine_generic (N : ℕ) [NeZero N] (data : ModularPolynomialData N)
+    (j₀ : AlgebraicClosure ℚ) {d : ℕ} (hd : 0 < d)
+    (htrio : ∀ r : HahnSeries ℚ (AlgebraicClosure ℚ),
+      (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ)))
+        (HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)))).IsRoot r →
+      HahnSeries.HasRamBound d r)
+    (v : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+      ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)))
+    (hv : 0 < v.ord ((⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+          laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) -
+        algebraMap (AlgebraicClosure ℚ) _ j₀)) :
+    v.ord ((⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+          laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) -
+        algebraMap (AlgebraicClosure ℚ) _ j₀) ∣ (d : ℤ) := by
+  classical
+  have htr := transcendental_coeffEmb_jq (AlgebraicClosure ℚ) N
+  have hinj : Function.Injective (Polynomial.aeval
+      (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+        laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) :
+      Polynomial (AlgebraicClosure ℚ) →ₐ[AlgebraicClosure ℚ] _) := by
+    rw [injective_iff_map_eq_zero]
+    intro p hp
+    exact transcendental_iff.mp htr p hp
+  set lift := RatFunc.liftAlgHom
+    (Polynomial.aeval (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+      coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+      laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)))
+    (nonZeroDivisors_le_comap_nonZeroDivisors_of_injective _ hinj) with hlift
+  have hlift_alg : ∀ p : Polynomial (AlgebraicClosure ℚ),
+      lift.toRingHom (algebraMap _ _ p) = Polynomial.aeval
+        (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+          coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+          laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) p := by
+    intro p
+    have h := RatFunc.liftAlgHom_apply_div' (φ := Polynomial.aeval _)
+      (hφ := nonZeroDivisors_le_comap_nonZeroDivisors_of_injective _ hinj) p 1
+    simpa using h
+  let : Algebra (RatFunc (AlgebraicClosure ℚ))
+      ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) :=
+    lift.toRingHom.toAlgebra
+  have halgmap : algebraMap (RatFunc (AlgebraicClosure ℚ))
+      ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) =
+      lift.toRingHom := rfl
+  have : IsScalarTower (AlgebraicClosure ℚ) (RatFunc (AlgebraicClosure ℚ))
+      ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) :=
+    IsScalarTower.of_algebraMap_eq' (lift.comp_algebraMap).symm
+  have hFD : FiniteDimensional (RatFunc (AlgebraicClosure ℚ))
+      ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) := by
+    have hfin := finiteDimensional_adjoin_coeffEmb_jq_full (AlgebraicClosure ℚ) N
+    obtain ⟨s, hs⟩ := Module.finite_def.mp hfin
+    refine ⟨⟨s, ?_⟩⟩
+    rw [eq_top_iff]
+    rintro z -
+    have hz : z ∈ Submodule.span
+        ↥(IntermediateField.adjoin (AlgebraicClosure ℚ)
+          ({⟨coeffEmb (AlgebraicClosure ℚ) jq,
+            coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩} :
+            Set ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)))) s := by
+      rw [hs]; trivial
+    induction hz using Submodule.span_induction with
+    | mem y hy => exact Submodule.subset_span hy
+    | zero => exact Submodule.zero_mem _
+    | add a b _ _ ha hb => exact Submodule.add_mem _ ha hb
+    | smul c y _ hy =>
+      have hc : (c : ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N))) ∈
+          lift.fieldRange := by
+        have hrange : IntermediateField.adjoin (AlgebraicClosure ℚ)
+            ({⟨coeffEmb (AlgebraicClosure ℚ) jq,
+              coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩} :
+              Set ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N))) ≤
+            lift.fieldRange := by
+          rw [IntermediateField.adjoin_le_iff]
+          rintro y' rfl
+          refine ⟨algebraMap (Polynomial (AlgebraicClosure ℚ))
+            (RatFunc (AlgebraicClosure ℚ)) Polynomial.X, ?_⟩
+          rw [hlift_alg, Polynomial.aeval_X]
+        exact hrange c.2
+      obtain ⟨c', hc'⟩ := hc
+      have hcc : c • y = c' • y := by
+        change (c : ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N))) * y =
+          lift.toRingHom c' * y
+        rw [hc']
+      rw [hcc]
+      exact Submodule.smul_mem _ c' hy
+  have hp : Irreducible (Polynomial.X - Polynomial.C j₀) := Polynomial.irreducible_X_sub_C j₀
+  have hroot : Polynomial.aeval j₀ (Polynomial.X - Polynomial.C j₀) = 0 := by simp
+  have hder : Polynomial.aeval j₀ (Polynomial.derivative
+      (Polynomial.X - Polynomial.C j₀)) ≠ 0 := by simp
+  have helt : algebraMap (RatFunc (AlgebraicClosure ℚ))
+      ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N))
+      (algebraMap (Polynomial (AlgebraicClosure ℚ)) (RatFunc (AlgebraicClosure ℚ))
+        (Polynomial.X - Polynomial.C j₀)) =
+      (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+        laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) -
+      algebraMap (AlgebraicClosure ℚ) _ j₀ := by
+    rw [halgmap, hlift_alg, map_sub, Polynomial.aeval_X, Polynomial.aeval_C]
+  have hX : algebraMap (RatFunc (AlgebraicClosure ℚ))
+      ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N))
+      (algebraMap (Polynomial (AlgebraicClosure ℚ)) (RatFunc (AlgebraicClosure ℚ))
+        Polynomial.X) =
+      (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+        laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) := by
+    rw [halgmap, hlift_alg, Polynomial.aeval_X]
+  have hA1 := AlgebraicCurve.Place.ord_dvd_of_forall_hahnSeries_embedding_hasRamBound
+    (K := AlgebraicClosure ℚ) (L := AlgebraicClosure ℚ)
+    (F := ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)))
+    (Polynomial.X - Polynomial.C j₀) hp j₀ hroot hder hd
+    (fun ψ hψ x => by
+      rw [hX] at hψ
+      exact forall_hasRamBound_of_embedding N data
+        (HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)) hd
+        (HahnSeries.HasRamBound.add (HahnSeries.hasRamBound_C j₀)
+          (HahnSeries.hasRamBound_single_one hd 1))
+        htrio ψ hψ x)
+    v (by rwa [helt])
+  rwa [helt] at hA1
+
+private theorem ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound (N : ℕ) [NeZero N]
+    (data : ModularPolynomialData N)
+    (htrio : ∀ r : HahnSeries ℚ (AlgebraicClosure ℚ),
+      (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ)))
+        (HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)))).IsRoot r →
+      HahnSeries.HasRamBound 3 r)
+    (v : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+      ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)))
+    (hv : 0 < v.ord (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+          laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N))) :
+    v.ord (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+          laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) ∣ (3 : ℤ) := by
+  have h0 := engine_generic N data 0 (d := 3) (by norm_num)
+    (fun r hr => htrio r (by rwa [map_zero, zero_add] at hr))
+    v (by simpa using hv)
+  simpa using h0
+
+private theorem ord_jBar_sub_1728_dvd_two_of_pos_of_forall_isRoot_hasRamBound (N : ℕ) [NeZero N]
+    (data : ModularPolynomialData N)
+    (htrio : ∀ r : HahnSeries ℚ (AlgebraicClosure ℚ),
+      (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ)))
+        ((1728 : HahnSeries ℚ (AlgebraicClosure ℚ)) +
+          HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)))).IsRoot r →
+      HahnSeries.HasRamBound 2 r)
+    (v : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+      ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)))
+    (hv : 0 < v.ord ((⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+          laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) - 1728)) :
+    v.ord ((⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+          laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) - 1728) ∣ (2 : ℤ)
+            := by
+  have hC : HahnSeries.C (1728 : AlgebraicClosure ℚ) =
+      (1728 : HahnSeries ℚ (AlgebraicClosure ℚ)) := map_ofNat _ 1728
+  have halg : algebraMap (AlgebraicClosure ℚ)
+      ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) 1728 =
+      (1728 : ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N))) :=
+    map_ofNat _ 1728
+  have h0 := engine_generic N data 1728 (d := 2) (by norm_num)
+    (fun r hr => htrio r (by rwa [hC] at hr))
+    v (by rwa [halg])
+  rwa [halg] at h0
+
+theorem ord_jBar_dvd_three_of_pos_of_odd_of_data (N : ℕ) [NeZero N] (hN : Odd N)
+    (data : ModularPolynomialData N)
+    (v : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+      ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)))
+    (hv : 0 < v.ord (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+          laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N))) :
+    v.ord (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+          laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) ∣ (3 : ℤ) :=
+  ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound N data
+    (fun r hr => data.hasRamBound_three_of_isRoot_at_zero_of_odd hN r hr) v hv
+
+theorem ord_jBar_sub_1728_dvd_two_of_pos_of_odd_of_data (N : ℕ) [NeZero N] (hN : Odd N)
+    (data : ModularPolynomialData N)
+    (v : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+      ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)))
+    (hv : 0 < v.ord ((⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+          laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) - 1728)) :
+    v.ord ((⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+          laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) - 1728) ∣ (2 : ℤ) :=
+  ord_jBar_sub_1728_dvd_two_of_pos_of_forall_isRoot_hasRamBound N data
+    (fun r hr => data.hasRamBound_two_of_isRoot_at_1728_of_odd hN r hr) v hv
+
+private theorem ord_jBar_dvd_three_of_pos_of_odd (N : ℕ) [NeZero N] (hN : Odd N)
+    (v : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+      ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)))
+    (hv : 0 < v.ord (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+          laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N))) :
+    v.ord (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+          laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) ∣ (3 : ℤ) :=
+  (nonempty_modularPolynomialData N).elim fun data =>
+    ord_jBar_dvd_three_of_pos_of_odd_of_data N hN data v hv
+
+private theorem ord_jBar_sub_1728_dvd_two_of_pos_of_odd (N : ℕ) [NeZero N] (hN : Odd N)
+    (v : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+      ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)))
+    (hv : 0 < v.ord ((⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+          laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) - 1728)) :
+    v.ord ((⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+          laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) - 1728) ∣ (2 : ℤ) :=
+  (nonempty_modularPolynomialData N).elim fun data =>
+    ord_jBar_sub_1728_dvd_two_of_pos_of_odd_of_data N hN data v hv
+
+end ModularCurve
+
+open HahnSeries Polynomial _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound.ModularCurve in
+theorem solution (N : ℕ) [NeZero N]
+    (data : ModularPolynomialData N)
+    (htrio : ∀ r : HahnSeries ℚ (AlgebraicClosure ℚ),
+      (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ)))
+        (HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)))).IsRoot r →
+      HahnSeries.HasRamBound 3 r)
+    (v : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+      ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)))
+    (hv : 0 < v.ord (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+          laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N))) :
+    v.ord (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+          laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) ∣ (3 : ℤ) :=
+  ModularCurve.ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound N data htrio v hv
+
+end
+end S_ModularCurve_ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound
+end P2MW
+export P2MW.S_ModularCurve_ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open HahnSeries Polynomial ModularCurve
+theorem ModularCurve.ord_jBar_dvd_three_of_pos_of_forall_isRoot_hasRamBound (N : ℕ) [NeZero N]
+    (data : ModularPolynomialData N)
+    (htrio : ∀ r : HahnSeries ℚ (AlgebraicClosure ℚ),
+      (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ)))
+        (HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)))).IsRoot r →
+      HahnSeries.HasRamBound 3 r)
+    (v : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+      ↥(laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)))
+    (hv : 0 < v.ord (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+          laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N))) :
+    v.ord (⟨coeffEmb (AlgebraicClosure ℚ) jq,
+        coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jq_mem_full N)⟩ :
+          laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull N)) ∣ (3 : ℤ) :=
+  solution N data htrio v hv
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_jBar_sub_1728_dvd_two.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_jBar_sub_1728_dvd_two.lean
new file mode 100644
index 0000000000..f65ae97404
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_jBar_sub_1728_dvd_two.lean
@@ -0,0 +1,512 @@
+/-
+Based on Prove2Me node ModularCurve.ord_jBar_sub_1728_dvd_two
+(ad7b8fd1-51b8-5a26-a7e1-ee7822d46f82) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e476b002-f8df-5a17-a9fe-04211252881b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_MazurStepThreeInputs
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+
+import Mathlib.Algebra.CharP.Invertible
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JLinePlacesBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_dvd_of_forall_hahnSeries_embedding_hasRamBound
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_mem_puiseuxRamSubfield_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_mem_of_isRoot_map_j_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_adjoin_jBar_jNBar_eq_top
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_adjoin_coeffEmb_jq_of_neZero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_modularPolynomialData
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_isUnit_discriminant_and_c6_sq_eq_mul_X_sq_powerSeries
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_hasRamBound_one_of_nsmul_eq_zero_of_isUnit_discriminant_powerSeries
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Ramification over j = 1728 divides 2 on X₀(N)
+
+Theorem statement: `ModularCurve.ord_jBar_sub_1728_dvd_two`
+(`ad7b8fd1-51b8-5a26-a7e1-ee7822d46f82`), by Claude, 2026-09-05.
+
+Proof: submission `e476b002-f8df-5a17-a9fe-04211252881b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a positive natural number, and work inside the field $\overline{\mathbb Q}F_N$ =
+[`ModularCurve.modularFunctionFieldBar N`](def/ModularCurve_ArithmeticGalois.html#L111), the
+intermediate field of the Laurent series field $\mathrm{LaurentSeries}(\overline{\mathbb Q})$ over
+$\overline{\mathbb Q} =$ `AlgebraicClosure ℚ` generated by the coefficientwise images, under the
+embedding `coeffEmb` induced by $\mathbb Q \to \overline{\mathbb Q}$, of the elements of
+[`ModularCurve.modularFunctionFieldFull N`](def/ModularCurve_X0.html#L305), itself the subfield of
+$\mathrm{LaurentSeries}(\mathbb Q)$ generated over $\mathbb Q$ by the divisor $q$-expansions
+`divisorExpansions N`. Let $v$ be a place of this field over $\overline{\mathbb Q}$ in the project's
+sense, i.e. a valuation subring of $\overline{\mathbb Q}F_N$ containing the image of
+$\overline{\mathbb Q}$, different from the whole field, and a principal ideal ring; for $f$ in the
+field, $v.\mathrm{ord}(f) \in \mathbb Z$ is minus the logarithm of the associated
+height-one-spectrum adic valuation of $f$. Let $\bar\jmath$ = [`ModularCurve.jBar
+N`](def/ModularCurve_MazurStepThreeInputs.html#L43) be the element of $\overline{\mathbb Q}F_N$
+given by the coefficientwise image of the $q$-expansion of the modular invariant $j$. Assuming
+$v.\mathrm{ord}(\bar\jmath - 1728) > 0$, the conclusion is that $v.\mathrm{ord}(\bar\jmath - 1728)$
+divides $2$ in $\mathbb Z$; equivalently, this order is $1$ or $2$.
+
+This is the local statement that the covering $X_0(N) \to X(1)$, read through the inclusion of
+function fields over $\overline{\mathbb Q}$, is at worst quadratically ramified above the elliptic
+point $j = 1728$, the point of order two for the modular group. It is one of the inputs to the
+ramification count entering the genus formula for $X_0(N)$ and to the description of Riemann–Roch
+spaces and regular differentials on the curve, being cited by
+[`ModularCurve.genus_modularFunctionFieldBar_eq_genusFormula`]
+(thm.html#ModularCurve.genus_modularFunctionFieldBar_eq_genusFormula)
+among others.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ord_jBar_sub_1728_dvd_two.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ord_jBar_sub_1728_dvd_two
+
+
+noncomputable section
+
+namespace OrdJBarSub1728
+namespace Wire
+
+open HahnSeries Polynomial WeierstrassCurve
+
+local notation "ℚ̄" => AlgebraicClosure ℚ
+local notation "𝕂" => HahnSeries ℚ (AlgebraicClosure ℚ)
+
+variable {K : Type*} [Field K]
+
+def hahnExpMul (n : ℕ) (hn : 0 < n) : HahnSeries ℚ K →+* HahnSeries ℚ K :=
+  HahnSeries.embDomainRingHom (AddMonoidHom.mulRight (n : ℚ))
+    (mul_left_injective₀ (Nat.cast_ne_zero.mpr hn.ne'))
+    (fun _ _ => mul_le_mul_iff_of_pos_right (Nat.cast_pos.mpr hn))
+
+@[scoped simp] theorem hahnExpMul_single (n : ℕ) (hn : 0 < n) (q : ℚ) (c : K) :
+    hahnExpMul n hn (HahnSeries.single q c) = HahnSeries.single (q * n) c := by
+  unfold hahnExpMul
+  rw [embDomainRingHom_apply, embDomain_single]
+  rfl
+
+@[scoped simp] theorem hahnExpMul_coeff_mul (n : ℕ) (hn : 0 < n) (r : HahnSeries ℚ K) (q : ℚ) :
+    (hahnExpMul n hn r).coeff (q * n) = r.coeff q :=
+  HahnSeries.embDomain_coeff
+
+theorem hasRamBound_one_hahnExpMul_iff (n : ℕ) (hn : 0 < n) (r : HahnSeries ℚ K) :
+    HasRamBound 1 (hahnExpMul n hn r) ↔ HasRamBound n r := by
+  have hnQ : (n : ℚ) ≠ 0 := Nat.cast_ne_zero.mpr hn.ne'
+  constructor
+  · intro h q hq
+    have hnq : q * n ∈ (hahnExpMul n hn r).support := by
+      rw [HahnSeries.mem_support, hahnExpMul_coeff_mul]; exact hq
+    obtain ⟨k, hk⟩ := h hnq
+    refine ⟨k, ?_⟩
+    simp only [Nat.cast_one, div_one] at hk
+    field_simp
+    linarith
+  · intro h q hq
+    obtain ⟨p, rfl⟩ : ∃ p : ℚ, p * n = q := ⟨q / n, div_mul_cancel₀ q hnQ⟩
+    have hp : p ∈ r.support := by
+      rw [HahnSeries.mem_support, ← hahnExpMul_coeff_mul n hn]; exact hq
+    obtain ⟨k, hk⟩ := h hp
+    refine ⟨k, ?_⟩
+    simp only [Nat.cast_one, div_one]
+    field_simp at hk
+    linarith [hk]
+
+abbrev spec (Φ : Polynomial (Polynomial ℤ)) (j₀ : HahnSeries ℚ K) : Polynomial (HahnSeries ℚ K) :=
+  Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ K)) j₀)
+
+theorem hahnExpMul_comp_eval (n : ℕ) (hn : 0 < n) (j₀ : HahnSeries ℚ K) :
+    (hahnExpMul n hn).comp (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ K)) j₀)
+      = Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ K)) (hahnExpMul n hn j₀) := by
+  refine Polynomial.ringHom_ext' (Subsingleton.elim _ _) ?_
+  simp [Polynomial.eval₂RingHom]
+
+theorem spec_hahnExpMul (n : ℕ) (hn : 0 < n) (Φ : Polynomial (Polynomial ℤ)) (j₀ : HahnSeries ℚ K) :
+    spec Φ (hahnExpMul n hn j₀) = (spec Φ j₀).map (hahnExpMul n hn) := by
+  rw [spec, spec, Polynomial.map_map, hahnExpMul_comp_eval]
+
+theorem hasRamBound_one_ofPowerSeries (p : PowerSeries K) :
+    HasRamBound 1 (HahnSeries.ofPowerSeries ℚ K p) := by
+  intro q hq
+  have hq' : q ∈ Set.range ((↑) : ℕ → ℚ) := by
+    by_contra h
+    rw [HahnSeries.mem_support, HahnSeries.ofPowerSeries_apply] at hq
+    exact hq (HahnSeries.embDomain_of_notMem_range (by simpa using h))
+  obtain ⟨m, rfl⟩ := hq'
+  exact ⟨(m : ℤ), by push_cast; ring⟩
+
+private theorem _root_.OrdJBarSub1728.Wire.algebraMap_eq_C (a : K) :
+    algebraMap K (HahnSeries ℚ K) a = HahnSeries.C a := by
+  have h1 : algebraMap K (PowerSeries K) a = PowerSeries.C a := by simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+
+p2m_export "OrdJBarSub1728.Wire" "algebraMap_eq_C"
+theorem transcendental_single_one : Transcendental K (HahnSeries.single (1 : ℚ) (1 : K)) := by
+  rw [transcendental_iff_injective]
+  have heq : (Polynomial.aeval (R := K) (HahnSeries.single (1:ℚ) (1:K))).toRingHom
+      = (HahnSeries.ofPowerSeries ℚ K).comp (Polynomial.coeToPowerSeries.ringHom (R := K)) := by
+    refine Polynomial.ringHom_ext (fun a => ?_) ?_
+    · change Polynomial.aeval (R := K) (HahnSeries.single (1:ℚ) (1:K)) (Polynomial.C a) = _
+      rw [Polynomial.aeval_C, algebraMap_eq_C,
+        RingHom.coe_comp, Function.comp_apply, Polynomial.coeToPowerSeries.ringHom_apply,
+        Polynomial.coe_C, HahnSeries.ofPowerSeries_C]
+    · change Polynomial.aeval (R := K) (HahnSeries.single (1:ℚ) (1:K)) Polynomial.X = _
+      rw [Polynomial.aeval_X, RingHom.coe_comp, Function.comp_apply,
+        Polynomial.coeToPowerSeries.ringHom_apply, Polynomial.coe_X, HahnSeries.ofPowerSeries_X]
+  intro p q hpq
+  have hpq' : (HahnSeries.ofPowerSeries ℚ K) (p : PowerSeries K)
+      = (HahnSeries.ofPowerSeries ℚ K) (q : PowerSeries K) := by
+    have hp := congrFun (congrArg DFunLike.coe heq) p
+    have hq := congrFun (congrArg DFunLike.coe heq) q
+    simp only [AlgHom.toRingHom_eq_coe, RingHom.coe_coe, RingHom.coe_comp,
+      Function.comp_apply, Polynomial.coeToPowerSeries.ringHom_apply] at hp hq
+    rw [← hp, ← hq]; exact hpq
+  exact Polynomial.coe_injective K (HahnSeries.ofPowerSeries_injective hpq')
+
+theorem transcendental_rat_of_qbar (x : 𝕂) (h : Transcendental ℚ̄ x) : Transcendental ℚ x := by
+  rintro ⟨p, hp0, hpx⟩
+  refine h ⟨p.map (algebraMap ℚ ℚ̄),
+    (Polynomial.map_ne_zero_iff (algebraMap ℚ ℚ̄).injective).mpr hp0, ?_⟩
+  rw [Polynomial.aeval_def, Polynomial.eval₂_map,
+    Subsingleton.elim ((algebraMap ℚ̄ 𝕂).comp (algebraMap ℚ ℚ̄)) (algebraMap ℚ 𝕂),
+    ← Polynomial.aeval_def]
+  exact hpx
+
+theorem transcendental_1728_add_single_two :
+    Transcendental ℚ ((1728 : 𝕂) + HahnSeries.single (2 : ℚ) (1 : ℚ̄)) := by
+  refine transcendental_rat_of_qbar _ (fun halg => ?_)
+  have h1728 : IsAlgebraic ℚ̄ ((1728 : ℕ) : 𝕂) := isAlgebraic_natCast 1728
+  rw [Nat.cast_ofNat] at h1728
+  have hsq : IsAlgebraic ℚ̄ (HahnSeries.single (2 : ℚ) (1 : ℚ̄) : 𝕂) := by
+    have := (IsIntegral.sub halg.isIntegral h1728.isIntegral).isAlgebraic
+    simpa using this
+  refine transcendental_single_one (K := ℚ̄) (IsAlgebraic.of_pow (n := 2) (by norm_num) ?_)
+  rw [HahnSeries.single_pow, one_pow]
+  have h2 : (2 : ℕ) • (1 : ℚ) = 2 := by norm_num
+  rwa [h2]
+
+theorem j_eq_1728_add_single_two_one (𝓔 : WeierstrassCurve (PowerSeries K)) (hΔ : IsUnit 𝓔.Δ)
+    (hc6 : 𝓔.c₆ ^ 2 = 𝓔.Δ * PowerSeries.X ^ 2) :
+    haveI : 𝓔.IsElliptic := ⟨hΔ⟩
+    (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).j
+      = (1728 : HahnSeries ℚ K) + HahnSeries.single (2 : ℚ) (1 : K) := by
+  have : 𝓔.IsElliptic := ⟨hΔ⟩
+  have hWΔ : IsUnit (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).Δ := by
+    rw [WeierstrassCurve.map_Δ]; exact hΔ.map _
+  have hΔj : (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).Δ *
+      (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).j
+      = (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).c₄ ^ 3 := by
+    rw [WeierstrassCurve.j, ← WeierstrassCurve.coe_Δ', ← mul_assoc, ← Units.val_mul,
+      mul_inv_cancel, Units.val_one, one_mul]
+  have hc4c6 : 𝓔.c₄ ^ 3 - 𝓔.c₆ ^ 2 = 1728 * 𝓔.Δ := by
+    simp only [WeierstrassCurve.c₄, WeierstrassCurve.c₆, WeierstrassCurve.Δ,
+      WeierstrassCurve.b₂, WeierstrassCurve.b₄, WeierstrassCurve.b₆, WeierstrassCurve.b₈]
+    ring
+  have hc4' : (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).c₄ ^ 3
+      = (𝓔.map (HahnSeries.ofPowerSeries ℚ K)).Δ
+        * ((1728 : HahnSeries ℚ K) + HahnSeries.single (2 : ℚ) (1 : K)) := by
+    have hc4'' : 𝓔.c₄ ^ 3 = 𝓔.Δ * (1728 + PowerSeries.X ^ 2) := by
+      have := hc4c6; linear_combination this + hc6
+    rw [WeierstrassCurve.map_c₄, ← map_pow, hc4'', map_mul, WeierstrassCurve.map_Δ,
+      map_add, map_ofNat, map_pow, HahnSeries.ofPowerSeries_X, HahnSeries.single_pow, one_pow]
+    congr 3
+    simp [nsmul_eq_mul]
+  exact hWΔ.mul_left_cancel (hΔj.trans hc4')
+
+theorem hasRamBound_two_of_isRoot_at_1728
+    {N : ℕ} [NeZero N] (data : ModularCurve.ModularPolynomialData N)
+    (r : HahnSeries ℚ (AlgebraicClosure ℚ))
+    (hroot : (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure
+      ℚ)))
+      ((1728 : HahnSeries ℚ (AlgebraicClosure ℚ)) + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure
+        ℚ)))).IsRoot r) :
+    HahnSeries.HasRamBound 2 r := by
+  classical
+  obtain ⟨𝓔, hΔ, hc⟩ :=
+    WeierstrassCurve.exists_isUnit_discriminant_and_c6_sq_eq_mul_X_sq_powerSeries
+      (AlgebraicClosure ℚ) two_ne_zero three_ne_zero
+  have h𝓔E : 𝓔.IsElliptic := ⟨hΔ⟩
+  have hjW : (𝓔.map (HahnSeries.ofPowerSeries ℚ ℚ̄)).j = (1728 : 𝕂) + HahnSeries.single (2 : ℚ) (1 :
+    ℚ̄) :=
+    j_eq_1728_add_single_two_one 𝓔 hΔ hc
+  have ht : Transcendental ℚ (𝓔.map (HahnSeries.ofPowerSeries ℚ ℚ̄)).j := by
+    rw [hjW]; exact transcendental_1728_add_single_two
+  have hτj : hahnExpMul 2 (by norm_num) ((1728 : 𝕂) + HahnSeries.single (1 : ℚ) (1 : ℚ̄))
+      = (𝓔.map (HahnSeries.ofPowerSeries ℚ ℚ̄)).j := by
+    rw [map_add, map_ofNat, hahnExpMul_single, one_mul, hjW]
+    norm_num
+  have hτroot : (spec data.Φ (𝓔.map (HahnSeries.ofPowerSeries ℚ ℚ̄)).j).IsRoot
+      (hahnExpMul 2 (by norm_num) r) := by
+    rw [← hτj, spec_hahnExpMul]
+    change Polynomial.eval _ _ = 0
+    rw [Polynomial.eval_map, Polynomial.eval₂_hom, show Polynomial.eval r (spec data.Φ _) = 0 from
+      hroot,
+      map_zero]
+  have hmemL : ∀ y : 𝕂, y ∈ HahnSeries.puiseuxRamSubfield ℚ̄ Nat.one_pos ↔ HasRamBound 1 y :=
+    fun y => HahnSeries.mem_puiseuxRamSubfield_iff Nat.one_pos
+  have hτrL : hahnExpMul 2 (by norm_num) r ∈ HahnSeries.puiseuxRamSubfield ℚ̄ Nat.one_pos := by
+    refine ModularCurve.ModularPolynomialData.mem_of_isRoot_map_j_of_transcendental data
+      (𝓔.map (HahnSeries.ofPowerSeries ℚ ℚ̄)) ht (HahnSeries.puiseuxRamSubfield ℚ̄ Nat.one_pos)
+      ?_ ?_ ?_ ?_ ?_ ?_ _ hτroot
+    · rw [WeierstrassCurve.map_a₁, hmemL]; exact hasRamBound_one_ofPowerSeries _
+    · rw [WeierstrassCurve.map_a₂, hmemL]; exact hasRamBound_one_ofPowerSeries _
+    · rw [WeierstrassCurve.map_a₃, hmemL]; exact hasRamBound_one_ofPowerSeries _
+    · rw [WeierstrassCurve.map_a₄, hmemL]; exact hasRamBound_one_ofPowerSeries _
+    · rw [WeierstrassCurve.map_a₆, hmemL]; exact hasRamBound_one_ofPowerSeries _
+    · intro x y hns hd
+      have h := WeierstrassCurve.hasRamBound_one_of_nsmul_eq_zero_of_isUnit_discriminant_powerSeries
+        𝓔 hΔ (Nat.pos_of_ne_zero (NeZero.ne N)) x y hns hd
+      exact ⟨(hmemL x).mpr h.1, (hmemL y).mpr h.2⟩
+  exact (hasRamBound_one_hahnExpMul_iff 2 (by norm_num) r).mp ((hmemL _).mp hτrL)
+
+end OrdJBarSub1728.Wire
+
+namespace OrdJBarSub1728
+
+open ModularCurve AlgebraicCurve IntermediateField Polynomial
+
+variable (N : ℕ) [NeZero N]
+
+abbrev jb : ↥(modularFunctionFieldBar N) :=
+  ⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+    (jq_mem_full N)⟩
+
+abbrev jNb : ↥(modularFunctionFieldBar N) :=
+  ⟨coeffEmb (AlgebraicClosure ℚ) (qExpand ℚ N jq),
+    coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jqd_mem_full N (dvd_refl N))⟩
+
+@[reducible] def algRF : Algebra (RatFunc (AlgebraicClosure ℚ)) ↥(modularFunctionFieldBar N) :=
+  ((algebraMap ↥(jLineBar N) ↥(modularFunctionFieldBar N)).comp (jLineBarRingEquiv
+    N).toRingHom).toAlgebra
+
+theorem isScalarTower_RF :
+    letI := algRF N
+    IsScalarTower (AlgebraicClosure ℚ) (RatFunc (AlgebraicClosure ℚ)) ↥(modularFunctionFieldBar N)
+      := by
+  let := algRF N
+  refine IsScalarTower.of_algebraMap_eq (fun a => ?_)
+  change algebraMap _ _ a = algebraMap ↥(jLineBar N) ↥(modularFunctionFieldBar N)
+    (jLineBarRingEquiv N (algebraMap _ _ a))
+  rw [jLineBarRingEquiv_algebraMap]
+  rfl
+
+theorem finite_RF :
+    letI := algRF N
+    FiniteDimensional (RatFunc (AlgebraicClosure ℚ)) ↥(modularFunctionFieldBar N) := by
+  let := algRF N
+  let algRE : Algebra (RatFunc (AlgebraicClosure ℚ)) ↥(jLineBar N) :=
+    (jLineBarRingEquiv N).toRingHom.toAlgebra
+  have : IsScalarTower (RatFunc (AlgebraicClosure ℚ)) ↥(jLineBar N) ↥(modularFunctionFieldBar N) :=
+    IsScalarTower.of_algebraMap_eq (fun _ => rfl)
+  have : Module.Finite (RatFunc (AlgebraicClosure ℚ)) ↥(jLineBar N) :=
+    Module.Finite.of_surjective (Algebra.linearMap (RatFunc (AlgebraicClosure ℚ)) ↥(jLineBar N))
+      (jLineBarRingEquiv N).surjective
+  have : FiniteDimensional ↥(jLineBar N) ↥(modularFunctionFieldBar N) :=
+    finiteDimensional_adjoin_coeffEmb_jq_of_neZero N
+  exact Module.Finite.trans ↥(jLineBar N) ↥(modularFunctionFieldBar N)
+
+theorem algebraMap_RF_X :
+    letI := algRF N
+    algebraMap (RatFunc (AlgebraicClosure ℚ)) ↥(modularFunctionFieldBar N)
+      (algebraMap (Polynomial (AlgebraicClosure ℚ)) (RatFunc (AlgebraicClosure ℚ)) Polynomial.X) =
+        jb N := by
+  let := algRF N
+  change ((jLineBarRingEquiv N (algebraMap (Polynomial (AlgebraicClosure ℚ)) (RatFunc
+    (AlgebraicClosure ℚ)) X)
+    : ↥(jLineBar N)) : ↥(modularFunctionFieldBar N)) = jb N
+  rw [RatFunc.algebraMap_X, jLineBarRingEquiv_X]
+
+theorem algebraMap_RF_C (c : AlgebraicClosure ℚ) :
+    letI := algRF N
+    algebraMap (RatFunc (AlgebraicClosure ℚ)) ↥(modularFunctionFieldBar N)
+      (algebraMap (Polynomial (AlgebraicClosure ℚ)) (RatFunc (AlgebraicClosure ℚ)) (Polynomial.C c))
+        = algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) c := by
+  let := algRF N
+  have := isScalarTower_RF N
+  rw [RatFunc.algebraMap_C, ← RatFunc.algebraMap_eq_C, ← IsScalarTower.algebraMap_apply]
+
+theorem algebraMap_RF_X_sub_C (c : AlgebraicClosure ℚ) :
+    letI := algRF N
+    algebraMap (RatFunc (AlgebraicClosure ℚ)) ↥(modularFunctionFieldBar N)
+      (algebraMap (Polynomial (AlgebraicClosure ℚ)) (RatFunc (AlgebraicClosure ℚ)) (X - C c))
+        = jb N - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) c := by
+  let := algRF N
+  rw [map_sub, map_sub, algebraMap_RF_X, algebraMap_RF_C]
+
+theorem eval₂_Phi_jb_jNb (data : ModularPolynomialData N) :
+    data.Φ.eval₂ (Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N)) (jb N))
+      (jNb N)
+      = 0 := by
+  apply Subtype.ext
+  have hval : ((modularFunctionFieldBar N).toSubfield.subtype).comp
+      (Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N)) (jb N))
+      = (coeffEmb (AlgebraicClosure ℚ)).comp evalAtJ := by
+    refine Polynomial.ringHom_ext (fun z => by simp) ?_
+    change ((Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N)) (jb N) X :
+        ↥(modularFunctionFieldBar N)) : LaurentSeries (AlgebraicClosure ℚ)) = coeffEmb
+          (AlgebraicClosure ℚ) (evalAtJ X)
+    rw [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X, evalAtJ_X]
+  have h0 := congrArg (coeffEmb (AlgebraicClosure ℚ)) data.eval_eq_zero
+  rw [map_zero, Polynomial.hom_eval₂, ← hval] at h0
+  rw [ZeroMemClass.coe_zero, ← h0]
+  change ((modularFunctionFieldBar N).toSubfield.subtype) _ = _
+  rw [Polynomial.hom_eval₂]
+  rfl
+
+theorem hasRamBound_C (a : AlgebraicClosure ℚ) :
+    HahnSeries.HasRamBound 1 (HahnSeries.C a : HahnSeries ℚ (AlgebraicClosure ℚ)) := by
+  intro g hg
+  have : g ∈ ({0} : Set ℚ) := HahnSeries.support_single_subset (a := (0 : ℚ)) (r := a) hg
+  rw [Set.mem_singleton_iff] at this
+  exact ⟨0, by simp [this]⟩
+
+theorem hasRamBound_C_add_single (a : AlgebraicClosure ℚ) :
+    HahnSeries.HasRamBound 1
+      (HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)) := by
+  intro g hg
+  rcases (HahnSeries.support_add_subset (x := HahnSeries.C a)
+      (y := HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ))) hg with h | h
+  · exact hasRamBound_C a h
+  · have : g ∈ ({1} : Set ℚ) :=
+      HahnSeries.support_single_subset (a := (1 : ℚ)) (r := (1 : AlgebraicClosure ℚ)) h
+    rw [Set.mem_singleton_iff] at this
+    exact ⟨1, by simp [this]⟩
+
+theorem hasRamBound_of_one' {e : ℕ} (he : 0 < e) {y : HahnSeries ℚ (AlgebraicClosure ℚ)}
+    (hy : HahnSeries.HasRamBound 1 y) : HahnSeries.HasRamBound e y := by
+  intro g hg
+  obtain ⟨k, hk⟩ := hy hg
+  refine ⟨k * e, ?_⟩
+  simp only [Nat.cast_one, div_one] at hk
+  have he' : (e : ℚ) ≠ 0 := Nat.cast_ne_zero.mpr he.ne'
+  rw [← hk]; push_cast; field_simp
+
+theorem forall_hasRamBound_of_roots (data : ModularPolynomialData N) (c : AlgebraicClosure ℚ)
+    {d : ℕ} (hd : 0 < d)
+    (hroots : ∀ r : HahnSeries ℚ (AlgebraicClosure ℚ),
+      (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ)))
+        (HahnSeries.C c + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)))).IsRoot r →
+          HahnSeries.HasRamBound d r)
+    (ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ] HahnSeries ℚ (AlgebraicClosure ℚ))
+    (hψ : ψ (jb N) = HahnSeries.C c + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)) :
+    ∀ z, HahnSeries.HasRamBound d (ψ z) := by
+  let S := HahnSeries.puiseuxRamSubfield (AlgebraicClosure ℚ) (e := d) hd
+  have hS : ∀ y, y ∈ S ↔ HahnSeries.HasRamBound d y :=
+    fun y => HahnSeries.mem_puiseuxRamSubfield_iff hd
+  let T : IntermediateField (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+    (S.comap ψ.toRingHom).toIntermediateField (fun a => by
+      change ψ (algebraMap (AlgebraicClosure ℚ) _ a) ∈ S
+      have hC : algebraMap (AlgebraicClosure ℚ) (HahnSeries ℚ (AlgebraicClosure ℚ)) a = HahnSeries.C
+        a :=
+        by
+        rw [HahnSeries.algebraMap_apply']; simp
+      rw [ψ.commutes, hS, hC]
+      exact hasRamBound_of_one' hd (hasRamBound_C a))
+  have hjb : jb N ∈ T := by
+    change ψ (jb N) ∈ S
+    rw [hψ, hS]
+    exact hasRamBound_of_one' hd (hasRamBound_C_add_single c)
+  have hjNb : jNb N ∈ T := by
+    change ψ (jNb N) ∈ S
+    rw [hS]
+    refine hroots _ ?_
+    rw [Polynomial.IsRoot, Polynomial.eval_map, ← hψ]
+    have hcomp : Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ))) (ψ
+      (jb N))
+        = (ψ.toRingHom).comp (Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N))
+          (jb N)) := by
+      refine Polynomial.ringHom_ext (fun z => by simp) ?_
+      simp
+    rw [hcomp]
+    have h := (Polynomial.hom_eval₂ data.Φ
+      (Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N)) (jb N)) ψ.toRingHom
+        (jNb N)).symm
+    rw [eval₂_Phi_jb_jNb N data, map_zero] at h
+    simpa using h
+  have htop := ModularCurve.adjoin_jBar_jNBar_eq_top (AlgebraicClosure ℚ) N
+  have hle : (⊤ : IntermediateField (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)) ≤ T := by
+    rw [← htop, IntermediateField.adjoin_le_iff]
+    intro z hz
+    rcases hz with rfl | rfl
+    · exact hjb
+    · exact hjNb
+  intro z
+  exact (hS _).mp (hle IntermediateField.mem_top)
+
+theorem ord_jb_sub_dvd (data : ModularPolynomialData N) (c : AlgebraicClosure ℚ) {d : ℕ}
+    (hd : 0 < d)
+    (hroots : ∀ r : HahnSeries ℚ (AlgebraicClosure ℚ),
+      (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ)))
+        (HahnSeries.C c + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)))).IsRoot r →
+          HahnSeries.HasRamBound d r)
+    (v : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N))
+    (hpos : 0 < v.ord (jb N - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) c)) :
+    v.ord (jb N - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) c) ∣ (d : ℤ) := by
+  let := algRF N
+  have := isScalarTower_RF N
+  have := finite_RF N
+  have key := AlgebraicCurve.Place.ord_dvd_of_forall_hahnSeries_embedding_hasRamBound
+    (K := AlgebraicClosure ℚ) (L := AlgebraicClosure ℚ) (F := ↥(modularFunctionFieldBar N))
+    (X - C c) (Polynomial.irreducible_X_sub_C c) c (by simp) (by simp) hd
+    (fun ψ hψ => forall_hasRamBound_of_roots N data c hd hroots ψ (by
+      rwa [algebraMap_RF_X] at hψ)) v
+    (by rwa [algebraMap_RF_X_sub_C])
+  rwa [algebraMap_RF_X_sub_C] at key
+
+theorem ord_jb_sub_1728_dvd_two
+    (v : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N))
+    (hpos : 0 < v.ord (jb N - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) 1728)) :
+    v.ord (jb N - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) 1728) ∣ 2 := by
+  obtain ⟨data⟩ := ModularCurve.nonempty_modularPolynomialData N
+  have h := ord_jb_sub_dvd N data 1728 (d := 2) two_pos (fun r hr => by
+    refine OrdJBarSub1728.Wire.hasRamBound_two_of_isRoot_at_1728 data r ?_
+    have : (HahnSeries.C (1728 : AlgebraicClosure ℚ) : HahnSeries ℚ (AlgebraicClosure ℚ)) = 1728 :=
+      map_ofNat _ 1728
+    rwa [this] at hr) v hpos
+  exact_mod_cast h
+
+end OrdJBarSub1728
+end
+
+theorem solution (N : ℕ) [NeZero N]
+    (v : AlgebraicCurve.Place (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar N))
+    (hpos : 0 < v.ord (ModularCurve.jBar N - algebraMap (AlgebraicClosure ℚ)
+      ↥(ModularCurve.modularFunctionFieldBar N) 1728)) :
+    v.ord (ModularCurve.jBar N - algebraMap (AlgebraicClosure ℚ)
+      ↥(ModularCurve.modularFunctionFieldBar N) 1728) ∣ 2 := by
+  exact OrdJBarSub1728.ord_jb_sub_1728_dvd_two N v hpos
+
+end S_ModularCurve_ord_jBar_sub_1728_dvd_two
+end P2MW
+export P2MW.S_ModularCurve_ord_jBar_sub_1728_dvd_two (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.ord_jBar_sub_1728_dvd_two (N : ℕ) [NeZero N]
+    (v : AlgebraicCurve.Place (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar N))
+    (hpos : 0 < v.ord (ModularCurve.jBar N - algebraMap (AlgebraicClosure ℚ)
+      ↥(ModularCurve.modularFunctionFieldBar N) 1728)) :
+    v.ord (ModularCurve.jBar N - algebraMap (AlgebraicClosure ℚ)
+      ↥(ModularCurve.modularFunctionFieldBar N) 1728) ∣ 2 :=
+  solution N v hpos
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_jBar_sub_eq_one_of_ne_zero_of_ne.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_jBar_sub_eq_one_of_ne_zero_of_ne.lean
new file mode 100644
index 0000000000..172b00f6b8
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_jBar_sub_eq_one_of_ne_zero_of_ne.lean
@@ -0,0 +1,138 @@
+/-
+Based on Prove2Me node ModularCurve.ord_jBar_sub_eq_one_of_ne_zero_of_ne
+(8450c858-176d-5738-8be9-66023ec86976) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 247cf59e-5a5f-59b6-a918-3f8435ea1ba5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_MazurStepThreeInputs
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_elliptic_cycSub_orbitMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finite_cycSub
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_sameOrbit_iff_eq_of_c4_ne_zero_of_c6_ne_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order one for jmath̄ - c when c ≠ 0, 1728
+
+Theorem statement: `ModularCurve.ord_jBar_sub_eq_one_of_ne_zero_of_ne`
+(`8450c858-176d-5738-8be9-66023ec86976`), by Claude, 2026-09-05.
+
+Proof: submission `247cf59e-5a5f-59b6-a918-3f8435ea1ba5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N \in \mathbb{N}$, nonzero. Let $\overline{F}_N$ denote [`ModularCurve.modularFunctionFieldBar
+N`](def/ModularCurve_ArithmeticGalois.html#L111), the intermediate field of $\overline{\mathbb{Q}}$
+inside the Laurent series field $\mathrm{LaurentSeries}(\overline{\mathbb{Q}})$ obtained by
+adjoining to $\overline{\mathbb{Q}}$ the image, under the coefficientwise ring map `coeffEmb`
+induced by $\mathbb{Q} \to \overline{\mathbb{Q}}$, of `modularFunctionFieldFull N` (the subfield of
+$\mathrm{LaurentSeries}(\mathbb{Q})$ generated over $\mathbb{Q}$ by the divisor expansions attached
+to level $N$). Let $v$ be a place of $\overline{F}_N$ over $\overline{\mathbb{Q}}$ in the sense of
+the project's `Place` structure: a valuation subring of $\overline{F}_N$ containing the image of
+$\overline{\mathbb{Q}}$, distinct from the whole field, and a principal ideal ring; its `ord` is
+minus the logarithm of the associated adic valuation, an integer. Let $c \in \overline{\mathbb{Q}}$
+with $c \neq 0$ and $c \neq 1728$, and let $\bar\jmath =$ `jBar N`, the element of $\overline{F}_N$
+given by the coefficientwise image of the $q$-expansion of the modular invariant. Assume
+$\mathrm{ord}_v(\bar\jmath - c) > 0$, where $c$ is viewed in $\overline{F}_N$ via the structure map.
+Then $\mathrm{ord}_v(\bar\jmath - c) = 1$.
+
+This is the statement that the $j$-map $X_0(N)_{\overline{\mathbb{Q}}} \to
+X(1)_{\overline{\mathbb{Q}}}$ is unramified over every finite $j$-value other than the two elliptic
+values $0$ and $1728$, phrased as a vanishing order of $\bar\jmath - c$ at a place. It is used in
+the genus computation for $\overline{F}_N$
+([`ModularCurve.genus_modularFunctionFieldBar_eq_genusFormula`]
+(thm.html#ModularCurve.genus_modularFunctionFieldBar_eq_genusFormula)),
+where the sum of local contributions to the differential $d\bar\jmath$ must be confined to the
+fibres over $0$, $1728$ and the cusp, and in the analysis of place specialisations and of regular
+differentials.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ord_jBar_sub_eq_one_of_ne_zero_of_ne.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ord_jBar_sub_eq_one_of_ne_zero_of_ne
+
+
+open ModularCurve AlgebraicCurve WeierstrassCurve
+
+theorem solution (N : ℕ) [NeZero N]
+    (v : AlgebraicCurve.Place (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar N))
+    (c : AlgebraicClosure ℚ) (hc0 : c ≠ 0) (hc1728 : c ≠ 1728)
+    (hpos : 0 < v.ord (ModularCurve.jBar N - algebraMap (AlgebraicClosure ℚ)
+      ↥(ModularCurve.modularFunctionFieldBar N) c)) :
+    v.ord (ModularCurve.jBar N - algebraMap (AlgebraicClosure ℚ)
+      ↥(ModularCurve.modularFunctionFieldBar N) c) = 1 := by
+  classical
+  obtain ⟨E₀, hE, hj, f, hfib, hord⟩ := ModularCurve.exists_elliptic_cycSub_orbitMap N c
+  let : E₀.IsElliptic := hE
+  have hΔ : E₀.Δ ≠ 0 := by rw [← E₀.coe_Δ']; exact E₀.Δ'.ne_zero
+  have hc4 : E₀.c₄ ≠ 0 := by
+    intro h; apply hc0
+    rw [← hj, WeierstrassCurve.j, h, zero_pow three_ne_zero, mul_zero]
+  have hc6 : E₀.c₆ ≠ 0 := by
+    intro h; apply hc1728; rw [← hj]
+    have hrel : (1728 : AlgebraicClosure ℚ) * E₀.Δ = E₀.c₄ ^ 3 - E₀.c₆ ^ 2 := by
+      simp only [WeierstrassCurve.c₄, WeierstrassCurve.c₆, WeierstrassCurve.Δ,
+        WeierstrassCurve.b₂, WeierstrassCurve.b₄, WeierstrassCurve.b₆, WeierstrassCurve.b₈]
+      ring
+    rw [h, zero_pow two_ne_zero, sub_zero] at hrel
+    rw [WeierstrassCurve.j, ← hrel, ← E₀.coe_Δ',
+        mul_comm (1728 : AlgebraicClosure ℚ), ← mul_assoc]
+    simp only [Units.val_inv_eq_inv_val, E₀.coe_Δ']
+    rw [inv_mul_cancel₀ hΔ, one_mul]
+  have hinj : Function.Injective f := by
+    intro H H' heq
+    have horb := (hfib H H').mp heq
+    have := (sameOrbit_iff_eq_of_c4_ne_zero_of_c6_ne_zero E₀ hc4 hc6 H.1 H'.1).mp horb
+    exact (Subtype.ext this.1).symm
+  have hordv := hord ⟨v, hpos⟩
+  have : Finite (CycSub E₀ N) := ModularCurve.finite_cycSub N E₀
+  have : Fintype {H : CycSub E₀ N // f H = ⟨v, hpos⟩} := Fintype.ofFinite _
+  have hsub : Subsingleton {H : CycSub E₀ N // f H = ⟨v, hpos⟩} :=
+    ⟨fun ⟨H, hH⟩ ⟨H', hH'⟩ => Subtype.ext (hinj (hH.trans hH'.symm))⟩
+  have hle : Nat.card {H : CycSub E₀ N // f H = ⟨v, hpos⟩} ≤ 1 := by
+    rw [Nat.card_eq_fintype_card]
+    exact Fintype.card_le_one_iff_subsingleton.mpr hsub
+  have htn : (v.ord (jBar N - algebraMap (AlgebraicClosure ℚ)
+      ↥(modularFunctionFieldBar N) c)).toNat ≤ 1 := hordv ▸ hle
+  omega
+
+end S_ModularCurve_ord_jBar_sub_eq_one_of_ne_zero_of_ne
+end P2MW
+export P2MW.S_ModularCurve_ord_jBar_sub_eq_one_of_ne_zero_of_ne (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.ord_jBar_sub_eq_one_of_ne_zero_of_ne (N : ℕ) [NeZero N]
+    (v : AlgebraicCurve.Place (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar N))
+    (c : AlgebraicClosure ℚ) (hc0 : c ≠ 0) (hc1728 : c ≠ 1728)
+    (hpos : 0 < v.ord (ModularCurve.jBar N - algebraMap (AlgebraicClosure ℚ)
+      ↥(ModularCurve.modularFunctionFieldBar N) c)) :
+    v.ord (ModularCurve.jBar N - algebraMap (AlgebraicClosure ℚ)
+      ↥(ModularCurve.modularFunctionFieldBar N) c) = 1 :=
+  solution N v c hc0 hc1728 hpos
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_jLinePlace1728_jGen_sub.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_jLinePlace1728_jGen_sub.lean
new file mode 100644
index 0000000000..57286139cb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_jLinePlace1728_jGen_sub.lean
@@ -0,0 +1,133 @@
+/-
+Based on Prove2Me node ModularCurve.ord_jLinePlace1728_jGen_sub
+(072344ea-db1b-58f9-8f2e-461269728261) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 63891d12-67e2-592c-b503-7d0520ead616
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JLinePlaces
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_X_sub_C
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# ord of j-1728 at the place j=1728 is 1
+
+Theorem statement: `ModularCurve.ord_jLinePlace1728_jGen_sub`
+(`072344ea-db1b-58f9-8f2e-461269728261`), by Claude, 2026-09-05.
+
+Proof: submission `63891d12-67e2-592c-b503-7d0520ead616`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Work in the simple extension $\mathbb{Q}\langle j_q\rangle$ of $\mathbb{Q}$ generated by the
+transcendental element [`ModularCurve.jq`](def/ModularCurve_X0.html#L157), a field which is
+therefore a rational function field in one variable over $\mathbb{Q}$;
+[`ModularCurve.jGen`](def/ModularCurve_X0.html#L268) denotes the generator $j_q$ regarded as an
+element of this field. The place
+[`ModularCurve.jLinePlace1728`](def/ModularCurve_JLinePlaces.html#L50) is the place of
+$\mathbb{Q}\langle j_q\rangle$ over $\mathbb{Q}$ — that is, a valuation subring containing
+$\mathbb{Q}$, distinct from the whole field and a principal ideal ring — obtained by transporting,
+along the ring isomorphism [`ModularCurve.jLineRingEquiv : RatFunc ℚ ≃+*
+ℚ⟮jq⟯`](def/ModularCurve_JLinePlaces.html#L36) which carries the variable to $j_q$ and fixes
+$\mathbb{Q}$, the finite place of $\mathbb{Q}(T)$ attached to the irreducible polynomial $T - 1728$.
+For a place $v$ and an element $f$, $v.\mathrm{ord}(f)$ is minus the logarithm of the value of $f$
+under the adic valuation of the height-one prime of the valuation subring of $v$. The assertion is
+that the order of $j_q - 1728$ at this place equals $1$: the function $j - 1728$ has a simple zero
+at the point $j = 1728$ of the $j$-line.
+
+This records one of the standard local normalisations on the $j$-line: $j-1728$ is a uniformiser at
+the point $j=1728$, the point below which the covering $X_0(N)\to X(1)$ has its ramification of
+order dividing $2$. It is used in
+[`ModularCurve.ramificationIndex_eq_ord_sub_of_restrict_eq_jLinePlace1728`]
+(thm.html#ModularCurve.ramificationIndex_eq_ord_sub_of_restrict_eq_jLinePlace1728),
+where ramification indices above $j=1728$ are computed as orders of $j-1728$ at places of the larger
+function field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ord_jLinePlace1728_jGen_sub.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ord_jLinePlace1728_jGen_sub
+
+open IntermediateField AlgebraicCurve AlgebraicCurve.RationalFunctionField
+
+attribute [local instance 2000] RatFunc.instAlgebraOfPolynomial
+attribute [local instance] ModularCurve.instDecidableEqRatFuncRat
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jLineRingEquiv jLineRingEquiv_X instDecidableEqRatFuncRat \
+  jLinePlace1728 jq jGen"
+namespace JLineOrdAux
+p2m_open "ModularCurve"
+
+theorem equiv_X_sub_C (b : ℚ) :
+    ModularCurve.jLineRingEquiv (algebraMap (Polynomial ℚ) (RatFunc ℚ) (Polynomial.X - Polynomial.C
+      b))
+      = ModularCurve.jGen - algebraMap ℚ ↥ℚ⟮ModularCurve.jq⟯ b := by
+  rw [map_sub, RatFunc.algebraMap_X, map_sub, ModularCurve.jLineRingEquiv_X, RatFunc.algebraMap_C]
+  congr 1
+  exact RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom b
+
+theorem exists_eq_congr (v : Place ℚ ↥ℚ⟮ModularCurve.jq⟯) :
+    ∃ v' : Place ℚ (RatFunc ℚ), v = Place.congrRingEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom) v' :=
+  ⟨(Place.congrEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom)).symm v,
+    ((Place.congrEquiv _ _).apply_symm_apply v).symm⟩
+
+theorem ord_congr_jGen_sub (b : ℚ) (v' : Place ℚ (RatFunc ℚ)) :
+    (Place.congrRingEquiv ModularCurve.jLineRingEquiv
+        (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom) v').ord
+      (ModularCurve.jGen - algebraMap ℚ ↥ℚ⟮ModularCurve.jq⟯ b)
+    = (Finsupp.single (placeOfPoint ℚ b) (1 : ℤ) + Finsupp.single (placeInfty ℚ) (-1 : ℤ)) v' := by
+  rw [← equiv_X_sub_C, Place.ord_congrRingEquiv]
+  exact ord_X_sub_C ℚ b v'
+
+theorem injective_congr : Function.Injective (Place.congrRingEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom) : Place ℚ (RatFunc ℚ) → _)
+        :=
+  (Place.congrEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom)).injective
+
+end ModularCurve.JLineOrdAux
+
+open ModularCurve.JLineOrdAux
+
+theorem solution : ModularCurve.jLinePlace1728.ord (ModularCurve.jGen - 1728) = 1 := by
+  have h := ord_congr_jGen_sub 1728 (placeOfPoint ℚ 1728)
+  rw [show algebraMap ℚ ↥ℚ⟮ModularCurve.jq⟯ 1728 = 1728 from map_ofNat _ 1728] at h
+  have h01 := placeOfPoint_ne_placeInfty ℚ 1728
+  unfold ModularCurve.jLinePlace1728
+  rw [h]
+  simp [h01]
+
+end S_ModularCurve_ord_jLinePlace1728_jGen_sub
+end P2MW
+export P2MW.S_ModularCurve_ord_jLinePlace1728_jGen_sub (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open IntermediateField AlgebraicCurve
+theorem ModularCurve.ord_jLinePlace1728_jGen_sub :
+    ModularCurve.jLinePlace1728.ord (ModularCurve.jGen - 1728) = 1 :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_jLinePlaceZero_jGen.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_jLinePlaceZero_jGen.lean
new file mode 100644
index 0000000000..6de3a3654f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_jLinePlaceZero_jGen.lean
@@ -0,0 +1,134 @@
+/-
+Based on Prove2Me node ModularCurve.ord_jLinePlaceZero_jGen
+(c5bdae23-0985-575a-b6e5-8d6aa05af46a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission fbf818ba-15bc-5b9a-a4e6-d195725c76f8
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JLinePlaces
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_X_sub_C
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# j is a uniformiser at the place j=0
+
+Theorem statement: `ModularCurve.ord_jLinePlaceZero_jGen` (`c5bdae23-0985-575a-b6e5-8d6aa05af46a`),
+by Claude, 2026-09-05.
+
+Proof: submission `fbf818ba-15bc-5b9a-a4e6-d195725c76f8`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Here $\mathbb{Q}\langle j\rangle = \mathbb{Q}\!\left(\mathrm{jq}\right)$ denotes the simple
+extension of $\mathbb{Q}$ generated inside the relevant Laurent/power series field by the
+$q$-expansion $\mathrm{jq}$ of the modular $j$-invariant, and
+[`ModularCurve.jGen`](def/ModularCurve_X0.html#L268) is that generator viewed as an element of
+$\mathbb{Q}\langle j\rangle$. A place of $\mathbb{Q}\langle j\rangle$ over $\mathbb{Q}$, in the
+sense of the project's structure `Place`, is a valuation subring of $\mathbb{Q}\langle j\rangle$
+that contains the image of $\mathbb{Q}$, is not the whole field, and is a principal ideal ring; for
+such a place $v$ and $f$ in the field, $v.\mathrm{ord}(f)$ is minus the logarithm of the value of
+$f$ under the adic valuation attached to the height-one prime of the valuation ring, i.e. the
+integer exponent with which the maximal ideal divides $f$. The place
+[`ModularCurve.jLinePlaceZero`](def/ModularCurve_JLinePlaces.html#L54) is obtained by transporting,
+along the isomorphism [`ModularCurve.jLineRingEquiv`](def/ModularCurve_JLinePlaces.html#L36) $:\
+\mathrm{RatFunc}\,\mathbb{Q} \xrightarrow{\ \sim\ } \mathbb{Q}\langle j\rangle$ sending the variable
+to $\mathrm{jq}$ (and fixing $\mathbb{Q}$), the finite place of $\mathbb{Q}(T)$ cut out by the
+irreducible polynomial $T-0$. The assertion is that the order of $\mathrm{jq}$ at this place equals
+$1$; that is, $j$ is a uniformiser at the place $j=0$ of the $j$-line.
+
+This records the elementary but needed fact that the rational function $j$ has a simple zero at the
+point $j=0$ of the $j$-line $X(1)_{\mathbb{Q}}$, the place being one of the three distinguished
+places $j=0,1728,\infty$. It is used by
+[`ModularCurve.ramificationIndex_eq_ord_of_restrict_eq_jLinePlaceZero`]
+(thm.html#ModularCurve.ramificationIndex_eq_ord_of_restrict_eq_jLinePlaceZero),
+where ramification indices of places of modular function fields above $j=0$ are computed as orders
+of $j$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ord_jLinePlaceZero_jGen.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ord_jLinePlaceZero_jGen
+
+open IntermediateField AlgebraicCurve AlgebraicCurve.RationalFunctionField
+
+attribute [local instance 2000] RatFunc.instAlgebraOfPolynomial
+attribute [local instance] ModularCurve.instDecidableEqRatFuncRat
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jLineRingEquiv jLineRingEquiv_X instDecidableEqRatFuncRat \
+  jLinePlaceZero jq jGen"
+namespace JLineOrdAux
+p2m_open "ModularCurve"
+
+theorem equiv_X_sub_C (b : ℚ) :
+    ModularCurve.jLineRingEquiv (algebraMap (Polynomial ℚ) (RatFunc ℚ) (Polynomial.X - Polynomial.C
+      b))
+      = ModularCurve.jGen - algebraMap ℚ ↥ℚ⟮ModularCurve.jq⟯ b := by
+  rw [map_sub, RatFunc.algebraMap_X, map_sub, ModularCurve.jLineRingEquiv_X, RatFunc.algebraMap_C]
+  congr 1
+  exact RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom b
+
+theorem exists_eq_congr (v : Place ℚ ↥ℚ⟮ModularCurve.jq⟯) :
+    ∃ v' : Place ℚ (RatFunc ℚ), v = Place.congrRingEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom) v' :=
+  ⟨(Place.congrEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom)).symm v,
+    ((Place.congrEquiv _ _).apply_symm_apply v).symm⟩
+
+theorem ord_congr_jGen_sub (b : ℚ) (v' : Place ℚ (RatFunc ℚ)) :
+    (Place.congrRingEquiv ModularCurve.jLineRingEquiv
+        (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom) v').ord
+      (ModularCurve.jGen - algebraMap ℚ ↥ℚ⟮ModularCurve.jq⟯ b)
+    = (Finsupp.single (placeOfPoint ℚ b) (1 : ℤ) + Finsupp.single (placeInfty ℚ) (-1 : ℤ)) v' := by
+  rw [← equiv_X_sub_C, Place.ord_congrRingEquiv]
+  exact ord_X_sub_C ℚ b v'
+
+theorem injective_congr : Function.Injective (Place.congrRingEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom) : Place ℚ (RatFunc ℚ) → _)
+        :=
+  (Place.congrEquiv ModularCurve.jLineRingEquiv
+      (RingHom.map_rat_algebraMap ModularCurve.jLineRingEquiv.toRingHom)).injective
+
+end ModularCurve.JLineOrdAux
+
+open ModularCurve.JLineOrdAux
+
+theorem solution : ModularCurve.jLinePlaceZero.ord ModularCurve.jGen = 1 := by
+  have h := ord_congr_jGen_sub 0 (placeOfPoint ℚ 0)
+  rw [map_zero, sub_zero] at h
+  have h01 := placeOfPoint_ne_placeInfty ℚ 0
+  unfold ModularCurve.jLinePlaceZero
+  rw [h]
+  simp [h01]
+
+end S_ModularCurve_ord_jLinePlaceZero_jGen
+end P2MW
+export P2MW.S_ModularCurve_ord_jLinePlaceZero_jGen (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open IntermediateField AlgebraicCurve
+theorem ModularCurve.ord_jLinePlaceZero_jGen :
+    ModularCurve.jLinePlaceZero.ord ModularCurve.jGen = 1 :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_qInftyPlaceBar.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_qInftyPlaceBar.lean
new file mode 100644
index 0000000000..846265d02a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_qInftyPlaceBar.lean
@@ -0,0 +1,107 @@
+/-
+Based on Prove2Me node ModularCurve.ord_qInftyPlaceBar
+(9fbf2f4a-fbc2-51f0-9678-51ab98df3e7d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8b418c51-75fc-5767-98c3-33d4ee81f38e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlace
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order at the q-adic place equals q-expansion order
+
+Theorem statement: `ModularCurve.ord_qInftyPlaceBar` (`9fbf2f4a-fbc2-51f0-9678-51ab98df3e7d`), by
+Claude, 2026-09-05.
+
+Proof: submission `8b418c51-75fc-5767-98c3-33d4ee81f38e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field and let $F$ be an intermediate field of the extension $L((q))/L$, where $L((q))$
+is the field of formal Laurent series over $L$; for $f \in F$ write $\overline{f} \in L((q))$ for
+its image, denoted `qSeriesBar L F f`. Assume the hypothesis $h$: some $j \in F$ satisfies
+$\operatorname{order}(\overline{j}) = -1$, the order of a Hahn series being the index of its lowest
+nonzero coefficient (with the convention $\operatorname{order}(0)=0$). Under $h$ the set $\{f \in F
+: \operatorname{order}(\overline{f}) \ge 0\}$ is a valuation subring of $F$ containing $L$, distinct
+from $F$ and a principal ideal ring, hence defines a place `qInftyPlaceBar L F h` of $F$ over $L$ in
+the sense of the project's structure `Place`. The assertion is that for every $f \in F$ the
+associated normalised order, namely minus the logarithm of the value of $f$ under the
+$\mathbb{Z}^{m0}$-valued adic valuation attached to the height-one prime of that valuation ring,
+equals $\operatorname{order}(\overline{f})$. In particular both sides vanish at $f = 0$.
+
+This identifies the valuation attached to the cusp $\infty$ on a curve presented through
+$q$-expansions with the elementary order of vanishing of the $q$-series, with no ramification
+factor, the hypothesis $h$ providing an element of $q$-order $-1$ whose inverse is a uniformiser. It
+is used in the computation of the order of $j$-type functions at the cusp and in the comparison of
+$\infty$ with its translates under field automorphisms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ord_qInftyPlaceBar.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ord_qInftyPlaceBar
+
+open ModularCurve AlgebraicCurve
+
+theorem solution (L : Type*) [Field L] {F : IntermediateField L (LaurentSeries L)}
+    (h : ∃ j : F, (qSeriesBar L F j).order = -1) (f : F) :
+    (qInftyPlaceBar L F h).ord f = (qSeriesBar L F f).order := by
+  obtain ⟨j, hj⟩ := h
+  rcases eq_or_ne f 0 with rfl | hf
+  · rw [Place.ord_zero, qSeriesBar_zero, HahnSeries.order_zero]
+  set n : ℤ := (qSeriesBar L F f).order with hn
+  have hπ0 : (j⁻¹ : F) ≠ 0 := inv_ne_zero (ne_zero_of_order_eq_neg_one hj)
+  have hπn : (j⁻¹ : F) ^ n ≠ 0 := zpow_ne_zero _ hπ0
+  have huord : (qSeriesBar L F (f / (j⁻¹) ^ n)).order = 0 := by
+    rw [qSeriesBar_div, qSeriesBar_zpow,
+      order_div_of_ne_zero_bar (qSeriesBar_ne_zero hf)
+        (zpow_ne_zero _ (qSeriesBar_ne_zero hπ0)),
+      order_zpow_of_ne_zero_bar (qSeriesBar_ne_zero hπ0), order_inv_of_order_eq_neg_one hj,
+      mul_one, ← hn]
+    ring
+  have humem : f / (j⁻¹) ^ n ∈ qIntegersBar L F := by
+    rw [mem_qIntegersBar_iff, huord]
+  have hune : f / (j⁻¹) ^ n ≠ 0 := div_ne_zero hf hπn
+  have huu : IsUnit (⟨f / (j⁻¹) ^ n, humem⟩ : qIntegersBar L F) :=
+    (isUnit_qIntegersBar_iff hune).mpr huord
+  have hdecomp : f = ((huu.unit : qIntegersBar L F) : F)
+      * (((uniformizerBar hj : qIntegersBar L F) : F) ^ n) := by
+    have hcoe : ((huu.unit : qIntegersBar L F) : F) = f / (j⁻¹) ^ n := by
+      rw [IsUnit.unit_spec]
+    rw [hcoe, coe_uniformizerBar]
+    exact (div_mul_cancel₀ f hπn).symm
+  rw [hdecomp]
+  exact (qInftyPlaceBar L F ⟨j, hj⟩).ord_unit_smul_zpow huu.unit (irreducible_uniformizerBar hj) n
+
+end S_ModularCurve_ord_qInftyPlaceBar
+end P2MW
+export P2MW.S_ModularCurve_ord_qInftyPlaceBar (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.ord_qInftyPlaceBar (L : Type*) [Field L]
+    {F : IntermediateField L (LaurentSeries L)} (h : ∃ j : F, (qSeriesBar L F j).order = -1) (f : F)
+    :
+    (qInftyPlaceBar L F h).ord f = (qSeriesBar L F f).order :=
+  solution L h f
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_sub_algebraMap_le_one_laurentBaseChange_qExpFunctionFieldC_of_ne_zero_of_ne_1728.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_sub_algebraMap_le_one_laurentBaseChange_qExpFunctionFieldC_of_ne_zero_of_ne_1728.lean
new file mode 100644
index 0000000000..c5da19ac66
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ord_sub_algebraMap_le_one_laurentBaseChange_qExpFunctionFieldC_of_ne_zero_of_ne_1728.lean
@@ -0,0 +1,1200 @@
+/-
+Based on Prove2Me node
+ModularCurve.ord_sub_algebraMap_le_one_laurentBaseChange_qExpFunctionFieldC_of_ne_zero_of_ne_1728
+(a6de7247-5400-574b-aa68-d302fb996ed0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 13721155-867c-5489-9ba2-ececa561e868
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_of_orderMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteDimensional_adjoin_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isIntegral_adjoin_intermediateField_mk
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_JOneES_exists_transcendental_finiteDimensional_laurentBaseChange
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_adjoin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Zeros of j-a are simple for a≠ 0,1728
+
+Theorem statement:
+`ModularCurve.ord_sub_algebraMap_le_one_laurentBaseChange_qExpFunctionFieldC_of_ne_zero_of_ne_1728`
+(`a6de7247-5400-574b-aa68-d302fb996ed0`), by Claude, 2026-09-05.
+
+Proof: submission `13721155-867c-5489-9ba2-ececa561e868`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $M \geq 1$ and a subgroup $\Gamma$ of $\mathrm{SL}(2,\mathbb{Z})$ containing $\Gamma_1(M)$. Let
+$F_0 =$ `qExpFunctionFieldC ℚ Γ` be the intermediate field of $\mathbb{Q}((q))$ generated over
+$\mathbb{Q}$ by the set of quotients `intSeriesC ℚ pf / intSeriesC ℚ pg`, where $f,g$ are modular
+forms of one and the same weight $k$ for $\Gamma$ (viewed in $\mathrm{GL}(2,\mathbb{R})$), $p_f,p_g$
+are power series over $\mathbb{Z}$ with `IsIntegralQExp f pf` and `IsIntegralQExp g pg`, and
+`intSeriesC ℚ pg ≠ 0`; and let $F =$ `laurentBaseChange ℂ F₀` be the intermediate field of
+$\mathbb{C}((q))$ generated over $\mathbb{C}$ by the image of $F_0$ under coefficientwise extension
+of scalars $\mathbb{Q} \to \mathbb{C}$. Let $y \in F$ be an element whose underlying Laurent series
+is `jqModC ℂ`, that is $q^{-1}$ times the image over $\mathbb{C}$ of the power series `jNum` $=
+E_4^3 \cdot$ `dedekindEtaUnitInv`, the $q$-expansion of the modular invariant $j$. Let $a \in
+\mathbb{C}$ with $a \neq 0$ and $a \neq 1728$, and let $P$ be a place of $F$ over $\mathbb{C}$, i.e.
+a valuation subring of $F$ other than $F$ itself which contains the image of $\mathbb{C}$ and is a
+principal ideal ring. Then $\mathrm{ord}_P(y - a) \leq 1$, where $\mathrm{ord}_P$ is minus the
+logarithm of the associated adic valuation.
+
+This is the local content of the Riemann–Hurwitz computation for modular curves: the covering
+$X(\Gamma) \to X(1)$ given by $j$ is unramified over every finite value $a \notin \{0,1728\}$, so
+that each zero of $j-a$ on the curve with function field $F$ is simple. It feeds, together with the
+companion bounds at $j=0$ and $j=1728$, into the ramification count over an algebraic closure and
+into the genus inequality for $\Gamma \supseteq \Gamma_1(M)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ord_sub_algebraMap_le_one_laurentBaseChange_qExpFunctionFieldC_of_ne_zero_of_ne_1728.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_29084bdf
+
+
+noncomputable section
+
+open UpperHalfPlane Filter
+open scoped MatrixGroups Topology Manifold IntermediateField.algebraAdjoinAdjoin
+
+namespace ModularCurve
+p2m_export "ModularCurve" "IsIntegralQExp intSeriesC intFormRatiosC qExpFunctionFieldC \
+  ofPowerSeries_coeff_of_neg coeffEmb coeffEmb_coeff laurentBaseChange jqModC \
+  isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder laurentBaseChange_adjoin \
+  jqModC_eq_qExpansion_E4_cube_div_discriminant \
+  meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two transcendental_jqModC \
+  JOneES.exists_transcendental_finiteDimensional_laurentBaseChange"
+namespace UnramifiedGamma
+p2m_open "ModularCurve"
+
+section Prelim
+
+variable {Γ : Subgroup SL(2, ℤ)}
+
+theorem T_mem_Gamma1 (M : ℕ) : ModularGroup.T ∈ CongruenceSubgroup.Gamma1 M := by
+  rw [CongruenceSubgroup.Gamma1_mem]
+  simp [ModularGroup.T]
+
+theorem one_mem_strictPeriods (hT : ModularGroup.T ∈ Γ) :
+    (1 : ℝ) ∈ ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  rw [Subgroup.mem_strictPeriods_iff]
+  refine ⟨ModularGroup.T, hT, ?_⟩
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp [ModularGroup.T, Matrix.GeneralLinearGroup.upperRightHom]
+
+abbrev qL {k : ℤ} (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) : LaurentSeries ℂ :=
+  ((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+
+theorem map_coe_nhdsNE (τ : ℍ) :
+    Filter.map ((↑) : ℍ → ℂ) (𝓝[≠] τ) = 𝓝[≠] (τ : ℂ) := by
+  have h := isOpenEmbedding_coe.map_nhdsWithin_preimage_eq ({(τ : ℂ)}ᶜ) τ
+  have hpre : ((↑) : ℍ → ℂ) ⁻¹' ({(τ : ℂ)}ᶜ : Set ℂ) = ({τ}ᶜ : Set ℍ) := by
+    ext w
+    simp
+  rwa [hpre] at h
+
+theorem eventually_nhdsNE_coe_iff {p : ℍ → Prop} {τ : ℍ} :
+    (∀ᶠ z in 𝓝[≠] (τ : ℂ), p (ofComplex z)) ↔ ∀ᶠ w in 𝓝[≠] τ, p w := by
+  rw [← map_coe_nhdsNE, Filter.eventually_map]
+  simp only [ofComplex_apply]
+
+scoped instance nhdsNE_neBot (τ : ℍ) : (𝓝[≠] τ).NeBot := by
+  have h : (Filter.map ((↑) : ℍ → ℂ) (𝓝[≠] τ)).NeBot := by
+    rw [map_coe_nhdsNE]; infer_instance
+  exact Filter.NeBot.of_map h
+
+theorem isBoundedUnder_nhdsNE_coe_iff {u : ℍ → ℝ} {τ : ℍ} :
+    IsBoundedUnder (· ≤ ·) (𝓝[≠] (τ : ℂ)) (fun z : ℂ => u (ofComplex z)) ↔
+      IsBoundedUnder (· ≤ ·) (𝓝[≠] τ) u := by
+  rw [← map_coe_nhdsNE, Filter.isBoundedUnder_map_iff]
+  simp only [Function.comp_def, ofComplex_apply]
+
+theorem analyticAt_comp_ofComplex {k : ℤ} (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (τ : ℍ) : AnalyticAt ℂ (fun z : ℂ => (f : ℍ → ℂ) (ofComplex z)) (τ : ℂ) := by
+  have hf : DifferentiableOn ℂ ((f : ℍ → ℂ) ∘ ofComplex) {z : ℂ | 0 < z.im} :=
+    UpperHalfPlane.mdifferentiable_iff.mp (ModularFormClass.holo f)
+  exact hf.analyticAt (isOpen_upperHalfPlaneSet.mem_nhds τ.im_pos)
+
+theorem coe_eq_zero_iff {k : ℤ} (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) :
+    (f : ℍ → ℂ) = 0 ↔ f = 0 := by
+  constructor
+  · intro h
+    exact DFunLike.coe_injective (h.trans (FunLike.coe_zero).symm)
+  · rintro rfl; rfl
+
+theorem eventually_ne_zero {k : ℤ} (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (hf : f ≠ 0) (τ : ℍ) : ∀ᶠ w in 𝓝[≠] τ, (f : ℍ → ℂ) w ≠ 0 := by
+  by_contra hcon
+  have hfr : ∃ᶠ w in 𝓝[≠] τ, (f : ℍ → ℂ) w = 0 := by
+    simpa [Filter.not_eventually] using hcon
+  exact hf ((coe_eq_zero_iff f).mp (eq_zero_of_frequently (ModularFormClass.holo f) hfr))
+
+theorem eventually_ne_zero_ofComplex {k : ℤ} (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (hf : f ≠ 0) (τ : ℍ) : ∀ᶠ z in 𝓝[≠] (τ : ℂ), (f : ℍ → ℂ) (ofComplex z) ≠ 0 :=
+  eventually_nhdsNE_coe_iff.mpr (eventually_ne_zero f hf τ)
+
+theorem meromorphicOrderAt_comp_ofComplex_ne_top {k : ℤ}
+    (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (hf : f ≠ 0) (τ : ℍ) :
+    meromorphicOrderAt (fun z : ℂ => (f : ℍ → ℂ) (ofComplex z)) (τ : ℂ) ≠ ⊤ :=
+  (meromorphicOrderAt_ne_top_iff_eventually_ne_zero
+    (analyticAt_comp_ofComplex f τ).meromorphicAt).mpr (eventually_ne_zero_ofComplex f hf τ)
+
+theorem exists_apply_ne_zero {k : ℤ} (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (hf : f ≠ 0) : ∃ w : ℍ, (f : ℍ → ℂ) w ≠ 0 :=
+  (eventually_ne_zero f hf UpperHalfPlane.I).exists
+
+theorem qL_ne_zero (hT : ModularGroup.T ∈ Γ) {k : ℤ}
+    (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (hf : f ≠ 0) : qL f ≠ 0 := by
+  intro h
+  apply hf
+  rw [← ModularForm.qExpansion_eq_zero_iff one_pos (one_mem_strictPeriods hT)]
+  apply (HahnSeries.ofPowerSeries_injective (Γ := ℤ) (R := ℂ))
+  simpa [qL] using h
+
+theorem ne_zero_of_qL_ne_zero {k : ℤ} (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (hf : qL f ≠ 0) : f ≠ 0 := by
+  rintro rfl
+  apply hf
+  simp [qL, UpperHalfPlane.qExpansion_zero]
+
+theorem qL_mul (hT : ModularGroup.T ∈ Γ) {a b : ℤ} (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) a)
+    (g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) b) : qL (f.mul g) = qL f * qL g := by
+  simp only [qL, ModularForm.coe_mul,
+    ModularForm.qExpansion_mul_coe one_pos (one_mem_strictPeriods hT), PowerSeries.coe_mul]
+
+theorem qL_add (hT : ModularGroup.T ∈ Γ) {a : ℤ} (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) a)
+    :
+    qL (f + g) = qL f + qL g := by
+  simp only [qL, FunLike.coe_add,
+    ModularForm.qExpansion_add one_pos (one_mem_strictPeriods hT), PowerSeries.coe_add]
+
+theorem qL_one : qL (1 : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 0) = 1 := by
+  simp only [qL, ModularForm.qExpansion_one, PowerSeries.coe_one]
+
+theorem qL_const (hT : ModularGroup.T ∈ Γ) (c : ℂ) :
+    qL (c • (1 : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 0)) = algebraMap ℂ (LaurentSeries ℂ) c
+      := by
+  rw [qL, FunLike.coe_smul,
+    ModularForm.qExpansion_smul one_pos (one_mem_strictPeriods hT), ModularForm.qExpansion_one,
+    Algebra.smul_def, mul_one, HahnSeries.algebraMap_apply']
+
+theorem mul_ne_zero_of_ne_zero {a b : ℤ} (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) a)
+    (g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) b) (hf : f ≠ 0) (hg : g ≠ 0) :
+    f.mul g ≠ 0 := by
+  intro hfg
+  obtain ⟨w, hw⟩ := ((eventually_ne_zero f hf UpperHalfPlane.I).and
+    (eventually_ne_zero g hg UpperHalfPlane.I)).exists
+  have := congrArg (fun F : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) (a + b) => (F : ℍ → ℂ) w) hfg
+  simp only [ModularForm.coe_mul, Pi.mul_apply, FunLike.coe_zero, Pi.zero_apply,
+    mul_eq_zero] at this
+  exact this.elim hw.1 hw.2
+
+theorem one_ne_zero' : (1 : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 0) ≠ 0 := by
+  intro h
+  have :=
+    congrArg (fun F : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 0 => (F : ℍ → ℂ) UpperHalfPlane.I) h
+  simp [ModularForm.one_coe_eq_one] at this
+
+theorem algebraMap_laurentSeries_eq_C (c : ℂ) :
+    algebraMap ℂ (LaurentSeries ℂ) c = HahnSeries.C c := by
+  rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_eq, HahnSeries.ofPowerSeries_C]
+
+end Prelim
+
+section Presentation
+
+variable (Γ : Subgroup SL(2, ℤ))
+
+structure Pres (x : LaurentSeries ℂ) where
+  k : ℤ
+  g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k
+  h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k
+  h_ne : h ≠ 0
+  eq : x * qL h = qL g
+
+variable {Γ}
+variable (hT : ModularGroup.T ∈ Γ)
+
+abbrev Pres.mul {x y : LaurentSeries ℂ} (P : Pres Γ x) (Q : Pres Γ y) : Pres Γ (x * y) where
+  k := P.k + Q.k
+  g := P.g.mul Q.g
+  h := P.h.mul Q.h
+  h_ne := mul_ne_zero_of_ne_zero P.h Q.h P.h_ne Q.h_ne
+  eq := by
+    rw [qL_mul hT, qL_mul hT, ← P.eq, ← Q.eq]; ring
+
+abbrev Pres.add {x y : LaurentSeries ℂ} (P : Pres Γ x) (Q : Pres Γ y) : Pres Γ (x + y) where
+  k := P.k + Q.k
+  g := P.g.mul Q.h + P.h.mul Q.g
+  h := P.h.mul Q.h
+  h_ne := mul_ne_zero_of_ne_zero P.h Q.h P.h_ne Q.h_ne
+  eq := by
+    rw [qL_add hT, qL_mul hT, qL_mul hT, qL_mul hT, ← P.eq, ← Q.eq]; ring
+
+abbrev Pres.const (c : ℂ) : Pres Γ (algebraMap ℂ (LaurentSeries ℂ) c) where
+  k := 0
+  g := c • (1 : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 0)
+  h := 1
+  h_ne := one_ne_zero'
+  eq := by
+    rw [qL_one, mul_one, qL_const hT]
+
+abbrev Pres.neg {x : LaurentSeries ℂ} (P : Pres Γ x) : Pres Γ (-x) where
+  k := P.k
+  g := -P.g
+  h := P.h
+  h_ne := P.h_ne
+  eq := by
+    have hneg : qL (-P.g) = -qL P.g := by
+      simp only [qL, FunLike.coe_neg,
+        ModularForm.qExpansion_neg one_pos (one_mem_strictPeriods hT), PowerSeries.coe_neg]
+    rw [hneg, ← P.eq]; ring
+
+abbrev Pres.inv {x : LaurentSeries ℂ} (P : Pres Γ x) (hx : x ≠ 0) : Pres Γ x⁻¹ where
+  k := P.k
+  g := P.h
+  h := P.g
+  h_ne := by
+    intro hg
+    have heq := P.eq
+    rw [hg, show qL (0 : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) P.k) = 0 by
+      simp [qL, UpperHalfPlane.qExpansion_zero]] at heq
+    exact (mul_eq_zero.mp heq).elim hx (qL_ne_zero hT P.h P.h_ne)
+  eq := by
+    have hh : qL P.h ≠ 0 := qL_ne_zero hT P.h P.h_ne
+    have hg : qL P.g ≠ 0 := by
+      intro hg
+      have heq := P.eq
+      rw [hg] at heq
+      exact (mul_eq_zero.mp heq).elim hx hh
+    rw [inv_mul_eq_iff_eq_mul₀ hx, P.eq]
+
+omit hT in
+def realizeG (x : LaurentSeries ℂ) (τ : ℍ) : ℂ := by
+  classical
+  exact
+    if H : ∃ p : (k : ℤ) × (ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k ×
+          ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k),
+        (p.2.2 : ℍ → ℂ) τ ≠ 0 ∧ x * qL p.2.2 = qL p.2.1
+    then (H.choose.2.1 : ℍ → ℂ) τ / (H.choose.2.2 : ℍ → ℂ) τ
+    else 0
+
+include hT in
+theorem realizeG_eq_div {k : ℤ} (g h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (x : LaurentSeries ℂ) (hx : x * qL h = qL g) (τ : ℍ) (hτ : (h : ℍ → ℂ) τ ≠ 0) :
+    realizeG (Γ := Γ) x τ = (g : ℍ → ℂ) τ / (h : ℍ → ℂ) τ := by
+  classical
+  have h1 := one_mem_strictPeriods hT
+  have H : ∃ p : (k : ℤ) × (ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k ×
+        ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k),
+      (p.2.2 : ℍ → ℂ) τ ≠ 0 ∧ x * qL p.2.2 = qL p.2.1 :=
+    ⟨⟨k, g, h⟩, hτ, hx⟩
+  have hval : realizeG (Γ := Γ) x τ = (H.choose.2.1 : ℍ → ℂ) τ / (H.choose.2.2 : ℍ → ℂ) τ := by
+    simp only [realizeG, dite_eq_left H]
+  rw [hval]
+  obtain ⟨hτ', hx'⟩ := H.choose_spec
+  set p := H.choose with hp
+  obtain ⟨k', g', h'⟩ := p
+  simp only at hτ' hx' ⊢
+  have hq : qExpansion 1 ((g' : ℍ → ℂ) * (h : ℍ → ℂ)) = qExpansion 1 ((g : ℍ → ℂ) * (h' : ℍ → ℂ)) :=
+    by
+    apply (HahnSeries.ofPowerSeries_injective (Γ := ℤ) (R := ℂ))
+    rw [ModularForm.qExpansion_mul_coe one_pos h1, ModularForm.qExpansion_mul_coe one_pos h1,
+      PowerSeries.coe_mul, PowerSeries.coe_mul]
+    change qL g' * qL h = qL g * qL h'
+    rw [← hx, ← hx']
+    ring
+  have hAB : (g'.mul h : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) (k' + k)) =
+      ModularForm.mcast (add_comm k k') (g.mul h') := by
+    rw [← sub_eq_zero, ← ModularForm.qExpansion_eq_zero_iff one_pos h1, FunLike.coe_sub,
+      ModularForm.qExpansion_sub one_pos h1, sub_eq_zero, ModularForm.coe_mcast,
+      ModularForm.coe_mul, ModularForm.coe_mul, hq]
+  have hτeq : (g' : ℍ → ℂ) τ * (h : ℍ → ℂ) τ = (g : ℍ → ℂ) τ * (h' : ℍ → ℂ) τ := by
+    have := congrArg (fun f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) (k' + k) => (f : ℍ → ℂ) τ)
+      hAB
+    simpa [ModularForm.coe_mul, ModularForm.coe_mcast] using this
+  rw [div_eq_div_iff hτ' hτ, hτeq]
+
+include hT in
+theorem realize_eventuallyEq {x : LaurentSeries ℂ} (P : Pres Γ x) (τ : ℍ) :
+    (fun z : ℂ => realizeG (Γ := Γ) x (ofComplex z)) =ᶠ[𝓝[≠] (τ : ℂ)]
+      fun z : ℂ => (P.g : ℍ → ℂ) (ofComplex z) / (P.h : ℍ → ℂ) (ofComplex z) := by
+  filter_upwards [eventually_ne_zero_ofComplex P.h P.h_ne τ] with z hz
+  exact realizeG_eq_div hT P.g P.h x P.eq (ofComplex z) hz
+
+include hT in
+theorem realize_eventuallyEq' {x : LaurentSeries ℂ} (P : Pres Γ x) (τ : ℍ) :
+    (fun w : ℍ => realizeG (Γ := Γ) x w) =ᶠ[𝓝[≠] τ]
+      fun w : ℍ => (P.g : ℍ → ℂ) w / (P.h : ℍ → ℂ) w := by
+  filter_upwards [eventually_ne_zero P.h P.h_ne τ] with w hw
+  exact realizeG_eq_div hT P.g P.h x P.eq w hw
+
+omit hT in
+theorem meromorphicAt_div (x : LaurentSeries ℂ) (P : Pres Γ x) (τ : ℍ) :
+    MeromorphicAt (fun z : ℂ => (P.g : ℍ → ℂ) (ofComplex z) / (P.h : ℍ → ℂ) (ofComplex z))
+      (τ : ℂ) :=
+  (analyticAt_comp_ofComplex P.g τ).meromorphicAt.div (analyticAt_comp_ofComplex P.h
+    τ).meromorphicAt
+
+include hT in
+theorem meromorphicAt_realize {x : LaurentSeries ℂ} (P : Pres Γ x) (τ : ℍ) :
+    MeromorphicAt (fun z : ℂ => realizeG (Γ := Γ) x (ofComplex z)) (τ : ℂ) :=
+  (meromorphicAt_div x P τ).congr (realize_eventuallyEq hT P τ).symm
+
+include hT in
+theorem meromorphicOrderAt_realize_eq {x : LaurentSeries ℂ} (P : Pres Γ x) (τ : ℍ) :
+    ∃ m : ℤ, 0 ≤ m ∧
+      meromorphicOrderAt (fun z : ℂ => (P.h : ℍ → ℂ) (ofComplex z)) (τ : ℂ) = m ∧
+      meromorphicOrderAt (fun z : ℂ => realizeG (Γ := Γ) x (ofComplex z)) (τ : ℂ) =
+        meromorphicOrderAt (fun z : ℂ => (P.g : ℍ → ℂ) (ofComplex z)) (τ : ℂ) + ((-m : ℤ) : WithTop
+          ℤ) := by
+  have hh := meromorphicOrderAt_comp_ofComplex_ne_top P.h P.h_ne τ
+  obtain ⟨m, hm⟩ := WithTop.ne_top_iff_exists.mp hh
+  have hm0 : 0 ≤ m := by
+    have := (analyticAt_comp_ofComplex P.h τ).meromorphicOrderAt_nonneg
+    rw [← hm] at this
+    exact_mod_cast this
+  refine ⟨m, hm0, hm.symm, ?_⟩
+  rw [meromorphicOrderAt_congr (realize_eventuallyEq hT P τ)]
+  have hdiv : (fun z : ℂ => (P.g : ℍ → ℂ) (ofComplex z) / (P.h : ℍ → ℂ) (ofComplex z)) =
+      (fun z : ℂ => (P.g : ℍ → ℂ) (ofComplex z)) * (fun z : ℂ => (P.h : ℍ → ℂ) (ofComplex z))⁻¹
+        := by
+    ext z; simp [div_eq_mul_inv]
+  rw [hdiv, meromorphicOrderAt_mul (analyticAt_comp_ofComplex P.g τ).meromorphicAt
+    (analyticAt_comp_ofComplex P.h τ).meromorphicAt.inv, meromorphicOrderAt_inv, ← hm]
+  rfl
+
+include hT in
+theorem realize_mul_eventuallyEq {x y : LaurentSeries ℂ} (P : Pres Γ x) (Q : Pres Γ y) (τ : ℍ) :
+    (fun z : ℂ => realizeG (Γ := Γ) (x * y) (ofComplex z)) =ᶠ[𝓝[≠] (τ : ℂ)]
+      (fun z : ℂ => realizeG (Γ := Γ) x (ofComplex z)) * fun z : ℂ => realizeG (Γ := Γ) y (ofComplex
+        z) := by
+  filter_upwards [realize_eventuallyEq hT (P.mul hT Q) τ, realize_eventuallyEq hT P τ,
+    realize_eventuallyEq hT Q τ] with z h1 h2 h3
+  rw [Pi.mul_apply, h2, h3, h1]
+  rw [ModularForm.coe_mul, ModularForm.coe_mul, Pi.mul_apply, Pi.mul_apply, mul_div_mul_comm]
+
+include hT in
+theorem realize_add_eventuallyEq {x y : LaurentSeries ℂ} (P : Pres Γ x) (Q : Pres Γ y) (τ : ℍ) :
+    (fun z : ℂ => realizeG (Γ := Γ) (x + y) (ofComplex z)) =ᶠ[𝓝[≠] (τ : ℂ)]
+      (fun z : ℂ => realizeG (Γ := Γ) x (ofComplex z)) + fun z : ℂ => realizeG (Γ := Γ) y (ofComplex
+        z) := by
+  filter_upwards [realize_eventuallyEq hT (P.add hT Q) τ, realize_eventuallyEq hT P τ,
+    realize_eventuallyEq hT Q τ, eventually_ne_zero_ofComplex P.h P.h_ne τ,
+    eventually_ne_zero_ofComplex Q.h Q.h_ne τ] with z h1 h2 h3 hP hQ
+  rw [Pi.add_apply, h2, h3, h1]
+  rw [FunLike.coe_add, Pi.add_apply, ModularForm.coe_mul, ModularForm.coe_mul,
+    ModularForm.coe_mul, Pi.mul_apply, Pi.mul_apply, Pi.mul_apply, div_add_div _ _ hP hQ,
+    mul_comm ((P.h : ℍ → ℂ) (ofComplex z)) ((Q.g : ℍ → ℂ) (ofComplex z))]
+
+include hT in
+theorem realize_const_eventuallyEq (c : ℂ) (τ : ℍ) :
+    (fun z : ℂ => realizeG (Γ := Γ) (algebraMap ℂ (LaurentSeries ℂ) c) (ofComplex z)) =ᶠ[𝓝[≠] (τ :
+      ℂ)]
+      fun _ => c := by
+  filter_upwards [realize_eventuallyEq hT (Pres.const hT c) τ] with z h1
+  rw [h1, FunLike.coe_smul, ModularForm.one_coe_eq_one]
+  simp
+
+end Presentation
+
+section Exists
+
+variable {Γ : Subgroup SL(2, ℤ)} (hT : ModularGroup.T ∈ Γ)
+
+theorem coeffEmb_intSeriesC (p : PowerSeries ℤ) :
+    coeffEmb ℂ (intSeriesC ℚ p) = HahnSeries.ofPowerSeries ℤ ℂ (p.map (Int.castRingHom ℂ)) := by
+  ext n
+  rw [coeffEmb_coeff, intSeriesC]
+  rcases le_or_gt 0 n with hn | hn
+  · lift n to ℕ using hn
+    rw [HahnSeries.ofPowerSeries_apply_coeff, HahnSeries.ofPowerSeries_apply_coeff,
+      PowerSeries.coeff_map, PowerSeries.coeff_map]
+    simp
+  · rw [ofPowerSeries_coeff_of_neg _ hn, ofPowerSeries_coeff_of_neg _ hn, map_zero]
+
+theorem coeffEmb_generator {k : ℤ} (f g : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    {pf pg : PowerSeries ℤ} (hf : IsIntegralQExp f pf) (hg : IsIntegralQExp g pg) :
+    coeffEmb ℂ (intSeriesC ℚ pf / intSeriesC ℚ pg) = qL f / qL g := by
+  rw [map_div₀, coeffEmb_intSeriesC, coeffEmb_intSeriesC]
+  rw [show pf.map (Int.castRingHom ℂ) = qExpansion 1 (f : ℍ → ℂ) from hf,
+    show pg.map (Int.castRingHom ℂ) = qExpansion 1 (g : ℍ → ℂ) from hg]
+
+def presSubfield : Subfield (LaurentSeries ℂ) where
+  carrier := {x | Nonempty (Pres Γ x)}
+  mul_mem' := by
+    rintro x y ⟨P⟩ ⟨Q⟩; exact ⟨P.mul hT Q⟩
+  one_mem' := by
+    have h := Pres.const (Γ := Γ) hT 1
+    rw [map_one] at h
+    exact ⟨h⟩
+  add_mem' := by
+    rintro x y ⟨P⟩ ⟨Q⟩; exact ⟨P.add hT Q⟩
+  zero_mem' := by
+    have h := Pres.const (Γ := Γ) hT 0
+    rw [map_zero] at h
+    exact ⟨h⟩
+  neg_mem' := by
+    rintro x ⟨P⟩; exact ⟨P.neg hT⟩
+  inv_mem' := by
+    rintro x ⟨P⟩
+    rcases eq_or_ne x 0 with rfl | hx
+    · rw [inv_zero]
+      have h := Pres.const (Γ := Γ) hT 0
+      rw [map_zero] at h
+      exact ⟨h⟩
+    · exact ⟨P.inv hT hx⟩
+
+theorem mem_presSubfield {x : LaurentSeries ℂ} :
+    x ∈ presSubfield hT ↔ Nonempty (Pres Γ x) := Iff.rfl
+
+include hT in
+theorem exists_pres (x : LaurentSeries ℂ) (hx : x ∈ laurentBaseChange ℂ (qExpFunctionFieldC ℚ Γ)) :
+    Nonempty (Pres Γ x) := by
+  rw [qExpFunctionFieldC, laurentBaseChange_adjoin] at hx
+  have hle : IntermediateField.adjoin ℂ (coeffEmb ℂ '' intFormRatiosC ℚ Γ) ≤
+      (presSubfield hT).toIntermediateField (fun c => by
+        rw [algebraMap_laurentSeries_eq_C, ← algebraMap_laurentSeries_eq_C]
+        exact ⟨Pres.const hT c⟩) := by
+    rw [IntermediateField.adjoin_le_iff]
+    rintro _ ⟨y, ⟨k, f, g, pf, pg, hf, hg, hg0, rfl⟩, rfl⟩
+    change coeffEmb ℂ (intSeriesC ℚ pf / intSeriesC ℚ pg) ∈ presSubfield hT
+    rw [coeffEmb_generator f g hf hg]
+    have hqg : qL g ≠ 0 := by
+      change HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (g : ℍ → ℂ)) ≠ 0
+      rw [← show pg.map (Int.castRingHom ℂ) = qExpansion 1 (g : ℍ → ℂ) from hg]
+      rw [← coeffEmb_intSeriesC]
+      exact (map_ne_zero_iff _ (coeffEmb ℂ).injective).mpr hg0
+    have hgne : g ≠ 0 := ne_zero_of_qL_ne_zero g hqg
+    exact ⟨⟨k, f, g, hgne, div_mul_cancel₀ _ hqg⟩⟩
+  exact hle hx
+
+end Exists
+
+section OrderFunction
+
+variable {Γ : Subgroup SL(2, ℤ)} (hT : ModularGroup.T ∈ Γ)
+
+abbrev CF (Γ : Subgroup SL(2, ℤ)) : Type :=
+  ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ Γ))
+
+def pres (x : CF Γ) : Pres Γ (x : LaurentSeries ℂ) :=
+  Classical.choice (exists_pres hT (x : LaurentSeries ℂ) x.2)
+
+def mu (τ : ℍ) (x : CF Γ) : WithTop ℤ :=
+  meromorphicOrderAt (fun z : ℂ => realizeG (Γ := Γ) (x : LaurentSeries ℂ) (ofComplex z)) (τ : ℂ)
+
+include hT in
+theorem meromorphicAt_realize' (x : CF Γ) (τ : ℍ) :
+    MeromorphicAt (fun z : ℂ => realizeG (Γ := Γ) (x : LaurentSeries ℂ) (ofComplex z)) (τ : ℂ) :=
+  meromorphicAt_realize hT (pres hT x) τ
+
+include hT in
+theorem mu_mul (τ : ℍ) (x y : CF Γ) : mu τ (x * y) = mu τ x + mu τ y := by
+  change meromorphicOrderAt
+      (fun z : ℂ => realizeG (Γ := Γ) ((x : LaurentSeries ℂ) * (y : LaurentSeries ℂ)) (ofComplex z))
+        (τ : ℂ) = _
+  rw [meromorphicOrderAt_congr (realize_mul_eventuallyEq hT (pres hT x) (pres hT y) τ),
+    meromorphicOrderAt_mul (meromorphicAt_realize' hT x τ) (meromorphicAt_realize' hT y τ)]
+  rfl
+
+include hT in
+theorem mu_add (τ : ℍ) (x y : CF Γ) : min (mu τ x) (mu τ y) ≤ mu τ (x + y) := by
+  change _ ≤ meromorphicOrderAt
+      (fun z : ℂ => realizeG (Γ := Γ) ((x : LaurentSeries ℂ) + (y : LaurentSeries ℂ)) (ofComplex z))
+      (τ : ℂ)
+  rw [meromorphicOrderAt_congr (realize_add_eventuallyEq hT (pres hT x) (pres hT y) τ)]
+  exact meromorphicOrderAt_add (meromorphicAt_realize' hT x τ) (meromorphicAt_realize' hT y τ)
+
+include hT in
+theorem mu_algebraMap (τ : ℍ) (c : ℂ) (hc : c ≠ 0) : mu τ (algebraMap ℂ (CF Γ) c) = 0 := by
+  classical
+  change meromorphicOrderAt
+      (fun z : ℂ => realizeG (Γ := Γ) (algebraMap ℂ (LaurentSeries ℂ) c) (ofComplex z)) (τ : ℂ) = 0
+  rw [meromorphicOrderAt_congr (realize_const_eventuallyEq hT c τ), meromorphicOrderAt_const,
+    ite_eq_right hc]
+
+include hT in
+theorem mu_eq_top_iff (τ : ℍ) (x : CF Γ) : mu τ x = ⊤ ↔ x = 0 := by
+  obtain ⟨m, hm0, hmh, hmu⟩ := meromorphicOrderAt_realize_eq hT (pres hT x) τ
+  constructor
+  · intro hx
+    unfold mu at hx
+    rw [hx] at hmu
+    have hg : meromorphicOrderAt (fun z : ℂ => ((pres hT x).g : ℍ → ℂ) (ofComplex z)) (τ : ℂ) = ⊤ :=
+      by
+      rcases WithTop.add_eq_top.mp hmu.symm with h | h
+      · exact h
+      · exact absurd h WithTop.coe_ne_top
+    have hg0 : (pres hT x).g = 0 := by
+      by_contra hne
+      exact meromorphicOrderAt_comp_ofComplex_ne_top _ hne τ hg
+    have heq := (pres hT x).eq
+    rw [hg0, show qL (0 : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) (pres hT x).k) = 0 by
+      simp [qL, UpperHalfPlane.qExpansion_zero]] at heq
+    have hx0 : (x : LaurentSeries ℂ) = 0 :=
+      (mul_eq_zero.mp heq).resolve_right (qL_ne_zero hT _ (pres hT x).h_ne)
+    exact_mod_cast hx0
+  · rintro rfl
+    have heq : (0 : LaurentSeries ℂ) * qL (pres hT (0 : CF Γ)).h = qL (pres hT (0 : CF Γ)).g :=
+      (pres hT (0 : CF Γ)).eq
+    rw [zero_mul] at heq
+    have hg0 : (pres hT (0 : CF Γ)).g = 0 := by
+      by_contra hne
+      exact qL_ne_zero hT _ hne heq.symm
+    unfold mu
+    rw [hmu, hg0]
+    have h0 : meromorphicOrderAt (fun z : ℂ =>
+        ((0 : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) (pres hT (0 : CF Γ)).k) : ℍ → ℂ)
+          (ofComplex z)) (τ : ℂ) = ⊤ :=
+      meromorphicOrderAt_eq_top_iff.mpr (Filter.Eventually.of_forall fun _ => by simp)
+    rw [h0, top_add]
+
+include hT in
+theorem mu_ne_top (τ : ℍ) {x : CF Γ} (hx : x ≠ 0) : mu τ x ≠ ⊤ :=
+  fun h => hx ((mu_eq_top_iff hT τ x).mp h)
+
+include hT in
+theorem mu_one (τ : ℍ) : mu τ (1 : CF Γ) = 0 := by
+  rw [← map_one (algebraMap ℂ (CF Γ))]
+  exact mu_algebraMap hT τ 1 one_ne_zero
+
+include hT in
+theorem exists_mu_pos (τ : ℍ) (X : CF Γ) (hX : ∀ c : ℂ, X ≠ algebraMap ℂ (CF Γ) c) :
+    ∃ x : CF Γ, 0 < mu τ x ∧ mu τ x ≠ ⊤ := by
+  have hX0 : X ≠ 0 := by simpa using hX 0
+  have hXt := mu_ne_top hT τ hX0
+  by_cases hneg : mu τ X < 0
+  · refine ⟨X⁻¹, ?_, mu_ne_top hT τ (inv_ne_zero hX0)⟩
+    have hsum : mu τ X⁻¹ + mu τ X = 0 := by
+      rw [← mu_mul hT, inv_mul_cancel₀ hX0, mu_one hT]
+    obtain ⟨m, hm⟩ := WithTop.ne_top_iff_exists.mp hXt
+    obtain ⟨n, hn⟩ := WithTop.ne_top_iff_exists.mp (mu_ne_top hT τ (inv_ne_zero hX0))
+    rw [← hm, ← hn, ← WithTop.coe_add, ← WithTop.coe_zero, WithTop.coe_eq_coe] at hsum
+    rw [← hm, ← WithTop.coe_zero, WithTop.coe_lt_coe] at hneg
+    rw [← hn, ← WithTop.coe_zero, WithTop.coe_lt_coe]
+    omega
+  · rw [not_lt] at hneg
+    obtain ⟨c, hc⟩ :=
+      (tendsto_nhds_iff_meromorphicOrderAt_nonneg (meromorphicAt_realize' hT X τ)).mpr hneg
+    refine ⟨X - algebraMap ℂ (CF Γ) c, ?_, mu_ne_top hT τ (sub_ne_zero.mpr (hX c))⟩
+    apply (tendsto_zero_iff_meromorphicOrderAt_pos (meromorphicAt_realize' hT _ τ)).mp
+    have hlim : Tendsto ((fun z : ℂ => realizeG (Γ := Γ) ((X : CF Γ) : LaurentSeries ℂ) (ofComplex
+      z)) +
+        fun _ => -c) (𝓝[≠] (τ : ℂ)) (𝓝 0) := by
+      have h__af := hc.add (tendsto_const_nhds (x := -c))
+      simp only [add_neg_cancel] at h__af
+      exact h__af
+    refine hlim.congr' ?_
+    have hcoe : ((X - algebraMap ℂ (CF Γ) c : CF Γ) : LaurentSeries ℂ) =
+        ((X : CF Γ) : LaurentSeries ℂ) + algebraMap ℂ (LaurentSeries ℂ) (-c) := by
+      rw [map_neg, ← sub_eq_add_neg]; rfl
+    rw [hcoe]
+    exact ((realize_add_eventuallyEq hT (pres hT X) (Pres.const hT (-c)) τ).trans
+      (EventuallyEq.rfl.add (realize_const_eventuallyEq hT (-c) τ))).symm
+
+include hT in
+theorem mu_nonneg_iff (τ : ℍ) (x : CF Γ) :
+    0 ≤ mu τ x ↔
+      IsBoundedUnder (· ≤ ·) (𝓝[≠] τ) (fun z : ℍ => ‖realizeG (Γ := Γ) (x : LaurentSeries ℂ) z‖)
+        := by
+  rw [← isBoundedUnder_nhdsNE_coe_iff, mu,
+    ← tendsto_nhds_iff_meromorphicOrderAt_nonneg (meromorphicAt_realize' hT x τ)]
+  constructor
+  · rintro ⟨c, hc⟩
+    exact hc.norm.isBoundedUnder_le
+  · intro hb
+    by_contra hno
+    have hneg : meromorphicOrderAt
+        (fun z : ℂ => realizeG (Γ := Γ) (x : LaurentSeries ℂ) (ofComplex z)) (τ : ℂ) < 0 := by
+      rw [tendsto_nhds_iff_meromorphicOrderAt_nonneg (meromorphicAt_realize' hT x τ), not_le] at hno
+      exact hno
+    have hcob :=
+      (tendsto_cobounded_iff_meromorphicOrderAt_neg (meromorphicAt_realize' hT x τ)).mpr hneg
+    rw [← tendsto_norm_atTop_iff_cobounded] at hcob
+    exact Filter.not_isBoundedUnder_of_tendsto_atTop hcob hb
+
+include hT in
+theorem exists_place (τ : ℍ) (X : CF Γ) (hX : ∀ c : ℂ, X ≠ algebraMap ℂ (CF Γ) c) :
+    ∃ (P : AlgebraicCurve.Place ℂ (CF Γ)) (e : ℕ), 0 < e ∧
+      (∀ x, x ∈ P.toValuationSubring ↔ 0 ≤ mu τ x) ∧
+      ∀ x, x ≠ 0 → mu τ x = (((e : ℤ) * P.ord x : ℤ) : WithTop ℤ) :=
+  AlgebraicCurve.Place.exists_of_orderMap (mu τ) (mu_eq_top_iff hT τ) (mu_mul hT τ) (mu_add hT τ)
+    (fun c hc => mu_algebraMap hT τ c hc) (exists_mu_pos hT τ X hX)
+
+end OrderFunction
+
+section LevelOne
+
+open ModularForm
+
+def jf : ℍ → ℂ := fun τ => (E₄ : ℍ → ℂ) τ ^ 3 / ModularForm.discriminant τ
+
+theorem jf_apply (τ : ℍ) : jf τ = (E₄ : ℍ → ℂ) τ ^ 3 / ModularForm.discriminant τ := rfl
+
+lemma E₄_smul (γ : SL(2, ℤ)) (τ : ℍ) : E₄ (γ • τ) = denom γ τ ^ (4 : ℤ) * E₄ τ := by
+  have h := SlashInvariantForm.slash_action_eqn'' (Γ := 𝒮ℒ) (k := (4 : ℤ)) E₄
+    (γ := (γ : GL (Fin 2) ℝ)) ⟨γ, rfl⟩ τ
+  simpa [ModularGroup.sl_moeb] using h
+
+lemma E₆_smul (γ : SL(2, ℤ)) (τ : ℍ) : E₆ (γ • τ) = denom γ τ ^ (6 : ℤ) * E₆ τ := by
+  have h := SlashInvariantForm.slash_action_eqn'' (Γ := 𝒮ℒ) (k := (6 : ℤ)) E₆
+    (γ := (γ : GL (Fin 2) ℝ)) ⟨γ, rfl⟩ τ
+  simpa [ModularGroup.sl_moeb] using h
+
+lemma Δ_smul (γ : SL(2, ℤ)) (τ : ℍ) :
+    ModularForm.discriminant (γ • τ) = denom γ τ ^ (12 : ℤ) * ModularForm.discriminant τ := by
+  have h := SlashInvariantForm.slash_action_eqn'' (Γ := 𝒮ℒ) (k := (12 : ℤ)) CuspForm.discriminant
+    (γ := (γ : GL (Fin 2) ℝ)) ⟨γ, rfl⟩ τ
+  simpa [ModularGroup.sl_moeb, CuspForm.coe_discriminant] using h
+
+lemma jf_smul (γ : SL(2, ℤ)) (τ : ℍ) : jf (γ • τ) = jf τ := by
+  simp only [jf]
+  rw [E₄_smul, Δ_smul]
+  have hd : (denom (γ : GL (Fin 2) ℝ) τ : ℂ) ≠ 0 := denom_ne_zero _ _
+  have hΔ := discriminant_ne_zero τ
+  field_simp
+
+lemma S_smul_I : ModularGroup.S • UpperHalfPlane.I = UpperHalfPlane.I :=
+  ModularGroup.stabilizer_I.mpr (by simp)
+
+lemma TinvS_smul_ρ : (ModularGroup.T⁻¹ * ModularGroup.S) • ρ = ρ :=
+  ModularGroup.stabilizer_ρ.mpr (by simp)
+
+lemma E₆_I : E₆ UpperHalfPlane.I = 0 := by
+  have h := E₆_smul ModularGroup.S UpperHalfPlane.I
+  rw [S_smul_I, ModularGroup.denom_S, UpperHalfPlane.coe_I] at h
+  have hI6 : Complex.I ^ (6 : ℤ) = -1 := by
+    rw [show (6 : ℤ) = ((6 : ℕ) : ℤ) from rfl, zpow_natCast]
+    calc Complex.I ^ 6 = (Complex.I ^ 2) ^ 3 := by ring
+      _ = -1 := by rw [Complex.I_sq]; norm_num
+  rw [hI6] at h
+  linear_combination h / 2
+
+lemma denom_TinvS_ρ :
+    denom (↑(ModularGroup.T⁻¹ * ModularGroup.S) : GL (Fin 2) ℝ) ρ = (ρ : ℂ) := by
+  rw [ModularGroup.denom_apply]
+  have h10 : (ModularGroup.T⁻¹ * ModularGroup.S) 1 0 = 1 := by
+    rw [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_T_inv, ModularGroup.coe_S]
+    simp
+  have h11 : (ModularGroup.T⁻¹ * ModularGroup.S) 1 1 = 0 := by
+    rw [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_T_inv, ModularGroup.coe_S]
+    simp
+  rw [h10, h11]
+  simp
+
+lemma ρ_ne_one : (ρ : ℂ) ≠ 1 := by
+  intro h
+  have := congrArg Complex.im h
+  rw [UpperHalfPlane.coe_im] at this
+  simp only [Complex.one_im] at this
+  exact ρ.im_pos.ne' this
+
+lemma E₄_ρ : E₄ ρ = 0 := by
+  have h := E₄_smul (ModularGroup.T⁻¹ * ModularGroup.S) ρ
+  rw [TinvS_smul_ρ, denom_TinvS_ρ] at h
+  have hρ4 : (ρ : ℂ) ^ (4 : ℤ) = (ρ : ℂ) := by
+    rw [show (4 : ℤ) = ((4 : ℕ) : ℤ) from rfl, zpow_natCast]
+    linear_combination ((ρ : ℂ) ^ 2 - ρ) * ρ_sq
+  rw [hρ4] at h
+  have : ((ρ : ℂ) - 1) * E₄ ρ = 0 := by linear_combination -h
+  rcases mul_eq_zero.mp this with h1 | h1
+  · exact absurd (sub_eq_zero.mp h1) ρ_ne_one
+  · exact h1
+
+lemma jf_ρ : jf ρ = 0 := by simp [jf, E₄_ρ]
+
+lemma jf_eq_of_E₆_eq_zero {τ : ℍ} (h6 : E₆ τ = 0) : jf τ = 1728 := by
+  have hΔ := discriminant_ne_zero τ
+  have hΔ' := discriminant_eq_E₄_cube_sub_E₆_sq τ
+  rw [h6] at hΔ'
+  simp only [jf]
+  rw [div_eq_iff hΔ, hΔ']
+  ring
+
+lemma jf_I : jf UpperHalfPlane.I = 1728 := jf_eq_of_E₆_eq_zero E₆_I
+
+lemma orbit_trichotomy (τ : ℍ) :
+    (∃ γ : SL(2, ℤ), τ = γ • UpperHalfPlane.I) ∨ (∃ γ : SL(2, ℤ), τ = γ • ρ) ∨
+      (∀ g : SL(2, ℤ), g • τ = τ → g = 1 ∨ g = -1) := by
+  obtain ⟨g₀, hg₀⟩ := ModularGroup.exists_smul_mem_fd τ
+  by_cases hI : g₀ • τ = UpperHalfPlane.I
+  · exact Or.inl ⟨g₀⁻¹, by rw [← hI, inv_smul_smul]⟩
+  by_cases hρ : g₀ • τ = ρ
+  · exact Or.inr (Or.inl ⟨g₀⁻¹, by rw [← hρ, inv_smul_smul]⟩)
+  by_cases hρ' : g₀ • τ = (1 : ℝ) +ᵥ ρ
+  · refine Or.inr (Or.inl ⟨g₀⁻¹ * ModularGroup.T, ?_⟩)
+    rw [mul_smul, UpperHalfPlane.modular_T_smul, ← hρ', inv_smul_smul]
+  refine Or.inr (Or.inr fun g hg => ?_)
+  have h : (g₀ * g * g₀⁻¹) • (g₀ • τ) = g₀ • τ := by
+    rw [mul_smul, mul_smul, inv_smul_smul, hg]
+  rcases ModularGroup.stabilizer_of_ne hg₀ h hI hρ hρ' with h1 | h1
+  · left
+    have := congrArg (fun x => g₀⁻¹ * x * g₀) h1
+    simpa [mul_assoc] using this
+  · right
+    have := congrArg (fun x => g₀⁻¹ * x * g₀) h1
+    simpa [mul_assoc] using this
+
+lemma natCard_stabilizer_eq_two {τ : ℍ} (h : ∀ g : SL(2, ℤ), g • τ = τ → g = 1 ∨ g = -1) :
+    Nat.card (MulAction.stabilizer SL(2, ℤ) τ) = 2 := by
+  have hiff : ∀ g : SL(2, ℤ), g ∈ MulAction.stabilizer SL(2, ℤ) τ ↔
+      g ∈ ({1, -1} : Finset SL(2, ℤ)) := by
+    intro g
+    rw [MulAction.mem_stabilizer_iff, Finset.mem_insert, Finset.mem_singleton]
+    refine ⟨h g, ?_⟩
+    rintro (rfl | rfl)
+    · exact one_smul _ _
+    · rw [ModularGroup.SL_neg_smul, one_smul]
+  rw [Nat.card_congr (Equiv.subtypeEquivRight
+    (q := fun g => g ∈ ({1, -1} : Finset SL(2, ℤ))) hiff), Nat.card_eq_finsetCard]
+  decide
+
+theorem natCard_stabilizer_eq_two_of_ne {τ : ℍ} (h0 : jf τ ≠ 0) (h1728 : jf τ ≠ 1728) :
+    Nat.card (MulAction.stabilizer SL(2, ℤ) τ) = 2 := by
+  rcases orbit_trichotomy τ with ⟨γ, rfl⟩ | ⟨γ, rfl⟩ | h
+  · exact absurd (by rw [jf_smul, jf_I]) h1728
+  · exact absurd (by rw [jf_smul, jf_ρ]) h0
+  · exact natCard_stabilizer_eq_two h
+
+theorem meromorphicOrderAt_jf_sub_eq_one {τ : ℍ} (h0 : jf τ ≠ 0) (h1728 : jf τ ≠ 1728) :
+    meromorphicOrderAt (fun z : ℂ => jf (ofComplex z) - jf τ) (τ : ℂ) = (1 : ℤ) := by
+  have h := meromorphicOrderAt_E4_cube_div_discriminant_sub_eq_card_stabilizer_div_two τ
+  rw [natCard_stabilizer_eq_two_of_ne h0 h1728] at h
+  exact h
+
+end LevelOne
+
+section Main
+
+variable {Γ : Subgroup SL(2, ℤ)} (hT : ModularGroup.T ∈ Γ)
+variable (y : CF Γ) (hy : (y : LaurentSeries ℂ) = jqModC ℂ)
+variable (M : ℕ) [NeZero M] (hΓ : CongruenceSubgroup.Gamma1 M ≤ Γ)
+
+theorem le_SL : ((Γ : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) ≤ 𝒮ℒ :=
+  Subgroup.map_le_range _ _
+
+def restrict {F : Type*} [FunLike F ℍ ℂ] {G G' : Subgroup (GL (Fin 2) ℝ)} (hle : G' ≤ G)
+    {k : ℤ} (f : F) [ModularFormClass F G k] : ModularForm G' k where
+  toFun := f
+  slash_action_eq' γ hγ := SlashInvariantFormClass.slash_action_eq f γ (hle hγ)
+  holo' := ModularFormClass.holo f
+  bdd_at_cusps' hc := ModularFormClass.bdd_at_cusps f (hc.mono hle)
+
+def GG : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12 :=
+  restrict (le_SL (Γ := Γ)) (ModularForm.mcast (by decide) (ModularForm.E₄.pow 3))
+
+def HH : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12 :=
+  restrict (le_SL (Γ := Γ)) CuspForm.discriminant
+
+theorem coe_GG : ((GG : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12) : ℍ → ℂ) =
+    ((ModularForm.E₄.pow 3 : ModularForm 𝒮ℒ (3 * 4)) : ℍ → ℂ) := rfl
+
+theorem coe_HH : ((HH : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12) : ℍ → ℂ) =
+    ModularForm.discriminant := rfl
+
+theorem HH_apply_ne_zero (z : ℍ) : (HH : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12) z ≠ 0 := by
+  change ModularForm.discriminant z ≠ 0
+  exact ModularForm.discriminant_ne_zero z
+
+theorem HH_ne_zero : (HH : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12) ≠ 0 := by
+  intro h
+  have := congrArg (fun f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12 => (f : ℍ → ℂ) I) h
+  exact HH_apply_ne_zero (Γ := Γ) I (by simpa using this)
+
+theorem GG_div_HH (z : ℍ) :
+    (GG : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12) z / (HH : ModularForm (Γ : Subgroup (GL (Fin
+      2) ℝ)) 12) z
+      = jf z := by
+  change ((ModularForm.E₄.pow 3 : ModularForm 𝒮ℒ (3 * 4)) : ℍ → ℂ) z / ModularForm.discriminant z =
+    jf z
+  rw [ModularForm.coe_pow, Pi.pow_apply, jf_apply]
+
+theorem qL_GG : qL (GG : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12) =
+    ((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) ^ 3 := by
+  have h : qExpansion 1 ((GG : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12) : ℍ → ℂ) =
+      (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) ^ 3 := by
+    rw [coe_GG, ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+  rw [qL, h, PowerSeries.coe_pow]
+
+include hT hy in
+theorem y_mul_qL_HH :
+    (y : LaurentSeries ℂ) * qL (HH : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12) =
+    qL (GG : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12) := by
+  have hH : qL (HH : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12) =
+      ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) := rfl
+  have hne : ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) ≠
+    0 :=
+    by
+    rw [← hH]; exact qL_ne_zero hT _ HH_ne_zero
+  rw [hy, jqModC_eq_qExpansion_E4_cube_div_discriminant, qL_GG, hH]
+  exact div_mul_cancel₀ _ hne
+
+include hT hy in
+theorem realizeG_y (z : ℍ) : realizeG (Γ := Γ) (y : LaurentSeries ℂ) z = jf z := by
+  rw [realizeG_eq_div hT GG HH _ (y_mul_qL_HH hT y hy) z (HH_apply_ne_zero z), GG_div_HH]
+
+include hy in
+theorem transcendental_y : Transcendental ℂ y := by
+  have h := transcendental_jqModC ℂ
+  rw [← hy] at h
+  exact (transcendental_algebraMap_iff (R := ℂ) (A := LaurentSeries ℂ) (S := CF Γ)
+    Subtype.val_injective).mp h
+
+include hy in
+theorem y_ne_algebraMap (c : ℂ) : y ≠ algebraMap ℂ (CF Γ) c := by
+  intro h
+  exact transcendental_y y hy (h ▸ isAlgebraic_algebraMap c)
+
+def pt (τ : ℍ) : AlgebraicCurve.Place ℂ (CF Γ) :=
+  (exists_place hT τ y (y_ne_algebraMap y hy)).choose
+
+def ee (τ : ℍ) : ℕ :=
+  (exists_place hT τ y (y_ne_algebraMap y hy)).choose_spec.choose
+
+theorem ee_pos (τ : ℍ) : 0 < ee hT y hy τ :=
+  (exists_place hT τ y (y_ne_algebraMap y hy)).choose_spec.choose_spec.1
+
+theorem mem_pt_iff (τ : ℍ) (x : CF Γ) : x ∈ (pt hT y hy τ).toValuationSubring ↔ 0 ≤ mu τ x :=
+  (exists_place hT τ y (y_ne_algebraMap y hy)).choose_spec.choose_spec.2.1 x
+
+theorem mu_eq_ee_mul_ord (τ : ℍ) (x : CF Γ) (hx : x ≠ 0) :
+    mu τ x = (((ee hT y hy τ : ℤ) * (pt hT y hy τ).ord x : ℤ) : WithTop ℤ) :=
+  (exists_place hT τ y (y_ne_algebraMap y hy)).choose_spec.choose_spec.2.2 x hx
+
+theorem mem_pt_iff_isBoundedUnder (τ : ℍ) (x : CF Γ) :
+    x ∈ (pt hT y hy τ).toValuationSubring ↔
+      IsBoundedUnder (· ≤ ·) (𝓝[≠] τ) (fun z : ℍ => ‖realizeG (Γ := Γ) (x : LaurentSeries ℂ) z‖)
+        := by
+  rw [mem_pt_iff, mu_nonneg_iff hT]
+
+theorem y_mem_pt (τ : ℍ) : y ∈ (pt hT y hy τ).toValuationSubring := by
+  rw [mem_pt_iff_isBoundedUnder]
+  have hcont : Continuous (fun z : ℍ => (GG : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12) z /
+      (HH : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12) z) :=
+    (ModularFormClass.holo (GG : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12)).continuous.div
+      (ModularFormClass.holo (HH : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12)).continuous
+      HH_apply_ne_zero
+  have hbd : IsBoundedUnder (· ≤ ·) (𝓝 τ)
+      (fun z : ℍ => ‖(GG : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12) z /
+        (HH : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12) z‖) :=
+    (hcont.continuousAt.norm.tendsto).isBoundedUnder_le
+  have hfun : (fun z : ℍ => ‖realizeG (Γ := Γ) (y : LaurentSeries ℂ) z‖) =
+      fun z : ℍ => ‖(GG : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12) z /
+        (HH : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12) z‖ :=
+    funext fun z => by rw [realizeG_y hT y hy, GG_div_HH]
+  rw [hfun]
+  exact hbd.mono nhdsWithin_le_nhds
+
+abbrev A : Subalgebra ℂ (CF Γ) := Algebra.adjoin ℂ {y}
+
+abbrev Kj : IntermediateField ℂ (CF Γ) := IntermediateField.adjoin ℂ {y}
+
+include hy in
+theorem isPrincipalIdealRing_A : IsPrincipalIdealRing (A y) :=
+  let e : Polynomial ℂ ≃ₐ[ℂ] A y := Polynomial.algEquivOfTranscendental ℂ y (transcendental_y y hy)
+  IsPrincipalIdealRing.of_surjective e.toRingEquiv.toRingHom e.toRingEquiv.surjective
+
+scoped instance instAlgebraAKj : Algebra (A y) (Kj y) := inferInstance
+scoped instance instSMulAKj : SMul (A y) (Kj y) := Algebra.toSMul
+scoped instance instIsScalarTowerAKjCF : IsScalarTower (A y) (Kj y) (CF Γ) :=
+  Subalgebra.inclusion.isScalarTower_right
+    (IntermediateField.algebra_adjoin_le_adjoin ℂ ({y} : Set (CF Γ))) _
+
+include hT hy hΓ in
+theorem finiteDimensional_Kj : FiniteDimensional (Kj y) (CF Γ) := by
+  have : Γ.FiniteIndex := Subgroup.finiteIndex_of_le hΓ
+  obtain ⟨x, hx, hfin⟩ := JOneES.exists_transcendental_finiteDimensional_laurentBaseChange ℂ Γ hT
+  have := hfin
+  exact AlgebraicCurve.finiteDimensional_adjoin_of_transcendental x (transcendental_y y hy)
+
+def B : Subalgebra (A y) (CF Γ) := integralClosure (A y) (CF Γ)
+
+theorem mem_B_iff {x : CF Γ} : x ∈ B y ↔ IsIntegral (A y) x := Iff.rfl
+
+scoped instance instCommRingB : CommRing (B y) := (B y).toCommRing
+scoped instance instIsDomainB : IsDomain (B y) := Subalgebra.isDomain (B y)
+scoped instance instAlgebraAB : Algebra (A y) (B y) := (B y).algebra
+scoped instance instSMulAB : SMul (A y) (B y) := Algebra.toSMul
+scoped instance instAlgebraBCF : Algebra (B y) (CF Γ) := (B y).toAlgebra
+scoped instance instSMulBCF : SMul (B y) (CF Γ) := Algebra.toSMul
+scoped instance instIsScalarTowerABCF : IsScalarTower (A y) (B y) (CF Γ) :=
+  IsScalarTower.subalgebra' (A y) (CF Γ) (CF Γ) (B y)
+
+theorem algebraMap_B_apply (b : B y) : algebraMap (B y) (CF Γ) b = (b : CF Γ) := rfl
+
+set_option synthInstance.maxHeartbeats 40000 in -- this is needed (DL)
+include hT hy hΓ in
+theorem isDedekindDomain_B : IsDedekindDomain (B y) := by
+  have := isPrincipalIdealRing_A y hy
+  have : IsDedekindDomain (A y) := inferInstance
+  have := finiteDimensional_Kj hT y hy M hΓ
+  unfold B; exact integralClosure.isDedekindDomain (A y) (Kj y) (CF Γ)
+
+include hT hy hΓ in
+theorem isFractionRing_B : IsFractionRing (B y) (CF Γ) := by
+  have := isPrincipalIdealRing_A y hy
+  have : IsDedekindDomain (A y) := inferInstance
+  have := finiteDimensional_Kj hT y hy M hΓ
+  unfold B; exact integralClosure.isFractionRing_of_finite_extension (Kj y) (CF Γ)
+
+def valSubalgebra (Q : AlgebraicCurve.Place ℂ (CF Γ)) : Subalgebra ℂ (CF Γ) where
+  carrier := Q.toValuationSubring
+  mul_mem' ha hb := Q.toValuationSubring.mul_mem _ _ ha hb
+  one_mem' := Q.toValuationSubring.one_mem
+  add_mem' ha hb := Q.toValuationSubring.add_mem _ _ ha hb
+  zero_mem' := Q.toValuationSubring.zero_mem
+  algebraMap_mem' c := Q.algebraMap_mem' c
+
+theorem mem_valSubalgebra {Q : AlgebraicCurve.Place ℂ (CF Γ)} {x : CF Γ} :
+    x ∈ valSubalgebra Q ↔ x ∈ Q.toValuationSubring := Iff.rfl
+
+theorem A_le {Q : AlgebraicCurve.Place ℂ (CF Γ)} (hQ : y ∈ Q.toValuationSubring) (a : A y) :
+    (a : CF Γ) ∈ Q.toValuationSubring := by
+  have hle : A y ≤ valSubalgebra Q :=
+    Algebra.adjoin_le (Set.singleton_subset_iff.mpr ((mem_valSubalgebra).mpr hQ))
+  exact (mem_valSubalgebra).mp (hle a.2)
+
+theorem forall_algebraMap_B_mem {Q : AlgebraicCurve.Place ℂ (CF Γ)}
+    (hQ : y ∈ Q.toValuationSubring) :
+    ∀ b : B y, algebraMap (B y) (CF Γ) b ∈ Q.toValuationSubring := by
+  intro b
+  obtain ⟨p, hp, hpb⟩ := (mem_B_iff y).mp b.2
+  rw [algebraMap_B_apply]
+  refine Q.mem_of_eval_monic_eq_zero (P := p.map (algebraMap (A y) (CF Γ))) (hp.map _)
+    (fun i => ?_) ?_
+  · rw [Polynomial.coeff_map]
+    exact A_le y hQ (p.coeff i)
+  · rw [Polynomial.eval_map]
+    exact hpb
+
+include hΓ in
+theorem isIntegral_of_forall_mem_pt (x : CF Γ) (hx : ∀ τ : ℍ, x ∈ (pt hT y hy τ).toValuationSubring)
+    :
+    IsIntegral (A y) x := by
+  set P := pres hT x with hP
+  have hb : ∀ τ : ℍ, IsBoundedUnder (· ≤ ·) (𝓝[≠] τ)
+      (fun z : ℍ => ‖(P.g : ℍ → ℂ) z / (P.h : ℍ → ℂ) z‖) := by
+    intro τ
+    have h1 := (mem_pt_iff_isBoundedUnder hT y hy τ x).mp (hx τ)
+    obtain ⟨M', hM'⟩ := h1.eventually_le
+    refine isBoundedUnder_of_eventually_le (a := M') ?_
+    filter_upwards [hM', realize_eventuallyEq' hT P τ] with z hz hz'
+    have hz'' : realizeG (Γ := Γ) (x : LaurentSeries ℂ) z = (P.g : ℍ → ℂ) z / (P.h : ℍ → ℂ) z := hz'
+    rw [← hz'']
+    exact hz
+  have hint :=
+    isIntegral_adjoin_jqModC_qExpansion_div_of_forall_isBoundedUnder M Γ hΓ P.g P.h P.h_ne hb
+  have hxeq : HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 ⇑P.g) /
+      HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 ⇑P.h) = (x : LaurentSeries ℂ) := by
+    change qL P.g / qL P.h = (x : LaurentSeries ℂ)
+    rw [div_eq_iff (qL_ne_zero hT P.h P.h_ne), P.eq]
+  rw [hxeq, ← hy] at hint
+  have := AlgebraicCurve.isIntegral_adjoin_intermediateField_mk
+    (laurentBaseChange ℂ (qExpFunctionFieldC ℚ Γ)) y.2 x.2 hint
+  simpa using this
+
+open AlgebraicCurve in
+open scoped nonZeroDivisors in
+include hΓ in
+theorem exists_pt_eq (P : Place ℂ (CF Γ)) (hP : y ∈ P.toValuationSubring) :
+    ∃ τ : ℍ, pt hT y hy τ = P := by
+  have := isDedekindDomain_B hT y hy M hΓ
+  have := isFractionRing_B hT y hy M hΓ
+  have eq_of_center_eq : ∀ {Q Q' : Place ℂ (CF Γ)}
+      (hQ : ∀ b : B y, algebraMap (B y) (CF Γ) b ∈ Q.toValuationSubring)
+      (hQ' : ∀ b : B y, algebraMap (B y) (CF Γ) b ∈ Q'.toValuationSubring),
+      Place.center (B y) Q hQ = Place.center (B y) Q' hQ' → Q = Q' := by
+    intro Q Q' hQ hQ' h
+    apply Place.ext
+    rw [Place.toValuationSubring_eq_of_forall_mem Q hQ, Place.toValuationSubring_eq_of_forall_mem Q'
+      hQ']
+    have hc : Place.centerHeightOneSpectrum (B y) Q hQ = Place.centerHeightOneSpectrum (B y) Q' hQ'
+      :=
+      IsDedekindDomain.HeightOneSpectrum.ext h
+    rw [hc]
+  have mem_of_mul_eq : ∀ {Q : Place ℂ (CF Γ)}
+      (hQ : ∀ b : B y, algebraMap (B y) (CF Γ) b ∈ Q.toValuationSubring)
+      {x : CF Γ} {b s : B y}, s ∉ Place.center (B y) Q hQ →
+      x * algebraMap (B y) (CF Γ) s = algebraMap (B y) (CF Γ) b → x ∈ Q.toValuationSubring := by
+    intro Q hQ x b s hs hx
+    set O := Q.toValuationSubring
+    have hsunit : IsUnit (⟨algebraMap (B y) (CF Γ) s, hQ s⟩ : O) :=
+      IsLocalRing.notMem_maximalIdeal.mp (fun hm => hs ((Place.mem_center_iff Q hQ).mpr hm))
+    have hv1 : O.valuation (algebraMap (B y) (CF Γ) s) = 1 :=
+      (O.valuation_eq_one_iff _).mp hsunit
+    have hs0 : algebraMap (B y) (CF Γ) s ≠ 0 := by
+      intro h0
+      rw [h0, map_zero] at hv1
+      exact zero_ne_one hv1
+    have hxeq : x = algebraMap (B y) (CF Γ) b * (algebraMap (B y) (CF Γ) s)⁻¹ := by
+      rw [← hx, mul_inv_cancel_right₀ hs0]
+    rw [← O.valuation_le_one_iff, hxeq, map_mul, map_inv₀, hv1, inv_one, mul_one]
+    exact O.valuation_le_one ⟨_, hQ b⟩
+  by_contra hne
+  push Not at hne
+  have hwP := forall_algebraMap_B_mem y hP
+  have h𝔭0 : Place.center (B y) P hwP ≠ ⊥ := Place.center_ne_bot P hwP
+  have h𝔭max : (Place.center (B y) P hwP).IsMaximal :=
+    (Place.centerHeightOneSpectrum (B y) P hwP).isPrime.isMaximal h𝔭0
+  obtain ⟨x, hx𝔭, hxB⟩ :=
+    FractionalIdeal.exists_notMem_one_of_ne_bot (K := CF Γ) h𝔭0 h𝔭max.ne_top
+  have hxτ : ∀ τ : ℍ, x ∈ (pt hT y hy τ).toValuationSubring := by
+    intro τ
+    have hwτ := forall_algebraMap_B_mem y (y_mem_pt hT y hy τ)
+    have hneq : ¬ Place.center (B y) P hwP ≤ Place.center (B y) (pt hT y hy τ) hwτ := fun hle =>
+      hne τ (eq_of_center_eq hwτ hwP
+        (h𝔭max.eq_of_le
+          (Place.centerHeightOneSpectrum (B y) (pt hT y hy τ) hwτ).isPrime.ne_top hle).symm)
+    obtain ⟨s, hs𝔭, hsτ⟩ := Set.not_subset.mp hneq
+    have hxs : x * algebraMap (B y) (CF Γ) s ∈ (1 : FractionalIdeal (B y)⁰ (CF Γ)) := by
+      have hmem : x * algebraMap (B y) (CF Γ) s ∈
+          ((Place.center (B y) P hwP : FractionalIdeal (B y)⁰ (CF Γ))⁻¹ *
+            (Place.center (B y) P hwP : FractionalIdeal (B y)⁰ (CF Γ))) :=
+        FractionalIdeal.mul_mem_mul hx𝔭 (FractionalIdeal.mem_coeIdeal_of_mem _ hs𝔭)
+      rwa [inv_mul_cancel₀ (FractionalIdeal.coeIdeal_ne_zero.mpr h𝔭0)] at hmem
+    obtain ⟨b, hb⟩ := (FractionalIdeal.mem_one_iff _).mp hxs
+    exact mem_of_mul_eq hwτ hsτ hb.symm
+  have hint' : IsIntegral (A y) x := isIntegral_of_forall_mem_pt hT y hy M hΓ x hxτ
+  exact hxB ((FractionalIdeal.mem_one_iff _).mpr ⟨⟨x, (mem_B_iff y).mpr hint'⟩, rfl⟩)
+
+theorem mem_of_ord_nonneg (v : AlgebraicCurve.Place ℂ (CF Γ)) {f : CF Γ} (h : 0 ≤ v.ord f) :
+    f ∈ v.toValuationSubring := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact v.toValuationSubring.zero_mem
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf0 hπ
+  rw [hu]
+  obtain ⟨n, hn⟩ := Int.eq_ofNat_of_zero_le h
+  rw [hn, zpow_natCast]
+  exact mul_mem (u : v.toValuationSubring).2 (pow_mem π.2 n)
+
+include hT hy hΓ in
+theorem ord_sub_le_one (a : ℂ) (ha₀ : a ≠ 0) (ha₁₇₂₈ : a ≠ 1728) (P : AlgebraicCurve.Place ℂ (CF Γ))
+    :
+    P.ord (y - algebraMap ℂ (CF Γ) a) ≤ 1 := by
+  by_contra hgt
+  push Not at hgt
+  set u : CF Γ := y - algebraMap ℂ (CF Γ) a with hu
+  have hu0 : u ≠ 0 := sub_ne_zero.mpr (y_ne_algebraMap y hy a)
+  have huP : u ∈ P.toValuationSubring := mem_of_ord_nonneg P (by omega)
+  have hyP : y ∈ P.toValuationSubring := by
+    have : y = u + algebraMap ℂ (CF Γ) a := by rw [hu]; ring
+    rw [this]
+    exact P.toValuationSubring.add_mem _ _ huP (P.algebraMap_mem' a)
+  obtain ⟨τ₀, hτ₀⟩ := exists_pt_eq hT y hy M hΓ P hyP
+  subst hτ₀
+  have hmu := mu_eq_ee_mul_ord hT y hy τ₀ u hu0
+  have he := ee_pos hT y hy τ₀
+  have hreal : (fun z : ℂ => realizeG (Γ := Γ) (u : LaurentSeries ℂ) (ofComplex z)) =ᶠ[𝓝[≠] (τ₀ :
+    ℂ)]
+      fun z : ℂ => jf (ofComplex z) - a := by
+    have hcoe : ((u : CF Γ) : LaurentSeries ℂ) =
+        ((y : CF Γ) : LaurentSeries ℂ) + algebraMap ℂ (LaurentSeries ℂ) (-a) := by
+      rw [hu, map_neg, ← sub_eq_add_neg]; rfl
+    rw [hcoe]
+    refine ((realize_add_eventuallyEq hT (pres hT y) (Pres.const hT (-a)) τ₀).trans
+      (EventuallyEq.rfl.add (realize_const_eventuallyEq hT (-a) τ₀))).trans ?_
+    filter_upwards with z
+    rw [Pi.add_apply, realizeG_y hT y hy, sub_eq_add_neg]
+  have hmu' : mu τ₀ u = meromorphicOrderAt (fun z : ℂ => jf (ofComplex z) - a) (τ₀ : ℂ) :=
+    meromorphicOrderAt_congr hreal
+  have hpos : 0 < mu τ₀ u := by
+    rw [hmu, ← WithTop.coe_zero, WithTop.coe_lt_coe]
+    have : (0 : ℤ) < ee hT y hy τ₀ := by exact_mod_cast he
+    positivity
+  have hja : jf τ₀ = a := by
+    have hanal : AnalyticAt ℂ (fun z : ℂ => jf (ofComplex z) - a) (τ₀ : ℂ) := by
+      have hG := analyticAt_comp_ofComplex (GG : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12) τ₀
+      have hH := analyticAt_comp_ofComplex (HH : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12) τ₀
+      have hdiv := hG.div hH (HH_apply_ne_zero _)
+      have heq : (fun z : ℂ => jf (ofComplex z) - a) =
+          fun z : ℂ => (GG : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12) (ofComplex z) /
+            (HH : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) 12) (ofComplex z) - a := by
+        funext z; rw [GG_div_HH]
+      rw [heq]
+      exact hdiv.sub analyticAt_const
+    rw [hmu'] at hpos
+    have htend := (tendsto_zero_iff_meromorphicOrderAt_pos hanal.meromorphicAt).mpr hpos
+    have hcont : ContinuousAt (fun z : ℂ => jf (ofComplex z) - a) (τ₀ : ℂ) := hanal.continuousAt
+    have hlim := tendsto_nhds_unique (hcont.tendsto.mono_left nhdsWithin_le_nhds) htend
+    rw [ofComplex_apply] at hlim
+    exact sub_eq_zero.mp hlim
+  have hone : mu τ₀ u = (1 : ℤ) := by
+    rw [hmu', ← hja]
+    exact meromorphicOrderAt_jf_sub_eq_one (by rw [hja]; exact ha₀) (by rw [hja]; exact ha₁₇₂₈)
+  rw [hmu, WithTop.coe_eq_coe] at hone
+  have hle : (pt hT y hy τ₀).ord u ≤ (ee hT y hy τ₀ : ℤ) * (pt hT y hy τ₀).ord u :=
+    le_mul_of_one_le_left (by omega) (by exact_mod_cast he)
+  omega
+
+end Main
+
+end ModularCurve.UnramifiedGamma
+end
+
+open _root_.ModularCurve
+  _root_.P2MW.S_OVERLONG_29084bdf.ModularCurve
+  ModularCurve.UnramifiedGamma in
+theorem solution
+    (M : ℕ) [NeZero M] (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+    (hΓ : CongruenceSubgroup.Gamma1 M ≤ Γ)
+    (y : ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ))
+    (hy : (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ)
+    (a : ℂ) (ha₀ : a ≠ 0) (ha₁₇₂₈ : a ≠ 1728)
+    (P : AlgebraicCurve.Place ℂ
+      (ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ))) :
+    P.ord (y - algebraMap ℂ
+        (ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ)) a) ≤ 1 := by
+  have : Γ.FiniteIndex := Subgroup.finiteIndex_of_le hΓ
+  exact ord_sub_le_one (Γ := Γ) (hΓ (T_mem_Gamma1 M)) y hy M hΓ a ha₀ ha₁₇₂₈ P
+
+end S_OVERLONG_29084bdf
+end P2MW
+export
+  P2MW.S_OVERLONG_29084bdf
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem
+  ModularCurve.ord_sub_algebraMap_le_one_laurentBaseChange_qExpFunctionFieldC_of_ne_zero_of_ne_1728
+    (M : ℕ) [NeZero M] (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+    (hΓ : CongruenceSubgroup.Gamma1 M ≤ Γ)
+    (y : ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ))
+    (hy : (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ)
+    (a : ℂ) (ha₀ : a ≠ 0) (ha₁₇₂₈ : a ≠ 1728)
+    (P : AlgebraicCurve.Place ℂ
+      (ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ))) :
+    P.ord (y - algebraMap ℂ
+        (ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ Γ)) a) ≤ 1 :=
+  solution M Γ hΓ y hy a ha₀ ha₁₇₂₈ P
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_order_coeffEmb.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_order_coeffEmb.lean
new file mode 100644
index 0000000000..aca1307aee
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_order_coeffEmb.lean
@@ -0,0 +1,93 @@
+/-
+Based on Prove2Me node ModularCurve.order_coeffEmb
+(b59606ce-9f0c-522b-a285-96a1a61dafa6) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 00163c79-24b1-51b5-a206-ad8d62088758
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Coefficientwise base change preserves the order of a Laurent series
+
+Theorem statement: `ModularCurve.order_coeffEmb` (`b59606ce-9f0c-522b-a285-96a1a61dafa6`), by
+Claude, 2026-09-05.
+
+Proof: submission `00163c79-24b1-51b5-a206-ad8d62088758`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbb{Q}$-algebra structure, and let $x$ be a formal Laurent
+series with rational coefficients, i.e. an element of `LaurentSeries ℚ`, the Hahn series ring over
+$\mathbb{Q}$ with value group $\mathbb{Z}$. Write `coeffEmb L` for the ring homomorphism
+`LaurentSeries ℚ →+* LaurentSeries L` obtained from `coeffMap` applied to the structure map
+$\mathbb{Q} \to L$, that is, the map sending a series to the series whose coefficient at each
+exponent is the image of the corresponding coefficient of $x$ under $\mathbb{Q} \to L$ (this is a
+ring homomorphism: it preserves $0$, $1$, sums and products). The assertion is the equality of
+orders $$\operatorname{order}(\mathrm{coeffEmb}_L(x)) = \operatorname{order}(x),$$ where the order
+of a Hahn series is its least exponent carrying a nonzero coefficient, with the convention that the
+zero series has order $0$. No hypothesis beyond $L$ being a field that is a $\mathbb{Q}$-algebra is
+imposed; in particular $L$ may be of arbitrary transcendence degree, and $x$ may be zero.
+
+This records that base change of coefficients along a field extension of $\mathbb{Q}$ is
+order-preserving on $q$-expansions, so that vanishing orders at the cusp computed over $\mathbb{Q}$
+may be transported to $L$. It is used in the treatment of $q$-expansions of modular functions and
+modular units over a general coefficient field, for instance in the computations of orders of $j(q)$
+and of modular unit series and in the divisibility statement for the order of a cuspidal divisor
+class.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_order_coeffEmb.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_order_coeffEmb
+
+open ModularCurve
+
+theorem solution (L : Type*) [Field L] [Algebra ℚ L] (x : LaurentSeries ℚ) :
+    (coeffEmb L x).order = x.order := by
+  rcases eq_or_ne x 0 with rfl | hx
+  · rw [map_zero, HahnSeries.order_zero, HahnSeries.order_zero]
+  have hLx : coeffEmb L x ≠ 0 := by
+    intro h0
+    have h1 : (coeffEmb L x).coeff x.order = 0 := by rw [h0]; rfl
+    rw [coeffEmb_coeff, map_eq_zero_iff _ (algebraMap ℚ L).injective] at h1
+    exact HahnSeries.coeff_order_eq_zero.not.mpr hx h1
+  refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero ?_)
+    (HahnSeries.order_le_of_coeff_ne_zero ?_)
+  · rw [coeffEmb_coeff]
+    exact fun h => HahnSeries.coeff_order_eq_zero.not.mpr hx
+      ((map_eq_zero_iff _ (algebraMap ℚ L).injective).mp h)
+  · intro h
+    exact HahnSeries.coeff_order_eq_zero.not.mpr hLx (by rw [coeffEmb_coeff, h, map_zero])
+
+end S_ModularCurve_order_coeffEmb
+end P2MW
+export P2MW.S_ModularCurve_order_coeffEmb (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.order_coeffEmb (L : Type*) [Field L] [Algebra ℚ L] (x : LaurentSeries ℚ) :
+    (coeffEmb L x).order = x.order :=
+  solution L x
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_order_jqModC.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_order_jqModC.lean
new file mode 100644
index 0000000000..d334030ca2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_order_jqModC.lean
@@ -0,0 +1,162 @@
+/-
+Based on Prove2Me node ModularCurve.order_jqModC
+(3bf7d631-bbdd-5a8b-a570-ea5a9eae0d30) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission fb254058-f084-5837-88a7-b3eaf37e4f9a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import Mathlib.RingTheory.Algebraic.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The q-expansion of j has order -1
+
+Theorem statement: `ModularCurve.order_jqModC` (`3bf7d631-bbdd-5a8b-a570-ea5a9eae0d30`), by Claude,
+2026-09-05.
+
+Proof: submission `fb254058-f084-5837-88a7-b3eaf37e4f9a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a nontrivial commutative ring. Consider the Laurent series $\bar j \in K((q))$, written
+`jqModC K`, defined as the product of the Hahn series monomial $q^{-1}$, i.e. `HahnSeries.single (-1
+: ℤ) 1`, with the image under `HahnSeries.ofPowerSeries` of the power series `jNum` $=
+E_4^3\cdot\eta^{-24}$ (the product of the cube of the Eisenstein series `eisenstein4` with
+`dedekindEtaUnitInv`, taken in $\mathbb{Z}[[q]]$) after base change along the ring homomorphism
+$\mathbb{Z}\to K$. The assertion is that the Hahn-series order of this element, `(jqModC K).order`,
+is equal to $-1$; that is, $\bar j$ is nonzero and the least exponent occurring in its support is
+$-1$, so $\bar j$ has a simple pole at $q=0$. No hypothesis beyond nontriviality of $K$ is imposed,
+so the statement holds in every characteristic; $K$ is not assumed to be a field or a domain.
+
+This records the classical fact that the $q$-expansion $j = q^{-1} + 744 + \cdots$ has a simple pole
+at the cusp, in the form needed for the $q$-adic valuation of the $j$-invariant on modular curves
+over an arbitrary base. It is used throughout the analysis of ramification of the covers $X_H \to
+X(1)$, for instance in the computations of ramification indices along the inclusion maps at points
+where the $j$-coordinate has prescribed order.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_order_jqModC.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_order_jqModC
+
+noncomputable section
+open HahnSeries
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC jNum constantCoeff_jNum ofPowerSeries_coeff_of_neg jq_pow"
+p2m_open "ModularCurve"
+namespace CharLRows
+
+variable (K : Type*) [CommRing K]
+
+theorem jqModC_pow (n : ℕ) :
+    (jqModC K) ^ n = HahnSeries.single (-(n : ℤ)) 1 *
+      HahnSeries.ofPowerSeries ℤ K ((jNum.map (Int.castRingHom K)) ^ n) := by
+  have h : n • (-1 : ℤ) = -(n : ℤ) := by simp
+  rw [jqModC, mul_pow, HahnSeries.single_pow, one_pow, h, ← map_pow]
+
+theorem constantCoeff_jNum_map : PowerSeries.constantCoeff (jNum.map (Int.castRingHom K)) = 1 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff, PowerSeries.coeff_map,
+    PowerSeries.coeff_zero_eq_constantCoeff,
+    constantCoeff_jNum, map_one]
+
+theorem coeff_jqModC_pow_self (n : ℕ) : ((jqModC K) ^ n).coeff (-(n : ℤ)) = 1 := by
+  rw [jqModC_pow, HahnSeries.coeff_single_mul, one_mul, sub_neg_eq_add, neg_add_cancel,
+    show (0 : ℤ) = ((0 : ℕ) : ℤ) from rfl, HahnSeries.ofPowerSeries_apply_coeff,
+    PowerSeries.coeff_zero_eq_constantCoeff, map_pow, constantCoeff_jNum_map, one_pow]
+
+theorem coeff_jqModC_pow_of_lt {n : ℕ} {m : ℤ} (hm : m < -(n : ℤ)) :
+    ((jqModC K) ^ n).coeff m = 0 := by
+  rw [jqModC_pow, HahnSeries.coeff_single_mul, one_mul]
+  exact ofPowerSeries_coeff_of_neg _ (by omega)
+
+theorem coeff_jqModC_neg_one : (jqModC K).coeff (-1 : ℤ) = 1 := by
+  simpa using coeff_jqModC_pow_self K 1
+
+theorem algebraMap_laurentSeries_eq_single (c : K) :
+    algebraMap K (LaurentSeries K) c = HahnSeries.single 0 c := by
+  have h1 : algebraMap K (PowerSeries K) c = PowerSeries.C c := by simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+  rfl
+
+theorem aeval_jqModC_eq_zero {p : Polynomial K} (hp : Polynomial.aeval (jqModC K) p = 0) :
+    p = 0 := by
+  by_contra hp0
+  set n := p.natDegree with hn
+  have hcoeff : (Polynomial.aeval (jqModC K) p).coeff (-(n : ℤ)) = p.coeff n := by
+    rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+      Finset.sum_eq_single n]
+    · rw [algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_zero_mul,
+        coeff_jqModC_pow_self, mul_one]
+    · intro i hi hin
+      have hilt : i < n := lt_of_le_of_ne (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hin
+      rw [algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_zero_mul,
+        coeff_jqModC_pow_of_lt, mul_zero]
+      omega
+    · intro hn'
+      exact absurd (Finset.self_mem_range_succ n) hn'
+  rw [hp] at hcoeff
+  simp only [HahnSeries.coeff_zero] at hcoeff
+  exact hp0 (Polynomial.leadingCoeff_eq_zero.mp hcoeff.symm)
+
+theorem transcendental_jqModC : Transcendental K (jqModC K) :=
+  transcendental_iff.mpr fun _ hp => aeval_jqModC_eq_zero K hp
+
+theorem jqModC_ne_zero [Nontrivial K] : jqModC K ≠ 0 := by
+  intro h
+  have h1 : (jqModC K).coeff (-1 : ℤ) = 1 := coeff_jqModC_neg_one K
+  rw [h, HahnSeries.coeff_zero] at h1
+  exact zero_ne_one h1
+
+theorem order_jqModC [Nontrivial K] : (jqModC K).order = -1 := by
+  refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero ?_) ?_
+  · rw [coeff_jqModC_neg_one]
+    exact one_ne_zero
+  · by_contra hlt
+    rw [not_le] at hlt
+    refine HahnSeries.coeff_order_eq_zero.not.mpr (jqModC_ne_zero K) ?_
+    have h := coeff_jqModC_pow_of_lt K (n := 1) (m := (jqModC K).order)
+      (by simpa using hlt)
+    simpa using h
+
+end CharLRows
+
+end ModularCurve
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_order_jqModC.ModularCurve in
+theorem solution (K : Type*) [CommRing K] [Nontrivial K] :
+    (jqModC K).order = -1 :=
+  CharLRows.order_jqModC K
+
+end S_ModularCurve_order_jqModC
+end P2MW
+export P2MW.S_ModularCurve_order_jqModC (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.order_jqModC (K : Type*) [CommRing K] [Nontrivial K] :
+    (jqModC K).order = -1 :=
+  solution K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_order_qExpand.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_order_qExpand.lean
new file mode 100644
index 0000000000..bfd96be51f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_order_qExpand.lean
@@ -0,0 +1,97 @@
+/-
+Based on Prove2Me node ModularCurve.order_qExpand
+(9ec674e4-806b-5f67-ab79-bda68f0a9706) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 33e3e2b5-fb2f-531e-9bb6-d63139cb42cd
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Substitution q ↦ q^N multiplies the order by N
+
+Theorem statement: `ModularCurve.order_qExpand` (`9ec674e4-806b-5f67-ab79-bda68f0a9706`), by Claude,
+2026-09-05.
+
+Proof: submission `33e3e2b5-fb2f-531e-9bb6-d63139cb42cd`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring, let $N$ be a natural number that is nonzero, and let $f$ be a formal
+Laurent series over $R$, i.e. an element of `LaurentSeries R`, the Hahn series over the value group
+$\mathbb{Z}$ with coefficients in $R$. The map `qExpand R N` is the ring homomorphism of
+`LaurentSeries R` obtained by embedding the index monoid along the additive map $x \mapsto N x$ on
+$\mathbb{Z}$, which is injective and strictly monotone because $N > 0$; concretely it is the
+substitution $q \mapsto q^{N}$, sending $\sum_{n} a_n q^{n}$ to $\sum_n a_n q^{Nn}$. The assertion
+is the equality of integers
+$$\operatorname{order}(\mathrm{qExpand}_{R,N}(f)) = N \cdot \operatorname{order}(f),$$
+where the order of a Hahn series is the least element of its support and is set to $0$ for the zero
+series, and $N$ is coerced into $\mathbb{Z}$. In particular, for $f = 0$ both sides are $0$, and for
+$f \neq 0$ the least exponent occurring in $\mathrm{qExpand}_{R,N}(f)$ is exactly $N$ times the
+least exponent occurring in $f$.
+
+This records the behaviour of the order (valuation) of a $q$-expansion under the substitution $q
+\mapsto q^{N}$, the Laurent-series counterpart of the expansion operator on power series. It is used
+throughout the treatment of $q$-expansions on modular curves, for instance in the counting of poles
+and zeros of modular functions such as $j$ and $j(Nz)$ at the cusps.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_order_qExpand.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_order_qExpand
+
+open ModularCurve
+
+theorem solution {R : Type*} [CommRing R] (N : ℕ) [NeZero N] (f : LaurentSeries R) :
+    (qExpand R N f).order = N * f.order := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · rw [map_zero, HahnSeries.order_zero, mul_zero]
+  have hc : (qExpand R N f).coeff ((N : ℤ) * f.order) ≠ 0 := by
+    rw [qExpand_coeff_mul]
+    exact HahnSeries.coeff_order_eq_zero.not.mpr hf
+  have hne : qExpand R N f ≠ 0 := fun h0 => hc (by rw [h0]; rfl)
+  refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero hc) ?_
+  by_contra! hlt
+  have hk := HahnSeries.coeff_order_eq_zero.not.mpr hne
+  by_cases hdvd : (N : ℤ) ∣ (qExpand R N f).order
+  · obtain ⟨m, hm⟩ := hdvd
+    rw [hm, qExpand_coeff_mul] at hk
+    have hNpos : (0 : ℤ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+    have hmlt : m < f.order := by
+      rw [hm] at hlt
+      exact lt_of_mul_lt_mul_left hlt hNpos.le
+    exact hk (HahnSeries.coeff_eq_zero_of_lt_order hmlt)
+  · exact hk (qExpand_coeff_of_not_dvd N f hdvd)
+
+end S_ModularCurve_order_qExpand
+end P2MW
+export P2MW.S_ModularCurve_order_qExpand (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.order_qExpand {R : Type*} [CommRing R] (N : ℕ) [NeZero N] (f : LaurentSeries R)
+    :
+    (qExpand R N f).order = N * f.order :=
+  solution N f
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_package_of_socket.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_package_of_socket.lean
new file mode 100644
index 0000000000..2ad079b987
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_package_of_socket.lean
@@ -0,0 +1,1122 @@
+/-
+Based on Prove2Me node ModularCurve.package_of_socket
+(e3f1941e-e249-507b-8bea-51cafb5aa8cf) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9994796b-2f01-51ab-adad-3712b292b0f4
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_neg_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_order_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_mul_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_of_mul_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot_of_isPrimitiveRoot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Polynomial_mem_range_of_unique_common_root
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime_pow
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_mul_of_coprime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_fullC_mul_prime_pow
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqNModC_prime_not_mem_fullC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqNModC_mem_modularFunctionFieldC_mul_prime
+import Mathlib.FieldTheory.Relrank
+import Mathlib.Data.Nat.Factorization.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree ψ(d) and generation at every d ∣ M
+
+Theorem statement: `ModularCurve.package_of_socket` (`e3f1941e-e249-507b-8bea-51cafb5aa8cf`), by
+Claude, 2026-09-05.
+
+Proof: submission `9994796b-2f01-51ab-adad-3712b292b0f4`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and $M$ a nonzero natural number, and suppose $\zeta \in K^\times$ is such that
+its image in $K$ is a primitive $M$-th root of unity. Write $j =$ `jqModC K` for the Laurent series
+$q^{-1}\cdot(E_4^3\eta^{-24})$ over $K$, that is, the $q$-expansion of the $j$-invariant with its
+integer coefficients read in $K$, and for $N \neq 0$ write $j(q^N) =$ `jqNModC K N` for its image
+under the ring homomorphism of $K((q))$ multiplying all exponents by $N$. Assume that for every
+prime $p$ dividing $M$ the series $j(q^p)$ does not lie in the intermediate field $K(j)$ generated
+by $j$ over $K$ inside $K((q))$. Then for every nonzero divisor $d$ of $M$ two things hold: first,
+the $K(j)$-dimension of $K(j)\bigl(j(q^d)\bigr)$ equals $\psi(d) = \sum_{d' \mid d,\ d' \text{
+squarefree}} d/d'$, the Dedekind psi function; second, the field $K\bigl(j, j(q^d)\bigr)$ coincides
+with the field generated over $K$ by all the expansions $j(q^{d'})$ for nonzero divisors $d'$ of
+$d$.
+
+This is the assembly, over a field containing a primitive $M$-th root of unity, of the tower of
+$q$-expansion models of the function fields of the modular curves $X_0(d)$: the degrees
+$[K(j)(j(q^d)):K(j)] = \psi(d)$ and the generation of $K(j,j(q^d))$ by the divisor expansions are
+obtained simultaneously for all $d \mid M$ from the prime-level non-membership hypothesis. It is the
+source of the unconditional characteristic-zero degree formula and of its version under the same
+hypotheses on the base field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_package_of_socket.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_package_of_socket
+
+noncomputable section
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_package_of_socket.ModularCurve ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData coeffMap \
+  coeffMap_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm jqModC \
+  jqNModC jqNModC_one map_jqModC modularFunctionFieldC jqModC_mem jqNModC_mem coeffMap_qExpand \
+  coeff_jqModC_neg_one order_jqModC PhiGen.splits_prime_at_slot_of_isPrimitiveRoot \
+  exists_phiIrreducible_evalSymm dedekindPsi_prime_pow dedekindPsi_mul_of_coprime \
+  relfinrank_fullC_mul_prime_pow jqNModC_prime_not_mem_fullC \
+  jqNModC_mem_modularFunctionFieldC_mul_prime"
+namespace W1
+p2m_open "ModularCurve"
+
+variable {K : Type*} [Field K]
+
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+theorem jqModC_eq_TS : jqModC K = TS K 1 1 := by
+  rw [TS, qTwist_one_apply, qExpand_one_apply]
+
+theorem jqNModC_eq_TS (d : ℕ) [NeZero d] : jqNModC K d = TS K d 1 := by
+  rw [jqNModC, TS, qTwist_one_apply]
+
+theorem qExpand_jqNModC (A d : ℕ) [NeZero A] [NeZero d] :
+    qExpand K A (jqNModC K d) = TS K (A * d) 1 := by
+  rw [jqNModC_eq_TS, qExpand_TS]
+
+theorem qExpand_jqModC_eq_TS (A : ℕ) [NeZero A] : qExpand K A (jqModC K) = TS K A 1 := by
+  rw [TS, qTwist_one_apply]
+
+theorem qTwist_qExpand_of_pow_eq_one (A : ℕ) [NeZero A] (v : Kˣ) (hv : v ^ A = 1)
+    (x : LaurentSeries K) :
+    qTwist v (qExpand K A x) = qExpand K A x := by
+  rw [qTwist_qExpand]
+  have : v ^ (A : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData coeffMap \
+  coeffMap_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm jqModC \
+  jqNModC jqNModC_one map_jqModC modularFunctionFieldC jqModC_mem jqNModC_mem coeffMap_qExpand \
+  coeff_jqModC_neg_one order_jqModC PhiGen.splits_prime_at_slot_of_isPrimitiveRoot \
+  exists_phiIrreducible_evalSymm dedekindPsi_prime_pow dedekindPsi_mul_of_coprime \
+  relfinrank_fullC_mul_prime_pow jqNModC_prime_not_mem_fullC \
+  jqNModC_mem_modularFunctionFieldC_mul_prime"
+namespace W1
+p2m_open "ModularCurve"
+
+section transport
+
+variable {R S : Type*} [CommRing R] [CommRing S]
+
+theorem coeffMap_qTwist (σ : R →+* S) (u : Rˣ) (f : LaurentSeries R) :
+    coeffMap σ (qTwist u f) = qTwist (Units.map σ.toMonoidHom u) (coeffMap σ f) := by
+  ext k
+  simp only [coeffMap_coeff, qTwist_coeff, map_mul]
+  congr 1
+  rw [← map_zpow, Units.coe_map]
+  rfl
+
+end transport
+
+variable {K : Type*} [Field K]
+
+theorem coeffMap_TS {L : Type*} [Field L] (σ : L →+* K) (e : ℕ) [NeZero e] (u : Lˣ) :
+    coeffMap σ (TS L e u) = TS K e (Units.map σ.toMonoidHom u) := by
+  rw [TS, TS, coeffMap_qExpand, coeffMap_qTwist]
+  exact congrArg (fun z => qExpand K e (qTwist (Units.map σ.toMonoidHom u) z)) (map_jqModC σ)
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem units_pow_eq_one_of_isPrimitiveRoot {N : ℕ} {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N) :
+    ζ ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData coeffMap \
+  coeffMap_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm jqModC \
+  jqNModC jqNModC_one map_jqModC modularFunctionFieldC jqModC_mem jqNModC_mem coeffMap_qExpand \
+  coeff_jqModC_neg_one order_jqModC PhiGen.splits_prime_at_slot_of_isPrimitiveRoot \
+  exists_phiIrreducible_evalSymm dedekindPsi_prime_pow dedekindPsi_mul_of_coprime \
+  relfinrank_fullC_mul_prime_pow jqNModC_prime_not_mem_fullC \
+  jqNModC_mem_modularFunctionFieldC_mul_prime"
+namespace W1
+p2m_open "ModularCurve"
+
+
+
+
+
+
+theorem phiAtSeed_jqNModC_eval {R : Type*} [CommRing R] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n)
+    (d : ℕ) [NeZero d] : (phiAtSeed data (jqNModC R d)).eval (jqNModC R (d * n)) = 0 := by
+  have h := data.eval_jqNModC_mul_eq_zero R d
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' ?_ ?_
+  · exact RingHom.ext_int _ _
+  · simp
+
+theorem phiAtSeed_jqNModC_eval_symm {R : Type*} [CommRing R] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n)
+    (hsymm : EvalSymm data.Φ) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (jqNModC R (d * n))).eval (jqNModC R d) = 0 := by
+  have h := data.eval_jqNModC_of_mul_eq_zero hsymm R d
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' ?_ ?_
+  · exact RingHom.ext_int _ _
+  · simp
+
+theorem phiAtSeed_TS_eval {K : Type*} [Field K] (A : ℕ) [NeZero A] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (TS K (A * d) 1)).eval (TS K (A * (d * n)) 1) = 0 := by
+  have h := phiAtSeed_eval_map data _ _ (qExpand K A) (phiAtSeed_jqNModC_eval (R := K) n data d)
+  rwa [qExpand_jqNModC, qExpand_jqNModC] at h
+
+theorem phiAtSeed_TS_eval_symm {K : Type*} [Field K] (A : ℕ) [NeZero A] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n) (hsymm : EvalSymm data.Φ) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (TS K (A * (d * n)) 1)).eval (TS K (A * d) 1) = 0 := by
+  have h :=
+    phiAtSeed_eval_map data _ _ (qExpand K A) (phiAtSeed_jqNModC_eval_symm (R := K) n data hsymm d)
+  rwa [qExpand_jqNModC, qExpand_jqNModC] at h
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData coeffMap \
+  coeffMap_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm jqModC \
+  jqNModC jqNModC_one map_jqModC modularFunctionFieldC jqModC_mem jqNModC_mem coeffMap_qExpand \
+  coeff_jqModC_neg_one order_jqModC PhiGen.splits_prime_at_slot_of_isPrimitiveRoot \
+  exists_phiIrreducible_evalSymm dedekindPsi_prime_pow dedekindPsi_mul_of_coprime \
+  relfinrank_fullC_mul_prime_pow jqNModC_prime_not_mem_fullC \
+  jqNModC_mem_modularFunctionFieldC_mul_prime"
+namespace W1
+p2m_open "ModularCurve"
+
+variable {K : Type*} [Field K]
+
+private theorem prod_form_ne_zero (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e] (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ b) (jqModC K)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (jqModC K))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K))) ::ₘ
+          (Multiset.range p).map (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot p ζ hζ data e u,
+    Polynomial.roots_mul (prod_form_ne_zero ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ b) (jqModC K))))
+        = ((Multiset.range p).map (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K))) (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K))) ::ₘ
+        (Multiset.range p).map (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K)))).Nodup := by
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h :=
+      (TS_injective (K := K) (e := e) (e' := p * (p * e)) (u := u * ζ ^ b) (u' := u ^ (p * p))
+        heq).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e) (u := u * ζ ^ b) (u' := u * ζ ^ b') heq).2
+    have h2 : ζ ^ b = ζ ^ b' := mul_left_cancel h
+    have h3 : ((ζ : Kˣ) : K) ^ b = ((ζ : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h2]
+    exact hζ.pow_inj hb hb' h3
+
+theorem roots_prime_at_slot_roots_nodup (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (jqModC K))))).roots.Nodup := by
+  rw [roots_prime_at_slot p ζ hζ data e u]
+  exact roots_prime_at_slot_nodup p ζ hζ e u
+
+theorem isRoot_prime_at_slot_iff (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (jqModC K))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ b) (jqModC K)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (jqModC K)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot p ζ hζ data e u]
+    exact prod_form_ne_zero ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot p ζ hζ data e u, Multiset.mem_cons,
+    Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+theorem roots_phiAtSeed_TS (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (phiAtSeed data (TS K (p * e) (u ^ p))).roots
+      = TS K (p * (p * e)) (u ^ (p * p)) ::ₘ (Multiset.range p).map (fun b => TS K e (u * ζ ^ b)) :=
+  roots_prime_at_slot p ζ hζ data e u
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData coeffMap \
+  coeffMap_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm jqModC \
+  jqNModC jqNModC_one map_jqModC modularFunctionFieldC jqModC_mem jqNModC_mem coeffMap_qExpand \
+  coeff_jqModC_neg_one order_jqModC PhiGen.splits_prime_at_slot_of_isPrimitiveRoot \
+  exists_phiIrreducible_evalSymm dedekindPsi_prime_pow dedekindPsi_mul_of_coprime \
+  relfinrank_fullC_mul_prime_pow jqNModC_prime_not_mem_fullC \
+  jqNModC_mem_modularFunctionFieldC_mul_prime"
+namespace W1
+p2m_open "ModularCurve"
+
+variable {K : Type*} [Field K]
+
+def divSet (K : Type*) [Field K] (L : ℕ) : Set (LaurentSeries K) :=
+  {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ L ∧ x = jqNModC K d'}
+
+def fullC (K : Type*) [Field K] (L : ℕ) : IntermediateField K (LaurentSeries K) :=
+  IntermediateField.adjoin K (divSet K L)
+
+theorem jqNModC_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) : jqNModC K n = jqNModC K m := by
+  subst h; rfl
+
+theorem jqNModC_mem_divSet {d L : ℕ} [NeZero d] (hd : d ∣ L) : jqNModC K d ∈ divSet K L :=
+  ⟨d, inferInstance, hd, rfl⟩
+
+theorem divSet_mono {L L' : ℕ} (h : L ∣ L') : divSet K L ⊆ divSet K L' := by
+  rintro x ⟨d, hd0, hdL, rfl⟩
+  exact ⟨d, hd0, hdL.trans h, rfl⟩
+
+theorem jqNModC_mem_fullC {d L : ℕ} [NeZero d] (hd : d ∣ L) : jqNModC K d ∈ fullC K L :=
+  IntermediateField.subset_adjoin K _ (jqNModC_mem_divSet hd)
+
+theorem jqModC_mem_fullC (L : ℕ) : jqModC K ∈ fullC K L := by
+  have h := jqNModC_mem_fullC (K := K) (d := 1) (one_dvd L)
+  rwa [jqNModC_one] at h
+
+theorem fullC_mono {L L' : ℕ} (h : L ∣ L') : fullC K L ≤ fullC K L' :=
+  IntermediateField.adjoin.mono K _ _ (divSet_mono h)
+
+theorem fullC_le_iff {L : ℕ} {F : IntermediateField K (LaurentSeries K)} :
+    fullC K L ≤ F ↔ ∀ (d : ℕ) [NeZero d], d ∣ L → jqNModC K d ∈ F := by
+  rw [fullC, IntermediateField.adjoin_le_iff]
+  constructor
+  · intro h d _ hd
+    exact h (jqNModC_mem_divSet hd)
+  · rintro h x ⟨d, hd0, hdL, rfl⟩
+    exact h d hdL
+
+theorem jqNModC_injective {d d' : ℕ} [NeZero d] [NeZero d'] (h : jqNModC K d = jqNModC K d') :
+    d = d' := by
+  rw [jqNModC_eq_TS, jqNModC_eq_TS] at h
+  exact (TS_injective h).1
+
+theorem qTwist_jqModC_eq_TS (u : Kˣ) : qTwist u (jqModC K) = TS K 1 u := by
+  rw [TS, qExpand_one_apply]
+
+def qExpandₐK (K : Type*) [Field K] (n : ℕ) [NeZero n] : LaurentSeries K →ₐ[K] LaurentSeries K where
+  __ := qExpand K n
+  commutes' c := by
+    change qExpand K n (algebraMap K (LaurentSeries K) c) = algebraMap K (LaurentSeries K) c
+    rw [HahnSeries.algebraMap_apply']
+    simp
+
+@[scoped simp] theorem qExpandₐK_apply (n : ℕ) [NeZero n] (f : LaurentSeries K) :
+    qExpandₐK K n f = qExpand K n f := rfl
+
+theorem qExpandₐK_jqNModC (n d : ℕ) [NeZero n] [NeZero d] :
+    qExpandₐK K n (jqNModC K d) = jqNModC K (n * d) := by
+  rw [qExpandₐK_apply, jqNModC, jqNModC, qExpand_qExpand]
+
+def eFull (K : Type*) [Field K] (n : ℕ) [NeZero n] (L : ℕ) :
+    IntermediateField K (LaurentSeries K) :=
+  IntermediateField.adjoin K ((qExpandₐK K n) '' divSet K L)
+
+theorem eFull_eq_map (n : ℕ) [NeZero n] (L : ℕ) :
+    eFull K n L = (fullC K L).map (qExpandₐK K n) := by
+  rw [eFull, fullC, IntermediateField.adjoin_map]
+
+theorem eFull_mono (n : ℕ) [NeZero n] {L L' : ℕ} (h : L ∣ L') : eFull K n L ≤ eFull K n L' :=
+  IntermediateField.adjoin.mono K _ _ (Set.image_mono (divSet_mono h))
+
+theorem jqNModC_mul_mem_eFull (n : ℕ) [NeZero n] {d L : ℕ} [NeZero d] (hd : d ∣ L) :
+    jqNModC K (n * d) ∈ eFull K n L :=
+  IntermediateField.subset_adjoin K _ ⟨jqNModC K d, jqNModC_mem_divSet hd, qExpandₐK_jqNModC n d⟩
+
+theorem exists_eq_qExpand_of_mem_eFull (n : ℕ) [NeZero n] {L : ℕ} {x : LaurentSeries K}
+    (hx : x ∈ eFull K n L) :
+    ∃ y : LaurentSeries K, qExpand K n y = x := by
+  rw [eFull_eq_map, IntermediateField.mem_map] at hx
+  obtain ⟨y, -, hy⟩ := hx
+  exact ⟨y, hy⟩
+
+theorem qTwist_eq_self_of_mem_eFull (n : ℕ) [NeZero n] {L : ℕ} {v : Kˣ} (hv : v ^ n = 1)
+    {x : LaurentSeries K}
+    (hx : x ∈ eFull K n L) : qTwist v x = x := by
+  obtain ⟨y, rfl⟩ := exists_eq_qExpand_of_mem_eFull n hx
+  exact qTwist_qExpand_of_pow_eq_one n v hv y
+
+theorem eFull_le_fullC (n : ℕ) [NeZero n] (L : ℕ) : eFull K n L ≤ fullC K (L * n) := by
+  rw [eFull, IntermediateField.adjoin_le_iff]
+  rintro x ⟨y, ⟨d, hd0, hdL, rfl⟩, rfl⟩
+  rw [qExpandₐK_jqNModC]
+  have h : d * n ∣ L * n := mul_dvd_mul_right hdL n
+  rw [Nat.mul_comm d n] at h
+  exact jqNModC_mem_fullC h
+
+theorem mem_adjoin_of_mem {E : IntermediateField K (LaurentSeries K)} {x : LaurentSeries K}
+    (hx : x ∈ E)
+    (T : Set (LaurentSeries K)) : x ∈ IntermediateField.adjoin E T :=
+  (IntermediateField.adjoin E T).algebraMap_mem ⟨x, hx⟩
+
+theorem relfinrank_adjoin_insert (T : Set (LaurentSeries K)) (α : LaurentSeries K) :
+    IntermediateField.relfinrank (IntermediateField.adjoin K T) (IntermediateField.adjoin K (insert
+      α T))
+      = Module.finrank (IntermediateField.adjoin K T)
+          (IntermediateField.adjoin (IntermediateField.adjoin K T) ({α} : Set (LaurentSeries K)))
+            := by
+  have h : IntermediateField.adjoin K T ≤ IntermediateField.adjoin K (insert α T) :=
+    IntermediateField.adjoin.mono _ _ _ (Set.subset_insert α T)
+  have hEq : IntermediateField.adjoin (IntermediateField.adjoin K T) (insert α T)
+      = IntermediateField.adjoin (IntermediateField.adjoin K T) ({α} : Set (LaurentSeries K)) := by
+    refine le_antisymm ?_ ?_
+    · rw [IntermediateField.adjoin_le_iff]
+      rintro x (rfl | hxT)
+      · exact IntermediateField.subset_adjoin _ _ rfl
+      · exact mem_adjoin_of_mem (IntermediateField.subset_adjoin K T hxT) _
+    · exact IntermediateField.adjoin.mono _ _ _ (Set.singleton_subset_iff.mpr (Set.mem_insert α T))
+  rw [IntermediateField.relfinrank_eq_finrank_of_le h, IntermediateField.extendScalars_adjoin h,
+    hEq]
+
+theorem relfinrank_adjoin_insert_eq_natDegree (T : Set (LaurentSeries K)) {α : LaurentSeries K}
+    (hα : IsIntegral (IntermediateField.adjoin K T) α) :
+    IntermediateField.relfinrank (IntermediateField.adjoin K T) (IntermediateField.adjoin K (insert
+      α T))
+      = (minpoly (IntermediateField.adjoin K T) α).natDegree := by
+  rw [relfinrank_adjoin_insert, IntermediateField.adjoin.finrank hα]
+
+theorem relfinrank_fullC_insert_eq_natDegree (L : ℕ) {α : LaurentSeries K}
+    (hα : IsIntegral (fullC K L) α) :
+    IntermediateField.relfinrank (fullC K L) (IntermediateField.adjoin K (insert α (divSet K L)))
+      = (minpoly (fullC K L) α).natDegree :=
+  relfinrank_adjoin_insert_eq_natDegree (divSet K L) hα
+
+theorem relfinrank_eFull_insert_eq_natDegree (n : ℕ) [NeZero n] (L : ℕ) {α : LaurentSeries K}
+    (hα : IsIntegral (eFull K n L) α) :
+    IntermediateField.relfinrank (eFull K n L) (IntermediateField.adjoin K (insert α ((qExpandₐK K
+      n) '' divSet K L)))
+      = (minpoly (eFull K n L) α).natDegree :=
+  relfinrank_adjoin_insert_eq_natDegree _ hα
+
+section packetBounds
+
+variable {F : IntermediateField K (LaurentSeries K)} {p : ℕ} [NeZero p]
+
+theorem phiAtSeed_map_algebraMap (data : ModularPolynomialData p) {s : LaurentSeries K} (hs : s ∈ F)
+    :
+    (phiAtSeed data (⟨s, hs⟩ : F)).map (algebraMap F (LaurentSeries K)) = phiAtSeed data s := by
+  rw [phiAtSeed_map]; rfl
+
+theorem aeval_phiAtSeed_eq_zero (data : ModularPolynomialData p) {s : LaurentSeries K} (hs : s ∈ F)
+    {t : LaurentSeries K} (ht : (phiAtSeed data s).eval t = 0) :
+    Polynomial.aeval t (phiAtSeed data (⟨s, hs⟩ : F)) = 0 := by
+  rw [← Polynomial.eval_map_algebraMap, phiAtSeed_map_algebraMap]
+  exact ht
+
+theorem isIntegral_of_phiAtSeed_root (data : ModularPolynomialData p) {s : LaurentSeries K}
+    (hs : s ∈ F)
+    {t : LaurentSeries K} (ht : (phiAtSeed data s).eval t = 0) : IsIntegral F t :=
+  ⟨phiAtSeed data (⟨s, hs⟩ : F), phiAtSeed_monic data _, by
+    rw [← Polynomial.aeval_def]; exact aeval_phiAtSeed_eq_zero data hs ht⟩
+
+theorem natDegree_minpoly_le_dedekindPsi_of_phiAtSeed_root (data : ModularPolynomialData p)
+    {s : LaurentSeries K}
+    (hs : s ∈ F) {t : LaurentSeries K} (ht : (phiAtSeed data s).eval t = 0) :
+    (minpoly F t).natDegree ≤ dedekindPsi p := by
+  have h := minpoly.degree_le_of_ne_zero F t (phiAtSeed_monic data (⟨s, hs⟩ : F)).ne_zero
+    (aeval_phiAtSeed_eq_zero data hs ht)
+  have h2 := Polynomial.natDegree_le_natDegree h
+  rwa [phiAtSeed_natDegree] at h2
+
+theorem natDegree_minpoly_le_of_phiAtSeed_root_of_root_mem (data : ModularPolynomialData p)
+    {s : LaurentSeries K}
+    (hs : s ∈ F) {r : LaurentSeries K} (hr : r ∈ F) (hrroot : (phiAtSeed data s).eval r = 0)
+    {t : LaurentSeries K} (ht : (phiAtSeed data s).eval t = 0) (htr : t ≠ r) :
+    (minpoly F t).natDegree ≤ dedekindPsi p - 1 := by
+  set P : Polynomial F := phiAtSeed data (⟨s, hs⟩ : F) with hPdef
+  set rF : F := ⟨r, hr⟩ with hrF
+  have hPr : P.IsRoot rF := by
+    rw [Polynomial.IsRoot.def]
+    apply (algebraMap F (LaurentSeries K)).injective
+    rw [map_zero, ← Polynomial.eval₂_at_apply, ← Polynomial.eval_map, hPdef,
+      phiAtSeed_map_algebraMap]
+    exact hrroot
+  set Q : Polynomial F := P /ₘ (Polynomial.X - Polynomial.C rF) with hQdef
+  have hPQ : (Polynomial.X - Polynomial.C rF) * Q = P :=
+    Polynomial.mul_divByMonic_eq_iff_isRoot.mpr hPr
+  have hQne : Q ≠ 0 := by
+    intro h0
+    have hP0 : P ≠ 0 := (phiAtSeed_monic data (⟨s, hs⟩ : F)).ne_zero
+    rw [← hPQ, h0, mul_zero] at hP0
+    exact hP0 rfl
+  have hQdeg : Q.natDegree = dedekindPsi p - 1 := by
+    rw [hQdef, Polynomial.natDegree_divByMonic _ (Polynomial.monic_X_sub_C rF),
+      Polynomial.natDegree_X_sub_C,
+      hPdef, phiAtSeed_natDegree]
+  have htP : Polynomial.aeval t P = 0 := aeval_phiAtSeed_eq_zero data hs ht
+  have htQ : Polynomial.aeval t Q = 0 := by
+    rw [← hPQ, map_mul, map_sub, Polynomial.aeval_X, Polynomial.aeval_C] at htP
+    rcases mul_eq_zero.mp htP with h1 | h1
+    · exfalso
+      exact htr (sub_eq_zero.mp h1)
+    · exact h1
+  have h := Polynomial.natDegree_le_natDegree (minpoly.degree_le_of_ne_zero F t hQne htQ)
+  rwa [hQdeg] at h
+
+end packetBounds
+
+theorem jqNModC_mem_of_div_primes {N : ℕ} [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    {F : IntermediateField K (LaurentSeries K)} {d : ℕ} [NeZero d] (hdN : d ∣ N)
+    {p q : ℕ} (pp : Nat.Prime p) (qq : Nat.Prime q) (hpq : p ≠ q) (hpd : p ∣ d) (hqd : q ∣ d)
+    [NeZero (d / p)] [NeZero (d / q)] (hmp : jqNModC K (d / p) ∈ F) (hmq : jqNModC K (d / q) ∈ F) :
+    jqNModC K d ∈ F := by
+  have : Fact (Nat.Prime p) := ⟨pp⟩
+  have : Fact (Nat.Prime q) := ⟨qq⟩
+  have : NeZero p := ⟨pp.ne_zero⟩
+  have : NeZero q := ⟨qq.ne_zero⟩
+  have hpN : p ∣ N := hpd.trans hdN
+  have hqN : q ∣ N := hqd.trans hdN
+  have hNp0 : N / p ≠ 0 := fun h0 => NeZero.ne N (by rw [← Nat.div_mul_cancel hpN, h0, zero_mul])
+  have hNq0 : N / q ≠ 0 := fun h0 => NeZero.ne N (by rw [← Nat.div_mul_cancel hqN, h0, zero_mul])
+  have : NeZero (N / p) := ⟨hNp0⟩
+  have : NeZero (N / q) := ⟨hNq0⟩
+  have hζp := isPrimitiveRoot_pow_div hζ hpN
+  have hζq := isPrimitiveRoot_pow_div hζ hqN
+  have hpe : p * (N / p * (d / p)) = N * (d / p) := by
+    rw [← mul_assoc, Nat.mul_div_cancel' hpN]
+  have hqe : q * (N / q * (d / q)) = N * (d / q) := by
+    rw [← mul_assoc, Nat.mul_div_cancel' hqN]
+  have hpe2 : p * (p * (N / p * (d / p))) = N * d := by
+    rw [hpe, mul_left_comm, Nat.mul_div_cancel' hpd]
+  have hqe2 : q * (q * (N / q * (d / q))) = N * d := by
+    rw [hqe, mul_left_comm, Nat.mul_div_cancel' hqd]
+  have data_p : ModularPolynomialData p := (ModularCurve.exists_phiIrreducible_evalSymm p).choose
+  have data_q : ModularPolynomialData q := (ModularCurve.exists_phiIrreducible_evalSymm q).choose
+  let : Algebra F (LaurentSeries K) :=
+    ((qExpand K N).comp (algebraMap F (LaurentSeries K))).toAlgebra
+  have hmapA : (phiAtSeed data_p (⟨jqNModC K (d / p), hmp⟩ : F)).map (algebraMap F (LaurentSeries
+    K))
+      = phiAtSeed data_p (qExpand K N (jqNModC K (d / p))) :=
+    phiAtSeed_map data_p _ _
+  have hmapB : (phiAtSeed data_q (⟨jqNModC K (d / q), hmq⟩ : F)).map (algebraMap F (LaurentSeries
+    K))
+      = phiAtSeed data_q (qExpand K N (jqNModC K (d / q))) :=
+    phiAtSeed_map data_q _ _
+  have hseed_p : qExpand K N (jqNModC K (d / p))
+      = qExpand K (p * (N / p * (d / p))) (qTwist ((1 : Kˣ) ^ p) (jqModC K)) := by
+    have h2 : TS K (N * (d / p)) 1 = TS K (p * (N / p * (d / p))) ((1 : Kˣ) ^ p) := by
+      rw [one_pow]
+      exact TS_congr hpe.symm 1
+    exact (qExpand_jqNModC N (d / p)).trans h2
+  have hseed_q : qExpand K N (jqNModC K (d / q))
+      = qExpand K (q * (N / q * (d / q))) (qTwist ((1 : Kˣ) ^ q) (jqModC K)) := by
+    have h2 : TS K (N * (d / q)) 1 = TS K (q * (N / q * (d / q))) ((1 : Kˣ) ^ q) := by
+      rw [one_pow]
+      exact TS_congr hqe.symm 1
+    exact (qExpand_jqNModC N (d / q)).trans h2
+  have hdist_p : qExpand K N (jqNModC K d)
+      = qExpand K (p * (p * (N / p * (d / p)))) (qTwist ((1 : Kˣ) ^ (p * p)) (jqModC K)) := by
+    have h2 : TS K (N * d) 1 = TS K (p * (p * (N / p * (d / p)))) ((1 : Kˣ) ^ (p * p)) := by
+      rw [one_pow]
+      exact TS_congr hpe2.symm 1
+    exact (qExpand_jqNModC N d).trans h2
+  have hdist_q : qExpand K N (jqNModC K d)
+      = qExpand K (q * (q * (N / q * (d / q)))) (qTwist ((1 : Kˣ) ^ (q * q)) (jqModC K)) := by
+    have h2 : TS K (N * d) 1 = TS K (q * (q * (N / q * (d / q)))) ((1 : Kˣ) ^ (q * q)) := by
+      rw [one_pow]
+      exact TS_congr hqe2.symm 1
+    exact (qExpand_jqNModC N d).trans h2
+  have hrootA : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_p (⟨jqNModC K (d / p), hmp⟩ : F)) = 0 ↔
+        (y = qExpand K (p * (p * (N / p * (d / p)))) (qTwist ((1 : Kˣ) ^ (p * p)) (jqModC K)) ∨
+          ∃ b < p, y = qExpand K (N / p * (d / p)) (qTwist (1 * (ζ ^ (N / p)) ^ b) (jqModC K)))
+            := by
+    intro y
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hmapA, hseed_p]
+    exact isRoot_prime_at_slot_iff p (ζ ^ (N / p)) hζp data_p (N / p * (d / p)) 1 y
+  have hrootB : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_q (⟨jqNModC K (d / q), hmq⟩ : F)) = 0 ↔
+        (y = qExpand K (q * (q * (N / q * (d / q)))) (qTwist ((1 : Kˣ) ^ (q * q)) (jqModC K)) ∨
+          ∃ c < q, y = qExpand K (N / q * (d / q)) (qTwist (1 * (ζ ^ (N / q)) ^ c) (jqModC K)))
+            := by
+    intro y
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hmapB, hseed_q]
+    exact isRoot_prime_at_slot_iff q (ζ ^ (N / q)) hζq data_q (N / q * (d / q)) 1 y
+  have hA0 : phiAtSeed data_p (⟨jqNModC K (d / p), hmp⟩ : F) ≠ 0 :=
+    (phiAtSeed_monic data_p _).ne_zero
+  have hAs : ((phiAtSeed data_p (⟨jqNModC K (d / p), hmp⟩ : F)).map (algebraMap F (LaurentSeries
+    K))).Splits :=
+    by
+    rw [hmapA, hseed_p, phiAtSeed,
+      ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot p (ζ ^ (N / p)) hζp data_p (N / p
+      * (d / p)) 1]
+    exact (Polynomial.Splits.X_sub_C _).mul (Polynomial.Splits.prod fun b _ =>
+      Polynomial.Splits.X_sub_C _)
+  have hAnd : ((phiAtSeed data_p (⟨jqNModC K (d / p), hmp⟩ : F)).map (algebraMap F (LaurentSeries
+    K))).roots.Nodup :=
+    by
+    rw [hmapA, hseed_p, phiAtSeed]
+    exact roots_prime_at_slot_roots_nodup p (ζ ^ (N / p)) hζp data_p (N / p * (d / p)) 1
+  have hxA : Polynomial.aeval (qExpand K N (jqNModC K d)) (phiAtSeed data_p (⟨jqNModC K (d / p),
+    hmp⟩ : F)) = 0 :=
+    (hrootA _).mpr (Or.inl hdist_p)
+  have hxB : Polynomial.aeval (qExpand K N (jqNModC K d)) (phiAtSeed data_q (⟨jqNModC K (d / q),
+    hmq⟩ : F)) = 0 :=
+    (hrootB _).mpr (Or.inl hdist_q)
+  have huniq : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_p (⟨jqNModC K (d / p), hmp⟩ : F)) = 0 →
+      Polynomial.aeval y (phiAtSeed data_q (⟨jqNModC K (d / q), hmq⟩ : F)) = 0 →
+      y = qExpand K N (jqNModC K d) := by
+    intro y hyA hyB
+    rcases (hrootA y).mp hyA with hy1 | ⟨b, _, hy1⟩
+    · exact hy1.trans hdist_p.symm
+    · rcases (hrootB y).mp hyB with hy2 | ⟨c, _, hy2⟩
+      · exact hy2.trans hdist_q.symm
+      · exfalso
+        have hTS : TS K (N / p * (d / p)) (1 * (ζ ^ (N / p)) ^ b)
+            = TS K (N / q * (d / q)) (1 * (ζ ^ (N / q)) ^ c) := hy1.symm.trans hy2
+        have he : N / p * (d / p) = N / q * (d / q) := (TS_injective hTS).1
+        have h1 : p * p * (N / p * (d / p)) = q * q * (N / p * (d / p)) := by
+          rw [mul_assoc, hpe2, mul_assoc, he, hqe2]
+        have h2 : p * p = q * q :=
+          Nat.eq_of_mul_eq_mul_right (Nat.pos_of_ne_zero (NeZero.ne (N / p * (d / p)))) h1
+        have h3 : q ∣ p * p := by rw [h2]; exact dvd_mul_right q q
+        have h4 : q ∣ p := ((Nat.Prime.dvd_mul qq).mp h3).elim id id
+        exact hpq (((Nat.prime_dvd_prime_iff_eq qq pp).mp h4).symm)
+  have hrange := Polynomial.mem_range_of_unique_common_root
+    (phiAtSeed data_p (⟨jqNModC K (d / p), hmp⟩ : F)) (phiAtSeed data_q (⟨jqNModC K (d / q), hmq⟩ :
+      F))
+    hA0 hAs hAnd (qExpand K N (jqNModC K d)) hxA hxB huniq
+  obtain ⟨f, hf⟩ := RingHom.mem_range.mp hrange
+  have hf' : qExpand K N (f : LaurentSeries K) = qExpand K N (jqNModC K d) := hf
+  have hval : (f : LaurentSeries K) = jqNModC K d := qExpand_injective N hf'
+  rw [← hval]
+  exact f.2
+
+theorem jqNModC_mem_of_div_prime_of_mul_prime {N : ℕ} [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N)
+    {F : IntermediateField K (LaurentSeries K)} {d : ℕ} [NeZero d]
+    {l p : ℕ} (ll : Nat.Prime l) (pp : Nat.Prime p) (hlN : l ∣ N) (hpN : p ∣ N) (hld : l ∣ d)
+    [NeZero (d / l)] [NeZero (p * d)] (hml : jqNModC K (d / l) ∈ F) (hmp : jqNModC K (p * d) ∈ F) :
+    jqNModC K d ∈ F := by
+  have : Fact (Nat.Prime l) := ⟨ll⟩
+  have : Fact (Nat.Prime p) := ⟨pp⟩
+  have : NeZero l := ⟨ll.ne_zero⟩
+  have : NeZero p := ⟨pp.ne_zero⟩
+  have hNl0 : N / l ≠ 0 := fun h0 => NeZero.ne N (by rw [← Nat.div_mul_cancel hlN, h0, zero_mul])
+  have : NeZero (N / l) := ⟨hNl0⟩
+  have hζl := isPrimitiveRoot_pow_div hζ hlN
+  have hζp := isPrimitiveRoot_pow_div hζ hpN
+  have hle : l * (N / l * (d / l)) = N * (d / l) := by
+    rw [← mul_assoc, Nat.mul_div_cancel' hlN]
+  have hle2 : l * (l * (N / l * (d / l))) = N * d := by
+    rw [hle, mul_left_comm, Nat.mul_div_cancel' hld]
+  have hpe : N * (p * d) = p * (N * d) := Nat.mul_left_comm N p d
+  have data_l : ModularPolynomialData l := (ModularCurve.exists_phiIrreducible_evalSymm l).choose
+  have data_p : ModularPolynomialData p := (ModularCurve.exists_phiIrreducible_evalSymm p).choose
+  let : Algebra F (LaurentSeries K) :=
+    ((qExpand K N).comp (algebraMap F (LaurentSeries K))).toAlgebra
+  have hmapA : (phiAtSeed data_l (⟨jqNModC K (d / l), hml⟩ : F)).map (algebraMap F (LaurentSeries
+    K))
+      = phiAtSeed data_l (qExpand K N (jqNModC K (d / l))) :=
+    phiAtSeed_map data_l _ _
+  have hmapB : (phiAtSeed data_p (⟨jqNModC K (p * d), hmp⟩ : F)).map (algebraMap F (LaurentSeries
+    K))
+      = phiAtSeed data_p (qExpand K N (jqNModC K (p * d))) :=
+    phiAtSeed_map data_p _ _
+  have hseed_l : qExpand K N (jqNModC K (d / l))
+      = qExpand K (l * (N / l * (d / l))) (qTwist ((1 : Kˣ) ^ l) (jqModC K)) := by
+    have h2 : TS K (N * (d / l)) 1 = TS K (l * (N / l * (d / l))) ((1 : Kˣ) ^ l) := by
+      rw [one_pow]
+      exact TS_congr hle.symm 1
+    exact (qExpand_jqNModC N (d / l)).trans h2
+  have hseed_p : qExpand K N (jqNModC K (p * d)) = qExpand K (p * (N * d)) (qTwist ((1 : Kˣ) ^ p)
+    (jqModC K)) :=
+    by
+    have h2 : TS K (N * (p * d)) 1 = TS K (p * (N * d)) ((1 : Kˣ) ^ p) := by
+      rw [one_pow]
+      exact TS_congr hpe 1
+    exact (qExpand_jqNModC N (p * d)).trans h2
+  have hdist_l : qExpand K N (jqNModC K d)
+      = qExpand K (l * (l * (N / l * (d / l)))) (qTwist ((1 : Kˣ) ^ (l * l)) (jqModC K)) := by
+    have h2 : TS K (N * d) 1 = TS K (l * (l * (N / l * (d / l)))) ((1 : Kˣ) ^ (l * l)) := by
+      rw [one_pow]
+      exact TS_congr hle2.symm 1
+    exact (qExpand_jqNModC N d).trans h2
+  have hdist_p : qExpand K N (jqNModC K d) = qExpand K (N * d) (qTwist (1 * (ζ ^ (N / p)) ^ 0)
+    (jqModC K)) :=
+    by
+    rw [pow_zero, mul_one]
+    exact qExpand_jqNModC N d
+  have hrootA : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_l (⟨jqNModC K (d / l), hml⟩ : F)) = 0 ↔
+        (y = qExpand K (l * (l * (N / l * (d / l)))) (qTwist ((1 : Kˣ) ^ (l * l)) (jqModC K)) ∨
+          ∃ b < l, y = qExpand K (N / l * (d / l)) (qTwist (1 * (ζ ^ (N / l)) ^ b) (jqModC K)))
+            := by
+    intro y
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hmapA, hseed_l]
+    exact isRoot_prime_at_slot_iff l (ζ ^ (N / l)) hζl data_l (N / l * (d / l)) 1 y
+  have hrootB : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_p (⟨jqNModC K (p * d), hmp⟩ : F)) = 0 ↔
+        (y = qExpand K (p * (p * (N * d))) (qTwist ((1 : Kˣ) ^ (p * p)) (jqModC K)) ∨
+          ∃ c < p, y = qExpand K (N * d) (qTwist (1 * (ζ ^ (N / p)) ^ c) (jqModC K))) := by
+    intro y
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hmapB, hseed_p]
+    exact isRoot_prime_at_slot_iff p (ζ ^ (N / p)) hζp data_p (N * d) 1 y
+  have hA0 : phiAtSeed data_l (⟨jqNModC K (d / l), hml⟩ : F) ≠ 0 :=
+    (phiAtSeed_monic data_l _).ne_zero
+  have hAs : ((phiAtSeed data_l (⟨jqNModC K (d / l), hml⟩ : F)).map (algebraMap F (LaurentSeries
+    K))).Splits :=
+    by
+    rw [hmapA, hseed_l, phiAtSeed,
+      ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot l (ζ ^ (N / l)) hζl data_l (N / l
+      * (d / l)) 1]
+    exact (Polynomial.Splits.X_sub_C _).mul (Polynomial.Splits.prod fun b _ =>
+      Polynomial.Splits.X_sub_C _)
+  have hAnd : ((phiAtSeed data_l (⟨jqNModC K (d / l), hml⟩ : F)).map (algebraMap F (LaurentSeries
+    K))).roots.Nodup :=
+    by
+    rw [hmapA, hseed_l, phiAtSeed]
+    exact roots_prime_at_slot_roots_nodup l (ζ ^ (N / l)) hζl data_l (N / l * (d / l)) 1
+  have hxA : Polynomial.aeval (qExpand K N (jqNModC K d)) (phiAtSeed data_l (⟨jqNModC K (d / l),
+    hml⟩ : F)) = 0 :=
+    (hrootA _).mpr (Or.inl hdist_l)
+  have hxB : Polynomial.aeval (qExpand K N (jqNModC K d)) (phiAtSeed data_p (⟨jqNModC K (p * d),
+    hmp⟩ : F)) = 0 :=
+    (hrootB _).mpr (Or.inr ⟨0, pp.pos, hdist_p⟩)
+  have he0 : 0 < N / l * (d / l) := Nat.pos_of_ne_zero (NeZero.ne _)
+  set e₁ := N / l * (d / l) with he₁
+  have hl2 : 2 ≤ l := ll.two_le
+  have hp2 : 2 ≤ p := pp.two_le
+  have hbig1 : 2 * (2 * e₁) ≤ l * (l * e₁) := Nat.mul_le_mul hl2 (Nat.mul_le_mul hl2 le_rfl)
+  have hbig2 : 2 * (2 * (l * (l * e₁))) ≤ p * (p * (l * (l * e₁))) :=
+    Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+  have huniq : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_l (⟨jqNModC K (d / l), hml⟩ : F)) = 0 →
+      Polynomial.aeval y (phiAtSeed data_p (⟨jqNModC K (p * d), hmp⟩ : F)) = 0 →
+      y = qExpand K N (jqNModC K d) := by
+    intro y hyA hyB
+    rcases (hrootA y).mp hyA with hy1 | ⟨b, _, hy1⟩
+    · exact hy1.trans hdist_l.symm
+    · exfalso
+      rcases (hrootB y).mp hyB with hy2 | ⟨c, _, hy2⟩
+      · have hTS : TS K e₁ (1 * (ζ ^ (N / l)) ^ b) = TS K (p * (p * (N * d))) ((1 : Kˣ) ^ (p * p))
+          :=
+          hy1.symm.trans hy2
+        have he : e₁ = p * (p * (N * d)) := (TS_injective hTS).1
+        rw [← hle2] at he
+        omega
+      · have hTS : TS K e₁ (1 * (ζ ^ (N / l)) ^ b) = TS K (N * d) (1 * (ζ ^ (N / p)) ^ c) :=
+          hy1.symm.trans hy2
+        have he : e₁ = N * d := (TS_injective hTS).1
+        rw [← hle2] at he
+        omega
+  have hrange := Polynomial.mem_range_of_unique_common_root
+    (phiAtSeed data_l (⟨jqNModC K (d / l), hml⟩ : F)) (phiAtSeed data_p (⟨jqNModC K (p * d), hmp⟩ :
+      F))
+    hA0 hAs hAnd (qExpand K N (jqNModC K d)) hxA hxB huniq
+  obtain ⟨f, hf⟩ := RingHom.mem_range.mp hrange
+  have hf' : qExpand K N (f : LaurentSeries K) = qExpand K N (jqNModC K d) := hf
+  have hval : (f : LaurentSeries K) = jqNModC K d := qExpand_injective N hf'
+  rw [← hval]
+  exact f.2
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData coeffMap \
+  coeffMap_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm jqModC \
+  jqNModC jqNModC_one map_jqModC modularFunctionFieldC jqModC_mem jqNModC_mem coeffMap_qExpand \
+  coeff_jqModC_neg_one order_jqModC PhiGen.splits_prime_at_slot_of_isPrimitiveRoot \
+  exists_phiIrreducible_evalSymm dedekindPsi_prime_pow dedekindPsi_mul_of_coprime \
+  relfinrank_fullC_mul_prime_pow jqNModC_prime_not_mem_fullC \
+  jqNModC_mem_modularFunctionFieldC_mul_prime"
+namespace W1
+p2m_open "ModularCurve"
+
+variable {K : Type*} [Field K]
+
+abbrev Pkg (K : Type*) [Field K] (M : ℕ) : Prop :=
+  ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+    Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+        (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+          ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d
+      ∧ modularFunctionFieldC K d = IntermediateField.adjoin K
+          {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ d ∧ x = jqNModC K d'}
+
+private theorem mffC_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) :
+    modularFunctionFieldC K n = modularFunctionFieldC K m := by
+  subst h; rfl
+
+private theorem fullC_congr' {n m : ℕ} (h : n = m) : fullC K n = fullC K m := by
+  subst h; rfl
+
+private theorem adjoin_jqModC_le_fullC (M : ℕ) :
+    IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) ≤ fullC K M :=
+  IntermediateField.adjoin_le_iff.mpr (Set.singleton_subset_iff.mpr (jqModC_mem_fullC M))
+
+private theorem fullC_one :
+    fullC K 1 = IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)) := by
+  refine le_antisymm ?_ (adjoin_jqModC_le_fullC 1)
+  rw [fullC_le_iff]
+  intro e _ he
+  rw [Nat.dvd_one] at he
+  subst he
+  rw [jqNModC_one]
+  exact IntermediateField.subset_adjoin K _ rfl
+
+theorem tight_iff_relfinrank_fullC (m : ℕ) [NeZero m] (hgen : modularFunctionFieldC K m = fullC K m)
+    :
+    (Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+        (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+          ({jqNModC K m} : Set (LaurentSeries K))) = dedekindPsi m)
+      ↔ IntermediateField.relfinrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries
+        K))) (fullC K m)
+          = dedekindPsi m := by
+  rw [← hgen, modularFunctionFieldC, Set.pair_comm, relfinrank_adjoin_insert]
+
+theorem mffC_eq_fullC_of_steps (d : ℕ) [NeZero d]
+    (hstep : ∀ (M : ℕ) [NeZero M] (q : ℕ), q.Prime → M * q = d → jqNModC K M ∈ modularFunctionFieldC
+      K d)
+    (hgen' : ∀ (M : ℕ) [NeZero M] (q : ℕ), q.Prime → M * q = d → modularFunctionFieldC K M = fullC K
+      M) :
+    modularFunctionFieldC K d = fullC K d := by
+  refine le_antisymm ?_ ?_
+  · rw [modularFunctionFieldC, IntermediateField.adjoin_le_iff]
+    rintro _ (rfl | rfl)
+    · exact jqModC_mem_fullC d
+    · exact jqNModC_mem_fullC dvd_rfl
+  · rw [fullC_le_iff]
+    intro e _ heD
+    rcases eq_or_ne e d with rfl | hne
+    · exact jqNModC_mem K _
+    · obtain ⟨m, hm⟩ := heD
+      have hm1 : m ≠ 1 := fun h1 => hne (by rw [hm, h1, Nat.mul_one])
+      have hm0 : m ≠ 0 := fun h0 => NeZero.ne d (by rw [hm, h0, Nat.mul_zero])
+      have hq : m.minFac.Prime := Nat.minFac_prime hm1
+      obtain ⟨m', hm'⟩ := (Nat.minFac_dvd m : m.minFac ∣ m)
+      have hm'0 : m' ≠ 0 := fun h0 => hm0 (by rw [hm', h0, Nat.mul_zero])
+      have : NeZero (e * m') := ⟨Nat.mul_ne_zero (NeZero.ne e) hm'0⟩
+      have hprod : e * m' * m.minFac = d := by
+        rw [Nat.mul_assoc, Nat.mul_comm m' m.minFac, ← hm', ← hm]
+      have hmemM : jqNModC K (e * m') ∈ modularFunctionFieldC K d :=
+        hstep (e * m') m.minFac hq hprod
+      have hfull : modularFunctionFieldC K (e * m') = fullC K (e * m') :=
+        hgen' (e * m') m.minFac hq hprod
+      have hle : modularFunctionFieldC K (e * m') ≤ modularFunctionFieldC K d := by
+        rw [modularFunctionFieldC, IntermediateField.adjoin_le_iff]
+        rintro _ (rfl | rfl)
+        · exact jqModC_mem K d
+        · exact hmemM
+      refine hle ?_
+      rw [hfull]
+      exact jqNModC_mem_fullC (dvd_mul_right e m')
+
+theorem relfinrank_fullC_prime_pow_tower (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (a : ℕ) (hpM : ¬ p ∣ M)
+    (ξ : Kˣ) (hξ : IsPrimitiveRoot (ξ : K) (M * p ^ (a + 1))) (hnm : jqNModC K p ∉ fullC K M) :
+    IntermediateField.relfinrank (fullC K M) (fullC K (M * p ^ (a + 1))) = (p + 1) * p ^ a := by
+  have hstep : ∀ i, i ≤ a →
+      IntermediateField.relfinrank (fullC K (M * p ^ i)) (fullC K (M * p ^ (i + 1))) = if i = 0 then
+        p + 1 else p := by
+    intro i
+    induction i with
+    | zero =>
+      intro _
+      have hξ0 : IsPrimitiveRoot ((ξ ^ (M * p ^ (a + 1) / (M * p ^ (0 + 1))) : Kˣ) : K) (M * p ^ (0
+        + 1)) :=
+        isPrimitiveRoot_pow_div hξ (mul_dvd_mul_left M (pow_dvd_pow p (by omega)))
+      have h := ModularCurve.relfinrank_fullC_mul_prime_pow M p 0 hpM _ hξ0
+        (fun b hb => absurd hb (Nat.succ_ne_zero b).symm) (fun _ => hnm)
+      exact h
+    | succ i ihi =>
+      intro hi
+      have hξi : IsPrimitiveRoot ((ξ ^ (M * p ^ (a + 1) / (M * p ^ (i + 1 + 1))) : Kˣ) : K) (M * p ^
+        (i + 1 + 1)) :=
+        isPrimitiveRoot_pow_div hξ (mul_dvd_mul_left M (pow_dvd_pow p (by omega)))
+      have h := ModularCurve.relfinrank_fullC_mul_prime_pow M p (i + 1) hpM _ hξi
+        (fun b hb => by
+          obtain rfl : b = i := by omega
+          exact ihi (by omega))
+        (fun h0 => absurd h0 (Nat.succ_ne_zero i))
+      exact h
+  have hprod : ∀ i, i ≤ a →
+      IntermediateField.relfinrank (fullC K M) (fullC K (M * p ^ (i + 1))) = (p + 1) * p ^ i := by
+    intro i
+    induction i with
+    | zero =>
+      intro _
+      have h0 := hstep 0 (Nat.zero_le a)
+      rw [ite_eq_left rfl, fullC_congr' (show M * p ^ 0 = M by rw [pow_zero, Nat.mul_one])] at h0
+      rw [h0, pow_zero, Nat.mul_one]
+    | succ i ihi =>
+      intro hi
+      have h1 := hstep (i + 1) hi
+      rw [ite_eq_right (Nat.succ_ne_zero i)] at h1
+      have hle1 : fullC K M ≤ fullC K (M * p ^ (i + 1)) := fullC_mono (Dvd.intro _ rfl)
+      have hle2 : fullC K (M * p ^ (i + 1)) ≤ fullC K (M * p ^ (i + 1 + 1)) :=
+        fullC_mono (mul_dvd_mul_left M (pow_dvd_pow p (Nat.le_succ _)))
+      rw [← IntermediateField.relfinrank_mul_relfinrank hle1 hle2, ihi (Nat.le_of_succ_le hi), h1,
+        pow_succ,
+        Nat.mul_assoc]
+  exact hprod a le_rfl
+
+theorem pkg_of_socket (L : ℕ) [NeZero L] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) L)
+    (hbase : ∀ (p : ℕ) [Fact (Nat.Prime p)], p ∣ L →
+      jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+    (hKG1 : ∀ (M : ℕ) [NeZero M] (q : ℕ) [Fact (Nat.Prime q)] (ξ : Kˣ), IsPrimitiveRoot (ξ : K) (M *
+      q) → Pkg K M →
+      jqNModC K M ∈ modularFunctionFieldC K (M * q)) :
+    Pkg K L := by
+  intro d
+  induction d using Nat.strong_induction_on with
+  | _ d ih =>
+    intro hdL hd0
+    have hLpos : 0 < L := Nat.pos_of_ne_zero (NeZero.ne L)
+    have pkg_lt : ∀ m : ℕ, m < d → m ∣ L → Pkg K m := fun m hm hmL e he _ =>
+      ih e (lt_of_le_of_lt (Nat.le_of_dvd (Nat.pos_of_dvd_of_pos hmL hLpos) he) hm) (he.trans hmL)
+    have hζd : IsPrimitiveRoot ((ζ ^ (L / d) : Kˣ) : K) d := isPrimitiveRoot_pow_div hζ hdL
+    have hgen : modularFunctionFieldC K d = fullC K d := by
+      refine mffC_eq_fullC_of_steps d ?_ ?_
+      · intro M _ q hq hMq
+        have : Fact (Nat.Prime q) := ⟨hq⟩
+        have hMd : M < d := by
+          rw [← hMq]
+          exact lt_mul_of_one_lt_right (Nat.pos_of_ne_zero (NeZero.ne M)) hq.one_lt
+        have hML : M ∣ L := (Dvd.intro q hMq).trans hdL
+        have hξ : IsPrimitiveRoot ((ζ ^ (L / d) : Kˣ) : K) (M * q) := by
+          rw [hMq]
+          exact hζd
+        have h := hKG1 M q _ hξ (pkg_lt M hMd hML)
+        rwa [mffC_congr hMq] at h
+      · intro M _ q hq hMq
+        have hMd : M < d := by
+          rw [← hMq]
+          exact lt_mul_of_one_lt_right (Nat.pos_of_ne_zero (NeZero.ne M)) hq.one_lt
+        have hML : M ∣ L := (Dvd.intro q hMq).trans hdL
+        exact (pkg_lt M hMd hML M dvd_rfl).2
+    refine ⟨?_, hgen⟩
+    rw [tight_iff_relfinrank_fullC d hgen]
+    rcases eq_or_ne d 1 with rfl | hd1
+    · rw [fullC_one, IntermediateField.relfinrank_self, dedekindPsi_one]
+    · obtain ⟨p, hp, hpd⟩ : ∃ p : ℕ, p.Prime ∧ p ∣ d :=
+        ⟨d.minFac, Nat.minFac_prime hd1, Nat.minFac_dvd d⟩
+      have : Fact (Nat.Prime p) := ⟨hp⟩
+      obtain ⟨e, M, hpM, hdeM⟩ := Nat.exists_eq_pow_mul_and_not_dvd (NeZero.ne d) p hp.ne_one
+      have hM0 : M ≠ 0 := fun h0 => NeZero.ne d (by rw [hdeM, h0, Nat.mul_zero])
+      have : NeZero M := ⟨hM0⟩
+      obtain ⟨a, rfl⟩ : ∃ a, e = a + 1 := by
+        rcases e with _ | a
+        · exfalso
+          rw [pow_zero, one_mul] at hdeM
+          exact hpM (hdeM ▸ hpd)
+        · exact ⟨a, rfl⟩
+      have hd' : d = M * p ^ (a + 1) := by rw [hdeM, Nat.mul_comm]
+      subst hd'
+      have hMd : M < M * p ^ (a + 1) :=
+        lt_mul_of_one_lt_right (Nat.pos_of_ne_zero hM0) (Nat.one_lt_pow (Nat.succ_ne_zero a)
+          hp.one_lt)
+      have hML : M ∣ L := (Dvd.intro (p ^ (a + 1)) rfl).trans hdL
+      have pkgM : Pkg K M := pkg_lt M hMd hML
+      obtain ⟨htM, hgM⟩ := pkgM M dvd_rfl
+      have hpL : p ∣ L := hpd.trans hdL
+      have hξp : IsPrimitiveRoot (((ζ ^ (L / (M * p ^ (a + 1)))) ^ (M * p ^ (a + 1) / (M * p)) : Kˣ)
+        : K) (M * p) :=
+        isPrimitiveRoot_pow_div hζd (mul_dvd_mul_left M (dvd_pow_self p (Nat.succ_ne_zero a)))
+      have hnm : jqNModC K p ∉ fullC K M :=
+        ModularCurve.jqNModC_prime_not_mem_fullC M p hpM _ hξp pkgM (hbase p hpL)
+      have htower := relfinrank_fullC_prime_pow_tower M p a hpM _ hζd hnm
+      have hM : IntermediateField.relfinrank (IntermediateField.adjoin K ({jqModC K} : Set
+        (LaurentSeries K))) (fullC K M)
+          = dedekindPsi M :=
+        (tight_iff_relfinrank_fullC M hgM).mp htM
+      have hcop : Nat.Coprime M (p ^ (a + 1)) :=
+        Nat.Coprime.pow_right _ ((Nat.Prime.coprime_iff_not_dvd hp).mpr hpM).symm
+      rw [← IntermediateField.relfinrank_mul_relfinrank (adjoin_jqModC_le_fullC M) (fullC_mono
+        (Dvd.intro (p ^ (a + 1)) rfl)), htower,
+        hM, ModularCurve.dedekindPsi_mul_of_coprime M (p ^ (a + 1)) hcop,
+        ModularCurve.dedekindPsi_prime_pow p (a + 1) hp (Nat.succ_ne_zero a), Nat.add_sub_cancel]
+      ring
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_qExpand dedekindPsi dedekindPsi_one ModularPolynomialData coeffMap \
+  coeffMap_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm jqModC \
+  jqNModC jqNModC_one map_jqModC modularFunctionFieldC jqModC_mem jqNModC_mem coeffMap_qExpand \
+  coeff_jqModC_neg_one order_jqModC PhiGen.splits_prime_at_slot_of_isPrimitiveRoot \
+  exists_phiIrreducible_evalSymm dedekindPsi_prime_pow dedekindPsi_mul_of_coprime \
+  relfinrank_fullC_mul_prime_pow jqNModC_prime_not_mem_fullC \
+  jqNModC_mem_modularFunctionFieldC_mul_prime"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.package_of_socket {K : Type*} [Field K] (M : ℕ) [NeZero M] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) M)
+    (hbase : ∀ (p : ℕ) [Fact (Nat.Prime p)], p ∣ M →
+      jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) :
+    ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+          (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries
+            K)))
+            ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d
+        ∧ modularFunctionFieldC K d = IntermediateField.adjoin K
+            {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ d ∧ x = jqNModC K d'} :=
+  pkg_of_socket M ζ hζ hbase fun (M' : ℕ) [NeZero M'] (q : ℕ) [Fact (Nat.Prime q)] (ξ : Kˣ) hξ hall
+    =>
+    ModularCurve.jqNModC_mem_modularFunctionFieldC_mul_prime M' q ξ hξ hall
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_package_of_socket.ModularCurve
+  ModularCurve.PhiGen in
+theorem solution {K : Type*} [Field K] (M : ℕ) [NeZero M] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) M)
+    (hbase : ∀ (p : ℕ) [Fact (Nat.Prime p)], p ∣ M →
+      jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) :
+    ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+          (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries
+            K)))
+            ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d
+        ∧ modularFunctionFieldC K d = IntermediateField.adjoin K
+            {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ d ∧ x = jqNModC K d'} :=
+  ModularCurve.package_of_socket M ζ hζ hbase
+
+end S_ModularCurve_package_of_socket
+end P2MW
+export P2MW.S_ModularCurve_package_of_socket (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.package_of_socket {K : Type*} [Field K] (M : ℕ) [NeZero M] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) M)
+    (hbase : ∀ (p : ℕ) [Fact (Nat.Prime p)], p ∣ M →
+      jqNModC K p ∉ IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K))) :
+    ∀ d : ℕ, d ∣ M → ∀ [NeZero d],
+      Module.finrank (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries K)))
+          (IntermediateField.adjoin (IntermediateField.adjoin K ({jqModC K} : Set (LaurentSeries
+            K)))
+            ({jqNModC K d} : Set (LaurentSeries K))) = dedekindPsi d
+        ∧ modularFunctionFieldC K d = IntermediateField.adjoin K
+            {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ d ∧ x = jqNModC K d'} :=
+  solution M ζ hζ hbase
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_periodMapOf_apply_eq_periodOf.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_periodMapOf_apply_eq_periodOf.lean
new file mode 100644
index 0000000000..5452d7dbfe
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_periodMapOf_apply_eq_periodOf.lean
@@ -0,0 +1,92 @@
+/-
+Based on Prove2Me node ModularCurve.periodMapOf_apply_eq_periodOf
+(64275804-bdd6-56b8-a4b3-a0476cf18f03) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7b55e655-acc1-5c11-92ed-d04fef14e499
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodOf
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_hasEquivariantPrimitiveOf
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_periodOf_apply_eq_sub_of_hasEquivariantPrimitiveOf
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Period homomorphism of a weight-2 cusp form equals its segment period
+
+Theorem statement: `ModularCurve.periodMapOf_apply_eq_periodOf`
+(`64275804-bdd6-56b8-a4b3-a0476cf18f03`), by Claude, 2026-09-05.
+
+Proof: submission `7b55e655-acc1-5c11-92ed-d04fef14e499`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of $\mathrm{SL}_2(\mathbb{Z})$ of finite index, let $f$ be a cusp form of
+weight $2$ for $\Gamma$, and let $\gamma \in \Gamma$. The assertion is that the value of the
+additive homomorphism [`ModularCurve.periodMapOf Γ f : Additive Γ →+
+ℂ`](def/ModularCurve_PeriodOf.html#L79) at `Additive.ofMul γ` equals [`ModularCurve.periodOf Γ γ
+f`](def/ModularCurve_PeriodOf.html#L56). Here `periodMapOf Γ f` is defined by cases: if some $F :
+\mathbb{H} \to \mathbb{C}$ satisfies `HasEquivariantPrimitiveOf Γ f F` — that is, $F \circ
+\mathrm{ofComplex}$ has derivative $f(\tau)$ at every $\tau \in \mathbb{H}$, $F \to 0$ along
+`atImInfty`, $F$ is an equivariant primitive for $\Gamma$ in the sense of
+`Period.IsEquivariantPrimitive`, and for each $\delta \in \mathrm{SL}_2(\mathbb{Z})$ the function $w
+\mapsto F(\delta \cdot w)$ has a limit along `atImInfty` — then `periodMapOf Γ f` is the
+homomorphism $\gamma \mapsto$ the period of $\gamma$ attached to (a choice of) such an $F$, and
+otherwise it is the zero homomorphism. On the other side, `periodOf Γ γ` is the linear functional
+`periodAlongOf Γ I ((γ : SL(2, ℤ)) • I)` on weight-$2$ cusp forms, whose value at $f$ is the
+interval integral $\int_0^1 \mathtt{periodIntegrandOf}\,\Gamma\, i\, (\gamma \cdot i)\, f\, t
+\,\mathrm{d}t$, the period of $f$ along the path from $i$ to $\gamma \cdot i$.
+
+This identifies the two descriptions of the periods of a weight-$2$ cusp form used in
+Eichler–Shimura theory: the character of $\Gamma$ obtained from an equivariant primitive of $f$, and
+the path period $\int_i^{\gamma i} f(\tau)\,\mathrm{d}\tau$. In particular the period character is
+independent of the primitive chosen, and the result is used downstream in the construction of the
+period map from cusp forms into the first cohomology of $\Gamma$ and its Hecke-equivariance
+statements.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_periodMapOf_apply_eq_periodOf.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_periodMapOf_apply_eq_periodOf
+
+open scoped MatrixGroups
+
+theorem solution (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex]
+    (f : CuspForm Γ 2) (γ : Γ) :
+    ModularCurve.periodMapOf Γ f (Additive.ofMul γ) = ModularCurve.periodOf Γ γ f := by
+  obtain ⟨F, hF⟩ := ModularCurve.exists_hasEquivariantPrimitiveOf Γ f
+  obtain ⟨F₀, h₀, hp⟩ := ModularCurve.periodMapOf_def Γ f hF
+  rw [hp, ModularCurve.Period.IsEquivariantPrimitive.periodHom_apply,
+    ModularCurve.periodOf_apply_eq_sub_of_hasEquivariantPrimitiveOf Γ f h₀ γ]
+  rfl
+
+end S_ModularCurve_periodMapOf_apply_eq_periodOf
+end P2MW
+export P2MW.S_ModularCurve_periodMapOf_apply_eq_periodOf (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.periodMapOf_apply_eq_periodOf (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex]
+    (f : CuspForm Γ 2) (γ : Γ) :
+    ModularCurve.periodMapOf Γ f (Additive.ofMul γ) = ModularCurve.periodOf Γ γ f :=
+  solution Γ f γ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_periodMapOf_mem_parabolicHoms.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_periodMapOf_mem_parabolicHoms.lean
new file mode 100644
index 0000000000..7a7ac9d40c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_periodMapOf_mem_parabolicHoms.lean
@@ -0,0 +1,165 @@
+/-
+Based on Prove2Me node ModularCurve.periodMapOf_mem_parabolicHoms
+(ac48d659-8a40-5df1-96e7-159faa0089b4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission de1fa56d-5059-596b-985c-8e2e04dcb9e9
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodOf
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularGroup_exists_eq_conj_T_zpow_of_trace_sq_eq_four
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Period maps of weight-2 cusp forms are parabolic
+
+Theorem statement: `ModularCurve.periodMapOf_mem_parabolicHoms`
+(`ac48d659-8a40-5df1-96e7-159faa0089b4`), by Claude, 2026-09-05.
+
+Proof: submission `de1fa56d-5059-596b-985c-8e2e04dcb9e9`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be an arbitrary subgroup of $\mathrm{SL}_2(\mathbb{Z})$ and let $f$ be a cusp form of
+weight $2$ for $\Gamma$. The assertion is that the additive homomorphism $\mathrm{periodMapOf}\
+\Gamma\ f : \mathrm{Additive}\ \Gamma \to_{+} \mathbb{C}$ belongs to the submodule
+[`ModularCurve.Period.parabolicHoms ℂ Γ ℂ`](def/ModularCurve_PeriodMap.html#L62) of
+$\mathbb{C}$-valued additive characters of $\Gamma$, that is, it satisfies `IsParabolicHom`:
+$\varphi(\gamma) = 0$ for every $\gamma \in \Gamma$ whose underlying integral matrix has
+$(\operatorname{tr}\gamma)^2 = 4$, i.e. trace $\pm 2$. Here $\mathrm{periodMapOf}\ \Gamma\ f$ is
+defined by cases: if there exists $F : \mathbb{H} \to \mathbb{C}$ satisfying
+`HasEquivariantPrimitiveOf Γ f F` — namely $F \circ \mathrm{ofComplex}$ has derivative $f(\tau)$ at
+every $\tau \in \mathbb{H}$, $F \to 0$ as $\operatorname{Im} \to \infty$, $F$ satisfies the
+predicate `Period.IsEquivariantPrimitive Γ F`, whose attached function $\mathrm{period}$ assigns to
+$\gamma \in \Gamma$ the value $F(\gamma \cdot z) - F(z)$ independently of $z$ and is additive in
+$\gamma$, and for each $\delta \in \mathrm{SL}_2(\mathbb{Z})$ the function $w \mapsto F(\delta \cdot
+w)$ has a limit along $\operatorname{Im} w \to \infty$ — then it is the character $\gamma \mapsto
+\mathrm{period}\ \gamma$ attached to such an $F$; otherwise it is the zero homomorphism. No
+hypothesis guaranteeing the existence of such an $F$ is imposed, so the degenerate case is covered
+trivially.
+
+This is the statement that the period character of a weight-$2$ cusp form is parabolic, i.e. kills
+the stabilisers of the cusps, so that the period map lands in the parabolic part
+$H^1_{\mathrm{par}}(\Gamma,\mathbb{C})$ of $H^1(\Gamma,\mathbb{C})$. It feeds the
+Eichler–Shimura-type comparison between weight-$2$ cusp forms and parabolic cohomology used later
+for Hecke eigenform and Galois-module constructions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_periodMapOf_mem_parabolicHoms.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_periodMapOf_mem_parabolicHoms
+
+open scoped MatrixGroups
+open UpperHalfPlane Filter Topology
+
+namespace ModularCurve
+p2m_export "ModularCurve" "HasEquivariantPrimitiveOf periodMapOf periodMapOf_def period \
+  Period.parabolicHoms"
+namespace PeriodMapParabolicOf
+p2m_open "ModularCurve"
+
+open ModularCurve.Period
+
+theorem tendsto_vadd_atImInfty (x : ℝ) :
+    Tendsto (fun z : ℍ => x +ᵥ z) atImInfty atImInfty := by
+  simp only [atImInfty, tendsto_comap_iff, Function.comp_def]
+  exact tendsto_comap.congr fun z => (vadd_im x z).symm
+
+theorem const_eq_zero_of_tendsto_sub {α : Type*} {l : Filter α} [l.NeBot]
+    {g h : α → ℂ} {L c : ℂ} (hg : Tendsto g l (𝓝 L)) (hh : Tendsto h l (𝓝 L))
+    (hc : ∀ a, g a - h a = c) : c = 0 := by
+  have hsub : Tendsto (fun a => g a - h a) l (𝓝 (L - L)) := hg.sub hh
+  rw [sub_self] at hsub
+  exact tendsto_nhds_unique (tendsto_const_nhds.congr fun a => (hc a).symm) hsub
+
+theorem period_eq_zero {Γ : Subgroup SL(2, ℤ)} {F : ℍ → ℂ}
+    (hF : IsEquivariantPrimitive Γ F) (δ : SL(2, ℤ)) {L : ℂ}
+    (hlim : Tendsto (fun w : ℍ => F (δ • w)) atImInfty (𝓝 L)) (n : ℤ) (ε : SL(2, ℤ))
+    (hε : ε = 1 ∨ ε = -1) (hγ : ε * (δ * ModularGroup.T ^ n * δ⁻¹) ∈ Γ) :
+    hF.period ⟨_, hγ⟩ = 0 := by
+  have hεact : ∀ z : ℍ, (ε : SL(2, ℤ)) • z = z := by
+    intro z
+    rcases hε with rfl | rfl
+    · exact one_smul _ z
+    · ext1
+      rw [UpperHalfPlane.specialLinearGroup_apply]
+      simp
+  have hkey : ∀ w : ℍ, (ε * (δ * ModularGroup.T ^ n * δ⁻¹) : SL(2, ℤ)) • ((δ : SL(2, ℤ)) • w)
+      = δ • (ModularGroup.T ^ n • w) := by
+    intro w
+    rw [mul_smul, hεact, ← mul_smul, ← mul_smul]
+    congr 1
+    group
+  have hc' : ∀ w : ℍ, F (δ • (ModularGroup.T ^ n • w)) - F (δ • w) = hF.period ⟨_, hγ⟩ := by
+    intro w
+    rw [← hkey]
+    exact hF.sub_eq_period ⟨_, hγ⟩ (δ • w)
+  refine const_eq_zero_of_tendsto_sub
+    (g := fun w : ℍ => F (δ • (ModularGroup.T ^ n • w)))
+    (h := fun w : ℍ => F (δ • w)) (L := L) ?_ hlim hc'
+  have hfun : (fun w : ℍ => F (δ • (ModularGroup.T ^ n • w)))
+      = (fun w : ℍ => F (δ • w)) ∘ fun w : ℍ => ((n : ℤ) : ℝ) +ᵥ w := by
+    funext w
+    simp only [Function.comp_apply, UpperHalfPlane.modular_T_zpow_smul]
+  rw [hfun]
+  exact hlim.comp (tendsto_vadd_atImInfty ((n : ℤ) : ℝ))
+
+theorem isParabolicHom_periodHom {Γ : Subgroup SL(2, ℤ)} {f : CuspForm Γ 2} {F : ℍ → ℂ}
+    (hF : ModularCurve.HasEquivariantPrimitiveOf Γ f F) :
+    IsParabolicHom Γ hF.2.2.1.periodHom := by
+  intro γ hγ
+  obtain ⟨ε, δ, n, hε, hγeq⟩ :=
+    ModularGroup.exists_eq_conj_T_zpow_of_trace_sq_eq_four (γ : SL(2, ℤ)) hγ
+  obtain ⟨L, hL⟩ := hF.2.2.2 δ
+  have hmem : ε * (δ * ModularGroup.T ^ n * δ⁻¹) ∈ Γ := by rw [← hγeq]; exact γ.2
+  have hγ' : γ = ⟨_, hmem⟩ := Subtype.ext hγeq
+  rw [IsEquivariantPrimitive.periodHom_apply, hγ']
+  exact period_eq_zero hF.2.2.1 δ hL n ε hε hmem
+
+theorem main (Γ : Subgroup SL(2, ℤ)) (f : CuspForm Γ 2) :
+    ModularCurve.periodMapOf Γ f ∈ parabolicHoms ℂ Γ ℂ := by
+  classical
+  by_cases h : ∃ F : ℍ → ℂ, ModularCurve.HasEquivariantPrimitiveOf Γ f F
+  · obtain ⟨F, hF⟩ := h
+    obtain ⟨F₀, h₀, hp⟩ := ModularCurve.periodMapOf_def Γ f hF
+    rw [hp]
+    exact isParabolicHom_periodHom h₀
+  · have : ModularCurve.periodMapOf Γ f = 0 := dite_eq_right h
+    rw [this]
+    exact Submodule.zero_mem _
+
+end ModularCurve.PeriodMapParabolicOf
+
+theorem solution (Γ : Subgroup SL(2, ℤ)) (f : CuspForm Γ 2) :
+    ModularCurve.periodMapOf Γ f ∈ ModularCurve.Period.parabolicHoms ℂ Γ ℂ :=
+  ModularCurve.PeriodMapParabolicOf.main Γ f
+
+end S_ModularCurve_periodMapOf_mem_parabolicHoms
+end P2MW
+export P2MW.S_ModularCurve_periodMapOf_mem_parabolicHoms (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.periodMapOf_mem_parabolicHoms (Γ : Subgroup SL(2, ℤ)) (f : CuspForm Γ 2) :
+    ModularCurve.periodMapOf Γ f ∈ ModularCurve.Period.parabolicHoms ℂ Γ ℂ :=
+  solution Γ f
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_periodOf_apply_eq_sub_of_hasEquivariantPrimitiveOf.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_periodOf_apply_eq_sub_of_hasEquivariantPrimitiveOf.lean
new file mode 100644
index 0000000000..fa31febe94
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_periodOf_apply_eq_sub_of_hasEquivariantPrimitiveOf.lean
@@ -0,0 +1,163 @@
+/-
+Based on Prove2Me node ModularCurve.periodOf_apply_eq_sub_of_hasEquivariantPrimitiveOf
+(0113dc16-2a0e-5225-bf3e-ef9894c1eec1) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 64337d03-0904-5fbc-b8e1-dc2e9a29da31
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodOf
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Segment period equals difference of primitive values
+
+Theorem statement: `ModularCurve.periodOf_apply_eq_sub_of_hasEquivariantPrimitiveOf`
+(`0113dc16-2a0e-5225-bf3e-ef9894c1eec1`), by Claude, 2026-09-05.
+
+Proof: submission `64337d03-0904-5fbc-b8e1-dc2e9a29da31`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of $\mathrm{SL}_2(\mathbb Z)$, let $f$ be a cusp form of weight $2$ for
+$\Gamma$, and let $F\colon\mathfrak H\to\mathbb C$ satisfy
+[`ModularCurve.HasEquivariantPrimitiveOf`](def/ModularCurve_PeriodOf.html#L71)$\,\Gamma\,f\,F$, that
+is: (i) for every $\tau\in\mathfrak H$ the function $F\circ\mathrm{ofComplex}$ has derivative
+$f(\tau)$ at the point $\tau$ of $\mathbb C$; (ii) $F$ tends to $0$ along the filter `atImInfty`;
+(iii) $F$ is an equivariant primitive in the sense that for each $\gamma\in\Gamma$ there is a
+constant $c\in\mathbb C$ with $F(\gamma\cdot z)-F(z)=c$ for all $z\in\mathfrak H$; and (iv) for
+every $\delta\in\mathrm{SL}_2(\mathbb Z)$ the function $w\mapsto F(\delta\cdot w)$ has a limit
+$L\in\mathbb C$ along `atImInfty`. Then for every $\gamma\in\Gamma$ the value at $f$ of the linear
+functional [`ModularCurve.periodOf`](def/ModularCurve_PeriodOf.html#L56)$\,\Gamma\,\gamma$ on
+$S_2(\Gamma)$ — by definition the integral $\int_0^1$ of the project's period integrand along the
+straight segment from $i$ to $\gamma\cdot i$, namely $t\mapsto f\bigl((1-t)i+t\,\gamma
+i\bigr)\,(\gamma i-i)$ — equals $F(\gamma\cdot i)-F(i)$.
+
+This is the fundamental theorem of calculus along a segment in the upper half plane, identifying the
+two standard descriptions of the periods of a weight-$2$ cusp form: segment integrals, which define
+the period lattice inside $S_2(\Gamma)^\vee$, and differences of values of a primitive, which define
+the period map into group cohomology. It is used throughout the construction of the period lattice
+and the Abel–Jacobi dictionary for modular curves, and in the recognition of eigenforms by their
+$q$-coefficients.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_periodOf_apply_eq_sub_of_hasEquivariantPrimitiveOf.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_periodOf_apply_eq_sub_of_hasEquivariantPrimitiveOf
+
+open scoped MatrixGroups
+open UpperHalfPlane
+
+namespace ModularCurve
+p2m_export "ModularCurve" "intervalIntegrable_periodIntegrandOf periodAlongOf periodAlongOf_apply \
+  periodOf HasEquivariantPrimitiveOf clamp01_of_mem segmentPoint continuous_segmentPoint \
+  segmentPath coe_segmentPath period"
+namespace PeriodFTCOf
+p2m_open "ModularCurve"
+
+theorem hasDerivAt_affine (a b : ℂ) (t : ℝ) :
+    HasDerivAt (fun s : ℝ => (1 - (s : ℂ)) * a + (s : ℂ) * b) (b - a) t := by
+  have h1 : HasDerivAt (fun s : ℝ => (s : ℂ)) 1 t := Complex.ofRealCLM.hasDerivAt
+  have h2 : HasDerivAt (fun s : ℝ => (1 - (s : ℂ)) * a) (-(1 : ℂ) * a) t := by
+    simpa using ((hasDerivAt_const t (1 : ℂ)).sub h1).mul_const a
+  have h3 : HasDerivAt (fun s : ℝ => (s : ℂ) * b) (1 * b) t := h1.mul_const b
+  have := h2.add h3
+  convert this using 1
+  · ring
+
+theorem segmentPoint_eq_of_mem {τ₀ τ₁ : ℍ} {t : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    ModularCurve.segmentPoint τ₀ τ₁ t = (1 - (t : ℂ)) * (τ₀ : ℂ) + (t : ℂ) * (τ₁ : ℂ) := by
+  simp only [ModularCurve.segmentPoint, ModularCurve.clamp01_of_mem ht, Complex.real_smul,
+    Complex.ofReal_sub, Complex.ofReal_one]
+
+theorem periodAlongOf_eq_sub (Γ : Subgroup SL(2, ℤ)) (f : CuspForm Γ 2)
+    {F : ℍ → ℂ} (hF : ∀ τ : ℍ, HasDerivAt (F ∘ ofComplex) (f τ) ↑τ) (τ₀ τ₁ : ℍ) :
+    ModularCurve.periodAlongOf Γ τ₀ τ₁ f = F τ₁ - F τ₀ := by
+  rw [ModularCurve.periodAlongOf_apply]
+  set g : ℝ → ℂ := fun t => F (ModularCurve.segmentPath τ₀ τ₁ t) with hg
+  have hgF : ∀ t, g t = (F ∘ ofComplex) (ModularCurve.segmentPoint τ₀ τ₁ t) := by
+    intro t
+    simp only [hg, Function.comp]
+    congr 1
+    rw [← ModularCurve.coe_segmentPath, ofComplex_apply]
+  have hg0 : g 0 = F τ₀ := by
+    rw [hgF]
+    have : ModularCurve.segmentPoint τ₀ τ₁ 0 = (τ₀ : ℂ) := by
+      rw [segmentPoint_eq_of_mem ⟨le_rfl, zero_le_one⟩]; push_cast; ring
+    simp only [Function.comp, this, ofComplex_apply]
+  have hg1 : g 1 = F τ₁ := by
+    rw [hgF]
+    have : ModularCurve.segmentPoint τ₀ τ₁ 1 = (τ₁ : ℂ) := by
+      rw [segmentPoint_eq_of_mem ⟨zero_le_one, le_rfl⟩]; push_cast; ring
+    simp only [Function.comp, this, ofComplex_apply]
+  have hFcont : ∀ τ : ℍ, ContinuousAt (F ∘ ofComplex) (τ : ℂ) := fun τ => (hF τ).continuousAt
+  have hgcont : Continuous g := by
+    have : g = (F ∘ ofComplex) ∘ ModularCurve.segmentPoint τ₀ τ₁ := funext hgF
+    rw [this]
+    refine continuous_iff_continuousAt.mpr fun t => ?_
+    refine ContinuousAt.comp ?_ (ModularCurve.continuous_segmentPoint τ₀ τ₁).continuousAt
+    have := hFcont (ModularCurve.segmentPath τ₀ τ₁ t)
+    rwa [ModularCurve.coe_segmentPath] at this
+  have hderiv : ∀ t ∈ Set.Ioo (0 : ℝ) 1,
+      HasDerivAt g (f (ModularCurve.segmentPath τ₀ τ₁ t) * ((τ₁ : ℂ) - τ₀)) t := by
+    intro t ht
+    have hpath : HasDerivAt (ModularCurve.segmentPoint τ₀ τ₁) ((τ₁ : ℂ) - τ₀) t := by
+      refine (hasDerivAt_affine (τ₀ : ℂ) (τ₁ : ℂ) t).congr_of_eventuallyEq ?_
+      filter_upwards [Ioo_mem_nhds ht.1 ht.2] with s hs
+      exact segmentPoint_eq_of_mem (Set.Ioo_subset_Icc_self hs)
+    have hFat : HasDerivAt (F ∘ ofComplex) (f (ModularCurve.segmentPath τ₀ τ₁ t))
+        (ModularCurve.segmentPoint τ₀ τ₁ t) := by
+      have := hF (ModularCurve.segmentPath τ₀ τ₁ t)
+      rwa [ModularCurve.coe_segmentPath] at this
+    have hcomp := hFat.comp t hpath
+    have : g = (F ∘ ofComplex) ∘ ModularCurve.segmentPoint τ₀ τ₁ := funext hgF
+    rw [this]
+    exact hcomp
+  have hint : IntervalIntegrable
+      (fun t => f (ModularCurve.segmentPath τ₀ τ₁ t) * ((τ₁ : ℂ) - τ₀)) MeasureTheory.volume 0 1 :=
+    ModularCurve.intervalIntegrable_periodIntegrandOf Γ τ₀ τ₁ f 0 1
+  have key := intervalIntegral.integral_eq_sub_of_hasDerivAt_of_le zero_le_one
+    hgcont.continuousOn hderiv hint
+  rw [key, hg0, hg1]
+
+end ModularCurve.PeriodFTCOf
+
+theorem solution (Γ : Subgroup SL(2, ℤ))
+    (f : CuspForm Γ 2) {F : UpperHalfPlane → ℂ}
+    (hF : ModularCurve.HasEquivariantPrimitiveOf Γ f F) (γ : Γ) :
+    ModularCurve.periodOf Γ γ f =
+      F ((γ : SL(2, ℤ)) • UpperHalfPlane.I) - F UpperHalfPlane.I :=
+  ModularCurve.PeriodFTCOf.periodAlongOf_eq_sub Γ f hF.1 _ _
+
+end S_ModularCurve_periodOf_apply_eq_sub_of_hasEquivariantPrimitiveOf
+end P2MW
+export P2MW.S_ModularCurve_periodOf_apply_eq_sub_of_hasEquivariantPrimitiveOf (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.periodOf_apply_eq_sub_of_hasEquivariantPrimitiveOf (Γ : Subgroup SL(2, ℤ))
+    (f : CuspForm Γ 2) {F : UpperHalfPlane → ℂ}
+    (hF : ModularCurve.HasEquivariantPrimitiveOf Γ f F) (γ : Γ) :
+    ModularCurve.periodOf Γ γ f =
+      F ((γ : SL(2, ℤ)) • UpperHalfPlane.I) - F UpperHalfPlane.I :=
+  solution Γ f hF γ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_place_eq_of_induces.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_place_eq_of_induces.lean
new file mode 100644
index 0000000000..bbc0e43287
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_place_eq_of_induces.lean
@@ -0,0 +1,125 @@
+/-
+Based on Prove2Me node ModularCurve.place_eq_of_induces
+(3e5b60a8-b53e-5a31-b5d0-fd9932faeef9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a98c9cd9-76a7-563b-aa3e-7afe08026cfa
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EMD
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Rat.Star
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A Hahn-series embedding induces at most one place
+
+Theorem statement: `ModularCurve.place_eq_of_induces` (`3e5b60a8-b53e-5a31-b5d0-fd9932faeef9`), by
+Claude, 2026-09-05.
+
+Proof: submission `a98c9cd9-76a7-563b-aa3e-7afe08026cfa`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $N \neq 0$ and write $\bar F_N$ for `modularFunctionFieldBar N`, the
+intermediate field of the Laurent series field $\overline{\mathbb{Q}}((q))$ obtained by adjoining to
+$\overline{\mathbb{Q}}$ the coefficientwise image of the subfield
+$\mathbb{Q}(\mathrm{divisorExpansions}\,N) \subseteq \mathbb{Q}((q))$. Let $\psi : \bar F_N \to
+\mathrm{HahnSeries}\ \mathbb{Q}\ \overline{\mathbb{Q}}$ be an $\overline{\mathbb{Q}}$-algebra
+homomorphism into the Hahn series over $\overline{\mathbb{Q}}$ with exponents in $\mathbb{Q}$, and
+let $w, w'$ be places of $\bar F_N$ over $\overline{\mathbb{Q}}$, that is, valuation subrings of
+$\bar F_N$ containing the image of $\overline{\mathbb{Q}}$, different from the whole field, and
+which are principal ideal rings. Assume that $\psi$ induces $w$ and that $\psi$ induces $w'$, where
+`Induces ψ w` means: there is a rational number $g > 0$ such that for every $x \in \bar F_N$ one has
+$(\mathrm{ord}_w x)\, g = \mathrm{order}(\psi x)$, the order of the Hahn series $\psi x$. The
+conclusion is $w = w'$: the scaling factors may differ, but the place is unique.
+
+This is the uniqueness half of the correspondence between embeddings of the level-$N$ modular
+function field into Hahn series and places of that field, the existence half being a separate
+statement. It is used in the computation of the orders of vanishing of $j$ and $j - 1728$ at the
+relevant places, hence in the verification of the Eichler–Selberg/mass-type count of elliptic
+points, and in [`ModularCurve.emd_holds`](thm.html#ModularCurve.emd_holds).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_place_eq_of_induces.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_place_eq_of_induces
+
+open ModularCurve AlgebraicCurve
+
+namespace S12Q
+
+variable (N : ℕ) [NeZero N]
+
+omit [NeZero N] in
+theorem mem_iff_ord_nonneg (w : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N))
+    {x : ↥(modularFunctionFieldBar N)} (hx : x ≠ 0) :
+    x ∈ w.toValuationSubring ↔ 0 ≤ w.ord x := by
+  rw [Place.mem_iff_adicValuation_le_one, Place.ord, neg_nonneg,
+    WithZero.log_le_iff_le_exp (w.adicValuation_ne_zero hx), WithZero.exp_zero]
+
+theorem induces_unique
+    {ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ] HahnSeries ℚ (AlgebraicClosure ℚ)}
+    {w w' : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)}
+    (hw : Induces ψ w) (hw' : Induces ψ w') : w = w' := by
+  obtain ⟨g, hg, h⟩ := hw
+  obtain ⟨g', hg', h'⟩ := hw'
+  have key : ∀ x, 0 ≤ w.ord x ↔ 0 ≤ w'.ord x := by
+    intro x
+    have hx := h x
+    rw [← h' x] at hx
+    constructor
+    · intro h0
+      have : 0 ≤ (w'.ord x : ℚ) * g' := by rw [← hx]; positivity
+      exact_mod_cast nonneg_of_mul_nonneg_left this hg'
+    · intro h0
+      have : 0 ≤ (w.ord x : ℚ) * g := by rw [hx]; positivity
+      exact_mod_cast nonneg_of_mul_nonneg_left this hg
+  apply Place.ext
+  ext x
+  rcases eq_or_ne x 0 with rfl | hx
+  · simp [zero_mem]
+  · rw [mem_iff_ord_nonneg N w hx, mem_iff_ord_nonneg N w' hx, key]
+
+end S12Q
+
+theorem solution {N : ℕ} [NeZero N]
+    {ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ] HahnSeries ℚ (AlgebraicClosure ℚ)}
+    {w w' : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)}
+    (h : Induces ψ w) (h' : Induces ψ w') : w = w' := by
+  exact S12Q.induces_unique N h h'
+
+end S_ModularCurve_place_eq_of_induces
+end P2MW
+export P2MW.S_ModularCurve_place_eq_of_induces (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve ModularCurve IsDedekindDomain WithZero
+theorem ModularCurve.place_eq_of_induces {N : ℕ} [NeZero N]
+    {ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ] HahnSeries ℚ (AlgebraicClosure ℚ)}
+    {w w' : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)}
+    (h : Induces ψ w) (h' : Induces ψ w')
+    : w = w' :=
+  solution h h'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_qExpand_image_intFormRatiosC_subset.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_qExpand_image_intFormRatiosC_subset.lean
new file mode 100644
index 0000000000..b5fb0ba266
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_qExpand_image_intFormRatiosC_subset.lean
@@ -0,0 +1,274 @@
+/-
+Based on Prove2Me node ModularCurve.qExpand_image_intFormRatiosC_subset
+(fb14d131-f259-581d-91cd-f5b2891d646b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c50984d4-0b5d-5469-b3bb-af2c21e8f9f6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_qCoeff_comp_heckeDiagMatrix_smul
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Substitution q↦ q^ℓ on ratios of integral forms
+
+Theorem statement: `ModularCurve.qExpand_image_intFormRatiosC_subset`
+(`fb14d131-f259-581d-91cd-f5b2891d646b`), by Claude, 2026-09-05.
+
+Proof: submission `c50984d4-0b5d-5469-b3bb-af2c21e8f9f6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, let $\Gamma,\Gamma'\le \mathrm{SL}_2(\mathbb Z)$ be subgroups with $\Gamma$ of
+finite index and containing $T=\begin{pmatrix}1&1\\0&1\end{pmatrix}$, and let $\ell$ be a nonzero
+natural number. Assume that for every $\gamma\in\Gamma'$ there is a $\gamma_1\in\Gamma$ with
+$(\gamma_1)_{00}=\gamma_{00}$, $(\gamma_1)_{01}=\ell\,\gamma_{01}$,
+$\ell\,(\gamma_1)_{10}=\gamma_{10}$ and $(\gamma_1)_{11}=\gamma_{11}$; that is,
+$\operatorname{diag}(\ell,1)\gamma\operatorname{diag}(\ell,1)^{-1}$ has integral entries and lies in
+$\Gamma$. For a subgroup $\Delta\le\mathrm{SL}_2(\mathbb Z)$, [`ModularCurve.intFormRatiosC K
+Δ`](def/ModularCurve_X1.html#L83) is the set of Laurent series over $K$ of the form $\bar p_f/\bar
+p_g$, where for some integer weight $k$ there are modular forms $f,g$ of weight $k$ for the image of
+$\Delta$ in $\mathrm{GL}_2(\mathbb R)$ and power series $p_f,p_g\in\mathbb Z[[q]]$ whose images in
+$\mathbb C[[q]]$ are the $q$-expansions of $f$ and $g$ of width $1$, $\bar p$ denoting the Laurent
+series obtained by reducing coefficients to $K$, subject to $\bar p_g\neq 0$. The assertion is that
+the ring endomorphism [`ModularCurve.qExpand K ℓ`](def/ModularCurve_X0.html#L25) of $K((q))$, given
+by rescaling the exponent support by $\ell$ (so $q\mapsto q^{\ell}$), carries
+[`ModularCurve.intFormRatiosC K Γ`](def/ModularCurve_X1.html#L83) into [`ModularCurve.intFormRatiosC
+K Γ'`](def/ModularCurve_X1.html#L83).
+
+This is the formal-$q$-expansion shadow of the classical fact that, for $f$ modular of weight $k$ on
+$\Gamma$, the function $\tau\mapsto f(\ell\tau)$ is modular of the same weight on any group
+$\Gamma'$ with $\operatorname{diag}(\ell,1)\Gamma'\operatorname{diag}(\ell,1)^{-1}\subseteq\Gamma$,
+so that $q\mapsto q^{\ell}$ respects the $q$-expansion function fields of the corresponding modular
+curves. It is used in the construction and comparison of degeneracy maps and Hecke operators on
+modular curves and their Jacobians.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_qExpand_image_intFormRatiosC_subset.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_qExpand_image_intFormRatiosC_subset
+
+noncomputable section
+
+open UpperHalfPlane ModularForm CongruenceSubgroup OnePoint Function HahnSeries
+open scoped MatrixGroups ModularForm Manifold
+
+namespace X1QExpandStretch
+
+section Cocycle
+
+variable {ℓ : ℕ}
+
+private theorem mapGL_coe_eq (s : SL(2, ℤ)) :
+    ((Matrix.SpecialLinearGroup.mapGL ℝ s : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ)
+      = (s : Matrix (Fin 2) (Fin 2) ℤ).map (algebraMap ℤ ℝ) := rfl
+
+theorem heckeDiagMatrix_mul_eq (hℓ : ℓ ≠ 0) {γ γ₁ : SL(2, ℤ)}
+    (h00 : γ₁ 0 0 = γ 0 0) (h01 : γ₁ 0 1 = (ℓ : ℤ) * γ 0 1)
+    (h10 : (ℓ : ℤ) * γ₁ 1 0 = γ 1 0) (h11 : γ₁ 1 1 = γ 1 1) :
+    heckeDiagMatrix ℓ * Matrix.SpecialLinearGroup.mapGL ℝ γ
+      = Matrix.SpecialLinearGroup.mapGL ℝ γ₁ * heckeDiagMatrix ℓ := by
+  apply Units.ext
+  rw [Units.val_mul, Units.val_mul, mapGL_coe_eq, mapGL_coe_eq, val_heckeDiagMatrix hℓ]
+  have e10 : ((γ 1 0 : ℤ) : ℝ) = (ℓ : ℝ) * ((γ₁ 1 0 : ℤ) : ℝ) := by
+    rw [← h10]; push_cast; ring
+  ext i j
+  fin_cases i <;> fin_cases j <;>
+    simp [Matrix.mul_apply, Fin.sum_univ_two, h00, h01, h11, e10, mul_comm]
+
+end Cocycle
+
+section Form
+
+variable {Γ Γ' : Subgroup SL(2, ℤ)} [Γ.FiniteIndex] {ℓ : ℕ} {k : ℤ}
+
+theorem isCusp_heckeDiagMatrix_smul (hℓ : ℓ ≠ 0) {c : OnePoint ℝ} (hc : IsCusp c 𝒮ℒ) :
+    IsCusp (heckeDiagMatrix ℓ • c) 𝒮ℒ := by
+  rw [isCusp_SL2Z_iff] at hc ⊢
+  obtain ⟨c₀, rfl⟩ := hc
+  let gQ : GL (Fin 2) ℚ := Matrix.GeneralLinearGroup.mkOfDetNeZero !![(ℓ : ℚ), 0; 0, 1]
+    (by
+      rw [Matrix.det_fin_two_of]; simp only [mul_one, mul_zero, sub_zero, ne_eq, Nat.cast_eq_zero];
+        exact_mod_cast hℓ)
+  have hg : gQ.map (Rat.castHom ℝ) = heckeDiagMatrix ℓ := by
+    apply Units.ext
+    rw [val_heckeDiagMatrix hℓ]
+    change (gQ : Matrix (Fin 2) (Fin 2) ℚ).map (Rat.castHom ℝ) = _
+    ext i j; fin_cases i <;> fin_cases j <;> simp [gQ]
+  refine ⟨gQ • c₀, ?_⟩
+  rw [← hg, ← Rat.coe_castHom, OnePoint.map_smul]
+
+variable (hΓ' : ∀ γ ∈ Γ', ∃ γ₁ ∈ Γ,
+  γ₁ 0 0 = γ 0 0 ∧ γ₁ 0 1 = (ℓ : ℤ) * γ 0 1 ∧ (ℓ : ℤ) * γ₁ 1 0 = γ 1 0 ∧ γ₁ 1 1 = γ 1 1)
+
+def stretchSlash (hℓ : ℓ ≠ 0) (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) :
+    ModularForm (Γ' : Subgroup (GL (Fin 2) ℝ)) k where
+  toFun := (⇑f : ℍ → ℂ) ∣[k] heckeDiagMatrix ℓ
+  slash_action_eq' := by
+    intro A hA
+    obtain ⟨γ, hγ, rfl⟩ := hA
+    obtain ⟨γ₁, hγ₁, h00, h01, h10, h11⟩ := hΓ' γ hγ
+    rw [← SlashAction.slash_mul, heckeDiagMatrix_mul_eq hℓ h00 h01 h10 h11,
+      SlashAction.slash_mul]
+    congr 1
+    exact SlashInvariantFormClass.slash_action_eq f _ (Subgroup.mem_map_of_mem _ hγ₁)
+  holo' := f.holo'.slash k _
+  bdd_at_cusps' := by
+    intro c hc
+    have hcSL : IsCusp c 𝒮ℒ := by
+      refine hc.mono ?_
+      rintro _ ⟨γ, -, rfl⟩
+      exact ⟨γ, rfl⟩
+    have hc' : IsCusp (heckeDiagMatrix ℓ • c) (Γ : Subgroup (GL (Fin 2) ℝ)) := by
+      rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z]
+      exact isCusp_heckeDiagMatrix_smul hℓ hcSL
+    exact IsBoundedAt.smul_iff.mp (f.bdd_at_cusps' hc')
+
+theorem stretchSlash_apply (hℓ : ℓ ≠ 0) (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k)
+    (τ : ℍ) :
+    stretchSlash hΓ' hℓ f τ = (ℓ : ℂ) ^ (k - 1) * f (heckeDiagMatrix ℓ • τ) :=
+  slash_heckeDiagMatrix_apply k hℓ _ τ
+
+def stretch (hℓ : ℓ ≠ 0) (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) :
+    ModularForm (Γ' : Subgroup (GL (Fin 2) ℝ)) k :=
+  ((ℓ : ℂ) ^ (k - 1))⁻¹ • stretchSlash hΓ' hℓ f
+
+theorem stretch_apply (hℓ : ℓ ≠ 0) (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (τ : ℍ) :
+    stretch hΓ' hℓ f τ = f (heckeDiagMatrix ℓ • τ) := by
+  have hpk : ((ℓ : ℂ) ^ (k - 1)) ≠ 0 := zpow_ne_zero _ (Nat.cast_ne_zero.mpr hℓ)
+  rw [stretch, smul_apply, stretchSlash_apply, smul_eq_mul, ← mul_assoc,
+    inv_mul_cancel₀ hpk, one_mul]
+
+theorem coe_stretch (hℓ : ℓ ≠ 0) (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) :
+    (⇑(stretch hΓ' hℓ f) : ℍ → ℂ) = fun τ => f (heckeDiagMatrix ℓ • τ) :=
+  funext (stretch_apply hΓ' hℓ f)
+
+omit [Γ.FiniteIndex] in
+private theorem _root_.X1QExpandStretch.periodic_comp_ofComplex (hT : ModularGroup.T ∈ Γ)
+    (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) :
+    Periodic ((⇑f : ℍ → ℂ) ∘ ofComplex) 1 := by
+  have h1 : (1 : ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+    rw [Subgroup.strictPeriods_eq_zmultiples_one_of_T_mem hT]
+    exact AddSubgroup.mem_zmultiples 1
+  exact SlashInvariantFormClass.periodic_comp_ofComplex f h1
+
+p2m_export "X1QExpandStretch" "periodic_comp_ofComplex"
+
+theorem qCoeff_stretch (hT : ModularGroup.T ∈ Γ) (hℓ : ℓ ≠ 0)
+    (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) (n : ℕ) :
+    ModularFormClass.qCoeff (⇑(stretch hΓ' hℓ f)) n
+      = if ℓ ∣ n then ModularFormClass.qCoeff (⇑f) (n / ℓ) else 0 := by
+  rw [coe_stretch]
+  exact UpperHalfPlane.qCoeff_comp_heckeDiagMatrix_smul (periodic_comp_ofComplex hT f) f.holo'
+    (ModularFormClass.bdd_at_infty f) hℓ n
+
+def expandPS (ℓ : ℕ) (p : PowerSeries ℤ) : PowerSeries ℤ :=
+  PowerSeries.mk fun n => if ℓ ∣ n then PowerSeries.coeff (n / ℓ) p else 0
+
+@[scoped simp] theorem coeff_expandPS (ℓ : ℕ) (p : PowerSeries ℤ) (n : ℕ) :
+    PowerSeries.coeff n (expandPS ℓ p) = if ℓ ∣ n then PowerSeries.coeff (n / ℓ) p else 0 :=
+  PowerSeries.coeff_mk _ _
+
+theorem isIntegralQExp_stretch (hT : ModularGroup.T ∈ Γ) (hℓ : ℓ ≠ 0)
+    (f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k) {p : PowerSeries ℤ}
+    (hp : ModularCurve.IsIntegralQExp f p) :
+    ModularCurve.IsIntegralQExp (stretch hΓ' hℓ f) (expandPS ℓ p) := by
+  rw [ModularCurve.isIntegralQExp_iff]
+  intro n
+  have h := qCoeff_stretch hΓ' hT hℓ f n
+  simp only [ModularFormClass.qCoeff] at h
+  rw [h, coeff_expandPS]
+  split_ifs with hdvd
+  · exact hp.coeff (n / ℓ)
+  · simp
+
+theorem intSeriesC_expandPS (K : Type*) [Field K] (ℓ : ℕ) [NeZero ℓ] (p : PowerSeries ℤ) :
+    ModularCurve.intSeriesC K (expandPS ℓ p)
+      = ModularCurve.qExpand K ℓ (ModularCurve.intSeriesC K p) := by
+  have hℓ : ℓ ≠ 0 := NeZero.ne ℓ
+  ext m
+  simp only [ModularCurve.intSeriesC]
+  by_cases hdvd : (ℓ : ℤ) ∣ m
+  · obtain ⟨m', rfl⟩ := hdvd
+    rw [ModularCurve.qExpand_coeff_mul, PowerSeries.coeff_coe, PowerSeries.coeff_coe]
+    by_cases hm' : m' < 0
+    · have : (ℓ : ℤ) * m' < 0 :=
+        mul_neg_of_pos_of_neg (by exact_mod_cast Nat.pos_of_ne_zero hℓ) hm'
+      rw [ite_eq_left this, ite_eq_left hm']
+    · have hm'0 : 0 ≤ m' := le_of_not_gt hm'
+      have hprod : ¬ (ℓ : ℤ) * m' < 0 := not_lt.mpr (mul_nonneg (by positivity) hm'0)
+      rw [ite_eq_right hprod, ite_eq_right hm', PowerSeries.coeff_map, PowerSeries.coeff_map,
+        coeff_expandPS]
+      have habs : ((ℓ : ℤ) * m').natAbs = ℓ * m'.natAbs := by
+        rw [Int.natAbs_mul, Int.natAbs_natCast]
+      rw [habs, ite_eq_left (dvd_mul_right ℓ _), Nat.mul_div_cancel_left _ (Nat.pos_of_ne_zero hℓ)]
+  · rw [ModularCurve.qExpand_coeff_of_not_dvd ℓ _ hdvd, PowerSeries.coeff_coe]
+    split_ifs with hm
+    · rfl
+    · rw [PowerSeries.coeff_map, coeff_expandPS]
+      have : ¬ ℓ ∣ m.natAbs := by
+        intro h
+        apply hdvd
+        have hm0 : 0 ≤ m := le_of_not_gt hm
+        rw [← Int.natAbs_of_nonneg hm0]
+        exact_mod_cast h
+      rw [ite_eq_right this, map_zero]
+
+end Form
+
+end X1QExpandStretch
+end
+
+open scoped MatrixGroups in
+theorem solution (K : Type*) [Field K]
+    {Γ Γ' : Subgroup SL(2, ℤ)} [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ) (ℓ : ℕ) [NeZero ℓ]
+    (hΓ' : ∀ γ ∈ Γ', ∃ γ₁ ∈ Γ,
+      γ₁ 0 0 = γ 0 0 ∧ γ₁ 0 1 = (ℓ : ℤ) * γ 0 1 ∧ (ℓ : ℤ) * γ₁ 1 0 = γ 1 0 ∧ γ₁ 1 1 = γ 1 1) :
+    ModularCurve.qExpand K ℓ '' ModularCurve.intFormRatiosC K Γ ⊆
+      ModularCurve.intFormRatiosC K Γ' := by
+  have hℓ : ℓ ≠ 0 := NeZero.ne ℓ
+  rintro _ ⟨x, ⟨k, f, g, pf, pg, hf, hg, hg0, rfl⟩, rfl⟩
+  refine ⟨k, X1QExpandStretch.stretch hΓ' hℓ f, X1QExpandStretch.stretch hΓ' hℓ g,
+    X1QExpandStretch.expandPS ℓ pf, X1QExpandStretch.expandPS ℓ pg,
+    X1QExpandStretch.isIntegralQExp_stretch hΓ' hT hℓ f hf,
+    X1QExpandStretch.isIntegralQExp_stretch hΓ' hT hℓ g hg, ?_, ?_⟩
+  · rw [X1QExpandStretch.intSeriesC_expandPS]
+    exact fun h => hg0 (ModularCurve.qExpand_injective ℓ (by rw [h, map_zero]))
+  · rw [X1QExpandStretch.intSeriesC_expandPS, X1QExpandStretch.intSeriesC_expandPS, map_div₀]
+
+end S_ModularCurve_qExpand_image_intFormRatiosC_subset
+end P2MW
+export P2MW.S_ModularCurve_qExpand_image_intFormRatiosC_subset (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups in
+theorem ModularCurve.qExpand_image_intFormRatiosC_subset (K : Type*) [Field K]
+    {Γ Γ' : Subgroup SL(2, ℤ)} [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ) (ℓ : ℕ) [NeZero ℓ]
+    (hΓ' : ∀ γ ∈ Γ', ∃ γ₁ ∈ Γ,
+      γ₁ 0 0 = γ 0 0 ∧ γ₁ 0 1 = (ℓ : ℤ) * γ 0 1 ∧ (ℓ : ℤ) * γ₁ 1 0 = γ 1 0 ∧ γ₁ 1 1 = γ 1 1) :
+    ModularCurve.qExpand K ℓ '' ModularCurve.intFormRatiosC K Γ ⊆
+      ModularCurve.intFormRatiosC K Γ' :=
+  solution K hT ℓ hΓ'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_qExpand_jqModC_eq_pow_unconditional.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_qExpand_jqModC_eq_pow_unconditional.lean
new file mode 100644
index 0000000000..078c964e7d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_qExpand_jqModC_eq_pow_unconditional.lean
@@ -0,0 +1,183 @@
+/-
+Based on Prove2Me node ModularCurve.qExpand_jqModC_eq_pow_unconditional
+(b852b094-d026-59b0-a6b0-e4f7cd340346) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a97c6c7b-6778-5951-a433-3e73695aadab
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_map_intCast_pow_char_eq_qExpand
+import Mathlib.RingTheory.Algebraic.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Frobenius identity ̄ j(q^ℓ) = ̄ j(q)^ℓ in characteristic ℓ
+
+Theorem statement: `ModularCurve.qExpand_jqModC_eq_pow_unconditional`
+(`b852b094-d026-59b0-a6b0-e4f7cd340346`), by Claude, 2026-09-05.
+
+Proof: submission `a97c6c7b-6778-5951-a433-3e73695aadab`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a commutative ring, $\ell$ a prime number, and suppose $K$ has characteristic $\ell$.
+Write $\bar j =$ `jqModC K` for the element of the Laurent series field `LaurentSeries K` given by
+$\mathrm{single}(-1,1)$ times the image under `HahnSeries.ofPowerSeries ℤ K` of the coefficientwise
+reduction along `Int.castRingHom K` of the integral power series `jNum` $=$ `eisenstein4 ^ 3 *
+dedekindEtaUnitInv`; thus $\bar j$ is $q^{-1}$ times the reduction in $K$ of the integral $q$-series
+$E_4^3\eta^{-24}$, i.e. the $q$-expansion of the modular $j$-invariant with its coefficients read in
+$K$. Write `qExpand K ℓ` for the ring endomorphism of `LaurentSeries K` obtained by transporting the
+support along multiplication by $\ell$ on $\mathbb{Z}$, that is, the substitution $q \mapsto
+q^{\ell}$. The assertion is the equality
+$$\bar j(q^{\ell}) = \bar j(q)^{\ell}$$
+in `LaurentSeries K`, i.e. `qExpand K ℓ (jqModC K) = (jqModC K) ^ ℓ`. No finiteness, perfectness or
+field hypothesis on $K$ is imposed.
+
+This is the $q$-expansion identity underlying Kronecker's congruence for the modular polynomial
+$\Phi_\ell$ in characteristic $\ell$; no statement about $\Phi_\ell$ itself is made here. It serves
+the study of the mod-$\ell$ geometry of modular curves and their charts, and is cited widely in that
+development.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_qExpand_jqModC_eq_pow_unconditional.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_qExpand_jqModC_eq_pow_unconditional
+
+noncomputable section
+open HahnSeries
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC jqNModC jqModC_eq_map_intCast qExpand qExpand_congr \
+  qExpand_qExpand jNum constantCoeff_jNum ofPowerSeries_coeff_of_neg jq_pow \
+  map_intCast_pow_char_eq_qExpand"
+p2m_open "ModularCurve"
+namespace CharLRows
+
+variable (K : Type*) [CommRing K]
+
+theorem jqModC_pow (n : ℕ) :
+    (jqModC K) ^ n = HahnSeries.single (-(n : ℤ)) 1 *
+      HahnSeries.ofPowerSeries ℤ K ((jNum.map (Int.castRingHom K)) ^ n) := by
+  have h : n • (-1 : ℤ) = -(n : ℤ) := by simp
+  rw [jqModC, mul_pow, HahnSeries.single_pow, one_pow, h, ← map_pow]
+
+theorem constantCoeff_jNum_map : PowerSeries.constantCoeff (jNum.map (Int.castRingHom K)) = 1 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff, PowerSeries.coeff_map,
+    PowerSeries.coeff_zero_eq_constantCoeff,
+    constantCoeff_jNum, map_one]
+
+theorem coeff_jqModC_pow_self (n : ℕ) : ((jqModC K) ^ n).coeff (-(n : ℤ)) = 1 := by
+  rw [jqModC_pow, HahnSeries.coeff_single_mul, one_mul, sub_neg_eq_add, neg_add_cancel,
+    show (0 : ℤ) = ((0 : ℕ) : ℤ) from rfl, HahnSeries.ofPowerSeries_apply_coeff,
+    PowerSeries.coeff_zero_eq_constantCoeff, map_pow, constantCoeff_jNum_map, one_pow]
+
+theorem coeff_jqModC_pow_of_lt {n : ℕ} {m : ℤ} (hm : m < -(n : ℤ)) :
+    ((jqModC K) ^ n).coeff m = 0 := by
+  rw [jqModC_pow, HahnSeries.coeff_single_mul, one_mul]
+  exact ofPowerSeries_coeff_of_neg _ (by omega)
+
+theorem coeff_jqModC_neg_one : (jqModC K).coeff (-1 : ℤ) = 1 := by
+  simpa using coeff_jqModC_pow_self K 1
+
+theorem algebraMap_laurentSeries_eq_single (c : K) :
+    algebraMap K (LaurentSeries K) c = HahnSeries.single 0 c := by
+  have h1 : algebraMap K (PowerSeries K) c = PowerSeries.C c := by simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+  rfl
+
+theorem aeval_jqModC_eq_zero {p : Polynomial K} (hp : Polynomial.aeval (jqModC K) p = 0) :
+    p = 0 := by
+  by_contra hp0
+  set n := p.natDegree with hn
+  have hcoeff : (Polynomial.aeval (jqModC K) p).coeff (-(n : ℤ)) = p.coeff n := by
+    rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+      Finset.sum_eq_single n]
+    · rw [algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_zero_mul,
+        coeff_jqModC_pow_self, mul_one]
+    · intro i hi hin
+      have hilt : i < n := lt_of_le_of_ne (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hin
+      rw [algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_zero_mul,
+        coeff_jqModC_pow_of_lt, mul_zero]
+      omega
+    · intro hn'
+      exact absurd (Finset.self_mem_range_succ n) hn'
+  rw [hp] at hcoeff
+  simp only [HahnSeries.coeff_zero] at hcoeff
+  exact hp0 (Polynomial.leadingCoeff_eq_zero.mp hcoeff.symm)
+
+theorem transcendental_jqModC : Transcendental K (jqModC K) :=
+  transcendental_iff.mpr fun _ hp => aeval_jqModC_eq_zero K hp
+
+theorem jqModC_ne_zero [Nontrivial K] : jqModC K ≠ 0 := by
+  intro h
+  have h1 : (jqModC K).coeff (-1 : ℤ) = 1 := coeff_jqModC_neg_one K
+  rw [h, HahnSeries.coeff_zero] at h1
+  exact zero_ne_one h1
+
+theorem order_jqModC [Nontrivial K] : (jqModC K).order = -1 := by
+  refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero ?_) ?_
+  · rw [coeff_jqModC_neg_one]
+    exact one_ne_zero
+  · by_contra hlt
+    rw [not_le] at hlt
+    refine HahnSeries.coeff_order_eq_zero.not.mpr (jqModC_ne_zero K) ?_
+    have h := coeff_jqModC_pow_of_lt K (n := 1) (m := (jqModC K).order)
+      (by simpa using hlt)
+    simpa using h
+
+theorem qExpand_jqModC_eq_pow (ℓ : ℕ) [Fact ℓ.Prime] [CharP K ℓ] :
+    qExpand K ℓ (jqModC K) = (jqModC K) ^ ℓ := by
+  rw [jqModC_eq_map_intCast K]
+  exact (map_intCast_pow_char_eq_qExpand ℓ _).symm
+
+theorem qExpand_jqNModC_eq_pow (N : ℕ) [NeZero N] (ℓ : ℕ) [Fact ℓ.Prime] [CharP K ℓ] :
+    qExpand K ℓ (jqNModC K N) = (jqNModC K N) ^ ℓ := by
+  rw [jqNModC, qExpand_qExpand, qExpand_congr (mul_comm ℓ N), ← qExpand_qExpand,
+    qExpand_jqModC_eq_pow K ℓ, map_pow]
+
+theorem frobenius_identity_geom (ℓ : ℕ) [Fact ℓ.Prime] [CharP K ℓ] :
+    jqNModC K ℓ = (jqModC K) ^ ℓ := by
+  rw [jqNModC]; exact qExpand_jqModC_eq_pow K ℓ
+
+end CharLRows
+
+end ModularCurve
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_qExpand_jqModC_eq_pow_unconditional.ModularCurve
+  in
+theorem solution (K : Type*) [CommRing K] {ℓ : ℕ} [Fact ℓ.Prime] [CharP K ℓ] :
+    qExpand K ℓ (jqModC K) = (jqModC K) ^ ℓ :=
+  CharLRows.qExpand_jqModC_eq_pow K ℓ
+
+end S_ModularCurve_qExpand_jqModC_eq_pow_unconditional
+end P2MW
+export P2MW.S_ModularCurve_qExpand_jqModC_eq_pow_unconditional (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.qExpand_jqModC_eq_pow_unconditional (K : Type*) [CommRing K] {ℓ : ℕ}
+    [Fact ℓ.Prime] [CharP K ℓ] :
+    qExpand K ℓ (jqModC K) = (jqModC K) ^ ℓ :=
+  solution K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_qExpansion_E4_eq_map_eisenstein4.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_qExpansion_E4_eq_map_eisenstein4.lean
new file mode 100644
index 0000000000..16d7b04981
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_qExpansion_E4_eq_map_eisenstein4.lean
@@ -0,0 +1,100 @@
+/-
+Based on Prove2Me node ModularCurve.qExpansion_E4_eq_map_eisenstein4
+(24fcb766-5d41-5d56-976b-59ad4bde647b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7b1feb85-48db-5059-8057-aadc774bbe0a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import Mathlib.NumberTheory.ModularForms.EisensteinSeries.QExpansion
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# q-expansion of E₄ equals 1+240sumσ₃(n)qⁿ
+
+Theorem statement: `ModularCurve.qExpansion_E4_eq_map_eisenstein4`
+(`24fcb766-5d41-5d56-976b-59ad4bde647b`), by Claude, 2026-09-05.
+
+Proof: submission `7b1feb85-48db-5059-8057-aadc774bbe0a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+The statement compares two power series with no hypotheses or parameters. On the analytic side,
+`UpperHalfPlane.qExpansion 1 ⇑ModularForm.E₄` is Mathlib's $q$-expansion, with respect to the period
+$1$, of the function underlying the weight-$4$ normalised Eisenstein series `ModularForm.E₄` on the
+upper half-plane; it is the element of $\mathbb{C}[[q]]$ whose $n$-th coefficient is the $n$-th
+Taylor coefficient at $q=0$ of the function of $q=e^{2\pi i\tau}$ induced by $E_4$. On the formal
+side, [`ModularCurve.eisenstein4`](def/ModularCurve_X0.html#L111) is the power series over
+$\mathbb{Z}$ whose $n$-th coefficient is $1$ when $n=0$ and $240\sum_{d\mid n} d^3$ otherwise, the
+sum being over the divisors of $n$ in the sense of `Nat.divisors`; `PowerSeries.map (Int.castRingHom
+ℂ)` applies the canonical ring homomorphism $\mathbb{Z}\to\mathbb{C}$ to each coefficient. The
+assertion is that these two elements of $\mathbb{C}[[q]]$ coincide, i.e. that $E_4(\tau) = 1 +
+240\sum_{n\ge 1}\sigma_3(n)q^n$ coefficientwise as formal power series.
+
+This is the classical $q$-expansion of the normalised weight-$4$ Eisenstein series for
+$\mathrm{SL}_2(\mathbb{Z})$. It identifies the purely formal integral series used in the
+$q$-expansion description of modular curves and their function fields with the analytic modular form
+`ModularForm.E₄`, and is used by the level-structure and Tate-curve computations that invoke $E_4$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_qExpansion_E4_eq_map_eisenstein4.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_qExpansion_E4_eq_map_eisenstein4
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology
+open scoped MatrixGroups PowerSeries.WithPiTopology
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+p2m_export "ModularCurve" "eisenstein4"
+end ModularCurve
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_qExpansion_E4_eq_map_eisenstein4.ModularCurve in
+theorem solution :
+    UpperHalfPlane.qExpansion 1 ⇑ModularForm.E₄ = PowerSeries.map (Int.castRingHom ℂ)
+      ModularCurve.eisenstein4 := by
+  ext m
+  rw [EisensteinSeries.E_qExpansion_coeff _ ⟨2, rfl⟩ m, PowerSeries.coeff_map, eisenstein4,
+    PowerSeries.coeff_mk]
+  split_ifs with hm
+  · simp
+  · rw [bernoulli_eq_bernoulli'_of_ne_one (by norm_num), bernoulli'_four,
+      ArithmeticFunction.sigma_apply]
+    simp only [eq_intCast, Int.cast_mul, Int.cast_ofNat, Int.cast_sum, Int.cast_pow,
+      Int.cast_natCast]
+    push_cast
+    ring
+end
+
+end S_ModularCurve_qExpansion_E4_eq_map_eisenstein4
+end P2MW
+export P2MW.S_ModularCurve_qExpansion_E4_eq_map_eisenstein4 (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.qExpansion_E4_eq_map_eisenstein4 :
+    UpperHalfPlane.qExpansion 1 ⇑ModularForm.E₄ = PowerSeries.map (Int.castRingHom ℂ)
+      ModularCurve.eisenstein4 :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_qExpansion_E6_eq_map_mk.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_qExpansion_E6_eq_map_mk.lean
new file mode 100644
index 0000000000..f7ee45e902
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_qExpansion_E6_eq_map_mk.lean
@@ -0,0 +1,106 @@
+/-
+Based on Prove2Me node ModularCurve.qExpansion_E6_eq_map_mk
+(927fc600-c5bf-52bb-9838-92e6faf0f968) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission cec48452-744c-5462-9081-67e7c0622c1f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import Mathlib.NumberTheory.ModularForms.EisensteinSeries.QExpansion
+
+import Mathlib.NumberTheory.Bernoulli
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integral q-expansion of E₆
+
+Theorem statement: `ModularCurve.qExpansion_E6_eq_map_mk` (`927fc600-c5bf-52bb-9838-92e6faf0f968`),
+by Claude, 2026-09-05.
+
+Proof: submission `cec48452-744c-5462-9081-67e7c0622c1f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+The assertion is an identity of formal power series over $\mathbb{C}$. On the left is
+`UpperHalfPlane.qExpansion 1` applied to the underlying function of `ModularForm.E₆`, i.e. the
+$q$-expansion of width $1$ (so $q = e^{2\pi i \tau}$) of the normalised weight-$6$ Eisenstein series
+for the full modular group $\mathrm{SL}_2(\mathbb{Z})$, whose $n$-th coefficient is the $n$-th
+Taylor coefficient at $0$ of the function on the punctured disc induced by $E_6$. On the right is
+the image, under the coefficient-wise map induced by the ring homomorphism $\mathbb{Z} \to
+\mathbb{C}$, of the power series in $\mathbb{Z}[[q]]$ whose $n$-th coefficient is $1$ for $n = 0$
+and $-504 \sum_{d \mid n} d^5$ for $n \ge 1$, the sum being over the divisors of $n$. Thus $E_6$ has
+constant term $1$ and all coefficients integral, namely $E_6 = 1 - 504\sum_{n \ge 1}\sigma_5(n)q^n$;
+there are no hypotheses or variables.
+
+This is the classical integral $q$-expansion of the weight-$6$ normalised Eisenstein series.
+Together with the analogous expansions for $E_4$ and $\Delta$ it supplies integral series with
+constant term $1$ by which forms of low weight may be multiplied into weight $12$; it is invoked in
+the construction of weight-one Tate-curve base changes and cusp data on modular curves of full
+level.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_qExpansion_E6_eq_map_mk.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_qExpansion_E6_eq_map_mk
+
+open UpperHalfPlane ModularForm Finset
+
+private lemma bernoulli'_five_s18 : bernoulli' 5 = 0 :=
+  bernoulli'_eq_zero_of_odd (by decide) (by norm_num)
+
+private lemma bernoulli'_six_s18 : bernoulli' 6 = 1 / 42 := by
+  rw [bernoulli'_def]
+  norm_num [Finset.sum_range_succ, bernoulli'_zero, bernoulli'_one, bernoulli'_two,
+    bernoulli'_three, bernoulli'_four, bernoulli'_five_s18, Nat.choose]
+
+private lemma bernoulli_six_s18 : bernoulli 6 = 1 / 42 := by
+  rw [bernoulli_eq_bernoulli'_of_ne_one (by norm_num), bernoulli'_six_s18]
+
+theorem solution :
+    UpperHalfPlane.qExpansion 1 ⇑ModularForm.E₆ =
+      PowerSeries.map (Int.castRingHom ℂ)
+        (PowerSeries.mk fun n => if n = 0 then 1 else -504 * ∑ d ∈ n.divisors, (d : ℤ) ^ 5) := by
+  ext m
+  rw [show (ModularForm.E₆ : ModularForm _ 6) = E (by norm_num : 3 ≤ 6) from rfl]
+  rw [EisensteinSeries.E_qExpansion_coeff (by norm_num : 3 ≤ 6) (by decide) m]
+  simp only [PowerSeries.coeff_map, PowerSeries.coeff_mk]
+  split_ifs with hm
+  · simp
+  · have hB : (bernoulli 6 : ℂ) = 1 / 42 := by
+      rw [bernoulli_six_s18]; push_cast; ring
+    rw [ArithmeticFunction.sigma_apply]
+    push_cast
+    rw [hB]
+    norm_num
+
+end S_ModularCurve_qExpansion_E6_eq_map_mk
+end P2MW
+export P2MW.S_ModularCurve_qExpansion_E6_eq_map_mk (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane ModularForm Finset
+theorem ModularCurve.qExpansion_E6_eq_map_mk :
+    UpperHalfPlane.qExpansion 1 ⇑ModularForm.E₆ =
+      PowerSeries.map (Int.castRingHom ℂ)
+        (PowerSeries.mk fun n => if n = 0 then 1 else -504 * ∑ d ∈ n.divisors, (d : ℤ) ^ 5) :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_qExpansion_discriminant_eq_X_mul_tprod.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_qExpansion_discriminant_eq_X_mul_tprod.lean
new file mode 100644
index 0000000000..6f545624e6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_qExpansion_discriminant_eq_X_mul_tprod.lean
@@ -0,0 +1,270 @@
+/-
+Based on Prove2Me node ModularCurve.qExpansion_discriminant_eq_X_mul_tprod
+(7b620c6f-aea9-5c41-881b-5c8cdb8e88d6) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3573c225-a393-504e-a31d-98408b63aabf
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import Mathlib.RingTheory.PowerSeries.PiTopology
+
+import Mathlib.Analysis.Complex.TaylorSeries
+import Mathlib.Analysis.Calculus.Deriv.Polynomial
+import Mathlib.Analysis.Complex.LocallyUniformLimit
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# q-expansion of Δ as a formal product
+
+Theorem statement: `ModularCurve.qExpansion_discriminant_eq_X_mul_tprod`
+(`7b620c6f-aea9-5c41-881b-5c8cdb8e88d6`), by Claude, 2026-09-05.
+
+Proof: submission `3573c225-a393-504e-a31d-98408b63aabf`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+The statement is a closed identity in the ring $\mathbb{C}[[X]]$ of formal power series over
+$\mathbb{C}$, with no variables or hypotheses. On the left stands `UpperHalfPlane.qExpansion 1
+ModularForm.discriminant`: the formal $q$-expansion, with respect to the period $1$, of the modular
+discriminant $\Delta$ on the upper half-plane, i.e. the power series whose $n$-th coefficient is the
+$n$-th Taylor coefficient at $q=0$ of the function on the punctured unit disc obtained from
+$\Delta(\tau)$ by the substitution $q=e^{2\pi i\tau}$. On the right stands the formal power series
+$X\cdot\prod'_{n\in\mathbb{N}}(1-X^{n+1})^{24}$, where the unordered product $\prod'$ is the
+unconditional (multipliable) product in `PowerSeries ℂ` taken with respect to the coefficientwise,
+i.e. $X$-adic, topology supplied by the `PowerSeries.WithPiTopology` scope; the indexing runs over
+all natural numbers $n\ge 0$, so the factors are $(1-X^{m})^{24}$ for $m\ge 1$. The assertion is
+that these two power series are equal, that is, $\sum_{n\ge 0}\tau(n)X^{n} = X\prod_{m\ge
+1}(1-X^{m})^{24}$.
+
+This is the classical product formula for the discriminant $\Delta = \eta^{24}$, here in its formal
+rather than pointwise form: it transfers the analytic identity $\Delta =
+q\prod_{m\ge1}(1-q^{m})^{24}$ into an identity of formal power series, where the coefficients
+$\tau(n)$ can be manipulated algebraically. It is used to identify the $q$-expansion of $\Delta$
+with the image of $X$ times the Dedekind eta unit, in
+[`ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit`]
+(thm.html#ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_qExpansion_discriminant_eq_X_mul_tprod.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_qExpansion_discriminant_eq_X_mul_tprod
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology
+open scoped MatrixGroups PowerSeries.WithPiTopology
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+
+open Polynomial in
+private def truncPoly (N : ℕ) : ℂ[X] := ∏ n ∈ Finset.range N, (1 - Polynomial.X ^ (n + 1)) ^ 24
+
+private def etaPow : PowerSeries ℂ := ∏' n : ℕ, (1 - PowerSeries.X ^ (n + 1)) ^ 24
+
+private def gfun (q : ℂ) : ℂ := ∏' n : ℕ, (1 - q ^ (n + 1)) ^ 24
+
+private lemma multipliable_factor_pow :
+    Multipliable fun n : ℕ => ((1 : PowerSeries ℂ) - PowerSeries.X ^ (n + 1)) ^ 24 :=
+  (PowerSeries.WithPiTopology.multipliable_one_sub_X_pow ℂ).pow 24
+
+private lemma coeff_mul_factor_eq {m n : ℕ} (hmn : m < n + 1) (Q : PowerSeries ℂ) :
+    PowerSeries.coeff m (Q * ((1 : PowerSeries ℂ) - PowerSeries.X ^ (n + 1)) ^ 24) =
+      PowerSeries.coeff m Q := by
+  obtain ⟨R, hR⟩ : PowerSeries.X ^ (n + 1) ∣
+      ((1 : PowerSeries ℂ) - PowerSeries.X ^ (n + 1)) ^ 24 - 1 := by
+    have h := sub_dvd_pow_sub_pow ((1 : PowerSeries ℂ) - PowerSeries.X ^ (n + 1)) 1 24
+    rw [one_pow, sub_sub_cancel_left] at h
+    exact neg_dvd.mp h
+  replace hR : ((1 : PowerSeries ℂ) - PowerSeries.X ^ (n + 1)) ^ 24 =
+      1 + PowerSeries.X ^ (n + 1) * R := by
+    rw [← hR]; ring
+  rw [hR, mul_add, mul_one, map_add, ← mul_assoc, mul_comm Q, mul_assoc,
+    PowerSeries.coeff_X_pow_mul', ite_eq_right (not_le.mpr hmn), add_zero]
+
+private lemma coeff_trunc_eq_coeff_etaPow (m : ℕ) {N : ℕ} (hN : m < N) :
+    PowerSeries.coeff m (∏ n ∈ Finset.range N, ((1 : PowerSeries ℂ) - PowerSeries.X ^ (n + 1)) ^ 24)
+      =
+      PowerSeries.coeff m etaPow := by
+  have hlim : Tendsto (fun N => PowerSeries.coeff m
+      (∏ n ∈ Finset.range N, ((1 : PowerSeries ℂ) - PowerSeries.X ^ (n + 1)) ^ 24)) atTop
+      (𝓝 (PowerSeries.coeff m etaPow)) :=
+    ((PowerSeries.WithPiTopology.continuous_coeff ℂ m).tendsto _).comp
+      multipliable_factor_pow.hasProd.tendsto_prod_nat
+  have hconst : ∀ N', m < N' → ∀ N, N' ≤ N →
+      PowerSeries.coeff m (∏ n ∈ Finset.range N, ((1 : PowerSeries ℂ) - PowerSeries.X ^ (n + 1)) ^
+        24) =
+      PowerSeries.coeff m (∏ n ∈ Finset.range N', ((1 : PowerSeries ℂ) - PowerSeries.X ^ (n + 1)) ^
+        24) := by
+    intro N' hN' N hle
+    induction N, hle using Nat.le_induction with
+    | base => rfl
+    | succ N hle ih => rw [Finset.prod_range_succ, coeff_mul_factor_eq (by omega), ih]
+  have hev : (fun N => PowerSeries.coeff m
+      (∏ n ∈ Finset.range N, ((1 : PowerSeries ℂ) - PowerSeries.X ^ (n + 1)) ^ 24)) =ᶠ[atTop]
+      fun _ => PowerSeries.coeff m
+        (∏ n ∈ Finset.range N, ((1 : PowerSeries ℂ) - PowerSeries.X ^ (n + 1)) ^ 24) :=
+    eventually_atTop.mpr ⟨N, fun N'' h => hconst N hN N'' h⟩
+  exact (tendsto_nhds_unique (hlim.congr' hev) tendsto_const_nhds).symm
+
+open Polynomial in
+private lemma truncPoly_toPowerSeries (N : ℕ) :
+    ((truncPoly N : ℂ[X]) : PowerSeries ℂ) =
+      ∏ n ∈ Finset.range N, ((1 : PowerSeries ℂ) - PowerSeries.X ^ (n + 1)) ^ 24 := by
+  rw [truncPoly, ← Polynomial.coeToPowerSeries.ringHom_apply, map_prod]
+  simp [Polynomial.coeToPowerSeries.ringHom_apply, Polynomial.coe_pow, Polynomial.coe_X]
+
+open Polynomial in
+private lemma iterate_deriv_polynomial_eval (p : ℂ[X]) (m : ℕ) :
+    deriv^[m] (fun q : ℂ => p.eval q) = fun q => (derivative^[m] p).eval q := by
+  induction m generalizing p with
+  | zero => rfl
+  | succ m ih =>
+    rw [Function.iterate_succ', Function.comp_apply, ih, Function.iterate_succ',
+      Function.comp_apply]
+    funext q
+    exact Polynomial.deriv _
+
+open Polynomial in
+private lemma truncPoly_eval (N : ℕ) (q : ℂ) :
+    (truncPoly N).eval q = ∏ n ∈ Finset.range N, (1 - q ^ (n + 1)) ^ 24 := by
+  simp [truncPoly, Polynomial.eval_prod]
+
+private lemma tendstoLocallyUniformlyOn_trunc :
+    TendstoLocallyUniformlyOn (fun N q => ∏ n ∈ Finset.range N, (1 - q ^ (n + 1)) ^ 24) gfun atTop
+      (Metric.ball (0 : ℂ) 1) := by
+  have h1 : TendstoLocallyUniformlyOn (fun N q => ∏ n ∈ Finset.range N, (1 - q ^ (n + 1)))
+      (fun q => ∏' n : ℕ, (1 - q ^ (n + 1))) atTop (Metric.ball (0 : ℂ) 1) := by
+    have := ModularForm.multipliableLocallyUniformlyOn_one_sub_pow.hasProdLocallyUniformlyOn
+      |>.tendstoLocallyUniformlyOn_finsetRange
+    refine this.congr (fun N => ?_)
+    intro q _
+    simp
+  have hc : ContinuousOn (fun q : ℂ => ∏' n : ℕ, (1 - q ^ (n + 1))) (Metric.ball (0 : ℂ) 1) :=
+    ModularForm.differentiableOn_tprod_one_sub_pow.continuousOn
+  have hpow : ∀ k : ℕ, TendstoLocallyUniformlyOn
+      (fun N q => (∏ n ∈ Finset.range N, (1 - q ^ (n + 1))) ^ k)
+      (fun q => (∏' n : ℕ, (1 - q ^ (n + 1))) ^ k) atTop (Metric.ball (0 : ℂ) 1) := by
+    intro k
+    induction k with
+    | zero =>
+      simp only [pow_zero]
+      intro u hu x _
+      exact ⟨Set.univ, Filter.univ_mem, Eventually.of_forall fun n y _ => refl_mem_uniformity hu⟩
+    | succ k ih =>
+      simp only [pow_succ]
+      exact ih.mul₀ h1 (hc.pow k) hc
+  refine ((hpow 24).congr fun N q _ => ?_).congr_right fun q hq => ?_
+  · exact (Finset.prod_pow _ _ _).symm
+  · exact ((ModularForm.multipliable_one_sub_pow (by simpa using hq)).tprod_pow 24).symm
+
+private lemma differentiableOn_gfun : DifferentiableOn ℂ gfun (Metric.ball (0 : ℂ) 1) :=
+  ModularForm.differentiableOn_tprod_one_sub_pow_pow 24
+
+open Polynomial in
+private lemma tendstoLocallyUniformlyOn_iterate_deriv_trunc (m : ℕ) :
+    TendstoLocallyUniformlyOn (fun N q => (derivative^[m] (truncPoly N)).eval q) (deriv^[m] gfun)
+      atTop (Metric.ball (0 : ℂ) 1) := by
+  induction m with
+  | zero =>
+    simpa only [Function.iterate_zero, id_eq, truncPoly_eval] using tendstoLocallyUniformlyOn_trunc
+  | succ m ih =>
+    have h :=
+      ih.deriv (Eventually.of_forall fun N => (Polynomial.differentiable _).differentiableOn)
+      Metric.isOpen_ball
+    rw [Function.iterate_succ', Function.iterate_succ']
+    refine h.congr fun N q _ => ?_
+    simp only [Function.comp_apply, Polynomial.deriv]
+
+open Polynomial in
+private lemma iteratedDeriv_gfun_zero (m : ℕ) :
+    iteratedDeriv m gfun 0 = m.factorial * PowerSeries.coeff m etaPow := by
+  have h0 : (0 : ℂ) ∈ Metric.ball (0 : ℂ) 1 := Metric.mem_ball_self one_pos
+  have hlim : Tendsto (fun N => (derivative^[m] (truncPoly N)).eval 0) atTop
+      (𝓝 (deriv^[m] gfun 0)) :=
+    (tendstoLocallyUniformlyOn_iterate_deriv_trunc m).tendsto_at h0
+  have hev : (fun N => (derivative^[m] (truncPoly N)).eval 0) =ᶠ[atTop]
+      fun _ => (m.factorial : ℂ) * PowerSeries.coeff m etaPow := by
+    refine eventually_atTop.mpr ⟨m + 1, fun N hN => ?_⟩
+    simp only
+    rw [← Polynomial.coeff_zero_eq_eval_zero, Polynomial.coeff_iterate_derivative, zero_add,
+      Nat.descFactorial_self, nsmul_eq_mul, ← Polynomial.coeff_coe, truncPoly_toPowerSeries,
+      coeff_trunc_eq_coeff_etaPow m (by omega)]
+  rw [iteratedDeriv_eq_iterate]
+  exact tendsto_nhds_unique hlim (tendsto_const_nhds.congr' hev.symm)
+
+private lemma hasSum_coeff_etaPow {q : ℂ} (hq : ‖q‖ < 1) :
+    HasSum (fun m : ℕ => PowerSeries.coeff m etaPow * q ^ m) (gfun q) := by
+  have hq' : q ∈ Metric.ball (0 : ℂ) 1 := by simpa using hq
+  have h := Complex.hasSum_taylorSeries_on_ball differentiableOn_gfun hq'
+  refine h.congr_fun fun m => ?_
+  rw [iteratedDeriv_gfun_zero, sub_zero, smul_eq_mul, smul_eq_mul]
+  field_simp
+  rw [mul_div_assoc, div_self (Nat.cast_ne_zero.mpr (Nat.factorial_ne_zero m)), mul_one]
+
+private lemma hasSum_coeff_X_mul_etaPow {q : ℂ} (hq : ‖q‖ < 1) :
+    HasSum (fun m : ℕ => PowerSeries.coeff m (PowerSeries.X * etaPow) * q ^ m) (q * gfun q) := by
+  have h := (hasSum_coeff_etaPow hq).mul_left q
+  rw [← hasSum_nat_add_iff' 1]
+  simp only [Finset.range_one, Finset.sum_singleton, pow_zero, mul_one,
+    PowerSeries.coeff_zero_X_mul,
+    sub_zero]
+  refine h.congr_fun fun m => ?_
+  rw [PowerSeries.coeff_succ_X_mul, pow_succ]
+  ring
+
+private lemma discriminant_eq_qParam_mul_gfun (τ : ℍ) :
+    ModularForm.discriminant τ = 𝕢 1 (τ : ℂ) * gfun (𝕢 1 (τ : ℂ)) := by
+  rw [ModularForm.discriminant_eq_q_prod, gfun]
+
+end ModularCurve
+
+open ModularCurve in
+theorem solution :
+    UpperHalfPlane.qExpansion 1 ModularForm.discriminant = PowerSeries.X * ∏' n : ℕ, ((1 :
+      PowerSeries ℂ) - PowerSeries.X ^ (n + 1)) ^ 24 := by
+  have hsum : ∀ τ : ℍ, HasSum (fun m : ℕ =>
+      PowerSeries.coeff m (PowerSeries.X * etaPow) • 𝕢 1 (τ : ℂ) ^ m) (CuspForm.discriminant τ) :=
+        by
+    intro τ
+    simp_rw [smul_eq_mul, CuspForm.coe_discriminant, discriminant_eq_qParam_mul_gfun τ]
+    exact hasSum_coeff_X_mul_etaPow (by exact_mod_cast UpperHalfPlane.norm_qParam_lt_one 1 τ)
+  ext m
+  have h := ModularFormClass.qExpansion_coeff_unique one_pos
+    one_mem_strictPeriods_SL (f := CuspForm.discriminant) hsum m
+  rw [CuspForm.coe_discriminant] at h
+  rw [← h]
+  rfl
+end
+
+end S_ModularCurve_qExpansion_discriminant_eq_X_mul_tprod
+end P2MW
+export P2MW.S_ModularCurve_qExpansion_discriminant_eq_X_mul_tprod (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped PowerSeries.WithPiTopology
+theorem ModularCurve.qExpansion_discriminant_eq_X_mul_tprod :
+    UpperHalfPlane.qExpansion 1 ModularForm.discriminant = PowerSeries.X * ∏' n : ℕ, ((1 :
+      PowerSeries ℂ) - PowerSeries.X ^ (n + 1)) ^ 24 :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit.lean
new file mode 100644
index 0000000000..5e08b55ed2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit.lean
@@ -0,0 +1,151 @@
+/-
+Based on Prove2Me node ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit
+(088c8d45-fb84-58cb-a56c-0cfe518effa7) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 079dba7f-ee83-5e53-9ee0-393d94b2828c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_discriminant_eq_X_mul_tprod
+import Mathlib.RingTheory.PowerSeries.PiTopology
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# q-expansion of Δ as integral series qprod(1-qⁿ)²⁴
+
+Theorem statement: `ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit`
+(`088c8d45-fb84-58cb-a56c-0cfe518effa7`), by Claude, 2026-09-05.
+
+Proof: submission `079dba7f-ee83-5e53-9ee0-393d94b2828c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+The statement is a closed identity in `PowerSeries ℂ`, with no variables or hypotheses. On the left
+stands `UpperHalfPlane.qExpansion 1 ModularForm.discriminant`, Mathlib's $q$-expansion of period $1$
+at the cusp $i\infty$ of the modular discriminant $\Delta$, i.e. the power series whose $n$-th
+coefficient is the $n$-th Taylor coefficient at $q=0$ of the function of $q$ induced by $\Delta$. On
+the right stands the coefficientwise image under the ring homomorphism $\mathbb{Z}\to\mathbb{C}$ of
+the integral series $X \cdot$ [`ModularCurve.dedekindEtaUnit`](def/ModularCurve_X0.html#L127), where
+[`ModularCurve.dedekindEtaUnit`](def/ModularCurve_X0.html#L127) is defined as the twenty-fourth
+power of [`ModularCurve.etaProd`](def/ModularCurve_X0.html#L119), itself the infinite product
+$\prod'_{n\,:\,\mathbb{N}} (1 - X^{n+1})$ in `PowerSeries ℤ` taken in the product (coefficientwise)
+topology. Thus the analytic $q$-expansion of $\Delta$ equals $q\prod_{n\ge 1}(1-q^n)^{24}$ with all
+coefficients obtained by casting integers into $\mathbb{C}$; in particular every coefficient of the
+$q$-expansion of $\Delta$ lies in the image of $\mathbb{Z}$.
+
+This is the classical product formula $\Delta = q\prod_{n\ge1}(1-q^n)^{24}$, in the form identifying
+the analytic $q$-expansion with the integral formal series used elsewhere in the development, so
+that integrality of the Ramanujan coefficients $\tau(n)$ and the normalisation $\tau(1)=1$ are
+available. It is used by the work on modular units and on $q$-expansions of forms on $X_0(N)$,
+including the level-one auxiliary results and congruences for coefficients of cusp forms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology
+open scoped MatrixGroups PowerSeries.WithPiTopology
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+p2m_export "ModularCurve" "etaProd dedekindEtaUnit qExpansion_discriminant_eq_X_mul_tprod"
+p2m_open "ModularCurve"
+
+private lemma coeff_mul_factor_eq' {R : Type*} [CommRing R] {m n : ℕ} (hmn : m < n + 1)
+    (Q : PowerSeries R) :
+    PowerSeries.coeff m (Q * ((1 : PowerSeries R) - PowerSeries.X ^ (n + 1)) ^ 24) =
+      PowerSeries.coeff m Q := by
+  obtain ⟨S, hS⟩ : PowerSeries.X ^ (n + 1) ∣
+      ((1 : PowerSeries R) - PowerSeries.X ^ (n + 1)) ^ 24 - 1 := by
+    have h := sub_dvd_pow_sub_pow ((1 : PowerSeries R) - PowerSeries.X ^ (n + 1)) 1 24
+    rw [one_pow, sub_sub_cancel_left] at h
+    exact neg_dvd.mp h
+  replace hS : ((1 : PowerSeries R) - PowerSeries.X ^ (n + 1)) ^ 24 =
+      1 + PowerSeries.X ^ (n + 1) * S := by
+    rw [← hS]; ring
+  rw [hS, mul_add, mul_one, map_add, ← mul_assoc, mul_comm Q, mul_assoc,
+    PowerSeries.coeff_X_pow_mul', ite_eq_right (not_le.mpr hmn), add_zero]
+
+private lemma coeff_trunc_eq_coeff_tprod (R : Type*) [CommRing R] [TopologicalSpace R]
+    [IsTopologicalRing R] [T2Space R] (m : ℕ) {N : ℕ} (hN : m < N) :
+    PowerSeries.coeff m (∏ n ∈ Finset.range N, ((1 : PowerSeries R) - PowerSeries.X ^ (n + 1)) ^ 24)
+      =
+      PowerSeries.coeff m (∏' n : ℕ, ((1 : PowerSeries R) - PowerSeries.X ^ (n + 1)) ^ 24) := by
+  have hmul : Multipliable fun n : ℕ => ((1 : PowerSeries R) - PowerSeries.X ^ (n + 1)) ^ 24 :=
+    (PowerSeries.WithPiTopology.multipliable_one_sub_X_pow R).pow 24
+  have hlim : Tendsto (fun N => PowerSeries.coeff m
+      (∏ n ∈ Finset.range N, ((1 : PowerSeries R) - PowerSeries.X ^ (n + 1)) ^ 24)) atTop
+      (𝓝 (PowerSeries.coeff m (∏' n : ℕ, ((1 : PowerSeries R) - PowerSeries.X ^ (n + 1)) ^ 24))) :=
+    ((PowerSeries.WithPiTopology.continuous_coeff R m).tendsto _).comp hmul.hasProd.tendsto_prod_nat
+  have hconst : ∀ N', N ≤ N' →
+      PowerSeries.coeff m (∏ n ∈ Finset.range N', ((1 : PowerSeries R) - PowerSeries.X ^ (n + 1)) ^
+        24) =
+      PowerSeries.coeff m (∏ n ∈ Finset.range N, ((1 : PowerSeries R) - PowerSeries.X ^ (n + 1)) ^
+        24) := by
+    intro N' hle
+    induction N', hle using Nat.le_induction with
+    | base => rfl
+    | succ N' hle ih => rw [Finset.prod_range_succ, coeff_mul_factor_eq' (by omega), ih]
+  have hev : (fun N' => PowerSeries.coeff m
+      (∏ n ∈ Finset.range N', ((1 : PowerSeries R) - PowerSeries.X ^ (n + 1)) ^ 24)) =ᶠ[atTop]
+      fun _ => PowerSeries.coeff m
+        (∏ n ∈ Finset.range N, ((1 : PowerSeries R) - PowerSeries.X ^ (n + 1)) ^ 24) :=
+    eventually_atTop.mpr ⟨N, hconst⟩
+  exact tendsto_nhds_unique tendsto_const_nhds (hlim.congr' hev)
+
+private lemma tprod_eq_map_dedekindEtaUnit :
+    (∏' n : ℕ, ((1 : PowerSeries ℂ) - PowerSeries.X ^ (n + 1)) ^ 24) =
+      dedekindEtaUnit.map (Int.castRingHom ℂ) := by
+  ext m
+  rw [dedekindEtaUnit, etaProd,
+    ← ((PowerSeries.WithPiTopology.multipliable_one_sub_X_pow ℤ).tprod_pow 24),
+    PowerSeries.coeff_map, ← coeff_trunc_eq_coeff_tprod ℂ m (Nat.lt_succ_self m),
+    ← coeff_trunc_eq_coeff_tprod ℤ m (Nat.lt_succ_self m), ← PowerSeries.coeff_map,
+    map_prod (PowerSeries.map (Int.castRingHom ℂ))]
+  simp
+
+end ModularCurve
+
+open _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit.ModularCurve in
+theorem solution :
+    UpperHalfPlane.qExpansion 1 ModularForm.discriminant = PowerSeries.map (Int.castRingHom ℂ)
+      (PowerSeries.X * ModularCurve.dedekindEtaUnit) := by
+  rw [qExpansion_discriminant_eq_X_mul_tprod, map_mul, PowerSeries.map_X,
+    tprod_eq_map_dedekindEtaUnit]
+end
+
+end S_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit
+end P2MW
+export P2MW.S_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit :
+    UpperHalfPlane.qExpansion 1 ModularForm.discriminant = PowerSeries.map (Int.castRingHom ℂ)
+      (PowerSeries.X * ModularCurve.dedekindEtaUnit) :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_qParam_coeff_unique.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_qParam_coeff_unique.lean
new file mode 100644
index 0000000000..287f1792e5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_qParam_coeff_unique.lean
@@ -0,0 +1,236 @@
+/-
+Based on Prove2Me node ModularCurve.qParam_coeff_unique
+(8190c564-9ec6-51fd-be96-ffe0839ea75f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5de8888d-fefe-5f7e-8aa9-ebd08656ab87
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Exp
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Manifold
+public import Mathlib.Analysis.Complex.UpperHalfPlane.FunctionsBoundedAtInfty
+
+import Mathlib.NumberTheory.ModularForms.QExpansion
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Uniqueness of q-expansion coefficients at period h
+
+Theorem statement: `ModularCurve.qParam_coeff_unique` (`8190c564-9ec6-51fd-be96-ffe0839ea75f`), by
+Claude, 2026-09-05.
+
+Proof: submission `5de8888d-fefe-5f7e-8aa9-ebd08656ab87`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $h$ be a real number with $h>0$, let $F$ be an arbitrary function from the upper half-plane
+$\mathfrak H$ to $\mathbb C$ (no holomorphy or modularity is assumed), and let $c,d\colon\mathbb
+N\to\mathbb C$ be two sequences of complex numbers. Write
+$q_h(\tau)=\mathrm{Function.Periodic.qParam}\,h\,\tau=e^{2\pi i\tau/h}$ for the standard
+$q$-parameter of period $h$, evaluated at the complex number underlying $\tau$. Assume that for
+every $\tau\in\mathfrak H$ the family $m\mapsto c_m\,q_h(\tau)^m$, indexed by $m\in\mathbb N$, is
+summable with sum $F(\tau)$, and likewise that for every $\tau\in\mathfrak H$ the family $m\mapsto
+d_m\,q_h(\tau)^m$ is summable with sum $F(\tau)$; here summability is unconditional summability in
+$\mathbb C$ (Lean's `HasSum`), so in particular both series converge at every point of $\mathfrak H$
+to the same value. The conclusion is the equality of the two sequences as functions $\mathbb
+N\to\mathbb C$, that is, $c_m=d_m$ for every $m\in\mathbb N$.
+
+This is the uniqueness half of the $q$-expansion principle at period $h$, stated for bare functions
+on the upper half-plane and bare coefficient sequences: a function determines its $q$-expansion
+coefficients. It is used in the treatment of Siegel units, where coefficients of $q$-expansions of
+modular forms and of their slashes are identified and shown to be integral, and it is the input to
+the corresponding uniqueness statement for Laurent-type expansions in $q_h$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_qParam_coeff_unique.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_qParam_coeff_unique
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology Function
+open scoped MatrixGroups ModularForm
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+
+namespace Realized
+
+variable {h : ℝ} {F : ℍ → ℂ} {c : ℕ → ℂ}
+
+lemma norm_qParam_lt_one_of_pos (hh : 0 < h) (τ : ℍ) : ‖𝕢 h (τ : ℂ)‖ < 1 := by
+  rw [Periodic.norm_qParam, Real.exp_lt_one_iff, neg_mul, coe_im, neg_mul, neg_div, neg_lt_zero]
+  exact div_pos (by positivity [τ.im_pos]) hh
+
+lemma hasSum_cuspFunction_punctured (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) {q : ℂ} (hq : ‖q‖ < 1)
+    (hq1 : q ≠ 0) : HasSum (fun m : ℕ => c m * q ^ m) (cuspFunction h F q) := by
+  have h1 := Periodic.im_invQParam_pos_of_norm_lt_one hh hq hq1
+  let τ : ℍ := ⟨Periodic.invQParam h q, h1⟩
+  have h2 := Periodic.cuspFunction_eq_of_nonzero h (F ∘ ofComplex) hq1
+  have h3 : cuspFunction h F q = F τ := by
+    simpa [τ, cuspFunction, UpperHalfPlane.ofComplex_apply_of_im_pos h1] using h2
+  have h4 : 𝕢 h (τ : ℂ) = q := Periodic.qParam_right_inv hh.ne' hq1
+  rw [h3, ← h4]
+  exact hF τ
+
+lemma hasFPowerSeriesOnBall_update (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) :
+    HasFPowerSeriesOnBall (update (cuspFunction h F) 0 (c 0)) (.ofScalars ℂ c) 0 1 := by
+  constructor
+  · refine le_of_forall_lt_imp_le_of_dense fun r hr ↦ ?_
+    rcases eq_or_ne r 0 with rfl | hr'
+    · simp
+    · lift r to NNReal using hr.ne_top
+      let : FiniteDimensional ℝ ℂ := basisOneI.finiteDimensional_of_finite
+      apply FormalMultilinearSeries.le_radius_of_summable
+      simpa [norm_mul, mul_comm] using
+        (hasSum_cuspFunction_punctured hh hF (q := r) (by simpa using hr)
+          (mod_cast hr')).summable.norm
+  · simp
+  · intro y hy
+    rw [zero_add]
+    rw [← ENNReal.coe_one, Metric.eball_coe, NNReal.coe_one, mem_ball_zero_iff] at hy
+    rcases eq_or_ne y 0 with rfl | hy'
+    · simpa +contextual [zero_pow_eq] using hasSum_ite_eq 0 (c 0)
+    · simpa [update_of_ne hy', mul_comm] using hasSum_cuspFunction_punctured hh hF hy hy'
+
+def discFun (h : ℝ) (F : ℍ → ℂ) (c : ℕ → ℂ) : ℂ → ℂ := update (cuspFunction h F) 0 (c 0)
+
+lemma hasSum_discFun (hh : 0 < h) (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ))
+    {q : ℂ} (hq : ‖q‖ < 1) : HasSum (fun m : ℕ => c m * q ^ m) (discFun h F c q) := by
+  have hy : q ∈ Metric.eball (0 : ℂ) 1 := by
+    rw [← ENNReal.coe_one, Metric.eball_coe]; simpa using hq
+  have h := (hasFPowerSeriesOnBall_update hh hF).hasSum hy
+  rw [zero_add] at h
+  simpa [discFun, mul_comm] using h
+
+lemma apply_eq_discFun (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ))
+    (τ : ℍ) : F τ = discFun h F c (𝕢 h (τ : ℂ)) :=
+  (hF τ).unique (hasSum_discFun hh hF (norm_qParam_lt_one_of_pos hh τ))
+
+lemma differentiableOn_discFun (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) :
+    DifferentiableOn ℂ (discFun h F c) (Metric.ball 0 1) := by
+  have h1 := (hasFPowerSeriesOnBall_update hh hF).differentiableOn
+  rwa [← ENNReal.coe_one, Metric.eball_coe, NNReal.coe_one] at h1
+
+lemma continuousAt_discFun (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) {q : ℂ} (hq : ‖q‖ < 1) :
+    ContinuousAt (discFun h F c) q :=
+  ((differentiableOn_discFun hh hF).differentiableAt
+    (Metric.isOpen_ball.mem_nhds (by simpa using hq))).continuousAt
+
+lemma discFun_zero : discFun h F c 0 = c 0 := by simp [discFun]
+
+theorem mdifferentiable (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) :
+    MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) F := by
+  rw [UpperHalfPlane.mdifferentiable_iff]
+  have h1 : DifferentiableOn ℂ (fun z : ℂ => discFun h F c (𝕢 h z)) {z : ℂ | 0 < z.im} := by
+    intro z hz
+    have hzq : ‖𝕢 h z‖ < 1 := by
+      have := norm_qParam_lt_one_of_pos hh ⟨z, hz⟩
+      simpa using this
+    exact (((differentiableOn_discFun hh hF).differentiableAt
+      (Metric.isOpen_ball.mem_nhds (by simpa using hzq))).comp z
+      ((Periodic.differentiable_qParam (h := h)) z)).differentiableWithinAt
+  refine h1.congr fun z hz => ?_
+  simp only [Function.comp_apply, apply_eq_discFun hh hF, ofComplex_apply_of_im_pos hz]
+
+theorem tendsto_atImInfty (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) :
+    Tendsto F atImInfty (𝓝 (c 0)) := by
+  have h1 : Tendsto (fun τ : ℍ => discFun h F c (𝕢 h (τ : ℂ))) atImInfty (𝓝 (discFun h F c 0)) :=
+    (continuousAt_discFun hh hF (q := 0) (by simp)).tendsto.comp (qParam_tendsto_atImInfty hh)
+  rw [discFun_zero] at h1
+  exact h1.congr fun τ => (apply_eq_discFun hh hF τ).symm
+
+theorem isBoundedAtImInfty (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) :
+    IsBoundedAtImInfty F :=
+  (tendsto_atImInfty hh hF).isBigO_one ℝ
+
+theorem periodic (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) :
+    Periodic (F ∘ ofComplex) h := by
+  intro w
+  by_cases hw : 0 < w.im
+  · have hw' : 0 < (w + h).im := by simpa using hw
+    simp only [Function.comp_apply, apply_eq_discFun hh hF, ofComplex_apply_of_im_pos hw,
+      ofComplex_apply_of_im_pos hw']
+    congr 1
+    simp only [Periodic.qParam]
+    rw [show 2 * ↑Real.pi * Complex.I * (w + ↑h) / ↑h = 2 * ↑Real.pi * Complex.I * w / ↑h + 2 *
+      ↑Real.pi * Complex.I by
+      field_simp [(Complex.ofReal_ne_zero.mpr hh.ne')]]
+    rw [Complex.exp_add, Complex.exp_two_pi_mul_I, mul_one]
+  · push Not at hw
+    have hw' : (w + h).im ≤ 0 := by simpa using hw
+    simp only [Function.comp_apply, ofComplex_apply_eq_of_im_nonpos hw' hw]
+
+theorem coeff_unique {d : ℕ → ℂ} (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ))
+    (hF' : ∀ τ : ℍ, HasSum (fun m : ℕ => d m * 𝕢 h (τ : ℂ) ^ m) (F τ)) : c = d := by
+  have hc := hasFPowerSeriesOnBall_update hh hF
+  have hd := hasFPowerSeriesOnBall_update hh hF'
+  have hlim : ∀ {e : ℕ → ℂ}, HasFPowerSeriesOnBall (update (cuspFunction h F) 0 (e 0)) (.ofScalars ℂ
+    e) 0 1 →
+      Tendsto (cuspFunction h F) (𝓝[≠] 0) (𝓝 (e 0)) := by
+    intro e he
+    have h1 : Tendsto (update (cuspFunction h F) 0 (e 0)) (𝓝[≠] 0) (𝓝 (e 0)) := by
+      have := he.hasFPowerSeriesAt.continuousAt.tendsto
+      rw [update_self] at this
+      exact this.mono_left nhdsWithin_le_nhds
+    refine h1.congr' ?_
+    filter_upwards [self_mem_nhdsWithin] with z hz using update_of_ne hz ..
+  have h0 : c 0 = d 0 := tendsto_nhds_unique (hlim hc) (hlim hd)
+  have hd' : HasFPowerSeriesOnBall (update (cuspFunction h F) 0 (c 0)) (.ofScalars ℂ d) 0 1 :=
+    h0 ▸ hd
+  have heq := hc.hasFPowerSeriesAt.eq_formalMultilinearSeries hd'.hasFPowerSeriesAt
+  funext m
+  simpa using congr_arg (FormalMultilinearSeries.coeff · m) heq
+
+end Realized
+
+end ModularCurve
+
+theorem solution (h : ℝ) (hh : 0 < h) (F : UpperHalfPlane → ℂ) (c d : ℕ → ℂ) (hc : ∀ τ :
+  UpperHalfPlane, HasSum (fun m : ℕ => c m * Function.Periodic.qParam h (τ : ℂ) ^ m) (F τ)) (hd : ∀
+  τ : UpperHalfPlane, HasSum (fun m : ℕ => d m * Function.Periodic.qParam h (τ : ℂ) ^ m) (F τ)) :
+    c = d :=
+  ModularCurve.Realized.coeff_unique hh hc hd
+
+end
+
+end S_ModularCurve_qParam_coeff_unique
+end P2MW
+export P2MW.S_ModularCurve_qParam_coeff_unique (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.qParam_coeff_unique (h : ℝ) (hh : 0 < h) (F : UpperHalfPlane → ℂ) (c d : ℕ → ℂ)
+  (hc : ∀ τ : UpperHalfPlane, HasSum (fun m : ℕ => c m * Function.Periodic.qParam h (τ : ℂ) ^ m) (F
+  τ)) (hd : ∀ τ : UpperHalfPlane, HasSum (fun m : ℕ => d m * Function.Periodic.qParam h (τ : ℂ) ^ m)
+  (F τ)) :
+    c = d :=
+  solution h hh F c d hc hd
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ramificationIndex_eq_ord_of_restrict_eq_jLinePlaceZero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ramificationIndex_eq_ord_of_restrict_eq_jLinePlaceZero.lean
new file mode 100644
index 0000000000..dfb6b1e882
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ramificationIndex_eq_ord_of_restrict_eq_jLinePlaceZero.lean
@@ -0,0 +1,107 @@
+/-
+Based on Prove2Me node ModularCurve.ramificationIndex_eq_ord_of_restrict_eq_jLinePlaceZero
+(5c7d51f8-f581-57c8-b93d-0960523f2ff4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 369901f6-b03d-5b99-81bf-172ae815534a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JLinePlaces
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_jLinePlaceZero_jGen
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Ramification index over j=0 equals ord_w(j)
+
+Theorem statement: `ModularCurve.ramificationIndex_eq_ord_of_restrict_eq_jLinePlaceZero`
+(`5c7d51f8-f581-57c8-b93d-0960523f2ff4`), by Claude, 2026-09-05.
+
+Proof: submission `369901f6-b03d-5b99-81bf-172ae815534a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N \ge 1$ and let $F_N = \mathbb{Q}(j_q, j_q|_{q \mapsto q^N})$ be the intermediate field
+[`ModularCurve.modularFunctionField N`](def/ModularCurve_X0.html#L250) of the Laurent series field
+$\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by the $q$-expansion $j_q$ of the modular invariant
+and by its image under the $N$-fold substitution `qExpand ℚ N`; it is regarded as an algebra over
+the subfield $\mathbb{Q}\langle j_q\rangle$ via the inclusion
+[`ModularCurve.jAdjoinRingHom`](def/ModularCurve_RouteBCoordRing.html#L14), and it is assumed
+integral over $\mathbb{Q}\langle j_q\rangle$. Let $w$ be a place of $F_N$ over $\mathbb{Q}$, that
+is, a valuation subring of $F_N$ which contains the image of $\mathbb{Q}$, is not all of $F_N$ and
+is a principal ideal ring. Assume that the restriction of $w$ to $\mathbb{Q}\langle j_q\rangle$ —
+the preimage of its valuation subring under the inclusion — is the place
+[`ModularCurve.jLinePlaceZero`](def/ModularCurve_JLinePlaces.html#L54), the place of
+$\mathbb{Q}\langle j_q\rangle$ obtained by transporting, along the isomorphism
+$\operatorname{RatFunc} \mathbb{Q} \cong \mathbb{Q}\langle j_q\rangle$ coming from the transcendence
+of $j_q$, the finite place of $\operatorname{RatFunc} \mathbb{Q}$ attached to $X - 0$. Then the
+ramification index of $w$ over $\mathbb{Q}\langle j_q\rangle$, namely the least $n > 0$ such that
+$\operatorname{ord}_w(f) = n$ for some nonzero $f$ in $\mathbb{Q}\langle j_q\rangle$, equals, as an
+integer, $\operatorname{ord}_w$ of the element $j_q$ of $F_N$, where $\operatorname{ord}_w$ is minus
+the logarithm of the associated $\mathbb{Z}^{m0}$-valued adic valuation.
+
+This is the standard identification, for a place of the function field of $X_0(N)$ lying above the
+place $j = 0$ of the $j$-line, of the ramification index with the order of vanishing of $j$ at that
+place. It is used in the counts of fibres of the covering $X_0(N) \to X(1)$ over the elliptic
+points, in
+[`ModularCurve.natCard_ord_jBar_eq_one_eq_nuThree`]
+(thm.html#ModularCurve.natCard_ord_jBar_eq_one_eq_nuThree)
+and
+[`ModularCurve.natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo`]
+(thm.html#ModularCurve.natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ramificationIndex_eq_ord_of_restrict_eq_jLinePlaceZero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ramificationIndex_eq_ord_of_restrict_eq_jLinePlaceZero
+
+
+open IntermediateField AlgebraicCurve
+
+theorem solution (N : ℕ) [NeZero N] :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ = ModularCurve.jLinePlaceZero →
+      (w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ : ℤ) = w.ord (⟨ModularCurve.jq, ModularCurve.jq_mem
+        N⟩ : ↥(ModularCurve.modularFunctionField N)) := by
+  let := ModularCurve.jAdjoinAlgebra N
+  intro _ w hres
+  have h := w.ord_restrict (F := ↥ℚ⟮ModularCurve.jq⟯) ModularCurve.jGen
+  rw [hres, ModularCurve.ord_jLinePlaceZero_jGen, mul_one] at h
+  exact h.symm
+
+end S_ModularCurve_ramificationIndex_eq_ord_of_restrict_eq_jLinePlaceZero
+end P2MW
+export P2MW.S_ModularCurve_ramificationIndex_eq_ord_of_restrict_eq_jLinePlaceZero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open IntermediateField AlgebraicCurve
+theorem ModularCurve.ramificationIndex_eq_ord_of_restrict_eq_jLinePlaceZero (N : ℕ) [NeZero N] :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ = ModularCurve.jLinePlaceZero →
+      (w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ : ℤ) = w.ord (⟨ModularCurve.jq, ModularCurve.jq_mem
+        N⟩ : ↥(ModularCurve.modularFunctionField N)) :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ramificationIndex_eq_ord_sub_of_restrict_eq_jLinePlace1728.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ramificationIndex_eq_ord_sub_of_restrict_eq_jLinePlace1728.lean
new file mode 100644
index 0000000000..a8fef5333c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ramificationIndex_eq_ord_sub_of_restrict_eq_jLinePlace1728.lean
@@ -0,0 +1,104 @@
+/-
+Based on Prove2Me node ModularCurve.ramificationIndex_eq_ord_sub_of_restrict_eq_jLinePlace1728
+(5f1a5448-3887-5ed9-a629-23d9fbc58e72) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 63381d0b-f86d-5012-83d1-8e9a2a773211
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JLinePlaces
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_jLinePlace1728_jGen_sub
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Ramification index over j=1728 equals ord_w(j-1728)
+
+Theorem statement: `ModularCurve.ramificationIndex_eq_ord_sub_of_restrict_eq_jLinePlace1728`
+(`5f1a5448-3887-5ed9-a629-23d9fbc58e72`), by Claude, 2026-09-05.
+
+Proof: submission `63381d0b-f86d-5012-83d1-8e9a2a773211`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N \ge 1$ and let $F_N = \mathbb{Q}(j_q, j_{q^N})$ be the modular function field, i.e. the
+intermediate field of $\mathbb{Q} \subseteq \mathrm{LaurentSeries}\,\mathbb{Q}$ generated by the
+Laurent series $j_q = q^{-1}\cdot j\mathrm{NumQ}$ and by its image under the $q \mapsto q^N$
+substitution homomorphism; regard $F_N$ as an algebra over the simple extension $\mathbb{Q}\langle
+j_q\rangle$ via the inclusion of $\mathbb{Q}\langle j_q\rangle$ into $F_N$, and assume this
+extension is integral. Let $w$ be a place of $F_N$ over $\mathbb{Q}$, that is, a valuation subring
+of $F_N$ which contains the image of $\mathbb{Q}$, is not the whole of $F_N$, and is a principal
+ideal ring. Suppose that the restriction of $w$ to $\mathbb{Q}\langle j_q\rangle$ — the valuation
+subring obtained as the preimage of $w$ under the inclusion — equals
+[`ModularCurve.jLinePlace1728`](def/ModularCurve_JLinePlaces.html#L50), the place of
+$\mathbb{Q}\langle j_q\rangle$ transported along the isomorphism $\mathrm{RatFunc}\,\mathbb{Q} \cong
+\mathbb{Q}\langle j_q\rangle$ (sending the variable to $j_q$) from the place of
+$\mathrm{RatFunc}\,\mathbb{Q}$ attached to the irreducible polynomial $X - 1728$. Then the
+ramification index of $w$ over $\mathbb{Q}\langle j_q\rangle$, defined as the least positive integer
+of the form $\operatorname{ord}_w(\iota f)$ with $f \in \mathbb{Q}\langle j_q\rangle$ nonzero,
+equals, as an integer, $\operatorname{ord}_w(j_q - 1728)$, where $j_q$ is viewed as an element of
+$F_N$ and $\operatorname{ord}_w$ is minus the logarithm of the associated $\mathbb{Z}^{m0}$-valued
+adic valuation.
+
+This is the standard identification, for a place of the function field of $X_0(N)$ lying over the
+point $j = 1728$ of the $j$-line, of the ramification index with the order of vanishing of $j -
+1728$; it is the computational form in which ramification above the elliptic point of order $2$ is
+handled. It is used in the counting of fibres over $j = 0$ and $j = 1728$, in the determination of
+$\nu_2$ and $\nu_3$ for $X_0(N)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ramificationIndex_eq_ord_sub_of_restrict_eq_jLinePlace1728.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ramificationIndex_eq_ord_sub_of_restrict_eq_jLinePlace1728
+
+
+open IntermediateField AlgebraicCurve
+
+theorem solution (N : ℕ) [NeZero N] :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ = ModularCurve.jLinePlace1728 →
+      (w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ : ℤ) = w.ord ((⟨ModularCurve.jq, ModularCurve.jq_mem
+        N⟩ : ↥(ModularCurve.modularFunctionField N)) - 1728) := by
+  let := ModularCurve.jAdjoinAlgebra N
+  intro _ w hres
+  have h := w.ord_restrict (F := ↥ℚ⟮ModularCurve.jq⟯) (ModularCurve.jGen - 1728)
+  rw [map_sub, map_ofNat] at h
+  rw [hres, ModularCurve.ord_jLinePlace1728_jGen_sub, mul_one] at h
+  exact h.symm
+
+end S_ModularCurve_ramificationIndex_eq_ord_sub_of_restrict_eq_jLinePlace1728
+end P2MW
+export P2MW.S_ModularCurve_ramificationIndex_eq_ord_sub_of_restrict_eq_jLinePlace1728 (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open IntermediateField AlgebraicCurve
+theorem ModularCurve.ramificationIndex_eq_ord_sub_of_restrict_eq_jLinePlace1728 (N : ℕ) [NeZero N] :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ = ModularCurve.jLinePlace1728 →
+      (w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ : ℤ) = w.ord ((⟨ModularCurve.jq, ModularCurve.jq_mem
+        N⟩ : ↥(ModularCurve.modularFunctionField N)) - 1728) :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ratPoint_eq_ratPoint_iff_of_isCoprime.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ratPoint_eq_ratPoint_iff_of_isCoprime.lean
new file mode 100644
index 0000000000..cf00a09eb1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_ratPoint_eq_ratPoint_iff_of_isCoprime.lean
@@ -0,0 +1,124 @@
+/-
+Based on Prove2Me node ModularCurve.ratPoint_eq_ratPoint_iff_of_isCoprime
+(6ea43388-53a5-59b1-918f-b834013d43a5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 31dfc0f7-ac9a-56d4-a45d-943788ca886f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CuspSpace
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Coprime integral coordinates on P¹(ℚ) are unique up to sign
+
+Theorem statement: `ModularCurve.ratPoint_eq_ratPoint_iff_of_isCoprime`
+(`6ea43388-53a5-59b1-918f-b834013d43a5`), by Claude, 2026-09-05.
+
+Proof: submission `31dfc0f7-ac9a-56d4-a45d-943788ca886f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+For integers $a, c, a', c'$ the map [`ModularCurve.ratPoint`](def/ModularCurve_CuspSpace.html#L11)
+sends a pair $(a,c)$ to the point of the one-point compactification `OnePoint ℚ` given by $\infty$
+if $c = 0$ and by the image of the rational number $a/c$ otherwise. The theorem assumes that $a$ and
+$c$ are coprime in $\mathbb{Z}$ (in the Bézout sense of `IsCoprime`, i.e. there exist $x, y$ with
+$xa + yc = 1$) and likewise that $a'$ and $c'$ are coprime, and asserts the equivalence:
+[`ModularCurve.ratPoint a c`](def/ModularCurve_CuspSpace.html#L11) equals [`ModularCurve.ratPoint a'
+c'`](def/ModularCurve_CuspSpace.html#L11) if and only if either $a = a'$ and $c = c'$, or $a = -a'$
+and $c = -c'$. Thus a point of $\mathbb{P}^1(\mathbb{Q})$, presented in this chart form, determines
+its coprime integral homogeneous coordinates up to a single global sign.
+
+This is the standard uniqueness of normalised homogeneous coordinates for points of
+$\mathbb{P}^1(\mathbb{Q})$, the elementary input for putting cusps of $\Gamma_0(N)$ into a normal
+form. It is used by
+[`ModularCurve.CuspSpace.normalFormCriterion`](thm.html#ModularCurve.CuspSpace.normalFormCriterion)
+in the treatment of the cusps of the modular curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_ratPoint_eq_ratPoint_iff_of_isCoprime.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_ratPoint_eq_ratPoint_iff_of_isCoprime
+
+open Matrix Matrix.SpecialLinearGroup OnePoint CongruenceSubgroup
+open scoped MatrixGroups
+open ModularCurve ModularCurve.CuspSpace
+
+theorem solution {a c a' c' : ℤ} (h : IsCoprime a c)
+    (h' : IsCoprime a' c') :
+    ModularCurve.ratPoint a c = ModularCurve.ratPoint a' c' ↔ (a = a' ∧ c = c') ∨ (a = -a' ∧ c =
+      -c') := by
+  constructor
+  · intro heq
+    rcases eq_or_ne c 0 with rfl | hc
+    · have hc' : c' = 0 := by
+        rw [ratPoint_zero_right] at heq
+        exact ratPoint_eq_infty_iff.mp heq.symm
+      subst hc'
+      have hu : IsUnit a := isCoprime_zero_right.mp h
+      have hu' : IsUnit a' := isCoprime_zero_right.mp h'
+      rcases Int.isUnit_iff.mp hu with rfl | rfl <;>
+          rcases Int.isUnit_iff.mp hu' with rfl | rfl <;>
+        norm_num
+    · have hc' : c' ≠ 0 := by
+        intro h0
+        rw [h0, ratPoint_zero_right, ratPoint_eq_infty_iff] at heq
+        exact hc heq
+      have hcQ : (c : ℚ) ≠ 0 := Int.cast_ne_zero.mpr hc
+      have hcQ' : (c' : ℚ) ≠ 0 := Int.cast_ne_zero.mpr hc'
+      rw [ratPoint_of_ne_zero _ hc, ratPoint_of_ne_zero _ hc', OnePoint.coe_eq_coe,
+        div_eq_div_iff hcQ hcQ'] at heq
+      have hZ : a * c' = a' * c := by exact_mod_cast heq
+      have h1 : c ∣ c' := h.symm.dvd_of_dvd_mul_left ⟨a', by linear_combination hZ⟩
+      have h2 : c' ∣ c := h'.symm.dvd_of_dvd_mul_left ⟨a, by linear_combination - hZ⟩
+      obtain ⟨u, hu⟩ := h1
+      obtain ⟨v, hv⟩ := h2
+      have huv : u * v = 1 := by
+        have h3 : c * (u * v) = c * 1 := by
+          rw [mul_one, ← mul_assoc, ← hu, ← hv]
+        exact mul_left_cancel₀ hc h3
+      rcases Int.isUnit_iff.mp (IsUnit.of_mul_eq_one v huv) with hu1 | hu1
+      · rw [hu1, mul_one] at hu
+        rw [hu] at hZ
+        exact Or.inl ⟨mul_right_cancel₀ hc hZ, hu.symm⟩
+      · rw [hu1, mul_neg_one] at hu
+        have hc2 : c = -c' := by rw [hu]; ring
+        have h4 : a * c' = -a' * c' := by
+          rw [hc2] at hZ
+          linear_combination hZ
+        exact Or.inr ⟨mul_right_cancel₀ hc' h4, hc2⟩
+  · rintro (⟨rfl, rfl⟩ | ⟨rfl, rfl⟩)
+    · rfl
+    · exact ratPoint_neg_neg a' c'
+
+end S_ModularCurve_ratPoint_eq_ratPoint_iff_of_isCoprime
+end P2MW
+export P2MW.S_ModularCurve_ratPoint_eq_ratPoint_iff_of_isCoprime (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open OnePoint
+theorem ModularCurve.ratPoint_eq_ratPoint_iff_of_isCoprime {a c a' c' : ℤ} (h : IsCoprime a c)
+    (h' : IsCoprime a' c') :
+    ModularCurve.ratPoint a c = ModularCurve.ratPoint a' c' ↔ (a = a' ∧ c = c') ∨ (a = -a' ∧ c =
+      -c') :=
+  solution h h'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_realizeOf_eq_div.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_realizeOf_eq_div.lean
new file mode 100644
index 0000000000..32e0230e5d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_realizeOf_eq_div.lean
@@ -0,0 +1,137 @@
+/-
+Based on Prove2Me node ModularCurve.realizeOf_eq_div
+(189c50d4-7af7-5360-ad95-f58a8c9162f0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 761815dc-7dd5-5884-b656-0972b95adad5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ComplexPlaceDictionaryOf
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Independence of the realisation from the chosen presentation
+
+Theorem statement: `ModularCurve.realizeOf_eq_div` (`189c50d4-7af7-5360-ad95-f58a8c9162f0`), by
+Claude, 2026-09-05.
+
+Proof: submission `761815dc-7dd5-5884-b656-0972b95adad5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma \le \mathrm{SL}_2(\mathbb{Z})$ be a subgroup containing the translation matrix
+`ModularGroup.T`, let $k \in \mathbb{Z}$, and let $g, h$ be modular forms of weight $k$ on $\Gamma$.
+Let $x$ be a Laurent series over $\mathbb{C}$ and suppose that $x$ times the image in
+$\mathbb{C}((q))$ of the period-$1$ $q$-expansion of $h$ equals the image of the period-$1$
+$q$-expansion of $g$. Let $\tau$ lie in the upper half plane and suppose $h(\tau) \neq 0$. Then
+[`ModularCurve.realizeOf`](def/ModularCurve_ComplexPlaceDictionaryOf.html#L15) $\Gamma\, x\, \tau$
+equals $g(\tau)/h(\tau)$. Here
+[`ModularCurve.realizeOf`](def/ModularCurve_ComplexPlaceDictionaryOf.html#L15) $\Gamma\, x\, \tau$
+is defined by cases: if there exists a triple consisting of a weight $j \in \mathbb{Z}$ and a pair
+$(G, H)$ of modular forms of weight $j$ on $\Gamma$ with $H(\tau) \neq 0$ and $x \cdot \widetilde{H}
+= \widetilde{G}$ in $\mathbb{C}((q))$ (tilde denoting the period-$1$ $q$-expansion pushed into
+Laurent series), it is $G(\tau)/H(\tau)$ for one such triple chosen by the axiom of choice, and
+otherwise it is $0$. Thus the assertion is that the chosen value agrees with the value computed from
+the given presentation $x \cdot \widetilde{h} = \widetilde{g}$.
+
+This is the well-definedness statement for the realisation of a Laurent series as a meromorphic
+function on the upper half plane as a ratio of modular forms of equal weight on $\Gamma$: the value
+at $\tau$ does not depend on the presentation. It underlies the complex-place dictionary for modular
+curves and is invoked throughout that development, for instance in the treatment of Abel–Jacobi
+images, of the action of complex conjugation on points, and of stabiliser orders and ramification.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_realizeOf_eq_div.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_realizeOf_eq_div
+
+open UpperHalfPlane
+open scoped MatrixGroups Topology Manifold
+
+namespace ModularCurve
+p2m_export "ModularCurve" "realizeOf realizeOf_def"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+theorem ModularCurve.RealizeOfWD.one_mem_strictPeriods (Γ : Subgroup SL(2, ℤ))
+    (hT : ModularGroup.T ∈ Γ) :
+    (1 : ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  rw [Subgroup.strictPeriods_eq_zmultiples_one_of_T_mem hT]
+  exact AddSubgroup.mem_zmultiples _
+
+open scoped MatrixGroups in
+theorem solution
+    (Γ : Subgroup SL(2, ℤ)) (hT : ModularGroup.T ∈ Γ) {k : ℤ}
+    (g h : ModularForm Γ k) (x : LaurentSeries ℂ)
+    (hx : x * ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) =
+      ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ))
+    (τ : UpperHalfPlane) (hτ : (h : UpperHalfPlane → ℂ) τ ≠ 0) :
+    ModularCurve.realizeOf Γ x τ = (g : UpperHalfPlane → ℂ) τ / (h : UpperHalfPlane → ℂ) τ := by
+  classical
+  have h1 : (1 : ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)).strictPeriods :=
+    ModularCurve.RealizeOfWD.one_mem_strictPeriods Γ hT
+  have H : ∃ p : (k : ℤ) × (ModularForm Γ k × ModularForm Γ k),
+      (p.2.2 : ℍ → ℂ) τ ≠ 0 ∧
+        x * ((qExpansion 1 (p.2.2 : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+          ((qExpansion 1 (p.2.1 : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) :=
+    ⟨⟨k, g, h⟩, hτ, hx⟩
+  have hval : ModularCurve.realizeOf Γ x τ = (H.choose.2.1 : ℍ → ℂ) τ / (H.choose.2.2 : ℍ → ℂ) τ :=
+    by
+    rw [ModularCurve.realizeOf_def]
+    exact dite_eq_left H
+  rw [hval]
+  obtain ⟨hτ', hx'⟩ := H.choose_spec
+  set p := H.choose with hp
+  obtain ⟨k', g', h'⟩ := p
+  simp only at hτ' hx' ⊢
+  have hq : qExpansion 1 ((g' : ℍ → ℂ) * (h : ℍ → ℂ)) = qExpansion 1 ((g : ℍ → ℂ) * (h' : ℍ → ℂ)) :=
+    by
+    apply (HahnSeries.ofPowerSeries_injective (Γ := ℤ) (R := ℂ))
+    rw [ModularForm.qExpansion_mul_coe one_pos h1, ModularForm.qExpansion_mul_coe one_pos h1,
+      PowerSeries.coe_mul, PowerSeries.coe_mul, ← hx, ← hx']
+    ring
+  have hAB : (g'.mul h : ModularForm Γ (k' + k)) = ModularForm.mcast (add_comm k k') (g.mul h') :=
+    by
+    rw [← sub_eq_zero, ← ModularForm.qExpansion_eq_zero_iff one_pos h1, FunLike.coe_sub,
+      ModularForm.qExpansion_sub one_pos h1, sub_eq_zero, ModularForm.coe_mcast,
+      ModularForm.coe_mul, ModularForm.coe_mul, hq]
+  have hτeq : (g' : ℍ → ℂ) τ * (h : ℍ → ℂ) τ = (g : ℍ → ℂ) τ * (h' : ℍ → ℂ) τ := by
+    have := congrArg (fun f : ModularForm Γ (k' + k) => (f : ℍ → ℂ) τ) hAB
+    simpa [ModularForm.coe_mul, ModularForm.coe_mcast] using this
+  rw [div_eq_div_iff hτ' hτ, hτeq]
+
+end S_ModularCurve_realizeOf_eq_div
+end P2MW
+export P2MW.S_ModularCurve_realizeOf_eq_div (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.realizeOf_eq_div
+    (Γ : Subgroup SL(2, ℤ)) (hT : ModularGroup.T ∈ Γ) {k : ℤ}
+    (g h : ModularForm Γ k) (x : LaurentSeries ℂ)
+    (hx : x * ((UpperHalfPlane.qExpansion 1 (h : UpperHalfPlane → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) =
+      ((UpperHalfPlane.qExpansion 1 (g : UpperHalfPlane → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ))
+    (τ : UpperHalfPlane) (hτ : (h : UpperHalfPlane → ℂ) τ ≠ 0) :
+    ModularCurve.realizeOf Γ x τ = (g : UpperHalfPlane → ℂ) τ / (h : UpperHalfPlane → ℂ) τ :=
+  solution Γ hT g h x hx τ hτ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_relfinrank_fullC_mul_prime_pow.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_relfinrank_fullC_mul_prime_pow.lean
new file mode 100644
index 0000000000..55fdb528fc
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_relfinrank_fullC_mul_prime_pow.lean
@@ -0,0 +1,1339 @@
+/-
+Based on Prove2Me node ModularCurve.relfinrank_fullC_mul_prime_pow
+(b8d18334-4f62-51c7-876d-ed4aaa767c4c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ff53b171-8fb3-55d9-b269-544ef1a87d89
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+public import Mathlib.FieldTheory.Relrank
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_neg_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_order_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_mul_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jqNModC_of_mul_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot_of_isPrimitiveRoot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_evalSymm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Polynomial_mem_range_of_unique_common_root
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Polynomial_irreducible_of_transitive_ringAut
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Prime-power step for fields of divisor q-expansions of j
+
+Theorem statement: `ModularCurve.relfinrank_fullC_mul_prime_pow`
+(`b8d18334-4f62-51c7-876d-ed4aaa767c4c`), by Claude, 2026-09-05.
+
+Proof: submission `ff53b171-8fb3-55d9-b269-544ef1a87d89`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, $M$ a nonzero natural number, $p$ a prime not dividing $M$, and $a$ a natural
+number, and suppose some unit $\zeta$ of $K$ is a primitive root of unity of order $M p^{a+1}$. For
+a nonzero natural number $n$ write $F_n$ for the intermediate field `IntermediateField.adjoin K` of
+the set of Laurent series of the form `jqNModC K d'` with $d'$ a nonzero divisor of $n$; here
+`jqNModC K d'` is the image of `jqModC K` $= q^{-1}\cdot(\text{the integral power series }$`jNum`$)$
+read in $K$ under the exponent-scaling ring homomorphism `qExpand K d'`, i.e. the expansion
+$j(q^{d'})$ inside $K((q))$. Assume: (i) whenever $a = b+1$, the relative degree of $F_{M p^{b+1}}$
+over $F_{M p^{b}}$ equals $p+1$ if $b = 0$ and $p$ otherwise; (ii) if $a = 0$, then $j(q^{p}) \notin
+F_{M}$. Then `IntermediateField.relfinrank` of $F_{M p^{a}}$ and $F_{M p^{a+1}}$, i.e. the relative
+degree $[F_{M p^{a+1}} : F_{M p^{a}}]$ as a natural number, equals $p+1$ if $a = 0$ and $p$
+otherwise.
+
+This is the inductive prime-power step in the computation of the degrees in the tower of fields
+generated over $K$ by the divisor expansions $j(q^{d})$, $d \mid n$, inside $K((q))$ — the
+$q$-expansion model of the function fields of the modular curves $X_0(n)$, whose total degree over
+$K(j(q))$ is Dedekind's $\psi(n)$. It is used by
+[`ModularCurve.package_of_socket`](thm.html#ModularCurve.package_of_socket).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_relfinrank_fullC_mul_prime_pow.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_relfinrank_fullC_mul_prime_pow
+
+noncomputable section
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_relfinrank_fullC_mul_prime_pow.ModularCurve \
+  ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_congr qExpand_qExpand dedekindPsi ModularPolynomialData coeffMap \
+  coeffMap_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm jqModC \
+  jqNModC jqNModC_one map_jqModC coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm dedekindPsi_prime"
+namespace W1
+p2m_open "ModularCurve"
+
+variable {K : Type*} [Field K]
+
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+theorem jqModC_eq_TS : jqModC K = TS K 1 1 := by
+  rw [TS, qTwist_one_apply, qExpand_one_apply]
+
+theorem jqNModC_eq_TS (d : ℕ) [NeZero d] : jqNModC K d = TS K d 1 := by
+  rw [jqNModC, TS, qTwist_one_apply]
+
+theorem qExpand_jqNModC (A d : ℕ) [NeZero A] [NeZero d] :
+    qExpand K A (jqNModC K d) = TS K (A * d) 1 := by
+  rw [jqNModC_eq_TS, qExpand_TS]
+
+theorem qExpand_jqModC_eq_TS (A : ℕ) [NeZero A] : qExpand K A (jqModC K) = TS K A 1 := by
+  rw [TS, qTwist_one_apply]
+
+theorem qTwist_qExpand_of_pow_eq_one (A : ℕ) [NeZero A] (v : Kˣ) (hv : v ^ A = 1)
+    (x : LaurentSeries K) :
+    qTwist v (qExpand K A x) = qExpand K A x := by
+  rw [qTwist_qExpand]
+  have : v ^ (A : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_congr qExpand_qExpand dedekindPsi ModularPolynomialData coeffMap \
+  coeffMap_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm jqModC \
+  jqNModC jqNModC_one map_jqModC coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm dedekindPsi_prime"
+namespace W1
+p2m_open "ModularCurve"
+
+section transport
+
+variable {R S : Type*} [CommRing R] [CommRing S]
+
+theorem coeffMap_qTwist (σ : R →+* S) (u : Rˣ) (f : LaurentSeries R) :
+    coeffMap σ (qTwist u f) = qTwist (Units.map σ.toMonoidHom u) (coeffMap σ f) := by
+  ext k
+  simp only [coeffMap_coeff, qTwist_coeff, map_mul]
+  congr 1
+  rw [← map_zpow, Units.coe_map]
+  rfl
+
+end transport
+
+variable {K : Type*} [Field K]
+
+theorem coeffMap_TS {L : Type*} [Field L] (σ : L →+* K) (e : ℕ) [NeZero e] (u : Lˣ) :
+    coeffMap σ (TS L e u) = TS K e (Units.map σ.toMonoidHom u) := by
+  rw [TS, TS, coeffMap_qExpand, coeffMap_qTwist]
+  exact congrArg (fun z => qExpand K e (qTwist (Units.map σ.toMonoidHom u) z)) (map_jqModC σ)
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem units_pow_eq_one_of_isPrimitiveRoot {N : ℕ} {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N) :
+    ζ ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_congr qExpand_qExpand dedekindPsi ModularPolynomialData coeffMap \
+  coeffMap_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm jqModC \
+  jqNModC jqNModC_one map_jqModC coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm dedekindPsi_prime"
+namespace W1
+p2m_open "ModularCurve"
+
+
+
+
+
+
+theorem phiAtSeed_jqNModC_eval {R : Type*} [CommRing R] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n)
+    (d : ℕ) [NeZero d] : (phiAtSeed data (jqNModC R d)).eval (jqNModC R (d * n)) = 0 := by
+  have h := data.eval_jqNModC_mul_eq_zero R d
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  exact Polynomial.ringHom_ext' (RingHom.ext_int _ _) (by simp)
+
+theorem phiAtSeed_jqNModC_eval_symm {R : Type*} [CommRing R] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n)
+    (hsymm : EvalSymm data.Φ) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (jqNModC R (d * n))).eval (jqNModC R d) = 0 := by
+  have h := data.eval_jqNModC_of_mul_eq_zero hsymm R d
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  exact Polynomial.ringHom_ext' (RingHom.ext_int _ _) (by simp)
+
+theorem phiAtSeed_TS_eval {K : Type*} [Field K] (A : ℕ) [NeZero A] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (TS K (A * d) 1)).eval (TS K (A * (d * n)) 1) = 0 := by
+  have h := phiAtSeed_eval_map data _ _ (qExpand K A) (phiAtSeed_jqNModC_eval (R := K) n data d)
+  rwa [qExpand_jqNModC, qExpand_jqNModC] at h
+
+theorem phiAtSeed_TS_eval_symm {K : Type*} [Field K] (A : ℕ) [NeZero A] (n : ℕ) [NeZero n]
+    (data : ModularPolynomialData n) (hsymm : EvalSymm data.Φ) (d : ℕ) [NeZero d] :
+    (phiAtSeed data (TS K (A * (d * n)) 1)).eval (TS K (A * d) 1) = 0 := by
+  have h :=
+    phiAtSeed_eval_map data _ _ (qExpand K A) (phiAtSeed_jqNModC_eval_symm (R := K) n data hsymm d)
+  rwa [qExpand_jqNModC, qExpand_jqNModC] at h
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_congr qExpand_qExpand dedekindPsi ModularPolynomialData coeffMap \
+  coeffMap_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm jqModC \
+  jqNModC jqNModC_one map_jqModC coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm dedekindPsi_prime"
+namespace W1
+p2m_open "ModularCurve"
+
+variable {K : Type*} [Field K]
+
+private theorem prod_form_ne_zero (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e] (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ b) (jqModC K)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (jqModC K))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K))) ::ₘ
+          (Multiset.range p).map (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot p ζ hζ data e u,
+    Polynomial.roots_mul (prod_form_ne_zero ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ b) (jqModC K))))
+        = ((Multiset.range p).map (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K))) (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K))) ::ₘ
+        (Multiset.range p).map (fun b => qExpand K e (qTwist (u * ζ ^ b) (jqModC K)))).Nodup := by
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h :=
+      (TS_injective (K := K) (e := e) (e' := p * (p * e)) (u := u * ζ ^ b) (u' := u ^ (p * p))
+        heq).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e) (u := u * ζ ^ b) (u' := u * ζ ^ b') heq).2
+    have h2 : ζ ^ b = ζ ^ b' := mul_left_cancel h
+    have h3 : ((ζ : Kˣ) : K) ^ b = ((ζ : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h2]
+    exact hζ.pow_inj hb hb' h3
+
+theorem roots_prime_at_slot_roots_nodup (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (jqModC K))))).roots.Nodup := by
+  rw [roots_prime_at_slot p ζ hζ data e u]
+  exact roots_prime_at_slot_nodup p ζ hζ e u
+
+theorem isRoot_prime_at_slot_iff (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (jqModC K))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (jqModC K)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ b) (jqModC K)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (jqModC K)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot p ζ hζ data e u]
+    exact prod_form_ne_zero ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot p ζ hζ data e u, Multiset.mem_cons,
+    Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+theorem roots_phiAtSeed_TS (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (phiAtSeed data (TS K (p * e) (u ^ p))).roots
+      = TS K (p * (p * e)) (u ^ (p * p)) ::ₘ (Multiset.range p).map (fun b => TS K e (u * ζ ^ b)) :=
+  roots_prime_at_slot p ζ hζ data e u
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_congr qExpand_qExpand dedekindPsi ModularPolynomialData coeffMap \
+  coeffMap_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm jqModC \
+  jqNModC jqNModC_one map_jqModC coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm dedekindPsi_prime"
+namespace W1
+p2m_open "ModularCurve"
+
+variable {K : Type*} [Field K]
+
+def divSet (K : Type*) [Field K] (L : ℕ) : Set (LaurentSeries K) :=
+  {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ L ∧ x = jqNModC K d'}
+
+def fullC (K : Type*) [Field K] (L : ℕ) : IntermediateField K (LaurentSeries K) :=
+  IntermediateField.adjoin K (divSet K L)
+
+theorem jqNModC_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) : jqNModC K n = jqNModC K m := by
+  subst h; rfl
+
+theorem jqNModC_mem_divSet {d L : ℕ} [NeZero d] (hd : d ∣ L) : jqNModC K d ∈ divSet K L :=
+  ⟨d, inferInstance, hd, rfl⟩
+
+theorem divSet_mono {L L' : ℕ} (h : L ∣ L') : divSet K L ⊆ divSet K L' := by
+  rintro x ⟨d, hd0, hdL, rfl⟩
+  exact ⟨d, hd0, hdL.trans h, rfl⟩
+
+theorem jqNModC_mem_fullC {d L : ℕ} [NeZero d] (hd : d ∣ L) : jqNModC K d ∈ fullC K L :=
+  IntermediateField.subset_adjoin K _ (jqNModC_mem_divSet hd)
+
+theorem jqModC_mem_fullC (L : ℕ) : jqModC K ∈ fullC K L := by
+  have h := jqNModC_mem_fullC (K := K) (d := 1) (one_dvd L)
+  rwa [jqNModC_one] at h
+
+theorem fullC_mono {L L' : ℕ} (h : L ∣ L') : fullC K L ≤ fullC K L' :=
+  IntermediateField.adjoin.mono K _ _ (divSet_mono h)
+
+theorem fullC_le_iff {L : ℕ} {F : IntermediateField K (LaurentSeries K)} :
+    fullC K L ≤ F ↔ ∀ (d : ℕ) [NeZero d], d ∣ L → jqNModC K d ∈ F := by
+  rw [fullC, IntermediateField.adjoin_le_iff]
+  constructor
+  · intro h d _ hd
+    exact h (jqNModC_mem_divSet hd)
+  · rintro h x ⟨d, hd0, hdL, rfl⟩
+    exact h d hdL
+
+theorem jqNModC_injective {d d' : ℕ} [NeZero d] [NeZero d'] (h : jqNModC K d = jqNModC K d') :
+    d = d' := by
+  rw [jqNModC_eq_TS, jqNModC_eq_TS] at h
+  exact (TS_injective h).1
+
+theorem qTwist_jqModC_eq_TS (u : Kˣ) : qTwist u (jqModC K) = TS K 1 u := by
+  rw [TS, qExpand_one_apply]
+
+def qExpandₐK (K : Type*) [Field K] (n : ℕ) [NeZero n] : LaurentSeries K →ₐ[K] LaurentSeries K where
+  __ := qExpand K n
+  commutes' c := by
+    change qExpand K n (algebraMap K (LaurentSeries K) c) = algebraMap K (LaurentSeries K) c
+    rw [HahnSeries.algebraMap_apply']
+    simp
+
+@[scoped simp] theorem qExpandₐK_apply (n : ℕ) [NeZero n] (f : LaurentSeries K) :
+    qExpandₐK K n f = qExpand K n f := rfl
+
+theorem qExpandₐK_jqNModC (n d : ℕ) [NeZero n] [NeZero d] :
+    qExpandₐK K n (jqNModC K d) = jqNModC K (n * d) := by
+  rw [qExpandₐK_apply, jqNModC, jqNModC, qExpand_qExpand]
+
+def eFull (K : Type*) [Field K] (n : ℕ) [NeZero n] (L : ℕ) :
+    IntermediateField K (LaurentSeries K) :=
+  IntermediateField.adjoin K ((qExpandₐK K n) '' divSet K L)
+
+theorem eFull_eq_map (n : ℕ) [NeZero n] (L : ℕ) :
+    eFull K n L = (fullC K L).map (qExpandₐK K n) := by
+  rw [eFull, fullC, IntermediateField.adjoin_map]
+
+theorem eFull_mono (n : ℕ) [NeZero n] {L L' : ℕ} (h : L ∣ L') : eFull K n L ≤ eFull K n L' :=
+  IntermediateField.adjoin.mono K _ _ (Set.image_mono (divSet_mono h))
+
+theorem jqNModC_mul_mem_eFull (n : ℕ) [NeZero n] {d L : ℕ} [NeZero d] (hd : d ∣ L) :
+    jqNModC K (n * d) ∈ eFull K n L :=
+  IntermediateField.subset_adjoin K _ ⟨jqNModC K d, jqNModC_mem_divSet hd, qExpandₐK_jqNModC n d⟩
+
+theorem exists_eq_qExpand_of_mem_eFull (n : ℕ) [NeZero n] {L : ℕ} {x : LaurentSeries K}
+    (hx : x ∈ eFull K n L) :
+    ∃ y : LaurentSeries K, qExpand K n y = x := by
+  rw [eFull_eq_map, IntermediateField.mem_map] at hx
+  obtain ⟨y, -, hy⟩ := hx
+  exact ⟨y, hy⟩
+
+theorem qTwist_eq_self_of_mem_eFull (n : ℕ) [NeZero n] {L : ℕ} {v : Kˣ} (hv : v ^ n = 1)
+    {x : LaurentSeries K}
+    (hx : x ∈ eFull K n L) : qTwist v x = x := by
+  obtain ⟨y, rfl⟩ := exists_eq_qExpand_of_mem_eFull n hx
+  exact qTwist_qExpand_of_pow_eq_one n v hv y
+
+theorem eFull_le_fullC (n : ℕ) [NeZero n] (L : ℕ) : eFull K n L ≤ fullC K (L * n) := by
+  rw [eFull, IntermediateField.adjoin_le_iff]
+  rintro x ⟨y, ⟨d, hd0, hdL, rfl⟩, rfl⟩
+  rw [qExpandₐK_jqNModC]
+  have h : d * n ∣ L * n := mul_dvd_mul_right hdL n
+  rw [Nat.mul_comm d n] at h
+  exact jqNModC_mem_fullC h
+
+theorem mem_adjoin_of_mem {E : IntermediateField K (LaurentSeries K)} {x : LaurentSeries K}
+    (hx : x ∈ E)
+    (T : Set (LaurentSeries K)) : x ∈ IntermediateField.adjoin E T :=
+  (IntermediateField.adjoin E T).algebraMap_mem ⟨x, hx⟩
+
+theorem relfinrank_adjoin_insert (T : Set (LaurentSeries K)) (α : LaurentSeries K) :
+    IntermediateField.relfinrank (IntermediateField.adjoin K T) (IntermediateField.adjoin K (insert
+      α T))
+      = Module.finrank (IntermediateField.adjoin K T)
+          (IntermediateField.adjoin (IntermediateField.adjoin K T) ({α} : Set (LaurentSeries K)))
+            := by
+  have h : IntermediateField.adjoin K T ≤ IntermediateField.adjoin K (insert α T) :=
+    IntermediateField.adjoin.mono _ _ _ (Set.subset_insert α T)
+  have hEq : IntermediateField.adjoin (IntermediateField.adjoin K T) (insert α T)
+      = IntermediateField.adjoin (IntermediateField.adjoin K T) ({α} : Set (LaurentSeries K)) := by
+    refine le_antisymm ?_ ?_
+    · rw [IntermediateField.adjoin_le_iff]
+      rintro x (rfl | hxT)
+      · exact IntermediateField.subset_adjoin _ _ rfl
+      · exact mem_adjoin_of_mem (IntermediateField.subset_adjoin K T hxT) _
+    · exact IntermediateField.adjoin.mono _ _ _ (Set.singleton_subset_iff.mpr (Set.mem_insert α T))
+  rw [IntermediateField.relfinrank_eq_finrank_of_le h, IntermediateField.extendScalars_adjoin h,
+    hEq]
+
+theorem relfinrank_adjoin_insert_eq_natDegree (T : Set (LaurentSeries K)) {α : LaurentSeries K}
+    (hα : IsIntegral (IntermediateField.adjoin K T) α) :
+    IntermediateField.relfinrank (IntermediateField.adjoin K T) (IntermediateField.adjoin K (insert
+      α T))
+      = (minpoly (IntermediateField.adjoin K T) α).natDegree := by
+  rw [relfinrank_adjoin_insert, IntermediateField.adjoin.finrank hα]
+
+theorem relfinrank_fullC_insert_eq_natDegree (L : ℕ) {α : LaurentSeries K}
+    (hα : IsIntegral (fullC K L) α) :
+    IntermediateField.relfinrank (fullC K L) (IntermediateField.adjoin K (insert α (divSet K L)))
+      = (minpoly (fullC K L) α).natDegree :=
+  relfinrank_adjoin_insert_eq_natDegree (divSet K L) hα
+
+theorem relfinrank_eFull_insert_eq_natDegree (n : ℕ) [NeZero n] (L : ℕ) {α : LaurentSeries K}
+    (hα : IsIntegral (eFull K n L) α) :
+    IntermediateField.relfinrank (eFull K n L) (IntermediateField.adjoin K (insert α ((qExpandₐK K
+      n) '' divSet K L)))
+      = (minpoly (eFull K n L) α).natDegree :=
+  relfinrank_adjoin_insert_eq_natDegree _ hα
+
+section packetBounds
+
+variable {F : IntermediateField K (LaurentSeries K)} {p : ℕ} [NeZero p]
+
+theorem phiAtSeed_map_algebraMap (data : ModularPolynomialData p) {s : LaurentSeries K} (hs : s ∈ F)
+    :
+    (phiAtSeed data (⟨s, hs⟩ : F)).map (algebraMap F (LaurentSeries K)) = phiAtSeed data s := by
+  rw [phiAtSeed_map]; rfl
+
+theorem aeval_phiAtSeed_eq_zero (data : ModularPolynomialData p) {s : LaurentSeries K} (hs : s ∈ F)
+    {t : LaurentSeries K} (ht : (phiAtSeed data s).eval t = 0) :
+    Polynomial.aeval t (phiAtSeed data (⟨s, hs⟩ : F)) = 0 := by
+  rw [← Polynomial.eval_map_algebraMap, phiAtSeed_map_algebraMap]
+  exact ht
+
+theorem isIntegral_of_phiAtSeed_root (data : ModularPolynomialData p) {s : LaurentSeries K}
+    (hs : s ∈ F)
+    {t : LaurentSeries K} (ht : (phiAtSeed data s).eval t = 0) : IsIntegral F t :=
+  ⟨phiAtSeed data (⟨s, hs⟩ : F), phiAtSeed_monic data _, by
+    rw [← Polynomial.aeval_def]; exact aeval_phiAtSeed_eq_zero data hs ht⟩
+
+theorem natDegree_minpoly_le_dedekindPsi_of_phiAtSeed_root (data : ModularPolynomialData p)
+    {s : LaurentSeries K}
+    (hs : s ∈ F) {t : LaurentSeries K} (ht : (phiAtSeed data s).eval t = 0) :
+    (minpoly F t).natDegree ≤ dedekindPsi p := by
+  have h := minpoly.degree_le_of_ne_zero F t (phiAtSeed_monic data (⟨s, hs⟩ : F)).ne_zero
+    (aeval_phiAtSeed_eq_zero data hs ht)
+  have h2 := Polynomial.natDegree_le_natDegree h
+  rwa [phiAtSeed_natDegree] at h2
+
+theorem natDegree_minpoly_le_of_phiAtSeed_root_of_root_mem (data : ModularPolynomialData p)
+    {s : LaurentSeries K}
+    (hs : s ∈ F) {r : LaurentSeries K} (hr : r ∈ F) (hrroot : (phiAtSeed data s).eval r = 0)
+    {t : LaurentSeries K} (ht : (phiAtSeed data s).eval t = 0) (htr : t ≠ r) :
+    (minpoly F t).natDegree ≤ dedekindPsi p - 1 := by
+  set P : Polynomial F := phiAtSeed data (⟨s, hs⟩ : F) with hPdef
+  set rF : F := ⟨r, hr⟩ with hrF
+  have hPr : P.IsRoot rF := by
+    rw [Polynomial.IsRoot.def]
+    apply (algebraMap F (LaurentSeries K)).injective
+    rw [map_zero, ← Polynomial.eval₂_at_apply, ← Polynomial.eval_map, hPdef,
+      phiAtSeed_map_algebraMap]
+    exact hrroot
+  set Q : Polynomial F := P /ₘ (Polynomial.X - Polynomial.C rF) with hQdef
+  have hPQ : (Polynomial.X - Polynomial.C rF) * Q = P :=
+    Polynomial.mul_divByMonic_eq_iff_isRoot.mpr hPr
+  have hQne : Q ≠ 0 := by
+    intro h0
+    have hP0 : P ≠ 0 := (phiAtSeed_monic data (⟨s, hs⟩ : F)).ne_zero
+    rw [← hPQ, h0, mul_zero] at hP0
+    exact hP0 rfl
+  have hQdeg : Q.natDegree = dedekindPsi p - 1 := by
+    rw [hQdef, Polynomial.natDegree_divByMonic _ (Polynomial.monic_X_sub_C rF),
+      Polynomial.natDegree_X_sub_C,
+      hPdef, phiAtSeed_natDegree]
+  have htP : Polynomial.aeval t P = 0 := aeval_phiAtSeed_eq_zero data hs ht
+  have htQ : Polynomial.aeval t Q = 0 := by
+    rw [← hPQ, map_mul, map_sub, Polynomial.aeval_X, Polynomial.aeval_C] at htP
+    rcases mul_eq_zero.mp htP with h1 | h1
+    · exfalso
+      exact htr (sub_eq_zero.mp h1)
+    · exact h1
+  have h := Polynomial.natDegree_le_natDegree (minpoly.degree_le_of_ne_zero F t hQne htQ)
+  rwa [hQdeg] at h
+
+end packetBounds
+
+theorem jqNModC_mem_of_div_primes {N : ℕ} [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    {F : IntermediateField K (LaurentSeries K)} {d : ℕ} [NeZero d] (hdN : d ∣ N)
+    {p q : ℕ} (pp : Nat.Prime p) (qq : Nat.Prime q) (hpq : p ≠ q) (hpd : p ∣ d) (hqd : q ∣ d)
+    [NeZero (d / p)] [NeZero (d / q)] (hmp : jqNModC K (d / p) ∈ F) (hmq : jqNModC K (d / q) ∈ F) :
+    jqNModC K d ∈ F := by
+  have : Fact (Nat.Prime p) := ⟨pp⟩
+  have : Fact (Nat.Prime q) := ⟨qq⟩
+  have : NeZero p := ⟨pp.ne_zero⟩
+  have : NeZero q := ⟨qq.ne_zero⟩
+  have hpN : p ∣ N := hpd.trans hdN
+  have hqN : q ∣ N := hqd.trans hdN
+  have hNp0 : N / p ≠ 0 := fun h0 => NeZero.ne N (by rw [← Nat.div_mul_cancel hpN, h0, zero_mul])
+  have hNq0 : N / q ≠ 0 := fun h0 => NeZero.ne N (by rw [← Nat.div_mul_cancel hqN, h0, zero_mul])
+  have : NeZero (N / p) := ⟨hNp0⟩
+  have : NeZero (N / q) := ⟨hNq0⟩
+  have hζp := isPrimitiveRoot_pow_div hζ hpN
+  have hζq := isPrimitiveRoot_pow_div hζ hqN
+  have hpe : p * (N / p * (d / p)) = N * (d / p) := by
+    rw [← mul_assoc, Nat.mul_div_cancel' hpN]
+  have hqe : q * (N / q * (d / q)) = N * (d / q) := by
+    rw [← mul_assoc, Nat.mul_div_cancel' hqN]
+  have hpe2 : p * (p * (N / p * (d / p))) = N * d := by
+    rw [hpe, mul_left_comm, Nat.mul_div_cancel' hpd]
+  have hqe2 : q * (q * (N / q * (d / q))) = N * d := by
+    rw [hqe, mul_left_comm, Nat.mul_div_cancel' hqd]
+  have data_p : ModularPolynomialData p := (ModularCurve.exists_phiIrreducible_evalSymm p).choose
+  have data_q : ModularPolynomialData q := (ModularCurve.exists_phiIrreducible_evalSymm q).choose
+  let : Algebra F (LaurentSeries K) :=
+    ((qExpand K N).comp (algebraMap F (LaurentSeries K))).toAlgebra
+  have hmapA : (phiAtSeed data_p (⟨jqNModC K (d / p), hmp⟩ : F)).map (algebraMap F (LaurentSeries
+    K))
+      = phiAtSeed data_p (qExpand K N (jqNModC K (d / p))) :=
+    phiAtSeed_map data_p _ _
+  have hmapB : (phiAtSeed data_q (⟨jqNModC K (d / q), hmq⟩ : F)).map (algebraMap F (LaurentSeries
+    K))
+      = phiAtSeed data_q (qExpand K N (jqNModC K (d / q))) :=
+    phiAtSeed_map data_q _ _
+  have hseed_p : qExpand K N (jqNModC K (d / p))
+      = qExpand K (p * (N / p * (d / p))) (qTwist ((1 : Kˣ) ^ p) (jqModC K)) := by
+    have h2 : TS K (N * (d / p)) 1 = TS K (p * (N / p * (d / p))) ((1 : Kˣ) ^ p) := by
+      rw [one_pow]
+      exact TS_congr hpe.symm 1
+    exact (qExpand_jqNModC N (d / p)).trans h2
+  have hseed_q : qExpand K N (jqNModC K (d / q))
+      = qExpand K (q * (N / q * (d / q))) (qTwist ((1 : Kˣ) ^ q) (jqModC K)) := by
+    have h2 : TS K (N * (d / q)) 1 = TS K (q * (N / q * (d / q))) ((1 : Kˣ) ^ q) := by
+      rw [one_pow]
+      exact TS_congr hqe.symm 1
+    exact (qExpand_jqNModC N (d / q)).trans h2
+  have hdist_p : qExpand K N (jqNModC K d)
+      = qExpand K (p * (p * (N / p * (d / p)))) (qTwist ((1 : Kˣ) ^ (p * p)) (jqModC K)) := by
+    have h2 : TS K (N * d) 1 = TS K (p * (p * (N / p * (d / p)))) ((1 : Kˣ) ^ (p * p)) := by
+      rw [one_pow]
+      exact TS_congr hpe2.symm 1
+    exact (qExpand_jqNModC N d).trans h2
+  have hdist_q : qExpand K N (jqNModC K d)
+      = qExpand K (q * (q * (N / q * (d / q)))) (qTwist ((1 : Kˣ) ^ (q * q)) (jqModC K)) := by
+    have h2 : TS K (N * d) 1 = TS K (q * (q * (N / q * (d / q)))) ((1 : Kˣ) ^ (q * q)) := by
+      rw [one_pow]
+      exact TS_congr hqe2.symm 1
+    exact (qExpand_jqNModC N d).trans h2
+  have hrootA : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_p (⟨jqNModC K (d / p), hmp⟩ : F)) = 0 ↔
+        (y = qExpand K (p * (p * (N / p * (d / p)))) (qTwist ((1 : Kˣ) ^ (p * p)) (jqModC K)) ∨
+          ∃ b < p, y = qExpand K (N / p * (d / p)) (qTwist (1 * (ζ ^ (N / p)) ^ b) (jqModC K)))
+            := by
+    intro y
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hmapA, hseed_p]
+    exact isRoot_prime_at_slot_iff p (ζ ^ (N / p)) hζp data_p (N / p * (d / p)) 1 y
+  have hrootB : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_q (⟨jqNModC K (d / q), hmq⟩ : F)) = 0 ↔
+        (y = qExpand K (q * (q * (N / q * (d / q)))) (qTwist ((1 : Kˣ) ^ (q * q)) (jqModC K)) ∨
+          ∃ c < q, y = qExpand K (N / q * (d / q)) (qTwist (1 * (ζ ^ (N / q)) ^ c) (jqModC K)))
+            := by
+    intro y
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hmapB, hseed_q]
+    exact isRoot_prime_at_slot_iff q (ζ ^ (N / q)) hζq data_q (N / q * (d / q)) 1 y
+  have hA0 : phiAtSeed data_p (⟨jqNModC K (d / p), hmp⟩ : F) ≠ 0 :=
+    (phiAtSeed_monic data_p _).ne_zero
+  have hAs : ((phiAtSeed data_p (⟨jqNModC K (d / p), hmp⟩ : F)).map (algebraMap F (LaurentSeries
+    K))).Splits :=
+    by
+    rw [hmapA, hseed_p, phiAtSeed,
+      ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot p (ζ ^ (N / p)) hζp data_p (N / p
+      * (d / p)) 1]
+    exact (Polynomial.Splits.X_sub_C _).mul (Polynomial.Splits.prod fun b _ =>
+      Polynomial.Splits.X_sub_C _)
+  have hAnd : ((phiAtSeed data_p (⟨jqNModC K (d / p), hmp⟩ : F)).map (algebraMap F (LaurentSeries
+    K))).roots.Nodup :=
+    by
+    rw [hmapA, hseed_p, phiAtSeed]
+    exact roots_prime_at_slot_roots_nodup p (ζ ^ (N / p)) hζp data_p (N / p * (d / p)) 1
+  have hxA : Polynomial.aeval (qExpand K N (jqNModC K d)) (phiAtSeed data_p (⟨jqNModC K (d / p),
+    hmp⟩ : F)) = 0 :=
+    (hrootA _).mpr (Or.inl hdist_p)
+  have hxB : Polynomial.aeval (qExpand K N (jqNModC K d)) (phiAtSeed data_q (⟨jqNModC K (d / q),
+    hmq⟩ : F)) = 0 :=
+    (hrootB _).mpr (Or.inl hdist_q)
+  have huniq : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_p (⟨jqNModC K (d / p), hmp⟩ : F)) = 0 →
+      Polynomial.aeval y (phiAtSeed data_q (⟨jqNModC K (d / q), hmq⟩ : F)) = 0 →
+      y = qExpand K N (jqNModC K d) := by
+    intro y hyA hyB
+    rcases (hrootA y).mp hyA with hy1 | ⟨b, _, hy1⟩
+    · exact hy1.trans hdist_p.symm
+    · rcases (hrootB y).mp hyB with hy2 | ⟨c, _, hy2⟩
+      · exact hy2.trans hdist_q.symm
+      · exfalso
+        have hTS : TS K (N / p * (d / p)) (1 * (ζ ^ (N / p)) ^ b)
+            = TS K (N / q * (d / q)) (1 * (ζ ^ (N / q)) ^ c) := hy1.symm.trans hy2
+        have he : N / p * (d / p) = N / q * (d / q) := (TS_injective hTS).1
+        have h1 : p * p * (N / p * (d / p)) = q * q * (N / p * (d / p)) := by
+          rw [mul_assoc, hpe2, mul_assoc, he, hqe2]
+        have h2 : p * p = q * q :=
+          Nat.eq_of_mul_eq_mul_right (Nat.pos_of_ne_zero (NeZero.ne (N / p * (d / p)))) h1
+        have h3 : q ∣ p * p := by rw [h2]; exact dvd_mul_right q q
+        have h4 : q ∣ p := ((Nat.Prime.dvd_mul qq).mp h3).elim id id
+        exact hpq (((Nat.prime_dvd_prime_iff_eq qq pp).mp h4).symm)
+  have hrange := Polynomial.mem_range_of_unique_common_root
+    (phiAtSeed data_p (⟨jqNModC K (d / p), hmp⟩ : F)) (phiAtSeed data_q (⟨jqNModC K (d / q), hmq⟩ :
+      F))
+    hA0 hAs hAnd (qExpand K N (jqNModC K d)) hxA hxB huniq
+  obtain ⟨f, hf⟩ := RingHom.mem_range.mp hrange
+  have hf' : qExpand K N (f : LaurentSeries K) = qExpand K N (jqNModC K d) := hf
+  have hval : (f : LaurentSeries K) = jqNModC K d := qExpand_injective N hf'
+  rw [← hval]
+  exact f.2
+
+theorem jqNModC_mem_of_div_prime_of_mul_prime {N : ℕ} [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N)
+    {F : IntermediateField K (LaurentSeries K)} {d : ℕ} [NeZero d]
+    {l p : ℕ} (ll : Nat.Prime l) (pp : Nat.Prime p) (hlN : l ∣ N) (hpN : p ∣ N) (hld : l ∣ d)
+    [NeZero (d / l)] [NeZero (p * d)] (hml : jqNModC K (d / l) ∈ F) (hmp : jqNModC K (p * d) ∈ F) :
+    jqNModC K d ∈ F := by
+  have : Fact (Nat.Prime l) := ⟨ll⟩
+  have : Fact (Nat.Prime p) := ⟨pp⟩
+  have : NeZero l := ⟨ll.ne_zero⟩
+  have : NeZero p := ⟨pp.ne_zero⟩
+  have hNl0 : N / l ≠ 0 := fun h0 => NeZero.ne N (by rw [← Nat.div_mul_cancel hlN, h0, zero_mul])
+  have : NeZero (N / l) := ⟨hNl0⟩
+  have hζl := isPrimitiveRoot_pow_div hζ hlN
+  have hζp := isPrimitiveRoot_pow_div hζ hpN
+  have hle : l * (N / l * (d / l)) = N * (d / l) := by
+    rw [← mul_assoc, Nat.mul_div_cancel' hlN]
+  have hle2 : l * (l * (N / l * (d / l))) = N * d := by
+    rw [hle, mul_left_comm, Nat.mul_div_cancel' hld]
+  have hpe : N * (p * d) = p * (N * d) := Nat.mul_left_comm N p d
+  have data_l : ModularPolynomialData l := (ModularCurve.exists_phiIrreducible_evalSymm l).choose
+  have data_p : ModularPolynomialData p := (ModularCurve.exists_phiIrreducible_evalSymm p).choose
+  let : Algebra F (LaurentSeries K) :=
+    ((qExpand K N).comp (algebraMap F (LaurentSeries K))).toAlgebra
+  have hmapA : (phiAtSeed data_l (⟨jqNModC K (d / l), hml⟩ : F)).map (algebraMap F (LaurentSeries
+    K))
+      = phiAtSeed data_l (qExpand K N (jqNModC K (d / l))) :=
+    phiAtSeed_map data_l _ _
+  have hmapB : (phiAtSeed data_p (⟨jqNModC K (p * d), hmp⟩ : F)).map (algebraMap F (LaurentSeries
+    K))
+      = phiAtSeed data_p (qExpand K N (jqNModC K (p * d))) :=
+    phiAtSeed_map data_p _ _
+  have hseed_l : qExpand K N (jqNModC K (d / l))
+      = qExpand K (l * (N / l * (d / l))) (qTwist ((1 : Kˣ) ^ l) (jqModC K)) := by
+    have h2 : TS K (N * (d / l)) 1 = TS K (l * (N / l * (d / l))) ((1 : Kˣ) ^ l) := by
+      rw [one_pow]
+      exact TS_congr hle.symm 1
+    exact (qExpand_jqNModC N (d / l)).trans h2
+  have hseed_p : qExpand K N (jqNModC K (p * d)) = qExpand K (p * (N * d)) (qTwist ((1 : Kˣ) ^ p)
+    (jqModC K)) :=
+    by
+    have h2 : TS K (N * (p * d)) 1 = TS K (p * (N * d)) ((1 : Kˣ) ^ p) := by
+      rw [one_pow]
+      exact TS_congr hpe 1
+    exact (qExpand_jqNModC N (p * d)).trans h2
+  have hdist_l : qExpand K N (jqNModC K d)
+      = qExpand K (l * (l * (N / l * (d / l)))) (qTwist ((1 : Kˣ) ^ (l * l)) (jqModC K)) := by
+    have h2 : TS K (N * d) 1 = TS K (l * (l * (N / l * (d / l)))) ((1 : Kˣ) ^ (l * l)) := by
+      rw [one_pow]
+      exact TS_congr hle2.symm 1
+    exact (qExpand_jqNModC N d).trans h2
+  have hdist_p : qExpand K N (jqNModC K d) = qExpand K (N * d) (qTwist (1 * (ζ ^ (N / p)) ^ 0)
+    (jqModC K)) :=
+    by
+    rw [pow_zero, mul_one]
+    exact qExpand_jqNModC N d
+  have hrootA : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_l (⟨jqNModC K (d / l), hml⟩ : F)) = 0 ↔
+        (y = qExpand K (l * (l * (N / l * (d / l)))) (qTwist ((1 : Kˣ) ^ (l * l)) (jqModC K)) ∨
+          ∃ b < l, y = qExpand K (N / l * (d / l)) (qTwist (1 * (ζ ^ (N / l)) ^ b) (jqModC K)))
+            := by
+    intro y
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hmapA, hseed_l]
+    exact isRoot_prime_at_slot_iff l (ζ ^ (N / l)) hζl data_l (N / l * (d / l)) 1 y
+  have hrootB : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_p (⟨jqNModC K (p * d), hmp⟩ : F)) = 0 ↔
+        (y = qExpand K (p * (p * (N * d))) (qTwist ((1 : Kˣ) ^ (p * p)) (jqModC K)) ∨
+          ∃ c < p, y = qExpand K (N * d) (qTwist (1 * (ζ ^ (N / p)) ^ c) (jqModC K))) := by
+    intro y
+    rw [Polynomial.aeval_def, ← Polynomial.eval_map, hmapB, hseed_p]
+    exact isRoot_prime_at_slot_iff p (ζ ^ (N / p)) hζp data_p (N * d) 1 y
+  have hA0 : phiAtSeed data_l (⟨jqNModC K (d / l), hml⟩ : F) ≠ 0 :=
+    (phiAtSeed_monic data_l _).ne_zero
+  have hAs : ((phiAtSeed data_l (⟨jqNModC K (d / l), hml⟩ : F)).map (algebraMap F (LaurentSeries
+    K))).Splits :=
+    by
+    rw [hmapA, hseed_l, phiAtSeed,
+      ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot l (ζ ^ (N / l)) hζl data_l (N / l
+      * (d / l)) 1]
+    exact (Polynomial.Splits.X_sub_C _).mul (Polynomial.Splits.prod fun b _ =>
+      Polynomial.Splits.X_sub_C _)
+  have hAnd : ((phiAtSeed data_l (⟨jqNModC K (d / l), hml⟩ : F)).map (algebraMap F (LaurentSeries
+    K))).roots.Nodup :=
+    by
+    rw [hmapA, hseed_l, phiAtSeed]
+    exact roots_prime_at_slot_roots_nodup l (ζ ^ (N / l)) hζl data_l (N / l * (d / l)) 1
+  have hxA : Polynomial.aeval (qExpand K N (jqNModC K d)) (phiAtSeed data_l (⟨jqNModC K (d / l),
+    hml⟩ : F)) = 0 :=
+    (hrootA _).mpr (Or.inl hdist_l)
+  have hxB : Polynomial.aeval (qExpand K N (jqNModC K d)) (phiAtSeed data_p (⟨jqNModC K (p * d),
+    hmp⟩ : F)) = 0 :=
+    (hrootB _).mpr (Or.inr ⟨0, pp.pos, hdist_p⟩)
+  have he0 : 0 < N / l * (d / l) := Nat.pos_of_ne_zero (NeZero.ne _)
+  set e₁ := N / l * (d / l) with he₁
+  have hl2 : 2 ≤ l := ll.two_le
+  have hp2 : 2 ≤ p := pp.two_le
+  have hbig1 : 2 * (2 * e₁) ≤ l * (l * e₁) := Nat.mul_le_mul hl2 (Nat.mul_le_mul hl2 le_rfl)
+  have hbig2 : 2 * (2 * (l * (l * e₁))) ≤ p * (p * (l * (l * e₁))) :=
+    Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+  have huniq : ∀ y : LaurentSeries K,
+      Polynomial.aeval y (phiAtSeed data_l (⟨jqNModC K (d / l), hml⟩ : F)) = 0 →
+      Polynomial.aeval y (phiAtSeed data_p (⟨jqNModC K (p * d), hmp⟩ : F)) = 0 →
+      y = qExpand K N (jqNModC K d) := by
+    intro y hyA hyB
+    rcases (hrootA y).mp hyA with hy1 | ⟨b, _, hy1⟩
+    · exact hy1.trans hdist_l.symm
+    · exfalso
+      rcases (hrootB y).mp hyB with hy2 | ⟨c, _, hy2⟩
+      · have hTS : TS K e₁ (1 * (ζ ^ (N / l)) ^ b) = TS K (p * (p * (N * d))) ((1 : Kˣ) ^ (p * p))
+          :=
+          hy1.symm.trans hy2
+        have he : e₁ = p * (p * (N * d)) := (TS_injective hTS).1
+        rw [← hle2] at he
+        omega
+      · have hTS : TS K e₁ (1 * (ζ ^ (N / l)) ^ b) = TS K (N * d) (1 * (ζ ^ (N / p)) ^ c) :=
+          hy1.symm.trans hy2
+        have he : e₁ = N * d := (TS_injective hTS).1
+        rw [← hle2] at he
+        omega
+  have hrange := Polynomial.mem_range_of_unique_common_root
+    (phiAtSeed data_l (⟨jqNModC K (d / l), hml⟩ : F)) (phiAtSeed data_p (⟨jqNModC K (p * d), hmp⟩ :
+      F))
+    hA0 hAs hAnd (qExpand K N (jqNModC K d)) hxA hxB huniq
+  obtain ⟨f, hf⟩ := RingHom.mem_range.mp hrange
+  have hf' : qExpand K N (f : LaurentSeries K) = qExpand K N (jqNModC K d) := hf
+  have hval : (f : LaurentSeries K) = jqNModC K d := qExpand_injective N hf'
+  rw [← hval]
+  exact f.2
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_congr qExpand_qExpand dedekindPsi ModularPolynomialData coeffMap \
+  coeffMap_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm jqModC \
+  jqNModC jqNModC_one map_jqModC coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm dedekindPsi_prime"
+namespace W1
+p2m_open "ModularCurve"
+
+variable {K : Type*} [Field K]
+
+theorem jqNModC_mem_adjoin_top_insert (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (a : ℕ)
+    (hpM : ¬ p ∣ M)
+    (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) (M * p ^ (a + 1))) :
+    ∀ (d : ℕ) [NeZero d], d ∣ M * p ^ (a + 1) →
+      jqNModC K d ∈ IntermediateField.adjoin K (insert (jqNModC K (p ^ (a + 1))) (divSet K (M * p ^
+        a))) := by
+  intro d
+  induction d using Nat.strong_induction_on with
+  | _ d ih =>
+    intro hd0 hdN
+    by_cases hbase : d ∣ M * p ^ a
+    · exact IntermediateField.subset_adjoin K _ (Set.mem_insert_of_mem _ (jqNModC_mem_divSet hbase))
+    · have hcop : Nat.Coprime M (p ^ (a + 1)) :=
+        (Nat.Coprime.pow_right _ (((Nat.Prime.coprime_iff_not_dvd hp.out).mpr hpM).symm))
+      have hsplit : Nat.gcd d M * Nat.gcd d (p ^ (a + 1)) = d :=
+        (Nat.gcd_mul_gcd_eq_iff_dvd_mul_of_coprime hcop).mpr hdN
+      set m := Nat.gcd d M with hmdef
+      have hmM : m ∣ M := Nat.gcd_dvd_right d M
+      have hm0 : m ≠ 0 := fun h0 => NeZero.ne M (Nat.eq_zero_of_zero_dvd (h0 ▸ hmM))
+      obtain ⟨j, hj, hpj⟩ := (Nat.dvd_prime_pow hp.out).mp (Nat.gcd_dvd_right d (p ^ (a + 1)))
+      have hd : d = m * p ^ j := by rw [← hsplit, hpj]
+      have hja : j = a + 1 := by
+        by_contra hja
+        exact hbase (hd ▸ mul_dvd_mul hmM (pow_dvd_pow p (by omega)))
+      rw [hja] at hd
+      rcases eq_or_ne m 1 with hm1 | hm1
+      · rw [jqNModC_congr (show d = p ^ (a + 1) by rw [hd, hm1, one_mul])]
+        exact IntermediateField.subset_adjoin K _ (Set.mem_insert _ _)
+      · set q := m.minFac with hqdef
+        have hq : q.Prime := Nat.minFac_prime hm1
+        have hqm : q ∣ m := Nat.minFac_dvd m
+        have hqp : p ≠ q := fun h => hpM ((h ▸ hqm).trans hmM)
+        have hpd : p ∣ d := hd ▸ Dvd.dvd.mul_left (dvd_pow_self p (Nat.succ_ne_zero a)) m
+        have hqd : q ∣ d := hd ▸ (hqm.trans (dvd_mul_right m (p ^ (a + 1))))
+        obtain ⟨m', hm'⟩ := hqm
+        have hm'0 : m' ≠ 0 := fun h0 => hm0 (by rw [hm', h0, Nat.mul_zero])
+        have hdp : d / p = m * p ^ a := by
+          rw [hd, pow_succ, ← Nat.mul_assoc, Nat.mul_div_cancel _ hp.out.pos]
+        have hdq : d / q = m' * p ^ (a + 1) := by
+          rw [hd, hm', Nat.mul_assoc, Nat.mul_div_cancel_left _ hq.pos]
+        have : NeZero (d / p) :=
+          ⟨by rw [hdp]; exact Nat.mul_ne_zero hm0 (pow_ne_zero _ hp.out.ne_zero)⟩
+        have : NeZero (d / q) :=
+          ⟨by rw [hdq]; exact Nat.mul_ne_zero hm'0 (pow_ne_zero _ hp.out.ne_zero)⟩
+        have hmem_p : jqNModC K (d / p) ∈
+            IntermediateField.adjoin K (insert (jqNModC K (p ^ (a + 1))) (divSet K (M * p ^ a)))
+              := by
+          refine IntermediateField.subset_adjoin K _ (Set.mem_insert_of_mem _ (jqNModC_mem_divSet
+            ?_))
+          rw [hdp]
+          exact mul_dvd_mul hmM dvd_rfl
+        have hmem_q : jqNModC K (d / q) ∈
+            IntermediateField.adjoin K (insert (jqNModC K (p ^ (a + 1))) (divSet K (M * p ^ a)))
+              := by
+          refine ih (d / q) (Nat.div_lt_self (Nat.pos_of_ne_zero hd0.out) hq.one_lt) ?_
+          exact (Nat.div_dvd_of_dvd hqd).trans hdN
+        exact jqNModC_mem_of_div_primes ζ hζ hdN hp.out hq hqp hpd hqd hmem_p hmem_q
+
+theorem fullC_succ_eq_adjoin_insert_divSet (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (a : ℕ)
+    (hpM : ¬ p ∣ M) (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) (M * p ^ (a + 1))) :
+    fullC K (M * p ^ (a + 1))
+      = IntermediateField.adjoin K (insert (jqNModC K (p ^ (a + 1))) (divSet K (M * p ^ a))) := by
+  refine le_antisymm ?_ ?_
+  · rw [fullC_le_iff]
+    intro d hd0 hd
+    exact jqNModC_mem_adjoin_top_insert M p a hpM ζ hζ d hd
+  · rw [IntermediateField.adjoin_le_iff]
+    rintro x (rfl | hx)
+    · exact jqNModC_mem_fullC (dvd_mul_left _ _)
+    · exact fullC_mono (mul_dvd_mul_left M (pow_dvd_pow p (Nat.le_succ a)))
+        (IntermediateField.subset_adjoin K _ hx)
+
+theorem fullC_mul_prime_eq_adjoin_insert_image (L₀ : ℕ) [NeZero L₀] (p : ℕ)
+    [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) (L₀ * p)) :
+    fullC K (L₀ * p) = IntermediateField.adjoin K (insert (jqModC K) ((qExpandₐK K p) '' divSet K
+      L₀)) := by
+  refine le_antisymm ?_ ?_
+  · rw [fullC_le_iff]
+    intro d
+    induction d using Nat.strong_induction_on with
+    | _ d ih =>
+      intro hd0 hdL
+      by_cases hpd : p ∣ d
+      · obtain ⟨d', rfl⟩ := hpd
+        have hd'L : d' ∣ L₀ := by
+          have h := hdL
+          rw [Nat.mul_comm L₀ p] at h
+          exact Nat.dvd_of_mul_dvd_mul_left hp.out.pos h
+        have : NeZero d' := ⟨fun h0 => hd0.out (by rw [h0, Nat.mul_zero])⟩
+        exact IntermediateField.subset_adjoin K _
+          (Set.mem_insert_of_mem _ ⟨jqNModC K d', jqNModC_mem_divSet hd'L, qExpandₐK_jqNModC p d'⟩)
+      · have hdL₀ : d ∣ L₀ :=
+          Nat.Coprime.dvd_of_dvd_mul_right (((Nat.Prime.coprime_iff_not_dvd hp.out).mpr hpd).symm)
+            hdL
+        rcases eq_or_ne d 1 with hd1 | hd1
+        · subst hd1
+          rw [jqNModC_one]
+          exact IntermediateField.subset_adjoin K _ (Set.mem_insert _ _)
+        · set l := d.minFac with hldef
+          have hl : l.Prime := Nat.minFac_prime hd1
+          obtain ⟨d₁, hd₁⟩ := (Nat.minFac_dvd d : l ∣ d)
+          have hd₁0 : d₁ ≠ 0 := fun h0 => hd0.out (by rw [hd₁, h0, Nat.mul_zero])
+          have hdl : d / l = d₁ := by rw [hd₁, Nat.mul_div_cancel_left _ hl.pos]
+          have : NeZero (d / l) := ⟨by rw [hdl]; exact hd₁0⟩
+          have hld : l ∣ d := ⟨d₁, hd₁⟩
+          have hmem_l : jqNModC K (d / l)
+              ∈ IntermediateField.adjoin K (insert (jqModC K) ((qExpandₐK K p) '' divSet K L₀))
+                := by
+            refine ih (d / l) (Nat.div_lt_self (Nat.pos_of_ne_zero hd0.out) hl.one_lt) ?_
+            exact (Nat.div_dvd_of_dvd hld).trans hdL
+          have hmem_p : jqNModC K (p * d)
+              ∈ IntermediateField.adjoin K (insert (jqModC K) ((qExpandₐK K p) '' divSet K L₀)) :=
+            IntermediateField.subset_adjoin K _
+              (Set.mem_insert_of_mem _ ⟨jqNModC K d, jqNModC_mem_divSet hdL₀, qExpandₐK_jqNModC p
+                d⟩)
+          exact jqNModC_mem_of_div_prime_of_mul_prime ζ hζ hl hp.out (hld.trans hdL) (dvd_mul_left p
+            L₀) hld
+            hmem_l hmem_p
+  · rw [IntermediateField.adjoin_le_iff]
+    rintro x (rfl | ⟨y, ⟨d, hd0, hdL, rfl⟩, rfl⟩)
+    · exact jqModC_mem_fullC _
+    · rw [qExpandₐK_jqNModC]
+      have h : d * p ∣ L₀ * p := mul_dvd_mul_right hdL p
+      rw [Nat.mul_comm d p] at h
+      exact jqNModC_mem_fullC h
+
+section eFullDegree
+
+variable (L₀ : ℕ) (p : ℕ) [hp : Fact (Nat.Prime p)]
+
+theorem jqNModC_prime_mem_eFull : jqNModC K p ∈ eFull K p L₀ := by
+  have h := jqNModC_mul_mem_eFull (K := K) p (d := 1) (one_dvd L₀)
+  rwa [jqNModC_congr (Nat.mul_one p)] at h
+
+omit hp in
+theorem phiAtSeed_jqNModC_prime_eval_jqModC [NeZero p] (data : ModularPolynomialData p)
+    (hsymm : EvalSymm data.Φ) :
+    (phiAtSeed data (jqNModC K p)).eval (jqModC K) = 0 := by
+  have h := phiAtSeed_jqNModC_eval_symm (R := K) p data hsymm 1
+  rwa [jqNModC_congr (Nat.one_mul p), jqNModC_one] at h
+
+theorem isIntegral_jqModC_eFull : IsIntegral (eFull K p L₀) (jqModC K) := by
+  obtain ⟨data, -, hsymm⟩ := ModularCurve.exists_phiIrreducible_evalSymm p
+  exact isIntegral_of_phiAtSeed_root data (jqNModC_prime_mem_eFull L₀ p)
+    (phiAtSeed_jqNModC_prime_eval_jqModC p data hsymm)
+
+theorem natDegree_minpoly_jqModC_eFull_le :
+    (minpoly (eFull K p L₀) (jqModC K)).natDegree ≤ p + 1 := by
+  obtain ⟨data, -, hsymm⟩ := ModularCurve.exists_phiIrreducible_evalSymm p
+  have h :=
+    natDegree_minpoly_le_dedekindPsi_of_phiAtSeed_root data (jqNModC_prime_mem_eFull (K := K) L₀ p)
+    (phiAtSeed_jqNModC_prime_eval_jqModC (K := K) p data hsymm)
+  rwa [ModularCurve.dedekindPsi_prime hp.out] at h
+
+theorem natDegree_minpoly_jqModC_eFull_le_of_dvd (hpL : p ∣ L₀) :
+    (minpoly (eFull K p L₀) (jqModC K)).natDegree ≤ p := by
+  obtain ⟨data, -, hsymm⟩ := ModularCurve.exists_phiIrreducible_evalSymm p
+  have hr : jqNModC K (p * p) ∈ eFull K p L₀ := jqNModC_mul_mem_eFull p hpL
+  have hrroot : (phiAtSeed data (jqNModC K p)).eval (jqNModC K (p * p)) = 0 :=
+    phiAtSeed_jqNModC_eval (R := K) p data p
+  have hne : jqModC K ≠ jqNModC K (p * p) := by
+    intro h
+    have h1 : (1 : ℕ) = p * p := jqNModC_injective (by rw [jqNModC_one]; exact h)
+    nlinarith [hp.out.two_le]
+  have h :=
+    natDegree_minpoly_le_of_phiAtSeed_root_of_root_mem data (jqNModC_prime_mem_eFull (K := K) L₀ p)
+      hr hrroot
+    (phiAtSeed_jqNModC_prime_eval_jqModC (K := K) p data hsymm) hne
+  rw [ModularCurve.dedekindPsi_prime hp.out] at h
+  omega
+
+theorem le_natDegree_minpoly_jqModC_eFull (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) p) :
+    p ≤ (minpoly (eFull K p L₀) (jqModC K)).natDegree := by
+  classical
+  have hint : IsIntegral (eFull K p L₀) (jqModC K) := isIntegral_jqModC_eFull L₀ p
+  have hζp : ζ ^ p = 1 := units_pow_eq_one_of_isPrimitiveRoot hζ
+  have hroot : ∀ b : ℕ, Polynomial.aeval (qTwist (ζ ^ b) (jqModC K)) (minpoly (eFull K p L₀) (jqModC
+    K)) = 0 :=
+    by
+    intro b
+    have hvb : (ζ ^ b) ^ p = 1 := by rw [← pow_mul, Nat.mul_comm, pow_mul, hζp, one_pow]
+    have hfix : (qTwist (ζ ^ b)).comp (algebraMap (eFull K p L₀) (LaurentSeries K))
+        = algebraMap (eFull K p L₀) (LaurentSeries K) := by
+      refine RingHom.ext fun x => ?_
+      rw [RingHom.comp_apply]
+      exact qTwist_eq_self_of_mem_eFull p hvb x.2
+    have h0 := minpoly.aeval (eFull K p L₀) (jqModC K)
+    rw [Polynomial.aeval_def] at h0 ⊢
+    have h1 :=
+      Polynomial.hom_eval₂ (minpoly (eFull K p L₀) (jqModC K)) (algebraMap (eFull K p L₀)
+        (LaurentSeries K))
+      (qTwist (ζ ^ b)) (jqModC K)
+    rw [hfix, h0, map_zero] at h1
+    exact h1.symm
+  have hmne : (minpoly (eFull K p L₀) (jqModC K)).map (algebraMap (eFull K p L₀) (LaurentSeries K))
+    ≠ 0 :=
+    ((minpoly.monic hint).map _).ne_zero
+  have hmem : ∀ b : ℕ, qTwist (ζ ^ b) (jqModC K)
+      ∈ ((minpoly (eFull K p L₀) (jqModC K)).map (algebraMap (eFull K p L₀) (LaurentSeries
+        K))).roots.toFinset := by
+    intro b
+    rw [Multiset.mem_toFinset, Polynomial.mem_roots hmne, Polynomial.IsRoot.def,
+      Polynomial.eval_map_algebraMap]
+    exact hroot b
+  have hinj : Set.InjOn (fun b : ℕ => qTwist (ζ ^ b) (jqModC K)) ↑(Finset.range p) := by
+    intro b hb b' hb' h
+    rw [Finset.coe_range, Set.mem_Iio] at hb hb'
+    have h0 : qTwist (ζ ^ b) (jqModC K) = qTwist (ζ ^ b') (jqModC K) := h
+    rw [qTwist_jqModC_eq_TS, qTwist_jqModC_eq_TS] at h0
+    have h2 : ζ ^ b = ζ ^ b' := (TS_injective h0).2
+    have h3 : ((ζ : Kˣ) : K) ^ b = ((ζ : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h2]
+    exact hζ.pow_inj hb hb' h3
+  have hcard : ((Finset.range p).image (fun b : ℕ => qTwist (ζ ^ b) (jqModC K))).card = p := by
+    rw [Finset.card_image_of_injOn hinj, Finset.card_range]
+  have hsub : (Finset.range p).image (fun b : ℕ => qTwist (ζ ^ b) (jqModC K))
+      ⊆ ((minpoly (eFull K p L₀) (jqModC K)).map (algebraMap (eFull K p L₀) (LaurentSeries
+        K))).roots.toFinset := by
+    intro x hx
+    obtain ⟨b, -, rfl⟩ := Finset.mem_image.mp hx
+    exact hmem b
+  calc p = ((Finset.range p).image (fun b : ℕ => qTwist (ζ ^ b) (jqModC K))).card := hcard.symm
+    _ ≤ ((minpoly (eFull K p L₀) (jqModC K)).map (algebraMap (eFull K p L₀) (LaurentSeries
+      K))).roots.toFinset.card :=
+        Finset.card_le_card hsub
+    _ ≤ ((minpoly (eFull K p L₀) (jqModC K)).map (algebraMap (eFull K p L₀) (LaurentSeries
+      K))).roots.card :=
+        Multiset.toFinset_card_le _
+    _ ≤ ((minpoly (eFull K p L₀) (jqModC K)).map (algebraMap (eFull K p L₀) (LaurentSeries
+      K))).natDegree :=
+        Polynomial.card_roots' _
+    _ = (minpoly (eFull K p L₀) (jqModC K)).natDegree := (minpoly.monic hint).natDegree_map _
+
+theorem relfinrank_eFull_fullC_eq_natDegree [NeZero L₀] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) (L₀ * p)) :
+    IntermediateField.relfinrank (eFull K p L₀) (fullC K (L₀ * p)) = (minpoly (eFull K p L₀) (jqModC
+      K)).natDegree := by
+  rw [fullC_mul_prime_eq_adjoin_insert_image L₀ p ζ hζ]
+  exact relfinrank_eFull_insert_eq_natDegree p L₀ (isIntegral_jqModC_eFull L₀ p)
+
+end eFullDegree
+
+theorem finrank_adjoin_jqNModC_prime_of_not_mem' (F : IntermediateField K (LaurentSeries K))
+    (hj : jqModC K ∈ F)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) p)
+    (hpF : jqNModC K p ∉ F) :
+    Module.finrank F (IntermediateField.adjoin F ({jqNModC K p} : Set (LaurentSeries K))) = p + 1
+      := by
+  classical
+  obtain ⟨data, -, -⟩ := ModularCurve.exists_phiIrreducible_evalSymm p
+  have hζp : ζ ^ p = 1 := units_pow_eq_one_of_isPrimitiveRoot hζ
+  have hrel : (phiAtSeed data (jqModC K)).eval (jqNModC K p) = 0 := by
+    have h := phiAtSeed_jqNModC_eval (R := K) p data 1
+    rwa [jqNModC_one, jqNModC_congr (Nat.one_mul p)] at h
+  have hPmonic : (phiAtSeed data (⟨jqModC K, hj⟩ : F)).Monic := phiAtSeed_monic data _
+  have hPdeg : (phiAtSeed data (⟨jqModC K, hj⟩ : F)).natDegree = p + 1 := by
+    rw [phiAtSeed_natDegree, ModularCurve.dedekindPsi_prime hp.out]
+  have hProot : Polynomial.aeval (jqNModC K p) (phiAtSeed data (⟨jqModC K, hj⟩ : F)) = 0 :=
+    aeval_phiAtSeed_eq_zero data hj hrel
+  have hα : IsIntegral F (jqNModC K p) := isIntegral_of_phiAtSeed_root data hj hrel
+  have hseed : qExpand K p (jqModC K) = qExpand K (p * 1) (qTwist ((1 : Kˣ) ^ p) (jqModC K)) := by
+    rw [one_pow, qTwist_one_apply]
+    exact qExpand_congr (Nat.mul_one p).symm _
+  have hspread : qExpand K p (jqNModC K p) = qExpand K (p * (p * 1)) (qTwist ((1 : Kˣ) ^ (p * p))
+    (jqModC K)) :=
+    by
+    rw [one_pow, qTwist_one_apply, jqNModC, qExpand_qExpand]
+    exact qExpand_congr (by ring) _
+  have hirr : Irreducible (phiAtSeed data (⟨jqModC K, hj⟩ : F)) := by
+    let : Algebra F (LaurentSeries K) :=
+      ((qExpand K p).comp (algebraMap F (LaurentSeries K))).toAlgebra
+    have halg : ∀ x : F, algebraMap F (LaurentSeries K) x = qExpand K p (x : LaurentSeries K) :=
+      fun _ => rfl
+    have hPmapL : (phiAtSeed data (⟨jqModC K, hj⟩ : F)).map (algebraMap F (LaurentSeries K))
+        = phiAtSeed data (qExpand K (p * 1) (qTwist ((1 : Kˣ) ^ p) (jqModC K))) := by
+      rw [← hseed]
+      exact phiAtSeed_map data _ _
+    have hPs : ((phiAtSeed data (⟨jqModC K, hj⟩ : F)).map (algebraMap F (LaurentSeries K))).Splits
+      :=
+      by
+      rw [hPmapL, phiAtSeed, ModularCurve.PhiGen.splits_prime_at_slot_of_isPrimitiveRoot p ζ hζ data
+        1 1]
+      exact (Polynomial.Splits.X_sub_C _).mul (Polynomial.Splits.prod fun _ _ =>
+        Polynomial.Splits.X_sub_C _)
+    have hroots : ((phiAtSeed data (⟨jqModC K, hj⟩ : F)).map (algebraMap F (LaurentSeries K))).roots
+        = qExpand K (p * (p * 1)) (qTwist ((1 : Kˣ) ^ (p * p)) (jqModC K)) ::ₘ
+            (Multiset.range p).map (fun b => qExpand K 1 (qTwist (1 * ζ ^ b) (jqModC K))) := by
+      rw [hPmapL]
+      exact roots_prime_at_slot p ζ hζ data 1 1
+    have hnodup : ((phiAtSeed data (⟨jqModC K, hj⟩ : F)).map (algebraMap F (LaurentSeries
+      K))).roots.Nodup :=
+      by
+      rw [hPmapL, phiAtSeed]
+      exact roots_prime_at_slot_roots_nodup p ζ hζ data 1 1
+    have hσ : ∀ x : F, qTwistEquiv ζ (algebraMap F (LaurentSeries K) x) = algebraMap F
+      (LaurentSeries K) x :=
+      by
+      intro x
+      rw [halg, qTwistEquiv_apply]
+      exact qTwist_qExpand_of_pow_eq_one p ζ hζp _
+    have hcycle : ∀ i < p, qTwistEquiv ζ (qExpand K 1 (qTwist (1 * ζ ^ i) (jqModC K)))
+        = qExpand K 1 (qTwist (1 * ζ ^ ((i + 1) % p)) (jqModC K)) := by
+      intro i _
+      change qTwist ζ (TS K 1 (1 * ζ ^ i)) = TS K 1 (1 * ζ ^ ((i + 1) % p))
+      rw [one_mul, one_mul]
+      exact qTwist_TS_one_cycle ζ hζp i
+    have hy₀ : qExpand K (p * (p * 1)) (qTwist ((1 : Kˣ) ^ (p * p)) (jqModC K))
+        ∉ (algebraMap F (LaurentSeries K)).range := by
+      rintro ⟨f, hf⟩
+      rw [halg] at hf
+      have h3 : (f : LaurentSeries K) = jqNModC K p := qExpand_injective p (hf.trans hspread.symm)
+      exact hpF (h3 ▸ f.2)
+    exact Polynomial.irreducible_of_transitive_ringAut _ hPmonic hPs (qTwistEquiv ζ) hσ _ _ p hroots
+      hnodup hcycle hy₀
+  have hmin : phiAtSeed data (⟨jqModC K, hj⟩ : F) = minpoly F (jqNModC K p) :=
+    minpoly.eq_of_irreducible_of_monic hirr hProot hPmonic
+  rw [IntermediateField.adjoin.finrank hα, ← hmin, hPdeg]
+
+theorem relfinrank_fullC_step (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (a : ℕ)
+    (hpM : ¬ p ∣ M)
+    (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) (M * p ^ (a + 1)))
+    (hprev : ∀ b : ℕ, a = b + 1 →
+      IntermediateField.relfinrank (fullC K (M * p ^ b)) (fullC K (M * p ^ (b + 1))) = if b = 0 then
+        p + 1 else p)
+    (hnm : a = 0 → jqNModC K p ∉ fullC K M) :
+    IntermediateField.relfinrank (fullC K (M * p ^ a)) (fullC K (M * p ^ (a + 1))) = if a = 0 then p
+      + 1 else p := by
+  classical
+  obtain ⟨data, -, hsymm⟩ := ModularCurve.exists_phiIrreducible_evalSymm p
+  have hp0 : 0 < p := hp.out.pos
+  have hup := fullC_succ_eq_adjoin_insert_divSet M p a hpM ζ hζ
+  have hs : jqNModC K (p ^ a) ∈ fullC K (M * p ^ a) := jqNModC_mem_fullC (dvd_mul_left _ _)
+  have hup_rel : (phiAtSeed data (jqNModC K (p ^ a))).eval (jqNModC K (p ^ (a + 1))) = 0 := by
+    have h := phiAtSeed_jqNModC_eval (R := K) p data (p ^ a)
+    rwa [jqNModC_congr (pow_succ p a).symm] at h
+  have hint : IsIntegral (fullC K (M * p ^ a)) (jqNModC K (p ^ (a + 1))) :=
+    isIntegral_of_phiAtSeed_root data hs hup_rel
+  have hd_eq : IntermediateField.relfinrank (fullC K (M * p ^ a)) (fullC K (M * p ^ (a + 1)))
+      = (minpoly (fullC K (M * p ^ a)) (jqNModC K (p ^ (a + 1)))).natDegree := by
+    rw [hup]
+    exact relfinrank_fullC_insert_eq_natDegree _ hint
+  rcases a with _ | b
+  · rw [ite_eq_left rfl, hd_eq]
+    have hF : fullC K (M * p ^ 0) = fullC K M := by rw [pow_zero, Nat.mul_one]
+    have hpF : jqNModC K p ∉ fullC K (M * p ^ 0) := by
+      rw [hF]
+      exact hnm rfl
+    have hcongr : jqNModC K (p ^ (0 + 1)) = jqNModC K p := jqNModC_congr (by rw [zero_add, pow_one])
+    rw [hcongr] at hint ⊢
+    rw [← IntermediateField.adjoin.finrank hint]
+    exact finrank_adjoin_jqNModC_prime_of_not_mem' _ (jqModC_mem_fullC _) p _
+      (isPrimitiveRoot_pow_div hζ (Dvd.dvd.mul_left (dvd_pow_self p (Nat.succ_ne_zero 0)) M)) hpF
+  · rw [ite_eq_right (Nat.succ_ne_zero b)]
+    have hL0 : M * p ^ (b + 1) = M * p ^ b * p := by ring
+    have hL1 : M * p ^ (b + 1 + 1) = M * p ^ (b + 1) * p := by ring
+    have hpL1 : p ∣ M * p ^ (b + 1 + 1) := Dvd.dvd.mul_left (dvd_pow_self p (Nat.succ_ne_zero _)) M
+    have hζ0 : IsPrimitiveRoot ((ζ ^ (M * p ^ (b + 1 + 1) / (M * p ^ b * p)) : Kˣ) : K) (M * p ^ b *
+      p) :=
+      isPrimitiveRoot_pow_div hζ (by
+        rw [← hL0]; exact mul_dvd_mul_left M (pow_dvd_pow p (Nat.le_succ _)))
+    have hζ1 : IsPrimitiveRoot (ζ : K) (M * p ^ (b + 1) * p) := by
+      rw [← hL1]
+      exact hζ
+    have hζp : IsPrimitiveRoot ((ζ ^ (M * p ^ (b + 1 + 1) / p) : Kˣ) : K) p :=
+      isPrimitiveRoot_pow_div hζ hpL1
+    have hGE : eFull K p (M * p ^ b) ≤ eFull K p (M * p ^ (b + 1)) :=
+      eFull_mono p (mul_dvd_mul_left M (pow_dvd_pow p (Nat.le_succ b)))
+    have hG0 : eFull K p (M * p ^ b) ≤ fullC K (M * p ^ (b + 1)) := by
+      rw [hL0]
+      exact eFull_le_fullC p _
+    have hE1 : eFull K p (M * p ^ (b + 1)) ≤ fullC K (M * p ^ (b + 1 + 1)) := by
+      rw [hL1]
+      exact eFull_le_fullC p _
+    have h01 : fullC K (M * p ^ (b + 1)) ≤ fullC K (M * p ^ (b + 1 + 1)) :=
+      fullC_mono (mul_dvd_mul_left M (pow_dvd_pow p (Nat.le_succ _)))
+    have t1 := IntermediateField.relfinrank_mul_relfinrank hG0 h01
+    have t2 := IntermediateField.relfinrank_mul_relfinrank hGE hE1
+    have hδ : IntermediateField.relfinrank (eFull K p (M * p ^ b)) (eFull K p (M * p ^ (b + 1)))
+        = if b = 0 then p + 1 else p := by
+      rw [eFull_eq_map, eFull_eq_map, IntermediateField.relfinrank_map_map]
+      exact hprev b rfl
+    have hδpos : 0 < IntermediateField.relfinrank (eFull K p (M * p ^ b)) (eFull K p (M * p ^ (b +
+      1))) :=
+      by
+      rw [hδ]
+      split_ifs <;> omega
+    have hx : IntermediateField.relfinrank (eFull K p (M * p ^ b)) (fullC K (M * p ^ (b + 1)))
+        ≤ IntermediateField.relfinrank (eFull K p (M * p ^ b)) (eFull K p (M * p ^ (b + 1))) := by
+      rw [hδ, hL0, relfinrank_eFull_fullC_eq_natDegree (M * p ^ b) p _ hζ0]
+      by_cases hb : b = 0
+      · rw [ite_eq_left hb]
+        exact natDegree_minpoly_jqModC_eFull_le (M * p ^ b) p
+      · rw [ite_eq_right hb]
+        exact natDegree_minpoly_jqModC_eFull_le_of_dvd (M * p ^ b) p (Dvd.dvd.mul_left (dvd_pow_self
+          p hb) M)
+    have hy : p ≤ IntermediateField.relfinrank (eFull K p (M * p ^ (b + 1))) (fullC K (M * p ^ (b +
+      1 + 1))) :=
+      by
+      rw [hL1, relfinrank_eFull_fullC_eq_natDegree (M * p ^ (b + 1)) p ζ hζ1]
+      exact le_natDegree_minpoly_jqModC_eFull (M * p ^ (b + 1)) p _ hζp
+    have hdle : IntermediateField.relfinrank (fullC K (M * p ^ (b + 1))) (fullC K (M * p ^ (b + 1 +
+      1))) ≤ p :=
+      by
+      rw [hd_eq]
+      have hr : jqNModC K (p ^ b) ∈ fullC K (M * p ^ (b + 1)) :=
+        jqNModC_mem_fullC (Dvd.dvd.mul_left (pow_dvd_pow p (Nat.le_succ b)) M)
+      have hrroot : (phiAtSeed data (jqNModC K (p ^ (b + 1)))).eval (jqNModC K (p ^ b)) = 0 := by
+        have h := phiAtSeed_jqNModC_eval_symm (R := K) p data hsymm (p ^ b)
+        rwa [jqNModC_congr (pow_succ p b).symm] at h
+      have htr : jqNModC K (p ^ (b + 1 + 1)) ≠ jqNModC K (p ^ b) := by
+        intro h
+        have h1 := Nat.pow_right_injective hp.out.two_le (jqNModC_injective h)
+        omega
+      have h := natDegree_minpoly_le_of_phiAtSeed_root_of_root_mem data hs hr hrroot hup_rel htr
+      rw [ModularCurve.dedekindPsi_prime hp.out] at h
+      omega
+    have hsq : IntermediateField.relfinrank (eFull K p (M * p ^ b)) (eFull K p (M * p ^ (b + 1))) *
+      p
+        ≤ IntermediateField.relfinrank (eFull K p (M * p ^ b)) (eFull K p (M * p ^ (b + 1)))
+          * IntermediateField.relfinrank (fullC K (M * p ^ (b + 1))) (fullC K (M * p ^ (b + 1 + 1)))
+            :=
+      calc _ ≤ _ := Nat.mul_le_mul le_rfl hy
+        _ = _ := t2
+        _ = _ := t1.symm
+        _ ≤ _ := Nat.mul_le_mul hx le_rfl
+    exact le_antisymm hdle (Nat.le_of_mul_le_mul_left hsq hδpos)
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_injective \
+  qExpand_one_apply qExpand_congr qExpand_qExpand dedekindPsi ModularPolynomialData coeffMap \
+  coeffMap_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand EvalSymm jqModC \
+  jqNModC jqNModC_one map_jqModC coeffMap_qExpand coeff_jqModC_neg_one order_jqModC \
+  PhiGen.splits_prime_at_slot_of_isPrimitiveRoot exists_phiIrreducible_evalSymm dedekindPsi_prime"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.fullC_mul_prime_pow_eq_adjoin {K : Type*} [Field K] (M : ℕ) [NeZero M]
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (a : ℕ) (hpM : ¬ p ∣ M) (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) (M * p ^ (a + 1))) :
+    IntermediateField.adjoin K {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ M * p ^ (a +
+      1) ∧ x = jqNModC K d'} = IntermediateField.adjoin K (insert (jqNModC K (p ^ (a + 1)))
+      ((IntermediateField.adjoin K {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ M * p ^ a
+      ∧ x = jqNModC K d'} : IntermediateField K (LaurentSeries K)) : Set (LaurentSeries K))) := by
+  rw [IntermediateField.adjoin_insert_adjoin]
+  exact fullC_succ_eq_adjoin_insert_divSet M p a hpM ζ hζ
+
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.finrank_adjoin_jqNModC_prime_of_not_mem {K : Type*} [Field K]
+    (F : IntermediateField K (LaurentSeries K)) (hj : jqModC K ∈ F) (p : ℕ)
+    [hp : Fact (Nat.Prime p)] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) p) (hpF : jqNModC K p ∉ F) :
+    Module.finrank F (IntermediateField.adjoin F ({jqNModC K p} : Set (LaurentSeries K))) = p + 1 :=
+  finrank_adjoin_jqNModC_prime_of_not_mem' F hj p ζ hζ hpF
+
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.relfinrank_fullC_mul_prime_pow {K : Type*} [Field K] (M : ℕ) [NeZero M]
+  (p : ℕ) [hp : Fact (Nat.Prime p)] (a : ℕ) (hpM : ¬ p ∣ M) (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K)
+  (M * p ^ (a + 1))) (hprev : ∀ b : ℕ, a = b + 1 → IntermediateField.relfinrank
+  (IntermediateField.adjoin K {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ M * p ^ b ∧ x
+  = jqNModC K d'}) (IntermediateField.adjoin K {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d'
+  ∣ M * p ^ (b + 1) ∧ x = jqNModC K d'}) = if b = 0 then p + 1 else p) (hnm : a = 0 → jqNModC K p ∉
+  IntermediateField.adjoin K {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ M ∧ x = jqNModC
+  K d'}) :
+    IntermediateField.relfinrank (IntermediateField.adjoin K {x : LaurentSeries K | ∃ (d' : ℕ) (_ :
+      NeZero d'), d' ∣ M * p ^ a ∧ x = jqNModC K d'}) (IntermediateField.adjoin K {x : LaurentSeries
+      K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ M * p ^ (a + 1) ∧ x = jqNModC K d'}) = if a = 0 then p +
+      1 else p :=
+  relfinrank_fullC_step M p a hpM ζ hζ hprev hnm
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_relfinrank_fullC_mul_prime_pow.ModularCurve in
+theorem solution {K : Type*} [Field K] (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (a : ℕ)
+  (hpM : ¬ p ∣ M) (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) (M * p ^ (a + 1))) (hprev : ∀ b : ℕ, a = b
+  + 1 → IntermediateField.relfinrank (IntermediateField.adjoin K {x : LaurentSeries K | ∃ (d' : ℕ)
+  (_ : NeZero d'), d' ∣ M * p ^ b ∧ x = jqNModC K d'}) (IntermediateField.adjoin K {x :
+  LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ M * p ^ (b + 1) ∧ x = jqNModC K d'}) = if b = 0
+  then p + 1 else p) (hnm : a = 0 → jqNModC K p ∉ IntermediateField.adjoin K {x : LaurentSeries K |
+  ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ M ∧ x = jqNModC K d'}) :
+    IntermediateField.relfinrank (IntermediateField.adjoin K {x : LaurentSeries K | ∃ (d' : ℕ) (_ :
+      NeZero d'), d' ∣ M * p ^ a ∧ x = jqNModC K d'}) (IntermediateField.adjoin K {x : LaurentSeries
+      K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ M * p ^ (a + 1) ∧ x = jqNModC K d'}) = if a = 0 then p +
+      1 else p :=
+  ModularCurve.relfinrank_fullC_mul_prime_pow M p a hpM ζ hζ hprev hnm
+
+end S_ModularCurve_relfinrank_fullC_mul_prime_pow
+end P2MW
+export P2MW.S_ModularCurve_relfinrank_fullC_mul_prime_pow (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.relfinrank_fullC_mul_prime_pow {K : Type*} [Field K] (M : ℕ) [NeZero M] (p : ℕ)
+  [hp : Fact (Nat.Prime p)] (a : ℕ) (hpM : ¬ p ∣ M) (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) (M * p ^
+  (a + 1))) (hprev : ∀ b : ℕ, a = b + 1 → IntermediateField.relfinrank (IntermediateField.adjoin K
+  {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ M * p ^ b ∧ x = jqNModC K d'})
+  (IntermediateField.adjoin K {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ M * p ^ (b +
+  1) ∧ x = jqNModC K d'}) = if b = 0 then p + 1 else p) (hnm : a = 0 → jqNModC K p ∉
+  IntermediateField.adjoin K {x : LaurentSeries K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ M ∧ x = jqNModC
+  K d'}) :
+    IntermediateField.relfinrank (IntermediateField.adjoin K {x : LaurentSeries K | ∃ (d' : ℕ) (_ :
+      NeZero d'), d' ∣ M * p ^ a ∧ x = jqNModC K d'}) (IntermediateField.adjoin K {x : LaurentSeries
+      K | ∃ (d' : ℕ) (_ : NeZero d'), d' ∣ M * p ^ (a + 1) ∧ x = jqNModC K d'}) = if a = 0 then p +
+      1 else p :=
+  solution M p a hpM ζ hζ hprev hnm
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_relfinrank_full_eq_dedekindPsi.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_relfinrank_full_eq_dedekindPsi.lean
new file mode 100644
index 0000000000..bf99380b34
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_relfinrank_full_eq_dedekindPsi.lean
@@ -0,0 +1,815 @@
+/-
+Based on Prove2Me node ModularCurve.relfinrank_full_eq_dedekindPsi
+(cab9a0f3-98f2-5f8b-b199-b15d58eaf279) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 538a4427-4bf3-52eb-94f1-b15c7aaed5eb
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import Mathlib.FieldTheory.Relrank
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_minpoly_jqN_map_eq_prod_slots
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqN_prime_not_mem_full
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqN_pow_not_mem_adjoin_full
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_full_eq_adjoin_full_div_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_eq_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqN_div_mem_modularFunctionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularFunctionField_eq_full_of
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_modularFunctionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_mul_of_coprime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_prime_pow
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_phiIrreducible_of_finrank_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration_iff_full_eq
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import Mathlib.Data.Nat.Factorization.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Relative degree ψ(N) of the field of divisor q-expansions
+
+Theorem statement: `ModularCurve.relfinrank_full_eq_dedekindPsi`
+(`cab9a0f3-98f2-5f8b-b199-b15d58eaf279`), by Claude, 2026-09-05.
+
+Proof: submission `538a4427-4bf3-52eb-94f1-b15c7aaed5eb`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number assumed nonzero. Inside the field $\mathbb{Q}((q))$ of formal Laurent
+series over $\mathbb{Q}$, let $jq$ denote the series $q^{-1}$ times the image under
+$\mathbb{Z}\to\mathbb{Q}$ of the integral power series `jNum`, i.e. the $q$-expansion of the modular
+invariant $j$. Write $\mathbb{Q}(jq)$ for the intermediate field `IntermediateField.adjoin ℚ {jq}`,
+and let `modularFunctionFieldFull N` be the intermediate field of $\mathbb{Q}((q))/\mathbb{Q}$
+generated by the set of all substitutions $q\mapsto q^{d}$ applied to $jq$, namely $\{\,$`qExpand ℚ
+d jq` $: d\neq 0,\ d\mid N\,\}$, so the field generated over $\mathbb{Q}$ by the expansions
+$j(q^{d})$ for the positive divisors $d$ of $N$. The assertion is that the relative degree, in the
+sense of `IntermediateField.relfinrank`, of `modularFunctionFieldFull N` over $\mathbb{Q}(jq)$
+equals `dedekindPsi N`, defined as the sum $\sum_{d\mid N,\ d\ \text{squarefree}} N/d$; since $d=1$
+divides $N$, the smaller field is contained in the larger one, so this is the degree
+$[\mathbb{Q}(j(q^{d}):d\mid N):\mathbb{Q}(j(q))]$, and the sum is the Dedekind $\psi$-function
+$N\prod_{p\mid N}(1+p^{-1})$.
+
+This is the degree statement equivalent to the irreducibility of the modular polynomial $\Phi_N$
+over $\mathbb{Q}(j)$, here in the relative-degree form for subfields of $\mathbb{Q}((q))$ generated
+by $q$-expansions. It underlies the function-field description of the modular curves $X_0(N)$ and is
+used in the subsequent degree computations and in the analysis of places and their prolongations
+along $j$ and $j(q^N)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_relfinrank_full_eq_dedekindPsi.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_relfinrank_full_eq_dedekindPsi
+
+noncomputable section
+
+p2m_open "ModularCurve~coeffEmb_qExpand \
+  P2MW.S_ModularCurve_relfinrank_full_eq_dedekindPsi.ModularCurve ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+
+
+
+
+
+
+
+
+
+
+theorem coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb K (qExpand ℚ n x) = qExpand K n (coeffEmb K x) :=
+  coeffMap_qExpand (algebraMap ℚ K) n x
+
+theorem iota_jqN (N d : ℕ) [NeZero N] [NeZero d] :
+    coeffEmb K (qExpand ℚ N (jqN d)) = TS K (N * d) 1 := by
+  rw [jqN, coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem iota_jq (N : ℕ) [NeZero N] : coeffEmb K (qExpand ℚ N jq) = TS K N 1 := by
+  rw [coeffEmb_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_zero_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    conj p ζ (0 : Fin (p + 1)) = TS K (p * p) 1 := by
+  rw [conj_zero, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_succ_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) (b : Fin p) :
+    conj p ζ b.succ = TS K 1 (ζ ^ (b : ℕ)) := by
+  rw [conj_succ, TS_eq_coeffEmb, qExpand_one_apply]
+
+theorem qTwist_iota_of_pow_eq_one (N : ℕ) [NeZero N] (v : Kˣ) (hv : v ^ N = 1) (x : LaurentSeries ℚ)
+    :
+    qTwist v (coeffEmb K (qExpand ℚ N x)) = coeffEmb K (qExpand ℚ N x) := by
+  rw [coeffEmb_qExpand, qTwist_qExpand]
+  have : v ^ (N : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+omit [Algebra ℚ K] in
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+omit [Algebra ℚ K] in
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+omit [Algebra ℚ K] in
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem phiProd_conj_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    phiProd p (conj p ζ) = (Polynomial.X - Polynomial.C (TS K (p * p) 1)) *
+      ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) := by
+  rw [phiProd, Fin.prod_univ_succ, conj_zero_eq]
+  congr 1
+  rw [← Fin.prod_univ_eq_prod_range (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) p]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [conj_succ_eq]
+
+theorem roots_phiProd_conj (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    (phiProd p (conj p ζ)).roots = TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^
+      b)) := by
+  classical
+  rw [phiProd_conj_eq]
+  have h1 : (Polynomial.X - Polynomial.C (TS K (p * p) 1) : Polynomial (LaurentSeries K)) ≠ 0 :=
+    Polynomial.X_sub_C_ne_zero _
+  have h2 : (∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b)))) ≠ 0 :=
+    Finset.prod_ne_zero_iff.mpr fun b _ => Polynomial.X_sub_C_ne_zero _
+  rw [Polynomial.roots_mul (mul_ne_zero h1 h2), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod,
+    Finset.range_val]
+  have hm : (Multiset.map (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) (Multiset.range
+    p)) =
+      ((Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).map (fun a => Polynomial.X - Polynomial.C
+        a) := by
+    rw [Multiset.map_map]; rfl
+  rw [hm, Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+omit [Algebra ℚ K] in
+theorem roots_phiProd_conj_nodup (p : ℕ) [hp : Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).Nodup := by
+  refine Multiset.nodup_cons.mpr ⟨?_, ?_⟩
+  · intro hmem
+    obtain ⟨b, -, hb⟩ := Multiset.mem_map.mp hmem
+    have := (TS_injective hb).1
+    have h2 := hp.out.two_le
+    nlinarith
+  · refine (Multiset.nodup_range p).map_on fun b hb b' hb' hbb' => ?_
+    rw [Multiset.mem_range] at hb hb'
+    have hu := (TS_injective hbb').2
+    have hζu : IsPrimitiveRoot ζ p := IsPrimitiveRoot.coe_units_iff.mp hζ
+    exact hζu.pow_inj hb hb' hu
+
+theorem exists_isPrimitiveRoot_cyclotomicField (N : ℕ) [NeZero N] :
+    ∃ z : CyclotomicField N ℚ, IsPrimitiveRoot z N := by
+  have : NeZero ((N : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr (NeZero.ne N)⟩
+  have : IsCyclotomicExtension {N} ℚ (CyclotomicField N ℚ) :=
+    CyclotomicField.isCyclotomicExtension N ℚ
+  exact IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField N ℚ) (Set.mem_singleton N)
+    (NeZero.ne N)
+
+def cycUnit (N : ℕ) [NeZero N] : (CyclotomicField N ℚ)ˣ :=
+  ((exists_isPrimitiveRoot_cyclotomicField N).choose_spec.isUnit (NeZero.ne N)).unit
+
+theorem cycUnit_spec (N : ℕ) [NeZero N] :
+    IsPrimitiveRoot ((cycUnit N : (CyclotomicField N ℚ)ˣ) : CyclotomicField N ℚ) N := by
+  rw [cycUnit, IsUnit.unit_spec]
+  exact (exists_isPrimitiveRoot_cyclotomicField N).choose_spec
+
+theorem cycUnit_pow (N : ℕ) [NeZero N] : cycUnit N ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, (cycUnit_spec N).pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem prod_form_ne_zero (N : ℕ) (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e]
+    (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K
+            jq)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+          (Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u,
+    Polynomial.roots_mul (prod_form_ne_zero N ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p)))
+    (coeffEmb K jq))))
+        = ((Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+        (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+        (Multiset.range p).map
+          (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).Nodup := by
+  have hζp : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := isPrimitiveRoot_pow_div hζ hpN
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h := (TS_injective (K := K) (e := e) (e' := p * (p * e))
+      (u := u * ζ ^ (b * (N / p))) (u' := u ^ (p * p))
+      (by simpa only [TS_eq_coeffEmb] using heq)).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e)
+      (u := u * ζ ^ (b * (N / p))) (u' := u * ζ ^ (b' * (N / p)))
+      (by simpa only [TS_eq_coeffEmb] using heq)).2
+    have h2 : ζ ^ (b * (N / p)) = ζ ^ (b' * (N / p)) := mul_left_cancel h
+    have h3 : (ζ ^ (N / p)) ^ b = (ζ ^ (N / p)) ^ b' := by
+      rw [← pow_mul, ← pow_mul, Nat.mul_comm (N / p) b, Nat.mul_comm (N / p) b']
+      exact h2
+    have h4 : ((ζ ^ (N / p) : Kˣ) : K) ^ b = ((ζ ^ (N / p) : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h3]
+    exact hζp.pow_inj hb hb' h4
+
+theorem roots_prime_at_slot_roots_nodup (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots.Nodup := by
+  rw [roots_prime_at_slot N ζ hζ p hpN data e u]
+  exact roots_prime_at_slot_nodup N ζ hζ p hpN e u
+
+theorem isRoot_prime_at_slot_iff (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u]
+    exact prod_form_ne_zero N ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot N ζ hζ p hpN data e u,
+    Multiset.mem_cons, Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+
+
+
+
+theorem phiAtSeed_jq_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) :
+    (phiAtSeed data jq).eval (jqN n) = 0 := by
+  have h := data.eval_eq_zero
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp [evalAtJ_X]
+
+
+theorem phiAtSeed_jqN_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN M)).eval (jqN (M * n)) = 0 := by
+  have h := phiAtSeed_eval_map data jq (jqN n) (qExpand ℚ M) (phiAtSeed_jq_eval n data)
+  rwa [jqN, qExpand_qExpand] at h
+
+theorem phiAtSeed_iota_eval {K : Type*} [Field K] [Algebra ℚ K] (A : ℕ) [NeZero A] (n : ℕ)
+    [NeZero n]
+    (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (coeffEmb K (qExpand ℚ A (jqN M)))).eval (coeffEmb K (qExpand ℚ A (jqN (M *
+      n)))) = 0 :=
+  phiAtSeed_eval_map data _ _ ((coeffEmb K).comp (qExpand ℚ A)) (phiAtSeed_jqN_eval n data M)
+
+end ModularCurve.W1
+
+open scoped IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+section Final
+
+private abbrev Tight (d : ℕ) [NeZero d] : Prop :=
+  Module.finrank ℚ⟮jq⟯ (IntermediateField.adjoin ℚ⟮jq⟯ ({jqN d} : Set (LaurentSeries ℚ))) =
+    dedekindPsi d
+
+private abbrev Gen (d : ℕ) [NeZero d] : Prop := modularFunctionField d = modularFunctionFieldFull d
+
+private abbrev Hall (N : ℕ) : Prop := ∀ d : ℕ, d ∣ N → ∀ [NeZero d], Tight d ∧ Gen d
+
+private theorem jqN_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) : jqN n = jqN m := by
+  subst h; rfl
+
+private theorem full_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) :
+    modularFunctionFieldFull n = modularFunctionFieldFull m := by
+  subst h; rfl
+
+private theorem mff_congr {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) :
+    modularFunctionField n = modularFunctionField m := by
+  subst h; rfl
+
+private theorem qExpand_congr' {R : Type*} [CommRing R] {n m : ℕ} [NeZero n] [NeZero m]
+    (h : n = m) (x : LaurentSeries R) : qExpand R n x = qExpand R m x := by
+  subst h
+  rfl
+
+private theorem dedekindPsi_prime' (p : ℕ) (hp : p.Prime) : dedekindPsi p = p + 1 := by
+  have h := ModularCurve.dedekindPsi_prime_pow p 1 hp one_ne_zero
+  rwa [pow_one, Nat.sub_self, pow_zero] at h
+
+private theorem dedekindPsi_mul_prime_not_dvd {m p : ℕ} (hp : p.Prime) (hpm : ¬ p ∣ m) :
+    dedekindPsi (m * p) = dedekindPsi m * (p + 1) := by
+  have hco : Nat.Coprime m p := ((Nat.Prime.coprime_iff_not_dvd hp).mpr hpm).symm
+  rw [ModularCurve.dedekindPsi_mul_of_coprime m p hco, dedekindPsi_prime' p hp]
+
+private theorem dedekindPsi_mul_prime_dvd {m p : ℕ} (hm : m ≠ 0) (hp : p.Prime)
+    (hpm : p ∣ m) : dedekindPsi (m * p) = dedekindPsi m * p := by
+  obtain ⟨k, u, hpu, hmu⟩ := Nat.exists_eq_pow_mul_and_not_dvd hm p hp.ne_one
+  obtain ⟨k', rfl⟩ : ∃ k', k = k' + 1 := by
+    rcases k with - | k'
+    · exfalso
+      rw [hmu, pow_zero, one_mul] at hpm
+      exact hpu hpm
+    · exact ⟨k', rfl⟩
+  subst hmu
+  have hcou : ∀ j : ℕ, j ≠ 0 → Nat.Coprime (p ^ j) u :=
+    fun j _ => Nat.Coprime.pow_left j ((Nat.Prime.coprime_iff_not_dvd hp).mpr hpu)
+  have h1 : p ^ (k' + 1) * u * p = p ^ (k' + 2) * u := by ring
+  rw [h1, ModularCurve.dedekindPsi_mul_of_coprime _ u (hcou _ (Nat.succ_ne_zero _)),
+    ModularCurve.dedekindPsi_mul_of_coprime _ u (hcou _ (Nat.succ_ne_zero _)),
+    ModularCurve.dedekindPsi_prime_pow p (k' + 2) hp (Nat.succ_ne_zero _),
+    ModularCurve.dedekindPsi_prime_pow p (k' + 1) hp (Nat.succ_ne_zero _)]
+  have h2 : k' + 2 - 1 = k' + 1 := rfl
+  have h3 : k' + 1 - 1 = k' := rfl
+  rw [h2, h3]
+  ring
+
+private theorem tight_one : Tight 1 := by
+  unfold Tight
+  have h1 : jqN 1 = jq := by rw [jqN, qExpand_one_apply]
+  rw [h1, ModularCurve.dedekindPsi_one]
+  have h2 : IntermediateField.adjoin ℚ⟮jq⟯ ({jq} : Set (LaurentSeries ℚ))
+      = (⊥ : IntermediateField ℚ⟮jq⟯ (LaurentSeries ℚ)) := by
+    rw [IntermediateField.adjoin_simple_eq_bot_iff, IntermediateField.mem_bot]
+    exact ⟨jGen, rfl⟩
+  rw [h2]
+  exact IntermediateField.finrank_bot
+
+private theorem gen_one : Gen 1 := by
+  unfold Gen
+  refine le_antisymm (modularFunctionField_le_full 1) ?_
+  rw [modularFunctionFieldFull, IntermediateField.adjoin_le_iff]
+  rintro x ⟨d, hne, hdvd, rfl⟩
+  have := hne
+  have hd1 : d = 1 := Nat.dvd_one.mp hdvd
+  subst hd1
+  rw [qExpand_one_apply]
+  exact jq_mem 1
+
+private theorem relfinrank_full_of (N : ℕ) [NeZero N] (ht : Tight N) (hg : Gen N) :
+    IntermediateField.relfinrank ℚ⟮jq⟯ (modularFunctionFieldFull N) = dedekindPsi N := by
+  unfold Gen at hg
+  unfold Tight at ht
+  rw [← hg, ModularCurve.relfinrank_modularFunctionField N, ht]
+
+private theorem F0_le_full (N : ℕ) [NeZero N] : ℚ⟮jq⟯ ≤ modularFunctionFieldFull N := by
+  rw [IntermediateField.adjoin_le_iff, Set.singleton_subset_iff]
+  have h := jqd_mem_full N (one_dvd N)
+  rw [qExpand_one_apply] at h
+  exact h
+
+private theorem full_le_adjoin_chain (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (hpM : ¬ p ∣ M) : ∀ a : ℕ,
+    modularFunctionFieldFull (M * p ^ a) ≤ IntermediateField.adjoin ℚ
+      ((modularFunctionFieldFull M : Set (LaurentSeries ℚ))
+        ∪ {x : LaurentSeries ℚ | ∃ i : ℕ, i ≤ a ∧ x = jqN (p ^ i)}) := by
+  intro a
+  induction a with
+  | zero =>
+      rw [full_congr (show M * p ^ 0 = M by rw [pow_zero, mul_one])]
+      exact fun x hx => IntermediateField.subset_adjoin ℚ _ (Set.mem_union_left _ hx)
+  | succ k ih =>
+      rw [ModularCurve.full_eq_adjoin_full_div_prime M p k hpM, IntermediateField.adjoin_le_iff,
+        Set.insert_subset_iff]
+      refine ⟨IntermediateField.subset_adjoin ℚ _ (Set.mem_union_right _
+        (show jqN (p ^ (k + 1)) ∈ {x : LaurentSeries ℚ | ∃ i : ℕ, i ≤ k + 1 ∧ x = jqN (p ^ i)} from
+          ⟨k + 1, le_rfl, rfl⟩)), ?_⟩
+      intro x hx
+      have hx' := ih hx
+      refine IntermediateField.adjoin.mono ℚ _ _ (Set.union_subset_union le_rfl ?_) hx'
+      intro y hy
+      obtain ⟨i, hi, hy⟩ := hy
+      exact ⟨i, Nat.le_succ_of_le hi, hy⟩
+
+private theorem jqN_pow_not_mem_full (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)]
+    (hpM : ¬ p ∣ M) (hallM : Hall M) (a : ℕ) :
+    jqN (p ^ (a + 1)) ∉ modularFunctionFieldFull (M * p ^ a) := by
+  have h0 : jqN p ∉ modularFunctionFieldFull M :=
+    ModularCurve.jqN_prime_not_mem_full M p hpM (fun d hd _ => hallM d hd)
+  rcases a with - | k
+  · rw [jqN_congr (show p ^ (0 + 1) = p by rw [zero_add, pow_one]),
+      full_congr (show M * p ^ 0 = M by rw [pow_zero, mul_one])]
+    exact h0
+  · intro hmem
+    have h1 := ModularCurve.jqN_pow_not_mem_adjoin_full M p k h0
+    exact h1 (full_le_adjoin_chain M p hpM (k + 1) hmem)
+
+section Shapes
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem root_shape (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) M) (hallM : Hall M) (y : LaurentSeries K)
+    (hy : Polynomial.eval y ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M *
+      p))).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))) = 0) :
+    ∃ a : ℕ, ∃ _ : NeZero a, a ∣ M ∧ ∃ b : ℕ, b < M / a ∧ y = TS K (p * (a * a)) (ζ ^ (b * a)) := by
+  have hid := ModularCurve.minpoly_jqN_map_eq_prod_slots (K := K) M ζ hζ (fun d hd _ => hallM d hd)
+  have hcomp : (qExpand K p).comp (((coeffEmb K).comp (qExpand ℚ M)).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))
+      = ((coeffEmb K).comp (qExpand ℚ (M * p))).comp (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)) := by
+    refine RingHom.ext fun z => ?_
+    simp only [RingHom.comp_apply]
+    rw [coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand]
+    exact qExpand_congr' (mul_comm p M) _
+  rw [← hcomp, ← Polynomial.map_map, hid, Polynomial.eval_map, Polynomial.eval₂_finsetProd] at hy
+  obtain ⟨a, ha, hy⟩ := Finset.prod_eq_zero_iff.mp hy
+  rw [Polynomial.eval₂_finsetProd] at hy
+  obtain ⟨b, hb, hy⟩ := Finset.prod_eq_zero_iff.mp hy
+  rw [Polynomial.eval₂_sub, Polynomial.eval₂_X, Polynomial.eval₂_C, sub_eq_zero] at hy
+  have ha0 : a ≠ 0 := Nat.ne_of_gt (Nat.pos_of_mem_divisors ha)
+  rw [dite_eq_right ha0] at hy
+  have : NeZero a := ⟨ha0⟩
+  refine ⟨a, ⟨ha0⟩, Nat.dvd_of_mem_divisors ha, b, (Finset.mem_range.mp (Finset.mem_filter.mp
+    hb).1), ?_⟩
+  rw [hy]
+  rw [← TS_eq_coeffEmb, qExpand_TS]
+
+private theorem htw_of (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) M) (hallM : Hall M) (y : LaurentSeries K)
+    (hy : Polynomial.eval y ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M *
+      p))).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))) = 0)
+    (w : Kˣ) (hw : y = qExpand K (M * p * M) (qTwist w (coeffEmb K jq))) : w = 1 := by
+  obtain ⟨a, _, haM, b, hb, rfl⟩ := root_shape M p ζ hζ hallM y hy
+  rw [← TS_eq_coeffEmb] at hw
+  obtain ⟨he, hu⟩ := TS_injective hw
+  have haM' : a = M := by
+    have h2 : a * a = M * M := by
+      have hp0 : 0 < p := hp.out.pos
+      have : p * (a * a) = p * (M * M) := by rw [he]; ring
+      exact Nat.eq_of_mul_eq_mul_left hp0 this
+    exact Nat.mul_self_inj.mp h2
+  subst haM'
+  have hb0 : b = 0 := by
+    rw [Nat.div_self (Nat.pos_of_ne_zero (NeZero.ne a))] at hb
+    omega
+  subst hb0
+  rw [zero_mul, pow_zero] at hu
+  exact hu.symm
+
+private theorem hsp_of (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) M) (hallM : Hall M) (y : LaurentSeries K)
+    (hy : Polynomial.eval y ((minpoly ℚ⟮jq⟯ (jqN M)).map (((coeffEmb K).comp (qExpand ℚ (M *
+      p))).comp
+      (algebraMap ℚ⟮jq⟯ (LaurentSeries ℚ)))) = 0) :
+    y ≠ coeffEmb K (qExpand ℚ (M * p) (jqN (M * p * p))) := by
+  obtain ⟨a, _, haM, b, _, rfl⟩ := root_shape M p ζ hζ hallM y hy
+  rw [iota_jqN]
+  intro h
+  obtain ⟨he, _⟩ := TS_injective h
+  have hp2 : 2 ≤ p := hp.out.two_le
+  have hM : 0 < M := Nat.pos_of_ne_zero (NeZero.ne M)
+  have ha : a ≤ M := Nat.le_of_dvd hM haM
+  have h1 : a * a = (M * p) * (M * p) := by
+    have : p * (a * a) = p * ((M * p) * (M * p)) := by rw [he]; ring
+    exact Nat.eq_of_mul_eq_mul_left hp.out.pos this
+  have h2 : a = M * p := Nat.mul_self_inj.mp h1
+  have : M * p ≤ M := h2 ▸ ha
+  have : M * 2 ≤ M * p := Nat.mul_le_mul_left M hp2
+  omega
+
+end Shapes
+
+private theorem hall_all : ∀ N : ℕ, N ≠ 0 → Hall N := by
+  intro N
+  induction N using Nat.strong_induction_on with
+  | _ N ih =>
+  intro hN d hdN hd
+  by_cases hdlt : d < N
+  · exact ih d hdlt (NeZero.ne d) d dvd_rfl
+  have hdN' : d = N := le_antisymm (Nat.le_of_dvd (Nat.pos_of_ne_zero hN) hdN) (not_lt.mp hdlt)
+  subst hdN'
+  have hprop : ∀ m : ℕ, m ∣ d → m < d → Hall m := fun m _ hlt => ih m hlt (by
+    rintro rfl; exact absurd hlt (by have := Nat.pos_of_ne_zero hN; omega))
+  by_cases h1 : d = 1
+  · subst h1; exact ⟨tight_one, gen_one⟩
+  have hgen : Gen d := by
+    unfold Gen
+    refine ModularCurve.modularFunctionField_eq_full_of d ?_ ?_
+    · intro M _ p hp hMp
+      have : Fact (Nat.Prime p) := ⟨hp⟩
+      have hMlt : M < d := by
+        rw [← hMp]; exact lt_mul_of_one_lt_right (Nat.pos_of_ne_zero (NeZero.ne M)) hp.one_lt
+      have hallM : Hall M := hprop M ⟨p, hMp.symm⟩ hMlt
+      have hmem :=
+        ModularCurve.jqN_div_mem_modularFunctionField M p (K := CyclotomicField (M * p) ℚ)
+        (cycUnit (M * p)) (cycUnit_spec (M * p))
+        (fun y hy w hw => htw_of M p (cycUnit (M * p) ^ (M * p / M))
+          (isPrimitiveRoot_pow_div (cycUnit_spec (M * p)) ⟨p, rfl⟩) hallM y hy w hw)
+        (fun y hy => hsp_of M p (cycUnit (M * p) ^ (M * p / M))
+          (isPrimitiveRoot_pow_div (cycUnit_spec (M * p)) ⟨p, rfl⟩) hallM y hy)
+      rw [mff_congr hMp] at hmem
+      exact hmem
+    · intro M _ p hp hMp
+      have hMlt : M < d := by
+        rw [← hMp]; exact lt_mul_of_one_lt_right (Nat.pos_of_ne_zero (NeZero.ne M)) hp.one_lt
+      exact (hprop M ⟨p, hMp.symm⟩ hMlt M dvd_rfl).2
+  refine ⟨?_, hgen⟩
+  unfold Tight
+  set p := d.minFac with hpdef
+  have hp : p.Prime := Nat.minFac_prime h1
+  have : Fact (Nat.Prime p) := ⟨hp⟩
+  obtain ⟨k, M, hpM, hdM⟩ := Nat.exists_eq_pow_mul_and_not_dvd hN p hp.ne_one
+  have hM0 : M ≠ 0 := by rintro rfl; rw [mul_zero] at hdM; exact hN hdM
+  have : NeZero M := ⟨hM0⟩
+  obtain ⟨a, rfl⟩ : ∃ a, k = a + 1 := by
+    rcases k with - | a
+    · exfalso
+      have : p ∣ d := Nat.minFac_dvd d
+      rw [hdM, pow_zero, one_mul] at this
+      exact hpM this
+    · exact ⟨a, rfl⟩
+  have hdM' : d = M * p ^ (a + 1) := by rw [hdM, mul_comm]
+  have hlow_dvd : M * p ^ a ∣ d := ⟨p, by rw [hdM', pow_succ, mul_assoc]⟩
+  have hlow_lt : M * p ^ a < d := by
+    rw [hdM', pow_succ, ← mul_assoc]
+    exact lt_mul_of_one_lt_right (Nat.pos_of_ne_zero (mul_ne_zero hM0 (pow_ne_zero _ hp.ne_zero)))
+      hp.one_lt
+  have hall_low : Hall (M * p ^ a) := hprop _ hlow_dvd hlow_lt
+  have hallM : Hall M := fun e he _ => hall_low e (he.trans ⟨p ^ a, rfl⟩)
+  have hlowdeg : IntermediateField.relfinrank ℚ⟮jq⟯ (modularFunctionFieldFull (M * p ^ a))
+      = dedekindPsi (M * p ^ a) := by
+    have h := hall_low (M * p ^ a) dvd_rfl
+    exact relfinrank_full_of _ h.1 h.2
+  have hstep := ModularCurve.relfinrank_full_eq_mul M p a
+    (ModularCurve.full_eq_adjoin_full_div_prime M p a hpM) (jqN_pow_not_mem_full M p hpM hallM a)
+  have htower := IntermediateField.relfinrank_mul_relfinrank (F0_le_full (M * p ^ a))
+    (full_degeneracy_le (N := M * p ^ a) (M := M * p ^ (a + 1)) ⟨p, by rw [pow_succ, mul_assoc]⟩)
+  rw [← ModularCurve.relfinrank_modularFunctionField d]
+  unfold Gen at hgen
+  rw [hgen, full_congr hdM', ← htower, hlowdeg, hstep]
+  have hpsi : dedekindPsi d = dedekindPsi (M * p ^ a) * (if a = 0 then p + 1 else p) := by
+    rw [hdM']
+    split_ifs with ha
+    · subst ha
+      rw [pow_zero, mul_one, zero_add, pow_one]
+      exact dedekindPsi_mul_prime_not_dvd hp hpM
+    · have h2 : M * p ^ (a + 1) = M * p ^ a * p := by rw [pow_succ, mul_assoc]
+      rw [h2]
+      refine dedekindPsi_mul_prime_dvd (mul_ne_zero hM0 (pow_ne_zero _ hp.ne_zero)) hp ⟨M * p ^ (a -
+        1), ?_⟩
+      obtain ⟨a', rfl⟩ := Nat.exists_eq_succ_of_ne_zero ha
+      rw [Nat.succ_sub_one, pow_succ]; ring
+  rw [hpsi]
+
+end Final
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi dedekindPsi_one evalAtJ_X \
+  ModularPolynomialData FunctionFieldGeneration modularFunctionField jq_mem jGen \
+  modularFunctionFieldFull jqd_mem_full modularFunctionField_le_full full_degeneracy_le coeffEmb \
+  coeffEmb_coeff qTwist qTwist_coeff qTwist_one_apply qTwist_qTwist qTwist_qExpand PhiIrreducible \
+  coeffMap_qExpand PhiGen.splits_prime_at_slot minpoly_jqN_map_eq_prod_slots \
+  jqN_prime_not_mem_full jqN_pow_not_mem_adjoin_full full_eq_adjoin_full_div_prime \
+  relfinrank_full_eq_mul jqN_div_mem_modularFunctionField modularFunctionField_eq_full_of \
+  relfinrank_modularFunctionField dedekindPsi_mul_of_coprime dedekindPsi_prime_pow \
+  exists_phiIrreducible_of_finrank_eq functionFieldGeneration_iff_full_eq"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi (N : ℕ) [NeZero N] :
+    Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+        ({jqN N} : Set (LaurentSeries ℚ))) = dedekindPsi N :=
+  (ModularCurve.W1.hall_all N (NeZero.ne N) N dvd_rfl).1
+
+p2m_open_scoped "ModularCurve" in
+open ModularCurve.W1 in
+private theorem ModularCurve.modularFunctionField_eq_full (N : ℕ) [NeZero N] :
+    modularFunctionField N = modularFunctionFieldFull N :=
+  (ModularCurve.W1.hall_all N (NeZero.ne N) N dvd_rfl).2
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.functionFieldGeneration (N : ℕ) [NeZero N] :
+    FunctionFieldGeneration N :=
+  (ModularCurve.functionFieldGeneration_iff_full_eq N).mpr
+    (ModularCurve.modularFunctionField_eq_full N).symm
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.exists_phiIrreducible (N : ℕ) [NeZero N] :
+    ∃ data : ModularPolynomialData N, PhiIrreducible data :=
+  ModularCurve.exists_phiIrreducible_of_finrank_eq N (ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi
+    N)
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.relfinrank_full_eq_dedekindPsi (N : ℕ) [NeZero N] :
+    IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (modularFunctionFieldFull N) = dedekindPsi N := by
+  rw [← ModularCurve.modularFunctionField_eq_full N, ModularCurve.relfinrank_modularFunctionField N]
+  exact ModularCurve.finrank_adjoin_jqN_eq_dedekindPsi N
+
+end
+
+p2m_open "ModularCurve~coeffEmb_qExpand\
+  " in
+open _root_.P2MW.S_ModularCurve_relfinrank_full_eq_dedekindPsi.ModularCurve in
+theorem solution (N : ℕ) [NeZero N] :
+    IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (modularFunctionFieldFull N) = dedekindPsi N :=
+  ModularCurve.relfinrank_full_eq_dedekindPsi N
+
+end S_ModularCurve_relfinrank_full_eq_dedekindPsi
+end P2MW
+export P2MW.S_ModularCurve_relfinrank_full_eq_dedekindPsi (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.relfinrank_full_eq_dedekindPsi (N : ℕ) [NeZero N] :
+    IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (modularFunctionFieldFull N) = dedekindPsi N :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_relfinrank_full_eq_mul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_relfinrank_full_eq_mul.lean
new file mode 100644
index 0000000000..78d4b0a487
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_relfinrank_full_eq_mul.lean
@@ -0,0 +1,157 @@
+/-
+Based on Prove2Me node ModularCurve.relfinrank_full_eq_mul
+(5f015f9c-5fab-5a82-a6d5-e91a75cefa54) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ec637fde-3fa5-5d1c-8df4-999b6d262557
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import Mathlib.FieldTheory.Relrank
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqN_prime_of_not_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqN_pow_succ_of_not_mem
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Relative degree of one prime-power step in the divisor-expansion tower
+
+Theorem statement: `ModularCurve.relfinrank_full_eq_mul` (`5f015f9c-5fab-5a82-a6d5-e91a75cefa54`),
+by Claude, 2026-09-05.
+
+Proof: submission `ec637fde-3fa5-5d1c-8df4-999b6d262557`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a positive integer $M$, a prime $p$ and a natural number $a$. For a positive integer $N$ write
+$j_N :=$ `jqN N` for the image of the $q$-expansion `jq` of the modular invariant under the ring
+endomorphism `qExpand ℚ N` of $\mathbb{Q}((q))$ that multiplies Hahn-series exponents by $N$
+(substitution $q \mapsto q^N$), and let `modularFunctionFieldFull N` be the intermediate field of
+$\mathbb{Q}((q))/\mathbb{Q}$ obtained by adjoining to $\mathbb{Q}$ the set of all $j_d$ with $d$ a
+positive divisor of $N$. Assume two things: first, that `modularFunctionFieldFull (M * p ^ (a + 1))`
+coincides with the field generated over $\mathbb{Q}$ by $j_{p^{a+1}}$ together with all elements of
+`modularFunctionFieldFull (M * p ^ a)`; second, that $j_{p^{a+1}}$ does not lie in
+`modularFunctionFieldFull (M * p ^ a)`. Then the relative degree (`IntermediateField.relfinrank`) of
+`modularFunctionFieldFull (M * p ^ (a + 1))` over `modularFunctionFieldFull (M * p ^ a)` equals $p +
+1$ if $a = 0$ and $p$ otherwise.
+
+This is one step of the tower computation of the degree of the modular equation: it reproduces the
+recursion $\psi(Mp^{a+1}) = \psi(Mp^{a}) \cdot (p+1)$ for $a = 0$ and $\psi(Mp^{a+1}) = \psi(Mp^{a})
+\cdot p$ for $a \ge 1$ satisfied by the Dedekind $\psi$-function. It feeds the identification of the
+degree of `modularFunctionFieldFull N` over $\mathbb{Q}(j)$ with $\psi(N)$ and the attendant
+irreducibility of the modular polynomial, and is cited in the development of the $q$-expansion model
+of the function field of $X_0(N)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_relfinrank_full_eq_mul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_relfinrank_full_eq_mul
+
+noncomputable section
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_relfinrank_full_eq_mul.ModularCurve"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand_one_apply jq jqN modularFunctionFieldFull jqd_mem_full \
+  finrank_adjoin_jqN_prime_of_not_mem finrank_adjoin_jqN_pow_succ_of_not_mem"
+namespace W1
+p2m_open "ModularCurve"
+
+private theorem jqN_congr' {n m : ℕ} [NeZero n] [NeZero m] (h : n = m) : jqN n = jqN m := by
+  subst h; rfl
+
+private theorem w1_relfinrank_insert (E : IntermediateField ℚ (LaurentSeries ℚ))
+    (α : LaurentSeries ℚ) :
+    IntermediateField.relfinrank E
+      (IntermediateField.adjoin ℚ (insert α (E : Set (LaurentSeries ℚ))))
+      = Module.finrank E
+          (IntermediateField.adjoin E ({α} : Set (LaurentSeries ℚ))) := by
+  have h : E ≤ IntermediateField.adjoin ℚ (insert α (E : Set (LaurentSeries ℚ))) :=
+    fun x hx => IntermediateField.subset_adjoin ℚ _ (Set.mem_insert_of_mem _ hx)
+  have hEq : IntermediateField.adjoin E (insert α (E : Set (LaurentSeries ℚ)))
+      = IntermediateField.adjoin E ({α} : Set (LaurentSeries ℚ)) := by
+    refine le_antisymm ?_ ?_
+    · rw [IntermediateField.adjoin_le_iff]
+      rintro x (rfl | hxE)
+      · exact IntermediateField.subset_adjoin _ _ rfl
+      · exact (IntermediateField.adjoin E _).algebraMap_mem (⟨x, hxE⟩ : E)
+    · exact IntermediateField.adjoin.mono _ _ _
+        (Set.singleton_subset_iff.mpr (Set.mem_insert α _))
+  rw [IntermediateField.relfinrank_eq_finrank_of_le h,
+    IntermediateField.extendScalars_adjoin h, hEq]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand_one_apply jq jqN modularFunctionFieldFull jqd_mem_full \
+  finrank_adjoin_jqN_prime_of_not_mem finrank_adjoin_jqN_pow_succ_of_not_mem"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.relfinrank_full_eq_mul (M : ℕ) [NeZero M] (p : ℕ)
+    [hp : Fact (Nat.Prime p)] (a : ℕ)
+    (hup : modularFunctionFieldFull (M * p ^ (a + 1)) =
+      IntermediateField.adjoin ℚ
+        (insert (jqN (p ^ (a + 1))) (modularFunctionFieldFull (M * p ^ a) :
+          Set (LaurentSeries ℚ))))
+    (hnm : jqN (p ^ (a + 1)) ∉ modularFunctionFieldFull (M * p ^ a)) :
+    IntermediateField.relfinrank (modularFunctionFieldFull (M * p ^ a))
+      (modularFunctionFieldFull (M * p ^ (a + 1))) = if a = 0 then p + 1 else p := by
+  rw [hup, ModularCurve.W1.w1_relfinrank_insert]
+  rcases Nat.eq_zero_or_pos a with rfl | ha
+  · rw [ite_eq_left rfl]
+    have e1 : p ^ (0 + 1) = p := by rw [zero_add, pow_one]
+    have hj : jq ∈ modularFunctionFieldFull (M * p ^ 0) := by
+      have h1 := jqd_mem_full (M * p ^ 0) (one_dvd _)
+      rwa [qExpand_one_apply] at h1
+    rw [ModularCurve.W1.jqN_congr' e1]
+    rw [ModularCurve.W1.jqN_congr' e1] at hnm
+    exact ModularCurve.finrank_adjoin_jqN_prime_of_not_mem _ hj p hnm
+  · obtain ⟨k, rfl⟩ := Nat.exists_eq_succ_of_ne_zero ha.ne'
+    rw [ite_eq_right (Nat.succ_ne_zero k)]
+    refine ModularCurve.finrank_adjoin_jqN_pow_succ_of_not_mem _ p k ?_ ?_ hnm
+    · exact jqd_mem_full _ (Dvd.dvd.mul_left (pow_dvd_pow p (Nat.le_succ k)) M)
+    · exact jqd_mem_full _ (dvd_mul_left _ _)
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_relfinrank_full_eq_mul.ModularCurve in
+theorem solution (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (a : ℕ) (hup :
+  modularFunctionFieldFull (M * p ^ (a + 1)) = IntermediateField.adjoin ℚ (insert (jqN (p ^ (a +
+  1))) (modularFunctionFieldFull (M * p ^ a) : Set (LaurentSeries ℚ)))) (hnm : jqN (p ^ (a + 1)) ∉
+  modularFunctionFieldFull (M * p ^ a)) :
+    IntermediateField.relfinrank (modularFunctionFieldFull (M * p ^ a)) (modularFunctionFieldFull (M
+      * p ^ (a + 1))) = if a = 0 then p + 1 else p :=
+  ModularCurve.relfinrank_full_eq_mul M p a hup hnm
+
+end S_ModularCurve_relfinrank_full_eq_mul
+end P2MW
+export P2MW.S_ModularCurve_relfinrank_full_eq_mul (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.relfinrank_full_eq_mul (M : ℕ) [NeZero M] (p : ℕ) [hp : Fact (Nat.Prime p)] (a
+  : ℕ) (hup : modularFunctionFieldFull (M * p ^ (a + 1)) = IntermediateField.adjoin ℚ (insert (jqN
+  (p ^ (a + 1))) (modularFunctionFieldFull (M * p ^ a) : Set (LaurentSeries ℚ)))) (hnm : jqN (p ^ (a
+  + 1)) ∉ modularFunctionFieldFull (M * p ^ a)) :
+    IntermediateField.relfinrank (modularFunctionFieldFull (M * p ^ a)) (modularFunctionFieldFull (M
+      * p ^ (a + 1))) = if a = 0 then p + 1 else p :=
+  solution M p a hup hnm
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_relfinrank_full_of_squarefree.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_relfinrank_full_of_squarefree.lean
new file mode 100644
index 0000000000..c4094142e4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_relfinrank_full_of_squarefree.lean
@@ -0,0 +1,582 @@
+/-
+Based on Prove2Me node ModularCurve.relfinrank_full_of_squarefree
+(5ae48c95-890d-56e3-89e4-e242203986a2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c27f5e6f-25a2-5e27-9899-5b33fb557ea4
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import Mathlib.FieldTheory.Relrank
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffMap_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_splits_prime_at_slot
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.NumberTheory.Cyclotomic.Basic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_full_eq_adjoin_primes
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqN_prime_of_not_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqN_prime_not_mem_adjoin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_of_squarefree
+import LeanPool.FLTEichlerShimura.Definitions.Defs_modularPolynomial_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Relative degree ψ(N) at squarefree level
+
+Theorem statement: `ModularCurve.relfinrank_full_of_squarefree`
+(`5ae48c95-890d-56e3-89e4-e242203986a2`), by Claude, 2026-09-05.
+
+Proof: submission `c27f5e6f-25a2-5e27-9899-5b33fb557ea4`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number which is squarefree. Work inside the Laurent series field
+$\mathrm{LaurentSeries}\ \mathbb{Q}$, and let $jq$ denote the Laurent series $q^{-1}$ times the
+image of the integral power series $jNum$ under $\mathbb{Z}\to\mathbb{Q}$, that is the $q$-expansion
+of the modular invariant $j$ with rational coefficients. Let $\mathrm{modularFunctionFieldFull}\ N$
+be the intermediate field of $\mathbb{Q}\subseteq\mathrm{LaurentSeries}\ \mathbb{Q}$ generated over
+$\mathbb{Q}$ by the set of all expansions $\mathrm{qExpand}\ \mathbb{Q}\ d\ jq$, for $d$ a nonzero
+divisor of $N$, and let $\mathbb{Q}(jq)$ be the intermediate field generated by $jq$ alone. The
+assertion is that the relative degree, in the sense of `IntermediateField.relfinrank`, of
+$\mathrm{modularFunctionFieldFull}\ N$ over $\mathbb{Q}(jq)$ — the degree of the former over the
+intersection of the two, which is the degree over $\mathbb{Q}(jq)$ since $d=1$ exhibits $jq$ in the
+larger field — equals $\mathrm{dedekindPsi}\ N=\sum_{d\mid N,\ d\ \text{squarefree}} N/d$, which for
+squarefree $N$ is $\prod_{p\mid N}(p+1)=\psi(N)$.
+
+This is the degree of the modular equation of level $N$ in its formal $q$-expansion form: for
+squarefree $N$ the field generated by the expansions $j(q^{d})$, $d\mid N$, has degree $\psi(N)$
+over $\mathbb{Q}(j(q))$, the classical statement that $\Phi_N(X,j)$ is irreducible of degree
+$\psi(N)$ over $\mathbb{Q}(j)$. It is used by
+[`ModularCurve.finrank_adjoin_jqN_eq_of_squarefree`]
+(thm.html#ModularCurve.finrank_adjoin_jqN_eq_of_squarefree)
+and
+[`ModularCurve.functionFieldGeneration_of_squarefree`]
+(thm.html#ModularCurve.functionFieldGeneration_of_squarefree)
+to identify the function field of $X_0(N)$ with $\mathbb{Q}(j,j_N)$ at squarefree level.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_relfinrank_full_of_squarefree.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open _root_.ModularCurve.W1
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_relfinrank_full_of_squarefree
+
+noncomputable section
+
+p2m_open "ModularCurve~coeffEmb_qExpand \
+  P2MW.S_ModularCurve_relfinrank_full_of_squarefree.ModularCurve ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionFieldFull coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  full_eq_adjoin_primes finrank_adjoin_jqN_prime_of_not_mem jqN_prime_not_mem_adjoin \
+  dedekindPsi_of_squarefree"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+
+
+
+
+
+
+
+
+
+
+theorem coeffEmb_qExpand (n : ℕ) [NeZero n] (x : LaurentSeries ℚ) :
+    coeffEmb K (qExpand ℚ n x) = qExpand K n (coeffEmb K x) :=
+  coeffMap_qExpand (algebraMap ℚ K) n x
+
+theorem iota_jqN (N d : ℕ) [NeZero N] [NeZero d] :
+    coeffEmb K (qExpand ℚ N (jqN d)) = TS K (N * d) 1 := by
+  rw [jqN, coeffEmb_qExpand, coeffEmb_qExpand, qExpand_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem iota_jq (N : ℕ) [NeZero N] : coeffEmb K (qExpand ℚ N jq) = TS K N 1 := by
+  rw [coeffEmb_qExpand, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_zero_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    conj p ζ (0 : Fin (p + 1)) = TS K (p * p) 1 := by
+  rw [conj_zero, TS_eq_coeffEmb, qTwist_one_apply]
+
+theorem conj_succ_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) (b : Fin p) :
+    conj p ζ b.succ = TS K 1 (ζ ^ (b : ℕ)) := by
+  rw [conj_succ, TS_eq_coeffEmb, qExpand_one_apply]
+
+theorem qTwist_iota_of_pow_eq_one (N : ℕ) [NeZero N] (v : Kˣ) (hv : v ^ N = 1) (x : LaurentSeries ℚ)
+    :
+    qTwist v (coeffEmb K (qExpand ℚ N x)) = coeffEmb K (qExpand ℚ N x) := by
+  rw [coeffEmb_qExpand, qTwist_qExpand]
+  have : v ^ (N : ℤ) = 1 := by exact_mod_cast hv
+  rw [this, qTwist_one_apply]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionFieldFull coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  full_eq_adjoin_primes finrank_adjoin_jqN_prime_of_not_mem jqN_prime_not_mem_adjoin \
+  dedekindPsi_of_squarefree"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+def qTwistEquiv (u : Kˣ) : LaurentSeries K ≃+* LaurentSeries K where
+  toFun := qTwist u
+  invFun := qTwist u⁻¹
+  left_inv := fun f => by
+    change qTwist u⁻¹ (qTwist u f) = f
+    rw [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply]
+  right_inv := fun f => by
+    change qTwist u (qTwist u⁻¹ f) = f
+    rw [qTwist_qTwist, mul_inv_cancel, qTwist_one_apply]
+  map_mul' := map_mul _
+  map_add' := map_add _
+
+omit [Algebra ℚ K] in
+@[scoped simp] theorem qTwistEquiv_apply (u : Kˣ) (f : LaurentSeries K) :
+    qTwistEquiv u f = qTwist u f := rfl
+
+omit [Algebra ℚ K] in
+theorem coe_qTwistEquiv (u : Kˣ) :
+    ((qTwistEquiv u : LaurentSeries K ≃+* LaurentSeries K) : LaurentSeries K →+* LaurentSeries K) =
+      qTwist u :=
+  RingHom.ext fun _ => rfl
+
+omit [Algebra ℚ K] in
+theorem qTwist_TS_one_cycle (ζ : Kˣ) {p : ℕ} (hζp : ζ ^ p = 1) (b : ℕ) :
+    qTwist ζ (TS K 1 (ζ ^ b)) = TS K 1 (ζ ^ ((b + 1) % p)) := by
+  rw [qTwist_TS]
+  congr 1
+  have : ζ ^ ((1 : ℕ) : ℤ) * ζ ^ b = ζ ^ (b + 1) := by rw [zpow_natCast, pow_one, pow_succ']
+  rw [this]
+  conv_lhs => rw [← Nat.mod_add_div (b + 1) p, pow_add, pow_mul, hζp, one_pow, mul_one]
+
+theorem phiProd_conj_eq (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    phiProd p (conj p ζ) = (Polynomial.X - Polynomial.C (TS K (p * p) 1)) *
+      ∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) := by
+  rw [phiProd, Fin.prod_univ_succ, conj_zero_eq]
+  congr 1
+  rw [← Fin.prod_univ_eq_prod_range (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) p]
+  refine Finset.prod_congr rfl fun b _ => ?_
+  rw [conj_succ_eq]
+
+theorem roots_phiProd_conj (p : ℕ) [Fact p.Prime] (ζ : Kˣ) :
+    (phiProd p (conj p ζ)).roots = TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^
+      b)) := by
+  classical
+  rw [phiProd_conj_eq]
+  have h1 : (Polynomial.X - Polynomial.C (TS K (p * p) 1) : Polynomial (LaurentSeries K)) ≠ 0 :=
+    Polynomial.X_sub_C_ne_zero _
+  have h2 : (∏ b ∈ Finset.range p, (Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b)))) ≠ 0 :=
+    Finset.prod_ne_zero_iff.mpr fun b _ => Polynomial.X_sub_C_ne_zero _
+  rw [Polynomial.roots_mul (mul_ne_zero h1 h2), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod,
+    Finset.range_val]
+  have hm : (Multiset.map (fun b => Polynomial.X - Polynomial.C (TS K 1 (ζ ^ b))) (Multiset.range
+    p)) =
+      ((Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).map (fun a => Polynomial.X - Polynomial.C
+        a) := by
+    rw [Multiset.map_map]; rfl
+  rw [hm, Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+omit [Algebra ℚ K] in
+theorem roots_phiProd_conj_nodup (p : ℕ) [hp : Fact p.Prime] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) p) :
+    (TS K (p * p) 1 ::ₘ (Multiset.range p).map (fun b => TS K 1 (ζ ^ b))).Nodup := by
+  refine Multiset.nodup_cons.mpr ⟨?_, ?_⟩
+  · intro hmem
+    obtain ⟨b, -, hb⟩ := Multiset.mem_map.mp hmem
+    have := (TS_injective hb).1
+    have h2 := hp.out.two_le
+    nlinarith
+  · refine (Multiset.nodup_range p).map_on fun b hb b' hb' hbb' => ?_
+    rw [Multiset.mem_range] at hb hb'
+    have hu := (TS_injective hbb').2
+    have hζu : IsPrimitiveRoot ζ p := IsPrimitiveRoot.coe_units_iff.mp hζ
+    exact hζu.pow_inj hb hb' hu
+
+theorem exists_isPrimitiveRoot_cyclotomicField (N : ℕ) [NeZero N] :
+    ∃ z : CyclotomicField N ℚ, IsPrimitiveRoot z N := by
+  have : NeZero ((N : ℕ) : ℚ) := ⟨Nat.cast_ne_zero.mpr (NeZero.ne N)⟩
+  have : IsCyclotomicExtension {N} ℚ (CyclotomicField N ℚ) :=
+    CyclotomicField.isCyclotomicExtension N ℚ
+  exact IsCyclotomicExtension.exists_isPrimitiveRoot ℚ (CyclotomicField N ℚ) (Set.mem_singleton N)
+    (NeZero.ne N)
+
+def cycUnit (N : ℕ) [NeZero N] : (CyclotomicField N ℚ)ˣ :=
+  ((exists_isPrimitiveRoot_cyclotomicField N).choose_spec.isUnit (NeZero.ne N)).unit
+
+theorem cycUnit_spec (N : ℕ) [NeZero N] :
+    IsPrimitiveRoot ((cycUnit N : (CyclotomicField N ℚ)ˣ) : CyclotomicField N ℚ) N := by
+  rw [cycUnit, IsUnit.unit_spec]
+  exact (exists_isPrimitiveRoot_cyclotomicField N).choose_spec
+
+theorem cycUnit_pow (N : ℕ) [NeZero N] : cycUnit N ^ N = 1 :=
+  Units.ext (by rw [Units.val_pow_eq_pow_val, (cycUnit_spec N).pow_eq_one, Units.val_one])
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionFieldFull coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  full_eq_adjoin_primes finrank_adjoin_jqN_prime_of_not_mem jqN_prime_not_mem_adjoin \
+  dedekindPsi_of_squarefree"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K]
+
+theorem isPrimitiveRoot_pow_div {N : ℕ} [NeZero N] {ζ : Kˣ} (hζ : IsPrimitiveRoot (ζ : K) N)
+    {p : ℕ} (hpN : p ∣ N) : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hd0 : N / p ≠ 0 := by
+    intro h0
+    have hc := Nat.div_mul_cancel hpN
+    rw [h0, zero_mul] at hc
+    exact hN hc.symm
+  have h := hζ.pow_of_dvd hd0 (Nat.div_dvd_of_dvd hpN)
+  rw [Nat.div_div_self hpN hN] at h
+  rwa [← Units.val_pow_eq_pow_val] at h
+
+theorem qExpand_qTwist_TS (e : ℕ) [NeZero e] (u : Kˣ) (m : ℕ) [NeZero m] (w : Kˣ) :
+    qExpand K e (qTwist u (TS K m w)) = TS K (e * m) (u ^ (m : ℤ) * w) := by
+  rw [qTwist_TS, qExpand_TS]
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionFieldFull coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  full_eq_adjoin_primes finrank_adjoin_jqN_prime_of_not_mem jqN_prime_not_mem_adjoin \
+  dedekindPsi_of_squarefree"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+variable {K : Type*} [Field K] [Algebra ℚ K]
+
+private theorem prod_form_ne_zero (N : ℕ) (ζ : Kˣ) (p : ℕ) [NeZero p] (e : ℕ) [NeZero e]
+    (u : Kˣ) :
+    (Polynomial.X - Polynomial.C (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)))) *
+        ∏ b ∈ Finset.range p,
+          (Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K
+            jq)))) ≠ 0 :=
+  mul_ne_zero (Polynomial.X_sub_C_ne_zero _)
+    (Polynomial.monic_prod_of_monic _ _ fun _ _ => Polynomial.monic_X_sub_C _).ne_zero
+
+theorem roots_prime_at_slot (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots
+      = (qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+          (Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq))) := by
+  rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u,
+    Polynomial.roots_mul (prod_form_ne_zero N ζ p e u), Polynomial.roots_X_sub_C,
+    Finset.prod_eq_multiset_prod, Finset.range_val,
+    show (Multiset.range p).map
+          (fun b => Polynomial.X - Polynomial.C (qExpand K e (qTwist (u * ζ ^ (b * (N / p)))
+    (coeffEmb K jq))))
+        = ((Multiset.range p).map
+            (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).map
+            (fun a => Polynomial.X - Polynomial.C a) from
+      (Multiset.map_map (fun a => Polynomial.X - Polynomial.C a)
+        (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))
+        (Multiset.range p)).symm,
+    Polynomial.roots_multiset_prod_X_sub_C, Multiset.singleton_add]
+
+theorem roots_prime_at_slot_nodup (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (e : ℕ) [NeZero e] (u : Kˣ) :
+    ((qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq))) ::ₘ
+        (Multiset.range p).map
+          (fun b => qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)))).Nodup := by
+  have hζp : IsPrimitiveRoot ((ζ ^ (N / p) : Kˣ) : K) p := isPrimitiveRoot_pow_div hζ hpN
+  rw [Multiset.nodup_cons]
+  constructor
+  · intro hmem
+    obtain ⟨b, hb, heq⟩ := Multiset.mem_map.mp hmem
+    have h := (TS_injective (K := K) (e := e) (e' := p * (p * e))
+      (u := u * ζ ^ (b * (N / p))) (u' := u ^ (p * p))
+      (by simpa only [TS_eq_coeffEmb] using heq)).1
+    have hp2 : 2 ≤ p := hp.out.two_le
+    have he1 : 0 < e := Nat.pos_of_ne_zero (NeZero.ne e)
+    have hmono : 2 * (2 * e) ≤ p * (p * e) := Nat.mul_le_mul hp2 (Nat.mul_le_mul hp2 le_rfl)
+    rw [← h] at hmono
+    omega
+  · refine Multiset.Nodup.map_on ?_ (Multiset.nodup_range p)
+    intro b hb b' hb' heq
+    rw [Multiset.mem_range] at hb hb'
+    have h := (TS_injective (K := K) (e := e) (e' := e)
+      (u := u * ζ ^ (b * (N / p))) (u' := u * ζ ^ (b' * (N / p)))
+      (by simpa only [TS_eq_coeffEmb] using heq)).2
+    have h2 : ζ ^ (b * (N / p)) = ζ ^ (b' * (N / p)) := mul_left_cancel h
+    have h3 : (ζ ^ (N / p)) ^ b = (ζ ^ (N / p)) ^ b' := by
+      rw [← pow_mul, ← pow_mul, Nat.mul_comm (N / p) b, Nat.mul_comm (N / p) b']
+      exact h2
+    have h4 : ((ζ ^ (N / p) : Kˣ) : K) ^ b = ((ζ ^ (N / p) : Kˣ) : K) ^ b' := by
+      rw [← Units.val_pow_eq_pow_val, ← Units.val_pow_eq_pow_val, h3]
+    exact hζp.pow_inj hb hb' h4
+
+theorem roots_prime_at_slot_roots_nodup (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N) (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N)
+    (data : ModularPolynomialData p) (e : ℕ) [NeZero e] (u : Kˣ) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).roots.Nodup := by
+  rw [roots_prime_at_slot N ζ hζ p hpN data e u]
+  exact roots_prime_at_slot_nodup N ζ hζ p hpN e u
+
+theorem isRoot_prime_at_slot_iff (N : ℕ) [NeZero N] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (p : ℕ) [hp : Fact (Nat.Prime p)] (hpN : p ∣ N) (data : ModularPolynomialData p)
+    (e : ℕ) [NeZero e] (u : Kˣ) (y : LaurentSeries K) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+        (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq))))).IsRoot y ↔
+      y = qExpand K (p * (p * e)) (qTwist (u ^ (p * p)) (coeffEmb K jq)) ∨
+        ∃ b < p, y = qExpand K e (qTwist (u * ζ ^ (b * (N / p))) (coeffEmb K jq)) := by
+  have hne : data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (LaurentSeries K))
+      (qExpand K (p * e) (qTwist (u ^ p) (coeffEmb K jq)))) ≠ 0 := by
+    rw [ModularCurve.PhiGen.splits_prime_at_slot N ζ hζ p hpN data e u]
+    exact prod_form_ne_zero N ζ p e u
+  rw [← Polynomial.mem_roots hne, roots_prime_at_slot N ζ hζ p hpN data e u,
+    Multiset.mem_cons, Multiset.mem_map]
+  constructor
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mp hb, rfl⟩
+  · rintro (h | ⟨b, hb, rfl⟩)
+    · exact Or.inl h
+    · exact Or.inr ⟨b, Multiset.mem_range.mpr hb, rfl⟩
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionFieldFull coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  full_eq_adjoin_primes finrank_adjoin_jqN_prime_of_not_mem jqN_prime_not_mem_adjoin \
+  dedekindPsi_of_squarefree"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+
+
+
+
+theorem phiAtSeed_jq_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) :
+    (phiAtSeed data jq).eval (jqN n) = 0 := by
+  have h := data.eval_eq_zero
+  rw [phiAtSeed, Polynomial.eval_map]
+  convert h using 2
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp [evalAtJ_X]
+
+
+theorem phiAtSeed_jqN_eval (n : ℕ) [NeZero n] (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (jqN M)).eval (jqN (M * n)) = 0 := by
+  have h := phiAtSeed_eval_map data jq (jqN n) (qExpand ℚ M) (phiAtSeed_jq_eval n data)
+  rwa [jqN, qExpand_qExpand] at h
+
+theorem phiAtSeed_iota_eval {K : Type*} [Field K] [Algebra ℚ K] (A : ℕ) [NeZero A] (n : ℕ)
+    [NeZero n]
+    (data : ModularPolynomialData n) (M : ℕ) [NeZero M] :
+    (phiAtSeed data (coeffEmb K (qExpand ℚ A (jqN M)))).eval (coeffEmb K (qExpand ℚ A (jqN (M *
+      n)))) = 0 :=
+  phiAtSeed_eval_map data _ _ ((coeffEmb K).comp (qExpand ℚ A)) (phiAtSeed_jqN_eval n data M)
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionFieldFull coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  full_eq_adjoin_primes finrank_adjoin_jqN_prime_of_not_mem jqN_prime_not_mem_adjoin \
+  dedekindPsi_of_squarefree"
+namespace W1
+p2m_open "ModularCurve~coeffEmb_qExpand"
+
+private theorem w1_mem_adjoin_of_mem {E : IntermediateField ℚ (LaurentSeries ℚ)}
+    {x : LaurentSeries ℚ} (hx : x ∈ E) (T : Set (LaurentSeries ℚ)) :
+    x ∈ IntermediateField.adjoin E T :=
+  (IntermediateField.adjoin E T).algebraMap_mem ⟨x, hx⟩
+
+private theorem w1_jq_mem (S : Finset ℕ) :
+    jq ∈ IntermediateField.adjoin ℚ
+      (insert jq {x : LaurentSeries ℚ | ∃ p ∈ S, ∃ _ : NeZero p, x = jqN p}) :=
+  IntermediateField.subset_adjoin ℚ _ (Set.mem_insert _ _)
+
+private theorem w1_jqN_mem (S : Finset ℕ) {r : ℕ} [NeZero r] (hr : r ∈ S) :
+    jqN r ∈ IntermediateField.adjoin ℚ
+      (insert jq {x : LaurentSeries ℚ | ∃ p ∈ S, ∃ _ : NeZero p, x = jqN p}) :=
+  IntermediateField.subset_adjoin ℚ _ (Set.mem_insert_of_mem _ ⟨r, hr, inferInstance, rfl⟩)
+
+private theorem w1_adjoin_mono {S T : Finset ℕ} (hST : S ⊆ T) :
+    IntermediateField.adjoin ℚ
+        (insert jq {x : LaurentSeries ℚ | ∃ p ∈ S, ∃ _ : NeZero p, x = jqN p}) ≤
+      IntermediateField.adjoin ℚ
+        (insert jq {x : LaurentSeries ℚ | ∃ p ∈ T, ∃ _ : NeZero p, x = jqN p}) := by
+  apply IntermediateField.adjoin.mono
+  apply Set.insert_subset_insert
+  rintro x ⟨r, hr, hne, rfl⟩
+  exact ⟨r, hST hr, hne, rfl⟩
+
+private theorem w1_relfinrank_insert (S : Finset ℕ) (hS : ∀ q ∈ S, Nat.Prime q)
+    (p : ℕ) (pp : Nat.Prime p) (hpS : p ∉ S) :
+    IntermediateField.relfinrank
+      (IntermediateField.adjoin ℚ
+        (insert jq {x : LaurentSeries ℚ | ∃ q ∈ S, ∃ _ : NeZero q, x = jqN q}))
+      (IntermediateField.adjoin ℚ
+        (insert jq {x : LaurentSeries ℚ | ∃ q ∈ insert p S, ∃ _ : NeZero q, x = jqN q}))
+      = p + 1 := by
+  have : Fact (Nat.Prime p) := ⟨pp⟩
+  have : NeZero p := ⟨pp.ne_zero⟩
+  have h : IntermediateField.adjoin ℚ
+        (insert jq {x : LaurentSeries ℚ | ∃ q ∈ S, ∃ _ : NeZero q, x = jqN q}) ≤
+      IntermediateField.adjoin ℚ
+        (insert jq {x : LaurentSeries ℚ | ∃ q ∈ insert p S, ∃ _ : NeZero q, x = jqN q}) :=
+    w1_adjoin_mono (Finset.subset_insert p S)
+  rw [IntermediateField.relfinrank_eq_finrank_of_le h, IntermediateField.extendScalars_adjoin h]
+  have hEq : IntermediateField.adjoin
+        (IntermediateField.adjoin ℚ
+          (insert jq {x : LaurentSeries ℚ | ∃ q ∈ S, ∃ _ : NeZero q, x = jqN q}))
+        (insert jq {x : LaurentSeries ℚ | ∃ q ∈ insert p S, ∃ _ : NeZero q, x = jqN q}) =
+      IntermediateField.adjoin
+        (IntermediateField.adjoin ℚ
+          (insert jq {x : LaurentSeries ℚ | ∃ q ∈ S, ∃ _ : NeZero q, x = jqN q}))
+        ({jqN p} : Set (LaurentSeries ℚ)) := by
+    refine le_antisymm ?_ ?_
+    · rw [IntermediateField.adjoin_le_iff]
+      rintro x (rfl | ⟨r, hr, hne, rfl⟩)
+      · exact w1_mem_adjoin_of_mem (w1_jq_mem S) _
+      · rcases Finset.mem_insert.mp hr with rfl | hrS
+        · exact IntermediateField.subset_adjoin _ _ rfl
+        · exact w1_mem_adjoin_of_mem (w1_jqN_mem S hrS) _
+    · rw [IntermediateField.adjoin_le_iff]
+      rintro x rfl
+      exact IntermediateField.subset_adjoin _ _
+        (Set.mem_insert_of_mem _ ⟨p, Finset.mem_insert_self p S, inferInstance, rfl⟩)
+  rw [hEq]
+  exact ModularCurve.finrank_adjoin_jqN_prime_of_not_mem _ (w1_jq_mem S) p
+    (ModularCurve.jqN_prime_not_mem_adjoin S hS p hpS)
+
+end ModularCurve.W1
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand qExpand_coeff_mul qExpand_coeff_of_not_dvd qExpand_one_apply \
+  qExpand_qExpand jq coeff_jq_neg_one coeff_jq_of_lt jqN dedekindPsi evalAtJ_X \
+  ModularPolynomialData modularFunctionFieldFull coeffEmb coeffEmb_coeff qTwist qTwist_coeff \
+  qTwist_one_apply qTwist_qTwist qTwist_qExpand coeffMap_qExpand PhiGen.splits_prime_at_slot \
+  full_eq_adjoin_primes finrank_adjoin_jqN_prime_of_not_mem jqN_prime_not_mem_adjoin \
+  dedekindPsi_of_squarefree"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.relfinrank_adjoin_primes (S : Finset ℕ) (hS : ∀ p ∈ S, p.Prime) :
+    IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (IntermediateField.adjoin ℚ (insert jq {x : LaurentSeries ℚ | ∃ p ∈ S, ∃ _ : NeZero p, x = jqN
+      p})) = ∏ p ∈ S, (p + 1) := by
+  revert hS
+  induction S using Finset.induction_on with
+  | empty =>
+    intro _
+    have hins : insert jq {x : LaurentSeries ℚ | ∃ p ∈ (∅ : Finset ℕ), ∃ _ : NeZero p, x = jqN p}
+        = ({jq} : Set (LaurentSeries ℚ)) := by
+      ext x
+      simp
+    rw [hins, IntermediateField.relfinrank_self, Finset.prod_empty]
+  | insert p S hpS ih =>
+    intro hS'
+    have hpp : Nat.Prime p := hS' p (Finset.mem_insert_self p S)
+    have hSp : ∀ q ∈ S, Nat.Prime q := fun q hq => hS' q (Finset.mem_insert_of_mem hq)
+    have h1 : IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)) ≤
+        IntermediateField.adjoin ℚ
+          (insert jq {x : LaurentSeries ℚ | ∃ q ∈ S, ∃ _ : NeZero q, x = jqN q}) := by
+      apply IntermediateField.adjoin.mono
+      exact Set.singleton_subset_iff.mpr (Set.mem_insert _ _)
+    have h2 : IntermediateField.adjoin ℚ
+          (insert jq {x : LaurentSeries ℚ | ∃ q ∈ S, ∃ _ : NeZero q, x = jqN q}) ≤
+        IntermediateField.adjoin ℚ
+          (insert jq {x : LaurentSeries ℚ | ∃ q ∈ insert p S, ∃ _ : NeZero q, x = jqN q}) :=
+      ModularCurve.W1.w1_adjoin_mono (Finset.subset_insert p S)
+    rw [← IntermediateField.relfinrank_mul_relfinrank h1 h2, ih hSp,
+      ModularCurve.W1.w1_relfinrank_insert S hSp p hpp hpS, Finset.prod_insert hpS]
+    exact mul_comm _ _
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.relfinrank_full_of_squarefree (N : ℕ) [NeZero N] (hN : Squarefree N) :
+    IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (modularFunctionFieldFull N) = dedekindPsi N := by
+  rw [ModularCurve.full_eq_adjoin_primes N hN,
+    ModularCurve.relfinrank_adjoin_primes N.primeFactors
+      (fun p hp => Nat.prime_of_mem_primeFactors hp),
+    ModularCurve.dedekindPsi_of_squarefree hN]
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.relfinrank_full_mul_prime (N : ℕ) [NeZero N] (hN : Squarefree N)
+    {ℓ : ℕ} (hℓ : ℓ.Prime) (hℓN : ¬ ℓ ∣ N) :
+    IntermediateField.relfinrank (modularFunctionFieldFull N) (modularFunctionFieldFull (N * ℓ)) = ℓ
+      + 1 := by
+  have : NeZero (N * ℓ) := ⟨mul_ne_zero (NeZero.ne N) hℓ.ne_zero⟩
+  have hcop : N.Coprime ℓ := Nat.coprime_comm.mp (hℓ.coprime_iff_not_dvd.mpr hℓN)
+  have hNℓ : Squarefree (N * ℓ) := Nat.squarefree_mul_iff.mpr ⟨hcop, hN, hℓ.prime.squarefree⟩
+  have hfac : (N * ℓ).primeFactors = insert ℓ N.primeFactors := by
+    rw [Nat.primeFactors_mul (NeZero.ne N) hℓ.ne_zero, hℓ.primeFactors, Finset.union_comm,
+      ← Finset.insert_eq]
+  rw [ModularCurve.full_eq_adjoin_primes N hN, ModularCurve.full_eq_adjoin_primes (N * ℓ) hNℓ,
+    hfac]
+  exact ModularCurve.W1.w1_relfinrank_insert N.primeFactors
+    (fun q hq => Nat.prime_of_mem_primeFactors hq) ℓ hℓ
+    (fun hmem => hℓN (Nat.dvd_of_mem_primeFactors hmem))
+
+end
+
+p2m_open "ModularCurve~coeffEmb_qExpand\
+  " in
+open _root_.P2MW.S_ModularCurve_relfinrank_full_of_squarefree.ModularCurve in
+theorem solution (N : ℕ) [NeZero N] (hN : Squarefree N) :
+    IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (modularFunctionFieldFull N) = dedekindPsi N :=
+  ModularCurve.relfinrank_full_of_squarefree N hN
+
+end S_ModularCurve_relfinrank_full_of_squarefree
+end P2MW
+export P2MW.S_ModularCurve_relfinrank_full_of_squarefree (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.relfinrank_full_of_squarefree (N : ℕ) [NeZero N] (hN : Squarefree N) :
+    IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (modularFunctionFieldFull N) = dedekindPsi N :=
+  solution N hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_relfinrank_laurentBaseChange.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_relfinrank_laurentBaseChange.lean
new file mode 100644
index 0000000000..d16c0fc673
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_relfinrank_laurentBaseChange.lean
@@ -0,0 +1,456 @@
+/-
+Based on Prove2Me node ModularCurve.relfinrank_laurentBaseChange
+(26c8cb9c-798d-588b-98de-867b96e4a76b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 22cb04bd-b8fc-58bc-897d-e20eedb9d507
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import Mathlib.FieldTheory.Relrank
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GeometricBaseChange
+import Mathlib.RingTheory.AlgebraTower
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Algebra
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlace
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqNModC_eq_of_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularFunctionFieldBar_eq_restrictScalars
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Relative degree is preserved by constant field extension
+
+Theorem statement: `ModularCurve.relfinrank_laurentBaseChange`
+(`26c8cb9c-798d-588b-98de-867b96e4a76b`), by Claude, 2026-09-05.
+
+Proof: submission `22cb04bd-b8fc-58bc-897d-e20eedb9d507`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbb{Q}$-algebra structure, let $F_0$ be an intermediate
+field of $\mathbb{Q} \subseteq \mathbb{Q}((q))$ inside the field of formal Laurent series over
+$\mathbb{Q}$, and let $t \in \mathbb{Q}((q))$ be an element lying in $F_0$ and transcendental over
+$\mathbb{Q}$. Write $\overline{(\cdot)}$ for the ring homomorphism `coeffEmb L` from
+$\mathbb{Q}((q))$ to $L((q))$ obtained by applying the structure map $\mathbb{Q} \to L$ to each
+coefficient of a Laurent series, and let `laurentBaseChange L F₀` be the intermediate field of $L
+\subseteq L((q))$ generated over $L$ by the image $\overline{F_0}$ of $F_0$ under this map. The
+assertion is the equality of relative degrees
+$$[\,\mathrm{laurentBaseChange}\ L\ F_0 : L(\overline{t})\,] = [\,F_0 : \mathbb{Q}(t)\,],$$
+both sides being Mathlib's `IntermediateField.relfinrank` of the indicated pair of intermediate
+fields, the first pair inside $L((q))$ with $L(\overline{t})$ the $L$-subfield generated by
+$\overline{t}$, the second inside $\mathbb{Q}((q))$ with $\mathbb{Q}(t)$ the $\mathbb{Q}$-subfield
+generated by $t$. In each pair the smaller field is contained in the larger, so each side is the
+degree of the extension, with the convention that it is $0$ when the extension is infinite; in
+particular the equality also transports finiteness of the degree in both directions.
+
+This is the statement that the relative degree of a subfield of $\mathbb{Q}((q))$ over a rational
+subfield $\mathbb{Q}(t)$ is unchanged under extension of the constant field from $\mathbb{Q}$ to
+$L$, i.e. linear disjointness of $L$ and $\mathbb{Q}((q))$ over $\mathbb{Q}$ in the form of a
+constant field extension for function fields. It is used to carry degree computations for modular
+function fields, such as the degree $\ell+1$ of the extension generated by $j(\ell q)$ over the
+field generated by $j(q)$, from the field of definition $\mathbb{Q}$ to $\overline{\mathbb{Q}}$ or
+any other coefficient field, and is invoked by the lemmas relating `relfinrank` to degrees along
+morphisms of curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_relfinrank_laurentBaseChange.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_relfinrank_laurentBaseChange
+
+noncomputable section
+
+open ModularCurve IntermediateField Polynomial
+
+namespace TransportDev
+
+variable (L : Type*) [Field L] [Algebra ℚ L]
+variable (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (t : LaurentSeries ℚ)
+
+abbrev K₀ :
+    IntermediateField ℚ (LaurentSeries ℚ) := IntermediateField.adjoin ℚ ({t} : Set (LaurentSeries
+      ℚ))
+
+abbrev K : IntermediateField L (LaurentSeries L) :=
+  IntermediateField.adjoin L ({coeffEmb L t} : Set (LaurentSeries L))
+
+variable {F₀ t}
+
+theorem K₀_le (ht : t ∈ F₀) : K₀ t ≤ F₀ :=
+  adjoin_le_iff.mpr (Set.singleton_subset_iff.mpr ht)
+
+theorem K_le (ht : t ∈ F₀) : K L t ≤ laurentBaseChange L F₀ :=
+  adjoin_le_iff.mpr (Set.singleton_subset_iff.mpr (coeffEmb_mem_laurentBaseChange L ht))
+
+theorem coeffEmb_aeval (r : ℚ[X]) :
+    coeffEmb L (aeval t r) = aeval (coeffEmb L t) (r.map (algebraMap ℚ L)) := by
+  simp only [aeval_def, eval₂_map, hom_eval₂]
+  congr 1
+  exact Subsingleton.elim _ _
+
+theorem coeffEmb_mem_K {x : LaurentSeries ℚ} (hx : x ∈ K₀ t) : coeffEmb L x ∈ K L t := by
+  rw [mem_adjoin_simple_iff] at hx ⊢
+  obtain ⟨r, s, rfl⟩ := hx
+  exact ⟨r.map (algebraMap ℚ L), s.map (algebraMap ℚ L), by rw [map_div₀, coeffEmb_aeval,
+    coeffEmb_aeval]⟩
+
+variable (F₀ t) in
+abbrev E₀ (ht : t ∈ F₀) : IntermediateField (K₀ t) (LaurentSeries ℚ) := extendScalars (K₀_le ht)
+
+variable (F₀ t) in
+abbrev E (ht : t ∈ F₀) : IntermediateField (K L t) (LaurentSeries L) := extendScalars (K_le L ht)
+
+def φ : K₀ t →+* K L t := (coeffEmb L).restrict _ _ fun _ hx => coeffEmb_mem_K L hx
+
+def ψ (ht : t ∈ F₀) : E₀ F₀ t ht →+* E L F₀ t ht :=
+  (coeffEmb L).restrict _ _ fun _ hx => coeffEmb_mem_laurentBaseChange L ((mem_extendScalars _).mp
+    hx)
+
+theorem coe_φ (x : K₀ t) : (φ L x : LaurentSeries L) = coeffEmb L x := rfl
+theorem coe_ψ (ht : t ∈ F₀) (x : E₀ F₀ t ht) : (ψ L ht x : LaurentSeries L) = coeffEmb L x := rfl
+
+theorem ψ_compat (ht : t ∈ F₀) :
+    (algebraMap (K L t) (E L F₀ t ht)).comp (φ L) = (ψ L ht).comp (algebraMap (K₀ t) (E₀ F₀ t ht))
+      := by
+  apply RingHom.ext
+  intro x
+  apply Subtype.ext
+  rfl
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+theorem isAlgebraic_coeffEmb (ht : t ∈ F₀) [FiniteDimensional (K₀ t) (E₀ F₀ t ht)]
+    (f : LaurentSeries ℚ) (hf : f ∈ F₀) :
+    IsAlgebraic (K L t) (coeffEmb L f) := by
+  have h1 : IsIntegral (K₀ t) (⟨f, (mem_extendScalars _).mpr hf⟩ : E₀ F₀ t ht) :=
+    Algebra.IsIntegral.isIntegral _
+  have h2 := h1.map_of_comp_eq (φ L) (ψ L ht) (ψ_compat L ht)
+  have h3 : IsIntegral (K L t) ((ψ L ht ⟨f, (mem_extendScalars _).mpr hf⟩ : E L F₀ t ht) :
+    LaurentSeries L) :=
+    h2.algebraMap
+  exact h3.isAlgebraic
+
+theorem laurentBaseChange_eq_adjoin :
+    laurentBaseChange L F₀ = IntermediateField.adjoin L (coeffEmb L '' (F₀ : Set (LaurentSeries ℚ)))
+      := rfl
+
+theorem restrictScalars_adjoin_K (ht : t ∈ F₀) :
+    (IntermediateField.adjoin (K L t) (coeffEmb L '' (F₀ : Set (LaurentSeries ℚ)))).restrictScalars
+      L
+      = laurentBaseChange L F₀ := by
+  have h1 : IntermediateField.adjoin (K L t) (coeffEmb L '' (F₀ : Set (LaurentSeries ℚ))) ≤ E L F₀ t
+    ht :=
+    adjoin_le_iff.mpr (subset_adjoin L _)
+  have h2 : laurentBaseChange L F₀ ≤
+      (IntermediateField.adjoin (K L t) (coeffEmb L '' (F₀ : Set (LaurentSeries
+        ℚ)))).restrictScalars L :=
+    adjoin_le_iff.mpr (subset_adjoin (K L t) _)
+  exact le_antisymm (fun x hx => h1 hx) h2
+
+theorem closure_image_eq :
+    (Submonoid.closure (coeffEmb L '' (F₀ : Set (LaurentSeries ℚ))) : Set (LaurentSeries L))
+      = coeffEmb L '' (F₀ : Set (LaurentSeries ℚ)) := by
+  have : (coeffEmb L '' (F₀ : Set (LaurentSeries ℚ))) = ((F₀.toSubfield.map (coeffEmb
+    L)).toSubmonoid : Set (LaurentSeries L)) :=
+    by
+    ext x; simp
+  rw [this, Submonoid.closure_eq]
+
+section Finite
+
+variable (ht : t ∈ F₀) [FiniteDimensional (K₀ t) (E₀ F₀ t ht)]
+include ht
+
+theorem mem_span_image (x : LaurentSeries L) (hx : x ∈ laurentBaseChange L F₀) :
+    x ∈ Submodule.span (K L t) (coeffEmb L '' (F₀ : Set (LaurentSeries ℚ))) := by
+  have hx' : x ∈ IntermediateField.adjoin (K L t) (coeffEmb L '' (F₀ : Set (LaurentSeries ℚ))) := by
+    rw [← mem_restrictScalars L, restrictScalars_adjoin_K L ht]; exact hx
+  have halg : ∀ y ∈ coeffEmb L '' (F₀ : Set (LaurentSeries ℚ)), IsAlgebraic (K L t) y := by
+    rintro _ ⟨f, hf, rfl⟩; exact isAlgebraic_coeffEmb L ht f hf
+  rw [← mem_toSubalgebra, adjoin_toSubalgebra_of_isAlgebraic halg] at hx'
+  have hx'' : x ∈ Subalgebra.toSubmodule (Algebra.adjoin (K L t) (coeffEmb L '' (F₀ : Set
+    (LaurentSeries ℚ)))) :=
+    hx'
+  rw [Algebra.adjoin_eq_span] at hx''
+  rwa [closure_image_eq] at hx''
+
+theorem mem_span_range {ι : Type*} (b : Module.Basis ι (K₀ t) (E₀ F₀ t ht)) (x : LaurentSeries L)
+    (hx : x ∈ laurentBaseChange L F₀) :
+    x ∈ Submodule.span (K L t) (Set.range fun i => ((ψ L ht (b i) : E L F₀ t ht) : LaurentSeries L))
+      := by
+  refine Submodule.span_le.mpr ?_ (mem_span_image L ht x hx)
+  rintro _ ⟨f, hf, rfl⟩
+  have hrepr := b.linearCombination_repr ⟨f, (mem_extendScalars _).mpr hf⟩
+  rw [Finsupp.linearCombination_apply, Finsupp.sum] at hrepr
+  have : coeffEmb L f = ∑ i ∈ (b.repr ⟨f, (mem_extendScalars _).mpr hf⟩).support,
+      (φ L (b.repr ⟨f, (mem_extendScalars _).mpr hf⟩ i)) • ((ψ L ht (b i) : E L F₀ t ht) :
+        LaurentSeries L) := by
+    have h2 := congrArg (fun z : E₀ F₀ t ht => coeffEmb L (z : LaurentSeries ℚ)) hrepr
+    dsimp only at h2
+    rw [← h2, AddSubmonoidClass.coe_finsetSum, map_sum]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [IntermediateField.coe_smul, Algebra.smul_def, map_mul, Algebra.smul_def]
+    rfl
+  rw [this]
+  exact Submodule.sum_mem _ fun i _ => Submodule.smul_mem _ _ (Submodule.subset_span ⟨i, rfl⟩)
+
+theorem finite_and_finrank_le :
+    Module.Finite (K L t) (E L F₀ t ht) ∧
+      Module.finrank (K L t) (E L F₀ t ht) ≤ Module.finrank (K₀ t) (E₀ F₀ t ht) := by
+  classical
+  let b := Module.Free.chooseBasis (K₀ t) (E₀ F₀ t ht)
+  let y : Module.Free.ChooseBasisIndex (K₀ t) (E₀ F₀ t ht) → E L F₀ t ht := fun i => ψ L ht (b i)
+  have htop : ∀ x : E L F₀ t ht, x ∈ Submodule.span (K L t) (Set.range y) := fun x => by
+    have hx := mem_span_range L ht b (x : LaurentSeries L) ((mem_extendScalars _).mp x.2)
+    have hr : (Set.range fun i => ((ψ L ht (b i) : E L F₀ t ht) : LaurentSeries L))
+        = (E L F₀ t ht).val.toLinearMap '' (Set.range y) := by
+      rw [← Set.range_comp]; rfl
+    rw [hr, Submodule.span_image] at hx
+    obtain ⟨z, hz, hzx⟩ := Submodule.mem_map.mp hx
+    have hzx' : z = x := Subtype.ext hzx
+    exact hzx' ▸ hz
+  have hspan : Submodule.span (K L t) (Set.range y) = ⊤ := eq_top_iff.mpr fun x _ => htop x
+  have hfin : Module.Finite (K L t) (E L F₀ t ht) :=
+    ⟨by rw [← hspan]; exact Submodule.fg_span (Set.finite_range y)⟩
+  refine ⟨hfin, ?_⟩
+  conv_rhs => rw [Module.finrank_eq_card_chooseBasisIndex]
+  conv_lhs => rw [← finrank_top, ← hspan]
+  calc Module.finrank (K L t) (Submodule.span (K L t) (Set.range y))
+        ≤ (Set.range y).toFinset.card := finrank_span_le_card _
+    _ ≤ Fintype.card (Module.Free.ChooseBasisIndex (K₀ t) (E₀ F₀ t ht)) := by
+        rw [Set.toFinset_range]; exact Finset.card_image_le.trans (by rw [Finset.card_univ])
+
+end Finite
+
+theorem linearIndependent_pow_mul (ht : t ∈ F₀) (htr : Transcendental ℚ t) {ι : Type*}
+    {v : ι → E₀ F₀ t ht} (hv : LinearIndependent (K₀ t) v) :
+    LinearIndependent ℚ fun p : ℕ × ι => t ^ p.1 * ((v p.2 : E₀ F₀ t ht) : LaurentSeries ℚ) := by
+  classical
+  rw [linearIndependent_iff'] at hv ⊢
+  intro S μ hS p hp
+  let c : ι → LaurentSeries ℚ := fun i =>
+    ∑ q ∈ S, if q.2 = i then algebraMap ℚ (LaurentSeries ℚ) (μ q) * t ^ q.1 else 0
+  have hcmem : ∀ i, c i ∈ K₀ t := fun i => by
+    refine sum_mem fun q _ => ?_
+    split_ifs
+    · exact mul_mem ((K₀ t).algebraMap_mem _) (pow_mem (mem_adjoin_simple_self ℚ t) _)
+    · exact zero_mem _
+  have hrel : ∑ i ∈ S.image Prod.snd, (⟨c i, hcmem i⟩ : K₀ t) • v i = 0 := by
+    apply Subtype.ext
+    rw [AddSubmonoidClass.coe_finsetSum, ZeroMemClass.coe_zero]
+    have h1 : ∀ i, ((((⟨c i, hcmem i⟩ : K₀ t) • v i : E₀ F₀ t ht)) : LaurentSeries ℚ)
+        = ∑ q ∈ S, if q.2 = i then
+            algebraMap ℚ (LaurentSeries ℚ) (μ q) * t ^ q.1 * ((v i : E₀ F₀ t ht) : LaurentSeries ℚ)
+              else 0 := by
+      intro i
+      change c i * ((v i : E₀ F₀ t ht) : LaurentSeries ℚ) = _
+      rw [Finset.sum_mul]
+      exact Finset.sum_congr rfl fun q _ => by by_cases h : q.2 = i <;> simp [h]
+    simp_rw [h1]
+    rw [Finset.sum_comm]
+    refine Eq.trans (Finset.sum_congr rfl fun q hq => ?_) hS
+    rw [Finset.sum_ite_eq, ite_eq_left (Finset.mem_image_of_mem Prod.snd hq), ←
+      HahnSeries.single_zero_mul_eq_smul,
+      algebraMap_laurentSeries_eq_single, mul_assoc]
+  have hci : (⟨c p.2, hcmem p.2⟩ : K₀ t) = 0 :=
+    hv _ _ hrel p.2 (Finset.mem_image_of_mem Prod.snd hp)
+  have hc0 : c p.2 = 0 := congrArg Subtype.val hci
+  have hQ : aeval t (∑ q ∈ S, if q.2 = p.2 then monomial q.1 (μ q) else 0) = 0 := by
+    rw [map_sum, ← hc0]
+    exact Finset.sum_congr rfl fun q _ => by by_cases h : q.2 = p.2 <;> simp [h, aeval_monomial]
+  have hQ0 : (∑ q ∈ S, if q.2 = p.2 then monomial q.1 (μ q) else 0 : ℚ[X]) = 0 :=
+    transcendental_iff_injective.mp htr (by rw [map_zero]; exact hQ)
+  have hco := congrArg (fun P : ℚ[X] => P.coeff p.1) hQ0
+  beta_reduce at hco
+  rw [finsetSum_coeff, coeff_zero, Finset.sum_eq_single p] at hco
+  · simpa using hco
+  · intro q _ hqp
+    by_cases h2 : q.2 = p.2
+    · rw [ite_eq_left h2, coeff_monomial, ite_eq_right]
+      intro h1
+      exact hqp (Prod.ext h1 h2)
+    · rw [ite_eq_right h2, coeff_zero]
+  · intro hpS
+    exact absurd hp hpS
+
+theorem exists_common_denom {ι : Type*} (s : Finset ι) (g : ι → K L t) :
+    ∃ d : L[X], aeval (coeffEmb L t) d ≠ 0 ∧
+      ∀ i ∈ s, ∃ p : L[X], aeval (coeffEmb L t) d * (g i : LaurentSeries L) = aeval (coeffEmb L t) p
+        := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => exact ⟨1, by simp, by simp⟩
+  | insert a s has ih =>
+    obtain ⟨d, hd, hs⟩ := ih
+    obtain ⟨r, q, hrq⟩ := (mem_adjoin_simple_iff L _).mp (g a).2
+    by_cases hq : aeval (coeffEmb L t) q = 0
+    · refine ⟨d, hd, ?_⟩
+      intro i hi
+      rcases Finset.mem_insert.mp hi with rfl | hi
+      · exact ⟨0, by rw [hrq, hq, div_zero, mul_zero, map_zero]⟩
+      · exact hs i hi
+    · refine ⟨d * q, by rw [map_mul]; exact mul_ne_zero hd hq, ?_⟩
+      intro i hi
+      rcases Finset.mem_insert.mp hi with rfl | hi
+      · refine ⟨d * r, ?_⟩
+        rw [hrq, map_mul, map_mul, mul_assoc, mul_div_cancel₀ _ hq]
+      · obtain ⟨p, hp⟩ := hs i hi
+        exact ⟨p * q, by rw [map_mul, map_mul, mul_right_comm, hp]⟩
+
+theorem linearIndependent_ψ (ht : t ∈ F₀) (htr : Transcendental ℚ t) {ι : Type*} [Finite ι]
+    {v : ι → E₀ F₀ t ht} (hv : LinearIndependent (K₀ t) v) :
+    LinearIndependent (K L t) fun i => ψ L ht (v i) := by
+  classical
+  let := Fintype.ofFinite ι
+  have hw := linearIndependent_coeffEmb L (linearIndependent_pow_mul ht htr hv)
+  rw [linearIndependent_iff'] at hw ⊢
+  intro s g hg i hi
+  obtain ⟨d, hd, hs⟩ := exists_common_denom L Finset.univ g
+  choose! P hP using hs
+  have hg' : ∑ j ∈ s, aeval (coeffEmb L t) (P j) * coeffEmb L ((v j : E₀ F₀ t ht) : LaurentSeries ℚ)
+    = 0 :=
+    by
+    have := congrArg (fun z : E L F₀ t ht => aeval (coeffEmb L t) d * (z : LaurentSeries L)) hg
+    beta_reduce at this
+    rw [ZeroMemClass.coe_zero, mul_zero, AddSubmonoidClass.coe_finsetSum, Finset.mul_sum] at this
+    rw [← this]
+    refine Finset.sum_congr rfl fun j _ => ?_
+    rw [IntermediateField.coe_smul]
+    change _ = aeval (coeffEmb L t) d * (((g j : K L t) : LaurentSeries L) * ((ψ L ht (v j) : E L F₀
+      t ht) : LaurentSeries L))
+    rw [← mul_assoc, hP j (Finset.mem_univ j)]
+    rfl
+  let n : ℕ := (s.sup fun j => (P j).natDegree) + 1
+  have hdeg : ∀ j ∈ s, (P j).natDegree < n := fun j hj =>
+    Nat.lt_succ_of_le (Finset.le_sup (f := fun j => (P j).natDegree) hj)
+  have hrel : ∑ p ∈ (Finset.range n) ×ˢ s,
+      (P p.2).coeff p.1 • coeffEmb L (t ^ p.1 * ((v p.2 : E₀ F₀ t ht) : LaurentSeries ℚ)) = 0 := by
+    rw [Finset.sum_product_right, ← hg']
+    refine Finset.sum_congr rfl fun j hj => ?_
+    rw [aeval_eq_sum_range' (hdeg j hj), Finset.sum_mul]
+    refine Finset.sum_congr rfl fun k _ => ?_
+    rw [← HahnSeries.single_zero_mul_eq_smul, map_mul, map_pow, Algebra.smul_def,
+      algebraMap_laurentSeries_eq_single, mul_assoc]
+  have hcoeff : ∀ j ∈ s, ∀ k ∈ Finset.range n, (P j).coeff k = 0 := fun j hj k hk =>
+    hw ((Finset.range n) ×ˢ s) (fun p => (P p.2).coeff p.1) hrel (k, j) (Finset.mem_product.mpr ⟨hk,
+      hj⟩)
+  have hP0 : P i = 0 := by
+    ext k
+    by_cases hk : k < n
+    · rw [hcoeff i hi k (Finset.mem_range.mpr hk), coeff_zero]
+    · rw [coeff_zero, coeff_eq_zero_of_natDegree_lt (lt_of_lt_of_le (hdeg i hi) (not_lt.mp hk))]
+  have h3 : aeval (coeffEmb L t) d * (g i : LaurentSeries L) = 0 := by
+    rw [hP i (Finset.mem_univ i), hP0, map_zero]
+  exact Subtype.ext ((mul_eq_zero.mp h3).resolve_left hd)
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+theorem relfinrank_eq (ht : t ∈ F₀) (htr : Transcendental ℚ t) :
+    relfinrank (K L t) (laurentBaseChange L F₀) = relfinrank (K₀ t) F₀ := by
+  classical
+  rw [relfinrank_eq_finrank_of_le (K_le L ht), relfinrank_eq_finrank_of_le (K₀_le ht)]
+  change Module.finrank (K L t) (E L F₀ t ht) = Module.finrank (K₀ t) (E₀ F₀ t ht)
+  by_cases hfin : FiniteDimensional (K₀ t) (E₀ F₀ t ht)
+  · obtain ⟨hfinE, hle⟩ := finite_and_finrank_le L ht
+    have := hfinE
+    refine le_antisymm hle ?_
+    let b := Module.Free.chooseBasis (K₀ t) (E₀ F₀ t ht)
+    have hind := linearIndependent_ψ L ht htr b.linearIndependent
+    rw [Module.finrank_eq_card_chooseBasisIndex]
+    exact hind.fintype_card_le_finrank
+  · rw [Module.finrank_of_not_finite hfin]
+    by_contra hE
+    have hE' : 0 < Module.finrank (K L t) (E L F₀ t ht) := Nat.pos_of_ne_zero hE
+    have : Module.Finite (K L t) (E L F₀ t ht) := Module.finite_of_finrank_pos hE'
+    apply hfin
+    have hrank : Module.rank (K₀ t) (E₀ F₀ t ht) ≤ Module.finrank (K L t) (E L F₀ t ht) := by
+      refine _root_.rank_le fun s hs => ?_
+      have hind := linearIndependent_ψ L ht htr hs
+      simpa using hind.fintype_card_le_finrank
+    exact Module.rank_lt_aleph0_iff.mp (lt_of_le_of_lt hrank (Cardinal.natCast_lt_aleph0))
+
+end TransportDev
+
+namespace TransportRows
+
+open TransportDev
+
+theorem relfinrank_laurentBaseChange (L : Type*) [Field L] [Algebra ℚ L]
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (t : LaurentSeries ℚ) (ht : t ∈ F₀)
+    (htr : Transcendental ℚ t) :
+    IntermediateField.relfinrank (IntermediateField.adjoin L ({coeffEmb L t} : Set (LaurentSeries
+      L))) (laurentBaseChange L F₀)
+      = IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({t} : Set (LaurentSeries ℚ))) F₀
+        :=
+  relfinrank_eq L ht htr
+
+theorem relfinrank_laurentBaseChange_full (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    IntermediateField.relfinrank (IntermediateField.adjoin L ({coeffEmb L jq} : Set (LaurentSeries
+      L)))
+        (laurentBaseChange L (modularFunctionFieldFull N))
+      = IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+        (modularFunctionFieldFull N) :=
+  relfinrank_eq L (jq_mem_full N) transcendental_jq
+
+theorem relfinrank_restrictScalars {K X : Type*} [Field K] [Field X] [Algebra K X]
+    (A : IntermediateField K X) (T : IntermediateField A X) :
+    IntermediateField.relfinrank A (T.restrictScalars K) = Module.finrank A T := by
+  have hle : A ≤ T.restrictScalars K := fun x hx => T.algebraMap_mem ⟨x, hx⟩
+  rw [relfinrank_eq_finrank_of_le hle]
+  have : extendScalars hle = T := restrictScalars_injective K (extendScalars_restrictScalars hle)
+  rw [this]
+
+theorem relfinrank_full_prime (ℓ : ℕ) [Fact ℓ.Prime] :
+    IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (modularFunctionFieldFull ℓ)
+      = ℓ + 1 := by
+  rw [← relfinrank_laurentBaseChange_full (AlgebraicClosure ℚ) ℓ, ←
+    finrank_adjoin_jqNModC_eq_of_prime ℓ]
+  have hbar : laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull ℓ) = _ :=
+    modularFunctionFieldBar_eq_restrictScalars ℓ
+  rw [hbar, coeffEmb_jq]
+  exact relfinrank_restrictScalars _ _
+
+end TransportRows
+
+end
+
+open ModularCurve in
+theorem solution (L : Type*) [Field L] [Algebra ℚ L] (F₀ : IntermediateField ℚ (LaurentSeries ℚ))
+    (t : LaurentSeries ℚ) (ht : t ∈ F₀) (htr : Transcendental ℚ t) :
+    IntermediateField.relfinrank (IntermediateField.adjoin L ({coeffEmb L t} : Set (LaurentSeries
+      L))) (laurentBaseChange L F₀) = IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({t}
+      : Set (LaurentSeries ℚ))) F₀ :=
+  TransportRows.relfinrank_laurentBaseChange L F₀ t ht htr
+
+end S_ModularCurve_relfinrank_laurentBaseChange
+end P2MW
+export P2MW.S_ModularCurve_relfinrank_laurentBaseChange (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.relfinrank_laurentBaseChange (L : Type*) [Field L] [Algebra ℚ L]
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (t : LaurentSeries ℚ) (ht : t ∈ F₀)
+    (htr : Transcendental ℚ t) :
+    IntermediateField.relfinrank (IntermediateField.adjoin L ({coeffEmb L t} : Set (LaurentSeries
+      L))) (laurentBaseChange L F₀) = IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({t}
+      : Set (LaurentSeries ℚ))) F₀ :=
+  solution L F₀ t ht htr
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_relfinrank_laurentBaseChange_modularFunctionFieldFull.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_relfinrank_laurentBaseChange_modularFunctionFieldFull.lean
new file mode 100644
index 0000000000..93b68f8c16
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_relfinrank_laurentBaseChange_modularFunctionFieldFull.lean
@@ -0,0 +1,452 @@
+/-
+Based on Prove2Me node ModularCurve.relfinrank_laurentBaseChange_modularFunctionFieldFull
+(f5160626-abe0-5536-b5c5-7d203939f95e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 95f36049-ece1-5d12-9930-f865510f26d4
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlace
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import Mathlib.FieldTheory.Relrank
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GeometricBaseChange
+import Mathlib.RingTheory.AlgebraTower
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Algebra
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqNModC_eq_of_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularFunctionFieldBar_eq_restrictScalars
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Relative degree over the j-line under base change of constants
+
+Theorem statement: `ModularCurve.relfinrank_laurentBaseChange_modularFunctionFieldFull`
+(`f5160626-abe0-5536-b5c5-7d203939f95e`), by Claude, 2026-09-05.
+
+Proof: submission `95f36049-ece1-5d12-9930-f865510f26d4`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbb{Q}$-algebra structure and let $N$ be a nonzero natural
+number. Write $jq \in \mathrm{LaurentSeries}\,\mathbb{Q}$ for the series $\mathrm{single}(-1,1)\cdot
+\mathrm{ofPowerSeries}(jNumQ)$, where $jNumQ$ is the power series $jNum$ with its integer
+coefficients mapped into $\mathbb{Q}$, and let $\mathrm{coeffEmb}\,L \colon
+\mathrm{LaurentSeries}\,\mathbb{Q} \to \mathrm{LaurentSeries}\,L$ be the ring homomorphism applying
+$\mathbb{Q} \to L$ to each coefficient. The field $\mathrm{modularFunctionFieldFull}\,N$ is the
+intermediate field of $\mathrm{LaurentSeries}\,\mathbb{Q}$ generated over $\mathbb{Q}$ by the set of
+all $\mathrm{qExpand}\,\mathbb{Q}\,d\,jq$ with $d$ a nonzero divisor of $N$, and
+$\mathrm{laurentBaseChange}\,L$ applied to it is the intermediate field of
+$\mathrm{LaurentSeries}\,L$ generated over $L$ by the image of that field under
+$\mathrm{coeffEmb}\,L$. The assertion is an equality of relative degrees in the sense of
+`IntermediateField.relfinrank`: the degree of
+$\mathrm{laurentBaseChange}\,L\,(\mathrm{modularFunctionFieldFull}\,N)$ relative to
+$L(\mathrm{coeffEmb}\,L\,jq)$ equals the degree of $\mathrm{modularFunctionFieldFull}\,N$ relative
+to $\mathbb{Q}(jq)$. In each case the first field is contained in the second, so both sides are
+ordinary field degrees. No value is asserted for the common number, and no condition (such as
+squarefreeness) is imposed on $N$.
+
+This is the constant-field-extension invariance of the degree of the full modular function field of
+level $N$ over the $j$-line: base change of the field of constants from $\mathbb{Q}$ to any field of
+characteristic zero leaves that relative degree unchanged. It is combined with the evaluation of the
+degree over $\mathbb{Q}$ to compute, for a prime $\ell$, the degree of the modular function field
+over an algebraically closed constant field, and it feeds the results on specialisation of places of
+modular function fields.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_relfinrank_laurentBaseChange_modularFunctionFieldFull.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_relfinrank_laurentBaseChange_modularFunctionFieldFull
+
+noncomputable section
+
+open ModularCurve IntermediateField Polynomial
+
+namespace TransportDev
+
+variable (L : Type*) [Field L] [Algebra ℚ L]
+variable (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (t : LaurentSeries ℚ)
+
+abbrev K₀ :
+    IntermediateField ℚ (LaurentSeries ℚ) := IntermediateField.adjoin ℚ ({t} : Set (LaurentSeries
+      ℚ))
+
+abbrev K : IntermediateField L (LaurentSeries L) :=
+  IntermediateField.adjoin L ({coeffEmb L t} : Set (LaurentSeries L))
+
+variable {F₀ t}
+
+theorem K₀_le (ht : t ∈ F₀) : K₀ t ≤ F₀ :=
+  adjoin_le_iff.mpr (Set.singleton_subset_iff.mpr ht)
+
+theorem K_le (ht : t ∈ F₀) : K L t ≤ laurentBaseChange L F₀ :=
+  adjoin_le_iff.mpr (Set.singleton_subset_iff.mpr (coeffEmb_mem_laurentBaseChange L ht))
+
+theorem coeffEmb_aeval (r : ℚ[X]) :
+    coeffEmb L (aeval t r) = aeval (coeffEmb L t) (r.map (algebraMap ℚ L)) := by
+  simp only [aeval_def, eval₂_map, hom_eval₂]
+  congr 1
+  exact Subsingleton.elim _ _
+
+theorem coeffEmb_mem_K {x : LaurentSeries ℚ} (hx : x ∈ K₀ t) : coeffEmb L x ∈ K L t := by
+  rw [mem_adjoin_simple_iff] at hx ⊢
+  obtain ⟨r, s, rfl⟩ := hx
+  exact ⟨r.map (algebraMap ℚ L), s.map (algebraMap ℚ L), by rw [map_div₀, coeffEmb_aeval,
+    coeffEmb_aeval]⟩
+
+variable (F₀ t) in
+abbrev E₀ (ht : t ∈ F₀) : IntermediateField (K₀ t) (LaurentSeries ℚ) := extendScalars (K₀_le ht)
+
+variable (F₀ t) in
+abbrev E (ht : t ∈ F₀) : IntermediateField (K L t) (LaurentSeries L) := extendScalars (K_le L ht)
+
+def φ : K₀ t →+* K L t := (coeffEmb L).restrict _ _ fun _ hx => coeffEmb_mem_K L hx
+
+def ψ (ht : t ∈ F₀) : E₀ F₀ t ht →+* E L F₀ t ht :=
+  (coeffEmb L).restrict _ _ fun _ hx => coeffEmb_mem_laurentBaseChange L ((mem_extendScalars _).mp
+    hx)
+
+theorem coe_φ (x : K₀ t) : (φ L x : LaurentSeries L) = coeffEmb L x := rfl
+theorem coe_ψ (ht : t ∈ F₀) (x : E₀ F₀ t ht) : (ψ L ht x : LaurentSeries L) = coeffEmb L x := rfl
+
+theorem ψ_compat (ht : t ∈ F₀) :
+    (algebraMap (K L t) (E L F₀ t ht)).comp (φ L) = (ψ L ht).comp (algebraMap (K₀ t) (E₀ F₀ t ht))
+      := by
+  apply RingHom.ext
+  intro x
+  apply Subtype.ext
+  rfl
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+theorem isAlgebraic_coeffEmb (ht : t ∈ F₀) [FiniteDimensional (K₀ t) (E₀ F₀ t ht)]
+    (f : LaurentSeries ℚ) (hf : f ∈ F₀) :
+    IsAlgebraic (K L t) (coeffEmb L f) := by
+  have h1 : IsIntegral (K₀ t) (⟨f, (mem_extendScalars _).mpr hf⟩ : E₀ F₀ t ht) :=
+    Algebra.IsIntegral.isIntegral _
+  have h2 := h1.map_of_comp_eq (φ L) (ψ L ht) (ψ_compat L ht)
+  have h3 : IsIntegral (K L t) ((ψ L ht ⟨f, (mem_extendScalars _).mpr hf⟩ : E L F₀ t ht) :
+    LaurentSeries L) :=
+    h2.algebraMap
+  exact h3.isAlgebraic
+
+theorem laurentBaseChange_eq_adjoin :
+    laurentBaseChange L F₀ = IntermediateField.adjoin L (coeffEmb L '' (F₀ : Set (LaurentSeries ℚ)))
+      := rfl
+
+theorem restrictScalars_adjoin_K (ht : t ∈ F₀) :
+    (IntermediateField.adjoin (K L t) (coeffEmb L '' (F₀ : Set (LaurentSeries ℚ)))).restrictScalars
+      L
+      = laurentBaseChange L F₀ := by
+  have h1 : IntermediateField.adjoin (K L t) (coeffEmb L '' (F₀ : Set (LaurentSeries ℚ))) ≤ E L F₀ t
+    ht :=
+    adjoin_le_iff.mpr (subset_adjoin L _)
+  have h2 : laurentBaseChange L F₀ ≤
+      (IntermediateField.adjoin (K L t) (coeffEmb L '' (F₀ : Set (LaurentSeries
+        ℚ)))).restrictScalars L :=
+    adjoin_le_iff.mpr (subset_adjoin (K L t) _)
+  exact le_antisymm (fun x hx => h1 hx) h2
+
+theorem closure_image_eq :
+    (Submonoid.closure (coeffEmb L '' (F₀ : Set (LaurentSeries ℚ))) : Set (LaurentSeries L))
+      = coeffEmb L '' (F₀ : Set (LaurentSeries ℚ)) := by
+  have : (coeffEmb L '' (F₀ : Set (LaurentSeries ℚ))) = ((F₀.toSubfield.map (coeffEmb
+    L)).toSubmonoid : Set (LaurentSeries L)) :=
+    by
+    ext x; simp
+  rw [this, Submonoid.closure_eq]
+
+section Finite
+
+variable (ht : t ∈ F₀) [FiniteDimensional (K₀ t) (E₀ F₀ t ht)]
+include ht
+
+theorem mem_span_image (x : LaurentSeries L) (hx : x ∈ laurentBaseChange L F₀) :
+    x ∈ Submodule.span (K L t) (coeffEmb L '' (F₀ : Set (LaurentSeries ℚ))) := by
+  have hx' : x ∈ IntermediateField.adjoin (K L t) (coeffEmb L '' (F₀ : Set (LaurentSeries ℚ))) := by
+    rw [← mem_restrictScalars L, restrictScalars_adjoin_K L ht]; exact hx
+  have halg : ∀ y ∈ coeffEmb L '' (F₀ : Set (LaurentSeries ℚ)), IsAlgebraic (K L t) y := by
+    rintro _ ⟨f, hf, rfl⟩; exact isAlgebraic_coeffEmb L ht f hf
+  rw [← mem_toSubalgebra, adjoin_toSubalgebra_of_isAlgebraic halg] at hx'
+  have hx'' : x ∈ Subalgebra.toSubmodule (Algebra.adjoin (K L t) (coeffEmb L '' (F₀ : Set
+    (LaurentSeries ℚ)))) :=
+    hx'
+  rw [Algebra.adjoin_eq_span] at hx''
+  rwa [closure_image_eq] at hx''
+
+theorem mem_span_range {ι : Type*} (b : Module.Basis ι (K₀ t) (E₀ F₀ t ht)) (x : LaurentSeries L)
+    (hx : x ∈ laurentBaseChange L F₀) :
+    x ∈ Submodule.span (K L t) (Set.range fun i => ((ψ L ht (b i) : E L F₀ t ht) : LaurentSeries L))
+      := by
+  refine Submodule.span_le.mpr ?_ (mem_span_image L ht x hx)
+  rintro _ ⟨f, hf, rfl⟩
+  have hrepr := b.linearCombination_repr ⟨f, (mem_extendScalars _).mpr hf⟩
+  rw [Finsupp.linearCombination_apply, Finsupp.sum] at hrepr
+  have : coeffEmb L f = ∑ i ∈ (b.repr ⟨f, (mem_extendScalars _).mpr hf⟩).support,
+      (φ L (b.repr ⟨f, (mem_extendScalars _).mpr hf⟩ i)) • ((ψ L ht (b i) : E L F₀ t ht) :
+        LaurentSeries L) := by
+    have h2 := congrArg (fun z : E₀ F₀ t ht => coeffEmb L (z : LaurentSeries ℚ)) hrepr
+    dsimp only at h2
+    rw [← h2, AddSubmonoidClass.coe_finsetSum, map_sum]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [IntermediateField.coe_smul, Algebra.smul_def, map_mul, Algebra.smul_def]
+    rfl
+  rw [this]
+  exact Submodule.sum_mem _ fun i _ => Submodule.smul_mem _ _ (Submodule.subset_span ⟨i, rfl⟩)
+
+theorem finite_and_finrank_le :
+    Module.Finite (K L t) (E L F₀ t ht) ∧
+      Module.finrank (K L t) (E L F₀ t ht) ≤ Module.finrank (K₀ t) (E₀ F₀ t ht) := by
+  classical
+  let b := Module.Free.chooseBasis (K₀ t) (E₀ F₀ t ht)
+  let y : Module.Free.ChooseBasisIndex (K₀ t) (E₀ F₀ t ht) → E L F₀ t ht := fun i => ψ L ht (b i)
+  have htop : ∀ x : E L F₀ t ht, x ∈ Submodule.span (K L t) (Set.range y) := fun x => by
+    have hx := mem_span_range L ht b (x : LaurentSeries L) ((mem_extendScalars _).mp x.2)
+    have hr : (Set.range fun i => ((ψ L ht (b i) : E L F₀ t ht) : LaurentSeries L))
+        = (E L F₀ t ht).val.toLinearMap '' (Set.range y) := by
+      rw [← Set.range_comp]; rfl
+    rw [hr, Submodule.span_image] at hx
+    obtain ⟨z, hz, hzx⟩ := Submodule.mem_map.mp hx
+    have hzx' : z = x := Subtype.ext hzx
+    exact hzx' ▸ hz
+  have hspan : Submodule.span (K L t) (Set.range y) = ⊤ := eq_top_iff.mpr fun x _ => htop x
+  have hfin : Module.Finite (K L t) (E L F₀ t ht) :=
+    ⟨by rw [← hspan]; exact Submodule.fg_span (Set.finite_range y)⟩
+  refine ⟨hfin, ?_⟩
+  conv_rhs => rw [Module.finrank_eq_card_chooseBasisIndex]
+  conv_lhs => rw [← finrank_top, ← hspan]
+  calc Module.finrank (K L t) (Submodule.span (K L t) (Set.range y))
+        ≤ (Set.range y).toFinset.card := finrank_span_le_card _
+    _ ≤ Fintype.card (Module.Free.ChooseBasisIndex (K₀ t) (E₀ F₀ t ht)) := by
+        rw [Set.toFinset_range]; exact Finset.card_image_le.trans (by rw [Finset.card_univ])
+
+end Finite
+
+theorem linearIndependent_pow_mul (ht : t ∈ F₀) (htr : Transcendental ℚ t) {ι : Type*}
+    {v : ι → E₀ F₀ t ht} (hv : LinearIndependent (K₀ t) v) :
+    LinearIndependent ℚ fun p : ℕ × ι => t ^ p.1 * ((v p.2 : E₀ F₀ t ht) : LaurentSeries ℚ) := by
+  classical
+  rw [linearIndependent_iff'] at hv ⊢
+  intro S μ hS p hp
+  let c : ι → LaurentSeries ℚ := fun i =>
+    ∑ q ∈ S, if q.2 = i then algebraMap ℚ (LaurentSeries ℚ) (μ q) * t ^ q.1 else 0
+  have hcmem : ∀ i, c i ∈ K₀ t := fun i => by
+    refine sum_mem fun q _ => ?_
+    split_ifs
+    · exact mul_mem ((K₀ t).algebraMap_mem _) (pow_mem (mem_adjoin_simple_self ℚ t) _)
+    · exact zero_mem _
+  have hrel : ∑ i ∈ S.image Prod.snd, (⟨c i, hcmem i⟩ : K₀ t) • v i = 0 := by
+    apply Subtype.ext
+    rw [AddSubmonoidClass.coe_finsetSum, ZeroMemClass.coe_zero]
+    have h1 : ∀ i, ((((⟨c i, hcmem i⟩ : K₀ t) • v i : E₀ F₀ t ht)) : LaurentSeries ℚ)
+        = ∑ q ∈ S, if q.2 = i then
+            algebraMap ℚ (LaurentSeries ℚ) (μ q) * t ^ q.1 * ((v i : E₀ F₀ t ht) : LaurentSeries ℚ)
+              else 0 := by
+      intro i
+      change c i * ((v i : E₀ F₀ t ht) : LaurentSeries ℚ) = _
+      rw [Finset.sum_mul]
+      exact Finset.sum_congr rfl fun q _ => by by_cases h : q.2 = i <;> simp [h]
+    simp_rw [h1]
+    rw [Finset.sum_comm]
+    refine Eq.trans (Finset.sum_congr rfl fun q hq => ?_) hS
+    rw [Finset.sum_ite_eq, ite_eq_left (Finset.mem_image_of_mem Prod.snd hq), ←
+      HahnSeries.single_zero_mul_eq_smul,
+      algebraMap_laurentSeries_eq_single, mul_assoc]
+  have hci : (⟨c p.2, hcmem p.2⟩ : K₀ t) = 0 :=
+    hv _ _ hrel p.2 (Finset.mem_image_of_mem Prod.snd hp)
+  have hc0 : c p.2 = 0 := congrArg Subtype.val hci
+  have hQ : aeval t (∑ q ∈ S, if q.2 = p.2 then monomial q.1 (μ q) else 0) = 0 := by
+    rw [map_sum, ← hc0]
+    exact Finset.sum_congr rfl fun q _ => by by_cases h : q.2 = p.2 <;> simp [h, aeval_monomial]
+  have hQ0 : (∑ q ∈ S, if q.2 = p.2 then monomial q.1 (μ q) else 0 : ℚ[X]) = 0 :=
+    transcendental_iff_injective.mp htr (by rw [map_zero]; exact hQ)
+  have hco := congrArg (fun P : ℚ[X] => P.coeff p.1) hQ0
+  rw [finsetSum_coeff, coeff_zero, Finset.sum_eq_single p] at hco
+  · simpa using hco
+  · intro q _ hqp
+    by_cases h2 : q.2 = p.2
+    · rw [ite_eq_left h2, coeff_monomial, ite_eq_right]
+      intro h1
+      exact hqp (Prod.ext h1 h2)
+    · rw [ite_eq_right h2, coeff_zero]
+  · intro hpS
+    exact absurd hp hpS
+
+theorem exists_common_denom {ι : Type*} (s : Finset ι) (g : ι → K L t) :
+    ∃ d : L[X], aeval (coeffEmb L t) d ≠ 0 ∧
+      ∀ i ∈ s, ∃ p : L[X], aeval (coeffEmb L t) d * (g i : LaurentSeries L) = aeval (coeffEmb L t) p
+        := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => exact ⟨1, by simp, by simp⟩
+  | insert a s has ih =>
+    obtain ⟨d, hd, hs⟩ := ih
+    obtain ⟨r, q, hrq⟩ := (mem_adjoin_simple_iff L _).mp (g a).2
+    by_cases hq : aeval (coeffEmb L t) q = 0
+    · refine ⟨d, hd, ?_⟩
+      intro i hi
+      rcases Finset.mem_insert.mp hi with rfl | hi
+      · exact ⟨0, by rw [hrq, hq, div_zero, mul_zero, map_zero]⟩
+      · exact hs i hi
+    · refine ⟨d * q, by rw [map_mul]; exact mul_ne_zero hd hq, ?_⟩
+      intro i hi
+      rcases Finset.mem_insert.mp hi with rfl | hi
+      · refine ⟨d * r, ?_⟩
+        rw [hrq, map_mul, map_mul, mul_assoc, mul_div_cancel₀ _ hq]
+      · obtain ⟨p, hp⟩ := hs i hi
+        exact ⟨p * q, by rw [map_mul, map_mul, mul_right_comm, hp]⟩
+
+theorem linearIndependent_ψ (ht : t ∈ F₀) (htr : Transcendental ℚ t) {ι : Type*} [Finite ι]
+    {v : ι → E₀ F₀ t ht} (hv : LinearIndependent (K₀ t) v) :
+    LinearIndependent (K L t) fun i => ψ L ht (v i) := by
+  classical
+  let := Fintype.ofFinite ι
+  have hw := linearIndependent_coeffEmb L (linearIndependent_pow_mul ht htr hv)
+  rw [linearIndependent_iff'] at hw ⊢
+  intro s g hg i hi
+  obtain ⟨d, hd, hs⟩ := exists_common_denom L Finset.univ g
+  choose! P hP using hs
+  have hg' : ∑ j ∈ s, aeval (coeffEmb L t) (P j) * coeffEmb L ((v j : E₀ F₀ t ht) : LaurentSeries ℚ)
+    = 0 :=
+    by
+    have := congrArg (fun z : E L F₀ t ht => aeval (coeffEmb L t) d * (z : LaurentSeries L)) hg
+    rw [ZeroMemClass.coe_zero, mul_zero, AddSubmonoidClass.coe_finsetSum, Finset.mul_sum] at this
+    rw [← this]
+    refine Finset.sum_congr rfl fun j _ => ?_
+    rw [IntermediateField.coe_smul]
+    change _ = aeval (coeffEmb L t) d * (((g j : K L t) : LaurentSeries L) * ((ψ L ht (v j) : E L F₀
+      t ht) : LaurentSeries L))
+    rw [← mul_assoc, hP j (Finset.mem_univ j)]
+    rfl
+  let n : ℕ := (s.sup fun j => (P j).natDegree) + 1
+  have hdeg : ∀ j ∈ s, (P j).natDegree < n := fun j hj =>
+    Nat.lt_succ_of_le (Finset.le_sup (f := fun j => (P j).natDegree) hj)
+  have hrel : ∑ p ∈ (Finset.range n) ×ˢ s,
+      (P p.2).coeff p.1 • coeffEmb L (t ^ p.1 * ((v p.2 : E₀ F₀ t ht) : LaurentSeries ℚ)) = 0 := by
+    rw [Finset.sum_product_right, ← hg']
+    refine Finset.sum_congr rfl fun j hj => ?_
+    rw [aeval_eq_sum_range' (hdeg j hj), Finset.sum_mul]
+    refine Finset.sum_congr rfl fun k _ => ?_
+    rw [← HahnSeries.single_zero_mul_eq_smul, map_mul, map_pow, Algebra.smul_def,
+      algebraMap_laurentSeries_eq_single, mul_assoc]
+  have hcoeff : ∀ j ∈ s, ∀ k ∈ Finset.range n, (P j).coeff k = 0 := fun j hj k hk =>
+    hw ((Finset.range n) ×ˢ s) (fun p => (P p.2).coeff p.1) hrel (k, j) (Finset.mem_product.mpr ⟨hk,
+      hj⟩)
+  have hP0 : P i = 0 := by
+    ext k
+    by_cases hk : k < n
+    · rw [hcoeff i hi k (Finset.mem_range.mpr hk), coeff_zero]
+    · rw [coeff_zero, coeff_eq_zero_of_natDegree_lt (lt_of_lt_of_le (hdeg i hi) (not_lt.mp hk))]
+  have h3 : aeval (coeffEmb L t) d * (g i : LaurentSeries L) = 0 := by
+    rw [hP i (Finset.mem_univ i), hP0, map_zero]
+  exact Subtype.ext ((mul_eq_zero.mp h3).resolve_left hd)
+
+set_option synthInstance.maxHeartbeats 40000 in -- this is needed (DL)
+theorem relfinrank_eq (ht : t ∈ F₀) (htr : Transcendental ℚ t) :
+    relfinrank (K L t) (laurentBaseChange L F₀) = relfinrank (K₀ t) F₀ := by
+  classical
+  rw [relfinrank_eq_finrank_of_le (K_le L ht), relfinrank_eq_finrank_of_le (K₀_le ht)]
+  change Module.finrank (K L t) (E L F₀ t ht) = Module.finrank (K₀ t) (E₀ F₀ t ht)
+  by_cases hfin : FiniteDimensional (K₀ t) (E₀ F₀ t ht)
+  · obtain ⟨hfinE, hle⟩ := finite_and_finrank_le L ht
+    have := hfinE
+    refine le_antisymm hle ?_
+    let b := Module.Free.chooseBasis (K₀ t) (E₀ F₀ t ht)
+    have hind := linearIndependent_ψ L ht htr b.linearIndependent
+    rw [Module.finrank_eq_card_chooseBasisIndex]
+    exact hind.fintype_card_le_finrank
+  · rw [Module.finrank_of_not_finite hfin]
+    by_contra hE
+    have hE' : 0 < Module.finrank (K L t) (E L F₀ t ht) := Nat.pos_of_ne_zero hE
+    have : Module.Finite (K L t) (E L F₀ t ht) := Module.finite_of_finrank_pos hE'
+    apply hfin
+    have hrank : Module.rank (K₀ t) (E₀ F₀ t ht) ≤ Module.finrank (K L t) (E L F₀ t ht) := by
+      refine _root_.rank_le fun s hs => ?_
+      have hind := linearIndependent_ψ L ht htr hs
+      simpa using hind.fintype_card_le_finrank
+    exact Module.rank_lt_aleph0_iff.mp (lt_of_le_of_lt hrank (Cardinal.natCast_lt_aleph0))
+
+end TransportDev
+
+namespace TransportRows
+
+open TransportDev
+
+theorem relfinrank_laurentBaseChange (L : Type*) [Field L] [Algebra ℚ L]
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (t : LaurentSeries ℚ) (ht : t ∈ F₀)
+    (htr : Transcendental ℚ t) :
+    IntermediateField.relfinrank (IntermediateField.adjoin L ({coeffEmb L t} : Set (LaurentSeries
+      L))) (laurentBaseChange L F₀)
+      = IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({t} : Set (LaurentSeries ℚ))) F₀
+        :=
+  relfinrank_eq L ht htr
+
+theorem relfinrank_laurentBaseChange_full (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    IntermediateField.relfinrank (IntermediateField.adjoin L ({coeffEmb L jq} : Set (LaurentSeries
+      L)))
+        (laurentBaseChange L (modularFunctionFieldFull N))
+      = IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+        (modularFunctionFieldFull N) :=
+  relfinrank_eq L (jq_mem_full N) transcendental_jq
+
+theorem relfinrank_restrictScalars {K X : Type*} [Field K] [Field X] [Algebra K X]
+    (A : IntermediateField K X) (T : IntermediateField A X) :
+    IntermediateField.relfinrank A (T.restrictScalars K) = Module.finrank A T := by
+  have hle : A ≤ T.restrictScalars K := fun x hx => T.algebraMap_mem ⟨x, hx⟩
+  rw [relfinrank_eq_finrank_of_le hle]
+  have : extendScalars hle = T := restrictScalars_injective K (extendScalars_restrictScalars hle)
+  rw [this]
+
+theorem relfinrank_full_prime (ℓ : ℕ) [Fact ℓ.Prime] :
+    IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (modularFunctionFieldFull ℓ)
+      = ℓ + 1 := by
+  rw [← relfinrank_laurentBaseChange_full (AlgebraicClosure ℚ) ℓ, ←
+    finrank_adjoin_jqNModC_eq_of_prime ℓ]
+  have hbar : laurentBaseChange (AlgebraicClosure ℚ) (modularFunctionFieldFull ℓ) = _ :=
+    modularFunctionFieldBar_eq_restrictScalars ℓ
+  rw [hbar, coeffEmb_jq]
+  exact relfinrank_restrictScalars _ _
+
+end TransportRows
+
+end
+
+open ModularCurve in
+theorem solution (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    IntermediateField.relfinrank (IntermediateField.adjoin L ({coeffEmb L jq} : Set (LaurentSeries
+      L))) (laurentBaseChange L (modularFunctionFieldFull N)) = IntermediateField.relfinrank
+      (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (modularFunctionFieldFull N) :=
+  TransportRows.relfinrank_laurentBaseChange_full L N
+
+end S_ModularCurve_relfinrank_laurentBaseChange_modularFunctionFieldFull
+end P2MW
+export P2MW.S_ModularCurve_relfinrank_laurentBaseChange_modularFunctionFieldFull (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.relfinrank_laurentBaseChange_modularFunctionFieldFull (L : Type*) [Field L]
+    [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    IntermediateField.relfinrank (IntermediateField.adjoin L ({coeffEmb L jq} : Set (LaurentSeries
+      L))) (laurentBaseChange L (modularFunctionFieldFull N)) = IntermediateField.relfinrank
+      (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) (modularFunctionFieldFull N) :=
+  solution L N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_relfinrank_modularFunctionField.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_relfinrank_modularFunctionField.lean
new file mode 100644
index 0000000000..bcab252ece
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_relfinrank_modularFunctionField.lean
@@ -0,0 +1,109 @@
+/-
+Based on Prove2Me node ModularCurve.relfinrank_modularFunctionField
+(19d6be68-bdd4-543c-8d62-a8b0a05dc95d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 006c8835-6c3e-5f21-afdf-108c317687c0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import Mathlib.FieldTheory.Relrank
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Relative degree of ℚ(j,j_N) over ℚ(j)
+
+Theorem statement: `ModularCurve.relfinrank_modularFunctionField`
+(`19d6be68-bdd4-543c-8d62-a8b0a05dc95d`), by Claude, 2026-09-05.
+
+Proof: submission `006c8835-6c3e-5f21-afdf-108c317687c0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $N \neq 0$. Work inside the field $\mathrm{LaurentSeries}\ \mathbb{Q}$ of
+formal Laurent series over $\mathbb{Q}$, and let $jq$ be the element $q^{-1}$ times the power series
+$jNumQ$ obtained from $jNum$ by mapping its integer coefficients into $\mathbb{Q}$, and let $jqN\ N$
+be the image $\mathrm{qExpand}\ \mathbb{Q}\ N\ (jq)$ of $jq$ under the ring homomorphism of Laurent
+(Hahn) series induced by multiplication by $N$ on exponents, i.e. the substitution $q \mapsto
+q^{N}$. Let $\mathrm{modularFunctionField}\ N$ be the intermediate field $\mathbb{Q}(jq,\
+\mathrm{qExpand}\ \mathbb{Q}\ N\ (jq))$ of $\mathrm{LaurentSeries}\ \mathbb{Q}$ generated over
+$\mathbb{Q}$ by these two series. The assertion is an equality of (possibly infinite)
+cardinal-valued degrees: the relative finrank, in the sense of `IntermediateField.relfinrank`, of
+the pair consisting of the intermediate field $\mathbb{Q}(jq)$ and $\mathrm{modularFunctionField}\
+N$ coincides with the $\mathbb{Q}(jq)$-module rank of the intermediate field of
+$\mathrm{LaurentSeries}\ \mathbb{Q}$ generated over $\mathbb{Q}(jq)$ by the single element $jqN\ N$.
+
+This is the bookkeeping identity that converts the relative degree of the two-generator modular
+function field $\mathbb{Q}(j(q), j(q^{N}))$ over $\mathbb{Q}(j(q))$ into the degree of a simple
+extension $\mathbb{Q}(j)(j_N)/\mathbb{Q}(j)$, the shape in which the degree $\psi(N)$ and the
+irreducibility of the modular polynomial $\Phi_N$ are established. It is used by the statements
+identifying this degree with $\psi(N)$, by the irreducibility statement for $\Phi_N$, and by the
+generation statement for the function field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_relfinrank_modularFunctionField.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_relfinrank_modularFunctionField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpand jq jqN modularFunctionField adjoin_jq_le"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+open IntermediateField in
+private theorem ModularCurve.relfinrank_modularFunctionField (N : ℕ) [NeZero N] :
+    IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (modularFunctionField N) =
+    Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+        ({jqN N} : Set (LaurentSeries ℚ))) := by
+  have key : extendScalars (ModularCurve.adjoin_jq_le N) =
+      adjoin (adjoin ℚ ({jq} : Set (LaurentSeries ℚ))) ({jqN N} : Set (LaurentSeries ℚ)) := by
+    have key0 := extendScalars_adjoin (ModularCurve.adjoin_jq_le N)
+    refine key0.trans (le_antisymm ?_ ?_)
+    · rw [adjoin_le_iff, Set.insert_subset_iff]
+      refine ⟨?_, Set.singleton_subset_iff.mpr (subset_adjoin _ _ rfl)⟩
+      exact (adjoin _ _).algebraMap_mem
+        (⟨jq, subset_adjoin ℚ _ rfl⟩ : ↥(adjoin ℚ ({jq} : Set (LaurentSeries ℚ))))
+    · exact adjoin.mono _ _ _ (Set.subset_insert _ _)
+  rw [relfinrank_eq_finrank_of_le (ModularCurve.adjoin_jq_le N), key]
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_relfinrank_modularFunctionField.ModularCurve in
+theorem solution (N : ℕ) [NeZero N] :
+    IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (modularFunctionField N) = Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set
+      (LaurentSeries ℚ))) (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set
+      (LaurentSeries ℚ))) ({jqN N} : Set (LaurentSeries ℚ))) :=
+  ModularCurve.relfinrank_modularFunctionField N
+
+end S_ModularCurve_relfinrank_modularFunctionField
+end P2MW
+export P2MW.S_ModularCurve_relfinrank_modularFunctionField (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.relfinrank_modularFunctionField (N : ℕ) [NeZero N] :
+    IntermediateField.relfinrank (IntermediateField.adjoin ℚ ({jq} : Set (LaurentSeries ℚ)))
+      (modularFunctionField N) = Module.finrank (IntermediateField.adjoin ℚ ({jq} : Set
+      (LaurentSeries ℚ))) (IntermediateField.adjoin (IntermediateField.adjoin ℚ ({jq} : Set
+      (LaurentSeries ℚ))) ({jqN N} : Set (LaurentSeries ℚ))) :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_restrict_eq_jLinePlace1728_iff.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_restrict_eq_jLinePlace1728_iff.lean
new file mode 100644
index 0000000000..4ccbe6d3c8
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_restrict_eq_jLinePlace1728_iff.lean
@@ -0,0 +1,135 @@
+/-
+Based on Prove2Me node ModularCurve.restrict_eq_jLinePlace1728_iff
+(8eaea59a-aa6c-59cc-a353-a8520358efe3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 86bcb0e4-7d67-520f-a740-73c223ee19d8
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JLinePlaces
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_eq_jLinePlace1728_iff_ord_jGen_sub_pos
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A place of the modular function field restricts to j=1728 iff ord_w(j-1728)>0
+
+Theorem statement: `ModularCurve.restrict_eq_jLinePlace1728_iff`
+(`8eaea59a-aa6c-59cc-a353-a8520358efe3`), by Claude, 2026-09-05.
+
+Proof: submission `86bcb0e4-7d67-520f-a740-73c223ee19d8`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N \ge 1$ and work inside the Laurent series field $\mathrm{LaurentSeries}\,\mathbb{Q}$, with
+[`ModularCurve.jq`](def/ModularCurve_X0.html#L157) the $q$-expansion of the $j$-invariant and
+[`ModularCurve.modularFunctionField N`](def/ModularCurve_X0.html#L250) the intermediate field
+$\mathbb{Q}(\mathtt{jq}, \mathtt{qExpand}\ N\ \mathtt{jq})$ generated over $\mathbb{Q}$ by `jq` and
+by its image under the $N$-fold rescaling of the exponent; it is an algebra over the subfield
+$\mathbb{Q}\langle \mathtt{jq}\rangle$ via the inclusion
+[`ModularCurve.jAdjoinRingHom`](def/ModularCurve_RouteBCoordRing.html#L14). Assume this extension is
+integral, and let $w$ be a place of `modularFunctionField N` over $\mathbb{Q}$, i.e. a valuation
+subring containing the image of $\mathbb{Q}$, distinct from the whole field and a principal ideal
+ring. Its restriction $w|_{\mathbb{Q}\langle \mathtt{jq}\rangle}$ is the pullback valuation subring
+along the inclusion. The assertion is that this restriction equals
+[`ModularCurve.jLinePlace1728`](def/ModularCurve_JLinePlaces.html#L50) — the place of
+$\mathbb{Q}\langle \mathtt{jq}\rangle$ obtained by transporting, along the isomorphism
+$\mathrm{RatFunc}\,\mathbb{Q} \cong \mathbb{Q}\langle \mathtt{jq}\rangle$ coming from the
+transcendence of `jq`, the finite place of $\mathrm{RatFunc}\,\mathbb{Q}$ attached to $X - 1728$ —
+precisely when $\mathrm{ord}_w(\mathtt{jq} - 1728) > 0$, where $\mathrm{ord}_w$ is minus the
+logarithm of the associated $\mathbb{Z}^{m0}$-valued adic valuation and `jq` is viewed in
+`modularFunctionField N`.
+
+This is the criterion identifying the places of the function field of $X_0(N)$ that lie over the
+elliptic point $j = 1728$ of the $j$-line, expressed through vanishing of $j - 1728$. It is used in
+the counts of fibres over $j = 0$ and $j = 1728$, namely in
+[`ModularCurve.natCard_ord_jBar_eq_one_eq_nuThree`]
+(thm.html#ModularCurve.natCard_ord_jBar_eq_one_eq_nuThree)
+and
+[`ModularCurve.natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo`]
+(thm.html#ModularCurve.natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_restrict_eq_jLinePlace1728_iff.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_restrict_eq_jLinePlace1728_iff
+
+
+open IntermediateField AlgebraicCurve
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jAdjoinAlgebra jLinePlace1728 jq modularFunctionField jq_mem jGen \
+  eq_jLinePlace1728_iff_ord_jGen_sub_pos"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+theorem ModularCurve.RestrictAux.ord_algebraMap_pos_iff (N : ℕ) [NeZero N] :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)) (x : ↥ℚ⟮ModularCurve.jq⟯),
+      (0 < w.ord (algebraMap ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N) x) ↔
+          0 < (w.restrict ↥ℚ⟮ModularCurve.jq⟯).ord x) ∧
+      (w.ord (algebraMap ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N) x) < 0 ↔
+          (w.restrict ↥ℚ⟮ModularCurve.jq⟯).ord x < 0) := by
+  let := ModularCurve.jAdjoinAlgebra N
+  intro _ w x
+  have he : (0 : ℤ) < (w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ : ℤ) :=
+    Int.natCast_pos.mpr (w.ramificationIndex_pos (F := ↥ℚ⟮ModularCurve.jq⟯))
+  rw [w.ord_restrict (F := ↥ℚ⟮ModularCurve.jq⟯) x]
+  constructor
+  · constructor
+    · intro h; by_contra hle; rw [not_lt] at hle; nlinarith
+    · intro h; positivity
+  · constructor
+    · intro h; by_contra hle; rw [not_lt] at hle; nlinarith
+    · intro h; nlinarith
+
+theorem solution (N : ℕ) [NeZero N] :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ = ModularCurve.jLinePlace1728 ↔
+        0 < w.ord ((⟨ModularCurve.jq, ModularCurve.jq_mem N⟩ : ↥(ModularCurve.modularFunctionField
+          N)) - 1728) := by
+  let := ModularCurve.jAdjoinAlgebra N
+  intro _ w
+  rw [ModularCurve.eq_jLinePlace1728_iff_ord_jGen_sub_pos,
+    ← (ModularCurve.RestrictAux.ord_algebraMap_pos_iff N w (ModularCurve.jGen - 1728)).1, map_sub,
+    map_ofNat]
+  rfl
+
+end S_ModularCurve_restrict_eq_jLinePlace1728_iff
+end P2MW
+export P2MW.S_ModularCurve_restrict_eq_jLinePlace1728_iff (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open IntermediateField AlgebraicCurve
+theorem ModularCurve.restrict_eq_jLinePlace1728_iff (N : ℕ) [NeZero N] :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ = ModularCurve.jLinePlace1728 ↔
+        0 < w.ord ((⟨ModularCurve.jq, ModularCurve.jq_mem N⟩ : ↥(ModularCurve.modularFunctionField
+          N)) - 1728) :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_restrict_eq_jLinePlaceInfty_iff.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_restrict_eq_jLinePlaceInfty_iff.lean
new file mode 100644
index 0000000000..1d41899b13
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_restrict_eq_jLinePlaceInfty_iff.lean
@@ -0,0 +1,130 @@
+/-
+Based on Prove2Me node ModularCurve.restrict_eq_jLinePlaceInfty_iff
+(42ee546b-e40b-52b8-8589-1ebff926f651) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d237ebb6-cb86-5259-9c06-2021cc8b647e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JLinePlaces
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_eq_jLinePlaceInfty_iff_ord_jGen_neg
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Places of F_N above j=∞ are the poles of j
+
+Theorem statement: `ModularCurve.restrict_eq_jLinePlaceInfty_iff`
+(`42ee546b-e40b-52b8-8589-1ebff926f651`), by Claude, 2026-09-05.
+
+Proof: submission `d237ebb6-cb86-5259-9c06-2021cc8b647e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N \ge 1$ and equip the field $F_N = \mathbb{Q}(j_q, j_q(q^N))$ — the intermediate field
+[`ModularCurve.modularFunctionField N`](def/ModularCurve_X0.html#L250) of $\mathbb{Q} \subseteq
+\mathrm{LaurentSeries}\,\mathbb{Q}$ generated by the Laurent series $j_q = q^{-1}\cdot(\text{power
+series } jNumQ)$ together with its image under $q \mapsto q^N$ — with the $\mathbb{Q}\langle
+j_q\rangle$-algebra structure given by the inclusion of subfields. Assume $F_N$ is integral over
+$\mathbb{Q}\langle j_q\rangle$, and let $w$ be a place of $F_N$ over $\mathbb{Q}$, i.e. a valuation
+subring of $F_N$ containing the image of $\mathbb{Q}$, distinct from $F_N$, and a principal ideal
+ring. Then the restriction of $w$ to $\mathbb{Q}\langle j_q\rangle$ (the preimage valuation subring
+along the inclusion) equals [`ModularCurve.jLinePlaceInfty`](def/ModularCurve_JLinePlaces.html#L58)
+— the place at infinity of $\mathrm{RatFunc}\,\mathbb{Q}$ transported along the isomorphism
+$\mathrm{RatFunc}\,\mathbb{Q} \cong \mathbb{Q}\langle j_q\rangle$ coming from the transcendence of
+$j_q$ — if and only if $\mathrm{ord}_w$ of the element $j_q$ of $F_N$ is negative, where
+$\mathrm{ord}_w$ is minus the logarithm of the adic valuation attached to $w$.
+
+This identifies the places of the function field of $X_0(N)$ lying above the point $j = \infty$ of
+the $j$-line as exactly those at which $j$ has a pole, the cusps. It is used in the computations of
+the numbers of elliptic points, in
+[`ModularCurve.natCard_ord_jBar_eq_one_eq_nuThree`]
+(thm.html#ModularCurve.natCard_ord_jBar_eq_one_eq_nuThree)
+and
+[`ModularCurve.natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo`]
+(thm.html#ModularCurve.natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo),
+where places above $j = \infty$ must be separated from those above $j = 0$ and $j = 1728$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_restrict_eq_jLinePlaceInfty_iff.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_restrict_eq_jLinePlaceInfty_iff
+
+
+open IntermediateField AlgebraicCurve
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jAdjoinAlgebra jLinePlaceInfty jq modularFunctionField jq_mem jGen \
+  eq_jLinePlaceInfty_iff_ord_jGen_neg"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+theorem ModularCurve.RestrictAux.ord_algebraMap_pos_iff (N : ℕ) [NeZero N] :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)) (x : ↥ℚ⟮ModularCurve.jq⟯),
+      (0 < w.ord (algebraMap ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N) x) ↔
+          0 < (w.restrict ↥ℚ⟮ModularCurve.jq⟯).ord x) ∧
+      (w.ord (algebraMap ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N) x) < 0 ↔
+          (w.restrict ↥ℚ⟮ModularCurve.jq⟯).ord x < 0) := by
+  let := ModularCurve.jAdjoinAlgebra N
+  intro _ w x
+  have he : (0 : ℤ) < (w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ : ℤ) :=
+    Int.natCast_pos.mpr (w.ramificationIndex_pos (F := ↥ℚ⟮ModularCurve.jq⟯))
+  rw [w.ord_restrict (F := ↥ℚ⟮ModularCurve.jq⟯) x]
+  constructor
+  · constructor
+    · intro h; by_contra hle; rw [not_lt] at hle; nlinarith
+    · intro h; positivity
+  · constructor
+    · intro h; by_contra hle; rw [not_lt] at hle; nlinarith
+    · intro h; nlinarith
+
+theorem solution (N : ℕ) [NeZero N] :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ = ModularCurve.jLinePlaceInfty ↔
+        w.ord (⟨ModularCurve.jq, ModularCurve.jq_mem N⟩ : ↥(ModularCurve.modularFunctionField N)) <
+          0 := by
+  let := ModularCurve.jAdjoinAlgebra N
+  intro _ w
+  rw [ModularCurve.eq_jLinePlaceInfty_iff_ord_jGen_neg,
+    ← (ModularCurve.RestrictAux.ord_algebraMap_pos_iff N w ModularCurve.jGen).2]
+  rfl
+
+end S_ModularCurve_restrict_eq_jLinePlaceInfty_iff
+end P2MW
+export P2MW.S_ModularCurve_restrict_eq_jLinePlaceInfty_iff (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open IntermediateField AlgebraicCurve
+theorem ModularCurve.restrict_eq_jLinePlaceInfty_iff (N : ℕ) [NeZero N] :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ = ModularCurve.jLinePlaceInfty ↔
+        w.ord (⟨ModularCurve.jq, ModularCurve.jq_mem N⟩ : ↥(ModularCurve.modularFunctionField N)) <
+          0 :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_restrict_eq_jLinePlaceZero_iff.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_restrict_eq_jLinePlaceZero_iff.lean
new file mode 100644
index 0000000000..6009426131
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_restrict_eq_jLinePlaceZero_iff.lean
@@ -0,0 +1,133 @@
+/-
+Based on Prove2Me node ModularCurve.restrict_eq_jLinePlaceZero_iff
+(7d50d614-5cbb-5eb3-b5b5-e72bcb066e77) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 27f578db-2387-5377-bc9f-08ac4de3ba3d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JLinePlaces
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_eq_jLinePlaceZero_iff_ord_jGen_pos
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Place of X₀(N) lies over j=0 iff ord_w(j)>0
+
+Theorem statement: `ModularCurve.restrict_eq_jLinePlaceZero_iff`
+(`7d50d614-5cbb-5eb3-b5b5-e72bcb066e77`), by Claude, 2026-09-05.
+
+Proof: submission `27f578db-2387-5377-bc9f-08ac4de3ba3d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $N \neq 0$ and let $F_N$ denote [`ModularCurve.modularFunctionField
+N`](def/ModularCurve_X0.html#L250), the intermediate field of $\mathbb{Q} \subseteq \mathbb{Q}((q))$
+(Laurent series over $\mathbb{Q}$) generated by the $q$-expansion $jq$ of the modular $j$-function
+and by its $N$-fold substitution $q \mapsto q^N$; $F_N$ is regarded as an algebra over the simple
+extension $\mathbb{Q}\langle jq\rangle$ by way of the inclusion of subfields of $\mathbb{Q}((q))$.
+Assume $F_N$ is integral over $\mathbb{Q}\langle jq \rangle$, and let $w$ be a place of $F_N$ over
+$\mathbb{Q}$, that is, a valuation subring of $F_N$ which contains the image of $\mathbb{Q}$, is not
+all of $F_N$, and is a principal ideal ring. Then the restriction of $w$ to $\mathbb{Q}\langle
+jq\rangle$ — the valuation subring obtained by pulling $w$ back along the inclusion
+$\mathbb{Q}\langle jq\rangle \hookrightarrow F_N$ — equals
+[`ModularCurve.jLinePlaceZero`](def/ModularCurve_JLinePlaces.html#L54), the place of the $j$-line
+obtained by transporting the finite place of $\mathbb{Q}(T)$ cut out by $T - 0$ along the
+isomorphism $\mathbb{Q}(T) \cong \mathbb{Q}\langle jq \rangle$ sending $T$ to $jq$ (available since
+$jq$ is transcendental over $\mathbb{Q}$), if and only if $\mathrm{ord}_w$ of the element $jq$ of
+$F_N$ is strictly positive, where $\mathrm{ord}_w$ is minus the logarithm of the adic valuation
+attached to the height-one prime of $w$.
+
+This is the statement that a place of the function field of $X_0(N)$ lies over the point $j = 0$ of
+the $j$-line exactly when the $j$-invariant vanishes there, one of the lemmas pinning down places of
+$F_N$ by the order of vanishing of $j$ (and of $j - 1728$) at them. It is used in the computations
+of the numbers of points of $X_0(N)$ above $j = 0$ and $j = 1728$, namely in
+[`ModularCurve.natCard_ord_jBar_eq_one_eq_nuThree`]
+(thm.html#ModularCurve.natCard_ord_jBar_eq_one_eq_nuThree)
+and
+[`ModularCurve.natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo`]
+(thm.html#ModularCurve.natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_restrict_eq_jLinePlaceZero_iff.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_restrict_eq_jLinePlaceZero_iff
+
+
+open IntermediateField AlgebraicCurve
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jAdjoinAlgebra jLinePlaceZero jq modularFunctionField jq_mem jGen \
+  eq_jLinePlaceZero_iff_ord_jGen_pos"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+theorem ModularCurve.RestrictAux.ord_algebraMap_pos_iff (N : ℕ) [NeZero N] :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)) (x : ↥ℚ⟮ModularCurve.jq⟯),
+      (0 < w.ord (algebraMap ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N) x) ↔
+          0 < (w.restrict ↥ℚ⟮ModularCurve.jq⟯).ord x) ∧
+      (w.ord (algebraMap ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N) x) < 0 ↔
+          (w.restrict ↥ℚ⟮ModularCurve.jq⟯).ord x < 0) := by
+  let := ModularCurve.jAdjoinAlgebra N
+  intro _ w x
+  have he : (0 : ℤ) < (w.ramificationIndex ↥ℚ⟮ModularCurve.jq⟯ : ℤ) :=
+    Int.natCast_pos.mpr (w.ramificationIndex_pos (F := ↥ℚ⟮ModularCurve.jq⟯))
+  rw [w.ord_restrict (F := ↥ℚ⟮ModularCurve.jq⟯) x]
+  constructor
+  · constructor
+    · intro h; by_contra hle; rw [not_lt] at hle; nlinarith
+    · intro h; positivity
+  · constructor
+    · intro h; by_contra hle; rw [not_lt] at hle; nlinarith
+    · intro h; nlinarith
+
+theorem solution (N : ℕ) [NeZero N] :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ = ModularCurve.jLinePlaceZero ↔
+        0 < w.ord (⟨ModularCurve.jq, ModularCurve.jq_mem N⟩ : ↥(ModularCurve.modularFunctionField
+          N)) := by
+  let := ModularCurve.jAdjoinAlgebra N
+  intro _ w
+  rw [ModularCurve.eq_jLinePlaceZero_iff_ord_jGen_pos,
+    ← (ModularCurve.RestrictAux.ord_algebraMap_pos_iff N w ModularCurve.jGen).1]
+  rfl
+
+end S_ModularCurve_restrict_eq_jLinePlaceZero_iff
+end P2MW
+export P2MW.S_ModularCurve_restrict_eq_jLinePlaceZero_iff (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open IntermediateField AlgebraicCurve
+theorem ModularCurve.restrict_eq_jLinePlaceZero_iff (N : ℕ) [NeZero N] :
+    letI := ModularCurve.jAdjoinAlgebra N
+    ∀ [Algebra.IsIntegral ↥ℚ⟮ModularCurve.jq⟯ ↥(ModularCurve.modularFunctionField N)]
+      (w : AlgebraicCurve.Place ℚ ↥(ModularCurve.modularFunctionField N)),
+      w.restrict ↥ℚ⟮ModularCurve.jq⟯ = ModularCurve.jLinePlaceZero ↔
+        0 < w.ord (⟨ModularCurve.jq, ModularCurve.jq_mem N⟩ : ↥(ModularCurve.modularFunctionField
+          N)) :=
+  solution N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_sameOrbit_iff_eq_of_c4_ne_zero_of_c6_ne_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_sameOrbit_iff_eq_of_c4_ne_zero_of_c6_ne_zero.lean
new file mode 100644
index 0000000000..cf0bb67b19
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_sameOrbit_iff_eq_of_c4_ne_zero_of_c6_ne_zero.lean
@@ -0,0 +1,139 @@
+/-
+Based on Prove2Me node ModularCurve.sameOrbit_iff_eq_of_c4_ne_zero_of_c6_ne_zero
+(11581efe-6a84-57cd-a5ff-529b072eee6a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 42e84fb2-5743-5abc-9b9f-49d45e7ba86a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EMD
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_vcInvFun_neg_heq_neg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_variableChange_smul_eq_self_iff_of_c4_ne_zero_of_c6_ne_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Orbit relation on cyclic subgroups is equality when c₄,c₆≠ 0
+
+Theorem statement: `ModularCurve.sameOrbit_iff_eq_of_c4_ne_zero_of_c6_ne_zero`
+(`11581efe-6a84-57cd-a5ff-529b072eee6a`), by Claude, 2026-09-05.
+
+Proof: submission `42e84fb2-5743-5abc-9b9f-49d45e7ba86a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $E_0$ be a Weierstrass curve over $\overline{\mathbb{Q}}$ (an algebraic closure of $\mathbb{Q}$)
+whose invariants satisfy $c_4(E_0)\neq 0$ and $c_6(E_0)\neq 0$, and let $H,H'$ be additive subgroups
+of the group $E_0(\overline{\mathbb{Q}})$ of points of the associated affine curve. The assertion is
+an equivalence. On the left stands the relation `SameOrbit E₀ H H'`, which by definition says: there
+is a Weierstrass variable change $\gamma$ over $\overline{\mathbb{Q}}$ with $\gamma \bullet E_0 =
+E_0$, together with points $g,g'$ of $E_0$ such that $H$ is the subgroup of integer multiples of
+$g$, $H'$ the subgroup of integer multiples of $g'$, and $g'$ agrees (as a heterogeneous equality,
+the two points living a priori on $E_0$ and on $\gamma\bullet E_0$) with the image
+$\mathrm{vcInvFun}\,\gamma\,E_0\,g$, where `vcInvFun` sends the point at infinity to the point at
+infinity and an affine point $(x,y)$ to $(\mathrm{vcXInv}\,\gamma\,x,
+\mathrm{vcYInv}\,\gamma\,x\,y)$ on $\gamma\bullet E_0$. On the right stands the conjunction: $H'=H$,
+and $H$ is the subgroup of integer multiples of some point $g$ of $E_0$. No nonsingularity or
+ellipticity of $E_0$ is assumed beyond $c_4\neq 0$, $c_6\neq 0$.
+
+This is the degenerate, generic-$j$ case of the orbit relation occurring in the curve-side
+description of cyclic subgroups up to automorphisms of a fixed Weierstrass model: for $c_4\neq 0$
+and $c_6\neq 0$ (for an elliptic curve, $j\notin\{0,1728\}$) the only changes of variables
+preserving the model are the identity and $[-1]$, so the orbit relation on cyclic subgroups
+collapses to equality. It is used in the computation of the order of vanishing of $\bar{j}-j_0$ in
+[`ModularCurve.ord_jBar_sub_eq_one_of_ne_zero_of_ne`]
+(thm.html#ModularCurve.ord_jBar_sub_eq_one_of_ne_zero_of_ne).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_sameOrbit_iff_eq_of_c4_ne_zero_of_c6_ne_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_sameOrbit_iff_eq_of_c4_ne_zero_of_c6_ne_zero
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_ModularCurve_sameOrbit_iff_eq_of_c4_ne_zero_of_c6_ne_zero.WeierstrassCurve \
+  WeierstrassCurve.Affine \
+  P2MW.S_ModularCurve_sameOrbit_iff_eq_of_c4_ne_zero_of_c6_ne_zero.WeierstrassCurve.Affine"
+open scoped Classical
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine VariableChange.one_def a₃ a₁ c₆ toAffine Affine.Point c₄ \
+  VariableChange variableChange_smul_eq_self_iff_of_c4_ne_zero_of_c6_ne_zero"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point vcXInv vcYInv"
+namespace Point
+p2m_export "WeierstrassCurve.Affine.Point" "some zero vcInvFun vcInvFun_neg_heq_neg"
+p2m_open "WeierstrassCurve.Affine.Point WeierstrassCurve.Affine WeierstrassCurve"
+
+variable {F : Type*} [Field F] [DecidableEq F]
+
+omit [DecidableEq F] in
+theorem vcInvFun_one_heq' (W : WeierstrassCurve F) (P : W.toAffine.Point) :
+    HEq (vcInvFun (1 : VariableChange F) W.toAffine P) P := by
+  have hW : ((1 : VariableChange F) • W).toAffine = W.toAffine := one_smul _ _
+  cases P with
+  | zero => exact ModularCurve.Point.heq_zero hW
+  | some x y h =>
+    simp only [vcInvFun]
+    refine ModularCurve.Point.heq_some hW ?_ ?_
+    · simp [vcXInv, VariableChange.one_def]
+    · simp [vcYInv, VariableChange.one_def]
+
+theorem zmultiples_eq_of_heq_vcInvFun_neg' (W : WeierstrassCurve F) (g g' : W.toAffine.Point)
+    (hg : HEq g' (vcInvFun (⟨-1, 0, -W.a₁, -W.a₃⟩ : VariableChange F) W.toAffine g)) :
+    AddSubgroup.zmultiples g' = AddSubgroup.zmultiples g := by
+  have : g' = -g := eq_of_heq (hg.trans (vcInvFun_neg_heq_neg W g))
+  rw [this, AddSubgroup.zmultiples_neg]
+
+end WeierstrassCurve.Affine.Point
+
+p2m_open "WeierstrassCurve.Affine.Point \
+  P2MW.S_ModularCurve_sameOrbit_iff_eq_of_c4_ne_zero_of_c6_ne_zero.WeierstrassCurve.Affine.Point"
+
+open ModularCurve
+
+theorem solution (E₀ : WeierstrassCurve (AlgebraicClosure ℚ))
+    (hc₄ : E₀.c₄ ≠ 0) (hc₆ : E₀.c₆ ≠ 0) (H H' : AddSubgroup E₀.toAffine.Point) :
+    SameOrbit E₀ H H' ↔ H' = H ∧ ∃ g : E₀.toAffine.Point, H = AddSubgroup.zmultiples g := by
+  constructor
+  · rintro ⟨γ, hγ, g, g', rfl, rfl, hheq⟩
+    refine ⟨?_, g, rfl⟩
+    have h2 : (2 : AlgebraicClosure ℚ) ≠ 0 := by norm_num
+    have h3 : (3 : AlgebraicClosure ℚ) ≠ 0 := by norm_num
+    rcases (WeierstrassCurve.variableChange_smul_eq_self_iff_of_c4_ne_zero_of_c6_ne_zero h2 h3 E₀
+      hc₄ hc₆ γ).mp hγ
+      with rfl | rfl
+    · rw [eq_of_heq (hheq.trans (vcInvFun_one_heq' E₀ g))]
+    · exact zmultiples_eq_of_heq_vcInvFun_neg' E₀ g g' hheq
+  · rintro ⟨rfl, g, rfl⟩
+    exact ⟨1, one_smul _ _, g, g, rfl, rfl, (vcInvFun_one_heq' E₀ g).symm⟩
+
+end S_ModularCurve_sameOrbit_iff_eq_of_c4_ne_zero_of_c6_ne_zero
+end P2MW
+export P2MW.S_ModularCurve_sameOrbit_iff_eq_of_c4_ne_zero_of_c6_ne_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve WeierstrassCurve
+theorem ModularCurve.sameOrbit_iff_eq_of_c4_ne_zero_of_c6_ne_zero (E₀ : WeierstrassCurve
+  (AlgebraicClosure ℚ))
+    (hc₄ : E₀.c₄ ≠ 0) (hc₆ : E₀.c₆ ≠ 0) (H H' : AddSubgroup E₀.toAffine.Point) :
+    SameOrbit E₀ H H' ↔ H' = H ∧ ∃ g : E₀.toAffine.Point, H = AddSubgroup.zmultiples g :=
+  solution E₀ hc₄ hc₆ H H'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_samePlace_iff_exists_hahnTwist.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_samePlace_iff_exists_hahnTwist.lean
new file mode 100644
index 0000000000..304d749ab4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_samePlace_iff_exists_hahnTwist.lean
@@ -0,0 +1,618 @@
+/-
+Based on Prove2Me node ModularCurve.samePlace_iff_exists_hahnTwist
+(eb4b6238-1259-5a50-8c99-8b7578c7bb13) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9771519d-80e8-5d04-b67d-0c7275efd2dc
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EMD
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_Monodromy
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_mul_eq_order_of_hasRamBound
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_hasRamBound_natDegree_factorial_of_isRoot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_mem_puiseuxRamSubfield_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_adjoin_jBar_jNBar_eq_top
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_normalized_algHom_jBar_eq_toNat_ord
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_modularPolynomialData
+import Mathlib.RingTheory.RootsOfUnity.EnoughRootsOfUnity
+import Mathlib.RingTheory.RootsOfUnity.AlgebraicallyClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Same induced place iff related by a monodromy twist
+
+Theorem statement: `ModularCurve.samePlace_iff_exists_hahnTwist`
+(`eb4b6238-1259-5a50-8c99-8b7578c7bb13`), by Claude, 2026-09-05.
+
+Proof: submission `9771519d-80e8-5d04-b67d-0c7275efd2dc`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a nonzero natural number $N$ and an element $j_0$ of $\overline{\mathbb{Q}} =$ `AlgebraicClosure
+ℚ`. Let $F =$ `modularFunctionFieldBar N`, the intermediate field of $\overline{\mathbb{Q}}((s))$
+obtained by base change to $\overline{\mathbb{Q}}$ of the level-$N$ modular function field
+`modularFunctionFieldFull N`, and let $\bar\jmath =$ `jBar N` be the element of $F$ given by the
+$q$-expansion of the modular invariant. Let $\psi,\psi'$ be two elements of `Emb N j₀`, i.e.
+$\overline{\mathbb{Q}}$-algebra homomorphisms from $F$ to the field $\mathbb{H}$ of Hahn series with
+rational exponents and coefficients in $\overline{\mathbb{Q}}$, each normalised by $\psi(\bar\jmath)
+= j_0 + s$ (constant term $j_0$ plus the monomial $s^{1}$ with coefficient $1$). The assertion is an
+equivalence. On one side, `SamePlace` holds for the underlying homomorphisms: there is a place $w$
+of $F$ over $\overline{\mathbb{Q}}$ — a valuation subring of $F$, not all of $F$, containing the
+image of $\overline{\mathbb{Q}}$ and a principal ideal ring — and rationals $g,g'>0$ with
+$\operatorname{ord}_w(x)\,g = \operatorname{ord}(\psi x)$ and $\operatorname{ord}_w(x)\,g' =
+\operatorname{ord}(\psi' x)$ for all $x \in F$. On the other side, there is a monoid homomorphism
+$\chi \colon \mathrm{Multiplicative}\,\mathbb{Q} \to \overline{\mathbb{Q}}^{\times}$ lying in
+[`HahnSeries.MonoChar`](def/HahnSeries_Monodromy.html#L95), that is, with $\chi(1) = 1$, such that
+$\psi'(x) = \mathrm{hahnTwist}\,\chi\,(\psi(x))$ for every $x \in F$, where the twist multiplies the
+coefficient of $s^{a}$ by $\chi(a)$ for each $a \in \mathbb{Q}$.
+
+This identifies, in function-field terms, the set of normalised Puiseux branches of the modular
+curve of level $N$ above the point $j = j_0$ of the $j$-line that induce one and the same place:
+they form a single orbit of the local monodromy group acting by twisting Hahn coefficients by a
+character trivial on $\mathbb{Z}$. It is used by
+[`ModularCurve.samePlace_iff_exists_monodromy`]
+(thm.html#ModularCurve.samePlace_iff_exists_monodromy),
+and rests on the counting of normalised embeddings inducing a given place together with the
+ramification bound $(\deg)!$ for roots of polynomials with Laurent coefficients.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_samePlace_iff_exists_hahnTwist.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_samePlace_iff_exists_hahnTwist
+
+
+noncomputable section
+
+open HahnSeries
+
+namespace ModularCurve
+p2m_export "ModularCurve" "Emb Induces SamePlace jBar modularFunctionFieldBar qExpand jq evalAtJ \
+  evalAtJ_X ModularPolynomialData jqd_mem_full coeffEmb coeffEmb_mem_laurentBaseChange jq_mem_full \
+  adjoin_jBar_jNBar_eq_top nonempty_modularPolynomialData \
+  natCard_normalized_algHom_jBar_eq_toNat_ord"
+namespace SamePlaceTwist
+p2m_open "ModularCurve"
+
+variable {K : Type*} [Field K]
+
+section Character
+
+variable [IsAlgClosed K] (ζ : Kˣ)
+
+noncomputable def rootSeq : ℕ → Kˣ
+  | 0 => ζ
+  | m + 1 =>
+    Units.mk0 (Classical.choose (IsAlgClosed.exists_pow_nat_eq ((rootSeq m : Kˣ) : K) m.succ_pos))
+      (by
+        intro h0
+        have h :=
+          Classical.choose_spec (IsAlgClosed.exists_pow_nat_eq ((rootSeq m : Kˣ) : K) m.succ_pos)
+        rw [h0, zero_pow (Nat.succ_ne_zero m)] at h
+        exact (rootSeq m).ne_zero h.symm)
+
+theorem rootSeq_zero : rootSeq ζ 0 = ζ := rfl
+
+theorem rootSeq_succ_pow (m : ℕ) : (rootSeq ζ (m + 1)) ^ (m + 1) = rootSeq ζ m := by
+  apply Units.ext
+  rw [Units.val_pow_eq_pow_val]
+  change (Classical.choose (IsAlgClosed.exists_pow_nat_eq ((rootSeq ζ m : Kˣ) : K) m.succ_pos)) ^
+    (m+1) = _
+  exact Classical.choose_spec (IsAlgClosed.exists_pow_nat_eq ((rootSeq ζ m : Kˣ) : K) m.succ_pos)
+
+theorem rootSeq_add_pow (m j : ℕ) :
+    (rootSeq ζ (m + j)) ^ ((m + j).factorial / m.factorial) = rootSeq ζ m := by
+  induction j with
+  | zero => simp [Nat.div_self (Nat.factorial_pos m)]
+  | succ j ih =>
+    rw [← add_assoc, Nat.factorial_succ, Nat.mul_div_assoc _ (Nat.factorial_dvd_factorial
+      (Nat.le_add_right m j)),
+      pow_mul, rootSeq_succ_pow, ih]
+
+theorem rootSeq_pow_of_le {m M : ℕ} (h : m ≤ M) :
+    (rootSeq ζ M) ^ (M.factorial / m.factorial) = rootSeq ζ m := by
+  obtain ⟨j, rfl⟩ := Nat.exists_eq_add_of_le h
+  exact rootSeq_add_pow ζ m j
+
+variable (b : ℕ)
+
+noncomputable def charFun (x : ℚ) : Kˣ :=
+  (rootSeq ζ x.den) ^ (x.num * (((b * x.den.factorial) / x.den : ℕ) : ℤ))
+
+variable {b}
+
+theorem charFun_eq (x : ℚ) (m : ℕ) (k : ℤ) (hk : x * ((b * m.factorial : ℕ) : ℚ) = k) :
+    charFun ζ b x = (rootSeq ζ m) ^ k := by
+  have hd0 : x.den ≠ 0 := x.den_nz
+  have hdvd : x.den ∣ x.den.factorial := Nat.dvd_factorial x.den_pos le_rfl
+  rw [charFun, ← rootSeq_pow_of_le ζ (Nat.le_add_right x.den m),
+    ← rootSeq_pow_of_le ζ (Nat.le_add_left m x.den),
+    ← zpow_natCast, ← zpow_natCast, ← zpow_mul, ← zpow_mul]
+  congr 1
+  apply mul_left_cancel₀ (show (x.den : ℤ) ≠ 0 by exact_mod_cast hd0)
+  have e1 : (((x.den + m).factorial / x.den.factorial : ℕ) : ℤ) * (x.den.factorial : ℤ)
+      = ((x.den + m).factorial : ℤ) := by
+    exact_mod_cast Nat.div_mul_cancel (Nat.factorial_dvd_factorial (Nat.le_add_right x.den m))
+  have e2 : (((b * x.den.factorial) / x.den : ℕ) : ℤ) * (x.den : ℤ) = b * x.den.factorial := by
+    exact_mod_cast Nat.div_mul_cancel (Dvd.dvd.mul_left hdvd b)
+  have e3 : (((x.den + m).factorial / m.factorial : ℕ) : ℤ) * (m.factorial : ℤ) = ((x.den +
+    m).factorial : ℤ) :=
+    by
+    exact_mod_cast Nat.div_mul_cancel (Nat.factorial_dvd_factorial (Nat.le_add_left m x.den))
+  have e4 : (k : ℤ) * x.den = x.num * (b * m.factorial : ℕ) := by
+    have hq : (k : ℚ) * x.den = x.num * (b * m.factorial : ℕ) := by
+      rw [← hk, mul_right_comm, Rat.mul_den_eq_num]
+    exact_mod_cast hq
+  calc (x.den : ℤ) * ((((x.den + m).factorial / x.den.factorial : ℕ) : ℤ)
+          * (x.num * (((b * x.den.factorial) / x.den : ℕ) : ℤ)))
+      = x.num * ((((b * x.den.factorial) / x.den : ℕ) : ℤ) * x.den)
+          * (((x.den + m).factorial / x.den.factorial : ℕ) : ℤ) := by ring
+    _ = x.num * (b * x.den.factorial) * (((x.den + m).factorial / x.den.factorial : ℕ) : ℤ) := by
+      rw [e2]
+    _ = x.num * b * ((((x.den + m).factorial / x.den.factorial : ℕ) : ℤ) * x.den.factorial) := by
+      ring
+    _ = x.num * b * ((x.den + m).factorial : ℤ) := by rw [e1]
+    _ = x.num * b * ((((x.den + m).factorial / m.factorial : ℕ) : ℤ) * m.factorial) := by rw [e3]
+    _ = (x.num * (b * m.factorial : ℕ)) * (((x.den + m).factorial / m.factorial : ℕ) : ℤ) := by
+          push_cast; ring
+    _ = (k * x.den) * (((x.den + m).factorial / m.factorial : ℕ) : ℤ) := by rw [e4]
+    _ = (x.den : ℤ) * ((((x.den + m).factorial / m.factorial : ℕ) : ℤ) * k) := by ring
+
+theorem exists_int_eq (b : ℕ) (x : ℚ) (m : ℕ) (hm : x.den ∣ m.factorial) :
+    ∃ k : ℤ, x * ((b * m.factorial : ℕ) : ℚ) = k := by
+  obtain ⟨c, hc⟩ := Dvd.dvd.mul_left hm b
+  refine ⟨x.num * c, ?_⟩
+  rw [hc]
+  push_cast
+  rw [← mul_assoc, Rat.mul_den_eq_num]
+
+variable (b)
+
+noncomputable def char : Multiplicative ℚ →* Kˣ where
+  toFun q := charFun ζ b (Multiplicative.toAdd q)
+  map_one' := by
+    change charFun ζ b 0 = 1
+    rw [charFun_eq ζ 0 0 0 (by simp), zpow_zero]
+  map_mul' x y := by
+    change charFun ζ b (Multiplicative.toAdd x + Multiplicative.toAdd y)
+      = charFun ζ b (Multiplicative.toAdd x) * charFun ζ b (Multiplicative.toAdd y)
+    have hm0 : 0 < (Multiplicative.toAdd x).den * (Multiplicative.toAdd y).den :=
+      Nat.pos_of_ne_zero (Nat.mul_ne_zero (Multiplicative.toAdd x).den_nz (Multiplicative.toAdd
+        y).den_nz)
+    have hfac : (Multiplicative.toAdd x).den * (Multiplicative.toAdd y).den ∣
+        ((Multiplicative.toAdd x).den * (Multiplicative.toAdd y).den).factorial :=
+      Nat.dvd_factorial hm0 le_rfl
+    have hu : (Multiplicative.toAdd x).den ∣
+        ((Multiplicative.toAdd x).den * (Multiplicative.toAdd y).den).factorial :=
+      (Dvd.intro _ rfl).trans hfac
+    have hv : (Multiplicative.toAdd y).den ∣
+        ((Multiplicative.toAdd x).den * (Multiplicative.toAdd y).den).factorial :=
+      (Dvd.intro_left _ rfl).trans hfac
+    have huv : (Multiplicative.toAdd x + Multiplicative.toAdd y).den ∣
+        ((Multiplicative.toAdd x).den * (Multiplicative.toAdd y).den).factorial :=
+      (Rat.add_den_dvd _ _).trans hfac
+    obtain ⟨ku, hku⟩ := exists_int_eq b _ _ hu
+    obtain ⟨kv, hkv⟩ := exists_int_eq b _ _ hv
+    have hkuv : (Multiplicative.toAdd x + Multiplicative.toAdd y)
+        * ((b * ((Multiplicative.toAdd x).den * (Multiplicative.toAdd y).den).factorial : ℕ) : ℚ)
+        = (ku + kv : ℤ) := by
+      rw [add_mul, hku, hkv]
+      push_cast
+      ring
+    rw [charFun_eq ζ _ _ _ hkuv, charFun_eq ζ _ _ _ hku, charFun_eq ζ _ _ _ hkv, zpow_add]
+
+theorem char_apply (x : ℚ) : char ζ b (Multiplicative.ofAdd x) = charFun ζ b x := rfl
+
+variable {b}
+
+theorem char_intCast (hζ : ζ ^ b = 1) (k : ℤ) :
+    char ζ b (Multiplicative.ofAdd (k : ℚ)) = 1 := by
+  rw [char_apply, charFun_eq ζ (k : ℚ) 0 (k * b) (by push_cast; simp), rootSeq_zero,
+    mul_comm, zpow_mul, zpow_natCast, hζ, one_zpow]
+
+theorem char_div (hb : 0 < b) (a : ℤ) :
+    char ζ b (Multiplicative.ofAdd ((a : ℚ) / b)) = ζ ^ a := by
+  have hb' : (b : ℚ) ≠ 0 := by exact_mod_cast hb.ne'
+  rw [char_apply, charFun_eq ζ ((a : ℚ) / b) 0 a (by push_cast; simp; field_simp), rootSeq_zero]
+
+end Character
+
+section Core
+
+variable {F : Type*} [Field F] [Algebra K F]
+
+theorem algebraMap_hahnSeries_eq_C (r : K) :
+    algebraMap K (HahnSeries ℚ K) r = HahnSeries.C r := by
+  rw [HahnSeries.algebraMap_apply']
+  simp
+
+theorem induces_hahnTwist (χ : Multiplicative ℚ →* Kˣ) {v : F → ℤ}
+    {ψ : F →ₐ[K] HahnSeries ℚ K}
+    (h : ∃ g : ℚ, 0 < g ∧ ∀ x : F, (v x : ℚ) * g = (ψ x).order) :
+    ∃ g : ℚ, 0 < g ∧ ∀ x : F, (v x : ℚ) * g = (hahnTwist χ (ψ x)).order := by
+  obtain ⟨g, hg, h⟩ := h
+  exact ⟨g, hg, fun x => by rw [order_hahnTwist, h]⟩
+
+theorem hahnTwist_normalised {χ : Multiplicative ℚ →* Kˣ} (hχ : χ ∈ MonoChar K)
+    {ψ : F →ₐ[K] HahnSeries ℚ K} {jb : F} {j₀ : K}
+    (hψ : ψ jb = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : K)) :
+    hahnTwist χ (ψ jb) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : K) := by
+  rw [hψ, map_add, ← algebraMap_hahnSeries_eq_C, AlgEquiv.commutes, hahnTwist_single,
+    mem_monoChar_iff.mp hχ, Units.val_one, one_mul]
+
+theorem induces_of_forall_eq_hahnTwist {χ : Multiplicative ℚ →* Kˣ} {v : F → ℤ}
+    {ψ ψ' : F →ₐ[K] HahnSeries ℚ K} (hχψ : ∀ x, ψ' x = hahnTwist χ (ψ x))
+    (h : ∃ g : ℚ, 0 < g ∧ ∀ x : F, (v x : ℚ) * g = (ψ x).order) :
+    ∃ g : ℚ, 0 < g ∧ ∀ x : F, (v x : ℚ) * g = (ψ' x).order := by
+  obtain ⟨g, hg, h⟩ := induces_hahnTwist χ h
+  exact ⟨g, hg, fun x => by rw [hχψ, h]⟩
+
+theorem exists_monoChar_of_induces [IsAlgClosed K] [CharZero K]
+    (v : F → ℤ) (jb : F) (j₀ : K) (ψ ψ' : F →ₐ[K] HahnSeries ℚ K)
+    (hψ : ψ jb = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : K))
+    (hψ' : ψ' jb = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : K))
+    (hind : ∃ g : ℚ, 0 < g ∧ ∀ x : F, (v x : ℚ) * g = (ψ x).order)
+    (hind' : ∃ g : ℚ, 0 < g ∧ ∀ x : F, (v x : ℚ) * g = (ψ' x).order)
+    (hunif : ∃ π : F, v π = 1)
+    (hcard : 0 < v (jb - algebraMap K F j₀) →
+      Nat.card {φ : F →ₐ[K] HahnSeries ℚ K //
+          φ jb = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : K) ∧
+          ∃ g : ℚ, 0 < g ∧ ∀ x, (v x : ℚ) * g = (φ x).order} =
+        (v (jb - algebraMap K F j₀)).toNat) :
+    ∃ χ ∈ MonoChar K, ∀ x, ψ' x = hahnTwist χ (ψ x) := by
+  obtain ⟨g, hg, hgx⟩ := hind
+  have h1 : ((v (jb - algebraMap K F j₀) : ℤ) : ℚ) * g = 1 := by
+    have := hgx (jb - algebraMap K F j₀)
+    rwa [map_sub, hψ, AlgHom.commutes, algebraMap_hahnSeries_eq_C, add_sub_cancel_left,
+      order_single one_ne_zero] at this
+  have he0 : 0 < v (jb - algebraMap K F j₀) := by
+    have : (0 : ℚ) < ((v (jb - algebraMap K F j₀) : ℤ) : ℚ) * g := by rw [h1]; exact one_pos
+    exact_mod_cast pos_of_mul_pos_left this hg.le
+  obtain ⟨n, hn⟩ : ∃ n : ℕ, (n : ℤ) = v (jb - algebraMap K F j₀) :=
+    ⟨(v (jb - algebraMap K F j₀)).toNat, Int.toNat_of_nonneg he0.le⟩
+  have hn0 : 0 < n := by exact_mod_cast hn ▸ he0
+  have hnq : (n : ℚ) ≠ 0 := by exact_mod_cast hn0.ne'
+  have hg' : g = 1 / (n : ℚ) := by
+    rw [← hn, Int.cast_natCast] at h1
+    field_simp
+    linarith [h1]
+  have hcard' : Nat.card {φ : F →ₐ[K] HahnSeries ℚ K //
+      φ jb = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : K) ∧
+      ∃ g : ℚ, 0 < g ∧ ∀ x, (v x : ℚ) * g = (φ x).order} = n := by
+    rw [hcard he0, ← hn, Int.toNat_natCast]
+  have : NeZero n := ⟨hn0.ne'⟩
+  obtain ⟨μ, hμ⟩ := HasEnoughRootsOfUnity.exists_primitiveRoot K n
+  have hμu : IsUnit μ := hμ.isUnit hn0.ne'
+  set ζ : Kˣ := hμu.unit with hζdef
+  have hζμ : (ζ : K) = μ := hμu.unit_spec
+  have hζ : IsPrimitiveRoot (ζ : K) n := by rw [hζμ]; exact hμ
+  have hζn : ζ ^ n = 1 := by
+    apply Units.ext
+    rw [Units.val_pow_eq_pow_val, hζ.pow_eq_one, Units.val_one]
+  set χ : Multiplicative ℚ →* Kˣ := char ζ n with hχdef
+  have hχ1 : χ ∈ MonoChar K := by
+    rw [mem_monoChar_iff]
+    have := char_intCast ζ hζn 1
+    rwa [Int.cast_one] at this
+  have hχn : χ (Multiplicative.ofAdd (1 / (n : ℚ))) = ζ := by
+    have := char_div ζ hn0 1
+    rwa [Int.cast_one, zpow_one] at this
+  obtain ⟨π, hπ⟩ := hunif
+  have hπ0 : ψ π ≠ 0 := by
+    intro h0
+    have := hgx π
+    rw [h0, order_zero, hπ, Int.cast_one, one_mul] at this
+    exact hg.ne' this
+  have hπord : (ψ π).order = 1 / (n : ℚ) := by
+    rw [← hgx π, hπ, Int.cast_one, one_mul, hg']
+  have hc : (ψ π).coeff (1 / (n : ℚ)) ≠ 0 := by
+    rw [← hπord]
+    exact fun h => hπ0 (coeff_order_eq_zero.mp h)
+  let Φ : Fin n → {φ : F →ₐ[K] HahnSeries ℚ K //
+      φ jb = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : K) ∧
+      ∃ g : ℚ, 0 < g ∧ ∀ x, (v x : ℚ) * g = (φ x).order} := fun k =>
+    ⟨(hahnTwist (χ ^ (k : ℕ))).toAlgHom.comp ψ,
+      hahnTwist_normalised (pow_mem hχ1 _) hψ, induces_hahnTwist _ ⟨g, hg, hgx⟩⟩
+  have hΦ : ∀ (k : Fin n) (x : F), (Φ k).1 x = hahnTwist (χ ^ (k : ℕ)) (ψ x) := fun k x => rfl
+  have hΦinj : Function.Injective Φ := by
+    intro k l hkl
+    have h : ((Φ k).1 π).coeff (1 / (n : ℚ)) = ((Φ l).1 π).coeff (1 / (n : ℚ)) := by rw [hkl]
+    rw [hΦ, hΦ, coeff_hahnTwist, coeff_hahnTwist, MonoidHom.pow_apply, MonoidHom.pow_apply,
+      hχn] at h
+    have h' : ((ζ : K)) ^ (k : ℕ) = (ζ : K) ^ (l : ℕ) := by
+      have := mul_right_cancel₀ hc h
+      rwa [Units.val_pow_eq_pow_val, Units.val_pow_eq_pow_val] at this
+    exact Fin.ext (hζ.pow_inj k.2 l.2 h')
+  have : Finite {φ : F →ₐ[K] HahnSeries ℚ K //
+      φ jb = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : K) ∧
+      ∃ g : ℚ, 0 < g ∧ ∀ x, (v x : ℚ) * g = (φ x).order} :=
+    Nat.finite_of_card_ne_zero (by rw [hcard']; exact hn0.ne')
+  have hΦbij : Function.Bijective Φ :=
+    hΦinj.bijective_of_nat_card_le (by rw [hcard', Nat.card_fin])
+  obtain ⟨k, hk⟩ := hΦbij.2 ⟨ψ', hψ', hind'⟩
+  refine ⟨χ ^ (k : ℕ), pow_mem hχ1 _, fun x => ?_⟩
+  rw [← hΦ k x, hk]
+
+theorem exists_induces_and_induces_iff [IsAlgClosed K] [CharZero K]
+    {V : Type*} (ord : V → F → ℤ) (jb : F) (j₀ : K) (ψ ψ' : F →ₐ[K] HahnSeries ℚ K)
+    (hψ : ψ jb = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : K))
+    (hψ' : ψ' jb = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : K))
+    (hunif : ∀ w : V, ∃ π : F, ord w π = 1)
+    (hcard : ∀ w : V, 0 < ord w (jb - algebraMap K F j₀) →
+      Nat.card {φ : F →ₐ[K] HahnSeries ℚ K //
+          φ jb = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : K) ∧
+          ∃ g : ℚ, 0 < g ∧ ∀ x, (ord w x : ℚ) * g = (φ x).order} =
+        (ord w (jb - algebraMap K F j₀)).toNat)
+    (hex : ∃ w : V, ∃ g : ℚ, 0 < g ∧ ∀ x : F, (ord w x : ℚ) * g = (ψ x).order) :
+    (∃ w : V, (∃ g : ℚ, 0 < g ∧ ∀ x : F, (ord w x : ℚ) * g = (ψ x).order) ∧
+        (∃ g : ℚ, 0 < g ∧ ∀ x : F, (ord w x : ℚ) * g = (ψ' x).order)) ↔
+      ∃ χ ∈ MonoChar K, ∀ x, ψ' x = hahnTwist χ (ψ x) := by
+  constructor
+  · rintro ⟨w, hw, hw'⟩
+    exact exists_monoChar_of_induces (ord w) jb j₀ ψ ψ' hψ hψ' hw hw' (hunif w) (hcard w)
+  · rintro ⟨χ, -, hχψ⟩
+    obtain ⟨w, hw⟩ := hex
+    exact ⟨w, hw, induces_of_forall_eq_hahnTwist hχψ hw⟩
+
+end Core
+
+end ModularCurve.SamePlaceTwist
+
+end
+
+noncomputable section
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_samePlace_iff_exists_hahnTwist.ModularCurve \
+  AlgebraicCurve IntermediateField Polynomial"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "Emb Induces SamePlace jBar modularFunctionFieldBar qExpand jq evalAtJ \
+  evalAtJ_X ModularPolynomialData jqd_mem_full coeffEmb coeffEmb_mem_laurentBaseChange jq_mem_full \
+  adjoin_jBar_jNBar_eq_top nonempty_modularPolynomialData \
+  natCard_normalized_algHom_jBar_eq_toNat_ord"
+namespace SamePlaceTwist
+namespace InducedPlace
+p2m_open "ModularCurve"
+
+variable (N : ℕ) [NeZero N]
+
+abbrev jb : ↥(modularFunctionFieldBar N) :=
+  ⟨coeffEmb (AlgebraicClosure ℚ) jq, coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ)
+    (jq_mem_full N)⟩
+
+abbrev jNb : ↥(modularFunctionFieldBar N) :=
+  ⟨coeffEmb (AlgebraicClosure ℚ) (qExpand ℚ N jq),
+    coeffEmb_mem_laurentBaseChange (AlgebraicClosure ℚ) (jqd_mem_full N (dvd_refl N))⟩
+
+theorem eval₂_Phi_jb_jNb (data : ModularPolynomialData N) :
+    data.Φ.eval₂ (Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N)) (jb N))
+      (jNb N)
+      = 0 := by
+  apply Subtype.ext
+  have hval : ((modularFunctionFieldBar N).toSubfield.subtype).comp
+      (Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N)) (jb N))
+      = (coeffEmb (AlgebraicClosure ℚ)).comp evalAtJ := by
+    refine Polynomial.ringHom_ext (fun z => by simp) ?_
+    change ((Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N)) (jb N) X :
+        ↥(modularFunctionFieldBar N)) : LaurentSeries (AlgebraicClosure ℚ)) = coeffEmb
+          (AlgebraicClosure ℚ) (evalAtJ X)
+    rw [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_X, evalAtJ_X]
+  have h0 := congrArg (coeffEmb (AlgebraicClosure ℚ)) data.eval_eq_zero
+  rw [map_zero, Polynomial.hom_eval₂, ← hval] at h0
+  rw [ZeroMemClass.coe_zero, ← h0]
+  change ((modularFunctionFieldBar N).toSubfield.subtype) _ = _
+  rw [Polynomial.hom_eval₂]
+  rfl
+
+section Hahn
+
+variable {e : ℕ}
+
+theorem hasRamBound_of_one (he : 0 < e) {y : HahnSeries ℚ (AlgebraicClosure ℚ)}
+    (hy : HahnSeries.HasRamBound 1 y) : HahnSeries.HasRamBound e y := by
+  intro g hg
+  obtain ⟨k, hk⟩ := hy hg
+  refine ⟨k * e, ?_⟩
+  simp only [Nat.cast_one, div_one] at hk
+  have he' : (e : ℚ) ≠ 0 := Nat.cast_ne_zero.mpr he.ne'
+  rw [← hk]; push_cast; field_simp
+
+theorem hasRamBound_C (a : AlgebraicClosure ℚ) :
+    HahnSeries.HasRamBound 1 (HahnSeries.C a : HahnSeries ℚ (AlgebraicClosure ℚ)) := by
+  intro g hg
+  have : g ∈ ({0} : Set ℚ) := HahnSeries.support_single_subset (a := (0 : ℚ)) (r := a) hg
+  rw [Set.mem_singleton_iff] at this
+  exact ⟨0, by simp [this]⟩
+
+theorem hasRamBound_C_add_single (a : AlgebraicClosure ℚ) :
+    HahnSeries.HasRamBound 1
+      (HahnSeries.C a + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)) := by
+  intro g hg
+  rcases (HahnSeries.support_add_subset (x := HahnSeries.C a)
+      (y := HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ))) hg with h | h
+  · exact hasRamBound_C a h
+  · have : g ∈ ({1} : Set ℚ) :=
+      HahnSeries.support_single_subset (a := (1 : ℚ)) (r := (1 : AlgebraicClosure ℚ)) h
+    rw [Set.mem_singleton_iff] at this
+    exact ⟨1, by simp [this]⟩
+
+theorem algebraMap_hahn_eq_C (a : AlgebraicClosure ℚ) :
+    algebraMap (AlgebraicClosure ℚ) (HahnSeries ℚ (AlgebraicClosure ℚ)) a = HahnSeries.C a := by
+  rw [HahnSeries.algebraMap_apply']; simp
+
+theorem eval₂RingHom_mem_puiseuxRamSubfield_one (y : HahnSeries ℚ (AlgebraicClosure ℚ))
+    (hy : HahnSeries.HasRamBound 1 y) (q : Polynomial ℤ) :
+    Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ))) y q
+      ∈ HahnSeries.puiseuxRamSubfield (AlgebraicClosure ℚ) (e := 1) one_pos := by
+  rw [Polynomial.coe_eval₂RingHom, Polynomial.eval₂_eq_sum_range]
+  refine Subfield.sum_mem _ (fun i _ => Subfield.mul_mem _ ?_ (Subfield.pow_mem _ ?_ _))
+  · exact intCast_mem _ _
+  · exact (HahnSeries.mem_puiseuxRamSubfield_iff one_pos).mpr hy
+
+end Hahn
+
+theorem exists_forall_hasRamBound (j₀ : AlgebraicClosure ℚ)
+    (ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ] HahnSeries ℚ (AlgebraicClosure ℚ))
+    (hψ : ψ (jb N) = HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ)) :
+    ∃ e : ℕ, 0 < e ∧ ∀ z, HahnSeries.HasRamBound e (ψ z) := by
+  obtain ⟨data⟩ := ModularCurve.nonempty_modularPolynomialData N
+  set P : Polynomial (HahnSeries ℚ (AlgebraicClosure ℚ)) :=
+    data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ)))
+      (HahnSeries.C j₀ + HahnSeries.single (1 : ℚ) (1 : AlgebraicClosure ℚ))) with hPdef
+  have hPmonic : P.Monic := data.monic.map _
+  have hP0 : P ≠ 0 := hPmonic.ne_zero
+  have hcoeff : ∀ i : ℕ, HahnSeries.HasRamBound 1 (P.coeff i) := by
+    intro i
+    rw [hPdef, Polynomial.coeff_map]
+    exact (HahnSeries.mem_puiseuxRamSubfield_iff one_pos).mp
+      (eval₂RingHom_mem_puiseuxRamSubfield_one _ (hasRamBound_C_add_single j₀) _)
+  have hroot : P.IsRoot (ψ (jNb N)) := by
+    rw [Polynomial.IsRoot, hPdef, Polynomial.eval_map, ← hψ]
+    have hcomp : Polynomial.eval₂RingHom (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ))) (ψ
+      (jb N))
+        = (ψ.toRingHom).comp (Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N))
+          (jb N)) := by
+      refine Polynomial.ringHom_ext (fun z => by simp) ?_
+      simp
+    rw [hcomp]
+    have h := (Polynomial.hom_eval₂ data.Φ
+      (Polynomial.eval₂RingHom (Int.castRingHom ↥(modularFunctionFieldBar N)) (jb N)) ψ.toRingHom
+        (jNb N)).symm
+    rw [eval₂_Phi_jb_jNb N data, map_zero] at h
+    simpa using h
+  have hbN := HahnSeries.hasRamBound_natDegree_factorial_of_isRoot hP0 hcoeff hroot
+  set e := P.natDegree.factorial with hedef
+  have he : 0 < e := Nat.factorial_pos _
+  refine ⟨e, he, ?_⟩
+  let S := HahnSeries.puiseuxRamSubfield (AlgebraicClosure ℚ) (e := e) he
+  have hS : ∀ y, y ∈ S ↔ HahnSeries.HasRamBound e y :=
+    fun y => HahnSeries.mem_puiseuxRamSubfield_iff he
+  let T : IntermediateField (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+    (S.comap ψ.toRingHom).toIntermediateField (fun a => by
+      change ψ (algebraMap (AlgebraicClosure ℚ) _ a) ∈ S
+      rw [ψ.commutes, hS, algebraMap_hahn_eq_C]
+      exact hasRamBound_of_one he (hasRamBound_C a))
+  have hjb : jb N ∈ T := by
+    change ψ (jb N) ∈ S
+    rw [hψ, hS]
+    exact hasRamBound_of_one he (hasRamBound_C_add_single j₀)
+  have hjNb : jNb N ∈ T := by
+    change ψ (jNb N) ∈ S
+    rw [hS]; exact hbN
+  have htop := ModularCurve.adjoin_jBar_jNBar_eq_top (AlgebraicClosure ℚ) N
+  have hle : (⊤ : IntermediateField (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)) ≤ T := by
+    rw [← htop, IntermediateField.adjoin_le_iff]
+    intro z hz
+    rcases hz with rfl | rfl
+    · exact hjb
+    · exact hjNb
+  intro z
+  exact (hS _).mp (hle IntermediateField.mem_top)
+
+omit [NeZero N] in
+theorem mem_iff_ord_nonneg (w : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N))
+    {x : ↥(modularFunctionFieldBar N)} (hx : x ≠ 0) :
+    x ∈ w.toValuationSubring ↔ 0 ≤ w.ord x := by
+  rw [Place.mem_iff_adicValuation_le_one, Place.ord, neg_nonneg,
+    WithZero.log_le_iff_le_exp (w.adicValuation_ne_zero hx), WithZero.exp_zero]
+
+theorem induces_unique
+    {ψ : ↥(modularFunctionFieldBar N) →ₐ[AlgebraicClosure ℚ] HahnSeries ℚ (AlgebraicClosure ℚ)}
+    {w w' : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)}
+    (hw : Induces ψ w) (hw' : Induces ψ w') : w = w' := by
+  obtain ⟨g, hg, h⟩ := hw
+  obtain ⟨g', hg', h'⟩ := hw'
+  have key : ∀ x, 0 ≤ w.ord x ↔ 0 ≤ w'.ord x := by
+    intro x
+    have hx := h x
+    rw [← h' x] at hx
+    constructor
+    · intro h0
+      have : 0 ≤ (w'.ord x : ℚ) * g' := by rw [← hx]; positivity
+      exact_mod_cast nonneg_of_mul_nonneg_left this hg'
+    · intro h0
+      have : 0 ≤ (w.ord x : ℚ) * g := by rw [hx]; positivity
+      exact_mod_cast nonneg_of_mul_nonneg_left this hg
+  apply Place.ext
+  ext x
+  rcases eq_or_ne x 0 with rfl | hx
+  · simp [zero_mem]
+  · rw [mem_iff_ord_nonneg N w hx, mem_iff_ord_nonneg N w' hx, key]
+
+theorem pos_ord_of_induces (j₀ : AlgebraicClosure ℚ) (ψ : Emb N j₀)
+    {w : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N)} (hw : Induces ψ.1 w) :
+    0 < w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) j₀) := by
+  obtain ⟨g, hg, h⟩ := hw
+  have hx := h (jBar N - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) j₀)
+  rw [map_sub, ψ.2, AlgHom.commutes, algebraMap_hahn_eq_C, add_sub_cancel_left,
+    HahnSeries.order_single (one_ne_zero)] at hx
+  have : (0 : ℚ) < (w.ord (jBar N - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) j₀)
+    : ℚ) * g :=
+    by
+    rw [hx]; exact_mod_cast one_pos
+  exact_mod_cast pos_of_mul_pos_left this hg.le
+
+theorem exists_induces (j₀ : AlgebraicClosure ℚ) (ψ : Emb N j₀) :
+    ∃ w : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N), Induces ψ.1 w := by
+  obtain ⟨e, he, hall⟩ := exists_forall_hasRamBound N j₀ ψ.1 ψ.2
+  have hnt : ∃ x : ↥(modularFunctionFieldBar N), (ψ.1 x).order ≠ 0 := by
+    refine ⟨jBar N - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) j₀, ?_⟩
+    rw [map_sub, ψ.2, AlgHom.commutes, algebraMap_hahn_eq_C, add_sub_cancel_left,
+      HahnSeries.order_single (one_ne_zero)]
+    exact one_ne_zero
+  obtain ⟨w, g, hg, h⟩ :=
+    AlgebraicCurve.Place.exists_ord_mul_eq_order_of_hasRamBound ψ.1 he hall hnt
+  exact ⟨w, g, hg, h⟩
+
+end ModularCurve.SamePlaceTwist.InducedPlace
+
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_samePlace_iff_exists_hahnTwist.ModularCurve in
+theorem solution (N : ℕ) [NeZero N] (j₀ : AlgebraicClosure ℚ) (ψ ψ' : Emb N j₀) :
+    SamePlace ψ.1 ψ'.1 ↔
+      ∃ χ ∈ HahnSeries.MonoChar (AlgebraicClosure ℚ), ∀ x, ψ'.1 x = HahnSeries.hahnTwist χ (ψ.1 x)
+        :=
+  ModularCurve.SamePlaceTwist.exists_induces_and_induces_iff
+    (fun (w : AlgebraicCurve.Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N))
+      (x : ↥(modularFunctionFieldBar N)) => w.ord x)
+    (jBar N) j₀ ψ.1 ψ'.1 ψ.2 ψ'.2
+    (fun w => by
+      obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+      exact ⟨(π : ↥(modularFunctionFieldBar N)), w.ord_coe_irreducible hπ⟩)
+    (ModularCurve.natCard_normalized_algHom_jBar_eq_toNat_ord N j₀)
+    (ModularCurve.SamePlaceTwist.InducedPlace.exists_induces N j₀ ψ)
+
+end S_ModularCurve_samePlace_iff_exists_hahnTwist
+end P2MW
+export P2MW.S_ModularCurve_samePlace_iff_exists_hahnTwist (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.samePlace_iff_exists_hahnTwist (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ) (ψ ψ' : Emb N j₀) :
+    SamePlace ψ.1 ψ'.1 ↔
+      ∃ χ ∈ HahnSeries.MonoChar (AlgebraicClosure ℚ),
+        ∀ x, ψ'.1 x = HahnSeries.hahnTwist χ (ψ.1 x) :=
+  solution N j₀ ψ ψ'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_samePlace_iff_exists_monodromy.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_samePlace_iff_exists_monodromy.lean
new file mode 100644
index 0000000000..8c45e14aa5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_samePlace_iff_exists_monodromy.lean
@@ -0,0 +1,109 @@
+/-
+Based on Prove2Me node ModularCurve.samePlace_iff_exists_monodromy
+(e7630490-b841-57a1-ad5b-d275ba655cec) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 17b854de-b789-501e-85f0-1cb724820173
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EMD
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_Monodromy
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_samePlace_iff_exists_hahnTwist
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Places of normalised Hahn-series embeddings differ by monodromy
+
+Theorem statement: `ModularCurve.samePlace_iff_exists_monodromy`
+(`e7630490-b841-57a1-ad5b-d275ba655cec`), by Claude, 2026-09-05.
+
+Proof: submission `17b854de-b789-501e-85f0-1cb724820173`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number with $N \neq 0$, let $j_0 \in \overline{\mathbb{Q}}$, and let $\psi,
+\psi'$ be elements of `Emb N j₀`, that is, $\overline{\mathbb{Q}}$-algebra homomorphisms from the
+field `modularFunctionFieldBar N` (the base change to $\overline{\mathbb{Q}}$ of the full level-$N$
+modular function field, an intermediate field of the Laurent series over $\overline{\mathbb{Q}}$)
+into the Hahn series $\mathrm{HahnSeries}\,\mathbb{Q}\,\overline{\mathbb{Q}}$ with rational
+exponents, each sending the distinguished element `jBar N` to $j_0 + t$, where $t$ is the monomial
+`single 1 1` of exponent $1$ and coefficient $1$. The theorem asserts the equivalence of two
+conditions. First, `SamePlace ψ.1 ψ'.1`: there is a place $w$ of `modularFunctionFieldBar N` over
+$\overline{\mathbb{Q}}$ (a proper valuation subring containing the image of $\overline{\mathbb{Q}}$
+and a principal ideal ring) which both $\psi$ and $\psi'$ induce, where $\psi$ induces $w$ when
+there is a rational $g > 0$ with $(\mathrm{ord}_w x)\,g = \mathrm{order}(\psi\,x)$ for every $x$
+(the scaling factor $g$ may differ for $\psi$ and $\psi'$). Second: there is an element $m$ of the
+subgroup `monodromy` of $\overline{\mathbb{Q}}$-algebra automorphisms of
+$\mathrm{HahnSeries}\,\mathbb{Q}\,\overline{\mathbb{Q}}$, namely the image under `hahnTwistHom` of
+the group `MonoChar` of monoid homomorphisms $\chi : \mathbb{Q} \to \overline{\mathbb{Q}}^{\times}$
+(written multiplicatively) with $\chi(1) = 1$, each such $\chi$ acting by scaling the coefficient of
+exponent $a$ by $\chi(a)$, such that $\psi$ followed by $m$ equals $\psi'$ as algebra homomorphisms.
+
+This identifies the fibres of the map from normalised Hahn-series expansions at $j_0$ to places of
+the level-$N$ modular function field: two normalised embeddings induce the same place exactly when
+they differ by a coefficientwise twist fixing the exponent-$1$ coefficient. It is used in the
+construction of elliptic points and cyclic-subgroup orbit maps on the modular curve, through
+[`ModularCurve.exists_elliptic_cycSub_orbitMap_of_props`]
+(thm.html#ModularCurve.exists_elliptic_cycSub_orbitMap_of_props)
+and
+[`ModularCurve.exists_elliptic_cycSub_orbitMap_prime_of_ne_two`]
+(thm.html#ModularCurve.exists_elliptic_cycSub_orbitMap_prime_of_ne_two).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_samePlace_iff_exists_monodromy.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_samePlace_iff_exists_monodromy
+
+open HahnSeries ModularCurve AlgebraicCurve
+
+theorem solution (N : ℕ) [NeZero N] (j₀ : AlgebraicClosure ℚ)
+    (ψ ψ' : Emb N j₀) :
+    SamePlace ψ.1 ψ'.1 ↔
+      ∃ m ∈ monodromy (AlgebraicClosure ℚ),
+        (↑m : HahnSeries ℚ (AlgebraicClosure ℚ) →ₐ[AlgebraicClosure ℚ]
+          HahnSeries ℚ (AlgebraicClosure ℚ)).comp ψ.1 = ψ'.1 := by
+  rw [ModularCurve.samePlace_iff_exists_hahnTwist]
+  constructor
+  · rintro ⟨χ, hχ, h⟩
+    refine ⟨hahnTwistHom χ, Subgroup.mem_map_of_mem _ hχ, AlgHom.ext fun x => ?_⟩
+    simpa only [AlgHom.comp_apply, hahnTwistHom_apply, AlgEquiv.toAlgHom_apply] using
+      (h x).symm
+  · rintro ⟨m, hm, h⟩
+    obtain ⟨χ, hχ, rfl⟩ := Subgroup.mem_map.mp hm
+    refine ⟨χ, hχ, fun x => ?_⟩
+    simpa only [AlgHom.comp_apply, hahnTwistHom_apply, AlgEquiv.toAlgHom_apply] using
+      (AlgHom.congr_fun h x).symm
+
+end S_ModularCurve_samePlace_iff_exists_monodromy
+end P2MW
+export P2MW.S_ModularCurve_samePlace_iff_exists_monodromy (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open HahnSeries ModularCurve AlgebraicCurve
+theorem ModularCurve.samePlace_iff_exists_monodromy (N : ℕ) [NeZero N] (j₀ : AlgebraicClosure ℚ)
+    (ψ ψ' : Emb N j₀) :
+    SamePlace ψ.1 ψ'.1 ↔
+      ∃ m ∈ monodromy (AlgebraicClosure ℚ),
+        (↑m : HahnSeries ℚ (AlgebraicClosure ℚ) →ₐ[AlgebraicClosure ℚ]
+          HahnSeries ℚ (AlgebraicClosure ℚ)).comp ψ.1 = ψ'.1 :=
+  solution N j₀ ψ ψ'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_six_mul_level_mul_finrank_parabolicHoms_Gamma_add_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_six_mul_level_mul_finrank_parabolicHoms_Gamma_add_eq.lean
new file mode 100644
index 0000000000..7a91b9e4ba
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_six_mul_level_mul_finrank_parabolicHoms_Gamma_add_eq.lean
@@ -0,0 +1,630 @@
+/-
+Based on Prove2Me node ModularCurve.six_mul_level_mul_finrank_parabolicHoms_Gamma_add_eq
+(519171ea-ebbc-5f2e-b68a-09223cae681b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a35ca822-2aca-5b04-9567-245ee17b3b6d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PeriodMap
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import Mathlib.GroupTheory.Transfer
+import Mathlib.NumberTheory.NumberField.Basic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Matrix_SpecialLinearGroup_finrank_addMonoidHom_eq_of_forall_trace_ne
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_Period_existsUnique_isParabolicHom_sup_zpowers_neg_one_apply_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_Period_exists_basis_parabolicHoms_castAddHom_comp
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_Period_finrank_parabolicHoms_add_natCard_le_finrank_addMonoidHom_add_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularGroup_exists_eq_conj_T_zpow_of_trace_sq_eq_four
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Parabolic cohomology rank of Γ(N), denominator-free form
+
+Theorem statement: `ModularCurve.six_mul_level_mul_finrank_parabolicHoms_Gamma_add_eq`
+(`519171ea-ebbc-5f2e-b68a-09223cae681b`), by Claude, 2026-09-05.
+
+Proof: submission `a35ca822-2aca-5b04-9567-245ee17b3b6d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number with $2 \le N$, let $\Gamma(N) \le \mathrm{SL}_2(\mathbb{Z})$ be the
+principal congruence subgroup of level $N$, and let $\mu_N$ denote the index in
+$\mathrm{SL}_2(\mathbb{Z})$ of the subgroup $\Gamma(N) \sqcup \langle -1 \rangle$ generated by
+$\Gamma(N)$ together with $-1$. Let $\mathrm{Hom}_{\mathrm{par}}(\Gamma(N), \mathbb{Z})$ be the
+$\mathbb{Z}$-submodule of the additive group of homomorphisms from the additivisation of $\Gamma(N)$
+to $\mathbb{Z}$ consisting of those $\varphi$ that vanish on every $\gamma \in \Gamma(N)$ whose
+matrix trace satisfies $\mathrm{tr}(\gamma)^2 = 4$, i.e. on all elements of trace $\pm 2$; this is
+the group-theoretic parabolic cohomology of $\Gamma(N)$ with $\mathbb{Z}$-coefficients. The
+assertion is the identity of natural numbers
+$$6N \cdot \mathrm{rank}_{\mathbb{Z}} \, \mathrm{Hom}_{\mathrm{par}}(\Gamma(N), \mathbb{Z}) + 6\mu_N
+= 12N + N\mu_N,$$
+where the rank is the $\mathbb{Z}$-module rank (`Module.finrank`). Written with denominators, this
+says that the rank equals $2\bigl(1 + \mu_N (N-6)/(12N)\bigr)$, twice the genus of $X(N)$; the form
+above avoids division and subtraction.
+
+This is the group-cohomological half of the classical computation $\mathrm{rank}\,
+H^1_{\mathrm{par}}(\Gamma(N), \mathbb{Z}) = 2\,g(X(N))$, obtained from the freeness of the image of
+$\Gamma(N)$ in $\mathrm{PSL}_2(\mathbb{Z})$ (no nontrivial torsion for $N \ge 2$) together with the
+count of cusps, i.e. of orbits of $\langle T \rangle$ on $\mathrm{SL}_2(\mathbb{Z})/\Gamma(N)$. It
+is used to bound the rank of parabolic cohomology of $\Gamma(N)$ by twice the dimension of the space
+of cusp forms of weight $2$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_six_mul_level_mul_finrank_parabolicHoms_Gamma_add_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_six_mul_level_mul_finrank_parabolicHoms_Gamma_add_eq
+
+open scoped MatrixGroups
+
+namespace BettiPrincipal
+
+open MulAction Function ModularCurve.Period
+
+theorem S_sq : ModularGroup.S * ModularGroup.S = (-1 : SL(2, ℤ)) := by
+  apply Subtype.ext
+  rw [Matrix.SpecialLinearGroup.coe_mul]
+  simpa using ModularGroup.S_mul_S_eq
+
+theorem S_pow_four : ModularGroup.S ^ 4 = (1 : SL(2, ℤ)) := by
+  rw [show (4 : ℕ) = 2 * 2 from rfl, pow_mul, sq ModularGroup.S, S_sq, neg_one_sq]
+
+theorem ST_pow_three : (ModularGroup.S * ModularGroup.T) ^ 3 = (-1 : SL(2, ℤ)) := by
+  apply Subtype.ext
+  simp only [Matrix.SpecialLinearGroup.coe_pow, Matrix.SpecialLinearGroup.coe_mul,
+    ModularGroup.coe_S, ModularGroup.coe_T, Matrix.SpecialLinearGroup.coe_neg,
+    Matrix.SpecialLinearGroup.coe_one]
+  ext i j
+  fin_cases i <;> fin_cases j <;>
+    simp [pow_succ, Matrix.one_fin_two]
+
+theorem ST_pow_six : (ModularGroup.S * ModularGroup.T) ^ 6 = (1 : SL(2, ℤ)) := by
+  rw [show (6 : ℕ) = 3 * 2 from rfl, pow_mul, ST_pow_three, neg_one_sq]
+
+theorem hom_T_eq_one (f : SL(2, ℤ) →* Multiplicative ℚ) : f ModularGroup.T = 1 := by
+  have hS : f ModularGroup.S = 1 := by
+    have h : (f ModularGroup.S) ^ 4 = 1 := by rw [← map_pow, S_pow_four, map_one]
+    have h' := congrArg Multiplicative.toAdd h
+    rw [toAdd_pow, toAdd_one, smul_eq_zero] at h'
+    rcases h' with h' | h'
+    · norm_num at h'
+    · exact toAdd_eq_zero.mp h'
+  have hU : f (ModularGroup.S * ModularGroup.T) = 1 := by
+    have h : (f (ModularGroup.S * ModularGroup.T)) ^ 6 = 1 := by
+      rw [← map_pow, ST_pow_six, map_one]
+    have h' := congrArg Multiplicative.toAdd h
+    rw [toAdd_pow, toAdd_one, smul_eq_zero] at h'
+    rcases h' with h' | h'
+    · norm_num at h'
+    · exact toAdd_eq_zero.mp h'
+  have : ModularGroup.T = ModularGroup.S⁻¹ * (ModularGroup.S * ModularGroup.T) := by
+    rw [inv_mul_cancel_left]
+  rw [this, map_mul, map_inv, hS, hU, inv_one, one_mul]
+
+section General
+
+variable (Γ : Subgroup SL(2, ℤ))
+
+abbrev Cusp : Type := orbitRel.Quotient (Subgroup.zpowers ModularGroup.T) (SL(2, ℤ) ⧸ Γ)
+
+noncomputable scoped instance instFintypeCusp [Γ.FiniteIndex] : Fintype (Cusp Γ) := Fintype.ofFinite
+  _
+
+noncomputable def width (x : SL(2, ℤ) ⧸ Γ) : ℕ := minimalPeriod (ModularGroup.T • ·) x
+
+theorem conj_zpow_mem_iff (g : SL(2, ℤ)) (n : ℤ) :
+    g⁻¹ * ModularGroup.T ^ n * g ∈ Γ ↔ (width Γ (g : SL(2, ℤ) ⧸ Γ) : ℤ) ∣ n := by
+  rw [mul_assoc, ← QuotientGroup.eq, ← smul_eq_mul, ← MulAction.Quotient.smul_coe, eq_comm,
+    zpow_smul_eq_iff_minimalPeriod_dvd]
+  rfl
+
+noncomputable def gen (g : SL(2, ℤ)) : SL(2, ℤ) :=
+  g⁻¹ * ModularGroup.T ^ ((width Γ (g : SL(2, ℤ) ⧸ Γ) : ℕ) : ℤ) * g
+
+theorem gen_mem (g : SL(2, ℤ)) : gen Γ g ∈ Γ :=
+  (conj_zpow_mem_iff Γ g (width Γ (g : SL(2, ℤ) ⧸ Γ))).mpr (dvd_refl _)
+
+noncomputable def genΓ (g : SL(2, ℤ)) : Γ := ⟨gen Γ g, gen_mem Γ g⟩
+
+variable {Γ}
+
+theorem conj_conj (g γ₀ : SL(2, ℤ)) (n m : ℤ) :
+    (ModularGroup.T ^ n * g * γ₀)⁻¹ * ModularGroup.T ^ m * (ModularGroup.T ^ n * g * γ₀) =
+      γ₀⁻¹ * (g⁻¹ * ModularGroup.T ^ m * g) * γ₀ := by
+  have hc : ModularGroup.T ^ m * ModularGroup.T ^ n = ModularGroup.T ^ n * ModularGroup.T ^ m :=
+    zpow_mul_comm _ _ _
+  simp only [mul_inv_rev, mul_assoc]
+  rw [← mul_assoc (ModularGroup.T ^ m) (ModularGroup.T ^ n), hc, mul_assoc (ModularGroup.T ^ n),
+    inv_mul_cancel_left]
+
+theorem exists_of_mem_orbit {g g' : SL(2, ℤ)}
+    (h : (g' : SL(2, ℤ) ⧸ Γ) ∈ orbit (Subgroup.zpowers ModularGroup.T) (g : SL(2, ℤ) ⧸ Γ)) :
+    ∃ (n : ℤ) (γ₀ : SL(2, ℤ)), γ₀ ∈ Γ ∧ g' = ModularGroup.T ^ n * g * γ₀ := by
+  obtain ⟨⟨k, hk⟩, hk'⟩ := h
+  obtain ⟨n, rfl⟩ := Subgroup.mem_zpowers_iff.mp hk
+  refine ⟨n, (ModularGroup.T ^ n * g)⁻¹ * g', ?_, by rw [mul_inv_cancel_left]⟩
+  rw [← QuotientGroup.eq]
+  change ModularGroup.T ^ n • (g : SL(2, ℤ) ⧸ Γ) = g' at hk'
+  rw [MulAction.Quotient.smul_coe, smul_eq_mul] at hk'
+  exact hk'
+
+theorem width_eq_of_mem_orbit {g g' : SL(2, ℤ)}
+    (h : (g' : SL(2, ℤ) ⧸ Γ) ∈ orbit (Subgroup.zpowers ModularGroup.T) (g : SL(2, ℤ) ⧸ Γ)) :
+    width Γ (g' : SL(2, ℤ) ⧸ Γ) = width Γ (g : SL(2, ℤ) ⧸ Γ) := by
+  obtain ⟨n, γ₀, hγ₀, rfl⟩ := exists_of_mem_orbit h
+  have key : ∀ m : ℤ, (ModularGroup.T ^ n * g * γ₀)⁻¹ * ModularGroup.T ^ m *
+      (ModularGroup.T ^ n * g * γ₀) ∈ Γ ↔ g⁻¹ * ModularGroup.T ^ m * g ∈ Γ := by
+    intro m
+    rw [conj_conj, Subgroup.mul_mem_cancel_right _ hγ₀,
+      Subgroup.mul_mem_cancel_left _ (Γ.inv_mem hγ₀)]
+  apply Nat.dvd_antisymm
+  · have := (conj_zpow_mem_iff Γ (ModularGroup.T ^ n * g * γ₀) (width Γ (g : SL(2, ℤ) ⧸ Γ))).mp
+      ((key _).mpr ((conj_zpow_mem_iff Γ g _).mpr (dvd_refl _)))
+    exact Int.natCast_dvd_natCast.mp this
+  · have := (conj_zpow_mem_iff Γ g
+      (width Γ ((ModularGroup.T ^ n * g * γ₀ : SL(2, ℤ)) : SL(2, ℤ) ⧸ Γ))).mp
+      ((key _).mp ((conj_zpow_mem_iff Γ _ _).mpr (dvd_refl _)))
+    exact Int.natCast_dvd_natCast.mp this
+
+variable {A : Type*} [AddCommGroup A] (φ : Additive Γ →+ A)
+
+theorem apply_gen_eq_of_mem_orbit {g g' : SL(2, ℤ)}
+    (h : (g' : SL(2, ℤ) ⧸ Γ) ∈ orbit (Subgroup.zpowers ModularGroup.T) (g : SL(2, ℤ) ⧸ Γ)) :
+    φ (Additive.ofMul (genΓ Γ g')) = φ (Additive.ofMul (genΓ Γ g)) := by
+  have hw := width_eq_of_mem_orbit h
+  obtain ⟨n, γ₀, hγ₀, rfl⟩ := exists_of_mem_orbit h
+  have hconj : genΓ Γ (ModularGroup.T ^ n * g * γ₀) = ⟨γ₀, hγ₀⟩⁻¹ * genΓ Γ g * ⟨γ₀, hγ₀⟩ := by
+    apply Subtype.ext
+    simp only [genΓ, gen, Subgroup.coe_mul, Subgroup.coe_inv, hw]
+    exact conj_conj g γ₀ n _
+  rw [hconj, ofMul_mul, ofMul_mul, ofMul_inv, map_add, map_add, map_neg]
+  abel
+
+theorem apply_conj_zpow {g : SL(2, ℤ)} {n : ℤ} (hn : g⁻¹ * ModularGroup.T ^ n * g ∈ Γ) :
+    ∃ t : ℤ, φ (Additive.ofMul (⟨_, hn⟩ : Γ)) = t • φ (Additive.ofMul (genΓ Γ g)) := by
+  obtain ⟨t, ht⟩ := (conj_zpow_mem_iff Γ g n).mp hn
+  refine ⟨t, ?_⟩
+  have : (⟨_, hn⟩ : Γ) = genΓ Γ g ^ t := by
+    apply Subtype.ext
+    simp only [Subgroup.coe_zpow, genΓ, gen]
+    rw [ht, zpow_mul]
+    have := (conj_zpow (a := g⁻¹)
+      (b := ModularGroup.T ^ ((width Γ (g : SL(2, ℤ) ⧸ Γ) : ℕ) : ℤ)) (i := t))
+    rw [inv_inv] at this
+    exact this.symm
+  rw [this, ofMul_zpow, map_zsmul]
+
+variable [Γ.FiniteIndex]
+
+noncomputable def cuspGen (q : Cusp Γ) : Γ :=
+  ⟨q.out.out⁻¹ * ModularGroup.T ^ minimalPeriod (ModularGroup.T • ·) q.out * q.out.out,
+    QuotientGroup.out_conj_pow_minimalPeriod_mem Γ ModularGroup.T q.out⟩
+
+omit [Γ.FiniteIndex] in
+theorem cuspGen_eq (q : Cusp Γ) : cuspGen q = genΓ Γ q.out.out := by
+  apply Subtype.ext
+  simp only [cuspGen, genΓ, gen, width, QuotientGroup.out_eq', zpow_natCast]
+
+theorem sum_apply_cuspGen_eq_zero (φ : Additive Γ →+ ℚ) :
+    ∑ q : Cusp Γ, φ (Additive.ofMul (cuspGen q)) = 0 := by
+  have h := (AddMonoidHom.toMultiplicativeRight φ).transfer_eq_prod_quotient_orbitRel_zpowers_quot
+    ModularGroup.T
+  rw [hom_T_eq_one] at h
+  have h' := congrArg Multiplicative.toAdd h
+  rw [toAdd_one, toAdd_prod] at h'
+  rw [h']
+  rfl
+
+omit [Γ.FiniteIndex] in
+theorem apply_gen_eq_zero_of_forall (h : ∀ q : Cusp Γ, φ (Additive.ofMul (cuspGen q)) = 0)
+    (g : SL(2, ℤ)) : φ (Additive.ofMul (genΓ Γ g)) = 0 := by
+  set q : Cusp Γ := Quotient.mk _ (g : SL(2, ℤ) ⧸ Γ) with hq
+  have hmem : ((q.out.out : SL(2, ℤ)) : SL(2, ℤ) ⧸ Γ) ∈
+      orbit (Subgroup.zpowers ModularGroup.T) (g : SL(2, ℤ) ⧸ Γ) := by
+    rw [QuotientGroup.out_eq']
+    exact Quotient.mk_out (s := orbitRel (Subgroup.zpowers ModularGroup.T) (SL(2, ℤ) ⧸ Γ))
+      (g : SL(2, ℤ) ⧸ Γ)
+  rw [← apply_gen_eq_of_mem_orbit φ hmem, ← cuspGen_eq]
+  exact h q
+
+omit [Γ.FiniteIndex] in
+theorem isParabolicHom_of_forall (hneg : (-1 : SL(2, ℤ)) ∈ Γ)
+    (h : ∀ q : Cusp Γ, φ (Additive.ofMul (cuspGen q)) = 0)
+    (htors : ∀ a : A, 2 • a = 0 → a = 0) : IsParabolicHom Γ φ := by
+  intro γ hγ
+  obtain ⟨ε, δ, k, hε, hγε⟩ := ModularGroup.exists_eq_conj_T_zpow_of_trace_sq_eq_four γ hγ
+  have hεmem : ε ∈ Γ := by
+    rcases hε with rfl | rfl
+    · exact Γ.one_mem
+    · exact hneg
+  have hφε : φ (Additive.ofMul ⟨ε, hεmem⟩) = 0 := by
+    apply htors
+    rw [two_nsmul, ← map_add, ← ofMul_mul]
+    have : (⟨ε, hεmem⟩ : Γ) * ⟨ε, hεmem⟩ = 1 := by
+      apply Subtype.ext
+      rcases hε with rfl | rfl <;> simp
+    rw [this, ofMul_one, map_zero]
+  have hpmem : δ⁻¹⁻¹ * ModularGroup.T ^ k * δ⁻¹ ∈ Γ := by
+    rw [inv_inv]
+    have : δ * ModularGroup.T ^ k * δ⁻¹ = ε⁻¹ * γ := by
+      rw [hγε, inv_mul_cancel_left]
+    rw [this]
+    exact Γ.mul_mem (Γ.inv_mem hεmem) γ.2
+  obtain ⟨t, ht⟩ := apply_conj_zpow φ hpmem
+  rw [apply_gen_eq_zero_of_forall φ h, smul_zero] at ht
+  have hsplit : γ = ⟨ε, hεmem⟩ * ⟨_, hpmem⟩ := by
+    apply Subtype.ext
+    simp only [Subgroup.coe_mul, inv_inv]
+    exact hγε
+  rw [hsplit, ofMul_mul, map_add, hφε, ht, add_zero]
+
+noncomputable def ev : (Additive Γ →+ ℚ) →ₗ[ℚ] (Cusp Γ → ℚ) where
+  toFun φ q := φ (Additive.ofMul (cuspGen q))
+  map_add' _ _ := rfl
+  map_smul' _ _ := rfl
+
+noncomputable def sumL : (Cusp Γ → ℚ) →ₗ[ℚ] ℚ := ∑ q : Cusp Γ, LinearMap.proj q
+
+omit [Γ.FiniteIndex] in
+theorem sumL_apply [Γ.FiniteIndex] (v : Cusp Γ → ℚ) : sumL v = ∑ q, v q := by
+  simp [sumL]
+
+theorem range_ev_le : LinearMap.range (ev (Γ := Γ)) ≤ LinearMap.ker (sumL (Γ := Γ)) := by
+  rintro _ ⟨φ, rfl⟩
+  rw [LinearMap.mem_ker, sumL_apply]
+  exact sum_apply_cuspGen_eq_zero φ
+
+scoped instance nonempty_cusp : Nonempty (Cusp Γ) := ⟨Quotient.mk _ ((1 : SL(2, ℤ)) : SL(2, ℤ) ⧸ Γ)⟩
+
+theorem finrank_ker_sumL_add_one :
+    Module.finrank ℚ (LinearMap.ker (sumL (Γ := Γ))) + 1 = Nat.card (Cusp Γ) := by
+  classical
+  obtain ⟨q₀⟩ := nonempty_cusp (Γ := Γ)
+  have hsurj : LinearMap.range (sumL (Γ := Γ)) = ⊤ := by
+    rw [LinearMap.range_eq_top]
+    intro r
+    refine ⟨Pi.single q₀ r, ?_⟩
+    rw [sumL_apply, Finset.sum_pi_single']
+    simp
+  have h := LinearMap.finrank_range_add_finrank_ker (sumL (Γ := Γ))
+  rw [hsurj, finrank_top, Module.finrank_self, Module.finrank_fintype_fun_eq_card] at h
+  rw [Nat.card_eq_fintype_card]
+  omega
+
+omit [Γ.FiniteIndex] in
+theorem ker_ev_le (hneg : (-1 : SL(2, ℤ)) ∈ Γ) :
+    LinearMap.ker (ev (Γ := Γ)) ≤ parabolicHoms ℚ Γ ℚ := by
+  intro φ hφ
+  rw [mem_parabolicHoms_iff]
+  refine isParabolicHom_of_forall φ hneg (fun q => ?_) (fun a ha => ?_)
+  · exact congrFun (LinearMap.mem_ker.mp hφ) q
+  · rcases smul_eq_zero.mp ha with h | h
+    · norm_num at h
+    · exact h
+
+theorem finrank_addMonoidHom_add_one_le (hneg : (-1 : SL(2, ℤ)) ∈ Γ) :
+    Module.finrank ℚ (Additive Γ →+ ℚ) + 1 ≤
+      Module.finrank ℚ (parabolicHoms ℚ Γ ℚ) + Nat.card (Cusp Γ) := by
+  have hc := finrank_ker_sumL_add_one (Γ := Γ)
+  by_cases hfin : Module.Finite ℚ (Additive Γ →+ ℚ)
+  · have h1 := LinearMap.finrank_range_add_finrank_ker (ev (Γ := Γ))
+    have h2 : Module.finrank ℚ (LinearMap.range (ev (Γ := Γ))) ≤
+        Module.finrank ℚ (LinearMap.ker (sumL (Γ := Γ))) := Submodule.finrank_mono range_ev_le
+    have h3 : Module.finrank ℚ (LinearMap.ker (ev (Γ := Γ))) ≤
+        Module.finrank ℚ (parabolicHoms ℚ Γ ℚ) := Submodule.finrank_mono (ker_ev_le hneg)
+    omega
+  · rw [Module.finrank_of_not_finite hfin]
+    omega
+
+end General
+
+section Principal
+
+variable (N : ℕ)
+
+abbrev Gpm : Subgroup SL(2, ℤ) := CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))
+
+scoped instance zpowers_neg_one_normal : (Subgroup.zpowers (-1 : SL(2, ℤ))).Normal :=
+  ⟨fun n hn g => by
+    obtain ⟨k, rfl⟩ := Subgroup.mem_zpowers_iff.mp hn
+    have hc : Commute g ((-1 : SL(2, ℤ)) ^ k) := (Commute.neg_one_right g).zpow_right k
+    rw [hc.eq, mul_inv_cancel_right]
+    exact Subgroup.zpow_mem _ (Subgroup.mem_zpowers _) k⟩
+
+theorem neg_one_mem_Gpm : (-1 : SL(2, ℤ)) ∈ Gpm N :=
+  Subgroup.mem_sup_right (Subgroup.mem_zpowers _)
+
+theorem mem_Gpm_of_mem {g : SL(2, ℤ)} (hg : g ∈ CongruenceSubgroup.Gamma N) : g ∈ Gpm N :=
+  Subgroup.mem_sup_left hg
+
+theorem neg_mem_Gpm {g : SL(2, ℤ)} (hg : g ∈ Gpm N) : -g ∈ Gpm N := by
+  rw [← neg_one_mul]; exact (Gpm N).mul_mem (neg_one_mem_Gpm N) hg
+
+theorem exists_of_mem_Gpm {g : SL(2, ℤ)} (hg : g ∈ Gpm N) :
+    ∃ γ : SL(2, ℤ), γ ∈ CongruenceSubgroup.Gamma N ∧ (g = γ ∨ g = -γ) := by
+  obtain ⟨y, hy, z, hz, rfl⟩ := Subgroup.mem_sup_of_normal_right.mp hg
+  obtain ⟨k, rfl⟩ := Subgroup.mem_zpowers_iff.mp hz
+  refine ⟨y, hy, ?_⟩
+  have h2 : ((-1 : SL(2, ℤ)) ^ (2 : ℤ)) = 1 := by rw [zpow_two]; simp
+  rcases Int.even_or_odd k with ⟨m, rfl⟩ | ⟨m, rfl⟩
+  · left
+    rw [← two_mul, zpow_mul, h2, one_zpow, mul_one]
+  · right
+    rw [zpow_add, zpow_mul, h2, one_zpow, one_mul, zpow_one, mul_neg_one]
+
+scoped instance Gpm_finiteIndex [NeZero N] : (Gpm N).FiniteIndex :=
+  Subgroup.finiteIndex_of_le (le_sup_left : CongruenceSubgroup.Gamma N ≤ Gpm N)
+
+theorem Gpm_normal : (Gpm N).Normal := by
+  refine ⟨fun g hg x => ?_⟩
+  obtain ⟨γ, hγ, h⟩ := exists_of_mem_Gpm N hg
+  have hc : x * γ * x⁻¹ ∈ CongruenceSubgroup.Gamma N :=
+    (CongruenceSubgroup.Gamma_normal N).conj_mem γ hγ x
+  rcases h with rfl | rfl
+  · exact mem_Gpm_of_mem N hc
+  · rw [mul_neg, neg_mul]
+    exact neg_mem_Gpm N (mem_Gpm_of_mem N hc)
+
+theorem conj_mem_Gpm_iff (g x : SL(2, ℤ)) : g⁻¹ * x * g ∈ Gpm N ↔ x ∈ Gpm N := by
+  constructor
+  · intro h
+    have := (Gpm_normal N).conj_mem _ h g
+    rwa [show g * (g⁻¹ * x * g) * g⁻¹ = x by group] at this
+  · intro h
+    have := (Gpm_normal N).conj_mem _ h g⁻¹
+    rwa [inv_inv] at this
+
+theorem sq_dvd_two_sub_trace {γ : SL(2, ℤ)} (hγ : γ ∈ CongruenceSubgroup.Gamma N) :
+    ((N : ℤ) ^ 2) ∣ 2 - (γ : Matrix (Fin 2) (Fin 2) ℤ).trace := by
+  rw [CongruenceSubgroup.Gamma_mem] at hγ
+  obtain ⟨ha, hb, hc, hd⟩ := hγ
+  have ha' : (N : ℤ) ∣ 1 - (γ : Matrix (Fin 2) (Fin 2) ℤ) 0 0 :=
+    (ZMod.intCast_eq_intCast_iff_dvd_sub _ 1 N).mp (ha.trans (Int.cast_one (R := ZMod N)).symm)
+  have hd' : (N : ℤ) ∣ 1 - (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 1 :=
+    (ZMod.intCast_eq_intCast_iff_dvd_sub _ 1 N).mp (hd.trans (Int.cast_one (R := ZMod N)).symm)
+  have hb' : (N : ℤ) ∣ (γ : Matrix (Fin 2) (Fin 2) ℤ) 0 1 :=
+    (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp hb
+  have hc' : (N : ℤ) ∣ (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 0 :=
+    (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp hc
+  have hdet : (γ : Matrix (Fin 2) (Fin 2) ℤ) 0 0 * (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 1 -
+      (γ : Matrix (Fin 2) (Fin 2) ℤ) 0 1 * (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 0 = 1 := by
+    have := Matrix.SpecialLinearGroup.det_coe γ
+    rwa [Matrix.det_fin_two] at this
+  have key : 2 - (γ : Matrix (Fin 2) (Fin 2) ℤ).trace =
+      (1 - (γ : Matrix (Fin 2) (Fin 2) ℤ) 0 0) * (1 - (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 1) -
+        (γ : Matrix (Fin 2) (Fin 2) ℤ) 0 1 * (γ : Matrix (Fin 2) (Fin 2) ℤ) 1 0 := by
+    rw [Matrix.trace_fin_two]
+    linear_combination (-1 : ℤ) * hdet
+  rw [key, sq]
+  exact dvd_sub (mul_dvd_mul ha' hd') (mul_dvd_mul hb' hc')
+
+theorem trace_ne (hN : 2 ≤ N) (g : SL(2, ℤ)) (hg : g ∈ Gpm N) :
+    (g : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 0 ∧ (g : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 1 ∧
+      (g : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ -1 := by
+  obtain ⟨γ, hγ, h⟩ := exists_of_mem_Gpm N hg
+  have hd := sq_dvd_two_sub_trace N hγ
+  have h4 : (4 : ℤ) ≤ (N : ℤ) ^ 2 := by
+    have : (2 : ℤ) ≤ N := by exact_mod_cast hN
+    nlinarith
+  have htr : (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 0 ∧ (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ 1 ∧
+      (γ : Matrix (Fin 2) (Fin 2) ℤ).trace ≠ -1 := by
+    refine ⟨fun ht => ?_, fun ht => ?_, fun ht => ?_⟩ <;>
+    · rw [ht] at hd
+      have := Int.le_of_dvd (by norm_num) hd
+      linarith
+  rcases h with rfl | rfl
+  · exact htr
+  · rw [Matrix.SpecialLinearGroup.coe_neg, Matrix.trace_neg]
+    omega
+
+theorem T_zpow_mem_Gpm_iff [NeZero N] (n : ℤ) :
+    ModularGroup.T ^ n ∈ Gpm N ↔ (N : ℤ) ∣ n := by
+  constructor
+  · intro h
+    obtain ⟨γ, hγ, h⟩ := exists_of_mem_Gpm N h
+    rw [CongruenceSubgroup.Gamma_mem] at hγ
+    have hb := hγ.2.1
+    rcases h with h | h
+    · rw [← h, ModularGroup.coe_T_zpow] at hb
+      simp only [Matrix.of_apply, Matrix.cons_val', Matrix.cons_val_zero, Matrix.cons_val_one,
+        Matrix.cons_val_fin_one, Matrix.empty_val'] at hb
+      exact (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp hb
+    · have h' : γ = -(ModularGroup.T ^ n) := by rw [h, neg_neg]
+      rw [h', Matrix.SpecialLinearGroup.coe_neg, ModularGroup.coe_T_zpow] at hb
+      simp only [Matrix.neg_apply, Matrix.of_apply, Matrix.cons_val', Matrix.cons_val_zero,
+        Matrix.cons_val_one, Matrix.cons_val_fin_one, Matrix.empty_val', Int.cast_neg,
+        neg_eq_zero] at hb
+      exact (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp hb
+  · intro h
+    apply mem_Gpm_of_mem
+    have := CongruenceSubgroup.ModularGroup_T_pow_mem_Gamma (N : ℤ) n h
+    rwa [Int.natAbs_natCast] at this
+
+theorem width_Gpm [NeZero N] (x : SL(2, ℤ) ⧸ Gpm N) : width (Gpm N) x = N := by
+  induction x using QuotientGroup.induction_on with
+  | H g =>
+    have key : ∀ n : ℤ, (width (Gpm N) (g : SL(2, ℤ) ⧸ Gpm N) : ℤ) ∣ n ↔ (N : ℤ) ∣ n := by
+      intro n
+      rw [← conj_zpow_mem_iff, conj_mem_Gpm_iff, T_zpow_mem_Gpm_iff]
+    apply Nat.dvd_antisymm
+    · exact Int.natCast_dvd_natCast.mp ((key N).mpr (dvd_refl _))
+    · exact Int.natCast_dvd_natCast.mp ((key _).mp (dvd_refl _))
+
+theorem index_Gpm_eq [NeZero N] : (Gpm N).index = N * Nat.card (Cusp (Gpm N)) := by
+  rw [Subgroup.index_eq_sum_minimalPeriod (Gpm N) ModularGroup.T]
+  have : ∀ q : Cusp (Gpm N), minimalPeriod (ModularGroup.T • ·) q.out = N :=
+    fun q => width_Gpm N q.out
+  simp only [this, Finset.sum_const, Finset.card_univ, smul_eq_mul, Nat.card_eq_fintype_card,
+    mul_comm]
+
+theorem dvd_index_of_pow_eq (hN : 2 ≤ N) (u : SL(2, ℤ)) (p : ℕ) [Fact p.Prime]
+    (hu : u ^ p = -1)
+    (htr : (u : Matrix (Fin 2) (Fin 2) ℤ).trace = 0 ∨ (u : Matrix (Fin 2) (Fin 2) ℤ).trace = 1 ∨
+      (u : Matrix (Fin 2) (Fin 2) ℤ).trace = -1) :
+    p ∣ (Gpm N).index := by
+  have : NeZero N := ⟨by omega⟩
+  have : Fintype (orbitRel.Quotient (Subgroup.zpowers u) (SL(2, ℤ) ⧸ Gpm N)) := Fintype.ofFinite _
+  have hper : ∀ x : SL(2, ℤ) ⧸ Gpm N, minimalPeriod (u • ·) x = p := by
+    intro x
+    induction x using QuotientGroup.induction_on with
+    | H g =>
+      apply minimalPeriod_eq_prime
+      · change (u • ·)^[p] (g : SL(2, ℤ) ⧸ Gpm N) = g
+        rw [smul_iterate]
+        change u ^ p • (g : SL(2, ℤ) ⧸ Gpm N) = g
+        rw [hu, MulAction.Quotient.smul_coe, smul_eq_mul, QuotientGroup.eq]
+        rw [show (-1 * g)⁻¹ * g = -1 by
+          rw [mul_inv_rev, inv_neg, inv_one, mul_neg_one, neg_mul, inv_mul_cancel]]
+        exact neg_one_mem_Gpm N
+      · intro hfix
+        change u • (g : SL(2, ℤ) ⧸ Gpm N) = g at hfix
+        rw [MulAction.Quotient.smul_coe, smul_eq_mul, QuotientGroup.eq, mul_inv_rev,
+          ← Subgroup.inv_mem_iff, mul_inv_rev, mul_inv_rev, inv_inv, inv_inv, ← mul_assoc,
+          conj_mem_Gpm_iff] at hfix
+        have h := trace_ne N hN u hfix
+        tauto
+  rw [Subgroup.index_eq_sum_minimalPeriod (Gpm N) u]
+  simp only [hper, Finset.sum_const, Finset.card_univ, smul_eq_mul]
+  exact Dvd.intro_left _ rfl
+
+theorem six_dvd_index (hN : 2 ≤ N) : 6 ∣ (Gpm N).index := by
+  have h2 : 2 ∣ (Gpm N).index := by
+    refine dvd_index_of_pow_eq N hN ModularGroup.S 2 ?_ (Or.inl ?_)
+    · rw [sq, S_sq]
+    · rw [ModularGroup.coe_S, Matrix.trace_fin_two_of]; norm_num
+  have h3 : 3 ∣ (Gpm N).index := by
+    have : Fact (Nat.Prime 3) := ⟨Nat.prime_three⟩
+    refine dvd_index_of_pow_eq N hN (ModularGroup.S * ModularGroup.T) 3 ST_pow_three (Or.inr (Or.inl
+      ?_))
+    rw [Matrix.SpecialLinearGroup.coe_mul, ModularGroup.coe_S, ModularGroup.coe_T,
+      Matrix.mul_fin_two,
+      Matrix.trace_fin_two_of]
+    norm_num
+  have : Nat.Coprime 2 3 := by norm_num
+  exact this.mul_dvd_of_dvd_of_dvd h2 h3
+
+theorem finrank_int_eq_finrank_rat [NeZero N] :
+    Module.finrank ℤ (parabolicHoms ℤ (CongruenceSubgroup.Gamma N) ℤ) =
+      Module.finrank ℚ (parabolicHoms ℚ (CongruenceSubgroup.Gamma N) ℚ) := by
+  obtain ⟨n, b, hb⟩ := exists_basis_parabolicHoms_castAddHom_comp (CongruenceSubgroup.Gamma N)
+  obtain ⟨bQ, -⟩ := hb ℚ
+  rw [Module.finrank_eq_card_basis b, Module.finrank_eq_card_basis bQ]
+
+noncomputable def resHom :
+    (Additive ↥(Gpm N) →+ ℚ) →ₗ[ℚ] (Additive ↥(CongruenceSubgroup.Gamma N) →+ ℚ) where
+  toFun φ := φ.comp (MonoidHom.toAdditive (Subgroup.inclusion (le_sup_left :
+    CongruenceSubgroup.Gamma N ≤ Gpm N)))
+  map_add' _ _ := rfl
+  map_smul' _ _ := rfl
+
+theorem resHom_apply (φ : Additive ↥(Gpm N) →+ ℚ) (γ : CongruenceSubgroup.Gamma N) :
+    resHom N φ (Additive.ofMul γ) =
+      φ (Additive.ofMul ⟨(γ : SL(2, ℤ)), Subgroup.mem_sup_left γ.2⟩) := rfl
+
+theorem resHom_mem (φ : Additive ↥(Gpm N) →+ ℚ) (hφ : φ ∈ parabolicHoms ℚ (Gpm N) ℚ) :
+    resHom N φ ∈ parabolicHoms ℚ (CongruenceSubgroup.Gamma N) ℚ := by
+  intro γ hγ
+  rw [resHom_apply]
+  exact hφ ⟨(γ : SL(2, ℤ)), Subgroup.mem_sup_left γ.2⟩ hγ
+
+noncomputable def resP :
+    parabolicHoms ℚ (Gpm N) ℚ →ₗ[ℚ] parabolicHoms ℚ (CongruenceSubgroup.Gamma N) ℚ :=
+  (resHom N).restrict (fun φ hφ => resHom_mem N φ hφ)
+
+theorem resP_bijective : Function.Bijective (resP N) := by
+  constructor
+  · intro φ ψ h
+    apply Subtype.ext
+    have hφ := φ.2
+    have hψ := ψ.2
+    rw [mem_parabolicHoms_iff] at hφ hψ
+    obtain ⟨χ, -, huniq⟩ := existsUnique_isParabolicHom_sup_zpowers_neg_one_apply_eq
+      (CongruenceSubgroup.Gamma N) ℚ (resHom N φ) (resHom_mem N φ φ.2)
+    have e1 := huniq φ.1 ⟨hφ, fun γ => rfl⟩
+    have e2 := huniq ψ.1 ⟨hψ, fun γ => ?_⟩
+    · exact e1.trans e2.symm
+    · have := congrArg (fun f : parabolicHoms ℚ (CongruenceSubgroup.Gamma N) ℚ =>
+        (f : Additive ↥(CongruenceSubgroup.Gamma N) →+ ℚ) (Additive.ofMul γ)) h
+      exact this.symm
+  · intro ψ
+    have hψ := ψ.2
+    rw [mem_parabolicHoms_iff] at hψ
+    obtain ⟨χ, ⟨hχ, hχres⟩, -⟩ := existsUnique_isParabolicHom_sup_zpowers_neg_one_apply_eq
+      (CongruenceSubgroup.Gamma N) ℚ ψ.1 hψ
+    refine ⟨⟨χ, hχ⟩, ?_⟩
+    apply Subtype.ext
+    ext γ
+    exact hχres γ
+
+theorem finrank_parabolicHoms_Gpm [NeZero N] :
+    Module.finrank ℚ (parabolicHoms ℚ (Gpm N) ℚ) =
+      Module.finrank ℚ (parabolicHoms ℚ (CongruenceSubgroup.Gamma N) ℚ) :=
+  LinearEquiv.finrank_eq (LinearEquiv.ofBijective (resP N) (resP_bijective N))
+
+theorem main (hN : 2 ≤ N) :
+    6 * N * Module.finrank ℤ (parabolicHoms ℤ (CongruenceSubgroup.Gamma N) ℤ) +
+        6 * (Gpm N).index = 12 * N + N * (Gpm N).index := by
+  have : NeZero N := ⟨by omega⟩
+  have hμc := index_Gpm_eq N
+  obtain ⟨k, hk⟩ := six_dvd_index N hN
+  have hHom : Module.finrank ℚ (Additive ↥(Gpm N) →+ ℚ) = 1 + (Gpm N).index / 6 :=
+    Matrix.SpecialLinearGroup.finrank_addMonoidHom_eq_of_forall_trace_ne (Gpm N)
+      (neg_one_mem_Gpm N) (trace_ne N hN) ℚ
+  have hle := finrank_parabolicHoms_add_natCard_le_finrank_addMonoidHom_add_one (Gpm N)
+    (neg_one_mem_Gpm N) ℚ
+  have hge := finrank_addMonoidHom_add_one_le (Γ := Gpm N) (neg_one_mem_Gpm N)
+  have hP := (finrank_int_eq_finrank_rat N).trans (finrank_parabolicHoms_Gpm N).symm
+  rw [hP]
+  set μ := (Gpm N).index with hμ
+  set c := Nat.card (Cusp (Gpm N)) with hcdef
+  set p := Module.finrank ℚ (parabolicHoms ℚ (Gpm N) ℚ) with hpdef
+  set d := Module.finrank ℚ (Additive ↥(Gpm N) →+ ℚ) with hddef
+  have hk6 : μ / 6 = k := by rw [hk]; exact Nat.mul_div_cancel_left k (by norm_num)
+  have e1 : p + c = 2 + k := by omega
+  have e2 : N * c = 6 * k := by rw [← hμc, hk]
+  have hk' : (μ : ℤ) = 6 * k := by exact_mod_cast hk
+  zify at e1 e2 ⊢
+  linear_combination (6 * (N : ℤ)) * e1 - 6 * e2 + (6 - (N : ℤ)) * hk'
+
+end Principal
+
+end BettiPrincipal
+
+theorem solution (N : ℕ) (hN : 2 ≤ N) :
+    6 * N * Module.finrank ℤ (ModularCurve.Period.parabolicHoms ℤ (CongruenceSubgroup.Gamma N) ℤ) +
+        6 * (CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index =
+      12 * N + N * (CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index :=
+  BettiPrincipal.main N hN
+
+end S_ModularCurve_six_mul_level_mul_finrank_parabolicHoms_Gamma_add_eq
+end P2MW
+export P2MW.S_ModularCurve_six_mul_level_mul_finrank_parabolicHoms_Gamma_add_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.six_mul_level_mul_finrank_parabolicHoms_Gamma_add_eq (N : ℕ) (hN : 2 ≤ N) :
+    6 * N * Module.finrank ℤ (ModularCurve.Period.parabolicHoms ℤ (CongruenceSubgroup.Gamma N) ℤ) +
+        6 * (CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index =
+      12 * N + N * (CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index :=
+  solution N hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_slot_ord_of_algHom_laurentBaseChange.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_slot_ord_of_algHom_laurentBaseChange.lean
new file mode 100644
index 0000000000..66985c3ea1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_slot_ord_of_algHom_laurentBaseChange.lean
@@ -0,0 +1,268 @@
+/-
+Based on Prove2Me node ModularCurve.slot_ord_of_algHom_laurentBaseChange
+(c6528a3c-2fc7-523d-882e-4b78efd6f4c2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 73f0101f-89f1-523f-81b7-92a1087bfc65
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlace
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_AtkinLehner
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_order_qExpand
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_adjoin_pair
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jqN
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cusp width and orders of j(q), j(q^N) at a place
+
+Theorem statement: `ModularCurve.slot_ord_of_algHom_laurentBaseChange`
+(`c6528a3c-2fc7-523d-882e-4b78efd6f4c2`), by Claude, 2026-09-05.
+
+Proof: submission `73f0101f-89f1-523f-81b7-92a1087bfc65`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field of characteristic zero (an algebra over $\mathbb{Q}$), let $N \ge 1$, let $\zeta$
+be a unit of $K$, and let $a, b$ be natural numbers with $a \mid N$ and $a \neq 0$. Write $F$ for
+`laurentBaseChange K (modularFunctionFieldFull N)`, the intermediate field of $K((q))$ generated
+over $K$ by the coefficientwise images under `coeffEmb K` of the subfield of $\mathbb{Q}((q))$
+generated over $\mathbb{Q}$ by the series $q \mapsto$ `qExpand ℚ d jq` for the nonzero divisors $d$
+of $N$, where `jq` is $q^{-1}$ times the power series `jNumQ` and `qExpand` is substitution of a
+power of the variable in exponents. Let $\iota : F \to K((q))$ be a $K$-algebra homomorphism sending
+the element `coeffEmb K jq` to `qExpand K N (coeffEmb K jq)` and the element `coeffEmb K (jqN N)` to
+`qExpand K (a*a)` applied to the twist of `coeffEmb K jq` by $\zeta^{ba}$ (the $k$-th coefficient
+multiplied by $\zeta^{bak}$). Let $w$ be a place of $F$ over $K$ in the project's sense (a valuation
+subring, not all of $F$, containing $K$ and a principal ideal ring), with associated order function
+`w.ord` given by minus the logarithm of the adic valuation. Assume $\gamma$ is a positive integer
+with $(w.\mathrm{ord}\,x)\gamma = \mathrm{order}(\iota x)$ for every $x \in F$. Then, with $g =
+\gcd(a, N/a)$: $\gamma = a g$, the order of `coeffEmb K jq` at $w$ is $-(N/a)/g$, and the order of
+`coeffEmb K (jqN N)` at $w$ is $-a/g$, all divisions being divisions of natural numbers cast to
+$\mathbb{Z}$.
+
+This is the local computation of cusp widths on $X_0(N)$: for a cusp with denominator $a$ the
+uniformiser pulls back to the $a\gcd(a,N/a)$-th power of the variable, and $j(q)$, $j(q^N)$ have
+poles there of orders $(N/a)/g$ and $a/g$. It is used in the counting of the cusps of $X_0(N)$, in
+the characterisation of places by the sign of the order of $j$, and in the analysis of the Hecke
+correspondence.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_slot_ord_of_algHom_laurentBaseChange.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_slot_ord_of_algHom_laurentBaseChange
+
+open ModularCurve AlgebraicCurve
+
+namespace CD
+
+section Helper
+
+variable {K : Type*} [Field K]
+
+theorem order_qTwist (u : Kˣ) (f : LaurentSeries K) : (qTwist u f).order = f.order := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · rw [map_zero]
+  · have hne : qTwist u f ≠ 0 := fun h =>
+      hf (qTwist_injective u (by rw [h, map_zero]))
+    refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero ?_)
+      (HahnSeries.order_le_of_coeff_ne_zero ?_)
+    · rw [qTwist_coeff]
+      exact mul_ne_zero (Units.ne_zero _) (HahnSeries.coeff_order_eq_zero.not.mpr hf)
+    · have := HahnSeries.coeff_order_eq_zero.not.mpr hne
+      rw [qTwist_coeff] at this
+      exact right_ne_zero_of_mul this
+
+noncomputable def qExpandAlgK (M : ℕ) [NeZero M] : LaurentSeries K →ₐ[K] LaurentSeries K where
+  __ := qExpand K M
+  commutes' r := by
+    change qExpand K M (algebraMap K (LaurentSeries K) r) = algebraMap K (LaurentSeries K) r
+    rw [algebraMap_laurentSeries_eq_single, qExpand_single, mul_zero]
+
+@[scoped simp]
+theorem qExpandAlgK_apply (M : ℕ) [NeZero M] (f : LaurentSeries K) :
+    qExpandAlgK M f = qExpand K M f := rfl
+
+theorem qExpand_mem_range_of_dvd (M P : ℕ) [NeZero M] [NeZero P] (h : M ∣ P)
+    (f : LaurentSeries K) :
+    qExpand K P f ∈ (qExpandAlgK (K := K) M).fieldRange := by
+  have : NeZero (P / M) :=
+    ⟨Nat.div_ne_zero_iff.mpr ⟨NeZero.ne M, Nat.le_of_dvd (Nat.pos_of_ne_zero (NeZero.ne P)) h⟩⟩
+  refine ⟨qExpand K (P / M) f, ?_⟩
+  change qExpand K M (qExpand K (P / M) f) = qExpand K P f
+  rw [qExpand_qExpand]
+  exact qExpand_congr (Nat.mul_div_cancel' h) f
+
+end Helper
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+private theorem _root_.ModularCurve.slot_ord_of_algHom_laurentBaseChange' (N : ℕ) [NeZero N]
+    (ζ : Kˣ) (a b : ℕ) (ha : a ∣ N) [NeZero a]
+    (ι : laurentBaseChange K (modularFunctionFieldFull N) →ₐ[K] LaurentSeries K)
+    (hι₁ : ι ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+        qExpand K N (coeffEmb K jq))
+    (hι₂ : ι ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩ =
+        qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)))
+    (w : Place K (laurentBaseChange K (modularFunctionFieldFull N))) (γ : ℤ) (hγ : 0 < γ)
+    (hw : ∀ x, w.ord x * γ = (ι x).order) :
+    γ = a * Nat.gcd a (N / a) ∧
+    w.ord ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+        -((N / a / Nat.gcd a (N / a) : ℕ) : ℤ) ∧
+    w.ord ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩ =
+        -((a / Nat.gcd a (N / a) : ℕ) : ℤ) := by
+  let F := laurentBaseChange K (modularFunctionFieldFull N)
+  let jbar : F := ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩
+  let jbarN : F :=
+    ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩
+  let g := Nat.gcd a (N / a)
+  have ha0 : a ≠ 0 := NeZero.ne a
+  have hg0 : g ≠ 0 := Nat.gcd_ne_zero_left ha0
+  have hag0 : NeZero (a * g) := ⟨Nat.mul_ne_zero ha0 hg0⟩
+  have hag_dvd_N : a * g ∣ N := by
+    calc a * g ∣ a * (N / a) := Nat.mul_dvd_mul_left a (Nat.gcd_dvd_right _ _)
+      _ = N := Nat.mul_div_cancel' ha
+  have hag_dvd_aa : a * g ∣ a * a := Nat.mul_dvd_mul_left a (Nat.gcd_dvd_left _ _)
+  have : NeZero (a * a) := ⟨Nat.mul_ne_zero ha0 ha0⟩
+  have hord1 : (ι jbar).order = -(N : ℤ) := by
+    rw [show ι jbar = qExpand K N (coeffEmb K jq) from hι₁, order_qExpand, order_coeffEmb_jq,
+      mul_neg_one]
+  have hord2 : (ι jbarN).order = -((a * a : ℕ) : ℤ) := by
+    rw [show ι jbarN = _ from hι₂, order_qExpand, order_qTwist, order_coeffEmb_jq,
+      mul_neg_one]
+  have hw1 : w.ord jbar * γ = -(N : ℤ) := (hw jbar).trans hord1
+  have hw2 : w.ord jbarN * γ = -((a * a : ℕ) : ℤ) := (hw jbarN).trans hord2
+  have hγdvd : γ ∣ ((a * g : ℕ) : ℤ) := by
+    have hN : γ ∣ (N : ℤ) := ⟨-(w.ord jbar), by rw [mul_neg, mul_comm γ, hw1, neg_neg]⟩
+    have haa : γ ∣ ((a * a : ℕ) : ℤ) :=
+      ⟨-(w.ord jbarN), by rw [mul_neg, mul_comm γ, hw2, neg_neg]⟩
+    have key : Nat.gcd N (a * a) = a * g := by
+      conv_lhs => rw [← Nat.mul_div_cancel' ha]
+      rw [Nat.gcd_mul_left, Nat.gcd_comm]
+    rw [← key, Nat.gcd_eq_gcd_ab]
+    exact dvd_add (Dvd.dvd.mul_right hN _) (Dvd.dvd.mul_right haa _)
+  have hrange : ∀ x : F, ι x ∈ (qExpandAlgK (K := K) (a * g)).fieldRange := by
+    have hadj := laurentBaseChange_adjoin_pair K N (functionFieldGeneration N)
+    have htop : IntermediateField.adjoin K ({jbar, jbarN} : Set F) = ⊤ := by
+      apply IntermediateField.map_injective F.val
+      calc (IntermediateField.adjoin K ({jbar, jbarN} : Set F)).map F.val
+          = IntermediateField.adjoin K (F.val '' {jbar, jbarN}) :=
+            IntermediateField.adjoin_map K _ F.val
+        _ = IntermediateField.adjoin K ({jqModC K, jqNModC K N} : Set (LaurentSeries K)) := by
+            congr 1
+            rw [Set.image_insert_eq, Set.image_singleton]
+            change ({coeffEmb K jq, coeffEmb K (jqN N)} : Set (LaurentSeries K)) = _
+            rw [coeffEmb_jq K, coeffEmb_jqN K N]
+        _ = F := hadj.symm
+        _ = (⊤ : IntermediateField K F).map F.val :=
+            (IntermediateField.fieldRange_val (S := F)).symm.trans
+              (AlgHom.fieldRange_eq_map F.val)
+    intro x
+    have hxmem : x ∈ IntermediateField.adjoin K ({jbar, jbarN} : Set F) :=
+      htop ▸ IntermediateField.mem_top
+    induction hxmem using IntermediateField.adjoin_induction with
+    | mem y hy =>
+      simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hy
+      rcases hy with rfl | rfl
+      · exact hι₁ ▸ qExpand_mem_range_of_dvd (a * g) N hag_dvd_N (coeffEmb K jq)
+      · exact hι₂ ▸ qExpand_mem_range_of_dvd (a * g) (a * a) hag_dvd_aa
+          (qTwist (ζ ^ (b * a)) (coeffEmb K jq))
+    | algebraMap c =>
+      rw [AlgHom.commutes]
+      exact IntermediateField.algebraMap_mem _ c
+    | add y z _ _ ihy ihz =>
+      have hadd : ι (y + z) = ι y + ι z := ι.toRingHom.map_add' y z
+      rw [hadd]
+      exact add_mem ihy ihz
+    | inv y _ ih => rw [map_inv₀ ι]; exact inv_mem ih
+    | mul y z _ _ ihy ihz => rw [map_mul ι]; exact mul_mem ihy ihz
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  obtain ⟨f, hfπ⟩ := hrange (π : F)
+  have hγeq : γ = (ι (π : F)).order := by
+    have := hw (π : F)
+    rw [w.ord_coe_irreducible hπ, one_mul] at this
+    exact this
+  have hagdvdγ : ((a * g : ℕ) : ℤ) ∣ γ := by
+    rw [hγeq, ← hfπ]
+    change ((a * g : ℕ) : ℤ) ∣ (qExpandAlgK (a * g) f).order
+    rw [qExpandAlgK_apply, order_qExpand]
+    exact Dvd.intro _ rfl
+  have hagpos : 0 < ((a * g : ℕ) : ℤ) := by
+    exact_mod_cast Nat.pos_of_ne_zero hag0.out
+  have hγval : γ = ((a * g : ℕ) : ℤ) :=
+    Int.dvd_antisymm (le_of_lt hγ) (le_of_lt hagpos) hγdvd hagdvdγ
+  refine ⟨by rw [hγval]; push_cast; ring, ?_, ?_⟩
+  · have hdiv : (N / a / g) * (a * g) = N := by
+      rw [Nat.div_div_eq_div_mul, Nat.div_mul_cancel hag_dvd_N]
+    have key : (-((N / a / g : ℕ) : ℤ)) * ((a * g : ℕ) : ℤ) = -(N : ℤ) := by
+      rw [neg_mul, ← Nat.cast_mul, hdiv]
+    exact mul_right_cancel₀ (ne_of_gt hagpos) ((hγval ▸ hw1).trans key.symm)
+  · have hdiv : (a / g) * (a * g) = a * a := by
+      rw [mul_comm a g, ← mul_assoc, Nat.div_mul_cancel (Nat.gcd_dvd_left a (N / a))]
+    have key : (-((a / g : ℕ) : ℤ)) * ((a * g : ℕ) : ℤ) = -((a * a : ℕ) : ℤ) := by
+      rw [neg_mul, ← Nat.cast_mul, hdiv]
+    exact mul_right_cancel₀ (ne_of_gt hagpos) ((hγval ▸ hw2).trans key.symm)
+
+end CD
+
+open ModularCurve AlgebraicCurve in
+theorem solution (K : Type*) [Field K] [Algebra ℚ K] (N : ℕ) [NeZero N] (ζ : Kˣ) (a b : ℕ)
+    (ha : a ∣ N) [NeZero a]
+    (ι : laurentBaseChange K (modularFunctionFieldFull N) →ₐ[K] LaurentSeries K)
+    (hι₁ : ι ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+        qExpand K N (coeffEmb K jq))
+    (hι₂ : ι ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩ =
+        qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)))
+    (w : Place K (laurentBaseChange K (modularFunctionFieldFull N))) (γ : ℤ) (hγ : 0 < γ)
+    (hw : ∀ x, w.ord x * γ = (ι x).order) :
+    γ = a * Nat.gcd a (N / a) ∧
+    w.ord ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+        -((N / a / Nat.gcd a (N / a) : ℕ) : ℤ) ∧
+    w.ord ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩ =
+        -((a / Nat.gcd a (N / a) : ℕ) : ℤ) :=
+  ModularCurve.slot_ord_of_algHom_laurentBaseChange' K N ζ a b ha ι hι₁ hι₂ w γ hγ hw
+
+end S_ModularCurve_slot_ord_of_algHom_laurentBaseChange
+end P2MW
+export P2MW.S_ModularCurve_slot_ord_of_algHom_laurentBaseChange (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.slot_ord_of_algHom_laurentBaseChange (K : Type*) [Field K] [Algebra ℚ K]
+    (N : ℕ) [NeZero N] (ζ : Kˣ) (a b : ℕ) (ha : a ∣ N) [NeZero a]
+    (ι : laurentBaseChange K (modularFunctionFieldFull N) →ₐ[K] LaurentSeries K)
+    (hι₁ : ι ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+        qExpand K N (coeffEmb K jq))
+    (hι₂ : ι ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩ =
+        qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)))
+    (w : Place K (laurentBaseChange K (modularFunctionFieldFull N))) (γ : ℤ) (hγ : 0 < γ)
+    (hw : ∀ x, w.ord x * γ = (ι x).order) :
+    γ = a * Nat.gcd a (N / a) ∧
+    w.ord ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+        -((N / a / Nat.gcd a (N / a) : ℕ) : ℤ) ∧
+    w.ord ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩ =
+        -((a / Nat.gcd a (N / a) : ℕ) : ℤ) :=
+  solution K N ζ a b ha ι hι₁ hι₂ w γ hγ hw
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_slot_place_eq_iff_modEq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_slot_place_eq_iff_modEq.lean
new file mode 100644
index 0000000000..f5dc333e37
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_slot_place_eq_iff_modEq.lean
@@ -0,0 +1,336 @@
+/-
+Based on Prove2Me node ModularCurve.slot_place_eq_iff_modEq
+(8abf7cfd-a637-59cd-90d0-f119e5677181) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 99d7a35d-f2cf-5bd9-950f-9c68e80b4081
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlace
+public import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+public import Mathlib.Tactic.LinearCombination
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_adjoin_pair
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_functionFieldGeneration
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jqN
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_iff_ord_nonneg
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Places of X₀(N) labelled by pairs (a,b)
+
+Theorem statement: `ModularCurve.slot_place_eq_iff_modEq` (`8abf7cfd-a637-59cd-90d0-f119e5677181`),
+by Claude, 2026-09-05.
+
+Proof: submission `99d7a35d-f2cf-5bd9-950f-9c68e80b4081`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field of characteristic zero (an algebra over $\mathbb{Q}$), let $N$ be a positive
+natural number, and let $\zeta$ be a unit of $K$ whose underlying element is a primitive $N$-th root
+of unity. Let $a,b,a',b'$ be natural numbers with $a\mid N$, $a'\mid N$ and $a,a'$ nonzero. Work in
+$F =$ `laurentBaseChange K (modularFunctionFieldFull N)`, the subfield of $K((q))$ generated over
+$K$ by the coefficientwise images under $\mathbb{Q}\to K$ of the subfield of $\mathbb{Q}((q))$
+generated over $\mathbb{Q}$ by all $q\mapsto q^d$ substitutions $j(q^d)$ of the $j$-expansion $jq$,
+for nonzero $d\mid N$. Let $\iota,\iota' : F\to K((q))$ be $K$-algebra maps such that $\iota$ and
+$\iota'$ both send the generator coming from $j(q)$ to $j(q^N)$, while $\iota$ sends the generator
+coming from $j(q^N)$ to $j(\zeta^{ba}q^{a^2})$, that is to the image under $q\mapsto q^{a\cdot a}$
+of the twist of $j(q)$ whose $k$-th coefficient is multiplied by $\zeta^{(b a)k}$, and $\iota'$
+sends it to $j(\zeta^{b'a'}q^{a'^2})$ likewise. Let $w,w'$ be places of $F$ over $K$ (valuation
+subrings containing $K$, proper, and principal ideal rings) and $\gamma,\gamma'$ positive integers
+with $w.\mathrm{ord}(x)\,\gamma = \mathrm{order}(\iota x)$ and $w'.\mathrm{ord}(x)\,\gamma' =
+\mathrm{order}(\iota' x)$ for all $x\in F$, where $\mathrm{ord}$ is the $\mathbb{Z}$-valued
+valuation attached to the place. Then $w = w'$ if and only if $a = a'$ and $b \equiv b'
+\pmod{\gcd(a, N/a)}$.
+
+This is the classical labelling of the cusps of $X_0(N)$ by pairs $(a,b)$ with $a\mid N$ and $b$
+taken modulo $\gcd(a,N/a)$, here expressed as a criterion for two places of the function field to
+coincide in terms of the normalised $q$-expansion embeddings attached to the labels. It is used in
+the count of the places of negative order at $\bar\jmath$ against the number of cusps and in the
+production of pairs of places in a fibre of the Hecke correspondence.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_slot_place_eq_iff_modEq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_slot_place_eq_iff_modEq
+
+open ModularCurve AlgebraicCurve Polynomial IntermediateField
+
+namespace CD
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+theorem order_eq_of_coeff {x : LaurentSeries K} {m : ℤ} (h1 : x.coeff m ≠ 0)
+    (h2 : ∀ i < m, x.coeff i = 0) : x.order = m := by
+  have _ := ‹Algebra ℚ K›
+  have hx : x ≠ 0 := fun h => h1 (by rw [h, HahnSeries.coeff_zero])
+  refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero h1) ?_
+  by_contra! h
+  exact hx (HahnSeries.coeff_order_eq_zero.mp (h2 _ h))
+
+theorem order_qTwist (v : Kˣ) (f : LaurentSeries K) : (qTwist v f).order = f.order := by
+  have _ := ‹Algebra ℚ K›
+  rcases eq_or_ne f 0 with rfl | hf
+  · rw [map_zero]
+  have h1 : ∀ (u : Kˣ) (g : LaurentSeries K), g ≠ 0 → (qTwist u g).order ≤ g.order :=
+    fun u g hg => HahnSeries.order_le_of_coeff_ne_zero (by
+      rw [qTwist_coeff]
+      exact mul_ne_zero (Units.ne_zero _) (mt HahnSeries.coeff_order_eq_zero.mp hg))
+  refine le_antisymm (h1 v f hf) ?_
+  have h2 := h1 v⁻¹ (qTwist v f) ((map_ne_zero_iff _ (qTwist_injective v)).mpr hf)
+  rwa [qTwist_qTwist, inv_mul_cancel, qTwist_one_apply] at h2
+
+theorem coeff_algebraMap_mul (c : K) (y : LaurentSeries K) (i : ℤ) :
+    (algebraMap K (LaurentSeries K) c * y).coeff i = c * y.coeff i := by
+  have _ := ‹Algebra ℚ K›
+  rw [algebraMap_laurentSeries_eq_single, HahnSeries.single_zero_mul_eq_smul, HahnSeries.coeff_smul,
+    smul_eq_mul]
+
+theorem coeff_slot_pow (v : Kˣ) (A : ℕ) [NeZero A] (n : ℕ) :
+    ((qExpand K A (qTwist v (coeffEmb K jq))) ^ n).coeff (-((A * n : ℕ) : ℤ)) =
+        ((v ^ (-(n : ℤ)) : Kˣ) : K) ∧
+      ∀ i < -((A * n : ℕ) : ℤ), ((qExpand K A (qTwist v (coeffEmb K jq))) ^ n).coeff i = 0 := by
+  rw [← map_pow, ← map_pow, ← map_pow]
+  constructor
+  · rw [show -((A * n : ℕ) : ℤ) = (A : ℤ) * (-(n : ℤ)) by push_cast; ring, qExpand_coeff_mul,
+      qTwist_coeff, coeffEmb_coeff, coeff_jq_pow_self, map_one, mul_one]
+  · intro i hi
+    by_cases hdvd : (A : ℤ) ∣ i
+    · obtain ⟨m, rfl⟩ := hdvd
+      have hA : (0 : ℤ) < A := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne A)
+      have hm : m < -(n : ℤ) := by
+        refine lt_of_mul_lt_mul_left ?_ hA.le
+        rw [mul_neg]
+        exact_mod_cast hi
+      rw [qExpand_coeff_mul, qTwist_coeff, coeffEmb_coeff, coeff_jq_pow_of_lt hm, map_zero,
+        mul_zero]
+    · exact qExpand_coeff_of_not_dvd A _ hdvd
+
+theorem coeff_qExpand_jq_pow (A : ℕ) [NeZero A] (n : ℕ) :
+    ((qExpand K A (coeffEmb K jq)) ^ n).coeff (-((A * n : ℕ) : ℤ)) = 1 ∧
+      ∀ i < -((A * n : ℕ) : ℤ), ((qExpand K A (coeffEmb K jq)) ^ n).coeff i = 0 := by
+  simpa [qTwist_one_apply] using coeff_slot_pow K 1 A n
+
+theorem order_slot (v : Kˣ) (A : ℕ) [NeZero A] :
+    (qExpand K A (qTwist v (coeffEmb K jq))).order = -(A : ℤ) := by
+  obtain ⟨h1, h2⟩ := coeff_slot_pow K v A 1
+  rw [pow_one, mul_one] at h1 h2
+  exact order_eq_of_coeff K (by rw [h1]; exact Units.ne_zero _) h2
+
+theorem order_qExpand_jq (A : ℕ) [NeZero A] :
+    (qExpand K A (coeffEmb K jq)).order = -(A : ℤ) := by
+  obtain ⟨h1, h2⟩ := coeff_qExpand_jq_pow K A 1
+  rw [pow_one, mul_one] at h1 h2
+  exact order_eq_of_coeff K (by rw [h1]; exact one_ne_zero) h2
+
+private theorem _root_.ModularCurve.slot_place_eq_iff_modEq' (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N)
+    (a b : ℕ) (ha : a ∣ N) [NeZero a] (a' b' : ℕ) (ha' : a' ∣ N) [NeZero a']
+    (ι ι' : laurentBaseChange K (modularFunctionFieldFull N) →ₐ[K] LaurentSeries K)
+    (hι₁ : ι ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+        qExpand K N (coeffEmb K jq))
+    (hι₂ : ι ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩ =
+        qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)))
+    (hι'₁ : ι' ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+        qExpand K N (coeffEmb K jq))
+    (hι'₂ : ι' ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩
+      =
+        qExpand K (a' * a') (qTwist (ζ ^ (b' * a')) (coeffEmb K jq)))
+    (w w' : Place K (laurentBaseChange K (modularFunctionFieldFull N))) (γ γ' : ℤ)
+    (hγ : 0 < γ) (hγ' : 0 < γ')
+    (hw : ∀ x, w.ord x * γ = (ι x).order) (hw' : ∀ x, w'.ord x * γ' = (ι' x).order) :
+    w = w' ↔ a = a' ∧ b ≡ b' [MOD Nat.gcd a (N / a)] := by
+  have _ := ha'
+  obtain ⟨d, rfl⟩ := ha
+  have ha0 : 0 < a := Nat.pos_of_ne_zero (NeZero.ne a)
+  have had : a * d / a = d := Nat.mul_div_cancel_left d ha0
+  rw [had]
+  have hζu : IsPrimitiveRoot ζ (a * d) := IsPrimitiveRoot.coe_units_iff.mp hζ
+  set jb : laurentBaseChange K (modularFunctionFieldFull (a * d)) :=
+    ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full (a * d))⟩ with hjb
+  set jbN : laurentBaseChange K (modularFunctionFieldFull (a * d)) :=
+    ⟨coeffEmb K (jqN (a * d)),
+      coeffEmb_mem_laurentBaseChange K (jqd_mem_full (a * d) (dvd_refl (a * d)))⟩ with hjbN
+  constructor
+  · intro hww
+    subst hww
+    have h1 := hw jb
+    have h1' := hw' jb
+    rw [hι₁, order_qExpand_jq] at h1
+    rw [hι'₁, order_qExpand_jq] at h1'
+    have hne : w.ord jb ≠ 0 := by
+      intro h0
+      rw [h0, zero_mul] at h1
+      exact NeZero.ne (a * d) (by exact_mod_cast (neg_eq_zero.mp h1.symm))
+    obtain rfl : γ = γ' := mul_left_cancel₀ hne (h1.trans h1'.symm)
+    have h2 := hw jbN
+    have h2' := hw' jbN
+    rw [hι₂, order_slot] at h2
+    rw [hι'₂, order_slot] at h2'
+    have haa : a * a = a' * a' := by exact_mod_cast neg_injective (h2.symm.trans h2')
+    obtain rfl : a = a' := Nat.mul_self_inj.mp haa
+    refine ⟨rfl, ?_⟩
+    obtain ⟨m, hm⟩ := Nat.gcd_dvd_left a d
+    obtain ⟨n, hn⟩ := Nat.gcd_dvd_right a d
+    set g := Nat.gcd a d with hg
+    have hd0 : 0 < d := Nat.pos_of_ne_zero fun h => NeZero.ne (a * d) (by rw [h, mul_zero])
+    have hn0 : 0 < n := Nat.pos_of_ne_zero fun h => hd0.ne' (by rw [hn, h, mul_zero])
+    have key : a * a * n = a * d * m := by
+      calc a * a * n = a * (g * m) * n := by rw [← hm]
+        _ = a * (g * n) * m := by ring
+        _ = a * d * m := by rw [← hn]
+    set c : K := (((ζ ^ (b * a)) ^ (-(n : ℤ)) : Kˣ) : K) with hc
+    set x₀ : laurentBaseChange K (modularFunctionFieldFull (a * d)) :=
+      jbN ^ n - algebraMap K _ c * jb ^ m with hx₀
+    have hιx : ι x₀ = (qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq))) ^ n -
+        algebraMap K (LaurentSeries K) c * (qExpand K (a * d) (coeffEmb K jq)) ^ m := by
+      rw [hx₀, map_sub, map_mul, map_pow, map_pow, AlgHom.commutes, hι₁, hι₂]
+    have hι'x : ι' x₀ = (qExpand K (a * a) (qTwist (ζ ^ (b' * a)) (coeffEmb K jq))) ^ n -
+        algebraMap K (LaurentSeries K) c * (qExpand K (a * d) (coeffEmb K jq)) ^ m := by
+      rw [hx₀, map_sub, map_mul, map_pow, map_pow, AlgHom.commutes, hι'₁, hι'₂]
+    obtain ⟨hS1, -⟩ := coeff_slot_pow K (ζ ^ (b * a)) (a * a) n
+    obtain ⟨hS1', hS2'⟩ := coeff_slot_pow K (ζ ^ (b' * a)) (a * a) n
+    obtain ⟨hE1, hE2⟩ := coeff_qExpand_jq_pow K (a * d) m
+    rw [← key] at hE1 hE2
+    have hcoeffι : (ι x₀).coeff (-((a * a * n : ℕ) : ℤ)) = 0 := by
+      rw [hιx, HahnSeries.coeff_sub, hS1, coeff_algebraMap_mul, hE1, mul_one, sub_self]
+    have hbelow' : ∀ i < -((a * a * n : ℕ) : ℤ), (ι' x₀).coeff i = 0 := fun i hi => by
+      rw [hι'x, HahnSeries.coeff_sub, hS2' i hi, coeff_algebraMap_mul, hE2 i hi, mul_zero, sub_zero]
+    have hcoeffι' : (ι' x₀).coeff (-((a * a * n : ℕ) : ℤ)) =
+        (((ζ ^ (b' * a)) ^ (-(n : ℤ)) : Kˣ) : K) - c := by
+      rw [hι'x, HahnSeries.coeff_sub, hS1', coeff_algebraMap_mul, hE1, mul_one]
+    have hordx : (ι' x₀).order = (ι x₀).order := (hw' x₀).symm.trans (hw x₀)
+    have hM0 : (0 : ℤ) < ((a * a * n : ℕ) : ℤ) := by
+      exact_mod_cast Nat.mul_pos (Nat.mul_pos ha0 ha0) hn0
+    have hvan : (ι' x₀).coeff (-((a * a * n : ℕ) : ℤ)) = 0 := by
+      by_cases hz : ι' x₀ = 0
+      · rw [hz, HahnSeries.coeff_zero]
+      refine HahnSeries.coeff_eq_zero_of_lt_order (lt_of_le_of_ne ?_ ?_)
+      · by_contra! hlt
+        exact hz (HahnSeries.coeff_order_eq_zero.mp (hbelow' _ hlt))
+      · intro heq
+        rw [hordx] at heq
+        by_cases hz0 : ι x₀ = 0
+        · rw [hz0, HahnSeries.order_zero] at heq
+          exact hM0.ne' (neg_eq_zero.mp heq)
+        · refine hz0 (HahnSeries.coeff_order_eq_zero.mp ?_)
+          rw [← heq]
+          exact hcoeffι
+    rw [hcoeffι', sub_eq_zero, hc] at hvan
+    have hu : (ζ ^ (b' * a)) ^ (-(n : ℤ)) = (ζ ^ (b * a)) ^ (-(n : ℤ)) := Units.ext hvan
+    rw [zpow_neg, zpow_neg, inv_inj, zpow_natCast, zpow_natCast, ← pow_mul, ← pow_mul,
+      pow_eq_pow_iff_modEq, ← hζu.eq_orderOf, show a * d = g * (a * n) by rw [hn]; ring,
+      mul_assoc, mul_assoc] at hu
+    exact (Nat.ModEq.mul_right_cancel' (Nat.mul_pos ha0 hn0).ne' hu).symm
+  · rintro ⟨rfl, hbb⟩
+    obtain ⟨q, hq⟩ := Nat.modEq_iff_dvd.mp hbb
+    have hbez := Nat.gcd_eq_gcd_ab a d
+    obtain ⟨k, hk⟩ : ∃ k : ℤ, (ζ ^ k) ^ ((a * a : ℕ) : ℤ) * ζ ^ (b * a) = ζ ^ (b' * a) := by
+      refine ⟨Nat.gcdA a d * q, ?_⟩
+      rw [← zpow_natCast ζ (b * a), ← zpow_natCast ζ (b' * a), ← zpow_mul, ← zpow_add,
+        ← mul_inv_eq_one, ← zpow_sub, hζu.zpow_eq_one_iff_dvd]
+      refine ⟨-(Nat.gcdB a d * q), ?_⟩
+      push_cast
+      linear_combination (-(a : ℤ)) * hq + (-(a : ℤ) * q) * hbez
+    let T : LaurentSeries K →ₐ[K] LaurentSeries K :=
+      { toRingHom := qTwist (ζ ^ k)
+        commutes' := fun c => by
+          change qTwist (ζ ^ k) (algebraMap K (LaurentSeries K) c) = algebraMap K (LaurentSeries K)
+            c
+          rw [algebraMap_laurentSeries_eq_single, qTwist_single, zpow_zero, Units.val_one,
+            one_mul] }
+    have hFeq : laurentBaseChange K (modularFunctionFieldFull (a * d)) =
+        IntermediateField.adjoin K {coeffEmb K jq, coeffEmb K (jqN (a * d))} := by
+      rw [laurentBaseChange_adjoin_pair K (a * d) (functionFieldGeneration (a * d)), ← coeffEmb_jq,
+        ← coeffEmb_jqN]
+    have hT : ι' = T.comp ι := by
+      refine algHom_ext_of_eq_adjoin K hFeq fun x hx => ?_
+      rcases hx with rfl | rfl
+      · change ι' jb = qTwist (ζ ^ k) (ι jb)
+        rw [hι'₁, hι₁, qTwist_qExpand, ← zpow_mul, zpow_mul', zpow_natCast, hζu.pow_eq_one,
+          one_zpow,
+          qTwist_one_apply]
+      · change ι' jbN = qTwist (ζ ^ k) (ι jbN)
+        rw [hι'₂, hι₂, qTwist_qExpand, qTwist_qTwist, hk]
+    have hordeq : ∀ x, (ι' x).order = (ι x).order := fun x => by
+      rw [hT]
+      exact order_qTwist K (ζ ^ k) (ι x)
+    apply Place.ext
+    ext f
+    rcases eq_or_ne f 0 with rfl | hf
+    · exact ⟨fun _ => zero_mem _, fun _ => zero_mem _⟩
+    rw [Place.mem_iff_ord_nonneg w hf, Place.mem_iff_ord_nonneg w' hf]
+    have e1 := mul_nonneg_iff_of_pos_right (b := w.ord f) hγ
+    have e2 := mul_nonneg_iff_of_pos_right (b := w'.ord f) hγ'
+    rw [hw] at e1
+    rw [hw', hordeq] at e2
+    exact e1.symm.trans e2
+
+end CD
+
+open ModularCurve AlgebraicCurve in
+theorem solution (K : Type*) [Field K] [Algebra ℚ K] (N : ℕ) [NeZero N] (ζ : Kˣ)
+    (hζ : IsPrimitiveRoot (ζ : K) N)
+    (a b : ℕ) (ha : a ∣ N) [NeZero a] (a' b' : ℕ) (ha' : a' ∣ N) [NeZero a']
+    (ι ι' : laurentBaseChange K (modularFunctionFieldFull N) →ₐ[K] LaurentSeries K)
+    (hι₁ : ι ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+        qExpand K N (coeffEmb K jq))
+    (hι₂ : ι ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩ =
+        qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)))
+    (hι'₁ : ι' ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+        qExpand K N (coeffEmb K jq))
+    (hι'₂ : ι' ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩
+      =
+        qExpand K (a' * a') (qTwist (ζ ^ (b' * a')) (coeffEmb K jq)))
+    (w w' : Place K (laurentBaseChange K (modularFunctionFieldFull N))) (γ γ' : ℤ)
+    (hγ : 0 < γ) (hγ' : 0 < γ')
+    (hw : ∀ x, w.ord x * γ = (ι x).order) (hw' : ∀ x, w'.ord x * γ' = (ι' x).order) :
+    w = w' ↔ a = a' ∧ b ≡ b' [MOD Nat.gcd a (N / a)] :=
+  ModularCurve.slot_place_eq_iff_modEq' K N ζ hζ a b ha a' b' ha' ι ι' hι₁ hι₂ hι'₁ hι'₂ w w' γ γ'
+    hγ hγ' hw hw'
+
+end S_ModularCurve_slot_place_eq_iff_modEq
+end P2MW
+export P2MW.S_ModularCurve_slot_place_eq_iff_modEq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.slot_place_eq_iff_modEq (K : Type*) [Field K] [Algebra ℚ K] (N : ℕ) [NeZero N]
+    (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) N)
+    (a b : ℕ) (ha : a ∣ N) [NeZero a] (a' b' : ℕ) (ha' : a' ∣ N) [NeZero a']
+    (ι ι' : laurentBaseChange K (modularFunctionFieldFull N) →ₐ[K] LaurentSeries K)
+    (hι₁ : ι ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+        qExpand K N (coeffEmb K jq))
+    (hι₂ : ι ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩ =
+        qExpand K (a * a) (qTwist (ζ ^ (b * a)) (coeffEmb K jq)))
+    (hι'₁ : ι' ⟨coeffEmb K jq, coeffEmb_mem_laurentBaseChange K (jq_mem_full N)⟩ =
+        qExpand K N (coeffEmb K jq))
+    (hι'₂ : ι' ⟨coeffEmb K (jqN N), coeffEmb_mem_laurentBaseChange K (jqd_mem_full N (dvd_refl N))⟩
+      =
+        qExpand K (a' * a') (qTwist (ζ ^ (b' * a')) (coeffEmb K jq)))
+    (w w' : Place K (laurentBaseChange K (modularFunctionFieldFull N))) (γ γ' : ℤ)
+    (hγ : 0 < γ) (hγ' : 0 < γ')
+    (hw : ∀ x, w.ord x * γ = (ι x).order) (hw' : ∀ x, w'.ord x * γ' = (ι' x).order) :
+    w = w' ↔ a = a' ∧ b ≡ b' [MOD Nat.gcd a (N / a)] :=
+  solution K N ζ hζ a b ha a' b' ha' ι ι' hι₁ hι₂ hι'₁ hι'₂ w w' γ γ' hγ hγ' hw hw'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_sum_neg_ord_jBar_eq_dedekindPsi.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_sum_neg_ord_jBar_eq_dedekindPsi.lean
new file mode 100644
index 0000000000..101d52d375
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_sum_neg_ord_jBar_eq_dedekindPsi.lean
@@ -0,0 +1,137 @@
+/-
+Based on Prove2Me node ModularCurve.sum_neg_ord_jBar_eq_dedekindPsi
+(b8399df5-1739-557d-b620-c21ac8c041a9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a3e6b6fd-f826-5988-85fd-7af515731c8b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_MazurStepThreeInputs
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCurveOver_modularFunctionFieldBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_sum_ord_jBar_sub_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The polar divisor of jmath̄ has degree ψ(N)
+
+Theorem statement: `ModularCurve.sum_neg_ord_jBar_eq_dedekindPsi`
+(`b8399df5-1739-557d-b620-c21ac8c041a9`), by Claude, 2026-09-05.
+
+Proof: submission `a3e6b6fd-f826-5988-85fd-7af515731c8b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $N$ with $N \neq 0$. Work inside the field
+$\mathrm{LaurentSeries}(\overline{\mathbb Q})$, where $\overline{\mathbb Q} =$ `AlgebraicClosure ℚ`,
+and let $\overline{\mathbb Q}F_N =$ [`ModularCurve.modularFunctionFieldBar
+N`](def/ModularCurve_ArithmeticGalois.html#L111) be the intermediate field obtained by adjoining to
+$\overline{\mathbb Q}$ the coefficientwise images, under the map `coeffEmb` induced by $\mathbb Q
+\hookrightarrow \overline{\mathbb Q}$, of the field $\mathbb Q$-generated by the divisor expansions
+attached to $N$; let $\bar\jmath =$ [`ModularCurve.jBar
+N`](def/ModularCurve_MazurStepThreeInputs.html#L43) be the element of this field given by the
+coefficientwise image of the $q$-expansion `jq` of the modular invariant. Places of
+$\overline{\mathbb Q}F_N$ over $\overline{\mathbb Q}$ are, in the project's sense, valuation
+subrings of $\overline{\mathbb Q}F_N$ that contain the image of $\overline{\mathbb Q}$, are proper,
+and are principal ideal rings. The data are a finite set $S$ of such places together with the
+hypothesis that a place $v$ lies in $S$ precisely when $\mathrm{ord}_v(\bar\jmath) < 0$, i.e. $S$
+enumerates exactly the poles of $\bar\jmath$. The conclusion is the integer identity $\sum_{v \in S}
+\bigl(-\mathrm{ord}_v(\bar\jmath)\bigr) = \psi(N)$, where $\psi(N) =$ [`ModularCurve.dedekindPsi
+N`](def/ModularCurve_X0.html#L201) is defined as $\sum_{d \mid N,\ d \text{ squarefree}} N/d$.
+
+This is the statement that the polar divisor of the modular invariant on $X_0(N)$ over
+$\overline{\mathbb Q}$ — supported at the cusps — has degree $\psi(N) = [\mathrm{SL}_2(\mathbb Z) :
+\Gamma_0(N)]$, the degree of the map $\bar\jmath$. It is the companion, for poles, of the result
+computing the degree of the divisor of zeros of $\bar\jmath - j_0$, and it feeds the Riemann–Roch
+and genus computations for $\overline{\mathbb Q}F_N$ used further on.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_sum_neg_ord_jBar_eq_dedekindPsi.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_sum_neg_ord_jBar_eq_dedekindPsi
+
+
+open AlgebraicCurve ModularCurve
+
+theorem solution (N : ℕ) [NeZero N]
+    (S : Finset (AlgebraicCurve.Place (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar
+      N)))
+    (hS : ∀ v, v ∈ S ↔ v.ord (ModularCurve.jBar N) < 0) :
+    ∑ v ∈ S, -v.ord (ModularCurve.jBar N) = ModularCurve.dedekindPsi N := by
+  classical
+  have : IsCurveOver (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+    isCurveOver_modularFunctionFieldBar N
+  have hHPD : HasPrincipalDivisors (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) :=
+    IsCurveOver.hasPrincipalDivisors
+  have hdeg : ∀ w : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N), w.deg = 1 :=
+    IsCurveOver.forall_deg_eq_one_of_isAlgClosed
+  have hne : jBar N ≠ 0 := by
+    intro h
+    have h1 :=
+      congrArg (fun f : ↥(modularFunctionFieldBar N) => (f : LaurentSeries (AlgebraicClosure ℚ))) h
+    simp only [ZeroMemClass.coe_zero] at h1
+    exact jq_ne_zero ((map_eq_zero_iff _ (coeffEmb (AlgebraicClosure ℚ)).injective).mp h1)
+  obtain ⟨D, hD, hdeg0⟩ := hHPD.exists_divisor (jBar N) hne
+  have hdegD : Divisor.degree D = ∑ v ∈ D.support, v.ord (jBar N) := by
+    change Finsupp.liftAddHom (fun v : Place (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) =>
+        AddMonoidHom.mulRight (v.deg : ℤ)) D = _
+    rw [Finsupp.liftAddHom_apply, Finsupp.sum]
+    refine Finset.sum_congr rfl fun v _ => ?_
+    rw [AddMonoidHom.mulRight_apply, hD, hdeg, Nat.cast_one, mul_one]
+  have hsupp : ∀ v, v ∈ D.support ↔ v.ord (jBar N) ≠ 0 := fun v => by
+    rw [Finsupp.mem_support_iff, hD]
+  set Sp := D.support.filter (fun v => 0 < v.ord (jBar N)) with hSpdef
+  have hSp : ∀ v, v ∈ Sp ↔
+      0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) ↥(modularFunctionFieldBar N) 0) := by
+    intro v
+    rw [map_zero, sub_zero, hSpdef, Finset.mem_filter, hsupp]
+    constructor
+    · exact fun h => h.2
+    · exact fun h => ⟨h.ne', h⟩
+  have hzero := sum_ord_jBar_sub_eq_dedekindPsi N 0 hdeg Sp hSp
+  simp only [map_zero, sub_zero] at hzero
+  have hSeq : D.support.filter (fun v => ¬ 0 < v.ord (jBar N)) = S := by
+    ext v
+    rw [Finset.mem_filter, hsupp, hS]
+    omega
+  have hsplit := Finset.sum_filter_add_sum_filter_not D.support (fun v => 0 < v.ord (jBar N))
+    (fun v => v.ord (jBar N))
+  rw [← hdegD, hdeg0, ← hSpdef, hzero, hSeq] at hsplit
+  rw [Finset.sum_neg_distrib]
+  linarith
+
+end S_ModularCurve_sum_neg_ord_jBar_eq_dedekindPsi
+end P2MW
+export P2MW.S_ModularCurve_sum_neg_ord_jBar_eq_dedekindPsi (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve AlgebraicCurve
+theorem ModularCurve.sum_neg_ord_jBar_eq_dedekindPsi (N : ℕ) [NeZero N]
+    (S : Finset (AlgebraicCurve.Place (AlgebraicClosure ℚ) ↥(ModularCurve.modularFunctionFieldBar
+      N)))
+    (hS : ∀ v, v ∈ S ↔ v.ord (ModularCurve.jBar N) < 0) :
+    ∑ v ∈ S, -v.ord (ModularCurve.jBar N) = ModularCurve.dedekindPsi N :=
+  solution N S hS
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_sum_ord_jBar_sub_eq_dedekindPsi.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_sum_ord_jBar_sub_eq_dedekindPsi.lean
new file mode 100644
index 0000000000..0fbfc3c904
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_sum_ord_jBar_sub_eq_dedekindPsi.lean
@@ -0,0 +1,425 @@
+/-
+Based on Prove2Me node ModularCurve.sum_ord_jBar_sub_eq_dedekindPsi
+(1cd6faac-fa37-5aa9-925c-5d6dc6e75fbe) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c97ef268-9ba7-50a5-900a-0d34b285dc0a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_MazurStepThreeInputs
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_laurentBaseChange_modularFunctionFieldFull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_relfinrank_full_eq_dedekindPsi
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_dedekindPsi_pos
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg_fiberOver
+import Mathlib.FieldTheory.Relrank
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Algebra
+import Mathlib.FieldTheory.Perfect
+import Mathlib.RingTheory.DedekindDomain.AdicValuation
+import Mathlib.RingTheory.Adjoin.Polynomial.Basic
+import Mathlib.RingTheory.Algebraic.Basic
+import Mathlib.RingTheory.PrincipalIdealDomain
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Zeros of jmath̄-j₀ on X₀(N) total ψ(N)
+
+Theorem statement: `ModularCurve.sum_ord_jBar_sub_eq_dedekindPsi`
+(`1cd6faac-fa37-5aa9-925c-5d6dc6e75fbe`), by Claude, 2026-09-05.
+
+Proof: submission `c97ef268-9ba7-50a5-900a-0d34b285dc0a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $N\neq 0$ and an element $j_0$ of $\overline{\mathbb{Q}}$ (realised as
+`AlgebraicClosure ℚ`). The field in play is `modularFunctionFieldBar N`, the subfield of the Laurent
+series field $\overline{\mathbb{Q}}((q))$ generated over $\overline{\mathbb{Q}}$ by the
+coefficientwise images of the elements of `modularFunctionFieldFull N`, the latter being the
+subfield of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by the divisor expansions attached to $N$;
+inside it, `jBar N` is the coefficientwise image of the $q$-expansion $j(q)$. A place of this field
+over $\overline{\mathbb{Q}}$ is a valuation subring, different from the whole field, containing the
+image of $\overline{\mathbb{Q}}$ and being a principal ideal ring; its degree is the
+$\overline{\mathbb{Q}}$-dimension of its residue field, and $v.\mathrm{ord}(f)$ is minus the
+logarithm of the associated $\mathbb{Z}^{m0}$-valued adic valuation of $f$. Assume every such place
+has degree $1$, and let $S$ be a finite set of places whose members are exactly the places $v$ with
+$v.\mathrm{ord}\bigl(\mathrm{jBar}\,N-j_0\bigr)>0$. Then $\sum_{v\in S}
+v.\mathrm{ord}\bigl(\mathrm{jBar}\,N-j_0\bigr)=\psi(N)$, where $\psi(N)=\sum_{d\mid N,\ d\
+\text{squarefree}} N/d$ is the Dedekind psi function.
+
+This is the statement that on the modular curve $X_0(N)$ over $\overline{\mathbb{Q}}$ the divisor of
+zeros of $\bar\jmath-j_0$ has degree equal to $\psi(N)$, the degree of the covering of the $j$-line;
+the individual orders (ramification indices above $j_0$) are not identified, and the fibre over
+$j=\infty$ is not addressed. It feeds the computations of Hecke divisors and of fibres in the
+characteristic-$p$ model of $X_0(N)$, and the Riemann–Roch estimates used there.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_sum_ord_jBar_sub_eq_dedekindPsi.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+open AlgebraicCurve Place
+
+namespace P2MW.S_ModularCurve_sum_ord_jBar_sub_eq_dedekindPsi
+
+noncomputable section
+
+p2m_open "AlgebraicCurve ModularCurve \
+  P2MW.S_ModularCurve_sum_ord_jBar_sub_eq_dedekindPsi.ModularCurve IsDedekindDomain WithZero"
+
+namespace B2Peo3
+
+section General
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+
+
+theorem mem_of_ord_sub_pos (w : Place K F) {f : F} {c : K}
+    (h : 0 < w.ord (f - algebraMap K F c)) : f ∈ w.toValuationSubring := by
+  have hne : f - algebraMap K F c ≠ 0 := by
+    intro h0
+    rw [h0, Place.ord_zero] at h
+    exact lt_irrefl _ h
+  have := add_mem (mem_of_ord_nonneg w hne h.le) (w.algebraMap_mem' c)
+  rwa [sub_add_cancel] at this
+
+theorem ord_eq_one_of_valuation_eq (w : Place K F) {v' : Valuation F ℤᵐ⁰}
+    (hv' : v'.valuationSubring = w.toValuationSubring) {x : F} (hx : v' x = exp (-1 : ℤ)) :
+    w.ord x = 1 := by
+  have hE := w.isEquiv_adicValuation_of_valuationSubring_eq hv'
+  have hx0 : v' x ≠ 0 := by rw [hx]; exact exp_ne_zero
+  have hu0 : w.adicValuation x ≠ 0 := (hE.eq_zero).ne.mp hx0
+  have hlt : w.adicValuation x < 1 := by
+    refine hE.lt_one_iff_lt_one.mp ?_
+    rw [hx, ← exp_zero]
+    exact exp_lt_exp.mpr (by norm_num)
+  obtain ⟨ϖ, hϖ⟩ := w.heightOneSpectrum.valuation_exists_uniformizer F
+  change w.adicValuation ϖ = exp (-1 : ℤ) at hϖ
+  have hϖ0 : w.adicValuation ϖ ≠ 0 := by rw [hϖ]; exact exp_ne_zero
+  have hϖlt : v' ϖ < 1 := by
+    refine hE.lt_one_iff_lt_one.mpr ?_
+    rw [hϖ, ← exp_zero]
+    exact exp_lt_exp.mpr (by norm_num)
+  have hϖ0' : v' ϖ ≠ 0 := (hE.eq_zero).ne.mpr hϖ0
+  have hϖle : v' ϖ ≤ v' x := by
+    rw [hx, ← log_le_iff_le_exp hϖ0']
+    have hlog : log (v' ϖ) < 0 := (log_lt_iff_lt_exp hϖ0').mpr (by rw [exp_zero]; exact hϖlt)
+    omega
+  have hge : exp (-1 : ℤ) ≤ w.adicValuation x := by
+    rw [← hϖ]
+    exact (hE ϖ x).mp hϖle
+  have hle' : log (w.adicValuation x) ≤ -1 := by
+    have hlog : log (w.adicValuation x) < 0 :=
+      (log_lt_iff_lt_exp hu0).mpr (by rw [exp_zero]; exact hlt)
+    omega
+  have hge' : -1 ≤ log (w.adicValuation x) := (le_log_iff_exp_le hu0).mpr hge
+  simp only [Place.ord]
+  omega
+
+scoped instance instIsPrincipalIdealRingAdjoinSingleton (t : F) :
+    IsPrincipalIdealRing (Algebra.adjoin K ({t} : Set F)) := by
+  have hmem : ∀ p : Polynomial K, Polynomial.aeval t p ∈ Algebra.adjoin K ({t} : Set F) := by
+    intro p
+    rw [Algebra.adjoin_singleton_eq_range_aeval]
+    exact ⟨p, rfl⟩
+  refine IsPrincipalIdealRing.of_surjective
+    ((Polynomial.aeval t).codRestrict (Algebra.adjoin K ({t} : Set F)) hmem) ?_
+  rintro ⟨a, ha⟩
+  obtain ⟨p, hp⟩ : ∃ p : Polynomial K, Polynomial.aeval t p = a := by
+    rw [Algebra.adjoin_singleton_eq_range_aeval] at ha
+    exact (AlgHom.mem_range _).mp ha
+  exact ⟨p, Subtype.ext hp⟩
+
+def linGen (t : F) (c : K) : Algebra.adjoin K ({t} : Set F) :=
+  ⟨t, Algebra.self_mem_adjoin_singleton K t⟩ - algebraMap K _ c
+
+@[scoped simp] theorem coe_linGen (t : F) (c : K) :
+    ((linGen t c : Algebra.adjoin K ({t} : Set F)) : F) = t - algebraMap K F c := by
+  simp [linGen]
+
+section Transcendental
+
+variable (t : F) (htr : Transcendental K t)
+
+include htr in
+theorem linGen_ne_zero (c : K) : linGen t c ≠ 0 := by
+  intro h
+  have h' := congrArg (fun a : Algebra.adjoin K ({t} : Set F) => (a : F)) h
+  simp only [coe_linGen, ZeroMemClass.coe_zero, sub_eq_zero] at h'
+  exact htr (by rw [h']; exact isAlgebraic_algebraMap c)
+
+def polyEquiv : Polynomial K ≃ₐ[K] Algebra.adjoin K ({t} : Set F) :=
+  (AlgEquiv.ofInjective (Polynomial.aeval t) (transcendental_iff_injective.mp htr)).trans
+    (Subalgebra.equivOfEq _ _ (by rw [Algebra.adjoin_singleton_eq_range_aeval]))
+
+theorem polyEquiv_X_sub_C (c : K) :
+    polyEquiv t htr (Polynomial.X - Polynomial.C c) = linGen t c := by
+  apply Subtype.ext
+  rw [coe_linGen]
+  simp [polyEquiv, Subalgebra.equivOfEq_apply, AlgEquiv.ofInjective_apply]
+
+include htr in
+theorem prime_linGen (c : K) : Prime (linGen t c) := by
+  rw [← polyEquiv_X_sub_C t htr c, MulEquiv.prime_iff]
+  exact Polynomial.prime_X_sub_C c
+
+def linPrime (c : K) : HeightOneSpectrum (Algebra.adjoin K ({t} : Set F)) :=
+  ⟨Ideal.span {linGen t c}, (Ideal.span_singleton_prime (linGen_ne_zero t htr c)).mpr
+    (prime_linGen t htr c), by
+      rw [ne_eq, Ideal.span_singleton_eq_bot]
+      exact linGen_ne_zero t htr c⟩
+
+open scoped IntermediateField.algebraAdjoinAdjoin
+
+def basePlace (c : K) : Place K (IntermediateField.adjoin K ({t} : Set F)) :=
+  Place.ofHeightOneSpectrum (K := K) (linPrime t htr c)
+
+theorem algebraMap_linGen (c : K) :
+    algebraMap (Algebra.adjoin K ({t} : Set F)) (IntermediateField.adjoin K ({t} : Set F))
+        (linGen t c) =
+      IntermediateField.AdjoinSimple.gen K t - algebraMap K _ c := by
+  apply Subtype.ext
+  rw [IntermediateField.algebraAdjoinAdjoin.coe_algebraMap, coe_linGen]
+  simp
+
+theorem ord_basePlace (c : K) :
+    (basePlace t htr c).ord (IntermediateField.AdjoinSimple.gen K t - algebraMap K _ c) = 1 := by
+  rw [← algebraMap_linGen]
+  refine ord_eq_one_of_valuation_eq (basePlace t htr c)
+    (v' := (linPrime t htr c).valuation (IntermediateField.adjoin K ({t} : Set F))) rfl ?_
+  rw [HeightOneSpectrum.valuation_of_algebraMap]
+  exact (linPrime t htr c).intValuation_singleton (linGen_ne_zero t htr c) rfl
+
+theorem forall_algebraMap_mem (v : Place K (IntermediateField.adjoin K ({t} : Set F)))
+    (ht : IntermediateField.AdjoinSimple.gen K t ∈ v.toValuationSubring)
+    (r : Algebra.adjoin K ({t} : Set F)) :
+    algebraMap (Algebra.adjoin K ({t} : Set F)) (IntermediateField.adjoin K ({t} : Set F)) r ∈
+      v.toValuationSubring := by
+  obtain ⟨x, hx⟩ := r
+  change (⟨x, IntermediateField.algebra_adjoin_le_adjoin K _ hx⟩ :
+      IntermediateField.adjoin K ({t} : Set F)) ∈ v.toValuationSubring
+  induction hx using Algebra.adjoin_induction with
+  | mem y hy =>
+    have hy' : y = t := Set.mem_singleton_iff.mp hy
+    subst hy'
+    exact ht
+  | algebraMap a => exact v.algebraMap_mem' a
+  | add y z hy hz ihy ihz => exact add_mem ihy ihz
+  | mul y z hy hz ihy ihz => exact mul_mem ihy ihz
+
+include htr in
+theorem eq_basePlace_of_ord_pos (v : Place K (IntermediateField.adjoin K ({t} : Set F))) (c : K)
+    (hv : 0 < v.ord (IntermediateField.AdjoinSimple.gen K t - algebraMap K _ c)) :
+    v = basePlace t htr c := by
+  have ht : IntermediateField.AdjoinSimple.gen K t ∈ v.toValuationSubring := mem_of_ord_sub_pos v hv
+  have hw := forall_algebraMap_mem t v ht
+  have hmem : linGen t c ∈ Place.center (Algebra.adjoin K ({t} : Set F)) v hw := by
+    rw [Place.mem_center_iff_ord_pos v hw (linGen_ne_zero t htr c), algebraMap_linGen]
+    exact hv
+  have hcenter : Place.center (Algebra.adjoin K ({t} : Set F)) v hw = Ideal.span {linGen t c} := by
+    have : (Ideal.span {linGen t c}).IsPrime := (linPrime t htr c).isPrime
+    have hmax : (Ideal.span {linGen t c}).IsMaximal :=
+      IsPrime.to_maximal_ideal (linPrime t htr c).ne_bot
+    exact (hmax.eq_of_le (Ideal.IsPrime.ne_top inferInstance)
+      ((Ideal.span_singleton_le_iff_mem _).mpr hmem)).symm
+  have hc : Place.centerHeightOneSpectrum (Algebra.adjoin K ({t} : Set F)) v hw =
+      linPrime t htr c := HeightOneSpectrum.ext hcenter
+  apply Place.ext
+  rw [v.toValuationSubring_eq_of_forall_mem hw, hc,
+    HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+  rfl
+
+scoped instance charZero_adjoin [CharZero K] : CharZero (IntermediateField.adjoin K ({t} : Set F))
+  :=
+  charZero_of_injective_algebraMap (algebraMap K _).injective
+
+variable [CharZero K] [FiniteDimensional (IntermediateField.adjoin K ({t} : Set F)) F]
+
+omit [CharZero K] [FiniteDimensional (IntermediateField.adjoin K ({t} : Set F)) F] in
+theorem algebraMap_gen_sub (c : K) :
+    algebraMap (IntermediateField.adjoin K ({t} : Set F)) F
+        (IntermediateField.AdjoinSimple.gen K t - algebraMap K _ c) =
+      t - algebraMap K F c := by
+  rw [map_sub, IntermediateField.AdjoinSimple.algebraMap_gen,
+    ← IsScalarTower.algebraMap_apply]
+
+omit [CharZero K] in
+theorem ord_sub_eq_mul (w : Place K F) (c : K) :
+    w.ord (t - algebraMap K F c) =
+      w.ramificationIndex (IntermediateField.adjoin K ({t} : Set F)) *
+        (w.restrict (IntermediateField.adjoin K ({t} : Set F))).ord
+          (IntermediateField.AdjoinSimple.gen K t - algebraMap K _ c) := by
+  rw [← algebraMap_gen_sub t c, Place.ord_restrict]
+
+omit [CharZero K] in
+include htr in
+theorem restrict_eq_basePlace_iff (w : Place K F) (c : K) :
+    w.restrict (IntermediateField.adjoin K ({t} : Set F)) = basePlace t htr c ↔
+      0 < w.ord (t - algebraMap K F c) := by
+  constructor
+  · intro h
+    rw [ord_sub_eq_mul t w c, h, ord_basePlace, mul_one]
+    exact_mod_cast w.ramificationIndex_pos (F := IntermediateField.adjoin K ({t} : Set F))
+  · intro h
+    refine eq_basePlace_of_ord_pos t htr _ c ?_
+    rw [ord_sub_eq_mul t w c] at h
+    exact (pos_iff_pos_of_mul_pos h).mp
+      (by exact_mod_cast w.ramificationIndex_pos (F := IntermediateField.adjoin K ({t} : Set F)))
+
+omit [CharZero K] in
+include htr in
+theorem ramificationIndex_eq_ord (w : Place K F) (c : K) (h : 0 < w.ord (t - algebraMap K F c)) :
+    (w.ramificationIndex (IntermediateField.adjoin K ({t} : Set F)) : ℤ) =
+      w.ord (t - algebraMap K F c) := by
+  rw [ord_sub_eq_mul t w c, (restrict_eq_basePlace_iff t htr w c).mpr h, ord_basePlace, mul_one]
+
+omit [CharZero K] in
+theorem inertiaDeg_eq_one (w : Place K F) (hw : w.deg = 1) :
+    w.inertiaDeg (IntermediateField.adjoin K ({t} : Set F)) = 1 := by
+  have h := w.deg_restrict_mul_inertiaDeg (F := IntermediateField.adjoin K ({t} : Set F))
+  rw [hw] at h
+  exact Nat.eq_one_of_mul_eq_one_left h
+
+include htr in
+theorem sum_ord_sub_eq_finrank (hdeg : ∀ w : Place K F, w.deg = 1) (c : K)
+    (S : Finset (Place K F)) (hS : ∀ w, w ∈ S ↔ 0 < w.ord (t - algebraMap K F c)) :
+    ∑ w ∈ S, w.ord (t - algebraMap K F c) =
+      Module.finrank (IntermediateField.adjoin K ({t} : Set F)) F := by
+  have hSfib : S = (basePlace t htr c).fiberOver F := by
+    ext w
+    rw [hS, Place.mem_fiberOver, restrict_eq_basePlace_iff t htr]
+  have hsum := Place.sum_ramificationIndex_mul_inertiaDeg_fiberOver (F' := F) (basePlace t htr c)
+  rw [← hSfib] at hsum
+  rw [← hsum]
+  refine Finset.sum_congr rfl fun w hw => ?_
+  rw [inertiaDeg_eq_one t w (hdeg w), Nat.cast_one, mul_one,
+    ramificationIndex_eq_ord t htr w c ((hS w).mp hw)]
+
+include htr in
+theorem exists_finset_ord_sub_pos (c : K) :
+    ∃ S : Finset (Place K F), ∀ w, w ∈ S ↔ 0 < w.ord (t - algebraMap K F c) :=
+  ⟨(basePlace t htr c).fiberOver F, fun w => by
+    rw [Place.mem_fiberOver, restrict_eq_basePlace_iff t htr]⟩
+
+end Transcendental
+
+end General
+
+theorem finrank_adjoin_jBar_eq_dedekindPsi (N : ℕ) [NeZero N] :
+    Module.finrank
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)))
+      (modularFunctionFieldBar N) = dedekindPsi N := by
+  have hcm : IntermediateField.comap (modularFunctionFieldBar N).val
+        (IntermediateField.adjoin (AlgebraicClosure ℚ)
+          ({((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))} :
+            Set (LaurentSeries (AlgebraicClosure ℚ))))
+      = IntermediateField.adjoin (AlgebraicClosure ℚ)
+          ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)) := by
+    rw [← IntermediateField.lift_adjoin_simple]
+    exact IntermediateField.comap_map (modularFunctionFieldBar N).val _
+  have h1 := IntermediateField.finrank_comap
+    (IntermediateField.adjoin (AlgebraicClosure ℚ)
+      ({((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))} :
+        Set (LaurentSeries (AlgebraicClosure ℚ))))
+    (modularFunctionFieldBar N).val
+  rw [hcm, IntermediateField.fieldRange_val] at h1
+  have h2 : IntermediateField.relfinrank
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({((jBar N : modularFunctionFieldBar N) : LaurentSeries (AlgebraicClosure ℚ))} :
+          Set (LaurentSeries (AlgebraicClosure ℚ))))
+      (modularFunctionFieldBar N) = dedekindPsi N := by
+    rw [← ModularCurve.relfinrank_full_eq_dedekindPsi N,
+      ← ModularCurve.relfinrank_laurentBaseChange_modularFunctionFieldFull (AlgebraicClosure ℚ) N]
+  rw [← h2]
+  exact h1
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+scoped instance finiteDimensional_adjoin_jBar (N : ℕ) [NeZero N] :
+    FiniteDimensional
+      (IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({(jBar N : modularFunctionFieldBar N)} : Set (modularFunctionFieldBar N)))
+      (modularFunctionFieldBar N) :=
+  Module.finite_of_finrank_pos (by
+    rw [finrank_adjoin_jBar_eq_dedekindPsi]
+    exact ModularCurve.dedekindPsi_pos N (NeZero.ne N))
+
+end B2Peo3
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jBar modularFunctionFieldBar dedekindPsi \
+  relfinrank_laurentBaseChange_modularFunctionFieldFull relfinrank_full_eq_dedekindPsi \
+  dedekindPsi_pos transcendental_coeffEmb_jq"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+open B2Peo3 in
+private theorem ModularCurve.sum_ord_jBar_sub_eq_dedekindPsi (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ)
+    (hdeg : ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), w.deg = 1)
+    (S : Finset (Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)))
+    (hS : ∀ v, v ∈ S ↔
+      0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)) :
+    ∑ v ∈ S, v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) =
+      dedekindPsi N := by
+  rw [← finrank_adjoin_jBar_eq_dedekindPsi N]
+  exact_mod_cast sum_ord_sub_eq_finrank (jBar N : modularFunctionFieldBar N)
+    (ModularCurve.transcendental_coeffEmb_jq (AlgebraicClosure ℚ) N) hdeg j₀ S hS
+
+p2m_open_scoped "ModularCurve" in
+open B2Peo3 in
+private theorem ModularCurve.exists_finset_ord_jBar_sub_pos (N : ℕ) [NeZero N]
+    (j₀ : AlgebraicClosure ℚ) :
+    ∃ S : Finset (Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)), ∀ v, v ∈ S ↔
+      0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) :=
+  exists_finset_ord_sub_pos (jBar N : modularFunctionFieldBar N)
+    (ModularCurve.transcendental_coeffEmb_jq (AlgebraicClosure ℚ) N) j₀
+
+end
+
+open AlgebraicCurve _root_.ModularCurve
+  _root_.P2MW.S_ModularCurve_sum_ord_jBar_sub_eq_dedekindPsi.ModularCurve in
+theorem solution (N : ℕ) [NeZero N] (j₀ : AlgebraicClosure ℚ)
+    (hdeg : ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), w.deg = 1)
+    (S : Finset (Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)))
+    (hS : ∀ v, v ∈ S ↔
+      0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)) :
+    ∑ v ∈ S, v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) =
+      dedekindPsi N :=
+  ModularCurve.sum_ord_jBar_sub_eq_dedekindPsi N j₀ hdeg S hS
+
+end S_ModularCurve_sum_ord_jBar_sub_eq_dedekindPsi
+end P2MW
+export P2MW.S_ModularCurve_sum_ord_jBar_sub_eq_dedekindPsi (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve ModularCurve
+theorem ModularCurve.sum_ord_jBar_sub_eq_dedekindPsi (N : ℕ) [NeZero N] (j₀ : AlgebraicClosure ℚ)
+    (hdeg : ∀ w : Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N), w.deg = 1)
+    (S : Finset (Place (AlgebraicClosure ℚ) (modularFunctionFieldBar N)))
+    (hS : ∀ v, v ∈ S ↔
+      0 < v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀)) :
+    ∑ v ∈ S, v.ord (jBar N - algebraMap (AlgebraicClosure ℚ) (modularFunctionFieldBar N) j₀) =
+      dedekindPsi N :=
+  solution N j₀ hdeg S hS
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_tendsto_atImInfty_of_hasSum_qParam.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_tendsto_atImInfty_of_hasSum_qParam.lean
new file mode 100644
index 0000000000..8d0cab9039
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_tendsto_atImInfty_of_hasSum_qParam.lean
@@ -0,0 +1,234 @@
+/-
+Based on Prove2Me node ModularCurve.tendsto_atImInfty_of_hasSum_qParam
+(99e3990b-a664-51c3-aced-4302ef14c172) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f78ca6b2-75b2-5d34-b8df-4d0ef380ad0f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Exp
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Manifold
+public import Mathlib.Analysis.Complex.UpperHalfPlane.FunctionsBoundedAtInfty
+
+import Mathlib.NumberTheory.ModularForms.QExpansion
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Convergent q-expansion tends to its constant term at i∞
+
+Theorem statement: `ModularCurve.tendsto_atImInfty_of_hasSum_qParam`
+(`99e3990b-a664-51c3-aced-4302ef14c172`), by Claude, 2026-09-05.
+
+Proof: submission `f78ca6b2-75b2-5d34-b8df-4d0ef380ad0f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $h$ be a real number with $0 < h$, let $F \colon \mathfrak{H} \to \mathbb{C}$ be an arbitrary
+function on the upper half-plane, and let $(c_m)_{m \in \mathbb{N}}$ be a sequence of complex
+numbers. Assume that for every $\tau \in \mathfrak{H}$ the series $\sum_{m \ge 0} c_m\, q^m$, where
+$q = \mathrm{qParam}\,h\,\tau = e^{2\pi i \tau / h}$ is Mathlib's $q$-parameter of period $h$, is
+summable with sum exactly $F(\tau)$ (the hypothesis is `HasSum`, i.e. unconditional summability of
+the family indexed by $m \in \mathbb{N}$ together with the identification of its sum with $F(\tau)$;
+no hypothesis of local uniformity or of holomorphy of $F$ is imposed). The conclusion is that $F$
+converges to $c_0$ along the filter `UpperHalfPlane.atImInfty`, the filter generated by the sets on
+which $\operatorname{Im} \tau$ exceeds a given bound: that is, $F(\tau) \to c_0$ as
+$\operatorname{Im} \tau \to \infty$.
+
+This is the standard statement that a function on the upper half-plane given by a convergent
+$q$-expansion of period $h$ is holomorphic-at-the-cusp-style bounded at $i\infty$, with limiting
+value the constant term $c_0$; in particular such an $F$ is bounded near $i\infty$. It is used in
+the treatment of Siegel units and in the estimates bounding slashed modular functions in terms of
+$q$-parameters.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_tendsto_atImInfty_of_hasSum_qParam.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_tendsto_atImInfty_of_hasSum_qParam
+
+noncomputable section
+
+open UpperHalfPlane Complex Filter Topology Function
+open scoped MatrixGroups ModularForm
+
+local notation "𝕢" => Function.Periodic.qParam
+
+namespace ModularCurve
+
+namespace Realized
+
+variable {h : ℝ} {F : ℍ → ℂ} {c : ℕ → ℂ}
+
+lemma norm_qParam_lt_one_of_pos (hh : 0 < h) (τ : ℍ) : ‖𝕢 h (τ : ℂ)‖ < 1 := by
+  rw [Periodic.norm_qParam, Real.exp_lt_one_iff, neg_mul, coe_im, neg_mul, neg_div, neg_lt_zero]
+  exact div_pos (by positivity [τ.im_pos]) hh
+
+lemma hasSum_cuspFunction_punctured (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) {q : ℂ} (hq : ‖q‖ < 1)
+    (hq1 : q ≠ 0) : HasSum (fun m : ℕ => c m * q ^ m) (cuspFunction h F q) := by
+  have h1 := Periodic.im_invQParam_pos_of_norm_lt_one hh hq hq1
+  let τ : ℍ := ⟨Periodic.invQParam h q, h1⟩
+  have h2 := Periodic.cuspFunction_eq_of_nonzero h (F ∘ ofComplex) hq1
+  have h3 : cuspFunction h F q = F τ := by
+    simp only [comp_apply, UpperHalfPlane.ofComplex_apply_of_im_pos h1] at h2
+    exact h2
+  have h4 : 𝕢 h (τ : ℂ) = q := Periodic.qParam_right_inv hh.ne' hq1
+  rw [h3, ← h4]
+  exact hF τ
+
+lemma hasFPowerSeriesOnBall_update (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) :
+    HasFPowerSeriesOnBall (update (cuspFunction h F) 0 (c 0)) (.ofScalars ℂ c) 0 1 := by
+  constructor
+  · refine le_of_forall_lt_imp_le_of_dense fun r hr ↦ ?_
+    rcases eq_or_ne r 0 with rfl | hr'
+    · simp
+    · lift r to NNReal using hr.ne_top
+      let : FiniteDimensional ℝ ℂ := basisOneI.finiteDimensional_of_finite
+      apply FormalMultilinearSeries.le_radius_of_summable
+      simpa [norm_mul, mul_comm] using
+        (hasSum_cuspFunction_punctured hh hF (q := r) (by simpa using hr)
+          (mod_cast hr')).summable.norm
+  · simp
+  · intro y hy
+    rw [zero_add]
+    rw [← ENNReal.coe_one, Metric.eball_coe, NNReal.coe_one, mem_ball_zero_iff] at hy
+    rcases eq_or_ne y 0 with rfl | hy'
+    · simpa +contextual [zero_pow_eq] using hasSum_ite_eq 0 (c 0)
+    · simpa [update_of_ne hy', mul_comm] using hasSum_cuspFunction_punctured hh hF hy hy'
+
+def discFun (h : ℝ) (F : ℍ → ℂ) (c : ℕ → ℂ) : ℂ → ℂ := update (cuspFunction h F) 0 (c 0)
+
+lemma hasSum_discFun (hh : 0 < h) (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ))
+    {q : ℂ} (hq : ‖q‖ < 1) : HasSum (fun m : ℕ => c m * q ^ m) (discFun h F c q) := by
+  have hy : q ∈ Metric.eball (0 : ℂ) 1 := by
+    rw [← ENNReal.coe_one, Metric.eball_coe]; simpa using hq
+  have h := (hasFPowerSeriesOnBall_update hh hF).hasSum hy
+  rw [zero_add] at h
+  simpa [discFun, mul_comm] using h
+
+lemma apply_eq_discFun (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ))
+    (τ : ℍ) : F τ = discFun h F c (𝕢 h (τ : ℂ)) :=
+  (hF τ).unique (hasSum_discFun hh hF (norm_qParam_lt_one_of_pos hh τ))
+
+lemma differentiableOn_discFun (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) :
+    DifferentiableOn ℂ (discFun h F c) (Metric.ball 0 1) := by
+  have h1 := (hasFPowerSeriesOnBall_update hh hF).differentiableOn
+  rwa [← ENNReal.coe_one, Metric.eball_coe, NNReal.coe_one] at h1
+
+lemma continuousAt_discFun (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) {q : ℂ} (hq : ‖q‖ < 1) :
+    ContinuousAt (discFun h F c) q :=
+  ((differentiableOn_discFun hh hF).differentiableAt
+    (Metric.isOpen_ball.mem_nhds (by simpa using hq))).continuousAt
+
+lemma discFun_zero : discFun h F c 0 = c 0 := by simp [discFun]
+
+theorem mdifferentiable (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) :
+    MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) F := by
+  rw [UpperHalfPlane.mdifferentiable_iff]
+  have h1 : DifferentiableOn ℂ (fun z : ℂ => discFun h F c (𝕢 h z)) {z : ℂ | 0 < z.im} := by
+    intro z hz
+    have hzq : ‖𝕢 h z‖ < 1 := by
+      have := norm_qParam_lt_one_of_pos hh ⟨z, hz⟩
+      simpa using this
+    exact (((differentiableOn_discFun hh hF).differentiableAt
+      (Metric.isOpen_ball.mem_nhds (by simpa using hzq))).comp z
+      ((Periodic.differentiable_qParam (h := h)) z)).differentiableWithinAt
+  refine h1.congr fun z hz => ?_
+  simp only [Function.comp_apply, apply_eq_discFun hh hF, ofComplex_apply_of_im_pos hz]
+
+theorem tendsto_atImInfty (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) :
+    Tendsto F atImInfty (𝓝 (c 0)) := by
+  have h1 : Tendsto (fun τ : ℍ => discFun h F c (𝕢 h (τ : ℂ))) atImInfty (𝓝 (discFun h F c 0)) :=
+    (continuousAt_discFun hh hF (q := 0) (by simp)).tendsto.comp (qParam_tendsto_atImInfty hh)
+  rw [discFun_zero] at h1
+  exact h1.congr fun τ => (apply_eq_discFun hh hF τ).symm
+
+theorem isBoundedAtImInfty (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) :
+    IsBoundedAtImInfty F :=
+  (tendsto_atImInfty hh hF).isBigO_one ℝ
+
+theorem periodic (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ)) :
+    Periodic (F ∘ ofComplex) h := by
+  intro w
+  by_cases hw : 0 < w.im
+  · have hw' : 0 < (w + h).im := by simpa using hw
+    simp only [Function.comp_apply, apply_eq_discFun hh hF, ofComplex_apply_of_im_pos hw,
+      ofComplex_apply_of_im_pos hw']
+    congr 1
+    simp only [Periodic.qParam]
+    rw [show 2 * ↑Real.pi * Complex.I * (w + ↑h) / ↑h = 2 * ↑Real.pi * Complex.I * w / ↑h + 2 *
+      ↑Real.pi * Complex.I by
+      field_simp [(Complex.ofReal_ne_zero.mpr hh.ne')]]
+    rw [Complex.exp_add, Complex.exp_two_pi_mul_I, mul_one]
+  · push Not at hw
+    have hw' : (w + h).im ≤ 0 := by simpa using hw
+    simp only [Function.comp_apply, ofComplex_apply_eq_of_im_nonpos hw' hw]
+
+theorem coeff_unique {d : ℕ → ℂ} (hh : 0 < h)
+    (hF : ∀ τ : ℍ, HasSum (fun m : ℕ => c m * 𝕢 h (τ : ℂ) ^ m) (F τ))
+    (hF' : ∀ τ : ℍ, HasSum (fun m : ℕ => d m * 𝕢 h (τ : ℂ) ^ m) (F τ)) : c = d := by
+  have hc := hasFPowerSeriesOnBall_update hh hF
+  have hd := hasFPowerSeriesOnBall_update hh hF'
+  have hlim : ∀ {e : ℕ → ℂ}, HasFPowerSeriesOnBall (update (cuspFunction h F) 0 (e 0)) (.ofScalars ℂ
+    e) 0 1 →
+      Tendsto (cuspFunction h F) (𝓝[≠] 0) (𝓝 (e 0)) := by
+    intro e he
+    have h1 : Tendsto (update (cuspFunction h F) 0 (e 0)) (𝓝[≠] 0) (𝓝 (e 0)) := by
+      have := he.hasFPowerSeriesAt.continuousAt.tendsto
+      rw [update_self] at this
+      exact this.mono_left nhdsWithin_le_nhds
+    refine h1.congr' ?_
+    filter_upwards [self_mem_nhdsWithin] with z hz using update_of_ne hz ..
+  have h0 : c 0 = d 0 := tendsto_nhds_unique (hlim hc) (hlim hd)
+  have hd' : HasFPowerSeriesOnBall (update (cuspFunction h F) 0 (c 0)) (.ofScalars ℂ d) 0 1 :=
+    h0 ▸ hd
+  have heq := hc.hasFPowerSeriesAt.eq_formalMultilinearSeries hd'.hasFPowerSeriesAt
+  funext m
+  simpa using congr_arg (FormalMultilinearSeries.coeff · m) heq
+
+end Realized
+
+end ModularCurve
+
+theorem solution (h : ℝ) (hh : 0 < h) (F : UpperHalfPlane → ℂ) (c : ℕ → ℂ) (hc : ∀ τ :
+  UpperHalfPlane, HasSum (fun m : ℕ => c m * Function.Periodic.qParam h (τ : ℂ) ^ m) (F τ)) :
+    Filter.Tendsto F UpperHalfPlane.atImInfty (nhds (c 0)) :=
+  ModularCurve.Realized.tendsto_atImInfty hh hc
+
+end
+
+end S_ModularCurve_tendsto_atImInfty_of_hasSum_qParam
+end P2MW
+export P2MW.S_ModularCurve_tendsto_atImInfty_of_hasSum_qParam (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.tendsto_atImInfty_of_hasSum_qParam (h : ℝ) (hh : 0 < h) (F : UpperHalfPlane →
+  ℂ) (c : ℕ → ℂ) (hc : ∀ τ : UpperHalfPlane, HasSum (fun m : ℕ => c m * Function.Periodic.qParam h
+  (τ : ℂ) ^ m) (F τ)) :
+    Filter.Tendsto F UpperHalfPlane.atImInfty (nhds (c 0)) :=
+  solution h hh F c hc
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_thetaL_coeffMap_eq_coeffMap_single_mul_derivative.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_thetaL_coeffMap_eq_coeffMap_single_mul_derivative.lean
new file mode 100644
index 0000000000..8883207917
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_thetaL_coeffMap_eq_coeffMap_single_mul_derivative.lean
@@ -0,0 +1,112 @@
+/-
+Based on Prove2Me node ModularCurve.thetaL_coeffMap_eq_coeffMap_single_mul_derivative
+(3c30c1ea-1e77-5efe-bbed-f3a4bfcc39c4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b97914a7-e9ca-53ec-a883-8830f1dbff86
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QExpansionDiff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Naturality of θ = q d/dq under coefficient base change
+
+Theorem statement: `ModularCurve.thetaL_coeffMap_eq_coeffMap_single_mul_derivative`
+(`3c30c1ea-1e77-5efe-bbed-f3a4bfcc39c4`), by Claude, 2026-09-05.
+
+Proof: submission `b97914a7-e9ca-53ec-a883-8830f1dbff86`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring, $K$ a field, $\varphi : R \to K$ a ring homomorphism, and $w$ a
+Laurent series over $R$ (an element of `LaurentSeries R`, i.e. a Hahn series over $R$ with value
+group $\mathbb{Z}$). Write `coeffMap` $\varphi$ for the ring homomorphism `LaurentSeries R →+*
+LaurentSeries K` obtained by applying $\varphi$ to every coefficient, and `thetaL` $K$ for the
+$K$-linear operator on `LaurentSeries K` sending $f$ to `HahnSeries.single 1 1` $\cdot$
+`LaurentSeries.derivative K f`, that is $f \mapsto q\,f'$. The assertion is the equality of Laurent
+series over $K$
+$$\mathtt{thetaL}\,K\,(\mathtt{coeffMap}\,\varphi\,w) \;=\;
+\mathtt{coeffMap}\,\varphi\,\bigl(\mathtt{HahnSeries.single}\,1\,1 \cdot
+\mathtt{LaurentSeries.derivative}\,R\,w\bigr),$$
+so that applying $\theta = q\,d/dq$ after pushing the coefficients of $w$ along $\varphi$ gives the
+same result as forming $q\,w'$ over $R$ and then pushing its coefficients along $\varphi$. Note that
+on the right-hand side the operator is written out as multiplication by $q$ composed with the formal
+derivative over $R$, no operator `thetaL R` being available for a general commutative ring.
+
+This is the naturality of the Ramanujan–Serre theta operator $\theta = q\,d/dq$ on $q$-expansions
+with respect to change of the coefficient ring. It is used throughout the treatment of mod $p$
+modular forms, for instance when comparing $\theta$ applied to a $q$-expansion with integral
+coefficients to $\theta$ applied to its reduction, as in the statements about $q$-expansions of mod
+$p$ forms and cusp forms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_thetaL_coeffMap_eq_coeffMap_single_mul_derivative.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_thetaL_coeffMap_eq_coeffMap_single_mul_derivative
+
+namespace ModularCurve
+p2m_export "ModularCurve" "thetaL thetaL_apply coeffMap coeffMap_coeff"
+p2m_open "ModularCurve"
+
+section
+
+variable {R K : Type*} [CommRing R] [Field K]
+
+private theorem coeffMap_single_one (φ : R →+* K) :
+    coeffMap φ (HahnSeries.single (1 : ℤ) (1 : R)) = HahnSeries.single (1 : ℤ) (1 : K) := by
+  ext n
+  rw [coeffMap_coeff, HahnSeries.coeff_single, HahnSeries.coeff_single]
+  split_ifs <;> simp
+
+private theorem derivative_coeffMap (φ : R →+* K) (w : LaurentSeries R) :
+    LaurentSeries.derivative K (coeffMap φ w) = coeffMap φ (LaurentSeries.derivative R w) := by
+  ext n
+  rw [LaurentSeries.derivative_apply, LaurentSeries.hasseDeriv_coeff, coeffMap_coeff,
+    coeffMap_coeff, LaurentSeries.derivative_apply, LaurentSeries.hasseDeriv_coeff, map_zsmul]
+
+private theorem thetaL_coeffMap_impl (φ : R →+* K) (w : LaurentSeries R) :
+    thetaL K (coeffMap φ w) =
+      coeffMap φ (HahnSeries.single (1 : ℤ) (1 : R) * LaurentSeries.derivative R w) := by
+  rw [thetaL_apply, derivative_coeffMap, map_mul, coeffMap_single_one]
+
+end
+
+end ModularCurve
+
+theorem solution {R : Type*} [CommRing R]
+    {K : Type*} [Field K] (φ : R →+* K) (w : LaurentSeries R) :
+    ModularCurve.thetaL K (ModularCurve.coeffMap φ w) =
+      ModularCurve.coeffMap φ (HahnSeries.single (1 : ℤ) (1 : R) * LaurentSeries.derivative R w) :=
+  ModularCurve.thetaL_coeffMap_impl φ w
+
+end S_ModularCurve_thetaL_coeffMap_eq_coeffMap_single_mul_derivative
+end P2MW
+export P2MW.S_ModularCurve_thetaL_coeffMap_eq_coeffMap_single_mul_derivative (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.thetaL_coeffMap_eq_coeffMap_single_mul_derivative {R : Type*} [CommRing R]
+    {K : Type*} [Field K] (φ : R →+* K) (w : LaurentSeries R) :
+    ModularCurve.thetaL K (ModularCurve.coeffMap φ w) =
+      ModularCurve.coeffMap φ (HahnSeries.single (1 : ℤ) (1 : R) * LaurentSeries.derivative R w) :=
+  solution φ w
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_thetaL_jq_mul_deltaSeries.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_thetaL_jq_mul_deltaSeries.lean
new file mode 100644
index 0000000000..80e68d8fec
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_thetaL_jq_mul_deltaSeries.lean
@@ -0,0 +1,131 @@
+/-
+Based on Prove2Me node ModularCurve.thetaL_jq_mul_deltaSeries
+(024ea356-97da-57e2-b8b3-0fb6abb9f7ca) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 203004d2-1ded-585d-8ad5-d584c9ae13c7
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ModularUnit
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QExpansionDiff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_TateFormal
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_eisenstein4_mul_thetaL_delta_sub_eq_eisenstein6_mul_delta
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_theta_mul
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Ramanujan's formula θ j·Δ=-E₄²E₆
+
+Theorem statement: `ModularCurve.thetaL_jq_mul_deltaSeries`
+(`024ea356-97da-57e2-b8b3-0fb6abb9f7ca`), by Claude, 2026-09-05.
+
+Proof: submission `203004d2-1ded-585d-8ad5-d584c9ae13c7`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+The assertion is a single identity in the field of formal Laurent series $\mathbb{Q}(\!(q)\!)$,
+realised as Hahn series over the integers with rational coefficients; it carries no variables and no
+hypotheses. Here `jq` is the Laurent series $\mathrm{single}(-1,1)$ times the image of the power
+series `jNum` (base-changed from $\mathbb{Z}$ to $\mathbb{Q}$), i.e. $q^{-1}$ times the
+$q$-expansion numerator of the $j$-invariant; `deltaSeries` is $\mathrm{single}(1,1)$ times the
+image of the unit power series `dedekindEtaUnit` base-changed to $\mathbb{Q}$, i.e.
+$q\cdot\prod$-type discriminant series; and `thetaL ℚ` is the $\mathbb{Q}$-linear operator on
+$\mathbb{Q}(\!(q)\!)$ sending $f$ to $\mathrm{single}(1,1)$ times the formal derivative of $f$, that
+is $\theta=q\,d/dq$. The power series `eisenstein4` has constant term $1$ and $n$-th coefficient
+$240\sum_{d\mid n}d^3$ for $n\ge 1$, and `eisenstein6` has constant term $1$ and $n$-th coefficient
+$-504\sum_{d\mid n}d^5$. The conclusion is $\theta(j)\cdot\Delta = -\,(E_4^2E_6)$, the right-hand
+side being the product `eisenstein4 ^ 2 * eisenstein6` mapped from $\mathbb{Z}$ to $\mathbb{Q}$ and
+viewed as a Laurent series, negated.
+
+This is Ramanujan's formula for the logarithmic derivative of the modular invariant, $\theta j =
+-E_4^2E_6/\Delta = -E_{14}/\Delta$, in the formal $q$-expansion setting. It feeds the project's
+treatment of $q$-expansions of differentials on $X_0(N)$: it is used for the statements about
+regular differentials and their $q$-expansions along a cusp, and for membership of $\theta(j)$-type
+series in the modular function field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_thetaL_jq_mul_deltaSeries.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_thetaL_jq_mul_deltaSeries
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_thetaL_jq_mul_deltaSeries.ModularCurve"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "eisenstein6 laurentOfInt laurentOfInt_apply eisenstein4 dedekindEtaUnit \
+  dedekindEtaUnitInv dedekindEtaUnit_mul_inv jNum jNumQ jq dedekindEtaUnitQ deltaSeries \
+  deltaSeries_ne_zero thetaL thetaL_apply \
+  eisenstein4_mul_thetaL_delta_sub_eq_eisenstein6_mul_delta theta_mul"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+theorem ModularCurve.RC18C3.jq_mul_deltaSeries :
+    jq * deltaSeries = laurentOfInt ℚ (eisenstein4 ^ 3) := by
+  have hι : ∀ f : PowerSeries ℤ,
+      HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ) f) = laurentOfInt ℚ f := fun
+        f => rfl
+  rw [jq, deltaSeries, dedekindEtaUnitQ, jNumQ, jNum, hι, hι, mul_mul_mul_comm,
+    HahnSeries.single_mul_single,
+    ← map_mul, mul_assoc, mul_comm dedekindEtaUnitInv, dedekindEtaUnit_mul_inv, mul_one, mul_one,
+    show (-1 : ℤ) + 1 = 0 by norm_num, HahnSeries.single_zero_one, one_mul]
+
+p2m_open_scoped "ModularCurve" in
+theorem ModularCurve.RC18C3.deltaSeries_eq_laurentOfInt :
+    deltaSeries = laurentOfInt ℚ (PowerSeries.X * dedekindEtaUnit) := by
+  rw [deltaSeries, dedekindEtaUnitQ, map_mul, laurentOfInt_apply, laurentOfInt_apply,
+    PowerSeries.map_X,
+    HahnSeries.ofPowerSeries_X]
+
+theorem solution :
+    thetaL ℚ jq * deltaSeries =
+      -(HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ) (eisenstein4 ^ 2 *
+        eisenstein6))) := by
+  have hι : ∀ f : PowerSeries ℤ,
+      HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ) f) = laurentOfInt ℚ f := fun
+        f => rfl
+  have hC2 := ModularCurve.eisenstein4_mul_thetaL_delta_sub_eq_eisenstein6_mul_delta
+  rw [hι, hι, hι, ← ModularCurve.RC18C3.deltaSeries_eq_laurentOfInt] at hC2
+  have hjΔ := ModularCurve.RC18C3.jq_mul_deltaSeries
+  rw [map_pow] at hjΔ
+  have hL := ModularCurve.theta_mul jq deltaSeries
+  rw [hjΔ, show laurentOfInt ℚ eisenstein4 ^ 3 =
+      laurentOfInt ℚ eisenstein4 * laurentOfInt ℚ eisenstein4 * laurentOfInt ℚ eisenstein4 by ring,
+    ModularCurve.theta_mul (laurentOfInt ℚ eisenstein4 * laurentOfInt ℚ eisenstein4) (laurentOfInt ℚ
+      eisenstein4),
+    ModularCurve.theta_mul (laurentOfInt ℚ eisenstein4) (laurentOfInt ℚ eisenstein4)] at hL
+  simp only [thetaL_apply] at hC2 ⊢
+  rw [hι, map_mul, map_pow]
+  apply mul_right_cancel₀ deltaSeries_ne_zero
+  linear_combination (-deltaSeries) * hL + (-(laurentOfInt ℚ eisenstein4) ^ 2) * hC2 +
+    (-((HahnSeries.single (1 : ℤ) (1 : ℚ) : LaurentSeries ℚ) * LaurentSeries.derivative ℚ
+      deltaSeries)) * hjΔ
+
+end S_ModularCurve_thetaL_jq_mul_deltaSeries
+end P2MW
+export P2MW.S_ModularCurve_thetaL_jq_mul_deltaSeries (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.thetaL_jq_mul_deltaSeries :
+    thetaL ℚ jq * deltaSeries =
+      -(HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ) (eisenstein4 ^ 2 *
+        eisenstein6))) :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_thetaL_jq_mul_eisenstein4_eq_neg_jq_mul_eisenstein6.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_thetaL_jq_mul_eisenstein4_eq_neg_jq_mul_eisenstein6.lean
new file mode 100644
index 0000000000..d9cad40fb8
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_thetaL_jq_mul_eisenstein4_eq_neg_jq_mul_eisenstein6.lean
@@ -0,0 +1,110 @@
+/-
+Based on Prove2Me node ModularCurve.thetaL_jq_mul_eisenstein4_eq_neg_jq_mul_eisenstein6
+(16225ddb-4c44-53f2-aa2c-ebfd126e3347) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission edf3ee91-9701-5557-afed-04d64c2d8b3c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QExpansionDiff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_TateFormal
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_thetaL_jq_mul_deltaSeries
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Ramanujan's relation θ j· E₄=- j E₆ for formal q-series
+
+Theorem statement: `ModularCurve.thetaL_jq_mul_eisenstein4_eq_neg_jq_mul_eisenstein6`
+(`16225ddb-4c44-53f2-aa2c-ebfd126e3347`), by Claude, 2026-09-05.
+
+Proof: submission `edf3ee91-9701-5557-afed-04d64c2d8b3c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+The assertion is an identity in the field of formal Laurent series $\mathbb{Q}((q))$, realised as
+Hahn series over $\mathbb{Z}$ with coefficients in $\mathbb{Q}$. Three ingredients occur. First,
+`thetaL ℚ` is the $\mathbb{Q}$-linear operator sending $f$ to $\mathrm{single}(1,1)\cdot f'$, i.e.
+$q\,d/dq$. Second, `jq` is the Laurent series $\mathrm{single}(-1,1)$ times the image under
+$\mathbb{Z}\to\mathbb{Q}$ of the integral power series `jNum`, so $q^{-1}$ times the numerator power
+series of the $j$-expansion. Third, `eisenstein4` and `eisenstein6` are the integral power series
+whose $n$-th coefficients are, respectively, $1$ and $240\sum_{d\mid n}d^{3}$ for $n=0$ and $n>0$,
+and $1$ and $-504\sum_{d\mid n}d^{5}$ for $n=0$ and $n>0$; both are pushed into $\mathbb{Q}((q))$ by
+coefficientwise scalar extension followed by the inclusion of power series into Laurent series.
+There are no hypotheses. The conclusion is the equality $$\bigl(q\,dj/dq\bigr)\cdot E_4 \;=\;
+-\,\bigl(j\cdot E_6\bigr)$$ in $\mathbb{Q}((q))$, i.e. Ramanujan's relation stated in
+cross-multiplied form so that no division is needed.
+
+This is the classical differential relation $\theta j=-jE_6/E_4$, equivalently
+$j'=-E_4^{2}E_6/\Delta$, recorded here as an identity of formal $q$-series. It is used in the
+treatment of $q$-expansions of differentials on modular curves, for instance in the computations of
+`diffQExp` along reduction maps and of the $q$-expansion of the diamond differential, and in a
+vanishing criterion for mod $p$ forms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_thetaL_jq_mul_eisenstein4_eq_neg_jq_mul_eisenstein6.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_thetaL_jq_mul_eisenstein4_eq_neg_jq_mul_eisenstein6
+
+p2m_open "ModularCurve \
+  P2MW.S_ModularCurve_thetaL_jq_mul_eisenstein4_eq_neg_jq_mul_eisenstein6.ModularCurve"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "eisenstein6 laurentOfInt eisenstein4 dedekindEtaUnitInv \
+  dedekindEtaUnit_mul_inv jNum jNumQ jq thetaL dedekindEtaUnitQ deltaSeries deltaSeries_ne_zero \
+  thetaL_jq_mul_deltaSeries"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+theorem ModularCurve.RC18Face.jq_mul_deltaSeries :
+    jq * deltaSeries = laurentOfInt ℚ (eisenstein4 ^ 3) := by
+  have hι : ∀ f : PowerSeries ℤ,
+      HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ) f) = laurentOfInt ℚ f := fun
+        f => rfl
+  rw [jq, deltaSeries, dedekindEtaUnitQ, jNumQ, jNum, hι, hι, mul_mul_mul_comm,
+    HahnSeries.single_mul_single,
+    ← map_mul, mul_assoc, mul_comm dedekindEtaUnitInv, dedekindEtaUnit_mul_inv, mul_one, mul_one,
+    show (-1 : ℤ) + 1 = 0 by norm_num, HahnSeries.single_zero_one, one_mul]
+
+theorem solution :
+    thetaL ℚ jq * HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ) eisenstein4) =
+      -(jq * HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ) eisenstein6)) := by
+  have hι : ∀ f : PowerSeries ℤ,
+      HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ) f) = laurentOfInt ℚ f := fun
+        f => rfl
+  have hC3 := ModularCurve.thetaL_jq_mul_deltaSeries
+  have hjΔ := ModularCurve.RC18Face.jq_mul_deltaSeries
+  rw [hι, map_mul, map_pow] at hC3
+  rw [map_pow] at hjΔ
+  rw [hι, hι]
+  apply mul_right_cancel₀ deltaSeries_ne_zero
+  linear_combination laurentOfInt ℚ eisenstein4 * hC3 + laurentOfInt ℚ eisenstein6 * hjΔ
+
+end S_ModularCurve_thetaL_jq_mul_eisenstein4_eq_neg_jq_mul_eisenstein6
+end P2MW
+export P2MW.S_ModularCurve_thetaL_jq_mul_eisenstein4_eq_neg_jq_mul_eisenstein6 (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.thetaL_jq_mul_eisenstein4_eq_neg_jq_mul_eisenstein6 :
+    thetaL ℚ jq * HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ) eisenstein4) =
+      -(jq * HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ) eisenstein6)) :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_theta_coeff.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_theta_coeff.lean
new file mode 100644
index 0000000000..e72cf29587
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_theta_coeff.lean
@@ -0,0 +1,305 @@
+/-
+Based on Prove2Me node ModularCurve.theta_coeff
+(ef949d2a-924c-5748-af33-47cdb6040e5a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7ce33550-81a0-5aa0-890d-e5d206b4718f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_sum_qTwist_coeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Coefficient law for θ = q d/dq on Laurent series
+
+Theorem statement: `ModularCurve.theta_coeff` (`ef949d2a-924c-5748-af33-47cdb6040e5a`), by Claude,
+2026-09-05.
+
+Proof: submission `7ce33550-81a0-5aa0-890d-e5d206b4718f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring and let $f$ be a formal Laurent series over $R$, that is, an element
+of `LaurentSeries R` $=$ `HahnSeries ℤ R`, so $f$ is given by its coefficients $f.\mathrm{coeff}\,n
+\in R$ indexed by $n \in \mathbb{Z}$ with well-ordered support. Let $k \in \mathbb{Z}$. Form the
+product of the monomial `HahnSeries.single (1 : ℤ) (1 : R)` — the series $q$, whose only nonzero
+coefficient is $1$ in degree $1$ — with the formal derivative `LaurentSeries.derivative R f` of $f$.
+The assertion is that the coefficient in degree $k$ of this product, i.e. of $\theta f = q\, f'$,
+equals $k \bullet (f.\mathrm{coeff}\,k)$, the action of the integer $k$ on the element
+$f.\mathrm{coeff}\,k$ of $R$ viewed as a $\mathbb{Z}$-module. No hypothesis beyond commutativity of
+$R$ is imposed; in particular $k$ ranges over all integers, positive, zero and negative, and no
+invertibility or characteristic assumption is made.
+
+This is the coefficient description of the classical operator $\theta = q\,\frac{d}{dq}$ acting on
+$q$-expansions, here realised purely formally on Laurent series over an arbitrary commutative ring.
+It serves as the working interface for $\theta$ in the $q$-expansion side of the treatment of
+modular curves and modular forms, and is invoked by a large number of later results, among them the
+dimension bound
+[`CuspForm.dimFormula_le_finrank_gamma0`](thm.html#CuspForm.dimFormula_le_finrank_gamma0) and
+computations with normalised derivatives of $q$-expansions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_theta_coeff.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_theta_coeff
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_theta_coeff.ModularCurve ModularCurve.PhiGen \
+  P2MW.S_ModularCurve_theta_coeff.ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qTwist qTwist_coeff qTwist_one_apply qExpand qExpand_coeff_mul \
+  qExpand_coeff_of_not_dvd qExpand_one_apply"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.theta_coeff {R : Type*} [CommRing R] (f : LaurentSeries R) (k : ℤ) :
+    ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R f).coeff k =
+      k • f.coeff k := by
+  rw [HahnSeries.coeff_single_mul, one_mul, LaurentSeries.derivative_apply,
+    LaurentSeries.hasseDeriv_coeff]
+  simp
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.theta_mul {R : Type*} [CommRing R] (f g : LaurentSeries R) :
+    (HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R (f * g) = f *
+      ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R g) + g *
+      ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R f) := by
+  have hθ : ∀ (h : LaurentSeries R) (m : ℤ),
+      ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R h).coeff m
+        = m • h.coeff m := by
+    intro h m
+    rw [HahnSeries.coeff_single_mul, one_mul, LaurentSeries.derivative_apply,
+      LaurentSeries.hasseDeriv_coeff]
+    simp
+  have hsupp : ∀ h : LaurentSeries R,
+      ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R h).support
+        ⊆ h.support := by
+    intro h m hm
+    rw [HahnSeries.mem_support] at hm ⊢
+    intro h0
+    exact hm (by rw [hθ, h0, smul_zero])
+  ext k
+  rw [HahnSeries.coeff_add, hθ, mul_comm g, HahnSeries.coeff_mul_right' g.isPWO_support (hsupp g),
+    HahnSeries.coeff_mul_left' f.isPWO_support (hsupp f), HahnSeries.coeff_mul, Finset.smul_sum,
+    ← Finset.sum_add_distrib]
+  refine Finset.sum_congr rfl fun ij hij => ?_
+  obtain ⟨-, -, hk⟩ := Finset.mem_antidiagonal.mp hij
+  rw [hθ, hθ, ← hk, add_smul, mul_smul_comm, smul_mul_assoc, add_comm]
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.theta_order {K : Type*} [Field K] [Algebra ℚ K] (f : LaurentSeries K)
+    (hf : f.order ≠ 0) :
+    ((HahnSeries.single (1 : ℤ) (1 : K) : LaurentSeries K) * LaurentSeries.derivative K f).order =
+      f.order := by
+  have hθ : ∀ m : ℤ,
+      ((HahnSeries.single (1 : ℤ) (1 : K) : LaurentSeries K) * LaurentSeries.derivative K f).coeff m
+        = m • f.coeff m := by
+    intro m
+    rw [HahnSeries.coeff_single_mul, one_mul, LaurentSeries.derivative_apply,
+      LaurentSeries.hasseDeriv_coeff]
+    simp
+  have : CharZero K := charZero_of_injective_algebraMap (algebraMap ℚ K).injective
+  have hf0 : f ≠ 0 := fun h => hf (by rw [h, HahnSeries.order_zero])
+  have hlead : ((HahnSeries.single (1 : ℤ) (1 : K) : LaurentSeries K) *
+      LaurentSeries.derivative K f).coeff f.order ≠ 0 := by
+    rw [hθ, zsmul_eq_mul]
+    exact mul_ne_zero (Int.cast_ne_zero.mpr hf) (HahnSeries.coeff_order_eq_zero.not.mpr hf0)
+  have hne : (HahnSeries.single (1 : ℤ) (1 : K) : LaurentSeries K) * LaurentSeries.derivative K f ≠
+    0 :=
+    HahnSeries.ne_zero_of_coeff_ne_zero hlead
+  refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero hlead) ?_
+  rw [HahnSeries.le_order_iff_forall hne]
+  intro j hj
+  rw [hθ, HahnSeries.coeff_eq_zero_of_lt_order hj, smul_zero]
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.theta_qExpand {R : Type*} [CommRing R] (N : ℕ) [NeZero N]
+    (f : LaurentSeries R) :
+    (HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R (qExpand R N
+      f) = N • (qExpand R N ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) *
+      LaurentSeries.derivative R f)) := by
+  ext k
+  rw [theta_coeff, HahnSeries.coeff_nsmul, Pi.smul_apply]
+  by_cases hk : (N : ℤ) ∣ k
+  · obtain ⟨m, rfl⟩ := hk
+    rw [qExpand_coeff_mul, qExpand_coeff_mul, theta_coeff, mul_smul, natCast_zsmul]
+  · rw [qExpand_coeff_of_not_dvd N f hk, qExpand_coeff_of_not_dvd N _ hk, smul_zero, smul_zero]
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.theta_qTwist {R : Type*} [CommRing R] (u : Rˣ) (f : LaurentSeries R) :
+    (HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R (qTwist u f)
+      = qTwist u ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R
+      f) := by
+  ext k
+  rw [theta_coeff, qTwist_coeff, qTwist_coeff, theta_coeff, mul_smul_comm]
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qTwist qTwist_coeff qTwist_one_apply qExpand qExpand_coeff_mul \
+  qExpand_coeff_of_not_dvd qExpand_one_apply"
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "sum_qTwist_coeff"
+end ModularCurve.PhiGen
+p2m_open_scoped "ModularCurve ModularCurve.PhiGen" in
+private theorem ModularCurve.PhiGen.weightTwo_coeff_sum_slots {K : Type*} [Field K] [Algebra ℚ K]
+    (ℓ : ℕ) [NeZero ℓ] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) ℓ) (f : LaurentSeries K) (n : ℤ) :
+    ((ℓ * ℓ) • qExpand K (ℓ * ℓ) f + ∑ b ∈ Finset.range ℓ, qTwist (ζ ^ b) f).coeff ((ℓ : ℤ) * n) =
+      (ℓ : K) * (f.coeff ((ℓ : ℤ) * n) + if (ℓ : ℤ) ∣ n then (ℓ : K) * f.coeff (n / ℓ) else 0) := by
+  have hℓ : (ℓ : ℤ) ≠ 0 := by exact_mod_cast NeZero.ne ℓ
+  rw [HahnSeries.coeff_add, HahnSeries.coeff_nsmul, Pi.smul_apply, sum_qTwist_coeff ℓ ζ hζ f,
+    ite_eq_left (dvd_mul_right _ _)]
+  by_cases hn : (ℓ : ℤ) ∣ n
+  · obtain ⟨m, rfl⟩ := hn
+    rw [ite_eq_left (dvd_mul_right _ _),
+      show (ℓ : ℤ) * ((ℓ : ℤ) * m) = ((ℓ * ℓ : ℕ) : ℤ) * m by push_cast; ring,
+      qExpand_coeff_mul, Int.mul_ediv_cancel_left _ hℓ, nsmul_eq_mul]
+    push_cast
+    ring
+  · rw [ite_eq_right hn, qExpand_coeff_of_not_dvd (ℓ * ℓ) f, smul_zero, zero_add, add_zero]
+    intro h
+    apply hn
+    push_cast at h
+    exact (mul_dvd_mul_iff_left hℓ).mp h
+
+p2m_open_scoped "ModularCurve ModularCurve.PhiGen" in
+private theorem ModularCurve.PhiGen.weightTwo_coeff_sum_slots_inv {K : Type*} [Field K]
+    [Algebra ℚ K] (ℓ : ℕ) [NeZero ℓ] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) ℓ) (f : LaurentSeries K)
+    (n : ℤ) :
+    ((ℓ : K) • qExpand K (ℓ * ℓ) f + (ℓ : K)⁻¹ • ∑ b ∈ Finset.range ℓ, qTwist (ζ ^ b) f).coeff ((ℓ :
+      ℤ) * n) = f.coeff ((ℓ : ℤ) * n) + if (ℓ : ℤ) ∣ n then (ℓ : K) * f.coeff (n / ℓ) else 0 := by
+  have hℓ : (ℓ : ℤ) ≠ 0 := by exact_mod_cast NeZero.ne ℓ
+  have : CharZero K := charZero_of_injective_algebraMap (algebraMap ℚ K).injective
+  have hℓK : (ℓ : K) ≠ 0 := by exact_mod_cast NeZero.ne ℓ
+  rw [HahnSeries.coeff_add, HahnSeries.coeff_smul, HahnSeries.coeff_smul, sum_qTwist_coeff ℓ ζ hζ f,
+    ite_eq_left (dvd_mul_right _ _), smul_eq_mul, smul_eq_mul, inv_mul_cancel_left₀ hℓK]
+  by_cases hn : (ℓ : ℤ) ∣ n
+  · obtain ⟨m, rfl⟩ := hn
+    rw [ite_eq_left (dvd_mul_right _ _),
+      show (ℓ : ℤ) * ((ℓ : ℤ) * m) = ((ℓ * ℓ : ℕ) : ℤ) * m by push_cast; ring,
+      qExpand_coeff_mul, Int.mul_ediv_cancel_left _ hℓ]
+    ring
+  · rw [ite_eq_right hn, qExpand_coeff_of_not_dvd (ℓ * ℓ) f, mul_zero, zero_add, add_zero]
+    intro h
+    apply hn
+    push_cast at h
+    exact (mul_dvd_mul_iff_left hℓ).mp h
+
+p2m_open_scoped "ModularCurve ModularCurve.PhiGen" in
+private theorem ModularCurve.PhiGen.weightTwo_coeff_sum_slots_not_dvd {K : Type*} [Field K]
+    [Algebra ℚ K] (ℓ : ℕ) [NeZero ℓ] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) ℓ) (f : LaurentSeries K)
+    {k : ℤ} (hk : ¬ (ℓ : ℤ) ∣ k) :
+    ((ℓ * ℓ) • qExpand K (ℓ * ℓ) f + ∑ b ∈ Finset.range ℓ, qTwist (ζ ^ b) f).coeff k = 0 := by
+  rw [HahnSeries.coeff_add, HahnSeries.coeff_nsmul, Pi.smul_apply, sum_qTwist_coeff ℓ ζ hζ f,
+    ite_eq_right hk, qExpand_coeff_of_not_dvd (ℓ * ℓ) f, smul_zero, add_zero]
+  intro h
+  apply hk
+  push_cast at h
+  exact dvd_trans (dvd_mul_right _ _) h
+
+p2m_open_scoped "ModularCurve ModularCurve.PhiGen" in
+private theorem ModularCurve.PhiGen.weightTwo_theta_sum_slots {R : Type*} [CommRing R] (ℓ : ℕ)
+    [NeZero ℓ] (ζ : Rˣ) (f : LaurentSeries R) :
+    (HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R (qExpand R (ℓ
+      * ℓ) f + ∑ b ∈ Finset.range ℓ, qTwist (ζ ^ b) f) = (ℓ * ℓ) • qExpand R (ℓ * ℓ)
+      ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R f) + ∑ b ∈
+      Finset.range ℓ, qTwist (ζ ^ b) ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) *
+      LaurentSeries.derivative R f) := by
+  rw [map_add, mul_add, theta_qExpand, map_sum, Finset.mul_sum]
+  congr 1
+  refine Finset.sum_congr rfl fun b _ => ?_
+  exact theta_qTwist (ζ ^ b) f
+
+p2m_open_scoped "ModularCurve ModularCurve.PhiGen" in
+private theorem ModularCurve.PhiGen.weightTwo_theta_coeff {R : Type*} [CommRing R] (ℓ : ℕ)
+    (f : LaurentSeries R) (n : ℤ) :
+    ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R f).coeff ((ℓ
+      : ℤ) * n) + (if (ℓ : ℤ) ∣ n then (ℓ : R) * ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries
+      R) * LaurentSeries.derivative R f).coeff (n / ℓ) else 0) = n • ((if (ℓ : ℤ) ∣ n then f.coeff
+      (n / ℓ) else 0) + (ℓ : R) * f.coeff ((ℓ : ℤ) * n)) := by
+  rw [theta_coeff]
+  by_cases hn : (ℓ : ℤ) ∣ n
+  · rw [ite_eq_left hn, ite_eq_left hn, theta_coeff]
+    obtain ⟨m, rfl⟩ := hn
+    rcases eq_or_ne (ℓ : ℤ) 0 with hℓ | hℓ
+    · simp [hℓ]
+    · rw [Int.mul_ediv_cancel_left _ hℓ]
+      simp only [zsmul_eq_mul, Int.cast_mul, Int.cast_natCast]
+      ring
+  · rw [ite_eq_right hn, ite_eq_right hn]
+    simp only [zsmul_eq_mul, Int.cast_mul, Int.cast_natCast, add_zero, zero_add]
+    ring
+
+example {R : Type*} [CommRing R] (f : LaurentSeries R) :
+    LaurentSeries.derivative R f = LaurentSeries.derivative ℤ f := rfl
+
+example {K : Type*} [Field K] [Algebra ℚ K] (f : LaurentSeries K) :
+    (HahnSeries.single (1 : ℤ) (1 : K) : LaurentSeries K) * LaurentSeries.derivative K f
+      = (HahnSeries.single (1 : ℤ) (1 : K) : LaurentSeries K) * LaurentSeries.derivative ℚ f := rfl
+
+example :
+    let F : LaurentSeries ℚ :=
+      HahnSeries.single (-1 : ℤ) (1 : ℚ) + HahnSeries.single (0 : ℤ) (744 : ℚ)
+      + HahnSeries.single (1 : ℤ) (196884 : ℚ) + HahnSeries.single (2 : ℤ) (21493760 : ℚ)
+      + HahnSeries.single (3 : ℤ) (864299970 : ℚ) + HahnSeries.single (4 : ℤ) (20245856256 : ℚ)
+    let w0 : ℤ → ℚ :=
+      fun n => (if (2 : ℤ) ∣ n then F.coeff (n / 2) else 0) + (2 : ℚ) * F.coeff (2 * n)
+    w0 (-2) = 1 ∧ w0 (-1) = 0 ∧ w0 0 = 2232 ∧ w0 1 = 42987520 ∧ w0 2 = 40491909396 := by
+  intro F w0
+  simp only [F, w0, HahnSeries.coeff_add, HahnSeries.coeff_single]
+  norm_num
+
+example :
+    let F : LaurentSeries ℚ :=
+      HahnSeries.single (-1 : ℤ) (1 : ℚ) + HahnSeries.single (0 : ℤ) (744 : ℚ)
+      + HahnSeries.single (1 : ℤ) (196884 : ℚ) + HahnSeries.single (2 : ℤ) (21493760 : ℚ)
+      + HahnSeries.single (3 : ℤ) (864299970 : ℚ) + HahnSeries.single (4 : ℤ) (20245856256 : ℚ)
+    let θF : LaurentSeries ℚ :=
+      (HahnSeries.single (1 : ℤ) (1 : ℚ) : LaurentSeries ℚ) * LaurentSeries.derivative ℚ F
+    let w0 : ℤ → ℚ :=
+      fun n => (if (2 : ℤ) ∣ n then F.coeff (n / 2) else 0) + (2 : ℚ) * F.coeff (2 * n)
+    let w2 : ℤ → ℚ :=
+      fun n => θF.coeff (2 * n) + (if (2 : ℤ) ∣ n then (2 : ℚ) * θF.coeff (n / 2) else 0)
+    (w2 (-2) = -2 ∧ w2 (-1) = 0 ∧ w2 0 = 0 ∧ w2 1 = 42987520 ∧ w2 2 = 80983818792) ∧
+      (w2 (-2) = (-2 : ℤ) • w0 (-2) ∧ w2 (-1) = (-1 : ℤ) • w0 (-1) ∧ w2 0 = (0 : ℤ) • w0 0 ∧
+        w2 1 = (1 : ℤ) • w0 1 ∧ w2 2 = (2 : ℤ) • w0 2) := by
+  intro F θF w0 w2
+  simp only [F, θF, w0, w2, ModularCurve.theta_coeff, HahnSeries.coeff_add, HahnSeries.coeff_single]
+  norm_num
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_theta_coeff.ModularCurve
+  _root_.ModularCurve.PhiGen _root_.P2MW.S_ModularCurve_theta_coeff.ModularCurve.PhiGen in
+theorem solution {R : Type*} [CommRing R] (f : LaurentSeries R) (k : ℤ) :
+    ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R f).coeff k =
+      k • f.coeff k :=
+  ModularCurve.theta_coeff f k
+
+end S_ModularCurve_theta_coeff
+end P2MW
+export P2MW.S_ModularCurve_theta_coeff (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.theta_coeff {R : Type*} [CommRing R] (f : LaurentSeries R) (k : ℤ) :
+    ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R f).coeff k =
+      k • f.coeff k :=
+  solution f k
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_theta_mul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_theta_mul.lean
new file mode 100644
index 0000000000..ed906e6840
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_theta_mul.lean
@@ -0,0 +1,305 @@
+/-
+Based on Prove2Me node ModularCurve.theta_mul
+(325f4b9b-8c7b-5575-82d2-42f0c802a2d7) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 560b302a-7c9a-5d58-992e-13581695d61b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PhiGen
+
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_PhiGen_sum_qTwist_coeff
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Leibniz rule for θ = q d/dq on Laurent series
+
+Theorem statement: `ModularCurve.theta_mul` (`325f4b9b-8c7b-5575-82d2-42f0c802a2d7`), by Claude,
+2026-09-05.
+
+Proof: submission `560b302a-7c9a-5d58-992e-13581695d61b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring and let $f, g$ be formal Laurent series over $R$, i.e. elements of
+`LaurentSeries R`, the Hahn series with integer exponents and coefficients in $R$. Write $q$ for the
+Hahn series `HahnSeries.single (1 : ℤ) (1 : R)`, the series with coefficient $1$ in degree $1$ and
+$0$ elsewhere, and write $f \mapsto f'$ for `LaurentSeries.derivative R`, the coefficientwise formal
+derivative. The assertion is the identity
+$$q \cdot (f g)' \;=\; f \cdot \bigl(q \cdot g'\bigr) \;+\; g \cdot \bigl(q \cdot f'\bigr)$$
+in `LaurentSeries R`. Equivalently, setting $\theta h = q \cdot h'$, the operator $\theta$ satisfies
+$\theta(fg) = f\,\theta g + g\,\theta f$, so that $\theta$ is a derivation of the ring of formal
+Laurent series over any commutative ring. No hypotheses beyond commutativity of $R$ are imposed, and
+no invertibility or integrality assumptions are made on the coefficients.
+
+This is the Leibniz rule for the logarithmic derivative operator $\theta = q\,d/dq$ acting on
+$q$-expansions, stated as a pure identity of formal Laurent series rather than for a bundled
+derivation. It is used throughout the $q$-expansion computations of the modular-curve part of the
+development, in particular in the analysis of $\theta$ applied to products and to twists of series
+by roots of unity.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_theta_mul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_theta_mul
+
+p2m_open "ModularCurve P2MW.S_ModularCurve_theta_mul.ModularCurve ModularCurve.PhiGen \
+  P2MW.S_ModularCurve_theta_mul.ModularCurve.PhiGen"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qTwist qTwist_coeff qTwist_one_apply qExpand qExpand_coeff_mul \
+  qExpand_coeff_of_not_dvd qExpand_one_apply"
+end ModularCurve
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.theta_coeff {R : Type*} [CommRing R] (f : LaurentSeries R) (k : ℤ) :
+    ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R f).coeff k =
+      k • f.coeff k := by
+  rw [HahnSeries.coeff_single_mul, one_mul, LaurentSeries.derivative_apply,
+    LaurentSeries.hasseDeriv_coeff]
+  simp
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.theta_mul {R : Type*} [CommRing R] (f g : LaurentSeries R) :
+    (HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R (f * g) = f *
+      ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R g) + g *
+      ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R f) := by
+  have hθ : ∀ (h : LaurentSeries R) (m : ℤ),
+      ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R h).coeff m
+        = m • h.coeff m := by
+    intro h m
+    rw [HahnSeries.coeff_single_mul, one_mul, LaurentSeries.derivative_apply,
+      LaurentSeries.hasseDeriv_coeff]
+    simp
+  have hsupp : ∀ h : LaurentSeries R,
+      ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R h).support
+        ⊆ h.support := by
+    intro h m hm
+    rw [HahnSeries.mem_support] at hm ⊢
+    intro h0
+    exact hm (by rw [hθ, h0, smul_zero])
+  ext k
+  rw [HahnSeries.coeff_add, hθ, mul_comm g, HahnSeries.coeff_mul_right' g.isPWO_support (hsupp g),
+    HahnSeries.coeff_mul_left' f.isPWO_support (hsupp f), HahnSeries.coeff_mul, Finset.smul_sum,
+    ← Finset.sum_add_distrib]
+  refine Finset.sum_congr rfl fun ij hij => ?_
+  obtain ⟨-, -, hk⟩ := Finset.mem_antidiagonal.mp hij
+  rw [hθ, hθ, ← hk, add_smul, mul_smul_comm, smul_mul_assoc, add_comm]
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.theta_order {K : Type*} [Field K] [Algebra ℚ K] (f : LaurentSeries K)
+    (hf : f.order ≠ 0) :
+    ((HahnSeries.single (1 : ℤ) (1 : K) : LaurentSeries K) * LaurentSeries.derivative K f).order =
+      f.order := by
+  have hθ : ∀ m : ℤ,
+      ((HahnSeries.single (1 : ℤ) (1 : K) : LaurentSeries K) * LaurentSeries.derivative K f).coeff m
+        = m • f.coeff m := by
+    intro m
+    rw [HahnSeries.coeff_single_mul, one_mul, LaurentSeries.derivative_apply,
+      LaurentSeries.hasseDeriv_coeff]
+    simp
+  have : CharZero K := charZero_of_injective_algebraMap (algebraMap ℚ K).injective
+  have hf0 : f ≠ 0 := fun h => hf (by rw [h, HahnSeries.order_zero])
+  have hlead : ((HahnSeries.single (1 : ℤ) (1 : K) : LaurentSeries K) *
+      LaurentSeries.derivative K f).coeff f.order ≠ 0 := by
+    rw [hθ, zsmul_eq_mul]
+    exact mul_ne_zero (Int.cast_ne_zero.mpr hf) (HahnSeries.coeff_order_eq_zero.not.mpr hf0)
+  have hne : (HahnSeries.single (1 : ℤ) (1 : K) : LaurentSeries K) * LaurentSeries.derivative K f ≠
+    0 :=
+    HahnSeries.ne_zero_of_coeff_ne_zero hlead
+  refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero hlead) ?_
+  rw [HahnSeries.le_order_iff_forall hne]
+  intro j hj
+  rw [hθ, HahnSeries.coeff_eq_zero_of_lt_order hj, smul_zero]
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.theta_qExpand {R : Type*} [CommRing R] (N : ℕ) [NeZero N]
+    (f : LaurentSeries R) :
+    (HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R (qExpand R N
+      f) = N • (qExpand R N ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) *
+      LaurentSeries.derivative R f)) := by
+  ext k
+  rw [theta_coeff, HahnSeries.coeff_nsmul, Pi.smul_apply]
+  by_cases hk : (N : ℤ) ∣ k
+  · obtain ⟨m, rfl⟩ := hk
+    rw [qExpand_coeff_mul, qExpand_coeff_mul, theta_coeff, mul_smul, natCast_zsmul]
+  · rw [qExpand_coeff_of_not_dvd N f hk, qExpand_coeff_of_not_dvd N _ hk, smul_zero, smul_zero]
+
+p2m_open_scoped "ModularCurve" in
+private theorem ModularCurve.theta_qTwist {R : Type*} [CommRing R] (u : Rˣ) (f : LaurentSeries R) :
+    (HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R (qTwist u f)
+      = qTwist u ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R
+      f) := by
+  ext k
+  rw [theta_coeff, qTwist_coeff, qTwist_coeff, theta_coeff, mul_smul_comm]
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qTwist qTwist_coeff qTwist_one_apply qExpand qExpand_coeff_mul \
+  qExpand_coeff_of_not_dvd qExpand_one_apply"
+namespace PhiGen
+p2m_export "ModularCurve.PhiGen" "sum_qTwist_coeff"
+end ModularCurve.PhiGen
+p2m_open_scoped "ModularCurve ModularCurve.PhiGen" in
+private theorem ModularCurve.PhiGen.weightTwo_coeff_sum_slots {K : Type*} [Field K] [Algebra ℚ K]
+    (ℓ : ℕ) [NeZero ℓ] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) ℓ) (f : LaurentSeries K) (n : ℤ) :
+    ((ℓ * ℓ) • qExpand K (ℓ * ℓ) f + ∑ b ∈ Finset.range ℓ, qTwist (ζ ^ b) f).coeff ((ℓ : ℤ) * n) =
+      (ℓ : K) * (f.coeff ((ℓ : ℤ) * n) + if (ℓ : ℤ) ∣ n then (ℓ : K) * f.coeff (n / ℓ) else 0) := by
+  have hℓ : (ℓ : ℤ) ≠ 0 := by exact_mod_cast NeZero.ne ℓ
+  rw [HahnSeries.coeff_add, HahnSeries.coeff_nsmul, Pi.smul_apply, sum_qTwist_coeff ℓ ζ hζ f,
+    ite_eq_left (dvd_mul_right _ _)]
+  by_cases hn : (ℓ : ℤ) ∣ n
+  · obtain ⟨m, rfl⟩ := hn
+    rw [ite_eq_left (dvd_mul_right _ _),
+      show (ℓ : ℤ) * ((ℓ : ℤ) * m) = ((ℓ * ℓ : ℕ) : ℤ) * m by push_cast; ring,
+      qExpand_coeff_mul, Int.mul_ediv_cancel_left _ hℓ, nsmul_eq_mul]
+    push_cast
+    ring
+  · rw [ite_eq_right hn, qExpand_coeff_of_not_dvd (ℓ * ℓ) f, smul_zero, zero_add, add_zero]
+    intro h
+    apply hn
+    push_cast at h
+    exact (mul_dvd_mul_iff_left hℓ).mp h
+
+p2m_open_scoped "ModularCurve ModularCurve.PhiGen" in
+private theorem ModularCurve.PhiGen.weightTwo_coeff_sum_slots_inv {K : Type*} [Field K]
+    [Algebra ℚ K] (ℓ : ℕ) [NeZero ℓ] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) ℓ) (f : LaurentSeries K)
+    (n : ℤ) :
+    ((ℓ : K) • qExpand K (ℓ * ℓ) f + (ℓ : K)⁻¹ • ∑ b ∈ Finset.range ℓ, qTwist (ζ ^ b) f).coeff ((ℓ :
+      ℤ) * n) = f.coeff ((ℓ : ℤ) * n) + if (ℓ : ℤ) ∣ n then (ℓ : K) * f.coeff (n / ℓ) else 0 := by
+  have hℓ : (ℓ : ℤ) ≠ 0 := by exact_mod_cast NeZero.ne ℓ
+  have : CharZero K := charZero_of_injective_algebraMap (algebraMap ℚ K).injective
+  have hℓK : (ℓ : K) ≠ 0 := by exact_mod_cast NeZero.ne ℓ
+  rw [HahnSeries.coeff_add, HahnSeries.coeff_smul, HahnSeries.coeff_smul, sum_qTwist_coeff ℓ ζ hζ f,
+    ite_eq_left (dvd_mul_right _ _), smul_eq_mul, smul_eq_mul, inv_mul_cancel_left₀ hℓK]
+  by_cases hn : (ℓ : ℤ) ∣ n
+  · obtain ⟨m, rfl⟩ := hn
+    rw [ite_eq_left (dvd_mul_right _ _),
+      show (ℓ : ℤ) * ((ℓ : ℤ) * m) = ((ℓ * ℓ : ℕ) : ℤ) * m by push_cast; ring,
+      qExpand_coeff_mul, Int.mul_ediv_cancel_left _ hℓ]
+    ring
+  · rw [ite_eq_right hn, qExpand_coeff_of_not_dvd (ℓ * ℓ) f, mul_zero, zero_add, add_zero]
+    intro h
+    apply hn
+    push_cast at h
+    exact (mul_dvd_mul_iff_left hℓ).mp h
+
+p2m_open_scoped "ModularCurve ModularCurve.PhiGen" in
+private theorem ModularCurve.PhiGen.weightTwo_coeff_sum_slots_not_dvd {K : Type*} [Field K]
+    [Algebra ℚ K] (ℓ : ℕ) [NeZero ℓ] (ζ : Kˣ) (hζ : IsPrimitiveRoot (ζ : K) ℓ) (f : LaurentSeries K)
+    {k : ℤ} (hk : ¬ (ℓ : ℤ) ∣ k) :
+    ((ℓ * ℓ) • qExpand K (ℓ * ℓ) f + ∑ b ∈ Finset.range ℓ, qTwist (ζ ^ b) f).coeff k = 0 := by
+  rw [HahnSeries.coeff_add, HahnSeries.coeff_nsmul, Pi.smul_apply, sum_qTwist_coeff ℓ ζ hζ f,
+    ite_eq_right hk, qExpand_coeff_of_not_dvd (ℓ * ℓ) f, smul_zero, add_zero]
+  intro h
+  apply hk
+  push_cast at h
+  exact dvd_trans (dvd_mul_right _ _) h
+
+p2m_open_scoped "ModularCurve ModularCurve.PhiGen" in
+private theorem ModularCurve.PhiGen.weightTwo_theta_sum_slots {R : Type*} [CommRing R] (ℓ : ℕ)
+    [NeZero ℓ] (ζ : Rˣ) (f : LaurentSeries R) :
+    (HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R (qExpand R (ℓ
+      * ℓ) f + ∑ b ∈ Finset.range ℓ, qTwist (ζ ^ b) f) = (ℓ * ℓ) • qExpand R (ℓ * ℓ)
+      ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R f) + ∑ b ∈
+      Finset.range ℓ, qTwist (ζ ^ b) ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) *
+      LaurentSeries.derivative R f) := by
+  rw [map_add, mul_add, theta_qExpand, map_sum, Finset.mul_sum]
+  congr 1
+  refine Finset.sum_congr rfl fun b _ => ?_
+  exact theta_qTwist (ζ ^ b) f
+
+p2m_open_scoped "ModularCurve ModularCurve.PhiGen" in
+private theorem ModularCurve.PhiGen.weightTwo_theta_coeff {R : Type*} [CommRing R] (ℓ : ℕ)
+    (f : LaurentSeries R) (n : ℤ) :
+    ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R f).coeff ((ℓ
+      : ℤ) * n) + (if (ℓ : ℤ) ∣ n then (ℓ : R) * ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries
+      R) * LaurentSeries.derivative R f).coeff (n / ℓ) else 0) = n • ((if (ℓ : ℤ) ∣ n then f.coeff
+      (n / ℓ) else 0) + (ℓ : R) * f.coeff ((ℓ : ℤ) * n)) := by
+  rw [theta_coeff]
+  by_cases hn : (ℓ : ℤ) ∣ n
+  · rw [ite_eq_left hn, ite_eq_left hn, theta_coeff]
+    obtain ⟨m, rfl⟩ := hn
+    rcases eq_or_ne (ℓ : ℤ) 0 with hℓ | hℓ
+    · simp [hℓ]
+    · rw [Int.mul_ediv_cancel_left _ hℓ]
+      simp only [zsmul_eq_mul, Int.cast_mul, Int.cast_natCast]
+      ring
+  · rw [ite_eq_right hn, ite_eq_right hn]
+    simp only [zsmul_eq_mul, Int.cast_mul, Int.cast_natCast, add_zero, zero_add]
+    ring
+
+example {R : Type*} [CommRing R] (f : LaurentSeries R) :
+    LaurentSeries.derivative R f = LaurentSeries.derivative ℤ f := rfl
+
+example {K : Type*} [Field K] [Algebra ℚ K] (f : LaurentSeries K) :
+    (HahnSeries.single (1 : ℤ) (1 : K) : LaurentSeries K) * LaurentSeries.derivative K f
+      = (HahnSeries.single (1 : ℤ) (1 : K) : LaurentSeries K) * LaurentSeries.derivative ℚ f := rfl
+
+example :
+    let F : LaurentSeries ℚ :=
+      HahnSeries.single (-1 : ℤ) (1 : ℚ) + HahnSeries.single (0 : ℤ) (744 : ℚ)
+      + HahnSeries.single (1 : ℤ) (196884 : ℚ) + HahnSeries.single (2 : ℤ) (21493760 : ℚ)
+      + HahnSeries.single (3 : ℤ) (864299970 : ℚ) + HahnSeries.single (4 : ℤ) (20245856256 : ℚ)
+    let w0 : ℤ → ℚ :=
+      fun n => (if (2 : ℤ) ∣ n then F.coeff (n / 2) else 0) + (2 : ℚ) * F.coeff (2 * n)
+    w0 (-2) = 1 ∧ w0 (-1) = 0 ∧ w0 0 = 2232 ∧ w0 1 = 42987520 ∧ w0 2 = 40491909396 := by
+  intro F w0
+  simp only [F, w0, HahnSeries.coeff_add, HahnSeries.coeff_single]
+  norm_num
+
+example :
+    let F : LaurentSeries ℚ :=
+      HahnSeries.single (-1 : ℤ) (1 : ℚ) + HahnSeries.single (0 : ℤ) (744 : ℚ)
+      + HahnSeries.single (1 : ℤ) (196884 : ℚ) + HahnSeries.single (2 : ℤ) (21493760 : ℚ)
+      + HahnSeries.single (3 : ℤ) (864299970 : ℚ) + HahnSeries.single (4 : ℤ) (20245856256 : ℚ)
+    let θF : LaurentSeries ℚ :=
+      (HahnSeries.single (1 : ℤ) (1 : ℚ) : LaurentSeries ℚ) * LaurentSeries.derivative ℚ F
+    let w0 : ℤ → ℚ :=
+      fun n => (if (2 : ℤ) ∣ n then F.coeff (n / 2) else 0) + (2 : ℚ) * F.coeff (2 * n)
+    let w2 : ℤ → ℚ :=
+      fun n => θF.coeff (2 * n) + (if (2 : ℤ) ∣ n then (2 : ℚ) * θF.coeff (n / 2) else 0)
+    (w2 (-2) = -2 ∧ w2 (-1) = 0 ∧ w2 0 = 0 ∧ w2 1 = 42987520 ∧ w2 2 = 80983818792) ∧
+      (w2 (-2) = (-2 : ℤ) • w0 (-2) ∧ w2 (-1) = (-1 : ℤ) • w0 (-1) ∧ w2 0 = (0 : ℤ) • w0 0 ∧
+        w2 1 = (1 : ℤ) • w0 1 ∧ w2 2 = (2 : ℤ) • w0 2) := by
+  intro F θF w0 w2
+  simp only [F, θF, w0, w2, ModularCurve.theta_coeff, HahnSeries.coeff_add, HahnSeries.coeff_single]
+  norm_num
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_theta_mul.ModularCurve
+  _root_.ModularCurve.PhiGen _root_.P2MW.S_ModularCurve_theta_mul.ModularCurve.PhiGen in
+theorem solution {R : Type*} [CommRing R] (f g : LaurentSeries R) :
+    (HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R (f * g) = f *
+      ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R g) + g *
+      ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R f) :=
+  ModularCurve.theta_mul f g
+
+end S_ModularCurve_theta_mul
+end P2MW
+export P2MW.S_ModularCurve_theta_mul (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve ModularCurve.PhiGen
+theorem ModularCurve.theta_mul {R : Type*} [CommRing R] (f g : LaurentSeries R) :
+    (HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R (f * g) = f *
+      ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R g) + g *
+      ((HahnSeries.single (1 : ℤ) (1 : R) : LaurentSeries R) * LaurentSeries.derivative R f) :=
+  solution f g
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_three_mul_natCard_moduliPoint_j_eq_zero_eq_dedekindPsi_add_two_mul_nuThree.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_three_mul_natCard_moduliPoint_j_eq_zero_eq_dedekindPsi_add_two_mul_nuThree.lean
new file mode 100644
index 0000000000..53c58c0068
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_three_mul_natCard_moduliPoint_j_eq_zero_eq_dedekindPsi_add_two_mul_nuThree.lean
@@ -0,0 +1,769 @@
+/-
+Based on Prove2Me node
+ModularCurve.three_mul_natCard_moduliPoint_j_eq_zero_eq_dedekindPsi_add_two_mul_nuThree
+(1e8e845b-4f4e-52ea-8350-7247b1885b38) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1a818f27-07a9-55f2-9fc6-6ba043e6af07
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ModuliPoint
+
+import Mathlib.Algebra.CharP.Invertible
+import Mathlib.AlgebraicGeometry.EllipticCurve.Reduction
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_moduliPoint_j_eq_eq_natCard_quot_addOrderOf_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_MulAction_card_mul_natCard_orbitRel_quotient_eq_of_natCard_eq_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_vcInvFun_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsion_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a4_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuThree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_variableChange_mk_smul_eq_self_of_pow_three_eq_one
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Moduli points with j = 0: 3#=ψ(N)+2ν₃(N)
+
+Theorem statement:
+`ModularCurve.three_mul_natCard_moduliPoint_j_eq_zero_eq_dedekindPsi_add_two_mul_nuThree`
+(`1e8e845b-4f4e-52ea-8350-7247b1885b38`), by Claude, 2026-09-05.
+
+Proof: submission `1a818f27-07a9-55f2-9fc6-6ba043e6af07`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and let $L$ be an algebraically closed field equipped with a
+$\mathbb{Q}$-algebra structure (so of characteristic $0$). Consider the type `ModuliPoint N L`, the
+quotient of the type of `Gamma0Pair N L` — structures consisting of a Weierstrass curve $W$ over $L$
+together with a proof that $W$ is elliptic and a point `gen` of the associated affine curve whose
+additive order is exactly $N$ — by the relation that carries a pair $(W,P)$ to $(W',P')$ whenever
+there is a Weierstrass variable change $\gamma$ over $L$ with $\gamma \cdot W = W'$ and a natural
+number $k$ coprime to $N$ with $P' = k \cdot \gamma^{-1}(P)$, where $\gamma^{-1}$ denotes the
+induced map `Point.vcInvFun` on points; thus a moduli point is a curve together with a cyclic
+subgroup of order $N$ up to isomorphism. The assertion is that the number of those moduli points
+whose $j$-invariant is $0$, multiplied by $3$, equals $\psi(N) + 2\nu_3(N)$, where $\psi(N)$ is
+`dedekindPsi N`, the sum of $N/d$ over the squarefree divisors $d$ of $N$, and $\nu_3(N)$ is
+`nuThree N`, the number of $x \in \mathbb{Z}/N$ with $x^2 + x + 1 = 0$.
+
+This is the count of the fibre of $Y_0(N) \to X(1)$ over the elliptic point $j = 0$: generically the
+fibre has $\psi(N)$ points, while at $j = 0$ the extra automorphism of order $3$ groups the cyclic
+subgroups of order $N$ into orbits of size $3$ apart from $\nu_3(N)$ fixed ones. It feeds the
+computation of the number of elliptic points of order $3$ of $\Gamma_0(N)$, used in the genus and
+ramification bookkeeping for $X_0(N)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_three_mul_natCard_moduliPoint_j_eq_zero_eq_dedekindPsi_add_two_mul_nuThree.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_44f45b4b
+
+
+open WeierstrassCurve WeierstrassCurve.Affine ModularCurve
+
+noncomputable section
+
+namespace P2MWs13
+namespace R2b
+
+variable {L : Type*} [Field L] [DecidableEq L]
+
+def coords {W : WeierstrassCurve L} : W.toAffine.Point → Option (L × L)
+  | 0 => none
+  | .some x y _ => some (x, y)
+
+omit [DecidableEq L] in
+@[scoped simp] theorem coords_zero {W : WeierstrassCurve L} :
+    coords (0 : W.toAffine.Point) = none := rfl
+omit [DecidableEq L] in
+@[scoped simp] theorem coords_some {W : WeierstrassCurve L} {x y : L} (h : W.toAffine.Nonsingular x
+  y) :
+    coords (Point.some x y h) = some (x, y) := rfl
+
+omit [DecidableEq L] in
+theorem coords_injective {W : WeierstrassCurve L} : Function.Injective (coords (W := W)) := by
+  rintro (_ | ⟨x, y, h⟩) (_ | ⟨x', y', h'⟩) hPQ
+  · rfl
+  · simp [coords] at hPQ
+  · simp [coords] at hPQ
+  · simp only [coords_some, Option.some.injEq, Prod.mk.injEq] at hPQ
+    obtain ⟨rfl, rfl⟩ := hPQ
+    rfl
+
+omit [DecidableEq L] in
+theorem coords_eq_of_heq {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂) {P : W₁.toAffine.Point}
+    {Q : W₂.toAffine.Point}
+    (h : HEq P Q) : coords P = coords Q := by
+  subst e; rw [eq_of_heq h]
+
+def castPt {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂) : W₁.toAffine.Point ≃+ W₂.toAffine.Point := by
+  subst e; exact AddEquiv.refl _
+
+theorem heq_castPt {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂) (P : W₁.toAffine.Point) :
+    HEq P (castPt e P) := by
+  subst e; rfl
+
+theorem castPt_eq_iff_heq {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂) (P : W₁.toAffine.Point)
+    (Q : W₂.toAffine.Point) :
+    castPt e P = Q ↔ HEq P Q := by
+  subst e; exact Iff.rfl.trans heq_iff_eq.symm
+
+theorem coords_castPt {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂) (P : W₁.toAffine.Point) :
+    coords (castPt e P) = coords P := by
+  subst e; rfl
+
+def autPt {W : WeierstrassCurve L} (γ : VariableChange L) (hγ : γ • W = W) :
+    W.toAffine.Point →+ W.toAffine.Point :=
+  (castPt hγ).toAddMonoidHom.comp (AddMonoidHom.mk' (Point.vcInvFun γ W.toAffine)
+    (Point.vcInvFun_add γ W.toAffine))
+
+theorem autPt_apply {W : WeierstrassCurve L} (γ : VariableChange L) (hγ : γ • W = W)
+    (P : W.toAffine.Point) :
+    autPt γ hγ P = castPt hγ (Point.vcInvFun γ W.toAffine P) := rfl
+
+theorem autPt_eq_iff_heq {W : WeierstrassCurve L} (γ : VariableChange L) (hγ : γ • W = W)
+    (P Q : W.toAffine.Point) :
+    autPt γ hγ P = Q ↔ HEq (Point.vcInvFun γ W.toAffine P) Q := by
+  rw [autPt_apply, castPt_eq_iff_heq]
+
+theorem autPt_congr {W : WeierstrassCurve L} {γ γ' : VariableChange L} (e : γ = γ') (hγ : γ • W = W)
+    (hγ' : γ' • W = W)
+    (P : W.toAffine.Point) : autPt γ hγ P = autPt γ' hγ' P := by
+  subst e; rfl
+
+theorem autPt_injective {W : WeierstrassCurve L} (γ : VariableChange L) (hγ : γ • W = W) :
+    Function.Injective (autPt γ hγ) := by
+  intro P Q h
+  rw [autPt_apply, autPt_apply] at h
+  exact (Point.vcFun_rightInverse (C := γ) (W := W.toAffine)).injective ((castPt hγ).injective h)
+
+theorem coords_autPt {W : WeierstrassCurve L} (v : Lˣ)
+    (hγ : (⟨v, 0, 0, 0⟩ : VariableChange L) • W = W)
+    (P : W.toAffine.Point) :
+    coords (autPt ⟨v, 0, 0, 0⟩ hγ P) = (coords P).map (fun q => (((v⁻¹ : Lˣ) : L) ^ 2 * q.1, ((v⁻¹ :
+      Lˣ) : L) ^ 3 * q.2)) := by
+  rw [autPt_apply, coords_castPt]
+  rcases P with _ | ⟨x, y, h⟩
+  · rfl
+  · change some _ = some _
+    simp [WeierstrassCurve.Affine.vcXInv, WeierstrassCurve.Affine.vcYInv]
+
+abbrev W0 (L : Type*) [Field L] : WeierstrassCurve L := ⟨0, 0, 0, 0, 1⟩
+
+omit [DecidableEq L] in
+theorem W0_Δ : (W0 L).Δ = -432 := by
+  simp only [WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄, WeierstrassCurve.b₆,
+    WeierstrassCurve.b₈]; ring
+
+omit [DecidableEq L] in
+theorem W0_c₄ : (W0 L).c₄ = 0 := by
+  simp only [WeierstrassCurve.c₄, WeierstrassCurve.b₂, WeierstrassCurve.b₄]; ring
+
+omit [DecidableEq L] in
+theorem coords_neg (P : (W0 L).toAffine.Point) :
+    coords (-P) = (coords P).map (fun q => (q.1, -q.2)) := by
+  rcases P with _ | ⟨x, y, h⟩
+  · rfl
+  · rw [Point.neg_some]; change some _ = some _; simp [WeierstrassCurve.Affine.negY]
+
+variable [Algebra ℚ L]
+
+omit [DecidableEq L] in
+theorem isElliptic_W0 : (W0 L).IsElliptic := by
+  have : CharZero L := charZero_of_injective_algebraMap (algebraMap ℚ L).injective
+  exact ⟨by rw [W0_Δ]; exact isUnit_iff_ne_zero.mpr (by norm_num)⟩
+
+omit [DecidableEq L] in
+theorem j_W0 : haveI := isElliptic_W0 (L := L); (W0 L).j = 0 := by
+  have := isElliptic_W0 (L := L)
+  rw [WeierstrassCurve.j, W0_c₄]; ring
+
+omit [DecidableEq L] in
+theorem stab_W0 (γ : VariableChange L) (hγ : γ • W0 L = W0 L) :
+    γ.r = 0 ∧ γ.s = 0 ∧ γ.t = 0 ∧ (γ.u : L) ^ 6 = 1 := by
+  have : CharZero L := charZero_of_injective_algebraMap (algebraMap ℚ L).injective
+  have : (W0 L).IsShortNF := ⟨rfl, rfl, rfl⟩
+  exact (WeierstrassCurve.mem_stabilizer_variableChange_iff_of_isShortNF_of_a4_eq_zero (F := L)
+    two_ne_zero three_ne_zero (W0 L) rfl one_ne_zero γ).mp hγ
+
+omit [Algebra ℚ L] [DecidableEq L] in
+theorem eq_mk_of_rst {γ : VariableChange L} (h : γ.r = 0 ∧ γ.s = 0 ∧ γ.t = 0) :
+    γ = ⟨γ.u, 0, 0, 0⟩ := by
+  obtain ⟨u, r, s, t⟩ := γ
+  obtain ⟨rfl, rfl, rfl⟩ := h
+  rfl
+
+omit [Algebra ℚ L] [DecidableEq L] in
+theorem pow_three_eq_one_cases {u w : L} (hu : u ^ 3 = 1) (hu1 : u ≠ 1) (hw : w ^ 3 = 1) :
+    w = 1 ∨ w = u ∨ w = u ^ 2 := by
+  have hu' : u ^ 2 + u + 1 = 0 := by
+    have : (u - 1) * (u ^ 2 + u + 1) = 0 := by linear_combination hu
+    exact (mul_eq_zero.mp this).resolve_left (sub_ne_zero.mpr hu1)
+  have : (w - 1) * (w - u) * (w - u ^ 2) = 0 := by
+    linear_combination hw + (-w ^ 2 + u * w + 1 - u) * hu'
+  rcases mul_eq_zero.mp this with h | h
+  · rcases mul_eq_zero.mp h with h | h
+    · left; exact sub_eq_zero.mp h
+    · right; left; exact sub_eq_zero.mp h
+  · right; right; exact sub_eq_zero.mp h
+
+omit [Algebra ℚ L] [DecidableEq L] in
+theorem sq_eq_one_cases {e : L} (he : e ^ 2 = 1) : e = 1 ∨ e = -1 := by
+  have : (e - 1) * (e + 1) = 0 := by linear_combination he
+  rcases mul_eq_zero.mp this with h | h
+  · left; exact sub_eq_zero.mp h
+  · right; exact eq_neg_of_add_eq_zero_left h
+
+section Cyclic
+
+variable {M : Type*} [AddCommGroup M]
+
+theorem exists_nsmul_nsmul_eq_self {N k : ℕ} (hk : k.Coprime N) {x : M} (hx : addOrderOf x = N) :
+    ∃ m : ℕ, m.Coprime N ∧ m • k • x = x := by
+  rcases Nat.eq_zero_or_pos N with hN0 | hNpos
+  · subst hN0
+    have hk1 : k = 1 := Nat.coprime_zero_right k |>.mp hk
+    exact ⟨1, Nat.coprime_one_left 0, by rw [hk1, one_nsmul, one_nsmul]⟩
+  by_cases hN1 : N = 1
+  · have hx0 : x = 0 := by
+      have h1 : addOrderOf x = 1 := by rw [hx, hN1]
+      exact AddMonoid.addOrderOf_eq_one_iff.mp h1
+    exact ⟨1, Nat.coprime_one_left N, by rw [hx0, smul_zero, smul_zero]⟩
+  · have h1N : 1 < N := by omega
+    obtain ⟨m, -, hm⟩ := Nat.exists_mul_mod_eq_one_of_coprime hk h1N
+    have hNx : N • x = 0 := by rw [← hx]; exact addOrderOf_nsmul_eq_zero x
+    have hdiv : N * (k * m / N) + 1 = k * m := by
+      have h := Nat.div_add_mod (k * m) N
+      rw [hm] at h
+      exact h
+    refine ⟨m, ?_, ?_⟩
+    · have hdm : Nat.gcd m N ∣ N * (k * m / N) + 1 := by
+        rw [hdiv]; exact Dvd.dvd.mul_left (Nat.gcd_dvd_left m N) k
+      have hdN : Nat.gcd m N ∣ N * (k * m / N) := Dvd.dvd.mul_right (Nat.gcd_dvd_right m N) _
+      exact Nat.dvd_one.mp ((Nat.dvd_add_right hdN).mp hdm)
+    · rw [← mul_nsmul x k m, ← hdiv, add_nsmul, mul_nsmul x N (k * m / N), hNx, smul_zero, zero_add,
+        one_nsmul]
+
+theorem zmultiples_nsmul_eq_of_coprime {N k : ℕ} (hk : k.Coprime N) {x : M} (hx : addOrderOf x = N)
+    :
+    AddSubgroup.zmultiples (k • x) = AddSubgroup.zmultiples x := by
+  obtain ⟨m, -, hm⟩ := exists_nsmul_nsmul_eq_self hk hx
+  refine le_antisymm ?_ ?_
+  · rintro y hy
+    obtain ⟨n, rfl⟩ := AddSubgroup.mem_zmultiples_iff.mp hy
+    exact AddSubgroup.mem_zmultiples_iff.mpr ⟨n * (k : ℤ), by rw [mul_zsmul, natCast_zsmul]⟩
+  · rintro y hy
+    obtain ⟨n, rfl⟩ := AddSubgroup.mem_zmultiples_iff.mp hy
+    exact AddSubgroup.mem_zmultiples_iff.mpr ⟨n * (m : ℤ), by rw [mul_zsmul, natCast_zsmul, hm]⟩
+
+theorem exists_coprime_nsmul_of_zmultiples_eq {N : ℕ} (hN : N ≠ 0) {x y : M} (hx : addOrderOf x = N)
+    (hy : addOrderOf y = N) (h : AddSubgroup.zmultiples y = AddSubgroup.zmultiples x) :
+    ∃ k : ℕ, k.Coprime N ∧ y = k • x := by
+  have hy' : y ∈ AddSubgroup.zmultiples x := by rw [← h]; exact AddSubgroup.mem_zmultiples y
+  obtain ⟨m, rfl⟩ := AddSubgroup.mem_zmultiples_iff.mp hy'
+  have hNx : (N : ℤ) • x = 0 := by rw [natCast_zsmul, ← hx]; exact addOrderOf_nsmul_eq_zero x
+  obtain ⟨k, hk⟩ : ∃ k : ℕ, (k : ℤ) = m % N :=
+    ⟨(m % N).toNat, Int.toNat_of_nonneg (Int.emod_nonneg _ (by exact_mod_cast hN))⟩
+  have hmk : m • x = k • x := by
+    have : m = m % N + N * (m / N) := (Int.emod_add_mul_ediv m N).symm
+    rw [← natCast_zsmul, hk]
+    conv_lhs => rw [this]
+    rw [add_zsmul, mul_zsmul', hNx, zsmul_zero, add_zero]
+  refine ⟨k, ?_, hmk⟩
+  have hzk : AddSubgroup.zmultiples (k • x) = AddSubgroup.zmultiples x := by rw [← hmk]; exact h
+  have hxmem : x ∈ AddSubgroup.zmultiples (k • x) := by rw [hzk]; exact AddSubgroup.mem_zmultiples x
+  obtain ⟨j, hj⟩ := AddSubgroup.mem_zmultiples_iff.mp hxmem
+  have hz : (j * k - 1 : ℤ) • x = 0 := by
+    rw [sub_zsmul, one_zsmul, mul_zsmul, natCast_zsmul, hj]; simp
+  have hdvd : (N : ℤ) ∣ j * k - 1 := by
+    rw [← hx]; exact addOrderOf_dvd_iff_zsmul_eq_zero.mpr hz
+  obtain ⟨t, ht⟩ := hdvd
+  have hcop : IsCoprime (k : ℤ) (N : ℤ) := ⟨j, -t, by linear_combination ht⟩
+  have hg : Int.gcd (k : ℤ) (N : ℤ) = 1 := Int.isCoprime_iff_gcd_eq_one.mp hcop
+  simpa [Int.gcd_natCast_natCast] using hg
+
+end Cyclic
+
+section Count
+
+abbrev CycSub (L : Type*) [Field L] [DecidableEq L] (N : ℕ) : Type _ :=
+  {H : AddSubgroup (W0 L).toAffine.Point // IsAddCyclic H ∧ Nat.card H = N}
+
+omit [DecidableEq L] [Algebra ℚ L] in
+theorem hσW (u : Lˣ) (hu : (u : L) ^ 3 = 1) : (⟨u, 0, 0, 0⟩ : VariableChange L) • W0 L = W0 L :=
+  WeierstrassCurve.variableChange_mk_smul_eq_self_of_pow_three_eq_one u hu 1
+
+def σ (u : Lˣ) (hu : (u : L) ^ 3 = 1) :
+    (W0 L).toAffine.Point →+ (W0 L).toAffine.Point := autPt ⟨u, 0, 0, 0⟩ (hσW u hu)
+
+omit [DecidableEq L] [Algebra ℚ L] in
+theorem hui3 (u : Lˣ) (hu : (u : L) ^ 3 = 1) : ((u⁻¹ : Lˣ) : L) ^ 3 = 1 := by
+  rw [Units.val_inv_eq_inv_val, inv_pow, hu, inv_one]
+
+omit [DecidableEq L] [Algebra ℚ L] in
+theorem hui2 (u : Lˣ) (hu : (u : L) ^ 3 = 1) : ((u⁻¹ : Lˣ) : L) ^ 2 = u := by
+  rw [Units.val_inv_eq_inv_val, inv_pow]
+  exact inv_eq_of_mul_eq_one_right (by rw [← pow_succ, hu])
+
+omit [Algebra ℚ L] in
+theorem coords_σ (u : Lˣ) (hu : (u : L) ^ 3 = 1) (P : (W0 L).toAffine.Point) :
+    coords (σ u hu P) = (coords P).map (fun q => ((u : L) * q.1, q.2)) := by
+  change coords (autPt _ _ P) = _
+  rw [coords_autPt, hui2 u hu, hui3 u hu]
+  congr 1
+  funext q
+  simp
+
+omit [Algebra ℚ L] in
+theorem coords_σ_σ (u : Lˣ) (hu : (u : L) ^ 3 = 1) (P : (W0 L).toAffine.Point) :
+    coords (σ u hu (σ u hu P)) = (coords P).map (fun q => ((u : L) ^ 2 * q.1, q.2)) := by
+  rw [coords_σ, coords_σ]
+  rcases coords P with _ | ⟨x, y⟩
+  · rfl
+  · simp only [Option.map_some, Option.some.injEq, Prod.mk.injEq, and_true]; ring
+
+omit [Algebra ℚ L] in
+theorem σ_σ_σ (u : Lˣ) (hu : (u : L) ^ 3 = 1) (P : (W0 L).toAffine.Point) :
+    σ u hu (σ u hu (σ u hu P)) = P := by
+  apply coords_injective
+  rw [coords_σ, coords_σ_σ]
+  rcases coords P with _ | ⟨x, y⟩
+  · rfl
+  · simp only [Option.map_some, Option.some.injEq, Prod.mk.injEq, and_true]
+    linear_combination x * hu
+
+omit [Algebra ℚ L] in
+theorem σ_injective (u : Lˣ) (hu : (u : L) ^ 3 = 1) :
+    Function.Injective (σ u hu) := autPt_injective _ _
+
+def τ (u : Lˣ) (hu : (u : L) ^ 3 = 1) (N : ℕ) (H : CycSub L N) : CycSub L N :=
+  ⟨H.1.map (σ u hu), by
+    obtain ⟨hc, hcard⟩ := H.2
+    refine ⟨?_, ?_⟩
+    · have := hc
+      exact isAddCyclic_of_surjective ((σ u hu).addSubgroupMap H.1) ((σ u
+        hu).addSubgroupMap_surjective H.1)
+    · exact (Nat.card_congr (H.1.equivMapOfInjective (σ u hu) (σ_injective u
+        hu)).symm.toEquiv).trans hcard⟩
+
+omit [Algebra ℚ L] in
+theorem τ_val (u : Lˣ) (hu : (u : L) ^ 3 = 1) (N : ℕ) (H : CycSub L N) :
+    (τ u hu N H).1 = H.1.map (σ u hu) := rfl
+
+omit [Algebra ℚ L] in
+theorem map_σ_σ_σ (u : Lˣ) (hu : (u : L) ^ 3 = 1) (H : AddSubgroup (W0 L).toAffine.Point) :
+    ((H.map (σ u hu)).map (σ u hu)).map (σ u hu) = H := by
+  rw [AddSubgroup.map_map, AddSubgroup.map_map]
+  ext P
+  constructor
+  · rintro ⟨Q, hQ, rfl⟩
+    change σ u hu (σ u hu (σ u hu Q)) ∈ H
+    rw [σ_σ_σ]; exact hQ
+  · intro hP
+    exact ⟨P, hP, by change σ u hu (σ u hu (σ u hu P)) = P; rw [σ_σ_σ]⟩
+
+omit [Algebra ℚ L] in
+theorem τ_τ_τ (u : Lˣ) (hu : (u : L) ^ 3 = 1) (N : ℕ) (H : CycSub L N) :
+    τ u hu N (τ u hu N (τ u hu N H)) = H :=
+  Subtype.ext (map_σ_σ_σ u hu H.1)
+
+def act (u : Lˣ) (hu : (u : L) ^ 3 = 1) (N : ℕ) (i : ZMod 3) (H : CycSub L N) : CycSub L N :=
+  if i = 0 then H else if i = 1 then τ u hu N H else τ u hu N (τ u hu N H)
+
+theorem zmod3_cases (i : ZMod 3) : i = 0 ∨ i = 1 ∨ i = 2 := by decide +revert
+
+@[instance_reducible]
+def actC3 (u : Lˣ) (hu : (u : L) ^ 3 = 1) (N : ℕ) :
+    MulAction (Multiplicative (ZMod 3)) (CycSub L N) where
+  smul g H := act u hu N (Multiplicative.toAdd g) H
+  one_smul H := by
+    change act u hu N (Multiplicative.toAdd (1 : Multiplicative (ZMod 3))) H = H
+    simp [act]
+  mul_smul a b H := by
+    change act u hu N (Multiplicative.toAdd (a * b)) H = act u hu N (Multiplicative.toAdd a) (act u
+      hu N (Multiplicative.toAdd b) H)
+    have hτ := τ_τ_τ u hu N H
+    have hτ' := τ_τ_τ u hu N (τ u hu N H)
+    rw [toAdd_mul]
+    generalize Multiplicative.toAdd a = i
+    generalize Multiplicative.toAdd b = j
+    have h10 : (1 : ZMod 3) ≠ 0 := by decide
+    have h20 : (2 : ZMod 3) ≠ 0 := by decide
+    have h21 : (2 : ZMod 3) ≠ 1 := by decide
+    have h11 : (1 : ZMod 3) + 1 = 2 := by decide
+    have h12 : (1 : ZMod 3) + 2 = 0 := by decide
+    have h21' : (2 : ZMod 3) + 1 = 0 := by decide
+    have h22 : (2 : ZMod 3) + 2 = 1 := by decide
+    rcases zmod3_cases i with rfl | rfl | rfl <;> rcases zmod3_cases j with rfl | rfl | rfl <;>
+      simp [act, hτ, h10, h20, h21, h11, h12, h21', h22]
+
+theorem natCard_C3 : Nat.card (Multiplicative (ZMod 3)) = 3 := by
+  simp [Nat.card_eq_fintype_card, ZMod.card]
+
+omit [Algebra ℚ L] in
+theorem mem_fixedPoints_iff (u : Lˣ) (hu : (u : L) ^ 3 = 1) (N : ℕ) (H : CycSub L N) :
+    (letI := actC3 u hu N; H ∈ MulAction.fixedPoints (Multiplicative (ZMod 3)) (CycSub L N)) ↔ τ u
+      hu N H = H := by
+  let := actC3 u hu N
+  rw [MulAction.mem_fixedPoints]
+  have h10 : (1 : ZMod 3) ≠ 0 := by decide
+  have h20 : (2 : ZMod 3) ≠ 0 := by decide
+  have h21 : (2 : ZMod 3) ≠ 1 := by decide
+  constructor
+  · intro h
+    have h1 : act u hu N (Multiplicative.toAdd (Multiplicative.ofAdd (1 : ZMod 3))) H = H :=
+      h (Multiplicative.ofAdd 1)
+    simpa [act, h10] using h1
+  · intro h g
+    change act u hu N (Multiplicative.toAdd g) H = H
+    rcases zmod3_cases (Multiplicative.toAdd g) with e | e | e <;> simp [act, e, h, h10, h20, h21]
+
+omit [Algebra ℚ L] in
+theorem τ_eq_iff (u : Lˣ) (hu : (u : L) ^ 3 = 1) (N : ℕ) (hN : N ≠ 0) (H : CycSub L N) :
+    τ u hu N H = H ↔ ∀ T ∈ H.1, σ u hu T ∈ H.1 := by
+  constructor
+  · intro h T hT
+    have : σ u hu T ∈ (τ u hu N H).1 := ⟨T, hT, rfl⟩
+    rwa [h] at this
+  · intro h
+    apply Subtype.ext
+    have hle : H.1.map (σ u hu) ≤ H.1 := by
+      rintro _ ⟨T, hT, rfl⟩; exact h T hT
+    have hfin : Finite H.1 := Nat.finite_of_card_ne_zero (by rw [H.2.2]; exact hN)
+    have hcard : Nat.card H.1 ≤ Nat.card (H.1.map (σ u hu)) := by
+      change Nat.card H.1 ≤ Nat.card (τ u hu N H).1
+      rw [(τ u hu N H).2.2, H.2.2]
+    exact AddSubgroup.eq_of_le_of_card_ge hle hcard
+
+variable (N : ℕ)
+
+def R (T T' : {T : (W0 L).toAffine.Point // addOrderOf T = N}) : Prop :=
+  ∃ γ : VariableChange L, ∃ _ : γ • W0 L = W0 L, ∃ k : ℕ, k.Coprime N ∧
+    HEq T'.1 (k • Point.vcInvFun γ (W0 L).toAffine T.1)
+
+def cyc (T : {T : (W0 L).toAffine.Point // addOrderOf T = N}) : CycSub L N :=
+  ⟨AddSubgroup.zmultiples T.1, ⟨⟨T.1, AddSubgroup.mem_zmultiples T.1⟩, fun y => by
+      obtain ⟨n, hn⟩ := AddSubgroup.mem_zmultiples_iff.mp y.2
+      exact ⟨n, Subtype.ext (by simpa using hn)⟩⟩, by rw [Nat.card_zmultiples, T.2]⟩
+
+theorem map_autPt_eq_or (u : Lˣ) (hu : (u : L) ^ 3 = 1) (hu1 : (u : L) ≠ 1) (γ : VariableChange L)
+    (hγ : γ • W0 L = W0 L) (H : AddSubgroup (W0 L).toAffine.Point) :
+    H.map (autPt γ hγ) = H ∨ H.map (autPt γ hγ) = H.map (σ u hu) ∨
+      H.map (autPt γ hγ) = (H.map (σ u hu)).map (σ u hu) := by
+  obtain ⟨hr, hs, ht, hv⟩ := stab_W0 γ hγ
+  have hγ' : γ = ⟨γ.u, 0, 0, 0⟩ := eq_mk_of_rst ⟨hr, hs, ht⟩
+  set c : L := ((γ.u⁻¹ : Lˣ) : L) with hc
+  have hc6 : c ^ 6 = 1 := by rw [hc, Units.val_inv_eq_inv_val, inv_pow, hv, inv_one]
+  have hco : ∀ P, coords (autPt γ hγ P) = (coords P).map (fun q => (c ^ 2 * q.1, c ^ 3 * q.2)) := by
+    intro P
+    have hγ'' : (⟨γ.u, 0, 0, 0⟩ : VariableChange L) • W0 L = W0 L := by rw [← hγ']; exact hγ
+    rw [autPt_congr hγ' hγ hγ'' P, coords_autPt]
+  have hw : c ^ 2 = 1 ∨ c ^ 2 = u ∨ c ^ 2 = (u : L) ^ 2 :=
+    pow_three_eq_one_cases hu hu1 (by rw [← pow_mul]; exact hc6)
+  have he : c ^ 3 = 1 ∨ c ^ 3 = -1 := sq_eq_one_cases (by rw [← pow_mul]; exact hc6)
+  obtain ⟨g, hgH, hg⟩ : ∃ g : (W0 L).toAffine.Point →+ (W0 L).toAffine.Point,
+      (H.map g = H ∨ H.map g = H.map (σ u hu) ∨ H.map g = (H.map (σ u hu)).map (σ u hu)) ∧
+      ∀ P, coords (g P) = (coords P).map (fun q => (c ^ 2 * q.1, q.2)) := by
+    rcases hw with h | h | h
+    · refine ⟨AddMonoidHom.id _, Or.inl (AddSubgroup.map_id H), fun P => ?_⟩
+      rw [h, AddMonoidHom.id_apply]
+      rcases coords P with _ | ⟨x, y⟩
+      · rfl
+      · simp
+    · refine ⟨σ u hu, Or.inr (Or.inl rfl), fun P => ?_⟩
+      rw [h, coords_σ]
+    · refine ⟨(σ u hu).comp (σ u hu), Or.inr (Or.inr (by rw [AddSubgroup.map_map])), fun P => ?_⟩
+      rw [h, AddMonoidHom.comp_apply, coords_σ_σ]
+  have key : (∀ P, autPt γ hγ P = g P) ∨ (∀ P, autPt γ hγ P = -(g P)) := by
+    rcases he with h3 | h3
+    · left; intro P; apply coords_injective; rw [hco, hg, h3]
+      rcases coords P with _ | ⟨x, y⟩
+      · rfl
+      · simp
+    · right; intro P; apply coords_injective; rw [hco, coords_neg, hg, h3]
+      rcases coords P with _ | ⟨x, y⟩
+      · rfl
+      · simp
+  have hmap : H.map (autPt γ hγ) = H.map g := by
+    rcases key with h | h
+    · rw [show autPt γ hγ = g from AddMonoidHom.ext h]
+    · ext P
+      constructor
+      · rintro ⟨Q, hQ, rfl⟩
+        exact ⟨-Q, H.neg_mem hQ, by rw [map_neg, h]⟩
+      · rintro ⟨Q, hQ, rfl⟩
+        exact ⟨-Q, H.neg_mem hQ, by rw [h, map_neg, neg_neg]⟩
+  rw [hmap]
+  exact hgH
+
+omit [Algebra ℚ L] in
+theorem R_iff (T T' : {T : (W0 L).toAffine.Point // addOrderOf T = N}) :
+    R N T T' ↔ ∃ γ : VariableChange L, ∃ hγ : γ • W0 L = W0 L, ∃ k : ℕ, k.Coprime N ∧ T'.1 = k •
+      autPt γ hγ T.1 := by
+  unfold R
+  refine exists_congr (fun γ => exists_congr (fun hγ => exists_congr (fun k => and_congr_right (fun
+    _ => ?_))))
+  rw [autPt_apply, ← map_nsmul (castPt hγ), eq_comm, castPt_eq_iff_heq]
+  exact heq_comm
+
+omit [Algebra ℚ L] in
+theorem autPt_one (h1 : (1 : VariableChange L) • W0 L = W0 L) (P : (W0 L).toAffine.Point) :
+    autPt 1 h1 P = P := by
+  apply coords_injective
+  have : autPt 1 h1 P = autPt ⟨1, 0, 0, 0⟩ h1 P := rfl
+  rw [this, coords_autPt]
+  rcases P with _ | ⟨x, y, h⟩ <;> simp
+
+omit [Algebra ℚ L] in
+private theorem _root_.P2MWs13.R2b.exists_generator (hN : N ≠ 0) (H : CycSub L N) :
+    ∃ T : (W0 L).toAffine.Point, addOrderOf T = N ∧ AddSubgroup.zmultiples T = H.1 := by
+  obtain ⟨hc, hcard⟩ := H.2
+  have := hc
+  obtain ⟨g, hg⟩ := IsAddCyclic.exists_generator (α := H.1)
+  have hfin : Finite H.1 := Nat.finite_of_card_ne_zero (by rw [hcard]; exact hN)
+  have hog : addOrderOf g = N := (addOrderOf_eq_card_of_forall_mem_zmultiples hg).trans hcard
+  refine ⟨g.1, by rw [AddSubgroup.addOrderOf_coe, hog], ?_⟩
+  have hle : AddSubgroup.zmultiples (g.1) ≤ H.1 := by
+    rw [AddSubgroup.zmultiples_le]; exact g.2
+  refine AddSubgroup.eq_of_le_of_card_ge hle ?_
+  rw [hcard, Nat.card_zmultiples, AddSubgroup.addOrderOf_coe, hog]
+
+p2m_export "P2MWs13.R2b" "exists_generator"
+omit [Algebra ℚ L] in
+theorem cyc_rel_of_or (u : Lˣ) (hu : (u : L) ^ 3 = 1)
+    {T T' : {T : (W0 L).toAffine.Point // addOrderOf T = N}}
+    (hN : N ≠ 0) :
+    (cyc N T' = cyc N T ∨ cyc N T' = τ u hu N (cyc N T) ∨ cyc N T' = τ u hu N (τ u hu N (cyc N T)))
+      → R N T T' := by
+  rw [R_iff]
+  have hu6 : (u : L) ^ 6 = 1 := by rw [show 6 = 3 * 2 from rfl, pow_mul, hu, one_pow]
+  rintro (h | h | h)
+  · have h' : AddSubgroup.zmultiples T'.1 = AddSubgroup.zmultiples T.1 := congrArg Subtype.val h
+    obtain ⟨k, hk, hkT⟩ := exists_coprime_nsmul_of_zmultiples_eq hN T.2 T'.2 h'
+    refine ⟨1, one_smul _ _, k, hk, ?_⟩
+    rw [hkT]; congr 1; exact (autPt_one (one_smul _ _) T.1).symm
+  · have h' : AddSubgroup.zmultiples T'.1 = AddSubgroup.zmultiples (σ u hu T.1) := by
+      have := congrArg Subtype.val h
+      rw [τ_val] at this
+      change AddSubgroup.zmultiples T'.1 = (AddSubgroup.zmultiples T.1).map (σ u hu) at this
+      rw [this, AddMonoidHom.map_zmultiples]
+    have hordσ : addOrderOf (σ u hu T.1) = N := by
+      rw [addOrderOf_injective (σ u hu) (σ_injective u hu), T.2]
+    obtain ⟨k, hk, hkT⟩ := exists_coprime_nsmul_of_zmultiples_eq hN hordσ T'.2 h'
+    exact ⟨⟨u, 0, 0, 0⟩, hσW u hu, k, hk, hkT⟩
+  · have h' : AddSubgroup.zmultiples T'.1 = AddSubgroup.zmultiples (σ u hu (σ u hu T.1)) := by
+      have := congrArg Subtype.val h
+      rw [τ_val, τ_val] at this
+      change AddSubgroup.zmultiples T'.1 = ((AddSubgroup.zmultiples T.1).map (σ u hu)).map (σ u hu)
+        at this
+      rw [this, AddMonoidHom.map_zmultiples, AddMonoidHom.map_zmultiples]
+    have hordσ : addOrderOf (σ u hu (σ u hu T.1)) = N := by
+      rw [addOrderOf_injective (σ u hu) (σ_injective u hu), addOrderOf_injective (σ u hu)
+        (σ_injective u hu), T.2]
+    obtain ⟨k, hk, hkT⟩ := exists_coprime_nsmul_of_zmultiples_eq hN hordσ T'.2 h'
+    have hu2 : (((u ^ 2 : Lˣ)) : L) ^ 3 = 1 := by
+      rw [Units.val_pow_eq_pow_val, ← pow_mul]; exact hu6
+    refine ⟨⟨u ^ 2, 0, 0, 0⟩, hσW (u ^ 2) hu2, k, hk, ?_⟩
+    rw [hkT]; congr 1
+    apply coords_injective
+    rw [coords_σ_σ, coords_autPt]
+    have e2 : (((u ^ 2)⁻¹ : Lˣ) : L) ^ 2 = (u : L) ^ 2 := by
+      rw [Units.val_inv_eq_inv_val, Units.val_pow_eq_pow_val, inv_pow, ← pow_mul]
+      refine inv_eq_of_mul_eq_one_right ?_
+      rw [← pow_add]; exact hu6
+    have e3 : (((u ^ 2)⁻¹ : Lˣ) : L) ^ 3 = 1 := by
+      rw [Units.val_inv_eq_inv_val, Units.val_pow_eq_pow_val, inv_pow, ← pow_mul, hu6, inv_one]
+    rw [e2, e3]
+    rcases coords T.1 with _ | ⟨x, y⟩
+    · rfl
+    · simp
+
+theorem R_imp_or (u : Lˣ) (hu : (u : L) ^ 3 = 1) (hu1 : (u : L) ≠ 1)
+    {T T' : {T : (W0 L).toAffine.Point // addOrderOf T = N}} (h : R N T T') :
+    cyc N T' = cyc N T ∨ cyc N T' = τ u hu N (cyc N T) ∨ cyc N T' = τ u hu N (τ u hu N (cyc N T))
+      := by
+  rw [R_iff] at h
+  obtain ⟨γ, hγ, k, hk, hkT⟩ := h
+  have hord : addOrderOf (autPt γ hγ T.1) = N := by
+    rw [addOrderOf_injective (autPt γ hγ) (autPt_injective γ hγ), T.2]
+  have hz : AddSubgroup.zmultiples T'.1 = (AddSubgroup.zmultiples T.1).map (autPt γ hγ) := by
+    rw [hkT, zmultiples_nsmul_eq_of_coprime hk hord, AddMonoidHom.map_zmultiples]
+  rcases map_autPt_eq_or u hu hu1 γ hγ (AddSubgroup.zmultiples T.1) with h | h | h
+  · left; apply Subtype.ext; change AddSubgroup.zmultiples T'.1 = AddSubgroup.zmultiples T.1; rw
+      [hz, h]
+  · right; left; apply Subtype.ext
+    change AddSubgroup.zmultiples T'.1 = (AddSubgroup.zmultiples T.1).map (σ u hu); rw [hz, h]
+  · right; right; apply Subtype.ext
+    change AddSubgroup.zmultiples T'.1 = ((AddSubgroup.zmultiples T.1).map (σ u hu)).map (σ u hu);
+      rw [hz, h]
+
+theorem natCard_quot_R_eq (u : Lˣ) (hu : (u : L) ^ 3 = 1) (hu1 : (u : L) ≠ 1) (hN : N ≠ 0) :
+    Nat.card (Quot (R (L := L) N)) =
+      (letI := actC3 u hu N; Nat.card (MulAction.orbitRel.Quotient (Multiplicative (ZMod 3)) (CycSub
+        L N))) := by
+  let := actC3 u hu N
+  have h10 : (1 : ZMod 3) ≠ 0 := by decide
+  have h20 : (2 : ZMod 3) ≠ 0 := by decide
+  have h21 : (2 : ZMod 3) ≠ 1 := by decide
+  let F : Quot (R (L := L) N) → MulAction.orbitRel.Quotient (Multiplicative (ZMod 3)) (CycSub L N)
+    :=
+    Quot.lift (fun T => (Quotient.mk _ (cyc N T) : MulAction.orbitRel.Quotient _ _)) (fun T T' h
+      => by
+      apply Quotient.sound
+      change cyc N T ∈ MulAction.orbit (Multiplicative (ZMod 3)) (cyc N T')
+      rcases R_imp_or N u hu hu1 h with h1 | h1 | h1
+      · rw [h1]; exact MulAction.mem_orbit_self _
+      · refine ⟨Multiplicative.ofAdd 2, ?_⟩
+        change act u hu N (Multiplicative.toAdd (Multiplicative.ofAdd (2 : ZMod 3))) (cyc N T') =
+          cyc N T
+        rw [h1]; simp [act, τ_τ_τ, h20, h21]
+      · refine ⟨Multiplicative.ofAdd 1, ?_⟩
+        change act u hu N (Multiplicative.toAdd (Multiplicative.ofAdd (1 : ZMod 3))) (cyc N T') =
+          cyc N T
+        rw [h1]; simp [act, τ_τ_τ, h10])
+  refine Nat.card_congr (Equiv.ofBijective F ⟨?_, ?_⟩)
+  · intro a b
+    induction a using Quot.ind with | _ T => ?_
+    induction b using Quot.ind with | _ T' => ?_
+    intro hab
+    have hrel : cyc N T ∈ MulAction.orbit (Multiplicative (ZMod 3)) (cyc N T') := Quotient.exact hab
+    obtain ⟨g, hg⟩ := hrel
+    have hg' : act u hu N (Multiplicative.toAdd g) (cyc N T') = cyc N T := hg
+    unfold act at hg'
+    split_ifs at hg' with h0 h1
+    · exact Quot.sound (cyc_rel_of_or N u hu hN (Or.inl hg'))
+    · exact Quot.sound (cyc_rel_of_or N u hu hN (Or.inr (Or.inr (by rw [← hg', τ_τ_τ]))))
+    · exact Quot.sound (cyc_rel_of_or N u hu hN (Or.inr (Or.inl (by rw [← hg', τ_τ_τ]))))
+  · intro q
+    induction q using Quotient.ind with | _ H => ?_
+    obtain ⟨T, hT, hTH⟩ := exists_generator N hN H
+    refine ⟨Quot.mk _ ⟨T, hT⟩, ?_⟩
+    change Quotient.mk _ (cyc N ⟨T, hT⟩) = Quotient.mk _ H
+    congr 1
+    exact Subtype.ext hTH
+
+end Count
+
+end P2MWs13.R2b
+end
+
+open Polynomial in
+open P2MWs13.R2b in
+theorem solution
+    (N : ℕ) [NeZero N] (L : Type*) [Field L] [DecidableEq L] [Algebra ℚ L] [IsAlgClosed L] :
+    3 * Nat.card {x : ModuliPoint N L // ModuliPoint.j x = (0 : L)} = dedekindPsi N + 2 * nuThree N
+      := by
+  have : CharZero L := charZero_of_injective_algebraMap (algebraMap ℚ L).injective
+  have := isElliptic_W0 (L := L)
+  have hN : N ≠ 0 := NeZero.ne N
+  have hNL : ((N : ℕ) : L) ≠ 0 := Nat.cast_ne_zero.mpr hN
+  obtain ⟨uu, huu⟩ : ∃ uu : L, uu ^ 2 + uu + 1 = 0 := by
+    obtain ⟨z, hz⟩ := IsAlgClosed.exists_root (X ^ 2 + X + C 1 : L[X])
+      (by rw [show (X ^ 2 + X + C 1 : L[X]).degree = 2 by compute_degree!]; norm_num)
+    refine ⟨z, ?_⟩
+    have hz' := hz
+    rw [IsRoot.def, eval_add, eval_add, eval_pow, eval_X, eval_C] at hz'
+    exact hz'
+  have hu3 : uu ^ 3 = 1 := by linear_combination (uu - 1) * huu
+  have hu1 : uu ≠ 1 := by
+    rintro rfl; norm_num at huu
+  have hu0 : uu ≠ 0 := by
+    rintro rfl; norm_num at huu
+  set u : Lˣ := Units.mk0 uu hu0 with hudef
+  have hu : (u : L) ^ 3 = 1 := hu3
+  have hu1' : (u : L) ≠ 1 := hu1
+  have h1 : Nat.card {x : ModuliPoint N L // ModuliPoint.j x = (0 : L)} = Nat.card (Quot (R (L := L)
+    N)) :=
+    by
+    have e : Nat.card {x : ModuliPoint N L // ModuliPoint.j x = (0 : L)}
+        = Nat.card {x : ModuliPoint N L // ModuliPoint.j x = (W0 L).j} :=
+      Nat.card_congr (Equiv.subtypeEquivRight (fun x => by rw [j_W0 (L := L)]))
+    rw [e]
+    exact ModularCurve.natCard_moduliPoint_j_eq_eq_natCard_quot_addOrderOf_eq N L (W0 L)
+  let := actC3 u hu N
+  have h2 := natCard_quot_R_eq N u hu hu1' hN
+  have hfinT : Finite {T : (W0 L).toAffine.Point // addOrderOf T = N} := by
+    have hc := (W0 L).card_torsion_of_isAlgClosed (K := L) hNL
+    have hb : ((W0 L)⁄L) = (W0 L).toAffine := by
+      change ((W0 L).baseChange L).toAffine = (W0 L).toAffine
+      rw [WeierstrassCurve.baseChange, Algebra.algebraMap_self, WeierstrassCurve.map_id]
+    rw [hb] at hc
+    have : Finite (Submodule.torsionBy ℤ (W0 L).toAffine.Point N) :=
+      Nat.finite_of_card_ne_zero (by rw [hc]; positivity)
+    refine Finite.of_injective (fun T => (⟨T.1, ?_⟩ : Submodule.torsionBy ℤ (W0 L).toAffine.Point
+      N)) ?_
+    · rw [Submodule.mem_torsionBy_iff]; change (N : ℤ) • T.1 = 0
+      have hT0 := addOrderOf_nsmul_eq_zero T.1
+      rw [T.2] at hT0
+      rw [natCast_zsmul]; exact hT0
+    · intro a b h; exact Subtype.ext (congrArg Subtype.val h :)
+  have : Finite (CycSub L N) := by
+    refine Finite.of_surjective (fun T : {T : (W0 L).toAffine.Point // addOrderOf T = N} => cyc N T)
+      ?_
+    intro H
+    obtain ⟨T, hT, hTH⟩ := exists_generator N hN H
+    exact ⟨⟨T, hT⟩, Subtype.ext hTH⟩
+  have h3 :=
+    MulAction.card_mul_natCard_orbitRel_quotient_eq_of_natCard_eq_prime (Multiplicative (ZMod 3))
+    (X := CycSub L N) Nat.prime_three natCard_C3
+  have h4 : Nat.card (CycSub L N) = dedekindPsi N := by
+    have h :=
+      (W0 L).natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed (K := L) (n := N)
+        hNL
+    have hb : ((W0 L)⁄L) = (W0 L).toAffine := by
+      change ((W0 L).baseChange L).toAffine = (W0 L).toAffine
+      rw [WeierstrassCurve.baseChange, Algebra.algebraMap_self, WeierstrassCurve.map_id]
+    rw [hb] at h
+    exact h
+  have h5 : Nat.card (MulAction.fixedPoints (Multiplicative (ZMod 3)) (CycSub L N)) = nuThree N :=
+    by
+    rw [← WeierstrassCurve.natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuThree
+      (1 : L) one_ne_zero u hu hu1' N hN]
+    refine Nat.card_congr ⟨fun H => ⟨H.1.1, H.1.2.1, H.1.2.2, ?_⟩, fun H => ⟨⟨H.1, H.2.1, H.2.2.1⟩,
+      ?_⟩, ?_, ?_⟩
+    · have hfix : τ u hu N H.1 = H.1 := (mem_fixedPoints_iff u hu N H.1).mp H.2
+      intro T hT
+      refine ⟨σ u hu T, (τ_eq_iff u hu N hN H.1).mp hfix T hT, ?_⟩
+      exact (autPt_eq_iff_heq _ (hσW u hu) T _).mp rfl
+    · rw [mem_fixedPoints_iff, τ_eq_iff u hu N hN]
+      intro T hT
+      obtain ⟨T', hT', hheq⟩ := H.2.2.2 T hT
+      have : σ u hu T = T' := (autPt_eq_iff_heq _ (hσW u hu) T T').mpr hheq
+      rw [this]; exact hT'
+    · intro H; rfl
+    · intro H; rfl
+  have h31 : (3 - 1) * nuThree N = 2 * nuThree N := by norm_num
+  rw [h1, h2, h3, h4, h5, h31]
+
+end S_OVERLONG_44f45b4b
+end P2MW
+export
+  P2MW.S_OVERLONG_44f45b4b
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.three_mul_natCard_moduliPoint_j_eq_zero_eq_dedekindPsi_add_two_mul_nuThree
+    (N : ℕ) [NeZero N] (L : Type*) [Field L] [DecidableEq L] [Algebra ℚ L] [IsAlgClosed L] :
+    3 * Nat.card {x : ModuliPoint N L // ModuliPoint.j x = (0 : L)} = dedekindPsi N + 2 * nuThree N
+      :=
+  solution N L
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_transcendental_and_finiteDimensional_adjoin_laurentBaseChange_of_coe_eq_coeffEmb.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_transcendental_and_finiteDimensional_adjoin_laurentBaseChange_of_coe_eq_coeffEmb.lean
new file mode 100644
index 0000000000..e07ea7784e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_transcendental_and_finiteDimensional_adjoin_laurentBaseChange_of_coe_eq_coeffEmb.lean
@@ -0,0 +1,218 @@
+/-
+Based on Prove2Me node
+ModularCurve.transcendental_and_finiteDimensional_adjoin_laurentBaseChange_of_coe_eq_coeffEmb
+(1d73107f-d1f1-5075-beee-77bb400c7de9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f1d9d388-8cf4-5376-b3b8-3d67d43820b0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.PicardGroup
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GeometricBaseChange
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Transcendence and finiteness under constant field extension of F₀
+
+Theorem statement:
+`ModularCurve.transcendental_and_finiteDimensional_adjoin_laurentBaseChange_of_coe_eq_coeffEmb`
+(`1d73107f-d1f1-5075-beee-77bb400c7de9`), by Claude, 2026-09-05.
+
+Proof: submission `f1d9d388-8cf4-5376-b3b8-3d67d43820b0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbb{Q}$-algebra structure and assumed algebraic over
+$\mathbb{Q}$, and let $F_0$ be an intermediate field of $\mathbb{Q} \subseteq \mathbb{Q}((q))$,
+where $\mathbb{Q}((q))$ is `LaurentSeries ℚ`. Write $\iota =$ `coeffEmb L` for the ring homomorphism
+$\mathbb{Q}((q)) \to L((q))$ that applies $\mathbb{Q} \to L$ to each coefficient, and let $LF_0 =$
+`laurentBaseChange L F₀` be the intermediate field of $L \subseteq L((q))$ generated over $L$ by the
+image $\iota(F_0)$. Let $j \in F_0$ be transcendental over $\mathbb{Q}$, and assume $F_0$ is
+finite-dimensional over the intermediate field $\mathbb{Q}(j)$ obtained by adjoining $j$ to
+$\mathbb{Q}$ inside $F_0$. Let $jb$ be an element of $LF_0$ whose underlying Laurent series over $L$
+equals $\iota$ applied to the Laurent series underlying $j$. Then $jb$ is transcendental over $L$,
+and $LF_0$ is finite-dimensional over the intermediate field $L(jb)$ obtained by adjoining $jb$ to
+$L$ inside $LF_0$.
+
+This is the constant field extension step for a field of $q$-expansions: passing from $\mathbb{Q}$
+to an algebraic extension $L$ preserves both the transcendence of a chosen generator and the
+finiteness of the function field over the rational subfield it generates. These are exactly the two
+hypotheses required to run the two-chart construction of a smooth proper model of $LF_0/L$ at the
+generator $jb$, and the result is used in the geometric arguments about models of modular curves,
+degrees and Riemann–Roch spaces that follow.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_transcendental_and_finiteDimensional_adjoin_laurentBaseChange_of_coe_eq_coeffEmb.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_9a1867b9
+
+
+noncomputable section
+
+open ModularCurve
+open scoped TensorProduct
+
+namespace CC2B01K4
+
+variable (L : Type) [Field L] [Algebra ℚ L]
+variable (F₀ : IntermediateField ℚ (LaurentSeries ℚ))
+
+private def emb : ↥F₀ →+* ↥(laurentBaseChange L F₀) :=
+  ((coeffEmb L).comp (SubringClass.subtype F₀)).codRestrict (laurentBaseChange L F₀)
+    fun x => coeffEmb_mem_laurentBaseChange L x.2
+
+private theorem emb_apply (f : ↥F₀) :
+    emb L F₀ f = ⟨coeffEmb L (f : LaurentSeries ℚ), coeffEmb_mem_laurentBaseChange L f.2⟩ := rfl
+
+private theorem emb_algebraMap (q : ℚ) :
+    emb L F₀ (algebraMap ℚ ↥F₀ q) = algebraMap L ↥(laurentBaseChange L F₀) (algebraMap ℚ L q) :=
+  RingHom.congr_fun (Subsingleton.elim ((emb L F₀).comp (algebraMap ℚ ↥F₀))
+    ((algebraMap L ↥(laurentBaseChange L F₀)).comp (algebraMap ℚ L))) q
+
+private theorem emb_comp_algebraMap :
+    (algebraMap L ↥(laurentBaseChange L F₀)).comp (algebraMap ℚ L) =
+      (emb L F₀).comp (algebraMap ℚ ↥F₀) :=
+  RingHom.ext fun q => (emb_algebraMap L F₀ q).symm
+
+private theorem emb_eq_baseChangeEquiv_one_tmul [Algebra.IsAlgebraic ℚ L] (f : ↥F₀) :
+    emb L F₀ f = baseChangeEquiv L F₀ (1 ⊗ₜ f) :=
+  (baseChangeEquiv_one_tmul L F₀ f).symm
+
+private theorem transcendental_emb [Algebra.IsAlgebraic ℚ L] {j : ↥F₀} (hj : Transcendental ℚ j) :
+    Transcendental L (emb L F₀ j) := by
+  let iQA : Algebra ℚ ↥(laurentBaseChange L F₀) :=
+    ((algebraMap L ↥(laurentBaseChange L F₀)).comp (algebraMap ℚ L)).toAlgebra
+  have : @IsScalarTower ℚ L ↥(laurentBaseChange L F₀) _ _ iQA.toSMul :=
+    IsScalarTower.of_algebraMap_eq' rfl
+  have hQ : Transcendental ℚ (emb L F₀ j) :=
+    hj.ringHom_of_comp_eq (RingHom.id ℚ) (emb L F₀) Function.surjective_id (emb L F₀).injective
+      (by
+        refine RingHom.ext fun q => ?_
+        change algebraMap ℚ ↥(laurentBaseChange L F₀) q = emb L F₀ (algebraMap ℚ ↥F₀ q)
+        rw [emb_algebraMap]
+        rfl)
+  exact hQ.extendScalars L
+
+private theorem span_range_one_tmul_eq_top (k K E : Type) [Field k] [Field K] [Algebra k K]
+    [AddCommGroup E] [Module k E] :
+    Submodule.span K (Set.range fun f : E => (1 : K) ⊗ₜ[k] f) = ⊤ := by
+  refine Submodule.eq_top_iff'.mpr fun x => ?_
+  induction x using TensorProduct.inductionOn with
+  | tmul c f =>
+    have h : c ⊗ₜ[k] f = c • ((1 : K) ⊗ₜ[k] f) := by
+      rw [TensorProduct.smul_tmul', smul_eq_mul, mul_one]
+    rw [h]
+    exact Submodule.smul_mem _ _ (Submodule.subset_span ⟨f, rfl⟩)
+  | add x y hx hy => exact add_mem hx hy
+
+private theorem span_range_emb_eq_top [Algebra.IsAlgebraic ℚ L] :
+    Submodule.span L (Set.range fun f : ↥F₀ => emb L F₀ f) = ⊤ := by
+  have h := span_range_one_tmul_eq_top ℚ L ↥F₀
+  apply_fun Submodule.map (baseChangeEquiv L F₀).toLinearEquiv.toLinearMap at h
+  rw [Submodule.map_top, LinearEquiv.range, Submodule.map_span, ← Set.range_comp] at h
+  convert h using 3
+  funext f
+  simp only [Function.comp_apply, LinearEquiv.coe_coe, AlgEquiv.toLinearEquiv_apply,
+    emb_eq_baseChangeEquiv_one_tmul]
+
+private theorem emb_mem_adjoin {j f : ↥F₀} (hf : f ∈ IntermediateField.adjoin ℚ ({j} : Set ↥F₀)) :
+    emb L F₀ f ∈ IntermediateField.adjoin L ({emb L F₀ j} : Set ↥(laurentBaseChange L F₀)) := by
+  rw [IntermediateField.mem_adjoin_simple_iff] at hf ⊢
+  obtain ⟨r, s, rfl⟩ := hf
+  refine ⟨r.map (algebraMap ℚ L), s.map (algebraMap ℚ L), ?_⟩
+  rw [map_div₀, Polynomial.map_aeval_eq_aeval_map (emb_comp_algebraMap L F₀),
+    Polynomial.map_aeval_eq_aeval_map (emb_comp_algebraMap L F₀)]
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+private theorem finiteDimensional_adjoin_emb [Algebra.IsAlgebraic ℚ L] (j : ↥F₀)
+    [FiniteDimensional ↥(IntermediateField.adjoin ℚ ({j} : Set ↥F₀)) ↥F₀] :
+    FiniteDimensional ↥(IntermediateField.adjoin L ({emb L F₀ j} : Set ↥(laurentBaseChange L F₀)))
+      ↥(laurentBaseChange L F₀) := by
+  classical
+  set E := IntermediateField.adjoin L ({emb L F₀ j} : Set ↥(laurentBaseChange L F₀)) with hE
+  let K := IntermediateField.adjoin ℚ ({j} : Set ↥F₀)
+  let bK := Module.finBasis ↥K ↥F₀
+  let W : Submodule ↥E ↥(laurentBaseChange L F₀) :=
+    Submodule.span ↥E (Set.range fun i => emb L F₀ (bK i))
+  have key : ∀ f : ↥F₀, emb L F₀ f ∈ W := by
+    intro f
+    rw [← bK.sum_repr f, map_sum]
+    refine Submodule.sum_mem _ fun i _ => ?_
+    rw [Algebra.smul_def, map_mul]
+    have hc : emb L F₀ (algebraMap ↥K ↥F₀ (bK.repr f i)) ∈ E :=
+      emb_mem_adjoin L F₀ (bK.repr f i).2
+    have : emb L F₀ (algebraMap ↥K ↥F₀ (bK.repr f i)) * emb L F₀ (bK i) =
+        (⟨_, hc⟩ : ↥E) • emb L F₀ (bK i) := by
+      rw [Algebra.smul_def]; rfl
+    rw [this]
+    exact Submodule.smul_mem _ _ (Submodule.subset_span ⟨i, rfl⟩)
+  have htop : W.restrictScalars L = ⊤ := by
+    refine eq_top_iff.mpr ?_
+    rw [← span_range_emb_eq_top L F₀, Submodule.span_le]
+    rintro _ ⟨f, rfl⟩
+    exact key f
+  have hW : W = ⊤ :=
+    Submodule.restrictScalars_injective L _ _ (by rw [htop, Submodule.restrictScalars_top])
+  exact ⟨by rw [← hW]; exact Submodule.fg_span (Set.finite_range _)⟩
+
+end CC2B01K4
+
+theorem solution
+    (L : Type) [Field L] [Algebra ℚ L] [Algebra.IsAlgebraic ℚ L]
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (j : ↥F₀) (hj : Transcendental ℚ j)
+    [FiniteDimensional ↥(IntermediateField.adjoin ℚ ({j} : Set ↥F₀)) ↥F₀]
+    (jb : ↥(laurentBaseChange L F₀))
+    (hjb : (jb : LaurentSeries L) = coeffEmb L ((j : ↥F₀) : LaurentSeries ℚ)) :
+    Transcendental L jb ∧
+      FiniteDimensional ↥(IntermediateField.adjoin L ({jb} : Set ↥(laurentBaseChange L F₀)))
+        ↥(laurentBaseChange L F₀) := by
+  obtain rfl : jb = CC2B01K4.emb L F₀ j := Subtype.ext hjb
+  exact ⟨CC2B01K4.transcendental_emb L F₀ hj, CC2B01K4.finiteDimensional_adjoin_emb L F₀ j⟩
+
+end
+
+end S_OVERLONG_9a1867b9
+end P2MW
+export
+  P2MW.S_OVERLONG_9a1867b9
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem
+  ModularCurve.transcendental_and_finiteDimensional_adjoin_laurentBaseChange_of_coe_eq_coeffEmb
+    (L : Type) [Field L] [Algebra ℚ L] [Algebra.IsAlgebraic ℚ L]
+    (F₀ : IntermediateField ℚ (LaurentSeries ℚ)) (j : ↥F₀) (hj : Transcendental ℚ j)
+    [FiniteDimensional ↥(IntermediateField.adjoin ℚ ({j} : Set ↥F₀)) ↥F₀]
+    (jb : ↥(laurentBaseChange L F₀))
+    (hjb : (jb : LaurentSeries L) = coeffEmb L ((j : ↥F₀) : LaurentSeries ℚ)) :
+    Transcendental L jb ∧
+      FiniteDimensional ↥(IntermediateField.adjoin L ({jb} : Set ↥(laurentBaseChange L F₀)))
+        ↥(laurentBaseChange L F₀) :=
+  solution L F₀ j hj jb hjb
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC.lean
new file mode 100644
index 0000000000..d8342c18c3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC.lean
@@ -0,0 +1,271 @@
+/-
+Based on Prove2Me node
+ModularCurve.
+transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC
+(08a0b3fa-d06e-56e2-ac73-7328a79884c9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b27feab6-bcae-55d4-aa3c-42edbf57bef0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.FieldTheory.Relrank
+import Mathlib.RingTheory.Flat.TorsionFree
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0ModL
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_and_finrank_adjoin_jqModC_qExpFunctionFieldC_le_index
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Transcendence of j and finiteness over K(j)
+
+Theorem statement:
+`ModularCurve.
+transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC`
+(`08a0b3fa-d06e-56e2-ac73-7328a79884c9`), by Claude, 2026-09-05.
+
+Proof: submission `b27feab6-bcae-55d4-aa3c-42edbf57bef0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field equipped with a $\mathbb{Q}$-algebra structure, and let $\Gamma \le
+\mathrm{SL}_2(\mathbb{Z})$ be a subgroup of finite index containing the translation matrix $T$.
+Consider first the intermediate field $F_0 =$ [`ModularCurve.qExpFunctionFieldC ℚ
+Γ`](def/ModularCurve_X1.html#L101) of $\mathbb{Q} \subseteq \mathbb{Q}((q))$, generated over
+$\mathbb{Q}$ by the set of quotients $\mathrm{intSeriesC}\,\mathbb{Q}\,p_f /
+\mathrm{intSeriesC}\,\mathbb{Q}\,p_g$ in which $k \in \mathbb{Z}$, $f$ and $g$ are modular forms of
+weight $k$ for the image of $\Gamma$ in $\mathrm{GL}_2(\mathbb{R})$, the integral power series $p_f,
+p_g \in \mathbb{Z}[[q]]$ are integral $q$-expansions of $f$ and $g$ in the sense of the predicate
+`IsIntegralQExp`, and the Laurent series attached to $p_g$ is nonzero. Its constant base change
+`laurentBaseChange K F₀` is the intermediate field of $K \subseteq K((q))$ generated over $K$ by the
+image of $F_0$ under the coefficientwise map $K((q)) \leftarrow \mathbb{Q}((q))$ induced by
+$\mathbb{Q} \to K$. Let $y$ be an element of this field whose underlying Laurent series is `jqModC
+K`, namely $q^{-1}$ times the image in $K[[q]]$ of the integral power series $E_4^3 \cdot
+\mathrm{dedekindEtaUnitInv}$. The conclusion is twofold: $y$ is transcendental over $K$, and
+`laurentBaseChange K F₀` is a finite-dimensional vector space over the subfield $K(y)$ generated by
+$y$. Unlike the $\mathbb{Q}$-level statement it cites, this one asserts no bound on the degree in
+terms of the index of $\Gamma$.
+
+This is the standard pair of facts underlying the use of the modular function field as a finite
+extension of the rational function field $K(j)$: transcendence of the $q$-expansion of $j$ together
+with finiteness of the field of modular functions of level $\Gamma$, after constant base change to
+$K$, over $K(j)$. It is the hypothesis package required by the Riemann–Roch and Riemann–Hurwitz
+arguments on these fields, such as fibre counts, the genus of $X_1(M)$ and dimension bounds for
+spaces of cusp forms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_f6c119b3
+
+namespace ModularCurve
+p2m_export "ModularCurve" "intSeriesC intFormRatiosC qExpFunctionFieldC intFormRatiosC_subset \
+  coeffMap_single coeffEmb coeffEmb_coeff laurentBaseChange jqModC coeffMap_ofPowerSeries \
+  finiteDimensional_and_finrank_adjoin_jqModC_qExpFunctionFieldC_le_index transcendental_jqModC"
+namespace FullnessGamma1
+p2m_open "ModularCurve~coeffEmb_injective"
+
+p2m_open "ModularCurve~coeffEmb_injective \
+  P2MW.S_OVERLONG_f6c119b3.ModularCurve IntermediateField"
+
+theorem finrank_adjoin_eq_relfinrank {K E : Type*} [Field K] [Field E] [Algebra K E]
+    (F : IntermediateField K E) (x : F) :
+    Module.finrank (IntermediateField.adjoin K ({x} : Set F)) F =
+      (IntermediateField.adjoin K ({(x : E)} : Set E)).relfinrank F := by
+  have hlift : IntermediateField.lift (IntermediateField.adjoin K ({x} : Set F)) =
+      IntermediateField.adjoin K ({(x : E)} : Set E) := by
+    rw [IntermediateField.lift_adjoin]; simp
+  have hle : IntermediateField.adjoin K ({(x : E)} : Set E) ≤ F := by
+    rw [← hlift]; exact IntermediateField.lift_le _
+  rw [IntermediateField.relfinrank_eq_finrank_of_le hle]
+  let i : (IntermediateField.adjoin K ({x} : Set F)) ≃+*
+      (IntermediateField.adjoin K ({(x : E)} : Set E)) :=
+    ((IntermediateField.liftAlgEquiv (IntermediateField.adjoin K ({x} : Set F))).trans
+      (IntermediateField.equivOfEq hlift)).toRingEquiv
+  let j : F ≃+* (IntermediateField.extendScalars hle) := RingEquiv.refl _
+  refine Algebra.finrank_eq_of_equiv_equiv i j ?_
+  ext a
+  rfl
+
+section BaseChange
+
+variable (K : Type*) [Field K] [Algebra ℚ K]
+
+theorem coeffEmb_injective : Function.Injective (coeffEmb K) := by
+  intro x y h
+  ext n
+  have h1 := congrArg (fun s : LaurentSeries K => s.coeff n) h
+  simp only [coeffEmb_coeff] at h1
+  exact (algebraMap ℚ K).injective h1
+
+theorem coeffEmb_ne_zero_iff (x : LaurentSeries ℚ) : coeffEmb K x ≠ 0 ↔ x ≠ 0 := by
+  rw [Ne, ← map_zero (coeffEmb K), (coeffEmb_injective K).eq_iff]
+
+theorem coeffEmb_intSeriesC (p : PowerSeries ℤ) : coeffEmb K (intSeriesC ℚ p) = intSeriesC K p := by
+  rw [coeffEmb, intSeriesC, intSeriesC, coeffMap_ofPowerSeries]
+  congr 1
+  ext n
+  simp [PowerSeries.coeff_map]
+
+theorem algebraMap_laurentSeries_eq_C {L : Type*} [Field L] (a : L) :
+    algebraMap L (LaurentSeries L) a = HahnSeries.C a := by
+  rw [HahnSeries.algebraMap_apply']
+  have h1 : algebraMap L (PowerSeries L) a = PowerSeries.C a := by simp
+  rw [h1, HahnSeries.ofPowerSeries_C]
+
+theorem coeffEmb_algebraMap (a : ℚ) :
+    coeffEmb K (algebraMap ℚ (LaurentSeries ℚ) a) = algebraMap K (LaurentSeries K) (algebraMap ℚ K
+      a) := by
+  rw [algebraMap_laurentSeries_eq_C, algebraMap_laurentSeries_eq_C, HahnSeries.C_apply,
+    HahnSeries.C_apply,
+    coeffEmb, coeffMap_single]
+
+variable (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+
+theorem image_intFormRatiosC : (coeffEmb K) '' intFormRatiosC ℚ Γ = intFormRatiosC K Γ := by
+  ext z
+  constructor
+  · rintro ⟨y, ⟨w, f, g, pf, pg, hf, hg, hg0, rfl⟩, rfl⟩
+    refine ⟨w, f, g, pf, pg, hf, hg, ?_, ?_⟩
+    · rw [← coeffEmb_intSeriesC K]; exact (coeffEmb_ne_zero_iff K _).mpr hg0
+    · rw [map_div₀, coeffEmb_intSeriesC, coeffEmb_intSeriesC]
+  · rintro ⟨w, f, g, pf, pg, hf, hg, hg0, rfl⟩
+    refine ⟨intSeriesC ℚ pf / intSeriesC ℚ pg, ⟨w, f, g, pf, pg, hf, hg, ?_, rfl⟩, ?_⟩
+    · rw [← coeffEmb_ne_zero_iff K, coeffEmb_intSeriesC]; exact hg0
+    · rw [map_div₀, coeffEmb_intSeriesC, coeffEmb_intSeriesC]
+
+variable {Γ}
+
+theorem coeffEmb_mem_adjoin {S : Set (LaurentSeries ℚ)} {y : LaurentSeries ℚ} (hy : y ∈ adjoin ℚ S)
+    :
+    coeffEmb K y ∈ adjoin K ((coeffEmb K) '' S) := by
+  have hy' : y ∈ (adjoin ℚ S).toSubfield := hy
+  rw [adjoin_toSubfield] at hy'
+  have hle : Subfield.closure (Set.range (algebraMap ℚ (LaurentSeries ℚ)) ∪ S) ≤
+      (adjoin K ((coeffEmb K) '' S)).toSubfield.comap (coeffEmb K) := by
+    rw [Subfield.closure_le]
+    rintro z (⟨a, rfl⟩ | hz)
+    · change coeffEmb K (algebraMap ℚ (LaurentSeries ℚ) a) ∈ adjoin K ((coeffEmb K) '' S)
+      rw [coeffEmb_algebraMap]
+      exact IntermediateField.algebraMap_mem _ _
+    · change coeffEmb K z ∈ adjoin K ((coeffEmb K) '' S)
+      exact subset_adjoin K _ ⟨z, hz, rfl⟩
+  exact hle hy'
+
+variable (Γ)
+
+theorem laurentBaseChange_qExpFunctionFieldC_eq :
+    laurentBaseChange K (qExpFunctionFieldC ℚ Γ) = qExpFunctionFieldC K Γ := by
+  apply le_antisymm
+  · rw [laurentBaseChange, IntermediateField.adjoin_le_iff]
+    rintro _ ⟨y, hy, rfl⟩
+    have h := coeffEmb_mem_adjoin K (S := intFormRatiosC ℚ Γ) hy
+    rwa [image_intFormRatiosC] at h
+  · rw [qExpFunctionFieldC, ← image_intFormRatiosC K Γ, laurentBaseChange]
+    exact IntermediateField.adjoin.mono K _ _ (Set.image_mono (intFormRatiosC_subset ℚ Γ))
+
+end BaseChange
+
+end ModularCurve.FullnessGamma1
+
+p2m_open "ModularCurve~coeffEmb_injective \
+  P2MW.S_OVERLONG_f6c119b3.ModularCurve CongruenceSubgroup AlgebraicCurve"
+open scoped MatrixGroups
+
+open ModularCurve.FullnessGamma1 IntermediateField in
+theorem solution
+    (K : Type*) [Field K] [Algebra ℚ K]
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    (y : ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ Γ)))
+    (hy : (y : LaurentSeries K) = ModularCurve.jqModC K) :
+    Transcendental K y ∧
+      FiniteDimensional
+        ↥(IntermediateField.adjoin K ({y} : Set ↥(ModularCurve.laurentBaseChange K
+          (ModularCurve.qExpFunctionFieldC ℚ Γ))))
+        ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ Γ)) := by
+  classical
+  constructor
+  · have hinj : Function.Injective
+        (algebraMap ↥(laurentBaseChange K (qExpFunctionFieldC ℚ Γ)) (LaurentSeries K)) :=
+      (algebraMap ↥(laurentBaseChange K (qExpFunctionFieldC ℚ Γ)) (LaurentSeries K)).injective
+    rw [← transcendental_algebraMap_iff hinj]
+    change Transcendental K (y : LaurentSeries K)
+    rw [hy]
+    exact ModularCurve.transcendental_jqModC K
+  · have hEE : laurentBaseChange K (qExpFunctionFieldC ℚ Γ) = qExpFunctionFieldC K Γ :=
+      laurentBaseChange_qExpFunctionFieldC_eq K Γ
+    have hjE' : jqModC K ∈ laurentBaseChange K (qExpFunctionFieldC ℚ Γ) := hy ▸ y.2
+    have hjE : jqModC K ∈ qExpFunctionFieldC K Γ := hEE ▸ hjE'
+    obtain ⟨hfin, -⟩ :=
+      ModularCurve.finiteDimensional_and_finrank_adjoin_jqModC_qExpFunctionFieldC_le_index K
+      Γ hT Γ le_rfl (fun γ hγ => Or.inl hγ) ⟨jqModC K, hjE⟩ rfl
+    have := hfin
+    have hpos : 0 < Module.finrank
+        ↥(IntermediateField.adjoin K ({(⟨jqModC K, hjE⟩ : qExpFunctionFieldC K Γ)} : Set
+          (qExpFunctionFieldC K Γ)))
+        ↥(qExpFunctionFieldC K Γ) := Module.finrank_pos
+    have e1 := finrank_adjoin_eq_relfinrank (qExpFunctionFieldC K Γ) ⟨jqModC K, hjE⟩
+    have e2 := finrank_adjoin_eq_relfinrank (laurentBaseChange K (qExpFunctionFieldC ℚ Γ)) y
+    have e12 : (IntermediateField.adjoin K ({((⟨jqModC K, hjE⟩ : qExpFunctionFieldC K Γ) :
+      LaurentSeries K)} :
+          Set (LaurentSeries K))).relfinrank (qExpFunctionFieldC K Γ) =
+        (IntermediateField.adjoin K ({(y : LaurentSeries K)} : Set (LaurentSeries K))).relfinrank
+          (laurentBaseChange K (qExpFunctionFieldC ℚ Γ)) := by
+      rw [hy, hEE]
+    have hpos' : 0 < Module.finrank
+        ↥(IntermediateField.adjoin K ({y} : Set ↥(laurentBaseChange K (qExpFunctionFieldC ℚ Γ))))
+        ↥(laurentBaseChange K (qExpFunctionFieldC ℚ Γ)) :=
+      lt_of_lt_of_eq hpos ((e1.trans e12).trans e2.symm)
+    have : Module.Free
+        ↥(IntermediateField.adjoin K ({y} : Set ↥(laurentBaseChange K (qExpFunctionFieldC ℚ Γ))))
+        ↥(laurentBaseChange K (qExpFunctionFieldC ℚ Γ)) := Module.Free.of_divisionRing _ _
+    exact Module.finite_of_finrank_pos hpos'
+
+end S_OVERLONG_f6c119b3
+end P2MW
+export
+  P2MW.S_OVERLONG_f6c119b3
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open CongruenceSubgroup AlgebraicCurve
+open scoped MatrixGroups
+
+namespace ModularCurve
+
+theorem
+  transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC
+    (K : Type*) [Field K] [Algebra ℚ K]
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex] (hT : ModularGroup.T ∈ Γ)
+    (y : ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ Γ)))
+    (hy : (y : LaurentSeries K) = ModularCurve.jqModC K) :
+    Transcendental K y ∧
+      FiniteDimensional
+        ↥(IntermediateField.adjoin K ({y} : Set ↥(ModularCurve.laurentBaseChange K
+          (ModularCurve.qExpFunctionFieldC ℚ Γ))))
+        ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ Γ)) :=
+  solution K Γ hT y hy
+
+end ModularCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_transcendental_coeffEmb_jq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_transcendental_coeffEmb_jq.lean
new file mode 100644
index 0000000000..cae359d05a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_transcendental_coeffEmb_jq.lean
@@ -0,0 +1,342 @@
+/-
+Based on Prove2Me node ModularCurve.transcendental_coeffEmb_jq
+(e4976549-c26d-5fc7-8aba-41c0ae2c4c8b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 0b41c60f-705b-5a9d-b0e3-9d4859e93387
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QAdicPlace
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ModularUnit
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CuspidalClass
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_cuspInftyBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_order_coeffEmb
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coe_frickeInvolutionFull_modularUnitSeries
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_modularUnitSeries_mem_modularFunctionFieldFull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_adjoin_jq_modularUnitSeries
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_adjoin_jq_modularUnitSeries_inv
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_eq_zero_of_isIntegral_adjoin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_smul_of_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isIntegral_adjoin_map_algHom
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isIntegral_adjoin_of_isScalarTower
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isIntegral_adjoin_intermediateField_mk
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_iff_ord_nonneg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Pic0_zsmul_mk_eq_zero_of_isPrincipal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Pic0_addOrderOf_mk_dvd_of_isPrincipal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isFrickeAutFull_frickeInvolutionFull_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_eq_cuspInftyBar_or_eq_cuspZeroBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_injective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_cuspZeroBar_ne_cuspInftyBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeffEmb_jq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurentBaseChange_modularFunctionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_full_eq_of_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_modularPolynomialData_of_squarefree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_adjoin_jqNModC
+import Mathlib.Algebra.Algebra.Rat
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCusp_cuspZeroBar
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCusp_cuspInftyBar
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Transcendence of j in the base-changed modular function field
+
+Theorem statement: `ModularCurve.transcendental_coeffEmb_jq`
+(`e4976549-c26d-5fc7-8aba-41c0ae2c4c8b`), by Claude, 2026-09-05.
+
+Proof: submission `0b41c60f-705b-5a9d-b0e3-9d4859e93387`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field equipped with a $\mathbb{Q}$-algebra structure and let $N$ be a nonzero natural
+number. Write $jq \in \mathbb{Q}((q))$ for the Laurent series $q^{-1}\cdot jNumQ$, where $jNumQ$ is
+the power series `jNum` with its integer coefficients pushed to $\mathbb{Q}$; thus $jq$ is the
+$q$-expansion of the modular invariant $j$. Let `modularFunctionFieldFull N` be the intermediate
+field of $\mathbb{Q}((q))$ obtained by adjoining to $\mathbb{Q}$ the set of series
+$qExpand_{\mathbb{Q}}\, d\, jq$ for the nonzero divisors $d$ of $N$, and let `coeffEmb L` be the
+ring homomorphism $\mathbb{Q}((q)) \to L((q))$ applying the structure map $\mathbb{Q} \to L$ to each
+coefficient. Finally let `laurentBaseChange L (modularFunctionFieldFull N)` be the intermediate
+field of $L((q))$ generated over $L$ by the image under `coeffEmb L` of `modularFunctionFieldFull
+N`. The assertion is that the element of this intermediate field determined by
+$\mathrm{coeffEmb}_L(jq)$, which lies there because $jq$ belongs to `modularFunctionFieldFull N`, is
+transcendental over $L$: it satisfies no nonzero polynomial with coefficients in $L$.
+
+This records the classical transcendence of the $q$-expansion of $j$ over the field of constants,
+now for an arbitrary field $L$ of characteristic zero and after base change of the modular function
+field of level $N$ to $L((q))$. It supplies the transcendence hypothesis needed to treat the
+base-changed field as a function field of one variable over $L$, and is invoked throughout the
+analysis of places of the modular curve and of the fibres of its models, in particular for the
+places attached to $j$ and to $j_N$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_transcendental_coeffEmb_jq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_transcendental_coeffEmb_jq
+
+open ModularCurve AlgebraicCurve IntermediateField
+open scoped Pointwise
+
+noncomputable section
+
+namespace DivUSol
+
+local notation "𝕂" => AlgebraicClosure ℚ
+
+variable (ℓ : ℕ)
+
+section inf
+variable [NeZero ℓ]
+
+def ubar (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ) : modularFunctionFieldBar ℓ :=
+  ⟨coeffEmb 𝕂 (modularUnitSeries ℓ), coeffEmb_mem_laurentBaseChange 𝕂 hmem⟩
+
+theorem coe_ubar (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ) :
+    (ubar ℓ hmem : LaurentSeries 𝕂) = coeffEmb 𝕂 (modularUnitSeries ℓ) := rfl
+
+theorem coeffEmb_modularUnitSeries_ne_zero : coeffEmb 𝕂 (modularUnitSeries ℓ) ≠ 0 := by
+  intro h
+  exact modularUnitSeries_ne_zero ℓ (coeffEmb_injective 𝕂 (by rw [h, map_zero]))
+
+theorem ubar_ne_zero (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ) :
+    ubar ℓ hmem ≠ 0 := by
+  intro h
+  exact coeffEmb_modularUnitSeries_ne_zero ℓ (by rw [← coe_ubar ℓ hmem, h]; rfl)
+
+theorem ord_inf (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ) :
+    (cuspInftyBar ℓ).ord (ubar ℓ hmem) = 1 - (ℓ : ℤ) := by
+  rw [ord_cuspInftyBar, coe_ubar, order_coeffEmb, order_modularUnitSeries]
+
+end inf
+
+variable [Fact ℓ.Prime]
+
+theorem coeffEmb_smul (c : ℚ) (x : LaurentSeries ℚ) :
+    coeffEmb 𝕂 (c • x) = (c : 𝕂) • coeffEmb 𝕂 x := by
+  rw [← HahnSeries.C_mul_eq_smul, ← HahnSeries.C_mul_eq_smul, map_mul]
+  congr 1
+  ext k
+  simp
+
+theorem fricke_ubar (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ) :
+    ((frickeInvolutionBar ℓ (ubar ℓ hmem) : modularFunctionFieldBar ℓ) : LaurentSeries 𝕂) =
+      ((ℓ : 𝕂) ^ 12) • (coeffEmb 𝕂 (modularUnitSeries ℓ))⁻¹ := by
+  have h := coe_geomAut_coeffEmb 𝕂 (modularFunctionFieldFull ℓ) (frickeInvolutionFull ℓ)
+    ⟨modularUnitSeries ℓ, hmem⟩
+  rw [coe_frickeInvolutionFull_modularUnitSeries ℓ hmem, coeffEmb_smul, map_inv₀] at h
+  rw [frickeInvolutionBar_def]
+  push_cast at h
+  exact h
+
+theorem fricke_ubar_elt (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ) :
+    frickeInvolutionBar ℓ (ubar ℓ hmem) =
+      algebraMap 𝕂 (modularFunctionFieldBar ℓ) ((ℓ : 𝕂) ^ 12) * (ubar ℓ hmem)⁻¹ := by
+  apply Subtype.ext
+  rw [fricke_ubar, ← HahnSeries.C_mul_eq_smul, HahnSeries.C_eq_algebraMap]
+  simp [coe_ubar]
+
+theorem ell_pow_ne_zero : ((ℓ : 𝕂) ^ 12) ≠ 0 :=
+  pow_ne_zero _ (Nat.cast_ne_zero.mpr (NeZero.ne ℓ))
+
+theorem fricke_symm_ubar (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ) :
+    (frickeInvolutionBar ℓ).symm (ubar ℓ hmem) = ((((ℓ : 𝕂) ^ 12))⁻¹ • ubar ℓ hmem)⁻¹ := by
+  apply (frickeInvolutionBar ℓ).injective
+  rw [AlgEquiv.apply_symm_apply, map_inv₀, Algebra.smul_def, map_mul, AlgEquiv.commutes,
+    fricke_ubar_elt,
+    ← mul_assoc, ← map_mul, inv_mul_cancel₀ (ell_pow_ne_zero ℓ), map_one, one_mul, inv_inv]
+
+theorem ord_zero (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ) :
+    (cuspZeroBar ℓ).ord (ubar ℓ hmem) = (ℓ : ℤ) - 1 := by
+  have key : (frickeInvolutionBar ℓ • cuspInftyBar ℓ).ord (ubar ℓ hmem) =
+      (cuspInftyBar ℓ).ord ((frickeInvolutionBar ℓ).symm (ubar ℓ hmem)) := by
+    conv_lhs => rw [← (frickeInvolutionBar ℓ).apply_symm_apply (ubar ℓ hmem)]
+    exact Place.ord_smul _ _ _
+  rw [cuspZeroBar_def, key, fricke_symm_ubar, Place.ord_inv,
+    Place.ord_smul_of_ne_zero _ (inv_ne_zero (ell_pow_ne_zero ℓ)), ord_inf]
+  ring
+
+def jb :
+    modularFunctionFieldBar ℓ := ⟨coeffEmb 𝕂 jq, coeffEmb_mem_laurentBaseChange 𝕂 (jq_mem_full ℓ)⟩
+
+theorem coe_jb : (jb ℓ : LaurentSeries 𝕂) = coeffEmb 𝕂 jq := rfl
+
+theorem isCusp_inf : IsCusp (jb ℓ) (cuspInftyBar ℓ) := isCusp_cuspInftyBar ℓ
+
+theorem isCusp_zero : IsCusp (jb ℓ) (cuspZeroBar ℓ) :=
+  isCusp_cuspZeroBar ℓ (isFrickeAutFull_frickeInvolutionFull_prime ℓ)
+
+def coeffEmbₐ : LaurentSeries ℚ →ₐ[ℚ] LaurentSeries 𝕂 := (coeffEmb 𝕂).toRatAlgHom
+
+theorem coeffEmbₐ_apply (x : LaurentSeries ℚ) : coeffEmbₐ x = coeffEmb 𝕂 x := rfl
+
+theorem isScalarTower_rat :
+    @IsScalarTower ℚ 𝕂 (LaurentSeries 𝕂) Algebra.toSMul Algebra.toSMul Algebra.toSMul :=
+  IsScalarTower.of_algebraMap_eq fun r =>
+    RingHom.congr_fun (Subsingleton.elim (algebraMap ℚ (LaurentSeries 𝕂))
+      ((algebraMap 𝕂 (LaurentSeries 𝕂)).comp (algebraMap ℚ 𝕂))) r
+
+attribute [local instance] isScalarTower_rat
+
+theorem isIntegral_ubar (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ) :
+    IsIntegral (Algebra.adjoin 𝕂 {jb ℓ}) (ubar ℓ hmem) := by
+  have h1 := isIntegral_adjoin_map_algHom coeffEmbₐ (isIntegral_adjoin_jq_modularUnitSeries ℓ)
+  rw [coeffEmbₐ_apply, coeffEmbₐ_apply] at h1
+  have h2 := isIntegral_adjoin_of_isScalarTower (L := 𝕂) h1
+  exact isIntegral_adjoin_intermediateField_mk (modularFunctionFieldBar ℓ) _ _ h2
+
+theorem isIntegral_ubar_inv (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ) :
+    IsIntegral (Algebra.adjoin 𝕂 {jb ℓ}) (ubar ℓ hmem)⁻¹ := by
+  have h1 := isIntegral_adjoin_map_algHom coeffEmbₐ (isIntegral_adjoin_jq_modularUnitSeries_inv ℓ)
+  rw [coeffEmbₐ_apply, coeffEmbₐ_apply, map_inv₀] at h1
+  have h2 := isIntegral_adjoin_of_isScalarTower (L := 𝕂) h1
+  have hxi : (coeffEmb 𝕂 (modularUnitSeries ℓ))⁻¹ ∈ modularFunctionFieldBar ℓ :=
+    inv_mem (coeffEmb_mem_laurentBaseChange 𝕂 hmem)
+  have h3 := isIntegral_adjoin_intermediateField_mk (modularFunctionFieldBar ℓ) (jb ℓ).2 hxi h2
+  have e : (⟨(coeffEmb 𝕂 (modularUnitSeries ℓ))⁻¹, hxi⟩ : modularFunctionFieldBar ℓ) = (ubar ℓ
+    hmem)⁻¹ :=
+    Subtype.ext rfl
+  rw [e] at h3
+  exact h3
+
+theorem ord_of_not_isCusp (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ)
+    (w : Place 𝕂 (modularFunctionFieldBar ℓ)) (hw : ¬ IsCusp (jb ℓ) w)
+    : w.ord (ubar ℓ hmem) = 0 := by
+  rw [isCusp_iff, not_not] at hw
+  exact Place.ord_eq_zero_of_isIntegral_adjoin w hw (isIntegral_ubar ℓ hmem) (isIntegral_ubar_inv ℓ
+    hmem)
+
+theorem smul_cuspidalDivisor_apply (hmem : modularUnitSeries ℓ ∈ modularFunctionFieldFull ℓ)
+    (v : Place 𝕂 (modularFunctionFieldBar ℓ)) :
+    (((ℓ : ℤ) - 1) • cuspidalDivisor ℓ) v = v.ord (ubar ℓ hmem) := by
+  classical
+  have hℓ : ℓ.Prime := Fact.out
+  have hne : cuspZeroBar ℓ ≠ cuspInftyBar ℓ :=
+    cuspZeroBar_ne_cuspInftyBar ℓ (isFrickeAutFull_frickeInvolutionFull_prime ℓ) hℓ.one_lt
+  simp only [cuspidalDivisor_def, Finsupp.smul_apply, Finsupp.sub_apply, Finsupp.single_apply,
+    smul_eq_mul]
+  by_cases hc : IsCusp (jb ℓ) v
+  · rcases eq_cuspInftyBar_or_eq_cuspZeroBar ℓ v hc with rfl | rfl
+    · rw [ite_eq_right hne, ite_eq_left rfl, ord_inf]; ring
+    · rw [ite_eq_left rfl, ite_eq_right hne.symm, ord_zero]; ring
+  · have h1 : cuspZeroBar ℓ ≠ v := fun h => hc (h ▸ isCusp_zero ℓ)
+    have h2 : cuspInftyBar ℓ ≠ v := fun h => hc (h ▸ isCusp_inf ℓ)
+    rw [ite_eq_right h1, ite_eq_right h2, ord_of_not_isCusp ℓ hmem v hc]; ring
+
+theorem isPrincipal_smul_cuspidalDivisor :
+    Divisor.IsPrincipal (((ℓ : ℤ) - 1) • cuspidalDivisor ℓ) :=
+  ⟨ubar ℓ (modularUnitSeries_mem_modularFunctionFieldFull ℓ), ubar_ne_zero ℓ _,
+    smul_cuspidalDivisor_apply ℓ _⟩
+
+theorem smul_cuspidalClass_eq_zero : ((ℓ : ℤ) - 1) • cuspidalClass ℓ = 0 := by
+  rw [cuspidalClass_def]
+  exact Pic0.zsmul_mk_eq_zero_of_isPrincipal _ _
+    (by rw [coe_cuspidalDivisor₀]; exact isPrincipal_smul_cuspidalDivisor ℓ)
+
+theorem addOrderOf_cuspidalClass_dvd : addOrderOf (cuspidalClass ℓ) ∣ ℓ - 1 := by
+  have hℓ : ℓ.Prime := Fact.out
+  rw [cuspidalClass_def]
+  refine Pic0.addOrderOf_mk_dvd_of_isPrincipal _ _ ?_
+  rw [coe_cuspidalDivisor₀, ← natCast_zsmul, Nat.cast_sub hℓ.one_le, Nat.cast_one]
+  exact isPrincipal_smul_cuspidalDivisor ℓ
+
+theorem bar_eq_restrictScalars :
+    modularFunctionFieldBar ℓ =
+      (IntermediateField.adjoin (IntermediateField.adjoin 𝕂 ({jqModC 𝕂} : Set (LaurentSeries 𝕂)))
+        ({jqNModC 𝕂 ℓ} : Set (LaurentSeries 𝕂))).restrictScalars 𝕂 := by
+  have hℓ : ℓ.Prime := Fact.out
+  change laurentBaseChange 𝕂 (modularFunctionFieldFull ℓ) = _
+  rw [full_eq_of_prime hℓ, laurentBaseChange_modularFunctionField]
+  exact (adjoin_simple_adjoin_simple 𝕂 (jqModC 𝕂) (jqNModC 𝕂 ℓ)).symm
+
+theorem mem_bar_iff (x : LaurentSeries 𝕂) :
+    x ∈ modularFunctionFieldBar ℓ ↔ x ∈ 𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯ := by
+  rw [bar_eq_restrictScalars ℓ, mem_restrictScalars]
+
+def jTr : (𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯) ≃+* modularFunctionFieldBar ℓ where
+  toFun x := ⟨x, (mem_bar_iff ℓ _).mpr x.2⟩
+  invFun y := ⟨y, (mem_bar_iff ℓ _).mp y.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  map_mul' _ _ := rfl
+  map_add' _ _ := rfl
+
+theorem coe_jTr (x : 𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯) :
+    ((jTr ℓ x : modularFunctionFieldBar ℓ) : LaurentSeries 𝕂) = x := by
+  ext; rfl
+
+def e₁ : (𝕂⟮jb ℓ⟯ : IntermediateField 𝕂 (modularFunctionFieldBar ℓ)) ≃ₐ[𝕂] 𝕂⟮jqModC 𝕂⟯ :=
+  (liftAlgEquiv 𝕂⟮jb ℓ⟯).trans (equivOfEq (by rw [lift_adjoin_simple, coe_jb, coeffEmb_jq]))
+
+theorem coe_e₁ (x : (𝕂⟮jb ℓ⟯ : IntermediateField 𝕂 (modularFunctionFieldBar ℓ))) :
+    ((e₁ ℓ x : 𝕂⟮jqModC 𝕂⟯) : LaurentSeries 𝕂) = ((x : modularFunctionFieldBar ℓ) : LaurentSeries 𝕂)
+      := by
+  ext; rfl
+
+theorem compat :
+    (algebraMap (𝕂⟮jb ℓ⟯ : IntermediateField 𝕂 (modularFunctionFieldBar ℓ)) (modularFunctionFieldBar
+      ℓ)).comp
+        (e₁ ℓ).symm.toRingEquiv.toRingHom =
+      (jTr ℓ).toRingHom.comp (algebraMap (𝕂⟮jqModC 𝕂⟯) (𝕂⟮jqModC 𝕂⟯⟮jqNModC 𝕂 ℓ⟯)) := by
+  ext; rfl
+
+theorem finiteDimensional_adjoin_jb :
+    FiniteDimensional (IntermediateField.adjoin 𝕂 ({jb ℓ} : Set (modularFunctionFieldBar ℓ)))
+      (modularFunctionFieldBar ℓ) := by
+  have hℓ : ℓ.Prime := Fact.out
+  obtain ⟨data⟩ := nonempty_modularPolynomialData_of_squarefree ℓ hℓ.squarefree hℓ.one_lt
+  have := finiteDimensional_adjoin_jqNModC 𝕂 data
+  exact Module.Finite.of_equiv_equiv (e₁ ℓ).symm.toRingEquiv (jTr ℓ) (compat ℓ)
+
+end DivUSol
+
+namespace BridgeSol
+
+theorem transcendental_coeffEmb_jq (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    Transcendental L (⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩ :
+      laurentBaseChange L (modularFunctionFieldFull N)) := by
+  intro h
+  apply transcendental_jqModC L
+  rw [← coeffEmb_jq]
+  exact h.algebraMap (A := LaurentSeries L)
+
+end BridgeSol
+
+end
+
+open ModularCurve AlgebraicCurve in
+theorem solution (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ) [NeZero N] :
+    Transcendental L (⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩ :
+      laurentBaseChange L (modularFunctionFieldFull N)) :=
+  BridgeSol.transcendental_coeffEmb_jq L N
+
+end S_ModularCurve_transcendental_coeffEmb_jq
+end P2MW
+export P2MW.S_ModularCurve_transcendental_coeffEmb_jq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.transcendental_coeffEmb_jq (L : Type*) [Field L] [Algebra ℚ L] (N : ℕ)
+    [NeZero N] :
+    Transcendental L (⟨coeffEmb L jq, coeffEmb_mem_laurentBaseChange L (jq_mem_full N)⟩ :
+      laurentBaseChange L (modularFunctionFieldFull N)) :=
+  solution L N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_transcendental_jq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_transcendental_jq.lean
new file mode 100644
index 0000000000..99507e7691
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_transcendental_jq.lean
@@ -0,0 +1,85 @@
+/-
+Based on Prove2Me node ModularCurve.transcendental_jq
+(39f04249-53e5-5935-83cd-a208f4acfafa) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3941aa83-1eb9-56a4-b9b3-5023ee22452b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_aeval_jq_eq_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Transcendence of the q-expansion j(q) over ℚ
+
+Theorem statement: `ModularCurve.transcendental_jq` (`39f04249-53e5-5935-83cd-a208f4acfafa`), by
+Claude, 2026-09-05.
+
+Proof: submission `3941aa83-1eb9-56a4-b9b3-5023ee22452b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+The statement concerns the element `jq` of the field of formal Laurent series $\mathbb{Q}((q))$,
+realised as the Hahn series field `LaurentSeries ℚ` over the value group $\mathbb{Z}$: by definition
+`jq` is the product of the Hahn series `HahnSeries.single (-1) 1`, i.e. the monomial $q^{-1}$, with
+the image under `HahnSeries.ofPowerSeries` of `jNumQ`, the power series obtained from the integral
+power series `jNum` by applying the coefficientwise ring homomorphism $\mathbb{Z} \to \mathbb{Q}$.
+Thus `jq` is $q^{-1}$ times a power series with rational (indeed integral) coefficients, the
+$q$-expansion of the modular invariant. There are no variables and no hypotheses. The conclusion is
+that `jq` is transcendental over $\mathbb{Q}$ with respect to the $\mathbb{Q}$-algebra structure on
+`LaurentSeries ℚ`: `jq` is not algebraic over $\mathbb{Q}$, equivalently no nonzero polynomial in
+$\mathbb{Q}[X]$ annihilates it under evaluation at `jq`. In particular the $\mathbb{Q}$-subalgebra
+generated by `jq` inside $\mathbb{Q}((q))$ is a polynomial ring, and the subfield it generates is a
+rational function field in one variable.
+
+This is the transcendence fact underlying the identification of $\mathbb{Q}(j(q)) \subseteq
+\mathbb{Q}((q))$ with the function field of $X(1) \cong \mathbb{P}^1_{\mathbb{Q}}$, and hence the
+starting point for the description of the function fields $\mathbb{Q}(j(q), j(q^N))$ attached to
+$X_0(N)$. It is used throughout the curve layer of the algebraic $X_0(N)$ development, for instance
+in the constructions of fibre models and charts at cusps and in the finiteness and degree
+computations for the associated models.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_transcendental_jq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_transcendental_jq
+
+open ModularCurve IntermediateField
+
+noncomputable section
+
+theorem solution : Transcendental ℚ jq :=
+  transcendental_iff.mpr fun _ hp => ModularCurve.aeval_jq_eq_zero hp
+
+end
+
+end S_ModularCurve_transcendental_jq
+end P2MW
+export P2MW.S_ModularCurve_transcendental_jq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve IntermediateField
+theorem ModularCurve.transcendental_jq :
+    Transcendental ℚ jq :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_transcendental_jqModC.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_transcendental_jqModC.lean
new file mode 100644
index 0000000000..2f6196e0e0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_transcendental_jqModC.lean
@@ -0,0 +1,165 @@
+/-
+Based on Prove2Me node ModularCurve.transcendental_jqModC
+(ea2ce9fb-744f-5e69-93fc-a5debf04eab1) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ea2dd952-adf4-5186-ab7c-03ff62ff75e1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+
+import Mathlib.RingTheory.Algebraic.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Transcendence of the q-expansion of j over any coefficient ring
+
+Theorem statement: `ModularCurve.transcendental_jqModC` (`ea2ce9fb-744f-5e69-93fc-a5debf04eab1`), by
+Claude, 2026-09-05.
+
+Proof: submission `ea2dd952-adf4-5186-ab7c-03ff62ff75e1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a commutative ring. Consider the Laurent series $\bar j =$ `jqModC K` $\in K((q)) =$
+`LaurentSeries K` $=$ `HahnSeries ℤ K`, defined as the product of the Hahn series `HahnSeries.single
+(-1) 1` (the monomial $q^{-1}$) with the image under `HahnSeries.ofPowerSeries` of the power series
+obtained from the integral series `jNum` $=$ `eisenstein4 ^ 3 * dedekindEtaUnitInv` by applying the
+coefficientwise map $\mathbb{Z} \to K$. The theorem asserts that $\bar j$ is transcendental over
+$K$, with respect to the canonical $K$-algebra structure on $K((q))$: `Transcendental K (jqModC K)`,
+that is, $\bar j$ is not algebraic over $K$, equivalently the only polynomial $p \in K[X]$ with
+$p(\bar j) = 0$ (evaluation via `Polynomial.aeval`) is $p = 0$. No hypotheses beyond commutativity
+of $K$ are imposed; in particular $K$ is not assumed to be a field, a domain, nontrivial, or of any
+particular characteristic (for the trivial ring the assertion holds because $K[X]$ is then the zero
+ring).
+
+This is the standard statement that the $q$-expansion $q^{-1} + 744 + \cdots$ of the modular
+invariant $j$ satisfies no algebraic relation over its ring of coefficients, so that $K(\bar j)$
+sits inside $K((q))$ as a rational function field in any characteristic. It underlies the
+construction of models of modular curves and of the $q$-expansion formalism used throughout, and is
+cited very widely in the development, for instance by the results comparing $q$-expansions of cusp
+forms and mod $p$ forms with power series on cusp charts.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_transcendental_jqModC.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_transcendental_jqModC
+
+noncomputable section
+open HahnSeries
+
+namespace ModularCurve
+p2m_export "ModularCurve" "jqModC jNum constantCoeff_jNum ofPowerSeries_coeff_of_neg jq_pow"
+p2m_open "ModularCurve"
+namespace CharLRows
+
+variable (K : Type*) [CommRing K]
+
+theorem jqModC_pow (n : ℕ) :
+    (jqModC K) ^ n = HahnSeries.single (-(n : ℤ)) 1 *
+      HahnSeries.ofPowerSeries ℤ K ((jNum.map (Int.castRingHom K)) ^ n) := by
+  have h : n • (-1 : ℤ) = -(n : ℤ) := by simp
+  rw [jqModC, mul_pow, HahnSeries.single_pow, one_pow, h, ← map_pow]
+
+theorem constantCoeff_jNum_map : PowerSeries.constantCoeff (jNum.map (Int.castRingHom K)) = 1 := by
+  rw [← PowerSeries.coeff_zero_eq_constantCoeff, PowerSeries.coeff_map,
+    PowerSeries.coeff_zero_eq_constantCoeff,
+    constantCoeff_jNum, map_one]
+
+theorem coeff_jqModC_pow_self (n : ℕ) : ((jqModC K) ^ n).coeff (-(n : ℤ)) = 1 := by
+  rw [jqModC_pow, HahnSeries.coeff_single_mul, one_mul, sub_neg_eq_add, neg_add_cancel,
+    show (0 : ℤ) = ((0 : ℕ) : ℤ) from rfl, HahnSeries.ofPowerSeries_apply_coeff,
+    PowerSeries.coeff_zero_eq_constantCoeff, map_pow, constantCoeff_jNum_map, one_pow]
+
+theorem coeff_jqModC_pow_of_lt {n : ℕ} {m : ℤ} (hm : m < -(n : ℤ)) :
+    ((jqModC K) ^ n).coeff m = 0 := by
+  rw [jqModC_pow, HahnSeries.coeff_single_mul, one_mul]
+  exact ofPowerSeries_coeff_of_neg _ (by omega)
+
+theorem coeff_jqModC_neg_one : (jqModC K).coeff (-1 : ℤ) = 1 := by
+  simpa using coeff_jqModC_pow_self K 1
+
+theorem algebraMap_laurentSeries_eq_single (c : K) :
+    algebraMap K (LaurentSeries K) c = HahnSeries.single 0 c := by
+  have h1 : algebraMap K (PowerSeries K) c = PowerSeries.C c := by simp
+  rw [HahnSeries.algebraMap_apply', h1, HahnSeries.ofPowerSeries_C]
+  rfl
+
+theorem aeval_jqModC_eq_zero {p : Polynomial K} (hp : Polynomial.aeval (jqModC K) p = 0) :
+    p = 0 := by
+  by_contra hp0
+  set n := p.natDegree with hn
+  have hcoeff : (Polynomial.aeval (jqModC K) p).coeff (-(n : ℤ)) = p.coeff n := by
+    rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range, HahnSeries.coeff_sum,
+      Finset.sum_eq_single n]
+    · rw [algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_zero_mul,
+        coeff_jqModC_pow_self, mul_one]
+    · intro i hi hin
+      have hilt : i < n := lt_of_le_of_ne (Nat.lt_succ_iff.mp (Finset.mem_range.mp hi)) hin
+      rw [algebraMap_laurentSeries_eq_single, HahnSeries.coeff_single_zero_mul,
+        coeff_jqModC_pow_of_lt, mul_zero]
+      omega
+    · intro hn'
+      exact absurd (Finset.self_mem_range_succ n) hn'
+  rw [hp] at hcoeff
+  simp only [HahnSeries.coeff_zero] at hcoeff
+  exact hp0 (Polynomial.leadingCoeff_eq_zero.mp hcoeff.symm)
+
+theorem transcendental_jqModC : Transcendental K (jqModC K) :=
+  transcendental_iff.mpr fun _ hp => aeval_jqModC_eq_zero K hp
+
+theorem jqModC_ne_zero [Nontrivial K] : jqModC K ≠ 0 := by
+  intro h
+  have h1 : (jqModC K).coeff (-1 : ℤ) = 1 := coeff_jqModC_neg_one K
+  rw [h, HahnSeries.coeff_zero] at h1
+  exact zero_ne_one h1
+
+theorem order_jqModC [Nontrivial K] : (jqModC K).order = -1 := by
+  refine le_antisymm (HahnSeries.order_le_of_coeff_ne_zero ?_) ?_
+  · rw [coeff_jqModC_neg_one]
+    exact one_ne_zero
+  · by_contra hlt
+    rw [not_le] at hlt
+    refine HahnSeries.coeff_order_eq_zero.not.mpr (jqModC_ne_zero K) ?_
+    have h := coeff_jqModC_pow_of_lt K (n := 1) (m := (jqModC K).order)
+      (by simpa using hlt)
+    simpa using h
+
+end CharLRows
+
+end ModularCurve
+end
+
+open _root_.ModularCurve _root_.P2MW.S_ModularCurve_transcendental_jqModC.ModularCurve in
+theorem solution (K : Type*) [CommRing K] :
+    Transcendental K (jqModC K) :=
+  CharLRows.transcendental_jqModC K
+
+end S_ModularCurve_transcendental_jqModC
+end P2MW
+export P2MW.S_ModularCurve_transcendental_jqModC (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.transcendental_jqModC (K : Type*) [CommRing K] :
+    Transcendental K (jqModC K) :=
+  solution K
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_transcendental_of_coe_eq_coeffEmb_jq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_transcendental_of_coe_eq_coeffEmb_jq.lean
new file mode 100644
index 0000000000..3e1e1784a9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_transcendental_of_coe_eq_coeffEmb_jq.lean
@@ -0,0 +1,136 @@
+/-
+Based on Prove2Me node ModularCurve.transcendental_of_coe_eq_coeffEmb_jq
+(b411998e-0d6c-507f-aebb-9320ce54e546) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7e14a216-4743-5440-aa50-f7cbba85e91c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_LaurentCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_AtkinLehner
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Transcendence of j over the base domain A
+
+Theorem statement: `ModularCurve.transcendental_of_coe_eq_coeffEmb_jq`
+(`b411998e-0d6c-507f-aebb-9320ce54e546`), by Claude, 2026-09-05.
+
+Proof: submission `7e14a216-4743-5440-aa50-f7cbba85e91c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field of characteristic zero, let $K$ be an intermediate field of the field of formal
+Laurent series $L((q))$ over $L$, and let $A$ be a commutative domain equipped with an algebra
+structure over which $L$ is the fraction field of $A$, together with an $A$-algebra structure on $K$
+making $A \to L \to K$ a tower of scalars. Let $j$ be an element of $K$ whose image in $L((q))$ is
+the coefficientwise image, under the ring map $\mathrm{LaurentSeries}\,\mathbb{Q} \to
+\mathrm{LaurentSeries}\,L$ induced by $\mathbb{Q} \to L$ applied termwise, of the Laurent series
+[`ModularCurve.jq`](def/ModularCurve_X0.html#L157), namely the product of the monomial $q^{-1}$ (the
+Hahn series with single coefficient $1$ in degree $-1$) with the power series `jNumQ`, the image
+over $\mathbb{Q}$ of the integral power series `jNum`. The conclusion is that $j$ is transcendental
+over $A$: it is not a root of any nonzero polynomial with coefficients in $A$.
+
+This records that the $j$-invariant, presented as an element of a subfield of $L((q))$ with
+$q$-expansion $q^{-1}+744+196884q+\cdots$, is transcendental over any domain $A$ whose fraction
+field is $L$. It supplies the transcendence hypothesis used throughout the construction of the
+modular curve models over such base rings, and is cited by a large number of statements in that
+development.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_transcendental_of_coe_eq_coeffEmb_jq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_transcendental_of_coe_eq_coeffEmb_jq
+
+namespace LaurentSeries
+p2m_open "LaurentSeries"
+
+open Polynomial in
+theorem transcendental_of_order_ne_zero {L : Type*} [Field L] (x : LaurentSeries L)
+    (hx : x.order ≠ 0) :
+    Transcendental L x := by
+  classical
+  have hx0 : x ≠ 0 := fun h => hx (by rw [h, HahnSeries.order_zero])
+  rintro ⟨p, hp0, hpx⟩
+  obtain ⟨i₀, hi₀, hmin⟩ :=
+    p.support.exists_min_image (fun i : ℕ => (i : ℤ) * x.order) (Polynomial.support_nonempty.mpr
+      hp0)
+  have hord : ∀ i : ℕ, (x ^ i).order = (i : ℤ) * x.order := fun i => by
+    rw [HahnSeries.order_pow, nsmul_eq_mul]
+  have hinj : ∀ i : ℕ, (i : ℤ) * x.order = (i₀ : ℤ) * x.order → i = i₀ := fun i h => by
+    exact_mod_cast mul_right_cancel₀ hx h
+  have hterm : ∀ i ∈ Finset.range (p.natDegree + 1), i ≠ i₀ →
+      (p.coeff i • x ^ i).coeff ((i₀ : ℤ) * x.order) = 0 := by
+    intro i _ hne
+    by_cases hci : p.coeff i = 0
+    · rw [hci, zero_smul, HahnSeries.coeff_zero]
+    · rw [HahnSeries.coeff_smul, HahnSeries.coeff_eq_zero_of_lt_order, smul_zero]
+      rw [hord]
+      exact lt_of_le_of_ne (hmin i (Polynomial.mem_support_iff.mpr hci)) (fun h => hne (hinj i
+        h.symm))
+  have halg : ∀ c : L, algebraMap L (LaurentSeries L) c = HahnSeries.C c := fun c => by
+    rw [HahnSeries.algebraMap_apply', ← PowerSeries.C_eq_algebraMap]
+    exact PowerSeries.coe_C c
+  rw [aeval_eq_sum_range] at hpx
+  simp_rw [Algebra.smul_def, halg, HahnSeries.C_mul_eq_smul] at hpx
+  have hc := congrArg (fun y : LaurentSeries L => y.coeff ((i₀ : ℤ) * x.order)) hpx
+  simp only [HahnSeries.coeff_sum, HahnSeries.coeff_zero] at hc
+  rw [Finset.sum_eq_single i₀ hterm (fun h => absurd (Polynomial.supp_subset_range_natDegree_succ
+    hi₀) h),
+    HahnSeries.coeff_smul, smul_eq_mul] at hc
+  have hlead : (x ^ i₀).coeff ((i₀ : ℤ) * x.order) ≠ 0 := by
+    rw [← hord]
+    exact HahnSeries.coeff_order_eq_zero.not.mpr (pow_ne_zero _ hx0)
+  exact hlead ((mul_eq_zero.mp hc).resolve_left (Polynomial.mem_support_iff.mp hi₀))
+
+end LaurentSeries
+
+theorem solution
+    (L : Type) [Field L] [CharZero L]
+    (K : IntermediateField L (LaurentSeries L))
+    (A : Type) [CommRing A] [IsDomain A] [Algebra A L] [IsFractionRing A L]
+    [Algebra A ↥K] [IsScalarTower A L ↥K]
+    (j : ↥K) (hj : ((j : LaurentSeries L)) = ModularCurve.coeffEmb L ModularCurve.jq) :
+    Transcendental A j := by
+  have h1 : Transcendental L ((j : LaurentSeries L)) := by
+    apply LaurentSeries.transcendental_of_order_ne_zero
+    rw [hj, ModularCurve.order_coeffEmb_jq]
+    decide
+  have h2 : Transcendental L j := fun halg => h1 (halg.algHom K.val)
+  exact fun halg => h2 (halg.extendScalars (IsFractionRing.injective A L))
+
+end S_ModularCurve_transcendental_of_coe_eq_coeffEmb_jq
+end P2MW
+export P2MW.S_ModularCurve_transcendental_of_coe_eq_coeffEmb_jq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem ModularCurve.transcendental_of_coe_eq_coeffEmb_jq
+    (L : Type) [Field L] [CharZero L]
+    (K : IntermediateField L (LaurentSeries L))
+    (A : Type) [CommRing A] [IsDomain A] [Algebra A L] [IsFractionRing A L]
+    [Algebra A ↥K] [IsScalarTower A L ↥K]
+    (j : ↥K) (hj : ((j : LaurentSeries L)) = ModularCurve.coeffEmb L ModularCurve.jq) :
+    Transcendental A j :=
+  solution L K A j hj
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_twelve_mul_add_mul_index_le_finrank_cuspForm_Gamma.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_twelve_mul_add_mul_index_le_finrank_cuspForm_Gamma.lean
new file mode 100644
index 0000000000..4be7ccf8ca
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_twelve_mul_add_mul_index_le_finrank_cuspForm_Gamma.lean
@@ -0,0 +1,229 @@
+/-
+Based on Prove2Me node ModularCurve.twelve_mul_add_mul_index_le_finrank_cuspForm_Gamma
+(f14d540e-b44b-5123-bac3-0fa7dbca0c7c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7822693f-5d9a-5f3b-b197-3a40faae9ac8
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.FieldTheory.RatFunc.IntermediateField
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_constantsAreBase_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_dCoordGenerates_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_essFiniteType_of_transcendental_of_finiteDimensional
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_separating_transcendental_of_perfectField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finite_and_finrank_regularDifferentials_eq_genus
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_genus_eq_genusFF
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_hasCanonicalDivisor_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_ratFunc
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_stichtenothGenusExists_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_weilDualityAdelic_of_functionFieldRiemannRoch_of_stichtenothGenusExists
+import LeanPool.FLTEichlerShimura.Theorems.Thm_CuspForm_finiteDimensional_of_isArithmetic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_linearMap_regularDifferentials_cuspForm_injective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_exists_monoidHom_algEquiv_fixedField_eq_adjoin
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_LevelN_twelve_mul_add_mul_index_le_genusFF
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelN_structure_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Genus bound for dim_ℂ S₂(Γ(N))
+
+Theorem statement: `ModularCurve.twelve_mul_add_mul_index_le_finrank_cuspForm_Gamma`
+(`f14d540e-b44b-5123-bac3-0fa7dbca0c7c`), by Claude, 2026-09-05.
+
+Proof: submission `7822693f-5d9a-5f3b-b197-3a40faae9ac8`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number with $2 \le N$, let $\Gamma(N) \le \mathrm{SL}_2(\mathbb Z)$ be the
+principal congruence subgroup of level $N$, and let $\mu_N$ denote the index in
+$\mathrm{SL}_2(\mathbb Z)$ of the subgroup generated by $\Gamma(N)$ together with $-I$ (formally,
+the index of the join of $\Gamma(N)$ and the subgroup of integer powers of $-I$). Write
+$S_2(\Gamma(N))$ for the complex vector space of weight-$2$ cusp forms for $\Gamma(N)$ and
+$\dim_{\mathbb C} S_2(\Gamma(N))$ for its rank as a $\mathbb C$-module. The assertion is the
+inequality of natural numbers
+$$12N + N\mu_N \;\le\; 12N \cdot \dim_{\mathbb C} S_2(\Gamma(N)) + 6\mu_N .$$
+All arithmetic takes place in $\mathbb N$, so the statement is a cleared-denominator form of the
+lower bound $\dim_{\mathbb C} S_2(\Gamma(N)) \ge 1 + \mu_N(N-6)/(12N)$, the right-hand side being
+the genus of $X(N)$. Only this one inequality is asserted: no upper bound on $\dim_{\mathbb C}
+S_2(\Gamma(N))$, and no identification of the dimension with the genus, is part of the conclusion.
+
+This is the existence (lower bound) half of the classical identity $\dim_{\mathbb C} S_2(\Gamma(N))
+= g(X(N))$, in the cleared-denominator shape in which the genus of $X(N)$ is computed from the index
+$\mu_N$. It is used in
+[`ModularCurve.finrank_parabolicHoms_Gamma_le_two_mul_finrank_cuspForm`]
+(thm.html#ModularCurve.finrank_parabolicHoms_Gamma_le_two_mul_finrank_cuspForm),
+and thence in the Eichler–Shimura comparison between parabolic cohomology of congruence subgroups
+and weight-$2$ cusp forms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_twelve_mul_add_mul_index_le_finrank_cuspForm_Gamma.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_twelve_mul_add_mul_index_le_finrank_cuspForm_Gamma
+
+
+open scoped MatrixGroups IntermediateField
+
+namespace ModularCurve
+p2m_export "ModularCurve" "LevelN.ring LevelN.exists_monoidHom_algEquiv_fixedField_eq_adjoin \
+  LevelN.twelve_mul_add_mul_index_le_genusFF \
+  LevelN.exists_linearMap_regularDifferentials_cuspForm_injective"
+namespace GenusBoundAssembly
+p2m_open "ModularCurve"
+
+open AlgebraicCurve ModularCurve.LevelN
+
+section Bridge
+
+variable {K F : Type*} [Field K] [IsAlgClosed K] [Field F] [Algebra K F]
+
+theorem curve_package {x : F} (htr : Transcendental K x)
+    (hfd : FiniteDimensional (IntermediateField.adjoin K ({x} : Set F)) F) :
+    ∃ (_ : IsCurveOver K F) (_ : Algebra.EssFiniteType K F)
+      (_ : ∀ w : Place K F, w.DCoordGenerates),
+      Module.Finite K ↥(regularDifferentials K F) ∧
+        genusFF K F = Module.finrank K ↥(regularDifferentials K F) := by
+  classical
+  obtain ⟨t, ht, htfd, htsep⟩ :=
+    AlgebraicCurve.exists_separating_transcendental_of_perfectField htr hfd
+  have := htfd
+  have := htsep
+  have hC1 : IsCurveOver K F := isCurveOver_of_transcendental ht htfd htsep
+  have hC2 : Algebra.EssFiniteType K F :=
+    essFiniteType_of_transcendental_of_finiteDimensional ht htfd
+  have : HasCanonicalDivisor (K := K) (F := F) := hasCanonicalDivisor_of_isCurveOver
+  have hC3 : ∀ w : Place K F, w.DCoordGenerates := dCoordGenerates_of_isCurveOver
+  set e : RatFunc K ≃ₐ[K] K⟮t⟯ := RatFunc.algEquivOfTranscendental t ht with he
+  let : Algebra (RatFunc K) F := ((algebraMap K⟮t⟯ F).comp e.toAlgHom.toRingHom).toAlgebra
+  have hsq : RingHom.comp (algebraMap (RatFunc K) F) (e.symm.toRingEquiv : K⟮t⟯ →+* RatFunc K)
+      = RingHom.comp (RingEquiv.refl F : F →+* F) (algebraMap K⟮t⟯ F) := by
+    refine RingHom.ext fun a => ?_
+    change algebraMap K⟮t⟯ F (e (e.symm a)) = algebraMap K⟮t⟯ F a
+    rw [e.apply_symm_apply]
+  have : IsScalarTower K (RatFunc K) F :=
+    IsScalarTower.of_algebraMap_eq fun a => by
+      change algebraMap K F a = algebraMap K⟮t⟯ F (e (algebraMap K (RatFunc K) a))
+      rw [e.commutes, ← IsScalarTower.algebraMap_apply]
+  have : FiniteDimensional (RatFunc K) F :=
+    Module.Finite.of_equiv_equiv e.symm.toRingEquiv (RingEquiv.refl F) hsq
+  have : Algebra.IsSeparable (RatFunc K) F :=
+    Algebra.IsSeparable.of_equiv_equiv e.symm.toRingEquiv (RingEquiv.refl F) hsq
+  have : Algebra.IsIntegral (RatFunc K) F := Algebra.IsIntegral.of_finite (RatFunc K) F
+  have : IsCurveOver K (RatFunc K) := isCurveOver_ratFunc K
+  have : FiniteDimensional (IntermediateField.adjoin K ({RatFunc.X} : Set (RatFunc K)))
+      (RatFunc K) := by
+    refine Module.Finite.of_surjective
+      (Algebra.linearMap (IntermediateField.adjoin K ({RatFunc.X} : Set (RatFunc K)))
+        (RatFunc K)) fun y => ?_
+    refine ⟨⟨y, ?_⟩, rfl⟩
+    rw [RatFunc.adjoin_X]
+    exact IntermediateField.mem_top
+  have : Algebra.EssFiniteType K (RatFunc K) :=
+    essFiniteType_of_transcendental_of_finiteDimensional
+      (RatFunc.transcendental_X (K := K)) inferInstance
+  have : ∀ v : Place K (RatFunc K), v.DCoordGenerates := dCoordGenerates_of_isCurveOver
+  have hRR : FunctionFieldRiemannRoch K F := by
+    unfold FunctionFieldRiemannRoch
+    intro _ _ _ ω hω D
+    exact functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver (K := K) (F := F) hω D
+  have hC : ConstantsAreBase K F := constantsAreBase_of_isAlgClosed K F
+  have hSG : StichtenothGenusExists K F := stichtenothGenusExists_of_isCurveOver hC
+  have hWDA : WeilDualityAdelic K F :=
+    weilDualityAdelic_of_functionFieldRiemannRoch_of_stichtenothGenusExists hRR hSG
+  have hg : genus K F = genusFF K F := genus_eq_genusFF hRR hWDA hC
+  obtain ⟨hfin, hdim⟩ := finite_and_finrank_regularDifferentials_eq_genus (K := K) (F := F)
+  exact ⟨hC1, hC2, hC3, hfin, by rw [hdim, hg]⟩
+
+end Bridge
+
+theorem isDomain_ring (N : ℕ) [NeZero N] : IsDomain (ring N) := by
+  have h := WLight.levelN_structure_package N PeriodPair.ofTau (fun τ => ⟨rfl, rfl⟩) (wp N)
+    (fun v τ => rfl) (fricke N) (fun v τ => rfl) jAnalytic (fun τ => rfl)
+  have hdom : ∀ a b : UpperHalfPlane → ℂ, a ∈ ring N → b ∈ ring N → a * b = 0 → a = 0 ∨ b = 0 :=
+    h.2.2.2.2.2
+  have : NoZeroDivisors (ring N) :=
+    ⟨fun {a b} hab => by
+      have h' := hdom (a : UpperHalfPlane → ℂ) b a.2 b.2 (by
+        have := congrArg (Subtype.val) hab
+        simpa using this)
+      rcases h' with h' | h'
+      · left; exact Subtype.ext h'
+      · right; exact Subtype.ext h'⟩
+  have : Nontrivial (ring N) := ⟨⟨0, 1, by
+    intro h01
+    have := congrArg (fun F : ring N => (F : UpperHalfPlane → ℂ) UpperHalfPlane.I) h01
+    simp at this⟩⟩
+  exact NoZeroDivisors.to_isDomain _
+
+theorem main (N : ℕ) (hN : 2 ≤ N) :
+    12 * N + N * (CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index ≤
+      12 * N * Module.finrank ℂ (CuspForm (CongruenceSubgroup.Gamma N) 2) +
+        6 * (CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index := by
+  classical
+  have : NeZero N := ⟨by omega⟩
+  have : IsDomain (ring N) := isDomain_ring N
+  let K := FractionRing (ring N)
+  obtain ⟨_, _, _, _, _, htr, hfd, _, _⟩ :=
+    ModularCurve.LevelN.exists_monoidHom_algEquiv_fixedField_eq_adjoin N K
+  have hgen := ModularCurve.LevelN.twelve_mul_add_mul_index_le_genusFF N hN K
+  obtain ⟨Φ, hΦ⟩ :=
+    ModularCurve.LevelN.exists_linearMap_regularDifferentials_cuspForm_injective N K
+  obtain ⟨_, _, _, hfin, hg⟩ := curve_package (K := ℂ) (F := K) htr hfd
+  have := hfin
+  have : FiniteDimensional ℂ (CuspForm (CongruenceSubgroup.Gamma N) 2) :=
+    CuspForm.finiteDimensional_of_isArithmetic _ 2
+  have hle : Module.finrank ℂ ↥(regularDifferentials ℂ K) ≤
+      Module.finrank ℂ (CuspForm (CongruenceSubgroup.Gamma N) 2) :=
+    LinearMap.finrank_le_finrank_of_injective hΦ
+  calc 12 * N + N * (CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index
+      ≤ 12 * N * genusFF ℂ K +
+          6 * (CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index := hgen
+    _ = 12 * N * Module.finrank ℂ ↥(regularDifferentials ℂ K) +
+          6 * (CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index := by rw [hg]
+    _ ≤ 12 * N * Module.finrank ℂ (CuspForm (CongruenceSubgroup.Gamma N) 2) +
+          6 * (CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index := by
+        gcongr
+
+end ModularCurve.GenusBoundAssembly
+
+theorem solution (N : ℕ) (hN : 2 ≤ N) :
+    12 * N + N * (CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index ≤
+      12 * N * Module.finrank ℂ (CuspForm (CongruenceSubgroup.Gamma N) 2) +
+        6 * (CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index :=
+  ModularCurve.GenusBoundAssembly.main N hN
+
+end S_ModularCurve_twelve_mul_add_mul_index_le_finrank_cuspForm_Gamma
+end P2MW
+export P2MW.S_ModularCurve_twelve_mul_add_mul_index_le_finrank_cuspForm_Gamma (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularCurve.twelve_mul_add_mul_index_le_finrank_cuspForm_Gamma (N : ℕ) (hN : 2 ≤ N) :
+    12 * N + N * (CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index ≤
+      12 * N * Module.finrank ℂ (CuspForm (CongruenceSubgroup.Gamma N) 2) +
+        6 * (CongruenceSubgroup.Gamma N ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index :=
+  solution N hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve.lean
new file mode 100644
index 0000000000..05efe16e95
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve.lean
@@ -0,0 +1,189 @@
+/-
+Based on Prove2Me node
+ModularCurve.
+twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve
+(93b28a2f-818b-54b1-9942-b0b31550fe4f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 74298caa-59e8-5731-bfdc-ce176d383621
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.GroupTheory.DoubleCoset
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Repartitions
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_CongruenceSubgroup_index_gamma1_sup_zpowers_neg_one_eq_three_mul_natCard_doubleCoset_and_eq_two_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_mem_intFormRatiosC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_place_ord_neg_laurentBaseChange_gamma1_eq_natCard_doubleCoset
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_two_mul_genusFF_add_card_fibres_eq_finrank_add_two_of_gamma1_le
+
+/-!
+# Genus formula for X₁(M) with M ≥ 5
+
+Theorem statement:
+`ModularCurve.
+twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve`
+(`93b28a2f-818b-54b1-9942-b0b31550fe4f`), by Claude, 2026-09-05.
+
+Proof: submission `74298caa-59e8-5731-bfdc-ce176d383621`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a natural number with $5 \le M$. Consider the intermediate field
+$\mathrm{qExpFunctionFieldC}\ \mathbb{Q}\ \Gamma_1(M)$ of $\mathbb{Q}((q))$, namely the subfield
+generated over $\mathbb{Q}$ by all quotients $\mathrm{intSeriesC}\,p_f/\mathrm{intSeriesC}\,p_g$
+with nonzero denominator, where $f,g$ run over modular forms of a common weight $k$ for the image of
+$\Gamma_1(M)$ in $\mathrm{GL}_2(\mathbb{R})$ and $p_f,p_g$ are integral power series realising their
+$q$-expansions; and let $F$ be its Laurent base change to $\overline{\mathbb{Q}} =
+\mathrm{AlgebraicClosure}\ \mathbb{Q}$, i.e. the intermediate field of $\overline{\mathbb{Q}}((q))$
+generated over $\overline{\mathbb{Q}}$ by the coefficientwise image of that field under $\mathbb{Q}
+\to \overline{\mathbb{Q}}$. Write $g = \mathrm{genusFF}\ \overline{\mathbb{Q}}\ F$, the
+$\overline{\mathbb{Q}}$-dimension of $H^1$ of the zero divisor of $F/\overline{\mathbb{Q}}$, let
+$\varepsilon_\infty$ be the number of double cosets $\Gamma_1(M) \backslash
+\mathrm{SL}_2(\mathbb{Z}) / \langle T, -1 \rangle$, and let $\mu$ be the index in
+$\mathrm{SL}_2(\mathbb{Z})$ of the subgroup generated by $\Gamma_1(M)$ together with $-1$. The
+assertion is the equality of natural numbers $12g + 6\varepsilon_\infty = \mu + 12$.
+
+This is the genus formula for the modular curve $X_1(M)$ over $\overline{\mathbb{Q}}$ in the form $g
+= 1 + \mu/12 - \varepsilon_\infty/2$, the elliptic-point contributions vanishing because
+$\Gamma_1(M)$ has no elliptic elements for $M \ge 4$; here the curve is presented through its
+function field of $q$-expansion ratios, with $\varepsilon_\infty$ the number of cusps. It is used in
+the comparison of this genus with that of the Igusa-type function field of $X_1(M)$, and in the
+variant of the formula stated for an arbitrary algebraically closed base field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+open ModularCurve CongruenceSubgroup AlgebraicCurve
+open scoped MatrixGroups
+
+theorem GenusX1.exists_coe_eq_jqModC_laurentBaseChange_qExpFunctionFieldC
+    (K : Type*) [Field K] [Algebra ℚ K]
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex] :
+    ∃ y : ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ Γ)),
+      (y : LaurentSeries K) = ModularCurve.jqModC K := by
+  have hmem : ModularCurve.jq ∈ ModularCurve.qExpFunctionFieldC ℚ Γ := by
+    rw [← ModularCurve.jqModC_rat]
+    exact ModularCurve.intFormRatiosC_subset ℚ Γ (ModularCurve.jqModC_mem_intFormRatiosC ℚ Γ)
+  refine ⟨⟨ModularCurve.coeffEmb K ModularCurve.jq, ModularCurve.coeffEmb_mem_laurentBaseChange K
+    hmem⟩, ?_⟩
+  change ModularCurve.coeffEmb K ModularCurve.jq = _
+  rw [← ModularCurve.jqModC_rat]
+  exact ModularCurve.map_jqModC (algebraMap ℚ K)
+
+theorem solution
+    (M : ℕ) [NeZero M] (hM : 5 ≤ M) :
+    12 * AlgebraicCurve.genusFF (AlgebraicClosure ℚ)
+        ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ (Gamma1 M))) +
+      6 * Nat.card (DoubleCoset.Quotient (Gamma1 M : Set SL(2, ℤ))
+        ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) : Set SL(2,
+          ℤ))) =
+      (Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index + 12 := by
+  classical
+  set Kb := AlgebraicClosure ℚ with hKb
+  obtain ⟨y, hy⟩ := GenusX1.exists_coe_eq_jqModC_laurentBaseChange_qExpFunctionFieldC
+    (AlgebraicClosure ℚ) (Gamma1 M)
+  have hfull :=
+    ModularCurve.finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index
+    (AlgebraicClosure ℚ) M y hy
+  have hfib := ModularCurve.two_mul_genusFF_add_card_fibres_eq_finrank_add_two_of_gamma1_le M
+    (Gamma1 M) le_rfl y hy
+  rw [hfull] at hfib
+  have hcusp := ModularCurve.natCard_place_ord_neg_laurentBaseChange_gamma1_eq_natCard_doubleCoset
+    (AlgebraicClosure ℚ) M y hy
+  obtain ⟨h0, h1728⟩ :=
+    ModularCurve.ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1
+    (AlgebraicClosure ℚ) M (le_trans (by norm_num) hM) y hy
+  obtain ⟨hμ3, hμ2⟩ :=
+    index_gamma1_sup_zpowers_neg_one_eq_three_mul_natCard_doubleCoset_and_eq_two_mul
+      M hM
+  obtain ⟨htr, hfd⟩ :=
+  transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC
+    (AlgebraicClosure ℚ) (Gamma1 M) (by
+      rw [Gamma1_mem]; simp [ModularGroup.T]) y hy
+  have := hfd
+  obtain ⟨S₀, hS₀, hsum₀⟩ :=
+    AlgebraicCurve.exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed
+    (AlgebraicClosure ℚ) y htr hfd 0
+  obtain ⟨S₁, hS₁, hsum₁⟩ :=
+    AlgebraicCurve.exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed
+    (AlgebraicClosure ℚ) y htr hfd 1728
+  simp only [map_zero, sub_zero] at hS₀ hsum₀
+  have hmap : (algebraMap (AlgebraicClosure ℚ) ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+    (ModularCurve.qExpFunctionFieldC ℚ (Gamma1 M))) 1728) = 1728 :=
+    by
+    exact map_ofNat _ 1728
+  rw [hmap] at hS₁ hsum₁
+  have hsum₀' : ∑ P ∈ S₀, P.ord y = 3 * (S₀.card : ℤ) := by
+    rw [Finset.sum_congr rfl (fun P hP => h0 P ((hS₀ P).mp hP)), Finset.sum_const, nsmul_eq_mul,
+      mul_comm]
+  have hsum₁' : ∑ P ∈ S₁, P.ord (y - 1728) = 2 * (S₁.card : ℤ) := by
+    rw [Finset.sum_congr rfl (fun P hP => h1728 P ((hS₁ P).mp hP)), Finset.sum_const, nsmul_eq_mul,
+      mul_comm]
+  have hcard₀ : Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+    ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+    (Gamma1 M))) // 0 < P.ord y} = S₀.card :=
+    by
+    rw [← Nat.card_eq_finsetCard]
+    exact Nat.card_congr (Equiv.subtypeEquivRight (fun P => (hS₀ P).symm))
+  have hcard₁ : Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+    ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+    (Gamma1 M))) // 0 < P.ord (y - 1728)} = S₁.card :=
+    by
+    rw [← Nat.card_eq_finsetCard]
+    exact Nat.card_congr (Equiv.subtypeEquivRight (fun P => (hS₁ P).symm))
+  rw [hcusp, hcard₀, hcard₁] at hfib
+  have e0 : 3 * (S₀.card : ℤ) = ((Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2,
+    ℤ))).index : ℤ) :=
+    by
+    rw [← hsum₀', hsum₀, hfull]
+  have e1 : 2 * (S₁.card : ℤ) = ((Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2,
+    ℤ))).index : ℤ) :=
+    by
+    rw [← hsum₁', hsum₁, hfull]
+  zify at hfib ⊢
+  omega
+
+end privateSection
+
+public section publicSection
+
+open CongruenceSubgroup AlgebraicCurve
+open scoped MatrixGroups
+
+namespace ModularCurve
+
+theorem
+  twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve
+    (M : ℕ) [NeZero M] (hM : 5 ≤ M) :
+    12 * AlgebraicCurve.genusFF (AlgebraicClosure ℚ)
+        ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ (Gamma1 M))) +
+      6 * Nat.card (DoubleCoset.Quotient (Gamma1 M : Set SL(2, ℤ))
+        ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) : Set SL(2,
+          ℤ))) =
+      (Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index + 12 :=
+  solution M hM
+
+end ModularCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve_of_isAlgClosed.lean
new file mode 100644
index 0000000000..6ef5032080
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve_of_isAlgClosed.lean
@@ -0,0 +1,269 @@
+/-
+Based on Prove2Me node
+ModularCurve.
+twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve_of_isAlgClosed
+(b4f27b99-307c-5f18-a0d8-4ac198590a9c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a53e31a1-4a29-5b8b-b2f0-57aea1672210
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.GroupTheory.DoubleCoset
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Repartitions
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.RingTheory.Flat.TorsionFree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_genusFF_eq_of_constantFieldExtension_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_transcendental_of_perfectField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_JOneES_exists_transcendental_finiteDimensional_laurentBaseChange
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve
+
+/-!
+# Genus of X₁(M) over an algebraically closed field of characteristic 0
+
+Theorem statement:
+`ModularCurve.
+twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve_of_isAlgClosed`
+(`b4f27b99-307c-5f18-a0d8-4ac198590a9c`), by Claude, 2026-09-05.
+
+Proof: submission `a53e31a1-4a29-5b8b-b2f0-57aea1672210`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field equipped with a $\mathbb{Q}$-algebra structure, and let $M$
+be a nonzero natural number with $M \ge 5$. Inside $\mathbb{Q}((q))$ consider the intermediate field
+$F_0 =$ [`ModularCurve.qExpFunctionFieldC ℚ (Gamma1 M)`](def/ModularCurve_X1.html#L101), generated
+over $\mathbb{Q}$ by all quotients $\mathrm{intSeriesC}\,\mathbb{Q}\,p_f /
+\mathrm{intSeriesC}\,\mathbb{Q}\,p_g$ with $f, g$ modular forms of some weight $k$ for the image of
+$\Gamma_1(M)$ in $\mathrm{GL}_2(\mathbb{R})$ having integral $q$-expansions $p_f, p_g \in
+\mathbb{Z}[[q]]$ and with nonvanishing denominator series, and let $F =$
+[`ModularCurve.laurentBaseChange K F₀`](def/ModularCurve_LaurentCoeff.html#L103) be the subfield of
+$K((q))$ generated over $K$ by the coefficientwise image of $F_0$ along $\mathbb{Q} \to K$. Write $g
+=$ [`AlgebraicCurve.genusFF K F`](def/AlgebraicCurve_Repartitions.html#L145), the $K$-dimension of
+$H^1$ of the zero divisor of $F/K$, $\varepsilon_\infty$ for the number of double cosets
+$\Gamma_1(M) \backslash \mathrm{SL}_2(\mathbb{Z}) / \langle T, -1 \rangle$, and $\mu$ for the index
+of $\Gamma_1(M) \cdot \{\pm 1\}$ in $\mathrm{SL}_2(\mathbb{Z})$. Then $12g + 6\varepsilon_\infty =
+\mu + 12$.
+
+This is the genus formula for the modular curve $X_1(M)$, $M \ge 5$ (a curve with no elliptic
+points), stated for the function field of $X_1(M)$ base changed from $\mathbb{Q}$ to an arbitrary
+algebraically closed field of characteristic $0$; it is obtained from the corresponding statement
+over $\overline{\mathbb{Q}}$ together with invariance of the genus under extension of an
+algebraically closed constant field. It feeds the lower bounds for the dimension of the spaces of
+cusp forms of even and of odd weight on $\Gamma_1(M)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+local notation "Kb" => AlgebraicClosure ℚ
+
+open  ModularCurve CongruenceSubgroup AlgebraicCurve
+
+open scoped MatrixGroups
+
+namespace GenusK
+
+variable (K : Type*) [Field K] [Algebra ℚ K] [IsAlgClosed K] (M : ℕ) [NeZero M]
+
+local notation "F₀" => (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))
+
+omit [NeZero M] in
+theorem hT : ModularGroup.T ∈ CongruenceSubgroup.Gamma1 M := by
+  rw [CongruenceSubgroup.Gamma1_mem]; simp [ModularGroup.T]
+
+noncomputable def ι : Kb →ₐ[ℚ] K :=
+  haveI : Algebra.IsAlgebraic ℚ Kb := AlgebraicClosure.isAlgebraic ℚ
+  IsAlgClosed.lift
+
+omit [NeZero M] in
+theorem coeffMap_mem (x : LaurentSeries Kb) (hx : x ∈ ModularCurve.laurentBaseChange Kb F₀) :
+    ModularCurve.coeffMap ((ι K).toRingHom) x ∈ ModularCurve.laurentBaseChange K F₀ := by
+  have hle : (ModularCurve.laurentBaseChange Kb F₀).toSubfield ≤
+      (ModularCurve.laurentBaseChange K F₀).toSubfield.comap (ModularCurve.coeffMap ((ι
+        K).toRingHom)) := by
+    rw [ModularCurve.laurentBaseChange]
+    refine IntermediateField.adjoin_le_subfield Kb _ ?_ ?_
+    · rintro _ ⟨a, rfl⟩
+      rw [SetLike.mem_coe, Subfield.mem_comap]
+      have hC1 : algebraMap Kb (LaurentSeries Kb) a = HahnSeries.single 0 a := by
+        rw [show algebraMap Kb (LaurentSeries Kb) a = HahnSeries.C a by
+          simp [HahnSeries.algebraMap_apply']]; rfl
+      have hC2 : algebraMap K (LaurentSeries K) (ι K a) = HahnSeries.single 0 (ι K a) := by
+        rw [show algebraMap K (LaurentSeries K) (ι K a) = HahnSeries.C (ι K a) by
+          simp [HahnSeries.algebraMap_apply']]; rfl
+      have : ModularCurve.coeffMap ((ι K).toRingHom) (algebraMap Kb (LaurentSeries Kb) a)
+          = algebraMap K (LaurentSeries K) (ι K a) := by
+        rw [hC1, hC2, ModularCurve.coeffMap_single]; rfl
+      rw [this]
+      exact IntermediateField.algebraMap_mem _ _
+    · rintro _ ⟨y, hy, rfl⟩
+      change ModularCurve.coeffMap ((ι K).toRingHom) (ModularCurve.coeffEmb Kb y) ∈
+        ModularCurve.laurentBaseChange K F₀
+      have : ModularCurve.coeffMap ((ι K).toRingHom) (ModularCurve.coeffEmb Kb y) =
+        ModularCurve.coeffEmb K y :=
+        by
+        ext n
+        simp [ModularCurve.coeffMap, ModularCurve.coeffEmb_coeff]
+      rw [this]
+      exact ModularCurve.coeffEmb_mem_laurentBaseChange K hy
+  exact hle hx
+
+noncomputable def φ :
+    ↥(ModularCurve.laurentBaseChange Kb (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))) →+* ↥(ModularCurve.laurentBaseChange K F₀) :=
+  ((ModularCurve.coeffMap ((ι K).toRingHom)).comp (ModularCurve.laurentBaseChange Kb
+    F₀).toSubfield.subtype).codRestrict
+    (ModularCurve.laurentBaseChange K F₀).toSubfield (fun x => coeffMap_mem K M x.1 x.2)
+
+omit [NeZero M] in
+theorem φ_apply_coe (x : ↥(ModularCurve.laurentBaseChange Kb F₀)) :
+    ((φ K M x : ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M)))) : LaurentSeries K) = ModularCurve.coeffMap ((ι K).toRingHom)
+      x := rfl
+
+end GenusK
+
+variable (K : Type*) [Field K] [Algebra ℚ K] [IsAlgClosed K] (M : ℕ) [NeZero M]
+
+local notation "F₀" => (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))
+
+theorem solution (hM : 5 ≤ M) :
+    12 * AlgebraicCurve.genusFF K ↥(ModularCurve.laurentBaseChange K F₀) +
+      6 * Nat.card (DoubleCoset.Quotient (CongruenceSubgroup.Gamma1 M : Set SL(2, ℤ))
+        ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) : Set SL(2,
+          ℤ))) =
+      (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index + 12 := by
+  classical
+  have hQ :=
+    twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve
+      M hM
+  let algQK : Algebra Kb K := (GenusK.ι K).toRingHom.toAlgebra
+  let algFF : Algebra ↥(ModularCurve.laurentBaseChange Kb F₀)
+    ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1
+    M))) :=
+    (GenusK.φ K M).toAlgebra
+  let algQF : Algebra Kb ↥(ModularCurve.laurentBaseChange K F₀) :=
+    ((algebraMap K ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M)))).comp (GenusK.ι K).toRingHom).toAlgebra
+  have : IsScalarTower Kb K ↥(ModularCurve.laurentBaseChange K F₀) :=
+    IsScalarTower.of_algebraMap_eq (fun a => rfl)
+  have : IsScalarTower Kb ↥(ModularCurve.laurentBaseChange Kb F₀)
+    ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1
+    M))) :=
+    by
+    refine IsScalarTower.of_algebraMap_eq (fun a => ?_)
+    apply Subtype.ext
+    change ((algebraMap K ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))) (GenusK.ι K a) : ↥(ModularCurve.laurentBaseChange K
+      F₀)) : LaurentSeries K)
+      = ModularCurve.coeffMap ((GenusK.ι K).toRingHom) ((algebraMap Kb
+        ↥(ModularCurve.laurentBaseChange Kb (ModularCurve.qExpFunctionFieldC ℚ
+        (CongruenceSubgroup.Gamma1 M))) a : ↥(ModularCurve.laurentBaseChange Kb
+        F₀)) : LaurentSeries
+        Kb)
+    rw [show ((algebraMap Kb ↥(ModularCurve.laurentBaseChange Kb F₀) a :
+      ↥(ModularCurve.laurentBaseChange Kb (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M)))) : LaurentSeries Kb) = algebraMap
+      Kb (LaurentSeries Kb) a from rfl,
+      show ((algebraMap K ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ
+        (CongruenceSubgroup.Gamma1 M))) (GenusK.ι K a) : ↥(ModularCurve.laurentBaseChange K
+        F₀)) : LaurentSeries K) =
+        algebraMap K (LaurentSeries K) (GenusK.ι K a) from rfl,
+      show algebraMap Kb (LaurentSeries Kb) a =
+        HahnSeries.single 0 a by
+        rw [show algebraMap Kb (LaurentSeries Kb) a =
+          HahnSeries.C a by
+          simp [HahnSeries.algebraMap_apply']]; rfl,
+      show algebraMap K (LaurentSeries K) (GenusK.ι K a) = HahnSeries.single 0 (GenusK.ι K a) by
+        rw [show algebraMap K (LaurentSeries K) (GenusK.ι K a) = HahnSeries.C (GenusK.ι K a) by
+          simp [HahnSeries.algebraMap_apply']]; rfl,
+      ModularCurve.coeffMap_single]
+    rfl
+  have hfg :=
+    ModularCurve.JOneES.exists_transcendental_finiteDimensional_laurentBaseChange (AlgebraicClosure
+      ℚ)
+    (CongruenceSubgroup.Gamma1 M) (GenusK.hT M)
+  have hfg' := ModularCurve.JOneES.exists_transcendental_finiteDimensional_laurentBaseChange K
+    (CongruenceSubgroup.Gamma1 M) (GenusK.hT M)
+  have : IsCurveOver Kb ↥(ModularCurve.laurentBaseChange Kb
+    (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))) :=
+    by
+    obtain ⟨x, htr, hfd⟩ :=
+      hfg; exact AlgebraicCurve.isCurveOver_of_transcendental_of_perfectField htr hfd
+  have : IsCurveOver K ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ
+    (CongruenceSubgroup.Gamma1 M))) :=
+    by
+    obtain ⟨x, htr, hfd⟩ :=
+      hfg'; exact AlgebraicCurve.isCurveOver_of_transcendental_of_perfectField htr hfd
+  have hgen : IntermediateField.adjoin K (Set.range (algebraMap ↥(ModularCurve.laurentBaseChange
+    Kb (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))
+    ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1
+    M))))) = ⊤ :=
+    by
+    apply IntermediateField.lift_injective
+    erw [IntermediateField.lift_top K (ModularCurve.laurentBaseChange K
+      (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))),
+      IntermediateField.lift_adjoin K (ModularCurve.laurentBaseChange K
+      (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))]
+    apply le_antisymm
+    · rw [IntermediateField.adjoin_le_iff]
+      rintro _ ⟨z, -, rfl⟩
+      exact z.2
+    · change IntermediateField.adjoin K (⇑(ModularCurve.coeffEmb K) ''
+        (((ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)) : IntermediateField ℚ
+        (LaurentSeries ℚ)) : Set (LaurentSeries ℚ))) ≤ _
+      rw [IntermediateField.adjoin_le_iff]
+      rintro _ ⟨y, hy, rfl⟩
+      refine IntermediateField.subset_adjoin K _ ⟨GenusK.φ K M ⟨ModularCurve.coeffEmb
+        Kb y,
+        ModularCurve.coeffEmb_mem_laurentBaseChange Kb hy⟩, ⟨_, rfl⟩, ?_⟩
+      change ModularCurve.coeffMap ((GenusK.ι K).toRingHom) (ModularCurve.coeffEmb (AlgebraicClosure
+        ℚ) y) = ModularCurve.coeffEmb K y
+      ext n
+      simp [ModularCurve.coeffMap, ModularCurve.coeffEmb_coeff]
+  have hinv :=
+    AlgebraicCurve.genusFF_eq_of_constantFieldExtension_of_isAlgClosed Kb
+      ↥(ModularCurve.laurentBaseChange Kb (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))) K ↥(ModularCurve.laurentBaseChange K
+      (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))) hfg hfg' hgen
+  rw [hinv]
+  exact hQ
+
+end privateSection
+
+public section publicSection
+
+
+open CongruenceSubgroup ModularCurve AlgebraicCurve
+open scoped MatrixGroups
+
+namespace ModularCurve
+
+theorem
+twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve_of_isAlgClosed
+    (K : Type*) [Field K] [Algebra ℚ K] [IsAlgClosed K]
+    (M : ℕ) [NeZero M] (hM : 5 ≤ M) :
+    12 * genusFF K ↥(laurentBaseChange K (qExpFunctionFieldC ℚ (Gamma1 M))) +
+      6 * Nat.card (DoubleCoset.Quotient (Gamma1 M)
+        ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) : Set SL(2,
+          ℤ))) =
+      (Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index + 12 :=
+  solution K M hM
+
+end ModularCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_two_mul_genusFF_add_card_fibres_eq_finrank_add_two_of_gamma1_le.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_two_mul_genusFF_add_card_fibres_eq_finrank_add_two_of_gamma1_le.lean
new file mode 100644
index 0000000000..e56080c69a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_two_mul_genusFF_add_card_fibres_eq_finrank_add_two_of_gamma1_le.lean
@@ -0,0 +1,259 @@
+/-
+Based on Prove2Me node ModularCurve.two_mul_genusFF_add_card_fibres_eq_finrank_add_two_of_gamma1_le
+(f1651288-3106-5b21-997e-5e33d77337df) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d6bc4896-535c-5a30-85ee-8a1ba31c0d2f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Repartitions
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_XH
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_add_eq_of_lt
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_finset_sum_neg_ord_eq_finrank_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_sum_ord_sub_one_le_two_mul_genusFF_of_isSeparable
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_two_mul_genusFF_add_card_fibres_le_finrank_add_two_of_gamma1_le
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Fibre identity for j on X(Γ) over ℚ̄
+
+Theorem statement: `ModularCurve.two_mul_genusFF_add_card_fibres_eq_finrank_add_two_of_gamma1_le`
+(`f1651288-3106-5b21-997e-5e33d77337df`), by Claude, 2026-09-05.
+
+Proof: submission `d6bc4896-535c-5a30-85ee-8a1ba31c0d2f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a nonzero natural number and let $\Gamma \le \mathrm{SL}_2(\mathbb{Z})$ contain
+$\Gamma_1(M)$. Write $F_0 =$ `qExpFunctionFieldC ℚ Γ` for the subfield of $\mathbb{Q}((q))$
+generated over $\mathbb{Q}$ by all quotients $\iota(p_f)/\iota(p_g)$ of the integral $q$-expansions
+$p_f, p_g \in \mathbb{Z}[[q]]$ of two modular forms $f, g$ of the same weight $k$ for the image of
+$\Gamma$ in $\mathrm{GL}_2(\mathbb{R})$, with $\iota(p_g) \ne 0$, and let $F =$ `laurentBaseChange
+(AlgebraicClosure ℚ) F₀` be the subfield of $\overline{\mathbb{Q}}((q))$ generated over $k =
+\overline{\mathbb{Q}}$ by the coefficientwise image of $F_0$. Let $y \in F$ be an element whose
+underlying Laurent series is $q^{-1}E_4^3\eta^{-24}$, the $q$-expansion of $j$, with coefficients
+taken in $k$. Then, with $g =$ `genusFF` $(k, F)$ the repartition genus of $F/k$, places being
+valuation subrings of $F$ containing $k$, proper and principal, and $\mathrm{ord}_P$ the associated
+normalised valuation,
+$$2g + \#\{P : \mathrm{ord}_P y < 0\} + \#\{P : \mathrm{ord}_P y > 0\} + \#\{P : \mathrm{ord}_P (y -
+1728) > 0\} = [F : k(y)] + 2,$$
+the last term being the $k(y)$-dimension of $F$, where $k(y) =$ `IntermediateField.adjoin k {y}`.
+
+This is the Riemann–Hurwitz equality for the degree-$[F:k(y)]$ map $j : X(\Gamma) \to X(1)$ over
+$\overline{\mathbb{Q}}$, in the form which uses that $j$ is ramified only above $0$, $1728$ and
+$\infty$, so that each of the three fibres contributes its cardinality. It is the arithmetic input
+to the genus computations for full level and for $\Gamma_1(M)$, in particular to the genus formula
+relating $g$, the index of $\Gamma$ and the number of relevant double cosets.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_two_mul_genusFF_add_card_fibres_eq_finrank_add_two_of_gamma1_le.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularCurve_two_mul_genusFF_add_card_fibres_eq_finrank_add_two_of_gamma1_le
+
+open ModularCurve CongruenceSubgroup AlgebraicCurve
+open scoped MatrixGroups
+
+open IntermediateField in
+set_option synthInstance.maxHeartbeats 1600000 in
+theorem solution
+    (M : ℕ) [NeZero M] (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+    (hΓ : CongruenceSubgroup.Gamma1 M ≤ Γ)
+    (y : ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ Γ)))
+    (hy : (y : LaurentSeries (AlgebraicClosure ℚ)) = ModularCurve.jqModC (AlgebraicClosure ℚ)) :
+    2 * AlgebraicCurve.genusFF (AlgebraicClosure ℚ)
+          ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ Γ)) +
+        Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+          ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ Γ)) // P.ord y < 0} +
+        Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+          ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ Γ)) // 0 < P.ord y} +
+        Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+          ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ Γ)) // 0 < P.ord (y - 1728)} =
+      Module.finrank
+          ↥(IntermediateField.adjoin (AlgebraicClosure ℚ)
+            ({y} : Set ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ Γ))))
+          ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ Γ)) + 2 := by
+  classical
+  have hKc : CharZero (AlgebraicClosure ℚ) :=
+    charZero_of_injective_algebraMap (algebraMap ℚ (AlgebraicClosure ℚ)).injective
+  have : (Gamma1 M).FiniteIndex := (CongruenceSubgroup.Gamma1_is_congruence M).finiteIndex
+  have : Γ.FiniteIndex := Subgroup.finiteIndex_of_le hΓ
+  have hT1 : ModularGroup.T ∈ Gamma1 M := by
+    rw [← ModularCurve.GammaH_bot M]; exact ModularCurve.translation_mem_GammaH M ⊥
+  have hT : ModularGroup.T ∈ Γ := hΓ hT1
+  obtain ⟨htr, hfin⟩ :=
+  transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC
+      (AlgebraicClosure ℚ) Γ hT y hy
+  have := hfin
+  have hle :=
+    ModularCurve.two_mul_genusFF_add_card_fibres_le_finrank_add_two_of_gamma1_le M Γ hΓ y hy
+  refine le_antisymm hle ?_
+  obtain ⟨S0, hS0mem, hS0sum⟩ :=
+    AlgebraicCurve.exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed (AlgebraicClosure
+      ℚ) y htr hfin 0
+  obtain ⟨S1, hS1mem, hS1sum⟩ :=
+    AlgebraicCurve.exists_finset_sum_ord_sub_algebraMap_eq_finrank_of_isAlgClosed (AlgebraicClosure
+      ℚ) y htr hfin 1728
+  obtain ⟨Si, hSimem, hSisum⟩ :=
+    AlgebraicCurve.exists_finset_sum_neg_ord_eq_finrank_of_isAlgClosed (AlgebraicClosure ℚ) y htr
+      hfin
+  have h0 : (y - algebraMap (AlgebraicClosure ℚ) _ (0 : AlgebraicClosure ℚ)) = y := by
+    rw [map_zero, sub_zero]
+  have h1728 : (algebraMap (AlgebraicClosure ℚ)
+      ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ Γ))
+        (1728 : AlgebraicClosure ℚ)) = (1728 : ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ Γ))) := by
+    exact map_ofNat _ 1728
+  simp only [h0] at hS0mem hS0sum
+  have cSi : Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+          ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+            Γ)) //
+            P.ord y < 0} = Si.card := by
+    rw [Nat.card_congr (Equiv.subtypeEquivRight (fun P => (hSimem P).symm))]
+    simp only [Nat.card_eq_fintype_card, Fintype.card_coe]
+  have cS0 : Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+          ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+            Γ)) //
+            0 < P.ord y} = S0.card := by
+    rw [Nat.card_congr (Equiv.subtypeEquivRight (fun P => (hS0mem P).symm))]
+    simp only [Nat.card_eq_fintype_card, Fintype.card_coe]
+  have cS1 : Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+          ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+            Γ)) //
+            0 < P.ord (y - 1728)} = S1.card := by
+    have e : ∀ P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+        ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+          Γ)),
+        0 < P.ord (y - 1728) ↔ P ∈ S1 := by
+      intro P; rw [hS1mem P, h1728]
+    rw [Nat.card_congr (Equiv.subtypeEquivRight e)]
+    simp only [Nat.card_eq_fintype_card, Fintype.card_coe]
+  have hdisj : Disjoint S0 S1 := by
+    rw [Finset.disjoint_left]
+    intro P hP0 hP1
+    have hy0 : 0 < P.ord y := (hS0mem P).mp hP0
+    have hy1 : 0 < P.ord (y - algebraMap (AlgebraicClosure ℚ) _ (1728 : AlgebraicClosure ℚ)) :=
+      (hS1mem P).mp hP1
+    have hc : P.ord (algebraMap (AlgebraicClosure ℚ)
+        ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ Γ))
+          (1728 : AlgebraicClosure ℚ)) = 0 := AlgebraicCurve.Place.ord_algebraMap P _
+    have hc0 : (algebraMap (AlgebraicClosure ℚ)
+        ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ Γ))
+          (1728 : AlgebraicClosure ℚ)) ≠ 0 := by
+      rw [map_ne_zero]; norm_num
+    have hg0 : y - algebraMap (AlgebraicClosure ℚ) _ (1728 : AlgebraicClosure ℚ) ≠ 0 := by
+      intro h; rw [h, AlgebraicCurve.Place.ord_zero] at hy1; exact lt_irrefl _ hy1
+    have hlt : P.ord (algebraMap (AlgebraicClosure ℚ)
+        ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ Γ))
+          (1728 : AlgebraicClosure ℚ)) <
+        P.ord (y - algebraMap (AlgebraicClosure ℚ) _ (1728 : AlgebraicClosure ℚ)) := by
+          rw [hc]; exact hy1
+    have hsum := AlgebraicCurve.Place.ord_add_eq_of_lt P hc0 hg0 hlt
+    rw [add_sub_cancel, hc] at hsum
+    rw [hsum] at hy0
+    exact lt_irrefl _ hy0
+  have : CharZero ↥(IntermediateField.adjoin (AlgebraicClosure ℚ)
+      ({y} : Set ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+        (ModularCurve.qExpFunctionFieldC ℚ Γ)))) :=
+    charZero_of_injective_algebraMap (algebraMap (AlgebraicClosure ℚ) _).injective
+  have hsep : Algebra.IsSeparable
+      ↥(IntermediateField.adjoin (AlgebraicClosure ℚ)
+        ({y} : Set ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ Γ))))
+      ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ Γ))
+        :=
+    Algebra.IsAlgebraic.isSeparable_of_perfectField
+  have hst :=
+    AlgebraicCurve.sum_ord_sub_one_le_two_mul_genusFF_of_isSeparable (AlgebraicClosure ℚ) y htr hfin
+      hsep
+    (S0 ∪ S1) (fun P => if P ∈ S0 then 0 else 1728)
+    (by
+      intro P hP
+      rcases Finset.mem_union.mp hP with h | h
+      · simp only [h, ite_true, map_zero, sub_zero]; exact (hS0mem P).mp h
+      · have hn : P ∉ S0 := fun h' => Finset.disjoint_left.mp hdisj h' h
+        simp only [hn, ite_false]; exact (hS1mem P).mp h)
+    Si (fun P hP => (hSimem P).mp hP)
+  have eA : ∀ P ∈ S0, (P.ord (y - algebraMap (AlgebraicClosure ℚ) _
+        ((fun P => if P ∈ S0 then (0 : AlgebraicClosure ℚ) else 1728) P)) - 1) = P.ord y - 1 := by
+    intro P hP
+    simp only [hP, ite_true, map_zero, sub_zero]
+  have eB : ∀ P ∈ S1, (P.ord (y - algebraMap (AlgebraicClosure ℚ) _
+        ((fun P => if P ∈ S0 then (0 : AlgebraicClosure ℚ) else 1728) P)) - 1) =
+      P.ord (y - algebraMap (AlgebraicClosure ℚ) _ (1728 : AlgebraicClosure ℚ)) - 1 := by
+    intro P hP
+    have hn : P ∉ S0 := fun h' => Finset.disjoint_left.mp hdisj h' hP
+    simp only [hn, ite_false]
+  rw [Finset.sum_union hdisj, Finset.sum_congr rfl eA, Finset.sum_congr rfl eB] at hst
+  simp only [Finset.sum_sub_distrib, Finset.sum_const, nsmul_eq_mul, mul_one] at hst
+  rw [hS0sum, hS1sum, hSisum] at hst
+  rw [cSi, cS0, cS1]
+  omega
+
+end S_ModularCurve_two_mul_genusFF_add_card_fibres_eq_finrank_add_two_of_gamma1_le
+end P2MW
+export P2MW.S_ModularCurve_two_mul_genusFF_add_card_fibres_eq_finrank_add_two_of_gamma1_le
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open CongruenceSubgroup
+open ModularCurve
+open AlgebraicCurve
+open scoped MatrixGroups
+theorem ModularCurve.two_mul_genusFF_add_card_fibres_eq_finrank_add_two_of_gamma1_le
+    (M : ℕ) [NeZero M] (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+    (hΓ : CongruenceSubgroup.Gamma1 M ≤ Γ)
+    (y : ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ Γ)))
+    (hy : (y : LaurentSeries (AlgebraicClosure ℚ)) = ModularCurve.jqModC (AlgebraicClosure ℚ)) :
+    2 * AlgebraicCurve.genusFF (AlgebraicClosure ℚ)
+          ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ Γ)) +
+        Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+          ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ Γ)) // P.ord y < 0} +
+        Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+          ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ Γ)) // 0 < P.ord y} +
+        Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+          ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ Γ)) // 0 < P.ord (y - 1728)} =
+      Module.finrank
+          ↥(IntermediateField.adjoin (AlgebraicClosure ℚ)
+            ({y} : Set ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ Γ))))
+          ↥(ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+          (ModularCurve.qExpFunctionFieldC ℚ Γ)) + 2 :=
+  solution M Γ hΓ y hy
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_two_mul_genusFF_add_card_fibres_le_finrank_add_two_of_gamma1_le.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_two_mul_genusFF_add_card_fibres_le_finrank_add_two_of_gamma1_le.lean
new file mode 100644
index 0000000000..81d37c807c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_two_mul_genusFF_add_card_fibres_le_finrank_add_two_of_gamma1_le.lean
@@ -0,0 +1,907 @@
+/-
+Based on Prove2Me node ModularCurve.two_mul_genusFF_add_card_fibres_le_finrank_add_two_of_gamma1_le
+(cb08000f-90f3-517d-ad94-c089495b2122) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 42a0726f-f7f5-5092-b94c-6cadd93ca7fe
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Repartitions
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.Analysis.CStarAlgebra.Classes
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.RingTheory.Finiteness.ModuleFinitePresentation
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_D_ne_zero_of_ord_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_diffCoeff_smul_D_of_ord_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_comap_algebraMap_eq_of_constantFieldExtension
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_exists_ord_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_min_ord_le_ord_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ordDiff_D_eq_ord_sub_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_diffCoeff_D_nonneg_of_perfectField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_constantsAreBase_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_dCoordGenerates_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_degree_canonicalDivisor_eq_of_riemannRoch
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_degree_poleDivisor_eq_finrank_adjoin_of_isAlgClosed_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_essFiniteType_of_transcendental_of_finiteDimensional
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteDimensional_adjoin_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_genus_eq_genusFF
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_hasCanonicalDivisor_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_transcendental_of_isSeparable
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_of_transcendental_of_perfectField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_isCurveOver_ratFunc
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_stichtenothGenusExists_of_isCurveOver
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_weilDualityAdelic_of_functionFieldRiemannRoch_of_stichtenothGenusExists
+import LeanPool.FLTEichlerShimura.Theorems.Thm_KaehlerDifferential_D_ne_zero_of_transcendental
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_JOneES_exists_transcendental_finiteDimensional_laurentBaseChange
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_sub_algebraMap_le_one_laurentBaseChange_qExpFunctionFieldC_of_ne_zero_of_ne_1728
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Riemann–Hurwitz inequality for j on X(Γ) over ℚ̄
+
+Theorem statement: `ModularCurve.two_mul_genusFF_add_card_fibres_le_finrank_add_two_of_gamma1_le`
+(`cb08000f-90f3-517d-ad94-c089495b2122`), by Claude, 2026-09-05.
+
+Proof: submission `42a0726f-f7f5-5092-b94c-6cadd93ca7fe`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a nonzero natural number and let $\Gamma$ be a subgroup of $\mathrm{SL}(2,\mathbb{Z})$
+containing $\Gamma_1(M)$. Let $F_0 =$ [`ModularCurve.qExpFunctionFieldC ℚ
+Γ`](def/ModularCurve_X1.html#L101) be the subfield of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$
+by the quotients $p_f/p_g$ of integral $q$-expansions of modular forms $f,g$ of a common weight on
+$\Gamma$ (viewed in $\mathrm{GL}(2,\mathbb{R})$), the denominator series being nonzero, and let $F$
+be its base change `laurentBaseChange`, namely the subfield of $\bar{\mathbb{Q}}((q))$ generated
+over $\bar{\mathbb{Q}} =$ `AlgebraicClosure ℚ` by the coefficientwise image of $F_0$. Let $y \in F$
+be an element whose underlying Laurent series is `jqModC`, i.e. $q^{-1}$ times the power series
+$E_4^3 \cdot \eta^{-24}$-type numerator `jNum` with coefficients mapped into $\bar{\mathbb{Q}}$.
+Places of $F/\bar{\mathbb{Q}}$ are valuation subrings of $F$ containing $\bar{\mathbb{Q}}$, distinct
+from $F$ itself and principal, with $\mathrm{ord}$ the associated normalised integer valuation, and
+`genusFF` is the $\bar{\mathbb{Q}}$-dimension of the first cohomology $H^1$ of the zero divisor. The
+assertion is that twice the genus of $F/\bar{\mathbb{Q}}$, plus the numbers (as `Nat.card` of the
+corresponding subtypes of places) of places where $y$ has a pole, where $y$ has a zero, and where
+$y-1728$ has a zero, is at most $[F : \bar{\mathbb{Q}}(y)] + 2$, the degree being the
+$\bar{\mathbb{Q}}(y)$-finrank of $F$ for $\bar{\mathbb{Q}}(y)$ the intermediate field generated by
+$y$.
+
+This is the Riemann–Hurwitz count, in inequality form, for the covering $j \colon X(\Gamma) \to X(1)
+= \mathbb{P}^1_j$ realised on the $q$-expansion model of the function field of $X(\Gamma)$ over
+$\bar{\mathbb{Q}}$: the ramification of $j$ occurs only above $j = \infty, 0, 1728$. It is used to
+obtain the corresponding equality
+[`ModularCurve.two_mul_genusFF_add_card_fibres_eq_finrank_add_two_of_gamma1_le`]
+(thm.html#ModularCurve.two_mul_genusFF_add_card_fibres_eq_finrank_add_two_of_gamma1_le)
+and, from there, the comparison of genera between the $q$-expansion model over $\bar{\mathbb{Q}}$
+and the reduction used for the modular curves $X_H$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_two_mul_genusFF_add_card_fibres_le_finrank_add_two_of_gamma1_le.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 3200000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+open AlgebraicCurve Divisor
+
+namespace P2MW.S_OVERLONG_7a292264
+
+
+noncomputable section
+
+open scoped MatrixGroups
+p2m_open "AlgebraicCurve IntermediateField KaehlerDifferential ModularCurve \
+  P2MW.S_OVERLONG_7a292264.ModularCurve"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "qExpFunctionFieldC coeffMap coeffMap_single coeffMap_coeffMap \
+  coeffMap_congr algebraMap_laurentSeries_eq_single coeffEmb laurentBaseChange \
+  coeffEmb_mem_laurentBaseChange mem_laurentBaseChange_iff jqModC map_jqModC \
+  ord_sub_algebraMap_le_one_laurentBaseChange_qExpFunctionFieldC_of_ne_zero_of_ne_1728 \
+  JOneES.exists_transcendental_finiteDimensional_laurentBaseChange transcendental_jqModC"
+namespace RiemannHurwitzCount
+p2m_open "ModularCurve"
+
+universe u v
+
+section Package
+
+variable (k : Type u) [Field k] {F : Type v} [Field F] [Algebra k F]
+  (x : F) (hx : Transcendental k x) (hfin : FiniteDimensional k⟮x⟯ F)
+  (hsep : Algebra.IsSeparable k⟮x⟯ F)
+
+include hx hfin hsep
+
+theorem isCurveOver_pkg : IsCurveOver k F :=
+  AlgebraicCurve.isCurveOver_of_transcendental_of_isSeparable k F x hx hfin hsep
+
+omit hsep in
+theorem essFiniteType_pkg : Algebra.EssFiniteType k F :=
+  AlgebraicCurve.essFiniteType_of_transcendental_of_finiteDimensional hx hfin
+
+theorem with_ratFunc {P : Prop}
+    (h : ∀ [Algebra (RatFunc k) F] [IsScalarTower k (RatFunc k) F]
+      [FiniteDimensional (RatFunc k) F] [Algebra.IsSeparable (RatFunc k) F],
+      algebraMap (RatFunc k) F RatFunc.X = x →
+      Module.finrank (RatFunc k) F = Module.finrank k⟮x⟯ F → P) : P := by
+  have := hfin
+  have := hsep
+  let e : RatFunc k ≃ₐ[k] k⟮x⟯ := RatFunc.algEquivOfTranscendental x hx
+  let : Algebra (RatFunc k) F := ((algebraMap k⟮x⟯ F).comp e.toAlgHom.toRingHom).toAlgebra
+  have hsq : RingHom.comp (algebraMap (RatFunc k) F) (e.symm.toRingEquiv : k⟮x⟯ →+* RatFunc k)
+      = RingHom.comp (RingEquiv.refl F : F →+* F) (algebraMap k⟮x⟯ F) := by
+    ext y
+    change algebraMap k⟮x⟯ F (e (e.symm y)) = algebraMap k⟮x⟯ F y
+    rw [e.apply_symm_apply]
+  have : IsScalarTower k (RatFunc k) F := IsScalarTower.of_algebraMap_eq fun a => by
+    change algebraMap k F a = algebraMap k⟮x⟯ F (e (algebraMap k (RatFunc k) a))
+    rw [e.commutes, ← IsScalarTower.algebraMap_apply]
+  have hfd : FiniteDimensional (RatFunc k) F :=
+    Module.Finite.of_equiv_equiv e.symm.toRingEquiv (RingEquiv.refl F) hsq
+  have : Algebra.IsSeparable (RatFunc k) F :=
+    Algebra.IsSeparable.of_equiv_equiv e.symm.toRingEquiv (RingEquiv.refl F) hsq
+  have hX : algebraMap (RatFunc k) F RatFunc.X = x := by
+    change algebraMap k⟮x⟯ F (e RatFunc.X) = x
+    have h := RatFunc.algEquivOfTranscendental_X x hx
+    exact h
+  have hn : Module.finrank (RatFunc k) F = Module.finrank k⟮x⟯ F :=
+    Algebra.finrank_eq_of_equiv_equiv e.toRingEquiv (RingEquiv.refl F) (by ext y; rfl)
+  exact h hX hn
+
+variable [IsAlgClosed k]
+
+theorem hasCanonicalDivisor_pkg : HasCanonicalDivisor (K := k) (F := F) := by
+  have := isCurveOver_pkg k x hx hfin hsep
+  have := essFiniteType_pkg k x hx hfin
+  exact AlgebraicCurve.hasCanonicalDivisor_of_isCurveOver
+
+theorem dCoordGenerates_pkg : ∀ v : Place k F, v.DCoordGenerates := by
+  have := isCurveOver_pkg k x hx hfin hsep
+  have := essFiniteType_pkg k x hx hfin
+  exact AlgebraicCurve.dCoordGenerates_of_isCurveOver
+
+theorem riemannRoch_and_constantsAreBase_pkg :
+    haveI := hasCanonicalDivisor_pkg k x hx hfin hsep
+    FunctionFieldRiemannRoch k F ∧ ConstantsAreBase k F := by
+  classical
+  have := hfin
+  have := isCurveOver_pkg k x hx hfin hsep
+  have := hasCanonicalDivisor_pkg k x hx hfin hsep
+  have := dCoordGenerates_pkg k x hx hfin hsep
+  have : IsCurveOver k (RatFunc k) := AlgebraicCurve.isCurveOver_ratFunc k
+  have : Algebra.EssFiniteType (Polynomial k) (RatFunc k) :=
+    Algebra.EssFiniteType.of_isLocalization _ (nonZeroDivisors (Polynomial k))
+  have : Algebra.EssFiniteType k (RatFunc k) :=
+    Algebra.EssFiniteType.comp k (Polynomial k) (RatFunc k)
+  have : ∀ v : Place k (RatFunc k), v.DCoordGenerates :=
+    AlgebraicCurve.dCoordGenerates_of_isCurveOver
+  refine with_ratFunc k x hx hfin hsep ?_
+  intro _ _ _ _ _ _
+  have : Algebra.IsIntegral (RatFunc k) F := Algebra.IsIntegral.of_finite _ _
+  exact ⟨AlgebraicCurve.functionFieldRiemannRoch_of_isAlgClosed_of_isCurveOver,
+    AlgebraicCurve.constantsAreBase_of_isAlgClosed k F⟩
+
+theorem genus_eq_genusFF_pkg :
+    haveI := hasCanonicalDivisor_pkg k x hx hfin hsep
+    genus k F = genusFF k F := by
+  have := isCurveOver_pkg k x hx hfin hsep
+  have := hasCanonicalDivisor_pkg k x hx hfin hsep
+  have := dCoordGenerates_pkg k x hx hfin hsep
+  have := essFiniteType_pkg k x hx hfin
+  have rr := riemannRoch_and_constantsAreBase_pkg k x hx hfin hsep
+  have hSG : StichtenothGenusExists k F :=
+    AlgebraicCurve.stichtenothGenusExists_of_isCurveOver rr.2
+  have wda : WeilDualityAdelic k F :=
+    AlgebraicCurve.weilDualityAdelic_of_functionFieldRiemannRoch_of_stichtenothGenusExists rr.1 hSG
+  exact AlgebraicCurve.genus_eq_genusFF rr.1 wda rr.2
+
+theorem degree_canonical_pkg :
+    haveI := hasCanonicalDivisor_pkg k x hx hfin hsep
+    ∀ {ω : Ω[F⁄k]} (hω : ω ≠ 0),
+      Divisor.degree (canonicalDivisorOf hω) = 2 * (genusFF k F : ℤ) - 2 := by
+  intro ω hω
+  have := isCurveOver_pkg k x hx hfin hsep
+  have := hasCanonicalDivisor_pkg k x hx hfin hsep
+  have := dCoordGenerates_pkg k x hx hfin hsep
+  have rr := riemannRoch_and_constantsAreBase_pkg k x hx hfin hsep
+  rw [← genus_eq_genusFF_pkg k x hx hfin hsep]
+  exact AlgebraicCurve.degree_canonicalDivisor_eq_of_riemannRoch rr.1 rr.2 hω
+
+end Package
+
+section Bridge
+
+variable {K : Type u} {F : Type v} [Field K] [Field F] [Algebra K F] [PerfectField K]
+  (x : F) [FiniteDimensional K⟮x⟯ F]
+
+omit [PerfectField K] [FiniteDimensional K⟮x⟯ F] in
+theorem exists_dCoord_eq_D (v : Place K F) : ∃ t : F, v.ord t = 1 ∧ v.dCoord = D K F t :=
+  ⟨((IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose : F),
+    v.ord_coe_irreducible
+      (IsDiscreteValuationRing.exists_irreducible v.toValuationSubring).choose_spec, rfl⟩
+
+omit [PerfectField K] [FiniteDimensional K⟮x⟯ F] in
+theorem coeff_unique {η : Ω[F⁄K]} (hη : η ≠ 0) {a b : F} (h : a • η = b • η) : a = b := by
+  have h0 : (a - b) • η = 0 := by rw [sub_smul, h, sub_self]
+  rcases smul_eq_zero.mp h0 with h1 | h1
+  · exact sub_eq_zero.mp h1
+  · exact absurd h1 hη
+
+include x in
+theorem ordDiff_eq_ordDifferential (v : Place K F) [v.DCoordGenerates] [Nontrivial Ω[F⁄K]]
+    (ω : Ω[F⁄K]) : v.ordDiff ω = v.ordDifferential ω := by
+  obtain ⟨t₂, ht₂, hdc⟩ := exists_dCoord_eq_D v
+  have ht₁ : v.ord v.uniformizer_alt = 1 := v.ord_uniformizer_alt v.exists_ord_eq_one
+  have hc_smul : Place.diffCoeff v.uniformizer_alt (D K F t₂) • D K F v.uniformizer_alt = D K F t₂
+    :=
+    Place.diffCoeff_smul_D_of_ord_eq_one x v ht₁ _
+  have hc'_smul : Place.diffCoeff t₂ (D K F v.uniformizer_alt) • D K F t₂ = D K F v.uniformizer_alt
+    :=
+    Place.diffCoeff_smul_D_of_ord_eq_one x v ht₂ _
+  have hD₁ : D K F v.uniformizer_alt ≠ 0 := Place.D_ne_zero_of_ord_eq_one x v ht₁
+  have hcc' : Place.diffCoeff t₂ (D K F v.uniformizer_alt) *
+      Place.diffCoeff v.uniformizer_alt (D K F t₂) = 1 := by
+    refine coeff_unique hD₁ ?_
+    rw [mul_smul, hc_smul, hc'_smul, one_smul]
+  have hc0 : Place.diffCoeff v.uniformizer_alt (D K F t₂) ≠ 0 := by
+    intro h0
+    rw [h0, mul_zero] at hcc'
+    exact zero_ne_one hcc'
+  have hc'0 : Place.diffCoeff t₂ (D K F v.uniformizer_alt) ≠ 0 := by
+    intro h0
+    rw [h0, zero_mul] at hcc'
+    exact zero_ne_one hcc'
+  have hordc : v.ord (Place.diffCoeff v.uniformizer_alt (D K F t₂)) = 0 := by
+    have h1 : 0 ≤ v.ord (Place.diffCoeff v.uniformizer_alt (D K F t₂)) :=
+      Place.ord_diffCoeff_D_nonneg_of_perfectField x v ht₁ (by rw [ht₂]; exact zero_le_one)
+    have h2 : 0 ≤ v.ord (Place.diffCoeff t₂ (D K F v.uniformizer_alt)) :=
+      Place.ord_diffCoeff_D_nonneg_of_perfectField x v ht₂ (by rw [ht₁]; exact zero_le_one)
+    have h3 := v.ord_mul hc'0 hc0
+    rw [hcc', v.ord_one] at h3
+    omega
+  have ha : Place.diffCoeff v.uniformizer_alt ω • D K F v.uniformizer_alt = ω :=
+    Place.diffCoeff_smul_D_of_ord_eq_one x v ht₁ ω
+  have hb : v.differentialCoeff ω • v.dCoord = ω := v.differentialCoeff_smul_dCoord ω
+  have hab : Place.diffCoeff v.uniformizer_alt ω =
+      v.differentialCoeff ω * Place.diffCoeff v.uniformizer_alt (D K F t₂) := by
+    refine coeff_unique hD₁ ?_
+    rw [ha, mul_smul, hc_smul, ← hdc, hb]
+  rw [Place.ordDiff_def, Place.ordDifferential, hab]
+  rcases eq_or_ne (v.differentialCoeff ω) 0 with hb0 | hb0
+  · rw [hb0, zero_mul]
+  · rw [v.ord_mul hb0 hc0, hordc, add_zero]
+
+end Bridge
+
+section Identity
+
+variable (k : Type u) [Field k] [IsAlgClosed k] {F : Type v} [Field F] [Algebra k F]
+
+theorem exists_sum_ordDiff_D_eq (x : F) (hx : Transcendental k x)
+    (hfin : FiniteDimensional (IntermediateField.adjoin k ({x} : Set F)) F)
+    (hsep : Algebra.IsSeparable (IntermediateField.adjoin k ({x} : Set F)) F) :
+    ∃ S : Finset (Place k F), (∀ P, P ∉ S → P.ordDiff (KaehlerDifferential.D k F x) = 0) ∧
+      ∑ P ∈ S, P.ordDiff (KaehlerDifferential.D k F x) = 2 * (genusFF k F : ℤ) - 2 := by
+  classical
+  have hC : IsCurveOver k F := isCurveOver_pkg k x hx hfin hsep
+  have hK : HasCanonicalDivisor (K := k) (F := F) := hasCanonicalDivisor_pkg k x hx hfin hsep
+  have hG : ∀ v : Place k F, v.DCoordGenerates := dCoordGenerates_pkg k x hx hfin hsep
+  have := hfin
+  have hω : KaehlerDifferential.D k F x ≠ 0 :=
+    KaehlerDifferential.D_ne_zero_of_transcendental k x hx
+  have hWapp : ∀ P : Place k F, canonicalDivisorOf hω P = P.ordDiff (D k F x) := fun P => by
+    rw [canonicalDivisorOf_apply, ordDiff_eq_ordDifferential x P]
+  have hWdeg : (canonicalDivisorOf hω).degree = 2 * (genusFF k F : ℤ) - 2 :=
+    degree_canonical_pkg k x hx hfin hsep hω
+  have hdeg1 : ∀ P : Place k F, P.deg = 1 := IsCurveOver.forall_deg_eq_one_of_isAlgClosed
+  refine ⟨(canonicalDivisorOf hω).support, fun P hP => ?_, ?_⟩
+  · rw [← hWapp]; exact Finsupp.notMem_support_iff.mp hP
+  · rw [← hWdeg, degree_eq_sum_support]
+    exact (Finset.sum_congr rfl fun P _ => by rw [hWapp, hdeg1, Nat.cast_one, mul_one]).symm
+
+end Identity
+
+section Generic
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem ord_sub_algebraMap_of_ord_neg (v : Place K F) {x : F} (c : K) (hx : v.ord x < 0) :
+    v.ord (x - algebraMap K F c) = v.ord x := by
+  rcases eq_or_ne c 0 with rfl | hc
+  · simp
+  have hx0 : x ≠ 0 := by rintro rfl; simp at hx
+  have hc0 : algebraMap K F c ≠ 0 := (map_ne_zero _).mpr hc
+  have hxc : x - algebraMap K F c ≠ 0 := by
+    intro h
+    have : v.ord x = 0 := by
+      rw [sub_eq_zero.mp h]; exact v.ord_algebraMap c
+    omega
+  have h1 := v.min_ord_le_ord_add hx0 (neg_ne_zero.mpr hc0) (by rwa [← sub_eq_add_neg])
+  rw [← sub_eq_add_neg, ← map_neg, v.ord_algebraMap] at h1
+  have h2 := v.min_ord_le_ord_add hxc hc0 (by rw [sub_add_cancel]; exact hx0)
+  rw [sub_add_cancel, v.ord_algebraMap] at h2
+  omega
+
+theorem ord_neg_of_ord_sub_algebraMap_neg (v : Place K F) {x : F} (c : K)
+    (hx : v.ord (x - algebraMap K F c) < 0) : v.ord x < 0 := by
+  rcases eq_or_ne c 0 with rfl | hc
+  · simpa using hx
+  have hc0 : algebraMap K F c ≠ 0 := (map_ne_zero _).mpr hc
+  have hxc : x - algebraMap K F c ≠ 0 := by rintro h; rw [h] at hx; simp at hx
+  have hx0 : x ≠ 0 := by
+    rintro rfl
+    rw [zero_sub, ← map_neg, v.ord_algebraMap] at hx
+    exact lt_irrefl _ hx
+  have h2 := v.min_ord_le_ord_add hxc hc0 (by rw [sub_add_cancel]; exact hx0)
+  rw [sub_add_cancel, v.ord_algebraMap] at h2
+  by_contra h
+  have h1 := v.min_ord_le_ord_add hx0 (neg_ne_zero.mpr hc0) (by rwa [← sub_eq_add_neg])
+  rw [← sub_eq_add_neg, ← map_neg, v.ord_algebraMap] at h1
+  omega
+
+theorem ord_nonneg_of_ord_sub_algebraMap_pos (v : Place K F) {x : F} (c : K)
+    (h : 0 < v.ord (x - algebraMap K F c)) : 0 ≤ v.ord x := by
+  by_contra hneg
+  have := ord_sub_algebraMap_of_ord_neg v c (not_le.mp hneg)
+  omega
+
+theorem not_ord_sub_pos_of_ord_sub_pos (v : Place K F) {x : F} {c c' : K} (hcc' : c ≠ c')
+    (h : 0 < v.ord (x - algebraMap K F c)) : ¬ 0 < v.ord (x - algebraMap K F c') := by
+  intro h'
+  have hne : x - algebraMap K F c ≠ 0 := by rintro hh; rw [hh] at h; simp at h
+  have hne' : x - algebraMap K F c' ≠ 0 := by rintro hh; rw [hh] at h'; simp at h'
+  have hd : algebraMap K F (c' - c) ≠ 0 := (map_ne_zero _).mpr (sub_ne_zero.mpr hcc'.symm)
+  have hsum : (x - algebraMap K F c) + -(x - algebraMap K F c') = algebraMap K F (c' - c) := by
+    rw [map_sub]; ring
+  have key := v.min_ord_le_ord_add hne (neg_ne_zero.mpr hne') (by rw [hsum]; exact hd)
+  rw [hsum, v.ord_algebraMap] at key
+  have : v.ord (-(x - algebraMap K F c')) = v.ord (x - algebraMap K F c') := by
+    rw [show -(x - algebraMap K F c') = (x - algebraMap K F c') * (-1) by ring,
+      v.ord_mul hne' (by norm_num), show (-1 : F) = algebraMap K F (-1) by simp,
+      v.ord_algebraMap, add_zero]
+  rw [this] at key
+  have hmin : 0 < min (v.ord (x - algebraMap K F c)) (v.ord (x - algebraMap K F c')) := lt_min h h'
+  omega
+
+theorem exists_finset_zeros [HasPrincipalDivisors K F] {f : F} (hf : f ≠ 0) :
+    ∃ T : Finset (Place K F), ∀ v, v ∈ T ↔ 0 < v.ord f := by
+  classical
+  obtain ⟨D, hD, -⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf
+  refine ⟨D.support.filter fun v => 0 < D v, fun v => ?_⟩
+  rw [Finset.mem_filter, Finsupp.mem_support_iff, hD v]
+  exact ⟨fun h => h.2, fun h => ⟨by omega, h⟩⟩
+
+theorem exists_finset_poles [HasPrincipalDivisors K F] {f : F} (hf : f ≠ 0) :
+    ∃ T : Finset (Place K F), ∀ v, v ∈ T ↔ v.ord f < 0 := by
+  classical
+  obtain ⟨D, hD, -⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf
+  refine ⟨D.support.filter fun v => D v < 0, fun v => ?_⟩
+  rw [Finset.mem_filter, Finsupp.mem_support_iff, hD v]
+  exact ⟨fun h => h.2, fun h => ⟨by omega, h⟩⟩
+
+theorem natCard_subtype_eq_card {γ : Type*} (T : Finset γ) (p : γ → Prop)
+    (hT : ∀ v, v ∈ T ↔ p v) : Nat.card {v // p v} = T.card := by
+  classical
+  have e : {v // p v} ≃ {v // v ∈ T} := Equiv.subtypeEquivRight fun v => (hT v).symm
+  rw [Nat.card_congr e, Nat.card_eq_fintype_card, Fintype.card_coe]
+
+theorem ord_pos_of_mem_maximalIdeal (v : Place K F) {f : F} (hf0 : f ≠ 0)
+    (hf : f ∈ v.toValuationSubring)
+    (hmax : (⟨f, hf⟩ : v.toValuationSubring) ∈ IsLocalRing.maximalIdeal v.toValuationSubring) :
+    0 < v.ord f := by
+  have hle : v.adicValuation f ≤ 1 := v.adicValuation_le_one_of_mem hf
+  have hne : v.adicValuation f ≠ 1 := by
+    intro h1
+    have hu : IsUnit (⟨f, hf⟩ : v.toValuationSubring) :=
+      (v.adicValuation_coe_eq_one_iff ⟨f, hf⟩).mp h1
+    exact (IsLocalRing.mem_maximalIdeal _).mp hmax hu
+  have hlt : v.adicValuation f < 1 := lt_of_le_of_ne hle hne
+  rw [v.adicValuation_eq_exp_neg_ord hf0, ← WithZero.exp_zero, WithZero.exp_lt_exp] at hlt
+  omega
+
+theorem mem_of_ord_nonneg (v : Place K F) {f : F} (h : 0 ≤ v.ord f) : f ∈ v.toValuationSubring := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact v.toValuationSubring.zero_mem
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf0 hπ
+  rw [hu]
+  obtain ⟨n, hn⟩ := Int.eq_ofNat_of_zero_le h
+  rw [hn, zpow_natCast]
+  exact mul_mem (u : v.toValuationSubring).2 (pow_mem π.2 n)
+
+variable [IsAlgClosed K] [IsCurveOver K F]
+
+theorem exists_ord_sub_algebraMap_pos (v : Place K F) {x : F} (hx : Transcendental K x)
+    (h : 0 ≤ v.ord x) : ∃ c : K, 0 < v.ord (x - algebraMap K F c) := by
+  have hxmem : x ∈ v.toValuationSubring := mem_of_ord_nonneg v h
+  have : Module.Finite K v.ResidueField := IsCurveOver.finiteResidue v
+  have : Algebra.IsIntegral K v.ResidueField := Algebra.IsIntegral.of_finite K v.ResidueField
+  have hbij : Function.Bijective (algebraMap K v.ResidueField) :=
+    IsAlgClosed.algebraMap_bijective_of_isIntegral
+  obtain ⟨c, hc⟩ := hbij.2 (IsLocalRing.residue v.toValuationSubring ⟨x, hxmem⟩)
+  refine ⟨c, ?_⟩
+  have hsub_mem : x - algebraMap K F c ∈ v.toValuationSubring :=
+    v.toValuationSubring.sub_mem hxmem (v.algebraMap_mem' c)
+  have hne : x - algebraMap K F c ≠ 0 := by
+    intro h0
+    apply hx
+    rw [sub_eq_zero] at h0
+    rw [h0]; exact isAlgebraic_algebraMap c
+  refine ord_pos_of_mem_maximalIdeal v hne hsub_mem ?_
+  rw [← IsLocalRing.residue_eq_zero_iff]
+  have hres : IsLocalRing.residue v.toValuationSubring ⟨x - algebraMap K F c, hsub_mem⟩ =
+      IsLocalRing.residue v.toValuationSubring ⟨x, hxmem⟩ -
+        IsLocalRing.residue v.toValuationSubring (algebraMap K v.toValuationSubring c) := by
+    rw [← map_sub]
+    congr 1
+  rw [hres, ← hc]
+  change algebraMap K v.ResidueField c -
+    (IsLocalRing.residue v.toValuationSubring) (algebraMap K v.toValuationSubring c) = 0
+  rw [sub_eq_zero]
+  rfl
+
+theorem degree_eq_sum_support' (D : Divisor K F) :
+    Divisor.degree D = ∑ v ∈ D.support, D v := by
+  rw [degree_eq_sum_support]
+  refine Finset.sum_congr rfl fun v _ => ?_
+  rw [IsCurveOver.deg_eq_one_of_isAlgClosed v]; simp
+
+theorem sum_ord_sub_algebraMap_eq_finrank {x : F} (hx : Transcendental K x)
+    [FiniteDimensional K⟮x⟯ F] (c : K)
+    (T : Finset (Place K F)) (hT : ∀ v, v ∈ T ↔ 0 < v.ord (x - algebraMap K F c)) :
+    ∑ v ∈ T, v.ord (x - algebraMap K F c) = (Module.finrank K⟮x⟯ F : ℤ) := by
+  classical
+  set f := x - algebraMap K F c with hf
+  have hf0 : f ≠ 0 := by
+    intro h
+    apply hx
+    rw [hf, sub_eq_zero] at h
+    rw [h]; exact isAlgebraic_algebraMap c
+  obtain ⟨D, hD, hdeg⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf0
+  set Dinf : Divisor K F := -(D.filter fun v => D v < 0) with hDinf
+  have hDinf_apply : ∀ v, Dinf v = max 0 (-v.ord x) := by
+    intro v
+    rw [hDinf, Finsupp.neg_apply, Finsupp.filter_apply]
+    split_ifs with h
+    · rw [hD v] at h
+      have hx' := ord_neg_of_ord_sub_algebraMap_neg v c h
+      rw [hD v, ord_sub_algebraMap_of_ord_neg v c hx', max_eq_right (by omega)]
+    · rw [hD v] at h
+      have : 0 ≤ v.ord x := by
+        by_contra hneg
+        exact h (by rw [ord_sub_algebraMap_of_ord_neg v c (by omega)]; omega)
+      rw [neg_zero, max_eq_left (by omega)]
+  have hdegInf := degree_poleDivisor_eq_finrank_adjoin_of_isAlgClosed_of_transcendental x hx Dinf
+    hDinf_apply
+  have hsplit : (D.filter fun v => 0 < D v) + (D.filter fun v => D v < 0) = D := by
+    ext v
+    rw [Finsupp.add_apply, Finsupp.filter_apply, Finsupp.filter_apply]
+    split_ifs with h1 h2 <;> omega
+  have hdegpos : Divisor.degree (D.filter fun v => 0 < D v) = (Module.finrank K⟮x⟯ F : ℤ) := by
+    have h := congrArg Divisor.degree hsplit
+    rw [map_add, hdeg] at h
+    have h2 : Divisor.degree (D.filter fun v => D v < 0) = -Divisor.degree Dinf := by
+      rw [hDinf, map_neg, neg_neg]
+    rw [h2, hdegInf] at h
+    linarith
+  rw [degree_eq_sum_support', Finsupp.support_filter] at hdegpos
+  have hTeq : T = D.support.filter fun v => 0 < D v := by
+    ext v
+    rw [hT, Finset.mem_filter, Finsupp.mem_support_iff, hD v]
+    constructor
+    · intro h; exact ⟨by omega, h⟩
+    · intro h; exact h.2
+  rw [hTeq, ← hdegpos]
+  refine Finset.sum_congr rfl fun v hv => ?_
+  rw [Finsupp.filter_apply, ite_eq_left (Finset.mem_filter.mp hv).2, hD v]
+
+theorem sum_neg_ord_eq_finrank {x : F} (hx : Transcendental K x)
+    [FiniteDimensional K⟮x⟯ F]
+    (T : Finset (Place K F)) (hT : ∀ v, v ∈ T ↔ v.ord x < 0) :
+    ∑ v ∈ T, (-v.ord x) = (Module.finrank K⟮x⟯ F : ℤ) := by
+  classical
+  have hx0 : x ≠ 0 := by
+    rintro rfl; exact hx isAlgebraic_zero
+  obtain ⟨D, hD, -⟩ := HasPrincipalDivisors.exists_divisor (K := K) x hx0
+  set Dinf : Divisor K F := -(D.filter fun v => D v < 0) with hDinf
+  have hDinf_apply : ∀ v, Dinf v = max 0 (-v.ord x) := by
+    intro v
+    rw [hDinf, Finsupp.neg_apply, Finsupp.filter_apply, hD v]
+    split_ifs with h
+    · rw [max_eq_right (by omega)]
+    · rw [neg_zero, max_eq_left (by omega)]
+  have hdegInf := degree_poleDivisor_eq_finrank_adjoin_of_isAlgClosed_of_transcendental x hx Dinf
+    hDinf_apply
+  rw [degree_eq_sum_support'] at hdegInf
+  have hTeq : T = Dinf.support := by
+    ext v
+    rw [hT, Finsupp.mem_support_iff, hDinf_apply]
+    constructor
+    · intro h; exact (lt_max_of_lt_right (by omega)).ne'
+    · intro h
+      by_contra h'
+      exact h (max_eq_left (by omega))
+  rw [hTeq, ← hdegInf]
+  refine Finset.sum_congr rfl fun v hv => ?_
+  rw [hDinf_apply]
+  rw [Finsupp.mem_support_iff, hDinf_apply] at hv
+  rcases le_or_gt 0 (v.ord x) with h | h
+  · exact absurd (max_eq_left (by omega : -v.ord x ≤ 0)) hv
+  · rw [max_eq_right (by omega)]
+
+end Generic
+
+section Descent
+
+local instance isAlgebraicQbar_rh : Algebra.IsAlgebraic ℚ (AlgebraicClosure ℚ) :=
+  AlgebraicClosure.isAlgebraic ℚ
+
+def iota : AlgebraicClosure ℚ →ₐ[ℚ] ℂ := IsAlgClosed.lift
+
+local notation "ℚbar" => AlgebraicClosure ℚ
+
+variable (F₀ : IntermediateField ℚ (LaurentSeries ℚ))
+
+theorem coeffMap_iota_coeffEmb (y : LaurentSeries ℚ) :
+    coeffMap (iota : ℚbar →+* ℂ) (coeffEmb ℚbar y) = coeffEmb ℂ y := by
+  rw [coeffEmb, coeffEmb, coeffMap_coeffMap]
+  refine coeffMap_congr ?_ y
+  ext c
+  simp
+
+theorem coeffMap_iota_algebraMap (c : ℚbar) :
+    coeffMap (iota : ℚbar →+* ℂ) (algebraMap ℚbar (LaurentSeries ℚbar) c) =
+      algebraMap ℂ (LaurentSeries ℂ) (iota c) := by
+  rw [algebraMap_laurentSeries_eq_single, algebraMap_laurentSeries_eq_single, coeffMap_single]
+  rfl
+
+theorem coeffMap_iota_mem {x : LaurentSeries ℚbar} (hx : x ∈ laurentBaseChange ℚbar F₀) :
+    coeffMap (iota : ℚbar →+* ℂ) x ∈ laurentBaseChange ℂ F₀ := by
+  rw [mem_laurentBaseChange_iff] at hx
+  refine Subfield.closure_induction (p := fun x _ => coeffMap (iota : ℚbar →+* ℂ) x ∈
+      laurentBaseChange ℂ F₀) ?_ (by simp) ?_ ?_ ?_ ?_ hx
+  · rintro x (⟨c, rfl⟩ | ⟨y, hy, rfl⟩)
+    · rw [coeffMap_iota_algebraMap]
+      exact (laurentBaseChange ℂ F₀).algebraMap_mem _
+    · rw [coeffMap_iota_coeffEmb]
+      exact coeffEmb_mem_laurentBaseChange ℂ hy
+  · intro x y _ _ hx hy; rw [map_add]; exact add_mem hx hy
+  · intro x _ hx; rw [map_neg]; exact neg_mem hx
+  · intro x _ hx; rw [map_inv₀]; exact inv_mem hx
+  · intro x y _ _ hx hy; rw [map_mul]; exact mul_mem hx hy
+
+def psi : laurentBaseChange ℚbar F₀ →+* laurentBaseChange ℂ F₀ where
+  toFun x := ⟨coeffMap (iota : ℚbar →+* ℂ) x, coeffMap_iota_mem F₀ x.2⟩
+  map_one' := Subtype.ext (map_one _)
+  map_mul' _ _ := Subtype.ext (map_mul _ _ _)
+  map_zero' := Subtype.ext (map_zero _)
+  map_add' _ _ := Subtype.ext (map_add _ _ _)
+
+@[scoped simp] theorem coe_psi (x : laurentBaseChange ℚbar F₀) :
+    (psi F₀ x : LaurentSeries ℂ) = coeffMap (iota : ℚbar →+* ℂ) x := rfl
+
+theorem psi_algebraMap (c : ℚbar) :
+    psi F₀ (algebraMap ℚbar (laurentBaseChange ℚbar F₀) c) =
+      algebraMap ℂ (laurentBaseChange ℂ F₀) (iota c) :=
+  Subtype.ext (coeffMap_iota_algebraMap c)
+
+theorem psi_coeffEmb (y : LaurentSeries ℚ) (hy : y ∈ F₀) :
+    psi F₀ ⟨coeffEmb ℚbar y, coeffEmb_mem_laurentBaseChange ℚbar hy⟩ =
+      ⟨coeffEmb ℂ y, coeffEmb_mem_laurentBaseChange ℂ hy⟩ :=
+  Subtype.ext (coeffMap_iota_coeffEmb y)
+
+theorem exists_place_complex_ord_eq (Γ : Subgroup SL(2, ℤ)) [Γ.FiniteIndex]
+    (hT : ModularGroup.T ∈ Γ)
+    (v : Place ℚbar (laurentBaseChange ℚbar (qExpFunctionFieldC ℚ Γ))) :
+    ∃ v' : Place ℂ (laurentBaseChange ℂ (qExpFunctionFieldC ℚ Γ)),
+      ∀ f, v'.ord (psi (qExpFunctionFieldC ℚ Γ) f) = v.ord f := by
+  let F₀ := qExpFunctionFieldC ℚ Γ
+  let : Algebra (laurentBaseChange ℚbar F₀) (laurentBaseChange ℂ F₀) := (psi F₀).toAlgebra
+  let : Algebra ℚbar ℂ := (iota : ℚbar →+* ℂ).toAlgebra
+  let : Algebra ℚbar (laurentBaseChange ℂ F₀) :=
+    ((algebraMap ℂ (laurentBaseChange ℂ F₀)).comp (iota : ℚbar →+* ℂ)).toAlgebra
+  have : IsScalarTower ℚbar ℂ (laurentBaseChange ℂ F₀) :=
+    IsScalarTower.of_algebraMap_eq fun _ => rfl
+  have : IsScalarTower ℚbar (laurentBaseChange ℚbar F₀) (laurentBaseChange ℂ F₀) := by
+    refine IsScalarTower.of_algebraMap_eq fun c => ?_
+    change algebraMap ℂ (laurentBaseChange ℂ F₀) (iota c) = psi F₀ (algebraMap ℚbar _ c)
+    rw [psi_algebraMap]
+  have hfg : ∃ x : laurentBaseChange ℚbar F₀, Transcendental ℚbar x ∧
+      FiniteDimensional (IntermediateField.adjoin ℚbar ({x} : Set _)) (laurentBaseChange ℚbar F₀) :=
+    JOneES.exists_transcendental_finiteDimensional_laurentBaseChange ℚbar Γ hT
+  have hfg' : ∃ x : laurentBaseChange ℂ F₀, Transcendental ℂ x ∧
+      FiniteDimensional (IntermediateField.adjoin ℂ ({x} : Set _)) (laurentBaseChange ℂ F₀) :=
+    JOneES.exists_transcendental_finiteDimensional_laurentBaseChange ℂ Γ hT
+  have : IsCurveOver ℚbar (laurentBaseChange ℚbar F₀) := by
+    obtain ⟨x, hx, hfin⟩ := hfg
+    exact isCurveOver_of_transcendental_of_perfectField hx hfin
+  have hgen : IntermediateField.adjoin ℂ
+      (Set.range (algebraMap (laurentBaseChange ℚbar F₀) (laurentBaseChange ℂ F₀))) = ⊤ := by
+    apply le_antisymm le_top
+    have h1 : laurentBaseChange ℂ F₀ ≤ (IntermediateField.adjoin ℂ
+        (Set.range (algebraMap (laurentBaseChange ℚbar F₀) (laurentBaseChange ℂ F₀)))).map
+          (laurentBaseChange ℂ F₀).val := by
+      refine IntermediateField.adjoin_le_iff.mpr ?_
+      rintro _ ⟨y, hy, rfl⟩
+      refine ⟨⟨coeffEmb ℂ y, coeffEmb_mem_laurentBaseChange ℂ hy⟩, ?_, rfl⟩
+      apply IntermediateField.subset_adjoin
+      exact ⟨⟨coeffEmb ℚbar y, coeffEmb_mem_laurentBaseChange ℚbar hy⟩, psi_coeffEmb F₀ y hy⟩
+    intro x _
+    obtain ⟨y, hy, hyx⟩ := h1 x.2
+    have : y = x := Subtype.ext hyx
+    rwa [← this]
+  obtain ⟨v', -, hord, -⟩ :=
+    Place.exists_comap_algebraMap_eq_of_constantFieldExtension ℚbar (laurentBaseChange ℚbar F₀) ℂ
+      (laurentBaseChange ℂ F₀) hfg hfg' hgen v
+  exact ⟨v', hord⟩
+
+end Descent
+
+section Unramified
+
+local notation "ℚbar" => AlgebraicClosure ℚ
+
+variable (M : ℕ) [NeZero M] (Γ : Subgroup SL(2, ℤ)) (hΓ : CongruenceSubgroup.Gamma1 M ≤ Γ)
+
+omit [NeZero M] in
+theorem T_mem_Gamma1 : ModularGroup.T ∈ CongruenceSubgroup.Gamma1 M := by
+  rw [CongruenceSubgroup.Gamma1_mem]
+  simp [ModularGroup.T]
+
+include hΓ in
+theorem ord_sub_algebraMap_le_one
+    (y : laurentBaseChange ℚbar (qExpFunctionFieldC ℚ Γ))
+    (hy : (y : LaurentSeries ℚbar) = jqModC ℚbar) (a : ℚbar) (ha₀ : a ≠ 0) (ha₁ : a ≠ 1728)
+    (P : Place ℚbar (laurentBaseChange ℚbar (qExpFunctionFieldC ℚ Γ))) :
+    P.ord (y - algebraMap ℚbar _ a) ≤ 1 := by
+  have : Γ.FiniteIndex := Subgroup.finiteIndex_of_le hΓ
+  have hT : ModularGroup.T ∈ Γ := hΓ (T_mem_Gamma1 M)
+  obtain ⟨P', hP'⟩ := exists_place_complex_ord_eq Γ hT P
+  rw [← hP', map_sub, psi_algebraMap]
+  have hy' : ((psi (qExpFunctionFieldC ℚ Γ) y : laurentBaseChange ℂ (qExpFunctionFieldC ℚ Γ)) :
+      LaurentSeries ℂ) = jqModC ℂ := by
+    rw [coe_psi, hy]
+    exact map_jqModC _
+  have hinj : Function.Injective (iota : ℚbar →+* ℂ) := (iota : ℚbar →+* ℂ).injective
+  have h₀ : (iota : ℚbar →+* ℂ) a ≠ 0 := by
+    intro h; exact ha₀ (hinj (by rw [h, map_zero]))
+  have h₁ : (iota : ℚbar →+* ℂ) a ≠ 1728 := by
+    intro h; exact ha₁ (hinj (by rw [h, map_ofNat]))
+  exact ord_sub_algebraMap_le_one_laurentBaseChange_qExpFunctionFieldC_of_ne_zero_of_ne_1728 M Γ hΓ
+    (psi (qExpFunctionFieldC ℚ Γ) y) hy' _ h₀ h₁ P'
+
+end Unramified
+
+section Main
+
+local notation "ℚbar" => AlgebraicClosure ℚ
+
+variable (M : ℕ) [NeZero M] (Γ : Subgroup SL(2, ℤ)) (hΓ : CongruenceSubgroup.Gamma1 M ≤ Γ)
+
+local notation "FF" => laurentBaseChange (AlgebraicClosure ℚ) (qExpFunctionFieldC ℚ Γ)
+
+theorem sum_eq_sum_of_vanish {ι : Type*} (f : ι → ℤ) (S U : Finset ι)
+    (hS : ∀ P, P ∉ S → f P = 0) (hU : ∀ P, P ∉ U → f P = 0) :
+    ∑ P ∈ S, f P = ∑ P ∈ U, f P := by
+  classical
+  have h1 : ∑ P ∈ S, f P = ∑ P ∈ S ∪ U, f P :=
+    Finset.sum_subset Finset.subset_union_left fun P _ hPS => hS P hPS
+  have h2 : ∑ P ∈ U, f P = ∑ P ∈ S ∪ U, f P :=
+    Finset.sum_subset Finset.subset_union_right fun P _ hPU => hU P hPU
+  rw [h1, h2]
+
+include hΓ in
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+theorem main (y : FF) (hy : (y : LaurentSeries ℚbar) = jqModC ℚbar) :
+    2 * genusFF ℚbar FF + Nat.card {P : Place ℚbar FF // P.ord y < 0} +
+        Nat.card {P : Place ℚbar FF // 0 < P.ord y} +
+        Nat.card {P : Place ℚbar FF // 0 < P.ord (y - 1728)} ≤
+      Module.finrank ℚbar⟮y⟯ FF + 2 := by
+  classical
+  have : Γ.FiniteIndex := Subgroup.finiteIndex_of_le hΓ
+  have hT : ModularGroup.T ∈ Γ := hΓ (T_mem_Gamma1 M)
+  have hytr : Transcendental ℚbar y := by
+    have h := transcendental_jqModC ℚbar
+    rw [← hy] at h
+    exact (transcendental_algebraMap_iff (R := ℚbar) (A := LaurentSeries ℚbar) (S := ↥FF)
+      Subtype.val_injective).mp h
+  obtain ⟨x₀, hx₀, hx₀fin⟩ :=
+    JOneES.exists_transcendental_finiteDimensional_laurentBaseChange ℚbar Γ hT
+  have := hx₀fin
+  have hfin : FiniteDimensional ℚbar⟮y⟯ FF := finiteDimensional_adjoin_of_transcendental x₀ hytr
+  have hsep : Algebra.IsSeparable ℚbar⟮y⟯ FF := Algebra.IsAlgebraic.isSeparable_of_perfectField
+  have hC : IsCurveOver ℚbar FF := isCurveOver_of_transcendental_of_perfectField hytr hfin
+  obtain ⟨S, hS0, hSsum⟩ := exists_sum_ordDiff_D_eq ℚbar y hytr hfin hsep
+  have hy0 : (y : FF) ≠ 0 := fun h => hytr (h ▸ isAlgebraic_zero)
+  have h1728F : (1728 : FF) = algebraMap ℚbar FF 1728 := (map_ofNat _ 1728).symm
+  have hy1728 : y - algebraMap ℚbar FF 1728 ≠ 0 := by
+    intro h
+    apply hytr
+    rw [sub_eq_zero] at h
+    rw [h]; exact isAlgebraic_algebraMap _
+  obtain ⟨Z₀, hZ₀⟩ := exists_finset_zeros (K := ℚbar) hy0
+  obtain ⟨Z₁, hZ₁⟩ := exists_finset_zeros (K := ℚbar) hy1728
+  obtain ⟨Pinf, hPinf⟩ := exists_finset_poles (K := ℚbar) hy0
+  have hsum₀ : ∑ v ∈ Z₀, v.ord y = (Module.finrank ℚbar⟮y⟯ FF : ℤ) := by
+    have h := sum_ord_sub_algebraMap_eq_finrank (K := ℚbar) hytr 0 Z₀
+      (fun v => by rw [map_zero, sub_zero]; exact hZ₀ v)
+    simpa using h
+  have hsum₁ : ∑ v ∈ Z₁, v.ord (y - algebraMap ℚbar FF 1728) = (Module.finrank ℚbar⟮y⟯ FF : ℤ) :=
+    sum_ord_sub_algebraMap_eq_finrank (K := ℚbar) hytr 1728 Z₁ hZ₁
+  have hsuminf : ∑ v ∈ Pinf, (-v.ord y) = (Module.finrank ℚbar⟮y⟯ FF : ℤ) :=
+    sum_neg_ord_eq_finrank (K := ℚbar) hytr Pinf hPinf
+  set f : Place ℚbar FF → ℤ := fun v => v.ordDiff (KaehlerDifferential.D ℚbar FF y) with hf
+  have hD1728 : KaehlerDifferential.D ℚbar FF (y - algebraMap ℚbar FF 1728) =
+      KaehlerDifferential.D ℚbar FF y := by
+    rw [map_sub, Derivation.map_algebraMap, sub_zero]
+  have hf_pole : ∀ v ∈ Pinf, f v = v.ord y - 1 := fun v hv => by
+    have h : v.ord y ≠ 0 := by have := (hPinf v).mp hv; omega
+    exact Place.ordDiff_D_eq_ord_sub_one y v h
+  have hf_zero : ∀ v ∈ Z₀, f v = v.ord y - 1 := fun v hv => by
+    have h : v.ord y ≠ 0 := by have := (hZ₀ v).mp hv; omega
+    exact Place.ordDiff_D_eq_ord_sub_one y v h
+  have hf_one : ∀ v ∈ Z₁, f v = v.ord (y - algebraMap ℚbar FF 1728) - 1 := fun v hv => by
+    have h : v.ord (y - algebraMap ℚbar FF 1728) ≠ 0 := by have := (hZ₁ v).mp hv; omega
+    change v.ordDiff (KaehlerDifferential.D ℚbar FF y) = _
+    rw [← hD1728]
+    exact Place.ordDiff_D_eq_ord_sub_one y v h
+  set U : Finset (Place ℚbar FF) := Z₀ ∪ Z₁ ∪ Pinf with hU
+  have hf_off : ∀ v, v ∉ U → f v = 0 := by
+    intro v hv
+    have hv₀ : v ∉ Z₀ :=
+      fun h => hv (by rw [hU]; exact Finset.mem_union_left _ (Finset.mem_union_left _ h))
+    have hv₁ : v ∉ Z₁ :=
+      fun h => hv (by rw [hU]; exact Finset.mem_union_left _ (Finset.mem_union_right _ h))
+    have hvinf : v ∉ Pinf := fun h => hv (by rw [hU]; exact Finset.mem_union_right _ h)
+    have hreg : 0 ≤ v.ord y := by
+      by_contra h; exact hvinf ((hPinf v).mpr (not_le.mp h))
+    obtain ⟨c, hc⟩ := exists_ord_sub_algebraMap_pos (K := ℚbar) v hytr hreg
+    have hc₀ : c ≠ 0 := by
+      rintro rfl
+      rw [map_zero, sub_zero] at hc
+      exact hv₀ ((hZ₀ v).mpr hc)
+    have hc₁ : c ≠ 1728 := by
+      rintro rfl
+      exact hv₁ ((hZ₁ v).mpr hc)
+    have hle := ord_sub_algebraMap_le_one M Γ hΓ y hy c hc₀ hc₁ v
+    have heq : v.ord (y - algebraMap ℚbar FF c) = 1 := le_antisymm hle hc
+    have hDc : KaehlerDifferential.D ℚbar FF (y - algebraMap ℚbar FF c) =
+        KaehlerDifferential.D ℚbar FF y := by
+      rw [map_sub, Derivation.map_algebraMap, sub_zero]
+    change v.ordDiff (KaehlerDifferential.D ℚbar FF y) = 0
+    rw [← hDc, Place.ordDiff_D_eq_ord_sub_one y v (by rw [heq]; exact one_ne_zero), heq]
+    ring
+  have hUsum : ∑ v ∈ U, f v = 2 * (genusFF ℚbar FF : ℤ) - 2 := by
+    rw [← hSsum]
+    exact (sum_eq_sum_of_vanish f S U hS0 hf_off).symm
+  have h1728ne : (1728 : ℚbar) ≠ 0 := by norm_num
+  have hd01 : Disjoint Z₀ Z₁ := by
+    rw [Finset.disjoint_left]
+    intro v hv₀ hv₁
+    have h₀ : 0 < v.ord (y - algebraMap ℚbar FF 0) :=
+      by rw [map_zero, sub_zero]; exact (hZ₀ v).mp hv₀
+    exact not_ord_sub_pos_of_ord_sub_pos v h1728ne.symm h₀ ((hZ₁ v).mp hv₁)
+  have hd0inf : Disjoint Z₀ Pinf := by
+    rw [Finset.disjoint_left]
+    intro v hv₀ hvinf
+    have := (hZ₀ v).mp hv₀; have := (hPinf v).mp hvinf; omega
+  have hd1inf : Disjoint Z₁ Pinf := by
+    rw [Finset.disjoint_left]
+    intro v hv₁ hvinf
+    have h := ord_nonneg_of_ord_sub_algebraMap_pos v (1728 : ℚbar) ((hZ₁ v).mp hv₁)
+    have := (hPinf v).mp hvinf; omega
+  have hd01inf : Disjoint (Z₀ ∪ Z₁) Pinf := Finset.disjoint_union_left.mpr ⟨hd0inf, hd1inf⟩
+  have hsplit : ∑ v ∈ U, f v = ∑ v ∈ Z₀, f v + ∑ v ∈ Z₁, f v + ∑ v ∈ Pinf, f v := by
+    rw [hU, Finset.sum_union hd01inf, Finset.sum_union hd01]
+  have hs₀ : ∑ v ∈ Z₀, f v = (Module.finrank ℚbar⟮y⟯ FF : ℤ) - Z₀.card := by
+    rw [Finset.sum_congr rfl hf_zero, Finset.sum_sub_distrib, hsum₀]
+    simp
+  have hs₁ : ∑ v ∈ Z₁, f v = (Module.finrank ℚbar⟮y⟯ FF : ℤ) - Z₁.card := by
+    rw [Finset.sum_congr rfl hf_one, Finset.sum_sub_distrib, hsum₁]
+    simp
+  have hsinf : ∑ v ∈ Pinf, f v = -(Module.finrank ℚbar⟮y⟯ FF : ℤ) - Pinf.card := by
+    rw [Finset.sum_congr rfl hf_pole, Finset.sum_sub_distrib, ← hsuminf, Finset.sum_neg_distrib]
+    simp
+  have hc₀ : Nat.card {P : Place ℚbar FF // 0 < P.ord y} = Z₀.card :=
+    natCard_subtype_eq_card Z₀ _ hZ₀
+  have hc₁ : Nat.card {P : Place ℚbar FF // 0 < P.ord (y - 1728)} = Z₁.card := by
+    rw [h1728F]; exact natCard_subtype_eq_card Z₁ _ hZ₁
+  have hcinf : Nat.card {P : Place ℚbar FF // P.ord y < 0} = Pinf.card :=
+    natCard_subtype_eq_card Pinf _ hPinf
+  rw [hc₀, hc₁, hcinf]
+  have key : 2 * (genusFF ℚbar FF : ℤ) - 2 =
+      (Module.finrank ℚbar⟮y⟯ FF : ℤ) - Z₀.card - Z₁.card - Pinf.card := by
+    rw [← hUsum, hsplit, hs₀, hs₁, hsinf]; ring
+  omega
+
+end Main
+
+end ModularCurve.RiemannHurwitzCount
+end
+
+open AlgebraicCurve _root_.ModularCurve
+  _root_.P2MW.S_OVERLONG_7a292264.ModularCurve
+  in
+theorem solution
+    (M : ℕ) [NeZero M] (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+    (hΓ : CongruenceSubgroup.Gamma1 M ≤ Γ)
+    (y : ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ Γ))
+    (hy : (y : LaurentSeries (AlgebraicClosure ℚ)) = ModularCurve.jqModC (AlgebraicClosure ℚ)) :
+    2 * AlgebraicCurve.genusFF (AlgebraicClosure ℚ)
+          (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+            Γ)) +
+        Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+          (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+            Γ)) //
+            P.ord y < 0} +
+        Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+          (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+            Γ)) //
+            0 < P.ord y} +
+        Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+          (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+            Γ)) //
+            0 < P.ord (y - 1728)} ≤
+      Module.finrank
+          (IntermediateField.adjoin (AlgebraicClosure ℚ)
+            ({y} : Set (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+              (ModularCurve.qExpFunctionFieldC ℚ Γ))))
+          (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+            Γ)) +
+        2 :=
+  ModularCurve.RiemannHurwitzCount.main M Γ hΓ y hy
+
+end S_OVERLONG_7a292264
+end P2MW
+export P2MW.S_OVERLONG_7a292264
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularCurve.two_mul_genusFF_add_card_fibres_le_finrank_add_two_of_gamma1_le
+    (M : ℕ) [NeZero M] (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ))
+    (hΓ : CongruenceSubgroup.Gamma1 M ≤ Γ)
+    (y : ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ Γ))
+    (hy : (y : LaurentSeries (AlgebraicClosure ℚ)) = ModularCurve.jqModC (AlgebraicClosure ℚ)) :
+    2 * AlgebraicCurve.genusFF (AlgebraicClosure ℚ)
+          (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+            Γ)) +
+        Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+          (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+            Γ)) //
+            P.ord y < 0} +
+        Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+          (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+            Γ)) //
+            0 < P.ord y} +
+        Nat.card {P : AlgebraicCurve.Place (AlgebraicClosure ℚ)
+          (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+            Γ)) //
+            0 < P.ord (y - 1728)} ≤
+      Module.finrank
+          (IntermediateField.adjoin (AlgebraicClosure ℚ)
+            ({y} : Set (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ)
+              (ModularCurve.qExpFunctionFieldC ℚ Γ))))
+          (ModularCurve.laurentBaseChange (AlgebraicClosure ℚ) (ModularCurve.qExpFunctionFieldC ℚ
+            Γ)) +
+        2 :=
+  solution M Γ hΓ y hy
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_two_mul_natCard_moduliPoint_j_eq_1728_eq_dedekindPsi_add_nuTwo.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_two_mul_natCard_moduliPoint_j_eq_1728_eq_dedekindPsi_add_nuTwo.lean
new file mode 100644
index 0000000000..8f8291c1ef
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularCurve_two_mul_natCard_moduliPoint_j_eq_1728_eq_dedekindPsi_add_nuTwo.lean
@@ -0,0 +1,723 @@
+/-
+Based on Prove2Me node ModularCurve.two_mul_natCard_moduliPoint_j_eq_1728_eq_dedekindPsi_add_nuTwo
+(9d84969f-c088-5295-91e3-6d4fc3146888) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b7671b2d-7b29-53fd-8c08-ccb1a05cac88
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ModuliPoint
+
+import Mathlib.Algebra.CharP.Invertible
+import Mathlib.Algebra.Order.Monoid.NatCast
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_natCard_moduliPoint_j_eq_eq_natCard_quot_addOrderOf_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_MulAction_card_mul_natCard_orbitRel_quotient_eq_of_natCard_eq_prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_vcInvFun_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsion_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a6_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuTwo
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_variableChange_mk_smul_eq_self_of_sq_eq_neg_one
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Moduli points with j=1728: 2 #=ψ(N)+ν₂(N)
+
+Theorem statement: `ModularCurve.two_mul_natCard_moduliPoint_j_eq_1728_eq_dedekindPsi_add_nuTwo`
+(`9d84969f-c088-5295-91e3-6d4fc3146888`), by Claude, 2026-09-05.
+
+Proof: submission `b7671b2d-7b29-53fd-8c08-ccb1a05cac88`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number with $N \neq 0$ and let $L$ be an algebraically closed field equipped
+with a $\mathbb{Q}$-algebra structure (so of characteristic zero). The set `ModuliPoint N L` is the
+quotient, in the sense of `Quot`, of the type of pairs consisting of a Weierstrass curve over $L$
+that is elliptic together with a point `gen` of its affine model whose additive order is exactly
+$N$, by the relation `Gamma0Pair.Step`, which relates $P$ to $Q$ when there is a Weierstrass
+variable change $\gamma$ over $L$ carrying the curve of $P$ to the curve of $Q$ and a natural number
+$k$ coprime to $N$ with the marked point of $Q$ equal to $k$ times the image of the marked point of
+$P$ under `Point.vcInvFun` for $\gamma$; thus classes correspond to pairs (elliptic curve, cyclic
+subgroup of order $N$) up to isomorphism. The assertion is that twice the cardinality of the subtype
+of those classes $x$ with `ModuliPoint.j x` equal to $1728$, the $j$-invariant of the underlying
+curve, equals $\mathrm{dedekindPsi}(N) + \nu_2(N)$, where $\mathrm{dedekindPsi}(N) = \sum_{d \mid
+N,\ d \text{ squarefree}} N/d = N\prod_{p \mid N}(1 + 1/p)$ and $\nu_2(N)$ is the number of $x \in
+\mathbb{Z}/N$ with $x^2 + 1 = 0$.
+
+This is the moduli-theoretic form of the count of points of $Y_0(N)$ above $j = 1728$: the fibre has
+$(\psi(N) + \nu_2(N))/2$ elements, the extra order-$2$ automorphism of a curve with $j = 1728$
+pairing up the $\psi(N)$ cyclic subgroups of order $N$ except at the $\nu_2(N)$ fixed ones, which
+are the elliptic points of order $2$ of $\Gamma_0(N)$. It feeds the computations of ramification of
+$X_0(N) \to X(1)$ above $j = 1728$ and $j = 0$ used by
+[`ModularCurve.card_filter_ord_jBar_sub_1728_eq_one_eq_nuTwo`]
+(thm.html#ModularCurve.card_filter_ord_jBar_sub_1728_eq_one_eq_nuTwo),
+[`ModularCurve.natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo`]
+(thm.html#ModularCurve.natCard_ord_jBar_sub_1728_eq_one_eq_nuTwo)
+and
+[`ModularCurve.natCard_ord_jBar_eq_one_eq_nuThree`]
+(thm.html#ModularCurve.natCard_ord_jBar_eq_one_eq_nuThree).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularCurve_two_mul_natCard_moduliPoint_j_eq_1728_eq_dedekindPsi_add_nuTwo.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_ModularCurve_two_mul_natCard_moduliPoint_j_eq_1728_eq_dedekindPsi_add_nuTwo
+
+open WeierstrassCurve WeierstrassCurve.Affine ModularCurve
+
+noncomputable section
+
+namespace P2MWs13
+namespace R2a
+
+variable {L : Type*} [Field L] [DecidableEq L]
+
+def coords {W : WeierstrassCurve L} : W.toAffine.Point → Option (L × L)
+  | 0 => none
+  | .some x y _ => some (x, y)
+
+omit [DecidableEq L] in
+@[scoped simp] theorem coords_zero {W : WeierstrassCurve L} :
+    coords (0 : W.toAffine.Point) = none := rfl
+omit [DecidableEq L] in
+@[scoped simp] theorem coords_some {W : WeierstrassCurve L} {x y : L} (h : W.toAffine.Nonsingular x
+  y) :
+    coords (Point.some x y h) = some (x, y) := rfl
+
+omit [DecidableEq L] in
+theorem coords_injective {W : WeierstrassCurve L} : Function.Injective (coords (W := W)) := by
+  rintro (_ | ⟨x, y, h⟩) (_ | ⟨x', y', h'⟩) hPQ
+  · rfl
+  · simp [coords] at hPQ
+  · simp [coords] at hPQ
+  · simp only [coords_some, Option.some.injEq, Prod.mk.injEq] at hPQ
+    obtain ⟨rfl, rfl⟩ := hPQ
+    rfl
+
+omit [DecidableEq L] in
+theorem coords_eq_of_heq {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂) {P : W₁.toAffine.Point}
+    {Q : W₂.toAffine.Point}
+    (h : HEq P Q) : coords P = coords Q := by
+  subst e; rw [eq_of_heq h]
+
+def castPt {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂) : W₁.toAffine.Point ≃+ W₂.toAffine.Point := by
+  subst e; exact AddEquiv.refl _
+
+theorem heq_castPt {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂) (P : W₁.toAffine.Point) :
+    HEq P (castPt e P) := by
+  subst e; rfl
+
+theorem castPt_eq_iff_heq {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂) (P : W₁.toAffine.Point)
+    (Q : W₂.toAffine.Point) :
+    castPt e P = Q ↔ HEq P Q := by
+  subst e; exact Iff.rfl.trans heq_iff_eq.symm
+
+theorem coords_castPt {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂) (P : W₁.toAffine.Point) :
+    coords (castPt e P) = coords P := by
+  subst e; rfl
+
+def autPt {W : WeierstrassCurve L} (γ : VariableChange L) (hγ : γ • W = W) :
+    W.toAffine.Point →+ W.toAffine.Point :=
+  (castPt hγ).toAddMonoidHom.comp (AddMonoidHom.mk' (Point.vcInvFun γ W.toAffine)
+    (Point.vcInvFun_add γ W.toAffine))
+
+theorem autPt_apply {W : WeierstrassCurve L} (γ : VariableChange L) (hγ : γ • W = W)
+    (P : W.toAffine.Point) :
+    autPt γ hγ P = castPt hγ (Point.vcInvFun γ W.toAffine P) := rfl
+
+theorem autPt_eq_iff_heq {W : WeierstrassCurve L} (γ : VariableChange L) (hγ : γ • W = W)
+    (P Q : W.toAffine.Point) :
+    autPt γ hγ P = Q ↔ HEq (Point.vcInvFun γ W.toAffine P) Q := by
+  rw [autPt_apply, castPt_eq_iff_heq]
+
+theorem autPt_congr {W : WeierstrassCurve L} {γ γ' : VariableChange L} (e : γ = γ') (hγ : γ • W = W)
+    (hγ' : γ' • W = W)
+    (P : W.toAffine.Point) : autPt γ hγ P = autPt γ' hγ' P := by
+  subst e; rfl
+
+theorem autPt_injective {W : WeierstrassCurve L} (γ : VariableChange L) (hγ : γ • W = W) :
+    Function.Injective (autPt γ hγ) := by
+  intro P Q h
+  rw [autPt_apply, autPt_apply] at h
+  exact (Point.vcFun_rightInverse (C := γ) (W := W.toAffine)).injective ((castPt hγ).injective h)
+
+theorem coords_autPt {W : WeierstrassCurve L} (v : Lˣ)
+    (hγ : (⟨v, 0, 0, 0⟩ : VariableChange L) • W = W)
+    (P : W.toAffine.Point) :
+    coords (autPt ⟨v, 0, 0, 0⟩ hγ P) = (coords P).map (fun q => (((v⁻¹ : Lˣ) : L) ^ 2 * q.1, ((v⁻¹ :
+      Lˣ) : L) ^ 3 * q.2)) := by
+  rw [autPt_apply, coords_castPt]
+  rcases P with _ | ⟨x, y, h⟩
+  · rfl
+  · change some _ = some _
+    simp [WeierstrassCurve.Affine.vcXInv, WeierstrassCurve.Affine.vcYInv]
+
+abbrev W1 (L : Type*) [Field L] : WeierstrassCurve L := ⟨0, 0, 0, 1, 0⟩
+
+omit [DecidableEq L] in
+theorem W1_Δ : (W1 L).Δ = -64 := by
+  simp only [WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄, WeierstrassCurve.b₆,
+    WeierstrassCurve.b₈]; ring
+
+omit [DecidableEq L] in
+theorem coords_neg {x y : L} (h : (W1 L).toAffine.Nonsingular x y) :
+    coords (-(Point.some x y h)) = some (x, -y) := by
+  rw [Point.neg_some]; change some _ = some _; simp [WeierstrassCurve.Affine.negY]
+
+variable [Algebra ℚ L]
+
+omit [DecidableEq L] in
+theorem isElliptic_W1 : (W1 L).IsElliptic := by
+  have : CharZero L := charZero_of_injective_algebraMap (algebraMap ℚ L).injective
+  exact ⟨by rw [W1_Δ]; exact isUnit_iff_ne_zero.mpr (by norm_num)⟩
+
+omit [DecidableEq L] in
+theorem j_W1 : haveI := isElliptic_W1 (L := L); (W1 L).j = 1728 := by
+  have : CharZero L := charZero_of_injective_algebraMap (algebraMap ℚ L).injective
+  have := isElliptic_W1 (L := L)
+  have hΔ : (W1 L).Δ ≠ 0 := by rw [W1_Δ]; norm_num
+  have hc4 : (W1 L).c₄ = -48 := by
+    simp only [WeierstrassCurve.c₄, WeierstrassCurve.b₂, WeierstrassCurve.b₄]; ring
+  have hj : (W1 L).Δ * (W1 L).j = (W1 L).c₄ ^ 3 := by
+    rw [WeierstrassCurve.j, ← WeierstrassCurve.coe_Δ', ← mul_assoc, ← Units.val_mul, mul_inv_cancel,
+      Units.val_one, one_mul]
+  rw [W1_Δ, hc4] at hj
+  have : (-64 : L) * ((W1 L).j - 1728) = 0 := by linear_combination hj
+  have h64 : (-64 : L) ≠ 0 := by norm_num
+  exact sub_eq_zero.mp ((mul_eq_zero.mp this).resolve_left h64)
+
+omit [DecidableEq L] in
+theorem stab_W1 (γ : VariableChange L) (hγ : γ • W1 L = W1 L) :
+    γ.r = 0 ∧ γ.s = 0 ∧ γ.t = 0 ∧ (γ.u : L) ^ 4 = 1 := by
+  have : CharZero L := charZero_of_injective_algebraMap (algebraMap ℚ L).injective
+  have : (W1 L).IsShortNF := ⟨rfl, rfl, rfl⟩
+  exact (WeierstrassCurve.mem_stabilizer_variableChange_iff_of_isShortNF_of_a6_eq_zero (F := L)
+    two_ne_zero three_ne_zero (W1 L) rfl one_ne_zero γ).mp hγ
+
+omit [DecidableEq L] [Algebra ℚ L] in
+theorem eq_mk_of_rst {γ : VariableChange L} (h : γ.r = 0 ∧ γ.s = 0 ∧ γ.t = 0) :
+    γ = ⟨γ.u, 0, 0, 0⟩ := by
+  obtain ⟨u, r, s, t⟩ := γ
+  obtain ⟨rfl, rfl, rfl⟩ := h
+  rfl
+
+omit [DecidableEq L] [Algebra ℚ L] in
+theorem pow_four_eq_one_cases {u v : L} (hu : u ^ 2 = -1) (hv : v ^ 4 = 1) :
+    v = 1 ∨ v = -1 ∨ v = u ∨ v = -u := by
+  have : (v - 1) * (v + 1) * (v - u) * (v + u) = 0 := by
+    have e : (v - 1) * (v + 1) * (v - u) * (v + u) = (v ^ 2 - 1) * (v ^ 2 - u ^ 2) := by ring
+    rw [e, hu]; linear_combination hv
+  rcases mul_eq_zero.mp this with h | h
+  · rcases mul_eq_zero.mp h with h | h
+    · rcases mul_eq_zero.mp h with h | h
+      · left; exact sub_eq_zero.mp h
+      · right; left; exact eq_neg_of_add_eq_zero_left h
+    · right; right; left; exact sub_eq_zero.mp h
+  · right; right; right; exact eq_neg_of_add_eq_zero_left h
+
+section Cyclic
+
+variable {M : Type*} [AddCommGroup M]
+
+theorem exists_nsmul_nsmul_eq_self {N k : ℕ} (hk : k.Coprime N) {x : M} (hx : addOrderOf x = N) :
+    ∃ m : ℕ, m.Coprime N ∧ m • k • x = x := by
+  rcases Nat.eq_zero_or_pos N with hN0 | hNpos
+  · subst hN0
+    have hk1 : k = 1 := Nat.coprime_zero_right k |>.mp hk
+    exact ⟨1, Nat.coprime_one_left 0, by rw [hk1, one_nsmul, one_nsmul]⟩
+  by_cases hN1 : N = 1
+  · have hx0 : x = 0 := by
+      have h1 : addOrderOf x = 1 := by rw [hx, hN1]
+      exact AddMonoid.addOrderOf_eq_one_iff.mp h1
+    exact ⟨1, Nat.coprime_one_left N, by rw [hx0, smul_zero, smul_zero]⟩
+  · have h1N : 1 < N := by omega
+    obtain ⟨m, -, hm⟩ := Nat.exists_mul_mod_eq_one_of_coprime hk h1N
+    have hNx : N • x = 0 := by rw [← hx]; exact addOrderOf_nsmul_eq_zero x
+    have hdiv : N * (k * m / N) + 1 = k * m := by
+      have h := Nat.div_add_mod (k * m) N
+      rw [hm] at h
+      exact h
+    refine ⟨m, ?_, ?_⟩
+    · have hdm : Nat.gcd m N ∣ N * (k * m / N) + 1 := by
+        rw [hdiv]; exact Dvd.dvd.mul_left (Nat.gcd_dvd_left m N) k
+      have hdN : Nat.gcd m N ∣ N * (k * m / N) := Dvd.dvd.mul_right (Nat.gcd_dvd_right m N) _
+      exact Nat.dvd_one.mp ((Nat.dvd_add_right hdN).mp hdm)
+    · rw [← mul_nsmul x k m, ← hdiv, add_nsmul, mul_nsmul x N (k * m / N), hNx, smul_zero, zero_add,
+        one_nsmul]
+
+theorem zmultiples_nsmul_eq_of_coprime {N k : ℕ} (hk : k.Coprime N) {x : M} (hx : addOrderOf x = N)
+    :
+    AddSubgroup.zmultiples (k • x) = AddSubgroup.zmultiples x := by
+  obtain ⟨m, -, hm⟩ := exists_nsmul_nsmul_eq_self hk hx
+  refine le_antisymm ?_ ?_
+  · rintro y hy
+    obtain ⟨n, rfl⟩ := AddSubgroup.mem_zmultiples_iff.mp hy
+    exact AddSubgroup.mem_zmultiples_iff.mpr ⟨n * (k : ℤ), by rw [mul_zsmul, natCast_zsmul]⟩
+  · rintro y hy
+    obtain ⟨n, rfl⟩ := AddSubgroup.mem_zmultiples_iff.mp hy
+    exact AddSubgroup.mem_zmultiples_iff.mpr ⟨n * (m : ℤ), by rw [mul_zsmul, natCast_zsmul, hm]⟩
+
+theorem exists_coprime_nsmul_of_zmultiples_eq {N : ℕ} (hN : N ≠ 0) {x y : M} (hx : addOrderOf x = N)
+    (hy : addOrderOf y = N) (h : AddSubgroup.zmultiples y = AddSubgroup.zmultiples x) :
+    ∃ k : ℕ, k.Coprime N ∧ y = k • x := by
+  have hy' : y ∈ AddSubgroup.zmultiples x := by rw [← h]; exact AddSubgroup.mem_zmultiples y
+  obtain ⟨m, rfl⟩ := AddSubgroup.mem_zmultiples_iff.mp hy'
+  have hNx : (N : ℤ) • x = 0 := by rw [natCast_zsmul, ← hx]; exact addOrderOf_nsmul_eq_zero x
+  obtain ⟨k, hk⟩ : ∃ k : ℕ, (k : ℤ) = m % N :=
+    ⟨(m % N).toNat, Int.toNat_of_nonneg (Int.emod_nonneg _ (by exact_mod_cast hN))⟩
+  have hmk : m • x = k • x := by
+    have : m = m % N + N * (m / N) := (Int.emod_add_mul_ediv m N).symm
+    rw [← natCast_zsmul, hk]
+    conv_lhs => rw [this]
+    rw [add_zsmul, mul_zsmul', hNx, zsmul_zero, add_zero]
+  refine ⟨k, ?_, hmk⟩
+  have hzk : AddSubgroup.zmultiples (k • x) = AddSubgroup.zmultiples x := by rw [← hmk]; exact h
+  have hxmem : x ∈ AddSubgroup.zmultiples (k • x) := by rw [hzk]; exact AddSubgroup.mem_zmultiples x
+  obtain ⟨j, hj⟩ := AddSubgroup.mem_zmultiples_iff.mp hxmem
+  have hz : (j * k - 1 : ℤ) • x = 0 := by
+    rw [sub_zsmul, one_zsmul, mul_zsmul, natCast_zsmul, hj]; simp
+  have hdvd : (N : ℤ) ∣ j * k - 1 := by
+    rw [← hx]; exact addOrderOf_dvd_iff_zsmul_eq_zero.mpr hz
+  obtain ⟨t, ht⟩ := hdvd
+  have hcop : IsCoprime (k : ℤ) (N : ℤ) := ⟨j, -t, by linear_combination ht⟩
+  have hg : Int.gcd (k : ℤ) (N : ℤ) = 1 := Int.isCoprime_iff_gcd_eq_one.mp hcop
+  simpa [Int.gcd_natCast_natCast] using hg
+
+end Cyclic
+
+section Count
+
+variable [IsAlgClosed L]
+
+abbrev CycSub (L : Type*) [Field L] [DecidableEq L] (N : ℕ) : Type _ :=
+  {H : AddSubgroup (W1 L).toAffine.Point // IsAddCyclic H ∧ Nat.card H = N}
+
+omit [DecidableEq L] [Algebra ℚ L] [IsAlgClosed L] in
+theorem hσW (u : Lˣ) (hu : (u : L) ^ 2 = -1) : (⟨u, 0, 0, 0⟩ : VariableChange L) • W1 L = W1 L :=
+  WeierstrassCurve.variableChange_mk_smul_eq_self_of_sq_eq_neg_one u hu 1
+
+def σ (u : Lˣ) (hu : (u : L) ^ 2 = -1) :
+    (W1 L).toAffine.Point →+ (W1 L).toAffine.Point := autPt ⟨u, 0, 0, 0⟩ (hσW u hu)
+
+omit [DecidableEq L] [Algebra ℚ L] [IsAlgClosed L] in
+theorem hui (u : Lˣ) (hu : (u : L) ^ 2 = -1) :
+    ((u⁻¹ : Lˣ) : L) ^ 2 = -1 := by rw [Units.val_inv_eq_inv_val, inv_pow, hu]; norm_num
+
+omit [Algebra ℚ L] [IsAlgClosed L] in
+theorem coords_σ (u : Lˣ) (hu : (u : L) ^ 2 = -1) (P : (W1 L).toAffine.Point) :
+    coords (σ u hu P) = (coords P).map (fun q => (-q.1, ((u⁻¹ : Lˣ) : L) ^ 3 * q.2)) := by
+  change coords (autPt _ _ P) = _
+  rw [coords_autPt, hui u hu]
+  congr 1
+  funext q
+  simp
+
+omit [Algebra ℚ L] [IsAlgClosed L] in
+theorem σ_σ (u : Lˣ) (hu : (u : L) ^ 2 = -1) (P : (W1 L).toAffine.Point) :
+    σ u hu (σ u hu P) = -P := by
+  apply coords_injective
+  rcases P with _ | ⟨x, y, h⟩
+  · change coords (σ u hu (σ u hu 0)) = coords (-0)
+    rw [map_zero, map_zero, neg_zero]
+  · rw [coords_σ, coords_σ, coords_some, coords_neg]
+    simp only [Option.map_some, neg_neg, Option.some.injEq, Prod.mk.injEq, true_and]
+    have h6 : (((u⁻¹ : Lˣ) : L) ^ 3) * (((u⁻¹ : Lˣ) : L) ^ 3 * y) = (((u⁻¹ : Lˣ) : L) ^ 2) ^ 3 * y
+      :=
+      by ring
+    rw [h6, hui u hu]; norm_num
+
+omit [Algebra ℚ L] [IsAlgClosed L] in
+theorem σ_injective (u : Lˣ) (hu : (u : L) ^ 2 = -1) :
+    Function.Injective (σ u hu) := autPt_injective _ _
+
+def τ (u : Lˣ) (hu : (u : L) ^ 2 = -1) (N : ℕ) (H : CycSub L N) : CycSub L N :=
+  ⟨H.1.map (σ u hu), by
+    obtain ⟨hc, hcard⟩ := H.2
+    refine ⟨?_, ?_⟩
+    · have := hc
+      exact isAddCyclic_of_surjective ((σ u hu).addSubgroupMap H.1) ((σ u
+        hu).addSubgroupMap_surjective H.1)
+    · exact (Nat.card_congr (H.1.equivMapOfInjective (σ u hu) (σ_injective u
+        hu)).symm.toEquiv).trans hcard⟩
+
+omit [Algebra ℚ L] [IsAlgClosed L] in
+theorem τ_val (u : Lˣ) (hu : (u : L) ^ 2 = -1) (N : ℕ) (H : CycSub L N) :
+    (τ u hu N H).1 = H.1.map (σ u hu) := rfl
+
+omit [Algebra ℚ L] [IsAlgClosed L] in
+theorem map_σ_map_σ (u : Lˣ) (hu : (u : L) ^ 2 = -1) (H : AddSubgroup (W1 L).toAffine.Point) :
+    (H.map (σ u hu)).map (σ u hu) = H := by
+  rw [AddSubgroup.map_map]
+  ext P
+  constructor
+  · rintro ⟨Q, hQ, rfl⟩
+    change (σ u hu) (σ u hu Q) ∈ H
+    rw [σ_σ]; exact H.neg_mem hQ
+  · intro hP
+    exact ⟨-P, H.neg_mem hP, by change σ u hu (σ u hu (-P)) = P; rw [σ_σ, neg_neg]⟩
+
+omit [Algebra ℚ L] [IsAlgClosed L] in
+theorem τ_τ (u : Lˣ) (hu : (u : L) ^ 2 = -1) (N : ℕ) (H : CycSub L N) : τ u hu N (τ u hu N H) = H :=
+  Subtype.ext (map_σ_map_σ u hu H.1)
+
+@[instance_reducible]
+def actC2 (u : Lˣ) (hu : (u : L) ^ 2 = -1) (N : ℕ) :
+    MulAction (Multiplicative (ZMod 2)) (CycSub L N) where
+  smul g H := if Multiplicative.toAdd g = 0 then H else τ u hu N H
+  one_smul H := by
+    change (if Multiplicative.toAdd (1 : Multiplicative (ZMod 2)) = 0 then H else τ u hu N H) = H
+    simp
+  mul_smul a b H := by
+    change (if Multiplicative.toAdd (a * b) = 0 then H else τ u hu N H)
+      = (if Multiplicative.toAdd a = 0 then (if Multiplicative.toAdd b = 0 then H else τ u hu N H)
+          else τ u hu N (if Multiplicative.toAdd b = 0 then H else τ u hu N H))
+    have hτ := τ_τ u hu N H
+    rw [toAdd_mul]
+    generalize Multiplicative.toAdd a = i
+    generalize Multiplicative.toAdd b = j
+    have h2 : ∀ i : ZMod 2, i = 0 ∨ i = 1 := by decide
+    have h11 : (1 : ZMod 2) + 1 = 0 := by decide
+    have h10 : (1 : ZMod 2) ≠ 0 := by decide
+    rcases h2 i with rfl | rfl <;> rcases h2 j with rfl | rfl <;> simp [hτ, h11, h10]
+
+theorem natCard_C2 : Nat.card (Multiplicative (ZMod 2)) = 2 := by
+  simp [Nat.card_eq_fintype_card, ZMod.card]
+
+omit [Algebra ℚ L] [IsAlgClosed L] in
+theorem mem_fixedPoints_iff (u : Lˣ) (hu : (u : L) ^ 2 = -1) (N : ℕ) (H : CycSub L N) :
+    (letI := actC2 u hu N; H ∈ MulAction.fixedPoints (Multiplicative (ZMod 2)) (CycSub L N)) ↔ τ u
+      hu N H = H := by
+  let := actC2 u hu N
+  rw [MulAction.mem_fixedPoints]
+  constructor
+  · intro h
+    have := h (Multiplicative.ofAdd 1)
+    exact this
+  · intro h g
+    change (if Multiplicative.toAdd g = 0 then H else τ u hu N H) = H
+    split_ifs
+    · rfl
+    · exact h
+
+omit [Algebra ℚ L] [IsAlgClosed L] in
+theorem τ_eq_iff (u : Lˣ) (hu : (u : L) ^ 2 = -1) (N : ℕ) (hN : N ≠ 0) (H : CycSub L N) :
+    τ u hu N H = H ↔ ∀ T ∈ H.1, σ u hu T ∈ H.1 := by
+  constructor
+  · intro h T hT
+    have : σ u hu T ∈ (τ u hu N H).1 := ⟨T, hT, rfl⟩
+    rwa [h] at this
+  · intro h
+    apply Subtype.ext
+    have hle : H.1.map (σ u hu) ≤ H.1 := by
+      rintro _ ⟨T, hT, rfl⟩; exact h T hT
+    have hfin : Finite H.1 := Nat.finite_of_card_ne_zero (by rw [H.2.2]; exact hN)
+    have hcard : Nat.card H.1 ≤ Nat.card (H.1.map (σ u hu)) := by
+      change Nat.card H.1 ≤ Nat.card (τ u hu N H).1
+      rw [(τ u hu N H).2.2, H.2.2]
+    exact AddSubgroup.eq_of_le_of_card_ge hle hcard
+
+variable (N : ℕ)
+
+def R (T T' : {T : (W1 L).toAffine.Point // addOrderOf T = N}) : Prop :=
+  ∃ γ : VariableChange L, ∃ _ : γ • W1 L = W1 L, ∃ k : ℕ, k.Coprime N ∧
+    HEq T'.1 (k • Point.vcInvFun γ (W1 L).toAffine T.1)
+
+def cyc (T : {T : (W1 L).toAffine.Point // addOrderOf T = N}) : CycSub L N :=
+  ⟨AddSubgroup.zmultiples T.1, ⟨⟨T.1, AddSubgroup.mem_zmultiples T.1⟩, fun y => by
+      obtain ⟨n, hn⟩ := AddSubgroup.mem_zmultiples_iff.mp y.2
+      exact ⟨n, Subtype.ext (by simpa using hn)⟩⟩, by rw [Nat.card_zmultiples, T.2]⟩
+
+omit [IsAlgClosed L] in
+theorem map_autPt_eq_or (u : Lˣ) (hu : (u : L) ^ 2 = -1) (γ : VariableChange L)
+    (hγ : γ • W1 L = W1 L) (H : AddSubgroup (W1 L).toAffine.Point) :
+    H.map (autPt γ hγ) = H ∨ H.map (autPt γ hγ) = H.map (σ u hu) := by
+  obtain ⟨hr, hs, ht, hv⟩ := stab_W1 γ hγ
+  have hγ' : γ = ⟨γ.u, 0, 0, 0⟩ := eq_mk_of_rst ⟨hr, hs, ht⟩
+  have hcases := pow_four_eq_one_cases hu hv
+  have key : (∀ P, autPt γ hγ P = P) ∨ (∀ P, autPt γ hγ P = -P) ∨ (∀ P, autPt γ hγ P = σ u hu P) ∨
+    (∀ P, autPt γ hγ P = -(σ u hu P)) :=
+    by
+    have hco : ∀ P, coords (autPt γ hγ P) = (coords P).map (fun q => (((γ.u⁻¹ : Lˣ) : L) ^ 2 * q.1,
+      ((γ.u⁻¹ : Lˣ) : L) ^ 3 * q.2)) :=
+      by
+      intro P
+      have hγ'' : (⟨γ.u, 0, 0, 0⟩ : VariableChange L) • W1 L = W1 L := by rw [← hγ']; exact hγ
+      rw [autPt_congr hγ' hγ hγ'' P, coords_autPt]
+    rcases hcases with h1 | h1 | h1 | h1
+    · left; intro P; apply coords_injective; rw [hco]
+      have : ((γ.u⁻¹ : Lˣ) : L) = 1 := by rw [Units.val_inv_eq_inv_val, h1, inv_one]
+      rcases P with _ | ⟨x, y, h⟩
+      · rfl
+      · rw [coords_some, Option.map_some, this]; simp
+    · right; left; intro P; apply coords_injective; rw [hco]
+      have : ((γ.u⁻¹ : Lˣ) : L) = -1 := by rw [Units.val_inv_eq_inv_val, h1]; norm_num
+      rcases P with _ | ⟨x, y, h⟩
+      · rfl
+      · rw [coords_neg, coords_some, Option.map_some, this]
+        change some (_, _) = some (_, _)
+        congr 1; ext
+        · change (-1 : L) ^ 2 * x = x
+          ring
+        · change (-1 : L) ^ 3 * y = -y
+          ring
+    · right; right; left; intro P; apply coords_injective; rw [hco, coords_σ]
+      have : ((γ.u⁻¹ : Lˣ) : L) = ((u⁻¹ : Lˣ) : L) := by
+        rw [Units.val_inv_eq_inv_val, Units.val_inv_eq_inv_val, h1]
+      rcases P with _ | ⟨x, y, h⟩
+      · rfl
+      · rw [coords_some, Option.map_some, Option.map_some, this]
+        change some (_, _) = some (_, _)
+        congr 1; ext
+        · change ((u⁻¹ : Lˣ) : L) ^ 2 * x = -x
+          rw [hui u hu]; ring
+        · rfl
+    · right; right; right; intro P; apply coords_injective; rw [hco]
+      have : ((γ.u⁻¹ : Lˣ) : L) = -((u⁻¹ : Lˣ) : L) := by
+        rw [Units.val_inv_eq_inv_val, Units.val_inv_eq_inv_val, h1, inv_neg]
+      rcases P with _ | ⟨x, y, h⟩
+      · change _ = coords (-(σ u hu 0))
+        rw [map_zero, neg_zero]; rfl
+      · obtain ⟨Q, hQ⟩ : ∃ Q, σ u hu (Point.some x y h) = Q := ⟨_, rfl⟩
+        have hcQ : coords Q = some (-x, ((u⁻¹ : Lˣ) : L) ^ 3 * y) := by
+          rw [← hQ, coords_σ, coords_some]; rfl
+        rcases Q with _ | ⟨x', y', h'⟩
+        · simp [coords] at hcQ
+        · simp only [coords_some, Option.some.injEq, Prod.mk.injEq] at hcQ
+          obtain ⟨rfl, rfl⟩ := hcQ
+          rw [hQ, coords_neg, coords_some, Option.map_some, this]
+          change some (_, _) = some (_, _)
+          congr 1; ext
+          · change (-((u⁻¹ : Lˣ) : L)) ^ 2 * x = -x
+            rw [neg_sq, hui u hu]; ring
+          · change (-((u⁻¹ : Lˣ) : L)) ^ 3 * y = -(((u⁻¹ : Lˣ) : L) ^ 3 * y)
+            ring
+  rcases key with h | h | h | h
+  · left; ext P; constructor
+    · rintro ⟨Q, hQ, rfl⟩; rw [h]; exact hQ
+    · intro hP; exact ⟨P, hP, h P⟩
+  · left; ext P; constructor
+    · rintro ⟨Q, hQ, rfl⟩; rw [h]; exact H.neg_mem hQ
+    · intro hP; exact ⟨-P, H.neg_mem hP, by rw [h, neg_neg]⟩
+  · right; ext P; constructor
+    · rintro ⟨Q, hQ, rfl⟩; exact ⟨Q, hQ, (h Q).symm⟩
+    · rintro ⟨Q, hQ, rfl⟩; exact ⟨Q, hQ, h Q⟩
+  · right; ext P; constructor
+    · rintro ⟨Q, hQ, rfl⟩; exact ⟨-Q, H.neg_mem hQ, by rw [map_neg, h]⟩
+    · rintro ⟨Q, hQ, rfl⟩; exact ⟨-Q, H.neg_mem hQ, by rw [map_neg, h, neg_neg]⟩
+
+omit [Algebra ℚ L] [IsAlgClosed L] in
+theorem R_iff (T T' : {T : (W1 L).toAffine.Point // addOrderOf T = N}) :
+    R N T T' ↔ ∃ γ : VariableChange L, ∃ hγ : γ • W1 L = W1 L, ∃ k : ℕ, k.Coprime N ∧ T'.1 = k •
+      autPt γ hγ T.1 := by
+  unfold R
+  refine exists_congr (fun γ => exists_congr (fun hγ => exists_congr (fun k => and_congr_right (fun
+    _ => ?_))))
+  rw [autPt_apply, ← map_nsmul (castPt hγ), eq_comm, castPt_eq_iff_heq]
+  exact heq_comm
+
+omit [Algebra ℚ L] [IsAlgClosed L] in
+theorem autPt_one (h1 : (1 : VariableChange L) • W1 L = W1 L) (P : (W1 L).toAffine.Point) :
+    autPt 1 h1 P = P := by
+  apply coords_injective
+  have : autPt 1 h1 P = autPt ⟨1, 0, 0, 0⟩ h1 P := rfl
+  rw [this, coords_autPt]
+  rcases P with _ | ⟨x, y, h⟩ <;> simp
+
+omit [Algebra ℚ L] [IsAlgClosed L] in
+private theorem _root_.P2MWs13.R2a.exists_generator (hN : N ≠ 0) (H : CycSub L N) :
+    ∃ T : (W1 L).toAffine.Point, addOrderOf T = N ∧ AddSubgroup.zmultiples T = H.1 := by
+  obtain ⟨hc, hcard⟩ := H.2
+  have := hc
+  obtain ⟨g, hg⟩ := IsAddCyclic.exists_generator (α := H.1)
+  have hfin : Finite H.1 := Nat.finite_of_card_ne_zero (by rw [hcard]; exact hN)
+  have hog : addOrderOf g = N := (addOrderOf_eq_card_of_forall_mem_zmultiples hg).trans hcard
+  refine ⟨g.1, by rw [AddSubgroup.addOrderOf_coe, hog], ?_⟩
+  have hle : AddSubgroup.zmultiples (g.1) ≤ H.1 := by
+    rw [AddSubgroup.zmultiples_le]; exact g.2
+  refine AddSubgroup.eq_of_le_of_card_ge hle ?_
+  rw [hcard, Nat.card_zmultiples, AddSubgroup.addOrderOf_coe, hog]
+
+p2m_export "P2MWs13.R2a" "exists_generator"
+
+omit [Algebra ℚ L] [IsAlgClosed L] in
+theorem cyc_eq_cyc_iff_or (u : Lˣ) (hu : (u : L) ^ 2 = -1)
+    {T T' : {T : (W1 L).toAffine.Point // addOrderOf T = N}} (hN : N ≠ 0) :
+    (cyc N T' = cyc N T ∨ cyc N T' = τ u hu N (cyc N T)) → R N T T' := by
+  rw [R_iff]
+  rintro (h | h)
+  · have h' : AddSubgroup.zmultiples T'.1 = AddSubgroup.zmultiples T.1 := congrArg Subtype.val h
+    obtain ⟨k, hk, hkT⟩ := exists_coprime_nsmul_of_zmultiples_eq hN T.2 T'.2 h'
+    refine ⟨1, one_smul _ _, k, hk, ?_⟩
+    rw [hkT]; congr 1; exact (autPt_one (one_smul _ _) T.1).symm
+  · have h' : AddSubgroup.zmultiples T'.1 = AddSubgroup.zmultiples (σ u hu T.1) := by
+      have := congrArg Subtype.val h
+      rw [τ_val] at this
+      change AddSubgroup.zmultiples T'.1 = (AddSubgroup.zmultiples T.1).map (σ u hu) at this
+      rw [this, AddMonoidHom.map_zmultiples]
+    have hordσ : addOrderOf (σ u hu T.1) = N := by
+      rw [show σ u hu = autPt _ (hσW u hu) from rfl, addOrderOf_injective (autPt _ (hσW u hu))
+        (autPt_injective _ _), T.2]
+    obtain ⟨k, hk, hkT⟩ := exists_coprime_nsmul_of_zmultiples_eq hN hordσ T'.2 h'
+    exact ⟨⟨u, 0, 0, 0⟩, hσW u hu, k, hk, hkT⟩
+
+omit [IsAlgClosed L] in
+theorem R_imp_or (u : Lˣ) (hu : (u : L) ^ 2 = -1)
+    {T T' : {T : (W1 L).toAffine.Point // addOrderOf T = N}} (h : R N T T') :
+    cyc N T' = cyc N T ∨ cyc N T' = τ u hu N (cyc N T) := by
+  rw [R_iff] at h
+  obtain ⟨γ, hγ, k, hk, hkT⟩ := h
+  have hord : addOrderOf (autPt γ hγ T.1) = N := by
+    rw [addOrderOf_injective (autPt γ hγ) (autPt_injective γ hγ), T.2]
+  have hz : AddSubgroup.zmultiples T'.1 = (AddSubgroup.zmultiples T.1).map (autPt γ hγ) := by
+    rw [hkT, zmultiples_nsmul_eq_of_coprime hk hord, AddMonoidHom.map_zmultiples]
+  rcases map_autPt_eq_or u hu γ hγ (AddSubgroup.zmultiples T.1) with h | h
+  · left; apply Subtype.ext; change AddSubgroup.zmultiples T'.1 = AddSubgroup.zmultiples T.1; rw
+      [hz, h]
+  · right; apply Subtype.ext; change AddSubgroup.zmultiples T'.1 = (AddSubgroup.zmultiples T.1).map
+      (σ u hu); rw [hz, h]
+
+omit [IsAlgClosed L] in
+theorem natCard_quot_R_eq (u : Lˣ) (hu : (u : L) ^ 2 = -1) (hN : N ≠ 0) :
+    Nat.card (Quot (R (L := L) N)) =
+      (letI := actC2 u hu N; Nat.card (MulAction.orbitRel.Quotient (Multiplicative (ZMod 2)) (CycSub
+        L N))) := by
+  let := actC2 u hu N
+  let F : Quot (R (L := L) N) → MulAction.orbitRel.Quotient (Multiplicative (ZMod 2)) (CycSub L N)
+    :=
+    Quot.lift (fun T => (Quotient.mk _ (cyc N T) : MulAction.orbitRel.Quotient _ _)) (fun T T' h
+      => by
+      apply Quotient.sound
+      rcases R_imp_or N u hu h with h1 | h1
+      · rw [h1]
+      · change cyc N T ∈ MulAction.orbit (Multiplicative (ZMod 2)) (cyc N T')
+        refine ⟨Multiplicative.ofAdd 1, ?_⟩
+        change (if Multiplicative.toAdd (Multiplicative.ofAdd (1 : ZMod 2)) = 0 then cyc N T' else τ
+          u hu N (cyc N T')) = cyc N T
+        rw [h1, τ_τ]; simp)
+  refine Nat.card_congr (Equiv.ofBijective F ⟨?_, ?_⟩)
+  · intro a b
+    induction a using Quot.ind with | _ T => ?_
+    induction b using Quot.ind with | _ T' => ?_
+    intro hab
+    have hrel : cyc N T ∈ MulAction.orbit (Multiplicative (ZMod 2)) (cyc N T') := Quotient.exact hab
+    obtain ⟨g, hg⟩ := hrel
+    have hg' : (if Multiplicative.toAdd g = 0 then cyc N T' else τ u hu N (cyc N T')) = cyc N T :=
+      hg
+    split_ifs at hg' with h0
+    · exact Quot.sound (cyc_eq_cyc_iff_or N u hu hN (Or.inl hg'))
+    · exact Quot.sound (cyc_eq_cyc_iff_or N u hu hN (Or.inr (by rw [← hg', τ_τ])))
+  · intro q
+    induction q using Quotient.ind with | _ H => ?_
+    obtain ⟨T, hT, hTH⟩ := exists_generator N hN H
+    refine ⟨Quot.mk _ ⟨T, hT⟩, ?_⟩
+    change Quotient.mk _ (cyc N ⟨T, hT⟩) = Quotient.mk _ H
+    congr 1
+    exact Subtype.ext hTH
+
+end Count
+
+end P2MWs13.R2a
+end
+
+open P2MWs13.R2a in
+theorem solution
+    (N : ℕ) [NeZero N] (L : Type*) [Field L] [DecidableEq L] [Algebra ℚ L] [IsAlgClosed L] :
+    2 * Nat.card {x : ModuliPoint N L // ModuliPoint.j x = (1728 : L)} = dedekindPsi N + nuTwo N
+      := by
+  have : CharZero L := charZero_of_injective_algebraMap (algebraMap ℚ L).injective
+  have := isElliptic_W1 (L := L)
+  have hN : N ≠ 0 := NeZero.ne N
+  have hNL : ((N : ℕ) : L) ≠ 0 := Nat.cast_ne_zero.mpr hN
+  obtain ⟨uu, huu⟩ := IsAlgClosed.exists_pow_nat_eq (-1 : L) two_pos
+  have hu0 : uu ≠ 0 := by rintro rfl; norm_num at huu
+  set u : Lˣ := Units.mk0 uu hu0 with hudef
+  have hu : (u : L) ^ 2 = -1 := huu
+  have h1 : Nat.card {x : ModuliPoint N L // ModuliPoint.j x = (1728 : L)} = Nat.card (Quot (R (L :=
+    L) N)) :=
+    by
+    have e : Nat.card {x : ModuliPoint N L // ModuliPoint.j x = (1728 : L)} = Nat.card {x :
+      ModuliPoint N L // ModuliPoint.j x = (W1 L).j} :=
+      Nat.card_congr (Equiv.subtypeEquivRight (fun x => by rw [j_W1 (L := L)]))
+    rw [e]
+    exact ModularCurve.natCard_moduliPoint_j_eq_eq_natCard_quot_addOrderOf_eq N L (W1 L)
+  let := actC2 u hu N
+  have h2 := natCard_quot_R_eq N u hu hN
+  have hfinT : Finite {T : (W1 L).toAffine.Point // addOrderOf T = N} := by
+    have hc := (W1 L).card_torsion_of_isAlgClosed (K := L) hNL
+    have hb : ((W1 L)⁄L) = (W1 L).toAffine := by
+      change ((W1 L).baseChange L).toAffine = (W1 L).toAffine
+      rw [WeierstrassCurve.baseChange, Algebra.algebraMap_self, WeierstrassCurve.map_id]
+    rw [hb] at hc
+    have : Finite (Submodule.torsionBy ℤ (W1 L).toAffine.Point N) :=
+      Nat.finite_of_card_ne_zero (by rw [hc]; positivity)
+    refine Finite.of_injective (fun T => (⟨T.1, ?_⟩ : Submodule.torsionBy ℤ (W1 L).toAffine.Point
+      N)) ?_
+    · rw [Submodule.mem_torsionBy_iff]; change (N : ℤ) • T.1 = 0
+      have hT0 := addOrderOf_nsmul_eq_zero T.1
+      rw [T.2] at hT0
+      rw [natCast_zsmul]; exact hT0
+    · intro a b h; exact Subtype.ext (congrArg Subtype.val h :)
+  have : Finite (CycSub L N) := by
+    refine Finite.of_surjective (fun T : {T : (W1 L).toAffine.Point // addOrderOf T = N} => cyc N T)
+      ?_
+    intro H
+    obtain ⟨T, hT, hTH⟩ := exists_generator N hN H
+    exact ⟨⟨T, hT⟩, Subtype.ext hTH⟩
+  have h3 :=
+    MulAction.card_mul_natCard_orbitRel_quotient_eq_of_natCard_eq_prime (Multiplicative (ZMod 2))
+    (X := CycSub L N) Nat.prime_two natCard_C2
+  have h4 : Nat.card (CycSub L N) = dedekindPsi N := by
+    have h :=
+      (W1 L).natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed (K := L) (n := N)
+        hNL
+    have hb : ((W1 L)⁄L) = (W1 L).toAffine := by
+      change ((W1 L).baseChange L).toAffine = (W1 L).toAffine
+      rw [WeierstrassCurve.baseChange, Algebra.algebraMap_self, WeierstrassCurve.map_id]
+    rw [hb] at h
+    exact h
+  have h5 : Nat.card (MulAction.fixedPoints (Multiplicative (ZMod 2)) (CycSub L N)) = nuTwo N := by
+    rw [← WeierstrassCurve.natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuTwo (1 : L)
+      one_ne_zero u hu N hN]
+    refine Nat.card_congr ⟨fun H => ⟨H.1.1, H.1.2.1, H.1.2.2, ?_⟩, fun H => ⟨⟨H.1, H.2.1, H.2.2.1⟩,
+      ?_⟩, ?_, ?_⟩
+    · have hfix : τ u hu N H.1 = H.1 := (mem_fixedPoints_iff u hu N H.1).mp H.2
+      intro T hT
+      refine ⟨σ u hu T, (τ_eq_iff u hu N hN H.1).mp hfix T hT, ?_⟩
+      exact (autPt_eq_iff_heq _ (hσW u hu) T _).mp rfl
+    · rw [mem_fixedPoints_iff, τ_eq_iff u hu N hN]
+      intro T hT
+      obtain ⟨T', hT', hheq⟩ := H.2.2.2 T hT
+      have : σ u hu T = T' := (autPt_eq_iff_heq _ (hσW u hu) T T').mpr hheq
+      rw [this]; exact hT'
+    · intro H; rfl
+    · intro H; rfl
+  rw [h1, h2, h3, h4, h5]
+  omega
+
+end S_ModularCurve_two_mul_natCard_moduliPoint_j_eq_1728_eq_dedekindPsi_add_nuTwo
+end P2MW
+export P2MW.S_ModularCurve_two_mul_natCard_moduliPoint_j_eq_1728_eq_dedekindPsi_add_nuTwo (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ModularCurve.two_mul_natCard_moduliPoint_j_eq_1728_eq_dedekindPsi_add_nuTwo
+    (N : ℕ) [NeZero N] (L : Type*) [Field L] [DecidableEq L] [Algebra ℚ L] [IsAlgClosed L] :
+    2 * Nat.card {x : ModuliPoint N L // ModuliPoint.j x = (1728 : L)} = dedekindPsi N + nuTwo N :=
+  solution N L
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularFormClass_eq_of_forall_qCoeff_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularFormClass_eq_of_forall_qCoeff_eq.lean
new file mode 100644
index 0000000000..579b221dbb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularFormClass_eq_of_forall_qCoeff_eq.lean
@@ -0,0 +1,405 @@
+/-
+Based on Prove2Me node ModularFormClass.eq_of_forall_qCoeff_eq
+(fb97e0fa-1f4b-59f3-b303-c7736e494490) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 15f2d259-53c2-55ec-9720-74e917f0e260
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A modular form is determined by its q-expansion
+
+Theorem statement: `ModularFormClass.eq_of_forall_qCoeff_eq`
+(`fb97e0fa-1f4b-59f3-b303-c7736e494490`), by Claude, 2026-09-05.
+
+Proof: submission `15f2d259-53c2-55ec-9720-74e917f0e260`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a type equipped with a `FunLike F UpperHalfPlane ℂ` structure, let $\Gamma$ be a subgroup
+of $\mathrm{GL}_2(\mathbb{R})$, let $k$ be an integer, and suppose $F$ carries a `ModularFormClass F
+Γ k` structure, so that its elements are interpreted as weight-$k$ modular forms on $\Gamma$. Let
+$f, g : F$. Assume that $1$ lies in `Γ.strictPeriods`, i.e. that $\Gamma$ contains the translation
+by $1$, so that the associated functions on the upper half-plane are invariant under $\tau \mapsto
+\tau + 1$ and admit $q$-expansions in $q = e^{2\pi i \tau}$. Assume further that for every natural
+number $n$ the $n$-th coefficients agree, $\mathrm{qCoeff}\ f\ n = \mathrm{qCoeff}\ g\ n$, where
+[`ModularFormClass.qCoeff`](def/FLTPrelim_Modularity.html#L19) of a function $\mathbb{H} \to
+\mathbb{C}$ at $n$ is by definition the $n$-th coefficient of its period-$1$ $q$-expansion
+`qExpansion 1`. The conclusion is the equality $f = g$ in $F$ itself, not merely the equality of the
+two functions on the upper half-plane.
+
+This is the standard injectivity of the $q$-expansion map at $\infty$ for modular forms with period
+$1$ (for instance on $\Gamma_0(N)$ or $\Gamma_1(N)$), stated uniformly for any carrier of modular
+forms of weight $k$ on $\Gamma$, such as holomorphic modular forms or cusp forms. It is the basic
+tool by which forms are compared through their Fourier coefficients, and is used throughout the
+treatment of newforms, normalised eigenforms and integral structures on spaces of cusp forms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularFormClass_eq_of_forall_qCoeff_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_ModularFormClass_eq_of_forall_qCoeff_eq
+
+noncomputable section
+
+open Complex Function Filter
+p2m_open "UpperHalfPlane~I"
+open scoped Real MatrixGroups ModularForm Manifold Topology
+
+namespace M4cP1W2
+
+open ModularForm ModularFormClass
+
+section Matrices
+
+variable (p j : ℕ)
+
+theorem heckeMatrix_one_zero :
+    ((heckeMatrix p j : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) 1 0 = 0 := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  · rw [val_heckeMatrix hp]; rfl
+
+theorem heckeDiagMatrix_one_zero :
+    ((heckeDiagMatrix p : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) 1 0 = 0 := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  · rw [val_heckeDiagMatrix hp]; rfl
+
+end Matrices
+
+section Regularity
+
+variable {f : ℍ → ℂ} (k : ℤ) (p : ℕ)
+
+theorem mdifferentiable_heckeU (hf : MDiff f) : MDiff (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => MDiff g) (fun _ _ ha hb => ha.add hb)
+    mdifferentiable_const (fun _ _ => hf.slash k _)
+
+theorem mdifferentiable_heckeT (hf : MDiff f) : MDiff (heckeT k p f) :=
+  (mdifferentiable_heckeU k p hf).add (hf.slash k _)
+
+theorem isBoundedAtImInfty_heckeU (hf : IsBoundedAtImInfty f) :
+    IsBoundedAtImInfty (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => IsBoundedAtImInfty g)
+    (fun _ _ ha hb => ha.add hb) UpperHalfPlane.zero_form_isBoundedAtImInfty
+    (fun j _ => hf.slash k (heckeMatrix_one_zero p j))
+
+theorem isBoundedAtImInfty_heckeT (hf : IsBoundedAtImInfty f) :
+    IsBoundedAtImInfty (heckeT k p f) :=
+  (isBoundedAtImInfty_heckeU k p hf).add (hf.slash k (heckeDiagMatrix_one_zero p))
+
+theorem isZeroAtImInfty_heckeU (hf : IsZeroAtImInfty f) :
+    IsZeroAtImInfty (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => IsZeroAtImInfty g)
+    (fun _ _ ha hb => ha.add hb) (zero_zeroAtFilter atImInfty)
+    (fun j _ => hf.slash k (heckeMatrix_one_zero p j))
+
+theorem isZeroAtImInfty_heckeT (hf : IsZeroAtImInfty f) :
+    IsZeroAtImInfty (heckeT k p f) :=
+  (isZeroAtImInfty_heckeU k p hf).add (hf.slash k (heckeDiagMatrix_one_zero p))
+
+theorem apply_eq_of_coe_eq_add_nat (hf : Periodic (f ∘ ofComplex) 1) {τ₁ τ₂ : ℍ} (m : ℕ)
+    (h : (τ₁ : ℂ) = τ₂ + m) : f τ₁ = f τ₂ := by
+  have h1 : (f ∘ ofComplex) ((τ₂ : ℂ) + m) = (f ∘ ofComplex) (τ₂ : ℂ) := by
+    have := hf.nat_mul m
+    rw [mul_one] at this
+    exact this (τ₂ : ℂ)
+  simp only [comp_apply] at h1
+  rw [← h, ofComplex_apply, ofComplex_apply] at h1
+  exact h1
+
+variable {p} in
+theorem heckeMatrix_smul_vadd (hp : p ≠ 0) (j : ℕ) (τ : ℍ) :
+    heckeMatrix p j • ((1 : ℝ) +ᵥ τ) = heckeMatrix p (j + 1) • τ := by
+  apply UpperHalfPlane.ext
+  rw [coe_heckeMatrix_smul hp, coe_heckeMatrix_smul hp, coe_vadd]
+  push_cast
+  ring
+
+variable {p} in
+theorem coe_heckeMatrix_smul_self (hp : p ≠ 0) (τ : ℍ) :
+    ((heckeMatrix p p • τ : ℍ) : ℂ) = (heckeMatrix p 0 • τ : ℍ) + (1 : ℕ) := by
+  have hp' : (p : ℂ) ≠ 0 := by exact_mod_cast hp
+  rw [coe_heckeMatrix_smul hp, coe_heckeMatrix_smul hp]
+  field_simp
+  push_cast
+  ring
+
+variable {p} in
+theorem coe_heckeDiagMatrix_smul_vadd (hp : p ≠ 0) (τ : ℍ) :
+    ((heckeDiagMatrix p • ((1 : ℝ) +ᵥ τ) : ℍ) : ℂ) = (heckeDiagMatrix p • τ : ℍ) + (p : ℕ) := by
+  rw [coe_heckeDiagMatrix_smul hp, coe_heckeDiagMatrix_smul hp, coe_vadd]
+  push_cast
+  ring
+
+variable {p} in
+theorem sum_heckeMatrix_smul_vadd (hp : p ≠ 0) (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    ∑ j ∈ Finset.range p, f (heckeMatrix p j • ((1 : ℝ) +ᵥ τ))
+      = ∑ j ∈ Finset.range p, f (heckeMatrix p j • τ) := by
+  simp only [heckeMatrix_smul_vadd hp]
+  have h0 := Finset.sum_range_succ' (fun j => f (heckeMatrix p j • τ)) p
+  have h1 := Finset.sum_range_succ (fun j => f (heckeMatrix p j • τ)) p
+  rw [apply_eq_of_coe_eq_add_nat hf 1 (coe_heckeMatrix_smul_self hp τ)] at h1
+  exact add_right_cancel (h0.symm.trans h1)
+
+theorem heckeU_vadd (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    heckeU k p f ((1 : ℝ) +ᵥ τ) = heckeU k p f τ := by
+  by_cases hp : p = 0
+  · simp only [hp, heckeU_zero_left, Pi.zero_apply]
+  · rw [heckeU_apply k hp, heckeU_apply k hp, sum_heckeMatrix_smul_vadd hp hf]
+
+theorem heckeT_vadd (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    heckeT k p f ((1 : ℝ) +ᵥ τ) = heckeT k p f τ := by
+  by_cases hp : p = 0
+  · simp only [hp, heckeT_zero_left]
+    exact apply_eq_of_coe_eq_add_nat hf 1 (by rw [coe_vadd]; push_cast; ring)
+  · rw [heckeT_apply k hp, heckeT_apply k hp, sum_heckeMatrix_smul_vadd hp hf,
+      apply_eq_of_coe_eq_add_nat hf p (coe_heckeDiagMatrix_smul_vadd hp τ)]
+
+theorem periodic_comp_ofComplex_of_vadd {g : ℍ → ℂ} (hg : ∀ τ : ℍ, g ((1 : ℝ) +ᵥ τ) = g τ) :
+    Periodic (g ∘ ofComplex) 1 := by
+  intro w
+  by_cases hw : 0 < im w
+  · have hw' : 0 < im (w + 1) := by simp [hw]
+    simp only [comp_apply, ofComplex_apply_of_im_pos hw', ofComplex_apply_of_im_pos hw]
+    convert hg ⟨w, hw⟩ using 2
+    apply UpperHalfPlane.ext
+    simp [add_comm]
+  · have hw1 : im (w + 1) ≤ 0 := by simpa using hw
+    have hw0 : im w ≤ 0 := not_lt.mp hw
+    simp only [comp_apply, ofComplex_apply_eq_of_im_nonpos hw1 hw0]
+
+theorem periodic_heckeU_comp_ofComplex (hf : Periodic (f ∘ ofComplex) 1) :
+    Periodic (heckeU k p f ∘ ofComplex) 1 :=
+  periodic_comp_ofComplex_of_vadd (heckeU_vadd k p hf)
+
+theorem periodic_heckeT_comp_ofComplex (hf : Periodic (f ∘ ofComplex) 1) :
+    Periodic (heckeT k p f ∘ ofComplex) 1 :=
+  periodic_comp_ofComplex_of_vadd (heckeT_vadd k p hf)
+
+end Regularity
+
+section Uniqueness
+
+theorem qExpansion_coeff_unique' {g : ℍ → ℂ} (hcont : Continuous g) {c : ℕ → ℂ}
+    (hg : AnalyticAt ℂ (cuspFunction 1 g) 0)
+    (hs : ∀ τ : ℍ, HasSum (fun m ↦ c m • Periodic.qParam 1 τ ^ m) (g τ)) (m : ℕ) :
+    c m = (qExpansion 1 g).coeff m :=
+  UpperHalfPlane.qExpansion_coeff_unique (ContinuousMap.mk g hcont) one_pos hg hs m
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+theorem hasSum_qCoeff [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) (τ : ℍ) :
+    HasSum (fun m ↦ qCoeff f m • Periodic.qParam 1 τ ^ m) (f τ) := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  exact hasSum_qExpansion one_pos (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ)
+    (holo f) (bdd_at_infty f) τ
+
+theorem eq_of_forall_qCoeff_eq [ModularFormClass F Γ k] {f g : F} (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (h : ∀ n : ℕ, qCoeff f n = qCoeff g n) : f = g := by
+  refine DFunLike.ext f g fun τ => ?_
+  have hf := hasSum_qCoeff f hΓ τ
+  have hg := hasSum_qCoeff g hΓ τ
+  simp only [h] at hf
+  exact hf.unique hg
+
+end Uniqueness
+
+section QExpAction
+
+theorem qParam_one (z : ℂ) : Periodic.qParam 1 z = exp (2 * π * I * z) := by
+  simp [Periodic.qParam]
+
+variable {p : ℕ} (hp : p ≠ 0)
+
+include hp in
+theorem natCast_ne_zero' : (p : ℂ) ≠ 0 := by exact_mod_cast hp
+
+include hp in
+theorem qParam_heckeMatrix_smul (j : ℕ) (τ : ℍ) :
+    Periodic.qParam 1 ((heckeMatrix p j • τ : ℍ) : ℂ)
+      = exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j := by
+  rw [qParam_one, coe_heckeMatrix_smul hp, ← Complex.exp_nat_mul, ← Complex.exp_add]
+  congr 1
+  have := natCast_ne_zero' hp
+  field_simp
+
+include hp in
+theorem qParam_heckeDiagMatrix_smul (τ : ℍ) :
+    Periodic.qParam 1 ((heckeDiagMatrix p • τ : ℍ) : ℂ) = Periodic.qParam 1 τ ^ p := by
+  rw [qParam_one, qParam_one, coe_heckeDiagMatrix_smul hp, ← Complex.exp_nat_mul]
+  congr 1
+  ring
+
+include hp in
+theorem exp_div_pow (τ : ℍ) : exp (2 * π * I * τ / p) ^ p = Periodic.qParam 1 τ := by
+  rw [qParam_one, ← Complex.exp_nat_mul]
+  congr 1
+  have := natCast_ne_zero' hp
+  field_simp
+
+include hp in
+theorem sum_rootOfUnity_pow (m : ℕ) :
+    ∑ j ∈ Finset.range p, (exp (2 * π * I / p) ^ j) ^ m = if p ∣ m then (p : ℂ) else 0 := by
+  have hζ := Complex.isPrimitiveRoot_exp p hp
+  have hswap : ∀ j : ℕ, (exp (2 * π * I / p) ^ j) ^ m = (exp (2 * π * I / p) ^ m) ^ j := fun j => by
+    rw [← pow_mul, ← pow_mul, Nat.mul_comm j m]
+  simp only [hswap]
+  split_ifs with h
+  · rw [(hζ.pow_eq_one_iff_dvd m).mpr h]
+    simp
+  · have hne : exp (2 * π * I / p) ^ m ≠ 1 := fun h1 => h ((hζ.pow_eq_one_iff_dvd m).mp h1)
+    rw [geom_sum_eq hne, ← pow_mul, Nat.mul_comm m p, pow_mul, hζ.pow_eq_one, one_pow, sub_self,
+      zero_div]
+
+theorem not_dvd_of_not_mem_range {m : ℕ} (hm : m ∉ Set.range (fun l : ℕ ↦ l * p)) : ¬ p ∣ m := by
+  rintro ⟨l, rfl⟩
+  exact hm ⟨l, by simp [mul_comm]⟩
+
+variable {f : ℍ → ℂ} (hper : Periodic (f ∘ ofComplex) 1) (hhol : MDiff f)
+  (hbdd : IsBoundedAtImInfty f)
+
+include hp hper hhol hbdd in
+theorem hasSum_average (τ : ℍ) :
+    HasSum (fun l : ℕ ↦ qCoeff f (l * p) * Periodic.qParam 1 τ ^ l)
+      ((p : ℂ)⁻¹ * ∑ j ∈ Finset.range p, f (heckeMatrix p j • τ)) := by
+  have hF : ∀ τ' : ℍ, HasSum (fun m ↦ qCoeff f m • Periodic.qParam 1 τ' ^ m) (f τ') :=
+    hasSum_qExpansion one_pos hper hhol hbdd
+  have h1 : HasSum (fun m ↦ ∑ j ∈ Finset.range p,
+      qCoeff f m • (exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j) ^ m)
+      (∑ j ∈ Finset.range p, f (heckeMatrix p j • τ)) := by
+    refine hasSum_sum fun j _ => ?_
+    have := hF (heckeMatrix p j • τ)
+    rwa [qParam_heckeMatrix_smul hp j τ] at this
+  have h2 : (fun m ↦ ∑ j ∈ Finset.range p,
+      qCoeff f m • (exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j) ^ m)
+      = fun m ↦ if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0 := by
+    funext m
+    simp only [mul_pow, smul_eq_mul, ← Finset.mul_sum, sum_rootOfUnity_pow hp m]
+    grind
+  rw [h2] at h1
+  have hinj : Function.Injective (fun l : ℕ ↦ l * p) := mul_left_injective₀ hp
+  have h3 := (hinj.hasSum_iff (f := fun m ↦
+      if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0)
+    (fun m hm => by simp [not_dvd_of_not_mem_range hm])).mpr h1
+  have h4 : ((fun m ↦ if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0) ∘
+      fun l : ℕ ↦ l * p) = fun l ↦ (p : ℂ) * (qCoeff f (l * p) * Periodic.qParam 1 τ ^ l) := by
+    funext l
+    simp only [comp_apply, ite_eq_left (dvd_mul_left p l)]
+    rw [mul_comm l p, pow_mul, exp_div_pow hp τ]
+    ring
+  rw [h4] at h3
+  have h5 := h3.mul_left ((p : ℂ)⁻¹)
+  simp only [← mul_assoc, inv_mul_cancel₀ (natCast_ne_zero' hp), one_mul] at h5
+  exact h5
+
+include hp hper hhol hbdd in
+theorem hasSum_diag (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ if p ∣ n then (p : ℂ) ^ (k - 1) * qCoeff f (n / p) * Periodic.qParam 1 τ ^ n
+        else 0)
+      ((p : ℂ) ^ (k - 1) * f (heckeDiagMatrix p • τ)) := by
+  have hD := (hasSum_qExpansion one_pos hper hhol hbdd (heckeDiagMatrix p • τ)).mul_left
+    ((p : ℂ) ^ (k - 1))
+  rw [qParam_heckeDiagMatrix_smul hp τ] at hD
+  have hinj : Function.Injective (fun l : ℕ ↦ l * p) := mul_left_injective₀ hp
+  refine (hinj.hasSum_iff (fun m hm => by simp [not_dvd_of_not_mem_range hm])).mp ?_
+  convert hD using 1
+  funext l
+  simp only [comp_apply, ite_eq_left (dvd_mul_left p l), Nat.mul_div_cancel _ (Nat.pos_of_ne_zero
+    hp),
+    smul_eq_mul]
+  rw [← pow_mul, mul_comm l p, mul_assoc]
+  rfl
+
+include hp hper hhol hbdd in
+theorem hasSum_heckeU (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ coeffHeckeU p (qCoeff f) n • Periodic.qParam 1 τ ^ n) (heckeU k p f τ) := by
+  rw [heckeU_apply k hp]
+  simpa only [coeffHeckeU_apply, smul_eq_mul] using hasSum_average hp hper hhol hbdd τ
+
+include hp hper hhol hbdd in
+theorem hasSum_heckeT (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ coeffHeckeT k p (qCoeff f) n • Periodic.qParam 1 τ ^ n) (heckeT k p f τ) :=
+      by
+  rw [heckeT_apply k hp]
+  convert (hasSum_average hp hper hhol hbdd τ).add (hasSum_diag hp hper hhol hbdd k τ) using 1
+  grind [coeffHeckeT_apply, smul_eq_mul]
+
+include hp hper hhol hbdd in
+theorem qCoeff_heckeU_bare (k : ℤ) (n : ℕ) :
+    qCoeff (heckeU k p f) n = coeffHeckeU p (qCoeff f) n :=
+  (qExpansion_coeff_unique' (mdifferentiable_heckeU k p hhol).continuous
+    (analyticAt_cuspFunction_zero one_pos (periodic_heckeU_comp_ofComplex k p hper)
+      (mdifferentiable_heckeU k p hhol) (isBoundedAtImInfty_heckeU k p hbdd))
+    (hasSum_heckeU hp hper hhol hbdd k) n).symm
+
+include hp hper hhol hbdd in
+theorem qCoeff_heckeT_bare (k : ℤ) (n : ℕ) :
+    qCoeff (heckeT k p f) n = coeffHeckeT k p (qCoeff f) n :=
+  (qExpansion_coeff_unique' (mdifferentiable_heckeT k p hhol).continuous
+    (analyticAt_cuspFunction_zero one_pos (periodic_heckeT_comp_ofComplex k p hper)
+      (mdifferentiable_heckeT k p hhol) (isBoundedAtImInfty_heckeT k p hbdd))
+    (hasSum_heckeT hp hper hhol hbdd k) n).symm
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+include hp in
+theorem qCoeff_heckeU_class [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (n : ℕ) : qCoeff (heckeU k p f) n = coeffHeckeU p (qCoeff f) n :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  qCoeff_heckeU_bare hp (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (holo f)
+    (bdd_at_infty f) k n
+
+include hp in
+theorem qCoeff_heckeT_class [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (n : ℕ) : qCoeff (heckeT k p f) n = coeffHeckeT k p (qCoeff f) n :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  qCoeff_heckeT_bare hp (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (holo f)
+    (bdd_at_infty f) k n
+
+end QExpAction
+
+end M4cP1W2
+
+end
+
+theorem solution {F : Type*} [FunLike F UpperHalfPlane ℂ]
+    {Γ : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)} {k : ℤ} [ModularFormClass F Γ k] {f g : F}
+    (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (h : ∀ n : ℕ, ModularFormClass.qCoeff f n = ModularFormClass.qCoeff g n) :
+    f = g :=
+  M4cP1W2.eq_of_forall_qCoeff_eq hΓ h
+
+end S_ModularFormClass_eq_of_forall_qCoeff_eq
+end P2MW
+export P2MW.S_ModularFormClass_eq_of_forall_qCoeff_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularFormClass.eq_of_forall_qCoeff_eq {F : Type*} [FunLike F UpperHalfPlane ℂ]
+    {Γ : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)} {k : ℤ} [ModularFormClass F Γ k] {f g : F}
+    (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (h : ∀ n : ℕ, ModularFormClass.qCoeff f n = ModularFormClass.qCoeff g n) :
+    f = g :=
+  solution hΓ h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularFormClass_heckeT_heckeT_comm.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularFormClass_heckeT_heckeT_comm.lean
new file mode 100644
index 0000000000..2cc3bc47fd
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularFormClass_heckeT_heckeT_comm.lean
@@ -0,0 +1,167 @@
+/-
+Based on Prove2Me node ModularFormClass.heckeT_heckeT_comm
+(44b9a042-0038-5d3e-b7e5-70f8a32ddeeb) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ac188186-6cc5-544c-826e-641d46eb8f9b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_qCoeff_heckeT
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_mdifferentiable_heckeT
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_isBoundedAtImInfty_heckeT
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_periodic_heckeT_comp_ofComplex
+import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_eq_of_forall_qCoeff_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_coeffHeckeT_comm
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Hecke translates Tₚ, T_q commute for coprime p,q
+
+Theorem statement: `ModularFormClass.heckeT_heckeT_comm` (`44b9a042-0038-5d3e-b7e5-70f8a32ddeeb`),
+by Claude, 2026-09-05.
+
+Proof: submission `ac188186-6cc5-544c-826e-641d46eb8f9b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a type of functions on the upper half-plane $\mathbb{H}$ with values in $\mathbb{C}$ (via
+a `FunLike` structure), let $\Gamma$ be a subgroup of $\mathrm{GL}_2(\mathbb{R})$ and $k$ an
+integer, and suppose $F$ is a class of modular forms of weight $k$ for $\Gamma$ (`ModularFormClass F
+Γ k`, so in particular each element is holomorphic on $\mathbb{H}$, weight-$k$ invariant under
+$\Gamma$ and bounded at the cusps). Let $f : F$, and assume that $1$ belongs to
+$\Gamma$`.strictPeriods`, the set of strict real periods of $\Gamma$; this hypothesis supplies the
+$1$-periodicity of $f \circ$ `ofComplex` and, via the fact that $\infty$ is then a cusp of $\Gamma$,
+the boundedness of $f$ at $i\infty$. Let $p, q$ be coprime natural numbers. For a function $g$ on
+$\mathbb{H}$ write $\mathrm{heckeT}\,k\,p\,g = \sum_{j < p} g \mid_k \mathrm{heckeMatrix}\,p\,j + g
+\mid_k \mathrm{heckeDiagMatrix}\,p$, where $\mid_k$ is the weight-$k$ slash action, the
+$\mathrm{heckeMatrix}\,p\,j$ ($0 \le j < p$) are the matrices used for the sum part, and
+$\mathrm{heckeDiagMatrix}\,p$ is the identity if $p = 0$ and otherwise the upper triangular element
+`upperTriangularGL p 0 1` of $\mathrm{GL}_2(\mathbb{R})$. The conclusion is the equality of
+functions $\mathbb{H} \to \mathbb{C}$: $\mathrm{heckeT}\,k\,p(\mathrm{heckeT}\,k\,q\,f) =
+\mathrm{heckeT}\,k\,q(\mathrm{heckeT}\,k\,p\,f)$. No modularity of the Hecke translates themselves
+is asserted or required.
+
+This is the commutativity of the Hecke operators $T_p$ and $T_q$ at coprime indices, in the concrete
+form of an identity between the Hecke translates of the underlying function on $\mathbb{H}$. It is
+the analytic input for the corresponding statements about the linear Hecke operators on spaces of
+modular and cusp forms, [`ModularForm.heckeTLin_comm`](thm.html#ModularForm.heckeTLin_comm) and
+[`CuspForm.heckeTLin_comm`](thm.html#CuspForm.heckeTLin_comm), and thence for the existence of
+simultaneous eigenforms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularFormClass_heckeT_heckeT_comm.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularFormClass_heckeT_heckeT_comm
+
+noncomputable section
+
+open Complex Function Filter
+p2m_open "UpperHalfPlane~I"
+open scoped Real MatrixGroups ModularForm Manifold Topology
+
+open ModularForm ModularFormClass
+
+namespace W2WsF
+
+private theorem _root_.W2WsF.eq_of_forall_qCoeff_eq {f g : ℍ → ℂ}
+    (hfper : Periodic (f ∘ ofComplex) 1) (hfhol : MDiff f)
+    (hfbdd : IsBoundedAtImInfty f) (hgper : Periodic (g ∘ ofComplex) 1) (hghol : MDiff g)
+    (hgbdd : IsBoundedAtImInfty g) (h : ∀ n : ℕ, qCoeff f n = qCoeff g n) : f = g :=
+  UpperHalfPlane.eq_of_forall_qCoeff_eq hfper hfhol hfbdd hgper hghol hgbdd h
+
+p2m_export "W2WsF" "eq_of_forall_qCoeff_eq"
+
+theorem qCoeff_const_smul {f : ℍ → ℂ} (hper : Periodic (f ∘ ofComplex) 1) (hhol : MDiff f)
+    (hbdd : IsBoundedAtImInfty f) (c : ℂ) (n : ℕ) : qCoeff (c • f) n = c * qCoeff f n := by
+  simp only [qCoeff]
+  rw [UpperHalfPlane.qExpansion_smul (analyticAt_cuspFunction_zero one_pos hper hhol hbdd)]
+  simp
+
+theorem periodic_const_smul {f : ℍ → ℂ} (hper : Periodic (f ∘ ofComplex) 1) (c : ℂ) :
+    Periodic ((c • f) ∘ ofComplex) 1 := fun z ↦ by
+  simpa using congrArg (c * ·) (hper z)
+
+section Class
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+theorem mf_periodic [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) :
+    Periodic (⇑f ∘ ofComplex) 1 :=
+  SlashInvariantFormClass.periodic_comp_ofComplex f hΓ
+
+theorem mf_bdd [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) :
+    IsBoundedAtImInfty ⇑f :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  bdd_at_infty f
+
+end Class
+
+theorem heckeT_heckeT_comm_bare {f : ℍ → ℂ} (hper : Periodic (f ∘ ofComplex) 1) (hhol : MDiff f)
+    (hbdd : IsBoundedAtImInfty f) (k : ℤ) {p q : ℕ} (hpq : p.Coprime q) :
+    heckeT k p (heckeT k q f) = heckeT k q (heckeT k p f) := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  rcases eq_or_ne q 0 with rfl | hq
+  · simp
+  refine eq_of_forall_qCoeff_eq
+    (periodic_heckeT_comp_ofComplex (periodic_heckeT_comp_ofComplex hper k q) k p)
+    (mdifferentiable_heckeT (mdifferentiable_heckeT hhol k q) k p)
+    (isBoundedAtImInfty_heckeT (isBoundedAtImInfty_heckeT hbdd k q) k p)
+    (periodic_heckeT_comp_ofComplex (periodic_heckeT_comp_ofComplex hper k p) k q)
+    (mdifferentiable_heckeT (mdifferentiable_heckeT hhol k p) k q)
+    (isBoundedAtImInfty_heckeT (isBoundedAtImInfty_heckeT hbdd k p) k q) fun n ↦ ?_
+  rw [UpperHalfPlane.qCoeff_heckeT (periodic_heckeT_comp_ofComplex hper k q)
+      (mdifferentiable_heckeT hhol k q) (isBoundedAtImInfty_heckeT hbdd k q) k hp,
+    UpperHalfPlane.qCoeff_heckeT (periodic_heckeT_comp_ofComplex hper k p)
+      (mdifferentiable_heckeT hhol k p) (isBoundedAtImInfty_heckeT hbdd k p) k hq]
+  have hq' : qCoeff (heckeT k q f) = coeffHeckeT k q (qCoeff f) :=
+    funext fun m ↦ UpperHalfPlane.qCoeff_heckeT hper hhol hbdd k hq m
+  have hp' : qCoeff (heckeT k p f) = coeffHeckeT k p (qCoeff f) :=
+    funext fun m ↦ UpperHalfPlane.qCoeff_heckeT hper hhol hbdd k hp m
+  rw [hq', hp', coeffHeckeT_comm k hpq]
+
+end W2WsF
+
+theorem solution {F : Type*} [FunLike F UpperHalfPlane ℂ]
+    {Γ : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)} {k : ℤ} [ModularFormClass F Γ k] (f : F)
+    (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) {p q : ℕ} (hpq : Nat.Coprime p q) :
+    ModularForm.heckeT k p (ModularForm.heckeT k q ⇑f) = ModularForm.heckeT k q (ModularForm.heckeT
+      k p ⇑f) :=
+  W2WsF.heckeT_heckeT_comm_bare (W2WsF.mf_periodic f hΓ) (ModularFormClass.holo f)
+    (W2WsF.mf_bdd f hΓ) k hpq
+
+end
+
+end S_ModularFormClass_heckeT_heckeT_comm
+end P2MW
+export P2MW.S_ModularFormClass_heckeT_heckeT_comm (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularFormClass.heckeT_heckeT_comm {F : Type*} [FunLike F UpperHalfPlane ℂ]
+    {Γ : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)} {k : ℤ} [ModularFormClass F Γ k] (f : F)
+    (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) {p q : ℕ} (hpq : Nat.Coprime p q) :
+    ModularForm.heckeT k p (ModularForm.heckeT k q ⇑f) = ModularForm.heckeT k q (ModularForm.heckeT
+      k p ⇑f) :=
+  solution f hΓ hpq
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularFormClass_heckeT_heckeU_comm.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularFormClass_heckeT_heckeU_comm.lean
new file mode 100644
index 0000000000..21c0e7628d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularFormClass_heckeT_heckeU_comm.lean
@@ -0,0 +1,166 @@
+/-
+Based on Prove2Me node ModularFormClass.heckeT_heckeU_comm
+(559509b8-2835-58a8-b392-183c8cf0ec41) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 267bd17d-c8b4-5ee3-b0cd-b6267c04386b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_qCoeff_heckeT
+import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_qCoeff_heckeU
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_mdifferentiable_heckeT
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_mdifferentiable_heckeU
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_isBoundedAtImInfty_heckeT
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_isBoundedAtImInfty_heckeU
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_periodic_heckeT_comp_ofComplex
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_periodic_heckeU_comp_ofComplex
+import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_eq_of_forall_qCoeff_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_coeffHeckeT_coeffHeckeU_comm
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Commutation of Tₚ and U_q for coprime p,q
+
+Theorem statement: `ModularFormClass.heckeT_heckeU_comm` (`559509b8-2835-58a8-b392-183c8cf0ec41`),
+by Claude, 2026-09-05.
+
+Proof: submission `267bd17d-c8b4-5ee3-b0cd-b6267c04386b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a type of functions $\mathbb{H} \to \mathbb{C}$ (via a `FunLike` structure), let $\Gamma$
+be a subgroup of $\mathrm{GL}_2(\mathbb{R})$ and $k$ an integer, and assume $F$ is a class of
+modular forms of weight $k$ for $\Gamma$, i.e. its elements are weight-$k$ slash-invariant under
+$\Gamma$, holomorphic on $\mathbb{H}$ and bounded at the cusps. Let $f : F$, and assume $1 \in
+\Gamma.\mathrm{strictPeriods}$, i.e. $1$ is a strict period of $\Gamma$ (so that $\infty$ is a cusp
+of $\Gamma$ and $f$ is invariant under $z \mapsto z+1$). Let $p, q$ be natural numbers with
+$\gcd(p,q) = 1$. The conclusion is an equality of functions $\mathbb{H} \to \mathbb{C}$: $T_p(U_q f)
+= U_q(T_p f)$, where for a function $g$ on $\mathbb{H}$ one sets $U_q g = \sum_{j < q} g \mid_k
+\begin{pmatrix} 1 & j \\ 0 & q\end{pmatrix}$ and $T_p g = U_p g + g \mid_k \begin{pmatrix} p & 0 \\
+0 & 1\end{pmatrix}$, the occurring matrices being replaced by the identity when the index is $0$ (so
+that $U_0 g = 0$ and $T_0 g = g$). Note that the two sides are asserted to agree as plain functions;
+no modular-form structure on them is claimed.
+
+This is the commutativity of the Hecke operator $T_p$ with the operator $U_q$ at coprime indices,
+one of the relations underlying the commutativity of the Hecke algebra at a given level (on
+$\Gamma_0(N)$, $T_p$ for $p \nmid N$ and $U_q$ for $q \mid N$). It is used to pass the relation to
+the linear operators on spaces of cusp forms, and from there in the analysis of newforms, of trace
+and Atkin–Lehner operators, and in locating good eigensystems.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularFormClass_heckeT_heckeU_comm.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularFormClass_heckeT_heckeU_comm
+
+noncomputable section
+
+open Complex Function Filter
+p2m_open "UpperHalfPlane~I"
+open scoped Real MatrixGroups ModularForm Manifold Topology
+
+open ModularForm ModularFormClass
+
+namespace W2WsF
+
+private theorem _root_.W2WsF.eq_of_forall_qCoeff_eq {f g : ℍ → ℂ}
+    (hfper : Periodic (f ∘ ofComplex) 1) (hfhol : MDiff f)
+    (hfbdd : IsBoundedAtImInfty f) (hgper : Periodic (g ∘ ofComplex) 1) (hghol : MDiff g)
+    (hgbdd : IsBoundedAtImInfty g) (h : ∀ n : ℕ, qCoeff f n = qCoeff g n) : f = g :=
+  UpperHalfPlane.eq_of_forall_qCoeff_eq hfper hfhol hfbdd hgper hghol hgbdd h
+
+p2m_export "W2WsF" "eq_of_forall_qCoeff_eq"
+
+theorem qCoeff_const_smul {f : ℍ → ℂ} (hper : Periodic (f ∘ ofComplex) 1) (hhol : MDiff f)
+    (hbdd : IsBoundedAtImInfty f) (c : ℂ) (n : ℕ) : qCoeff (c • f) n = c * qCoeff f n := by
+  simp only [qCoeff]
+  rw [UpperHalfPlane.qExpansion_smul (analyticAt_cuspFunction_zero one_pos hper hhol hbdd)]
+  simp
+
+theorem periodic_const_smul {f : ℍ → ℂ} (hper : Periodic (f ∘ ofComplex) 1) (c : ℂ) :
+    Periodic ((c • f) ∘ ofComplex) 1 := fun z ↦ by
+  simpa using congrArg (c * ·) (hper z)
+
+section Class
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+theorem mf_periodic [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) :
+    Periodic (⇑f ∘ ofComplex) 1 :=
+  SlashInvariantFormClass.periodic_comp_ofComplex f hΓ
+
+theorem mf_bdd [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) :
+    IsBoundedAtImInfty ⇑f :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  bdd_at_infty f
+
+end Class
+
+theorem heckeT_heckeU_comm_bare {f : ℍ → ℂ} (hper : Periodic (f ∘ ofComplex) 1) (hhol : MDiff f)
+    (hbdd : IsBoundedAtImInfty f) (k : ℤ) {p q : ℕ} (hpq : p.Coprime q) :
+    heckeT k p (heckeU k q f) = heckeU k q (heckeT k p f) := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  rcases eq_or_ne q 0 with rfl | hq
+  · simp
+  refine eq_of_forall_qCoeff_eq
+    (periodic_heckeT_comp_ofComplex (periodic_heckeU_comp_ofComplex hper k q) k p)
+    (mdifferentiable_heckeT (mdifferentiable_heckeU hhol k q) k p)
+    (isBoundedAtImInfty_heckeT (isBoundedAtImInfty_heckeU hbdd k q) k p)
+    (periodic_heckeU_comp_ofComplex (periodic_heckeT_comp_ofComplex hper k p) k q)
+    (mdifferentiable_heckeU (mdifferentiable_heckeT hhol k p) k q)
+    (isBoundedAtImInfty_heckeU (isBoundedAtImInfty_heckeT hbdd k p) k q) fun n ↦ ?_
+  rw [UpperHalfPlane.qCoeff_heckeT (periodic_heckeU_comp_ofComplex hper k q)
+      (mdifferentiable_heckeU hhol k q) (isBoundedAtImInfty_heckeU hbdd k q) k hp,
+    UpperHalfPlane.qCoeff_heckeU (periodic_heckeT_comp_ofComplex hper k p)
+      (mdifferentiable_heckeT hhol k p) (isBoundedAtImInfty_heckeT hbdd k p) k hq]
+  have hq' : qCoeff (heckeU k q f) = coeffHeckeU q (qCoeff f) :=
+    funext fun m ↦ UpperHalfPlane.qCoeff_heckeU hper hhol hbdd k hq m
+  have hp' : qCoeff (heckeT k p f) = coeffHeckeT k p (qCoeff f) :=
+    funext fun m ↦ UpperHalfPlane.qCoeff_heckeT hper hhol hbdd k hp m
+  rw [hq', hp', coeffHeckeT_coeffHeckeU_comm k hpq]
+
+end W2WsF
+
+theorem solution {F : Type*} [FunLike F UpperHalfPlane ℂ]
+    {Γ : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)} {k : ℤ} [ModularFormClass F Γ k] (f : F)
+    (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) {p q : ℕ} (hpq : Nat.Coprime p q) :
+    ModularForm.heckeT k p (ModularForm.heckeU k q ⇑f) = ModularForm.heckeU k q (ModularForm.heckeT
+      k p ⇑f) :=
+  W2WsF.heckeT_heckeU_comm_bare (W2WsF.mf_periodic f hΓ) (ModularFormClass.holo f)
+    (W2WsF.mf_bdd f hΓ) k hpq
+
+end
+
+end S_ModularFormClass_heckeT_heckeU_comm
+end P2MW
+export P2MW.S_ModularFormClass_heckeT_heckeU_comm (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularFormClass.heckeT_heckeU_comm {F : Type*} [FunLike F UpperHalfPlane ℂ]
+    {Γ : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)} {k : ℤ} [ModularFormClass F Γ k] (f : F)
+    (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) {p q : ℕ} (hpq : Nat.Coprime p q) :
+    ModularForm.heckeT k p (ModularForm.heckeU k q ⇑f) = ModularForm.heckeU k q (ModularForm.heckeT
+      k p ⇑f) :=
+  solution f hΓ hpq
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularFormClass_heckeU_heckeU_comm.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularFormClass_heckeU_heckeU_comm.lean
new file mode 100644
index 0000000000..1d0f20af99
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularFormClass_heckeU_heckeU_comm.lean
@@ -0,0 +1,162 @@
+/-
+Based on Prove2Me node ModularFormClass.heckeU_heckeU_comm
+(f3f80576-97c9-5e28-975f-d88e7b710af9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 663622ea-77ea-5185-ba22-a26da8ff350f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_qCoeff_heckeU
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_mdifferentiable_heckeU
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_isBoundedAtImInfty_heckeU
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_periodic_heckeU_comp_ofComplex
+import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_eq_of_forall_qCoeff_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_coeffHeckeU_comm
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Commutativity of the Hecke operators Uₚ and U_q
+
+Theorem statement: `ModularFormClass.heckeU_heckeU_comm` (`f3f80576-97c9-5e28-975f-d88e7b710af9`),
+by Claude, 2026-09-05.
+
+Proof: submission `663622ea-77ea-5185-ba22-a26da8ff350f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a type of functions on the upper half-plane $\mathbb{H}$ with values in $\mathbb{C}$ (a
+`FunLike` structure), let $\Gamma$ be a subgroup of $\mathrm{GL}_2(\mathbb{R})$, let $k$ be an
+integer, and assume $F$ is a class of modular forms of weight $k$ for $\Gamma$ (`ModularFormClass F
+Γ k`). Let $f : F$, and assume $1$ belongs to `Γ.strictPeriods`, i.e. the real number $1$ is a
+strict period of $\Gamma$ in Mathlib's sense, so that the translation $z \mapsto z+1$ is available
+as a symmetry and the cusp $\infty$ is a cusp of $\Gamma$. Let $p$ and $q$ be arbitrary natural
+numbers. Here, for a function $g : \mathbb{H} \to \mathbb{C}$, the operator is defined by
+$\mathrm{heckeU}\,k\,p\,g = \sum_{j=0}^{p-1} g \mid_k \gamma_{p,j}$, the weight-$k$ slash action of
+the invertible real matrices $\gamma_{p,j}$ with rows $(1, j)$ and $(0, p)$ for $p \neq 0$ (and
+$\gamma_{0,j} = 1$, so that the empty sum makes $\mathrm{heckeU}\,k\,0$ the zero function). The
+conclusion is the equality of functions $\mathbb{H} \to \mathbb{C}$: $U_p(U_q \underline{f}) =
+U_q(U_p \underline{f})$, where $\underline{f}$ is the function underlying $f$. No primality,
+coprimality or positivity hypothesis on $p$ and $q$ is imposed.
+
+This is the commutativity of the operators $U_p$ on modular forms, one ingredient in the
+commutativity of the Hecke algebra acting on spaces of modular forms. It is used for the
+corresponding statement for linear operators on cusp forms,
+[`CuspForm.heckeULin_comm`](thm.html#CuspForm.heckeULin_comm).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularFormClass_heckeU_heckeU_comm.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularFormClass_heckeU_heckeU_comm
+
+noncomputable section
+
+open Complex Function Filter
+p2m_open "UpperHalfPlane~I"
+open scoped Real MatrixGroups ModularForm Manifold Topology
+
+open ModularForm ModularFormClass
+
+namespace W2WsF
+
+private theorem _root_.W2WsF.eq_of_forall_qCoeff_eq {f g : ℍ → ℂ}
+    (hfper : Periodic (f ∘ ofComplex) 1) (hfhol : MDiff f)
+    (hfbdd : IsBoundedAtImInfty f) (hgper : Periodic (g ∘ ofComplex) 1) (hghol : MDiff g)
+    (hgbdd : IsBoundedAtImInfty g) (h : ∀ n : ℕ, qCoeff f n = qCoeff g n) : f = g :=
+  UpperHalfPlane.eq_of_forall_qCoeff_eq hfper hfhol hfbdd hgper hghol hgbdd h
+
+p2m_export "W2WsF" "eq_of_forall_qCoeff_eq"
+
+theorem qCoeff_const_smul {f : ℍ → ℂ} (hper : Periodic (f ∘ ofComplex) 1) (hhol : MDiff f)
+    (hbdd : IsBoundedAtImInfty f) (c : ℂ) (n : ℕ) : qCoeff (c • f) n = c * qCoeff f n := by
+  simp only [qCoeff]
+  rw [UpperHalfPlane.qExpansion_smul (analyticAt_cuspFunction_zero one_pos hper hhol hbdd)]
+  simp
+
+theorem periodic_const_smul {f : ℍ → ℂ} (hper : Periodic (f ∘ ofComplex) 1) (c : ℂ) :
+    Periodic ((c • f) ∘ ofComplex) 1 := fun z ↦ by
+  simpa using congrArg (c * ·) (hper z)
+
+section Class
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+theorem mf_periodic [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) :
+    Periodic (⇑f ∘ ofComplex) 1 :=
+  SlashInvariantFormClass.periodic_comp_ofComplex f hΓ
+
+theorem mf_bdd [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) :
+    IsBoundedAtImInfty ⇑f :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  bdd_at_infty f
+
+end Class
+
+theorem heckeU_heckeU_comm_bare {f : ℍ → ℂ} (hper : Periodic (f ∘ ofComplex) 1) (hhol : MDiff f)
+    (hbdd : IsBoundedAtImInfty f) (k : ℤ) (p q : ℕ) :
+    heckeU k p (heckeU k q f) = heckeU k q (heckeU k p f) := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  rcases eq_or_ne q 0 with rfl | hq
+  · simp
+  refine eq_of_forall_qCoeff_eq
+    (periodic_heckeU_comp_ofComplex (periodic_heckeU_comp_ofComplex hper k q) k p)
+    (mdifferentiable_heckeU (mdifferentiable_heckeU hhol k q) k p)
+    (isBoundedAtImInfty_heckeU (isBoundedAtImInfty_heckeU hbdd k q) k p)
+    (periodic_heckeU_comp_ofComplex (periodic_heckeU_comp_ofComplex hper k p) k q)
+    (mdifferentiable_heckeU (mdifferentiable_heckeU hhol k p) k q)
+    (isBoundedAtImInfty_heckeU (isBoundedAtImInfty_heckeU hbdd k p) k q) fun n ↦ ?_
+  rw [UpperHalfPlane.qCoeff_heckeU (periodic_heckeU_comp_ofComplex hper k q)
+      (mdifferentiable_heckeU hhol k q) (isBoundedAtImInfty_heckeU hbdd k q) k hp,
+    UpperHalfPlane.qCoeff_heckeU (periodic_heckeU_comp_ofComplex hper k p)
+      (mdifferentiable_heckeU hhol k p) (isBoundedAtImInfty_heckeU hbdd k p) k hq]
+  have hq' : qCoeff (heckeU k q f) = coeffHeckeU q (qCoeff f) :=
+    funext fun m ↦ UpperHalfPlane.qCoeff_heckeU hper hhol hbdd k hq m
+  have hp' : qCoeff (heckeU k p f) = coeffHeckeU p (qCoeff f) :=
+    funext fun m ↦ UpperHalfPlane.qCoeff_heckeU hper hhol hbdd k hp m
+  rw [hq', hp', coeffHeckeU_comm]
+
+end W2WsF
+
+theorem solution {F : Type*} [FunLike F UpperHalfPlane ℂ]
+    {Γ : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)} {k : ℤ} [ModularFormClass F Γ k] (f : F)
+    (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) (p q : ℕ) :
+    ModularForm.heckeU k p (ModularForm.heckeU k q ⇑f) = ModularForm.heckeU k q (ModularForm.heckeU
+      k p ⇑f) :=
+  W2WsF.heckeU_heckeU_comm_bare (W2WsF.mf_periodic f hΓ) (ModularFormClass.holo f)
+    (W2WsF.mf_bdd f hΓ) k p q
+
+end
+
+end S_ModularFormClass_heckeU_heckeU_comm
+end P2MW
+export P2MW.S_ModularFormClass_heckeU_heckeU_comm (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularFormClass.heckeU_heckeU_comm {F : Type*} [FunLike F UpperHalfPlane ℂ]
+    {Γ : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)} {k : ℤ} [ModularFormClass F Γ k] (f : F)
+    (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) (p q : ℕ) :
+    ModularForm.heckeU k p (ModularForm.heckeU k q ⇑f) = ModularForm.heckeU k q (ModularForm.heckeU
+      k p ⇑f) :=
+  solution f hΓ p q
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularFormClass_isBoundedAt_heckeT.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularFormClass_isBoundedAt_heckeT.lean
new file mode 100644
index 0000000000..6c8e99d7f9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularFormClass_isBoundedAt_heckeT.lean
@@ -0,0 +1,215 @@
+/-
+Based on Prove2Me node ModularFormClass.isBoundedAt_heckeT
+(25cbeda5-8d19-592d-8416-c64dd14fde75) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2f1a1daa-2b9b-518a-82b1-f997445165ee
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Tₚ f is bounded at every cusp
+
+Theorem statement: `ModularFormClass.isBoundedAt_heckeT` (`25cbeda5-8d19-592d-8416-c64dd14fde75`),
+by Claude, 2026-09-05.
+
+Proof: submission `2f1a1daa-2b9b-518a-82b1-f997445165ee`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a type whose elements are coerced to functions $\mathbb{H} \to \mathbb{C}$ on the upper
+half-plane, let $\Gamma$ be a subgroup of $\mathrm{GL}_2(\mathbb{R})$ that is arithmetic, let $k$ be
+an integer, and suppose $F$ is a class of weight-$k$ modular forms for $\Gamma$ (so each $f : F$ is
+holomorphic, satisfies the weight-$k$ transformation law under $\Gamma$, and is bounded at the cusps
+of $\Gamma$). Let $f : F$, let $p$ be a natural number, and let $c \in \mathbb{P}^1(\mathbb{R}) =$
+`OnePoint ℝ` be a cusp of $\Gamma$, i.e. `IsCusp c Γ` holds. The conclusion is that the function
+$$\mathrm{heckeT}\,k\,p\,f \;=\; \sum_{j = 0}^{p-1} f \mid_k \begin{pmatrix} 1 & j \\ 0 &
+p\end{pmatrix} \;+\; f \mid_k \begin{pmatrix} p & 0 \\ 0 & 1\end{pmatrix}$$ is bounded at $c$ in
+weight $k$, in the sense of `OnePoint.IsBoundedAt`: its weight-$k$ slashes by matrices carrying
+$\infty$ to $c$ are bounded towards $i\infty$. No condition relating $p$ to a level is imposed, and
+$p = 0$ is allowed: by convention both Hecke matrices are then the identity, so the sum is empty and
+the second term is $f \mid_k 1$.
+
+This is the boundedness-at-the-cusps half of the statement that the Hecke operator $T_p$ preserves
+modular forms; together with the corresponding holomorphy and weight-$k$ invariance statements it
+supplies the `bdd_at_cusps` datum needed to package $T_p f$ as a modular form on $\Gamma_0(N)$. The
+companion result for cusp forms replaces boundedness by vanishing at the cusps.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularFormClass_isBoundedAt_heckeT.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularFormClass_isBoundedAt_heckeT
+
+namespace ModularForm
+p2m_export "ModularForm" "add ext upperTriangularGL heckeMatrix heckeDiagMatrix heckeMatrix_zero \
+  heckeDiagMatrix_zero heckeU heckeT heckeU_def heckeT_eq_heckeU_add"
+namespace S06W2
+p2m_open "ModularForm"
+
+open UpperHalfPlane OnePoint
+p2m_open_scoped "MatrixGroups ModularForm P2MW.S_ModularFormClass_isBoundedAt_heckeT.ModularForm"
+
+section RatCusps
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} [Γ.IsArithmetic] {k : ℤ}
+
+theorem isCusp_ratCast_smul {c : OnePoint ℝ} (hc : IsCusp c Γ) (g : GL (Fin 2) ℚ) :
+    IsCusp (Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) g • c) Γ := by
+  rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z, isCusp_SL2Z_iff] at hc ⊢
+  obtain ⟨c, rfl⟩ := hc
+  exact ⟨g • c, by rw [← Rat.coe_castHom, OnePoint.map_smul]⟩
+
+theorem isBoundedAt_slash_ratCast [ModularFormClass F Γ k] (f : F) (g : GL (Fin 2) ℚ)
+    {c : OnePoint ℝ}
+    (hc : IsCusp c Γ) : c.IsBoundedAt (⇑f ∣[k] (Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) g)) k
+      :=
+  OnePoint.IsBoundedAt.smul_iff.mp (ModularFormClass.bdd_at_cusps f (isCusp_ratCast_smul hc g))
+
+theorem isZeroAt_slash_ratCast [CuspFormClass F Γ k] (f : F) (g : GL (Fin 2) ℚ) {c : OnePoint ℝ}
+    (hc : IsCusp c Γ) : c.IsZeroAt (⇑f ∣[k] (Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) g)) k :=
+  OnePoint.IsZeroAt.smul_iff.mp (CuspFormClass.zero_at_cusps f (isCusp_ratCast_smul hc g))
+
+end RatCusps
+
+section HeckeMatrices
+
+def ratUpperTriangularGL (a b d : ℚ) (had : a * d ≠ 0) : GL (Fin 2) ℚ :=
+  Matrix.GeneralLinearGroup.mkOfDetNeZero !![a, b; 0, d]
+    (by rwa [Matrix.det_fin_two_of, mul_zero, sub_zero])
+
+theorem upperTriangularGL_eq_map (a b d : ℚ) (had : a * d ≠ 0) :
+    upperTriangularGL a b d (by exact_mod_cast had) =
+      Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) (ratUpperTriangularGL a b d had) := by
+  ext i j
+  fin_cases i <;> fin_cases j <;>
+    simp [ratUpperTriangularGL, upperTriangularGL, Matrix.GeneralLinearGroup.mkOfDetNeZero]
+
+theorem exists_heckeMatrix_eq_map (p j : ℕ) :
+    ∃ g : GL (Fin 2) ℚ, heckeMatrix p j = Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) g := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · exact ⟨1, by rw [heckeMatrix_zero, map_one]⟩
+  · refine ⟨ratUpperTriangularGL 1 j p (by rw [one_mul]; exact_mod_cast hp), ?_⟩
+    ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp [heckeMatrix, hp, ratUpperTriangularGL, upperTriangularGL,
+        Matrix.GeneralLinearGroup.mkOfDetNeZero]
+
+theorem exists_heckeDiagMatrix_eq_map (p : ℕ) :
+    ∃ g : GL (Fin 2) ℚ, heckeDiagMatrix p = Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) g := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · exact ⟨1, by rw [heckeDiagMatrix_zero, map_one]⟩
+  · refine ⟨ratUpperTriangularGL p 0 1 (by rw [mul_one]; exact_mod_cast hp), ?_⟩
+    ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp [heckeDiagMatrix, hp, ratUpperTriangularGL, upperTriangularGL,
+        Matrix.GeneralLinearGroup.mkOfDetNeZero]
+
+end HeckeMatrices
+
+section Cusps
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} [Γ.IsArithmetic] {k : ℤ}
+
+theorem isBoundedAt_sum {ι : Type*} {c : OnePoint ℝ} {k : ℤ} (s : Finset ι)
+    {f : ι → ℍ → ℂ} (hf : ∀ i ∈ s, c.IsBoundedAt (f i) k) : c.IsBoundedAt (∑ i ∈ s, f i) k := by
+  classical
+  induction s using Finset.induction_on with
+  | empty =>
+    intro g _
+    rw [Finset.sum_empty, SlashAction.zero_slash]
+    exact Filter.const_boundedAtFilter _ (0 : ℂ)
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha]
+    exact (hf a (Finset.mem_insert_self a s)).add (ih fun i hi => hf i (Finset.mem_insert_of_mem
+      hi))
+
+theorem isZeroAt_sum {ι : Type*} {c : OnePoint ℝ} {k : ℤ} (s : Finset ι)
+    {f : ι → ℍ → ℂ} (hf : ∀ i ∈ s, c.IsZeroAt (f i) k) : c.IsZeroAt (∑ i ∈ s, f i) k := by
+  classical
+  induction s using Finset.induction_on with
+  | empty =>
+    intro g _
+    rw [Finset.sum_empty, SlashAction.zero_slash]
+    exact Filter.zero_zeroAtFilter _
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha]
+    exact (hf a (Finset.mem_insert_self a s)).add (ih fun i hi => hf i (Finset.mem_insert_of_mem
+      hi))
+
+theorem isBoundedAt_heckeU [ModularFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ}
+    (hc : IsCusp c Γ) :
+    c.IsBoundedAt (heckeU k p ⇑f) k := by
+  rw [heckeU_def]
+  refine isBoundedAt_sum _ fun j _ => ?_
+  obtain ⟨g, hg⟩ := exists_heckeMatrix_eq_map p j
+  rw [hg]
+  exact isBoundedAt_slash_ratCast f g hc
+
+theorem isBoundedAt_heckeT [ModularFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ}
+    (hc : IsCusp c Γ) :
+    c.IsBoundedAt (heckeT k p ⇑f) k := by
+  rw [heckeT_eq_heckeU_add]
+  refine (isBoundedAt_heckeU f p hc).add ?_
+  obtain ⟨g, hg⟩ := exists_heckeDiagMatrix_eq_map p
+  rw [hg]
+  exact isBoundedAt_slash_ratCast f g hc
+
+theorem isZeroAt_heckeU [CuspFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ} (hc : IsCusp c Γ) :
+    c.IsZeroAt (heckeU k p ⇑f) k := by
+  rw [heckeU_def]
+  refine isZeroAt_sum _ fun j _ => ?_
+  obtain ⟨g, hg⟩ := exists_heckeMatrix_eq_map p j
+  rw [hg]
+  exact isZeroAt_slash_ratCast f g hc
+
+theorem isZeroAt_heckeT [CuspFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ} (hc : IsCusp c Γ) :
+    c.IsZeroAt (heckeT k p ⇑f) k := by
+  rw [heckeT_eq_heckeU_add]
+  refine (isZeroAt_heckeU f p hc).add ?_
+  obtain ⟨g, hg⟩ := exists_heckeDiagMatrix_eq_map p
+  rw [hg]
+  exact isZeroAt_slash_ratCast f g hc
+
+end Cusps
+
+end ModularForm.S06W2
+
+theorem solution {F : Type*} [FunLike F UpperHalfPlane ℂ]
+    {Γ : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)} [Γ.IsArithmetic] {k : ℤ}
+    [ModularFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ} (hc : IsCusp c Γ) :
+    OnePoint.IsBoundedAt c (ModularForm.heckeT k p ⇑f) k :=
+  ModularForm.S06W2.isBoundedAt_heckeT f p hc
+
+end S_ModularFormClass_isBoundedAt_heckeT
+end P2MW
+export P2MW.S_ModularFormClass_isBoundedAt_heckeT (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularFormClass.isBoundedAt_heckeT {F : Type*} [FunLike F UpperHalfPlane ℂ]
+    {Γ : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)} [Γ.IsArithmetic] {k : ℤ}
+    [ModularFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ} (hc : IsCusp c Γ) :
+    OnePoint.IsBoundedAt c (ModularForm.heckeT k p ⇑f) k :=
+  solution f p hc
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularFormClass_isBoundedAt_heckeU.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularFormClass_isBoundedAt_heckeU.lean
new file mode 100644
index 0000000000..b2dcbac111
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularFormClass_isBoundedAt_heckeU.lean
@@ -0,0 +1,211 @@
+/-
+Based on Prove2Me node ModularFormClass.isBoundedAt_heckeU
+(9e99632d-bbbf-5a55-9d7e-eb14a1471767) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1be9a414-4aa1-56c6-aa58-e07600186dd3
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+/-!
+# Uₚ f is bounded at every cusp
+
+Theorem statement: `ModularFormClass.isBoundedAt_heckeU` (`9e99632d-bbbf-5a55-9d7e-eb14a1471767`),
+by Claude, 2026-09-05.
+
+Proof: submission `1be9a414-4aa1-56c6-aa58-e07600186dd3`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a type whose elements act as functions from the upper half-plane $\mathbb{H}$ to
+$\mathbb{C}$, let $\Gamma$ be a subgroup of $\mathrm{GL}_2(\mathbb{R})$ satisfying
+`Subgroup.IsArithmetic`, let $k$ be an integer, and assume `ModularFormClass F \Gamma k`, so that
+each element of $F$ is a weight-$k$ modular form for $\Gamma$ (in particular holomorphic,
+slash-invariant and bounded at the cusps of $\Gamma$). Let $f : F$, let $p$ be a natural number, and
+let $c \in \mathbb{P}^1(\mathbb{R}) =$ `OnePoint ℝ` be a cusp of $\Gamma$, i.e. `IsCusp c Γ` holds.
+The conclusion is that the function $$\mathrm{heckeU}\,k\,p\,f \;=\; \sum_{j \in \{0,\dots,p-1\}} f
+\mid_k \mathrm{heckeMatrix}\,p\,j,$$ where $\mathrm{heckeMatrix}\,p\,j$ is the identity when $p = 0$
+and otherwise the upper triangular matrix $\begin{pmatrix} 1 & j \\ 0 & p\end{pmatrix} \in
+\mathrm{GL}_2(\mathbb{R})$, is bounded at $c$ in weight $k$ in the sense of `OnePoint.IsBoundedAt`.
+No condition relating $p$ to the level of $\Gamma$ is imposed, and for $p = 0$ the sum is empty, so
+the assertion is then boundedness of the zero function.
+
+This is the cusp-boundedness half of the statement that the Hecke operator $U_p$ preserves
+weight-$k$ modular forms; together with holomorphy and slash-invariance it supplies the
+`bdd_at_cusps` condition needed to view $U_p f$ as a modular form on a congruence subgroup. It is
+used in the study of $q$-expansions and function fields of modular curves, for instance in the
+comparison of $q$-expansion function fields for $\Gamma_0$-level structures and in the
+identification of the function field at full level for level two.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularFormClass_isBoundedAt_heckeU.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+namespace ModularForm
+
+open UpperHalfPlane OnePoint
+open scoped MatrixGroups ModularForm
+
+section RatCusps
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)}
+  [Γ.IsArithmetic] {k : ℤ}
+
+theorem isCusp_ratCast_smul {c : OnePoint ℝ} (hc : IsCusp c Γ) (g : GL (Fin 2) ℚ) :
+    IsCusp (Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) g • c) Γ := by
+  rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z, isCusp_SL2Z_iff] at hc ⊢
+  obtain ⟨c, rfl⟩ := hc
+  exact ⟨g • c, by rw [← Rat.coe_castHom, OnePoint.map_smul]⟩
+
+theorem isBoundedAt_slash_ratCast
+    [ModularFormClass F Γ k] (f : F) (g : GL (Fin 2) ℚ) {c : OnePoint ℝ} (hc : IsCusp c Γ) :
+    c.IsBoundedAt (⇑f ∣[k] (Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) g)) k :=
+  OnePoint.IsBoundedAt.smul_iff.mp (ModularFormClass.bdd_at_cusps f (isCusp_ratCast_smul hc g))
+
+theorem isZeroAt_slash_ratCast [CuspFormClass F Γ k]
+    (f : F) (g : GL (Fin 2) ℚ) {c : OnePoint ℝ} (hc : IsCusp c Γ) :
+    c.IsZeroAt (⇑f ∣[k] (Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) g)) k :=
+  OnePoint.IsZeroAt.smul_iff.mp (CuspFormClass.zero_at_cusps f (isCusp_ratCast_smul hc g))
+
+end RatCusps
+
+section HeckeMatrices
+
+def ratUpperTriangularGL (a b d : ℚ) (had : a * d ≠ 0) : GL (Fin 2) ℚ :=
+  Matrix.GeneralLinearGroup.mkOfDetNeZero !![a, b; 0, d]
+    (by rwa [Matrix.det_fin_two_of, mul_zero, sub_zero])
+
+theorem upperTriangularGL_eq_map (a b d : ℚ) (had : a * d ≠ 0) :
+    upperTriangularGL a b d (by exact_mod_cast had) =
+      Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) (ratUpperTriangularGL a b d had) := by
+  ext i j
+  fin_cases i <;> fin_cases j <;>
+    simp [ratUpperTriangularGL, upperTriangularGL, Matrix.GeneralLinearGroup.mkOfDetNeZero]
+
+theorem exists_heckeMatrix_eq_map (p j : ℕ) :
+    ∃ g : GL (Fin 2) ℚ,
+      heckeMatrix p j = Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) g := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · exact ⟨1, by rw [heckeMatrix_zero, map_one]⟩
+  · refine ⟨ratUpperTriangularGL 1 j p (by rw [one_mul]; exact_mod_cast hp), ?_⟩
+    ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp [heckeMatrix, hp, ratUpperTriangularGL, upperTriangularGL,
+        Matrix.GeneralLinearGroup.mkOfDetNeZero]
+
+theorem exists_heckeDiagMatrix_eq_map (p : ℕ) :
+    ∃ g : GL (Fin 2) ℚ,
+      heckeDiagMatrix p = Matrix.GeneralLinearGroup.map (Rat.castHom ℝ) g := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · exact ⟨1, by rw [heckeDiagMatrix_zero, map_one]⟩
+  · refine ⟨ratUpperTriangularGL p 0 1 (by rw [mul_one]; exact_mod_cast hp), ?_⟩
+    ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp [heckeDiagMatrix, hp, ratUpperTriangularGL, upperTriangularGL,
+        Matrix.GeneralLinearGroup.mkOfDetNeZero]
+
+end HeckeMatrices
+
+section Cusps
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)}
+  [Γ.IsArithmetic] {k : ℤ}
+
+theorem isBoundedAt_sum {ι : Type*} {c : OnePoint ℝ} {k : ℤ} (s : Finset ι)
+    {f : ι → ℍ → ℂ} (hf : ∀ i ∈ s, c.IsBoundedAt (f i) k) :
+    c.IsBoundedAt (∑ i ∈ s, f i) k := by
+  classical
+  induction s using Finset.induction_on with
+  | empty =>
+    intro g _
+    rw [Finset.sum_empty, SlashAction.zero_slash]
+    exact Filter.const_boundedAtFilter _ (0 : ℂ)
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha]
+    exact (hf a (Finset.mem_insert_self a s)).add
+      (ih fun i hi => hf i (Finset.mem_insert_of_mem hi))
+
+theorem isZeroAt_sum {ι : Type*} {c : OnePoint ℝ} {k : ℤ} (s : Finset ι)
+    {f : ι → ℍ → ℂ} (hf : ∀ i ∈ s, c.IsZeroAt (f i) k) :
+    c.IsZeroAt (∑ i ∈ s, f i) k := by
+  classical
+  induction s using Finset.induction_on with
+  | empty =>
+    intro g _
+    rw [Finset.sum_empty, SlashAction.zero_slash]
+    exact Filter.zero_zeroAtFilter _
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha]
+    exact (hf a (Finset.mem_insert_self a s)).add
+      (ih fun i hi => hf i (Finset.mem_insert_of_mem hi))
+
+theorem isBoundedAt_heckeU
+    [ModularFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ} (hc : IsCusp c Γ) :
+    c.IsBoundedAt (heckeU k p ⇑f) k := by
+  rw [heckeU_def]
+  refine isBoundedAt_sum _ fun j _ => ?_
+  obtain ⟨g, hg⟩ := exists_heckeMatrix_eq_map p j
+  rw [hg]
+  exact isBoundedAt_slash_ratCast f g hc
+
+theorem isBoundedAt_heckeT
+    [ModularFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ} (hc : IsCusp c Γ) :
+    c.IsBoundedAt (heckeT k p ⇑f) k := by
+  rw [heckeT_eq_heckeU_add]
+  refine (isBoundedAt_heckeU f p hc).add ?_
+  obtain ⟨g, hg⟩ := exists_heckeDiagMatrix_eq_map p
+  rw [hg]
+  exact isBoundedAt_slash_ratCast f g hc
+
+theorem isZeroAt_heckeU [CuspFormClass F Γ k]
+    (f : F) (p : ℕ) {c : OnePoint ℝ} (hc : IsCusp c Γ) :
+    c.IsZeroAt (heckeU k p ⇑f) k := by
+  rw [heckeU_def]
+  refine isZeroAt_sum _ fun j _ => ?_
+  obtain ⟨g, hg⟩ := exists_heckeMatrix_eq_map p j
+  rw [hg]
+  exact isZeroAt_slash_ratCast f g hc
+
+theorem isZeroAt_heckeT [CuspFormClass F Γ k]
+    (f : F) (p : ℕ) {c : OnePoint ℝ} (hc : IsCusp c Γ) :
+    c.IsZeroAt (heckeT k p ⇑f) k := by
+  rw [heckeT_eq_heckeU_add]
+  refine (isZeroAt_heckeU f p hc).add ?_
+  obtain ⟨g, hg⟩ := exists_heckeDiagMatrix_eq_map p
+  rw [hg]
+  exact isZeroAt_slash_ratCast f g hc
+
+end Cusps
+
+end ModularForm
+
+theorem solution
+    {F : Type*} [FunLike F UpperHalfPlane ℂ] {Γ : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)}
+    [Γ.IsArithmetic] {k : ℤ} [ModularFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ}
+    (hc : IsCusp c Γ) :
+    OnePoint.IsBoundedAt c (ModularForm.heckeU k p ⇑f) k :=
+  ModularForm.isBoundedAt_heckeU f p hc
+
+end privateSection
+
+public section publicSection
+
+theorem ModularFormClass.isBoundedAt_heckeU
+    {F : Type*} [FunLike F UpperHalfPlane ℂ] {Γ : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)}
+    [Γ.IsArithmetic] {k : ℤ} [ModularFormClass F Γ k] (f : F) (p : ℕ) {c : OnePoint ℝ}
+    (hc : IsCusp c Γ) :
+    OnePoint.IsBoundedAt c (ModularForm.heckeU k p ⇑f) k :=
+  solution f p hc
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularFormClass_qCoeff_comp_heckeDiagMatrix_smul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularFormClass_qCoeff_comp_heckeDiagMatrix_smul.lean
new file mode 100644
index 0000000000..c34e6ef7b1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularFormClass_qCoeff_comp_heckeDiagMatrix_smul.lean
@@ -0,0 +1,199 @@
+/-
+Based on Prove2Me node ModularFormClass.qCoeff_comp_heckeDiagMatrix_smul
+(39a1ca12-fba1-54bd-a0be-c186090e9746) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 99f2a9c5-c9cc-5664-9299-730f84b5cbbe
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# q-expansion of f(dτ): coefficients shift by d
+
+Theorem statement: `ModularFormClass.qCoeff_comp_heckeDiagMatrix_smul`
+(`39a1ca12-fba1-54bd-a0be-c186090e9746`), by Claude, 2026-09-05.
+
+Proof: submission `99f2a9c5-c9cc-5664-9299-730f84b5cbbe`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a type equipped with a coercion to functions from the upper half-plane $\mathbb{H}$ to
+$\mathbb{C}$, let $\Gamma$ be a subgroup of $\mathrm{GL}_2(\mathbb{R})$, let $k$ be an integer, and
+assume $F$ is a `ModularFormClass` for $\Gamma$ and $k$ (so each element of $F$ is weight-$k$
+invariant under $\Gamma$, holomorphic, and bounded at $i\infty$). Let $f : F$, and assume $1$
+belongs to $\Gamma$.`strictPeriods`, i.e. the real number $1$ is a strict period of $\Gamma$, which
+in particular makes $\infty$ a cusp for $\Gamma$ and gives $f$ a Fourier expansion in $q = e^{2\pi i
+\tau}$. Let $d$ be a nonzero natural number and $n$ a natural number. Here [`ModularFormClass.qCoeff
+g n`](def/FLTPrelim_Modularity.html#L19) denotes the $n$-th coefficient of the $q$-expansion of
+period $1$ of a function $g : \mathbb{H} \to \mathbb{C}$, and [`ModularForm.heckeDiagMatrix
+d`](def/ModularForm_HeckeOperator.html#L21) is the element of $\mathrm{GL}_2(\mathbb{R})$ given by
+the upper triangular matrix $\begin{pmatrix} d & 0 \\ 0 & 1\end{pmatrix}$ for $d \neq 0$ (and the
+identity for $d = 0$), whose action on $\mathbb{H}$ is $\tau \mapsto d\tau$. The conclusion is that
+the $n$-th $q$-expansion coefficient of $\tau \mapsto f(d\tau)$ equals the $(n/d)$-th coefficient of
+$f$ if $d \mid n$, and $0$ otherwise.
+
+This is the effect on Fourier coefficients of the degeneracy (oldform) operator $V_d : f \mapsto
+f(d\tau)$, i.e. the identity $f(d\tau) = \sum_n a_n q^{dn}$. It is used throughout the treatment of
+oldforms, newforms and level lowering, for instance in identifying the level of a newform from the
+vanishing of its coefficients at primes and in comparisons of degeneracy maps on spaces of cusp
+forms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularFormClass_qCoeff_comp_heckeDiagMatrix_smul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularFormClass_qCoeff_comp_heckeDiagMatrix_smul
+
+p2m_open "Complex Filter Function UpperHalfPlane \
+  P2MW.S_ModularFormClass_qCoeff_comp_heckeDiagMatrix_smul.UpperHalfPlane ModularForm"
+open scoped Real MatrixGroups Topology Manifold ModularForm
+
+noncomputable section
+
+namespace UpperHalfPlane
+p2m_export "UpperHalfPlane" "cuspFunction qExpansion ofComplex_apply_of_im_pos \
+  analyticAt_cuspFunction_zero atImInfty ofComplex_apply_of_im_nonpos hasSum_qExpansion \
+  qExpansion_coeff_unique im_smul_eq_div_normSq re IsBoundedAtImInfty im ofComplex"
+namespace DegeneracyQExp
+p2m_open "UpperHalfPlane"
+
+private def FnLike : Type := ℍ → ℂ
+
+private scoped instance : FunLike FnLike ℍ ℂ where
+  coe f := f
+  coe_injective _ _ h := h
+
+variable {d : ℕ}
+
+theorem heckeDiagMatrix_smul_ofComplex (hd : d ≠ 0) {z : ℂ} (hz : 0 < z.im) :
+    heckeDiagMatrix d • ofComplex z = ofComplex ((d : ℂ) * z) := by
+  have hz' : 0 < ((d : ℂ) * z).im := by
+    rw [show ((d : ℂ) * z).im = d * z.im by simp]
+    have : (0 : ℝ) < d := by exact_mod_cast Nat.pos_of_ne_zero hd
+    positivity
+  apply UpperHalfPlane.ext
+  rw [coe_heckeDiagMatrix_smul hd, ofComplex_apply_of_im_pos hz, ofComplex_apply_of_im_pos hz']
+
+theorem periodic_comp_smul (hd : d ≠ 0) {F : ℍ → ℂ} (hper : Periodic (F ∘ ofComplex) 1) :
+    Periodic ((fun τ ↦ F (heckeDiagMatrix d • τ)) ∘ ofComplex) 1 := by
+  intro w
+  by_cases hw : 0 < w.im
+  · have hw1 : 0 < (w + 1).im := by simpa using hw
+    simp only [comp_apply]
+    rw [heckeDiagMatrix_smul_ofComplex hd hw1, heckeDiagMatrix_smul_ofComplex hd hw, mul_add,
+      mul_one]
+    have h := hper.nat_mul d ((d : ℂ) * w)
+    simpa using h
+  · push Not at hw
+    have hw1 : (w + 1).im ≤ 0 := by simpa using hw
+    simp only [comp_apply, ofComplex_apply_of_im_nonpos hw, ofComplex_apply_of_im_nonpos hw1]
+
+theorem mdifferentiable_comp_smul (hd : d ≠ 0) {F : ℍ → ℂ} (hhol : MDiff F) :
+    MDiff (fun τ ↦ F (heckeDiagMatrix d • τ)) := by
+  have hd' : (d : ℂ) ≠ 0 := by exact_mod_cast hd
+  have h := (hhol.slash 0 (heckeDiagMatrix d)).const_smul (d : ℂ)
+  convert h using 1
+  funext τ
+  rw [Pi.smul_apply, slash_heckeDiagMatrix_apply 0 hd, smul_eq_mul, zero_sub, zpow_neg_one,
+    ← mul_assoc, mul_inv_cancel₀ hd', one_mul]
+
+theorem isBoundedAtImInfty_comp_smul (hd : d ≠ 0) {F : ℍ → ℂ} (hbdd : IsBoundedAtImInfty F) :
+    IsBoundedAtImInfty (fun τ ↦ F (heckeDiagMatrix d • τ)) := by
+  refine hbdd.comp_tendsto ?_
+  rw [atImInfty, tendsto_comap_iff]
+  have him : (UpperHalfPlane.im ∘ fun τ : ℍ ↦ heckeDiagMatrix d • τ) = fun τ ↦ (d : ℝ) * τ.im := by
+    funext τ
+    simp only [comp_apply]
+    rw [UpperHalfPlane.im_smul_eq_div_normSq, denom_heckeDiagMatrix hd, det_heckeDiagMatrix hd]
+    simp
+  rw [him]
+  have hd0 : (0 : ℝ) < d := by exact_mod_cast Nat.pos_of_ne_zero hd
+  exact tendsto_comap.const_mul_atTop hd0
+
+theorem qCoeff_comp_smul {F : ℍ → ℂ} (hper : Periodic (F ∘ ofComplex) 1) (hhol : MDiff F)
+    (hbdd : IsBoundedAtImInfty F) (hd : d ≠ 0) (n : ℕ) :
+    ModularFormClass.qCoeff (fun τ ↦ F (heckeDiagMatrix d • τ)) n =
+      if d ∣ n then ModularFormClass.qCoeff F (n / d) else 0 := by
+  set G : ℍ → ℂ := fun τ ↦ F (heckeDiagMatrix d • τ) with hG
+  have han : AnalyticAt ℂ (cuspFunction 1 G) 0 :=
+    analyticAt_cuspFunction_zero one_pos (periodic_comp_smul hd hper) (mdifferentiable_comp_smul hd
+      hhol)
+      (isBoundedAtImInfty_comp_smul hd hbdd)
+  set c : ℕ → ℂ := fun n ↦ if d ∣ n then (qExpansion 1 F).coeff (n / d) else 0 with hc
+  have hsum : ∀ τ : ℍ, HasSum (fun m ↦ c m • Periodic.qParam 1 τ ^ m) (G τ) := by
+    intro τ
+    have hq : Periodic.qParam 1 ((heckeDiagMatrix d • τ : ℍ) : ℂ) = Periodic.qParam 1 τ ^ d := by
+      simp only [Periodic.qParam, ← Complex.exp_nat_mul, coe_heckeDiagMatrix_smul hd]
+      congr 1
+      push_cast
+      ring
+    have hs := hasSum_qExpansion one_pos hper hhol hbdd (heckeDiagMatrix d • τ)
+    simp_rw [hq, ← pow_mul] at hs
+    have hinj : Injective (fun m : ℕ ↦ d * m) := mul_right_injective₀ hd
+    have hsupp : ∀ x ∉ Set.range (fun m : ℕ ↦ d * m),
+        (fun m ↦ c m • Periodic.qParam 1 τ ^ m) x = 0 := by
+      intro x hx
+      have : ¬ d ∣ x := by
+        rintro ⟨e, rfl⟩
+        exact hx ⟨e, rfl⟩
+      simp [hc, this]
+    refine (hinj.hasSum_iff hsupp).mp ?_
+    convert hs using 1
+    ext m
+    simp [hc, Nat.mul_div_cancel_left _ (Nat.pos_of_ne_zero hd)]
+  have key := qExpansion_coeff_unique (F := FnLike) (show FnLike from G) one_pos han hsum n
+  change (qExpansion 1 G).coeff n = if d ∣ n then (qExpansion 1 F).coeff (n / d) else 0
+  exact key.symm
+
+theorem qCoeff_comp_smul_of_modularFormClass {FF : Type*} [FunLike FF ℍ ℂ]
+    {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [ModularFormClass FF Γ k] (f : FF)
+    (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) (hd : d ≠ 0) (n : ℕ) :
+    ModularFormClass.qCoeff (fun τ ↦ f (heckeDiagMatrix d • τ)) n =
+      if d ∣ n then ModularFormClass.qCoeff f (n / d) else 0 :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  qCoeff_comp_smul (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (ModularFormClass.holo f)
+    (ModularFormClass.bdd_at_infty f) hd n
+
+end UpperHalfPlane.DegeneracyQExp
+end
+
+theorem solution {F : Type*} [FunLike F UpperHalfPlane ℂ]
+    {Γ : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)} {k : ℤ} [ModularFormClass F Γ k] (f : F)
+    (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) {d : ℕ} (hd : d ≠ 0) (n : ℕ) :
+    ModularFormClass.qCoeff (fun τ ↦ f (ModularForm.heckeDiagMatrix d • τ)) n = if d ∣ n then
+      ModularFormClass.qCoeff f (n / d) else 0 :=
+  UpperHalfPlane.DegeneracyQExp.qCoeff_comp_smul_of_modularFormClass f hΓ hd n
+
+end S_ModularFormClass_qCoeff_comp_heckeDiagMatrix_smul
+end P2MW
+export P2MW.S_ModularFormClass_qCoeff_comp_heckeDiagMatrix_smul (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem ModularFormClass.qCoeff_comp_heckeDiagMatrix_smul {F : Type*} [FunLike F UpperHalfPlane ℂ]
+    {Γ : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)} {k : ℤ} [ModularFormClass F Γ k] (f : F)
+    (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) {d : ℕ} (hd : d ≠ 0) (n : ℕ) :
+    ModularFormClass.qCoeff (fun τ ↦ f (ModularForm.heckeDiagMatrix d • τ)) n = if d ∣ n then
+      ModularFormClass.qCoeff f (n / d) else 0 :=
+  solution f hΓ hd n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_coeffHeckeT_coeffHeckeU_comm.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_coeffHeckeT_coeffHeckeU_comm.lean
new file mode 100644
index 0000000000..952f75c13b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_coeffHeckeT_coeffHeckeU_comm.lean
@@ -0,0 +1,138 @@
+/-
+Based on Prove2Me node ModularForm.coeffHeckeT_coeffHeckeU_comm
+(d67181b2-d9a8-52ab-ab08-d4ed37010b41) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 67be7ef0-0c1b-5ef1-b21b-e725ceaeed0e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import Mathlib.Data.Nat.GCD.Basic
+import Mathlib.Basic.Complex.Basic
+import Mathlib.Algebra.Lie.OfAssociative
+import Mathlib.Algebra.Algebra.Rat
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Coefficient operators Tₚ and U_q commute for coprime p,q
+
+Theorem statement: `ModularForm.coeffHeckeT_coeffHeckeU_comm`
+(`d67181b2-d9a8-52ab-ab08-d4ed37010b41`), by Claude, 2026-09-05.
+
+Proof: submission `67be7ef0-0c1b-5ef1-b21b-e725ceaeed0e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $k$ be an integer, let $p,q$ be natural numbers with $\gcd(p,q)=1$, and let
+$a:\mathbb{N}\to\mathbb{C}$ be an arbitrary sequence of complex numbers. The two coefficient-level
+operators involved are defined purely combinatorially: [`ModularForm.coeffHeckeU
+q`](def/ModularForm_HeckeOperator.html#L165) sends $a$ to the sequence $n\mapsto a(nq)$, and
+[`ModularForm.coeffHeckeT k p`](def/ModularForm_HeckeOperator.html#L162) sends $a$ to the sequence
+$n\mapsto a(np) + p^{k-1}a(n/p)$ when $p\mid n$, and $n\mapsto a(np)$ otherwise (the correction term
+being literally $\mathbf{1}_{p\mid n}\,(p:\mathbb{C})^{k-1}a(n/p)$, with $n/p$ natural division and
+the power taken in $\mathbb{C}$ with integer exponent). The assertion is the equality of functions
+$\mathbb{N}\to\mathbb{C}$
+$$\mathrm{coeffHeckeT}_k^p\bigl(\mathrm{coeffHeckeU}^q a\bigr) =
+\mathrm{coeffHeckeU}^q\bigl(\mathrm{coeffHeckeT}_k^p a\bigr),$$
+both sides sending $n$ to $a(npq) + \mathbf{1}_{p\mid n}\,p^{k-1}a((n/p)q)$. No modularity, growth
+or holomorphy hypothesis on $a$ is imposed: this is an identity about arbitrary complex sequences.
+
+This is the commutation relation $T_pU_q = U_qT_p$ for coprime indices, read on $q$-expansion
+coefficients, as it holds classically for $T_p$ with $p\nmid N$ and $U_q$ with $q\mid N$ acting on
+$M_k(\Gamma_0(N))$. It is used by
+[`ModularFormClass.heckeT_heckeU_comm`](thm.html#ModularFormClass.heckeT_heckeU_comm) to transport
+the relation to the operators on modular forms themselves, and thence in
+[`CuspForm.exists_isNormalizedEigenform`](thm.html#CuspForm.exists_isNormalizedEigenform), the
+existence of a normalised eigenform in the relevant eigenspace.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_coeffHeckeT_coeffHeckeU_comm.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_coeffHeckeT_coeffHeckeU_comm
+
+namespace M4cP1W2
+
+open ModularForm
+
+theorem coeffHeckeU_comm (p q : ℕ) (a : ℕ → ℂ) :
+    coeffHeckeU p (coeffHeckeU q a) = coeffHeckeU q (coeffHeckeU p a) := by
+  funext n
+  simp only [coeffHeckeU_apply, Nat.mul_right_comm]
+
+theorem coeffHeckeT_coeffHeckeU_comm (k : ℤ) {p q : ℕ} (hpq : Nat.Coprime p q) (a : ℕ → ℂ) :
+    coeffHeckeT k p (coeffHeckeU q a) = coeffHeckeU q (coeffHeckeT k p a) := by
+  funext n
+  simp only [coeffHeckeT_apply, coeffHeckeU_apply]
+  have hiff : p ∣ n * q ↔ p ∣ n := hpq.dvd_mul_right
+  by_cases hpn : p ∣ n
+  · rw [ite_eq_left hpn, ite_eq_left (hiff.mpr hpn), Nat.mul_right_comm, Nat.div_mul_right_comm hpn]
+  · rw [ite_eq_right hpn, ite_eq_right (fun h => hpn (hiff.mp h)), Nat.mul_right_comm]
+
+theorem coeffHeckeT_comm (k : ℤ) {p q : ℕ} (hpq : Nat.Coprime p q) (a : ℕ → ℂ) :
+    coeffHeckeT k p (coeffHeckeT k q a) = coeffHeckeT k q (coeffHeckeT k p a) := by
+  funext n
+  simp only [coeffHeckeT_apply]
+  have hq : q ∣ n * p ↔ q ∣ n := hpq.symm.dvd_mul_right
+  have hp : p ∣ n * q ↔ p ∣ n := hpq.dvd_mul_right
+  have hpq' : ∀ {m : ℕ}, p ∣ m → (q ∣ m / p ↔ p * q ∣ m) := fun h =>
+    Nat.dvd_div_iff_mul_dvd h
+  have hqp' : ∀ {m : ℕ}, q ∣ m → (p ∣ m / q ↔ q * p ∣ m) := fun h =>
+    Nat.dvd_div_iff_mul_dvd h
+  by_cases hpn : p ∣ n <;> by_cases hqn : q ∣ n
+  · have hpqn : p * q ∣ n := hpq.mul_dvd_of_dvd_of_dvd hpn hqn
+    rw [ite_eq_left (hq.mpr hqn), ite_eq_left hpn, ite_eq_left ((hpq' hpn).mpr hpqn), ite_eq_left
+      (hp.mpr hpn),
+      ite_eq_left hqn, ite_eq_left ((hqp' hqn).mpr (mul_comm p q ▸ hpqn)),
+      Nat.mul_right_comm, Nat.div_mul_right_comm hqn, Nat.div_mul_right_comm hpn,
+      Nat.div_div_eq_div_mul, Nat.div_div_eq_div_mul, mul_comm q p]
+    ring
+  · have h1 : ¬ q ∣ n / p := fun h => hqn (Nat.dvd_trans (Nat.dvd_mul_left q p) ((hpq' hpn).mp h))
+    rw [ite_eq_right (fun h => hqn (hq.mp h)), ite_eq_left hpn, ite_eq_right h1, ite_eq_left (hp.mpr
+      hpn), ite_eq_right hqn,
+      Nat.mul_right_comm, Nat.div_mul_right_comm hpn]
+    ring
+  · have h1 : ¬ p ∣ n / q := fun h => hpn (Nat.dvd_trans (Nat.dvd_mul_left p q) ((hqp' hqn).mp h))
+    rw [ite_eq_left (hq.mpr hqn), ite_eq_right hpn, ite_eq_right (fun h => hpn (hp.mp h)),
+      ite_eq_left hqn, ite_eq_right h1,
+      Nat.mul_right_comm, Nat.div_mul_right_comm hqn]
+    ring
+  · rw [ite_eq_right (fun h => hqn (hq.mp h)), ite_eq_right hpn, ite_eq_right (fun h => hpn (hp.mp
+      h)), ite_eq_right hqn,
+      Nat.mul_right_comm]
+
+end M4cP1W2
+
+theorem solution (k : ℤ) {p q : ℕ} (hpq : Nat.Coprime p q) (a : ℕ → ℂ) :
+    ModularForm.coeffHeckeT k p (ModularForm.coeffHeckeU q a) = ModularForm.coeffHeckeU q
+      (ModularForm.coeffHeckeT k p a) :=
+  M4cP1W2.coeffHeckeT_coeffHeckeU_comm k hpq a
+
+end S_ModularForm_coeffHeckeT_coeffHeckeU_comm
+end P2MW
+export P2MW.S_ModularForm_coeffHeckeT_coeffHeckeU_comm (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularForm.coeffHeckeT_coeffHeckeU_comm (k : ℤ) {p q : ℕ} (hpq : Nat.Coprime p q)
+    (a : ℕ → ℂ) :
+    ModularForm.coeffHeckeT k p (ModularForm.coeffHeckeU q a) = ModularForm.coeffHeckeU q
+      (ModularForm.coeffHeckeT k p a) :=
+  solution k hpq a
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_coeffHeckeT_comm.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_coeffHeckeT_comm.lean
new file mode 100644
index 0000000000..1476c21864
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_coeffHeckeT_comm.lean
@@ -0,0 +1,137 @@
+/-
+Based on Prove2Me node ModularForm.coeffHeckeT_comm
+(f18f7626-ec63-50ae-b63e-610da651f925) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3bf3db43-f7a7-5651-bf5f-39ec4111e419
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import Mathlib.Data.Nat.GCD.Basic
+import Mathlib.Basic.Complex.Basic
+import Mathlib.Algebra.Lie.OfAssociative
+import Mathlib.Algebra.Algebra.Rat
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Coefficient Hecke operators commute at coprime levels
+
+Theorem statement: `ModularForm.coeffHeckeT_comm` (`f18f7626-ec63-50ae-b63e-610da651f925`), by
+Claude, 2026-09-05.
+
+Proof: submission `3bf3db43-f7a7-5651-bf5f-39ec4111e419`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix an integer weight $k$, natural numbers $p,q$ with $\mathrm{Nat.Coprime}\ p\ q$ (that is,
+$\gcd(p,q)=1$), and an arbitrary sequence $a\colon\mathbb N\to\mathbb C$. Here
+[`ModularForm.coeffHeckeT k p`](def/ModularForm_HeckeOperator.html#L162) is the operator on
+sequences defined coefficientwise by
+$$(\mathrm{coeffHeckeT}\,k\,p\,a)(n)=a(np)+\begin{cases}(p:\mathbb C)^{k-1}\,a(n/p)&\text{if }p\mid
+n,\\0&\text{otherwise,}\end{cases}$$
+where $n/p$ is natural-number division and $(p:\mathbb C)^{k-1}$ is the integer power of the complex
+number $p$ (so the exponent may be negative, and $0^{k-1}$ is interpreted by the usual conventions
+when $p=0$). The assertion is the equality of the two sequences $\mathbb N\to\mathbb C$ obtained by
+applying these operators in the two orders:
+$$\mathrm{coeffHeckeT}\,k\,p\,(\mathrm{coeffHeckeT}\,k\,q\,a)=\mathrm{coeffHeckeT}\,k\,q\,(
+\mathrm{coeffHeckeT}\,k\,p\,a).$$
+No primality of $p$ or $q$, and no positivity, is assumed beyond coprimality; the statement is
+purely one about sequences, with no modularity hypothesis on $a$.
+
+This is the coefficient-side form of the commutation relation $T_pT_q=T_qT_p$ for Hecke operators at
+coprime indices, read on $q$-expansions. It is used to obtain commutativity of the Hecke operators
+acting on modular forms,
+[`ModularFormClass.heckeT_heckeT_comm`](thm.html#ModularFormClass.heckeT_heckeT_comm), and thence in
+the construction of normalised eigenforms,
+[`CuspForm.exists_isNormalizedEigenform`](thm.html#CuspForm.exists_isNormalizedEigenform).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_coeffHeckeT_comm.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_coeffHeckeT_comm
+
+namespace M4cP1W2
+
+open ModularForm
+
+theorem coeffHeckeU_comm (p q : ℕ) (a : ℕ → ℂ) :
+    coeffHeckeU p (coeffHeckeU q a) = coeffHeckeU q (coeffHeckeU p a) := by
+  funext n
+  simp only [coeffHeckeU_apply, Nat.mul_right_comm]
+
+theorem coeffHeckeT_coeffHeckeU_comm (k : ℤ) {p q : ℕ} (hpq : Nat.Coprime p q) (a : ℕ → ℂ) :
+    coeffHeckeT k p (coeffHeckeU q a) = coeffHeckeU q (coeffHeckeT k p a) := by
+  funext n
+  simp only [coeffHeckeT_apply, coeffHeckeU_apply]
+  have hiff : p ∣ n * q ↔ p ∣ n := hpq.dvd_mul_right
+  by_cases hpn : p ∣ n
+  · rw [ite_eq_left hpn, ite_eq_left (hiff.mpr hpn), Nat.mul_right_comm, Nat.div_mul_right_comm hpn]
+  · rw [ite_eq_right hpn, ite_eq_right (fun h => hpn (hiff.mp h)), Nat.mul_right_comm]
+
+theorem coeffHeckeT_comm (k : ℤ) {p q : ℕ} (hpq : Nat.Coprime p q) (a : ℕ → ℂ) :
+    coeffHeckeT k p (coeffHeckeT k q a) = coeffHeckeT k q (coeffHeckeT k p a) := by
+  funext n
+  simp only [coeffHeckeT_apply]
+  have hq : q ∣ n * p ↔ q ∣ n := hpq.symm.dvd_mul_right
+  have hp : p ∣ n * q ↔ p ∣ n := hpq.dvd_mul_right
+  have hpq' : ∀ {m : ℕ}, p ∣ m → (q ∣ m / p ↔ p * q ∣ m) := fun h =>
+    Nat.dvd_div_iff_mul_dvd h
+  have hqp' : ∀ {m : ℕ}, q ∣ m → (p ∣ m / q ↔ q * p ∣ m) := fun h =>
+    Nat.dvd_div_iff_mul_dvd h
+  by_cases hpn : p ∣ n <;> by_cases hqn : q ∣ n
+  · have hpqn : p * q ∣ n := hpq.mul_dvd_of_dvd_of_dvd hpn hqn
+    rw [ite_eq_left (hq.mpr hqn), ite_eq_left hpn, ite_eq_left ((hpq' hpn).mpr hpqn), ite_eq_left
+      (hp.mpr hpn),
+      ite_eq_left hqn, ite_eq_left ((hqp' hqn).mpr (mul_comm p q ▸ hpqn)),
+      Nat.mul_right_comm, Nat.div_mul_right_comm hqn, Nat.div_mul_right_comm hpn,
+      Nat.div_div_eq_div_mul, Nat.div_div_eq_div_mul, mul_comm q p]
+    ring
+  · have h1 : ¬ q ∣ n / p := fun h => hqn (Nat.dvd_trans (Nat.dvd_mul_left q p) ((hpq' hpn).mp h))
+    rw [ite_eq_right (fun h => hqn (hq.mp h)), ite_eq_left hpn, ite_eq_right h1, ite_eq_left (hp.mpr
+      hpn), ite_eq_right hqn,
+      Nat.mul_right_comm, Nat.div_mul_right_comm hpn]
+    ring
+  · have h1 : ¬ p ∣ n / q := fun h => hpn (Nat.dvd_trans (Nat.dvd_mul_left p q) ((hqp' hqn).mp h))
+    rw [ite_eq_left (hq.mpr hqn), ite_eq_right hpn, ite_eq_right (fun h => hpn (hp.mp h)),
+      ite_eq_left hqn, ite_eq_right h1,
+      Nat.mul_right_comm, Nat.div_mul_right_comm hqn]
+    ring
+  · rw [ite_eq_right (fun h => hqn (hq.mp h)), ite_eq_right hpn, ite_eq_right (fun h => hpn (hp.mp
+      h)), ite_eq_right hqn,
+      Nat.mul_right_comm]
+
+end M4cP1W2
+
+theorem solution (k : ℤ) {p q : ℕ} (hpq : Nat.Coprime p q) (a : ℕ → ℂ) :
+    ModularForm.coeffHeckeT k p (ModularForm.coeffHeckeT k q a) = ModularForm.coeffHeckeT k q
+      (ModularForm.coeffHeckeT k p a) :=
+  M4cP1W2.coeffHeckeT_comm k hpq a
+
+end S_ModularForm_coeffHeckeT_comm
+end P2MW
+export P2MW.S_ModularForm_coeffHeckeT_comm (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularForm.coeffHeckeT_comm (k : ℤ) {p q : ℕ} (hpq : Nat.Coprime p q) (a : ℕ → ℂ) :
+    ModularForm.coeffHeckeT k p (ModularForm.coeffHeckeT k q a) = ModularForm.coeffHeckeT k q
+      (ModularForm.coeffHeckeT k p a) :=
+  solution k hpq a
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_coeffHeckeU_comm.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_coeffHeckeU_comm.lean
new file mode 100644
index 0000000000..d72b94e25a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_coeffHeckeU_comm.lean
@@ -0,0 +1,136 @@
+/-
+Based on Prove2Me node ModularForm.coeffHeckeU_comm
+(5775d3a4-e629-5eee-a4a1-1d422c2910f2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission aa042317-cd48-5d4d-a2f3-164eb32e76c3
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import Mathlib.Data.Nat.GCD.Basic
+import Mathlib.Basic.Complex.Basic
+import Mathlib.Algebra.Lie.OfAssociative
+import Mathlib.Algebra.Algebra.Rat
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Commutativity of the coefficient operators Uₚ and U_q
+
+Theorem statement: `ModularForm.coeffHeckeU_comm` (`5775d3a4-e629-5eee-a4a1-1d422c2910f2`), by
+Claude, 2026-09-05.
+
+Proof: submission `aa042317-cd48-5d4d-a2f3-164eb32e76c3`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+For natural numbers $p$ and $q$ and an arbitrary function $a : \mathbb{N} \to \mathbb{C}$ (a formal
+sequence of Fourier coefficients, with no modularity, growth or multiplicativity assumption), the
+two iterated applications of the coefficient-level operator
+[`ModularForm.coeffHeckeU`](def/ModularForm_HeckeOperator.html#L165) agree:
+$$\mathrm{coeffHeckeU}\,p\,(\mathrm{coeffHeckeU}\,q\,a) =
+\mathrm{coeffHeckeU}\,q\,(\mathrm{coeffHeckeU}\,p\,a),$$ an equality of functions $\mathbb{N} \to
+\mathbb{C}$. Here [`ModularForm.coeffHeckeU p a`](def/ModularForm_HeckeOperator.html#L165) is by
+definition the sequence $n \mapsto a(n p)$, that is, the reindexing of $a$ along multiplication by
+$p$; thus the left-hand side sends $n$ to $a(n p q)$ and the right-hand side sends $n$ to $a(n q
+p)$. No primality of $p$ or $q$, and no coprimality of $p$ and $q$, is assumed: the identity is
+unconditional in the two natural-number parameters, and in particular holds for $p = q$ and when
+either is $0$ or $1$.
+
+This is the coefficient-sequence shadow of the classical commutation $U_p U_q = U_q U_p$ for the
+Hecke operators $U$ attached to two integers, formulated purely in terms of the action $a(n) \mapsto
+a(np)$ on Fourier expansions. It is used to establish the corresponding commutation of the operators
+on spaces of modular forms
+([`ModularFormClass.heckeU_heckeU_comm`](thm.html#ModularFormClass.heckeU_heckeU_comm)) and, through
+that, in the construction of normalised eigenforms
+([`CuspForm.exists_isNormalizedEigenform`](thm.html#CuspForm.exists_isNormalizedEigenform)).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_coeffHeckeU_comm.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_coeffHeckeU_comm
+
+namespace M4cP1W2
+
+open ModularForm
+
+theorem coeffHeckeU_comm (p q : ℕ) (a : ℕ → ℂ) :
+    coeffHeckeU p (coeffHeckeU q a) = coeffHeckeU q (coeffHeckeU p a) := by
+  funext n
+  simp only [coeffHeckeU_apply, Nat.mul_right_comm]
+
+theorem coeffHeckeT_coeffHeckeU_comm (k : ℤ) {p q : ℕ} (hpq : Nat.Coprime p q) (a : ℕ → ℂ) :
+    coeffHeckeT k p (coeffHeckeU q a) = coeffHeckeU q (coeffHeckeT k p a) := by
+  funext n
+  simp only [coeffHeckeT_apply, coeffHeckeU_apply]
+  have hiff : p ∣ n * q ↔ p ∣ n := hpq.dvd_mul_right
+  by_cases hpn : p ∣ n
+  · rw [ite_eq_left hpn, ite_eq_left (hiff.mpr hpn), Nat.mul_right_comm, Nat.div_mul_right_comm hpn]
+  · rw [ite_eq_right hpn, ite_eq_right (fun h => hpn (hiff.mp h)), Nat.mul_right_comm]
+
+theorem coeffHeckeT_comm (k : ℤ) {p q : ℕ} (hpq : Nat.Coprime p q) (a : ℕ → ℂ) :
+    coeffHeckeT k p (coeffHeckeT k q a) = coeffHeckeT k q (coeffHeckeT k p a) := by
+  funext n
+  simp only [coeffHeckeT_apply]
+  have hq : q ∣ n * p ↔ q ∣ n := hpq.symm.dvd_mul_right
+  have hp : p ∣ n * q ↔ p ∣ n := hpq.dvd_mul_right
+  have hpq' : ∀ {m : ℕ}, p ∣ m → (q ∣ m / p ↔ p * q ∣ m) := fun h =>
+    Nat.dvd_div_iff_mul_dvd h
+  have hqp' : ∀ {m : ℕ}, q ∣ m → (p ∣ m / q ↔ q * p ∣ m) := fun h =>
+    Nat.dvd_div_iff_mul_dvd h
+  by_cases hpn : p ∣ n <;> by_cases hqn : q ∣ n
+  · have hpqn : p * q ∣ n := hpq.mul_dvd_of_dvd_of_dvd hpn hqn
+    rw [ite_eq_left (hq.mpr hqn), ite_eq_left hpn, ite_eq_left ((hpq' hpn).mpr hpqn), ite_eq_left
+      (hp.mpr hpn),
+      ite_eq_left hqn, ite_eq_left ((hqp' hqn).mpr (mul_comm p q ▸ hpqn)),
+      Nat.mul_right_comm, Nat.div_mul_right_comm hqn, Nat.div_mul_right_comm hpn,
+      Nat.div_div_eq_div_mul, Nat.div_div_eq_div_mul, mul_comm q p]
+    ring
+  · have h1 : ¬ q ∣ n / p := fun h => hqn (Nat.dvd_trans (Nat.dvd_mul_left q p) ((hpq' hpn).mp h))
+    rw [ite_eq_right (fun h => hqn (hq.mp h)), ite_eq_left hpn, ite_eq_right h1, ite_eq_left (hp.mpr
+      hpn), ite_eq_right hqn,
+      Nat.mul_right_comm, Nat.div_mul_right_comm hpn]
+    ring
+  · have h1 : ¬ p ∣ n / q := fun h => hpn (Nat.dvd_trans (Nat.dvd_mul_left p q) ((hqp' hqn).mp h))
+    rw [ite_eq_left (hq.mpr hqn), ite_eq_right hpn, ite_eq_right (fun h => hpn (hp.mp h)),
+      ite_eq_left hqn, ite_eq_right h1,
+      Nat.mul_right_comm, Nat.div_mul_right_comm hqn]
+    ring
+  · rw [ite_eq_right (fun h => hqn (hq.mp h)), ite_eq_right hpn, ite_eq_right (fun h => hpn (hp.mp
+      h)), ite_eq_right hqn,
+      Nat.mul_right_comm]
+
+end M4cP1W2
+
+theorem solution (p q : ℕ) (a : ℕ → ℂ) :
+    ModularForm.coeffHeckeU p (ModularForm.coeffHeckeU q a) = ModularForm.coeffHeckeU q
+      (ModularForm.coeffHeckeU p a) :=
+  M4cP1W2.coeffHeckeU_comm p q a
+
+end S_ModularForm_coeffHeckeU_comm
+end P2MW
+export P2MW.S_ModularForm_coeffHeckeU_comm (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularForm.coeffHeckeU_comm (p q : ℕ) (a : ℕ → ℂ) :
+    ModularForm.coeffHeckeU p (ModularForm.coeffHeckeU q a) = ModularForm.coeffHeckeU q
+      (ModularForm.coeffHeckeU p a) :=
+  solution p q a
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_eq_zero_of_lt_order_qExpansion_of_isArithmetic.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_eq_zero_of_lt_order_qExpansion_of_isArithmetic.lean
new file mode 100644
index 0000000000..d405f8b259
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_eq_zero_of_lt_order_qExpansion_of_isArithmetic.lean
@@ -0,0 +1,146 @@
+/-
+Based on Prove2Me node ModularForm.eq_zero_of_lt_order_qExpansion_of_isArithmetic
+(333be7f0-9499-527a-a03d-8cbc1f0d21ea) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f8274cc2-6924-5759-95b0-02b19e333c16
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import Mathlib.RingTheory.PowerSeries.Order
+
+import Mathlib.NumberTheory.ModularForms.NormTrace
+import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_qExpansion_prod
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_eq_zero_of_lt_order_qExpansion
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Sturm bound at width M for arithmetic groups
+
+Theorem statement: `ModularForm.eq_zero_of_lt_order_qExpansion_of_isArithmetic`
+(`333be7f0-9499-527a-a03d-8cbc1f0d21ea`), by Claude, 2026-09-05.
+
+Proof: submission `f8274cc2-6924-5759-95b0-02b19e333c16`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\mathcal{G}$ be a subgroup of $\mathrm{GL}_2(\mathbb{R})$ carrying the instance
+`Subgroup.IsArithmetic`, let $k$ be an integer and let $f$ be a modular form of weight $k$ for
+$\mathcal{G}$. Let $M$ be a natural number with $0 < M$, and assume that for every $\gamma \in
+\mathrm{SL}_2(\mathbb{Z})$ the real number $M$ lies in the strict periods of the conjugated subgroup
+$(\mathrm{ConjAct.toConjAct}(\gamma)) \bullet \mathcal{G}$, where $\gamma$ is taken in
+$\mathrm{GL}_2(\mathbb{R})$ through `Matrix.SpecialLinearGroup.mapGL`; that is, $M$ is a strict
+period of each $\gamma\mathcal{G}\gamma^{-1}$. Write $\mu =$ `𝒢.relIndex 𝒮ℒ` for the relative index
+of $\mathcal{G}$ in the image $\mathcal{SL}$ of $\mathrm{SL}_2(\mathbb{Z})$ in
+$\mathrm{GL}_2(\mathbb{R})$, i.e. the index of $\mathcal{G} \cap \mathcal{SL}$ in $\mathcal{SL}$.
+Assume finally that the order of the power series `qExpansion M f`, the $q$-expansion of $f$ at
+width $M$ (parameter $e^{2\pi i \tau / M}$), is strictly greater than the natural number $M \cdot
+\lfloor (k\mu)^{+}/12 \rfloor$, the integer $k\mu$ being truncated to $\mathbb{N}$ by `Int.toNat`
+and the division being natural division, this bound being compared in $\mathbb{N}_\infty$. The
+conclusion is that $f = 0$.
+
+This is the Sturm, or valence, bound in a form applicable to arithmetic groups that need not contain
+the translation $T$, the width $M$ playing the role of a common period of all
+$\mathrm{SL}_2(\mathbb{Z})$-conjugates of $\mathcal{G}$ (for instance $M = N$ for $\Gamma(N)$). It
+is used to derive the finite dimensionality of the space of modular forms of weight $k$ for an
+arithmetic group,
+[`ModularForm.finiteDimensional_of_isArithmetic`]
+(thm.html#ModularForm.finiteDimensional_of_isArithmetic),
+and the corresponding Sturm bound statement
+[`ModularForm.sturm_bound_of_isArithmetic`](thm.html#ModularForm.sturm_bound_of_isArithmetic).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_eq_zero_of_lt_order_qExpansion_of_isArithmetic.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_eq_zero_of_lt_order_qExpansion_of_isArithmetic
+
+p2m_open "UpperHalfPlane ModularForm \
+  P2MW.S_ModularForm_eq_zero_of_lt_order_qExpansion_of_isArithmetic.ModularForm SlashInvariantForm \
+  Matrix.SpecialLinearGroup ConjAct"
+p2m_open_scoped "MatrixGroups ModularForm \
+  P2MW.S_ModularForm_eq_zero_of_lt_order_qExpansion_of_isArithmetic.ModularForm Topology Manifold \
+  Pointwise"
+
+noncomputable section
+
+namespace ModularForm
+p2m_export "ModularForm" "coe_norm translate norm_eq_zero_iff coe_zero \
+  levelOne_eq_zero_of_lt_order_qExpansion"
+end ModularForm
+namespace ModularForm
+p2m_open_scoped "ModularForm" in
+private theorem _root_.ModularForm.analyticAt_cuspFunction_quotientFunc_W2D {𝒢 : Subgroup (GL (Fin
+  2) ℝ)}
+    {k : ℤ} (f : ModularForm 𝒢 k) {M : ℕ} (hM : 0 < M)
+    (hconj : ∀ γ : SL(2, ℤ), (M : ℝ) ∈ (toConjAct (mapGL ℝ γ) • 𝒢).strictPeriods)
+    (q : 𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) :
+    AnalyticAt ℂ (cuspFunction M (quotientFunc f q)) 0 := by
+  induction q using Quotient.inductionOn with
+  | h r =>
+    obtain ⟨γ, hγ⟩ := r.2
+    have hp : (M : ℝ) ∈ (toConjAct (r.1⁻¹)⁻¹ • 𝒢).strictPeriods := by
+      rw [inv_inv, ← hγ]
+      exact hconj γ
+    exact ModularFormClass.analyticAt_cuspFunction_zero (ModularForm.translate f r.1⁻¹)
+      (Nat.cast_pos.mpr hM) hp
+
+end ModularForm
+p2m_export "" "ModularForm.analyticAt_cuspFunction_quotientFunc_W2D"
+theorem solution {𝒢 : Subgroup (GL (Fin 2) ℝ)} [𝒢.IsArithmetic] {k : ℤ} (f : ModularForm 𝒢 k) {M :
+  ℕ} (hM : 0 < M) (hconj : ∀ γ : SL(2, ℤ), (M : ℝ) ∈ (ConjAct.toConjAct
+  (Matrix.SpecialLinearGroup.mapGL ℝ γ) • 𝒢).strictPeriods) (h : ((M * ((k * 𝒢.relIndex 𝒮ℒ).toNat /
+  12) : ℕ) : ℕ∞) < (qExpansion M f).order) :
+    f = 0 := by
+  set F := ModularForm.norm 𝒮ℒ f with hF
+  have hanalytic := f.analyticAt_cuspFunction_quotientFunc_W2D hM hconj
+  let _ : Fintype (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) := Fintype.ofFinite _
+  have hprod : qExpansion M F = ∏ q : 𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ, qExpansion M (quotientFunc f q) := by
+    rw [hF, ModularForm.coe_norm]
+    exact UpperHalfPlane.qExpansion_prod Finset.univ fun q _ ↦ hanalytic q
+  have hone : quotientFunc f (⟦1⟧ : 𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) = ⇑f := by
+    rw [quotientFunc_mk]
+    simp
+  have horder : (qExpansion M f).order ≤ (qExpansion M F).order := by
+    rw [hprod, PowerSeries.order_prod, ← hone]
+    exact Finset.single_le_sum (f := fun q ↦ (qExpansion M (quotientFunc f q)).order)
+      (fun _ _ ↦ zero_le) (Finset.mem_univ _)
+  have hrel : 𝒢.relIndex 𝒮ℒ = Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) := rfl
+  have hF0 : F = 0 := by
+    refine ModularForm.levelOne_eq_zero_of_lt_order_qExpansion M hM F (lt_of_lt_of_le ?_ horder)
+    simpa [hrel] using h
+  rw [hF, ModularForm.norm_eq_zero_iff] at hF0
+  exact DFunLike.coe_injective (hF0.trans FunLike.coe_zero.symm)
+end
+
+end S_ModularForm_eq_zero_of_lt_order_qExpansion_of_isArithmetic
+end P2MW
+export P2MW.S_ModularForm_eq_zero_of_lt_order_qExpansion_of_isArithmetic (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane
+open scoped MatrixGroups Pointwise
+theorem ModularForm.eq_zero_of_lt_order_qExpansion_of_isArithmetic {𝒢 : Subgroup (GL (Fin 2) ℝ)}
+  [𝒢.IsArithmetic] {k : ℤ} (f : ModularForm 𝒢 k) {M : ℕ} (hM : 0 < M) (hconj : ∀ γ : SL(2, ℤ), (M :
+  ℝ) ∈ (ConjAct.toConjAct (Matrix.SpecialLinearGroup.mapGL ℝ γ) • 𝒢).strictPeriods) (h : ((M * ((k *
+  𝒢.relIndex 𝒮ℒ).toNat / 12) : ℕ) : ℕ∞) < (qExpansion M f).order) :
+    f = 0 :=
+  solution f hM hconj h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_coe_eq_of_levelOne.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_coe_eq_of_levelOne.lean
new file mode 100644
index 0000000000..0f879941b6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_coe_eq_of_levelOne.lean
@@ -0,0 +1,80 @@
+/-
+Based on Prove2Me node ModularForm.exists_coe_eq_of_levelOne
+(fee19eff-fcb6-501a-9f78-02aaaa0ed7cd) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e3fefdb9-2f2f-5591-a384-7435bef2e8cf
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Basic
+
+/-!
+# Level-one modular forms restrict to any subgroup of SL₂(ℤ)
+
+Theorem statement: `ModularForm.exists_coe_eq_of_levelOne` (`fee19eff-fcb6-501a-9f78-02aaaa0ed7cd`),
+by Claude, 2026-09-05.
+
+Proof: submission `e3fefdb9-2f2f-5591-a384-7435bef2e8cf`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of $SL_2(\mathbb{Z})$, let $k$ be an integer, and let $F$ be a modular
+form of weight $k$ for the group $\mathcal{SL}$, the image of $SL_2(\mathbb{Z})$ inside
+$GL_2(\mathbb{R})$ (so $F$ is a holomorphic function on the upper half-plane $\mathbb{H}$, invariant
+under the weight-$k$ slash action of every element of $\mathcal{SL}$, and bounded at the cusps of
+$\mathcal{SL}$). The assertion is that there exists a modular form $G$ of weight $k$ for the
+subgroup of $GL_2(\mathbb{R})$ obtained as the image of $\Gamma$ under the canonical map
+$SL_2(\mathbb{Z}) \to GL_2(\mathbb{R})$, such that the underlying functions $\mathbb{H} \to
+\mathbb{C}$ of $G$ and of $F$ coincide. Thus a level-one form of weight $k$ may be regarded, without
+altering its values, as a form of the same weight on the smaller group; no hypothesis of finite
+index, congruence condition or normality on $\Gamma$ is imposed.
+
+This is the standard remark that a modular form of level one is a modular form for any subgroup of
+$SL_2(\mathbb{Z})$, used to view $E_4$, $E_6$ and $\Delta$ as forms on $\Gamma_1(M)$ and
+$\Gamma_0(M)$. It is invoked in the analysis of $q$-expansions and of orders of vanishing on modular
+curves, for instance in the divisor computations for $\Gamma_1$ and in the construction of cusp
+forms with prescribed $q$-expansion divisible by a power of a theta series.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_exists_coe_eq_of_levelOne.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open UpperHalfPlane
+open scoped MatrixGroups
+
+theorem solution
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) {k : ℤ}
+    (F : ModularForm 𝒮ℒ k) :
+    ∃ G : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k,
+      (G : ℍ → ℂ) = (F : ℍ → ℂ) := by
+  have hle : ((Γ : Subgroup (GL (Fin 2) ℝ))) ≤ 𝒮ℒ := by
+    rintro _ ⟨γ, -, rfl⟩
+    exact ⟨γ, rfl⟩
+  refine ⟨{ toFun := F
+            slash_action_eq' := fun γ hγ => F.slash_action_eq' γ (hle hγ)
+            holo' := F.holo'
+            bdd_at_cusps' := fun hc => F.bdd_at_cusps' (hc.mono hle) }, rfl⟩
+
+end privateSection
+
+public section publicSection
+
+open UpperHalfPlane
+open scoped MatrixGroups
+theorem ModularForm.exists_coe_eq_of_levelOne
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) {k : ℤ}
+    (F : ModularForm 𝒮ℒ k) :
+    ∃ G : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) k, (G : ℍ → ℂ) = (F : ℍ → ℂ) :=
+  solution Γ F
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_cuspForm_mul_eq_of_analyticOrderAt_le.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_cuspForm_mul_eq_of_analyticOrderAt_le.lean
new file mode 100644
index 0000000000..f48d27b789
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_cuspForm_mul_eq_of_analyticOrderAt_le.lean
@@ -0,0 +1,282 @@
+/-
+Based on Prove2Me node ModularForm.exists_cuspForm_mul_eq_of_analyticOrderAt_le
+(845d9969-50b1-5115-b4d6-72ca22e7ace9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a6a71a9b-e208-5957-9525-48c2d0acf9a7
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.CStarAlgebra.Classes
+public import Mathlib.NumberTheory.ModularForms.Basic
+
+import Mathlib.Algebra.Order.Star.Real
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Division of modular forms: Φ/Ψ is a cusp form
+
+Theorem statement: `ModularForm.exists_cuspForm_mul_eq_of_analyticOrderAt_le`
+(`845d9969-50b1-5115-b4d6-72ca22e7ace9`), by Claude, 2026-09-05.
+
+Proof: submission `a6a71a9b-e208-5957-9525-48c2d0acf9a7`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number and let $a,b,c$ be integers with $b+c=a$. Let $\Phi$ be a modular form
+of weight $a$ for $\Gamma_0(N)$ and let $\Psi$ be a nonzero modular form of weight $b$ for
+$\Gamma_0(N)$. Assume two hypotheses. First, at every point $\tau$ of the upper half-plane the
+analytic order of vanishing at $\tau \in \mathbb{C}$ of $\Psi$, viewed as the function on
+$\mathbb{C}$ obtained by precomposing with `UpperHalfPlane.ofComplex`, is at most the analytic order
+of vanishing at $\tau$ of $\Phi$ viewed the same way (orders taken in $\mathbb{N}\cup\{\infty\}$).
+Second, for every $A \in \mathrm{SL}_2(\mathbb{Z})$ and every real $\varepsilon > 0$ one has
+$\|(\Phi \mid_a A)(\tau)\| \le \varepsilon\,\|(\Psi \mid_b A)(\tau)\|$ for all $\tau$ in the filter
+$\mathrm{atImInfty}$, where $\mid_k$ denotes the weight-$k$ slash action of $A$ regarded in
+$\mathrm{GL}_2(\mathbb{R})$; that is, $\Phi \mid_a A = o(\Psi \mid_b A)$ as $\operatorname{Im}\tau
+\to \infty$. The conclusion is that there exists a cusp form $f$ of weight $c$ for $\Gamma_0(N)$
+with $f(\tau)\,\Psi(\tau) = \Phi(\tau)$ for every $\tau$ in the upper half-plane.
+
+This is the division lemma in the graded ring of modular forms: the pointwise order condition makes
+the quotient $\Phi/\Psi$ holomorphic on the upper half-plane, and the decay condition along all
+$\mathrm{SL}_2(\mathbb{Z})$-translates makes it vanish at every cusp, so that the quotient is a cusp
+form of the difference weight. It is used to produce cusp forms from quotients of explicit modular
+forms by theta series, in
+[`ModularCurve.exists_cuspForm_qExpansion_eq_mul_thetaL_of_isIntegral`]
+(thm.html#ModularCurve.exists_cuspForm_qExpansion_eq_mul_thetaL_of_isIntegral)
+and
+[`ModularCurve.exists_cuspForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral`]
+(thm.html#ModularCurve.exists_cuspForm_qExpansion_eq_mul_thetaL_pow_of_isIntegral).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_exists_cuspForm_mul_eq_of_analyticOrderAt_le.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_exists_cuspForm_mul_eq_of_analyticOrderAt_le
+
+open UpperHalfPlane Filter
+open scoped MatrixGroups ModularForm Manifold Topology
+
+noncomputable section
+
+namespace ANa
+
+theorem local_factor {F G : ℂ → ℂ} {z : ℂ} (hF : AnalyticAt ℂ F z) (hG : AnalyticAt ℂ G z)
+    (hG0 : ¬ (∀ᶠ w in 𝓝 z, G w = 0)) (hle : analyticOrderAt G z ≤ analyticOrderAt F z) :
+    ∃ q : ℂ → ℂ, AnalyticAt ℂ q z ∧ ∀ᶠ w in 𝓝 z, F w = q w * G w := by
+  have hGtop : analyticOrderAt G z ≠ ⊤ := by rwa [ne_eq, analyticOrderAt_eq_top]
+  obtain ⟨n, hn⟩ := ENat.ne_top_iff_exists.mp hGtop
+  obtain ⟨u, hu, hu0, hGu⟩ := (hG.analyticOrderAt_eq_natCast).mp hn.symm
+  obtain ⟨v, hv, hFv⟩ : ∃ v : ℂ → ℂ, AnalyticAt ℂ v z ∧ ∀ᶠ w in 𝓝 z, F w = (w - z) ^ n • v w := by
+    have : (n : ℕ∞) ≤ analyticOrderAt F z := by rw [hn]; exact hle
+    exact (natCast_le_analyticOrderAt hF).mp this
+  refine ⟨fun w => v w / u w, hv.div hu hu0, ?_⟩
+  have hune : ∀ᶠ w in 𝓝 z, u w ≠ 0 := hu.continuousAt.eventually_ne hu0
+  filter_upwards [hGu, hFv, hune] with w hGw hFw huw
+  rw [hFw, hGw, smul_eq_mul, smul_eq_mul]
+  field_simp
+
+def quo (F G : ℂ → ℂ) (z : ℂ) : ℂ := limUnder (𝓝[≠] z) (fun w => F w / G w)
+
+theorem quo_eq {F G q : ℂ → ℂ} {z : ℂ} (hq : AnalyticAt ℂ q z) (hfac : ∀ᶠ w in 𝓝 z, F w = q w * G w)
+    (hG : ∀ᶠ w in 𝓝[≠] z, G w ≠ 0) : quo F G z = q z := by
+  apply Filter.Tendsto.limUnder_eq
+  have h1 : q =ᶠ[𝓝[≠] z] (fun w => F w / G w) := by
+    filter_upwards [hG, hfac.filter_mono nhdsWithin_le_nhds] with w hGw hw
+    rw [hw, mul_div_cancel_right₀ _ hGw]
+  exact (hq.continuousAt.tendsto.mono_left nhdsWithin_le_nhds).congr' h1
+
+theorem quo_analytic {F G : ℂ → ℂ} {U : Set ℂ} (hU : IsOpen U)
+    (hF : ∀ z ∈ U, AnalyticAt ℂ F z) (hG : ∀ z ∈ U, AnalyticAt ℂ G z)
+    (hG0 : ∀ z ∈ U, ¬ (∀ᶠ w in 𝓝 z, G w = 0))
+    (hle : ∀ z ∈ U, analyticOrderAt G z ≤ analyticOrderAt F z) (z : ℂ) (hz : z ∈ U) :
+    AnalyticAt ℂ (quo F G) z ∧ F z = quo F G z * G z := by
+  obtain ⟨q, hq, hfac⟩ := local_factor (hF z hz) (hG z hz) (hG0 z hz) (hle z hz)
+  have hGne : ∀ w ∈ U, ∀ᶠ v in 𝓝[≠] w, G v ≠ 0 := fun w hw =>
+    ((hG w hw).eventually_eq_zero_or_eventually_ne_zero).resolve_left (hG0 w hw)
+  have heq : ∀ᶠ w in 𝓝 z, quo F G w = q w := by
+    filter_upwards [hq.eventually_analyticAt, hfac.eventually_nhds, hU.mem_nhds hz] with w hqw hfw
+      hwU
+    exact quo_eq hqw hfw (hGne w hwU)
+  refine ⟨hq.congr (EventuallyEq.symm heq), ?_⟩
+  have h1 := heq.self_of_nhds
+  have h2 := hfac.self_of_nhds
+  rw [h1]
+  exact h2
+
+theorem analyticAt_of_mdiff {P : ℍ → ℂ} (hP : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) P) {z : ℂ} (hz : 0 < z.im) :
+    AnalyticAt ℂ (P ∘ ofComplex) z :=
+  (UpperHalfPlane.mdifferentiable_iff.mp hP).analyticAt
+    ((isOpen_lt continuous_const Complex.continuous_im).mem_nhds hz)
+
+theorem vanish {P : ℍ → ℂ} (hP : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) P) {W : Set ℍ} (hW : IsOpen W) {τ₀ : ℍ}
+    (hτ₀ : τ₀ ∈ W) (h0 : ∀ τ ∈ W, P τ = 0) : ∀ τ, P τ = 0 := by
+  have hPa : AnalyticOnNhd ℂ (P ∘ ofComplex) {z : ℂ | 0 < z.im} :=
+    fun z hz => analyticAt_of_mdiff hP hz
+  have hconn : IsPreconnected {z : ℂ | 0 < z.im} := (convex_halfSpace_im_gt 0).isPreconnected
+  have hW' : IsOpen (((↑) : ℍ → ℂ) '' W) := isOpenEmbedding_coe.isOpenMap _ hW
+  have hnhds : (P ∘ ofComplex) =ᶠ[𝓝 (τ₀ : ℂ)] 0 := by
+    filter_upwards [hW'.mem_nhds ⟨τ₀, hτ₀, rfl⟩]
+    rintro _ ⟨σ, hσ, rfl⟩
+    simp [ofComplex_apply, h0 σ hσ]
+  have hEq := hPa.eqOn_zero_of_preconnected_of_eventuallyEq_zero hconn τ₀.im_pos hnhds
+  intro τ
+  have := hEq τ.im_pos
+  simpa [ofComplex_apply] using this
+
+end ANa
+
+theorem solution (N : ℕ) {a b : ℤ} (c : ℤ) (habc : b + c = a)
+    (Φ : ModularForm (CongruenceSubgroup.Gamma0 N) a)
+    (Ψ : ModularForm (CongruenceSubgroup.Gamma0 N) b) (hΨ : Ψ ≠ 0)
+    (hord : ∀ τ : UpperHalfPlane, analyticOrderAt ((Ψ : UpperHalfPlane → ℂ) ∘
+      UpperHalfPlane.ofComplex) (τ : ℂ) ≤
+      analyticOrderAt ((Φ : UpperHalfPlane → ℂ) ∘ UpperHalfPlane.ofComplex) (τ : ℂ))
+    (hcusp : ∀ (A : Matrix.SpecialLinearGroup (Fin 2) ℤ) (ε : ℝ), 0 < ε →
+      ∀ᶠ τ : UpperHalfPlane in UpperHalfPlane.atImInfty,
+        ‖((Φ : UpperHalfPlane → ℂ) ∣[a] (A : GL (Fin 2) ℝ)) τ‖ ≤ ε * ‖((Ψ : UpperHalfPlane → ℂ) ∣[b]
+          (A : GL (Fin 2) ℝ)) τ‖) :
+    ∃ f : CuspForm (CongruenceSubgroup.Gamma0 N) c, ∀ τ : UpperHalfPlane, f τ * Ψ τ = Φ τ := by
+  classical
+  set Φ' : ℂ → ℂ := (Φ : ℍ → ℂ) ∘ ofComplex with hΦ'
+  set Ψ' : ℂ → ℂ := (Ψ : ℍ → ℂ) ∘ ofComplex with hΨ'
+  have hUo : IsOpen {z : ℂ | 0 < z.im} := isOpen_lt continuous_const Complex.continuous_im
+  have hUconn : IsPreconnected {z : ℂ | 0 < z.im} := (convex_halfSpace_im_gt 0).isPreconnected
+  have hΦa : ∀ z ∈ {z : ℂ | 0 < z.im}, AnalyticAt ℂ Φ' z :=
+    fun z hz => ANa.analyticAt_of_mdiff Φ.holo' hz
+  have hΨa : ∀ z ∈ {z : ℂ | 0 < z.im}, AnalyticAt ℂ Ψ' z :=
+    fun z hz => ANa.analyticAt_of_mdiff Ψ.holo' hz
+  have hΨ0 : ∀ z ∈ {z : ℂ | 0 < z.im}, ¬ (∀ᶠ w in 𝓝 z, Ψ' w = 0) := by
+    intro z hz hloc
+    apply hΨ
+    have hEq := AnalyticOnNhd.eqOn_zero_of_preconnected_of_eventuallyEq_zero
+      (f := Ψ') (U := {z : ℂ | 0 < z.im}) (fun w hw => hΨa w hw) hUconn hz hloc
+    refine DFunLike.ext Ψ 0 fun τ => ?_
+    have := hEq τ.im_pos
+    simpa [hΨ', ofComplex_apply] using this
+  have hle : ∀ z ∈ {z : ℂ | 0 < z.im}, analyticOrderAt Ψ' z ≤ analyticOrderAt Φ' z :=
+    fun z hz => hord ⟨z, hz⟩
+  have hF := ANa.quo_analytic hUo hΦa hΨa hΨ0 hle
+  set F : ℂ → ℂ := ANa.quo Φ' Ψ' with hFdef
+  let f : ℍ → ℂ := fun τ => F τ
+  have hfΨ : ∀ τ : ℍ, f τ * Ψ τ = Φ τ := fun τ => by
+    have := (hF τ τ.im_pos).2
+    simp only [hΦ', hΨ', Function.comp_apply, ofComplex_apply] at this
+    exact this.symm
+  have hfΨfun : f * (Ψ : ℍ → ℂ) = (Φ : ℍ → ℂ) := funext hfΨ
+  have hf_mdiff : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f := by
+    rw [UpperHalfPlane.mdifferentiable_iff]
+    have h1 : DifferentiableOn ℂ F {z : ℂ | 0 < z.im} := fun z hz =>
+      (hF z hz).1.differentiableAt.differentiableWithinAt
+    refine h1.congr fun z hz => ?_
+    exact congrArg F (by rw [ofComplex_apply_of_im_pos hz])
+  have hcb : c + b = a := by omega
+  have hf_slash : ∀ γ ∈ Subgroup.map (Matrix.SpecialLinearGroup.mapGL ℝ) (CongruenceSubgroup.Gamma0
+    N),
+      f ∣[c] γ = f := by
+    rintro _ ⟨γ₀, hγ₀, rfl⟩
+    have hmem : (Matrix.SpecialLinearGroup.mapGL ℝ γ₀) ∈
+        Subgroup.map (Matrix.SpecialLinearGroup.mapGL ℝ) (CongruenceSubgroup.Gamma0 N) := ⟨γ₀, hγ₀,
+          rfl⟩
+    change f ∣[c] γ₀ = f
+    have hΨinv : (Ψ : ℍ → ℂ) ∣[b] γ₀ = Ψ := SlashInvariantForm.slash_action_eqn Ψ _ hmem
+    have hΦinv : (Φ : ℍ → ℂ) ∣[a] γ₀ = Φ := SlashInvariantForm.slash_action_eqn Φ _ hmem
+    have hprod : (f ∣[c] γ₀) * (Ψ : ℍ → ℂ) = Φ := by
+      calc (f ∣[c] γ₀) * (Ψ : ℍ → ℂ) = (f ∣[c] γ₀) * ((Ψ : ℍ → ℂ) ∣[b] γ₀) := by rw [hΨinv]
+        _ = (f * (Ψ : ℍ → ℂ)) ∣[c + b] γ₀ := (ModularForm.mul_slash_SL2 c b γ₀ f Ψ).symm
+        _ = (Φ : ℍ → ℂ) ∣[a] γ₀ := by rw [hfΨfun, hcb]
+        _ = Φ := hΦinv
+    have hD : ∀ τ, (f ∣[c] γ₀ - f) τ * Ψ τ = 0 := fun τ => by
+      have h1 := congrFun hprod τ
+      simp only [Pi.mul_apply] at h1
+      rw [Pi.sub_apply, sub_mul, h1, hfΨ τ, sub_self]
+    have hDm : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (f ∣[c] γ₀ - f) := by
+      have := hf_mdiff.slash c (γ₀ : GL (Fin 2) ℝ)
+      exact this.sub hf_mdiff
+    by_contra hne
+    have hex : ∃ τ, (f ∣[c] γ₀ - f) τ ≠ 0 := by
+      by_contra hall
+      exact hne (sub_eq_zero.mp (funext fun τ => not_not.mp (not_exists.mp hall τ)))
+    obtain ⟨τ₀, hτ₀⟩ := hex
+    have hWo : IsOpen {τ : ℍ | (f ∣[c] γ₀ - f) τ ≠ 0} :=
+      isOpen_ne_fun hDm.continuous continuous_const
+    have hΨW : ∀ τ ∈ {τ : ℍ | (f ∣[c] γ₀ - f) τ ≠ 0}, Ψ τ = 0 := fun τ hτ =>
+      (mul_eq_zero.mp (hD τ)).resolve_left hτ
+    have hall := ANa.vanish Ψ.holo' hWo hτ₀ hΨW
+    exact hΨ (DFunLike.ext Ψ 0 hall)
+  have hcusp' : ∀ γ : SL(2, ℤ), IsZeroAtImInfty (f ∣[c] γ) := by
+    intro γ
+    rw [UpperHalfPlane.isZeroAtImInfty_iff]
+    intro ε hε
+    obtain ⟨T, hT⟩ := (atImInfty_mem _).mp (hcusp γ ε hε)
+    refine ⟨T + 1, fun τ hτ => ?_⟩
+    by_contra hlt'
+    have hlt : ε < ‖(f ∣[c] γ) τ‖ := not_le.mp hlt'
+    set G : ℍ → ℂ := f ∣[c] γ with hG
+    set ΨA : ℍ → ℂ := (Ψ : ℍ → ℂ) ∣[b] γ with hΨA
+    have hprodA : G * ΨA = (Φ : ℍ → ℂ) ∣[a] γ := by
+      rw [hG, hΨA, ← ModularForm.mul_slash_SL2, hfΨfun, hcb]
+    have hΨA_mdiff : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) ΨA := by
+      have := Ψ.holo'.slash b (γ : GL (Fin 2) ℝ)
+      exact this
+    have hG_cont : Continuous G := (hf_mdiff.slash c (γ : GL (Fin 2) ℝ)).continuous
+    have hWo : IsOpen {σ : ℍ | ε < ‖G σ‖ ∧ T < σ.im} :=
+      (isOpen_lt continuous_const hG_cont.norm).inter (isOpen_lt continuous_const
+        UpperHalfPlane.continuous_im)
+    have hΨAW : ∀ σ ∈ {σ : ℍ | ε < ‖G σ‖ ∧ T < σ.im}, ΨA σ = 0 := by
+      rintro σ ⟨h1, h2⟩
+      have hb := hT σ h2.le
+      change ‖((Φ : ℍ → ℂ) ∣[a] γ) σ‖ ≤ ε * ‖ΨA σ‖ at hb
+      rw [← hprodA, Pi.mul_apply, norm_mul] at hb
+      have hn : ‖ΨA σ‖ ≤ 0 := by nlinarith [norm_nonneg (ΨA σ)]
+      exact norm_eq_zero.mp (le_antisymm hn (norm_nonneg _))
+    have hΨA0 : ∀ σ, ΨA σ = 0 := ANa.vanish hΨA_mdiff hWo ⟨hlt, by linarith⟩ hΨAW
+    apply hΨ
+    refine DFunLike.ext Ψ 0 fun σ => ?_
+    have hback : (Ψ : ℍ → ℂ) = ΨA ∣[b] γ⁻¹ := by
+      rw [hΨA, ← SlashAction.slash_mul, mul_inv_cancel, SlashAction.slash_one]
+    have := congrFun hback σ
+    rw [this, ModularForm.SL_slash_apply, hΨA0, zero_mul]
+    rfl
+  refine ⟨{ toFun := f, slash_action_eq' := hf_slash, holo' := hf_mdiff,
+            zero_at_cusps' := fun {cc} hc => ?_ }, hfΨ⟩
+  have hc' : IsCusp cc (Matrix.SpecialLinearGroup.mapGL ℝ).range :=
+    hc.mono (Subgroup.map_le_range _ _)
+  exact (OnePoint.isZeroAt_iff_forall_SL2Z hc').mpr fun γ _ => hcusp' γ
+
+end
+end S_ModularForm_exists_cuspForm_mul_eq_of_analyticOrderAt_le
+end P2MW
+export P2MW.S_ModularForm_exists_cuspForm_mul_eq_of_analyticOrderAt_le (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups ModularForm
+theorem ModularForm.exists_cuspForm_mul_eq_of_analyticOrderAt_le (N : ℕ) {a b : ℤ} (c : ℤ)
+    (habc : b + c = a)
+    (Φ : ModularForm (CongruenceSubgroup.Gamma0 N) a)
+    (Ψ : ModularForm (CongruenceSubgroup.Gamma0 N) b) (hΨ : Ψ ≠ 0)
+    (hord : ∀ τ : UpperHalfPlane, analyticOrderAt ((Ψ : UpperHalfPlane → ℂ) ∘
+      UpperHalfPlane.ofComplex) (τ : ℂ) ≤
+      analyticOrderAt ((Φ : UpperHalfPlane → ℂ) ∘ UpperHalfPlane.ofComplex) (τ : ℂ))
+    (hcusp : ∀ (A : Matrix.SpecialLinearGroup (Fin 2) ℤ) (ε : ℝ), 0 < ε →
+      ∀ᶠ τ : UpperHalfPlane in UpperHalfPlane.atImInfty,
+        ‖((Φ : UpperHalfPlane → ℂ) ∣[a] (A : GL (Fin 2) ℝ)) τ‖ ≤ ε * ‖((Ψ : UpperHalfPlane → ℂ) ∣[b]
+          (A : GL (Fin 2) ℝ)) τ‖) :
+    ∃ f : CuspForm (CongruenceSubgroup.Gamma0 N) c, ∀ τ : UpperHalfPlane, f τ * Ψ τ = Φ τ :=
+  solution N c habc Φ Ψ hΨ hord hcusp
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_degeneracy_Gamma0.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_degeneracy_Gamma0.lean
new file mode 100644
index 0000000000..7140f85ad5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_degeneracy_Gamma0.lean
@@ -0,0 +1,185 @@
+/-
+Based on Prove2Me node ModularForm.exists_degeneracy_Gamma0
+(977cb42e-8443-5be3-bfc1-1aa296405e93) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 0670174c-f940-5179-9fee-8cb0c577d55a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+public import Mathlib.NumberTheory.ModularForms.Basic
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+
+import Mathlib.NumberTheory.ModularForms.NormTrace
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degeneracy map f(τ)↦ f(dτ) from Γ₀(M) to Γ₀(N)
+
+Theorem statement: `ModularForm.exists_degeneracy_Gamma0` (`977cb42e-8443-5be3-bfc1-1aa296405e93`),
+by Claude, 2026-09-05.
+
+Proof: submission `0670174c-f940-5179-9fee-8cb0c577d55a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $k$ be an integer and $M, N, d$ natural numbers with $N$ nonzero, and suppose $d\,M \mid N$ (so
+in particular $d \neq 0$ and $M \neq 0$). Write `heckeDiagMatrix d` for the element of
+$\mathrm{GL}_2(\mathbb{R})$ which is the identity when $d = 0$ and otherwise the upper triangular
+matrix $\begin{pmatrix} d & 0 \\ 0 & 1\end{pmatrix}$ (viewed as invertible since $d \cdot 1 \neq
+0$), acting on the upper half plane by $\tau \mapsto d\tau$. Then for every modular form $f$ of
+weight $k$ for the congruence subgroup $\Gamma_0(M)$, regarded as a subgroup of
+$\mathrm{GL}_2(\mathbb{R})$, there exists a modular form $g$ of weight $k$ for $\Gamma_0(N)$ whose
+underlying function is exactly $\tau \mapsto f(\,$`heckeDiagMatrix d`$\cdot \tau)$, that is,
+$g(\tau) = f(d\tau)$ with no normalising constant. The assertion is the existence of such a $g$, not
+a map or a linear embedding of spaces of forms.
+
+This is the degeneracy (level-raising) map $V_d$ of Atkin–Lehner theory, in the form $f(\tau)
+\mapsto f(d\tau)$, sending weight-$k$ forms on $\Gamma_0(M)$ to weight-$k$ forms on $\Gamma_0(N)$
+whenever $dM \mid N$; such maps produce the oldforms of level $N$ coming from level $M$. It is used
+throughout the project wherever a form of small level must be regarded, after rescaling of the
+variable, as a form of larger level.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_exists_degeneracy_Gamma0.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_exists_degeneracy_Gamma0
+
+p2m_open_scoped "MatrixGroups ModularForm P2MW.S_ModularForm_exists_degeneracy_Gamma0.ModularForm \
+  Pointwise"
+
+noncomputable section
+
+namespace ModularForm
+p2m_export "ModularForm" "translate IsGLPos.coe_smul coe_smul holo' ext smul_apply bdd_at_cusps' \
+  coe_translate heckeDiagMatrix val_heckeDiagMatrix slash_heckeDiagMatrix_apply"
+namespace DegeneracyPort
+p2m_open "ModularForm"
+
+variable {k : ℤ}
+
+def restrictMF {Γ Γ' : Subgroup (GL (Fin 2) ℝ)} (h : Γ' ≤ Γ) (F : ModularForm Γ k) :
+    ModularForm Γ' k where
+  toFun := F
+  slash_action_eq' γ hγ := SlashInvariantForm.slash_action_eqn F γ (h hγ)
+  holo' := F.holo'
+  bdd_at_cusps' hc := F.bdd_at_cusps' (hc.mono h)
+
+def restrictCF {Γ Γ' : Subgroup (GL (Fin 2) ℝ)} (h : Γ' ≤ Γ) (F : CuspForm Γ k) :
+    CuspForm Γ' k where
+  toFun := F
+  slash_action_eq' γ hγ := SlashInvariantForm.slash_action_eqn F γ (h hγ)
+  holo' := F.holo'
+  zero_at_cusps' hc := F.zero_at_cusps' (hc.mono h)
+
+@[scoped simp] theorem coe_restrictMF {Γ Γ' : Subgroup (GL (Fin 2) ℝ)} (h : Γ' ≤ Γ) (F : ModularForm
+  Γ k) :
+    ⇑(restrictMF h F) = ⇑F := rfl
+
+@[scoped simp] theorem coe_restrictCF {Γ Γ' : Subgroup (GL (Fin 2) ℝ)} (h : Γ' ≤ Γ) (F : CuspForm Γ
+  k) :
+    ⇑(restrictCF h F) = ⇑F := rfl
+
+theorem Gamma0_le_conj_Gamma0 {M N d : ℕ} (hd : d ≠ 0) (hdiv : d * M ∣ N) :
+    ((CongruenceSubgroup.Gamma0 N : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) ≤
+      ConjAct.toConjAct (heckeDiagMatrix d)⁻¹ •
+        ((CongruenceSubgroup.Gamma0 M : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) := by
+  rintro _ ⟨A, hA, rfl⟩
+  rw [Subgroup.mem_pointwise_smul_iff_inv_smul_mem, ConjAct.toConjAct_inv, inv_inv,
+    ConjAct.toConjAct_smul]
+  have hN : (N : ℤ) ∣ (A : Matrix (Fin 2) (Fin 2) ℤ) 1 0 :=
+    (ZMod.intCast_zmod_eq_zero_iff_dvd _ N).mp (CongruenceSubgroup.Gamma0_mem.mp hA)
+  obtain ⟨c', hc'⟩ : (d : ℤ) ∣ (A : Matrix (Fin 2) (Fin 2) ℤ) 1 0 :=
+    (Int.natCast_dvd_natCast.mpr (Dvd.intro _ rfl : d ∣ d * M)).trans
+      ((Int.natCast_dvd_natCast.mpr hdiv).trans hN)
+  have hMc' : (M : ℤ) ∣ c' := by
+    have h1 : (d : ℤ) * M ∣ (d : ℤ) * c' := by
+      rw [← hc']; exact_mod_cast (Int.natCast_dvd_natCast.mpr hdiv).trans hN
+    exact (mul_dvd_mul_iff_left (by exact_mod_cast hd)).mp h1
+  have hdet : (A : Matrix (Fin 2) (Fin 2) ℤ) 0 0 * (A : Matrix (Fin 2) (Fin 2) ℤ) 1 1 -
+      (A : Matrix (Fin 2) (Fin 2) ℤ) 0 1 * (A : Matrix (Fin 2) (Fin 2) ℤ) 1 0 = 1 := by
+    rw [← Matrix.det_fin_two, A.det_coe]
+  let B : SL(2, ℤ) :=
+    ⟨!![(A : Matrix (Fin 2) (Fin 2) ℤ) 0 0, d * (A : Matrix (Fin 2) (Fin 2) ℤ) 0 1;
+      c', (A : Matrix (Fin 2) (Fin 2) ℤ) 1 1], by
+    rw [Matrix.det_fin_two_of]
+    linear_combination hdet + (A : Matrix (Fin 2) (Fin 2) ℤ) 0 1 * hc'⟩
+  refine ⟨B, ?_, ?_⟩
+  · rw [SetLike.mem_coe, CongruenceSubgroup.Gamma0_mem]
+    change ((c' : ℤ) : ZMod M) = 0
+    exact (ZMod.intCast_zmod_eq_zero_iff_dvd _ M).mpr hMc'
+  · rw [eq_mul_inv_iff_mul_eq]
+    apply Units.ext
+    simp only [Units.val_mul, Matrix.SpecialLinearGroup.mapGL_coe_matrix, val_heckeDiagMatrix hd]
+    ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp [Matrix.mul_apply, Fin.sum_univ_two, B, hc', mul_comm]
+
+theorem exists_modularForm {M N d : ℕ} [NeZero N] (hdiv : d * M ∣ N)
+    (f : ModularForm (CongruenceSubgroup.Gamma0 M) k) :
+    ∃ g : ModularForm (CongruenceSubgroup.Gamma0 N) k,
+      ⇑g = fun τ ↦ f (ModularForm.heckeDiagMatrix d • τ) := by
+  have hd : d ≠ 0 := by
+    rintro rfl
+    rw [zero_mul, zero_dvd_iff] at hdiv
+    exact NeZero.ne N hdiv
+  have hdk : ((d : ℂ) ^ (k - 1)) ≠ 0 := zpow_ne_zero _ (Nat.cast_ne_zero.mpr hd)
+  refine ⟨((d : ℂ) ^ (k - 1))⁻¹ •
+    restrictMF (Gamma0_le_conj_Gamma0 hd hdiv) (ModularForm.translate f (heckeDiagMatrix d)), ?_⟩
+  funext τ
+  rw [FunLike.coe_smul, Pi.smul_apply, coe_restrictMF, ModularForm.coe_translate,
+    slash_heckeDiagMatrix_apply k hd, smul_eq_mul, ← mul_assoc, inv_mul_cancel₀ hdk, one_mul]
+
+theorem exists_cuspForm {M N d : ℕ} [NeZero N] (hdiv : d * M ∣ N)
+    (f : CuspForm (CongruenceSubgroup.Gamma0 M) k) :
+    ∃ g : CuspForm (CongruenceSubgroup.Gamma0 N) k,
+      ⇑g = fun τ ↦ f (ModularForm.heckeDiagMatrix d • τ) := by
+  have hd : d ≠ 0 := by
+    rintro rfl
+    rw [zero_mul, zero_dvd_iff] at hdiv
+    exact NeZero.ne N hdiv
+  have hdk : ((d : ℂ) ^ (k - 1)) ≠ 0 := zpow_ne_zero _ (Nat.cast_ne_zero.mpr hd)
+  refine ⟨((d : ℂ) ^ (k - 1))⁻¹ •
+    restrictCF (Gamma0_le_conj_Gamma0 hd hdiv) (CuspForm.translate f (heckeDiagMatrix d)), ?_⟩
+  funext τ
+  rw [FunLike.coe_smul, Pi.smul_apply, coe_restrictCF]
+  change ((d : ℂ) ^ (k - 1))⁻¹ • (⇑f ∣[k] heckeDiagMatrix d) τ = _
+  rw [slash_heckeDiagMatrix_apply k hd, smul_eq_mul, ← mul_assoc, inv_mul_cancel₀ hdk, one_mul]
+
+end ModularForm.DegeneracyPort
+end
+
+theorem solution {k : ℤ} {M N d : ℕ} [NeZero N] (hd : d * M ∣ N)
+    (f : ModularForm (CongruenceSubgroup.Gamma0 M) k) :
+    ∃ g : ModularForm (CongruenceSubgroup.Gamma0 N) k, ⇑g = fun τ ↦ f (ModularForm.heckeDiagMatrix d
+      • τ) :=
+  ModularForm.DegeneracyPort.exists_modularForm hd f
+
+end S_ModularForm_exists_degeneracy_Gamma0
+end P2MW
+export P2MW.S_ModularForm_exists_degeneracy_Gamma0 (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularForm.exists_degeneracy_Gamma0 {k : ℤ} {M N d : ℕ} [NeZero N] (hd : d * M ∣ N)
+    (f : ModularForm (CongruenceSubgroup.Gamma0 M) k) :
+    ∃ g : ModularForm (CongruenceSubgroup.Gamma0 N) k, ⇑g = fun τ ↦ f (ModularForm.heckeDiagMatrix d
+      • τ) :=
+  solution hd f
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_gamma0_qExpansion_eq_of_levelOne.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_gamma0_qExpansion_eq_of_levelOne.lean
new file mode 100644
index 0000000000..5fa72e2e2c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_gamma0_qExpansion_eq_of_levelOne.lean
@@ -0,0 +1,107 @@
+/-
+Based on Prove2Me node ModularForm.exists_gamma0_qExpansion_eq_of_levelOne
+(de6d7e36-aff6-5cb4-ae4c-3871257781e3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e837a47a-7fc4-5078-8494-19044c10edd3
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.LevelOne.DimensionFormula
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import Mathlib.RingTheory.LaurentSeries
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_degeneracy_Gamma0
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A level-one form is a form for Γ₀(N)
+
+Theorem statement: `ModularForm.exists_gamma0_qExpansion_eq_of_levelOne`
+(`de6d7e36-aff6-5cb4-ae4c-3871257781e3`), by Claude, 2026-09-05.
+
+Proof: submission `e837a47a-7fc4-5078-8494-19044c10edd3`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number that is nonzero, let $k$ be an integer, and let $F$ be a modular form of
+weight $k$ for the subgroup $\mathcal{SL}$ of $\mathrm{GL}(2,\mathbb{R})$, i.e. for the image of
+$\mathrm{SL}(2,\mathbb{Z})$ under the canonical map into $\mathrm{GL}(2,\mathbb{R})$ (the level-one
+case). The assertion is that there exists a modular form $G$ of the same weight $k$ for the
+congruence subgroup $\Gamma_0(N)$, in Mathlib's sense `CongruenceSubgroup.Gamma0 N`, whose
+underlying function $\mathbb{H}\to\mathbb{C}$ is equal to that of $F$. Thus the conclusion is an
+equality of functions on the upper half-plane, not merely an agreement of $q$-expansions as the name
+might suggest; it says that an $\mathrm{SL}(2,\mathbb{Z})$-form, regarded as a holomorphic function
+on $\mathbb{H}$, is in the image of the set of $\Gamma_0(N)$-forms under passage to the underlying
+function. No hypothesis relating $N$ to $k$ or to $F$ is imposed beyond $N \neq 0$.
+
+This is the restriction (trivial degeneracy) map from level $1$ to level $N$, stated existentially
+so that subsequent statements never have to name a restriction operator; it lets level-one forms
+such as $E_6^2$ and $E_4^2E_6$ be fed into statements formulated for $\Gamma_0(N)$. It is used by
+the statements on $q$-expansion coefficients of cusp forms at various levels, in particular those
+comparing Atkin–Lehner and Hecke operators with integrality hypotheses.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_exists_gamma0_qExpansion_eq_of_levelOne.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_exists_gamma0_qExpansion_eq_of_levelOne
+
+open UpperHalfPlane
+open scoped MatrixGroups
+
+namespace SolRESTRAux
+
+private theorem gamma0_one_eq_top : CongruenceSubgroup.Gamma0 1 = ⊤ := by
+  ext A
+  simp [CongruenceSubgroup.Gamma0_mem, eq_iff_true_of_subsingleton]
+
+private theorem gamma0_one_coe :
+    ((CongruenceSubgroup.Gamma0 1 : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) = 𝒮ℒ := by
+  simp [gamma0_one_eq_top, MonoidHom.range_eq_map]
+
+private theorem heckeDiagMatrix_one : ModularForm.heckeDiagMatrix 1 = 1 := by
+  apply Units.ext
+  simp [Matrix.one_fin_two]
+
+end SolRESTRAux
+
+theorem solution (N : ℕ) [NeZero N] {k : ℤ} (F : ModularForm 𝒮ℒ k) :
+    ∃ G : ModularForm (CongruenceSubgroup.Gamma0 N) k, (G : ℍ → ℂ) = (F : ℍ → ℂ) := by
+  obtain ⟨G, hG⟩ := ModularForm.exists_degeneracy_Gamma0 (show 1 * 1 ∣ N by simp)
+    (ModularForm.mcast rfl F SolRESTRAux.gamma0_one_coe)
+  refine ⟨G, ?_⟩
+  rw [hG, SolRESTRAux.heckeDiagMatrix_one]
+  funext τ
+  rw [one_smul]
+  rfl
+
+end S_ModularForm_exists_gamma0_qExpansion_eq_of_levelOne
+end P2MW
+export P2MW.S_ModularForm_exists_gamma0_qExpansion_eq_of_levelOne (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane
+open scoped MatrixGroups
+theorem ModularForm.exists_gamma0_qExpansion_eq_of_levelOne (N : ℕ) [NeZero N] {k : ℤ}
+    (F : ModularForm 𝒮ℒ k) :
+    ∃ G : ModularForm (CongruenceSubgroup.Gamma0 N) k, (G : ℍ → ℂ) = (F : ℍ → ℂ) :=
+  solution N F
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_gamma1_isIntegralQExp_eisenstein_four_six.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_gamma1_isIntegralQExp_eisenstein_four_six.lean
new file mode 100644
index 0000000000..496cec0ecf
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_gamma1_isIntegralQExp_eisenstein_four_six.lean
@@ -0,0 +1,144 @@
+/-
+Based on Prove2Me node ModularForm.exists_gamma1_isIntegralQExp_eisenstein_four_six
+(2a343937-c946-585e-bee8-a81c8eb9515f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 01dce715-2be2-5628-8186-35130ce8fc7b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ArithmeticFunction.Misc
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import Mathlib.NumberTheory.ModularForms.EisensteinSeries.QExpansion
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integral q-expansions of E₄ and E₆ on Γ₁(M)
+
+Theorem statement: `ModularForm.exists_gamma1_isIntegralQExp_eisenstein_four_six`
+(`2a343937-c946-585e-bee8-a81c8eb9515f`), by Claude, 2026-09-05.
+
+Proof: submission `01dce715-2be2-5628-8186-35130ce8fc7b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a natural number, assumed nonzero (the `NeZero M` instance). Then there exist a modular
+form $E_4$ of weight $4$ and a modular form $E_6$ of weight $6$, both for the group $\Gamma_1(M)$
+viewed, via the inclusion of $\mathrm{SL}_2(\mathbb{Z})$, as a subgroup of
+$\mathrm{GL}_2(\mathbb{R})$, with the following property. Writing $p_4 \in \mathbb{Z}[[q]]$ for the
+power series whose $n$-th coefficient is $1$ for $n = 0$ and $240\,\sigma_3(n)$ otherwise, and $p_6$
+for the power series whose $n$-th coefficient is $1$ for $n = 0$ and $-504\,\sigma_5(n)$ otherwise
+(here $\sigma_k(n) = \sum_{d \mid n} d^k$), both $E_4$ and $E_6$ satisfy
+[`ModularCurve.IsIntegralQExp`](def/ModularCurve_X1.html#L37), which by definition asserts that the
+image of the given integral power series under the coefficientwise ring homomorphism $\mathbb{Z} \to
+\mathbb{C}$ coincides with the $q$-expansion of width $1$ of the underlying function $\mathbb{H} \to
+\mathbb{C}$. Thus the $q$-expansions at $\infty$ of $E_4$ and $E_6$ are exactly $1 + 240\sum_{n \ge
+1}\sigma_3(n)q^n$ and $1 - 504\sum_{n \ge 1}\sigma_5(n)q^n$.
+
+This is the classical normalisation of the level-one Eisenstein series of weights $4$ and $6$,
+transported to level $\Gamma_1(M)$ by restriction, so that forms with explicitly integral
+$q$-expansions are available at every level. It is used in the construction and identification of
+function fields of modular curves, in particular in the arguments concerning the Igusa and Kummer
+generators and in producing a weight-one form on $\Gamma_1(M)$ whose square has a prescribed
+$q$-expansion.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_exists_gamma1_isIntegralQExp_eisenstein_four_six.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_exists_gamma1_isIntegralQExp_eisenstein_four_six
+
+open ModularCurve CongruenceSubgroup
+open scoped MatrixGroups ArithmeticFunction.sigma
+
+namespace E46Aux
+
+theorem bernoulli_four : bernoulli 4 = -1 / 30 := by
+  rw [bernoulli_eq_bernoulli'_of_ne_one (by norm_num), bernoulli'_four]
+
+theorem bernoulli'_six : bernoulli' 6 = 1 / 42 := by
+  rw [bernoulli'_def]
+  simp only [Finset.sum_range_succ, Finset.sum_range_zero, bernoulli'_zero, bernoulli'_one,
+    bernoulli'_two,
+    bernoulli'_three, bernoulli'_four, bernoulli'_eq_zero_of_odd (by decide : Odd 5) (by norm_num)]
+  norm_num [Nat.choose]
+
+theorem bernoulli_six : bernoulli 6 = 1 / 42 := by
+  rw [bernoulli_eq_bernoulli'_of_ne_one (by norm_num), bernoulli'_six]
+
+theorem isIntegralQExp_E4 :
+    IsIntegralQExp (⇑ModularForm.E₄ : UpperHalfPlane → ℂ) (PowerSeries.mk fun n => if n = 0 then 1
+      else 240 * (σ 3 n : ℤ)) := by
+  rw [isIntegralQExp_iff]
+  intro n
+  have h := EisensteinSeries.E_qExpansion_coeff (by norm_num : 3 ≤ 4) (by decide : Even 4) n
+  rw [ModularForm.E₄] at *
+  rw [h]
+  simp only [PowerSeries.coeff_mk]
+  split_ifs with hn
+  · simp
+  · rw [bernoulli_four]
+    push_cast
+    ring
+
+theorem isIntegralQExp_E6 :
+    IsIntegralQExp (⇑ModularForm.E₆ : UpperHalfPlane → ℂ) (PowerSeries.mk fun n => if n = 0 then 1
+      else -504 * (σ 5 n : ℤ)) := by
+  rw [isIntegralQExp_iff]
+  intro n
+  have h := EisensteinSeries.E_qExpansion_coeff (by norm_num : 3 ≤ 6) (by decide : Even 6) n
+  rw [h]
+  simp only [PowerSeries.coeff_mk]
+  split_ifs with hn
+  · simp
+  · rw [bernoulli_six]
+    push_cast
+    ring
+
+end E46Aux
+
+open E46Aux in
+theorem solution (M : ℕ) [NeZero M] :
+    ∃ (E4 : ModularForm (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) 4)
+      (E6 : ModularForm (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) 6),
+      ModularCurve.IsIntegralQExp E4 (PowerSeries.mk fun n => if n = 0 then 1 else 240 * (σ 3 n :
+        ℤ)) ∧
+      ModularCurve.IsIntegralQExp E6 (PowerSeries.mk fun n => if n = 0 then 1 else -504 * (σ 5 n :
+        ℤ)) := by
+  have hle : ((Gamma1 M : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) ≤ 𝒮ℒ :=
+    Subgroup.map_le_range _ _
+  exact ⟨restrictForm hle ModularForm.E₄, restrictForm hle ModularForm.E₆, isIntegralQExp_E4,
+    isIntegralQExp_E6⟩
+
+end S_ModularForm_exists_gamma1_isIntegralQExp_eisenstein_four_six
+end P2MW
+export P2MW.S_ModularForm_exists_gamma1_isIntegralQExp_eisenstein_four_six (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped ArithmeticFunction.sigma
+theorem ModularForm.exists_gamma1_isIntegralQExp_eisenstein_four_six (M : ℕ) [NeZero M] :
+    ∃ (E4 : ModularForm (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) 4)
+      (E6 : ModularForm (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) 6),
+      ModularCurve.IsIntegralQExp E4 (PowerSeries.mk fun n => if n = 0 then 1 else 240 * (σ 3 n :
+        ℤ)) ∧
+      ModularCurve.IsIntegralQExp E6 (PowerSeries.mk fun n => if n = 0 then 1 else -504 * (σ 5 n :
+        ℤ)) :=
+  solution M
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_gamma1_weightOne_ne_zero_and_mul_thetaL_eq_qExpansion_sq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_gamma1_weightOne_ne_zero_and_mul_thetaL_eq_qExpansion_sq.lean
new file mode 100644
index 0000000000..1795057347
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_gamma1_weightOne_ne_zero_and_mul_thetaL_eq_qExpansion_sq.lean
@@ -0,0 +1,248 @@
+/-
+Based on Prove2Me node ModularForm.exists_gamma1_weightOne_ne_zero_and_mul_thetaL_eq_qExpansion_sq
+(ad2d7347-49c0-57ec-b6d2-4ab3b26be5d6) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a139a896-0051-5778-b2a2-ec10695bd075
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JqCoeff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_QExpansionDiff
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_mem_intFormRatiosC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_integralWeightOneForm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_thetaL_jq_mul_eisenstein4_eq_neg_jq_mul_eisenstein6
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_theta_coeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_gamma1_isIntegralQExp_eisenstein_four_six
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Weight-one form on Γ₁(M) with v vartheta j = w²
+
+Theorem statement: `ModularForm.exists_gamma1_weightOne_ne_zero_and_mul_thetaL_eq_qExpansion_sq`
+(`ad2d7347-49c0-57ec-b6d2-4ab3b26be5d6`), by Claude, 2026-09-05.
+
+Proof: submission `a139a896-0051-5778-b2a2-ec10695bd075`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a natural number with $5 \le M$ (and $M \neq 0$). The assertion is the existence of a
+modular form $w$ of weight $1$ for the group $\Gamma_1(M)$, regarded as a subgroup of
+$\mathrm{GL}_2(\mathbb{R})$, together with a Laurent series $v \in \mathbb{C}((q))$, such that three
+conditions hold. First, $w \neq 0$. Second, $v$ lies in [`ModularCurve.laurentBaseChange ℂ
+(ModularCurve.qExpFunctionFieldC ℚ (Gamma1 M))`](def/ModularCurve_LaurentCoeff.html#L103), that is,
+in the intermediate field of $\mathbb{C}((q))$ over $\mathbb{C}$ generated by the coefficientwise
+images under $\mathbb{Q} \to \mathbb{C}$ of the elements of `qExpFunctionFieldC ℚ (Gamma1 M)`, the
+subfield of $\mathbb{Q}((q))$ generated over $\mathbb{Q}$ by all quotients
+$\mathrm{intSeriesC}\,\mathbb{Q}\,p_f / \mathrm{intSeriesC}\,\mathbb{Q}\,p_g$ in which $f$ and $g$
+are modular forms of some common weight $k$ for $\Gamma_1(M)$, $p_f$ and $p_g$ are integral power
+series satisfying the predicate `IsIntegralQExp` with respect to $f$ and $g$, and
+$\mathrm{intSeriesC}\,\mathbb{Q}\,p_g \neq 0$. Third, $v \cdot \vartheta j =
+\bigl(\text{$q$-expansion of } w\bigr)^2$ in $\mathbb{C}((q))$, where $\vartheta j$ is `thetaL ℂ
+(jqModC ℂ)`, the operator $f \mapsto q\,\mathrm{d}f/\mathrm{d}q$ applied to $q^{-1}\cdot(E_4^3 \cdot
+\mathrm{dedekindEtaUnitInv})$ with coefficients pushed to $\mathbb{C}$, and the square is that of
+the image of `UpperHalfPlane.qExpansion 1 w` in $\mathbb{C}((q))$.
+
+This supplies the odd-weight analogue of the multiplier $(\vartheta j)^m$: a square root of a
+suitable power of $\vartheta j$ up to a function on $X_1(M)$, realised by a non-zero weight-one form
+such as an Eisenstein series attached to an odd Dirichlet character. It is used by
+[`ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_odd`]
+(thm.html#ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_odd)
+in the proof of the upper bound for the dimension of spaces of modular forms of odd weight on
+$\Gamma_1(M)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_exists_gamma1_weightOne_ne_zero_and_mul_thetaL_eq_qExpansion_sq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_exists_gamma1_weightOne_ne_zero_and_mul_thetaL_eq_qExpansion_sq
+
+open CongruenceSubgroup ModularCurve UpperHalfPlane
+open scoped MatrixGroups ModularForm ArithmeticFunction.sigma
+
+noncomputable section
+
+namespace W1OddE96
+
+variable (M : ℕ) [NeZero M]
+
+local notation "Γ₁ℝ" => ((CongruenceSubgroup.Gamma1 M : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2)
+  ℝ))
+
+omit [NeZero M] in
+theorem one_mem_strictPeriods_gamma1 : (1 : ℝ) ∈ (Γ₁ℝ).strictPeriods := by
+  simp
+
+theorem isIntegralQExp_mul {a b : ℤ} (f : ModularForm Γ₁ℝ a) (g : ModularForm Γ₁ℝ b)
+    {p q : PowerSeries ℤ} (hf : IsIntegralQExp f p) (hg : IsIntegralQExp g q) :
+    IsIntegralQExp (f.mul g) (p * q) := by
+  rw [IsIntegralQExp] at hf hg ⊢
+  rw [map_mul, hf, hg, ← ModularForm.qExpansion_mul one_pos (one_mem_strictPeriods_gamma1 M) f g]
+
+omit [NeZero M] in
+theorem isIntegralQExp_mcast {a b : ℤ} (h : a = b) (f : ModularForm Γ₁ℝ a) {p : PowerSeries ℤ}
+    (hf : IsIntegralQExp f p) : IsIntegralQExp (ModularForm.mcast h f) p := by
+  rw [IsIntegralQExp] at hf ⊢
+  rw [hf]
+  rfl
+
+theorem mk_sigma_three_eq_eisenstein4 :
+    (PowerSeries.mk fun n => if n = 0 then 1 else 240 * (σ 3 n : ℤ)) = eisenstein4 := by
+  ext n
+  simp only [eisenstein4, PowerSeries.coeff_mk, ArithmeticFunction.sigma_apply, Nat.cast_sum,
+    Nat.cast_pow]
+
+theorem mk_sigma_five_eq_eisenstein6 :
+    (PowerSeries.mk fun n => if n = 0 then 1 else -504 * (σ 5 n : ℤ)) = eisenstein6 := by
+  ext n
+  simp only [eisenstein6, PowerSeries.coeff_mk, ArithmeticFunction.sigma_apply, Nat.cast_sum,
+    Nat.cast_pow]
+
+theorem coeffEmb_intSeriesC (L : Type*) [Field L] [CharZero L] (q : PowerSeries ℤ) :
+    coeffEmb L (intSeriesC ℚ q) = intSeriesC L q := by
+  ext n
+  rw [coeffEmb_coeff, intSeriesC, intSeriesC]
+  rcases le_or_gt 0 n with hn | hn
+  · obtain ⟨m, rfl⟩ := Int.eq_ofNat_of_zero_le hn
+    rw [HahnSeries.ofPowerSeries_apply_coeff, HahnSeries.ofPowerSeries_apply_coeff,
+      PowerSeries.coeff_map,
+      PowerSeries.coeff_map, eq_intCast, eq_intCast, map_intCast]
+  · rw [ofPowerSeries_coeff_of_neg _ hn, ofPowerSeries_coeff_of_neg _ hn, map_zero]
+
+theorem coeffEmb_thetaL (L : Type*) [Field L] [CharZero L] (f : LaurentSeries ℚ) :
+    coeffEmb L (thetaL ℚ f) = thetaL L (coeffEmb L f) := by
+  ext n
+  rw [coeffEmb_coeff, thetaL_apply, thetaL_apply, ModularCurve.theta_coeff,
+    ModularCurve.theta_coeff,
+    coeffEmb_coeff, zsmul_eq_mul, zsmul_eq_mul, map_mul, map_intCast]
+
+theorem intSeriesC_ne_zero_of_constantCoeff (K : Type*) [Field K] (q : PowerSeries ℤ)
+    (hq : PowerSeries.constantCoeff q = 1) : intSeriesC K q ≠ 0 := by
+  intro h
+  have := congrArg (fun s : LaurentSeries K => s.coeff 0) h
+  simp only [intSeriesC, HahnSeries.coeff_zero] at this
+  rw [show (0 : ℤ) = ((0 : ℕ) : ℤ) from rfl, HahnSeries.ofPowerSeries_apply_coeff,
+    PowerSeries.coeff_map,
+    PowerSeries.coeff_zero_eq_constantCoeff, hq, map_one] at this
+  exact one_ne_zero this
+
+end W1OddE96
+
+end
+
+open W1OddE96 in
+theorem solution
+    (M : ℕ) [NeZero M] (hM : 5 ≤ M) :
+    ∃ (w : ModularForm (Gamma1 M) 1) (v : LaurentSeries ℂ), w ≠ 0 ∧
+      v ∈ ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+        (CongruenceSubgroup.Gamma1 M)) ∧
+      v * ModularCurve.thetaL ℂ (ModularCurve.jqModC ℂ) =
+        HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 w) ^ 2 := by
+  classical
+  obtain ⟨wI⟩ := ModularCurve.nonempty_integralWeightOneForm ℚ M (by omega)
+  obtain ⟨E4, E6, hE4, hE6⟩ := ModularForm.exists_gamma1_isIntegralQExp_eisenstein_four_six M
+  rw [mk_sigma_three_eq_eisenstein4] at hE4
+  rw [mk_sigma_five_eq_eisenstein6] at hE6
+  set w := wI.form with hwdef
+  set W : LaurentSeries ℂ := HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 w) with hWdef
+  have hWint : W = intSeriesC ℂ wI.series := by
+    rw [hWdef, intSeriesC, ← wI.isIntegralQExp]
+  have hWne : intSeriesC ℂ wI.series ≠ 0 := by
+    intro h
+    apply wI.intSeriesC_ne_zero
+    have h' : intSeriesC ℂ wI.series = coeffEmb ℂ (intSeriesC ℚ wI.series) :=
+      (coeffEmb_intSeriesC ℂ _).symm
+    rw [h'] at h
+    exact (map_eq_zero (coeffEmb ℂ)).mp h
+  have hw0 : w ≠ 0 := by
+    intro h0
+    apply hWne
+    rw [← hWint, hWdef, h0]
+    simp [qExpansion_zero]
+  let Nf : ModularForm ((Gamma1 M : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) 10 :=
+    ModularForm.mcast (by norm_num) ((w.mul w).mul (E4.mul E4))
+  let Df : ModularForm ((Gamma1 M : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) 10 :=
+    ModularForm.mcast (by norm_num) (E4.mul E6)
+  have hNf : IsIntegralQExp Nf (wI.series * wI.series * (eisenstein4 * eisenstein4)) :=
+    isIntegralQExp_mcast M _ _ (isIntegralQExp_mul M _ _ (isIntegralQExp_mul M _ _ wI.isIntegralQExp
+      wI.isIntegralQExp)
+      (isIntegralQExp_mul M _ _ hE4 hE4))
+  have hDf : IsIntegralQExp Df (eisenstein4 * eisenstein6) :=
+    isIntegralQExp_mcast M _ _ (isIntegralQExp_mul M _ _ hE4 hE6)
+  have hE4ne : ∀ (K : Type) [Field K], intSeriesC K eisenstein4 ≠ 0 := fun K _ =>
+    intSeriesC_ne_zero_of_constantCoeff K _ constantCoeff_eisenstein4
+  have hE6c : PowerSeries.constantCoeff eisenstein6 = 1 := by
+    rw [← PowerSeries.coeff_zero_eq_constantCoeff]; simp [eisenstein6]
+  have hE6ne : ∀ (K : Type) [Field K], intSeriesC K eisenstein6 ≠ 0 := fun K _ =>
+    intSeriesC_ne_zero_of_constantCoeff K _ hE6c
+  have hDne : intSeriesC ℚ (eisenstein4 * eisenstein6) ≠ 0 := by
+    rw [intSeriesC_mul]; exact mul_ne_zero (hE4ne ℚ) (hE6ne ℚ)
+  have humem : intSeriesC ℂ (wI.series * wI.series * (eisenstein4 * eisenstein4)) /
+      intSeriesC ℂ (eisenstein4 * eisenstein6) ∈
+      ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1
+        M)) := by
+    rw [← coeffEmb_intSeriesC ℂ, ← coeffEmb_intSeriesC ℂ, ← map_div₀]
+    exact coeffEmb_mem_laurentBaseChange ℂ (div_mem_qExpFunctionFieldC Nf Df hNf hDf hDne)
+  have hjmem : ModularCurve.jqModC ℂ ∈
+      ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1
+        M)) := by
+    rw [← map_jqModC (algebraMap ℚ ℂ), jqModC_rat]
+    exact coeffEmb_mem_laurentBaseChange ℂ
+      (intFormRatiosC_subset ℚ _ (by rw [← jqModC_rat]; exact jqModC_mem_intFormRatiosC ℚ _))
+  refine ⟨w, -(intSeriesC ℂ (wI.series * wI.series * (eisenstein4 * eisenstein4)) /
+      intSeriesC ℂ (eisenstein4 * eisenstein6) * (ModularCurve.jqModC ℂ)⁻¹), hw0, ?_, ?_⟩
+  · exact neg_mem (mul_mem humem (inv_mem hjmem))
+  · have hjC : coeffEmb ℂ jq = ModularCurve.jqModC ℂ := by
+      rw [← jqModC_rat]; exact map_jqModC (algebraMap ℚ ℂ)
+    have hid :=
+      congrArg (coeffEmb ℂ) ModularCurve.thetaL_jq_mul_eisenstein4_eq_neg_jq_mul_eisenstein6
+    rw [map_mul, map_neg, map_mul, coeffEmb_thetaL, hjC] at hid
+    have h4 : coeffEmb ℂ (HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ)
+      eisenstein4)) =
+        intSeriesC ℂ eisenstein4 := coeffEmb_intSeriesC ℂ eisenstein4
+    have h6 : coeffEmb ℂ (HahnSeries.ofPowerSeries ℤ ℚ (PowerSeries.map (Int.castRingHom ℚ)
+      eisenstein6)) =
+        intSeriesC ℂ eisenstein6 := coeffEmb_intSeriesC ℂ eisenstein6
+    rw [h4, h6] at hid
+    have hj : ModularCurve.jqModC ℂ ≠ 0 := by
+      rw [← hjC]; exact (map_ne_zero (coeffEmb ℂ)).mpr jq_ne_zero
+    rw [intSeriesC_mul, intSeriesC_mul, intSeriesC_mul, intSeriesC_mul, ← hWint]
+    have e4 := hE4ne ℂ
+    have e6 := hE6ne ℂ
+    field_simp
+    linear_combination (-(W ^ 2)) * hid
+
+end S_ModularForm_exists_gamma1_weightOne_ne_zero_and_mul_thetaL_eq_qExpansion_sq
+end P2MW
+export P2MW.S_ModularForm_exists_gamma1_weightOne_ne_zero_and_mul_thetaL_eq_qExpansion_sq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open CongruenceSubgroup ModularCurve
+open scoped MatrixGroups ModularForm
+theorem ModularForm.exists_gamma1_weightOne_ne_zero_and_mul_thetaL_eq_qExpansion_sq
+    (M : ℕ) [NeZero M] (hM : 5 ≤ M) :
+    ∃ (w : ModularForm (Gamma1 M) 1) (v : LaurentSeries ℂ), w ≠ 0 ∧
+      v ∈ ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+        (CongruenceSubgroup.Gamma1 M)) ∧
+      v * ModularCurve.thetaL ℂ (ModularCurve.jqModC ℂ) =
+        HahnSeries.ofPowerSeries ℤ ℂ (UpperHalfPlane.qExpansion 1 w) ^ 2 :=
+  solution M hM
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_gamma1_weight_four_isIntegralQExp_partialDivisorSum_slash_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_gamma1_weight_four_isIntegralQExp_partialDivisorSum_slash_eq.lean
new file mode 100644
index 0000000000..484f30d2ca
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_gamma1_weight_four_isIntegralQExp_partialDivisorSum_slash_eq.lean
@@ -0,0 +1,313 @@
+/-
+Based on Prove2Me node
+ModularForm.exists_gamma1_weight_four_isIntegralQExp_partialDivisorSum_slash_eq
+(e9b4b55b-7321-51fb-94da-15e460883231) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 48fc3a70-d6e7-5cd6-8313-511443e012cd
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_CohCarrier_Level
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X1
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_EisensteinSeries_exists_modularForm_coe_eq_eisensteinG
+import LeanPool.FLTEichlerShimura.Theorems.Thm_EisensteinSeries_sum_eisensteinG_vecCons_eq_mul_tsum_divisorSum_mul_cexp_pow
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Weight-four Eisenstein series with partial divisor-sum q-expansions
+
+Theorem statement: `ModularForm.exists_gamma1_weight_four_isIntegralQExp_partialDivisorSum_slash_eq`
+(`e9b4b55b-7321-51fb-94da-15e460883231`), by Claude, 2026-09-05.
+
+Proof: submission `48fc3a70-d6e7-5cd6-8313-511443e012cd`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a nonzero natural number with $3 \le M$. Then there is a family $R$ of modular forms,
+indexed by the units $c$ of $\mathbb{Z}/M$, each $R_c$ of weight $4$ for the congruence subgroup
+$\Gamma_1(M)$ regarded as a subgroup of $\mathrm{GL}(2,\mathbb{R})$, with the following two
+properties. First, for every unit $c$ the form $R_c$ has integral $q$-expansion given by the power
+series with coefficients $a_0 = 0$ and, for $n \ge 1$,
+$$a_n = \sum_{\substack{d \mid n \\ n/d \equiv c \text{ or } n/d \equiv -c \ (M)}} d^3 \in
+\mathbb{Z};$$
+here integrality means, as in the project predicate
+[`ModularCurve.IsIntegralQExp`](def/ModularCurve_X1.html#L37), that the image of this integral power
+series under $\mathbb{Z} \to \mathbb{C}$ is the $q$-expansion of $R_c$ of width $1$. Second, for
+every unit $c$ and every $\gamma \in \mathrm{SL}(2,\mathbb{Z})$ lying in $\Gamma_0(M)$, the
+weight-$4$ slash action of the image of $\gamma$ in $\mathrm{GL}(2,\mathbb{R})$ on the function
+underlying $R_c$ equals the function underlying $R_{c\delta^{-1}}$, where $\delta =$
+[`CohCarrier.gamma0Units M ⟨γ, hγ⟩`](def/CohCarrier_Level.html#L121) is the unit of $\mathbb{Z}/M$
+whose value is the reduction of the lower-right entry of $\gamma$ and whose inverse is the reduction
+of its upper-left entry.
+
+This is the classical construction, for each unit class $\pm c$ modulo $M$, of a weight-four
+Eisenstein series on $\Gamma_1(M)$ with rational integral Fourier coefficients $\sum_{d \mid n,\ n/d
+\equiv \pm c} d^3$ and vanishing constant term, together with the action of the diamond operators
+permuting the family. It supplies the explicit forms used in
+[`ModularCurve.IsDiamondPullbackModL.apply_eq_one_iff_gamma0Units_mem`]
+(thm.html#ModularCurve.IsDiamondPullbackModL.apply_eq_one_iff_gamma0Units_mem)
+and in
+[`ModularCurve.exists_intSeriesC_mul_ne_of_gamma0Units_not_mem`]
+(thm.html#ModularCurve.exists_intSeriesC_mul_ne_of_gamma0Units_not_mem)
+to detect the image of $\Gamma_0(M)$ in $(\mathbb{Z}/M)^\times$ by its effect on $q$-expansions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_exists_gamma1_weight_four_isIntegralQExp_partialDivisorSum_slash_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_exists_gamma1_weight_four_isIntegralQExp_partialDivisorSum_slash_eq
+
+open UpperHalfPlane
+
+section FracLemma
+open scoped MatrixGroups ModularForm Real
+
+private theorem eisRc_isIntegralQExp_of_apply_eq (M : ℕ) [NeZero M] (hM : 3 ≤ M) (c : (ZMod M)ˣ)
+    (f : ModularForm (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) 4)
+    (hf : ∀ z : UpperHalfPlane,
+      f z = ((-2 * π * Complex.I) ^ 4 / (Nat.factorial 3 : ℂ))⁻¹ *
+        ∑ e : ZMod M, EisensteinSeries.eisensteinG M 4 ![(c : ZMod M), e] z) :
+    ModularCurve.IsIntegralQExp f
+      (PowerSeries.mk fun n : ℕ => if n = 0 then 0 else
+        ∑ d ∈ n.divisors,
+          if ((n / d : ℕ) : ZMod M) = (c : ZMod M) ∨ ((n / d : ℕ) : ZMod M) = -(c : ZMod M)
+          then (d : ℤ) ^ 3 else 0) := by
+  classical
+  have h1per : (1 : ℝ) ∈ (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+    rw [CongruenceSubgroup.strictPeriods_Gamma1]
+    exact AddSubgroup.mem_zmultiples 1
+  have hc0 : (c : ZMod M) ≠ 0 := by
+    have : Nontrivial (ZMod M) := ZMod.nontrivial_iff.mpr (by omega)
+    exact c.ne_zero
+  have hcneg : (c : ZMod M) ≠ -(c : ZMod M) := by
+    intro h
+    have h3 : (2 : ZMod M) * (c : ZMod M) = 0 := by
+      rw [two_mul]
+      nth_rw 2 [h]
+      exact add_neg_cancel _
+    have h2 : ((2 : ℤ) : ZMod M) = 0 := by
+      rw [Int.cast_ofNat]
+      exact (Units.mul_left_eq_zero c).mp h3
+    have := Nat.le_of_dvd two_pos
+      (Int.natCast_dvd_natCast.mp ((ZMod.intCast_zmod_eq_zero_iff_dvd 2 M).mp h2))
+    omega
+  let T : ℕ → ℂ := fun n => ∑ d ∈ n.divisors,
+      ((if ((n / d : ℕ) : ZMod M) = (c : ZMod M) then (d : ℂ) ^ (4 - 1) else 0) +
+        (if ((n / d : ℕ) : ZMod M) = -(c : ZMod M) then (d : ℂ) ^ (4 - 1) else 0))
+  have hT : ∀ n : ℕ, T n = (((PowerSeries.coeff n) (PowerSeries.mk fun n : ℕ => if n = 0 then (0 :
+    ℤ) else
+      ∑ d ∈ n.divisors,
+        if ((n / d : ℕ) : ZMod M) = (c : ZMod M) ∨ ((n / d : ℕ) : ZMod M) = -(c : ZMod M)
+        then (d : ℤ) ^ 3 else 0) : ℤ) : ℂ) := by
+    intro n
+    rw [PowerSeries.coeff_mk]
+    by_cases hn : n = 0
+    · subst hn
+      simp [T]
+    · rw [ite_eq_right hn]
+      push_cast
+      refine Finset.sum_congr rfl fun d _ => ?_
+      by_cases hP : ((n / d : ℕ) : ZMod M) = (c : ZMod M)
+      · have hQ : ¬ ((n / d : ℕ) : ZMod M) = -(c : ZMod M) := fun hQ => hcneg (hP.symm.trans hQ)
+        rw [ite_eq_left hP, ite_eq_right hQ, ite_eq_left (Or.inl hP), add_zero]
+      · by_cases hQ : ((n / d : ℕ) : ZMod M) = -(c : ZMod M)
+        · rw [ite_eq_right hP, ite_eq_left hQ, ite_eq_left (Or.inr hQ), zero_add]
+        · rw [ite_eq_right hP, ite_eq_right hQ, ite_eq_right (not_or.mpr ⟨hP, hQ⟩), add_zero]
+  have hTnorm : ∀ n : ℕ, ‖T n‖ ≤ 2 * (n : ℝ) ^ 4 := by
+    intro n
+    rcases Nat.eq_zero_or_pos n with rfl | hn
+    · simp [T]
+    calc ‖T n‖ ≤ ∑ d ∈ n.divisors, 2 * (n : ℝ) ^ 3 := by
+          refine norm_sum_le_of_le _ fun d hd => ?_
+          have hdn : (d : ℝ) ≤ n := by exact_mod_cast Nat.divisor_le hd
+          refine (norm_add_le _ _).trans ?_
+          have hd3 : ‖(d : ℂ) ^ (4 - 1)‖ ≤ (n : ℝ) ^ 3 := by
+            rw [norm_pow, Complex.norm_natCast]
+            exact pow_le_pow_left₀ (Nat.cast_nonneg _) hdn 3
+          have hn3 : (0 : ℝ) ≤ (n : ℝ) ^ 3 := by positivity
+          split_ifs <;> (try simp only [norm_zero]) <;> linarith
+      _ = (n.divisors.card : ℝ) * (2 * (n : ℝ) ^ 3) := by rw [Finset.sum_const, nsmul_eq_mul]
+      _ ≤ (n : ℝ) * (2 * (n : ℝ) ^ 3) := by
+          gcongr
+          exact_mod_cast Nat.card_divisors_le_self n
+      _ = 2 * (n : ℝ) ^ 4 := by ring
+  have hC0 : ((-2 * π * Complex.I) ^ 4 / (Nat.factorial 3 : ℂ)) ≠ 0 := by
+    refine div_ne_zero (pow_ne_zero _ ?_) (by exact_mod_cast Nat.factorial_ne_zero 3)
+    refine mul_ne_zero (mul_ne_zero (by norm_num) ?_) Complex.I_ne_zero
+    exact_mod_cast Real.pi_ne_zero
+  have hHas : ∀ τ : UpperHalfPlane,
+      HasSum (fun m : ℕ => T m • Function.Periodic.qParam (1 : ℝ) (τ : ℂ) ^ m) (f τ) := by
+    intro τ
+    have hq : Function.Periodic.qParam (1 : ℝ) (τ : ℂ) = Complex.exp (2 * π * Complex.I * τ) := by
+      simp [Function.Periodic.qParam]
+    have hqn : ‖Complex.exp (2 * π * Complex.I * τ)‖ < 1 :=
+      UpperHalfPlane.norm_exp_two_pi_I_lt_one τ
+    have hsum : Summable fun m : ℕ => T m * Complex.exp (2 * π * Complex.I * τ) ^ m := by
+      have hg : Summable fun m : ℕ => 2 * ((m : ℝ) ^ 4 * ‖Complex.exp (2 * π * Complex.I * τ)‖ ^ m)
+        :=
+        (summable_pow_mul_geometric_of_norm_lt_one (R := ℝ)
+          (r := ‖Complex.exp (2 * π * Complex.I * τ)‖) 4 (by simpa using hqn)).mul_left 2
+      refine Summable.of_norm_bounded hg fun m => ?_
+      rw [norm_mul, norm_pow, ← mul_assoc]
+      gcongr
+      exact hTnorm m
+    have hE2 := EisensteinSeries.sum_eisensteinG_vecCons_eq_mul_tsum_divisorSum_mul_cexp_pow M
+      (c : ZMod M) hc0 (k := 4) (by norm_num) (by decide) τ
+    have hval : f τ = ∑' m : ℕ, T m * Complex.exp (2 * π * Complex.I * τ) ^ m := by
+      rw [hf τ]
+      simp only [Nat.cast_ofNat] at hE2
+      rw [hE2, ← mul_assoc]
+      have hfac : ((4 - 1).factorial : ℂ) = (Nat.factorial 3 : ℂ) := by norm_num
+      rw [hfac, inv_mul_cancel₀ hC0, one_mul]
+    rw [hval]
+    simp_rw [hq, smul_eq_mul]
+    exact hsum.hasSum
+  unfold ModularCurve.IsIntegralQExp
+  ext n
+  rw [PowerSeries.coeff_map, eq_intCast, ← hT n]
+  exact ModularFormClass.qExpansion_coeff_unique one_pos h1per hHas n
+
+end FracLemma
+
+open Matrix
+open scoped Real
+
+open scoped MatrixGroups ModularForm in
+theorem solution
+    (M : ℕ) [NeZero M] (hM : 3 ≤ M) :
+    ∃ R : (ZMod M)ˣ → ModularForm (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) 4,
+      (∀ c : (ZMod M)ˣ, ModularCurve.IsIntegralQExp (R c)
+        (PowerSeries.mk fun n : ℕ => if n = 0 then 0 else
+          ∑ d ∈ n.divisors,
+            if ((n / d : ℕ) : ZMod M) = (c : ZMod M) ∨ ((n / d : ℕ) : ZMod M) = -(c : ZMod M)
+            then (d : ℤ) ^ 3 else 0)) ∧
+      (∀ (c : (ZMod M)ˣ) (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M),
+        ((⇑(R c) : UpperHalfPlane → ℂ) ∣[(4 : ℤ)] (γ : GL (Fin 2) ℝ)) =
+          ⇑(R (c * (CohCarrier.gamma0Units M ⟨γ, hγ⟩)⁻¹))) := by
+  classical
+  set C : ℂ := ((-2 * π * Complex.I) ^ 4 / (Nat.factorial 3 : ℂ))⁻¹ with hC
+  have hE := fun v : Fin 2 → ZMod M =>
+    EisensteinSeries.exists_modularForm_coe_eq_eisensteinG M 4 (by norm_num) v
+  choose F hF using fun v : Fin 2 → ZMod M => (hE v).1
+  have hslash : ∀ (v : Fin 2 → ZMod M) (γ : SL(2, ℤ)),
+      EisensteinSeries.eisensteinG M 4 v ∣[(4 : ℤ)] γ = EisensteinSeries.eisensteinG M 4 (v ᵥ* γ) :=
+    fun v γ => (hE v).2 γ
+  let S : ZMod M → ℍ → ℂ := fun c z => ∑ e : ZMod M, EisensteinSeries.eisensteinG M 4 ![c, e] z
+  have hS : ∀ c : ZMod M, S c = ∑ e : ZMod M, EisensteinSeries.eisensteinG M 4 ![c, e] := by
+    intro c; ext z; simp [S, Finset.sum_apply]
+  let FS : ZMod M → ModularForm (CongruenceSubgroup.Gamma M : Subgroup (GL (Fin 2) ℝ)) 4 :=
+    fun c => ∑ e : ZMod M, F ![c, e]
+  have hcoe_sum : ∀ c : ZMod M, (⇑(FS c) : ℍ → ℂ) = S c := by
+    intro c
+    have h1 : (⇑(FS c) : ℍ → ℂ) = ∑ e : ZMod M, ⇑(F ![c, e]) :=
+      map_sum (FunLike.coeAddMonoidHom (ModularForm (CongruenceSubgroup.Gamma M : Subgroup (GL (Fin
+        2) ℝ)) 4) ℍ ℂ)
+        (fun e : ZMod M => F ![c, e]) Finset.univ
+    rw [h1, hS]
+    exact Finset.sum_congr rfl fun e _ => hF _
+  have hsum_slash : ∀ (φ : ZMod M → ℍ → ℂ) (γ : SL(2, ℤ)),
+      ((∑ e : ZMod M, φ e) ∣[(4 : ℤ)] γ) = ∑ e : ZMod M, (φ e ∣[(4 : ℤ)] γ) := by
+    intro φ γ
+    induction (Finset.univ : Finset (ZMod M)) using Finset.induction_on with
+    | empty => simp [SlashAction.zero_slash]
+    | insert a s ha ih => rw [Finset.sum_insert ha, Finset.sum_insert ha, SlashAction.add_slash, ih]
+  have hvec : ∀ (c e : ZMod M) (γ : SL(2, ℤ)),
+      (![c, e] ᵥ* γ : Fin 2 → ZMod M) =
+        ![c * ((γ 0 0 : ℤ) : ZMod M) + e * ((γ 1 0 : ℤ) : ZMod M),
+          c * ((γ 0 1 : ℤ) : ZMod M) + e * ((γ 1 1 : ℤ) : ZMod M)] := by
+    intro c e γ
+    ext i
+    fin_cases i <;>
+      simp [Matrix.vecMul, dotProduct, Fin.sum_univ_two, ]
+  have hrow_slash : ∀ (c : ZMod M) (γ : SL(2, ℤ)), γ ∈ CongruenceSubgroup.Gamma0 M →
+      S c ∣[(4 : ℤ)] γ = S (c * ((γ 0 0 : ℤ) : ZMod M)) := by
+    intro c γ hγ
+    have h10 : ((γ 1 0 : ℤ) : ZMod M) = 0 := CongruenceSubgroup.Gamma0_mem.mp hγ
+    have hdet : ((γ 0 0 : ℤ) : ZMod M) * ((γ 1 1 : ℤ) : ZMod M) = 1 := by
+      have := Matrix.SpecialLinearGroup.det_coe γ
+      rw [Matrix.det_fin_two] at this
+      have h := congrArg (fun z : ℤ => (z : ZMod M)) this
+      simp only [Int.cast_sub, Int.cast_mul, Int.cast_one, h10, mul_zero, sub_zero] at h
+      exact h
+    rw [hS c, hsum_slash, hS]
+    simp_rw [hslash, hvec, h10, mul_zero, add_zero]
+    let σ : ZMod M ≃ ZMod M :=
+      { toFun := fun e => c * ((γ 0 1 : ℤ) : ZMod M) + e * ((γ 1 1 : ℤ) : ZMod M)
+        invFun := fun e' => (e' - c * ((γ 0 1 : ℤ) : ZMod M)) * ((γ 0 0 : ℤ) : ZMod M)
+        left_inv := fun e => by
+          change (c * _ + e * _ - c * _) * _ = e
+          rw [add_sub_cancel_left, mul_assoc, mul_comm ((γ 1 1 : ℤ) : ZMod M), hdet, mul_one]
+        right_inv := fun e' => by
+          change c * _ + (e' - c * _) * _ * _ = e'
+          rw [mul_assoc, hdet, mul_one, add_sub_cancel] }
+    exact (Fintype.sum_equiv σ _ _ fun e => rfl)
+  have hcusp : ∀ {x : OnePoint ℝ},
+      IsCusp x (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) →
+      IsCusp x (CongruenceSubgroup.Gamma M : Subgroup (GL (Fin 2) ℝ)) := fun hx =>
+    (Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z _).mpr
+      ((Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z _).mp hx)
+  let lift : ZMod M → ModularForm (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) 4 :=
+    fun c =>
+    { toFun := ⇑(FS c)
+      slash_action_eq' := fun A hA => by
+        obtain ⟨β, hβ, rfl⟩ := Subgroup.mem_map.mp hA
+        have hβ' := (CongruenceSubgroup.Gamma1_mem M β).mp hβ
+        have hβ0 : β ∈ CongruenceSubgroup.Gamma0 M := CongruenceSubgroup.Gamma1_in_Gamma0 M hβ
+        have key : (⇑(FS c) : ℍ → ℂ) ∣[(4 : ℤ)] β = ⇑(FS c) := by
+          rw [hcoe_sum, hrow_slash c β hβ0, hβ'.1, mul_one]
+        simpa [Matrix.SpecialLinearGroup.mapGL, ← ModularForm.SL_slash] using key
+      holo' := (FS c).holo'
+      bdd_at_cusps' := fun hx => (FS c).bdd_at_cusps' (hcusp hx) }
+  have hlift : ∀ c, (⇑(lift c) : ℍ → ℂ) = S c := fun c => (hcoe_sum c)
+  let R : (ZMod M)ˣ → ModularForm (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) 4 :=
+    fun c => C • lift (c : ZMod M)
+  have hRcoe : ∀ c : (ZMod M)ˣ, (⇑(R c) : ℍ → ℂ) = C • S c := fun c => by
+    simp only [R]
+    rw [FunLike.coe_smul, hlift]
+  refine ⟨R, fun c => ?_, fun c γ hγ => ?_⟩
+  · refine eisRc_isIntegralQExp_of_apply_eq M hM c (R c) fun z => ?_
+    rw [hRcoe]
+    simp [S, hC]
+  · have hinv : (((CohCarrier.gamma0Units M ⟨γ, hγ⟩)⁻¹ : (ZMod M)ˣ) : ZMod M) =
+        ((γ 0 0 : ℤ) : ZMod M) := rfl
+    rw [hRcoe, hRcoe, ← ModularForm.SL_slash, ModularForm.SL_smul_slash, hrow_slash _ γ hγ,
+      Units.val_mul, hinv]
+
+end S_ModularForm_exists_gamma1_weight_four_isIntegralQExp_partialDivisorSum_slash_eq
+end P2MW
+export P2MW.S_ModularForm_exists_gamma1_weight_four_isIntegralQExp_partialDivisorSum_slash_eq
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups ModularForm in
+theorem ModularForm.exists_gamma1_weight_four_isIntegralQExp_partialDivisorSum_slash_eq
+    (M : ℕ) [NeZero M] (hM : 3 ≤ M) :
+    ∃ R : (ZMod M)ˣ → ModularForm (CongruenceSubgroup.Gamma1 M : Subgroup (GL (Fin 2) ℝ)) 4,
+      (∀ c : (ZMod M)ˣ, ModularCurve.IsIntegralQExp (R c)
+        (PowerSeries.mk fun n : ℕ => if n = 0 then 0 else
+          ∑ d ∈ n.divisors,
+            if ((n / d : ℕ) : ZMod M) = (c : ZMod M) ∨ ((n / d : ℕ) : ZMod M) = -(c : ZMod M)
+            then (d : ℤ) ^ 3 else 0)) ∧
+      (∀ (c : (ZMod M)ˣ) (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 M),
+        ((⇑(R c) : UpperHalfPlane → ℂ) ∣[(4 : ℤ)] (γ : GL (Fin 2) ℝ)) =
+          ⇑(R (c * (CohCarrier.gamma0Units M ⟨γ, hγ⟩)⁻¹))) :=
+  solution M hM
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card.lean
new file mode 100644
index 0000000000..99a5942d06
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card.lean
@@ -0,0 +1,105 @@
+/-
+Based on Prove2Me node ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card
+(e52e7754-dd59-54dc-8282-e638ce354cfe) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 938c3173-ee4f-5f3a-bbcb-7e51cd60b0e7
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.GroupTheory.DoubleCoset
+public import Mathlib.NumberTheory.ModularForms.Basic
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card_of_even
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card_of_odd
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Lower bound for dim M_k(Γ₁(M)), k≥ 3, M≥ 5
+
+Theorem statement: `ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card`
+(`e52e7754-dd59-54dc-8282-e638ce354cfe`), by Claude, 2026-09-05.
+
+Proof: submission `938c3173-ee4f-5f3a-bbcb-7e51cd60b0e7`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a nonzero natural number with $5 \le M$, and let $k$ be a natural number with $3 \le k$.
+The assertion is that there exist a natural number $d$ and a family $f : \mathrm{Fin}\,d \to
+M_k(\Gamma_1(M))$ of modular forms of weight $k$ (the integer $k$) for the congruence subgroup
+$\Gamma_1(M) \le \mathrm{SL}_2(\mathbb{Z})$ which is linearly independent over $\mathbb{C}$ and
+satisfies the numerical inequality
+$$(k-1)\,[\mathrm{SL}_2(\mathbb{Z}) : \Gamma_1(M)\cdot\{\pm 1\}] + 6\,c \;\le\; 12\,d,$$
+where the index is that of the subgroup of $\mathrm{SL}_2(\mathbb{Z})$ generated by $\Gamma_1(M)$
+together with $-1$ (the join of $\Gamma_1(M)$ with the cyclic group of integral powers of $-1$), and
+$c$ is the cardinality of the set of double cosets $\Gamma_1(M)\backslash
+\mathrm{SL}_2(\mathbb{Z})/\langle T, -1\rangle$, the subgroup on the right being generated by the
+translation matrix $T$ and by $-1$. All arithmetic is in $\mathbb{N}$, so $k-1$ is truncated
+subtraction; since $k \ge 3$ this is the ordinary difference. Since the forms are linearly
+independent, the conclusion is a lower bound for $\dim_{\mathbb{C}} M_k(\Gamma_1(M))$ and not an
+exact dimension formula.
+
+This is the existence half of the classical dimension formula for $M_k(\Gamma_1(M))$ in the range $k
+\ge 3$, $M \ge 5$, where $\Gamma_1(M)$ has no elliptic points, does not contain $-1$ and has only
+regular cusps; in that range $12\dim_{\mathbb{C}} M_k(\Gamma_1(M)) =
+(k-1)[\mathrm{SL}_2(\mathbb{Z}):\pm\Gamma_1(M)] + 6c$, the double-coset count $c$ being the number
+of cusps of $\Gamma_1(M)$, and the statement records the inequality $\le$ in the form needed later.
+It feeds
+[`ModularCurve.exists_isIntegralQExp_linearIndependent_complex_gamma1_dimFormula_le_card`]
+(thm.html#ModularCurve.exists_isIntegralQExp_linearIndependent_complex_gamma1_dimFormula_le_card),
+which refines the independent family to one with integral $q$-expansions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card
+
+open CongruenceSubgroup
+open scoped MatrixGroups ModularForm
+
+theorem solution
+    (M : ℕ) [NeZero M] (hM : 5 ≤ M) (k : ℕ) (hk : 3 ≤ k) :
+    ∃ (d : ℕ) (f : Fin d → ModularForm (Gamma1 M) (k : ℤ)), LinearIndependent ℂ f ∧
+      (k - 1) * (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index +
+          6 * Nat.card (DoubleCoset.Quotient (CongruenceSubgroup.Gamma1 M : Set SL(2, ℤ))
+            ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) : Set
+              SL(2, ℤ)))
+        ≤ 12 * d := by
+  rcases Nat.even_or_odd k with hke | hko
+  · exact ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_even M hM k hk hke
+  · exact ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_odd M hM k hk
+
+end S_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card
+end P2MW
+export P2MW.S_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open CongruenceSubgroup
+open scoped MatrixGroups ModularForm
+theorem ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card
+    (M : ℕ) [NeZero M] (hM : 5 ≤ M) (k : ℕ) (hk : 3 ≤ k) :
+    ∃ (d : ℕ) (f : Fin d → ModularForm (Gamma1 M) (k : ℤ)), LinearIndependent ℂ f ∧
+      (k - 1) * (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index +
+          6 * Nat.card (DoubleCoset.Quotient (CongruenceSubgroup.Gamma1 M : Set SL(2, ℤ))
+            ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) : Set
+              SL(2, ℤ)))
+        ≤ 12 * d :=
+  solution M hM k hk
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card_of_even.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card_of_even.lean
new file mode 100644
index 0000000000..64f472045b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card_of_even.lean
@@ -0,0 +1,339 @@
+/-
+Based on Prove2Me node ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_even
+(9935fe93-ca4a-50ab-99f5-609a2e925be9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 174702df-0d5d-58f7-98fb-fcc34a6e0712
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.GroupTheory.DoubleCoset
+public import Mathlib.NumberTheory.ModularForms.Basic
+
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.RingTheory.Flat.TorsionFree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_degree_add_one_sub_genusFF_of_isAlgClosed_of_isSeparable
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_divisor_forall_eq_weightFloor
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_six_mul_degree_eq_mul_finrank_of_forall_eq_weightFloor_of_ord_eq_three_two
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coeff_jqModC_neg_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_modularForm_gamma1_qExpansion_eq_mul_thetaL_pow_of_isIntegral
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_riemannRochSpace_laurentBaseChange_qExpFunctionFieldC_gamma1
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCurveOver_laurentBaseChange_qExpFunctionFieldC_gamma1
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_and_isIntegral_of_mem_riemannRochSpace_weightFloor
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_mem_intFormRatiosC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_theta_coeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Even-weight dimension lower bound for M_k(Γ₁(M))
+
+Theorem statement: `ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_even`
+(`9935fe93-ca4a-50ab-99f5-609a2e925be9`), by Claude, 2026-09-05.
+
+Proof: submission `174702df-0d5d-58f7-98fb-fcc34a6e0712`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a positive integer with $M \ge 5$, and let $k$ be a natural number with $3 \le k$ and $k$
+even. The assertion is that there exist a natural number $d$ and a family $f : \mathrm{Fin}\,d \to
+\mathrm{ModularForm}\,(\Gamma_1(M))\,k$ of modular forms of weight $k$ (the integer cast of $k$) for
+the congruence subgroup $\Gamma_1(M) \le \mathrm{SL}_2(\mathbb{Z})$, linearly independent over
+$\mathbb{C}$, such that
+$$(k-1)\,\big[\mathrm{SL}_2(\mathbb{Z}) : \Gamma_1(M)\,\sqcup\,\langle -1\rangle\big] \;+\;
+6\,\#\big(\Gamma_1(M)\backslash \mathrm{SL}_2(\mathbb{Z})/\langle T, -1\rangle\big) \;\le\; 12\,d
+.$$
+Here the first index is the index, as a natural number, of the subgroup of
+$\mathrm{SL}_2(\mathbb{Z})$ generated by $\Gamma_1(M)$ together with $-1$ (the join of $\Gamma_1(M)$
+with the subgroup of integer powers of $-1$); $k-1$ is truncated subtraction of naturals, harmless
+since $k \ge 3$; and the second term counts the double cosets of $\Gamma_1(M)$ and of the subgroup
+generated by the translation matrix $T$ and $-1$ in $\mathrm{SL}_2(\mathbb{Z})$, as the cardinality
+of the corresponding double coset quotient. Thus $\dim_{\mathbb{C}} M_k(\Gamma_1(M)) \ge d$ is
+bounded below by one twelfth of the displayed expression.
+
+This is the even-weight case of the classical lower bound on the dimension of the space of
+weight-$k$ modular forms on $\Gamma_1(M)$, the right-hand side of the classical dimension formula
+for $M \ge 5$ (no elliptic points, all cusps regular) being written in terms of the index of
+$\pm\Gamma_1(M)$ and the number of cusps presented as a double coset count. It is combined with the
+odd-weight case in
+[`ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card`]
+(thm.html#ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card),
+which supplies the supply of forms needed later in the argument.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card_of_even.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card_of_even
+
+
+open ModularCurve CongruenceSubgroup AlgebraicCurve UpperHalfPlane
+open scoped MatrixGroups ModularForm Manifold
+
+noncomputable section
+
+namespace DimLBEven
+
+theorem finite_doubleCoset_quotient {G : Type*} [Group G] (H K : Subgroup G) [H.FiniteIndex] :
+    Finite (DoubleCoset.Quotient (H : Set G) (K : Set G)) := by
+  classical
+  have : Finite (Quotient (QuotientGroup.rightRel H)) :=
+    Finite.of_equiv _ (QuotientGroup.quotientRightRelEquivQuotientLeftRel H).symm
+  refine Finite.of_surjective (fun q : Quotient (QuotientGroup.rightRel H) => Quotient.liftOn' q
+    (fun g => DoubleCoset.mk H K g) ?_) ?_
+  · intro a b hab
+    rw [QuotientGroup.rightRel_apply] at hab
+    apply DoubleCoset.mk_eq_of_doubleCoset_eq
+    refine DoubleCoset.doubleCoset_eq_of_mem ?_
+    refine DoubleCoset.mem_doubleCoset.mpr ⟨a * b⁻¹, by
+      simpa using H.inv_mem hab, 1, K.one_mem, by
+        group⟩
+  · intro q
+    induction q using Quotient.inductionOn' with
+    | h g => exact ⟨Quotient.mk'' g, rfl⟩
+
+theorem exists_coe_eq_jqModC_laurentBaseChange_qExpFunctionFieldC
+    (K : Type*) [Field K] [Algebra ℚ K]
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex] :
+    ∃ y : ↥(ModularCurve.laurentBaseChange K (ModularCurve.qExpFunctionFieldC ℚ Γ)),
+      (y : LaurentSeries K) = ModularCurve.jqModC K := by
+  have hmem : ModularCurve.jq ∈ ModularCurve.qExpFunctionFieldC ℚ Γ := by
+    rw [← ModularCurve.jqModC_rat]
+    exact ModularCurve.intFormRatiosC_subset ℚ Γ (ModularCurve.jqModC_mem_intFormRatiosC ℚ Γ)
+  refine ⟨⟨ModularCurve.coeffEmb K ModularCurve.jq, ModularCurve.coeffEmb_mem_laurentBaseChange K
+    hmem⟩, ?_⟩
+  change ModularCurve.coeffEmb K ModularCurve.jq = _
+  rw [← ModularCurve.jqModC_rat]
+  exact ModularCurve.map_jqModC (algebraMap ℚ K)
+
+variable (M : ℕ) [NeZero M]
+
+local notation "Γ₁ℝ" => ((CongruenceSubgroup.Gamma1 M : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2)
+  ℝ))
+
+omit [NeZero M] in
+theorem one_mem_strictPeriods_gamma1 : (1 : ℝ) ∈ (Γ₁ℝ).strictPeriods := by
+  simp
+
+omit [NeZero M] in
+theorem analyticAt_cuspFunction {k : ℤ} (g : ModularForm Γ₁ℝ k) :
+    AnalyticAt ℂ (cuspFunction 1 (⇑g : ℍ → ℂ)) 0 :=
+  ModularFormClass.analyticAt_cuspFunction_zero g one_pos (one_mem_strictPeriods_gamma1 M)
+
+omit [NeZero M] in
+theorem qExpansion_sum_smul {k : ℤ} {ι : Type*} (s : Finset ι) (c : ι → ℂ)
+    (f : ι → ModularForm Γ₁ℝ k) :
+    qExpansion 1 (⇑(∑ i ∈ s, c i • f i) : ℍ → ℂ) = ∑ i ∈ s, c i • qExpansion 1 (⇑(f i) : ℍ → ℂ)
+      := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => simp [qExpansion_zero]
+  | insert a s ha ih =>
+    have hcoe : (⇑(c a • f a + ∑ i ∈ s, c i • f i) : ℍ → ℂ) = (⇑(c a • f a) : ℍ → ℂ) + (⇑(∑ i ∈ s, c
+      i • f i) : ℍ → ℂ) :=
+      rfl
+    have hcoe2 : (⇑(c a • f a) : ℍ → ℂ) = (c a) • (⇑(f a) : ℍ → ℂ) := rfl
+    have h1 : qExpansion 1 (⇑(c a • f a) : ℍ → ℂ) = c a • qExpansion 1 (⇑(f a) : ℍ → ℂ) := by
+      rw [hcoe2]; exact qExpansion_smul (analyticAt_cuspFunction M (f a)) (c a)
+    rw [Finset.sum_insert ha, Finset.sum_insert ha, hcoe,
+      qExpansion_add (analyticAt_cuspFunction M (c a • f a)) (analyticAt_cuspFunction M (∑ i ∈ s, c
+      i • f i)), ih, h1]
+
+theorem eq_zero_of_qExpansion_eq_zero {k : ℤ} (g : ModularForm Γ₁ℝ k)
+    (h : qExpansion 1 (⇑g : ℍ → ℂ) = 0) :
+    g = 0 := by
+  apply DFunLike.ext
+  intro τ
+  have hs :=
+    hasSum_qExpansion one_pos (SlashInvariantFormClass.periodic_comp_ofComplex g
+      (one_mem_strictPeriods_gamma1 M))
+    g.holo' (ModularFormClass.bdd_at_infty g) τ
+  rw [h] at hs
+  simpa using hs.tsum_eq.symm
+
+theorem thetaL_jqModC_ne_zero : thetaL ℂ (jqModC ℂ) ≠ 0 := by
+  intro h
+  have := congrArg (fun s : LaurentSeries ℂ => s.coeff (-1)) h
+  simp only [thetaL_apply, ModularCurve.theta_coeff, coeff_jqModC_neg_one,
+    HahnSeries.coeff_zero] at this
+  norm_num at this
+
+theorem ofPowerSeries_smul (a : ℂ) (p : PowerSeries ℂ) :
+    HahnSeries.ofPowerSeries ℤ ℂ (a • p) = algebraMap ℂ (LaurentSeries ℂ) a *
+      HahnSeries.ofPowerSeries ℤ ℂ p := by
+  rw [PowerSeries.smul_eq_C_mul, map_mul]
+  congr 1
+
+end DimLBEven
+
+end
+
+open DimLBEven in
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+theorem solution
+    (M : ℕ) [NeZero M] (hM : 5 ≤ M) (k : ℕ) (hk : 3 ≤ k) (hke : Even k) :
+    ∃ (d : ℕ) (f : Fin d → ModularForm (Gamma1 M) (k : ℤ)), LinearIndependent ℂ f ∧
+      (k - 1) * (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index +
+          6 * Nat.card (DoubleCoset.Quotient (CongruenceSubgroup.Gamma1 M : Set SL(2, ℤ))
+            ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) : Set
+              SL(2, ℤ)))
+        ≤ 12 * d := by
+  classical
+  obtain ⟨m, rfl⟩ := hke
+  have hm1 : 1 ≤ m := by omega
+  have hfi : (CongruenceSubgroup.Gamma1 M).FiniteIndex := inferInstance
+  have hfi' : (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).FiniteIndex :=
+    Subgroup.finiteIndex_of_le le_sup_left
+  have hμpos : 0 < (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index :=
+    Nat.pos_of_ne_zero Subgroup.FiniteIndex.index_ne_zero
+  have hcpos : 1 ≤ Nat.card (DoubleCoset.Quotient (CongruenceSubgroup.Gamma1 M : Set SL(2, ℤ))
+      ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) : Set SL(2,
+        ℤ))) := by
+    have :=
+      finite_doubleCoset_quotient (CongruenceSubgroup.Gamma1 M) (Subgroup.zpowers ModularGroup.T ⊔
+        Subgroup.zpowers (-1) : Subgroup SL(2, ℤ))
+    have : Nonempty (DoubleCoset.Quotient (CongruenceSubgroup.Gamma1 M : Set SL(2, ℤ))
+      ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) : Set SL(2,
+        ℤ))) := ⟨DoubleCoset.mk _ _ 1⟩
+    exact Nat.card_pos
+  obtain ⟨y, hy⟩ :=
+    exists_coe_eq_jqModC_laurentBaseChange_qExpFunctionFieldC ℂ (CongruenceSubgroup.Gamma1 M)
+  have hT : ModularGroup.T ∈ CongruenceSubgroup.Gamma1 M := by
+    rw [CongruenceSubgroup.Gamma1_mem]; simp [ModularGroup.T]
+  obtain ⟨htr, hfin⟩ :=
+  transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC
+    ℂ (CongruenceSubgroup.Gamma1 M) hT y hy
+  have := hfin
+  have hfull :=
+    ModularCurve.finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index ℂ M y hy
+  have hsep : Algebra.IsSeparable ↥(IntermediateField.adjoin ℂ ({y} : Set ↥(laurentBaseChange ℂ
+    (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))))
+      ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))) := inferInstance
+  obtain ⟨h0, h1728⟩ :=
+    ModularCurve.ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1 ℂ M (by
+      omega) y hy
+  have : IsCurveOver ℂ ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))
+    :=
+    ModularCurve.isCurveOver_laurentBaseChange_qExpFunctionFieldC_gamma1 ℂ M
+  obtain ⟨D, hD⟩ := AlgebraicCurve.exists_divisor_forall_eq_weightFloor ℂ y m
+  have hdeg :=
+    AlgebraicCurve.six_mul_degree_eq_mul_finrank_of_forall_eq_weightFloor_of_ord_eq_three_two ℂ y
+      htr hfin h0 h1728 m D hD
+  rw [hfull] at hdeg
+  have hg :=
+    twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve_of_isAlgClosed
+      ℂ M hM
+  set μ : ℕ := (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index with hμdef
+  set cc : ℕ := Nat.card (DoubleCoset.Quotient (CongruenceSubgroup.Gamma1 M : Set SL(2, ℤ))
+      ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) : Set SL(2,
+        ℤ))) with hccdef
+  set gg : ℕ := genusFF ℂ ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1
+    M))) with hggdef
+  have hgZ : (12 : ℤ) * gg + 6 * cc = μ + 12 := by exact_mod_cast hg
+  have hμZ : (0 : ℤ) ≤ μ := by exact_mod_cast Nat.zero_le μ
+  have hmZ : (1 : ℤ) ≤ m := by exact_mod_cast hm1
+  have hcZ : (1 : ℤ) ≤ cc := by exact_mod_cast hcpos
+  have hRRhyp : 2 * (gg : ℤ) - 1 ≤ D.degree := by nlinarith [hdeg, hgZ, hμZ, hmZ, hcZ]
+  have hRR :=
+    AlgebraicCurve.ell_eq_degree_add_one_sub_genusFF_of_isAlgClosed_of_isSeparable ℂ y htr hfin hsep
+      D hRRhyp
+  have :=
+    ModularCurve.finiteDimensional_riemannRochSpace_laurentBaseChange_qExpFunctionFieldC_gamma1 ℂ M
+      D
+  set d : ℕ := Module.finrank ℂ ↥(riemannRochSpace D) with hddef
+  have hell : (ell D : ℤ) = d := rfl
+  let b := Module.finBasis ℂ ↥(riemannRochSpace D)
+  have hshape : ∀ i : Fin d, _ := fun i =>
+    ModularCurve.isIntegral_and_isIntegral_of_mem_riemannRochSpace_weightFloor ℂ
+      (laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))) y hy m D hD ((b i :
+        ↥(riemannRochSpace D)) : _) (b i).2
+  choose f hf using fun i : Fin d =>
+    ModularCurve.exists_modularForm_gamma1_qExpansion_eq_mul_thetaL_pow_of_isIntegral M m hm1
+      (((b i : ↥(riemannRochSpace D)) : ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ
+        (CongruenceSubgroup.Gamma1 M)))) : LaurentSeries ℂ)
+      ((b i : ↥(riemannRochSpace D)) : ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ
+        (CongruenceSubgroup.Gamma1 M)))).2
+      (hshape i).1 (hshape i).2
+  have hw : ((m + m : ℕ) : ℤ) = 2 * (m : ℤ) := by push_cast; ring
+  rw [hw]
+  refine ⟨d, f, ?_, ?_⟩
+  · rw [Fintype.linearIndependent_iff]
+    intro g hg0 i
+    have hq : qExpansion 1 (⇑(∑ i, g i • f i) : ℍ → ℂ) = 0 := by
+      rw [hg0]; exact qExpansion_zero 1
+    rw [qExpansion_sum_smul M] at hq
+    have hval : ∀ v : ↥(riemannRochSpace D), ((v : ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M)))) : LaurentSeries ℂ) =
+        (laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))).val
+          ((riemannRochSpace D).subtype v) := fun v => rfl
+    have h3 : (((∑ i, g i • b i : ↥(riemannRochSpace D)) : ↥(laurentBaseChange ℂ (qExpFunctionFieldC
+      ℚ (CongruenceSubgroup.Gamma1 M)))) : LaurentSeries ℂ) =
+        ∑ i, algebraMap ℂ (LaurentSeries ℂ) (g i) * (((b i : ↥(riemannRochSpace D)) :
+          ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))) :
+          LaurentSeries ℂ) := by
+      rw [Submodule.coe_sum, AddSubmonoidClass.coe_finsetSum]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [Submodule.coe_smul, IntermediateField.coe_smul]
+      first
+        | rw [Algebra.smul_def]
+    have hL : (((∑ i, g i • b i : ↥(riemannRochSpace D)) : ↥(laurentBaseChange ℂ (qExpFunctionFieldC
+      ℚ (CongruenceSubgroup.Gamma1 M)))) : LaurentSeries ℂ) * thetaL ℂ (jqModC ℂ) ^ m = 0 :=
+      by
+      have h1 := congrArg (HahnSeries.ofPowerSeries ℤ ℂ) hq
+      rw [map_sum, map_zero] at h1
+      have h2 : ∀ i, HahnSeries.ofPowerSeries ℤ ℂ (g i • qExpansion 1 (⇑(f i) : ℍ → ℂ)) =
+          (algebraMap ℂ (LaurentSeries ℂ) (g i) * (((b i : ↥(riemannRochSpace D)) :
+            ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))) :
+            LaurentSeries ℂ)) * thetaL ℂ (jqModC ℂ) ^ m := fun i => by
+        rw [ofPowerSeries_smul, hf i, mul_assoc]
+      simp only [h2] at h1
+      rw [← Finset.sum_mul] at h1
+      rw [h3]; exact h1
+    have hθ : thetaL ℂ (jqModC ℂ) ^ m ≠ 0 := pow_ne_zero _ thetaL_jqModC_ne_zero
+    have hsum := (mul_eq_zero.1 hL).resolve_right hθ
+    have hsumF : (∑ i, g i • b i) = 0 := by
+      apply Subtype.val_injective; apply Subtype.val_injective
+      rw [hsum]; rfl
+    exact Fintype.linearIndependent_iff.1 b.linearIndependent g hsumF i
+  · have h12 : (12 : ℤ) * d = 2 * m * μ - μ + 6 * cc := by
+      rw [← hell, hRR]; linarith [hdeg, hgZ]
+    zify [show 1 ≤ m + m by omega]
+    nlinarith [h12, hμZ]
+
+end S_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card_of_even
+end P2MW
+export P2MW.S_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card_of_even (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open CongruenceSubgroup
+open scoped MatrixGroups ModularForm
+theorem ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_even
+    (M : ℕ) [NeZero M] (hM : 5 ≤ M) (k : ℕ) (hk : 3 ≤ k) (hke : Even k) :
+    ∃ (d : ℕ) (f : Fin d → ModularForm (Gamma1 M) (k : ℤ)), LinearIndependent ℂ f ∧
+      (k - 1) * (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index +
+          6 * Nat.card (DoubleCoset.Quotient (CongruenceSubgroup.Gamma1 M : Set SL(2, ℤ))
+            ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) : Set
+              SL(2, ℤ)))
+        ≤ 12 * d :=
+  solution M hM k hk hke
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card_of_odd.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card_of_odd.lean
new file mode 100644
index 0000000000..9862789bfb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card_of_odd.lean
@@ -0,0 +1,443 @@
+/-
+Based on Prove2Me node ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_odd
+(502ed595-0a14-5d67-a40a-29590288ac71) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 32af4b01-b7fd-5b8e-81f4-0fc04c36576c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.GroupTheory.DoubleCoset
+public import Mathlib.NumberTheory.ModularForms.Basic
+
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.RingTheory.Flat.TorsionFree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_ell_eq_degree_add_one_sub_genusFF_of_isAlgClosed_of_isSeparable
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_exists_divisor_forall_eq_weightFloor
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_six_mul_degree_eq_mul_finrank_of_forall_eq_weightFloor_of_ord_eq_three_two
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_divisor_two_mul_eq_ord_add_weightFloor_one_laurentBaseChange_gamma1
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_modularForm_gamma1_qExpansion_eq_mul_pow_of_qExpansion_eq_sq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_exists_modularForm_gamma1_qExpansion_eq_mul_thetaL_pow_of_isIntegral
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finiteDimensional_riemannRochSpace_laurentBaseChange_qExpFunctionFieldC_gamma1
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isCurveOver_laurentBaseChange_qExpFunctionFieldC_gamma1
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_isIntegral_and_isIntegral_of_mem_riemannRochSpace_weightFloor
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_mem_intFormRatiosC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_gamma1_weightOne_ne_zero_and_mul_thetaL_eq_qExpansion_sq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Odd-weight dimension lower bound for M_k(Γ₁(M))
+
+Theorem statement: `ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_odd`
+(`502ed595-0a14-5d67-a40a-29590288ac71`), by Claude, 2026-09-05.
+
+Proof: submission `32af4b01-b7fd-5b8e-81f4-0fc04c36576c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a positive natural number with $M \ge 5$, and let $k$ be a natural number with $k \ge 3$
+and $k$ odd. Then there exist a natural number $d$ and a family $f : \mathrm{Fin}\,d \to$
+`ModularForm (Gamma1 M) (k : ℤ)` of modular forms of weight $k$ (the integer cast of $k$) for the
+congruence subgroup $\Gamma_1(M) \le \mathrm{SL}_2(\mathbb{Z})$, linearly independent over
+$\mathbb{C}$, such that
+$$(k-1)\,\bigl[\mathrm{SL}_2(\mathbb{Z}) : \Gamma_1(M)\vee\langle -1\rangle\bigr] \; + \;
+6\,\#\bigl(\Gamma_1(M) \backslash \mathrm{SL}_2(\mathbb{Z}) / \langle T, -1\rangle\bigr) \; \le \;
+12\,d,$$
+where the first index is that of the subgroup of $\mathrm{SL}_2(\mathbb{Z})$ generated by
+$\Gamma_1(M)$ together with the integer powers of $-1$, i.e. of $\pm\Gamma_1(M)$; the subtraction
+$k-1$ is in $\mathbb{N}$; and the second term counts the double cosets of $\Gamma_1(M)$ and of the
+subgroup generated by the translation matrix `ModularGroup.T` and $-1$, a finite cardinality taken
+via `Nat.card`. Thus the space of weight-$k$ forms on $\Gamma_1(M)$ contains at least
+$\bigl((k-1)[\mathrm{SL}_2(\mathbb{Z}):\pm\Gamma_1(M)] + 6\,\#\text{cusps}\bigr)/12$ linearly
+independent elements.
+
+This is the odd-weight case of the lower bound on $\dim_{\mathbb{C}} M_k(\Gamma_1(M))$ coming from
+the classical dimension formula, expressed as the existence of a linearly independent family rather
+than as an equality of dimensions; the double-coset count is the number of cusps of $X_1(M)$ and the
+index term is $[\mathrm{SL}_2(\mathbb{Z}):\pm\Gamma_1(M)]$, which by the genus formula for $X_1(M)$
+rewrites the bound as $\dim M_k \ge (k-1)(g-1) + kc/2$. Together with the even-weight case it feeds
+[`ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card`]
+(thm.html#ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card),
+the uniform dimension lower bound used to produce modular forms of prescribed weight and level.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card_of_odd.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 6400000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card_of_odd
+
+
+p2m_open "ModularCurve CongruenceSubgroup AlgebraicCurve~genus UpperHalfPlane"
+open scoped MatrixGroups ModularForm Manifold
+
+noncomputable section
+
+namespace DimLBOddE96
+
+theorem finite_doubleCoset_quotient {G : Type*} [Group G] (H K : Subgroup G) [H.FiniteIndex] :
+    Finite (DoubleCoset.Quotient (H : Set G) (K : Set G)) := by
+  classical
+  have : Finite (Quotient (QuotientGroup.rightRel H)) :=
+    Finite.of_equiv _ (QuotientGroup.quotientRightRelEquivQuotientLeftRel H).symm
+  refine Finite.of_surjective (fun q : Quotient (QuotientGroup.rightRel H) => Quotient.liftOn' q
+    (fun g => DoubleCoset.mk H K g) ?_) ?_
+  · intro a b hab
+    rw [QuotientGroup.rightRel_apply] at hab
+    apply DoubleCoset.mk_eq_of_doubleCoset_eq
+    refine DoubleCoset.doubleCoset_eq_of_mem ?_
+    refine DoubleCoset.mem_doubleCoset.mpr ⟨a * b⁻¹, by
+      simpa using H.inv_mem hab, 1, K.one_mem, by
+        group⟩
+  · intro q
+    induction q using Quotient.inductionOn' with
+    | h g => exact ⟨Quotient.mk'' g, rfl⟩
+
+theorem exists_coe_eq_jqModC (M : ℕ) [NeZero M] :
+    ∃ y : ↥(ModularCurve.laurentBaseChange ℂ (ModularCurve.qExpFunctionFieldC ℚ
+      (CongruenceSubgroup.Gamma1 M))),
+      (y : LaurentSeries ℂ) = ModularCurve.jqModC ℂ := by
+  have hmem : ModularCurve.jq ∈ ModularCurve.qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M) :=
+    by
+    rw [← ModularCurve.jqModC_rat]
+    exact ModularCurve.intFormRatiosC_subset ℚ _ (ModularCurve.jqModC_mem_intFormRatiosC ℚ _)
+  refine ⟨⟨ModularCurve.coeffEmb ℂ ModularCurve.jq, ModularCurve.coeffEmb_mem_laurentBaseChange ℂ
+    hmem⟩, ?_⟩
+  change ModularCurve.coeffEmb ℂ ModularCurve.jq = _
+  rw [← ModularCurve.jqModC_rat]
+  exact ModularCurve.map_jqModC (algebraMap ℚ ℂ)
+
+variable (M : ℕ) [NeZero M]
+
+local notation "Γ₁ℝ" => ((CongruenceSubgroup.Gamma1 M : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2)
+  ℝ))
+
+omit [NeZero M] in
+theorem one_mem_strictPeriods_gamma1 : (1 : ℝ) ∈ (Γ₁ℝ).strictPeriods := by
+  simp
+
+omit [NeZero M] in
+theorem analyticAt_cuspFunction {k : ℤ} (g : ModularForm Γ₁ℝ k) :
+    AnalyticAt ℂ (cuspFunction 1 (⇑g : ℍ → ℂ)) 0 :=
+  ModularFormClass.analyticAt_cuspFunction_zero g one_pos (one_mem_strictPeriods_gamma1 M)
+
+omit [NeZero M] in
+theorem qExpansion_sum_smul {k : ℤ} {ι : Type*} (s : Finset ι) (c : ι → ℂ)
+    (f : ι → ModularForm Γ₁ℝ k) :
+    qExpansion 1 (⇑(∑ i ∈ s, c i • f i) : ℍ → ℂ) = ∑ i ∈ s, c i • qExpansion 1 (⇑(f i) : ℍ → ℂ)
+      := by
+  classical
+  induction s using Finset.induction_on with
+  | empty => simp [qExpansion_zero]
+  | insert a s ha ih =>
+    have hcoe : (⇑(c a • f a + ∑ i ∈ s, c i • f i) : ℍ → ℂ) = (⇑(c a • f a) : ℍ → ℂ) + (⇑(∑ i ∈ s, c
+      i • f i) : ℍ → ℂ) :=
+      rfl
+    have hcoe2 : (⇑(c a • f a) : ℍ → ℂ) = (c a) • (⇑(f a) : ℍ → ℂ) := rfl
+    have h1 : qExpansion 1 (⇑(c a • f a) : ℍ → ℂ) = c a • qExpansion 1 (⇑(f a) : ℍ → ℂ) := by
+      rw [hcoe2]; exact qExpansion_smul (analyticAt_cuspFunction M (f a)) (c a)
+    rw [Finset.sum_insert ha, Finset.sum_insert ha, hcoe,
+      qExpansion_add (analyticAt_cuspFunction M (c a • f a)) (analyticAt_cuspFunction M (∑ i ∈ s, c
+      i • f i)), ih, h1]
+
+theorem eq_zero_of_qExpansion_eq_zero {k : ℤ} (g : ModularForm Γ₁ℝ k)
+    (h : qExpansion 1 (⇑g : ℍ → ℂ) = 0) :
+    g = 0 := by
+  apply DFunLike.ext
+  intro τ
+  have hs :=
+    hasSum_qExpansion one_pos (SlashInvariantFormClass.periodic_comp_ofComplex g
+      (one_mem_strictPeriods_gamma1 M))
+    g.holo' (ModularFormClass.bdd_at_infty g) τ
+  rw [h] at hs
+  simpa using hs.tsum_eq.symm
+
+theorem ofPowerSeries_smul (a : ℂ) (p : PowerSeries ℂ) :
+    HahnSeries.ofPowerSeries ℤ ℂ (a • p) = algebraMap ℂ (LaurentSeries ℂ) a *
+      HahnSeries.ofPowerSeries ℤ ℂ p := by
+  rw [PowerSeries.smul_eq_C_mul, map_mul]
+  congr 1
+
+end DimLBOddE96
+
+end
+
+open DimLBOddE96 in
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+theorem solution
+    (M : ℕ) [NeZero M] (hM : 5 ≤ M) (k : ℕ) (hk : 3 ≤ k) :
+    ∃ (d : ℕ) (f : Fin d → ModularForm (Gamma1 M) (k : ℤ)), LinearIndependent ℂ f ∧
+      (k - 1) * (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index +
+          6 * Nat.card (DoubleCoset.Quotient (CongruenceSubgroup.Gamma1 M : Set SL(2, ℤ))
+            ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) : Set
+              SL(2, ℤ)))
+        ≤ 12 * d := by
+  classical
+  have hk1 : 1 ≤ k := by omega
+  have hfi' : (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).FiniteIndex :=
+    Subgroup.finiteIndex_of_le le_sup_left
+  obtain ⟨y, hy⟩ := exists_coe_eq_jqModC M
+  have hT : ModularGroup.T ∈ CongruenceSubgroup.Gamma1 M := by
+    rw [CongruenceSubgroup.Gamma1_mem]; simp [ModularGroup.T]
+  obtain ⟨htr, hfin⟩ :=
+  transcendental_and_finiteDimensional_adjoin_laurentBaseChange_qExpFunctionFieldC_of_coe_eq_jqModC
+      ℂ (CongruenceSubgroup.Gamma1 M) hT y hy
+  have := hfin
+  have hfull :=
+    ModularCurve.finrank_adjoin_jqModC_laurentBaseChange_qExpFunctionFieldC_gamma1_eq_index ℂ M y hy
+  have hsep : Algebra.IsSeparable
+      ↥(IntermediateField.adjoin ℂ ({y} : Set ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ
+        (CongruenceSubgroup.Gamma1 M)))))
+      ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))) := inferInstance
+  obtain ⟨h0, h1728⟩ :=
+    ModularCurve.ord_eq_three_of_ord_pos_and_ord_sub_eq_two_laurentBaseChange_gamma1 ℂ M (by
+      omega) y hy
+  have : IsCurveOver ℂ ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))
+    :=
+    ModularCurve.isCurveOver_laurentBaseChange_qExpFunctionFieldC_gamma1 ℂ M
+  have hg :=
+    twelve_mul_genusFF_laurentBaseChange_gamma1_add_six_mul_natCard_doubleCoset_eq_index_add_twelve_of_isAlgClosed
+      ℂ M hM
+  obtain ⟨w, v0, hw0, hv0mem, hv0⟩ :=
+    ModularForm.exists_gamma1_weightOne_ne_zero_and_mul_thetaL_eq_qExpansion_sq M hM
+  let v : ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))) :=
+    ⟨v0, hv0mem⟩
+  obtain ⟨Dw, hDw⟩ :=
+    ModularCurve.exists_divisor_two_mul_eq_ord_add_weightFloor_one_laurentBaseChange_gamma1 M hM y
+      hy w hw0 v hv0
+  obtain ⟨Dk, hDk⟩ := AlgebraicCurve.exists_divisor_forall_eq_weightFloor ℂ y k
+  have hdegk :=
+    AlgebraicCurve.six_mul_degree_eq_mul_finrank_of_forall_eq_weightFloor_of_ord_eq_three_two
+    ℂ y htr hfin h0 h1728 k Dk hDk
+  rw [hfull] at hdegk
+  set W : LaurentSeries ℂ := HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 w) with hWdef
+  have hW : W ≠ 0 := by
+    intro h0
+    apply hw0
+    apply eq_zero_of_qExpansion_eq_zero M
+    exact HahnSeries.ofPowerSeries_injective (by rw [← hWdef, h0, map_zero])
+  have hvne : v ≠ 0 := by
+    intro h0
+    have : (v : LaurentSeries ℂ) = 0 := by rw [h0]; rfl
+    apply pow_ne_zero 2 hW
+    rw [← hv0]
+    change v0 * _ = 0
+    rw [show v0 = (v : LaurentSeries ℂ) from rfl, this, zero_mul]
+  obtain ⟨Pv, hPv, hdegPv⟩ := AlgebraicCurve.HasPrincipalDivisors.exists_divisor (K := ℂ) v hvne
+  obtain ⟨D1, hD1⟩ := AlgebraicCurve.exists_divisor_forall_eq_weightFloor ℂ y 1
+  have hdeg1 :=
+    AlgebraicCurve.six_mul_degree_eq_mul_finrank_of_forall_eq_weightFloor_of_ord_eq_three_two
+    ℂ y htr hfin h0 h1728 1 D1 hD1
+  rw [hfull] at hdeg1
+  have h2Dw : (2 : ℕ) • Dw = Pv + D1 := by
+    ext P
+    rw [Finsupp.smul_apply, Finsupp.add_apply, nsmul_eq_mul, hPv P, hD1 P]
+    push_cast
+    rw [hDw P]
+    ring_nf
+  have hdegDw : 2 * Dw.degree = D1.degree := by
+    have := congrArg AlgebraicCurve.Divisor.degree h2Dw
+    rw [map_nsmul, map_add, hdegPv, zero_add, nsmul_eq_mul] at this
+    exact_mod_cast this
+  have hdegw : 12 * (k • Dw).degree =
+      (k : ℤ) * (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index := by
+    rw [map_nsmul, nsmul_eq_mul]
+    have : (12 : ℤ) * Dw.degree = (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2,
+      ℤ))).index :=
+      by
+      have e := hdeg1
+      push_cast at e
+      linarith [hdegDw]
+    calc (12 : ℤ) * ((k : ℤ) * Dw.degree) = k * (12 * Dw.degree) := by ring
+      _ = _ := by rw [this]
+  set μ : ℕ := (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index with hμdef
+  set cc : ℕ := Nat.card (DoubleCoset.Quotient (CongruenceSubgroup.Gamma1 M : Set SL(2, ℤ))
+      ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) : Set SL(2,
+        ℤ))) with hccdef
+  set gg : ℕ := genusFF ℂ ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1
+    M))) with hggdef
+  have hgZ : (12 : ℤ) * gg + 6 * cc = μ + 12 := by exact_mod_cast hg
+  have hcpos : 1 ≤ cc := by
+    have := finite_doubleCoset_quotient (CongruenceSubgroup.Gamma1 M)
+      (Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ))
+    have : Nonempty (DoubleCoset.Quotient (CongruenceSubgroup.Gamma1 M : Set SL(2, ℤ))
+      ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) : Set SL(2,
+        ℤ))) :=
+      ⟨DoubleCoset.mk _ _ 1⟩
+    exact Nat.card_pos
+  have hcZ : (1 : ℤ) ≤ cc := by exact_mod_cast hcpos
+  have hkZ : (3 : ℤ) ≤ k := by exact_mod_cast hk
+  have hμZ : (0 : ℤ) ≤ μ := by exact_mod_cast Nat.zero_le μ
+  have hRRhyp : 2 * (gg : ℤ) - 1 ≤ (k • Dw).degree := by nlinarith [hdegw, hgZ, hμZ, hkZ, hcZ]
+  have hRR :=
+    AlgebraicCurve.ell_eq_degree_add_one_sub_genusFF_of_isAlgClosed_of_isSeparable ℂ y htr hfin hsep
+      (k • Dw) hRRhyp
+  have :=
+    ModularCurve.finiteDimensional_riemannRochSpace_laurentBaseChange_qExpFunctionFieldC_gamma1 ℂ M
+      (k • Dw)
+  set d : ℕ := Module.finrank ℂ ↥(riemannRochSpace (k • Dw)) with hddef
+  have hell : (ell (k • Dw) : ℤ) = d := rfl
+  let b := Module.finBasis ℂ ↥(riemannRochSpace (k • Dw))
+  have hEk : ∀ P : AlgebraicCurve.Place ℂ ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ
+    (CongruenceSubgroup.Gamma1 M))),
+      (k : ℤ) * D1 P = Dk P := by
+    intro P
+    rw [hD1 P, hDk P]
+    push_cast
+    have t1 : (k : ℤ) * (if 0 < P.ord y then (2 * 1 * P.ord y) / 3 else 0) =
+        (if 0 < P.ord y then (2 * (k : ℤ) * P.ord y) / 3 else 0) := by
+      split_ifs with hc
+      · rw [h0 P hc]; omega
+      · simp
+    have t2 : (k : ℤ) * (if 0 < P.ord (y - 1728) then (1 * P.ord (y - 1728)) / 2 else 0) =
+        (if 0 < P.ord (y - 1728) then ((k : ℤ) * P.ord (y - 1728)) / 2 else 0) := by
+      split_ifs with hc
+      · rw [h1728 P hc]; omega
+      · simp
+    have t3 : (k : ℤ) * (if P.ord y < 0 then 1 * P.ord y else 0) = (if P.ord y < 0 then (k : ℤ) *
+      P.ord y else 0) :=
+      by
+      split_ifs <;> simp
+    rw [← t1, ← t2, ← t3]
+    ring_nf
+  have hmemk : ∀ G : ↥(riemannRochSpace (k • Dw)),
+      ((G : ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))) ^ 2 * v ^
+        k)
+        ∈ riemannRochSpace Dk := by
+    intro G
+    rw [AlgebraicCurve.mem_riemannRochSpace_iff]
+    intro P
+    have hG := (AlgebraicCurve.mem_riemannRochSpace_iff.mp G.2) P
+    by_cases hG0 : (G : ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))))
+      = 0
+    · left; rw [hG0]; ring
+    · right
+      rcases hG with hG | hG
+      · exact absurd hG hG0
+      rw [P.ord_mul (pow_ne_zero _ hG0) (pow_ne_zero _ hvne), ← zpow_natCast, P.ord_zpow, ←
+        zpow_natCast,
+        P.ord_zpow]
+      rw [Finsupp.smul_apply, nsmul_eq_mul] at hG
+      have e2 : 2 * Dw P = P.ord v + D1 P := by
+        have := congrArg (fun D : AlgebraicCurve.Divisor ℂ _ => D P) h2Dw
+        simp only [Finsupp.smul_apply, Finsupp.add_apply, nsmul_eq_mul, Nat.cast_ofNat] at this
+        rw [hPv P] at this
+        exact_mod_cast this
+      have e3 := hEk P
+      push_cast
+      nlinarith [hG, e2, e3]
+  have hshape : ∀ i : Fin d, _ := fun i =>
+    ModularCurve.isIntegral_and_isIntegral_of_mem_riemannRochSpace_weightFloor ℂ
+      (laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M))) y hy k Dk hDk _
+        (hmemk (b i))
+  choose F₂ hF₂ using fun i : Fin d =>
+    ModularCurve.exists_modularForm_gamma1_qExpansion_eq_mul_thetaL_pow_of_isIntegral M k hk1
+      ((((b i : ↥(riemannRochSpace (k • Dw))) :
+          ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))) ^ 2 * v ^ k :
+          ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))) :
+            LaurentSeries ℂ)
+      (((b i : ↥(riemannRochSpace (k • Dw))) :
+          ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))) ^ 2 * v ^
+            k).2
+      (hshape i).1 (hshape i).2
+  have hsq : ∀ i : Fin d,
+      HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (F₂ i)) =
+        ((((b i : ↥(riemannRochSpace (k • Dw))) :
+            ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))) :
+              LaurentSeries ℂ) *
+          HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 w) ^ k) ^ 2 := by
+    intro i
+    rw [hF₂ i]
+    push_cast
+    rw [show ((v : ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))) :
+      LaurentSeries ℂ) = v0
+      from rfl, ← hWdef, mul_assoc, ← mul_pow, hv0]
+    ring
+  choose f hf using fun i : Fin d =>
+    ModularCurve.exists_modularForm_gamma1_qExpansion_eq_mul_pow_of_qExpansion_eq_sq M k w
+      ((((b i : ↥(riemannRochSpace (k • Dw))) :
+          ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))) :
+            LaurentSeries ℂ))
+      ((b i : ↥(riemannRochSpace (k • Dw))) :
+          ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))).2
+      (F₂ i) (hsq i)
+  refine ⟨d, f, ?_, ?_⟩
+  · rw [Fintype.linearIndependent_iff]
+    intro g hg0 i
+    have hq : qExpansion 1 (⇑(∑ i, g i • f i) : ℍ → ℂ) = 0 := by
+      rw [hg0]; exact qExpansion_zero 1
+    rw [qExpansion_sum_smul M] at hq
+    have h3 : (((∑ i, g i • b i : ↥(riemannRochSpace (k • Dw))) :
+          ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))) :
+            LaurentSeries ℂ) =
+        ∑ i, algebraMap ℂ (LaurentSeries ℂ) (g i) *
+          (((b i : ↥(riemannRochSpace (k • Dw))) :
+            ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))) :
+              LaurentSeries ℂ) := by
+      rw [Submodule.coe_sum, AddSubmonoidClass.coe_finsetSum]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [Submodule.coe_smul, IntermediateField.coe_smul]
+      first
+        | rw [Algebra.smul_def]
+    have hL : (((∑ i, g i • b i : ↥(riemannRochSpace (k • Dw))) :
+          ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))) :
+            LaurentSeries ℂ) * W ^ k = 0 := by
+      have h1 := congrArg (HahnSeries.ofPowerSeries ℤ ℂ) hq
+      rw [map_sum, map_zero] at h1
+      have h2 : ∀ i, HahnSeries.ofPowerSeries ℤ ℂ (g i • qExpansion 1 (⇑(f i) : ℍ → ℂ)) =
+          (algebraMap ℂ (LaurentSeries ℂ) (g i) *
+            (((b i : ↥(riemannRochSpace (k • Dw))) :
+              ↥(laurentBaseChange ℂ (qExpFunctionFieldC ℚ (CongruenceSubgroup.Gamma1 M)))) :
+                LaurentSeries ℂ)) * W ^ k :=
+        fun i => by rw [ofPowerSeries_smul, hf i, hWdef, mul_assoc]
+      simp only [h2] at h1
+      rw [← Finset.sum_mul] at h1
+      rw [h3]; exact h1
+    have hsum := (mul_eq_zero.1 hL).resolve_right (pow_ne_zero _ hW)
+    have hsumF : (∑ i, g i • b i) = 0 := by
+      apply Subtype.val_injective; apply Subtype.val_injective
+      rw [hsum]; rfl
+    exact Fintype.linearIndependent_iff.1 b.linearIndependent g hsumF i
+  · have h12 : (12 : ℤ) * d = k * μ - μ + 6 * cc := by
+      rw [← hell, hRR]; linarith [hdegw, hgZ]
+    zify [show 1 ≤ k by omega]
+    nlinarith [h12, hμZ]
+
+end S_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card_of_odd
+end P2MW
+export P2MW.S_ModularForm_exists_linearIndependent_gamma1_dimFormula_le_card_of_odd (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open CongruenceSubgroup
+open scoped MatrixGroups ModularForm
+theorem ModularForm.exists_linearIndependent_gamma1_dimFormula_le_card_of_odd
+    (M : ℕ) [NeZero M] (hM : 5 ≤ M) (k : ℕ) (hk : 3 ≤ k) :
+    ∃ (d : ℕ) (f : Fin d → ModularForm (Gamma1 M) (k : ℤ)), LinearIndependent ℂ f ∧
+      (k - 1) * (CongruenceSubgroup.Gamma1 M ⊔ Subgroup.zpowers (-1 : SL(2, ℤ))).index +
+          6 * Nat.card (DoubleCoset.Quotient (CongruenceSubgroup.Gamma1 M : Set SL(2, ℤ))
+            ((Subgroup.zpowers ModularGroup.T ⊔ Subgroup.zpowers (-1) : Subgroup SL(2, ℤ)) : Set
+              SL(2, ℤ)))
+        ≤ 12 * d :=
+  solution M hM k hk
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_modularForm_mul_eq_of_analyticOrderAt_le_of_finiteIndex.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_modularForm_mul_eq_of_analyticOrderAt_le_of_finiteIndex.lean
new file mode 100644
index 0000000000..d3cb1d1f29
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_modularForm_mul_eq_of_analyticOrderAt_le_of_finiteIndex.lean
@@ -0,0 +1,277 @@
+/-
+Based on Prove2Me node ModularForm.exists_modularForm_mul_eq_of_analyticOrderAt_le_of_finiteIndex
+(3ff49f55-d188-5a7b-a06c-2ec5d85adc00) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 74b731cd-3ffd-584a-9dd8-bca75c3fb9be
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.CStarAlgebra.Classes
+public import Mathlib.NumberTheory.ModularForms.Basic
+
+import Mathlib.Algebra.Order.Star.Real
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Division of modular forms on a finite-index subgroup
+
+Theorem statement: `ModularForm.exists_modularForm_mul_eq_of_analyticOrderAt_le_of_finiteIndex`
+(`3ff49f55-d188-5a7b-a06c-2ec5d85adc00`), by Claude, 2026-09-05.
+
+Proof: submission `74b731cd-3ffd-584a-9dd8-bca75c3fb9be`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of $\mathrm{SL}_2(\mathbb{Z})$ of finite index, let $a,b,c$ be integers
+with $b+c=a$, and regard $\Gamma$ as a subgroup of $\mathrm{GL}_2(\mathbb{R})$. Let $\Phi$ be a
+modular form of weight $a$ and $\Psi$ a nonzero modular form of weight $b$, both for this subgroup.
+Assume two conditions. First, at every point $\tau$ of the upper half-plane the analytic order of
+vanishing of $\Psi$, transported to a function on $\mathbb{C}$ via `UpperHalfPlane.ofComplex`, is at
+most that of $\Phi$ at the same point (orders being compared in $\mathbb{N}\cup\{\infty\}$). Second,
+for every $A \in \mathrm{SL}_2(\mathbb{Z})$ there is a real constant $C$ such that the weight-$a$
+slash $\Phi\mid_a A$ satisfies $\|(\Phi\mid_a A)(\tau)\| \le C\,\|(\Psi\mid_b A)(\tau)\|$ eventually
+along the filter $\mathrm{atImInfty}$, i.e. as $\operatorname{Im}\tau \to \infty$. The conclusion is
+that there exists a modular form $f$ of weight $c$ for the same subgroup with $f(\tau)\,\Psi(\tau) =
+\Phi(\tau)$ for all $\tau$ in the upper half-plane.
+
+This is the standard division lemma for modular forms: the pointwise order hypothesis makes the
+quotient $\Phi/\Psi$ holomorphic on the upper half-plane, it is automatically invariant of weight
+$c$, and the growth hypothesis at the translates of the cusp $i\infty$ makes it a modular form. It
+is stated here for an arbitrary finite-index subgroup of $\mathrm{SL}_2(\mathbb{Z})$, and is used in
+the construction of forms on $\Gamma_1(M)$ with prescribed $q$-expansions, in particular in the
+analytic weight-$2m$ criteria feeding the dimension estimates.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_exists_modularForm_mul_eq_of_analyticOrderAt_le_of_finiteIndex.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_exists_modularForm_mul_eq_of_analyticOrderAt_le_of_finiteIndex
+
+open UpperHalfPlane Filter
+open scoped MatrixGroups ModularForm Manifold Topology
+
+noncomputable section
+
+namespace ANa
+
+theorem local_factor {F G : ℂ → ℂ} {z : ℂ} (hF : AnalyticAt ℂ F z) (hG : AnalyticAt ℂ G z)
+    (hG0 : ¬ (∀ᶠ w in 𝓝 z, G w = 0)) (hle : analyticOrderAt G z ≤ analyticOrderAt F z) :
+    ∃ q : ℂ → ℂ, AnalyticAt ℂ q z ∧ ∀ᶠ w in 𝓝 z, F w = q w * G w := by
+  have hGtop : analyticOrderAt G z ≠ ⊤ := by rwa [ne_eq, analyticOrderAt_eq_top]
+  obtain ⟨n, hn⟩ := ENat.ne_top_iff_exists.mp hGtop
+  obtain ⟨u, hu, hu0, hGu⟩ := (hG.analyticOrderAt_eq_natCast).mp hn.symm
+  obtain ⟨v, hv, hFv⟩ : ∃ v : ℂ → ℂ, AnalyticAt ℂ v z ∧ ∀ᶠ w in 𝓝 z, F w = (w - z) ^ n • v w := by
+    have : (n : ℕ∞) ≤ analyticOrderAt F z := by rw [hn]; exact hle
+    exact (natCast_le_analyticOrderAt hF).mp this
+  refine ⟨fun w => v w / u w, hv.div hu hu0, ?_⟩
+  have hune : ∀ᶠ w in 𝓝 z, u w ≠ 0 := hu.continuousAt.eventually_ne hu0
+  filter_upwards [hGu, hFv, hune] with w hGw hFw huw
+  rw [hFw, hGw, smul_eq_mul, smul_eq_mul]
+  field_simp
+
+def quo (F G : ℂ → ℂ) (z : ℂ) : ℂ := limUnder (𝓝[≠] z) (fun w => F w / G w)
+
+theorem quo_eq {F G q : ℂ → ℂ} {z : ℂ} (hq : AnalyticAt ℂ q z) (hfac : ∀ᶠ w in 𝓝 z, F w = q w * G w)
+    (hG : ∀ᶠ w in 𝓝[≠] z, G w ≠ 0) : quo F G z = q z := by
+  apply Filter.Tendsto.limUnder_eq
+  have h1 : q =ᶠ[𝓝[≠] z] (fun w => F w / G w) := by
+    filter_upwards [hG, hfac.filter_mono nhdsWithin_le_nhds] with w hGw hw
+    rw [hw, mul_div_cancel_right₀ _ hGw]
+  exact (hq.continuousAt.tendsto.mono_left nhdsWithin_le_nhds).congr' h1
+
+theorem quo_analytic {F G : ℂ → ℂ} {U : Set ℂ} (hU : IsOpen U)
+    (hF : ∀ z ∈ U, AnalyticAt ℂ F z) (hG : ∀ z ∈ U, AnalyticAt ℂ G z)
+    (hG0 : ∀ z ∈ U, ¬ (∀ᶠ w in 𝓝 z, G w = 0))
+    (hle : ∀ z ∈ U, analyticOrderAt G z ≤ analyticOrderAt F z) (z : ℂ) (hz : z ∈ U) :
+    AnalyticAt ℂ (quo F G) z ∧ F z = quo F G z * G z := by
+  obtain ⟨q, hq, hfac⟩ := local_factor (hF z hz) (hG z hz) (hG0 z hz) (hle z hz)
+  have hGne : ∀ w ∈ U, ∀ᶠ v in 𝓝[≠] w, G v ≠ 0 := fun w hw =>
+    ((hG w hw).eventually_eq_zero_or_eventually_ne_zero).resolve_left (hG0 w hw)
+  have heq : ∀ᶠ w in 𝓝 z, quo F G w = q w := by
+    filter_upwards [hq.eventually_analyticAt, hfac.eventually_nhds, hU.mem_nhds hz] with w hqw hfw
+      hwU
+    exact quo_eq hqw hfw (hGne w hwU)
+  refine ⟨hq.congr (EventuallyEq.symm heq), ?_⟩
+  have h1 := heq.self_of_nhds
+  have h2 := hfac.self_of_nhds
+  rw [h1]
+  exact h2
+
+theorem analyticAt_of_mdiff {P : ℍ → ℂ} (hP : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) P) {z : ℂ} (hz : 0 < z.im) :
+    AnalyticAt ℂ (P ∘ ofComplex) z :=
+  (UpperHalfPlane.mdifferentiable_iff.mp hP).analyticAt
+    ((isOpen_lt continuous_const Complex.continuous_im).mem_nhds hz)
+
+theorem vanish {P : ℍ → ℂ} (hP : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) P) {W : Set ℍ} (hW : IsOpen W) {τ₀ : ℍ}
+    (hτ₀ : τ₀ ∈ W) (h0 : ∀ τ ∈ W, P τ = 0) : ∀ τ, P τ = 0 := by
+  have hPa : AnalyticOnNhd ℂ (P ∘ ofComplex) {z : ℂ | 0 < z.im} :=
+    fun z hz => analyticAt_of_mdiff hP hz
+  have hconn : IsPreconnected {z : ℂ | 0 < z.im} := (convex_halfSpace_im_gt 0).isPreconnected
+  have hW' : IsOpen (((↑) : ℍ → ℂ) '' W) := isOpenEmbedding_coe.isOpenMap _ hW
+  have hnhds : (P ∘ ofComplex) =ᶠ[𝓝 (τ₀ : ℂ)] 0 := by
+    filter_upwards [hW'.mem_nhds ⟨τ₀, hτ₀, rfl⟩]
+    rintro _ ⟨σ, hσ, rfl⟩
+    simp [ofComplex_apply, h0 σ hσ]
+  have hEq := hPa.eqOn_zero_of_preconnected_of_eventuallyEq_zero hconn τ₀.im_pos hnhds
+  intro τ
+  have := hEq τ.im_pos
+  simpa [ofComplex_apply] using this
+
+end ANa
+
+theorem solution (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex] {a b : ℤ}
+    (c : ℤ) (habc : b + c = a)
+    (Φ : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) a)
+    (Ψ : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) b) (hΨ : Ψ ≠ 0)
+    (hord : ∀ τ : UpperHalfPlane, analyticOrderAt ((Ψ : UpperHalfPlane → ℂ) ∘
+      UpperHalfPlane.ofComplex) (τ : ℂ) ≤
+      analyticOrderAt ((Φ : UpperHalfPlane → ℂ) ∘ UpperHalfPlane.ofComplex) (τ : ℂ))
+    (hcusp : ∀ A : Matrix.SpecialLinearGroup (Fin 2) ℤ, ∃ C : ℝ,
+      ∀ᶠ τ : UpperHalfPlane in UpperHalfPlane.atImInfty,
+        ‖((Φ : UpperHalfPlane → ℂ) ∣[a] (A : GL (Fin 2) ℝ)) τ‖ ≤ C * ‖((Ψ : UpperHalfPlane → ℂ) ∣[b]
+          (A : GL (Fin 2) ℝ)) τ‖) :
+    ∃ f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) c, ∀ τ : UpperHalfPlane, f τ * Ψ τ = Φ τ := by
+  classical
+  set Φ' : ℂ → ℂ := (Φ : ℍ → ℂ) ∘ ofComplex with hΦ'
+  set Ψ' : ℂ → ℂ := (Ψ : ℍ → ℂ) ∘ ofComplex with hΨ'
+  have hUo : IsOpen {z : ℂ | 0 < z.im} := isOpen_lt continuous_const Complex.continuous_im
+  have hUconn : IsPreconnected {z : ℂ | 0 < z.im} := (convex_halfSpace_im_gt 0).isPreconnected
+  have hΦa : ∀ z ∈ {z : ℂ | 0 < z.im}, AnalyticAt ℂ Φ' z :=
+    fun z hz => ANa.analyticAt_of_mdiff Φ.holo' hz
+  have hΨa : ∀ z ∈ {z : ℂ | 0 < z.im}, AnalyticAt ℂ Ψ' z :=
+    fun z hz => ANa.analyticAt_of_mdiff Ψ.holo' hz
+  have hΨ0 : ∀ z ∈ {z : ℂ | 0 < z.im}, ¬ (∀ᶠ w in 𝓝 z, Ψ' w = 0) := by
+    intro z hz hloc
+    apply hΨ
+    have hEq := AnalyticOnNhd.eqOn_zero_of_preconnected_of_eventuallyEq_zero
+      (f := Ψ') (U := {z : ℂ | 0 < z.im}) (fun w hw => hΨa w hw) hUconn hz hloc
+    refine DFunLike.ext Ψ 0 fun τ => ?_
+    have := hEq τ.im_pos
+    simpa [hΨ', ofComplex_apply] using this
+  have hle : ∀ z ∈ {z : ℂ | 0 < z.im}, analyticOrderAt Ψ' z ≤ analyticOrderAt Φ' z :=
+    fun z hz => hord ⟨z, hz⟩
+  have hF := ANa.quo_analytic hUo hΦa hΨa hΨ0 hle
+  set F : ℂ → ℂ := ANa.quo Φ' Ψ' with hFdef
+  let f : ℍ → ℂ := fun τ => F τ
+  have hfΨ : ∀ τ : ℍ, f τ * Ψ τ = Φ τ := fun τ => by
+    have := (hF τ τ.im_pos).2
+    simp only [hΦ', hΨ', Function.comp_apply, ofComplex_apply] at this
+    exact this.symm
+  have hfΨfun : f * (Ψ : ℍ → ℂ) = (Φ : ℍ → ℂ) := funext hfΨ
+  have hf_mdiff : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f := by
+    rw [UpperHalfPlane.mdifferentiable_iff]
+    have h1 : DifferentiableOn ℂ F {z : ℂ | 0 < z.im} := fun z hz =>
+      (hF z hz).1.differentiableAt.differentiableWithinAt
+    refine h1.congr fun z hz => ?_
+    exact congrArg F (by rw [ofComplex_apply_of_im_pos hz])
+  have hcb : c + b = a := by omega
+  have hf_slash : ∀ γ ∈ Subgroup.map (Matrix.SpecialLinearGroup.mapGL ℝ) Γ,
+      f ∣[c] γ = f := by
+    rintro _ ⟨γ₀, hγ₀, rfl⟩
+    have hmem : (Matrix.SpecialLinearGroup.mapGL ℝ γ₀) ∈
+        Subgroup.map (Matrix.SpecialLinearGroup.mapGL ℝ) Γ := ⟨γ₀, hγ₀, rfl⟩
+    change f ∣[c] γ₀ = f
+    have hΨinv : (Ψ : ℍ → ℂ) ∣[b] γ₀ = Ψ := SlashInvariantForm.slash_action_eqn Ψ _ hmem
+    have hΦinv : (Φ : ℍ → ℂ) ∣[a] γ₀ = Φ := SlashInvariantForm.slash_action_eqn Φ _ hmem
+    have hprod : (f ∣[c] γ₀) * (Ψ : ℍ → ℂ) = Φ := by
+      calc (f ∣[c] γ₀) * (Ψ : ℍ → ℂ) = (f ∣[c] γ₀) * ((Ψ : ℍ → ℂ) ∣[b] γ₀) := by rw [hΨinv]
+        _ = (f * (Ψ : ℍ → ℂ)) ∣[c + b] γ₀ := (ModularForm.mul_slash_SL2 c b γ₀ f Ψ).symm
+        _ = (Φ : ℍ → ℂ) ∣[a] γ₀ := by rw [hfΨfun, hcb]
+        _ = Φ := hΦinv
+    have hD : ∀ τ, (f ∣[c] γ₀ - f) τ * Ψ τ = 0 := fun τ => by
+      have h1 := congrFun hprod τ
+      simp only [Pi.mul_apply] at h1
+      rw [Pi.sub_apply, sub_mul, h1, hfΨ τ, sub_self]
+    have hDm : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (f ∣[c] γ₀ - f) := by
+      have := hf_mdiff.slash c (γ₀ : GL (Fin 2) ℝ)
+      exact this.sub hf_mdiff
+    by_contra hne
+    have hex : ∃ τ, (f ∣[c] γ₀ - f) τ ≠ 0 := by
+      by_contra hall
+      exact hne (sub_eq_zero.mp (funext fun τ => not_not.mp (not_exists.mp hall τ)))
+    obtain ⟨τ₀, hτ₀⟩ := hex
+    have hWo : IsOpen {τ : ℍ | (f ∣[c] γ₀ - f) τ ≠ 0} :=
+      isOpen_ne_fun hDm.continuous continuous_const
+    have hΨW : ∀ τ ∈ {τ : ℍ | (f ∣[c] γ₀ - f) τ ≠ 0}, Ψ τ = 0 := fun τ hτ =>
+      (mul_eq_zero.mp (hD τ)).resolve_left hτ
+    have hall := ANa.vanish Ψ.holo' hWo hτ₀ hΨW
+    exact hΨ (DFunLike.ext Ψ 0 hall)
+  have hcusp' : ∀ γ : SL(2, ℤ), IsBoundedAtImInfty (f ∣[c] γ) := by
+    intro γ
+    rw [UpperHalfPlane.isBoundedAtImInfty_iff]
+    obtain ⟨C, hC⟩ := hcusp γ
+    obtain ⟨T, hT⟩ := (atImInfty_mem _).mp hC
+    refine ⟨C, T + 1, fun τ hτ => ?_⟩
+    by_contra hlt'
+    have hlt : C < ‖(f ∣[c] γ) τ‖ := not_le.mp hlt'
+    set G : ℍ → ℂ := f ∣[c] γ with hG
+    set ΨA : ℍ → ℂ := (Ψ : ℍ → ℂ) ∣[b] γ with hΨA
+    have hprodA : G * ΨA = (Φ : ℍ → ℂ) ∣[a] γ := by
+      rw [hG, hΨA, ← ModularForm.mul_slash_SL2, hfΨfun, hcb]
+    have hΨA_mdiff : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) ΨA := by
+      have := Ψ.holo'.slash b (γ : GL (Fin 2) ℝ)
+      exact this
+    have hG_cont : Continuous G := (hf_mdiff.slash c (γ : GL (Fin 2) ℝ)).continuous
+    have hWo : IsOpen {σ : ℍ | C < ‖G σ‖ ∧ T < σ.im} :=
+      (isOpen_lt continuous_const hG_cont.norm).inter (isOpen_lt continuous_const
+        UpperHalfPlane.continuous_im)
+    have hΨAW : ∀ σ ∈ {σ : ℍ | C < ‖G σ‖ ∧ T < σ.im}, ΨA σ = 0 := by
+      rintro σ ⟨h1, h2⟩
+      have hb := hT σ h2.le
+      change ‖((Φ : ℍ → ℂ) ∣[a] γ) σ‖ ≤ C * ‖ΨA σ‖ at hb
+      rw [← hprodA, Pi.mul_apply, norm_mul] at hb
+      have hn : ‖ΨA σ‖ ≤ 0 := by nlinarith [norm_nonneg (ΨA σ), norm_nonneg (G σ)]
+      exact norm_eq_zero.mp (le_antisymm hn (norm_nonneg _))
+    have hΨA0 : ∀ σ, ΨA σ = 0 := ANa.vanish hΨA_mdiff hWo ⟨hlt, by linarith⟩ hΨAW
+    apply hΨ
+    refine DFunLike.ext Ψ 0 fun σ => ?_
+    have hback : (Ψ : ℍ → ℂ) = ΨA ∣[b] γ⁻¹ := by
+      rw [hΨA, ← SlashAction.slash_mul, mul_inv_cancel, SlashAction.slash_one]
+    have := congrFun hback σ
+    rw [this, ModularForm.SL_slash_apply, hΨA0, zero_mul]
+    rfl
+  refine ⟨{ toFun := f, slash_action_eq' := hf_slash, holo' := hf_mdiff,
+            bdd_at_cusps' := fun {cc} hc => ?_ }, hfΨ⟩
+  have hc' : IsCusp cc (Matrix.SpecialLinearGroup.mapGL ℝ).range :=
+    hc.mono (Subgroup.map_le_range _ _)
+  exact (OnePoint.isBoundedAt_iff_forall_SL2Z hc').mpr fun γ _ => hcusp' γ
+
+end
+end S_ModularForm_exists_modularForm_mul_eq_of_analyticOrderAt_le_of_finiteIndex
+end P2MW
+export P2MW.S_ModularForm_exists_modularForm_mul_eq_of_analyticOrderAt_le_of_finiteIndex (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups ModularForm
+theorem ModularForm.exists_modularForm_mul_eq_of_analyticOrderAt_le_of_finiteIndex
+    (Γ : Subgroup (Matrix.SpecialLinearGroup (Fin 2) ℤ)) [Γ.FiniteIndex] {a b : ℤ} (c : ℤ)
+    (habc : b + c = a)
+    (Φ : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) a)
+    (Ψ : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) b) (hΨ : Ψ ≠ 0)
+    (hord : ∀ τ : UpperHalfPlane, analyticOrderAt ((Ψ : UpperHalfPlane → ℂ) ∘
+      UpperHalfPlane.ofComplex) (τ : ℂ) ≤
+      analyticOrderAt ((Φ : UpperHalfPlane → ℂ) ∘ UpperHalfPlane.ofComplex) (τ : ℂ))
+    (hcusp : ∀ A : Matrix.SpecialLinearGroup (Fin 2) ℤ, ∃ C : ℝ,
+      ∀ᶠ τ : UpperHalfPlane in UpperHalfPlane.atImInfty,
+        ‖((Φ : UpperHalfPlane → ℂ) ∣[a] (A : GL (Fin 2) ℝ)) τ‖ ≤ C * ‖((Ψ : UpperHalfPlane → ℂ) ∣[b]
+          (A : GL (Fin 2) ℝ)) τ‖) :
+    ∃ f : ModularForm (Γ : Subgroup (GL (Fin 2) ℝ)) c, ∀ τ : UpperHalfPlane, f τ * Ψ τ = Φ τ :=
+  solution Γ c habc Φ Ψ hΨ hord hcusp
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_qExpansion_eq_aeval_mul_pow_levelOne.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_qExpansion_eq_aeval_mul_pow_levelOne.lean
new file mode 100644
index 0000000000..07d13ecb3d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_qExpansion_eq_aeval_mul_pow_levelOne.lean
@@ -0,0 +1,178 @@
+/-
+Based on Prove2Me node ModularForm.exists_qExpansion_eq_aeval_mul_pow_levelOne
+(dc26842e-3c37-5ba0-aaba-e83bcd87e7b3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 74ab1c20-fb2b-5f2f-88be-47b82744a75a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.LevelOne.DimensionFormula
+public import Mathlib.RingTheory.LaurentSeries
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Level one: weight 12N forms are P(j) Δ^N in ℂ((q))
+
+Theorem statement: `ModularForm.exists_qExpansion_eq_aeval_mul_pow_levelOne`
+(`dc26842e-3c37-5ba0-aaba-e83bcd87e7b3`), by Claude, 2026-09-05.
+
+Proof: submission `74ab1c20-fb2b-5f2f-88be-47b82744a75a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number and let $F$ be a modular form of weight $12N$ for the full modular group
+$\mathrm{SL}_2(\mathbb{Z})$ (an element of `ModularForm 𝒮ℒ (12 * (N : ℤ))`, the weight being the
+integer $12N$). The assertion is that there exists a polynomial $P \in \mathbb{C}[X]$ whose
+`natDegree` is at most $N$ such that, after the canonical embedding of power series into Laurent
+series $\mathbb{C}((q))$, the $q$-expansion of $F$ at width $1$ satisfies $$\widetilde{F} =
+P\bigl(\widetilde{E_4}^{\,3}/\widetilde{\Delta}\bigr)\cdot \widetilde{\Delta}^{\,N},$$ where
+$\widetilde{\,\cdot\,}$ denotes `qExpansion 1` of the underlying function on the upper half-plane,
+$E_4$ is the normalised weight-$4$ Eisenstein series `ModularForm.E₄`, $\Delta$ is
+`ModularForm.discriminant`, the quotient and the $N$-th power are formed in the field of Laurent
+series, and $P$ is evaluated at that quotient through the $\mathbb{C}$-algebra structure of
+$\mathbb{C}((q))$. Thus the bound on $P$ is on its natural degree, and the identity is an identity
+of Laurent series, not of modular forms.
+
+This is the level-one structure statement in $q$-expansion form: every weight-$12N$ form for
+$\mathrm{SL}_2(\mathbb{Z})$ is a polynomial of degree at most $N$ in $j = E_4^3/\Delta$ multiplied
+by $\Delta^N$. It is used in the integrality arguments for $q$-expansion coefficients on modular
+curves, for instance in the results establishing integrality of coefficient data over an algebra
+generated by $j$-series data and in the Hasse-polynomial descent step.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_exists_qExpansion_eq_aeval_mul_pow_levelOne.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_exists_qExpansion_eq_aeval_mul_pow_levelOne
+
+open UpperHalfPlane
+open scoped MatrixGroups
+
+theorem solution (N : ℕ) (F : ModularForm 𝒮ℒ (12 * (N : ℤ))) :
+    ∃ P : Polynomial ℂ, P.natDegree ≤ N ∧ ((qExpansion 1 (F : ℍ → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) = Polynomial.aeval (((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) : PowerSeries ℂ)
+      : LaurentSeries ℂ) ^ 3 / ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ)) P * ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) ^ N := by
+  induction N with
+  | zero =>
+    obtain ⟨c, hc⟩ := ModularFormClass.levelOne_weight_zero_const
+      (ModularForm.mcast (show (12 * ((0 : ℕ) : ℤ)) = 0 by simp) F)
+    rw [ModularForm.coe_mcast] at hc
+    have hconst : Function.const ℍ c = ⇑(c • (1 : ModularForm 𝒮ℒ 0)) := by
+      funext τ
+      simp
+    have hq : qExpansion 1 (F : ℍ → ℂ) = c • (1 : PowerSeries ℂ) := by
+      rw [hc, hconst, FunLike.coe_smul,
+        ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL,
+        ModularForm.qExpansion_one]
+    have hbridge : (algebraMap ℂ (LaurentSeries ℂ)) c
+        = ((PowerSeries.C c : PowerSeries ℂ) : LaurentSeries ℂ) := by
+      rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_eq]
+    refine ⟨Polynomial.C c, by simp, ?_⟩
+    rw [hq, PowerSeries.smul_eq_C_mul, mul_one, Polynomial.aeval_C, pow_zero, mul_one, hbridge]
+  | succ N ih =>
+    have hw : ((3 * (N + 1) : ℕ) : ℤ) * 4 = 12 * ((N + 1 : ℕ) : ℤ) := by push_cast; ring
+    set c : ℂ := (qExpansion 1 (F : ℍ → ℂ)).coeff 0 with hcdef
+    set Epow : ModularForm 𝒮ℒ (12 * ((N + 1 : ℕ) : ℤ)) :=
+      ModularForm.mcast hw (ModularForm.E₄.pow (3 * (N + 1))) with hEpow
+    set G : ModularForm 𝒮ℒ (12 * ((N + 1 : ℕ) : ℤ)) := F - c • Epow with hGdef
+    have hE40 : (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)).coeff 0 = 1 :=
+      EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) ⟨2, rfl⟩
+    have hGq : qExpansion 1 (G : ℍ → ℂ) = qExpansion 1 (F : ℍ → ℂ)
+        - PowerSeries.C c * (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) ^ (3 * (N + 1)) := by
+      rw [hGdef, FunLike.coe_sub, ModularForm.qExpansion_sub one_pos one_mem_strictPeriods_SL,
+        FunLike.coe_smul, ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL,
+        hEpow, ModularForm.qExpansion_mcast,
+        ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL, PowerSeries.smul_eq_C_mul]
+    have hpow0 : ((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) ^ (3 * (N + 1))).coeff 0 = 1 := by
+      rw [PowerSeries.coeff_zero_eq_constantCoeff_apply, map_pow,
+        ← PowerSeries.coeff_zero_eq_constantCoeff_apply, hE40, one_pow]
+    have hCc : (PowerSeries.C c
+        * (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) ^ (3 * (N + 1))).coeff 0 = c := by
+      rw [PowerSeries.coeff_zero_eq_constantCoeff_apply, map_mul, PowerSeries.constantCoeff_C,
+        ← PowerSeries.coeff_zero_eq_constantCoeff_apply, hpow0, mul_one]
+    have h0 : (qExpansion 1 (G : ℍ → ℂ)).coeff 0 = 0 := by
+      rw [hGq, map_sub, hCc, ← hcdef, sub_self]
+    have hkey := ModularForm.qExpansion_eq_qExpansion_discriminant_mul G h0
+    have hw2 : (12 * ((N + 1 : ℕ) : ℤ)) - 12 = 12 * ((N : ℕ) : ℤ) := by push_cast; ring
+    obtain ⟨P', hdeg', hP'⟩ :=
+      ih (ModularForm.mcast hw2 (CuspForm.discriminantEquiv (ModularForm.toCuspForm G h0)))
+    rw [ModularForm.coe_mcast] at hP'
+    refine ⟨Polynomial.C c * Polynomial.X ^ (N + 1) + P', ?_, ?_⟩
+    · exact Polynomial.natDegree_add_le_of_degree_le
+        (Polynomial.natDegree_C_mul_X_pow_le c (N + 1)) (hdeg'.trans (Nat.le_succ N))
+    · have hsum : qExpansion 1 (ModularForm.discriminant : ℍ → ℂ)
+          * qExpansion 1 (CuspForm.discriminantEquiv (ModularForm.toCuspForm G h0) : ℍ → ℂ)
+          + PowerSeries.C c * (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) ^ (3 * (N + 1))
+          = qExpansion 1 (F : ℍ → ℂ) := by
+        rw [← hkey]
+        exact eq_sub_iff_add_eq.mp hGq
+      have hL : ((qExpansion 1 (F : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+          = ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+            * ((qExpansion 1 (CuspForm.discriminantEquiv (ModularForm.toCuspForm G h0) : ℍ → ℂ) :
+                PowerSeries ℂ) : LaurentSeries ℂ)
+            + ((PowerSeries.C c : PowerSeries ℂ) : LaurentSeries ℂ)
+              * ((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+                ^ (3 * (N + 1)) := by
+        rw [← hsum]
+        push_cast
+        ring
+      rw [hL, hP']
+      have hΔ0 : qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) ≠ 0 := by
+        intro h
+        simpa [h] using ModularForm.discriminant_qExpansion_coeff_one
+      have hΔL0 : ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) :
+          LaurentSeries ℂ) ≠ 0 := by
+        rw [Ne, ← PowerSeries.coe_zero]
+        exact fun h => hΔ0 (HahnSeries.ofPowerSeries_injective h)
+      have hsplit : (((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) ^
+        3)
+            ^ (N + 1)
+          = (((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) ^ 3
+              / ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries
+                ℂ))
+              ^ (N + 1)
+            * ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+              ^ (N + 1) := by
+        rw [← mul_pow, div_mul_cancel₀ _ hΔL0]
+      have hbridge : (algebraMap ℂ (LaurentSeries ℂ)) c
+          = ((PowerSeries.C c : PowerSeries ℂ) : LaurentSeries ℂ) := by
+        rw [HahnSeries.algebraMap_apply', PowerSeries.algebraMap_eq]
+      rw [pow_mul, hsplit, map_add, map_mul, Polynomial.aeval_C, Polynomial.aeval_X_pow, hbridge]
+      ring
+
+end S_ModularForm_exists_qExpansion_eq_aeval_mul_pow_levelOne
+end P2MW
+export P2MW.S_ModularForm_exists_qExpansion_eq_aeval_mul_pow_levelOne (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane
+open scoped MatrixGroups
+theorem ModularForm.exists_qExpansion_eq_aeval_mul_pow_levelOne (N : ℕ)
+    (F : ModularForm 𝒮ℒ (12 * (N : ℤ))) :
+    ∃ P : Polynomial ℂ, P.natDegree ≤ N ∧ ((qExpansion 1 (F : ℍ → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) = Polynomial.aeval (((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) : PowerSeries ℂ)
+      : LaurentSeries ℂ) ^ 3 / ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ)) P * ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) ^ N :=
+  solution N F
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_rankinCohen_one_qExpansion_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_rankinCohen_one_qExpansion_eq.lean
new file mode 100644
index 0000000000..2676519b21
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_rankinCohen_one_qExpansion_eq.lean
@@ -0,0 +1,381 @@
+/-
+Based on Prove2Me node ModularForm.exists_rankinCohen_one_qExpansion_eq
+(e8850798-0c57-5fb7-a64a-92cd6acf63fa) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission def20c56-75fb-5edc-b936-a9e3eb5213ca
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Derivative
+
+import Mathlib.Analysis.Complex.Liouville
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_coe_qExpansion_normalizedDerivOfComplex
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# First Rankin–Cohen bracket of modular forms
+
+Theorem statement: `ModularForm.exists_rankinCohen_one_qExpansion_eq`
+(`e8850798-0c57-5fb7-a64a-92cd6acf63fa`), by Claude, 2026-09-05.
+
+Proof: submission `def20c56-75fb-5edc-b936-a9e3eb5213ca`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of finite index of $\mathrm{SL}_2(\mathbb{Z})$ such that the real number
+$1$ is a strict period of the image of $\Gamma$ in $\mathrm{GL}_2(\mathbb{R})$, i.e. $1$ lies in
+`strictPeriods` of that image, so that translation by $1$ is available and $q = e^{2\pi i \tau}$ is
+the correct local parameter at $\infty$. Let $k_1, k_2$ be integers, let $g$ be a modular form on
+$\Gamma$ of weight $k_1$ and $h$ a modular form on $\Gamma$ of weight $k_2$. The assertion is that
+there exists a modular form $B$ on $\Gamma$ of weight $k_1 + k_2 + 2$ with two properties. First,
+for every $\tau$ in the upper half-plane, $B(\tau) = k_1\, g(\tau)\, (Dh)(\tau) - k_2\, (Dg)(\tau)\,
+h(\tau)$, where $D$ denotes `Derivative.normalizedDerivOfComplex`, the normalised derivative $(2\pi
+i)^{-1}\, d/d\tau = q\, d/dq$. Second, the $q$-expansion of $B$ with respect to the period $1$
+equals, as a power series over $\mathbb{C}$, $$k_1 \cdot \tilde g \cdot \vartheta\tilde h - k_2
+\cdot (\vartheta \tilde g) \cdot \tilde h,$$ where $\tilde g, \tilde h$ are the $q$-expansions of
+$g$ and $h$ for the period $1$, the constants $k_1, k_2$ enter as the constant power series
+`PowerSeries.C` of their images in $\mathbb{C}$, and $\vartheta$ is the operator sending a power
+series with coefficients $a_n$ to the series with coefficients $n\,a_n$.
+
+This is the first Rankin–Cohen bracket $[g,h]_1 = k_1 g\,Dh - k_2\,(Dg)h$: the non-modular terms in
+the derivatives of $g$ and $h$ cancel in this combination, so the bracket is again a modular form,
+of weight raised by $2$, and its $q$-expansion is given by the coefficientwise operator $\vartheta =
+q\,d/dq$. It serves in the project as the source of weight-raising operations on $q$-expansions, and
+is used in the construction of differentials attached to cusp forms with integral $q$-expansions and
+in the study of mod $p$ modular forms and of the diamond operators on $q$-expansions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_exists_rankinCohen_one_qExpansion_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_exists_rankinCohen_one_qExpansion_eq
+
+open UpperHalfPlane Filter
+open scoped Real
+p2m_open_scoped "MatrixGroups Manifold Topology ModularForm \
+  P2MW.S_ModularForm_exists_rankinCohen_one_qExpansion_eq.ModularForm"
+
+noncomputable section
+
+namespace ModularForm
+p2m_export "ModularForm" "mk SL_slash_apply translate holo' add SL_slash ext bdd_at_cusps' mul"
+namespace RankinCohenOne
+p2m_open "ModularForm"
+
+theorem det_coe_SL (γ : SL(2, ℤ)) : ((γ : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ).det = 1 := by
+  have := Matrix.SpecialLinearGroup.det_coe (γ.map (Int.castRingHom ℝ))
+  simpa using this
+
+theorem denom_SL (γ : SL(2, ℤ)) (z : ℂ) :
+    denom (γ : GL (Fin 2) ℝ) z = ((γ 1 0 : ℤ) : ℂ) * z + ((γ 1 1 : ℤ) : ℂ) := by
+  simp [denom]
+
+theorem hasDerivAt_comp_smul {F : ℍ → ℂ} (hF : MDiff F) (γ : SL(2, ℤ)) (τ : ℍ) :
+    HasDerivAt (fun z : ℂ => F (γ • ofComplex z))
+      (deriv (F ∘ ofComplex) ↑(γ • τ) * (1 / denom (γ : GL (Fin 2) ℝ) τ ^ 2)) τ := by
+  have hs := (hasStrictDerivAt_smul (g := (γ : GL (Fin 2) ℝ))
+    (by rw [det_coe_SL]; exact one_pos) τ).hasDerivAt
+  have hF' : HasDerivAt (F ∘ ofComplex) (deriv (F ∘ ofComplex) ↑(γ • τ))
+      ↑((γ : GL (Fin 2) ℝ) • ofComplex (τ : ℂ)) := by
+    rw [ofComplex_apply]
+    exact (mdifferentiableAt_iff.mp (hF _)).hasDerivAt
+  have := hF'.comp (τ : ℂ) hs
+  convert this using 1 <;> first
+    | (ext z; simp only [Function.comp_apply, ofComplex_apply]; done)
+    | (ext z; simp only [Function.comp_apply, ofComplex_apply]; rfl)
+    | (rw [det_coe_SL]; push_cast; ring)
+
+theorem hasDerivAt_denom_zpow (k : ℤ) (γ : SL(2, ℤ)) (τ : ℍ) :
+    HasDerivAt (fun z : ℂ => denom (γ : GL (Fin 2) ℝ) z ^ (-k))
+      ((-k : ℂ) * denom (γ : GL (Fin 2) ℝ) τ ^ (-k - 1) * ((γ 1 0 : ℤ) : ℂ)) τ := by
+  have hden : denom (γ : GL (Fin 2) ℝ) τ ≠ 0 := denom_ne_zero _ _
+  have hlin : HasDerivAt (fun z : ℂ => denom (γ : GL (Fin 2) ℝ) z) ((γ 1 0 : ℤ) : ℂ) τ := by
+    simp_rw [denom_SL]
+    simpa using ((hasDerivAt_id (τ : ℂ)).const_mul ((γ 1 0 : ℤ) : ℂ)).add_const ((γ 1 1 : ℤ) : ℂ)
+  have hz := (hasDerivAt_zpow (-k) (denom (γ : GL (Fin 2) ℝ) τ) (Or.inl hden)).comp (τ : ℂ) hlin
+  push_cast at hz
+  exact hz
+
+theorem D_slash {F : ℍ → ℂ} (hF : MDiff F) (k : ℤ) (γ : SL(2, ℤ)) (τ : ℍ) :
+    Derivative.normalizedDerivOfComplex (F ∣[k] γ) τ =
+      (Derivative.normalizedDerivOfComplex F (γ • τ) * (denom (γ : GL (Fin 2) ℝ) τ)⁻¹ ^ 2
+        - k * (2 * π * Complex.I)⁻¹ * ((γ 1 0 : ℤ) : ℂ) * (denom (γ : GL (Fin 2) ℝ) τ)⁻¹ * F (γ •
+          τ))
+        * denom (γ : GL (Fin 2) ℝ) τ ^ (-k) := by
+  have hden : denom (γ : GL (Fin 2) ℝ) τ ≠ 0 := denom_ne_zero _ _
+  have hprod := (hasDerivAt_comp_smul hF γ τ).mul (hasDerivAt_denom_zpow k γ τ)
+  have hev : ((F ∣[k] γ) ∘ ofComplex) =ᶠ[𝓝 (τ : ℂ)]
+      fun z : ℂ => F (γ • ofComplex z) * denom (γ : GL (Fin 2) ℝ) z ^ (-k) := by
+    filter_upwards [isOpen_upperHalfPlaneSet.mem_nhds τ.2] with z hz
+    rw [Function.comp_apply, SL_slash_apply, ofComplex_apply_of_im_pos hz]
+  have hD := hprod.congr_of_eventuallyEq hev
+  simp only [Derivative.normalizedDerivOfComplex]
+  rw [hD.deriv]
+  have e1 : denom (γ : GL (Fin 2) ℝ) τ ^ (-k - 1) =
+      denom (γ : GL (Fin 2) ℝ) τ ^ (-k) * (denom (γ : GL (Fin 2) ℝ) τ)⁻¹ := by
+    rw [sub_eq_add_neg, zpow_add₀ hden, zpow_neg_one]
+  rw [e1]
+  simp only [ofComplex_apply]
+  field_simp
+  ring
+
+end ModularForm.RankinCohenOne
+
+namespace ModularForm
+p2m_export "ModularForm" "mk SL_slash_apply translate holo' add SL_slash ext bdd_at_cusps' mul"
+namespace RankinCohenOne
+p2m_open "ModularForm"
+
+local notation "D" => Derivative.normalizedDerivOfComplex
+
+def bracket (k₁ k₂ : ℤ) (g h : ℍ → ℂ) : ℍ → ℂ :=
+  (k₁ : ℂ) • (g * D h) - (k₂ : ℂ) • (D g * h)
+
+theorem bracket_apply (k₁ k₂ : ℤ) (g h : ℍ → ℂ) (τ : ℍ) :
+    bracket k₁ k₂ g h τ = k₁ * (g τ * D h τ) - k₂ * (D g τ * h τ) := rfl
+
+theorem bracket_slash {g h : ℍ → ℂ} (hg : MDiff g) (hh : MDiff h) (k₁ k₂ : ℤ)
+    (γ : SL(2, ℤ)) :
+    bracket k₁ k₂ (g ∣[k₁] γ) (h ∣[k₂] γ) = (bracket k₁ k₂ g h) ∣[k₁ + k₂ + 2] γ := by
+  funext τ
+  have hden : denom (γ : GL (Fin 2) ℝ) τ ≠ 0 := denom_ne_zero _ _
+  rw [SL_slash_apply, bracket_apply, bracket_apply, D_slash hg, D_slash hh, SL_slash_apply,
+    SL_slash_apply]
+  have e : denom (γ : GL (Fin 2) ℝ) τ ^ (-(k₁ + k₂ + 2)) =
+      denom (γ : GL (Fin 2) ℝ) τ ^ (-k₁) * denom (γ : GL (Fin 2) ℝ) τ ^ (-k₂) *
+        (denom (γ : GL (Fin 2) ℝ) τ)⁻¹ ^ 2 := by
+    rw [show (-(k₁ + k₂ + 2) : ℤ) = -k₁ + -k₂ + -2 by ring, zpow_add₀ hden, zpow_add₀ hden,
+      zpow_neg _ 2, zpow_ofNat, inv_pow]
+  rw [e]
+  ring
+
+theorem isBoundedAtImInfty_D {F : ℍ → ℂ} (hF : MDiff F) (hb : IsBoundedAtImInfty F) :
+    IsBoundedAtImInfty (D F) := by
+  rw [isBoundedAtImInfty_iff] at hb ⊢
+  obtain ⟨M, A, hMA⟩ := hb
+  refine ⟨‖(2 * π * Complex.I)⁻¹‖ * M, max A 0 + 2, fun z hz => ?_⟩
+  have hzA : max A 0 + 2 ≤ (z : ℂ).im := by rwa [coe_im]
+  have hdisc : ∀ w : ℂ, dist w z ≤ 1 → 0 < w.im ∧ A ≤ w.im := by
+    intro w hw
+    have h1 : |(w - z).im| ≤ ‖w - (z : ℂ)‖ := Complex.abs_im_le_norm _
+    rw [dist_eq_norm] at hw
+    have h2 := (abs_le.mp (h1.trans hw)).1
+    simp only [Complex.sub_im] at h2
+    constructor
+    · linarith [le_max_right A 0]
+    · linarith [le_max_left A 0]
+  have key : ‖deriv (F ∘ ofComplex) z‖ ≤ M / 1 := by
+    apply Complex.norm_deriv_le_of_forall_mem_sphere_norm_le one_pos
+    · apply DifferentiableOn.diffContOnCl
+      refine (UpperHalfPlane.mdifferentiable_iff.mp hF).mono ?_
+      rw [closure_ball _ one_ne_zero]
+      intro w hw
+      exact (hdisc w (Metric.mem_closedBall.mp hw)).1
+    · intro w hw
+      have hw' : dist w z ≤ 1 := (Metric.mem_sphere.mp hw).le
+      obtain ⟨hwpos, hwA⟩ := hdisc w hw'
+      have := hMA ⟨w, hwpos⟩ hwA
+      simpa [Function.comp_apply, ofComplex_apply_of_im_pos hwpos] using this
+  rw [div_one] at key
+  simp only [Derivative.normalizedDerivOfComplex, norm_mul]
+  gcongr
+
+theorem periodic_D {F : ℍ → ℂ} (hper : Function.Periodic (F ∘ ofComplex) 1) :
+    Function.Periodic (D F ∘ ofComplex) 1 := by
+  intro w
+  simp only [Function.comp_apply, Derivative.normalizedDerivOfComplex]
+  congr 1
+  by_cases hw : 0 < w.im
+  · have hw' : 0 < (w + 1).im := by simpa using hw
+    rw [ofComplex_apply_of_im_pos hw, ofComplex_apply_of_im_pos hw']
+    change deriv (F ∘ ofComplex) (w + 1) = deriv (F ∘ ofComplex) w
+    have hfun : (F ∘ ofComplex) = fun x => (F ∘ ofComplex) (x + 1) := (funext hper).symm
+    conv_rhs => rw [hfun]
+    rw [deriv_comp_add_const]
+  · have hw' : (w + 1).im ≤ 0 := by simpa using not_lt.mp hw
+    rw [ofComplex_apply_eq_of_im_nonpos hw' (not_lt.mp hw)]
+
+theorem mdifferentiable_bracket {g h : ℍ → ℂ} (hg : MDiff g) (hh : MDiff h) (k₁ k₂ : ℤ) :
+    MDiff (bracket k₁ k₂ g h) :=
+  ((hg.mul (Derivative.normalizedDerivOfComplex_mdifferentiable hh)).const_smul _).sub
+    (((Derivative.normalizedDerivOfComplex_mdifferentiable hg).mul hh).const_smul _)
+
+theorem isBoundedAtImInfty_bracket {g h : ℍ → ℂ} (hg : MDiff g) (hh : MDiff h)
+    (hgb : IsBoundedAtImInfty g) (hhb : IsBoundedAtImInfty h) (k₁ k₂ : ℤ) :
+    IsBoundedAtImInfty (bracket k₁ k₂ g h) := by
+  rw [bracket, sub_eq_add_neg]
+  exact ((hgb.mul (isBoundedAtImInfty_D hh hhb)).smul _).add
+    (((isBoundedAtImInfty_D hg hgb).mul hhb).smul _).neg
+
+theorem periodic_bracket {g h : ℍ → ℂ} (hg : Function.Periodic (g ∘ ofComplex) 1)
+    (hh : Function.Periodic (h ∘ ofComplex) 1) (k₁ k₂ : ℤ) :
+    Function.Periodic (bracket k₁ k₂ g h ∘ ofComplex) 1 := by
+  intro w
+  have h1 := hg w
+  have h2 := hh w
+  have h3 := periodic_D hg w
+  have h4 := periodic_D hh w
+  simp only [Function.comp_apply] at h1 h2 h3 h4 ⊢
+  rw [bracket_apply, bracket_apply, h1, h2, h3, h4]
+
+variable {Γ : Subgroup SL(2, ℤ)} {k₁ k₂ : ℤ}
+
+def rankinCohen [Γ.FiniteIndex] (g : ModularForm Γ k₁) (h : ModularForm Γ k₂) :
+    ModularForm Γ (k₁ + k₂ + 2) where
+  toFun := bracket k₁ k₂ g h
+  slash_action_eq' A hA := by
+    obtain ⟨γ, hγ, rfl⟩ := Subgroup.mem_map.mp hA
+    have hγ' : (γ : GL (Fin 2) ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)) := Subgroup.mem_map_of_mem _ hγ
+    change bracket k₁ k₂ g h ∣[k₁ + k₂ + 2] (γ : GL (Fin 2) ℝ) = _
+    rw [← SL_slash, ← bracket_slash (ModularFormClass.holo g) (ModularFormClass.holo h), SL_slash,
+      SL_slash, SlashInvariantForm.slash_action_eqn g _ hγ',
+      SlashInvariantForm.slash_action_eqn h _ hγ']
+  holo' := mdifferentiable_bracket (ModularFormClass.holo g) (ModularFormClass.holo h) k₁ k₂
+  bdd_at_cusps' {c} hc := by
+    have hc' : IsCusp c (Matrix.SpecialLinearGroup.mapGL ℝ : SL(2, ℤ) →* _).range :=
+      (Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z _).mp hc
+    rw [OnePoint.isBoundedAt_iff_forall_SL2Z hc']
+    intro γ _
+    rw [← bracket_slash (ModularFormClass.holo g) (ModularFormClass.holo h)]
+    exact isBoundedAtImInfty_bracket ((ModularFormClass.holo g).slash k₁ (γ : GL (Fin 2) ℝ))
+      ((ModularFormClass.holo h).slash k₂ (γ : GL (Fin 2) ℝ))
+      (ModularFormClass.bdd_at_infty_slash g γ) (ModularFormClass.bdd_at_infty_slash h γ) k₁ k₂
+
+theorem rankinCohen_apply [Γ.FiniteIndex] (g : ModularForm Γ k₁) (h : ModularForm Γ k₂) (τ : ℍ) :
+    rankinCohen g h τ = k₁ * g τ * D h τ - k₂ * D g τ * h τ := by
+  change bracket k₁ k₂ g h τ = _
+  rw [bracket_apply]; ring
+
+theorem coe_rankinCohen [Γ.FiniteIndex] (g : ModularForm Γ k₁) (h : ModularForm Γ k₂) :
+    (rankinCohen g h : ℍ → ℂ) = bracket k₁ k₂ g h := rfl
+
+open ModularCurve in
+theorem coeff_nat_thetaL_ofPowerSeries (φ : PowerSeries ℂ) (n : ℕ) :
+    (thetaL ℂ (HahnSeries.ofPowerSeries ℤ ℂ φ)).coeff (n : ℤ) = (n : ℂ) * PowerSeries.coeff n φ
+      := by
+  rw [thetaL_apply, show ((n : ℤ)) = ((n : ℤ) - 1) + 1 by ring, HahnSeries.coeff_single_mul_add,
+    one_mul, LaurentSeries.derivative_apply, LaurentSeries.hasseDeriv_coeff, Nat.cast_one,
+    sub_add_cancel, Ring.choose_one_right, HahnSeries.ofPowerSeries_apply_coeff, zsmul_eq_mul,
+    Int.cast_natCast]
+
+theorem qExpansion_D {F : ℍ → ℂ} (hper : Function.Periodic (F ∘ ofComplex) 1) (hhol : MDiff F)
+    (hbdd : IsBoundedAtImInfty F) :
+    qExpansion 1 (D F) =
+      PowerSeries.mk fun n : ℕ => (n : ℂ) * (qExpansion 1 F).coeff n := by
+  ext n
+  have h := congrArg (fun x : LaurentSeries ℂ => x.coeff (n : ℤ))
+    (ModularCurve.coe_qExpansion_normalizedDerivOfComplex F hper hhol hbdd)
+  beta_reduce at h
+  rw [HahnSeries.ofPowerSeries_apply_coeff, coeff_nat_thetaL_ofPowerSeries] at h
+  rw [h, PowerSeries.coeff_mk]
+
+section
+
+variable (h1 : (1 : ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)).strictPeriods)
+include h1
+
+theorem periodic_coe {k : ℤ} (f : ModularForm Γ k) : Function.Periodic (⇑f ∘ ofComplex) 1 := by
+  simpa using SlashInvariantFormClass.periodic_comp_ofComplex f h1
+
+theorem analyticAt_cuspFunction {k : ℤ} (f : ModularForm Γ k) :
+    AnalyticAt ℂ (cuspFunction 1 (f : ℍ → ℂ)) 0 :=
+  ModularFormClass.analyticAt_cuspFunction_zero f one_pos h1
+
+theorem analyticAt_cuspFunction_D [Γ.FiniteIndex] {k : ℤ} (f : ModularForm Γ k) :
+    AnalyticAt ℂ (cuspFunction 1 (D (f : ℍ → ℂ))) 0 := by
+  have := analyticAt_cuspFunction_zero (h := 1) (f := D (f : ℍ → ℂ)) one_pos
+    (by simpa using periodic_D (periodic_coe h1 f))
+    (Derivative.normalizedDerivOfComplex_mdifferentiable (ModularFormClass.holo f))
+    (isBoundedAtImInfty_D (ModularFormClass.holo f) (ModularFormClass.bdd_at_infty f))
+  exact this
+
+theorem qExpansion_D_coe [Γ.FiniteIndex] {k : ℤ} (f : ModularForm Γ k) :
+    qExpansion 1 (D (f : ℍ → ℂ)) =
+      PowerSeries.mk fun n : ℕ => (n : ℂ) * (qExpansion 1 (f : ℍ → ℂ)).coeff n :=
+  qExpansion_D (by simpa using periodic_coe h1 f) (ModularFormClass.holo f)
+    (ModularFormClass.bdd_at_infty f)
+
+theorem qExpansion_rankinCohen [Γ.FiniteIndex] (g : ModularForm Γ k₁) (h : ModularForm Γ k₂) :
+    qExpansion 1 (rankinCohen g h : ℍ → ℂ) =
+      PowerSeries.C (k₁ : ℂ) * qExpansion 1 (g : ℍ → ℂ) *
+          PowerSeries.mk (fun n : ℕ => (n : ℂ) * (qExpansion 1 (h : ℍ → ℂ)).coeff n)
+        - PowerSeries.C (k₂ : ℂ) *
+          PowerSeries.mk (fun n : ℕ => (n : ℂ) * (qExpansion 1 (g : ℍ → ℂ)).coeff n) *
+            qExpansion 1 (h : ℍ → ℂ) := by
+  have ag := analyticAt_cuspFunction h1 g
+  have ah := analyticAt_cuspFunction h1 h
+  have aDg := analyticAt_cuspFunction_D h1 g
+  have aDh := analyticAt_cuspFunction_D h1 h
+  have a1 : AnalyticAt ℂ (cuspFunction 1 ((g : ℍ → ℂ) * D (h : ℍ → ℂ))) 0 := by
+    rw [cuspFunction_mul ag.continuousAt aDh.continuousAt]; exact ag.mul aDh
+  have a2 : AnalyticAt ℂ (cuspFunction 1 (D (g : ℍ → ℂ) * (h : ℍ → ℂ))) 0 := by
+    rw [cuspFunction_mul aDg.continuousAt ah.continuousAt]; exact aDg.mul ah
+  have a1' : AnalyticAt ℂ (cuspFunction 1 ((k₁ : ℂ) • ((g : ℍ → ℂ) * D (h : ℍ → ℂ)))) 0 := by
+    rw [cuspFunction_smul a1.continuousAt]; exact analyticAt_const.smul a1
+  have a2' : AnalyticAt ℂ (cuspFunction 1 ((k₂ : ℂ) • (D (g : ℍ → ℂ) * (h : ℍ → ℂ)))) 0 := by
+    rw [cuspFunction_smul a2.continuousAt]; exact analyticAt_const.smul a2
+  rw [coe_rankinCohen, bracket, qExpansion_sub a1' a2', qExpansion_smul a1, qExpansion_smul a2,
+    qExpansion_mul ag aDh, qExpansion_mul aDg ah, qExpansion_D_coe h1 g, qExpansion_D_coe h1 h,
+    PowerSeries.smul_eq_C_mul, PowerSeries.smul_eq_C_mul, mul_assoc, mul_assoc]
+
+end
+
+end ModularForm.RankinCohenOne
+
+end
+
+open ModularForm.RankinCohenOne in
+theorem solution
+    {Γ : Subgroup SL(2, ℤ)} [Γ.FiniteIndex]
+    (h1 : (1 : ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)).strictPeriods)
+    {k₁ k₂ : ℤ} (g : ModularForm Γ k₁) (h : ModularForm Γ k₂) :
+    ∃ B : ModularForm Γ (k₁ + k₂ + 2),
+      (∀ τ : ℍ, B τ = k₁ * g τ * Derivative.normalizedDerivOfComplex h τ
+                     - k₂ * Derivative.normalizedDerivOfComplex g τ * h τ) ∧
+      qExpansion 1 (B : ℍ → ℂ) =
+        PowerSeries.C (k₁ : ℂ) * qExpansion 1 (g : ℍ → ℂ) *
+            PowerSeries.mk (fun n : ℕ => (n : ℂ) * (qExpansion 1 (h : ℍ → ℂ)).coeff n)
+          - PowerSeries.C (k₂ : ℂ) *
+            PowerSeries.mk (fun n : ℕ => (n : ℂ) * (qExpansion 1 (g : ℍ → ℂ)).coeff n) *
+              qExpansion 1 (h : ℍ → ℂ) :=
+  ⟨rankinCohen g h, rankinCohen_apply g h, qExpansion_rankinCohen h1 g h⟩
+
+end S_ModularForm_exists_rankinCohen_one_qExpansion_eq
+end P2MW
+export P2MW.S_ModularForm_exists_rankinCohen_one_qExpansion_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane
+open scoped MatrixGroups
+theorem ModularForm.exists_rankinCohen_one_qExpansion_eq
+    {Γ : Subgroup SL(2, ℤ)} [Γ.FiniteIndex]
+    (h1 : (1 : ℝ) ∈ (Γ : Subgroup (GL (Fin 2) ℝ)).strictPeriods)
+    {k₁ k₂ : ℤ} (g : ModularForm Γ k₁) (h : ModularForm Γ k₂) :
+    ∃ B : ModularForm Γ (k₁ + k₂ + 2),
+      (∀ τ : ℍ, B τ = k₁ * g τ * Derivative.normalizedDerivOfComplex h τ
+                     - k₂ * Derivative.normalizedDerivOfComplex g τ * h τ) ∧
+      qExpansion 1 (B : ℍ → ℂ) =
+        PowerSeries.C (k₁ : ℂ) * qExpansion 1 (g : ℍ → ℂ) *
+            PowerSeries.mk (fun n : ℕ => (n : ℂ) * (qExpansion 1 (h : ℍ → ℂ)).coeff n)
+          - PowerSeries.C (k₂ : ℂ) *
+            PowerSeries.mk (fun n : ℕ => (n : ℂ) * (qExpansion 1 (g : ℍ → ℂ)).coeff n) *
+              qExpansion 1 (h : ℍ → ℂ) :=
+  solution h1 g h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_tendsto_slash_div_qParam_pow_of_conj_T_pow_mem.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_tendsto_slash_div_qParam_pow_of_conj_T_pow_mem.lean
new file mode 100644
index 0000000000..3abd6170ee
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_tendsto_slash_div_qParam_pow_of_conj_T_pow_mem.lean
@@ -0,0 +1,182 @@
+/-
+Based on Prove2Me node ModularForm.exists_tendsto_slash_div_qParam_pow_of_conj_T_pow_mem
+(9d753039-c1c3-58d5-a99e-0b93d94348bd) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 93f47bff-f255-5fc7-a911-2d01d2f8749e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.CStarAlgebra.Classes
+public import Mathlib.Analysis.Complex.Periodic
+public import Mathlib.NumberTheory.ModularForms.Basic
+
+import Mathlib.NumberTheory.ModularForms.QExpansion
+import Mathlib.NumberTheory.ModularForms.NormTrace
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finite order of a non-zero modular form at a cusp
+
+Theorem statement: `ModularForm.exists_tendsto_slash_div_qParam_pow_of_conj_T_pow_mem`
+(`9d753039-c1c3-58d5-a99e-0b93d94348bd`), by Claude, 2026-09-05.
+
+Proof: submission `93f47bff-f255-5fc7-a911-2d01d2f8749e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Gamma$ be a subgroup of $\mathrm{SL}_2(\mathbb{Z})$, let $k$ be an integer and let $f$ be a
+modular form of weight $k$ for $\Gamma$ (in the sense of `ModularForm Γ k`: holomorphic,
+slash-invariant of weight $k$ under $\Gamma$ and bounded at the cusps), assumed to be non-zero. Let
+$\sigma \in \mathrm{SL}_2(\mathbb{Z})$ and let $h$ be a positive natural number such that the
+conjugate $\sigma T^{h} \sigma^{-1}$ lies in $\Gamma$, where $T =
+\begin{pmatrix}1&1\\0&1\end{pmatrix}$ is `ModularGroup.T`. Then there exist a natural number $n$ and
+a non-zero complex number $a$ such that the function $$\tau \mapsto \frac{(f\mid_k
+\sigma)(\tau)}{q_h(\tau)^{n}}, \qquad q_h(\tau) = e^{2\pi i \tau / h},$$ on the upper half-plane
+converges to $a$ along the filter `atImInfty`, i.e. as $\operatorname{Im}\tau \to \infty$. Here
+$f\mid_k \sigma$ is the weight-$k$ slash action of the image of $\sigma$ in
+$\mathrm{GL}_2(\mathbb{R})$ on the underlying function $\mathbb{H} \to \mathbb{C}$, and $q_h$ is
+`Function.Periodic.qParam h`. In particular the asymptotic order of vanishing of $f\mid_k\sigma$ in
+the parameter $q_h$ at the cusp $\sigma\infty$ is finite and equal to $n$.
+
+This is the statement that a non-zero modular form has a well-defined finite order of vanishing in
+the local parameter $q_h = e^{2\pi i \tau/h}$ at a cusp $\sigma\infty$ whose width divides $h$, the
+basic input for defining the divisor of a modular form on a modular curve. It is used in the
+computation of orders of a weight-one form at the cusps of the curves $X_1(M)$, namely by
+[`ModularCurve.even_ord_add_ord_of_not_mem_toValuationSubring_laurentBaseChange_gamma1`]
+(thm.html#ModularCurve.even_ord_add_ord_of_not_mem_toValuationSubring_laurentBaseChange_gamma1).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_exists_tendsto_slash_div_qParam_pow_of_conj_T_pow_mem.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_exists_tendsto_slash_div_qParam_pow_of_conj_T_pow_mem
+
+open UpperHalfPlane Filter Topology
+open scoped MatrixGroups ModularForm Pointwise
+
+noncomputable section
+
+namespace WCuspOrdAux
+
+theorem exists_tendsto_div_qParam_pow {Γ' : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} {h : ℝ} (hh : 0 < h)
+    (hΓ : h ∈ Γ'.strictPeriods) (F : ModularForm Γ' k) (hF : F ≠ 0) :
+    ∃ (n : ℕ) (a : ℂ), a ≠ 0 ∧
+      Tendsto (fun τ : ℍ => F τ / Function.Periodic.qParam h τ ^ n) atImInfty (𝓝 a) := by
+  have hper : Function.Periodic ((F : ℍ → ℂ) ∘ ofComplex) h :=
+    SlashInvariantFormClass.periodic_comp_ofComplex F hΓ
+  have hG : AnalyticAt ℂ (cuspFunction h F) 0 :=
+    ModularFormClass.analyticAt_cuspFunction_zero F hh hΓ
+  have : Fact (IsCusp OnePoint.infty Γ') := ⟨Γ'.isCusp_of_mem_strictPeriods hh hΓ⟩
+  have hne : ¬ ∀ᶠ z in 𝓝 (0 : ℂ), cuspFunction h F z = 0 := by
+    intro h0
+    apply hF
+    have hsum := fun τ : ℍ =>
+      hasSum_qExpansion hh hper (ModularFormClass.holo F) (ModularFormClass.bdd_at_infty F) τ
+    have hps := hasFPowerSeriesOnBall_cuspFunction hh hG hsum
+    have hp0 := hps.hasFPowerSeriesAt.locally_zero_iff.mp h0
+    rw [← ModularForm.qExpansion_eq_zero_iff hh hΓ F]
+    ext m
+    have e := congrArg (fun p : FormalMultilinearSeries ℂ ℂ ℂ => p.coeff m) hp0
+    simp only [FormalMultilinearSeries.coeff_ofScalars] at e
+    exact e
+  obtain ⟨n, g, hg, hg0, hfg⟩ := hG.exists_eventuallyEq_pow_smul_nonzero_iff.mpr hne
+  refine ⟨n, g 0, hg0, ?_⟩
+  have hq : Tendsto (fun τ : ℍ => Function.Periodic.qParam h τ) atImInfty (𝓝[≠] 0) :=
+    (Function.Periodic.qParam_tendsto hh).comp UpperHalfPlane.tendsto_coe_atImInfty
+  have hlim : Tendsto (fun z : ℂ => cuspFunction h F z / z ^ n) (𝓝[≠] 0) (𝓝 (g 0)) := by
+    have hgc : Tendsto g (𝓝[≠] 0) (𝓝 (g 0)) := hg.continuousAt.tendsto.mono_left nhdsWithin_le_nhds
+    refine hgc.congr' ?_
+    have hfg' : ∀ᶠ z in 𝓝[≠] (0 : ℂ), cuspFunction h F z = (z - 0) ^ n • g z :=
+      hfg.filter_mono nhdsWithin_le_nhds
+    filter_upwards [hfg', self_mem_nhdsWithin] with z hz hz0
+    have hz0' : z ≠ 0 := hz0
+    rw [hz, sub_zero, smul_eq_mul, mul_div_cancel_left₀ _ (pow_ne_zero n hz0')]
+  refine (hlim.comp hq).congr (fun τ => ?_)
+  simp only [Function.comp_apply]
+  rw [UpperHalfPlane.eq_cuspFunction τ hh.ne' hper]
+
+theorem mapGL_T_zpow (n : ℤ) :
+    Matrix.SpecialLinearGroup.mapGL ℝ (ModularGroup.T ^ n) = Matrix.GeneralLinearGroup.upperRightHom
+      (n : ℝ) := by
+  simp only [Units.ext_iff, Matrix.SpecialLinearGroup.mapGL_coe_matrix,
+    Matrix.SpecialLinearGroup.map_apply_coe]
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp [ModularGroup.coe_T_zpow]
+
+end WCuspOrdAux
+
+open WCuspOrdAux in
+theorem WCuspOrdAux.slash_main
+    (Γ : Subgroup SL(2, ℤ)) (k : ℤ) (f : ModularForm Γ k) (hf : f ≠ 0)
+    (σ : SL(2, ℤ)) (h : ℕ) (hh : 0 < h) (hper : σ * ModularGroup.T ^ h * σ⁻¹ ∈ Γ) :
+    ∃ (n : ℕ) (a : ℂ), a ≠ 0 ∧
+      Tendsto (fun τ : ℍ => ((f : ℍ → ℂ) ∣[k] (σ : GL (Fin 2) ℝ)) τ / Function.Periodic.qParam h τ ^
+        n)
+        atImInfty (𝓝 a) := by
+  let F := ModularForm.translate f (σ : GL (Fin 2) ℝ)
+  have hΓ' : ((h : ℝ)) ∈ (ConjAct.toConjAct ((σ : GL (Fin 2) ℝ))⁻¹ •
+      (Γ : Subgroup (GL (Fin 2) ℝ))).strictPeriods := by
+    rw [Subgroup.mem_strictPeriods_iff, Subgroup.mem_pointwise_smul_iff_inv_smul_mem,
+      ConjAct.toConjAct_inv, inv_inv,
+      ConjAct.smul_def, ConjAct.ofConjAct_toConjAct]
+    refine Subgroup.mem_map.mpr ⟨σ * ModularGroup.T ^ h * σ⁻¹, hper, ?_⟩
+    rw [map_mul, map_mul, map_inv, ← zpow_natCast, mapGL_T_zpow, Int.cast_natCast]
+    rfl
+  have hF : F ≠ 0 := by
+    intro h0
+    apply hf
+    have hc : ((f : ℍ → ℂ) ∣[k] (σ : GL (Fin 2) ℝ)) = 0 := by
+      have e1 : ((F : ℍ → ℂ)) = ((0 : ModularForm _ k) : ℍ → ℂ) := congrArg DFunLike.coe h0
+      rw [FunLike.coe_zero] at e1
+      exact e1
+    rw [← FunLike.coe_zero_iff]
+    have e : (f : ℍ → ℂ) = ((f : ℍ → ℂ) ∣[k] (σ : GL (Fin 2) ℝ)) ∣[k] ((σ : GL (Fin 2) ℝ))⁻¹ := by
+      rw [← SlashAction.slash_mul, mul_inv_cancel, SlashAction.slash_one]
+    rw [e, hc, SlashAction.zero_slash]
+  have hhR : (0 : ℝ) < (h : ℝ) := by exact_mod_cast hh
+  obtain ⟨n, a, ha, hlim⟩ := exists_tendsto_div_qParam_pow hhR hΓ' F hF
+  exact ⟨n, a, ha, hlim⟩
+
+theorem solution
+    (Γ : Subgroup SL(2, ℤ)) (k : ℤ) (f : ModularForm Γ k) (hf : f ≠ 0)
+    (σ : SL(2, ℤ)) (h : ℕ) (hh : 0 < h) (hper : σ * ModularGroup.T ^ h * σ⁻¹ ∈ Γ) :
+    ∃ (n : ℕ) (a : ℂ), a ≠ 0 ∧
+      Tendsto (fun τ : ℍ => ((f : ℍ → ℂ) ∣[k] (σ : GL (Fin 2) ℝ)) τ / Function.Periodic.qParam h τ ^
+        n)
+        atImInfty (𝓝 a) :=
+  WCuspOrdAux.slash_main Γ k f hf σ h hh hper
+
+end
+end S_ModularForm_exists_tendsto_slash_div_qParam_pow_of_conj_T_pow_mem
+end P2MW
+export P2MW.S_ModularForm_exists_tendsto_slash_div_qParam_pow_of_conj_T_pow_mem (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane Filter Topology
+open scoped MatrixGroups ModularForm
+theorem ModularForm.exists_tendsto_slash_div_qParam_pow_of_conj_T_pow_mem
+    (Γ : Subgroup SL(2, ℤ)) (k : ℤ) (f : ModularForm Γ k) (hf : f ≠ 0)
+    (σ : SL(2, ℤ)) (h : ℕ) (hh : 0 < h) (hper : σ * ModularGroup.T ^ h * σ⁻¹ ∈ Γ) :
+    ∃ (n : ℕ) (a : ℂ), a ≠ 0 ∧
+      Tendsto (fun τ : ℍ => ((f : ℍ → ℂ) ∣[k] (σ : GL (Fin 2) ℝ)) τ / Function.Periodic.qParam h τ ^
+        n)
+        atImInfty (𝓝 a) :=
+  solution Γ k f hf σ h hh hper
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_weightOne_eisenstein_qCoeff_eq_of_isPrimitive_of_odd.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_weightOne_eisenstein_qCoeff_eq_of_isPrimitive_of_odd.lean
new file mode 100644
index 0000000000..d88e82c88b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_weightOne_eisenstein_qCoeff_eq_of_isPrimitive_of_odd.lean
@@ -0,0 +1,804 @@
+/-
+Based on Prove2Me node ModularForm.exists_weightOne_eisenstein_qCoeff_eq_of_isPrimitive_of_odd
+(fac9a4fa-2696-5e7f-9f62-7db5aaaccd55) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ab860447-527f-5f59-bb5a-02b7675a1abd
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.DirichletCharacter.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+
+import Mathlib.Analysis.Fourier.ZMod
+import Mathlib.Analysis.Complex.LocallyUniformLimit
+import Mathlib.Analysis.SpecialFunctions.Trigonometric.Cotangent
+import Mathlib.NumberTheory.DirichletCharacter.Bounds
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_EisensteinSeries_eisensteinG1_apply_smul_and_eisensteinG1_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_EisensteinSeries_isBoundedAtImInfty_eisensteinG1_and_hasSum_eisensteinG1
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Hecke's weight-one Eisenstein series for an odd primitive character
+
+Theorem statement: `ModularForm.exists_weightOne_eisenstein_qCoeff_eq_of_isPrimitive_of_odd`
+(`fac9a4fa-2696-5e7f-9f62-7db5aaaccd55`), by Claude, 2026-09-05.
+
+Proof: submission `ab860447-527f-5f59-bb5a-02b7675a1abd`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a positive integer and let $\chi$ be a Dirichlet character modulo $L$ with values in
+$\mathbb{C}$ which is primitive and odd. Then there exists a modular form $E$ of weight $1$ on
+$\Gamma_1(L)$ with the following three properties. First, $E$ transforms under the full group
+$\Gamma_0(L)$ with nebentypus $\chi$: for every $\gamma \in \mathrm{SL}_2(\mathbb{Z})$ lying in
+$\Gamma_0(L)$ and every $\tau$ in the upper half-plane, $E(\gamma \cdot \tau) = \chi(\gamma_{11}
+\bmod L)\,(\gamma_{10}\tau + \gamma_{11})^{1}\,E(\tau)$, the exponent $1$ being an integer power of
+the automorphy factor and the entries being those in the bottom row of $\gamma$. Second, writing
+$\mathrm{qCoeff}\,E\,n$ for the $n$-th coefficient of the $q$-expansion of $E$ at width $1$ (so $q =
+e^{2\pi i \tau}$), the constant term is $$\mathrm{qCoeff}\,E\,0 = -\Bigl(\sum_{a=0}^{L-1} a\,\chi(a
+\bmod L)\Bigr)\Big/ (2L),$$ i.e. $-B_{1,\chi}/2$. Third, for every $n > 0$ one has
+$\mathrm{qCoeff}\,E\,n = \sum_{d \mid n} \chi(d \bmod L)$.
+
+This is Hecke's Eisenstein series of weight one attached to an odd primitive Dirichlet character,
+exhibiting the divisor-sum $q$-expansion $-B_{1,\chi}/2 + \sum_{n\ge 1}\sigma_{0,\chi}(n)q^n$ as an
+element of $M_1(L,\chi)$. It supplies the explicit weight-one forms used downstream in the
+Deligne–Serre style passage from weight one to weight two and in the construction of integral
+weight-one forms on modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_exists_weightOne_eisenstein_qCoeff_eq_of_isPrimitive_of_odd.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_exists_weightOne_eisenstein_qCoeff_eq_of_isPrimitive_of_odd
+
+open scoped Topology Real MatrixGroups Matrix CongruenceSubgroup ModularForm Manifold
+p2m_open "UpperHalfPlane~I"
+open EisensteinSeries Filter Complex
+
+noncomputable section
+
+namespace WZE
+
+section arith
+
+variable {L : ℕ} [NeZero L]
+
+lemma three_le (χ : DirichletCharacter ℂ L) (hodd : χ.Odd) : 3 ≤ L := by
+  by_contra h
+  have hL : L = 1 ∨ L = 2 := by
+    have := NeZero.ne L
+    omega
+  have hneg : (-1 : ZMod L) = 1 := by
+    rcases hL with rfl | rfl <;> decide
+  have h1 : χ (-1) = -1 := hodd
+  rw [hneg, map_one] at h1
+  norm_num at h1
+
+omit [NeZero L] in
+lemma factorsThrough_inv (χ : DirichletCharacter ℂ L) {d : ℕ} (h : χ.FactorsThrough d) :
+    χ⁻¹.FactorsThrough d := by
+  obtain ⟨hd, χ₀, hχ₀⟩ := h
+  exact ⟨hd, χ₀⁻¹, by rw [hχ₀, map_inv]⟩
+
+omit [NeZero L] in
+lemma conductor_inv (χ : DirichletCharacter ℂ L) : χ⁻¹.conductor = χ.conductor := by
+  have hset : χ⁻¹.conductorSet = χ.conductorSet := by
+    ext d
+    simp only [DirichletCharacter.mem_conductorSet_iff]
+    constructor
+    · intro h
+      simpa using factorsThrough_inv χ⁻¹ h
+    · exact factorsThrough_inv χ
+  rw [DirichletCharacter.conductor, DirichletCharacter.conductor, hset]
+
+omit [NeZero L] in
+lemma isPrimitive_inv (χ : DirichletCharacter ℂ L) (hχ : χ.IsPrimitive) : χ⁻¹.IsPrimitive := by
+  rw [DirichletCharacter.isPrimitive_def, conductor_inv]
+  exact hχ
+
+abbrev ψL (L : ℕ) [NeZero L] : AddChar (ZMod L) ℂ := ZMod.stdAddChar
+
+def gs (χ : DirichletCharacter ℂ L) : ℂ := gaussSum χ⁻¹ (ψL L)
+
+lemma sum_inv_mul_psi (χ : DirichletCharacter ℂ L) (hχ : χ.IsPrimitive) (a : ZMod L) :
+    ∑ b : ZMod L, χ⁻¹ b * ψL L (b * a) = χ a * gs χ := by
+  have h := gaussSum_mulShift_of_isPrimitive (ψL L) (isPrimitive_inv χ hχ) a
+  rw [inv_inv] at h
+  rw [gs, ← h, gaussSum]
+  refine Finset.sum_congr rfl fun b _ => ?_
+  rw [AddChar.mulShift_apply, mul_comm a b]
+
+lemma gaussSum_ne_zero_of_isPrimitive (φ : DirichletCharacter ℂ L) (hφ : φ.IsPrimitive) :
+    gaussSum φ (ψL L) ≠ 0 := by
+  intro h0
+  have h1 : ZMod.dft (⇑φ) = 0 := by
+    funext k
+    rw [DirichletCharacter.IsPrimitive.fourierTransform_eq_inv_mul_gaussSum hφ]
+    simp [h0]
+  have h2 := ZMod.dft_dft (⇑φ)
+  rw [h1, map_zero] at h2
+  have h3 := congr_fun h2 (-1)
+  simp only [Pi.zero_apply, neg_neg, map_one, smul_eq_mul, mul_one] at h3
+  exact (NeZero.ne (L : ℂ)) h3.symm
+
+lemma gs_ne_zero (χ : DirichletCharacter ℂ L) (hχ : χ.IsPrimitive) : gs χ ≠ 0 :=
+  gaussSum_ne_zero_of_isPrimitive χ⁻¹ (isPrimitive_inv χ hχ)
+
+omit [NeZero L] in
+lemma inv_ne_one (χ : DirichletCharacter ℂ L) (hodd : χ.Odd) : χ⁻¹ ≠ 1 := by
+  intro h
+  have : χ = 1 := by rw [← inv_inv χ, h, inv_one]
+  have h1 : χ (-1) = -1 := hodd
+  rw [this, MulChar.one_apply (isUnit_one.neg)] at h1
+  norm_num at h1
+
+lemma sum_inv_eq_zero (χ : DirichletCharacter ℂ L) (hodd : χ.Odd) : ∑ b : ZMod L, χ⁻¹ b = 0 :=
+  MulChar.sum_eq_zero_of_ne_one (inv_ne_one χ hodd)
+
+omit [NeZero L] in
+lemma chi_neg (χ : DirichletCharacter ℂ L) (hodd : χ.Odd) (a : ZMod L) : χ (-a) = -χ a := by
+  have h1 : χ (-1) = -1 := hodd
+  rw [show -a = -1 * a by ring, map_mul, h1]
+  ring
+
+omit [NeZero L] in
+lemma inv_mul_unit (χ : DirichletCharacter ℂ L) (b u : ZMod L) (hu : IsUnit u) :
+    χ⁻¹ (b * u) * χ u = χ⁻¹ b := by
+  rw [map_mul, mul_assoc]
+  have : χ⁻¹ u * χ u = 1 := by
+    rw [← MulChar.mul_apply, inv_mul_cancel, MulChar.one_apply hu]
+  rw [this, mul_one]
+
+omit [NeZero L] in
+lemma sum_mul_pow_eq {x : ℂ} (hx1 : x ≠ 1) (hxL : x ^ L = 1) :
+    ∑ j ∈ Finset.range L, (j : ℂ) * x ^ j = L / (x - 1) := by
+  have hx : x - 1 ≠ 0 := sub_ne_zero.mpr hx1
+  have hgeom : ∑ j ∈ Finset.range L, x ^ j = 0 := by
+    rw [geom_sum_eq hx1, hxL, sub_self, zero_div]
+  rw [eq_div_iff hx]
+  have key : ∀ n : ℕ, (∑ j ∈ Finset.range n, (j : ℂ) * x ^ j) * (x - 1) =
+      (n : ℂ) * x ^ n - ∑ j ∈ Finset.range n, x ^ (j + 1) := by
+    intro n
+    induction n with
+    | zero => simp
+    | succ n ih =>
+        rw [Finset.sum_range_succ, Finset.sum_range_succ, add_mul, ih]
+        push_cast
+        ring
+  rw [key L, hxL, mul_one]
+  have : ∑ j ∈ Finset.range L, x ^ (j + 1) = x * ∑ j ∈ Finset.range L, x ^ j := by
+    rw [Finset.mul_sum]
+    refine Finset.sum_congr rfl fun j _ => ?_
+    ring
+  rw [this, hgeom, mul_zero, sub_zero]
+
+lemma pi_cot_eq_sum (b : ZMod L) (hb : b ≠ 0) :
+    (π : ℂ) * Complex.cot (π * (b.val : ℂ) / L) =
+      π * I + 2 * π * I / L * ∑ j ∈ Finset.range L, (j : ℂ) * ψL L (b * (j : ZMod L)) := by
+  have hL : (L : ℂ) ≠ 0 := by exact_mod_cast NeZero.ne L
+  set x : ℂ := cexp (2 * π * I * ((b.val : ℂ) / L)) with hxdef
+  have hψb : ψL L b = x := by
+    rw [hxdef]
+    conv_lhs => rw [← ZMod.natCast_zmod_val b]
+    rw [show ((b.val : ℕ) : ZMod L) = ((b.val : ℤ) : ZMod L) by simp, ZMod.stdAddChar_coe]
+    congr 1
+    push_cast
+    ring
+  have hxψ : ∀ j : ℕ, ψL L (b * (j : ZMod L)) = x ^ j := by
+    intro j
+    rw [show b * (j : ZMod L) = j • b by rw [nsmul_eq_mul, mul_comm], AddChar.map_nsmul_eq_pow,
+      hψb]
+  have hxL : x ^ L = 1 := by
+    rw [hxdef, ← Complex.exp_nat_mul, Complex.exp_eq_one_iff]
+    refine ⟨b.val, ?_⟩
+    push_cast
+    field_simp
+  have hx1 : x ≠ 1 := by
+    rw [hxdef]
+    intro h
+    rw [Complex.exp_eq_one_iff] at h
+    obtain ⟨n, hn⟩ := h
+    have h2 : ((b.val : ℂ) / L) = n := by
+      have h2πI : (2 * π * I : ℂ) ≠ 0 := by simp [Real.pi_ne_zero, I_ne_zero]
+      have := mul_left_cancel₀ h2πI (hn.trans (by ring))
+      exact this
+    have h3 : (b.val : ℂ) = n * L := by
+      field_simp at h2
+      linear_combination h2
+    have h4 : (b.val : ℤ) = n * L := by exact_mod_cast h3
+    have h5 : (L : ℤ) ∣ b.val := ⟨n, by rw [h4]; ring⟩
+    have h6 : L ∣ b.val := by exact_mod_cast h5
+    have h7 : b.val = 0 := Nat.eq_zero_of_dvd_of_lt h6 (ZMod.val_lt b)
+    exact hb ((ZMod.val_eq_zero b).mp h7)
+  simp_rw [hxψ]
+  rw [sum_mul_pow_eq hx1 hxL, show π * (b.val : ℂ) / L = π * ((b.val : ℂ) / L) by ring,
+    Complex.cot_pi_eq_exp_ratio, ← hxdef]
+  have hx' : x - 1 ≠ 0 := sub_ne_zero.mpr hx1
+  have hx'' : 1 - x ≠ 0 := sub_ne_zero.mpr (Ne.symm hx1)
+  have hI : I * (1 - x) ≠ 0 := mul_ne_zero I_ne_zero hx''
+  field_simp
+  ring_nf
+  rw [I_sq]
+  ring
+
+end arith
+
+section E0
+
+variable (L : ℕ) [NeZero L] (χ : DirichletCharacter ℂ L)
+
+def vb (b : ZMod L) : Fin 2 → ℤ := ![0, (b.val : ℤ)]
+
+def E0 (τ : ℍ) : ℂ := ∑ b : ZMod L, χ⁻¹ b * eisensteinG1 L (vb L b) τ
+
+variable {L}
+
+lemma vb_not_dvd {b : ZMod L} (hb : b ≠ 0) : ¬ ∀ i, (L : ℤ) ∣ vb L b i := by
+  intro h
+  have h1 : (L : ℤ) ∣ (b.val : ℤ) := by simpa [vb] using h 1
+  have h2 : L ∣ b.val := by exact_mod_cast h1
+  have h3 : b.val = 0 := Nat.eq_zero_of_dvd_of_lt h2 (ZMod.val_lt b)
+  exact hb ((ZMod.val_eq_zero b).mp h3)
+
+omit [NeZero L] in
+lemma inv_zero_eq (hL : 3 ≤ L) : χ⁻¹ (0 : ZMod L) = 0 := by
+  have : Fact (1 < L) := ⟨by omega⟩
+  apply MulChar.map_nonunit
+  simp
+
+lemma isUnit_entry (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 L) :
+    IsUnit (((γ 1 1 : ℤ) : ZMod L)) := by
+  have hdet := Matrix.SpecialLinearGroup.det_coe γ
+  rw [Matrix.det_fin_two] at hdet
+  rw [CongruenceSubgroup.Gamma0_mem] at hγ
+  have h : (((γ 0 0 : ℤ) : ZMod L)) * ((γ 1 1 : ℤ) : ZMod L) = 1 := by
+    have := congr_arg (fun x : ℤ => (x : ZMod L)) hdet
+    simp only [Int.cast_sub, Int.cast_mul, Int.cast_one] at this
+    rw [hγ, mul_zero, sub_zero] at this
+    exact this
+  exact IsUnit.of_mul_eq_one_right _ h
+
+lemma vb_vecMul_eq (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 L) (b : ZMod L) :
+    ∃ w : Fin 2 → ℤ, vb L b ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ) =
+      vb L (b * ((γ 1 1 : ℤ) : ZMod L)) + (L : ℤ) • w := by
+  rw [CongruenceSubgroup.Gamma0_mem] at hγ
+  have h1 : (L : ℤ) ∣ (b.val : ℤ) * γ 1 0 := by
+    have : (L : ℤ) ∣ γ 1 0 := (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp hγ
+    exact this.mul_left _
+  have h2 : (L : ℤ) ∣ (b.val : ℤ) * γ 1 1 - ((b * ((γ 1 1 : ℤ) : ZMod L)).val : ℤ) := by
+    rw [← ZMod.intCast_zmod_eq_zero_iff_dvd]
+    push_cast
+    rw [ZMod.natCast_zmod_val, ZMod.natCast_zmod_val, sub_self]
+  obtain ⟨w0, hw0⟩ := h1
+  obtain ⟨w1, hw1⟩ := h2
+  refine ⟨![w0, w1], ?_⟩
+  funext i
+  fin_cases i
+  · change (vb L b ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ)) 0 =
+      vb L (b * ((γ 1 1 : ℤ) : ZMod L)) 0 + (L : ℤ) * (![w0, w1] : Fin 2 → ℤ) 0
+    simp only [Matrix.vecMul, dotProduct, Fin.sum_univ_two, vb, Matrix.cons_val_zero,
+      Matrix.cons_val_one, Matrix.cons_val_fin_one, zero_mul, zero_add]
+    linear_combination hw0
+  · change (vb L b ᵥ* (γ : Matrix (Fin 2) (Fin 2) ℤ)) 1 =
+      vb L (b * ((γ 1 1 : ℤ) : ZMod L)) 1 + (L : ℤ) * (![w0, w1] : Fin 2 → ℤ) 1
+    simp only [Matrix.vecMul, dotProduct, Fin.sum_univ_two, vb, Matrix.cons_val_zero,
+      Matrix.cons_val_one, Matrix.cons_val_fin_one, zero_mul, zero_add]
+    linear_combination hw1
+
+theorem E0_smul (hL : 3 ≤ L) (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 L) (τ : ℍ) :
+    E0 L χ (γ • τ) = χ ((γ 1 1 : ℤ) : ZMod L) * denom γ τ * E0 L χ τ := by
+  have hT := (EisensteinSeries.eisensteinG1_apply_smul_and_eisensteinG1_add L τ).1 γ
+  have hP := (EisensteinSeries.eisensteinG1_apply_smul_and_eisensteinG1_add L τ).2
+  set d : ZMod L := ((γ 1 1 : ℤ) : ZMod L) with hd
+  have hdu : IsUnit d := isUnit_entry γ hγ
+  have h0 : χ⁻¹ (0 : ZMod L) = 0 := inv_zero_eq χ hL
+  have hterm : ∀ b : ZMod L, χ⁻¹ b * eisensteinG1 L (vb L b) (γ • τ) =
+      denom γ τ * (χ⁻¹ (b * d) * χ d * eisensteinG1 L (vb L (b * d)) τ) := by
+    intro b
+    by_cases hb : b = 0
+    · subst hb
+      simp [h0]
+    · rw [inv_mul_unit χ b d hdu, hT]
+      obtain ⟨w, hw⟩ := vb_vecMul_eq γ hγ b
+      rw [hw, hP _ _ (vb_not_dvd ((hdu.mul_left_eq_zero.not).mpr hb))]
+      ring
+  unfold E0
+  simp_rw [hterm]
+  rw [← Finset.mul_sum]
+  have hbij : Function.Bijective fun b : ZMod L => b * d :=
+    Finite.injective_iff_bijective.mp hdu.mul_left_injective
+  rw [show ∑ b : ZMod L, χ⁻¹ (b * d) * χ d * eisensteinG1 L (vb L (b * d)) τ =
+      ∑ b : ZMod L, χ⁻¹ b * χ d * eisensteinG1 L (vb L b) τ from
+    Fintype.sum_bijective _ hbij _ _ (fun b => rfl)]
+  rw [Finset.mul_sum, Finset.mul_sum]
+  refine Finset.sum_congr rfl fun b _ => ?_
+  ring
+
+lemma denom_eq (γ : SL(2, ℤ)) (τ : ℍ) :
+    (denom γ τ : ℂ) = ((γ 1 0 : ℤ) : ℂ) * τ + ((γ 1 1 : ℤ) : ℂ) := by
+  simp [ModularGroup.denom_apply]
+
+variable (L)
+
+def E0SIF (hL : 3 ≤ L) : SlashInvariantForm (CongruenceSubgroup.Gamma1 L) 1 where
+  toFun := E0 L χ
+  slash_action_eq' A hA := by
+    obtain ⟨γ, hγ, rfl⟩ := hA
+    have hγ' : γ ∈ CongruenceSubgroup.Gamma1 L := hγ
+    rw [CongruenceSubgroup.Gamma1_mem] at hγ'
+    have hγ0 : γ ∈ CongruenceSubgroup.Gamma0 L := by
+      rw [CongruenceSubgroup.Gamma0_mem]; exact hγ'.2.2
+    change E0 L χ ∣[(1 : ℤ)] (γ : GL (Fin 2) ℝ) = E0 L χ
+    funext τ
+    rw [← ModularForm.SL_slash, ModularForm.SL_slash_apply, E0_smul χ hL γ hγ0 τ, hγ'.2.1, map_one]
+    have hD : (denom γ τ : ℂ) ≠ 0 := denom_ne_zero _ τ
+    field_simp
+
+lemma E0SIF_apply (hL : 3 ≤ L) (τ : ℍ) : E0SIF L χ hL τ = E0 L χ τ := rfl
+
+lemma coe_E0SIF (hL : 3 ≤ L) : ⇑(E0SIF L χ hL) = E0 L χ := rfl
+
+variable {L}
+
+lemma E0_slash (A : SL(2, ℤ)) :
+    E0 L χ ∣[(1 : ℤ)] A = fun τ => ∑ b : ZMod L,
+      χ⁻¹ b * eisensteinG1 L (vb L b ᵥ* (A : Matrix (Fin 2) (Fin 2) ℤ)) τ := by
+  funext τ
+  have hT := (EisensteinSeries.eisensteinG1_apply_smul_and_eisensteinG1_add L τ).1 A
+  have hD : (denom A τ : ℂ) ≠ 0 := denom_ne_zero _ τ
+  rw [ModularForm.SL_slash_apply, E0]
+  simp_rw [hT]
+  rw [Finset.sum_mul]
+  refine Finset.sum_congr rfl fun b _ => ?_
+  field_simp
+
+omit [NeZero L] in
+lemma not_dvd_vecMul {v : Fin 2 → ℤ} (hv : ¬ ∀ i, (L : ℤ) ∣ v i) (A : SL(2, ℤ)) :
+    ¬ ∀ i, (L : ℤ) ∣ (v ᵥ* (A : Matrix (Fin 2) (Fin 2) ℤ)) i := by
+  intro h
+  apply hv
+  have key : v = (v ᵥ* (A : Matrix (Fin 2) (Fin 2) ℤ)) ᵥ* ((A⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2)
+    ℤ) :=
+    by
+    rw [Matrix.vecMul_vecMul, ← Matrix.SpecialLinearGroup.coe_mul, mul_inv_cancel,
+      Matrix.SpecialLinearGroup.coe_one, Matrix.vecMul_one]
+  intro i
+  rw [key]
+  generalize v ᵥ* (A : Matrix (Fin 2) (Fin 2) ℤ) = u at h ⊢
+  simp only [Matrix.vecMul, dotProduct, Fin.sum_univ_two]
+  exact dvd_add ((h 0).mul_right _) ((h 1).mul_right _)
+
+theorem isBoundedAtImInfty_E0_slash (hL : 3 ≤ L) (A : SL(2, ℤ)) :
+    IsBoundedAtImInfty (E0 L χ ∣[(1 : ℤ)] A) := by
+  have hB := (EisensteinSeries.isBoundedAtImInfty_eisensteinG1_and_hasSum_eisensteinG1 L).1
+  rw [E0_slash]
+  have : (fun τ => ∑ b : ZMod L, χ⁻¹ b * eisensteinG1 L (vb L b ᵥ* (A : Matrix (Fin 2) (Fin 2) ℤ))
+    τ)
+      = ∑ b : ZMod L, fun τ => χ⁻¹ b * eisensteinG1 L (vb L b ᵥ* (A : Matrix (Fin 2) (Fin 2) ℤ)) τ
+        := by
+    funext τ; simp [Finset.sum_apply]
+  rw [this]
+  refine Finset.sum_induction _ (fun f : ℍ → ℂ => IsBoundedAtImInfty f)
+    (fun f g hf hg => hf.add hg) ?_ ?_
+  · exact Filter.const_boundedAtFilter _ (0 : ℂ)
+  · intro b _
+    by_cases hb : b = 0
+    · subst hb
+      have : (fun τ : ℍ => χ⁻¹ (0 : ZMod L) *
+          eisensteinG1 L (vb L 0 ᵥ* (A : Matrix (Fin 2) (Fin 2) ℤ)) τ) = Function.const ℍ (0 : ℂ) :=
+            by
+        funext τ; simp [inv_zero_eq χ hL]
+      rw [this]
+      exact Filter.const_boundedAtFilter _ (0 : ℂ)
+    · have h1 : IsBoundedAtImInfty (eisensteinG1 L (vb L b ᵥ* (A : Matrix (Fin 2) (Fin 2) ℤ))) :=
+        hB _ (not_dvd_vecMul (vb_not_dvd hb) A)
+      have h2 : IsBoundedAtImInfty (Function.const ℍ (χ⁻¹ b)) := Filter.const_boundedAtFilter _ _
+      exact h2.mul h1
+
+end E0
+
+section qexp
+
+variable {L : ℕ} [NeZero L] (χ : DirichletCharacter ℂ L)
+
+def cb (b : ZMod L) (n : ℕ) : ℂ :=
+  if n = 0 then π / L * Complex.cot (π * ((b.val : ℤ) : ℂ) / L) else
+    -(2 * π * I) / L * ∑ k ∈ n.divisors,
+      (cexp (2 * π * I * ((b.val : ℤ) : ℂ) * k / L) - cexp (-(2 * π * I * ((b.val : ℤ) : ℂ) * k /
+        L)))
+
+lemma hasSum_G {b : ZMod L} (hb : b ≠ 0) (τ : ℍ) :
+    HasSum (fun n : ℕ => cb b n * cexp (2 * π * I * τ) ^ n) (eisensteinG1 L (vb L b) τ) := by
+  have hb' : ¬ (L : ℤ) ∣ (b.val : ℤ) := by
+    intro h
+    have h2 : L ∣ b.val := by exact_mod_cast h
+    have h3 : b.val = 0 := Nat.eq_zero_of_dvd_of_lt h2 (ZMod.val_lt b)
+    exact hb ((ZMod.val_eq_zero b).mp h3)
+  exact (EisensteinSeries.isBoundedAtImInfty_eisensteinG1_and_hasSum_eisensteinG1 L).2 _ hb' τ
+
+def A (n : ℕ) : ℂ := ∑ b : ZMod L, χ⁻¹ b * cb b n
+
+theorem hasSum_E0 (hL : 3 ≤ L) (τ : ℍ) :
+    HasSum (fun n : ℕ => A χ n * cexp (2 * π * I * τ) ^ n) (E0 L χ τ) := by
+  have h : ∀ b ∈ (Finset.univ : Finset (ZMod L)),
+      HasSum (fun n : ℕ => χ⁻¹ b * (cb b n * cexp (2 * π * I * τ) ^ n))
+        (χ⁻¹ b * eisensteinG1 L (vb L b) τ) := by
+    intro b _
+    by_cases hb : b = 0
+    · subst hb
+      simp only [inv_zero_eq χ hL, zero_mul]
+      exact hasSum_zero
+    · exact (hasSum_G hb τ).mul_left _
+  refine (hasSum_sum h).congr_fun fun n => ?_
+  rw [A, Finset.sum_mul]
+  refine Finset.sum_congr rfl fun b _ => ?_
+  ring
+
+lemma cexp_eq_psi (b : ZMod L) (k : ℕ) :
+    cexp (2 * π * I * ((b.val : ℤ) : ℂ) * k / L) = ψL L (b * (k : ZMod L)) ∧
+    cexp (-(2 * π * I * ((b.val : ℤ) : ℂ) * k / L)) = ψL L (b * (-(k : ZMod L))) := by
+  constructor
+  · have := ZMod.stdAddChar_coe (N := L) ((b.val : ℤ) * k)
+    rw [show (((b.val : ℤ) * k : ℤ) : ZMod L) = b * (k : ZMod L) by
+      push_cast; rw [ZMod.natCast_zmod_val]] at this
+    rw [ψL, this]
+    congr 1
+    push_cast
+    ring
+  · have := ZMod.stdAddChar_coe (N := L) (-((b.val : ℤ) * k))
+    rw [show ((-((b.val : ℤ) * k) : ℤ) : ZMod L) = b * (-(k : ZMod L)) by
+      push_cast; rw [ZMod.natCast_zmod_val]; ring] at this
+    rw [ψL, this]
+    congr 1
+    push_cast
+    ring
+
+def cst (χ : DirichletCharacter ℂ L) : ℂ := -(4 * π * I) * gs χ / L
+
+lemma cst_ne_zero (hχ : χ.IsPrimitive) : cst χ ≠ 0 := by
+  have hL : (L : ℂ) ≠ 0 := by exact_mod_cast NeZero.ne L
+  have hg := gs_ne_zero χ hχ
+  simp [cst, hL, hg, Real.pi_ne_zero, I_ne_zero]
+
+theorem A_of_ne_zero (hχ : χ.IsPrimitive) (hodd : χ.Odd) {n : ℕ} (hn : n ≠ 0) :
+    A χ n = cst χ * ∑ d ∈ n.divisors, χ (d : ZMod L) := by
+  unfold A
+  simp only [cb, ite_eq_right hn]
+  have hterm : ∀ b : ZMod L, χ⁻¹ b * (-(2 * π * I) / L * ∑ k ∈ n.divisors,
+      (cexp (2 * π * I * ((b.val : ℤ) : ℂ) * k / L) - cexp (-(2 * π * I * ((b.val : ℤ) : ℂ) * k /
+        L)))) =
+      -(2 * π * I) / L * ∑ k ∈ n.divisors,
+        (χ⁻¹ b * ψL L (b * (k : ZMod L)) - χ⁻¹ b * ψL L (b * (-(k : ZMod L)))) := by
+    intro b
+    rw [Finset.mul_sum, Finset.mul_sum, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun k _ => ?_
+    rw [(cexp_eq_psi b k).1, (cexp_eq_psi b k).2]
+    ring
+  simp_rw [hterm]
+  rw [← Finset.mul_sum, Finset.sum_comm]
+  simp_rw [Finset.sum_sub_distrib, sum_inv_mul_psi χ hχ, chi_neg χ hodd]
+  rw [← Finset.sum_sub_distrib, cst, Finset.mul_sum, Finset.mul_sum]
+  refine Finset.sum_congr rfl fun k _ => ?_
+  ring
+
+theorem A_zero (hχ : χ.IsPrimitive) (hodd : χ.Odd) :
+    A χ 0 = cst χ * (-(∑ a ∈ Finset.range L, (a : ℂ) * χ (a : ZMod L)) / (2 * L)) := by
+  have hL : (L : ℂ) ≠ 0 := by exact_mod_cast NeZero.ne L
+  have hL3 := three_le χ hodd
+  set S : ZMod L → ℂ := fun b => ∑ j ∈ Finset.range L, (j : ℂ) * ψL L (b * (j : ZMod L)) with hSdef
+  have hterm : ∀ b : ZMod L, χ⁻¹ b * cb b 0 = 1 / L * (χ⁻¹ b * (π * I + 2 * π * I / L * S b)) := by
+    intro b
+    by_cases hb : b = 0
+    · subst hb; simp [inv_zero_eq χ hL3]
+    · have := pi_cot_eq_sum b hb
+      simp only [cb, ite_true]
+      rw [Int.cast_natCast, show π / (L : ℂ) * Complex.cot (π * (b.val : ℂ) / L) =
+        1 / L * (π * Complex.cot (π * (b.val : ℂ) / L)) by ring, this]
+      ring
+  have hS : ∑ b : ZMod L, χ⁻¹ b * S b = gs χ * ∑ j ∈ Finset.range L, (j : ℂ) * χ (j : ZMod L) := by
+    have h1 : ∀ b : ZMod L, χ⁻¹ b * S b =
+        ∑ j ∈ Finset.range L, (j : ℂ) * (χ⁻¹ b * ψL L (b * (j : ZMod L))) := by
+      intro b
+      simp only [hSdef, Finset.mul_sum]
+      refine Finset.sum_congr rfl fun j _ => ?_
+      ring
+    simp_rw [h1]
+    rw [Finset.sum_comm, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun j _ => ?_
+    rw [← Finset.mul_sum, sum_inv_mul_psi χ hχ]
+    ring
+  unfold A
+  simp_rw [hterm]
+  rw [← Finset.mul_sum]
+  simp_rw [mul_add]
+  rw [Finset.sum_add_distrib]
+  have e1 : ∑ b : ZMod L, χ⁻¹ b * (π * I) = 0 := by
+    rw [← Finset.sum_mul, sum_inv_eq_zero χ hodd, zero_mul]
+  have e2 : ∑ b : ZMod L, χ⁻¹ b * (2 * π * I / L * S b) =
+      2 * π * I / L * (gs χ * ∑ j ∈ Finset.range L, (j : ℂ) * χ (j : ZMod L)) := by
+    rw [← hS, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun b _ => ?_
+    ring
+  rw [e1, e2, cst]
+  field_simp
+  ring
+
+lemma norm_cb_le (b : ZMod L) (n : ℕ) : ‖cb b n‖ ≤ ‖cb b 0‖ + 4 * π * n := by
+  by_cases hn : n = 0
+  · subst hn; simp
+  · have hLpos : (0 : ℝ) < L := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne L)
+    have hL1 : (1 : ℝ) ≤ L := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne L)
+    have h0 : 0 ≤ ‖cb b 0‖ := norm_nonneg _
+    rw [cb, ite_eq_right hn, norm_mul, norm_div, norm_neg, norm_mul, norm_mul, Complex.norm_two,
+      Complex.norm_real, Real.norm_of_nonneg Real.pi_pos.le, Complex.norm_I, mul_one,
+      Complex.norm_natCast]
+    have hsum : ‖∑ k ∈ n.divisors, (cexp (2 * π * I * ((b.val : ℤ) : ℂ) * k / L) -
+        cexp (-(2 * π * I * ((b.val : ℤ) : ℂ) * k / L)))‖ ≤ 2 * n := by
+      refine (norm_sum_le _ _).trans ?_
+      have : ∀ k ∈ n.divisors, ‖cexp (2 * π * I * ((b.val : ℤ) : ℂ) * k / L) -
+          cexp (-(2 * π * I * ((b.val : ℤ) : ℂ) * k / L))‖ ≤ 2 := by
+        intro k _
+        refine (norm_sub_le _ _).trans ?_
+        rw [(cexp_eq_psi b k).1, (cexp_eq_psi b k).2, ψL, ZMod.stdAddChar_apply,
+          ZMod.stdAddChar_apply, Circle.norm_coe, Circle.norm_coe]
+        norm_num
+      refine (Finset.sum_le_sum this).trans ?_
+      rw [Finset.sum_const, nsmul_eq_mul]
+      have := Nat.card_divisors_le_self n
+      have : (n.divisors.card : ℝ) ≤ n := by exact_mod_cast this
+      linarith
+    calc 2 * π / L * ‖∑ k ∈ n.divisors, (cexp (2 * π * I * ((b.val : ℤ) : ℂ) * k / L) -
+          cexp (-(2 * π * I * ((b.val : ℤ) : ℂ) * k / L)))‖
+        ≤ 2 * π / 1 * (2 * n) := by
+          gcongr
+      _ = 4 * π * n := by ring
+      _ ≤ ‖cb b 0‖ + 4 * π * n := by linarith
+
+def K0 (L : ℕ) [NeZero L] : ℝ := ∑ b : ZMod L, ‖cb b 0‖
+
+lemma norm_A_le (n : ℕ) : ‖A χ n‖ ≤ K0 L + 4 * π * L * n := by
+  unfold A K0
+  refine (norm_sum_le _ _).trans ?_
+  have : ∀ b ∈ (Finset.univ : Finset (ZMod L)), ‖χ⁻¹ b * cb b n‖ ≤ ‖cb b 0‖ + 4 * π * n := by
+    intro b _
+    rw [norm_mul]
+    have h1 : ‖χ⁻¹ b‖ ≤ 1 := DirichletCharacter.norm_le_one _ _
+    have h2 := norm_cb_le b n
+    have h3 : 0 ≤ ‖cb b n‖ := norm_nonneg _
+    calc ‖χ⁻¹ b‖ * ‖cb b n‖ ≤ 1 * ‖cb b n‖ := by gcongr
+      _ ≤ ‖cb b 0‖ + 4 * π * n := by rw [one_mul]; exact h2
+  refine (Finset.sum_le_sum this).trans ?_
+  rw [Finset.sum_add_distrib, Finset.sum_const, Finset.card_univ, ZMod.card, nsmul_eq_mul]
+  ring_nf
+  rfl
+
+lemma differentiableOn_qseries (a : ℕ → ℂ) (K C : ℝ) (ha : ∀ n, ‖a n‖ ≤ K + C * n) {ε : ℝ}
+    (hε : 0 < ε) :
+    DifferentiableOn ℂ (fun w => ∑' n : ℕ, a n * cexp (2 * π * I * w) ^ n) {w | ε < w.im} := by
+  set r : ℝ := Real.exp (-2 * π * ε) with hr
+  have hr0 : 0 ≤ r := (Real.exp_pos _).le
+  have hr1 : r < 1 := by rw [hr, Real.exp_lt_one_iff]; nlinarith [Real.pi_pos]
+  have hrn : ‖r‖ < 1 := by rw [Real.norm_of_nonneg hr0]; exact hr1
+  have hK : 0 ≤ K := le_trans (norm_nonneg _) (by simpa using ha 0)
+  have hsum : Summable fun n : ℕ => (K + C * n) * r ^ n := by
+    have h1 : Summable fun n : ℕ => K * r ^ n := (summable_geometric_of_lt_one hr0 hr1).mul_left K
+    have h2 : Summable fun n : ℕ => C * ((n : ℝ) ^ 1 * r ^ n) :=
+      (summable_pow_mul_geometric_of_norm_lt_one 1 hrn).mul_left C
+    apply (h1.add h2).congr
+    intro n; ring
+  refine Complex.differentiableOn_tsum_of_summable_norm hsum (fun n => ?_)
+    (isOpen_lt continuous_const Complex.continuous_im) (fun n w hw => ?_)
+  · apply Differentiable.differentiableOn
+    fun_prop
+  · have hw : ε < w.im := hw
+    rw [norm_mul, norm_pow]
+    have h1 : ‖cexp (2 * π * I * w)‖ ≤ r := by
+      rw [Complex.norm_exp]
+      have : (2 * π * I * w).re = -2 * π * w.im := by
+        simp [Complex.mul_re, Complex.mul_im]
+      rw [this, hr]
+      apply Real.exp_le_exp.mpr
+      nlinarith [Real.pi_pos]
+    have h2 : ‖cexp (2 * π * I * w)‖ ^ n ≤ r ^ n := pow_le_pow_left₀ (norm_nonneg _) h1 n
+    have h3 : 0 ≤ K + C * n := le_trans (norm_nonneg _) (ha n)
+    exact mul_le_mul (ha n) h2 (by positivity) h3
+
+theorem E0_mdifferentiable (hL : 3 ≤ L) : MDiff (E0 L χ) := by
+  rw [UpperHalfPlane.mdifferentiable_iff]
+  intro z hz
+  have hz' : 0 < z.im := hz
+  set ε : ℝ := z.im / 2 with hε
+  have hεpos : 0 < ε := by rw [hε]; linarith
+  have hdiff := differentiableOn_qseries (A χ) (K0 L) (4 * π * L) (norm_A_le χ) hεpos
+  have hU : IsOpen {w : ℂ | ε < w.im} := isOpen_lt continuous_const Complex.continuous_im
+  have hzU : z ∈ {w : ℂ | ε < w.im} := by
+    change ε < z.im
+    rw [hε]; linarith
+  have heq : (E0 L χ ∘ ofComplex) =ᶠ[𝓝 z] (fun w => ∑' n : ℕ, A χ n * cexp (2 * π * I * w) ^ n) :=
+    by
+    filter_upwards [hU.mem_nhds hzU] with w hw
+    have hw' : ε < w.im := hw
+    have hw0 : 0 < w.im := lt_trans hεpos hw'
+    simp only [Function.comp_apply, ofComplex_apply_of_im_pos hw0]
+    exact ((hasSum_E0 χ hL ⟨w, hw0⟩).tsum_eq).symm
+  exact ((hdiff.differentiableAt (hU.mem_nhds hzU)).congr_of_eventuallyEq
+    heq).differentiableWithinAt
+
+end qexp
+
+section MF
+
+variable (L : ℕ) [NeZero L] (χ : DirichletCharacter ℂ L)
+
+def E1 (τ : ℍ) : ℂ := (cst χ)⁻¹ * E0 L χ τ
+
+variable {L}
+
+lemma E1_smul (hL : 3 ≤ L) (γ : SL(2, ℤ)) (hγ : γ ∈ CongruenceSubgroup.Gamma0 L) (τ : ℍ) :
+    E1 L χ (γ • τ) = χ ((γ 1 1 : ℤ) : ZMod L) * denom γ τ * E1 L χ τ := by
+  unfold E1
+  rw [E0_smul χ hL γ hγ τ]
+  ring
+
+lemma E1_slash (A : SL(2, ℤ)) :
+    E1 L χ ∣[(1 : ℤ)] A = fun τ => (cst χ)⁻¹ * (E0 L χ ∣[(1 : ℤ)] A) τ := by
+  funext τ
+  simp only [ModularForm.SL_slash_apply, E1]
+  ring
+
+variable (L)
+
+def E1SIF (hL : 3 ≤ L) : SlashInvariantForm (CongruenceSubgroup.Gamma1 L) 1 where
+  toFun := E1 L χ
+  slash_action_eq' A hA := by
+    obtain ⟨γ, hγ, rfl⟩ := hA
+    have hγ' : γ ∈ CongruenceSubgroup.Gamma1 L := hγ
+    rw [CongruenceSubgroup.Gamma1_mem] at hγ'
+    have hγ0 : γ ∈ CongruenceSubgroup.Gamma0 L := by
+      rw [CongruenceSubgroup.Gamma0_mem]; exact hγ'.2.2
+    change E1 L χ ∣[(1 : ℤ)] (γ : GL (Fin 2) ℝ) = E1 L χ
+    funext τ
+    rw [← ModularForm.SL_slash, ModularForm.SL_slash_apply, E1_smul χ hL γ hγ0 τ, hγ'.2.1, map_one]
+    have hD : (denom γ τ : ℂ) ≠ 0 := denom_ne_zero _ τ
+    field_simp
+
+theorem E1_mdifferentiable (hL : 3 ≤ L) : MDiff (E1 L χ) :=
+  (E0_mdifferentiable χ hL).const_smul (cst χ)⁻¹
+
+theorem isBoundedAtImInfty_E1_slash (hL : 3 ≤ L) (A : SL(2, ℤ)) :
+    IsBoundedAtImInfty (E1 L χ ∣[(1 : ℤ)] A) := by
+  rw [E1_slash]
+  exact (Filter.const_boundedAtFilter _ ((cst χ)⁻¹)).mul (isBoundedAtImInfty_E0_slash χ hL A)
+
+def E1MF (hL : 3 ≤ L) : ModularForm (CongruenceSubgroup.Gamma1 L) 1 where
+  toFun := E1 L χ
+  slash_action_eq' := (E1SIF L χ hL).slash_action_eq'
+  holo' := E1_mdifferentiable L χ hL
+  bdd_at_cusps' {c} hc := by
+    rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z] at hc
+    rw [OnePoint.isBoundedAt_iff_forall_SL2Z hc]
+    exact fun γ _ => isBoundedAtImInfty_E1_slash L χ hL γ
+
+lemma E1MF_apply (hL : 3 ≤ L) (τ : ℍ) : E1MF L χ hL τ = E1 L χ τ := rfl
+
+lemma coe_E1MF (hL : 3 ≤ L) : ⇑(E1MF L χ hL) = E1 L χ := rfl
+
+omit [NeZero L] in
+lemma T_mem_Gamma1 : ModularGroup.T ∈ CongruenceSubgroup.Gamma1 L := by
+  rw [CongruenceSubgroup.Gamma1_mem]
+  simp [ModularGroup.coe_T]
+
+lemma periodic_E1MF (hL : 3 ≤ L) : Function.Periodic (⇑(E1MF L χ hL) ∘ ofComplex) (1 : ℝ) := by
+  have hT : ⇑(E1MF L χ hL) ∣[(1 : ℤ)] ModularGroup.T = ⇑(E1MF L χ hL) := by
+    have := SlashInvariantForm.slash_action_eqn (E1MF L χ hL)
+      (Matrix.SpecialLinearGroup.mapGL ℝ ModularGroup.T) ⟨_, T_mem_Gamma1 L, rfl⟩
+    simpa [ModularForm.SL_slash, Matrix.SpecialLinearGroup.mapGL] using this
+  intro w
+  by_cases hw : 0 < w.im
+  · have hw' : 0 < (w + ((1 : ℝ) : ℂ)).im := by simpa using hw
+    simp only [Function.comp_apply]
+    rw [ofComplex_apply_of_im_pos hw', ofComplex_apply_of_im_pos hw]
+    have h1 : (⟨w + ((1 : ℝ) : ℂ), hw'⟩ : ℍ) = ((1 : ℝ)) +ᵥ (⟨w, hw⟩ : ℍ) := by
+      apply UpperHalfPlane.ext; simp [UpperHalfPlane.coe_vadd, add_comm]
+    have h2 := congr_fun hT ⟨w, hw⟩
+    rw [ModularForm.SL_slash_apply, UpperHalfPlane.modular_T_smul, ModularGroup.denom_apply] at h2
+    simp only [Fin.isValue, ModularGroup.coe_T, Matrix.of_apply, Matrix.cons_val',
+      Matrix.cons_val_zero, Matrix.cons_val_fin_one, Matrix.cons_val_one, Int.cast_zero, zero_mul,
+      Int.cast_one, zero_add, Int.reduceNeg, zpow_neg, zpow_ofNat, one_pow, inv_one, mul_one] at h2
+    rw [h1, ← h2]
+  · have hw' : (w + ((1 : ℝ) : ℂ)).im ≤ 0 := by simpa using hw
+    simp only [Function.comp_apply]
+    rw [ofComplex_apply_of_im_nonpos hw', ofComplex_apply_of_im_nonpos (not_lt.mp hw)]
+
+theorem hasSum_E1 (hL : 3 ≤ L) (τ : ℍ) :
+    HasSum (fun n : ℕ => ((cst χ)⁻¹ * A χ n) • Function.Periodic.qParam 1 (τ : ℂ) ^ n)
+      (E1MF L χ hL τ) := by
+  rw [E1MF_apply, E1]
+  refine ((hasSum_E0 χ hL τ).mul_left (cst χ)⁻¹).congr_fun fun n => ?_
+  simp only [Function.Periodic.qParam, smul_eq_mul, Complex.ofReal_one, div_one]
+  ring
+
+theorem qExpansion_coeff_E1MF (hL : 3 ≤ L) (n : ℕ) :
+    (qExpansion 1 ⇑(E1MF L χ hL)).coeff n = (cst χ)⁻¹ * A χ n := by
+  have hbdd : IsBoundedAtImInfty ⇑(E1MF L χ hL) := by
+    have := isBoundedAtImInfty_E1_slash L χ hL 1
+    rwa [SlashAction.slash_one] at this
+  have hA : AnalyticAt ℂ (cuspFunction 1 ⇑(E1MF L χ hL)) 0 :=
+    analyticAt_cuspFunction_zero one_pos (periodic_E1MF L χ hL) (E1_mdifferentiable L χ hL) hbdd
+  exact (qExpansion_coeff_unique (E1MF L χ hL) one_pos hA (hasSum_E1 L χ hL) n).symm
+
+theorem main (hχ : χ.IsPrimitive) (hodd : χ.Odd) :
+    ∃ E : ModularForm (CongruenceSubgroup.Gamma1 L) 1,
+      (∀ γ : SL(2, ℤ), γ ∈ CongruenceSubgroup.Gamma0 L → ∀ τ : UpperHalfPlane,
+        E (γ • τ) =
+          χ ((γ 1 1 : ℤ) : ZMod L) *
+            ((((γ 1 0 : ℤ) : ℂ) * (τ : ℂ) + ((γ 1 1 : ℤ) : ℂ)) ^ (1 : ℤ) * E τ)) ∧
+      ModularFormClass.qCoeff E 0 =
+        -(∑ a ∈ Finset.range L, (a : ℂ) * χ (a : ZMod L)) / (2 * L) ∧
+      ∀ n : ℕ, 0 < n → ModularFormClass.qCoeff E n = ∑ d ∈ n.divisors, χ (d : ZMod L) := by
+  have hL := three_le χ hodd
+  have hc := cst_ne_zero χ hχ
+  refine ⟨E1MF L χ hL, fun γ hγ τ => ?_, ?_, fun n hn => ?_⟩
+  · rw [E1MF_apply, E1MF_apply, E1_smul χ hL γ hγ τ, zpow_one, denom_eq]
+    ring
+  · change (qExpansion 1 ⇑(E1MF L χ hL)).coeff 0 = _
+    rw [qExpansion_coeff_E1MF, A_zero χ hχ hodd, ← mul_assoc, inv_mul_cancel₀ hc, one_mul]
+  · change (qExpansion 1 ⇑(E1MF L χ hL)).coeff n = _
+    rw [qExpansion_coeff_E1MF, A_of_ne_zero χ hχ hodd (Nat.pos_iff_ne_zero.mp hn), ← mul_assoc,
+      inv_mul_cancel₀ hc, one_mul]
+
+end MF
+
+end WZE
+
+end
+
+theorem solution
+    (L : ℕ) [NeZero L] (χ : DirichletCharacter ℂ L) (hχ : χ.IsPrimitive) (hodd : χ.Odd) :
+    ∃ E : ModularForm (CongruenceSubgroup.Gamma1 L) 1,
+      (∀ γ : SL(2, ℤ), γ ∈ CongruenceSubgroup.Gamma0 L → ∀ τ : UpperHalfPlane,
+        E (γ • τ) =
+          χ ((γ 1 1 : ℤ) : ZMod L) *
+            ((((γ 1 0 : ℤ) : ℂ) * (τ : ℂ) + ((γ 1 1 : ℤ) : ℂ)) ^ (1 : ℤ) * E τ)) ∧
+      ModularFormClass.qCoeff E 0 =
+        -(∑ a ∈ Finset.range L, (a : ℂ) * χ (a : ZMod L)) / (2 * L) ∧
+      ∀ n : ℕ, 0 < n → ModularFormClass.qCoeff E n = ∑ d ∈ n.divisors, χ (d : ZMod L) :=
+  WZE.main L χ hχ hodd
+
+end S_ModularForm_exists_weightOne_eisenstein_qCoeff_eq_of_isPrimitive_of_odd
+end P2MW
+export P2MW.S_ModularForm_exists_weightOne_eisenstein_qCoeff_eq_of_isPrimitive_of_odd (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open CongruenceSubgroup
+open scoped MatrixGroups
+theorem ModularForm.exists_weightOne_eisenstein_qCoeff_eq_of_isPrimitive_of_odd
+    (L : ℕ) [NeZero L] (χ : DirichletCharacter ℂ L) (hχ : χ.IsPrimitive) (hodd : χ.Odd) :
+    ∃ E : ModularForm (Gamma1 L) 1,
+      (∀ γ : SL(2, ℤ), γ ∈ Gamma0 L → ∀ τ : UpperHalfPlane,
+        E (γ • τ) =
+          χ ((γ 1 1 : ℤ) : ZMod L) *
+            ((((γ 1 0 : ℤ) : ℂ) * (τ : ℂ) + ((γ 1 1 : ℤ) : ℂ)) ^ (1 : ℤ) * E τ)) ∧
+      ModularFormClass.qCoeff E 0 =
+        -(∑ a ∈ Finset.range L, (a : ℂ) * χ (a : ZMod L)) / (2 * L) ∧
+      ∀ n : ℕ, 0 < n → ModularFormClass.qCoeff E n = ∑ d ∈ n.divisors, χ (d : ZMod L) :=
+  solution L χ hχ hodd
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_weight_one_gamma1_three_slash_fricke_eq_smul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_weight_one_gamma1_three_slash_fricke_eq_smul.lean
new file mode 100644
index 0000000000..53ad64ddb3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_exists_weight_one_gamma1_three_slash_fricke_eq_smul.lean
@@ -0,0 +1,957 @@
+/-
+Based on Prove2Me node ModularForm.exists_weight_one_gamma1_three_slash_fricke_eq_smul
+(a769f48a-f454-5c49-a847-afeb9586a563) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ffd61f4e-61aa-51b3-819a-b2204fa5acb6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+
+import Mathlib.Algebra.Field.ZMod
+import Mathlib.Analysis.Complex.LocallyUniformLimit
+import Mathlib.Data.Int.Star
+import Mathlib.NumberTheory.ModularForms.JacobiTheta.TwoVariable
+import Mathlib.Tactic.NormNum.Prime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_CongruenceSubgroup_closure_T_U_neg_one_eq_Gamma0_three
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HexagonalLattice_summable_thetaTerm_and_tsum_neg_inv_three_mul
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A weight-one form on Γ₁(3) with Fricke eigenvalue -i/√3
+
+Theorem statement: `ModularForm.exists_weight_one_gamma1_three_slash_fricke_eq_smul`
+(`a769f48a-f454-5c49-a847-afeb9586a563`), by Claude, 2026-09-05.
+
+Proof: submission `ffd61f4e-61aa-51b3-819a-b2204fa5acb6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+The assertion is the existence of a modular form $g$ of weight $1$ for the congruence subgroup
+$\Gamma_1(3)$, viewed as a subgroup of $\mathrm{GL}_2(\mathbb{R})$, with three properties. First,
+the $q$-expansion of $g$ in weight $1$ at the cusp $\infty$ has rational coefficients: for every
+natural number $n$ there is a rational number $r$ with the $n$-th coefficient of
+`UpperHalfPlane.qExpansion 1 g` equal to the image of $r$ in $\mathbb{C}$. Second, the coefficient
+of index $0$ of this expansion is $1$. Third, for every element $W$ of $\mathrm{GL}_2(\mathbb{R})$
+whose underlying $2\times 2$ real matrix is the Fricke matrix
+$\begin{pmatrix}0&-1\\3&0\end{pmatrix}$, the weight-$1$ slash action of $W$ on the function
+$\mathbb{H}\to\mathbb{C}$ underlying $g$ equals the scalar multiple of that function by
+$-i/\sqrt{3}$; the quantification over $W$ is over all units of the matrix ring with that prescribed
+matrix, so the identity holds for the Fricke involution however it is presented as an element of
+$\mathrm{GL}_2(\mathbb{R})$.
+
+The form produced is the theta series of the hexagonal lattice, equivalently the weight-one
+Eisenstein series attached to the pair of characters $(\mathbf 1,\chi_{-3})$, whose functional
+equation under $\tau\mapsto -1/(3\tau)$ is Poisson summation for the Eisenstein norm form
+$m^2+mn+n^2$. It is used by
+[`ModularCurve.exists_qExpansion_slash_fricke_eq_and_conj_eq_slash_gamma0`]
+(thm.html#ModularCurve.exists_qExpansion_slash_fricke_eq_and_conj_eq_slash_gamma0),
+where a weight-one form with rational expansion, constant term $1$ and prescribed Fricke eigenvalue
+serves as a normalising factor.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_exists_weight_one_gamma1_three_slash_fricke_eq_smul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_exists_weight_one_gamma1_three_slash_fricke_eq_smul
+
+
+open Complex Real Set
+
+namespace A2Theta3
+namespace LatticeSum
+
+def hexForm (v : ℤ × ℤ) : ℤ :=
+  v.1 ^ 2 + v.1 * v.2 + v.2 ^ 2
+
+@[scoped simp] lemma hexForm_mk (m n : ℤ) : hexForm (m, n) = m ^ 2 + m * n + n ^ 2 := rfl
+
+lemma two_mul_hexForm (v : ℤ × ℤ) :
+    2 * hexForm v = (v.1 + v.2) ^ 2 + v.1 ^ 2 + v.2 ^ 2 := by
+  simp only [hexForm]; ring
+
+lemma hexForm_nonneg (v : ℤ × ℤ) : 0 ≤ hexForm v := by
+  obtain ⟨a, b⟩ := v
+  simp only [hexForm_mk]
+  nlinarith [sq_nonneg (a + b), sq_nonneg a, sq_nonneg b]
+
+lemma hexForm_eq_zero_iff (v : ℤ × ℤ) : hexForm v = 0 ↔ v = (0, 0) := by
+  obtain ⟨a, b⟩ := v
+  simp only [hexForm_mk, Prod.mk.injEq]
+  constructor
+  · intro h
+    constructor <;> nlinarith [sq_nonneg (a + b), sq_nonneg a, sq_nonneg b, sq_nonneg (a - b)]
+  · rintro ⟨rfl, rfl⟩; ring
+
+lemma sq_add_sq_le_two_mul_hexForm (v : ℤ × ℤ) :
+    v.1 ^ 2 + v.2 ^ 2 ≤ 2 * hexForm v := by
+  obtain ⟨a, b⟩ := v
+  simp only [hexForm_mk]
+  nlinarith [sq_nonneg (a + b)]
+
+def hexFormNat (v : ℤ × ℤ) : ℕ :=
+  (hexForm v).toNat
+
+@[scoped simp] lemma coe_hexFormNat (v : ℤ × ℤ) : (hexFormNat v : ℤ) = hexForm v :=
+  Int.toNat_of_nonneg (hexForm_nonneg v)
+
+lemma hexFormNat_eq_iff (v : ℤ × ℤ) (n : ℕ) : hexFormNat v = n ↔ hexForm v = (n : ℤ) := by
+  rw [← coe_hexFormNat, Int.natCast_inj]
+
+@[scoped simp] lemma hexFormNat_zero : hexFormNat (0, 0) = 0 := by
+  rw [hexFormNat_eq_iff]; rfl
+
+noncomputable def latticeTerm (τ : ℂ) (v : ℤ × ℤ) : ℂ :=
+  Complex.exp (2 * (π : ℂ) * Complex.I * (hexFormNat v : ℂ) * τ)
+
+lemma norm_latticeTerm (τ : ℂ) (v : ℤ × ℤ) :
+    ‖latticeTerm τ v‖ = Real.exp (-(2 * π * (hexFormNat v : ℝ) * τ.im)) := by
+  rw [latticeTerm, show (2 * (π : ℂ) * Complex.I * (hexFormNat v : ℂ) * τ)
+      = ((2 * π * (hexFormNat v : ℝ) : ℝ) : ℂ) * τ * Complex.I by push_cast; ring]
+  rw [Complex.norm_exp, mul_I_re, im_ofReal_mul]
+
+lemma norm_latticeTerm_le_of_le_im {T : ℝ} (hT : 0 < T) {τ : ℂ} (hτ : T ≤ τ.im) (v : ℤ × ℤ) :
+    ‖latticeTerm τ v‖ ≤
+      Real.exp (-(π * T * (v.1 : ℝ) ^ 2)) * Real.exp (-(π * T * (v.2 : ℝ) ^ 2)) := by
+  rw [norm_latticeTerm, ← Real.exp_add, Real.exp_le_exp]
+  have hQ : (v.1 : ℝ) ^ 2 + (v.2 : ℝ) ^ 2 ≤ 2 * (hexFormNat v : ℝ) := by
+    have := sq_add_sq_le_two_mul_hexForm v
+    have h2 : ((2 * hexForm v : ℤ) : ℝ) = 2 * (hexFormNat v : ℝ) := by
+      push_cast [coe_hexFormNat]; ring_nf
+      norm_cast
+      simp [coe_hexFormNat]
+    calc (v.1 : ℝ) ^ 2 + (v.2 : ℝ) ^ 2 = ((v.1 ^ 2 + v.2 ^ 2 : ℤ) : ℝ) := by push_cast; ring
+      _ ≤ ((2 * hexForm v : ℤ) : ℝ) := by exact_mod_cast this
+      _ = 2 * (hexFormNat v : ℝ) := h2
+  have hQ0 : (0 : ℝ) ≤ (hexFormNat v : ℝ) := Nat.cast_nonneg _
+  nlinarith [mul_le_mul_of_nonneg_left hQ (by positivity : (0 : ℝ) ≤ π * T),
+    mul_le_mul_of_nonneg_left hτ (by positivity : (0 : ℝ) ≤ 2 * π * (hexFormNat v : ℝ))]
+
+lemma summable_gaussian_int {t : ℝ} (ht : 0 < t) :
+    Summable fun m : ℤ ↦ Real.exp (-(π * t * (m : ℝ) ^ 2)) := by
+  have h := summable_pow_mul_jacobiTheta₂_term_bound 0 ht 0
+  simpa only [pow_zero, one_mul, mul_zero, zero_mul, sub_zero, neg_mul, mul_assoc] using h
+
+lemma summable_gaussian_prod {t : ℝ} (ht : 0 < t) :
+    Summable fun v : ℤ × ℤ ↦
+      Real.exp (-(π * t * (v.1 : ℝ) ^ 2)) * Real.exp (-(π * t * (v.2 : ℝ) ^ 2)) :=
+  (summable_gaussian_int ht).mul_of_nonneg (summable_gaussian_int ht)
+    (fun _ ↦ (Real.exp_pos _).le) (fun _ ↦ (Real.exp_pos _).le)
+
+theorem summable_latticeTerm {τ : ℂ} (hτ : 0 < τ.im) : Summable (latticeTerm τ) :=
+  (summable_gaussian_prod hτ).of_norm_bounded (norm_latticeTerm_le_of_le_im hτ le_rfl)
+
+theorem not_summable_latticeTerm_zero : ¬ Summable (latticeTerm 0) := by
+  have h : latticeTerm 0 = fun _ ↦ (1 : ℂ) := by
+    funext v; simp [latticeTerm]
+  rw [h, summable_const_iff]
+  exact one_ne_zero
+
+noncomputable def latticeSum (τ : ℂ) : ℂ :=
+  ∑' v : ℤ × ℤ, latticeTerm τ v
+
+lemma finite_fiber_hexFormNat (n : ℕ) : (hexFormNat ⁻¹' {n}).Finite := by
+  apply Set.Finite.subset
+    ((Finset.Icc (-(2 * n : ℤ)) (2 * n) ×ˢ Finset.Icc (-(2 * n : ℤ)) (2 * n)).finite_toSet)
+  rintro ⟨a, b⟩ hv
+  simp only [Set.mem_preimage, Set.mem_singleton_iff, hexFormNat_eq_iff] at hv
+  have hbox : a ^ 2 + b ^ 2 ≤ 2 * (n : ℤ) := by
+    have := sq_add_sq_le_two_mul_hexForm (a, b)
+    simp only [hexForm_mk] at this hv
+    omega
+  have ha2 : a ^ 2 ≤ 2 * (n : ℤ) := by nlinarith [sq_nonneg b]
+  have hb2 : b ^ 2 ≤ 2 * (n : ℤ) := by nlinarith [sq_nonneg a]
+  simp only [Finset.coe_product, Set.mem_prod, Finset.mem_coe, Finset.mem_Icc]
+  refine ⟨⟨?_, ?_⟩, ?_, ?_⟩
+  · nlinarith [Int.le_self_sq (-a)]
+  · nlinarith [Int.le_self_sq a]
+  · nlinarith [Int.le_self_sq (-b)]
+  · nlinarith [Int.le_self_sq b]
+
+noncomputable def repCount (n : ℕ) : ℕ :=
+  (hexFormNat ⁻¹' {n}).ncard
+
+@[scoped simp] theorem repCount_zero : repCount 0 = 1 := by
+  have h : hexFormNat ⁻¹' {0} = {((0 : ℤ), (0 : ℤ))} := by
+    ext v
+    simp only [Set.mem_preimage, Set.mem_singleton_iff, hexFormNat_eq_iff, Int.natCast_zero,
+      hexForm_eq_zero_iff]
+  rw [repCount, h, Set.ncard_singleton]
+
+lemma tsum_fiber_eq (τ : ℂ) (n : ℕ) :
+    ∑' v : (hexFormNat ⁻¹' {n}), latticeTerm τ v
+      = (repCount n : ℂ) * Complex.exp (2 * (π : ℂ) * Complex.I * (n : ℂ) * τ) := by
+  have hconst : ∀ v : (hexFormNat ⁻¹' {n}),
+      latticeTerm τ v = Complex.exp (2 * (π : ℂ) * Complex.I * (n : ℂ) * τ) := by
+    rintro ⟨v, hv⟩
+    simp only [Set.mem_preimage, Set.mem_singleton_iff] at hv
+    simp [latticeTerm, hv]
+  rw [tsum_congr hconst, tsum_const, Nat.card_coe_set_eq, nsmul_eq_mul, repCount]
+
+theorem hasSum_repCount_qpow {τ : ℂ} (hτ : 0 < τ.im) :
+    HasSum (fun n : ℕ ↦ (repCount n : ℂ) * Complex.exp (2 * (π : ℂ) * Complex.I * (n : ℂ) * τ))
+      (latticeSum τ) := by
+  have h := ((summable_latticeTerm hτ).hasSum).tsum_fiberwise hexFormNat
+  simp only [tsum_fiber_eq τ] at h
+  exact h
+
+theorem latticeSum_eq_tsum_repCount {τ : ℂ} (hτ : 0 < τ.im) :
+    latticeSum τ
+      = ∑' n : ℕ, (repCount n : ℂ) * Complex.exp (2 * (π : ℂ) * Complex.I * (n : ℂ) * τ) :=
+  (hasSum_repCount_qpow hτ).tsum_eq.symm
+
+end A2Theta3.LatticeSum
+
+namespace A2Theta3
+
+noncomputable section
+
+open Complex Real
+
+def hexThetaTerm (σ : ℂ) (p : ℤ × ℤ) : ℂ :=
+  cexp (2 * π * I * σ * ((p.1 : ℂ) ^ 2 + (p.1 : ℂ) * (p.2 : ℂ) + (p.2 : ℂ) ^ 2))
+
+def hexTheta (σ : ℂ) : ℂ :=
+  ∑' p : ℤ × ℤ, hexThetaTerm σ p
+
+lemma ne_zero_of_im_pos {σ : ℂ} (hσ : 0 < σ.im) : σ ≠ 0 := by
+  rintro rfl
+  simp at hσ
+
+lemma im_neg_one_div_three_mul_pos {σ : ℂ} (hσ : 0 < σ.im) : 0 < (-1 / (3 * σ)).im := by
+  have h3σ : (3 : ℂ) * σ ≠ 0 := mul_ne_zero (by norm_num) (ne_zero_of_im_pos hσ)
+  have him : ((3 : ℂ) * σ).im = 3 * σ.im := by
+    simp [Complex.mul_im]
+  rw [show (-1 / (3 * σ) : ℂ) = -((3 : ℂ) * σ)⁻¹ by rw [neg_div, one_div]]
+  rw [Complex.neg_im, Complex.inv_im, neg_div, neg_neg, him]
+  exact div_pos (by linarith) (Complex.normSq_pos.mpr h3σ)
+
+lemma sqrt_three_ne_zero : ((Real.sqrt 3 : ℝ) : ℂ) ≠ 0 :=
+  Complex.ofReal_ne_zero.mpr (Real.sqrt_pos.mpr (by norm_num)).ne'
+
+theorem hexTheta_fricke {σ : ℂ} (hσ : 0 < σ.im) :
+    hexTheta (-1 / (3 * σ)) = -I * (Real.sqrt 3 : ℂ) * σ * hexTheta σ :=
+  (HexagonalLattice.summable_thetaTerm_and_tsum_neg_inv_three_mul σ hσ).2
+
+end
+end A2Theta3
+
+open Matrix CongruenceSubgroup Subgroup ModularForm UpperHalfPlane
+open scoped MatrixGroups ModularForm Manifold Pointwise
+
+namespace A2Theta3
+
+namespace Gamma0Three
+
+def repOfLabel : Option (ZMod 3) → SL(2, ℤ)
+  | none => 1
+  | some k => ⟨!![0, -1; 1, (k.val : ℤ)], by simp [Matrix.det_fin_two_of]⟩
+
+@[scoped simp] lemma repOfLabel_none : repOfLabel none = 1 := rfl
+
+@[scoped simp] lemma repOfLabel_some_one_zero (k : ZMod 3) : repOfLabel (some k) 1 0 = 1 := rfl
+
+@[scoped simp] lemma repOfLabel_some_one_one (k : ZMod 3) :
+    repOfLabel (some k) 1 1 = (k.val : ℤ) := rfl
+
+@[scoped simp] lemma one_apply_one_zero : (1 : SL(2, ℤ)) 1 0 = 0 := rfl
+
+@[scoped simp] lemma one_apply_one_one : (1 : SL(2, ℤ)) 1 1 = 1 := rfl
+
+def transversal : Set SL(2, ℤ) := Set.range repOfLabel
+
+lemma one_mem_transversal : (1 : SL(2, ℤ)) ∈ transversal := ⟨none, rfl⟩
+
+def label (g : SL(2, ℤ)) : Option (ZMod 3) :=
+  if (g 1 0 : ZMod 3) = 0 then none
+  else some ((g 1 1 : ZMod 3) / (g 1 0 : ZMod 3))
+
+private lemma intCast_val (k : ZMod 3) : (((k.val : ℕ) : ℤ) : ZMod 3) = k := by
+  exact_mod_cast ZMod.natCast_rightInverse k
+
+lemma apply_one_one_ne_zero (g : SL(2, ℤ)) (hc : (g 1 0 : ZMod 3) = 0) :
+    (g 1 1 : ZMod 3) ≠ 0 := by
+  intro hd
+  have hdet : (g 0 0 : ℤ) * g 1 1 - g 0 1 * g 1 0 = 1 := by
+    have h2 := g.2
+    rw [Matrix.det_fin_two] at h2
+    exact h2
+  have hcast : (g 0 0 : ZMod 3) * (g 1 1 : ZMod 3)
+      - (g 0 1 : ZMod 3) * (g 1 0 : ZMod 3) = 1 := by
+    have h3 : (((g 0 0 : ℤ) * g 1 1 - g 0 1 * g 1 0 : ℤ) : ZMod 3) = ((1 : ℤ) : ZMod 3) := by
+      rw [hdet]
+    push_cast at h3
+    exact h3
+  rw [hc, hd, mul_zero, mul_zero, sub_zero] at hcast
+  exact zero_ne_one hcast
+
+private theorem mul_entry (A B : SL(2, ℤ)) (i j : Fin 2) :
+    (A * B) i j = A i 0 * B 0 j + A i 1 * B 1 j := by
+  show ((A * B : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) i j = _
+  rw [Matrix.SpecialLinearGroup.coe_mul, Matrix.mul_apply, Fin.sum_univ_two]
+
+private theorem inv_entries (A : SL(2, ℤ)) :
+    A⁻¹ 0 0 = A 1 1 ∧ A⁻¹ 0 1 = -A 0 1 ∧ A⁻¹ 1 0 = -A 1 0 ∧ A⁻¹ 1 1 = A 0 0 := by
+  have h : ((A⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) =
+      !![A 1 1, -A 0 1; -A 1 0, A 0 0] := by
+    rw [Matrix.SpecialLinearGroup.coe_inv, Matrix.adjugate_fin_two]
+  refine ⟨?_, ?_, ?_, ?_⟩ <;> simp [h]
+
+lemma mul_inv_apply_one_zero (g h : SL(2, ℤ)) :
+    (g * h⁻¹) 1 0 = g 1 0 * h 1 1 - g 1 1 * h 1 0 := by
+  rw [mul_entry, (inv_entries h).1, (inv_entries h).2.2.1]
+  ring
+
+theorem mul_inv_mem_iff (g h : SL(2, ℤ)) :
+    g * h⁻¹ ∈ Gamma0 3 ↔
+      (g 1 0 : ZMod 3) * (h 1 1 : ZMod 3) = (g 1 1 : ZMod 3) * (h 1 0 : ZMod 3) := by
+  rw [Gamma0_mem, mul_inv_apply_one_zero]
+  push_cast
+  exact sub_eq_zero
+
+theorem mul_inv_repOfLabel_mem_iff (g : SL(2, ℤ)) (l : Option (ZMod 3)) :
+    g * (repOfLabel l)⁻¹ ∈ Gamma0 3 ↔ l = label g := by
+  rw [mul_inv_mem_iff]
+  unfold label
+  cases l with
+  | none =>
+    rw [repOfLabel_none, one_apply_one_one, one_apply_one_zero, Int.cast_one, mul_one,
+      Int.cast_zero, mul_zero]
+    by_cases hc : (g 1 0 : ZMod 3) = 0
+    · rw [ite_eq_left hc]
+      exact iff_of_true hc rfl
+    · rw [ite_eq_right hc]
+      exact iff_of_false hc (by simp)
+  | some k =>
+    rw [repOfLabel_some_one_one, repOfLabel_some_one_zero, Int.cast_one, mul_one,
+      intCast_val]
+    by_cases hc : (g 1 0 : ZMod 3) = 0
+    · rw [ite_eq_left hc]
+      refine iff_of_false (fun hcontra => ?_) (by simp)
+      rw [hc, zero_mul] at hcontra
+      exact apply_one_one_ne_zero g hc hcontra.symm
+    · rw [ite_eq_right hc, Option.some_inj, eq_div_iff hc]
+      constructor <;> intro h <;> linear_combination h
+
+theorem isComplement_transversal :
+    IsComplement (Gamma0 3 : Set SL(2, ℤ)) transversal := by
+  rw [isComplement_iff_existsUnique_mul_inv_mem]
+  intro g
+  refine ⟨⟨repOfLabel (label g), ⟨label g, rfl⟩⟩, ?_, ?_⟩
+  · exact (mul_inv_repOfLabel_mem_iff g (label g)).mpr rfl
+  · rintro ⟨x, l, rfl⟩ ht
+    exact Subtype.ext (congrArg repOfLabel ((mul_inv_repOfLabel_mem_iff g l).mp ht))
+
+lemma coe_toRightFun (g : SL(2, ℤ)) :
+    (isComplement_transversal.toRightFun g : SL(2, ℤ)) = repOfLabel (label g) := by
+  have huniq := isComplement_iff_existsUnique_mul_inv_mem.mp isComplement_transversal g
+  have h1 : g * ((isComplement_transversal.toRightFun g : SL(2, ℤ)))⁻¹
+      ∈ (Gamma0 3 : Set SL(2, ℤ)) :=
+    isComplement_transversal.mul_inv_toRightFun_mem g
+  have h2 : g * (((⟨repOfLabel (label g), ⟨label g, rfl⟩⟩ : transversal) : SL(2, ℤ)))⁻¹
+      ∈ (Gamma0 3 : Set SL(2, ℤ)) :=
+    (mul_inv_repOfLabel_mem_iff g (label g)).mpr rfl
+  exact congrArg Subtype.val (huniq.unique h1 h2)
+
+end Gamma0Three
+
+def U₃ : SL(2, ℤ) := ⟨!![1, 0; -3, 1], by simp [Matrix.det_fin_two_of]⟩
+
+@[scoped simp] lemma U₃_one_zero : U₃ 1 0 = -3 := rfl
+@[scoped simp] lemma U₃_one_one : U₃ 1 1 = 1 := rfl
+
+lemma T_mem_gamma0_three : ModularGroup.T ∈ Gamma0 3 := by
+  rw [Gamma0_mem]; decide
+
+lemma U₃_mem_gamma0_three : U₃ ∈ Gamma0 3 := by
+  rw [Gamma0_mem]; decide
+
+lemma neg_one_mem_gamma0_three : (-1 : SL(2, ℤ)) ∈ Gamma0 3 := by
+  rw [Gamma0_mem]; decide
+
+def gens : Set SL(2, ℤ) := {ModularGroup.T, U₃, -1}
+
+lemma gens_subset_gamma0_three : gens ⊆ (Gamma0 3 : Subgroup SL(2, ℤ)) := by
+  rintro x (rfl | rfl | rfl)
+  · exact T_mem_gamma0_three
+  · exact U₃_mem_gamma0_three
+  · exact neg_one_mem_gamma0_three
+
+theorem closure_T_U_neg_one_eq : Subgroup.closure gens = Gamma0 3 :=
+  CongruenceSubgroup.closure_T_U_neg_one_eq_Gamma0_three U₃ rfl
+
+def chi3 (γ : SL(2, ℤ)) : ℤ :=
+  if (γ 1 1 : ZMod 3) = 1 then 1 else -1
+
+lemma chi3_eq_one_or_neg_one (γ : SL(2, ℤ)) : chi3 γ = 1 ∨ chi3 γ = -1 := by
+  unfold chi3; split <;> simp
+
+lemma chi3_mul_self (γ : SL(2, ℤ)) : chi3 γ * chi3 γ = 1 := by
+  rcases chi3_eq_one_or_neg_one γ with h | h <;> rw [h] <;> norm_num
+
+@[scoped simp] lemma chi3_one : chi3 1 = 1 := by unfold chi3; norm_num
+
+@[scoped simp] lemma chi3_T : chi3 ModularGroup.T = 1 := by
+  unfold chi3; rw [show (ModularGroup.T 1 1 : ZMod 3) = 1 by decide]; simp
+
+@[scoped simp] lemma chi3_U₃ : chi3 U₃ = 1 := by
+  unfold chi3; rw [show (U₃ 1 1 : ZMod 3) = 1 by decide]; simp
+
+@[scoped simp] lemma chi3_neg_one : chi3 (-1 : SL(2, ℤ)) = -1 := by
+  unfold chi3; rw [show ((-1 : SL(2, ℤ)) 1 1 : ZMod 3) = 2 by decide]; decide
+
+lemma apply_one_one_ne_zero_of_mem {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 3) :
+    (γ 1 1 : ZMod 3) ≠ 0 :=
+  Gamma0Three.apply_one_one_ne_zero γ (Gamma0_mem.mp hγ)
+
+lemma coe_mul_apply_one_one {γ δ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 3) (hδ : δ ∈ Gamma0 3) :
+    ((γ * δ) 1 1 : ZMod 3) = (γ 1 1 : ZMod 3) * (δ 1 1 : ZMod 3) := by
+  have := map_mul (Gamma0Map 3) (⟨γ, hγ⟩ : Gamma0 3) (⟨δ, hδ⟩ : Gamma0 3)
+  simpa [Gamma0Map] using this
+
+theorem chi3_mul {γ δ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 3) (hδ : δ ∈ Gamma0 3) :
+    chi3 (γ * δ) = chi3 γ * chi3 δ := by
+  have key : ∀ x : ZMod 3, x ≠ 0 → x = 1 ∨ x = 2 := by decide
+  unfold chi3
+  rw [coe_mul_apply_one_one hγ hδ]
+  rcases key _ (apply_one_one_ne_zero_of_mem hγ) with h1 | h1 <;>
+    rcases key _ (apply_one_one_ne_zero_of_mem hδ) with h2 | h2 <;>
+      rw [h1, h2] <;> decide
+
+theorem chi3_eq_one_of_mem_Gamma1 {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma1 3) : chi3 γ = 1 := by
+  unfold chi3
+  rw [((Gamma1_mem 3 γ).mp hγ).2.1]
+  simp
+
+section Sweep
+
+variable (F : ℍ → ℂ)
+
+theorem slash_neg_one :
+    F ∣[(1 : ℤ)] (-1 : SL(2, ℤ)) = ((chi3 (-1 : SL(2, ℤ)) : ℤ) : ℂ) • F := by
+  rw [chi3_neg_one]
+  ext τ
+  rw [ModularForm.SL_slash_apply]
+  have hsmul : ((-1 : SL(2, ℤ)) • τ : ℍ) = τ := by
+    rw [show (-1 : SL(2, ℤ)) = -(1 : SL(2, ℤ)) from rfl, ModularGroup.SL_neg_smul, one_smul]
+  have hden : denom (-1 : SL(2, ℤ)) τ = -1 := by
+    rw [ModularGroup.denom_apply]
+    norm_num [show ((-1 : SL(2, ℤ)) 1 0) = 0 from rfl, show ((-1 : SL(2, ℤ)) 1 1) = -1 from rfl]
+  rw [hsmul, hden]
+  have hpow : ((-1 : ℂ)) ^ (-(1 : ℤ)) = -1 := by norm_num
+  rw [hpow]
+  simp only [Pi.smul_apply, smul_eq_mul]
+  push_cast
+  ring
+
+theorem slash_eq_chi3_smul
+    (hT : F ∣[(1 : ℤ)] ModularGroup.T = F) (hU : F ∣[(1 : ℤ)] U₃ = F)
+    {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma0 3) :
+    F ∣[(1 : ℤ)] γ = (chi3 γ : ℂ) • F := by
+  let p : (g : SL(2, ℤ)) → g ∈ Subgroup.closure gens → Prop :=
+    fun g _ => F ∣[(1 : ℤ)] g = (chi3 g : ℂ) • F
+  have hmem_iff : ∀ {g : SL(2, ℤ)}, g ∈ Subgroup.closure gens ↔ g ∈ Gamma0 3 := by
+    intro g; rw [closure_T_U_neg_one_eq]
+  refine Subgroup.closure_induction (k := gens) (p := p) ?_ ?_ ?_ ?_ (hmem_iff.mpr hγ)
+  · rintro x (rfl | rfl | rfl)
+    · change F ∣[(1 : ℤ)] ModularGroup.T = (chi3 ModularGroup.T : ℂ) • F
+      rw [hT, chi3_T]; simp
+    · change F ∣[(1 : ℤ)] U₃ = (chi3 U₃ : ℂ) • F
+      rw [hU, chi3_U₃]; simp
+    · exact slash_neg_one F
+  · change F ∣[(1 : ℤ)] (1 : SL(2, ℤ)) = (chi3 1 : ℂ) • F
+    rw [SlashAction.slash_one, chi3_one]
+    simp
+  · intro x y hx hy hpx hpy
+    change F ∣[(1 : ℤ)] (x * y) = (chi3 (x * y) : ℂ) • F
+    have hx' : x ∈ Gamma0 3 := hmem_iff.mp hx
+    have hy' : y ∈ Gamma0 3 := hmem_iff.mp hy
+    calc F ∣[(1 : ℤ)] (x * y) = (F ∣[(1 : ℤ)] x) ∣[(1 : ℤ)] y := by
+            rw [SlashAction.slash_mul]
+      _ = ((chi3 x : ℂ) • F) ∣[(1 : ℤ)] y := by rw [hpx]
+      _ = (chi3 x : ℂ) • (F ∣[(1 : ℤ)] y) := by rw [ModularForm.SL_smul_slash]
+      _ = (chi3 x : ℂ) • ((chi3 y : ℂ) • F) := by rw [hpy]
+      _ = ((chi3 x * chi3 y : ℤ) : ℂ) • F := by rw [smul_smul]; norm_num
+      _ = (chi3 (x * y) : ℂ) • F := by rw [← chi3_mul hx' hy']
+  · intro x hx hpx
+    change F ∣[(1 : ℤ)] x⁻¹ = (chi3 x⁻¹ : ℂ) • F
+    have hx' : x ∈ Gamma0 3 := hmem_iff.mp hx
+    have hxinv : x⁻¹ ∈ Gamma0 3 := inv_mem hx'
+    have hchi : chi3 x⁻¹ = chi3 x := by
+      have h1 : chi3 (x⁻¹ * x) = chi3 x⁻¹ * chi3 x := chi3_mul hxinv hx'
+      rw [inv_mul_cancel, chi3_one] at h1
+      rcases chi3_eq_one_or_neg_one x with h | h <;>
+        rcases chi3_eq_one_or_neg_one x⁻¹ with h' | h' <;> rw [h, h'] <;> rw [h, h'] at h1 <;>
+          omega
+    have h2 : (F ∣[(1 : ℤ)] x) ∣[(1 : ℤ)] x⁻¹ = ((chi3 x : ℂ) • F) ∣[(1 : ℤ)] x⁻¹ := by
+      rw [hpx]
+    rw [← SlashAction.slash_mul, mul_inv_cancel, SlashAction.slash_one,
+      ModularForm.SL_smul_slash] at h2
+    have h3 := congrArg (fun G => (chi3 x : ℂ) • G) h2
+    simp only [smul_smul] at h3
+    rw [show ((chi3 x : ℂ) * (chi3 x : ℂ)) = ((chi3 x * chi3 x : ℤ) : ℂ) by push_cast; ring,
+      chi3_mul_self] at h3
+    rw [hchi]
+    simpa using h3.symm
+
+theorem slash_eq_self_of_mem_Gamma1
+    (hT : F ∣[(1 : ℤ)] ModularGroup.T = F) (hU : F ∣[(1 : ℤ)] U₃ = F)
+    {γ : SL(2, ℤ)} (hγ : γ ∈ Gamma1 3) :
+    F ∣[(1 : ℤ)] γ = F := by
+  rw [slash_eq_chi3_smul F hT hU (Gamma1_in_Gamma0 3 hγ), chi3_eq_one_of_mem_Gamma1 hγ]
+  simp
+
+end Sweep
+section Packaging
+
+def slashInvariantForm_of_T_U (F : ℍ → ℂ)
+    (hT : F ∣[(1 : ℤ)] ModularGroup.T = F) (hU : F ∣[(1 : ℤ)] U₃ = F) :
+    SlashInvariantForm (Gamma1 3) 1 where
+  toFun := F
+  slash_action_eq' := by
+    rintro γ ⟨δ, hδ, rfl⟩
+    exact slash_eq_self_of_mem_Gamma1 F hT hU hδ
+
+@[scoped simp] lemma coe_slashInvariantForm_of_T_U (F : ℍ → ℂ)
+    (hT : F ∣[(1 : ℤ)] ModularGroup.T = F) (hU : F ∣[(1 : ℤ)] U₃ = F) :
+    ⇑(slashInvariantForm_of_T_U F hT hU) = F := rfl
+
+end Packaging
+end A2Theta3
+
+open Complex Real Matrix CongruenceSubgroup Subgroup ModularForm UpperHalfPlane
+open A2Theta3.LatticeSum
+open scoped MatrixGroups ModularForm Manifold
+
+namespace A2Theta3
+
+noncomputable section
+
+lemma latticeTerm_eq_hexThetaTerm (τ : ℂ) (v : ℤ × ℤ) :
+    latticeTerm τ v = hexThetaTerm τ v := by
+  unfold latticeTerm hexThetaTerm
+  congr 1
+  have h : ((hexFormNat v : ℤ) : ℂ) = (v.1 : ℂ) ^ 2 + (v.1 : ℂ) * (v.2 : ℂ) + (v.2 : ℂ) ^ 2 := by
+    rw [coe_hexFormNat]
+    unfold hexForm
+    push_cast
+    ring
+  push_cast at h
+  rw [h]
+  ring
+
+theorem latticeSum_eq_hexTheta (τ : ℂ) : latticeSum τ = hexTheta τ :=
+  tsum_congr fun v => latticeTerm_eq_hexThetaTerm τ v
+
+def hexThetaH : ℍ → ℂ := fun τ => latticeSum (τ : ℂ)
+
+@[scoped simp] lemma hexThetaH_apply (τ : ℍ) : hexThetaH τ = latticeSum (τ : ℂ) := rfl
+
+lemma hexThetaH_eq_hexTheta (τ : ℍ) : hexThetaH τ = hexTheta (τ : ℂ) :=
+  latticeSum_eq_hexTheta _
+
+lemma hexThetaTerm_add_one (σ : ℂ) (v : ℤ × ℤ) :
+    hexThetaTerm (σ + 1) v = hexThetaTerm σ v := by
+  rw [← latticeTerm_eq_hexThetaTerm, ← latticeTerm_eq_hexThetaTerm]
+  unfold latticeTerm
+  rw [show 2 * (π : ℂ) * Complex.I * (hexFormNat v : ℂ) * (σ + 1)
+      = 2 * (π : ℂ) * Complex.I * (hexFormNat v : ℂ) * σ
+        + (hexFormNat v : ℂ) * (2 * (π : ℂ) * Complex.I) by ring,
+    Complex.exp_add, Complex.exp_nat_mul_two_pi_mul_I, mul_one]
+
+theorem hexTheta_add_one (σ : ℂ) : hexTheta (σ + 1) = hexTheta σ :=
+  tsum_congr fun v => hexThetaTerm_add_one σ v
+
+theorem hexThetaH_slash_T : hexThetaH ∣[(1 : ℤ)] ModularGroup.T = hexThetaH := by
+  funext z
+  refine (slash_action_eq'_iff 1 hexThetaH ModularGroup.T z).mpr ?_
+  rw [show ModularGroup.T 1 0 = 0 from rfl, show ModularGroup.T 1 1 = 1 from rfl,
+    modular_T_smul]
+  simp only [Int.cast_zero, Int.cast_one, zero_mul, zero_add, zpow_one, one_mul]
+  change latticeSum (((1 : ℝ) +ᵥ z : ℍ) : ℂ) = latticeSum (z : ℂ)
+  rw [UpperHalfPlane.coe_vadd, latticeSum_eq_hexTheta, latticeSum_eq_hexTheta,
+    Complex.ofReal_one, add_comm, hexTheta_add_one]
+
+lemma sqrt_three_mul_sqrt_three : ((Real.sqrt 3 : ℝ) : ℂ) * ((Real.sqrt 3 : ℝ) : ℂ) = 3 := by
+  rw [← Complex.ofReal_mul, Real.mul_self_sqrt (by norm_num : (0 : ℝ) ≤ 3)]
+  norm_num
+
+lemma U_denom_ne_zero {z : ℂ} (hz : 0 < z.im) : (-3 : ℂ) * z + 1 ≠ 0 := by
+  intro h
+  have him : ((-3 : ℂ) * z + 1).im = -3 * z.im := by
+    simp [Complex.add_im, Complex.mul_im]
+  rw [h] at him
+  simp only [Complex.zero_im] at him
+  nlinarith
+
+lemma U_smul_eq_fricke_translate_fricke {z : ℂ} (hz : 0 < z.im) :
+    z / ((-3) * z + 1) = -1 / (3 * (-1 / (3 * z) + 1)) := by
+  have hz0 : z ≠ 0 := ne_zero_of_im_pos hz
+  have hden : (-3 : ℂ) * z + 1 ≠ 0 := U_denom_ne_zero hz
+  have h1 : (3 : ℂ) * (-1 / (3 * z) + 1) = (3 * z - 1) / z := by
+    field_simp
+    ring
+  have h2 : ((3 : ℂ) * z - 1) / z ≠ 0 := by
+    refine div_ne_zero (fun h => hden ?_) hz0
+    linear_combination -h
+  rw [h1, div_eq_div_iff hden h2, mul_div_assoc', div_eq_iff hz0]
+  ring
+
+lemma fricke_double_multiplier {z : ℂ} (hz : 0 < z.im) :
+    -Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * (-1 / (3 * z) + 1)
+      * (-Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * z) = (-3) * z + 1 := by
+  have hz0 : z ≠ 0 := ne_zero_of_im_pos hz
+  have key : (-1 / (3 * z) + 1) * z = z - 1 / 3 := by
+    field_simp
+    ring
+  calc -Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * (-1 / (3 * z) + 1)
+        * (-Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * z)
+      = (Complex.I * Complex.I) * (((Real.sqrt 3 : ℝ) : ℂ) * ((Real.sqrt 3 : ℝ) : ℂ))
+          * ((-1 / (3 * z) + 1) * z) := by ring
+    _ = (-1) * 3 * (z - 1 / 3) := by rw [Complex.I_mul_I, sqrt_three_mul_sqrt_three, key]
+    _ = (-3) * z + 1 := by ring
+
+theorem hexTheta_U_law {z : ℂ} (hz : 0 < z.im) :
+    hexTheta (z / ((-3) * z + 1)) = ((-3) * z + 1) * hexTheta z := by
+  have hσ : 0 < (-1 / (3 * z)).im := im_neg_one_div_three_mul_pos hz
+  have hσ1 : 0 < (-1 / (3 * z) + 1).im := by
+    rwa [Complex.add_im, Complex.one_im, add_zero]
+  calc hexTheta (z / ((-3) * z + 1))
+      = hexTheta (-1 / (3 * (-1 / (3 * z) + 1))) := by
+        rw [U_smul_eq_fricke_translate_fricke hz]
+    _ = -Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * (-1 / (3 * z) + 1)
+          * hexTheta (-1 / (3 * z) + 1) := hexTheta_fricke hσ1
+    _ = -Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * (-1 / (3 * z) + 1)
+          * hexTheta (-1 / (3 * z)) := by rw [hexTheta_add_one]
+    _ = -Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * (-1 / (3 * z) + 1)
+          * (-Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * z * hexTheta z) := by
+        rw [hexTheta_fricke hz]
+    _ = ((-3) * z + 1) * hexTheta z := by
+        rw [show -Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * (-1 / (3 * z) + 1)
+              * (-Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * z * hexTheta z)
+            = -Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * (-1 / (3 * z) + 1)
+              * (-Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * z) * hexTheta z by ring,
+          fricke_double_multiplier hz]
+
+lemma coe_U_smul (z : ℍ) : ((U₃ • z : ℍ) : ℂ) = (z : ℂ) / ((-3) * (z : ℂ) + 1) := by
+  rw [UpperHalfPlane.coe_specialLinearGroup_apply]
+  simp only [show U₃ 0 0 = 1 from rfl, show U₃ 0 1 = 0 from rfl,
+    show U₃ 1 0 = -3 from rfl, show U₃ 1 1 = 1 from rfl, eq_intCast]
+  push_cast
+  rw [one_mul, add_zero]
+
+theorem hexThetaH_slash_U : hexThetaH ∣[(1 : ℤ)] U₃ = hexThetaH := by
+  funext z
+  refine (slash_action_eq'_iff 1 hexThetaH U₃ z).mpr ?_
+  have hz : 0 < (z : ℂ).im := by rw [UpperHalfPlane.coe_im]; exact z.im_pos
+  rw [U₃_one_zero, U₃_one_one]
+  push_cast
+  rw [zpow_one]
+  change latticeSum ((U₃ • z : ℍ) : ℂ) = _ * latticeSum (z : ℂ)
+  rw [coe_U_smul, latticeSum_eq_hexTheta, latticeSum_eq_hexTheta, hexTheta_U_law hz]
+
+def thetaBound : ℝ :=
+  ∑' v : ℤ × ℤ, Real.exp (-(π * (v.1 : ℝ) ^ 2)) * Real.exp (-(π * (v.2 : ℝ) ^ 2))
+
+lemma thetaBound_nonneg : 0 ≤ thetaBound :=
+  tsum_nonneg fun _ => mul_nonneg (Real.exp_pos _).le (Real.exp_pos _).le
+
+theorem norm_latticeSum_le_of_one_le_im {τ : ℂ} (hτ : 1 ≤ τ.im) :
+    ‖latticeSum τ‖ ≤ thetaBound := by
+  have hτ0 : 0 < τ.im := lt_of_lt_of_le one_pos hτ
+  have hdom : ∀ v : ℤ × ℤ, ‖latticeTerm τ v‖
+      ≤ Real.exp (-(π * (v.1 : ℝ) ^ 2)) * Real.exp (-(π * (v.2 : ℝ) ^ 2)) := by
+    intro v
+    have h := norm_latticeTerm_le_of_le_im one_pos hτ v
+    simpa only [mul_one, one_mul] using h
+  have hgauss : Summable fun v : ℤ × ℤ =>
+      Real.exp (-(π * (v.1 : ℝ) ^ 2)) * Real.exp (-(π * (v.2 : ℝ) ^ 2)) := by
+    simpa only [mul_one, one_mul] using summable_gaussian_prod one_pos
+  have hsum_norm : Summable fun v : ℤ × ℤ => ‖latticeTerm τ v‖ :=
+    Summable.of_nonneg_of_le (fun _ => norm_nonneg _) hdom hgauss
+  calc ‖latticeSum τ‖ ≤ ∑' v : ℤ × ℤ, ‖latticeTerm τ v‖ := norm_tsum_le_tsum_norm hsum_norm
+    _ ≤ ∑' v : ℤ × ℤ, Real.exp (-(π * (v.1 : ℝ) ^ 2)) * Real.exp (-(π * (v.2 : ℝ) ^ 2)) :=
+        hsum_norm.tsum_le_tsum hdom hgauss
+    _ = thetaBound := rfl
+
+theorem isBoundedAtImInfty_hexThetaH : IsBoundedAtImInfty hexThetaH := by
+  refine UpperHalfPlane.isBoundedAtImInfty_iff.mpr ⟨thetaBound, 1, fun z hz => ?_⟩
+  exact norm_latticeSum_le_of_one_le_im (by rwa [UpperHalfPlane.coe_im])
+
+lemma im_add_natCast_div_three (w : ℂ) (n : ℕ) : ((w + (n : ℂ)) / 3).im = w.im / 3 := by
+  rw [show (3 : ℂ) = ((3 : ℝ) : ℂ) by norm_num, Complex.div_ofReal_im]
+  simp [Complex.add_im]
+
+lemma norm_neg_I_div_sqrt_three_le_one :
+    ‖(-Complex.I / ((Real.sqrt 3 : ℝ) : ℂ))‖ ≤ 1 := by
+  have h3 : (1 : ℝ) ≤ Real.sqrt 3 := by
+    nlinarith [Real.sq_sqrt (show (0 : ℝ) ≤ 3 by norm_num), Real.sqrt_nonneg 3]
+  rw [norm_div, norm_neg, Complex.norm_I, Complex.norm_real, Real.norm_eq_abs,
+    abs_of_nonneg (Real.sqrt_nonneg 3), div_le_one (by linarith)]
+  exact h3
+
+theorem hexThetaH_slash_repOfLabel_apply (k : ZMod 3) (z : ℍ) :
+    (hexThetaH ∣[(1 : ℤ)] Gamma0Three.repOfLabel (some k)) z
+      = (-Complex.I / ((Real.sqrt 3 : ℝ) : ℂ)) * hexTheta (((z : ℂ) + (k.val : ℂ)) / 3) := by
+  have hz : 0 < (z : ℂ).im := by rw [UpperHalfPlane.coe_im]; exact z.im_pos
+  have hden_im : ((z : ℂ) + (k.val : ℂ)).im = (z : ℂ).im := by
+    simp only [Complex.add_im, Complex.natCast_im, add_zero]
+  have hden_ne : (z : ℂ) + (k.val : ℂ) ≠ 0 := by
+    intro h
+    rw [← Complex.zero_im, ← h, hden_im] at hz
+    exact lt_irrefl _ hz
+  have hσ_im : 0 < (((z : ℂ) + (k.val : ℂ)) / 3).im := by
+    rw [im_add_natCast_div_three]
+    positivity
+  have hsmul : ((Gamma0Three.repOfLabel (some k) • z : ℍ) : ℂ)
+      = -1 / ((z : ℂ) + (k.val : ℂ)) := by
+    rw [UpperHalfPlane.coe_specialLinearGroup_apply]
+    simp only [show Gamma0Three.repOfLabel (some k) 0 0 = 0 from rfl,
+      show Gamma0Three.repOfLabel (some k) 0 1 = -1 from rfl,
+      show Gamma0Three.repOfLabel (some k) 1 0 = 1 from rfl,
+      show Gamma0Three.repOfLabel (some k) 1 1 = (k.val : ℤ) from rfl, eq_intCast]
+    push_cast
+    rw [zero_mul, zero_add, one_mul]
+  have hdenom : denom (Gamma0Three.repOfLabel (some k)) z = (z : ℂ) + (k.val : ℂ) := by
+    rw [ModularGroup.denom_apply,
+      show Gamma0Three.repOfLabel (some k) 1 0 = 1 from rfl,
+      show Gamma0Three.repOfLabel (some k) 1 1 = (k.val : ℤ) from rfl]
+    push_cast
+    rw [one_mul]
+  have hfricke : hexTheta (-1 / ((z : ℂ) + (k.val : ℂ)))
+      = -Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * (((z : ℂ) + (k.val : ℂ)) / 3)
+        * hexTheta (((z : ℂ) + (k.val : ℂ)) / 3) := by
+    have h := hexTheta_fricke hσ_im
+    rw [show (3 : ℂ) * (((z : ℂ) + (k.val : ℂ)) / 3) = (z : ℂ) + (k.val : ℂ) by ring] at h
+    exact h
+  have hmul : -Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * (((z : ℂ) + (k.val : ℂ)) / 3)
+      * ((z : ℂ) + (k.val : ℂ))⁻¹ = -Complex.I / ((Real.sqrt 3 : ℝ) : ℂ) := by
+    rw [eq_div_iff sqrt_three_ne_zero,
+      show -Complex.I * ((Real.sqrt 3 : ℝ) : ℂ) * (((z : ℂ) + (k.val : ℂ)) / 3)
+          * ((z : ℂ) + (k.val : ℂ))⁻¹ * ((Real.sqrt 3 : ℝ) : ℂ)
+        = -Complex.I * (((Real.sqrt 3 : ℝ) : ℂ) * ((Real.sqrt 3 : ℝ) : ℂ))
+          * (((z : ℂ) + (k.val : ℂ)) * ((z : ℂ) + (k.val : ℂ))⁻¹) / 3 by ring,
+      sqrt_three_mul_sqrt_three, mul_inv_cancel₀ hden_ne]
+    ring
+  rw [ModularForm.SL_slash_apply, hdenom, _root_.zpow_neg, zpow_one]
+  change latticeSum ((Gamma0Three.repOfLabel (some k) • z : ℍ) : ℂ) * _ = _
+  rw [hsmul, latticeSum_eq_hexTheta, hfricke]
+  linear_combination (hexTheta (((z : ℂ) + (k.val : ℂ)) / 3)) * hmul
+
+theorem isBoundedAtImInfty_hexThetaH_slash (γ : SL(2, ℤ)) :
+    IsBoundedAtImInfty (hexThetaH ∣[(1 : ℤ)] γ) := by
+  set r := Gamma0Three.repOfLabel (Gamma0Three.label γ) with hr
+  have hδ : γ * r⁻¹ ∈ Gamma0 3 :=
+    (Gamma0Three.mul_inv_repOfLabel_mem_iff γ (Gamma0Three.label γ)).mpr rfl
+  have hfact : γ = γ * r⁻¹ * r := (inv_mul_cancel_right γ r).symm
+  rw [hfact, SlashAction.slash_mul,
+    slash_eq_chi3_smul hexThetaH hexThetaH_slash_T hexThetaH_slash_U hδ,
+    ModularForm.SL_smul_slash]
+  refine Filter.BoundedAtFilter.smul _ ?_
+  rcases hcase : Gamma0Three.label γ with _ | k
+  · rw [hr, hcase, Gamma0Three.repOfLabel_none, SlashAction.slash_one]
+    exact isBoundedAtImInfty_hexThetaH
+  · rw [hr, hcase]
+    refine UpperHalfPlane.isBoundedAtImInfty_iff.mpr ⟨thetaBound, 3, fun z hz => ?_⟩
+    rw [hexThetaH_slash_repOfLabel_apply k z, norm_mul]
+    have him : 1 ≤ (((z : ℂ) + (k.val : ℂ)) / 3).im := by
+      rw [im_add_natCast_div_three, UpperHalfPlane.coe_im, le_div_iff₀ (by norm_num)]
+      linarith
+    have hbound : ‖hexTheta (((z : ℂ) + (k.val : ℂ)) / 3)‖ ≤ thetaBound := by
+      rw [← latticeSum_eq_hexTheta]
+      exact norm_latticeSum_le_of_one_le_im him
+    calc ‖(-Complex.I / ((Real.sqrt 3 : ℝ) : ℂ))‖ * ‖hexTheta (((z : ℂ) + (k.val : ℂ)) / 3)‖
+        ≤ 1 * thetaBound :=
+          mul_le_mul norm_neg_I_div_sqrt_three_le_one hbound (norm_nonneg _) zero_le_one
+      _ = thetaBound := one_mul _
+
+theorem hexThetaH_isBoundedAt_cusp (c : OnePoint ℝ)
+    (hc : IsCusp c ((Gamma1 3 : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ))) :
+    c.IsBoundedAt hexThetaH 1 := by
+  rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z] at hc
+  obtain ⟨γ, rfl⟩ := isCusp_SL2Z_iff'.mp hc
+  refine (OnePoint.isBoundedAt_iff rfl).mpr ?_
+  exact isBoundedAtImInfty_hexThetaH_slash γ
+
+end
+end A2Theta3
+
+open Complex Real Filter
+open A2Theta3.LatticeSum
+open scoped Manifold Topology
+
+namespace A2Theta3
+
+noncomputable section
+
+lemma differentiable_latticeTerm (v : ℤ × ℤ) :
+    Differentiable ℂ fun τ : ℂ => latticeTerm τ v := by
+  unfold latticeTerm
+  fun_prop
+
+def thetaBoundAt (T : ℝ) : ℝ :=
+  ∑' v : ℤ × ℤ, Real.exp (-(π * T * (v.1 : ℝ) ^ 2)) * Real.exp (-(π * T * (v.2 : ℝ) ^ 2))
+
+theorem norm_latticeSum_le_of_le_im {T : ℝ} (hT : 0 < T) {τ : ℂ} (hτ : T ≤ τ.im) :
+    ‖latticeSum τ‖ ≤ thetaBoundAt T := by
+  have hdom : ∀ v : ℤ × ℤ, ‖latticeTerm τ v‖
+      ≤ Real.exp (-(π * T * (v.1 : ℝ) ^ 2)) * Real.exp (-(π * T * (v.2 : ℝ) ^ 2)) :=
+    fun v => norm_latticeTerm_le_of_le_im hT hτ v
+  have hgauss : Summable fun v : ℤ × ℤ =>
+      Real.exp (-(π * T * (v.1 : ℝ) ^ 2)) * Real.exp (-(π * T * (v.2 : ℝ) ^ 2)) :=
+    summable_gaussian_prod hT
+  have hsum_norm : Summable fun v : ℤ × ℤ => ‖latticeTerm τ v‖ :=
+    Summable.of_nonneg_of_le (fun _ => norm_nonneg _) hdom hgauss
+  calc ‖latticeSum τ‖ ≤ ∑' v : ℤ × ℤ, ‖latticeTerm τ v‖ := norm_tsum_le_tsum_norm hsum_norm
+    _ ≤ ∑' v : ℤ × ℤ, Real.exp (-(π * T * (v.1 : ℝ) ^ 2))
+          * Real.exp (-(π * T * (v.2 : ℝ) ^ 2)) :=
+        hsum_norm.tsum_le_tsum hdom hgauss
+    _ = thetaBoundAt T := rfl
+
+theorem thetaBoundAt_one_eq : thetaBoundAt 1 = thetaBound := by
+  unfold thetaBoundAt thetaBound
+  simp only [mul_one]
+
+lemma isOpen_lt_im (T : ℝ) : IsOpen {z : ℂ | T < z.im} :=
+  isOpen_lt continuous_const Complex.continuous_im
+
+theorem differentiableOn_latticeSum_of_lt_im {T : ℝ} (hT : 0 < T) :
+    DifferentiableOn ℂ latticeSum {z : ℂ | T < z.im} := by
+  have h := Complex.differentiableOn_tsum_of_summable_norm
+    (F := fun (v : ℤ × ℤ) (τ : ℂ) => latticeTerm τ v)
+    (summable_gaussian_prod hT)
+    (fun v => (differentiable_latticeTerm v).differentiableOn)
+    (isOpen_lt_im T)
+    (fun v w hw => norm_latticeTerm_le_of_le_im hT (le_of_lt hw) v)
+  exact h
+
+theorem differentiableAt_latticeSum {τ : ℂ} (hτ : 0 < τ.im) :
+    DifferentiableAt ℂ latticeSum τ := by
+  have hT : (0 : ℝ) < τ.im / 2 := by positivity
+  have hmem : τ ∈ {z : ℂ | τ.im / 2 < z.im} := by
+    simp only [Set.mem_ofPred_eq]
+    linarith
+  exact (differentiableOn_latticeSum_of_lt_im hT).differentiableAt
+    ((isOpen_lt_im _).mem_nhds hmem)
+
+theorem differentiableOn_latticeSum :
+    DifferentiableOn ℂ latticeSum {z : ℂ | 0 < z.im} :=
+  fun _ hz => (differentiableAt_latticeSum hz).differentiableWithinAt
+
+theorem mdifferentiable_hexThetaH : MDiff hexThetaH := by
+  rw [UpperHalfPlane.mdifferentiable_iff]
+  refine DifferentiableOn.congr (f := latticeSum) differentiableOn_latticeSum
+    (fun z hz => ?_)
+  simp [hexThetaH, Function.comp_apply, UpperHalfPlane.ofComplex_apply_of_im_pos hz]
+
+end
+end A2Theta3
+
+open Complex Real Matrix CongruenceSubgroup Subgroup ModularForm UpperHalfPlane
+open A2Theta3.LatticeSum
+open scoped MatrixGroups ModularForm Manifold
+
+namespace A2Theta3
+
+noncomputable section
+
+def thetaForm : ModularForm (Gamma1 3) 1 :=
+  { slashInvariantForm_of_T_U hexThetaH hexThetaH_slash_T hexThetaH_slash_U with
+    holo' := mdifferentiable_hexThetaH
+    bdd_at_cusps' := fun {c} hc => hexThetaH_isBoundedAt_cusp c hc }
+
+@[scoped simp] theorem coe_thetaForm : (⇑thetaForm : ℍ → ℂ) = hexThetaH := rfl
+
+theorem one_mem_strictPeriods_Gamma1_three :
+    (1 : ℝ) ∈ ((Gamma1 3 : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  rw [CongruenceSubgroup.strictPeriods_Gamma1]; exact AddSubgroup.mem_zmultiples _
+
+theorem qExpansion_coeff_thetaForm (n : ℕ) :
+    (qExpansion 1 (⇑thetaForm : ℍ → ℂ)).coeff n = (repCount n : ℂ) := by
+  symm
+  refine ModularFormClass.qExpansion_coeff_unique (c := fun n => (repCount n : ℂ)) one_pos
+    one_mem_strictPeriods_Gamma1_three (f := thetaForm) (fun τ => ?_) n
+  have hτ : 0 < (τ : ℂ).im := by rw [UpperHalfPlane.coe_im]; exact τ.im_pos
+  have h := hasSum_repCount_qpow hτ
+  rw [coe_thetaForm, hexThetaH_apply]
+  convert h using 1
+  funext m
+  rw [smul_eq_mul, Function.Periodic.qParam, ← Complex.exp_nat_mul]
+  congr 1
+  push_cast
+  ring_nf
+
+theorem thetaForm_slash_fricke (W : GL (Fin 2) ℝ)
+    (hW : (W : Matrix (Fin 2) (Fin 2) ℝ) = !![(0 : ℝ), -1; 3, 0]) :
+    (⇑thetaForm : ℍ → ℂ) ∣[(1 : ℤ)] W = (-Complex.I / (Real.sqrt 3 : ℂ)) • (⇑thetaForm : ℍ → ℂ) :=
+      by
+  funext τ
+  have hdet : (W.det : ℝ) = 3 := by
+    rw [Matrix.GeneralLinearGroup.val_det_apply, hW, Matrix.det_fin_two_of]; norm_num
+  have hdetpos : 0 < (W.det : ℝ) := by rw [hdet]; norm_num
+  have hτ : 0 < (τ : ℂ).im := by rw [UpperHalfPlane.coe_im]; exact τ.im_pos
+  have hτ0 : (τ : ℂ) ≠ 0 := ne_zero_of_im_pos hτ
+  rw [ModularForm.slash_apply, Pi.smul_apply, smul_eq_mul]
+  have hσ : σ W = ContinuousAlgEquiv.refl ℝ ℂ := by rw [σ, ite_eq_left hdetpos]
+  have hsm : ((W • τ : ℍ) : ℂ) = -1 / (3 * (τ : ℂ)) := by
+    rw [coe_smul_of_det_pos hdetpos]
+    simp [num, denom, hW]
+  have hden : denom W τ = 3 * (τ : ℂ) := by simp [denom, hW]
+  rw [hσ, ContinuousAlgEquiv.refl_apply, hdet, coe_thetaForm, hexThetaH_eq_hexTheta,
+    hexThetaH_eq_hexTheta, hsm,
+    hexTheta_fricke hτ, hden]
+  have hs0 : ((Real.sqrt 3 : ℝ) : ℂ) ≠ 0 := sqrt_three_ne_zero
+  have hs3 : ((Real.sqrt 3 : ℝ) : ℂ) ^ 2 = 3 := by
+    rw [← Complex.ofReal_pow, Real.sq_sqrt (by norm_num)]; push_cast; rfl
+  rw [sub_self, zpow_zero, mul_one, _root_.zpow_neg, zpow_one]
+  field_simp
+  linear_combination (-hexTheta (τ : ℂ)) * hs3
+
+end
+end A2Theta3
+
+open scoped MatrixGroups ModularForm in
+theorem solution :
+    ∃ g : ModularForm (CongruenceSubgroup.Gamma1 3 : Subgroup (GL (Fin 2) ℝ)) 1,
+      (∀ n : ℕ, ∃ r : ℚ, (UpperHalfPlane.qExpansion 1 g).coeff n = (r : ℂ)) ∧
+      (UpperHalfPlane.qExpansion 1 g).coeff 0 = 1 ∧
+      ∀ W : GL (Fin 2) ℝ, (W : Matrix (Fin 2) (Fin 2) ℝ) = !![(0 : ℝ), -1; 3, 0] →
+        (⇑g : UpperHalfPlane → ℂ) ∣[(1 : ℤ)] W =
+          (-Complex.I / (Real.sqrt 3 : ℂ)) • (⇑g : UpperHalfPlane → ℂ) := by
+  refine ⟨A2Theta3.thetaForm, fun n => ⟨(A2Theta3.LatticeSum.repCount n : ℚ), ?_⟩, ?_,
+    fun W hW => A2Theta3.thetaForm_slash_fricke W hW⟩
+  · rw [A2Theta3.qExpansion_coeff_thetaForm]; push_cast; rfl
+  · rw [A2Theta3.qExpansion_coeff_thetaForm, A2Theta3.LatticeSum.repCount_zero]; push_cast; rfl
+
+end S_ModularForm_exists_weight_one_gamma1_three_slash_fricke_eq_smul
+end P2MW
+export P2MW.S_ModularForm_exists_weight_one_gamma1_three_slash_fricke_eq_smul (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups ModularForm in
+theorem ModularForm.exists_weight_one_gamma1_three_slash_fricke_eq_smul :
+    ∃ g : ModularForm (CongruenceSubgroup.Gamma1 3 : Subgroup (GL (Fin 2) ℝ)) 1,
+      (∀ n : ℕ, ∃ r : ℚ, (UpperHalfPlane.qExpansion 1 g).coeff n = (r : ℂ)) ∧
+      (UpperHalfPlane.qExpansion 1 g).coeff 0 = 1 ∧
+      ∀ W : GL (Fin 2) ℝ, (W : Matrix (Fin 2) (Fin 2) ℝ) = !![(0 : ℝ), -1; 3, 0] →
+        (⇑g : UpperHalfPlane → ℂ) ∣[(1 : ℤ)] W =
+          (-Complex.I / (Real.sqrt 3 : ℂ)) • (⇑g : UpperHalfPlane → ℂ) :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_finiteDimensional_of_isArithmetic.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_finiteDimensional_of_isArithmetic.lean
new file mode 100644
index 0000000000..7bded416a9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_finiteDimensional_of_isArithmetic.lean
@@ -0,0 +1,126 @@
+/-
+Based on Prove2Me node ModularForm.finiteDimensional_of_isArithmetic
+(fec292ab-0757-5b48-a9bc-a13e34bc1b49) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f0fe8027-1c91-5a96-a216-df41053259eb
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+
+import Mathlib.RingTheory.PowerSeries.Order
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Subgroup_IsArithmetic_exists_nat_mem_strictPeriods_conj
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_eq_zero_of_lt_order_qExpansion_of_isArithmetic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finite-dimensionality of M_k(G) for arithmetic G
+
+Theorem statement: `ModularForm.finiteDimensional_of_isArithmetic`
+(`fec292ab-0757-5b48-a9bc-a13e34bc1b49`), by Claude, 2026-09-05.
+
+Proof: submission `f0fe8027-1c91-5a96-a216-df41053259eb`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\mathcal{G}$ be a subgroup of $\mathrm{GL}_2(\mathbb{R})$ which is arithmetic, i.e. carries the
+instance `Subgroup.IsArithmetic` expressing commensurability with the image of
+$\mathrm{SL}_2(\mathbb{Z})$, and all of whose elements have determinant $1$ (the instance
+`Subgroup.HasDetOne`, which is what gives the space of forms its $\mathbb{C}$-module structure), and
+let $k$ be an arbitrary integer weight, positive, zero or negative. Then the complex vector space
+`ModularForm 𝒢 k` of weight-$k$ modular forms for $\mathcal{G}$ — holomorphic functions on the upper
+half-plane satisfying the weight-$k$ slash-invariance under $\mathcal{G}$ together with the growth
+condition at the cusps imposed by Mathlib's definition — is finite-dimensional over $\mathbb{C}$. No
+congruence, torsion-freeness or sign condition on $\mathcal{G}$ is assumed, and no bound on the
+dimension is asserted: the conclusion is finiteness alone, in the form of the `FiniteDimensional ℂ`
+instance.
+
+This is the classical finite-dimensionality of spaces of modular forms of fixed weight on an
+arithmetic group, here in the uniform form covering all finite-index subgroups of
+$\mathrm{SL}_2(\mathbb{Z})$, in particular $\Gamma_0(N)$, $\Gamma_1(N)$ and $\Gamma(N)$. It
+underlies the corresponding statements for cusp forms
+([`CuspForm.finiteDimensional_of_isArithmetic`]
+(thm.html#CuspForm.finiteDimensional_of_isArithmetic),
+[`CuspForm.finiteDimensional_Gamma1`](thm.html#CuspForm.finiteDimensional_Gamma1)) and the
+construction of bases with controlled $q$-expansion coefficients, and hence the treatment of Hecke
+operators as a commuting family of endomorphisms of a finite-dimensional space.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_finiteDimensional_of_isArithmetic.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_finiteDimensional_of_isArithmetic
+
+p2m_open "UpperHalfPlane ModularForm \
+  P2MW.S_ModularForm_finiteDimensional_of_isArithmetic.ModularForm SlashInvariantForm \
+  Matrix.SpecialLinearGroup ConjAct"
+p2m_open_scoped "MatrixGroups ModularForm \
+  P2MW.S_ModularForm_finiteDimensional_of_isArithmetic.ModularForm Topology Manifold Pointwise"
+
+noncomputable section
+
+namespace ModularForm
+p2m_export "ModularForm" "ext eq_zero_of_lt_order_qExpansion_of_isArithmetic"
+end ModularForm
+p2m_open_scoped "ModularForm" in
+def ModularForm.qExpansionCoeffs_W2D {𝒢 : Subgroup (GL (Fin 2) ℝ)} [𝒢.HasDetOne] (k : ℤ) {h : ℝ}
+    (hh : 0 < h) (h𝒢 : h ∈ 𝒢.strictPeriods) (B : ℕ) : ModularForm 𝒢 k →ₗ[ℂ] (Fin B → ℂ) where
+  toFun f n := (qExpansion h f).coeff n
+  map_add' f g := by
+    ext n
+    simp [ModularForm.qExpansion_add hh h𝒢]
+  map_smul' a f := by
+    ext n
+    simp [ModularForm.qExpansion_smul hh h𝒢]
+
+p2m_open_scoped "ModularForm" in
+lemma ModularForm.le_order_of_qExpansionCoeffs_eq_zero_W2D {𝒢 : Subgroup (GL (Fin 2) ℝ)}
+    [𝒢.HasDetOne]
+    {k : ℤ} {h : ℝ} (hh : 0 < h) (h𝒢 : h ∈ 𝒢.strictPeriods) {B : ℕ} {f : ModularForm 𝒢 k}
+    (hf : ModularForm.qExpansionCoeffs_W2D k hh h𝒢 B f = 0) : (B : ℕ∞) ≤ (qExpansion h f).order :=
+  PowerSeries.nat_le_order _ _ fun n hn ↦ by
+    have h__af := congr_fun hf ⟨n, hn⟩; simp only [Pi.zero_apply] at h__af; exact h__af
+
+theorem solution (𝒢 : Subgroup (GL (Fin 2) ℝ)) [𝒢.IsArithmetic] [𝒢.HasDetOne] (k : ℤ) :
+    FiniteDimensional ℂ (ModularForm 𝒢 k) := by
+  obtain ⟨M, hM, hconj⟩ := Subgroup.IsArithmetic.exists_nat_mem_strictPeriods_conj 𝒢
+  have hM𝒢 : (M : ℝ) ∈ 𝒢.strictPeriods := by simpa using hconj 1
+  set B := M * ((k * 𝒢.relIndex 𝒮ℒ).toNat / 12) + 1 with hB
+  refine Module.Finite.of_injective (ModularForm.qExpansionCoeffs_W2D k (Nat.cast_pos.mpr hM) hM𝒢 B)
+    ?_
+  rw [injective_iff_map_eq_zero]
+  intro f hf
+  refine f.eq_zero_of_lt_order_qExpansion_of_isArithmetic hM hconj (lt_of_lt_of_le ?_
+    (ModularForm.le_order_of_qExpansionCoeffs_eq_zero_W2D _ hM𝒢 hf))
+  exact_mod_cast Nat.lt_succ_self _
+end
+
+end S_ModularForm_finiteDimensional_of_isArithmetic
+end P2MW
+export P2MW.S_ModularForm_finiteDimensional_of_isArithmetic (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane
+open scoped MatrixGroups
+theorem ModularForm.finiteDimensional_of_isArithmetic (𝒢 : Subgroup (GL (Fin 2) ℝ)) [𝒢.IsArithmetic]
+    [𝒢.HasDetOne] (k : ℤ) :
+    FiniteDimensional ℂ (ModularForm 𝒢 k) :=
+  solution 𝒢 k
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_heckeT_slash_eq_self_of_mem_Gamma0.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_heckeT_slash_eq_self_of_mem_Gamma0.lean
new file mode 100644
index 0000000000..dd90d3fc6f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_heckeT_slash_eq_self_of_mem_Gamma0.lean
@@ -0,0 +1,446 @@
+/-
+Based on Prove2Me node ModularForm.heckeT_slash_eq_self_of_mem_Gamma0
+(2107b482-b48e-53c7-b123-455181e52920) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e453db6c-b6a8-5616-a076-875d1bf6c772
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import Mathlib.Algebra.Field.ZMod
+import Mathlib.Topology.Compactification.OnePoint.ProjectiveLine
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Tₚ preserves Γ₀(N)-invariance for p ∤ N
+
+Theorem statement: `ModularForm.heckeT_slash_eq_self_of_mem_Gamma0`
+(`2107b482-b48e-53c7-b123-455181e52920`), by Claude, 2026-09-05.
+
+Proof: submission `e453db6c-b6a8-5616-a076-875d1bf6c772`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, $k$ an integer and $p$ a prime with $p \nmid N$, and let $f :
+\mathbb{H} \to \mathbb{C}$ be an arbitrary function (no holomorphy or growth condition is imposed).
+Assume that $f$ is invariant under the weight-$k$ slash action of every element of $\Gamma_0(N)$,
+viewed through the coercion of `CongruenceSubgroup.Gamma0 N` into a subgroup of
+$\mathrm{GL}_2(\mathbb{R})$: $f \mid_k \gamma = f$ for all such $\gamma$. Then the function
+$$\mathrm{heckeT}\,k\,p\,f \;=\; \sum_{j=0}^{p-1} f \mid_k \mathtt{heckeMatrix}\,p\,j \;+\; f \mid_k
+\mathtt{heckeDiagMatrix}\,p,$$ where the last matrix is the identity when $p = 0$ and otherwise the
+upper-triangular element `upperTriangularGL p 0 1` of $\mathrm{GL}_2(\mathbb{R})$ with entries $p$,
+$0$, $1$, enjoys the same invariance: for every $\gamma \in \mathrm{GL}_2(\mathbb{R})$ lying in (the
+image of) $\Gamma_0(N)$ one has $(\mathrm{heckeT}\,k\,p\,f) \mid_k \gamma =
+\mathrm{heckeT}\,k\,p\,f$. The coset representatives $\mathtt{heckeMatrix}\,p\,j$, $0 \le j < p$,
+are the remaining terms of the Hecke sum.
+
+This is the automorphy, or level-preservation, half of the assertion that the Hecke operator $T_p$
+at a prime $p$ not dividing the level acts on modular forms for $\Gamma_0(N)$: the invariance under
+the weight-$k$ action of $\Gamma_0(N)$ is preserved, while holomorphy and the conditions at the
+cusps are treated separately. It is used by
+[`CuspForm.exists_coe_eq_heckeT`](thm.html#CuspForm.exists_coe_eq_heckeT), which realises $T_p$ as
+an operator on cusp forms of level $N$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_heckeT_slash_eq_self_of_mem_Gamma0.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_heckeT_slash_eq_self_of_mem_Gamma0
+
+noncomputable section
+
+open Matrix.SpecialLinearGroup UpperHalfPlane
+p2m_open_scoped "MatrixGroups ModularForm \
+  P2MW.S_ModularForm_heckeT_slash_eq_self_of_mem_Gamma0.ModularForm OnePoint"
+
+namespace ModularForm
+p2m_export "ModularForm" "rec ext heckeMatrix heckeDiagMatrix heckeU heckeT heckeU_def \
+  heckeT_eq_heckeU_add"
+p2m_open "ModularForm"
+
+namespace HeckeSlashInvariance
+
+@[scoped simp] theorem mapGL_apply (g : SL(2, ℤ)) (i j : Fin 2) :
+    (mapGL ℝ g : GL (Fin 2) ℝ) i j = ((g i j : ℤ) : ℝ) := by
+  simp
+
+theorem det_eq (g : SL(2, ℤ)) : g 0 0 * g 1 1 - g 0 1 * g 1 0 = 1 := by
+  have h := g.det_coe
+  rwa [Matrix.det_fin_two] at h
+
+section commutation
+
+variable {p : ℕ} (hp : p ≠ 0)
+include hp
+
+theorem heckeMatrix_mul_of_eq (g : SL(2, ℤ)) (j j' : ℕ) (e : ℤ)
+    (he : g 0 1 + j * g 1 1 = j' * (g 0 0 + j * g 1 0) + p * e) :
+    ∃ g' : SL(2, ℤ), g' 1 0 = p * g 1 0 ∧
+      heckeMatrix p j * mapGL ℝ g = mapGL ℝ g' * heckeMatrix p j' := by
+  have hdet := det_eq g
+  refine ⟨⟨!![g 0 0 + j * g 1 0, e; p * g 1 0, g 1 1 - g 1 0 * j'], ?_⟩, rfl, ?_⟩
+  · rw [Matrix.det_fin_two_of]
+    linear_combination hdet + (g 1 0) * he
+  · ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp only [Fin.zero_eta, Fin.isValue, Units.val_mul, ne_eq, hp, not_false_eq_true,
+        val_heckeMatrix, mapGL_coe_matrix, algebraMap_int_eq, map_apply_coe,
+        RingHom.mapMatrix_apply, Int.coe_castRingHom, Matrix.mul_apply, Matrix.of_apply,
+        Matrix.cons_val', Matrix.cons_val_fin_one, Matrix.cons_val_zero, Matrix.map_apply,
+        Fin.sum_univ_two, one_mul, Matrix.cons_val_one, Int.cast_add, Int.cast_mul,
+        Int.cast_natCast, mul_one, mul_zero, add_zero, Fin.mk_one, zero_mul, zero_add, Int.cast_sub]
+    all_goals first
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination this)
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination -this)
+      | ring1
+
+theorem heckeMatrix_mul_of_eq' (g : SL(2, ℤ)) (j : ℕ) (e : ℤ)
+    (he : g 0 0 + j * g 1 0 = p * e) :
+    ∃ g' : SL(2, ℤ), g' 1 0 = g 1 0 ∧
+      heckeMatrix p j * mapGL ℝ g = mapGL ℝ g' * heckeDiagMatrix p := by
+  have hdet := det_eq g
+  refine ⟨⟨!![e, g 0 1 + j * g 1 1; g 1 0, p * g 1 1], ?_⟩, rfl, ?_⟩
+  · rw [Matrix.det_fin_two_of]
+    linear_combination hdet - (g 1 1) * he
+  · ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp only [Fin.zero_eta, Fin.isValue, Units.val_mul, ne_eq, hp, not_false_eq_true,
+        val_heckeMatrix, mapGL_coe_matrix, algebraMap_int_eq, map_apply_coe,
+        RingHom.mapMatrix_apply, Int.coe_castRingHom, Matrix.mul_apply, Matrix.of_apply,
+        Matrix.cons_val', Matrix.cons_val_fin_one, Matrix.cons_val_zero, Matrix.map_apply,
+        Fin.sum_univ_two, one_mul, Matrix.cons_val_one, val_heckeDiagMatrix, Int.cast_add,
+        Int.cast_mul, Int.cast_natCast, mul_zero, add_zero, Fin.mk_one, mul_one, zero_add, zero_mul]
+    all_goals first
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination this)
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination -this)
+      | ring1
+
+theorem heckeDiagMatrix_mul_of_eq (g : SL(2, ℤ)) (j' : ℕ) (e : ℤ)
+    (he : g 1 1 = g 1 0 * j' + p * e) :
+    ∃ g' : SL(2, ℤ), g' 1 0 = g 1 0 ∧
+      heckeDiagMatrix p * mapGL ℝ g = mapGL ℝ g' * heckeMatrix p j' := by
+  have hdet := det_eq g
+  refine ⟨⟨!![p * g 0 0, g 0 1 - g 0 0 * j'; g 1 0, e], ?_⟩, rfl, ?_⟩
+  · rw [Matrix.det_fin_two_of]
+    linear_combination hdet - (g 0 0) * he
+  · ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp only [Fin.zero_eta, Fin.isValue, Units.val_mul, ne_eq, hp, not_false_eq_true,
+        val_heckeDiagMatrix, mapGL_coe_matrix, algebraMap_int_eq, map_apply_coe,
+        RingHom.mapMatrix_apply, Int.coe_castRingHom, Matrix.mul_apply, Matrix.of_apply,
+        Matrix.cons_val', Matrix.cons_val_fin_one, Matrix.cons_val_zero, Matrix.map_apply,
+        Fin.sum_univ_two, Matrix.cons_val_one, zero_mul, add_zero, val_heckeMatrix, Int.cast_mul,
+        Int.cast_natCast, mul_one, Int.cast_sub, mul_zero, Fin.mk_one, one_mul, zero_add]
+    all_goals first
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination this)
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination -this)
+      | ring1
+
+theorem heckeDiagMatrix_mul_of_eq' (g : SL(2, ℤ)) (e : ℤ) (he : g 1 0 = p * e) :
+    ∃ g' : SL(2, ℤ), g' 1 0 = e ∧
+      heckeDiagMatrix p * mapGL ℝ g = mapGL ℝ g' * heckeDiagMatrix p := by
+  have hdet := det_eq g
+  refine ⟨⟨!![g 0 0, p * g 0 1; e, g 1 1], ?_⟩, rfl, ?_⟩
+  · rw [Matrix.det_fin_two_of]
+    linear_combination hdet + (g 0 1) * he
+  · ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp only [Fin.zero_eta, Fin.isValue, Units.val_mul, ne_eq, hp, not_false_eq_true,
+        val_heckeDiagMatrix, mapGL_coe_matrix, algebraMap_int_eq, map_apply_coe,
+        RingHom.mapMatrix_apply, Int.coe_castRingHom, Matrix.mul_apply, Matrix.of_apply,
+        Matrix.cons_val', Matrix.cons_val_fin_one, Matrix.cons_val_zero, Matrix.map_apply,
+        Fin.sum_univ_two, Matrix.cons_val_one, zero_mul, add_zero, Int.cast_mul, Int.cast_natCast,
+        mul_zero, Fin.mk_one, mul_one, zero_add, one_mul]
+    all_goals first
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination this)
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination -this)
+      | ring1
+
+end commutation
+
+section reindex
+
+variable {p : ℕ} [NeZero p]
+
+theorem sum_range_eq_sum_zmod {M : Type*} [AddCommMonoid M] (F : ℕ → M) :
+    ∑ j ∈ Finset.range p, F j = ∑ x : ZMod p, F x.val := by
+  refine Finset.sum_nbij' (fun j : ℕ ↦ (j : ZMod p)) (fun x : ZMod p ↦ x.val) (fun _ _ ↦
+    Finset.mem_univ _)
+    (fun x _ ↦ Finset.mem_range.mpr x.val_lt) (fun j hj ↦ ?_) (fun x _ ↦ ?_) (fun j hj ↦ ?_)
+  · exact ZMod.val_cast_of_lt (Finset.mem_range.mp hj)
+  · exact ZMod.natCast_zmod_val x
+  · rw [ZMod.val_cast_of_lt (Finset.mem_range.mp hj)]
+
+theorem heckeU_eq_sum_zmod (k : ℤ) (f : ℍ → ℂ) :
+    heckeU k p f = ∑ x : ZMod p, f ∣[k] heckeMatrix p x.val := by
+  rw [heckeU_def]
+  exact sum_range_eq_sum_zmod _
+
+end reindex
+
+section heckeU
+
+variable {p : ℕ}
+
+theorem unit_of_apply_one_zero_eq_zero (g : SL(2, ℤ)) (hc : ((g 1 0 : ℤ) : ZMod p) = 0) :
+    ((g 0 0 : ℤ) : ZMod p) * ((g 1 1 : ℤ) : ZMod p) = 1 := by
+  have := congrArg (Int.cast : ℤ → ZMod p) (det_eq g)
+  push_cast at this
+  linear_combination this + ((g 0 1 : ℤ) : ZMod p) * hc
+
+def affinePerm (g : SL(2, ℤ)) (hc : ((g 1 0 : ℤ) : ZMod p) = 0) : Equiv.Perm (ZMod p) where
+  toFun j := ((g 1 1 : ℤ) : ZMod p) * (((g 0 1 : ℤ) : ZMod p) + ((g 1 1 : ℤ) : ZMod p) * j)
+  invFun j := ((g 0 0 : ℤ) : ZMod p) * (((g 0 0 : ℤ) : ZMod p) * j - ((g 0 1 : ℤ) : ZMod p))
+  left_inv j := by
+    linear_combination (((g 0 0 : ℤ) : ZMod p) * ((g 0 1 : ℤ) : ZMod p)
+      + j * (((g 0 0 : ℤ) : ZMod p) * ((g 1 1 : ℤ) : ZMod p) + 1)) *
+        unit_of_apply_one_zero_eq_zero g hc
+  right_inv j := by
+    linear_combination (-(((g 1 1 : ℤ) : ZMod p) * ((g 0 1 : ℤ) : ZMod p))
+      + j * (((g 0 0 : ℤ) : ZMod p) * ((g 1 1 : ℤ) : ZMod p) + 1)) *
+        unit_of_apply_one_zero_eq_zero g hc
+
+theorem affinePerm_apply (g : SL(2, ℤ)) (hc : ((g 1 0 : ℤ) : ZMod p) = 0) (j : ZMod p) :
+    affinePerm g hc j =
+      ((g 1 1 : ℤ) : ZMod p) * (((g 0 1 : ℤ) : ZMod p) + ((g 1 1 : ℤ) : ZMod p) * j) := rfl
+
+variable [NeZero p]
+
+theorem heckeMatrix_mul_of_dvd (g : SL(2, ℤ)) (hc : (p : ℤ) ∣ g 1 0) (x : ZMod p) :
+    ∃ g' : SL(2, ℤ), g' 1 0 = p * g 1 0 ∧
+      heckeMatrix p x.val * mapGL ℝ g =
+        mapGL ℝ g' * heckeMatrix p (affinePerm g ((ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mpr hc)
+          x).val := by
+  have hc0 : ((g 1 0 : ℤ) : ZMod p) = 0 := (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mpr hc
+  set x' := affinePerm g hc0 x with hx'
+  obtain ⟨e, he⟩ : (p : ℤ) ∣ g 0 1 + x.val * g 1 1 - x'.val * (g 0 0 + x.val * g 1 0) := by
+    rw [← ZMod.intCast_zmod_eq_zero_iff_dvd]
+    push_cast
+    rw [ZMod.natCast_zmod_val, ZMod.natCast_zmod_val, hx', affinePerm_apply]
+    linear_combination (-(((g 0 1 : ℤ) : ZMod p) + x * ((g 1 1 : ℤ) : ZMod p))) *
+      unit_of_apply_one_zero_eq_zero g hc0
+      - (((g 1 1 : ℤ) : ZMod p) * (((g 0 1 : ℤ) : ZMod p) + ((g 1 1 : ℤ) : ZMod p) * x) * x) * hc0
+  exact heckeMatrix_mul_of_eq (NeZero.ne p) g x.val x'.val e (by linear_combination he)
+
+variable {N : ℕ} (k : ℤ)
+
+theorem heckeU_slash_mapGL (hpN : p ∣ N) (f : ℍ → ℂ)
+    (hf : ∀ γ ∈ (CongruenceSubgroup.Gamma0 N : Subgroup (GL (Fin 2) ℝ)), f ∣[k] γ = f)
+    (g : SL(2, ℤ)) (hg : g ∈ CongruenceSubgroup.Gamma0 N) :
+    heckeU k p f ∣[k] (mapGL ℝ g) = heckeU k p f := by
+  have hcN : (N : ℤ) ∣ g 1 0 :=
+    (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp (CongruenceSubgroup.Gamma0_mem.mp hg)
+  have hc : (p : ℤ) ∣ g 1 0 := (Int.natCast_dvd_natCast.mpr hpN).trans hcN
+  rw [heckeU_eq_sum_zmod k f, SlashAction.sum_slash]
+  calc ∑ x : ZMod p, (f ∣[k] heckeMatrix p x.val) ∣[k] mapGL ℝ g
+      = ∑ x : ZMod p, f ∣[k] heckeMatrix p
+          (affinePerm g ((ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mpr hc) x).val := by
+        refine Finset.sum_congr rfl fun x _ ↦ ?_
+        obtain ⟨g', hg', hmul⟩ := heckeMatrix_mul_of_dvd g hc x
+        have hg'N : g' ∈ CongruenceSubgroup.Gamma0 N := by
+          rw [CongruenceSubgroup.Gamma0_mem, hg']
+          push_cast
+          rw [CongruenceSubgroup.Gamma0_mem.mp hg, mul_zero]
+        rw [← SlashAction.slash_mul, hmul, SlashAction.slash_mul,
+          hf _ (Subgroup.mem_map_of_mem (mapGL ℝ) hg'N)]
+    _ = ∑ x : ZMod p, f ∣[k] heckeMatrix p x.val :=
+        Equiv.sum_comp (affinePerm g _) (fun x ↦ f ∣[k] heckeMatrix p x.val)
+
+end heckeU
+
+section heckeT
+
+variable {p : ℕ}
+
+def heckeRep (p : ℕ) (x : OnePoint (ZMod p)) : GL (Fin 2) ℝ :=
+  x.elim (heckeDiagMatrix p) (fun j ↦ heckeMatrix p j.val)
+
+@[scoped simp] theorem heckeRep_infty : heckeRep p ∞ = heckeDiagMatrix p := rfl
+
+@[scoped simp] theorem heckeRep_coe (j : ZMod p) : heckeRep p j = heckeMatrix p j.val := rfl
+
+theorem heckeT_eq_sum_onePoint [NeZero p] (k : ℤ) (f : ℍ → ℂ) :
+    heckeT k p f = ∑ x : OnePoint (ZMod p), f ∣[k] heckeRep p x := by
+  rw [heckeT_eq_heckeU_add, heckeU_eq_sum_zmod, add_comm]
+  exact (Fintype.sum_option (fun x : OnePoint (ZMod p) ↦ f ∣[k] heckeRep p x)).symm
+
+variable [Fact p.Prime]
+
+variable (p) in
+def redMatrix (g : SL(2, ℤ)) : GL (Fin 2) (ZMod p) :=
+  Matrix.GeneralLinearGroup.mkOfDetNeZero
+    !![((g 1 1 : ℤ) : ZMod p), ((g 0 1 : ℤ) : ZMod p); ((g 1 0 : ℤ) : ZMod p), ((g 0 0 : ℤ) : ZMod
+      p)]
+    (by
+      have := congrArg (Int.cast : ℤ → ZMod p) (det_eq g)
+      push_cast at this
+      rw [Matrix.det_fin_two_of,
+        show ((g 1 1 : ℤ) : ZMod p) * ((g 0 0 : ℤ) : ZMod p) - ((g 0 1 : ℤ) : ZMod p) * ((g 1 0 : ℤ)
+          : ZMod p)
+          = 1 by linear_combination this]
+      exact one_ne_zero)
+
+@[scoped simp] theorem redMatrix_apply_zero_zero (g : SL(2, ℤ)) :
+    redMatrix p g 0 0 = ((g 1 1 : ℤ) : ZMod p) := by
+  simp [redMatrix]
+
+@[scoped simp] theorem redMatrix_apply_zero_one (g : SL(2, ℤ)) :
+    redMatrix p g 0 1 = ((g 0 1 : ℤ) : ZMod p) := by
+  simp [redMatrix]
+
+@[scoped simp] theorem redMatrix_apply_one_zero (g : SL(2, ℤ)) :
+    redMatrix p g 1 0 = ((g 1 0 : ℤ) : ZMod p) := by
+  simp [redMatrix]
+
+@[scoped simp] theorem redMatrix_apply_one_one (g : SL(2, ℤ)) :
+    redMatrix p g 1 1 = ((g 0 0 : ℤ) : ZMod p) := by
+  simp [redMatrix]
+
+scoped instance : NeZero p := ⟨(Fact.out : p.Prime).ne_zero⟩
+
+theorem heckeRep_mul {N : ℕ} (hpN : ¬ p ∣ N) (g : SL(2, ℤ)) (hg : (N : ℤ) ∣ g 1 0)
+    (x : OnePoint (ZMod p)) :
+    ∃ g' : SL(2, ℤ), (N : ℤ) ∣ g' 1 0 ∧
+      heckeRep p x * mapGL ℝ g = mapGL ℝ g' * heckeRep p (redMatrix p g • x) := by
+  have hp : p ≠ 0 := (Fact.out : p.Prime).ne_zero
+  induction x using OnePoint.rec with
+  | infty =>
+    rw [OnePoint.smul_infty_eq_ite]
+    by_cases hc : ((g 1 0 : ℤ) : ZMod p) = 0
+    · rw [ite_eq_left (by simpa using hc), heckeRep_infty]
+      obtain ⟨e, he⟩ := (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp hc
+      obtain ⟨g', hg', hmul⟩ := heckeDiagMatrix_mul_of_eq' hp g e he
+      refine ⟨g', ?_, hmul⟩
+      rw [hg']
+      have hcop : IsCoprime (N : ℤ) (p : ℤ) :=
+        Nat.isCoprime_iff_coprime.mpr ((Nat.Prime.coprime_iff_not_dvd Fact.out).mpr hpN).symm
+      exact hcop.dvd_of_dvd_mul_left (he ▸ hg)
+    · rw [ite_eq_right (by simpa using hc), heckeRep_infty, heckeRep_coe]
+      set y : ZMod p := redMatrix p g 0 0 / redMatrix p g 1 0
+        with hy
+      obtain ⟨e, he⟩ : (p : ℤ) ∣ g 1 1 - g 1 0 * y.val := by
+        rw [← ZMod.intCast_zmod_eq_zero_iff_dvd]
+        push_cast
+        rw [ZMod.natCast_zmod_val, hy, redMatrix_apply_zero_zero, redMatrix_apply_one_zero,
+          mul_div_cancel₀ _ hc, sub_self]
+      obtain ⟨g', hg', hmul⟩ := heckeDiagMatrix_mul_of_eq hp g y.val e (by linear_combination he)
+      exact ⟨g', hg' ▸ hg, hmul⟩
+  | coe j =>
+    rw [OnePoint.smul_some_eq_ite]
+    by_cases h : redMatrix p g 1 0 * j + redMatrix p g 1 1 = 0
+    · rw [ite_eq_left h, heckeRep_infty, heckeRep_coe]
+      rw [redMatrix_apply_one_zero, redMatrix_apply_one_one] at h
+      obtain ⟨e, he⟩ : (p : ℤ) ∣ g 0 0 + j.val * g 1 0 := by
+        rw [← ZMod.intCast_zmod_eq_zero_iff_dvd]
+        push_cast
+        rw [ZMod.natCast_zmod_val]
+        linear_combination h
+      obtain ⟨g', hg', hmul⟩ := heckeMatrix_mul_of_eq' hp g j.val e he
+      exact ⟨g', hg' ▸ hg, hmul⟩
+    · rw [ite_eq_right h, heckeRep_coe, heckeRep_coe]
+      set y : ZMod p := (redMatrix p g 0 0 * j + redMatrix p g 0 1) /
+        (redMatrix p g 1 0 * j + redMatrix p g 1 1) with hy
+      obtain ⟨e, he⟩ : (p : ℤ) ∣ g 0 1 + j.val * g 1 1 - y.val * (g 0 0 + j.val * g 1 0) := by
+        rw [← ZMod.intCast_zmod_eq_zero_iff_dvd]
+        push_cast
+        rw [ZMod.natCast_zmod_val, ZMod.natCast_zmod_val,
+          show ((g 0 0 : ℤ) : ZMod p) + j * ((g 1 0 : ℤ) : ZMod p)
+            = redMatrix p g 1 0 * j + redMatrix p g 1 1 by
+              rw [redMatrix_apply_one_zero, redMatrix_apply_one_one]; ring,
+          hy, div_mul_cancel₀ _ h, redMatrix_apply_zero_zero, redMatrix_apply_zero_one]
+        ring
+      obtain ⟨g', hg', hmul⟩ := heckeMatrix_mul_of_eq hp g j.val y.val e (by linear_combination he)
+      exact ⟨g', hg' ▸ dvd_mul_of_dvd_right hg _, hmul⟩
+
+variable {N : ℕ} (k : ℤ)
+
+theorem heckeT_slash_mapGL (hpN : ¬ p ∣ N) (f : ℍ → ℂ)
+    (hf : ∀ γ ∈ (CongruenceSubgroup.Gamma0 N : Subgroup (GL (Fin 2) ℝ)), f ∣[k] γ = f)
+    (g : SL(2, ℤ)) (hg : g ∈ CongruenceSubgroup.Gamma0 N) :
+    heckeT k p f ∣[k] (mapGL ℝ g) = heckeT k p f := by
+  have hcN : (N : ℤ) ∣ g 1 0 :=
+    (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp (CongruenceSubgroup.Gamma0_mem.mp hg)
+  rw [heckeT_eq_sum_onePoint k f, SlashAction.sum_slash]
+  calc ∑ x : OnePoint (ZMod p), (f ∣[k] heckeRep p x) ∣[k] mapGL ℝ g
+      = ∑ x : OnePoint (ZMod p), f ∣[k] heckeRep p (redMatrix p g • x) := by
+        refine Finset.sum_congr rfl fun x _ ↦ ?_
+        obtain ⟨g', hg', hmul⟩ := heckeRep_mul hpN g hcN x
+        have hg'N : g' ∈ CongruenceSubgroup.Gamma0 N :=
+          CongruenceSubgroup.Gamma0_mem.mpr ((ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mpr hg')
+        rw [← SlashAction.slash_mul, hmul, SlashAction.slash_mul,
+          hf _ (Subgroup.mem_map_of_mem (mapGL ℝ) hg'N)]
+    _ = ∑ x : OnePoint (ZMod p), f ∣[k] heckeRep p x :=
+        Equiv.sum_comp (MulAction.toPerm (redMatrix p g)) (fun x ↦ f ∣[k] heckeRep p x)
+
+end heckeT
+
+end HeckeSlashInvariance
+
+open HeckeSlashInvariance in
+theorem heckeT_slash_eq_self_of_mem_Gamma0' {N : ℕ} (k : ℤ) {p : ℕ} (hp : p.Prime) (hpN : ¬ p ∣ N)
+    {f : UpperHalfPlane → ℂ}
+    (hf : ∀ γ ∈ (CongruenceSubgroup.Gamma0 N : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)),
+      SlashAction.map k γ f = f)
+    (γ : Matrix.GeneralLinearGroup (Fin 2) ℝ)
+    (hγ : γ ∈ (CongruenceSubgroup.Gamma0 N : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ))) :
+    SlashAction.map k γ (ModularForm.heckeT k p f) = ModularForm.heckeT k p f := by
+  have : Fact p.Prime := ⟨hp⟩
+  obtain ⟨g, hg, rfl⟩ := hγ
+  exact heckeT_slash_mapGL k hpN f hf g hg
+
+open HeckeSlashInvariance in
+theorem heckeU_slash_eq_self_of_mem_Gamma0' {N : ℕ} (k : ℤ) {p : ℕ} (hpN : p ∣ N)
+    {f : UpperHalfPlane → ℂ}
+    (hf : ∀ γ ∈ (CongruenceSubgroup.Gamma0 N : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)),
+      SlashAction.map k γ f = f)
+    (γ : Matrix.GeneralLinearGroup (Fin 2) ℝ)
+    (hγ : γ ∈ (CongruenceSubgroup.Gamma0 N : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ))) :
+    SlashAction.map k γ (ModularForm.heckeU k p f) = ModularForm.heckeU k p f := by
+  rcases Nat.eq_zero_or_pos p with rfl | hp
+  · simp
+  have : NeZero p := ⟨hp.ne'⟩
+  obtain ⟨g, hg, rfl⟩ := hγ
+  exact heckeU_slash_mapGL k hpN f hf g hg
+
+end ModularForm
+
+theorem solution {N : ℕ} (k : ℤ) {p : ℕ} (hp : p.Prime) (hpN : ¬ p ∣ N) {f : UpperHalfPlane → ℂ} (hf
+  : ∀ γ ∈ (CongruenceSubgroup.Gamma0 N : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)),
+  SlashAction.map k γ f = f) (γ : Matrix.GeneralLinearGroup (Fin 2) ℝ) (hγ : γ ∈
+  (CongruenceSubgroup.Gamma0 N : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ))) :
+    SlashAction.map k γ (ModularForm.heckeT k p f) = ModularForm.heckeT k p f :=
+  ModularForm.heckeT_slash_eq_self_of_mem_Gamma0' k hp hpN hf γ hγ
+
+end
+end S_ModularForm_heckeT_slash_eq_self_of_mem_Gamma0
+end P2MW
+export P2MW.S_ModularForm_heckeT_slash_eq_self_of_mem_Gamma0 (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularForm.heckeT_slash_eq_self_of_mem_Gamma0 {N : ℕ} (k : ℤ) {p : ℕ} (hp : p.Prime) (hpN :
+  ¬ p ∣ N) {f : UpperHalfPlane → ℂ} (hf : ∀ γ ∈ (CongruenceSubgroup.Gamma0 N : Subgroup
+  (Matrix.GeneralLinearGroup (Fin 2) ℝ)), SlashAction.map k γ f = f) (γ : Matrix.GeneralLinearGroup
+  (Fin 2) ℝ) (hγ : γ ∈ (CongruenceSubgroup.Gamma0 N : Subgroup (Matrix.GeneralLinearGroup (Fin 2)
+  ℝ))) :
+    SlashAction.map k γ (ModularForm.heckeT k p f) = ModularForm.heckeT k p f :=
+  solution k hp hpN hf γ hγ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_heckeU_slash_eq_self_of_mem_Gamma0.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_heckeU_slash_eq_self_of_mem_Gamma0.lean
new file mode 100644
index 0000000000..15966a45dd
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_heckeU_slash_eq_self_of_mem_Gamma0.lean
@@ -0,0 +1,445 @@
+/-
+Based on Prove2Me node ModularForm.heckeU_slash_eq_self_of_mem_Gamma0
+(9f17ad58-ad6c-5a85-ac1d-ca32b4f24fd3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c5cf11ce-073d-5c43-b76f-81444a1bbe3e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import Mathlib.Algebra.Field.ZMod
+import Mathlib.Topology.Compactification.OnePoint.ProjectiveLine
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Uₚ preserves weight-k invariance under Γ₀(N)
+
+Theorem statement: `ModularForm.heckeU_slash_eq_self_of_mem_Gamma0`
+(`9f17ad58-ad6c-5a85-ac1d-ca32b4f24fd3`), by Claude, 2026-09-05.
+
+Proof: submission `c5cf11ce-073d-5c43-b76f-81444a1bbe3e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, $k$ an integer, and $p$ a natural number dividing $N$. Let $f :
+\mathbb{H} \to \mathbb{C}$ be a function on the upper half-plane which is invariant under the
+weight-$k$ slash action of $\Gamma_0(N)$, in the sense that $f \mid_k \gamma = f$ for every $\gamma$
+in the image of the congruence subgroup $\Gamma_0(N)$ inside $\mathrm{GL}_2(\mathbb{R})$. Let
+$\gamma$ be an element of $\mathrm{GL}_2(\mathbb{R})$ lying in that subgroup. The conclusion is that
+the function
+$$\mathrm{heckeU}\,k\,p\,f \;=\; \sum_{j=0}^{p-1} f \mid_k M_{p,j}, \qquad M_{p,j} \;=\;
+\begin{pmatrix} 1 & j \\ 0 & p \end{pmatrix} \in \mathrm{GL}_2(\mathbb{R}) \ \ (M_{0,j} = 1),$$
+satisfies $(\mathrm{heckeU}\,k\,p\,f) \mid_k \gamma = \mathrm{heckeU}\,k\,p\,f$; that is, the finite
+sum of weight-$k$ slashes of $f$ by the matrices $\begin{pmatrix} 1 & j \\ 0 & p \end{pmatrix}$, $0
+\le j < p$, is again invariant under the weight-$k$ action of $\Gamma_0(N)$. No primality of $p$ is
+assumed, and $f$ is an arbitrary function, subject only to the invariance hypothesis: no holomorphy,
+growth or cusp condition enters.
+
+This is the level-preservation half of the classical statement that the Atkin–Lehner operator $U_p$,
+for $p$ dividing the level $N$, acts on weight-$k$ modular forms for $\Gamma_0(N)$, isolated here at
+the level of bare functions invariant under the slash action. It is used by
+[`CuspForm.exists_coe_eq_heckeU`](thm.html#CuspForm.exists_coe_eq_heckeU), which produces a cusp
+form whose underlying function is $U_p f$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_heckeU_slash_eq_self_of_mem_Gamma0.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_heckeU_slash_eq_self_of_mem_Gamma0
+
+noncomputable section
+
+open Matrix.SpecialLinearGroup UpperHalfPlane
+p2m_open_scoped "MatrixGroups ModularForm \
+  P2MW.S_ModularForm_heckeU_slash_eq_self_of_mem_Gamma0.ModularForm OnePoint"
+
+namespace ModularForm
+p2m_export "ModularForm" "rec ext heckeMatrix heckeDiagMatrix heckeU heckeT heckeU_def \
+  heckeT_eq_heckeU_add"
+p2m_open "ModularForm"
+
+namespace HeckeSlashInvariance
+
+@[scoped simp] theorem mapGL_apply (g : SL(2, ℤ)) (i j : Fin 2) :
+    (mapGL ℝ g : GL (Fin 2) ℝ) i j = ((g i j : ℤ) : ℝ) := by
+  simp
+
+theorem det_eq (g : SL(2, ℤ)) : g 0 0 * g 1 1 - g 0 1 * g 1 0 = 1 := by
+  have h := g.det_coe
+  rwa [Matrix.det_fin_two] at h
+
+section commutation
+
+variable {p : ℕ} (hp : p ≠ 0)
+include hp
+
+theorem heckeMatrix_mul_of_eq (g : SL(2, ℤ)) (j j' : ℕ) (e : ℤ)
+    (he : g 0 1 + j * g 1 1 = j' * (g 0 0 + j * g 1 0) + p * e) :
+    ∃ g' : SL(2, ℤ), g' 1 0 = p * g 1 0 ∧
+      heckeMatrix p j * mapGL ℝ g = mapGL ℝ g' * heckeMatrix p j' := by
+  have hdet := det_eq g
+  refine ⟨⟨!![g 0 0 + j * g 1 0, e; p * g 1 0, g 1 1 - g 1 0 * j'], ?_⟩, rfl, ?_⟩
+  · rw [Matrix.det_fin_two_of]
+    linear_combination hdet + (g 1 0) * he
+  · ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp only [Fin.zero_eta, Fin.isValue, Units.val_mul, ne_eq, hp, not_false_eq_true,
+        val_heckeMatrix, mapGL_coe_matrix, algebraMap_int_eq, map_apply_coe,
+        RingHom.mapMatrix_apply, Int.coe_castRingHom, Matrix.mul_apply, Matrix.of_apply,
+        Matrix.cons_val', Matrix.cons_val_fin_one, Matrix.cons_val_zero, Matrix.map_apply,
+        Fin.sum_univ_two, one_mul, Matrix.cons_val_one, Int.cast_add, Int.cast_mul,
+        Int.cast_natCast, mul_one, mul_zero, add_zero, Fin.mk_one, zero_mul, zero_add, Int.cast_sub]
+    all_goals first
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination this)
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination -this)
+      | ring1
+
+theorem heckeMatrix_mul_of_eq' (g : SL(2, ℤ)) (j : ℕ) (e : ℤ)
+    (he : g 0 0 + j * g 1 0 = p * e) :
+    ∃ g' : SL(2, ℤ), g' 1 0 = g 1 0 ∧
+      heckeMatrix p j * mapGL ℝ g = mapGL ℝ g' * heckeDiagMatrix p := by
+  have hdet := det_eq g
+  refine ⟨⟨!![e, g 0 1 + j * g 1 1; g 1 0, p * g 1 1], ?_⟩, rfl, ?_⟩
+  · rw [Matrix.det_fin_two_of]
+    linear_combination hdet - (g 1 1) * he
+  · ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp only [Fin.zero_eta, Fin.isValue, Units.val_mul, ne_eq, hp, not_false_eq_true,
+        val_heckeMatrix, mapGL_coe_matrix, algebraMap_int_eq, map_apply_coe,
+        RingHom.mapMatrix_apply, Int.coe_castRingHom, Matrix.mul_apply, Matrix.of_apply,
+        Matrix.cons_val', Matrix.cons_val_fin_one, Matrix.cons_val_zero, Matrix.map_apply,
+        Fin.sum_univ_two, one_mul, Matrix.cons_val_one, val_heckeDiagMatrix, Int.cast_add,
+        Int.cast_mul, Int.cast_natCast, mul_zero, add_zero, Fin.mk_one, mul_one, zero_add, zero_mul]
+    all_goals first
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination this)
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination -this)
+      | ring1
+
+theorem heckeDiagMatrix_mul_of_eq (g : SL(2, ℤ)) (j' : ℕ) (e : ℤ)
+    (he : g 1 1 = g 1 0 * j' + p * e) :
+    ∃ g' : SL(2, ℤ), g' 1 0 = g 1 0 ∧
+      heckeDiagMatrix p * mapGL ℝ g = mapGL ℝ g' * heckeMatrix p j' := by
+  have hdet := det_eq g
+  refine ⟨⟨!![p * g 0 0, g 0 1 - g 0 0 * j'; g 1 0, e], ?_⟩, rfl, ?_⟩
+  · rw [Matrix.det_fin_two_of]
+    linear_combination hdet - (g 0 0) * he
+  · ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp only [Fin.zero_eta, Fin.isValue, Units.val_mul, ne_eq, hp, not_false_eq_true,
+        val_heckeDiagMatrix, mapGL_coe_matrix, algebraMap_int_eq, map_apply_coe,
+        RingHom.mapMatrix_apply, Int.coe_castRingHom, Matrix.mul_apply, Matrix.of_apply,
+        Matrix.cons_val', Matrix.cons_val_fin_one, Matrix.cons_val_zero, Matrix.map_apply,
+        Fin.sum_univ_two, Matrix.cons_val_one, zero_mul, add_zero, val_heckeMatrix, Int.cast_mul,
+        Int.cast_natCast, mul_one, Int.cast_sub, mul_zero, Fin.mk_one, one_mul, zero_add]
+    all_goals first
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination this)
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination -this)
+      | ring1
+
+theorem heckeDiagMatrix_mul_of_eq' (g : SL(2, ℤ)) (e : ℤ) (he : g 1 0 = p * e) :
+    ∃ g' : SL(2, ℤ), g' 1 0 = e ∧
+      heckeDiagMatrix p * mapGL ℝ g = mapGL ℝ g' * heckeDiagMatrix p := by
+  have hdet := det_eq g
+  refine ⟨⟨!![g 0 0, p * g 0 1; e, g 1 1], ?_⟩, rfl, ?_⟩
+  · rw [Matrix.det_fin_two_of]
+    linear_combination hdet + (g 0 1) * he
+  · ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp only [Fin.zero_eta, Fin.isValue, Units.val_mul, ne_eq, hp, not_false_eq_true,
+        val_heckeDiagMatrix, mapGL_coe_matrix, algebraMap_int_eq, map_apply_coe,
+        RingHom.mapMatrix_apply, Int.coe_castRingHom, Matrix.mul_apply, Matrix.of_apply,
+        Matrix.cons_val', Matrix.cons_val_fin_one, Matrix.cons_val_zero, Matrix.map_apply,
+        Fin.sum_univ_two, Matrix.cons_val_one, zero_mul, add_zero, Int.cast_mul, Int.cast_natCast,
+        mul_zero, Fin.mk_one, mul_one, zero_add, one_mul]
+    all_goals first
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination this)
+      | (have := congrArg (Int.cast : ℤ → ℝ) he; push_cast at this ⊢; linear_combination -this)
+      | ring1
+
+end commutation
+
+section reindex
+
+variable {p : ℕ} [NeZero p]
+
+theorem sum_range_eq_sum_zmod {M : Type*} [AddCommMonoid M] (F : ℕ → M) :
+    ∑ j ∈ Finset.range p, F j = ∑ x : ZMod p, F x.val := by
+  refine Finset.sum_nbij' (fun j : ℕ ↦ (j : ZMod p)) (fun x : ZMod p ↦ x.val) (fun _ _ ↦
+    Finset.mem_univ _)
+    (fun x _ ↦ Finset.mem_range.mpr x.val_lt) (fun j hj ↦ ?_) (fun x _ ↦ ?_) (fun j hj ↦ ?_)
+  · exact ZMod.val_cast_of_lt (Finset.mem_range.mp hj)
+  · exact ZMod.natCast_zmod_val x
+  · rw [ZMod.val_cast_of_lt (Finset.mem_range.mp hj)]
+
+theorem heckeU_eq_sum_zmod (k : ℤ) (f : ℍ → ℂ) :
+    heckeU k p f = ∑ x : ZMod p, f ∣[k] heckeMatrix p x.val := by
+  rw [heckeU_def]
+  exact sum_range_eq_sum_zmod _
+
+end reindex
+
+section heckeU
+
+variable {p : ℕ}
+
+theorem unit_of_apply_one_zero_eq_zero (g : SL(2, ℤ)) (hc : ((g 1 0 : ℤ) : ZMod p) = 0) :
+    ((g 0 0 : ℤ) : ZMod p) * ((g 1 1 : ℤ) : ZMod p) = 1 := by
+  have := congrArg (Int.cast : ℤ → ZMod p) (det_eq g)
+  push_cast at this
+  linear_combination this + ((g 0 1 : ℤ) : ZMod p) * hc
+
+def affinePerm (g : SL(2, ℤ)) (hc : ((g 1 0 : ℤ) : ZMod p) = 0) : Equiv.Perm (ZMod p) where
+  toFun j := ((g 1 1 : ℤ) : ZMod p) * (((g 0 1 : ℤ) : ZMod p) + ((g 1 1 : ℤ) : ZMod p) * j)
+  invFun j := ((g 0 0 : ℤ) : ZMod p) * (((g 0 0 : ℤ) : ZMod p) * j - ((g 0 1 : ℤ) : ZMod p))
+  left_inv j := by
+    linear_combination (((g 0 0 : ℤ) : ZMod p) * ((g 0 1 : ℤ) : ZMod p)
+      + j * (((g 0 0 : ℤ) : ZMod p) * ((g 1 1 : ℤ) : ZMod p) + 1)) *
+        unit_of_apply_one_zero_eq_zero g hc
+  right_inv j := by
+    linear_combination (-(((g 1 1 : ℤ) : ZMod p) * ((g 0 1 : ℤ) : ZMod p))
+      + j * (((g 0 0 : ℤ) : ZMod p) * ((g 1 1 : ℤ) : ZMod p) + 1)) *
+        unit_of_apply_one_zero_eq_zero g hc
+
+theorem affinePerm_apply (g : SL(2, ℤ)) (hc : ((g 1 0 : ℤ) : ZMod p) = 0) (j : ZMod p) :
+    affinePerm g hc j =
+      ((g 1 1 : ℤ) : ZMod p) * (((g 0 1 : ℤ) : ZMod p) + ((g 1 1 : ℤ) : ZMod p) * j) := rfl
+
+variable [NeZero p]
+
+theorem heckeMatrix_mul_of_dvd (g : SL(2, ℤ)) (hc : (p : ℤ) ∣ g 1 0) (x : ZMod p) :
+    ∃ g' : SL(2, ℤ), g' 1 0 = p * g 1 0 ∧
+      heckeMatrix p x.val * mapGL ℝ g =
+        mapGL ℝ g' * heckeMatrix p (affinePerm g ((ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mpr hc)
+          x).val := by
+  have hc0 : ((g 1 0 : ℤ) : ZMod p) = 0 := (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mpr hc
+  set x' := affinePerm g hc0 x with hx'
+  obtain ⟨e, he⟩ : (p : ℤ) ∣ g 0 1 + x.val * g 1 1 - x'.val * (g 0 0 + x.val * g 1 0) := by
+    rw [← ZMod.intCast_zmod_eq_zero_iff_dvd]
+    push_cast
+    rw [ZMod.natCast_zmod_val, ZMod.natCast_zmod_val, hx', affinePerm_apply]
+    linear_combination (-(((g 0 1 : ℤ) : ZMod p) + x * ((g 1 1 : ℤ) : ZMod p))) *
+      unit_of_apply_one_zero_eq_zero g hc0
+      - (((g 1 1 : ℤ) : ZMod p) * (((g 0 1 : ℤ) : ZMod p) + ((g 1 1 : ℤ) : ZMod p) * x) * x) * hc0
+  exact heckeMatrix_mul_of_eq (NeZero.ne p) g x.val x'.val e (by linear_combination he)
+
+variable {N : ℕ} (k : ℤ)
+
+theorem heckeU_slash_mapGL (hpN : p ∣ N) (f : ℍ → ℂ)
+    (hf : ∀ γ ∈ (CongruenceSubgroup.Gamma0 N : Subgroup (GL (Fin 2) ℝ)), f ∣[k] γ = f)
+    (g : SL(2, ℤ)) (hg : g ∈ CongruenceSubgroup.Gamma0 N) :
+    heckeU k p f ∣[k] (mapGL ℝ g) = heckeU k p f := by
+  have hcN : (N : ℤ) ∣ g 1 0 :=
+    (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp (CongruenceSubgroup.Gamma0_mem.mp hg)
+  have hc : (p : ℤ) ∣ g 1 0 := (Int.natCast_dvd_natCast.mpr hpN).trans hcN
+  rw [heckeU_eq_sum_zmod k f, SlashAction.sum_slash]
+  calc ∑ x : ZMod p, (f ∣[k] heckeMatrix p x.val) ∣[k] mapGL ℝ g
+      = ∑ x : ZMod p, f ∣[k] heckeMatrix p
+          (affinePerm g ((ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mpr hc) x).val := by
+        refine Finset.sum_congr rfl fun x _ ↦ ?_
+        obtain ⟨g', hg', hmul⟩ := heckeMatrix_mul_of_dvd g hc x
+        have hg'N : g' ∈ CongruenceSubgroup.Gamma0 N := by
+          rw [CongruenceSubgroup.Gamma0_mem, hg']
+          push_cast
+          rw [CongruenceSubgroup.Gamma0_mem.mp hg, mul_zero]
+        rw [← SlashAction.slash_mul, hmul, SlashAction.slash_mul,
+          hf _ (Subgroup.mem_map_of_mem (mapGL ℝ) hg'N)]
+    _ = ∑ x : ZMod p, f ∣[k] heckeMatrix p x.val :=
+        Equiv.sum_comp (affinePerm g _) (fun x ↦ f ∣[k] heckeMatrix p x.val)
+
+end heckeU
+
+section heckeT
+
+variable {p : ℕ}
+
+def heckeRep (p : ℕ) (x : OnePoint (ZMod p)) : GL (Fin 2) ℝ :=
+  x.elim (heckeDiagMatrix p) (fun j ↦ heckeMatrix p j.val)
+
+@[scoped simp] theorem heckeRep_infty : heckeRep p ∞ = heckeDiagMatrix p := rfl
+
+@[scoped simp] theorem heckeRep_coe (j : ZMod p) : heckeRep p j = heckeMatrix p j.val := rfl
+
+theorem heckeT_eq_sum_onePoint [NeZero p] (k : ℤ) (f : ℍ → ℂ) :
+    heckeT k p f = ∑ x : OnePoint (ZMod p), f ∣[k] heckeRep p x := by
+  rw [heckeT_eq_heckeU_add, heckeU_eq_sum_zmod, add_comm]
+  exact (Fintype.sum_option (fun x : OnePoint (ZMod p) ↦ f ∣[k] heckeRep p x)).symm
+
+variable [Fact p.Prime]
+
+variable (p) in
+def redMatrix (g : SL(2, ℤ)) : GL (Fin 2) (ZMod p) :=
+  Matrix.GeneralLinearGroup.mkOfDetNeZero
+    !![((g 1 1 : ℤ) : ZMod p), ((g 0 1 : ℤ) : ZMod p); ((g 1 0 : ℤ) : ZMod p), ((g 0 0 : ℤ) : ZMod
+      p)]
+    (by
+      have := congrArg (Int.cast : ℤ → ZMod p) (det_eq g)
+      push_cast at this
+      rw [Matrix.det_fin_two_of,
+        show ((g 1 1 : ℤ) : ZMod p) * ((g 0 0 : ℤ) : ZMod p) - ((g 0 1 : ℤ) : ZMod p) * ((g 1 0 : ℤ)
+          : ZMod p)
+          = 1 by linear_combination this]
+      exact one_ne_zero)
+
+@[scoped simp] theorem redMatrix_apply_zero_zero (g : SL(2, ℤ)) :
+    redMatrix p g 0 0 = ((g 1 1 : ℤ) : ZMod p) := by
+  simp [redMatrix]
+
+@[scoped simp] theorem redMatrix_apply_zero_one (g : SL(2, ℤ)) :
+    redMatrix p g 0 1 = ((g 0 1 : ℤ) : ZMod p) := by
+  simp [redMatrix]
+
+@[scoped simp] theorem redMatrix_apply_one_zero (g : SL(2, ℤ)) :
+    redMatrix p g 1 0 = ((g 1 0 : ℤ) : ZMod p) := by
+  simp [redMatrix]
+
+@[scoped simp] theorem redMatrix_apply_one_one (g : SL(2, ℤ)) :
+    redMatrix p g 1 1 = ((g 0 0 : ℤ) : ZMod p) := by
+  simp [redMatrix]
+
+scoped instance : NeZero p := ⟨(Fact.out : p.Prime).ne_zero⟩
+
+theorem heckeRep_mul {N : ℕ} (hpN : ¬ p ∣ N) (g : SL(2, ℤ)) (hg : (N : ℤ) ∣ g 1 0)
+    (x : OnePoint (ZMod p)) :
+    ∃ g' : SL(2, ℤ), (N : ℤ) ∣ g' 1 0 ∧
+      heckeRep p x * mapGL ℝ g = mapGL ℝ g' * heckeRep p (redMatrix p g • x) := by
+  have hp : p ≠ 0 := (Fact.out : p.Prime).ne_zero
+  induction x using OnePoint.rec with
+  | infty =>
+    rw [OnePoint.smul_infty_eq_ite]
+    by_cases hc : ((g 1 0 : ℤ) : ZMod p) = 0
+    · rw [ite_eq_left (by simpa using hc), heckeRep_infty]
+      obtain ⟨e, he⟩ := (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp hc
+      obtain ⟨g', hg', hmul⟩ := heckeDiagMatrix_mul_of_eq' hp g e he
+      refine ⟨g', ?_, hmul⟩
+      rw [hg']
+      have hcop : IsCoprime (N : ℤ) (p : ℤ) :=
+        Nat.isCoprime_iff_coprime.mpr ((Nat.Prime.coprime_iff_not_dvd Fact.out).mpr hpN).symm
+      exact hcop.dvd_of_dvd_mul_left (he ▸ hg)
+    · rw [ite_eq_right (by simpa using hc), heckeRep_infty, heckeRep_coe]
+      set y : ZMod p := redMatrix p g 0 0 / redMatrix p g 1 0
+        with hy
+      obtain ⟨e, he⟩ : (p : ℤ) ∣ g 1 1 - g 1 0 * y.val := by
+        rw [← ZMod.intCast_zmod_eq_zero_iff_dvd]
+        push_cast
+        rw [ZMod.natCast_zmod_val, hy, redMatrix_apply_zero_zero, redMatrix_apply_one_zero,
+          mul_div_cancel₀ _ hc, sub_self]
+      obtain ⟨g', hg', hmul⟩ := heckeDiagMatrix_mul_of_eq hp g y.val e (by linear_combination he)
+      exact ⟨g', hg' ▸ hg, hmul⟩
+  | coe j =>
+    rw [OnePoint.smul_some_eq_ite]
+    by_cases h : redMatrix p g 1 0 * j + redMatrix p g 1 1 = 0
+    · rw [ite_eq_left h, heckeRep_infty, heckeRep_coe]
+      rw [redMatrix_apply_one_zero, redMatrix_apply_one_one] at h
+      obtain ⟨e, he⟩ : (p : ℤ) ∣ g 0 0 + j.val * g 1 0 := by
+        rw [← ZMod.intCast_zmod_eq_zero_iff_dvd]
+        push_cast
+        rw [ZMod.natCast_zmod_val]
+        linear_combination h
+      obtain ⟨g', hg', hmul⟩ := heckeMatrix_mul_of_eq' hp g j.val e he
+      exact ⟨g', hg' ▸ hg, hmul⟩
+    · rw [ite_eq_right h, heckeRep_coe, heckeRep_coe]
+      set y : ZMod p := (redMatrix p g 0 0 * j + redMatrix p g 0 1) /
+        (redMatrix p g 1 0 * j + redMatrix p g 1 1) with hy
+      obtain ⟨e, he⟩ : (p : ℤ) ∣ g 0 1 + j.val * g 1 1 - y.val * (g 0 0 + j.val * g 1 0) := by
+        rw [← ZMod.intCast_zmod_eq_zero_iff_dvd]
+        push_cast
+        rw [ZMod.natCast_zmod_val, ZMod.natCast_zmod_val,
+          show ((g 0 0 : ℤ) : ZMod p) + j * ((g 1 0 : ℤ) : ZMod p)
+            = redMatrix p g 1 0 * j + redMatrix p g 1 1 by
+              rw [redMatrix_apply_one_zero, redMatrix_apply_one_one]; ring,
+          hy, div_mul_cancel₀ _ h, redMatrix_apply_zero_zero, redMatrix_apply_zero_one]
+        ring
+      obtain ⟨g', hg', hmul⟩ := heckeMatrix_mul_of_eq hp g j.val y.val e (by linear_combination he)
+      exact ⟨g', hg' ▸ dvd_mul_of_dvd_right hg _, hmul⟩
+
+variable {N : ℕ} (k : ℤ)
+
+theorem heckeT_slash_mapGL (hpN : ¬ p ∣ N) (f : ℍ → ℂ)
+    (hf : ∀ γ ∈ (CongruenceSubgroup.Gamma0 N : Subgroup (GL (Fin 2) ℝ)), f ∣[k] γ = f)
+    (g : SL(2, ℤ)) (hg : g ∈ CongruenceSubgroup.Gamma0 N) :
+    heckeT k p f ∣[k] (mapGL ℝ g) = heckeT k p f := by
+  have hcN : (N : ℤ) ∣ g 1 0 :=
+    (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp (CongruenceSubgroup.Gamma0_mem.mp hg)
+  rw [heckeT_eq_sum_onePoint k f, SlashAction.sum_slash]
+  calc ∑ x : OnePoint (ZMod p), (f ∣[k] heckeRep p x) ∣[k] mapGL ℝ g
+      = ∑ x : OnePoint (ZMod p), f ∣[k] heckeRep p (redMatrix p g • x) := by
+        refine Finset.sum_congr rfl fun x _ ↦ ?_
+        obtain ⟨g', hg', hmul⟩ := heckeRep_mul hpN g hcN x
+        have hg'N : g' ∈ CongruenceSubgroup.Gamma0 N :=
+          CongruenceSubgroup.Gamma0_mem.mpr ((ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mpr hg')
+        rw [← SlashAction.slash_mul, hmul, SlashAction.slash_mul,
+          hf _ (Subgroup.mem_map_of_mem (mapGL ℝ) hg'N)]
+    _ = ∑ x : OnePoint (ZMod p), f ∣[k] heckeRep p x :=
+        Equiv.sum_comp (MulAction.toPerm (redMatrix p g)) (fun x ↦ f ∣[k] heckeRep p x)
+
+end heckeT
+
+end HeckeSlashInvariance
+
+open HeckeSlashInvariance in
+theorem heckeT_slash_eq_self_of_mem_Gamma0' {N : ℕ} (k : ℤ) {p : ℕ} (hp : p.Prime) (hpN : ¬ p ∣ N)
+    {f : UpperHalfPlane → ℂ}
+    (hf : ∀ γ ∈ (CongruenceSubgroup.Gamma0 N : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)),
+      SlashAction.map k γ f = f)
+    (γ : Matrix.GeneralLinearGroup (Fin 2) ℝ)
+    (hγ : γ ∈ (CongruenceSubgroup.Gamma0 N : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ))) :
+    SlashAction.map k γ (ModularForm.heckeT k p f) = ModularForm.heckeT k p f := by
+  have : Fact p.Prime := ⟨hp⟩
+  obtain ⟨g, hg, rfl⟩ := hγ
+  exact heckeT_slash_mapGL k hpN f hf g hg
+
+open HeckeSlashInvariance in
+theorem heckeU_slash_eq_self_of_mem_Gamma0' {N : ℕ} (k : ℤ) {p : ℕ} (hpN : p ∣ N)
+    {f : UpperHalfPlane → ℂ}
+    (hf : ∀ γ ∈ (CongruenceSubgroup.Gamma0 N : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)),
+      SlashAction.map k γ f = f)
+    (γ : Matrix.GeneralLinearGroup (Fin 2) ℝ)
+    (hγ : γ ∈ (CongruenceSubgroup.Gamma0 N : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ))) :
+    SlashAction.map k γ (ModularForm.heckeU k p f) = ModularForm.heckeU k p f := by
+  rcases Nat.eq_zero_or_pos p with rfl | hp
+  · simp
+  have : NeZero p := ⟨hp.ne'⟩
+  obtain ⟨g, hg, rfl⟩ := hγ
+  exact heckeU_slash_mapGL k hpN f hf g hg
+
+end ModularForm
+
+theorem solution {N : ℕ} (k : ℤ) {p : ℕ} (hpN : p ∣ N) {f : UpperHalfPlane → ℂ} (hf : ∀ γ ∈
+  (CongruenceSubgroup.Gamma0 N : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ)), SlashAction.map k
+  γ f = f) (γ : Matrix.GeneralLinearGroup (Fin 2) ℝ) (hγ : γ ∈ (CongruenceSubgroup.Gamma0 N :
+  Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ))) :
+    SlashAction.map k γ (ModularForm.heckeU k p f) = ModularForm.heckeU k p f :=
+  ModularForm.heckeU_slash_eq_self_of_mem_Gamma0' k hpN hf γ hγ
+
+end
+end S_ModularForm_heckeU_slash_eq_self_of_mem_Gamma0
+end P2MW
+export P2MW.S_ModularForm_heckeU_slash_eq_self_of_mem_Gamma0 (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularForm.heckeU_slash_eq_self_of_mem_Gamma0 {N : ℕ} (k : ℤ) {p : ℕ} (hpN : p ∣ N) {f :
+  UpperHalfPlane → ℂ} (hf : ∀ γ ∈ (CongruenceSubgroup.Gamma0 N : Subgroup (Matrix.GeneralLinearGroup
+  (Fin 2) ℝ)), SlashAction.map k γ f = f) (γ : Matrix.GeneralLinearGroup (Fin 2) ℝ) (hγ : γ ∈
+  (CongruenceSubgroup.Gamma0 N : Subgroup (Matrix.GeneralLinearGroup (Fin 2) ℝ))) :
+    SlashAction.map k γ (ModularForm.heckeU k p f) = ModularForm.heckeU k p f :=
+  solution k hpN hf γ hγ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_isBoundedAtImInfty_heckeT.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_isBoundedAtImInfty_heckeT.lean
new file mode 100644
index 0000000000..76e2e15d5b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_isBoundedAtImInfty_heckeT.lean
@@ -0,0 +1,407 @@
+/-
+Based on Prove2Me node ModularForm.isBoundedAtImInfty_heckeT
+(8d04f3f6-88fa-5055-b10d-e1d6631bbd39) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission cf1c71a5-e422-5a7f-a76b-0cc6acb8ac87
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.Complex.UpperHalfPlane.FunctionsBoundedAtInfty
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Boundedness at i∞ is preserved by Tₚ
+
+Theorem statement: `ModularForm.isBoundedAtImInfty_heckeT` (`8d04f3f6-88fa-5055-b10d-e1d6631bbd39`),
+by Claude, 2026-09-05.
+
+Proof: submission `cf1c71a5-e422-5a7f-a76b-0cc6acb8ac87`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $f:\mathbb{H}\to\mathbb{C}$ be a function on the upper half-plane which is bounded at infinity,
+i.e. `UpperHalfPlane.IsBoundedAtImInfty f`: $f$ is bounded along the filter of points with large
+imaginary part. Let $k\in\mathbb{Z}$ be a weight and $p$ a natural number, with no primality,
+positivity or modularity assumption on $p$, $k$ or $f$. The assertion is that [`ModularForm.heckeT k
+p f`](def/ModularForm_HeckeOperator.html#L96) is again bounded at infinity. Here `heckeT k p f` is,
+by definition, the sum of `heckeU k p f`, namely $\sum_{j<p} f\mid[k]\,$`heckeMatrix p j` where the
+slash is the weight-$k$ action of $\mathrm{GL}_2(\mathbb{R})$ on functions on $\mathbb{H}$ and
+`heckeMatrix p j` is the $j$-th of the $p$ matrices used in the definition of the Hecke operator,
+and the single extra term $f\mid[k]\,$`heckeDiagMatrix p`, where `heckeDiagMatrix p` is the identity
+if $p=0$ and otherwise the element `upperTriangularGL p 0 1` of $\mathrm{GL}_2(\mathbb{R})$, the
+upper-triangular matrix with diagonal entries $p$ and $1$ and upper-right entry $0$. Thus for $p\neq
+0$ the conclusion concerns $\tau\mapsto p^{-1}\sum_{j<p} f((\tau+j)/p)+p^{k-1}f(p\tau)$ up to the
+normalisation built into the slash action, and for $p=0$ it concerns $f$ itself.
+
+This is the growth half of the statement that the Hecke operator $T_p$ preserves modular and cusp
+forms: each of the $p+1$ matrices involved is upper triangular, so that translating $f$ by it
+preserves boundedness as $\operatorname{Im}\tau\to\infty$. It is used in the construction of $T_p$
+on spaces of modular and cusp forms and in the computations relating $q$-expansion coefficients of
+an eigenform to its eigenvalue.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_isBoundedAtImInfty_heckeT.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_ModularForm_isBoundedAtImInfty_heckeT
+
+noncomputable section
+
+open Complex Function Filter
+p2m_open "UpperHalfPlane~I"
+open scoped Real MatrixGroups ModularForm Manifold Topology
+
+namespace M4cP1W2
+
+open ModularForm ModularFormClass
+
+section Matrices
+
+variable (p j : ℕ)
+
+theorem heckeMatrix_one_zero :
+    ((heckeMatrix p j : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) 1 0 = 0 := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  · rw [val_heckeMatrix hp]; rfl
+
+theorem heckeDiagMatrix_one_zero :
+    ((heckeDiagMatrix p : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) 1 0 = 0 := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  · rw [val_heckeDiagMatrix hp]; rfl
+
+end Matrices
+
+section Regularity
+
+variable {f : ℍ → ℂ} (k : ℤ) (p : ℕ)
+
+theorem mdifferentiable_heckeU (hf : MDiff f) : MDiff (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => MDiff g) (fun _ _ ha hb => ha.add hb)
+    mdifferentiable_const (fun _ _ => hf.slash k _)
+
+theorem mdifferentiable_heckeT (hf : MDiff f) : MDiff (heckeT k p f) :=
+  (mdifferentiable_heckeU k p hf).add (hf.slash k _)
+
+theorem isBoundedAtImInfty_heckeU (hf : IsBoundedAtImInfty f) :
+    IsBoundedAtImInfty (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => IsBoundedAtImInfty g)
+    (fun _ _ ha hb => ha.add hb) UpperHalfPlane.zero_form_isBoundedAtImInfty
+    (fun j _ => hf.slash k (heckeMatrix_one_zero p j))
+
+theorem isBoundedAtImInfty_heckeT (hf : IsBoundedAtImInfty f) :
+    IsBoundedAtImInfty (heckeT k p f) :=
+  (isBoundedAtImInfty_heckeU k p hf).add (hf.slash k (heckeDiagMatrix_one_zero p))
+
+theorem isZeroAtImInfty_heckeU (hf : IsZeroAtImInfty f) :
+    IsZeroAtImInfty (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => IsZeroAtImInfty g)
+    (fun _ _ ha hb => ha.add hb) (zero_zeroAtFilter atImInfty)
+    (fun j _ => hf.slash k (heckeMatrix_one_zero p j))
+
+theorem isZeroAtImInfty_heckeT (hf : IsZeroAtImInfty f) :
+    IsZeroAtImInfty (heckeT k p f) :=
+  (isZeroAtImInfty_heckeU k p hf).add (hf.slash k (heckeDiagMatrix_one_zero p))
+
+theorem apply_eq_of_coe_eq_add_nat (hf : Periodic (f ∘ ofComplex) 1) {τ₁ τ₂ : ℍ} (m : ℕ)
+    (h : (τ₁ : ℂ) = τ₂ + m) : f τ₁ = f τ₂ := by
+  have h1 : (f ∘ ofComplex) ((τ₂ : ℂ) + m) = (f ∘ ofComplex) (τ₂ : ℂ) := by
+    have := hf.nat_mul m
+    rw [mul_one] at this
+    exact this (τ₂ : ℂ)
+  simp only [comp_apply] at h1
+  rw [← h, ofComplex_apply, ofComplex_apply] at h1
+  exact h1
+
+variable {p} in
+theorem heckeMatrix_smul_vadd (hp : p ≠ 0) (j : ℕ) (τ : ℍ) :
+    heckeMatrix p j • ((1 : ℝ) +ᵥ τ) = heckeMatrix p (j + 1) • τ := by
+  apply UpperHalfPlane.ext
+  rw [coe_heckeMatrix_smul hp, coe_heckeMatrix_smul hp, coe_vadd]
+  push_cast
+  ring
+
+variable {p} in
+theorem coe_heckeMatrix_smul_self (hp : p ≠ 0) (τ : ℍ) :
+    ((heckeMatrix p p • τ : ℍ) : ℂ) = (heckeMatrix p 0 • τ : ℍ) + (1 : ℕ) := by
+  have hp' : (p : ℂ) ≠ 0 := by exact_mod_cast hp
+  rw [coe_heckeMatrix_smul hp, coe_heckeMatrix_smul hp]
+  field_simp
+  push_cast
+  ring
+
+variable {p} in
+theorem coe_heckeDiagMatrix_smul_vadd (hp : p ≠ 0) (τ : ℍ) :
+    ((heckeDiagMatrix p • ((1 : ℝ) +ᵥ τ) : ℍ) : ℂ) = (heckeDiagMatrix p • τ : ℍ) + (p : ℕ) := by
+  rw [coe_heckeDiagMatrix_smul hp, coe_heckeDiagMatrix_smul hp, coe_vadd]
+  push_cast
+  ring
+
+variable {p} in
+theorem sum_heckeMatrix_smul_vadd (hp : p ≠ 0) (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    ∑ j ∈ Finset.range p, f (heckeMatrix p j • ((1 : ℝ) +ᵥ τ))
+      = ∑ j ∈ Finset.range p, f (heckeMatrix p j • τ) := by
+  simp only [heckeMatrix_smul_vadd hp]
+  have h0 := Finset.sum_range_succ' (fun j => f (heckeMatrix p j • τ)) p
+  have h1 := Finset.sum_range_succ (fun j => f (heckeMatrix p j • τ)) p
+  rw [apply_eq_of_coe_eq_add_nat hf 1 (coe_heckeMatrix_smul_self hp τ)] at h1
+  exact add_right_cancel (h0.symm.trans h1)
+
+theorem heckeU_vadd (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    heckeU k p f ((1 : ℝ) +ᵥ τ) = heckeU k p f τ := by
+  by_cases hp : p = 0
+  · simp only [hp, heckeU_zero_left, Pi.zero_apply]
+  · rw [heckeU_apply k hp, heckeU_apply k hp, sum_heckeMatrix_smul_vadd hp hf]
+
+theorem heckeT_vadd (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    heckeT k p f ((1 : ℝ) +ᵥ τ) = heckeT k p f τ := by
+  by_cases hp : p = 0
+  · simp only [hp, heckeT_zero_left]
+    exact apply_eq_of_coe_eq_add_nat hf 1 (by rw [coe_vadd]; push_cast; ring)
+  · rw [heckeT_apply k hp, heckeT_apply k hp, sum_heckeMatrix_smul_vadd hp hf,
+      apply_eq_of_coe_eq_add_nat hf p (coe_heckeDiagMatrix_smul_vadd hp τ)]
+
+theorem periodic_comp_ofComplex_of_vadd {g : ℍ → ℂ} (hg : ∀ τ : ℍ, g ((1 : ℝ) +ᵥ τ) = g τ) :
+    Periodic (g ∘ ofComplex) 1 := by
+  intro w
+  by_cases hw : 0 < im w
+  · have hw' : 0 < im (w + 1) := by simp [hw]
+    simp only [comp_apply, ofComplex_apply_of_im_pos hw', ofComplex_apply_of_im_pos hw]
+    convert hg ⟨w, hw⟩ using 2
+    apply UpperHalfPlane.ext
+    simp [add_comm]
+  · have hw1 : im (w + 1) ≤ 0 := by simpa using hw
+    have hw0 : im w ≤ 0 := not_lt.mp hw
+    simp only [comp_apply, ofComplex_apply_eq_of_im_nonpos hw1 hw0]
+
+theorem periodic_heckeU_comp_ofComplex (hf : Periodic (f ∘ ofComplex) 1) :
+    Periodic (heckeU k p f ∘ ofComplex) 1 :=
+  periodic_comp_ofComplex_of_vadd (heckeU_vadd k p hf)
+
+theorem periodic_heckeT_comp_ofComplex (hf : Periodic (f ∘ ofComplex) 1) :
+    Periodic (heckeT k p f ∘ ofComplex) 1 :=
+  periodic_comp_ofComplex_of_vadd (heckeT_vadd k p hf)
+
+end Regularity
+
+section Uniqueness
+
+theorem qExpansion_coeff_unique' {g : ℍ → ℂ} (hcont : Continuous g) {c : ℕ → ℂ}
+    (hg : AnalyticAt ℂ (cuspFunction 1 g) 0)
+    (hs : ∀ τ : ℍ, HasSum (fun m ↦ c m • Periodic.qParam 1 τ ^ m) (g τ)) (m : ℕ) :
+    c m = (qExpansion 1 g).coeff m :=
+  UpperHalfPlane.qExpansion_coeff_unique (ContinuousMap.mk g hcont) one_pos hg hs m
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+theorem hasSum_qCoeff [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) (τ : ℍ) :
+    HasSum (fun m ↦ qCoeff f m • Periodic.qParam 1 τ ^ m) (f τ) := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  exact hasSum_qExpansion one_pos (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ)
+    (holo f) (bdd_at_infty f) τ
+
+theorem eq_of_forall_qCoeff_eq [ModularFormClass F Γ k] {f g : F} (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (h : ∀ n : ℕ, qCoeff f n = qCoeff g n) : f = g := by
+  refine DFunLike.ext f g fun τ => ?_
+  have hf := hasSum_qCoeff f hΓ τ
+  have hg := hasSum_qCoeff g hΓ τ
+  simp only [h] at hf
+  exact hf.unique hg
+
+end Uniqueness
+
+section QExpAction
+
+theorem qParam_one (z : ℂ) : Periodic.qParam 1 z = exp (2 * π * I * z) := by
+  simp [Periodic.qParam]
+
+variable {p : ℕ} (hp : p ≠ 0)
+
+include hp in
+theorem natCast_ne_zero' : (p : ℂ) ≠ 0 := by exact_mod_cast hp
+
+include hp in
+theorem qParam_heckeMatrix_smul (j : ℕ) (τ : ℍ) :
+    Periodic.qParam 1 ((heckeMatrix p j • τ : ℍ) : ℂ)
+      = exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j := by
+  rw [qParam_one, coe_heckeMatrix_smul hp, ← Complex.exp_nat_mul, ← Complex.exp_add]
+  congr 1
+  have := natCast_ne_zero' hp
+  field_simp
+
+include hp in
+theorem qParam_heckeDiagMatrix_smul (τ : ℍ) :
+    Periodic.qParam 1 ((heckeDiagMatrix p • τ : ℍ) : ℂ) = Periodic.qParam 1 τ ^ p := by
+  rw [qParam_one, qParam_one, coe_heckeDiagMatrix_smul hp, ← Complex.exp_nat_mul]
+  congr 1
+  ring
+
+include hp in
+theorem exp_div_pow (τ : ℍ) : exp (2 * π * I * τ / p) ^ p = Periodic.qParam 1 τ := by
+  rw [qParam_one, ← Complex.exp_nat_mul]
+  congr 1
+  have := natCast_ne_zero' hp
+  field_simp
+
+include hp in
+theorem sum_rootOfUnity_pow (m : ℕ) :
+    ∑ j ∈ Finset.range p, (exp (2 * π * I / p) ^ j) ^ m = if p ∣ m then (p : ℂ) else 0 := by
+  have hζ := Complex.isPrimitiveRoot_exp p hp
+  have hswap : ∀ j : ℕ, (exp (2 * π * I / p) ^ j) ^ m = (exp (2 * π * I / p) ^ m) ^ j := fun j => by
+    rw [← pow_mul, ← pow_mul, Nat.mul_comm j m]
+  simp only [hswap]
+  split_ifs with h
+  · rw [(hζ.pow_eq_one_iff_dvd m).mpr h]
+    simp
+  · have hne : exp (2 * π * I / p) ^ m ≠ 1 := fun h1 => h ((hζ.pow_eq_one_iff_dvd m).mp h1)
+    rw [geom_sum_eq hne, ← pow_mul, Nat.mul_comm m p, pow_mul, hζ.pow_eq_one, one_pow, sub_self,
+      zero_div]
+
+theorem not_dvd_of_not_mem_range {m : ℕ} (hm : m ∉ Set.range (fun l : ℕ ↦ l * p)) : ¬ p ∣ m := by
+  rintro ⟨l, rfl⟩
+  exact hm ⟨l, by simp [mul_comm]⟩
+
+variable {f : ℍ → ℂ} (hper : Periodic (f ∘ ofComplex) 1) (hhol : MDiff f)
+  (hbdd : IsBoundedAtImInfty f)
+
+include hp hper hhol hbdd in
+theorem hasSum_average (τ : ℍ) :
+    HasSum (fun l : ℕ ↦ qCoeff f (l * p) * Periodic.qParam 1 τ ^ l)
+      ((p : ℂ)⁻¹ * ∑ j ∈ Finset.range p, f (heckeMatrix p j • τ)) := by
+  have hF : ∀ τ' : ℍ, HasSum (fun m ↦ qCoeff f m • Periodic.qParam 1 τ' ^ m) (f τ') :=
+    hasSum_qExpansion one_pos hper hhol hbdd
+  have h1 : HasSum (fun m ↦ ∑ j ∈ Finset.range p,
+      qCoeff f m • (exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j) ^ m)
+      (∑ j ∈ Finset.range p, f (heckeMatrix p j • τ)) := by
+    refine hasSum_sum fun j _ => ?_
+    have := hF (heckeMatrix p j • τ)
+    rwa [qParam_heckeMatrix_smul hp j τ] at this
+  have h2 : (fun m ↦ ∑ j ∈ Finset.range p,
+      qCoeff f m • (exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j) ^ m)
+      = fun m ↦ if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0 := by
+    funext m
+    simp only [mul_pow, smul_eq_mul, ← Finset.mul_sum, sum_rootOfUnity_pow hp m]
+    split_ifs <;> ring
+  rw [h2] at h1
+  have hinj : Function.Injective (fun l : ℕ ↦ l * p) := mul_left_injective₀ hp
+  have h3 := (hinj.hasSum_iff (f := fun m ↦
+      if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0)
+    (fun m hm => by simp [not_dvd_of_not_mem_range hm])).mpr h1
+  have h4 : ((fun m ↦ if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0) ∘
+      fun l : ℕ ↦ l * p) = fun l ↦ (p : ℂ) * (qCoeff f (l * p) * Periodic.qParam 1 τ ^ l) := by
+    funext l
+    simp only [comp_apply, ite_eq_left (dvd_mul_left p l)]
+    rw [mul_comm l p, pow_mul, exp_div_pow hp τ]
+    ring
+  rw [h4] at h3
+  have h5 := h3.mul_left ((p : ℂ)⁻¹)
+  simp only [← mul_assoc, inv_mul_cancel₀ (natCast_ne_zero' hp), one_mul] at h5
+  exact h5
+
+include hp hper hhol hbdd in
+theorem hasSum_diag (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ if p ∣ n then (p : ℂ) ^ (k - 1) * qCoeff f (n / p) * Periodic.qParam 1 τ ^ n
+        else 0)
+      ((p : ℂ) ^ (k - 1) * f (heckeDiagMatrix p • τ)) := by
+  have hD := (hasSum_qExpansion one_pos hper hhol hbdd (heckeDiagMatrix p • τ)).mul_left
+    ((p : ℂ) ^ (k - 1))
+  rw [qParam_heckeDiagMatrix_smul hp τ] at hD
+  have hinj : Function.Injective (fun l : ℕ ↦ l * p) := mul_left_injective₀ hp
+  refine (hinj.hasSum_iff (fun m hm => by simp [not_dvd_of_not_mem_range hm])).mp ?_
+  convert hD using 1
+  funext l
+  simp only [comp_apply, ite_eq_left (dvd_mul_left p l), Nat.mul_div_cancel _ (Nat.pos_of_ne_zero
+    hp),
+    smul_eq_mul]
+  rw [← pow_mul, mul_comm l p, mul_assoc]
+  rfl
+
+include hp hper hhol hbdd in
+theorem hasSum_heckeU (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ coeffHeckeU p (qCoeff f) n • Periodic.qParam 1 τ ^ n) (heckeU k p f τ) := by
+  rw [heckeU_apply k hp]
+  simpa only [coeffHeckeU_apply, smul_eq_mul] using hasSum_average hp hper hhol hbdd τ
+
+include hp hper hhol hbdd in
+theorem hasSum_heckeT (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ coeffHeckeT k p (qCoeff f) n • Periodic.qParam 1 τ ^ n) (heckeT k p f τ) :=
+      by
+  rw [heckeT_apply k hp]
+  convert (hasSum_average hp hper hhol hbdd τ).add (hasSum_diag hp hper hhol hbdd k τ) using 1
+  funext n
+  rw [coeffHeckeT_apply, smul_eq_mul]
+  split_ifs <;> ring
+
+include hp hper hhol hbdd in
+theorem qCoeff_heckeU_bare (k : ℤ) (n : ℕ) :
+    qCoeff (heckeU k p f) n = coeffHeckeU p (qCoeff f) n :=
+  (qExpansion_coeff_unique' (mdifferentiable_heckeU k p hhol).continuous
+    (analyticAt_cuspFunction_zero one_pos (periodic_heckeU_comp_ofComplex k p hper)
+      (mdifferentiable_heckeU k p hhol) (isBoundedAtImInfty_heckeU k p hbdd))
+    (hasSum_heckeU hp hper hhol hbdd k) n).symm
+
+include hp hper hhol hbdd in
+theorem qCoeff_heckeT_bare (k : ℤ) (n : ℕ) :
+    qCoeff (heckeT k p f) n = coeffHeckeT k p (qCoeff f) n :=
+  (qExpansion_coeff_unique' (mdifferentiable_heckeT k p hhol).continuous
+    (analyticAt_cuspFunction_zero one_pos (periodic_heckeT_comp_ofComplex k p hper)
+      (mdifferentiable_heckeT k p hhol) (isBoundedAtImInfty_heckeT k p hbdd))
+    (hasSum_heckeT hp hper hhol hbdd k) n).symm
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+include hp in
+theorem qCoeff_heckeU_class [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (n : ℕ) : qCoeff (heckeU k p f) n = coeffHeckeU p (qCoeff f) n :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  qCoeff_heckeU_bare hp (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (holo f)
+    (bdd_at_infty f) k n
+
+include hp in
+theorem qCoeff_heckeT_class [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (n : ℕ) : qCoeff (heckeT k p f) n = coeffHeckeT k p (qCoeff f) n :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  qCoeff_heckeT_bare hp (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (holo f)
+    (bdd_at_infty f) k n
+
+end QExpAction
+
+end M4cP1W2
+
+end
+
+theorem solution {f : UpperHalfPlane → ℂ} (hf : UpperHalfPlane.IsBoundedAtImInfty f) (k : ℤ) (p : ℕ)
+    :
+    UpperHalfPlane.IsBoundedAtImInfty (ModularForm.heckeT k p f) :=
+  M4cP1W2.isBoundedAtImInfty_heckeT k p hf
+
+end S_ModularForm_isBoundedAtImInfty_heckeT
+end P2MW
+export P2MW.S_ModularForm_isBoundedAtImInfty_heckeT (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularForm.isBoundedAtImInfty_heckeT {f : UpperHalfPlane → ℂ}
+    (hf : UpperHalfPlane.IsBoundedAtImInfty f) (k : ℤ) (p : ℕ) :
+    UpperHalfPlane.IsBoundedAtImInfty (ModularForm.heckeT k p f) :=
+  solution hf k p
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_isBoundedAtImInfty_heckeU.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_isBoundedAtImInfty_heckeU.lean
new file mode 100644
index 0000000000..79ed22584a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_isBoundedAtImInfty_heckeU.lean
@@ -0,0 +1,397 @@
+/-
+Based on Prove2Me node ModularForm.isBoundedAtImInfty_heckeU
+(57c6f688-1f2d-5e58-9710-47fd4e400f56) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 454b4d52-3014-58e3-9a6c-e42b3b37790d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.Complex.UpperHalfPlane.FunctionsBoundedAtInfty
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+
+/-!
+# Boundedness at i∞ is preserved by Uₚ
+
+Theorem statement: `ModularForm.isBoundedAtImInfty_heckeU` (`57c6f688-1f2d-5e58-9710-47fd4e400f56`),
+by Claude, 2026-09-05.
+
+Proof: submission `454b4d52-3014-58e3-9a6c-e42b3b37790d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $f \colon \mathbb{H} \to \mathbb{C}$ be any function on the upper half-plane which is bounded at
+$i\infty$, i.e. $f$ is $O(1)$ with respect to the filter `UpperHalfPlane.atImInfty` of large
+imaginary part; no holomorphy, modularity or growth hypothesis beyond this is assumed. Let $k$ be an
+integer and $p$ a natural number. The assertion is that the function $\mathrm{heckeU}\,k\,p\,f =
+\sum_{j=0}^{p-1} f \mid_k M_{p,j}$ is again bounded at $i\infty$, where $\mid_k$ is the weight-$k$
+slash action of $\mathrm{GL}_2(\mathbb{R})$ (with positive determinant) and $M_{p,j}$ is the matrix
+$\mathrm{heckeMatrix}\,p\,j$, equal to the upper triangular matrix $\begin{pmatrix} 1 & j \\ 0 &
+p\end{pmatrix}$ when $p \neq 0$ and to the identity when $p = 0$. Since the index set is
+`Finset.range p`, the case $p = 0$ gives the empty sum, namely the zero function, and the value of
+$\mathrm{heckeMatrix}\,0\,j$ is irrelevant there.
+
+This is the growth half of the statement that the Hecke operator $U_p$, written as a sum of $p$
+upper triangular slashes, acts on spaces of modular and cusp forms: boundedness at $i\infty$ of each
+slash $f \mid_k \begin{pmatrix} 1 & j \\ 0 & p\end{pmatrix}$ is inherited by the finite sum. It is
+used in the analysis of $U_p$-eigenforms and of the degeneracy maps between forms of level $N$ and
+level $Np$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_isBoundedAtImInfty_heckeU.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+noncomputable section
+
+open Complex Function Filter
+
+open UpperHalfPlane hiding I
+
+open scoped Real MatrixGroups ModularForm Manifold Topology
+
+namespace M4cP1W2
+
+open ModularForm ModularFormClass
+
+section Matrices
+
+variable (p j : ℕ)
+
+theorem heckeMatrix_one_zero :
+    ((heckeMatrix p j : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) 1 0 = 0 := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  · rw [val_heckeMatrix hp]; rfl
+
+theorem heckeDiagMatrix_one_zero :
+    ((heckeDiagMatrix p : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) 1 0 = 0 := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  · rw [val_heckeDiagMatrix hp]; rfl
+
+end Matrices
+
+section Regularity
+
+variable {f : ℍ → ℂ} (k : ℤ) (p : ℕ)
+
+theorem mdifferentiable_heckeU (hf : MDiff f) : MDiff (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => MDiff g) (fun _ _ ha hb => ha.add hb)
+    mdifferentiable_const (fun _ _ => hf.slash k _)
+
+theorem mdifferentiable_heckeT (hf : MDiff f) : MDiff (heckeT k p f) :=
+  (mdifferentiable_heckeU k p hf).add (hf.slash k _)
+
+theorem isBoundedAtImInfty_heckeU (hf : IsBoundedAtImInfty f) :
+    IsBoundedAtImInfty (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => IsBoundedAtImInfty g)
+    (fun _ _ ha hb => ha.add hb) UpperHalfPlane.zero_form_isBoundedAtImInfty
+    (fun j _ => hf.slash k (heckeMatrix_one_zero p j))
+
+theorem isBoundedAtImInfty_heckeT (hf : IsBoundedAtImInfty f) :
+    IsBoundedAtImInfty (heckeT k p f) :=
+  (isBoundedAtImInfty_heckeU k p hf).add (hf.slash k (heckeDiagMatrix_one_zero p))
+
+theorem isZeroAtImInfty_heckeU (hf : IsZeroAtImInfty f) :
+    IsZeroAtImInfty (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => IsZeroAtImInfty g)
+    (fun _ _ ha hb => ha.add hb) (zero_zeroAtFilter atImInfty)
+    (fun j _ => hf.slash k (heckeMatrix_one_zero p j))
+
+theorem isZeroAtImInfty_heckeT (hf : IsZeroAtImInfty f) :
+    IsZeroAtImInfty (heckeT k p f) :=
+  (isZeroAtImInfty_heckeU k p hf).add (hf.slash k (heckeDiagMatrix_one_zero p))
+
+theorem apply_eq_of_coe_eq_add_nat (hf : Periodic (f ∘ ofComplex) 1) {τ₁ τ₂ : ℍ} (m : ℕ)
+    (h : (τ₁ : ℂ) = τ₂ + m) : f τ₁ = f τ₂ := by
+  have h1 : (f ∘ ofComplex) ((τ₂ : ℂ) + m) = (f ∘ ofComplex) (τ₂ : ℂ) := by
+    have := hf.nat_mul m
+    rw [mul_one] at this
+    exact this (τ₂ : ℂ)
+  simp only [comp_apply] at h1
+  rw [← h, ofComplex_apply, ofComplex_apply] at h1
+  exact h1
+
+variable {p} in
+theorem heckeMatrix_smul_vadd (hp : p ≠ 0) (j : ℕ) (τ : ℍ) :
+    heckeMatrix p j • ((1 : ℝ) +ᵥ τ) = heckeMatrix p (j + 1) • τ := by
+  apply UpperHalfPlane.ext
+  rw [coe_heckeMatrix_smul hp, coe_heckeMatrix_smul hp, coe_vadd]
+  push_cast
+  ring
+
+variable {p} in
+theorem coe_heckeMatrix_smul_self (hp : p ≠ 0) (τ : ℍ) :
+    ((heckeMatrix p p • τ : ℍ) : ℂ) = (heckeMatrix p 0 • τ : ℍ) + (1 : ℕ) := by
+  have hp' : (p : ℂ) ≠ 0 := by exact_mod_cast hp
+  rw [coe_heckeMatrix_smul hp, coe_heckeMatrix_smul hp]
+  field_simp
+  push_cast
+  ring
+
+variable {p} in
+theorem coe_heckeDiagMatrix_smul_vadd (hp : p ≠ 0) (τ : ℍ) :
+    ((heckeDiagMatrix p • ((1 : ℝ) +ᵥ τ) : ℍ) : ℂ) = (heckeDiagMatrix p • τ : ℍ) + (p : ℕ) := by
+  rw [coe_heckeDiagMatrix_smul hp, coe_heckeDiagMatrix_smul hp, coe_vadd]
+  push_cast
+  ring
+
+variable {p} in
+theorem sum_heckeMatrix_smul_vadd (hp : p ≠ 0) (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    ∑ j ∈ Finset.range p, f (heckeMatrix p j • ((1 : ℝ) +ᵥ τ))
+      = ∑ j ∈ Finset.range p, f (heckeMatrix p j • τ) := by
+  simp only [heckeMatrix_smul_vadd hp]
+  have h0 := Finset.sum_range_succ' (fun j => f (heckeMatrix p j • τ)) p
+  have h1 := Finset.sum_range_succ (fun j => f (heckeMatrix p j • τ)) p
+  rw [apply_eq_of_coe_eq_add_nat hf 1 (coe_heckeMatrix_smul_self hp τ)] at h1
+  exact add_right_cancel (h0.symm.trans h1)
+
+theorem heckeU_vadd (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    heckeU k p f ((1 : ℝ) +ᵥ τ) = heckeU k p f τ := by
+  by_cases hp : p = 0
+  · simp only [hp, heckeU_zero_left, Pi.zero_apply]
+  · rw [heckeU_apply k hp, heckeU_apply k hp, sum_heckeMatrix_smul_vadd hp hf]
+
+theorem heckeT_vadd (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    heckeT k p f ((1 : ℝ) +ᵥ τ) = heckeT k p f τ := by
+  by_cases hp : p = 0
+  · simp only [hp, heckeT_zero_left]
+    exact apply_eq_of_coe_eq_add_nat hf 1 (by rw [coe_vadd]; push_cast; ring)
+  · rw [heckeT_apply k hp, heckeT_apply k hp, sum_heckeMatrix_smul_vadd hp hf,
+      apply_eq_of_coe_eq_add_nat hf p (coe_heckeDiagMatrix_smul_vadd hp τ)]
+
+theorem periodic_comp_ofComplex_of_vadd {g : ℍ → ℂ} (hg : ∀ τ : ℍ, g ((1 : ℝ) +ᵥ τ) = g τ) :
+    Periodic (g ∘ ofComplex) 1 := by
+  intro w
+  by_cases hw : 0 < im w
+  · have hw' : 0 < im (w + 1) := by simp [hw]
+    simp only [comp_apply, ofComplex_apply_of_im_pos hw', ofComplex_apply_of_im_pos hw]
+    convert hg ⟨w, hw⟩ using 2
+    apply UpperHalfPlane.ext
+    simp [add_comm]
+  · have hw1 : im (w + 1) ≤ 0 := by simpa using hw
+    have hw0 : im w ≤ 0 := not_lt.mp hw
+    simp only [comp_apply, ofComplex_apply_eq_of_im_nonpos hw1 hw0]
+
+theorem periodic_heckeU_comp_ofComplex (hf : Periodic (f ∘ ofComplex) 1) :
+    Periodic (heckeU k p f ∘ ofComplex) 1 :=
+  periodic_comp_ofComplex_of_vadd (heckeU_vadd k p hf)
+
+theorem periodic_heckeT_comp_ofComplex (hf : Periodic (f ∘ ofComplex) 1) :
+    Periodic (heckeT k p f ∘ ofComplex) 1 :=
+  periodic_comp_ofComplex_of_vadd (heckeT_vadd k p hf)
+
+end Regularity
+
+section Uniqueness
+
+theorem qExpansion_coeff_unique' {g : ℍ → ℂ} (hcont : Continuous g) {c : ℕ → ℂ}
+    (hg : AnalyticAt ℂ (cuspFunction 1 g) 0)
+    (hs : ∀ τ : ℍ, HasSum (fun m ↦ c m • Periodic.qParam 1 τ ^ m) (g τ)) (m : ℕ) :
+    c m = (qExpansion 1 g).coeff m :=
+  UpperHalfPlane.qExpansion_coeff_unique (ContinuousMap.mk g hcont) one_pos hg hs m
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+theorem hasSum_qCoeff [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) (τ : ℍ) :
+    HasSum (fun m ↦ qCoeff f m • Periodic.qParam 1 τ ^ m) (f τ) := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  exact hasSum_qExpansion one_pos (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ)
+    (holo f) (bdd_at_infty f) τ
+
+theorem eq_of_forall_qCoeff_eq [ModularFormClass F Γ k] {f g : F} (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (h : ∀ n : ℕ, qCoeff f n = qCoeff g n) : f = g := by
+  refine DFunLike.ext f g fun τ => ?_
+  have hf := hasSum_qCoeff f hΓ τ
+  have hg := hasSum_qCoeff g hΓ τ
+  simp only [h] at hf
+  exact hf.unique hg
+
+end Uniqueness
+
+section QExpAction
+
+theorem qParam_one (z : ℂ) : Periodic.qParam 1 z = exp (2 * π * I * z) := by
+  simp [Periodic.qParam]
+
+variable {p : ℕ} (hp : p ≠ 0)
+
+include hp in
+theorem natCast_ne_zero' : (p : ℂ) ≠ 0 := by exact_mod_cast hp
+
+include hp in
+theorem qParam_heckeMatrix_smul (j : ℕ) (τ : ℍ) :
+    Periodic.qParam 1 ((heckeMatrix p j • τ : ℍ) : ℂ)
+      = exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j := by
+  rw [qParam_one, coe_heckeMatrix_smul hp, ← Complex.exp_nat_mul, ← Complex.exp_add]
+  congr 1
+  have := natCast_ne_zero' hp
+  field_simp
+
+include hp in
+theorem qParam_heckeDiagMatrix_smul (τ : ℍ) :
+    Periodic.qParam 1 ((heckeDiagMatrix p • τ : ℍ) : ℂ) = Periodic.qParam 1 τ ^ p := by
+  rw [qParam_one, qParam_one, coe_heckeDiagMatrix_smul hp, ← Complex.exp_nat_mul]
+  congr 1
+  ring
+
+include hp in
+theorem exp_div_pow (τ : ℍ) : exp (2 * π * I * τ / p) ^ p = Periodic.qParam 1 τ := by
+  rw [qParam_one, ← Complex.exp_nat_mul]
+  congr 1
+  have := natCast_ne_zero' hp
+  field_simp
+
+include hp in
+theorem sum_rootOfUnity_pow (m : ℕ) :
+    ∑ j ∈ Finset.range p, (exp (2 * π * I / p) ^ j) ^ m = if p ∣ m then (p : ℂ) else 0 := by
+  have hζ := Complex.isPrimitiveRoot_exp p hp
+  have hswap : ∀ j : ℕ, (exp (2 * π * I / p) ^ j) ^ m = (exp (2 * π * I / p) ^ m) ^ j := fun j => by
+    rw [← pow_mul, ← pow_mul, Nat.mul_comm j m]
+  simp only [hswap]
+  split_ifs with h
+  · rw [(hζ.pow_eq_one_iff_dvd m).mpr h]
+    simp
+  · have hne : exp (2 * π * I / p) ^ m ≠ 1 := fun h1 => h ((hζ.pow_eq_one_iff_dvd m).mp h1)
+    rw [geom_sum_eq hne, ← pow_mul, Nat.mul_comm m p, pow_mul, hζ.pow_eq_one, one_pow, sub_self,
+      zero_div]
+
+theorem not_dvd_of_not_mem_range {m : ℕ} (hm : m ∉ Set.range (fun l : ℕ ↦ l * p)) : ¬ p ∣ m := by
+  rintro ⟨l, rfl⟩
+  exact hm ⟨l, by simp [mul_comm]⟩
+
+variable {f : ℍ → ℂ} (hper : Periodic (f ∘ ofComplex) 1) (hhol : MDiff f)
+  (hbdd : IsBoundedAtImInfty f)
+
+include hp hper hhol hbdd in
+theorem hasSum_average (τ : ℍ) :
+    HasSum (fun l : ℕ ↦ qCoeff f (l * p) * Periodic.qParam 1 τ ^ l)
+      ((p : ℂ)⁻¹ * ∑ j ∈ Finset.range p, f (heckeMatrix p j • τ)) := by
+  have hF : ∀ τ' : ℍ, HasSum (fun m ↦ qCoeff f m • Periodic.qParam 1 τ' ^ m) (f τ') :=
+    hasSum_qExpansion one_pos hper hhol hbdd
+  have h1 : HasSum (fun m ↦ ∑ j ∈ Finset.range p,
+      qCoeff f m • (exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j) ^ m)
+      (∑ j ∈ Finset.range p, f (heckeMatrix p j • τ)) := by
+    refine hasSum_sum fun j _ => ?_
+    have := hF (heckeMatrix p j • τ)
+    rwa [qParam_heckeMatrix_smul hp j τ] at this
+  have h2 : (fun m ↦ ∑ j ∈ Finset.range p,
+      qCoeff f m • (exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j) ^ m)
+      = fun m ↦ if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0 := by
+    funext m
+    simp only [mul_pow, smul_eq_mul, ← Finset.mul_sum, sum_rootOfUnity_pow hp m]
+    split_ifs <;> ring
+  rw [h2] at h1
+  have hinj : Function.Injective (fun l : ℕ ↦ l * p) := mul_left_injective₀ hp
+  have h3 := (hinj.hasSum_iff (f := fun m ↦
+      if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0)
+    (fun m hm => by simp [not_dvd_of_not_mem_range hm])).mpr h1
+  have h4 : ((fun m ↦ if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0) ∘
+      fun l : ℕ ↦ l * p) = fun l ↦ (p : ℂ) * (qCoeff f (l * p) * Periodic.qParam 1 τ ^ l) := by
+    funext l
+    simp only [comp_apply, ite_eq_left (dvd_mul_left p l)]
+    rw [mul_comm l p, pow_mul, exp_div_pow hp τ]
+    ring
+  rw [h4] at h3
+  have h5 := h3.mul_left ((p : ℂ)⁻¹)
+  simp only [← mul_assoc, inv_mul_cancel₀ (natCast_ne_zero' hp), one_mul] at h5
+  exact h5
+
+include hp hper hhol hbdd in
+theorem hasSum_diag (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ if p ∣ n then (p : ℂ) ^ (k - 1) * qCoeff f (n / p) * Periodic.qParam 1 τ ^ n
+        else 0)
+      ((p : ℂ) ^ (k - 1) * f (heckeDiagMatrix p • τ)) := by
+  have hD := (hasSum_qExpansion one_pos hper hhol hbdd (heckeDiagMatrix p • τ)).mul_left
+    ((p : ℂ) ^ (k - 1))
+  rw [qParam_heckeDiagMatrix_smul hp τ] at hD
+  have hinj : Function.Injective (fun l : ℕ ↦ l * p) := mul_left_injective₀ hp
+  refine (hinj.hasSum_iff (fun m hm => by simp [not_dvd_of_not_mem_range hm])).mp ?_
+  convert hD using 1
+  funext l
+  simp only [comp_apply, ite_eq_left (dvd_mul_left p l),
+    Nat.mul_div_cancel _ (Nat.pos_of_ne_zero hp), smul_eq_mul]
+  rw [← pow_mul, mul_comm l p, mul_assoc]
+  rfl
+
+include hp hper hhol hbdd in
+theorem hasSum_heckeU (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ coeffHeckeU p (qCoeff f) n • Periodic.qParam 1 τ ^ n) (heckeU k p f τ) := by
+  rw [heckeU_apply k hp]
+  simpa only [coeffHeckeU_apply, smul_eq_mul] using hasSum_average hp hper hhol hbdd τ
+
+include hp hper hhol hbdd in
+theorem hasSum_heckeT (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ coeffHeckeT k p (qCoeff f) n • Periodic.qParam 1 τ ^ n)
+    (heckeT k p f τ) := by
+  rw [heckeT_apply k hp]
+  convert (hasSum_average hp hper hhol hbdd τ).add (hasSum_diag hp hper hhol hbdd k τ) using 1
+  funext n
+  rw [coeffHeckeT_apply, smul_eq_mul]
+  split_ifs <;> ring
+
+include hp hper hhol hbdd in
+theorem qCoeff_heckeU_bare (k : ℤ) (n : ℕ) :
+    qCoeff (heckeU k p f) n = coeffHeckeU p (qCoeff f) n :=
+  (qExpansion_coeff_unique' (mdifferentiable_heckeU k p hhol).continuous
+    (analyticAt_cuspFunction_zero one_pos (periodic_heckeU_comp_ofComplex k p hper)
+      (mdifferentiable_heckeU k p hhol) (isBoundedAtImInfty_heckeU k p hbdd))
+    (hasSum_heckeU hp hper hhol hbdd k) n).symm
+
+include hp hper hhol hbdd in
+theorem qCoeff_heckeT_bare (k : ℤ) (n : ℕ) :
+    qCoeff (heckeT k p f) n = coeffHeckeT k p (qCoeff f) n :=
+  (qExpansion_coeff_unique' (mdifferentiable_heckeT k p hhol).continuous
+    (analyticAt_cuspFunction_zero one_pos (periodic_heckeT_comp_ofComplex k p hper)
+      (mdifferentiable_heckeT k p hhol) (isBoundedAtImInfty_heckeT k p hbdd))
+    (hasSum_heckeT hp hper hhol hbdd k) n).symm
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+include hp in
+theorem qCoeff_heckeU_class [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (n : ℕ) : qCoeff (heckeU k p f) n = coeffHeckeU p (qCoeff f) n :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  qCoeff_heckeU_bare hp (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (holo f)
+    (bdd_at_infty f) k n
+
+include hp in
+theorem qCoeff_heckeT_class [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (n : ℕ) : qCoeff (heckeT k p f) n = coeffHeckeT k p (qCoeff f) n :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  qCoeff_heckeT_bare hp (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (holo f)
+    (bdd_at_infty f) k n
+
+end QExpAction
+
+end M4cP1W2
+
+end
+
+theorem solution
+    {f : UpperHalfPlane → ℂ} (hf : UpperHalfPlane.IsBoundedAtImInfty f) (k : ℤ) (p : ℕ) :
+    UpperHalfPlane.IsBoundedAtImInfty (ModularForm.heckeU k p f) :=
+  M4cP1W2.isBoundedAtImInfty_heckeU k p hf
+
+end privateSection
+
+public section publicSection
+
+theorem ModularForm.isBoundedAtImInfty_heckeU
+    {f : UpperHalfPlane → ℂ} (hf : UpperHalfPlane.IsBoundedAtImInfty f) (k : ℤ) (p : ℕ) :
+    UpperHalfPlane.IsBoundedAtImInfty (ModularForm.heckeU k p f) :=
+  solution hf k p
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_isIntegral_adjoin_qExpansion_div_discriminant_pow_of_isArithmetic.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_isIntegral_adjoin_qExpansion_div_discriminant_pow_of_isArithmetic.lean
new file mode 100644
index 0000000000..ee7322f7a0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_isIntegral_adjoin_qExpansion_div_discriminant_pow_of_isArithmetic.lean
@@ -0,0 +1,570 @@
+/-
+Based on Prove2Me node ModularForm.isIntegral_adjoin_qExpansion_div_discriminant_pow_of_isArithmetic
+(d634d576-a9d7-5ca7-9008-24980764c73f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4e485c8d-c717-58a8-adf5-7304e067d430
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.NormTrace
+public import Mathlib.NumberTheory.ModularForms.LevelOne.DimensionFormula
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import Mathlib.RingTheory.LaurentSeries
+public import Mathlib.RingTheory.IntegralClosure.IsIntegral.Defs
+
+import Mathlib.LinearAlgebra.Lagrange
+import Mathlib.RingTheory.Adjoin.Polynomial.Basic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_qExpansion_eq_aeval_mul_pow_levelOne
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality of ̃ g/Δ̃^{ m} over ℂ[jmath̃]
+
+Theorem statement: `ModularForm.isIntegral_adjoin_qExpansion_div_discriminant_pow_of_isArithmetic`
+(`d634d576-a9d7-5ca7-9008-24980764c73f`), by Claude, 2026-09-05.
+
+Proof: submission `4e485c8d-c717-58a8-adf5-7304e067d430`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\mathcal G$ be a subgroup of $\mathrm{GL}_2(\mathbb R)$ which is arithmetic and all of whose
+elements have determinant one, and assume that the real number $1$ belongs to `𝒢.strictPeriods`, so
+that $q$-expansions of width $1$ are available for forms on $\mathcal G$. Let $m$ be a natural
+number, let $k$ be an integer with $k = 12m$, and let $g$ be a modular form of weight $k$ for
+$\mathcal G$. Write $\tilde h$ for the image in the field of Laurent series $\mathbb C((q))$ of the
+width-one $q$-expansion `qExpansion 1` of a form $h$, the expansions of the level-one forms $E_4$
+and $\Delta$ being taken as such, with no restriction to $\mathcal G$ intervening. The assertion is
+that the Laurent series $\tilde g/\tilde\Delta^{\,m}$ is integral over the $\mathbb C$-subalgebra of
+$\mathbb C((q))$ generated by the single element $\tilde E_4^{\,3}/\tilde\Delta$, that is, over
+$\mathbb C[\tilde\jmath]$ up to the normalisation of $j$. No bound on the degree of a monic
+relation, and no relation to the index of $\mathcal G$, is asserted; the case $m = 0$ says that
+$\tilde g$ itself is integral over this subalgebra.
+
+This is the monic (integrality) form of the classical statement that a modular function whose only
+poles are at the cusps is integral over $\mathbb C[j]$, here phrased entirely on the level of
+$q$-expansions in $\mathbb C((q))$ and for an arbitrary arithmetic group of determinant one
+admitting $1$ as a strict period. It is the source of integrality over $\mathbb C[\tilde\jmath]$ in
+the construction of models of modular curves, and is invoked by the results on integrality of
+coefficient embeddings of $\tilde\jmath$; its proof cites the level-one case
+[`ModularForm.exists_qExpansion_eq_aeval_mul_pow_levelOne`]
+(thm.html#ModularForm.exists_qExpansion_eq_aeval_mul_pow_levelOne),
+which writes $\tilde F = P(\tilde E_4^{\,3}/\tilde\Delta)\,\tilde\Delta^{\,N}$ with $\deg P \le N$
+for a level-one form $F$ of weight $12N$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_isIntegral_adjoin_qExpansion_div_discriminant_pow_of_isArithmetic.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+local notation "Δ" => ModularForm.discriminant
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+open UpperHalfPlane
+open scoped MatrixGroups
+
+namespace PenA
+namespace ALG
+
+open Polynomial SlashInvariantForm
+
+variable {ι : Type*}
+
+lemma natDegree_prod_linear_le (s : Finset ι) (a b : ι → ℂ) :
+    (∏ q ∈ s, (C (a q) - C (b q) * X)).natDegree ≤ s.card := by
+  induction s using Finset.cons_induction with
+  | empty => simp
+  | cons j s hj ih =>
+    rw [Finset.prod_cons, Finset.card_cons]
+    refine le_trans (Polynomial.natDegree_mul_le) ?_
+    have hfac : (C (a j) - C (b j) * X).natDegree ≤ 1 := by
+      refine le_trans (Polynomial.natDegree_sub_le _ _) (max_le ?_ ?_)
+      · simp [Polynomial.natDegree_C]
+      · exact le_trans (Polynomial.natDegree_C_mul_le _ _) Polynomial.natDegree_X_le
+    omega
+
+lemma coeff_card_prod_linear (s : Finset ι) (a b : ι → ℂ) :
+    (∏ q ∈ s, (C (a q) - C (b q) * X)).coeff s.card = ∏ q ∈ s, (-(b q)) := by
+  induction s using Finset.cons_induction with
+  | empty => simp
+  | cons j s hj ih =>
+    rw [Finset.prod_cons, Finset.prod_cons, Finset.card_cons]
+    have hre : (C (a j) - C (b j) * X) * (∏ q ∈ s, (C (a q) - C (b q) * X))
+        = C (a j) * (∏ q ∈ s, (C (a q) - C (b q) * X))
+          - C (b j) * (X * (∏ q ∈ s, (C (a q) - C (b q) * X))) := by ring
+    rw [hre, Polynomial.coeff_sub, Polynomial.coeff_C_mul, Polynomial.coeff_C_mul,
+      Polynomial.coeff_X_mul, Polynomial.coeff_eq_zero_of_natDegree_lt
+        (lt_of_le_of_lt (natDegree_prod_linear_le s a b) (Nat.lt_succ_self _)), ih]
+    ring
+
+lemma aux_scalar (co x y : ℂ) (hy : y ≠ 0) {r c : ℕ} (hr : r ≤ c) :
+    co * x ^ r * y ^ (c - r) = co * (x / y) ^ r * y ^ c := by
+  rw [div_pow, pow_sub₀ _ hy hr]
+  field_simp
+
+lemma key_vanish (s : Finset ι) (a b : ι → ℂ) (j0 : ι) (hj0 : j0 ∈ s) :
+    ∑ r ∈ Finset.range (s.card + 1),
+      (∏ q ∈ s, (C (a q) - C (b q) * X)).coeff r * (a j0) ^ r * (b j0) ^ (s.card - r) = 0 := by
+  set p : Polynomial ℂ := ∏ q ∈ s, (C (a q) - C (b q) * X) with hp
+  by_cases hy : b j0 = 0
+  · refine Finset.sum_eq_zero fun r hr => ?_
+    have hr' : r ≤ s.card := Nat.lt_succ_iff.mp (Finset.mem_range.mp hr)
+    rcases lt_or_eq_of_le hr' with hlt | rfl
+    · rw [hy, zero_pow (by omega), mul_zero]
+    · rw [hp, coeff_card_prod_linear, Finset.prod_eq_zero hj0 (by rw [hy, neg_zero]), zero_mul,
+        zero_mul]
+  · have hdeg : p.natDegree < s.card + 1 :=
+      lt_of_le_of_lt (hp ▸ natDegree_prod_linear_le s a b) (Nat.lt_succ_self _)
+    calc ∑ r ∈ Finset.range (s.card + 1), p.coeff r * (a j0) ^ r * (b j0) ^ (s.card - r)
+        = ∑ r ∈ Finset.range (s.card + 1), p.coeff r * (a j0 / b j0) ^ r * (b j0) ^ s.card := by
+          refine Finset.sum_congr rfl fun r hr => ?_
+          exact aux_scalar _ _ _ hy (Nat.lt_succ_iff.mp (Finset.mem_range.mp hr))
+      _ = (∑ r ∈ Finset.range (s.card + 1), p.coeff r * (a j0 / b j0) ^ r) * (b j0) ^ s.card := by
+          rw [Finset.sum_mul]
+      _ = p.eval (a j0 / b j0) * (b j0) ^ s.card := by
+          rw [Polynomial.eval_eq_sum_range' hdeg]
+      _ = 0 := by
+          rw [hp, Polynomial.eval_prod, Finset.prod_eq_zero hj0 (by
+            rw [Polynomial.eval_sub, Polynomial.eval_C, Polynomial.eval_mul, Polynomial.eval_C,
+              Polynomial.eval_X, mul_div_cancel₀ _ hy, sub_self]), zero_mul]
+
+noncomputable def restrict {Γ Γ' : Subgroup (GL (Fin 2) ℝ)} (hle : Γ' ≤ Γ) {w : ℤ}
+    (f : ModularForm Γ w) : ModularForm Γ' w where
+  toFun := f
+  slash_action_eq' A hA := f.slash_action_eq' A (hle hA)
+  holo' := f.holo'
+  bdd_at_cusps' hc := f.bdd_at_cusps' (hc.mono hle)
+
+@[scoped simp] lemma coe_restrict {Γ Γ' : Subgroup (GL (Fin 2) ℝ)} (hle : Γ' ≤ Γ) {w : ℤ}
+    (f : ModularForm Γ w) : ⇑(restrict hle f) = ⇑f := rfl
+
+lemma sigma_eq_id {A : GL (Fin 2) ℝ} (hA : A ∈ 𝒮ℒ) (c : ℂ) : σ A c = c := by
+  have hdet : (0 : ℝ) < (↑A : Matrix (Fin 2) (Fin 2) ℝ).det := by
+    rw [← Matrix.GeneralLinearGroup.val_det_apply, Subgroup.HasDetOne.det_eq hA]
+    simp
+  simp [UpperHalfPlane.σ, hdet]
+
+variable {𝒢 : Subgroup (GL (Fin 2) ℝ)}
+
+lemma quotientFunc_sub_smul [𝒢.HasDetOne] (c : ℂ) {w : ℤ} (g₁ h₁ : ModularForm 𝒢 w)
+    (q : 𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) (τ : ℍ) :
+    quotientFunc (g₁ - c • h₁) q τ = quotientFunc g₁ q τ - quotientFunc h₁ q τ * c := by
+  induction q using Quotient.inductionOn with
+  | h r =>
+    have hA : (r.val)⁻¹ ∈ 𝒮ℒ := inv_mem r.2
+    rw [quotientFunc_mk, quotientFunc_mk, quotientFunc_mk, FunLike.coe_sub,
+      FunLike.coe_smul, sub_eq_add_neg, SlashAction.add_slash,
+      SlashAction.neg_slash, ModularForm.smul_slash, sigma_eq_id hA]
+    simp only [Pi.add_apply, Pi.neg_apply, Pi.smul_apply, smul_eq_mul]
+    ring
+
+lemma norm_apply_eq {w : ℤ} [𝒢.IsArithmetic] (f : ModularForm 𝒢 w) (τ : ℍ)
+    [Fintype (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ)] :
+    ModularForm.norm 𝒮ℒ f τ = ∏ q : 𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ, quotientFunc f q τ := by
+  have h1 : ModularForm.norm 𝒮ℒ f τ = (∏ q : 𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ, quotientFunc f q) τ := by
+    rw [show ⇑(ModularForm.norm 𝒮ℒ f) = _ from ModularForm.coe_norm 𝒮ℒ f]
+    congr!
+  rw [h1, Finset.prod_apply]
+
+lemma quotientFunc_one {w : ℤ} (f : ModularForm 𝒢 w) :
+    quotientFunc f (⟦1⟧ : 𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) = ⇑f := by
+  rw [quotientFunc_mk]
+  simp
+
+lemma one_mem_strictPeriods_inf (h1 : (1 : ℝ) ∈ 𝒢.strictPeriods) :
+    (1 : ℝ) ∈ (𝒢 ⊓ 𝒮ℒ).strictPeriods := by
+  rw [Subgroup.mem_strictPeriods_iff] at h1 ⊢
+  exact Subgroup.mem_inf.mpr ⟨h1, Subgroup.mem_strictPeriods_iff.mp one_mem_strictPeriods_SL⟩
+
+lemma coeff_eq_sum_lagrange {n : ℕ} (p : Polynomial ℂ) (hdeg : p.natDegree < n + 1) (r : ℕ)
+    (v : Fin (n + 1) → ℂ) (hv : Set.InjOn v ↑(Finset.univ : Finset (Fin (n + 1)))) :
+    p.coeff r = ∑ i : Fin (n + 1), p.eval (v i) * (Lagrange.basis Finset.univ v i).coeff r := by
+  have hdeg' : p.degree < (Finset.univ : Finset (Fin (n + 1))).card := by
+    rw [Finset.card_univ, Fintype.card_fin]
+    exact lt_of_le_of_lt p.degree_le_natDegree (by exact_mod_cast hdeg)
+  conv_lhs => rw [Lagrange.eq_interpolate hv hdeg', Lagrange.interpolate_apply]
+  rw [Polynomial.finsetSum_coeff]
+  exact Finset.sum_congr rfl fun i _ => by rw [Polynomial.coeff_C_mul]
+
+noncomputable def nodes (m : ℕ) : Fin m → ℂ := fun j => ((j : ℕ) : ℂ)
+
+lemma nodes_injOn (m : ℕ) : Set.InjOn (nodes m) ↑(Finset.univ : Finset (Fin m)) :=
+  fun _ _ _ _ hij => Fin.ext (Nat.cast_injective hij)
+
+noncomputable def Pp [Fintype (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ)] {w : ℤ} (g₁ h₁ : ModularForm 𝒢 w)
+    (τ : ℍ) : Polynomial ℂ :=
+  ∏ q : 𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ,
+    (C (quotientFunc g₁ q τ) - C (quotientFunc h₁ q τ) * X)
+
+lemma natDegree_Pp_le [Fintype (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ)] {w : ℤ} (g₁ h₁ : ModularForm 𝒢 w)
+    (τ : ℍ) : (Pp g₁ h₁ τ).natDegree ≤ Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) := by
+  refine le_trans (natDegree_prod_linear_le _ _ _) ?_
+  rw [Finset.card_univ, Nat.card_eq_fintype_card]
+
+lemma norm_eval_Pp [Fintype (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ)] {w : ℤ} [𝒢.IsArithmetic] [𝒢.HasDetOne]
+    (g₁ h₁ : ModularForm 𝒢 w) (c : ℂ) (τ : ℍ) :
+    ModularForm.norm 𝒮ℒ (g₁ - c • h₁) τ = (Pp g₁ h₁ τ).eval c := by
+  rw [norm_apply_eq]
+  unfold Pp
+  rw [Polynomial.eval_prod]
+  exact Finset.prod_congr rfl fun q _ => by
+    rw [quotientFunc_sub_smul, Polynomial.eval_sub, Polynomial.eval_C, Polynomial.eval_mul,
+      Polynomial.eval_C, Polynomial.eval_X]
+
+noncomputable def Aform {w : ℤ} [𝒢.IsArithmetic] [𝒢.HasDetOne] (g₁ h₁ : ModularForm 𝒢 w)
+    (r : ℕ) : ModularForm 𝒮ℒ (w * (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) : ℤ)) :=
+  ∑ i : Fin (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) + 1),
+    ((Lagrange.basis Finset.univ (nodes (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) + 1)) i).coeff r) •
+      ModularForm.norm 𝒮ℒ (g₁ - nodes (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) + 1) i • h₁)
+
+lemma Aform_apply [Fintype (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ)] {w : ℤ} [𝒢.IsArithmetic] [𝒢.HasDetOne]
+    (g₁ h₁ : ModularForm 𝒢 w) (r : ℕ) (τ : ℍ) :
+    Aform g₁ h₁ r τ = (Pp g₁ h₁ τ).coeff r := by
+  have hdeg : (Pp g₁ h₁ τ).natDegree < Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) + 1 :=
+    Nat.lt_succ_of_le (natDegree_Pp_le g₁ h₁ τ)
+  have hcoe : ⇑(Aform g₁ h₁ r) = ∑ i : Fin (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) + 1),
+      ((Lagrange.basis Finset.univ (nodes (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) + 1)) i).coeff r) •
+        ⇑(ModularForm.norm 𝒮ℒ (g₁ - nodes (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) + 1) i • h₁)) :=
+    map_sum (FunLike.coeAddMonoidHom (ModularForm _ _) UpperHalfPlane ℂ) _ _
+  rw [show Aform g₁ h₁ r τ = ⇑(Aform g₁ h₁ r) τ from rfl, hcoe, Finset.sum_apply,
+    coeff_eq_sum_lagrange (Pp g₁ h₁ τ) hdeg r _ (nodes_injOn _)]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [Pi.smul_apply, smul_eq_mul, norm_eval_Pp, mul_comm]
+
+noncomputable def Tform {K : ℕ} [𝒢.IsArithmetic] [𝒢.HasDetOne]
+    (g₁ h₁ : ModularForm 𝒢 (12 * (K : ℤ)))
+    (r : Fin (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) + 1)) :
+    ModularForm (𝒢 ⊓ 𝒮ℒ) (24 * (K : ℤ) * (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) : ℤ)) :=
+  ModularForm.mcast (by rw [Nat.cast_sub (Nat.lt_succ_iff.mp r.2)]; ring)
+    (((restrict inf_le_right (Aform g₁ h₁ (r : ℕ))).mul
+        ((restrict inf_le_left g₁).pow (r : ℕ))).mul
+      ((restrict inf_le_left h₁).pow (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) - (r : ℕ))))
+
+lemma Tform_apply [Fintype (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ)] {K : ℕ} [𝒢.IsArithmetic] [𝒢.HasDetOne]
+    (g₁ h₁ : ModularForm 𝒢 (12 * (K : ℤ)))
+    (r : Fin (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) + 1)) (τ : ℍ) :
+    Tform g₁ h₁ r τ = (Pp g₁ h₁ τ).coeff (r : ℕ) * (g₁ τ) ^ (r : ℕ)
+      * (h₁ τ) ^ (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) - (r : ℕ)) := by
+  show (⇑(Tform g₁ h₁ r)) τ = _
+  unfold Tform
+  simp only [ModularForm.coe_mcast, ModularForm.coe_mul, ModularForm.coe_pow, coe_restrict,
+    Pi.mul_apply, Pi.pow_apply]
+  rw [Aform_apply]
+
+lemma qExpansion_Tform {K : ℕ} [𝒢.IsArithmetic] [𝒢.HasDetOne]
+    (h1' : (1 : ℝ) ∈ (𝒢 ⊓ 𝒮ℒ).strictPeriods) (g₁ h₁ : ModularForm 𝒢 (12 * (K : ℤ)))
+    (r : Fin (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) + 1)) :
+    qExpansion 1 (Tform g₁ h₁ r)
+      = qExpansion 1 (Aform g₁ h₁ (r : ℕ))
+        * (qExpansion 1 (g₁)) ^ (r : ℕ)
+        * (qExpansion 1 (h₁)) ^ (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) - (r : ℕ)) := by
+  unfold Tform
+  rw [ModularForm.qExpansion_mcast, ModularForm.qExpansion_mul one_pos h1',
+    ModularForm.qExpansion_mul one_pos h1', ModularForm.qExpansion_pow one_pos h1',
+    ModularForm.qExpansion_pow one_pos h1', coe_restrict, coe_restrict, coe_restrict]
+
+noncomputable def Sform {K : ℕ} [𝒢.IsArithmetic] [𝒢.HasDetOne]
+    (g₁ h₁ : ModularForm 𝒢 (12 * (K : ℤ))) :
+    ModularForm (𝒢 ⊓ 𝒮ℒ) (24 * (K : ℤ) * (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) : ℤ)) :=
+  ∑ r : Fin (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) + 1), Tform g₁ h₁ r
+
+lemma Sform_eq_zero {K : ℕ} [𝒢.IsArithmetic] [𝒢.HasDetOne]
+    (g₁ h₁ : ModularForm 𝒢 (12 * (K : ℤ))) : Sform g₁ h₁ = 0 := by
+  let : Fintype (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) := Fintype.ofFinite _
+  have hcard : (Finset.univ : Finset (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ)).card
+      = Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) := by
+    rw [Finset.card_univ, Nat.card_eq_fintype_card]
+  ext τ
+  have hcoe : ⇑(Sform g₁ h₁) = ∑ r : Fin (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) + 1),
+      ⇑(Tform g₁ h₁ r) := map_sum (FunLike.coeAddMonoidHom (ModularForm _ _) UpperHalfPlane ℂ) _ _
+  rw [show Sform g₁ h₁ τ = ⇑(Sform g₁ h₁) τ from rfl, hcoe, Finset.sum_apply]
+  have hkv := key_vanish (Finset.univ : Finset (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ))
+    (fun q => quotientFunc g₁ q τ) (fun q => quotientFunc h₁ q τ) ⟦1⟧ (Finset.mem_univ _)
+  simp only [quotientFunc_one] at hkv
+  rw [hcard] at hkv
+  calc ∑ r : Fin (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) + 1), Tform g₁ h₁ r τ
+      = ∑ r : Fin (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) + 1),
+          (Pp g₁ h₁ τ).coeff (r : ℕ) * (g₁ τ) ^ (r : ℕ)
+            * (h₁ τ) ^ (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) - (r : ℕ)) :=
+        Finset.sum_congr rfl fun r _ => Tform_apply g₁ h₁ r τ
+    _ = ∑ r ∈ Finset.range (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) + 1),
+          (Pp g₁ h₁ τ).coeff r * (g₁ τ) ^ r
+            * (h₁ τ) ^ (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) - r) :=
+        Fin.sum_univ_eq_sum_range
+          (fun m => (Pp g₁ h₁ τ).coeff m * (g₁ τ) ^ m
+            * (h₁ τ) ^ (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) - m))
+          (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) + 1)
+    _ = 0 := by
+        unfold Pp
+        exact hkv
+    _ = (0 : ModularForm (𝒢 ⊓ 𝒮ℒ) (24 * (K : ℤ) * (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) : ℤ))) τ :=
+        by simp
+
+lemma qExpansion_Sform {K : ℕ} [𝒢.IsArithmetic] [𝒢.HasDetOne]
+    (h1' : (1 : ℝ) ∈ (𝒢 ⊓ 𝒮ℒ).strictPeriods) (g₁ h₁ : ModularForm 𝒢 (12 * (K : ℤ))) :
+    qExpansion 1 (Sform g₁ h₁)
+      = ∑ r : Fin (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) + 1),
+          qExpansion 1 (Aform g₁ h₁ (r : ℕ))
+            * (qExpansion 1 (g₁)) ^ (r : ℕ)
+            * (qExpansion 1 (h₁)) ^ (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) - (r : ℕ)) := by
+  rw [show qExpansion 1 (Sform g₁ h₁)
+      = ModularForm.qExpansionAddHom one_pos h1'
+          (24 * (K : ℤ) * (Nat.card (𝒮ℒ ⧸ 𝒢.subgroupOf 𝒮ℒ) : ℤ)) (Sform g₁ h₁) from rfl]
+  unfold Sform
+  rw [map_sum]
+  exact Finset.sum_congr rfl fun r _ => qExpansion_Tform h1' g₁ h₁ r
+
+end PenA.ALG
+
+open PenA.ALG SlashInvariantForm in
+theorem solution {𝒢 : Subgroup (GL (Fin 2) ℝ)} [𝒢.IsArithmetic] [𝒢.HasDetOne]
+    (h1 : 1 ∈ 𝒢.strictPeriods) (m : ℕ) {k : ℤ} (hk : k = 12 * m) (g : ModularForm 𝒢 k) :
+    IsIntegral (Algebra.adjoin ℂ {(qExpansion 1 ModularForm.E₄) ^ 3 /
+        (qExpansion 1 Δ : LaurentSeries ℂ)})
+    (qExpansion 1 g / (qExpansion 1 Δ : LaurentSeries ℂ) ^ m) := by
+  classical
+  subst hk
+  set Δmf : ModularForm 𝒮ℒ 12 := (CuspForm.discriminant : ModularForm 𝒮ℒ 12) with hΔmfdef
+  have hΔcoe : ⇑Δmf = Δ := rfl
+  set Dsl : ModularForm 𝒮ℒ (12 * (m : ℤ)) :=
+    ModularForm.mcast (by ring) (Δmf.pow m) with hDSLdef
+  have hDSLq : qExpansion 1 Dsl = (qExpansion 1 Δ) ^ m := by
+    rw [hDSLdef, ModularForm.qExpansion_mcast,
+      ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL, hΔcoe]
+  set g' : ModularForm (𝒢 ⊓ 𝒮ℒ) (12 * (m : ℤ)) := restrict inf_le_left g with hg'def
+  set D' : ModularForm (𝒢 ⊓ 𝒮ℒ) (12 * (m : ℤ)) := restrict inf_le_right Dsl with hD'def
+  have hg'q : qExpansion 1 g' = qExpansion 1 g := by
+    rw [hg'def, PenA.ALG.coe_restrict]
+  have hD'q : qExpansion 1 D'
+      = (qExpansion 1 Δ) ^ m := by
+    rw [hD'def, PenA.ALG.coe_restrict]
+    exact hDSLq
+  have hΔ0 : qExpansion 1 Δ ≠ 0 := fun h0 => by
+    simpa [h0] using ModularForm.discriminant_qExpansion_coeff_one
+  have hΔL : (qExpansion 1 Δ :
+      LaurentSeries ℂ) ≠ 0 :=
+    by
+    rw [Ne, ← PowerSeries.coe_zero]
+    exact fun h0 => hΔ0 (HahnSeries.ofPowerSeries_injective h0)
+  have hΔmL : (qExpansion 1 Δ :
+      LaurentSeries ℂ) ^ m ≠ 0 :=
+    pow_ne_zero m hΔL
+  let : Fintype (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ) := Fintype.ofFinite _
+  have h1' : (1 : ℝ) ∈ (𝒢 ⊓ 𝒮ℒ).strictPeriods := one_mem_strictPeriods_inf h1
+  have h1'' : (1 : ℝ) ∈ ((𝒢 ⊓ 𝒮ℒ) ⊓ 𝒮ℒ).strictPeriods := one_mem_strictPeriods_inf h1'
+  have hq0 : ∑ r : Fin (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ) + 1),
+      qExpansion 1 (Aform g' D' (r : ℕ)) * (qExpansion 1 g') ^ (r : ℕ)
+        * (qExpansion 1 D') ^ (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ) - (r : ℕ)) = 0 := by
+    rw [← qExpansion_Sform h1'' g' D', Sform_eq_zero g' D', FunLike.coe_zero, qExpansion_zero]
+  have hq0L : ∑ r : Fin (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ) + 1),
+      (qExpansion 1 (Aform g' D' (r : ℕ)) : LaurentSeries ℂ)
+        * (qExpansion 1 g' : LaurentSeries ℂ) ^ (r : ℕ)
+        * (qExpansion 1 D' : LaurentSeries ℂ)
+            ^ (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ) - (r : ℕ)) = 0 := by
+    have h2 := congrArg (HahnSeries.ofPowerSeries ℤ ℂ) hq0
+    rw [map_zero, map_sum] at h2
+    rw [← h2]
+    exact Finset.sum_congr rfl fun r _ => by rw [map_mul, map_mul, map_pow, map_pow]
+  have hVP : ∀ r : ℕ, ∃ Pco : Polynomial ℂ,
+      (qExpansion 1 (Aform g' D' r) : LaurentSeries ℂ)
+        = Polynomial.aeval ((qExpansion 1 ModularForm.E₄ :
+          LaurentSeries ℂ) ^ 3 / ((qExpansion 1 Δ :
+              PowerSeries ℂ) :
+            LaurentSeries ℂ)) Pco * ((qExpansion 1 Δ :
+              PowerSeries ℂ) :
+            LaurentSeries ℂ) ^ (m * Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ)) := by
+    intro r
+    obtain ⟨Pco, -, hPc⟩ := ModularForm.exists_qExpansion_eq_aeval_mul_pow_levelOne
+      (m * Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ))
+      (ModularForm.mcast (by push_cast; ring) (Aform g' D' r))
+    refine ⟨Pco, ?_⟩
+    rw [← hPc, ModularForm.qExpansion_mcast]
+  choose Pc hP using hVP
+  set FL : LaurentSeries ℂ := (qExpansion 1 g : LaurentSeries ℂ) /
+    (qExpansion 1 Δ : LaurentSeries ℂ) ^ m
+    with hFLdef
+  have hgL : (qExpansion 1 g' : LaurentSeries ℂ)
+      = (qExpansion 1 g : LaurentSeries ℂ) := by rw [hg'q]
+  have hDqL : (qExpansion 1 D' : LaurentSeries ℂ)
+      = (qExpansion 1 Δ :
+        LaurentSeries ℂ) ^ m := by
+    rw [hD'q, PowerSeries.coe_pow]
+  have hkey : (∑ r : Fin (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ) + 1),
+      Polynomial.aeval ((qExpansion 1 ModularForm.E₄ :
+        LaurentSeries ℂ) ^ 3 / (qExpansion 1 Δ :
+          LaurentSeries ℂ)) (Pc (r : ℕ)) * FL ^ (r : ℕ))
+      * ((qExpansion 1 Δ : LaurentSeries ℂ) ^
+          (m * Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ))
+          * (qExpansion 1 D' : LaurentSeries ℂ) ^
+            Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ))
+      = ∑ r : Fin (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ) + 1),
+        (qExpansion 1 (Aform g' D' (r : ℕ)) : LaurentSeries ℂ)
+          * (qExpansion 1 g' : LaurentSeries ℂ) ^ (r : ℕ)
+          * (qExpansion 1 D' : LaurentSeries ℂ)
+              ^ (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ) - (r : ℕ)) := by
+    rw [Finset.sum_mul]
+    refine Finset.sum_congr rfl fun r _ => ?_
+    rw [hP (r : ℕ)]
+    have hr : (r : ℕ) ≤ Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ) := Nat.lt_succ_iff.mp r.2
+    have hexp : (qExpansion 1 g' : LaurentSeries ℂ) ^ (r : ℕ)
+        * (qExpansion 1 D' : LaurentSeries ℂ)
+            ^ (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ) - (r : ℕ))
+        = FL ^ (r : ℕ)
+          * (qExpansion 1 D' : LaurentSeries ℂ) ^ Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ) := by
+      rw [hgL, hDqL, pow_sub₀ _ hΔmL hr, hFLdef, div_pow]
+      field_simp
+    linear_combination (-(Polynomial.aeval ((qExpansion 1 ModularForm.E₄ : LaurentSeries ℂ) ^ 3 /
+      (qExpansion 1 Δ : LaurentSeries ℂ)) (Pc (r : ℕ))
+      * (qExpansion 1 Δ : LaurentSeries ℂ) ^ (m * Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ)))) * hexp
+  have hDne : (qExpansion 1 Δ : LaurentSeries ℂ) ^ (m * Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ))
+      * (qExpansion 1 D' : LaurentSeries ℂ) ^ Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ) ≠ 0 := by
+    rw [hDqL]
+    exact mul_ne_zero (pow_ne_zero _ hΔL) (pow_ne_zero _ hΔmL)
+  have hsum0 : ∑ r : Fin (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ) + 1),
+      Polynomial.aeval ((qExpansion 1 ModularForm.E₄ : LaurentSeries ℂ) ^ 3 /
+        (qExpansion 1 Δ : LaurentSeries ℂ)) (Pc (r : ℕ)) * FL ^ (r : ℕ) = 0 := by
+    have h3 := hkey.trans hq0L
+    rcases mul_eq_zero.mp h3 with h' | h'
+    · exact h'
+    · exact absurd h' hDne
+  have hsum0r : ∑ r ∈ Finset.range (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ) + 1),
+      Polynomial.aeval ((qExpansion 1 ModularForm.E₄ : LaurentSeries ℂ) ^ 3 /
+        (qExpansion 1 Δ : LaurentSeries ℂ)) (Pc r) * FL ^ r = 0 := by
+    rw [← Fin.sum_univ_eq_sum_range
+      (fun rr => Polynomial.aeval ((qExpansion 1 ModularForm.E₄ :
+      LaurentSeries ℂ) ^ 3 / (qExpansion 1 Δ :
+      LaurentSeries ℂ)) (Pc rr) * FL ^ rr) (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ) + 1)]
+    exact hsum0
+  have hsum1 : (∑ r ∈ Finset.range (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ)),
+      Polynomial.aeval ((qExpansion 1 ModularForm.E₄ : LaurentSeries ℂ) ^ 3 /
+        (qExpansion 1 Δ : LaurentSeries ℂ)) (Pc r) * FL ^ r)
+      + Polynomial.aeval ((qExpansion 1 ModularForm.E₄ : LaurentSeries ℂ) ^ 3 /
+        (qExpansion 1 Δ : LaurentSeries ℂ)) (Pc (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ)))
+      * FL ^ (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ)) = 0 := by
+    rw [← Finset.sum_range_succ
+      (fun r => Polynomial.aeval ((qExpansion 1 ModularForm.E₄ :
+      LaurentSeries ℂ) ^ 3 / (qExpansion 1 Δ :
+      LaurentSeries ℂ)) (Pc r) * FL ^ r) (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ))]
+    exact hsum0r
+  have hcard : (Finset.univ : Finset (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ)).card =
+      Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ) :=
+    by
+    rw [Finset.card_univ, Nat.card_eq_fintype_card]
+  have hAn : Aform g' D' (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ))
+      = ((-1 : ℂ) ^ (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ))) • ModularForm.norm 𝒮ℒ D' := by
+    ext τ
+    rw [Aform_apply, smul_apply, norm_apply_eq, smul_eq_mul]
+    unfold Pp
+    conv_lhs => rw [← hcard]
+    rw [coeff_card_prod_linear, Finset.prod_neg, hcard]
+  have hqfD : ∀ (q : 𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ) (τ : ℍ), quotientFunc D' q τ = Dsl τ := by
+    intro q τ
+    induction q using Quotient.inductionOn with
+    | h r =>
+      rw [quotientFunc_mk, hD'def, PenA.ALG.coe_restrict, slash_action_eqn Dsl _ (inv_mem r.2)]
+  have hnormD : ModularForm.norm 𝒮ℒ D' = ModularForm.mcast (by ring)
+      (Dsl.pow (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ))) := by
+    ext τ
+    calc ModularForm.norm 𝒮ℒ D' τ
+        = ∏ q : 𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ, quotientFunc D' q τ := norm_apply_eq D' τ
+      _ = ∏ _q : 𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ, Dsl τ := Finset.prod_congr rfl fun q _ => hqfD q τ
+      _ = (Dsl τ) ^ (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ)) := by rw [Finset.prod_const, hcard]
+      _ = (ModularForm.mcast (by ring) (Dsl.pow (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ))) :
+        ModularForm 𝒮ℒ (12 * (m : ℤ) * (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ) : ℤ))) τ := by
+          simp only [ModularForm.coe_mcast, ModularForm.coe_pow, Pi.pow_apply]
+  have hqAnL : qExpansion 1 (Aform g' D' (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ)))
+      = (-1 : LaurentSeries ℂ) ^ (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ))
+        * (qExpansion 1 Δ : LaurentSeries ℂ) ^ (m * Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ)) := by
+    have hps : qExpansion 1 (Aform g' D' (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ)))
+        = PowerSeries.C ((-1 : ℂ) ^ (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ)))
+          * (qExpansion 1 Δ) ^ (m * Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ)) := by
+      rw [hAn, FunLike.coe_smul,
+        ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL, hnormD,
+        ModularForm.qExpansion_mcast,
+        ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL, hDSLq, ← pow_mul,
+        PowerSeries.smul_eq_C_mul]
+    rw [hps, PowerSeries.coe_mul, PowerSeries.coe_pow, PowerSeries.coe_C, map_pow, map_neg,
+      map_one]
+  have hPn : Polynomial.aeval ((qExpansion 1 ModularForm.E₄ :
+      LaurentSeries ℂ) ^ 3 / (qExpansion 1 Δ : LaurentSeries ℂ))
+      (Pc (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ))) = (-1 : LaurentSeries ℂ) ^
+        (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ)) :=
+    by
+    have h4 := (hP (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ))).symm.trans hqAnL
+    exact mul_right_cancel₀ (pow_ne_zero _ hΔL) h4
+  rw [hPn] at hsum1
+  have hmem : ∀ r : ℕ, ((-1 : LaurentSeries ℂ) ^ (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ))
+        * Polynomial.aeval ((qExpansion 1 ModularForm.E₄ : LaurentSeries ℂ) ^ 3 /
+          (qExpansion 1 Δ : LaurentSeries ℂ)) (Pc r))
+      ∈ Algebra.adjoin ℂ ({((qExpansion 1 ModularForm.E₄ : LaurentSeries ℂ) ^ 3 /
+        (qExpansion 1 Δ : LaurentSeries ℂ))}) := fun r =>
+    Subalgebra.mul_mem _ (pow_mem (neg_mem (one_mem _)) _)
+      (Polynomial.aeval_mem_adjoin_singleton ℂ _)
+  refine ⟨Polynomial.X ^ (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ))
+    + ∑ r ∈ Finset.range (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ)),
+      Polynomial.C (⟨_, hmem r⟩ : Algebra.adjoin ℂ ({((qExpansion 1 ModularForm.E₄ :
+        LaurentSeries ℂ) ^ 3 / (qExpansion 1 Δ : LaurentSeries ℂ))}))
+      * Polynomial.X ^ r, ?_, ?_⟩
+  · refine Polynomial.monic_X_pow_add ?_
+    refine lt_of_le_of_lt (Polynomial.degree_sum_le _ _) ?_
+    rw [Finset.sup_lt_iff (WithBot.bot_lt_coe _)]
+    intro r hr
+    exact lt_of_le_of_lt (Polynomial.degree_C_mul_X_pow_le r _)
+      (by exact_mod_cast Finset.mem_range.mp hr)
+  · rw [← Polynomial.aeval_def, map_add, map_pow, Polynomial.aeval_X, map_sum]
+    have hterm : ∀ r ∈ Finset.range (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ)),
+        Polynomial.aeval FL
+          (Polynomial.C (⟨_, hmem r⟩ : Algebra.adjoin ℂ ({((qExpansion 1 ModularForm.E₄ :
+            LaurentSeries ℂ) ^ 3 / (qExpansion 1 Δ : LaurentSeries ℂ))}))
+            * Polynomial.X ^ r)
+          = ((-1 : LaurentSeries ℂ) ^ (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ))
+            * Polynomial.aeval ((qExpansion 1 ModularForm.E₄ : LaurentSeries ℂ) ^ 3 /
+              (qExpansion 1 Δ : LaurentSeries ℂ)) (Pc r)) * FL ^ r := by
+      intro r _
+      rw [map_mul, Polynomial.aeval_C, map_pow, Polynomial.aeval_X]
+      rfl
+    rw [Finset.sum_congr rfl hterm]
+    have hdist : ∑ r ∈ Finset.range (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ)),
+        ((-1 : LaurentSeries ℂ) ^ (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ))
+        * Polynomial.aeval ((qExpansion 1 ModularForm.E₄ : LaurentSeries ℂ) ^ 3 /
+        (qExpansion 1 Δ : LaurentSeries ℂ)) (Pc r)) * FL ^ r
+        = (-1 : LaurentSeries ℂ) ^ (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ))
+          * ∑ r ∈ Finset.range (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ)),
+            Polynomial.aeval ((qExpansion 1 ModularForm.E₄ : LaurentSeries ℂ) ^ 3 /
+              (qExpansion 1 Δ : LaurentSeries ℂ)) (Pc r) * FL ^ r := by
+      rw [Finset.mul_sum]
+      exact Finset.sum_congr rfl fun r _ => by ring
+    rw [hdist]
+    have h11 : ((-1 : LaurentSeries ℂ) ^ (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ)))
+        * ((-1 : LaurentSeries ℂ) ^ (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ))) = 1 :=
+      by
+      rw [← pow_add, ← two_mul, pow_mul]
+      norm_num
+    linear_combination ((-1 : LaurentSeries ℂ) ^ (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ))) * hsum1
+      - (FL ^ (Nat.card (𝒮ℒ ⧸ (𝒢 ⊓ 𝒮ℒ).subgroupOf 𝒮ℒ))) * h11
+
+end privateSection
+
+public section publicSection
+
+open UpperHalfPlane
+open scoped MatrixGroups
+theorem ModularForm.isIntegral_adjoin_qExpansion_div_discriminant_pow_of_isArithmetic
+    {𝒢 : Subgroup (GL (Fin 2) ℝ)} [𝒢.IsArithmetic] [𝒢.HasDetOne] (h1 : (1 : ℝ) ∈ 𝒢.strictPeriods)
+    (m : ℕ) {k : ℤ} (hk : k = 12 * m) (g : ModularForm 𝒢 k) :
+    IsIntegral (Algebra.adjoin ℂ ({((qExpansion 1 ModularForm.E₄ :
+      LaurentSeries ℂ) ^ 3 / (qExpansion 1 Δ : LaurentSeries ℂ))} :
+      Set (LaurentSeries ℂ))) ((qExpansion 1 g :
+      LaurentSeries ℂ) / (qExpansion 1 Δ : LaurentSeries ℂ) ^ m) :=
+  solution h1 m hk g
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_levelOne_eq_zero_of_lt_order_qExpansion.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_levelOne_eq_zero_of_lt_order_qExpansion.lean
new file mode 100644
index 0000000000..e7be92cb61
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_levelOne_eq_zero_of_lt_order_qExpansion.lean
@@ -0,0 +1,153 @@
+/-
+Based on Prove2Me node ModularForm.levelOne_eq_zero_of_lt_order_qExpansion
+(e1585de7-1d2c-5b27-b930-e63ef4b550b7) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 32791a70-c6a0-5752-a175-d6274ad3c223
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.LevelOne.DimensionFormula
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Level-one vanishing from q-expansion order at width M
+
+Theorem statement: `ModularForm.levelOne_eq_zero_of_lt_order_qExpansion`
+(`e1585de7-1d2c-5b27-b930-e63ef4b550b7`), by Claude, 2026-09-05.
+
+Proof: submission `32791a70-c6a0-5752-a175-d6274ad3c223`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a natural number with $0 < M$, let $k$ be an integer, and let $F$ be a modular form of
+weight $k$ for the full modular group $\mathcal{SL}$, i.e. an element of `ModularForm 𝒮ℒ k`.
+Consider the power series `qExpansion (M : ℝ) F`, the $q$-expansion of $F$ computed with respect to
+the width $M$, so in the variable $q_M = e^{2\pi i \tau / M}$. The hypothesis is that the natural
+number $M \cdot (\mathrm{k.toNat} / 12)$, where `k.toNat` is $\max(k,0)$ and the division is
+truncated division of natural numbers, is strictly smaller, as an element of
+$\mathbb{N}\cup\{\infty\}$, than the order of that power series (the order being $\infty$ when the
+series vanishes). The conclusion is that $F = 0$. Thus a level-one form of weight $k$ whose
+width-$M$ expansion vanishes to order exceeding $M\lfloor k/12\rfloor$ (with the convention that
+negative weights give the bound $0$) is identically zero.
+
+This is the Sturm bound in level one, stated for an expansion variable of arbitrary width $M$ rather
+than only for the standard width $1$. It is the shape in which the level-one bound is applied to
+forms whose natural expansion parameter is $q_M$, such as norms $\prod_\gamma f\,|_k\,\gamma$ of
+forms on a finite-index subgroup; it is cited by
+[`ModularForm.eq_zero_of_lt_order_qExpansion_of_isArithmetic`]
+(thm.html#ModularForm.eq_zero_of_lt_order_qExpansion_of_isArithmetic).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_levelOne_eq_zero_of_lt_order_qExpansion.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_levelOne_eq_zero_of_lt_order_qExpansion
+
+noncomputable section
+
+open Complex Filter Function UpperHalfPlane ModularForm SlashInvariantFormClass ModularFormClass
+
+open scoped Real MatrixGroups Topology Manifold
+
+def W26FnLike : Type := ℍ → ℂ
+
+scoped instance : FunLike W26FnLike ℍ ℂ where
+  coe f := f
+  coe_injective _ _ h := h
+
+theorem W26.qExpansion_coeff_nat_mul {h : ℝ} (hh : 0 < h) {F : ℍ → ℂ}
+    (hper : Function.Periodic (F ∘ UpperHalfPlane.ofComplex) h) (hhol : MDiff F)
+    (hbdd : UpperHalfPlane.IsBoundedAtImInfty F) {M : ℕ} (hM : 0 < M) (n : ℕ) :
+    (qExpansion (M * h) F).coeff n = if M ∣ n then (qExpansion h F).coeff (n / M) else 0 := by
+  have hMh : 0 < (M : ℝ) * h := by positivity
+  have hM0 : (M : ℂ) ≠ 0 := by exact_mod_cast hM.ne'
+  have hh0 : (h : ℂ) ≠ 0 := by exact_mod_cast hh.ne'
+  have hper' : Periodic (F ∘ ofComplex) (((M : ℝ) * h : ℝ) : ℂ) := by
+    simpa using hper.nat_mul M
+  have han : AnalyticAt ℂ (cuspFunction (M * h) F) 0 :=
+    analyticAt_cuspFunction_zero hMh hper' hhol hbdd
+  set c : ℕ → ℂ := fun n ↦ if M ∣ n then (qExpansion h F).coeff (n / M) else 0 with hc
+  have hsum : ∀ τ : ℍ, HasSum (fun m ↦ c m • Periodic.qParam (M * h) τ ^ m) (F τ) := by
+    intro τ
+    have hq : Periodic.qParam h τ = Periodic.qParam (M * h) τ ^ M := by
+      simp only [Periodic.qParam, ← Complex.exp_nat_mul]
+      congr 1
+      push_cast
+      field_simp
+    have hs := hasSum_qExpansion hh hper hhol hbdd τ
+    simp_rw [hq, ← pow_mul] at hs
+    have hinj : Injective (fun m : ℕ ↦ M * m) := mul_right_injective₀ hM.ne'
+    have hsupp : ∀ x ∉ Set.range (fun m : ℕ ↦ M * m),
+        (fun m ↦ c m • Periodic.qParam (M * h) τ ^ m) x = 0 := by
+      intro x hx
+      have : ¬ M ∣ x := by
+        rintro ⟨d, rfl⟩
+        exact hx ⟨d, rfl⟩
+      simp [hc, this]
+    refine (hinj.hasSum_iff hsupp).mp ?_
+    convert hs using 1
+    ext m
+    simp [hc, Nat.mul_div_cancel_left _ hM]
+  have key := qExpansion_coeff_unique (F := W26FnLike) (show W26FnLike from F) hMh han hsum n
+  exact key.symm
+
+theorem solution (M : ℕ) (hM : 0 < M) {k : ℤ} (F : ModularForm 𝒮ℒ k)
+    (h : ((M * (k.toNat / 12) : ℕ) : ℕ∞) < (qExpansion (M : ℝ) F).order) :
+    F = 0 := by
+  by_contra hF
+  have hq1 : qExpansion 1 F ≠ 0 := by
+    rwa [Ne, ModularForm.qExpansion_eq_zero_iff one_pos one_mem_strictPeriods_SL]
+  have hord : (qExpansion 1 F).order ≠ ⊤ := by
+    rwa [Ne, PowerSeries.order_eq_top]
+  obtain ⟨n, hn⟩ := ENat.ne_top_iff_exists.mp hord
+  have hle : n ≤ k.toNat / 12 := by
+    refine le_of_not_gt fun hlt ↦ hF (ModularForm.sturm_bound_levelOne ?_)
+    rw [← hn]
+    exact_mod_cast hlt
+  have hcoeff : (qExpansion 1 F).coeff n ≠ 0 := by
+    have := PowerSeries.coeff_order hq1
+    rwa [← hn, ENat.toNat_natCast] at this
+  have hper := periodic_comp_ofComplex F one_mem_strictPeriods_SL
+  have : Fact (IsCusp OnePoint.infty 𝒮ℒ) := ⟨(𝒮ℒ).isCusp_of_mem_strictPeriods one_pos
+    one_mem_strictPeriods_SL⟩
+  have hM' := W26.qExpansion_coeff_nat_mul one_pos hper (holo F) (bdd_at_infty F)
+    hM (M * n)
+  rw [mul_one, ite_eq_left (dvd_mul_right M n), Nat.mul_div_cancel_left _ hM] at hM'
+  have hordM : (qExpansion (M : ℝ) F).order ≤ (M * n : ℕ) :=
+    PowerSeries.order_le _ (by rwa [hM'])
+  have : ((M * n : ℕ) : ℕ∞) ≤ (M * (k.toNat / 12) : ℕ) := by
+    exact_mod_cast Nat.mul_le_mul_left M hle
+  exact absurd (h.trans_le (hordM.trans this)) (lt_irrefl _)
+
+end
+
+end S_ModularForm_levelOne_eq_zero_of_lt_order_qExpansion
+end P2MW
+export P2MW.S_ModularForm_levelOne_eq_zero_of_lt_order_qExpansion (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane
+open scoped MatrixGroups Manifold
+theorem ModularForm.levelOne_eq_zero_of_lt_order_qExpansion (M : ℕ) (hM : 0 < M) {k : ℤ}
+    (F : ModularForm 𝒮ℒ k) (h : ((M * (k.toNat / 12) : ℕ) : ℕ∞) < (qExpansion (M : ℝ) F).order) :
+    F = 0 :=
+  solution M hM F h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_levelOne_weight_four_qCoeff_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_levelOne_weight_four_qCoeff_one.lean
new file mode 100644
index 0000000000..5db18e7286
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_levelOne_weight_four_qCoeff_one.lean
@@ -0,0 +1,102 @@
+/-
+Based on Prove2Me node ModularForm.levelOne_weight_four_qCoeff_one
+(d72ee19f-da51-59b5-8b15-aad02c02caa0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 54741e01-2324-5556-b7be-3e8618c52eda
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+public import Mathlib.NumberTheory.ModularForms.LevelOne.DimensionFormula
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Weight four level one: a₁ = 240 a₀
+
+Theorem statement: `ModularForm.levelOne_weight_four_qCoeff_one`
+(`d72ee19f-da51-59b5-8b15-aad02c02caa0`), by Claude, 2026-09-05.
+
+Proof: submission `54741e01-2324-5556-b7be-3e8618c52eda`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $Y$ be a modular form of weight $4$ for the full modular group $\mathrm{SL}_2(\mathbb{Z})$, i.e.
+an element of `ModularForm 𝒮ℒ 4`. For a function $f$ on the upper half-plane,
+[`ModularFormClass.qCoeff f n`](def/FLTPrelim_Modularity.html#L19) denotes the $n$-th coefficient of
+the $q$-expansion of $f$ taken with respect to period $1$, that is, the coefficient of $q^n$ in
+`qExpansion 1 f`. The theorem asserts that the first two such coefficients of (the underlying
+function of) $Y$ are related by
+$$\mathrm{qCoeff}\,Y\,1 = 240 \cdot \mathrm{qCoeff}\,Y\,0,$$
+an identity in $\mathbb{C}$. No further hypotheses are imposed: the statement holds for every
+weight-four level-one form, including the zero form, and in particular pins down the linear
+coefficient of such a form in terms of its constant term.
+
+This is the coefficient identity expressing that the space of level-one modular forms of weight $4$
+is spanned by the Eisenstein series $E_4 = 1 + 240q + \cdots$, so that any such form is a scalar
+multiple of $E_4$. It is used in the project wherever weight-four level-one forms occur, for
+instance in the divisibility estimate
+[`CuspForm.dvd_240_mul_qCoeff_one_sq_of_qCoeff_congr_sigmaPrimeTo`]
+(thm.html#CuspForm.dvd_240_mul_qCoeff_one_sq_of_qCoeff_congr_sigmaPrimeTo)
+and in the bounds on analytic orders of vanishing on modular curves appearing in
+[`ModularCurve.analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq`]
+(thm.html#ModularCurve.analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq)
+and its variant for powers.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_levelOne_weight_four_qCoeff_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_levelOne_weight_four_qCoeff_one
+open scoped MatrixGroups
+
+namespace ModularForm
+p2m_export "ModularForm" "levelOne_weight_four_rank_one E₄_qExpansion_coeff_one E₄"
+end ModularForm
+p2m_open_scoped "ModularForm" in
+private theorem ModularForm.levelOne_weight_four_qCoeff_one (Y : ModularForm 𝒮ℒ 4) :
+    ModularFormClass.qCoeff ⇑Y 1 = 240 * ModularFormClass.qCoeff ⇑Y 0 := by
+  obtain ⟨c, hc⟩ : ∃ c : ℂ, c • ModularForm.E₄ = Y :=
+    (finrank_eq_one_iff_of_nonzero' ModularForm.E₄ (EisensteinSeries.E_ne_zero _ ⟨2, rfl⟩)).mp
+      (Module.rank_eq_one_iff_finrank_eq_one.mp ModularForm.levelOne_weight_four_rank_one) Y
+  have hq : UpperHalfPlane.qExpansion 1 ⇑Y = c • UpperHalfPlane.qExpansion 1 ⇑ModularForm.E₄ := by
+    rw [← ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL c ModularForm.E₄,
+      show (c • ⇑ModularForm.E₄) = ⇑Y from congrArg DFunLike.coe hc]
+  have h0 : (UpperHalfPlane.qExpansion 1 ⇑ModularForm.E₄).coeff 0 = 1 :=
+    EisensteinSeries.E_qExpansion_coeff_zero _ ⟨2, rfl⟩
+  change (UpperHalfPlane.qExpansion 1 ⇑Y).coeff 1 = _ * (UpperHalfPlane.qExpansion 1 ⇑Y).coeff 0
+  rw [hq, PowerSeries.coeff_smul, PowerSeries.coeff_smul, smul_eq_mul, smul_eq_mul, h0,
+    ModularForm.E₄_qExpansion_coeff_one]
+  ring
+
+theorem solution (Y : ModularForm 𝒮ℒ 4) :
+    ModularFormClass.qCoeff ⇑Y 1 = 240 * ModularFormClass.qCoeff ⇑Y 0 :=
+  ModularForm.levelOne_weight_four_qCoeff_one Y
+
+end S_ModularForm_levelOne_weight_four_qCoeff_one
+end P2MW
+export P2MW.S_ModularForm_levelOne_weight_four_qCoeff_one (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularForm.levelOne_weight_four_qCoeff_one (Y : ModularForm 𝒮ℒ 4) :
+    ModularFormClass.qCoeff ⇑Y 1 = 240 * ModularFormClass.qCoeff ⇑Y 0 :=
+  solution Y
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_levelOne_weight_six_qCoeff_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_levelOne_weight_six_qCoeff_one.lean
new file mode 100644
index 0000000000..b41a841e7b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_levelOne_weight_six_qCoeff_one.lean
@@ -0,0 +1,102 @@
+/-
+Based on Prove2Me node ModularForm.levelOne_weight_six_qCoeff_one
+(0cdd5148-2211-59d3-b80f-7f2b715c9053) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 97749c72-5f9d-5ed9-8f33-208eed9b16d7
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+public import Mathlib.NumberTheory.ModularForms.LevelOne.DimensionFormula
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Weight six level one: a₁ = -504 a₀
+
+Theorem statement: `ModularForm.levelOne_weight_six_qCoeff_one`
+(`0cdd5148-2211-59d3-b80f-7f2b715c9053`), by Claude, 2026-09-05.
+
+Proof: submission `97749c72-5f9d-5ed9-8f33-208eed9b16d7`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $Y$ be a modular form of weight $6$ for the full modular group $\mathrm{SL}_2(\mathbb{Z})$, i.e.
+an element of `ModularForm 𝒮ℒ 6`. Write, for a function $f$ on the upper half-plane,
+$\mathrm{qCoeff}(f,n)$ for the $n$-th coefficient of the $q$-expansion of $f$ of width $1$, that is
+the coefficient of $q^n$ in `qExpansion 1 f` as a formal power series. The assertion is the single
+linear relation
+$$\mathrm{qCoeff}(Y,1) = -504\,\mathrm{qCoeff}(Y,0)$$
+between the first two $q$-expansion coefficients of the function underlying $Y$, with both sides
+complex numbers. There are no further hypotheses: the relation holds for every weight $6$ level one
+form, with no normalisation, cuspidality or integrality assumption, and it is an identity of
+$q$-coefficients only, not a statement about $Y$ itself.
+
+This is the explicit form of the fact that the space of level one modular forms of weight $6$ is
+one-dimensional, spanned by $E_6 = 1 - 504q - \cdots$, so that $a_1$ is determined by $a_0$. It is
+used in the project's control of $q$-expansions of level one forms, for instance in the divisibility
+statement
+[`CuspForm.dvd_504_mul_qCoeff_one_cube_of_qCoeff_congr_sigmaPrimeTo`]
+(thm.html#CuspForm.dvd_504_mul_qCoeff_one_cube_of_qCoeff_congr_sigmaPrimeTo)
+and in the bounds on analytic orders of vanishing of integral combinations of $j$ appearing in
+[`ModularCurve.analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq`]
+(thm.html#ModularCurve.analyticOrderAt_le_of_isIntegral_adjoin_coeffEmb_jq)
+and its power variant.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_levelOne_weight_six_qCoeff_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_levelOne_weight_six_qCoeff_one
+open scoped MatrixGroups
+
+namespace ModularForm
+p2m_export "ModularForm" "levelOne_weight_six_rank_one E₆ E₆_qExpansion_coeff_one"
+end ModularForm
+p2m_open_scoped "ModularForm" in
+private theorem ModularForm.levelOne_weight_six_qCoeff_one (Y : ModularForm 𝒮ℒ 6) :
+    ModularFormClass.qCoeff ⇑Y 1 = -504 * ModularFormClass.qCoeff ⇑Y 0 := by
+  obtain ⟨c, hc⟩ : ∃ c : ℂ, c • ModularForm.E₆ = Y :=
+    (finrank_eq_one_iff_of_nonzero' ModularForm.E₆ (EisensteinSeries.E_ne_zero _ ⟨3, rfl⟩)).mp
+      (Module.rank_eq_one_iff_finrank_eq_one.mp ModularForm.levelOne_weight_six_rank_one) Y
+  have hq : UpperHalfPlane.qExpansion 1 ⇑Y = c • UpperHalfPlane.qExpansion 1 ⇑ModularForm.E₆ := by
+    rw [← ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL c ModularForm.E₆,
+      show (c • ⇑ModularForm.E₆) = ⇑Y from congrArg DFunLike.coe hc]
+  have h0 : (UpperHalfPlane.qExpansion 1 ⇑ModularForm.E₆).coeff 0 = 1 :=
+    EisensteinSeries.E_qExpansion_coeff_zero _ ⟨3, rfl⟩
+  change (UpperHalfPlane.qExpansion 1 ⇑Y).coeff 1 = _ * (UpperHalfPlane.qExpansion 1 ⇑Y).coeff 0
+  rw [hq, PowerSeries.coeff_smul, PowerSeries.coeff_smul, smul_eq_mul, smul_eq_mul, h0,
+    ModularForm.E₆_qExpansion_coeff_one]
+  ring
+
+theorem solution (Y : ModularForm 𝒮ℒ 6) :
+    ModularFormClass.qCoeff ⇑Y 1 = -504 * ModularFormClass.qCoeff ⇑Y 0 :=
+  ModularForm.levelOne_weight_six_qCoeff_one Y
+
+end S_ModularForm_levelOne_weight_six_qCoeff_one
+end P2MW
+export P2MW.S_ModularForm_levelOne_weight_six_qCoeff_one (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularForm.levelOne_weight_six_qCoeff_one (Y : ModularForm 𝒮ℒ 6) :
+    ModularFormClass.qCoeff ⇑Y 1 = -504 * ModularFormClass.qCoeff ⇑Y 0 :=
+  solution Y
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant.lean
new file mode 100644
index 0000000000..12c9f10161
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant.lean
@@ -0,0 +1,117 @@
+/-
+Based on Prove2Me node ModularForm.levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant
+(d50a0369-6f22-53be-8459-cdd59ce95206) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7be5f29a-1076-51f5-8a10-56a56cc887e4
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+
+import Mathlib.NumberTheory.ModularForms.LevelOne.DimensionFormula
+
+/-!
+# Level-one weight-12 forms with vanishing constant term are τ-multiples
+
+Theorem statement: `ModularForm.levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant`
+(`d50a0369-6f22-53be-8459-cdd59ce95206`), by Claude, 2026-09-05.
+
+Proof: submission `7be5f29a-1076-51f5-8a10-56a56cc887e4`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $Z$ be a modular form of weight $12$ for the full modular group $\mathrm{SL}_2(\mathbb{Z})$
+(written $\mathcal{SL}$ in the statement). For a function $f \colon \mathbb{H} \to \mathbb{C}$ and
+$n \in \mathbb{N}$, write $\mathrm{qCoeff}(f, n)$ for the $n$-th coefficient of the $q$-expansion of
+$f$ taken with respect to the period $1$, i.e. the coefficient of $q^n$ in `qExpansion 1 f`. Assume
+that the constant term of $Z$ vanishes, $\mathrm{qCoeff}(Z, 0) = 0$. Then for every natural number
+$n$, $$\mathrm{qCoeff}(Z, n) = \mathrm{qCoeff}(Z, 1) \cdot \mathrm{qCoeff}(\Delta, n),$$ where
+$\Delta$ denotes the modular discriminant `ModularForm.discriminant`, regarded as a function on the
+upper half plane. Thus all $q$-expansion coefficients of such a $Z$ are determined by its first
+coefficient, being $a_1(Z)\tau(n)$ with $\tau$ the Ramanujan function, and in particular $Z$ is a
+scalar multiple of $\Delta$ at the level of $q$-expansions.
+
+This is the coefficient form of the statement that the space of cusp forms of weight $12$ and level
+one is one-dimensional, spanned by $\Delta = q - 24q^2 + \cdots$: a weight-$12$ level-one form with
+vanishing constant term is a multiple of $\Delta$. It is used in the project's analysis of the
+$q$-expansion of modular functions on the modular curve, in particular in the bounds on analytic
+orders of vanishing in terms of integrality of the $j$-function's $q$-expansion coefficients.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open scoped MatrixGroups
+
+namespace WL12Pen
+
+private theorem exists_coe_eq_smul_discriminant (Z : ModularForm 𝒮ℒ 12)
+    (h0 : ModularFormClass.qCoeff ⇑Z 0 = 0) :
+    ∃ c : ℂ, (⇑Z : UpperHalfPlane → ℂ) = c • ⇑CuspForm.discriminant := by
+  obtain ⟨c, hc⟩ :=
+    CuspForm.exists_smul_discriminant_of_weight_eq_twelve (ModularForm.toCuspForm Z h0)
+  exact ⟨c, (show (c • ⇑CuspForm.discriminant : UpperHalfPlane → ℂ)
+    = ⇑(ModularForm.toCuspForm Z h0) from congrArg DFunLike.coe hc).symm⟩
+
+private theorem qExpansion_eq_smul (Z : ModularForm 𝒮ℒ 12) (c : ℂ)
+    (hZ : (⇑Z : UpperHalfPlane → ℂ) = c • ⇑CuspForm.discriminant) :
+    UpperHalfPlane.qExpansion 1 ⇑Z = c • UpperHalfPlane.qExpansion 1 ModularForm.discriminant := by
+  rw [hZ, ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL c CuspForm.discriminant,
+    CuspForm.coe_discriminant]
+
+private theorem qCoeff_eq_mul (Z : ModularForm 𝒮ℒ 12) (c : ℂ)
+    (hq : UpperHalfPlane.qExpansion 1 ⇑Z
+      = c • UpperHalfPlane.qExpansion 1 ModularForm.discriminant) (n : ℕ) :
+    ModularFormClass.qCoeff ⇑Z n = c * ModularFormClass.qCoeff ModularForm.discriminant n := by
+  unfold ModularFormClass.qCoeff
+  rw [hq, PowerSeries.coeff_smul, smul_eq_mul]
+
+private theorem qCoeff_one_eq (Z : ModularForm 𝒮ℒ 12) (c : ℂ)
+    (hq : UpperHalfPlane.qExpansion 1 ⇑Z
+      = c • UpperHalfPlane.qExpansion 1 ModularForm.discriminant) :
+    ModularFormClass.qCoeff ⇑Z 1 = c := by
+  have h1 : ModularFormClass.qCoeff ModularForm.discriminant 1 = 1 := by
+    unfold ModularFormClass.qCoeff
+    exact ModularForm.discriminant_qExpansion_coeff_one
+  rw [qCoeff_eq_mul Z c hq 1, h1, mul_one]
+
+end WL12Pen
+
+private theorem ModularForm.levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant'
+    (Z : ModularForm 𝒮ℒ 12) (h0 : ModularFormClass.qCoeff ⇑Z 0 = 0) :
+    ∀ n : ℕ, ModularFormClass.qCoeff ⇑Z n = ModularFormClass.qCoeff ⇑Z 1 * ModularFormClass.qCoeff
+      ModularForm.discriminant n := by
+  obtain ⟨c, hZ⟩ := WL12Pen.exists_coe_eq_smul_discriminant Z h0
+  have hq := WL12Pen.qExpansion_eq_smul Z c hZ
+  intro n
+  rw [WL12Pen.qCoeff_eq_mul Z c hq n, WL12Pen.qCoeff_one_eq Z c hq]
+
+theorem solution (Z : ModularForm 𝒮ℒ 12) (h0 : ModularFormClass.qCoeff ⇑Z 0 = 0) :
+    ∀ n : ℕ, ModularFormClass.qCoeff ⇑Z n = ModularFormClass.qCoeff ⇑Z 1 * ModularFormClass.qCoeff
+      ModularForm.discriminant n :=
+  ModularForm.levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant' Z h0
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularForm.levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant
+    (Z : ModularForm 𝒮ℒ 12) (h0 : ModularFormClass.qCoeff ⇑Z 0 = 0) :
+    ∀ n : ℕ, ModularFormClass.qCoeff ⇑Z n = ModularFormClass.qCoeff ⇑Z 1 * ModularFormClass.qCoeff
+      ModularForm.discriminant n :=
+  solution Z h0
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_mdifferentiable_heckeT.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_mdifferentiable_heckeT.lean
new file mode 100644
index 0000000000..f6a57c7bea
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_mdifferentiable_heckeT.lean
@@ -0,0 +1,409 @@
+/-
+Based on Prove2Me node ModularForm.mdifferentiable_heckeT
+(2743fa4f-4160-5456-aeb8-0f6485a20067) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 35b46d18-227d-5c45-a94b-dc88ace693ca
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.CStarAlgebra.Classes
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Manifold
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Holomorphy of Tₚ f for holomorphic f
+
+Theorem statement: `ModularForm.mdifferentiable_heckeT` (`2743fa4f-4160-5456-aeb8-0f6485a20067`), by
+Claude, 2026-09-05.
+
+Proof: submission `35b46d18-227d-5c45-a94b-dc88ace693ca`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $f : \mathbb{H} \to \mathbb{C}$ be a function on the upper half-plane which is `MDifferentiable`
+for the standard self-model-with-corners of $\mathbb{C}$ on both source and target, i.e. holomorphic
+as a map between the complex manifolds $\mathbb{H}$ and $\mathbb{C}$. Let $k$ be an integer and $p$
+a natural number. Then the function [`ModularForm.heckeT k p
+f`](def/ModularForm_HeckeOperator.html#L96), defined as the sum $\sum_{j \in \{0,\dots,p-1\}} f
+\mid[k] \,$`heckeMatrix p j` $+\; f \mid[k] \,$`heckeDiagMatrix p`, is again holomorphic in the same
+sense, where $\mid[k]$ is the weight-$k$ slash action of $\mathrm{GL}_2(\mathbb{R})$ on functions on
+$\mathbb{H}$, the matrices `heckeMatrix p j` are the $p$ upper-triangular representatives used in
+the project's definition of `heckeU`, and `heckeDiagMatrix p` is the identity when $p = 0$ and the
+element `upperTriangularGL p 0 1` of $\mathrm{GL}_2(\mathbb{R})$ otherwise. No positivity, primality
+or non-vanishing assumption is imposed on $p$; for $p = 0$ the first sum is empty and the statement
+reduces to the holomorphy of $f \mid[k] 1$.
+
+This is the holomorphy half of the standard statement that the Hecke operator $T_p$ preserves
+holomorphic functions on $\mathbb{H}$, formulated for arbitrary functions rather than only for
+modular or cusp forms. It is used when assembling $T_p$ on spaces of cusp forms, for instance in the
+results producing a cusp form whose underlying function is `heckeT k p f` and in the computations of
+$q$-expansion coefficients of $T_p$-eigenforms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_mdifferentiable_heckeT.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_ModularForm_mdifferentiable_heckeT
+
+noncomputable section
+
+open Complex Function Filter
+p2m_open "UpperHalfPlane~I"
+open scoped Real MatrixGroups ModularForm Manifold Topology
+
+namespace M4cP1W2
+
+open ModularForm ModularFormClass
+
+section Matrices
+
+variable (p j : ℕ)
+
+theorem heckeMatrix_one_zero :
+    ((heckeMatrix p j : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) 1 0 = 0 := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  · rw [val_heckeMatrix hp]; rfl
+
+theorem heckeDiagMatrix_one_zero :
+    ((heckeDiagMatrix p : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) 1 0 = 0 := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  · rw [val_heckeDiagMatrix hp]; rfl
+
+end Matrices
+
+section Regularity
+
+variable {f : ℍ → ℂ} (k : ℤ) (p : ℕ)
+
+theorem mdifferentiable_heckeU (hf : MDiff f) : MDiff (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => MDiff g) (fun _ _ ha hb => ha.add hb)
+    mdifferentiable_const (fun _ _ => hf.slash k _)
+
+theorem mdifferentiable_heckeT (hf : MDiff f) : MDiff (heckeT k p f) :=
+  (mdifferentiable_heckeU k p hf).add (hf.slash k _)
+
+theorem isBoundedAtImInfty_heckeU (hf : IsBoundedAtImInfty f) :
+    IsBoundedAtImInfty (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => IsBoundedAtImInfty g)
+    (fun _ _ ha hb => ha.add hb) UpperHalfPlane.zero_form_isBoundedAtImInfty
+    (fun j _ => hf.slash k (heckeMatrix_one_zero p j))
+
+theorem isBoundedAtImInfty_heckeT (hf : IsBoundedAtImInfty f) :
+    IsBoundedAtImInfty (heckeT k p f) :=
+  (isBoundedAtImInfty_heckeU k p hf).add (hf.slash k (heckeDiagMatrix_one_zero p))
+
+theorem isZeroAtImInfty_heckeU (hf : IsZeroAtImInfty f) :
+    IsZeroAtImInfty (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => IsZeroAtImInfty g)
+    (fun _ _ ha hb => ha.add hb) (zero_zeroAtFilter atImInfty)
+    (fun j _ => hf.slash k (heckeMatrix_one_zero p j))
+
+theorem isZeroAtImInfty_heckeT (hf : IsZeroAtImInfty f) :
+    IsZeroAtImInfty (heckeT k p f) :=
+  (isZeroAtImInfty_heckeU k p hf).add (hf.slash k (heckeDiagMatrix_one_zero p))
+
+theorem apply_eq_of_coe_eq_add_nat (hf : Periodic (f ∘ ofComplex) 1) {τ₁ τ₂ : ℍ} (m : ℕ)
+    (h : (τ₁ : ℂ) = τ₂ + m) : f τ₁ = f τ₂ := by
+  have h1 : (f ∘ ofComplex) ((τ₂ : ℂ) + m) = (f ∘ ofComplex) (τ₂ : ℂ) := by
+    have := hf.nat_mul m
+    rw [mul_one] at this
+    exact this (τ₂ : ℂ)
+  simp only [comp_apply] at h1
+  rw [← h, ofComplex_apply, ofComplex_apply] at h1
+  exact h1
+
+variable {p} in
+theorem heckeMatrix_smul_vadd (hp : p ≠ 0) (j : ℕ) (τ : ℍ) :
+    heckeMatrix p j • ((1 : ℝ) +ᵥ τ) = heckeMatrix p (j + 1) • τ := by
+  apply UpperHalfPlane.ext
+  rw [coe_heckeMatrix_smul hp, coe_heckeMatrix_smul hp, coe_vadd]
+  push_cast
+  ring
+
+variable {p} in
+theorem coe_heckeMatrix_smul_self (hp : p ≠ 0) (τ : ℍ) :
+    ((heckeMatrix p p • τ : ℍ) : ℂ) = (heckeMatrix p 0 • τ : ℍ) + (1 : ℕ) := by
+  have hp' : (p : ℂ) ≠ 0 := by exact_mod_cast hp
+  rw [coe_heckeMatrix_smul hp, coe_heckeMatrix_smul hp]
+  field_simp
+  push_cast
+  ring
+
+variable {p} in
+theorem coe_heckeDiagMatrix_smul_vadd (hp : p ≠ 0) (τ : ℍ) :
+    ((heckeDiagMatrix p • ((1 : ℝ) +ᵥ τ) : ℍ) : ℂ) = (heckeDiagMatrix p • τ : ℍ) + (p : ℕ) := by
+  rw [coe_heckeDiagMatrix_smul hp, coe_heckeDiagMatrix_smul hp, coe_vadd]
+  push_cast
+  ring
+
+variable {p} in
+theorem sum_heckeMatrix_smul_vadd (hp : p ≠ 0) (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    ∑ j ∈ Finset.range p, f (heckeMatrix p j • ((1 : ℝ) +ᵥ τ))
+      = ∑ j ∈ Finset.range p, f (heckeMatrix p j • τ) := by
+  simp only [heckeMatrix_smul_vadd hp]
+  have h0 := Finset.sum_range_succ' (fun j => f (heckeMatrix p j • τ)) p
+  have h1 := Finset.sum_range_succ (fun j => f (heckeMatrix p j • τ)) p
+  rw [apply_eq_of_coe_eq_add_nat hf 1 (coe_heckeMatrix_smul_self hp τ)] at h1
+  exact add_right_cancel (h0.symm.trans h1)
+
+theorem heckeU_vadd (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    heckeU k p f ((1 : ℝ) +ᵥ τ) = heckeU k p f τ := by
+  by_cases hp : p = 0
+  · simp only [hp, heckeU_zero_left, Pi.zero_apply]
+  · rw [heckeU_apply k hp, heckeU_apply k hp, sum_heckeMatrix_smul_vadd hp hf]
+
+theorem heckeT_vadd (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    heckeT k p f ((1 : ℝ) +ᵥ τ) = heckeT k p f τ := by
+  by_cases hp : p = 0
+  · simp only [hp, heckeT_zero_left]
+    exact apply_eq_of_coe_eq_add_nat hf 1 (by rw [coe_vadd]; push_cast; ring)
+  · rw [heckeT_apply k hp, heckeT_apply k hp, sum_heckeMatrix_smul_vadd hp hf,
+      apply_eq_of_coe_eq_add_nat hf p (coe_heckeDiagMatrix_smul_vadd hp τ)]
+
+theorem periodic_comp_ofComplex_of_vadd {g : ℍ → ℂ} (hg : ∀ τ : ℍ, g ((1 : ℝ) +ᵥ τ) = g τ) :
+    Periodic (g ∘ ofComplex) 1 := by
+  intro w
+  by_cases hw : 0 < im w
+  · have hw' : 0 < im (w + 1) := by simp [hw]
+    simp only [comp_apply, ofComplex_apply_of_im_pos hw', ofComplex_apply_of_im_pos hw]
+    convert hg ⟨w, hw⟩ using 2
+    apply UpperHalfPlane.ext
+    simp [add_comm]
+  · have hw1 : im (w + 1) ≤ 0 := by simpa using hw
+    have hw0 : im w ≤ 0 := not_lt.mp hw
+    simp only [comp_apply, ofComplex_apply_eq_of_im_nonpos hw1 hw0]
+
+theorem periodic_heckeU_comp_ofComplex (hf : Periodic (f ∘ ofComplex) 1) :
+    Periodic (heckeU k p f ∘ ofComplex) 1 :=
+  periodic_comp_ofComplex_of_vadd (heckeU_vadd k p hf)
+
+theorem periodic_heckeT_comp_ofComplex (hf : Periodic (f ∘ ofComplex) 1) :
+    Periodic (heckeT k p f ∘ ofComplex) 1 :=
+  periodic_comp_ofComplex_of_vadd (heckeT_vadd k p hf)
+
+end Regularity
+
+section Uniqueness
+
+theorem qExpansion_coeff_unique' {g : ℍ → ℂ} (hcont : Continuous g) {c : ℕ → ℂ}
+    (hg : AnalyticAt ℂ (cuspFunction 1 g) 0)
+    (hs : ∀ τ : ℍ, HasSum (fun m ↦ c m • Periodic.qParam 1 τ ^ m) (g τ)) (m : ℕ) :
+    c m = (qExpansion 1 g).coeff m :=
+  UpperHalfPlane.qExpansion_coeff_unique (ContinuousMap.mk g hcont) one_pos hg hs m
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+theorem hasSum_qCoeff [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) (τ : ℍ) :
+    HasSum (fun m ↦ qCoeff f m • Periodic.qParam 1 τ ^ m) (f τ) := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  exact hasSum_qExpansion one_pos (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ)
+    (holo f) (bdd_at_infty f) τ
+
+theorem eq_of_forall_qCoeff_eq [ModularFormClass F Γ k] {f g : F} (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (h : ∀ n : ℕ, qCoeff f n = qCoeff g n) : f = g := by
+  refine DFunLike.ext f g fun τ => ?_
+  have hf := hasSum_qCoeff f hΓ τ
+  have hg := hasSum_qCoeff g hΓ τ
+  simp only [h] at hf
+  exact hf.unique hg
+
+end Uniqueness
+
+section QExpAction
+
+theorem qParam_one (z : ℂ) : Periodic.qParam 1 z = exp (2 * π * I * z) := by
+  simp [Periodic.qParam]
+
+variable {p : ℕ} (hp : p ≠ 0)
+
+include hp in
+theorem natCast_ne_zero' : (p : ℂ) ≠ 0 := by exact_mod_cast hp
+
+include hp in
+theorem qParam_heckeMatrix_smul (j : ℕ) (τ : ℍ) :
+    Periodic.qParam 1 ((heckeMatrix p j • τ : ℍ) : ℂ)
+      = exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j := by
+  rw [qParam_one, coe_heckeMatrix_smul hp, ← Complex.exp_nat_mul, ← Complex.exp_add]
+  congr 1
+  have := natCast_ne_zero' hp
+  field_simp
+
+include hp in
+theorem qParam_heckeDiagMatrix_smul (τ : ℍ) :
+    Periodic.qParam 1 ((heckeDiagMatrix p • τ : ℍ) : ℂ) = Periodic.qParam 1 τ ^ p := by
+  rw [qParam_one, qParam_one, coe_heckeDiagMatrix_smul hp, ← Complex.exp_nat_mul]
+  congr 1
+  ring
+
+include hp in
+theorem exp_div_pow (τ : ℍ) : exp (2 * π * I * τ / p) ^ p = Periodic.qParam 1 τ := by
+  rw [qParam_one, ← Complex.exp_nat_mul]
+  congr 1
+  have := natCast_ne_zero' hp
+  field_simp
+
+include hp in
+theorem sum_rootOfUnity_pow (m : ℕ) :
+    ∑ j ∈ Finset.range p, (exp (2 * π * I / p) ^ j) ^ m = if p ∣ m then (p : ℂ) else 0 := by
+  have hζ := Complex.isPrimitiveRoot_exp p hp
+  have hswap : ∀ j : ℕ, (exp (2 * π * I / p) ^ j) ^ m = (exp (2 * π * I / p) ^ m) ^ j := fun j => by
+    rw [← pow_mul, ← pow_mul, Nat.mul_comm j m]
+  simp only [hswap]
+  split_ifs with h
+  · rw [(hζ.pow_eq_one_iff_dvd m).mpr h]
+    simp
+  · have hne : exp (2 * π * I / p) ^ m ≠ 1 := fun h1 => h ((hζ.pow_eq_one_iff_dvd m).mp h1)
+    rw [geom_sum_eq hne, ← pow_mul, Nat.mul_comm m p, pow_mul, hζ.pow_eq_one, one_pow, sub_self,
+      zero_div]
+
+theorem not_dvd_of_not_mem_range {m : ℕ} (hm : m ∉ Set.range (fun l : ℕ ↦ l * p)) : ¬ p ∣ m := by
+  rintro ⟨l, rfl⟩
+  exact hm ⟨l, by simp [mul_comm]⟩
+
+variable {f : ℍ → ℂ} (hper : Periodic (f ∘ ofComplex) 1) (hhol : MDiff f)
+  (hbdd : IsBoundedAtImInfty f)
+
+include hp hper hhol hbdd in
+theorem hasSum_average (τ : ℍ) :
+    HasSum (fun l : ℕ ↦ qCoeff f (l * p) * Periodic.qParam 1 τ ^ l)
+      ((p : ℂ)⁻¹ * ∑ j ∈ Finset.range p, f (heckeMatrix p j • τ)) := by
+  have hF : ∀ τ' : ℍ, HasSum (fun m ↦ qCoeff f m • Periodic.qParam 1 τ' ^ m) (f τ') :=
+    hasSum_qExpansion one_pos hper hhol hbdd
+  have h1 : HasSum (fun m ↦ ∑ j ∈ Finset.range p,
+      qCoeff f m • (exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j) ^ m)
+      (∑ j ∈ Finset.range p, f (heckeMatrix p j • τ)) := by
+    refine hasSum_sum fun j _ => ?_
+    have := hF (heckeMatrix p j • τ)
+    rwa [qParam_heckeMatrix_smul hp j τ] at this
+  have h2 : (fun m ↦ ∑ j ∈ Finset.range p,
+      qCoeff f m • (exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j) ^ m)
+      = fun m ↦ if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0 := by
+    funext m
+    simp only [mul_pow, smul_eq_mul, ← Finset.mul_sum, sum_rootOfUnity_pow hp m]
+    split_ifs <;> ring
+  rw [h2] at h1
+  have hinj : Function.Injective (fun l : ℕ ↦ l * p) := mul_left_injective₀ hp
+  have h3 := (hinj.hasSum_iff (f := fun m ↦
+      if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0)
+    (fun m hm => by simp [not_dvd_of_not_mem_range hm])).mpr h1
+  have h4 : ((fun m ↦ if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0) ∘
+      fun l : ℕ ↦ l * p) = fun l ↦ (p : ℂ) * (qCoeff f (l * p) * Periodic.qParam 1 τ ^ l) := by
+    funext l
+    simp only [comp_apply, ite_eq_left (dvd_mul_left p l)]
+    rw [mul_comm l p, pow_mul, exp_div_pow hp τ]
+    ring
+  rw [h4] at h3
+  have h5 := h3.mul_left ((p : ℂ)⁻¹)
+  simp only [← mul_assoc, inv_mul_cancel₀ (natCast_ne_zero' hp), one_mul] at h5
+  exact h5
+
+include hp hper hhol hbdd in
+theorem hasSum_diag (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ if p ∣ n then (p : ℂ) ^ (k - 1) * qCoeff f (n / p) * Periodic.qParam 1 τ ^ n
+        else 0)
+      ((p : ℂ) ^ (k - 1) * f (heckeDiagMatrix p • τ)) := by
+  have hD := (hasSum_qExpansion one_pos hper hhol hbdd (heckeDiagMatrix p • τ)).mul_left
+    ((p : ℂ) ^ (k - 1))
+  rw [qParam_heckeDiagMatrix_smul hp τ] at hD
+  have hinj : Function.Injective (fun l : ℕ ↦ l * p) := mul_left_injective₀ hp
+  refine (hinj.hasSum_iff (fun m hm => by simp [not_dvd_of_not_mem_range hm])).mp ?_
+  convert hD using 1
+  funext l
+  simp only [comp_apply, ite_eq_left (dvd_mul_left p l), Nat.mul_div_cancel _ (Nat.pos_of_ne_zero
+    hp),
+    smul_eq_mul]
+  rw [← pow_mul, mul_comm l p, mul_assoc]
+  rfl
+
+include hp hper hhol hbdd in
+theorem hasSum_heckeU (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ coeffHeckeU p (qCoeff f) n • Periodic.qParam 1 τ ^ n) (heckeU k p f τ) := by
+  rw [heckeU_apply k hp]
+  simpa only [coeffHeckeU_apply, smul_eq_mul] using hasSum_average hp hper hhol hbdd τ
+
+include hp hper hhol hbdd in
+theorem hasSum_heckeT (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ coeffHeckeT k p (qCoeff f) n • Periodic.qParam 1 τ ^ n) (heckeT k p f τ) :=
+      by
+  rw [heckeT_apply k hp]
+  convert (hasSum_average hp hper hhol hbdd τ).add (hasSum_diag hp hper hhol hbdd k τ) using 1
+  funext n
+  rw [coeffHeckeT_apply, smul_eq_mul]
+  split_ifs <;> ring
+
+include hp hper hhol hbdd in
+theorem qCoeff_heckeU_bare (k : ℤ) (n : ℕ) :
+    qCoeff (heckeU k p f) n = coeffHeckeU p (qCoeff f) n :=
+  (qExpansion_coeff_unique' (mdifferentiable_heckeU k p hhol).continuous
+    (analyticAt_cuspFunction_zero one_pos (periodic_heckeU_comp_ofComplex k p hper)
+      (mdifferentiable_heckeU k p hhol) (isBoundedAtImInfty_heckeU k p hbdd))
+    (hasSum_heckeU hp hper hhol hbdd k) n).symm
+
+include hp hper hhol hbdd in
+theorem qCoeff_heckeT_bare (k : ℤ) (n : ℕ) :
+    qCoeff (heckeT k p f) n = coeffHeckeT k p (qCoeff f) n :=
+  (qExpansion_coeff_unique' (mdifferentiable_heckeT k p hhol).continuous
+    (analyticAt_cuspFunction_zero one_pos (periodic_heckeT_comp_ofComplex k p hper)
+      (mdifferentiable_heckeT k p hhol) (isBoundedAtImInfty_heckeT k p hbdd))
+    (hasSum_heckeT hp hper hhol hbdd k) n).symm
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+include hp in
+theorem qCoeff_heckeU_class [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (n : ℕ) : qCoeff (heckeU k p f) n = coeffHeckeU p (qCoeff f) n :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  qCoeff_heckeU_bare hp (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (holo f)
+    (bdd_at_infty f) k n
+
+include hp in
+theorem qCoeff_heckeT_class [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (n : ℕ) : qCoeff (heckeT k p f) n = coeffHeckeT k p (qCoeff f) n :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  qCoeff_heckeT_bare hp (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (holo f)
+    (bdd_at_infty f) k n
+
+end QExpAction
+
+end M4cP1W2
+
+end
+
+theorem solution {f : UpperHalfPlane → ℂ}
+    (hf : MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) f) (k : ℤ) (p : ℕ) :
+    MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) (ModularForm.heckeT k p f)
+      :=
+  M4cP1W2.mdifferentiable_heckeT k p hf
+
+end S_ModularForm_mdifferentiable_heckeT
+end P2MW
+export P2MW.S_ModularForm_mdifferentiable_heckeT (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularForm.mdifferentiable_heckeT {f : UpperHalfPlane → ℂ}
+    (hf : MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) f) (k : ℤ) (p : ℕ) :
+    MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) (ModularForm.heckeT k p f)
+      :=
+  solution hf k p
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_mdifferentiable_heckeU.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_mdifferentiable_heckeU.lean
new file mode 100644
index 0000000000..5ea32c4362
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_mdifferentiable_heckeU.lean
@@ -0,0 +1,408 @@
+/-
+Based on Prove2Me node ModularForm.mdifferentiable_heckeU
+(f99d76db-114b-59c2-856b-577cdfd4ee73) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d46f4ba4-df1d-5def-b9d9-154ff2b7bd8c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.CStarAlgebra.Classes
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Manifold
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Holomorphy of Uₚ f on the upper half-plane
+
+Theorem statement: `ModularForm.mdifferentiable_heckeU` (`f99d76db-114b-59c2-856b-577cdfd4ee73`), by
+Claude, 2026-09-05.
+
+Proof: submission `d46f4ba4-df1d-5def-b9d9-154ff2b7bd8c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $f : \mathbb{H} \to \mathbb{C}$ be a function on the upper half-plane which is differentiable in
+the sense of the manifold structure on $\mathbb{H}$ and on $\mathbb{C}$ given by the trivial model
+with corners of $\mathbb{C}$ over itself, i.e. holomorphic on $\mathbb{H}$. Let $k$ be an integer
+and $p$ a natural number. The assertion is that the function $\mathrm{heckeU}\ k\ p\ f$, namely the
+finite sum
+$$\sum_{j=0}^{p-1} f \mid_{k} M_{p,j},$$
+where $\mid_{k}$ denotes the weight-$k$ slash action of $\mathrm{GL}_2(\mathbb{R})$ and $M_{p,j} \in
+\mathrm{GL}_2(\mathbb{R})$ is the upper triangular matrix with diagonal entries $1, p$ and upper
+right entry $j$ (with the convention that $M_{0,j}$ is the identity, a case in which the sum is
+empty in any event), is again differentiable for the same model with corners on source and target,
+i.e. holomorphic on $\mathbb{H}$.
+
+This records that the operator $U_p$, formed from the slash action of the matrices $\begin{pmatrix}
+1 & j \\ 0 & p\end{pmatrix}$ for $0 \le j < p$, preserves holomorphy on the upper half-plane; it is
+the analytic half of the construction of $U_p$ as an operator on modular and cusp forms. It is used
+throughout the study of $U_p$-eigenforms, in particular in the level-lowering and degeneracy-map
+computations relating $U_p$-eigenvalues to $q$-expansion coefficients.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_mdifferentiable_heckeU.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_ModularForm_mdifferentiable_heckeU
+
+noncomputable section
+
+open Complex Function Filter
+p2m_open "UpperHalfPlane~I"
+open scoped Real MatrixGroups ModularForm Manifold Topology
+
+namespace M4cP1W2
+
+open ModularForm ModularFormClass
+
+section Matrices
+
+variable (p j : ℕ)
+
+theorem heckeMatrix_one_zero :
+    ((heckeMatrix p j : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) 1 0 = 0 := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  · rw [val_heckeMatrix hp]; rfl
+
+theorem heckeDiagMatrix_one_zero :
+    ((heckeDiagMatrix p : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) 1 0 = 0 := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  · rw [val_heckeDiagMatrix hp]; rfl
+
+end Matrices
+
+section Regularity
+
+variable {f : ℍ → ℂ} (k : ℤ) (p : ℕ)
+
+theorem mdifferentiable_heckeU (hf : MDiff f) : MDiff (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => MDiff g) (fun _ _ ha hb => ha.add hb)
+    mdifferentiable_const (fun _ _ => hf.slash k _)
+
+theorem mdifferentiable_heckeT (hf : MDiff f) : MDiff (heckeT k p f) :=
+  (mdifferentiable_heckeU k p hf).add (hf.slash k _)
+
+theorem isBoundedAtImInfty_heckeU (hf : IsBoundedAtImInfty f) :
+    IsBoundedAtImInfty (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => IsBoundedAtImInfty g)
+    (fun _ _ ha hb => ha.add hb) UpperHalfPlane.zero_form_isBoundedAtImInfty
+    (fun j _ => hf.slash k (heckeMatrix_one_zero p j))
+
+theorem isBoundedAtImInfty_heckeT (hf : IsBoundedAtImInfty f) :
+    IsBoundedAtImInfty (heckeT k p f) :=
+  (isBoundedAtImInfty_heckeU k p hf).add (hf.slash k (heckeDiagMatrix_one_zero p))
+
+theorem isZeroAtImInfty_heckeU (hf : IsZeroAtImInfty f) :
+    IsZeroAtImInfty (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => IsZeroAtImInfty g)
+    (fun _ _ ha hb => ha.add hb) (zero_zeroAtFilter atImInfty)
+    (fun j _ => hf.slash k (heckeMatrix_one_zero p j))
+
+theorem isZeroAtImInfty_heckeT (hf : IsZeroAtImInfty f) :
+    IsZeroAtImInfty (heckeT k p f) :=
+  (isZeroAtImInfty_heckeU k p hf).add (hf.slash k (heckeDiagMatrix_one_zero p))
+
+theorem apply_eq_of_coe_eq_add_nat (hf : Periodic (f ∘ ofComplex) 1) {τ₁ τ₂ : ℍ} (m : ℕ)
+    (h : (τ₁ : ℂ) = τ₂ + m) : f τ₁ = f τ₂ := by
+  have h1 : (f ∘ ofComplex) ((τ₂ : ℂ) + m) = (f ∘ ofComplex) (τ₂ : ℂ) := by
+    have := hf.nat_mul m
+    rw [mul_one] at this
+    exact this (τ₂ : ℂ)
+  simp only [comp_apply] at h1
+  rw [← h, ofComplex_apply, ofComplex_apply] at h1
+  exact h1
+
+variable {p} in
+theorem heckeMatrix_smul_vadd (hp : p ≠ 0) (j : ℕ) (τ : ℍ) :
+    heckeMatrix p j • ((1 : ℝ) +ᵥ τ) = heckeMatrix p (j + 1) • τ := by
+  apply UpperHalfPlane.ext
+  rw [coe_heckeMatrix_smul hp, coe_heckeMatrix_smul hp, coe_vadd]
+  push_cast
+  ring
+
+variable {p} in
+theorem coe_heckeMatrix_smul_self (hp : p ≠ 0) (τ : ℍ) :
+    ((heckeMatrix p p • τ : ℍ) : ℂ) = (heckeMatrix p 0 • τ : ℍ) + (1 : ℕ) := by
+  have hp' : (p : ℂ) ≠ 0 := by exact_mod_cast hp
+  rw [coe_heckeMatrix_smul hp, coe_heckeMatrix_smul hp]
+  field_simp
+  push_cast
+  ring
+
+variable {p} in
+theorem coe_heckeDiagMatrix_smul_vadd (hp : p ≠ 0) (τ : ℍ) :
+    ((heckeDiagMatrix p • ((1 : ℝ) +ᵥ τ) : ℍ) : ℂ) = (heckeDiagMatrix p • τ : ℍ) + (p : ℕ) := by
+  rw [coe_heckeDiagMatrix_smul hp, coe_heckeDiagMatrix_smul hp, coe_vadd]
+  push_cast
+  ring
+
+variable {p} in
+theorem sum_heckeMatrix_smul_vadd (hp : p ≠ 0) (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    ∑ j ∈ Finset.range p, f (heckeMatrix p j • ((1 : ℝ) +ᵥ τ))
+      = ∑ j ∈ Finset.range p, f (heckeMatrix p j • τ) := by
+  simp only [heckeMatrix_smul_vadd hp]
+  have h0 := Finset.sum_range_succ' (fun j => f (heckeMatrix p j • τ)) p
+  have h1 := Finset.sum_range_succ (fun j => f (heckeMatrix p j • τ)) p
+  rw [apply_eq_of_coe_eq_add_nat hf 1 (coe_heckeMatrix_smul_self hp τ)] at h1
+  exact add_right_cancel (h0.symm.trans h1)
+
+theorem heckeU_vadd (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    heckeU k p f ((1 : ℝ) +ᵥ τ) = heckeU k p f τ := by
+  by_cases hp : p = 0
+  · simp only [hp, heckeU_zero_left, Pi.zero_apply]
+  · rw [heckeU_apply k hp, heckeU_apply k hp, sum_heckeMatrix_smul_vadd hp hf]
+
+theorem heckeT_vadd (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    heckeT k p f ((1 : ℝ) +ᵥ τ) = heckeT k p f τ := by
+  by_cases hp : p = 0
+  · simp only [hp, heckeT_zero_left]
+    exact apply_eq_of_coe_eq_add_nat hf 1 (by rw [coe_vadd]; push_cast; ring)
+  · rw [heckeT_apply k hp, heckeT_apply k hp, sum_heckeMatrix_smul_vadd hp hf,
+      apply_eq_of_coe_eq_add_nat hf p (coe_heckeDiagMatrix_smul_vadd hp τ)]
+
+theorem periodic_comp_ofComplex_of_vadd {g : ℍ → ℂ} (hg : ∀ τ : ℍ, g ((1 : ℝ) +ᵥ τ) = g τ) :
+    Periodic (g ∘ ofComplex) 1 := by
+  intro w
+  by_cases hw : 0 < im w
+  · have hw' : 0 < im (w + 1) := by simp [hw]
+    simp only [comp_apply, ofComplex_apply_of_im_pos hw', ofComplex_apply_of_im_pos hw]
+    convert hg ⟨w, hw⟩ using 2
+    apply UpperHalfPlane.ext
+    simp [add_comm]
+  · have hw1 : im (w + 1) ≤ 0 := by simpa using hw
+    have hw0 : im w ≤ 0 := not_lt.mp hw
+    simp only [comp_apply, ofComplex_apply_eq_of_im_nonpos hw1 hw0]
+
+theorem periodic_heckeU_comp_ofComplex (hf : Periodic (f ∘ ofComplex) 1) :
+    Periodic (heckeU k p f ∘ ofComplex) 1 :=
+  periodic_comp_ofComplex_of_vadd (heckeU_vadd k p hf)
+
+theorem periodic_heckeT_comp_ofComplex (hf : Periodic (f ∘ ofComplex) 1) :
+    Periodic (heckeT k p f ∘ ofComplex) 1 :=
+  periodic_comp_ofComplex_of_vadd (heckeT_vadd k p hf)
+
+end Regularity
+
+section Uniqueness
+
+theorem qExpansion_coeff_unique' {g : ℍ → ℂ} (hcont : Continuous g) {c : ℕ → ℂ}
+    (hg : AnalyticAt ℂ (cuspFunction 1 g) 0)
+    (hs : ∀ τ : ℍ, HasSum (fun m ↦ c m • Periodic.qParam 1 τ ^ m) (g τ)) (m : ℕ) :
+    c m = (qExpansion 1 g).coeff m :=
+  UpperHalfPlane.qExpansion_coeff_unique (ContinuousMap.mk g hcont) one_pos hg hs m
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+theorem hasSum_qCoeff [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) (τ : ℍ) :
+    HasSum (fun m ↦ qCoeff f m • Periodic.qParam 1 τ ^ m) (f τ) := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  exact hasSum_qExpansion one_pos (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ)
+    (holo f) (bdd_at_infty f) τ
+
+theorem eq_of_forall_qCoeff_eq [ModularFormClass F Γ k] {f g : F} (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (h : ∀ n : ℕ, qCoeff f n = qCoeff g n) : f = g := by
+  refine DFunLike.ext f g fun τ => ?_
+  have hf := hasSum_qCoeff f hΓ τ
+  have hg := hasSum_qCoeff g hΓ τ
+  simp only [h] at hf
+  exact hf.unique hg
+
+end Uniqueness
+
+section QExpAction
+
+theorem qParam_one (z : ℂ) : Periodic.qParam 1 z = exp (2 * π * I * z) := by
+  simp [Periodic.qParam]
+
+variable {p : ℕ} (hp : p ≠ 0)
+
+include hp in
+theorem natCast_ne_zero' : (p : ℂ) ≠ 0 := by exact_mod_cast hp
+
+include hp in
+theorem qParam_heckeMatrix_smul (j : ℕ) (τ : ℍ) :
+    Periodic.qParam 1 ((heckeMatrix p j • τ : ℍ) : ℂ)
+      = exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j := by
+  rw [qParam_one, coe_heckeMatrix_smul hp, ← Complex.exp_nat_mul, ← Complex.exp_add]
+  congr 1
+  have := natCast_ne_zero' hp
+  field_simp
+
+include hp in
+theorem qParam_heckeDiagMatrix_smul (τ : ℍ) :
+    Periodic.qParam 1 ((heckeDiagMatrix p • τ : ℍ) : ℂ) = Periodic.qParam 1 τ ^ p := by
+  rw [qParam_one, qParam_one, coe_heckeDiagMatrix_smul hp, ← Complex.exp_nat_mul]
+  congr 1
+  ring
+
+include hp in
+theorem exp_div_pow (τ : ℍ) : exp (2 * π * I * τ / p) ^ p = Periodic.qParam 1 τ := by
+  rw [qParam_one, ← Complex.exp_nat_mul]
+  congr 1
+  have := natCast_ne_zero' hp
+  field_simp
+
+include hp in
+theorem sum_rootOfUnity_pow (m : ℕ) :
+    ∑ j ∈ Finset.range p, (exp (2 * π * I / p) ^ j) ^ m = if p ∣ m then (p : ℂ) else 0 := by
+  have hζ := Complex.isPrimitiveRoot_exp p hp
+  have hswap : ∀ j : ℕ, (exp (2 * π * I / p) ^ j) ^ m = (exp (2 * π * I / p) ^ m) ^ j := fun j => by
+    rw [← pow_mul, ← pow_mul, Nat.mul_comm j m]
+  simp only [hswap]
+  split_ifs with h
+  · rw [(hζ.pow_eq_one_iff_dvd m).mpr h]
+    simp
+  · have hne : exp (2 * π * I / p) ^ m ≠ 1 := fun h1 => h ((hζ.pow_eq_one_iff_dvd m).mp h1)
+    rw [geom_sum_eq hne, ← pow_mul, Nat.mul_comm m p, pow_mul, hζ.pow_eq_one, one_pow, sub_self,
+      zero_div]
+
+theorem not_dvd_of_not_mem_range {m : ℕ} (hm : m ∉ Set.range (fun l : ℕ ↦ l * p)) : ¬ p ∣ m := by
+  rintro ⟨l, rfl⟩
+  exact hm ⟨l, by simp [mul_comm]⟩
+
+variable {f : ℍ → ℂ} (hper : Periodic (f ∘ ofComplex) 1) (hhol : MDiff f)
+  (hbdd : IsBoundedAtImInfty f)
+
+include hp hper hhol hbdd in
+theorem hasSum_average (τ : ℍ) :
+    HasSum (fun l : ℕ ↦ qCoeff f (l * p) * Periodic.qParam 1 τ ^ l)
+      ((p : ℂ)⁻¹ * ∑ j ∈ Finset.range p, f (heckeMatrix p j • τ)) := by
+  have hF : ∀ τ' : ℍ, HasSum (fun m ↦ qCoeff f m • Periodic.qParam 1 τ' ^ m) (f τ') :=
+    hasSum_qExpansion one_pos hper hhol hbdd
+  have h1 : HasSum (fun m ↦ ∑ j ∈ Finset.range p,
+      qCoeff f m • (exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j) ^ m)
+      (∑ j ∈ Finset.range p, f (heckeMatrix p j • τ)) := by
+    refine hasSum_sum fun j _ => ?_
+    have := hF (heckeMatrix p j • τ)
+    rwa [qParam_heckeMatrix_smul hp j τ] at this
+  have h2 : (fun m ↦ ∑ j ∈ Finset.range p,
+      qCoeff f m • (exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j) ^ m)
+      = fun m ↦ if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0 := by
+    funext m
+    simp only [mul_pow, smul_eq_mul, ← Finset.mul_sum, sum_rootOfUnity_pow hp m]
+    split_ifs <;> ring
+  rw [h2] at h1
+  have hinj : Function.Injective (fun l : ℕ ↦ l * p) := mul_left_injective₀ hp
+  have h3 := (hinj.hasSum_iff (f := fun m ↦
+      if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0)
+    (fun m hm => by simp [not_dvd_of_not_mem_range hm])).mpr h1
+  have h4 : ((fun m ↦ if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0) ∘
+      fun l : ℕ ↦ l * p) = fun l ↦ (p : ℂ) * (qCoeff f (l * p) * Periodic.qParam 1 τ ^ l) := by
+    funext l
+    simp only [comp_apply, ite_eq_left (dvd_mul_left p l)]
+    rw [mul_comm l p, pow_mul, exp_div_pow hp τ]
+    ring
+  rw [h4] at h3
+  have h5 := h3.mul_left ((p : ℂ)⁻¹)
+  simp only [← mul_assoc, inv_mul_cancel₀ (natCast_ne_zero' hp), one_mul] at h5
+  exact h5
+
+include hp hper hhol hbdd in
+theorem hasSum_diag (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ if p ∣ n then (p : ℂ) ^ (k - 1) * qCoeff f (n / p) * Periodic.qParam 1 τ ^ n
+        else 0)
+      ((p : ℂ) ^ (k - 1) * f (heckeDiagMatrix p • τ)) := by
+  have hD := (hasSum_qExpansion one_pos hper hhol hbdd (heckeDiagMatrix p • τ)).mul_left
+    ((p : ℂ) ^ (k - 1))
+  rw [qParam_heckeDiagMatrix_smul hp τ] at hD
+  have hinj : Function.Injective (fun l : ℕ ↦ l * p) := mul_left_injective₀ hp
+  refine (hinj.hasSum_iff (fun m hm => by simp [not_dvd_of_not_mem_range hm])).mp ?_
+  convert hD using 1
+  funext l
+  simp only [comp_apply, ite_eq_left (dvd_mul_left p l), Nat.mul_div_cancel _ (Nat.pos_of_ne_zero
+    hp),
+    smul_eq_mul]
+  rw [← pow_mul, mul_comm l p, mul_assoc]
+  rfl
+
+include hp hper hhol hbdd in
+theorem hasSum_heckeU (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ coeffHeckeU p (qCoeff f) n • Periodic.qParam 1 τ ^ n) (heckeU k p f τ) := by
+  rw [heckeU_apply k hp]
+  simpa only [coeffHeckeU_apply, smul_eq_mul] using hasSum_average hp hper hhol hbdd τ
+
+include hp hper hhol hbdd in
+theorem hasSum_heckeT (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ coeffHeckeT k p (qCoeff f) n • Periodic.qParam 1 τ ^ n) (heckeT k p f τ) :=
+      by
+  rw [heckeT_apply k hp]
+  convert (hasSum_average hp hper hhol hbdd τ).add (hasSum_diag hp hper hhol hbdd k τ) using 1
+  funext n
+  rw [coeffHeckeT_apply, smul_eq_mul]
+  split_ifs <;> ring
+
+include hp hper hhol hbdd in
+theorem qCoeff_heckeU_bare (k : ℤ) (n : ℕ) :
+    qCoeff (heckeU k p f) n = coeffHeckeU p (qCoeff f) n :=
+  (qExpansion_coeff_unique' (mdifferentiable_heckeU k p hhol).continuous
+    (analyticAt_cuspFunction_zero one_pos (periodic_heckeU_comp_ofComplex k p hper)
+      (mdifferentiable_heckeU k p hhol) (isBoundedAtImInfty_heckeU k p hbdd))
+    (hasSum_heckeU hp hper hhol hbdd k) n).symm
+
+include hp hper hhol hbdd in
+theorem qCoeff_heckeT_bare (k : ℤ) (n : ℕ) :
+    qCoeff (heckeT k p f) n = coeffHeckeT k p (qCoeff f) n :=
+  (qExpansion_coeff_unique' (mdifferentiable_heckeT k p hhol).continuous
+    (analyticAt_cuspFunction_zero one_pos (periodic_heckeT_comp_ofComplex k p hper)
+      (mdifferentiable_heckeT k p hhol) (isBoundedAtImInfty_heckeT k p hbdd))
+    (hasSum_heckeT hp hper hhol hbdd k) n).symm
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+include hp in
+theorem qCoeff_heckeU_class [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (n : ℕ) : qCoeff (heckeU k p f) n = coeffHeckeU p (qCoeff f) n :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  qCoeff_heckeU_bare hp (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (holo f)
+    (bdd_at_infty f) k n
+
+include hp in
+theorem qCoeff_heckeT_class [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (n : ℕ) : qCoeff (heckeT k p f) n = coeffHeckeT k p (qCoeff f) n :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  qCoeff_heckeT_bare hp (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (holo f)
+    (bdd_at_infty f) k n
+
+end QExpAction
+
+end M4cP1W2
+
+end
+
+theorem solution {f : UpperHalfPlane → ℂ}
+    (hf : MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) f) (k : ℤ) (p : ℕ) :
+    MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) (ModularForm.heckeU k p f)
+      :=
+  M4cP1W2.mdifferentiable_heckeU k p hf
+
+end S_ModularForm_mdifferentiable_heckeU
+end P2MW
+export P2MW.S_ModularForm_mdifferentiable_heckeU (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularForm.mdifferentiable_heckeU {f : UpperHalfPlane → ℂ}
+    (hf : MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) f) (k : ℤ) (p : ℕ) :
+    MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) (ModularForm.heckeU k p f)
+      :=
+  solution hf k p
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_periodic_heckeT_comp_ofComplex.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_periodic_heckeT_comp_ofComplex.lean
new file mode 100644
index 0000000000..3ac0a623f2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_periodic_heckeT_comp_ofComplex.lean
@@ -0,0 +1,408 @@
+/-
+Based on Prove2Me node ModularForm.periodic_heckeT_comp_ofComplex
+(10e2ffea-bcda-51ed-91d1-cd13ab4c5c96) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 55cf07e7-6c40-596d-81e3-2b589390d345
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Topology
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# 1-periodicity of Tₚ f
+
+Theorem statement: `ModularForm.periodic_heckeT_comp_ofComplex`
+(`10e2ffea-bcda-51ed-91d1-cd13ab4c5c96`), by Claude, 2026-09-05.
+
+Proof: submission `55cf07e7-6c40-596d-81e3-2b589390d345`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $f \colon \mathbb{H} \to \mathbb{C}$ be any function on the upper half plane, let $k \in
+\mathbb{Z}$ and let $p \in \mathbb{N}$. The hypothesis is that the composite of $f$ with Mathlib's
+map `UpperHalfPlane.ofComplex` (which retracts $\mathbb{C}$ onto $\mathbb{H}$, sending points off
+the upper half plane to a fixed junk value) is periodic with period $1$ as a function on
+$\mathbb{C}$, i.e. $f(\mathrm{ofComplex}(z+1)) = f(\mathrm{ofComplex}(z))$ for all $z \in
+\mathbb{C}$; on $\mathbb{H}$ this is the usual invariance $f(\tau+1)=f(\tau)$. The conclusion is
+that $\mathrm{heckeT}\,k\,p\,f$ composed with `UpperHalfPlane.ofComplex` is again $1$-periodic. Here
+$\mathrm{heckeT}\,k\,p\,f = \mathrm{heckeU}\,k\,p\,f + f \mid[k] \mathrm{heckeDiagMatrix}\,p$, where
+$\mathrm{heckeU}\,k\,p\,f = \sum_{j \in \mathrm{range}\,p} f\mid[k] \mathrm{heckeMatrix}\,p\,j$ is
+the sum of the weight-$k$ slash actions of the elements `heckeMatrix p j` of
+$\mathrm{GL}_2(\mathbb{R})$ for $j < p$, and $\mathrm{heckeDiagMatrix}\,p$ is the identity if $p =
+0$ and otherwise the upper-triangular element `upperTriangularGL p 0 1`, i.e. $\mathrm{diag}(p,1)$.
+No hypothesis on $f$ beyond periodicity is imposed: it need not be holomorphic or modular of any
+level, and $p$ need not be prime or nonzero.
+
+This is the elementary compatibility of the Hecke operator $T_p$, taken here as an operator on
+arbitrary functions on $\mathbb{H}$, with translation by $1$; it is what allows $T_p f$ to be given
+a $q$-expansion whenever $f$ has one. It is used in the statements relating the $q$-expansion
+coefficients of $U_p f + f\mid[k]\mathrm{heckeDiagMatrix}\,p$ to those of $f$, and in the eigenform
+criterion [`ModularFormClass.heckeT_eq_smul_iff`](thm.html#ModularFormClass.heckeT_eq_smul_iff).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_periodic_heckeT_comp_ofComplex.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_ModularForm_periodic_heckeT_comp_ofComplex
+
+noncomputable section
+
+open Complex Function Filter
+p2m_open "UpperHalfPlane~I"
+open scoped Real MatrixGroups ModularForm Manifold Topology
+
+namespace M4cP1W2
+
+open ModularForm ModularFormClass
+
+section Matrices
+
+variable (p j : ℕ)
+
+theorem heckeMatrix_one_zero :
+    ((heckeMatrix p j : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) 1 0 = 0 := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  · rw [val_heckeMatrix hp]; rfl
+
+theorem heckeDiagMatrix_one_zero :
+    ((heckeDiagMatrix p : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) 1 0 = 0 := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  · rw [val_heckeDiagMatrix hp]; rfl
+
+end Matrices
+
+section Regularity
+
+variable {f : ℍ → ℂ} (k : ℤ) (p : ℕ)
+
+theorem mdifferentiable_heckeU (hf : MDiff f) : MDiff (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => MDiff g) (fun _ _ ha hb => ha.add hb)
+    mdifferentiable_const (fun _ _ => hf.slash k _)
+
+theorem mdifferentiable_heckeT (hf : MDiff f) : MDiff (heckeT k p f) :=
+  (mdifferentiable_heckeU k p hf).add (hf.slash k _)
+
+theorem isBoundedAtImInfty_heckeU (hf : IsBoundedAtImInfty f) :
+    IsBoundedAtImInfty (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => IsBoundedAtImInfty g)
+    (fun _ _ ha hb => ha.add hb) UpperHalfPlane.zero_form_isBoundedAtImInfty
+    (fun j _ => hf.slash k (heckeMatrix_one_zero p j))
+
+theorem isBoundedAtImInfty_heckeT (hf : IsBoundedAtImInfty f) :
+    IsBoundedAtImInfty (heckeT k p f) :=
+  (isBoundedAtImInfty_heckeU k p hf).add (hf.slash k (heckeDiagMatrix_one_zero p))
+
+theorem isZeroAtImInfty_heckeU (hf : IsZeroAtImInfty f) :
+    IsZeroAtImInfty (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => IsZeroAtImInfty g)
+    (fun _ _ ha hb => ha.add hb) (zero_zeroAtFilter atImInfty)
+    (fun j _ => hf.slash k (heckeMatrix_one_zero p j))
+
+theorem isZeroAtImInfty_heckeT (hf : IsZeroAtImInfty f) :
+    IsZeroAtImInfty (heckeT k p f) :=
+  (isZeroAtImInfty_heckeU k p hf).add (hf.slash k (heckeDiagMatrix_one_zero p))
+
+theorem apply_eq_of_coe_eq_add_nat (hf : Periodic (f ∘ ofComplex) 1) {τ₁ τ₂ : ℍ} (m : ℕ)
+    (h : (τ₁ : ℂ) = τ₂ + m) : f τ₁ = f τ₂ := by
+  have h1 : (f ∘ ofComplex) ((τ₂ : ℂ) + m) = (f ∘ ofComplex) (τ₂ : ℂ) := by
+    have := hf.nat_mul m
+    rw [mul_one] at this
+    exact this (τ₂ : ℂ)
+  simp only [comp_apply] at h1
+  rw [← h, ofComplex_apply, ofComplex_apply] at h1
+  exact h1
+
+variable {p} in
+theorem heckeMatrix_smul_vadd (hp : p ≠ 0) (j : ℕ) (τ : ℍ) :
+    heckeMatrix p j • ((1 : ℝ) +ᵥ τ) = heckeMatrix p (j + 1) • τ := by
+  apply UpperHalfPlane.ext
+  rw [coe_heckeMatrix_smul hp, coe_heckeMatrix_smul hp, coe_vadd]
+  push_cast
+  ring
+
+variable {p} in
+theorem coe_heckeMatrix_smul_self (hp : p ≠ 0) (τ : ℍ) :
+    ((heckeMatrix p p • τ : ℍ) : ℂ) = (heckeMatrix p 0 • τ : ℍ) + (1 : ℕ) := by
+  have hp' : (p : ℂ) ≠ 0 := by exact_mod_cast hp
+  rw [coe_heckeMatrix_smul hp, coe_heckeMatrix_smul hp]
+  field_simp
+  push_cast
+  ring
+
+variable {p} in
+theorem coe_heckeDiagMatrix_smul_vadd (hp : p ≠ 0) (τ : ℍ) :
+    ((heckeDiagMatrix p • ((1 : ℝ) +ᵥ τ) : ℍ) : ℂ) = (heckeDiagMatrix p • τ : ℍ) + (p : ℕ) := by
+  rw [coe_heckeDiagMatrix_smul hp, coe_heckeDiagMatrix_smul hp, coe_vadd]
+  push_cast
+  ring
+
+variable {p} in
+theorem sum_heckeMatrix_smul_vadd (hp : p ≠ 0) (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    ∑ j ∈ Finset.range p, f (heckeMatrix p j • ((1 : ℝ) +ᵥ τ))
+      = ∑ j ∈ Finset.range p, f (heckeMatrix p j • τ) := by
+  simp only [heckeMatrix_smul_vadd hp]
+  have h0 := Finset.sum_range_succ' (fun j => f (heckeMatrix p j • τ)) p
+  have h1 := Finset.sum_range_succ (fun j => f (heckeMatrix p j • τ)) p
+  rw [apply_eq_of_coe_eq_add_nat hf 1 (coe_heckeMatrix_smul_self hp τ)] at h1
+  exact add_right_cancel (h0.symm.trans h1)
+
+theorem heckeU_vadd (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    heckeU k p f ((1 : ℝ) +ᵥ τ) = heckeU k p f τ := by
+  by_cases hp : p = 0
+  · simp only [hp, heckeU_zero_left, Pi.zero_apply]
+  · rw [heckeU_apply k hp, heckeU_apply k hp, sum_heckeMatrix_smul_vadd hp hf]
+
+theorem heckeT_vadd (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    heckeT k p f ((1 : ℝ) +ᵥ τ) = heckeT k p f τ := by
+  by_cases hp : p = 0
+  · simp only [hp, heckeT_zero_left]
+    exact apply_eq_of_coe_eq_add_nat hf 1 (by rw [coe_vadd]; push_cast; ring)
+  · rw [heckeT_apply k hp, heckeT_apply k hp, sum_heckeMatrix_smul_vadd hp hf,
+      apply_eq_of_coe_eq_add_nat hf p (coe_heckeDiagMatrix_smul_vadd hp τ)]
+
+theorem periodic_comp_ofComplex_of_vadd {g : ℍ → ℂ} (hg : ∀ τ : ℍ, g ((1 : ℝ) +ᵥ τ) = g τ) :
+    Periodic (g ∘ ofComplex) 1 := by
+  intro w
+  by_cases hw : 0 < im w
+  · have hw' : 0 < im (w + 1) := by simp [hw]
+    simp only [comp_apply, ofComplex_apply_of_im_pos hw', ofComplex_apply_of_im_pos hw]
+    convert hg ⟨w, hw⟩ using 2
+    apply UpperHalfPlane.ext
+    simp [add_comm]
+  · have hw1 : im (w + 1) ≤ 0 := by simpa using hw
+    have hw0 : im w ≤ 0 := not_lt.mp hw
+    simp only [comp_apply, ofComplex_apply_eq_of_im_nonpos hw1 hw0]
+
+theorem periodic_heckeU_comp_ofComplex (hf : Periodic (f ∘ ofComplex) 1) :
+    Periodic (heckeU k p f ∘ ofComplex) 1 :=
+  periodic_comp_ofComplex_of_vadd (heckeU_vadd k p hf)
+
+theorem periodic_heckeT_comp_ofComplex (hf : Periodic (f ∘ ofComplex) 1) :
+    Periodic (heckeT k p f ∘ ofComplex) 1 :=
+  periodic_comp_ofComplex_of_vadd (heckeT_vadd k p hf)
+
+end Regularity
+
+section Uniqueness
+
+theorem qExpansion_coeff_unique' {g : ℍ → ℂ} (hcont : Continuous g) {c : ℕ → ℂ}
+    (hg : AnalyticAt ℂ (cuspFunction 1 g) 0)
+    (hs : ∀ τ : ℍ, HasSum (fun m ↦ c m • Periodic.qParam 1 τ ^ m) (g τ)) (m : ℕ) :
+    c m = (qExpansion 1 g).coeff m :=
+  UpperHalfPlane.qExpansion_coeff_unique (ContinuousMap.mk g hcont) one_pos hg hs m
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+theorem hasSum_qCoeff [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) (τ : ℍ) :
+    HasSum (fun m ↦ qCoeff f m • Periodic.qParam 1 τ ^ m) (f τ) := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  exact hasSum_qExpansion one_pos (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ)
+    (holo f) (bdd_at_infty f) τ
+
+theorem eq_of_forall_qCoeff_eq [ModularFormClass F Γ k] {f g : F} (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (h : ∀ n : ℕ, qCoeff f n = qCoeff g n) : f = g := by
+  refine DFunLike.ext f g fun τ => ?_
+  have hf := hasSum_qCoeff f hΓ τ
+  have hg := hasSum_qCoeff g hΓ τ
+  simp only [h] at hf
+  exact hf.unique hg
+
+end Uniqueness
+
+section QExpAction
+
+theorem qParam_one (z : ℂ) : Periodic.qParam 1 z = exp (2 * π * I * z) := by
+  simp [Periodic.qParam]
+
+variable {p : ℕ} (hp : p ≠ 0)
+
+include hp in
+theorem natCast_ne_zero' : (p : ℂ) ≠ 0 := by exact_mod_cast hp
+
+include hp in
+theorem qParam_heckeMatrix_smul (j : ℕ) (τ : ℍ) :
+    Periodic.qParam 1 ((heckeMatrix p j • τ : ℍ) : ℂ)
+      = exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j := by
+  rw [qParam_one, coe_heckeMatrix_smul hp, ← Complex.exp_nat_mul, ← Complex.exp_add]
+  congr 1
+  have := natCast_ne_zero' hp
+  field_simp
+
+include hp in
+theorem qParam_heckeDiagMatrix_smul (τ : ℍ) :
+    Periodic.qParam 1 ((heckeDiagMatrix p • τ : ℍ) : ℂ) = Periodic.qParam 1 τ ^ p := by
+  rw [qParam_one, qParam_one, coe_heckeDiagMatrix_smul hp, ← Complex.exp_nat_mul]
+  congr 1
+  ring
+
+include hp in
+theorem exp_div_pow (τ : ℍ) : exp (2 * π * I * τ / p) ^ p = Periodic.qParam 1 τ := by
+  rw [qParam_one, ← Complex.exp_nat_mul]
+  congr 1
+  have := natCast_ne_zero' hp
+  field_simp
+
+include hp in
+theorem sum_rootOfUnity_pow (m : ℕ) :
+    ∑ j ∈ Finset.range p, (exp (2 * π * I / p) ^ j) ^ m = if p ∣ m then (p : ℂ) else 0 := by
+  have hζ := Complex.isPrimitiveRoot_exp p hp
+  have hswap : ∀ j : ℕ, (exp (2 * π * I / p) ^ j) ^ m = (exp (2 * π * I / p) ^ m) ^ j := fun j => by
+    rw [← pow_mul, ← pow_mul, Nat.mul_comm j m]
+  simp only [hswap]
+  split_ifs with h
+  · rw [(hζ.pow_eq_one_iff_dvd m).mpr h]
+    simp
+  · have hne : exp (2 * π * I / p) ^ m ≠ 1 := fun h1 => h ((hζ.pow_eq_one_iff_dvd m).mp h1)
+    rw [geom_sum_eq hne, ← pow_mul, Nat.mul_comm m p, pow_mul, hζ.pow_eq_one, one_pow, sub_self,
+      zero_div]
+
+theorem not_dvd_of_not_mem_range {m : ℕ} (hm : m ∉ Set.range (fun l : ℕ ↦ l * p)) : ¬ p ∣ m := by
+  rintro ⟨l, rfl⟩
+  exact hm ⟨l, by simp [mul_comm]⟩
+
+variable {f : ℍ → ℂ} (hper : Periodic (f ∘ ofComplex) 1) (hhol : MDiff f)
+  (hbdd : IsBoundedAtImInfty f)
+
+include hp hper hhol hbdd in
+theorem hasSum_average (τ : ℍ) :
+    HasSum (fun l : ℕ ↦ qCoeff f (l * p) * Periodic.qParam 1 τ ^ l)
+      ((p : ℂ)⁻¹ * ∑ j ∈ Finset.range p, f (heckeMatrix p j • τ)) := by
+  have hF : ∀ τ' : ℍ, HasSum (fun m ↦ qCoeff f m • Periodic.qParam 1 τ' ^ m) (f τ') :=
+    hasSum_qExpansion one_pos hper hhol hbdd
+  have h1 : HasSum (fun m ↦ ∑ j ∈ Finset.range p,
+      qCoeff f m • (exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j) ^ m)
+      (∑ j ∈ Finset.range p, f (heckeMatrix p j • τ)) := by
+    refine hasSum_sum fun j _ => ?_
+    have := hF (heckeMatrix p j • τ)
+    rwa [qParam_heckeMatrix_smul hp j τ] at this
+  have h2 : (fun m ↦ ∑ j ∈ Finset.range p,
+      qCoeff f m • (exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j) ^ m)
+      = fun m ↦ if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0 := by
+    funext m
+    simp only [mul_pow, smul_eq_mul, ← Finset.mul_sum, sum_rootOfUnity_pow hp m]
+    split_ifs <;> ring
+  rw [h2] at h1
+  have hinj : Function.Injective (fun l : ℕ ↦ l * p) := mul_left_injective₀ hp
+  have h3 := (hinj.hasSum_iff (f := fun m ↦
+      if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0)
+    (fun m hm => by simp [not_dvd_of_not_mem_range hm])).mpr h1
+  have h4 : ((fun m ↦ if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0) ∘
+      fun l : ℕ ↦ l * p) = fun l ↦ (p : ℂ) * (qCoeff f (l * p) * Periodic.qParam 1 τ ^ l) := by
+    funext l
+    simp only [comp_apply, ite_eq_left (dvd_mul_left p l)]
+    rw [mul_comm l p, pow_mul, exp_div_pow hp τ]
+    ring
+  rw [h4] at h3
+  have h5 := h3.mul_left ((p : ℂ)⁻¹)
+  simp only [← mul_assoc, inv_mul_cancel₀ (natCast_ne_zero' hp), one_mul] at h5
+  exact h5
+
+include hp hper hhol hbdd in
+theorem hasSum_diag (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ if p ∣ n then (p : ℂ) ^ (k - 1) * qCoeff f (n / p) * Periodic.qParam 1 τ ^ n
+        else 0)
+      ((p : ℂ) ^ (k - 1) * f (heckeDiagMatrix p • τ)) := by
+  have hD := (hasSum_qExpansion one_pos hper hhol hbdd (heckeDiagMatrix p • τ)).mul_left
+    ((p : ℂ) ^ (k - 1))
+  rw [qParam_heckeDiagMatrix_smul hp τ] at hD
+  have hinj : Function.Injective (fun l : ℕ ↦ l * p) := mul_left_injective₀ hp
+  refine (hinj.hasSum_iff (fun m hm => by simp [not_dvd_of_not_mem_range hm])).mp ?_
+  convert hD using 1
+  funext l
+  simp only [comp_apply, ite_eq_left (dvd_mul_left p l), Nat.mul_div_cancel _ (Nat.pos_of_ne_zero
+    hp),
+    smul_eq_mul]
+  rw [← pow_mul, mul_comm l p, mul_assoc]
+  rfl
+
+include hp hper hhol hbdd in
+theorem hasSum_heckeU (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ coeffHeckeU p (qCoeff f) n • Periodic.qParam 1 τ ^ n) (heckeU k p f τ) := by
+  rw [heckeU_apply k hp]
+  simpa only [coeffHeckeU_apply, smul_eq_mul] using hasSum_average hp hper hhol hbdd τ
+
+include hp hper hhol hbdd in
+theorem hasSum_heckeT (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ coeffHeckeT k p (qCoeff f) n • Periodic.qParam 1 τ ^ n) (heckeT k p f τ) :=
+      by
+  rw [heckeT_apply k hp]
+  convert (hasSum_average hp hper hhol hbdd τ).add (hasSum_diag hp hper hhol hbdd k τ) using 1
+  funext n
+  rw [coeffHeckeT_apply, smul_eq_mul]
+  split_ifs <;> ring
+
+include hp hper hhol hbdd in
+theorem qCoeff_heckeU_bare (k : ℤ) (n : ℕ) :
+    qCoeff (heckeU k p f) n = coeffHeckeU p (qCoeff f) n :=
+  (qExpansion_coeff_unique' (mdifferentiable_heckeU k p hhol).continuous
+    (analyticAt_cuspFunction_zero one_pos (periodic_heckeU_comp_ofComplex k p hper)
+      (mdifferentiable_heckeU k p hhol) (isBoundedAtImInfty_heckeU k p hbdd))
+    (hasSum_heckeU hp hper hhol hbdd k) n).symm
+
+include hp hper hhol hbdd in
+theorem qCoeff_heckeT_bare (k : ℤ) (n : ℕ) :
+    qCoeff (heckeT k p f) n = coeffHeckeT k p (qCoeff f) n :=
+  (qExpansion_coeff_unique' (mdifferentiable_heckeT k p hhol).continuous
+    (analyticAt_cuspFunction_zero one_pos (periodic_heckeT_comp_ofComplex k p hper)
+      (mdifferentiable_heckeT k p hhol) (isBoundedAtImInfty_heckeT k p hbdd))
+    (hasSum_heckeT hp hper hhol hbdd k) n).symm
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+include hp in
+theorem qCoeff_heckeU_class [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (n : ℕ) : qCoeff (heckeU k p f) n = coeffHeckeU p (qCoeff f) n :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  qCoeff_heckeU_bare hp (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (holo f)
+    (bdd_at_infty f) k n
+
+include hp in
+theorem qCoeff_heckeT_class [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (n : ℕ) : qCoeff (heckeT k p f) n = coeffHeckeT k p (qCoeff f) n :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  qCoeff_heckeT_bare hp (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (holo f)
+    (bdd_at_infty f) k n
+
+end QExpAction
+
+end M4cP1W2
+
+end
+
+theorem solution {f : UpperHalfPlane → ℂ} (hf : Function.Periodic (f ∘ UpperHalfPlane.ofComplex) 1)
+    (k : ℤ) (p : ℕ) :
+    Function.Periodic (ModularForm.heckeT k p f ∘ UpperHalfPlane.ofComplex) 1 :=
+  M4cP1W2.periodic_heckeT_comp_ofComplex k p hf
+
+end S_ModularForm_periodic_heckeT_comp_ofComplex
+end P2MW
+export P2MW.S_ModularForm_periodic_heckeT_comp_ofComplex (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularForm.periodic_heckeT_comp_ofComplex {f : UpperHalfPlane → ℂ}
+    (hf : Function.Periodic (f ∘ UpperHalfPlane.ofComplex) 1) (k : ℤ) (p : ℕ) :
+    Function.Periodic (ModularForm.heckeT k p f ∘ UpperHalfPlane.ofComplex) 1 :=
+  solution hf k p
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_periodic_heckeU_comp_ofComplex.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_periodic_heckeU_comp_ofComplex.lean
new file mode 100644
index 0000000000..3e51f228f0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_periodic_heckeU_comp_ofComplex.lean
@@ -0,0 +1,408 @@
+/-
+Based on Prove2Me node ModularForm.periodic_heckeU_comp_ofComplex
+(5711f1c3-c1eb-5781-a87e-76c555cbbcc3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1fe09704-7eb8-5014-8f2a-a1dbc6bedd21
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Topology
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Uₚ preserves 1-periodicity
+
+Theorem statement: `ModularForm.periodic_heckeU_comp_ofComplex`
+(`5711f1c3-c1eb-5781-a87e-76c555cbbcc3`), by Claude, 2026-09-05.
+
+Proof: submission `1fe09704-7eb8-5014-8f2a-a1dbc6bedd21`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $f : \mathbb{H} \to \mathbb{C}$ be any function on the upper half plane, $k$ an integer and $p$
+a natural number. Write $g \mapsto g \circ$ `UpperHalfPlane.ofComplex` for precomposition with the
+retraction $\mathbb{C} \to \mathbb{H}$ which is the identity on points of positive imaginary part
+and takes a fixed value elsewhere, so that $f \circ$ `ofComplex` is a function $\mathbb{C} \to
+\mathbb{C}$. The hypothesis is that $f \circ$ `ofComplex` is periodic with period $1$, i.e.
+$f(\mathrm{ofComplex}(z+1)) = f(\mathrm{ofComplex}(z))$ for all $z \in \mathbb{C}$. The conclusion
+is that [`ModularForm.heckeU k p f`](def/ModularForm_HeckeOperator.html#L93) $\circ$ `ofComplex` is
+again periodic with period $1$. Here [`ModularForm.heckeU k p
+f`](def/ModularForm_HeckeOperator.html#L93) is the finite sum $\sum_{j < p} f \mid[k] \,$
+`heckeMatrix p j` of weight-$k$ slash transforms, where `heckeMatrix p j` is the identity of
+$\mathrm{GL}_2(\mathbb{R})$ when $p = 0$ and otherwise the upper triangular matrix with rows $(1,
+j)$ and $(0, p)$; thus for $p \ge 1$ the value at $\tau$ is, up to the determinant and cocycle
+factors built into the slash action, $\sum_{j=0}^{p-1} f((\tau+j)/p)$, and for $p = 0$ the sum is
+empty. No modularity or holomorphy of $f$ is assumed.
+
+This is the elementary stability statement that the Hecke operator $U_p$, defined by the matrices
+$\begin{pmatrix}1&j\\0&p\end{pmatrix}$, sends $1$-periodic functions to $1$-periodic functions, the
+shift $j \mapsto j+1$ permuting the summands modulo $p$. It is what allows $U_p f$ to be given a
+$q$-expansion, and it is used throughout the analysis of eigenforms and their $q$-expansion
+coefficients in the level-lowering part of the argument.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_periodic_heckeU_comp_ofComplex.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_ModularForm_periodic_heckeU_comp_ofComplex
+
+noncomputable section
+
+open Complex Function Filter
+p2m_open "UpperHalfPlane~I"
+open scoped Real MatrixGroups ModularForm Manifold Topology
+
+namespace M4cP1W2
+
+open ModularForm ModularFormClass
+
+section Matrices
+
+variable (p j : ℕ)
+
+theorem heckeMatrix_one_zero :
+    ((heckeMatrix p j : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) 1 0 = 0 := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  · rw [val_heckeMatrix hp]; rfl
+
+theorem heckeDiagMatrix_one_zero :
+    ((heckeDiagMatrix p : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) 1 0 = 0 := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  · rw [val_heckeDiagMatrix hp]; rfl
+
+end Matrices
+
+section Regularity
+
+variable {f : ℍ → ℂ} (k : ℤ) (p : ℕ)
+
+theorem mdifferentiable_heckeU (hf : MDiff f) : MDiff (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => MDiff g) (fun _ _ ha hb => ha.add hb)
+    mdifferentiable_const (fun _ _ => hf.slash k _)
+
+theorem mdifferentiable_heckeT (hf : MDiff f) : MDiff (heckeT k p f) :=
+  (mdifferentiable_heckeU k p hf).add (hf.slash k _)
+
+theorem isBoundedAtImInfty_heckeU (hf : IsBoundedAtImInfty f) :
+    IsBoundedAtImInfty (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => IsBoundedAtImInfty g)
+    (fun _ _ ha hb => ha.add hb) UpperHalfPlane.zero_form_isBoundedAtImInfty
+    (fun j _ => hf.slash k (heckeMatrix_one_zero p j))
+
+theorem isBoundedAtImInfty_heckeT (hf : IsBoundedAtImInfty f) :
+    IsBoundedAtImInfty (heckeT k p f) :=
+  (isBoundedAtImInfty_heckeU k p hf).add (hf.slash k (heckeDiagMatrix_one_zero p))
+
+theorem isZeroAtImInfty_heckeU (hf : IsZeroAtImInfty f) :
+    IsZeroAtImInfty (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => IsZeroAtImInfty g)
+    (fun _ _ ha hb => ha.add hb) (zero_zeroAtFilter atImInfty)
+    (fun j _ => hf.slash k (heckeMatrix_one_zero p j))
+
+theorem isZeroAtImInfty_heckeT (hf : IsZeroAtImInfty f) :
+    IsZeroAtImInfty (heckeT k p f) :=
+  (isZeroAtImInfty_heckeU k p hf).add (hf.slash k (heckeDiagMatrix_one_zero p))
+
+theorem apply_eq_of_coe_eq_add_nat (hf : Periodic (f ∘ ofComplex) 1) {τ₁ τ₂ : ℍ} (m : ℕ)
+    (h : (τ₁ : ℂ) = τ₂ + m) : f τ₁ = f τ₂ := by
+  have h1 : (f ∘ ofComplex) ((τ₂ : ℂ) + m) = (f ∘ ofComplex) (τ₂ : ℂ) := by
+    have := hf.nat_mul m
+    rw [mul_one] at this
+    exact this (τ₂ : ℂ)
+  simp only [comp_apply] at h1
+  rw [← h, ofComplex_apply, ofComplex_apply] at h1
+  exact h1
+
+variable {p} in
+theorem heckeMatrix_smul_vadd (hp : p ≠ 0) (j : ℕ) (τ : ℍ) :
+    heckeMatrix p j • ((1 : ℝ) +ᵥ τ) = heckeMatrix p (j + 1) • τ := by
+  apply UpperHalfPlane.ext
+  rw [coe_heckeMatrix_smul hp, coe_heckeMatrix_smul hp, coe_vadd]
+  push_cast
+  ring
+
+variable {p} in
+theorem coe_heckeMatrix_smul_self (hp : p ≠ 0) (τ : ℍ) :
+    ((heckeMatrix p p • τ : ℍ) : ℂ) = (heckeMatrix p 0 • τ : ℍ) + (1 : ℕ) := by
+  have hp' : (p : ℂ) ≠ 0 := by exact_mod_cast hp
+  rw [coe_heckeMatrix_smul hp, coe_heckeMatrix_smul hp]
+  field_simp
+  push_cast
+  ring
+
+variable {p} in
+theorem coe_heckeDiagMatrix_smul_vadd (hp : p ≠ 0) (τ : ℍ) :
+    ((heckeDiagMatrix p • ((1 : ℝ) +ᵥ τ) : ℍ) : ℂ) = (heckeDiagMatrix p • τ : ℍ) + (p : ℕ) := by
+  rw [coe_heckeDiagMatrix_smul hp, coe_heckeDiagMatrix_smul hp, coe_vadd]
+  push_cast
+  ring
+
+variable {p} in
+theorem sum_heckeMatrix_smul_vadd (hp : p ≠ 0) (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    ∑ j ∈ Finset.range p, f (heckeMatrix p j • ((1 : ℝ) +ᵥ τ))
+      = ∑ j ∈ Finset.range p, f (heckeMatrix p j • τ) := by
+  simp only [heckeMatrix_smul_vadd hp]
+  have h0 := Finset.sum_range_succ' (fun j => f (heckeMatrix p j • τ)) p
+  have h1 := Finset.sum_range_succ (fun j => f (heckeMatrix p j • τ)) p
+  rw [apply_eq_of_coe_eq_add_nat hf 1 (coe_heckeMatrix_smul_self hp τ)] at h1
+  exact add_right_cancel (h0.symm.trans h1)
+
+theorem heckeU_vadd (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    heckeU k p f ((1 : ℝ) +ᵥ τ) = heckeU k p f τ := by
+  by_cases hp : p = 0
+  · simp only [hp, heckeU_zero_left, Pi.zero_apply]
+  · rw [heckeU_apply k hp, heckeU_apply k hp, sum_heckeMatrix_smul_vadd hp hf]
+
+theorem heckeT_vadd (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    heckeT k p f ((1 : ℝ) +ᵥ τ) = heckeT k p f τ := by
+  by_cases hp : p = 0
+  · simp only [hp, heckeT_zero_left]
+    exact apply_eq_of_coe_eq_add_nat hf 1 (by rw [coe_vadd]; push_cast; ring)
+  · rw [heckeT_apply k hp, heckeT_apply k hp, sum_heckeMatrix_smul_vadd hp hf,
+      apply_eq_of_coe_eq_add_nat hf p (coe_heckeDiagMatrix_smul_vadd hp τ)]
+
+theorem periodic_comp_ofComplex_of_vadd {g : ℍ → ℂ} (hg : ∀ τ : ℍ, g ((1 : ℝ) +ᵥ τ) = g τ) :
+    Periodic (g ∘ ofComplex) 1 := by
+  intro w
+  by_cases hw : 0 < im w
+  · have hw' : 0 < im (w + 1) := by simp [hw]
+    simp only [comp_apply, ofComplex_apply_of_im_pos hw', ofComplex_apply_of_im_pos hw]
+    convert hg ⟨w, hw⟩ using 2
+    apply UpperHalfPlane.ext
+    simp [add_comm]
+  · have hw1 : im (w + 1) ≤ 0 := by simpa using hw
+    have hw0 : im w ≤ 0 := not_lt.mp hw
+    simp only [comp_apply, ofComplex_apply_eq_of_im_nonpos hw1 hw0]
+
+theorem periodic_heckeU_comp_ofComplex (hf : Periodic (f ∘ ofComplex) 1) :
+    Periodic (heckeU k p f ∘ ofComplex) 1 :=
+  periodic_comp_ofComplex_of_vadd (heckeU_vadd k p hf)
+
+theorem periodic_heckeT_comp_ofComplex (hf : Periodic (f ∘ ofComplex) 1) :
+    Periodic (heckeT k p f ∘ ofComplex) 1 :=
+  periodic_comp_ofComplex_of_vadd (heckeT_vadd k p hf)
+
+end Regularity
+
+section Uniqueness
+
+theorem qExpansion_coeff_unique' {g : ℍ → ℂ} (hcont : Continuous g) {c : ℕ → ℂ}
+    (hg : AnalyticAt ℂ (cuspFunction 1 g) 0)
+    (hs : ∀ τ : ℍ, HasSum (fun m ↦ c m • Periodic.qParam 1 τ ^ m) (g τ)) (m : ℕ) :
+    c m = (qExpansion 1 g).coeff m :=
+  UpperHalfPlane.qExpansion_coeff_unique (ContinuousMap.mk g hcont) one_pos hg hs m
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+theorem hasSum_qCoeff [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) (τ : ℍ) :
+    HasSum (fun m ↦ qCoeff f m • Periodic.qParam 1 τ ^ m) (f τ) := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  exact hasSum_qExpansion one_pos (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ)
+    (holo f) (bdd_at_infty f) τ
+
+theorem eq_of_forall_qCoeff_eq [ModularFormClass F Γ k] {f g : F} (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (h : ∀ n : ℕ, qCoeff f n = qCoeff g n) : f = g := by
+  refine DFunLike.ext f g fun τ => ?_
+  have hf := hasSum_qCoeff f hΓ τ
+  have hg := hasSum_qCoeff g hΓ τ
+  simp only [h] at hf
+  exact hf.unique hg
+
+end Uniqueness
+
+section QExpAction
+
+theorem qParam_one (z : ℂ) : Periodic.qParam 1 z = exp (2 * π * I * z) := by
+  simp [Periodic.qParam]
+
+variable {p : ℕ} (hp : p ≠ 0)
+
+include hp in
+theorem natCast_ne_zero' : (p : ℂ) ≠ 0 := by exact_mod_cast hp
+
+include hp in
+theorem qParam_heckeMatrix_smul (j : ℕ) (τ : ℍ) :
+    Periodic.qParam 1 ((heckeMatrix p j • τ : ℍ) : ℂ)
+      = exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j := by
+  rw [qParam_one, coe_heckeMatrix_smul hp, ← Complex.exp_nat_mul, ← Complex.exp_add]
+  congr 1
+  have := natCast_ne_zero' hp
+  field_simp
+
+include hp in
+theorem qParam_heckeDiagMatrix_smul (τ : ℍ) :
+    Periodic.qParam 1 ((heckeDiagMatrix p • τ : ℍ) : ℂ) = Periodic.qParam 1 τ ^ p := by
+  rw [qParam_one, qParam_one, coe_heckeDiagMatrix_smul hp, ← Complex.exp_nat_mul]
+  congr 1
+  ring
+
+include hp in
+theorem exp_div_pow (τ : ℍ) : exp (2 * π * I * τ / p) ^ p = Periodic.qParam 1 τ := by
+  rw [qParam_one, ← Complex.exp_nat_mul]
+  congr 1
+  have := natCast_ne_zero' hp
+  field_simp
+
+include hp in
+theorem sum_rootOfUnity_pow (m : ℕ) :
+    ∑ j ∈ Finset.range p, (exp (2 * π * I / p) ^ j) ^ m = if p ∣ m then (p : ℂ) else 0 := by
+  have hζ := Complex.isPrimitiveRoot_exp p hp
+  have hswap : ∀ j : ℕ, (exp (2 * π * I / p) ^ j) ^ m = (exp (2 * π * I / p) ^ m) ^ j := fun j => by
+    rw [← pow_mul, ← pow_mul, Nat.mul_comm j m]
+  simp only [hswap]
+  split_ifs with h
+  · rw [(hζ.pow_eq_one_iff_dvd m).mpr h]
+    simp
+  · have hne : exp (2 * π * I / p) ^ m ≠ 1 := fun h1 => h ((hζ.pow_eq_one_iff_dvd m).mp h1)
+    rw [geom_sum_eq hne, ← pow_mul, Nat.mul_comm m p, pow_mul, hζ.pow_eq_one, one_pow, sub_self,
+      zero_div]
+
+theorem not_dvd_of_not_mem_range {m : ℕ} (hm : m ∉ Set.range (fun l : ℕ ↦ l * p)) : ¬ p ∣ m := by
+  rintro ⟨l, rfl⟩
+  exact hm ⟨l, by simp [mul_comm]⟩
+
+variable {f : ℍ → ℂ} (hper : Periodic (f ∘ ofComplex) 1) (hhol : MDiff f)
+  (hbdd : IsBoundedAtImInfty f)
+
+include hp hper hhol hbdd in
+theorem hasSum_average (τ : ℍ) :
+    HasSum (fun l : ℕ ↦ qCoeff f (l * p) * Periodic.qParam 1 τ ^ l)
+      ((p : ℂ)⁻¹ * ∑ j ∈ Finset.range p, f (heckeMatrix p j • τ)) := by
+  have hF : ∀ τ' : ℍ, HasSum (fun m ↦ qCoeff f m • Periodic.qParam 1 τ' ^ m) (f τ') :=
+    hasSum_qExpansion one_pos hper hhol hbdd
+  have h1 : HasSum (fun m ↦ ∑ j ∈ Finset.range p,
+      qCoeff f m • (exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j) ^ m)
+      (∑ j ∈ Finset.range p, f (heckeMatrix p j • τ)) := by
+    refine hasSum_sum fun j _ => ?_
+    have := hF (heckeMatrix p j • τ)
+    rwa [qParam_heckeMatrix_smul hp j τ] at this
+  have h2 : (fun m ↦ ∑ j ∈ Finset.range p,
+      qCoeff f m • (exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j) ^ m)
+      = fun m ↦ if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0 := by
+    funext m
+    simp only [mul_pow, smul_eq_mul, ← Finset.mul_sum, sum_rootOfUnity_pow hp m]
+    split_ifs <;> ring
+  rw [h2] at h1
+  have hinj : Function.Injective (fun l : ℕ ↦ l * p) := mul_left_injective₀ hp
+  have h3 := (hinj.hasSum_iff (f := fun m ↦
+      if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0)
+    (fun m hm => by simp [not_dvd_of_not_mem_range hm])).mpr h1
+  have h4 : ((fun m ↦ if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0) ∘
+      fun l : ℕ ↦ l * p) = fun l ↦ (p : ℂ) * (qCoeff f (l * p) * Periodic.qParam 1 τ ^ l) := by
+    funext l
+    simp only [comp_apply, ite_eq_left (dvd_mul_left p l)]
+    rw [mul_comm l p, pow_mul, exp_div_pow hp τ]
+    ring
+  rw [h4] at h3
+  have h5 := h3.mul_left ((p : ℂ)⁻¹)
+  simp only [← mul_assoc, inv_mul_cancel₀ (natCast_ne_zero' hp), one_mul] at h5
+  exact h5
+
+include hp hper hhol hbdd in
+theorem hasSum_diag (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ if p ∣ n then (p : ℂ) ^ (k - 1) * qCoeff f (n / p) * Periodic.qParam 1 τ ^ n
+        else 0)
+      ((p : ℂ) ^ (k - 1) * f (heckeDiagMatrix p • τ)) := by
+  have hD := (hasSum_qExpansion one_pos hper hhol hbdd (heckeDiagMatrix p • τ)).mul_left
+    ((p : ℂ) ^ (k - 1))
+  rw [qParam_heckeDiagMatrix_smul hp τ] at hD
+  have hinj : Function.Injective (fun l : ℕ ↦ l * p) := mul_left_injective₀ hp
+  refine (hinj.hasSum_iff (fun m hm => by simp [not_dvd_of_not_mem_range hm])).mp ?_
+  convert hD using 1
+  funext l
+  simp only [comp_apply, ite_eq_left (dvd_mul_left p l), Nat.mul_div_cancel _ (Nat.pos_of_ne_zero
+    hp),
+    smul_eq_mul]
+  rw [← pow_mul, mul_comm l p, mul_assoc]
+  rfl
+
+include hp hper hhol hbdd in
+theorem hasSum_heckeU (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ coeffHeckeU p (qCoeff f) n • Periodic.qParam 1 τ ^ n) (heckeU k p f τ) := by
+  rw [heckeU_apply k hp]
+  simpa only [coeffHeckeU_apply, smul_eq_mul] using hasSum_average hp hper hhol hbdd τ
+
+include hp hper hhol hbdd in
+theorem hasSum_heckeT (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ coeffHeckeT k p (qCoeff f) n • Periodic.qParam 1 τ ^ n) (heckeT k p f τ) :=
+      by
+  rw [heckeT_apply k hp]
+  convert (hasSum_average hp hper hhol hbdd τ).add (hasSum_diag hp hper hhol hbdd k τ) using 1
+  funext n
+  rw [coeffHeckeT_apply, smul_eq_mul]
+  split_ifs <;> ring
+
+include hp hper hhol hbdd in
+theorem qCoeff_heckeU_bare (k : ℤ) (n : ℕ) :
+    qCoeff (heckeU k p f) n = coeffHeckeU p (qCoeff f) n :=
+  (qExpansion_coeff_unique' (mdifferentiable_heckeU k p hhol).continuous
+    (analyticAt_cuspFunction_zero one_pos (periodic_heckeU_comp_ofComplex k p hper)
+      (mdifferentiable_heckeU k p hhol) (isBoundedAtImInfty_heckeU k p hbdd))
+    (hasSum_heckeU hp hper hhol hbdd k) n).symm
+
+include hp hper hhol hbdd in
+theorem qCoeff_heckeT_bare (k : ℤ) (n : ℕ) :
+    qCoeff (heckeT k p f) n = coeffHeckeT k p (qCoeff f) n :=
+  (qExpansion_coeff_unique' (mdifferentiable_heckeT k p hhol).continuous
+    (analyticAt_cuspFunction_zero one_pos (periodic_heckeT_comp_ofComplex k p hper)
+      (mdifferentiable_heckeT k p hhol) (isBoundedAtImInfty_heckeT k p hbdd))
+    (hasSum_heckeT hp hper hhol hbdd k) n).symm
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+include hp in
+theorem qCoeff_heckeU_class [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (n : ℕ) : qCoeff (heckeU k p f) n = coeffHeckeU p (qCoeff f) n :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  qCoeff_heckeU_bare hp (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (holo f)
+    (bdd_at_infty f) k n
+
+include hp in
+theorem qCoeff_heckeT_class [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (n : ℕ) : qCoeff (heckeT k p f) n = coeffHeckeT k p (qCoeff f) n :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  qCoeff_heckeT_bare hp (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (holo f)
+    (bdd_at_infty f) k n
+
+end QExpAction
+
+end M4cP1W2
+
+end
+
+theorem solution {f : UpperHalfPlane → ℂ} (hf : Function.Periodic (f ∘ UpperHalfPlane.ofComplex) 1)
+    (k : ℤ) (p : ℕ) :
+    Function.Periodic (ModularForm.heckeU k p f ∘ UpperHalfPlane.ofComplex) 1 :=
+  M4cP1W2.periodic_heckeU_comp_ofComplex k p hf
+
+end S_ModularForm_periodic_heckeU_comp_ofComplex
+end P2MW
+export P2MW.S_ModularForm_periodic_heckeU_comp_ofComplex (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ModularForm.periodic_heckeU_comp_ofComplex {f : UpperHalfPlane → ℂ}
+    (hf : Function.Periodic (f ∘ UpperHalfPlane.ofComplex) 1) (k : ℤ) (p : ℕ) :
+    Function.Periodic (ModularForm.heckeU k p f ∘ UpperHalfPlane.ofComplex) 1 :=
+  solution hf k p
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_qExpansion_E4_mul_theta_discriminant_sub.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_qExpansion_E4_mul_theta_discriminant_sub.lean
new file mode 100644
index 0000000000..99ebdaf7f6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_qExpansion_E4_mul_theta_discriminant_sub.lean
@@ -0,0 +1,176 @@
+/-
+Based on Prove2Me node ModularForm.qExpansion_E4_mul_theta_discriminant_sub
+(73b2a8bf-533e-503c-95b3-770a40d8a71e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 58601e44-c349-582e-b387-00c9a3c2488a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+
+import Mathlib.NumberTheory.ModularForms.LevelOne.DimensionFormula
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_rankinCohen_one_qExpansion_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# First Rankin–Cohen bracket of E₄ and Δ
+
+Theorem statement: `ModularForm.qExpansion_E4_mul_theta_discriminant_sub`
+(`73b2a8bf-533e-503c-95b3-770a40d8a71e`), by Claude, 2026-09-05.
+
+Proof: submission `58601e44-c349-582e-b387-00c9a3c2488a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+The assertion is a single identity in the ring $\mathbb{C}[\![q]\!]$ of formal power series, with no
+variables or hypotheses. For a function $f \colon \mathbb{H} \to \mathbb{C}$, write $\tilde f =
+\mathrm{qExpansion}\,1\,f$ for its $q$-expansion of width $1$ at the cusp $\infty$, and for a power
+series $P$ let $\theta P$ denote the series whose $n$-th coefficient is $n$ times the $n$-th
+coefficient of $P$, realised here as `PowerSeries.mk (fun n => (n : ℂ) * P.coeff n)`, i.e. the Euler
+operator $q\,d/dq$. Taking $f$ to be the underlying function of the normalised level-one Eisenstein
+series `ModularForm.E₄` of weight $4$, of `ModularForm.E₆` of weight $6$, and the function
+`ModularForm.discriminant` on $\mathbb{H}$ (the modular discriminant $\Delta$, the function
+underlying the level-one cusp form of weight $12$), the theorem states
+$$\tilde E_4 \cdot \theta\tilde\Delta \; - \; 3\,\theta\tilde E_4 \cdot \tilde\Delta \; = \; \tilde
+E_6 \cdot \tilde\Delta,$$
+where $3$ is the constant power series $3$. Thus it is the classical first Rankin–Cohen bracket
+identity $[E_4,\Delta]_1 = 4E_4\,D\Delta - 12\,DE_4\,\Delta = 4E_6\Delta$, read on $q$-expansions
+and divided by $4$.
+
+Equivalent to Ramanujan's formula for the derivative of the $j$-invariant, $\theta j =
+-E_4^2E_6/\Delta$, in the shape of the first Rankin–Cohen bracket of $E_4$ and $\Delta$ on formal
+$q$-expansions. It is used by
+[`ModularCurve.eisenstein4_mul_thetaL_delta_sub_eq_eisenstein6_mul_delta`]
+(thm.html#ModularCurve.eisenstein4_mul_thetaL_delta_sub_eq_eisenstein6_mul_delta).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_qExpansion_E4_mul_theta_discriminant_sub.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_qExpansion_E4_mul_theta_discriminant_sub
+
+open UpperHalfPlane ModularForm EisensteinSeries CongruenceSubgroup
+open scoped MatrixGroups Manifold
+
+noncomputable section
+
+theorem solution :
+    qExpansion 1 (⇑ModularForm.E₄ : ℍ → ℂ) *
+        PowerSeries.mk (fun n : ℕ => (n : ℂ) * (qExpansion 1 ModularForm.discriminant).coeff n)
+      - 3 * PowerSeries.mk (fun n : ℕ => (n : ℂ) * (qExpansion 1 (⇑ModularForm.E₄ : ℍ → ℂ)).coeff n)
+        * qExpansion 1 ModularForm.discriminant
+      = qExpansion 1 (⇑ModularForm.E₆ : ℍ → ℂ) * qExpansion 1 ModularForm.discriminant := by
+  have hΓ : ((Gamma 1 : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) = 𝒮ℒ := Gamma_one_coe_eq_SL
+  have h1 : (1 : ℝ) ∈ ((Gamma 1 : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+    rw [hΓ]; exact one_mem_strictPeriods_SL
+  obtain ⟨B, -, hBq⟩ := ModularForm.exists_rankinCohen_one_qExpansion_eq h1
+    (E₄.mcast rfl hΓ) ((CuspForm.discriminant : ModularForm 𝒮ℒ 12).mcast rfl hΓ)
+  set P4 : PowerSeries ℂ := qExpansion 1 (⇑ModularForm.E₄ : ℍ → ℂ) with hP4
+  set P6 : PowerSeries ℂ := qExpansion 1 (⇑ModularForm.E₆ : ℍ → ℂ) with hP6
+  set PD : PowerSeries ℂ := qExpansion 1 ModularForm.discriminant with hPD
+  change qExpansion 1 (B : ℍ → ℂ) =
+      PowerSeries.C ((4 : ℤ) : ℂ) * P4 * PowerSeries.mk (fun n : ℕ => (n : ℂ) * PD.coeff n)
+        - PowerSeries.C ((12 : ℤ) : ℂ) * PowerSeries.mk (fun n : ℕ => (n : ℂ) * P4.coeff n) * PD
+          at hBq
+  have h40 : P4.coeff 0 = 1 := E_qExpansion_coeff_zero (by norm_num) ⟨2, rfl⟩
+  have h60 : P6.coeff 0 = 1 := E_qExpansion_coeff_zero (by norm_num) ⟨3, rfl⟩
+  have hD0 : PD.coeff 0 = 0 := by
+    rw [hPD, ← CuspForm.coe_discriminant, UpperHalfPlane.qExpansion_coeff_zero one_pos
+      (ModularFormClass.analyticAt_cuspFunction_zero _ one_pos one_mem_strictPeriods_SL)
+      (SlashInvariantFormClass.periodic_comp_ofComplex _ one_mem_strictPeriods_SL)]
+    exact (CuspFormClass.zero_at_infty CuspForm.discriminant).valueAtInfty_eq_zero
+  have hD1 : PD.coeff 1 = 1 := discriminant_qExpansion_coeff_one
+  set B' : ModularForm 𝒮ℒ 18 := B.mcast (by norm_num) hΓ.symm with hB'
+  have hB'q : qExpansion 1 (B' : ℍ → ℂ) = qExpansion 1 (B : ℍ → ℂ) := rfl
+  have hcusp : IsCuspForm B' := by
+    rw [isCuspForm_iff_coeffZero_eq_zero, hB'q, hBq]
+    simp [h40, hD0]
+  obtain ⟨G, hG⟩ := hcusp
+  have hGB : (G : ℍ → ℂ) = (B : ℍ → ℂ) := by
+    funext τ
+    have := DFunLike.congr_fun hG τ
+    first | exact this
+  set M : ModularForm 𝒮ℒ 6 := (CuspForm.discriminantEquiv G).mcast (by norm_num) with hM
+  obtain ⟨c, hc⟩ : ∃ c : ℂ, c • E₆ = M :=
+    (finrank_eq_one_iff_of_nonzero' E₆ (E_ne_zero (by norm_num) ⟨3, rfl⟩)).mp
+      (Module.rank_eq_one_iff_finrank_eq_one.mp levelOne_weight_six_rank_one) M
+  have hpt : (B : ℍ → ℂ) = ModularForm.discriminant * (c • (⇑ModularForm.E₆ : ℍ → ℂ)) := by
+    rw [← hGB]
+    funext τ
+    have h2 : M τ = c * E₆ τ := by
+      have := DFunLike.congr_fun hc τ
+      rw [smul_apply, smul_eq_mul] at this
+      exact this.symm
+    have h3 : ModularForm.discriminant τ * M τ = G τ := by
+      change ModularForm.discriminant τ * (G τ / ModularForm.discriminant τ) = G τ
+      exact mul_div_cancel₀ _ (discriminant_ne_zero τ)
+    rw [Pi.mul_apply, Pi.smul_apply, smul_eq_mul, ← h2, h3]
+  have hq2 : qExpansion 1 (B : ℍ → ℂ) = PD * (c • P6) := by
+    rw [hpt, UpperHalfPlane.qExpansion_mul, UpperHalfPlane.qExpansion_smul]
+    · exact ModularFormClass.analyticAt_cuspFunction_zero ModularForm.E₆ one_pos
+        one_mem_strictPeriods_SL
+    · rw [← CuspForm.coe_discriminant]
+      exact ModularFormClass.analyticAt_cuspFunction_zero CuspForm.discriminant one_pos
+        one_mem_strictPeriods_SL
+    · have : (c • (⇑ModularForm.E₆ : ℍ → ℂ)) = ⇑(c • ModularForm.E₆) := by
+        rw [FunLike.coe_smul]
+      rw [this]
+      exact ModularFormClass.analyticAt_cuspFunction_zero _ one_pos one_mem_strictPeriods_SL
+  have key := hBq.symm.trans hq2
+  have hc4 : c = 4 := by
+    have := congrArg (PowerSeries.coeff 1) key
+    simp [PowerSeries.coeff_mul, Finset.Nat.antidiagonal_succ, h40, h60, hD0, hD1] at this
+    first
+      | exact this.symm
+  subst hc4
+  have h4 : (PowerSeries.C (4 : ℂ)) ≠ 0 := by simp
+  apply mul_left_cancel₀ h4
+  have e12 : PowerSeries.C ((12 : ℤ) : ℂ) = PowerSeries.C (4 : ℂ) * 3 := by
+    rw [show (3 : PowerSeries ℂ) = PowerSeries.C 3 from rfl, ← map_mul]; norm_num
+  have e4 : PowerSeries.C ((4 : ℤ) : ℂ) = PowerSeries.C (4 : ℂ) := by norm_num
+  rw [e12, e4, PowerSeries.smul_eq_C_mul] at key
+  calc PowerSeries.C (4 : ℂ) * (P4 * PowerSeries.mk (fun n : ℕ => (n : ℂ) * PD.coeff n)
+          - 3 * PowerSeries.mk (fun n : ℕ => (n : ℂ) * P4.coeff n) * PD)
+        = PowerSeries.C (4 : ℂ) * P4 * PowerSeries.mk (fun n : ℕ => (n : ℂ) * PD.coeff n)
+          - PowerSeries.C (4 : ℂ) * 3 * PowerSeries.mk (fun n : ℕ => (n : ℂ) * P4.coeff n) * PD
+            := by
+          ring
+    _ = PD * (PowerSeries.C 4 * P6) := key
+    _ = PowerSeries.C (4 : ℂ) * (P6 * PD) := by ring
+
+end
+
+end S_ModularForm_qExpansion_E4_mul_theta_discriminant_sub
+end P2MW
+export P2MW.S_ModularForm_qExpansion_E4_mul_theta_discriminant_sub (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem ModularForm.qExpansion_E4_mul_theta_discriminant_sub :
+    UpperHalfPlane.qExpansion 1 (⇑ModularForm.E₄ : UpperHalfPlane → ℂ) *
+        PowerSeries.mk (fun n : ℕ => (n : ℂ) * (UpperHalfPlane.qExpansion 1
+          ModularForm.discriminant).coeff n)
+      - 3 * PowerSeries.mk (fun n : ℕ => (n : ℂ) * (UpperHalfPlane.qExpansion 1 (⇑ModularForm.E₄ :
+        UpperHalfPlane → ℂ)).coeff n)
+        * UpperHalfPlane.qExpansion 1 ModularForm.discriminant
+      = UpperHalfPlane.qExpansion 1 (⇑ModularForm.E₆ : UpperHalfPlane → ℂ) *
+        UpperHalfPlane.qExpansion 1 ModularForm.discriminant :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_qExpansion_heckeDiagMatrix_smul_eq_qExpand_of_levelOne.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_qExpansion_heckeDiagMatrix_smul_eq_qExpand_of_levelOne.lean
new file mode 100644
index 0000000000..09d52365bd
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_qExpansion_heckeDiagMatrix_smul_eq_qExpand_of_levelOne.lean
@@ -0,0 +1,187 @@
+/-
+Based on Prove2Me node ModularForm.qExpansion_heckeDiagMatrix_smul_eq_qExpand_of_levelOne
+(fb6ad152-fbff-5727-97a8-4508cee47650) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 32fbc617-cc1d-5356-a450-bbd4c87d5116
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_degeneracy_Gamma0
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_laurent_qParam_coeff_unique
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# q-expansion of τ↦ F(Nτ) for level-one F
+
+Theorem statement: `ModularForm.qExpansion_heckeDiagMatrix_smul_eq_qExpand_of_levelOne`
+(`fb6ad152-fbff-5727-97a8-4508cee47650`), by Claude, 2026-09-05.
+
+Proof: submission `32fbc617-cc1d-5356-a450-bbd4c87d5116`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number that is nonzero, let $k$ be an integer, and let $F$ be a modular form of
+weight $k$ for the subgroup $\mathcal{SL} \le \mathrm{GL}(2,\mathbb{R})$ (the image of
+$\mathrm{SL}(2,\mathbb{Z})$), acting on the upper half-plane $\mathbb{H}$. Here
+[`ModularForm.heckeDiagMatrix N`](def/ModularForm_HeckeOperator.html#L21) is, for $N \neq 0$, the
+element of $\mathrm{GL}(2,\mathbb{R})$ given by the upper triangular matrix $\begin{pmatrix} N & 0
+\\ 0 & 1\end{pmatrix}$, whose action on $\mathbb{H}$ is $\tau \mapsto N\tau$; and
+[`ModularCurve.qExpand ℂ N`](def/ModularCurve_X0.html#L25) is the ring endomorphism of the Laurent
+series field $\mathbb{C}(\!(q)\!)$ obtained by embedding the exponent group $\mathbb{Z}$ along
+multiplication by $N$, i.e. the substitution $q \mapsto q^{N}$, which sends the coefficient of index
+$m$ to the coefficient of index $Nm$ and sets all coefficients of index not divisible by $N$ to
+zero. The assertion is that the width-one $q$-expansion of the dilated function $\tau \mapsto
+F(N\tau)$, viewed as a power series and then as a Laurent series, equals the image under this
+substitution of the width-one $q$-expansion of $F$; in the classical notation, the expansion of
+$F(N\tau)$ is $\tilde F(q^{N})$.
+
+This identifies the $q$-expansion of the degeneracy (dilation) image of a level-one form, the basic
+compatibility between the map $\tau \mapsto N\tau$ on $\mathbb{H}$ and the substitution $q \mapsto
+q^{N}$ on Laurent expansions. It is used in the analytic study of modular curves and their cusps,
+for instance in the computations with modular polynomial data and Tate-type expansions that invoke
+it downstream.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_qExpansion_heckeDiagMatrix_smul_eq_qExpand_of_levelOne.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularForm_qExpansion_heckeDiagMatrix_smul_eq_qExpand_of_levelOne
+
+open UpperHalfPlane
+open scoped MatrixGroups
+
+namespace SolDILAux
+
+private theorem gamma0_one_eq_top : CongruenceSubgroup.Gamma0 1 = ⊤ := by
+  ext A
+  simp [CongruenceSubgroup.Gamma0_mem, eq_iff_true_of_subsingleton]
+
+private theorem gamma0_one_coe :
+    ((CongruenceSubgroup.Gamma0 1 : Subgroup SL(2, ℤ)) : Subgroup (GL (Fin 2) ℝ)) = 𝒮ℒ := by
+  simp [gamma0_one_eq_top, MonoidHom.range_eq_map]
+
+private theorem one_mem_sp (M : ℕ) : (1 : ℝ) ∈
+    ((CongruenceSubgroup.Gamma0 M : Subgroup SL(2, ℤ)) :
+      Subgroup (GL (Fin 2) ℝ)).strictPeriods := by
+  rw [CongruenceSubgroup.strictPeriods_Gamma0]
+  exact AddSubgroup.mem_zmultiples 1
+
+private theorem hasSum_int {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} {F : Type*} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) (τ : ℍ) :
+    HasSum (fun m : ℤ =>
+      ((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ).coeff m *
+        Function.Periodic.qParam 1 (τ : ℂ) ^ m) (f τ) := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  have h0 := UpperHalfPlane.hasSum_qExpansion (f := (f : ℍ → ℂ)) one_pos
+    (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (ModularFormClass.holo f)
+    (ModularFormClass.bdd_at_infty f) τ
+  refine (Function.Injective.hasSum_iff Nat.cast_injective ?_).mp ?_
+  · intro m hm
+    rcases m with n | n
+    · exact absurd ⟨n, rfl⟩ hm
+    · rw [ModularCurve.ofPowerSeries_coeff_of_neg _ (Int.negSucc_lt_zero n), zero_mul]
+  · have hcomp : ((fun m : ℤ =>
+        ((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ).coeff m *
+          Function.Periodic.qParam 1 (τ : ℂ) ^ m) ∘ (Nat.cast : ℕ → ℤ)) =
+        fun n : ℕ => (qExpansion 1 (f : ℍ → ℂ)).coeff n •
+          Function.Periodic.qParam 1 (τ : ℂ) ^ n := by
+      funext n
+      simp only [Function.comp_apply, smul_eq_mul, zpow_natCast,
+        LaurentSeries.coeff_coe_powerSeries]
+    rw [hcomp]
+    exact h0
+
+private theorem hasSum_qExpand (N : ℕ) [NeZero N] {A : LaurentSeries ℂ} {S : ℂ} {τ : ℍ}
+    (h : HasSum (fun m : ℤ => A.coeff m *
+      Function.Periodic.qParam 1 (((ModularForm.heckeDiagMatrix N • τ : ℍ)) : ℂ) ^ m) S) :
+    HasSum (fun m : ℤ => (ModularCurve.qExpand ℂ N A).coeff m *
+      Function.Periodic.qParam 1 (τ : ℂ) ^ m) S := by
+  have hq : Function.Periodic.qParam 1 (((ModularForm.heckeDiagMatrix N • τ : ℍ)) : ℂ) =
+      Function.Periodic.qParam 1 (τ : ℂ) ^ (N : ℕ) := by
+    rw [ModularForm.coe_heckeDiagMatrix_smul (NeZero.ne N) τ]
+    unfold Function.Periodic.qParam
+    rw [← Complex.exp_nat_mul]
+    congr 1
+    ring
+  rw [hq] at h
+  have hinj : Function.Injective (fun m : ℤ => (N : ℤ) * m) :=
+    mul_right_injective₀ (by exact_mod_cast NeZero.ne N)
+  refine (Function.Injective.hasSum_iff hinj ?_).mp ?_
+  · intro m hm
+    have hnd : ¬ ((N : ℕ) : ℤ) ∣ m := by
+      rintro ⟨c, rfl⟩
+      exact hm ⟨c, rfl⟩
+    rw [ModularCurve.qExpand_coeff_of_not_dvd N A hnd, zero_mul]
+  · have hcomp : ((fun m : ℤ => (ModularCurve.qExpand ℂ N A).coeff m *
+        Function.Periodic.qParam 1 (τ : ℂ) ^ m) ∘ (fun m : ℤ => (N : ℤ) * m)) =
+        fun m : ℤ => A.coeff m *
+          (Function.Periodic.qParam 1 (τ : ℂ) ^ (N : ℕ)) ^ m := by
+      funext m
+      simp only [Function.comp_apply]
+      rw [ModularCurve.qExpand_coeff_mul, zpow_mul, zpow_natCast]
+    rw [hcomp]
+    exact h
+
+private theorem qExpansion_coe_dilate {N : ℕ} [NeZero N] {k : ℤ}
+    (f : ModularForm (CongruenceSubgroup.Gamma0 1) k)
+    (g : ModularForm (CongruenceSubgroup.Gamma0 N) k)
+    (hg : ⇑g = fun τ => f (ModularForm.heckeDiagMatrix N • τ)) :
+    ((qExpansion 1 (g : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) =
+      ModularCurve.qExpand ℂ N
+        ((qExpansion 1 (f : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) := by
+  refine ModularCurve.laurent_qParam_coeff_unique 1 one_pos (g : ℍ → ℂ) _ _
+    (hasSum_int g (one_mem_sp N)) ?_
+  intro τ
+  have h := hasSum_qExpand N (hasSum_int f (one_mem_sp 1) (ModularForm.heckeDiagMatrix N • τ))
+  rw [show f (ModularForm.heckeDiagMatrix N • τ) = g τ from by rw [hg]] at h
+  exact h
+
+end SolDILAux
+
+theorem solution (N : ℕ) [NeZero N] {k : ℤ} (F : ModularForm 𝒮ℒ k) :
+    ((qExpansion 1 (fun τ : ℍ => (F : ℍ → ℂ) (ModularForm.heckeDiagMatrix N • τ)) :
+      PowerSeries ℂ) : LaurentSeries ℂ) =
+    ModularCurve.qExpand ℂ N ((qExpansion 1 (F : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) := by
+  obtain ⟨G, hG⟩ := ModularForm.exists_degeneracy_Gamma0 (show N * 1 ∣ N by simp)
+    (ModularForm.mcast rfl F SolDILAux.gamma0_one_coe)
+  have h1 : (fun τ : ℍ => (F : ℍ → ℂ) (ModularForm.heckeDiagMatrix N • τ)) = ⇑G := by
+    rw [hG]
+    simp only [ModularForm.coe_mcast]
+  rw [h1]
+  exact SolDILAux.qExpansion_coe_dilate (ModularForm.mcast rfl F SolDILAux.gamma0_one_coe) G hG
+
+end S_ModularForm_qExpansion_heckeDiagMatrix_smul_eq_qExpand_of_levelOne
+end P2MW
+export P2MW.S_ModularForm_qExpansion_heckeDiagMatrix_smul_eq_qExpand_of_levelOne (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane
+open scoped MatrixGroups
+theorem ModularForm.qExpansion_heckeDiagMatrix_smul_eq_qExpand_of_levelOne (N : ℕ) [NeZero N]
+    {k : ℤ} (F : ModularForm 𝒮ℒ k) :
+    ((qExpansion 1 (fun τ : ℍ => (F : ℍ → ℂ) (ModularForm.heckeDiagMatrix N • τ)) : PowerSeries ℂ) :
+      LaurentSeries ℂ) = ModularCurve.qExpand ℂ N ((qExpansion 1 (F : ℍ → ℂ) : PowerSeries ℂ) :
+      LaurentSeries ℂ) :=
+  solution N F
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_weierstrassP_torsion_qExpansion_package.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_weierstrassP_torsion_qExpansion_package.lean
new file mode 100644
index 0000000000..694e4ddee5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularForm_weierstrassP_torsion_qExpansion_package.lean
@@ -0,0 +1,1405 @@
+/-
+Based on Prove2Me node ModularForm.weierstrassP_torsion_qExpansion_package
+(91566695-d863-5200-bb1e-36b065994f44) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 220b9575-68c5-5d5c-af1c-4a6cb65111f4
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.EisensteinSeries.QExpansion
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import Mathlib.Analysis.SpecialFunctions.Elliptic.Weierstrass
+public import Mathlib.Geometry.Manifold.Notation
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Defs
+
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+import Mathlib.RingTheory.DedekindDomain.IntegralClosure
+import Mathlib.RingTheory.DedekindDomain.Ideal.Lemmas
+import Mathlib.RingTheory.Unramified.Field
+import Mathlib.Analysis.Meromorphic.NormalForm
+import Mathlib.RingTheory.Discriminant
+import Mathlib.RingTheory.Adjoin.PowerBasis
+import Mathlib.FieldTheory.PrimitiveElement
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.LinearAlgebra.Lagrange
+import Mathlib.FieldTheory.LinearDisjoint
+import Mathlib.FieldTheory.Galois.Infinite
+import Mathlib.RingTheory.AlgebraicIndependent.TranscendenceBasis
+import Mathlib.RingTheory.AlgebraicIndependent.AlgebraicClosure
+import Mathlib.RingTheory.AlgebraicIndependent.Adjoin
+import Mathlib.RingTheory.Polynomial.RationalRoot
+import Mathlib.Analysis.Analytic.Order
+import Mathlib.RingTheory.PowerSeries.Order
+import Mathlib.RingTheory.Polynomial.IsIntegral
+import Mathlib.Analysis.Complex.IntegerCompl
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_weierstrassP_qExpansion_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Regularity, rationality and Galois transport for wp at torsion
+
+Theorem statement: `ModularForm.weierstrassP_torsion_qExpansion_package`
+(`91566695-d863-5200-bb1e-36b065994f44`), by Claude, 2026-09-05.
+
+Proof: submission `220b9575-68c5-5d5c-af1c-4a6cb65111f4`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N\in\mathbb{N}$ with $N\neq 0$ and a map $L\colon\mathbb{H}\to\mathrm{PeriodPair}$ whose
+periods are $(L\,\tau).\omega_1=\tau$ and $(L\,\tau).\omega_2=1$ for every $\tau$. Put
+$\zeta=e^{2\pi i/N}\in\mathbb{C}$, let $k=\mathbb{Q}(\zeta)$ be the intermediate field of
+$\mathbb{C}/\mathbb{Q}$ generated by $\zeta$ with $\zeta_k\in k$ the adjoined generator, and set
+$W_{a_1,a_2}(\tau)=(2\pi i)^{-2}\,\wp_{L\,\tau}\bigl((a_1\tau+a_2)/N\bigr)$ for
+$a_1,a_2\in\mathbb{N}$. The conclusion is a sevenfold conjunction. First, for all $a_1,a_2<N$ not
+both zero, $W_{a_1,a_2}$ is holomorphic on $\mathbb{H}$ (differentiable as a map of complex
+manifolds), its extension along `UpperHalfPlane.ofComplex` is periodic with period $N$, it is
+bounded at $i\infty$, and every coefficient of its width-$N$ $q$-expansion `qExpansion N` lies in
+$k$. Secondly, for nonzero $(a_1,a_2),(b_1,b_2)\in[0,N)^2$, equality $W_{a_1,a_2}=W_{b_1,b_2}$ of
+functions on $\mathbb{H}$ forces $(b_1,b_2)=(a_1,a_2)$ or $(b_1,b_2)=((N-a_1)\bmod N,(N-a_2)\bmod
+N)$. Thirdly, there is $S\colon\mathbb{N}\to\mathbb{N}\to k[\![q]\!]$ with $S_{a_1,a_2}$ pushed
+forward along $k\hookrightarrow\mathbb{C}$ equal to `qExpansion N (W a₁ a₂)` for all such
+$(a_1,a_2)$, and such that for every $s$ coprime to $N$ and every ring homomorphism $\varphi\colon
+k\to\mathbb{C}$ with $\varphi(\zeta_k)=\zeta^s$ one has $\varphi_*S_{a_1,a_2}=$ `qExpansion N (W a₁
+(s * a₂ % N))` — the transport fixes $a_1$ and multiplies $a_2$ by $s$ modulo $N$. Fourthly, a
+width-change lemma: for any $f\colon\mathbb{H}\to\mathbb{C}$ which is holomorphic, bounded at
+$i\infty$ and $1$-periodic after composition with `UpperHalfPlane.ofComplex`, the $n$-th coefficient
+of `qExpansion N f` equals the $(n/N)$-th coefficient of `qExpansion 1 f` when $N\mid n$ and
+vanishes otherwise. The last three assertions state that all coefficients of the width-$1$
+$q$-expansions of `ModularForm.E₄`, `ModularForm.E₆` and `ModularForm.discriminant` are rational
+numbers.
+
+Up to the normalisation by $E_4E_6/\Delta$, the functions $W_{a_1,a_2}$ are the Fricke functions
+attached to the $N$-torsion of the analytic family $\mathbb{C}/(\mathbb{Z}\tau+\mathbb{Z})$, and the
+four parts record their holomorphy and boundedness, the $\mathbb{Q}(\zeta_N)$-rationality of their
+$q_N$-expansions, their separation up to negation of the index, and the effect of
+$\mathrm{Gal}(\mathbb{Q}(\zeta_N)/\mathbb{Q})$ on these expansions, together with the comparison of
+$q_N$- and $q$-expansions and the rationality of the coefficients of $E_4$, $E_6$ and $\Delta$. It
+is the analytic input used by
+[`WLight.frickeFunction_modularity_package`](thm.html#WLight.frickeFunction_modularity_package) and
+[`WLight.frickeFunction_orbit_package`](thm.html#WLight.frickeFunction_orbit_package) towards the
+field of modular functions of level $N$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularForm_weierstrassP_torsion_qExpansion_package.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 400000
+
+section privateSection
+
+namespace P2MW.S_ModularForm_weierstrassP_torsion_qExpansion_package
+
+noncomputable section
+
+open Complex Real
+
+namespace WLightR2
+
+section Floor
+open scoped UpperHalfPlane Manifold
+open PeriodPair
+
+def periodPairOfTau (τ : ℍ) : PeriodPair where
+  ω₁ := (τ : ℂ)
+  ω₂ := 1
+  indep := LinearIndependent.pair_iff.mpr fun s t hst ↦ by
+    have him : s * (τ : ℂ).im = 0 := by
+      have := congrArg Complex.im hst
+      simpa [Complex.add_im, Complex.smul_im, smul_eq_mul] using this
+    have hs : s = 0 :=
+      (mul_eq_zero.mp him).resolve_right (UpperHalfPlane.coe_im τ ▸ τ.im_ne_zero)
+    subst hs
+    simpa using hst
+
+@[scoped simp] lemma periodPairOfTau_ω₁ (τ : ℍ) : (periodPairOfTau τ).ω₁ = (τ : ℂ) := rfl
+@[scoped simp] lemma periodPairOfTau_ω₂ (τ : ℍ) : (periodPairOfTau τ).ω₂ = 1 := rfl
+
+def zetaN (N : ℕ) : ℂ := cexp (2 * π * I / N)
+
+def qN (N : ℕ) (τ : ℂ) : ℂ := cexp (2 * π * I * τ / N)
+
+lemma zetaN_ne_zero (N : ℕ) : zetaN N ≠ 0 := Complex.exp_ne_zero _
+lemma qN_ne_zero (N : ℕ) (τ : ℂ) : qN N τ ≠ 0 := Complex.exp_ne_zero _
+
+lemma qN_pow_self {N : ℕ} (hN : N ≠ 0) (τ : ℂ) : qN N τ ^ N = cexp (2 * π * I * τ) := by
+  have : (N : ℂ) ≠ 0 := by exact_mod_cast hN
+  rw [qN, ← Complex.exp_nat_mul]
+  congr 1
+  field_simp
+
+lemma cexp_two_pi_I_mul_torsionPt {N : ℕ} (hN : N ≠ 0) (a₁ a₂ : ℕ) (τ : ℂ) :
+    cexp (2 * π * I * ((a₁ * τ + a₂) / N)) = zetaN N ^ a₂ * qN N τ ^ a₁ := by
+  have : (N : ℂ) ≠ 0 := by exact_mod_cast hN
+  rw [zetaN, qN, ← Complex.exp_nat_mul, ← Complex.exp_nat_mul, ← Complex.exp_add]
+  congr 1
+  field_simp
+  ring
+
+lemma norm_qN (N : ℕ) (τ : ℂ) : ‖qN N τ‖ = Real.exp (-(2 * π * τ.im / N)) := by
+  rw [qN, Complex.norm_exp]
+  congr 1
+  rw [show 2 * (π : ℂ) * I * τ / N = (2 * π * I * τ) / (N : ℕ) from rfl, Complex.div_natCast_re]
+  simp [mul_comm]
+  ring
+
+lemma norm_zetaN (N : ℕ) : ‖zetaN N‖ = 1 := by
+  rw [zetaN, Complex.norm_exp, show 2 * (π : ℂ) * I / N = (2 * π * I) / (N : ℕ) from rfl,
+    Complex.div_natCast_re]
+  simp
+
+lemma norm_qN_le_one (N : ℕ) {τ : ℂ} (hτ : 0 ≤ τ.im) : ‖qN N τ‖ ≤ 1 := by
+  rw [norm_qN, Real.exp_le_one_iff, neg_nonpos]
+  positivity
+
+lemma norm_qN_lt_one {N : ℕ} (hN : 0 < N) {τ : ℂ} (hτ : 0 < τ.im) : ‖qN N τ‖ < 1 := by
+  rw [norm_qN, Real.exp_lt_one_iff, neg_lt_zero]
+  have : (0 : ℝ) < N := by exact_mod_cast hN
+  positivity
+
+lemma norm_qN_le_of_le_im (N : ℕ) {B : ℝ} {τ : ℂ} (hτ : B ≤ τ.im) :
+    ‖qN N τ‖ ≤ Real.exp (-(2 * π * B / N)) := by
+  rw [norm_qN, Real.exp_le_exp, neg_le_neg_iff]
+  rcases Nat.eq_zero_or_pos N with hN | hN
+  · simp [hN]
+  · have : (0 : ℝ) < N := by exact_mod_cast hN
+    gcongr
+
+def wpTail (N a₁ a₂ : ℕ) (p : ℕ+ × ℕ+) (τ : ℂ) : ℂ :=
+  ((p.2 : ℕ) : ℂ) *
+    (zetaN N ^ (a₂ * (p.2 : ℕ)) * qN N τ ^ (((p.1 : ℕ) * N + a₁) * (p.2 : ℕ)) +
+      (zetaN N)⁻¹ ^ (a₂ * (p.2 : ℕ)) * qN N τ ^ (((p.1 : ℕ) * N - a₁) * (p.2 : ℕ)) -
+        2 * qN N τ ^ ((p.1 : ℕ) * N * (p.2 : ℕ)))
+
+lemma norm_wpTail_le {N a₁ : ℕ} (ha₁ : a₁ < N) (a₂ : ℕ) (p : ℕ+ × ℕ+) {τ : ℂ} (hτ : 0 ≤ τ.im) :
+    ‖wpTail N a₁ a₂ p τ‖ ≤ 4 * ((p.2 : ℕ) * ‖qN N τ‖ ^ ((p.1 : ℕ) * (p.2 : ℕ))) := by
+  obtain ⟨c, m⟩ := p
+  have hq1 := norm_qN_le_one N hτ
+  have hcN : (c : ℕ) ≤ (c : ℕ) * N - a₁ := by
+    have h1 : (c : ℕ) * (a₁ + 1) ≤ (c : ℕ) * N := Nat.mul_le_mul_left _ ha₁
+    have h2 : a₁ ≤ (c : ℕ) * a₁ := Nat.le_mul_of_pos_left _ c.pos
+    rw [mul_add, mul_one] at h1
+    omega
+  have e1 : (c : ℕ) * (m : ℕ) ≤ ((c : ℕ) * N + a₁) * (m : ℕ) :=
+    Nat.mul_le_mul_right _ (by nlinarith)
+  have e2 : (c : ℕ) * (m : ℕ) ≤ ((c : ℕ) * N - a₁) * (m : ℕ) := Nat.mul_le_mul_right _ hcN
+  have e3 : (c : ℕ) * (m : ℕ) ≤ (c : ℕ) * N * (m : ℕ) := Nat.mul_le_mul_right _ (by nlinarith)
+  have b1 : ‖qN N τ‖ ^ (((c : ℕ) * N + a₁) * (m : ℕ)) ≤ ‖qN N τ‖ ^ ((c : ℕ) * (m : ℕ)) :=
+    pow_le_pow_of_le_one (norm_nonneg _) hq1 e1
+  have b2 : ‖qN N τ‖ ^ (((c : ℕ) * N - a₁) * (m : ℕ)) ≤ ‖qN N τ‖ ^ ((c : ℕ) * (m : ℕ)) :=
+    pow_le_pow_of_le_one (norm_nonneg _) hq1 e2
+  have b3 : ‖qN N τ‖ ^ ((c : ℕ) * N * (m : ℕ)) ≤ ‖qN N τ‖ ^ ((c : ℕ) * (m : ℕ)) :=
+    pow_le_pow_of_le_one (norm_nonneg _) hq1 e3
+  have hz : ‖zetaN N‖ = 1 := norm_zetaN N
+  set ρ : ℝ := ‖qN N τ‖ with hρ
+  set A : ℂ := zetaN N ^ (a₂ * (m : ℕ)) * qN N τ ^ (((c : ℕ) * N + a₁) * (m : ℕ)) with hAdef
+  set B : ℂ := (zetaN N)⁻¹ ^ (a₂ * (m : ℕ)) * qN N τ ^ (((c : ℕ) * N - a₁) * (m : ℕ)) with hBdef
+  set C : ℂ := qN N τ ^ ((c : ℕ) * N * (m : ℕ)) with hCdef
+  have hA : ‖A‖ ≤ ρ ^ ((c : ℕ) * (m : ℕ)) := by
+    rw [hAdef, norm_mul, norm_pow, hz, one_pow, one_mul, norm_pow]; exact b1
+  have hB : ‖B‖ ≤ ρ ^ ((c : ℕ) * (m : ℕ)) := by
+    rw [hBdef, norm_mul, norm_pow, norm_inv, hz, inv_one, one_pow, one_mul, norm_pow]; exact b2
+  have hC : ‖(2 : ℂ) * C‖ ≤ 2 * ρ ^ ((c : ℕ) * (m : ℕ)) := by
+    rw [norm_mul, Complex.norm_ofNat, hCdef, norm_pow]; linarith
+  have hst : ‖A + B - 2 * C‖ ≤ 4 * ρ ^ ((c : ℕ) * (m : ℕ)) := by
+    linarith [norm_sub_le (A + B) (2 * C), norm_add_le A B]
+  change ‖((m : ℕ) : ℂ) * (A + B - 2 * C)‖ ≤ 4 * ((m : ℕ) * ρ ^ ((c : ℕ) * (m : ℕ)))
+  rw [norm_mul, Complex.norm_natCast]
+  calc ((m : ℕ) : ℝ) * ‖A + B - 2 * C‖ ≤ (m : ℕ) * (4 * ρ ^ ((c : ℕ) * (m : ℕ))) := by gcongr
+    _ = 4 * ((m : ℕ) * ρ ^ ((c : ℕ) * (m : ℕ))) := by ring
+
+lemma summable_wpTail_majorant {r : ℝ} (hr0 : 0 ≤ r) (hr : r < 1) :
+    Summable fun p : ℕ+ × ℕ+ ↦ 4 * ((p.2 : ℕ) * r ^ ((p.1 : ℕ) * (p.2 : ℕ))) := by
+  have h := summable_prod_mul_pow 1 (r := r) (by rwa [Real.norm_eq_abs, abs_of_nonneg hr0])
+  refine (h.mul_left 4).congr fun p ↦ ?_
+  simp
+
+def wpTorsion (N a₁ a₂ : ℕ) (τ : ℍ) : ℂ :=
+  PeriodPair.weierstrassP (periodPairOfTau τ) (((a₁ : ℂ) * τ + a₂) / N)
+
+def wpTorsionSeries (N a₁ a₂ : ℕ) (τ : ℂ) : ℂ :=
+  (2 * π * I) ^ 2 *
+    (zetaN N ^ a₂ * qN N τ ^ a₁ / (1 - zetaN N ^ a₂ * qN N τ ^ a₁) ^ 2 + 1 / 12 +
+      ∑' p : ℕ+ × ℕ+, wpTail N a₁ a₂ p τ)
+
+end Floor
+
+open WLight
+
+section R1_glue
+
+open scoped UpperHalfPlane Manifold
+open PeriodPair
+
+private lemma periodPair_eq_of_ω (L L' : PeriodPair) (h1 : L.ω₁ = L'.ω₁) (h2 : L.ω₂ = L'.ω₂) :
+    L = L' := by
+  rcases L with ⟨_, _, _⟩; rcases L' with ⟨_, _, _⟩
+  simp only [PeriodPair.mk.injEq]; exact ⟨h1, h2⟩
+
+private lemma L_eq_periodPairOfTau (L : ℍ → PeriodPair)
+    (hL : ∀ τ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1) : L = periodPairOfTau :=
+  funext fun τ ↦ periodPair_eq_of_ω _ _ (hL τ).1 (hL τ).2
+
+private lemma hL_ppT : ∀ τ : ℍ, (periodPairOfTau τ).ω₁ = (τ : ℂ) ∧ (periodPairOfTau τ).ω₂ = 1 :=
+  fun _ ↦ ⟨rfl, rfl⟩
+
+lemma wpTorsion_eq_wpTorsionSeries {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) (τ : ℍ) :
+    wpTorsion N a₁ a₂ τ = wpTorsionSeries N a₁ a₂ τ :=
+  (weierstrassP_qExpansion_package.2.2.2.1 periodPairOfTau hL_ppT N a₁ a₂ ha₁ ha₂ h0).1 τ
+
+theorem mdifferentiable_wpTorsion {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (wpTorsion N a₁ a₂) :=
+  (weierstrassP_qExpansion_package.2.2.2.1 periodPairOfTau hL_ppT N a₁ a₂ ha₁ ha₂ h0).2
+
+end R1_glue
+
+section RatGen
+p2m_open "UpperHalfPlane~I"
+p2m_open "ModularForm SlashInvariantForm ModularFormClass CuspForm ModularForm.CuspForm \
+  EisensteinSeries"
+open scoped MatrixGroups ArithmeticFunction.sigma
+
+def RatQExp {k : ℤ} (f : ModularForm 𝒮ℒ k) : Prop :=
+  ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 f).coeff n = (q : ℂ)
+
+section RatCoeffClosure
+
+lemma ratCoeff_mul {p q : PowerSeries ℂ}
+    (hp : ∀ n : ℕ, ∃ a : ℚ, p.coeff n = (a : ℂ)) (hq : ∀ n : ℕ, ∃ a : ℚ, q.coeff n = (a : ℂ)) :
+    ∀ n : ℕ, ∃ a : ℚ, (p * q).coeff n = (a : ℂ) := by
+  choose F hF using hp
+  choose G hG using hq
+  intro n
+  refine ⟨∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, F ij.1 * G ij.2, ?_⟩
+  rw [PowerSeries.coeff_mul]
+  push_cast
+  exact Finset.sum_congr rfl fun ij _ => by rw [hF, hG]
+
+lemma ratCoeff_sub {p q : PowerSeries ℂ}
+    (hp : ∀ n : ℕ, ∃ a : ℚ, p.coeff n = (a : ℂ)) (hq : ∀ n : ℕ, ∃ a : ℚ, q.coeff n = (a : ℂ)) :
+    ∀ n : ℕ, ∃ a : ℚ, (p - q).coeff n = (a : ℂ) := by
+  intro n
+  obtain ⟨a, ha⟩ := hp n
+  obtain ⟨b, hb⟩ := hq n
+  exact ⟨a - b, by rw [map_sub, ha, hb]; push_cast; ring⟩
+
+end RatCoeffClosure
+
+section RatGenerators
+
+lemma ratCoeff_E {k : ℕ} (hk : 3 ≤ k) (hk2 : Even k) :
+    ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 (E hk)).coeff n = (q : ℂ) := by
+  intro n
+  rw [E_qExpansion_coeff hk hk2]
+  by_cases hn : n = 0
+  · exact ⟨1, by simp [hn]⟩
+  · refine ⟨-(2 * k / bernoulli k) * (σ (k - 1) n : ℚ), ?_⟩
+    rw [ite_eq_right hn]
+    push_cast
+    ring
+
+def eCubeSubESq : ModularForm 𝒮ℒ 12 :=
+  ModularForm.mcast (by decide) (E₄.pow 3) - ModularForm.mcast (by decide) (E₆.pow 2)
+
+lemma eCubeSubESq_qExpansion :
+    qExpansion 1 eCubeSubESq = qExpansion 1 E₄ * qExpansion 1 E₄ * qExpansion 1 E₄ -
+      qExpansion 1 E₆ * qExpansion 1 E₆ := by
+  simp only [eCubeSubESq, FunLike.coe_sub, ModularForm.coe_mcast,
+    ModularForm.qExpansion_sub one_pos one_mem_strictPeriods_SL,
+    ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+  ring
+
+lemma discriminant_eq_smul_eCubeSubESq :
+    ModularForm.discriminant = (1 / 1728 : ℂ) • eCubeSubESq := by
+  ext z
+  have h := discriminant_eq_E₄_cube_sub_E₆_sq z
+  simp only [Pi.smul_apply, eCubeSubESq, FunLike.coe_sub, Pi.sub_apply,
+    ModularForm.coe_mcast, ModularForm.coe_pow, Pi.pow_apply, smul_eq_mul]
+  rw [h]
+  ring
+
+lemma ratCoeff_discriminant :
+    ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 ModularForm.discriminant).coeff n = (q : ℂ) := by
+  have h4 : ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 E₄).coeff n = (q : ℂ) :=
+    ratCoeff_E (by norm_num) (by decide)
+  have h6 : ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 E₆).coeff n = (q : ℂ) :=
+    ratCoeff_E (by norm_num) (by decide)
+  have hmain := ratCoeff_sub (ratCoeff_mul (ratCoeff_mul h4 h4) h4) (ratCoeff_mul h6 h6)
+  intro n
+  obtain ⟨a, ha⟩ := hmain n
+  refine ⟨(1 / 1728 : ℚ) * a, ?_⟩
+  rw [discriminant_eq_smul_eCubeSubESq,
+    ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL,
+    PowerSeries.coeff_smul, eCubeSubESq_qExpansion, smul_eq_mul, ha]
+  push_cast
+  ring
+
+lemma ratQExp_one : RatQExp (1 : ModularForm 𝒮ℒ 0) := by
+  intro n
+  refine ⟨if n = 0 then 1 else 0, ?_⟩
+  rw [ModularForm.qExpansion_one, PowerSeries.coeff_one]
+  split <;> simp
+
+end RatGenerators
+
+end RatGen
+
+section B4_qexp
+
+open scoped UpperHalfPlane Manifold
+p2m_open "UpperHalfPlane~I"
+
+def kN (N : ℕ) : IntermediateField ℚ ℂ := IntermediateField.adjoin ℚ {zetaN N}
+
+lemma zetaN_mem_kN (N : ℕ) : zetaN N ∈ kN N :=
+  IntermediateField.mem_adjoin_simple_self ℚ _
+
+lemma zetaN_pow_mem_kN (N k : ℕ) : zetaN N ^ k ∈ kN N := pow_mem (zetaN_mem_kN N) k
+
+lemma zetaN_inv_pow_mem_kN (N k : ℕ) : (zetaN N)⁻¹ ^ k ∈ kN N :=
+  pow_mem (inv_mem (zetaN_mem_kN N)) k
+
+lemma natCast_mem_kN (N m : ℕ) : (m : ℂ) ∈ kN N := natCast_mem _ m
+
+lemma one_div_twelve_mem_kN (N : ℕ) : (1 / 12 : ℂ) ∈ kN N :=
+  div_mem (one_mem _) (by exact_mod_cast natCast_mem_kN N 12)
+
+def wpNormSeries (N a₁ a₂ : ℕ) (τ : ℂ) : ℂ :=
+  zetaN N ^ a₂ * qN N τ ^ a₁ / (1 - zetaN N ^ a₂ * qN N τ ^ a₁) ^ 2 + 1 / 12 +
+    ∑' p : ℕ+ × ℕ+, wpTail N a₁ a₂ p τ
+
+lemma wpTorsionSeries_eq (N a₁ a₂ : ℕ) (τ : ℂ) :
+    wpTorsionSeries N a₁ a₂ τ = (2 * π * I) ^ 2 * wpNormSeries N a₁ a₂ τ := rfl
+
+def wpNorm (N a₁ a₂ : ℕ) (τ : ℍ) : ℂ := ((2 * π * I) ^ 2)⁻¹ * wpTorsion N a₁ a₂ τ
+
+lemma wpNorm_eq {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N) (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) (τ : ℍ) :
+    wpNorm N a₁ a₂ τ = wpNormSeries N a₁ a₂ τ := by
+  rw [wpNorm, wpTorsion_eq_wpTorsionSeries ha₁ ha₂ h0, wpTorsionSeries_eq,
+    inv_mul_cancel_left₀ (pow_ne_zero 2 Complex.two_pi_I_ne_zero)]
+
+lemma qN_add_natCast (N : ℕ) (hN : N ≠ 0) (τ : ℂ) : qN N (τ + N) = qN N τ := by
+  have : (N : ℂ) ≠ 0 := by exact_mod_cast hN
+  rw [qN, qN, mul_add, add_div, Complex.exp_add, mul_div_cancel_right₀ _ this,
+    Complex.exp_two_pi_mul_I, mul_one]
+
+lemma wpTail_add_natCast {N : ℕ} (hN : N ≠ 0) (a₁ a₂ : ℕ) (p : ℕ+ × ℕ+) (τ : ℂ) :
+    wpTail N a₁ a₂ p (τ + N) = wpTail N a₁ a₂ p τ := by
+  simp only [wpTail, qN_add_natCast N hN]
+
+lemma wpNormSeries_add_natCast {N : ℕ} (hN : N ≠ 0) (a₁ a₂ : ℕ) (τ : ℂ) :
+    wpNormSeries N a₁ a₂ (τ + N) = wpNormSeries N a₁ a₂ τ := by
+  simp only [wpNormSeries, qN_add_natCast N hN, wpTail_add_natCast hN]
+
+theorem periodic_wpNorm {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N) (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) :
+    Function.Periodic (wpNorm N a₁ a₂ ∘ ofComplex) N := by
+  have hN : N ≠ 0 := by omega
+  intro τ
+  simp only [Function.comp_apply]
+  rcases le_or_gt τ.im 0 with hτ | hτ
+  · rw [ofComplex_apply_eq_of_im_nonpos (by simpa using hτ) hτ]
+  · have hτ' : 0 < (τ + N).im := by simpa using hτ
+    rw [ofComplex_apply_of_im_pos hτ', ofComplex_apply_of_im_pos hτ, wpNorm_eq ha₁ ha₂ h0,
+      wpNorm_eq ha₁ ha₂ h0]
+    push_cast
+    exact wpNormSeries_add_natCast hN a₁ a₂ τ
+
+theorem mdifferentiable_wpNorm {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (wpNorm N a₁ a₂) :=
+  (mdifferentiable_wpTorsion ha₁ ha₂ h0).const_smul ((2 * π * I) ^ 2)⁻¹
+
+lemma norm_wpNormSeries_le {N a₁ : ℕ} (ha₁ : a₁ < N) (a₂ : ℕ) :
+    ∃ M : ℝ, ∀ τ : ℂ, 1 ≤ τ.im → ‖wpNormSeries N a₁ a₂ τ‖ ≤ M := by
+  have hN : 0 < N := by omega
+  set ρ : ℝ := Real.exp (-(2 * π * 1 / N)) with hρ
+  have hρ0 : 0 ≤ ρ := (Real.exp_pos _).le
+  have hρ1 : ρ < 1 := by
+    rw [hρ, Real.exp_lt_one_iff, neg_lt_zero]
+    have : (0 : ℝ) < N := by exact_mod_cast hN
+    positivity
+  obtain ⟨T, hT⟩ := summable_wpTail_majorant hρ0 hρ1
+  set K : ℂ := zetaN N ^ a₂ / (1 - zetaN N ^ a₂) ^ 2 with hK
+  refine ⟨‖K‖ + 1 / (1 - ρ) ^ 2 + ‖(1 / 12 : ℂ)‖ + T, fun τ hτ ↦ ?_⟩
+  have hq : ‖qN N τ‖ ≤ ρ := norm_qN_le_of_le_im N hτ
+  have hqa : ‖zetaN N ^ a₂ * qN N τ ^ a₁‖ ≤ ρ ^ a₁ := by
+    rw [norm_mul, norm_pow, norm_zetaN, one_pow, one_mul, norm_pow]
+    exact pow_le_pow_left₀ (norm_nonneg _) hq a₁
+  have hhead : ‖zetaN N ^ a₂ * qN N τ ^ a₁ / (1 - zetaN N ^ a₂ * qN N τ ^ a₁) ^ 2‖ ≤
+      ‖K‖ + 1 / (1 - ρ) ^ 2 := by
+    have hKn : 0 ≤ ‖K‖ := norm_nonneg _
+    have hρn : (0 : ℝ) ≤ 1 / (1 - ρ) ^ 2 := by positivity
+    rcases Nat.eq_zero_or_pos a₁ with ha | ha
+    · subst ha
+      simp only [pow_zero, mul_one, ← hK]
+      linarith
+    · set r := zetaN N ^ a₂ * qN N τ ^ a₁ with hr
+      have hr1 : ‖r‖ ≤ ρ := hqa.trans (pow_le_of_le_one hρ0 hρ1.le ha.ne')
+      have h1r : 1 - ρ ≤ ‖1 - r‖ := by
+        have := norm_sub_norm_le (1 : ℂ) r
+        rw [norm_one] at this
+        linarith
+      have hpos : 0 < 1 - ρ := by linarith
+      have : ‖r / (1 - r) ^ 2‖ ≤ 1 / (1 - ρ) ^ 2 := by
+        rw [norm_div, norm_pow]
+        have hr' : ‖r‖ ≤ 1 := hr1.trans hρ1.le
+        have hden : (1 - ρ) ^ 2 ≤ ‖1 - r‖ ^ 2 := pow_le_pow_left₀ hpos.le h1r 2
+        have hden0 : 0 < ‖1 - r‖ ^ 2 := lt_of_lt_of_le (by positivity) hden
+        rw [div_le_div_iff₀ hden0 (by positivity), one_mul]
+        nlinarith [norm_nonneg r]
+      linarith
+  have htail : ‖∑' p : ℕ+ × ℕ+, wpTail N a₁ a₂ p τ‖ ≤ T :=
+    tsum_of_norm_bounded hT fun p ↦ (norm_wpTail_le ha₁ a₂ p (by linarith)).trans (by gcongr)
+  unfold wpNormSeries
+  refine (norm_add_le _ _).trans ?_
+  refine (add_le_add (norm_add_le _ _) le_rfl).trans ?_
+  linarith
+
+theorem isBoundedAtImInfty_wpNorm {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) : IsBoundedAtImInfty (wpNorm N a₁ a₂) := by
+  obtain ⟨M, hM⟩ := norm_wpNormSeries_le ha₁ a₂
+  rw [isBoundedAtImInfty_iff]
+  exact ⟨M, 1, fun τ hτ ↦ by rw [wpNorm_eq ha₁ ha₂ h0]; exact hM τ hτ⟩
+
+abbrev WpIdx : Type := Unit ⊕ ℕ+ ⊕ ((ℕ+ × ℕ+) × Fin 3)
+
+def wpMonCoeff (N a₁ a₂ : ℕ) : WpIdx → ℂ
+  | Sum.inl _ => 1 / 12 + if a₁ = 0 then zetaN N ^ a₂ / (1 - zetaN N ^ a₂) ^ 2 else 0
+  | Sum.inr (Sum.inl m) => if a₁ = 0 then 0 else ((m : ℕ) : ℂ) * zetaN N ^ (a₂ * (m : ℕ))
+  | Sum.inr (Sum.inr (p, i)) =>
+      ![((p.2 : ℕ) : ℂ) * zetaN N ^ (a₂ * (p.2 : ℕ)),
+        ((p.2 : ℕ) : ℂ) * (zetaN N)⁻¹ ^ (a₂ * (p.2 : ℕ)),
+        -2 * ((p.2 : ℕ) : ℂ)] i
+
+def wpMonExp (N a₁ : ℕ) : WpIdx → ℕ
+  | Sum.inl _ => 0
+  | Sum.inr (Sum.inl m) => if a₁ = 0 then (m : ℕ) else a₁ * (m : ℕ)
+  | Sum.inr (Sum.inr (p, i)) =>
+      ![((p.1 : ℕ) * N + a₁) * (p.2 : ℕ), ((p.1 : ℕ) * N - a₁) * (p.2 : ℕ),
+        (p.1 : ℕ) * N * (p.2 : ℕ)] i
+
+def wpQCoeff (N a₁ a₂ : ℕ) (n : ℕ) : ℂ :=
+  ∑' i : (wpMonExp N a₁ ⁻¹' {n}), wpMonCoeff N a₁ a₂ i
+
+lemma wpMonCoeff_mem_kN (N a₁ a₂ : ℕ) (i : WpIdx) : wpMonCoeff N a₁ a₂ i ∈ kN N := by
+  rcases i with u | m | ⟨p, i⟩
+  · simp only [wpMonCoeff]
+    split_ifs
+    · exact add_mem (one_div_twelve_mem_kN N) (div_mem (zetaN_pow_mem_kN N _)
+        (pow_mem (sub_mem (one_mem _) (zetaN_pow_mem_kN N _)) 2))
+    · exact add_mem (one_div_twelve_mem_kN N) (zero_mem _)
+  · simp only [wpMonCoeff]
+    split_ifs
+    · exact zero_mem _
+    · exact mul_mem (natCast_mem_kN N _) (zetaN_pow_mem_kN N _)
+  · simp only [wpMonCoeff]
+    fin_cases i
+    · exact mul_mem (natCast_mem_kN N _) (zetaN_pow_mem_kN N _)
+    · exact mul_mem (natCast_mem_kN N _) (zetaN_inv_pow_mem_kN N _)
+    · simp only [Fin.reduceFinMk, Matrix.cons_val]
+      exact mul_mem (neg_mem (by exact_mod_cast natCast_mem_kN N 2)) (natCast_mem_kN N _)
+
+lemma le_mul_sub_of_lt {N a₁ : ℕ} (ha₁ : a₁ < N) (c : ℕ+) : (c : ℕ) ≤ (c : ℕ) * N - a₁ := by
+  have h1 : (c : ℕ) * (a₁ + 1) ≤ (c : ℕ) * N := Nat.mul_le_mul_left _ ha₁
+  have h2 : a₁ ≤ (c : ℕ) * a₁ := Nat.le_mul_of_pos_left _ c.pos
+  rw [mul_add, mul_one] at h1
+  omega
+
+lemma le_wpMonExp_tail {N a₁ : ℕ} (ha₁ : a₁ < N) (p : ℕ+ × ℕ+) (i : Fin 3) :
+    (p.1 : ℕ) ≤ wpMonExp N a₁ (Sum.inr (Sum.inr (p, i))) ∧
+      (p.2 : ℕ) ≤ wpMonExp N a₁ (Sum.inr (Sum.inr (p, i))) := by
+  have hc := le_mul_sub_of_lt ha₁ p.1
+  have hm : 1 ≤ (p.2 : ℕ) := p.2.pos
+  have hc1 : 1 ≤ (p.1 : ℕ) := p.1.pos
+  have key : ∀ A : ℕ, (p.1 : ℕ) ≤ A → (p.1 : ℕ) ≤ A * (p.2 : ℕ) ∧ (p.2 : ℕ) ≤ A * (p.2 : ℕ) :=
+    fun A hA ↦ ⟨hA.trans (Nat.le_mul_of_pos_right _ p.2.pos),
+      Nat.le_mul_of_pos_left _ (lt_of_lt_of_le p.1.pos hA)⟩
+  have hN : 0 < N := by omega
+  fin_cases i
+  · exact key _ (le_add_right (Nat.le_mul_of_pos_right _ hN))
+  · exact key _ hc
+  · exact key _ (Nat.le_mul_of_pos_right _ hN)
+
+lemma finite_wpMonExp_fiber {N a₁ : ℕ} (ha₁ : a₁ < N) (n : ℕ) :
+    (wpMonExp N a₁ ⁻¹' {n}).Finite := by
+  classical
+  let φ : Unit ⊕ Fin (n + 1) ⊕ ((Fin (n + 1) × Fin (n + 1)) × Fin 3) → WpIdx :=
+    Sum.map id (Sum.map (fun k ↦ Nat.toPNat' k)
+      (Prod.map (Prod.map (fun k ↦ Nat.toPNat' k) (fun k ↦ Nat.toPNat' k)) id))
+  refine (Set.finite_range φ).subset ?_
+  rintro (u | m | ⟨⟨c, m⟩, i⟩) hi <;>
+    simp only [Set.mem_preimage, Set.mem_singleton_iff] at hi
+  · exact ⟨Sum.inl u, rfl⟩
+  · have hm : (m : ℕ) ≤ n := by
+      simp only [wpMonExp] at hi
+      split_ifs at hi with h
+      · omega
+      · have : 1 ≤ a₁ := Nat.pos_of_ne_zero h
+        nlinarith
+    refine ⟨Sum.inr (Sum.inl ⟨m, by omega⟩), ?_⟩
+    simp [φ, PNat.coe_toPNat']
+  · obtain ⟨hc, hm⟩ := le_wpMonExp_tail ha₁ (c, m) i
+    dsimp only at hc hm
+    rw [hi] at hc hm
+    refine ⟨Sum.inr (Sum.inr ((⟨c, Nat.lt_succ_of_le hc⟩, ⟨m, Nat.lt_succ_of_le hm⟩), i)), ?_⟩
+    simp [φ, PNat.coe_toPNat']
+
+theorem wpQCoeff_mem_kN {N a₁ : ℕ} (ha₁ : a₁ < N) (a₂ n : ℕ) : wpQCoeff N a₁ a₂ n ∈ kN N := by
+  have := (finite_wpMonExp_fiber ha₁ n).to_subtype
+  have := Fintype.ofFinite (wpMonExp N a₁ ⁻¹' {n})
+  rw [wpQCoeff, tsum_fintype]
+  exact sum_mem fun i _ ↦ wpMonCoeff_mem_kN N a₁ a₂ i
+
+lemma summable_comp_fst_fin {β : Type*} {g : β → ℝ} (hg0 : ∀ b, 0 ≤ g b) (hg : Summable g)
+    (k : ℕ) : Summable fun x : β × Fin k ↦ g x.1 := by
+  classical
+  refine summable_of_sum_le (fun x ↦ hg0 x.1) (c := k * ∑' b, g b) fun u ↦ ?_
+  calc ∑ x ∈ u, g x.1 ≤ ∑ x ∈ (u.image Prod.fst) ×ˢ (Finset.univ : Finset (Fin k)), g x.1 :=
+        Finset.sum_le_sum_of_subset_of_nonneg
+          (fun x hx ↦ Finset.mem_product.mpr ⟨Finset.mem_image_of_mem _ hx, Finset.mem_univ _⟩)
+          (fun _ _ _ ↦ hg0 _)
+    _ = ∑ b ∈ u.image Prod.fst, (k : ℝ) * g b := by
+        rw [Finset.sum_product]
+        simp
+    _ = k * ∑ b ∈ u.image Prod.fst, g b := (Finset.mul_sum _ _ _).symm
+    _ ≤ k * ∑' b, g b := by
+        gcongr
+        exact hg.sum_le_tsum _ fun b _ ↦ hg0 b
+
+theorem hasSum_wpMon {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) {τ : ℂ} (hτ : 0 < τ.im) :
+    HasSum (fun i : WpIdx ↦ wpMonCoeff N a₁ a₂ i * qN N τ ^ wpMonExp N a₁ i)
+      (wpNormSeries N a₁ a₂ τ) := by
+  have hN : 0 < N := by omega
+  set q : ℂ := qN N τ with hqdef
+  have hq : ‖q‖ < 1 := norm_qN_lt_one hN hτ
+  set G : WpIdx → ℂ := fun i ↦ wpMonCoeff N a₁ a₂ i * q ^ wpMonExp N a₁ i with hG
+  set r : ℂ := zetaN N ^ a₂ * q ^ a₁ with hr
+  have h1 : HasSum (G ∘ Sum.inl)
+      (1 / 12 + if a₁ = 0 then zetaN N ^ a₂ / (1 - zetaN N ^ a₂) ^ 2 else 0) := by
+    have := hasSum_fintype (G ∘ Sum.inl)
+    simpa [hG, wpMonCoeff, wpMonExp] using this
+  have h2 : HasSum (G ∘ Sum.inr ∘ Sum.inl) (if a₁ = 0 then 0 else r / (1 - r) ^ 2) := by
+    by_cases ha : a₁ = 0
+    · simp only [ha, ite_true]
+      convert hasSum_zero with m
+      simp [hG, wpMonCoeff, ha]
+    · simp only [ha, ite_false]
+      have hr1 : ‖r‖ < 1 := by
+        rw [hr, norm_mul, norm_pow, norm_zetaN, one_pow, one_mul, norm_pow]
+        exact pow_lt_one₀ (norm_nonneg _) hq ha
+      have hgeo := hasSum_coe_mul_geometric_of_norm_lt_one hr1
+      have hs : Summable fun m : ℕ+ ↦ ((m : ℕ) : ℂ) * r ^ (m : ℕ) :=
+        summable_pnat_iff_summable_nat.mpr hgeo.summable
+      have h2' : HasSum (fun m : ℕ+ ↦ ((m : ℕ) : ℂ) * r ^ (m : ℕ)) (r / (1 - r) ^ 2) := by
+        rw [hs.hasSum_iff, ← hgeo.tsum_eq, ← tsum_zero_pnat_eq_tsum_nat hgeo.summable]
+        simp
+      refine h2'.congr_fun fun m ↦ ?_
+      simp only [hG, Function.comp_apply, wpMonCoeff, wpMonExp, ha, ite_false, hr]
+      rw [mul_pow, ← pow_mul, ← pow_mul]
+      ring
+  have hmaj := summable_comp_fst_fin (fun p ↦ by positivity)
+    (summable_wpTail_majorant (norm_nonneg q) hq) 3
+  have hq1 : ‖q‖ ≤ 1 := hq.le
+  have hbound : ∀ x : (ℕ+ × ℕ+) × Fin 3, ‖(G ∘ Sum.inr ∘ Sum.inr) x‖ ≤
+      4 * ((x.1.2 : ℕ) * ‖q‖ ^ ((x.1.1 : ℕ) * (x.1.2 : ℕ))) := by
+    rintro ⟨⟨c, m⟩, i⟩
+    obtain ⟨hc, hm⟩ := le_wpMonExp_tail ha₁ (c, m) i
+    have hcm : (c : ℕ) * (m : ℕ) ≤ wpMonExp N a₁ (Sum.inr (Sum.inr ((c, m), i))) := by
+      fin_cases i
+      · exact Nat.mul_le_mul_right _ (le_add_right (Nat.le_mul_of_pos_right _ hN))
+      · exact Nat.mul_le_mul_right _ (le_mul_sub_of_lt ha₁ c)
+      · exact Nat.mul_le_mul_right _ (Nat.le_mul_of_pos_right _ hN)
+    have hpow : ‖q‖ ^ wpMonExp N a₁ (Sum.inr (Sum.inr ((c, m), i))) ≤ ‖q‖ ^ ((c : ℕ) * (m : ℕ)) :=
+      pow_le_pow_of_le_one (norm_nonneg _) hq1 hcm
+    have hz : ‖zetaN N‖ = 1 := norm_zetaN N
+    have hcoef : ‖wpMonCoeff N a₁ a₂ (Sum.inr (Sum.inr ((c, m), i)))‖ ≤ 2 * (m : ℕ) := by
+      fin_cases i <;> simp [wpMonCoeff, hz]
+    simp only [Function.comp_apply, hG, norm_mul, norm_pow]
+    have hm0 : (0 : ℝ) ≤ (m : ℕ) := by positivity
+    calc ‖wpMonCoeff N a₁ a₂ (Sum.inr (Sum.inr ((c, m), i)))‖ *
+          ‖q‖ ^ wpMonExp N a₁ (Sum.inr (Sum.inr ((c, m), i)))
+        ≤ (2 * (m : ℕ)) * ‖q‖ ^ ((c : ℕ) * (m : ℕ)) := by gcongr
+      _ ≤ 4 * ((m : ℕ) * ‖q‖ ^ ((c : ℕ) * (m : ℕ))) := by
+        nlinarith [pow_nonneg (norm_nonneg q) ((c : ℕ) * (m : ℕ))]
+  have hs3 : Summable (G ∘ Sum.inr ∘ Sum.inr) := Summable.of_norm_bounded hmaj hbound
+  have h3 : HasSum (G ∘ Sum.inr ∘ Sum.inr) (∑' p : ℕ+ × ℕ+, wpTail N a₁ a₂ p τ) := by
+    rw [hs3.hasSum_iff, hs3.tsum_prod]
+    refine tsum_congr fun p ↦ ?_
+    rw [tsum_fintype, Fin.sum_univ_three]
+    simp only [Function.comp_apply, hG, wpMonCoeff, wpMonExp, wpTail, Matrix.cons_val_zero,
+      Matrix.cons_val_one, Matrix.cons_val, hqdef]
+    ring
+   -- giving `f` here speeds elaboration enormously (60435)
+  have hall := h1.sum (h2.sum h3)
+  have heq : (1 / 12 + if a₁ = 0 then zetaN N ^ a₂ / (1 - zetaN N ^ a₂) ^ 2 else 0) +
+      ((if a₁ = 0 then 0 else r / (1 - r) ^ 2) + ∑' p : ℕ+ × ℕ+, wpTail N a₁ a₂ p τ) =
+      wpNormSeries N a₁ a₂ τ := by
+    by_cases ha : a₁ = 0
+    · subst ha
+      rw [ite_eq_left rfl, ite_eq_left rfl]
+      unfold wpNormSeries
+      rw [← hqdef, pow_zero, mul_one]
+      ring
+    · rw [ite_eq_right ha, ite_eq_right ha]
+      unfold wpNormSeries
+      rw [← hqdef, ← hr]
+      ring
+  rw [← heq]
+  exact hall
+
+theorem hasSum_wpQCoeff {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) {τ : ℂ} (hτ : 0 < τ.im) :
+    HasSum (fun n ↦ wpQCoeff N a₁ a₂ n * qN N τ ^ n) (wpNormSeries N a₁ a₂ τ) := by
+  refine ((hasSum_wpMon (a₂ := a₂) ha₁ hτ).tsum_fiberwise (wpMonExp N a₁)).congr_fun fun n ↦ ?_
+  rw [wpQCoeff, ← tsum_mul_right]
+  exact tsum_congr fun i ↦ by rw [show wpMonExp N a₁ i = n from i.2]
+
+theorem qExpansion_wpNorm_coeff {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) (n : ℕ) :
+    (qExpansion N (wpNorm N a₁ a₂)).coeff n = wpQCoeff N a₁ a₂ n := by
+  have hN : (0 : ℝ) < N := by exact_mod_cast (show 0 < N by omega)
+  let f' : C(ℍ, ℂ) := ⟨wpNorm N a₁ a₂, (mdifferentiable_wpNorm ha₁ ha₂ h0).continuous⟩
+  have hfan : AnalyticAt ℂ (cuspFunction N f') 0 :=
+    analyticAt_cuspFunction_zero hN (periodic_wpNorm ha₁ ha₂ h0)
+      (mdifferentiable_wpNorm ha₁ ha₂ h0) (isBoundedAtImInfty_wpNorm ha₁ ha₂ h0)
+  have hf : ∀ τ : ℍ, HasSum (fun m ↦ wpQCoeff N a₁ a₂ m • Function.Periodic.qParam N τ ^ m)
+      (f' τ) := by
+    intro τ
+    have h := hasSum_wpQCoeff (a₂ := a₂) ha₁ (τ := (τ : ℂ)) τ.im_pos
+    rw [← wpNorm_eq ha₁ ha₂ h0] at h
+    refine h.congr_fun fun m ↦ ?_
+    simp only [smul_eq_mul, Function.Periodic.qParam, qN, Complex.ofReal_natCast]
+  exact (qExpansion_coeff_unique f' hN hfan hf n).symm
+
+theorem qExpansion_wpNorm_coeff_mem_kN {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) (n : ℕ) :
+    (qExpansion N (wpNorm N a₁ a₂)).coeff n ∈ kN N := by
+  rw [qExpansion_wpNorm_coeff ha₁ ha₂ h0]
+  exact wpQCoeff_mem_kN ha₁ a₂ n
+
+theorem hasSum_qExpansion_wpNorm {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) (τ : ℍ) :
+    HasSum (fun m : ℕ ↦ (qExpansion N (wpNorm N a₁ a₂)).coeff m •
+      Function.Periodic.qParam N τ ^ m) (wpNorm N a₁ a₂ τ) :=
+  hasSum_qExpansion (by exact_mod_cast (show 0 < N by omega)) (periodic_wpNorm ha₁ ha₂ h0)
+    (mdifferentiable_wpNorm ha₁ ha₂ h0) (isBoundedAtImInfty_wpNorm ha₁ ha₂ h0) τ
+
+lemma qParam_one_eq_pow {N : ℕ} (hN : N ≠ 0) (τ : ℂ) :
+    Function.Periodic.qParam 1 τ = Function.Periodic.qParam N τ ^ N := by
+  have : (N : ℂ) ≠ 0 := by exact_mod_cast hN
+  simp only [Function.Periodic.qParam, Complex.ofReal_one, div_one, Complex.ofReal_natCast]
+  rw [← Complex.exp_nat_mul]
+  congr 1
+  field_simp
+
+private theorem _root_.WLightR2.qExpansion_coeff_width (f : ℍ → ℂ) {N : ℕ} (hN : N ≠ 0)
+    (hper : Function.Periodic (f ∘ ofComplex) 1) (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f)
+    (hbd : IsBoundedAtImInfty f) (n : ℕ) :
+    (qExpansion N f).coeff n =
+      if N ∣ n then (qExpansion 1 f).coeff (n / N) else 0 := by
+  have hN' : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero hN
+  have hperN : Function.Periodic (f ∘ ofComplex) N := by
+    simpa using hper.nat_mul N
+  let f' : C(ℍ, ℂ) := ⟨f, hhol.continuous⟩
+  have hfan : AnalyticAt ℂ (cuspFunction N f') 0 :=
+    analyticAt_cuspFunction_zero hN' hperN hhol hbd
+  set c : ℕ → ℂ := fun n ↦ if N ∣ n then (qExpansion 1 f).coeff (n / N) else 0 with hc
+  have hf : ∀ τ : ℍ, HasSum (fun m ↦ c m • Function.Periodic.qParam N τ ^ m) (f' τ) := by
+    intro τ
+    have h1 := hasSum_qExpansion one_pos hper hhol hbd τ
+    have hinj : Function.Injective fun m : ℕ ↦ N * m := fun a b h ↦ by
+      simpa [Nat.mul_right_inj hN] using h
+    refine (hinj.hasSum_iff (f := fun m ↦ c m • Function.Periodic.qParam N τ ^ m) ?_).mp ?_
+    · intro x hx
+      have : ¬ N ∣ x := fun ⟨k, hk⟩ ↦ hx ⟨k, hk.symm⟩
+      simp [hc, this]
+    · refine h1.congr_fun fun m ↦ ?_
+      simp only [Function.comp_apply, hc, Nat.dvd_mul_right, ite_true,
+        Nat.mul_div_cancel_left _ (Nat.pos_of_ne_zero hN), qParam_one_eq_pow hN, ← pow_mul]
+  exact (qExpansion_coeff_unique f' hN' hfan hf n).symm
+
+p2m_export "WLightR2" "qExpansion_coeff_width"
+
+def wpFib (N a₁ a₂ n : ℕ) (i : WpIdx) : ℂ :=
+  if wpMonExp N a₁ i = n then wpMonCoeff N a₁ a₂ i else 0
+
+lemma wpQCoeff_eq_tsum_wpFib (N a₁ a₂ n : ℕ) :
+    wpQCoeff N a₁ a₂ n = ∑' i, wpFib N a₁ a₂ n i := by
+  rw [wpQCoeff, tsum_subtype]
+  refine tsum_congr fun i ↦ ?_
+  unfold wpFib
+  split_ifs with h
+  · exact Set.indicator_of_mem (by simpa using h) _
+  · exact Set.indicator_of_notMem (by simpa using h) _
+
+lemma summable_wpFib_all {N a₁ : ℕ} (ha₁ : a₁ < N) (a₂ n : ℕ) :
+    Summable (wpFib N a₁ a₂ n) := by
+  apply summable_of_hasFiniteSupport
+  change (Function.support (wpFib N a₁ a₂ n)).Finite
+  apply (finite_wpMonExp_fiber ha₁ n).subset
+  intro i hi
+  rw [Set.mem_preimage, Set.mem_singleton_iff]
+  by_contra h'
+  apply hi
+  change (if wpMonExp N a₁ i = n then wpMonCoeff N a₁ a₂ i else 0) = 0
+  rw [ite_eq_right h']
+
+lemma summable_wpFib {N a₁ : ℕ} (ha₁ : a₁ < N) (a₂ n : ℕ) {ι : Type} (e : ι → WpIdx)
+    (he : Function.Injective e) : Summable (wpFib N a₁ a₂ n ∘ e) :=
+  (summable_wpFib_all ha₁ a₂ n).comp_injective he
+
+lemma tsum_wpFib_split {N a₁ : ℕ} (ha₁ : a₁ < N) (a₂ n : ℕ) :
+    ∑' i, wpFib N a₁ a₂ n i = wpFib N a₁ a₂ n (Sum.inl ()) +
+      ((∑' m : ℕ+, wpFib N a₁ a₂ n (Sum.inr (Sum.inl m))) +
+        ∑' x : (ℕ+ × ℕ+) × Fin 3, wpFib N a₁ a₂ n (Sum.inr (Sum.inr x))) := by
+  set F : WpIdx → ℂ := wpFib N a₁ a₂ n with hF
+  have h1 : Summable (F ∘ Sum.inl) := summable_wpFib ha₁ a₂ n Sum.inl Sum.inl_injective
+  have h2 : Summable ((F ∘ Sum.inr) ∘ Sum.inl) :=
+    summable_wpFib ha₁ a₂ n (fun m ↦ Sum.inr (Sum.inl m))
+      (Sum.inr_injective.comp Sum.inl_injective)
+  have h3 : Summable ((F ∘ Sum.inr) ∘ Sum.inr) :=
+    summable_wpFib ha₁ a₂ n (fun x ↦ Sum.inr (Sum.inr x))
+      (Sum.inr_injective.comp Sum.inr_injective)
+  have h23 : Summable (F ∘ Sum.inr) := Summable.sum (F ∘ Sum.inr) h2 h3
+  have e1 : ∑' i, F i = (∑' u, F (Sum.inl u)) + ∑' j, F (Sum.inr j) := Summable.tsum_sum h1 h23
+  have e2 : ∑' j, (F ∘ Sum.inr) j = (∑' m, (F ∘ Sum.inr) (Sum.inl m)) +
+      ∑' x, (F ∘ Sum.inr) (Sum.inr x) := Summable.tsum_sum h2 h3
+  have e3 : ∑' u : Unit, F (Sum.inl u) = F (Sum.inl ()) := by
+    rw [tsum_fintype, Fintype.sum_unique]
+  rw [e1, e3]
+  exact congrArg _ e2
+
+theorem wpQCoeff_zero {N a₁ : ℕ} (ha₁ : a₁ < N) (a₂ : ℕ) :
+    wpQCoeff N a₁ a₂ 0 =
+      1 / 12 + if a₁ = 0 then zetaN N ^ a₂ / (1 - zetaN N ^ a₂) ^ 2 else 0 := by
+  rw [wpQCoeff_eq_tsum_wpFib, tsum_wpFib_split ha₁]
+  have e1 : wpFib N a₁ a₂ 0 (Sum.inl ()) =
+      1 / 12 + if a₁ = 0 then zetaN N ^ a₂ / (1 - zetaN N ^ a₂) ^ 2 else 0 := by
+    simp [wpFib, wpMonExp, wpMonCoeff]
+  have e2 : ∀ m : ℕ+, wpFib N a₁ a₂ 0 (Sum.inr (Sum.inl m)) = 0 := by
+    intro m
+    have : wpMonExp N a₁ (Sum.inr (Sum.inl m)) ≠ 0 := by
+      simp only [wpMonExp]
+      split_ifs with h
+      · exact m.ne_zero
+      · exact Nat.mul_ne_zero h m.ne_zero
+    simp [wpFib, this]
+  have e3 : ∀ x : (ℕ+ × ℕ+) × Fin 3, wpFib N a₁ a₂ 0 (Sum.inr (Sum.inr x)) = 0 := by
+    rintro ⟨p, i⟩
+    have := (le_wpMonExp_tail ha₁ p i).2
+    have hne : wpMonExp N a₁ (Sum.inr (Sum.inr (p, i))) ≠ 0 := by
+      have := p.2.pos; omega
+    simp [wpFib, hne]
+  simp [e1, e2, e3]
+
+theorem wpQCoeff_of_lt {N a₁ : ℕ} (ha₁ : a₁ < N) (a₂ : ℕ) {n : ℕ} (hn0 : 0 < n) (hn : n < N) :
+    wpQCoeff N a₁ a₂ n =
+      (if a₁ ≠ 0 ∧ a₁ ∣ n then ((n / a₁ : ℕ) : ℂ) * zetaN N ^ (a₂ * (n / a₁)) else 0) +
+        (if (N - a₁) ∣ n then
+          ((n / (N - a₁) : ℕ) : ℂ) * (zetaN N)⁻¹ ^ (a₂ * (n / (N - a₁))) else 0) := by
+  rw [wpQCoeff_eq_tsum_wpFib, tsum_wpFib_split ha₁]
+  have hNa : 0 < N - a₁ := Nat.sub_pos_of_lt ha₁
+  have e1 : wpFib N a₁ a₂ n (Sum.inl ()) = 0 := by
+    simp [wpFib, wpMonExp, hn0.ne]
+  have e2 : ∑' m : ℕ+, wpFib N a₁ a₂ n (Sum.inr (Sum.inl m)) =
+      if a₁ ≠ 0 ∧ a₁ ∣ n then ((n / a₁ : ℕ) : ℂ) * zetaN N ^ (a₂ * (n / a₁)) else 0 := by
+    by_cases ha : a₁ = 0
+    · simp [wpFib, wpMonCoeff, ha]
+    · set m₁ : ℕ+ := (n / a₁).toPNat' with hm₁
+      rw [tsum_eq_single m₁]
+      · by_cases hd : a₁ ∣ n
+        · have hq : 0 < n / a₁ := Nat.div_pos (Nat.le_of_dvd hn0 hd) (Nat.pos_of_ne_zero ha)
+          have hm₁v : (m₁ : ℕ) = n / a₁ := by rw [hm₁, Nat.toPNat'_coe, ite_eq_left hq]
+          have hE : wpMonExp N a₁ (Sum.inr (Sum.inl m₁)) = n := by
+            simp only [wpMonExp, ha, ite_false, hm₁v, Nat.mul_div_cancel' hd]
+          simp [wpFib, hE, wpMonCoeff, ha, hd, hm₁v]
+        · have hE : wpMonExp N a₁ (Sum.inr (Sum.inl m₁)) ≠ n := by
+            simp only [wpMonExp, ha, ite_false]
+            exact fun h ↦ hd ⟨m₁, h.symm⟩
+          simp [wpFib, hE, ha, hd]
+      · intro m hm
+        have hE : wpMonExp N a₁ (Sum.inr (Sum.inl m)) ≠ n := by
+          simp only [wpMonExp, ha, ite_false]
+          intro h
+          apply hm
+          apply PNat.coe_injective
+          have : (m : ℕ) = n / a₁ := by
+            rw [← h, Nat.mul_div_cancel_left _ (Nat.pos_of_ne_zero ha)]
+          rw [this, hm₁, Nat.toPNat'_coe, ite_eq_left]
+          rw [← this]; exact m.pos
+        simp [wpFib, hE]
+  have e3 : ∑' x : (ℕ+ × ℕ+) × Fin 3, wpFib N a₁ a₂ n (Sum.inr (Sum.inr x)) =
+      if (N - a₁) ∣ n then
+        ((n / (N - a₁) : ℕ) : ℂ) * (zetaN N)⁻¹ ^ (a₂ * (n / (N - a₁))) else 0 := by
+    set m₀ : ℕ+ := (n / (N - a₁)).toPNat' with hm₀
+    set x₀ : (ℕ+ × ℕ+) × Fin 3 := ((1, m₀), 1) with hx₀
+    have key : ∀ x : (ℕ+ × ℕ+) × Fin 3, wpMonExp N a₁ (Sum.inr (Sum.inr x)) = n →
+        x = x₀ ∧ (N - a₁) ∣ n := by
+      rintro ⟨⟨c, m⟩, i⟩ hE
+      have hc := c.pos
+      have hm := m.pos
+      have hcN : N ≤ (c : ℕ) * N := Nat.le_mul_of_pos_left _ hc
+      fin_cases i
+      · exfalso
+        simp only [wpMonExp, Fin.zero_eta, Matrix.cons_val_zero] at hE
+        nlinarith
+      · simp only [wpMonExp, Fin.mk_one, Matrix.cons_val_one, Matrix.cons_val_zero] at hE
+        have hc1 : (c : ℕ) = 1 := by
+          by_contra hc1
+          have hc2 : 2 ≤ (c : ℕ) := by omega
+          have : 2 * N ≤ (c : ℕ) * N := Nat.mul_le_mul_right _ hc2
+          have h3 : N + 1 ≤ (c : ℕ) * N - a₁ := by omega
+          nlinarith
+        rw [hc1, one_mul] at hE
+        have hd : (N - a₁) ∣ n := ⟨m, hE.symm⟩
+        have hmv : (m : ℕ) = n / (N - a₁) := by
+          rw [← hE, Nat.mul_div_cancel_left _ hNa]
+        refine ⟨?_, hd⟩
+        rw [hx₀]
+        congr
+        · exact PNat.coe_injective hc1
+        · apply PNat.coe_injective
+          rw [hmv, hm₀, Nat.toPNat'_coe, ite_eq_left (hmv ▸ hm)]
+      · exfalso
+        simp only [wpMonExp, Fin.reduceFinMk, Matrix.cons_val] at hE
+        nlinarith
+    rw [tsum_eq_single x₀]
+    · by_cases hd : (N - a₁) ∣ n
+      · have hq : 0 < n / (N - a₁) := Nat.div_pos (Nat.le_of_dvd hn0 hd) hNa
+        have hm₀v : (m₀ : ℕ) = n / (N - a₁) := by rw [hm₀, Nat.toPNat'_coe, ite_eq_left hq]
+        have hE : wpMonExp N a₁ (Sum.inr (Sum.inr x₀)) = n := by
+          simp only [wpMonExp, hx₀, PNat.one_coe, one_mul, Matrix.cons_val_one,
+            Matrix.cons_val_zero, hm₀v, Nat.mul_div_cancel' hd]
+        rw [wpFib, ite_eq_left hE, ite_eq_left hd, hx₀]
+        simp only [wpMonCoeff, Matrix.cons_val_one, Matrix.cons_val_zero, hm₀v]
+      · have hE : wpMonExp N a₁ (Sum.inr (Sum.inr x₀)) ≠ n := fun h ↦ hd (key x₀ h).2
+        simp [wpFib, hE, hd]
+    · intro x hx
+      have hE : wpMonExp N a₁ (Sum.inr (Sum.inr x)) ≠ n := fun h ↦ hx (key x h).1
+      simp [wpFib, hE]
+  rw [e1, e2, e3, zero_add]
+
+lemma isPrimitiveRoot_zetaN {N : ℕ} (hN : N ≠ 0) : IsPrimitiveRoot (zetaN N) N := by
+  simpa [zetaN] using Complex.isPrimitiveRoot_exp N hN
+
+theorem wpQCoeff_eq_iff_neg {N a₁ a₂ b₁ b₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (ha0 : a₁ ≠ 0 ∨ a₂ ≠ 0) (hb₁ : b₁ < N) (hb₂ : b₂ < N) (hb0 : b₁ ≠ 0 ∨ b₂ ≠ 0)
+    (h : ∀ n, wpQCoeff N a₁ a₂ n = wpQCoeff N b₁ b₂ n) :
+    (b₁ = a₁ ∧ b₂ = a₂) ∨ (b₁ = (N - a₁) % N ∧ b₂ = (N - a₂) % N) := by
+  have hN : N ≠ 0 := by omega
+  have hζ := isPrimitiveRoot_zetaN hN
+  set ζ := zetaN N with hζdef
+  have hζ0 : ζ ≠ 0 := zetaN_ne_zero N
+  have powinj : ∀ {x y : ℕ}, x < N → y < N → ζ ^ x = ζ ^ y → x = y :=
+    fun hx hy e ↦ hζ.pow_inj hx hy e
+  have powmul : ∀ {x y : ℕ}, x < N → y < N → ζ ^ x * ζ ^ y = 1 → y = (N - x) % N := by
+    intro x y hx hy e
+    rw [← pow_add, hζ.pow_eq_one_iff_dvd] at e
+    obtain ⟨c, hc⟩ := e
+    have hc2 : c < 2 := by nlinarith
+    interval_cases c
+    · rw [mul_zero, Nat.add_eq_zero_iff] at hc
+      obtain ⟨rfl, rfl⟩ := hc
+      simp
+    · rw [mul_one] at hc
+      have hx0 : 0 < x := by omega
+      have : (N - x) % N = N - x := Nat.mod_eq_of_lt (by omega)
+      rw [this]; omega
+  have invpow : ∀ y : ℕ, ζ⁻¹ ^ y * ζ ^ y = 1 := fun y ↦ by
+    rw [inv_pow, inv_mul_cancel₀ (pow_ne_zero _ hζ0)]
+  have powne1 : ∀ {x : ℕ}, 0 < x → x < N → ζ ^ x ≠ 1 := by
+    intro x hx0 hx e
+    rw [← pow_zero ζ] at e
+    have := powinj hx (by omega) e
+    omega
+  have match_uu : ζ ^ a₂ = ζ ^ b₂ → b₂ = a₂ := fun e ↦ (powinj ha₂ hb₂ e).symm
+  have match_uv : ζ ^ a₂ = ζ⁻¹ ^ b₂ → b₂ = (N - a₂) % N := fun e ↦
+    powmul ha₂ hb₂ (by rw [e]; exact invpow b₂)
+  have match_vu : ζ⁻¹ ^ a₂ = ζ ^ b₂ → b₂ = (N - a₂) % N := fun e ↦
+    powmul ha₂ hb₂ (by rw [mul_comm, ← e]; exact invpow a₂)
+  have match_vv : ζ⁻¹ ^ a₂ = ζ⁻¹ ^ b₂ → b₂ = a₂ := fun e ↦ by
+    have : ζ ^ a₂ = ζ ^ b₂ := by
+      rw [inv_pow, inv_pow, inv_inj] at e; exact e
+    exact (powinj ha₂ hb₂ this).symm
+  have h0 := h 0
+  rw [wpQCoeff_zero ha₁, wpQCoeff_zero hb₁, add_right_inj, ← hζdef] at h0
+  have Kne : ∀ {x : ℕ}, 0 < x → x < N → ζ ^ x / (1 - ζ ^ x) ^ 2 ≠ 0 := fun hx0 hx ↦
+    div_ne_zero (pow_ne_zero _ hζ0) (pow_ne_zero _ (sub_ne_zero.mpr (powne1 hx0 hx).symm))
+  by_cases hA : a₁ = 0
+  · have ha₂0 : 0 < a₂ := Nat.pos_of_ne_zero (ha0.resolve_left (not_not.mpr hA))
+    have hB : b₁ = 0 := by
+      by_contra hB
+      rw [ite_eq_left hA, ite_eq_right hB] at h0
+      exact Kne ha₂0 ha₂ h0
+    have hb₂0 : 0 < b₂ := Nat.pos_of_ne_zero (hb0.resolve_left (not_not.mpr hB))
+    rw [ite_eq_left hA, ite_eq_left hB] at h0
+    subst hA; subst hB
+    set t := ζ ^ a₂ with ht
+    set u := ζ ^ b₂ with hu
+    have ht1 : 1 - t ≠ 0 := sub_ne_zero.mpr (powne1 ha₂0 ha₂).symm
+    have hu1 : 1 - u ≠ 0 := sub_ne_zero.mpr (powne1 hb₂0 hb₂).symm
+    rw [div_eq_div_iff (pow_ne_zero 2 ht1) (pow_ne_zero 2 hu1)] at h0
+    have key : (t - u) * (1 - t * u) = 0 := by linear_combination h0
+    rcases mul_eq_zero.mp key with e | e
+    · left; exact ⟨rfl, match_uu (sub_eq_zero.mp e)⟩
+    · right
+      refine ⟨by simp, powmul ha₂ hb₂ ?_⟩
+      rw [← ht, ← hu]; linear_combination -e
+  · have hB : b₁ ≠ 0 := by
+      intro hB
+      have hb₂0 : 0 < b₂ := Nat.pos_of_ne_zero (hb0.resolve_left (not_not.mpr hB))
+      rw [ite_eq_right hA, ite_eq_left hB] at h0
+      exact Kne hb₂0 hb₂ h0.symm
+    have hmodA : (N - a₁) % N = N - a₁ := Nat.mod_eq_of_lt (by omega)
+    rw [hmodA]
+    set ka := min a₁ (N - a₁) with hka
+    set kb := min b₁ (N - b₁) with hkb
+    have hka0 : 0 < ka := lt_min (Nat.pos_of_ne_zero hA) (Nat.sub_pos_of_lt ha₁)
+    have hkb0 : 0 < kb := lt_min (Nat.pos_of_ne_zero hB) (Nat.sub_pos_of_lt hb₁)
+    have hkaN : ka < N := lt_of_le_of_lt (min_le_left _ _) ha₁
+    have hkbN : kb < N := lt_of_le_of_lt (min_le_left _ _) hb₁
+    have eval : ∀ {x₁ : ℕ} (x₂ : ℕ), x₁ < N → x₁ ≠ 0 → ∀ {n : ℕ}, 0 < n → n ≤ min x₁ (N - x₁) →
+        wpQCoeff N x₁ x₂ n =
+          (if x₁ = n then ζ ^ x₂ else 0) + (if N - x₁ = n then ζ⁻¹ ^ x₂ else 0) := by
+      intro x₁ x₂ hx₁ hx0 n hn0 hn
+      have hnN : n < N := lt_of_le_of_lt (le_trans hn (min_le_left _ _)) hx₁
+      rw [wpQCoeff_of_lt hx₁ x₂ hn0 hnN, ← hζdef]
+      have hn1 : n ≤ x₁ := le_trans hn (min_le_left _ _)
+      have hn2 : n ≤ N - x₁ := le_trans hn (min_le_right _ _)
+      congr 1
+      · by_cases e : x₁ = n
+        · subst e
+          simp [hx0, Nat.div_self hn0]
+        · have : ¬ (x₁ ∣ n) := fun hd ↦ e (le_antisymm (Nat.le_of_dvd hn0 hd) hn1)
+          simp [e, this]
+      · by_cases e : N - x₁ = n
+        · rw [ite_eq_left e, ite_eq_left (e ▸ dvd_refl _), e, Nat.div_self hn0]
+          simp
+        · have : ¬ (N - x₁ ∣ n) := fun hd ↦ e (le_antisymm (Nat.le_of_dvd hn0 hd) hn2)
+          rw [ite_eq_right e, ite_eq_right this]
+    have hkk : ka = kb := by
+      by_contra hne
+      rcases lt_or_gt_of_ne hne with hlt | hlt
+      · have hb := eval b₂ hb₁ hB hka0 hlt.le
+        rw [ite_eq_right (by
+          omega : ¬ b₁ = ka), ite_eq_right (by
+            omega : ¬ N - b₁ = ka), add_zero] at hb
+        have ha := eval a₂ ha₁ hA hka0 le_rfl
+        rw [h ka, hb] at ha
+        have : a₁ = ka ∨ N - a₁ = ka := by omega
+        rcases this with e | e
+        · by_cases e' : N - a₁ = ka
+          · omega
+          · rw [ite_eq_left e, ite_eq_right e', add_zero] at ha
+            exact pow_ne_zero _ hζ0 ha.symm
+        · by_cases e' : a₁ = ka
+          · omega
+          · rw [ite_eq_right e', ite_eq_left e, zero_add] at ha
+            exact pow_ne_zero _ (inv_ne_zero hζ0) ha.symm
+      · have ha := eval a₂ ha₁ hA hkb0 hlt.le
+        rw [ite_eq_right (by
+          omega : ¬ a₁ = kb), ite_eq_right (by
+            omega : ¬ N - a₁ = kb), add_zero] at ha
+        have hb := eval b₂ hb₁ hB hkb0 le_rfl
+        rw [← h kb, ha] at hb
+        have : b₁ = kb ∨ N - b₁ = kb := by omega
+        rcases this with e | e
+        · by_cases e' : N - b₁ = kb
+          · omega
+          · rw [ite_eq_left e, ite_eq_right e', add_zero] at hb
+            exact pow_ne_zero _ hζ0 hb.symm
+        · by_cases e' : b₁ = kb
+          · omega
+          · rw [ite_eq_right e', ite_eq_left e, zero_add] at hb
+            exact pow_ne_zero _ (inv_ne_zero hζ0) hb.symm
+    have ha := eval a₂ ha₁ hA hka0 le_rfl
+    have hb := eval b₂ hb₁ hB hkb0 le_rfl
+    rw [← hkk, ← h ka, ha] at hb
+    have haon : a₁ = ka ∨ N - a₁ = ka := by omega
+    have hbon : b₁ = ka ∨ N - b₁ = ka := by omega
+    by_cases hmid : a₁ = ka ∧ N - a₁ = ka
+    · obtain ⟨e1, e2⟩ := hmid
+      have hb12 : b₁ = ka ∧ N - b₁ = ka := by omega
+      rw [ite_eq_left e1, ite_eq_left e2, ite_eq_left hb12.1, ite_eq_left hb12.2] at hb
+      set u := ζ ^ a₂ with hu
+      set u' := ζ ^ b₂ with hu'
+      have hu0 : u ≠ 0 := pow_ne_zero _ hζ0
+      have hu'0 : u' ≠ 0 := pow_ne_zero _ hζ0
+      rw [inv_pow, inv_pow] at hb
+      have e3 : u * u⁻¹ = 1 := mul_inv_cancel₀ hu0
+      have e4 : u' * u'⁻¹ = 1 := mul_inv_cancel₀ hu'0
+      have key : (u - u') * (u * u' - 1) = 0 := by
+        linear_combination (u * u') * hb + u * e4 - u' * e3
+      rcases mul_eq_zero.mp key with e | e
+      · left; exact ⟨by omega, match_uu (sub_eq_zero.mp e)⟩
+      · right; exact ⟨by omega, powmul ha₂ hb₂ (by rw [← hu, ← hu']; linear_combination e)⟩
+    · rcases haon with e1 | e2
+      · have e2 : ¬ N - a₁ = ka := fun e2 ↦ hmid ⟨e1, e2⟩
+        rw [ite_eq_left e1, ite_eq_right e2, add_zero] at hb
+        rcases hbon with f1 | f2
+        · have f2 : ¬ N - b₁ = ka := by omega
+          rw [ite_eq_left f1, ite_eq_right f2, add_zero] at hb
+          left; exact ⟨by omega, match_uu hb⟩
+        · have f1 : ¬ b₁ = ka := by omega
+          rw [ite_eq_right f1, ite_eq_left f2, zero_add] at hb
+          right; exact ⟨by omega, match_uv hb⟩
+      · have e1 : ¬ a₁ = ka := fun e1 ↦ hmid ⟨e1, e2⟩
+        rw [ite_eq_right e1, ite_eq_left e2, zero_add] at hb
+        rcases hbon with f1 | f2
+        · have f2 : ¬ N - b₁ = ka := by omega
+          rw [ite_eq_left f1, ite_eq_right f2, add_zero] at hb
+          right; exact ⟨by omega, match_vu hb⟩
+        · have f1 : ¬ b₁ = ka := by omega
+          rw [ite_eq_right f1, ite_eq_left f2, zero_add] at hb
+          left; exact ⟨by omega, match_vv hb⟩
+
+theorem wpNorm_eq_imp {N a₁ a₂ b₁ b₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (ha0 : a₁ ≠ 0 ∨ a₂ ≠ 0) (hb₁ : b₁ < N) (hb₂ : b₂ < N) (hb0 : b₁ ≠ 0 ∨ b₂ ≠ 0)
+    (h : wpNorm N a₁ a₂ = wpNorm N b₁ b₂) :
+    (b₁ = a₁ ∧ b₂ = a₂) ∨ (b₁ = (N - a₁) % N ∧ b₂ = (N - a₂) % N) := by
+  refine wpQCoeff_eq_iff_neg ha₁ ha₂ ha0 hb₁ hb₂ hb0 fun n ↦ ?_
+  rw [← qExpansion_wpNorm_coeff ha₁ ha₂ ha0, ← qExpansion_wpNorm_coeff hb₁ hb₂ hb0, h]
+
+def zetaK (N : ℕ) : kN N := ⟨zetaN N, zetaN_mem_kN N⟩
+
+@[scoped simp] lemma coe_zetaK (N : ℕ) : (zetaK N : ℂ) = zetaN N := rfl
+
+lemma zetaN_pow_N {N : ℕ} (hN : N ≠ 0) : zetaN N ^ N = 1 :=
+  (isPrimitiveRoot_zetaN hN).pow_eq_one
+
+lemma pow_mul_eq_pow_mod_mul {M : Type*} [Monoid M] {x : M} {N : ℕ} (hx : x ^ N = 1)
+    (k m : ℕ) : x ^ (k * m) = x ^ (k % N * m) := by
+  rw [pow_eq_pow_mod (k * m) hx, pow_eq_pow_mod (k % N * m) hx, Nat.mod_mul_mod]
+
+def wpMonCoeffK (N a₁ a₂ : ℕ) (i : WpIdx) :
+    kN N := ⟨wpMonCoeff N a₁ a₂ i, wpMonCoeff_mem_kN N a₁ a₂ i⟩
+
+def wpQCoeffK {N a₁ : ℕ} (ha₁ : a₁ < N) (a₂ n : ℕ) : kN N :=
+  ⟨wpQCoeff N a₁ a₂ n, wpQCoeff_mem_kN ha₁ a₂ n⟩
+
+@[scoped simp] lemma coe_wpQCoeffK {N a₁ : ℕ} (ha₁ : a₁ < N) (a₂ n : ℕ) :
+    (wpQCoeffK ha₁ a₂ n : ℂ) = wpQCoeff N a₁ a₂ n := rfl
+
+lemma ringHom_wpMonCoeffK {N : ℕ} (hN : N ≠ 0) (φ : kN N →+* ℂ) {s : ℕ}
+    (hφ : φ (zetaK N) = zetaN N ^ s) (a₁ a₂ : ℕ) (i : WpIdx) :
+    φ (wpMonCoeffK N a₁ a₂ i) = wpMonCoeff N a₁ (s * a₂ % N) i := by
+  have hζN := zetaN_pow_N hN
+  have hpow : ∀ k : ℕ, φ ⟨zetaN N ^ k, zetaN_pow_mem_kN N k⟩ = (zetaN N ^ s) ^ k := fun k ↦ by
+    rw [← hφ, ← map_pow]; rfl
+  have hinvpow : ∀ k : ℕ, φ ⟨(zetaN N)⁻¹ ^ k, zetaN_inv_pow_mem_kN N k⟩ = ((zetaN N ^ s)⁻¹) ^ k :=
+    fun k ↦ by
+    rw [← hφ, ← map_inv₀, ← map_pow]; rfl
+  have hnatK : ∀ m : ℕ, (⟨(m : ℂ), natCast_mem_kN N m⟩ : kN N) = (m : kN N) := fun m ↦
+    Subtype.ext (by simp)
+  have hnat : ∀ m : ℕ, φ ⟨(m : ℂ), natCast_mem_kN N m⟩ = m := fun m ↦ by
+    rw [hnatK, map_natCast]
+  have htw : φ ⟨1 / 12, one_div_twelve_mem_kN N⟩ = 1 / 12 := by
+    have h12 : (⟨1 / 12, one_div_twelve_mem_kN N⟩ : kN N) *
+        ⟨((12 : ℕ) : ℂ), natCast_mem_kN N 12⟩ = 1 :=
+      Subtype.ext (by change (1 / 12 : ℂ) * ((12 : ℕ) : ℂ) = 1; norm_num)
+    have := congrArg φ h12
+    rw [map_mul, map_one, hnat] at this
+    rw [eq_one_div_of_mul_eq_one_left this]
+    norm_num
+  have hexp1 : (zetaN N ^ s) ^ a₂ = zetaN N ^ (s * a₂ % N) := by
+    rw [← pow_mul, pow_eq_pow_mod (s * a₂) hζN]
+  have hexp : ∀ m : ℕ, (zetaN N ^ s) ^ (a₂ * m) = zetaN N ^ (s * a₂ % N * m) := fun m ↦ by
+    rw [← pow_mul, ← mul_assoc, pow_mul_eq_pow_mod_mul hζN]
+  have hexpinv : ∀ m : ℕ, ((zetaN N ^ s)⁻¹) ^ (a₂ * m) = (zetaN N)⁻¹ ^ (s * a₂ % N * m) :=
+    fun m ↦ by
+    have hζN' : (zetaN N)⁻¹ ^ N = 1 := by rw [inv_pow, hζN, inv_one]
+    rw [← inv_pow, ← pow_mul, ← mul_assoc, pow_mul_eq_pow_mod_mul hζN']
+  rcases i with u | m | ⟨p, i⟩
+  · have e : wpMonCoeffK N a₁ a₂ (Sum.inl u) = ⟨1 / 12, one_div_twelve_mem_kN N⟩ +
+        (if a₁ = 0 then ⟨zetaN N ^ a₂, zetaN_pow_mem_kN N a₂⟩ /
+          (1 - ⟨zetaN N ^ a₂, zetaN_pow_mem_kN N a₂⟩) ^ 2 else 0) := by
+      apply Subtype.ext
+      simp only [wpMonCoeffK, wpMonCoeff]
+      split_ifs <;> simp
+    rw [e, map_add, htw]
+    simp only [wpMonCoeff]
+    split_ifs with h
+    · rw [map_div₀, map_pow, map_sub, map_one, hpow, hexp1]
+    · rw [map_zero]
+  · have e : wpMonCoeffK N a₁ a₂ (Sum.inr (Sum.inl m)) =
+        (if a₁ = 0 then 0 else ⟨((m : ℕ) : ℂ), natCast_mem_kN N m⟩ *
+          ⟨zetaN N ^ (a₂ * m), zetaN_pow_mem_kN N _⟩) := by
+      apply Subtype.ext
+      simp only [wpMonCoeffK, wpMonCoeff]
+      split_ifs <;> simp
+    rw [e]
+    simp only [wpMonCoeff]
+    split_ifs with h
+    · rw [map_zero]
+    · rw [map_mul, hnat, hpow, hexp]
+  · fin_cases i
+    · have e : wpMonCoeffK N a₁ a₂ (Sum.inr (Sum.inr (p, 0))) =
+          ⟨((p.2 : ℕ) : ℂ), natCast_mem_kN N _⟩ * ⟨zetaN N ^ (a₂ * p.2), zetaN_pow_mem_kN N _⟩ :=
+        Subtype.ext (by simp [wpMonCoeffK, wpMonCoeff])
+      simp only [Fin.zero_eta, Fin.isValue]
+      rw [e, map_mul, hnat, hpow, hexp]
+      simp [wpMonCoeff]
+    · have e : wpMonCoeffK N a₁ a₂ (Sum.inr (Sum.inr (p, 1))) =
+          ⟨((p.2 : ℕ) : ℂ), natCast_mem_kN N _⟩ *
+            ⟨(zetaN N)⁻¹ ^ (a₂ * p.2), zetaN_inv_pow_mem_kN N _⟩ :=
+        Subtype.ext (by simp [wpMonCoeffK, wpMonCoeff])
+      simp only [Fin.mk_one, Fin.isValue]
+      rw [e, map_mul, hnat, hinvpow, hexpinv]
+      simp [wpMonCoeff]
+    · have e : wpMonCoeffK N a₁ a₂ (Sum.inr (Sum.inr (p, 2))) =
+          -⟨((2 : ℕ) : ℂ), natCast_mem_kN N 2⟩ * ⟨((p.2 : ℕ) : ℂ), natCast_mem_kN N _⟩ :=
+        Subtype.ext (by
+          change wpMonCoeff N a₁ a₂ (Sum.inr (Sum.inr (p, 2))) = -((2 : ℕ) : ℂ) * ((p.2 : ℕ) : ℂ)
+          simp [wpMonCoeff])
+      simp only [Fin.reduceFinMk, Fin.isValue]
+      rw [e, map_mul, map_neg, hnat, hnat]
+      simp [wpMonCoeff]
+
+theorem ringHom_wpQCoeffK {N a₁ : ℕ} (ha₁ : a₁ < N) (φ : kN N →+* ℂ) {s : ℕ}
+    (hφ : φ (zetaK N) = zetaN N ^ s) (a₂ n : ℕ) :
+    φ (wpQCoeffK ha₁ a₂ n) = wpQCoeff N a₁ (s * a₂ % N) n := by
+  have hN : N ≠ 0 := by omega
+  have hfin := (finite_wpMonExp_fiber ha₁ n).to_subtype
+  have := Fintype.ofFinite (wpMonExp N a₁ ⁻¹' {n})
+  have e : wpQCoeffK ha₁ a₂ n = ∑ i : (wpMonExp N a₁ ⁻¹' {n}), wpMonCoeffK N a₁ a₂ i := by
+    apply Subtype.ext
+    rw [AddSubmonoidClass.coe_finsetSum, coe_wpQCoeffK, wpQCoeff, tsum_fintype]
+    rfl
+  rw [e, map_sum, wpQCoeff, tsum_fintype]
+  exact Finset.sum_congr rfl fun i _ ↦ ringHom_wpMonCoeffK hN φ hφ a₁ a₂ i
+
+end B4_qexp
+
+section B4_assembly
+
+open scoped UpperHalfPlane Manifold MatrixGroups
+p2m_open "UpperHalfPlane~I"
+open ModularForm SlashInvariantFormClass ModularFormClass
+
+lemma mem_kN_of_rat {N : ℕ} {x : ℂ} (h : ∃ q : ℚ, x = (q : ℂ)) : x ∈ kN N := by
+  obtain ⟨q, rfl⟩ := h
+  exact (kN N).algebraMap_mem q
+
+lemma qExpansion_E4E6_coeff_mem_kN {N : ℕ} (hN : N ≠ 0) (n : ℕ) :
+    (qExpansion N (⇑E₄ * ⇑E₆ : ℍ → ℂ)).coeff n ∈ kN N := by
+  have hper : Function.Periodic ((⇑E₄ * ⇑E₆ : ℍ → ℂ) ∘ ofComplex) 1 := by
+    have h4 := periodic_comp_ofComplex E₄ one_mem_strictPeriods_SL
+    have h6 := periodic_comp_ofComplex E₆ one_mem_strictPeriods_SL
+    intro τ
+    have e4 := h4 τ
+    have e6 := h6 τ
+    simp only [Function.comp_apply, Pi.mul_apply, Complex.ofReal_one] at e4 e6 ⊢
+    rw [e4, e6]
+  have hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (⇑E₄ * ⇑E₆ : ℍ → ℂ) := E₄.holo'.mul E₆.holo'
+  have hbd : IsBoundedAtImInfty (⇑E₄ * ⇑E₆ : ℍ → ℂ) :=
+    (ModularFormClass.bdd_at_infty E₄).mul (ModularFormClass.bdd_at_infty E₆)
+  rw [qExpansion_coeff_width _ hN hper hhol hbd]
+  split_ifs with hd
+  · apply mem_kN_of_rat
+    rw [ModularForm.qExpansion_mul_coe one_pos one_mem_strictPeriods_SL]
+    exact ratCoeff_mul (ratCoeff_E (by norm_num) (by decide)) (ratCoeff_E (by norm_num) (by decide))
+      _
+  · exact zero_mem _
+
+def frickeH (N a₁ a₂ : ℕ) : ℍ → ℂ := (⇑E₄ * ⇑E₆ : ℍ → ℂ) * wpNorm N a₁ a₂
+
+theorem periodic_frickeH {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N) (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) :
+    Function.Periodic (frickeH N a₁ a₂ ∘ ofComplex) N := by
+  have h4 := (periodic_comp_ofComplex E₄ one_mem_strictPeriods_SL).nat_mul N
+  have h6 := (periodic_comp_ofComplex E₆ one_mem_strictPeriods_SL).nat_mul N
+  have hw := periodic_wpNorm ha₁ ha₂ h0
+  intro τ
+  have e4 := h4 τ; have e6 := h6 τ; have ew := hw τ
+  simp only [Complex.ofReal_one, mul_one, Function.comp_apply] at e4 e6 ew
+  simp only [Function.comp_apply, frickeH, Pi.mul_apply, e4, e6, ew]
+
+theorem mdifferentiable_frickeH {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (frickeH N a₁ a₂) :=
+  (E₄.holo'.mul E₆.holo').mul (mdifferentiable_wpNorm ha₁ ha₂ h0)
+
+theorem isBoundedAtImInfty_frickeH {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) : IsBoundedAtImInfty (frickeH N a₁ a₂) :=
+  ((ModularFormClass.bdd_at_infty E₄).mul (ModularFormClass.bdd_at_infty E₆)).mul
+    (isBoundedAtImInfty_wpNorm ha₁ ha₂ h0)
+
+theorem qExpansion_frickeH_coeff_mem_kN {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) (n : ℕ) :
+    (qExpansion N (frickeH N a₁ a₂)).coeff n ∈ kN N := by
+  have hN : N ≠ 0 := by omega
+  have hN' : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero hN
+  have hperE : Function.Periodic ((⇑E₄ * ⇑E₆ : ℍ → ℂ) ∘ ofComplex) N := by
+    have h4 := (periodic_comp_ofComplex E₄ one_mem_strictPeriods_SL).nat_mul N
+    have h6 := (periodic_comp_ofComplex E₆ one_mem_strictPeriods_SL).nat_mul N
+    intro τ
+    have e4 := h4 τ; have e6 := h6 τ
+    simp only [Complex.ofReal_one, mul_one, Function.comp_apply] at e4 e6
+    simp only [Function.comp_apply, Pi.mul_apply, e4, e6]
+  have hE : AnalyticAt ℂ (cuspFunction N (⇑E₄ * ⇑E₆ : ℍ → ℂ)) 0 :=
+    analyticAt_cuspFunction_zero hN' hperE (E₄.holo'.mul E₆.holo')
+      ((ModularFormClass.bdd_at_infty E₄).mul (ModularFormClass.bdd_at_infty E₆))
+  have hW : AnalyticAt ℂ (cuspFunction N (wpNorm N a₁ a₂)) 0 :=
+    analyticAt_cuspFunction_zero hN' (periodic_wpNorm ha₁ ha₂ h0)
+      (mdifferentiable_wpNorm ha₁ ha₂ h0) (isBoundedAtImInfty_wpNorm ha₁ ha₂ h0)
+  rw [frickeH, qExpansion_mul hE hW, PowerSeries.coeff_mul]
+  exact sum_mem fun ij _ ↦ mul_mem (qExpansion_E4E6_coeff_mem_kN hN _)
+    (qExpansion_wpNorm_coeff_mem_kN ha₁ ha₂ h0 _)
+
+theorem hasSum_qExpansion_frickeH {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) (τ : ℍ) :
+    HasSum (fun m : ℕ ↦ (qExpansion N (frickeH N a₁ a₂)).coeff m •
+      Function.Periodic.qParam N τ ^ m) (frickeH N a₁ a₂ τ) :=
+  hasSum_qExpansion (by exact_mod_cast (show 0 < N by omega)) (periodic_frickeH ha₁ ha₂ h0)
+    (mdifferentiable_frickeH ha₁ ha₂ h0) (isBoundedAtImInfty_frickeH ha₁ ha₂ h0) τ
+
+end B4_assembly
+
+section C6_width
+
+open scoped UpperHalfPlane Manifold MatrixGroups
+p2m_open "UpperHalfPlane~I"
+open SlashInvariantFormClass ModularFormClass
+
+namespace ModularFormClass
+private theorem _root_.WLightR2.ModularFormClass.qExpansion_coeff_width {F : Type*} [FunLike F ℍ ℂ]
+    {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [ModularFormClass F Γ k] (f : F)
+    (h1 : (1 : ℝ) ∈ Γ.strictPeriods) {N : ℕ} (hN : N ≠ 0) (n : ℕ) :
+    (qExpansion N f).coeff n = if N ∣ n then (qExpansion 1 f).coeff (n / N) else 0 := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos h1⟩
+  exact WLightR2.qExpansion_coeff_width f hN (by simpa using periodic_comp_ofComplex f h1)
+    (ModularFormClass.holo f) (ModularFormClass.bdd_at_infty f) n
+
+end ModularFormClass
+p2m_export "WLightR2" "ModularFormClass.qExpansion_coeff_width"
+end C6_width
+
+end WLightR2
+
+p2m_open "UpperHalfPlane~I" in
+open scoped UpperHalfPlane Manifold in
+open WLightR2 in
+theorem solution (N : ℕ) (hN : N ≠ 0) (L : ℍ → PeriodPair)
+    (hL : ∀ τ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1) :
+    let ζ : ℂ := Complex.exp (2 * π * I / N)
+    let k : IntermediateField ℚ ℂ := IntermediateField.adjoin ℚ {ζ}
+    let ζk : k := IntermediateField.AdjoinSimple.gen ℚ ζ
+    let W : ℕ → ℕ → ℍ → ℂ := fun a₁ a₂ τ ↦ ((2 * π * I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ) (((a₁ : ℂ) * (τ : ℂ) + (a₂ : ℂ)) / (N : ℂ))
+    (∀ a₁ a₂ : ℕ, a₁ < N → a₂ < N → (a₁ ≠ 0 ∨ a₂ ≠ 0) →
+        MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (W a₁ a₂)
+        ∧ Function.Periodic ((W a₁ a₂) ∘ UpperHalfPlane.ofComplex) (N : ℂ)
+        ∧ IsBoundedAtImInfty (W a₁ a₂)
+        ∧ ∀ n, (qExpansion N (W a₁ a₂)).coeff n ∈ k)
+    ∧ (∀ a₁ a₂ b₁ b₂ : ℕ, a₁ < N → a₂ < N → (a₁ ≠ 0 ∨ a₂ ≠ 0) →
+        b₁ < N → b₂ < N → (b₁ ≠ 0 ∨ b₂ ≠ 0) →
+        W a₁ a₂ = W b₁ b₂ →
+        (b₁ = a₁ ∧ b₂ = a₂) ∨ (b₁ = (N - a₁) % N ∧ b₂ = (N - a₂) % N))
+    ∧ (∃ S : ℕ → ℕ → PowerSeries k,
+        (∀ a₁ a₂ : ℕ, a₁ < N → a₂ < N → (a₁ ≠ 0 ∨ a₂ ≠ 0) →
+          (S a₁ a₂).map (algebraMap k ℂ) = qExpansion N (W a₁ a₂))
+        ∧ ∀ s : ℕ, s.Coprime N → ∀ φ : k →+* ℂ, φ ζk = ζ ^ s →
+            ∀ a₁ a₂ : ℕ, a₁ < N → a₂ < N → (a₁ ≠ 0 ∨ a₂ ≠ 0) →
+              (S a₁ a₂).map φ = qExpansion N (W a₁ (s * a₂ % N)))
+    ∧ (∀ f : ℍ → ℂ, Function.Periodic (f ∘ UpperHalfPlane.ofComplex) (1 : ℂ) →
+        MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f → IsBoundedAtImInfty f →
+        ∀ n, (qExpansion N f).coeff n =
+          if N ∣ n then (qExpansion 1 f).coeff (n / N) else 0)
+    ∧ (∀ n, ∃ q : ℚ, (qExpansion 1 (⇑ModularForm.E₄ : ℍ → ℂ)).coeff n = (q : ℂ))
+    ∧ (∀ n, ∃ q : ℚ, (qExpansion 1 (⇑ModularForm.E₆ : ℍ → ℂ)).coeff n = (q : ℂ))
+    ∧ (∀ n, ∃ q : ℚ,
+        (qExpansion 1 (ModularForm.discriminant : ℍ → ℂ)).coeff n = (q : ℂ)) := by
+  extract_lets ζ k ζk W
+  obtain rfl := L_eq_periodPairOfTau L hL
+  have hW : W = wpNorm N := by
+    funext a₁ a₂ τ; rfl
+  have hk : k = kN N := rfl
+  refine ⟨?_, ?_, ?_, ?_, ?_, ?_, ?_⟩
+  · intro a₁ a₂ ha₁ ha₂ h0
+    rw [hW]
+    exact ⟨mdifferentiable_wpNorm ha₁ ha₂ h0, periodic_wpNorm ha₁ ha₂ h0,
+      isBoundedAtImInfty_wpNorm ha₁ ha₂ h0, fun n ↦ hk ▸ qExpansion_wpNorm_coeff_mem_kN ha₁ ha₂ h0
+        n⟩
+  · intro a₁ a₂ b₁ b₂ ha₁ ha₂ ha0 hb₁ hb₂ hb0 heq
+    exact wpNorm_eq_imp ha₁ ha₂ ha0 hb₁ hb₂ hb0 (hW ▸ heq)
+  · have hζk : ζk = zetaK N := rfl
+    refine ⟨fun a₁ a₂ ↦ if ha₁ : a₁ < N then PowerSeries.mk (hk ▸ wpQCoeffK ha₁ a₂) else 0, ?_, ?_⟩
+    · intro a₁ a₂ ha₁ ha₂ h0
+      simp only
+      rw [dite_eq_left ha₁, hW]
+      refine PowerSeries.ext fun n ↦ ?_
+      rw [PowerSeries.coeff_map, PowerSeries.coeff_mk,
+        qExpansion_wpNorm_coeff ha₁ ha₂ h0]
+      rfl
+    · intro s hs φ hφ a₁ a₂ ha₁ ha₂ h0
+      have hφ' : φ (zetaK N) = zetaN N ^ s := hζk ▸ hφ
+      have hsa₂ : s * a₂ % N < N := Nat.mod_lt _ (Nat.pos_of_ne_zero hN)
+      have h0' : a₁ ≠ 0 ∨ s * a₂ % N ≠ 0 := by
+        refine h0.imp id fun ha₂0 hc ↦ ha₂0 ?_
+        rw [← Nat.dvd_iff_mod_eq_zero] at hc
+        exact Nat.eq_zero_of_dvd_of_lt (hs.symm.dvd_of_dvd_mul_left hc) ha₂
+      simp only
+      rw [dite_eq_left ha₁, hW]
+      refine PowerSeries.ext fun n ↦ ?_
+      rw [PowerSeries.coeff_map, PowerSeries.coeff_mk]
+      exact (ringHom_wpQCoeffK ha₁ φ hφ' a₂ n).trans
+        (qExpansion_wpNorm_coeff ha₁ hsa₂ h0' n).symm
+  · intro f hper hhol hbd n
+    exact qExpansion_coeff_width f hN (by simpa using hper) hhol hbd n
+  · exact ratCoeff_E (by norm_num) (by decide)
+  · exact ratCoeff_E (by norm_num) (by decide)
+  · exact ratCoeff_discriminant
+
+end
+end S_ModularForm_weierstrassP_torsion_qExpansion_package
+end P2MW
+export P2MW.S_ModularForm_weierstrassP_torsion_qExpansion_package (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Complex Real
+open UpperHalfPlane hiding I
+open scoped UpperHalfPlane Manifold
+theorem ModularForm.weierstrassP_torsion_qExpansion_package
+    (N : ℕ) (hN : N ≠ 0) (L : ℍ → PeriodPair)
+    (hL : ∀ τ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1) :
+    let ζ : ℂ := Complex.exp (2 * π * I / N)
+    let k : IntermediateField ℚ ℂ := IntermediateField.adjoin ℚ {ζ}
+    let ζk : k := IntermediateField.AdjoinSimple.gen ℚ ζ
+    let W : ℕ → ℕ → ℍ → ℂ := fun a₁ a₂ τ ↦ ((2 * π * I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ) (((a₁ : ℂ) * (τ : ℂ) + (a₂ : ℂ)) / (N : ℂ))
+    (∀ a₁ a₂ : ℕ, a₁ < N → a₂ < N → (a₁ ≠ 0 ∨ a₂ ≠ 0) →
+        MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (W a₁ a₂)
+        ∧ Function.Periodic ((W a₁ a₂) ∘ UpperHalfPlane.ofComplex) (N : ℂ)
+        ∧ IsBoundedAtImInfty (W a₁ a₂)
+        ∧ ∀ n, (qExpansion N (W a₁ a₂)).coeff n ∈ k)
+    ∧ (∀ a₁ a₂ b₁ b₂ : ℕ, a₁ < N → a₂ < N → (a₁ ≠ 0 ∨ a₂ ≠ 0) →
+        b₁ < N → b₂ < N → (b₁ ≠ 0 ∨ b₂ ≠ 0) →
+        W a₁ a₂ = W b₁ b₂ →
+        (b₁ = a₁ ∧ b₂ = a₂) ∨ (b₁ = (N - a₁) % N ∧ b₂ = (N - a₂) % N))
+    ∧ (∃ S : ℕ → ℕ → PowerSeries k,
+        (∀ a₁ a₂ : ℕ, a₁ < N → a₂ < N → (a₁ ≠ 0 ∨ a₂ ≠ 0) →
+          (S a₁ a₂).map (algebraMap k ℂ) = qExpansion N (W a₁ a₂))
+        ∧ ∀ s : ℕ, s.Coprime N → ∀ φ : k →+* ℂ, φ ζk = ζ ^ s →
+            ∀ a₁ a₂ : ℕ, a₁ < N → a₂ < N → (a₁ ≠ 0 ∨ a₂ ≠ 0) →
+              (S a₁ a₂).map φ = qExpansion N (W a₁ (s * a₂ % N)))
+    ∧ (∀ f : ℍ → ℂ, Function.Periodic (f ∘ UpperHalfPlane.ofComplex) (1 : ℂ) →
+        MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f → IsBoundedAtImInfty f →
+        ∀ n, (qExpansion N f).coeff n =
+          if N ∣ n then (qExpansion 1 f).coeff (n / N) else 0)
+    ∧ (∀ n, ∃ q : ℚ, (qExpansion 1 (⇑ModularForm.E₄ : ℍ → ℂ)).coeff n = (q : ℂ))
+    ∧ (∀ n, ∃ q : ℚ, (qExpansion 1 (⇑ModularForm.E₆ : ℍ → ℂ)).coeff n = (q : ℂ))
+    ∧ (∀ n, ∃ q : ℚ,
+        (qExpansion 1 (ModularForm.discriminant : ℍ → ℂ)).coeff n = (q : ℂ)) :=
+  solution N hN L hL
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularGroup_exists_eq_conj_T_zpow_of_trace_sq_eq_four.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularGroup_exists_eq_conj_T_zpow_of_trace_sq_eq_four.lean
new file mode 100644
index 0000000000..e6f0a92ac4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularGroup_exists_eq_conj_T_zpow_of_trace_sq_eq_four.lean
@@ -0,0 +1,202 @@
+/-
+Based on Prove2Me node ModularGroup.exists_eq_conj_T_zpow_of_trace_sq_eq_four
+(6b721e9a-dc95-5f8f-86c9-2be3af8e0bc2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d3dc972b-e5e6-58e5-870b-75a6f5343992
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.LinearAlgebra.Matrix.SpecialLinearGroup
+public import Mathlib.LinearAlgebra.Matrix.Trace
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Algebra.Ring.IsFormallyReal
+import Mathlib.Analysis.Normed.Ring.Lemmas
+import Mathlib.Data.Int.Star
+import Mathlib.Tactic.LinearCombination
+import Mathlib.Tactic.LinearCombination.Lemmas
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Trace-±2 elements of SL₂(ℤ) are ±δ T^hδ⁻¹
+
+Theorem statement: `ModularGroup.exists_eq_conj_T_zpow_of_trace_sq_eq_four`
+(`6b721e9a-dc95-5f8f-86c9-2be3af8e0bc2`), by Claude, 2026-09-05.
+
+Proof: submission `d3dc972b-e5e6-58e5-870b-75a6f5343992`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\gamma$ be an element of $SL(2,\mathbb{Z})$, the group of $2\times 2$ integer matrices of
+determinant $1$, and suppose that the square of the trace of the underlying matrix of $\gamma$
+equals $4$, i.e. $(\operatorname{tr}\gamma)^2 = 4$, so that $\operatorname{tr}\gamma = 2$ or
+$\operatorname{tr}\gamma = -2$. The assertion is that there exist elements $\varepsilon,\delta \in
+SL(2,\mathbb{Z})$ and an integer $h$ such that $\varepsilon$ is either the identity matrix or its
+negative, and $\gamma = \varepsilon\,(\delta\, T^{h}\, \delta^{-1})$, where $T$ denotes the Mathlib
+matrix $\begin{pmatrix}1&1\\0&1\end{pmatrix}$ in $SL(2,\mathbb{Z})$ and $T^h$ is its integer power
+$\begin{pmatrix}1&h\\0&1\end{pmatrix}$. Thus every element of trace $\pm 2$, including $\pm 1$
+themselves (the case $h = 0$), is a sign times a conjugate of a power of $T$. The sign
+$\varepsilon$, the conjugating element $\delta$ and the exponent $h$ are produced existentially,
+with no uniqueness or normalisation claimed.
+
+This is the classification of elements of $SL_2(\mathbb{Z})$ with $(\operatorname{tr})^2 = 4$,
+equivalently the statement that the stabiliser of a cusp is conjugate to $\{\pm T^h : h \in
+\mathbb{Z}\}$. It is the group-theoretic input to the parabolicity of Eichler–Shimura period
+cocycles attached to cusp forms, and is used throughout the treatment of the cohomological carrier
+of modular symbols.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularGroup_exists_eq_conj_T_zpow_of_trace_sq_eq_four.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularGroup_exists_eq_conj_T_zpow_of_trace_sq_eq_four
+
+open scoped MatrixGroups
+
+namespace ModularGroup
+p2m_export "ModularGroup" "T coe_T_zpow det_coe"
+namespace ParabolicClassificationSol
+p2m_open "ModularGroup"
+
+p2m_open "Matrix Matrix.SpecialLinearGroup ModularGroup \
+  P2MW.S_ModularGroup_exists_eq_conj_T_zpow_of_trace_sq_eq_four.ModularGroup"
+
+private theorem det_entries (γ : SL(2, ℤ)) : γ 0 0 * γ 1 1 - γ 0 1 * γ 1 0 = 1 := by
+  have := γ.det_coe
+  rwa [Matrix.det_fin_two] at this
+
+private theorem mul_entry (A B : SL(2, ℤ)) (i j : Fin 2) :
+    (A * B) i j = A i 0 * B 0 j + A i 1 * B 1 j := by
+  show ((A * B : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) i j = _
+  rw [Matrix.SpecialLinearGroup.coe_mul, Matrix.mul_apply, Fin.sum_univ_two]
+
+private theorem inv_entries (A : SL(2, ℤ)) :
+    A⁻¹ 0 0 = A 1 1 ∧ A⁻¹ 0 1 = -A 0 1 ∧ A⁻¹ 1 0 = -A 1 0 ∧ A⁻¹ 1 1 = A 0 0 := by
+  have h : ((A⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) =
+      !![A 1 1, -A 0 1; -A 1 0, A 0 0] := by
+    rw [Matrix.SpecialLinearGroup.coe_inv, Matrix.adjugate_fin_two]
+  refine ⟨?_, ?_, ?_, ?_⟩ <;> simp [h]
+
+theorem exists_col_eq {p r : ℤ} (h : IsCoprime p r) :
+    ∃ δ : SL(2, ℤ), δ 0 0 = p ∧ δ 1 0 = r := by
+  obtain ⟨u, v, huv⟩ := h
+  refine ⟨⟨!![p, -v; r, u], ?_⟩, rfl, rfl⟩
+  rw [Matrix.det_fin_two_of]
+  linear_combination huv
+
+theorem eq_T_zpow_of_col {M : SL(2, ℤ)} (h00 : M 0 0 = 1) (h10 : M 1 0 = 0) :
+    M = ModularGroup.T ^ (M 0 1) := by
+  have hdet := det_entries M
+  rw [h00, h10, one_mul, mul_zero, sub_zero] at hdet
+  ext i j
+  fin_cases i <;> fin_cases j <;>
+    simp_all [ModularGroup.coe_T_zpow]
+
+theorem exists_isCoprime_fixed {γ : SL(2, ℤ)}
+    (htr : (γ : Matrix (Fin 2) (Fin 2) ℤ).trace = 2) (hc : γ 1 0 ≠ 0) :
+    ∃ p r : ℤ, IsCoprime p r ∧
+      γ 0 0 * p + γ 0 1 * r = p ∧ γ 1 0 * p + γ 1 1 * r = r := by
+  rw [Matrix.trace_fin_two] at htr
+  have hdet := det_entries γ
+  have hgcd_pos : 0 < Int.gcd (γ 0 0 - 1) (γ 1 0) := by
+    rcases Nat.eq_zero_or_pos (Int.gcd (γ 0 0 - 1) (γ 1 0)) with h | h
+    · exact absurd (Int.gcd_eq_zero_iff.mp h).2 hc
+    · exact h
+  obtain ⟨p, r, hpr, hp, hr⟩ := Int.exists_gcd_one hgcd_pos
+  set g : ℤ := (Int.gcd (γ 0 0 - 1) (γ 1 0) : ℤ) with hgdef
+  have hgne : g ≠ 0 := by
+    rw [hgdef]
+    exact_mod_cast hgcd_pos.ne'
+  refine ⟨p, r, Int.isCoprime_iff_gcd_eq_one.mpr hpr, ?_, ?_⟩
+  · have key : g * (γ 0 0 * p + γ 0 1 * r - p) = 0 := by
+      linear_combination (-(γ 0 0 - 1)) * hp - γ 0 1 * hr + γ 0 0 * htr - hdet
+    have h0 := (mul_eq_zero.mp key).resolve_left hgne
+    linarith
+  · have key : g * (γ 1 0 * p + γ 1 1 * r - r) = 0 := by
+      linear_combination (-(γ 1 0)) * hp - (γ 1 1 - 1) * hr + γ 1 0 * htr
+    have h0 := (mul_eq_zero.mp key).resolve_left hgne
+    linarith
+
+theorem exists_conj_T_zpow_of_trace_eq_two {γ : SL(2, ℤ)}
+    (htr : (γ : Matrix (Fin 2) (Fin 2) ℤ).trace = 2) :
+    ∃ (δ : SL(2, ℤ)) (n : ℤ), γ = δ * ModularGroup.T ^ n * δ⁻¹ := by
+  rcases eq_or_ne (γ 1 0) 0 with hc | hc
+  · have hdet := det_entries γ
+    rw [hc, mul_zero, sub_zero] at hdet
+    rw [Matrix.trace_fin_two] at htr
+    have hsq : (γ 0 0 - 1) ^ 2 = 0 := by
+      linear_combination γ 0 0 * htr - hdet
+    have ha : γ 0 0 = 1 := by
+      have := sq_eq_zero_iff.mp hsq
+      linarith
+    refine ⟨1, γ 0 1, ?_⟩
+    rw [inv_one, mul_one, one_mul]
+    exact eq_T_zpow_of_col ha hc
+  · obtain ⟨p, r, hpr, hfix1, hfix2⟩ := exists_isCoprime_fixed htr hc
+    obtain ⟨δ, hδ00, hδ10⟩ := exists_col_eq hpr
+    obtain ⟨hi00, hi01, hi10, hi11⟩ := inv_entries δ
+    have hδdet := det_entries δ
+    rw [hδ00, hδ10] at hδdet
+    have hγδ0 : (γ * δ) 0 0 = δ 0 0 := by
+      rw [mul_entry γ δ 0 0, hδ00, hδ10]; exact hfix1
+    have hγδ1 : (γ * δ) 1 0 = δ 1 0 := by
+      rw [mul_entry γ δ 1 0, hδ00, hδ10]; exact hfix2
+    have hM00 : (δ⁻¹ * (γ * δ)) 0 0 = 1 := by
+      rw [mul_entry δ⁻¹ (γ * δ) 0 0, hγδ0, hγδ1, hi00, hi01, hδ00, hδ10]
+      linear_combination hδdet
+    have hM10 : (δ⁻¹ * (γ * δ)) 1 0 = 0 := by
+      rw [mul_entry δ⁻¹ (γ * δ) 1 0, hγδ0, hγδ1, hi10, hi11, hδ00, hδ10]
+      ring
+    refine ⟨δ, (δ⁻¹ * (γ * δ)) 0 1, ?_⟩
+    rw [← eq_T_zpow_of_col hM00 hM10]
+    group
+
+theorem classification (γ : SL(2, ℤ)) (hγ : ((γ : Matrix (Fin 2) (Fin 2) ℤ).trace) ^ 2 = 4) :
+    ∃ (ε δ : SL(2, ℤ)) (n : ℤ), (ε = 1 ∨ ε = -1) ∧ γ = ε * (δ * ModularGroup.T ^ n * δ⁻¹) := by
+  have hsplit : ((γ : Matrix (Fin 2) (Fin 2) ℤ).trace - 2) *
+      ((γ : Matrix (Fin 2) (Fin 2) ℤ).trace + 2) = 0 := by
+    linear_combination hγ
+  rcases mul_eq_zero.mp hsplit with h | h
+  · obtain ⟨δ, n, hδ⟩ := exists_conj_T_zpow_of_trace_eq_two (γ := γ) (by linarith)
+    exact ⟨1, δ, n, Or.inl rfl, by rw [one_mul]; exact hδ⟩
+  · have htrneg : ((-γ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).trace = 2 := by
+      rw [Matrix.SpecialLinearGroup.coe_neg, Matrix.trace_neg]
+      linarith
+    obtain ⟨δ, n, hδ⟩ := exists_conj_T_zpow_of_trace_eq_two htrneg
+    refine ⟨-1, δ, n, Or.inr rfl, ?_⟩
+    rw [neg_one_mul, ← hδ, neg_neg]
+
+end ModularGroup.ParabolicClassificationSol
+
+theorem solution (γ : SL(2, ℤ)) (hγ : ((γ : Matrix (Fin 2) (Fin 2) ℤ).trace) ^ 2 = 4) :
+    ∃ (ε δ : SL(2, ℤ)) (h : ℤ), (ε = 1 ∨ ε = -1) ∧ γ = ε * (δ * ModularGroup.T ^ h * δ⁻¹) :=
+  ModularGroup.ParabolicClassificationSol.classification γ hγ
+
+end S_ModularGroup_exists_eq_conj_T_zpow_of_trace_sq_eq_four
+end P2MW
+export P2MW.S_ModularGroup_exists_eq_conj_T_zpow_of_trace_sq_eq_four (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups
+theorem ModularGroup.exists_eq_conj_T_zpow_of_trace_sq_eq_four (γ : SL(2, ℤ))
+    (hγ : ((γ : Matrix (Fin 2) (Fin 2) ℤ).trace) ^ 2 = 4) :
+    ∃ (ε δ : SL(2, ℤ)) (h : ℤ), (ε = 1 ∨ ε = -1) ∧ γ = ε * (δ * ModularGroup.T ^ h * δ⁻¹) :=
+  solution γ hγ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularGroup_exists_mulEquiv_freeProduct_quotient_center.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularGroup_exists_mulEquiv_freeProduct_quotient_center.lean
new file mode 100644
index 0000000000..5efd896adf
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ModularGroup_exists_mulEquiv_freeProduct_quotient_center.lean
@@ -0,0 +1,594 @@
+/-
+Based on Prove2Me node ModularGroup.exists_mulEquiv_freeProduct_quotient_center
+(22fc53a0-d932-55da-98a2-9820eacb2e30) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 15e678a5-1e64-5634-b2c7-ea1a098446f2
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.GroupTheory.CoprodI
+public import Mathlib.LinearAlgebra.Matrix.SpecialLinearGroup
+
+import Mathlib.Analysis.Normed.Ring.Lemmas
+import Mathlib.LinearAlgebra.Matrix.FixedDetMatrices
+import Mathlib.NumberTheory.Real.Irrational
+import Mathlib.Order.CompletePartialOrder
+import Mathlib.Tactic.LinearCombination
+import Mathlib.Tactic.LinearCombination.Lemmas
+
+/-!
+# PSL₂(ℤ) is the free product C₂ * C₃
+
+Theorem statement: `ModularGroup.exists_mulEquiv_freeProduct_quotient_center`
+(`22fc53a0-d932-55da-98a2-9820eacb2e30`), by Claude, 2026-09-05.
+
+Proof: submission `15e678a5-1e64-5634-b2c7-ea1a098446f2`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+The assertion is the existence of a group isomorphism $e$ from the free product (coproduct in the
+category of groups, `Monoid.CoprodI`) of the family indexed by $i \in \mathrm{Fin}\,2$ whose $i$-th
+factor is the group $\mathbb{Z}/(i+2)\mathbb{Z}$ written multiplicatively — so the factors are
+cyclic of orders $2$ and $3$ — onto the quotient of $\mathrm{SL}_2(\mathbb{Z})$, the group of $2
+\times 2$ integer matrices of determinant $1$, by its centre, subject to two normalisations: $e$
+sends the canonical image in the free product of the element $1$ of the $0$-th factor
+$\mathbb{Z}/2\mathbb{Z}$ (transported through `Multiplicative.ofAdd`, i.e. the generator of the
+factor of order $2$) to the class modulo the centre of $S = \begin{pmatrix} 0 & -1 \\ 1 &
+0\end{pmatrix}$, and sends the canonical image of the element $1$ of the first factor
+$\mathbb{Z}/3\mathbb{Z}$ (the generator of the factor of order $3$) to the class modulo the centre
+of $ST = \begin{pmatrix} 0 & -1 \\ 1 & 1 \end{pmatrix}$. No hypotheses are assumed. The centre of
+$\mathrm{SL}_2(\mathbb{Z})$ being $\{\pm 1\}$, the quotient is $\mathrm{PSL}_2(\mathbb{Z})$.
+
+This is the classical presentation of the modular group: $\mathrm{PSL}_2(\mathbb{Z})$ is the free
+product of the cyclic groups generated by the images of $S$ and $ST$, of orders $2$ and $3$. It
+underlies the combinatorial analysis of functions on $\mathrm{SL}_2(\mathbb{Z})$-orbits used in the
+numerical work on modular curves, and is cited in the computation of ranks of spaces of additive
+maps and of orbit counts for the $S$, $ST$ action.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ModularGroup_exists_mulEquiv_freeProduct_quotient_center.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ModularGroup_exists_mulEquiv_freeProduct_quotient_center
+
+open Matrix MatrixGroups ModularGroup
+open scoped Pointwise
+
+namespace ModularCurve
+
+namespace ModularGroupPingPong
+
+theorem det_entries (γ : SL(2, ℤ)) : γ 0 0 * γ 1 1 - γ 0 1 * γ 1 0 = 1 := by
+  have h := γ.2
+  rw [Matrix.det_fin_two] at h
+  exact h
+
+def IrrationalPt : Type := {x : ℝ // Irrational x}
+
+namespace IrrationalPt
+
+scoped instance : CoeOut IrrationalPt ℝ := ⟨Subtype.val⟩
+
+@[scoped ext] theorem ext {x y : IrrationalPt} (h : (x : ℝ) = y) : x = y := Subtype.ext h
+
+theorem irrational (x : IrrationalPt) : Irrational (x : ℝ) := x.2
+
+noncomputable def sqrtTwo : IrrationalPt := ⟨Real.sqrt 2, irrational_sqrt_two⟩
+
+theorem sqrtTwo_pos : (0 : ℝ) < (sqrtTwo : ℝ) := by
+  have : (0 : ℝ) < Real.sqrt 2 := Real.sqrt_pos.mpr (by norm_num)
+  exact this
+
+noncomputable def negSqrtTwo : IrrationalPt := ⟨-Real.sqrt 2, irrational_sqrt_two.neg⟩
+
+theorem negSqrtTwo_neg : ((negSqrtTwo : ℝ)) < 0 := by
+  have : (0 : ℝ) < Real.sqrt 2 := Real.sqrt_pos.mpr (by norm_num)
+  change -Real.sqrt 2 < 0
+  linarith
+
+end IrrationalPt
+
+open IrrationalPt
+
+noncomputable def moebius (γ : SL(2, ℤ)) (x : ℝ) : ℝ :=
+  ((γ 0 0 : ℝ) * x + (γ 0 1 : ℝ)) / ((γ 1 0 : ℝ) * x + (γ 1 1 : ℝ))
+
+theorem det_entries_real (γ : SL(2, ℤ)) :
+    (γ 0 0 : ℝ) * (γ 1 1 : ℝ) - (γ 0 1 : ℝ) * (γ 1 0 : ℝ) = 1 := by
+  exact_mod_cast congrArg (fun n : ℤ => (n : ℝ)) (det_entries γ)
+
+theorem mul_entry (A B : SL(2, ℤ)) (i j : Fin 2) :
+    (A * B) i j = A i 0 * B 0 j + A i 1 * B 1 j := by
+  show ((A * B : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) i j = _
+  rw [Matrix.SpecialLinearGroup.coe_mul, Matrix.mul_apply, Fin.sum_univ_two]
+
+theorem den_ne_zero (γ : SL(2, ℤ)) {x : ℝ} (hx : Irrational x) :
+    (γ 1 0 : ℝ) * x + (γ 1 1 : ℝ) ≠ 0 := by
+  rcases eq_or_ne (γ 1 0) 0 with h | h
+  · have hdet := det_entries γ
+    rw [h, mul_zero, sub_zero] at hdet
+    rw [h]
+    push_cast
+    rw [zero_mul, zero_add]
+    intro hzero
+    rw [show (γ 1 1 : ℤ) = 0 from by exact_mod_cast hzero, mul_zero] at hdet
+    exact zero_ne_one hdet
+  · intro heq
+    refine hx ⟨-(γ 1 1 : ℚ) / (γ 1 0 : ℚ), ?_⟩
+    have hc : (γ 1 0 : ℝ) ≠ 0 := by exact_mod_cast h
+    push_cast
+    rw [div_eq_iff hc]
+    linarith
+
+theorem irrational_moebius (γ : SL(2, ℤ)) {x : ℝ} (hx : Irrational x) :
+    Irrational (moebius γ x) := by
+  rintro ⟨q, hq⟩
+  have hden := den_ne_zero γ hx
+  rw [moebius, eq_comm, div_eq_iff hden] at hq
+  rcases eq_or_ne ((γ 0 0 : ℚ) - q * (γ 1 0 : ℚ)) 0 with h | h
+  · have hR : (γ 0 0 : ℝ) - (q : ℝ) * (γ 1 0 : ℝ) = 0 := by exact_mod_cast h
+    have hb : (γ 0 1 : ℝ) = (q : ℝ) * (γ 1 1 : ℝ) := by
+      linear_combination hq - x * hR
+    have hdet := det_entries_real γ
+    rw [show (γ 0 0 : ℝ) = (q : ℝ) * (γ 1 0 : ℝ) from by linarith, hb] at hdet
+    have h01 : (0 : ℝ) = 1 := by linear_combination hdet
+    exact zero_ne_one h01
+  · refine hx ⟨((q : ℚ) * (γ 1 1 : ℚ) - (γ 0 1 : ℚ)) / ((γ 0 0 : ℚ) - q * (γ 1 0 : ℚ)), ?_⟩
+    have hR : (γ 0 0 : ℝ) - (q : ℝ) * (γ 1 0 : ℝ) ≠ 0 := by
+      intro hc
+      exact h (by exact_mod_cast hc)
+    push_cast
+    rw [div_eq_iff hR]
+    linear_combination -hq
+
+private theorem div_div_div_same {P Q D : ℝ} (hD : D ≠ 0) : P / D / (Q / D) = P / Q := by
+  obtain rfl | hQ := eq_or_ne Q 0
+  · simp
+  · field_simp
+
+theorem moebius_mul (A B : SL(2, ℤ)) {x : ℝ} (hx : Irrational x) :
+    moebius (A * B) x = moebius A (moebius B x) := by
+  have hB : ((B 1 0 : ℝ) * x + (B 1 1 : ℝ)) ≠ 0 := den_ne_zero B hx
+  have key : ∀ a b : ℤ, (a : ℝ) * moebius B x + (b : ℝ)
+      = ((a : ℝ) * ((B 0 0 : ℝ) * x + (B 0 1 : ℝ))
+          + (b : ℝ) * ((B 1 0 : ℝ) * x + (B 1 1 : ℝ)))
+        / ((B 1 0 : ℝ) * x + (B 1 1 : ℝ)) := by
+    intro a b
+    rw [moebius, eq_div_iff hB, add_mul, mul_assoc, div_mul_cancel₀ _ hB]
+  rw [moebius, moebius, key (A 0 0) (A 0 1), key (A 1 0) (A 1 1), div_div_div_same hB]
+  have e00 := mul_entry A B 0 0
+  have e01 := mul_entry A B 0 1
+  have e10 := mul_entry A B 1 0
+  have e11 := mul_entry A B 1 1
+  congr 1
+  · rw [show ((A * B) 0 0 : ℝ) = ((A 0 0 * B 0 0 + A 0 1 * B 1 0 : ℤ) : ℝ) from by
+      exact_mod_cast congrArg (fun n : ℤ => (n : ℝ)) e00,
+      show ((A * B) 0 1 : ℝ) = ((A 0 0 * B 0 1 + A 0 1 * B 1 1 : ℤ) : ℝ) from by
+      exact_mod_cast congrArg (fun n : ℤ => (n : ℝ)) e01]
+    push_cast
+    ring
+  · rw [show ((A * B) 1 0 : ℝ) = ((A 1 0 * B 0 0 + A 1 1 * B 1 0 : ℤ) : ℝ) from by
+      exact_mod_cast congrArg (fun n : ℤ => (n : ℝ)) e10,
+      show ((A * B) 1 1 : ℝ) = ((A 1 0 * B 0 1 + A 1 1 * B 1 1 : ℤ) : ℝ) from by
+      exact_mod_cast congrArg (fun n : ℤ => (n : ℝ)) e11]
+    push_cast
+    ring
+
+theorem moebius_one (x : ℝ) : moebius 1 x = x := by
+  have h00 : ((1 : SL(2, ℤ)) 0 0 : ℤ) = 1 := rfl
+  have h01 : ((1 : SL(2, ℤ)) 0 1 : ℤ) = 0 := rfl
+  have h10 : ((1 : SL(2, ℤ)) 1 0 : ℤ) = 0 := rfl
+  have h11 : ((1 : SL(2, ℤ)) 1 1 : ℤ) = 1 := rfl
+  rw [moebius, h00, h01, h10, h11]
+  push_cast
+  rw [one_mul, add_zero, zero_mul, zero_add, div_one]
+
+noncomputable scoped instance : MulAction SL(2, ℤ) IrrationalPt where
+  smul γ x := ⟨moebius γ (x : ℝ), irrational_moebius γ x.2⟩
+  one_smul x := IrrationalPt.ext (moebius_one (x : ℝ))
+  mul_smul A B x := IrrationalPt.ext (moebius_mul A B x.2)
+
+theorem smul_coe (γ : SL(2, ℤ)) (x : IrrationalPt) :
+    ((γ • x : IrrationalPt) : ℝ) = moebius γ (x : ℝ) := rfl
+
+def Pos : Set IrrationalPt := {x | 0 < (x : ℝ)}
+
+def Neg : Set IrrationalPt := {x | (x : ℝ) < 0}
+
+theorem pos_nonempty : Pos.Nonempty := ⟨IrrationalPt.sqrtTwo, IrrationalPt.sqrtTwo_pos⟩
+
+theorem neg_nonempty : Neg.Nonempty := ⟨IrrationalPt.negSqrtTwo, IrrationalPt.negSqrtTwo_neg⟩
+
+theorem disjoint_pos_neg : Disjoint Pos Neg := by
+  rw [Set.disjoint_left]
+  intro x hx hx'
+  have h1 : (0 : ℝ) < (x : ℝ) := hx
+  have h2 : (x : ℝ) < 0 := hx'
+  linarith
+
+theorem S_smul_coe (x : IrrationalPt) : ((S • x : IrrationalPt) : ℝ) = -1 / (x : ℝ) := by
+  rw [smul_coe, moebius]
+  norm_num [show (S 0 0 : ℤ) = 0 from rfl, show (S 0 1 : ℤ) = -1 from rfl,
+    show (S 1 0 : ℤ) = 1 from rfl, show (S 1 1 : ℤ) = 0 from rfl]
+
+theorem ST_smul_coe (x : IrrationalPt) :
+    (((S * T) • x : IrrationalPt) : ℝ) = -1 / ((x : ℝ) + 1) := by
+  rw [smul_coe, moebius]
+  norm_num [show ((S * T) 0 0 : ℤ) = 0 from rfl, show ((S * T) 0 1 : ℤ) = -1 from rfl,
+    show ((S * T) 1 0 : ℤ) = 1 from rfl, show ((S * T) 1 1 : ℤ) = 1 from rfl]
+
+theorem ST_sq_smul_coe (x : IrrationalPt) :
+    ((((S * T) * (S * T)) • x : IrrationalPt) : ℝ) = (-(x : ℝ) - 1) / (x : ℝ) := by
+  rw [smul_coe, moebius]
+  norm_num [show (((S * T) * (S * T)) 0 0 : ℤ) = -1 from rfl,
+    show (((S * T) * (S * T)) 0 1 : ℤ) = -1 from rfl,
+    show (((S * T) * (S * T)) 1 0 : ℤ) = 1 from rfl,
+    show (((S * T) * (S * T)) 1 1 : ℤ) = 0 from rfl]
+  ring
+
+theorem neg_one_smul_eq (x : IrrationalPt) : ((-1 : SL(2, ℤ)) • x) = x := by
+  apply IrrationalPt.ext
+  rw [smul_coe, moebius]
+  norm_num [show ((-1 : SL(2, ℤ)) 0 0 : ℤ) = -1 from rfl,
+    show ((-1 : SL(2, ℤ)) 0 1 : ℤ) = 0 from rfl,
+    show ((-1 : SL(2, ℤ)) 1 0 : ℤ) = 0 from rfl,
+    show ((-1 : SL(2, ℤ)) 1 1 : ℤ) = -1 from rfl]
+
+theorem S_smul_neg_mem_pos {x : IrrationalPt} (hx : x ∈ Neg) : S • x ∈ Pos := by
+  change (0 : ℝ) < ((S • x : IrrationalPt) : ℝ)
+  rw [S_smul_coe]
+  exact div_pos_of_neg_of_neg (by norm_num) hx
+
+theorem ST_smul_pos_mem_neg {x : IrrationalPt} (hx : x ∈ Pos) : (S * T) • x ∈ Neg := by
+  change (((S * T) • x : IrrationalPt) : ℝ) < 0
+  rw [ST_smul_coe]
+  apply div_neg_of_neg_of_pos (by norm_num)
+  have : (0 : ℝ) < (x : ℝ) := hx
+  linarith
+
+theorem ST_sq_smul_pos_mem_neg {x : IrrationalPt} (hx : x ∈ Pos) :
+    ((S * T) * (S * T)) • x ∈ Neg := by
+  change ((((S * T) * (S * T)) • x : IrrationalPt) : ℝ) < 0
+  rw [ST_sq_smul_coe]
+  have : (0 : ℝ) < (x : ℝ) := hx
+  apply div_neg_of_neg_of_pos (by linarith) this
+
+noncomputable def toPerm : SL(2, ℤ) →* Equiv.Perm IrrationalPt :=
+  MulAction.toPermHom SL(2, ℤ) IrrationalPt
+
+theorem toPerm_apply (γ : SL(2, ℤ)) (x : IrrationalPt) : toPerm γ x = γ • x := rfl
+
+noncomputable def permS : Equiv.Perm IrrationalPt := toPerm S
+
+noncomputable def permU : Equiv.Perm IrrationalPt := toPerm (S * T)
+
+theorem toPerm_neg_one : toPerm (-1) = 1 := by
+  apply Equiv.ext
+  intro x
+  exact neg_one_smul_eq x
+
+theorem permS_sq : permS ^ 2 = 1 := by
+  rw [permS, ← map_pow, show S ^ 2 = -1 from by decide, toPerm_neg_one]
+
+theorem permU_pow_three : permU ^ 3 = 1 := by
+  rw [permU, ← map_pow, show (S * T) ^ 3 = -1 from by decide, toPerm_neg_one]
+
+theorem permS_ne_one : permS ≠ 1 := by
+  intro h
+  have h2 : permS IrrationalPt.sqrtTwo = IrrationalPt.sqrtTwo := by rw [h]; rfl
+  have h3 : ((S • IrrationalPt.sqrtTwo : IrrationalPt) : ℝ) = (IrrationalPt.sqrtTwo : ℝ) :=
+    congrArg _ h2
+  rw [S_smul_coe] at h3
+  have hpos := IrrationalPt.sqrtTwo_pos
+  have : -1 / (IrrationalPt.sqrtTwo : ℝ) < 0 := div_neg_of_neg_of_pos (by norm_num) hpos
+  linarith
+
+theorem permU_ne_one : permU ≠ 1 := by
+  intro h
+  have h2 : permU IrrationalPt.sqrtTwo = IrrationalPt.sqrtTwo := by rw [h]; rfl
+  have h3 : (((S * T) • IrrationalPt.sqrtTwo : IrrationalPt) : ℝ)
+      = (IrrationalPt.sqrtTwo : ℝ) := congrArg _ h2
+  rw [ST_smul_coe] at h3
+  have hpos := IrrationalPt.sqrtTwo_pos
+  have : -1 / ((IrrationalPt.sqrtTwo : ℝ) + 1) < 0 :=
+    div_neg_of_neg_of_pos (by norm_num) (by linarith)
+  linarith
+
+theorem permU_sq_ne_one : permU ^ 2 ≠ 1 := by
+  intro h
+  have h2 : (permU ^ 2) IrrationalPt.sqrtTwo = IrrationalPt.sqrtTwo := by rw [h]; rfl
+  have hcoe : (permU ^ 2) IrrationalPt.sqrtTwo
+      = (((S * T) * (S * T)) • IrrationalPt.sqrtTwo : IrrationalPt) := by
+    rw [pow_two, permU, ← map_mul]
+    rfl
+  rw [hcoe] at h2
+  have h3 : ((((S * T) * (S * T)) • IrrationalPt.sqrtTwo : IrrationalPt) : ℝ)
+      = (IrrationalPt.sqrtTwo : ℝ) := congrArg _ h2
+  rw [ST_sq_smul_coe] at h3
+  have hpos := IrrationalPt.sqrtTwo_pos
+  have : (-(IrrationalPt.sqrtTwo : ℝ) - 1) / (IrrationalPt.sqrtTwo : ℝ) < 0 :=
+    div_neg_of_neg_of_pos (by linarith) hpos
+  linarith
+
+theorem orderOf_permS : orderOf permS = 2 :=
+  orderOf_eq_prime permS_sq permS_ne_one
+
+theorem orderOf_permU : orderOf permU = 3 :=
+  orderOf_eq_prime permU_pow_three permU_ne_one
+
+open Subgroup
+
+abbrev G23 (i : Fin 2) : Type := Multiplicative (ZMod (i.val + 2))
+
+scoped instance factOneLt (i : Fin 2) : Fact (1 < i.val + 2) := ⟨by omega⟩
+
+noncomputable def gen : Fin 2 → Equiv.Perm IrrationalPt := ![permS, permU]
+
+@[scoped simp] theorem gen_zero : gen 0 = permS := rfl
+@[scoped simp] theorem gen_one : gen 1 = permU := rfl
+
+theorem gen_pow_eq_one (i : Fin 2) : gen i ^ (i.val + 2) = 1 := by
+  fin_cases i
+  · exact permS_sq
+  · exact permU_pow_three
+
+noncomputable def incl (i : Fin 2) : G23 i →* Equiv.Perm IrrationalPt where
+  toFun x := gen i ^ (Multiplicative.toAdd x).val
+  map_one' := by rw [toAdd_one, ZMod.val_zero, pow_zero]
+  map_mul' x y := by
+    rw [toAdd_mul, ZMod.val_add, ← pow_eq_pow_mod _ (gen_pow_eq_one i), pow_add]
+
+theorem incl_ofAdd_one (i : Fin 2) : incl i (Multiplicative.ofAdd 1) = gen i := by
+  change gen i ^ (Multiplicative.toAdd (Multiplicative.ofAdd (1 : ZMod (i.val + 2)))).val = gen i
+  rw [toAdd_ofAdd, ZMod.val_one, pow_one]
+
+theorem incl_zero_eq (h : G23 0) (hne : h ≠ 1) : incl 0 h = permS := by
+  have hh : h = Multiplicative.ofAdd 1 := by
+    revert hne; revert h; decide
+  subst hh
+  rw [incl_ofAdd_one, gen_zero]
+
+theorem incl_one_eq (h : G23 1) (hne : h ≠ 1) :
+    incl 1 h = permU ∨ incl 1 h = permU * permU := by
+  have hh : h = Multiplicative.ofAdd 1 ∨
+      h = Multiplicative.ofAdd 1 * Multiplicative.ofAdd 1 := by
+    revert hne; revert h; decide
+  rcases hh with rfl | rfl
+  · left; rw [incl_ofAdd_one, gen_one]
+  · right; rw [map_mul, incl_ofAdd_one, gen_one]
+
+def pingPongSet : Fin 2 → Set IrrationalPt := ![Pos, Neg]
+
+@[scoped simp] theorem pingPongSet_zero : pingPongSet 0 = Pos := rfl
+@[scoped simp] theorem pingPongSet_one : pingPongSet 1 = Neg := rfl
+
+theorem pingPong : Pairwise fun i j => ∀ h : G23 i, h ≠ 1 →
+    incl i h • pingPongSet j ⊆ pingPongSet i := by
+  intro i j hij h hne
+  fin_cases i <;> fin_cases j
+  · exact absurd rfl hij
+  · rintro _ ⟨y, hy, rfl⟩
+    change incl 0 h • y ∈ Pos
+    rw [incl_zero_eq h hne]
+    exact S_smul_neg_mem_pos hy
+  · rintro _ ⟨y, hy, rfl⟩
+    change incl 1 h • y ∈ Neg
+    rcases incl_one_eq h hne with h1 | h2
+    · rw [h1]
+      exact ST_smul_pos_mem_neg hy
+    · rw [h2, permU, ← map_mul]
+      exact ST_sq_smul_pos_mem_neg hy
+  · exact absurd rfl hij
+
+theorem three_le_card_factor_one : 3 ≤ Cardinal.mk (G23 1) := by
+  have hc : Fintype.card (G23 1) = 3 := by decide
+  rw [Cardinal.mk_fintype, hc]
+  norm_num
+
+theorem lift_injective : Function.Injective (Monoid.CoprodI.lift incl) := by
+  apply Monoid.CoprodI.lift_injective_of_ping_pong incl
+    (Or.inr ⟨1, three_le_card_factor_one⟩) pingPongSet
+  · intro i
+    fin_cases i
+    · exact pos_nonempty
+    · exact neg_nonempty
+  · intro i j hij
+    fin_cases i <;> fin_cases j
+    · exact absurd rfl hij
+    · exact disjoint_pos_neg
+    · exact disjoint_pos_neg.symm
+    · exact absurd rfl hij
+  · exact pingPong
+
+theorem range_lift_eq : (Monoid.CoprodI.lift incl).range = toPerm.range := by
+  apply le_antisymm
+  · rw [Monoid.CoprodI.range_eq_iSup]
+    apply iSup_le
+    intro i
+    rintro _ ⟨x, rfl⟩
+    change gen i ^ (Multiplicative.toAdd x).val ∈ toPerm.range
+    refine Subgroup.pow_mem _ ?_ _
+    fin_cases i
+    · exact ⟨S, rfl⟩
+    · exact ⟨S * T, rfl⟩
+  · rw [MonoidHom.range_eq_map, ← SpecialLinearGroup.SL2Z_generators, MonoidHom.map_closure,
+      Subgroup.closure_le]
+    rintro _ ⟨x, hx, rfl⟩
+    simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hx
+    have hS : toPerm S ∈ (Monoid.CoprodI.lift incl).range := by
+      refine ⟨Monoid.CoprodI.of (i := 0) (Multiplicative.ofAdd 1), ?_⟩
+      rw [Monoid.CoprodI.lift_of, incl_ofAdd_one, gen_zero, permS]
+    have hST : toPerm (S * T) ∈ (Monoid.CoprodI.lift incl).range := by
+      refine ⟨Monoid.CoprodI.of (i := 1) (Multiplicative.ofAdd 1), ?_⟩
+      rw [Monoid.CoprodI.lift_of, incl_ofAdd_one, gen_one, permU]
+    rcases hx with rfl | rfl
+    · exact hS
+    · have : toPerm T = (toPerm S)⁻¹ * toPerm (S * T) := by
+        rw [← map_inv, ← map_mul, inv_mul_cancel_left]
+      rw [this]
+      exact mul_mem (inv_mem hS) hST
+
+theorem irrational_sqrt_three : Irrational (Real.sqrt 3) := by
+  have h : Irrational (Real.sqrt ((3 : ℕ) : ℝ)) := Nat.prime_three.irrational_sqrt
+  rwa [Nat.cast_ofNat] at h
+
+theorem eq_zero_of_irrational_relation {x : ℝ} (hx : Irrational x) {p q : ℤ}
+    (h : (p : ℝ) + (q : ℝ) * x = 0) : p = 0 ∧ q = 0 := by
+  rcases eq_or_ne q 0 with rfl | hq
+  · refine ⟨?_, rfl⟩
+    have hp : (p : ℝ) = 0 := by push_cast at h; linarith
+    exact_mod_cast hp
+  · exfalso
+    refine hx ⟨-(p : ℚ) / (q : ℚ), ?_⟩
+    have hq' : (q : ℝ) ≠ 0 := by exact_mod_cast hq
+    push_cast
+    rw [div_eq_iff hq']
+    have hcomm : x * (q : ℝ) = (q : ℝ) * x := mul_comm _ _
+    linarith
+
+theorem moebius_eq_self_relation (γ : SL(2, ℤ)) {x : ℝ} (hx : Irrational x)
+    (h : moebius γ x = x) :
+    (γ 1 0 : ℝ) * (x * x) + ((γ 1 1 : ℝ) - (γ 0 0 : ℝ)) * x - (γ 0 1 : ℝ) = 0 := by
+  rw [moebius, div_eq_iff (den_ne_zero γ hx)] at h
+  linear_combination -h
+
+theorem eq_one_or_neg_one_of_toPerm_eq_one {γ : SL(2, ℤ)} (h : toPerm γ = 1) :
+    γ = 1 ∨ γ = -1 := by
+  have key : ∀ x : IrrationalPt, moebius γ (x : ℝ) = (x : ℝ) := by
+    intro x
+    have hx : toPerm γ x = x := by simp [h]
+    have hval : ((γ • x : IrrationalPt) : ℝ) = (x : ℝ) := congrArg Subtype.val hx
+    rwa [smul_coe] at hval
+  have r2 := moebius_eq_self_relation γ irrational_sqrt_two
+    (key ⟨Real.sqrt 2, irrational_sqrt_two⟩)
+  rw [Real.mul_self_sqrt (by norm_num : (0 : ℝ) ≤ 2)] at r2
+  obtain ⟨h2a, hdiag⟩ := eq_zero_of_irrational_relation irrational_sqrt_two
+    (p := 2 * γ 1 0 - γ 0 1) (q := γ 1 1 - γ 0 0) (by push_cast; linear_combination r2)
+  have r3 := moebius_eq_self_relation γ irrational_sqrt_three
+    (key ⟨Real.sqrt 3, irrational_sqrt_three⟩)
+  rw [Real.mul_self_sqrt (by norm_num : (0 : ℝ) ≤ 3)] at r3
+  obtain ⟨h3a, -⟩ := eq_zero_of_irrational_relation irrational_sqrt_three
+    (p := 3 * γ 1 0 - γ 0 1) (q := γ 1 1 - γ 0 0) (by push_cast; linear_combination r3)
+  have hc : γ 1 0 = 0 := by omega
+  have hb : γ 0 1 = 0 := by omega
+  have hd : γ 1 1 = γ 0 0 := by omega
+  have hdet : γ 0 0 * γ 0 0 = 1 := by
+    have h0 := det_entries γ
+    rw [hb, hc, hd] at h0
+    linear_combination h0
+  rcases mul_self_eq_one_iff.mp hdet with h00 | h00
+  · left
+    ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp [hb, hc, hd, h00]
+  · right
+    ext i j
+    fin_cases i <;> fin_cases j <;>
+      simp [hb, hc, hd, h00, Matrix.SpecialLinearGroup.coe_neg, Matrix.neg_apply]
+
+theorem mem_center_iff_eq (A : SL(2, ℤ)) : A ∈ Subgroup.center SL(2, ℤ) ↔ A = 1 ∨ A = -1 := by
+  rw [Matrix.SpecialLinearGroup.mem_center_iff]
+  constructor
+  · rintro ⟨r, hr, hA⟩
+    have hr' : r * r = 1 := by rw [← pow_two]; simpa using hr
+    rcases mul_self_eq_one_iff.mp hr' with rfl | rfl
+    · left
+      apply Subtype.ext
+      rw [← hA, map_one]
+      rfl
+    · right
+      apply Subtype.ext
+      rw [← hA, map_neg, map_one]
+      rfl
+  · rintro (rfl | rfl)
+    · exact ⟨1, by simp, by simp⟩
+    · exact ⟨-1, by simp, by simp⟩
+
+theorem ker_toPerm_eq_center : toPerm.ker = Subgroup.center SL(2, ℤ) := by
+  ext γ
+  rw [MonoidHom.mem_ker, mem_center_iff_eq]
+  constructor
+  · exact eq_one_or_neg_one_of_toPerm_eq_one
+  · rintro (rfl | rfl)
+    · exact map_one _
+    · exact toPerm_neg_one
+
+noncomputable def equivRange : Monoid.CoprodI G23 ≃* toPerm.range :=
+  (MonoidHom.ofInjective lift_injective).trans (MulEquiv.subgroupCongr range_lift_eq)
+
+theorem equivRange_apply_coe (w : Monoid.CoprodI G23) :
+    (equivRange w : Equiv.Perm IrrationalPt) = Monoid.CoprodI.lift incl w := rfl
+
+noncomputable def mulEquiv : Monoid.CoprodI G23 ≃* SL(2, ℤ) ⧸ Subgroup.center SL(2, ℤ) :=
+  equivRange.trans
+    ((QuotientGroup.quotientKerEquivRange toPerm).symm.trans
+      (QuotientGroup.quotientMulEquivOfEq ker_toPerm_eq_center))
+
+theorem mulEquiv_apply_of_eq (i : Fin 2) (x : G23 i) (g : SL(2, ℤ)) (hg : toPerm g = incl i x) :
+    mulEquiv (Monoid.CoprodI.of x) = QuotientGroup.mk g := by
+  unfold mulEquiv
+  rw [MulEquiv.trans_apply, MulEquiv.trans_apply]
+  have h1 : equivRange (Monoid.CoprodI.of x) = ⟨toPerm g, g, rfl⟩ := by
+    apply Subtype.ext
+    rw [equivRange_apply_coe, Monoid.CoprodI.lift_of]
+    exact hg.symm
+  have h2 : (QuotientGroup.quotientKerEquivRange toPerm) (QuotientGroup.mk g) = ⟨toPerm g, g, rfl⟩
+    :=
+    rfl
+  rw [h1, ← h2, MulEquiv.symm_apply_apply]
+  rfl
+
+theorem mulEquiv_of_zero :
+    mulEquiv (Monoid.CoprodI.of (i := 0) (Multiplicative.ofAdd 1)) = QuotientGroup.mk S :=
+  mulEquiv_apply_of_eq 0 _ S (by rw [incl_ofAdd_one, gen_zero, permS])
+
+theorem mulEquiv_of_one :
+    mulEquiv (Monoid.CoprodI.of (i := 1) (Multiplicative.ofAdd 1)) = QuotientGroup.mk (S * T) :=
+  mulEquiv_apply_of_eq 1 _ (S * T) (by rw [incl_ofAdd_one, gen_one, permU])
+
+end ModularGroupPingPong
+end ModularCurve
+
+theorem solution :
+    ∃ e : Monoid.CoprodI (fun i : Fin 2 => Multiplicative (ZMod (i.val + 2)))
+        ≃* Matrix.SpecialLinearGroup (Fin 2) ℤ ⧸ Subgroup.center (Matrix.SpecialLinearGroup (Fin 2)
+          ℤ),
+      e (Monoid.CoprodI.of (M := fun i : Fin 2 => Multiplicative (ZMod (i.val + 2))) (i := 0)
+          (Multiplicative.ofAdd 1)) = QuotientGroup.mk ModularGroup.S ∧
+      e (Monoid.CoprodI.of (M := fun i : Fin 2 => Multiplicative (ZMod (i.val + 2))) (i := 1)
+          (Multiplicative.ofAdd 1)) = QuotientGroup.mk (ModularGroup.S * ModularGroup.T) :=
+  ⟨ModularCurve.ModularGroupPingPong.mulEquiv, ModularCurve.ModularGroupPingPong.mulEquiv_of_zero,
+    ModularCurve.ModularGroupPingPong.mulEquiv_of_one⟩
+
+end S_ModularGroup_exists_mulEquiv_freeProduct_quotient_center
+end P2MW
+export P2MW.S_ModularGroup_exists_mulEquiv_freeProduct_quotient_center (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem ModularGroup.exists_mulEquiv_freeProduct_quotient_center :
+    ∃ e : Monoid.CoprodI (fun i : Fin 2 => Multiplicative (ZMod (i.val + 2)))
+        ≃* Matrix.SpecialLinearGroup (Fin 2) ℤ ⧸ Subgroup.center (Matrix.SpecialLinearGroup (Fin 2)
+          ℤ),
+      e (Monoid.CoprodI.of (M := fun i : Fin 2 => Multiplicative (ZMod (i.val + 2))) (i := 0)
+          (Multiplicative.ofAdd 1)) = QuotientGroup.mk ModularGroup.S ∧
+      e (Monoid.CoprodI.of (M := fun i : Fin 2 => Multiplicative (ZMod (i.val + 2))) (i := 1)
+          (Multiplicative.ofAdd 1)) = QuotientGroup.mk (ModularGroup.S * ModularGroup.T) :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_MonoidAlgebra_isLocalRing_of_isPGroup.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_MonoidAlgebra_isLocalRing_of_isPGroup.lean
new file mode 100644
index 0000000000..46370dac5f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_MonoidAlgebra_isLocalRing_of_isPGroup.lean
@@ -0,0 +1,210 @@
+/-
+Based on Prove2Me node MonoidAlgebra.isLocalRing_of_isPGroup
+(7ce0fa38-2284-5b44-be60-d8d4bda77e9a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3d5ed44a-2f20-507a-ab24-8def69c820f1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.MonoidAlgebra.Defs
+public import Mathlib.GroupTheory.PGroup
+public import Mathlib.RingTheory.LocalRing.MaximalIdeal.Defs
+
+import Mathlib.Algebra.CharP.Lemmas
+import Mathlib.RingTheory.Bialgebra.Basic
+import Mathlib.RingTheory.Coalgebra.MonoidAlgebra
+import Mathlib.RingTheory.Finiteness.Ideal
+import Mathlib.RingTheory.LocalRing.MaximalIdeal.Basic
+import Mathlib.RingTheory.Nakayama
+
+/-!
+# Group ring of a finite abelian p-group is local
+
+Theorem statement: `MonoidAlgebra.isLocalRing_of_isPGroup` (`7ce0fa38-2284-5b44-be60-d8d4bda77e9a`),
+by Claude, 2026-09-05.
+
+Proof: submission `3d5ed44a-2f20-507a-ab24-8def69c820f1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\mathcal O$ be a commutative ring that is local (so it has a unique maximal ideal $\mathfrak
+m_{\mathcal O}$, in Mathlib's `IsLocalRing` sense), let $p$ be a prime number, and assume that the
+image of $p$ under the canonical map $\mathbb N \to \mathcal O$ lies in $\mathfrak m_{\mathcal O}$.
+Let $G$ be a commutative group that is finite and that is a $p$-group in the sense of `IsPGroup p
+G`, i.e. every element of $G$ is killed by some power of $p$. The conclusion is that the monoid
+algebra $\mathcal O[G]$, namely `MonoidAlgebra 𝒪 G` (finitely supported functions $G \to \mathcal O$
+with convolution product), is again a local ring. No completeness or Noetherian hypothesis on
+$\mathcal O$ is imposed, and $\mathcal O$ is not assumed to have residue characteristic exactly $p$
+beyond the stated condition $p \in \mathfrak m_{\mathcal O}$; the two hypotheses $p \in \mathfrak
+m_{\mathcal O}$ and $G$ a $p$-group are both needed, since otherwise $\mathcal O[G]$ acquires
+non-trivial idempotents.
+
+This is the standard fact that the group ring of a finite abelian $p$-group over a local ring of
+residue characteristic divisible by $p$ is local, with maximal ideal the preimage of $\mathfrak
+m_{\mathcal O}$ under the augmentation. It is used in the Taylor–Wiles patching apparatus, where the
+diamond group ring $\mathcal O[\Delta_Q]$ must be a local $\mathcal O$-algebra; it is cited by the
+construction of the Hecke ring at Taylor–Wiles level, by the comparison of $\mathcal
+O[\Delta_Q]$-module bases, and by the presentation of $\mathcal O[G]$ as a quotient of a power
+series ring.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_MonoidAlgebra_isLocalRing_of_isPGroup.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+universe u v
+
+namespace S_MonoidAlgebra_isLocalRing_of_isPGroup
+
+namespace M4cP4R2L
+
+open MonoidAlgebra IsLocalRing
+
+variable {𝒪 : Type u} [CommRing 𝒪] {G : Type v} [CommGroup G]
+
+local notation "Λ" => MonoidAlgebra 𝒪 G
+
+theorem counit_of (g : G) : Coalgebra.counit (R := 𝒪) (MonoidAlgebra.of 𝒪 G g) = 1 := by
+  rw [MonoidAlgebra.of_apply, MonoidAlgebra.counit_single, CommSemiring.counit_apply]
+
+theorem sub_algebraMap_counit_mem (x : Λ) :
+    x - algebraMap 𝒪 Λ (Coalgebra.counit (R := 𝒪) x) ∈
+      Ideal.span (Set.range fun g : G => MonoidAlgebra.of 𝒪 G g - 1) := by
+  set J := Ideal.span (Set.range fun g : G => MonoidAlgebra.of 𝒪 G g - 1)
+  have hc : Coalgebra.counit (R := 𝒪) x = x.coeff.sum (fun _ a => a) := by
+    conv_lhs => rw [← MonoidAlgebra.sum_coeff_single x]
+    rw [Finsupp.sum, map_sum, Finsupp.sum]
+    refine Finset.sum_congr rfl fun g _ => ?_
+    rw [MonoidAlgebra.counit_single, CommSemiring.counit_apply]
+  have hdecomp : x - algebraMap 𝒪 Λ (Coalgebra.counit (R := 𝒪) x) =
+      x.coeff.sum (fun g a => a • (MonoidAlgebra.of 𝒪 G g - 1)) := by
+    rw [sub_eq_iff_eq_add, hc, Finsupp.sum, Finsupp.sum, map_sum, ← Finset.sum_add_distrib]
+    conv_lhs => rw [← MonoidAlgebra.sum_coeff_single x, Finsupp.sum]
+    refine Finset.sum_congr rfl fun g _ => ?_
+    rw [smul_sub, Algebra.algebraMap_eq_smul_one, sub_add_cancel, MonoidAlgebra.of_apply,
+      MonoidAlgebra.smul_single', mul_one]
+  rw [hdecomp, Finsupp.sum]
+  exact Submodule.sum_mem _ fun g _ => Submodule.smul_of_tower_mem _ _ (Ideal.subset_span ⟨g, rfl⟩)
+
+section PPow
+
+variable {p : ℕ} [Fact p.Prime]
+
+theorem of_sub_one_pow_mem (g : G) (k : ℕ) (hg : g ^ p ^ k = 1) :
+    (MonoidAlgebra.of 𝒪 G g - 1) ^ p ^ k ∈ Ideal.span {(p : Λ)} := by
+  obtain ⟨r, hr⟩ := exists_add_pow_prime_pow_eq (Fact.out : p.Prime) (MonoidAlgebra.of 𝒪 G g) (-1) k
+  rw [sub_eq_add_neg, hr, ← map_pow, hg, map_one]
+  rcases Nat.even_or_odd (p ^ k) with hev | hodd
+  · have hp2 : p = 2 := ((Fact.out : p.Prime).even_iff).mp (Nat.even_pow.mp hev).1
+    have h11 : (1 : Λ) + 1 = (p : Λ) := by rw [hp2, Nat.cast_two, one_add_one_eq_two]
+    rw [hev.neg_one_pow, h11, mul_assoc, mul_assoc]
+    exact Ideal.add_mem _ (Ideal.mem_span_singleton_self _) (Ideal.mul_mem_right _ _
+      (Ideal.mem_span_singleton_self _))
+  · rw [hodd.neg_one_pow, add_neg_cancel, zero_add, mul_assoc, mul_assoc]
+    exact Ideal.mul_mem_right _ _ (Ideal.mem_span_singleton_self _)
+
+end PPow
+
+section Local
+
+variable [IsLocalRing 𝒪]
+
+theorem isUnit_one_add_of_mem_map [Finite G] {m : Λ}
+    (hm : m ∈ (maximalIdeal 𝒪).map (algebraMap 𝒪 Λ)) : IsUnit (1 + m) := by
+  let μ : Λ →ₗ[𝒪] Λ := LinearMap.mulLeft 𝒪 (1 + m)
+  have hle : (⊤ : Submodule 𝒪 Λ) ≤ LinearMap.range μ ⊔ (maximalIdeal 𝒪) • ⊤ := by
+    intro x _
+    have hx : x = (1 + m) * x - m * x := by ring
+    rw [hx]
+    refine Submodule.sub_mem _ (Submodule.mem_sup_left ⟨x, rfl⟩) (Submodule.mem_sup_right ?_)
+    rw [Ideal.smul_top_eq_map]
+    exact Ideal.mul_mem_right _ _ hm
+  have htop : (⊤ : Submodule 𝒪 Λ) ≤ LinearMap.range μ :=
+    Submodule.le_of_le_smul_of_le_jacobson_bot Module.Finite.fg_top (maximalIdeal_le_jacobson _) hle
+  obtain ⟨y, hy⟩ : (1 : Λ) ∈ LinearMap.range μ := htop Submodule.mem_top
+  exact IsUnit.of_mul_eq_one y hy
+
+variable [Finite G] {p : ℕ} [Fact p.Prime]
+
+theorem exists_pow_augIdeal_le (hp : (p : 𝒪) ∈ maximalIdeal 𝒪) (hG : IsPGroup p G) :
+    ∃ N : ℕ, Ideal.span (Set.range fun g : G => MonoidAlgebra.of 𝒪 G g - 1) ^ N ≤
+      (maximalIdeal 𝒪).map (algebraMap 𝒪 Λ) := by
+  refine Ideal.exists_pow_le_of_le_radical_of_fg ?_ (Submodule.fg_span (Set.finite_range _))
+  rw [Ideal.span_le]
+  rintro _ ⟨g, rfl⟩
+  obtain ⟨k, hk⟩ := hG g
+  refine ⟨p ^ k, ?_⟩
+  have hpmem : (p : Λ) ∈ (maximalIdeal 𝒪).map (algebraMap 𝒪 Λ) := by
+    rw [← map_natCast (algebraMap 𝒪 Λ)]
+    exact Ideal.mem_map_of_mem _ hp
+  exact (Ideal.span_singleton_le_iff_mem _ |>.mpr hpmem) (of_sub_one_pow_mem g k hk)
+
+theorem isUnit_one_add_of_mem_augIdeal (hp : (p : 𝒪) ∈ maximalIdeal 𝒪) (hG : IsPGroup p G) {i : Λ}
+    (hi : i ∈ Ideal.span (Set.range fun g : G => MonoidAlgebra.of 𝒪 G g - 1)) : IsUnit (1 + i) := by
+  obtain ⟨N, hN⟩ := exists_pow_augIdeal_le (𝒪 := 𝒪) (G := G) hp hG
+  have hiN : (-i) ^ N ∈ (maximalIdeal 𝒪).map (algebraMap 𝒪 Λ) := by
+    rw [neg_pow]
+    exact Ideal.mul_mem_left _ _ (hN (Ideal.pow_mem_pow hi N))
+  have hgeom : (1 + i) * ∑ j ∈ Finset.range N, (-i) ^ j = 1 + -(-i) ^ N := by
+    have := mul_neg_geom_sum (-i) N
+    rw [sub_neg_eq_add] at this
+    rw [this, sub_eq_add_neg]
+  have hu : IsUnit ((1 + i) * ∑ j ∈ Finset.range N, (-i) ^ j) := by
+    rw [hgeom]
+    exact isUnit_one_add_of_mem_map (Ideal.neg_mem_iff _ |>.mpr hiN)
+  exact isUnit_of_mul_isUnit_left hu
+
+theorem isUnit_of_counit_not_mem (hp : (p : 𝒪) ∈ maximalIdeal 𝒪) (hG : IsPGroup p G) {x : Λ}
+    (hx : Coalgebra.counit (R := 𝒪) x ∉ maximalIdeal 𝒪) : IsUnit x := by
+  set c := Coalgebra.counit (R := 𝒪) x
+  have hc : IsUnit c := by
+    by_contra h
+    exact hx ((mem_maximalIdeal _).mpr h)
+  obtain ⟨u, hu⟩ := hc
+  have hdecomp : x = algebraMap 𝒪 Λ c * (1 + algebraMap 𝒪 Λ (↑u⁻¹ : 𝒪) * (x - algebraMap 𝒪 Λ c)) :=
+    by
+    rw [mul_add, mul_one, ← mul_assoc, ← map_mul, ← hu, Units.mul_inv, map_one, one_mul,
+      add_sub_cancel]
+  rw [hdecomp]
+  refine ((hu ▸ Units.isUnit u).map (algebraMap 𝒪 Λ)).mul ?_
+  exact isUnit_one_add_of_mem_augIdeal hp hG (Ideal.mul_mem_left _ _ (sub_algebraMap_counit_mem x))
+
+end Local
+
+end M4cP4R2L
+
+open M4cP4R2L IsLocalRing in
+theorem solution
+    {𝒪 : Type u} [CommRing 𝒪] [IsLocalRing 𝒪] {p : ℕ} [Fact p.Prime]
+    (hp : (p : 𝒪) ∈ IsLocalRing.maximalIdeal 𝒪)
+    {G : Type v} [CommGroup G] [Finite G] (hG : IsPGroup p G) :
+    IsLocalRing (MonoidAlgebra 𝒪 G) := by
+  refine IsLocalRing.of_isUnit_or_isUnit_one_sub_self fun a => ?_
+  by_cases ha : Coalgebra.counit (R := 𝒪) a ∈ maximalIdeal 𝒪
+  · right
+    refine isUnit_of_counit_not_mem hp hG ?_
+    intro h1
+    have : Coalgebra.counit (R := 𝒪) (1 : MonoidAlgebra 𝒪 G) = 1 := by
+      rw [MonoidAlgebra.one_def, MonoidAlgebra.counit_single, CommSemiring.counit_apply]
+    rw [map_sub, this] at h1
+    exact (maximalIdeal.isMaximal 𝒪).ne_top
+      ((Ideal.eq_top_iff_one _).mpr (by simpa using (maximalIdeal 𝒪).add_mem h1 ha))
+  · exact Or.inl (isUnit_of_counit_not_mem hp hG ha)
+
+end S_MonoidAlgebra_isLocalRing_of_isPGroup
+
+public section publicSection
+
+theorem MonoidAlgebra.isLocalRing_of_isPGroup {𝒪 : Type u} [CommRing 𝒪] [IsLocalRing 𝒪] {p : ℕ}
+    [Fact p.Prime] (hp : (p : 𝒪) ∈ IsLocalRing.maximalIdeal 𝒪) {G : Type v} [CommGroup G]
+    [Finite G] (hG : IsPGroup p G) : IsLocalRing (MonoidAlgebra 𝒪 G) :=
+  S_MonoidAlgebra_isLocalRing_of_isPGroup.solution hp hG
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Monoid_CoprodI_exists_addMonoidHom_conj_pow_minimalPeriod_eq_of_finsum_eq_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Monoid_CoprodI_exists_addMonoidHom_conj_pow_minimalPeriod_eq_of_finsum_eq_zero.lean
new file mode 100644
index 0000000000..7f0a71b3e9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Monoid_CoprodI_exists_addMonoidHom_conj_pow_minimalPeriod_eq_of_finsum_eq_zero.lean
@@ -0,0 +1,634 @@
+/-
+Based on Prove2Me node
+Monoid.CoprodI.exists_addMonoidHom_conj_pow_minimalPeriod_eq_of_finsum_eq_zero
+(58b14f3f-1204-5f4c-b250-45a15a04fa48) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1cbeae97-a859-5ba9-911c-45cfc97a8772
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.BigOperators.Finprod
+public import Mathlib.GroupTheory.CoprodI
+public import Mathlib.GroupTheory.Index
+
+import Mathlib.Algebra.GroupWithZero.Action.Hom
+import Mathlib.Data.Finsupp.Basic
+import Mathlib.LinearAlgebra.Span.Basic
+import Mathlib.Data.ZMod.QuotientGroup
+import Mathlib.GroupTheory.SemidirectProduct
+
+/-!
+# Sum-zero cusp functions arise from characters of H
+
+Theorem statement: `Monoid.CoprodI.exists_addMonoidHom_conj_pow_minimalPeriod_eq_of_finsum_eq_zero`
+(`58b14f3f-1204-5f4c-b250-45a15a04fa48`), by Claude, 2026-09-05.
+
+Proof: submission `1cbeae97-a859-5ba9-911c-45cfc97a8772`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $G$ denote the free product (`Monoid.CoprodI`) of the family $i \mapsto
+\mathrm{Multiplicative}(\mathbb{Z}/(i+2))$ indexed by $i \in \mathrm{Fin}\,2$, that is, $C_2 * C_3$
+written multiplicatively, and let $t \in G$ be an element assumed equal to the product of the
+canonical image in $G$ of the generator $\mathrm{ofAdd}\,1$ of the factor with index $0$ and the
+canonical image of the generator $\mathrm{ofAdd}\,1$ of the factor with index $1$. Let $H \le G$ be
+a subgroup of finite index, and let $R$ be an additive abelian group. Consider the quotient of the
+coset space $G/H$ by the orbit relation of the action of the subgroup $\langle t \rangle$ of integer
+powers of $t$, and let $a$ be an arbitrary function from that quotient to $R$ whose (finitely
+supported) sum $\sum^{\mathrm{f}}_{c} a(c)$ vanishes. Then there is an additive homomorphism
+$\varphi$ from $H$, viewed additively, to $R$ with the following property: for every $g \in G$ and
+every proof that $g^{-1} t^{\,w} g \in H$, where $w$ is the minimal period of the map $x \mapsto t
+\cdot x$ at the coset $gH$, the value of $\varphi$ at the corresponding element of $H$ equals $a$
+evaluated at the $\langle t \rangle$-orbit class of $gH$.
+
+In the identification $C_2 * C_3 \cong \mathrm{PSL}_2(\mathbb{Z})$ the element $t$ corresponds to
+the parabolic class of $T$, the $\langle t \rangle$-orbits on $G/H$ are the cusps of the
+finite-index subgroup $H$, the minimal period $w$ is the width of the cusp through $gH$, and
+$g^{-1}t^{w}g$ is the associated cusp generator; the statement says that every $R$-valued function
+on the cusps with total sum zero is realised by evaluating a homomorphism $H \to R$ on the cusp
+generators. It is used for the corresponding assertion about $\mathrm{SL}_2(\mathbb{Z})$ and its
+parabolic elements, and thence in the construction of homomorphisms on congruence subgroups with
+prescribed behaviour at the cusps.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Monoid_CoprodI_exists_addMonoidHom_conj_pow_minimalPeriod_eq_of_finsum_eq_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open Subgroup Monoid Monoid.CoprodI MulAction
+
+noncomputable section
+
+namespace BassSerreCusp
+
+section EdgeChain
+
+variable {G : Fin 2 → Type*} [∀ i, Group (G i)]
+
+def lTransl (g : CoprodI G) : (CoprodI G →₀ ℤ) →+ (CoprodI G →₀ ℤ) :=
+  Finsupp.mapDomain.addMonoidHom (g * ·)
+
+@[scoped simp] theorem lTransl_single (g x : CoprodI G) (n : ℤ) :
+    lTransl g (Finsupp.single x n) = Finsupp.single (g * x) n :=
+  Finsupp.mapDomain_single
+
+@[scoped simp] theorem lTransl_one_apply (f : CoprodI G →₀ ℤ) : lTransl 1 f = f := by
+  change Finsupp.mapDomain (1 * ·) f = f
+  rw [show ((1 : CoprodI G) * ·) = id from funext fun x => one_mul x]
+  exact Finsupp.mapDomain_id
+
+theorem lTransl_mul_apply (g₁ g₂ : CoprodI G) (f : CoprodI G →₀ ℤ) :
+    lTransl (g₁ * g₂) f = lTransl g₁ (lTransl g₂ f) := by
+  change Finsupp.mapDomain (g₁ * g₂ * ·) f
+      = Finsupp.mapDomain (g₁ * ·) (Finsupp.mapDomain (g₂ * ·) f)
+  rw [← Finsupp.mapDomain_comp]
+  simp only [Function.comp_def, mul_assoc]
+
+def lTranslAddAut (g : CoprodI G) : AddAut (CoprodI G →₀ ℤ) where
+  toFun := lTransl g
+  invFun := lTransl g⁻¹
+  left_inv f := by rw [← lTransl_mul_apply, inv_mul_cancel, lTransl_one_apply]
+  right_inv f := by rw [← lTransl_mul_apply, mul_inv_cancel, lTransl_one_apply]
+  map_add' := (lTransl g).map_add
+
+def lTranslMulAut : CoprodI G →* MulAut (Multiplicative (CoprodI G →₀ ℤ)) where
+  toFun g := AddEquiv.toMultiplicative (lTranslAddAut g)
+  map_one' := MulEquiv.ext fun f => Multiplicative.toAdd.injective
+    (lTransl_one_apply (Multiplicative.toAdd f))
+  map_mul' g₁ g₂ := MulEquiv.ext fun f => Multiplicative.toAdd.injective
+    (lTransl_mul_apply g₁ g₂ (Multiplicative.toAdd f))
+
+@[scoped simp] theorem toAdd_lTranslMulAut (g : CoprodI G)
+    (f : Multiplicative (CoprodI G →₀ ℤ)) :
+    Multiplicative.toAdd (lTranslMulAut g f) = lTransl g (Multiplicative.toAdd f) := rfl
+
+abbrev ChainCarrier (G : Fin 2 → Type*) [∀ i, Group (G i)] : Type _ :=
+  SemidirectProduct (Multiplicative (CoprodI G →₀ ℤ)) (CoprodI G) lTranslMulAut
+
+def factorOneSect : G 1 →* ChainCarrier G where
+  toFun a := ⟨Multiplicative.ofAdd
+      (Finsupp.single 1 1 - Finsupp.single (CoprodI.of a) 1 : CoprodI G →₀ ℤ),
+    CoprodI.of a⟩
+  map_one' := by
+    refine SemidirectProduct.ext ?_ ?_
+    · change Multiplicative.ofAdd (Finsupp.single 1 1 - Finsupp.single (of (1 : G 1)) 1) = 1
+      rw [map_one, sub_self]; rfl
+    · exact map_one _
+  map_mul' a b := by
+    refine SemidirectProduct.ext ?_ (map_mul CoprodI.of a b)
+    change Multiplicative.ofAdd
+        (Finsupp.single 1 1 - Finsupp.single (of (a * b)) 1 : CoprodI G →₀ ℤ) =
+      Multiplicative.ofAdd (Finsupp.single 1 1 - Finsupp.single (of a) 1) *
+        lTranslMulAut (of a)
+          (Multiplicative.ofAdd (Finsupp.single 1 1 - Finsupp.single (of b) 1))
+    apply Multiplicative.toAdd.injective
+    rw [toAdd_mul, toAdd_lTranslMulAut, toAdd_ofAdd, toAdd_ofAdd, toAdd_ofAdd,
+      map_sub, lTransl_single, lTransl_single, mul_one, map_mul,
+      sub_add_sub_cancel]
+
+def chainSect : CoprodI G →* ChainCarrier G :=
+  CoprodI.lift fun i =>
+    match i with
+    | 0 => SemidirectProduct.inr.comp CoprodI.of
+    | 1 => factorOneSect
+
+@[scoped simp] theorem chainSect_right (g : CoprodI G) : (chainSect g).right = g := by
+  have h : SemidirectProduct.rightHom.comp chainSect = MonoidHom.id (CoprodI G) := by
+    refine CoprodI.ext_hom _ _ fun i => ?_
+    match i with
+    | 0 => ext a; rfl
+    | 1 => ext a; rfl
+  exact DFunLike.congr_fun h g
+
+def edgeChain (g : CoprodI G) : CoprodI G →₀ ℤ :=
+  Multiplicative.toAdd (chainSect g).left
+
+@[scoped simp] theorem edgeChain_one : edgeChain (1 : CoprodI G) = 0 := by
+  unfold edgeChain; rw [map_one]; rfl
+
+theorem edgeChain_mul (g₁ g₂ : CoprodI G) :
+    edgeChain (g₁ * g₂) = edgeChain g₁ + lTransl g₁ (edgeChain g₂) := by
+  unfold edgeChain
+  rw [map_mul, SemidirectProduct.mul_left, chainSect_right, toAdd_mul, toAdd_lTranslMulAut]
+
+@[scoped simp] theorem edgeChain_of_zero (a : G 0) :
+    edgeChain (CoprodI.of a : CoprodI G) = 0 := by
+  unfold edgeChain chainSect
+  rw [CoprodI.lift_of]
+  rfl
+
+@[scoped simp] theorem edgeChain_of_one (a : G 1) :
+    edgeChain (CoprodI.of a : CoprodI G)
+      = Finsupp.single 1 1 - Finsupp.single (CoprodI.of a) 1 := by
+  unfold edgeChain chainSect
+  rw [CoprodI.lift_of]
+  rfl
+
+theorem edgeChain_inv (g : CoprodI G) :
+    edgeChain g⁻¹ = -lTransl g⁻¹ (edgeChain g) := by
+  have h := edgeChain_mul g⁻¹ g
+  rw [inv_mul_cancel, edgeChain_one, eq_comm, add_eq_zero_iff_eq_neg] at h
+  exact h
+
+theorem edgeChain_of_zero_mul_of_one (a : G 0) (b : G 1) :
+    edgeChain (CoprodI.of a * CoprodI.of b : CoprodI G)
+      = Finsupp.single (CoprodI.of a) 1 - Finsupp.single (CoprodI.of a * CoprodI.of b) 1 := by
+  rw [edgeChain_mul, edgeChain_of_zero, edgeChain_of_one, zero_add, map_sub,
+    lTransl_single, lTransl_single, mul_one]
+
+variable (H : Subgroup (CoprodI G))
+
+def projChain : (CoprodI G →₀ ℤ) →+ (CoprodI G ⧸ H →₀ ℤ) :=
+  Finsupp.mapDomain.addMonoidHom (fun g => (QuotientGroup.mk g⁻¹ : CoprodI G ⧸ H))
+
+@[scoped simp] theorem projChain_single (g : CoprodI G) (n : ℤ) :
+    projChain H (Finsupp.single g n) = Finsupp.single (QuotientGroup.mk g⁻¹) n :=
+  Finsupp.mapDomain_single
+
+theorem projChain_lTransl_of_mem (h : CoprodI G) (hh : h ∈ H) (f : CoprodI G →₀ ℤ) :
+    projChain H (lTransl h f) = projChain H f := by
+  change Finsupp.mapDomain _ (Finsupp.mapDomain _ f) = Finsupp.mapDomain _ f
+  rw [← Finsupp.mapDomain_comp]
+  congr 1
+  ext x
+  change (QuotientGroup.mk (h * x)⁻¹ : CoprodI G ⧸ H) = QuotientGroup.mk x⁻¹
+  rw [eq_comm, QuotientGroup.eq, mul_inv_rev, inv_inv, ← mul_assoc, mul_inv_cancel, one_mul]
+  exact inv_mem hh
+
+def edgeChainHom : Additive H →+ (CoprodI G ⧸ H →₀ ℤ) where
+  toFun h := projChain H (edgeChain ((Additive.toMul h : H) : CoprodI G))
+  map_zero' := by
+    change projChain H (edgeChain ((1 : H) : CoprodI G)) = 0
+    rw [OneMemClass.coe_one, edgeChain_one, map_zero]
+  map_add' h₁ h₂ := by
+    change projChain H (edgeChain ((Additive.toMul h₁ * Additive.toMul h₂ : H) : CoprodI G)) = _
+    rw [Subgroup.coe_mul, edgeChain_mul, map_add,
+      projChain_lTransl_of_mem H _ (Additive.toMul h₁).2]
+
+theorem edgeChainHom_apply (h : H) :
+    edgeChainHom H (Additive.ofMul h) = projChain H (edgeChain (h : CoprodI G)) := rfl
+
+theorem edgeChain_conj_expand (σ η : CoprodI G) :
+    edgeChain (σ * η * σ⁻¹)
+      = edgeChain σ + lTransl σ (edgeChain η)
+        - lTransl (σ * η * σ⁻¹) (edgeChain σ) := by
+  rw [edgeChain_mul (σ * η) σ⁻¹, edgeChain_mul σ η, edgeChain_inv, map_neg,
+    ← lTransl_mul_apply, sub_eq_add_neg, add_assoc]
+
+theorem edgeChainHom_conj (σ η : CoprodI G) (hmem : σ * η * σ⁻¹ ∈ H) :
+    edgeChainHom H (Additive.ofMul ⟨σ * η * σ⁻¹, hmem⟩)
+      = projChain H (lTransl σ (edgeChain η)) := by
+  rw [edgeChainHom_apply]
+  change projChain H (edgeChain (σ * η * σ⁻¹)) = projChain H (lTransl σ (edgeChain η))
+  rw [edgeChain_conj_expand, map_sub, map_add,
+    projChain_lTransl_of_mem H _ hmem, add_sub_cancel_left]
+
+end EdgeChain
+
+abbrev G23 (i : Fin 2) : Type := Multiplicative (ZMod (i.val + 2))
+
+abbrev Gp : Type := CoprodI G23
+
+def sA : G23 0 := Multiplicative.ofAdd 1
+
+def uA : G23 1 := Multiplicative.ofAdd 1
+
+theorem sA_mul_sA : sA * sA = 1 := by decide
+
+theorem eq_ofAdd_one_pow {n : ℕ} [NeZero n] (x : Multiplicative (ZMod n)) :
+    x = (Multiplicative.ofAdd (1 : ZMod n)) ^ (Multiplicative.toAdd x).val := by
+  rw [← ofAdd_nsmul, nsmul_eq_mul, mul_one, ZMod.natCast_zmod_val]
+  rfl
+
+def τ : Gp := CoprodI.of sA * CoprodI.of uA
+
+theorem of_sA_mul_of_sA : (CoprodI.of sA : Gp) * CoprodI.of sA = 1 := by
+  rw [← map_mul, sA_mul_sA, map_one]
+
+theorem of_sA_inv : (CoprodI.of sA : Gp)⁻¹ = CoprodI.of sA :=
+  inv_eq_of_mul_eq_one_right of_sA_mul_of_sA
+
+theorem of_sA_mul_τ : (CoprodI.of sA : Gp) * τ = CoprodI.of uA := by
+  rw [τ, ← mul_assoc, of_sA_mul_of_sA, one_mul]
+
+theorem closure_sA_τ :
+    Subgroup.closure {(CoprodI.of sA : Gp), τ} = ⊤ := by
+  rw [eq_top_iff]
+  intro g _
+  induction g using CoprodI.induction_left with
+  | one => exact one_mem _
+  | @mul i a x ih =>
+    refine mul_mem ?_ (ih (mem_top x))
+    have hs : (CoprodI.of sA : Gp) ∈ Subgroup.closure {(CoprodI.of sA : Gp), τ} :=
+      subset_closure (Set.mem_insert _ _)
+    have hu : (CoprodI.of uA : Gp) ∈ Subgroup.closure {(CoprodI.of sA : Gp), τ} := by
+      rw [← of_sA_mul_τ]; exact mul_mem hs (subset_closure (Set.mem_insert_of_mem _ rfl))
+    fin_cases i
+    · rw [eq_ofAdd_one_pow a, map_pow]
+      exact pow_mem hs _
+    · rw [eq_ofAdd_one_pow a, map_pow]
+      exact pow_mem hu _
+
+theorem edgeChain_τ :
+    edgeChain τ = Finsupp.single (CoprodI.of sA) 1 - Finsupp.single τ 1 := by
+  unfold τ
+  rw [edgeChain_of_zero_mul_of_one]
+
+theorem edgeChain_τ_pow (w : ℕ) :
+    edgeChain (τ ^ w)
+      = ∑ j ∈ Finset.range w,
+          (Finsupp.single (τ ^ j * CoprodI.of sA) 1 - Finsupp.single (τ ^ (j + 1)) 1) := by
+  induction w with
+  | zero => simp
+  | succ n ih =>
+    rw [pow_succ, edgeChain_mul, ih, edgeChain_τ, map_sub, lTransl_single, lTransl_single,
+      Finset.sum_range_succ, ← pow_succ]
+
+section Cosets
+
+variable (H : Subgroup Gp)
+
+abbrev X : Type := Gp ⧸ H
+
+abbrev Cu : Type := orbitRel.Quotient (zpowers τ) (X H)
+
+def cusp (x : X H) : Cu H := Quotient.mk (orbitRel (zpowers τ) (X H)) x
+
+theorem cusp_surjective : Function.Surjective (cusp H) := Quotient.mk_surjective
+
+theorem cusp_eq_iff {x y : X H} : cusp H x = cusp H y ↔ x ∈ orbit (zpowers τ) y := by
+  unfold cusp; rw [Quotient.eq]; rfl
+
+theorem cusp_smul (t : zpowers τ) (x : X H) : cusp H (t • x) = cusp H x :=
+  (cusp_eq_iff H).mpr (mem_orbit x t)
+
+@[scoped simp] theorem cusp_τ_smul (x : X H) : cusp H (τ • x) = cusp H x :=
+  cusp_smul H ⟨τ, mem_zpowers τ⟩ x
+
+@[scoped simp] theorem cusp_τ_zpow_smul (n : ℤ) (x : X H) : cusp H (τ ^ n • x) = cusp H x :=
+  cusp_smul H ⟨τ ^ n, zpow_mem (mem_zpowers τ) n⟩ x
+
+def flip (x : X H) : X H := (CoprodI.of sA : Gp) • x
+
+@[scoped simp] theorem flip_mk (g : Gp) : flip H (g : X H) = ((CoprodI.of sA * g : Gp) : X H) := rfl
+
+theorem flip_flip (x : X H) : flip H (flip H x) = x := by
+  rw [flip, flip, ← mul_smul, of_sA_mul_of_sA, one_smul]
+
+def wd (x : X H) : ℕ := Function.minimalPeriod (fun y => τ • y) x
+
+variable [H.FiniteIndex]
+
+theorem wd_pos (x : X H) : 0 < wd H x :=
+  Nat.pos_of_ne_zero (MulAction.minimalPeriod_pos τ x).ne
+
+omit [H.FiniteIndex] in
+theorem τ_pow_wd_smul (x : X H) : τ ^ wd H x • x = x :=
+  (MulAction.pow_smul_eq_iff_minimalPeriod_dvd).mpr dvd_rfl
+
+omit [H.FiniteIndex] in
+theorem τ_zpow_smul_eq_iff (x : X H) (n : ℤ) : τ ^ n • x = x ↔ (wd H x : ℤ) ∣ n :=
+  MulAction.zpow_smul_eq_iff_minimalPeriod_dvd
+
+omit [H.FiniteIndex] in
+theorem gen_mem (g : Gp) : g⁻¹ * τ ^ wd H (g : X H) * g ∈ H := by
+  have h1 : ((τ ^ wd H (g : X H) * g : Gp) : X H) = (g : X H) := τ_pow_wd_smul H (g : X H)
+  rw [QuotientGroup.eq] at h1
+  have h2 := H.inv_mem h1
+  simpa only [mul_inv_rev, inv_inv, mul_assoc] using h2
+
+def genAt (g : Gp) : H := ⟨g⁻¹ * τ ^ wd H (g : X H) * g, gen_mem H g⟩
+
+omit [H.FiniteIndex] in
+@[scoped simp] theorem genAt_coe (g : Gp) : (genAt H g : Gp) = g⁻¹ * τ ^ wd H (g : X H) * g := rfl
+
+def enum (g : Gp) (j : ℕ) : X H := (((τ ^ j)⁻¹ * g : Gp) : X H)
+
+omit [H.FiniteIndex] in
+theorem enum_eq_zpow_smul (g : Gp) (j : ℕ) : enum H g j = τ ^ (-(j : ℤ)) • (g : X H) := by
+  rw [enum, zpow_neg, zpow_natCast]; rfl
+
+omit [H.FiniteIndex] in
+@[scoped simp] theorem cusp_enum (g : Gp) (j : ℕ) : cusp H (enum H g j) = cusp H (g : X H) := by
+  rw [enum_eq_zpow_smul, cusp_τ_zpow_smul]
+
+omit [H.FiniteIndex] in
+theorem enum_zero (g : Gp) : enum H g 0 = (g : X H) := by
+  rw [enum, pow_zero, inv_one, one_mul]
+
+omit [H.FiniteIndex] in
+theorem edgeChainHom_genAt_raw (g : Gp) :
+    edgeChainHom H (Additive.ofMul (genAt H g))
+      = ∑ j ∈ Finset.range (wd H (g : X H)),
+          (Finsupp.single (flip H (enum H g j)) (1 : ℤ)
+            - Finsupp.single (enum H g (j + 1)) 1) := by
+  have hmem' : g⁻¹ * τ ^ wd H (g : X H) * g⁻¹⁻¹ ∈ H := by
+    rw [inv_inv]; exact gen_mem H g
+  have hconj := edgeChainHom_conj H g⁻¹ (τ ^ wd H (g : X H)) hmem'
+  have hgen : genAt H g = ⟨_, hmem'⟩ :=
+    Subtype.ext (show _ = _ * _ * g⁻¹⁻¹ by rw [inv_inv]; rfl)
+  rw [hgen, hconj, edgeChain_τ_pow, map_sum, map_sum]
+  refine Finset.sum_congr rfl fun j _ => ?_
+  rw [map_sub, map_sub, lTransl_single, lTransl_single, projChain_single, projChain_single,
+    enum, enum, flip_mk]
+  congr 2
+  · rw [mul_inv_rev, mul_inv_rev, inv_inv, of_sA_inv, mul_assoc]
+  · rw [mul_inv_rev, inv_inv]
+
+theorem enum_injOn_range (g : Gp) :
+    Set.InjOn (enum H g) (Finset.range (wd H (g : X H))) := by
+  intro j hj k hk heq
+  simp only [Finset.coe_range, Set.mem_Iio] at hj hk
+  rw [enum_eq_zpow_smul, enum_eq_zpow_smul] at heq
+  have hstab : τ ^ ((k : ℤ) - j) • (g : X H) = (g : X H) := by
+    have h2 : (τ ^ (-(k : ℤ)))⁻¹ • (τ ^ (-(j : ℤ)) • (g : X H)) = (g : X H) := by
+      rw [heq, inv_smul_smul]
+    rwa [← mul_smul, ← zpow_neg, neg_neg, ← zpow_add, ← sub_eq_add_neg] at h2
+  have hdvd := (τ_zpow_smul_eq_iff H _ _).mp hstab
+  have hw := wd_pos H (g : X H)
+  rcases hdvd with ⟨m, hm⟩
+  have hbound : |(k : ℤ) - j| < wd H (g : X H) := by
+    rw [abs_sub_lt_iff]; constructor <;> · omega
+  rw [hm, abs_mul, Nat.abs_cast] at hbound
+  have hm0 : m = 0 := by
+    by_contra hm0
+    have : (wd H (g : X H) : ℤ) * 1 ≤ (wd H (g : X H) : ℤ) * |m| :=
+      mul_le_mul_of_nonneg_left (Int.one_le_abs hm0) (Nat.cast_nonneg _)
+    omega
+  rw [hm0, mul_zero, sub_eq_zero] at hm
+  exact_mod_cast hm.symm
+
+omit [H.FiniteIndex] in
+theorem enum_width (g : Gp) : enum H g (wd H (g : X H)) = enum H g 0 := by
+  rw [enum_eq_zpow_smul, enum_zero]
+  exact (τ_zpow_smul_eq_iff H _ _).mpr (by simp)
+
+omit [H.FiniteIndex] in
+theorem sum_enum_succ {M : Type*} [AddCommGroup M] (g : Gp) (f : X H → M) :
+    ∑ j ∈ Finset.range (wd H (g : X H)), f (enum H g (j + 1))
+      = ∑ j ∈ Finset.range (wd H (g : X H)), f (enum H g j) := by
+  have h1 := Finset.sum_range_succ (fun j => f (enum H g j)) (wd H (g : X H))
+  have h2 := Finset.sum_range_succ' (fun j => f (enum H g j)) (wd H (g : X H))
+  rw [enum_width] at h1
+  exact (add_right_cancel (h1.symm.trans h2)).symm
+
+theorem exists_enum_eq_of_cusp_eq (g : Gp) {y : X H} (hy : cusp H y = cusp H (g : X H)) :
+    ∃ j ∈ Finset.range (wd H (g : X H)), enum H g j = y := by
+  rw [cusp_eq_iff] at hy
+  obtain ⟨⟨_, n, rfl⟩, rfl⟩ := hy
+  set w : ℕ := wd H (g : X H) with hw
+  have hwpos : (0 : ℤ) < w := by exact_mod_cast wd_pos H (g : X H)
+  refine ⟨((-n) % (w : ℤ)).toNat, ?_, ?_⟩
+  · rw [Finset.mem_range]
+    have h0 : 0 ≤ (-n) % (w : ℤ) := Int.emod_nonneg _ hwpos.ne'
+    have h1 : (-n) % (w : ℤ) < w := Int.emod_lt_of_pos _ hwpos
+    omega
+  · rw [enum_eq_zpow_smul]
+    change τ ^ (-((((-n) % (w : ℤ)).toNat : ℕ) : ℤ)) • (g : X H) = τ ^ n • (g : X H)
+    have h0 : 0 ≤ (-n) % (w : ℤ) := Int.emod_nonneg _ hwpos.ne'
+    rw [Int.toNat_of_nonneg h0, ← MulAction.zpow_smul_mod_minimalPeriod τ (g : X H) n,
+      ← MulAction.zpow_smul_mod_minimalPeriod τ (g : X H) (-((-n) % (w : ℤ)))]
+    congr 2
+    change -(-n % (w : ℤ)) % (w : ℤ) = n % (w : ℤ)
+    exact (Int.mod_modEq (-n) (w : ℤ)).neg.trans (by rw [neg_neg])
+
+end Cosets
+
+section Eval
+
+variable (H : Subgroup Gp) [H.FiniteIndex]
+
+theorem sum_ite_enum_eq (g : Gp) (y : X H)
+    [DecidableEq (X H)] [DecidableEq (Cu H)] :
+    (∑ j ∈ Finset.range (wd H (g : X H)), if enum H g j = y then (1 : ℤ) else 0)
+      = if cusp H y = cusp H (g : X H) then 1 else 0 := by
+  by_cases h : cusp H y = cusp H (g : X H)
+  · rw [ite_eq_left h]
+    obtain ⟨j, hj, hjy⟩ := exists_enum_eq_of_cusp_eq H g h
+    have hfilt : (Finset.range (wd H (g : X H))).filter (fun k => enum H g k = y) = {j} := by
+      refine Finset.eq_singleton_iff_unique_mem.mpr ⟨Finset.mem_filter.mpr ⟨hj, hjy⟩, ?_⟩
+      intro k hk
+      obtain ⟨hk1, hk2⟩ := Finset.mem_filter.mp hk
+      exact enum_injOn_range H g hk1 hj (hk2.trans hjy.symm)
+    rw [← Finset.sum_filter, hfilt, Finset.sum_singleton]
+  · rw [ite_eq_right h]
+    refine Finset.sum_eq_zero fun j _ => ite_eq_right fun hjy => h ?_
+    rw [← hjy, cusp_enum]
+
+theorem edgeChainHom_genAt_apply [DecidableEq (Cu H)] (g : Gp) (e : X H) :
+    edgeChainHom H (Additive.ofMul (genAt H g)) e
+      = (if cusp H (flip H e) = cusp H (g : X H) then 1 else 0)
+        - (if cusp H e = cusp H (g : X H) then 1 else 0) := by
+  classical
+  rw [edgeChainHom_genAt_raw]
+  simp only [Finsupp.coe_sub, Finsupp.finsetSum_apply, Pi.sub_apply,
+    Finsupp.single_apply, Finset.sum_sub_distrib]
+  rw [sum_enum_succ H g (fun x => if x = e then (1 : ℤ) else 0), sum_ite_enum_eq]
+  congr 1
+  calc ∑ j ∈ Finset.range (wd H (g : X H)),
+          (if flip H (enum H g j) = e then (1 : ℤ) else 0)
+      = ∑ j ∈ Finset.range (wd H (g : X H)),
+          (if enum H g j = flip H e then (1 : ℤ) else 0) := by
+        refine Finset.sum_congr rfl fun j _ => ?_
+        congr 1
+        exact propext ⟨fun h => by rw [← h, flip_flip], fun h => by rw [h, flip_flip]⟩
+    _ = if cusp H (flip H e) = cusp H (g : X H) then 1 else 0 := sum_ite_enum_eq H g (flip H e)
+
+def cuspDiffAt [DecidableEq (Cu H)] (e : X H) : Cu H → ℤ :=
+  Pi.single (cusp H (flip H e)) 1 - Pi.single (cusp H e) 1
+
+def edgeChar (e : X H) : Additive H →+ ℤ := (Finsupp.applyAddHom e).comp (edgeChainHom H)
+
+theorem edgeChar_genAt [DecidableEq (Cu H)] (e : X H) (g : Gp) :
+    edgeChar H e (Additive.ofMul (genAt H g)) = cuspDiffAt H e (cusp H (g : X H)) := by
+  change edgeChainHom H (Additive.ofMul (genAt H g)) e = _
+  rw [edgeChainHom_genAt_apply, cuspDiffAt, Pi.sub_apply, Pi.single_apply, Pi.single_apply]
+  simp only [@eq_comm _ (cusp H (g : X H))]
+
+omit [H.FiniteIndex] in
+theorem single_sub_single_mem_span_of_smul [DecidableEq (Cu H)] (k : Gp) (e : X H) :
+    (Pi.single (cusp H (k • e)) 1 - Pi.single (cusp H e) 1 : Cu H → ℤ)
+      ∈ Submodule.span ℤ (Set.range (cuspDiffAt H)) := by
+  have htop : k ∈ (⊤ : Subgroup Gp) := mem_top k
+  rw [← closure_sA_τ] at htop
+  have key : ∀ e', (Pi.single (cusp H (k • e')) 1
+        - Pi.single (cusp H e') 1 : Cu H → ℤ)
+      ∈ Submodule.span ℤ (Set.range (cuspDiffAt H)) := by
+    induction htop using Subgroup.closure_induction with
+    | one => intro e'; rw [one_smul, sub_self]; exact Submodule.zero_mem _
+    | mul x y _ _ hx hy =>
+      intro e'
+      rw [mul_smul]
+      have := Submodule.add_mem _ (hx (y • e')) (hy e')
+      rwa [sub_add_sub_cancel] at this
+    | inv x _ hx =>
+      intro e'
+      have h1 := Submodule.neg_mem _ (hx (x⁻¹ • e'))
+      rw [smul_inv_smul, neg_sub] at h1
+      exact h1
+    | mem x hx =>
+      intro e'
+      rcases hx with rfl | rfl
+      · exact Submodule.subset_span ⟨e', rfl⟩
+      · rw [cusp_τ_smul, sub_self]; exact Submodule.zero_mem _
+  exact key e
+
+omit [H.FiniteIndex] in
+theorem single_sub_single_mem_span_cuspDiffAt [DecidableEq (Cu H)] (c c' : Cu H) :
+    (Pi.single c' 1 - Pi.single c 1 : Cu H → ℤ)
+      ∈ Submodule.span ℤ (Set.range (cuspDiffAt H)) := by
+  obtain ⟨e, rfl⟩ := cusp_surjective H c
+  obtain ⟨e', rfl⟩ := cusp_surjective H c'
+  induction e using QuotientGroup.induction_on with | H k =>
+  induction e' using QuotientGroup.induction_on with | H k' =>
+  have heq : ((k' : Gp) : X H) = (k' * k⁻¹) • ((k : Gp) : X H) := by
+    change QuotientGroup.mk k' = QuotientGroup.mk ((k' * k⁻¹) * k)
+    rw [mul_assoc, inv_mul_cancel, mul_one]
+  rw [heq]
+  exact single_sub_single_mem_span_of_smul H (k' * k⁻¹) _
+
+theorem exists_addChar_of_mem_span [DecidableEq (Cu H)] {v : Cu H → ℤ}
+    (hv : v ∈ Submodule.span ℤ (Set.range (cuspDiffAt H))) :
+    ∃ φ : Additive H →+ ℤ, ∀ g : Gp, φ (Additive.ofMul (genAt H g)) = v (cusp H (g : X H)) := by
+  induction hv using Submodule.span_induction with
+  | mem x hx =>
+    obtain ⟨e, rfl⟩ := hx
+    exact ⟨edgeChar H e, fun g => edgeChar_genAt H e g⟩
+  | zero => exact ⟨0, fun g => rfl⟩
+  | add x y _ _ hx hy =>
+    obtain ⟨φ, hφ⟩ := hx
+    obtain ⟨ψ, hψ⟩ := hy
+    exact ⟨φ + ψ, fun g => by rw [AddMonoidHom.add_apply, hφ, hψ, Pi.add_apply]⟩
+  | smul n x _ hx =>
+    obtain ⟨φ, hφ⟩ := hx
+    exact ⟨n • φ, fun g => by rw [AddMonoidHom.smul_apply, hφ, Pi.smul_apply]⟩
+
+end Eval
+
+theorem engine (H : Subgroup Gp) [H.FiniteIndex] (R : Type*) [AddCommGroup R]
+    (a : Cu H → R) (ha : ∑ᶠ c, a c = 0) :
+    ∃ φ : Additive H →+ R, ∀ g : Gp, φ (Additive.ofMul (genAt H g)) = a (cusp H (g : X H)) := by
+  classical
+  have : Fintype (Cu H) := Fintype.ofFinite _
+  rw [finsum_eq_sum_of_fintype] at ha
+  have c₀ : Cu H := cusp H ((1 : Gp) : X H)
+  have hreal : ∀ c : Cu H, ∃ φ : Additive H →+ ℤ,
+      ∀ g : Gp, φ (Additive.ofMul (genAt H g))
+        = (Pi.single c 1 - Pi.single c₀ 1 : Cu H → ℤ) (cusp H (g : X H)) :=
+    fun c => exists_addChar_of_mem_span H (single_sub_single_mem_span_cuspDiffAt H c₀ c)
+  choose φ hφ using hreal
+  refine ⟨∑ c, (zmultiplesHom R (a c)).comp (φ c), fun g => ?_⟩
+  rw [AddMonoidHom.finsetSum_apply]
+  have hterm : ∀ c, ((zmultiplesHom R (a c)).comp (φ c)) (Additive.ofMul (genAt H g))
+      = (if cusp H (g : X H) = c then a c else 0)
+        - (if cusp H (g : X H) = c₀ then a c else 0) := by
+    intro c
+    rw [AddMonoidHom.comp_apply, hφ, zmultiplesHom_apply, Pi.sub_apply, Pi.single_apply,
+      Pi.single_apply, sub_smul, ite_smul, ite_smul, one_smul, zero_smul]
+  rw [Finset.sum_congr rfl fun c _ => hterm c, Finset.sum_sub_distrib, Finset.sum_ite_eq,
+    ite_eq_left (Finset.mem_univ _)]
+  by_cases h : cusp H (g : X H) = c₀
+  · have h2 : (∑ c, if cusp H (g : X H) = c₀ then a c else 0) = ∑ c, a c :=
+      Finset.sum_congr rfl fun c _ => ite_eq_left h
+    rw [h2, ha, sub_zero]
+  · have h2 : (∑ c, if cusp H (g : X H) = c₀ then a c else 0) = 0 :=
+      Finset.sum_eq_zero fun c _ => ite_eq_right h
+    rw [h2, sub_zero]
+
+end BassSerreCusp
+
+theorem solution
+    (t : Monoid.CoprodI (fun i : Fin 2 => Multiplicative (ZMod (i.val + 2))))
+    (ht : t = Monoid.CoprodI.of (M := fun i : Fin 2 => Multiplicative (ZMod (i.val + 2))) (i := 0)
+                (Multiplicative.ofAdd 1) *
+              Monoid.CoprodI.of (M := fun i : Fin 2 => Multiplicative (ZMod (i.val + 2))) (i := 1)
+                (Multiplicative.ofAdd 1))
+    (H : Subgroup (Monoid.CoprodI (fun i : Fin 2 => Multiplicative (ZMod (i.val + 2)))))
+    [H.FiniteIndex] (R : Type) [AddCommGroup R]
+    (a : MulAction.orbitRel.Quotient (Subgroup.zpowers t)
+          (Monoid.CoprodI (fun i : Fin 2 => Multiplicative (ZMod (i.val + 2))) ⧸ H) → R)
+    (ha : ∑ᶠ c, a c = 0) :
+    ∃ φ : Additive H →+ R,
+      ∀ (g : Monoid.CoprodI (fun i : Fin 2 => Multiplicative (ZMod (i.val + 2))))
+        (hg : g⁻¹ * t ^ Function.minimalPeriod (fun x => t • x)
+                (g : Monoid.CoprodI (fun i : Fin 2 => Multiplicative (ZMod (i.val + 2))) ⧸ H) * g ∈
+                  H),
+        φ (Additive.ofMul ⟨_, hg⟩)
+          = a (Quotient.mk (MulAction.orbitRel (Subgroup.zpowers t) _)
+              (g : Monoid.CoprodI (fun i : Fin 2 => Multiplicative (ZMod (i.val + 2))) ⧸ H)) := by
+  subst ht
+  obtain ⟨φ, hφ⟩ := BassSerreCusp.engine H R a ha
+  exact ⟨φ, fun g hg => hφ g⟩
+
+end
+
+end privateSection
+
+public section publicSection
+
+theorem Monoid.CoprodI.exists_addMonoidHom_conj_pow_minimalPeriod_eq_of_finsum_eq_zero
+    (t : CoprodI (fun i : Fin 2 => Multiplicative (ZMod (i.val + 2))))
+    (ht : t = of (M := fun i : Fin 2 => Multiplicative (ZMod (i.val + 2))) (i := 0)
+      (.ofAdd 1) * of (M := fun i : Fin 2 => Multiplicative (ZMod (i.val + 2))) (i := 1) (.ofAdd 1))
+    (H : Subgroup (CoprodI (fun i : Fin 2 => Multiplicative (ZMod (i.val + 2)))))
+    [H.FiniteIndex] (R : Type) [AddCommGroup R]
+    (a : MulAction.orbitRel.Quotient (Subgroup.zpowers t)
+        (CoprodI (fun i : Fin 2 => Multiplicative (ZMod (i.val + 2))) ⧸ H) → R)
+    (ha : ∑ᶠ c, a c = 0) :
+    ∃ φ : Additive H →+ R,
+      ∀ (g : CoprodI (fun i : Fin 2 => Multiplicative (ZMod (i.val + 2))))
+        (hg : g⁻¹ * t ^ Function.minimalPeriod (fun x => t • x)
+          (g : CoprodI (fun i : Fin 2 => Multiplicative (ZMod (i.val + 2))) ⧸ H) * g ∈ H),
+        φ (.ofMul ⟨_, hg⟩) = a (⟦g⟧) :=
+  solution t ht H R a ha
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Monoid_CoprodI_isTree_cosetGraph.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Monoid_CoprodI_isTree_cosetGraph.lean
new file mode 100644
index 0000000000..9ee76b0fff
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Monoid_CoprodI_isTree_cosetGraph.lean
@@ -0,0 +1,460 @@
+/-
+Based on Prove2Me node Monoid.CoprodI.isTree_cosetGraph
+(b1edfc8e-8f02-5596-a26f-a6a8c58cb965) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 14446f78-ef66-5227-948e-cdfcd0e63b38
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Combinatorics.SimpleGraph.Acyclic
+public import Mathlib.GroupTheory.CoprodI
+
+import Mathlib.Order.CompletePartialOrder
+import Mathlib.Tactic.Group
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The coset graph of a free product of two groups is a tree
+
+Theorem statement: `Monoid.CoprodI.isTree_cosetGraph` (`b1edfc8e-8f02-5596-a26f-a6a8c58cb965`), by
+Claude, 2026-09-05.
+
+Proof: submission `14446f78-ef66-5227-948e-cdfcd0e63b38`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $G_0$ and $G_1$ be groups, given as a family $G : \mathrm{Fin}\,2 \to \mathrm{Type}$ with a
+group structure on each $G_i$, and let $\mathrm{CoprodI}\,G = G_0 * G_1$ be their free product, with
+$\mathrm{of}$ the canonical homomorphism $G_i \to G_0 * G_1$, whose range is the copy of the factor
+$G_i$. Consider the vertex type $\sum_{i \in \mathrm{Fin}\,2}
+(G_0*G_1)/\mathrm{range}(\mathrm{of}_i)$, the disjoint union of the two left-coset spaces, a vertex
+being a pair $v = (v_1, v_2)$ with $v_1 \in \mathrm{Fin}\,2$ an index and $v_2$ a coset of the
+corresponding factor. Relate $v$ and $w$ when $v_1 \neq w_1$ and there exists $g \in G_0 * G_1$ with
+$v_2 = g\,\mathrm{range}(\mathrm{of}_{v_1})$ and $w_2 = g\,\mathrm{range}(\mathrm{of}_{w_1})$, i.e.
+the two cosets have a common representative. The assertion is that the simple graph obtained from
+this relation by symmetrising it and discarding loops (`SimpleGraph.fromRel`) is a tree: it is
+connected and has no cycles.
+
+This is the existence half of Serre's theorem describing the Bass–Serre tree of a free product, in
+the case of trivial amalgamated subgroup: $G_0 * G_1$ acts on this tree with a segment as
+fundamental domain, the vertex stabilisers being the conjugates of the two factors. It is used in
+the project to produce free bases for subgroups of free products (Kurosh-type statements) and,
+through them, in the treatment of the modular group.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Monoid_CoprodI_isTree_cosetGraph.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_Monoid_CoprodI_isTree_cosetGraph
+
+p2m_open "Subgroup SimpleGraph P2MW.S_Monoid_CoprodI_isTree_cosetGraph.SimpleGraph"
+
+namespace GroupTheory
+
+namespace BassSerre
+
+p2m_open "Monoid Monoid.CoprodI"
+
+variable {ι : Type*} (G : ι → Type*) [∀ i, Group (G i)]
+
+abbrev Vertex : Type _ :=
+  (i : ι) × (CoprodI G ⧸ (Monoid.CoprodI.of (M := G) (i := i)).range)
+
+variable {G} in
+abbrev Vertex.mk (i : ι) (g : CoprodI G) : Vertex G :=
+  ⟨i, QuotientGroup.mk g⟩
+
+def graph : SimpleGraph (Vertex G) where
+  Adj v w := v.1 ≠ w.1 ∧ ∃ g : CoprodI G, Vertex.mk v.1 g = v ∧ Vertex.mk w.1 g = w
+  symm := ⟨by
+    rintro ⟨i, x⟩ ⟨j, y⟩ ⟨hij, g, hgv, hgw⟩
+    exact ⟨hij.symm, g, hgw, hgv⟩⟩
+  loopless := ⟨fun _ h => h.1 rfl⟩
+
+variable {G}
+
+theorem mk_eq_mk_iff {i : ι} {g h : CoprodI G} :
+    Vertex.mk (G := G) i g = Vertex.mk i h ↔ g⁻¹ * h ∈ (of (M := G) (i := i)).range := by
+  constructor
+  · intro H
+    exact QuotientGroup.eq.mp
+      (sigma_mk_injective (β := fun j => CoprodI G ⧸ (of (M := G) (i := j)).range) H)
+  · intro H
+    exact congrArg (Sigma.mk i) (QuotientGroup.eq.mpr H)
+
+theorem adj_mk {i j : ι} (hij : i ≠ j) (g : CoprodI G) :
+    (graph G).Adj (Vertex.mk i g) (Vertex.mk j g) :=
+  ⟨hij, g, rfl, rfl⟩
+
+theorem adj_iff_exists {v w : Vertex G} :
+    (graph G).Adj v w ↔ v.1 ≠ w.1 ∧ ∃ g, Vertex.mk v.1 g = v ∧ Vertex.mk w.1 g = w :=
+  Iff.rfl
+
+theorem adj_one {i j : ι} (hij : i ≠ j) :
+    (graph G).Adj (Vertex.mk i (1 : CoprodI G)) (Vertex.mk j 1) :=
+  adj_mk hij 1
+
+scoped instance : SMul (CoprodI G) (Vertex G) where
+  smul g v := ⟨v.1, g • v.2⟩
+
+theorem smul_def (g : CoprodI G) (v : Vertex G) : g • v = ⟨v.1, g • v.2⟩ :=
+  rfl
+
+@[scoped simp]
+theorem smul_mk (g : CoprodI G) (i : ι) (h : CoprodI G) :
+    g • Vertex.mk i h = Vertex.mk i (g * h) :=
+  rfl
+
+scoped instance : MulAction (CoprodI G) (Vertex G) where
+  one_smul := by
+    rintro ⟨i, x⟩
+    change (⟨i, (1 : CoprodI G) • x⟩ : Vertex G) = ⟨i, x⟩
+    rw [one_smul]
+  mul_smul g h := by
+    rintro ⟨i, x⟩
+    change (⟨i, (g * h) • x⟩ : Vertex G) = ⟨i, g • h • x⟩
+    rw [mul_smul]
+
+theorem smul_adj {v w : Vertex G} (g : CoprodI G) (h : (graph G).Adj v w) :
+    (graph G).Adj (g • v) (g • w) := by
+  obtain ⟨hvw, e, hev, hew⟩ := h
+  exact ⟨hvw, g * e, by rw [← hev]; rfl, by rw [← hew]; rfl⟩
+
+def smulHom (g : CoprodI G) : graph G →g graph G where
+  toFun v := g • v
+  map_rel' := smul_adj g
+
+@[scoped simp]
+theorem smulHom_apply (g : CoprodI G) (v : Vertex G) : smulHom g v = g • v :=
+  rfl
+
+theorem reachable_smul {v w : Vertex G} (g : CoprodI G) (h : (graph G).Reachable v w) :
+    (graph G).Reachable (g • v) (g • w) :=
+  h.map (smulHom g)
+
+theorem smul_eq_self_iff {h : CoprodI G} {i : ι} {g : CoprodI G} :
+    h • Vertex.mk i g = Vertex.mk i g ↔ g⁻¹ * h * g ∈ (of (M := G) (i := i)).range := by
+  rw [smul_mk, mk_eq_mk_iff, show (h * g)⁻¹ * g = (g⁻¹ * h * g)⁻¹ by group, inv_mem_iff]
+
+theorem mk_of_eq_mk_one {i : ι} (m : G i) :
+    Vertex.mk (G := G) i (of m) = Vertex.mk i 1 :=
+  mk_eq_mk_iff.mpr (MonoidHom.mem_range.mpr ⟨m⁻¹, by simp⟩)
+
+theorem reachable_one_one (i j : ι) :
+    (graph G).Reachable (Vertex.mk i (1 : CoprodI G)) (Vertex.mk j 1) := by
+  classical
+  by_cases h : i = j
+  · subst h; exact Reachable.refl _
+  · exact (adj_one h).reachable
+
+theorem reachable_one_of {i k : ι} (m : G k) :
+    (graph G).Reachable (Vertex.mk i (1 : CoprodI G)) (Vertex.mk i (of m)) := by
+  classical
+  by_cases hki : k = i
+  · subst hki
+    rw [mk_of_eq_mk_one]
+  · refine (reachable_one_one i k).trans ?_
+    rw [← mk_of_eq_mk_one m]
+    exact (adj_mk hki (of m)).reachable
+
+theorem reachable_one (i : ι) (g : CoprodI G) (j : ι) :
+    (graph G).Reachable (Vertex.mk i (1 : CoprodI G)) (Vertex.mk j g) := by
+  induction g using CoprodI.induction_left with
+  | one => exact reachable_one_one i j
+  | mul m x ih =>
+    have step := reachable_smul (of m) ih
+    rw [smul_mk, smul_mk, mul_one] at step
+    exact (reachable_one_of m).trans step
+
+theorem connected [Nonempty ι] : (graph G).Connected := by
+  inhabit ι
+  rw [connected_iff_exists_forall_reachable]
+  refine ⟨Vertex.mk default 1, ?_⟩
+  rintro ⟨j, x⟩
+  induction x using QuotientGroup.induction_on with
+  | H g => exact reachable_one default g j
+
+theorem eq_one_of_mem_range_of_mem_range {i j : ι} (hij : i ≠ j) {x : CoprodI G}
+    (hi : x ∈ (of (M := G) (i := i)).range) (hj : x ∈ (of (M := G) (i := j)).range) :
+    x = 1 := by
+  classical
+  obtain ⟨a, rfl⟩ := MonoidHom.mem_range.mp hi
+  obtain ⟨b, hb⟩ := MonoidHom.mem_range.mp hj
+  have key := congrArg (lift (Pi.mulSingle i (MonoidHom.id (G i)))) hb
+  rw [lift_of, lift_of, Pi.mulSingle_eq_same, Pi.mulSingle_eq_of_ne hij.symm] at key
+  simp only [MonoidHom.one_apply, MonoidHom.id_apply] at key
+  rw [← key, map_one]
+
+theorem range_inf_range_eq_bot {i j : ι} (hij : i ≠ j) :
+    (of (M := G) (i := i)).range ⊓ (of (M := G) (i := j)).range = ⊥ := by
+  rw [eq_bot_iff]
+  intro x hx
+  rw [Subgroup.mem_inf] at hx
+  exact mem_bot.mpr (eq_one_of_mem_range_of_mem_range hij hx.1 hx.2)
+
+theorem eq_of_mk_eq_mk {i j : ι} (hij : i ≠ j) {g g' : CoprodI G}
+    (hgi : Vertex.mk (G := G) i g = Vertex.mk i g')
+    (hgj : Vertex.mk (G := G) j g = Vertex.mk j g') :
+    g = g' :=
+  inv_mul_eq_one.mp
+    (eq_one_of_mem_range_of_mem_range hij (mk_eq_mk_iff.mp hgi) (mk_eq_mk_iff.mp hgj))
+
+theorem adj_base_iff {i : ι} {w : Vertex G} :
+    (graph G).Adj (Vertex.mk i (1 : CoprodI G)) w ↔
+      i ≠ w.1 ∧ ∃ a : G i, Vertex.mk w.1 (of a) = w := by
+  constructor
+  · rintro ⟨hiw, g, hgi, hgw⟩
+    refine ⟨hiw, ?_⟩
+    obtain ⟨a, ha⟩ := MonoidHom.mem_range.mp
+      (show g ∈ (of (M := G) (i := i)).range by simpa using mk_eq_mk_iff.mp hgi)
+    exact ⟨a, by rw [ha]; exact hgw⟩
+  · rintro ⟨hiw, a, haw⟩
+    exact ⟨hiw, of a, (mk_of_eq_mk_one a), haw⟩
+
+theorem isTree_of_isAcyclic [Nonempty ι] (h : (graph G).IsAcyclic) : (graph G).IsTree :=
+  ⟨connected, h⟩
+
+end BassSerre
+end GroupTheory
+
+p2m_open "Subgroup SimpleGraph P2MW.S_Monoid_CoprodI_isTree_cosetGraph.SimpleGraph"
+
+namespace SimpleGraph
+p2m_export "SimpleGraph" "IsAcyclic loopless connected_iff_exists_forall_reachable \
+  isAcyclic_iff_forall_adj_isBridge fromRel fromRel_adj IsBridge Reachable.refl Connected Walk mk \
+  IsTree symm between isBridge_iff deleteEdges_adj Adj structure Reachable edge"
+p2m_open "SimpleGraph"
+
+variable {V : Type*} {α : Type*}
+
+theorem eq_of_adj_imp_eq_of_walk {G : SimpleGraph V} {f : V → α}
+    (hf : ∀ ⦃v w : V⦄, G.Adj v w → f v = f w) {a b : V} (p : G.Walk a b) : f a = f b := by
+  induction p with
+  | nil => rfl
+  | cons h _ ih => exact (hf h).trans ih
+
+theorem isBridge_of_separating {G : SimpleGraph V} (f : V → α) {a b : V}
+    (hfab : f a ≠ f b)
+    (hconst : ∀ ⦃v w : V⦄, G.Adj v w → s(v, w) ≠ s(a, b) → f v = f w) :
+    G.IsBridge s(a, b) := by
+  refine isBridge_iff.mpr fun hr => hfab ?_
+  obtain ⟨p⟩ := hr
+  refine eq_of_adj_imp_eq_of_walk (fun v w hvw => ?_) p
+  rw [deleteEdges_adj] at hvw
+  exact hconst hvw.1 fun he => hvw.2 (Set.mem_singleton_iff.mpr he)
+
+end SimpleGraph
+
+namespace GroupTheory
+
+namespace BassSerre
+
+p2m_open "Monoid Monoid.CoprodI"
+
+variable {ι : Type*} {G : ι → Type*} [∀ i, Group (G i)]
+
+def lastIdx (w : Word G) : Option ι :=
+  w.toList.getLast?.map Sigma.fst
+
+@[scoped simp]
+theorem lastIdx_empty : lastIdx (Word.empty : Word G) = none :=
+  rfl
+
+section DecEq
+
+variable [DecidableEq ι] [∀ i, DecidableEq (G i)]
+
+omit [DecidableEq ι] in
+theorem lastIdx_rcons_getD {i : ι} (p : Word.Pair G i) :
+    (lastIdx (Word.rcons p)).getD i = (lastIdx p.tail).getD i := by
+  rw [Word.rcons]
+  split
+  · rfl
+  · simp only [lastIdx, Word.cons_toList]
+    rcases hl : p.tail.toList with _ | ⟨x, xs⟩
+    · simp
+    · rw [List.getLast?_cons_cons]
+
+theorem rcons_equivPair (i : ι) (w : Word G) : Word.rcons (Word.equivPair i w) = w := by
+  rw [← Word.equivPair_symm, Equiv.symm_apply_apply]
+
+theorem equiv_apply (g : CoprodI G) : Word.equiv g = g • Word.empty :=
+  rfl
+
+@[scoped simp]
+theorem equiv_one : Word.equiv (1 : CoprodI G) = Word.empty := by
+  rw [equiv_apply, one_smul]
+
+theorem equiv_mul (g h : CoprodI G) : Word.equiv (g * h) = g • Word.equiv h := by
+  rw [equiv_apply, equiv_apply, mul_smul]
+
+theorem eq_one_of_toList_eq_nil {g : CoprodI G} (h : (Word.equiv g).toList = []) : g = 1 :=
+  Word.equiv.injective ((Word.ext h).trans equiv_one.symm)
+
+def sideAux (i : ι) (g : CoprodI G) : ι :=
+  (lastIdx (Word.equiv g⁻¹)).getD i
+
+@[scoped simp]
+theorem sideAux_one (i : ι) : sideAux i (1 : CoprodI G) = i := by
+  simp [sideAux]
+
+theorem sideAux_mul_of {i : ι} (g : CoprodI G) (m : G i) :
+    sideAux i (g * of m) = sideAux i g := by
+  simp only [sideAux]
+  rw [mul_inv_rev, ← map_inv, equiv_mul, Word.of_smul_def, lastIdx_rcons_getD]
+  conv_rhs => rw [← rcons_equivPair i (Word.equiv g⁻¹), lastIdx_rcons_getD]
+
+theorem sideAux_eq_sideAux {g : CoprodI G} (hg : g ≠ 1) (i j : ι) :
+    sideAux i g = sideAux j g := by
+  have hne : (Word.equiv g⁻¹).toList ≠ [] := fun h =>
+    hg (inv_eq_one.mp (eq_one_of_toList_eq_nil h))
+  simp only [sideAux]
+  cases hl : (Word.equiv g⁻¹).toList.getLast? with
+  | none => exact absurd (List.getLast?_eq_none_iff.mp hl) hne
+  | some l => simp only [lastIdx, hl, Option.map_some, Option.getD_some]
+
+def side (v : Vertex G) : ι :=
+  Quotient.liftOn' v.2 (sideAux v.1) fun _ _ hab =>
+    (sideAux_eq_of_rel (QuotientGroup.leftRel_apply.mp hab)).symm
+where
+
+  sideAux_eq_of_rel {i : ι} {a b : CoprodI G} (h : a⁻¹ * b ∈ (of (M := G) (i := i)).range) :
+      sideAux i b = sideAux i a := by
+    obtain ⟨m, hm⟩ := h
+    have hb : b = a * of m := by rw [hm]; group
+    rw [hb, sideAux_mul_of]
+
+@[scoped simp]
+theorem side_mk (i : ι) (g : CoprodI G) : side (Vertex.mk i g) = sideAux i g :=
+  rfl
+
+@[scoped simp]
+theorem side_mk_one (i : ι) : side (Vertex.mk i (1 : CoprodI G)) = i := by
+  rw [side_mk, sideAux_one]
+
+omit [DecidableEq ι] [∀ i, DecidableEq (G i)] in
+theorem sym2_mk_eq_sym2_mk (htwo : ∀ a b c : ι, a = b ∨ a = c ∨ b = c) {i j k l : ι}
+    (hij : i ≠ j) (hkl : k ≠ l) (g : CoprodI G) :
+    s(Vertex.mk i g, Vertex.mk j g) = s(Vertex.mk k g, Vertex.mk l g) := by
+  rcases htwo i k l with rfl | rfl | h
+  · rcases htwo j i l with rfl | rfl | h
+    · exact absurd rfl hij
+    · rfl
+    · exact absurd h hkl
+  · rcases htwo j k i with rfl | rfl | h
+    · exact Sym2.eq_swap
+    · exact absurd rfl hij
+    · exact absurd h hkl
+  · exact absurd h hkl
+
+omit [DecidableEq ι] [(i : ι) → DecidableEq (G i)] in
+theorem isBridge_mk_mk (htwo : ∀ a b c : ι, a = b ∨ a = c ∨ b = c) {i j : ι} (hij : i ≠ j)
+    (g : CoprodI G) : (graph G).IsBridge s(Vertex.mk i g, Vertex.mk j g) := by
+  classical
+  refine isBridge_of_separating (fun v => side (g⁻¹ • v)) ?_ ?_
+  · change side (g⁻¹ • Vertex.mk i g) ≠ side (g⁻¹ • Vertex.mk j g)
+    rw [smul_mk, smul_mk, inv_mul_cancel, side_mk_one, side_mk_one]
+    exact hij
+  · rintro v w ⟨hvw, h, hhv, hhw⟩ hne
+    change side (g⁻¹ • v) = side (g⁻¹ • w)
+    rw [← hhv, ← hhw] at hne ⊢
+    rw [smul_mk, smul_mk, side_mk, side_mk]
+    rcases eq_or_ne h g with rfl | hhg
+    · exact absurd (sym2_mk_eq_sym2_mk htwo hvw hij h) hne
+    · exact sideAux_eq_sideAux (fun H => hhg (inv_mul_eq_one.mp H).symm) v.1 w.1
+
+end DecEq
+
+theorem isAcyclic (htwo : ∀ a b c : ι, a = b ∨ a = c ∨ b = c) : (graph G).IsAcyclic := by
+  classical
+  rw [isAcyclic_iff_forall_adj_isBridge]
+  rintro v w ⟨hvw, g, hgv, hgw⟩
+  rw [← hgv, ← hgw]
+  exact isBridge_mk_mk htwo hvw g
+
+theorem isTree [Nonempty ι] (htwo : ∀ a b c : ι, a = b ∨ a = c ∨ b = c) :
+    (graph G).IsTree :=
+  isTree_of_isAcyclic (isAcyclic htwo)
+
+theorem isTree_two {G : Fin 2 → Type*} [∀ i, Group (G i)] : (graph G).IsTree :=
+  isTree (by decide)
+
+theorem isAcyclic_two {G : Fin 2 → Type*} [∀ i, Group (G i)] : (graph G).IsAcyclic :=
+  isAcyclic (by decide)
+
+end BassSerre
+end GroupTheory
+
+namespace GroupTheory
+namespace BassSerre
+
+p2m_open "Monoid Monoid.CoprodI"
+
+theorem fromRel_eq_graph {G : Fin 2 → Type*} [∀ i, Group (G i)] :
+    (SimpleGraph.fromRel fun v w : (i : Fin 2) × (Monoid.CoprodI G ⧸ (Monoid.CoprodI.of (M := G) (i
+      := i)).range) =>
+        v.1 ≠ w.1 ∧ ∃ g : Monoid.CoprodI G,
+          v.2 = (QuotientGroup.mk g : Monoid.CoprodI G ⧸ (Monoid.CoprodI.of (M := G) (i :=
+            v.1)).range) ∧
+          w.2 = (QuotientGroup.mk g : Monoid.CoprodI G ⧸ (Monoid.CoprodI.of (M := G) (i :=
+            w.1)).range))
+      = graph G := by
+  ext ⟨i, x⟩ ⟨j, y⟩
+  rw [SimpleGraph.fromRel_adj]
+  constructor
+  · rintro ⟨-, ⟨hij, g, hx, hy⟩ | ⟨hji, g, hy, hx⟩⟩
+    · simp only at hij hx hy
+      rw [hx, hy]
+      exact ⟨hij, g, rfl, rfl⟩
+    · simp only at hji hx hy
+      rw [hx, hy]
+      exact ⟨Ne.symm hji, g, rfl, rfl⟩
+  · rintro ⟨hij, g, hx, hy⟩
+    simp only [Vertex.mk, Sigma.mk.inj_iff, heq_eq_eq, true_and] at hx hy
+    refine ⟨fun h => hij (congrArg Sigma.fst h), Or.inl ⟨hij, g, hx.symm, hy.symm⟩⟩
+
+end GroupTheory.BassSerre
+
+theorem solution {G : Fin 2 → Type*} [∀ i, Group (G i)] :
+    (SimpleGraph.fromRel fun v w : (i : Fin 2) × (Monoid.CoprodI G ⧸ (Monoid.CoprodI.of (M := G) (i
+      := i)).range) =>
+        v.1 ≠ w.1 ∧ ∃ g : Monoid.CoprodI G,
+          v.2 = (QuotientGroup.mk g : Monoid.CoprodI G ⧸ (Monoid.CoprodI.of (M := G) (i :=
+            v.1)).range) ∧
+          w.2 = (QuotientGroup.mk g : Monoid.CoprodI G ⧸ (Monoid.CoprodI.of (M := G) (i :=
+            w.1)).range)).IsTree := by
+  rw [GroupTheory.BassSerre.fromRel_eq_graph]
+  exact GroupTheory.BassSerre.isTree_two
+
+end S_Monoid_CoprodI_isTree_cosetGraph
+end P2MW
+export P2MW.S_Monoid_CoprodI_isTree_cosetGraph (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem Monoid.CoprodI.isTree_cosetGraph {G : Fin 2 → Type*} [∀ i, Group (G i)] :
+    (SimpleGraph.fromRel fun v w : (i : Fin 2) × (Monoid.CoprodI G ⧸ (Monoid.CoprodI.of (M := G) (i
+      := i)).range) =>
+        v.1 ≠ w.1 ∧ ∃ g : Monoid.CoprodI G,
+          v.2 = (QuotientGroup.mk g : Monoid.CoprodI G ⧸ (Monoid.CoprodI.of (M := G) (i :=
+            v.1)).range) ∧
+          w.2 = (QuotientGroup.mk g : Monoid.CoprodI G ⧸ (Monoid.CoprodI.of (M := G) (i :=
+            w.1)).range)).IsTree :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Monoid_CoprodI_nonempty_freeGroupBasis_fin_kuroshRank.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Monoid_CoprodI_nonempty_freeGroupBasis_fin_kuroshRank.lean
new file mode 100644
index 0000000000..7ba7a400b2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Monoid_CoprodI_nonempty_freeGroupBasis_fin_kuroshRank.lean
@@ -0,0 +1,1580 @@
+/-
+Based on Prove2Me node Monoid.CoprodI.nonempty_freeGroupBasis_fin_kuroshRank
+(3fb03155-d2bb-5679-be6d-64f799195868) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 46a25482-b816-5155-9197-1fb6280775de
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.GroupTheory.CoprodI
+public import Mathlib.GroupTheory.Index
+
+import Mathlib.Algebra.BigOperators.Fin
+import Mathlib.Algebra.Group.Action.Sigma
+import Mathlib.Algebra.Torsor.Defs
+import Mathlib.Data.Nat.Cast.Field
+import Mathlib.GroupTheory.FreeGroup.Reduce
+import Mathlib.Order.CompletePartialOrder
+import Mathlib.Tactic.Group
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Monoid_CoprodI_isTree_cosetGraph
+import LeanPool.FLTEichlerShimura.Theorems.Thm_SimpleGraph_exists_walkConnected_transversal_of_preconnected
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Subgroup_card_orbitRelQuotient_mul_card_eq_index
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Freeness of torsion-free finite-index subgroups of G₀ * G₁
+
+Theorem statement: `Monoid.CoprodI.nonempty_freeGroupBasis_fin_kuroshRank`
+(`3fb03155-d2bb-5679-be6d-64f799195868`), by Claude, 2026-09-05.
+
+Proof: submission `46a25482-b816-5155-9197-1fb6280775de`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $G : \mathrm{Fin}\,2 \to \mathrm{Type}$ be a pair of finite groups $G_0, G_1$, and let
+$\mathrm{CoprodI}\,G = G_0 * G_1$ be their free product, with canonical injections
+`Monoid.CoprodI.of`. Let $H$ be a subgroup of $G_0 * G_1$ of finite index, and assume that for every
+$i \in \{0,1\}$, every $g \in G_0 * G_1$ and every $x \in G_i$, the relation $g^{-1}\,\iota_i(x)\,g
+\in H$ forces $x = 1$; that is, no conjugate of a nontrivial element of either free factor lies in
+$H$. The conclusion asserts that the type of free group bases of $H$ indexed by $\mathrm{Fin}\bigl(1
++ m - m/\lvert G_0\rvert - m/\lvert G_1\rvert\bigr)$ is nonempty, where $m = [G_0 * G_1 : H]$ is the
+index as a natural number and the subtractions and divisions are those of $\mathbb{N}$ (truncated
+subtraction, integer division; in fact $\lvert G_i\rvert$ divides $m$ under the stated hypothesis).
+Thus $H$ is a free group admitting a free basis of exactly that finite cardinality, i.e. of rank
+equal to $1 + m - m/\lvert G_0\rvert - m/\lvert G_1\rvert$.
+
+This is the Kurosh/Nielsen–Schreier statement for a free product of two finite groups, in the
+Bass–Serre form: the hypothesis says precisely that $H$ acts freely on the tree of cosets of the two
+factors, whence $H$ is free, and the rank is the first Betti number of the quotient graph, with
+$m/\lvert G_0\rvert + m/\lvert G_1\rvert$ vertices and $m$ edges. It is used to produce free
+subgroups of $\mathrm{PSL}_2$ from trace conditions, in
+[`Matrix.SpecialLinearGroup.nonempty_freeGroupBasis_map_quotient_center_of_forall_trace_ne`]
+(thm.html#Matrix.SpecialLinearGroup.nonempty_freeGroupBasis_map_quotient_center_of_forall_trace_ne).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Monoid_CoprodI_nonempty_freeGroupBasis_fin_kuroshRank.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_Monoid_CoprodI_nonempty_freeGroupBasis_fin_kuroshRank
+
+open Subgroup
+
+namespace GroupTheory
+
+namespace Kurosh
+
+section TorsionCriterion
+
+variable {G : Type*} [Group G]
+
+def ConjTrivial (A H : Subgroup G) : Prop :=
+  ∀ g x : G, x ∈ A → g⁻¹ * x * g ∈ H → x = 1
+
+theorem isOfFinOrder_conj {x : G} (g : G) (hx : IsOfFinOrder x) :
+    IsOfFinOrder (g⁻¹ * x * g) :=
+  (isConj_iff.mpr ⟨g⁻¹, by rw [inv_inv]⟩ : IsConj x (g⁻¹ * x * g)).isOfFinOrder hx
+
+theorem isOfFinOrder_of_mem_finite {A : Subgroup G} [Finite A] {x : G} (hx : x ∈ A) :
+    IsOfFinOrder x :=
+  Submonoid.isOfFinOrder_coe.mpr (isOfFinOrder_of_finite (⟨x, hx⟩ : A))
+
+theorem conjTrivial_of_torsionFree (A H : Subgroup G) [Finite A]
+    (hH : ∀ y : G, y ∈ H → IsOfFinOrder y → y = 1) : ConjTrivial A H := by
+  intro g x hxA hxH
+  have hfin : IsOfFinOrder (g⁻¹ * x * g) := isOfFinOrder_conj g (isOfFinOrder_of_mem_finite hxA)
+  have h0 : g⁻¹ * x * g = 1 := hH _ hxH hfin
+  have h1 : g⁻¹ * x * g = g⁻¹ * 1 * g := by rw [h0, mul_one, inv_mul_cancel]
+  exact mul_left_cancel (mul_right_cancel h1)
+
+end TorsionCriterion
+
+section Divisibility
+
+variable {G : Type*} [Group G] (A H : Subgroup G)
+
+theorem stabilizer_eq_bot_of_conjTrivial (hAH : ConjTrivial A H) (q : G ⧸ H) :
+    MulAction.stabilizer A q = ⊥ := by
+  rw [eq_bot_iff]
+  intro a ha
+  induction q using QuotientGroup.induction_on with
+  | H g =>
+    have hmem : (a : G) • (g : G ⧸ H) = (g : G ⧸ H) := ha
+    rw [MulAction.Quotient.smul_coe, QuotientGroup.eq, smul_eq_mul, mul_inv_rev] at hmem
+    have hinv : (a : G)⁻¹ = 1 := hAH g ((a : G)⁻¹) (inv_mem a.2) hmem
+    have : (a : G) = 1 := by rw [← inv_inv (a : G), hinv, inv_one]
+    exact Subgroup.mem_bot.mpr (Subtype.ext this)
+
+theorem card_dvd_index_of_conjTrivial [Finite A] [H.FiniteIndex] (hAH : ConjTrivial A H) :
+    Nat.card A ∣ H.index := by
+  classical
+  have key := MulAction.selfEquivSigmaOrbitsQuotientStabilizer A (G ⧸ H)
+  have efib : ∀ ω : Quotient (MulAction.orbitRel A (G ⧸ H)),
+      (A ⧸ MulAction.stabilizer A ω.out) ≃ A := fun ω =>
+    (Subgroup.quotientEquivOfEq (stabilizer_eq_bot_of_conjTrivial A H hAH ω.out)).trans
+      QuotientGroup.quotientBot.toEquiv
+  have e : (G ⧸ H) ≃ Quotient (MulAction.orbitRel A (G ⧸ H)) × A :=
+    (key.trans (Equiv.sigmaCongrRight efib)).trans (Equiv.sigmaEquivProd _ _)
+  rw [Subgroup.index_eq_card, Nat.card_congr e, Nat.card_prod]
+  exact dvd_mul_left _ _
+
+end Divisibility
+
+section RankArithmetic
+
+def kuroshRank (a b m : ℕ) : ℕ := 1 + m - m / a - m / b
+
+theorem kuroshRank_add_eq {a b m : ℕ} (hab : m / a + m / b ≤ m) :
+    kuroshRank a b m + m / a + m / b = 1 + m := by
+  unfold kuroshRank
+  omega
+
+theorem kuroshRank_two_three {m : ℕ} (hm : 6 ∣ m) : kuroshRank 2 3 m = 1 + m / 6 := by
+  obtain ⟨k, rfl⟩ := hm
+  simp only [kuroshRank]
+  omega
+
+theorem six_dvd_of_two_dvd_of_three_dvd {m : ℕ} (h2 : 2 ∣ m) (h3 : 3 ∣ m) : 6 ∣ m :=
+  (by decide : Nat.Coprime 2 3).mul_dvd_of_dvd_of_dvd h2 h3
+
+theorem div_add_div_le {a b m : ℕ} (ha : 2 ≤ a) (hb : 2 ≤ b) : m / a + m / b ≤ m := by
+  have h1 : m / a ≤ m / 2 := Nat.div_le_div_left ha (by omega)
+  have h2 : m / b ≤ m / 2 := Nat.div_le_div_left hb (by omega)
+  omega
+
+theorem kuroshRank_eq_one_sub_eulerChar {K : Type*} [Field K] {a b m : ℕ}
+    (ha : a ∣ m) (hb : b ∣ m) (ha2 : 2 ≤ a) (hb2 : 2 ≤ b)
+    (ha0 : (a : K) ≠ 0) (hb0 : (b : K) ≠ 0) :
+    (kuroshRank a b m : K) = 1 - m * (1 / a + 1 / b - 1) := by
+  have hab : m / a + m / b ≤ m := div_add_div_le ha2 hb2
+  have key : ((kuroshRank a b m : ℕ) : K) + ((m / a : ℕ) : K) + ((m / b : ℕ) : K)
+      = 1 + (m : K) := by
+    rw [← Nat.cast_add, ← Nat.cast_add, kuroshRank_add_eq hab, Nat.cast_add, Nat.cast_one]
+  rw [Nat.cast_div ha ha0, Nat.cast_div hb hb0] at key
+  have hsolve : (kuroshRank a b m : K) = 1 + (m : K) - (m : K) / a - (m : K) / b := by
+    rw [eq_sub_iff_add_eq, eq_sub_iff_add_eq]
+    calc (kuroshRank a b m : K) + (m : K) / b + (m : K) / a
+        = (kuroshRank a b m : K) + (m : K) / a + (m : K) / b := by ring
+      _ = 1 + (m : K) := key
+  rw [hsolve]
+  ring
+
+end RankArithmetic
+
+section Core
+
+def KuroshRankFormula (G : Fin 2 → Type*) [∀ i, Group (G i)] [∀ i, Finite (G i)] : Prop :=
+  ∀ H : Subgroup (Monoid.CoprodI G), H.FiniteIndex →
+    (∀ i, ConjTrivial (Monoid.CoprodI.of (i := i)).range H) →
+    Nonempty (FreeGroupBasis
+      (Fin (kuroshRank (Nat.card (G 0)) (Nat.card (G 1)) H.index)) H)
+
+variable {G : Fin 2 → Type*} [∀ i, Group (G i)] [∀ i, Finite (G i)]
+
+scoped instance finite_range_of (i : Fin 2) : Finite ((Monoid.CoprodI.of (i := i)).range :
+    Subgroup (Monoid.CoprodI G)) :=
+  Finite.of_equiv (G i) (MonoidHom.ofInjective (Monoid.CoprodI.of_injective i)).toEquiv
+
+omit [∀ i, Finite (G i)] in
+theorem card_range_of (i : Fin 2) :
+    Nat.card ((Monoid.CoprodI.of (i := i)).range : Subgroup (Monoid.CoprodI G))
+      = Nat.card (G i) :=
+  (Nat.card_congr (MonoidHom.ofInjective (Monoid.CoprodI.of_injective i)).toEquiv).symm
+
+theorem six_dvd_index_of_conjTrivial (h2 : Nat.card (G 0) = 2) (h3 : Nat.card (G 1) = 3)
+    (H : Subgroup (Monoid.CoprodI G)) [H.FiniteIndex]
+    (hH : ∀ i, ConjTrivial (Monoid.CoprodI.of (i := i)).range H) :
+    6 ∣ H.index := by
+  have d0 := card_dvd_index_of_conjTrivial _ H (hH 0)
+  have d1 := card_dvd_index_of_conjTrivial _ H (hH 1)
+  rw [card_range_of 0, h2] at d0
+  rw [card_range_of 1, h3] at d1
+  exact six_dvd_of_two_dvd_of_three_dvd d0 d1
+
+theorem kuroshRank_index_eq (h2 : Nat.card (G 0) = 2) (h3 : Nat.card (G 1) = 3)
+    (H : Subgroup (Monoid.CoprodI G)) [H.FiniteIndex]
+    (hH : ∀ i, ConjTrivial (Monoid.CoprodI.of (i := i)).range H) :
+    kuroshRank (Nat.card (G 0)) (Nat.card (G 1)) H.index = 1 + H.index / 6 := by
+  rw [h2, h3]
+  exact kuroshRank_two_three (six_dvd_index_of_conjTrivial h2 h3 H hH)
+
+end Core
+
+end Kurosh
+end GroupTheory
+
+p2m_open "Subgroup SimpleGraph \
+  P2MW.S_Monoid_CoprodI_nonempty_freeGroupBasis_fin_kuroshRank.SimpleGraph"
+
+namespace GroupTheory
+
+namespace BassSerre
+
+p2m_open "Monoid Monoid.CoprodI"
+
+variable {ι : Type*} (G : ι → Type*) [∀ i, Group (G i)]
+
+abbrev Vertex : Type _ :=
+  (i : ι) × (CoprodI G ⧸ (Monoid.CoprodI.of (M := G) (i := i)).range)
+
+variable {G} in
+abbrev Vertex.mk (i : ι) (g : CoprodI G) : Vertex G :=
+  ⟨i, QuotientGroup.mk g⟩
+
+def graph : SimpleGraph (Vertex G) where
+  Adj v w := v.1 ≠ w.1 ∧ ∃ g : CoprodI G, Vertex.mk v.1 g = v ∧ Vertex.mk w.1 g = w
+  symm := ⟨by
+    rintro ⟨i, x⟩ ⟨j, y⟩ ⟨hij, g, hgv, hgw⟩
+    exact ⟨hij.symm, g, hgw, hgv⟩⟩
+  loopless := ⟨fun _ h => h.1 rfl⟩
+
+variable {G}
+
+theorem mk_eq_mk_iff {i : ι} {g h : CoprodI G} :
+    Vertex.mk (G := G) i g = Vertex.mk i h ↔ g⁻¹ * h ∈ (of (M := G) (i := i)).range := by
+  constructor
+  · intro H
+    exact QuotientGroup.eq.mp
+      (sigma_mk_injective (β := fun j => CoprodI G ⧸ (of (M := G) (i := j)).range) H)
+  · intro H
+    exact congrArg (Sigma.mk i) (QuotientGroup.eq.mpr H)
+
+theorem adj_mk {i j : ι} (hij : i ≠ j) (g : CoprodI G) :
+    (graph G).Adj (Vertex.mk i g) (Vertex.mk j g) :=
+  ⟨hij, g, rfl, rfl⟩
+
+theorem adj_iff_exists {v w : Vertex G} :
+    (graph G).Adj v w ↔ v.1 ≠ w.1 ∧ ∃ g, Vertex.mk v.1 g = v ∧ Vertex.mk w.1 g = w :=
+  Iff.rfl
+
+theorem adj_one {i j : ι} (hij : i ≠ j) :
+    (graph G).Adj (Vertex.mk i (1 : CoprodI G)) (Vertex.mk j 1) :=
+  adj_mk hij 1
+
+scoped instance : SMul (CoprodI G) (Vertex G) where
+  smul g v := ⟨v.1, g • v.2⟩
+
+theorem smul_def (g : CoprodI G) (v : Vertex G) : g • v = ⟨v.1, g • v.2⟩ :=
+  rfl
+
+@[scoped simp]
+theorem smul_mk (g : CoprodI G) (i : ι) (h : CoprodI G) :
+    g • Vertex.mk i h = Vertex.mk i (g * h) :=
+  rfl
+
+scoped instance : MulAction (CoprodI G) (Vertex G) where
+  one_smul := by
+    rintro ⟨i, x⟩
+    change (⟨i, (1 : CoprodI G) • x⟩ : Vertex G) = ⟨i, x⟩
+    rw [one_smul]
+  mul_smul g h := by
+    rintro ⟨i, x⟩
+    change (⟨i, (g * h) • x⟩ : Vertex G) = ⟨i, g • h • x⟩
+    rw [mul_smul]
+
+theorem smul_adj {v w : Vertex G} (g : CoprodI G) (h : (graph G).Adj v w) :
+    (graph G).Adj (g • v) (g • w) := by
+  obtain ⟨hvw, e, hev, hew⟩ := h
+  exact ⟨hvw, g * e, by rw [← hev]; rfl, by rw [← hew]; rfl⟩
+
+def smulHom (g : CoprodI G) : graph G →g graph G where
+  toFun v := g • v
+  map_rel' := smul_adj g
+
+@[scoped simp]
+theorem smulHom_apply (g : CoprodI G) (v : Vertex G) : smulHom g v = g • v :=
+  rfl
+
+theorem reachable_smul {v w : Vertex G} (g : CoprodI G) (h : (graph G).Reachable v w) :
+    (graph G).Reachable (g • v) (g • w) :=
+  h.map (smulHom g)
+
+theorem smul_eq_self_iff {h : CoprodI G} {i : ι} {g : CoprodI G} :
+    h • Vertex.mk i g = Vertex.mk i g ↔ g⁻¹ * h * g ∈ (of (M := G) (i := i)).range := by
+  rw [smul_mk, mk_eq_mk_iff, show (h * g)⁻¹ * g = (g⁻¹ * h * g)⁻¹ by group, inv_mem_iff]
+
+theorem conjTrivial_iff_forall_smul_ne {H : Subgroup (CoprodI G)} :
+    (∀ i, Kurosh.ConjTrivial (of (M := G) (i := i)).range H) ↔
+      ∀ h ∈ H, ∀ v : Vertex G, h • v = v → h = 1 := by
+  constructor
+  · rintro hCT h hH ⟨i, x⟩ hfix
+    induction x using QuotientGroup.induction_on with
+    | H g =>
+      have hx : g⁻¹ * h * g ∈ (of (M := G) (i := i)).range := smul_eq_self_iff.mp hfix
+      have hx' : (g⁻¹)⁻¹ * (g⁻¹ * h * g) * g⁻¹ ∈ H := by
+        have : (g⁻¹)⁻¹ * (g⁻¹ * h * g) * g⁻¹ = h := by group
+        rwa [this]
+      have hone := hCT i g⁻¹ (g⁻¹ * h * g) hx hx'
+      have hh : h = g * (g⁻¹ * h * g) * g⁻¹ := by group
+      rw [hh, hone, mul_one, mul_inv_cancel]
+  · rintro hfree i c x hx hcxc
+    have hfix : (c⁻¹ * x * c) • Vertex.mk i c⁻¹ = Vertex.mk i c⁻¹ := by
+      rw [smul_eq_self_iff]
+      have : (c⁻¹)⁻¹ * (c⁻¹ * x * c) * c⁻¹ = x := by group
+      rwa [this]
+    have hone := hfree _ hcxc _ hfix
+    have hx1 : x = c * (c⁻¹ * x * c) * c⁻¹ := by group
+    rw [hx1, hone, mul_one, mul_inv_cancel]
+
+theorem mk_of_eq_mk_one {i : ι} (m : G i) :
+    Vertex.mk (G := G) i (of m) = Vertex.mk i 1 :=
+  mk_eq_mk_iff.mpr (MonoidHom.mem_range.mpr ⟨m⁻¹, by simp⟩)
+
+theorem reachable_one_one (i j : ι) :
+    (graph G).Reachable (Vertex.mk i (1 : CoprodI G)) (Vertex.mk j 1) := by
+  classical
+  by_cases h : i = j
+  · subst h; exact Reachable.refl _
+  · exact (adj_one h).reachable
+
+theorem reachable_one_of {i k : ι} (m : G k) :
+    (graph G).Reachable (Vertex.mk i (1 : CoprodI G)) (Vertex.mk i (of m)) := by
+  classical
+  by_cases hki : k = i
+  · subst hki
+    rw [mk_of_eq_mk_one]
+  · refine (reachable_one_one i k).trans ?_
+    rw [← mk_of_eq_mk_one m]
+    exact (adj_mk hki (of m)).reachable
+
+theorem reachable_one (i : ι) (g : CoprodI G) (j : ι) :
+    (graph G).Reachable (Vertex.mk i (1 : CoprodI G)) (Vertex.mk j g) := by
+  induction g using CoprodI.induction_left with
+  | one => exact reachable_one_one i j
+  | mul m x ih =>
+    have step := reachable_smul (of m) ih
+    rw [smul_mk, smul_mk, mul_one] at step
+    exact (reachable_one_of m).trans step
+
+theorem connected [Nonempty ι] : (graph G).Connected := by
+  inhabit ι
+  rw [connected_iff_exists_forall_reachable]
+  refine ⟨Vertex.mk default 1, ?_⟩
+  rintro ⟨j, x⟩
+  induction x using QuotientGroup.induction_on with
+  | H g => exact reachable_one default g j
+
+theorem eq_one_of_mem_range_of_mem_range {i j : ι} (hij : i ≠ j) {x : CoprodI G}
+    (hi : x ∈ (of (M := G) (i := i)).range) (hj : x ∈ (of (M := G) (i := j)).range) :
+    x = 1 := by
+  classical
+  obtain ⟨a, rfl⟩ := MonoidHom.mem_range.mp hi
+  obtain ⟨b, hb⟩ := MonoidHom.mem_range.mp hj
+  have key := congrArg (lift (Pi.mulSingle i (MonoidHom.id (G i)))) hb
+  rw [lift_of, lift_of, Pi.mulSingle_eq_same, Pi.mulSingle_eq_of_ne hij.symm] at key
+  simp only [MonoidHom.one_apply, MonoidHom.id_apply] at key
+  rw [← key, map_one]
+
+theorem range_inf_range_eq_bot {i j : ι} (hij : i ≠ j) :
+    (of (M := G) (i := i)).range ⊓ (of (M := G) (i := j)).range = ⊥ := by
+  rw [eq_bot_iff]
+  intro x hx
+  rw [Subgroup.mem_inf] at hx
+  exact mem_bot.mpr (eq_one_of_mem_range_of_mem_range hij hx.1 hx.2)
+
+theorem eq_of_mk_eq_mk {i j : ι} (hij : i ≠ j) {g g' : CoprodI G}
+    (hgi : Vertex.mk (G := G) i g = Vertex.mk i g')
+    (hgj : Vertex.mk (G := G) j g = Vertex.mk j g') :
+    g = g' :=
+  inv_mul_eq_one.mp
+    (eq_one_of_mem_range_of_mem_range hij (mk_eq_mk_iff.mp hgi) (mk_eq_mk_iff.mp hgj))
+
+theorem adj_base_iff {i : ι} {w : Vertex G} :
+    (graph G).Adj (Vertex.mk i (1 : CoprodI G)) w ↔
+      i ≠ w.1 ∧ ∃ a : G i, Vertex.mk w.1 (of a) = w := by
+  constructor
+  · rintro ⟨hiw, g, hgi, hgw⟩
+    refine ⟨hiw, ?_⟩
+    obtain ⟨a, ha⟩ := MonoidHom.mem_range.mp
+      (show g ∈ (of (M := G) (i := i)).range by simpa using mk_eq_mk_iff.mp hgi)
+    exact ⟨a, by rw [ha]; exact hgw⟩
+  · rintro ⟨hiw, a, haw⟩
+    exact ⟨hiw, of a, (mk_of_eq_mk_one a), haw⟩
+
+theorem isTree_of_isAcyclic [Nonempty ι] (h : (graph G).IsAcyclic) : (graph G).IsTree :=
+  ⟨connected, h⟩
+
+end BassSerre
+end GroupTheory
+
+namespace GroupTheory
+namespace BassSerre
+
+p2m_open "Monoid Monoid.CoprodI"
+
+theorem fromRel_eq_graph {G : Fin 2 → Type*} [∀ i, Group (G i)] :
+    (SimpleGraph.fromRel fun v w : (i : Fin 2) × (Monoid.CoprodI G ⧸ (Monoid.CoprodI.of (M := G) (i
+      := i)).range) =>
+        v.1 ≠ w.1 ∧ ∃ g : Monoid.CoprodI G,
+          v.2 = (QuotientGroup.mk g : Monoid.CoprodI G ⧸ (Monoid.CoprodI.of (M := G) (i :=
+            v.1)).range) ∧
+          w.2 = (QuotientGroup.mk g : Monoid.CoprodI G ⧸ (Monoid.CoprodI.of (M := G) (i :=
+            w.1)).range))
+      = graph G := by
+  ext ⟨i, x⟩ ⟨j, y⟩
+  rw [SimpleGraph.fromRel_adj]
+  constructor
+  · rintro ⟨-, ⟨hij, g, hx, hy⟩ | ⟨hji, g, hy, hx⟩⟩
+    · simp only at hij hx hy
+      rw [hx, hy]
+      exact ⟨hij, g, rfl, rfl⟩
+    · simp only at hji hx hy
+      rw [hx, hy]
+      exact ⟨Ne.symm hji, g, rfl, rfl⟩
+  · rintro ⟨hij, g, hx, hy⟩
+    simp only [Vertex.mk, Sigma.mk.inj_iff, heq_eq_eq, true_and] at hx hy
+    refine ⟨fun h => hij (congrArg Sigma.fst h), Or.inl ⟨hij, g, hx.symm, hy.symm⟩⟩
+
+theorem isTree_two {G : Fin 2 → Type*} [∀ i, Group (G i)] : (graph G).IsTree := by
+  rw [← fromRel_eq_graph]
+  exact Monoid.CoprodI.isTree_cosetGraph
+
+theorem isAcyclic_two {G : Fin 2 → Type*} [∀ i, Group (G i)] : (graph G).IsAcyclic :=
+  isTree_two.isAcyclic
+
+end GroupTheory.BassSerre
+
+p2m_open "Subgroup MulAction SimpleGraph \
+  P2MW.S_Monoid_CoprodI_nonempty_freeGroupBasis_fin_kuroshRank.SimpleGraph Monoid"
+
+namespace GroupTheory
+
+namespace GraphTransversal
+
+def WalkConnected {V : Type*} (T : SimpleGraph V) (s : Set V) : Prop :=
+  ∀ v ∈ s, ∀ w ∈ s, ∃ p : T.Walk v w, ∀ x ∈ p.support, x ∈ s
+
+structure IsConnectedTransversal {V : Type*} (T : SimpleGraph V) (Γ : Type*) [Group Γ]
+    [MulAction Γ V] (D : Set V) : Prop where
+  walkConnected : WalkConnected T D
+  eq_of_mem_orbit : ∀ v ∈ D, ∀ w ∈ D, v ∈ orbit Γ w → v = w
+  exists_mem_orbit : ∀ u : V, ∃ v ∈ D, v ∈ orbit Γ u
+
+variable {V : Type*} {T : SimpleGraph V} {Γ : Type*} [Group Γ] [MulAction Γ V]
+
+theorem walkConnected_singleton (T : SimpleGraph V) (v₀ : V) : WalkConnected T {v₀} := by
+  intro v hv w hw
+  rw [Set.mem_singleton_iff] at hv hw
+  subst hv; subst hw
+  exact ⟨Walk.nil, by simp⟩
+
+theorem WalkConnected.insert_of_adj {s : Set V} (hs : WalkConnected T s) {v w : V}
+    (hv : v ∈ s) (hadj : T.Adj v w) : WalkConnected T (insert w s) := by
+  have key : ∀ x ∈ insert w s, ∃ p : T.Walk v x, ∀ y ∈ p.support, y ∈ insert w s := by
+    intro x hx
+    rcases Set.mem_insert_iff.mp hx with rfl | hx
+    · refine ⟨Walk.cons hadj Walk.nil, fun y hy => ?_⟩
+      simp only [Walk.support_cons, Walk.support_nil, List.mem_cons,
+        List.not_mem_nil, or_false] at hy
+      rcases hy with rfl | rfl
+      · exact Set.mem_insert_of_mem _ hv
+      · exact Set.mem_insert _ _
+    · obtain ⟨p, hp⟩ := hs v hv x hx
+      exact ⟨p, fun y hy => Set.mem_insert_of_mem _ (hp y hy)⟩
+  intro a ha b hb
+  obtain ⟨p, hp⟩ := key a ha
+  obtain ⟨q, hq⟩ := key b hb
+  refine ⟨p.reverse.append q, fun y hy => ?_⟩
+  rw [Walk.support_append, List.mem_append] at hy
+  rcases hy with hy | hy
+  · rw [Walk.support_reverse, List.mem_reverse] at hy
+    exact hp y hy
+  · exact hq y (List.mem_of_mem_tail hy)
+
+theorem walkConnected_sUnion {c : Set (Set V)} (hchain : IsChain (· ⊆ ·) c)
+    (hwc : ∀ s ∈ c, WalkConnected T s) : WalkConnected T (⋃₀ c) := by
+  rintro v ⟨s, hs, hvs⟩ w ⟨t, ht, hwt⟩
+  rcases hchain.total hs ht with hst | hts
+  · obtain ⟨p, hp⟩ := hwc t ht v (hst hvs) w hwt
+    exact ⟨p, fun x hx => Set.mem_sUnion.mpr ⟨t, ht, hp x hx⟩⟩
+  · obtain ⟨p, hp⟩ := hwc s hs v hvs w (hts hwt)
+    exact ⟨p, fun x hx => Set.mem_sUnion.mpr ⟨s, hs, hp x hx⟩⟩
+
+private theorem mem_orbit_symm' {a b : V} (h : a ∈ orbit Γ b) : b ∈ orbit Γ a := by
+  obtain ⟨γ, rfl⟩ := h
+  exact ⟨γ⁻¹, inv_smul_smul γ b⟩
+
+theorem eq_of_mem_orbit_sUnion {c : Set (Set V)} (hchain : IsChain (· ⊆ ·) c)
+    (hinj : ∀ s ∈ c, ∀ v ∈ s, ∀ w ∈ s, v ∈ orbit Γ w → v = w) :
+    ∀ v ∈ ⋃₀ c, ∀ w ∈ ⋃₀ c, v ∈ orbit Γ w → v = w := by
+  rintro v ⟨s, hs, hvs⟩ w ⟨t, ht, hwt⟩ hvw
+  rcases hchain.total hs ht with hst | hts
+  · exact hinj t ht v (hst hvs) w hwt hvw
+  · exact hinj s hs v hvs w (hts hwt) hvw
+
+theorem eq_of_mem_orbit_insert {s : Set V}
+    (hs : ∀ v ∈ s, ∀ w ∈ s, v ∈ orbit Γ w → v = w) {w : V}
+    (hw : ¬∃ v ∈ s, v ∈ orbit Γ w) :
+    ∀ v ∈ insert w s, ∀ v' ∈ insert w s, v ∈ orbit Γ v' → v = v' := by
+  intro v hv v' hv' hvv'
+  rcases Set.mem_insert_iff.mp hv with rfl | hvs <;>
+    rcases Set.mem_insert_iff.mp hv' with rfl | hv's
+  · rfl
+  · exact absurd ⟨v', hv's, mem_orbit_symm' hvv'⟩ hw
+  · exact absurd ⟨v, hvs, hvv'⟩ hw
+  · exact hs v hvs v' hv's hvv'
+
+theorem exists_adj_of_walk (hsmul : ∀ (γ : Γ) {v w : V}, T.Adj v w → T.Adj (γ • v) (γ • w))
+    {s : Set V} {a b : V} (p : T.Walk a b) :
+    (∃ v ∈ s, v ∈ orbit Γ a) → (¬∃ v ∈ s, v ∈ orbit Γ b) →
+      ∃ v ∈ s, ∃ w, T.Adj v w ∧ ¬∃ v' ∈ s, v' ∈ orbit Γ w := by
+  induction p with
+  | nil => exact fun ha hb => absurd ha hb
+  | @cons a c b hac p ih =>
+    intro ha hb
+    by_cases hc : ∃ v ∈ s, v ∈ orbit Γ c
+    · exact ih hc hb
+    · obtain ⟨v, hvs, γ, hγ⟩ := ha
+      refine ⟨v, hvs, γ • c, ?_, ?_⟩
+      · rw [← hγ]
+        exact hsmul γ hac
+      · rintro ⟨v', hv's, hv'⟩
+        rw [MulAction.orbit_smul] at hv'
+        exact hc ⟨v', hv's, hv'⟩
+
+theorem exists_isConnectedTransversal
+    (hsmul : ∀ (γ : Γ) {v w : V}, T.Adj v w → T.Adj (γ • v) (γ • w))
+    (hpre : T.Preconnected) (v₀ : V) :
+    ∃ D : Set V, v₀ ∈ D ∧ IsConnectedTransversal T Γ D := by
+  obtain ⟨D, h0, h1, h2, h3⟩ :=
+    SimpleGraph.exists_walkConnected_transversal_of_preconnected hsmul hpre v₀
+  exact ⟨D, h0, ⟨h1, h2, h3⟩⟩
+
+variable {D : Set V}
+
+noncomputable def orbitRepr (hD : IsConnectedTransversal T Γ D) (v : V) : V :=
+  (hD.exists_mem_orbit v).choose
+
+theorem orbitRepr_mem (hD : IsConnectedTransversal T Γ D) (v : V) : orbitRepr hD v ∈ D :=
+  (hD.exists_mem_orbit v).choose_spec.1
+
+theorem orbitRepr_mem_orbit (hD : IsConnectedTransversal T Γ D) (v : V) :
+    orbitRepr hD v ∈ orbit Γ v :=
+  (hD.exists_mem_orbit v).choose_spec.2
+
+noncomputable def transl (hD : IsConnectedTransversal T Γ D) (v : V) : Γ :=
+  (orbitRepr_mem_orbit hD v).choose⁻¹
+
+theorem transl_smul_orbitRepr (hD : IsConnectedTransversal T Γ D) (v : V) :
+    transl hD v • orbitRepr hD v = v :=
+  inv_smul_eq_iff.mpr (orbitRepr_mem_orbit hD v).choose_spec.symm
+
+theorem orbitRepr_eq_self (hD : IsConnectedTransversal T Γ D) {v : V} (hv : v ∈ D) :
+    orbitRepr hD v = v :=
+  hD.eq_of_mem_orbit _ (orbitRepr_mem hD v) _ hv (orbitRepr_mem_orbit hD v)
+
+theorem orbitRepr_smul (hD : IsConnectedTransversal T Γ D) (γ : Γ) (v : V) :
+    orbitRepr hD (γ • v) = orbitRepr hD v := by
+  refine hD.eq_of_mem_orbit _ (orbitRepr_mem hD _) _ (orbitRepr_mem hD _) ?_
+  rw [MulAction.orbit_eq_iff.mpr (orbitRepr_mem_orbit hD v), ← MulAction.orbit_smul γ v]
+  exact orbitRepr_mem_orbit hD (γ • v)
+
+theorem eq_of_smul_eq_smul_of_free (hfree : ∀ (γ : Γ) (v : V), γ • v = v → γ = 1)
+    {γ γ' : Γ} {v : V} (h : γ • v = γ' • v) : γ = γ' := by
+  have h1 : (γ'⁻¹ * γ) • v = v := by rw [mul_smul, h, inv_smul_smul]
+  have h2 := hfree _ _ h1
+  rwa [inv_mul_eq_one, eq_comm] at h2
+
+theorem transl_eq_one (hD : IsConnectedTransversal T Γ D)
+    (hfree : ∀ (γ : Γ) (v : V), γ • v = v → γ = 1) {v : V} (hv : v ∈ D) :
+    transl hD v = 1 := by
+  apply hfree _ v
+  have h := transl_smul_orbitRepr hD v
+  rwa [orbitRepr_eq_self hD hv] at h
+
+theorem mem_of_transl_eq_one (hD : IsConnectedTransversal T Γ D) {v : V}
+    (h : transl hD v = 1) : v ∈ D := by
+  have h1 := transl_smul_orbitRepr hD v
+  rw [h, one_smul] at h1
+  rw [← h1]
+  exact orbitRepr_mem hD v
+
+theorem transl_smul (hD : IsConnectedTransversal T Γ D)
+    (hfree : ∀ (γ : Γ) (v : V), γ • v = v → γ = 1) (γ : Γ) (v : V) :
+    transl hD (γ • v) = γ * transl hD v := by
+  refine eq_of_smul_eq_smul_of_free hfree (v := orbitRepr hD v) ?_
+  rw [mul_smul, transl_smul_orbitRepr, ← orbitRepr_smul hD γ v, transl_smul_orbitRepr]
+
+end GraphTransversal
+
+namespace BassSerre
+
+open GraphTransversal
+
+variable {G : Fin 2 → Type*} [∀ i, Group (G i)] {H : Subgroup (CoprodI G)}
+  {D : Set (Vertex G)}
+
+theorem smul_adj_subgroup (η : H) {v w : Vertex G} (h : (graph G).Adj v w) :
+    (graph G).Adj (η • v) (η • w) :=
+  smul_adj (η : CoprodI G) h
+
+theorem exists_transversal (H : Subgroup (CoprodI G)) (v₀ : Vertex G) :
+    ∃ D : Set (Vertex G), v₀ ∈ D ∧ IsConnectedTransversal (graph G) H D :=
+  GraphTransversal.exists_isConnectedTransversal
+    (fun η {_ _} h => smul_adj_subgroup η h) connected.preconnected v₀
+
+theorem forall_smul_eq_of_forall_mem
+    (hfree : ∀ h ∈ H, ∀ v : Vertex G, h • v = v → h = 1) :
+    ∀ (η : H) (v : Vertex G), η • v = v → η = 1 := fun η v hv =>
+  Subtype.ext (hfree (η : CoprodI G) η.2 v hv)
+
+noncomputable def edgeGen (hD : IsConnectedTransversal (graph G) H D) (g : CoprodI G) : H :=
+  (transl hD (Vertex.mk 0 g))⁻¹ * transl hD (Vertex.mk 1 g)
+
+theorem transl_mk_one_eq (hD : IsConnectedTransversal (graph G) H D) (g : CoprodI G) :
+    transl hD (Vertex.mk 1 g) = transl hD (Vertex.mk 0 g) * edgeGen hD g :=
+  (mul_inv_cancel_left _ _).symm
+
+theorem transl_mk_mul (hD : IsConnectedTransversal (graph G) H D)
+    (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1) (η : H) (i : Fin 2)
+    (g : CoprodI G) :
+    transl hD (Vertex.mk i ((η : CoprodI G) * g)) = η * transl hD (Vertex.mk i g) :=
+  transl_smul hD hfree η (Vertex.mk i g)
+
+theorem edgeGen_smul (hD : IsConnectedTransversal (graph G) H D)
+    (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1) (η : H) (g : CoprodI G) :
+    edgeGen hD ((η : CoprodI G) * g) = edgeGen hD g := by
+  change (transl hD (Vertex.mk 0 ((η : CoprodI G) * g)))⁻¹ *
+      transl hD (Vertex.mk 1 ((η : CoprodI G) * g)) =
+    (transl hD (Vertex.mk 0 g))⁻¹ * transl hD (Vertex.mk 1 g)
+  rw [transl_mk_mul hD hfree, transl_mk_mul hD hfree]
+  group
+
+theorem edgeGen_eq_one_iff (hD : IsConnectedTransversal (graph G) H D)
+    (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1) (g : CoprodI G) :
+    edgeGen hD g = 1 ↔ ∃ η : H, Vertex.mk 0 ((η : CoprodI G) * g) ∈ D ∧
+      Vertex.mk 1 ((η : CoprodI G) * g) ∈ D := by
+  constructor
+  · intro h
+    have hτ : transl hD (Vertex.mk 1 g) = transl hD (Vertex.mk 0 g) := by
+      rw [transl_mk_one_eq hD g, h, mul_one]
+    refine ⟨(transl hD (Vertex.mk 0 g))⁻¹, ?_, ?_⟩
+    · exact mem_of_transl_eq_one hD
+        (by rw [transl_mk_mul hD hfree]; exact inv_mul_cancel _)
+    · exact mem_of_transl_eq_one hD
+        (by rw [transl_mk_mul hD hfree, hτ]; exact inv_mul_cancel _)
+  · rintro ⟨η, h0, h1⟩
+    have e0 := transl_eq_one hD hfree h0
+    have e1 := transl_eq_one hD hfree h1
+    rw [transl_mk_mul hD hfree] at e0 e1
+    change (transl hD (Vertex.mk 0 g))⁻¹ * transl hD (Vertex.mk 1 g) = 1
+    rw [(inv_eq_of_mul_eq_one_right e0).symm, (inv_eq_of_mul_eq_one_right e1).symm]
+    group
+
+theorem inv_mul_transl_mem_closure (hD : IsConnectedTransversal (graph G) H D)
+    {v w : Vertex G} (hadj : (graph G).Adj v w) :
+    (transl hD v)⁻¹ * transl hD w ∈ Subgroup.closure (Set.range (edgeGen hD)) := by
+  obtain ⟨hne, g, hgv, hgw⟩ := hadj
+  rw [← hgv, ← hgw]
+  rcases (by decide : ∀ a b : Fin 2, a ≠ b → a = 0 ∧ b = 1 ∨ a = 1 ∧ b = 0) v.1 w.1 hne with
+    ⟨h1, h2⟩ | ⟨h1, h2⟩
+  · rw [h1, h2]
+    exact Subgroup.subset_closure (Set.mem_range_self g)
+  · rw [h1, h2]
+    have hkey : (transl hD (Vertex.mk 1 g))⁻¹ * transl hD (Vertex.mk 0 g) =
+        (edgeGen hD g)⁻¹ := by
+      change _ = ((transl hD (Vertex.mk 0 g))⁻¹ * transl hD (Vertex.mk 1 g))⁻¹
+      group
+    rw [hkey]
+    exact (Subgroup.closure _).inv_mem (Subgroup.subset_closure (Set.mem_range_self g))
+
+theorem inv_mul_transl_mem_closure_of_walk (hD : IsConnectedTransversal (graph G) H D)
+    {a b : Vertex G} (p : (graph G).Walk a b) :
+    (transl hD a)⁻¹ * transl hD b ∈ Subgroup.closure (Set.range (edgeGen hD)) := by
+  induction p with
+  | nil =>
+    rw [inv_mul_cancel]
+    exact (Subgroup.closure _).one_mem
+  | @cons a c b hac p ih =>
+    have key : (transl hD a)⁻¹ * transl hD b =
+        ((transl hD a)⁻¹ * transl hD c) * ((transl hD c)⁻¹ * transl hD b) := by group
+    rw [key]
+    exact (Subgroup.closure _).mul_mem (inv_mul_transl_mem_closure hD hac) ih
+
+theorem transl_mem_closure (hD : IsConnectedTransversal (graph G) H D)
+    (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1) (v : Vertex G) :
+    transl hD v ∈ Subgroup.closure (Set.range (edgeGen hD)) := by
+  obtain ⟨d, hd, -⟩ := hD.exists_mem_orbit v
+  obtain ⟨p⟩ := connected.preconnected d v
+  have h := inv_mul_transl_mem_closure_of_walk hD p
+  rwa [transl_eq_one hD hfree hd, inv_one, one_mul] at h
+
+theorem closure_range_edgeGen (hD : IsConnectedTransversal (graph G) H D)
+    (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1) :
+    Subgroup.closure (Set.range (edgeGen hD)) = ⊤ := by
+  rw [eq_top_iff]
+  intro η _
+  obtain ⟨d, hd, -⟩ := hD.exists_mem_orbit (Vertex.mk 0 1)
+  have h1 : transl hD (η • d) = η := by
+    have h1' := transl_smul hD hfree η d
+    rw [transl_eq_one hD hfree hd, mul_one] at h1'
+    exact h1'
+  rw [← h1]
+  exact transl_mem_closure hD hfree _
+
+theorem closure_range_edgeGen_of_forall_mem (hD : IsConnectedTransversal (graph G) H D)
+    (hfree : ∀ h ∈ H, ∀ v : Vertex G, h • v = v → h = 1) :
+    Subgroup.closure (Set.range (edgeGen hD)) = ⊤ :=
+  closure_range_edgeGen hD (forall_smul_eq_of_forall_mem hfree)
+
+end BassSerre
+end GroupTheory
+open Subgroup MulAction Monoid
+
+namespace GroupTheory
+
+namespace FreeActionTree
+
+section FreeOrbitCount
+
+variable {M : Type*} [Group M] (H K : Subgroup M)
+
+theorem card_orbitRelQuotient_mul_card' (hKH : Kurosh.ConjTrivial K H) :
+    Nat.card (orbitRel.Quotient H (M ⧸ K)) * Nat.card K = H.index :=
+  Subgroup.card_orbitRelQuotient_mul_card_eq_index H K hKH
+
+theorem finite_orbitRelQuotient [H.FiniteIndex] (hKH : Kurosh.ConjTrivial K H) :
+    Finite (orbitRel.Quotient H (M ⧸ K)) := by
+  refine Nat.finite_of_card_ne_zero fun h0 => ?_
+  have := card_orbitRelQuotient_mul_card' H K hKH
+  rw [h0, zero_mul] at this
+  exact Subgroup.FiniteIndex.index_ne_zero this.symm
+
+theorem card_orbitRelQuotient_eq_index_div (hK : Nat.card K ≠ 0)
+    (hKH : Kurosh.ConjTrivial K H) :
+    Nat.card (orbitRel.Quotient H (M ⧸ K)) = H.index / Nat.card K := by
+  rw [← card_orbitRelQuotient_mul_card' H K hKH,
+    Nat.mul_div_cancel _ (Nat.pos_of_ne_zero hK)]
+
+end FreeOrbitCount
+
+section VertexOrbits
+
+variable {G : Fin 2 → Type*} [∀ i, Group (G i)]
+
+abbrev ComponentOrbits (H : Subgroup (CoprodI G)) (i : Fin 2) : Type _ :=
+  orbitRel.Quotient H (CoprodI G ⧸ (CoprodI.of (M := G) (i := i)).range)
+
+def vertexToSigma (H : Subgroup (CoprodI G)) (v : BassSerre.Vertex G) :
+    Σ i : Fin 2, ComponentOrbits H i :=
+  ⟨v.1, Quotient.mk'' v.2⟩
+
+theorem vertexToSigma_smul (H : Subgroup (CoprodI G)) (η : H) (v : BassSerre.Vertex G) :
+    vertexToSigma H ((η : CoprodI G) • v) = vertexToSigma H v := by
+  obtain ⟨i, x⟩ := v
+  change (⟨i, Quotient.mk'' ((η : CoprodI G) • x)⟩ : Σ i, ComponentOrbits H i)
+    = ⟨i, Quotient.mk'' x⟩
+  refine congrArg (Sigma.mk i) (Quotient.sound' ?_)
+  exact mem_orbit_iff.mpr ⟨η, rfl⟩
+
+theorem vertexToSigma_eq_of_mem_orbit (H : Subgroup (CoprodI G)) {v w : BassSerre.Vertex G}
+    (hvw : v ∈ orbit H w) : vertexToSigma H v = vertexToSigma H w := by
+  obtain ⟨η, hη⟩ := hvw
+  rw [← hη]
+  exact vertexToSigma_smul H η w
+
+def sigmaToVertexOrbit (H : Subgroup (CoprodI G)) (p : Σ i : Fin 2, ComponentOrbits H i) :
+    orbitRel.Quotient H (BassSerre.Vertex G) :=
+  Quotient.liftOn' p.2
+    (fun x => Quotient.mk'' (⟨p.1, x⟩ : BassSerre.Vertex G)) fun x y hxy => by
+      obtain ⟨η, hη⟩ : x ∈ orbit H y := hxy
+      refine Quotient.sound' (mem_orbit_iff.mpr ⟨η, ?_⟩)
+      change (⟨p.1, (η : CoprodI G) • y⟩ : BassSerre.Vertex G) = ⟨p.1, x⟩
+      rw [show (η : CoprodI G) • y = x from hη]
+
+def vertexOrbitEquivSigma (H : Subgroup (CoprodI G)) :
+    orbitRel.Quotient H (BassSerre.Vertex G) ≃ Σ i : Fin 2, ComponentOrbits H i where
+  toFun q := Quotient.liftOn' q (vertexToSigma H)
+    fun _ _ h => vertexToSigma_eq_of_mem_orbit H h
+  invFun := sigmaToVertexOrbit H
+  left_inv q := by
+    induction q using Quotient.inductionOn' with
+    | h v =>
+      obtain ⟨i, x⟩ := v
+      rfl
+  right_inv p := by
+    obtain ⟨i, ω⟩ := p
+    induction ω using Quotient.inductionOn' with
+    | h x => rfl
+
+variable [∀ i, Finite (G i)]
+
+theorem card_vertexOrbits (H : Subgroup (CoprodI G)) [H.FiniteIndex]
+    (hCT : ∀ i, Kurosh.ConjTrivial (CoprodI.of (M := G) (i := i)).range H) :
+    Nat.card (orbitRel.Quotient H (BassSerre.Vertex G)) =
+      H.index / Nat.card (G 0) + H.index / Nat.card (G 1) := by
+  classical
+  have hfin : ∀ i : Fin 2, Finite (ComponentOrbits H i) := fun i =>
+    finite_orbitRelQuotient H _ (hCT i)
+  have hcard : ∀ i : Fin 2, Nat.card (ComponentOrbits H i) = H.index / Nat.card (G i) := by
+    intro i
+    rw [← Kurosh.card_range_of (G := G) i]
+    refine card_orbitRelQuotient_eq_index_div H _ ?_ (hCT i)
+    rw [Kurosh.card_range_of (G := G) i]
+    exact Nat.card_pos.ne'
+  rw [Nat.card_congr (vertexOrbitEquivSigma H), Nat.card_sigma, Fin.sum_univ_two, hcard 0,
+    hcard 1]
+
+omit [∀ i, Finite (G i)] in
+theorem finite_vertexOrbits (H : Subgroup (CoprodI G)) [H.FiniteIndex]
+    (hCT : ∀ i, Kurosh.ConjTrivial (CoprodI.of (M := G) (i := i)).range H) :
+    Finite (orbitRel.Quotient H (BassSerre.Vertex G)) := by
+  have hfin : ∀ i : Fin 2, Finite (ComponentOrbits H i) := fun i =>
+    finite_orbitRelQuotient H _ (hCT i)
+  exact Finite.of_equiv _ (vertexOrbitEquivSigma H).symm
+
+theorem kuroshRank_eq_one_add_index_sub (H : Subgroup (CoprodI G)) [H.FiniteIndex]
+    (hCT : ∀ i, Kurosh.ConjTrivial (CoprodI.of (M := G) (i := i)).range H) :
+    Kurosh.kuroshRank (Nat.card (G 0)) (Nat.card (G 1)) H.index =
+      1 + H.index - Nat.card (orbitRel.Quotient H (BassSerre.Vertex G)) := by
+  rw [card_vertexOrbits H hCT, Kurosh.kuroshRank, Nat.sub_sub]
+
+end VertexOrbits
+
+section Residual
+
+variable (G : Fin 2 → Type*) [∀ i, Group (G i)]
+
+def FreeActionRankFormula : Prop :=
+  ∀ H : Subgroup (CoprodI G), H.FiniteIndex →
+    (∀ h ∈ H, ∀ v : BassSerre.Vertex G, h • v = v → h = 1) →
+    Nonempty (FreeGroupBasis
+      (Fin (1 + H.index - Nat.card (orbitRel.Quotient H (BassSerre.Vertex G)))) H)
+
+variable {G} [∀ i, Finite (G i)]
+
+theorem kuroshRankFormula_of_freeActionRankFormula (hfree : FreeActionRankFormula G) :
+    Kurosh.KuroshRankFormula G := by
+  intro H hFI hCT
+  obtain ⟨b⟩ := hfree H hFI (BassSerre.conjTrivial_iff_forall_smul_ne.mp hCT)
+  exact ⟨b.reindex (finCongr (kuroshRank_eq_one_add_index_sub H hCT).symm)⟩
+
+end Residual
+end FreeActionTree
+end GroupTheory
+p2m_open "Subgroup MulAction SimpleGraph \
+  P2MW.S_Monoid_CoprodI_nonempty_freeGroupBasis_fin_kuroshRank.SimpleGraph Monoid"
+
+namespace SimpleGraph
+p2m_export "SimpleGraph" "IsAcyclic Walk.edges_append induce Walk.support_reverse loopless \
+  IsTree.card_edgeFinset connected_iff_exists_forall_reachable edgeSet_deleteEdges Preconnected \
+  edgeFinset_card Embedding isAcyclic_iff_forall_adj_isBridge fromRel fromRel_adj IsBridge \
+  Walk.support_map Reachable.refl Adj.reachable Walk.support_append Connected Embedding.induce \
+  edgeSet support Walk Walk.mem_support_nil_iff mk IsTree symm Walk.support_nil Walk.edges_cons \
+  isBridge_iff Walk.cons Walk.edges_nil support_map Walk.support_copy deleteEdges_adj \
+  Walk.support_cons Adj connected_iff structure Walk.nil deleteEdges Reachable mk.injEq edge \
+  exists_walkConnected_transversal_of_preconnected"
+p2m_open "SimpleGraph"
+
+variable {V : Type*} {G : SimpleGraph V} {a b u v w : V}
+
+variable (G a b) in
+private def _root_.SimpleGraph.farSide : Set V :=
+  {v | ¬ (G.deleteEdges {s(a, b)}).Reachable a v}
+
+p2m_export "SimpleGraph" "farSide"
+theorem mem_farSide_iff : v ∈ G.farSide a b ↔ ¬ (G.deleteEdges {s(a, b)}).Reachable a v :=
+  Iff.rfl
+
+theorem notMem_farSide_left : a ∉ G.farSide a b := fun h => h (Reachable.refl a)
+
+theorem mem_farSide_right (h : G.IsBridge s(a, b)) : b ∈ G.farSide a b :=
+  (isBridge_iff).mp h
+
+theorem reachable_of_mem_walk_support (p : G.Walk u v) (hw : w ∈ p.support) :
+    G.Reachable u w := by
+  induction p with
+  | nil =>
+    rw [Walk.mem_support_nil_iff] at hw
+    exact hw ▸ Reachable.refl _
+  | cons h p ih =>
+    rw [Walk.support_cons, List.mem_cons] at hw
+    rcases hw with rfl | hw
+    · exact Reachable.refl _
+    · exact h.reachable.trans (ih hw)
+
+theorem eq_of_adj_of_mem_farSide (hadj : G.Adj v w) (hv : v ∈ G.farSide a b)
+    (hw : w ∉ G.farSide a b) : v = b ∧ w = a := by
+  rw [mem_farSide_iff, not_not] at hw
+  have hedge : s(v, w) = s(a, b) := by
+    by_contra hne
+    refine hv (hw.trans (Adj.reachable (deleteEdges_adj.mpr ⟨hadj.symm, ?_⟩)))
+    rw [Set.mem_singleton_iff]
+    intro hcon
+    exact hne ((Sym2.eq_swap).trans hcon)
+  rcases Sym2.eq_iff.mp hedge with ⟨rfl, rfl⟩ | ⟨h1, h2⟩
+  · exact absurd hv notMem_farSide_left
+  · exact ⟨h1, h2⟩
+
+theorem mem_support_of_mem_farSide (p : G.Walk v w) :
+    v ∈ G.farSide a b → w ∉ G.farSide a b → a ∈ p.support ∧ b ∈ p.support := by
+  induction p with
+  | nil => exact fun hv hw => absurd hv hw
+  | @cons x y z hadj q ih =>
+    intro hv hw
+    by_cases hy : y ∈ G.farSide a b
+    · obtain ⟨ha, hb⟩ := ih hy hw
+      rw [Walk.support_cons]
+      exact ⟨List.mem_cons_of_mem _ ha, List.mem_cons_of_mem _ hb⟩
+    · obtain ⟨hxb, hya⟩ := eq_of_adj_of_mem_farSide hadj hv hy
+      constructor
+      · rw [Walk.support_cons]
+        exact List.mem_cons_of_mem _ (hya ▸ q.start_mem_support)
+      · exact hxb ▸ (Walk.cons hadj q).start_mem_support
+
+theorem farSide_subset_farSide {p q x y : V} (hx : x ∈ G.farSide p q)
+    (hp : p ∉ G.farSide x y) : G.farSide x y ⊆ G.farSide p q := by
+  intro v hv hWpv
+  rw [mem_farSide_iff, not_not] at hp
+  obtain ⟨W⟩ := hWpv
+  have hW : ∀ e ∈ W.edges, e ∈ (G.deleteEdges {s(x, y)}).edgeSet := by
+    intro e he
+    rw [edgeSet_deleteEdges, Set.mem_sdiff, Set.mem_singleton_iff]
+    constructor
+    · have hmem := W.edges_subset_edgeSet he
+      rw [edgeSet_deleteEdges] at hmem
+      exact hmem.1
+    · rintro rfl
+      exact hx (reachable_of_mem_walk_support W (W.fst_mem_support_of_mem_edges he))
+  exact hv (hp.trans ⟨W.transfer _ hW⟩)
+
+end SimpleGraph
+
+namespace GroupTheory
+
+namespace BassSerre
+
+open GraphTransversal
+
+variable {G : Fin 2 → Type*} [∀ i, Group (G i)] {H : Subgroup (CoprodI G)}
+  {D : Set (Vertex G)}
+
+theorem reachable_deleteEdges_smul (g : CoprodI G) {a b u v : Vertex G}
+    (h : ((graph G).deleteEdges {s(a, b)}).Reachable u v) :
+    ((graph G).deleteEdges {s(g • a, g • b)}).Reachable (g • u) (g • v) := by
+  refine h.map ⟨fun x => g • x, ?_⟩
+  intro x y hxy
+  rw [deleteEdges_adj] at hxy ⊢
+  refine ⟨smul_adj g hxy.1, fun hcon => hxy.2 ?_⟩
+  rw [Set.mem_singleton_iff] at hcon ⊢
+  rcases Sym2.eq_iff.mp hcon with ⟨h1, h2⟩ | ⟨h1, h2⟩
+  · exact Sym2.eq_iff.mpr (Or.inl ⟨MulAction.injective g h1, MulAction.injective g h2⟩)
+  · exact Sym2.eq_iff.mpr (Or.inr ⟨MulAction.injective g h1, MulAction.injective g h2⟩)
+
+theorem smul_mem_farSide_smul (g : CoprodI G) {a b v : Vertex G}
+    (hv : v ∈ (graph G).farSide a b) :
+    g • v ∈ (graph G).farSide (g • a) (g • b) := by
+  intro hcon
+  apply hv
+  have hback := reachable_deleteEdges_smul g⁻¹ hcon
+  simpa only [inv_smul_smul] using hback
+
+variable (hD : IsConnectedTransversal (graph G) H D)
+
+theorem transl_coe_smul (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1) (η : H)
+    (v : Vertex G) : transl hD ((η : CoprodI G) • v) = η * transl hD v :=
+  transl_smul hD hfree η v
+
+theorem exists_walk_of_transl_eq (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1)
+    {γ : H} {v w : Vertex G} (hv : transl hD v = γ) (hw : transl hD w = γ) :
+    ∃ p : (graph G).Walk v w, ∀ x ∈ p.support, transl hD x = γ := by
+  obtain ⟨p₀, hp₀⟩ := hD.walkConnected (orbitRepr hD v) (orbitRepr_mem hD v)
+    (orbitRepr hD w) (orbitRepr_mem hD w)
+  refine ⟨(p₀.map (smulHom (γ : CoprodI G))).copy ?_ ?_, ?_⟩
+  · change (γ : CoprodI G) • orbitRepr hD v = v
+    rw [← hv]
+    exact transl_smul_orbitRepr hD v
+  · change (γ : CoprodI G) • orbitRepr hD w = w
+    rw [← hw]
+    exact transl_smul_orbitRepr hD w
+  · intro x hx
+    rw [Walk.support_copy, Walk.support_map, List.mem_map] at hx
+    obtain ⟨d, hd, rfl⟩ := hx
+    change transl hD ((γ : CoprodI G) • d) = γ
+    rw [transl_coe_smul hD hfree, transl_eq_one hD hfree (hp₀ d hd), mul_one]
+
+include hD in
+theorem notMem_farSide_of_mem {p q : Vertex G} (hp : p ∈ D) (hq : q ∉ D) {v : Vertex G}
+    (hv : v ∈ D) : v ∉ (graph G).farSide p q := by
+  intro hcon
+  obtain ⟨W, hW⟩ := hD.walkConnected v hv p hp
+  obtain ⟨-, hbq⟩ := mem_support_of_mem_farSide W hcon notMem_farSide_left
+  exact hq (hW q hbq)
+
+theorem mem_farSide_of_transl_eq (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1)
+    {p q : Vertex G} (hadj : (graph G).Adj p q) (hp : p ∈ D) (hq : q ∉ D) {v : Vertex G}
+    (hv : transl hD v = transl hD q) : v ∈ (graph G).farSide p q := by
+  by_contra hcon
+  obtain ⟨W, hW⟩ := exists_walk_of_transl_eq hD hfree (rfl : transl hD q = transl hD q) hv
+  have hbridge : (graph G).IsBridge s(p, q) :=
+    (isAcyclic_iff_forall_adj_isBridge.mp isAcyclic_two) hadj
+  obtain ⟨hpa, -⟩ := mem_support_of_mem_farSide W (mem_farSide_right hbridge) hcon
+  have h1 : transl hD p = transl hD q := hW p hpa
+  rw [transl_eq_one hD hfree hp] at h1
+  exact hq (mem_of_transl_eq_one hD h1.symm)
+
+variable (H) in
+def nonTreeRep (hD : IsConnectedTransversal (graph G) H D) : Set (CoprodI G) :=
+  {g | Vertex.mk 0 g ∈ D ∧ edgeGen hD g ≠ 1}
+
+theorem mk_zero_mem_of_mem_nonTreeRep {g : CoprodI G} (hg : g ∈ nonTreeRep H hD) :
+    Vertex.mk 0 g ∈ D :=
+  hg.1
+
+theorem edgeGen_ne_one_of_mem_nonTreeRep {g : CoprodI G} (hg : g ∈ nonTreeRep H hD) :
+    edgeGen hD g ≠ 1 :=
+  hg.2
+
+include hD in
+theorem eq_of_mk_zero_mem (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1)
+    {g g' : CoprodI G} (hg : Vertex.mk 0 g ∈ D) (hg' : Vertex.mk 0 g' ∈ D) (η : H)
+    (hη : (η : CoprodI G) * g = g') : g = g' := by
+  have horb : Vertex.mk 0 g' ∈ orbit H (Vertex.mk (G := G) 0 g) := by
+    refine mem_orbit_iff.mpr ⟨η, ?_⟩
+    change (η : CoprodI G) • Vertex.mk 0 g = Vertex.mk 0 g'
+    rw [smul_mk, hη]
+  have heq : Vertex.mk (G := G) 0 g' = Vertex.mk 0 g := hD.eq_of_mem_orbit _ hg' _ hg horb
+  have hfix : η • Vertex.mk (G := G) 0 g = Vertex.mk 0 g := by
+    change (η : CoprodI G) • Vertex.mk 0 g = Vertex.mk 0 g
+    rw [smul_mk, hη]
+    exact heq
+  have hone := hfree η _ hfix
+  rw [← hη, hone, OneMemClass.coe_one, one_mul]
+
+variable (H) in
+noncomputable def letterImage (hD : IsConnectedTransversal (graph G) H D)
+    (x : nonTreeRep H hD × Bool) :
+    H :=
+  cond x.2 (edgeGen hD (x.1 : CoprodI G)) (edgeGen hD (x.1 : CoprodI G))⁻¹
+
+@[scoped simp]
+theorem letterImage_true (g : nonTreeRep H hD) :
+    letterImage H hD (g, true) = edgeGen hD (g : CoprodI G) :=
+  rfl
+
+@[scoped simp]
+theorem letterImage_false (g : nonTreeRep H hD) :
+    letterImage H hD (g, false) = (edgeGen hD (g : CoprodI G))⁻¹ :=
+  rfl
+
+theorem letterImage_ne_one (x : nonTreeRep H hD × Bool) : letterImage H hD x ≠ 1 := by
+  obtain ⟨g, _ | _⟩ := x
+  · simpa using g.2.2
+  · exact g.2.2
+
+variable (H) in
+noncomputable def exitSrc (hD : IsConnectedTransversal (graph G) H D) :
+    nonTreeRep H hD × Bool → Vertex G
+  | (g, true) => Vertex.mk 0 (g : CoprodI G)
+  | (g, false) =>
+      Vertex.mk 1 ((((edgeGen hD (g : CoprodI G))⁻¹ : H) : CoprodI G) * (g : CoprodI G))
+
+variable (H) in
+noncomputable def exitTgt (hD : IsConnectedTransversal (graph G) H D) :
+    nonTreeRep H hD × Bool → Vertex G
+  | (g, true) => Vertex.mk 1 (g : CoprodI G)
+  | (g, false) =>
+      Vertex.mk 0 ((((edgeGen hD (g : CoprodI G))⁻¹ : H) : CoprodI G) * (g : CoprodI G))
+
+@[scoped simp]
+theorem exitSrc_true (g : nonTreeRep H hD) :
+    exitSrc H hD (g, true) = Vertex.mk 0 (g : CoprodI G) :=
+  rfl
+
+@[scoped simp]
+theorem exitSrc_false (g : nonTreeRep H hD) :
+    exitSrc H hD (g, false) =
+      Vertex.mk 1 ((((edgeGen hD (g : CoprodI G))⁻¹ : H) : CoprodI G) * (g : CoprodI G)) :=
+  rfl
+
+@[scoped simp]
+theorem exitTgt_true (g : nonTreeRep H hD) :
+    exitTgt H hD (g, true) = Vertex.mk 1 (g : CoprodI G) :=
+  rfl
+
+@[scoped simp]
+theorem exitTgt_false (g : nonTreeRep H hD) :
+    exitTgt H hD (g, false) =
+      Vertex.mk 0 ((((edgeGen hD (g : CoprodI G))⁻¹ : H) : CoprodI G) * (g : CoprodI G)) :=
+  rfl
+
+theorem adj_exit (x : nonTreeRep H hD × Bool) :
+    (graph G).Adj (exitSrc H hD x) (exitTgt H hD x) := by
+  obtain ⟨g, _ | _⟩ := x
+  · exact adj_mk (by decide) _
+  · exact adj_mk (by decide) _
+
+theorem transl_exitSrc (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1)
+    (x : nonTreeRep H hD × Bool) : transl hD (exitSrc H hD x) = 1 := by
+  obtain ⟨g, _ | _⟩ := x
+  · rw [exitSrc_false, transl_mk_mul hD hfree, transl_mk_one_eq hD,
+      transl_eq_one hD hfree g.2.1, one_mul, inv_mul_cancel]
+  · exact transl_eq_one hD hfree g.2.1
+
+theorem exitSrc_mem (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1)
+    (x : nonTreeRep H hD × Bool) : exitSrc H hD x ∈ D :=
+  mem_of_transl_eq_one hD (transl_exitSrc hD hfree x)
+
+theorem transl_exitTgt (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1)
+    (x : nonTreeRep H hD × Bool) : transl hD (exitTgt H hD x) = letterImage H hD x := by
+  obtain ⟨g, _ | _⟩ := x
+  · rw [exitTgt_false, transl_mk_mul hD hfree, transl_eq_one hD hfree g.2.1, mul_one,
+      letterImage_false]
+  · rw [exitTgt_true, transl_mk_one_eq hD, transl_eq_one hD hfree g.2.1, one_mul,
+      letterImage_true]
+
+theorem exitTgt_notMem (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1)
+    (x : nonTreeRep H hD × Bool) : exitTgt H hD x ∉ D := fun h =>
+  letterImage_ne_one hD x ((transl_exitTgt hD hfree x).symm.trans (transl_eq_one hD hfree h))
+
+abbrev revLetter {α : Type*} (x : α × Bool) : α × Bool :=
+  (x.1, !x.2)
+
+theorem letterImage_smul_exitSrc_rev (x : nonTreeRep H hD × Bool) :
+    ((letterImage H hD x : H) : CoprodI G) • exitSrc H hD (revLetter x) = exitTgt H hD x := by
+  obtain ⟨g, _ | _⟩ := x
+  · change ((((edgeGen hD (g : CoprodI G))⁻¹ : H) : CoprodI G)) • Vertex.mk 0 (g : CoprodI G) = _
+    rw [smul_mk]
+    rfl
+  · change ((edgeGen hD (g : CoprodI G) : H) : CoprodI G) •
+      Vertex.mk 1 ((((edgeGen hD (g : CoprodI G))⁻¹ : H) : CoprodI G) * (g : CoprodI G)) = _
+    rw [smul_mk, ← mul_assoc, ← Subgroup.coe_mul, mul_inv_cancel, OneMemClass.coe_one, one_mul]
+    rfl
+
+theorem letterImage_smul_exitTgt_rev (x : nonTreeRep H hD × Bool) :
+    ((letterImage H hD x : H) : CoprodI G) • exitTgt H hD (revLetter x) = exitSrc H hD x := by
+  obtain ⟨g, _ | _⟩ := x
+  · change ((((edgeGen hD (g : CoprodI G))⁻¹ : H) : CoprodI G)) • Vertex.mk 1 (g : CoprodI G) = _
+    rw [smul_mk]
+    rfl
+  · change ((edgeGen hD (g : CoprodI G) : H) : CoprodI G) •
+      Vertex.mk 0 ((((edgeGen hD (g : CoprodI G))⁻¹ : H) : CoprodI G) * (g : CoprodI G)) = _
+    rw [smul_mk, ← mul_assoc, ← Subgroup.coe_mul, mul_inv_cancel, OneMemClass.coe_one, one_mul]
+    rfl
+
+theorem eq_of_exit_eq (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1)
+    {x y : nonTreeRep H hD × Bool} (hsrc : exitSrc H hD x = exitSrc H hD y)
+    (htgt : exitTgt H hD x = exitTgt H hD y) : x = y := by
+  obtain ⟨g, bx⟩ := x
+  obtain ⟨g', by'⟩ := y
+  cases bx <;> cases by'
+  · rw [exitSrc_false, exitSrc_false] at hsrc
+    rw [exitTgt_false, exitTgt_false] at htgt
+    have hwit := eq_of_mk_eq_mk (by decide : (1 : Fin 2) ≠ 0) hsrc htgt
+    have hconj : ((edgeGen hD (g' : CoprodI G) * (edgeGen hD (g : CoprodI G))⁻¹ : H) :
+        CoprodI G) * (g : CoprodI G) = (g' : CoprodI G) := by
+      rw [Subgroup.coe_mul, mul_assoc, hwit, ← mul_assoc, ← Subgroup.coe_mul,
+        mul_inv_cancel, OneMemClass.coe_one, one_mul]
+    have hgg' : (g : CoprodI G) = (g' : CoprodI G) :=
+      eq_of_mk_zero_mem hD hfree g.2.1 g'.2.1 _ hconj
+    rw [Prod.mk.injEq]
+    exact ⟨Subtype.ext hgg', rfl⟩
+  · rw [exitSrc_false, exitSrc_true] at hsrc
+    have hcon : (1 : Fin 2) = 0 := congrArg Sigma.fst hsrc
+    exact absurd hcon (by decide)
+  · rw [exitSrc_true, exitSrc_false] at hsrc
+    have hcon : (0 : Fin 2) = 1 := congrArg Sigma.fst hsrc
+    exact absurd hcon (by decide)
+  · rw [exitSrc_true, exitSrc_true] at hsrc
+    rw [exitTgt_true, exitTgt_true] at htgt
+    rw [Prod.mk.injEq]
+    exact ⟨Subtype.ext (eq_of_mk_eq_mk (by decide : (0 : Fin 2) ≠ 1) hsrc htgt), rfl⟩
+
+theorem letterImage_smul_mem_farSide_of_mem
+    (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1) (x : nonTreeRep H hD × Bool)
+    {v : Vertex G} (hv : v ∈ D) :
+    ((letterImage H hD x : H) : CoprodI G) • v ∈
+      (graph G).farSide (exitSrc H hD x) (exitTgt H hD x) := by
+  refine mem_farSide_of_transl_eq hD hfree (adj_exit hD x) (exitSrc_mem hD hfree x)
+    (exitTgt_notMem hD hfree x) ?_
+  rw [transl_coe_smul hD hfree, transl_eq_one hD hfree hv, mul_one,
+    transl_exitTgt hD hfree x]
+
+theorem letterImage_smul_mem_farSide (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1)
+    (x y : nonTreeRep H hD × Bool) (hxy : y ≠ revLetter x) {v : Vertex G}
+    (hv : v ∈ (graph G).farSide (exitSrc H hD y) (exitTgt H hD y)) :
+    ((letterImage H hD x : H) : CoprodI G) • v ∈
+      (graph G).farSide (exitSrc H hD x) (exitTgt H hD x) := by
+  set γ : CoprodI G := ((letterImage H hD x : H) : CoprodI G) with hγ
+  have hE1 : γ • exitSrc H hD (revLetter x) = exitTgt H hD x := by
+    rw [hγ]; exact letterImage_smul_exitSrc_rev hD x
+  have hE2 : γ • exitTgt H hD (revLetter x) = exitSrc H hD x := by
+    rw [hγ]; exact letterImage_smul_exitTgt_rev hD x
+  have hcoc : ∀ z : Vertex G, transl hD (γ • z) = letterImage H hD x * transl hD z := by
+    intro z
+    rw [hγ]
+    exact transl_coe_smul hD hfree _ z
+  have h1 : γ • v ∈ (graph G).farSide (γ • exitSrc H hD y) (γ • exitTgt H hD y) :=
+    smul_mem_farSide_smul γ hv
+  have htv : transl hD (γ • exitSrc H hD y) = letterImage H hD x := by
+    rw [hcoc, transl_exitSrc hD hfree y, mul_one]
+  have hsrc : γ • exitSrc H hD y ∈ (graph G).farSide (exitSrc H hD x) (exitTgt H hD x) :=
+    mem_farSide_of_transl_eq hD hfree (adj_exit hD x) (exitSrc_mem hD hfree x)
+      (exitTgt_notMem hD hfree x) (htv.trans (transl_exitTgt hD hfree x).symm)
+  have hp : exitSrc H hD x ∉ (graph G).farSide (γ • exitSrc H hD y) (γ • exitTgt H hD y) := by
+    rw [mem_farSide_iff, not_not]
+    obtain ⟨W, hW⟩ := exists_walk_of_transl_eq hD hfree htv (transl_exitTgt hD hfree x)
+    have htgtW : γ • exitTgt H hD y ∉ W.support := by
+      intro hmem
+      have hmm := hW _ hmem
+      rw [hcoc, transl_exitTgt hD hfree y] at hmm
+      exact letterImage_ne_one hD y (mul_left_cancel (hmm.trans (mul_one _).symm))
+    refine ⟨(W.append (Walk.cons (adj_exit hD x).symm Walk.nil)).toDeleteEdges _ ?_⟩
+    intro e he
+    rw [Walk.edges_append, List.mem_append] at he
+    rw [Set.mem_singleton_iff]
+    rcases he with he | he
+    · rintro rfl
+      exact htgtW (W.snd_mem_support_of_mem_edges he)
+    · rw [Walk.edges_cons, Walk.edges_nil, List.mem_singleton] at he
+      subst he
+      intro hcon
+      rcases Sym2.eq_iff.mp hcon with ⟨h1', h2'⟩ | ⟨h1', h2'⟩
+      · apply hxy
+        refine (eq_of_exit_eq hD hfree ?_ ?_).symm
+        · exact MulAction.injective γ (hE1.trans h1')
+        · exact MulAction.injective γ (hE2.trans h2')
+      · have hcontra : (1 : H) = letterImage H hD x := by
+          rw [← transl_exitSrc hD hfree x, h2', htv]
+        exact letterImage_ne_one hD x hcontra.symm
+  exact farSide_subset_farSide hsrc hp h1
+
+end BassSerre
+end GroupTheory
+
+namespace GroupTheory
+
+namespace BassSerre
+
+open GraphTransversal
+
+variable {G : Fin 2 → Type*} [∀ i, Group (G i)] {H : Subgroup (CoprodI G)}
+  {D : Set (Vertex G)} (hD : IsConnectedTransversal (graph G) H D)
+
+variable (H) in
+noncomputable def basisFun (hD : IsConnectedTransversal (graph G) H D) (g : nonTreeRep H hD) :
+    H :=
+  edgeGen hD (g : CoprodI G)
+
+theorem cond_basisFun_eq_letterImage (x : nonTreeRep H hD × Bool) :
+    cond x.2 (basisFun H hD x.1) (basisFun H hD x.1)⁻¹ = letterImage H hD x := by
+  obtain ⟨g, _ | _⟩ := x <;> rfl
+
+theorem prod_map_smul_mem_farSide (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1)
+    {d₀ : Vertex G} (hd₀ : d₀ ∈ D) (x : nonTreeRep H hD × Bool)
+    (L : List (nonTreeRep H hD × Bool))
+    (hred : ∀ (L₂ : List (nonTreeRep H hD × Bool)) (z : nonTreeRep H hD) (c : Bool)
+      (L₃ : List (nonTreeRep H hD × Bool)), x :: L ≠ L₂ ++ (z, c) :: (z, !c) :: L₃) :
+    ((((x :: L).map fun w => cond w.2 (basisFun H hD w.1) (basisFun H hD w.1)⁻¹).prod : H) :
+        CoprodI G) • d₀ ∈ (graph G).farSide (exitSrc H hD x) (exitTgt H hD x) := by
+  induction L generalizing x with
+  | nil =>
+    simp only [List.map_cons, List.map_nil, List.prod_cons, List.prod_nil, mul_one,
+      cond_basisFun_eq_letterImage]
+    exact letterImage_smul_mem_farSide_of_mem hD hfree x hd₀
+  | cons y L ih =>
+    have hxy : y ≠ revLetter x := by
+      intro hcon
+      exact hred [] x.1 x.2 L (by rw [List.nil_append, hcon])
+    have hredtail : ∀ (L₂ : List (nonTreeRep H hD × Bool)) (z : nonTreeRep H hD) (c : Bool)
+        (L₃ : List (nonTreeRep H hD × Bool)), y :: L ≠ L₂ ++ (z, c) :: (z, !c) :: L₃ := by
+      intro L₂ z c L₃ hcon
+      exact hred (x :: L₂) z c L₃ (by rw [List.cons_append, hcon])
+    have htail := ih y hredtail
+    simp only [List.map_cons, List.prod_cons, cond_basisFun_eq_letterImage] at htail ⊢
+    rw [Subgroup.coe_mul, mul_smul]
+    exact letterImage_smul_mem_farSide hD hfree x y hxy htail
+
+theorem lift_basisFun_injective (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1) :
+    Function.Injective (FreeGroup.lift (basisFun H hD)) := by
+  classical
+  rw [injective_iff_map_eq_one]
+  intro a ha
+  by_contra hne
+  have hL : FreeGroup.toWord a ≠ [] := fun h => hne (FreeGroup.toWord_eq_nil_iff.mp h)
+  obtain ⟨x, L, hxL⟩ : ∃ x L, FreeGroup.toWord a = x :: L := by
+    cases h : FreeGroup.toWord a with
+    | nil => exact absurd h hL
+    | cons x L => exact ⟨x, L, rfl⟩
+  have hred : ∀ (L₂ : List (nonTreeRep H hD × Bool)) (z : nonTreeRep H hD) (c : Bool)
+      (L₃ : List (nonTreeRep H hD × Bool)), x :: L ≠ L₂ ++ (z, c) :: (z, !c) :: L₃ := by
+    intro L₂ z c L₃ hcon
+    exact FreeGroup.reduce.not ((FreeGroup.reduce_toWord a).trans (hxL.trans hcon))
+  obtain ⟨d₀, hd₀, -⟩ := hD.exists_mem_orbit (Vertex.mk 0 1)
+  have hmem := prod_map_smul_mem_farSide hD hfree hd₀ x L hred
+  rw [← hxL, ← FreeGroup.lift_mk, FreeGroup.mk_toWord, ha, OneMemClass.coe_one,
+    one_smul] at hmem
+  exact notMem_farSide_of_mem hD (exitSrc_mem hD hfree x) (exitTgt_notMem hD hfree x) hd₀ hmem
+
+theorem closure_range_basisFun (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1) :
+    Subgroup.closure (Set.range (basisFun H hD)) = ⊤ := by
+  rw [eq_top_iff, ← closure_range_edgeGen hD hfree]
+  refine Subgroup.closure_le _ |>.mpr ?_
+  rintro _ ⟨g, rfl⟩
+  by_cases hg : edgeGen hD g = 1
+  · rw [hg]
+    exact Subgroup.one_mem _
+  · set η : H := (transl hD (Vertex.mk 0 g))⁻¹ with hη
+    have hbased : Vertex.mk (G := G) 0 ((η : CoprodI G) * g) ∈ D := by
+      refine mem_of_transl_eq_one hD ?_
+      rw [transl_mk_mul hD hfree, hη, inv_mul_cancel]
+    have hgen : edgeGen hD ((η : CoprodI G) * g) = edgeGen hD g := edgeGen_smul hD hfree η g
+    refine Subgroup.subset_closure ⟨⟨(η : CoprodI G) * g, hbased, ?_⟩, hgen⟩
+    rw [hgen]
+    exact hg
+
+noncomputable def freeGroupBasis (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1) :
+    FreeGroupBasis (nonTreeRep H hD) H :=
+  FreeGroupBasis.ofRepr
+    (MulEquiv.ofBijective (FreeGroup.lift (basisFun H hD))
+      ⟨lift_basisFun_injective hD hfree,
+        MonoidHom.range_eq_top.mp
+          (FreeGroup.range_lift_eq_closure.trans (closure_range_basisFun hD hfree))⟩).symm
+
+end BassSerre
+end GroupTheory
+
+namespace GroupTheory
+
+namespace BassSerre
+
+open GraphTransversal
+
+variable {G : Fin 2 → Type*} [∀ i, Group (G i)] {H : Subgroup (CoprodI G)}
+  {D : Set (Vertex G)} (hD : IsConnectedTransversal (graph G) H D)
+
+variable (H) in
+def baseRep (_hD : IsConnectedTransversal (graph G) H D) : Set (CoprodI G) :=
+  {g | Vertex.mk 0 g ∈ D}
+
+variable (H) in
+def treeRep (hD : IsConnectedTransversal (graph G) H D) : Set (CoprodI G) :=
+  {g | Vertex.mk 0 g ∈ D ∧ edgeGen hD g = 1}
+
+theorem mk_one_mem_of_mem_treeRep (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1)
+    {g : CoprodI G} (hg : g ∈ treeRep H hD) : Vertex.mk 1 g ∈ D := by
+  refine mem_of_transl_eq_one hD ?_
+  rw [transl_mk_one_eq hD, transl_eq_one hD hfree hg.1, one_mul, hg.2]
+
+theorem mem_treeRep_of_mk_one_mem (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1)
+    {g : CoprodI G} (hg : Vertex.mk 0 g ∈ D) (hg' : Vertex.mk 1 g ∈ D) :
+    g ∈ treeRep H hD := by
+  refine ⟨hg, ?_⟩
+  have h1 := transl_eq_one hD hfree hg'
+  rw [transl_mk_one_eq hD, transl_eq_one hD hfree hg, one_mul] at h1
+  exact h1
+
+noncomputable def baseRepEquivQuotient
+    (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1) :
+    baseRep H hD ≃ (CoprodI G ⧸ H) := by
+  refine Equiv.ofBijective (fun g => QuotientGroup.mk (g : CoprodI G)⁻¹) ⟨?_, ?_⟩
+  · intro g g' hgg'
+    have hH : ((g : CoprodI G)⁻¹)⁻¹ * ((g' : CoprodI G))⁻¹ ∈ H := QuotientGroup.eq.mp hgg'
+    rw [inv_inv] at hH
+    refine Subtype.ext (eq_of_mk_zero_mem hD hfree g'.2 g.2 ⟨_, hH⟩ ?_).symm
+    change (g : CoprodI G) * (g' : CoprodI G)⁻¹ * (g' : CoprodI G) = (g : CoprodI G)
+    group
+  · intro x
+    induction x using QuotientGroup.induction_on with
+    | H y =>
+      refine ⟨⟨(((transl hD (Vertex.mk 0 y⁻¹))⁻¹ : H) : CoprodI G) * y⁻¹, ?_⟩, ?_⟩
+      · refine mem_of_transl_eq_one hD ?_
+        rw [transl_mk_mul hD hfree, inv_mul_cancel]
+      · refine (QuotientGroup.eq).mpr ?_
+        change (((((transl hD (Vertex.mk 0 y⁻¹))⁻¹ : H) : CoprodI G) * y⁻¹)⁻¹)⁻¹ * y ∈ H
+        rw [inv_inv, mul_assoc, inv_mul_cancel, mul_one]
+        exact SetLike.coe_mem _
+
+theorem nat_card_baseRep (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1) :
+    Nat.card (baseRep H hD) = H.index := by
+  rw [Nat.card_congr (baseRepEquivQuotient hD hfree), Subgroup.index_eq_card]
+
+theorem finite_baseRep [H.FiniteIndex]
+    (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1) :
+    Finite (baseRep H hD) :=
+  Finite.of_equiv _ (baseRepEquivQuotient hD hfree).symm
+
+include hD in
+noncomputable def transversalEquivOrbits :
+    D ≃ MulAction.orbitRel.Quotient H (Vertex G) := by
+  refine Equiv.ofBijective (fun d => Quotient.mk'' (d : Vertex G)) ⟨?_, ?_⟩
+  · intro d d' hdd'
+    exact Subtype.ext (hD.eq_of_mem_orbit _ d.2 _ d'.2 (Quotient.exact' hdd'))
+  · intro x
+    induction x using Quotient.inductionOn' with
+    | h v =>
+      obtain ⟨d, hd, hdorb⟩ := hD.exists_mem_orbit v
+      exact ⟨⟨d, hd⟩, Quotient.sound' hdorb⟩
+
+include hD in
+theorem nat_card_transversal :
+    Nat.card D = Nat.card (MulAction.orbitRel.Quotient H (Vertex G)) :=
+  Nat.card_congr (transversalEquivOrbits hD)
+
+include hD in
+theorem connected_induce_transversal : ((graph G).induce D).Connected := by
+  obtain ⟨d₀, hd₀, -⟩ := hD.exists_mem_orbit (Vertex.mk 0 1)
+  have : Nonempty D := ⟨⟨d₀, hd₀⟩⟩
+  refine (connected_iff _).mpr ⟨?_, inferInstance⟩
+  rintro ⟨v, hv⟩ ⟨w, hw⟩
+  obtain ⟨p, hp⟩ := hD.walkConnected v hv w hw
+  exact ⟨p.induce D hp⟩
+
+theorem isAcyclic_induce_transversal : ((graph G).induce D).IsAcyclic := by
+  intro v c hc
+  exact isAcyclic_two (c.map (SimpleGraph.Embedding.induce D).toHom)
+    (hc.map Subtype.val_injective)
+
+noncomputable def treeRepEquivEdgeSet
+    (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1) :
+    treeRep H hD ≃ ((graph G).induce D).edgeSet := by
+  refine Equiv.ofBijective (fun g =>
+    ⟨s((⟨Vertex.mk 0 (g : CoprodI G), g.2.1⟩ : D),
+       (⟨Vertex.mk 1 (g : CoprodI G), mk_one_mem_of_mem_treeRep hD hfree g.2⟩ : D)),
+     adj_mk (by decide : (0 : Fin 2) ≠ 1) (g : CoprodI G)⟩) ⟨?_, ?_⟩
+  · intro g g' hgg'
+    rw [Subtype.mk.injEq, Sym2.eq_iff] at hgg'
+    rcases hgg' with ⟨h1, h2⟩ | ⟨h1, h2⟩
+    · exact Subtype.ext (eq_of_mk_eq_mk (by decide : (0 : Fin 2) ≠ 1)
+        (congrArg Subtype.val h1) (congrArg Subtype.val h2))
+    · have hcon : (0 : Fin 2) = 1 := congrArg (fun v => (Subtype.val v).1) h1
+      exact absurd hcon (by decide)
+  · rintro ⟨e, he⟩
+    revert he
+    induction e using Sym2.ind with
+    | _ u w =>
+      intro he
+      obtain ⟨hne, g, hgu, hgw⟩ := (he : ((graph G).induce D).Adj u w)
+      rcases (by decide : ∀ a b : Fin 2, a ≠ b → a = 0 ∧ b = 1 ∨ a = 1 ∧ b = 0)
+        _ _ hne with ⟨h1, h2⟩ | ⟨h1, h2⟩
+      · rw [h1] at hgu
+        rw [h2] at hgw
+        refine ⟨⟨g, mem_treeRep_of_mk_one_mem hD hfree (by rw [hgu]; exact u.2)
+          (by rw [hgw]; exact w.2)⟩, ?_⟩
+        refine Subtype.ext (Sym2.eq_iff.mpr (Or.inl ⟨?_, ?_⟩))
+        · exact Subtype.ext hgu
+        · exact Subtype.ext hgw
+      · rw [h1] at hgu
+        rw [h2] at hgw
+        refine ⟨⟨g, mem_treeRep_of_mk_one_mem hD hfree (by rw [hgw]; exact w.2)
+          (by rw [hgu]; exact u.2)⟩, ?_⟩
+        refine Subtype.ext (Sym2.eq_iff.mpr (Or.inr ⟨?_, ?_⟩))
+        · exact Subtype.ext hgw
+        · exact Subtype.ext hgu
+
+theorem nat_card_treeRep_add_one [H.FiniteIndex]
+    (hfree : ∀ h ∈ H, ∀ v : Vertex G, h • v = v → h = 1) :
+    Nat.card (treeRep H hD) + 1 = Nat.card D := by
+  classical
+  have hfree' := forall_smul_eq_of_forall_mem hfree
+  have : Finite (MulAction.orbitRel.Quotient H (Vertex G)) :=
+    FreeActionTree.finite_vertexOrbits H (conjTrivial_iff_forall_smul_ne.mpr hfree)
+  have : Finite D := Finite.of_equiv _ (transversalEquivOrbits hD).symm
+  have : Fintype D := Fintype.ofFinite _
+  have : Fintype ((graph G).induce D).edgeSet := Set.Finite.fintype (Set.toFinite _)
+  have hcount := SimpleGraph.IsTree.card_edgeFinset
+    ⟨connected_induce_transversal hD, isAcyclic_induce_transversal⟩
+  rw [SimpleGraph.edgeFinset_card] at hcount
+  rw [Nat.card_congr (treeRepEquivEdgeSet hD hfree'), Nat.card_eq_fintype_card,
+    Nat.card_eq_fintype_card]
+  exact hcount
+
+theorem nat_card_nonTreeRep [H.FiniteIndex]
+    (hfree : ∀ h ∈ H, ∀ v : Vertex G, h • v = v → h = 1) :
+    Nat.card (nonTreeRep H hD) =
+      1 + H.index - Nat.card (MulAction.orbitRel.Quotient H (Vertex G)) := by
+  have hfree' := forall_smul_eq_of_forall_mem hfree
+  have := finite_baseRep hD hfree'
+  have hsub : nonTreeRep H hD ⊆ baseRep H hD := fun g hg => hg.1
+  have hdiff : baseRep H hD \ nonTreeRep H hD = treeRep H hD := by
+    ext g
+    simp only [Set.mem_sdiff, baseRep, nonTreeRep, treeRep, Set.mem_ofPred_eq, not_and, not_not]
+    exact ⟨fun ⟨hg, hg'⟩ => ⟨hg, hg' hg⟩, fun ⟨hg, hg'⟩ => ⟨hg, fun _ => hg'⟩⟩
+  have hpart := Set.ncard_sdiff_add_ncard_of_subset hsub (Set.toFinite _)
+  rw [hdiff] at hpart
+  rw [← Nat.card_coe_set_eq, ← Nat.card_coe_set_eq, ← Nat.card_coe_set_eq] at hpart
+  have htree := nat_card_treeRep_add_one hD hfree
+  have hbase := nat_card_baseRep hD hfree'
+  have hvert := nat_card_transversal hD
+  omega
+
+theorem finite_nonTreeRep [H.FiniteIndex]
+    (hfree : ∀ (η : H) (v : Vertex G), η • v = v → η = 1) :
+    Finite (nonTreeRep H hD) :=
+  haveI := finite_baseRep hD hfree
+  Finite.Set.subset (baseRep H hD) (fun _ hg => hg.1)
+
+end BassSerre
+end GroupTheory
+
+namespace GroupTheory
+
+namespace FreeActionTree
+
+open BassSerre
+
+theorem freeActionRankFormula (G : Fin 2 → Type*) [∀ i, Group (G i)] :
+    FreeActionRankFormula G := by
+  intro H hFI hfree
+  have := hFI
+  obtain ⟨D, -, hD⟩ := exists_transversal H (Vertex.mk 0 1)
+  have hfree' := forall_smul_eq_of_forall_mem hfree
+  have := finite_nonTreeRep hD hfree'
+  obtain ⟨n, ⟨e⟩⟩ := Finite.exists_equiv_fin (nonTreeRep H hD)
+  have hn : n = 1 + H.index - Nat.card (MulAction.orbitRel.Quotient H (Vertex G)) := by
+    rw [← Nat.card_eq_of_equiv_fin e, nat_card_nonTreeRep hD hfree]
+  exact ⟨(freeGroupBasis hD hfree').reindex (e.trans (finCongr hn))⟩
+
+end FreeActionTree
+
+namespace Kurosh
+
+theorem kuroshRankFormula (G : Fin 2 → Type*) [∀ i, Group (G i)] [∀ i, Finite (G i)] :
+    KuroshRankFormula G :=
+  FreeActionTree.kuroshRankFormula_of_freeActionRankFormula
+    (FreeActionTree.freeActionRankFormula G)
+
+end Kurosh
+end GroupTheory
+
+theorem solution {G : Fin 2 → Type*} [∀ i, Group (G i)] [∀ i, Finite (G i)]
+    (H : Subgroup (Monoid.CoprodI G)) [H.FiniteIndex]
+    (hH : ∀ (i : Fin 2) (g : Monoid.CoprodI G) (x : G i), g⁻¹ * Monoid.CoprodI.of x * g ∈ H → x = 1)
+      :
+    Nonempty (FreeGroupBasis
+      (Fin (1 + H.index - H.index / Nat.card (G 0) - H.index / Nat.card (G 1))) H) := by
+  have hCT : ∀ i, GroupTheory.Kurosh.ConjTrivial (Monoid.CoprodI.of (M := G) (i := i)).range H := by
+    rintro i g x ⟨a, rfl⟩ h
+    rw [hH i g a h, map_one]
+  exact GroupTheory.Kurosh.kuroshRankFormula G H inferInstance hCT
+
+end S_Monoid_CoprodI_nonempty_freeGroupBasis_fin_kuroshRank
+end P2MW
+export P2MW.S_Monoid_CoprodI_nonempty_freeGroupBasis_fin_kuroshRank (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem Monoid.CoprodI.nonempty_freeGroupBasis_fin_kuroshRank {G : Fin 2 → Type*} [∀ i, Group (G i)]
+    [∀ i, Finite (G i)]
+    (H : Subgroup (Monoid.CoprodI G)) [H.FiniteIndex]
+    (hH : ∀ (i : Fin 2) (g : Monoid.CoprodI G) (x : G i), g⁻¹ * Monoid.CoprodI.of x * g ∈ H → x = 1)
+      :
+    Nonempty (FreeGroupBasis
+      (Fin (1 + H.index - H.index / Nat.card (G 0) - H.index / Nat.card (G 1))) H) :=
+  solution H hH
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_MulAction_card_mul_natCard_orbitRel_quotient_eq_of_natCard_eq_prime.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_MulAction_card_mul_natCard_orbitRel_quotient_eq_of_natCard_eq_prime.lean
new file mode 100644
index 0000000000..f33805b2a2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_MulAction_card_mul_natCard_orbitRel_quotient_eq_of_natCard_eq_prime.lean
@@ -0,0 +1,118 @@
+/-
+Based on Prove2Me node MulAction.card_mul_natCard_orbitRel_quotient_eq_of_natCard_eq_prime
+(066fb680-60a4-5e46-ac13-417af1e630b1) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 23344518-361b-5787-9abb-031c6df7519d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Data.Nat.Prime.Defs
+public import Mathlib.GroupTheory.GroupAction.Defs
+public import Mathlib.SetTheory.Cardinal.Finite
+
+import Mathlib.Data.ZMod.QuotientGroup
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Orbit count for an action of a group of prime order
+
+Theorem statement: `MulAction.card_mul_natCard_orbitRel_quotient_eq_of_natCard_eq_prime`
+(`066fb680-60a4-5e46-ac13-417af1e630b1`), by Claude, 2026-09-05.
+
+Proof: submission `23344518-361b-5787-9abb-031c6df7519d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $G$ be a group and $X$ a type carrying a multiplicative $G$-action, with both $G$ and $X$
+finite, and let $p$ be a prime natural number such that the number of elements of $G$ equals $p$.
+The conclusion is the identity of natural numbers $$p \cdot
+\#\bigl(\mathrm{MulAction.orbitRel.Quotient}\ G\ X\bigr) \;=\; \#X + (p-1)\cdot
+\#\bigl(\mathrm{MulAction.fixedPoints}\ G\ X\bigr),$$ where each $\#$ denotes the natural-number
+cardinality of a finite type: the first of the quotient of $X$ by the orbit equivalence relation,
+i.e. of the set of $G$-orbits; the second of $X$ itself; the third of the subtype of those $x \in X$
+with $g \bullet x = x$ for every $g \in G$. The subtraction $p-1$ is truncated subtraction in
+$\mathbb{N}$, which is harmless since $p \ge 2$. Equivalently, since every orbit has size $1$ or $p$
+and the singleton orbits are exactly the points fixed by all of $G$, the number of orbits equals
+$\#X^G + (\#X - \#X^G)/p$.
+
+This is Burnside's orbit-counting lemma specialised to a group of prime order, where the only
+possible orbit sizes are $1$ and $p$. It is used in the counting of elliptic points on modular
+curves, for instance in the double counts relating the number of moduli points with $j = 0$ to the
+Dedekind $\psi$ function and $\nu_3(N)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_MulAction_card_mul_natCard_orbitRel_quotient_eq_of_natCard_eq_prime.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_MulAction_card_mul_natCard_orbitRel_quotient_eq_of_natCard_eq_prime
+
+open MulAction in
+theorem solution
+    (G : Type*) {X : Type*} [Group G] [MulAction G X] [Finite G] [Finite X]
+    {p : ℕ} (hp : p.Prime) (hG : Nat.card G = p) :
+    p * Nat.card (MulAction.orbitRel.Quotient G X)
+      = Nat.card X + (p - 1) * Nat.card (MulAction.fixedPoints G X) := by
+  classical
+  have : Fintype G := Fintype.ofFinite G
+  have : Fintype X := Fintype.ofFinite X
+  have hGc : Fintype.card G = p := by rw [← Nat.card_eq_fintype_card]; exact hG
+  have hfix : ∀ g : G, g ≠ 1 → fixedBy X g = fixedPoints G X := by
+    intro g hg
+    have hord : orderOf g = p := by
+      have hdvd : orderOf g ∣ p := hG ▸ orderOf_dvd_natCard g
+      rcases (Nat.dvd_prime hp).mp hdvd with h1 | h
+      · exact absurd (orderOf_eq_one_iff.mp h1) hg
+      · exact h
+    have hgen : Subgroup.zpowers g = ⊤ := by
+      apply Subgroup.eq_top_of_card_eq
+      rw [Nat.card_zpowers, hord, hG]
+    ext x
+    simp only [mem_fixedBy, mem_fixedPoints]
+    constructor
+    · intro hx h
+      have hle : Subgroup.zpowers g ≤ stabilizer G x := by
+        rw [Subgroup.zpowers_le]; exact hx
+      exact hle (by rw [hgen]; exact Subgroup.mem_top h)
+    · intro hx; exact hx g
+  have c1 : Fintype.card (fixedBy X (1 : G)) = Fintype.card X :=
+    Fintype.card_congr (Equiv.subtypeUnivEquiv (fun x => show x ∈ fixedBy X (1 : G) from one_smul G
+      x))
+  have cg : ∀ g : G, g ≠ 1 → Fintype.card (fixedBy X g) = Fintype.card (fixedPoints G X) :=
+    fun g hg => Fintype.card_congr (Set.equivOfEq (hfix g hg))
+  have hB := sum_card_fixedBy_eq_card_orbits_mul_card_group G X
+  rw [← Finset.add_sum_erase _ _ (Finset.mem_univ (1 : G)), c1,
+    Finset.sum_congr rfl (fun g hg => cg g (Finset.ne_of_mem_erase hg)),
+    Finset.sum_const, smul_eq_mul, Finset.card_erase_of_mem (Finset.mem_univ _),
+    Finset.card_univ, hGc] at hB
+  rw [Nat.card_eq_fintype_card, Nat.card_eq_fintype_card, Nat.card_eq_fintype_card]
+  convert hB.symm using 1
+  all_goals (first | exact mul_comm _ _ )
+
+end S_MulAction_card_mul_natCard_orbitRel_quotient_eq_of_natCard_eq_prime
+end P2MW
+export P2MW.S_MulAction_card_mul_natCard_orbitRel_quotient_eq_of_natCard_eq_prime (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem MulAction.card_mul_natCard_orbitRel_quotient_eq_of_natCard_eq_prime
+    (G : Type*) {X : Type*} [Group G] [MulAction G X] [Finite G] [Finite X]
+    {p : ℕ} (hp : p.Prime) (hG : Nat.card G = p) :
+    p * Nat.card (MulAction.orbitRel.Quotient G X)
+      = Nat.card X + (p - 1) * Nat.card (MulAction.fixedPoints G X) :=
+  solution G hp hG
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_MvPolynomial_IsHomogeneous_iterate_pderiv_eq_zero_of_lt.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_MvPolynomial_IsHomogeneous_iterate_pderiv_eq_zero_of_lt.lean
new file mode 100644
index 0000000000..36970de5bd
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_MvPolynomial_IsHomogeneous_iterate_pderiv_eq_zero_of_lt.lean
@@ -0,0 +1,102 @@
+/-
+Based on Prove2Me node MvPolynomial.IsHomogeneous.iterate_pderiv_eq_zero_of_lt
+(6acf2c45-10bd-553c-81b2-a6163bfe51ad) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6026d3ff-85d3-50dd-bcae-ee5de615de95
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.MvPolynomial.PDeriv
+public import Mathlib.RingTheory.MvPolynomial.Homogeneous
+
+import Mathlib.RingTheory.MvPolynomial.EulerIdentity
+
+/-!
+# Iterated partial derivatives of order >n annihilate degree-n forms
+
+Theorem statement: `MvPolynomial.IsHomogeneous.iterate_pderiv_eq_zero_of_lt`
+(`6acf2c45-10bd-553c-81b2-a6163bfe51ad`), by Claude, 2026-09-05.
+
+Proof: submission `6026d3ff-85d3-50dd-bcae-ee5de615de95`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative semiring and $\sigma$ an arbitrary type of variables, and let $\varphi \in
+R[X_s : s \in \sigma]$ be a multivariate polynomial. Assume $\varphi$ is homogeneous of degree $n$
+in the sense of Mathlib's `MvPolynomial.IsHomogeneous`, i.e. every monomial occurring in $\varphi$
+with nonzero coefficient has total degree $n$. Let $k \in \sigma$ be one of the variables, and let
+$i$ be a natural number with $n < i$. The conclusion is that the $i$-fold iterate of the partial
+derivative operator $\partial/\partial X_k$, applied to $\varphi$, is the zero polynomial:
+$(\mathrm{pderiv}\ k)^{[i]} \varphi = 0$. Note that only the single variable $k$ is differentiated
+repeatedly, and that the statement holds over an arbitrary commutative semiring, with no finiteness
+assumption on the set $\sigma$ of variables.
+
+This is the elementary fact that a homogeneous polynomial of degree $n$ is annihilated by any $n+1$
+iterated derivatives in a single variable. It is used in the treatment of Eichler integrals and the
+Bol identity, where it shows that the rung above the top of the differentiation ladder vanishes; it
+is cited by
+[`HeckeEis.IsEichlerIntegral.eq_zero_of_eval_eq_const`]
+(thm.html#HeckeEis.IsEichlerIntegral.eq_zero_of_eval_eq_const)
+and
+[`HeckeEis.IsEichlerIntegral.isBoundedAtImInfty_eval`]
+(thm.html#HeckeEis.IsEichlerIntegral.isBoundedAtImInfty_eval).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_MvPolynomial_IsHomogeneous_iterate_pderiv_eq_zero_of_lt.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace MvPolynomial
+namespace DegAux
+open MvPolynomial
+
+open MvPolynomial
+
+theorem isHomogeneous_iterate_pderiv
+    {σ R : Type*} [CommSemiring R] {φ : MvPolynomial σ R} {n : ℕ} (k : σ)
+    (hφ : φ.IsHomogeneous n) (j : ℕ) : ((pderiv k)^[j] φ).IsHomogeneous (n - j) := by
+  induction j with
+  | zero => simpa using hφ
+  | succ j ih =>
+    rw [Function.iterate_succ_apply']
+    simpa [Nat.sub_sub] using ih.pderiv
+
+theorem iterate_pderiv_eq_zero_of_lt {σ R : Type*} [CommSemiring R] {φ : MvPolynomial σ R} {n : ℕ}
+    (hφ : φ.IsHomogeneous n) (k : σ) {i : ℕ} (hi : n < i) : (pderiv k)^[i] φ = 0 := by
+  obtain ⟨m, rfl⟩ := Nat.exists_eq_add_of_lt hi
+  rw [show n + m + 1 = m + 1 + n by ring, Function.iterate_add_apply,
+    Function.iterate_succ_apply]
+  have h0 : ((pderiv k)^[n] φ).IsHomogeneous 0 := by
+    simpa using isHomogeneous_iterate_pderiv k hφ n
+  have hC : (pderiv k)^[n] φ = C (AddMonoidAlgebra.coeff ((pderiv k)^[n] φ) 0) :=
+    totalDegree_eq_zero_iff_eq_C.mp (Nat.eq_zero_of_le_zero h0.totalDegree_le)
+  rw [hC, pderiv_C]
+  exact Function.iterate_fixed (map_zero _) m
+
+end MvPolynomial.DegAux
+
+theorem solution {σ R : Type*} [CommSemiring R] {φ : MvPolynomial σ R}
+    {n : ℕ} (hφ : φ.IsHomogeneous n) (k : σ) {i : ℕ} (hi : n < i) :
+    (MvPolynomial.pderiv k)^[i] φ = 0 :=
+  MvPolynomial.DegAux.iterate_pderiv_eq_zero_of_lt hφ k hi
+
+end privateSection
+
+public section publicSection
+
+theorem MvPolynomial.IsHomogeneous.iterate_pderiv_eq_zero_of_lt
+    {σ R : Type*} [CommSemiring R] {φ : MvPolynomial σ R}
+    {n : ℕ} (hφ : φ.IsHomogeneous n) (k : σ) {i : ℕ} (hi : n < i) :
+    (MvPolynomial.pderiv k)^[i] φ = 0 := by
+  exact solution hφ k hi
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Nat_exists_squarefree_sq_add.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Nat_exists_squarefree_sq_add.lean
new file mode 100644
index 0000000000..2b6beecf24
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Nat_exists_squarefree_sq_add.lean
@@ -0,0 +1,359 @@
+/-
+Based on Prove2Me node Nat.exists_squarefree_sq_add
+(cc2c6b12-9479-5ff7-8420-6713a3e98239) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission cb36fccd-3246-5e80-8101-644646652259
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Squarefree.Basic
+
+import Mathlib.Algebra.Field.ZMod
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Analysis.PSeries
+import Mathlib.Data.Int.Star
+import Mathlib.Data.Nat.Prime.Int
+import Mathlib.NumberTheory.Chebyshev
+import Mathlib.Tactic.NormNum.Prime
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Squarefree values of c² + D
+
+Theorem statement: `Nat.exists_squarefree_sq_add` (`cc2c6b12-9479-5ff7-8420-6713a3e98239`), by
+Claude, 2026-09-05.
+
+Proof: submission `cb36fccd-3246-5e80-8101-644646652259`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $D$ be a natural number with $1 \le D$. The assertion is that there exists a natural number $c$
+with $1 \le c$ such that $c^2 + D$ is squarefree in the sense of Mathlib's `Squarefree` predicate
+for the monoid $\mathbb{N}$, namely that every natural number whose square divides $c^2 + D$ is a
+unit, i.e. equal to $1$. Only existence of one such $c$ is claimed; no bound on $c$, no density
+statement, and no information about the multiplicative structure of $c^2 + D$ beyond squarefreeness.
+The hypothesis $1 \le D$ excludes $D = 0$, for which the conclusion would fail since $c^2$ is never
+squarefree for $c \ge 1$ (indeed $c \ge 2$; and $c = 1$ gives $1$, which is squarefree, so the
+restriction is genuinely needed only in the stated uniform form).
+
+This is the existence half of the degree-two case of the classical result of Estermann on squarefree
+values of quadratic polynomials; here the polynomial is $X^2 + D$ in the shifted form required
+later. It is used by
+[`Int.exists_squarefree_sq_add_mul_add_mul_sq_of_sq_lt_four_mul`]
+(thm.html#Int.exists_squarefree_sq_add_mul_add_mul_sq_of_sq_lt_four_mul),
+which produces squarefree values of a positive definite integral binary quadratic form and thereby
+supplies the auxiliary squarefree integers needed in the imaginary quadratic norm representation
+step.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Nat_exists_squarefree_sq_add.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_Nat_exists_squarefree_sq_add
+
+
+noncomputable section
+
+namespace K2Seam3
+namespace SqfreeSieve
+
+abbrev KwExistsSqfreeSqAdd : Prop :=
+  ∀ D : ℕ, 1 ≤ D → ∃ c : ℕ, 1 ≤ c ∧ Squarefree (c ^ 2 + D)
+
+section Sieve
+
+p2m_open "Finset Nat Finset.Nat Real Filter"
+
+lemma kw_psq_dvd_of_not_dvd {p : ℕ} (hp : p.Prime) {a b : ℤ}
+    (ha : ¬ (p : ℤ) ∣ a) (hab : (p : ℤ) ^ 2 ∣ a * b) : (p : ℤ) ^ 2 ∣ b := by
+  have hpZ : Prime (p : ℤ) := Nat.prime_iff_prime_int.mp hp
+  have hpb : (p : ℤ) ∣ b :=
+    (hpZ.dvd_mul.mp (dvd_trans ⟨(p : ℤ), (sq (p : ℤ))⟩ hab)).resolve_left ha
+  obtain ⟨c, rfl⟩ := hpb
+  rw [show a * ((p : ℤ) * c) = (p : ℤ) * (a * c) by ring, sq] at hab
+  have hpac := (mul_dvd_mul_iff_left (a := (p : ℤ))
+    (by exact_mod_cast hp.ne_zero)).mp hab
+  obtain ⟨d, rfl⟩ := (hpZ.dvd_mul.mp hpac).resolve_left ha
+  exact ⟨d, by ring⟩
+
+lemma kw_sqAdd_pm_congr {p D : ℕ} (hp : p.Prime) (hp2 : p ≠ 2) (hpD : ¬ p ∣ D)
+    {x y : ℤ} (hx : (p : ℤ) ^ 2 ∣ x ^ 2 + D) (hy : (p : ℤ) ^ 2 ∣ y ^ 2 + D) :
+    (p : ℤ) ^ 2 ∣ (x - y) ∨ (p : ℤ) ^ 2 ∣ (x + y) := by
+  have hpZ : Prime (p : ℤ) := Nat.prime_iff_prime_int.mp hp
+  have hdiff : (p : ℤ) ^ 2 ∣ (x - y) * (x + y) := by
+    have h := dvd_sub hx hy
+    have heq : x ^ 2 + (D : ℤ) - (y ^ 2 + D) = (x - y) * (x + y) := by ring
+    rwa [heq] at h
+  have hnx : ¬ (p : ℤ) ∣ x := fun hd => hpD <| by
+    have hpxD : (p : ℤ) ∣ x ^ 2 + D := dvd_trans ⟨(p : ℤ), (sq (p : ℤ))⟩ hx
+    have hpD' : (p : ℤ) ∣ (D : ℤ) := by
+      have := dvd_sub hpxD (dvd_pow hd two_ne_zero); simpa using this
+    exact_mod_cast hpD'
+  by_cases hxmy : (p : ℤ) ∣ (x - y)
+  · by_cases hxpy : (p : ℤ) ∣ (x + y)
+    · exfalso
+      have h2x : (p : ℤ) ∣ 2 * x := by
+        have := dvd_add hxmy hxpy; simpa [two_mul] using this
+      rcases hpZ.dvd_mul.mp h2x with h2 | hx'
+      · exact hp2 ((Nat.prime_dvd_prime_iff_eq hp Nat.prime_two).mp (by exact_mod_cast h2))
+      · exact hnx hx'
+    · exact Or.inl (kw_psq_dvd_of_not_dvd hp hxpy (by rwa [mul_comm] at hdiff))
+  · exact Or.inr (kw_psq_dvd_of_not_dvd hp hxmy hdiff)
+
+lemma kw_perPrime_count {D K p : ℕ} (hp : p.Prime) (hp3 : 3 ≤ p)
+    (hpD : ¬ p ∣ D) :
+    ((Finset.range K).filter (fun k => p ^ 2 ∣ (2*D*k + D + 1) ^ 2 + D)).card
+      ≤ 2 * (K / p ^ 2 + 1) := by
+  classical
+  set c : ℕ → ℤ := fun k => (2*D*k + D + 1 : ℤ) with hc_def
+  set Bad := (Finset.range K).filter (fun k => p ^ 2 ∣ (2*D*k + D + 1) ^ 2 + D) with hBad_def
+  rcases Bad.eq_empty_or_nonempty with hemp | ⟨k₀, hk₀⟩
+  · rw [hemp]; simp
+  have hp2pos : 0 < p ^ 2 := by positivity
+  have hp2 : p ≠ 2 := by omega
+  have hp2D : ¬ (p : ℤ) ∣ (2 * D : ℤ) := fun h => by
+    rcases (Nat.prime_iff_prime_int.mp hp).dvd_mul.mp h with h2 | hd
+    · exact hp2 ((Nat.prime_dvd_prime_iff_eq hp Nat.prime_two).mp (by exact_mod_cast h2))
+    · exact hpD (by exact_mod_cast hd)
+  have hceq : ∀ k, (c k) ^ 2 + (D:ℤ) = (((2*D*k + D + 1) ^ 2 + D : ℕ) : ℤ) := fun k => by
+    simp only [c]; push_cast; ring
+  have hfc : ∀ k, p ^ 2 ∣ (2*D*k + D + 1) ^ 2 + D ↔ (p:ℤ) ^ 2 ∣ (c k) ^ 2 + D := fun k => by
+    rw [hceq, show ((p:ℤ) ^ 2) = ((p ^ 2:ℕ):ℤ) by push_cast; ring]
+    exact Int.natCast_dvd_natCast.symm
+  have hk₀' : (p:ℤ) ^ 2 ∣ (c k₀) ^ 2 + D := (hfc k₀).mp (Finset.mem_filter.mp hk₀).2
+  let g : ℕ → Bool × ℕ := fun k => (decide ((p:ℤ) ^ 2 ∣ c k - c k₀), k / p ^ 2)
+  have hinj : Set.InjOn g Bad := by
+    intro a haB b hbB hab
+    simp only [g, Prod.mk.injEq, decide_eq_decide] at hab
+    obtain ⟨hd, hq⟩ := hab
+    have ha' := (hfc a).mp (Finset.mem_filter.mp haB).2
+    have hb' := (hfc b).mp (Finset.mem_filter.mp hbB).2
+    have hda := kw_sqAdd_pm_congr hp hp2 hpD ha' hk₀'
+    have hdb := kw_sqAdd_pm_congr hp hp2 hpD hb' hk₀'
+    have hcab : (p:ℤ) ^ 2 ∣ c a - c b := by
+      by_cases hca : (p:ℤ) ^ 2 ∣ c a - c k₀
+      · have hcb : (p:ℤ) ^ 2 ∣ c b - c k₀ := hd.mp hca
+        have := dvd_sub hca hcb; simpa using this
+      · have hca' : (p:ℤ) ^ 2 ∣ c a + c k₀ := hda.resolve_left hca
+        have hcb' : (p:ℤ) ^ 2 ∣ c b + c k₀ := hdb.resolve_left (fun h => hca (hd.mpr h))
+        have := dvd_sub hca' hcb'; simpa using this
+    have hcabeq : c a - c b = (2*D : ℤ) * ((a:ℤ) - b) := by
+      simp only [c]; ring
+    rw [hcabeq] at hcab
+    have hkab : (p:ℤ) ^ 2 ∣ ((a:ℤ) - b) := kw_psq_dvd_of_not_dvd hp hp2D hcab
+    have h1 := Nat.div_add_mod a (p ^ 2)
+    have h2 := Nat.div_add_mod b (p ^ 2)
+    have heq : (a:ℤ) - b = ((a % p ^ 2 : ℕ) : ℤ) - ((b % p ^ 2 : ℕ) : ℤ) := by
+      set Q : ℕ := p ^ 2 * (a / p ^ 2) with hQ
+      have hQb : p ^ 2 * (b / p ^ 2) = Q := by rw [hQ, hq]
+      have hZ1 : (a:ℤ) = (Q:ℤ) + ((a % p ^ 2 : ℕ):ℤ) := by exact_mod_cast h1.symm
+      have hZ2 : (b:ℤ) = (Q:ℤ) + ((b % p ^ 2 : ℕ):ℤ) := by
+        rw [← hQb] at hQ ⊢; exact_mod_cast h2.symm
+      linarith
+    rw [heq] at hkab
+    obtain ⟨m, hm⟩ := hkab
+    have ha' : ((a % p ^ 2 : ℕ):ℤ) < ((p ^ 2:ℕ):ℤ) := by exact_mod_cast Nat.mod_lt a hp2pos
+    have hb' : ((b % p ^ 2 : ℕ):ℤ) < ((p ^ 2:ℕ):ℤ) := by exact_mod_cast Nat.mod_lt b hp2pos
+    have ha0 : (0:ℤ) ≤ ((a % p ^ 2 : ℕ):ℤ) := Int.natCast_nonneg _
+    have hb0 : (0:ℤ) ≤ ((b % p ^ 2 : ℕ):ℤ) := Int.natCast_nonneg _
+    have hpc : ((p ^ 2:ℕ):ℤ) = (p:ℤ) ^ 2 := by push_cast; ring
+    have hm0 : m = 0 := by
+      rcases lt_trichotomy m 0 with hneg | h0 | hpos
+      · exfalso; nlinarith [hm, hpc]
+      · exact h0
+      · exfalso; nlinarith [hm, hpc]
+    have hmodeq : a % p ^ 2 = b % p ^ 2 := by
+      have : ((a % p ^ 2 : ℕ):ℤ) = ((b % p ^ 2 : ℕ):ℤ) := by rw [hm0, mul_zero] at hm; linarith
+      exact_mod_cast this
+    omega
+  calc Bad.card
+      ≤ ((Finset.univ : Finset Bool) ×ˢ Finset.range (K / p ^ 2 + 1)).card := by
+        apply Finset.card_le_card_of_injOn g ?_ hinj
+        intro k hk
+        have hkK : k < K := Finset.mem_range.mp (Finset.mem_filter.mp hk).1
+        have hdiv : k / p ^ 2 ≤ K / p ^ 2 := Nat.div_le_div_right (le_of_lt hkK)
+        refine Finset.mem_product.mpr ⟨Finset.mem_univ _, ?_⟩
+        simp only [g, Finset.mem_range]; omega
+    _ = 2 * (K / p ^ 2 + 1) := by
+        rw [Finset.card_product, Finset.card_range, Finset.card_univ, Fintype.card_bool]
+
+lemma kw_four_not_dvd_f (D k : ℕ) : ¬ (4 : ℕ) ∣ ((2*D*k + D + 1) ^ 2 + D) := by
+  have hexp : (2*D*k + D + 1) ^ 2 + D = 4*(D ^ 2*k ^ 2 + D ^ 2*k + D*k) + (D ^ 2 + 3*D + 1) :=
+    by ring
+  intro h; rw [hexp] at h
+  have h4 : (4 : ℕ) ∣ (D ^ 2 + 3*D + 1) := (Nat.dvd_add_right ⟨_, rfl⟩).mp h
+  have hZ : ((D:ZMod 4) ^ 2 + 3*(D:ZMod 4) + 1 : ZMod 4) = 0 := by
+    have := (ZMod.natCast_eq_zero_iff (D ^ 2 + 3*D + 1) 4).mpr h4
+    push_cast at this; linear_combination this
+  exact (by decide : ∀ d : ZMod 4, d ^ 2 + 3*d + 1 ≠ 0) _ hZ
+
+lemma kw_primeDvdD_not_dvd_f {D p : ℕ} (k : ℕ) (hp : p.Prime) (hpD : p ∣ D) :
+    ¬ p ∣ ((2*D*k + D + 1) ^ 2 + D) := by
+  have := Fact.mk hp
+  intro h
+  have hZ : (((2*D*k + D + 1) ^ 2 + D : ℕ) : ZMod p) = 0 := (ZMod.natCast_eq_zero_iff _ p).mpr h
+  have hDZ : ((D : ℕ) : ZMod p) = 0 := (ZMod.natCast_eq_zero_iff _ p).mpr hpD
+  push_cast at hZ
+  rw [hDZ] at hZ; ring_nf at hZ
+  exact one_ne_zero hZ
+
+theorem kw_existsSqfreeSqAdd_proved : KwExistsSqfreeSqAdd := by
+  intro D hD
+  set f : ℕ → ℕ := fun k => (2*D*k + D + 1) ^ 2 + D with hf_def
+  suffices h : ∃ k, Squarefree (f k) by
+    obtain ⟨k, hk⟩ := h; exact ⟨2*D*k + D + 1, by omega, hk⟩
+  by_contra hcon; push Not at hcon
+  obtain ⟨N₀, hN₀⟩ :=
+    eventually_atTop.mp (Chebyshev.eventually_primeCounting_le (ε := 1) one_pos)
+  have htend : Tendsto (fun K : ℕ => (3 * D * K : ℝ)) atTop atTop := by
+    refine (tendsto_natCast_atTop_atTop.const_mul_atTop (by positivity : (0:ℝ) < 3*D)).congr ?_
+    intro K; ring
+  obtain ⟨K, hKlog, hKN, hK1⟩ :
+      ∃ K : ℕ, 54 * D * (Real.log 4 + 1) < Real.log (3 * D * K)
+        ∧ max N₀ 3 ≤ (3 * D * K : ℝ) ∧ 1 ≤ K :=
+    (((Real.tendsto_log_atTop.comp htend).eventually_gt_atTop _).and
+      ((htend.eventually_ge_atTop (max N₀ 3)).and (eventually_ge_atTop 1))).exists
+  set P := 3 * D * K with hP_def
+  have hPR : (P : ℝ) = 3 * (D : ℝ) * K := by rw [hP_def]; push_cast; ring
+  have hP3 : (3 : ℝ) ≤ (P : ℝ) := by rw [hPR]; exact le_trans (le_max_right _ _) hKN
+  have hPN₀ : N₀ ≤ (P : ℝ) := by rw [hPR]; exact le_trans (le_max_left _ _) hKN
+  have hPnat3 : 3 ≤ P := by exact_mod_cast hP3
+  have hlogP : 0 < Real.log P := Real.log_pos (by linarith)
+  rw [← hPR] at hKlog
+  set S := (Finset.range P).filter (fun p => p.Prime ∧ 3 ≤ p ∧ ¬ p ∣ D) with hS_def
+  have hcov : Finset.range K ⊆ S.biUnion fun p => (Finset.range K).filter (p ^ 2 ∣ f ·) := by
+    intro k hkK
+    have hns := hcon k
+    rw [Nat.squarefree_iff_prime_squarefree] at hns; push Not at hns
+    obtain ⟨p, hp, hdvd⟩ := hns
+    rw [← sq] at hdvd
+    have hp3 : 3 ≤ p := by
+      by_contra h3
+      interval_cases p
+      · exact absurd hp (by decide)
+      · exact absurd hp (by decide)
+      · exact kw_four_not_dvd_f D k (by simpa using hdvd)
+    have hpnD : ¬ p ∣ D := fun hpD =>
+      kw_primeDvdD_not_dvd_f k hp hpD (dvd_trans (dvd_pow_self p two_ne_zero) hdvd)
+    have hpP : p < P := by
+      have hfpos : 0 < f k := by simp only [hf_def]; positivity
+      have hple : p ^ 2 ≤ f k := Nat.le_of_dvd hfpos hdvd
+      have hkK' : k + 1 ≤ K := Finset.mem_range.mp hkK
+      have hck : 2*D*k + D + 2 ≤ P := by nlinarith
+      have hfk : f k < P ^ 2 := by
+        simp only [hf_def]
+        calc (2*D*k+D+1) ^ 2 + D
+            < (2*D*k+D+1) ^ 2 + (2*(2*D*k+D+1) + 1) := by omega
+          _ = (2*D*k+D+2) ^ 2 := by ring
+          _ ≤ P ^ 2 := Nat.pow_le_pow_left hck 2
+      nlinarith [hp.two_le]
+    exact Finset.mem_biUnion.mpr ⟨p,
+      by simp only [S, Finset.mem_filter, Finset.mem_range]; exact ⟨hpP, hp, hp3, hpnD⟩,
+      Finset.mem_filter.mpr ⟨hkK, hdvd⟩⟩
+  have hKle : (K : ℝ) ≤ ∑ p ∈ S, (((Finset.range K).filter (p ^ 2 ∣ f ·)).card : ℝ) := by
+    have h1 : K ≤ ∑ p ∈ S, ((Finset.range K).filter (p ^ 2 ∣ f ·)).card :=
+      calc K = (Finset.range K).card := (Finset.card_range K).symm
+        _ ≤ (S.biUnion fun p => (Finset.range K).filter (p ^ 2 ∣ f ·)).card :=
+            Finset.card_le_card hcov
+        _ ≤ _ := Finset.card_biUnion_le
+    exact_mod_cast h1
+  have hper : ∀ p ∈ S, (((Finset.range K).filter (p ^ 2 ∣ f ·)).card : ℝ)
+      ≤ 2 * K * ((p:ℝ) ^ 2)⁻¹ + 2 := by
+    intro p hpS
+    simp only [S, Finset.mem_filter, Finset.mem_range] at hpS
+    obtain ⟨_, hp, hp3, hpnD⟩ := hpS
+    have hNat : ((Finset.range K).filter (p ^ 2 ∣ f ·)).card ≤ 2 * (K / p ^ 2 + 1) := by
+      simp only [hf_def]; exact kw_perPrime_count hp hp3 hpnD
+    calc (((Finset.range K).filter (p ^ 2 ∣ f ·)).card : ℝ)
+        ≤ (2 * (K / p ^ 2 + 1) : ℕ) := by exact_mod_cast hNat
+      _ = 2 * ((K / p ^ 2 : ℕ) : ℝ) + 2 := by push_cast; ring
+      _ ≤ 2 * ((K : ℝ) / (p ^ 2 : ℕ)) + 2 := by
+          gcongr; exact Nat.cast_div_le
+      _ = 2 * K * ((p:ℝ) ^ 2)⁻¹ + 2 := by push_cast; ring
+  have hSsub : S ⊆ Finset.Ioc 2 P := by
+    intro p hp
+    simp only [S, Finset.mem_filter, Finset.mem_range] at hp
+    simp only [Finset.mem_Ioc]; omega
+  have hsumInv : ∑ p ∈ S, ((p:ℝ) ^ 2)⁻¹ ≤ 4/9 := by
+    calc ∑ p ∈ S, ((p:ℝ) ^ 2)⁻¹
+        ≤ ∑ p ∈ Finset.Ioc 2 P, ((p:ℝ) ^ 2)⁻¹ := by
+          apply Finset.sum_le_sum_of_subset_of_nonneg hSsub
+          intros; positivity
+      _ = ((3:ℝ) ^ 2)⁻¹ + ∑ p ∈ Finset.Ioc 3 P, ((p:ℝ) ^ 2)⁻¹ := by
+          rw [show Finset.Ioc 2 P = insert 3 (Finset.Ioc 3 P) by
+            ext x; simp only [Finset.mem_Ioc, Finset.mem_insert]; omega]
+          rw [Finset.sum_insert (by simp)]; norm_num
+      _ ≤ 1/9 + ((3:ℝ)⁻¹ - (P:ℝ)⁻¹) := by
+          gcongr
+          · norm_num
+          · exact sum_Ioc_inv_sq_le_sub (by norm_num) hPnat3
+      _ ≤ 4/9 := by
+          have hPinv : 0 ≤ (P:ℝ)⁻¹ := by positivity
+          linarith
+  have hScard : (S.card : ℝ) < K / 18 := by
+    have hSle : S.card ≤ P.primeCounting := by
+      calc S.card ≤ ((Finset.range P).filter Nat.Prime).card := by
+            apply Finset.card_le_card; intro p hp
+            simp only [S, Finset.mem_filter, Finset.mem_range] at hp ⊢
+            exact ⟨hp.1, hp.2.1⟩
+        _ = P.primesBelow.card := by rfl
+        _ = P.primeCounting' := Nat.primesBelow_card_eq_primeCounting' P
+        _ = (P - 1).primeCounting := (Nat.primeCounting_sub_one P).symm
+        _ ≤ P.primeCounting := Nat.monotone_primeCounting (Nat.sub_le P 1)
+    have hπ : (P.primeCounting : ℝ) ≤ (Real.log 4 + 1) * P / Real.log P := by
+      have := hN₀ (P : ℝ) hPN₀
+      simpa using this
+    calc (S.card : ℝ) ≤ P.primeCounting := by exact_mod_cast hSle
+      _ ≤ (Real.log 4 + 1) * P / Real.log P := hπ
+      _ < K / 18 := by
+          rw [div_lt_div_iff₀ hlogP (by norm_num : (0:ℝ) < 18)]
+          have hl4 : 0 < Real.log 4 + 1 := by positivity
+          have hPpos : (0:ℝ) < (P:ℝ) := by linarith
+          have hkey : (Real.log 4 + 1) * (P:ℝ) * 18 = (K:ℝ) * (54 * D * (Real.log 4 + 1)) := by
+            rw [hPR]; ring
+          nlinarith [hKlog, hkey, mul_pos (show (0:ℝ) < K by positivity)
+            (sub_pos.mpr hKlog)]
+  have hcontra : (K : ℝ) < K := by
+    calc (K : ℝ)
+        ≤ ∑ p ∈ S, (((Finset.range K).filter (p ^ 2 ∣ f ·)).card : ℝ) := hKle
+      _ ≤ ∑ p ∈ S, (2 * K * ((p:ℝ) ^ 2)⁻¹ + 2) := Finset.sum_le_sum hper
+      _ = 2 * K * ∑ p ∈ S, ((p:ℝ) ^ 2)⁻¹ + 2 * S.card := by
+          rw [Finset.sum_add_distrib, ← Finset.mul_sum, Finset.sum_const, nsmul_eq_mul]
+          ring
+      _ ≤ 2 * K * (4/9) + 2 * S.card := by gcongr
+      _ < 2 * K * (4/9) + 2 * (K / 18) := by linarith [hScard]
+      _ = K := by ring
+  exact absurd hcontra (lt_irrefl _)
+
+end Sieve
+
+end K2Seam3.SqfreeSieve
+end
+
+theorem solution (D : ℕ) (hD : 1 ≤ D) :
+    ∃ c : ℕ, 1 ≤ c ∧ Squarefree (c ^ 2 + D) :=
+  K2Seam3.SqfreeSieve.kw_existsSqfreeSqAdd_proved D hD
+
+end S_Nat_exists_squarefree_sq_add
+end P2MW
+export P2MW.S_Nat_exists_squarefree_sq_add (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem Nat.exists_squarefree_sq_add (D : ℕ) (hD : 1 ≤ D) :
+    ∃ c : ℕ, 1 ≤ c ∧ Squarefree (c ^ 2 + D) :=
+  solution D hD
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_NumberField_exists_isFrobenius_lift_arithFrobAt.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_NumberField_exists_isFrobenius_lift_arithFrobAt.lean
new file mode 100644
index 0000000000..7839dc3670
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_NumberField_exists_isFrobenius_lift_arithFrobAt.lean
@@ -0,0 +1,323 @@
+/-
+Based on Prove2Me node NumberField.exists_isFrobenius_lift_arithFrobAt
+(f08038fa-7fc0-5e28-b713-0a7ed0b5475f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 42d61a93-803b-5413-8179-14cce2dafe8c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_TaylorWiles_Primes
+public import Mathlib.NumberTheory.NumberField.Basic
+public import Mathlib.FieldTheory.Normal.Defs
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_FieldTheory_RatAlgClosureGalois
+import Mathlib.RingTheory.Invariant.Profinite
+import Mathlib.FieldTheory.Galois.Profinite
+import Mathlib.FieldTheory.Galois.Infinite
+import Mathlib.FieldTheory.KrullTopology
+import Mathlib.FieldTheory.Normal.Closure
+import Mathlib.Topology.Algebra.MulAction
+import Mathlib.FieldTheory.IsAlgClosed.Basic
+import Mathlib.Algebra.Lie.OfAssociative
+import Mathlib.Algebra.Algebra.Rat
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Lifting the arithmetic Frobenius at Q to Gal(ℚ̄/ℚ)
+
+Theorem statement: `NumberField.exists_isFrobenius_lift_arithFrobAt`
+(`f08038fa-7fc0-5e28-b713-0a7ed0b5475f`), by Claude, 2026-09-05.
+
+Proof: submission `42d61a93-803b-5413-8179-14cce2dafe8c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $E$ be an intermediate field of the extension $\mathbb{Q} \subseteq \overline{\mathbb{Q}}$ (the
+ambient algebraic closure being `AlgebraicClosure ℚ`) which is a number field and is Galois over
+$\mathbb{Q}$, let $\ell$ be a natural number assumed prime, and let $Q$ be a prime ideal of the ring
+of integers $\mathcal{O}_E$ lying over the ideal $\mathrm{span}\{(\ell : \mathbb{Z})\} = (\ell)$ of
+$\mathbb{Z}$, with finite residue ring $\mathcal{O}_E/Q$. Then there exist a maximal ideal $Q_t$ of
+the ring $\mathcal{O}_{\overline{\mathbb{Q}}}$ of all algebraic integers and a $\mathbb{Q}$-algebra
+automorphism $\tau$ of $\overline{\mathbb{Q}}$ such that: $Q_t$ lies over $Q$; the restriction of
+$\tau$ to $E$ along the normality of $E$ over $\mathbb{Q}$, `AlgEquiv.restrictNormal τ E`, is equal
+on the nose to the arithmetic Frobenius `arithFrobAt ℤ (E ≃ₐ[ℚ] E) Q` attached to $Q$ for the action
+of $\mathrm{Gal}(E/\mathbb{Q})$ on $\mathcal{O}_E$ over $\mathbb{Z}$; for every algebraic integer
+$x$ one has $\tau \cdot x \in Q_t$ if and only if $x \in Q_t$, so $\tau$ stabilises $Q_t$; and $\tau
+\cdot x - x^{\ell} \in Q_t$ for every algebraic integer $x$, i.e. $\tau$ induces the $\ell$-th power
+map on $\mathcal{O}_{\overline{\mathbb{Q}}}/Q_t$. No unramifiedness hypothesis at $Q$ is imposed,
+and the conclusion about the restriction is an equality rather than a statement up to conjugacy.
+
+This is the standard compatibility between Frobenius elements phrased in terms of a prime $Q$ of a
+Galois number field $E$ and Frobenius elements of the absolute Galois group
+$\mathrm{Gal}(\overline{\mathbb{Q}}/\mathbb{Q})$ at a prime of the ring of all algebraic integers
+above $Q$. It serves as the bridge from statements about $\mathrm{arithFrobAt}$ on $\mathcal{O}_E$
+to statements about Frobenius elements acting on $\overline{\mathbb{Q}}$, and is used in the results
+on conjugates of Frobenius elements in the Frobenius-density material and in the Langlands–Tunnell
+input on traces of Frobenius.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_NumberField_exists_isFrobenius_lift_arithFrobAt.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_NumberField_exists_isFrobenius_lift_arithFrobAt
+
+open scoped NumberField Pointwise
+
+local notation "ℚ̄" => AlgebraicClosure ℚ
+local notation "Γℚ" => (AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ)
+
+noncomputable section
+
+namespace C6P1T2
+
+section T1
+variable (E : IntermediateField ℚ ℚ̄)
+
+scoped instance smulCommClass_gal_ringOfIntegers : SMulCommClass (ℚ̄ ≃ₐ[E] ℚ̄) (𝓞 E) (𝓞 ℚ̄) where
+  smul_comm g a b := by
+    apply Subtype.ext
+    change g ((algebraMap (𝓞 E) (𝓞 ℚ̄) a : ℚ̄) * (b : ℚ̄)) = (algebraMap (𝓞 E) (𝓞 ℚ̄) a : ℚ̄) * g (b
+      : ℚ̄)
+    rw [map_mul]
+    congr 1
+    exact g.commutes (a : E)
+
+scoped instance continuousSMul_gal_ringOfIntegers :
+    @ContinuousSMul (ℚ̄ ≃ₐ[E] ℚ̄) (𝓞 ℚ̄) _ _ ⊥ := by
+  let : TopologicalSpace (𝓞 ℚ̄) := ⊥
+  have : DiscreteTopology (𝓞 ℚ̄) := ⟨rfl⟩
+  rw [continuousSMul_iff_stabilizer_isOpen]
+  intro b
+  have h := stabilizer_isOpen_of_isIntegral (K := E) (L := ℚ̄) (b : ℚ̄)
+  convert h using 1
+  ext g
+  simp only [SetLike.mem_coe, MulAction.mem_stabilizer_iff]
+  exact ⟨fun hg => congrArg Subtype.val hg, fun hg => Subtype.ext hg⟩
+
+scoped instance isInvariant_gal_ringOfIntegers :
+    Algebra.IsInvariant (𝓞 E) (𝓞 ℚ̄) (ℚ̄ ≃ₐ[E] ℚ̄) where
+  isInvariant b hb := by
+    have hbE : (b : ℚ̄) ∈ (⊥ : IntermediateField E ℚ̄) := by
+      rw [InfiniteGalois.mem_bot_iff_fixed]
+      intro g
+      exact congrArg Subtype.val (hb g)
+    obtain ⟨e, he⟩ := IntermediateField.mem_bot.mp hbE
+    have hint : IsIntegral ℤ e := by
+      have hb' : IsIntegral ℤ (b : ℚ̄) := b.2
+      rw [← he] at hb'
+      exact (isIntegral_algHom_iff (algebraMap E ℚ̄).toIntAlgHom (algebraMap E ℚ̄).injective).mp hb'
+    refine ⟨⟨e, hint⟩, Subtype.ext ?_⟩
+    exact he
+
+end T1
+
+section T2
+variable (E : IntermediateField ℚ ℚ̄) [IsGalois ℚ E]
+
+theorem restrictNormal_restrictScalars (δ : ℚ̄ ≃ₐ[E] ℚ̄) :
+    (δ.restrictScalars ℚ).restrictNormal E = 1 := by
+  apply AlgEquiv.ext
+  intro x
+  apply (algebraMap E ℚ̄).injective
+  rw [AlgEquiv.restrictNormal_commutes]
+  exact δ.commutes x
+
+end T2
+
+end C6P1T2
+end
+
+open C6P1T2 in
+theorem solution
+    (E : IntermediateField ℚ (AlgebraicClosure ℚ)) [NumberField E] [IsGalois ℚ E]
+    (ℓ : ℕ) (hℓ : ℓ.Prime) (Q : Ideal (𝓞 E)) [Q.IsPrime]
+    [Q.LiesOver (FrobeniusDensity.ratPrimeIdeal ℓ)]
+    [Finite (𝓞 E ⧸ Q)] :
+    ∃ (Qt : Ideal (𝓞 (AlgebraicClosure ℚ))) (_ : Qt.IsMaximal)
+      (τ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ),
+      Qt.LiesOver Q ∧ AlgEquiv.restrictNormal τ E = arithFrobAt ℤ (E ≃ₐ[ℚ] E) Q ∧
+      (∀ x : 𝓞 (AlgebraicClosure ℚ), τ • x ∈ Qt ↔ x ∈ Qt) ∧
+      ∀ x : 𝓞 (AlgebraicClosure ℚ), τ • x - x ^ ℓ ∈ Qt := by
+  let : TopologicalSpace (𝓞 ℚ̄) := ⊥
+  have : DiscreteTopology (𝓞 ℚ̄) := ⟨rfl⟩
+  have hQbot : Q ≠ ⊥ := FrobeniusDensity.ne_bot_of_liesOver_ratPrimeIdeal hℓ
+  have hQmax : Q.IsMaximal := Ideal.IsPrime.isMaximal inferInstance hQbot
+  have : Algebra.IsIntegral (𝓞 E) (𝓞 ℚ̄) :=
+    IsIntegralClosure.isIntegral_algebra (𝓞 E) (A := 𝓞 ℚ̄) ℚ̄
+  obtain ⟨Qt, hQt, hQtQ⟩ := Ideal.exists_maximal_ideal_liesOver_of_isIntegral (S := 𝓞 ℚ̄) Q
+  have := hQt; have := hQtQ
+  set φ : E ≃ₐ[ℚ] E := arithFrobAt ℤ (E ≃ₐ[ℚ] E) Q with hφdef
+  have hφQ : φ • Q = Q := IsArithFrobAt.arithFrobAt_mem_stabilizer ℤ (E ≃ₐ[ℚ] E) Q
+  have coe_smul : ∀ (g : Γℚ) (b : 𝓞 ℚ̄), ((g • b : 𝓞 ℚ̄) : ℚ̄) = g (b : ℚ̄) := fun _ _ => rfl
+  have coe_smul' : ∀ (g : ℚ̄ ≃ₐ[E] ℚ̄) (b : 𝓞 ℚ̄), ((g • b : 𝓞 ℚ̄) : ℚ̄) = g (b : ℚ̄) :=
+    fun _ _ => rfl
+  have coe_smulE : ∀ (g : E ≃ₐ[ℚ] E) (a : 𝓞 E), ((g • a : 𝓞 E) : E) = g (a : E) := fun _ _ => rfl
+  have coe_alg : ∀ a : 𝓞 E, ((algebraMap (𝓞 E) (𝓞 ℚ̄) a : 𝓞 ℚ̄) : ℚ̄) = ((a : E) : ℚ̄) :=
+    fun _ => rfl
+  have smul_alg : ∀ (τ : Γℚ) (a : 𝓞 E),
+      τ • algebraMap (𝓞 E) (𝓞 ℚ̄) a = algebraMap (𝓞 E) (𝓞 ℚ̄) ((τ.restrictNormal E) • a) := by
+    intro τ a
+    apply Subtype.ext
+    exact (AlgEquiv.restrictNormal_commutes τ E (a : E)).symm
+  have res_scalars : ∀ (δ : ℚ̄ ≃ₐ[E] ℚ̄) (b : 𝓞 ℚ̄), (δ.restrictScalars ℚ) • b = δ • b :=
+    fun _ _ => rfl
+  have res_scalars_ideal : ∀ (δ : ℚ̄ ≃ₐ[E] ℚ̄) (I : Ideal (𝓞 ℚ̄)), (δ.restrictScalars ℚ) • I = δ • I
+    :=
+    by
+    intro δ I
+    rw [Ideal.pointwise_smul_def, Ideal.pointwise_smul_def]
+    congr 1
+  obtain ⟨τ₀, hτ₀⟩ :=
+    AlgEquiv.restrictNormalHom_surjective (F := ℚ) (K₁ := E) (E := AlgebraicClosure ℚ) φ
+  have hτ₀' : τ₀.restrictNormal E = φ := hτ₀
+  have hunder : (τ₀ • Qt).under (𝓞 E) = Qt.under (𝓞 E) := by
+    ext a
+    rw [Ideal.under_def, Ideal.under_def, Ideal.mem_comap, Ideal.mem_comap,
+      Ideal.mem_pointwise_smul_iff_inv_smul_mem, smul_alg]
+    have hinv : (τ₀⁻¹).restrictNormal E = φ⁻¹ := by
+      change AlgEquiv.restrictNormalHom E τ₀⁻¹ = φ⁻¹
+      rw [map_inv]; exact congrArg _ hτ₀
+    rw [hinv, ← Ideal.mem_of_liesOver Qt Q, ← Ideal.mem_of_liesOver Qt Q,
+      ← Ideal.mem_inv_pointwise_smul_iff, inv_inv, hφQ]
+  obtain ⟨g, hg⟩ := Algebra.IsInvariant.exists_smul_of_under_eq_of_profinite
+    (A := 𝓞 E) (B := 𝓞 ℚ̄) (G := ℚ̄ ≃ₐ[E] ℚ̄) (τ₀ • Qt) Qt hunder
+  set τ₁ : Γℚ := g.restrictScalars ℚ * τ₀ with hτ₁def
+  have hτ₁Qt : τ₁ • Qt = Qt := by
+    rw [hτ₁def, mul_smul, res_scalars_ideal, ← hg]
+  have hτ₁res : τ₁.restrictNormal E = φ := by
+    change AlgEquiv.restrictNormalHom E (g.restrictScalars ℚ * τ₀) = φ
+    rw [map_mul]
+    change (g.restrictScalars ℚ).restrictNormal E * τ₀.restrictNormal E = φ
+    rw [restrictNormal_restrictScalars, one_mul, hτ₀']
+  have hstab₁ : ∀ x : 𝓞 ℚ̄, τ₁ • x ∈ Qt ↔ x ∈ Qt := fun x => by
+    conv_lhs => rw [← hτ₁Qt]
+    exact Ideal.smul_mem_pointwise_smul_iff
+  have hℓQ : ((ℓ : ℤ) : 𝓞 E) ∈ Q := by
+    have := (Ideal.mem_of_liesOver Q (FrobeniusDensity.ratPrimeIdeal ℓ) (ℓ : ℤ)).mp
+      (Ideal.mem_span_singleton_self _)
+    simpa using this
+  have hℓQt : ((ℓ : ℕ) : 𝓞 ℚ̄) ∈ Qt := by
+    have h2 := (Ideal.mem_of_liesOver Qt Q ((ℓ : ℤ) : 𝓞 E)).mp hℓQ
+    simpa using h2
+  have : Fact ℓ.Prime := ⟨hℓ⟩
+  have hchar : CharP (𝓞 ℚ̄ ⧸ Qt) ℓ :=
+    (CharP.charP_iff_prime_eq_zero hℓ).mpr ((Ideal.Quotient.eq_zero_iff_mem).mpr (by
+      simpa using hℓQt))
+  let F : 𝓞 ℚ̄ ⧸ Qt →+* 𝓞 ℚ̄ ⧸ Qt := frobenius (𝓞 ℚ̄ ⧸ Qt) ℓ
+  have hFbij : Function.Bijective F := by
+    refine ⟨frobenius_inj _ _, fun y => ?_⟩
+    obtain ⟨b, rfl⟩ := Ideal.Quotient.mk_surjective y
+    obtain ⟨c, hc⟩ := IsAlgClosed.exists_pow_nat_eq (b : ℚ̄) hℓ.pos
+    have hcint : IsIntegral ℤ c := IsIntegral.of_pow hℓ.pos (by rw [hc]; exact b.2)
+    refine ⟨Ideal.Quotient.mk Qt ⟨c, hcint⟩, ?_⟩
+    change (Ideal.Quotient.mk Qt ⟨c, hcint⟩) ^ ℓ = _
+    rw [← map_pow]
+    congr 1
+    exact Subtype.ext hc
+  have hle : ∀ τ : Γℚ, (∀ x : 𝓞 ℚ̄, τ • x ∈ Qt ↔ x ∈ Qt) →
+      Qt ≤ Qt.comap (MulSemiringAction.toRingHom Γℚ (𝓞 ℚ̄) τ) := fun τ h x hx => (h x).mpr hx
+  have hstab₁' : ∀ x : 𝓞 ℚ̄, τ₁⁻¹ • x ∈ Qt ↔ x ∈ Qt := fun x => by
+    rw [← hstab₁ (τ₁⁻¹ • x), smul_inv_smul]
+  let θinv : 𝓞 ℚ̄ ⧸ Qt →+* 𝓞 ℚ̄ ⧸ Qt := Ideal.quotientMap Qt _ (hle τ₁⁻¹ hstab₁')
+  have hθinv : ∀ x : 𝓞 ℚ̄, θinv (Ideal.Quotient.mk Qt x) = Ideal.Quotient.mk Qt (τ₁⁻¹ • x) :=
+    fun x => rfl
+  have hφfrob : ∀ a : 𝓞 E, φ • a - a ^ ℓ ∈ Q := by
+    intro a
+    have h := (IsArithFrobAt.arithFrobAt ℤ (E ≃ₐ[ℚ] E) Q) a
+    have hcard : Nat.card (ℤ ⧸ Q.under ℤ) = ℓ := by
+      rw [← Q.over_def (FrobeniusDensity.ratPrimeIdeal ℓ)]
+      rw [Nat.card_congr (Int.quotientSpanNatEquivZMod ℓ).toEquiv, Nat.card_zmod]
+    rw [hcard] at h
+    exact h
+  have hinv1 : (τ₁⁻¹).restrictNormal E = φ⁻¹ := by
+    change AlgEquiv.restrictNormalHom E τ₁⁻¹ = φ⁻¹
+    rw [map_inv]; exact congrArg _ hτ₁res
+  have hcomm : ∀ a : 𝓞 E, F (θinv (Ideal.Quotient.mk Qt (algebraMap (𝓞 E) (𝓞 ℚ̄) a)))
+      = Ideal.Quotient.mk Qt (algebraMap (𝓞 E) (𝓞 ℚ̄) a) := by
+    intro a
+    rw [hθinv, smul_alg, hinv1, frobenius_def, ← map_pow, ← map_pow, Ideal.Quotient.eq, ← map_sub,
+      ← Ideal.mem_of_liesOver Qt Q]
+    have h := hφfrob (φ⁻¹ • a)
+    rw [smul_inv_smul] at h
+    rw [← neg_sub]
+    exact Q.neg_mem h
+  let θ : 𝓞 ℚ̄ ⧸ Qt →+* 𝓞 ℚ̄ ⧸ Qt := Ideal.quotientMap Qt _ (hle τ₁ hstab₁)
+  have hθ : ∀ x : 𝓞 ℚ̄, θ (Ideal.Quotient.mk Qt x) = Ideal.Quotient.mk Qt (τ₁ • x) := fun x => rfl
+  have hθinv_bij : Function.Bijective θinv := by
+    refine Function.bijective_iff_has_inverse.mpr ⟨θ, fun y => ?_, fun y => ?_⟩
+    · obtain ⟨x, rfl⟩ := Ideal.Quotient.mk_surjective y
+      rw [hθinv, hθ, smul_inv_smul]
+    · obtain ⟨x, rfl⟩ := Ideal.Quotient.mk_surjective y
+      rw [hθ, hθinv, inv_smul_smul]
+  let ψ₀ : 𝓞 ℚ̄ ⧸ Qt →+* 𝓞 ℚ̄ ⧸ Qt := F.comp θinv
+  have hψ₀ : ∀ x : 𝓞 ℚ̄, ψ₀ (Ideal.Quotient.mk Qt x) = F (θinv (Ideal.Quotient.mk Qt x)) :=
+    fun _ => rfl
+  let ψ₁ : (𝓞 ℚ̄ ⧸ Qt) →ₐ[𝓞 E ⧸ Q] (𝓞 ℚ̄ ⧸ Qt) :=
+    { ψ₀ with
+      commutes' := fun r => by
+        obtain ⟨a, rfl⟩ := Ideal.Quotient.mk_surjective r
+        rw [Ideal.Quotient.algebraMap_mk_of_liesOver]
+        exact hcomm a }
+  let ψ : (𝓞 ℚ̄ ⧸ Qt) ≃ₐ[𝓞 E ⧸ Q] (𝓞 ℚ̄ ⧸ Qt) := AlgEquiv.ofBijective ψ₁ (hFbij.comp hθinv_bij)
+  have hψ : ∀ x : 𝓞 ℚ̄, ψ (Ideal.Quotient.mk Qt x) = F (θinv (Ideal.Quotient.mk Qt x)) :=
+    fun _ => rfl
+  obtain ⟨δ, hδ⟩ := Ideal.Quotient.stabilizerHom_surjective_of_profinite (G := ℚ̄ ≃ₐ[E] ℚ̄) Q Qt ψ
+  have hδ' : ∀ b : 𝓞 ℚ̄, Ideal.Quotient.mk Qt ((δ : ℚ̄ ≃ₐ[E] ℚ̄) • b) = F (θinv (Ideal.Quotient.mk
+    Qt b)) :=
+    by
+    intro b
+    have := DFunLike.congr_fun hδ (Ideal.Quotient.mk Qt b)
+    rw [Ideal.Quotient.stabilizerHom_apply] at this
+    rw [← hψ, ← this]
+    rfl
+  have hδQt : ∀ y : 𝓞 ℚ̄, (δ : ℚ̄ ≃ₐ[E] ℚ̄) • y ∈ Qt ↔ y ∈ Qt := fun y => by
+    have h2 : (δ : ℚ̄ ≃ₐ[E] ℚ̄) • Qt = Qt := δ.2
+    have h3 := (Ideal.smul_mem_pointwise_smul_iff (a := (δ : ℚ̄ ≃ₐ[E] ℚ̄)) (S := Qt) (x := y))
+    rwa [h2] at h3
+  refine ⟨Qt, hQt, ((δ : ℚ̄ ≃ₐ[E] ℚ̄).restrictScalars ℚ) * τ₁, hQtQ, ?_, ?_, ?_⟩
+  · change AlgEquiv.restrictNormalHom E (((δ : ℚ̄ ≃ₐ[E] ℚ̄).restrictScalars ℚ) * τ₁) = φ
+    rw [map_mul]
+    change ((δ : ℚ̄ ≃ₐ[E] ℚ̄).restrictScalars ℚ).restrictNormal E * τ₁.restrictNormal E = φ
+    rw [restrictNormal_restrictScalars, one_mul, hτ₁res]
+  · intro x
+    rw [mul_smul, res_scalars, hδQt, hstab₁]
+  · intro x
+    rw [← Ideal.Quotient.eq, map_pow, mul_smul, res_scalars, hδ', hθinv, inv_smul_smul,
+      frobenius_def]
+
+end S_NumberField_exists_isFrobenius_lift_arithFrobAt
+end P2MW
+export P2MW.S_NumberField_exists_isFrobenius_lift_arithFrobAt (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped NumberField Pointwise
+
+theorem NumberField.exists_isFrobenius_lift_arithFrobAt
+    (E : IntermediateField ℚ (AlgebraicClosure ℚ)) [NumberField E] [IsGalois ℚ E]
+    (ℓ : ℕ) (hℓ : ℓ.Prime) (Q : Ideal (𝓞 E)) [Q.IsPrime]
+    [Q.LiesOver (FrobeniusDensity.ratPrimeIdeal ℓ)]
+    [Finite (𝓞 E ⧸ Q)] :
+    ∃ (Qt : Ideal (𝓞 (AlgebraicClosure ℚ))) (_ : Qt.IsMaximal)
+      (τ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ),
+      Qt.LiesOver Q ∧ AlgEquiv.restrictNormal τ E = arithFrobAt ℤ (E ≃ₐ[ℚ] E) Q ∧
+      (∀ x : 𝓞 (AlgebraicClosure ℚ), τ • x ∈ Qt ↔ x ∈ Qt) ∧
+      ∀ x : 𝓞 (AlgebraicClosure ℚ), τ • x - x ^ ℓ ∈ Qt :=
+  solution E ℓ hℓ Q
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_NumberField_exists_lift_mem_inertia_integralClosure.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_NumberField_exists_lift_mem_inertia_integralClosure.lean
new file mode 100644
index 0000000000..1c97417077
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_NumberField_exists_lift_mem_inertia_integralClosure.lean
@@ -0,0 +1,272 @@
+/-
+Based on Prove2Me node NumberField.exists_lift_mem_inertia_integralClosure
+(7539aed3-1668-5c1c-b1fa-3294131adbb4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 219bb7b4-2c6c-57de-9834-f87a61c9d497
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.NumberField.Basic
+
+import Mathlib.Algebra.Algebra.Rat
+import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure
+import Mathlib.FieldTheory.Galois.Profinite
+import Mathlib.FieldTheory.Galois.Infinite
+import Mathlib.RingTheory.Invariant.Profinite
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Lifting inertia from a finite Galois subfield to G_ℚ
+
+Theorem statement: `NumberField.exists_lift_mem_inertia_integralClosure`
+(`7539aed3-1668-5c1c-b1fa-3294131adbb4`), by Claude, 2026-09-05.
+
+Proof: submission `219bb7b4-2c6c-57de-9834-f87a61c9d497`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be an intermediate field of $\mathbb Q \subset \overline{\mathbb Q} =$ `AlgebraicClosure ℚ`
+which is finite-dimensional over $\mathbb Q$ and Galois over $\mathbb Q$, let $Q$ be a maximal ideal
+of the ring of integers $\mathcal O_L$ of $L$, let $q$ be a natural number whose image in $\mathcal
+O_L$ lies in $Q$, and let $\tau$ be a $\mathbb Q$-automorphism of $L$ belonging to the inertia
+subgroup `Q.inertia` of $Q$ inside $\operatorname{Gal}(L/\mathbb Q)$, that is, $\tau$ preserves $Q$
+and acts trivially on $\mathcal O_L/Q$. The conclusion asserts the existence of a $\mathbb
+Q$-automorphism $\sigma$ of $\overline{\mathbb Q}$ such that the restriction homomorphism
+`AlgEquiv.restrictNormalHom L` sends $\sigma$ to $\tau$, together with a maximal ideal $\mathfrak Q$
+of the integral closure $\overline{\mathbb Z}$ of $\mathbb Z$ in $\overline{\mathbb Q}$ such that
+the image of $q$ in $\overline{\mathbb Z}$ lies in $\mathfrak Q$ and such that for every $b \in
+\overline{\mathbb Z}$ there is an element $c$ of $\mathfrak Q$ whose image in $\overline{\mathbb Q}$
+equals $\sigma(b) - b$; in other words $\sigma$ acts trivially on $\overline{\mathbb Z}/\mathfrak
+Q$. No primality is required of $q$.
+
+This is the surjectivity half of Hilbert ramification theory for the profinite group $G_{\mathbb Q}
+= \operatorname{Gal}(\overline{\mathbb Q}/\mathbb Q)$: the inertia group of a maximal ideal of
+$\overline{\mathbb Z}$ above $Q$ maps onto the inertia group of $Q$ in $\operatorname{Gal}(L/\mathbb
+Q)$. It is the bridge from ramification data of number fields to inertia subgroups of the absolute
+Galois group, and is used where a hypothesis that all inertia subgroups of $G_{\mathbb Q}$ (at a
+given residue characteristic) act in a prescribed way has to be converted into a statement about a
+finite Galois extension, for instance in the analysis of the image of Galois on cyclotomic and unit
+data.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_NumberField_exists_lift_mem_inertia_integralClosure.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_NumberField_exists_lift_mem_inertia_integralClosure
+
+open scoped NumberField Pointwise
+
+local notation "ℚ̄" => AlgebraicClosure ℚ
+local notation "𝔅" => integralClosure ℤ (AlgebraicClosure ℚ)
+
+theorem solution
+    (L : IntermediateField ℚ (AlgebraicClosure ℚ)) [FiniteDimensional ℚ L] [IsGalois ℚ L]
+    (Q : Ideal (NumberField.RingOfIntegers L)) [Q.IsMaximal] {q : ℕ}
+    (hqQ : (q : NumberField.RingOfIntegers L) ∈ Q) (τ : L ≃ₐ[ℚ] L)
+    (hτ : τ ∈ Q.inertia (L ≃ₐ[ℚ] L)) :
+    ∃ σ : (AlgebraicClosure ℚ) ≃ₐ[ℚ] (AlgebraicClosure ℚ), AlgEquiv.restrictNormalHom L σ = τ ∧
+      ∃ 𝔔 : Ideal (integralClosure ℤ (AlgebraicClosure ℚ)), 𝔔.IsMaximal ∧
+        (q : integralClosure ℤ (AlgebraicClosure ℚ)) ∈ 𝔔 ∧
+        ∀ b : integralClosure ℤ (AlgebraicClosure ℚ), ∃ c ∈ 𝔔,
+          (c : AlgebraicClosure ℚ) = σ b - b := by
+  classical
+  have hnormQ : Normal ℚ ℚ̄ := by
+    have h : @Normal ℚ ℚ̄ _ _ (AlgebraicClosure.instAlgebra ℚ) := inferInstance
+    exact h
+  have halgQ : Algebra.IsAlgebraic ℚ ℚ̄ := by
+    have h : @Algebra.IsAlgebraic ℚ ℚ̄ _ _ (AlgebraicClosure.instAlgebra ℚ) := inferInstance
+    exact h
+  have hsepQ : Algebra.IsSeparable ℚ ℚ̄ := by
+    have h : @Algebra.IsSeparable ℚ ℚ̄ _ _ (AlgebraicClosure.instAlgebra ℚ) := inferInstance
+    exact h
+  have : Algebra.IsAlgebraic L ℚ̄ := Algebra.IsAlgebraic.tower_top (K := ℚ) L
+  have : Algebra.IsIntegral L ℚ̄ := Algebra.isAlgebraic_iff_isIntegral.mp inferInstance
+  have : Normal L ℚ̄ := Normal.tower_top_of_normal ℚ L ℚ̄
+  have : Algebra.IsSeparable L ℚ̄ := Algebra.isSeparable_tower_top_of_isSeparable ℚ L ℚ̄
+  have : IsGalois L ℚ̄ := ⟨⟩
+  have hτ' : ∀ x : 𝓞 L, τ • x - x ∈ Q := fun x => (AddSubgroup.mem_inertia.mp hτ) x
+  have hstabτ : τ • Q = Q := Ideal.inertia_le_stabilizer Q hτ
+  let actG : MulSemiringAction (ℚ̄ ≃ₐ[ℚ] ℚ̄) 𝔅 := inferInstance
+  let actGI : DistribMulAction (ℚ̄ ≃ₐ[ℚ] ℚ̄) (Ideal 𝔅) := Ideal.pointwiseDistribMulAction
+  let mulActGI : MulAction (ℚ̄ ≃ₐ[ℚ] ℚ̄) (Ideal 𝔅) := DistribMulAction.toMulAction
+  let dsmulGI : DistribSMul (ℚ̄ ≃ₐ[ℚ] ℚ̄) (Ideal 𝔅) := DistribMulAction.toDistribSMul
+  let smulzGI : SMulZeroClass (ℚ̄ ≃ₐ[ℚ] ℚ̄) (Ideal 𝔅) := DistribSMul.toSMulZeroClass
+  let smulGI : SMul (ℚ̄ ≃ₐ[ℚ] ℚ̄) (Ideal 𝔅) := SMulZeroClass.toSMul
+  let f : 𝓞 L →+* 𝔅 := (algebraMap (𝓞 L) ℚ̄).codRestrict (integralClosure ℤ ℚ̄) fun x =>
+    (map_isIntegral_int (algebraMap (𝓞 L) ℚ̄) (Algebra.IsIntegral.isIntegral x))
+  let algOB : Algebra (𝓞 L) 𝔅 := f.toAlgebra
+  have hf_coe : ∀ x : 𝓞 L, ((algebraMap (𝓞 L) 𝔅 x : 𝔅) : ℚ̄) = algebraMap L ℚ̄ (x : L) :=
+    fun x => rfl
+  have : IsScalarTower (𝓞 L) 𝔅 ℚ̄ := IsScalarTower.of_algebraMap_eq fun x => rfl
+  have hf_inj : Function.Injective (algebraMap (𝓞 L) 𝔅) := by
+    intro x y hxy
+    have h := congrArg (fun z : 𝔅 => (z : ℚ̄)) hxy
+    simp only [hf_coe] at h
+    exact NumberField.RingOfIntegers.coe_injective ((algebraMap L ℚ̄).injective h)
+  have hres : ∀ (σ : ℚ̄ ≃ₐ[ℚ] ℚ̄) (x : 𝓞 L),
+      σ • algebraMap (𝓞 L) 𝔅 x = algebraMap (𝓞 L) 𝔅 ((AlgEquiv.restrictNormalHom L σ) • x) := by
+    intro σ x
+    apply Subtype.ext
+    change σ (algebraMap L ℚ̄ (x : L)) = algebraMap L ℚ̄ ((σ.restrictNormal L) (x : L))
+    exact (AlgEquiv.restrictNormal_commutes σ L (x : L)).symm
+  let rsh : (ℚ̄ ≃ₐ[L] ℚ̄) →* (ℚ̄ ≃ₐ[ℚ] ℚ̄) :=
+    { toFun := fun g => g.restrictScalars ℚ
+      map_one' := rfl
+      map_mul' := fun _ _ => rfl }
+  have hrsh_apply : ∀ (g : ℚ̄ ≃ₐ[L] ℚ̄) (x : ℚ̄), rsh g x = g x := fun _ _ => rfl
+  have hresL : ∀ g : ℚ̄ ≃ₐ[L] ℚ̄, AlgEquiv.restrictNormalHom L (rsh g) = 1 := by
+    intro g
+    refine AlgEquiv.ext fun x => (algebraMap L ℚ̄).injective ?_
+    change algebraMap L ℚ̄ (((rsh g).restrictNormal L) x) = algebraMap L ℚ̄ x
+    rw [AlgEquiv.restrictNormal_commutes, hrsh_apply]
+    exact g.commutes x
+  let actL : MulSemiringAction (ℚ̄ ≃ₐ[L] ℚ̄) 𝔅 := MulSemiringAction.compHom 𝔅 rsh
+  let actLI : DistribMulAction (ℚ̄ ≃ₐ[L] ℚ̄) (Ideal 𝔅) := Ideal.pointwiseDistribMulAction
+  let mulActLI : MulAction (ℚ̄ ≃ₐ[L] ℚ̄) (Ideal 𝔅) := DistribMulAction.toMulAction
+  let dsmulLI : DistribSMul (ℚ̄ ≃ₐ[L] ℚ̄) (Ideal 𝔅) := DistribMulAction.toDistribSMul
+  let smulzLI : SMulZeroClass (ℚ̄ ≃ₐ[L] ℚ̄) (Ideal 𝔅) := DistribSMul.toSMulZeroClass
+  let smulLI : SMul (ℚ̄ ≃ₐ[L] ℚ̄) (Ideal 𝔅) := SMulZeroClass.toSMul
+  have hrs : ∀ (g : ℚ̄ ≃ₐ[L] ℚ̄) (b : 𝔅), g • b = rsh g • b := fun _ _ => rfl
+  have hrsI : ∀ (g : ℚ̄ ≃ₐ[L] ℚ̄) (J : Ideal 𝔅), g • J = rsh g • J := by
+    intro g J
+    ext b
+    rw [Ideal.mem_pointwise_smul_iff_inv_smul_mem, Ideal.mem_pointwise_smul_iff_inv_smul_mem,
+      ← map_inv, hrs]
+  have : SMulCommClass (ℚ̄ ≃ₐ[L] ℚ̄) (𝓞 L) 𝔅 := ⟨fun g a b => by
+    apply Subtype.ext
+    change g ((algebraMap L ℚ̄ (a : L)) * (b : ℚ̄)) = algebraMap L ℚ̄ (a : L) * g (b : ℚ̄)
+    rw [map_mul, AlgEquiv.commutes]⟩
+  let : TopologicalSpace 𝔅 := ⊥
+  have : DiscreteTopology 𝔅 := ⟨rfl⟩
+  have : ContinuousSMul (ℚ̄ ≃ₐ[L] ℚ̄) 𝔅 := by
+    refine continuousSMul_iff_stabilizer_isOpen.mpr fun b => ?_
+    have : FiniteDimensional L (IntermediateField.adjoin L {(b : ℚ̄)}) :=
+      IntermediateField.adjoin.finiteDimensional (Algebra.IsIntegral.isIntegral (b : ℚ̄))
+    refine Subgroup.isOpen_mono ?_
+      (IntermediateField.fixingSubgroup_isOpen (IntermediateField.adjoin L {(b : ℚ̄)}))
+    intro g hg
+    rw [MulAction.mem_stabilizer_iff]
+    apply Subtype.ext
+    change g (b : ℚ̄) = b
+    rw [IntermediateField.mem_fixingSubgroup_iff] at hg
+    exact hg _ (IntermediateField.mem_adjoin_simple_self L (b : ℚ̄))
+  have : Algebra.IsInvariant (𝓞 L) 𝔅 (ℚ̄ ≃ₐ[L] ℚ̄) := ⟨fun b hb => by
+    have hb' : (b : ℚ̄) ∈ Set.range (algebraMap L ℚ̄) := by
+      rw [InfiniteGalois.mem_range_algebraMap_iff_fixed]
+      intro g
+      exact congrArg (fun z : 𝔅 => (z : ℚ̄)) (hb g)
+    obtain ⟨y, hy⟩ := hb'
+    have hyint : IsIntegral ℤ y := by
+      obtain ⟨p, hp, hp0⟩ := (b.2 : IsIntegral ℤ (b : ℚ̄))
+      refine ⟨p, hp, (algebraMap L ℚ̄).injective ?_⟩
+      rw [Polynomial.hom_eval₂, map_zero, hy]
+      convert hp0 using 2
+      rfl
+    refine ⟨⟨y, hyint⟩, Subtype.ext ?_⟩
+    rw [hf_coe]
+    exact hy⟩
+  have : Algebra.IsIntegral (𝓞 L) 𝔅 :=
+    Algebra.IsInvariant.isIntegral_of_profinite (G := ℚ̄ ≃ₐ[L] ℚ̄)
+  obtain ⟨𝔔, h𝔔max, h𝔔Q⟩ := Ideal.exists_ideal_over_maximal_of_isIntegral (S := 𝔅) Q (by
+    intro x hx
+    rw [RingHom.mem_ker] at hx
+    have hx0 : x = 0 := hf_inj (by rw [hx, map_zero])
+    rw [hx0]
+    exact Q.zero_mem)
+  have h𝔔prime : 𝔔.IsPrime := h𝔔max.isPrime
+  have h𝔔lies : 𝔔.LiesOver Q := ⟨h𝔔Q.symm⟩
+  have hmemQ : ∀ x : 𝓞 L, algebraMap (𝓞 L) 𝔅 x ∈ 𝔔 ↔ x ∈ Q := fun x => by
+    rw [← Ideal.mem_under, h𝔔Q]
+  obtain ⟨σ₀, hσ₀⟩ := AlgEquiv.restrictNormalHom_surjective (K₁ := L) ℚ̄ τ
+  have hunder : Ideal.under (𝓞 L) (σ₀ • 𝔔 : Ideal 𝔅) = Ideal.under (𝓞 L) 𝔔 := by
+    ext x
+    rw [Ideal.mem_under, Ideal.mem_under, Ideal.mem_pointwise_smul_iff_inv_smul_mem, hres,
+      hmemQ, hmemQ, map_inv, hσ₀]
+    conv_rhs => rw [← hstabτ]
+    rw [Ideal.mem_pointwise_smul_iff_inv_smul_mem]
+  obtain ⟨g, hg⟩ := Algebra.IsInvariant.exists_smul_of_under_eq_of_profinite
+      (A := 𝓞 L) (G := ℚ̄ ≃ₐ[L] ℚ̄) (σ₀ • 𝔔 : Ideal 𝔅) 𝔔 hunder
+  have hσ₁𝔔 : (rsh g * σ₀) • 𝔔 = 𝔔 := by rw [mul_smul, ← hrsI, ← hg]
+  have hσ₁L : AlgEquiv.restrictNormalHom L (rsh g * σ₀) = τ := by
+    rw [map_mul, hresL, one_mul, hσ₀]
+  have hσ₁stab : rsh g * σ₀ ∈ MulAction.stabilizer (ℚ̄ ≃ₐ[ℚ] ℚ̄) 𝔔 := hσ₁𝔔
+  let φ₀ : (𝔅 ⧸ 𝔔) ≃ₐ[ℤ ⧸ 𝔔.under ℤ] (𝔅 ⧸ 𝔔) :=
+    Ideal.Quotient.stabilizerHom 𝔔 (𝔔.under ℤ) (ℚ̄ ≃ₐ[ℚ] ℚ̄) ⟨rsh g * σ₀, hσ₁stab⟩
+  have hφ₀ : ∀ b : 𝔅, φ₀ (Ideal.Quotient.mk 𝔔 b) = Ideal.Quotient.mk 𝔔 ((rsh g * σ₀) • b) :=
+    fun b => rfl
+  have hστQ : ∀ x : 𝓞 L, Ideal.Quotient.mk 𝔔 ((rsh g * σ₀) • algebraMap (𝓞 L) 𝔅 x) =
+      Ideal.Quotient.mk 𝔔 (algebraMap (𝓞 L) 𝔅 x) := by
+    intro x
+    rw [Ideal.Quotient.eq, hres, hσ₁L, ← map_sub, hmemQ]
+    exact hτ' x
+  let φ : (𝔅 ⧸ 𝔔) ≃ₐ[𝓞 L ⧸ Q] (𝔅 ⧸ 𝔔) :=
+    AlgEquiv.ofRingEquiv (f := (φ₀ : (𝔅 ⧸ 𝔔) ≃+* (𝔅 ⧸ 𝔔))) (by
+      intro a
+      obtain ⟨x, rfl⟩ := Ideal.Quotient.mk_surjective a
+      rw [Ideal.Quotient.algebraMap_mk_of_liesOver]
+      exact hστQ x)
+  have hφ : ∀ b : 𝔅, φ (Ideal.Quotient.mk 𝔔 b) = Ideal.Quotient.mk 𝔔 ((rsh g * σ₀) • b) :=
+    fun b => rfl
+  obtain ⟨t, ht⟩ :=
+    Ideal.Quotient.stabilizerHom_surjective_of_profinite (G := ℚ̄ ≃ₐ[L] ℚ̄) Q 𝔔 φ
+  have ht' : ∀ b : 𝔅, Ideal.Quotient.mk 𝔔 ((t : ℚ̄ ≃ₐ[L] ℚ̄) • b) =
+      Ideal.Quotient.mk 𝔔 ((rsh g * σ₀) • b) := by
+    intro b
+    have h := congrArg (fun e => e (Ideal.Quotient.mk 𝔔 b)) ht
+    simp only [Ideal.Quotient.stabilizerHom_apply, hφ] at h
+    exact h
+  refine ⟨(rsh (t : ℚ̄ ≃ₐ[L] ℚ̄))⁻¹ * (rsh g * σ₀), ?_, 𝔔, h𝔔max, ?_, ?_⟩
+  · rw [map_mul, map_inv, hresL, inv_one, one_mul, hσ₁L]
+  · have h : algebraMap (𝓞 L) 𝔅 (q : 𝓞 L) ∈ 𝔔 := (hmemQ _).mpr hqQ
+    simpa only [map_natCast] using h
+  · intro b
+    refine ⟨((rsh (t : ℚ̄ ≃ₐ[L] ℚ̄))⁻¹ * (rsh g * σ₀)) • b - b, ?_, rfl⟩
+    have h1 : (rsh g * σ₀) • b - (t : ℚ̄ ≃ₐ[L] ℚ̄) • b ∈ 𝔔 := by
+      rw [← Ideal.Quotient.eq]
+      exact (ht' b).symm
+    have h2 : ((t⁻¹ : MulAction.stabilizer (ℚ̄ ≃ₐ[L] ℚ̄) 𝔔) : ℚ̄ ≃ₐ[L] ℚ̄) •
+        ((rsh g * σ₀) • b - (t : ℚ̄ ≃ₐ[L] ℚ̄) • b) ∈ 𝔔 := by
+      have hmem := (Ideal.smul_mem_pointwise_smul_iff
+        (a := ((t⁻¹ : MulAction.stabilizer (ℚ̄ ≃ₐ[L] ℚ̄) 𝔔) : ℚ̄ ≃ₐ[L] ℚ̄))).mpr h1
+      rwa [MulAction.mem_stabilizer_iff.mp (t⁻¹).2] at hmem
+    have h3 : ((t⁻¹ : MulAction.stabilizer (ℚ̄ ≃ₐ[L] ℚ̄) 𝔔) : ℚ̄ ≃ₐ[L] ℚ̄) •
+        ((rsh g * σ₀) • b - (t : ℚ̄ ≃ₐ[L] ℚ̄) • b) =
+        ((rsh (t : ℚ̄ ≃ₐ[L] ℚ̄))⁻¹ * (rsh g * σ₀)) • b - b := by
+      rw [Subgroup.coe_inv, smul_sub, inv_smul_smul, hrs, map_inv]
+      simp only [mul_smul]
+    rw [← h3]
+    exact h2
+
+end S_NumberField_exists_lift_mem_inertia_integralClosure
+end P2MW
+export P2MW.S_NumberField_exists_lift_mem_inertia_integralClosure (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem NumberField.exists_lift_mem_inertia_integralClosure
+    (L : IntermediateField ℚ (AlgebraicClosure ℚ)) [FiniteDimensional ℚ L] [IsGalois ℚ L]
+    (Q : Ideal (NumberField.RingOfIntegers L)) [Q.IsMaximal] {q : ℕ}
+    (hqQ : (q : NumberField.RingOfIntegers L) ∈ Q) (τ : L ≃ₐ[ℚ] L) (hτ : τ ∈ Q.inertia (L ≃ₐ[ℚ] L))
+    :
+    ∃ σ : (AlgebraicClosure ℚ) ≃ₐ[ℚ] (AlgebraicClosure ℚ), AlgEquiv.restrictNormalHom L σ = τ ∧ ∃ 𝔔
+      : Ideal (integralClosure ℤ (AlgebraicClosure ℚ)), 𝔔.IsMaximal ∧ (q : integralClosure ℤ
+      (AlgebraicClosure ℚ)) ∈ 𝔔 ∧ ∀ b : integralClosure ℤ (AlgebraicClosure ℚ), ∃ c ∈ 𝔔, (c :
+      AlgebraicClosure ℚ) = σ b - b :=
+  solution L Q hqQ τ hτ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_NumberField_exists_valuationSubring_eq_localization.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_NumberField_exists_valuationSubring_eq_localization.lean
new file mode 100644
index 0000000000..8f0d5cad84
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_NumberField_exists_valuationSubring_eq_localization.lean
@@ -0,0 +1,186 @@
+/-
+Based on Prove2Me node NumberField.exists_valuationSubring_eq_localization
+(95c89632-a8bf-54a5-a513-d015d275c4fe) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission dfbaf41d-01c4-5774-ac74-ba1d4d280268
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.NumberField.Basic
+public import Mathlib.RingTheory.Valuation.ValuationSubring
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_FieldTheory_RatAlgClosureGalois
+import Mathlib.RingTheory.DedekindDomain.AdicValuation
+import Mathlib.RingTheory.DedekindDomain.IntegralClosure
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+import Mathlib.RingTheory.Ideal.GoingUp
+import Mathlib.Algebra.Lie.OfAssociative
+import Mathlib.Algebra.Algebra.Rat
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Localisation of ℤ̄ at a maximal ideal is a valuation subring
+
+Theorem statement: `NumberField.exists_valuationSubring_eq_localization`
+(`95c89632-a8bf-54a5-a513-d015d275c4fe`), by Claude, 2026-09-05.
+
+Proof: submission `dfbaf41d-01c4-5774-ac74-ba1d4d280268`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix an algebraic closure $\overline{\mathbb{Q}}$ of $\mathbb{Q}$ (Mathlib's `AlgebraicClosure ℚ`)
+and let $\mathcal{O} = 𝓞\,(\text{AlgebraicClosure }ℚ)$ denote its ring of integers, i.e. the
+integral closure of $\mathbb{Z}$ in $\overline{\mathbb{Q}}$, the ring of all algebraic integers. Let
+$Qt$ be an ideal of $\mathcal{O}$ which is assumed maximal (a typeclass hypothesis `Qt.IsMaximal`).
+The theorem asserts the existence of a valuation subring $A$ of the field $\overline{\mathbb{Q}}$ —
+that is, a subring with the property that for every $x$ either $x \in A$ or $x^{-1} \in A$ — whose
+underlying set is described explicitly: for every $x \in \overline{\mathbb{Q}}$, one has $x \in A$
+if and only if there exist $s, a \in \mathcal{O}$ with $s \notin Qt$ and $s\,x = a$ in
+$\overline{\mathbb{Q}}$ (the images of $s$ and $a$ under the inclusion of $\mathcal{O}$ into
+$\overline{\mathbb{Q}}$ being understood). Thus the localisation $\mathcal{O}_{Qt}$, realised inside
+$\overline{\mathbb{Q}}$ as the set of fractions with denominator prime to $Qt$, is a valuation ring
+of $\overline{\mathbb{Q}}$. No uniqueness or further property of $A$ is claimed.
+
+This is the passage from the ideal-theoretic to the place-theoretic description of the arithmetic of
+$\overline{\mathbb{Q}}$: a maximal ideal of the ring of all algebraic integers determines a place of
+$\overline{\mathbb{Q}}$, whose valuation subring is the corresponding localisation. It is used
+downstream in the treatment of decomposition groups and Frobenius elements, in particular by the
+statements on existence of Frobenius conjugates and by the characterisation of the valuation subring
+through the condition that all elements have valuation at most one.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_NumberField_exists_valuationSubring_eq_localization.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_NumberField_exists_valuationSubring_eq_localization
+
+open scoped NumberField
+
+local notation "ℚ̄" => AlgebraicClosure ℚ
+
+namespace C6P1T3a
+
+variable (Qt : Ideal (𝓞 ℚ̄)) [Qt.IsMaximal]
+
+def carrier : Set ℚ̄ := {x | ∃ s : 𝓞 ℚ̄, s ∉ Qt ∧ ∃ a : 𝓞 ℚ̄, (s : ℚ̄) * x = a}
+
+omit [Qt.IsMaximal] in
+theorem mem_carrier {x : ℚ̄} :
+    x ∈ carrier Qt ↔ ∃ s : 𝓞 ℚ̄, s ∉ Qt ∧ ∃ a : 𝓞 ℚ̄, (s : ℚ̄) * x = a := Iff.rfl
+
+theorem one_notMem :
+    (1 : 𝓞 ℚ̄) ∉ Qt := fun h => Ideal.IsPrime.ne_top' ((Ideal.eq_top_iff_one Qt).mpr h)
+
+noncomputable def subring : Subring ℚ̄ where
+  carrier := carrier Qt
+  mul_mem' := by
+    rintro x y ⟨s, hs, a, ha⟩ ⟨t, ht, b, hb⟩
+    refine ⟨s * t, fun h => ((Ideal.IsPrime.mem_or_mem inferInstance h).elim hs ht), a * b, ?_⟩
+    simp only [NumberField.RingOfIntegers.coe_eq_algebraMap, map_mul] at ha hb ⊢
+    rw [← ha, ← hb]; ring
+  one_mem' := ⟨1, one_notMem Qt, 1, by simp only [map_one, mul_one]⟩
+  add_mem' := by
+    rintro x y ⟨s, hs, a, ha⟩ ⟨t, ht, b, hb⟩
+    refine ⟨s * t, fun h => ((Ideal.IsPrime.mem_or_mem inferInstance h).elim hs ht), t * a + s * b,
+      ?_⟩
+    simp only [NumberField.RingOfIntegers.coe_eq_algebraMap, map_mul, map_add] at ha hb ⊢
+    rw [← ha, ← hb]; ring
+  zero_mem' := ⟨1, one_notMem Qt, 0, by simp only [map_one, map_zero, mul_zero]⟩
+  neg_mem' := by
+    rintro x ⟨s, hs, a, ha⟩
+    refine ⟨s, hs, -a, ?_⟩
+    simp only [NumberField.RingOfIntegers.coe_eq_algebraMap, map_neg] at ha ⊢
+    rw [← ha]; ring
+
+theorem comap_ne_bot (K : IntermediateField ℚ ℚ̄) [NumberField K] :
+    Qt.comap (algebraMap (𝓞 K) (𝓞 ℚ̄)) ≠ ⊥ := by
+  have : (Qt.under ℤ).IsMaximal := Ideal.IsMaximal.under ℤ Qt
+  have hne : Qt.under ℤ ≠ ⊥ := Ring.ne_bot_of_isMaximal_of_not_isField inferInstance Int.not_isField
+  obtain ⟨n, hn, hn0⟩ := Submodule.exists_mem_ne_zero_of_ne_bot hne
+  rw [Ideal.under_def, Ideal.mem_comap] at hn
+  intro h
+  have hmem : ((n : ℤ) : 𝓞 K) ∈ Qt.comap (algebraMap (𝓞 K) (𝓞 ℚ̄)) := by
+    rw [Ideal.mem_comap, map_intCast]
+    simpa using hn
+  rw [h, Ideal.mem_bot] at hmem
+  exact hn0 (by exact_mod_cast hmem)
+
+theorem mem_or_inv_mem (x : ℚ̄) : x ∈ carrier Qt ∨ x⁻¹ ∈ carrier Qt := by
+  have hx : IsIntegral ℚ x := Algebra.IsIntegral.isIntegral x
+  let K : IntermediateField ℚ ℚ̄ := IntermediateField.adjoin ℚ {x}
+  have : FiniteDimensional ℚ K := IntermediateField.adjoin.finiteDimensional hx
+  have : NumberField K := NumberField.mk
+  have hxK : x ∈ K := IntermediateField.mem_adjoin_simple_self ℚ x
+  let v : IsDedekindDomain.HeightOneSpectrum (𝓞 K) :=
+    ⟨Qt.comap (algebraMap (𝓞 K) (𝓞 ℚ̄)), Ideal.IsPrime.comap _, comap_ne_bot Qt K⟩
+  obtain ⟨n, d, hnd⟩ :=
+    IsDedekindDomain.HeightOneSpectrum.exists_primeCompl_mul_eq_or_mul_eq (K := K) v ⟨x, hxK⟩
+  have hd : algebraMap (𝓞 K) (𝓞 ℚ̄) d ∉ Qt := fun h => d.2 (Ideal.mem_comap.mpr h)
+  have coe_alg : ∀ a : 𝓞 K, ((algebraMap (𝓞 K) (𝓞 ℚ̄) a : 𝓞 ℚ̄) : ℚ̄) = ((algebraMap (𝓞 K) K a : K)
+    : ℚ̄) :=
+    fun _ => rfl
+  rcases hnd with h | h
+  · left
+    refine ⟨algebraMap (𝓞 K) (𝓞 ℚ̄) d, hd, algebraMap (𝓞 K) (𝓞 ℚ̄) n, ?_⟩
+    have := congrArg (fun y : K => (y : ℚ̄)) h
+    simp only [MulMemClass.coe_mul] at this
+    rw [coe_alg, coe_alg, ← this, mul_comm]
+  · right
+    have hK := congrArg (fun y : K => (y : ℚ̄)) h
+    simp only [MulMemClass.coe_mul] at hK
+    have hx0 : x ≠ 0 := by
+      rintro rfl
+      apply d.2
+      have hd0 : (algebraMap (𝓞 K) K (d : 𝓞 K) : K) = 0 := by
+        apply Subtype.ext
+        change ((algebraMap (𝓞 K) K (d : 𝓞 K) : K) : ℚ̄) = 0
+        rw [← hK]; simp
+      have : (d : 𝓞 K) = 0 := (IsFractionRing.injective (𝓞 K) K) (by rw [hd0, map_zero])
+      rw [this]; exact Ideal.zero_mem _
+    refine ⟨algebraMap (𝓞 K) (𝓞 ℚ̄) d, hd, algebraMap (𝓞 K) (𝓞 ℚ̄) n, ?_⟩
+    rw [coe_alg, coe_alg, ← hK, mul_comm x, mul_assoc, mul_inv_cancel₀ hx0, mul_one]
+
+noncomputable def valuationSubring : ValuationSubring ℚ̄ :=
+  { subring Qt with
+    mem_or_inv_mem' := mem_or_inv_mem Qt }
+
+end C6P1T3a
+
+theorem solution
+    (Qt : Ideal (𝓞 (AlgebraicClosure ℚ))) [Qt.IsMaximal] :
+    ∃ A : ValuationSubring (AlgebraicClosure ℚ), ∀ x : AlgebraicClosure ℚ,
+      x ∈ A ↔ ∃ s : 𝓞 (AlgebraicClosure ℚ), s ∉ Qt ∧ ∃ a : 𝓞 (AlgebraicClosure ℚ), (s :
+        AlgebraicClosure ℚ) * x = a :=
+  ⟨C6P1T3a.valuationSubring Qt, fun _ => Iff.rfl⟩
+
+end S_NumberField_exists_valuationSubring_eq_localization
+end P2MW
+export P2MW.S_NumberField_exists_valuationSubring_eq_localization (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped NumberField Pointwise
+
+theorem NumberField.exists_valuationSubring_eq_localization
+    (Qt : Ideal (𝓞 (AlgebraicClosure ℚ))) [Qt.IsMaximal] :
+    ∃ A : ValuationSubring (AlgebraicClosure ℚ), ∀ x : AlgebraicClosure ℚ,
+      x ∈ A ↔ ∃ s : 𝓞 (AlgebraicClosure ℚ), s ∉ Qt ∧ ∃ a : 𝓞 (AlgebraicClosure ℚ), (s :
+        AlgebraicClosure ℚ) * x = a :=
+  solution Qt
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_adicValuation_valuationSubring.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_adicValuation_valuationSubring.lean
new file mode 100644
index 0000000000..e96d53cb44
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_adicValuation_valuationSubring.lean
@@ -0,0 +1,112 @@
+/-
+Based on Prove2Me node P2M.Dup.AlgebraicCurve.Place.adicValuation_valuationSubring
+(646c2de6-b8b8-518d-a699-d3d5314a5847) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 711fba28-6ca8-5319-b522-97c7a2931003
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Valuation subring of a place's adic valuation
+
+Theorem statement: `P2M.Dup.AlgebraicCurve.Place.adicValuation_valuationSubring`
+(`646c2de6-b8b8-518d-a699-d3d5314a5847`), by Claude, 2026-09-05.
+
+Proof: submission `711fba28-6ca8-5319-b522-97c7a2931003`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F/K$ in the sense of
+the project, i.e. the data of a valuation subring $\mathcal{O}_v = v.\mathtt{toValuationSubring}$ of
+$F$ such that the image of every element of $K$ under the structure map $K \to F$ lies in
+$\mathcal{O}_v$, such that $\mathcal{O}_v \neq F$, and such that $\mathcal{O}_v$ is a principal
+ideal ring (so that $\mathcal{O}_v$ is a discrete valuation ring). Attached to $v$ is the height-one
+prime `Place.heightOneSpectrum` of $\mathcal{O}_v$ given by its maximal ideal, and
+`Place.adicValuation` is the associated $\mathbb{Z}^{m0}$-valued valuation on $F$, i.e. the
+$\mathfrak{m}_v$-adic valuation of the Dedekind domain $\mathcal{O}_v$ extended to its fraction
+field $F$. The theorem asserts the equality of valuation subrings of $F$: the valuation subring $\{x
+\in F : v.\mathtt{adicValuation}(x) \le 1\}$ of this adic valuation is equal to $\mathcal{O}_v$
+itself.
+
+This identifies the normalised (discretely valued) valuation canonically attached to a place with
+the place's own valuation ring, so that the two descriptions of a place — as a valuation subring and
+as a $\mathbb{Z}$-valued valuation — agree. It is used in the treatment of the rational function
+field, where places are recognised by their valuation subrings, via
+(`AlgebraicCurve.RationalFunctionField.toValuationSubring_eq_of_forall_ne_ofHeightOneSpectrum`).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_adicValuation_valuationSubring.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_adicValuation_valuationSubring
+
+open IsDedekindDomain WithZero IsLocalRing
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext heightOneSpectrum adicValuation toValuationSubring"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem rowMain :
+    v.adicValuation.valuationSubring = v.toValuationSubring := by
+  ext x
+  rw [Valuation.mem_valuationSubring_iff]
+  constructor
+  · intro hx
+    obtain ⟨a, rfl⟩ := IsDiscreteValuationRing.exists_lift_of_le_one hx
+    exact a.2
+  · intro hx
+    exact v.heightOneSpectrum.valuation_le_one (⟨x, hx⟩ : v.toValuationSubring)
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_Place_adicValuation_valuationSubring.AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) :
+    v.adicValuation.valuationSubring = v.toValuationSubring :=
+  AlgebraicCurve.Place.rowMain v
+
+end S_AlgebraicCurve_Place_adicValuation_valuationSubring
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_adicValuation_valuationSubring (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem P2M.Dup.AlgebraicCurve.Place.adicValuation_valuationSubring {K F : Type*} [Field K]
+    [Field F] [Algebra K F] (v : Place K F) :
+    v.adicValuation.valuationSubring = v.toValuationSubring :=
+  solution v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_exists_ord_pos.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_exists_ord_pos.lean
new file mode 100644
index 0000000000..b38ea22ec4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_exists_ord_pos.lean
@@ -0,0 +1,107 @@
+/-
+Based on Prove2Me node P2M.Dup.AlgebraicCurve.Place.exists_ord_pos
+(7310faff-75cc-51ed-b15c-c65808e99684) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 0deb1c2c-8bbd-5bd0-a674-b56e874c9500
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CharLFrobeniusGeomLevel
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Every place admits an element of positive order
+
+Theorem statement: `P2M.Dup.AlgebraicCurve.Place.exists_ord_pos`
+(`7310faff-75cc-51ed-b15c-c65808e99684`), by Claude, 2026-09-05.
+
+Proof: submission `0deb1c2c-8bbd-5bd0-a674-b56e874c9500`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+sense of the project: a valuation subring $v.\mathrm{toValuationSubring}$ of $F$ which contains the
+image of $K$ under the structure map $K \to F$, which is not the whole of $F$, and which is a
+principal ideal ring. Associated with such a $v$ is the height-one prime of its valuation ring,
+whose $\mathbb{Z}^{m0}$-valued adic valuation $v.\mathrm{adicValuation}$ on $F$ is used to define
+the integer-valued order function $v.\mathrm{ord}\,f =
+-\log\bigl(v.\mathrm{adicValuation}\,f\bigr)$, where $\log$ denotes the chosen identification of the
+value group $\mathbb{Z}^{m0}$ with $\mathbb{Z}$ on nonzero values. The assertion is that there is an
+element $f \in F$ with $f \neq 0$ and $v.\mathrm{ord}\,f > 0$; that is, $F$ contains a nonzero
+element of strictly positive order of vanishing at $v$. No normalisation claim beyond positivity
+($\mathrm{ord}\,f = 1$, say) is made in the conclusion.
+
+This is the basic nondegeneracy statement for places of a function field: the order function
+attached to a place is not identically nonpositive on $F^{\times}$, so a uniformiser exists. It is
+used in the theory of divisors on a curve, in particular in the proofs of the pushforward-norm
+formulae for divisors and of the identity $\sum_{w} e_w f_w = [F':F]$ for places above a given
+place.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_exists_ord_pos.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_exists_ord_pos
+
+open IsDedekindDomain WithZero IsLocalRing
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ord ord_coe_irreducible toValuationSubring"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem rowMain : ∃ f : F, f ≠ 0 ∧ 0 < v.ord f := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  refine ⟨(π : F), ?_, ?_⟩
+  · simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  · rw [v.ord_coe_irreducible hπ]
+    exact one_pos
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve _root_.P2MW.S_AlgebraicCurve_Place_exists_ord_pos.AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) :
+    ∃ f : F, f ≠ 0 ∧ 0 < v.ord f :=
+  AlgebraicCurve.Place.rowMain v
+
+end S_AlgebraicCurve_Place_exists_ord_pos
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_exists_ord_pos (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem P2M.Dup.AlgebraicCurve.Place.exists_ord_pos {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : Place K F) :
+    ∃ f : F, f ≠ 0 ∧ 0 < v.ord f :=
+  solution v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_isEquiv_adicValuation_ofHeightOneSpectrum.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_isEquiv_adicValuation_ofHeightOneSpectrum.lean
new file mode 100644
index 0000000000..3aea7a8121
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_isEquiv_adicValuation_ofHeightOneSpectrum.lean
@@ -0,0 +1,122 @@
+/-
+Based on Prove2Me node P2M.Dup.AlgebraicCurve.Place.isEquiv_adicValuation_ofHeightOneSpectrum
+(528f172d-ca7f-5f6c-81d9-ec2063b49a00) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e74eff09-d23d-5be3-9c3e-765d894317be
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The w-adic valuation is equivalent to its place's valuation
+
+Theorem statement: `P2M.Dup.AlgebraicCurve.Place.isEquiv_adicValuation_ofHeightOneSpectrum`
+(`528f172d-ca7f-5f6c-81d9-ec2063b49a00`), by Claude, 2026-09-05.
+
+Proof: submission `e74eff09-d23d-5be3-9c3e-765d894317be`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $R$ be a Dedekind domain that is an
+$F$-algebra with $F$ as its fraction field, and also a $K$-algebra, the maps $K \to R \to F$ forming
+a scalar tower (so the inclusion $K \subseteq F$ factors through $R$). Let $w$ be a height-one prime
+of $R$. On the one hand there is the $w$-adic valuation `w.valuation F` on $F$, with values in
+$\mathbb{Z}^{m0}$. On the other hand, `Place.ofHeightOneSpectrum w` is the place of $F$ over $K$
+whose underlying valuation subring is the valuation subring of `w.valuation F`: its defining data
+are that this subring contains $\mathrm{algebraMap}_{K,F}(a)$ for all $a \in K$, that it is not all
+of $F$, and that it is a principal ideal ring; and the associated `adicValuation` is the valuation
+on $F$ attached to the maximal ideal of that valuation subring, regarded as a height-one prime of
+it. The assertion is that these two valuations on $F$ are equivalent in the sense of
+`Valuation.IsEquiv`, i.e. they induce the same order relation $v(x) \le v(y)$ on $F$.
+
+This identifies the normalised valuation attached to the place of a height-one prime $w$ of a
+Dedekind domain with the $w$-adic valuation itself, the basic compatibility needed to pass between
+divisors on a curve described by primes of a coordinate ring and divisors described by places of its
+function field. It is used in computing the degree of the place of a height-one prime of the
+rational function field, via
+[`AlgebraicCurve.RationalFunctionField.deg_ofHeightOneSpectrum`]
+(thm.html#AlgebraicCurve.RationalFunctionField.deg_ofHeightOneSpectrum).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_isEquiv_adicValuation_ofHeightOneSpectrum.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_isEquiv_adicValuation_ofHeightOneSpectrum
+
+open IsDedekindDomain WithZero IsLocalRing
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ofHeightOneSpectrum"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext heightOneSpectrum adicValuation ofHeightOneSpectrum \
+  toValuationSubring"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+p2m_export "AlgebraicCurve.Place" "adicValuation_valuationSubring"
+
+p2m_export "AlgebraicCurve.Place" "isEquiv_adicValuation_of_valuationSubring_eq"
+section OfHeightOneSpectrum
+
+variable {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R F] [IsFractionRing R F]
+  [Algebra K R] [IsScalarTower K R F]
+
+private theorem rowMain (w : HeightOneSpectrum R) :
+    (w.valuation F).IsEquiv (ofHeightOneSpectrum (K := K) w).adicValuation :=
+  (ofHeightOneSpectrum (K := K) w).isEquiv_adicValuation_of_valuationSubring_eq rfl
+
+end OfHeightOneSpectrum
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_Place_isEquiv_adicValuation_ofHeightOneSpectrum.AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] {R : Type*} [CommRing R]
+    [IsDedekindDomain R] [Algebra R F] [IsFractionRing R F]
+    [Algebra K R] [IsScalarTower K R F] (w : IsDedekindDomain.HeightOneSpectrum R) :
+    (w.valuation F).IsEquiv (Place.ofHeightOneSpectrum (K := K) w).adicValuation :=
+  AlgebraicCurve.Place.rowMain (K := K) (F := F) w
+
+end S_AlgebraicCurve_Place_isEquiv_adicValuation_ofHeightOneSpectrum
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_isEquiv_adicValuation_ofHeightOneSpectrum (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem P2M.Dup.AlgebraicCurve.Place.isEquiv_adicValuation_ofHeightOneSpectrum {K F : Type*}
+    [Field K] [Field F] [Algebra K F] {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R F]
+    [IsFractionRing R F]
+    [Algebra K R] [IsScalarTower K R F] (w : IsDedekindDomain.HeightOneSpectrum R) :
+    (w.valuation F).IsEquiv (Place.ofHeightOneSpectrum (K := K) w).adicValuation :=
+  solution w
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_isEquiv_adicValuation_of_valuationSubring_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_isEquiv_adicValuation_of_valuationSubring_eq.lean
new file mode 100644
index 0000000000..e9562b6b2d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_isEquiv_adicValuation_of_valuationSubring_eq.lean
@@ -0,0 +1,112 @@
+/-
+Based on Prove2Me node P2M.Dup.AlgebraicCurve.Place.isEquiv_adicValuation_of_valuationSubring_eq
+(10c978df-0cda-523d-ad8c-b753a669abe3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission bbf8958b-b703-5410-8970-74399f7ccbdd
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Equivalence with v's adic valuation from equal valuation rings
+
+Theorem statement: `P2M.Dup.AlgebraicCurve.Place.isEquiv_adicValuation_of_valuationSubring_eq`
+(`10c978df-0cda-523d-ad8c-b753a669abe3`), by Claude, 2026-09-05.
+
+Proof: submission `bbf8958b-b703-5410-8970-74399f7ccbdd`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+sense of the project's structure `Place K F`: a valuation subring $\mathcal{O}_v \subseteq F$
+(recorded as `v.toValuationSubring`) which contains the image of $K$ under the structure map, is not
+all of $F$, and is a principal ideal ring. Attached to $v$ is the height-one prime of
+$\mathcal{O}_v$ given by its maximal ideal, and `v.adicValuation` is the associated
+$\mathbb{Z}^{m0}$-valued valuation on $F$, i.e. the valuation of $F$ determined by that height-one
+prime, with values in $\mathbb{Z}^{m0} = \mathbb{Z}^{\mathrm{multiplicative}}$ adjoined zero. The
+theorem asserts: for any linearly ordered commutative group with zero $\Gamma$ and any valuation $w
+: F \to \Gamma$ whose valuation subring $\{x \in F : w(x) \le 1\}$ coincides with $\mathcal{O}_v$,
+the valuation $w$ is equivalent to `v.adicValuation` in Mathlib's sense (`Valuation.IsEquiv`), that
+is, the two induce the same order relation on $F$, hence differ only by a rescaling of value groups.
+
+This is the standard fact that a valuation on a field is determined up to equivalence by its
+valuation ring, specialised to the normalised (discrete, $\mathbb{Z}$-valued) valuation attached to
+a place of $F/K$. It is used to identify arbitrary valuations with the normalised one, feeding into
+the computation of the order function of a place and into the degree-one criterion for places of a
+rational function field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_isEquiv_adicValuation_of_valuationSubring_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_isEquiv_adicValuation_of_valuationSubring_eq
+
+open IsDedekindDomain WithZero IsLocalRing
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext heightOneSpectrum adicValuation toValuationSubring"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+p2m_export "AlgebraicCurve.Place" "adicValuation_valuationSubring"
+private theorem rowMain {Γ : Type*}
+    [LinearOrderedCommGroupWithZero Γ] {w : Valuation F Γ}
+    (h : w.valuationSubring = v.toValuationSubring) : w.IsEquiv v.adicValuation :=
+  (Valuation.isEquiv_iff_valuationSubring _ _).mpr
+    (h.trans v.adicValuation_valuationSubring.symm)
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_Place_isEquiv_adicValuation_of_valuationSubring_eq.AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) {Γ : Type*}
+    [LinearOrderedCommGroupWithZero Γ] {w : Valuation F Γ}
+    (h : w.valuationSubring = v.toValuationSubring) :
+    w.IsEquiv v.adicValuation :=
+  AlgebraicCurve.Place.rowMain v h
+
+end S_AlgebraicCurve_Place_isEquiv_adicValuation_of_valuationSubring_eq
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_isEquiv_adicValuation_of_valuationSubring_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem P2M.Dup.AlgebraicCurve.Place.isEquiv_adicValuation_of_valuationSubring_eq {K F : Type*}
+    [Field K] [Field F] [Algebra K F] (v : Place K F) {Γ : Type*}
+    [LinearOrderedCommGroupWithZero Γ] {w : Valuation F Γ}
+    (h : w.valuationSubring = v.toValuationSubring) :
+    w.IsEquiv v.adicValuation :=
+  solution v h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_mem_iff_adicValuation_le_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_mem_iff_adicValuation_le_one.lean
new file mode 100644
index 0000000000..7716aac56f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_mem_iff_adicValuation_le_one.lean
@@ -0,0 +1,109 @@
+/-
+Based on Prove2Me node P2M.Dup.AlgebraicCurve.Place.mem_iff_adicValuation_le_one
+(178e8109-545f-5538-87ec-8b136dff080c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2817c4bc-3434-5f96-8550-ad0de37dd8b4
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Membership in a place's valuation ring via v≤ 1
+
+Theorem statement: `P2M.Dup.AlgebraicCurve.Place.mem_iff_adicValuation_le_one`
+(`178e8109-545f-5538-87ec-8b136dff080c`), by Claude, 2026-09-05.
+
+Proof: submission `2817c4bc-3434-5f96-8550-ad0de37dd8b4`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+sense of the project's structure `Place K F`: a valuation subring $\mathcal{O}_v \subseteq F$
+(recorded as `v.toValuationSubring`) which contains the image of $K$ under the structure map, which
+is not the whole of $F$, and which is a principal ideal ring — so that $\mathcal{O}_v$ is a discrete
+valuation ring, with `v.heightOneSpectrum` its maximal ideal viewed as a point of the height-one
+spectrum and `v.adicValuation` the associated $\mathbb{Z}^{m0}$-valued valuation on the fraction
+field $F$, normalised so that a uniformiser has value the image of $-1$ (equivalently, the valuation
+attached to that height-one prime). The theorem asserts, for an arbitrary element $f$ of $F$, the
+equivalence of the two conditions: $f$ lies in the valuation subring $\mathcal{O}_v$, and
+$v.\mathrm{adicValuation}(f) \le 1$ in $\mathbb{Z}^{m0}$. Thus the subring attached to a place
+coincides with the set of elements of valuation at most one for the normalised valuation it
+determines.
+
+This is the elementary compatibility between the two descriptions of a place of a function field —
+as a valuation subring and as a normalised discrete valuation — and it is the bridge used whenever
+the order function of a place is computed from ring membership. It is cited throughout the divisor
+and divisor-class-group material for places of $F/K$, for instance in the determination of degrees
+of points on the rational function field and in the computation of the first cohomology of the
+structure sheaf.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_mem_iff_adicValuation_le_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_mem_iff_adicValuation_le_one
+
+open IsDedekindDomain WithZero IsLocalRing
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext heightOneSpectrum adicValuation toValuationSubring"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+p2m_export "AlgebraicCurve.Place" "adicValuation_valuationSubring"
+private theorem rowMain {f : F} :
+    f ∈ v.toValuationSubring ↔ v.adicValuation f ≤ 1 := by
+  rw [← v.adicValuation_valuationSubring]
+  exact Valuation.mem_valuationSubring_iff _ _
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_Place_mem_iff_adicValuation_le_one.AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) {f : F} :
+    f ∈ v.toValuationSubring ↔ v.adicValuation f ≤ 1 :=
+  AlgebraicCurve.Place.rowMain v
+
+end S_AlgebraicCurve_Place_mem_iff_adicValuation_le_one
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_mem_iff_adicValuation_le_one (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem P2M.Dup.AlgebraicCurve.Place.mem_iff_adicValuation_le_one {K F : Type*} [Field K] [Field F]
+    [Algebra K F] (v : Place K F) {f : F} :
+    f ∈ v.toValuationSubring ↔ v.adicValuation f ≤ 1 :=
+  solution v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_mem_iff_ord_nonneg.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_mem_iff_ord_nonneg.lean
new file mode 100644
index 0000000000..e3ac775ada
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_mem_iff_ord_nonneg.lean
@@ -0,0 +1,110 @@
+/-
+Based on Prove2Me node P2M.Dup.AlgebraicCurve.Place.mem_iff_ord_nonneg
+(9df28f64-daf8-58d2-9abd-1f4ba1354da6) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 570ca25e-0ed9-53ed-a879-4a9919f80f4f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CharLFrobeniusGeomLevel
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Valuation ring membership iff non-negative order
+
+Theorem statement: `P2M.Dup.AlgebraicCurve.Place.mem_iff_ord_nonneg`
+(`9df28f64-daf8-58d2-9abd-1f4ba1354da6`), by Claude, 2026-09-05.
+
+Proof: submission `570ca25e-0ed9-53ed-a879-4a9919f80f4f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+sense of the project notion `Place`: a valuation subring $\mathcal{O}_v$ of $F$ (recorded as
+`v.toValuationSubring`) which contains the image of $K$ under the structure map $K \to F$, is not
+all of $F$, and is a principal ideal ring. For an element $f$ of $F$ assumed non-zero, the theorem
+asserts the equivalence of the following two statements: $f$ lies in the valuation subring
+$\mathcal{O}_v$, and $0 \le v.\mathrm{ord}(f)$, where $v.\mathrm{ord}(f)$ is the integer $-\log$ of
+the value of $f$ under the adic valuation of $v$, i.e. $\mathrm{ord}(f) =
+-\log\big(v_{\mathcal{O}_v}(f)\big)$ with $v_{\mathcal{O}_v} \colon F \to \mathbb{Z}^{m0}$ the
+valuation attached to the height-one prime of $\mathcal{O}_v$ (`Place.adicValuation`, defined as the
+`HeightOneSpectrum` valuation of `v.heightOneSpectrum` on $F$) and $\log$ the `WithZero` logarithm.
+Thus the integer-valued order function of a place detects, by its sign, membership in the local ring
+of the place.
+
+This is the standard compatibility between the valuation ring of a place of a function field and its
+normalised order function: $\mathcal{O}_v = \{f : \mathrm{ord}_v(f) \ge 0\}$ on non-zero elements.
+It is a basic tool in the project's treatment of places, divisors and the divisor class group, and
+is invoked throughout the development of annuli, charts and residues on curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_mem_iff_ord_nonneg.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_mem_iff_ord_nonneg
+
+open IsDedekindDomain WithZero IsLocalRing
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ord ord_unit_smul_zpow exists_unit_mul_zpow toValuationSubring"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+
+p2m_export "AlgebraicCurve.Place" "ord_nonneg_of_mem"
+
+p2m_export "AlgebraicCurve.Place" "mem_of_ord_nonneg"
+private theorem rowMain {f : F} (hf : f ≠ 0) :
+    f ∈ v.toValuationSubring ↔ 0 ≤ v.ord f :=
+  ⟨v.ord_nonneg_of_mem, v.mem_of_ord_nonneg hf⟩
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve _root_.P2MW.S_AlgebraicCurve_Place_mem_iff_ord_nonneg.AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) {f : F}
+    (hf : f ≠ 0) :
+    f ∈ v.toValuationSubring ↔ 0 ≤ v.ord f :=
+  AlgebraicCurve.Place.rowMain v hf
+
+end S_AlgebraicCurve_Place_mem_iff_ord_nonneg
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_mem_iff_ord_nonneg (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem P2M.Dup.AlgebraicCurve.Place.mem_iff_ord_nonneg {K F : Type*} [Field K] [Field F]
+    [Algebra K F] (v : Place K F) {f : F} (hf : f ≠ 0) :
+    f ∈ v.toValuationSubring ↔ 0 ≤ v.ord f :=
+  solution v hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_mem_maximalIdeal_iff_adicValuation_lt_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_mem_maximalIdeal_iff_adicValuation_lt_one.lean
new file mode 100644
index 0000000000..6f5ef359ea
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_mem_maximalIdeal_iff_adicValuation_lt_one.lean
@@ -0,0 +1,111 @@
+/-
+Based on Prove2Me node P2M.Dup.AlgebraicCurve.Place.mem_maximalIdeal_iff_adicValuation_lt_one
+(a8e08be7-d4e9-541b-96b8-7d67bcaa2dc7) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9f6c4921-a863-5e79-9897-bccdf869b69b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Maximal ideal of a place: v-valuation <1
+
+Theorem statement: `P2M.Dup.AlgebraicCurve.Place.mem_maximalIdeal_iff_adicValuation_lt_one`
+(`a8e08be7-d4e9-541b-96b8-7d67bcaa2dc7`), by Claude, 2026-09-05.
+
+Proof: submission `9f6c4921-a863-5e79-9897-bccdf869b69b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+sense of the project's structure `Place K F`: a valuation subring $\mathcal{O}_v \subseteq F$
+(written `v.toValuationSubring`) which contains the image of $K$ under the structure map, is not all
+of $F$, and is a principal ideal ring. Since $\mathcal{O}_v$ is then a discrete valuation ring, its
+maximal ideal determines a point `v.heightOneSpectrum` of the height-one spectrum of
+$\mathcal{O}_v$, and `v.adicValuation` denotes the associated $\mathbb{Z}^{m0}$-valued valuation on
+the fraction field $F$. The assertion is that for an element $a$ of the subring $\mathcal{O}_v$, the
+element $a$ lies in the maximal ideal of the local ring $\mathcal{O}_v$ if and only if the value of
+`v.adicValuation` at the image of $a$ in $F$ is strictly less than $1$.
+
+This is the standard identification of the maximal ideal of the valuation ring of a place with the
+set of elements of positive valuation, in the form needed to pass between ideal-theoretic and
+valuation-theoretic descriptions of a place. It is used in the development of places, divisors and
+the divisor class group of a function field, for instance in the computation of places of the
+rational function field and in statements about evaluation at a place.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_mem_maximalIdeal_iff_adicValuation_lt_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_mem_maximalIdeal_iff_adicValuation_lt_one
+
+open IsDedekindDomain WithZero IsLocalRing
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext heightOneSpectrum adicValuation \
+  adicValuation_coe_eq_one_iff toValuationSubring"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+p2m_export "AlgebraicCurve.Place" "adicValuation_valuationSubring"
+
+p2m_export "AlgebraicCurve.Place" "mem_iff_adicValuation_le_one"
+private theorem rowMain (a : v.toValuationSubring) :
+    a ∈ IsLocalRing.maximalIdeal v.toValuationSubring ↔ v.adicValuation (a : F) < 1 := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff, ← v.adicValuation_coe_eq_one_iff,
+    lt_iff_le_and_ne]
+  have hle : v.adicValuation (a : F) ≤ 1 := v.mem_iff_adicValuation_le_one.mp a.2
+  tauto
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_Place_mem_maximalIdeal_iff_adicValuation_lt_one.AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+    (a : v.toValuationSubring) :
+    a ∈ IsLocalRing.maximalIdeal v.toValuationSubring ↔ v.adicValuation (a : F) < 1 :=
+  AlgebraicCurve.Place.rowMain v a
+
+end S_AlgebraicCurve_Place_mem_maximalIdeal_iff_adicValuation_lt_one
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_mem_maximalIdeal_iff_adicValuation_lt_one (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem P2M.Dup.AlgebraicCurve.Place.mem_maximalIdeal_iff_adicValuation_lt_one {K F : Type*}
+    [Field K] [Field F] [Algebra K F] (v : Place K F) (a : v.toValuationSubring) :
+    a ∈ IsLocalRing.maximalIdeal v.toValuationSubring ↔ v.adicValuation (a : F) < 1 :=
+  solution v a
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_mem_of_ord_nonneg.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_mem_of_ord_nonneg.lean
new file mode 100644
index 0000000000..725a33adc7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_mem_of_ord_nonneg.lean
@@ -0,0 +1,106 @@
+/-
+Based on Prove2Me node P2M.Dup.AlgebraicCurve.Place.mem_of_ord_nonneg
+(ca37e605-477f-5084-ad18-3b7e34e8f02e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 0bf989c1-a311-581e-9cc2-ca7143ec471a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CharLFrobeniusGeomLevel
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Nonnegative order implies membership in the valuation ring
+
+Theorem statement: `P2M.Dup.AlgebraicCurve.Place.mem_of_ord_nonneg`
+(`ca37e605-477f-5084-ad18-3b7e34e8f02e`), by Claude, 2026-09-05.
+
+Proof: submission `0bf989c1-a311-581e-9cc2-ca7143ec471a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+sense of the project's structure `Place K F`: a valuation subring $v.\mathrm{toValuationSubring}$ of
+$F$ which contains the image of $K$ under the structure map, which is not the whole of $F$, and
+whose underlying ring is a principal ideal ring. Let $f \in F$ be nonzero and suppose that the
+integer $v.\mathrm{ord}\,f$ is nonnegative, where $v.\mathrm{ord}$ is defined as minus the logarithm
+(in the sense of `WithZero.log`, with values in $\mathbb{Z}$) of the value
+$v.\mathrm{adicValuation}\,f \in \mathbb{Z}^{m0}$, and $v.\mathrm{adicValuation}$ is the adic
+valuation on $F$ attached to the height-one prime `v.heightOneSpectrum` associated with the place.
+The conclusion is that $f$ belongs to the valuation subring $v.\mathrm{toValuationSubring}$.
+
+This is the elementary compatibility between the integer-valued order function attached to a place
+and membership in its valuation ring: an element with no pole at $v$ is regular at $v$. It serves as
+a basic tool throughout the divisor-theoretic part of the development, being invoked in the
+treatment of annuli, residues and divisors on curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_mem_of_ord_nonneg.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_mem_of_ord_nonneg
+
+open IsDedekindDomain WithZero IsLocalRing
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ord exists_unit_mul_zpow toValuationSubring"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem rowMain {f : F} (hf : f ≠ 0) (h : 0 ≤ v.ord f) :
+    f ∈ v.toValuationSubring := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ
+  rw [hu, show v.ord f = (((v.ord f).toNat : ℕ) : ℤ) from (Int.toNat_of_nonneg h).symm,
+    zpow_natCast]
+  exact mul_mem (u : v.toValuationSubring).2 (pow_mem (π : v.toValuationSubring).2 _)
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve _root_.P2MW.S_AlgebraicCurve_Place_mem_of_ord_nonneg.AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) {f : F}
+    (hf : f ≠ 0) (h : 0 ≤ v.ord f) :
+    f ∈ v.toValuationSubring :=
+  AlgebraicCurve.Place.rowMain v hf h
+
+end S_AlgebraicCurve_Place_mem_of_ord_nonneg
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_mem_of_ord_nonneg (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem P2M.Dup.AlgebraicCurve.Place.mem_of_ord_nonneg {K F : Type*} [Field K] [Field F]
+    [Algebra K F] (v : Place K F) {f : F} (hf : f ≠ 0) (h : 0 ≤ v.ord f) :
+    f ∈ v.toValuationSubring :=
+  solution v hf h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_ord_eq_zero_iff_adicValuation_eq_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_ord_eq_zero_iff_adicValuation_eq_one.lean
new file mode 100644
index 0000000000..400d4bad91
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_ord_eq_zero_iff_adicValuation_eq_one.lean
@@ -0,0 +1,115 @@
+/-
+Based on Prove2Me node P2M.Dup.AlgebraicCurve.Place.ord_eq_zero_iff_adicValuation_eq_one
+(543bb235-c2f6-5043-93bd-8f039c096e0f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a801c400-863a-5678-ab07-8344d9328e2c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order zero at a place iff adic valuation one
+
+Theorem statement: `P2M.Dup.AlgebraicCurve.Place.ord_eq_zero_iff_adicValuation_eq_one`
+(`543bb235-c2f6-5043-93bd-8f039c096e0f`), by Claude, 2026-09-05.
+
+Proof: submission `a801c400-863a-5678-ab07-8344d9328e2c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$, that is, a
+valuation subring $\mathcal{O}_v \subseteq F$ containing the image of $K$ under the structure map,
+distinct from all of $F$, and whose underlying ring is a principal ideal ring (hence a discrete
+valuation ring). Attached to $v$ is its height-one prime, the maximal ideal of $\mathcal{O}_v$, and
+the induced valuation $v.\mathrm{adicValuation} : F \to \mathbb{Z}^{m0}$, the valuation on the
+fraction field $F$ associated with that height-one prime, with values in $\mathbb{Z}$ written
+multiplicatively and adjoined zero; the order function is $v.\mathrm{ord}(f) =
+-\log\big(v.\mathrm{adicValuation}(f)\big) \in \mathbb{Z}$, where $\log$ is the inverse of the
+multiplicative-to-additive identification, sending the adjoined zero to $0$. The theorem asserts
+that for every $f \in F$ with $f \neq 0$ one has $v.\mathrm{ord}(f) = 0$ if and only if
+$v.\mathrm{adicValuation}(f) = 1$. The hypothesis $f \neq 0$ is what rules out the degenerate
+direction, since the adic valuation of $0$ is the adjoined zero element, whose logarithm is also
+$0$.
+
+This is the elementary compatibility between the additive order of vanishing at a place and the
+multiplicatively written adic valuation: a nonzero function is a unit at $v$ exactly when its order
+is zero. It is used in the divisor-theoretic part of the development, for instance in the norm
+formula for pushforwards of divisors and in recognising unramified places from divisibility
+properties of orders.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ord_eq_zero_iff_adicValuation_eq_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ord_eq_zero_iff_adicValuation_eq_one
+
+open IsDedekindDomain WithZero IsLocalRing
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "adicValuation adicValuation_ne_zero ord"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem rowMain {f : F} (hf : f ≠ 0) :
+    v.ord f = 0 ↔ v.adicValuation f = 1 := by
+  simp only [ord, neg_eq_zero]
+  constructor
+  · intro h
+    have h2 := exp_log (v.adicValuation_ne_zero hf)
+    rw [h, exp_zero] at h2
+    exact h2.symm
+  · intro h
+    rw [h, log_one]
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_Place_ord_eq_zero_iff_adicValuation_eq_one.AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) {f : F}
+    (hf : f ≠ 0) :
+    v.ord f = 0 ↔ v.adicValuation f = 1 :=
+  AlgebraicCurve.Place.rowMain v hf
+
+end S_AlgebraicCurve_Place_ord_eq_zero_iff_adicValuation_eq_one
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ord_eq_zero_iff_adicValuation_eq_one (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem P2M.Dup.AlgebraicCurve.Place.ord_eq_zero_iff_adicValuation_eq_one {K F : Type*} [Field K]
+    [Field F] [Algebra K F] (v : Place K F) {f : F} (hf : f ≠ 0) :
+    v.ord f = 0 ↔ v.adicValuation f = 1 :=
+  solution v hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_ord_neg.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_ord_neg.lean
new file mode 100644
index 0000000000..e048909d7a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_ord_neg.lean
@@ -0,0 +1,95 @@
+/-
+Based on Prove2Me node P2M.Dup.AlgebraicCurve.Place.ord_neg
+(8c0b10a2-5676-5352-854d-dc714c96fb0c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 096a7292-b89a-5d87-88d4-edf06a37980d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Invariance of ordᵥ under negation
+
+Theorem statement: `P2M.Dup.AlgebraicCurve.Place.ord_neg` (`8c0b10a2-5676-5352-854d-dc714c96fb0c`),
+by Claude, 2026-09-05.
+
+Proof: submission `096a7292-b89a-5d87-88d4-edf06a37980d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+sense of the project's structure
+[`AlgebraicCurve.Place`](def/AlgebraicCurve_DivisorClassGroup.html#L22): a valuation subring of $F$
+containing the image of $K$ under the structure map, distinct from all of $F$, and a principal ideal
+ring. Attached to $v$ is the valuation
+[`AlgebraicCurve.Place.adicValuation`](def/AlgebraicCurve_DivisorClassGroup.html#L102), the
+$\mathbb{Z}^{m0}$-valued adic valuation of the height one prime of $v$, and the integer-valued order
+function $\operatorname{ord}_v(f) = -\log(v_{\mathrm{adic}}(f))$, where $\log$ is the `WithZero`
+logarithm (so that the value $0$ of the valuation, in particular at $f = 0$, contributes
+$\operatorname{ord}_v = 0$). The theorem asserts that for every $f \in F$, with no further
+hypotheses on $f$ and in particular with no assumption on the characteristic,
+$\operatorname{ord}_v(-f) = \operatorname{ord}_v(f)$; the case $f = 0$ is included, both sides then
+being $0$ by the stated convention.
+
+A routine ultrametric normalisation fact for the order function of a place, recording that
+$\operatorname{ord}_v$ is insensitive to sign. It is used throughout the divisor-theoretic
+development of curves, for instance in the statements about the existence of elements with
+prescribed valuations of differences and in the computations of orders of differentials.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ord_neg.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ord_neg
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ord_algebraMap"
+namespace FF2S
+p2m_open "AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem ord_neg (v : Place K F) (f : F) : v.ord (-f) = v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · simp
+  · rw [neg_eq_neg_one_mul, v.ord_mul (neg_ne_zero.mpr one_ne_zero) hf,
+      show (-1 : F) = algebraMap K F (-1) by simp, v.ord_algebraMap, zero_add]
+
+end AlgebraicCurve.FF2S
+
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : AlgebraicCurve.Place K F)
+    (f : F) :
+    v.ord (-f) = v.ord f :=
+  AlgebraicCurve.FF2S.ord_neg v f
+
+end S_AlgebraicCurve_Place_ord_neg
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ord_neg (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem P2M.Dup.AlgebraicCurve.Place.ord_neg {K F : Type*} [Field K] [Field F] [Algebra K F]
+    (v : AlgebraicCurve.Place K F) (f : F) :
+    v.ord (-f) = v.ord f :=
+  solution v f
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_ord_nonneg_of_mem.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_ord_nonneg_of_mem.lean
new file mode 100644
index 0000000000..f0daa3e195
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_ord_nonneg_of_mem.lean
@@ -0,0 +1,115 @@
+/-
+Based on Prove2Me node P2M.Dup.AlgebraicCurve.Place.ord_nonneg_of_mem
+(d307b413-b474-5236-96cb-fbb209d1d14d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 69a5c075-6561-5c56-8dd1-75954bd43a3d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CharLFrobeniusGeomLevel
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Elements of a place's valuation ring have nonnegative order
+
+Theorem statement: `P2M.Dup.AlgebraicCurve.Place.ord_nonneg_of_mem`
+(`d307b413-b474-5236-96cb-fbb209d1d14d`), by Claude, 2026-09-05.
+
+Proof: submission `69a5c075-6561-5c56-8dd1-75954bd43a3d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $v$ be a place of $F$ over $K$ in the
+sense of the project's structure `Place K F`: a valuation subring $\mathcal{O}_v \subseteq F$,
+written `v.toValuationSubring`, which contains the image of $K$ under the structure map, is not all
+of $F$, and whose ring structure is that of a principal ideal ring. Associated with $v$ is the
+valuation `v.adicValuation`, the $\mathbb{Z}^{m0}$-valued valuation on $F$ attached to the
+height-one prime determined by $v$, and the integer-valued order function $\mathrm{ord}_v(f) =
+-\log\bigl(v.\mathrm{adicValuation}(f)\bigr)$, where $\log$ is the logarithm map from
+$\mathbb{Z}^{m0} = \mathbb{Z} \cup \{0\}$ (multiplicatively written, with zero) to $\mathbb{Z}$. The
+assertion is that for every $f \in F$ lying in the valuation subring `v.toValuationSubring` one has
+$0 \le \mathrm{ord}_v(f)$, that is, the order of $f$ at $v$ is nonnegative.
+
+This is the basic compatibility between membership in the local ring at a place and nonnegativity of
+the order of vanishing there, in the setting of places of a function field $F/K$ used to build
+divisors and the degree-zero divisor class group. It is invoked throughout the divisor-theoretic
+part of the development, for instance in the estimates relating degrees of divisors to dimensions of
+spaces of functions and in the analysis of annuli and of local parameters.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ord_nonneg_of_mem.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ord_nonneg_of_mem
+
+open IsDedekindDomain WithZero IsLocalRing
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ord ord_unit_smul_zpow toValuationSubring"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem rowMain {f : F} (hf : f ∈ v.toValuationSubring) : 0 ≤ v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf0
+  · simp
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨n, u, hu⟩ :=
+    IsDiscreteValuationRing.eq_unit_mul_pow_irreducible
+      (x := (⟨f, hf⟩ : v.toValuationSubring)) (by simpa [Subtype.ext_iff] using hf0) hπ
+  have hcoe : f = ((u : v.toValuationSubring) : F) * ((π : F) ^ (n : ℤ)) := by
+    have h := congrArg (Subtype.val) hu
+    push_cast at h
+    rw [zpow_natCast]
+    exact h
+  rw [hcoe, v.ord_unit_smul_zpow u hπ (n : ℤ)]
+  exact Int.natCast_nonneg n
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve _root_.P2MW.S_AlgebraicCurve_Place_ord_nonneg_of_mem.AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F) {f : F}
+    (hf : f ∈ v.toValuationSubring) :
+    0 ≤ v.ord f :=
+  AlgebraicCurve.Place.rowMain v hf
+
+end S_AlgebraicCurve_Place_ord_nonneg_of_mem
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ord_nonneg_of_mem (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem P2M.Dup.AlgebraicCurve.Place.ord_nonneg_of_mem {K F : Type*} [Field K] [Field F]
+    [Algebra K F] (v : Place K F) {f : F} (hf : f ∈ v.toValuationSubring) :
+    0 ≤ v.ord f :=
+  solution v hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_ord_ofHeightOneSpectrum_ne_zero_iff.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_ord_ofHeightOneSpectrum_ne_zero_iff.lean
new file mode 100644
index 0000000000..7ee2bb8c4b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_Place_ord_ofHeightOneSpectrum_ne_zero_iff.lean
@@ -0,0 +1,130 @@
+/-
+Based on Prove2Me node P2M.Dup.AlgebraicCurve.Place.ord_ofHeightOneSpectrum_ne_zero_iff
+(f4087ed2-76b0-55fc-b089-42687d780882) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5a76c5a1-f457-5eb8-8142-b4e7933bc2ce
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Order at the place of w is nonzero exactly on w
+
+Theorem statement: `P2M.Dup.AlgebraicCurve.Place.ord_ofHeightOneSpectrum_ne_zero_iff`
+(`f4087ed2-76b0-55fc-b089-42687d780882`), by Claude, 2026-09-05.
+
+Proof: submission `5a76c5a1-f457-5eb8-8142-b4e7933bc2ce`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ and $F$ be fields with $F$ a $K$-algebra, and let $R$ be a commutative ring which is a
+Dedekind domain, equipped with an $R$-algebra structure on $F$ exhibiting $F$ as the fraction field
+of $R$, together with a $K$-algebra structure on $R$ compatible with the given one on $F$ (a scalar
+tower $K \to R \to F$). Let $w$ be a height-one prime of $R$ and let $q \in R$ be nonzero. Consider
+the place `Place.ofHeightOneSpectrum w` of $F$ over $K$, that is, the datum consisting of the
+valuation subring of the $w$-adic valuation of $F$ together with the facts that $K$ maps into it,
+that it is not all of $F$, and that it is a principal ideal ring. For a place $v$, the integer
+$v.\mathrm{ord}(f)$ is by definition $-\log$ of the value at $f$ of the $\mathbb{Z}^{m0}$-valued
+valuation attached to the height-one prime of the valuation subring of $v$. The assertion is that
+$\mathrm{ord}$ of the image of $q$ in $F$ at this place is nonzero if and only if $q$ lies in the
+ideal underlying $w$.
+
+This identifies the support of the divisor of a nonzero element of a Dedekind domain inside its
+fraction field: the place attached to a height-one prime $w$ occurs in the divisor of $q$ precisely
+when $w \mid q$. It is used in the treatment of divisors on the rational function field, in the
+proofs that a divisor all of whose multiplicities come from a single element has degree zero and
+that such a divisor is principal, and in a naive height computation on the modular curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_Place_ord_ofHeightOneSpectrum_ne_zero_iff.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_Place_ord_ofHeightOneSpectrum_ne_zero_iff
+
+open IsDedekindDomain WithZero IsLocalRing
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ofHeightOneSpectrum"
+p2m_open "AlgebraicCurve"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext heightOneSpectrum adicValuation adicValuation_ne_zero ord \
+  ofHeightOneSpectrum toValuationSubring"
+p2m_open "AlgebraicCurve.Place"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+p2m_export "AlgebraicCurve.Place" "adicValuation_valuationSubring"
+
+p2m_export "AlgebraicCurve.Place" "isEquiv_adicValuation_of_valuationSubring_eq"
+
+p2m_export "AlgebraicCurve.Place" "ord_eq_zero_iff_adicValuation_eq_one"
+section OfHeightOneSpectrum
+
+variable {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R F] [IsFractionRing R F]
+  [Algebra K R] [IsScalarTower K R F]
+
+private theorem isEquiv_adicValuation_ofHeightOneSpectrum (w : HeightOneSpectrum R) :
+    (w.valuation F).IsEquiv (ofHeightOneSpectrum (K := K) w).adicValuation :=
+  (ofHeightOneSpectrum (K := K) w).isEquiv_adicValuation_of_valuationSubring_eq rfl
+
+private theorem rowMain (w : HeightOneSpectrum R) {q : R} (hq : q ≠ 0) :
+    (ofHeightOneSpectrum (K := K) (F := F) w).ord (algebraMap R F q) ≠ 0 ↔ q ∈ w.asIdeal := by
+  have hq' : algebraMap R F q ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective R F)).mpr hq
+  rw [ne_eq, (ofHeightOneSpectrum (K := K) w).ord_eq_zero_iff_adicValuation_eq_one hq',
+    ← (isEquiv_adicValuation_ofHeightOneSpectrum (K := K) (F := F) w).eq_one_iff_eq_one,
+    HeightOneSpectrum.valuation_eq_one_iff_notMem, not_not]
+
+end OfHeightOneSpectrum
+
+end Place
+
+end AlgebraicCurve
+
+end
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_AlgebraicCurve_Place_ord_ofHeightOneSpectrum_ne_zero_iff.AlgebraicCurve in
+theorem solution {K F : Type*} [Field K] [Field F] [Algebra K F] {R : Type*} [CommRing R]
+    [IsDedekindDomain R] [Algebra R F] [IsFractionRing R F]
+    [Algebra K R] [IsScalarTower K R F] (w : IsDedekindDomain.HeightOneSpectrum R) {q : R}
+    (hq : q ≠ 0) :
+    (Place.ofHeightOneSpectrum (K := K) (F := F) w).ord (algebraMap R F q) ≠ 0 ↔ q ∈ w.asIdeal :=
+  AlgebraicCurve.Place.rowMain (K := K) (F := F) w hq
+
+end S_AlgebraicCurve_Place_ord_ofHeightOneSpectrum_ne_zero_iff
+end P2MW
+export P2MW.S_AlgebraicCurve_Place_ord_ofHeightOneSpectrum_ne_zero_iff (solution)
+
+end privateSection
+
+public section publicSection
+
+open AlgebraicCurve
+theorem P2M.Dup.AlgebraicCurve.Place.ord_ofHeightOneSpectrum_ne_zero_iff {K F : Type*} [Field K]
+    [Field F] [Algebra K F] {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R F]
+    [IsFractionRing R F] [Algebra K R] [IsScalarTower K R F]
+    (w : IsDedekindDomain.HeightOneSpectrum R) {q : R} (hq : q ≠ 0) :
+    (Place.ofHeightOneSpectrum (K := K) (F := F) w).ord (algebraMap R F q) ≠ 0 ↔ q ∈ w.asIdeal :=
+  _root_.P2MW.S_AlgebraicCurve_Place_ord_ofHeightOneSpectrum_ne_zero_iff.solution w hq
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_deg_ofHeightOneSpectrum.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_deg_ofHeightOneSpectrum.lean
new file mode 100644
index 0000000000..cfb2659330
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_deg_ofHeightOneSpectrum.lean
@@ -0,0 +1,202 @@
+/-
+Based on Prove2Me node P2M.Dup.AlgebraicCurve.RationalFunctionField.deg_ofHeightOneSpectrum
+(5af0de55-e9d0-5053-9710-3cae70f4b9b2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 25afb3a3-646e-530e-9ea5-650c775aa3e1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.RatFunc.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+
+import Mathlib.RingTheory.AdjoinRoot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_iff_adicValuation_le_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_mem_maximalIdeal_iff_adicValuation_lt_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_Place_isEquiv_adicValuation_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree of a finite place of K(t) equals deg p
+
+Theorem statement: `P2M.Dup.AlgebraicCurve.RationalFunctionField.deg_ofHeightOneSpectrum`
+(`5af0de55-e9d0-5053-9710-3cae70f4b9b2`), by Claude, 2026-09-05.
+
+Proof: submission `25afb3a3-646e-530e-9ea5-650c775aa3e1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $w$ be a height-one prime of the polynomial ring $K[X]$, and let $p \in
+K[X]$ be a polynomial generating it, i.e. $w.\mathrm{asIdeal} = (p)$. Consider the place of the
+rational function field $\mathrm{RatFunc}\,K$ over $K$ obtained from $w$ by
+`Place.ofHeightOneSpectrum`: here a `Place K F` is a valuation subring of $F$ containing the image
+of $K$ under the structure map, different from the whole of $F$, and a principal ideal ring; the
+place attached to $w$ is the valuation subring of the $w$-adic valuation of $\mathrm{RatFunc}\,K$.
+Its degree `Place.deg` is by definition the $K$-dimension $\operatorname{finrank}_K$ of the residue
+field of that valuation subring, i.e. of the quotient by its maximal ideal. The assertion is that
+this degree equals the natural-number degree $\deg p$ of the chosen generator. No irreducibility or
+monicity of $p$ is assumed separately: both follow from $w.\mathrm{asIdeal}$ being a nonzero prime
+ideal with generator $p$.
+
+This is the computation of the degree of a finite place of the rational function field $K(t)/K$: the
+place associated with a height-one prime $(p)$ of $K[X]$ has residue field $K[X]/(p)$ and hence
+degree $\deg p$. It is used in this development to show that the degrees of places of $K(t)$ are
+nonzero and in the analysis of divisors of degree zero on the rational function field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_deg_ofHeightOneSpectrum.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_RationalFunctionField_deg_ofHeightOneSpectrum
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_AlgebraicCurve_RationalFunctionField_deg_ofHeightOneSpectrum.AlgebraicCurve"
+open IsDedekindDomain WithZero IsLocalRing
+open scoped Polynomial
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.deg Place.ofHeightOneSpectrum \
+  Place.mem_iff_adicValuation_le_one Place.mem_maximalIdeal_iff_adicValuation_lt_one \
+  Place.isEquiv_adicValuation_ofHeightOneSpectrum"
+namespace RationalFunctionField
+p2m_open "AlgebraicCurve"
+
+namespace WFf
+variable (K : Type*) [Field K]
+
+theorem algebraMap_mem_ofHeightOneSpectrum (w : HeightOneSpectrum K[X]) (q : K[X]) :
+    algebraMap K[X] (RatFunc K) q ∈
+      (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).toValuationSubring :=
+  (Place.mem_iff_adicValuation_le_one _).mpr
+    ((Place.isEquiv_adicValuation_ofHeightOneSpectrum (K := K)
+      (F := RatFunc K) w).le_one_iff_le_one.mp (w.valuation_le_one q))
+
+def residueOfHeightOneSpectrum (w : HeightOneSpectrum K[X]) :
+    K[X] →+* (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ResidueField :=
+  (IsLocalRing.residue _).comp
+    ((algebraMap K[X] (RatFunc K)).codRestrict
+      (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).toValuationSubring.toSubring
+      (algebraMap_mem_ofHeightOneSpectrum K w))
+
+theorem residueOfHeightOneSpectrum_apply (w : HeightOneSpectrum K[X]) (q : K[X]) :
+    residueOfHeightOneSpectrum K w q = IsLocalRing.residue _
+      ⟨algebraMap K[X] (RatFunc K) q, algebraMap_mem_ofHeightOneSpectrum K w q⟩ := rfl
+
+theorem ker_residueOfHeightOneSpectrum (w : HeightOneSpectrum K[X]) :
+    RingHom.ker (residueOfHeightOneSpectrum K w) = w.asIdeal := by
+  ext q
+  rw [RingHom.mem_ker, residueOfHeightOneSpectrum_apply, IsLocalRing.residue_eq_zero_iff,
+    Place.mem_maximalIdeal_iff_adicValuation_lt_one,
+    ← (Place.isEquiv_adicValuation_ofHeightOneSpectrum (K := K)
+      (F := RatFunc K) w).lt_one_iff_lt_one]
+  exact HeightOneSpectrum.valuation_lt_one_iff_mem w q
+
+theorem surjective_residueOfHeightOneSpectrum (w : HeightOneSpectrum K[X]) :
+    Function.Surjective (residueOfHeightOneSpectrum K w) := by
+  intro y
+  obtain ⟨⟨x, hx⟩, rfl⟩ := IsLocalRing.residue_surjective y
+  have hxval : w.valuation (RatFunc K) x ≤ 1 :=
+    (Place.isEquiv_adicValuation_ofHeightOneSpectrum (K := K)
+      (F := RatFunc K) w).le_one_iff_le_one.mpr ((Place.mem_iff_adicValuation_le_one _).mp hx)
+  have hden_ne : algebraMap K[X] (RatFunc K) x.denom ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr x.denom_ne_zero
+  have hmul : x * algebraMap K[X] (RatFunc K) x.denom = algebraMap K[X] (RatFunc K) x.num :=
+    ((div_eq_iff hden_ne).mp x.num_div_denom).symm
+  have hden : x.denom ∉ w.asIdeal := by
+    intro hd
+    have hnum : x.num ∉ w.asIdeal := by
+      intro hn
+      refine w.isPrime.ne_top ((Ideal.eq_top_iff_one _).mpr ?_)
+      obtain ⟨a, b, hab⟩ := RatFunc.isCoprime_num_denom x
+      exact hab ▸ Ideal.add_mem _ (Ideal.mul_mem_left _ _ hn) (Ideal.mul_mem_left _ _ hd)
+    have h1 : w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) x.num) = 1 :=
+      (HeightOneSpectrum.valuation_eq_one_iff_notMem w).mpr hnum
+    refine absurd h1 (ne_of_lt ?_)
+    calc w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) x.num)
+        = w.valuation (RatFunc K) x
+            * w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) x.denom) := by
+          rw [← map_mul, hmul]
+      _ ≤ w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) x.denom) :=
+          mul_le_of_le_one_left' hxval
+      _ < 1 := (HeightOneSpectrum.valuation_lt_one_iff_mem w x.denom).mpr hd
+  have hmax : w.asIdeal.IsMaximal := IsPrime.to_maximal_ideal w.ne_bot
+  obtain ⟨t, ht⟩ : ∃ t : K[X], x.denom * t - 1 ∈ w.asIdeal := by
+    obtain ⟨b, c, hc, hbc⟩ := hmax.exists_inv hden
+    refine ⟨b, ?_⟩
+    rw [show x.denom * b - 1 = -c by linear_combination hbc]
+    exact neg_mem hc
+  refine ⟨x.num * t, ?_⟩
+  rw [residueOfHeightOneSpectrum_apply, ← sub_eq_zero, ← map_sub,
+    IsLocalRing.residue_eq_zero_iff, Place.mem_maximalIdeal_iff_adicValuation_lt_one]
+  change (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).adicValuation
+    (algebraMap K[X] (RatFunc K) (x.num * t) - x) < 1
+  rw [← (Place.isEquiv_adicValuation_ofHeightOneSpectrum (K := K)
+      (F := RatFunc K) w).lt_one_iff_lt_one]
+  have key : algebraMap K[X] (RatFunc K) (x.num * t) - x
+      = x * algebraMap K[X] (RatFunc K) (x.denom * t - 1) := by
+    rw [map_sub, map_mul, map_mul, map_one, mul_sub, mul_one, ← mul_assoc, hmul]
+  rw [key, map_mul]
+  calc w.valuation (RatFunc K) x
+        * w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) (x.denom * t - 1))
+      ≤ w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) (x.denom * t - 1)) :=
+        mul_le_of_le_one_left' hxval
+    _ < 1 := (HeightOneSpectrum.valuation_lt_one_iff_mem w _).mpr ht
+
+def residueFieldEquivOfHeightOneSpectrum (w : HeightOneSpectrum K[X]) :
+    (K[X] ⧸ w.asIdeal) ≃ₐ[K]
+      (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ResidueField := by
+  refine AlgEquiv.ofRingEquiv (f := (Ideal.quotEquivOfEq
+    (ker_residueOfHeightOneSpectrum K w).symm).trans
+    (RingHom.quotientKerEquivOfSurjective (surjective_residueOfHeightOneSpectrum K w))) ?_
+  intro a
+  rw [show (algebraMap K (K[X] ⧸ w.asIdeal)) a
+      = Ideal.Quotient.mk w.asIdeal (algebraMap K K[X] a) from rfl]
+  rw [RingEquiv.trans_apply, Ideal.quotEquivOfEq_mk,
+    RingHom.quotientKerEquivOfSurjective_apply_mk, residueOfHeightOneSpectrum_apply]
+  exact congrArg (IsLocalRing.residue _)
+    (Subtype.ext (IsScalarTower.algebraMap_apply K K[X] (RatFunc K) a).symm)
+
+end WFf
+
+end AlgebraicCurve.RationalFunctionField
+
+end
+
+theorem solution (K : Type*) [Field K] {w : IsDedekindDomain.HeightOneSpectrum (Polynomial K)}
+    {p : Polynomial K} (hw : w.asIdeal = Ideal.span {p}) :
+    (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).deg = p.natDegree := by
+  rw [Place.deg, ← (AlgebraicCurve.RationalFunctionField.WFf.residueFieldEquivOfHeightOneSpectrum K
+    w).toLinearEquiv.finrank_eq, hw]
+  exact finrank_quotient_span_eq_natDegree
+
+end S_AlgebraicCurve_RationalFunctionField_deg_ofHeightOneSpectrum
+end P2MW
+export P2MW.S_AlgebraicCurve_RationalFunctionField_deg_ofHeightOneSpectrum (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+theorem P2M.Dup.AlgebraicCurve.RationalFunctionField.deg_ofHeightOneSpectrum (K : Type*) [Field K]
+    {w : IsDedekindDomain.HeightOneSpectrum (Polynomial K)} {p : Polynomial K}
+    (hw : w.asIdeal = Ideal.span {p}) :
+    (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).deg = p.natDegree :=
+  solution K hw
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_eq_ofHeightOneSpectrum_or_eq_placeInfty.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_eq_ofHeightOneSpectrum_or_eq_placeInfty.lean
new file mode 100644
index 0000000000..851c8102f4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_eq_ofHeightOneSpectrum_or_eq_placeInfty.lean
@@ -0,0 +1,90 @@
+/-
+Based on Prove2Me node
+P2M.Dup.AlgebraicCurve.RationalFunctionField.eq_ofHeightOneSpectrum_or_eq_placeInfty
+(c0f27816-d641-5c01-9328-7eb6d67b8805) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 246310e9-5f60-5eb0-b628-f6f18800d82c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceInfty
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_eq_placeInfty_iff_forall_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Places of K(t): the finite places and ∞
+
+Theorem statement:
+`P2M.Dup.AlgebraicCurve.RationalFunctionField.eq_ofHeightOneSpectrum_or_eq_placeInfty`
+(`c0f27816-d641-5c01-9328-7eb6d67b8805`), by Claude, 2026-09-05.
+
+Proof: submission `246310e9-5f60-5eb0-b628-f6f18800d82c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and consider the rational function field $\mathrm{RatFunc}\,K$ as a $K$-algebra.
+A `Place K (RatFunc K)` is a valuation subring of $\mathrm{RatFunc}\,K$ which contains the image of
+$K$ under the structure map, is not the whole field, and is a principal ideal ring. The assertion is
+that every such place $v$ satisfies one of two alternatives: either there is a height-one prime $w$
+of the polynomial ring $K[X]$ with $v =$ `Place.ofHeightOneSpectrum w`, that is, $v$ is the
+valuation subring of the $w$-adic valuation of $K[X]$ extended to its fraction field
+$\mathrm{RatFunc}\,K$; or $v =$ `placeInfty K`, the place whose valuation subring is that of
+`RatFunc.inftyValuation K`, the valuation attached to the degree function at infinity. The
+disjunction is stated as an inclusive `Or`, with the first alternative an existential over
+height-one primes; no hypothesis beyond $v$ being a place is imposed.
+
+This is Ostrowski's classification of the places of a rational function field over $K$
+(equivalently, of the valuations of $K(t)$ trivial on $K$): the points of $\mathbb{P}^1$, namely the
+closed points of the affine line together with the point at infinity. It is the basic enumeration
+underlying the divisor-theoretic and local-analytic work with places of $K(t)$ in the development,
+and is cited by results on orders at places and on integrality of polynomials away from infinity.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_eq_ofHeightOneSpectrum_or_eq_placeInfty.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_RationalFunctionField_eq_ofHeightOneSpectrum_or_eq_placeInfty
+
+open IsDedekindDomain AlgebraicCurve AlgebraicCurve.RationalFunctionField
+
+theorem solution {K : Type*} [Field K] [DecidableEq (RatFunc K)] (v : Place K (RatFunc K)) :
+    (∃ w : IsDedekindDomain.HeightOneSpectrum (Polynomial K), v = Place.ofHeightOneSpectrum w) ∨ v =
+      placeInfty K := by
+  by_cases h : ∀ w : IsDedekindDomain.HeightOneSpectrum (Polynomial K), v ≠
+    Place.ofHeightOneSpectrum w
+  · exact Or.inr
+      ((AlgebraicCurve.RationalFunctionField.eq_placeInfty_iff_forall_ne_ofHeightOneSpectrum v).2 h)
+  · push Not at h
+    exact Or.inl h
+
+end S_AlgebraicCurve_RationalFunctionField_eq_ofHeightOneSpectrum_or_eq_placeInfty
+end P2MW
+export P2MW.S_AlgebraicCurve_RationalFunctionField_eq_ofHeightOneSpectrum_or_eq_placeInfty
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve AlgebraicCurve.RationalFunctionField
+theorem P2M.Dup.AlgebraicCurve.RationalFunctionField.eq_ofHeightOneSpectrum_or_eq_placeInfty
+    {K : Type*} [Field K] [DecidableEq (RatFunc K)] (v : Place K (RatFunc K)) :
+    (∃ w : IsDedekindDomain.HeightOneSpectrum (Polynomial K), v = Place.ofHeightOneSpectrum w) ∨ v =
+      placeInfty K :=
+  solution v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_eq_placeOfPoint_or_eq_placeInfty.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_eq_placeOfPoint_or_eq_placeInfty.lean
new file mode 100644
index 0000000000..4c2e8513ae
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_eq_placeOfPoint_or_eq_placeInfty.lean
@@ -0,0 +1,136 @@
+/-
+Based on Prove2Me node P2M.Dup.AlgebraicCurve.RationalFunctionField.eq_placeOfPoint_or_eq_placeInfty
+(86424baf-e08f-5188-813f-e3201b47929f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6cfd4548-58da-5540-b323-33de1612c317
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceInfty
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import Mathlib.FieldTheory.IsAlgClosed.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Theorems.Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_eq_ofHeightOneSpectrum_or_eq_placeInfty
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Places of K(t) for K algebraically closed: P¹(K)
+
+Theorem statement: `P2M.Dup.AlgebraicCurve.RationalFunctionField.eq_placeOfPoint_or_eq_placeInfty`
+(`86424baf-e08f-5188-813f-e3201b47929f`), by Claude, 2026-09-05.
+
+Proof: submission `6cfd4548-58da-5540-b323-33de1612c317`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field and let $v$ be a place of the rational function field
+$\mathrm{RatFunc}\,K$ over $K$, that is, a term of the project structure `Place K (RatFunc K)`: a
+valuation subring of $\mathrm{RatFunc}\,K$ which contains the image of $K$ under the structure map,
+is not the whole field, and is a principal ideal ring. The conclusion is a disjunction: either there
+is an element $a \in K$ with $v =$ `placeOfPoint K a`, the place attached to the irreducible
+polynomial $X - C(a)$ (namely `Place.ofHeightOneSpectrum` applied to the height-one prime of $K[X]$
+generated by $X - C(a)$), or $v =$ `placeInfty K`, the place whose valuation subring is the
+valuation subring of `RatFunc.inftyValuation K`. Thus the places of $K(t)/K$ for $K$ algebraically
+closed are exhausted by the points $a \in K$ together with the point at infinity. The statement
+asserts only that this list is exhaustive; disjointness of the two cases and injectivity of $a
+\mapsto$ `placeOfPoint K a` are not part of it.
+
+This is the classification of the places of a rational function field, specialised to an
+algebraically closed constant field, where the finite places correspond to the linear monic
+polynomials and hence to the points of $\mathbb{A}^1(K)$, so that the full set of places is
+identified with $\mathbb{P}^1(K) = K \cup \{\infty\}$. It serves as a basic tool in the
+function-field part of the development, used wherever an argument proceeds by cases over all places
+of $K(t)$, for instance in results on divisors, charts of annuli, and comparisons of places under
+constant field extension.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_eq_placeOfPoint_or_eq_placeInfty.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_cb6c3088
+
+p2m_open "Polynomial IsDedekindDomain AlgebraicCurve~RationalFunctionField.exists_eq_placeOfPoint \
+  P2MW.S_OVERLONG_cb6c3088.AlgebraicCurve \
+  AlgebraicCurve.RationalFunctionField~exists_eq_placeOfPoint \
+  P2MW.S_OVERLONG_cb6c3088.AlgebraicCurve.Ratio\
+  nalFunctionField"
+
+open scoped Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ofHeightOneSpectrum \
+  RationalFunctionField.eq_ofHeightOneSpectrum_or_eq_placeInfty"
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "placeInfty heightOneSpectrumOfIrreducible \
+  heightOneSpectrumOfIrreducible_asIdeal exists_irreducible_span placeOfPoint \
+  placeOfPoint_eq_ofHeightOneSpectrum eq_ofHeightOneSpectrum_or_eq_placeInfty"
+p2m_open "AlgebraicCurve.RationalFunctionField~exists_eq_placeOfPoint \
+  AlgebraicCurve~RationalFunctionField.exists_eq_placeOfPoint"
+
+variable (K : Type*) [Field K]
+
+theorem exists_eq_placeOfPoint [IsAlgClosed K] (w : HeightOneSpectrum K[X]) :
+    ∃ a : K, Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w = placeOfPoint K a := by
+  obtain ⟨p, hp, hwp⟩ := exists_irreducible_span K w
+  have hdeg : p.degree ≠ 0 := by
+    rw [IsAlgClosed.degree_eq_one_of_irreducible K hp]
+    exact one_ne_zero
+  obtain ⟨a, ha⟩ := IsAlgClosed.exists_root p hdeg
+  refine ⟨a, ?_⟩
+  have hassoc : Associated ((X : K[X]) - C a) p :=
+    (irreducible_X_sub_C a).associated_of_dvd hp (dvd_iff_isRoot.mpr ha)
+  have hideal : w = heightOneSpectrumOfIrreducible K (irreducible_X_sub_C a) :=
+    HeightOneSpectrum.ext (by
+      rw [hwp, heightOneSpectrumOfIrreducible_asIdeal]
+      exact (Ideal.span_singleton_eq_span_singleton.mpr hassoc).symm)
+  rw [hideal, placeOfPoint_eq_ofHeightOneSpectrum]
+
+end AlgebraicCurve.RationalFunctionField
+
+p2m_open "AlgebraicCurve~RationalFunctionField.exists_eq_placeOfPoint" in
+p2m_open "AlgebraicCurve.\
+  RationalFunctionField~exists_eq_placeOfPoint\
+  " in
+open
+  _root_.P2MW.S_OVERLONG_cb6c3088.AlgebraicCurve
+  _root_.P2MW.S_OVERLONG_cb6c3088.AlgebraicCurve.RationalFunctionField
+  in
+theorem solution (K : Type*) [Field K] [IsAlgClosed K] [DecidableEq (RatFunc K)]
+    (v : Place K (RatFunc K)) :
+    (∃ a : K, v = placeOfPoint K a) ∨ v = placeInfty K := by
+  rcases AlgebraicCurve.RationalFunctionField.eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, hw⟩
+    | hw
+  · obtain ⟨a, ha⟩ := exists_eq_placeOfPoint K w
+    exact Or.inl ⟨a, hw.trans ha⟩
+  · exact Or.inr hw
+
+end S_OVERLONG_cb6c3088
+end P2MW
+export P2MW.S_OVERLONG_cb6c3088 (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve AlgebraicCurve.RationalFunctionField
+theorem P2M.Dup.AlgebraicCurve.RationalFunctionField.eq_placeOfPoint_or_eq_placeInfty (K : Type*)
+    [Field K] [IsAlgClosed K] [DecidableEq (RatFunc K)] (v : Place K (RatFunc K)) :
+    (∃ a : K, v = placeOfPoint K a) ∨ v = placeInfty K :=
+  solution K v
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_placeInfty_ne_ofHeightOneSpectrum.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_placeInfty_ne_ofHeightOneSpectrum.lean
new file mode 100644
index 0000000000..65ad7e0389
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_P2M_Dup_AlgebraicCurve_RationalFunctionField_placeInfty_ne_ofHeightOneSpectrum.lean
@@ -0,0 +1,89 @@
+/-
+Based on Prove2Me node
+P2M.Dup.AlgebraicCurve.RationalFunctionField.placeInfty_ne_ofHeightOneSpectrum
+(5ec48eeb-92f6-50ae-bebc-475dbfe352a1) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6646b61f-8a44-51da-a0f8-ce1bb8662eb6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceInfty
+
+import Mathlib.FieldTheory.RatFunc.AsPolynomial
+import Mathlib.NumberTheory.RatFunc.Ostrowski
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The place at infinity of K(t) is not a finite place
+
+Theorem statement: `P2M.Dup.AlgebraicCurve.RationalFunctionField.placeInfty_ne_ofHeightOneSpectrum`
+(`5ec48eeb-92f6-50ae-bebc-475dbfe352a1`), by Claude, 2026-09-05.
+
+Proof: submission `6646b61f-8a44-51da-a0f8-ce1bb8662eb6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $w$ be a height-one prime of the polynomial ring $K[t]$, i.e. an element
+of the height-one spectrum of the Dedekind domain $\mathrm{Polynomial}\ K$. Two places of the
+rational function field $\mathrm{RatFunc}\ K$ over $K$ are compared, where a place of an extension
+$F/K$ is a valuation subring of $F$ containing the image of $K$ under the structure map, different
+from $F$ itself, and whose ring structure is that of a principal ideal ring. The first is
+`placeInfty K`, whose valuation subring is that of the infinity valuation `RatFunc.inftyValuation K`
+of $K(t)$, that is, the subring of rational functions whose numerator degree does not exceed the
+denominator degree. The second is `Place.ofHeightOneSpectrum w`, whose valuation subring is that of
+the $w$-adic valuation of $K(t)$ attached to the prime $w$ of $K[t]$, $K(t)$ being the fraction
+field of $K[t]$. The assertion is that these two places are distinct: $\mathrm{placeInfty}\ K \neq
+\mathrm{Place.ofHeightOneSpectrum}\ w$ for every such $w$.
+
+This is the elementary separation, in the classification of the places of the rational function
+field, between the place at infinity and the finite places indexed by the monic irreducible
+polynomials; here the places are recorded as valuation subrings of $K(t)$ containing $K$. It is used
+for the degree computation at infinity and for the reformulation of 'being the place at infinity' as
+'not being of the form $v_P$', and thence in the divisor-theoretic bookkeeping for $\mathbb{P}^1$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_AlgebraicCurve_RationalFunctionField_placeInfty_ne_ofHeightOneSpectrum.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_AlgebraicCurve_RationalFunctionField_placeInfty_ne_ofHeightOneSpectrum
+
+open IsDedekindDomain AlgebraicCurve AlgebraicCurve.RationalFunctionField
+
+theorem solution (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+    (w : IsDedekindDomain.HeightOneSpectrum (Polynomial K)) :
+    placeInfty K ≠ Place.ofHeightOneSpectrum w := by
+  intro h
+  refine RatFunc.adicValuation_not_isEquiv_infty_valuation w
+    ((Valuation.isEquiv_iff_valuationSubring _ _).mpr ?_)
+  have h2 := congrArg Place.toValuationSubring h
+  rw [placeInfty_toValuationSubring, Place.ofHeightOneSpectrum_toValuationSubring] at h2
+  exact h2.symm
+
+end S_AlgebraicCurve_RationalFunctionField_placeInfty_ne_ofHeightOneSpectrum
+end P2MW
+export P2MW.S_AlgebraicCurve_RationalFunctionField_placeInfty_ne_ofHeightOneSpectrum (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve AlgebraicCurve.RationalFunctionField
+theorem P2M.Dup.AlgebraicCurve.RationalFunctionField.placeInfty_ne_ofHeightOneSpectrum (K : Type*)
+    [Field K] [DecidableEq (RatFunc K)] (w : IsDedekindDomain.HeightOneSpectrum (Polynomial K)) :
+    placeInfty K ≠ Place.ofHeightOneSpectrum w :=
+  solution K w
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_discriminant_ne_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_discriminant_ne_zero.lean
new file mode 100644
index 0000000000..cc13cc00ed
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_discriminant_ne_zero.lean
@@ -0,0 +1,394 @@
+/-
+Based on Prove2Me node PeriodPair.discriminant_ne_zero
+(2d123a01-45de-5814-8eeb-541809a9d5f3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6cfc278d-1a2e-5208-a95f-f24a2956696e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_PeriodPair_Uniformization
+
+import Mathlib.NumberTheory.ModularForms.LevelOne.DimensionFormula
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Non-vanishing of the discriminant g₂³-27g₃²
+
+Theorem statement: `PeriodPair.discriminant_ne_zero` (`2d123a01-45de-5814-8eeb-541809a9d5f3`), by
+Claude, 2026-09-05.
+
+Proof: submission `6cfc278d-1a2e-5208-a95f-f24a2956696e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+The assertion is that for every term $L$ of the type `PeriodPair` the predicate
+`L.DiscriminantNeZero` holds, that is, the complex number
+$$L.g_2^3 - 27\,L.g_3^2$$
+is nonzero, where $L.g_2$ and $L.g_3$ are the two invariants attached to $L$. There are no further
+variables and no hypotheses: the statement is universally quantified over all period pairs, so the
+non-vanishing is unconditional and holds for every object of this type. Unfolded,
+`DiscriminantNeZero` is precisely the proposition $L.g_2^3 - 27 L.g_3^2 \neq 0$, with the numeral
+$27$ read in $\mathbb{C}$; no factor such as $16$ or $-16$ normalising the discriminant of the
+associated cubic is included, and the statement makes no reference to the roots of that cubic, to
+smoothness, or to any Weierstrass equation. In classical terms, for the lattice determined by $L$
+with Eisenstein invariants $g_2$ and $g_3$ this is the non-vanishing of $\Delta$ up to a nonzero
+constant factor.
+
+This is the non-vanishing of the modular discriminant for a period lattice, the condition under
+which $y^2 = 4x^3 - g_2 x - g_3$ defines an elliptic curve. It discharges, once and for all, the
+`DiscriminantNeZero` hypothesis carried by the constructions of the analytic uniformisation (the
+point map attached to a period pair and the associated statements about rational homomorphisms and
+differentiable lifts), and is cited by those results.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_PeriodPair_discriminant_ne_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+noncomputable section privateSection
+
+open scoped MatrixGroups Real
+open Complex UpperHalfPlane ModularForm ModularFormClass EisensteinSeries PowerSeries
+
+namespace ModularForm
+
+def kw_E4cube : ModularForm 𝒮ℒ 12 :=
+  ModularForm.mcast (by ring) ((E₄.mul E₄).mul E₄)
+
+def kw_E6sq : ModularForm 𝒮ℒ 12 :=
+  ModularForm.mcast (by ring) (E₆.mul E₆)
+
+@[scoped simp] theorem kw_E4cube_apply (τ : ℍ) : kw_E4cube τ = E₄ τ ^ 3 := by
+  change ((E₄.mul E₄).mul E₄) τ = E₄ τ ^ 3
+  simp only [ModularForm.coe_mul, Pi.mul_apply]; ring
+
+@[scoped simp] theorem kw_E6sq_apply (τ : ℍ) : kw_E6sq τ = E₆ τ ^ 2 := by
+  change (E₆.mul E₆) τ = E₆ τ ^ 2
+  simp only [ModularForm.coe_mul, Pi.mul_apply]; ring
+
+def kw_E4cube_sub_E6sq : ModularForm 𝒮ℒ 12 := kw_E4cube - kw_E6sq
+
+@[scoped simp] theorem kw_E4cube_sub_E6sq_apply (τ : ℍ) :
+    kw_E4cube_sub_E6sq τ = E₄ τ ^ 3 - E₆ τ ^ 2 := by
+  simp [kw_E4cube_sub_E6sq]
+
+theorem kw_qExpansion_E4cube :
+    qExpansion 1 (kw_E4cube : ℍ → ℂ) = qExpansion 1 (E₄ : ℍ → ℂ) ^ 3 := by
+  change qExpansion 1 (((E₄.mul E₄).mul E₄ : ModularForm _ _) : ℍ → ℂ) = _
+  rw [ModularForm.qExpansion_mul one_pos one_mem_strictPeriods_SL,
+    ModularForm.qExpansion_mul one_pos one_mem_strictPeriods_SL]
+  ring
+
+theorem kw_qExpansion_E6sq :
+    qExpansion 1 (kw_E6sq : ℍ → ℂ) = qExpansion 1 (E₆ : ℍ → ℂ) ^ 2 := by
+  change qExpansion 1 ((E₆.mul E₆ : ModularForm _ _) : ℍ → ℂ) = _
+  rw [ModularForm.qExpansion_mul one_pos one_mem_strictPeriods_SL]
+  ring
+
+theorem kw_qExpansion_E4cube_sub_E6sq :
+    qExpansion 1 (kw_E4cube_sub_E6sq : ℍ → ℂ)
+      = qExpansion 1 (E₄ : ℍ → ℂ) ^ 3 - qExpansion 1 (E₆ : ℍ → ℂ) ^ 2 := by
+  rw [show (kw_E4cube_sub_E6sq : ℍ → ℂ) = (kw_E4cube : ℍ → ℂ) - (kw_E6sq : ℍ → ℂ) from
+      rfl,
+    ModularForm.qExpansion_sub one_pos one_mem_strictPeriods_SL,
+    kw_qExpansion_E4cube, kw_qExpansion_E6sq]
+
+theorem kw_E4_coeff_zero : (qExpansion 1 (E₄ : ℍ → ℂ)).coeff 0 = 1 :=
+  E_qExpansion_coeff_zero (by norm_num) ⟨2, rfl⟩
+
+theorem kw_E6_coeff_zero : (qExpansion 1 (E₆ : ℍ → ℂ)).coeff 0 = 1 :=
+  E_qExpansion_coeff_zero (by norm_num) ⟨3, rfl⟩
+
+theorem kw_E4cube_sub_E6sq_coeff_zero :
+    (qExpansion 1 (kw_E4cube_sub_E6sq : ℍ → ℂ)).coeff 0 = 0 := by
+  rw [kw_qExpansion_E4cube_sub_E6sq, PowerSeries.coeff_zero_eq_constantCoeff, map_sub, map_pow,
+    map_pow, ← PowerSeries.coeff_zero_eq_constantCoeff_apply,
+    ← PowerSeries.coeff_zero_eq_constantCoeff_apply, kw_E4_coeff_zero, kw_E6_coeff_zero]
+  ring
+
+theorem kw_antidiagonal_one :
+    (Finset.HasAntidiagonal.antidiagonal 1 : Finset (ℕ × ℕ)) = {(0, 1), (1, 0)} := by decide
+
+theorem kw_coeff_one_mul (p q : PowerSeries ℂ) :
+    (p * q).coeff 1 = p.coeff 0 * q.coeff 1 + p.coeff 1 * q.coeff 0 := by
+  rw [PowerSeries.coeff_mul, kw_antidiagonal_one]
+  simp
+
+theorem kw_coeff_one_sq (p : PowerSeries ℂ) :
+    (p ^ 2).coeff 1 = 2 * p.coeff 0 * p.coeff 1 := by
+  rw [sq, kw_coeff_one_mul]; ring
+
+theorem kw_coeff_one_cube (p : PowerSeries ℂ) :
+    (p ^ 3).coeff 1 = 3 * p.coeff 0 ^ 2 * p.coeff 1 := by
+  have hsq0 : (p ^ 2).coeff 0 = p.coeff 0 ^ 2 := by
+    simp only [PowerSeries.coeff_zero_eq_constantCoeff, map_pow]
+  rw [show p ^ 3 = p * p ^ 2 from by ring, kw_coeff_one_mul, kw_coeff_one_sq, hsq0]
+  ring
+
+theorem kw_E4cube_sub_E6sq_coeff_one :
+    (qExpansion 1 (kw_E4cube_sub_E6sq : ℍ → ℂ)).coeff 1 = 1728 := by
+  rw [kw_qExpansion_E4cube_sub_E6sq, map_sub, kw_coeff_one_cube, kw_coeff_one_sq,
+    kw_E4_coeff_zero, kw_E6_coeff_zero, E₄_qExpansion_coeff_one, E₆_qExpansion_coeff_one]
+  ring
+
+def kw_E4cube_sub_E6sq_cuspForm : CuspForm 𝒮ℒ 12 :=
+  toCuspForm kw_E4cube_sub_E6sq kw_E4cube_sub_E6sq_coeff_zero
+
+@[scoped simp] theorem kw_E4cube_sub_E6sq_cuspForm_apply (τ : ℍ) :
+    kw_E4cube_sub_E6sq_cuspForm τ = E₄ τ ^ 3 - E₆ τ ^ 2 :=
+  kw_E4cube_sub_E6sq_apply τ
+
+theorem kw_exists_smul_discriminant_eq_E4cube_sub_E6sq :
+    ∃ c : ℂ, c ≠ 0 ∧ (∀ τ : ℍ, E₄ τ ^ 3 - E₆ τ ^ 2 = c * discriminant τ) ∧
+      c * (qExpansion 1 (discriminant : ℍ → ℂ)).coeff 1 = 1728 := by
+  obtain ⟨c, hc⟩ :=
+    CuspForm.exists_smul_discriminant_of_weight_eq_twelve kw_E4cube_sub_E6sq_cuspForm
+  have hpt : ∀ τ : ℍ, E₄ τ ^ 3 - E₆ τ ^ 2 = c * discriminant τ := fun τ => by
+    have h := DFunLike.congr_fun hc τ
+    simp only [smul_apply, CuspForm.coe_discriminant, smul_eq_mul,
+      kw_E4cube_sub_E6sq_cuspForm_apply] at h
+    exact h.symm
+  have hcoeff : c * (qExpansion 1 (discriminant : ℍ → ℂ)).coeff 1 = 1728 := by
+    have hfun : (kw_E4cube_sub_E6sq_cuspForm : ℍ → ℂ)
+        = c • (CuspForm.discriminant : ℍ → ℂ) := by
+      exact_mod_cast congrArg DFunLike.coe hc.symm
+    have := kw_E4cube_sub_E6sq_coeff_one
+    rw [show (kw_E4cube_sub_E6sq : ℍ → ℂ) = (kw_E4cube_sub_E6sq_cuspForm : ℍ → ℂ) from rfl,
+      hfun, ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL,
+      PowerSeries.coeff_smul, smul_eq_mul, CuspForm.coe_discriminant] at this
+    exact this
+  grind
+
+theorem kw_E4cube_ne_E6sq (τ : ℍ) : E₄ τ ^ 3 ≠ E₆ τ ^ 2 := by
+  obtain ⟨c, hc, hpt, -⟩ := kw_exists_smul_discriminant_eq_E4cube_sub_E6sq
+  intro h
+  have := hpt τ
+  rw [h, sub_self] at this
+  exact mul_ne_zero hc (discriminant_ne_zero τ) this.symm
+
+end ModularForm
+
+namespace PeriodPair
+
+theorem kw_ofTau_latticeEquivProd_symm_apply (τ : ℍ) (p : ℤ × ℤ) :
+    ((ofTau τ).latticeEquivProd.symm p : ℂ) = p.1 * (τ : ℂ) + p.2 := by
+  rw [latticeEquiv_symm_apply]; simp
+
+end PeriodPair
+
+
+namespace PeriodPair
+
+theorem kw_G_ofTau_eq {k : ℕ} (hk : 3 ≤ k) (τ : ℍ) :
+    (ofTau τ).G k = 2 * riemannZeta k * E hk τ := by
+  rw [G, ← (ofTau τ).latticeEquivProd.symm.toEquiv.tsum_eq]
+  simp only [LinearEquiv.coe_toEquiv, kw_ofTau_latticeEquivProd_symm_apply]
+  have hstep : ∀ p : ℤ × ℤ,
+      ((↑p.1 * (τ : ℂ) + ↑p.2) ^ k)⁻¹ = eisSummand k ((finTwoArrowEquiv ℤ).symm p) τ := by
+    intro p
+    simp only [eisSummand, finTwoArrowEquiv_symm_apply, Matrix.cons_val_zero,
+      Matrix.cons_val_one, Matrix.cons_val_fin_one, _root_.zpow_neg, zpow_natCast]
+  simp only [hstep]
+  rw [(finTwoArrowEquiv ℤ).symm.tsum_eq (f := fun v => eisSummand (k : ℤ) v τ),
+    tsum_eisSummand_eq_riemannZeta_mul_eisensteinSeries hk τ]
+  have hE : (E hk : ℍ → ℂ) τ = (1 / 2 : ℂ) * eisensteinSeries (N := 1) 0 k τ := rfl
+  grind
+
+end PeriodPair
+
+namespace ModularCurve
+
+theorem kw_riemannZeta_six : riemannZeta 6 = (π : ℂ) ^ 6 / 945 := by
+  have hb5 : bernoulli' 5 = 0 := by
+    have : Nat.choose 5 2 = 10 := by decide
+    rw [bernoulli'_def]
+    norm_num [Finset.sum_range_succ, this]
+  have hb6 : bernoulli' 6 = 1 / 42 := by
+    have h62 : Nat.choose 6 2 = 15 := by decide
+    have h64 : Nat.choose 6 4 = 15 := by decide
+    rw [bernoulli'_def]
+    norm_num [Finset.sum_range_succ, hb5, h62, h64]
+  have hb : bernoulli 6 = 1 / 42 := by
+    rw [bernoulli_eq_bernoulli'_of_ne_one (by norm_num), hb6]
+  have h := riemannZeta_two_mul_nat (k := 3) (by norm_num)
+  simp only [show 2 * 3 = 6 from rfl, Nat.cast_ofNat, hb,
+    show (6 : ℕ).factorial = 720 from by decide] at h
+  rw [show (2 * (3 : ℂ) : ℂ) = (6 : ℂ) by ring] at h
+  push_cast at h
+  grind
+
+end ModularCurve
+
+open ModularCurve
+
+namespace PeriodPair
+
+theorem kw_g₂_ofTau (τ : ℍ) :
+    (ofTau τ).g₂ = (4 * (π : ℂ) ^ 4 / 3) * E₄ τ := by
+  rw [g₂, kw_G_ofTau_eq (by norm_num : (3:ℕ) ≤ 4) τ,
+    show ((4 : ℕ) : ℂ) = (4 : ℂ) by grind, riemannZeta_four]
+  ring
+
+theorem kw_g₃_ofTau (τ : ℍ) :
+    (ofTau τ).g₃ = (8 * (π : ℂ) ^ 6 / 27) * E₆ τ := by
+  rw [g₃, kw_G_ofTau_eq (by norm_num : (3:ℕ) ≤ 6) τ,
+    show ((6 : ℕ) : ℂ) = (6 : ℂ) by grind, kw_riemannZeta_six]
+  ring
+
+variable (L : PeriodPair)
+
+section Scale
+
+variable (α : ℂˣ)
+
+def mulLeftR (a : ℂ) : ℂ →ₗ[ℝ] ℂ := Algebra.lmul ℝ ℂ a
+
+def mulLeftZ (a : ℂ) : ℂ →ₗ[ℤ] ℂ := (mulLeftR a).restrictScalars ℤ
+
+@[scoped simp] theorem mulLeftZ_apply (a z : ℂ) : mulLeftZ a z = a * z := rfl
+
+theorem scale_lattice :
+    (L.scale α).lattice = Submodule.map (mulLeftZ (α : ℂ)) L.lattice := by
+  unfold lattice scale
+  rw [Submodule.map_span]
+  congr 1
+  ext z
+  simp only [Set.mem_insert_iff, Set.mem_singleton_iff, Set.mem_image, mulLeftZ_apply]
+  grind
+
+def scaleLatticeEquiv : L.lattice ≃ₗ[ℤ] (L.scale α).lattice :=
+  (Submodule.equivMapOfInjective (mulLeftZ (α : ℂ))
+    (fun _ _ h => mul_left_cancel₀ α.ne_zero (by simpa using h)) L.lattice).trans
+    (LinearEquiv.ofEq _ _ (L.scale_lattice α).symm)
+
+@[scoped simp] theorem scaleLatticeEquiv_apply (l : L.lattice) :
+    ((L.scaleLatticeEquiv α l : (L.scale α).lattice) : ℂ) = (α : ℂ) * (l : ℂ) := rfl
+
+end Scale
+
+section Homogeneity
+
+variable (α : ℂˣ)
+
+theorem G_scale (n : ℕ) : (L.scale α).G n = ((α : ℂ) ^ n)⁻¹ * L.G n := by
+  unfold G
+  rw [← (L.scaleLatticeEquiv α).toEquiv.tsum_eq]
+  simp only [LinearEquiv.coe_toEquiv, scaleLatticeEquiv_apply, mul_pow, mul_inv]
+  exact tsum_mul_left
+
+theorem g₂_scale : (L.scale α).g₂ = ((α : ℂ) ^ 4)⁻¹ * L.g₂ := by
+  unfold g₂; rw [G_scale]; ring
+
+theorem g₃_scale : (L.scale α).g₃ = ((α : ℂ) ^ 6)⁻¹ * L.g₃ := by
+  unfold g₃; rw [G_scale]; ring
+
+theorem discriminant_scale :
+    (L.scale α).g₂ ^ 3 - 27 * (L.scale α).g₃ ^ 2
+      = ((α : ℂ) ^ 12)⁻¹ * (L.g₂ ^ 3 - 27 * L.g₃ ^ 2) := by
+  rw [g₂_scale, g₃_scale]; ring
+
+theorem discriminantNeZero_scale_iff :
+    (L.scale α).DiscriminantNeZero ↔ L.DiscriminantNeZero := by
+  unfold DiscriminantNeZero
+  rw [discriminant_scale]
+  simp only [mul_ne_zero_iff, and_iff_right (inv_ne_zero (pow_ne_zero 12 α.ne_zero))]
+
+end Homogeneity
+
+section LatticeDependence
+
+variable {L L' : PeriodPair}
+
+def latticeEquivOfEq (h : L.lattice = L'.lattice) : L.lattice ≃ L'.lattice where
+  toFun l := ⟨(l : ℂ), h ▸ l.2⟩
+  invFun l := ⟨(l : ℂ), h.symm ▸ l.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+
+theorem G_eq_of_lattice_eq (h : L.lattice = L'.lattice) (n : ℕ) : L.G n = L'.G n :=
+  (latticeEquivOfEq h).tsum_eq fun l => ((l : ℂ) ^ n)⁻¹
+
+theorem g₂_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.g₂ = L'.g₂ := by
+  unfold g₂; rw [G_eq_of_lattice_eq h]
+
+theorem g₃_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.g₃ = L'.g₃ := by
+  unfold g₃; rw [G_eq_of_lattice_eq h]
+
+end LatticeDependence
+
+theorem kw_discriminant_ofTau_eq (τ : ℍ) :
+    (ofTau τ).g₂ ^ 3 - 27 * (ofTau τ).g₃ ^ 2
+      = (64 * (π : ℂ) ^ 12 / 27) * (E₄ τ ^ 3 - E₆ τ ^ 2) := by
+  rw [kw_g₂_ofTau, kw_g₃_ofTau]; ring
+
+theorem kw_discriminantNeZero_ofTau (τ : ℍ) : (ofTau τ).DiscriminantNeZero := by
+  unfold DiscriminantNeZero
+  rw [kw_discriminant_ofTau_eq]
+  refine mul_ne_zero ?_ (sub_ne_zero.mpr (kw_E4cube_ne_E6sq τ))
+  refine div_ne_zero (mul_ne_zero (by norm_num) (pow_ne_zero 12 ?_)) (by norm_num)
+  exact_mod_cast Real.pi_ne_zero
+
+theorem kw_discriminantNeZero_of_lattice_eq {L L' : PeriodPair}
+    (h : L.lattice = L'.lattice) : L.DiscriminantNeZero ↔ L'.DiscriminantNeZero := by
+  unfold DiscriminantNeZero
+  rw [g₂_eq_of_lattice_eq h, g₃_eq_of_lattice_eq h]
+
+theorem kw_im_div_ne_zero (L : PeriodPair) : (L.ω₁ / L.ω₂).im ≠ 0 := by
+  have hω₂ : L.ω₂ ≠ 0 := by
+    have := L.indep.ne_zero 1; simpa using this
+  intro him
+  have hdiv : (L.ω₁ / L.ω₂ : ℂ) = ((L.ω₁ / L.ω₂).re : ℂ) :=
+    Complex.ext (by simp) (by simp [him])
+  have hreal : L.ω₁ = ((L.ω₁ / L.ω₂).re : ℂ) * L.ω₂ := by grind
+  have key : (1 : ℝ) • L.ω₁ + (-(L.ω₁ / L.ω₂).re) • L.ω₂ = 0 := by
+    rw [one_smul, _root_.neg_smul, Complex.real_smul, ← hreal, add_neg_cancel]
+  exact one_ne_zero (LinearIndependent.pair_iff.mp L.indep 1 (-(L.ω₁ / L.ω₂).re) key).1
+
+theorem kw_span_neg_fst (a b : ℂ) :
+    Submodule.span ℤ ({-a, b} : Set ℂ) = Submodule.span ℤ ({a, b} : Set ℂ) := by
+  have hna : (-a : ℂ) ∈ Submodule.span ℤ ({a, b} : Set ℂ) :=
+    neg_mem (Submodule.subset_span (Set.mem_insert _ _))
+  have ha : (a : ℂ) ∈ Submodule.span ℤ ({-a, b} : Set ℂ) := by
+    have hneg : (-(-a) : ℂ) ∈ Submodule.span ℤ ({-a, b} : Set ℂ) :=
+      neg_mem (Submodule.subset_span (Set.mem_insert _ _))
+    simpa using hneg
+  apply le_antisymm <;> rw [Submodule.span_le, Set.insert_subset_iff] <;>
+    exact ⟨by assumption,
+      Set.singleton_subset_iff.mpr (Submodule.subset_span (Set.mem_insert_of_mem _ rfl))⟩
+
+theorem kw_discriminantNeZero (L : PeriodPair) : L.DiscriminantNeZero := by
+  have hω₂ : L.ω₂ ≠ 0 := by have := L.indep.ne_zero 1; simpa using this
+  set α : ℂˣ := (Units.mk0 L.ω₂ hω₂)⁻¹
+  have hα : (α : ℂ) = (L.ω₂)⁻¹ := by
+    simp only [α, Units.val_inv_eq_inv_val, Units.val_mk0]
+  have hω : (α : ℂ) * L.ω₁ = L.ω₁ / L.ω₂ ∧ (α : ℂ) * L.ω₂ = 1 := by grind
+  have hlat : (L.scale α).lattice = Submodule.span ℤ {L.ω₁ / L.ω₂, 1} := by
+    simp only [lattice, scale_ω₁, scale_ω₂, hω.1, hω.2]
+  rcases lt_or_gt_of_ne (kw_im_div_ne_zero L) with hneg | hpos
+  · set τ : ℍ := ⟨-(L.ω₁ / L.ω₂), by simp only [Complex.neg_im]; linarith⟩
+    have heq : (L.scale α).lattice = (ofTau τ).lattice := by
+      rw [hlat, ofTau_lattice]; exact (kw_span_neg_fst _ _).symm
+    exact (discriminantNeZero_scale_iff L α).mp
+      ((kw_discriminantNeZero_of_lattice_eq heq).mpr (kw_discriminantNeZero_ofTau τ))
+  · set τ : ℍ := ⟨L.ω₁ / L.ω₂, hpos⟩
+    have heq : (L.scale α).lattice = (ofTau τ).lattice := by rw [hlat, ofTau_lattice]
+    exact (discriminantNeZero_scale_iff L α).mp
+      ((kw_discriminantNeZero_of_lattice_eq heq).mpr (kw_discriminantNeZero_ofTau τ))
+
+end PeriodPair
+
+end privateSection
+
+public section publicSection
+
+theorem PeriodPair.discriminant_ne_zero (L : PeriodPair) : L.DiscriminantNeZero :=
+  L.kw_discriminantNeZero
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_exists_differentiable_toPoint_comp_eq_pointMapOfPushforward_toPoint.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_exists_differentiable_toPoint_comp_eq_pointMapOfPushforward_toPoint.lean
new file mode 100644
index 0000000000..62f31f4b6e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_exists_differentiable_toPoint_comp_eq_pointMapOfPushforward_toPoint.lean
@@ -0,0 +1,2904 @@
+/-
+Based on Prove2Me node
+PeriodPair.exists_differentiable_toPoint_comp_eq_pointMapOfPushforward_toPoint
+(e5395f79-d46c-5b66-a6aa-c05a04dab723) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8fe161dd-bc82-51ec-93f4-d8f706ef4404
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_PeriodPair_Uniformization
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.Analysis.Convex.Contractible
+import Mathlib.Analysis.Normed.Module.Connected
+import Mathlib.AlgebraicTopology.FundamentalGroupoid.SimplyConnected
+import Mathlib.Order.CompletePartialOrder
+import Mathlib.Topology.Homotopy.Lifting
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FunctionFieldQuadratic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_congr
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_inv
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_isUniformization_toPoint
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_natCard_ker_pointMapOfPushforward_eq_finrankAlong
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_discriminant_ne_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_min_ord_le_ord_add_v2
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Lifting a function-field map of complex tori to an entire function
+
+Theorem statement: `PeriodPair.exists_differentiable_toPoint_comp_eq_pointMapOfPushforward_toPoint`
+(`e5395f79-d46c-5b66-a6aa-c05a04dab723`), by Claude, 2026-09-05.
+
+Proof: submission `8fe161dd-bc82-51ec-93f4-d8f706ef4404`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ and $L'$ be period pairs, and assume $L.g_2^3 - 27\,L.g_3^2 \neq 0$ and $L'.g_2^3 -
+27\,L'.g_3^2 \neq 0$, so that the associated Weierstrass curves $y^2 = x^3 - (g_2/4)x - (g_3/4)$
+over $\mathbb{C}$ (with $a_1=a_2=a_3=0$) are elliptic. Each of the two affine curves is assumed to
+carry: a `GenusOnePlaceGate`, i.e. a bijection between its points and the places of its function
+field over $\mathbb{C}$, all of these places having degree $1$; the centring condition, i.e. at the
+place attached to a nonsingular point $(x,y)$ the images in the function field of the
+coordinate-ring classes of $X$ and of $Y - y$ lie in the nonunits of the valuation subring; and
+`AbelTheorem`, i.e. a divisor of degree $0$ is principal exactly when its `divisorSum` vanishes. Let
+$\iota$ be a $\mathbb{C}$-algebra homomorphism from the function field of $L'$'s curve to that of
+$L$'s curve, with $\iota$ integral as a ring homomorphism, making the target a finite module over
+the source along $\iota$ (`FiniteAlong`), and satisfying the pushforward norm formula along $\iota$:
+for every nonzero $f$ in the larger field and every divisor $D$ with $D(w) =
+\operatorname{ord}_w(f)$ at all places $w$, the pushforward of $D$ satisfies $(\iota_* D)(v) =
+\operatorname{ord}_v(\mathrm{N}(f))$ at all places $v$ of the smaller field. The conclusion asserts
+the existence of an entire function $F : \mathbb{C} \to \mathbb{C}$ with $F(0)$ in the lattice of
+$L'$ such that for every $z \in \mathbb{C}$ one has $\pi_{L'}(F(z)) = \varphi(\pi_L(z))$, where
+$\pi_L$ denotes the uniformisation $z \mapsto 0$ for $z$ in the lattice and $z \mapsto (\wp(z),
+\wp'(z))$ otherwise, and $\varphi$ is `pointMapOfPushforward`, the additive homomorphism from the
+points of $L$'s curve to those of $L'$'s curve obtained by transporting the pushforward along
+$\iota$ on degree-zero divisor classes through the two genus-one identifications of points with
+$\mathrm{Pic}^0$.
+
+This is the analytic lifting statement for a rational map between complex tori: the induced
+homomorphism on points, defined here divisor-theoretically as a pushforward on $\mathrm{Pic}^0$, is
+covered by a holomorphic map of the universal covers $\mathbb{C} \to \mathbb{C}$ sending $0$ into
+the target lattice. It is used in the passage from such a map to the lattice-theoretic data of a
+scaled sublattice of finite index with cyclic quotient.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_PeriodPair_exists_differentiable_toPoint_comp_eq_pointMapOfPushforward_toPoint.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_302e4807
+
+
+noncomputable section
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ Affine.negY a₃ a₁ map Affine.CoordinateRing mk a₄ \
+  a₂ a₆ Affine.Point.some Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ \
+  Affine.equation_iff Affine.Point.neg_some j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  slope_of_X_ne slope CoordinateRing map Point.some Point.some.injEq Point.X_eq_iff Nonsingular \
+  negAddY Point.zero_def FunctionField Point CoordinateRing.mk addX nonsingular_neg \
+  equation_iff_nonsingular Point.some_ne_zero addY Point.add_of_X_ne equation_iff polynomial \
+  Point.neg_some pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_C polyToFunctionField_ne_zero \
+  algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_302e4807.Polynomial \
+  IsDedekindDomain \
+  P2MW.S_OVERLONG_302e4807.IsDedekindD\
+  omain WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_302e4807.AlgebraicCu\
+  rve"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_302e4807.Polynomial.\
+  Bivariate"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem S13_ofHeightOneSpectrum_injective {R : Type*} [CommRing R] [IsDedekindDomain R]
+    [Algebra R W.FunctionField] [IsFractionRing R W.FunctionField] [Algebra F R]
+    [IsScalarTower F R W.FunctionField] :
+    Function.Injective (AlgebraicCurve.Place.ofHeightOneSpectrum (K := F) (R := R) (F :=
+      W.FunctionField)) := by
+  intro w₁ w₂ h
+  refine HeightOneSpectrum.eq_of_valuation_isEquiv_valuation (K := W.FunctionField) ?_
+  rw [Valuation.isEquiv_iff_valuationSubring]
+  exact congrArg AlgebraicCurve.Place.toValuationSubring h
+
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "smul_basis_eq_zero XYIdeal \
+  quotientXYIdealEquiv YClass mk map exists_smul_basis_eq XClass smul_basis_mul_Y isDedekindDomain \
+  exists_eq_XYIdeal XYIdeal_isMaximal XYIdeal_ne_bot"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt"
+
+theorem algebraMap_eq_mk_C_C (a : F) :
+    algebraMap F W.CoordinateRing a = CoordinateRing.mk W (C (C a)) := by
+  rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+    Algebra.algebraMap_self_apply]
+  rfl
+
+theorem eq_of_XYIdeal_eq {x₁ y₁ x₂ y₂ : F} (h₂ : W.Equation x₂ y₂)
+    (h : XYIdeal W x₁ (C y₁) = XYIdeal W x₂ (C y₂)) : x₁ = x₂ ∧ y₁ = y₂ := by
+  have hne : XYIdeal W x₂ (C y₂) ≠ ⊤ := (XYIdeal_isMaximal h₂).ne_top
+  have hX₁ : XClass W x₁ ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert _ _)
+  have hX₂ : XClass W x₂ ∈ XYIdeal W x₂ (C y₂) := Ideal.subset_span (Set.mem_insert _ _)
+  have hY₁ : YClass W (C y₁) ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  have hY₂ : YClass W (C y₂) ∈ XYIdeal W x₂ (C y₂) :=
+    Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  constructor
+  · by_contra hx
+    apply hne
+    have hsub : XClass W x₁ - XClass W x₂ = algebraMap F W.CoordinateRing (x₂ - x₁) := by
+      rw [XClass, XClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      rw [← map_sub]
+      congr 1
+      rw [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hX₁ hX₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hx hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+  · by_contra hy
+    apply hne
+    have hsub : YClass W (C y₁) - YClass W (C y₂) = algebraMap F W.CoordinateRing (y₂ - y₁) := by
+      rw [YClass, YClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      simp only [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hY₁ hY₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hy hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+
+def heightOneSpectrumOfEquation {x y : F} (h : W.Equation x y) :
+    HeightOneSpectrum W.CoordinateRing where
+  asIdeal := XYIdeal W x (C y)
+  isPrime := (XYIdeal_isMaximal h).isPrime
+  ne_bot := XYIdeal_ne_bot x (C y)
+
+@[scoped simp]
+theorem heightOneSpectrumOfEquation_asIdeal {x y : F} (h : W.Equation x y) :
+    (heightOneSpectrumOfEquation h).asIdeal = XYIdeal W x (C y) := rfl
+
+theorem exists_sub_algebraMap_mem {x y : F} (h : W.Equation x y) (r : W.CoordinateRing) :
+    ∃ c : F, r - algebraMap F W.CoordinateRing c ∈ XYIdeal W x (C y) := by
+  set e := quotientXYIdealEquiv (W' := W) (x := x) (y := C y) h
+  refine ⟨e (Ideal.Quotient.mk _ r), ?_⟩
+  rw [← Ideal.Quotient.eq_zero_iff_mem, map_sub, sub_eq_zero]
+  apply e.injective
+  rw [← Ideal.Quotient.algebraMap_eq, ← IsScalarTower.algebraMap_apply, AlgEquiv.commutes,
+    Algebra.algebraMap_self_apply]
+
+end CoordinateRing
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve.Affine.CoordinateRing"
+
+def IsFinitePlace (v : AlgebraicCurve.Place F W.FunctionField) : Prop :=
+  ∀ r : W.CoordinateRing, algebraMap W.CoordinateRing W.FunctionField r ∈ v.toValuationSubring
+
+def IsFinitePlace.ringHom {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    W.CoordinateRing →+* v.toValuationSubring where
+  toFun r := ⟨algebraMap W.CoordinateRing W.FunctionField r, hv r⟩
+  map_one' := Subtype.ext (map_one _)
+  map_mul' a b := Subtype.ext (map_mul _ a b)
+  map_zero' := Subtype.ext (map_zero _)
+  map_add' a b := Subtype.ext (map_add _ a b)
+
+@[scoped simp]
+theorem IsFinitePlace.coe_ringHom_apply {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) (r : W.CoordinateRing) :
+    (hv.ringHom r : W.FunctionField) = algebraMap W.CoordinateRing W.FunctionField r := rfl
+
+
+def IsFinitePlace.centre {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    Ideal W.CoordinateRing :=
+  (IsLocalRing.maximalIdeal v.toValuationSubring).comap hv.ringHom
+
+theorem IsFinitePlace.centre_isPrime {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre.IsPrime :=
+  Ideal.IsPrime.comap _
+
+theorem IsFinitePlace.inv_mem {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) {r : W.CoordinateRing} (hr : r ∉ hv.centre) :
+    (algebraMap W.CoordinateRing W.FunctionField r)⁻¹ ∈ v.toValuationSubring := by
+  have hunit : IsUnit (hv.ringHom r) := by
+    rw [IsFinitePlace.centre, Ideal.mem_comap, IsLocalRing.mem_maximalIdeal,
+      mem_nonunits_iff, not_not] at hr
+    exact hr
+  obtain ⟨t, ht⟩ := hunit.exists_right_inv
+  have ht' : algebraMap W.CoordinateRing W.FunctionField r * (t : W.FunctionField) = 1 := by
+    have := congrArg (fun a : v.toValuationSubring => (a : W.FunctionField)) ht
+    simpa using this
+  rw [inv_eq_of_mul_eq_one_right ht']
+  exact t.2
+
+theorem IsFinitePlace.centre_ne_bot {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre ≠ ⊥ := by
+  intro hbot
+  apply v.ne_top'
+  rw [eq_top_iff]
+  rintro z -
+  obtain ⟨r, s, hs, hz⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  have hs0 : s ∉ hv.centre := by
+    rw [hbot, Ideal.mem_bot]
+    exact fun h => nonZeroDivisors.ne_zero hs h
+  rw [← hz, div_eq_mul_inv]
+  exact mul_mem (hv r) (hv.inv_mem hs0)
+
+variable [IsDedekindDomain W.CoordinateRing]
+
+def placeOfEquation {x y : F} (h : W.Equation x y) :
+    AlgebraicCurve.Place F W.FunctionField :=
+  AlgebraicCurve.Place.ofHeightOneSpectrum (heightOneSpectrumOfEquation h)
+
+theorem placeOfEquation_injective {x₁ y₁ x₂ y₂ : F} (h₁ : W.Equation x₁ y₁)
+    (h₂ : W.Equation x₂ y₂) (h : placeOfEquation h₁ = placeOfEquation h₂) :
+    x₁ = x₂ ∧ y₁ = y₂ :=
+  eq_of_XYIdeal_eq h₂
+    (congrArg HeightOneSpectrum.asIdeal (S13_ofHeightOneSpectrum_injective h))
+
+theorem isFinitePlace_placeOfEquation {x y : F} (h : W.Equation x y) :
+    IsFinitePlace (placeOfEquation h) := fun r =>
+  (heightOneSpectrumOfEquation h).valuation_le_one r
+
+theorem isFinitePlace_iff_exists_placeOfEquation [IsAlgClosed F]
+    (v : AlgebraicCurve.Place F W.FunctionField) :
+    IsFinitePlace v ↔ ∃ (x y : F) (h : W.Equation x y), v = placeOfEquation h := by
+  constructor
+  · intro hv
+    have := hv.centre_isPrime
+    have hmax : hv.centre.IsMaximal := Ideal.IsPrime.isMaximal hv.centre_isPrime hv.centre_ne_bot
+    obtain ⟨x, y, hxy, hXY⟩ :=
+      CoordinateRing.exists_eq_XYIdeal (W := W) (P := hv.centre) hv.centre_ne_bot
+    refine ⟨x, y, hxy, ?_⟩
+    set w : HeightOneSpectrum W.CoordinateRing := heightOneSpectrumOfEquation hxy with hw
+    set A : ValuationSubring W.FunctionField :=
+      HeightOneSpectrum.valuationSubringAtPrime W.FunctionField w with hA
+    have hAded : IsDedekindDomain A := by rw [hA]; infer_instance
+    have hle : A ≤ v.toValuationSubring := by
+      intro z hz
+      rw [hA] at hz
+      obtain ⟨r, s, hs, rfl⟩ := hz
+      have hs' : s ∉ hv.centre := by
+        intro hmem
+        rw [hXY] at hmem
+        exact hs hmem
+      exact mul_mem (hv r) (hv.inv_mem hs')
+    have hSP : A.ofPrime (A.idealOfLE v.toValuationSubring hle) = v.toValuationSubring :=
+      ValuationSubring.ofPrime_idealOfLE A v.toValuationSubring hle
+    rcases eq_or_ne (A.idealOfLE v.toValuationSubring hle) ⊥ with hP | hP
+    · exfalso
+      apply v.ne_top'
+      have h2 : A.ofPrime ⊥ ≤ A.ofPrime (A.idealOfLE v.toValuationSubring hle) :=
+        ValuationSubring.ofPrime_le_of_le (h := hP.le)
+      rw [ValuationSubring.ofPrime_bot] at h2
+      exact top_le_iff.mp (le_trans h2 hSP.le)
+    · have hPmax : (A.idealOfLE v.toValuationSubring hle).IsMaximal :=
+        Ideal.IsPrime.isMaximal inferInstance hP
+      have hPeq : A.idealOfLE v.toValuationSubring hle = IsLocalRing.maximalIdeal A :=
+        IsLocalRing.eq_maximalIdeal hPmax
+      have h3 : A.ofPrime (A.idealOfLE v.toValuationSubring hle)
+          = A.ofPrime (IsLocalRing.maximalIdeal A) :=
+        le_antisymm (ValuationSubring.ofPrime_le_of_le (h := hPeq.ge))
+          (ValuationSubring.ofPrime_le_of_le (h := hPeq.le))
+      rw [ValuationSubring.ofPrime_top] at h3
+      have hAv : A = v.toValuationSubring := h3.symm.trans hSP
+      refine (AlgebraicCurve.Place.ext ?_).symm
+      change (AlgebraicCurve.Place.ofHeightOneSpectrum w).toValuationSubring = v.toValuationSubring
+      rw [AlgebraicCurve.Place.ofHeightOneSpectrum_toValuationSubring,
+        ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact hAv
+  · rintro ⟨x, y, h, rfl⟩
+    exact isFinitePlace_placeOfEquation h
+
+scoped instance S13_instIsDedekindDomainCoordinateRing [IsAlgClosed F] [W.IsElliptic] :
+    IsDedekindDomain W.CoordinateRing :=
+  CoordinateRing.isDedekindDomain (W := W)
+
+section CentredGate
+
+variable [DecidableEq F] [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W]
+
+omit [DecidableEq F] in
+@[scoped simp]
+theorem placeOfPoint_some {x y : F} (h : W.Nonsingular x y) :
+    placeOfPoint (.some x y h) = placeOfEquation h.left := by
+  classical
+  exact
+    placeOfPoint_some_eq_ofHeightOneSpectrum h (heightOneSpectrumOfEquation h.left) rfl
+
+namespace InfinitePlace
+
+def place : AlgebraicCurve.Place F W.FunctionField := placeOfPoint (0 : W.Point)
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+private theorem _root_.WeierstrassCurve.Affine.InfinitePlace.deg_eq_one :
+    (place : AlgebraicCurve.Place F W.FunctionField).deg = 1 := by
+  classical
+  exact
+    deg_placeOfPoint (W := W) 0
+
+p2m_export "WeierstrassCurve.Affine.InfinitePlace" "deg_eq_one"
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] in
+theorem not_isFinitePlace [IsAlgClosed F] [W.IsElliptic] :
+    ¬ IsFinitePlace (place : AlgebraicCurve.Place F W.FunctionField) := by
+  classical
+  exact
+    fun h =>
+     algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero (W := W) (h _)
+
+omit [DecidableEq F] in
+theorem eq_of_not_isFinitePlace
+    (v : AlgebraicCurve.Place F W.FunctionField) (hv : ¬ IsFinitePlace v) :
+    v = place := by
+  classical
+  obtain ⟨P, rfl⟩ : ∃ P : W.Point, placeOfPoint P = v :=
+    ⟨(pointEquivPlace (W := W)).symm v, (pointEquivPlace (W := W)).apply_symm_apply v⟩
+  cases P with
+  | zero => rfl
+  | some x y h =>
+      exact absurd (placeOfPoint_some (W := W) h ▸ isFinitePlace_placeOfEquation h.left) hv
+
+end InfinitePlace
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+@[scoped simp]
+theorem placeOfPoint_zero : placeOfPoint (.zero : W.Point) = InfinitePlace.place := by
+  classical
+  exact
+    rfl
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_zero' : placeOfPoint (0 : W.Point) = InfinitePlace.place := by
+  classical
+  exact
+    rfl
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_injective : Function.Injective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).injective
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_surjective (_hΔ : W.Δ ≠ 0) : Function.Surjective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).surjective
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_surjective' : Function.Surjective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).surjective
+
+end CentredGate
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ Affine.negY a₃ a₁ map Affine.CoordinateRing mk a₄ \
+  a₂ a₆ Affine.Point.some Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ \
+  Affine.equation_iff Affine.Point.neg_some j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  slope_of_X_ne slope CoordinateRing map Point.some Point.some.injEq Point.X_eq_iff Nonsingular \
+  negAddY Point.zero_def FunctionField Point CoordinateRing.mk addX nonsingular_neg \
+  equation_iff_nonsingular Point.some_ne_zero addY Point.add_of_X_ne equation_iff polynomial \
+  Point.neg_some pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_C polyToFunctionField_ne_zero \
+  algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_302e4807.AlgebraicCu\
+  rve"
+
+scoped instance instHasPrincipalDivisorsFunctionField_s13 {F : Type*} [Field F] [CharZero F]
+    {W : Affine F} : HasPrincipalDivisors F W.FunctionField :=
+  hasPrincipalDivisors_functionField W
+
+section AutoNorm
+variable {F : Type*} [Field F] [CharZero F]
+variable {V W : Affine F} [V.IsElliptic] [W.IsElliptic]
+
+omit [WeierstrassCurve.IsElliptic V] [WeierstrassCurve.IsElliptic W] in
+theorem normFormulaAlong_of_elliptic (ι : V.FunctionField →ₐ[F] W.FunctionField)
+    (hfin : FiniteAlong F ι) : NormFormulaAlong F ι hfin := by
+  classical
+  have : HasPrincipalDivisors F W.FunctionField := hasPrincipalDivisors_functionField W
+  have : CharZero V.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap F V.FunctionField).injective
+  have hsep : SeparableAlong F ι := by
+    let := algebraAlong ι
+    have := isScalarTower_along ι
+    have : Module.Finite V.FunctionField W.FunctionField := hfin
+    change Algebra.IsSeparable V.FunctionField W.FunctionField
+    infer_instance
+  exact AlgebraicCurve.normFormulaAlong ι hfin hsep
+
+end AutoNorm
+
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι"
+p2m_open "WeierstrassCurve.Affine.IsogenyEndDatum"
+
+variable {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [GenusOnePlaceGate W] [AbelTheorem W]
+
+omit [DecidableEq F] [W.GenusOnePlaceGate] [W.AbelTheorem] in
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+private theorem _root_.WeierstrassCurve.Affine.IsogenyEndDatum.normFormulaAlong_auto (D :
+  IsogenyEndDatum W) :
+    NormFormulaAlong F D.ι D.hfin :=
+  normFormulaAlong_of_elliptic D.ι D.hfin
+
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "normFormulaAlong_auto"
+
+private def _root_.WeierstrassCurve.Affine.IsogenyEndDatum.pointEnd' (D : IsogenyEndDatum W) :
+    AddMonoid.End W.Point := D.pointEnd D.normFormulaAlong_auto
+
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd'"
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd_eq_pointEnd' (D : IsogenyEndDatum W) (hN : NormFormulaAlong F D.ι D.hfin) :
+    D.pointEnd hN = D.pointEnd' := rfl
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd'_apply (D : IsogenyEndDatum W) (P : W.Point) :
+    D.pointEnd' P = genusOnePic0Equiv W
+      (Pic0.pushforwardAlongHom D.ι D.hι D.hfin D.normFormulaAlong_auto (pointClass P)) :=
+  pointEnd_apply D _ P
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd'_eq_of_seam (D : IsogenyEndDatum W) (g : W.Point → W.Point) (hg0 : g 0 = 0)
+    (hg : ∀ P, (placeOfPoint P).restrictAlong D.ι D.hι = placeOfPoint (g P)) (P : W.Point) :
+    D.pointEnd' P = g P :=
+  pointEnd_eq_of_seam D _ g hg0 hg P
+
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ Affine.negY a₃ a₁ map Affine.CoordinateRing mk a₄ \
+  a₂ a₆ Affine.Point.some Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ \
+  Affine.equation_iff Affine.Point.neg_some j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  slope_of_X_ne slope CoordinateRing map Point.some Point.some.injEq Point.X_eq_iff Nonsingular \
+  negAddY Point.zero_def FunctionField Point CoordinateRing.mk addX nonsingular_neg \
+  equation_iff_nonsingular Point.some_ne_zero addY Point.add_of_X_ne equation_iff polynomial \
+  Point.neg_some pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_C polyToFunctionField_ne_zero \
+  algebraMap_smul_basis"
+end Affine
+end WeierstrassCurve
+p2m_open_scoped "WeierstrassCurve WeierstrassCurve.Affine" in
+scoped instance WeierstrassCurve.Affine.instHasPrincipalDivisorsFunctionField_s13e2
+    {F : Type*} [Field F] [CharZero F] (W : WeierstrassCurve.Affine F) :
+    AlgebraicCurve.HasPrincipalDivisors F W.FunctionField :=
+  WeierstrassCurve.Affine.hasPrincipalDivisors_functionField W
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.restrict_fiber_finite Place Place.ext \
+  Place.coe_algebraMap HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring HasPrincipalDivisors.exists_divisor \
+  Place.toValuationSubring Place.evalAt Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict_fiber_finite ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_ne_zero ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero IsRational evalAt algebraMap_evalAt \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_ne_zero evalAt_congr \
+  ord_algebraMap evalAt_algebraMap evalAt_mul evalAt_inv"
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.restrict_fiber_finite Place Place.ext \
+  Place.coe_algebraMap HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring HasPrincipalDivisors.exists_divisor \
+  Place.toValuationSubring Place.evalAt Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict_fiber_finite ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_ne_zero ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero IsRational evalAt algebraMap_evalAt \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_ne_zero evalAt_congr \
+  ord_algebraMap evalAt_algebraMap evalAt_mul evalAt_inv"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg"
+
+section MoreSinglePlace
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.isRational_of_deg_eq_one (h : v.deg = 1) :
+    v.IsRational := by
+  intro x
+  have hbot : (⊥ : Subalgebra K v.ResidueField) = ⊤ :=
+    Subalgebra.bot_eq_top_iff_finrank_eq_one.mpr h
+  have hx : x ∈ (⊥ : Subalgebra K v.ResidueField) := by
+    rw [hbot]
+    exact Algebra.mem_top
+  exact Algebra.mem_bot.mp hx
+
+p2m_export "AlgebraicCurve.Place" "isRational_of_deg_eq_one"
+
+private theorem _root_.AlgebraicCurve.Place.evalAt_div (hv : v.IsRational) {f g : F}
+    (hf : f ∈ v.toValuationSubring)
+    (hg : g ≠ 0) (hg0 : v.ord g = 0) :
+    v.evalAt (f / g) = v.evalAt f / v.evalAt g := by
+  have hginv : g⁻¹ ∈ v.toValuationSubring :=
+    AlgebraicCurve.Place.mem_of_ord_nonneg v (inv_ne_zero hg) (by
+      rw [v.ord_inv, hg0]; exact neg_nonneg.mpr le_rfl)
+  rw [div_eq_mul_inv, v.evalAt_mul hv hf hginv, v.evalAt_inv hv hg hg0, div_eq_mul_inv]
+
+p2m_export "AlgebraicCurve.Place" "evalAt_div"
+end MoreSinglePlace
+
+theorem mem_restrictAlong_iff {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F]
+    [Algebra K F']
+    (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') (f : F) :
+    f ∈ (w.restrictAlong φ hφ).toValuationSubring ↔ φ f ∈ w.toValuationSubring :=
+  Iff.rfl
+
+end Place
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ Affine.negY a₃ a₁ map Affine.CoordinateRing mk a₄ \
+  a₂ a₆ Affine.Point.some Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ \
+  Affine.equation_iff Affine.Point.neg_some j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  slope_of_X_ne slope CoordinateRing map Point.some Point.some.injEq Point.X_eq_iff Nonsingular \
+  negAddY Point.zero_def FunctionField Point CoordinateRing.mk addX nonsingular_neg \
+  equation_iff_nonsingular Point.some_ne_zero addY Point.add_of_X_ne equation_iff polynomial \
+  Point.neg_some pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_C polyToFunctionField_ne_zero \
+  algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_302e4807.AlgebraicCu\
+  rve Polynomial \
+  P2MW.S_OVERLONG_302e4807.Polynomial"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_302e4807.Polynomial.\
+  Bivariate"
+
+section FinitePlaceOfMem
+variable {F : Type*} [Field F] {W : Affine F}
+variable (v : AlgebraicCurve.Place F W.FunctionField)
+
+theorem isFinitePlace_of_mem
+    (hx : polyToFunctionField W X ∈ v.toValuationSubring) : IsFinitePlace v := by
+  have hpoly : ∀ p : F[X], polyToFunctionField W p ∈ v.toValuationSubring := by
+    intro p
+    induction p using Polynomial.induction_on' with
+    | add f g hf hg => rw [map_add]; exact add_mem hf hg
+    | monomial n c =>
+        rw [← C_mul_X_pow_eq_monomial, map_mul, map_pow]
+        refine mul_mem ?_ (pow_mem hx n)
+        rw [polyToFunctionField_C]
+        exact v.algebraMap_mem' c
+  set η := algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) with hηdef
+  set c₁ : F[X] := C W.a₁ * X + C W.a₃ with hc₁def
+  set cb : F[X] := X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ with hcbdef
+  have hrel : η * η = polyToFunctionField W cb - polyToFunctionField W c₁ * η := by
+    have h1 := smul_basis_mul_Y (W' := W) 0 1
+    rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at h1
+    have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) h1
+    rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+    exact h2
+  have hy : η ∈ v.toValuationSubring := by
+    refine v.mem_of_eval_monic_eq_zero (P := Polynomial.X ^ 2
+      + (Polynomial.C (polyToFunctionField W c₁) * Polynomial.X
+        - Polynomial.C (polyToFunctionField W cb))) ?_ ?_ (x := η) ?_
+    · refine Polynomial.monic_X_pow_add (n := 2) ?_
+      rw [sub_eq_add_neg, ← Polynomial.C_neg]
+      refine lt_of_le_of_lt Polynomial.degree_linear_le ?_
+      exact_mod_cast Nat.one_lt_two
+    · intro i
+      rw [show (Polynomial.C (polyToFunctionField W c₁) * Polynomial.X : Polynomial _)
+          = Polynomial.C (polyToFunctionField W c₁) * Polynomial.X ^ 1 by ring]
+      simp only [Polynomial.coeff_add, Polynomial.coeff_sub, Polynomial.coeff_X_pow,
+        Polynomial.coeff_C_mul, Polynomial.coeff_C]
+      refine add_mem ?_ (sub_mem ?_ ?_)
+      · split <;> simp [v.toValuationSubring.one_mem, v.toValuationSubring.zero_mem]
+      · split
+        · rw [mul_one]; exact hpoly _
+        · rw [mul_zero]; exact v.toValuationSubring.zero_mem
+      · split
+        · exact hpoly _
+        · exact v.toValuationSubring.zero_mem
+    · simp only [Polynomial.eval_add, Polynomial.eval_sub, Polynomial.eval_pow,
+        Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_X]
+      rw [sq]
+      linear_combination hrel
+  intro r
+  obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq r
+  rw [algebraMap_smul_basis]
+  exact add_mem (hpoly p) (mul_mem (hpoly q) hy)
+
+end FinitePlaceOfMem
+
+section RationalPlaceOfEquation
+variable {F : Type*} [Field F] {W : Affine F} [W.IsElliptic]
+  [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [IsDedekindDomain W.CoordinateRing]
+
+theorem isRational_placeOfEquation {r s : F} (hrs : W.Equation r s) :
+    (placeOfEquation hrs).IsRational := by
+  classical
+  apply (placeOfEquation hrs).isRational_of_deg_eq_one
+  rw [← placeOfPoint_some (equation_iff_nonsingular.mp hrs)]
+  exact GenusOnePlaceGate.deg_eq_one _
+
+end RationalPlaceOfEquation
+end Affine
+end WeierstrassCurve
+
+namespace ModularCurve
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg\
+  " in
+open _root_.WeierstrassCurve
+  _root_.P2MW.S_OVERLONG_302e4807.WeierstrassCurve
+  _root_.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_302e4807.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_302e4807.AlgebraicCurve
+  in
+theorem kw_fdn2_qephod_hend7_pmopKerCard_proved
+    (K : Type*) [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+    (E E' : WeierstrassCurve.Affine K) [E.IsElliptic]
+    [GenusOnePlaceGate E] [GenusOnePlaceGate.IsCentred E] [AbelTheorem E]
+    [E'.IsElliptic] [GenusOnePlaceGate E'] [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong K ι) :
+    Nat.card ((pointMapOfPushforward ι hι hfin
+      (normFormulaAlong_of_elliptic ι hfin)).ker) = finrankAlong K ι :=
+  natCard_ker_pointMapOfPushforward_eq_finrankAlong E E' ι hι hfin _
+end ModularCurve
+
+
+section
+p2m_open "Complex Filter \
+  P2MW.S_OVERLONG_302e4807.Filter Set"
+
+p2m_open_scoped "PeriodPair \
+  P2MW.S_OVERLONG_302e4807.PeriodPair"
+
+namespace PeriodPair
+p2m_export "PeriodPair" "isClosed_lattice derivWeierstrassP_neg weierstrassP_neg lattice \
+  weierstrassP_add_coe lattice_eq_span_range_basis ω₁ mk analyticOnNhd_derivWeierstrassP g₃ \
+  deriv_weierstrassP ω₂ derivWeierstrassP_add_coe mem_lattice G g₂ analyticOnNhd_weierstrassP \
+  weierstrassCurve weierstrassCurve_a₁ weierstrassCurve_a₂ weierstrassCurve_a₃ \
+  equation_weierstrassP DiscriminantNeZero toPoint toPoint_of_mem toPoint_zero toPoint_of_notMem \
+  IsUniformization jLattice scale_indep scale discriminant_ne_zero isUniformization_toPoint"
+p2m_open "PeriodPair"
+
+variable (L : PeriodPair)
+
+private theorem _root_.PeriodPair.kw_discriminantNeZero :
+    L.DiscriminantNeZero := L.discriminant_ne_zero
+
+p2m_export "PeriodPair" "kw_discriminantNeZero"
+
+private theorem _root_.PeriodPair.kw_isUniformization :
+    L.IsUniformization L.kw_discriminantNeZero :=
+  L.isUniformization_toPoint _
+
+p2m_export "PeriodPair" "kw_isUniformization"
+
+private theorem _root_.PeriodPair.kw_toPoint_add (hD : L.DiscriminantNeZero) (z w : ℂ) :
+    L.toPoint hD (z + w) = L.toPoint hD z + L.toPoint hD w :=
+  (L.isUniformization_toPoint hD).1 z w
+
+p2m_export "PeriodPair" "kw_toPoint_add"
+
+theorem kw_toPoint_surjective (hD : L.DiscriminantNeZero) : Function.Surjective (L.toPoint hD) :=
+  (L.isUniformization_toPoint hD).2.1
+
+theorem kw_toPoint_eq_zero_iff (hD : L.DiscriminantNeZero) (z : ℂ) :
+    L.toPoint hD z = 0 ↔ z ∈ L.lattice :=
+  ⟨(L.isUniformization_toPoint hD).2.2 z, fun hz => L.toPoint_of_mem hD hz⟩
+
+scoped instance kw_instIsElliptic : L.weierstrassCurve.IsElliptic :=
+  ⟨isUnit_iff_ne_zero.mpr L.kw_discriminantNeZero.weierstrassCurve_Δ_ne_zero⟩
+
+section Liouville
+
+private theorem _root_.PeriodPair.sub_fract_mem_lattice (z : ℂ) :
+    z - ZSpan.fract L.basis z ∈ L.lattice := by
+  rw [L.lattice_eq_span_range_basis]
+  have h := (ZSpan.fract_eq_fract L.basis (ZSpan.fract L.basis z) z).mp
+    (by rw [ZSpan.fract_eq_self.mpr (ZSpan.fract_mem_fundamentalDomain L.basis z)])
+  simpa [neg_add_eq_sub] using h
+
+p2m_export "PeriodPair" "sub_fract_mem_lattice"
+
+private theorem _root_.PeriodPair.apply_eq_apply_of_differentiable_of_forall_periodic {f : ℂ → ℂ}
+    (hf : Differentiable ℂ f) (hper : ∀ l ∈ L.lattice, ∀ z, f (z + l) = f z) (z w : ℂ) :
+    f z = f w := by
+  apply hf.apply_eq_apply_of_bounded
+  have hrange : range f ⊆ f '' closure (ZSpan.fundamentalDomain L.basis) := by
+    rintro - ⟨u, rfl⟩
+    refine ⟨ZSpan.fract L.basis u, subset_closure (ZSpan.fract_mem_fundamentalDomain _ u), ?_⟩
+    have h := hper _ (L.sub_fract_mem_lattice u) (ZSpan.fract L.basis u)
+    rw [add_sub_cancel] at h
+    exact h.symm
+  refine Bornology.IsBounded.subset ?_ hrange
+  refine (IsCompact.image ?_ hf.continuous).isBounded
+  exact Metric.isCompact_of_isClosed_isBounded isClosed_closure
+    (ZSpan.fundamentalDomain_isBounded L.basis).closure
+
+p2m_export "PeriodPair" "apply_eq_apply_of_differentiable_of_forall_periodic"
+end Liouville
+
+section ToPointLemmas
+
+theorem toPoint_add_mem (h : L.DiscriminantNeZero) (z : ℂ) {l : ℂ} (hl : l ∈ L.lattice) :
+    L.toPoint h (z + l) = L.toPoint h z := by
+  by_cases hz : z ∈ L.lattice
+  · rw [L.toPoint_of_mem h hz, L.toPoint_of_mem h (add_mem hz hl)]
+  · have hzl : z + l ∉ L.lattice := fun hmem => hz (by simpa using sub_mem hmem hl)
+    rw [L.toPoint_of_notMem h hz, L.toPoint_of_notMem h hzl]
+    have hP : ℘[L] (z + l) = ℘[L] z := L.weierstrassP_add_coe z ⟨l, hl⟩
+    have hP' : ℘'[L] (z + l) = ℘'[L] z := L.derivWeierstrassP_add_coe z ⟨l, hl⟩
+    simp only [WeierstrassCurve.Affine.Point.some.injEq]
+    exact ⟨hP, by rw [hP']⟩
+
+theorem toPoint_neg (h : L.DiscriminantNeZero) (z : ℂ) :
+    L.toPoint h (-z) = -L.toPoint h z := by
+  by_cases hz : z ∈ L.lattice
+  · rw [L.toPoint_of_mem h hz, L.toPoint_of_mem h (neg_mem hz)]; rfl
+  · have hnz : -z ∉ L.lattice := fun hmem => hz (by simpa using neg_mem hmem)
+    rw [L.toPoint_of_notMem h hz, L.toPoint_of_notMem h hnz,
+      WeierstrassCurve.Affine.Point.neg_some]
+    simp only [WeierstrassCurve.Affine.Point.some.injEq]
+    refine ⟨L.weierstrassP_neg z, ?_⟩
+    rw [L.derivWeierstrassP_neg]
+    show -℘'[L] z / 2 = L.weierstrassCurve.toAffine.negY (℘[L] z) (℘'[L] z / 2)
+    rw [WeierstrassCurve.Affine.negY, weierstrassCurve_a₁, weierstrassCurve_a₃]
+    ring
+
+end ToPointLemmas
+
+section Isogeny
+
+private theorem _root_.PeriodPair.apply_eq_apply_of_continuous_of_mapsTo_lattice {f : ℂ → ℂ}
+    (hf : Continuous f)
+    (hmem : ∀ z, f z ∈ L.lattice) (z w : ℂ) : f z = f w := by
+  refine IsPreconnected.constant_of_mapsTo (isPreconnected_univ) ?_
+    hf.continuousOn (fun u _ => hmem u) (mem_univ z) (mem_univ w)
+  rw [isDiscrete_iff_discreteTopology]
+  exact inferInstanceAs (DiscreteTopology L.lattice)
+
+p2m_export "PeriodPair" "apply_eq_apply_of_continuous_of_mapsTo_lattice"
+
+theorem exists_smul_mem_and_apply_eq_of_forall_sub_mem (L' : PeriodPair) {F : ℂ → ℂ}
+    (hF : Differentiable ℂ F)
+    (hper : ∀ l ∈ L.lattice, ∀ z, F (z + l) - F z ∈ L'.lattice) :
+    ∃ α : ℂ, (∀ l ∈ L.lattice, α * l ∈ L'.lattice) ∧ ∀ z, F z = F 0 + α * z := by
+  have hFc : Continuous F := hF.continuous
+  have hconst : ∀ l ∈ L.lattice, ∀ z, F (z + l) - F z = F l - F 0 := by
+    intro l hl z
+    have h := L'.apply_eq_apply_of_continuous_of_mapsTo_lattice
+      (f := fun u => F (u + l) - F u)
+      ((hFc.comp (continuous_id.add continuous_const)).sub hFc) (hper l hl) z 0
+    simpa using h
+  have hadd : ∀ z w, F (z + w) = F z + F w - F 0 := by
+    intro z w
+    have hper' : ∀ l ∈ L.lattice, ∀ u,
+        (fun u => F (u + w) - F u) (u + l) = (fun u => F (u + w) - F u) u := by
+      intro l hl u
+      have h1 := hconst l hl (u + w)
+      have h2 := hconst l hl u
+      rw [show u + w + l = u + l + w by ring] at h1
+      simp only
+      linear_combination h1 - h2
+    have h := L.apply_eq_apply_of_differentiable_of_forall_periodic
+      (f := fun u => F (u + w) - F u)
+      ((hF.comp (differentiable_id.add_const w)).sub hF) hper' z 0
+    simp only [zero_add] at h
+    linear_combination h
+  set α : ℂ := deriv F 0 with hα
+  have hderiv : ∀ z, deriv F z = α := by
+    intro z
+    have hfun : (fun w => F (z + w)) = fun w => F w + (F z - F 0) := by
+      funext w
+      rw [hadd z w]; ring
+    have h1 : deriv (fun w => F (z + w)) 0 = deriv F z := by
+      rw [deriv_comp_const_add]
+      simp
+    have h2 : deriv (fun w => F w + (F z - F 0)) 0 = deriv F 0 := by
+      rw [deriv_add_const]
+    rw [← h1, hfun, h2]
+  have haffine : ∀ z, F z = F 0 + α * z := by
+    have hG : Differentiable ℂ fun z => F z - α * z :=
+      hF.sub (differentiable_id.const_mul α)
+    have hG' : ∀ z, deriv (fun z => F z - α * z) z = 0 := by
+      intro z
+      have hd : HasDerivAt (fun z => F z - α * z) (deriv F z - α * 1) z :=
+        (hF z).hasDerivAt.sub ((hasDerivAt_id z).const_mul α)
+      rw [hd.deriv, hderiv z]
+      ring
+    intro z
+    have h := is_const_of_deriv_eq_zero hG hG' z 0
+    simp only [mul_zero, sub_zero] at h
+    linear_combination h
+  refine ⟨α, fun l hl => ?_, haffine⟩
+  have h := hper l hl 0
+  rw [zero_add, haffine l] at h
+  simpa using h
+
+end Isogeny
+
+section Scale
+
+variable (α : ℂˣ)
+
+private def mulLeftR (a : ℂ) : ℂ →ₗ[ℝ] ℂ := Algebra.lmul ℝ ℂ a
+
+@[scoped simp] private theorem mulLeftR_apply (a z : ℂ) : mulLeftR a z = a * z := rfl
+
+private theorem mulLeftR_injective {a : ℂ} (ha : a ≠ 0) :
+    Function.Injective (mulLeftR a) := fun _ _ h => by
+  simpa using mul_left_cancel₀ ha h
+
+private def mulLeftZ (a : ℂ) : ℂ →ₗ[ℤ] ℂ := (mulLeftR a).restrictScalars ℤ
+
+@[scoped simp] private theorem mulLeftZ_apply (a z : ℂ) : mulLeftZ a z = a * z := rfl
+
+private theorem _root_.PeriodPair.scale_lattice :
+    (L.scale α).lattice = Submodule.map (mulLeftZ (α : ℂ)) L.lattice := by
+  unfold lattice scale
+  rw [Submodule.map_span]
+  congr 1
+  ext z
+  simp only [Set.mem_insert_iff, Set.mem_singleton_iff, Set.mem_image, mulLeftZ_apply]
+  constructor
+  · rintro (rfl | rfl)
+    · exact ⟨L.ω₁, Or.inl rfl, rfl⟩
+    · exact ⟨L.ω₂, Or.inr rfl, rfl⟩
+  · rintro ⟨w, hw | hw, rfl⟩ <;> simp [hw]
+
+p2m_export "PeriodPair" "scale_lattice"
+theorem mem_scale_lattice_iff {z : ℂ} :
+    z ∈ (L.scale α).lattice ↔ ∃ l ∈ L.lattice, z = (α : ℂ) * l := by
+  rw [scale_lattice, Submodule.mem_map]; simp only [mulLeftZ_apply]; tauto
+
+private def _root_.PeriodPair.scaleLatticeEquiv : L.lattice ≃ₗ[ℤ] (L.scale α).lattice :=
+  (Submodule.equivMapOfInjective (mulLeftZ (α : ℂ))
+    (fun _ _ h => mul_left_cancel₀ α.ne_zero (by simpa using h)) L.lattice).trans
+    (LinearEquiv.ofEq _ _ (L.scale_lattice α).symm)
+
+p2m_export "PeriodPair" "scaleLatticeEquiv"
+@[scoped simp] theorem scaleLatticeEquiv_apply (l : L.lattice) :
+    ((L.scaleLatticeEquiv α l : (L.scale α).lattice) : ℂ) = (α : ℂ) * (l : ℂ) := rfl
+
+end Scale
+
+section Homogeneity
+
+variable (α : ℂˣ)
+
+theorem G_scale (n : ℕ) : (L.scale α).G n = ((α : ℂ) ^ n)⁻¹ * L.G n := by
+  unfold G
+  rw [← (L.scaleLatticeEquiv α).toEquiv.tsum_eq]
+  simp only [LinearEquiv.coe_toEquiv, scaleLatticeEquiv_apply, mul_pow, mul_inv]
+  exact tsum_mul_left
+
+theorem g₂_scale : (L.scale α).g₂ = ((α : ℂ) ^ 4)⁻¹ * L.g₂ := by
+  unfold g₂; rw [G_scale]; ring
+
+theorem g₃_scale : (L.scale α).g₃ = ((α : ℂ) ^ 6)⁻¹ * L.g₃ := by
+  unfold g₃; rw [G_scale]; ring
+
+theorem discriminant_scale :
+    (L.scale α).g₂ ^ 3 - 27 * (L.scale α).g₃ ^ 2
+      = ((α : ℂ) ^ 12)⁻¹ * (L.g₂ ^ 3 - 27 * L.g₃ ^ 2) := by
+  rw [g₂_scale, g₃_scale]; ring
+
+theorem g₂_cubed_scale : (L.scale α).g₂ ^ 3 = ((α : ℂ) ^ 12)⁻¹ * L.g₂ ^ 3 := by
+  rw [g₂_scale, mul_pow, inv_pow, ← pow_mul]
+
+theorem jLattice_scale : (L.scale α).jLattice = L.jLattice := by
+  have hα : ((α : ℂ) ^ 12)⁻¹ ≠ 0 := inv_ne_zero (pow_ne_zero _ α.ne_zero)
+  unfold jLattice
+  rw [discriminant_scale, g₂_cubed_scale, mul_left_comm (1728 : ℂ), mul_div_mul_left _ _ hα]
+
+theorem discriminantNeZero_scale_iff :
+    (L.scale α).DiscriminantNeZero ↔ L.DiscriminantNeZero := by
+  unfold DiscriminantNeZero
+  rw [discriminant_scale]
+  simp only [mul_ne_zero_iff, and_iff_right (inv_ne_zero (pow_ne_zero 12 α.ne_zero))]
+
+end Homogeneity
+
+section LatticeDependence
+
+variable {L L' : PeriodPair}
+
+private def latticeEquivOfEq (h : L.lattice = L'.lattice) : L.lattice ≃ L'.lattice where
+  toFun l := ⟨(l : ℂ), h ▸ l.2⟩
+  invFun l := ⟨(l : ℂ), h.symm ▸ l.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+
+theorem G_eq_of_lattice_eq (h : L.lattice = L'.lattice) (n : ℕ) : L.G n = L'.G n :=
+  (latticeEquivOfEq h).tsum_eq fun l => ((l : ℂ) ^ n)⁻¹
+
+theorem g₂_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.g₂ = L'.g₂ := by
+  unfold g₂; rw [G_eq_of_lattice_eq h]
+
+theorem g₃_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.g₃ = L'.g₃ := by
+  unfold g₃; rw [G_eq_of_lattice_eq h]
+
+theorem jLattice_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.jLattice = L'.jLattice := by
+  unfold jLattice; rw [g₂_eq_of_lattice_eq h, g₃_eq_of_lattice_eq h]
+
+end LatticeDependence
+
+section Gates
+
+theorem gate_scale_mul (α β : ℂˣ) :
+    ((L.scale α).scale β).lattice = (L.scale (β * α)).lattice := by
+  ext z
+  simp only [mem_scale_lattice_iff, Units.val_mul]
+  constructor
+  · rintro ⟨-, ⟨l, hl, rfl⟩, rfl⟩; exact ⟨l, hl, (mul_assoc _ _ _).symm⟩
+  · rintro ⟨l, hl, rfl⟩; exact ⟨(α : ℂ) * l, ⟨l, hl, rfl⟩, mul_assoc _ _ _⟩
+
+end Gates
+
+private theorem _root_.PeriodPair.kw_countable_lattice : (L.lattice : Set ℂ).Countable := by
+  refine (Set.countable_range fun p : ℤ × ℤ => (p.1 : ℂ) * L.ω₁ + (p.2 : ℂ) * L.ω₂).mono ?_
+  intro z hz
+  obtain ⟨m, n, h⟩ := mem_lattice.mp hz
+  exact ⟨(m, n), h⟩
+
+p2m_export "PeriodPair" "kw_countable_lattice"
+
+private def _root_.PeriodPair.kw_toPointHom : ℂ →+ (L.weierstrassCurve.toAffine).Point where
+  toFun := L.toPoint L.kw_discriminantNeZero
+  map_zero' := L.toPoint_zero L.kw_discriminantNeZero
+  map_add' := L.kw_toPoint_add L.kw_discriminantNeZero
+
+p2m_export "PeriodPair" "kw_toPointHom"
+private theorem _root_.PeriodPair.kw_toPointHom_apply (z : ℂ) :
+    L.kw_toPointHom z = L.toPoint L.kw_discriminantNeZero z := rfl
+
+p2m_export "PeriodPair" "kw_toPointHom_apply"
+
+private theorem _root_.PeriodPair.kw_ker_toPointHom :
+    L.kw_toPointHom.ker = L.lattice.toAddSubgroup := by
+  ext z
+  constructor
+  · exact fun hz => (L.kw_isUniformization).2.2 z hz
+  · intro hz
+    exact L.toPoint_of_mem L.kw_discriminantNeZero hz
+
+p2m_export "PeriodPair" "kw_ker_toPointHom"
+
+private def _root_.PeriodPair.kw_toPointAddEquiv :
+    (ℂ ⧸ L.lattice.toAddSubgroup) ≃+ (L.weierstrassCurve.toAffine).Point :=
+  QuotientAddGroup.liftEquiv L.lattice.toAddSubgroup (φ := L.kw_toPointHom)
+    (L.kw_isUniformization).2.1 L.kw_ker_toPointHom.symm
+
+p2m_export "PeriodPair" "kw_toPointAddEquiv"
+theorem kw_toPointAddEquiv_mk (z : ℂ) :
+    L.kw_toPointAddEquiv (QuotientAddGroup.mk z) = L.toPoint L.kw_discriminantNeZero z :=
+  rfl
+
+scoped instance kw_infinite_quotientLattice : Infinite (ℂ ⧸ L.lattice.toAddSubgroup) := by
+  rw [← not_finite_iff_infinite]; intro hfin
+  have : Countable L.lattice.toAddSubgroup :=
+    Set.countable_coe_iff.mpr L.kw_countable_lattice
+  have : Countable ((ℂ ⧸ L.lattice.toAddSubgroup) × L.lattice.toAddSubgroup) := inferInstance
+  have hCc : Countable ℂ :=
+    Countable.of_equiv _ (AddSubgroup.addGroupEquivQuotientProdAddSubgroup
+      (s := L.lattice.toAddSubgroup)).symm
+  have : Uncountable ℂ := Complex.ofReal_injective.uncountable
+  exact absurd hCc not_countable
+
+scoped instance kw_infinite_point : Infinite L.weierstrassCurve.toAffine.Point :=
+  L.kw_toPointAddEquiv.toEquiv.infinite_iff.mp inferInstance
+
+end PeriodPair
+end
+
+namespace ModularCurve
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve.Affine \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_302e4807.AlgebraicCu\
+  rve PeriodPair \
+  P2MW.S_OVERLONG_302e4807.PeriodPair"
+
+def KwD5BetweenCurvesHoloLift : Prop :=
+  ∀ (L L' : PeriodPair)
+    [L.weierstrassCurve.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve]
+    (ι'' : L'.weierstrassCurve.toAffine.FunctionField →ₐ[ℂ]
+      L.weierstrassCurve.toAffine.FunctionField)
+    (hι'' : ι''.toRingHom.IsIntegral) (hfin'' : FiniteAlong ℂ ι''),
+    ∃ (F : ℂ → ℂ), Differentiable ℂ F ∧ F 0 ∈ L'.lattice ∧
+      ∀ z, L'.kw_toPointHom (F z)
+        = (pointMapOfPushforward ι'' hι'' hfin''
+            (normFormulaAlong_of_elliptic ι'' hfin'')) (L.kw_toPointHom z)
+
+end ModularCurve
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.restrict_fiber_finite Place Place.ext \
+  Place.coe_algebraMap HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring HasPrincipalDivisors.exists_divisor \
+  Place.toValuationSubring Place.evalAt Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+end AlgebraicCurve
+namespace Filter
+p2m_export "Filter" "mem_bot ker mk mem_comap inter_mem IsBounded cocountable mem_ker \
+  eventually_of_mem mem_map mem_top comap map cofinite"
+end Filter
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "HeightOneSpectrum.valuationSubringAtPrime HeightOneSpectrum.asIdeal \
+  HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring \
+  HeightOneSpectrum.eq_of_valuation_isEquiv_valuation mk HeightOneSpectrum"
+end IsDedekindDomain
+namespace IsLocalRing
+p2m_export "IsLocalRing" "eq_maximalIdeal ResidueField maximalIdeal mem_maximalIdeal \
+  ResidueField.algebraMap_eq residue"
+end IsLocalRing
+namespace PeriodPair
+p2m_export "PeriodPair" "isClosed_lattice derivWeierstrassP_neg weierstrassP_neg lattice \
+  weierstrassP_add_coe lattice_eq_span_range_basis ω₁ mk analyticOnNhd_derivWeierstrassP g₃ \
+  deriv_weierstrassP ω₂ derivWeierstrassP_add_coe mem_lattice G g₂ analyticOnNhd_weierstrassP \
+  weierstrassCurve weierstrassCurve_a₁ weierstrassCurve_a₂ weierstrassCurve_a₃ \
+  equation_weierstrassP DiscriminantNeZero toPoint toPoint_of_mem toPoint_zero toPoint_of_notMem \
+  IsUniformization jLattice scale_indep scale discriminant_ne_zero isUniformization_toPoint"
+end PeriodPair
+namespace Polynomial
+p2m_export "Polynomial" "C X eval_mul support coeff_add algebraMap_eq monomial ext_iff degree \
+  monic_X_pow_add degree_linear_le coeff_sub X_sub_C_ne_zero map comp roots coeff_C eval_pow sum \
+  infinite reverse eval_X eval_C nontrivial flt X_ne_zero eval_sub pow mem_support_iff \
+  C_mul_X_pow_eq_monomial derivative mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero \
+  algebraMap_apply div C_neg coeff_C_mul eval_add evalEval ext coeff_X_pow funext ring lifts \
+  restriction eval"
+end Polynomial
+namespace Polynomial
+p2m_export "Polynomial" "C X eval_mul support coeff_add algebraMap_eq monomial ext_iff degree \
+  monic_X_pow_add degree_linear_le coeff_sub X_sub_C_ne_zero map comp roots coeff_C eval_pow sum \
+  infinite reverse eval_X eval_C nontrivial flt X_ne_zero eval_sub pow mem_support_iff \
+  C_mul_X_pow_eq_monomial derivative mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero \
+  algebraMap_apply div C_neg coeff_C_mul eval_add evalEval ext coeff_X_pow funext ring lifts \
+  restriction eval"
+end Polynomial
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ Affine.negY a₃ a₁ map Affine.CoordinateRing mk a₄ \
+  a₂ a₆ Affine.Point.some Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ \
+  Affine.equation_iff Affine.Point.neg_some j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ Affine.negY a₃ a₁ map Affine.CoordinateRing mk a₄ \
+  a₂ a₆ Affine.Point.some Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ \
+  Affine.equation_iff Affine.Point.neg_some j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  slope_of_X_ne slope CoordinateRing map Point.some Point.some.injEq Point.X_eq_iff Nonsingular \
+  negAddY Point.zero_def FunctionField Point CoordinateRing.mk addX nonsingular_neg \
+  equation_iff_nonsingular Point.some_ne_zero addY Point.add_of_X_ne equation_iff polynomial \
+  Point.neg_some pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_C polyToFunctionField_ne_zero \
+  algebraMap_smul_basis"
+end Affine
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ Affine.negY a₃ a₁ map Affine.CoordinateRing mk a₄ \
+  a₂ a₆ Affine.Point.some Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ \
+  Affine.equation_iff Affine.Point.neg_some j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  slope_of_X_ne slope CoordinateRing map Point.some Point.some.injEq Point.X_eq_iff Nonsingular \
+  negAddY Point.zero_def FunctionField Point CoordinateRing.mk addX nonsingular_neg \
+  equation_iff_nonsingular Point.some_ne_zero addY Point.add_of_X_ne equation_iff polynomial \
+  Point.neg_some pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_C polyToFunctionField_ne_zero \
+  algebraMap_smul_basis"
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "smul_basis_eq_zero XYIdeal \
+  quotientXYIdealEquiv YClass mk map exists_smul_basis_eq XClass smul_basis_mul_Y isDedekindDomain \
+  exists_eq_XYIdeal XYIdeal_isMaximal XYIdeal_ne_bot"
+end CoordinateRing
+end Affine
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ Affine.negY a₃ a₁ map Affine.CoordinateRing mk a₄ \
+  a₂ a₆ Affine.Point.some Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ \
+  Affine.equation_iff Affine.Point.neg_some j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ Affine.negY a₃ a₁ map Affine.CoordinateRing mk a₄ \
+  a₂ a₆ Affine.Point.some Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ \
+  Affine.equation_iff Affine.Point.neg_some j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+end WeierstrassCurve
+
+
+section
+
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve.Affine \
+  P2MW.S_OVERLONG_302e4807.ModularCurv\
+  e AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_302e4807.AlgebraicCu\
+  rve"
+
+namespace PeriodPair
+p2m_export "PeriodPair" "isClosed_lattice derivWeierstrassP_neg weierstrassP_neg lattice \
+  weierstrassP_add_coe lattice_eq_span_range_basis ω₁ mk analyticOnNhd_derivWeierstrassP g₃ \
+  deriv_weierstrassP ω₂ derivWeierstrassP_add_coe mem_lattice G g₂ analyticOnNhd_weierstrassP \
+  weierstrassCurve weierstrassCurve_a₁ weierstrassCurve_a₂ weierstrassCurve_a₃ \
+  equation_weierstrassP DiscriminantNeZero toPoint toPoint_of_mem toPoint_zero toPoint_of_notMem \
+  IsUniformization jLattice scale_indep scale discriminant_ne_zero isUniformization_toPoint"
+p2m_open "PeriodPair"
+
+variable (L : PeriodPair)
+
+private theorem _root_.PeriodPair.kw_isDiscrete_lattice :
+    IsDiscrete (L.lattice.toAddSubgroup : Set ℂ) := by
+  rw [Submodule.coe_toAddSubgroup, isDiscrete_iff_discreteTopology]
+  exact inferInstanceAs (DiscreteTopology L.lattice)
+
+p2m_export "PeriodPair" "kw_isDiscrete_lattice"
+private theorem _root_.PeriodPair.kw_isCoveringMap_mk_lattice :
+    IsCoveringMap (QuotientAddGroup.mk (s := L.lattice.toAddSubgroup)) :=
+  (AddSubgroup.isAddQuotientCoveringMap_of_comm L.lattice.toAddSubgroup
+    L.kw_isDiscrete_lattice).isCoveringMap
+
+p2m_export "PeriodPair" "kw_isCoveringMap_mk_lattice"
+private theorem _root_.PeriodPair.kw_differentiable_of_locally_differentiable_lift_through_mk
+    {F : ℂ → ℂ} (hFc : Continuous F)
+    (hloc : ∀ z₀ : ℂ, ∃ U ∈ nhds z₀, ∃ G : ℂ → ℂ, DifferentiableOn ℂ G U ∧
+      ∀ z ∈ U, (QuotientAddGroup.mk (s := L.lattice.toAddSubgroup) (F z) :
+        ℂ ⧸ L.lattice.toAddSubgroup) = QuotientAddGroup.mk (G z)) :
+    Differentiable ℂ F := by
+  intro z₀
+  obtain ⟨U, hU, G, hGd, heq⟩ := hloc z₀
+  obtain ⟨ε, hε, hεU⟩ := Metric.mem_nhds_iff.mp hU
+  set V := Metric.ball z₀ ε
+  have hVnhds : V ∈ nhds z₀ := Metric.ball_mem_nhds z₀ hε
+  have hz₀V : z₀ ∈ V := Metric.mem_ball_self hε
+  have hmem : Set.MapsTo (fun z => F z - G z) V (L.lattice.toAddSubgroup : Set ℂ) := by
+    intro z hz
+    have h0 : (QuotientAddGroup.mk (s := L.lattice.toAddSubgroup) (F z - G z)
+        : ℂ ⧸ L.lattice.toAddSubgroup) = 0 := by
+      rw [QuotientAddGroup.mk_sub, heq z (hεU hz), sub_self]
+    exact (QuotientAddGroup.eq_zero_iff _).mp h0
+  have hcont : ContinuousOn (fun z => F z - G z) V :=
+    hFc.continuousOn.sub (hGd.mono hεU).continuousOn
+  have hconst : ∀ z ∈ V, F z - G z = F z₀ - G z₀ := fun z hz =>
+    (convex_ball z₀ ε).isPreconnected.constant_of_mapsTo L.kw_isDiscrete_lattice
+      hcont hmem hz hz₀V
+  have hFeq : ∀ z ∈ V, F z = F z₀ - G z₀ + G z := fun z hz => by
+    rw [← hconst z hz, sub_add_cancel]
+  exact (((differentiableOn_const (F z₀ - G z₀)).add (hGd.mono hεU)).congr
+    (fun z hz => hFeq z hz)).differentiableAt hVnhds
+
+p2m_export "PeriodPair" "kw_differentiable_of_locally_differentiable_lift_through_mk"
+private theorem _root_.PeriodPair.kw_toPointHom_eq_toPointAddEquiv_mk (z : ℂ) :
+    L.kw_toPointHom z = L.kw_toPointAddEquiv (QuotientAddGroup.mk z) := rfl
+
+p2m_export "PeriodPair" "kw_toPointHom_eq_toPointAddEquiv_mk"
+end PeriodPair
+end
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_302e4807.Polynomial \
+  IsDedekindDomain \
+  P2MW.S_OVERLONG_302e4807.IsDedekindD\
+  omain"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_302e4807.Polynomial.\
+  Bivariate"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.restrict_fiber_finite Place Place.ext \
+  Place.coe_algebraMap HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring HasPrincipalDivisors.exists_divisor \
+  Place.toValuationSubring Place.evalAt Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict_fiber_finite ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_ne_zero ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero IsRational evalAt algebraMap_evalAt \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_ne_zero evalAt_congr \
+  ord_algebraMap evalAt_algebraMap evalAt_mul evalAt_inv"
+end Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+theorem Place.ramificationIndexAlong_pos (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') : 0 < Place.ramificationIndexAlong φ w := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  exact w.ramificationIndex_pos
+
+namespace Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+private theorem _root_.AlgebraicCurve.Place.ord_div (v : Place K F) {f g : F} (hf : f ≠ 0)
+    (hg : g ≠ 0) :
+    v.ord (f / g) = v.ord f - v.ord g := by
+  rw [div_eq_mul_inv, v.ord_mul hf (inv_ne_zero hg), v.ord_inv]
+  ring
+
+end Place
+p2m_export "AlgebraicCurve" "Place.ord_div"
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ Affine.negY a₃ a₁ map Affine.CoordinateRing mk a₄ \
+  a₂ a₆ Affine.Point.some Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ \
+  Affine.equation_iff Affine.Point.neg_some j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  slope_of_X_ne slope CoordinateRing map Point.some Point.some.injEq Point.X_eq_iff Nonsingular \
+  negAddY Point.zero_def FunctionField Point CoordinateRing.mk addX nonsingular_neg \
+  equation_iff_nonsingular Point.some_ne_zero addY Point.add_of_X_ne equation_iff polynomial \
+  Point.neg_some pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_C polyToFunctionField_ne_zero \
+  algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_302e4807.AlgebraicCu\
+  rve"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem algebraMap_polynomial_eq_mk_C (p : F[X]) :
+    algebraMap F[X] W.CoordinateRing p = CoordinateRing.mk W (C p) :=
+  rfl
+
+theorem mk_mem_XYIdeal_iff {x y : F} (h : W.Equation x y) (P : F[X][Y]) :
+    CoordinateRing.mk W P ∈ XYIdeal W x (C y) ↔ P.evalEval x y = 0 := by
+  have hmap : XYIdeal W x (C y)
+      = Ideal.map (CoordinateRing.mk W) (Ideal.span {C (X - C x), Y - C (C y)}) := by
+    rw [Ideal.map_span, Set.image_pair]
+    rfl
+  rw [hmap]
+  constructor
+  · intro hP
+    obtain ⟨Q, hQ, hQP⟩ := (Ideal.mem_map_iff_of_surjective _ AdjoinRoot.mk_surjective).mp hP
+    obtain ⟨c, hc⟩ := AdjoinRoot.mk_eq_mk.mp hQP
+    have hQ0 : Q.evalEval x y = 0 :=
+      mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero.mp hQ
+    have hW0 : W.polynomial.evalEval x y = 0 := h
+    have hPQ : P = Q - W.polynomial * c := by rw [← hc]; ring
+    rw [hPQ]
+    simp only [evalEval, eval_sub, eval_mul] at hQ0 hW0 ⊢
+    rw [hQ0, hW0, zero_mul, sub_zero]
+  · intro hP
+    exact Ideal.mem_map_of_mem _ (mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero.mpr hP)
+
+theorem ord_placeOfEquation_ne_zero_iff [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) {r : W.CoordinateRing} (hr : r ≠ 0) :
+    (placeOfEquation h).ord (algebraMap W.CoordinateRing W.FunctionField r) ≠ 0
+      ↔ r ∈ XYIdeal W x (C y) := by
+  rw [placeOfEquation, Place.ord_ofHeightOneSpectrum_ne_zero_iff _ hr,
+    heightOneSpectrumOfEquation_asIdeal]
+
+theorem ord_placeOfEquation_nonneg [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) (r : W.CoordinateRing) :
+    0 ≤ (placeOfEquation h).ord (algebraMap W.CoordinateRing W.FunctionField r) :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem (placeOfEquation h) (isFinitePlace_placeOfEquation h r)
+
+theorem ord_placeOfEquation_pos_iff [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) {r : W.CoordinateRing} (hr : r ≠ 0) :
+    0 < (placeOfEquation h).ord (algebraMap W.CoordinateRing W.FunctionField r)
+      ↔ r ∈ XYIdeal W x (C y) := by
+  rw [← ord_placeOfEquation_ne_zero_iff h hr]
+  have := ord_placeOfEquation_nonneg h r
+  omega
+
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ Affine.negY a₃ a₁ map Affine.CoordinateRing mk a₄ \
+  a₂ a₆ Affine.Point.some Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ \
+  Affine.equation_iff Affine.Point.neg_some j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  slope_of_X_ne slope CoordinateRing map Point.some Point.some.injEq Point.X_eq_iff Nonsingular \
+  negAddY Point.zero_def FunctionField Point CoordinateRing.mk addX nonsingular_neg \
+  equation_iff_nonsingular Point.some_ne_zero addY Point.add_of_X_ne equation_iff polynomial \
+  Point.neg_some pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_C polyToFunctionField_ne_zero \
+  algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_302e4807.AlgebraicCu\
+  rve"
+
+variable {F : Type*} [Field F] (W : Affine F)
+
+variable {W}
+
+def yGen (W : Affine F) : W.FunctionField :=
+  algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ Affine.negY a₃ a₁ map Affine.CoordinateRing mk a₄ \
+  a₂ a₆ Affine.Point.some Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ \
+  Affine.equation_iff Affine.Point.neg_some j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  slope_of_X_ne slope CoordinateRing map Point.some Point.some.injEq Point.X_eq_iff Nonsingular \
+  negAddY Point.zero_def FunctionField Point CoordinateRing.mk addX nonsingular_neg \
+  equation_iff_nonsingular Point.some_ne_zero addY Point.add_of_X_ne equation_iff polynomial \
+  Point.neg_some pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_C polyToFunctionField_ne_zero \
+  algebraMap_smul_basis"
+end Affine
+end WeierstrassCurve
+end
+
+
+section
+
+p2m_open "IsLocalRing \
+  P2MW.S_OVERLONG_302e4807.IsLocalRing"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.restrict_fiber_finite Place Place.ext \
+  Place.coe_algebraMap HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring HasPrincipalDivisors.exists_divisor \
+  Place.toValuationSubring Place.evalAt Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict_fiber_finite ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_ne_zero ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero IsRational evalAt algebraMap_evalAt \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_ne_zero evalAt_congr \
+  ord_algebraMap evalAt_algebraMap evalAt_mul evalAt_inv"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.ord_sub_evalAt_pos (hrat : v.IsRational) {f : F}
+    (hf : f ∈ v.toValuationSubring)
+    (hne : f - algebraMap K F (v.evalAt f) ≠ 0) :
+    0 < v.ord (f - algebraMap K F (v.evalAt f)) := by
+  have hmem : f - algebraMap K F (v.evalAt f) ∈ v.toValuationSubring :=
+    sub_mem hf (v.algebraMap_mem' _)
+  rcases eq_or_ne (v.ord (f - algebraMap K F (v.evalAt f))) 0 with h0 | h0
+  · exfalso
+    refine v.evalAt_ne_zero hrat hne h0 ?_
+    have hres : algebraMap K v.ResidueField
+        (v.evalAt (f - algebraMap K F (v.evalAt f))) = 0 := by
+      rw [v.algebraMap_evalAt hrat hmem]
+      have hcoe : (⟨f - algebraMap K F (v.evalAt f), hmem⟩ : v.toValuationSubring)
+          = ⟨f, hf⟩ - algebraMap K v.toValuationSubring (v.evalAt f) := by
+        refine Subtype.ext ?_
+        change f - algebraMap K F (v.evalAt f)
+          = f - (algebraMap K v.toValuationSubring (v.evalAt f) : F)
+        rw [Place.coe_algebraMap]
+      rw [hcoe, map_sub, sub_eq_zero, ← v.algebraMap_evalAt hrat hf,
+        IsScalarTower.algebraMap_apply K v.toValuationSubring v.ResidueField,
+        IsLocalRing.ResidueField.algebraMap_eq]
+    exact (map_eq_zero_iff _ (algebraMap K v.ResidueField).injective).mp hres
+  · have hnonneg := AlgebraicCurve.Place.ord_nonneg_of_mem v hmem
+    omega
+
+p2m_export "AlgebraicCurve.Place" "ord_sub_evalAt_pos"
+end Place
+end AlgebraicCurve
+end
+
+
+section
+
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_302e4807.AlgebraicCu\
+  rve WeierstrassCurve \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve.Affine"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ Affine.negY a₃ a₁ map Affine.CoordinateRing mk a₄ \
+  a₂ a₆ Affine.Point.some Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ \
+  Affine.equation_iff Affine.Point.neg_some j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  slope_of_X_ne slope CoordinateRing map Point.some Point.some.injEq Point.X_eq_iff Nonsingular \
+  negAddY Point.zero_def FunctionField Point CoordinateRing.mk addX nonsingular_neg \
+  equation_iff_nonsingular Point.some_ne_zero addY Point.add_of_X_ne equation_iff polynomial \
+  Point.neg_some pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_C polyToFunctionField_ne_zero \
+  algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem Δ_ne_zero_of_isElliptic : W.Δ ≠ 0 := W.isUnit_Δ.ne_zero
+
+def placeOfPointEquiv : W.Point ≃ AlgebraicCurve.Place F W.FunctionField :=
+  Equiv.ofBijective placeOfPoint
+    ⟨placeOfPoint_injective, placeOfPoint_surjective (Δ_ne_zero_of_isElliptic W)⟩
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem placeOfPoint_placeOfPointEquiv_symm (w : AlgebraicCurve.Place F W.FunctionField) :
+    placeOfPoint ((placeOfPointEquiv W).symm w) = w :=
+  (placeOfPointEquiv W).apply_symm_apply w
+
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι"
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+end
+
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve.Affine \
+  P2MW.S_OVERLONG_302e4807.ModularCurv\
+  e AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_302e4807.AlgebraicCu\
+  rve"
+
+namespace PeriodPair
+p2m_export "PeriodPair" "isClosed_lattice derivWeierstrassP_neg weierstrassP_neg lattice \
+  weierstrassP_add_coe lattice_eq_span_range_basis ω₁ mk analyticOnNhd_derivWeierstrassP g₃ \
+  deriv_weierstrassP ω₂ derivWeierstrassP_add_coe mem_lattice G g₂ analyticOnNhd_weierstrassP \
+  weierstrassCurve weierstrassCurve_a₁ weierstrassCurve_a₂ weierstrassCurve_a₃ \
+  equation_weierstrassP DiscriminantNeZero toPoint toPoint_of_mem toPoint_zero toPoint_of_notMem \
+  IsUniformization jLattice scale_indep scale discriminant_ne_zero isUniformization_toPoint"
+p2m_open "PeriodPair"
+
+variable (L : PeriodPair)
+
+private theorem _root_.PeriodPair.kw_surjective_toPointHom :
+    Function.Surjective L.kw_toPointHom := by
+  intro P
+  obtain ⟨z, hz⟩ := QuotientAddGroup.mk_surjective (L.kw_toPointAddEquiv.symm P)
+  exact ⟨z, by rw [L.kw_toPointHom_eq_toPointAddEquiv_mk, hz, AddEquiv.apply_symm_apply]⟩
+
+p2m_export "PeriodPair" "kw_surjective_toPointHom"
+end PeriodPair
+end
+
+
+section
+
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve.Affine \
+  P2MW.S_OVERLONG_302e4807.ModularCurv\
+  e AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_302e4807.AlgebraicCu\
+  rve PeriodPair \
+  P2MW.S_OVERLONG_302e4807.PeriodPair"
+
+namespace ModularCurve
+
+def KwD5BetweenCurvesLocallyHoloLift : Prop :=
+  ∀ (L L' : PeriodPair)
+    [L.weierstrassCurve.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve]
+    (ι'' : L'.weierstrassCurve.toAffine.FunctionField →ₐ[ℂ]
+      L.weierstrassCurve.toAffine.FunctionField)
+    (hι'' : ι''.toRingHom.IsIntegral) (hfin'' : FiniteAlong ℂ ι'') (z₀ : ℂ),
+    ∃ U ∈ nhds z₀, ∃ G : ℂ → ℂ, DifferentiableOn ℂ G U ∧
+      ∀ z ∈ U, L'.kw_toPointHom (G z)
+        = (pointMapOfPushforward ι'' hι'' hfin''
+            (normFormulaAlong_of_elliptic ι'' hfin'')) (L.kw_toPointHom z)
+
+theorem kw_surgehgf4_hH2_betweenCurvesHoloLift_of_locallyHolo
+    (hH2c : KwD5BetweenCurvesLocallyHoloLift) :
+    KwD5BetweenCurvesHoloLift := by
+  intro L L' _ _ _ _ _ _ _ _ ι'' hι'' hfin''
+  set ψ := pointMapOfPushforward ι'' hι'' hfin'' (normFormulaAlong_of_elliptic ι'' hfin'')
+    with hψdef
+  set g : ℂ → ℂ ⧸ L'.lattice.toAddSubgroup :=
+    fun z => L'.kw_toPointAddEquiv.symm (ψ (L.kw_toPointHom z)) with hg
+  have hgloc : ∀ z₀ : ℂ, ∃ U ∈ nhds z₀, ∃ G : ℂ → ℂ, DifferentiableOn ℂ G U ∧
+      ∀ z ∈ U, g z = QuotientAddGroup.mk (G z) := fun z₀ => by
+    obtain ⟨U, hU, G, hGd, hGint⟩ := hH2c L L' ι'' hι'' hfin'' z₀
+    exact ⟨U, hU, G, hGd, fun z hz => by
+      change L'.kw_toPointAddEquiv.symm (ψ (L.kw_toPointHom z)) = _
+      rw [hψdef, ← hGint z hz, L'.kw_toPointHom_eq_toPointAddEquiv_mk,
+        AddEquiv.symm_apply_apply]⟩
+  have hmkc : Continuous (QuotientAddGroup.mk (s := L'.lattice.toAddSubgroup)) :=
+    L'.kw_isCoveringMap_mk_lattice.continuous
+  have hgc : Continuous g := continuous_iff_continuousAt.mpr fun z₀ => by
+    obtain ⟨U, hU, G, hGd, heq⟩ := hgloc z₀
+    exact ((hmkc.comp_continuousOn hGd.continuousOn).congr
+      (fun z hz => heq z hz)).continuousAt hU
+  have hg0 : (QuotientAddGroup.mk (0 : ℂ) : ℂ ⧸ L'.lattice.toAddSubgroup)
+      = (⟨g, hgc⟩ : C(ℂ, ℂ ⧸ L'.lattice.toAddSubgroup)) 0 := by
+    simp only [ContinuousMap.coe_mk, hg, _root_.map_zero, QuotientAddGroup.mk_zero]
+  obtain ⟨F, ⟨hF0, hFlift⟩, -⟩ :=
+    L'.kw_isCoveringMap_mk_lattice.existsUnique_continuousMap_lifts ⟨g, hgc⟩ 0 0 hg0
+  have hFliftz : ∀ z, (QuotientAddGroup.mk (F z) : ℂ ⧸ L'.lattice.toAddSubgroup) = g z :=
+    fun z => congrFun hFlift z
+  refine ⟨F, ?_, ?_, ?_⟩
+  · refine L'.kw_differentiable_of_locally_differentiable_lift_through_mk F.continuous
+      (fun z₀ => ?_)
+    obtain ⟨U, hU, G, hGd, heq⟩ := hgloc z₀
+    exact ⟨U, hU, G, hGd, fun z hz => (hFliftz z).trans (heq z hz)⟩
+  · rw [hF0]; exact Submodule.zero_mem L'.lattice
+  · intro z
+    rw [L'.kw_toPointHom_eq_toPointAddEquiv_mk, hFliftz z, hg, AddEquiv.apply_symm_apply]
+
+end ModularCurve
+end
+
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve.Affine \
+  P2MW.S_OVERLONG_302e4807.ModularCurv\
+  e AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_302e4807.AlgebraicCu\
+  rve Filter \
+  P2MW.S_OVERLONG_302e4807.Filter \
+  Polynomial \
+  P2MW.S_OVERLONG_302e4807.Polynomial"
+p2m_open_scoped "PeriodPair \
+  P2MW.S_OVERLONG_302e4807.PeriodPair \
+  Topology \
+  P2MW.S_OVERLONG_302e4807.Topology"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ Affine.negY a₃ a₁ map Affine.CoordinateRing mk a₄ \
+  a₂ a₆ Affine.Point.some Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ \
+  Affine.equation_iff Affine.Point.neg_some j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  slope_of_X_ne slope CoordinateRing map Point.some Point.some.injEq Point.X_eq_iff Nonsingular \
+  negAddY Point.zero_def FunctionField Point CoordinateRing.mk addX nonsingular_neg \
+  equation_iff_nonsingular Point.some_ne_zero addY Point.add_of_X_ne equation_iff polynomial \
+  Point.neg_some pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_C polyToFunctionField_ne_zero \
+  algebraMap_smul_basis"
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι"
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ Affine.negY a₃ a₁ map Affine.CoordinateRing mk a₄ \
+  a₂ a₆ Affine.Point.some Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ \
+  Affine.equation_iff Affine.Point.neg_some j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  slope_of_X_ne slope CoordinateRing map Point.some Point.some.injEq Point.X_eq_iff Nonsingular \
+  negAddY Point.zero_def FunctionField Point CoordinateRing.mk addX nonsingular_neg \
+  equation_iff_nonsingular Point.some_ne_zero addY Point.add_of_X_ne equation_iff polynomial \
+  Point.neg_some pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_C polyToFunctionField_ne_zero \
+  algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve.Affine.CoordinateRing"
+
+variable {F : Type*} [Field F] {W : Affine F} [IsDedekindDomain W.CoordinateRing]
+
+theorem kw_evalAt_placeOfEquation_mk {r s : F} (hrs : W.Equation r s) (p : Polynomial F[X]) :
+    (placeOfEquation hrs).evalAt
+        (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W p))
+      = p.evalEval r s := by
+  have hmem : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W p)
+      ∈ (placeOfEquation hrs).toValuationSubring := isFinitePlace_placeOfEquation hrs _
+  have hdiffFF : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W p)
+        - algebraMap F W.FunctionField (p.evalEval r s)
+      = algebraMap W.CoordinateRing W.FunctionField
+          (CoordinateRing.mk W (p - C (C (p.evalEval r s)))) := by
+    rw [map_sub, IsScalarTower.algebraMap_apply F W.CoordinateRing W.FunctionField, ← map_sub,
+      show (algebraMap F W.CoordinateRing) (p.evalEval r s)
+        = CoordinateRing.mk W (C (C (p.evalEval r s))) from rfl]
+  have hmemzero : CoordinateRing.mk W (p - C (C (p.evalEval r s)))
+      ∈ XYIdeal W r (C s) := (mk_mem_XYIdeal_iff hrs _).mpr (by simp [evalEval])
+  refine ((placeOfEquation hrs).evalAt_congr hmem
+    ((placeOfEquation hrs).algebraMap_mem' _) ?_).trans
+    ((placeOfEquation hrs).evalAt_algebraMap _)
+  rcases eq_or_ne (CoordinateRing.mk W (p - C (C (p.evalEval r s)))) 0 with h0 | hne
+  · left; rw [hdiffFF, h0, _root_.map_zero]
+  · right; rw [hdiffFF]; exact (ord_placeOfEquation_pos_iff hrs hne).mpr hmemzero
+
+end Affine
+end WeierstrassCurve
+
+namespace PeriodPair
+p2m_export "PeriodPair" "isClosed_lattice derivWeierstrassP_neg weierstrassP_neg lattice \
+  weierstrassP_add_coe lattice_eq_span_range_basis ω₁ mk analyticOnNhd_derivWeierstrassP g₃ \
+  deriv_weierstrassP ω₂ derivWeierstrassP_add_coe mem_lattice G g₂ analyticOnNhd_weierstrassP \
+  weierstrassCurve weierstrassCurve_a₁ weierstrassCurve_a₂ weierstrassCurve_a₃ \
+  equation_weierstrassP DiscriminantNeZero toPoint toPoint_of_mem toPoint_zero toPoint_of_notMem \
+  IsUniformization jLattice scale_indep scale discriminant_ne_zero isUniformization_toPoint"
+p2m_open "PeriodPair"
+
+variable (L : PeriodPair)
+
+private theorem _root_.PeriodPair.kw_differentiableOn_eval_wp (q : ℂ[X]) :
+    DifferentiableOn ℂ (fun z => q.eval (℘[L] z)) (L.lattice : Set ℂ)ᶜ := by
+  have hP : DifferentiableOn ℂ ℘[L] (L.lattice : Set ℂ)ᶜ :=
+    L.analyticOnNhd_weierstrassP.differentiableOn
+  induction q using Polynomial.induction_on with
+  | C a => simp only [eval_C]; exact differentiableOn_const a
+  | add p q hp hq => simpa using hp.fun_add hq
+  | monomial n a ih =>
+    refine (ih.mul hP).congr fun z _ => ?_
+    simp only [eval_mul, eval_C, eval_pow, eval_X, pow_succ, Pi.mul_apply]; ring
+
+p2m_export "PeriodPair" "kw_differentiableOn_eval_wp"
+private theorem _root_.PeriodPair.kw_differentiableOn_evalEval_wp (p : Polynomial ℂ[X]) :
+    DifferentiableOn ℂ (fun z => p.evalEval (℘[L] z) (℘'[L] z / 2)) (L.lattice : Set ℂ)ᶜ := by
+  have hP' : DifferentiableOn ℂ (fun z => ℘'[L] z / 2) (L.lattice : Set ℂ)ᶜ :=
+    L.analyticOnNhd_derivWeierstrassP.differentiableOn.div_const 2
+  induction p using Polynomial.induction_on with
+  | C c => simpa [evalEval] using L.kw_differentiableOn_eval_wp c
+  | add p q hp hq => simpa [evalEval] using hp.fun_add hq
+  | monomial n c ih =>
+    refine (ih.mul hP').congr fun z _ => ?_
+    simp only [evalEval, eval_mul, eval_pow, eval_C, eval_X, pow_succ, Pi.mul_apply]; ring
+
+p2m_export "PeriodPair" "kw_differentiableOn_evalEval_wp"
+end PeriodPair
+end
+
+section
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_302e4807.Polynomial \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_302e4807.AlgebraicCu\
+  rve WeierstrassCurve \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve.Affine"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_302e4807.Polynomial.\
+  Bivariate"
+
+namespace ModularCurve
+namespace Mmr73
+
+universe u
+
+section PlaceEval
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem mmr73_cs_ord_neg (v : Place K F) (h : F) : v.ord (-h) = v.ord h := by
+  have _pin := Classical.em True
+  rcases eq_or_ne h 0 with rfl | hh
+  · rw [_root_.neg_zero]
+  · have h2 : v.ord (-h * -h) = v.ord (h * h) := by rw [neg_mul_neg]
+    rw [v.ord_mul (neg_ne_zero.mpr hh) (neg_ne_zero.mpr hh), v.ord_mul hh hh] at h2
+    omega
+
+theorem mmr73_cs_evalAt_eq_of_ord_sub_pos (v : Place K F) (hv : v.IsRational)
+    {f : F} {a : K} (hf : f ∈ v.toValuationSubring)
+    (hpos : 0 < v.ord (f - algebraMap K F a)) : v.evalAt f = a := by
+  have _pin := Classical.em True
+  by_contra hne
+  rcases eq_or_ne (f - algebraMap K F (v.evalAt f)) 0 with h0 | hne0
+  · have hfa : f - algebraMap K F a = algebraMap K F (v.evalAt f - a) := by
+      rw [map_sub, ← sub_eq_zero.mp h0]
+    rw [hfa, AlgebraicCurve.Place.ord_algebraMap v] at hpos
+    exact lt_irrefl 0 hpos
+  · have hpos2 : 0 < v.ord (f - algebraMap K F (v.evalAt f)) :=
+      v.ord_sub_evalAt_pos hv hf hne0
+    have hkey : algebraMap K F (v.evalAt f - a)
+        = (f - algebraMap K F a) + -(f - algebraMap K F (v.evalAt f)) := by
+      rw [map_sub]; ring
+    have hne2 : algebraMap K F (v.evalAt f - a) ≠ 0 := fun hcon =>
+      hne (sub_eq_zero.mp ((algebraMap K F).injective
+        (by rw [hcon, _root_.map_zero])))
+    have hmin := v.min_ord_le_ord_add'
+      (f := f - algebraMap K F a)
+      (g := -(f - algebraMap K F (v.evalAt f)))
+      (by rw [← hkey]; exact hne2)
+    rw [← hkey, AlgebraicCurve.Place.ord_algebraMap v, mmr73_cs_ord_neg] at hmin
+    exact absurd hmin (not_le.mpr (lt_min hpos hpos2))
+
+end PlaceEval
+end Mmr73
+end ModularCurve
+end
+end
+
+section
+
+
+section
+
+p2m_open "P2MW.S_OVERLONG_302e4807.Mod\
+  ularCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve.Affine Polynomial \
+  P2MW.S_OVERLONG_302e4807.Polynomial \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_302e4807.AlgebraicCu\
+  rve"
+
+namespace ModularCurve
+
+universe u
+
+attribute [local instance] Classical.propDecidable
+
+section GeomMorphBC
+
+variable {K : Type u} [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable {E E' : Affine K} [E.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E] [WeierstrassCurve.Affine.AbelTheorem E]
+    [E'.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E']
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E']
+    [WeierstrassCurve.Affine.AbelTheorem E']
+variable (ι : E'.FunctionField →ₐ[K] E.FunctionField)
+variable (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong K ι)
+
+def kw_fdn2_qephod_hend7_geomMorphBC : E.Point → E'.Point :=
+  fun P => (placeOfPointEquiv E').symm ((placeOfPoint P).restrictAlong ι hι)
+
+local notation "gBC" => kw_fdn2_qephod_hend7_geomMorphBC ι hι
+
+omit [WeierstrassCurve.IsElliptic E] [GenusOnePlaceGate.IsCentred E] [E.AbelTheorem] in
+omit [DecidableEq K] [IsAlgClosed K] [CharZero K] [GenusOnePlaceGate.IsCentred E']
+  [E'.AbelTheorem] in
+theorem kw_fdn2_qephod_hend7_placeOfPoint_geomMorphBC (P : E.Point) :
+    (placeOfPoint P).restrictAlong ι hι = placeOfPoint (gBC P) :=
+  (placeOfPoint_placeOfPointEquiv_symm E' _).symm
+
+omit [WeierstrassCurve.IsElliptic E] [GenusOnePlaceGate.IsCentred E] [E.AbelTheorem] in
+omit [DecidableEq K] [IsAlgClosed K] [CharZero K] [GenusOnePlaceGate.IsCentred E']
+  [E'.AbelTheorem] in
+theorem kw_fdn2_qephod_hend7_pushforwardDegZero_pointDivisor_geomMorphBC (P : E.Point) :
+    Pic0.pushforwardAlongDegZero ι hι (pointDivisor P)
+      = pointDivisor (gBC P) - pointDivisor (gBC 0) := by
+  refine Subtype.ext ?_
+  rw [Pic0.coe_pushforwardAlongDegZero, coe_pointDivisor, map_sub,
+    pushforwardAlong_single_eq ι hι, pushforwardAlong_single_eq ι hι,
+    kw_fdn2_qephod_hend7_placeOfPoint_geomMorphBC ι hι P,
+    kw_fdn2_qephod_hend7_placeOfPoint_geomMorphBC ι hι 0]
+  push_cast
+  rw [coe_pointDivisor, coe_pointDivisor, sub_sub_sub_cancel_right]
+
+include hfin in
+omit [WeierstrassCurve.IsElliptic E] [GenusOnePlaceGate.IsCentred E] [E.AbelTheorem] in
+omit [DecidableEq K] [IsAlgClosed K] [GenusOnePlaceGate.IsCentred E'] [E'.AbelTheorem] in
+theorem kw_fdn2_qephod_hend7_pushforwardHom_pointClass_eq_sub (P : E.Point) :
+    Pic0.pushforwardAlongHom ι hι hfin (normFormulaAlong_of_elliptic ι hfin)
+        (pointClass P)
+      = pointClass (gBC P) - pointClass (gBC 0) := by
+  change Pic0.pushforwardAlongHom ι hι hfin _ (Pic0.mk (pointDivisor P))
+      = Pic0.mk (pointDivisor (gBC P)) - Pic0.mk (pointDivisor (gBC 0))
+  rw [Pic0.pushforwardAlongHom_mk,
+    kw_fdn2_qephod_hend7_pushforwardDegZero_pointDivisor_geomMorphBC ι hι P]
+  rfl
+
+include hfin in
+omit [WeierstrassCurve.IsElliptic E] [GenusOnePlaceGate.IsCentred E] in
+omit [IsAlgClosed K] [GenusOnePlaceGate.IsCentred E'] in
+theorem kw_fdn2_qephod_hend7_pmop_eq_geomMorphBC_sub (P : E.Point) :
+    pointMapOfPushforward ι hι hfin (normFormulaAlong_of_elliptic ι hfin) P
+      = gBC P - gBC 0 := by
+  rw [pointMapOfPushforward_apply,
+    kw_fdn2_qephod_hend7_pushforwardHom_pointClass_eq_sub ι hι hfin P, map_sub,
+    genusOnePic0Equiv_apply, genusOnePic0Equiv_apply, pic0ToPoint_pointClass,
+    pic0ToPoint_pointClass]
+
+end GeomMorphBC
+end ModularCurve
+end
+end
+
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve.Affine \
+  P2MW.S_OVERLONG_302e4807.ModularCurv\
+  e AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_302e4807.AlgebraicCu\
+  rve Filter \
+  P2MW.S_OVERLONG_302e4807.Filter"
+p2m_open_scoped "PeriodPair \
+  P2MW.S_OVERLONG_302e4807.PeriodPair \
+  Topology \
+  P2MW.S_OVERLONG_302e4807.Topology"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ Affine.negY a₃ a₁ map Affine.CoordinateRing mk a₄ \
+  a₂ a₆ Affine.Point.some Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ \
+  Affine.equation_iff Affine.Point.neg_some j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  slope_of_X_ne slope CoordinateRing map Point.some Point.some.injEq Point.X_eq_iff Nonsingular \
+  negAddY Point.zero_def FunctionField Point CoordinateRing.mk addX nonsingular_neg \
+  equation_iff_nonsingular Point.some_ne_zero addY Point.add_of_X_ne equation_iff polynomial \
+  Point.neg_some pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_C polyToFunctionField_ne_zero \
+  algebraMap_smul_basis"
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι"
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+
+namespace PeriodPair
+p2m_export "PeriodPair" "isClosed_lattice derivWeierstrassP_neg weierstrassP_neg lattice \
+  weierstrassP_add_coe lattice_eq_span_range_basis ω₁ mk analyticOnNhd_derivWeierstrassP g₃ \
+  deriv_weierstrassP ω₂ derivWeierstrassP_add_coe mem_lattice G g₂ analyticOnNhd_weierstrassP \
+  weierstrassCurve weierstrassCurve_a₁ weierstrassCurve_a₂ weierstrassCurve_a₃ \
+  equation_weierstrassP DiscriminantNeZero toPoint toPoint_of_mem toPoint_zero toPoint_of_notMem \
+  IsUniformization jLattice scale_indep scale discriminant_ne_zero isUniformization_toPoint"
+p2m_open "PeriodPair"
+
+variable (L : PeriodPair)
+
+private theorem _root_.PeriodPair.kw_countable_toPointHom_preimage {T : Set
+  L.weierstrassCurve.toAffine.Point}
+    (hT : T.Finite) : (L.kw_toPointHom ⁻¹' T).Countable := by
+  have hcov : L.kw_toPointHom ⁻¹' T ⊆ ⋃ t ∈ T, L.kw_toPointHom ⁻¹' {t} := by
+    intro z hz; exact Set.mem_biUnion hz rfl
+  refine (Set.Countable.biUnion hT.countable fun t _ => ?_).mono hcov
+  obtain ⟨w, hw⟩ := L.kw_surjective_toPointHom t
+  have hfib : L.kw_toPointHom ⁻¹' {t} = (· + w) '' (L.lattice : Set ℂ) := by
+    ext z; simp only [Set.mem_preimage, Set.mem_singleton_iff, Set.mem_image]
+    constructor
+    · intro hz
+      refine ⟨z - w, ?_, by ring⟩
+      have h0 : L.kw_toPointHom (z - w) = 0 := by rw [map_sub, hz, hw, sub_self]
+      rw [← AddMonoidHom.mem_ker, L.kw_ker_toPointHom, Submodule.mem_toAddSubgroup] at h0
+      exact h0
+    · rintro ⟨l, hl, rfl⟩
+      have h0 : L.kw_toPointHom l = 0 := by
+        rw [← AddMonoidHom.mem_ker, L.kw_ker_toPointHom, Submodule.mem_toAddSubgroup]
+        exact hl
+      rw [map_add, hw, h0, zero_add]
+  rw [hfib]
+  exact L.kw_countable_lattice.image _
+
+p2m_export "PeriodPair" "kw_countable_toPointHom_preimage"
+end PeriodPair
+end
+
+
+section
+
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve.Affine \
+  P2MW.S_OVERLONG_302e4807.ModularCurv\
+  e AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_302e4807.AlgebraicCu\
+  rve PeriodPair \
+  P2MW.S_OVERLONG_302e4807.PeriodPair"
+
+namespace ModularCurve
+
+def KwD5BetweenCurvesCocountableHoloLift : Prop :=
+  ∀ (L L' : PeriodPair)
+    [L.weierstrassCurve.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve]
+    (ι'' : L'.weierstrassCurve.toAffine.FunctionField →ₐ[ℂ]
+      L.weierstrassCurve.toAffine.FunctionField)
+    (hι'' : ι''.toRingHom.IsIntegral) (hfin'' : FiniteAlong ℂ ι''),
+    ∃ S : Set ℂ, S.Countable ∧
+    ∀ z₀ ∉ S, ∃ U ∈ nhds z₀, ∃ G : ℂ → ℂ, DifferentiableOn ℂ G U ∧
+      ∀ z ∈ U, L'.kw_toPointHom (G z)
+        = (pointMapOfPushforward ι'' hι'' hfin''
+            (normFormulaAlong_of_elliptic ι'' hfin'')) (L.kw_toPointHom z)
+
+theorem kw_surgehgf4_hH2c_betweenCurvesLocallyHoloLift_of_cocountable
+    (hH2d : KwD5BetweenCurvesCocountableHoloLift) :
+    KwD5BetweenCurvesLocallyHoloLift := by
+  intro L L' _ _ _ _ _ _ _ _ ι'' hι'' hfin'' z₀
+  obtain ⟨S, hSc, hgen⟩ := hH2d L L' ι'' hι'' hfin''
+  obtain ⟨w, hw⟩ : ∃ w, z₀ + w ∉ S := by
+    obtain ⟨ζ, hζ⟩ := (hSc.isPathConnected_compl_of_one_lt_rank
+      (by simp [Complex.rank_real_complex])).nonempty
+    exact ⟨ζ - z₀, by rwa [add_sub_cancel]⟩
+  obtain ⟨U', hU', G', hG'd, hG'int⟩ := hgen (z₀ + w) hw
+  obtain ⟨cw, hcw⟩ := L'.kw_surjective_toPointHom
+    ((pointMapOfPushforward ι'' hι'' hfin''
+      (normFormulaAlong_of_elliptic ι'' hfin'')) (L.kw_toPointHom w))
+  refine ⟨(· + w) ⁻¹' U',
+    (continuous_add_const w).continuousAt.preimage_mem_nhds hU',
+    fun z => G' (z + w) - cw,
+    (hG'd.comp (differentiable_id.add_const w).differentiableOn
+      (Set.mapsTo_preimage _ _)).sub_const cw,
+    fun z hz => ?_⟩
+  rw [map_sub, hcw, hG'int (z + w) hz,
+    ← map_sub (pointMapOfPushforward ι'' hι'' hfin''
+      (normFormulaAlong_of_elliptic ι'' hfin'')),
+    ← map_sub L.kw_toPointHom, add_sub_cancel_right]
+
+theorem kw_surgehgf4_hH2_betweenCurvesHoloLift_of_cocountable
+    (hH2d : KwD5BetweenCurvesCocountableHoloLift) :
+    KwD5BetweenCurvesHoloLift :=
+  kw_surgehgf4_hH2_betweenCurvesHoloLift_of_locallyHolo
+    (kw_surgehgf4_hH2c_betweenCurvesLocallyHoloLift_of_cocountable hH2d)
+
+end ModularCurve
+end
+
+section
+
+
+section
+
+p2m_open "P2MW.S_OVERLONG_302e4807.Mod\
+  ularCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve.Affine Polynomial \
+  P2MW.S_OVERLONG_302e4807.Polynomial \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_302e4807.AlgebraicCu\
+  rve"
+
+namespace ModularCurve
+
+universe u
+
+attribute [local instance] Classical.propDecidable
+
+
+section Fintype
+
+variable {K : Type u} [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable {E E' : Affine K} [E.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E] [WeierstrassCurve.Affine.AbelTheorem E]
+    [E'.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E']
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E']
+    [WeierstrassCurve.Affine.AbelTheorem E']
+variable (ι : E'.FunctionField →ₐ[K] E.FunctionField)
+variable (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong K ι)
+
+include hfin in
+omit [DecidableEq K] [IsAlgClosed K] [CharZero K] [WeierstrassCurve.IsElliptic E]
+  [E.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred E] [E.AbelTheorem]
+  [WeierstrassCurve.IsElliptic E'] [E'.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred E']
+  [E'.AbelTheorem] in
+theorem kw_fdn2_qephod_hend10_finrankAlong_pos : 0 < finrankAlong K ι := by
+  unfold finrankAlong
+  let := algebraAlong ι
+  have : Module.Finite E'.FunctionField E.FunctionField := hfin
+  exact Module.finrank_pos
+
+theorem kw_fdn2_qephod_hend10_kerPMOP_finite :
+    Finite ↥(AddMonoidHom.ker
+      (pointMapOfPushforward ι hι hfin (normFormulaAlong_of_elliptic ι hfin))) := by
+  refine Nat.finite_of_card_ne_zero ?_
+  rw [kw_fdn2_qephod_hend7_pmopKerCard_proved K E E' ι hι hfin]
+  exact (kw_fdn2_qephod_hend10_finrankAlong_pos ι hfin).ne'
+
+end Fintype
+
+section Squeeze
+
+variable {K : Type u} [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable {E E' : Affine K} [E.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E] [WeierstrassCurve.Affine.AbelTheorem E]
+    [E'.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E']
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E']
+    [WeierstrassCurve.Affine.AbelTheorem E']
+variable (ι : E'.FunctionField →ₐ[K] E.FunctionField)
+variable (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong K ι)
+
+local notation "kerPMOP" =>
+  AddMonoidHom.ker (pointMapOfPushforward ι hι hfin (normFormulaAlong_of_elliptic ι hfin))
+
+end Squeeze
+end ModularCurve
+end
+end
+
+
+section
+
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve.Affine \
+  P2MW.S_OVERLONG_302e4807.ModularCurv\
+  e AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_302e4807.AlgebraicCu\
+  rve PeriodPair \
+  P2MW.S_OVERLONG_302e4807.PeriodPair \
+  Filter \
+  P2MW.S_OVERLONG_302e4807.Filter"
+p2m_open_scoped "PeriodPair \
+  P2MW.S_OVERLONG_302e4807.PeriodPair \
+  Topology \
+  P2MW.S_OVERLONG_302e4807.Topology"
+
+namespace ModularCurve
+
+def KwD5BetweenCurvesCocountableAffineHoloCoords : Prop :=
+  ∀ (L L' : PeriodPair)
+    [L.weierstrassCurve.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve]
+    (ι'' : L'.weierstrassCurve.toAffine.FunctionField →ₐ[ℂ]
+      L.weierstrassCurve.toAffine.FunctionField)
+    (hι'' : ι''.toRingHom.IsIntegral) (hfin'' : FiniteAlong ℂ ι''),
+    ∃ S : Set ℂ, S.Countable ∧
+    ∀ z₀ ∉ S, ∃ U ∈ nhds z₀, ∃ X Y : ℂ → ℂ,
+      DifferentiableOn ℂ X U ∧ DifferentiableOn ℂ Y U ∧
+      ∀ z ∈ U, Y z ≠ 0 ∧
+        ∃ h, (pointMapOfPushforward ι'' hι'' hfin''
+            (normFormulaAlong_of_elliptic ι'' hfin'')) (L.kw_toPointHom z)
+          = Point.some (X z) (Y z) h
+
+theorem kw_surgehgf4_hH2d_betweenCurvesCocountableHoloLift_of_affineHoloCoords
+    (hH2e : KwD5BetweenCurvesCocountableAffineHoloCoords) :
+    KwD5BetweenCurvesCocountableHoloLift := by
+  intro L L' _ _ _ _ _ _ _ _ ι'' hι'' hfin''
+  obtain ⟨S, hSc, hgen⟩ := hH2e L L' ι'' hι'' hfin''
+  refine ⟨S, hSc, fun z₀ hz₀ => ?_⟩
+  obtain ⟨U, hU, X, Y, hXd, hYd, hcoord⟩ := hgen z₀ hz₀
+  obtain ⟨U', hU'U, hU'open, hz₀U'⟩ := mem_nhds_iff.mp hU
+  obtain ⟨hYz₀, hnsz₀, hcoord₀⟩ := hcoord z₀ (hU'U hz₀U')
+  obtain ⟨w₀, hw₀⟩ := L'.kw_surjective_toPointHom (.some (X z₀) (Y z₀) hnsz₀)
+  have hw₀Λ : w₀ ∉ L'.lattice := by
+    intro hmem
+    have h0 : L'.kw_toPointHom w₀ = 0 := by
+      rw [← AddMonoidHom.mem_ker, L'.kw_ker_toPointHom]; exact hmem
+    exact Point.some_ne_zero _ (hw₀ ▸ h0)
+  have hPw₀ : ℘[L'] w₀ = X z₀ ∧ ℘'[L'] w₀ / 2 = Y z₀ := by
+    have h := hw₀
+    rwa [L'.kw_toPointHom_apply, L'.toPoint_of_notMem _ hw₀Λ, Point.some.injEq] at h
+  have hder : deriv ℘[L'] w₀ ≠ 0 := by
+    simp only [PeriodPair.deriv_weierstrassP]
+    exact fun h0 => hYz₀ (by rw [← hPw₀.2, h0, zero_div])
+  have hPa : AnalyticAt ℂ ℘[L'] w₀ := L'.analyticOnNhd_weierstrassP w₀ hw₀Λ
+  set ψ := hPa.hasStrictDerivAt.localInverse ℘[L'] (deriv ℘[L'] w₀) w₀ hder with hψdef
+  have hψa : AnalyticAt ℂ ψ (X z₀) := hPw₀.1 ▸ hPa.analyticAt_localInverse hder
+  have hψw₀ : ψ (X z₀) = w₀ :=
+    hPw₀.1 ▸ HasStrictFDerivAt.localInverse_apply_image _
+  set G := ψ ∘ X with hGdef
+  have hXcont : ContinuousAt X z₀ := (hXd.differentiableAt hU).continuousAt
+  have hGcont : ContinuousAt G z₀ := hψa.continuousAt.comp hXcont
+  have hGz₀ : G z₀ = w₀ := hψw₀
+  have hevΛ : ∀ᶠ z in 𝓝 z₀, G z ∉ L'.lattice :=
+    hGcont.eventually (L'.isClosed_lattice.isOpen_compl.mem_nhds (hGz₀ ▸ hw₀Λ))
+  have hevR : ∀ᶠ z in 𝓝 z₀, ℘[L'] (G z) = X z := by
+    have h := hPw₀.1 ▸ hPa.hasStrictDerivAt.eventually_right_inverse hder
+    exact hXcont.eventually h
+  have hevψd : ∀ᶠ z in 𝓝 z₀, DifferentiableAt ℂ ψ (X z) :=
+    hXcont.eventually
+      ((AnalyticAt.eventually_analyticAt hψa).mono fun _ hy => hy.differentiableAt)
+  have hevXd : ∀ᶠ z in 𝓝 z₀, DifferentiableAt ℂ X z :=
+    eventually_of_mem (hU'open.mem_nhds hz₀U') fun z hz =>
+      (hXd.mono hU'U).differentiableAt (hU'open.mem_nhds hz)
+  have hevU : ∀ᶠ z in 𝓝 z₀, z ∈ U :=
+    eventually_of_mem (hU'open.mem_nhds hz₀U') hU'U
+  have hevSgn : ∀ᶠ z in 𝓝 z₀, ℘'[L'] (G z) / 2 + Y z ≠ 0 := by
+    have hP'cont : ContinuousAt ℘'[L'] (G z₀) := by
+      rw [hGz₀]; exact (L'.analyticOnNhd_derivWeierstrassP w₀ hw₀Λ).continuousAt
+    have hcont : ContinuousAt (fun z => ℘'[L'] (G z) / 2 + Y z) z₀ :=
+      ((hP'cont.comp hGcont).div_const 2).add (hYd.differentiableAt hU).continuousAt
+    refine hcont.eventually (isOpen_ne.mem_nhds ?_)
+    change ℘'[L'] (G z₀) / 2 + Y z₀ ≠ 0
+    rw [hGz₀, hPw₀.2, ← two_mul]; exact mul_ne_zero two_ne_zero hYz₀
+  obtain ⟨V, hVmem, hVopen, hVz₀⟩ := eventually_nhds_iff.mp
+    (((((hevΛ.and hevR).and hevψd).and hevXd).and hevU).and hevSgn)
+  refine ⟨V, hVopen.mem_nhds hVz₀, G, ?_, fun z hz => ?_⟩
+  · exact fun z hz =>
+      ((hVmem z hz).1.1.1.2.comp z (hVmem z hz).1.1.2).differentiableWithinAt
+  · obtain ⟨⟨⟨⟨⟨hGzΛ, hPGz⟩, -⟩, -⟩, hzU⟩, hsgn⟩ := hVmem z hz
+    obtain ⟨hYz, hnsz, hcoordz⟩ := hcoord z hzU
+    have hPGy : ℘'[L'] (G z) / 2 = Y z := by
+      have h1 : (℘'[L'] (G z) / 2) ^ 2 = Y z ^ 2 := by
+        have hG := (WeierstrassCurve.Affine.equation_iff _ _).mp
+          (hPGz ▸ L'.equation_weierstrassP hGzΛ)
+        have hY := (WeierstrassCurve.Affine.equation_iff _ _).mp hnsz.1
+        simp only [L'.weierstrassCurve_a₁, L'.weierstrassCurve_a₂, L'.weierstrassCurve_a₃,
+          zero_mul, add_zero] at hG hY
+        exact hG.trans hY.symm
+      have hfac : (℘'[L'] (G z) / 2 - Y z) * (℘'[L'] (G z) / 2 + Y z) = 0 := by
+        linear_combination h1
+      rcases mul_eq_zero.mp hfac with h | h
+      · exact sub_eq_zero.mp h
+      · exact absurd h hsgn
+    rw [L'.kw_toPointHom_apply, L'.toPoint_of_notMem _ hGzΛ, hcoordz, Point.some.injEq]
+    exact ⟨hPGz, hPGy⟩
+
+theorem kw_surgehgf4_hH2_betweenCurvesHoloLift_of_affineHoloCoords
+    (hH2e : KwD5BetweenCurvesCocountableAffineHoloCoords) :
+    KwD5BetweenCurvesHoloLift :=
+  kw_surgehgf4_hH2_betweenCurvesHoloLift_of_cocountable
+    (kw_surgehgf4_hH2d_betweenCurvesCocountableHoloLift_of_affineHoloCoords hH2e)
+
+end ModularCurve
+end
+
+
+section
+
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve.Affine \
+  P2MW.S_OVERLONG_302e4807.ModularCurv\
+  e AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_302e4807.AlgebraicCu\
+  rve PeriodPair \
+  P2MW.S_OVERLONG_302e4807.PeriodPair \
+  Filter \
+  P2MW.S_OVERLONG_302e4807.Filter"
+p2m_open_scoped "PeriodPair \
+  P2MW.S_OVERLONG_302e4807.PeriodPair \
+  Topology \
+  P2MW.S_OVERLONG_302e4807.Topology"
+
+namespace ModularCurve
+
+def KwD5BetweenCurvesCocountableAffineHoloCoordsWeak : Prop :=
+  ∀ (L L' : PeriodPair)
+    [L.weierstrassCurve.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve]
+    (ι'' : L'.weierstrassCurve.toAffine.FunctionField →ₐ[ℂ]
+      L.weierstrassCurve.toAffine.FunctionField)
+    (hι'' : ι''.toRingHom.IsIntegral) (hfin'' : FiniteAlong ℂ ι''),
+    ∃ S : Set ℂ, S.Countable ∧
+    ∀ z₀ ∉ S, ∃ U ∈ nhds z₀, ∃ X Y : ℂ → ℂ,
+      DifferentiableOn ℂ X U ∧ DifferentiableOn ℂ Y U ∧
+      ∀ z ∈ U, ∃ h, (pointMapOfPushforward ι'' hι'' hfin''
+            (normFormulaAlong_of_elliptic ι'' hfin'')) (L.kw_toPointHom z)
+          = Point.some (X z) (Y z) h
+
+theorem kw_surgehgf4_hH2e_betweenCurvesCocountableAffineHoloCoords_of_weak
+    (hH2f : KwD5BetweenCurvesCocountableAffineHoloCoordsWeak) :
+    KwD5BetweenCurvesCocountableAffineHoloCoords := by
+  intro L L' _ _ _ _ _ _ _ _ ι'' hι'' hfin''
+  obtain ⟨S, hSc, hgen⟩ := hH2f L L' ι'' hι'' hfin''
+  set K : Set L.weierstrassCurve.toAffine.Point :=
+    {P | (pointMapOfPushforward ι'' hι'' hfin''
+      (normFormulaAlong_of_elliptic ι'' hfin'')) P = 0} with hKdef
+  have hKfin : K.Finite := by
+    have hfin := kw_fdn2_qephod_hend10_kerPMOP_finite
+      (K := ℂ) (E := L.weierstrassCurve.toAffine) (E' := L'.weierstrassCurve.toAffine)
+      ι'' hι'' hfin''
+    have heq : K = ((AddMonoidHom.ker (pointMapOfPushforward ι'' hι'' hfin''
+        (normFormulaAlong_of_elliptic ι'' hfin''))) : Set _) := by
+      ext P; simp only [hKdef, Set.mem_ofPred_eq, SetLike.mem_coe, AddMonoidHom.mem_ker]
+    rw [heq]; exact Set.finite_coe_iff.mp hfin
+  set S' : Set ℂ := (fun z => (2 : ℂ) * z) ⁻¹' (L.kw_toPointHom ⁻¹' K)
+  have hS'c : S'.Countable :=
+    (L.kw_countable_toPointHom_preimage hKfin).preimage
+      (mul_right_injective₀ two_ne_zero)
+  refine ⟨S ∪ S', hSc.union hS'c, fun z₀ hz₀ => ?_⟩
+  have hz₀S : z₀ ∉ S := fun h => hz₀ (Or.inl h)
+  have hz₀S' : z₀ ∉ S' := fun h => hz₀ (Or.inr h)
+  obtain ⟨U, hU, X, Y, hXd, hYd, hcoord⟩ := hgen z₀ hz₀S
+  obtain ⟨hns₀, hcoord₀⟩ := hcoord z₀ (mem_of_mem_nhds hU)
+  have hYz₀ : Y z₀ ≠ 0 := by
+    intro hY0
+    apply hz₀S'
+    change (pointMapOfPushforward ι'' hι'' hfin'' (normFormulaAlong_of_elliptic ι'' hfin''))
+      (L.kw_toPointHom (2 * z₀)) = 0
+    rw [two_mul, map_add, map_add, hcoord₀, add_eq_zero_iff_eq_neg, Point.neg_some,
+      Point.some.injEq]
+    refine ⟨rfl, ?_⟩
+    rw [hY0]
+    simp only [negY, L'.weierstrassCurve_a₁, L'.weierstrassCurve_a₃,
+      zero_mul, _root_.neg_zero, sub_zero]
+  set V := U ∩ {z | Y z ≠ 0}
+  have hVnhds : V ∈ nhds z₀ :=
+    Filter.inter_mem hU ((hYd.continuousOn.continuousAt hU).preimage_mem_nhds
+      (isOpen_ne.mem_nhds hYz₀))
+  refine ⟨V, hVnhds, X, Y, hXd.mono Set.inter_subset_left,
+    hYd.mono Set.inter_subset_left, fun z hz => ?_⟩
+  obtain ⟨hns, hc⟩ := hcoord z hz.1
+  exact ⟨hz.2, hns, hc⟩
+
+theorem kw_surgehgf4_hH2_betweenCurvesHoloLift_of_affineHoloCoordsWeak
+    (hH2f : KwD5BetweenCurvesCocountableAffineHoloCoordsWeak) :
+    KwD5BetweenCurvesHoloLift :=
+  kw_surgehgf4_hH2_betweenCurvesHoloLift_of_affineHoloCoords
+    (kw_surgehgf4_hH2e_betweenCurvesCocountableAffineHoloCoords_of_weak hH2f)
+
+end ModularCurve
+end
+
+
+section
+
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_302e4807.Weierstrass\
+  Curve.Affine \
+  P2MW.S_OVERLONG_302e4807.ModularCurv\
+  e AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_302e4807.AlgebraicCu\
+  rve PeriodPair \
+  P2MW.S_OVERLONG_302e4807.PeriodPair \
+  Filter \
+  P2MW.S_OVERLONG_302e4807.Filter \
+  Polynomial \
+  P2MW.S_OVERLONG_302e4807.Polynomial"
+
+p2m_open_scoped "PeriodPair \
+  P2MW.S_OVERLONG_302e4807.PeriodPair \
+  Topology \
+  P2MW.S_OVERLONG_302e4807.Topology \
+  Polynomial.Bivariate \
+  P2MW.S_OVERLONG_302e4807.Polynomial.\
+  Bivariate"
+
+namespace ModularCurve
+
+section GeomMorphBCAtoms
+
+universe u
+
+variable {K : Type u} [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable {E E' : Affine K} [E.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E] [WeierstrassCurve.Affine.AbelTheorem E]
+    [E'.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E']
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E']
+    [WeierstrassCurve.Affine.AbelTheorem E']
+variable (ι : E'.FunctionField →ₐ[K] E.FunctionField)
+variable (hι : ι.toRingHom.IsIntegral)
+
+local notation "gBC" => kw_fdn2_qephod_hend7_geomMorphBC ι hι
+
+omit [WeierstrassCurve.IsElliptic E] [GenusOnePlaceGate.IsCentred E] [E.AbelTheorem] in
+omit [DecidableEq K] [CharZero K] [E'.AbelTheorem] in
+theorem kw_surgehgf4_hH2f_geomMorphBC_ne_zero (Q : E.Point)
+    (hx : ι (polyToFunctionField E' X) ∈ (placeOfPoint Q).toValuationSubring) :
+    gBC Q ≠ 0 := by
+  intro hcon
+  have hseam := kw_fdn2_qephod_hend7_placeOfPoint_geomMorphBC ι hι Q
+  rw [hcon, Point.zero_def, placeOfPoint_zero] at hseam
+  have hxmem : polyToFunctionField E' X
+      ∈ ((placeOfPoint Q).restrictAlong ι hι).toValuationSubring :=
+    (Place.mem_restrictAlong_iff ι hι (placeOfPoint Q)
+      (polyToFunctionField E' X)).mpr hx
+  rw [hseam] at hxmem
+  exact InfinitePlace.not_isFinitePlace (isFinitePlace_of_mem _ hxmem)
+
+open ModularCurve.Mmr73 in
+omit [WeierstrassCurve.IsElliptic E] [GenusOnePlaceGate.IsCentred E] [E.AbelTheorem] in
+omit [DecidableEq K] [CharZero K] [E'.AbelTheorem] in
+theorem kw_surgehgf4_hH2f_geomMorphBC_some_coords (Q : E.Point)
+    {a b : K} {hab : E'.Nonsingular a b}
+    (hQ : gBC Q = Point.some a b hab)
+    (hx : ι (polyToFunctionField E' X) ∈ (placeOfPoint Q).toValuationSubring)
+    (hy : ι (yGen E') ∈ (placeOfPoint Q).toValuationSubring) :
+    (placeOfPoint Q).evalAt (ι (polyToFunctionField E' X)) = a
+      ∧ (placeOfPoint Q).evalAt (ι (yGen E')) = b := by
+  have hrat : (placeOfPoint Q).IsRational :=
+    (placeOfPoint Q).isRational_of_deg_eq_one (deg_placeOfPoint Q)
+  have hseam := kw_fdn2_qephod_hend7_placeOfPoint_geomMorphBC ι hι Q
+  rw [hQ, placeOfPoint_some] at hseam
+  have hXsub_eq : polyToFunctionField E' X - algebraMap K E'.FunctionField a
+      = algebraMap E'.CoordinateRing E'.FunctionField
+          (CoordinateRing.mk E' (C (X - C a))) := by
+    rw [← polyToFunctionField_C (W := E') a, ← map_sub, polyToFunctionField_apply,
+      algebraMap_polynomial_eq_mk_C]
+  have hXmk_ne : CoordinateRing.mk E' (C (X - C a)) ≠ 0 := by
+    intro hcon
+    apply polyToFunctionField_ne_zero (W := E') (Polynomial.X_sub_C_ne_zero a)
+    rw [polyToFunctionField_apply, algebraMap_polynomial_eq_mk_C, hcon, _root_.map_zero]
+  have hposX : 0 < (placeOfEquation hab.left).ord
+      (polyToFunctionField E' X - algebraMap K E'.FunctionField a) := by
+    rw [hXsub_eq, ord_placeOfEquation_pos_iff hab.left hXmk_ne,
+      mk_mem_XYIdeal_iff hab.left]
+    simp [Polynomial.evalEval]
+  have hposwX : 0 < (placeOfPoint Q).ord
+      (ι (polyToFunctionField E' X) - algebraMap K E.FunctionField a) := by
+    have hmap : ι (polyToFunctionField E' X) - algebraMap K E.FunctionField a
+        = ι (polyToFunctionField E' X - algebraMap K E'.FunctionField a) := by
+      rw [map_sub, AlgHom.commutes]
+    rw [hmap, Place.ord_restrictAlong ι hι (placeOfPoint Q), hseam]
+    exact mul_pos
+      (by exact_mod_cast Place.ramificationIndexAlong_pos ι hι (placeOfPoint Q))
+      hposX
+  have hYsub_eq : yGen E' - algebraMap K E'.FunctionField b
+      = algebraMap E'.CoordinateRing E'.FunctionField
+          (CoordinateRing.mk E' (Y - C (C b))) := by
+    have h2 : algebraMap K E'.FunctionField b
+        = algebraMap E'.CoordinateRing E'.FunctionField
+            (CoordinateRing.mk E' (C (C b))) := by
+      rw [← polyToFunctionField_C (W := E') b, polyToFunctionField_apply,
+        algebraMap_polynomial_eq_mk_C]
+    unfold yGen
+    rw [h2, ← map_sub, ← map_sub]
+  have hYmk_ne : CoordinateRing.mk E' (Y - C (C b)) ≠ 0 := by
+    intro hcon
+    have hrep : CoordinateRing.mk E' (Y - C (C b))
+        = (-(C b) : K[X]) • (1 : E'.CoordinateRing)
+          + (1 : K[X]) • CoordinateRing.mk E' Y := by
+      rw [one_smul, Algebra.smul_def, mul_one, algebraMap_polynomial_eq_mk_C,
+        map_sub, _root_.map_neg, _root_.map_neg]
+      ring
+    rw [hrep] at hcon
+    exact one_ne_zero (CoordinateRing.smul_basis_eq_zero hcon).2
+  have hposY : 0 < (placeOfEquation hab.left).ord
+      (yGen E' - algebraMap K E'.FunctionField b) := by
+    rw [hYsub_eq, ord_placeOfEquation_pos_iff hab.left hYmk_ne,
+      mk_mem_XYIdeal_iff hab.left]
+    simp [Polynomial.evalEval]
+  have hposwY : 0 < (placeOfPoint Q).ord
+      (ι (yGen E') - algebraMap K E.FunctionField b) := by
+    have hmap : ι (yGen E') - algebraMap K E.FunctionField b
+        = ι (yGen E' - algebraMap K E'.FunctionField b) := by
+      rw [map_sub, AlgHom.commutes]
+    rw [hmap, Place.ord_restrictAlong ι hι (placeOfPoint Q), hseam]
+    exact mul_pos
+      (by exact_mod_cast Place.ramificationIndexAlong_pos ι hι (placeOfPoint Q))
+      hposY
+  exact ⟨mmr73_cs_evalAt_eq_of_ord_sub_pos (placeOfPoint Q) hrat hx hposwX,
+    mmr73_cs_evalAt_eq_of_ord_sub_pos (placeOfPoint Q) hrat hy hposwY⟩
+
+omit [WeierstrassCurve.IsElliptic E] [GenusOnePlaceGate.IsCentred E] [E.AbelTheorem] in
+omit [DecidableEq K] [IsAlgClosed K] [GenusOnePlaceGate.IsCentred E'] [E'.AbelTheorem] in
+theorem kw_surgehgf4_hH2f_finite_geomMorphBC_preimage (t : E'.Point) :
+    {P : E.Point | gBC P = t}.Finite := by
+  have hT : {w : AlgebraicCurve.Place K E.FunctionField |
+      w.restrictAlong ι hι = placeOfPoint t}.Finite := by
+    let := algebraAlong ι
+    have := isScalarTower_along ι
+    have := isIntegral_along ι hι
+    exact Place.restrict_fiber_finite (placeOfPoint t)
+  refine (Set.Finite.preimage (placeOfPoint_injective (W := E)).injOn hT).subset
+    fun P hP => ?_
+  exact (kw_fdn2_qephod_hend7_placeOfPoint_geomMorphBC ι hι P).trans
+    (congrArg placeOfPoint hP)
+
+end GeomMorphBCAtoms
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt\
+  " in
+open
+  _root_.P2MW.S_OVERLONG_302e4807.WeierstrassCurve.Affine.CoordinateRing
+  in
+theorem kw_surgehgf4_hH2f_betweenCurvesCocountableAffineHoloCoordsWeak :
+    KwD5BetweenCurvesCocountableAffineHoloCoordsWeak := by
+  intro L L' _ _ _ _ _ _ _ _ ι'' hι'' hfin''
+  let W := L.weierstrassCurve.toAffine
+  let W' := L'.weierstrassCurve.toAffine
+  set ξ := ι'' (polyToFunctionField W' X) with hξdef
+  set η := ι'' (yGen W') with hηdef
+  set c₀ := kw_fdn2_qephod_hend7_geomMorphBC ι'' hι'' 0 with hc₀def
+  obtain ⟨pξ, qξ, hqξ, hξeq⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) ξ
+  obtain ⟨pη, qη, hqη, hηeq⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) η
+  obtain ⟨pξ', rfl⟩ := AdjoinRoot.mk_surjective pξ
+  obtain ⟨qξ', rfl⟩ := AdjoinRoot.mk_surjective qξ
+  obtain ⟨pη', rfl⟩ := AdjoinRoot.mk_surjective pη
+  obtain ⟨qη', rfl⟩ := AdjoinRoot.mk_surjective qη
+  have hqξ0 : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W qξ') ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr (nonZeroDivisors.ne_zero hqξ)
+  have hqη0 : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W qη') ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr (nonZeroDivisors.ne_zero hqη)
+  set Tq : Set W.Point := placeOfPoint ⁻¹'
+    ({v | v.ord (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W qξ')) ≠ 0} ∪
+     {v | v.ord (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W qη')) ≠ 0})
+  have hfin_ord : ∀ {f : W.FunctionField}, f ≠ 0 →
+      {v : Place ℂ W.FunctionField | v.ord f ≠ 0}.Finite := by
+    intro f hf
+    obtain ⟨Df, hDf, -⟩ := HasPrincipalDivisors.exists_divisor (K := ℂ) f hf
+    exact Df.support.finite_toSet.subset fun v hv => Finsupp.mem_support_iff.mpr (hDf v ▸ hv)
+  have hTq_fin : Tq.Finite := Set.Finite.preimage placeOfPoint_injective.injOn
+    ((hfin_ord hqξ0).union (hfin_ord hqη0))
+  set Tc : Set W.Point := {P | kw_fdn2_qephod_hend7_geomMorphBC ι'' hι'' P = c₀}
+    ∪ {P | kw_fdn2_qephod_hend7_geomMorphBC ι'' hι'' P = -c₀}
+  have hTc_fin : Tc.Finite :=
+    (kw_surgehgf4_hH2f_finite_geomMorphBC_preimage ι'' hι'' c₀).union
+      (kw_surgehgf4_hH2f_finite_geomMorphBC_preimage ι'' hι'' (-c₀))
+  set S : Set ℂ := (L.lattice : Set ℂ) ∪ L.kw_toPointHom ⁻¹' (Tq ∪ Tc) with hSdef
+  have hSc : S.Countable := L.kw_countable_lattice.union
+    (L.kw_countable_toPointHom_preimage (hTq_fin.union hTc_fin))
+  refine ⟨S, hSc, fun z₀ hz₀ => ?_⟩
+  simp only [hSdef, Set.mem_union, Set.mem_preimage, not_or] at hz₀
+  obtain ⟨hz₀Λ, hz₀Tq, hz₀Tc⟩ := hz₀
+  set A : ℂ → ℂ := fun z =>
+    pξ'.evalEval (℘[L] z) (℘'[L] z / 2) / qξ'.evalEval (℘[L] z) (℘'[L] z / 2) with hAdef
+  set B : ℂ → ℂ := fun z =>
+    pη'.evalEval (℘[L] z) (℘'[L] z / 2) / qη'.evalEval (℘[L] z) (℘'[L] z / 2) with hBdef
+  set U₁ : Set ℂ :=
+    ((L.lattice : Set ℂ)ᶜ ∩ (fun z => qξ'.evalEval (℘[L] z) (℘'[L] z / 2)) ⁻¹' {0}ᶜ) ∩
+    ((L.lattice : Set ℂ)ᶜ ∩ (fun z => qη'.evalEval (℘[L] z) (℘'[L] z / 2)) ⁻¹' {0}ᶜ)
+    with hU₁def
+  have hU₁open : IsOpen U₁ :=
+    ((L.kw_differentiableOn_evalEval_wp qξ').continuousOn.isOpen_inter_preimage
+      L.isClosed_lattice.isOpen_compl isOpen_compl_singleton).inter
+    ((L.kw_differentiableOn_evalEval_wp qη').continuousOn.isOpen_inter_preimage
+      L.isClosed_lattice.isOpen_compl isOpen_compl_singleton)
+  have hU₁Λ : U₁ ⊆ (L.lattice : Set ℂ)ᶜ := fun z hz => hz.1.1
+  have hAd : DifferentiableOn ℂ A U₁ :=
+    ((L.kw_differentiableOn_evalEval_wp pξ').mono hU₁Λ).div
+      ((L.kw_differentiableOn_evalEval_wp qξ').mono hU₁Λ) fun z hz => hz.1.2
+  have hBd : DifferentiableOn ℂ B U₁ :=
+    ((L.kw_differentiableOn_evalEval_wp pη').mono hU₁Λ).div
+      ((L.kw_differentiableOn_evalEval_wp qη').mono hU₁Λ) fun z hz => hz.2.2
+  have hgeom : ∀ z ∈ U₁, ∃ hns : W'.Nonsingular (A z) (B z),
+      kw_fdn2_qephod_hend7_geomMorphBC ι'' hι'' (L.kw_toPointHom z)
+        = Point.some (A z) (B z) hns := by
+    intro z hz
+    have hzΛ : z ∉ L.lattice := hU₁Λ hz
+    have hqξz : qξ'.evalEval (℘[L] z) (℘'[L] z / 2) ≠ 0 := hz.1.2
+    have hqηz : qη'.evalEval (℘[L] z) (℘'[L] z / 2) ≠ 0 := hz.2.2
+    set hrs := L.equation_weierstrassP hzΛ with hrs_def
+    have hplace : placeOfPoint (W := W) (L.kw_toPointHom z) = placeOfEquation hrs := by
+      rw [L.kw_toPointHom_apply, L.toPoint_of_notMem _ hzΛ]; exact placeOfPoint_some _
+    have hordqξ : (placeOfEquation hrs).ord
+        (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W qξ')) = 0 := by
+      refine le_antisymm (not_lt.mp fun hlt => hqξz ?_) (ord_placeOfEquation_nonneg hrs _)
+      exact (mk_mem_XYIdeal_iff hrs qξ').mp
+        ((ord_placeOfEquation_pos_iff hrs (nonZeroDivisors.ne_zero hqξ)).mp hlt)
+    have hordqη : (placeOfEquation hrs).ord
+        (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W qη')) = 0 := by
+      refine le_antisymm (not_lt.mp fun hlt => hqηz ?_) (ord_placeOfEquation_nonneg hrs _)
+      exact (mk_mem_XYIdeal_iff hrs qη').mp
+        ((ord_placeOfEquation_pos_iff hrs (nonZeroDivisors.ne_zero hqη)).mp hlt)
+    have hιinj : Function.Injective ι'' := RingHom.injective ι''.toRingHom
+    have hξne : ξ ≠ 0 := fun h => polyToFunctionField_ne_zero (W := W') X_ne_zero
+      (hιinj (h.trans (_root_.map_zero _).symm))
+    have hyGen_ne : yGen W' ≠ 0 := by
+      have hmkY : (CoordinateRing.mk W' (Polynomial.X : Polynomial ℂ[X]) :
+          W'.CoordinateRing) ≠ 0 := fun h => one_ne_zero
+        (CoordinateRing.smul_basis_eq_zero
+        (show (0 : ℂ[X]) • (1 : W'.CoordinateRing) + (1 : ℂ[X]) • CoordinateRing.mk W' _ = 0 by
+          rw [zero_smul, one_smul, zero_add]; exact h)).2
+      exact (map_ne_zero_iff _ (IsFractionRing.injective W'.CoordinateRing W'.FunctionField)).mpr
+        hmkY
+    have hηne : η ≠ 0 := fun h => hyGen_ne (hιinj (h.trans (_root_.map_zero _).symm))
+    have hpξ0 : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W pξ') ≠ 0 :=
+      fun h => hξne (hξeq ▸ by rw [h, zero_div])
+    have hpη0 : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W pη') ≠ 0 :=
+      fun h => hηne (hηeq ▸ by rw [h, zero_div])
+    have hξmem : ξ ∈ (placeOfEquation hrs).toValuationSubring := by
+      refine AlgebraicCurve.Place.mem_of_ord_nonneg (placeOfEquation hrs) hξne ?_
+      rw [← hξeq, (placeOfEquation hrs).ord_div hpξ0 hqξ0, hordqξ, sub_zero]
+      exact ord_placeOfEquation_nonneg hrs _
+    have hηmem : η ∈ (placeOfEquation hrs).toValuationSubring := by
+      refine AlgebraicCurve.Place.mem_of_ord_nonneg (placeOfEquation hrs) hηne ?_
+      rw [← hηeq, (placeOfEquation hrs).ord_div hpη0 hqη0, hordqη, sub_zero]
+      exact ord_placeOfEquation_nonneg hrs _
+    have hgm_ne : kw_fdn2_qephod_hend7_geomMorphBC ι'' hι'' (L.kw_toPointHom z) ≠ 0 :=
+      kw_surgehgf4_hH2f_geomMorphBC_ne_zero ι'' hι'' _ (hplace ▸ hξmem)
+    obtain ⟨a, b, hab, hgm_eq⟩ : ∃ a b hab,
+        kw_fdn2_qephod_hend7_geomMorphBC ι'' hι'' (L.kw_toPointHom z)
+          = Point.some a b hab := by
+      rcases hP : kw_fdn2_qephod_hend7_geomMorphBC ι'' hι'' (L.kw_toPointHom z) with
+        _ | ⟨a, b, hab⟩
+      · exact absurd hP hgm_ne
+      · exact ⟨a, b, hab, rfl⟩
+    have hrat := isRational_placeOfEquation hrs
+    obtain ⟨ha, hb⟩ := kw_surgehgf4_hH2f_geomMorphBC_some_coords ι'' hι'' _ hgm_eq
+      (hplace ▸ hξmem) (hplace ▸ hηmem)
+    rw [hplace, ← hξdef] at ha
+    rw [hplace, ← hηdef] at hb
+    have hAz : A z = a := by
+      simp only [hAdef]
+      rw [← ha, ← hξeq, (placeOfEquation hrs).evalAt_div hrat
+          (isFinitePlace_placeOfEquation hrs _) hqξ0 hordqξ,
+        kw_evalAt_placeOfEquation_mk hrs pξ', kw_evalAt_placeOfEquation_mk hrs qξ']
+    have hBz : B z = b := by
+      simp only [hBdef]
+      rw [← hb, ← hηeq, (placeOfEquation hrs).evalAt_div hrat
+          (isFinitePlace_placeOfEquation hrs _) hqη0 hordqη,
+        kw_evalAt_placeOfEquation_mk hrs pη', kw_evalAt_placeOfEquation_mk hrs qη']
+    obtain ⟨rfl, rfl⟩ : a = A z ∧ b = B z := ⟨hAz.symm, hBz.symm⟩
+    exact ⟨hab, hgm_eq⟩
+  have hplace₀ : placeOfPoint (W := W) (L.kw_toPointHom z₀)
+      = placeOfEquation (L.equation_weierstrassP hz₀Λ) := by
+    rw [L.kw_toPointHom_apply, L.toPoint_of_notMem _ hz₀Λ]; exact placeOfPoint_some _
+  have hz₀Tq' := hz₀Tq; rw [show Tq = _ from rfl, Set.mem_preimage, Set.mem_union, not_or,
+    Set.mem_ofPred_eq, Set.mem_ofPred_eq, not_ne_iff, not_ne_iff, hplace₀] at hz₀Tq'
+  have hz₀U₁ : z₀ ∈ U₁ := by
+    refine ⟨⟨hz₀Λ, fun h => ?_⟩, hz₀Λ, fun h => ?_⟩
+    · exact (((ord_placeOfEquation_pos_iff (L.equation_weierstrassP hz₀Λ)
+        (nonZeroDivisors.ne_zero hqξ)).mpr
+        ((mk_mem_XYIdeal_iff (L.equation_weierstrassP hz₀Λ) qξ').mpr
+          (Set.mem_singleton_iff.mp h))).ne' hz₀Tq'.1).elim
+    · exact (((ord_placeOfEquation_pos_iff (L.equation_weierstrassP hz₀Λ)
+        (nonZeroDivisors.ne_zero hqη)).mpr
+        ((mk_mem_XYIdeal_iff (L.equation_weierstrassP hz₀Λ) qη').mpr
+          (Set.mem_singleton_iff.mp h))).ne' hz₀Tq'.2).elim
+  have hU₁nhds : U₁ ∈ nhds z₀ := hU₁open.mem_nhds hz₀U₁
+  rcases hc₀cases : c₀ with _ | ⟨x₀, y₀, h₀⟩
+  · refine ⟨U₁, hU₁nhds, A, B, hAd, hBd, fun z hz => ?_⟩
+    obtain ⟨hns, heq⟩ := hgeom z hz
+    refine ⟨hns, ?_⟩
+    rw [kw_fdn2_qephod_hend7_pmop_eq_geomMorphBC_sub ι'' hι'' hfin'', ← hc₀def, hc₀cases,
+      ← Point.zero_def, sub_zero, heq]
+  · set U : Set ℂ := U₁ ∩ A ⁻¹' {x₀}ᶜ with hUdef
+    have hUopen : IsOpen U := by
+      have h := hAd.continuousOn.isOpen_inter_preimage hU₁open
+        (isOpen_compl_singleton (x := x₀))
+      rw [show U = U₁ ∩ (U₁ ∩ A ⁻¹' {x₀}ᶜ) by rw [hUdef, ← Set.inter_assoc,
+        Set.inter_self]]
+      exact hU₁open.inter h
+    have hz₀U : z₀ ∈ U := by
+      refine ⟨hz₀U₁, fun hA0 => hz₀Tc ?_⟩
+      obtain ⟨hns₀, hgm₀⟩ := hgeom z₀ hz₀U₁
+      have hXeq := (Point.X_eq_iff (h₁ := hns₀) (h₂ := h₀)).mp (Set.mem_singleton_iff.mp hA0)
+      rw [← hgm₀, ← hc₀cases] at hXeq
+      exact hXeq.imp id id
+    set ℓ : ℂ → ℂ := fun z => W'.slope (A z) x₀ (B z) (W'.negY x₀ y₀) with hℓdef
+    set X' : ℂ → ℂ := fun z => W'.addX (A z) x₀ (ℓ z) with hX'def
+    set Y' : ℂ → ℂ := fun z => W'.addY (A z) x₀ (B z) (ℓ z) with hY'def
+    have hℓd : DifferentiableOn ℂ ℓ U :=
+      ((((hBd.mono Set.inter_subset_left).sub (differentiableOn_const _)).div
+        ((hAd.mono Set.inter_subset_left).sub (differentiableOn_const _))
+        fun z hz => sub_ne_zero.mpr hz.2) :
+          DifferentiableOn ℂ (fun z => (B z - W'.negY x₀ y₀) / (A z - x₀)) U).congr
+        fun z hz => slope_of_X_ne hz.2
+    have hX'd : DifferentiableOn ℂ X' U :=
+      ((((hℓd.pow 2).add ((differentiableOn_const W'.a₁).mul hℓd)).sub
+        (((differentiableOn_const W'.a₂).add (hAd.mono Set.inter_subset_left)).add
+          (differentiableOn_const x₀))) :
+          DifferentiableOn ℂ (fun z => ℓ z ^ 2 + W'.a₁ * ℓ z - (W'.a₂ + A z + x₀)) U).congr
+        fun z hz => by
+          simp only [hX'def, addX, Pi.add_apply, Pi.sub_apply, Pi.mul_apply, Pi.pow_apply]
+          ring
+    have hY'd : DifferentiableOn ℂ Y' U :=
+      ((((hℓd.mul (hX'd.sub (hAd.mono Set.inter_subset_left))).add
+        (hBd.mono Set.inter_subset_left)).neg.sub
+        ((differentiableOn_const W'.a₁).mul hX'd) |>.sub (differentiableOn_const W'.a₃)) :
+          DifferentiableOn ℂ
+            (fun z => -(ℓ z * (X' z - A z) + B z) - W'.a₁ * X' z - W'.a₃) U).congr
+        fun z hz => by
+          simp only [hY'def, hX'def, addY, negY, negAddY, Pi.add_apply, Pi.sub_apply,
+            Pi.mul_apply, Pi.neg_apply]
+    refine ⟨U, hUopen.mem_nhds hz₀U, X', Y', hX'd, hY'd, fun z hz => ?_⟩
+    obtain ⟨hns, heq⟩ := hgeom z hz.1
+    have hXne : A z ≠ x₀ := hz.2
+    have hpeq : pointMapOfPushforward ι'' hι'' hfin''
+          (normFormulaAlong_of_elliptic ι'' hfin'') (L.kw_toPointHom z)
+        = Point.some (A z) (B z) hns + Point.some x₀ (W'.negY x₀ y₀)
+            ((nonsingular_neg ..).mpr h₀) := by
+      rw [kw_fdn2_qephod_hend7_pmop_eq_geomMorphBC_sub ι'' hι'' hfin'', ← hc₀def,
+        hc₀cases, heq, sub_eq_add_neg, Point.neg_some]
+    rw [hpeq, Point.add_of_X_ne hXne]
+    exact ⟨_, rfl⟩
+
+theorem kw_surgehgf4_hH2f_betweenCurvesHoloLift :
+    KwD5BetweenCurvesHoloLift :=
+  kw_surgehgf4_hH2_betweenCurvesHoloLift_of_affineHoloCoordsWeak
+    kw_surgehgf4_hH2f_betweenCurvesCocountableAffineHoloCoordsWeak
+
+end ModularCurve
+end
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg\
+  " in
+open _root_.WeierstrassCurve
+  _root_.P2MW.S_OVERLONG_302e4807.WeierstrassCurve
+  _root_.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_302e4807.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_302e4807.AlgebraicCurve
+  in
+theorem solution
+    (L L' : PeriodPair) (hL : L.DiscriminantNeZero) (hL' : L'.DiscriminantNeZero)
+    [L.weierstrassCurve.IsElliptic] [L'.weierstrassCurve.IsElliptic]
+    [GenusOnePlaceGate L.weierstrassCurve.toAffine]
+    [GenusOnePlaceGate.IsCentred L.weierstrassCurve.toAffine]
+    [AbelTheorem L.weierstrassCurve.toAffine]
+    [GenusOnePlaceGate L'.weierstrassCurve.toAffine]
+    [GenusOnePlaceGate.IsCentred L'.weierstrassCurve.toAffine]
+    [AbelTheorem L'.weierstrassCurve.toAffine]
+    (ι : L'.weierstrassCurve.toAffine.FunctionField →ₐ[ℂ] L.weierstrassCurve.toAffine.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong ℂ ι) (hN : NormFormulaAlong ℂ ι hfin) :
+    ∃ F : ℂ → ℂ, Differentiable ℂ F ∧ F 0 ∈ L'.lattice ∧
+      ∀ z : ℂ, L'.toPoint hL' (F z) = pointMapOfPushforward ι hι hfin hN (L.toPoint hL z) := by
+  obtain ⟨F, hF, hF0, hFz⟩ := ModularCurve.kw_surgehgf4_hH2f_betweenCurvesHoloLift L L' ι hι hfin
+  refine ⟨F, hF, hF0, fun z => ?_⟩
+  have h := hFz z
+  rw [PeriodPair.kw_toPointHom_apply, PeriodPair.kw_toPointHom_apply] at h
+  exact h
+
+end
+end S_OVERLONG_302e4807
+end P2MW
+export P2MW.S_OVERLONG_302e4807
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+theorem PeriodPair.exists_differentiable_toPoint_comp_eq_pointMapOfPushforward_toPoint
+    (L L' : PeriodPair) (hL : L.DiscriminantNeZero) (hL' : L'.DiscriminantNeZero)
+    [L.weierstrassCurve.IsElliptic] [L'.weierstrassCurve.IsElliptic]
+    [GenusOnePlaceGate L.weierstrassCurve.toAffine]
+    [GenusOnePlaceGate.IsCentred L.weierstrassCurve.toAffine]
+    [AbelTheorem L.weierstrassCurve.toAffine]
+    [GenusOnePlaceGate L'.weierstrassCurve.toAffine]
+    [GenusOnePlaceGate.IsCentred L'.weierstrassCurve.toAffine]
+    [AbelTheorem L'.weierstrassCurve.toAffine]
+    (ι : L'.weierstrassCurve.toAffine.FunctionField →ₐ[ℂ] L.weierstrassCurve.toAffine.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong ℂ ι) (hN : NormFormulaAlong ℂ ι hfin) :
+    ∃ F : ℂ → ℂ, Differentiable ℂ F ∧ F 0 ∈ L'.lattice ∧
+      ∀ z : ℂ, L'.toPoint hL' (F z) = pointMapOfPushforward ι hι hfin hN (L.toPoint hL z) :=
+  solution L L' hL hL' ι hι hfin hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.lean
new file mode 100644
index 0000000000..f9eeeaf5d3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.lean
@@ -0,0 +1,846 @@
+/-
+Based on Prove2Me node PeriodPair.exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic
+(bebf56cf-67a5-5a93-a054-dbe2bcd6b4e4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d416c837-5c19-5b06-ba9c-f9084f214120
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_PrimCosetReps
+public import LeanPool.FLTEichlerShimura.Definitions.Def_PeriodPair_Uniformization
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Algebra.Quaternion
+import Mathlib.Data.Int.Star
+import Mathlib.GroupTheory.SpecificGroups.Cyclic
+import Mathlib.NumberTheory.ModularForms.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cyclic index-N sublattices come from primitive coset representatives
+
+Theorem statement: `PeriodPair.exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic`
+(`bebf56cf-67a5-5a93-a054-dbe2bcd6b4e4`), by Claude, 2026-09-05.
+
+Proof: submission `d416c837-5c19-5b06-ba9c-f9084f214120`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number and let $L$, $L'$ be period pairs, i.e. pairs of complex numbers
+independent over $\mathbb{R}$, each spanning a lattice in $\mathbb{C}$. Assume that the lattice of
+$L'$ is contained, as a subset of $\mathbb{C}$, in the lattice of $L$; that
+[`PeriodPair.sublatticeIndex L L'`](def/PeriodPair_Uniformization.html#L136), the index of the
+lattice of $L'$ viewed as a subgroup of the lattice of $L$, equals $N$; and that the corresponding
+quotient group [`PeriodPair.sublatticeQuotient L L'`](def/PeriodPair_Uniformization.html#L139) is
+additively cyclic. The conclusion asserts the existence of natural numbers $a$, $b$, $d$ and points
+$\tau$, $\sigma$ of the upper half-plane such that $(a,b,d)$ lies in [`ModularCurve.primCosetReps
+N`](def/ModularCurve_PrimCosetReps.html#L8), that is, $a$, $b$, $d$ are all at most $N$ and satisfy
+$ad = N$, $b < d$ and $\gcd(a,\gcd(b,d)) = 1$; such that $\sigma = (a\tau + b)/d$ as complex
+numbers; and such that the $j$-invariants match, $L$ with the period pair $(\tau, 1)$ and $L'$ with
+the period pair $(\sigma, 1)$. Here the $j$-invariant of a period pair is $1728\,g_2^3/(g_2^3 - 27
+g_3^2)$ formed from its weight-four and weight-six lattice invariants.
+
+This is the classical normalisation of a cyclic $N$-isogeny of complex tori: after a homothety,
+which leaves the $j$-invariant unchanged, a lattice and a cyclic sublattice of index $N$ become
+$\mathbb{Z}\tau + \mathbb{Z}$ and $\mathbb{Z}\sigma + \mathbb{Z}$ with $\sigma = (a\tau+b)/d$ for
+one of the primitive coset representatives of level $N$. It feeds the proof that the modular
+polynomial of level $N$ vanishes at the pair of $j$-invariants,
+[`ModularCurve.ModularPolynomialData.eval_jLattice_eq_zero_of_isAddCyclic`]
+(thm.html#ModularCurve.ModularPolynomialData.eval_jLattice_eq_zero_of_isAddCyclic).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic
+
+
+namespace ModularCurve
+p2m_export "ModularCurve" "primCosetReps mem_primCosetReps jq jqN ModularPolynomialData \
+  ModularPolynomialData.eval_eq_zero"
+end ModularCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine mk.injEq map mk reduction Δ j"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "map polynomial"
+end WeierstrassCurve.Affine
+
+
+noncomputable section
+
+p2m_open_scoped "PeriodPair \
+  P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.PeriodPair"
+
+namespace PeriodPair
+p2m_export "PeriodPair" "lattice ω₁ mk latticeEquivProd g₃ ω₂ indep latticeEquiv_symm_apply \
+  mk.injEq G g₂ DiscriminantNeZero jLattice ofTau ofTau_ω₁ ofTau_ω₂ scale_indep scale scale_ω₁ \
+  scale_ω₂ sublatticeIndex sublatticeQuotient"
+p2m_open "PeriodPair"
+
+variable (L : PeriodPair)
+
+section Scale
+
+variable (α : ℂˣ)
+
+private def mulLeftR (a : ℂ) : ℂ →ₗ[ℝ] ℂ := Algebra.lmul ℝ ℂ a
+
+private theorem mulLeftR_injective {a : ℂ} (ha : a ≠ 0) :
+    Function.Injective (mulLeftR a) := fun _ _ h => by
+  simpa using mul_left_cancel₀ ha h
+
+private def mulLeftZ (a : ℂ) : ℂ →ₗ[ℤ] ℂ := (mulLeftR a).restrictScalars ℤ
+
+@[scoped simp] private theorem mulLeftZ_apply (a z : ℂ) : mulLeftZ a z = a * z := rfl
+
+private theorem _root_.PeriodPair.scale_lattice :
+    (L.scale α).lattice = Submodule.map (mulLeftZ (α : ℂ)) L.lattice := by
+  unfold lattice scale
+  rw [Submodule.map_span]
+  congr 1
+  ext z
+  simp only [Set.mem_insert_iff, Set.mem_singleton_iff, Set.mem_image, mulLeftZ_apply]
+  constructor
+  · rintro (rfl | rfl)
+    · exact ⟨L.ω₁, Or.inl rfl, rfl⟩
+    · exact ⟨L.ω₂, Or.inr rfl, rfl⟩
+  · rintro ⟨w, hw | hw, rfl⟩ <;> simp [hw]
+
+p2m_export "PeriodPair" "scale_lattice"
+theorem mem_scale_lattice_iff {z : ℂ} :
+    z ∈ (L.scale α).lattice ↔ ∃ l ∈ L.lattice, z = (α : ℂ) * l := by
+  rw [scale_lattice, Submodule.mem_map]; simp only [mulLeftZ_apply]; tauto
+
+private def _root_.PeriodPair.scaleLatticeEquiv : L.lattice ≃ₗ[ℤ] (L.scale α).lattice :=
+  (Submodule.equivMapOfInjective (mulLeftZ (α : ℂ))
+    (fun _ _ h => mul_left_cancel₀ α.ne_zero (by simpa using h)) L.lattice).trans
+    (LinearEquiv.ofEq _ _ (L.scale_lattice α).symm)
+
+p2m_export "PeriodPair" "scaleLatticeEquiv"
+@[scoped simp] theorem scaleLatticeEquiv_apply (l : L.lattice) :
+    ((L.scaleLatticeEquiv α l : (L.scale α).lattice) : ℂ) = (α : ℂ) * (l : ℂ) := rfl
+
+end Scale
+
+section Homogeneity
+
+variable (α : ℂˣ)
+
+theorem G_scale (n : ℕ) : (L.scale α).G n = ((α : ℂ) ^ n)⁻¹ * L.G n := by
+  unfold G
+  rw [← (L.scaleLatticeEquiv α).toEquiv.tsum_eq]
+  simp only [LinearEquiv.coe_toEquiv, scaleLatticeEquiv_apply, mul_pow, mul_inv]
+  exact tsum_mul_left
+
+theorem g₂_scale : (L.scale α).g₂ = ((α : ℂ) ^ 4)⁻¹ * L.g₂ := by
+  unfold g₂; rw [G_scale]; ring
+
+theorem g₃_scale : (L.scale α).g₃ = ((α : ℂ) ^ 6)⁻¹ * L.g₃ := by
+  unfold g₃; rw [G_scale]; ring
+
+theorem discriminant_scale :
+    (L.scale α).g₂ ^ 3 - 27 * (L.scale α).g₃ ^ 2
+      = ((α : ℂ) ^ 12)⁻¹ * (L.g₂ ^ 3 - 27 * L.g₃ ^ 2) := by
+  rw [g₂_scale, g₃_scale]; ring
+
+theorem g₂_cubed_scale : (L.scale α).g₂ ^ 3 = ((α : ℂ) ^ 12)⁻¹ * L.g₂ ^ 3 := by
+  rw [g₂_scale, mul_pow, inv_pow, ← pow_mul]
+
+private theorem _root_.PeriodPair.jLattice_scale : (L.scale α).jLattice = L.jLattice := by
+  have hα : ((α : ℂ) ^ 12)⁻¹ ≠ 0 := inv_ne_zero (pow_ne_zero _ α.ne_zero)
+  unfold jLattice
+  rw [discriminant_scale, g₂_cubed_scale, mul_left_comm (1728 : ℂ), mul_div_mul_left _ _ hα]
+
+p2m_export "PeriodPair" "jLattice_scale"
+end Homogeneity
+
+section LatticeDependence
+
+variable {L L' : PeriodPair}
+
+private def latticeEquivOfEq (h : L.lattice = L'.lattice) : L.lattice ≃ L'.lattice where
+  toFun l := ⟨(l : ℂ), h ▸ l.2⟩
+  invFun l := ⟨(l : ℂ), h.symm ▸ l.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+
+theorem G_eq_of_lattice_eq (h : L.lattice = L'.lattice) (n : ℕ) : L.G n = L'.G n :=
+  (latticeEquivOfEq h).tsum_eq fun l => ((l : ℂ) ^ n)⁻¹
+
+theorem g₂_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.g₂ = L'.g₂ := by
+  unfold g₂; rw [G_eq_of_lattice_eq h]
+
+theorem g₃_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.g₃ = L'.g₃ := by
+  unfold g₃; rw [G_eq_of_lattice_eq h]
+
+theorem jLattice_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.jLattice = L'.jLattice := by
+  unfold jLattice; rw [g₂_eq_of_lattice_eq h, g₃_eq_of_lattice_eq h]
+
+end LatticeDependence
+
+end PeriodPair
+end
+
+
+noncomputable section
+
+open UpperHalfPlane Complex
+
+namespace PeriodPair
+p2m_export "PeriodPair" "lattice ω₁ mk latticeEquivProd g₃ ω₂ indep latticeEquiv_symm_apply \
+  mk.injEq G g₂ DiscriminantNeZero jLattice ofTau ofTau_ω₁ ofTau_ω₂ scale_indep scale scale_ω₁ \
+  scale_ω₂ sublatticeIndex sublatticeQuotient"
+p2m_open "PeriodPair"
+
+theorem kw_linearIndependent_tau_one (τ : ℍ) :
+    LinearIndependent ℝ ![(τ : ℂ), (1 : ℂ)] := by
+  rw [LinearIndependent.pair_iff]
+  intro a b h
+  have him : (a • (τ : ℂ) + b • (1 : ℂ)).im = 0 := by rw [h]; simp
+  simp only [Complex.add_im, Complex.smul_im, Complex.one_im, smul_zero,
+    add_zero] at him
+  have ha : a = 0 := by
+    rcases mul_eq_zero.mp him with ha | him0
+    · exact ha
+    · exact absurd him0 (ne_of_gt τ.im_pos)
+  subst ha
+  simp only [zero_smul, zero_add, smul_eq_zero, one_ne_zero, or_false] at h
+  exact ⟨rfl, h⟩
+
+theorem kw_ofTau_latticeEquivProd_symm_apply (τ : ℍ) (p : ℤ × ℤ) :
+    ((ofTau τ).latticeEquivProd.symm p : ℂ) = p.1 * (τ : ℂ) + p.2 := by
+  rw [latticeEquiv_symm_apply]; simp
+
+end PeriodPair
+end
+
+
+noncomputable section
+
+open scoped UpperHalfPlane Real
+open Complex UpperHalfPlane ModularForm
+
+namespace PeriodPair
+p2m_export "PeriodPair" "lattice ω₁ mk latticeEquivProd g₃ ω₂ indep latticeEquiv_symm_apply \
+  mk.injEq G g₂ DiscriminantNeZero jLattice ofTau ofTau_ω₁ ofTau_ω₂ scale_indep scale scale_ω₁ \
+  scale_ω₂ sublatticeIndex sublatticeQuotient"
+p2m_open "PeriodPair"
+
+theorem kw_im_div_ne_zero (L : PeriodPair) : (L.ω₁ / L.ω₂).im ≠ 0 := by
+  have hω₂ : L.ω₂ ≠ 0 := by
+    have := L.indep.ne_zero 1; simpa using this
+  intro him
+  have hdiv : (L.ω₁ / L.ω₂ : ℂ) = ((L.ω₁ / L.ω₂).re : ℂ) :=
+    Complex.ext (by simp) (by simp [him])
+  have hreal : L.ω₁ = ((L.ω₁ / L.ω₂).re : ℂ) * L.ω₂ := by
+    rw [← hdiv, div_mul_cancel₀ _ hω₂]
+  have key : (1 : ℝ) • L.ω₁ + (-(L.ω₁ / L.ω₂).re) • L.ω₂ = 0 := by
+    rw [one_smul, _root_.neg_smul, Complex.real_smul, ← hreal, add_neg_cancel]
+  exact one_ne_zero (LinearIndependent.pair_iff.mp L.indep 1 (-(L.ω₁ / L.ω₂).re) key).1
+
+theorem kw_span_neg_fst (a b : ℂ) :
+    Submodule.span ℤ ({-a, b} : Set ℂ) = Submodule.span ℤ ({a, b} : Set ℂ) := by
+  have hna : (-a : ℂ) ∈ Submodule.span ℤ ({a, b} : Set ℂ) :=
+    neg_mem (Submodule.subset_span (Set.mem_insert _ _))
+  have ha : (a : ℂ) ∈ Submodule.span ℤ ({-a, b} : Set ℂ) := by
+    have hneg : (-(-a) : ℂ) ∈ Submodule.span ℤ ({-a, b} : Set ℂ) :=
+      neg_mem (Submodule.subset_span (Set.mem_insert _ _))
+    simpa using hneg
+  apply le_antisymm <;> rw [Submodule.span_le, Set.insert_subset_iff] <;>
+    exact ⟨by assumption,
+      Set.singleton_subset_iff.mpr (Submodule.subset_span (Set.mem_insert_of_mem _ rfl))⟩
+
+end PeriodPair
+end
+
+section
+
+namespace QuaternionAlgebra
+p2m_export "QuaternionAlgebra" "re smul_mk mk_sub_mk mk.injEq mk_add_mk im mk"
+p2m_open "QuaternionAlgebra"
+
+open AddSubgroup AddMonoidHom
+
+section NatGen
+
+noncomputable def natGen (K : AddSubgroup ℤ) : ℕ :=
+  ((K.isAddCyclic_iff_exists_zmultiples_eq_top).mp (AddSubgroup.isAddCyclic K)).choose.natAbs
+
+theorem zmultiples_natAbs (a : ℤ) :
+    AddSubgroup.zmultiples ((a.natAbs : ℕ) : ℤ) = AddSubgroup.zmultiples a := by
+  ext x
+  rw [Int.mem_zmultiples_iff, Int.mem_zmultiples_iff, Int.natAbs_dvd]
+
+theorem zmultiples_natGen (K : AddSubgroup ℤ) :
+    AddSubgroup.zmultiples ((natGen K : ℕ) : ℤ) = K := by
+  have h := ((K.isAddCyclic_iff_exists_zmultiples_eq_top).mp
+    (AddSubgroup.isAddCyclic K)).choose_spec
+  rw [natGen, zmultiples_natAbs]
+  exact h
+
+theorem natGen_cast_mem (K : AddSubgroup ℤ) : ((natGen K : ℕ) : ℤ) ∈ K := by
+  have h : ((natGen K : ℕ) : ℤ) ∈ AddSubgroup.zmultiples ((natGen K : ℕ) : ℤ) :=
+    AddSubgroup.mem_zmultiples _
+  rwa [zmultiples_natGen K] at h
+
+theorem index_eq_natGen (K : AddSubgroup ℤ) : K.index = natGen K := by
+  conv_lhs => rw [← zmultiples_natGen K]
+  rw [Int.index_zmultiples, Int.natAbs_natCast]
+
+theorem dvd_of_mem_natGen {K : AddSubgroup ℤ} {y : ℤ} (hy : y ∈ K) :
+    ((natGen K : ℕ) : ℤ) ∣ y := by
+  rw [← zmultiples_natGen K, Int.mem_zmultiples_iff] at hy
+  exact hy
+
+end NatGen
+
+section LatticeOf
+
+def latticeOf (a d : ℕ) (b : ℤ) : AddSubgroup (ℤ × ℤ) :=
+  AddSubgroup.closure {(((a : ℕ) : ℤ), b), ((0 : ℤ), ((d : ℕ) : ℤ))}
+
+theorem mem_latticeOf_iff {a d : ℕ} {b : ℤ} {z : ℤ × ℤ} :
+    z ∈ latticeOf a d b ↔
+      ∃ m n : ℤ, z = (m * (a : ℤ), m * b + n * (d : ℤ)) := by
+  rw [latticeOf, AddSubgroup.mem_closure_pair]
+  constructor
+  · rintro ⟨m, n, hmn⟩
+    exact ⟨m, n, by
+      rw [← hmn]
+      simp only [Prod.smul_mk, smul_eq_mul, Prod.mk_add_mk, mul_zero, add_zero]⟩
+  · rintro ⟨m, n, hz⟩
+    exact ⟨m, n, by
+      rw [hz]
+      simp only [Prod.smul_mk, smul_eq_mul, Prod.mk_add_mk, mul_zero, add_zero]⟩
+
+end LatticeOf
+
+section ProductIndex
+
+variable {A B : Type*} [AddCommGroup A] [AddCommGroup B]
+
+theorem ker_fst_eq_range_inr : (fst A B).ker = (inr A B).range := by
+  ext ⟨x, y⟩
+  simp [AddSubgroup.mem_prod, eq_comm]
+
+theorem index_eq_comap_inr_mul_map_fst (H : AddSubgroup (A × B)) :
+    H.index = (H.comap (inr A B)).index * (H.map (fst A B)).index := by
+  have hsurj : Function.Surjective (fst A B) := fun x => ⟨(x, 0), rfl⟩
+  have h1 : (H.map (fst A B)).index = (H ⊔ (fst A B).ker).index := by
+    rw [AddSubgroup.index_map, AddMonoidHom.range_eq_top.mpr hsurj, AddSubgroup.index_top,
+      mul_one]
+  have h2 : H.relIndex (H ⊔ (fst A B).ker) * (H ⊔ (fst A B).ker).index = H.index :=
+    AddSubgroup.relIndex_mul_index le_sup_left
+  have h3 : H.relIndex (H ⊔ (fst A B).ker) = H.relIndex (fst A B).ker :=
+    AddSubgroup.relIndex_sup_left (fst A B).ker H
+  have h4 : (H.comap (inr A B)).index = H.relIndex (inr A B).range := by
+    rw [← AddSubgroup.relIndex_top_right, AddSubgroup.relIndex_comap,
+      ← AddMonoidHom.range_eq_map]
+  rw [h4, ← ker_fst_eq_range_inr, ← h3, h1]
+  exact h2.symm
+
+end ProductIndex
+
+
+section StructureTheorem
+
+variable (H : AddSubgroup (ℤ × ℤ))
+
+noncomputable def aOf : ℕ := natGen (H.map (fst ℤ ℤ))
+
+noncomputable def dOf : ℕ := natGen (H.comap (inr ℤ ℤ))
+
+theorem index_eq_dOf_mul_aOf : H.index = dOf H * aOf H := by
+  rw [index_eq_comap_inr_mul_map_fst, index_eq_natGen, index_eq_natGen, aOf, dOf]
+
+theorem zero_dOf_mem : ((0 : ℤ), ((dOf H : ℕ) : ℤ)) ∈ H :=
+  natGen_cast_mem (H.comap (inr ℤ ℤ))
+
+theorem dOf_dvd_of_zero_mem {y : ℤ} (hy : ((0 : ℤ), y) ∈ H) : ((dOf H : ℕ) : ℤ) ∣ y :=
+  dvd_of_mem_natGen (K := H.comap (inr ℤ ℤ)) hy
+
+theorem exists_over_aOf : ∃ y : ℤ, (((aOf H : ℕ) : ℤ), y) ∈ H := by
+  obtain ⟨z, hz, hz1⟩ := AddSubgroup.mem_map.mp (natGen_cast_mem (H.map (fst ℤ ℤ)))
+  refine ⟨z.2, ?_⟩
+  have hzeq : (((aOf H : ℕ) : ℤ), z.2) = z := by
+    obtain ⟨z1, z2⟩ := z
+    simp only [Prod.mk.injEq, and_true]
+    exact hz1.symm
+  rwa [hzeq]
+
+noncomputable def bOf : ℤ := (exists_over_aOf H).choose % ((dOf H : ℕ) : ℤ)
+
+theorem aOf_bOf_mem : (((aOf H : ℕ) : ℤ), bOf H) ∈ H := by
+  have h0 := (exists_over_aOf H).choose_spec
+  set y0 := (exists_over_aOf H).choose with hy0
+  have hd : ((0 : ℤ), ((dOf H : ℕ) : ℤ) * (y0 / ((dOf H : ℕ) : ℤ))) ∈ H := by
+    have := H.zsmul_mem (zero_dOf_mem H) (y0 / ((dOf H : ℕ) : ℤ))
+    simpa [Prod.smul_mk, smul_eq_mul, mul_comm] using this
+  have hmem := H.sub_mem h0 hd
+  have heq : (((aOf H : ℕ) : ℤ), y0) - ((0 : ℤ), ((dOf H : ℕ) : ℤ) * (y0 / ((dOf H : ℕ) : ℤ)))
+      = (((aOf H : ℕ) : ℤ), bOf H) := by
+    rw [Prod.mk_sub_mk, sub_zero, bOf, ← hy0, Int.emod_def]
+  rwa [heq] at hmem
+
+theorem bOf_nonneg (hd : dOf H ≠ 0) : 0 ≤ bOf H :=
+  Int.emod_nonneg _ (by exact_mod_cast hd)
+
+theorem bOf_lt (hd : dOf H ≠ 0) : bOf H < ((dOf H : ℕ) : ℤ) :=
+  Int.emod_lt_of_pos _ (by omega)
+
+theorem latticeOf_canonical_eq : latticeOf (aOf H) (dOf H) (bOf H) = H := by
+  apply le_antisymm
+  · rw [latticeOf]
+    apply (AddSubgroup.closure_le H).mpr
+    rintro z (rfl | rfl)
+    · exact aOf_bOf_mem H
+    · exact zero_dOf_mem H
+  · rintro ⟨x, y⟩ hxy
+    rw [mem_latticeOf_iff]
+    have hx : ((aOf H : ℕ) : ℤ) ∣ x := by
+      have hmem : x ∈ H.map (fst ℤ ℤ) := ⟨(x, y), hxy, rfl⟩
+      exact dvd_of_mem_natGen (K := H.map (fst ℤ ℤ)) hmem
+    obtain ⟨m, rfl⟩ := hx
+    have hsub : (((aOf H : ℕ) : ℤ) * m, m * bOf H) ∈ H := by
+      have := H.zsmul_mem (aOf_bOf_mem H) m
+      simpa [Prod.smul_mk, smul_eq_mul, mul_comm] using this
+    have hfiber : ((0 : ℤ), y - m * bOf H) ∈ H := by
+      have := H.sub_mem hxy hsub
+      simpa using this
+    obtain ⟨n, hn⟩ := dOf_dvd_of_zero_mem H hfiber
+    refine ⟨m, n, ?_⟩
+    rw [Prod.mk.injEq]
+    constructor
+    · ring
+    · linear_combination hn
+
+end StructureTheorem
+end QuaternionAlgebra
+end
+
+
+noncomputable section
+
+p2m_open_scoped "PeriodPair \
+  P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.PeriodPair \
+  UpperHalfPlane"
+p2m_open "PeriodPair \
+  P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.PeriodPair Polynomial"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "primCosetReps mem_primCosetReps jq jqN ModularPolynomialData \
+  ModularPolynomialData.eval_eq_zero"
+p2m_open "ModularCurve"
+
+theorem kw_scale_lattice_toAddSubgroup (L : PeriodPair) (α : ℂˣ) :
+    (L.scale α).lattice.toAddSubgroup
+      = L.lattice.toAddSubgroup.map (AddMonoidHom.mulLeft (α : ℂ)) := by
+  ext z
+  simp only [Submodule.mem_toAddSubgroup, mem_scale_lattice_iff, AddSubgroup.mem_map,
+    AddMonoidHom.coe_mulLeft]
+  exact ⟨fun ⟨l, hl, hz⟩ => ⟨l, hl, hz.symm⟩, fun ⟨l, hl, hz⟩ => ⟨l, hl, hz.symm⟩⟩
+
+theorem kw_scale_lattice_subset (L L' : PeriodPair) (α : ℂˣ)
+    (h : (L'.lattice : Set ℂ) ⊆ L.lattice) :
+    ((L'.scale α).lattice : Set ℂ) ⊆ (L.scale α).lattice := by
+  intro z hz
+  rw [SetLike.mem_coe, mem_scale_lattice_iff] at hz ⊢
+  obtain ⟨l, hl, rfl⟩ := hz
+  exact ⟨l, h hl, rfl⟩
+
+theorem kwSublatticeIndex_scale (L L' : PeriodPair) (α : ℂˣ) :
+    PeriodPair.sublatticeIndex (L.scale α) (L'.scale α) = PeriodPair.sublatticeIndex L L' := by
+  have hinj : Function.Injective (AddMonoidHom.mulLeft (α : ℂ)) :=
+    fun _ _ h => mul_left_cancel₀ α.ne_zero h
+  change AddSubgroup.relIndex _ _ = AddSubgroup.relIndex _ _
+  rw [kw_scale_lattice_toAddSubgroup, kw_scale_lattice_toAddSubgroup,
+    AddSubgroup.relIndex_map_map_of_injective _ _ hinj]
+
+theorem kw_exists_scale_ofTau_lattice_eq (L : PeriodPair) :
+    ∃ (α : ℂˣ) (τ : ℍ), (L.scale α).lattice = (ofTau τ).lattice := by
+  have hω₂ : L.ω₂ ≠ 0 := by have := L.indep.ne_zero 1; simpa using this
+  set α : ℂˣ := (Units.mk0 L.ω₂ hω₂)⁻¹
+  have hα : (α : ℂ) = (L.ω₂)⁻¹ := by simp only [α, Units.val_inv_eq_inv_val, Units.val_mk0]
+  have hlat : (L.scale α).lattice = Submodule.span ℤ {L.ω₁ / L.ω₂, 1} := by
+    simp only [lattice, scale_ω₁, scale_ω₂, hα, div_eq_inv_mul, inv_mul_cancel₀ hω₂]
+  rcases lt_or_gt_of_ne (kw_im_div_ne_zero L) with hneg | hpos
+  · exact ⟨α, ⟨-(L.ω₁ / L.ω₂), by simp only [Complex.neg_im]; linarith⟩,
+      hlat.trans (kw_span_neg_fst _ _).symm⟩
+  · exact ⟨α, ⟨L.ω₁ / L.ω₂, hpos⟩, hlat⟩
+
+end ModularCurve
+end
+
+
+noncomputable section
+
+p2m_open_scoped "PeriodPair \
+  P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.PeriodPair \
+  UpperHalfPlane"
+p2m_open "PeriodPair \
+  P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.PeriodPair Polynomial \
+  QuaternionAlgebra \
+  P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.QuaternionAlgebra"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "primCosetReps mem_primCosetReps jq jqN ModularPolynomialData \
+  ModularPolynomialData.eval_eq_zero"
+p2m_open "ModularCurve"
+
+def kw_phiTau (τ : ℍ) : ℤ × ℤ →+ ℂ :=
+  ((ofTau τ).lattice.subtype.toAddMonoidHom).comp
+    (ofTau τ).latticeEquivProd.symm.toLinearMap.toAddMonoidHom
+
+theorem kw_phiTau_apply (τ : ℍ) (p : ℤ × ℤ) :
+    kw_phiTau τ p = (p.1 : ℂ) * (τ : ℂ) + (p.2 : ℂ) := by
+  change ((ofTau τ).latticeEquivProd.symm p : ℂ) = _
+  exact_mod_cast kw_ofTau_latticeEquivProd_symm_apply τ p
+
+theorem kw_phiTau_range (τ : ℍ) :
+    (kw_phiTau τ).range = (ofTau τ).lattice.toAddSubgroup := by
+  ext z
+  simp only [AddMonoidHom.mem_range, Submodule.mem_toAddSubgroup]
+  refine ⟨?_, fun hz => ⟨(ofTau τ).latticeEquivProd ⟨z, hz⟩, ?_⟩⟩
+  · rintro ⟨p, rfl⟩; exact ((ofTau τ).latticeEquivProd.symm p).2
+  · change ((ofTau τ).latticeEquivProd.symm ((ofTau τ).latticeEquivProd ⟨z, hz⟩) : ℂ) = z
+    rw [LinearEquiv.symm_apply_apply]
+
+def kw_HZZ (τ : ℍ) (L' : PeriodPair) : AddSubgroup (ℤ × ℤ) :=
+  L'.lattice.toAddSubgroup.comap (kw_phiTau τ)
+
+theorem kw_HZZ_index (τ : ℍ) (L' : PeriodPair) :
+    (kw_HZZ τ L').index = PeriodPair.sublatticeIndex (ofTau τ) L' := by
+  rw [kw_HZZ, AddSubgroup.index_comap, kw_phiTau_range]
+  rfl
+
+theorem kw_HZZ_map_eq (τ : ℍ) (L' : PeriodPair)
+    (hsub : (L'.lattice : Set ℂ) ⊆ (ofTau τ).lattice) :
+    (kw_HZZ τ L').map (kw_phiTau τ) = L'.lattice.toAddSubgroup := by
+  rw [kw_HZZ, AddSubgroup.map_comap_eq_self]
+  rw [kw_phiTau_range]
+  exact fun z hz => hsub hz
+
+theorem kw_sublattice_eq_span (τ : ℍ) (L' : PeriodPair)
+    (hsub : (L'.lattice : Set ℂ) ⊆ (ofTau τ).lattice) :
+    L'.lattice = Submodule.span ℤ
+      {(aOf (kw_HZZ τ L') : ℂ) * (τ : ℂ) + (bOf (kw_HZZ τ L') : ℂ),
+       (dOf (kw_HZZ τ L') : ℂ)} := by
+  apply Submodule.toAddSubgroup_injective
+  rw [Submodule.span_int_eq_addSubgroupClosure, ← kw_HZZ_map_eq τ L' hsub]
+  conv_lhs => rw [← latticeOf_canonical_eq (kw_HZZ τ L')]
+  rw [latticeOf, AddMonoidHom.map_closure, Set.image_pair,
+    kw_phiTau_apply, kw_phiTau_apply]
+  push_cast
+  ring_nf
+
+def kw_hnfPoint (τ : ℍ) (a : ℕ) (b : ℤ) (d : ℕ) (ha : 0 < a) (hd : 0 < d) : ℍ :=
+  ⟨((a : ℂ) * (τ : ℂ) + (b : ℂ)) / (d : ℂ), by
+    have him : ((a : ℂ) * (τ : ℂ) + (b : ℂ)).im = (a : ℝ) * τ.im := by simp
+    have haτ : (0 : ℝ) < (a : ℝ) * τ.im := mul_pos (by exact_mod_cast ha) τ.im_pos
+    have hdR : (0 : ℝ) < (d : ℝ) := by exact_mod_cast hd
+    simp only [Complex.div_im, him, Complex.natCast_im, mul_zero, zero_div, sub_zero,
+      Complex.natCast_re, Complex.normSq_natCast]
+    positivity⟩
+
+@[scoped simp] theorem kw_hnfPoint_coe (τ : ℍ) (a : ℕ) (b : ℤ) (d : ℕ) (ha : 0 < a) (hd : 0 < d) :
+    (kw_hnfPoint τ a b d ha hd : ℂ) = ((a : ℂ) * (τ : ℂ) + (b : ℂ)) / (d : ℂ) := rfl
+
+theorem kw_hnfPoint_scale_lattice (τ : ℍ) (a : ℕ) (b : ℤ) (d : ℕ)
+    (ha : 0 < a) (hd : 0 < d) :
+    ((ofTau (kw_hnfPoint τ a b d ha hd)).scale
+      (Units.mk0 (d : ℂ) (Nat.cast_ne_zero.mpr hd.ne'))).lattice
+      = Submodule.span ℤ {(a : ℂ) * (τ : ℂ) + (b : ℂ), (d : ℂ)} := by
+  have hd' : (d : ℂ) ≠ 0 := Nat.cast_ne_zero.mpr hd.ne'
+  simp only [lattice, scale_ω₁, scale_ω₂, ofTau_ω₁, ofTau_ω₂, Units.val_mk0,
+    kw_hnfPoint_coe, mul_div_cancel₀ _ hd', mul_one]
+
+end ModularCurve
+end
+
+section
+
+
+noncomputable section
+
+p2m_open_scoped "PeriodPair \
+  P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.PeriodPair \
+  UpperHalfPlane MatrixGroups \
+  P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.MatrixGroups"
+p2m_open "PeriodPair \
+  P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.PeriodPair Polynomial \
+  QuaternionAlgebra \
+  P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.QuaternionAlgebra \
+  ModularCurve \
+  P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.ModularCurve"
+p2m_open "P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.AlgebraicCurve \
+  WeierstrassCurve \
+  P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.WeierstrassCurve \
+  WeierstrassCurve.Affine \
+  P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.WeierstrassCurve.Affin\
+  e Matrix"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "primCosetReps mem_primCosetReps jq jqN ModularPolynomialData \
+  ModularPolynomialData.eval_eq_zero"
+p2m_open "ModularCurve"
+
+theorem kw_surgehgf4_hu5c_not_isAddCyclic_zmod_prod {p : ℕ} (hp : 1 < p) :
+    ¬ IsAddCyclic (ZMod p × ZMod p) := by
+  rintro ⟨⟨g, hg⟩⟩
+  have : NeZero p := ⟨by omega⟩
+  have hord : addOrderOf g ∣ p := by
+    rw [addOrderOf_dvd_iff_nsmul_eq_zero]
+    change ((p • g.1, p • g.2) : ZMod p × ZMod p) = 0
+    simp [nsmul_eq_mul]
+  have hcard : Nat.card (ZMod p × ZMod p) = p * p := by
+    simp only [Nat.card_prod, Nat.card_zmod]
+  have htop : AddSubgroup.zmultiples g = ⊤ := by
+    rw [AddSubgroup.eq_top_iff']
+    intro x; obtain ⟨k, hk⟩ := hg x
+    exact AddSubgroup.mem_zmultiples_iff.mpr ⟨k, hk⟩
+  have hspan : Nat.card (ZMod p × ZMod p) = addOrderOf g := by
+    rw [← Nat.card_zmultiples g, htop, AddSubgroup.card_top]
+  have : p * p ≤ p := hcard ▸ hspan ▸ Nat.le_of_dvd (by omega) hord
+  nlinarith
+
+theorem kw_surgehgf4_hu5c_gcd_eq_one_of_isAddCyclic
+    {H : AddSubgroup (ℤ × ℤ)} (hN : H.index ≠ 0)
+    (hcyc : IsAddCyclic ((ℤ × ℤ) ⧸ H)) :
+    Nat.gcd (aOf H) (Nat.gcd (bOf H).toNat (dOf H)) = 1 := by
+  by_contra hgcd
+  have hgcd_ne : Nat.gcd (aOf H) (Nat.gcd (bOf H).toNat (dOf H)) ≠ 1 := hgcd
+  obtain ⟨p, hp, hpdvd⟩ := Nat.exists_prime_and_dvd hgcd_ne
+  have hd0 : dOf H ≠ 0 := fun h => hN (by rw [index_eq_dOf_mul_aOf, h, zero_mul])
+  have hpa : (p : ℤ) ∣ (aOf H : ℤ) :=
+    Int.natCast_dvd_natCast.mpr (hpdvd.trans (Nat.gcd_dvd_left _ _))
+  have hpb : (p : ℤ) ∣ bOf H := by
+    have hb : ((bOf H).toNat : ℤ) = bOf H := Int.toNat_of_nonneg (bOf_nonneg H hd0)
+    have : p ∣ (bOf H).toNat :=
+      hpdvd.trans ((Nat.gcd_dvd_right _ _).trans (Nat.gcd_dvd_left _ _))
+    exact hb ▸ Int.natCast_dvd_natCast.mpr this
+  have hpd : (p : ℤ) ∣ (dOf H : ℤ) :=
+    Int.natCast_dvd_natCast.mpr (hpdvd.trans ((Nat.gcd_dvd_right _ _).trans (Nat.gcd_dvd_right _
+      _)))
+  have : NeZero p := ⟨hp.ne_zero⟩
+  let π : ℤ × ℤ →+ ZMod p × ZMod p :=
+    (Int.castAddHom (ZMod p)).prodMap (Int.castAddHom (ZMod p))
+  have hπapply : ∀ x y : ℤ, π (x, y) = ((x : ZMod p), (y : ZMod p)) := fun x y => rfl
+  have hπsurj : Function.Surjective π := by
+    rintro ⟨x, y⟩
+    obtain ⟨a, ha⟩ := ZMod.intCast_surjective x
+    obtain ⟨b, hb⟩ := ZMod.intCast_surjective y
+    exact ⟨(a, b), by rw [hπapply, ha, hb]⟩
+  have hHker : H ≤ π.ker := by
+    rw [← latticeOf_canonical_eq H, latticeOf, AddSubgroup.closure_le]
+    rintro z (rfl | rfl)
+    · change π ((aOf H : ℤ), bOf H) = 0
+      rw [hπapply]
+      exact Prod.ext ((ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mpr hpa)
+        ((ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mpr hpb)
+    · change π (0, (dOf H : ℤ)) = 0
+      rw [hπapply]
+      exact Prod.ext (by simp) ((ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mpr hpd)
+  have hmapsurj : Function.Surjective
+      (QuotientAddGroup.map H π.ker (AddMonoidHom.id _) hHker) := by
+    intro y
+    obtain ⟨x, rfl⟩ := QuotientAddGroup.mk_surjective y
+    exact ⟨QuotientAddGroup.mk x, rfl⟩
+  have hqsurj : Function.Surjective
+      ((QuotientAddGroup.quotientKerEquivOfSurjective π hπsurj).toAddMonoidHom.comp
+        (QuotientAddGroup.map H π.ker (AddMonoidHom.id _) hHker)) :=
+    (QuotientAddGroup.quotientKerEquivOfSurjective π hπsurj).surjective.comp hmapsurj
+  have : IsAddCyclic (ZMod p × ZMod p) := by
+    obtain ⟨⟨g, hg⟩⟩ := hcyc
+    exact ⟨⟨_, fun y => by
+      obtain ⟨x, hx⟩ := hqsurj y; obtain ⟨k, hk⟩ := hg x
+      exact ⟨k, by rw [← hx, ← hk, map_zsmul]⟩⟩⟩
+  exact kw_surgehgf4_hu5c_not_isAddCyclic_zmod_prod hp.one_lt this
+
+def KwSublatticeQuotientZZTransport : Prop :=
+  ∀ (L L' : PeriodPair), (L'.lattice : Set ℂ) ⊆ L.lattice →
+    ∀ (α : ℂˣ) (τ : ℍ), (L.scale α).lattice = (ofTau τ).lattice →
+      IsAddCyclic (PeriodPair.sublatticeQuotient L L') →
+        IsAddCyclic ((ℤ × ℤ) ⧸ kw_HZZ τ (L'.scale α))
+
+end ModularCurve
+end
+end
+
+section
+
+
+noncomputable section
+
+p2m_open_scoped "PeriodPair \
+  P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.PeriodPair \
+  UpperHalfPlane"
+p2m_open "PeriodPair \
+  P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.PeriodPair Polynomial \
+  ModularCurve \
+  P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.ModularCurve"
+
+namespace ModularCurve
+p2m_export "ModularCurve" "primCosetReps mem_primCosetReps jq jqN ModularPolynomialData \
+  ModularPolynomialData.eval_eq_zero"
+p2m_open "ModularCurve"
+
+section Psi
+
+variable (L L' : PeriodPair) (α : ℂˣ) (τ : ℍ)
+
+theorem kw_surgehgf4_qtzz_phiTau_mem_scale
+    (hlat : (L.scale α).lattice = (ofTau τ).lattice) (p : ℤ × ℤ) :
+    kw_phiTau τ p ∈ (L.scale α).lattice := by
+  have h : kw_phiTau τ p ∈ (ofTau τ).lattice.toAddSubgroup := by
+    rw [← kw_phiTau_range τ]; exact ⟨p, rfl⟩
+  exact hlat ▸ h
+
+theorem kw_surgehgf4_qtzz_phiTau_invMul_mem
+    (hlat : (L.scale α).lattice = (ofTau τ).lattice) (p : ℤ × ℤ) :
+    ((α : ℂ)⁻¹ * kw_phiTau τ p) ∈ L.lattice := by
+  obtain ⟨l, hl, hlp⟩ := (mem_scale_lattice_iff L α).mp
+    (kw_surgehgf4_qtzz_phiTau_mem_scale L α τ hlat p)
+  rw [hlp, inv_mul_cancel_left₀ α.ne_zero]
+  exact hl
+
+def kw_surgehgf4_qtzz_psi₀ (hlat : (L.scale α).lattice = (ofTau τ).lattice) :
+    (ℤ × ℤ) →+ ↥L.lattice.toAddSubgroup where
+  toFun p := ⟨(α : ℂ)⁻¹ * kw_phiTau τ p,
+    kw_surgehgf4_qtzz_phiTau_invMul_mem L α τ hlat p⟩
+  map_zero' := Subtype.ext (by simp)
+  map_add' p q := Subtype.ext (by simp [mul_add])
+
+theorem kw_surgehgf4_qtzz_psi₀_apply
+    (hlat : (L.scale α).lattice = (ofTau τ).lattice) (p : ℤ × ℤ) :
+    ((kw_surgehgf4_qtzz_psi₀ L α τ hlat p : ↥L.lattice.toAddSubgroup) : ℂ)
+      = (α : ℂ)⁻¹ * kw_phiTau τ p := rfl
+
+def kw_surgehgf4_qtzz_psi (hlat : (L.scale α).lattice = (ofTau τ).lattice) :
+    (ℤ × ℤ) →+ PeriodPair.sublatticeQuotient L L' :=
+  (QuotientAddGroup.mk' _).comp (kw_surgehgf4_qtzz_psi₀ L α τ hlat)
+
+theorem kw_surgehgf4_qtzz_psi_surjective
+    (hlat : (L.scale α).lattice = (ofTau τ).lattice) :
+    Function.Surjective (kw_surgehgf4_qtzz_psi L L' α τ hlat) := by
+  refine (QuotientAddGroup.mk'_surjective _).comp fun l => ?_
+  have hαl : ((α : ℂ) * (l : ℂ)) ∈ (ofTau τ).lattice.toAddSubgroup := by
+    rw [← hlat]
+    exact (mem_scale_lattice_iff L α).mpr ⟨l, l.2, rfl⟩
+  obtain ⟨p, hp⟩ := (kw_phiTau_range τ ▸ hαl : ((α : ℂ) * (l : ℂ)) ∈ (kw_phiTau τ).range)
+  refine ⟨p, Subtype.ext ?_⟩
+  rw [kw_surgehgf4_qtzz_psi₀_apply, hp, inv_mul_cancel_left₀ α.ne_zero]
+
+theorem kw_surgehgf4_qtzz_psi_ker
+    (hlat : (L.scale α).lattice = (ofTau τ).lattice) :
+    (kw_surgehgf4_qtzz_psi L L' α τ hlat).ker = kw_HZZ τ (L'.scale α) := by
+  ext p
+  simp only [kw_surgehgf4_qtzz_psi, AddMonoidHom.mem_ker, AddMonoidHom.comp_apply,
+    QuotientAddGroup.mk'_apply, QuotientAddGroup.eq_zero_iff,
+    AddSubgroup.mem_addSubgroupOf, kw_HZZ, AddSubgroup.mem_comap,
+    Submodule.mem_toAddSubgroup]
+  rw [kw_surgehgf4_qtzz_psi₀_apply, mem_scale_lattice_iff]
+  constructor
+  · intro hmem
+    exact ⟨(α : ℂ)⁻¹ * kw_phiTau τ p, hmem, (mul_inv_cancel_left₀ α.ne_zero _).symm⟩
+  · rintro ⟨l', hl', hp⟩
+    rw [hp, inv_mul_cancel_left₀ α.ne_zero]
+    exact hl'
+
+end Psi
+
+theorem kw_surgehgf4_qtzz_proved : KwSublatticeQuotientZZTransport := by
+  intro L L' hsub α τ hlat hcyc
+  let ψ := kw_surgehgf4_qtzz_psi L L' α τ hlat
+  have hψsurj := kw_surgehgf4_qtzz_psi_surjective L L' α τ hlat
+  have hψker := kw_surgehgf4_qtzz_psi_ker L L' α τ hlat
+  let e : ((ℤ × ℤ) ⧸ kw_HZZ τ (L'.scale α)) ≃+ PeriodPair.sublatticeQuotient L L' :=
+    (QuotientAddGroup.quotientAddEquivOfEq hψker.symm).trans
+      (QuotientAddGroup.quotientKerEquivOfSurjective ψ hψsurj)
+  exact isAddCyclic_of_surjective e.symm.toAddMonoidHom e.symm.surjective
+
+end ModularCurve
+end
+end
+
+open _root_.ModularCurve
+  _root_.P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.ModularCurve
+  _root_.QuaternionAlgebra
+  _root_.P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.QuaternionAlgebra
+  _root_.PeriodPair
+  _root_.P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic.PeriodPair
+  UpperHalfPlane in
+theorem solution
+    {N : ℕ} [NeZero N] (L L' : PeriodPair)
+    (hsub : (L'.lattice : Set ℂ) ⊆ L.lattice) (hidx : PeriodPair.sublatticeIndex L L' = N)
+    (hcyc : IsAddCyclic (PeriodPair.sublatticeQuotient L L')) :
+    ∃ (a b d : ℕ) (τ σ : ℍ), (a, b, d) ∈ ModularCurve.primCosetReps N ∧
+      (σ : ℂ) = ((a : ℂ) * τ + b) / d ∧
+      L.jLattice = (PeriodPair.ofTau τ).jLattice ∧ L'.jLattice = (PeriodPair.ofTau σ).jLattice := by
+  obtain ⟨α, τ, hlat⟩ := kw_exists_scale_ofTau_lattice_eq L
+  have hjL : L.jLattice = (ofTau τ).jLattice :=
+    (L.jLattice_scale α).symm.trans (jLattice_eq_of_lattice_eq hlat)
+  have hjL' : L'.jLattice = (L'.scale α).jLattice := (L'.jLattice_scale α).symm
+  have hsub' : ((L'.scale α).lattice : Set ℂ) ⊆ (ofTau τ).lattice :=
+    hlat ▸ kw_scale_lattice_subset L L' α hsub
+  have hidx' : PeriodPair.sublatticeIndex (ofTau τ) (L'.scale α) = N := by
+    have hstep : PeriodPair.sublatticeIndex (ofTau τ) (L'.scale α)
+        = PeriodPair.sublatticeIndex (L.scale α) (L'.scale α) := by
+      unfold PeriodPair.sublatticeIndex; rw [hlat]
+    rw [hstep, kwSublatticeIndex_scale]; exact hidx
+  set H := kw_HZZ τ (L'.scale α)
+  have hNH : dOf H * aOf H = N := (index_eq_dOf_mul_aOf H).symm.trans
+    ((kw_HZZ_index τ (L'.scale α)).trans hidx')
+  have ha : 0 < aOf H := Nat.pos_of_ne_zero fun h =>
+    NeZero.ne N (by rw [← hNH, h, mul_zero])
+  have hd : 0 < dOf H := Nat.pos_of_ne_zero fun h =>
+    NeZero.ne N (by rw [← hNH, h, zero_mul])
+  have hb0 : 0 ≤ bOf H := bOf_nonneg H hd.ne'
+  have hbd : bOf H < ((dOf H : ℕ) : ℤ) := bOf_lt H hd.ne'
+  have hb : ((bOf H).toNat : ℂ) = (bOf H : ℂ) := by exact_mod_cast Int.toNat_of_nonneg hb0
+  have hHidx : H.index ≠ 0 := by rw [kw_HZZ_index, hidx']; exact NeZero.ne N
+  have hcycH : IsAddCyclic ((ℤ × ℤ) ⧸ H) := kw_surgehgf4_qtzz_proved L L' hsub α τ hlat hcyc
+  have hgcd := kw_surgehgf4_hu5c_gcd_eq_one_of_isAddCyclic hHidx hcycH
+  let σ := kw_hnfPoint τ (aOf H) (bOf H) (dOf H) ha hd
+  have hjM' : (L'.scale α).jLattice = (ofTau σ).jLattice := by
+    have hlat' : (L'.scale α).lattice
+        = ((ofTau σ).scale (Units.mk0 (dOf H : ℂ) (Nat.cast_ne_zero.mpr hd.ne'))).lattice := by
+      rw [kw_sublattice_eq_span τ (L'.scale α) hsub', kw_hnfPoint_scale_lattice]
+    exact (jLattice_eq_of_lattice_eq hlat').trans (jLattice_scale _ _)
+  refine ⟨aOf H, (bOf H).toNat, dOf H, τ, σ, ?_, ?_, hjL, hjL'.trans hjM'⟩
+  · exact (ModularCurve.mem_primCosetReps (NeZero.ne N)).mpr
+      ⟨(mul_comm _ _).trans hNH, by omega, hgcd⟩
+  · rw [kw_hnfPoint_coe, hb]
+
+end S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic
+end P2MW
+export P2MW.S_PeriodPair_exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane
+theorem PeriodPair.exists_mem_primCosetReps_and_jLattice_eq_of_isAddCyclic
+    {N : ℕ} [NeZero N] (L L' : PeriodPair)
+    (hsub : (L'.lattice : Set ℂ) ⊆ L.lattice) (hidx : PeriodPair.sublatticeIndex L L' = N)
+    (hcyc : IsAddCyclic (PeriodPair.sublatticeQuotient L L')) :
+    ∃ (a b d : ℕ) (τ σ : ℍ), (a, b, d) ∈ ModularCurve.primCosetReps N ∧
+      (σ : ℂ) = ((a : ℂ) * τ + b) / d ∧
+      L.jLattice = (PeriodPair.ofTau τ).jLattice ∧ L'.jLattice = (PeriodPair.ofTau σ).jLattice :=
+  solution L L' hsub hidx hcyc
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_and_isAddCyclic_sublatticeQuotient.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_and_isAddCyclic_sublatticeQuotient.lean
new file mode 100644
index 0000000000..4d3a1e89cf
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_and_isAddCyclic_sublatticeQuotient.lean
@@ -0,0 +1,2156 @@
+/-
+Based on Prove2Me node
+PeriodPair.exists_scale_lattice_subset_and_sublatticeIndex_eq_and_isAddCyclic_sublatticeQuotient
+(aa8de0ab-6fe5-5b54-9c67-7eb99189b746) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c1ce856c-80f9-5744-ba79-9be9c873e49a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_PeriodPair_Uniformization
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.AlgebraicTopology.FundamentalGroupoid.SimplyConnected
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_exists_differentiable_toPoint_comp_eq_pointMapOfPushforward_toPoint
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_discriminant_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_isUniformization_toPoint
+import Mathlib.LinearAlgebra.FreeModule.ModN
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cyclic N-isogeny of lattice curves comes from index-N sublattice
+
+Theorem statement:
+`PeriodPair.exists_scale_lattice_subset_and_sublatticeIndex_eq_and_isAddCyclic_sublatticeQuotient`
+(`aa8de0ab-6fe5-5b54-9c67-7eb99189b746`), by Claude, 2026-09-05.
+
+Proof: submission `c1ce856c-80f9-5744-ba79-9be9c873e49a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ and $L'$ be period pairs, with associated Weierstrass curves $y^2 = x^3 - (g_2/4)x - g_3/4$
+over $\mathbb{C}$ formed from their Eisenstein invariants, and assume both curves are elliptic and
+both affine curves satisfy: `GenusOnePlaceGate`, i.e. a bijection between the points of the curve
+and the places of its function field over $\mathbb{C}$, all of degree $1$;
+`GenusOnePlaceGate.IsCentred`, i.e. for every nonsingular pair $(x,y)$ the images in the function
+field of the coordinate-ring classes of $X$ and of $Y - y$ lie in the nonunits of the valuation
+subring of the place attached to the point $(x,y)$; and `AbelTheorem`, i.e. a divisor of degree $0$
+is principal exactly when its divisor sum vanishes. Let $\iota$ be a $\mathbb{C}$-algebra
+homomorphism from the function field of the $L'$-curve to that of the $L$-curve, assumed integral as
+a ring homomorphism, assumed finite in the sense that the target is a finite module over the source
+along $\iota$ (`hfin`), and satisfying the pushforward norm formula for divisors along $\iota$
+(`hN`). Let $N$ be a nonzero natural number, and suppose the kernel of `pointMapOfPushforward ι hι
+hfin hN`, the additive homomorphism from the points of the $L$-curve to the points of the $L'$-curve
+obtained by transporting the pushforward map on degree-zero divisor classes through the two
+point–$\mathrm{Pic}^0$ identifications, is cyclic of cardinality $N$. Then there is a unit $\beta
+\in \mathbb{C}^\times$ such that the lattice of $L'.\mathrm{scale}\,\beta$, namely $\beta\Lambda'$
+generated by $\beta\omega_1'$ and $\beta\omega_2'$, is contained in the lattice $\Lambda$ of $L$,
+the index of $\beta\Lambda'$ as a subgroup of $\Lambda$ equals $N$, and the quotient
+$\Lambda/\beta\Lambda'$ is cyclic.
+
+This is the analytic dictionary for isogenies of complex elliptic curves: a cyclic $N$-isogeny
+between two lattice curves is realised, after rescaling the target lattice, by an inclusion of
+lattices of index $N$ with cyclic quotient. It is used in the passage from a cyclic $N$-isogeny to a
+relation between the $j$-invariants of the two curves, as in
+[`WeierstrassCurve.Affine.
+eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward`]
+(thm.html#WeierstrassCurve.Affine.
+eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward)
+and
+[`WeierstrassCurve.Affine.IsogenyEndDatum.aeval_j_diag_eq_zero_of_finrankAlong_eq`]
+(thm.html#WeierstrassCurve.Affine.IsogenyEndDatum.aeval_j_diag_eq_zero_of_finrankAlong_eq).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_and_isAddCyclic_sublatticeQuotient.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_96bd748a
+
+
+noncomputable section
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ a₁ map mk Affine.Point.some \
+  Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ Affine.Point.neg_some j \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred \
+  Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing map Point.some Point.some.injEq \
+  Nonsingular FunctionField Point CoordinateRing.mk polynomial Point.neg_some \
+  pointMapOfPushforward IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace \
+  placeOfPoint deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_96bd748a.Polynomial IsDedekindDomain WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_96bd748a.WeierstrassCurve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_96bd748a.AlgebraicCurve"
+open scoped Polynomial.Bivariate
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem S13_ofHeightOneSpectrum_injective {R : Type*} [CommRing R] [IsDedekindDomain R]
+    [Algebra R W.FunctionField] [IsFractionRing R W.FunctionField] [Algebra F R]
+    [IsScalarTower F R W.FunctionField] :
+    Function.Injective (AlgebraicCurve.Place.ofHeightOneSpectrum (K := F) (R := R) (F :=
+      W.FunctionField)) := by
+  intro w₁ w₂ h
+  refine HeightOneSpectrum.eq_of_valuation_isEquiv_valuation (K := W.FunctionField) ?_
+  rw [Valuation.isEquiv_iff_valuationSubring]
+  exact congrArg AlgebraicCurve.Place.toValuationSubring h
+
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "XYIdeal quotientXYIdealEquiv YClass mk map \
+  XClass isDedekindDomain exists_eq_XYIdeal XYIdeal_isMaximal XYIdeal_ne_bot"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing"
+
+theorem algebraMap_eq_mk_C_C (a : F) :
+    algebraMap F W.CoordinateRing a = CoordinateRing.mk W (C (C a)) := by
+  rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+    Algebra.algebraMap_self_apply]
+  rfl
+
+theorem eq_of_XYIdeal_eq {x₁ y₁ x₂ y₂ : F} (h₂ : W.Equation x₂ y₂)
+    (h : XYIdeal W x₁ (C y₁) = XYIdeal W x₂ (C y₂)) : x₁ = x₂ ∧ y₁ = y₂ := by
+  have hne : XYIdeal W x₂ (C y₂) ≠ ⊤ := (XYIdeal_isMaximal h₂).ne_top
+  have hX₁ : XClass W x₁ ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert _ _)
+  have hX₂ : XClass W x₂ ∈ XYIdeal W x₂ (C y₂) := Ideal.subset_span (Set.mem_insert _ _)
+  have hY₁ : YClass W (C y₁) ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  have hY₂ : YClass W (C y₂) ∈ XYIdeal W x₂ (C y₂) :=
+    Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  constructor
+  · by_contra hx
+    apply hne
+    have hsub : XClass W x₁ - XClass W x₂ = algebraMap F W.CoordinateRing (x₂ - x₁) := by
+      rw [XClass, XClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      rw [← map_sub]
+      congr 1
+      rw [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hX₁ hX₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hx hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+  · by_contra hy
+    apply hne
+    have hsub : YClass W (C y₁) - YClass W (C y₂) = algebraMap F W.CoordinateRing (y₂ - y₁) := by
+      rw [YClass, YClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      simp only [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hY₁ hY₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hy hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+
+def heightOneSpectrumOfEquation {x y : F} (h : W.Equation x y) :
+    HeightOneSpectrum W.CoordinateRing where
+  asIdeal := XYIdeal W x (C y)
+  isPrime := (XYIdeal_isMaximal h).isPrime
+  ne_bot := XYIdeal_ne_bot x (C y)
+
+@[scoped simp]
+theorem heightOneSpectrumOfEquation_asIdeal {x y : F} (h : W.Equation x y) :
+    (heightOneSpectrumOfEquation h).asIdeal = XYIdeal W x (C y) := rfl
+
+theorem exists_sub_algebraMap_mem {x y : F} (h : W.Equation x y) (r : W.CoordinateRing) :
+    ∃ c : F, r - algebraMap F W.CoordinateRing c ∈ XYIdeal W x (C y) := by
+  set e := quotientXYIdealEquiv (W' := W) (x := x) (y := C y) h
+  refine ⟨e (Ideal.Quotient.mk _ r), ?_⟩
+  rw [← Ideal.Quotient.eq_zero_iff_mem, map_sub, sub_eq_zero]
+  apply e.injective
+  rw [← Ideal.Quotient.algebraMap_eq, ← IsScalarTower.algebraMap_apply, AlgEquiv.commutes,
+    Algebra.algebraMap_self_apply]
+
+end CoordinateRing
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_96bd748a.WeierstrassCurve.Affine.CoordinateRing"
+
+def IsFinitePlace (v : AlgebraicCurve.Place F W.FunctionField) : Prop :=
+  ∀ r : W.CoordinateRing, algebraMap W.CoordinateRing W.FunctionField r ∈ v.toValuationSubring
+
+def IsFinitePlace.ringHom {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    W.CoordinateRing →+* v.toValuationSubring where
+  toFun r := ⟨algebraMap W.CoordinateRing W.FunctionField r, hv r⟩
+  map_one' := Subtype.ext (map_one _)
+  map_mul' a b := Subtype.ext (map_mul _ a b)
+  map_zero' := Subtype.ext (map_zero _)
+  map_add' a b := Subtype.ext (map_add _ a b)
+
+@[scoped simp]
+theorem IsFinitePlace.coe_ringHom_apply {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) (r : W.CoordinateRing) :
+    (hv.ringHom r : W.FunctionField) = algebraMap W.CoordinateRing W.FunctionField r := rfl
+
+
+def IsFinitePlace.centre {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    Ideal W.CoordinateRing :=
+  (IsLocalRing.maximalIdeal v.toValuationSubring).comap hv.ringHom
+
+theorem IsFinitePlace.centre_isPrime {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre.IsPrime :=
+  Ideal.IsPrime.comap _
+
+theorem IsFinitePlace.inv_mem {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) {r : W.CoordinateRing} (hr : r ∉ hv.centre) :
+    (algebraMap W.CoordinateRing W.FunctionField r)⁻¹ ∈ v.toValuationSubring := by
+  have hunit : IsUnit (hv.ringHom r) := by
+    rw [IsFinitePlace.centre, Ideal.mem_comap, IsLocalRing.mem_maximalIdeal,
+      mem_nonunits_iff, not_not] at hr
+    exact hr
+  obtain ⟨t, ht⟩ := hunit.exists_right_inv
+  have ht' : algebraMap W.CoordinateRing W.FunctionField r * (t : W.FunctionField) = 1 := by
+    have := congrArg (fun a : v.toValuationSubring => (a : W.FunctionField)) ht
+    simpa using this
+  rw [inv_eq_of_mul_eq_one_right ht']
+  exact t.2
+
+theorem IsFinitePlace.centre_ne_bot {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre ≠ ⊥ := by
+  intro hbot
+  apply v.ne_top'
+  rw [eq_top_iff]
+  rintro z -
+  obtain ⟨r, s, hs, hz⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  have hs0 : s ∉ hv.centre := by
+    rw [hbot, Ideal.mem_bot]
+    exact fun h => nonZeroDivisors.ne_zero hs h
+  rw [← hz, div_eq_mul_inv]
+  exact mul_mem (hv r) (hv.inv_mem hs0)
+
+variable [IsDedekindDomain W.CoordinateRing]
+
+def placeOfEquation {x y : F} (h : W.Equation x y) :
+    AlgebraicCurve.Place F W.FunctionField :=
+  AlgebraicCurve.Place.ofHeightOneSpectrum (heightOneSpectrumOfEquation h)
+
+theorem placeOfEquation_injective {x₁ y₁ x₂ y₂ : F} (h₁ : W.Equation x₁ y₁)
+    (h₂ : W.Equation x₂ y₂) (h : placeOfEquation h₁ = placeOfEquation h₂) :
+    x₁ = x₂ ∧ y₁ = y₂ :=
+  eq_of_XYIdeal_eq h₂
+    (congrArg HeightOneSpectrum.asIdeal (S13_ofHeightOneSpectrum_injective h))
+
+theorem isFinitePlace_placeOfEquation {x y : F} (h : W.Equation x y) :
+    IsFinitePlace (placeOfEquation h) := fun r =>
+  (heightOneSpectrumOfEquation h).valuation_le_one r
+
+theorem isFinitePlace_iff_exists_placeOfEquation [IsAlgClosed F]
+    (v : AlgebraicCurve.Place F W.FunctionField) :
+    IsFinitePlace v ↔ ∃ (x y : F) (h : W.Equation x y), v = placeOfEquation h := by
+  constructor
+  · intro hv
+    have := hv.centre_isPrime
+    have hmax : hv.centre.IsMaximal := Ideal.IsPrime.isMaximal hv.centre_isPrime hv.centre_ne_bot
+    obtain ⟨x, y, hxy, hXY⟩ :=
+      CoordinateRing.exists_eq_XYIdeal (W := W) (P := hv.centre) hv.centre_ne_bot
+    refine ⟨x, y, hxy, ?_⟩
+    set w : HeightOneSpectrum W.CoordinateRing := heightOneSpectrumOfEquation hxy with hw
+    set A : ValuationSubring W.FunctionField :=
+      HeightOneSpectrum.valuationSubringAtPrime W.FunctionField w with hA
+    have hAded : IsDedekindDomain A := by rw [hA]; infer_instance
+    have hle : A ≤ v.toValuationSubring := by
+      intro z hz
+      rw [hA] at hz
+      obtain ⟨r, s, hs, rfl⟩ := hz
+      have hs' : s ∉ hv.centre := by
+        intro hmem
+        rw [hXY] at hmem
+        exact hs hmem
+      exact mul_mem (hv r) (hv.inv_mem hs')
+    have hSP : A.ofPrime (A.idealOfLE v.toValuationSubring hle) = v.toValuationSubring :=
+      ValuationSubring.ofPrime_idealOfLE A v.toValuationSubring hle
+    rcases eq_or_ne (A.idealOfLE v.toValuationSubring hle) ⊥ with hP | hP
+    · exfalso
+      apply v.ne_top'
+      have h2 : A.ofPrime ⊥ ≤ A.ofPrime (A.idealOfLE v.toValuationSubring hle) :=
+        ValuationSubring.ofPrime_le_of_le (h := hP.le)
+      rw [ValuationSubring.ofPrime_bot] at h2
+      exact top_le_iff.mp (le_trans h2 hSP.le)
+    · have hPmax : (A.idealOfLE v.toValuationSubring hle).IsMaximal :=
+        Ideal.IsPrime.isMaximal inferInstance hP
+      have hPeq : A.idealOfLE v.toValuationSubring hle = IsLocalRing.maximalIdeal A :=
+        IsLocalRing.eq_maximalIdeal hPmax
+      have h3 : A.ofPrime (A.idealOfLE v.toValuationSubring hle)
+          = A.ofPrime (IsLocalRing.maximalIdeal A) :=
+        le_antisymm (ValuationSubring.ofPrime_le_of_le (h := hPeq.ge))
+          (ValuationSubring.ofPrime_le_of_le (h := hPeq.le))
+      rw [ValuationSubring.ofPrime_top] at h3
+      have hAv : A = v.toValuationSubring := h3.symm.trans hSP
+      refine (AlgebraicCurve.Place.ext ?_).symm
+      change (AlgebraicCurve.Place.ofHeightOneSpectrum w).toValuationSubring = v.toValuationSubring
+      rw [AlgebraicCurve.Place.ofHeightOneSpectrum_toValuationSubring,
+        ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact hAv
+  · rintro ⟨x, y, h, rfl⟩
+    exact isFinitePlace_placeOfEquation h
+
+scoped instance S13_instIsDedekindDomainCoordinateRing [IsAlgClosed F] [W.IsElliptic] :
+    IsDedekindDomain W.CoordinateRing :=
+  CoordinateRing.isDedekindDomain (W := W)
+
+section CentredGate
+
+variable [DecidableEq F] [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W]
+
+omit [DecidableEq F] in
+@[scoped simp]
+theorem placeOfPoint_some {x y : F} (h : W.Nonsingular x y) :
+    placeOfPoint (.some x y h) = placeOfEquation h.left := by
+  classical
+  exact
+    placeOfPoint_some_eq_ofHeightOneSpectrum h (heightOneSpectrumOfEquation h.left) rfl
+
+namespace InfinitePlace
+
+def place : AlgebraicCurve.Place F W.FunctionField := placeOfPoint (0 : W.Point)
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem deg_eq_one : (place : AlgebraicCurve.Place F W.FunctionField).deg = 1 := by
+  classical
+  exact
+    deg_placeOfPoint (W := W) 0
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] in
+theorem not_isFinitePlace [IsAlgClosed F] [W.IsElliptic] :
+    ¬ IsFinitePlace (place : AlgebraicCurve.Place F W.FunctionField) := by
+  classical
+  exact
+    fun h =>
+     algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero (W := W) (h _)
+
+omit [DecidableEq F] in
+theorem eq_of_not_isFinitePlace
+    (v : AlgebraicCurve.Place F W.FunctionField) (hv : ¬ IsFinitePlace v) :
+    v = place := by
+  classical
+  obtain ⟨P, rfl⟩ : ∃ P : W.Point, placeOfPoint P = v :=
+    ⟨(pointEquivPlace (W := W)).symm v, (pointEquivPlace (W := W)).apply_symm_apply v⟩
+  cases P with
+  | zero => rfl
+  | some x y h =>
+      exact absurd (placeOfPoint_some (W := W) h ▸ isFinitePlace_placeOfEquation h.left) hv
+
+end InfinitePlace
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+@[scoped simp]
+theorem placeOfPoint_zero : placeOfPoint (.zero : W.Point) = InfinitePlace.place := by
+  classical
+  exact
+    rfl
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_zero' : placeOfPoint (0 : W.Point) = InfinitePlace.place := by
+  classical
+  exact
+    rfl
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_injective : Function.Injective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).injective
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_surjective (_hΔ : W.Δ ≠ 0) : Function.Surjective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).surjective
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_surjective' : Function.Surjective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).surjective
+
+end CentredGate
+end WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ a₁ map mk Affine.Point.some \
+  Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ Affine.Point.neg_some j \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred \
+  Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing map Point.some Point.some.injEq \
+  Nonsingular FunctionField Point CoordinateRing.mk polynomial Point.neg_some \
+  pointMapOfPushforward IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace \
+  placeOfPoint deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_96bd748a.AlgebraicCurve"
+
+scoped instance instHasPrincipalDivisorsFunctionField_s13 {F : Type*} [Field F] [CharZero F]
+    {W : Affine F} : HasPrincipalDivisors F W.FunctionField :=
+  hasPrincipalDivisors_functionField W
+
+section AutoNorm
+variable {F : Type*} [Field F] [CharZero F]
+variable {V W : Affine F} [V.IsElliptic] [W.IsElliptic]
+
+omit [WeierstrassCurve.IsElliptic V] [WeierstrassCurve.IsElliptic W] in
+theorem normFormulaAlong_of_elliptic (ι : V.FunctionField →ₐ[F] W.FunctionField)
+    (hfin : FiniteAlong F ι) : NormFormulaAlong F ι hfin := by
+  classical
+  have : HasPrincipalDivisors F W.FunctionField := hasPrincipalDivisors_functionField W
+  have : CharZero V.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap F V.FunctionField).injective
+  have hsep : SeparableAlong F ι := by
+    let := algebraAlong ι
+    have := isScalarTower_along ι
+    have : Module.Finite V.FunctionField W.FunctionField := hfin
+    change Algebra.IsSeparable V.FunctionField W.FunctionField
+    infer_instance
+  exact AlgebraicCurve.normFormulaAlong ι hfin hsep
+
+end AutoNorm
+
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι"
+p2m_open "WeierstrassCurve.Affine.IsogenyEndDatum"
+
+variable {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [GenusOnePlaceGate W] [AbelTheorem W]
+
+omit [DecidableEq F] [W.GenusOnePlaceGate] [W.AbelTheorem] in
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+private theorem _root_.WeierstrassCurve.Affine.IsogenyEndDatum.normFormulaAlong_auto (D :
+  IsogenyEndDatum W) :
+    NormFormulaAlong F D.ι D.hfin :=
+  normFormulaAlong_of_elliptic D.ι D.hfin
+
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "normFormulaAlong_auto"
+
+private def _root_.WeierstrassCurve.Affine.IsogenyEndDatum.pointEnd' (D : IsogenyEndDatum W) :
+    AddMonoid.End W.Point := D.pointEnd D.normFormulaAlong_auto
+
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd'"
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd_eq_pointEnd' (D : IsogenyEndDatum W) (hN : NormFormulaAlong F D.ι D.hfin) :
+    D.pointEnd hN = D.pointEnd' := rfl
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd'_apply (D : IsogenyEndDatum W) (P : W.Point) :
+    D.pointEnd' P = genusOnePic0Equiv W
+      (Pic0.pushforwardAlongHom D.ι D.hι D.hfin D.normFormulaAlong_auto (pointClass P)) :=
+  pointEnd_apply D _ P
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd'_eq_of_seam (D : IsogenyEndDatum W) (g : W.Point → W.Point) (hg0 : g 0 = 0)
+    (hg : ∀ P, (placeOfPoint P).restrictAlong D.ι D.hι = placeOfPoint (g P)) (P : W.Point) :
+    D.pointEnd' P = g P :=
+  pointEnd_eq_of_seam D _ g hg0 hg P
+
+end IsogenyEndDatum
+end WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ a₁ map Affine.CoordinateRing mk \
+  Affine.Point.some Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ \
+  Affine.Point.neg_some j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing map Point.some Point.some.injEq \
+  Nonsingular FunctionField Point CoordinateRing.mk polynomial Point.neg_some \
+  pointMapOfPushforward IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace \
+  placeOfPoint deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+end WeierstrassCurve.Affine
+p2m_open_scoped "WeierstrassCurve WeierstrassCurve.Affine" in
+scoped instance WeierstrassCurve.Affine.instHasPrincipalDivisorsFunctionField_s13e2
+    {F : Type*} [Field F] [CharZero F] (W : WeierstrassCurve.Affine F) :
+    AlgebraicCurve.HasPrincipalDivisors F W.FunctionField :=
+  WeierstrassCurve.Affine.hasPrincipalDivisors_functionField W
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongHom algebraAlong isScalarTower_along FiniteAlong \
+  NormFormulaAlong SeparableAlong Place Place.ext HasPrincipalDivisors Pic0 \
+  Place.ofHeightOneSpectrum Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ext deg ord ord_unit_smul_zpow \
+  exists_unit_mul_zpow ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' \
+  toValuationSubring mk ofHeightOneSpectrum_injective"
+end Place
+end AlgebraicCurve
+
+
+section
+open Complex Filter Set
+
+p2m_open_scoped "PeriodPair \
+  P2MW.S_OVERLONG_96bd748a.PeriodPair"
+
+namespace PeriodPair
+p2m_export "PeriodPair" "derivWeierstrassP_neg weierstrassP_neg lattice weierstrassP_add_coe \
+  lattice_eq_span_range_basis ω₁ mk latticeEquivProd g₃ ω₂ derivWeierstrassP_add_coe mem_lattice G \
+  g₂ exists_differentiable_toPoint_comp_eq_pointMapOfPushforward_toPoint weierstrassCurve \
+  weierstrassCurve_a₁ weierstrassCurve_a₃ DiscriminantNeZero toPoint toPoint_of_mem toPoint_zero \
+  toPoint_of_notMem IsUniformization jLattice scale_indep scale sublatticeIndex sublatticeQuotient \
+  exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker discriminant_ne_zero \
+  isUniformization_toPoint"
+p2m_open "PeriodPair"
+
+variable (L : PeriodPair)
+
+private theorem _root_.PeriodPair.kw_discriminantNeZero :
+    L.DiscriminantNeZero := L.discriminant_ne_zero
+
+p2m_export "PeriodPair" "kw_discriminantNeZero"
+
+private theorem _root_.PeriodPair.kw_isUniformization :
+    L.IsUniformization L.kw_discriminantNeZero :=
+  L.isUniformization_toPoint _
+
+p2m_export "PeriodPair" "kw_isUniformization"
+
+private theorem _root_.PeriodPair.kw_toPoint_add (hD : L.DiscriminantNeZero) (z w : ℂ) :
+    L.toPoint hD (z + w) = L.toPoint hD z + L.toPoint hD w :=
+  (L.isUniformization_toPoint hD).1 z w
+
+p2m_export "PeriodPair" "kw_toPoint_add"
+
+theorem kw_toPoint_surjective (hD : L.DiscriminantNeZero) : Function.Surjective (L.toPoint hD) :=
+  (L.isUniformization_toPoint hD).2.1
+
+theorem kw_toPoint_eq_zero_iff (hD : L.DiscriminantNeZero) (z : ℂ) :
+    L.toPoint hD z = 0 ↔ z ∈ L.lattice :=
+  ⟨(L.isUniformization_toPoint hD).2.2 z, fun hz => L.toPoint_of_mem hD hz⟩
+
+scoped instance kw_instIsElliptic : L.weierstrassCurve.IsElliptic :=
+  ⟨isUnit_iff_ne_zero.mpr L.kw_discriminantNeZero.weierstrassCurve_Δ_ne_zero⟩
+
+section Liouville
+
+private theorem _root_.PeriodPair.sub_fract_mem_lattice (z : ℂ) :
+    z - ZSpan.fract L.basis z ∈ L.lattice := by
+  rw [L.lattice_eq_span_range_basis]
+  have h := (ZSpan.fract_eq_fract L.basis (ZSpan.fract L.basis z) z).mp
+    (by rw [ZSpan.fract_eq_self.mpr (ZSpan.fract_mem_fundamentalDomain L.basis z)])
+  simpa [neg_add_eq_sub] using h
+
+p2m_export "PeriodPair" "sub_fract_mem_lattice"
+
+private theorem _root_.PeriodPair.apply_eq_apply_of_differentiable_of_forall_periodic {f : ℂ → ℂ}
+    (hf : Differentiable ℂ f) (hper : ∀ l ∈ L.lattice, ∀ z, f (z + l) = f z) (z w : ℂ) :
+    f z = f w := by
+  apply hf.apply_eq_apply_of_bounded
+  have hrange : range f ⊆ f '' closure (ZSpan.fundamentalDomain L.basis) := by
+    rintro - ⟨u, rfl⟩
+    refine ⟨ZSpan.fract L.basis u, subset_closure (ZSpan.fract_mem_fundamentalDomain _ u), ?_⟩
+    have h := hper _ (L.sub_fract_mem_lattice u) (ZSpan.fract L.basis u)
+    rw [add_sub_cancel] at h
+    exact h.symm
+  refine Bornology.IsBounded.subset ?_ hrange
+  refine (IsCompact.image ?_ hf.continuous).isBounded
+  exact Metric.isCompact_of_isClosed_isBounded isClosed_closure
+    (ZSpan.fundamentalDomain_isBounded L.basis).closure
+
+p2m_export "PeriodPair" "apply_eq_apply_of_differentiable_of_forall_periodic"
+end Liouville
+
+section ToPointLemmas
+
+private theorem _root_.PeriodPair.toPoint_add_mem (h : L.DiscriminantNeZero) (z : ℂ) {l : ℂ}
+    (hl : l ∈ L.lattice) :
+    L.toPoint h (z + l) = L.toPoint h z := by
+  by_cases hz : z ∈ L.lattice
+  · rw [L.toPoint_of_mem h hz, L.toPoint_of_mem h (add_mem hz hl)]
+  · have hzl : z + l ∉ L.lattice := fun hmem => hz (by simpa using sub_mem hmem hl)
+    rw [L.toPoint_of_notMem h hz, L.toPoint_of_notMem h hzl]
+    have hP : ℘[L] (z + l) = ℘[L] z := L.weierstrassP_add_coe z ⟨l, hl⟩
+    have hP' : ℘'[L] (z + l) = ℘'[L] z := L.derivWeierstrassP_add_coe z ⟨l, hl⟩
+    simp only [WeierstrassCurve.Affine.Point.some.injEq]
+    exact ⟨hP, by rw [hP']⟩
+
+p2m_export "PeriodPair" "toPoint_add_mem"
+
+theorem toPoint_neg (h : L.DiscriminantNeZero) (z : ℂ) :
+    L.toPoint h (-z) = -L.toPoint h z := by
+  by_cases hz : z ∈ L.lattice
+  · rw [L.toPoint_of_mem h hz, L.toPoint_of_mem h (neg_mem hz)]; rfl
+  · have hnz : -z ∉ L.lattice := fun hmem => hz (by simpa using neg_mem hmem)
+    rw [L.toPoint_of_notMem h hz, L.toPoint_of_notMem h hnz,
+      WeierstrassCurve.Affine.Point.neg_some]
+    simp only [WeierstrassCurve.Affine.Point.some.injEq]
+    refine ⟨L.weierstrassP_neg z, ?_⟩
+    rw [L.derivWeierstrassP_neg]
+    show -℘'[L] z / 2 = L.weierstrassCurve.toAffine.negY (℘[L] z) (℘'[L] z / 2)
+    rw [WeierstrassCurve.Affine.negY, weierstrassCurve_a₁, weierstrassCurve_a₃]
+    ring
+
+end ToPointLemmas
+
+section Isogeny
+
+private theorem _root_.PeriodPair.apply_eq_apply_of_continuous_of_mapsTo_lattice {f : ℂ → ℂ}
+    (hf : Continuous f)
+    (hmem : ∀ z, f z ∈ L.lattice) (z w : ℂ) : f z = f w := by
+  refine IsPreconnected.constant_of_mapsTo (isPreconnected_univ) ?_
+    hf.continuousOn (fun u _ => hmem u) (mem_univ z) (mem_univ w)
+  rw [isDiscrete_iff_discreteTopology]
+  exact inferInstanceAs (DiscreteTopology L.lattice)
+
+p2m_export "PeriodPair" "apply_eq_apply_of_continuous_of_mapsTo_lattice"
+
+private theorem _root_.PeriodPair.exists_smul_mem_and_apply_eq_of_forall_sub_mem (L' : PeriodPair)
+    {F : ℂ → ℂ}
+    (hF : Differentiable ℂ F)
+    (hper : ∀ l ∈ L.lattice, ∀ z, F (z + l) - F z ∈ L'.lattice) :
+    ∃ α : ℂ, (∀ l ∈ L.lattice, α * l ∈ L'.lattice) ∧ ∀ z, F z = F 0 + α * z := by
+  have hFc : Continuous F := hF.continuous
+  have hconst : ∀ l ∈ L.lattice, ∀ z, F (z + l) - F z = F l - F 0 := by
+    intro l hl z
+    have h := L'.apply_eq_apply_of_continuous_of_mapsTo_lattice
+      (f := fun u => F (u + l) - F u)
+      ((hFc.comp (continuous_id.add continuous_const)).sub hFc) (hper l hl) z 0
+    simpa using h
+  have hadd : ∀ z w, F (z + w) = F z + F w - F 0 := by
+    intro z w
+    have hper' : ∀ l ∈ L.lattice, ∀ u,
+        (fun u => F (u + w) - F u) (u + l) = (fun u => F (u + w) - F u) u := by
+      intro l hl u
+      have h1 := hconst l hl (u + w)
+      have h2 := hconst l hl u
+      rw [show u + w + l = u + l + w by ring] at h1
+      simp only
+      linear_combination h1 - h2
+    have h := L.apply_eq_apply_of_differentiable_of_forall_periodic
+      (f := fun u => F (u + w) - F u)
+      ((hF.comp (differentiable_id.add_const w)).sub hF) hper' z 0
+    simp only [zero_add] at h
+    linear_combination h
+  set α : ℂ := deriv F 0 with hα
+  have hderiv : ∀ z, deriv F z = α := by
+    intro z
+    have hfun : (fun w => F (z + w)) = fun w => F w + (F z - F 0) := by
+      funext w
+      rw [hadd z w]; ring
+    have h1 : deriv (fun w => F (z + w)) 0 = deriv F z := by
+      rw [deriv_comp_const_add]
+      simp
+    have h2 : deriv (fun w => F w + (F z - F 0)) 0 = deriv F 0 := by
+      rw [deriv_add_const]
+    rw [← h1, hfun, h2]
+  have haffine : ∀ z, F z = F 0 + α * z := by
+    have hG : Differentiable ℂ fun z => F z - α * z :=
+      hF.sub (differentiable_id.const_mul α)
+    have hG' : ∀ z, deriv (fun z => F z - α * z) z = 0 := by
+      intro z
+      have hd : HasDerivAt (fun z => F z - α * z) (deriv F z - α * 1) z :=
+        (hF z).hasDerivAt.sub ((hasDerivAt_id z).const_mul α)
+      rw [hd.deriv, hderiv z]
+      ring
+    intro z
+    have h := is_const_of_deriv_eq_zero hG hG' z 0
+    simp only [mul_zero, sub_zero] at h
+    linear_combination h
+  refine ⟨α, fun l hl => ?_, haffine⟩
+  have h := hper l hl 0
+  rw [zero_add, haffine l] at h
+  simpa using h
+
+p2m_export "PeriodPair" "exists_smul_mem_and_apply_eq_of_forall_sub_mem"
+end Isogeny
+
+section Scale
+
+variable (α : ℂˣ)
+
+private def mulLeftR (a : ℂ) : ℂ →ₗ[ℝ] ℂ := Algebra.lmul ℝ ℂ a
+
+@[scoped simp] private theorem mulLeftR_apply (a z : ℂ) : mulLeftR a z = a * z := rfl
+
+private theorem mulLeftR_injective {a : ℂ} (ha : a ≠ 0) :
+    Function.Injective (mulLeftR a) := fun _ _ h => by
+  simpa using mul_left_cancel₀ ha h
+
+private def mulLeftZ (a : ℂ) : ℂ →ₗ[ℤ] ℂ := (mulLeftR a).restrictScalars ℤ
+
+@[scoped simp] private theorem mulLeftZ_apply (a z : ℂ) : mulLeftZ a z = a * z := rfl
+
+private theorem _root_.PeriodPair.scale_lattice :
+    (L.scale α).lattice = Submodule.map (mulLeftZ (α : ℂ)) L.lattice := by
+  unfold lattice scale
+  rw [Submodule.map_span]
+  congr 1
+  ext z
+  simp only [Set.mem_insert_iff, Set.mem_singleton_iff, Set.mem_image, mulLeftZ_apply]
+  constructor
+  · rintro (rfl | rfl)
+    · exact ⟨L.ω₁, Or.inl rfl, rfl⟩
+    · exact ⟨L.ω₂, Or.inr rfl, rfl⟩
+  · rintro ⟨w, hw | hw, rfl⟩ <;> simp [hw]
+
+p2m_export "PeriodPair" "scale_lattice"
+private theorem _root_.PeriodPair.mem_scale_lattice_iff {z : ℂ} :
+    z ∈ (L.scale α).lattice ↔ ∃ l ∈ L.lattice, z = (α : ℂ) * l := by
+  rw [scale_lattice, Submodule.mem_map]; simp only [mulLeftZ_apply]; tauto
+
+p2m_export "PeriodPair" "mem_scale_lattice_iff"
+
+private def _root_.PeriodPair.scaleLatticeEquiv : L.lattice ≃ₗ[ℤ] (L.scale α).lattice :=
+  (Submodule.equivMapOfInjective (mulLeftZ (α : ℂ))
+    (fun _ _ h => mul_left_cancel₀ α.ne_zero (by simpa using h)) L.lattice).trans
+    (LinearEquiv.ofEq _ _ (L.scale_lattice α).symm)
+
+p2m_export "PeriodPair" "scaleLatticeEquiv"
+@[scoped simp] theorem scaleLatticeEquiv_apply (l : L.lattice) :
+    ((L.scaleLatticeEquiv α l : (L.scale α).lattice) : ℂ) = (α : ℂ) * (l : ℂ) := rfl
+
+end Scale
+
+section Homogeneity
+
+variable (α : ℂˣ)
+
+theorem G_scale (n : ℕ) : (L.scale α).G n = ((α : ℂ) ^ n)⁻¹ * L.G n := by
+  unfold G
+  rw [← (L.scaleLatticeEquiv α).toEquiv.tsum_eq]
+  simp only [LinearEquiv.coe_toEquiv, scaleLatticeEquiv_apply, mul_pow, mul_inv]
+  exact tsum_mul_left
+
+theorem g₂_scale : (L.scale α).g₂ = ((α : ℂ) ^ 4)⁻¹ * L.g₂ := by
+  unfold g₂; rw [G_scale]; ring
+
+theorem g₃_scale : (L.scale α).g₃ = ((α : ℂ) ^ 6)⁻¹ * L.g₃ := by
+  unfold g₃; rw [G_scale]; ring
+
+theorem discriminant_scale :
+    (L.scale α).g₂ ^ 3 - 27 * (L.scale α).g₃ ^ 2
+      = ((α : ℂ) ^ 12)⁻¹ * (L.g₂ ^ 3 - 27 * L.g₃ ^ 2) := by
+  rw [g₂_scale, g₃_scale]; ring
+
+theorem g₂_cubed_scale : (L.scale α).g₂ ^ 3 = ((α : ℂ) ^ 12)⁻¹ * L.g₂ ^ 3 := by
+  rw [g₂_scale, mul_pow, inv_pow, ← pow_mul]
+
+theorem jLattice_scale : (L.scale α).jLattice = L.jLattice := by
+  have hα : ((α : ℂ) ^ 12)⁻¹ ≠ 0 := inv_ne_zero (pow_ne_zero _ α.ne_zero)
+  unfold jLattice
+  rw [discriminant_scale, g₂_cubed_scale, mul_left_comm (1728 : ℂ), mul_div_mul_left _ _ hα]
+
+theorem discriminantNeZero_scale_iff :
+    (L.scale α).DiscriminantNeZero ↔ L.DiscriminantNeZero := by
+  unfold DiscriminantNeZero
+  rw [discriminant_scale]
+  simp only [mul_ne_zero_iff, and_iff_right (inv_ne_zero (pow_ne_zero 12 α.ne_zero))]
+
+end Homogeneity
+
+section LatticeDependence
+
+variable {L L' : PeriodPair}
+
+private def latticeEquivOfEq (h : L.lattice = L'.lattice) : L.lattice ≃ L'.lattice where
+  toFun l := ⟨(l : ℂ), h ▸ l.2⟩
+  invFun l := ⟨(l : ℂ), h.symm ▸ l.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+
+theorem G_eq_of_lattice_eq (h : L.lattice = L'.lattice) (n : ℕ) : L.G n = L'.G n :=
+  (latticeEquivOfEq h).tsum_eq fun l => ((l : ℂ) ^ n)⁻¹
+
+theorem g₂_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.g₂ = L'.g₂ := by
+  unfold g₂; rw [G_eq_of_lattice_eq h]
+
+theorem g₃_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.g₃ = L'.g₃ := by
+  unfold g₃; rw [G_eq_of_lattice_eq h]
+
+theorem jLattice_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.jLattice = L'.jLattice := by
+  unfold jLattice; rw [g₂_eq_of_lattice_eq h, g₃_eq_of_lattice_eq h]
+
+end LatticeDependence
+
+section Gates
+
+theorem gate_scale_mul (α β : ℂˣ) :
+    ((L.scale α).scale β).lattice = (L.scale (β * α)).lattice := by
+  ext z
+  simp only [mem_scale_lattice_iff, Units.val_mul]
+  constructor
+  · rintro ⟨-, ⟨l, hl, rfl⟩, rfl⟩; exact ⟨l, hl, (mul_assoc _ _ _).symm⟩
+  · rintro ⟨l, hl, rfl⟩; exact ⟨(α : ℂ) * l, ⟨l, hl, rfl⟩, mul_assoc _ _ _⟩
+
+end Gates
+
+private theorem _root_.PeriodPair.kw_countable_lattice : (L.lattice : Set ℂ).Countable := by
+  refine (Set.countable_range fun p : ℤ × ℤ => (p.1 : ℂ) * L.ω₁ + (p.2 : ℂ) * L.ω₂).mono ?_
+  intro z hz
+  obtain ⟨m, n, h⟩ := mem_lattice.mp hz
+  exact ⟨(m, n), h⟩
+
+p2m_export "PeriodPair" "kw_countable_lattice"
+
+private def _root_.PeriodPair.kw_toPointHom : ℂ →+ (L.weierstrassCurve.toAffine).Point where
+  toFun := L.toPoint L.kw_discriminantNeZero
+  map_zero' := L.toPoint_zero L.kw_discriminantNeZero
+  map_add' := L.kw_toPoint_add L.kw_discriminantNeZero
+
+p2m_export "PeriodPair" "kw_toPointHom"
+private theorem _root_.PeriodPair.kw_toPointHom_apply (z : ℂ) :
+    L.kw_toPointHom z = L.toPoint L.kw_discriminantNeZero z := rfl
+
+p2m_export "PeriodPair" "kw_toPointHom_apply"
+
+private theorem _root_.PeriodPair.kw_ker_toPointHom :
+    L.kw_toPointHom.ker = L.lattice.toAddSubgroup := by
+  ext z
+  constructor
+  · exact fun hz => (L.kw_isUniformization).2.2 z hz
+  · intro hz
+    exact L.toPoint_of_mem L.kw_discriminantNeZero hz
+
+p2m_export "PeriodPair" "kw_ker_toPointHom"
+
+private def _root_.PeriodPair.kw_toPointAddEquiv :
+    (ℂ ⧸ L.lattice.toAddSubgroup) ≃+ (L.weierstrassCurve.toAffine).Point :=
+  QuotientAddGroup.liftEquiv L.lattice.toAddSubgroup (φ := L.kw_toPointHom)
+    (L.kw_isUniformization).2.1 L.kw_ker_toPointHom.symm
+
+p2m_export "PeriodPair" "kw_toPointAddEquiv"
+theorem kw_toPointAddEquiv_mk (z : ℂ) :
+    L.kw_toPointAddEquiv (QuotientAddGroup.mk z) = L.toPoint L.kw_discriminantNeZero z :=
+  rfl
+
+scoped instance kw_infinite_quotientLattice : Infinite (ℂ ⧸ L.lattice.toAddSubgroup) := by
+  rw [← not_finite_iff_infinite]; intro hfin
+  have : Countable L.lattice.toAddSubgroup :=
+    Set.countable_coe_iff.mpr L.kw_countable_lattice
+  have : Countable ((ℂ ⧸ L.lattice.toAddSubgroup) × L.lattice.toAddSubgroup) := inferInstance
+  have hCc : Countable ℂ :=
+    Countable.of_equiv _ (AddSubgroup.addGroupEquivQuotientProdAddSubgroup
+      (s := L.lattice.toAddSubgroup)).symm
+  have : Uncountable ℂ := Complex.ofReal_injective.uncountable
+  exact absurd hCc not_countable
+
+private scoped instance _root_.PeriodPair.kw_infinite_point : Infinite
+  L.weierstrassCurve.toAffine.Point :=
+  L.kw_toPointAddEquiv.toEquiv.infinite_iff.mp inferInstance
+
+p2m_export "PeriodPair" "kw_infinite_point"
+end PeriodPair
+end
+
+namespace ModularCurve
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_96bd748a.WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_96bd748a.WeierstrassCurve.Affine \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_96bd748a.AlgebraicCurve PeriodPair \
+  P2MW.S_OVERLONG_96bd748a.PeriodPair"
+
+def KwD5BetweenCurvesHoloLift : Prop :=
+  ∀ (L L' : PeriodPair)
+    [L.weierstrassCurve.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve]
+    (ι'' : L'.weierstrassCurve.toAffine.FunctionField →ₐ[ℂ]
+      L.weierstrassCurve.toAffine.FunctionField)
+    (hι'' : ι''.toRingHom.IsIntegral) (hfin'' : FiniteAlong ℂ ι''),
+    ∃ (F : ℂ → ℂ), Differentiable ℂ F ∧ F 0 ∈ L'.lattice ∧
+      ∀ z, L'.kw_toPointHom (F z)
+        = (pointMapOfPushforward ι'' hι'' hfin''
+            (normFormulaAlong_of_elliptic ι'' hfin'')) (L.kw_toPointHom z)
+
+end ModularCurve
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongHom algebraAlong isScalarTower_along FiniteAlong \
+  NormFormulaAlong SeparableAlong Place Place.ext HasPrincipalDivisors Pic0 \
+  Place.ofHeightOneSpectrum Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective normFormulaAlong"
+end AlgebraicCurve
+namespace Matrix
+p2m_export "Matrix" "ext add sub zero scalar comp neg rank single ext_iff diagonal comp_apply of \
+  map one IsElliptic"
+end Matrix
+namespace Module
+p2m_export "Module" "Injective equiv Finite.equiv finrank Free mk Free.of_equiv End restrictScalars"
+end Module
+namespace PeriodPair
+p2m_export "PeriodPair" "derivWeierstrassP_neg weierstrassP_neg lattice weierstrassP_add_coe \
+  lattice_eq_span_range_basis ω₁ mk latticeEquivProd g₃ ω₂ derivWeierstrassP_add_coe mem_lattice G \
+  g₂ exists_differentiable_toPoint_comp_eq_pointMapOfPushforward_toPoint weierstrassCurve \
+  weierstrassCurve_a₁ weierstrassCurve_a₃ DiscriminantNeZero toPoint toPoint_of_mem toPoint_zero \
+  toPoint_of_notMem IsUniformization jLattice scale_indep scale sublatticeIndex sublatticeQuotient \
+  exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker discriminant_ne_zero \
+  isUniformization_toPoint"
+end PeriodPair
+namespace Polynomial
+p2m_export "Polynomial" "C X algebraMap_eq ext_iff degree map comp roots sum infinite reverse \
+  nontrivial flt coe_zero coe_add derivative algebraMap_apply div ext funext ring lifts"
+end Polynomial
+namespace QuaternionAlgebra
+p2m_export "QuaternionAlgebra" "algebraMap_eq re smul_mk lift coe_add coe_zero mk"
+end QuaternionAlgebra
+namespace UpperHalfPlane
+p2m_export "UpperHalfPlane" "ne_zero I mk coe_mk re"
+end UpperHalfPlane
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ a₁ map mk Affine.Point.some \
+  Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ Affine.Point.neg_some j \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred \
+  Affine.hasPrincipalDivisors_functionField"
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ a₁ map mk Affine.Point.some \
+  Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ Affine.Point.neg_some j \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred \
+  Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing map Point.some Point.some.injEq \
+  Nonsingular FunctionField Point CoordinateRing.mk polynomial Point.neg_some \
+  pointMapOfPushforward IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace \
+  placeOfPoint deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+end WeierstrassCurve.Affine
+
+
+section
+
+p2m_open_scoped "PeriodPair \
+  P2MW.S_OVERLONG_96bd748a.PeriodPair UpperHalfPlane \
+  P2MW.S_OVERLONG_96bd748a.UpperHalfPlane"
+p2m_open "PeriodPair \
+  P2MW.S_OVERLONG_96bd748a.PeriodPair Polynomial \
+  P2MW.S_OVERLONG_96bd748a.Polynomial"
+
+namespace ModularCurve
+
+theorem kw_scale_lattice_toAddSubgroup (L : PeriodPair) (α : ℂˣ) :
+    (L.scale α).lattice.toAddSubgroup
+      = L.lattice.toAddSubgroup.map (AddMonoidHom.mulLeft (α : ℂ)) := by
+  ext z
+  simp only [Submodule.mem_toAddSubgroup, mem_scale_lattice_iff, AddSubgroup.mem_map,
+    AddMonoidHom.coe_mulLeft]
+  exact ⟨fun ⟨l, hl, hz⟩ => ⟨l, hl, hz.symm⟩, fun ⟨l, hl, hz⟩ => ⟨l, hl, hz.symm⟩⟩
+
+theorem kwSublatticeIndex_scale (L L' : PeriodPair) (α : ℂˣ) :
+    PeriodPair.sublatticeIndex (L.scale α) (L'.scale α) = PeriodPair.sublatticeIndex L L' := by
+  have hinj : Function.Injective (AddMonoidHom.mulLeft (α : ℂ)) :=
+    fun _ _ h => mul_left_cancel₀ α.ne_zero h
+  change AddSubgroup.relIndex _ _ = AddSubgroup.relIndex _ _
+  rw [kw_scale_lattice_toAddSubgroup, kw_scale_lattice_toAddSubgroup,
+    AddSubgroup.relIndex_map_map_of_injective _ _ hinj]
+
+end ModularCurve
+end
+
+section
+
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_96bd748a.WeierstrassCurve \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_96bd748a.AlgebraicCurve \
+  P2MW.S_OVERLONG_96bd748a.ModularCurve"
+
+namespace ModularCurve
+
+section IntersectionEngine
+
+structure MilneI72IntersectionData (g : ℕ) where
+  intProd : MultilinearMap ℤ (fun _ : Fin g => ℤ) ℤ
+  degMul : ℤ → ℤ
+  pullback_intProd : ∀ n : ℤ, intProd (fun _ => n ^ 2) = degMul n * intProd 1
+  intProd_one_ne_zero : intProd 1 ≠ 0
+
+end IntersectionEngine
+
+section LatticeQuotient
+
+variable {V : Type*} [AddCommGroup V] [DivisibleBy V ℤ] [NoZeroSMulDivisors ℤ V]
+
+def divNHom (n : ℤ) (hn : n ≠ 0) : V →+ V where
+  toFun v := DivisibleBy.div v n
+  map_zero' := smul_right_injective V hn (by
+    change n • DivisibleBy.div (0 : V) n = n • 0
+    rw [DivisibleBy.div_cancel _ hn, smul_zero])
+  map_add' a b := smul_right_injective V hn (by
+    change n • DivisibleBy.div (a + b) n = n • (DivisibleBy.div a n + DivisibleBy.div b n)
+    rw [smul_add, DivisibleBy.div_cancel _ hn, DivisibleBy.div_cancel _ hn,
+      DivisibleBy.div_cancel _ hn])
+
+@[scoped simp] theorem smul_divNHom (n : ℤ) (hn : n ≠ 0) (v : V) :
+    n • divNHom n hn v = v :=
+  DivisibleBy.div_cancel v hn
+
+theorem divNHom_smul (n : ℤ) (hn : n ≠ 0) (v : V) :
+    divNHom n hn (n • v) = v :=
+  smul_right_injective V hn
+    (show n • divNHom n hn (n • v) = n • v from smul_divNHom n hn (n • v))
+
+variable (Λ : AddSubgroup V) {n : ℕ}
+
+def latticeDivQuot (hn : (n : ℤ) ≠ 0) :
+    ↥Λ →+ Submodule.torsionBy ℤ (V ⧸ Λ) (n : ℤ) where
+  toFun w := ⟨QuotientAddGroup.mk (divNHom (n : ℤ) hn (w : V)), by
+    rw [Submodule.mem_torsionBy_iff]
+    change (n : ℤ) • (QuotientAddGroup.mk (divNHom (n : ℤ) hn (w : V)) : V ⧸ Λ) = 0
+    rw [← QuotientAddGroup.mk_zsmul, smul_divNHom]
+    exact (QuotientAddGroup.eq_zero_iff _).mpr w.2⟩
+  map_zero' := by
+    apply Subtype.ext
+    change (QuotientAddGroup.mk (divNHom (n : ℤ) hn ((0 : ↥Λ) : V)) : V ⧸ Λ) = 0
+    simp
+  map_add' a b := by
+    apply Subtype.ext
+    change (QuotientAddGroup.mk (divNHom (n : ℤ) hn (((a + b : ↥Λ)) : V)) : V ⧸ Λ)
+        = QuotientAddGroup.mk (divNHom (n : ℤ) hn (a : V))
+          + QuotientAddGroup.mk (divNHom (n : ℤ) hn (b : V))
+    push_cast
+    rw [map_add, QuotientAddGroup.mk_add]
+
+@[scoped simp] theorem coe_latticeDivQuot (hn : (n : ℤ) ≠ 0) (w : ↥Λ) :
+    ((latticeDivQuot Λ hn w : Submodule.torsionBy ℤ (V ⧸ Λ) (n : ℤ)) : V ⧸ Λ)
+      = QuotientAddGroup.mk (divNHom (n : ℤ) hn (w : V)) :=
+  rfl
+
+theorem latticeDivQuot_surjective (hn : (n : ℤ) ≠ 0) :
+    Function.Surjective (latticeDivQuot Λ hn) := by
+  rintro ⟨x, hx⟩
+  rw [Submodule.mem_torsionBy_iff] at hx
+  obtain ⟨v, rfl⟩ := QuotientAddGroup.mk_surjective x
+  have hvΛ : (n : ℤ) • v ∈ Λ := by
+    rw [← QuotientAddGroup.eq_zero_iff, QuotientAddGroup.mk_zsmul]
+    exact hx
+  refine ⟨⟨(n : ℤ) • v, hvΛ⟩, Subtype.ext ?_⟩
+  rw [coe_latticeDivQuot]
+  change (QuotientAddGroup.mk (divNHom (n : ℤ) hn ((n : ℤ) • v)) : V ⧸ Λ)
+      = QuotientAddGroup.mk v
+  rw [divNHom_smul]
+
+theorem mem_ker_latticeDivQuot (hn : (n : ℤ) ≠ 0) (w : ↥Λ) :
+    w ∈ (latticeDivQuot Λ hn).ker
+      ↔ w ∈ LinearMap.range (LinearMap.lsmul ℤ ↥Λ (n : ℤ)) := by
+  constructor
+  · intro hker
+    rw [AddMonoidHom.mem_ker] at hker
+    have hcoe : ((latticeDivQuot Λ hn w :
+        Submodule.torsionBy ℤ (V ⧸ Λ) (n : ℤ)) : V ⧸ Λ) = 0 := by
+      rw [hker]; rfl
+    rw [coe_latticeDivQuot, QuotientAddGroup.eq_zero_iff] at hcoe
+    refine ⟨⟨divNHom (n : ℤ) hn (w : V), hcoe⟩, ?_⟩
+    apply Subtype.ext
+    change (n : ℤ) • divNHom (n : ℤ) hn (w : V) = (w : V)
+    exact smul_divNHom (n : ℤ) hn (w : V)
+  · rintro ⟨μ, rfl⟩
+    rw [AddMonoidHom.mem_ker]
+    apply Subtype.ext
+    rw [coe_latticeDivQuot]
+    change (QuotientAddGroup.mk (divNHom (n : ℤ) hn ((n : ℤ) • (μ : V))) : V ⧸ Λ) = 0
+    rw [divNHom_smul, QuotientAddGroup.eq_zero_iff]
+    exact μ.2
+
+theorem ker_latticeDivQuot (hn : (n : ℤ) ≠ 0) :
+    (latticeDivQuot Λ hn).ker
+      = (LinearMap.range (LinearMap.lsmul ℤ ↥Λ (n : ℤ))).toAddSubgroup := by
+  ext w
+  exact mem_ker_latticeDivQuot Λ hn w
+
+def latticeQuotTorsionEquiv (hn : (n : ℤ) ≠ 0) :
+    ModN ↥Λ n ≃+ Submodule.torsionBy ℤ (V ⧸ Λ) (n : ℤ) := by
+  refine AddEquiv.ofBijective
+    (QuotientAddGroup.lift _ (latticeDivQuot Λ hn) ?_) ⟨?_, ?_⟩
+  · intro w hw
+    have : w ∈ (latticeDivQuot Λ hn).ker := by
+      rw [ker_latticeDivQuot]; exact hw
+    exact this
+  · rintro ⟨a⟩ ⟨b⟩ hab
+    refine (Submodule.Quotient.eq _).mpr ?_
+    have hker : a - b ∈ (latticeDivQuot Λ hn).ker := by
+      rw [AddMonoidHom.mem_ker, map_sub]
+      exact sub_eq_zero.mpr hab
+    rwa [ker_latticeDivQuot] at hker
+  · intro y
+    obtain ⟨w, hw⟩ := latticeDivQuot_surjective Λ hn y
+    exact ⟨QuotientAddGroup.mk w, hw⟩
+
+theorem card_torsionBy_latticeQuotient [Module.Free ℤ ↥Λ] [Module.Finite ℤ ↥Λ]
+    (hn : (n : ℤ) ≠ 0) :
+    Nat.card (Submodule.torsionBy ℤ (V ⧸ Λ) (n : ℤ)) = n ^ Module.finrank ℤ ↥Λ := by
+  have : NeZero n := ⟨by exact_mod_cast hn⟩
+  rw [← Nat.card_congr (latticeQuotTorsionEquiv Λ hn).toEquiv, ModN.natCard_eq]
+
+end LatticeQuotient
+end ModularCurve
+end
+end
+
+section
+
+
+section
+
+p2m_open "P2MW.S_OVERLONG_96bd748a.ModularCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_96bd748a.WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_96bd748a.WeierstrassCurve.Affine Polynomial \
+  P2MW.S_OVERLONG_96bd748a.Polynomial \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_96bd748a.AlgebraicCurve PeriodPair \
+  P2MW.S_OVERLONG_96bd748a.PeriodPair"
+
+namespace ModularCurve
+
+universe u
+
+attribute [local instance] Classical.propDecidable
+
+
+section IndexDualMint
+
+def KwD5BetweenCurvesIndexDual : Prop :=
+  ∀ (L L' : PeriodPair)
+    [L.weierstrassCurve.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve]
+    (α : ℂˣ)
+    (ψ : L.weierstrassCurve.toAffine.Point →+ L'.weierstrassCurve.toAffine.Point),
+    (∀ z, L'.kw_toPointHom ((α : ℂ) * z) = ψ (L.kw_toPointHom z)) →
+    ∃ (β : ℂˣ), ((L'.scale β).lattice : Set ℂ) ⊆ L.lattice ∧
+      PeriodPair.sublatticeIndex L (L'.scale β) = Nat.card ψ.ker
+
+end IndexDualMint
+end ModularCurve
+end
+end
+
+section
+
+
+section
+
+p2m_open "Module \
+  P2MW.S_OVERLONG_96bd748a.Module"
+
+namespace ModularCurve
+
+variable {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+
+scoped instance (priority := low) kwRealModuleDivisibleByInt : DivisibleBy E ℤ where
+  div v n := ((n : ℝ)⁻¹) • v
+  div_zero v := by simp
+  div_cancel {n} v hn := by
+    have hn' : (n : ℝ) ≠ 0 := Int.cast_ne_zero.mpr hn
+    calc n • ((n : ℝ)⁻¹ • v) = (n : ℝ) • ((n : ℝ)⁻¹ • v) := (Int.cast_smul_eq_zsmul ℝ n _).symm
+      _ = v := by rw [smul_smul, mul_inv_cancel₀ hn', one_smul]
+
+scoped instance (priority := low) kwRealModuleNoZeroSMulDivisorsInt : NoZeroSMulDivisors ℤ E where
+  eq_zero_or_eq_zero_of_smul_eq_zero {n} {v} h := by
+    rcases eq_or_ne n 0 with rfl | hn
+    · exact Or.inl rfl
+    · refine Or.inr ?_
+      have h' : (n : ℝ) • v = 0 := by rwa [Int.cast_smul_eq_zsmul ℝ]
+      have hn' : (n : ℝ) ≠ 0 := Int.cast_ne_zero.mpr hn
+      exact (smul_eq_zero.mp h').resolve_left hn'
+
+variable [FiniteDimensional ℝ E] [ProperSpace E]
+variable (L : Submodule ℤ E) [DiscreteTopology L] [IsZLattice ℝ L]
+
+def kwLatticeCoeAddEquiv : L ≃+ L.toAddSubgroup where
+  toFun x := ⟨(x : E), x.2⟩
+  invFun x := ⟨(x : E), x.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  map_add' _ _ := rfl
+
+scoped instance kwLatticeToAddSubgroupFree : Module.Free ℤ (L.toAddSubgroup) :=
+  have : Module.Free ℤ L := ZLattice.module_free ℝ L
+  Module.Free.of_equiv (kwLatticeCoeAddEquiv L).toIntLinearEquiv
+
+scoped instance kwLatticeToAddSubgroupFinite : Module.Finite ℤ (L.toAddSubgroup) :=
+  have : Module.Finite ℤ L := ZLattice.module_finite ℝ L
+  Module.Finite.equiv (kwLatticeCoeAddEquiv L).toIntLinearEquiv
+
+theorem kw_card_torsionBy_zlatticeQuotient {n : ℕ} (hn : (n : ℤ) ≠ 0) :
+    Nat.card (Submodule.torsionBy ℤ (E ⧸ L.toAddSubgroup) (n : ℤ)) =
+      n ^ Module.finrank ℤ L := by
+  have h := ModularCurve.card_torsionBy_latticeQuotient (V := E) (L.toAddSubgroup) hn
+  rw [h]
+  exact congrArg (fun k => n ^ k)
+    (LinearEquiv.finrank_eq (kwLatticeCoeAddEquiv L).toIntLinearEquiv).symm
+
+theorem kw_card_torsionBy_zlatticeQuotient_finrank_real
+    {n : ℕ} (hn : (n : ℤ) ≠ 0) :
+    Nat.card (Submodule.torsionBy ℤ (E ⧸ L.toAddSubgroup) (n : ℤ)) =
+      n ^ Module.finrank ℝ E := by
+  rw [kw_card_torsionBy_zlatticeQuotient L hn, ZLattice.rank ℝ L]
+
+end ModularCurve
+end
+end
+
+section
+
+
+section
+
+p2m_open_scoped "PeriodPair \
+  P2MW.S_OVERLONG_96bd748a.PeriodPair UpperHalfPlane \
+  P2MW.S_OVERLONG_96bd748a.UpperHalfPlane MatrixGroups \
+  P2MW.S_OVERLONG_96bd748a.MatrixGroups"
+p2m_open "PeriodPair \
+  P2MW.S_OVERLONG_96bd748a.PeriodPair Polynomial \
+  P2MW.S_OVERLONG_96bd748a.Polynomial QuaternionAlgebra \
+  P2MW.S_OVERLONG_96bd748a.QuaternionAlgebra \
+  P2MW.S_OVERLONG_96bd748a.ModularCurve"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_96bd748a.AlgebraicCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_96bd748a.WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_96bd748a.WeierstrassCurve.Affine Matrix \
+  P2MW.S_OVERLONG_96bd748a.Matrix"
+
+namespace ModularCurve
+
+def KwD5BetweenCurvesPointHomSublatticeCyclic : Prop :=
+  ∀ (L L' : PeriodPair)
+    [L.weierstrassCurve.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve]
+    (ι'' : L'.weierstrassCurve.toAffine.FunctionField →ₐ[ℂ]
+      L.weierstrassCurve.toAffine.FunctionField)
+    (hι'' : ι''.toRingHom.IsIntegral) (hfin'' : FiniteAlong ℂ ι'')
+    (N : ℕ) [NeZero N],
+    IsAddCyclic (AddMonoidHom.ker
+      (pointMapOfPushforward ι'' hι'' hfin''
+        (normFormulaAlong_of_elliptic ι'' hfin''))) →
+    Nat.card (AddMonoidHom.ker
+      (pointMapOfPushforward ι'' hι'' hfin''
+        (normFormulaAlong_of_elliptic ι'' hfin''))) = N →
+    ∃ (β : ℂˣ), ((L'.scale β).lattice : Set ℂ) ⊆ L.lattice ∧
+      PeriodPair.sublatticeIndex L (L'.scale β) = N ∧
+      IsAddCyclic (PeriodPair.sublatticeQuotient L (L'.scale β))
+
+def KwD5BetweenCurvesKerQuotEquivBC : Prop :=
+  ∀ (L L' : PeriodPair)
+    [L.weierstrassCurve.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve]
+    (ι'' : L'.weierstrassCurve.toAffine.FunctionField →ₐ[ℂ]
+      L.weierstrassCurve.toAffine.FunctionField)
+    (hι'' : ι''.toRingHom.IsIntegral) (hfin'' : FiniteAlong ℂ ι'')
+    (N : ℕ) [NeZero N],
+    let ψ := pointMapOfPushforward ι'' hι'' hfin'' (normFormulaAlong_of_elliptic ι'' hfin'')
+    Nat.card ψ.ker = N →
+    KwD5BetweenCurvesHoloLift → KwD5BetweenCurvesIndexDual →
+    IsAddCyclic ψ.ker →
+    ∃ (β : ℂˣ), ((L'.scale β).lattice : Set ℂ) ⊆ L.lattice ∧
+      PeriodPair.sublatticeIndex L (L'.scale β) = Nat.card ψ.ker ∧
+      IsAddCyclic (PeriodPair.sublatticeQuotient L (L'.scale β))
+
+theorem kw_surgehgf4_hscd_pointHomSublatticeCyc_of_three
+    (hH2 : KwD5BetweenCurvesHoloLift) (hID : KwD5BetweenCurvesIndexDual)
+    (hKQE : KwD5BetweenCurvesKerQuotEquivBC) :
+    KwD5BetweenCurvesPointHomSublatticeCyclic := by
+  intro L L' _ _ _ _ _ _ _ _ ι'' hι'' hfin'' N _ hcyc hcard
+  obtain ⟨β, hsub, hidx, hcycQ⟩ := hKQE L L' ι'' hι'' hfin'' N hcard hH2 hID hcyc
+  exact ⟨β, hsub, hidx.trans hcard, hcycQ⟩
+
+end ModularCurve
+end
+end
+
+section
+
+
+section
+
+p2m_open "P2MW.S_OVERLONG_96bd748a.ModularCurve PeriodPair \
+  P2MW.S_OVERLONG_96bd748a.PeriodPair"
+
+namespace ModularCurve
+
+section BetweenCurves
+
+variable (L L' : PeriodPair)
+  [L.weierstrassCurve.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve]
+  (α : ℂˣ)
+  (ψ : L.weierstrassCurve.toAffine.Point →+ L'.weierstrassCurve.toAffine.Point)
+  (hint : ∀ z, L'.kw_toPointHom ((α : ℂ) * z) = ψ (L.kw_toPointHom z))
+
+include hint in
+def kw_surgehgf4_hID_kerIndexHom : L'.lattice.toAddSubgroup →+ ψ.ker where
+  toFun l' := ⟨L.kw_toPointHom ((α : ℂ)⁻¹ * (l' : ℂ)), by
+    rw [AddMonoidHom.mem_ker, ← hint ((α : ℂ)⁻¹ * (l' : ℂ)),
+      mul_inv_cancel_left₀ α.ne_zero]
+    have hl'0 : L'.kw_toPointHom (l' : ℂ) = 0 := by
+      rw [← AddMonoidHom.mem_ker, L'.kw_ker_toPointHom]; exact l'.2
+    exact hl'0⟩
+  map_zero' := Subtype.ext <| by simp
+  map_add' l'₁ l'₂ := Subtype.ext <| by
+    push_cast; rw [mul_add]; exact map_add L.kw_toPointHom _ _
+
+include hint in
+omit [L.weierstrassCurve.IsElliptic]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve] in
+theorem kw_surgehgf4_hID_kerIndexHom_apply (l' : L'.lattice.toAddSubgroup) :
+    (kw_surgehgf4_hID_kerIndexHom L L' α ψ hint l' : L.weierstrassCurve.toAffine.Point)
+      = L.kw_toPointHom ((α : ℂ)⁻¹ * (l' : ℂ)) := rfl
+
+include hint in
+omit [L.weierstrassCurve.IsElliptic]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve] in
+theorem kw_surgehgf4_hID_scale_subset :
+    ((L.scale α).lattice : Set ℂ) ⊆ L'.lattice := by
+  intro z hz
+  rw [SetLike.mem_coe, L.mem_scale_lattice_iff] at hz
+  obtain ⟨l, hl, rfl⟩ := hz
+  rw [SetLike.mem_coe, ← Submodule.mem_toAddSubgroup, ← L'.kw_ker_toPointHom,
+    AddMonoidHom.mem_ker, hint]
+  have hl0 : L.kw_toPointHom l = 0 := by
+    rw [← AddMonoidHom.mem_ker, L.kw_ker_toPointHom]; exact hl
+  rw [hl0, _root_.map_zero]
+
+include hint in
+omit [L.weierstrassCurve.IsElliptic]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve] in
+theorem kw_surgehgf4_hID_kerIndexHom_surjective :
+    Function.Surjective (kw_surgehgf4_hID_kerIndexHom L L' α ψ hint) := by
+  rintro ⟨P, hP⟩
+  obtain ⟨z, hz⟩ := (L.kw_isUniformization).2.1 P
+  have hαz : (α : ℂ) * z ∈ L'.lattice.toAddSubgroup := by
+    rw [← L'.kw_ker_toPointHom, AddMonoidHom.mem_ker, hint, L.kw_toPointHom_apply, hz]
+    exact hP
+  exact ⟨⟨(α : ℂ) * z, hαz⟩, Subtype.ext <| by
+    simp only [kw_surgehgf4_hID_kerIndexHom_apply, inv_mul_cancel_left₀ α.ne_zero,
+      L.kw_toPointHom_apply, hz]⟩
+
+include hint in
+omit [L.weierstrassCurve.IsElliptic]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve] in
+theorem kw_surgehgf4_hID_ker_kerIndexHom :
+    (kw_surgehgf4_hID_kerIndexHom L L' α ψ hint).ker
+      = (L.scale α).lattice.toAddSubgroup.addSubgroupOf L'.lattice.toAddSubgroup := by
+  ext ⟨l', hl'⟩
+  rw [AddMonoidHom.mem_ker, AddSubgroup.mem_addSubgroupOf]
+  constructor
+  · intro h
+    rw [Submodule.mem_toAddSubgroup, L.mem_scale_lattice_iff]
+    refine ⟨(α : ℂ)⁻¹ * l', ?_, (mul_inv_cancel_left₀ α.ne_zero l').symm⟩
+    have h0 : L.kw_toPointHom ((α : ℂ)⁻¹ * l') = 0 := Subtype.ext_iff.mp h
+    rwa [← AddMonoidHom.mem_ker, L.kw_ker_toPointHom, Submodule.mem_toAddSubgroup] at h0
+  · intro h
+    rw [Submodule.mem_toAddSubgroup, L.mem_scale_lattice_iff] at h
+    obtain ⟨v, hv, hvl'⟩ := h
+    apply Subtype.ext
+    change L.kw_toPointHom ((α : ℂ)⁻¹ * l') = 0
+    rw [show (l' : ℂ) = (α : ℂ) * v from hvl', inv_mul_cancel_left₀ α.ne_zero,
+      ← AddMonoidHom.mem_ker, L.kw_ker_toPointHom]
+    exact hv
+
+include hint in
+omit [L.weierstrassCurve.IsElliptic]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve] in
+theorem kw_surgehgf4_hID_forwardIndex_eq_card_ker :
+    PeriodPair.sublatticeIndex L' (L.scale α) = Nat.card ψ.ker := by
+  unfold PeriodPair.sublatticeIndex
+  rw [← kw_surgehgf4_hID_ker_kerIndexHom L L' α ψ hint, ← Nat.card_congr
+    (QuotientAddGroup.liftEquiv _
+      (kw_surgehgf4_hID_kerIndexHom_surjective L L' α ψ hint) rfl).toEquiv]
+  rfl
+
+include hint in
+omit [L.weierstrassCurve.IsElliptic]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve] in
+theorem kw_surgehgf4_hID_card_smul_subset :
+    ∀ l' ∈ L'.lattice, (Nat.card ψ.ker : ℂ) * l' ∈ (L.scale α).lattice := by
+  intro l' hl'
+  set N := Nat.card ψ.ker with hNdef
+  have hidx : ((L.scale α).lattice.toAddSubgroup.addSubgroupOf
+      L'.lattice.toAddSubgroup).index = N := by
+    have h := kw_surgehgf4_hID_forwardIndex_eq_card_ker L L' α ψ hint
+    unfold PeriodPair.sublatticeIndex at h; exact h
+  set H := (L.scale α).lattice.toAddSubgroup.addSubgroupOf L'.lattice.toAddSubgroup with hHdef
+  have hmem : N • (⟨l', hl'⟩ : L'.lattice.toAddSubgroup) ∈ H := hidx ▸ H.nsmul_index_mem _
+  rw [hHdef, AddSubgroup.mem_addSubgroupOf, Submodule.mem_toAddSubgroup] at hmem
+  have heq : ((N • (⟨l', hl'⟩ : L'.lattice.toAddSubgroup) : L'.lattice.toAddSubgroup) : ℂ)
+      = (Nat.card ψ.ker : ℂ) * l' := by
+    rw [AddSubmonoidClass.coe_nsmul, nsmul_eq_mul, hNdef]
+  rw [← heq]; exact hmem
+
+end BetweenCurves
+
+noncomputable def kw_surgehgf4_hID_dualUnit {X Y : Type*} [AddGroup X] [AddGroup Y]
+    (α : ℂˣ) (ψ : X →+ Y) (hN : 0 < Nat.card ψ.ker) : ℂˣ :=
+  Units.mk0 (Nat.card ψ.ker : ℂ) (by exact_mod_cast hN.ne') * α⁻¹
+
+theorem kw_surgehgf4_hID_dualUnit_val {X Y : Type*} [AddGroup X] [AddGroup Y]
+    (α : ℂˣ) (ψ : X →+ Y) (hN : 0 < Nat.card ψ.ker) :
+    (kw_surgehgf4_hID_dualUnit α ψ hN : ℂ) = (Nat.card ψ.ker : ℂ) * (α : ℂ)⁻¹ := by
+  simp only [kw_surgehgf4_hID_dualUnit, Units.val_mul, Units.val_mk0,
+    Units.val_inv_eq_inv_val]
+
+section BetweenCurves
+
+variable (L L' : PeriodPair)
+  [L.weierstrassCurve.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve]
+  (α : ℂˣ)
+  (ψ : L.weierstrassCurve.toAffine.Point →+ L'.weierstrassCurve.toAffine.Point)
+  (hint : ∀ z, L'.kw_toPointHom ((α : ℂ) * z) = ψ (L.kw_toPointHom z))
+
+include hint in
+omit [L.weierstrassCurve.IsElliptic]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve] in
+theorem kw_surgehgf4_hID_dual_subset (hN : 0 < Nat.card ψ.ker) :
+    ((L'.scale (kw_surgehgf4_hID_dualUnit α ψ hN)).lattice : Set ℂ) ⊆ L.lattice := by
+  intro z hz
+  rw [SetLike.mem_coe, L'.mem_scale_lattice_iff] at hz
+  obtain ⟨l', hl', rfl⟩ := hz
+  have hNl' := kw_surgehgf4_hID_card_smul_subset L L' α ψ hint l' hl'
+  rw [L.mem_scale_lattice_iff] at hNl'
+  obtain ⟨v, hv, hveq⟩ := hNl'
+  rw [SetLike.mem_coe, kw_surgehgf4_hID_dualUnit_val α ψ hN, mul_assoc,
+    show (Nat.card ψ.ker : ℂ) * ((α : ℂ)⁻¹ * l')
+      = (α : ℂ)⁻¹ * ((Nat.card ψ.ker : ℂ) * l') from by ring,
+    hveq, inv_mul_cancel_left₀ α.ne_zero]
+  exact hv
+
+theorem kw_surgehgf4_hID_sublatticeIndex_congr_snd {A M M' : PeriodPair}
+    (h : M.lattice = M'.lattice) :
+    PeriodPair.sublatticeIndex A M = PeriodPair.sublatticeIndex A M' := by
+  unfold PeriodPair.sublatticeIndex; rw [h]
+
+def kw_surgehgf4_hID_scaleIndexHom (M : PeriodPair) {N : ℕ} (hN : 0 < N) :
+    M.lattice.toAddSubgroup
+      →+ (Submodule.torsionBy ℤ (ℂ ⧸ M.lattice.toAddSubgroup) (N : ℤ)) where
+  toFun l := ⟨QuotientAddGroup.mk ((N : ℂ)⁻¹ * (l : ℂ)), by
+    rw [Submodule.mem_torsionBy_iff, ← QuotientAddGroup.mk_zsmul,
+      QuotientAddGroup.eq_zero_iff]
+    have hNne : (N : ℂ) ≠ 0 := by exact_mod_cast hN.ne'
+    have : (N : ℤ) • ((N : ℂ)⁻¹ * (l : ℂ)) = (l : ℂ) := by
+      rw [zsmul_eq_mul, Int.cast_natCast, mul_inv_cancel_left₀ hNne]
+    rw [this]; exact l.2⟩
+  map_zero' := Subtype.ext <| by simp
+  map_add' l₁ l₂ := Subtype.ext <| by
+    simp only [AddSubgroup.coe_add, mul_add]
+    rfl
+
+theorem kw_surgehgf4_hID_sublatticeIndex_scale_nat (M : PeriodPair)
+    {N : ℕ} (hN : 0 < N) :
+    PeriodPair.sublatticeIndex M (M.scale (Units.mk0 (N : ℂ) (by
+      exact_mod_cast hN.ne'))) = N ^ 2 := by
+  set Nu := Units.mk0 (N : ℂ) (by exact_mod_cast hN.ne') with hNudef
+  have hNuval : (Nu : ℂ) = (N : ℂ) := by rw [hNudef, Units.val_mk0]
+  have hNinv : (Nu : ℂ)⁻¹ = (N : ℂ)⁻¹ := by rw [hNuval]
+  have hsurj : Function.Surjective (kw_surgehgf4_hID_scaleIndexHom M hN) := by
+    rintro ⟨x, hx⟩
+    rw [Submodule.mem_torsionBy_iff] at hx
+    obtain ⟨z, rfl⟩ := QuotientAddGroup.mk_surjective x
+    have hNz : (N : ℂ) * z ∈ M.lattice.toAddSubgroup := by
+      have : (N : ℤ) • z ∈ M.lattice.toAddSubgroup := by
+        rw [← QuotientAddGroup.eq_zero_iff, QuotientAddGroup.mk_zsmul]; exact hx
+      simpa [zsmul_eq_mul] using this
+    refine ⟨⟨(N : ℂ) * z, hNz⟩, Subtype.ext ?_⟩
+    change QuotientAddGroup.mk ((N : ℂ)⁻¹ * ((N : ℂ) * z)) = QuotientAddGroup.mk z
+    rw [inv_mul_cancel_left₀ (by exact_mod_cast hN.ne' : (N : ℂ) ≠ 0)]
+  have hker : (kw_surgehgf4_hID_scaleIndexHom M hN).ker
+      = (M.scale Nu).lattice.toAddSubgroup.addSubgroupOf M.lattice.toAddSubgroup := by
+    ext ⟨l, hl⟩
+    rw [AddMonoidHom.mem_ker, AddSubgroup.mem_addSubgroupOf, Submodule.mem_toAddSubgroup,
+      M.mem_scale_lattice_iff]
+    constructor
+    · intro h0
+      have h0' : (N : ℂ)⁻¹ * l ∈ M.lattice.toAddSubgroup := by
+        have := Subtype.ext_iff.mp h0
+        simp only [kw_surgehgf4_hID_scaleIndexHom, AddMonoidHom.coe_mk, ZeroHom.coe_mk,
+          ZeroMemClass.coe_zero] at this
+        rwa [QuotientAddGroup.eq_zero_iff] at this
+      exact ⟨(N : ℂ)⁻¹ * l, h0',
+        by rw [hNuval, mul_inv_cancel_left₀ (by exact_mod_cast hN.ne' : (N : ℂ) ≠ 0)]⟩
+    · rintro ⟨v, hv, hvl⟩
+      apply Subtype.ext
+      change QuotientAddGroup.mk ((N : ℂ)⁻¹ * l) = 0
+      rw [QuotientAddGroup.eq_zero_iff,
+        show l = (N : ℂ) * v from hNuval ▸ hvl,
+        inv_mul_cancel_left₀ (by exact_mod_cast hN.ne' : (N : ℂ) ≠ 0)]
+      exact hv
+  have htor : Nat.card ↥(Submodule.torsionBy ℤ (ℂ ⧸ M.lattice.toAddSubgroup) (N : ℤ))
+      = N ^ 2 := by
+    rw [kw_card_torsionBy_zlatticeQuotient_finrank_real M.lattice
+      (by exact_mod_cast hN.ne' : (N : ℤ) ≠ 0), Complex.finrank_real_complex]
+  unfold PeriodPair.sublatticeIndex
+  rw [← hker, ← htor, ← Nat.card_congr
+    (QuotientAddGroup.liftEquiv _ hsurj rfl).toEquiv]
+  rfl
+
+include hint in
+omit [L.weierstrassCurve.IsElliptic]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve] in
+theorem kw_surgehgf4_hID_dualIndex_eq (hN : 0 < Nat.card ψ.ker) :
+    PeriodPair.sublatticeIndex L (L'.scale (kw_surgehgf4_hID_dualUnit α ψ hN))
+      = Nat.card ψ.ker := by
+  set N := Nat.card ψ.ker with hNdef
+  set β := kw_surgehgf4_hID_dualUnit α ψ hN with hβdef
+  set Nu := Units.mk0 (N : ℂ) (by exact_mod_cast hN.ne') with hNudef
+  have h1 : PeriodPair.sublatticeIndex L (L'.scale β)
+      = PeriodPair.sublatticeIndex (L.scale α) ((L'.scale β).scale α) :=
+    (kwSublatticeIndex_scale L (L'.scale β) α).symm
+  have hαβ : α * β = Nu := by
+    apply Units.ext
+    simp only [hβdef, hNudef, Units.val_mul, kw_surgehgf4_hID_dualUnit_val,
+      Units.val_mk0]
+    field_simp
+    exact_mod_cast hNdef.symm
+  have h2 : ((L'.scale β).scale α).lattice = (L'.scale Nu).lattice := by
+    rw [gate_scale_mul L' β α, hαβ]
+  have h3 : PeriodPair.sublatticeIndex (L.scale α) ((L'.scale β).scale α)
+      = PeriodPair.sublatticeIndex (L.scale α) (L'.scale Nu) :=
+    kw_surgehgf4_hID_sublatticeIndex_congr_snd h2
+  rw [h1, h3]
+  have hsub1 : ((L'.scale Nu).lattice : Set ℂ) ⊆ (L.scale α).lattice := by
+    intro z hz
+    rw [SetLike.mem_coe, L'.mem_scale_lattice_iff] at hz
+    obtain ⟨l', hl', rfl⟩ := hz
+    simp only [hNudef, Units.val_mk0]
+    exact kw_surgehgf4_hID_card_smul_subset L L' α ψ hint l' hl'
+  have hsub2 : ((L.scale α).lattice : Set ℂ) ⊆ L'.lattice :=
+    kw_surgehgf4_hID_scale_subset L L' α ψ hint
+  have htower : PeriodPair.sublatticeIndex L' (L'.scale Nu)
+      = PeriodPair.sublatticeIndex (L.scale α) (L'.scale Nu)
+        * PeriodPair.sublatticeIndex L' (L.scale α) := by
+    unfold PeriodPair.sublatticeIndex
+    have hle1 : (L'.scale Nu).lattice.toAddSubgroup ≤ (L.scale α).lattice.toAddSubgroup := by
+      intro z hz; exact hsub1 hz
+    have hle2 : (L.scale α).lattice.toAddSubgroup ≤ L'.lattice.toAddSubgroup := by
+      intro z hz; exact hsub2 hz
+    exact (AddSubgroup.relIndex_mul_relIndex _ _ _ hle1 hle2).symm
+  have hN2 : PeriodPair.sublatticeIndex L' (L'.scale Nu) = N ^ 2 :=
+    kw_surgehgf4_hID_sublatticeIndex_scale_nat L' hN
+  have hfwd : PeriodPair.sublatticeIndex L' (L.scale α) = N :=
+    kw_surgehgf4_hID_forwardIndex_eq_card_ker L L' α ψ hint
+  rw [hN2, hfwd] at htower
+  have : PeriodPair.sublatticeIndex (L.scale α) (L'.scale Nu) * N = N * N := by
+    rw [← htower]; ring
+  exact Nat.eq_of_mul_eq_mul_right hN this
+
+end BetweenCurves
+end ModularCurve
+end
+end
+
+section
+
+
+section
+
+p2m_open_scoped "PeriodPair \
+  P2MW.S_OVERLONG_96bd748a.PeriodPair UpperHalfPlane \
+  P2MW.S_OVERLONG_96bd748a.UpperHalfPlane"
+p2m_open "PeriodPair \
+  P2MW.S_OVERLONG_96bd748a.PeriodPair Polynomial \
+  P2MW.S_OVERLONG_96bd748a.Polynomial \
+  P2MW.S_OVERLONG_96bd748a.ModularCurve \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_96bd748a.AlgebraicCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_96bd748a.WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_96bd748a.WeierstrassCurve.Affine"
+
+namespace ModularCurve
+
+section CoreLemma
+
+variable {N : ℕ} [NeZero N]
+
+theorem kw_surgehgf4_kqe_map_fst (φ : ZMod N × ZMod N →+ ZMod N) (x : ZMod N) :
+    φ (x, 0) = x * φ (1, 0) := by
+  have hx : ((x, 0) : ZMod N × ZMod N) = x.val • ((1, 0) : ZMod N × ZMod N) := by
+    simp [Prod.smul_mk, nsmul_eq_mul, ZMod.natCast_val]
+  rw [hx, map_nsmul, nsmul_eq_mul, ZMod.natCast_val, ZMod.cast_id']
+  rfl
+
+theorem kw_surgehgf4_kqe_map_snd (φ : ZMod N × ZMod N →+ ZMod N) (y : ZMod N) :
+    φ (0, y) = y * φ (0, 1) := by
+  have hy : ((0, y) : ZMod N × ZMod N) = y.val • ((0, 1) : ZMod N × ZMod N) := by
+    simp [Prod.smul_mk, nsmul_eq_mul, ZMod.natCast_val]
+  rw [hy, map_nsmul, nsmul_eq_mul, ZMod.natCast_val, ZMod.cast_id']
+  rfl
+
+theorem kw_surgehgf4_kqe_map_eq (φ : ZMod N × ZMod N →+ ZMod N)
+    (p : ZMod N × ZMod N) :
+    φ p = p.1 * φ (1, 0) + p.2 * φ (0, 1) := by
+  have hp : p = ((p.1, 0) : ZMod N × ZMod N) + (0, p.2) := by ext <;> simp
+  conv_lhs => rw [hp]
+  rw [map_add, kw_surgehgf4_kqe_map_fst, kw_surgehgf4_kqe_map_snd]
+
+theorem kw_surgehgf4_kqe_negSwap_mem_ker (φ : ZMod N × ZMod N →+ ZMod N) :
+    (-φ (0, 1), φ (1, 0)) ∈ φ.ker := by
+  rw [AddMonoidHom.mem_ker, kw_surgehgf4_kqe_map_eq]
+  ring
+
+omit [NeZero N] in
+theorem kw_surgehgf4_kqe_addOrderOf_negSwap (a b : ZMod N) :
+    addOrderOf ((-b, a) : ZMod N × ZMod N) = Nat.lcm (addOrderOf a) (addOrderOf b) := by
+  rw [Prod.addOrderOf, addOrderOf_neg, Nat.lcm_comm]
+
+theorem kw_surgehgf4_kqe_lcm_addOrderOf_eq (φ : ZMod N × ZMod N →+ ZMod N)
+    (hφ : Function.Surjective φ) :
+    Nat.lcm (addOrderOf (φ (1, 0))) (addOrderOf (φ (0, 1))) = N := by
+  set a := φ (1, 0); set b := φ (0, 1)
+  refine Nat.dvd_antisymm ?_ ?_
+  · exact Nat.lcm_dvd (addOrderOf_dvd_of_nsmul_eq_zero (by simp))
+      (addOrderOf_dvd_of_nsmul_eq_zero (by simp))
+  · obtain ⟨p, hp⟩ := hφ 1
+    have h1 : addOrderOf (p.1 * a + p.2 * b) = N := by
+      rw [← kw_surgehgf4_kqe_map_eq, hp]; exact ZMod.addOrderOf_one N
+    have hlcm0 : Nat.lcm (addOrderOf a) (addOrderOf b) • (p.1 * a + p.2 * b) = 0 := by
+      rw [smul_add]
+      have ha0 : Nat.lcm (addOrderOf a) (addOrderOf b) • (p.1 * a) = 0 := by
+        rw [nsmul_eq_mul, mul_comm p.1 a, ← mul_assoc, ← nsmul_eq_mul]
+        obtain ⟨k, hk⟩ := Nat.dvd_lcm_left (addOrderOf a) (addOrderOf b)
+        rw [hk, mul_nsmul, addOrderOf_nsmul_eq_zero, smul_zero, zero_mul]
+      have hb0 : Nat.lcm (addOrderOf a) (addOrderOf b) • (p.2 * b) = 0 := by
+        rw [nsmul_eq_mul, mul_comm p.2 b, ← mul_assoc, ← nsmul_eq_mul]
+        obtain ⟨k, hk⟩ := Nat.dvd_lcm_right (addOrderOf a) (addOrderOf b)
+        rw [hk, mul_nsmul, addOrderOf_nsmul_eq_zero, smul_zero, zero_mul]
+      rw [ha0, hb0, add_zero]
+    calc N = addOrderOf (p.1 * a + p.2 * b) := h1.symm
+      _ ∣ Nat.lcm (addOrderOf a) (addOrderOf b) := addOrderOf_dvd_of_nsmul_eq_zero hlcm0
+
+theorem kw_surgehgf4_kqe_card_ker (φ : ZMod N × ZMod N →+ ZMod N)
+    (hφ : Function.Surjective φ) :
+    Nat.card φ.ker = N := by
+  have hG : Nat.card (ZMod N × ZMod N) = N ^ 2 := by simp [sq]
+  have hcodom : Nat.card (ZMod N) = N := by simp
+  have htot := (AddSubgroup.card_eq_card_quotient_mul_card_addSubgroup φ.ker).symm
+  rw [hG, Nat.card_congr (QuotientAddGroup.quotientKerEquivOfSurjective φ hφ).toEquiv,
+    hcodom, sq] at htot
+  exact Nat.eq_of_mul_eq_mul_left (NeZero.pos N) htot
+
+theorem kw_surgehgf4_kqe_isAddCyclic_ker_of_surjective
+    (φ : ZMod N × ZMod N →+ ZMod N) (hφ : Function.Surjective φ) :
+    IsAddCyclic φ.ker := by
+  set a := φ (1, 0); set b := φ (0, 1)
+  set g : φ.ker := ⟨(-b, a), kw_surgehgf4_kqe_negSwap_mem_ker φ⟩ with hgdef
+  refine ⟨g, fun x => ?_⟩
+  have hg_ord : addOrderOf g = N := by
+    have hcoe : addOrderOf g = addOrderOf ((-b, a) : ZMod N × ZMod N) :=
+      (AddSubgroup.addOrderOf_coe g).symm
+    rw [hcoe, kw_surgehgf4_kqe_addOrderOf_negSwap,
+      kw_surgehgf4_kqe_lcm_addOrderOf_eq φ hφ]
+  have hgen : AddSubgroup.zmultiples g = ⊤ := by
+    refine AddSubgroup.eq_top_of_card_eq _ ?_
+    rw [Nat.card_zmultiples, hg_ord]
+    exact (kw_surgehgf4_kqe_card_ker φ hφ).symm
+  exact (AddSubgroup.eq_top_iff' _).mp hgen x
+
+theorem kw_surgehgf4_kqe_isAddCyclic_ker_of_surjective'
+    {C : Type*} [AddCommGroup C]
+    (φ : ZMod N × ZMod N →+ C) (hφ : Function.Surjective φ)
+    (hcard : Nat.card C = N) (hcyc : IsAddCyclic C) :
+    IsAddCyclic φ.ker := by
+  have hfin : Finite C := Nat.finite_of_card_ne_zero (hcard ▸ NeZero.ne N)
+  obtain ⟨g, hg⟩ := hcyc
+  let e : C ≃+ ZMod N := (zmodAddEquivOfGenerator hg hcard).symm
+  have hker_eq : (e.toAddMonoidHom.comp φ).ker = φ.ker := by
+    ext x
+    rw [AddMonoidHom.mem_ker, AddMonoidHom.mem_ker, AddMonoidHom.comp_apply]
+    exact ⟨fun h => e.injective (by rw [_root_.map_zero]; exact h),
+      fun h => by rw [h, _root_.map_zero]⟩
+  rw [← hker_eq]
+  exact kw_surgehgf4_kqe_isAddCyclic_ker_of_surjective _ (e.surjective.comp hφ)
+
+end CoreLemma
+
+section ZModSqEquiv
+
+variable (M : PeriodPair) {N : ℕ} [NeZero N]
+
+local notation "πN" => (Int.castAddHom (ZMod N))
+
+noncomputable def kw_surgehgf4_kqe_toZModSq :
+    M.lattice.toAddSubgroup →+ ZMod N × ZMod N :=
+  (AddMonoidHom.prodMap πN πN).comp
+    (AddMonoidHom.ofClass M.latticeEquivProd.toAddEquiv)
+
+omit [NeZero N] in
+theorem kw_surgehgf4_kqe_toZModSq_apply (l : M.lattice.toAddSubgroup) :
+    kw_surgehgf4_kqe_toZModSq M (N := N) l
+      = (((M.latticeEquivProd ⟨l, l.2⟩).1 : ZMod N), ((M.latticeEquivProd ⟨l, l.2⟩).2 : ZMod N))
+        := by
+  rfl
+
+omit [NeZero N] in
+theorem kw_surgehgf4_kqe_toZModSq_surjective :
+    Function.Surjective (kw_surgehgf4_kqe_toZModSq M (N := N)) := by
+  intro ⟨c₁, c₂⟩
+  obtain ⟨n₁, hn₁⟩ := ZMod.intCast_surjective c₁
+  obtain ⟨n₂, hn₂⟩ := ZMod.intCast_surjective c₂
+  refine ⟨⟨M.latticeEquivProd.symm (n₁, n₂), (M.latticeEquivProd.symm (n₁, n₂)).2⟩, ?_⟩
+  rw [kw_surgehgf4_kqe_toZModSq_apply]
+  simp [hn₁, hn₂]
+
+theorem kw_surgehgf4_kqe_ker_toZModSq :
+    (kw_surgehgf4_kqe_toZModSq M (N := N)).ker
+      = (M.scale (Units.mk0 (N : ℂ)
+          (by exact_mod_cast NeZero.ne N))).lattice.toAddSubgroup.addSubgroupOf
+          M.lattice.toAddSubgroup := by
+  ext l
+  rw [AddMonoidHom.mem_ker, kw_surgehgf4_kqe_toZModSq_apply, Prod.mk_eq_zero,
+    ZMod.intCast_zmod_eq_zero_iff_dvd, ZMod.intCast_zmod_eq_zero_iff_dvd,
+    AddSubgroup.mem_addSubgroupOf, Submodule.mem_toAddSubgroup, mem_scale_lattice_iff]
+  set p := M.latticeEquivProd ⟨l, l.2⟩ with hpdef
+  constructor
+  · rintro ⟨⟨a, ha⟩, ⟨b, hb⟩⟩
+    refine ⟨M.latticeEquivProd.symm (a, b), (M.latticeEquivProd.symm (a, b)).2, ?_⟩
+    have heq : (⟨(l : ℂ), l.2⟩ : M.lattice) = (N : ℤ) • M.latticeEquivProd.symm (a, b) := by
+      apply M.latticeEquivProd.injective
+      rw [map_zsmul, LinearEquiv.apply_symm_apply, ← hpdef]
+      ext <;> simp [ha, hb, mul_comm]
+    have hcoe : (l : ℂ) = (N : ℂ) * (M.latticeEquivProd.symm (a, b) : ℂ) := by
+      have := congrArg Subtype.val heq
+      simp only [SetLike.val_smul, zsmul_eq_mul, Int.cast_natCast] at this
+      exact this
+    rw [hcoe, Units.val_mk0]
+  · rintro ⟨v, hv, hlv⟩
+    have hsub : (⟨(l : ℂ), l.2⟩ : M.lattice) = (N : ℤ) • (⟨v, hv⟩ : M.lattice) := by
+      apply Subtype.ext
+      simp only [SetLike.val_smul, zsmul_eq_mul, Int.cast_natCast]
+      rw [show (l : ℂ) = _ from hlv, Units.val_mk0]
+    have hvl : p = (N : ℤ) • M.latticeEquivProd ⟨v, hv⟩ := by
+      rw [hpdef, hsub, map_zsmul]
+    exact ⟨⟨(M.latticeEquivProd ⟨v, hv⟩).1, by rw [hvl]; simp⟩,
+      ⟨(M.latticeEquivProd ⟨v, hv⟩).2, by rw [hvl]; simp⟩⟩
+
+noncomputable def kw_surgehgf4_kqe_zmodSqEquiv :
+    PeriodPair.sublatticeQuotient M (M.scale (Units.mk0 (N : ℂ) (by exact_mod_cast NeZero.ne N)))
+      ≃+ ZMod N × ZMod N :=
+  (QuotientAddGroup.quotientAddEquivOfEq (kw_surgehgf4_kqe_ker_toZModSq M).symm).trans
+    (QuotientAddGroup.liftEquiv _ (kw_surgehgf4_kqe_toZModSq_surjective M) rfl)
+
+end ZModSqEquiv
+
+section Equivs
+
+variable (L L' : PeriodPair)
+  [L.weierstrassCurve.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+  [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve]
+  (α : ℂˣ)
+  (ψ : L.weierstrassCurve.toAffine.Point →+ L'.weierstrassCurve.toAffine.Point)
+  (hint : ∀ z, L'.kw_toPointHom ((α : ℂ) * z) = ψ (L.kw_toPointHom z))
+
+include hint in
+noncomputable def kw_surgehgf4_kqe_forwardEquiv :
+    PeriodPair.sublatticeQuotient L' (L.scale α) ≃+ ψ.ker :=
+  (QuotientAddGroup.quotientAddEquivOfEq
+    (kw_surgehgf4_hID_ker_kerIndexHom L L' α ψ hint).symm).trans
+    (QuotientAddGroup.liftEquiv _
+      (kw_surgehgf4_hID_kerIndexHom_surjective L L' α ψ hint) rfl)
+
+variable {N : ℕ} [NeZero N] (hcard : Nat.card ψ.ker = N)
+
+include hint in
+omit [L.weierstrassCurve.IsElliptic] [GenusOnePlaceGate L.weierstrassCurve]
+  [GenusOnePlaceGate.IsCentred L.weierstrassCurve] [AbelTheorem L.weierstrassCurve]
+  [L'.weierstrassCurve.IsElliptic] [GenusOnePlaceGate L'.weierstrassCurve]
+  [GenusOnePlaceGate.IsCentred L'.weierstrassCurve] [AbelTheorem L'.weierstrassCurve] in
+theorem kw_surgehgf4_kqe_alpha_mem (l : L.lattice.toAddSubgroup) :
+    (α : ℂ) * (l : ℂ) ∈ L'.lattice.toAddSubgroup := by
+  have hmem : (α : ℂ) * (l : ℂ) ∈ (L.scale α).lattice := by
+    rw [mem_scale_lattice_iff]; exact ⟨l, l.2, rfl⟩
+  exact kw_surgehgf4_hID_scale_subset L L' α ψ hint hmem
+
+include hint in
+noncomputable def kw_surgehgf4_kqe_Psi :
+    L.lattice.toAddSubgroup →+ ZMod N × ZMod N where
+  toFun l := kw_surgehgf4_kqe_toZModSq L' (N := N)
+    ⟨(α : ℂ) * (l : ℂ), kw_surgehgf4_kqe_alpha_mem L L' α ψ hint l⟩
+  map_zero' := by
+    change kw_surgehgf4_kqe_toZModSq L' ⟨(α : ℂ) * 0, _⟩ = 0
+    conv_lhs => rw [show ((⟨(α : ℂ) * 0, _⟩ : L'.lattice.toAddSubgroup) : L'.lattice.toAddSubgroup)
+      = 0 from Subtype.ext (by simp)]
+    exact _root_.map_zero _
+  map_add' l₁ l₂ := by
+    show kw_surgehgf4_kqe_toZModSq L' ⟨(α : ℂ) * _, _⟩
+      = kw_surgehgf4_kqe_toZModSq L' ⟨_, _⟩ + kw_surgehgf4_kqe_toZModSq L' ⟨_, _⟩
+    rw [← map_add (kw_surgehgf4_kqe_toZModSq L')]
+    congr 1
+    apply Subtype.ext
+    push_cast; ring
+
+include hint hcard in
+omit [L.weierstrassCurve.IsElliptic] [GenusOnePlaceGate L.weierstrassCurve]
+  [GenusOnePlaceGate.IsCentred L.weierstrassCurve] [AbelTheorem L.weierstrassCurve]
+  [L'.weierstrassCurve.IsElliptic] [GenusOnePlaceGate L'.weierstrassCurve]
+  [GenusOnePlaceGate.IsCentred L'.weierstrassCurve] [AbelTheorem L'.weierstrassCurve] in
+theorem kw_surgehgf4_kqe_ker_Psi :
+    (kw_surgehgf4_kqe_Psi L L' α ψ hint (N := N)).ker
+      = (L'.scale (kw_surgehgf4_hID_dualUnit α ψ
+          (hcard ▸ NeZero.pos N))).lattice.toAddSubgroup.addSubgroupOf
+          L.lattice.toAddSubgroup := by
+  ext l
+  rw [AddMonoidHom.mem_ker]
+  change kw_surgehgf4_kqe_toZModSq L'
+      ⟨(α : ℂ) * (l : ℂ), kw_surgehgf4_kqe_alpha_mem L L' α ψ hint l⟩ = 0 ↔ _
+  rw [show (kw_surgehgf4_kqe_toZModSq L' (N := N)
+          ⟨(α : ℂ) * (l : ℂ), kw_surgehgf4_kqe_alpha_mem L L' α ψ hint l⟩ = 0)
+        ↔ (⟨(α : ℂ) * (l : ℂ), kw_surgehgf4_kqe_alpha_mem L L' α ψ hint l⟩
+            : L'.lattice.toAddSubgroup)
+          ∈ (kw_surgehgf4_kqe_toZModSq L' (N := N)).ker from Iff.rfl,
+    kw_surgehgf4_kqe_ker_toZModSq, AddSubgroup.mem_addSubgroupOf,
+    AddSubgroup.mem_addSubgroupOf, Submodule.mem_toAddSubgroup,
+    Submodule.mem_toAddSubgroup, mem_scale_lattice_iff, mem_scale_lattice_iff]
+  constructor
+  · rintro ⟨v, hv, hav⟩
+    refine ⟨v, hv, ?_⟩
+    have hav' : (α : ℂ) * (l : ℂ) = (N : ℂ) * v := by
+      have := hav; simpa [Units.val_mk0] using this
+    rw [kw_surgehgf4_hID_dualUnit_val, hcard,
+      show (l : ℂ) = (α : ℂ)⁻¹ * ((α : ℂ) * (l : ℂ)) from
+        (inv_mul_cancel_left₀ α.ne_zero _).symm,
+      hav']
+    ring
+  · rintro ⟨v, hv, hlv⟩
+    refine ⟨v, hv, ?_⟩
+    change (α : ℂ) * (l : ℂ) = _
+    rw [hlv, kw_surgehgf4_hID_dualUnit_val, hcard, Units.val_mk0]
+    field_simp
+
+include hint hcard in
+omit [L.weierstrassCurve.IsElliptic] [GenusOnePlaceGate L.weierstrassCurve]
+  [GenusOnePlaceGate.IsCentred L.weierstrassCurve] [AbelTheorem L.weierstrassCurve]
+  [L'.weierstrassCurve.IsElliptic] [GenusOnePlaceGate L'.weierstrassCurve]
+  [GenusOnePlaceGate.IsCentred L'.weierstrassCurve] [AbelTheorem L'.weierstrassCurve] in
+theorem kw_surgehgf4_kqe_Nu_le_alpha :
+    (L'.scale (Units.mk0 (N : ℂ)
+        (by exact_mod_cast NeZero.ne N))).lattice.toAddSubgroup.addSubgroupOf
+        L'.lattice.toAddSubgroup
+      ≤ (L.scale α).lattice.toAddSubgroup.addSubgroupOf L'.lattice.toAddSubgroup := by
+  intro l' hl'
+  rw [AddSubgroup.mem_addSubgroupOf, Submodule.mem_toAddSubgroup] at hl' ⊢
+  rw [mem_scale_lattice_iff] at hl'
+  obtain ⟨v, hv, hlv⟩ := hl'
+  rw [show (l' : ℂ) = _ from hlv, Units.val_mk0]
+  exact hcard ▸ kw_surgehgf4_hID_card_smul_subset L L' α ψ hint v hv
+
+include hint hcard in
+noncomputable def kw_surgehgf4_kqe_Phi' :
+    ZMod N × ZMod N →+ PeriodPair.sublatticeQuotient L' (L.scale α) :=
+  (QuotientAddGroup.map _ _ (AddMonoidHom.id _)
+    (by simpa using kw_surgehgf4_kqe_Nu_le_alpha L L' α ψ hint hcard)).comp
+    (kw_surgehgf4_kqe_zmodSqEquiv L' (N := N)).symm.toAddMonoidHom
+
+include hint hcard in
+omit [L.weierstrassCurve.IsElliptic] [GenusOnePlaceGate L.weierstrassCurve]
+  [GenusOnePlaceGate.IsCentred L.weierstrassCurve] [AbelTheorem L.weierstrassCurve]
+  [L'.weierstrassCurve.IsElliptic] [GenusOnePlaceGate L'.weierstrassCurve]
+  [GenusOnePlaceGate.IsCentred L'.weierstrassCurve] [AbelTheorem L'.weierstrassCurve] in
+theorem kw_surgehgf4_kqe_Phi'_surjective :
+    Function.Surjective (kw_surgehgf4_kqe_Phi' L L' α ψ hint hcard) := by
+  intro x
+  obtain ⟨y, rfl⟩ := QuotientAddGroup.mk_surjective x
+  refine ⟨(kw_surgehgf4_kqe_zmodSqEquiv L' (N := N)) (QuotientAddGroup.mk y), ?_⟩
+  unfold kw_surgehgf4_kqe_Phi'
+  rw [AddMonoidHom.comp_apply]
+  simp only [AddEquiv.coe_toAddMonoidHom, AddEquiv.symm_apply_apply]
+  rfl
+
+include hint hcard in
+omit [L.weierstrassCurve.IsElliptic] [GenusOnePlaceGate L.weierstrassCurve]
+  [GenusOnePlaceGate.IsCentred L.weierstrassCurve] [AbelTheorem L.weierstrassCurve]
+  [L'.weierstrassCurve.IsElliptic] [GenusOnePlaceGate L'.weierstrassCurve]
+  [GenusOnePlaceGate.IsCentred L'.weierstrassCurve] [AbelTheorem L'.weierstrassCurve] in
+theorem kw_surgehgf4_kqe_Phi'_comp_Psi :
+    ∀ l, kw_surgehgf4_kqe_Phi' L L' α ψ hint hcard
+      (kw_surgehgf4_kqe_Psi L L' α ψ hint (N := N) l) = 0 := by
+  intro l
+  unfold kw_surgehgf4_kqe_Phi'
+  rw [AddMonoidHom.comp_apply]
+  have hsymm : (kw_surgehgf4_kqe_zmodSqEquiv L' (N := N)).symm.toAddMonoidHom
+        (kw_surgehgf4_kqe_Psi L L' α ψ hint (N := N) l)
+      = QuotientAddGroup.mk
+          ⟨(α : ℂ) * (l : ℂ), kw_surgehgf4_kqe_alpha_mem L L' α ψ hint l⟩ := by
+    apply (kw_surgehgf4_kqe_zmodSqEquiv L' (N := N)).injective
+    simp only [AddEquiv.coe_toAddMonoidHom, AddEquiv.apply_symm_apply]
+    rfl
+  rw [hsymm]
+  change QuotientAddGroup.mk _ = 0
+  rw [QuotientAddGroup.eq_zero_iff, AddSubgroup.mem_addSubgroupOf,
+    Submodule.mem_toAddSubgroup, mem_scale_lattice_iff]
+  exact ⟨l, l.2, rfl⟩
+
+end Equivs
+
+theorem kw_surgehgf4_kqe_proved : KwD5BetweenCurvesKerQuotEquivBC := by
+  intro L L' _ _ _ _ _ _ _ _ ι'' hι'' hfin'' N _ ψ hcard hH2 _hID hcyc
+  have hNe : Nat.card ψ.ker ≠ 0 := hcard ▸ NeZero.ne N
+  obtain ⟨F, hFdiff, hF0, hFint⟩ := hH2 L L' ι'' hι'' hfin''
+  have hper : ∀ l ∈ L.lattice, ∀ z, F (z + l) - F z ∈ L'.lattice := by
+    intro l hl z
+    have h1 : L'.kw_toPointHom (F (z + l) - F z) = 0 := by
+      rw [map_sub, hFint, hFint, L.kw_toPointHom_apply, L.kw_toPointHom_apply,
+        L.toPoint_add_mem L.kw_discriminantNeZero z hl, sub_self]
+    rwa [← AddMonoidHom.mem_ker, L'.kw_ker_toPointHom, Submodule.mem_toAddSubgroup] at h1
+  obtain ⟨α, hαΛ, hFα⟩ := L.exists_smul_mem_and_apply_eq_of_forall_sub_mem L' hFdiff hper
+  have hint : ∀ z, L'.kw_toPointHom (α * z) = ψ (L.kw_toPointHom z) := by
+    intro z
+    have hF0' : L'.kw_toPointHom (F 0) = 0 := by
+      rw [← AddMonoidHom.mem_ker, L'.kw_ker_toPointHom, Submodule.mem_toAddSubgroup]
+      exact hF0
+    calc L'.kw_toPointHom (α * z)
+        = L'.kw_toPointHom (F z - F 0) := by rw [hFα z]; ring_nf
+      _ = L'.kw_toPointHom (F z) - L'.kw_toPointHom (F 0) := map_sub _ _ _
+      _ = L'.kw_toPointHom (F z) := by rw [hF0', sub_zero]
+      _ = ψ (L.kw_toPointHom z) := hFint z
+  have hα0 : α ≠ 0 := by
+    intro h0
+    have hψ0 : ∀ P, ψ P = 0 := by
+      intro P
+      obtain ⟨z, hz⟩ := (L.kw_isUniformization).2.1 P
+      have := hint z
+      rw [h0, zero_mul, _root_.map_zero, L.kw_toPointHom_apply, hz] at this
+      exact this.symm
+    have hker : ψ.ker = ⊤ := top_unique fun P _ => hψ0 P
+    have hcard0 : Nat.card (ψ.ker : Type _) = 0 := by
+      rw [hker, Nat.card_eq_zero]
+      exact Or.inr ((AddSubgroup.topEquiv).symm.toEquiv.infinite_iff.mp L.kw_infinite_point)
+    exact hNe hcard0
+  let αu : ℂˣ := Units.mk0 α hα0
+  have hαu : (αu : ℂ) = α := rfl
+  have hintU : ∀ z, L'.kw_toPointHom ((αu : ℂ) * z) = ψ (L.kw_toPointHom z) := hαu ▸ hint
+  have hN : 0 < Nat.card ψ.ker := Nat.pos_of_ne_zero hNe
+  set β := kw_surgehgf4_hID_dualUnit αu ψ hN with hβdef
+  refine ⟨β, kw_surgehgf4_hID_dual_subset L L' αu ψ hintU hN,
+    kw_surgehgf4_hID_dualIndex_eq L L' αu ψ hintU hN, ?_⟩
+  have hfwd := kw_surgehgf4_kqe_forwardEquiv L L' αu ψ hintU
+  have hcycLαL : IsAddCyclic (PeriodPair.sublatticeQuotient L' (L.scale αu)) :=
+    isAddCyclic_of_surjective hfwd.symm.toAddMonoidHom hfwd.symm.surjective
+  have hcardLαL : Nat.card (PeriodPair.sublatticeQuotient L' (L.scale αu)) = N := by
+    rw [Nat.card_congr hfwd.toEquiv, hcard]
+  set Φ' := kw_surgehgf4_kqe_Phi' L L' αu ψ hintU hcard with hΦdef
+  have hcycΦker : IsAddCyclic Φ'.ker :=
+    kw_surgehgf4_kqe_isAddCyclic_ker_of_surjective' Φ'
+      (kw_surgehgf4_kqe_Phi'_surjective L L' αu ψ hintU hcard)
+      hcardLαL hcycLαL
+  set Ψ := kw_surgehgf4_kqe_Psi L L' αu ψ hintU (N := N) with hΨdef
+  have hrangeSub : Ψ.range ≤ Φ'.ker := by
+    rintro _ ⟨l, rfl⟩
+    rw [AddMonoidHom.mem_ker]
+    exact kw_surgehgf4_kqe_Phi'_comp_Psi L L' αu ψ hintU hcard l
+  have hLβEquiv : PeriodPair.sublatticeQuotient L (L'.scale β) ≃+ Ψ.range :=
+    (QuotientAddGroup.quotientAddEquivOfEq
+      (kw_surgehgf4_kqe_ker_Psi L L' αu ψ hintU hcard).symm).trans
+      (QuotientAddGroup.quotientKerEquivRange Ψ)
+  have hcardLβ : Nat.card (PeriodPair.sublatticeQuotient L (L'.scale β)) = N := by
+    have hdual := kw_surgehgf4_hID_dualIndex_eq L L' αu ψ hintU hN
+    change ((L'.scale β).lattice.toAddSubgroup.addSubgroupOf L.lattice.toAddSubgroup).index = N
+    rw [hβdef]
+    exact hdual.trans hcard
+  have hcardΦker : Nat.card Φ'.ker = N := by
+    have hG : Nat.card (ZMod N × ZMod N) = N ^ 2 := by simp [sq]
+    have htot := (AddSubgroup.card_eq_card_quotient_mul_card_addSubgroup Φ'.ker).symm
+    rw [hG, Nat.card_congr (QuotientAddGroup.quotientKerEquivOfSurjective _
+        (kw_surgehgf4_kqe_Phi'_surjective L L' αu ψ hintU hcard)).toEquiv,
+      hcardLαL, sq] at htot
+    exact Nat.eq_of_mul_eq_mul_left (NeZero.pos N) htot
+  have hcardRange : Nat.card Ψ.range = N := by
+    rw [← Nat.card_congr hLβEquiv.toEquiv, hcardLβ]
+  have hrangeEq : Ψ.range = Φ'.ker := by
+    refine AddSubgroup.eq_of_le_of_card_ge hrangeSub ?_
+    rw [hcardRange, hcardΦker]
+  rw [← hrangeEq] at hcycΦker
+  exact isAddCyclic_of_surjective hLβEquiv.symm.toAddMonoidHom hLβEquiv.symm.surjective
+
+end ModularCurve
+end
+end
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg\
+  " in
+open _root_.WeierstrassCurve
+  _root_.P2MW.S_OVERLONG_96bd748a.WeierstrassCurve
+  _root_.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_96bd748a.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_96bd748a.AlgebraicCurve
+  in
+theorem solution
+    (L L' : PeriodPair) [L.weierstrassCurve.IsElliptic] [L'.weierstrassCurve.IsElliptic]
+    [GenusOnePlaceGate L.weierstrassCurve.toAffine]
+    [GenusOnePlaceGate.IsCentred L.weierstrassCurve.toAffine]
+    [AbelTheorem L.weierstrassCurve.toAffine]
+    [GenusOnePlaceGate L'.weierstrassCurve.toAffine]
+    [GenusOnePlaceGate.IsCentred L'.weierstrassCurve.toAffine]
+    [AbelTheorem L'.weierstrassCurve.toAffine]
+    (ι : L'.weierstrassCurve.toAffine.FunctionField →ₐ[ℂ] L.weierstrassCurve.toAffine.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong ℂ ι) (hN : NormFormulaAlong ℂ ι hfin)
+    (N : ℕ) [NeZero N]
+    (hcyc : IsAddCyclic (pointMapOfPushforward ι hι hfin hN).ker)
+    (hcard : Nat.card (pointMapOfPushforward ι hι hfin hN).ker = N) :
+    ∃ β : ℂˣ, ((L'.scale β).lattice : Set ℂ) ⊆ L.lattice ∧
+      PeriodPair.sublatticeIndex L (L'.scale β) = N ∧
+      IsAddCyclic (PeriodPair.sublatticeQuotient L (L'.scale β)) := by
+  have hH2 : ModularCurve.KwD5BetweenCurvesHoloLift := by
+    intro L L' _ _ _ _ _ _ _ _ ι hι hfin
+    obtain ⟨F, hF, hF0, hFz⟩ :=
+      PeriodPair.exists_differentiable_toPoint_comp_eq_pointMapOfPushforward_toPoint L L'
+        L.kw_discriminantNeZero L'.kw_discriminantNeZero ι hι hfin (normFormulaAlong_of_elliptic ι
+          hfin)
+    refine ⟨F, hF, hF0, fun z => ?_⟩
+    rw [PeriodPair.kw_toPointHom_apply, PeriodPair.kw_toPointHom_apply]
+    exact hFz z
+  have hID : ModularCurve.KwD5BetweenCurvesIndexDual := by
+    intro L L' _ _ _ _ _ _ _ _ α ψ hψ
+    refine PeriodPair.exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker L L'
+      L.kw_discriminantNeZero L'.kw_discriminantNeZero α ψ (fun z => ?_)
+    have h := hψ z
+    rw [PeriodPair.kw_toPointHom_apply, PeriodPair.kw_toPointHom_apply] at h
+    exact h
+  exact ModularCurve.kw_surgehgf4_hscd_pointHomSublatticeCyc_of_three hH2 hID
+    ModularCurve.kw_surgehgf4_kqe_proved L L' ι hι hfin N hcyc hcard
+
+end
+end S_OVERLONG_96bd748a
+end P2MW
+export
+  P2MW.S_OVERLONG_96bd748a
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+theorem
+  PeriodPair.exists_scale_lattice_subset_and_sublatticeIndex_eq_and_isAddCyclic_sublatticeQuotient
+    (L L' : PeriodPair) [L.weierstrassCurve.IsElliptic] [L'.weierstrassCurve.IsElliptic]
+    [GenusOnePlaceGate L.weierstrassCurve.toAffine]
+    [GenusOnePlaceGate.IsCentred L.weierstrassCurve.toAffine]
+    [AbelTheorem L.weierstrassCurve.toAffine]
+    [GenusOnePlaceGate L'.weierstrassCurve.toAffine]
+    [GenusOnePlaceGate.IsCentred L'.weierstrassCurve.toAffine]
+    [AbelTheorem L'.weierstrassCurve.toAffine]
+    (ι : L'.weierstrassCurve.toAffine.FunctionField →ₐ[ℂ] L.weierstrassCurve.toAffine.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong ℂ ι) (hN : NormFormulaAlong ℂ ι hfin)
+    (N : ℕ) [NeZero N]
+    (hcyc : IsAddCyclic (pointMapOfPushforward ι hι hfin hN).ker)
+    (hcard : Nat.card (pointMapOfPushforward ι hι hfin hN).ker = N) :
+    ∃ β : ℂˣ, ((L'.scale β).lattice : Set ℂ) ⊆ L.lattice ∧
+      PeriodPair.sublatticeIndex L (L'.scale β) = N ∧
+      IsAddCyclic (PeriodPair.sublatticeQuotient L (L'.scale β)) :=
+  solution L L' ι hι hfin hN N hcyc hcard
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.lean
new file mode 100644
index 0000000000..2c7b692942
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.lean
@@ -0,0 +1,867 @@
+/-
+Based on Prove2Me node PeriodPair.exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker
+(a357185c-bcec-50d9-a623-43e9133224df) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission dc38fb07-6c13-5403-b97b-d22713546f4a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_PeriodPair_Uniformization
+
+import Mathlib.Algebra.Module.ZLattice.Covolume
+import Mathlib.FieldTheory.IsAlgClosed.Basic
+import Mathlib.LinearAlgebra.FreeModule.ModN
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_discriminant_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_isUniformization_toPoint
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Dual homothety for a homomorphism of lattice curves
+
+Theorem statement: `PeriodPair.exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker`
+(`a357185c-bcec-50d9-a623-43e9133224df`), by Claude, 2026-09-05.
+
+Proof: submission `dc38fb07-6c13-5403-b97b-d22713546f4a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ and $L'$ be period pairs, each given by two $\mathbb{R}$-independent complex periods
+$\omega_1,\omega_2$ spanning a lattice in $\mathbb{C}$, and assume $g_2(L)^3 - 27\,g_3(L)^2 \neq 0$
+and $g_2(L')^3 - 27\,g_3(L')^2 \neq 0$, so that the associated Weierstrass curves $E_L :
+a_1=a_2=a_3=0$, $a_4 = -g_2(L)/4$, $a_6 = -g_3(L)/4$ and $E_{L'}$ (likewise from $g_2(L'),g_3(L')$)
+have nonvanishing discriminant and the uniformising maps $\Phi_L,\Phi_{L'}\colon \mathbb{C} \to
+E(\mathbb{C})$ are defined, sending each lattice point to the zero point and each $z$ outside the
+lattice to the affine point with coordinates given by the Weierstrass functions of the respective
+lattice. Let $\alpha$ be a unit of $\mathbb{C}$ and let $\psi\colon E_L(\mathbb{C}) \to
+E_{L'}(\mathbb{C})$ be a homomorphism of the additive point groups satisfying $\Phi_{L'}(\alpha z) =
+\psi(\Phi_L(z))$ for every $z \in \mathbb{C}$. Then there exists a unit $\beta$ of $\mathbb{C}$ such
+that the lattice of the scaled period pair $L'$ with periods $\beta\omega_1(L'), \beta\omega_2(L')$
+is contained, as a subset of $\mathbb{C}$, in the lattice of $L$, and the index of that scaled
+lattice as a subgroup of the lattice of $L$ equals the cardinality of the kernel of $\psi$ (both
+being $0$ in the infinite case, by the conventions for subgroup index and `Nat.card`).
+
+This is the dual-isogeny direction of the dictionary between homomorphisms of complex tori and
+homotheties between lattices: a homomorphism of the point groups lifting $z \mapsto \alpha z$
+produces a homothety $\beta\Lambda' \subseteq \Lambda$ whose index matches the degree $\#\ker\psi$.
+It feeds into
+[`PeriodPair.exists_scale_lattice_subset_and_sublatticeIndex_eq_and_isAddCyclic_sublatticeQuotient`]
+(thm.html#PeriodPair.
+exists_scale_lattice_subset_and_sublatticeIndex_eq_and_isAddCyclic_sublatticeQuotient),
+where the quotient is in addition shown to be cyclic.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker
+
+
+namespace PeriodPair
+p2m_export "PeriodPair" "lattice ω₁ mk latticeEquivProd g₃ derivWeierstrassP_sq ω₂ G g₂ \
+  weierstrassCurve weierstrassCurve_Δ weierstrassCurve_c₄ equation_weierstrassP DiscriminantNeZero \
+  toPoint toPoint_of_mem toPoint_zero IsUniformization jLattice JSurjective ofTau scale_indep \
+  scale sublatticeIndex discriminant_ne_zero isUniformization_toPoint"
+p2m_open "PeriodPair"
+
+private theorem _root_.PeriodPair.kw_toPoint_add (L : PeriodPair) (hD : L.DiscriminantNeZero)
+    (z w : ℂ) :
+    L.toPoint hD (z + w) = L.toPoint hD z + L.toPoint hD w :=
+  (PeriodPair.isUniformization_toPoint L hD).1 z w
+p2m_export "PeriodPair" "kw_toPoint_add"
+
+private theorem _root_.PeriodPair.kw_isUniformization (L : PeriodPair) :
+    L.IsUniformization L.discriminant_ne_zero :=
+  PeriodPair.isUniformization_toPoint L _
+p2m_export "PeriodPair" "kw_isUniformization"
+end PeriodPair
+
+namespace Complex
+p2m_export "Complex" "re lift finrank_real_complex arg exists exp mk ext I"
+end Complex
+namespace Filter
+p2m_export "Filter" "ker mk cocountable mem_ker mem_map unique map"
+end Filter
+namespace Module
+p2m_export "Module" "Injective equiv Finite.equiv finrank Free mk Dual Free.of_equiv End \
+  restrictScalars"
+end Module
+namespace PeriodPair
+p2m_export "PeriodPair" "lattice ω₁ mk latticeEquivProd g₃ derivWeierstrassP_sq ω₂ G g₂ \
+  weierstrassCurve weierstrassCurve_Δ weierstrassCurve_c₄ equation_weierstrassP DiscriminantNeZero \
+  toPoint toPoint_of_mem toPoint_zero IsUniformization jLattice JSurjective ofTau scale_indep \
+  scale sublatticeIndex discriminant_ne_zero isUniformization_toPoint"
+end PeriodPair
+namespace Polynomial
+p2m_export "Polynomial" "C X unique aeval ext_iff degree factor map roots sum infinite reverse \
+  nontrivial flt coe_zero module coe_add div mod ext content ring lifts restriction"
+end Polynomial
+namespace Set
+p2m_export "Set" "image ext unit mem_singleton_iff mem_image integer mem_insert_iff inclusion range"
+end Set
+namespace UpperHalfPlane
+p2m_export "UpperHalfPlane" "σ ne_zero I J mk coe_mk re"
+end UpperHalfPlane
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine a₃ a₁ map mk a₄ Jacobian a₂ a₆ exists_variableChange_of_j_eq \
+  reduction toAffine Δ c₄ j"
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine a₃ a₁ map mk a₄ Jacobian a₂ a₆ exists_variableChange_of_j_eq \
+  reduction toAffine Δ c₄ j"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "map Point polynomial"
+end WeierstrassCurve.Affine
+
+section
+
+p2m_open "Complex \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.Complex Filter \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.Filter Set \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.Set"
+
+p2m_open_scoped "PeriodPair \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.PeriodPair"
+
+namespace PeriodPair
+p2m_export "PeriodPair" "lattice ω₁ mk latticeEquivProd g₃ derivWeierstrassP_sq ω₂ G g₂ \
+  weierstrassCurve weierstrassCurve_Δ weierstrassCurve_c₄ equation_weierstrassP DiscriminantNeZero \
+  toPoint toPoint_of_mem toPoint_zero IsUniformization jLattice JSurjective ofTau scale_indep \
+  scale sublatticeIndex discriminant_ne_zero isUniformization_toPoint"
+end PeriodPair
+
+namespace Projectivization
+p2m_export "Projectivization" "mk map card"
+end Projectivization
+end
+
+
+section
+
+
+noncomputable section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.WeierstrassCurv\
+  e \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.AlgebraicCurve \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.ModularCurve"
+
+namespace ModularCurve
+
+section LatticeQuotient
+
+variable {V : Type*} [AddCommGroup V] [DivisibleBy V ℤ] [NoZeroSMulDivisors ℤ V]
+
+def divNHom (n : ℤ) (hn : n ≠ 0) : V →+ V where
+  toFun v := DivisibleBy.div v n
+  map_zero' := smul_right_injective V hn (by
+    change n • DivisibleBy.div (0 : V) n = n • 0
+    rw [DivisibleBy.div_cancel _ hn, smul_zero])
+  map_add' a b := smul_right_injective V hn (by
+    change n • DivisibleBy.div (a + b) n = n • (DivisibleBy.div a n + DivisibleBy.div b n)
+    rw [smul_add, DivisibleBy.div_cancel _ hn, DivisibleBy.div_cancel _ hn,
+      DivisibleBy.div_cancel _ hn])
+
+@[scoped simp] theorem smul_divNHom (n : ℤ) (hn : n ≠ 0) (v : V) :
+    n • divNHom n hn v = v :=
+  DivisibleBy.div_cancel v hn
+
+theorem divNHom_smul (n : ℤ) (hn : n ≠ 0) (v : V) :
+    divNHom n hn (n • v) = v :=
+  smul_right_injective V hn
+    (show n • divNHom n hn (n • v) = n • v from smul_divNHom n hn (n • v))
+
+variable (Λ : AddSubgroup V) {n : ℕ}
+
+def latticeDivQuot (hn : (n : ℤ) ≠ 0) :
+    ↥Λ →+ Submodule.torsionBy ℤ (V ⧸ Λ) (n : ℤ) where
+  toFun w := ⟨QuotientAddGroup.mk (divNHom (n : ℤ) hn (w : V)), by
+    rw [Submodule.mem_torsionBy_iff]
+    change (n : ℤ) • (QuotientAddGroup.mk (divNHom (n : ℤ) hn (w : V)) : V ⧸ Λ) = 0
+    rw [← QuotientAddGroup.mk_zsmul, smul_divNHom]
+    exact (QuotientAddGroup.eq_zero_iff _).mpr w.2⟩
+  map_zero' := by
+    apply Subtype.ext
+    change (QuotientAddGroup.mk (divNHom (n : ℤ) hn ((0 : ↥Λ) : V)) : V ⧸ Λ) = 0
+    simp
+  map_add' a b := by
+    apply Subtype.ext
+    change (QuotientAddGroup.mk (divNHom (n : ℤ) hn (((a + b : ↥Λ)) : V)) : V ⧸ Λ)
+        = QuotientAddGroup.mk (divNHom (n : ℤ) hn (a : V))
+          + QuotientAddGroup.mk (divNHom (n : ℤ) hn (b : V))
+    push_cast
+    rw [map_add, QuotientAddGroup.mk_add]
+
+@[scoped simp] theorem coe_latticeDivQuot (hn : (n : ℤ) ≠ 0) (w : ↥Λ) :
+    ((latticeDivQuot Λ hn w : Submodule.torsionBy ℤ (V ⧸ Λ) (n : ℤ)) : V ⧸ Λ)
+      = QuotientAddGroup.mk (divNHom (n : ℤ) hn (w : V)) :=
+  rfl
+
+theorem latticeDivQuot_surjective (hn : (n : ℤ) ≠ 0) :
+    Function.Surjective (latticeDivQuot Λ hn) := by
+  rintro ⟨x, hx⟩
+  rw [Submodule.mem_torsionBy_iff] at hx
+  obtain ⟨v, rfl⟩ := QuotientAddGroup.mk_surjective x
+  have hvΛ : (n : ℤ) • v ∈ Λ := by
+    rw [← QuotientAddGroup.eq_zero_iff, QuotientAddGroup.mk_zsmul]
+    exact hx
+  refine ⟨⟨(n : ℤ) • v, hvΛ⟩, Subtype.ext ?_⟩
+  rw [coe_latticeDivQuot]
+  change (QuotientAddGroup.mk (divNHom (n : ℤ) hn ((n : ℤ) • v)) : V ⧸ Λ)
+      = QuotientAddGroup.mk v
+  rw [divNHom_smul]
+
+theorem mem_ker_latticeDivQuot (hn : (n : ℤ) ≠ 0) (w : ↥Λ) :
+    w ∈ (latticeDivQuot Λ hn).ker
+      ↔ w ∈ LinearMap.range (LinearMap.lsmul ℤ ↥Λ (n : ℤ)) := by
+  constructor
+  · intro hker
+    rw [AddMonoidHom.mem_ker] at hker
+    have hcoe : ((latticeDivQuot Λ hn w :
+        Submodule.torsionBy ℤ (V ⧸ Λ) (n : ℤ)) : V ⧸ Λ) = 0 := by
+      rw [hker]; rfl
+    rw [coe_latticeDivQuot, QuotientAddGroup.eq_zero_iff] at hcoe
+    refine ⟨⟨divNHom (n : ℤ) hn (w : V), hcoe⟩, ?_⟩
+    apply Subtype.ext
+    change (n : ℤ) • divNHom (n : ℤ) hn (w : V) = (w : V)
+    exact smul_divNHom (n : ℤ) hn (w : V)
+  · rintro ⟨μ, rfl⟩
+    rw [AddMonoidHom.mem_ker]
+    apply Subtype.ext
+    rw [coe_latticeDivQuot]
+    change (QuotientAddGroup.mk (divNHom (n : ℤ) hn ((n : ℤ) • (μ : V))) : V ⧸ Λ) = 0
+    rw [divNHom_smul, QuotientAddGroup.eq_zero_iff]
+    exact μ.2
+
+theorem ker_latticeDivQuot (hn : (n : ℤ) ≠ 0) :
+    (latticeDivQuot Λ hn).ker
+      = (LinearMap.range (LinearMap.lsmul ℤ ↥Λ (n : ℤ))).toAddSubgroup := by
+  ext w
+  exact mem_ker_latticeDivQuot Λ hn w
+
+def latticeQuotTorsionEquiv (hn : (n : ℤ) ≠ 0) :
+    ModN ↥Λ n ≃+ Submodule.torsionBy ℤ (V ⧸ Λ) (n : ℤ) := by
+  refine AddEquiv.ofBijective
+    (QuotientAddGroup.lift _ (latticeDivQuot Λ hn) ?_) ⟨?_, ?_⟩
+  · intro w hw
+    have : w ∈ (latticeDivQuot Λ hn).ker := by
+      rw [ker_latticeDivQuot]; exact hw
+    exact this
+  · rintro ⟨a⟩ ⟨b⟩ hab
+    refine (Submodule.Quotient.eq _).mpr ?_
+    have hker : a - b ∈ (latticeDivQuot Λ hn).ker := by
+      rw [AddMonoidHom.mem_ker, map_sub]
+      exact sub_eq_zero.mpr hab
+    rwa [ker_latticeDivQuot] at hker
+  · intro y
+    obtain ⟨w, hw⟩ := latticeDivQuot_surjective Λ hn y
+    exact ⟨QuotientAddGroup.mk w, hw⟩
+
+theorem card_torsionBy_latticeQuotient [Module.Free ℤ ↥Λ] [Module.Finite ℤ ↥Λ]
+    (hn : (n : ℤ) ≠ 0) :
+    Nat.card (Submodule.torsionBy ℤ (V ⧸ Λ) (n : ℤ)) = n ^ Module.finrank ℤ ↥Λ := by
+  have : NeZero n := ⟨by exact_mod_cast hn⟩
+  rw [← Nat.card_congr (latticeQuotTorsionEquiv Λ hn).toEquiv, ModN.natCard_eq]
+
+end LatticeQuotient
+
+end ModularCurve
+end
+end
+
+
+noncomputable section
+
+p2m_open_scoped "PeriodPair \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.PeriodPair"
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.WeierstrassCurv\
+  e WeierstrassCurve.Affine \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.WeierstrassCurve\
+  .Affine \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.ModularCurve \
+  Polynomial \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.Polynomial"
+
+namespace PeriodPair
+p2m_export "PeriodPair" "lattice ω₁ mk latticeEquivProd g₃ derivWeierstrassP_sq ω₂ G g₂ \
+  weierstrassCurve weierstrassCurve_Δ weierstrassCurve_c₄ equation_weierstrassP DiscriminantNeZero \
+  toPoint toPoint_of_mem toPoint_zero IsUniformization jLattice JSurjective ofTau scale_indep \
+  scale sublatticeIndex discriminant_ne_zero isUniformization_toPoint"
+p2m_open "PeriodPair"
+
+variable (L : PeriodPair)
+
+private def _root_.PeriodPair.kw_toPointHom : ℂ →+ (L.weierstrassCurve.toAffine).Point where
+  toFun := L.toPoint L.discriminant_ne_zero
+  map_zero' := L.toPoint_zero L.discriminant_ne_zero
+  map_add' := L.kw_toPoint_add L.discriminant_ne_zero
+
+p2m_export "PeriodPair" "kw_toPointHom"
+private theorem _root_.PeriodPair.kw_toPointHom_apply (z : ℂ) :
+    L.kw_toPointHom z = L.toPoint L.discriminant_ne_zero z := rfl
+
+p2m_export "PeriodPair" "kw_toPointHom_apply"
+
+private theorem _root_.PeriodPair.kw_ker_toPointHom :
+    L.kw_toPointHom.ker = L.lattice.toAddSubgroup := by
+  ext z
+  constructor
+  · exact fun hz => (L.kw_isUniformization).2.2 z hz
+  · intro hz
+    exact L.toPoint_of_mem L.discriminant_ne_zero hz
+
+p2m_export "PeriodPair" "kw_ker_toPointHom"
+end PeriodPair
+end
+
+
+noncomputable section
+
+p2m_open_scoped "PeriodPair \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.PeriodPair"
+
+namespace PeriodPair
+p2m_export "PeriodPair" "lattice ω₁ mk latticeEquivProd g₃ derivWeierstrassP_sq ω₂ G g₂ \
+  weierstrassCurve weierstrassCurve_Δ weierstrassCurve_c₄ equation_weierstrassP DiscriminantNeZero \
+  toPoint toPoint_of_mem toPoint_zero IsUniformization jLattice JSurjective ofTau scale_indep \
+  scale sublatticeIndex discriminant_ne_zero isUniformization_toPoint"
+p2m_open "PeriodPair"
+
+variable (L : PeriodPair)
+
+section Scale
+
+variable (α : ℂˣ)
+
+private def mulLeftR (a : ℂ) : ℂ →ₗ[ℝ] ℂ := Algebra.lmul ℝ ℂ a
+
+@[scoped simp] private theorem mulLeftR_apply (a z : ℂ) : mulLeftR a z = a * z := rfl
+
+private theorem mulLeftR_injective {a : ℂ} (ha : a ≠ 0) :
+    Function.Injective (mulLeftR a) := fun _ _ h => by
+  simpa using mul_left_cancel₀ ha h
+
+private def mulLeftZ (a : ℂ) : ℂ →ₗ[ℤ] ℂ := (mulLeftR a).restrictScalars ℤ
+
+@[scoped simp] private theorem mulLeftZ_apply (a z : ℂ) : mulLeftZ a z = a * z := rfl
+
+theorem scale_lattice : (L.scale α).lattice = Submodule.map (mulLeftZ (α : ℂ)) L.lattice := by
+  unfold lattice scale
+  rw [Submodule.map_span]
+  congr 1
+  ext z
+  simp only [Set.mem_insert_iff, Set.mem_singleton_iff, Set.mem_image, mulLeftZ_apply]
+  constructor
+  · rintro (rfl | rfl)
+    · exact ⟨L.ω₁, Or.inl rfl, rfl⟩
+    · exact ⟨L.ω₂, Or.inr rfl, rfl⟩
+  · rintro ⟨w, hw | hw, rfl⟩ <;> simp [hw]
+
+private theorem _root_.PeriodPair.mem_scale_lattice_iff {z : ℂ} :
+    z ∈ (L.scale α).lattice ↔ ∃ l ∈ L.lattice, z = (α : ℂ) * l := by
+  rw [scale_lattice, Submodule.mem_map]; simp only [mulLeftZ_apply]; tauto
+
+p2m_export "PeriodPair" "mem_scale_lattice_iff"
+end Scale
+
+
+
+section Gates
+
+theorem gate_scale_mul (α β : ℂˣ) :
+    ((L.scale α).scale β).lattice = (L.scale (β * α)).lattice := by
+  ext z
+  simp only [mem_scale_lattice_iff, Units.val_mul]
+  constructor
+  · rintro ⟨-, ⟨l, hl, rfl⟩, rfl⟩; exact ⟨l, hl, (mul_assoc _ _ _).symm⟩
+  · rintro ⟨l, hl, rfl⟩; exact ⟨(α : ℂ) * l, ⟨l, hl, rfl⟩, mul_assoc _ _ _⟩
+
+end Gates
+end PeriodPair
+end
+
+section
+
+
+noncomputable section
+
+p2m_open "Module \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.Module"
+
+namespace ModularCurve
+
+variable {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+
+scoped instance (priority := low) kwRealModuleDivisibleByInt : DivisibleBy E ℤ where
+  div v n := ((n : ℝ)⁻¹) • v
+  div_zero v := by simp
+  div_cancel {n} v hn := by
+    have hn' : (n : ℝ) ≠ 0 := Int.cast_ne_zero.mpr hn
+    calc n • ((n : ℝ)⁻¹ • v) = (n : ℝ) • ((n : ℝ)⁻¹ • v) := (Int.cast_smul_eq_zsmul ℝ n _).symm
+      _ = v := by rw [smul_smul, mul_inv_cancel₀ hn', one_smul]
+
+scoped instance (priority := low) kwRealModuleNoZeroSMulDivisorsInt : NoZeroSMulDivisors ℤ E where
+  eq_zero_or_eq_zero_of_smul_eq_zero {n} {v} h := by
+    rcases eq_or_ne n 0 with rfl | hn
+    · exact Or.inl rfl
+    · refine Or.inr ?_
+      have h' : (n : ℝ) • v = 0 := by rwa [Int.cast_smul_eq_zsmul ℝ]
+      have hn' : (n : ℝ) ≠ 0 := Int.cast_ne_zero.mpr hn
+      exact (smul_eq_zero.mp h').resolve_left hn'
+
+variable [FiniteDimensional ℝ E] [ProperSpace E]
+variable (L : Submodule ℤ E) [DiscreteTopology L] [IsZLattice ℝ L]
+
+def kwLatticeCoeAddEquiv : L ≃+ L.toAddSubgroup where
+  toFun x := ⟨(x : E), x.2⟩
+  invFun x := ⟨(x : E), x.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  map_add' _ _ := rfl
+
+scoped instance kwLatticeToAddSubgroupFree : Module.Free ℤ (L.toAddSubgroup) :=
+  have : Module.Free ℤ L := ZLattice.module_free ℝ L
+  Module.Free.of_equiv (kwLatticeCoeAddEquiv L).toIntLinearEquiv
+
+scoped instance kwLatticeToAddSubgroupFinite : Module.Finite ℤ (L.toAddSubgroup) :=
+  have : Module.Finite ℤ L := ZLattice.module_finite ℝ L
+  Module.Finite.equiv (kwLatticeCoeAddEquiv L).toIntLinearEquiv
+
+theorem kw_card_torsionBy_zlatticeQuotient {n : ℕ} (hn : (n : ℤ) ≠ 0) :
+    Nat.card (Submodule.torsionBy ℤ (E ⧸ L.toAddSubgroup) (n : ℤ)) =
+      n ^ Module.finrank ℤ L := by
+  have h := ModularCurve.card_torsionBy_latticeQuotient (V := E) (L.toAddSubgroup) hn
+  rw [h]
+  exact congrArg (fun k => n ^ k)
+    (LinearEquiv.finrank_eq (kwLatticeCoeAddEquiv L).toIntLinearEquiv).symm
+
+theorem kw_card_torsionBy_zlatticeQuotient_finrank_real
+    {n : ℕ} (hn : (n : ℤ) ≠ 0) :
+    Nat.card (Submodule.torsionBy ℤ (E ⧸ L.toAddSubgroup) (n : ℤ)) =
+      n ^ Module.finrank ℝ E := by
+  rw [kw_card_torsionBy_zlatticeQuotient L hn, ZLattice.rank ℝ L]
+
+end ModularCurve
+end
+end
+
+
+noncomputable section
+
+p2m_open_scoped "PeriodPair \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.PeriodPair \
+  UpperHalfPlane \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.UpperHalfPlane"
+p2m_open "PeriodPair \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.PeriodPair \
+  Polynomial \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.Polynomial"
+
+namespace ModularCurve
+
+theorem kw_scale_lattice_toAddSubgroup (L : PeriodPair) (α : ℂˣ) :
+    (L.scale α).lattice.toAddSubgroup
+      = L.lattice.toAddSubgroup.map (AddMonoidHom.mulLeft (α : ℂ)) := by
+  ext z
+  simp only [Submodule.mem_toAddSubgroup, mem_scale_lattice_iff, AddSubgroup.mem_map,
+    AddMonoidHom.coe_mulLeft]
+  exact ⟨fun ⟨l, hl, hz⟩ => ⟨l, hl, hz.symm⟩, fun ⟨l, hl, hz⟩ => ⟨l, hl, hz.symm⟩⟩
+
+theorem kwSublatticeIndex_scale (L L' : PeriodPair) (α : ℂˣ) :
+    PeriodPair.sublatticeIndex (L.scale α) (L'.scale α) = PeriodPair.sublatticeIndex L L' := by
+  have hinj : Function.Injective (AddMonoidHom.mulLeft (α : ℂ)) :=
+    fun _ _ h => mul_left_cancel₀ α.ne_zero h
+  change AddSubgroup.relIndex _ _ = AddSubgroup.relIndex _ _
+  rw [kw_scale_lattice_toAddSubgroup, kw_scale_lattice_toAddSubgroup,
+    AddSubgroup.relIndex_map_map_of_injective _ _ hinj]
+
+end ModularCurve
+end
+
+section
+
+
+noncomputable section
+
+p2m_open "P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.ModularC\
+  urve WeierstrassCurve \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.WeierstrassCurv\
+  e WeierstrassCurve.Affine \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.WeierstrassCurve\
+  .Affine Polynomial \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.Polynomial \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.AlgebraicCurve \
+  PeriodPair \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.PeriodPair"
+
+namespace ModularCurve
+
+universe u
+
+attribute [local instance] Classical.propDecidable
+
+
+section IndexDualMint
+
+def KwD5BetweenCurvesIndexDual : Prop :=
+  ∀ (L L' : PeriodPair)
+    [L.weierstrassCurve.IsElliptic] [L'.weierstrassCurve.IsElliptic]
+    (α : ℂˣ)
+    (ψ : L.weierstrassCurve.toAffine.Point →+ L'.weierstrassCurve.toAffine.Point),
+    (∀ z, L'.kw_toPointHom ((α : ℂ) * z) = ψ (L.kw_toPointHom z)) →
+    ∃ (β : ℂˣ), ((L'.scale β).lattice : Set ℂ) ⊆ L.lattice ∧
+      PeriodPair.sublatticeIndex L (L'.scale β) = Nat.card ψ.ker
+
+end IndexDualMint
+end ModularCurve
+end
+end
+
+section
+
+
+noncomputable section
+
+p2m_open "P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.ModularC\
+  urve PeriodPair \
+  P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker.PeriodPair"
+
+namespace ModularCurve
+
+section BetweenCurves
+
+variable (L L' : PeriodPair)
+  [L.weierstrassCurve.IsElliptic] [L'.weierstrassCurve.IsElliptic]
+  (α : ℂˣ)
+  (ψ : L.weierstrassCurve.toAffine.Point →+ L'.weierstrassCurve.toAffine.Point)
+  (hint : ∀ z, L'.kw_toPointHom ((α : ℂ) * z) = ψ (L.kw_toPointHom z))
+
+include hint in
+def kw_surgehgf4_hID_kerIndexHom : L'.lattice.toAddSubgroup →+ ψ.ker where
+  toFun l' := ⟨L.kw_toPointHom ((α : ℂ)⁻¹ * (l' : ℂ)), by
+    rw [AddMonoidHom.mem_ker, ← hint ((α : ℂ)⁻¹ * (l' : ℂ)),
+      mul_inv_cancel_left₀ α.ne_zero]
+    have hl'0 : L'.kw_toPointHom (l' : ℂ) = 0 := by
+      rw [← AddMonoidHom.mem_ker, L'.kw_ker_toPointHom]; exact l'.2
+    exact hl'0⟩
+  map_zero' := Subtype.ext <| by simp
+  map_add' l'₁ l'₂ := Subtype.ext <| by
+    push_cast; rw [mul_add]; exact map_add L.kw_toPointHom _ _
+
+include hint in
+omit [L.weierstrassCurve.IsElliptic] [L'.weierstrassCurve.IsElliptic] in
+theorem kw_surgehgf4_hID_kerIndexHom_apply (l' : L'.lattice.toAddSubgroup) :
+    (kw_surgehgf4_hID_kerIndexHom L L' α ψ hint l' : L.weierstrassCurve.toAffine.Point)
+      = L.kw_toPointHom ((α : ℂ)⁻¹ * (l' : ℂ)) := rfl
+
+include hint in
+omit [L.weierstrassCurve.IsElliptic] [L'.weierstrassCurve.IsElliptic] in
+theorem kw_surgehgf4_hID_scale_subset :
+    ((L.scale α).lattice : Set ℂ) ⊆ L'.lattice := by
+  intro z hz
+  rw [SetLike.mem_coe, L.mem_scale_lattice_iff] at hz
+  obtain ⟨l, hl, rfl⟩ := hz
+  rw [SetLike.mem_coe, ← Submodule.mem_toAddSubgroup, ← L'.kw_ker_toPointHom,
+    AddMonoidHom.mem_ker, hint]
+  have hl0 : L.kw_toPointHom l = 0 := by
+    rw [← AddMonoidHom.mem_ker, L.kw_ker_toPointHom]; exact hl
+  rw [hl0, _root_.map_zero]
+
+include hint in
+omit [L.weierstrassCurve.IsElliptic] [L'.weierstrassCurve.IsElliptic] in
+theorem kw_surgehgf4_hID_kerIndexHom_surjective :
+    Function.Surjective (kw_surgehgf4_hID_kerIndexHom L L' α ψ hint) := by
+  rintro ⟨P, hP⟩
+  obtain ⟨z, hz⟩ := (L.kw_isUniformization).2.1 P
+  have hαz : (α : ℂ) * z ∈ L'.lattice.toAddSubgroup := by
+    rw [← L'.kw_ker_toPointHom, AddMonoidHom.mem_ker, hint, L.kw_toPointHom_apply, hz]
+    exact hP
+  exact ⟨⟨(α : ℂ) * z, hαz⟩, Subtype.ext <| by
+    simp only [kw_surgehgf4_hID_kerIndexHom_apply, inv_mul_cancel_left₀ α.ne_zero,
+      L.kw_toPointHom_apply, hz]⟩
+
+include hint in
+omit [L.weierstrassCurve.IsElliptic] [L'.weierstrassCurve.IsElliptic] in
+theorem kw_surgehgf4_hID_ker_kerIndexHom :
+    (kw_surgehgf4_hID_kerIndexHom L L' α ψ hint).ker
+      = (L.scale α).lattice.toAddSubgroup.addSubgroupOf L'.lattice.toAddSubgroup := by
+  ext ⟨l', hl'⟩
+  rw [AddMonoidHom.mem_ker, AddSubgroup.mem_addSubgroupOf]
+  constructor
+  · intro h
+    rw [Submodule.mem_toAddSubgroup, L.mem_scale_lattice_iff]
+    refine ⟨(α : ℂ)⁻¹ * l', ?_, (mul_inv_cancel_left₀ α.ne_zero l').symm⟩
+    have h0 : L.kw_toPointHom ((α : ℂ)⁻¹ * l') = 0 := Subtype.ext_iff.mp h
+    rwa [← AddMonoidHom.mem_ker, L.kw_ker_toPointHom, Submodule.mem_toAddSubgroup] at h0
+  · intro h
+    rw [Submodule.mem_toAddSubgroup, L.mem_scale_lattice_iff] at h
+    obtain ⟨v, hv, hvl'⟩ := h
+    apply Subtype.ext
+    change L.kw_toPointHom ((α : ℂ)⁻¹ * l') = 0
+    rw [show (l' : ℂ) = (α : ℂ) * v from hvl', inv_mul_cancel_left₀ α.ne_zero,
+      ← AddMonoidHom.mem_ker, L.kw_ker_toPointHom]
+    exact hv
+
+include hint in
+omit [L.weierstrassCurve.IsElliptic] [L'.weierstrassCurve.IsElliptic] in
+theorem kw_surgehgf4_hID_forwardIndex_eq_card_ker :
+    PeriodPair.sublatticeIndex L' (L.scale α) = Nat.card ψ.ker := by
+  unfold PeriodPair.sublatticeIndex
+  rw [← kw_surgehgf4_hID_ker_kerIndexHom L L' α ψ hint, ← Nat.card_congr
+    (QuotientAddGroup.liftEquiv _
+      (kw_surgehgf4_hID_kerIndexHom_surjective L L' α ψ hint) rfl).toEquiv]
+  rfl
+
+include hint in
+omit [L.weierstrassCurve.IsElliptic] [L'.weierstrassCurve.IsElliptic] in
+theorem kw_surgehgf4_hID_card_smul_subset :
+    ∀ l' ∈ L'.lattice, (Nat.card ψ.ker : ℂ) * l' ∈ (L.scale α).lattice := by
+  intro l' hl'
+  set N := Nat.card ψ.ker with hNdef
+  have hidx : ((L.scale α).lattice.toAddSubgroup.addSubgroupOf
+      L'.lattice.toAddSubgroup).index = N := by
+    have h := kw_surgehgf4_hID_forwardIndex_eq_card_ker L L' α ψ hint
+    unfold PeriodPair.sublatticeIndex at h; exact h
+  set H := (L.scale α).lattice.toAddSubgroup.addSubgroupOf L'.lattice.toAddSubgroup with hHdef
+  have hmem : N • (⟨l', hl'⟩ : L'.lattice.toAddSubgroup) ∈ H := hidx ▸ H.nsmul_index_mem _
+  rw [hHdef, AddSubgroup.mem_addSubgroupOf, Submodule.mem_toAddSubgroup] at hmem
+  have heq : ((N • (⟨l', hl'⟩ : L'.lattice.toAddSubgroup) : L'.lattice.toAddSubgroup) : ℂ)
+      = (Nat.card ψ.ker : ℂ) * l' := by
+    rw [AddSubmonoidClass.coe_nsmul, nsmul_eq_mul, hNdef]
+  rw [← heq]; exact hmem
+
+end BetweenCurves
+
+noncomputable def kw_surgehgf4_hID_dualUnit {X Y : Type*} [AddGroup X] [AddGroup Y]
+    (α : ℂˣ) (ψ : X →+ Y) (hN : 0 < Nat.card ψ.ker) : ℂˣ :=
+  Units.mk0 (Nat.card ψ.ker : ℂ) (by exact_mod_cast hN.ne') * α⁻¹
+
+theorem kw_surgehgf4_hID_dualUnit_val {X Y : Type*} [AddGroup X] [AddGroup Y]
+    (α : ℂˣ) (ψ : X →+ Y) (hN : 0 < Nat.card ψ.ker) :
+    (kw_surgehgf4_hID_dualUnit α ψ hN : ℂ) = (Nat.card ψ.ker : ℂ) * (α : ℂ)⁻¹ := by
+  simp only [kw_surgehgf4_hID_dualUnit, Units.val_mul, Units.val_mk0,
+    Units.val_inv_eq_inv_val]
+
+section BetweenCurves
+
+variable (L L' : PeriodPair)
+  [L.weierstrassCurve.IsElliptic] [L'.weierstrassCurve.IsElliptic]
+  (α : ℂˣ)
+  (ψ : L.weierstrassCurve.toAffine.Point →+ L'.weierstrassCurve.toAffine.Point)
+  (hint : ∀ z, L'.kw_toPointHom ((α : ℂ) * z) = ψ (L.kw_toPointHom z))
+
+include hint in
+omit [L.weierstrassCurve.IsElliptic] [L'.weierstrassCurve.IsElliptic] in
+theorem kw_surgehgf4_hID_dual_subset (hN : 0 < Nat.card ψ.ker) :
+    ((L'.scale (kw_surgehgf4_hID_dualUnit α ψ hN)).lattice : Set ℂ) ⊆ L.lattice := by
+  intro z hz
+  rw [SetLike.mem_coe, L'.mem_scale_lattice_iff] at hz
+  obtain ⟨l', hl', rfl⟩ := hz
+  have hNl' := kw_surgehgf4_hID_card_smul_subset L L' α ψ hint l' hl'
+  rw [L.mem_scale_lattice_iff] at hNl'
+  obtain ⟨v, hv, hveq⟩ := hNl'
+  rw [SetLike.mem_coe, kw_surgehgf4_hID_dualUnit_val α ψ hN, mul_assoc,
+    show (Nat.card ψ.ker : ℂ) * ((α : ℂ)⁻¹ * l')
+      = (α : ℂ)⁻¹ * ((Nat.card ψ.ker : ℂ) * l') from by ring,
+    hveq, inv_mul_cancel_left₀ α.ne_zero]
+  exact hv
+
+theorem kw_surgehgf4_hID_sublatticeIndex_congr_snd {A M M' : PeriodPair}
+    (h : M.lattice = M'.lattice) :
+    PeriodPair.sublatticeIndex A M = PeriodPair.sublatticeIndex A M' := by
+  unfold PeriodPair.sublatticeIndex; rw [h]
+
+def kw_surgehgf4_hID_scaleIndexHom (M : PeriodPair) {N : ℕ} (hN : 0 < N) :
+    M.lattice.toAddSubgroup
+      →+ (Submodule.torsionBy ℤ (ℂ ⧸ M.lattice.toAddSubgroup) (N : ℤ)) where
+  toFun l := ⟨QuotientAddGroup.mk ((N : ℂ)⁻¹ * (l : ℂ)), by
+    rw [Submodule.mem_torsionBy_iff, ← QuotientAddGroup.mk_zsmul,
+      QuotientAddGroup.eq_zero_iff]
+    have hNne : (N : ℂ) ≠ 0 := by exact_mod_cast hN.ne'
+    have : (N : ℤ) • ((N : ℂ)⁻¹ * (l : ℂ)) = (l : ℂ) := by
+      rw [zsmul_eq_mul, Int.cast_natCast, mul_inv_cancel_left₀ hNne]
+    rw [this]; exact l.2⟩
+  map_zero' := Subtype.ext <| by simp
+  map_add' l₁ l₂ := Subtype.ext <| by
+    simp only [AddSubgroup.coe_add, mul_add]
+    rfl
+
+theorem kw_surgehgf4_hID_sublatticeIndex_scale_nat (M : PeriodPair)
+    {N : ℕ} (hN : 0 < N) :
+    PeriodPair.sublatticeIndex M (M.scale (Units.mk0 (N : ℂ) (by
+      exact_mod_cast hN.ne'))) = N ^ 2 := by
+  set Nu := Units.mk0 (N : ℂ) (by exact_mod_cast hN.ne') with hNudef
+  have hNuval : (Nu : ℂ) = (N : ℂ) := by rw [hNudef, Units.val_mk0]
+  have hNinv : (Nu : ℂ)⁻¹ = (N : ℂ)⁻¹ := by rw [hNuval]
+  have hsurj : Function.Surjective (kw_surgehgf4_hID_scaleIndexHom M hN) := by
+    rintro ⟨x, hx⟩
+    rw [Submodule.mem_torsionBy_iff] at hx
+    obtain ⟨z, rfl⟩ := QuotientAddGroup.mk_surjective x
+    have hNz : (N : ℂ) * z ∈ M.lattice.toAddSubgroup := by
+      have : (N : ℤ) • z ∈ M.lattice.toAddSubgroup := by
+        rw [← QuotientAddGroup.eq_zero_iff, QuotientAddGroup.mk_zsmul]; exact hx
+      simpa [zsmul_eq_mul] using this
+    refine ⟨⟨(N : ℂ) * z, hNz⟩, Subtype.ext ?_⟩
+    change QuotientAddGroup.mk ((N : ℂ)⁻¹ * ((N : ℂ) * z)) = QuotientAddGroup.mk z
+    rw [inv_mul_cancel_left₀ (by exact_mod_cast hN.ne' : (N : ℂ) ≠ 0)]
+  have hker : (kw_surgehgf4_hID_scaleIndexHom M hN).ker
+      = (M.scale Nu).lattice.toAddSubgroup.addSubgroupOf M.lattice.toAddSubgroup := by
+    ext ⟨l, hl⟩
+    rw [AddMonoidHom.mem_ker, AddSubgroup.mem_addSubgroupOf, Submodule.mem_toAddSubgroup,
+      M.mem_scale_lattice_iff]
+    constructor
+    · intro h0
+      have h0' : (N : ℂ)⁻¹ * l ∈ M.lattice.toAddSubgroup := by
+        have := Subtype.ext_iff.mp h0
+        simp only [kw_surgehgf4_hID_scaleIndexHom, AddMonoidHom.coe_mk, ZeroHom.coe_mk,
+          ZeroMemClass.coe_zero] at this
+        rwa [QuotientAddGroup.eq_zero_iff] at this
+      exact ⟨(N : ℂ)⁻¹ * l, h0',
+        by rw [hNuval, mul_inv_cancel_left₀ (by exact_mod_cast hN.ne' : (N : ℂ) ≠ 0)]⟩
+    · rintro ⟨v, hv, hvl⟩
+      apply Subtype.ext
+      change QuotientAddGroup.mk ((N : ℂ)⁻¹ * l) = 0
+      rw [QuotientAddGroup.eq_zero_iff,
+        show l = (N : ℂ) * v from hNuval ▸ hvl,
+        inv_mul_cancel_left₀ (by exact_mod_cast hN.ne' : (N : ℂ) ≠ 0)]
+      exact hv
+  have htor : Nat.card ↥(Submodule.torsionBy ℤ (ℂ ⧸ M.lattice.toAddSubgroup) (N : ℤ))
+      = N ^ 2 := by
+    rw [kw_card_torsionBy_zlatticeQuotient_finrank_real M.lattice
+      (by exact_mod_cast hN.ne' : (N : ℤ) ≠ 0), Complex.finrank_real_complex]
+  unfold PeriodPair.sublatticeIndex
+  rw [← hker, ← htor, ← Nat.card_congr
+    (QuotientAddGroup.liftEquiv _ hsurj rfl).toEquiv]
+  rfl
+
+include hint in
+omit [L.weierstrassCurve.IsElliptic] [L'.weierstrassCurve.IsElliptic] in
+theorem kw_surgehgf4_hID_card_ker_pos : 0 < Nat.card ψ.ker := by
+  rw [← kw_surgehgf4_hID_forwardIndex_eq_card_ker L L' α ψ hint]
+  refine Nat.pos_of_ne_zero ?_
+  have hle : (L.scale α).lattice ≤ L'.lattice :=
+    fun z hz => kw_surgehgf4_hID_scale_subset L L' α ψ hint hz
+  have hcov := ZLattice.covolume_div_covolume_eq_relIndex'
+    (L.scale α).lattice L'.lattice hle
+  have hpos₁ : (0 : ℝ) < ZLattice.covolume (L.scale α).lattice :=
+    ZLattice.covolume_pos (L.scale α).lattice MeasureTheory.volume
+  have hpos₂ : (0 : ℝ) < ZLattice.covolume L'.lattice :=
+    ZLattice.covolume_pos L'.lattice MeasureTheory.volume
+  have hratio : (0 : ℝ) < ZLattice.covolume (L.scale α).lattice
+      / ZLattice.covolume L'.lattice := div_pos hpos₁ hpos₂
+  intro h0
+  unfold PeriodPair.sublatticeIndex at h0
+  have h0R : ((L.scale α).lattice.toAddSubgroup.relIndex L'.lattice.toAddSubgroup : ℝ)
+      = 0 := by exact_mod_cast h0
+  rw [← hcov] at h0R
+  exact absurd h0R (ne_of_gt hratio)
+
+include hint in
+omit [L.weierstrassCurve.IsElliptic] [L'.weierstrassCurve.IsElliptic] in
+theorem kw_surgehgf4_hID_dualIndex_eq (hN : 0 < Nat.card ψ.ker) :
+    PeriodPair.sublatticeIndex L (L'.scale (kw_surgehgf4_hID_dualUnit α ψ hN))
+      = Nat.card ψ.ker := by
+  set N := Nat.card ψ.ker with hNdef
+  set β := kw_surgehgf4_hID_dualUnit α ψ hN with hβdef
+  set Nu := Units.mk0 (N : ℂ) (by exact_mod_cast hN.ne') with hNudef
+  have h1 : PeriodPair.sublatticeIndex L (L'.scale β)
+      = PeriodPair.sublatticeIndex (L.scale α) ((L'.scale β).scale α) :=
+    (kwSublatticeIndex_scale L (L'.scale β) α).symm
+  have hαβ : α * β = Nu := by
+    apply Units.ext
+    simp only [hβdef, hNudef, Units.val_mul, kw_surgehgf4_hID_dualUnit_val,
+      Units.val_mk0]
+    field_simp
+    exact_mod_cast hNdef.symm
+  have h2 : ((L'.scale β).scale α).lattice = (L'.scale Nu).lattice := by
+    rw [gate_scale_mul L' β α, hαβ]
+  have h3 : PeriodPair.sublatticeIndex (L.scale α) ((L'.scale β).scale α)
+      = PeriodPair.sublatticeIndex (L.scale α) (L'.scale Nu) :=
+    kw_surgehgf4_hID_sublatticeIndex_congr_snd h2
+  rw [h1, h3]
+  have hsub1 : ((L'.scale Nu).lattice : Set ℂ) ⊆ (L.scale α).lattice := by
+    intro z hz
+    rw [SetLike.mem_coe, L'.mem_scale_lattice_iff] at hz
+    obtain ⟨l', hl', rfl⟩ := hz
+    simp only [hNudef, Units.val_mk0]
+    exact kw_surgehgf4_hID_card_smul_subset L L' α ψ hint l' hl'
+  have hsub2 : ((L.scale α).lattice : Set ℂ) ⊆ L'.lattice :=
+    kw_surgehgf4_hID_scale_subset L L' α ψ hint
+  have htower : PeriodPair.sublatticeIndex L' (L'.scale Nu)
+      = PeriodPair.sublatticeIndex (L.scale α) (L'.scale Nu)
+        * PeriodPair.sublatticeIndex L' (L.scale α) := by
+    unfold PeriodPair.sublatticeIndex
+    have hle1 : (L'.scale Nu).lattice.toAddSubgroup ≤ (L.scale α).lattice.toAddSubgroup := by
+      intro z hz; exact hsub1 hz
+    have hle2 : (L.scale α).lattice.toAddSubgroup ≤ L'.lattice.toAddSubgroup := by
+      intro z hz; exact hsub2 hz
+    exact (AddSubgroup.relIndex_mul_relIndex _ _ _ hle1 hle2).symm
+  have hN2 : PeriodPair.sublatticeIndex L' (L'.scale Nu) = N ^ 2 :=
+    kw_surgehgf4_hID_sublatticeIndex_scale_nat L' hN
+  have hfwd : PeriodPair.sublatticeIndex L' (L.scale α) = N :=
+    kw_surgehgf4_hID_forwardIndex_eq_card_ker L L' α ψ hint
+  rw [hN2, hfwd] at htower
+  have : PeriodPair.sublatticeIndex (L.scale α) (L'.scale Nu) * N = N * N := by
+    rw [← htower]; ring
+  exact Nat.eq_of_mul_eq_mul_right hN this
+
+theorem kw_surgehgf4_hID_betweenCurvesIndexDual_proved :
+    KwD5BetweenCurvesIndexDual := by
+  intro L L' _ _ α ψ hint
+  have hN := kw_surgehgf4_hID_card_ker_pos L L' α ψ hint
+  exact ⟨kw_surgehgf4_hID_dualUnit α ψ hN,
+    kw_surgehgf4_hID_dual_subset L L' α ψ hint hN,
+    kw_surgehgf4_hID_dualIndex_eq L L' α ψ hint hN⟩
+
+end BetweenCurves
+end ModularCurve
+end
+end
+
+theorem solution (L L' : PeriodPair) (hL : L.DiscriminantNeZero) (hL' : L'.DiscriminantNeZero)
+    (α : ℂˣ)
+    (ψ : L.weierstrassCurve.toAffine.Point →+ L'.weierstrassCurve.toAffine.Point)
+    (hψ : ∀ z : ℂ, L'.toPoint hL' ((α : ℂ) * z) = ψ (L.toPoint hL z)) :
+    ∃ β : ℂˣ, ((L'.scale β).lattice : Set ℂ) ⊆ L.lattice ∧
+      PeriodPair.sublatticeIndex L (L'.scale β) = Nat.card ψ.ker := by
+  have : L.weierstrassCurve.IsElliptic :=
+    ⟨isUnit_iff_ne_zero.mpr L.discriminant_ne_zero.weierstrassCurve_Δ_ne_zero⟩
+  have : L'.weierstrassCurve.IsElliptic :=
+    ⟨isUnit_iff_ne_zero.mpr L'.discriminant_ne_zero.weierstrassCurve_Δ_ne_zero⟩
+  refine ModularCurve.kw_surgehgf4_hID_betweenCurvesIndexDual_proved L L' α ψ ?_
+  intro z
+  rw [PeriodPair.kw_toPointHom_apply, PeriodPair.kw_toPointHom_apply]
+  exact hψ z
+
+end S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker
+end P2MW
+export P2MW.S_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem PeriodPair.exists_scale_lattice_subset_and_sublatticeIndex_eq_natCard_ker
+    (L L' : PeriodPair) (hL : L.DiscriminantNeZero) (hL' : L'.DiscriminantNeZero) (α : ℂˣ)
+    (ψ : L.weierstrassCurve.toAffine.Point →+ L'.weierstrassCurve.toAffine.Point)
+    (hψ : ∀ z : ℂ, L'.toPoint hL' ((α : ℂ) * z) = ψ (L.toPoint hL z)) :
+    ∃ β : ℂˣ, ((L'.scale β).lattice : Set ℂ) ⊆ L.lattice ∧
+      PeriodPair.sublatticeIndex L (L'.scale β) = Nat.card ψ.ker :=
+  solution L L' hL hL' α ψ hψ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_exists_variableChange_smul_weierstrassCurve_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_exists_variableChange_smul_weierstrassCurve_eq.lean
new file mode 100644
index 0000000000..b84bb4142b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_exists_variableChange_smul_weierstrassCurve_eq.lean
@@ -0,0 +1,84 @@
+/-
+Based on Prove2Me node PeriodPair.exists_variableChange_smul_weierstrassCurve_eq
+(8a943e5f-0e08-51be-ac4b-8a8bf8cc3a81) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission cd5d01de-195f-57c3-8d1a-160c9b151e8c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_PeriodPair_Uniformization
+
+import Mathlib.AlgebraicGeometry.EllipticCurve.IsomOfJ
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_jLattice_surjective
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Every complex elliptic curve is a lattice curve
+
+Theorem statement: `PeriodPair.exists_variableChange_smul_weierstrassCurve_eq`
+(`8a943e5f-0e08-51be-ac4b-8a8bf8cc3a81`), by Claude, 2026-09-05.
+
+Proof: submission `cd5d01de-195f-57c3-8d1a-160c9b151e8c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $E$ be a Weierstrass curve over $\mathbb{C}$, given by coefficients $a_1,a_2,a_3,a_4,a_6$, and
+assume $E$ is elliptic in Mathlib's sense, i.e. its discriminant is a unit of $\mathbb{C}$. The
+assertion is that there exist a period pair $L$ (a `PeriodPair`, with associated invariants $L.g_2$
+and $L.g_3$) and an admissible change of Weierstrass coordinates $C$ over $\mathbb{C}$, that is an
+element $(u,r,s,t)$ with $u \in \mathbb{C}^\times$, such that the image of the Weierstrass curve
+attached to $L$ under $C$ is exactly $E$. Here the curve attached to $L$ is the one with $a_1 = a_2
+= a_3 = 0$, $a_4 = -L.g_2/4$ and $a_6 = -L.g_3/4$, that is $y^2 = x^3 - \tfrac{1}{4}g_2(L)\,x -
+\tfrac{1}{4}g_3(L)$, and the equality $C \bullet L.\mathrm{weierstrassCurve} = E$ is equality of
+Weierstrass curves, i.e. of all five coefficients, not merely an isomorphism of the associated
+curves.
+
+This is the algebraic half of the uniformisation theorem over $\mathbb{C}$: every elliptic curve in
+Weierstrass form arises, after an admissible coordinate change, from the Eisenstein invariants of a
+lattice. It is used in the project's work with complex-analytic models of elliptic curves, in
+particular in the results on isogeny data, modular polynomials and rational homomorphism sets that
+invoke it.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_PeriodPair_exists_variableChange_smul_weierstrassCurve_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_PeriodPair_exists_variableChange_smul_weierstrassCurve_eq
+
+theorem solution (E : WeierstrassCurve ℂ) [E.IsElliptic] :
+    ∃ (L : PeriodPair) (C : WeierstrassCurve.VariableChange ℂ), C • L.weierstrassCurve = E := by
+  obtain ⟨L, hΔ, hj⟩ := PeriodPair.jLattice_surjective E.j
+  have : L.weierstrassCurve.IsElliptic :=
+    ⟨isUnit_iff_ne_zero.mpr hΔ.weierstrassCurve_Δ_ne_zero⟩
+  have hjE : L.weierstrassCurve.j = E.j := by
+    rw [← hj, L.jLattice_eq_c₄_pow_three_div_Δ, WeierstrassCurve.j, div_eq_mul_inv, mul_comm,
+      Units.val_inv_eq_inv_val, WeierstrassCurve.coe_Δ']
+  exact ⟨L, WeierstrassCurve.exists_variableChange_of_j_eq L.weierstrassCurve E hjE⟩
+
+end S_PeriodPair_exists_variableChange_smul_weierstrassCurve_eq
+end P2MW
+export P2MW.S_PeriodPair_exists_variableChange_smul_weierstrassCurve_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem PeriodPair.exists_variableChange_smul_weierstrassCurve_eq (E : WeierstrassCurve ℂ)
+    [E.IsElliptic] :
+    ∃ (L : PeriodPair) (C : WeierstrassCurve.VariableChange ℂ), C • L.weierstrassCurve = E :=
+  solution E
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_isUniformization_toPoint.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_isUniformization_toPoint.lean
new file mode 100644
index 0000000000..032918e4f1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_isUniformization_toPoint.lean
@@ -0,0 +1,1582 @@
+/-
+Based on Prove2Me node PeriodPair.isUniformization_toPoint
+(cbff35ea-4fa5-52e2-9107-ed9c3b019fa2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 609d830f-975d-599b-b20a-34a3171a6d10
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_PeriodPair_Uniformization
+
+import Mathlib.Analysis.Calculus.Deriv.Pow
+import Mathlib.Analysis.Complex.CauchyIntegral
+import Mathlib.Analysis.Complex.Liouville
+import Mathlib.Analysis.Complex.RemovableSingularity
+import Mathlib.Analysis.Normed.Module.Connected
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_discriminant_ne_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Uniformisation: z ↦ (wp(z), wp'(z)/2) parametrises E_Λ(ℂ)
+
+Theorem statement: `PeriodPair.isUniformization_toPoint` (`cbff35ea-4fa5-52e2-9107-ed9c3b019fa2`),
+by Claude, 2026-09-05.
+
+Proof: submission `609d830f-975d-599b-b20a-34a3171a6d10`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a period pair, with associated lattice `L.lattice` $\subset \mathbb{C}$, invariants
+`L.g₂`, `L.g₃` and Weierstrass curve `L.weierstrassCurve`, and let $h$ be a proof of
+`L.DiscriminantNeZero`, i.e. of $g_2^3 - 27 g_3^2 \neq 0$; this condition guarantees that the
+discriminant of `L.weierstrassCurve` is nonzero, so that every solution of the affine Weierstrass
+equation is a nonsingular point. Consider the map `L.toPoint h` from $\mathbb{C}$ to the group of
+points of the affine curve `L.weierstrassCurve.toAffine`, which sends $z \in$ `L.lattice` to the
+point at infinity $0$ and sends $z \notin$ `L.lattice` to the affine point with coordinates given by
+`L.weierstrassP` at $z$, these coordinates satisfying the curve equation by
+`L.equation_weierstrassP`. The theorem asserts `L.IsUniformization h`, that is, the conjunction of
+three statements: `L.toPoint h` is additive, $\Phi(z+w) = \Phi(z) + \Phi(w)$ for all $z, w \in
+\mathbb{C}$; it is surjective onto the group of points of the curve; and its kernel is contained in
+the lattice, $\Phi(z) = 0$ implying $z \in$ `L.lattice` (the converse inclusion holds by definition
+of $\Phi$). The proof cites
+[`PeriodPair.discriminant_ne_zero`](thm.html#PeriodPair.discriminant_ne_zero), which asserts that
+the hypothesis $g_2^3 - 27 g_3^2 \neq 0$ holds for every period pair.
+
+This is the complex uniformisation theorem for elliptic curves in Weierstrass form: the Weierstrass
+parametrisation of a lattice induces a group isomorphism $\mathbb{C}/\Lambda \cong
+E_\Lambda(\mathbb{C})$. It underlies the subsequent transfer of analytic data to the algebraic
+curve, and is cited by the results comparing maps of period pairs with morphisms of the
+corresponding Weierstrass curves, such as
+[`PeriodPair.exists_mem_rationalHomSet_forall_apply_toPoint_eq_toPoint_mul`]
+(thm.html#PeriodPair.exists_mem_rationalHomSet_forall_apply_toPoint_eq_toPoint_mul)
+and
+[`PeriodPair.exists_differentiable_toPoint_comp_eq_pointMapOfPushforward_toPoint`]
+(thm.html#PeriodPair.exists_differentiable_toPoint_comp_eq_pointMapOfPushforward_toPoint).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_PeriodPair_isUniformization_toPoint.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_PeriodPair_isUniformization_toPoint
+
+
+namespace Bornology
+p2m_export "Bornology" "IsBounded.subset ext induced IsBounded cobounded"
+end Bornology
+namespace Complex
+p2m_export "Complex" "re lift differentiableOn_compl_singleton_and_continuousAt_iff \
+  rank_real_complex exists ext I"
+end Complex
+namespace Filter
+p2m_export "Filter" "NeBot Tendsto inter_mem IsBounded sets tendsto_atTop_mono atTop \
+  Tendsto.congr' tendsto_inv₀_cobounded eventually_of_mem tendsto_atTop_add_const_right codiscrete \
+  map"
+end Filter
+namespace PeriodPair
+p2m_export "PeriodPair" "analyticAt_weierstrassPExcept ω₁_div_two_notMem_lattice isClosed_lattice \
+  derivWeierstrassP_neg derivWeierstrassPExcept_sub weierstrassP_neg lattice weierstrassPExcept \
+  analyticOnNhd_weierstrassPExcept isClosed_of_subset_lattice weierstrassP_add_coe \
+  order_weierstrassP lattice_eq_span_range_basis isOpen_compl_lattice_diff ω₁ \
+  weierstrassPExcept_zero analyticOnNhd_derivWeierstrassP analyticAt_derivWeierstrassPExcept \
+  deriv_weierstrassPExcept_same g₃ weierstrassPExcept_add deriv_weierstrassP \
+  derivWeierstrassPExcept_zero_zero derivWeierstrassP_sq ω₂ derivWeierstrassP_add_coe mem_lattice \
+  derivWeierstrassPExcept compl_lattice_diff_singleton_mem_nhds G g₂ analyticOnNhd_weierstrassP \
+  weierstrassCurve weierstrassCurve_a₁ weierstrassCurve_a₂ weierstrassCurve_a₃ weierstrassCurve_Δ \
+  weierstrassCurve_c₄ equation_weierstrassP DiscriminantNeZero toPoint toPoint_of_mem toPoint_zero \
+  toPoint_of_notMem IsUniformization jLattice JSurjective ofTau scale sublatticeIndex \
+  discriminant_ne_zero"
+end PeriodPair
+namespace Set
+p2m_export "Set" "mem_diff preimage countable_coe_iff mem_compl_iff image ext preimage_compl \
+  compl_union mem_singleton_iff nonempty_compl compl_setOf diff_subset mem_inter inter_subset_left \
+  EqOn countable_range mem_inter_iff mem_ofPred_eq mem_preimage range"
+end Set
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne a₃ a₁ map a₄ a₂ a₆ \
+  Affine.Point.some Affine.Point.some.injEq Affine.negAddY reduction toAffine Affine.Point \
+  Affine.addX Affine.Point.some_ne_zero Δ c₄ Affine.addY Affine.Point.add_of_X_ne \
+  Affine.equation_iff Affine.Point.neg_some j"
+end WeierstrassCurve
+
+
+noncomputable section
+
+p2m_open_scoped "PeriodPair P2MW.S_PeriodPair_isUniformization_toPoint.PeriodPair Topology \
+  P2MW.S_PeriodPair_isUniformization_toPoint.Topology"
+p2m_open "Filter P2MW.S_PeriodPair_isUniformization_toPoint.Filter Set \
+  P2MW.S_PeriodPair_isUniformization_toPoint.Set"
+
+namespace PeriodPair
+p2m_export "PeriodPair" "analyticAt_weierstrassPExcept ω₁_div_two_notMem_lattice isClosed_lattice \
+  derivWeierstrassP_neg derivWeierstrassPExcept_sub weierstrassP_neg lattice weierstrassPExcept \
+  analyticOnNhd_weierstrassPExcept isClosed_of_subset_lattice weierstrassP_add_coe \
+  order_weierstrassP lattice_eq_span_range_basis isOpen_compl_lattice_diff ω₁ \
+  weierstrassPExcept_zero analyticOnNhd_derivWeierstrassP analyticAt_derivWeierstrassPExcept \
+  deriv_weierstrassPExcept_same g₃ weierstrassPExcept_add deriv_weierstrassP \
+  derivWeierstrassPExcept_zero_zero derivWeierstrassP_sq ω₂ derivWeierstrassP_add_coe mem_lattice \
+  derivWeierstrassPExcept compl_lattice_diff_singleton_mem_nhds G g₂ analyticOnNhd_weierstrassP \
+  weierstrassCurve weierstrassCurve_a₁ weierstrassCurve_a₂ weierstrassCurve_a₃ weierstrassCurve_Δ \
+  weierstrassCurve_c₄ equation_weierstrassP DiscriminantNeZero toPoint toPoint_of_mem toPoint_zero \
+  toPoint_of_notMem IsUniformization jLattice JSurjective ofTau scale sublatticeIndex \
+  discriminant_ne_zero"
+p2m_open "PeriodPair"
+
+variable (L : PeriodPair)
+
+private theorem _root_.PeriodPair.kw_countable_lattice : (L.lattice : Set ℂ).Countable := by
+  refine (Set.countable_range fun p : ℤ × ℤ => (p.1 : ℂ) * L.ω₁ + (p.2 : ℂ) * L.ω₂).mono ?_
+  intro z hz
+  obtain ⟨m, n, h⟩ := mem_lattice.mp hz
+  exact ⟨(m, n), h⟩
+
+p2m_export "PeriodPair" "kw_countable_lattice"
+
+private theorem _root_.PeriodPair.kw_isPreconnected_compl_lattice :
+    IsPreconnected (L.lattice : Set ℂ)ᶜ := by
+  have hrank : 1 < Module.rank ℝ ℂ := by simp [Complex.rank_real_complex]
+  have hpath : IsPathConnected (L.lattice : Set ℂ)ᶜ :=
+    L.kw_countable_lattice.isPathConnected_compl_of_one_lt_rank hrank
+  exact IsConnected.isPreconnected (IsPathConnected.isConnected hpath)
+
+p2m_export "PeriodPair" "kw_isPreconnected_compl_lattice"
+
+private theorem _root_.PeriodPair.kw_compl_lattice_mem_nhdsNE_zero :
+    (L.lattice : Set ℂ)ᶜ ∈ 𝓝[≠] (0 : ℂ) := by
+  have hcl : IsClosed ((L.lattice : Set ℂ) \ {0}) :=
+    L.isClosed_of_subset_lattice Set.sdiff_subset
+  have hopen : ((L.lattice : Set ℂ) \ {0})ᶜ ∈ 𝓝 (0 : ℂ) :=
+    hcl.isOpen_compl.mem_nhds (by simp)
+  filter_upwards [mem_nhdsWithin_of_mem_nhds hopen, self_mem_nhdsWithin] with z hz hzne hzL
+  exact hz ⟨hzL, hzne⟩
+
+p2m_export "PeriodPair" "kw_compl_lattice_mem_nhdsNE_zero"
+
+private theorem _root_.PeriodPair.kw_weierstrassP_not_eventually_const {c : ℂ} (hc : c ∉ L.lattice)
+    (e : ℂ) :
+    ¬ ℘[L] =ᶠ[𝓝 c] fun _ => e := by
+  intro hconst
+  have hEq : Set.EqOn ℘[L] (fun _ => e) (L.lattice : Set ℂ)ᶜ :=
+    L.analyticOnNhd_weierstrassP.eqOn_of_preconnected_of_eventuallyEq
+      analyticOnNhd_const L.kw_isPreconnected_compl_lattice hc hconst
+  have htend_e : Tendsto ℘[L] (𝓝[≠] 0) (𝓝 e) :=
+    Tendsto.congr' (eventually_of_mem L.kw_compl_lattice_mem_nhdsNE_zero
+      fun z hz => (hEq hz).symm) tendsto_const_nhds
+  have htend_top : Tendsto ℘[L] (𝓝[≠] 0) (Bornology.cobounded ℂ) := by
+    refine tendsto_cobounded_of_meromorphicOrderAt_neg ?_
+    simp only [L.order_weierstrassP 0 (zero_mem _)]
+    decide
+  have habs : Tendsto (‖℘[L] ·‖) (𝓝[≠] 0) atTop :=
+    tendsto_norm_atTop_iff_cobounded.mpr htend_top
+  have hbdd : Tendsto (‖℘[L] ·‖) (𝓝[≠] 0) (𝓝 ‖e‖) :=
+    (continuous_norm.tendsto e).comp htend_e
+  exact not_tendsto_nhds_of_tendsto_atTop habs ‖e‖ hbdd
+
+p2m_export "PeriodPair" "kw_weierstrassP_not_eventually_const"
+
+private theorem _root_.PeriodPair.kw_analyticOrderAt_weierstrassP_sub_self_ne_top {c : ℂ}
+    (hc : c ∉ L.lattice) :
+    analyticOrderAt (fun z => ℘[L] z - ℘[L] c) c ≠ ⊤ := by
+  rw [Ne, analyticOrderAt_eq_top]
+  exact fun h => L.kw_weierstrassP_not_eventually_const hc (℘[L] c)
+    (h.mono fun z hz => sub_eq_zero.mp hz)
+
+p2m_export "PeriodPair" "kw_analyticOrderAt_weierstrassP_sub_self_ne_top"
+
+private theorem _root_.PeriodPair.kw_analyticOrderAt_derivWeierstrassP {c : ℂ} (hc : c ∉ L.lattice)
+    :
+    analyticOrderAt ℘'[L] c + 1 = analyticOrderAt (fun z => ℘[L] z - ℘[L] c) c := by
+  have hP : AnalyticAt ℂ ℘[L] c := L.analyticOnNhd_weierstrassP c hc
+  simpa [L.deriv_weierstrassP] using hP.analyticOrderAt_deriv_add_one
+
+p2m_export "PeriodPair" "kw_analyticOrderAt_derivWeierstrassP"
+
+end PeriodPair
+
+end
+
+section
+
+p2m_open "Complex P2MW.S_PeriodPair_isUniformization_toPoint.Complex Filter \
+  P2MW.S_PeriodPair_isUniformization_toPoint.Filter Set \
+  P2MW.S_PeriodPair_isUniformization_toPoint.Set"
+
+p2m_open_scoped "PeriodPair P2MW.S_PeriodPair_isUniformization_toPoint.PeriodPair"
+
+namespace PeriodPair
+p2m_export "PeriodPair" "analyticAt_weierstrassPExcept ω₁_div_two_notMem_lattice isClosed_lattice \
+  derivWeierstrassP_neg derivWeierstrassPExcept_sub weierstrassP_neg lattice weierstrassPExcept \
+  analyticOnNhd_weierstrassPExcept isClosed_of_subset_lattice weierstrassP_add_coe \
+  order_weierstrassP lattice_eq_span_range_basis isOpen_compl_lattice_diff ω₁ \
+  weierstrassPExcept_zero analyticOnNhd_derivWeierstrassP analyticAt_derivWeierstrassPExcept \
+  deriv_weierstrassPExcept_same g₃ weierstrassPExcept_add deriv_weierstrassP \
+  derivWeierstrassPExcept_zero_zero derivWeierstrassP_sq ω₂ derivWeierstrassP_add_coe mem_lattice \
+  derivWeierstrassPExcept compl_lattice_diff_singleton_mem_nhds G g₂ analyticOnNhd_weierstrassP \
+  weierstrassCurve weierstrassCurve_a₁ weierstrassCurve_a₂ weierstrassCurve_a₃ weierstrassCurve_Δ \
+  weierstrassCurve_c₄ equation_weierstrassP DiscriminantNeZero toPoint toPoint_of_mem toPoint_zero \
+  toPoint_of_notMem IsUniformization jLattice JSurjective ofTau scale sublatticeIndex \
+  discriminant_ne_zero"
+p2m_open "PeriodPair"
+
+variable (L : PeriodPair)
+
+section Liouville
+
+private theorem _root_.PeriodPair.sub_fract_mem_lattice (z : ℂ) :
+    z - ZSpan.fract L.basis z ∈ L.lattice := by
+  rw [L.lattice_eq_span_range_basis]
+  have h := (ZSpan.fract_eq_fract L.basis (ZSpan.fract L.basis z) z).mp
+    (by rw [ZSpan.fract_eq_self.mpr (ZSpan.fract_mem_fundamentalDomain L.basis z)])
+  simpa [neg_add_eq_sub] using h
+
+p2m_export "PeriodPair" "sub_fract_mem_lattice"
+
+private theorem _root_.PeriodPair.apply_eq_apply_of_differentiable_of_forall_periodic {f : ℂ → ℂ}
+    (hf : Differentiable ℂ f) (hper : ∀ l ∈ L.lattice, ∀ z, f (z + l) = f z) (z w : ℂ) :
+    f z = f w := by
+  apply hf.apply_eq_apply_of_bounded
+  have hrange : range f ⊆ f '' closure (ZSpan.fundamentalDomain L.basis) := by
+    rintro - ⟨u, rfl⟩
+    refine ⟨ZSpan.fract L.basis u, subset_closure (ZSpan.fract_mem_fundamentalDomain _ u), ?_⟩
+    have h := hper _ (L.sub_fract_mem_lattice u) (ZSpan.fract L.basis u)
+    rw [add_sub_cancel] at h
+    exact h.symm
+  refine Bornology.IsBounded.subset ?_ hrange
+  refine (IsCompact.image ?_ hf.continuous).isBounded
+  exact Metric.isCompact_of_isClosed_isBounded isClosed_closure
+    (ZSpan.fundamentalDomain_isBounded L.basis).closure
+
+p2m_export "PeriodPair" "apply_eq_apply_of_differentiable_of_forall_periodic"
+end Liouville
+
+section ToPoint
+
+private theorem _root_.PeriodPair.toPoint_add_mem (h : L.DiscriminantNeZero) (z : ℂ) {l : ℂ}
+    (hl : l ∈ L.lattice) :
+    L.toPoint h (z + l) = L.toPoint h z := by
+  by_cases hz : z ∈ L.lattice
+  · rw [L.toPoint_of_mem h hz, L.toPoint_of_mem h (add_mem hz hl)]
+  · have hzl : z + l ∉ L.lattice := fun hmem => hz (by simpa using sub_mem hmem hl)
+    rw [L.toPoint_of_notMem h hz, L.toPoint_of_notMem h hzl]
+    have hP : ℘[L] (z + l) = ℘[L] z := L.weierstrassP_add_coe z ⟨l, hl⟩
+    have hP' : ℘'[L] (z + l) = ℘'[L] z := L.derivWeierstrassP_add_coe z ⟨l, hl⟩
+    simp only [WeierstrassCurve.Affine.Point.some.injEq]
+    exact ⟨hP, by rw [hP']⟩
+
+p2m_export "PeriodPair" "toPoint_add_mem"
+
+private theorem _root_.PeriodPair.toPoint_neg (h : L.DiscriminantNeZero) (z : ℂ) :
+    L.toPoint h (-z) = -L.toPoint h z := by
+  by_cases hz : z ∈ L.lattice
+  · rw [L.toPoint_of_mem h hz, L.toPoint_of_mem h (neg_mem hz)]; rfl
+  · have hnz : -z ∉ L.lattice := fun hmem => hz (by simpa using neg_mem hmem)
+    rw [L.toPoint_of_notMem h hz, L.toPoint_of_notMem h hnz,
+      WeierstrassCurve.Affine.Point.neg_some]
+    simp only [WeierstrassCurve.Affine.Point.some.injEq]
+    refine ⟨L.weierstrassP_neg z, ?_⟩
+    rw [L.derivWeierstrassP_neg]
+    show -℘'[L] z / 2 = L.weierstrassCurve.toAffine.negY (℘[L] z) (℘'[L] z / 2)
+    rw [WeierstrassCurve.Affine.negY, weierstrassCurve_a₁, weierstrassCurve_a₃]
+    ring
+
+p2m_export "PeriodPair" "toPoint_neg"
+end ToPoint
+
+end PeriodPair
+
+namespace Projectivization
+p2m_export "Projectivization" "map card"
+end Projectivization
+end
+
+
+
+noncomputable section
+
+p2m_open_scoped "PeriodPair P2MW.S_PeriodPair_isUniformization_toPoint.PeriodPair Topology \
+  P2MW.S_PeriodPair_isUniformization_toPoint.Topology"
+p2m_open "Filter P2MW.S_PeriodPair_isUniformization_toPoint.Filter Set \
+  P2MW.S_PeriodPair_isUniformization_toPoint.Set"
+
+namespace PeriodPair
+p2m_export "PeriodPair" "analyticAt_weierstrassPExcept ω₁_div_two_notMem_lattice isClosed_lattice \
+  derivWeierstrassP_neg derivWeierstrassPExcept_sub weierstrassP_neg lattice weierstrassPExcept \
+  analyticOnNhd_weierstrassPExcept isClosed_of_subset_lattice weierstrassP_add_coe \
+  order_weierstrassP lattice_eq_span_range_basis isOpen_compl_lattice_diff ω₁ \
+  weierstrassPExcept_zero analyticOnNhd_derivWeierstrassP analyticAt_derivWeierstrassPExcept \
+  deriv_weierstrassPExcept_same g₃ weierstrassPExcept_add deriv_weierstrassP \
+  derivWeierstrassPExcept_zero_zero derivWeierstrassP_sq ω₂ derivWeierstrassP_add_coe mem_lattice \
+  derivWeierstrassPExcept compl_lattice_diff_singleton_mem_nhds G g₂ analyticOnNhd_weierstrassP \
+  weierstrassCurve weierstrassCurve_a₁ weierstrassCurve_a₂ weierstrassCurve_a₃ weierstrassCurve_Δ \
+  weierstrassCurve_c₄ equation_weierstrassP DiscriminantNeZero toPoint toPoint_of_mem toPoint_zero \
+  toPoint_of_notMem IsUniformization jLattice JSurjective ofTau scale sublatticeIndex \
+  discriminant_ne_zero"
+p2m_open "PeriodPair"
+
+variable (L : PeriodPair)
+
+private theorem _root_.PeriodPair.kw_exists_derivWeierstrassP_ne_zero :
+    ∃ c, c ∉ L.lattice ∧ ℘'[L] c ≠ 0 := by
+  by_contra! h
+  have h0 : ℘'[L] =ᶠ[𝓝 (L.ω₁ / 2)] fun _ => 0 :=
+    eventually_of_mem (L.isClosed_lattice.isOpen_compl.mem_nhds L.ω₁_div_two_notMem_lattice)
+      fun u hu => h u hu
+  have hord_top : analyticOrderAt ℘'[L] (L.ω₁ / 2) = ⊤ := analyticOrderAt_eq_top.mpr h0
+  have hfin := L.kw_analyticOrderAt_weierstrassP_sub_self_ne_top L.ω₁_div_two_notMem_lattice
+  rw [← L.kw_analyticOrderAt_derivWeierstrassP L.ω₁_div_two_notMem_lattice, hord_top,
+    top_add] at hfin
+  exact hfin rfl
+
+p2m_export "PeriodPair" "kw_exists_derivWeierstrassP_ne_zero"
+
+private theorem _root_.PeriodPair.kw_two_mul_deriv_derivWeierstrassP_mul {z : ℂ}
+    (hz : z ∉ L.lattice) :
+    2 * ℘'[L] z * deriv ℘'[L] z = (12 * ℘[L] z ^ 2 - L.g₂) * ℘'[L] z := by
+  have hP : DifferentiableAt ℂ ℘[L] z := (L.analyticOnNhd_weierstrassP z hz).differentiableAt
+  have hP' : DifferentiableAt ℂ ℘'[L] z := (L.analyticOnNhd_derivWeierstrassP z hz).differentiableAt
+  have hEq : (fun u => ℘'[L] u ^ 2) =ᶠ[𝓝 z]
+      fun u => 4 * ℘[L] u ^ 3 - L.g₂ * ℘[L] u - L.g₃ := by
+    filter_upwards [L.isClosed_lattice.isOpen_compl.mem_nhds hz] with u hu
+    exact L.derivWeierstrassP_sq u hu
+  have hD := hEq.deriv_eq
+  have hdP : HasDerivAt ℘[L] (℘'[L] z) z := L.deriv_weierstrassP ▸ hP.hasDerivAt
+  have hL : HasDerivAt (fun u => ℘'[L] u ^ 2) (2 * ℘'[L] z * deriv ℘'[L] z) z :=
+    (hP'.hasDerivAt.pow 2).congr_deriv (by ring)
+  have hR' : HasDerivAt (fun u => 4 * ℘[L] u ^ 3 - L.g₂ * ℘[L] u - L.g₃)
+      (4 * (3 * ℘[L] z ^ 2 * ℘'[L] z) - L.g₂ * ℘'[L] z - 0) z :=
+    (((hdP.pow 3).const_mul 4).sub (hdP.const_mul L.g₂)).sub (hasDerivAt_const z _)
+  have hR : HasDerivAt (fun u => 4 * ℘[L] u ^ 3 - L.g₂ * ℘[L] u - L.g₃)
+      ((12 * ℘[L] z ^ 2 - L.g₂) * ℘'[L] z) z := hR'.congr_deriv (by ring)
+  rw [hL.deriv, hR.deriv] at hD
+  exact hD
+
+p2m_export "PeriodPair" "kw_two_mul_deriv_derivWeierstrassP_mul"
+
+private theorem _root_.PeriodPair.kw_deriv_derivWeierstrassP {z : ℂ} (hz : z ∉ L.lattice) :
+    deriv ℘'[L] z = 6 * ℘[L] z ^ 2 - L.g₂ / 2 := by
+  have hAnL : AnalyticOnNhd ℂ (deriv ℘'[L]) (L.lattice : Set ℂ)ᶜ :=
+    fun u hu => (L.analyticOnNhd_derivWeierstrassP u hu).deriv
+  have hAnR : AnalyticOnNhd ℂ (fun u => 6 * ℘[L] u ^ 2 - L.g₂ / 2) (L.lattice : Set ℂ)ᶜ :=
+    fun u hu => (analyticAt_const.mul ((L.analyticOnNhd_weierstrassP u hu).pow 2)).sub
+      analyticAt_const
+  obtain ⟨c, hc, hP'c⟩ := L.kw_exists_derivWeierstrassP_ne_zero
+  have hAgree : deriv ℘'[L] =ᶠ[𝓝 c] fun u => 6 * ℘[L] u ^ 2 - L.g₂ / 2 := by
+    have hP'cont : ContinuousAt ℘'[L] c :=
+      (L.analyticOnNhd_derivWeierstrassP c hc).continuousAt
+    have hne_nhd : ∀ᶠ u in 𝓝 c, ℘'[L] u ≠ 0 := hP'cont.eventually_ne hP'c
+    filter_upwards [hne_nhd, L.isClosed_lattice.isOpen_compl.mem_nhds hc] with u hu_ne hu_mem
+    have hmul := L.kw_two_mul_deriv_derivWeierstrassP_mul hu_mem
+    refine mul_left_cancel₀ (a := 2 * ℘'[L] u) (mul_ne_zero two_ne_zero hu_ne) ?_
+    calc 2 * ℘'[L] u * deriv ℘'[L] u = (12 * ℘[L] u ^ 2 - L.g₂) * ℘'[L] u := hmul
+      _ = 2 * ℘'[L] u * (6 * ℘[L] u ^ 2 - L.g₂ / 2) := by ring
+  exact hAnL.eqOn_of_preconnected_of_eventuallyEq hAnR L.kw_isPreconnected_compl_lattice
+    hc hAgree hz
+
+p2m_export "PeriodPair" "kw_deriv_derivWeierstrassP"
+
+private theorem _root_.PeriodPair.kw_deriv2_derivWeierstrassP {z : ℂ} (hz : z ∉ L.lattice) :
+    deriv (deriv ℘'[L]) z = 12 * ℘[L] z * ℘'[L] z := by
+  have hP : DifferentiableAt ℂ ℘[L] z := (L.analyticOnNhd_weierstrassP z hz).differentiableAt
+  have hEq : deriv ℘'[L] =ᶠ[𝓝 z] fun u => 6 * ℘[L] u ^ 2 - L.g₂ / 2 := by
+    filter_upwards [L.isClosed_lattice.isOpen_compl.mem_nhds hz] with u hu
+    exact L.kw_deriv_derivWeierstrassP hu
+  rw [hEq.deriv_eq]
+  have hdP : HasDerivAt ℘[L] (℘'[L] z) z := L.deriv_weierstrassP ▸ hP.hasDerivAt
+  have h1' : HasDerivAt (fun u => 6 * ℘[L] u ^ 2 - L.g₂ / 2)
+      (6 * (2 * ℘[L] z ^ 1 * ℘'[L] z) - 0) z :=
+    ((hdP.pow 2).const_mul 6).sub (hasDerivAt_const z _)
+  exact h1'.congr_deriv (by ring) |>.deriv
+
+p2m_export "PeriodPair" "kw_deriv2_derivWeierstrassP"
+end PeriodPair
+
+end
+
+noncomputable section
+
+p2m_open_scoped "PeriodPair P2MW.S_PeriodPair_isUniformization_toPoint.PeriodPair Topology \
+  P2MW.S_PeriodPair_isUniformization_toPoint.Topology"
+p2m_open "Filter P2MW.S_PeriodPair_isUniformization_toPoint.Filter Set \
+  P2MW.S_PeriodPair_isUniformization_toPoint.Set Bornology \
+  P2MW.S_PeriodPair_isUniformization_toPoint.Bornology Complex \
+  P2MW.S_PeriodPair_isUniformization_toPoint.Complex"
+
+namespace PeriodPair
+p2m_export "PeriodPair" "analyticAt_weierstrassPExcept ω₁_div_two_notMem_lattice isClosed_lattice \
+  derivWeierstrassP_neg derivWeierstrassPExcept_sub weierstrassP_neg lattice weierstrassPExcept \
+  analyticOnNhd_weierstrassPExcept isClosed_of_subset_lattice weierstrassP_add_coe \
+  order_weierstrassP lattice_eq_span_range_basis isOpen_compl_lattice_diff ω₁ \
+  weierstrassPExcept_zero analyticOnNhd_derivWeierstrassP analyticAt_derivWeierstrassPExcept \
+  deriv_weierstrassPExcept_same g₃ weierstrassPExcept_add deriv_weierstrassP \
+  derivWeierstrassPExcept_zero_zero derivWeierstrassP_sq ω₂ derivWeierstrassP_add_coe mem_lattice \
+  derivWeierstrassPExcept compl_lattice_diff_singleton_mem_nhds G g₂ analyticOnNhd_weierstrassP \
+  weierstrassCurve weierstrassCurve_a₁ weierstrassCurve_a₂ weierstrassCurve_a₃ weierstrassCurve_Δ \
+  weierstrassCurve_c₄ equation_weierstrassP DiscriminantNeZero toPoint toPoint_of_mem toPoint_zero \
+  toPoint_of_notMem IsUniformization jLattice JSurjective ofTau scale sublatticeIndex \
+  discriminant_ne_zero"
+p2m_open "PeriodPair"
+
+variable (L : PeriodPair)
+
+private theorem _root_.PeriodPair.kw_compl_lattice_mem_nhdsNE (l : ℂ) :
+    (L.lattice : Set ℂ)ᶜ ∈ 𝓝[≠] l := by
+  filter_upwards [mem_nhdsWithin_of_mem_nhds (L.compl_lattice_sdiff_singleton_mem_nhds l),
+    self_mem_nhdsWithin] with z hz hzne hzL
+  exact hz ⟨hzL, hzne⟩
+
+p2m_export "PeriodPair" "kw_compl_lattice_mem_nhdsNE"
+
+private theorem _root_.PeriodPair.kw_tendsto_weierstrassP_cobounded {l : ℂ} (hl : l ∈ L.lattice) :
+    Tendsto ℘[L] (𝓝[≠] l) (cobounded ℂ) := by
+  refine tendsto_cobounded_of_meromorphicOrderAt_neg ?_
+  simp only [L.order_weierstrassP l hl]
+  decide
+
+p2m_export "PeriodPair" "kw_tendsto_weierstrassP_cobounded"
+
+private theorem _root_.PeriodPair.kw_weierstrassP_surjective (x₀ : ℂ) :
+    ∃ z, z ∉ L.lattice ∧ ℘[L] z = x₀ := by
+  by_contra! hno
+  classical
+  let G : ℂ → ℂ := fun z => if z ∈ L.lattice then 0 else (℘[L] z - x₀)⁻¹
+  have hGcompl : ∀ z ∉ L.lattice, G z = (℘[L] z - x₀)⁻¹ := fun z hz => ite_eq_right hz
+  have hGmem : ∀ z ∈ L.lattice, G z = 0 := fun z hz => ite_eq_left hz
+  have hGper : ∀ l ∈ L.lattice, ∀ z, G (z + l) = G z := by
+    intro l hl z
+    by_cases hz : z ∈ L.lattice
+    · rw [hGmem z hz, hGmem (z + l) (add_mem hz hl)]
+    · have hzl : z + l ∉ L.lattice := fun h => hz (by simpa using sub_mem h hl)
+      rw [hGcompl z hz, hGcompl (z + l) hzl, L.weierstrassP_add_coe z ⟨l, hl⟩]
+  have hne : ∀ z ∉ L.lattice, ℘[L] z - x₀ ≠ 0 := fun z hz => sub_ne_zero.mpr (hno z hz)
+  have hGdiff_compl : DifferentiableOn ℂ G (L.lattice : Set ℂ)ᶜ := by
+    refine DifferentiableOn.congr ?_ (fun z hz => hGcompl z hz)
+    exact fun z hz => ((L.analyticOnNhd_weierstrassP z hz).sub
+      analyticAt_const).differentiableAt.inv (hne z hz) |>.differentiableWithinAt
+  have hGdiff : Differentiable ℂ G := by
+    intro z
+    by_cases hz : z ∈ L.lattice
+    · set s := ((L.lattice : Set ℂ) \ {z})ᶜ with hs_def
+      have hs_nhds : s ∈ 𝓝 z := L.compl_lattice_sdiff_singleton_mem_nhds z
+      have hs_diff : s \ {z} = (L.lattice : Set ℂ)ᶜ := by
+        ext w; simp only [hs_def, Set.mem_sdiff, mem_compl_iff, mem_singleton_iff]
+        constructor
+        · rintro ⟨hw, hwne⟩ hwL; exact hw ⟨hwL, hwne⟩
+        · exact fun hwL => ⟨fun ⟨h, _⟩ => hwL h, fun h => hwL (h ▸ hz)⟩
+      have hGcont : ContinuousAt G z := by
+        rw [← continuousWithinAt_compl_self, ContinuousWithinAt, hGmem z hz]
+        refine Tendsto.congr'
+          (eventually_of_mem (L.kw_compl_lattice_mem_nhdsNE z)
+            (fun w hw => (hGcompl w hw).symm)) ?_
+        have h℘ := L.kw_tendsto_weierstrassP_cobounded hz
+        have h℘' : Tendsto (fun w => ℘[L] w - x₀) (𝓝[≠] z) (cobounded ℂ) := by
+          rw [← tendsto_norm_atTop_iff_cobounded] at h℘ ⊢
+          exact tendsto_atTop_mono (fun w => norm_sub_norm_le (℘[L] w) x₀)
+            (tendsto_atTop_add_const_right _ (-‖x₀‖) h℘)
+        exact tendsto_inv₀_cobounded.comp h℘'
+      exact ((differentiableOn_compl_singleton_and_continuousAt_iff hs_nhds).mp
+        ⟨hs_diff ▸ hGdiff_compl, hGcont⟩).differentiableAt hs_nhds
+    · exact (hGdiff_compl z hz).differentiableAt (L.isClosed_lattice.isOpen_compl.mem_nhds hz)
+  have hGconst := L.apply_eq_apply_of_differentiable_of_forall_periodic hGdiff hGper
+  have h0 : G 0 = 0 := hGmem 0 (zero_mem _)
+  have hω : G (L.ω₁ / 2) = (℘[L] (L.ω₁ / 2) - x₀)⁻¹ :=
+    hGcompl _ L.ω₁_div_two_notMem_lattice
+  refine absurd (hGconst (L.ω₁ / 2) 0) ?_
+  rw [h0, hω]
+  exact inv_ne_zero (hne _ L.ω₁_div_two_notMem_lattice)
+
+p2m_export "PeriodPair" "kw_weierstrassP_surjective"
+
+private theorem _root_.PeriodPair.kw_toPoint_eq_zero_iff (h : L.DiscriminantNeZero) (z : ℂ) :
+    L.toPoint h z = 0 ↔ z ∈ L.lattice := by
+  refine ⟨fun hz => by_contra fun hnz => ?_, L.toPoint_of_mem h⟩
+  rw [L.toPoint_of_notMem h hnz] at hz
+  exact WeierstrassCurve.Affine.Point.some_ne_zero _ hz
+
+p2m_export "PeriodPair" "kw_toPoint_eq_zero_iff"
+
+private theorem _root_.PeriodPair.kw_toPoint_surjective (h : L.DiscriminantNeZero) :
+    Function.Surjective (L.toPoint h) := by
+  intro P
+  rcases P with _ | ⟨x₀, y₀, hP⟩
+  · exact ⟨0, L.toPoint_zero h⟩
+  obtain ⟨z, hz, h℘z⟩ := L.kw_weierstrassP_surjective x₀
+  have hsq : (℘'[L] z / 2) ^ 2 = y₀ ^ 2 := by
+    have h1 := L.equation_weierstrassP hz
+    have h2 := hP.1
+    rw [WeierstrassCurve.Affine.equation_iff] at h1 h2
+    simp only [weierstrassCurve_a₁, weierstrassCurve_a₂, weierstrassCurve_a₃,
+      h℘z, zero_mul, add_zero] at h1 h2
+    linear_combination h1 - h2
+  rcases sq_eq_sq_iff_eq_or_eq_neg.mp hsq with heq | heq
+  · exact ⟨z, by
+      rw [L.toPoint_of_notMem h hz]
+      simp only [WeierstrassCurve.Affine.Point.some.injEq]
+      exact ⟨h℘z, heq⟩⟩
+  · have hnz : -z ∉ L.lattice := fun hm => hz (neg_neg z ▸ neg_mem hm)
+    exact ⟨-z, by
+      rw [L.toPoint_of_notMem h hnz]
+      simp only [WeierstrassCurve.Affine.Point.some.injEq]
+      refine ⟨(L.weierstrassP_neg z).trans h℘z, ?_⟩
+      rw [L.derivWeierstrassP_neg]
+      linear_combination -heq⟩
+
+p2m_export "PeriodPair" "kw_toPoint_surjective"
+
+end PeriodPair
+
+end
+
+
+
+noncomputable section
+
+p2m_open_scoped "PeriodPair P2MW.S_PeriodPair_isUniformization_toPoint.PeriodPair Topology \
+  P2MW.S_PeriodPair_isUniformization_toPoint.Topology"
+p2m_open "Filter P2MW.S_PeriodPair_isUniformization_toPoint.Filter Set \
+  P2MW.S_PeriodPair_isUniformization_toPoint.Set"
+
+namespace PeriodPair
+p2m_export "PeriodPair" "analyticAt_weierstrassPExcept ω₁_div_two_notMem_lattice isClosed_lattice \
+  derivWeierstrassP_neg derivWeierstrassPExcept_sub weierstrassP_neg lattice weierstrassPExcept \
+  analyticOnNhd_weierstrassPExcept isClosed_of_subset_lattice weierstrassP_add_coe \
+  order_weierstrassP lattice_eq_span_range_basis isOpen_compl_lattice_diff ω₁ \
+  weierstrassPExcept_zero analyticOnNhd_derivWeierstrassP analyticAt_derivWeierstrassPExcept \
+  deriv_weierstrassPExcept_same g₃ weierstrassPExcept_add deriv_weierstrassP \
+  derivWeierstrassPExcept_zero_zero derivWeierstrassP_sq ω₂ derivWeierstrassP_add_coe mem_lattice \
+  derivWeierstrassPExcept compl_lattice_diff_singleton_mem_nhds G g₂ analyticOnNhd_weierstrassP \
+  weierstrassCurve weierstrassCurve_a₁ weierstrassCurve_a₂ weierstrassCurve_a₃ weierstrassCurve_Δ \
+  weierstrassCurve_c₄ equation_weierstrassP DiscriminantNeZero toPoint toPoint_of_mem toPoint_zero \
+  toPoint_of_notMem IsUniformization jLattice JSurjective ofTau scale sublatticeIndex \
+  discriminant_ne_zero"
+p2m_open "PeriodPair"
+
+variable (L : PeriodPair) {w : ℂ}
+
+private theorem _root_.PeriodPair.kw_hasDerivAt_weierstrassP_add {z : ℂ} (hzw : z + w ∉ L.lattice) :
+    HasDerivAt (fun u => ℘[L] (u + w)) (℘'[L] (z + w)) z := by
+  have h := (L.analyticOnNhd_weierstrassP (z + w) hzw).differentiableAt.hasDerivAt
+  simpa [L.deriv_weierstrassP] using h.comp_add_const z w
+
+p2m_export "PeriodPair" "kw_hasDerivAt_weierstrassP_add"
+
+private theorem _root_.PeriodPair.kw_add_notMem_mem_nhds_zero (hw : w ∉ L.lattice) :
+    {u : ℂ | u + w ∉ L.lattice} ∈ 𝓝 (0 : ℂ) :=
+  IsOpen.mem_nhds
+    (L.isClosed_lattice.isOpen_compl.preimage (continuous_id.add continuous_const))
+    (by simpa using hw)
+
+p2m_export "PeriodPair" "kw_add_notMem_mem_nhds_zero"
+
+private theorem _root_.PeriodPair.kw_analyticAt_weierstrassP_add_zero (hw : w ∉ L.lattice) :
+    AnalyticAt ℂ (fun u => ℘[L] (u + w)) 0 := by
+  have hd : DifferentiableOn ℂ (fun u => ℘[L] (u + w)) {u : ℂ | u + w ∉ L.lattice} := by
+    intro u hu
+    exact (L.kw_hasDerivAt_weierstrassP_add hu).differentiableAt.differentiableWithinAt
+  exact (hd.analyticOnNhd
+    (L.isClosed_lattice.isOpen_compl.preimage (continuous_id.add continuous_const)))
+    0 (by simpa using hw)
+
+p2m_export "PeriodPair" "kw_analyticAt_weierstrassP_add_zero"
+
+private def _root_.PeriodPair.kwAddCoreE (w : ℂ) (z : ℂ) : ℂ :=
+  4 * ℘[L] (z + w) + (-8 * ℘[L] w) * (z ^ 2 * ℘[L] (z + w))
+    + (-4 * ℘[L] w) + (-4 * ℘'[L] w) * z + (L.g₂ - 4 * ℘[L] w ^ 2) * z ^ 2
+
+p2m_export "PeriodPair" "kwAddCoreE"
+
+private def _root_.PeriodPair.kwAddCoreE₁ (w : ℂ) (z : ℂ) : ℂ :=
+  4 * ℘'[L] (z + w)
+    + (-8 * ℘[L] w) * (2 * z * ℘[L] (z + w) + z ^ 2 * ℘'[L] (z + w))
+    + 0 + (-4 * ℘'[L] w) * 1 + (L.g₂ - 4 * ℘[L] w ^ 2) * (2 * z)
+
+p2m_export "PeriodPair" "kwAddCoreE₁"
+
+private def _root_.PeriodPair.kwAddCoreE₂ (w : ℂ) (z : ℂ) : ℂ :=
+  4 * deriv ℘'[L] (z + w)
+    + (-8 * ℘[L] w) * (2 * ℘[L] (z + w) + 4 * z * ℘'[L] (z + w)
+        + z ^ 2 * deriv ℘'[L] (z + w))
+    + 0 + 0 + (L.g₂ - 4 * ℘[L] w ^ 2) * 2
+
+p2m_export "PeriodPair" "kwAddCoreE₂"
+
+private theorem _root_.PeriodPair.kw_analyticAt_addCoreE (hw : w ∉ L.lattice) :
+    AnalyticAt ℂ (L.kwAddCoreE w) 0 := by
+  unfold kwAddCoreE
+  have hP := L.kw_analyticAt_weierstrassP_add_zero hw
+  fun_prop
+
+p2m_export "PeriodPair" "kw_analyticAt_addCoreE"
+
+private theorem _root_.PeriodPair.kw_addCoreE_zero : L.kwAddCoreE w 0 = 0 := by
+  simp only [kwAddCoreE, zero_add, zero_pow, mul_zero, add_zero, ne_eq, OfNat.ofNat_ne_zero,
+    not_false_eq_true, zero_mul]
+  ring
+
+p2m_export "PeriodPair" "kw_addCoreE_zero"
+
+private theorem _root_.PeriodPair.kw_hasDerivAt_addCoreE {z : ℂ} (hz : z + w ∉ L.lattice) :
+    HasDerivAt (L.kwAddCoreE w)
+      (4 * ℘'[L] (z + w)
+        + (-8 * ℘[L] w) * (2 * z * ℘[L] (z + w) + z ^ 2 * ℘'[L] (z + w))
+        + 0 + (-4 * ℘'[L] w) * 1 + (L.g₂ - 4 * ℘[L] w ^ 2) * (2 * z)) z := by
+  have hP : HasDerivAt (fun u => ℘[L] (u + w)) (℘'[L] (z + w)) z :=
+    L.kw_hasDerivAt_weierstrassP_add hz
+  have hid : HasDerivAt (fun u : ℂ => u) 1 z := hasDerivAt_id z
+  have hz2 : HasDerivAt (fun u : ℂ => u ^ 2) (2 * z) z :=
+    (hid.pow 2).congr_deriv (by ring)
+  have hQ : HasDerivAt (fun u => u ^ 2 * ℘[L] (u + w))
+      (2 * z * ℘[L] (z + w) + z ^ 2 * ℘'[L] (z + w)) z := hz2.mul hP
+  exact ((((hP.const_mul 4).add (hQ.const_mul _)).add (hasDerivAt_const z _)).add
+    (hid.const_mul _)).add (hz2.const_mul _)
+
+p2m_export "PeriodPair" "kw_hasDerivAt_addCoreE"
+variable (hw : w ∉ L.lattice)
+include hw
+
+private theorem _root_.PeriodPair.kw_deriv_addCoreE_eqNhds :
+    deriv (L.kwAddCoreE w) =ᶠ[𝓝 0] L.kwAddCoreE₁ w := by
+  filter_upwards [L.kw_add_notMem_mem_nhds_zero hw] with z hz
+  exact (L.kw_hasDerivAt_addCoreE hz).deriv
+
+p2m_export "PeriodPair" "kw_deriv_addCoreE_eqNhds"
+
+private theorem _root_.PeriodPair.kw_deriv_addCoreE_zero : deriv (L.kwAddCoreE w) 0 = 0 := by
+  rw [(L.kw_deriv_addCoreE_eqNhds hw).eq_of_nhds]
+  simp only [kwAddCoreE₁, zero_add, mul_zero, zero_mul, add_zero, mul_one]
+  ring
+
+p2m_export "PeriodPair" "kw_deriv_addCoreE_zero"
+omit hw in
+private theorem _root_.PeriodPair.kw_hasDerivAt_addCoreE₁ {z : ℂ} (hz : z + w ∉ L.lattice) :
+    HasDerivAt (L.kwAddCoreE₁ w)
+      (4 * deriv ℘'[L] (z + w)
+        + (-8 * ℘[L] w) * (2 * ℘[L] (z + w) + 4 * z * ℘'[L] (z + w)
+            + z ^ 2 * deriv ℘'[L] (z + w))
+        + 0 + 0 + (L.g₂ - 4 * ℘[L] w ^ 2) * 2) z := by
+  have hP : HasDerivAt (fun u => ℘[L] (u + w)) (℘'[L] (z + w)) z :=
+    L.kw_hasDerivAt_weierstrassP_add hz
+  have hP' : HasDerivAt (fun u => ℘'[L] (u + w)) (deriv ℘'[L] (z + w)) z :=
+    (L.analyticOnNhd_derivWeierstrassP (z + w) hz).differentiableAt.hasDerivAt.comp_add_const z w
+  have hid : HasDerivAt (fun u : ℂ => u) 1 z := hasDerivAt_id z
+  have hz2 : HasDerivAt (fun u : ℂ => u ^ 2) (2 * z) z :=
+    (hid.pow 2).congr_deriv (by ring)
+  have hQ : HasDerivAt (fun u => 2 * u * ℘[L] (u + w) + u ^ 2 * ℘'[L] (u + w))
+      (2 * ℘[L] (z + w) + 4 * z * ℘'[L] (z + w) + z ^ 2 * deriv ℘'[L] (z + w)) z := by
+    have h1 : HasDerivAt (fun u => 2 * u * ℘[L] (u + w))
+        (2 * 1 * ℘[L] (z + w) + 2 * z * ℘'[L] (z + w)) z := (hid.const_mul 2).mul hP
+    have h2 : HasDerivAt (fun u => u ^ 2 * ℘'[L] (u + w))
+        (2 * z * ℘'[L] (z + w) + z ^ 2 * deriv ℘'[L] (z + w)) z := hz2.mul hP'
+    exact (h1.add h2).congr_deriv (by ring)
+  have h2z : HasDerivAt (fun u : ℂ => 2 * u) (2 : ℂ) z :=
+    (hid.const_mul 2).congr_deriv (by ring)
+  exact ((((hP'.const_mul 4).add (hQ.const_mul _)).add (hasDerivAt_const z _)).add
+    (hasDerivAt_const z _)).add (h2z.const_mul _)
+
+p2m_export "PeriodPair" "kw_hasDerivAt_addCoreE₁"
+
+private theorem _root_.PeriodPair.kw_deriv2_addCoreE_eqNhds :
+    deriv (deriv (L.kwAddCoreE w)) =ᶠ[𝓝 0] L.kwAddCoreE₂ w := by
+  refine ((L.kw_deriv_addCoreE_eqNhds hw).deriv).trans ?_
+  filter_upwards [L.kw_add_notMem_mem_nhds_zero hw] with z hz
+  exact (L.kw_hasDerivAt_addCoreE₁ hz).deriv
+
+p2m_export "PeriodPair" "kw_deriv2_addCoreE_eqNhds"
+
+private theorem _root_.PeriodPair.kw_deriv2_addCoreE_zero :
+    deriv (deriv (L.kwAddCoreE w)) 0 = 0 := by
+  rw [(L.kw_deriv2_addCoreE_eqNhds hw).eq_of_nhds]
+  simp only [kwAddCoreE₂, zero_add, mul_zero, zero_mul, add_zero]
+  rw [L.kw_deriv_derivWeierstrassP hw]
+  ring
+
+p2m_export "PeriodPair" "kw_deriv2_addCoreE_zero"
+omit hw in
+private theorem _root_.PeriodPair.kw_hasDerivAt_addCoreE₂ {z : ℂ} (hz : z + w ∉ L.lattice) :
+    HasDerivAt (L.kwAddCoreE₂ w)
+      (4 * deriv (deriv ℘'[L]) (z + w)
+        + (-8 * ℘[L] w) * (6 * ℘'[L] (z + w) + 6 * z * deriv ℘'[L] (z + w)
+            + z ^ 2 * deriv (deriv ℘'[L]) (z + w))
+        + 0 + 0 + 0) z := by
+  have hP : HasDerivAt (fun u => ℘[L] (u + w)) (℘'[L] (z + w)) z :=
+    L.kw_hasDerivAt_weierstrassP_add hz
+  have hP' : HasDerivAt (fun u => ℘'[L] (u + w)) (deriv ℘'[L] (z + w)) z :=
+    (L.analyticOnNhd_derivWeierstrassP (z + w) hz).differentiableAt.hasDerivAt.comp_add_const z w
+  have hP'' : HasDerivAt (fun u => deriv ℘'[L] (u + w)) (deriv (deriv ℘'[L]) (z + w)) z :=
+    ((L.analyticOnNhd_derivWeierstrassP (z + w)
+      hz).deriv).differentiableAt.hasDerivAt.comp_add_const z w
+  have hid : HasDerivAt (fun u : ℂ => u) 1 z := hasDerivAt_id z
+  have hz2 : HasDerivAt (fun u : ℂ => u ^ 2) (2 * z) z :=
+    (hid.pow 2).congr_deriv (by ring)
+  have hQ : HasDerivAt
+      (fun u => 2 * ℘[L] (u + w) + 4 * u * ℘'[L] (u + w) + u ^ 2 * deriv ℘'[L] (u + w))
+      (6 * ℘'[L] (z + w) + 6 * z * deriv ℘'[L] (z + w)
+        + z ^ 2 * deriv (deriv ℘'[L]) (z + w)) z := by
+    have h1 : HasDerivAt (fun u => 4 * u * ℘'[L] (u + w))
+        (4 * 1 * ℘'[L] (z + w) + 4 * z * deriv ℘'[L] (z + w)) z := (hid.const_mul 4).mul hP'
+    have h2 : HasDerivAt (fun u => u ^ 2 * deriv ℘'[L] (u + w))
+        (2 * z * deriv ℘'[L] (z + w) + z ^ 2 * deriv (deriv ℘'[L]) (z + w)) z := hz2.mul hP''
+    exact (((hP.const_mul 2).add h1).add h2).congr_deriv (by ring)
+  exact ((((hP''.const_mul 4).add (hQ.const_mul _)).add (hasDerivAt_const z _)).add
+    (hasDerivAt_const z _)).add (hasDerivAt_const z _)
+
+p2m_export "PeriodPair" "kw_hasDerivAt_addCoreE₂"
+
+private theorem _root_.PeriodPair.kw_deriv3_addCoreE_eqNhds :
+    deriv (deriv (deriv (L.kwAddCoreE w))) =ᶠ[𝓝 0]
+      fun z => 4 * deriv (deriv ℘'[L]) (z + w)
+        + (-8 * ℘[L] w) * (6 * ℘'[L] (z + w) + 6 * z * deriv ℘'[L] (z + w)
+            + z ^ 2 * deriv (deriv ℘'[L]) (z + w))
+        + 0 + 0 + 0 := by
+  refine ((L.kw_deriv2_addCoreE_eqNhds hw).deriv).trans ?_
+  filter_upwards [L.kw_add_notMem_mem_nhds_zero hw] with z hz
+  exact (L.kw_hasDerivAt_addCoreE₂ hz).deriv
+
+p2m_export "PeriodPair" "kw_deriv3_addCoreE_eqNhds"
+
+private theorem _root_.PeriodPair.kw_deriv3_addCoreE_zero :
+    deriv (deriv (deriv (L.kwAddCoreE w))) 0 = 0 := by
+  rw [(L.kw_deriv3_addCoreE_eqNhds hw).eq_of_nhds]
+  simp only [zero_add, mul_zero, zero_mul, add_zero]
+  rw [L.kw_deriv2_derivWeierstrassP hw]
+  ring
+
+p2m_export "PeriodPair" "kw_deriv3_addCoreE_zero"
+
+private theorem _root_.PeriodPair.kw_addCoreE_order_ge_four :
+    (4 : ℕ∞) ≤ analyticOrderAt (L.kwAddCoreE w) 0 := by
+  rw [show (4 : ℕ∞) = ((4 : ℕ) : ℕ∞) from rfl,
+    natCast_le_analyticOrderAt_iff_iteratedDeriv_eq_zero (L.kw_analyticAt_addCoreE hw)]
+  intro i hi
+  interval_cases i
+  · simpa [iteratedDeriv_zero] using L.kw_addCoreE_zero
+  · simpa [iteratedDeriv_one] using L.kw_deriv_addCoreE_zero hw
+  · have : iteratedDeriv 2 (L.kwAddCoreE w) = deriv (deriv (L.kwAddCoreE w)) := by
+      rw [iteratedDeriv_succ, iteratedDeriv_one]
+    rw [this]; exact L.kw_deriv2_addCoreE_zero hw
+  · have : iteratedDeriv 3 (L.kwAddCoreE w) = deriv (deriv (deriv (L.kwAddCoreE w))) := by
+      rw [iteratedDeriv_succ, iteratedDeriv_succ, iteratedDeriv_one]
+    rw [this]; exact L.kw_deriv3_addCoreE_zero hw
+
+p2m_export "PeriodPair" "kw_addCoreE_order_ge_four"
+end PeriodPair
+
+end
+
+noncomputable section
+
+p2m_open_scoped "PeriodPair P2MW.S_PeriodPair_isUniformization_toPoint.PeriodPair Topology \
+  P2MW.S_PeriodPair_isUniformization_toPoint.Topology"
+p2m_open "Filter P2MW.S_PeriodPair_isUniformization_toPoint.Filter Set \
+  P2MW.S_PeriodPair_isUniformization_toPoint.Set"
+
+namespace PeriodPair
+p2m_export "PeriodPair" "analyticAt_weierstrassPExcept ω₁_div_two_notMem_lattice isClosed_lattice \
+  derivWeierstrassP_neg derivWeierstrassPExcept_sub weierstrassP_neg lattice weierstrassPExcept \
+  analyticOnNhd_weierstrassPExcept isClosed_of_subset_lattice weierstrassP_add_coe \
+  order_weierstrassP lattice_eq_span_range_basis isOpen_compl_lattice_diff ω₁ \
+  weierstrassPExcept_zero analyticOnNhd_derivWeierstrassP analyticAt_derivWeierstrassPExcept \
+  deriv_weierstrassPExcept_same g₃ weierstrassPExcept_add deriv_weierstrassP \
+  derivWeierstrassPExcept_zero_zero derivWeierstrassP_sq ω₂ derivWeierstrassP_add_coe mem_lattice \
+  derivWeierstrassPExcept compl_lattice_diff_singleton_mem_nhds G g₂ analyticOnNhd_weierstrassP \
+  weierstrassCurve weierstrassCurve_a₁ weierstrassCurve_a₂ weierstrassCurve_a₃ weierstrassCurve_Δ \
+  weierstrassCurve_c₄ equation_weierstrassP DiscriminantNeZero toPoint toPoint_of_mem toPoint_zero \
+  toPoint_of_notMem IsUniformization jLattice JSurjective ofTau scale sublatticeIndex \
+  discriminant_ne_zero"
+p2m_open "PeriodPair"
+
+variable (L : PeriodPair) {w : ℂ}
+
+private theorem _root_.PeriodPair.kw_weierstrassPExcept_zero_order_ge_two :
+    (2 : ℕ∞) ≤ analyticOrderAt (L.weierstrassPExcept (0 : ℂ)) (0 : ℂ) := by
+  rw [show (2 : ℕ∞) = ((2 : ℕ) : ℕ∞) from rfl,
+    natCast_le_analyticOrderAt_iff_iteratedDeriv_eq_zero
+      (PeriodPair.analyticAt_weierstrassPExcept L (0 : ℂ))]
+  intro i hi
+  interval_cases i
+  · simp only [iteratedDeriv_zero]; exact PeriodPair.weierstrassPExcept_zero L (0 : ℂ)
+  · simp only [iteratedDeriv_one]
+    rw [PeriodPair.deriv_weierstrassPExcept_same L (0 : ℂ)]
+    exact PeriodPair.derivWeierstrassPExcept_zero_zero L
+
+p2m_export "PeriodPair" "kw_weierstrassPExcept_zero_order_ge_two"
+
+private def _root_.PeriodPair.kwAddBridgeT (w : ℂ) (z : ℂ) : ℂ :=
+  4 * ((L.weierstrassPExcept (0:ℂ)) z - ℘[L] w) ^ 2 * ℘[L] (z + w)
+    - 4 * ℘[L] w * (L.weierstrassPExcept (0:ℂ)) z ^ 2 - 4 * ℘[L] w ^ 2 * (L.weierstrassPExcept
+      (0:ℂ)) z
+    + L.g₂ * (L.weierstrassPExcept (0:ℂ)) z + L.g₂ * ℘[L] w + 2 * L.g₃ + 2 * ℘'[L] w *
+      (L.derivWeierstrassPExcept (0:ℂ)) z
+
+p2m_export "PeriodPair" "kwAddBridgeT"
+
+private def _root_.PeriodPair.kwAddBridgeR (w : ℂ) (z : ℂ) : ℂ :=
+  8 * (z ^ 2 * (L.weierstrassPExcept (0:ℂ)) z) * (℘[L] (z + w) - ℘[L] w) + z ^ 4 * L.kwAddBridgeT w
+    z
+
+p2m_export "PeriodPair" "kwAddBridgeR"
+
+private theorem _root_.PeriodPair.kw_analyticAt_addBridgeT (hw : w ∉ L.lattice) :
+    AnalyticAt ℂ (L.kwAddBridgeT w) 0 := by
+  unfold kwAddBridgeT
+  have h1 := PeriodPair.analyticAt_weierstrassPExcept L (0 : ℂ)
+  have h2 := L.kw_analyticAt_weierstrassP_add_zero hw
+  have h3 := PeriodPair.analyticAt_derivWeierstrassPExcept L (0 : ℂ)
+  fun_prop
+
+p2m_export "PeriodPair" "kw_analyticAt_addBridgeT"
+
+private theorem _root_.PeriodPair.kw_analyticAt_addBridgeR (hw : w ∉ L.lattice) :
+    AnalyticAt ℂ (L.kwAddBridgeR w) 0 := by
+  unfold kwAddBridgeR
+  have h1 := PeriodPair.analyticAt_weierstrassPExcept L (0 : ℂ)
+  have h2 := L.kw_analyticAt_weierstrassP_add_zero hw
+  have h3 := L.kw_analyticAt_addBridgeT hw
+  fun_prop
+
+p2m_export "PeriodPair" "kw_analyticAt_addBridgeR"
+
+private theorem _root_.PeriodPair.kw_addBridgeR_order_ge_four (hw : w ∉ L.lattice) :
+    (4 : ℕ∞) ≤ analyticOrderAt (L.kwAddBridgeR w) (0 : ℂ) := by
+  have hg := PeriodPair.analyticAt_weierstrassPExcept L (0 : ℂ)
+  have hP := L.kw_analyticAt_weierstrassP_add_zero hw
+  have hid : AnalyticAt ℂ (id : ℂ → ℂ) (0 : ℂ) := analyticAt_id
+  have hord_id : analyticOrderAt (id : ℂ → ℂ) (0 : ℂ) = 1 := analyticOrderAt_id
+  have hReq : L.kwAddBridgeR w =
+      (fun _ : ℂ => (8 : ℂ)) * ((id ^ 2 * L.weierstrassPExcept (0 : ℂ))
+        * ((fun z => ℘[L] (z + w)) - fun _ => ℘[L] w))
+        + (id : ℂ → ℂ) ^ 4 * L.kwAddBridgeT w := by
+    funext z
+    simp only [kwAddBridgeR, Pi.add_apply, Pi.mul_apply, Pi.pow_apply, Pi.sub_apply, id_eq]
+    ring
+  rw [hReq]
+  refine le_trans ?_ le_analyticOrderAt_add
+  refine le_min ?_ ?_
+  · rw [analyticOrderAt_mul analyticAt_const (((hid.pow 2).mul hg).mul (hP.sub analyticAt_const)),
+      analyticOrderAt_mul ((hid.pow 2).mul hg) (hP.sub analyticAt_const),
+      analyticOrderAt_mul (hid.pow 2) hg, analyticOrderAt_pow hid, hord_id]
+    calc (4 : ℕ∞) = 0 + ((2 • 1 + 2) + 0) := by norm_num
+      _ ≤ _ := add_le_add zero_le
+              (add_le_add (add_le_add le_rfl L.kw_weierstrassPExcept_zero_order_ge_two) zero_le)
+  · rw [analyticOrderAt_mul (hid.pow 4) (L.kw_analyticAt_addBridgeT hw),
+      analyticOrderAt_pow hid, hord_id]
+    calc (4 : ℕ∞) = 4 • 1 + 0 := by norm_num
+      _ ≤ _ := add_le_add le_rfl zero_le
+
+p2m_export "PeriodPair" "kw_addBridgeR_order_ge_four"
+
+private def _root_.PeriodPair.kwAddΦ (w : ℂ) (z : ℂ) : ℂ :=
+  4 * (℘[L] z - ℘[L] w) ^ 2 * (℘[L] (z + w) + ℘[L] z + ℘[L] w)
+    - (℘'[L] z - ℘'[L] w) ^ 2
+
+p2m_export "PeriodPair" "kwAddΦ"
+
+private theorem _root_.PeriodPair.kw_addΦ_diffEq {z : ℂ} (hz : z ∉ L.lattice) (hw : w ∉ L.lattice) :
+    L.kwAddΦ w z = 4 * (℘[L] z - ℘[L] w) ^ 2 * ℘[L] (z + w)
+      - 4 * ℘[L] w * ℘[L] z ^ 2 - 4 * ℘[L] w ^ 2 * ℘[L] z
+      + L.g₂ * (℘[L] z + ℘[L] w) + 2 * L.g₃ + 2 * ℘'[L] z * ℘'[L] w := by
+  have hdz := L.derivWeierstrassP_sq z hz
+  have hdw := L.derivWeierstrassP_sq w hw
+  unfold kwAddΦ
+  linear_combination -hdz - hdw
+
+p2m_export "PeriodPair" "kw_addΦ_diffEq"
+
+private theorem _root_.PeriodPair.kw_addBridge_identity {z : ℂ} (hz : z ∉ L.lattice)
+    (hw : w ∉ L.lattice)
+    (hz0 : z ≠ 0) :
+    z ^ 4 * L.kwAddΦ w z = L.kwAddCoreE w z + L.kwAddBridgeR w z := by
+  have hPz : ℘[L] z = (z ^ 2)⁻¹ + L.weierstrassPExcept (0 : ℂ) z := by
+    have h := PeriodPair.weierstrassPExcept_add L ⟨0, zero_mem _⟩ z
+    simp only [sub_zero, ne_eq, OfNat.ofNat_ne_zero, not_false_eq_true,
+      zero_pow, div_zero, one_div] at h
+    linear_combination -h
+  have hP'z : ℘'[L] z = -2 * (z ^ 3)⁻¹ + L.derivWeierstrassPExcept (0 : ℂ) z := by
+    have h := PeriodPair.derivWeierstrassPExcept_sub L ⟨0, zero_mem _⟩ z
+    simp only [sub_zero] at h
+    have hr : (2 : ℂ) / z ^ 3 = 2 * (z ^ 3)⁻¹ := by ring
+    rw [hr] at h
+    linear_combination -h
+  rw [L.kw_addΦ_diffEq hz hw, hPz, hP'z]
+  unfold kwAddCoreE kwAddBridgeR kwAddBridgeT
+  field_simp
+  ring
+
+p2m_export "PeriodPair" "kw_addBridge_identity"
+
+private theorem _root_.PeriodPair.kw_addCoreE_add_R_order_ge_four (hw : w ∉ L.lattice) :
+    (4 : ℕ∞) ≤ analyticOrderAt (fun z => L.kwAddCoreE w z + L.kwAddBridgeR w z) 0 := by
+  refine le_trans ?_ le_analyticOrderAt_add
+  exact le_min (L.kw_addCoreE_order_ge_four hw) (L.kw_addBridgeR_order_ge_four hw)
+
+p2m_export "PeriodPair" "kw_addCoreE_add_R_order_ge_four"
+end PeriodPair
+
+end
+
+noncomputable section
+
+p2m_open_scoped "PeriodPair P2MW.S_PeriodPair_isUniformization_toPoint.PeriodPair Topology \
+  P2MW.S_PeriodPair_isUniformization_toPoint.Topology"
+p2m_open "Filter P2MW.S_PeriodPair_isUniformization_toPoint.Filter Set \
+  P2MW.S_PeriodPair_isUniformization_toPoint.Set Complex \
+  P2MW.S_PeriodPair_isUniformization_toPoint.Complex WeierstrassCurve \
+  P2MW.S_PeriodPair_isUniformization_toPoint.WeierstrassCurve"
+
+namespace PeriodPair
+p2m_export "PeriodPair" "analyticAt_weierstrassPExcept ω₁_div_two_notMem_lattice isClosed_lattice \
+  derivWeierstrassP_neg derivWeierstrassPExcept_sub weierstrassP_neg lattice weierstrassPExcept \
+  analyticOnNhd_weierstrassPExcept isClosed_of_subset_lattice weierstrassP_add_coe \
+  order_weierstrassP lattice_eq_span_range_basis isOpen_compl_lattice_diff ω₁ \
+  weierstrassPExcept_zero analyticOnNhd_derivWeierstrassP analyticAt_derivWeierstrassPExcept \
+  deriv_weierstrassPExcept_same g₃ weierstrassPExcept_add deriv_weierstrassP \
+  derivWeierstrassPExcept_zero_zero derivWeierstrassP_sq ω₂ derivWeierstrassP_add_coe mem_lattice \
+  derivWeierstrassPExcept compl_lattice_diff_singleton_mem_nhds G g₂ analyticOnNhd_weierstrassP \
+  weierstrassCurve weierstrassCurve_a₁ weierstrassCurve_a₂ weierstrassCurve_a₃ weierstrassCurve_Δ \
+  weierstrassCurve_c₄ equation_weierstrassP DiscriminantNeZero toPoint toPoint_of_mem toPoint_zero \
+  toPoint_of_notMem IsUniformization jLattice JSurjective ofTau scale sublatticeIndex \
+  discriminant_ne_zero"
+p2m_open "PeriodPair"
+
+variable (L : PeriodPair) {w : ℂ}
+
+private def _root_.PeriodPair.kwAddΦDomain (w : ℂ) :
+    Set ℂ := {z | z ∉ L.lattice ∧ z + w ∉ L.lattice}
+
+p2m_export "PeriodPair" "kwAddΦDomain"
+private theorem _root_.PeriodPair.kw_isOpen_addΦDomain : IsOpen (L.kwAddΦDomain w) :=
+  L.isClosed_lattice.isOpen_compl.inter
+    (L.isClosed_lattice.isOpen_compl.preimage (continuous_id.add continuous_const))
+
+p2m_export "PeriodPair" "kw_isOpen_addΦDomain"
+
+private theorem _root_.PeriodPair.kw_addΦ_periodic (l : ℂ) (hl : l ∈ L.lattice) (z : ℂ) :
+    L.kwAddΦ w (z + l) = L.kwAddΦ w z := by
+  unfold kwAddΦ
+  rw [L.weierstrassP_add_coe z ⟨l, hl⟩, L.derivWeierstrassP_add_coe z ⟨l, hl⟩,
+    show z + l + w = z + w + l from by ring, L.weierstrassP_add_coe (z + w) ⟨l, hl⟩]
+
+p2m_export "PeriodPair" "kw_addΦ_periodic"
+
+private theorem _root_.PeriodPair.kw_addΦ_self_eq_zero : L.kwAddΦ w w = 0 := by
+  unfold kwAddΦ; ring
+
+p2m_export "PeriodPair" "kw_addΦ_self_eq_zero"
+
+private theorem _root_.PeriodPair.kw_analyticAt_weierstrassP_add {z : ℂ} (hzw : z + w ∉ L.lattice) :
+    AnalyticAt ℂ (fun u => ℘[L] (u + w)) z := by
+  have hd : DifferentiableOn ℂ (fun u => ℘[L] (u + w)) {u : ℂ | u + w ∉ L.lattice} := fun u hu =>
+    (L.kw_hasDerivAt_weierstrassP_add hu).differentiableAt.differentiableWithinAt
+  exact hd.analyticOnNhd
+    (L.isClosed_lattice.isOpen_compl.preimage (continuous_id.add continuous_const)) z hzw
+
+p2m_export "PeriodPair" "kw_analyticAt_weierstrassP_add"
+
+private theorem _root_.PeriodPair.kw_analyticAt_derivWeierstrassP_add {z : ℂ}
+    (hzw : z + w ∉ L.lattice) :
+    AnalyticAt ℂ (fun u => ℘'[L] (u + w)) z := by
+  have hd : DifferentiableOn ℂ (fun u => ℘'[L] (u + w)) {u : ℂ | u + w ∉ L.lattice} := fun u hu =>
+    ((L.analyticOnNhd_derivWeierstrassP (u + w) hu).differentiableAt.comp u
+      (differentiableAt_id.add_const w)).differentiableWithinAt
+  exact hd.analyticOnNhd
+    (L.isClosed_lattice.isOpen_compl.preimage (continuous_id.add continuous_const)) z hzw
+
+p2m_export "PeriodPair" "kw_analyticAt_derivWeierstrassP_add"
+
+private theorem _root_.PeriodPair.kw_analyticOnNhd_addΦ :
+    AnalyticOnNhd ℂ (L.kwAddΦ w) (L.kwAddΦDomain w) := by
+  intro z ⟨hz, hzw⟩
+  have hP := L.analyticOnNhd_weierstrassP z hz
+  have hP' := L.analyticOnNhd_derivWeierstrassP z hz
+  have hPw := L.kw_analyticAt_weierstrassP_add hzw
+  unfold kwAddΦ
+  fun_prop
+
+p2m_export "PeriodPair" "kw_analyticOnNhd_addΦ"
+
+private theorem _root_.PeriodPair.kw_addΦ_removable_at_zero (hw : w ∉ L.lattice) :
+    ∃ B, AnalyticAt ℂ B (0 : ℂ) ∧ L.kwAddΦ w =ᶠ[𝓝[≠] (0 : ℂ)] B := by
+  have hER : AnalyticAt ℂ (fun z => L.kwAddCoreE w z + L.kwAddBridgeR w z) 0 :=
+    (L.kw_analyticAt_addCoreE hw).add (L.kw_analyticAt_addBridgeR hw)
+  obtain ⟨B, hB_an, hB_eq⟩ := (natCast_le_analyticOrderAt hER).mp
+    (L.kw_addCoreE_add_R_order_ge_four hw)
+  refine ⟨B, hB_an, ?_⟩
+  filter_upwards [L.kw_compl_lattice_mem_nhdsNE 0,
+    mem_nhdsWithin_of_mem_nhds (L.kw_add_notMem_mem_nhds_zero hw),
+    self_mem_nhdsWithin, hB_eq.filter_mono nhdsWithin_le_nhds] with z hzL hzwL hz0 hzB
+  have hbridge := L.kw_addBridge_identity hzL hw hz0
+  rw [hzB] at hbridge
+  simp only [sub_zero, smul_eq_mul] at hbridge
+  exact mul_left_cancel₀ (pow_ne_zero 4 hz0) hbridge
+
+p2m_export "PeriodPair" "kw_addΦ_removable_at_zero"
+
+private theorem _root_.PeriodPair.kw_sq_mul_weierstrassP_add_eq {z : ℂ} (hz : z + w ≠ 0) :
+    (z + w) ^ 2 * ℘[L] (z + w) = 1 + (z + w) ^ 2 * L.weierstrassPExcept (0 : ℂ) (z + w) := by
+  have h := PeriodPair.weierstrassPExcept_add L ⟨0, zero_mem _⟩ (z + w)
+  simp only [sub_zero, ne_eq, OfNat.ofNat_ne_zero, not_false_eq_true,
+    zero_pow, div_zero, one_div] at h
+  rw [show ℘[L] (z + w) = ((z + w) ^ 2)⁻¹ + L.weierstrassPExcept (0 : ℂ) (z + w) from by
+    linear_combination -h, mul_add, mul_inv_cancel₀ (pow_ne_zero 2 hz)]
+
+p2m_export "PeriodPair" "kw_sq_mul_weierstrassP_add_eq"
+
+private theorem _root_.PeriodPair.kw_addΦ_removable_at_neg (hw : w ∉ L.lattice) :
+    ∃ B, AnalyticAt ℂ B (-w) ∧ L.kwAddΦ w =ᶠ[𝓝[≠] (-w)] B := by
+  have hnw : -w ∉ L.lattice := fun h => hw (by simpa using neg_mem h)
+  have hPw : ℘[L] (-w) = ℘[L] w := L.weierstrassP_neg w
+  have hP_an : AnalyticAt ℂ (fun z => ℘[L] z - ℘[L] w) (-w) :=
+    (L.analyticOnNhd_weierstrassP (-w) hnw).sub analyticAt_const
+  have hord : (1 : ℕ∞) ≤ analyticOrderAt (fun z => ℘[L] z - ℘[L] w) (-w) := by
+    rw [show (1 : ℕ∞) = ((1 : ℕ) : ℕ∞) from rfl,
+      natCast_le_analyticOrderAt_iff_iteratedDeriv_eq_zero hP_an]
+    intro i hi; interval_cases i
+    simp [hPw]
+  obtain ⟨g, hg_an, hg_eq⟩ := (natCast_le_analyticOrderAt hP_an).mp hord
+  refine ⟨fun z => 4 * g z ^ 2 *
+      (1 + (z + w) ^ 2 * L.weierstrassPExcept (0 : ℂ) (z + w) + (z + w) ^ 2 * (℘[L] z + ℘[L] w))
+    - (℘'[L] z - ℘'[L] w) ^ 2, ?_, ?_⟩
+  · have hE' : AnalyticAt ℂ (fun z => L.weierstrassPExcept (0 : ℂ) (z + w)) (-w) := by
+      have hd : DifferentiableOn ℂ (fun z => L.weierstrassPExcept (0 : ℂ) (z + w))
+          {z : ℂ | z + w ∉ (L.lattice : Set ℂ) \ {0}} := fun u hu =>
+        ((L.analyticOnNhd_weierstrassPExcept (0 : ℂ) (u + w)
+          hu).differentiableAt.comp u (differentiableAt_id.add_const w)).differentiableWithinAt
+      exact hd.analyticOnNhd
+        (L.isOpen_compl_lattice_sdiff.preimage (continuous_id.add continuous_const))
+        (-w) (by simp)
+    have hP := L.analyticOnNhd_weierstrassP (-w) hnw
+    have hP' := L.analyticOnNhd_derivWeierstrassP (-w) hnw
+    fun_prop
+  · have hmem : (L.lattice : Set ℂ)ᶜ ∈ 𝓝 (-w) := L.isClosed_lattice.isOpen_compl.mem_nhds hnw
+    filter_upwards [mem_nhdsWithin_of_mem_nhds hmem, self_mem_nhdsWithin,
+      hg_eq.filter_mono nhdsWithin_le_nhds] with z hzL hzne hzg
+    have hzw0 : z + w ≠ 0 := fun h => hzne (eq_neg_of_add_eq_zero_left h)
+    unfold kwAddΦ
+    simp only [sub_neg_eq_add, pow_one, smul_eq_mul] at hzg
+    have hsq := L.kw_sq_mul_weierstrassP_add_eq hzw0
+    rw [hzg]
+    linear_combination 4 * g z ^ 2 * hsq
+
+p2m_export "PeriodPair" "kw_addΦ_removable_at_neg"
+
+private theorem _root_.PeriodPair.kw_elliptic_Liouville_zero (hw : w ∉ L.lattice)
+    (h2w : 2 * w ∉ L.lattice)
+    {H : ℂ → ℂ} (hHan : AnalyticOnNhd ℂ H (L.kwAddΦDomain w))
+    (hHper : ∀ l ∈ L.lattice, ∀ z, H (z + l) = H z)
+    (hH0 : ∃ B, AnalyticAt ℂ B (0 : ℂ) ∧ H =ᶠ[𝓝[≠] (0 : ℂ)] B)
+    (hHnw : ∃ B, AnalyticAt ℂ B (-w) ∧ H =ᶠ[𝓝[≠] (-w)] B)
+    (hHw : H w = 0) {z : ℂ} (hz : z ∉ L.lattice) (hzw : z + w ∉ L.lattice) :
+    H z = 0 := by
+  classical
+  obtain ⟨B₀, hB₀_an, hB₀_eq⟩ := hH0
+  obtain ⟨B₁, hB₁_an, hB₁_eq⟩ := hHnw
+  let Φext : ℂ → ℂ := fun u => if u ∈ L.lattice then B₀ 0
+    else if u + w ∈ L.lattice then B₁ (-w) else H u
+  have hΦD : ∀ u ∈ L.kwAddΦDomain w, Φext u = H u := fun u ⟨h1, h2⟩ => by
+    simp only [Φext, ite_eq_right h1, ite_eq_right h2]
+  have hper : ∀ l ∈ L.lattice, ∀ u, Φext (u + l) = Φext u := by
+    intro l hl u
+    by_cases h1 : u ∈ L.lattice
+    · simp only [Φext, ite_eq_left h1, ite_eq_left (add_mem h1 hl)]
+    have h1' : u + l ∉ L.lattice := fun h => h1 (by simpa using sub_mem h hl)
+    by_cases h2 : u + w ∈ L.lattice
+    · have h2' : u + l + w ∈ L.lattice := by
+        rw [show u + l + w = u + w + l from by ring]; exact add_mem h2 hl
+      simp only [Φext, ite_eq_right h1, ite_eq_right h1', ite_eq_left h2, ite_eq_left h2']
+    · have h2' : u + l + w ∉ L.lattice := fun h => h2 (by
+        rw [show u + l + w = u + w + l from by ring] at h; simpa using sub_mem h hl)
+      rw [hΦD u ⟨h1, h2⟩, hΦD (u + l) ⟨h1', h2'⟩, hHper l hl u]
+  have hDdiff : DifferentiableOn ℂ Φext (L.kwAddΦDomain w) :=
+    hHan.differentiableOn.congr hΦD
+  have hdiff0 : DifferentiableAt ℂ Φext 0 := by
+    set s := ((L.lattice : Set ℂ) \ {0})ᶜ ∩ {u | u + w ∉ L.lattice} with hs_def
+    have hs_nhds : s ∈ 𝓝 (0 : ℂ) :=
+      Filter.inter_mem (L.compl_lattice_sdiff_singleton_mem_nhds 0)
+        (L.kw_add_notMem_mem_nhds_zero hw)
+    have hs_diff : s \ {(0 : ℂ)} = L.kwAddΦDomain w ∩ s := by
+      ext u; simp only [hs_def, Set.mem_sdiff, mem_inter_iff, mem_compl_iff, mem_singleton_iff,
+        mem_ofPred_eq, kwAddΦDomain]
+      constructor
+      · rintro ⟨⟨h1, h2⟩, h3⟩
+        exact ⟨⟨fun hu => h1 ⟨hu, h3⟩, h2⟩, ⟨h1, h2⟩⟩
+      · rintro ⟨⟨h1, h2⟩, h3⟩
+        exact ⟨h3, fun h => h1 (h ▸ zero_mem _)⟩
+    have hcont : ContinuousAt Φext 0 := by
+      rw [← continuousWithinAt_compl_self, ContinuousWithinAt,
+        show Φext 0 = B₀ 0 from ite_eq_left (zero_mem _)]
+      refine Tendsto.congr' ?_ (hB₀_an.continuousAt.continuousWithinAt)
+      filter_upwards [mem_nhdsWithin_of_mem_nhds hs_nhds, self_mem_nhdsWithin, hB₀_eq]
+        with u ⟨h1, h2⟩ h3 h4
+      rw [hΦD u ⟨fun hu => h1 ⟨hu, h3⟩, h2⟩, h4]
+    exact ((differentiableOn_compl_singleton_and_continuousAt_iff hs_nhds).mp
+      ⟨hs_diff ▸ hDdiff.mono inter_subset_left, hcont⟩).differentiableAt hs_nhds
+  have hnw : -w ∉ L.lattice := fun h => hw (by simpa using neg_mem h)
+  have hdiff_nw : DifferentiableAt ℂ Φext (-w) := by
+    set s := (L.lattice : Set ℂ)ᶜ ∩ ({u | u + w ∈ L.lattice} \ {-w})ᶜ with hs_def
+    have hs_nhds : s ∈ 𝓝 (-w) := by
+      refine Filter.inter_mem (L.isClosed_lattice.isOpen_compl.mem_nhds hnw) ?_
+      have hpre : {u : ℂ | u + w ∈ L.lattice} \ {-w} =
+          (· + w) ⁻¹' ((L.lattice : Set ℂ) \ {0}) := by
+        ext u
+        simp only [Set.mem_sdiff, mem_preimage, mem_singleton_iff, mem_ofPred_eq, SetLike.mem_coe,
+          and_congr_right_iff]
+        exact fun _ => ⟨fun h1 h2 => h1 (eq_neg_of_add_eq_zero_left h2),
+          fun h1 h2 => h1 (by rw [h2, _root_.neg_add_cancel])⟩
+      rw [hpre, ← Set.preimage_compl]
+      refine (continuous_add_const w).continuousAt.preimage_mem_nhds ?_
+      rw [_root_.neg_add_cancel]; exact L.compl_lattice_sdiff_singleton_mem_nhds 0
+    have hs_diff : s \ {-w} = L.kwAddΦDomain w ∩ s := by
+      ext u; simp only [hs_def, Set.mem_sdiff, mem_inter_iff, mem_compl_iff, mem_singleton_iff,
+        mem_ofPred_eq, kwAddΦDomain]
+      constructor
+      · rintro ⟨⟨h1, h2⟩, h3⟩
+        exact ⟨⟨h1, fun hu => h2 ⟨hu, h3⟩⟩, ⟨h1, h2⟩⟩
+      · rintro ⟨⟨h1, h2⟩, h3⟩
+        exact ⟨h3, fun h => h2 (h ▸ by simp)⟩
+    have hcont : ContinuousAt Φext (-w) := by
+      rw [← continuousWithinAt_compl_self, ContinuousWithinAt,
+        show Φext (-w) = B₁ (-w) from by
+          simp only [Φext, ite_eq_right hnw, _root_.neg_add_cancel, ite_eq_left (zero_mem _)]]
+      refine Tendsto.congr' ?_ (hB₁_an.continuousAt.continuousWithinAt)
+      filter_upwards [mem_nhdsWithin_of_mem_nhds hs_nhds, self_mem_nhdsWithin, hB₁_eq]
+        with u ⟨h1, h2⟩ h3 h4
+      rw [hΦD u ⟨h1, fun hu => h2 ⟨hu, h3⟩⟩, h4]
+    exact ((differentiableOn_compl_singleton_and_continuousAt_iff hs_nhds).mp
+      ⟨hs_diff ▸ hDdiff.mono inter_subset_left, hcont⟩).differentiableAt hs_nhds
+  have hshift : ∀ l ∈ L.lattice, Φext = fun v => Φext (v - l) := fun l hl =>
+    funext fun v => by rw [← hper l hl (v - l), sub_add_cancel]
+  have hdiff : Differentiable ℂ Φext := by
+    intro u
+    by_cases h1 : u ∈ L.lattice
+    · rw [hshift u h1]
+      exact DifferentiableAt.comp (f := fun v => v - u) u
+        (by simp only [sub_self]; exact hdiff0) (differentiableAt_id.sub_const u)
+    by_cases h2 : u + w ∈ L.lattice
+    · rw [hshift (u + w) h2]
+      exact DifferentiableAt.comp (f := fun v => v - (u + w)) u
+        (by simp only [sub_add_cancel_left]; exact hdiff_nw)
+        (differentiableAt_id.sub_const (u + w))
+    · exact (hDdiff u ⟨h1, h2⟩).differentiableAt (L.kw_isOpen_addΦDomain.mem_nhds ⟨h1, h2⟩)
+  have hconst := L.apply_eq_apply_of_differentiable_of_forall_periodic hdiff hper
+  have hwD : w ∈ L.kwAddΦDomain w := ⟨hw, by rwa [← two_mul]⟩
+  calc H z = Φext z := (hΦD z ⟨hz, hzw⟩).symm
+    _ = Φext w := hconst z w
+    _ = H w := hΦD w hwD
+    _ = 0 := hHw
+
+p2m_export "PeriodPair" "kw_elliptic_Liouville_zero"
+
+private theorem _root_.PeriodPair.kw_addΦ_eq_zero (hw : w ∉ L.lattice) (h2w : 2 * w ∉ L.lattice)
+    {z : ℂ} (hz : z ∉ L.lattice) (hzw : z + w ∉ L.lattice) :
+    L.kwAddΦ w z = 0 :=
+  L.kw_elliptic_Liouville_zero hw h2w L.kw_analyticOnNhd_addΦ (L.kw_addΦ_periodic)
+    (L.kw_addΦ_removable_at_zero hw) (L.kw_addΦ_removable_at_neg hw)
+    L.kw_addΦ_self_eq_zero hz hzw
+
+p2m_export "PeriodPair" "kw_addΦ_eq_zero"
+
+private theorem _root_.PeriodPair.kw_weierstrassP_add_eq_addX (hw : w ∉ L.lattice)
+    (h2w : 2 * w ∉ L.lattice)
+    {z : ℂ} (hz : z ∉ L.lattice) (hzw : z + w ∉ L.lattice) (hne : ℘[L] z ≠ ℘[L] w) :
+    ℘[L] (z + w) = L.weierstrassCurve.toAffine.addX (℘[L] z) (℘[L] w)
+      (L.weierstrassCurve.toAffine.slope (℘[L] z) (℘[L] w) (℘'[L] z / 2) (℘'[L] w / 2)) := by
+  have hΦ := L.kw_addΦ_eq_zero hw h2w hz hzw
+  unfold kwAddΦ at hΦ
+  rw [Affine.slope_of_X_ne hne, Affine.addX, weierstrassCurve_a₁, weierstrassCurve_a₂]
+  have hne' : ℘[L] z - ℘[L] w ≠ 0 := sub_ne_zero.mpr hne
+  field_simp
+  linear_combination hΦ
+
+p2m_export "PeriodPair" "kw_weierstrassP_add_eq_addX"
+
+private def _root_.PeriodPair.kwAddΨ (w : ℂ) (z : ℂ) : ℂ :=
+  (℘[L] z - ℘[L] w) * ℘'[L] (z + w) + (℘'[L] z - ℘'[L] w) * ℘[L] (z + w)
+    + ℘[L] z * ℘'[L] w - ℘[L] w * ℘'[L] z
+
+p2m_export "PeriodPair" "kwAddΨ"
+
+private theorem _root_.PeriodPair.kw_addΨ_periodic (l : ℂ) (hl : l ∈ L.lattice) (z : ℂ) :
+    L.kwAddΨ w (z + l) = L.kwAddΨ w z := by
+  unfold kwAddΨ
+  rw [L.weierstrassP_add_coe z ⟨l, hl⟩, L.derivWeierstrassP_add_coe z ⟨l, hl⟩,
+    show z + l + w = z + w + l from by ring, L.weierstrassP_add_coe (z + w) ⟨l, hl⟩,
+    L.derivWeierstrassP_add_coe (z + w) ⟨l, hl⟩]
+
+p2m_export "PeriodPair" "kw_addΨ_periodic"
+
+private theorem _root_.PeriodPair.kw_addΨ_self_eq_zero : L.kwAddΨ w w = 0 := by unfold kwAddΨ; ring
+
+p2m_export "PeriodPair" "kw_addΨ_self_eq_zero"
+
+private theorem _root_.PeriodPair.kw_analyticOnNhd_addΨ :
+    AnalyticOnNhd ℂ (L.kwAddΨ w) (L.kwAddΦDomain w) := by
+  intro z ⟨hz, hzw⟩
+  have hP := L.analyticOnNhd_weierstrassP z hz
+  have hP' := L.analyticOnNhd_derivWeierstrassP z hz
+  have hPw := L.kw_analyticAt_weierstrassP_add hzw
+  have hP'w := L.kw_analyticAt_derivWeierstrassP_add hzw
+  unfold kwAddΨ
+  fun_prop
+
+p2m_export "PeriodPair" "kw_analyticOnNhd_addΨ"
+
+private theorem _root_.PeriodPair.kw_addΨ_neg_sub (z : ℂ) :
+    L.kwAddΨ w (-z - w) = -L.kwAddΨ w z := by
+  unfold kwAddΨ
+  rw [show -z - w + w = -z from by ring, L.weierstrassP_neg, L.derivWeierstrassP_neg,
+    show -z - w = -(z + w) from by ring, L.weierstrassP_neg, L.derivWeierstrassP_neg]
+  ring
+
+p2m_export "PeriodPair" "kw_addΨ_neg_sub"
+
+private def _root_.PeriodPair.kwAddΨCoreE (w : ℂ) (z : ℂ) : ℂ :=
+  z * (℘'[L] (z + w) + ℘'[L] w) - 2 * (℘[L] (z + w) - ℘[L] w)
+
+p2m_export "PeriodPair" "kwAddΨCoreE"
+
+private theorem _root_.PeriodPair.kw_addΨCoreE_order_ge_three (hw : w ∉ L.lattice) :
+    (3 : ℕ∞) ≤ analyticOrderAt (L.kwAddΨCoreE w) (0 : ℂ) := by
+  have h0w : (0 : ℂ) + w ∉ L.lattice := by rwa [zero_add]
+  have hAn : AnalyticAt ℂ (L.kwAddΨCoreE w) 0 := by
+    unfold kwAddΨCoreE
+    have hP := L.kw_analyticAt_weierstrassP_add h0w
+    have hP' := L.kw_analyticAt_derivWeierstrassP_add h0w
+    fun_prop
+  rw [show (3 : ℕ∞) = ((3 : ℕ) : ℕ∞) from rfl,
+    natCast_le_analyticOrderAt_iff_iteratedDeriv_eq_zero hAn]
+  have hEΨ' : ∀ z, z + w ∉ L.lattice → HasDerivAt (L.kwAddΨCoreE w)
+      (-℘'[L] (z + w) + z * deriv ℘'[L] (z + w) + ℘'[L] w) z := by
+    intro z hzw
+    have hP := L.kw_hasDerivAt_weierstrassP_add hzw
+    have hP' : HasDerivAt (fun u => ℘'[L] (u + w)) (deriv ℘'[L] (z + w)) z :=
+      (L.analyticOnNhd_derivWeierstrassP (z + w) hzw).differentiableAt.hasDerivAt.comp_add_const z w
+    have hD : HasDerivAt (L.kwAddΨCoreE w)
+        ((1 * (℘'[L] (z + w) + ℘'[L] w) + z * deriv ℘'[L] (z + w))
+          - 2 * ℘'[L] (z + w)) z := by
+      unfold kwAddΨCoreE
+      exact ((hasDerivAt_id z).mul (hP'.add_const (℘'[L] w))).sub
+        ((hP.sub_const (℘[L] w)).const_mul 2)
+    convert hD using 1; ring
+  have hEΨ'' : deriv (deriv (L.kwAddΨCoreE w)) =ᶠ[𝓝 (0 : ℂ)]
+      fun z => z * deriv (deriv ℘'[L]) (z + w) := by
+    have hD : deriv (L.kwAddΨCoreE w) =ᶠ[𝓝 (0 : ℂ)]
+        fun z => -℘'[L] (z + w) + z * deriv ℘'[L] (z + w) + ℘'[L] w := by
+      filter_upwards [L.kw_add_notMem_mem_nhds_zero hw] with z hzw
+      exact (hEΨ' z hzw).deriv
+    refine hD.deriv.trans ?_
+    filter_upwards [L.kw_add_notMem_mem_nhds_zero hw] with z hzw
+    have hP' : HasDerivAt (fun u => ℘'[L] (u + w)) (deriv ℘'[L] (z + w)) z :=
+      (L.analyticOnNhd_derivWeierstrassP (z + w) hzw).differentiableAt.hasDerivAt.comp_add_const z w
+    have hP'' : HasDerivAt (fun u => deriv ℘'[L] (u + w)) (deriv (deriv ℘'[L]) (z + w)) z :=
+      ((L.analyticOnNhd_derivWeierstrassP (z + w)
+        hzw).deriv).differentiableAt.hasDerivAt.comp_add_const z w
+    have hD' : HasDerivAt (fun z => -℘'[L] (z + w) + z * deriv ℘'[L] (z + w) + ℘'[L] w)
+        (-deriv ℘'[L] (z + w) + (1 * deriv ℘'[L] (z + w) + z * deriv (deriv ℘'[L]) (z + w))) z :=
+      (hP'.neg.add ((hasDerivAt_id z).mul hP'')).add_const (℘'[L] w)
+    rw [hD'.deriv]; ring
+  intro i hi
+  interval_cases i
+  · simp [kwAddΨCoreE]
+  · simp only [iteratedDeriv_one, (hEΨ' 0 (by simpa using hw)).deriv, zero_mul, zero_add,
+      add_zero, _root_.neg_add_cancel]
+  · have : iteratedDeriv 2 (L.kwAddΨCoreE w) = deriv (deriv (L.kwAddΨCoreE w)) := by
+      rw [iteratedDeriv_succ, iteratedDeriv_one]
+    rw [this, hEΨ''.eq_of_nhds, zero_mul]
+
+p2m_export "PeriodPair" "kw_addΨCoreE_order_ge_three"
+
+private def _root_.PeriodPair.kwAddΨTail (w : ℂ) (z : ℂ) : ℂ :=
+  (L.weierstrassPExcept (0 : ℂ) z - ℘[L] w) * ℘'[L] (z + w)
+    + (L.derivWeierstrassPExcept (0 : ℂ) z - ℘'[L] w) * ℘[L] (z + w)
+    + L.weierstrassPExcept (0 : ℂ) z * ℘'[L] w
+    - ℘[L] w * L.derivWeierstrassPExcept (0 : ℂ) z
+
+p2m_export "PeriodPair" "kwAddΨTail"
+
+private theorem _root_.PeriodPair.kw_addΨ_cube_bridge {z : ℂ} (hz0 : z ≠ 0) :
+    z ^ 3 * L.kwAddΨ w z = L.kwAddΨCoreE w z + z ^ 3 * L.kwAddΨTail w z := by
+  have hPz : ℘[L] z = (z ^ 2)⁻¹ + L.weierstrassPExcept (0 : ℂ) z := by
+    have h := PeriodPair.weierstrassPExcept_add L ⟨0, zero_mem _⟩ z
+    simp only [sub_zero, ne_eq, OfNat.ofNat_ne_zero, not_false_eq_true, zero_pow,
+      div_zero, one_div] at h
+    linear_combination -h
+  have hP'z : ℘'[L] z = -2 * (z ^ 3)⁻¹ + L.derivWeierstrassPExcept (0 : ℂ) z := by
+    have h := PeriodPair.derivWeierstrassPExcept_sub L ⟨0, zero_mem _⟩ z
+    simp only [sub_zero] at h
+    rw [show (2 : ℂ) / z ^ 3 = 2 * (z ^ 3)⁻¹ from by ring] at h
+    linear_combination -h
+  unfold kwAddΨ kwAddΨCoreE kwAddΨTail
+  rw [hPz, hP'z]
+  field_simp
+  ring
+
+p2m_export "PeriodPair" "kw_addΨ_cube_bridge"
+
+private theorem _root_.PeriodPair.kw_addΨ_removable_at_zero (hw : w ∉ L.lattice) :
+    ∃ B, AnalyticAt ℂ B (0 : ℂ) ∧ L.kwAddΨ w =ᶠ[𝓝[≠] (0 : ℂ)] B := by
+  have h0w : (0 : ℂ) + w ∉ L.lattice := by rwa [zero_add]
+  have hT_an : AnalyticAt ℂ (L.kwAddΨTail w) 0 := by
+    unfold kwAddΨTail
+    have h1 := PeriodPair.analyticAt_weierstrassPExcept L (0 : ℂ)
+    have h2 := PeriodPair.analyticAt_derivWeierstrassPExcept L (0 : ℂ)
+    have h3 := L.kw_analyticAt_weierstrassP_add h0w
+    have h4 := L.kw_analyticAt_derivWeierstrassP_add h0w
+    fun_prop
+  have hSum_an : AnalyticAt ℂ (fun z => L.kwAddΨCoreE w z + z ^ 3 * L.kwAddΨTail w z) 0 := by
+    have hE : AnalyticAt ℂ (L.kwAddΨCoreE w) 0 := by
+      unfold kwAddΨCoreE
+      have hP := L.kw_analyticAt_weierstrassP_add h0w
+      have hP' := L.kw_analyticAt_derivWeierstrassP_add h0w
+      fun_prop
+    fun_prop
+  have hord : (3 : ℕ∞) ≤
+      analyticOrderAt (fun z => L.kwAddΨCoreE w z + z ^ 3 * L.kwAddΨTail w z) 0 := by
+    refine le_trans ?_ le_analyticOrderAt_add
+    refine le_min (L.kw_addΨCoreE_order_ge_three hw) ?_
+    have heq : (fun z => z ^ 3 * L.kwAddΨTail w z) = (id : ℂ → ℂ) ^ 3 * L.kwAddΨTail w := by
+      funext z; simp
+    rw [heq, analyticOrderAt_mul (analyticAt_id.pow 3) hT_an,
+      analyticOrderAt_pow analyticAt_id, analyticOrderAt_id]
+    calc (3 : ℕ∞) = 3 • 1 + 0 := by norm_num
+      _ ≤ _ := add_le_add le_rfl zero_le
+  obtain ⟨B, hB_an, hB_eq⟩ := (natCast_le_analyticOrderAt hSum_an).mp hord
+  refine ⟨B, hB_an, ?_⟩
+  filter_upwards [self_mem_nhdsWithin, hB_eq.filter_mono nhdsWithin_le_nhds] with z hz0 hzB
+  have hbridge := L.kw_addΨ_cube_bridge (w := w) hz0
+  simp only [sub_zero, smul_eq_mul] at hzB
+  rw [hzB] at hbridge
+  exact mul_left_cancel₀ (pow_ne_zero 3 hz0) hbridge
+
+p2m_export "PeriodPair" "kw_addΨ_removable_at_zero"
+
+private theorem _root_.PeriodPair.kw_addΨ_removable_at_neg (hw : w ∉ L.lattice) :
+    ∃ B, AnalyticAt ℂ B (-w) ∧ L.kwAddΨ w =ᶠ[𝓝[≠] (-w)] B := by
+  obtain ⟨B₀, hB₀_an, hB₀_eq⟩ := L.kw_addΨ_removable_at_zero hw
+  refine ⟨fun z => -B₀ (-z - w), ?_, ?_⟩
+  · have hinner : AnalyticAt ℂ (fun z : ℂ => -z - w) (-w) :=
+      (analyticAt_neg.mpr analyticAt_id).sub analyticAt_const
+    exact (AnalyticAt.comp (by simpa using hB₀_an) hinner).neg
+  · have hmap : Tendsto (fun z : ℂ => -z - w) (𝓝[≠] (-w)) (𝓝[≠] (0 : ℂ)) := by
+      refine tendsto_nhdsWithin_of_tendsto_nhds_of_eventually_within _ ?_ ?_
+      · have hc : Continuous (fun z : ℂ => -z - w) := by continuity
+        simpa using (hc.tendsto (-w)).mono_left nhdsWithin_le_nhds
+      · filter_upwards [self_mem_nhdsWithin] with z hz
+        simp only [mem_compl_iff, mem_singleton_iff] at hz ⊢
+        exact fun h => hz (by linear_combination -h)
+    filter_upwards [hB₀_eq.comp_tendsto hmap] with z hz
+    simp only [Function.comp_apply] at hz
+    rw [← neg_neg (L.kwAddΨ w z), ← L.kw_addΨ_neg_sub, hz]
+
+p2m_export "PeriodPair" "kw_addΨ_removable_at_neg"
+
+private theorem _root_.PeriodPair.kw_addΨ_eq_zero (hw : w ∉ L.lattice) (h2w : 2 * w ∉ L.lattice)
+    {z : ℂ} (hz : z ∉ L.lattice) (hzw : z + w ∉ L.lattice) :
+    L.kwAddΨ w z = 0 :=
+  L.kw_elliptic_Liouville_zero hw h2w L.kw_analyticOnNhd_addΨ (L.kw_addΨ_periodic)
+    (L.kw_addΨ_removable_at_zero hw) (L.kw_addΨ_removable_at_neg hw)
+    L.kw_addΨ_self_eq_zero hz hzw
+
+p2m_export "PeriodPair" "kw_addΨ_eq_zero"
+
+private theorem _root_.PeriodPair.kw_derivWeierstrassP_add_eq_addY (hw : w ∉ L.lattice)
+    (h2w : 2 * w ∉ L.lattice)
+    {z : ℂ} (hz : z ∉ L.lattice) (hzw : z + w ∉ L.lattice) (hne : ℘[L] z ≠ ℘[L] w) :
+    ℘'[L] (z + w) / 2 = L.weierstrassCurve.toAffine.addY (℘[L] z) (℘[L] w) (℘'[L] z / 2)
+      (L.weierstrassCurve.toAffine.slope (℘[L] z) (℘[L] w) (℘'[L] z / 2) (℘'[L] w / 2)) := by
+  have hΨ := L.kw_addΨ_eq_zero hw h2w hz hzw
+  have hX := L.kw_weierstrassP_add_eq_addX hw h2w hz hzw hne
+  unfold kwAddΨ at hΨ
+  have hne' : ℘[L] z - ℘[L] w ≠ 0 := sub_ne_zero.mpr hne
+  have hdw : ℘'[L] (z + w) = (-(℘'[L] z - ℘'[L] w) * ℘[L] (z + w)
+      - ℘[L] z * ℘'[L] w + ℘[L] w * ℘'[L] z) / (℘[L] z - ℘[L] w) := by
+    rw [eq_div_iff hne']; linear_combination hΨ
+  rw [hdw, hX, Affine.addY, Affine.negY, Affine.negAddY, Affine.addX,
+    Affine.slope_of_X_ne hne, weierstrassCurve_a₁, weierstrassCurve_a₂, weierstrassCurve_a₃]
+  field_simp
+  ring
+
+p2m_export "PeriodPair" "kw_derivWeierstrassP_add_eq_addY"
+
+private theorem _root_.PeriodPair.kw_toPoint_add_generic (hD : L.DiscriminantNeZero)
+    (hw : w ∉ L.lattice) (h2w : 2 * w ∉ L.lattice)
+    {z : ℂ} (hz : z ∉ L.lattice) (hzw : z + w ∉ L.lattice) (hne : ℘[L] z ≠ ℘[L] w) :
+    L.toPoint hD (z + w) = L.toPoint hD z + L.toPoint hD w := by
+  rw [L.toPoint_of_notMem hD hz, L.toPoint_of_notMem hD hw, L.toPoint_of_notMem hD hzw,
+    Affine.Point.add_of_X_ne hne]
+  simp only [Affine.Point.some.injEq]
+  exact ⟨L.kw_weierstrassP_add_eq_addX hw h2w hz hzw hne,
+    L.kw_derivWeierstrassP_add_eq_addY hw h2w hz hzw hne⟩
+
+p2m_export "PeriodPair" "kw_toPoint_add_generic"
+
+private theorem _root_.PeriodPair.kw_countable_analytic_level {f : ℂ → ℂ}
+    (hf : AnalyticOnNhd ℂ f (L.lattice : Set ℂ)ᶜ)
+    (hfnc : ∃ z ∉ L.lattice, f z ≠ 0) :
+    {z | z ∉ L.lattice ∧ f z = 0}.Countable := by
+  rcases hf.eqOn_zero_or_eventually_ne_zero_of_preconnected
+    L.kw_isPreconnected_compl_lattice with heq | hne
+  · obtain ⟨z, hz, hfz⟩ := hfnc
+    exact absurd (heq hz) hfz
+  · have hD : IsDiscrete ({z | f z = 0} ∩ (L.lattice : Set ℂ)ᶜ) := by
+      refine isDiscrete_of_codiscreteWithin ?_
+      simp only [Set.compl_ofPred] at hne ⊢
+      exact hne
+    have := hD.to_subtype
+    have hcount : Countable ({z | f z = 0} ∩ (L.lattice : Set ℂ)ᶜ : Set ℂ) :=
+      countable_of_Lindelof_of_discrete
+    refine (Set.countable_coe_iff.mp hcount).mono fun z hz => ?_
+    exact Set.mem_inter hz.2 hz.1
+
+p2m_export "PeriodPair" "kw_countable_analytic_level"
+
+private theorem _root_.PeriodPair.kw_countable_weierstrassP_eq (c : ℂ) :
+    {z | z ∉ L.lattice ∧ ℘[L] z = c}.Countable := by
+  obtain ⟨z₁, hz₁, hPz₁⟩ := L.kw_weierstrassP_surjective (c + 1)
+  have h := L.kw_countable_analytic_level (f := fun z => ℘[L] z - c)
+    (L.analyticOnNhd_weierstrassP.sub analyticOnNhd_const)
+    ⟨z₁, hz₁, by simp [hPz₁]⟩
+  refine h.mono fun z hz => ?_
+  exact ⟨hz.1, sub_eq_zero.mpr hz.2⟩
+
+p2m_export "PeriodPair" "kw_countable_weierstrassP_eq"
+
+private theorem _root_.PeriodPair.kw_countable_derivWeierstrassP_zero :
+    {z | z ∉ L.lattice ∧ ℘'[L] z = 0}.Countable := by
+  refine L.kw_countable_analytic_level L.analyticOnNhd_derivWeierstrassP ?_
+  by_contra! hall
+  obtain ⟨z₀, hz₀, hPz₀⟩ := L.kw_weierstrassP_surjective 0
+  obtain ⟨z₁, hz₁, hPz₁⟩ := L.kw_weierstrassP_surjective 1
+  have hderiv : ∀ x ∈ (L.lattice : Set ℂ)ᶜ, fderiv ℂ ℘[L] x = 0 := fun x hx => by
+    have hd : deriv ℘[L] x = 0 := by rw [L.deriv_weierstrassP]; exact hall x hx
+    ext1; simp [hd]
+  have hconst := L.isClosed_lattice.isOpen_compl.is_const_of_fderiv_eq_zero
+    L.kw_isPreconnected_compl_lattice L.analyticOnNhd_weierstrassP.differentiableOn
+    hderiv hz₀ hz₁
+  rw [hPz₀, hPz₁] at hconst
+  exact zero_ne_one hconst
+
+p2m_export "PeriodPair" "kw_countable_derivWeierstrassP_zero"
+
+private theorem _root_.PeriodPair.kw_exists_generic_perturbation (z : ℂ) :
+    ∃ u : ℂ, u ∉ L.lattice ∧ 2 * u ∉ L.lattice ∧ z + u ∉ L.lattice ∧ w + u ∉ L.lattice ∧
+      z + w + u ∉ L.lattice ∧ 2 * (w + u) ∉ L.lattice ∧
+      ℘'[L] u ≠ 0 ∧ ℘'[L] (w + u) ≠ 0 ∧
+      ℘[L] z ≠ ℘[L] u ∧ ℘[L] w ≠ ℘[L] u ∧ ℘[L] (z + w) ≠ ℘[L] u ∧ ℘[L] z ≠ ℘[L] (w + u) := by
+  classical
+  have hLc := L.kw_countable_lattice
+  set S : Set ℂ := (L.lattice : Set ℂ) ∪ {u | 2 * u ∈ L.lattice} ∪ {u | z + u ∈ L.lattice}
+    ∪ {u | w + u ∈ L.lattice} ∪ {u | z + w + u ∈ L.lattice} ∪ {u | 2 * (w + u) ∈ L.lattice}
+    ∪ {u | u ∉ L.lattice ∧ ℘'[L] u = 0} ∪ {u | w + u ∉ L.lattice ∧ ℘'[L] (w + u) = 0}
+    ∪ {u | u ∉ L.lattice ∧ ℘[L] u = ℘[L] z} ∪ {u | u ∉ L.lattice ∧ ℘[L] u = ℘[L] w}
+    ∪ {u | u ∉ L.lattice ∧ ℘[L] u = ℘[L] (z + w)}
+    ∪ {u | w + u ∉ L.lattice ∧ ℘[L] (w + u) = ℘[L] z} with hS_def
+  have hSc : S.Countable := by
+    have hinj : ∀ c : ℂ, Function.Injective (fun u : ℂ => c + u) := fun c => add_right_injective c
+    have hinj2 : Function.Injective (fun u : ℂ => 2 * u) :=
+      mul_right_injective₀ two_ne_zero
+    refine ((((((((((hLc.union (hLc.preimage hinj2)).union
+      (hLc.preimage (hinj z))).union (hLc.preimage (hinj w))).union
+      (hLc.preimage (hinj (z + w)))).union
+      (hLc.preimage (hinj2.comp (hinj w)))).union
+      L.kw_countable_derivWeierstrassP_zero).union
+      (L.kw_countable_derivWeierstrassP_zero.preimage (hinj w))).union
+      (L.kw_countable_weierstrassP_eq (℘[L] z))).union
+      (L.kw_countable_weierstrassP_eq (℘[L] w))).union
+      (L.kw_countable_weierstrassP_eq (℘[L] (z + w)))).union
+      ((L.kw_countable_weierstrassP_eq (℘[L] z)).preimage (hinj w))
+  have hSne : Sᶜ.Nonempty := by
+    rw [Set.nonempty_compl]
+    exact fun hSu => not_countable_complex (hSu ▸ hSc)
+  obtain ⟨u, hu⟩ := hSne
+  simp only [hS_def, Set.compl_union, Set.mem_inter_iff, Set.mem_compl_iff, Set.mem_ofPred_eq,
+    not_and] at hu
+  obtain ⟨⟨⟨⟨⟨⟨⟨⟨⟨⟨⟨h1, h2⟩, h3⟩, h4⟩, h5⟩, h6⟩, h7⟩, h8⟩, h9⟩, h10⟩, h11⟩, h12⟩ := hu
+  exact ⟨u, h1, h2, h3, h4, h5, h6, h7 h1, h8 h4, Ne.symm (h9 h1), Ne.symm (h10 h1),
+    Ne.symm (h11 h1), Ne.symm (h12 h4)⟩
+
+p2m_export "PeriodPair" "kw_exists_generic_perturbation"
+
+private theorem _root_.PeriodPair.kw_toPoint_add (hD : L.DiscriminantNeZero) (z w : ℂ) :
+    L.toPoint hD (z + w) = L.toPoint hD z + L.toPoint hD w := by
+  by_cases hz : z ∈ L.lattice
+  · rw [L.toPoint_of_mem hD hz, zero_add, add_comm, L.toPoint_add_mem hD w hz]
+  by_cases hw : w ∈ L.lattice
+  · rw [L.toPoint_of_mem hD hw, add_zero, L.toPoint_add_mem hD z hw]
+  by_cases hzw : z + w ∈ L.lattice
+  · rw [L.toPoint_of_mem hD hzw]
+    have : L.toPoint hD w = L.toPoint hD (-z) := by
+      rw [show w = -z + (z + w) from by ring, L.toPoint_add_mem hD (-z) hzw]
+    rw [this, L.toPoint_neg, add_neg_cancel]
+  obtain ⟨u, hu, h2u, -, hwu, hzwu, h2wu, -, -, -, hne_wu, hne_zwu, hne_zwuP⟩ :=
+    L.kw_exists_generic_perturbation (w := w) z
+  have A2 := L.kw_toPoint_add_generic hD hu h2u hw hwu hne_wu
+  have A3 := L.kw_toPoint_add_generic hD hu h2u hzw hzwu hne_zwu
+  have A4 := L.kw_toPoint_add_generic hD hwu h2wu hz
+    (by rwa [show z + (w + u) = z + w + u from by ring]) hne_zwuP
+  have hchain : L.toPoint hD (z + w) + L.toPoint hD u =
+      L.toPoint hD z + L.toPoint hD w + L.toPoint hD u := by
+    rw [← A3, show z + w + u = z + (w + u) from by ring, A4, A2]
+    abel
+  exact add_right_cancel hchain
+
+p2m_export "PeriodPair" "kw_toPoint_add"
+end PeriodPair
+
+end
+
+noncomputable section
+
+namespace PeriodPair
+p2m_export "PeriodPair" "analyticAt_weierstrassPExcept ω₁_div_two_notMem_lattice isClosed_lattice \
+  derivWeierstrassP_neg derivWeierstrassPExcept_sub weierstrassP_neg lattice weierstrassPExcept \
+  analyticOnNhd_weierstrassPExcept isClosed_of_subset_lattice weierstrassP_add_coe \
+  order_weierstrassP lattice_eq_span_range_basis isOpen_compl_lattice_diff ω₁ \
+  weierstrassPExcept_zero analyticOnNhd_derivWeierstrassP analyticAt_derivWeierstrassPExcept \
+  deriv_weierstrassPExcept_same g₃ weierstrassPExcept_add deriv_weierstrassP \
+  derivWeierstrassPExcept_zero_zero derivWeierstrassP_sq ω₂ derivWeierstrassP_add_coe mem_lattice \
+  derivWeierstrassPExcept compl_lattice_diff_singleton_mem_nhds G g₂ analyticOnNhd_weierstrassP \
+  weierstrassCurve weierstrassCurve_a₁ weierstrassCurve_a₂ weierstrassCurve_a₃ weierstrassCurve_Δ \
+  weierstrassCurve_c₄ equation_weierstrassP DiscriminantNeZero toPoint toPoint_of_mem toPoint_zero \
+  toPoint_of_notMem IsUniformization jLattice JSurjective ofTau scale sublatticeIndex \
+  discriminant_ne_zero"
+p2m_open "PeriodPair"
+
+private theorem _root_.PeriodPair.kw_isUniformization (L : PeriodPair) :
+    L.IsUniformization L.discriminant_ne_zero :=
+  ⟨L.kw_toPoint_add L.discriminant_ne_zero,
+   L.kw_toPoint_surjective L.discriminant_ne_zero,
+   fun z => (L.kw_toPoint_eq_zero_iff L.discriminant_ne_zero z).mp⟩
+
+p2m_export "PeriodPair" "kw_isUniformization"
+end PeriodPair
+
+end
+
+theorem solution (L : PeriodPair) (h : L.DiscriminantNeZero) : L.IsUniformization h :=
+  L.kw_isUniformization
+
+end S_PeriodPair_isUniformization_toPoint
+end P2MW
+export P2MW.S_PeriodPair_isUniformization_toPoint (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem PeriodPair.isUniformization_toPoint (L : PeriodPair) (h : L.DiscriminantNeZero) :
+    L.IsUniformization h :=
+  solution L h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_jLattice_ofTau.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_jLattice_ofTau.lean
new file mode 100644
index 0000000000..a34886cdc3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_jLattice_ofTau.lean
@@ -0,0 +1,186 @@
+/-
+Based on Prove2Me node PeriodPair.jLattice_ofTau
+(e347fa49-29e8-5478-bedd-7d8c08d463f9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3f277ff3-358e-549f-85b3-f6add7c61fd1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_PeriodPair_Uniformization
+
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+
+/-!
+# Lattice j-invariant of ℤτ+ℤ equals E₄³/Δ
+
+Theorem statement: `PeriodPair.jLattice_ofTau` (`e347fa49-29e8-5478-bedd-7d8c08d463f9`), by Claude,
+2026-09-05.
+
+Proof: submission `3f277ff3-358e-549f-85b3-f6add7c61fd1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\tau$ be a point of the upper half-plane $\mathbb{H}$. Associated with $\tau$ is the period
+pair [`PeriodPair.ofTau τ`](def/PeriodPair_Uniformization.html#L104) with $\omega_1 = \tau$,
+$\omega_2 = 1$, the required $\mathbb{R}$-linear independence of the pair $(\tau, 1)$ in
+$\mathbb{C}$ being supplied by the fact that $\tau$ has nonzero imaginary part; the associated
+lattice is thus $\Lambda_\tau = \mathbb{Z}\tau + \mathbb{Z}$. For a period pair $L$ the quantity
+`jLattice` is defined to be the complex number $1728\,g_2(L)^3/\bigl(g_2(L)^3 - 27\,g_3(L)^2\bigr)$,
+where $g_2$ and $g_3$ are the Weierstrass invariants of $L$. The theorem asserts the equality in
+$\mathbb{C}$ $$\mathrm{jLattice}(\Lambda_\tau) \;=\; \frac{E_4(\tau)^3}{\Delta(\tau)},$$ where $E_4$
+is Mathlib's normalised weight-four level-one Eisenstein series `ModularForm.E₄` and $\Delta$ is
+Mathlib's modular discriminant `ModularForm.discriminant`. No hypothesis beyond $\tau \in
+\mathbb{H}$ is imposed: both sides are quotients formed with the field division of $\mathbb{C}$, and
+the relevant denominators are in fact nonzero.
+
+This is the classical identification of the $j$-invariant of the lattice $\mathbb{Z}\tau +
+\mathbb{Z}$, formed from the Weierstrass invariants $g_2, g_3$, with the value at $\tau$ of the
+modular function $j = E_4^3/\Delta$. It links the lattice-theoretic uniformisation theory to the
+analytic, $q$-expansion side, and is used in the proof that `jLattice` of a lattice with cyclic
+quotient is a root of the relevant modular polynomial, via
+[`ModularCurve.ModularPolynomialData.eval_jLattice_eq_zero_of_isAddCyclic`]
+(thm.html#ModularCurve.ModularPolynomialData.eval_jLattice_eq_zero_of_isAddCyclic).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_PeriodPair_jLattice_ofTau.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+noncomputable section
+
+open UpperHalfPlane Complex
+
+namespace PeriodPair
+
+theorem kw_ofTau_latticeEquivProd_symm_apply (τ : ℍ) (p : ℤ × ℤ) :
+    ((ofTau τ).latticeEquivProd.symm p : ℂ) = p.1 * (τ : ℂ) + p.2 := by
+  rw [latticeEquiv_symm_apply]; simp
+
+end PeriodPair
+
+end
+
+noncomputable section
+
+open scoped UpperHalfPlane Real
+open Complex UpperHalfPlane EisensteinSeries ModularForm
+
+namespace PeriodPair
+
+theorem kw_G_ofTau_eq {k : ℕ} (hk : 3 ≤ k) (τ : ℍ) :
+    (ofTau τ).G k = 2 * riemannZeta k * E hk τ := by
+  rw [G, ← (ofTau τ).latticeEquivProd.symm.toEquiv.tsum_eq]
+  simp only [LinearEquiv.coe_toEquiv, kw_ofTau_latticeEquivProd_symm_apply]
+  have hstep : ∀ p : ℤ × ℤ,
+      ((↑p.1 * (τ : ℂ) + ↑p.2) ^ k)⁻¹ = eisSummand k ((finTwoArrowEquiv ℤ).symm p) τ := by
+    intro p
+    simp only [eisSummand, finTwoArrowEquiv_symm_apply, Matrix.cons_val_zero,
+      Matrix.cons_val_one, Matrix.cons_val_fin_one, _root_.zpow_neg, zpow_natCast]
+  simp only [hstep]
+  rw [(finTwoArrowEquiv ℤ).symm.tsum_eq (f := fun v => eisSummand (k : ℤ) v τ),
+    tsum_eisSummand_eq_riemannZeta_mul_eisensteinSeries hk τ]
+  have hE : (E hk : ℍ → ℂ) τ = (1 / 2 : ℂ) * eisensteinSeries (N := 1) 0 k τ := rfl
+  rw [hE]; ring
+
+end PeriodPair
+
+namespace ModularCurve
+
+theorem kw_riemannZeta_six : riemannZeta 6 = (π : ℂ) ^ 6 / 945 := by
+  have hb5 : bernoulli' 5 = 0 := by
+    have : Nat.choose 5 2 = 10 := by decide
+    rw [bernoulli'_def]
+    norm_num [Finset.sum_range_succ, this]
+  have hb6 : bernoulli' 6 = 1 / 42 := by
+    have h62 : Nat.choose 6 2 = 15 := by decide
+    have h64 : Nat.choose 6 4 = 15 := by decide
+    rw [bernoulli'_def]
+    norm_num [Finset.sum_range_succ, hb5, h62, h64]
+  have hb : bernoulli 6 = 1 / 42 := by
+    rw [bernoulli_eq_bernoulli'_of_ne_one (by norm_num), hb6]
+  have h := riemannZeta_two_mul_nat (k := 3) (by norm_num)
+  simp only [show 2 * 3 = 6 from rfl, Nat.cast_ofNat, hb,
+    show (6 : ℕ).factorial = 720 from by decide] at h
+  rw [show (2 * (3 : ℂ) : ℂ) = (6 : ℂ) by ring] at h
+  push_cast at h
+  rw [h]; ring
+
+end ModularCurve
+
+namespace PeriodPair
+
+open ModularCurve
+
+theorem kw_g₂_ofTau (τ : ℍ) :
+    (ofTau τ).g₂ = (4 * (π : ℂ) ^ 4 / 3) * E₄ τ := by
+  rw [g₂, kw_G_ofTau_eq (by norm_num : (3:ℕ) ≤ 4) τ,
+    show ((4 : ℕ) : ℂ) = (4 : ℂ) by push_cast; ring, riemannZeta_four]
+  ring
+
+theorem kw_g₃_ofTau (τ : ℍ) :
+    (ofTau τ).g₃ = (8 * (π : ℂ) ^ 6 / 27) * E₆ τ := by
+  rw [g₃, kw_G_ofTau_eq (by norm_num : (3:ℕ) ≤ 6) τ,
+    show ((6 : ℕ) : ℂ) = (6 : ℂ) by push_cast; ring, kw_riemannZeta_six]
+  ring
+
+end PeriodPair
+
+end
+
+noncomputable section
+
+open scoped UpperHalfPlane Real
+open Complex UpperHalfPlane ModularForm
+
+namespace PeriodPair
+
+theorem kw_discriminant_ofTau_eq (τ : ℍ) :
+    (ofTau τ).g₂ ^ 3 - 27 * (ofTau τ).g₃ ^ 2
+      = (64 * (π : ℂ) ^ 12 / 27) * (E₄ τ ^ 3 - E₆ τ ^ 2) := by
+  rw [kw_g₂_ofTau, kw_g₃_ofTau]; ring
+
+theorem kw_jLattice_ofTau_eq (τ : ℍ) :
+    (ofTau τ).jLattice = 1728 * E₄ τ ^ 3 / (E₄ τ ^ 3 - E₆ τ ^ 2) := by
+  have hK : (64 * (π : ℂ) ^ 12 / 27) ≠ 0 :=
+    div_ne_zero (mul_ne_zero (by norm_num)
+      (pow_ne_zero 12 (by exact_mod_cast Real.pi_ne_zero))) (by norm_num)
+  unfold jLattice
+  rw [kw_discriminant_ofTau_eq, kw_g₂_ofTau, mul_pow,
+    show (4 * (π : ℂ) ^ 4 / 3) ^ 3 = 64 * (π : ℂ) ^ 12 / 27 by ring,
+    show (1728 : ℂ) * (64 * (π : ℂ) ^ 12 / 27 * E₄ τ ^ 3)
+        = 64 * (π : ℂ) ^ 12 / 27 * (1728 * E₄ τ ^ 3) by ring,
+    mul_div_mul_left _ _ hK]
+
+end PeriodPair
+
+end
+
+open scoped UpperHalfPlane in
+theorem solution (τ : ℍ) :
+    (PeriodPair.ofTau τ).jLattice = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ := by
+  rw [PeriodPair.kw_jLattice_ofTau_eq, ModularForm.discriminant_eq_E₄_cube_sub_E₆_sq,
+    div_div_eq_mul_div]
+  ring
+
+end privateSection
+
+public section publicSection
+
+
+open scoped UpperHalfPlane
+theorem PeriodPair.jLattice_ofTau (τ : ℍ) :
+    (PeriodPair.ofTau τ).jLattice = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ :=
+      _root_.solution τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_jLattice_surjective.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_jLattice_surjective.lean
new file mode 100644
index 0000000000..eb9a098ec0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_jLattice_surjective.lean
@@ -0,0 +1,684 @@
+/-
+Based on Prove2Me node PeriodPair.jLattice_surjective
+(50646b81-ed3e-5faa-a8ed-15a3e3a886ef) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 82da8266-a598-53dd-bea0-f41567ca354c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_PeriodPair_Uniformization
+
+import Mathlib.Data.Int.Star
+import Mathlib.NumberTheory.ModularForms.LevelOne.DimensionFormula
+
+/-!
+# Surjectivity of the j-invariant of period pairs
+
+Theorem statement: `PeriodPair.jLattice_surjective` (`50646b81-ed3e-5faa-a8ed-15a3e3a886ef`), by
+Claude, 2026-09-05.
+
+Proof: submission `82da8266-a598-53dd-bea0-f41567ca354c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+The assertion is the proposition [`PeriodPair.JSurjective`](def/PeriodPair_Uniformization.html#L90):
+for every complex number $c$ there exists a period pair $L$ (an element of the type `PeriodPair`)
+such that, first, `L.DiscriminantNeZero` holds, i.e. the associated invariants satisfy $g_2(L)^3 -
+27\,g_3(L)^2 \neq 0$, and second, `L.jLattice` equals $c$, where `jLattice` is by definition the
+quotient $$1728\,\frac{g_2(L)^3}{g_2(L)^3 - 27\,g_3(L)^2}.$$ There are no hypotheses and no
+parameters: the theorem is the bare statement that the function sending a period pair to this
+quotient of its invariants takes every value in $\mathbb{C}$, together with the non-vanishing of the
+discriminant expression at the witnessing period pair. The latter conjunct is in fact automatic,
+since the cited [`PeriodPair.discriminant_ne_zero`](thm.html#PeriodPair.discriminant_ne_zero) gives
+$g_2(L)^3 - 27\,g_3(L)^2 \neq 0$ for every period pair $L$, so the substance of the statement is the
+surjectivity of $L \mapsto$ `L.jLattice` onto $\mathbb{C}$.
+
+This is the surjectivity of the modular $j$-invariant in the form needed for the analytic
+uniformisation of elliptic curves over $\mathbb{C}$: every complex number occurs as the
+$j$-invariant of a complex torus. It is used to produce, for a given Weierstrass curve over
+$\mathbb{C}$, a period pair with the same $j$-invariant, hence a change of variables matching the
+two curves, and it feeds into the computation of $j$-invariants attached to isogeny endomorphism
+data.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_PeriodPair_jLattice_surjective.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+noncomputable section privateSection
+
+section
+
+open scoped MatrixGroups UpperHalfPlane
+open UpperHalfPlane ModularForm ModularFormClass EisensteinSeries PowerSeries
+
+namespace ModularForm
+open ModularForm
+
+def kw_E4cube : ModularForm 𝒮ℒ 12 :=
+  ModularForm.mcast (by ring) ((E₄.mul E₄).mul E₄)
+
+def kw_E6sq : ModularForm 𝒮ℒ 12 :=
+  ModularForm.mcast (by ring) (E₆.mul E₆)
+
+@[scoped simp] theorem kw_E4cube_apply (τ : ℍ) : kw_E4cube τ = E₄ τ ^ 3 := by
+  change ((E₄.mul E₄).mul E₄) τ = E₄ τ ^ 3
+  simp only [ModularForm.coe_mul, Pi.mul_apply]; ring
+
+@[scoped simp] theorem kw_E6sq_apply (τ : ℍ) : kw_E6sq τ = E₆ τ ^ 2 := by
+  change (E₆.mul E₆) τ = E₆ τ ^ 2
+  simp only [ModularForm.coe_mul, Pi.mul_apply]; ring
+
+def kw_E4cube_sub_E6sq : ModularForm 𝒮ℒ 12 := kw_E4cube - kw_E6sq
+
+@[scoped simp] theorem kw_E4cube_sub_E6sq_apply (τ : ℍ) :
+    kw_E4cube_sub_E6sq τ = E₄ τ ^ 3 - E₆ τ ^ 2 := by
+  simp [kw_E4cube_sub_E6sq]
+
+private theorem kw_qExpansion_E4cube :
+    qExpansion 1 (kw_E4cube : ℍ → ℂ) = qExpansion 1 (E₄ : ℍ → ℂ) ^ 3 := by
+  change qExpansion 1 (((E₄.mul E₄).mul E₄ : ModularForm _ _) : ℍ → ℂ) = _
+  rw [ModularForm.qExpansion_mul one_pos one_mem_strictPeriods_SL,
+    ModularForm.qExpansion_mul one_pos one_mem_strictPeriods_SL]
+  ring
+
+private theorem kw_qExpansion_E6sq :
+    qExpansion 1 (kw_E6sq : ℍ → ℂ) = qExpansion 1 (E₆ : ℍ → ℂ) ^ 2 := by
+  change qExpansion 1 ((E₆.mul E₆ : ModularForm _ _) : ℍ → ℂ) = _
+  rw [ModularForm.qExpansion_mul one_pos one_mem_strictPeriods_SL]
+  ring
+
+private theorem kw_qExpansion_E4cube_sub_E6sq :
+    qExpansion 1 (kw_E4cube_sub_E6sq : ℍ → ℂ)
+      = qExpansion 1 (E₄ : ℍ → ℂ) ^ 3 - qExpansion 1 (E₆ : ℍ → ℂ) ^ 2 := by
+  rw [show (kw_E4cube_sub_E6sq : ℍ → ℂ) = (kw_E4cube : ℍ → ℂ) - (kw_E6sq : ℍ → ℂ) from
+      rfl,
+    ModularForm.qExpansion_sub one_pos one_mem_strictPeriods_SL,
+    kw_qExpansion_E4cube, kw_qExpansion_E6sq]
+
+private theorem kw_E4_coeff_zero : (qExpansion 1 (E₄ : ℍ → ℂ)).coeff 0 = 1 :=
+  E_qExpansion_coeff_zero (by norm_num) ⟨2, rfl⟩
+
+private theorem kw_E6_coeff_zero : (qExpansion 1 (E₆ : ℍ → ℂ)).coeff 0 = 1 :=
+  E_qExpansion_coeff_zero (by norm_num) ⟨3, rfl⟩
+
+theorem kw_E4cube_sub_E6sq_coeff_zero :
+    (qExpansion 1 (kw_E4cube_sub_E6sq : ℍ → ℂ)).coeff 0 = 0 := by
+  rw [kw_qExpansion_E4cube_sub_E6sq, PowerSeries.coeff_zero_eq_constantCoeff, map_sub, map_pow,
+    map_pow, ← PowerSeries.coeff_zero_eq_constantCoeff_apply,
+    ← PowerSeries.coeff_zero_eq_constantCoeff_apply, kw_E4_coeff_zero, kw_E6_coeff_zero]
+  ring
+
+private theorem kw_antidiagonal_one :
+    (Finset.HasAntidiagonal.antidiagonal 1 : Finset (ℕ × ℕ)) = {(0, 1), (1, 0)} := by decide
+
+private theorem kw_coeff_one_mul (p q : PowerSeries ℂ) :
+    (p * q).coeff 1 = p.coeff 0 * q.coeff 1 + p.coeff 1 * q.coeff 0 := by
+  rw [PowerSeries.coeff_mul, kw_antidiagonal_one]
+  simp
+
+private theorem kw_coeff_one_sq (p : PowerSeries ℂ) :
+    (p ^ 2).coeff 1 = 2 * p.coeff 0 * p.coeff 1 := by
+  rw [sq, kw_coeff_one_mul]; ring
+
+private theorem kw_coeff_one_cube (p : PowerSeries ℂ) :
+    (p ^ 3).coeff 1 = 3 * p.coeff 0 ^ 2 * p.coeff 1 := by
+  have hsq0 : (p ^ 2).coeff 0 = p.coeff 0 ^ 2 := by
+    simp only [PowerSeries.coeff_zero_eq_constantCoeff, map_pow]
+  rw [show p ^ 3 = p * p ^ 2 from by ring, kw_coeff_one_mul, kw_coeff_one_sq, hsq0]
+  ring
+
+theorem kw_E4cube_sub_E6sq_coeff_one :
+    (qExpansion 1 (kw_E4cube_sub_E6sq : ℍ → ℂ)).coeff 1 = 1728 := by
+  rw [kw_qExpansion_E4cube_sub_E6sq, map_sub, kw_coeff_one_cube, kw_coeff_one_sq,
+    kw_E4_coeff_zero, kw_E6_coeff_zero, E₄_qExpansion_coeff_one, E₆_qExpansion_coeff_one]
+  ring
+
+def kw_E4cube_sub_E6sq_cuspForm : CuspForm 𝒮ℒ 12 :=
+  toCuspForm kw_E4cube_sub_E6sq kw_E4cube_sub_E6sq_coeff_zero
+
+@[scoped simp] theorem kw_E4cube_sub_E6sq_cuspForm_apply (τ : ℍ) :
+    kw_E4cube_sub_E6sq_cuspForm τ = E₄ τ ^ 3 - E₆ τ ^ 2 :=
+  kw_E4cube_sub_E6sq_apply τ
+
+theorem kw_exists_smul_discriminant_eq_E4cube_sub_E6sq :
+    ∃ c : ℂ, c ≠ 0 ∧ (∀ τ : ℍ, E₄ τ ^ 3 - E₆ τ ^ 2 = c * discriminant τ) ∧
+      c * (qExpansion 1 (discriminant : ℍ → ℂ)).coeff 1 = 1728 := by
+  obtain ⟨c, hc⟩ :=
+    CuspForm.exists_smul_discriminant_of_weight_eq_twelve kw_E4cube_sub_E6sq_cuspForm
+  have hpt : ∀ τ : ℍ, E₄ τ ^ 3 - E₆ τ ^ 2 = c * discriminant τ := fun τ => by
+    have h := DFunLike.congr_fun hc τ
+    simp only [smul_apply, CuspForm.coe_discriminant, smul_eq_mul,
+      kw_E4cube_sub_E6sq_cuspForm_apply] at h
+    exact h.symm
+  have hcoeff : c * (qExpansion 1 (discriminant : ℍ → ℂ)).coeff 1 = 1728 := by
+    have hfun : (kw_E4cube_sub_E6sq_cuspForm : ℍ → ℂ)
+        = c • (CuspForm.discriminant : ℍ → ℂ) := by
+      exact_mod_cast congrArg DFunLike.coe hc.symm
+    have := kw_E4cube_sub_E6sq_coeff_one
+    rw [show (kw_E4cube_sub_E6sq : ℍ → ℂ) = (kw_E4cube_sub_E6sq_cuspForm : ℍ → ℂ) from rfl,
+      hfun, ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL,
+      PowerSeries.coeff_smul, smul_eq_mul, CuspForm.coe_discriminant] at this
+    exact this
+  refine ⟨c, ?_, hpt, hcoeff⟩
+  intro hzero
+  rw [hzero, zero_mul] at hcoeff
+  exact absurd hcoeff (by norm_num)
+
+theorem kw_E4cube_ne_E6sq (τ : ℍ) : E₄ τ ^ 3 ≠ E₆ τ ^ 2 := by
+  obtain ⟨c, hc, hpt, -⟩ := kw_exists_smul_discriminant_eq_E4cube_sub_E6sq
+  intro h
+  have := hpt τ
+  rw [h, sub_self] at this
+  exact mul_ne_zero hc (discriminant_ne_zero τ) this.symm
+
+end ModularForm
+end
+
+section
+
+open UpperHalfPlane Complex
+
+namespace PeriodPair
+open PeriodPair
+
+theorem kw_ofTau_latticeEquivProd_symm_apply (τ : ℍ) (p : ℤ × ℤ) :
+    ((ofTau τ).latticeEquivProd.symm p : ℂ) = p.1 * (τ : ℂ) + p.2 := by
+  rw [latticeEquiv_symm_apply]; simp
+
+end PeriodPair
+end
+
+
+section
+
+open Filter Topology UpperHalfPlane
+
+namespace ModularCurve
+
+theorem kwQepw118c_modularForm_tendsto_valueAtInfty
+    {k : ℤ} {Γ : Subgroup (GL (Fin 2) ℝ)} {F : Type*}
+    [FunLike F UpperHalfPlane ℂ] [ModularFormClass F Γ k] (f : F)
+    {h : ℝ} (hh : 0 < h) (hΓ : h ∈ Γ.strictPeriods) :
+    Tendsto (f : UpperHalfPlane → ℂ) UpperHalfPlane.atImInfty
+      (𝓝 (UpperHalfPlane.valueAtInfty f)) := by
+  have hanal := ModularFormClass.analyticAt_cuspFunction_zero f hh hΓ
+  have hper := SlashInvariantFormClass.periodic_comp_ofComplex f hΓ
+  rw [← UpperHalfPlane.cuspFunction_apply_zero hh hanal hper]
+  exact (hanal.continuousAt.tendsto.comp
+      (UpperHalfPlane.qParam_tendsto_atImInfty hh)).congr
+    fun τ => SlashInvariantFormClass.eq_cuspFunction f τ hΓ hh.ne'
+
+theorem kwQepw118c_eisenstein4_tendsto_one :
+    Tendsto (ModularForm.E₄ : UpperHalfPlane → ℂ)
+      UpperHalfPlane.atImInfty (𝓝 1) := by
+  have htend := kwQepw118c_modularForm_tendsto_valueAtInfty
+    ModularForm.E₄ one_pos one_mem_strictPeriods_SL
+  have hanal := ModularFormClass.analyticAt_cuspFunction_zero
+    ModularForm.E₄ one_pos one_mem_strictPeriods_SL
+  have hper := SlashInvariantFormClass.periodic_comp_ofComplex
+    ModularForm.E₄ one_mem_strictPeriods_SL
+  have hcoeff := UpperHalfPlane.qExpansion_coeff_zero one_pos hanal hper
+  have hE : (UpperHalfPlane.qExpansion 1
+      (ModularForm.E₄ : UpperHalfPlane → ℂ)).coeff 0 = 1 :=
+    EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) (by decide)
+  rw [hE] at hcoeff
+  rw [hcoeff]
+  exact htend
+
+end ModularCurve
+end
+section
+
+namespace ModularCurve
+
+abbrev kwQepw124b_PencilFibreProp
+    (F : ℂ → ℂ → ℂ) (J : UpperHalfPlane → ℂ) : Prop :=
+  ∀ c : ℂ, ∀ τ : UpperHalfPlane, F c (↑τ : ℂ) = 0 ↔ J τ = c
+
+end ModularCurve
+end
+section
+
+open Filter Topology
+
+namespace ModularCurve
+
+abbrev kwQepw129c_TopEdgeCuspVanishingProp
+    (f : UpperHalfPlane → ℂ) (L : ℂ) : Prop :=
+  Filter.Tendsto f UpperHalfPlane.atImInfty (nhds L)
+
+end ModularCurve
+end
+section
+
+open scoped UpperHalfPlane Real
+open Complex UpperHalfPlane EisensteinSeries ModularForm
+
+namespace PeriodPair
+open PeriodPair
+
+theorem kw_G_ofTau_eq {k : ℕ} (hk : 3 ≤ k) (τ : ℍ) :
+    (ofTau τ).G k = 2 * riemannZeta k * E hk τ := by
+  rw [G, ← (ofTau τ).latticeEquivProd.symm.toEquiv.tsum_eq]
+  simp only [LinearEquiv.coe_toEquiv, kw_ofTau_latticeEquivProd_symm_apply]
+  have hstep : ∀ p : ℤ × ℤ,
+      ((↑p.1 * (τ : ℂ) + ↑p.2) ^ k)⁻¹ = eisSummand k ((finTwoArrowEquiv ℤ).symm p) τ := by
+    intro p
+    simp only [eisSummand, finTwoArrowEquiv_symm_apply, Matrix.cons_val_zero,
+      Matrix.cons_val_one, Matrix.cons_val_fin_one, _root_.zpow_neg, zpow_natCast]
+  simp only [hstep]
+  rw [(finTwoArrowEquiv ℤ).symm.tsum_eq (f := fun v => eisSummand (k : ℤ) v τ),
+    tsum_eisSummand_eq_riemannZeta_mul_eisensteinSeries hk τ]
+  have hE : (E hk : ℍ → ℂ) τ = (1 / 2 : ℂ) * eisensteinSeries (N := 1) 0 k τ := rfl
+  rw [hE]; ring
+
+end PeriodPair
+namespace ModularCurve
+
+theorem kw_riemannZeta_six : riemannZeta 6 = (π : ℂ) ^ 6 / 945 := by
+  have hb5 : bernoulli' 5 = 0 := by
+    have : Nat.choose 5 2 = 10 := by decide
+    rw [bernoulli'_def]
+    norm_num [Finset.sum_range_succ, this]
+  have hb6 : bernoulli' 6 = 1 / 42 := by
+    have h62 : Nat.choose 6 2 = 15 := by decide
+    have h64 : Nat.choose 6 4 = 15 := by decide
+    rw [bernoulli'_def]
+    norm_num [Finset.sum_range_succ, hb5, h62, h64]
+  have hb : bernoulli 6 = 1 / 42 := by
+    rw [bernoulli_eq_bernoulli'_of_ne_one (by norm_num), hb6]
+  have h := riemannZeta_two_mul_nat (k := 3) (by norm_num)
+  simp only [show 2 * 3 = 6 from rfl, Nat.cast_ofNat, hb,
+    show (6 : ℕ).factorial = 720 from by decide] at h
+  rw [show (2 * (3 : ℂ) : ℂ) = (6 : ℂ) by ring] at h
+  push_cast at h
+  rw [h]; ring
+
+end ModularCurve
+namespace PeriodPair
+open PeriodPair
+
+open ModularCurve
+
+theorem kw_g₂_ofTau (τ : ℍ) :
+    (ofTau τ).g₂ = (4 * (π : ℂ) ^ 4 / 3) * E₄ τ := by
+  rw [g₂, kw_G_ofTau_eq (by norm_num : (3:ℕ) ≤ 4) τ,
+    show ((4 : ℕ) : ℂ) = (4 : ℂ) by push_cast; ring, riemannZeta_four]
+  ring
+
+theorem kw_g₃_ofTau (τ : ℍ) :
+    (ofTau τ).g₃ = (8 * (π : ℂ) ^ 6 / 27) * E₆ τ := by
+  rw [g₃, kw_G_ofTau_eq (by norm_num : (3:ℕ) ≤ 6) τ,
+    show ((6 : ℕ) : ℂ) = (6 : ℂ) by push_cast; ring, kw_riemannZeta_six]
+  ring
+
+end PeriodPair
+end
+
+section
+
+open scoped MatrixGroups
+
+namespace ModularCurve
+
+def kwQepw123c_jH (tau : UpperHalfPlane) : ℂ :=
+  ModularForm.E₄ tau ^ 3 / ModularForm.discriminant tau
+
+def kwQepw123c_E₄cubeExt (z : ℂ) : ℂ :=
+  if h : 0 < z.im then ModularForm.E₄ (⟨z, h⟩ : UpperHalfPlane) ^ 3 else 0
+
+def kwQepw123c_ΔExt (z : ℂ) : ℂ :=
+  if h : 0 < z.im then ModularForm.discriminant (⟨z, h⟩ : UpperHalfPlane) else 0
+
+def kwQepw123c_pencil (c z : ℂ) : ℂ :=
+  kwQepw123c_E₄cubeExt z - c * kwQepw123c_ΔExt z
+
+theorem kwQepw123c_E₄cubeExt_coe (tau : UpperHalfPlane) :
+    kwQepw123c_E₄cubeExt (tau : ℂ) = ModularForm.E₄ tau ^ 3 := by
+  exact dite_eq_left tau.coe_im_pos
+
+theorem kwQepw123c_ΔExt_coe (tau : UpperHalfPlane) :
+    kwQepw123c_ΔExt (tau : ℂ) = ModularForm.discriminant tau := by
+  exact dite_eq_left tau.coe_im_pos
+
+theorem kwQepw123c_pencil_coe (c : ℂ) (tau : UpperHalfPlane) :
+    kwQepw123c_pencil c (tau : ℂ)
+      = ModularForm.E₄ tau ^ 3 - c * ModularForm.discriminant tau := by
+  unfold kwQepw123c_pencil
+  rw [kwQepw123c_E₄cubeExt_coe, kwQepw123c_ΔExt_coe]
+
+theorem kwQepw123c_pencilFibre_jH :
+    kwQepw124b_PencilFibreProp kwQepw123c_pencil kwQepw123c_jH := by
+  intro c tau
+  rw [kwQepw123c_pencil_coe, sub_eq_zero]
+  unfold kwQepw123c_jH
+  rw [div_eq_iff (ModularForm.discriminant_ne_zero tau)]
+
+end ModularCurve
+end
+
+section
+
+open Filter Topology
+
+namespace ModularCurve
+
+abbrev kwQepw120c_DiscriminantCuspVanishingProp : Prop :=
+  kwQepw129c_TopEdgeCuspVanishingProp
+    (fun tau => ModularForm.discriminant tau) 0
+
+end ModularCurve
+end
+
+section
+
+open scoped UpperHalfPlane Real
+open Complex UpperHalfPlane ModularForm
+
+namespace PeriodPair
+open PeriodPair
+
+theorem kw_discriminant_ofTau_eq (τ : ℍ) :
+    (ofTau τ).g₂ ^ 3 - 27 * (ofTau τ).g₃ ^ 2
+      = (64 * (π : ℂ) ^ 12 / 27) * (E₄ τ ^ 3 - E₆ τ ^ 2) := by
+  rw [kw_g₂_ofTau, kw_g₃_ofTau]; ring
+
+theorem kw_discriminantNeZero_ofTau (τ : ℍ) : (ofTau τ).DiscriminantNeZero := by
+  unfold DiscriminantNeZero
+  rw [kw_discriminant_ofTau_eq]
+  refine mul_ne_zero ?_ (sub_ne_zero.mpr (kw_E4cube_ne_E6sq τ))
+  refine div_ne_zero (mul_ne_zero (by norm_num) (pow_ne_zero 12 ?_)) (by norm_num)
+  exact_mod_cast Real.pi_ne_zero
+
+theorem kw_jLattice_ofTau_eq (τ : ℍ) :
+    (ofTau τ).jLattice = 1728 * E₄ τ ^ 3 / (E₄ τ ^ 3 - E₆ τ ^ 2) := by
+  have hK : (64 * (π : ℂ) ^ 12 / 27) ≠ 0 :=
+    div_ne_zero (mul_ne_zero (by norm_num)
+      (pow_ne_zero 12 (by exact_mod_cast Real.pi_ne_zero))) (by norm_num)
+  unfold jLattice
+  rw [kw_discriminant_ofTau_eq, kw_g₂_ofTau, mul_pow,
+    show (4 * (π : ℂ) ^ 4 / 3) ^ 3 = 64 * (π : ℂ) ^ 12 / 27 by ring,
+    show (1728 : ℂ) * (64 * (π : ℂ) ^ 12 / 27 * E₄ τ ^ 3)
+        = 64 * (π : ℂ) ^ 12 / 27 * (1728 * E₄ τ ^ 3) by ring,
+    mul_div_mul_left _ _ hK]
+
+end PeriodPair
+end
+
+section
+
+open Filter Topology UpperHalfPlane
+
+namespace ModularCurve
+
+theorem kwQepw116c_sanity_jH_surjective_iff_pencil_has_zero :
+    (∀ c : ℂ, ∃ tau : UpperHalfPlane, kwQepw123c_jH tau = c)
+      ↔ ∀ c : ℂ, ∃ tau : UpperHalfPlane,
+          kwQepw123c_pencil c (↑tau : ℂ) = 0 := by
+  constructor
+  · intro h c
+    obtain ⟨tau, htau⟩ := h c
+    exact ⟨tau, (kwQepw123c_pencilFibre_jH c tau).mpr htau⟩
+  · intro h c
+    obtain ⟨tau, htau⟩ := h c
+    exact ⟨tau, (kwQepw123c_pencilFibre_jH c tau).mp htau⟩
+
+end ModularCurve
+end
+
+section
+
+open scoped MatrixGroups
+
+namespace ModularCurve
+
+abbrev kwQepw121c_PencilSlashWeightTwelveProp
+    {C : Type*} (F : C → ℂ → ℂ) : Prop :=
+  ∀ c : C, ∀ g : Matrix.SpecialLinearGroup (Fin 2) ℤ,
+    ∀ tau : UpperHalfPlane,
+      F c (↑(g • tau) : ℂ)
+        = UpperHalfPlane.denom (Matrix.SpecialLinearGroup.mapGL ℝ g)
+            (tau : ℂ) ^ (12 : ℤ) * F c (↑tau : ℂ)
+
+abbrev kwQepw121c_PencilHolomorphicProp
+    {C : Type*} (F : C → ℂ → ℂ) : Prop :=
+  ∀ c : C, ∀ tau : UpperHalfPlane, AnalyticAt ℂ (F c) (↑tau : ℂ)
+
+theorem kwQepw121c_pencil_slashWeightTwelve :
+    kwQepw121c_PencilSlashWeightTwelveProp kwQepw123c_pencil := by
+  intro c g tau
+  have hmem : Matrix.SpecialLinearGroup.mapGL ℝ g ∈ 𝒮ℒ :=
+    MonoidHom.mem_range.mpr ⟨g, rfl⟩
+  have hE : ModularForm.E₄ (g • tau)
+      = UpperHalfPlane.denom (Matrix.SpecialLinearGroup.mapGL ℝ g) (tau : ℂ)
+          ^ (4 : ℤ) * ModularForm.E₄ tau :=
+    SlashInvariantForm.slash_action_eqn'' ModularForm.E₄ hmem tau
+  have hD : ModularForm.discriminant (g • tau)
+      = UpperHalfPlane.denom (Matrix.SpecialLinearGroup.mapGL ℝ g) (tau : ℂ)
+          ^ (12 : ℤ) * ModularForm.discriminant tau :=
+    SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hmem tau
+  have hkey : (UpperHalfPlane.denom
+        (Matrix.SpecialLinearGroup.mapGL ℝ g) (tau : ℂ) ^ (4 : ℤ)
+        * ModularForm.E₄ tau) ^ 3
+      = UpperHalfPlane.denom
+          (Matrix.SpecialLinearGroup.mapGL ℝ g) (tau : ℂ) ^ (12 : ℤ)
+          * ModularForm.E₄ tau ^ 3 := by
+    rw [mul_pow, ← zpow_natCast (UpperHalfPlane.denom
+      (Matrix.SpecialLinearGroup.mapGL ℝ g) (tau : ℂ) ^ (4 : ℤ)) 3,
+      ← zpow_mul]
+    norm_num
+  rw [kwQepw123c_pencil_coe, kwQepw123c_pencil_coe, hE, hD, hkey]
+  ring
+
+end ModularCurve
+end
+
+section
+
+open Filter Topology
+
+namespace ModularCurve
+
+theorem kwQepw119c_tendsto_isBoundedAtImInfty
+    {f : UpperHalfPlane → ℂ} {L : ℂ}
+    (h : Tendsto f UpperHalfPlane.atImInfty (𝓝 L)) :
+    UpperHalfPlane.IsBoundedAtImInfty f := by
+  exact h.isBigO_one ℝ
+
+theorem kwQepw119c_discriminant_cuspVanishing :
+    kwQepw120c_DiscriminantCuspVanishingProp := by
+  exact ModularForm.discriminant_isZeroAtImInfty
+
+end ModularCurve
+end
+
+section
+
+open Filter Topology UpperHalfPlane
+
+namespace ModularCurve
+
+theorem kwQepw117c_modularForm_analyticAt_comp_ofComplex
+    {k : ℤ} {Γ : Subgroup (GL (Fin 2) ℝ)} {F : Type*}
+    [FunLike F UpperHalfPlane ℂ] [ModularFormClass F Γ k] (f : F)
+    (tau : UpperHalfPlane) :
+    AnalyticAt ℂ ((f : UpperHalfPlane → ℂ) ∘ UpperHalfPlane.ofComplex)
+      (↑tau : ℂ) := by
+  exact (UpperHalfPlane.mdifferentiable_iff.mp
+    (ModularFormClass.holo f)).analyticAt
+    (UpperHalfPlane.isOpen_upperHalfPlaneSet.mem_nhds tau.im_pos)
+
+theorem kwQepw117c_E₄cubeExt_analyticAt (tau : UpperHalfPlane) :
+    AnalyticAt ℂ kwQepw123c_E₄cubeExt (↑tau : ℂ) := by
+  have hE := kwQepw117c_modularForm_analyticAt_comp_ofComplex
+    ModularForm.E₄ tau
+  refine (hE.pow 3).congr ?_
+  filter_upwards [UpperHalfPlane.isOpen_upperHalfPlaneSet.mem_nhds
+    tau.im_pos] with z hz
+  simp only [kwQepw123c_E₄cubeExt, dite_eq_left hz, Pi.pow_apply,
+    Function.comp_apply, UpperHalfPlane.ofComplex_apply_of_im_pos hz]
+
+theorem kwQepw117c_ΔExt_analyticAt (tau : UpperHalfPlane) :
+    AnalyticAt ℂ kwQepw123c_ΔExt (↑tau : ℂ) := by
+  have hΔ := kwQepw117c_modularForm_analyticAt_comp_ofComplex
+    CuspForm.discriminant tau
+  refine hΔ.congr ?_
+  filter_upwards [UpperHalfPlane.isOpen_upperHalfPlaneSet.mem_nhds
+    tau.im_pos] with z hz
+  simp only [kwQepw123c_ΔExt, dite_eq_left hz, Function.comp_apply,
+    UpperHalfPlane.ofComplex_apply_of_im_pos hz,
+    CuspForm.coe_discriminant]
+
+theorem kwQepw117c_pencil_holomorphic :
+    kwQepw121c_PencilHolomorphicProp kwQepw123c_pencil := by
+  intro c tau
+  have hE := kwQepw117c_E₄cubeExt_analyticAt tau
+  have hΔ := kwQepw117c_ΔExt_analyticAt tau
+  have hc : AnalyticAt ℂ (fun _ : ℂ => c) (↑tau : ℂ) := analyticAt_const
+  refine (hE.sub (hc.mul hΔ)).congr
+    (Filter.Eventually.of_forall fun z => ?_)
+  simp only [kwQepw123c_pencil, Pi.sub_apply, Pi.mul_apply]
+
+end ModularCurve
+end
+
+section
+
+open Filter Topology UpperHalfPlane ModularForm Matrix.SpecialLinearGroup
+
+open scoped MatrixGroups Manifold
+
+namespace ModularCurve
+
+theorem kwQepw115c_pencil_tendsto_one_atImInfty (c : ℂ) :
+    Tendsto (fun τ : UpperHalfPlane => kwQepw123c_pencil c (↑τ : ℂ))
+      UpperHalfPlane.atImInfty (𝓝 1) := by
+  have hE : Tendsto (fun τ : UpperHalfPlane => ModularForm.E₄ τ ^ 3)
+      UpperHalfPlane.atImInfty (𝓝 1) := by
+    have := kwQepw118c_eisenstein4_tendsto_one.pow 3
+    simpa using this
+  have hΔ : Tendsto (fun τ : UpperHalfPlane =>
+        c * ModularForm.discriminant τ)
+      UpperHalfPlane.atImInfty (𝓝 0) := by
+    have := kwQepw119c_discriminant_cuspVanishing.const_mul c
+    simpa using this
+  have hsub := hE.sub hΔ
+  simp only [sub_zero] at hsub
+  refine hsub.congr fun τ => ?_
+  exact (kwQepw123c_pencil_coe c τ).symm
+
+theorem kwQepw115c_invPencilH_slash (c : ℂ)
+    (g : Matrix.SpecialLinearGroup (Fin 2) ℤ) :
+    (fun τ : UpperHalfPlane => (kwQepw123c_pencil c (↑τ : ℂ))⁻¹)
+      ∣[(-12 : ℤ)] g
+      = fun τ : UpperHalfPlane =>
+        (kwQepw123c_pencil c (↑τ : ℂ))⁻¹ := by
+  ext τ
+  rw [ModularForm.SL_slash_apply, neg_neg,
+    kwQepw121c_pencil_slashWeightTwelve c g τ]
+  have hden : UpperHalfPlane.denom (mapGL ℝ g) (↑τ : ℂ) ≠ 0 :=
+    UpperHalfPlane.denom_ne_zero _ τ
+  field_simp
+  rfl
+
+theorem kwQepw115c_invPencilH_mdifferentiable (c : ℂ)
+    (hnz : ∀ τ : UpperHalfPlane, kwQepw123c_pencil c (↑τ : ℂ) ≠ 0) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ)
+      (fun τ : UpperHalfPlane => (kwQepw123c_pencil c (↑τ : ℂ))⁻¹) := by
+  rw [UpperHalfPlane.mdifferentiable_iff]
+  refine DifferentiableOn.congr
+    (f := fun z => (kwQepw123c_pencil c z)⁻¹) ?_ (fun z hz => ?_)
+  · intro z hz
+    exact ((kwQepw117c_pencil_holomorphic c ⟨z, hz⟩).inv
+        (hnz ⟨z, hz⟩)).differentiableAt.differentiableWithinAt
+  · simp only [Function.comp_apply,
+      UpperHalfPlane.ofComplex_apply_of_im_pos hz]
+
+theorem kwQepw115c_invPencilH_isBoundedAtImInfty (c : ℂ) :
+    UpperHalfPlane.IsBoundedAtImInfty
+      (fun τ : UpperHalfPlane => (kwQepw123c_pencil c (↑τ : ℂ))⁻¹) := by
+  have htend : Tendsto
+      (fun τ : UpperHalfPlane => (kwQepw123c_pencil c (↑τ : ℂ))⁻¹)
+      UpperHalfPlane.atImInfty (𝓝 1) := by
+    have := (kwQepw115c_pencil_tendsto_one_atImInfty c).inv₀ one_ne_zero
+    simpa using this
+  exact kwQepw119c_tendsto_isBoundedAtImInfty htend
+
+def kwQepw115c_invPencilMF (c : ℂ)
+    (hnz : ∀ τ : UpperHalfPlane, kwQepw123c_pencil c (↑τ : ℂ) ≠ 0) :
+    ModularForm 𝒮ℒ (-12) where
+  toFun := fun τ => (kwQepw123c_pencil c (↑τ : ℂ))⁻¹
+  slash_action_eq' := by
+    rintro A ⟨g, rfl⟩
+    exact kwQepw115c_invPencilH_slash c g
+  holo' := kwQepw115c_invPencilH_mdifferentiable c hnz
+  bdd_at_cusps' {p} hp := by
+    rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z] at hp
+    rw [OnePoint.isBoundedAt_iff_forall_SL2Z hp]
+    intro γ _
+    rw [kwQepw115c_invPencilH_slash c γ]
+    exact kwQepw115c_invPencilH_isBoundedAtImInfty c
+
+theorem kwQepw115c_pencil_has_zero (c : ℂ) :
+    ∃ τ : UpperHalfPlane, kwQepw123c_pencil c (↑τ : ℂ) = 0 := by
+  by_contra hcon
+  have hnz : ∀ τ : UpperHalfPlane, kwQepw123c_pencil c (↑τ : ℂ) ≠ 0 :=
+    not_exists.mp hcon
+  have hzero := ModularFormClass.levelOne_neg_weight_eq_zero
+    (k := (-12 : ℤ)) (by norm_num) (kwQepw115c_invPencilMF c hnz)
+  have hI : (kwQepw115c_invPencilMF c hnz) UpperHalfPlane.I = 0 :=
+    congrFun hzero UpperHalfPlane.I
+  have hI' : (kwQepw123c_pencil c (↑(UpperHalfPlane.I) : ℂ))⁻¹ = 0 :=
+    hI
+  exact hnz UpperHalfPlane.I (inv_eq_zero.mp hI')
+
+theorem kwQepw115c_jH_surjective :
+    ∀ c : ℂ, ∃ τ : UpperHalfPlane, kwQepw123c_jH τ = c := by
+  exact kwQepw116c_sanity_jH_surjective_iff_pencil_has_zero.mpr
+    kwQepw115c_pencil_has_zero
+
+end ModularCurve
+end
+
+section
+
+open scoped UpperHalfPlane
+open Complex UpperHalfPlane ModularForm
+
+namespace PeriodPair
+open PeriodPair
+
+open ModularCurve
+
+theorem kw_jLattice_ofTau_eq_jH (c' : ℂ)
+    (hpt : ∀ τ : ℍ, E₄ τ ^ 3 - E₆ τ ^ 2 = c' * discriminant τ) (τ : ℍ) :
+    (ofTau τ).jLattice = (1728 / c') * kwQepw123c_jH τ := by
+  rw [kw_jLattice_ofTau_eq, hpt τ, kwQepw123c_jH, div_mul_eq_mul_div, mul_div_assoc,
+    mul_comm c', ← div_div, mul_div_assoc]
+
+theorem kw_JSurjective : PeriodPair.JSurjective := by
+  intro c₀
+  obtain ⟨c', hc', hpt, -⟩ := kw_exists_smul_discriminant_eq_E4cube_sub_E6sq
+  obtain ⟨τ, hτ⟩ := kwQepw115c_jH_surjective (c₀ * c' / 1728)
+  refine ⟨ofTau τ, kw_discriminantNeZero_ofTau τ, ?_⟩
+  rw [kw_jLattice_ofTau_eq_jH c' hpt τ, hτ]
+  field_simp
+
+end PeriodPair
+end
+end privateSection
+
+public section publicSection
+
+theorem PeriodPair.jLattice_surjective : PeriodPair.JSurjective :=
+  PeriodPair.kw_JSurjective
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_lattice_eq_of_g2_eq_of_g3_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_lattice_eq_of_g2_eq_of_g3_eq.lean
new file mode 100644
index 0000000000..de6d6b267b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_PeriodPair_lattice_eq_of_g2_eq_of_g3_eq.lean
@@ -0,0 +1,309 @@
+/-
+Based on Prove2Me node PeriodPair.lattice_eq_of_g2_eq_of_g3_eq
+(c7d8f57c-5169-5cf8-b285-6d3447415d83) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1749db28-16c0-5568-b3b2-d691f50cf4f9
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.SpecialFunctions.Elliptic.Weierstrass
+
+import Mathlib.Analysis.CStarAlgebra.Classes
+import Mathlib.Analysis.Calculus.Deriv.Pow
+import Mathlib.Analysis.Normed.Module.Connected
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A lattice is determined by g₂ and g₃
+
+Theorem statement: `PeriodPair.lattice_eq_of_g2_eq_of_g3_eq`
+(`c7d8f57c-5169-5cf8-b285-6d3447415d83`), by Claude, 2026-09-05.
+
+Proof: submission `1749db28-16c0-5568-b3b2-d691f50cf4f9`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+The statement concerns two period pairs $L$ and $L'$, i.e. two terms of the type `PeriodPair` of
+pairs of complex numbers that are linearly independent over $\mathbb{R}$; to such a pair are
+attached the lattice $L.\mathrm{lattice} = \mathbb{Z}\omega_1 + \mathbb{Z}\omega_2$, the additive
+subgroup of $\mathbb{C}$ generated by the two periods, and the Weierstrass invariants $L.g_2 =
+60\sum_{0 \neq \lambda \in \Lambda} \lambda^{-4}$ and $L.g_3 = 140\sum_{0 \neq \lambda \in \Lambda}
+\lambda^{-6}$, where $\Lambda$ is that lattice. Under the two hypotheses that $L.g_2 = L'.g_2$ and
+$L.g_3 = L'.g_3$, the conclusion is that $L.\mathrm{lattice} = L'.\mathrm{lattice}$, an equality of
+subgroups of $\mathbb{C}$. Note that only the lattices, and not the period pairs themselves, are
+asserted to agree: two different bases of one and the same lattice have the same invariants, and the
+statement says precisely that no further collapsing occurs.
+
+This is the injectivity half of the uniformisation theorem for complex elliptic curves: the
+assignment sending a lattice $\Lambda \subset \mathbb{C}$ to the pair $(g_2(\Lambda), g_3(\Lambda))$
+is injective. It is used for the rigidity statements
+[`ModularCurve.exists_smul_eq_of_E4_cube_div_discriminant_eq`]
+(thm.html#ModularCurve.exists_smul_eq_of_E4_cube_div_discriminant_eq),
+[`ModularForm.exists_gamma0_apply_mul_apply_ne_of_forall_smul_ne`]
+(thm.html#ModularForm.exists_gamma0_apply_mul_apply_ne_of_forall_smul_ne)
+and
+[`PeriodPair.scale_lattice_eq_of_pow_four_eq_one_or_g2_eq_zero`]
+(thm.html#PeriodPair.scale_lattice_eq_of_pow_four_eq_one_or_g2_eq_zero),
+which translate equalities of modular invariants into relations between lattices and hence into
+$\mathrm{SL}_2(\mathbb{Z})$-equivalences of points of the upper half-plane.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_PeriodPair_lattice_eq_of_g2_eq_of_g3_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_PeriodPair_lattice_eq_of_g2_eq_of_g3_eq
+
+noncomputable section
+
+open Complex Filter Topology
+p2m_open_scoped "PeriodPair P2MW.S_PeriodPair_lattice_eq_of_g2_eq_of_g3_eq.PeriodPair"
+
+namespace PeriodPair
+p2m_export "PeriodPair" "analyticAt_weierstrassPExcept isClosed_lattice \
+  derivWeierstrassPExcept_sub lattice weierstrassPExcept order_weierstrassP \
+  analyticAt_derivWeierstrassPExcept g₃ weierstrassPExcept_add derivWeierstrassP_sq \
+  eqOn_deriv_weierstrassPExcept_derivWeierstrassPExcept derivWeierstrassPExcept \
+  compl_lattice_diff_singleton_mem_nhds g₂ analyticOnNhd_weierstrassP"
+namespace LatticeFromInvariants
+p2m_open "PeriodPair"
+
+lemma weierstrassP_eq_except (L : PeriodPair) (z : ℂ) :
+    ℘[L] z = (L.weierstrassPExcept 0) z + 1 / z ^ 2 := by
+  have h := L.weierstrassPExcept_add ⟨0, zero_mem _⟩ z
+  simp only [sub_zero, ne_eq, OfNat.ofNat_ne_zero, not_false_eq_true, zero_pow, div_zero] at h
+  exact h.symm
+
+lemma derivWeierstrassP_eq_except (L : PeriodPair) (z : ℂ) :
+    ℘'[L] z = (L.derivWeierstrassPExcept 0) z - 2 / z ^ 3 := by
+  have h := L.derivWeierstrassPExcept_sub ⟨0, zero_mem _⟩ z
+  simp only [sub_zero] at h
+  exact h.symm
+
+lemma ode_except (L : PeriodPair) {z : ℂ} (hz : z ∉ L.lattice) :
+    (z ^ 3 * (L.derivWeierstrassPExcept 0) z - 2) ^ 2 -
+      (4 * (z ^ 2 * (L.weierstrassPExcept 0) z + 1) ^ 3
+        - L.g₂ * z ^ 4 * (z ^ 2 * (L.weierstrassPExcept 0) z + 1)
+        - L.g₃ * z ^ 6) = 0 := by
+  have hz0 : z ≠ 0 := fun h => hz (h ▸ zero_mem _)
+  have hODE := L.derivWeierstrassP_sq z hz
+  rw [weierstrassP_eq_except L z, derivWeierstrassP_eq_except L z] at hODE
+  have key : (z ^ 3 * (L.derivWeierstrassPExcept 0) z - 2) ^ 2 -
+      (4 * (z ^ 2 * (L.weierstrassPExcept 0) z + 1) ^ 3
+        - L.g₂ * z ^ 4 * (z ^ 2 * (L.weierstrassPExcept 0) z + 1)
+        - L.g₃ * z ^ 6) =
+      z ^ 6 * (((L.derivWeierstrassPExcept 0) z - 2 / z ^ 3) ^ 2 -
+        (4 * ((L.weierstrassPExcept 0) z + 1 / z ^ 2) ^ 3
+          - L.g₂ * ((L.weierstrassPExcept 0) z + 1 / z ^ 2) - L.g₃)) := by
+    field_simp
+  rw [key, hODE, sub_self, mul_zero]
+
+lemma eventuallyEq_zero (L L' : PeriodPair) (h₂ : L.g₂ = L'.g₂) (h₃ : L.g₃ = L'.g₃) :
+    ∀ᶠ z in 𝓝[≠] (0 : ℂ), ℘[L] z = ℘[L'] z := by
+  have hP₁ : AnalyticAt ℂ (L.weierstrassPExcept 0) 0 := L.analyticAt_weierstrassPExcept 0
+  have hP₂ : AnalyticAt ℂ (L'.weierstrassPExcept 0) 0 := L'.analyticAt_weierstrassPExcept 0
+  have hQ₁ : AnalyticAt ℂ (L.derivWeierstrassPExcept 0) 0 :=
+    L.analyticAt_derivWeierstrassPExcept 0
+  have hQ₂ : AnalyticAt ℂ (L'.derivWeierstrassPExcept 0) 0 :=
+    L'.analyticAt_derivWeierstrassPExcept 0
+  have hdP₁ : ∀ᶠ z in 𝓝 (0 : ℂ),
+      deriv (L.weierstrassPExcept 0) z = (L.derivWeierstrassPExcept 0) z :=
+    Filter.eventually_of_mem (L.compl_lattice_sdiff_singleton_mem_nhds 0)
+      (L.eqOn_deriv_weierstrassPExcept_derivWeierstrassPExcept 0)
+  have hdP₂ : ∀ᶠ z in 𝓝 (0 : ℂ),
+      deriv (L'.weierstrassPExcept 0) z = (L'.derivWeierstrassPExcept 0) z :=
+    Filter.eventually_of_mem (L'.compl_lattice_sdiff_singleton_mem_nhds 0)
+      (L'.eqOn_deriv_weierstrassPExcept_derivWeierstrassPExcept 0)
+  suffices hD0 : ∀ᶠ z in 𝓝 (0 : ℂ),
+      ((L.weierstrassPExcept 0) - (L'.weierstrassPExcept 0)) z = 0 by
+    refine mem_nhdsWithin_of_mem_nhds ?_
+    filter_upwards [hD0] with z hz
+    rw [Pi.sub_apply, sub_eq_zero] at hz
+    show ℘[L] z = ℘[L'] z
+    rw [weierstrassP_eq_except L, weierstrassP_eq_except L', hz]
+  by_contra hD0
+  obtain ⟨m, E, hE, hE0, hDE⟩ :=
+    (hP₁.sub hP₂).exists_eventuallyEq_pow_smul_nonzero_iff.mpr hD0
+  have hDE' : ∀ᶠ z in 𝓝 (0 : ℂ),
+      ((L.weierstrassPExcept 0) - (L'.weierstrassPExcept 0)) z = z ^ m * E z := by
+    filter_upwards [hDE] with z hz
+    rw [hz, sub_zero, smul_eq_mul]
+  have hderiv : ∀ᶠ z in 𝓝 (0 : ℂ),
+      (L.derivWeierstrassPExcept 0) z - (L'.derivWeierstrassPExcept 0) z =
+        (m : ℂ) * z ^ (m - 1) * E z + z ^ m * deriv E z := by
+    have h1 : deriv ((L.weierstrassPExcept 0) - (L'.weierstrassPExcept 0)) =ᶠ[𝓝 0]
+        deriv (fun z => z ^ m * E z) :=
+      Filter.EventuallyEq.deriv hDE'
+    filter_upwards [h1, hP₁.eventually_analyticAt, hP₂.eventually_analyticAt,
+      hE.eventually_analyticAt, hdP₁, hdP₂] with z hz h1z h2z hEz hd1 hd2
+    have lhs : deriv ((L.weierstrassPExcept 0) - (L'.weierstrassPExcept 0)) z =
+        deriv (L.weierstrassPExcept 0) z - deriv (L'.weierstrassPExcept 0) z :=
+      deriv_sub h1z.differentiableAt h2z.differentiableAt
+    have rhs : deriv (fun z => z ^ m * E z) z =
+        (m : ℂ) * z ^ (m - 1) * E z + z ^ m * deriv E z :=
+      ((hasDerivAt_pow m z).mul hEz.differentiableAt.hasDerivAt).deriv
+    rw [← hd1, ← hd2, ← lhs, hz, rhs]
+  have key : ∀ᶠ z in 𝓝[≠] (0 : ℂ),
+      ((m : ℂ) * E z + z * deriv E z) *
+          ((z ^ 3 * (L.derivWeierstrassPExcept 0) z - 2) +
+            (z ^ 3 * (L'.derivWeierstrassPExcept 0) z - 2)) =
+        E z * (4 * ((z ^ 2 * (L.weierstrassPExcept 0) z + 1) ^ 2 +
+          (z ^ 2 * (L.weierstrassPExcept 0) z + 1) *
+            (z ^ 2 * (L'.weierstrassPExcept 0) z + 1) +
+            (z ^ 2 * (L'.weierstrassPExcept 0) z + 1) ^ 2) - L.g₂ * z ^ 4) := by
+    filter_upwards [mem_nhdsWithin_of_mem_nhds (L.compl_lattice_sdiff_singleton_mem_nhds 0),
+      mem_nhdsWithin_of_mem_nhds (L'.compl_lattice_sdiff_singleton_mem_nhds 0),
+      mem_nhdsWithin_of_mem_nhds hDE', mem_nhdsWithin_of_mem_nhds hderiv,
+      self_mem_nhdsWithin] with z hz1 hz2 hz3 hz4 hz0
+    have hz0' : z ≠ 0 := hz0
+    simp only [Set.mem_compl_iff, Set.mem_sdiff, SetLike.mem_coe, Set.mem_singleton_iff,
+      not_and, not_not] at hz1 hz2
+    have hzL : z ∉ L.lattice := fun h => hz0' (hz1 h)
+    have hzL' : z ∉ L'.lattice := fun h => hz0' (hz2 h)
+    have H1 := ode_except L hzL
+    have H2 := ode_except L' hzL'
+    rw [← h₂, ← h₃] at H2
+    have H3 : (L.weierstrassPExcept 0) z - (L'.weierstrassPExcept 0) z = z ^ m * E z :=
+      hz3
+    have H4 : z * ((L.derivWeierstrassPExcept 0) z - (L'.derivWeierstrassPExcept 0) z) =
+        (m : ℂ) * z ^ m * E z + z ^ (m + 1) * deriv E z := by
+      rw [hz4]
+      rcases m.eq_zero_or_pos with hm | hm
+      · subst hm; simp
+      · obtain ⟨k, rfl⟩ := Nat.exists_eq_add_of_le hm
+        simp only [Nat.add_sub_cancel_left, Nat.cast_add, Nat.cast_one]
+        ring
+    apply mul_left_cancel₀ (pow_ne_zero (m + 2) hz0')
+    linear_combination H1 - H2
+      - z ^ 2 * ((z ^ 3 * (L.derivWeierstrassPExcept 0) z - 2) +
+          (z ^ 3 * (L'.derivWeierstrassPExcept 0) z - 2)) * H4
+      + z ^ 2 * (4 * ((z ^ 2 * (L.weierstrassPExcept 0) z + 1) ^ 2 +
+          (z ^ 2 * (L.weierstrassPExcept 0) z + 1) *
+            (z ^ 2 * (L'.weierstrassPExcept 0) z + 1) +
+            (z ^ 2 * (L'.weierstrassPExcept 0) z + 1) ^ 2) - L.g₂ * z ^ 4) * H3
+  have hEc : ContinuousAt E 0 := hE.continuousAt
+  have hE'c : ContinuousAt (deriv E) 0 := hE.deriv.continuousAt
+  have hP₁c := hP₁.continuousAt
+  have hP₂c := hP₂.continuousAt
+  have hQ₁c := hQ₁.continuousAt
+  have hQ₂c := hQ₂.continuousAt
+  have hcont1 : ContinuousAt (fun z : ℂ => ((m : ℂ) * E z + z * deriv E z) *
+      ((z ^ 3 * (L.derivWeierstrassPExcept 0) z - 2) +
+        (z ^ 3 * (L'.derivWeierstrassPExcept 0) z - 2))) 0 := by
+    fun_prop
+  have hcont2 : ContinuousAt (fun z : ℂ => E z *
+      (4 * ((z ^ 2 * (L.weierstrassPExcept 0) z + 1) ^ 2 +
+      (z ^ 2 * (L.weierstrassPExcept 0) z + 1) * (z ^ 2 * (L'.weierstrassPExcept 0) z + 1) +
+        (z ^ 2 * (L'.weierstrassPExcept 0) z + 1) ^ 2) - L.g₂ * z ^ 4)) 0 := by
+    fun_prop
+  have hlim := tendsto_nhds_unique_of_eventuallyEq hcont1.continuousWithinAt.tendsto
+    hcont2.continuousWithinAt.tendsto key
+  have hlim' : ((m : ℂ) * E 0 + 0 * deriv E 0) *
+      (((0 : ℂ) ^ 3 * (L.derivWeierstrassPExcept 0) 0 - 2) +
+        ((0 : ℂ) ^ 3 * (L'.derivWeierstrassPExcept 0) 0 - 2)) =
+      E 0 * (4 * (((0 : ℂ) ^ 2 * (L.weierstrassPExcept 0) 0 + 1) ^ 2 +
+        ((0 : ℂ) ^ 2 * (L.weierstrassPExcept 0) 0 + 1) *
+          ((0 : ℂ) ^ 2 * (L'.weierstrassPExcept 0) 0 + 1) +
+          ((0 : ℂ) ^ 2 * (L'.weierstrassPExcept 0) 0 + 1) ^ 2) - L.g₂ * (0 : ℂ) ^ 4) := hlim
+  have hm : (4 * (m : ℂ) + 12) ≠ 0 := by
+    have : (4 * (m : ℂ) + 12) = ((4 * m + 12 : ℕ) : ℂ) := by push_cast; ring
+    rw [this, Nat.cast_ne_zero]; omega
+  apply hE0
+  have h : E 0 * (4 * (m : ℂ) + 12) = 0 := by linear_combination -hlim'
+  exact (mul_eq_zero.mp h).resolve_right hm
+
+lemma lattice_le_of_eqOn (L L' : PeriodPair)
+    (heq : Set.EqOn ℘[L] ℘[L'] ((L.lattice : Set ℂ) ∪ L'.lattice)ᶜ) :
+    L.lattice ≤ L'.lattice := by
+  intro x hx
+  by_contra hx'
+  have hU : ((L.lattice : Set ℂ) ∪ L'.lattice)ᶜ ∈ 𝓝[≠] x := by
+    have h1 : ((L.lattice : Set ℂ) \ {x})ᶜ ∈ 𝓝[≠] x :=
+      mem_nhdsWithin_of_mem_nhds (L.compl_lattice_sdiff_singleton_mem_nhds x)
+    have h2 : (L'.lattice : Set ℂ)ᶜ ∈ 𝓝[≠] x :=
+      mem_nhdsWithin_of_mem_nhds (L'.isClosed_lattice.isOpen_compl.mem_nhds hx')
+    filter_upwards [h1, h2, self_mem_nhdsWithin] with z hz1 hz2 hz3
+    simp only [Set.mem_compl_iff, Set.mem_sdiff, Set.mem_singleton_iff, SetLike.mem_coe,
+      Set.mem_union, not_or] at hz1 hz2 hz3 ⊢
+    exact ⟨fun h => hz1 ⟨h, hz3⟩, hz2⟩
+  have hfeq : ℘[L] =ᶠ[𝓝[≠] x] ℘[L'] := Filter.eventually_of_mem hU heq
+  have h₁ := L.order_weierstrassP x hx
+  have h₂ := (L'.analyticOnNhd_weierstrassP x hx').meromorphicOrderAt_nonneg
+  rw [← meromorphicOrderAt_congr hfeq, h₁] at h₂
+  exact absurd h₂ (by decide)
+
+lemma isPreconnected_compl_union (L L' : PeriodPair) :
+    IsPreconnected ((L.lattice : Set ℂ) ∪ L'.lattice)ᶜ := by
+  refine (Set.Countable.isConnected_compl_of_one_lt_rank (by simp) ?_).isPreconnected
+  refine Set.Countable.union ?_ ?_
+  · exact Set.countable_coe_iff.mp (countable_of_Lindelof_of_discrete (X := L.lattice))
+  · exact Set.countable_coe_iff.mp (countable_of_Lindelof_of_discrete (X := L'.lattice))
+
+lemma eqOn_of_eventuallyEq_zero (L L' : PeriodPair)
+    (h0 : ∀ᶠ z in 𝓝[≠] (0 : ℂ), ℘[L] z = ℘[L'] z) :
+    Set.EqOn ℘[L] ℘[L'] ((L.lattice : Set ℂ) ∪ L'.lattice)ᶜ := by
+  set U : Set ℂ := ((L.lattice : Set ℂ) ∪ L'.lattice)ᶜ with hU
+  have hUmem : ∀ᶠ z in 𝓝[≠] (0 : ℂ), z ∈ U := by
+    have h1 : ((L.lattice : Set ℂ) \ {0})ᶜ ∈ 𝓝[≠] (0 : ℂ) :=
+      mem_nhdsWithin_of_mem_nhds (L.compl_lattice_sdiff_singleton_mem_nhds 0)
+    have h2 : ((L'.lattice : Set ℂ) \ {0})ᶜ ∈ 𝓝[≠] (0 : ℂ) :=
+      mem_nhdsWithin_of_mem_nhds (L'.compl_lattice_sdiff_singleton_mem_nhds 0)
+    filter_upwards [h1, h2, self_mem_nhdsWithin] with z hz1 hz2 hz3
+    simp only [Set.mem_compl_iff, Set.mem_sdiff, Set.mem_singleton_iff, SetLike.mem_coe,
+      Set.mem_union, not_or, hU] at hz1 hz2 hz3 ⊢
+    exact ⟨fun h => hz1 ⟨h, hz3⟩, fun h => hz2 ⟨h, hz3⟩⟩
+  have hboth : ∀ᶠ z in 𝓝[≠] (0 : ℂ),
+      ∀ᶠ w in 𝓝 z, w ∈ U ∧ ℘[L] w = ℘[L'] w := by
+    have h := (hUmem.and h0)
+    rw [eventually_nhdsWithin_iff] at h ⊢
+    filter_upwards [h.eventually_nhds] with z hz hz0
+    have hne : ∀ᶠ w in 𝓝 z, w ≠ (0 : ℂ) := isOpen_ne.mem_nhds hz0
+    filter_upwards [hz, hne] with w hw hwne
+    exact hw hwne
+  obtain ⟨z₀, hz₀⟩ := hboth.exists
+  have hz₀U : z₀ ∈ U := (hz₀.self_of_nhds).1
+  have hfg : ℘[L] =ᶠ[𝓝 z₀] ℘[L'] := hz₀.mono fun w hw => hw.2
+  have hf : AnalyticOnNhd ℂ ℘[L] U :=
+    L.analyticOnNhd_weierstrassP.mono (Set.compl_subset_compl.2 Set.subset_union_left)
+  have hg : AnalyticOnNhd ℂ ℘[L'] U :=
+    L'.analyticOnNhd_weierstrassP.mono (Set.compl_subset_compl.2 Set.subset_union_right)
+  exact hf.eqOn_of_preconnected_of_eventuallyEq hg (isPreconnected_compl_union L L') hz₀U hfg
+
+end PeriodPair.LatticeFromInvariants
+
+end
+
+open PeriodPair.LatticeFromInvariants in
+theorem solution (L L' : PeriodPair)
+    (h₂ : L.g₂ = L'.g₂) (h₃ : L.g₃ = L'.g₃) : L.lattice = L'.lattice := by
+  have heq := eqOn_of_eventuallyEq_zero L L' (eventuallyEq_zero L L' h₂ h₃)
+  refine le_antisymm (lattice_le_of_eqOn L L' heq) (lattice_le_of_eqOn L' L ?_)
+  rw [Set.union_comm]
+  exact heq.symm
+
+end S_PeriodPair_lattice_eq_of_g2_eq_of_g3_eq
+end P2MW
+export P2MW.S_PeriodPair_lattice_eq_of_g2_eq_of_g3_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem PeriodPair.lattice_eq_of_g2_eq_of_g3_eq (L L' : PeriodPair)
+    (h₂ : L.g₂ = L'.g₂) (h₃ : L.g₃ = L'.g₃)
+    : L.lattice = L'.lattice :=
+  solution L L' h₂ h₃
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Polynomial_irreducible_of_transitive_ringAut.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Polynomial_irreducible_of_transitive_ringAut.lean
new file mode 100644
index 0000000000..d86e1901aa
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Polynomial_irreducible_of_transitive_ringAut.lean
@@ -0,0 +1,263 @@
+/-
+Based on Prove2Me node Polynomial.irreducible_of_transitive_ringAut
+(763351d7-5da4-5854-bb26-2f75fc84e0e7) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d7f4eaeb-1dc2-5c76-9fab-2dcba212579a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Polynomial.Splits
+
+import Mathlib.Algebra.Polynomial.FieldDivision
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Irreducibility from an automorphism cycling all but one root
+
+Theorem statement: `Polynomial.irreducible_of_transitive_ringAut`
+(`763351d7-5da4-5854-bb26-2f75fc84e0e7`), by Claude, 2026-09-05.
+
+Proof: submission `d7f4eaeb-1dc2-5c76-9fab-2dcba212579a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $L$ be fields with $L$ an $F$-algebra, and let $P \in F[X]$ be monic and such that its
+image $P^{L}$ under the coefficient map $F \to L$ splits over $L$. Let $\sigma : L \to L$ be a ring
+automorphism of $L$ fixing every element of the image of $F$ in $L$, i.e.
+$\sigma(\mathrm{algebraMap}\,a) = \mathrm{algebraMap}\,a$ for all $a \in F$. Suppose given $y_0 \in
+L$, a sequence $r : \mathbb{N} \to L$ and a natural number $n$ such that the multiset of roots of
+$P^{L}$ is exactly $y_0$ together with $r(0), \dots, r(n-1)$ (the image of $\{0,\dots,n-1\}$ under
+$r$), that this multiset of roots has no repetitions, that $\sigma(r(i)) = r((i+1) \bmod n)$ for
+every $i < n$, so that $\sigma$ permutes $r(0), \dots, r(n-1)$ cyclically, and that $y_0$ does not
+lie in the image of $F$ in $L$. Then $P$ is irreducible in $F[X]$.
+
+This is the standard orbit argument for irreducibility: a monic polynomial split with simple roots
+over $L$, whose roots other than a distinguished one form a single cycle under an $F$-fixing
+automorphism of $L$, cannot factor nontrivially once the distinguished root is irrational over $F$.
+It is applied in the algebraic theory of the modular curve $X_0(N)$, where it supplies the
+irreducibility input for the computations of $\mathrm{finrank}$ of fields generated by values
+$j(q^N)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Polynomial_irreducible_of_transitive_ringAut.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_Polynomial_irreducible_of_transitive_ringAut
+
+p2m_open "Polynomial P2MW.S_Polynomial_irreducible_of_transitive_ringAut.Polynomial"
+
+namespace Polynomial
+p2m_export "Polynomial" "C Splits.of_dvd card_roots' coeff_map natDegree_mul coeff unique aeval \
+  coeff_C_zero Splits.of_natDegree_eq_one degree factor IsRoot.def map_map Splits map mem_roots \
+  eq_zero_of_natDegree_lt_card_of_eval_eq_zero' Monic comp roots natDegree_eq_card_roots \
+  roots.le_of_dvd natDegree eval_C natDegree_sub_le eval_sub natDegree_map map_dvd natDegree_C mod \
+  eval_map_algebraMap ext roots_map IsRoot ring roots_mul"
+end Polynomial
+p2m_open_scoped "Polynomial" in
+private theorem Polynomial.mem_range_of_unique_common_root {F L : Type*} [Field F] [Field L]
+    [Algebra F L]
+    (A B : Polynomial F) (hA : A ≠ 0) (hAs : (A.map (algebraMap F L)).Splits)
+    (hAnd : (A.map (algebraMap F L)).roots.Nodup) (x : L) (hxA : Polynomial.aeval x A = 0)
+    (hxB : Polynomial.aeval x B = 0)
+    (huniq : ∀ y : L, Polynomial.aeval y A = 0 → Polynomial.aeval y B = 0 → y = x) :
+    x ∈ (algebraMap F L).range := by
+  classical
+  set i := algebraMap F L with hi
+  set g := EuclideanDomain.gcd A B with hg
+  have hg0 : g ≠ 0 := fun h => hA (EuclideanDomain.gcd_eq_zero_iff.mp h).1
+  have hgA : g ∣ A := EuclideanDomain.gcd_dvd_left _ _
+  have hgB : g ∣ B := EuclideanDomain.gcd_dvd_right _ _
+  have hAm0 : A.map i ≠ 0 := (Polynomial.map_ne_zero_iff i.injective).mpr hA
+  have hgm0 : g.map i ≠ 0 := (Polynomial.map_ne_zero_iff i.injective).mpr hg0
+  have hxg : Polynomial.aeval x g = 0 := by
+    rw [hg, EuclideanDomain.gcd_eq_gcd_ab A B, map_add, map_mul, map_mul, hxA, hxB, zero_mul,
+      zero_mul,
+      add_zero]
+  have hroot_eq : ∀ y ∈ (g.map i).roots, y = x := by
+    intro y hy
+    rw [Polynomial.mem_roots hgm0, Polynomial.IsRoot.def, Polynomial.eval_map_algebraMap] at hy
+    refine huniq y ?_ ?_
+    · obtain ⟨c, hc⟩ := hgA
+      rw [hc, map_mul, hy, zero_mul]
+    · obtain ⟨c, hc⟩ := hgB
+      rw [hc, map_mul, hy, zero_mul]
+  have hxmem : x ∈ (g.map i).roots := by
+    rw [Polynomial.mem_roots hgm0, Polynomial.IsRoot.def, Polynomial.eval_map_algebraMap]; exact hxg
+  have hle : (g.map i).roots ≤ (A.map i).roots :=
+    Polynomial.roots.le_of_dvd hAm0 (Polynomial.map_dvd i hgA)
+  have hnd : (g.map i).roots.Nodup := Multiset.nodup_of_le hle hAnd
+  have hcount : (g.map i).roots.count x = Multiset.card (g.map i).roots :=
+    Multiset.count_eq_card.mpr fun y hy => (hroot_eq y hy).symm
+  have hcard : Multiset.card (g.map i).roots = 1 := by
+    have h1 : (g.map i).roots.count x ≤ 1 := Multiset.nodup_iff_count_le_one.mp hnd x
+    have h2 : 0 < (g.map i).roots.count x := Multiset.count_pos.mpr hxmem
+    omega
+  have hgs : (g.map i).Splits := Polynomial.Splits.of_dvd hAs hAm0 (Polynomial.map_dvd i hgA)
+  have hdeg : g.natDegree = 1 := by
+    rw [← Polynomial.natDegree_map i, hgs.natDegree_eq_card_roots, hcard]
+  have hgsF : g.Splits := Polynomial.Splits.of_natDegree_eq_one hdeg
+  exact hgsF.mem_range_of_isRoot hg0 ((Polynomial.mem_roots hgm0).mp hxmem)
+
+p2m_open_scoped "Polynomial" in
+private theorem Polynomial.mem_range_of_eval_eq_const {F L : Type*} [Field F] [Field L]
+    [Algebra F L]
+    (g : Polynomial F) (x : L) (s : Finset L) (hcard : g.natDegree < s.card)
+    (hval : ∀ y ∈ s, Polynomial.aeval y g = x) : x ∈ (algebraMap F L).range := by
+  classical
+  set i := algebraMap F L
+  set Q : Polynomial L := g.map i - Polynomial.C x with hQ
+  have hQdeg : Q.natDegree ≤ g.natDegree := by
+    refine (Polynomial.natDegree_sub_le _ _).trans ?_
+    rw [Polynomial.natDegree_map, Polynomial.natDegree_C, max_eq_left (Nat.zero_le _)]
+  have hQ0 : Q = 0 := by
+    refine Polynomial.eq_zero_of_natDegree_lt_card_of_eval_eq_zero' Q s (fun y hy => ?_)
+      (hQdeg.trans_lt hcard)
+    rw [hQ, Polynomial.eval_sub, Polynomial.eval_C, Polynomial.eval_map_algebraMap, hval y hy,
+      sub_self]
+  have hconst : g.map i = Polynomial.C x := sub_eq_zero.mp hQ0
+  refine ⟨g.coeff 0, ?_⟩
+  have := congrArg (fun P : Polynomial L => P.coeff 0) hconst
+  simpa only [Polynomial.coeff_map, Polynomial.coeff_C_zero] using this
+
+p2m_open_scoped "Polynomial" in
+private theorem Polynomial.irreducible_of_transitive_ringAut {F L : Type*} [Field F] [Field L]
+    [Algebra F L]
+    (P : Polynomial F) (hP : P.Monic) (hPs : (P.map (algebraMap F L)).Splits) (σ : L ≃+* L)
+    (hσ : ∀ a : F, σ (algebraMap F L a) = algebraMap F L a) (y₀ : L) (r : ℕ → L) (n : ℕ)
+    (hroots : (P.map (algebraMap F L)).roots = y₀ ::ₘ (Multiset.range n).map r)
+    (hnodup : (P.map (algebraMap F L)).roots.Nodup) (hcycle : ∀ i < n, σ (r i) = r ((i + 1) % n))
+    (hy₀ : y₀ ∉ (algebraMap F L).range) : Irreducible P := by
+  classical
+  set i := algebraMap F L with hi
+  have hσi : (σ : L →+* L).comp i = i := RingHom.ext fun a => hσ a
+  have hPm0 : P.map i ≠ 0 := (Polynomial.map_ne_zero_iff i.injective).mpr hP.ne_zero
+  have hPdeg : P.natDegree = n + 1 := by
+    rw [← Polynomial.natDegree_map i, hPs.natDegree_eq_card_roots, hroots, Multiset.card_cons,
+      Multiset.card_map,
+      Multiset.card_range]
+  have hy₀_notin : y₀ ∉ (Multiset.range n).map r := by
+    rw [hroots] at hnodup; exact (Multiset.nodup_cons.mp hnodup).1
+  have hr_nodup : ((Multiset.range n).map r).Nodup := by
+    rw [hroots] at hnodup; exact (Multiset.nodup_cons.mp hnodup).2
+  have key : ∀ f g : Polynomial F, f.Monic → g.Monic → f * g = P → y₀ ∈ (f.map i).roots →
+    g.natDegree = 0 :=
+    by
+    intro f g hf hg hfg hyf
+    have hfm0 : f.map i ≠ 0 := (Polynomial.map_ne_zero_iff i.injective).mpr hf.ne_zero
+    have hgm0 : g.map i ≠ 0 := (Polynomial.map_ne_zero_iff i.injective).mpr hg.ne_zero
+    have hsplit : (P.map i).roots = (f.map i).roots + (g.map i).roots := by
+      rw [← hfg, Polynomial.map_mul, Polynomial.roots_mul (mul_ne_zero hfm0 hgm0)]
+    have hgle : (g.map i).roots ≤ (P.map i).roots := by rw [hsplit]; exact Multiset.le_add_left _ _
+    have hg_nd : (g.map i).roots.Nodup := Multiset.nodup_of_le hgle hnodup
+    have hy₀g : y₀ ∉ (g.map i).roots := by
+      intro hyg
+      have h2 : 2 ≤ (P.map i).roots.count y₀ := by
+        rw [hsplit, Multiset.count_add]
+        have := Multiset.count_pos.mpr hyf; have := Multiset.count_pos.mpr hyg; omega
+      have h1 := Multiset.nodup_iff_count_le_one.mp hnodup y₀
+      omega
+    have hgsub : ∀ y ∈ (g.map i).roots, y ∈ (Multiset.range n).map r := by
+      intro y hy
+      have : y ∈ (P.map i).roots := Multiset.mem_of_le hgle hy
+      rw [hroots, Multiset.mem_cons] at this
+      rcases this with rfl | h
+      · exact absurd hy hy₀g
+      · exact h
+    have hgs : (g.map i).Splits :=
+      Polynomial.Splits.of_dvd hPs hPm0 (by rw [← hfg, Polynomial.map_mul]; exact dvd_mul_left _ _)
+    have hstable : ((g.map i).roots).map (σ : L →+* L) = (g.map i).roots := by
+      rw [← hgs.roots_map (σ : L →+* L), Polynomial.map_map, hσi]
+    have hmemσ : ∀ y ∈ (g.map i).roots, σ y ∈ (g.map i).roots := by
+      intro y hy
+      rw [← hstable]; exact Multiset.mem_map.mpr ⟨y, hy, rfl⟩
+    by_contra hgdeg
+    have hgroots_ne : (g.map i).roots ≠ 0 := by
+      intro h0
+      apply hgdeg
+      rw [← Polynomial.natDegree_map i, hgs.natDegree_eq_card_roots, h0, Multiset.card_zero]
+    obtain ⟨y, hy⟩ := Multiset.exists_mem_of_ne_zero hgroots_ne
+    obtain ⟨j₀, hj₀, rfl⟩ := Multiset.mem_map.mp (hgsub y hy)
+    rw [Multiset.mem_range] at hj₀
+    have hnpos : 0 < n := lt_of_le_of_lt (Nat.zero_le _) hj₀
+    have horbit : ∀ k : ℕ, r ((j₀ + k) % n) ∈ (g.map i).roots := by
+      intro k
+      induction k with
+      | zero => rwa [add_zero, Nat.mod_eq_of_lt hj₀]
+      | succ k ih =>
+        have h1 := hmemσ _ ih
+        rw [hcycle _ (Nat.mod_lt _ hnpos), Nat.mod_add_mod, add_assoc] at h1
+        exact h1
+    have hall : ∀ j < n, r j ∈ (g.map i).roots := by
+      intro j hj
+      have := horbit (j + n - j₀)
+      have e : (j₀ + (j + n - j₀)) % n = j := by
+        rw [show j₀ + (j + n - j₀) = j + n by omega, Nat.add_mod_right, Nat.mod_eq_of_lt hj]
+      rwa [e] at this
+    have hle : (Multiset.range n).map r ≤ (g.map i).roots := by
+      rw [Multiset.le_iff_subset hr_nodup]
+      intro y hy
+      obtain ⟨j, hj, rfl⟩ := Multiset.mem_map.mp hy
+      exact hall j (Multiset.mem_range.mp hj)
+    have hgdeg_ge : n ≤ g.natDegree := by
+      rw [← Polynomial.natDegree_map i, hgs.natDegree_eq_card_roots]
+      simpa using Multiset.card_le_card hle
+    have hsum : f.natDegree + g.natDegree = n + 1 := by rw [← hf.natDegree_mul hg, hfg, hPdeg]
+    have hfdeg_pos : 1 ≤ f.natDegree := by
+      rw [← Polynomial.natDegree_map i]
+      have := Polynomial.card_roots' (f.map i)
+      have hpos : 0 < Multiset.card (f.map i).roots :=
+        Multiset.card_pos_iff_exists_mem.mpr ⟨y₀, hyf⟩
+      omega
+    have hfdeg : f.natDegree = 1 := by omega
+    have hfs : f.Splits := Polynomial.Splits.of_natDegree_eq_one hfdeg
+    exact hy₀ (hfs.mem_range_of_isRoot hf.ne_zero ((Polynomial.mem_roots hfm0).mp hyf))
+  rw [hP.irreducible_iff_natDegree]
+  refine ⟨fun h1 => by simp [h1] at hPdeg, fun f g hf hg hfg => ?_⟩
+  have hfm0 : f.map i ≠ 0 := (Polynomial.map_ne_zero_iff i.injective).mpr hf.ne_zero
+  have hgm0 : g.map i ≠ 0 := (Polynomial.map_ne_zero_iff i.injective).mpr hg.ne_zero
+  have hy₀P : y₀ ∈ (P.map i).roots := by rw [hroots]; exact Multiset.mem_cons_self _ _
+  rw [← hfg, Polynomial.map_mul, Polynomial.roots_mul (mul_ne_zero hfm0 hgm0),
+    Multiset.mem_add] at hy₀P
+  rcases hy₀P with h | h
+  · exact Or.inr (key f g hf hg hfg h)
+  · exact Or.inl (key g f hg hf (by rw [mul_comm]; exact hfg) h)
+
+theorem solution {F L : Type*} [Field F] [Field L] [Algebra F L] (P : Polynomial F) (hP : P.Monic)
+    (hPs : (P.map (algebraMap F L)).Splits) (σ : L ≃+* L)
+    (hσ : ∀ a : F, σ (algebraMap F L a) = algebraMap F L a) (y₀ : L) (r : ℕ → L) (n : ℕ)
+    (hroots : (P.map (algebraMap F L)).roots = y₀ ::ₘ (Multiset.range n).map r)
+    (hnodup : (P.map (algebraMap F L)).roots.Nodup) (hcycle : ∀ i < n, σ (r i) = r ((i + 1) % n))
+    (hy₀ : y₀ ∉ (algebraMap F L).range) :
+    Irreducible P :=
+  Polynomial.irreducible_of_transitive_ringAut P hP hPs σ hσ y₀ r n hroots hnodup hcycle hy₀
+
+end S_Polynomial_irreducible_of_transitive_ringAut
+end P2MW
+export P2MW.S_Polynomial_irreducible_of_transitive_ringAut (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem Polynomial.irreducible_of_transitive_ringAut {F L : Type*} [Field F] [Field L] [Algebra F L]
+    (P : Polynomial F) (hP : P.Monic) (hPs : (P.map (algebraMap F L)).Splits) (σ : L ≃+* L)
+    (hσ : ∀ a : F, σ (algebraMap F L a) = algebraMap F L a) (y₀ : L) (r : ℕ → L) (n : ℕ)
+    (hroots : (P.map (algebraMap F L)).roots = y₀ ::ₘ (Multiset.range n).map r)
+    (hnodup : (P.map (algebraMap F L)).roots.Nodup) (hcycle : ∀ i < n, σ (r i) = r ((i + 1) % n))
+    (hy₀ : y₀ ∉ (algebraMap F L).range) :
+    Irreducible P :=
+  solution P hP hPs σ hσ y₀ r n hroots hnodup hcycle hy₀
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Polynomial_mem_range_of_eval_eq_const.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Polynomial_mem_range_of_eval_eq_const.lean
new file mode 100644
index 0000000000..ad81faec26
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Polynomial_mem_range_of_eval_eq_const.lean
@@ -0,0 +1,255 @@
+/-
+Based on Prove2Me node Polynomial.mem_range_of_eval_eq_const
+(c4f3e03f-4be9-50b0-a04b-f07534522a5a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 27471ee8-b989-5b1c-a3a8-e96fa677fc40
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Polynomial.Splits
+
+import Mathlib.Algebra.Polynomial.FieldDivision
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A value attained too often lies in the base field
+
+Theorem statement: `Polynomial.mem_range_of_eval_eq_const` (`c4f3e03f-4be9-50b0-a04b-f07534522a5a`),
+by Claude, 2026-09-05.
+
+Proof: submission `27471ee8-b989-5b1c-a3a8-e96fa677fc40`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $L$ be fields with $L$ an $F$-algebra, let $g \in F[Y]$ be a polynomial with
+coefficients in $F$, let $x \in L$, and let $s$ be a finite subset of $L$. Assume that the natural
+degree of $g$ is strictly smaller than the cardinality of $s$, and that for every $y \in s$ the
+value of $g$ at $y$ under the $F$-algebra evaluation map $L[Y] \to L$ induced by $y$ (that is, $g$
+evaluated at $y$ after pushing its coefficients into $L$ along the structure map) equals $x$. The
+conclusion is that $x$ lies in the range of the algebra map $F \to L$, i.e. $x$ is the image of an
+element of $F$. Note that the hypothesis uses `natDegree`, so the degenerate case $g = 0$ is
+covered: there the hypothesis merely requires $s$ to be nonempty, and the value $x$ is then $0$,
+which is indeed in the range.
+
+This is the elementary statement that a polynomial over $F$ of degree less than $\#s$ which is
+constant on $s$ has its constant value in $F$ — equivalently, that the nonzero polynomial $g - x$
+could not have $\#s$ roots in $L$ unless $x$ comes from $F$. It is used in the analysis of the
+function field of the modular curve $X_0(N)$, in the proof that the relevant $j$-value does not lie
+in the subalgebra generated by the modular polynomial's other root.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Polynomial_mem_range_of_eval_eq_const.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_Polynomial_mem_range_of_eval_eq_const
+
+p2m_open "Polynomial P2MW.S_Polynomial_mem_range_of_eval_eq_const.Polynomial"
+
+namespace Polynomial
+p2m_export "Polynomial" "C Splits.of_dvd card_roots' coeff_map natDegree_mul coeff unique aeval \
+  coeff_C_zero Splits.of_natDegree_eq_one degree factor IsRoot.def map_map Splits map mem_roots \
+  eq_zero_of_natDegree_lt_card_of_eval_eq_zero' Monic comp roots natDegree_eq_card_roots \
+  roots.le_of_dvd natDegree eval_C natDegree_sub_le eval_sub natDegree_map map_dvd natDegree_C mod \
+  eval_map_algebraMap ext roots_map IsRoot ring roots_mul"
+end Polynomial
+p2m_open_scoped "Polynomial" in
+private theorem Polynomial.mem_range_of_unique_common_root {F L : Type*} [Field F] [Field L]
+    [Algebra F L]
+    (A B : Polynomial F) (hA : A ≠ 0) (hAs : (A.map (algebraMap F L)).Splits)
+    (hAnd : (A.map (algebraMap F L)).roots.Nodup) (x : L) (hxA : Polynomial.aeval x A = 0)
+    (hxB : Polynomial.aeval x B = 0)
+    (huniq : ∀ y : L, Polynomial.aeval y A = 0 → Polynomial.aeval y B = 0 → y = x) :
+    x ∈ (algebraMap F L).range := by
+  classical
+  set i := algebraMap F L with hi
+  set g := EuclideanDomain.gcd A B with hg
+  have hg0 : g ≠ 0 := fun h => hA (EuclideanDomain.gcd_eq_zero_iff.mp h).1
+  have hgA : g ∣ A := EuclideanDomain.gcd_dvd_left _ _
+  have hgB : g ∣ B := EuclideanDomain.gcd_dvd_right _ _
+  have hAm0 : A.map i ≠ 0 := (Polynomial.map_ne_zero_iff i.injective).mpr hA
+  have hgm0 : g.map i ≠ 0 := (Polynomial.map_ne_zero_iff i.injective).mpr hg0
+  have hxg : Polynomial.aeval x g = 0 := by
+    rw [hg, EuclideanDomain.gcd_eq_gcd_ab A B, map_add, map_mul, map_mul, hxA, hxB, zero_mul,
+      zero_mul,
+      add_zero]
+  have hroot_eq : ∀ y ∈ (g.map i).roots, y = x := by
+    intro y hy
+    rw [Polynomial.mem_roots hgm0, Polynomial.IsRoot.def, Polynomial.eval_map_algebraMap] at hy
+    refine huniq y ?_ ?_
+    · obtain ⟨c, hc⟩ := hgA
+      rw [hc, map_mul, hy, zero_mul]
+    · obtain ⟨c, hc⟩ := hgB
+      rw [hc, map_mul, hy, zero_mul]
+  have hxmem : x ∈ (g.map i).roots := by
+    rw [Polynomial.mem_roots hgm0, Polynomial.IsRoot.def, Polynomial.eval_map_algebraMap]; exact hxg
+  have hle : (g.map i).roots ≤ (A.map i).roots :=
+    Polynomial.roots.le_of_dvd hAm0 (Polynomial.map_dvd i hgA)
+  have hnd : (g.map i).roots.Nodup := Multiset.nodup_of_le hle hAnd
+  have hcount : (g.map i).roots.count x = Multiset.card (g.map i).roots :=
+    Multiset.count_eq_card.mpr fun y hy => (hroot_eq y hy).symm
+  have hcard : Multiset.card (g.map i).roots = 1 := by
+    have h1 : (g.map i).roots.count x ≤ 1 := Multiset.nodup_iff_count_le_one.mp hnd x
+    have h2 : 0 < (g.map i).roots.count x := Multiset.count_pos.mpr hxmem
+    omega
+  have hgs : (g.map i).Splits := Polynomial.Splits.of_dvd hAs hAm0 (Polynomial.map_dvd i hgA)
+  have hdeg : g.natDegree = 1 := by
+    rw [← Polynomial.natDegree_map i, hgs.natDegree_eq_card_roots, hcard]
+  have hgsF : g.Splits := Polynomial.Splits.of_natDegree_eq_one hdeg
+  exact hgsF.mem_range_of_isRoot hg0 ((Polynomial.mem_roots hgm0).mp hxmem)
+
+p2m_open_scoped "Polynomial" in
+private theorem Polynomial.mem_range_of_eval_eq_const {F L : Type*} [Field F] [Field L]
+    [Algebra F L]
+    (g : Polynomial F) (x : L) (s : Finset L) (hcard : g.natDegree < s.card)
+    (hval : ∀ y ∈ s, Polynomial.aeval y g = x) : x ∈ (algebraMap F L).range := by
+  classical
+  set i := algebraMap F L
+  set Q : Polynomial L := g.map i - Polynomial.C x with hQ
+  have hQdeg : Q.natDegree ≤ g.natDegree := by
+    refine (Polynomial.natDegree_sub_le _ _).trans ?_
+    rw [Polynomial.natDegree_map, Polynomial.natDegree_C, max_eq_left (Nat.zero_le _)]
+  have hQ0 : Q = 0 := by
+    refine Polynomial.eq_zero_of_natDegree_lt_card_of_eval_eq_zero' Q s (fun y hy => ?_)
+      (hQdeg.trans_lt hcard)
+    rw [hQ, Polynomial.eval_sub, Polynomial.eval_C, Polynomial.eval_map_algebraMap, hval y hy,
+      sub_self]
+  have hconst : g.map i = Polynomial.C x := sub_eq_zero.mp hQ0
+  refine ⟨g.coeff 0, ?_⟩
+  have := congrArg (fun P : Polynomial L => P.coeff 0) hconst
+  simpa only [Polynomial.coeff_map, Polynomial.coeff_C_zero] using this
+
+p2m_open_scoped "Polynomial" in
+private theorem Polynomial.irreducible_of_transitive_ringAut {F L : Type*} [Field F] [Field L]
+    [Algebra F L]
+    (P : Polynomial F) (hP : P.Monic) (hPs : (P.map (algebraMap F L)).Splits) (σ : L ≃+* L)
+    (hσ : ∀ a : F, σ (algebraMap F L a) = algebraMap F L a) (y₀ : L) (r : ℕ → L) (n : ℕ)
+    (hroots : (P.map (algebraMap F L)).roots = y₀ ::ₘ (Multiset.range n).map r)
+    (hnodup : (P.map (algebraMap F L)).roots.Nodup) (hcycle : ∀ i < n, σ (r i) = r ((i + 1) % n))
+    (hy₀ : y₀ ∉ (algebraMap F L).range) : Irreducible P := by
+  classical
+  set i := algebraMap F L with hi
+  have hσi : (σ : L →+* L).comp i = i := RingHom.ext fun a => hσ a
+  have hPm0 : P.map i ≠ 0 := (Polynomial.map_ne_zero_iff i.injective).mpr hP.ne_zero
+  have hPdeg : P.natDegree = n + 1 := by
+    rw [← Polynomial.natDegree_map i, hPs.natDegree_eq_card_roots, hroots, Multiset.card_cons,
+      Multiset.card_map,
+      Multiset.card_range]
+  have hy₀_notin : y₀ ∉ (Multiset.range n).map r := by
+    rw [hroots] at hnodup; exact (Multiset.nodup_cons.mp hnodup).1
+  have hr_nodup : ((Multiset.range n).map r).Nodup := by
+    rw [hroots] at hnodup; exact (Multiset.nodup_cons.mp hnodup).2
+  have key : ∀ f g : Polynomial F, f.Monic → g.Monic → f * g = P → y₀ ∈ (f.map i).roots →
+    g.natDegree = 0 :=
+    by
+    intro f g hf hg hfg hyf
+    have hfm0 : f.map i ≠ 0 := (Polynomial.map_ne_zero_iff i.injective).mpr hf.ne_zero
+    have hgm0 : g.map i ≠ 0 := (Polynomial.map_ne_zero_iff i.injective).mpr hg.ne_zero
+    have hsplit : (P.map i).roots = (f.map i).roots + (g.map i).roots := by
+      rw [← hfg, Polynomial.map_mul, Polynomial.roots_mul (mul_ne_zero hfm0 hgm0)]
+    have hgle : (g.map i).roots ≤ (P.map i).roots := by rw [hsplit]; exact Multiset.le_add_left _ _
+    have hg_nd : (g.map i).roots.Nodup := Multiset.nodup_of_le hgle hnodup
+    have hy₀g : y₀ ∉ (g.map i).roots := by
+      intro hyg
+      have h2 : 2 ≤ (P.map i).roots.count y₀ := by
+        rw [hsplit, Multiset.count_add]
+        have := Multiset.count_pos.mpr hyf; have := Multiset.count_pos.mpr hyg; omega
+      have h1 := Multiset.nodup_iff_count_le_one.mp hnodup y₀
+      omega
+    have hgsub : ∀ y ∈ (g.map i).roots, y ∈ (Multiset.range n).map r := by
+      intro y hy
+      have : y ∈ (P.map i).roots := Multiset.mem_of_le hgle hy
+      rw [hroots, Multiset.mem_cons] at this
+      rcases this with rfl | h
+      · exact absurd hy hy₀g
+      · exact h
+    have hgs : (g.map i).Splits :=
+      Polynomial.Splits.of_dvd hPs hPm0 (by rw [← hfg, Polynomial.map_mul]; exact dvd_mul_left _ _)
+    have hstable : ((g.map i).roots).map (σ : L →+* L) = (g.map i).roots := by
+      rw [← hgs.roots_map (σ : L →+* L), Polynomial.map_map, hσi]
+    have hmemσ : ∀ y ∈ (g.map i).roots, σ y ∈ (g.map i).roots := by
+      intro y hy
+      rw [← hstable]; exact Multiset.mem_map.mpr ⟨y, hy, rfl⟩
+    by_contra hgdeg
+    have hgroots_ne : (g.map i).roots ≠ 0 := by
+      intro h0
+      apply hgdeg
+      rw [← Polynomial.natDegree_map i, hgs.natDegree_eq_card_roots, h0, Multiset.card_zero]
+    obtain ⟨y, hy⟩ := Multiset.exists_mem_of_ne_zero hgroots_ne
+    obtain ⟨j₀, hj₀, rfl⟩ := Multiset.mem_map.mp (hgsub y hy)
+    rw [Multiset.mem_range] at hj₀
+    have hnpos : 0 < n := lt_of_le_of_lt (Nat.zero_le _) hj₀
+    have horbit : ∀ k : ℕ, r ((j₀ + k) % n) ∈ (g.map i).roots := by
+      intro k
+      induction k with
+      | zero => rwa [add_zero, Nat.mod_eq_of_lt hj₀]
+      | succ k ih =>
+        have h1 := hmemσ _ ih
+        rw [hcycle _ (Nat.mod_lt _ hnpos), Nat.mod_add_mod, add_assoc] at h1
+        exact h1
+    have hall : ∀ j < n, r j ∈ (g.map i).roots := by
+      intro j hj
+      have := horbit (j + n - j₀)
+      have e : (j₀ + (j + n - j₀)) % n = j := by
+        rw [show j₀ + (j + n - j₀) = j + n by omega, Nat.add_mod_right, Nat.mod_eq_of_lt hj]
+      rwa [e] at this
+    have hle : (Multiset.range n).map r ≤ (g.map i).roots := by
+      rw [Multiset.le_iff_subset hr_nodup]
+      intro y hy
+      obtain ⟨j, hj, rfl⟩ := Multiset.mem_map.mp hy
+      exact hall j (Multiset.mem_range.mp hj)
+    have hgdeg_ge : n ≤ g.natDegree := by
+      rw [← Polynomial.natDegree_map i, hgs.natDegree_eq_card_roots]
+      simpa using Multiset.card_le_card hle
+    have hsum : f.natDegree + g.natDegree = n + 1 := by rw [← hf.natDegree_mul hg, hfg, hPdeg]
+    have hfdeg_pos : 1 ≤ f.natDegree := by
+      rw [← Polynomial.natDegree_map i]
+      have := Polynomial.card_roots' (f.map i)
+      have hpos : 0 < Multiset.card (f.map i).roots :=
+        Multiset.card_pos_iff_exists_mem.mpr ⟨y₀, hyf⟩
+      omega
+    have hfdeg : f.natDegree = 1 := by omega
+    have hfs : f.Splits := Polynomial.Splits.of_natDegree_eq_one hfdeg
+    exact hy₀ (hfs.mem_range_of_isRoot hf.ne_zero ((Polynomial.mem_roots hfm0).mp hyf))
+  rw [hP.irreducible_iff_natDegree]
+  refine ⟨fun h1 => by simp [h1] at hPdeg, fun f g hf hg hfg => ?_⟩
+  have hfm0 : f.map i ≠ 0 := (Polynomial.map_ne_zero_iff i.injective).mpr hf.ne_zero
+  have hgm0 : g.map i ≠ 0 := (Polynomial.map_ne_zero_iff i.injective).mpr hg.ne_zero
+  have hy₀P : y₀ ∈ (P.map i).roots := by rw [hroots]; exact Multiset.mem_cons_self _ _
+  rw [← hfg, Polynomial.map_mul, Polynomial.roots_mul (mul_ne_zero hfm0 hgm0),
+    Multiset.mem_add] at hy₀P
+  rcases hy₀P with h | h
+  · exact Or.inr (key f g hf hg hfg h)
+  · exact Or.inl (key g f hg hf (by rw [mul_comm]; exact hfg) h)
+
+theorem solution {F L : Type*} [Field F] [Field L] [Algebra F L] (g : Polynomial F) (x : L)
+    (s : Finset L) (hcard : g.natDegree < s.card) (hval : ∀ y ∈ s, Polynomial.aeval y g = x) :
+    x ∈ (algebraMap F L).range :=
+  Polynomial.mem_range_of_eval_eq_const g x s hcard hval
+
+end S_Polynomial_mem_range_of_eval_eq_const
+end P2MW
+export P2MW.S_Polynomial_mem_range_of_eval_eq_const (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem Polynomial.mem_range_of_eval_eq_const {F L : Type*} [Field F] [Field L] [Algebra F L]
+    (g : Polynomial F) (x : L) (s : Finset L) (hcard : g.natDegree < s.card)
+    (hval : ∀ y ∈ s, Polynomial.aeval y g = x) :
+    x ∈ (algebraMap F L).range :=
+  solution g x s hcard hval
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Polynomial_mem_range_of_unique_common_root.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Polynomial_mem_range_of_unique_common_root.lean
new file mode 100644
index 0000000000..d4fff8187b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Polynomial_mem_range_of_unique_common_root.lean
@@ -0,0 +1,260 @@
+/-
+Based on Prove2Me node Polynomial.mem_range_of_unique_common_root
+(059deab2-7e60-5275-95da-b2b308cb1ae6) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1be1f735-9591-5b4c-87da-71c8bc6713bf
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Polynomial.Splits
+
+import Mathlib.Algebra.Polynomial.FieldDivision
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Unique common root of a split separable polynomial is rational
+
+Theorem statement: `Polynomial.mem_range_of_unique_common_root`
+(`059deab2-7e60-5275-95da-b2b308cb1ae6`), by Claude, 2026-09-05.
+
+Proof: submission `1be1f735-9591-5b4c-87da-71c8bc6713bf`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $L$ be fields with $L$ an $F$-algebra, and let $A, B \in F[X]$. Assume $A \neq 0$, that
+the image $A^{L}$ of $A$ under the coefficient map $F \to L$ splits over $L$ (`Polynomial.Splits`
+for a polynomial over a field, i.e. $A^{L}$ factors into linear factors in $L[X]$), and that the
+multiset of roots of $A^{L}$ has no repetitions, so that $A^{L}$ has only simple roots. Let $x \in
+L$ satisfy $A(x) = 0$ and $B(x) = 0$, where the evaluation is via the structure map $F \to L$, and
+suppose $x$ is the only common zero: every $y \in L$ with $A(y) = 0$ and $B(y) = 0$ equals $x$. Then
+$x$ lies in the range of `algebraMap F L`, i.e. $x$ is the image of an element of $F$. Note that $B$
+is not assumed nonzero and no separability or normality hypothesis is imposed on the extension $L/F$
+beyond the splitting and simplicity of the roots of $A$.
+
+This is a descent criterion for a point of $L$ to be $F$-rational, obtained by looking at the
+greatest common divisor of $A$ and $B$ in $F[X]$, whose reduction over $L$ must be linear. It is
+used in the treatment of modular curves, for instance by
+[`ModularCurve.full_eq_adjoin_primes`](thm.html#ModularCurve.full_eq_adjoin_primes) and
+[`ModularCurve.full_sq_eq_adjoin`](thm.html#ModularCurve.full_sq_eq_adjoin), to show that certain
+coordinates cut out by a pair of polynomial relations already lie in the base field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Polynomial_mem_range_of_unique_common_root.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_Polynomial_mem_range_of_unique_common_root
+
+p2m_open "Polynomial P2MW.S_Polynomial_mem_range_of_unique_common_root.Polynomial"
+
+namespace Polynomial
+p2m_export "Polynomial" "C Splits.of_dvd card_roots' coeff_map natDegree_mul coeff unique aeval \
+  coeff_C_zero Splits.of_natDegree_eq_one degree factor IsRoot.def map_map Splits map mem_roots \
+  eq_zero_of_natDegree_lt_card_of_eval_eq_zero' Monic comp roots natDegree_eq_card_roots \
+  roots.le_of_dvd natDegree eval_C natDegree_sub_le eval_sub natDegree_map map_dvd natDegree_C mod \
+  eval_map_algebraMap ext roots_map IsRoot ring roots_mul"
+end Polynomial
+p2m_open_scoped "Polynomial" in
+private theorem Polynomial.mem_range_of_unique_common_root {F L : Type*} [Field F] [Field L]
+    [Algebra F L]
+    (A B : Polynomial F) (hA : A ≠ 0) (hAs : (A.map (algebraMap F L)).Splits)
+    (hAnd : (A.map (algebraMap F L)).roots.Nodup) (x : L) (hxA : Polynomial.aeval x A = 0)
+    (hxB : Polynomial.aeval x B = 0)
+    (huniq : ∀ y : L, Polynomial.aeval y A = 0 → Polynomial.aeval y B = 0 → y = x) :
+    x ∈ (algebraMap F L).range := by
+  classical
+  set i := algebraMap F L with hi
+  set g := EuclideanDomain.gcd A B with hg
+  have hg0 : g ≠ 0 := fun h => hA (EuclideanDomain.gcd_eq_zero_iff.mp h).1
+  have hgA : g ∣ A := EuclideanDomain.gcd_dvd_left _ _
+  have hgB : g ∣ B := EuclideanDomain.gcd_dvd_right _ _
+  have hAm0 : A.map i ≠ 0 := (Polynomial.map_ne_zero_iff i.injective).mpr hA
+  have hgm0 : g.map i ≠ 0 := (Polynomial.map_ne_zero_iff i.injective).mpr hg0
+  have hxg : Polynomial.aeval x g = 0 := by
+    rw [hg, EuclideanDomain.gcd_eq_gcd_ab A B, map_add, map_mul, map_mul, hxA, hxB, zero_mul,
+      zero_mul,
+      add_zero]
+  have hroot_eq : ∀ y ∈ (g.map i).roots, y = x := by
+    intro y hy
+    rw [Polynomial.mem_roots hgm0, Polynomial.IsRoot.def, Polynomial.eval_map_algebraMap] at hy
+    refine huniq y ?_ ?_
+    · obtain ⟨c, hc⟩ := hgA
+      rw [hc, map_mul, hy, zero_mul]
+    · obtain ⟨c, hc⟩ := hgB
+      rw [hc, map_mul, hy, zero_mul]
+  have hxmem : x ∈ (g.map i).roots := by
+    rw [Polynomial.mem_roots hgm0, Polynomial.IsRoot.def, Polynomial.eval_map_algebraMap]; exact hxg
+  have hle : (g.map i).roots ≤ (A.map i).roots :=
+    Polynomial.roots.le_of_dvd hAm0 (Polynomial.map_dvd i hgA)
+  have hnd : (g.map i).roots.Nodup := Multiset.nodup_of_le hle hAnd
+  have hcount : (g.map i).roots.count x = Multiset.card (g.map i).roots :=
+    Multiset.count_eq_card.mpr fun y hy => (hroot_eq y hy).symm
+  have hcard : Multiset.card (g.map i).roots = 1 := by
+    have h1 : (g.map i).roots.count x ≤ 1 := Multiset.nodup_iff_count_le_one.mp hnd x
+    have h2 : 0 < (g.map i).roots.count x := Multiset.count_pos.mpr hxmem
+    omega
+  have hgs : (g.map i).Splits := Polynomial.Splits.of_dvd hAs hAm0 (Polynomial.map_dvd i hgA)
+  have hdeg : g.natDegree = 1 := by
+    rw [← Polynomial.natDegree_map i, hgs.natDegree_eq_card_roots, hcard]
+  have hgsF : g.Splits := Polynomial.Splits.of_natDegree_eq_one hdeg
+  exact hgsF.mem_range_of_isRoot hg0 ((Polynomial.mem_roots hgm0).mp hxmem)
+
+p2m_open_scoped "Polynomial" in
+private theorem Polynomial.mem_range_of_eval_eq_const {F L : Type*} [Field F] [Field L]
+    [Algebra F L]
+    (g : Polynomial F) (x : L) (s : Finset L) (hcard : g.natDegree < s.card)
+    (hval : ∀ y ∈ s, Polynomial.aeval y g = x) : x ∈ (algebraMap F L).range := by
+  classical
+  set i := algebraMap F L
+  set Q : Polynomial L := g.map i - Polynomial.C x with hQ
+  have hQdeg : Q.natDegree ≤ g.natDegree := by
+    refine (Polynomial.natDegree_sub_le _ _).trans ?_
+    rw [Polynomial.natDegree_map, Polynomial.natDegree_C, max_eq_left (Nat.zero_le _)]
+  have hQ0 : Q = 0 := by
+    refine Polynomial.eq_zero_of_natDegree_lt_card_of_eval_eq_zero' Q s (fun y hy => ?_)
+      (hQdeg.trans_lt hcard)
+    rw [hQ, Polynomial.eval_sub, Polynomial.eval_C, Polynomial.eval_map_algebraMap, hval y hy,
+      sub_self]
+  have hconst : g.map i = Polynomial.C x := sub_eq_zero.mp hQ0
+  refine ⟨g.coeff 0, ?_⟩
+  have := congrArg (fun P : Polynomial L => P.coeff 0) hconst
+  simpa only [Polynomial.coeff_map, Polynomial.coeff_C_zero] using this
+
+p2m_open_scoped "Polynomial" in
+private theorem Polynomial.irreducible_of_transitive_ringAut {F L : Type*} [Field F] [Field L]
+    [Algebra F L]
+    (P : Polynomial F) (hP : P.Monic) (hPs : (P.map (algebraMap F L)).Splits) (σ : L ≃+* L)
+    (hσ : ∀ a : F, σ (algebraMap F L a) = algebraMap F L a) (y₀ : L) (r : ℕ → L) (n : ℕ)
+    (hroots : (P.map (algebraMap F L)).roots = y₀ ::ₘ (Multiset.range n).map r)
+    (hnodup : (P.map (algebraMap F L)).roots.Nodup) (hcycle : ∀ i < n, σ (r i) = r ((i + 1) % n))
+    (hy₀ : y₀ ∉ (algebraMap F L).range) : Irreducible P := by
+  classical
+  set i := algebraMap F L with hi
+  have hσi : (σ : L →+* L).comp i = i := RingHom.ext fun a => hσ a
+  have hPm0 : P.map i ≠ 0 := (Polynomial.map_ne_zero_iff i.injective).mpr hP.ne_zero
+  have hPdeg : P.natDegree = n + 1 := by
+    rw [← Polynomial.natDegree_map i, hPs.natDegree_eq_card_roots, hroots, Multiset.card_cons,
+      Multiset.card_map,
+      Multiset.card_range]
+  have hy₀_notin : y₀ ∉ (Multiset.range n).map r := by
+    rw [hroots] at hnodup; exact (Multiset.nodup_cons.mp hnodup).1
+  have hr_nodup : ((Multiset.range n).map r).Nodup := by
+    rw [hroots] at hnodup; exact (Multiset.nodup_cons.mp hnodup).2
+  have key : ∀ f g : Polynomial F, f.Monic → g.Monic → f * g = P → y₀ ∈ (f.map i).roots →
+    g.natDegree = 0 :=
+    by
+    intro f g hf hg hfg hyf
+    have hfm0 : f.map i ≠ 0 := (Polynomial.map_ne_zero_iff i.injective).mpr hf.ne_zero
+    have hgm0 : g.map i ≠ 0 := (Polynomial.map_ne_zero_iff i.injective).mpr hg.ne_zero
+    have hsplit : (P.map i).roots = (f.map i).roots + (g.map i).roots := by
+      rw [← hfg, Polynomial.map_mul, Polynomial.roots_mul (mul_ne_zero hfm0 hgm0)]
+    have hgle : (g.map i).roots ≤ (P.map i).roots := by rw [hsplit]; exact Multiset.le_add_left _ _
+    have hg_nd : (g.map i).roots.Nodup := Multiset.nodup_of_le hgle hnodup
+    have hy₀g : y₀ ∉ (g.map i).roots := by
+      intro hyg
+      have h2 : 2 ≤ (P.map i).roots.count y₀ := by
+        rw [hsplit, Multiset.count_add]
+        have := Multiset.count_pos.mpr hyf; have := Multiset.count_pos.mpr hyg; omega
+      have h1 := Multiset.nodup_iff_count_le_one.mp hnodup y₀
+      omega
+    have hgsub : ∀ y ∈ (g.map i).roots, y ∈ (Multiset.range n).map r := by
+      intro y hy
+      have : y ∈ (P.map i).roots := Multiset.mem_of_le hgle hy
+      rw [hroots, Multiset.mem_cons] at this
+      rcases this with rfl | h
+      · exact absurd hy hy₀g
+      · exact h
+    have hgs : (g.map i).Splits :=
+      Polynomial.Splits.of_dvd hPs hPm0 (by rw [← hfg, Polynomial.map_mul]; exact dvd_mul_left _ _)
+    have hstable : ((g.map i).roots).map (σ : L →+* L) = (g.map i).roots := by
+      rw [← hgs.roots_map (σ : L →+* L), Polynomial.map_map, hσi]
+    have hmemσ : ∀ y ∈ (g.map i).roots, σ y ∈ (g.map i).roots := by
+      intro y hy
+      rw [← hstable]; exact Multiset.mem_map.mpr ⟨y, hy, rfl⟩
+    by_contra hgdeg
+    have hgroots_ne : (g.map i).roots ≠ 0 := by
+      intro h0
+      apply hgdeg
+      rw [← Polynomial.natDegree_map i, hgs.natDegree_eq_card_roots, h0, Multiset.card_zero]
+    obtain ⟨y, hy⟩ := Multiset.exists_mem_of_ne_zero hgroots_ne
+    obtain ⟨j₀, hj₀, rfl⟩ := Multiset.mem_map.mp (hgsub y hy)
+    rw [Multiset.mem_range] at hj₀
+    have hnpos : 0 < n := lt_of_le_of_lt (Nat.zero_le _) hj₀
+    have horbit : ∀ k : ℕ, r ((j₀ + k) % n) ∈ (g.map i).roots := by
+      intro k
+      induction k with
+      | zero => rwa [add_zero, Nat.mod_eq_of_lt hj₀]
+      | succ k ih =>
+        have h1 := hmemσ _ ih
+        rw [hcycle _ (Nat.mod_lt _ hnpos), Nat.mod_add_mod, add_assoc] at h1
+        exact h1
+    have hall : ∀ j < n, r j ∈ (g.map i).roots := by
+      intro j hj
+      have := horbit (j + n - j₀)
+      have e : (j₀ + (j + n - j₀)) % n = j := by
+        rw [show j₀ + (j + n - j₀) = j + n by omega, Nat.add_mod_right, Nat.mod_eq_of_lt hj]
+      rwa [e] at this
+    have hle : (Multiset.range n).map r ≤ (g.map i).roots := by
+      rw [Multiset.le_iff_subset hr_nodup]
+      intro y hy
+      obtain ⟨j, hj, rfl⟩ := Multiset.mem_map.mp hy
+      exact hall j (Multiset.mem_range.mp hj)
+    have hgdeg_ge : n ≤ g.natDegree := by
+      rw [← Polynomial.natDegree_map i, hgs.natDegree_eq_card_roots]
+      simpa using Multiset.card_le_card hle
+    have hsum : f.natDegree + g.natDegree = n + 1 := by rw [← hf.natDegree_mul hg, hfg, hPdeg]
+    have hfdeg_pos : 1 ≤ f.natDegree := by
+      rw [← Polynomial.natDegree_map i]
+      have := Polynomial.card_roots' (f.map i)
+      have hpos : 0 < Multiset.card (f.map i).roots :=
+        Multiset.card_pos_iff_exists_mem.mpr ⟨y₀, hyf⟩
+      omega
+    have hfdeg : f.natDegree = 1 := by omega
+    have hfs : f.Splits := Polynomial.Splits.of_natDegree_eq_one hfdeg
+    exact hy₀ (hfs.mem_range_of_isRoot hf.ne_zero ((Polynomial.mem_roots hfm0).mp hyf))
+  rw [hP.irreducible_iff_natDegree]
+  refine ⟨fun h1 => by simp [h1] at hPdeg, fun f g hf hg hfg => ?_⟩
+  have hfm0 : f.map i ≠ 0 := (Polynomial.map_ne_zero_iff i.injective).mpr hf.ne_zero
+  have hgm0 : g.map i ≠ 0 := (Polynomial.map_ne_zero_iff i.injective).mpr hg.ne_zero
+  have hy₀P : y₀ ∈ (P.map i).roots := by rw [hroots]; exact Multiset.mem_cons_self _ _
+  rw [← hfg, Polynomial.map_mul, Polynomial.roots_mul (mul_ne_zero hfm0 hgm0),
+    Multiset.mem_add] at hy₀P
+  rcases hy₀P with h | h
+  · exact Or.inr (key f g hf hg hfg h)
+  · exact Or.inl (key g f hg hf (by rw [mul_comm]; exact hfg) h)
+
+theorem solution {F L : Type*} [Field F] [Field L] [Algebra F L] (A B : Polynomial F) (hA : A ≠ 0)
+    (hAs : (A.map (algebraMap F L)).Splits) (hAnd : (A.map (algebraMap F L)).roots.Nodup) (x : L)
+    (hxA : Polynomial.aeval x A = 0) (hxB : Polynomial.aeval x B = 0)
+    (huniq : ∀ y : L, Polynomial.aeval y A = 0 → Polynomial.aeval y B = 0 → y = x) :
+    x ∈ (algebraMap F L).range :=
+  Polynomial.mem_range_of_unique_common_root A B hA hAs hAnd x hxA hxB huniq
+
+end S_Polynomial_mem_range_of_unique_common_root
+end P2MW
+export P2MW.S_Polynomial_mem_range_of_unique_common_root (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem Polynomial.mem_range_of_unique_common_root {F L : Type*} [Field F] [Field L] [Algebra F L]
+    (A B : Polynomial F) (hA : A ≠ 0) (hAs : (A.map (algebraMap F L)).Splits)
+    (hAnd : (A.map (algebraMap F L)).roots.Nodup) (x : L) (hxA : Polynomial.aeval x A = 0)
+    (hxB : Polynomial.aeval x B = 0)
+    (huniq : ∀ y : L, Polynomial.aeval y A = 0 → Polynomial.aeval y B = 0 → y = x) :
+    x ∈ (algebraMap F L).range :=
+  solution A B hA hAs hAnd x hxA hxB huniq
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_PowerSeries_mem_range_map_of_monic_of_mul_mem_range.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_PowerSeries_mem_range_map_of_monic_of_mul_mem_range.lean
new file mode 100644
index 0000000000..3678bc224d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_PowerSeries_mem_range_map_of_monic_of_mul_mem_range.lean
@@ -0,0 +1,143 @@
+/-
+Based on Prove2Me node PowerSeries.mem_range_map_of_monic_of_mul_mem_range
+(77b18431-9004-5889-81a8-ffc299d3cb96) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2b94f26a-1dad-55ad-90cd-9806de208d35
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.Localization.FractionRing
+public import Mathlib.RingTheory.PowerSeries.Basic
+
+import Mathlib.FieldTheory.PurelyInseparable.Basic
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.PowerSeries.Ideal
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality plus a denominator forces descent of power series
+
+Theorem statement: `PowerSeries.mem_range_map_of_monic_of_mul_mem_range`
+(`77b18431-9004-5889-81a8-ffc299d3cb96`), by Claude, 2026-09-05.
+
+Proof: submission `2b94f26a-1dad-55ad-90cd-9806de208d35`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative domain that is a principal ideal ring, let $K$ be a field with an
+$R$-algebra structure making $K$ the fraction field of $R$, and write $\iota =$ `PowerSeries.map
+(algebraMap R K)` for the coefficientwise ring homomorphism $R[[X]] \to K[[X]]$. Let $g \in K[[X]]$,
+and let $\Phi$ be a monic polynomial in one variable with coefficients in $R[[X]]$ such that $g$ is
+a root of the polynomial obtained from $\Phi$ by applying $\iota$ to its coefficients, i.e.
+$\mathrm{eval}_2(\iota, g, \Phi) = 0$ in $K[[X]]$. Suppose further that there is a power series $h
+\in R[[X]]$ with $h \neq 0$ such that the product $\iota(h) \cdot g$ lies in the image of $\iota$,
+that is, $\iota(h)\,g = \iota(u)$ for some $u \in R[[X]]$. Then $g$ itself lies in the image of
+$\iota$: there is $p \in R[[X]]$ with $\iota(p) = g$. In other words, a power series over $K$ which
+is integral over $R[[X]]$ and admits a nonzero denominator in $R[[X]]$ has all its coefficients in
+$R$.
+
+This is the descent step used to convert bounded denominators for an auxiliary multiple of a
+$q$-expansion into integrality of the $q$-expansion itself; it rests on the normality of $R[[X]]$
+for $R$ a principal ideal domain. It is applied with $R = \mathbb{Z}$ in
+[`ModularCurve.exists_ne_zero_forall_intCast_mul_qExpansion_coeff_of_gamma_invariant`]
+(thm.html#ModularCurve.exists_ne_zero_forall_intCast_mul_qExpansion_coeff_of_gamma_invariant).
+The hypothesis on $h$ cannot be omitted: $\sqrt{4+X} \in \mathbb{Q}[[X]]$ is integral over
+$\mathbb{Z}[[X]]$ but has unbounded denominators.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_PowerSeries_mem_range_map_of_monic_of_mul_mem_range.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_PowerSeries_mem_range_map_of_monic_of_mul_mem_range
+
+namespace PowerSeriesNormalityPID
+
+open Polynomial
+
+variable {R K : Type*} [CommRing R] [IsDomain R] [IsPrincipalIdealRing R] [Field K] [Algebra R K]
+  [IsFractionRing R K]
+
+omit [IsDomain R] [IsPrincipalIdealRing R] in
+theorem map_injective : Function.Injective (PowerSeries.map (algebraMap R K)) := by
+  intro a b h
+  ext n
+  apply IsFractionRing.injective R K
+  have := congrArg (PowerSeries.coeff n) h
+  simpa only [PowerSeries.coeff_map] using this
+
+theorem main (g : PowerSeries K) (Φ : Polynomial (PowerSeries R)) (hΦ : Φ.Monic)
+    (hroot : Polynomial.eval₂ (PowerSeries.map (algebraMap R K)) g Φ = 0)
+    (h : PowerSeries R) (h0 : h ≠ 0)
+    (hmul : PowerSeries.map (algebraMap R K) h * g ∈ (PowerSeries.map (algebraMap R K)).range) :
+    g ∈ (PowerSeries.map (algebraMap R K)).range := by
+  classical
+  set ι : PowerSeries R →+* PowerSeries K := PowerSeries.map (algebraMap R K) with hι
+  let F := FractionRing (PowerSeries R)
+  let F' := FractionRing (PowerSeries K)
+  let alg' : PowerSeries K →+* F' := algebraMap (PowerSeries K) F'
+  have hι_inj : Function.Injective ι := map_injective
+  have halg'_inj : Function.Injective alg' := IsFractionRing.injective (PowerSeries K) F'
+  have hcomp_inj : Function.Injective (alg'.comp ι) := halg'_inj.comp hι_inj
+  let θ : F →+* F' := IsFractionRing.lift (A := PowerSeries R) (K := F) (g := alg'.comp ι) hcomp_inj
+  have hθ_alg : ∀ a : PowerSeries R, θ (algebraMap (PowerSeries R) F a) = alg' (ι a) := fun a =>
+    IsFractionRing.lift_algebraMap hcomp_inj a
+  have hθ_comp : θ.comp (algebraMap (PowerSeries R) F) = alg'.comp ι := RingHom.ext hθ_alg
+  have hθ_inj : Function.Injective θ := θ.injective
+  obtain ⟨u, hu⟩ := hmul
+  set x : F := algebraMap (PowerSeries R) F u / algebraMap (PowerSeries R) F h with hx
+  have hιh : ι h ≠ 0 := fun h' => h0 (hι_inj (by rw [h', map_zero]))
+  have halg'h : alg' (ι h) ≠ 0 := fun h' => hιh (halg'_inj (by rw [h', map_zero]))
+  have hθx : θ x = alg' g := by
+    rw [hx, map_div₀, hθ_alg, hθ_alg, div_eq_iff halg'h, ← map_mul, mul_comm, ← hu]
+  have hint : IsIntegral (PowerSeries R) x := by
+    refine ⟨Φ, hΦ, ?_⟩
+    apply hθ_inj
+    rw [Polynomial.hom_eval₂, hθ_comp, hθx, map_zero, ← Polynomial.hom_eval₂, hroot, map_zero]
+  obtain ⟨p, hp⟩ := IsIntegrallyClosed.algebraMap_eq_of_integral hint
+  refine ⟨p, halg'_inj ?_⟩
+  change alg' (ι p) = alg' g
+  rw [← hθ_alg, hp, hθx]
+
+end PowerSeriesNormalityPID
+
+theorem solution
+    {R K : Type*} [CommRing R] [IsDomain R] [IsPrincipalIdealRing R] [Field K] [Algebra R K]
+    [IsFractionRing R K] (g : PowerSeries K) (Φ : Polynomial (PowerSeries R)) (hΦ : Φ.Monic)
+    (hroot : Polynomial.eval₂ (PowerSeries.map (algebraMap R K)) g Φ = 0)
+    (h : PowerSeries R) (h0 : h ≠ 0)
+    (hmul : PowerSeries.map (algebraMap R K) h * g ∈ (PowerSeries.map (algebraMap R K)).range) :
+    g ∈ (PowerSeries.map (algebraMap R K)).range :=
+  PowerSeriesNormalityPID.main g Φ hΦ hroot h h0 hmul
+
+end S_PowerSeries_mem_range_map_of_monic_of_mul_mem_range
+end P2MW
+export P2MW.S_PowerSeries_mem_range_map_of_monic_of_mul_mem_range (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem PowerSeries.mem_range_map_of_monic_of_mul_mem_range
+    {R K : Type*} [CommRing R] [IsDomain R] [IsPrincipalIdealRing R] [Field K] [Algebra R K]
+    [IsFractionRing R K] (g : PowerSeries K) (Φ : Polynomial (PowerSeries R)) (hΦ : Φ.Monic)
+    (hroot : Polynomial.eval₂ (PowerSeries.map (algebraMap R K)) g Φ = 0)
+    (h : PowerSeries R) (h0 : h ≠ 0)
+    (hmul : PowerSeries.map (algebraMap R K) h * g ∈ (PowerSeries.map (algebraMap R K)).range) :
+    g ∈ (PowerSeries.map (algebraMap R K)).range :=
+  solution g Φ hΦ hroot h h0 hmul
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Rep_finiteDimensional_coind_and_finrank_coind_eq_index_mul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Rep_finiteDimensional_coind_and_finrank_coind_eq_index_mul.lean
new file mode 100644
index 0000000000..31115773a4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Rep_finiteDimensional_coind_and_finrank_coind_eq_index_mul.lean
@@ -0,0 +1,156 @@
+/-
+Based on Prove2Me node Rep.finiteDimensional_coind_and_finrank_coind_eq_index_mul
+(e8c7e524-83e3-5eb1-8320-90e917319796) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 35d27f01-8cea-5f80-863f-61155e2b07bf
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.GroupTheory.Index
+public import Mathlib.RepresentationTheory.Coinduced
+
+import Mathlib.LinearAlgebra.FreeModule.PID
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finite-dimensionality and dimension of a coinduced representation
+
+Theorem statement: `Rep.finiteDimensional_coind_and_finrank_coind_eq_index_mul`
+(`e8c7e524-83e3-5eb1-8320-90e917319796`), by Claude, 2026-09-05.
+
+Proof: submission `35d27f01-8cea-5f80-863f-61155e2b07bf`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $k$ be a field and $G$ a group (both in the same universe), let $S \le G$ be a subgroup of
+finite index, i.e. carrying a `Subgroup.FiniteIndex` instance, and let $N$ be a $k$-linear
+representation of $S$ whose underlying $k$-vector space is finite-dimensional. Consider the
+representation of $G$ coinduced along the inclusion `S.subtype : S →* G`, namely `Rep.coind
+S.subtype N`, whose underlying space is the space of functions $f \colon G \to N$ satisfying $f(sg)
+= \rho_N(s)\,f(g)$ for all $s \in S$ and $g \in G$, with $k$-linear structure computed pointwise.
+The theorem asserts the conjunction of two facts: this coinduced representation is
+finite-dimensional over $k$, and its $k$-dimension is given by $$\dim_k \operatorname{coind}_{S}^{G}
+N = [G : S] \cdot \dim_k N,$$ where $[G:S]$ is `Subgroup.index`, the cardinality of the left coset
+space $G ⧸ S$. Both assertions are statements about the underlying $k$-vector space only; no
+compatibility with the $G$-action beyond the defining equivariance condition enters the conclusion.
+
+This is the dimension count underlying Shapiro-type comparisons between the cohomology of $G$ on a
+coinduced module and that of the finite-index subgroup $S$ on $N$. It is used by
+[`Rep.exists_shortExact_coind_res`](thm.html#Rep.exists_shortExact_coind_res) and, through it, in
+[`groupCohomology.euler_poincare_identity_of_hypotheses`]
+(thm.html#groupCohomology.euler_poincare_identity_of_hypotheses),
+where the multiplicativity of dimensions by the index supplies the numerical input to the
+Euler–Poincaré argument.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Rep_finiteDimensional_coind_and_finrank_coind_eq_index_mul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_Rep_finiteDimensional_coind_and_finrank_coind_eq_index_mul
+
+universe u
+
+open CategoryTheory
+
+theorem solution {k G : Type u} [Field k] [Group G] (S : Subgroup G) [S.FiniteIndex]
+    (N : Rep.{u} k S) [FiniteDimensional k N] :
+    FiniteDimensional k (Rep.coind S.subtype N) ∧
+      Module.finrank k (Rep.coind S.subtype N) = S.index * Module.finrank k N := by
+  classical
+  let Q := Quotient (QuotientGroup.rightRel S)
+  have : Finite Q := Finite.of_equiv _ (QuotientGroup.quotientRightRelEquivQuotientLeftRel S).symm
+  let : Fintype Q := Fintype.ofFinite Q
+  let rep : G → G := fun g => (Quotient.mk (QuotientGroup.rightRel S) g).out
+  have rep_spec : ∀ g : G, g * (rep g)⁻¹ ∈ S := fun g =>
+    QuotientGroup.rightRel_apply.1 (Quotient.mk_out (s := QuotientGroup.rightRel S) g)
+  have rep_mul : ∀ (s : S) (g : G), rep ((s : G) * g) = rep g := fun s g => by
+    change (Quotient.mk _ ((s : G) * g)).out = (Quotient.mk _ g).out
+    congr 1
+    apply Quotient.sound
+    change @Setoid.r _ (QuotientGroup.rightRel S) ((s : G) * g) g
+    rw [QuotientGroup.rightRel_apply]
+    simp
+  have key : ∀ (a : G) (ha : a ∈ S) (v : N), a = 1 → N.ρ ⟨a, ha⟩ v = v := by
+    rintro a ha v rfl
+    exact congrFun (congrArg DFunLike.coe (map_one N.ρ)) v
+  let e : Rep.coind S.subtype N ≃ₗ[k] (Q → N) :=
+    { toFun := fun f q => (f : G → N) q.out
+      map_add' := fun _ _ => rfl
+      map_smul' := fun _ _ => rfl
+      invFun := fun F => ⟨fun g => N.ρ ⟨g * (rep g)⁻¹, rep_spec g⟩ (F (Quotient.mk _ g)), fun s h =>
+        by
+        simp only [Subgroup.coe_subtype]
+        have hq : (Quotient.mk (QuotientGroup.rightRel S) ((s : G) * h)) = Quotient.mk _ h :=
+          Quotient.sound (by
+            change @Setoid.r _ (QuotientGroup.rightRel S) ((s : G) * h) h
+            rw [QuotientGroup.rightRel_apply]; simp)
+        rw [← Module.End.mul_apply, ← map_mul]
+        have hmem : (s : G) * h * (rep ((s : G) * h))⁻¹ ∈ S := rep_spec _
+        have : (⟨(s : G) * h * (rep ((s : G) * h))⁻¹, hmem⟩ : S) = s * ⟨h * (rep h)⁻¹, rep_spec h⟩
+          :=
+          by
+          apply Subtype.ext
+          simp only [Subgroup.coe_mul, rep_mul, mul_assoc]
+        rw [show (⟨(s : G) * h * (rep ((s : G) * h))⁻¹, rep_spec _⟩ : S) = s * ⟨h * (rep h)⁻¹,
+          rep_spec h⟩ from this,
+          hq]⟩
+      left_inv := fun f => by
+        apply Subtype.ext
+        funext g
+        change N.ρ ⟨g * (rep g)⁻¹, rep_spec g⟩ ((f : G → N) (Quotient.mk (QuotientGroup.rightRel S)
+          g).out) = (f : G → N) g
+        have := f.2 ⟨g * (rep g)⁻¹, rep_spec g⟩ (rep g)
+        rw [← this]
+        change (f : G → N) (g * (rep g)⁻¹ * rep g) = (f : G → N) g
+        rw [inv_mul_cancel_right]
+      right_inv := fun F => by
+        funext q
+        change N.ρ ⟨q.out * (rep q.out)⁻¹, rep_spec q.out⟩ (F (Quotient.mk _ q.out)) = F q
+        have hout : Quotient.mk (QuotientGroup.rightRel S) q.out = q := Quotient.out_eq q
+        rw [hout]
+        exact key _ _ _ (by
+          change q.out * ((Quotient.mk (QuotientGroup.rightRel S) q.out).out)⁻¹ = 1; rw [hout,
+            mul_inv_cancel]) }
+  have : FiniteDimensional k (Rep.coind S.subtype N) := LinearEquiv.finiteDimensional e.symm
+  refine ⟨inferInstance, ?_⟩
+  rw [LinearEquiv.finrank_eq e, Module.finrank_pi_fintype, Finset.sum_const, Finset.card_univ,
+    smul_eq_mul,
+    Subgroup.index, ← Nat.card_eq_fintype_card,
+    Nat.card_congr (QuotientGroup.quotientRightRelEquivQuotientLeftRel S)]
+
+end S_Rep_finiteDimensional_coind_and_finrank_coind_eq_index_mul
+end P2MW
+export P2MW.S_Rep_finiteDimensional_coind_and_finrank_coind_eq_index_mul (solution)
+
+end privateSection
+
+public section publicSection
+
+
+universe u
+
+open CategoryTheory
+theorem Rep.finiteDimensional_coind_and_finrank_coind_eq_index_mul {k G : Type u} [Field k]
+    [Group G] (S : Subgroup G) [S.FiniteIndex]
+    (N : Rep.{u} k S) [FiniteDimensional k N] :
+    FiniteDimensional k (Rep.coind S.subtype N) ∧
+      Module.finrank k (Rep.coind S.subtype N) = S.index * Module.finrank k N :=
+  solution S N
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_SimpleGraph_exists_walkConnected_transversal_of_preconnected.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_SimpleGraph_exists_walkConnected_transversal_of_preconnected.lean
new file mode 100644
index 0000000000..ed80f096c0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_SimpleGraph_exists_walkConnected_transversal_of_preconnected.lean
@@ -0,0 +1,224 @@
+/-
+Based on Prove2Me node SimpleGraph.exists_walkConnected_transversal_of_preconnected
+(3a345bde-711e-5ffe-854b-2b82dd8748d2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b2d210d0-04be-52d5-97fb-e9ec06a3ce91
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Combinatorics.SimpleGraph.Connectivity.Connected
+public import Mathlib.GroupTheory.GroupAction.Defs
+
+import Mathlib.Order.CompletePartialOrder
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Walk-connected orbit transversal in a preconnected graph
+
+Theorem statement: `SimpleGraph.exists_walkConnected_transversal_of_preconnected`
+(`3a345bde-711e-5ffe-854b-2b82dd8748d2`), by Claude, 2026-09-05.
+
+Proof: submission `b2d210d0-04be-52d5-97fb-e9ec06a3ce91`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $V$ be a type carrying a simple graph $T$, and let $\Gamma$ be a group acting on $V$. Assume
+that the action preserves adjacency: for every $\gamma \in \Gamma$ and all $v, w \in V$, if $v$ and
+$w$ are adjacent in $T$ then so are $\gamma \cdot v$ and $\gamma \cdot w$. Assume further that $T$
+is preconnected, i.e. any two vertices are joined by a walk, and fix a base vertex $v_0 \in V$. The
+conclusion is the existence of a set $D \subseteq V$ with the following four properties: $v_0 \in
+D$; for all $v, w \in D$ there is a walk $p$ in $T$ from $v$ to $w$ all of whose support lies in
+$D$; for all $v, w \in D$, if $v$ lies in the $\Gamma$-orbit of $w$ then $v = w$; and for every $u
+\in V$ there is some $v \in D$ lying in the $\Gamma$-orbit of $u$. Thus $D$ is walk-connected inside
+$T$, contains $v_0$, and meets every $\Gamma$-orbit in exactly one point. No finiteness, freeness or
+stabiliser hypothesis is imposed.
+
+This is the vertex-set form of Serre's tree of representatives (fundamental domain) for a group
+acting on a connected graph, as in §I.3 of Serre's Trees. It is used in the present development in
+the treatment of free products, supporting the Kurosh/Nielsen–Schreier style statements
+[`Monoid.CoprodI.nonempty_freeGroupBasis_fin_kuroshRank`]
+(thm.html#Monoid.CoprodI.nonempty_freeGroupBasis_fin_kuroshRank)
+and
+[`Monoid.CoprodI.finrank_addMonoidHom_add_card_orbitRelQuotient_le_index_add_one`]
+(thm.html#Monoid.CoprodI.finrank_addMonoidHom_add_card_orbitRelQuotient_le_index_add_one).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_SimpleGraph_exists_walkConnected_transversal_of_preconnected.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_SimpleGraph_exists_walkConnected_transversal_of_preconnected
+
+open Subgroup MulAction SimpleGraph Monoid
+
+namespace GroupTheory
+
+namespace GraphTransversal
+
+def WalkConnected {V : Type*} (T : SimpleGraph V) (s : Set V) : Prop :=
+  ∀ v ∈ s, ∀ w ∈ s, ∃ p : T.Walk v w, ∀ x ∈ p.support, x ∈ s
+
+structure IsConnectedTransversal {V : Type*} (T : SimpleGraph V) (Γ : Type*) [Group Γ]
+    [MulAction Γ V] (D : Set V) : Prop where
+  walkConnected : WalkConnected T D
+  eq_of_mem_orbit : ∀ v ∈ D, ∀ w ∈ D, v ∈ orbit Γ w → v = w
+  exists_mem_orbit : ∀ u : V, ∃ v ∈ D, v ∈ orbit Γ u
+
+variable {V : Type*} {T : SimpleGraph V} {Γ : Type*} [Group Γ] [MulAction Γ V]
+
+theorem walkConnected_singleton (T : SimpleGraph V) (v₀ : V) : WalkConnected T {v₀} := by
+  intro v hv w hw
+  rw [Set.mem_singleton_iff] at hv hw
+  subst hv; subst hw
+  exact ⟨Walk.nil, by simp⟩
+
+theorem WalkConnected.insert_of_adj {s : Set V} (hs : WalkConnected T s) {v w : V}
+    (hv : v ∈ s) (hadj : T.Adj v w) : WalkConnected T (insert w s) := by
+  have key : ∀ x ∈ insert w s, ∃ p : T.Walk v x, ∀ y ∈ p.support, y ∈ insert w s := by
+    intro x hx
+    rcases Set.mem_insert_iff.mp hx with rfl | hx
+    · refine ⟨Walk.cons hadj Walk.nil, fun y hy => ?_⟩
+      simp only [Walk.support_cons, Walk.support_nil, List.mem_cons,
+        List.not_mem_nil, or_false] at hy
+      rcases hy with rfl | rfl
+      · exact Set.mem_insert_of_mem _ hv
+      · exact Set.mem_insert _ _
+    · obtain ⟨p, hp⟩ := hs v hv x hx
+      exact ⟨p, fun y hy => Set.mem_insert_of_mem _ (hp y hy)⟩
+  intro a ha b hb
+  obtain ⟨p, hp⟩ := key a ha
+  obtain ⟨q, hq⟩ := key b hb
+  refine ⟨p.reverse.append q, fun y hy => ?_⟩
+  rw [Walk.support_append, List.mem_append] at hy
+  rcases hy with hy | hy
+  · rw [Walk.support_reverse, List.mem_reverse] at hy
+    exact hp y hy
+  · exact hq y (List.mem_of_mem_tail hy)
+
+theorem walkConnected_sUnion {c : Set (Set V)} (hchain : IsChain (· ⊆ ·) c)
+    (hwc : ∀ s ∈ c, WalkConnected T s) : WalkConnected T (⋃₀ c) := by
+  rintro v ⟨s, hs, hvs⟩ w ⟨t, ht, hwt⟩
+  rcases hchain.total hs ht with hst | hts
+  · obtain ⟨p, hp⟩ := hwc t ht v (hst hvs) w hwt
+    exact ⟨p, fun x hx => Set.mem_sUnion.mpr ⟨t, ht, hp x hx⟩⟩
+  · obtain ⟨p, hp⟩ := hwc s hs v hvs w (hts hwt)
+    exact ⟨p, fun x hx => Set.mem_sUnion.mpr ⟨s, hs, hp x hx⟩⟩
+
+private theorem mem_orbit_symm' {a b : V} (h : a ∈ orbit Γ b) : b ∈ orbit Γ a := by
+  obtain ⟨γ, rfl⟩ := h
+  exact ⟨γ⁻¹, inv_smul_smul γ b⟩
+
+theorem eq_of_mem_orbit_sUnion {c : Set (Set V)} (hchain : IsChain (· ⊆ ·) c)
+    (hinj : ∀ s ∈ c, ∀ v ∈ s, ∀ w ∈ s, v ∈ orbit Γ w → v = w) :
+    ∀ v ∈ ⋃₀ c, ∀ w ∈ ⋃₀ c, v ∈ orbit Γ w → v = w := by
+  rintro v ⟨s, hs, hvs⟩ w ⟨t, ht, hwt⟩ hvw
+  rcases hchain.total hs ht with hst | hts
+  · exact hinj t ht v (hst hvs) w hwt hvw
+  · exact hinj s hs v hvs w (hts hwt) hvw
+
+theorem eq_of_mem_orbit_insert {s : Set V}
+    (hs : ∀ v ∈ s, ∀ w ∈ s, v ∈ orbit Γ w → v = w) {w : V}
+    (hw : ¬∃ v ∈ s, v ∈ orbit Γ w) :
+    ∀ v ∈ insert w s, ∀ v' ∈ insert w s, v ∈ orbit Γ v' → v = v' := by
+  intro v hv v' hv' hvv'
+  rcases Set.mem_insert_iff.mp hv with rfl | hvs <;>
+    rcases Set.mem_insert_iff.mp hv' with rfl | hv's
+  · rfl
+  · exact absurd ⟨v', hv's, mem_orbit_symm' hvv'⟩ hw
+  · exact absurd ⟨v, hvs, hvv'⟩ hw
+  · exact hs v hvs v' hv's hvv'
+
+theorem exists_adj_of_walk (hsmul : ∀ (γ : Γ) {v w : V}, T.Adj v w → T.Adj (γ • v) (γ • w))
+    {s : Set V} {a b : V} (p : T.Walk a b) :
+    (∃ v ∈ s, v ∈ orbit Γ a) → (¬∃ v ∈ s, v ∈ orbit Γ b) →
+      ∃ v ∈ s, ∃ w, T.Adj v w ∧ ¬∃ v' ∈ s, v' ∈ orbit Γ w := by
+  induction p with
+  | nil => exact fun ha hb => absurd ha hb
+  | @cons a c b hac p ih =>
+    intro ha hb
+    by_cases hc : ∃ v ∈ s, v ∈ orbit Γ c
+    · exact ih hc hb
+    · obtain ⟨v, hvs, γ, hγ⟩ := ha
+      refine ⟨v, hvs, γ • c, ?_, ?_⟩
+      · rw [← hγ]
+        exact hsmul γ hac
+      · rintro ⟨v', hv's, hv'⟩
+        rw [MulAction.orbit_smul] at hv'
+        exact hc ⟨v', hv's, hv'⟩
+
+theorem exists_isConnectedTransversal
+    (hsmul : ∀ (γ : Γ) {v w : V}, T.Adj v w → T.Adj (γ • v) (γ • w))
+    (hpre : T.Preconnected) (v₀ : V) :
+    ∃ D : Set V, v₀ ∈ D ∧ IsConnectedTransversal T Γ D := by
+  classical
+  obtain ⟨D, hsub, hDmem, hDmax⟩ := zorn_subset_nonempty
+    {s : Set V | v₀ ∈ s ∧ WalkConnected T s ∧ ∀ v ∈ s, ∀ w ∈ s, v ∈ orbit Γ w → v = w}
+    (fun c hc hchain hcne => by
+      obtain ⟨s₀, hs₀⟩ := hcne
+      exact ⟨⋃₀ c, ⟨Set.mem_sUnion.mpr ⟨s₀, hs₀, (hc hs₀).1⟩,
+        walkConnected_sUnion hchain fun s hs => (hc hs).2.1,
+        eq_of_mem_orbit_sUnion hchain fun s hs => (hc hs).2.2⟩,
+        fun s hs => Set.subset_sUnion_of_mem hs⟩)
+    {v₀}
+    ⟨Set.mem_singleton v₀, walkConnected_singleton T v₀, by
+      intro v hv w hw _
+      rw [Set.mem_singleton_iff] at hv hw
+      rw [hv, hw]⟩
+  have hv₀D : v₀ ∈ D := hsub (Set.mem_singleton v₀)
+  refine ⟨D, hv₀D, hDmem.2.1, hDmem.2.2, fun u => ?_⟩
+  by_contra hu
+  obtain ⟨p⟩ := hpre v₀ u
+  obtain ⟨v, hvD, w, hadj, hw⟩ :=
+    exists_adj_of_walk hsmul p ⟨v₀, hv₀D, MulAction.mem_orbit_self v₀⟩ hu
+  have hwD : w ∉ D := fun hwD => hw ⟨w, hwD, MulAction.mem_orbit_self w⟩
+  have hins : insert w D ∈
+      {s : Set V | v₀ ∈ s ∧ WalkConnected T s ∧ ∀ v ∈ s, ∀ w ∈ s, v ∈ orbit Γ w → v = w} :=
+    ⟨Set.mem_insert_of_mem _ hv₀D, hDmem.2.1.insert_of_adj hvD hadj,
+      eq_of_mem_orbit_insert hDmem.2.2 hw⟩
+  exact hwD (hDmax hins (Set.subset_insert w D) (Set.mem_insert w D))
+
+end GraphTransversal
+
+end GroupTheory
+
+theorem solution {V : Type*} {T : SimpleGraph V} {Γ : Type*} [Group Γ] [MulAction Γ V]
+    (hsmul : ∀ (γ : Γ) {v w : V}, T.Adj v w → T.Adj (γ • v) (γ • w))
+    (hpre : T.Preconnected) (v₀ : V) :
+    ∃ D : Set V, v₀ ∈ D ∧
+      (∀ v ∈ D, ∀ w ∈ D, ∃ p : T.Walk v w, ∀ x ∈ p.support, x ∈ D) ∧
+      (∀ v ∈ D, ∀ w ∈ D, v ∈ MulAction.orbit Γ w → v = w) ∧
+      (∀ u : V, ∃ v ∈ D, v ∈ MulAction.orbit Γ u) := by
+  obtain ⟨D, h0, hD⟩ := GroupTheory.GraphTransversal.exists_isConnectedTransversal hsmul hpre v₀
+  exact ⟨D, h0, hD.walkConnected, hD.eq_of_mem_orbit, hD.exists_mem_orbit⟩
+
+end S_SimpleGraph_exists_walkConnected_transversal_of_preconnected
+end P2MW
+export P2MW.S_SimpleGraph_exists_walkConnected_transversal_of_preconnected (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem SimpleGraph.exists_walkConnected_transversal_of_preconnected {V : Type*} {T : SimpleGraph V}
+    {Γ : Type*} [Group Γ] [MulAction Γ V]
+    (hsmul : ∀ (γ : Γ) {v w : V}, T.Adj v w → T.Adj (γ • v) (γ • w))
+    (hpre : T.Preconnected) (v₀ : V) :
+    ∃ D : Set V, v₀ ∈ D ∧
+      (∀ v ∈ D, ∀ w ∈ D, ∃ p : T.Walk v w, ∀ x ∈ p.support, x ∈ D) ∧
+      (∀ v ∈ D, ∀ w ∈ D, v ∈ MulAction.orbit Γ w → v = w) ∧
+      (∀ u : V, ∃ v ∈ D, v ∈ MulAction.orbit Γ u) :=
+  solution hsmul hpre v₀
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Subgroup_IsArithmetic_exists_nat_mem_strictPeriods_conj.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Subgroup_IsArithmetic_exists_nat_mem_strictPeriods_conj.lean
new file mode 100644
index 0000000000..3dc4624f48
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Subgroup_IsArithmetic_exists_nat_mem_strictPeriods_conj.lean
@@ -0,0 +1,108 @@
+/-
+Based on Prove2Me node Subgroup.IsArithmetic.exists_nat_mem_strictPeriods_conj
+(fabaf53f-b200-50fb-9e51-df1019449bf7) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission dac764ca-64e0-5825-b105-2678ecee9162
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.Cusps
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A uniform integer period for all SL₂(ℤ)-conjugates
+
+Theorem statement: `Subgroup.IsArithmetic.exists_nat_mem_strictPeriods_conj`
+(`fabaf53f-b200-50fb-9e51-df1019449bf7`), by Claude, 2026-09-05.
+
+Proof: submission `dac764ca-64e0-5825-b105-2678ecee9162`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\mathcal{G}$ be a subgroup of $\mathrm{GL}_2(\mathbb{R})$ which is arithmetic in the sense of
+Mathlib's class `Subgroup.IsArithmetic`; the feature of that hypothesis used here is that the
+preimage of $\mathcal{G}$ in $\mathrm{SL}_2(\mathbb{Z})$ under the map $\mathrm{SL}_2(\mathbb{Z})
+\to \mathrm{GL}_2(\mathbb{R})$ (`Matrix.SpecialLinearGroup.mapGL`) has finite index. The assertion
+is that there exists a natural number $M$ with $M > 0$ such that for every $\gamma \in
+\mathrm{SL}_2(\mathbb{Z})$ the real number $M$ belongs to the group of strict periods of the
+conjugate subgroup $\mathrm{toConjAct}(\mathrm{mapGL}_{\mathbb{R}}\,\gamma) \cdot \mathcal{G}$, that
+is, of $\gamma\mathcal{G}\gamma^{-1}$ inside $\mathrm{GL}_2(\mathbb{R})$, where $\gamma$ acts
+through its image in $\mathrm{GL}_2(\mathbb{R})$. Since `Subgroup.strictPeriods` consists of those
+$x \in \mathbb{R}$ for which the upper unitriangular matrix $\begin{pmatrix} 1 & x \\ 0 &
+1\end{pmatrix}$ lies in the subgroup, the conclusion says that one single positive integer $M$ has
+$T^M = \begin{pmatrix} 1 & M \\ 0 & 1\end{pmatrix} \in \gamma\mathcal{G}\gamma^{-1}$ simultaneously
+for all $\gamma \in \mathrm{SL}_2(\mathbb{Z})$.
+
+This is the statement that an arithmetic subgroup of $\mathrm{GL}_2(\mathbb{R})$ admits one integer
+width that is a period at every cusp, uniformly over all $\mathrm{SL}_2(\mathbb{Z})$-translates, so
+that the $q$-expansions of all translates $f\mid_k\gamma$ of a modular form can be taken in the same
+variable $q^{1/M}$. It is used in the construction of equivariant primitives on modular curves and
+in the proofs of finite-dimensionality and of a Sturm bound for spaces of modular forms on
+arithmetic groups.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Subgroup_IsArithmetic_exists_nat_mem_strictPeriods_conj.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_Subgroup_IsArithmetic_exists_nat_mem_strictPeriods_conj
+
+open Matrix.SpecialLinearGroup ConjAct
+open scoped MatrixGroups Pointwise
+
+noncomputable section
+
+theorem solution (𝒢 : Subgroup (GL (Fin 2) ℝ)) [𝒢.IsArithmetic] :
+    ∃ M : ℕ, 0 < M ∧ ∀ γ : SL(2, ℤ), (M : ℝ) ∈ (ConjAct.toConjAct (Matrix.SpecialLinearGroup.mapGL ℝ
+      γ) • 𝒢).strictPeriods := by
+  have : (𝒢.comap (mapGL (R := ℤ) ℝ)).FiniteIndex := Subgroup.IsArithmetic.finiteIndex_comap 𝒢
+  set Λ : Subgroup SL(2, ℤ) := (𝒢.comap (mapGL (R := ℤ) ℝ)).normalCore with hΛ
+  have : Λ.FiniteIndex := inferInstance
+  have hN : Λ.Normal := inferInstance
+  refine ⟨Λ.index, Nat.pos_of_ne_zero Subgroup.FiniteIndex.index_ne_zero, fun γ ↦ ?_⟩
+  have hT : ModularGroup.T ^ Λ.index ∈ Λ := Λ.pow_index_mem ModularGroup.T
+  have hconj : γ⁻¹ * ModularGroup.T ^ Λ.index * γ ∈ 𝒢.comap (mapGL ℝ) := by
+    apply Subgroup.normalCore_le
+    simpa using hN.conj_mem _ hT γ⁻¹
+  have hU : ∀ m : ℤ, Matrix.GeneralLinearGroup.upperRightHom ((m : ℝ)) =
+      mapGL ℝ (ModularGroup.T ^ m) := by
+    intro m
+    simp only [Units.ext_iff, mapGL_coe_matrix, map_apply_coe]
+    ext i j
+    fin_cases i <;> fin_cases j <;> simp [ModularGroup.coe_T_zpow]
+  have hU' := hU Λ.index
+  rw [zpow_natCast, Int.cast_natCast] at hU'
+  rw [Subgroup.mem_strictPeriods_iff, Subgroup.mem_pointwise_smul_iff_inv_smul_mem, ← toConjAct_inv,
+    toConjAct_smul, inv_inv, hU', ← map_inv, ← map_mul, ← map_mul]
+  exact hconj
+end
+
+end S_Subgroup_IsArithmetic_exists_nat_mem_strictPeriods_conj
+end P2MW
+export P2MW.S_Subgroup_IsArithmetic_exists_nat_mem_strictPeriods_conj (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped MatrixGroups Pointwise
+theorem Subgroup.IsArithmetic.exists_nat_mem_strictPeriods_conj (𝒢 : Subgroup (GL (Fin 2) ℝ))
+    [𝒢.IsArithmetic] :
+    ∃ M : ℕ, 0 < M ∧ ∀ γ : SL(2, ℤ), (M : ℝ) ∈ (ConjAct.toConjAct (Matrix.SpecialLinearGroup.mapGL ℝ
+      γ) • 𝒢).strictPeriods :=
+  solution 𝒢
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Subgroup_card_orbitRelQuotient_mul_card_eq_index.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Subgroup_card_orbitRelQuotient_mul_card_eq_index.lean
new file mode 100644
index 0000000000..bb68231116
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Subgroup_card_orbitRelQuotient_mul_card_eq_index.lean
@@ -0,0 +1,188 @@
+/-
+Based on Prove2Me node Subgroup.card_orbitRelQuotient_mul_card_eq_index
+(5c45036a-fa78-5e04-9231-abdaa4f44270) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 499349aa-7fe9-5213-80bc-5e6fd1b94016
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.GroupTheory.Index
+
+import Mathlib.Order.CompletePartialOrder
+import Mathlib.Tactic.Group
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Free double-coset count: #(Hbackslash M/K)·|K|=[M:H]
+
+Theorem statement: `Subgroup.card_orbitRelQuotient_mul_card_eq_index`
+(`5c45036a-fa78-5e04-9231-abdaa4f44270`), by Claude, 2026-09-05.
+
+Proof: submission `499349aa-7fe9-5213-80bc-5e6fd1b94016`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $M$ be a group and let $H$ and $K$ be subgroups of $M$. Assume that no nontrivial element of $K$
+is conjugate into $H$: for all $g, x \in M$, if $x \in K$ and $g^{-1} x g \in H$, then $x = 1$. Then
+the product of the number of orbits of $H$ acting by left translation on the left-coset space $M /
+K$ — that is, the cardinality of the quotient of $M/K$ by the orbit relation of the $H$-action,
+which is the double-coset space $H \backslash M / K$ — with the cardinality of $K$ equals the index
+of $H$ in $M$. All three cardinalities are `Nat.card`, so each infinite set contributes the value
+$0$ and the identity holds degenerately when $K$, the double-coset space or $M/H$ is infinite; in
+particular no finiteness hypothesis is imposed on $M$, $H$ or $K$.
+
+This is the elementary double-coset count underlying the Bass–Serre analysis of subgroups of free
+products: a subgroup $H$ meeting no conjugate of a factor $K$ acts on the coset tree with the type
+of $K$-vertices contributing $[M:H]/|K|$ orbits. It is used in the construction of free bases, for
+subgroups of free products of groups
+([`Monoid.CoprodI.nonempty_freeGroupBasis_fin_kuroshRank`]
+(thm.html#Monoid.CoprodI.nonempty_freeGroupBasis_fin_kuroshRank))
+and for subgroups of $\mathrm{SL}_2$ modulo centre generated by elements of prescribed trace
+(`Matrix.SpecialLinearGroup.nonempty_freeGroupBasis_map_quotient_center_of_forall_trace_ne`)
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Subgroup_card_orbitRelQuotient_mul_card_eq_index.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_Subgroup_card_orbitRelQuotient_mul_card_eq_index
+
+open Subgroup MulAction
+
+namespace GroupTheory
+
+namespace FreeDoubleCoset
+
+variable {M : Type*} [Group M]
+
+def ConjTrivial (K H : Subgroup M) : Prop :=
+  ∀ g x : M, x ∈ K → g⁻¹ * x * g ∈ H → x = 1
+
+theorem stabilizer_eq_bot_of_conjTrivial (K H : Subgroup M) (hKH : ConjTrivial K H) (q : M ⧸ H) :
+    MulAction.stabilizer K q = ⊥ := by
+  rw [eq_bot_iff]
+  intro a ha
+  induction q using QuotientGroup.induction_on with
+  | H g =>
+    have hmem : (a : M) • (g : M ⧸ H) = (g : M ⧸ H) := ha
+    rw [MulAction.Quotient.smul_coe, QuotientGroup.eq, smul_eq_mul, mul_inv_rev] at hmem
+    have hinv : (a : M)⁻¹ = 1 := hKH g ((a : M)⁻¹) (inv_mem a.2) hmem
+    have : (a : M) = 1 := by rw [← inv_inv (a : M), hinv, inv_one]
+    exact Subgroup.mem_bot.mpr (Subtype.ext this)
+
+section DoubleCoset
+
+variable (H K : Subgroup M)
+
+theorem mk''_mk_inv_eq {g g' : M} (η : M) (hη : η ∈ H) (hk : g'⁻¹ * η⁻¹ * g ∈ K) :
+    (Quotient.mk'' ((g⁻¹ : M) : M ⧸ H) : orbitRel.Quotient K (M ⧸ H)) =
+      Quotient.mk'' ((g'⁻¹ : M) : M ⧸ H) := by
+  refine Quotient.sound' (mem_orbit_iff.mpr ⟨(⟨g'⁻¹ * η⁻¹ * g, hk⟩ : K)⁻¹, ?_⟩)
+  change (((⟨g'⁻¹ * η⁻¹ * g, hk⟩ : K)⁻¹ : K) : M) • ((g'⁻¹ : M) : M ⧸ H) = ((g⁻¹ : M) : M ⧸ H)
+  rw [MulAction.Quotient.smul_coe, smul_eq_mul, QuotientGroup.eq]
+  change ((((g'⁻¹ * η⁻¹ * g)⁻¹ : M) : M) * g'⁻¹)⁻¹ * g⁻¹ ∈ H
+  have key : (((g'⁻¹ * η⁻¹ * g)⁻¹ : M) * g'⁻¹)⁻¹ * g⁻¹ = η⁻¹ := by group
+  rw [key]
+  exact H.inv_mem hη
+
+def toOrbitAux (x : M ⧸ K) : orbitRel.Quotient K (M ⧸ H) :=
+  Quotient.liftOn' x (fun g => Quotient.mk'' ((g⁻¹ : M) : M ⧸ H)) fun g g' hgg' => by
+    have hk : g'⁻¹ * (1 : M)⁻¹ * g ∈ K := by
+      simpa using K.inv_mem (QuotientGroup.leftRel_apply.mp hgg')
+    exact mk''_mk_inv_eq H K 1 H.one_mem hk
+
+@[scoped simp]
+theorem toOrbitAux_mk (g : M) :
+    toOrbitAux H K ((g : M) : M ⧸ K) = Quotient.mk'' ((g⁻¹ : M) : M ⧸ H) :=
+  rfl
+
+theorem toOrbitAux_eq_of_mem_orbit {x y : M ⧸ K} (hxy : x ∈ orbit H y) :
+    toOrbitAux H K x = toOrbitAux H K y := by
+  obtain ⟨η, hη⟩ := hxy
+  induction y using QuotientGroup.induction_on with
+  | H g' =>
+  rw [← hη]
+  change toOrbitAux H K (((η : M) * g' : M) : M ⧸ K) = toOrbitAux H K ((g' : M) : M ⧸ K)
+  rw [toOrbitAux_mk, toOrbitAux_mk]
+  refine mk''_mk_inv_eq H K (η : M) η.2 ?_
+  have : g'⁻¹ * (η : M)⁻¹ * ((η : M) * g') = 1 := by group
+  rw [this]
+  exact K.one_mem
+
+def orbitQuotientEquiv :
+    orbitRel.Quotient H (M ⧸ K) ≃ orbitRel.Quotient K (M ⧸ H) where
+  toFun q := Quotient.liftOn' q (toOrbitAux H K) fun _ _ h => toOrbitAux_eq_of_mem_orbit H K h
+  invFun q := Quotient.liftOn' q (toOrbitAux K H) fun _ _ h => toOrbitAux_eq_of_mem_orbit K H h
+  left_inv q := by
+    induction q using Quotient.inductionOn' with
+    | h x =>
+      induction x using QuotientGroup.induction_on with
+      | H g =>
+        change Quotient.mk'' ((g⁻¹⁻¹ : M) : M ⧸ K) = Quotient.mk'' ((g : M) : M ⧸ K)
+        rw [inv_inv]
+  right_inv q := by
+    induction q using Quotient.inductionOn' with
+    | h x =>
+      induction x using QuotientGroup.induction_on with
+      | H g =>
+        change Quotient.mk'' ((g⁻¹⁻¹ : M) : M ⧸ H) = Quotient.mk'' ((g : M) : M ⧸ H)
+        rw [inv_inv]
+
+theorem card_orbitRel_quotient_eq :
+    Nat.card (orbitRel.Quotient H (M ⧸ K)) = Nat.card (orbitRel.Quotient K (M ⧸ H)) :=
+  Nat.card_congr (orbitQuotientEquiv H K)
+
+noncomputable def quotientEquivOrbitsProd (hKH : ConjTrivial K H) :
+    (M ⧸ H) ≃ orbitRel.Quotient K (M ⧸ H) × K := by
+  classical
+  refine (MulAction.selfEquivSigmaOrbitsQuotientStabilizer K (M ⧸ H)).trans ?_
+  refine (Equiv.sigmaCongrRight fun ω => ?_).trans (Equiv.sigmaEquivProd _ _)
+  exact (Subgroup.quotientEquivOfEq
+    (stabilizer_eq_bot_of_conjTrivial K H hKH ω.out)).trans
+    QuotientGroup.quotientBot.toEquiv
+
+theorem card_orbitRelQuotient_mul_card (hKH : ConjTrivial K H) :
+    Nat.card (orbitRel.Quotient K (M ⧸ H)) * Nat.card K = H.index := by
+  rw [Subgroup.index_eq_card, Nat.card_congr (quotientEquivOrbitsProd H K hKH), Nat.card_prod]
+
+theorem card_orbitRelQuotient_mul_card' (hKH : ConjTrivial K H) :
+    Nat.card (orbitRel.Quotient H (M ⧸ K)) * Nat.card K = H.index := by
+  rw [card_orbitRel_quotient_eq]
+  exact card_orbitRelQuotient_mul_card H K hKH
+
+end DoubleCoset
+
+end FreeDoubleCoset
+end GroupTheory
+
+theorem solution {M : Type*} [Group M] (H K : Subgroup M)
+    (hKH : ∀ g x : M, x ∈ K → g⁻¹ * x * g ∈ H → x = 1) :
+    Nat.card (MulAction.orbitRel.Quotient H (M ⧸ K)) * Nat.card K = H.index :=
+  GroupTheory.FreeDoubleCoset.card_orbitRelQuotient_mul_card' H K hKH
+
+end S_Subgroup_card_orbitRelQuotient_mul_card_eq_index
+end P2MW
+export P2MW.S_Subgroup_card_orbitRelQuotient_mul_card_eq_index (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem Subgroup.card_orbitRelQuotient_mul_card_eq_index {M : Type*} [Group M] (H K : Subgroup M)
+    (hKH : ∀ g x : M, x ∈ K → g⁻¹ * x * g ∈ H → x = 1) :
+    Nat.card (MulAction.orbitRel.Quotient H (M ⧸ K)) * Nat.card K = H.index :=
+  solution H K hKH
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_TateModule_exists_linearEquiv_rationalTateModule_comp_rationalGaloisRep_eq_of_addEquiv.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_TateModule_exists_linearEquiv_rationalTateModule_comp_rationalGaloisRep_eq_of_addEquiv.lean
new file mode 100644
index 0000000000..7a42b457c2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_TateModule_exists_linearEquiv_rationalTateModule_comp_rationalGaloisRep_eq_of_addEquiv.lean
@@ -0,0 +1,137 @@
+/-
+Based on Prove2Me node
+TateModule.exists_linearEquiv_rationalTateModule_comp_rationalGaloisRep_eq_of_addEquiv
+(64daf8fe-6f13-5b0e-94db-45282c874d70) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 66603ac4-11de-59a7-8c10-7ec507634ff6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_JZeroTateModule
+public import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_TateModule_exists_linearMap_apply_eq_of_addMonoidHom
+
+/-!
+# Functoriality of the rational Tate module under a group isomorphism
+
+Theorem statement:
+`TateModule.exists_linearEquiv_rationalTateModule_comp_rationalGaloisRep_eq_of_addEquiv`
+(`64daf8fe-6f13-5b0e-94db-45282c874d70`), by Claude, 2026-09-05.
+
+Proof: submission `66603ac4-11de-59a7-8c10-7ec507634ff6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $p$ be a prime, let $J$ and $J'$ be abelian groups and let $\Psi : J \simeq J'$ be an
+isomorphism of additive groups; let $G$ and $G'$ be monoids acting distributively on $J$ and on $J'$
+respectively. Here $T_p J$ denotes the subgroup [`TateModule p
+J`](def/EllipticCurve_TateModule.html#L15) of sequences $x : \mathbb{N} \to J$ satisfying $p^n \cdot
+x_n = 0$ and $p \cdot x_{n+1} = x_n$ for all $n$, with $\mathbb{Z}_p$-module structure, `proj p J n`
+the evaluation $x \mapsto x_n$, and `RationalTateModule p J` the base change $\mathbb{Q}_p
+\otimes_{\mathbb{Z}_p} T_p J$; `rationalGaloisRep p J G` is the monoid homomorphism sending $g \in
+G$ to the $\mathbb{Q}_p$-linear endomorphism obtained by base change from the levelwise action $x
+\mapsto (g \cdot x_n)_n$ of $g$ on $T_p J$. The assertion is that there exists a
+$\mathbb{Q}_p$-linear isomorphism $\Theta : \mathbb{Q}_p \otimes_{\mathbb{Z}_p} T_p J \to
+\mathbb{Q}_p \otimes_{\mathbb{Z}_p} T_p J'$ such that, first, for every $x \in T_p J$ there is $y
+\in T_p J'$ with $\Theta(1 \otimes x) = 1 \otimes y$ and $y_n = \Psi(x_n)$ for all $n$; and second,
+for all $g \in G$ and $g' \in G'$ with $\Psi(g \cdot z) = g' \cdot \Psi(z)$ for all $z \in J$, the
+underlying linear maps satisfy $\Theta \circ \mathrm{rationalGaloisRep}(g) =
+\mathrm{rationalGaloisRep}(g') \circ \Theta$.
+
+This is the functoriality of the rational Tate module $V_p = \mathbb{Q}_p \otimes_{\mathbb{Z}_p}
+T_p$ for an isomorphism of the underlying abelian groups, together with the statement that the
+induced isomorphism intertwines operators corresponding under $\Psi$; the pinning on pure tensors
+identifies $\Theta$ as the map induced levelwise by $\Psi$. It is used to transport representations
+on Tate modules of Jacobians along an isomorphism of the groups carrying them, for instance in
+[`DrinfeldCurve.exists_linearEquiv_tateProd_comp_tateProdRep_eq_of_algEquiv`]
+(thm.html#DrinfeldCurve.exists_linearEquiv_tateProd_comp_tateProdRep_eq_of_algEquiv).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_TateModule_exists_linearEquiv_rationalTateModule_comp_rationalGaloisRep_eq_of_addEquiv.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open scoped TensorProduct
+
+theorem solution
+    (p : ℕ) [Fact p.Prime] {J J' : Type} [AddCommGroup J] [AddCommGroup J'] (Ψ : J ≃+ J')
+    (G G' : Type) [Monoid G] [Monoid G'] [DistribMulAction G J] [DistribMulAction G' J'] :
+    ∃ Θ : ModularCurve.RationalTateModule p J ≃ₗ[ℚ_[p]] ModularCurve.RationalTateModule p J',
+      (∀ x : TateModule p J, ∃ y : TateModule p J',
+        Θ ((1 : ℚ_[p]) ⊗ₜ[ℤ_[p]] x) = (1 : ℚ_[p]) ⊗ₜ[ℤ_[p]] y ∧
+          ∀ n : ℕ, TateModule.proj p J' n y = Ψ (TateModule.proj p J n x)) ∧
+      ∀ (g : G) (g' : G'), (∀ x : J, Ψ (g • x) = g' • Ψ x) →
+        (Θ : ModularCurve.RationalTateModule p J →ₗ[ℚ_[p]] ModularCurve.RationalTateModule p J') ∘ₗ
+            ModularCurve.rationalGaloisRep p J G g =
+          ModularCurve.rationalGaloisRep p J' G' g' ∘ₗ
+            (Θ : ModularCurve.RationalTateModule p J →ₗ[ℚ_[p]]
+              ModularCurve.RationalTateModule p J') := by
+  classical
+  obtain ⟨P, hP, -⟩ := TateModule.exists_linearMap_apply_eq_of_addMonoidHom p (Ψ : J →+ J')
+  obtain ⟨Q, hQ, -⟩ := TateModule.exists_linearMap_apply_eq_of_addMonoidHom p (Ψ.symm : J' →+ J)
+  have hQP : Q ∘ₗ P = LinearMap.id := by
+    apply LinearMap.ext; intro x; apply Subtype.ext; funext n
+    rw [LinearMap.comp_apply, hQ, hP, LinearMap.id_apply]
+    exact Ψ.symm_apply_apply _
+  have hPQ : P ∘ₗ Q = LinearMap.id := by
+    apply LinearMap.ext; intro y; apply Subtype.ext; funext n
+    rw [LinearMap.comp_apply, hP, hQ, LinearMap.id_apply]
+    exact Ψ.apply_symm_apply _
+  set P' := P.baseChange ℚ_[p] with hP'
+  set Q' := Q.baseChange ℚ_[p] with hQ'
+  have hQP' : Q' ∘ₗ P' = LinearMap.id := by
+    rw [hP', hQ', ← LinearMap.baseChange_comp, hQP, LinearMap.baseChange_id]
+  have hPQ' : P' ∘ₗ Q' = LinearMap.id := by
+    rw [hP', hQ', ← LinearMap.baseChange_comp, hPQ, LinearMap.baseChange_id]
+  refine ⟨LinearEquiv.ofLinearMap P' Q' hPQ' hQP', fun x => ⟨P x, ?_, fun n => ?_⟩,
+      fun g g' hgg' => ?_⟩
+  · change P' ((1 : ℚ_[p]) ⊗ₜ[ℤ_[p]] x) = (1 : ℚ_[p]) ⊗ₜ[ℤ_[p]] P x
+    rw [hP', LinearMap.baseChange_tmul]
+  · change ((P x : TateModule p J') : ℕ → J') n = Ψ ((x : ℕ → J) n)
+    exact hP x n
+  have hnat : P ∘ₗ TateModule.rep p J G g = TateModule.rep p J' G' g' ∘ₗ P := by
+    apply LinearMap.ext; intro x; apply Subtype.ext; funext n
+    rw [LinearMap.comp_apply, LinearMap.comp_apply, hP, TateModule.rep_apply, TateModule.rep_apply,
+      hP]
+    exact hgg' _
+  change P' ∘ₗ ModularCurve.rationalGaloisRep p J G g =
+    ModularCurve.rationalGaloisRep p J' G' g' ∘ₗ P'
+  rw [ModularCurve.rationalGaloisRep_apply, ModularCurve.rationalGaloisRep_apply, hP', ←
+    LinearMap.baseChange_comp,
+    ← LinearMap.baseChange_comp, hnat]
+
+end privateSection
+
+public section publicSection
+
+open AlgebraicCurve
+
+open scoped TensorProduct
+
+theorem TateModule.exists_linearEquiv_rationalTateModule_comp_rationalGaloisRep_eq_of_addEquiv
+    (p : ℕ) [Fact p.Prime] {J J' : Type} [AddCommGroup J] [AddCommGroup J'] (Ψ : J ≃+ J')
+    (G G' : Type) [Monoid G] [Monoid G'] [DistribMulAction G J] [DistribMulAction G' J'] :
+    ∃ Θ : ModularCurve.RationalTateModule p J ≃ₗ[ℚ_[p]] ModularCurve.RationalTateModule p J',
+      (∀ x : TateModule p J, ∃ y : TateModule p J',
+        Θ ((1 : ℚ_[p]) ⊗ₜ[ℤ_[p]] x) = (1 : ℚ_[p]) ⊗ₜ[ℤ_[p]] y ∧
+          ∀ n : ℕ, TateModule.proj p J' n y = Ψ (TateModule.proj p J n x)) ∧
+      ∀ (g : G) (g' : G'), (∀ x : J, Ψ (g • x) = g' • Ψ x) →
+        (Θ : ModularCurve.RationalTateModule p J →ₗ[ℚ_[p]] ModularCurve.RationalTateModule p J') ∘ₗ
+            ModularCurve.rationalGaloisRep p J G g =
+          ModularCurve.rationalGaloisRep p J' G' g' ∘ₗ
+            (Θ : ModularCurve.RationalTateModule p J →ₗ[ℚ_[p]]
+              ModularCurve.RationalTateModule p J') :=
+  solution p Ψ G G'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_TateModule_exists_linearMap_apply_eq_of_addMonoidHom.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_TateModule_exists_linearMap_apply_eq_of_addMonoidHom.lean
new file mode 100644
index 0000000000..85478a3170
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_TateModule_exists_linearMap_apply_eq_of_addMonoidHom.lean
@@ -0,0 +1,93 @@
+/-
+Based on Prove2Me node TateModule.exists_linearMap_apply_eq_of_addMonoidHom
+(dfa4a18f-38e5-5670-9cca-25d1da811b68) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 15eca05f-9aed-50eb-bf5d-cd2cfcd2dcb0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_TateModule
+public import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Functoriality of the p-adic Tate module in M
+
+Theorem statement: `TateModule.exists_linearMap_apply_eq_of_addMonoidHom`
+(`dfa4a18f-38e5-5670-9cca-25d1da811b68`), by Claude, 2026-09-05.
+
+Proof: submission `15eca05f-9aed-50eb-bf5d-cd2cfcd2dcb0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $p$ be a prime and let $M$, $M'$ be additive commutative groups, and let $f \colon M \to M'$ be
+an additive homomorphism. For an additive commutative group $M$, the project's $p$-adic Tate module
+[`TateModule p M`](def/EllipticCurve_TateModule.html#L15) is the subgroup of sequences $x \colon
+\mathbb{N} \to M$ such that for every $n$ one has $p^n \cdot x_n = 0$ and $p \cdot x_{n+1} = x_n$
+(integer scalar multiples), carrying its $\mathbb{Z}_p$-module structure, in which $a \in
+\mathbb{Z}_p$ acts levelwise through the integer approximations $a.\mathrm{appr}\,n$ of $a$. The
+assertion is that there exists a $\mathbb{Z}_p$-linear map $e \colon$ [`TateModule p
+M`](def/EllipticCurve_TateModule.html#L15) $\to$ [`TateModule p
+M'`](def/EllipticCurve_TateModule.html#L15) with two properties: first, $e$ acts levelwise by $f$,
+that is, for every $x$ in [`TateModule p M`](def/EllipticCurve_TateModule.html#L15) and every $n \in
+\mathbb{N}$ the $n$-th component of the sequence underlying $e(x)$ equals $f(x_n)$, where $x_n$ is
+the $n$-th component of the sequence underlying $x$; second, if $f$ is injective then $e$ is
+injective. Only the existence of such an $e$ is asserted, not its uniqueness (which would in any
+case follow from the levelwise description).
+
+This is the functoriality of the $p$-adic Tate module $T_p(-) = \varprojlim_n (-)[p^n]$ in the
+coefficient group, in the form used throughout the project to transport Tate modules along maps of
+abelian groups. It is invoked where Tate modules of Jacobians and of $p$-divisible groups are
+compared, for instance in the passage from an additive isomorphism to an isomorphism of rational
+Tate modules compatible with Galois representations, and in the construction of Tate modules
+attached to $J_1$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_TateModule_exists_linearMap_apply_eq_of_addMonoidHom.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+theorem solution
+    (p : ℕ) [Fact p.Prime] {M M' : Type} [AddCommGroup M] [AddCommGroup M'] (f : M →+ M') :
+    ∃ e : TateModule p M →ₗ[ℤ_[p]] TateModule p M',
+      (∀ (x : TateModule p M) (n : ℕ), ((e x : TateModule p M') : ℕ → M') n = f ((x : ℕ → M) n)) ∧
+      (Function.Injective f → Function.Injective e) := by
+  refine ⟨{ toFun := fun x => ⟨fun n => f ((x : ℕ → M) n), fun n => ⟨?_, ?_⟩⟩,
+            map_add' := ?_, map_smul' := ?_ }, ?_, ?_⟩
+  · rw [← map_zsmul, TateModule.torsion, map_zero]
+  · rw [← map_zsmul, TateModule.compat]
+  · intro x y
+    exact Subtype.ext (funext fun n => by
+      change f (((x + y : TateModule p M) : ℕ → M) n) = f ((x : ℕ → M) n) + f ((y : ℕ → M) n)
+      rw [AddSubgroup.coe_add, Pi.add_apply, map_add])
+  · intro a x
+    exact Subtype.ext (funext fun n => by
+      change f (((a • x : TateModule p M) : ℕ → M) n) = ((a.appr n : ℕ) : ℤ) • f ((x : ℕ → M) n)
+      rw [TateModule.smul_apply, map_zsmul])
+  · intro x n
+    rfl
+  · intro hf x y hxy
+    refine Subtype.ext (funext fun n => hf ?_)
+    have := congrArg (fun z : TateModule p M' => (z : ℕ → M') n) hxy
+    exact this
+
+end privateSection
+
+public section publicSection
+
+theorem TateModule.exists_linearMap_apply_eq_of_addMonoidHom
+    (p : ℕ) [Fact p.Prime] {M M' : Type} [AddCommGroup M] [AddCommGroup M'] (f : M →+ M') :
+    ∃ e : TateModule p M →ₗ[ℤ_[p]] TateModule p M',
+      (∀ (x : TateModule p M) (n : ℕ), ((e x : TateModule p M') : ℕ → M') n = f ((x : ℕ → M) n)) ∧
+      (Function.Injective f → Function.Injective e) :=
+  solution p f
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_apply_add_eq_apply_of_hasDerivAt_of_isZeroAtImInfty.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_apply_add_eq_apply_of_hasDerivAt_of_isZeroAtImInfty.lean
new file mode 100644
index 0000000000..96acf8561d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_apply_add_eq_apply_of_hasDerivAt_of_isZeroAtImInfty.lean
@@ -0,0 +1,189 @@
+/-
+Based on Prove2Me node UpperHalfPlane.apply_add_eq_apply_of_hasDerivAt_of_isZeroAtImInfty
+(bbacd8c8-5316-54db-8bc3-63af17930a98) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d8372a76-c0fa-53b0-b50c-35dbfca89d5a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.CStarAlgebra.Classes
+public import Mathlib.Analysis.Complex.UpperHalfPlane.FunctionsBoundedAtInfty
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Manifold
+
+import Mathlib.Algebra.Order.Star.Real
+import Mathlib.Analysis.Complex.HasPrimitives
+import Mathlib.NumberTheory.ModularForms.QExpansion
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Periodicity of a primitive of a periodic form vanishing at i∞
+
+Theorem statement: `UpperHalfPlane.apply_add_eq_apply_of_hasDerivAt_of_isZeroAtImInfty`
+(`bbacd8c8-5316-54db-8bc3-63af17930a98`), by Claude, 2026-09-05.
+
+Proof: submission `d8372a76-c0fa-53b0-b50c-35dbfca89d5a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $h$ be a real number with $0 < h$, and let $g \colon \mathfrak{H} \to \mathbb{C}$ be a function
+on the upper half-plane subject to three hypotheses: the composite $g \circ \mathtt{ofComplex}$, the
+extension of $g$ to all of $\mathbb{C}$ obtained by sending points off the upper half-plane to a
+fixed base point, is periodic with period $h$; $g$ is differentiable as a map of complex manifolds
+for the trivial charts on $\mathfrak{H}$ and on $\mathbb{C}$, that is, holomorphic; and $g$ is zero
+at $i\infty$, i.e. $g$ tends to $0$ along the filter of large imaginary part. Let further $\varphi
+\colon \mathbb{C} \to \mathbb{C}$ be a function which, at every point $\tau$ of the upper
+half-plane, has derivative $g(\tau)$ there (the hypothesis is stated pointwise on $\mathfrak{H}$;
+nothing is assumed about $\varphi$ elsewhere). Then for every $\tau \in \mathfrak{H}$ one has
+$\varphi(\tau + h) = \varphi(\tau)$; equivalently, the integral of $g$ along any path from $\tau$ to
+$\tau + h$ in $\mathfrak{H}$ vanishes.
+
+This is the vanishing of the constant Fourier coefficient of a periodic holomorphic function
+decaying at $i\infty$, in primitive form: an antiderivative of such a $g$ is itself $h$-periodic. It
+is used in the construction of Eichler integrals, where it supplies the invariance needed in
+[`HeckeEis.IsEichlerIntegral.vadd_sub_T_zpow_apply_mem_range`]
+(thm.html#HeckeEis.IsEichlerIntegral.vadd_sub_T_zpow_apply_mem_range).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_UpperHalfPlane_apply_add_eq_apply_of_hasDerivAt_of_isZeroAtImInfty.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_UpperHalfPlane_apply_add_eq_apply_of_hasDerivAt_of_isZeroAtImInfty
+
+open scoped Manifold Topology
+
+namespace UpperHalfPlane
+p2m_export "UpperHalfPlane" "cuspFunction isOpen_upperHalfPlaneSet σ analyticAt_cuspFunction_zero \
+  differentiableOn_cuspFunction_ball I eq_cuspFunction cuspFunction_apply_zero IsZeroAtImInfty \
+  IsBoundedAtImInfty im coe_vadd ofComplex"
+namespace PeriodicPrimitiveSol
+p2m_open "UpperHalfPlane"
+
+p2m_open "UpperHalfPlane \
+  P2MW.S_UpperHalfPlane_apply_add_eq_apply_of_hasDerivAt_of_isZeroAtImInfty.UpperHalfPlane Filter \
+  Topology Complex Function Metric"
+open scoped Real Manifold
+
+local notation "𝕢" => Function.Periodic.qParam
+
+theorem hasDerivAt_qParam (h : ℝ) (z : ℂ) :
+    HasDerivAt (𝕢 h) (2 * π * Complex.I / h * 𝕢 h z) z := by
+  have h1 : HasDerivAt (fun w : ℂ => 2 * ↑π * Complex.I * w / ↑h)
+      (2 * ↑π * Complex.I / ↑h) z := by
+    simpa using ((hasDerivAt_id z).const_mul (2 * ↑π * Complex.I)).div_const (↑h : ℂ)
+  have h2 := h1.cexp
+  have hval : 2 * (π:ℂ) * Complex.I / ↑h * 𝕢 h z
+      = cexp (2 * ↑π * Complex.I * z / ↑h) * (2 * ↑π * Complex.I / ↑h) := by
+    simp only [Function.Periodic.qParam]
+    ring
+  rw [hval]
+  exact h2
+
+theorem qParam_add_period (h : ℝ) (hh : h ≠ 0) (z : ℂ) : 𝕢 h (z + h) = 𝕢 h z := by
+  simp only [Function.Periodic.qParam]
+  have hne : (h : ℂ) ≠ 0 := ofReal_ne_zero.mpr hh
+  rw [show 2 * ↑π * Complex.I * (z + ↑h) / ↑h = 2 * ↑π * Complex.I * z / ↑h + 2 * ↑π * Complex.I by
+    field_simp,
+    Complex.exp_add, Complex.exp_two_pi_mul_I, mul_one]
+
+theorem exists_periodic_primitive {h : ℝ} {g : ℍ → ℂ} (hh : 0 < h)
+    (hper : Periodic (g ∘ ofComplex) h)
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g) (hzero : IsZeroAtImInfty g) :
+    ∃ G : ℂ → ℂ, (∀ τ : ℍ, HasDerivAt G (g τ) ↑τ) ∧ Periodic G h := by
+  have hbdd : IsBoundedAtImInfty g := hzero.boundedAtFilter
+  set Φ : ℂ → ℂ := cuspFunction h g with hΦ
+  have hΦdiff : DifferentiableOn ℂ Φ (ball 0 1) :=
+    differentiableOn_cuspFunction_ball hh hper hhol hbdd
+  have hΦ0 : Φ 0 = 0 := by
+    rw [hΦ, cuspFunction_apply_zero hh (analyticAt_cuspFunction_zero hh hper hhol hbdd) hper]
+    exact hzero.valueAtInfty_eq_zero
+  set Φ₁ : ℂ → ℂ := dslope Φ 0 with hΦ₁
+  have hΦ₁diff : DifferentiableOn ℂ Φ₁ (ball 0 1) :=
+    (Complex.differentiableOn_dslope (ball_mem_nhds 0 one_pos)).mpr hΦdiff
+  have hΦ₁mul : ∀ q : ℂ, q * Φ₁ q = Φ q := fun q => by
+    have := sub_smul_dslope Φ 0 q
+    simpa [hΦ0, smul_eq_mul] using this
+  obtain ⟨Ψ, hΨ0, hΨ⟩ := (hΦ₁diff.isExactOn_ball).with_val_at 0 0
+  have hqball : ∀ τ : ℍ, 𝕢 h ↑τ ∈ ball (0:ℂ) 1 := by
+    intro τ
+    rw [mem_ball_zero_iff, Function.Periodic.norm_qParam]
+    have him : (0:ℝ) < Complex.im ↑τ := τ.2
+    calc Real.exp (-2 * π * Complex.im ↑τ / h) < Real.exp 0 :=
+          Real.exp_lt_exp.mpr (by
+            apply div_neg_of_neg_of_pos _ hh
+            nlinarith [Real.pi_pos])
+      _ = 1 := Real.exp_zero
+  refine ⟨fun z : ℂ => ↑h / (2 * π * Complex.I) * Ψ (𝕢 h z), fun τ => ?_, fun z => ?_⟩
+  · have h1 : HasDerivAt (fun z : ℂ => Ψ (𝕢 h z))
+        (Φ₁ (𝕢 h ↑τ) * (2 * π * Complex.I / h * 𝕢 h ↑τ)) ↑τ :=
+      (hΨ _ (hqball τ)).comp (↑τ : ℂ) (hasDerivAt_qParam h ↑τ)
+    have h2 := h1.const_mul (↑h / (2 * π * Complex.I))
+    convert h2 using 1
+    have hne : (↑h : ℂ) ≠ 0 := ofReal_ne_zero.mpr hh.ne'
+    have h3 : ↑h / (2 * ↑π * Complex.I) * (Φ₁ (𝕢 h ↑τ) * (2 * ↑π * Complex.I / ↑h * 𝕢 h ↑τ))
+        = 𝕢 h ↑τ * Φ₁ (𝕢 h ↑τ) := by
+      field_simp
+    rw [h3, hΦ₁mul]
+    exact (eq_cuspFunction τ hh.ne' hper).symm
+  · change ↑h / (2 * π * Complex.I) * Ψ (𝕢 h (z + h)) = ↑h / (2 * π * Complex.I) * Ψ (𝕢 h z)
+    rw [qParam_add_period h hh.ne' z]
+
+theorem apply_eq_apply_of_hasDerivAt_zero {D : ℂ → ℂ}
+    (hD : ∀ τ : ℍ, HasDerivAt D 0 ↑τ) (z w : ℍ) : D ↑z = D ↑w := by
+  have hmem : ∀ σ : ℍ, (↑σ : ℂ) ∈ {c : ℂ | 0 < c.im} := fun σ => σ.2
+  refine isOpen_upperHalfPlaneSet.is_const_of_fderiv_eq_zero
+    ((convex_halfSpace_im_gt 0).isPreconnected)
+    (fun x hx => ((hD ⟨x, hx⟩).differentiableAt).differentiableWithinAt)
+    (fun x hx => ?_) (hmem z) (hmem w)
+  have h0 := ((hD ⟨x, hx⟩).hasFDerivAt).fderiv
+  rw [Pi.zero_apply, h0]
+  ext1
+  simp
+
+end UpperHalfPlane.PeriodicPrimitiveSol
+
+open _root_.UpperHalfPlane
+  _root_.P2MW.S_UpperHalfPlane_apply_add_eq_apply_of_hasDerivAt_of_isZeroAtImInfty.UpperHalfPlane
+  UpperHalfPlane.PeriodicPrimitiveSol in
+theorem solution {h : ℝ} (hh : 0 < h) {g : UpperHalfPlane → ℂ}
+    (hper : Function.Periodic (g ∘ UpperHalfPlane.ofComplex) h)
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g) (hzero : UpperHalfPlane.IsZeroAtImInfty g)
+    {φ : ℂ → ℂ} (hφ : ∀ τ : UpperHalfPlane, HasDerivAt φ (g τ) ↑τ) (τ : UpperHalfPlane) :
+    φ (↑τ + h) = φ ↑τ := by
+  obtain ⟨G, hG, hGper⟩ := exists_periodic_primitive hh hper hhol hzero
+  have hD : ∀ σ : ℍ, HasDerivAt (fun z => φ z - G z) 0 ↑σ := fun σ => by
+    convert (hφ σ).sub (hG σ) using 1
+    all_goals simp
+  have key := apply_eq_apply_of_hasDerivAt_zero hD (h +ᵥ τ) τ
+  simp only [coe_vadd] at key
+  rw [add_comm] at key
+  rw [hGper] at key
+  linear_combination key
+
+end S_UpperHalfPlane_apply_add_eq_apply_of_hasDerivAt_of_isZeroAtImInfty
+end P2MW
+export P2MW.S_UpperHalfPlane_apply_add_eq_apply_of_hasDerivAt_of_isZeroAtImInfty (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Manifold Topology
+theorem UpperHalfPlane.apply_add_eq_apply_of_hasDerivAt_of_isZeroAtImInfty {h : ℝ} (hh : 0 < h)
+    {g : UpperHalfPlane → ℂ} (hper : Function.Periodic (g ∘ UpperHalfPlane.ofComplex) h)
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g) (hzero : UpperHalfPlane.IsZeroAtImInfty g)
+    {φ : ℂ → ℂ} (hφ : ∀ τ : UpperHalfPlane, HasDerivAt φ (g τ) ↑τ) (τ : UpperHalfPlane) :
+    φ (↑τ + h) = φ ↑τ :=
+  solution hh hper hhol hzero hφ τ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_eq_of_forall_qCoeff_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_eq_of_forall_qCoeff_eq.lean
new file mode 100644
index 0000000000..923f08bd92
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_eq_of_forall_qCoeff_eq.lean
@@ -0,0 +1,116 @@
+/-
+Based on Prove2Me node UpperHalfPlane.eq_of_forall_qCoeff_eq
+(156ca36b-a1ef-54a0-aeaa-bdac6bb4f1f0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 335e7620-2dc9-5c6e-87f5-74e923b83810
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.CStarAlgebra.Classes
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+
+import Mathlib.NumberTheory.ModularForms.QExpansion
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Uniqueness of q-expansions of periodic holomorphic functions
+
+Theorem statement: `UpperHalfPlane.eq_of_forall_qCoeff_eq` (`156ca36b-a1ef-54a0-aeaa-bdac6bb4f1f0`),
+by Claude, 2026-09-05.
+
+Proof: submission `335e7620-2dc9-5c6e-87f5-74e923b83810`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $f, g : \mathbb{H} \to \mathbb{C}$ be two functions on the upper half-plane, each subject to
+three hypotheses: that its extension to $\mathbb{C}$ obtained by composing with
+`UpperHalfPlane.ofComplex` is periodic with period $1$; that it is holomorphic, expressed as
+differentiability with respect to the standard complex manifold structure on $\mathbb{C}$ on both
+source and target; and that it is bounded at $i\infty$ in the sense of
+`UpperHalfPlane.IsBoundedAtImInfty`, i.e. bounded on the region where the imaginary part exceeds
+some constant. Assume further that for every natural number $n$ one has $\mathrm{qCoeff}\,f\,n =
+\mathrm{qCoeff}\,g\,n$, where $\mathrm{qCoeff}\,h\,n$ is by definition the $n$-th coefficient of
+Mathlib's power series $\mathrm{qExpansion}\,1\,h$, the $q$-expansion of $h$ with respect to the
+period $1$. The conclusion is the equality $f = g$ of functions on $\mathbb{H}$. No modularity under
+any congruence subgroup is assumed: only $1$-periodicity, holomorphy and boundedness at the cusp
+$i\infty$.
+
+This is the injectivity of the $q$-expansion map on $1$-periodic holomorphic functions bounded at
+$i\infty$, an unbundled companion of the $q$-expansion principle for modular forms; it applies in
+particular to Hecke translates of forms before these are known to be modular. It is used throughout
+the Hecke-operator part of the development, for instance to verify eigenform identities and the
+behaviour of eigenforms under change of level by comparing $q$-expansion coefficients.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_UpperHalfPlane_eq_of_forall_qCoeff_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_UpperHalfPlane_eq_of_forall_qCoeff_eq
+
+noncomputable section
+
+open Complex Function Filter
+p2m_open "UpperHalfPlane~I"
+open scoped Real MatrixGroups ModularForm Manifold Topology
+
+open ModularForm ModularFormClass
+
+namespace W2WsF
+
+theorem hasSum_qCoeff {f : ℍ → ℂ} (hper : Periodic (f ∘ ofComplex) 1) (hhol : MDiff f)
+    (hbdd : IsBoundedAtImInfty f) (τ : ℍ) :
+    HasSum (fun m ↦ qCoeff f m • Periodic.qParam 1 τ ^ m) (f τ) :=
+  hasSum_qExpansion one_pos hper hhol hbdd τ
+
+end W2WsF
+
+theorem solution {f g : UpperHalfPlane → ℂ}
+    (hfper : Function.Periodic (f ∘ UpperHalfPlane.ofComplex) 1)
+    (hfhol : MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) f)
+    (hfbdd : UpperHalfPlane.IsBoundedAtImInfty f)
+    (hgper : Function.Periodic (g ∘ UpperHalfPlane.ofComplex) 1)
+    (hghol : MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) g)
+    (hgbdd : UpperHalfPlane.IsBoundedAtImInfty g)
+    (h : ∀ n : ℕ, ModularFormClass.qCoeff f n = ModularFormClass.qCoeff g n) :
+    f = g := by
+  funext τ
+  have hf := W2WsF.hasSum_qCoeff hfper hfhol hfbdd τ
+  have hg := W2WsF.hasSum_qCoeff hgper hghol hgbdd τ
+  simp only [h] at hf
+  exact hf.unique hg
+
+end
+
+end S_UpperHalfPlane_eq_of_forall_qCoeff_eq
+end P2MW
+export P2MW.S_UpperHalfPlane_eq_of_forall_qCoeff_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem UpperHalfPlane.eq_of_forall_qCoeff_eq {f g : UpperHalfPlane → ℂ}
+    (hfper : Function.Periodic (f ∘ UpperHalfPlane.ofComplex) 1)
+    (hfhol : MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) f)
+    (hfbdd : UpperHalfPlane.IsBoundedAtImInfty f)
+    (hgper : Function.Periodic (g ∘ UpperHalfPlane.ofComplex) 1)
+    (hghol : MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) g)
+    (hgbdd : UpperHalfPlane.IsBoundedAtImInfty g)
+    (h : ∀ n : ℕ, ModularFormClass.qCoeff f n = ModularFormClass.qCoeff g n) :
+    f = g :=
+  solution hfper hfhol hfbdd hgper hghol hgbdd h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_isBoundedAtImInfty_of_hasDerivAt_of_periodic.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_isBoundedAtImInfty_of_hasDerivAt_of_periodic.lean
new file mode 100644
index 0000000000..94c960285b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_isBoundedAtImInfty_of_hasDerivAt_of_periodic.lean
@@ -0,0 +1,251 @@
+/-
+Based on Prove2Me node UpperHalfPlane.isBoundedAtImInfty_of_hasDerivAt_of_periodic
+(6ab34a64-cfbc-517b-b670-33bca77557e8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission df2e711a-cda0-5d6c-ac21-33fa8604bc46
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.CStarAlgebra.Classes
+public import Mathlib.Analysis.Complex.UpperHalfPlane.FunctionsBoundedAtInfty
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Manifold
+
+import Mathlib.Algebra.Order.Star.Real
+import Mathlib.Analysis.Complex.HasPrimitives
+import Mathlib.NumberTheory.ModularForms.QExpansion
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Periodic primitives of bounded periodic holomorphic functions on H
+
+Theorem statement: `UpperHalfPlane.isBoundedAtImInfty_of_hasDerivAt_of_periodic`
+(`6ab34a64-cfbc-517b-b670-33bca77557e8`), by Claude, 2026-09-05.
+
+Proof: submission `df2e711a-cda0-5d6c-ac21-33fa8604bc46`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $h$ be a real number with $h>0$ and let $u,v\colon\mathfrak H\to\mathbb C$ be functions on the
+upper half-plane. Assume: the composite of `UpperHalfPlane.ofComplex` with $u$ is $h$-periodic as a
+function on $\mathbb C$ (since `ofComplex` is the identity on points of positive imaginary part and
+constant elsewhere, this amounts to $u(\tau+h)=u(\tau)$ for all $\tau\in\mathfrak H$); $u$ is
+holomorphic, in the sense of being differentiable as a map of complex manifolds from $\mathfrak H$
+with its chart model $\mathcal I(\mathbb C)$ to $\mathbb C$; $u$ is bounded at $i\infty$, i.e.
+bounded along the filter `atImInfty`, so bounded on some region $\{\operatorname{Im}\tau\ge A\}$;
+for every $\tau\in\mathfrak H$ the complex-variable function obtained by composing `ofComplex` with
+$v$ has derivative $u(\tau)$ at the point $\tau$ of $\mathbb C$, so $v$ is a primitive of $u$ on
+$\mathfrak H$; and this same composite is $h$-periodic, i.e. $v(\tau+h)=v(\tau)$ on $\mathfrak H$.
+The conclusion is that $v$ too is bounded at $i\infty$.
+
+This is the standard $q$-expansion argument showing that an $h$-periodic primitive of an
+$h$-periodic holomorphic function that is bounded at the cusp is itself bounded at the cusp:
+periodicity of the primitive forces the constant term of the $q$-expansion of $u$ to vanish. The
+periodicity of $v$ is essential ($u=1$, $v=\tau$ is a counterexample without it). It is used to
+establish boundedness at $i\infty$ of the evaluations of Eichler integrals, via
+[`HeckeEis.IsEichlerIntegral.isBoundedAtImInfty_eval`]
+(thm.html#HeckeEis.IsEichlerIntegral.isBoundedAtImInfty_eval).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_UpperHalfPlane_isBoundedAtImInfty_of_hasDerivAt_of_periodic.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_UpperHalfPlane_isBoundedAtImInfty_of_hasDerivAt_of_periodic
+
+namespace UpperHalfPlane
+p2m_export "UpperHalfPlane" "cuspFunction isOpen_upperHalfPlaneSet ofComplex_apply_of_im_pos σ \
+  differentiableOn_cuspFunction_ball I ofComplex_apply im_pos isBoundedAtImInfty_iff \
+  eq_cuspFunction IsBoundedAtImInfty im coe_vadd ofComplex"
+namespace PrimBddAux
+p2m_open "UpperHalfPlane"
+
+p2m_open "UpperHalfPlane \
+  P2MW.S_UpperHalfPlane_isBoundedAtImInfty_of_hasDerivAt_of_periodic.UpperHalfPlane Filter \
+  Topology Complex Function Metric"
+open scoped Real Manifold
+
+local notation "𝕢" => Function.Periodic.qParam
+
+theorem hasDerivAt_qParam (h : ℝ) (z : ℂ) :
+    HasDerivAt (𝕢 h) (2 * π * Complex.I / h * 𝕢 h z) z := by
+  have h1 : HasDerivAt (fun w : ℂ => 2 * ↑π * Complex.I * w / ↑h)
+      (2 * ↑π * Complex.I / ↑h) z := by
+    simpa using ((hasDerivAt_id z).const_mul (2 * ↑π * Complex.I)).div_const (↑h : ℂ)
+  have h2 := h1.cexp
+  have hval : 2 * (π:ℂ) * Complex.I / ↑h * 𝕢 h z
+      = cexp (2 * ↑π * Complex.I * z / ↑h) * (2 * ↑π * Complex.I / ↑h) := by
+    simp only [Function.Periodic.qParam]
+    ring
+  rw [hval]
+  exact h2
+
+theorem qParam_add_period (h : ℝ) (hh : h ≠ 0) (z : ℂ) : 𝕢 h (z + h) = 𝕢 h z := by
+  simp only [Function.Periodic.qParam]
+  have hne : (h : ℂ) ≠ 0 := ofReal_ne_zero.mpr hh
+  rw [show 2 * ↑π * Complex.I * (z + ↑h) / ↑h = 2 * ↑π * Complex.I * z / ↑h + 2 * ↑π * Complex.I by
+    field_simp,
+    Complex.exp_add, Complex.exp_two_pi_mul_I, mul_one]
+
+theorem apply_eq_apply_of_hasDerivAt_zero {D : ℂ → ℂ}
+    (hD : ∀ τ : ℍ, HasDerivAt D 0 ↑τ) (z w : ℍ) : D ↑z = D ↑w := by
+  have hmem : ∀ σ : ℍ, (↑σ : ℂ) ∈ {c : ℂ | 0 < c.im} := fun σ => σ.2
+  refine isOpen_upperHalfPlaneSet.is_const_of_fderiv_eq_zero
+    ((convex_halfSpace_im_gt 0).isPreconnected)
+    (fun x hx => ((hD ⟨x, hx⟩).differentiableAt).differentiableWithinAt)
+    (fun x hx => ?_) (hmem z) (hmem w)
+  have h0 := ((hD ⟨x, hx⟩).hasFDerivAt).fderiv
+  rw [Pi.zero_apply, h0]
+  ext1
+  simp
+
+theorem ofComplex_coe_add_real (τ : ℍ) (p : ℝ) : ofComplex ((τ : ℂ) + (p : ℂ)) = (p +ᵥ τ) := by
+  have him : 0 < ((τ : ℂ) + (p : ℂ)).im := by simpa using τ.im_pos
+  rw [ofComplex_apply_of_im_pos him]
+  apply UpperHalfPlane.ext
+  simp [UpperHalfPlane.coe_vadd, add_comm]
+
+theorem isBoundedAtImInfty_of_hasDerivAt_of_periodic {h : ℝ} (hh : 0 < h) {u v : ℍ → ℂ}
+    (hu_per : Periodic (u ∘ ofComplex) h) (hu_hol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) u)
+    (hu_bdd : IsBoundedAtImInfty u)
+    (hv : ∀ τ : ℍ, HasDerivAt (v ∘ ofComplex) (u τ) ↑τ) (hv_per : Periodic (v ∘ ofComplex) h) :
+    IsBoundedAtImInfty v := by
+  set Φ : ℂ → ℂ := cuspFunction h u with hΦ
+  have hΦdiff : DifferentiableOn ℂ Φ (ball 0 1) :=
+    differentiableOn_cuspFunction_ball hh hu_per hu_hol hu_bdd
+  set L : ℂ := Φ 0 with hL
+  set Φ₁ : ℂ → ℂ := dslope Φ 0 with hΦ₁
+  have hΦ₁diff : DifferentiableOn ℂ Φ₁ (ball 0 1) :=
+    (Complex.differentiableOn_dslope (ball_mem_nhds 0 one_pos)).mpr hΦdiff
+  have hΦ₁mul : ∀ q : ℂ, q * Φ₁ q = Φ q - L := fun q => by
+    have := sub_smul_dslope Φ 0 q
+    simpa [smul_eq_mul] using this
+  obtain ⟨Ψ, -, hΨ⟩ := (hΦ₁diff.isExactOn_ball).with_val_at 0 0
+  have hnormq : ∀ τ : ℍ, ‖𝕢 h ↑τ‖ = Real.exp (-2 * π * τ.im / h) := fun τ => by
+    rw [Function.Periodic.norm_qParam]; rfl
+  have hqball : ∀ τ : ℍ, 𝕢 h ↑τ ∈ ball (0:ℂ) 1 := by
+    intro τ
+    rw [mem_ball_zero_iff, hnormq]
+    calc Real.exp (-2 * π * τ.im / h) < Real.exp 0 :=
+          Real.exp_lt_exp.mpr (by
+            apply div_neg_of_neg_of_pos _ hh
+            have := τ.im_pos
+            nlinarith [Real.pi_pos])
+      _ = 1 := Real.exp_zero
+  set G : ℂ → ℂ := fun z => ↑h / (2 * π * Complex.I) * Ψ (𝕢 h z) with hGdef
+  have hG : ∀ τ : ℍ, HasDerivAt G (u τ - L) ↑τ := by
+    intro τ
+    have h1 : HasDerivAt (fun z : ℂ => Ψ (𝕢 h z))
+        (Φ₁ (𝕢 h ↑τ) * (2 * π * Complex.I / h * 𝕢 h ↑τ)) ↑τ :=
+      (hΨ _ (hqball τ)).comp (↑τ : ℂ) (hasDerivAt_qParam h ↑τ)
+    have h2 := h1.const_mul (↑h / (2 * π * Complex.I))
+    convert h2 using 1
+    have hne : (↑h : ℂ) ≠ 0 := ofReal_ne_zero.mpr hh.ne'
+    have h3 : ↑h / (2 * ↑π * Complex.I) * (Φ₁ (𝕢 h ↑τ) * (2 * ↑π * Complex.I / ↑h * 𝕢 h ↑τ))
+        = 𝕢 h ↑τ * Φ₁ (𝕢 h ↑τ) := by
+      field_simp
+    rw [h3, hΦ₁mul, hΦ]
+    rw [eq_cuspFunction τ hh.ne' hu_per]
+  have hGper : ∀ z : ℂ, G (z + h) = G z := fun z => by
+    simp only [hGdef]
+    rw [qParam_add_period h hh.ne' z]
+  have hD : ∀ σ : ℍ, HasDerivAt (fun z : ℂ => (v ∘ ofComplex) z - G z - L * z) 0 ↑σ := by
+    intro σ
+    have := ((hv σ).sub (hG σ)).sub ((hasDerivAt_id (σ : ℂ)).const_mul L)
+    convert this using 1
+    all_goals first | rfl | simp
+  have hconst : ∀ τ : ℍ, v τ - G ↑τ - L * ↑τ = v I - G ↑I - L * ↑I := by
+    intro τ
+    have := apply_eq_apply_of_hasDerivAt_zero hD τ I
+    simp only [Function.comp_apply, ofComplex_apply] at this
+    exact this
+  have hL0 : L = 0 := by
+    have h1 := hconst ((h : ℝ) +ᵥ I)
+    have hvper : v ((h : ℝ) +ᵥ I) = v I := by
+      have := hv_per (I : ℂ)
+      simp only [Function.comp_apply] at this
+      rw [ofComplex_coe_add_real I h, ofComplex_apply] at this
+      exact this
+    have hGI : G ↑((h : ℝ) +ᵥ I) = G ↑I := by
+      rw [coe_vadd, add_comm]
+      exact hGper _
+    rw [hvper, hGI, coe_vadd] at h1
+    have : L * (h : ℂ) = 0 := by linear_combination -h1
+    rcases mul_eq_zero.mp this with h0 | h0
+    · exact h0
+    · exact absurd (ofReal_eq_zero.mp h0) hh.ne'
+  set r : ℝ := Real.exp (-2 * π) with hr
+  have hr1 : r < 1 := by
+    rw [hr]
+    calc Real.exp (-2 * π) < Real.exp 0 := Real.exp_lt_exp.mpr (by nlinarith [Real.pi_pos])
+      _ = 1 := Real.exp_zero
+  have hΨcont : ContinuousOn Ψ (closedBall (0:ℂ) r) := by
+    intro q hq
+    have hq' : q ∈ ball (0:ℂ) 1 := by
+      rw [mem_ball_zero_iff]; rw [mem_closedBall_zero_iff] at hq; linarith
+    exact (hΨ q hq').continuousAt.continuousWithinAt
+  obtain ⟨M, hM⟩ := (isCompact_closedBall (0:ℂ) r).exists_bound_of_continuousOn hΨcont
+  rw [isBoundedAtImInfty_iff]
+  refine ⟨‖(↑h / (2 * π * Complex.I) : ℂ)‖ * M + ‖v I - G ↑I‖, h, fun τ hτ => ?_⟩
+  have hqr : 𝕢 h ↑τ ∈ closedBall (0:ℂ) r := by
+    rw [mem_closedBall_zero_iff, hnormq, hr]
+    apply Real.exp_le_exp.mpr
+    have him : 0 < τ.im := τ.im_pos
+    rw [neg_mul, neg_mul, neg_div, neg_le_neg_iff]
+    rw [le_div_iff₀ hh]
+    nlinarith [Real.pi_pos]
+  have hvτ : v τ = G ↑τ + (v I - G ↑I) := by
+    have := hconst τ
+    rw [hL0] at this
+    linear_combination this
+  rw [hvτ]
+  calc ‖G ↑τ + (v I - G ↑I)‖ ≤ ‖G ↑τ‖ + ‖v I - G ↑I‖ := norm_add_le _ _
+    _ ≤ ‖(↑h / (2 * π * Complex.I) : ℂ)‖ * M + ‖v I - G ↑I‖ := by
+        gcongr
+        simp only [hGdef]
+        rw [norm_mul]
+        gcongr
+        exact hM _ hqr
+
+end UpperHalfPlane.PrimBddAux
+
+open scoped Manifold in
+theorem solution {h : ℝ} (hh : 0 < h) {u v : UpperHalfPlane → ℂ}
+    (hu_per : Function.Periodic (u ∘ UpperHalfPlane.ofComplex) h)
+    (hu_hol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) u)
+    (hu_bdd : UpperHalfPlane.IsBoundedAtImInfty u)
+    (hv : ∀ τ : UpperHalfPlane, HasDerivAt (v ∘ UpperHalfPlane.ofComplex) (u τ) ↑τ)
+    (hv_per : Function.Periodic (v ∘ UpperHalfPlane.ofComplex) h) :
+    UpperHalfPlane.IsBoundedAtImInfty v :=
+  UpperHalfPlane.PrimBddAux.isBoundedAtImInfty_of_hasDerivAt_of_periodic hh hu_per hu_hol hu_bdd hv
+    hv_per
+
+end S_UpperHalfPlane_isBoundedAtImInfty_of_hasDerivAt_of_periodic
+end P2MW
+export P2MW.S_UpperHalfPlane_isBoundedAtImInfty_of_hasDerivAt_of_periodic (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Manifold
+theorem UpperHalfPlane.isBoundedAtImInfty_of_hasDerivAt_of_periodic {h : ℝ} (hh : 0 < h)
+    {u v : UpperHalfPlane → ℂ}
+    (hu_per : Function.Periodic (u ∘ UpperHalfPlane.ofComplex) h)
+    (hu_hol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) u)
+    (hu_bdd : UpperHalfPlane.IsBoundedAtImInfty u)
+    (hv : ∀ τ : UpperHalfPlane, HasDerivAt (v ∘ UpperHalfPlane.ofComplex) (u τ) ↑τ)
+    (hv_per : Function.Periodic (v ∘ UpperHalfPlane.ofComplex) h) :
+    UpperHalfPlane.IsBoundedAtImInfty v :=
+  solution hh hu_per hu_hol hu_bdd hv hv_per
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_linearIndependent_complex_of_qExpansion_coeff_mem.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_linearIndependent_complex_of_qExpansion_coeff_mem.lean
new file mode 100644
index 0000000000..3634c658e5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_linearIndependent_complex_of_qExpansion_coeff_mem.lean
@@ -0,0 +1,636 @@
+/-
+Based on Prove2Me node UpperHalfPlane.linearIndependent_complex_of_qExpansion_coeff_mem
+(86f7f158-b9cb-57fe-bb1f-df7bb12cab0e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 0bbedbd9-a16b-5467-8150-3c609ef94532
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import Mathlib.FieldTheory.IntermediateField.Basic
+
+import Mathlib.NumberTheory.ModularForms.EisensteinSeries.QExpansion
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+import Mathlib.Geometry.Manifold.Notation
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Linear independence over K descends from q-expansion coefficients to ℂ
+
+Theorem statement: `UpperHalfPlane.linearIndependent_complex_of_qExpansion_coeff_mem`
+(`86f7f158-b9cb-57fe-bb1f-df7bb12cab0e`), by Claude, 2026-09-05.
+
+Proof: submission `0bbedbd9-a16b-5467-8150-3c609ef94532`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a positive natural number, let $K$ be an intermediate field of $\mathbb{Q} \subseteq
+\mathbb{C}$, let $\iota$ be an arbitrary index type, and let $f : \iota \to (\mathfrak{H} \to
+\mathbb{C})$ be a family of complex-valued functions on the upper half-plane. Assume that for each
+index $i$ the function $f_i$ is holomorphic, in the sense of being differentiable as a map between
+complex manifolds modelled on $\mathbb{C}$, and that there exists an exponent $m \in \mathbb{N}$
+such that the product $f_i \cdot \Delta^m$, with $\Delta$ the discriminant modular form, satisfies
+the following three conditions: its extension to $\mathbb{C}$ by `UpperHalfPlane.ofComplex` is
+periodic with period $N$; it is bounded at $i\infty$; and every coefficient of its $q$-expansion of
+level $N$, i.e. its power series in $q_N = e^{2\pi i \tau / N}$, lies in $K$. Assume further that
+the family $f$ is linearly independent over $K$, as a family in the $K$-module of functions
+$\mathfrak{H} \to \mathbb{C}$. Then $f$ is linearly independent over $\mathbb{C}$.
+
+This is a coefficientwise base-change statement for $q$-expansions: $\mathbb{C}$ is free over $K$,
+so a $\mathbb{C}$-linear relation among families whose $q$-coefficient columns are $K$-valued is a
+$\mathbb{C}$-combination of $K$-linear relations, and injectivity of the $q$-expansion map on
+holomorphic, $N$-periodic, bounded functions transfers relations among coefficients back to
+relations among the functions. It is used in the $q$-expansion-principle arguments for cusp forms,
+in particular by
+[`CuspForm.exists_qCoeff_alSlash_heckeULinH_add_qCoeff_diamondLinH_eq_mul_of_mem_twoCuspLattice`]
+(thm.html#CuspForm.
+exists_qCoeff_alSlash_heckeULinH_add_qCoeff_diamondLinH_eq_mul_of_mem_twoCuspLattice),
+[`CuspForm.exists_ratCast_qCoeff_alSlash_of_forall_qCoeff_ratCast_gammaH`]
+(thm.html#CuspForm.exists_ratCast_qCoeff_alSlash_of_forall_qCoeff_ratCast_gammaH)
+and
+[`WLight.exists_monicRel_j_K_of_mdifferentiable_frickeQuotient`]
+(thm.html#WLight.exists_monicRel_j_K_of_mdifferentiable_frickeQuotient).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_UpperHalfPlane_linearIndependent_complex_of_qExpansion_coeff_mem.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_UpperHalfPlane_linearIndependent_complex_of_qExpansion_coeff_mem
+
+noncomputable section
+
+open Complex Real
+
+namespace WLight
+
+section RatCoeff
+
+p2m_open "UpperHalfPlane ModularForm SlashInvariantForm ModularFormClass CuspForm \
+  ModularForm.CuspForm EisensteinSeries"
+open scoped MatrixGroups ArithmeticFunction.sigma
+
+private lemma ratCoeff_mul {p q : PowerSeries ℂ}
+    (hp : ∀ n : ℕ, ∃ a : ℚ, p.coeff n = (a : ℂ)) (hq : ∀ n : ℕ, ∃ a : ℚ, q.coeff n = (a : ℂ)) :
+    ∀ n : ℕ, ∃ a : ℚ, (p * q).coeff n = (a : ℂ) := by
+  choose F hF using hp
+  choose G hG using hq
+  intro n
+  refine ⟨∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, F ij.1 * G ij.2, ?_⟩
+  rw [PowerSeries.coeff_mul]
+  push_cast
+  exact Finset.sum_congr rfl fun ij _ => by rw [hF, hG]
+
+private lemma ratCoeff_sub {p q : PowerSeries ℂ}
+    (hp : ∀ n : ℕ, ∃ a : ℚ, p.coeff n = (a : ℂ)) (hq : ∀ n : ℕ, ∃ a : ℚ, q.coeff n = (a : ℂ)) :
+    ∀ n : ℕ, ∃ a : ℚ, (p - q).coeff n = (a : ℂ) := by
+  intro n
+  obtain ⟨a, ha⟩ := hp n
+  obtain ⟨b, hb⟩ := hq n
+  exact ⟨a - b, by rw [map_sub, ha, hb]; push_cast; ring⟩
+
+private lemma ratCoeff_E {k : ℕ} (hk : 3 ≤ k) (hk2 : Even k) :
+    ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 (E hk)).coeff n = (q : ℂ) := by
+  intro n
+  rw [E_qExpansion_coeff hk hk2]
+  by_cases hn : n = 0
+  · exact ⟨1, by simp [hn]⟩
+  · refine ⟨-(2 * k / bernoulli k) * (σ (k - 1) n : ℚ), ?_⟩
+    rw [ite_eq_right hn]
+    push_cast
+    ring
+
+private def eCubeSubESq : ModularForm 𝒮ℒ 12 :=
+  ModularForm.mcast (by decide) (E₄.pow 3) - ModularForm.mcast (by decide) (E₆.pow 2)
+
+private lemma eCubeSubESq_qExpansion :
+    qExpansion 1 eCubeSubESq = qExpansion 1 E₄ * qExpansion 1 E₄ * qExpansion 1 E₄ -
+      qExpansion 1 E₆ * qExpansion 1 E₆ := by
+  simp only [eCubeSubESq, FunLike.coe_sub, ModularForm.coe_mcast,
+    ModularForm.qExpansion_sub one_pos one_mem_strictPeriods_SL,
+    ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+  ring
+
+private lemma discriminant_eq_smul_eCubeSubESq :
+    ModularForm.discriminant = (1 / 1728 : ℂ) • eCubeSubESq := by
+  ext z
+  have h := discriminant_eq_E₄_cube_sub_E₆_sq z
+  simp only [Pi.smul_apply, eCubeSubESq, FunLike.coe_sub, Pi.sub_apply,
+    ModularForm.coe_mcast, ModularForm.coe_pow, Pi.pow_apply, smul_eq_mul]
+  rw [h]
+  ring
+
+private lemma ratCoeff_discriminant :
+    ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 ModularForm.discriminant).coeff n = (q : ℂ) := by
+  have h4 : ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 E₄).coeff n = (q : ℂ) :=
+    ratCoeff_E (by norm_num) (by decide)
+  have h6 : ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 E₆).coeff n = (q : ℂ) :=
+    ratCoeff_E (by norm_num) (by decide)
+  have hmain := ratCoeff_sub (ratCoeff_mul (ratCoeff_mul h4 h4) h4) (ratCoeff_mul h6 h6)
+  intro n
+  obtain ⟨a, ha⟩ := hmain n
+  refine ⟨(1 / 1728 : ℚ) * a, ?_⟩
+  rw [discriminant_eq_smul_eCubeSubESq,
+    ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL,
+    PowerSeries.coeff_smul, eCubeSubESq_qExpansion, smul_eq_mul, ha]
+  push_cast
+  ring
+
+private lemma ratCoeff_pow {p : PowerSeries ℂ} (hp : ∀ n : ℕ, ∃ a : ℚ, p.coeff n = (a : ℂ)) (k : ℕ)
+    :
+    ∀ n : ℕ, ∃ a : ℚ, (p ^ k).coeff n = (a : ℂ) := by
+  induction k with
+  | zero =>
+    intro n
+    refine ⟨if n = 0 then 1 else 0, ?_⟩
+    rw [pow_zero, PowerSeries.coeff_one]
+    split <;> simp
+  | succ k ih =>
+    rw [pow_succ]
+    exact ratCoeff_mul ih hp
+
+end RatCoeff
+
+section DiscPow
+
+p2m_open "UpperHalfPlane ModularForm SlashInvariantForm ModularFormClass CuspForm \
+  ModularForm.CuspForm EisensteinSeries OnePoint Matrix.SpecialLinearGroup"
+
+open scoped MatrixGroups Manifold
+
+private def discPowForm (m : ℕ) : ModularForm 𝒮ℒ (12 * m) :=
+  ModularForm.mcast (by ring) ((CuspForm.toModularFormₗ CuspForm.discriminant).pow m)
+
+private lemma discPowForm_coe (m : ℕ) : ⇑(discPowForm m) = ⇑CuspForm.discriminant ^ m := by
+  funext z
+  simp [discPowForm, ModularForm.coe_mcast, ModularForm.coe_pow,
+    CuspForm.toModularFormₗ_apply]
+
+end DiscPow
+
+section Width
+
+open scoped UpperHalfPlane Manifold
+p2m_open "UpperHalfPlane~I"
+
+private lemma qParam_one_eq_pow {N : ℕ} (hN : N ≠ 0) (τ : ℂ) :
+    Function.Periodic.qParam 1 τ = Function.Periodic.qParam N τ ^ N := by
+  have : (N : ℂ) ≠ 0 := by exact_mod_cast hN
+  simp only [Function.Periodic.qParam, Complex.ofReal_one, div_one, Complex.ofReal_natCast]
+  rw [← Complex.exp_nat_mul]
+  congr 1
+  field_simp
+
+private theorem _root_.WLight.qExpansion_coeff_width (f : ℍ → ℂ) {N : ℕ} (hN : N ≠ 0)
+    (hper : Function.Periodic (f ∘ ofComplex) 1) (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f)
+    (hbd : IsBoundedAtImInfty f) (n : ℕ) :
+    (qExpansion N f).coeff n =
+      if N ∣ n then (qExpansion 1 f).coeff (n / N) else 0 := by
+  have hN' : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero hN
+  have hperN : Function.Periodic (f ∘ ofComplex) N := by
+    simpa using hper.nat_mul N
+  let f' : C(ℍ, ℂ) := ⟨f, hhol.continuous⟩
+  have hfan : AnalyticAt ℂ (cuspFunction N f') 0 :=
+    analyticAt_cuspFunction_zero hN' hperN hhol hbd
+  set c : ℕ → ℂ := fun n ↦ if N ∣ n then (qExpansion 1 f).coeff (n / N) else 0 with hc
+  have hf : ∀ τ : ℍ, HasSum (fun m ↦ c m • Function.Periodic.qParam N τ ^ m) (f' τ) := by
+    intro τ
+    have h1 := hasSum_qExpansion one_pos hper hhol hbd τ
+    have hinj : Function.Injective fun m : ℕ ↦ N * m := fun a b h ↦ by
+      simpa [Nat.mul_right_inj hN] using h
+    refine (hinj.hasSum_iff (f := fun m ↦ c m • Function.Periodic.qParam N τ ^ m) ?_).mp ?_
+    · intro x hx
+      have : ¬ N ∣ x := fun ⟨k, hk⟩ ↦ hx ⟨k, hk.symm⟩
+      simp [hc, this]
+    · refine h1.congr_fun fun m ↦ ?_
+      simp only [Function.comp_apply, hc, Nat.dvd_mul_right, ite_true,
+        Nat.mul_div_cancel_left _ (Nat.pos_of_ne_zero hN), qParam_one_eq_pow hN, ← pow_mul]
+  exact (qExpansion_coeff_unique f' hN' hfan hf n).symm
+
+p2m_export "WLight" "qExpansion_coeff_width"
+end Width
+
+section WidthMF
+
+open scoped UpperHalfPlane Manifold MatrixGroups
+p2m_open "UpperHalfPlane~I"
+open SlashInvariantFormClass ModularFormClass
+
+namespace ModularFormClass
+private theorem _root_.WLight.ModularFormClass.qExpansion_coeff_width {F : Type*} [FunLike F ℍ ℂ]
+    {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [ModularFormClass F Γ k] (f : F)
+    (h1 : (1 : ℝ) ∈ Γ.strictPeriods) {N : ℕ} (hN : N ≠ 0) (n : ℕ) :
+    (qExpansion N f).coeff n = if N ∣ n then (qExpansion 1 f).coeff (n / N) else 0 := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos h1⟩
+  exact WLight.qExpansion_coeff_width f hN (by simpa using periodic_comp_ofComplex f h1)
+    (ModularFormClass.holo f) (ModularFormClass.bdd_at_infty f) n
+
+end ModularFormClass
+p2m_export "WLight" "ModularFormClass.qExpansion_coeff_width"
+end WidthMF
+
+section BSix
+
+p2m_open "UpperHalfPlane ModularForm SlashInvariantForm \
+  P2MW.S_UpperHalfPlane_linearIndependent_complex_of_qExpansion_coeff_mem.WLight.ModularFormClass \
+  CuspForm ModularForm.CuspForm Polynomial Real.Polynomial Filter"
+open scoped MatrixGroups Manifold
+
+private lemma isBoundedAtImInfty_discriminant :
+    IsBoundedAtImInfty (⇑CuspForm.discriminant : ℍ → ℂ) :=
+  (CuspFormClass.zero_at_infty CuspForm.discriminant).boundedAtFilter
+
+private lemma isBoundedAtImInfty_discPow (n : ℕ) :
+    IsBoundedAtImInfty (⇑CuspForm.discriminant ^ n : ℍ → ℂ) := by
+  induction n with
+  | zero => exact pow_zero (⇑CuspForm.discriminant : ℍ → ℂ) ▸ const_boundedAtFilter _ (1 : ℂ)
+  | succ k ih =>
+    rw [pow_succ]
+    exact ih.mul isBoundedAtImInfty_discriminant
+
+private lemma IsBoundedAtImInfty.mul_discPow_mono {f : ℍ → ℂ} {m m' : ℕ} (hm : m ≤ m')
+    (h : IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m)) :
+    IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m') := by
+  have hshape : (f * ⇑CuspForm.discriminant ^ m' : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m) * ⇑CuspForm.discriminant ^ (m' - m) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply]
+    rw [mul_assoc, ← pow_add, Nat.add_sub_cancel' hm]
+  rw [hshape]
+  exact h.mul (isBoundedAtImInfty_discPow (m' - m))
+
+end BSix
+
+section KPoleSec
+
+p2m_open "UpperHalfPlane ModularForm \
+  P2MW.S_UpperHalfPlane_linearIndependent_complex_of_qExpansion_coeff_mem.WLight.ModularFormClass \
+  CuspForm ModularForm.CuspForm Polynomial Real.Polynomial Filter"
+open scoped MatrixGroups Manifold
+
+variable {N : ℕ}
+
+private lemma mem_of_rat (K : IntermediateField ℚ ℂ) {x : ℂ} (h : ∃ q : ℚ, x = (q : ℂ)) :
+    x ∈ K := by
+  obtain ⟨q, rfl⟩ := h
+  exact SubfieldClass.ratCast_mem K q
+
+private def KPoleAt (K : IntermediateField ℚ ℂ) (N m : ℕ) (f : ℍ → ℂ) : Prop :=
+  Function.Periodic ((f * ⇑CuspForm.discriminant ^ m) ∘ ofComplex) N ∧
+    IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m) ∧
+    ∀ n : ℕ, (qExpansion N (f * ⇑CuspForm.discriminant ^ m)).coeff n ∈ K
+
+private def KPole (K : IntermediateField ℚ ℂ) (N : ℕ) (f : ℍ → ℂ) : Prop :=
+  MDiff f ∧ ∃ m : ℕ, KPoleAt K N m f
+
+private lemma periodic_one_fn (c : ℝ) :
+    Function.Periodic ((1 : ℍ → ℂ) ∘ ofComplex) c := fun _ => rfl
+
+private lemma periodic_discPow_comp_ofComplex (k : ℕ) (N : ℕ) :
+    Function.Periodic ((⇑CuspForm.discriminant ^ k : ℍ → ℂ) ∘ ofComplex) N := by
+  have h1 : Function.Periodic (⇑CuspForm.discriminant ∘ ofComplex) 1 :=
+    SlashInvariantFormClass.periodic_comp_ofComplex CuspForm.discriminant
+      one_mem_strictPeriods_SL
+  have hk : Function.Periodic ((⇑CuspForm.discriminant ^ k : ℍ → ℂ) ∘ ofComplex) 1 := by
+    induction k with
+    | zero => exact periodic_one_fn 1
+    | succ k ih =>
+      intro x
+      have hx := (ih.mul h1) x
+      simp only [Function.comp_apply, Pi.mul_apply, Pi.pow_apply] at hx ⊢
+      rw [pow_succ, pow_succ]
+      exact hx
+  simpa using hk.nat_mul N
+
+private lemma mdiff_discPow (k : ℕ) : MDiff (⇑CuspForm.discriminant ^ k : ℍ → ℂ) := by
+  rw [← discPowForm_coe]
+  exact (discPowForm k).holo'
+
+private lemma mdiff_mul_discPow {f : ℍ → ℂ} (hf : MDiff f) (m : ℕ) :
+    MDiff (f * ⇑CuspForm.discriminant ^ m : ℍ → ℂ) :=
+  hf.mul (mdiff_discPow m)
+
+private lemma analyticAt_cuspFunction_zero_of [NeZero N] {g : ℍ → ℂ} (hhol : MDiff g)
+    (hper : Function.Periodic (g ∘ ofComplex) N) (hbd : IsBoundedAtImInfty g) :
+    AnalyticAt ℂ (cuspFunction N g) 0 :=
+  analyticAt_cuspFunction_zero
+    (by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)) hper hhol hbd
+
+private lemma qExpansion_one_discPowForm (k : ℕ) :
+    qExpansion 1 (discPowForm k) = (qExpansion 1 ModularForm.discriminant) ^ k := by
+  rw [discPowForm, ModularForm.qExpansion_mcast,
+    ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+  have hco : (⇑(CuspForm.toModularFormₗ CuspForm.discriminant) : ℍ → ℂ) =
+      ModularForm.discriminant := by
+    funext z
+    rw [CuspForm.toModularFormₗ_apply]
+    exact congrFun CuspForm.coe_discriminant z
+  rw [hco]
+
+private lemma qExpansion_discPow_coeff_mem (K : IntermediateField ℚ ℂ) [NeZero N] (k n : ℕ) :
+    (qExpansion N (⇑CuspForm.discriminant ^ k : ℍ → ℂ)).coeff n ∈ K := by
+  have h1 : qExpansion (N : ℝ) (⇑CuspForm.discriminant ^ k : ℍ → ℂ) =
+      qExpansion (N : ℝ) (discPowForm k) := by
+    rw [← discPowForm_coe]
+  rw [h1, ModularFormClass.qExpansion_coeff_width (discPowForm k)
+    one_mem_strictPeriods_SL (NeZero.ne N)]
+  split
+  · rw [qExpansion_one_discPowForm]
+    exact mem_of_rat K (ratCoeff_pow ratCoeff_discriminant k _)
+  · exact zero_mem _
+
+private lemma KPoleAt.pad {K : IntermediateField ℚ ℂ} [NeZero N] {f : ℍ → ℂ} {m m' : ℕ}
+    (hhol : MDiff f) (hm : m ≤ m') (h : KPoleAt K N m f) : KPoleAt K N m' f := by
+  obtain ⟨hper, hbd, hmem⟩ := h
+  have hshape : (f * ⇑CuspForm.discriminant ^ m' : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m) * ⇑CuspForm.discriminant ^ (m' - m) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply]
+    rw [mul_assoc, ← pow_add, Nat.add_sub_cancel' hm]
+  refine ⟨?_, ?_, ?_⟩
+  · rw [hshape]
+    exact hper.mul (periodic_discPow_comp_ofComplex (m' - m) N)
+  · exact IsBoundedAtImInfty.mul_discPow_mono hm hbd
+  · intro n
+    rw [hshape, qExpansion_mul
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hhol m) hper hbd)
+      (analyticAt_cuspFunction_zero_of (mdiff_discPow (m' - m))
+        (periodic_discPow_comp_ofComplex (m' - m) N) (isBoundedAtImInfty_discPow (m' - m))),
+      PowerSeries.coeff_mul]
+    exact sum_mem fun ij _ => mul_mem (hmem ij.1) (qExpansion_discPow_coeff_mem K _ ij.2)
+
+end KPoleSec
+
+section BEightEngine
+
+open Function
+
+private theorem linearIndependent_pi_algebraMap_of_field {k K σ ι : Type*}
+    [Field k] [CommRing K] [Nontrivial K] [Algebra k K]
+    {v : ι → σ → k} (hv : LinearIndependent k v) :
+    LinearIndependent K (fun i n ↦ algebraMap k K (v i n)) := by
+  classical
+  obtain ⟨⟨β, b⟩⟩ := Module.Free.exists_basis (R := k) (M := K)
+  rw [linearIndependent_iff'] at hv ⊢
+  intro s c hc i hi
+  have key : ∀ n : σ, (∑ j ∈ s, (v j n) • c j) = 0 := by
+    intro n
+    have := congrFun hc n
+    simp only [Finset.sum_apply, Pi.smul_apply, Pi.zero_apply, smul_eq_mul] at this
+    rw [← this]
+    refine Finset.sum_congr rfl fun j _ ↦ ?_
+    rw [Algebra.smul_def, mul_comm]
+  have key2 : ∀ (α : β) (n : σ), (∑ j ∈ s, (v j n) * (b.repr (c j) α)) = 0 := by
+    intro α n
+    have h1 := congrArg b.repr (key n)
+    rw [map_sum, map_zero] at h1
+    have h2 := congrFun (congrArg DFunLike.coe h1) α
+    simpa only [Finsupp.coe_finsetSum, Finset.sum_apply, map_smul, Finsupp.smul_apply,
+      smul_eq_mul, Finsupp.coe_zero, Pi.zero_apply] using h2
+  have key3 : ∀ (α : β) (j : ι), j ∈ s → b.repr (c j) α = 0 := by
+    intro α
+    refine hv s (fun j ↦ b.repr (c j) α) ?_
+    funext n
+    simp only [Finset.sum_apply, Pi.smul_apply, smul_eq_mul, Pi.zero_apply]
+    rw [← key2 α n]
+    exact Finset.sum_congr rfl fun j _ ↦ mul_comm _ _
+  have hzero : b.repr (c i) = 0 := Finsupp.ext fun α ↦ key3 α i hi
+  exact b.repr.injective (by rw [hzero, map_zero])
+
+end BEightEngine
+
+section BEightHelper
+
+open UpperHalfPlane Function Filter
+open scoped Manifold
+
+variable {N : ℕ}
+
+private lemma mdpb_finsetSum_smul [NeZero N] {ι : Type*}
+    (s : Finset ι) (c : ι → ℂ) {g : ι → ℍ → ℂ}
+    (hhol : ∀ i ∈ s, MDiff (g i)) (hper : ∀ i ∈ s, Periodic ((g i) ∘ ofComplex) N)
+    (hbd : ∀ i ∈ s, IsBoundedAtImInfty (g i)) :
+    MDiff (∑ j ∈ s, c j • g j) ∧ Periodic ((∑ j ∈ s, c j • g j) ∘ ofComplex) N
+      ∧ IsBoundedAtImInfty (∑ j ∈ s, c j • g j) := by
+  classical
+  induction s using Finset.cons_induction with
+  | empty =>
+    refine ⟨?_, fun _ ↦ rfl, const_boundedAtFilter _ 0⟩
+    have h__af := (mdifferentiable_const : MDiff (fun _ : ℍ ↦ (0 : ℂ)))
+    simp only [Finset.sum_empty] at h__af ⊢
+    exact h__af
+  | cons a t hat ih =>
+    have ⟨hh, hp, hb⟩ := ih (fun i hi ↦ hhol i (Finset.mem_cons_of_mem hi))
+      (fun i hi ↦ hper i (Finset.mem_cons_of_mem hi))
+      (fun i hi ↦ hbd i (Finset.mem_cons_of_mem hi))
+    have haS : a ∈ Finset.cons a t hat := Finset.mem_cons_self a t
+    simp only [Finset.sum_cons]
+    refine ⟨((hhol a haS).const_smul _).add hh, ?_, ((hbd a haS).smul (c a)).add hb⟩
+    intro z
+    have h1 := hper a haS z; have h2 := hp z
+    simp only [comp_apply] at h1 h2
+    simp only [comp_apply, Pi.add_apply, Pi.smul_apply, smul_eq_mul, h1, h2]
+
+private theorem qExpansion_finsetSum_smul [NeZero N] {ι : Type*} (s : Finset ι) (c : ι → ℂ)
+    {g : ι → ℍ → ℂ} (hhol : ∀ i ∈ s, MDiff (g i))
+    (hper : ∀ i ∈ s, Periodic ((g i) ∘ ofComplex) N) (hbd : ∀ i ∈ s, IsBoundedAtImInfty (g i)) :
+    qExpansion N (∑ j ∈ s, c j • g j) = ∑ j ∈ s, c j • qExpansion N (g j) := by
+  classical
+  induction s using Finset.cons_induction with
+  | empty => simpa using qExpansion_zero (N : ℝ)
+  | cons a t hat ih =>
+    have haS : a ∈ Finset.cons a t hat := Finset.mem_cons_self a t
+    have htS : ∀ i ∈ t, i ∈ Finset.cons a t hat := fun i hi ↦ Finset.mem_cons_of_mem hi
+    obtain ⟨hhS, hpS, hbS⟩ := mdpb_finsetSum_smul t c
+      (fun i hi ↦ hhol i (htS i hi)) (fun i hi ↦ hper i (htS i hi))
+      (fun i hi ↦ hbd i (htS i hi))
+    have hper_a : Periodic ((c a • g a) ∘ ofComplex) N := fun z ↦ by
+      have h1 := hper a haS z; simp only [comp_apply] at h1
+      simp only [comp_apply, Pi.smul_apply, smul_eq_mul, h1]
+    have han_a : AnalyticAt ℂ (cuspFunction N (c a • g a)) 0 :=
+      analyticAt_cuspFunction_zero_of ((hhol a haS).const_smul _) hper_a ((hbd a haS).smul (c a))
+    have han_t : AnalyticAt ℂ (cuspFunction N (∑ j ∈ t, c j • g j)) 0 :=
+      analyticAt_cuspFunction_zero_of hhS hpS hbS
+    rw [Finset.sum_cons, Finset.sum_cons, qExpansion_add han_a han_t,
+      qExpansion_smul (analyticAt_cuspFunction_zero_of (hhol a haS) (hper a haS) (hbd a haS)),
+      ih (fun i hi ↦ hhol i (htS i hi)) (fun i hi ↦ hper i (htS i hi))
+        (fun i hi ↦ hbd i (htS i hi))]
+
+end BEightHelper
+
+section QNonzero
+
+open scoped UpperHalfPlane Manifold MatrixGroups IntermediateField
+p2m_open "UpperHalfPlane~I"
+
+variable {N : ℕ} [NeZero N]
+
+private lemma exists_qExpansion_coeff_ne_zero {g : ℍ → ℂ} (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hper : Function.Periodic (g ∘ ofComplex) N) (hbd : IsBoundedAtImInfty g) (hg : g ≠ 0) :
+    ∃ n, (qExpansion N g).coeff n ≠ 0 := by
+  by_contra h
+  push Not at h
+  apply hg
+  funext τ
+  have hs := hasSum_qExpansion (by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)) hper hhol hbd τ
+  simp only [h, zero_smul] at hs
+  exact (hs.unique hasSum_zero)
+
+end QNonzero
+
+section BEightStageTwo
+
+open UpperHalfPlane Function Filter
+open scoped Manifold
+
+variable {N : ℕ}
+
+private lemma eq_zero_of_mul_discPow_eq_zero (M : ℕ) {h : ℍ → ℂ}
+    (h0 : h * (⇑CuspForm.discriminant ^ M : ℍ → ℂ) = 0) : h = 0 := by
+  funext τ
+  have := congrFun h0 τ
+  simp only [Pi.mul_apply, Pi.pow_apply, Pi.zero_apply] at this
+  refine (mul_eq_zero.mp this).resolve_right ?_
+  rw [congrFun CuspForm.coe_discriminant τ]
+  exact pow_ne_zero M (ModularForm.discriminant_ne_zero τ)
+
+private lemma finsetSum_smul_eq_zero_iff_qCoeff [NeZero N] {ι : Type*}
+    (s : Finset ι) (c : ι → ℂ) {f : ι → ℍ → ℂ} (M : ℕ)
+    (hhol : ∀ j ∈ s, MDiff (f j))
+    (hper : ∀ j ∈ s, Periodic ((f j * ⇑CuspForm.discriminant ^ M) ∘ ofComplex) N)
+    (hbd : ∀ j ∈ s, IsBoundedAtImInfty (f j * ⇑CuspForm.discriminant ^ M)) :
+    (∑ j ∈ s, c j • f j = 0)
+      ↔ ∀ n, ∑ j ∈ s, c j * (qExpansion N (f j * ⇑CuspForm.discriminant ^ M)).coeff n = 0 := by
+  set g : ι → ℍ → ℂ := fun j ↦ f j * ⇑CuspForm.discriminant ^ M with hg_def
+  have hghol : ∀ j ∈ s, MDiff (g j) := fun j hj ↦ mdiff_mul_discPow (hhol j hj) M
+  have hpull : ∑ j ∈ s, c j • g j = (∑ j ∈ s, c j • f j) * ⇑CuspForm.discriminant ^ M := by
+    rw [Finset.sum_mul]
+    exact Finset.sum_congr rfl fun j _ ↦ (smul_mul_assoc (c j) (f j) _).symm
+  have hq := qExpansion_finsetSum_smul s c hghol hper hbd
+  constructor
+  · intro h0 n
+    rw [hpull, h0, zero_mul, qExpansion_zero (N : ℝ)] at hq
+    have := congrArg (fun p : PowerSeries ℂ ↦ p.coeff n) hq.symm
+    simpa only [map_sum, PowerSeries.coeff_smul, smul_eq_mul, map_zero] using this
+  · intro h0
+    have hqeq : qExpansion N (∑ j ∈ s, c j • g j) = 0 := by
+      rw [hq]; ext n
+      simpa only [map_sum, PowerSeries.coeff_smul, smul_eq_mul, map_zero] using h0 n
+    obtain ⟨hh, hp, hb⟩ := mdpb_finsetSum_smul s c hghol hper hbd
+    apply eq_zero_of_mul_discPow_eq_zero M
+    rw [← hpull]
+    by_contra hne
+    obtain ⟨n, hn⟩ := exists_qExpansion_coeff_ne_zero hh hp hb hne
+    rw [hqeq] at hn; simp at hn
+
+private theorem linearIndependent_complex_of_kPole [NeZero N] (K : IntermediateField ℚ ℂ)
+    {ι : Type*} {f : ι → ℍ → ℂ} (hKP : ∀ i, KPole K N (f i))
+    (hli : LinearIndependent ↥K f) : LinearIndependent ℂ f := by
+  classical
+  rw [linearIndependent_iff']
+  intro s c hc i hi
+  set m : ι → ℕ := fun j ↦ (hKP j).2.choose
+  set M : ℕ := s.sup m
+  have hKPM : ∀ j ∈ s, KPoleAt K N M (f j) := fun j hj ↦
+    KPoleAt.pad (hKP j).1 (Finset.le_sup hj) (hKP j).2.choose_spec
+  have hhol : ∀ (j : s), MDiff (f j) := fun j ↦ (hKP j).1
+  have hper : ∀ (j : s), Periodic ((f j * ⇑CuspForm.discriminant ^ M) ∘ ofComplex) N :=
+    fun j ↦ (hKPM j j.2).1
+  have hbd : ∀ (j : s), IsBoundedAtImInfty (f j * ⇑CuspForm.discriminant ^ M) :=
+    fun j ↦ (hKPM j j.2).2.1
+  have hiff : ∀ (t : Finset s) (c' : s → ℂ),
+      (∑ j ∈ t, c' j • f j = 0)
+        ↔ ∀ n, ∑ j ∈ t, c' j * (qExpansion N (f j * ⇑CuspForm.discriminant ^ M)).coeff n = 0 :=
+    fun t c' ↦ finsetSum_smul_eq_zero_iff_qCoeff t c' M (fun j _ ↦ hhol j)
+      (fun j _ ↦ hper j) (fun j _ ↦ hbd j)
+  set vK : s → ℕ → ↥K := fun j n ↦
+    ⟨(qExpansion N (f j * ⇑CuspForm.discriminant ^ M)).coeff n, (hKPM j j.2).2.2 n⟩ with hvK_def
+  have halg : ∀ x : ↥K, (x : ℂ) = algebraMap ↥K ℂ x := fun _ ↦ rfl
+  have hvKcoe : ∀ (j : s) n, algebraMap ↥K ℂ (vK j n)
+      = (qExpansion N (f j * ⇑CuspForm.discriminant ^ M)).coeff n := fun _ _ ↦ rfl
+  have hli_s := hli.comp (Subtype.val : s → ι) Subtype.val_injective
+  have hvKli : LinearIndependent ↥K vK := by
+    rw [linearIndependent_iff']
+    intro t d hd j hj
+    have hcoeff : ∀ n, ∑ j' ∈ t, (d j' : ℂ)
+        * (qExpansion N (f j' * ⇑CuspForm.discriminant ^ M)).coeff n = 0 := by
+      intro n
+      have h1 := congrFun hd n
+      simp only [Finset.sum_apply, Pi.smul_apply, Pi.zero_apply, smul_eq_mul] at h1
+      have h2 := congrArg (fun x : ↥K ↦ (x : ℂ)) h1
+      simp only [AddSubmonoidClass.coe_finsetSum, MulMemClass.coe_mul,
+        ZeroMemClass.coe_zero] at h2
+      simp only [halg, hvKcoe] at h2; exact h2
+    have hsumC : ∑ j' ∈ t, (d j' : ℂ) • f j' = 0 :=
+      (hiff t (fun j' ↦ (d j' : ℂ))).mpr hcoeff
+    have hsumK : ∑ j' ∈ t, d j' • (fun j'' : s ↦ f j'') j' = 0 := by
+      rw [← hsumC]
+      exact Finset.sum_congr rfl fun j' _ ↦ (algebraMap_smul ℂ (d j') (f j')).symm
+    exact linearIndependent_iff'.mp hli_s t d hsumK j hj
+  have hvCli := linearIndependent_pi_algebraMap_of_field (K := ℂ) hvKli
+  have hcoeff' : ∀ n, ∑ j' ∈ (Finset.univ : Finset s), c j'
+      * (qExpansion N (f j' * ⇑CuspForm.discriminant ^ M)).coeff n = 0 := by
+    intro n
+    have := (hiff Finset.univ (fun j' ↦ c j')).mp ?_ n
+    · exact this
+    · rw [Finset.sum_coe_sort s (fun j' ↦ c j' • f j')]; exact hc
+  have hsum0 : ∑ j' ∈ (Finset.univ : Finset s), (fun j'' : s ↦ c j''.1) j'
+      • (fun n ↦ (algebraMap ↥K ℂ) (vK j' n)) = 0 := by
+    funext n
+    simp only [Finset.sum_apply, Pi.smul_apply, smul_eq_mul, Pi.zero_apply, hvKcoe]
+    exact hcoeff' n
+  exact linearIndependent_iff'.mp hvCli Finset.univ (fun j'' ↦ c j''.1) hsum0 ⟨i, hi⟩
+    (Finset.mem_univ _)
+
+end BEightStageTwo
+
+end WLight
+
+open scoped Manifold in
+theorem solution (N : ℕ) [NeZero N]
+    (K : IntermediateField ℚ ℂ) {ι : Type*} (f : ι → UpperHalfPlane → ℂ)
+    (hf : ∀ i, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (f i) ∧ ∃ m : ℕ,
+      Function.Periodic ((f i * ModularForm.discriminant ^ m) ∘ UpperHalfPlane.ofComplex) N ∧
+      UpperHalfPlane.IsBoundedAtImInfty (f i * ModularForm.discriminant ^ m) ∧
+      ∀ n : ℕ, (UpperHalfPlane.qExpansion N (f i * ModularForm.discriminant ^ m)).coeff n ∈ K)
+    (hli : LinearIndependent ↥K f) : LinearIndependent ℂ f :=
+  WLight.linearIndependent_complex_of_kPole K
+    (fun i => ⟨(hf i).1, by
+      obtain ⟨m, hm⟩ := (hf i).2
+      exact ⟨m, by simpa only [WLight.KPoleAt, CuspForm.coe_discriminant] using hm⟩⟩) hli
+
+end
+
+end S_UpperHalfPlane_linearIndependent_complex_of_qExpansion_coeff_mem
+end P2MW
+export P2MW.S_UpperHalfPlane_linearIndependent_complex_of_qExpansion_coeff_mem (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Manifold
+theorem UpperHalfPlane.linearIndependent_complex_of_qExpansion_coeff_mem (N : ℕ) [NeZero N]
+    (K : IntermediateField ℚ ℂ) {ι : Type*} (f : ι → UpperHalfPlane → ℂ)
+    (hf : ∀ i, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (f i) ∧ ∃ m : ℕ,
+      Function.Periodic ((f i * ModularForm.discriminant ^ m) ∘ UpperHalfPlane.ofComplex) N ∧
+      UpperHalfPlane.IsBoundedAtImInfty (f i * ModularForm.discriminant ^ m) ∧
+      ∀ n : ℕ, (UpperHalfPlane.qExpansion N (f i * ModularForm.discriminant ^ m)).coeff n ∈ K)
+    (hli : LinearIndependent ↥K f) : LinearIndependent ℂ f :=
+  solution N K f hf hli
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_qCoeff_comp_heckeDiagMatrix_smul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_qCoeff_comp_heckeDiagMatrix_smul.lean
new file mode 100644
index 0000000000..9fbc01350c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_qCoeff_comp_heckeDiagMatrix_smul.lean
@@ -0,0 +1,199 @@
+/-
+Based on Prove2Me node UpperHalfPlane.qCoeff_comp_heckeDiagMatrix_smul
+(9cbe736c-cda2-5e3a-b708-dbc4e42582e4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 276b173c-b4da-596b-b834-943f491bcf70
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# q-expansion of f(dτ): coefficients shifted by d
+
+Theorem statement: `UpperHalfPlane.qCoeff_comp_heckeDiagMatrix_smul`
+(`9cbe736c-cda2-5e3a-b708-dbc4e42582e4`), by Claude, 2026-09-05.
+
+Proof: submission `276b173c-b4da-596b-b834-943f491bcf70`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $f : \mathbb{H} \to \mathbb{C}$ be a function on the upper half-plane subject to three
+hypotheses: the composite of `UpperHalfPlane.ofComplex` with $f$ is periodic with period $1$ as a
+function on $\mathbb{C}$; $f$ is holomorphic, in the sense of being `MDifferentiable` for the
+standard model with corners of $\mathbb{C}$ over itself on both source and target; and $f$ is
+bounded at $i\infty$ (`UpperHalfPlane.IsBoundedAtImInfty`). Let $d$ be a natural number with $d \neq
+0$ and let $n$ be a natural number. Here [`ModularForm.heckeDiagMatrix
+d`](def/ModularForm_HeckeOperator.html#L21) is, for $d \neq 0$, the element of
+$\mathrm{GL}_2(\mathbb{R})$ given by the upper triangular matrix $\begin{pmatrix} d & 0 \\ 0 &
+1\end{pmatrix}$ (and $1$ when $d = 0$), so that its action on $\mathbb{H}$ sends $\tau$ to $d\tau$;
+and [`ModularFormClass.qCoeff g n`](def/FLTPrelim_Modularity.html#L19) denotes the $n$-th
+coefficient of the $q$-expansion of $g$ taken with respect to the period $1$. The assertion is that
+the $n$-th such coefficient of $\tau \mapsto f(\mathrm{heckeDiagMatrix}\, d \cdot \tau)$ equals the
+$(n/d)$-th coefficient of $f$ when $d \mid n$, and $0$ otherwise.
+
+This is the coefficient formula for the degeneracy (oldform) operator $V_d : \sum_n a_n q^n \mapsto
+\sum_n a_n q^{dn}$, stated for bare functions on $\mathbb{H}$ rather than for elements of a space of
+modular forms, so that it applies before any slash-invariance is recorded. It is used throughout the
+level-lowering and oldform bookkeeping, for instance in the analysis of eigenforms under the
+operators $U_\ell$ and the degeneracy maps between levels.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_UpperHalfPlane_qCoeff_comp_heckeDiagMatrix_smul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_UpperHalfPlane_qCoeff_comp_heckeDiagMatrix_smul
+
+p2m_open "Complex Filter Function UpperHalfPlane \
+  P2MW.S_UpperHalfPlane_qCoeff_comp_heckeDiagMatrix_smul.UpperHalfPlane ModularForm"
+open scoped Real MatrixGroups Topology Manifold ModularForm
+
+noncomputable section
+
+namespace UpperHalfPlane
+p2m_export "UpperHalfPlane" "cuspFunction qExpansion ofComplex_apply_of_im_pos \
+  analyticAt_cuspFunction_zero atImInfty ofComplex_apply_of_im_nonpos hasSum_qExpansion \
+  qExpansion_coeff_unique im_smul_eq_div_normSq re IsBoundedAtImInfty im ofComplex"
+namespace DegeneracyQExp
+p2m_open "UpperHalfPlane"
+
+private def FnLike : Type := ℍ → ℂ
+
+private scoped instance : FunLike FnLike ℍ ℂ where
+  coe f := f
+  coe_injective _ _ h := h
+
+variable {d : ℕ}
+
+theorem heckeDiagMatrix_smul_ofComplex (hd : d ≠ 0) {z : ℂ} (hz : 0 < z.im) :
+    heckeDiagMatrix d • ofComplex z = ofComplex ((d : ℂ) * z) := by
+  have hz' : 0 < ((d : ℂ) * z).im := by
+    rw [show ((d : ℂ) * z).im = d * z.im by simp]
+    have : (0 : ℝ) < d := by exact_mod_cast Nat.pos_of_ne_zero hd
+    positivity
+  apply UpperHalfPlane.ext
+  rw [coe_heckeDiagMatrix_smul hd, ofComplex_apply_of_im_pos hz, ofComplex_apply_of_im_pos hz']
+
+theorem periodic_comp_smul (hd : d ≠ 0) {F : ℍ → ℂ} (hper : Periodic (F ∘ ofComplex) 1) :
+    Periodic ((fun τ ↦ F (heckeDiagMatrix d • τ)) ∘ ofComplex) 1 := by
+  intro w
+  by_cases hw : 0 < w.im
+  · have hw1 : 0 < (w + 1).im := by simpa using hw
+    simp only [comp_apply]
+    rw [heckeDiagMatrix_smul_ofComplex hd hw1, heckeDiagMatrix_smul_ofComplex hd hw, mul_add,
+      mul_one]
+    have h := hper.nat_mul d ((d : ℂ) * w)
+    simpa using h
+  · push Not at hw
+    have hw1 : (w + 1).im ≤ 0 := by simpa using hw
+    simp only [comp_apply, ofComplex_apply_of_im_nonpos hw, ofComplex_apply_of_im_nonpos hw1]
+
+theorem mdifferentiable_comp_smul (hd : d ≠ 0) {F : ℍ → ℂ} (hhol : MDiff F) :
+    MDiff (fun τ ↦ F (heckeDiagMatrix d • τ)) := by
+  have hd' : (d : ℂ) ≠ 0 := by exact_mod_cast hd
+  have h := (hhol.slash 0 (heckeDiagMatrix d)).const_smul (d : ℂ)
+  convert h using 1
+  funext τ
+  rw [Pi.smul_apply, slash_heckeDiagMatrix_apply 0 hd, smul_eq_mul, zero_sub, zpow_neg_one,
+    ← mul_assoc, mul_inv_cancel₀ hd', one_mul]
+
+theorem isBoundedAtImInfty_comp_smul (hd : d ≠ 0) {F : ℍ → ℂ} (hbdd : IsBoundedAtImInfty F) :
+    IsBoundedAtImInfty (fun τ ↦ F (heckeDiagMatrix d • τ)) := by
+  refine hbdd.comp_tendsto ?_
+  rw [atImInfty, tendsto_comap_iff]
+  have him : (UpperHalfPlane.im ∘ fun τ : ℍ ↦ heckeDiagMatrix d • τ) = fun τ ↦ (d : ℝ) * τ.im := by
+    funext τ
+    simp only [comp_apply]
+    rw [UpperHalfPlane.im_smul_eq_div_normSq, denom_heckeDiagMatrix hd, det_heckeDiagMatrix hd]
+    simp
+  rw [him]
+  have hd0 : (0 : ℝ) < d := by exact_mod_cast Nat.pos_of_ne_zero hd
+  exact tendsto_comap.const_mul_atTop hd0
+
+theorem qCoeff_comp_smul {F : ℍ → ℂ} (hper : Periodic (F ∘ ofComplex) 1) (hhol : MDiff F)
+    (hbdd : IsBoundedAtImInfty F) (hd : d ≠ 0) (n : ℕ) :
+    ModularFormClass.qCoeff (fun τ ↦ F (heckeDiagMatrix d • τ)) n =
+      if d ∣ n then ModularFormClass.qCoeff F (n / d) else 0 := by
+  set G : ℍ → ℂ := fun τ ↦ F (heckeDiagMatrix d • τ) with hG
+  have han : AnalyticAt ℂ (cuspFunction 1 G) 0 :=
+    analyticAt_cuspFunction_zero one_pos (periodic_comp_smul hd hper) (mdifferentiable_comp_smul hd
+      hhol)
+      (isBoundedAtImInfty_comp_smul hd hbdd)
+  set c : ℕ → ℂ := fun n ↦ if d ∣ n then (qExpansion 1 F).coeff (n / d) else 0 with hc
+  have hsum : ∀ τ : ℍ, HasSum (fun m ↦ c m • Periodic.qParam 1 τ ^ m) (G τ) := by
+    intro τ
+    have hq : Periodic.qParam 1 ((heckeDiagMatrix d • τ : ℍ) : ℂ) = Periodic.qParam 1 τ ^ d := by
+      simp only [Periodic.qParam, ← Complex.exp_nat_mul, coe_heckeDiagMatrix_smul hd]
+      congr 1
+      push_cast
+      ring
+    have hs := hasSum_qExpansion one_pos hper hhol hbdd (heckeDiagMatrix d • τ)
+    simp_rw [hq, ← pow_mul] at hs
+    have hinj : Injective (fun m : ℕ ↦ d * m) := mul_right_injective₀ hd
+    have hsupp : ∀ x ∉ Set.range (fun m : ℕ ↦ d * m),
+        (fun m ↦ c m • Periodic.qParam 1 τ ^ m) x = 0 := by
+      intro x hx
+      have : ¬ d ∣ x := by
+        rintro ⟨e, rfl⟩
+        exact hx ⟨e, rfl⟩
+      simp [hc, this]
+    refine (hinj.hasSum_iff hsupp).mp ?_
+    convert hs using 1
+    ext m
+    simp [hc, Nat.mul_div_cancel_left _ (Nat.pos_of_ne_zero hd)]
+  have key := qExpansion_coeff_unique (F := FnLike) (show FnLike from G) one_pos han hsum n
+  change (qExpansion 1 G).coeff n = if d ∣ n then (qExpansion 1 F).coeff (n / d) else 0
+  exact key.symm
+
+theorem qCoeff_comp_smul_of_modularFormClass {FF : Type*} [FunLike FF ℍ ℂ]
+    {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [ModularFormClass FF Γ k] (f : FF)
+    (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) (hd : d ≠ 0) (n : ℕ) :
+    ModularFormClass.qCoeff (fun τ ↦ f (heckeDiagMatrix d • τ)) n =
+      if d ∣ n then ModularFormClass.qCoeff f (n / d) else 0 :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  qCoeff_comp_smul (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (ModularFormClass.holo f)
+    (ModularFormClass.bdd_at_infty f) hd n
+
+end UpperHalfPlane.DegeneracyQExp
+end
+
+theorem solution {f : UpperHalfPlane → ℂ}
+    (hper : Function.Periodic (f ∘ UpperHalfPlane.ofComplex) 1)
+    (hhol : MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) f)
+    (hbdd : UpperHalfPlane.IsBoundedAtImInfty f) {d : ℕ} (hd : d ≠ 0) (n : ℕ) :
+    ModularFormClass.qCoeff (fun τ ↦ f (ModularForm.heckeDiagMatrix d • τ)) n = if d ∣ n then
+      ModularFormClass.qCoeff f (n / d) else 0 :=
+  UpperHalfPlane.DegeneracyQExp.qCoeff_comp_smul hper hhol hbdd hd n
+
+end S_UpperHalfPlane_qCoeff_comp_heckeDiagMatrix_smul
+end P2MW
+export P2MW.S_UpperHalfPlane_qCoeff_comp_heckeDiagMatrix_smul (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem UpperHalfPlane.qCoeff_comp_heckeDiagMatrix_smul {f : UpperHalfPlane → ℂ}
+    (hper : Function.Periodic (f ∘ UpperHalfPlane.ofComplex) 1)
+    (hhol : MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) f)
+    (hbdd : UpperHalfPlane.IsBoundedAtImInfty f) {d : ℕ} (hd : d ≠ 0) (n : ℕ) :
+    ModularFormClass.qCoeff (fun τ ↦ f (ModularForm.heckeDiagMatrix d • τ)) n = if d ∣ n then
+      ModularFormClass.qCoeff f (n / d) else 0 :=
+  solution hper hhol hbdd hd n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_qCoeff_heckeT.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_qCoeff_heckeT.lean
new file mode 100644
index 0000000000..157b15d086
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_qCoeff_heckeT.lean
@@ -0,0 +1,417 @@
+/-
+Based on Prove2Me node UpperHalfPlane.qCoeff_heckeT
+(601074a8-3bec-5792-9972-247fd53f3cad) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d81a5c6f-3ff3-5dc4-8b57-70572110d24b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.CStarAlgebra.Classes
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# q-expansion coefficients of Tₚ f
+
+Theorem statement: `UpperHalfPlane.qCoeff_heckeT` (`601074a8-3bec-5792-9972-247fd53f3cad`), by
+Claude, 2026-09-05.
+
+Proof: submission `d81a5c6f-3ff3-5dc4-8b57-70572110d24b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $f:\mathbb{H}\to\mathbb{C}$ be a function on the upper half plane subject to the three
+hypotheses under which Mathlib's $q$-expansion machinery applies: the composite of $f$ with
+`UpperHalfPlane.ofComplex` is periodic of period $1$, $f$ is holomorphic (complex differentiable in
+the manifold sense, for the standard model with corners on $\mathbb{C}$), and $f$ is bounded at
+$i\infty$. Let $k\in\mathbb{Z}$ be a weight, $p$ a natural number with $p\neq 0$, and $n$ a natural
+number. Write $a_m=$ [`ModularFormClass.qCoeff f m`](def/FLTPrelim_Modularity.html#L19) for the
+$m$-th coefficient of the $q$-expansion of $f$ of width $1$, i.e. the coefficient of the power
+series `qExpansion 1 f`. The assertion is that the $n$-th such coefficient of the function
+$$\mathrm{heckeT}\,k\,p\,f=\sum_{j<p} f\mid_k \mathrm{heckeMatrix}\,p\,j \;+\; f\mid_k
+\mathrm{heckeDiagMatrix}\,p,$$ where $\mathrm{heckeDiagMatrix}\,p$ is the invertible real matrix
+$\begin{pmatrix}p&0\\0&1\end{pmatrix}$ for $p\neq 0$ and $\mid_k$ is the weight-$k$ slash action,
+equals $$a_{np}+\begin{cases}p^{\,k-1}a_{n/p}&\text{if }p\mid n,\\0&\text{otherwise,}\end{cases}$$
+which is the value at $n$ of [`ModularForm.coeffHeckeT k
+p`](def/ModularForm_HeckeOperator.html#L162) applied to the coefficient sequence of $f$. No
+modularity or level is assumed of $f$.
+
+This is the classical formula for the effect of the Hecke operator $T_p$ on $q$-expansions, here for
+arbitrary $1$-periodic holomorphic functions bounded at $i\infty$ rather than only for modular
+forms, so that it applies to iterates and to intermediate functions for which modularity is not yet
+known. It is used by
+[`ModularFormClass.heckeT_eq_smul_iff`](thm.html#ModularFormClass.heckeT_eq_smul_iff) and by the
+lemmas identifying the $q$-coefficients of eigenforms for `heckeU` together with the diagonal slash
+term.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_UpperHalfPlane_qCoeff_heckeT.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_UpperHalfPlane_qCoeff_heckeT
+
+noncomputable section
+
+open Complex Function Filter
+p2m_open "UpperHalfPlane~I"
+open scoped Real MatrixGroups ModularForm Manifold Topology
+
+namespace M4cP1W2
+
+open ModularForm ModularFormClass
+
+section Matrices
+
+variable (p j : ℕ)
+
+theorem heckeMatrix_one_zero :
+    ((heckeMatrix p j : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) 1 0 = 0 := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  · rw [val_heckeMatrix hp]; rfl
+
+theorem heckeDiagMatrix_one_zero :
+    ((heckeDiagMatrix p : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) 1 0 = 0 := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  · rw [val_heckeDiagMatrix hp]; rfl
+
+end Matrices
+
+section Regularity
+
+variable {f : ℍ → ℂ} (k : ℤ) (p : ℕ)
+
+theorem mdifferentiable_heckeU (hf : MDiff f) : MDiff (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => MDiff g) (fun _ _ ha hb => ha.add hb)
+    mdifferentiable_const (fun _ _ => hf.slash k _)
+
+theorem mdifferentiable_heckeT (hf : MDiff f) : MDiff (heckeT k p f) :=
+  (mdifferentiable_heckeU k p hf).add (hf.slash k _)
+
+theorem isBoundedAtImInfty_heckeU (hf : IsBoundedAtImInfty f) :
+    IsBoundedAtImInfty (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => IsBoundedAtImInfty g)
+    (fun _ _ ha hb => ha.add hb) UpperHalfPlane.zero_form_isBoundedAtImInfty
+    (fun j _ => hf.slash k (heckeMatrix_one_zero p j))
+
+theorem isBoundedAtImInfty_heckeT (hf : IsBoundedAtImInfty f) :
+    IsBoundedAtImInfty (heckeT k p f) :=
+  (isBoundedAtImInfty_heckeU k p hf).add (hf.slash k (heckeDiagMatrix_one_zero p))
+
+theorem isZeroAtImInfty_heckeU (hf : IsZeroAtImInfty f) :
+    IsZeroAtImInfty (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => IsZeroAtImInfty g)
+    (fun _ _ ha hb => ha.add hb) (zero_zeroAtFilter atImInfty)
+    (fun j _ => hf.slash k (heckeMatrix_one_zero p j))
+
+theorem isZeroAtImInfty_heckeT (hf : IsZeroAtImInfty f) :
+    IsZeroAtImInfty (heckeT k p f) :=
+  (isZeroAtImInfty_heckeU k p hf).add (hf.slash k (heckeDiagMatrix_one_zero p))
+
+theorem apply_eq_of_coe_eq_add_nat (hf : Periodic (f ∘ ofComplex) 1) {τ₁ τ₂ : ℍ} (m : ℕ)
+    (h : (τ₁ : ℂ) = τ₂ + m) : f τ₁ = f τ₂ := by
+  have h1 : (f ∘ ofComplex) ((τ₂ : ℂ) + m) = (f ∘ ofComplex) (τ₂ : ℂ) := by
+    have := hf.nat_mul m
+    rw [mul_one] at this
+    exact this (τ₂ : ℂ)
+  simp only [comp_apply] at h1
+  rw [← h, ofComplex_apply, ofComplex_apply] at h1
+  exact h1
+
+variable {p} in
+theorem heckeMatrix_smul_vadd (hp : p ≠ 0) (j : ℕ) (τ : ℍ) :
+    heckeMatrix p j • ((1 : ℝ) +ᵥ τ) = heckeMatrix p (j + 1) • τ := by
+  apply UpperHalfPlane.ext
+  rw [coe_heckeMatrix_smul hp, coe_heckeMatrix_smul hp, coe_vadd]
+  push_cast
+  ring
+
+variable {p} in
+theorem coe_heckeMatrix_smul_self (hp : p ≠ 0) (τ : ℍ) :
+    ((heckeMatrix p p • τ : ℍ) : ℂ) = (heckeMatrix p 0 • τ : ℍ) + (1 : ℕ) := by
+  have hp' : (p : ℂ) ≠ 0 := by exact_mod_cast hp
+  rw [coe_heckeMatrix_smul hp, coe_heckeMatrix_smul hp]
+  field_simp
+  push_cast
+  ring
+
+variable {p} in
+theorem coe_heckeDiagMatrix_smul_vadd (hp : p ≠ 0) (τ : ℍ) :
+    ((heckeDiagMatrix p • ((1 : ℝ) +ᵥ τ) : ℍ) : ℂ) = (heckeDiagMatrix p • τ : ℍ) + (p : ℕ) := by
+  rw [coe_heckeDiagMatrix_smul hp, coe_heckeDiagMatrix_smul hp, coe_vadd]
+  push_cast
+  ring
+
+variable {p} in
+theorem sum_heckeMatrix_smul_vadd (hp : p ≠ 0) (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    ∑ j ∈ Finset.range p, f (heckeMatrix p j • ((1 : ℝ) +ᵥ τ))
+      = ∑ j ∈ Finset.range p, f (heckeMatrix p j • τ) := by
+  simp only [heckeMatrix_smul_vadd hp]
+  have h0 := Finset.sum_range_succ' (fun j => f (heckeMatrix p j • τ)) p
+  have h1 := Finset.sum_range_succ (fun j => f (heckeMatrix p j • τ)) p
+  rw [apply_eq_of_coe_eq_add_nat hf 1 (coe_heckeMatrix_smul_self hp τ)] at h1
+  exact add_right_cancel (h0.symm.trans h1)
+
+theorem heckeU_vadd (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    heckeU k p f ((1 : ℝ) +ᵥ τ) = heckeU k p f τ := by
+  by_cases hp : p = 0
+  · simp only [hp, heckeU_zero_left, Pi.zero_apply]
+  · rw [heckeU_apply k hp, heckeU_apply k hp, sum_heckeMatrix_smul_vadd hp hf]
+
+theorem heckeT_vadd (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    heckeT k p f ((1 : ℝ) +ᵥ τ) = heckeT k p f τ := by
+  by_cases hp : p = 0
+  · simp only [hp, heckeT_zero_left]
+    exact apply_eq_of_coe_eq_add_nat hf 1 (by rw [coe_vadd]; push_cast; ring)
+  · rw [heckeT_apply k hp, heckeT_apply k hp, sum_heckeMatrix_smul_vadd hp hf,
+      apply_eq_of_coe_eq_add_nat hf p (coe_heckeDiagMatrix_smul_vadd hp τ)]
+
+theorem periodic_comp_ofComplex_of_vadd {g : ℍ → ℂ} (hg : ∀ τ : ℍ, g ((1 : ℝ) +ᵥ τ) = g τ) :
+    Periodic (g ∘ ofComplex) 1 := by
+  intro w
+  by_cases hw : 0 < im w
+  · have hw' : 0 < im (w + 1) := by simp [hw]
+    simp only [comp_apply, ofComplex_apply_of_im_pos hw', ofComplex_apply_of_im_pos hw]
+    convert hg ⟨w, hw⟩ using 2
+    apply UpperHalfPlane.ext
+    simp [add_comm]
+  · have hw1 : im (w + 1) ≤ 0 := by simpa using hw
+    have hw0 : im w ≤ 0 := not_lt.mp hw
+    simp only [comp_apply, ofComplex_apply_eq_of_im_nonpos hw1 hw0]
+
+theorem periodic_heckeU_comp_ofComplex (hf : Periodic (f ∘ ofComplex) 1) :
+    Periodic (heckeU k p f ∘ ofComplex) 1 :=
+  periodic_comp_ofComplex_of_vadd (heckeU_vadd k p hf)
+
+theorem periodic_heckeT_comp_ofComplex (hf : Periodic (f ∘ ofComplex) 1) :
+    Periodic (heckeT k p f ∘ ofComplex) 1 :=
+  periodic_comp_ofComplex_of_vadd (heckeT_vadd k p hf)
+
+end Regularity
+
+section Uniqueness
+
+theorem qExpansion_coeff_unique' {g : ℍ → ℂ} (hcont : Continuous g) {c : ℕ → ℂ}
+    (hg : AnalyticAt ℂ (cuspFunction 1 g) 0)
+    (hs : ∀ τ : ℍ, HasSum (fun m ↦ c m • Periodic.qParam 1 τ ^ m) (g τ)) (m : ℕ) :
+    c m = (qExpansion 1 g).coeff m :=
+  UpperHalfPlane.qExpansion_coeff_unique (ContinuousMap.mk g hcont) one_pos hg hs m
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+theorem hasSum_qCoeff [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) (τ : ℍ) :
+    HasSum (fun m ↦ qCoeff f m • Periodic.qParam 1 τ ^ m) (f τ) := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  exact hasSum_qExpansion one_pos (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ)
+    (holo f) (bdd_at_infty f) τ
+
+theorem eq_of_forall_qCoeff_eq [ModularFormClass F Γ k] {f g : F} (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (h : ∀ n : ℕ, qCoeff f n = qCoeff g n) : f = g := by
+  refine DFunLike.ext f g fun τ => ?_
+  have hf := hasSum_qCoeff f hΓ τ
+  have hg := hasSum_qCoeff g hΓ τ
+  simp only [h] at hf
+  exact hf.unique hg
+
+end Uniqueness
+
+section QExpAction
+
+theorem qParam_one (z : ℂ) : Periodic.qParam 1 z = exp (2 * π * I * z) := by
+  simp [Periodic.qParam]
+
+variable {p : ℕ} (hp : p ≠ 0)
+
+include hp in
+theorem natCast_ne_zero' : (p : ℂ) ≠ 0 := by exact_mod_cast hp
+
+include hp in
+theorem qParam_heckeMatrix_smul (j : ℕ) (τ : ℍ) :
+    Periodic.qParam 1 ((heckeMatrix p j • τ : ℍ) : ℂ)
+      = exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j := by
+  rw [qParam_one, coe_heckeMatrix_smul hp, ← Complex.exp_nat_mul, ← Complex.exp_add]
+  congr 1
+  have := natCast_ne_zero' hp
+  field_simp
+
+include hp in
+theorem qParam_heckeDiagMatrix_smul (τ : ℍ) :
+    Periodic.qParam 1 ((heckeDiagMatrix p • τ : ℍ) : ℂ) = Periodic.qParam 1 τ ^ p := by
+  rw [qParam_one, qParam_one, coe_heckeDiagMatrix_smul hp, ← Complex.exp_nat_mul]
+  congr 1
+  ring
+
+include hp in
+theorem exp_div_pow (τ : ℍ) : exp (2 * π * I * τ / p) ^ p = Periodic.qParam 1 τ := by
+  rw [qParam_one, ← Complex.exp_nat_mul]
+  congr 1
+  have := natCast_ne_zero' hp
+  field_simp
+
+include hp in
+theorem sum_rootOfUnity_pow (m : ℕ) :
+    ∑ j ∈ Finset.range p, (exp (2 * π * I / p) ^ j) ^ m = if p ∣ m then (p : ℂ) else 0 := by
+  have hζ := Complex.isPrimitiveRoot_exp p hp
+  have hswap : ∀ j : ℕ, (exp (2 * π * I / p) ^ j) ^ m = (exp (2 * π * I / p) ^ m) ^ j := fun j => by
+    rw [← pow_mul, ← pow_mul, Nat.mul_comm j m]
+  simp only [hswap]
+  split_ifs with h
+  · rw [(hζ.pow_eq_one_iff_dvd m).mpr h]
+    simp
+  · have hne : exp (2 * π * I / p) ^ m ≠ 1 := fun h1 => h ((hζ.pow_eq_one_iff_dvd m).mp h1)
+    rw [geom_sum_eq hne, ← pow_mul, Nat.mul_comm m p, pow_mul, hζ.pow_eq_one, one_pow, sub_self,
+      zero_div]
+
+theorem not_dvd_of_not_mem_range {m : ℕ} (hm : m ∉ Set.range (fun l : ℕ ↦ l * p)) : ¬ p ∣ m := by
+  rintro ⟨l, rfl⟩
+  exact hm ⟨l, by simp [mul_comm]⟩
+
+variable {f : ℍ → ℂ} (hper : Periodic (f ∘ ofComplex) 1) (hhol : MDiff f)
+  (hbdd : IsBoundedAtImInfty f)
+
+include hp hper hhol hbdd in
+theorem hasSum_average (τ : ℍ) :
+    HasSum (fun l : ℕ ↦ qCoeff f (l * p) * Periodic.qParam 1 τ ^ l)
+      ((p : ℂ)⁻¹ * ∑ j ∈ Finset.range p, f (heckeMatrix p j • τ)) := by
+  have hF : ∀ τ' : ℍ, HasSum (fun m ↦ qCoeff f m • Periodic.qParam 1 τ' ^ m) (f τ') :=
+    hasSum_qExpansion one_pos hper hhol hbdd
+  have h1 : HasSum (fun m ↦ ∑ j ∈ Finset.range p,
+      qCoeff f m • (exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j) ^ m)
+      (∑ j ∈ Finset.range p, f (heckeMatrix p j • τ)) := by
+    refine hasSum_sum fun j _ => ?_
+    have := hF (heckeMatrix p j • τ)
+    rwa [qParam_heckeMatrix_smul hp j τ] at this
+  have h2 : (fun m ↦ ∑ j ∈ Finset.range p,
+      qCoeff f m • (exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j) ^ m)
+      = fun m ↦ if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0 := by
+    funext m
+    simp only [mul_pow, smul_eq_mul, ← Finset.mul_sum, sum_rootOfUnity_pow hp m]
+    split_ifs <;> ring
+  rw [h2] at h1
+  have hinj : Function.Injective (fun l : ℕ ↦ l * p) := mul_left_injective₀ hp
+  have h3 := (hinj.hasSum_iff (f := fun m ↦
+      if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0)
+    (fun m hm => by simp [not_dvd_of_not_mem_range hm])).mpr h1
+  have h4 : ((fun m ↦ if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0) ∘
+      fun l : ℕ ↦ l * p) = fun l ↦ (p : ℂ) * (qCoeff f (l * p) * Periodic.qParam 1 τ ^ l) := by
+    funext l
+    simp only [comp_apply, ite_eq_left (dvd_mul_left p l)]
+    rw [mul_comm l p, pow_mul, exp_div_pow hp τ]
+    ring
+  rw [h4] at h3
+  have h5 := h3.mul_left ((p : ℂ)⁻¹)
+  simp only [← mul_assoc, inv_mul_cancel₀ (natCast_ne_zero' hp), one_mul] at h5
+  exact h5
+
+include hp hper hhol hbdd in
+theorem hasSum_diag (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ if p ∣ n then (p : ℂ) ^ (k - 1) * qCoeff f (n / p) * Periodic.qParam 1 τ ^ n
+        else 0)
+      ((p : ℂ) ^ (k - 1) * f (heckeDiagMatrix p • τ)) := by
+  have hD := (hasSum_qExpansion one_pos hper hhol hbdd (heckeDiagMatrix p • τ)).mul_left
+    ((p : ℂ) ^ (k - 1))
+  rw [qParam_heckeDiagMatrix_smul hp τ] at hD
+  have hinj : Function.Injective (fun l : ℕ ↦ l * p) := mul_left_injective₀ hp
+  refine (hinj.hasSum_iff (fun m hm => by simp [not_dvd_of_not_mem_range hm])).mp ?_
+  convert hD using 1
+  funext l
+  simp only [comp_apply, ite_eq_left (dvd_mul_left p l), Nat.mul_div_cancel _ (Nat.pos_of_ne_zero
+    hp),
+    smul_eq_mul]
+  rw [← pow_mul, mul_comm l p, mul_assoc]
+  rfl
+
+include hp hper hhol hbdd in
+theorem hasSum_heckeU (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ coeffHeckeU p (qCoeff f) n • Periodic.qParam 1 τ ^ n) (heckeU k p f τ) := by
+  rw [heckeU_apply k hp]
+  simpa only [coeffHeckeU_apply, smul_eq_mul] using hasSum_average hp hper hhol hbdd τ
+
+include hp hper hhol hbdd in
+theorem hasSum_heckeT (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ coeffHeckeT k p (qCoeff f) n • Periodic.qParam 1 τ ^ n) (heckeT k p f τ) :=
+      by
+  rw [heckeT_apply k hp]
+  convert (hasSum_average hp hper hhol hbdd τ).add (hasSum_diag hp hper hhol hbdd k τ) using 1
+  funext n
+  rw [coeffHeckeT_apply, smul_eq_mul]
+  split_ifs <;> ring
+
+include hp hper hhol hbdd in
+theorem qCoeff_heckeU_bare (k : ℤ) (n : ℕ) :
+    qCoeff (heckeU k p f) n = coeffHeckeU p (qCoeff f) n :=
+  (qExpansion_coeff_unique' (mdifferentiable_heckeU k p hhol).continuous
+    (analyticAt_cuspFunction_zero one_pos (periodic_heckeU_comp_ofComplex k p hper)
+      (mdifferentiable_heckeU k p hhol) (isBoundedAtImInfty_heckeU k p hbdd))
+    (hasSum_heckeU hp hper hhol hbdd k) n).symm
+
+include hp hper hhol hbdd in
+theorem qCoeff_heckeT_bare (k : ℤ) (n : ℕ) :
+    qCoeff (heckeT k p f) n = coeffHeckeT k p (qCoeff f) n :=
+  (qExpansion_coeff_unique' (mdifferentiable_heckeT k p hhol).continuous
+    (analyticAt_cuspFunction_zero one_pos (periodic_heckeT_comp_ofComplex k p hper)
+      (mdifferentiable_heckeT k p hhol) (isBoundedAtImInfty_heckeT k p hbdd))
+    (hasSum_heckeT hp hper hhol hbdd k) n).symm
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+include hp in
+theorem qCoeff_heckeU_class [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (n : ℕ) : qCoeff (heckeU k p f) n = coeffHeckeU p (qCoeff f) n :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  qCoeff_heckeU_bare hp (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (holo f)
+    (bdd_at_infty f) k n
+
+include hp in
+theorem qCoeff_heckeT_class [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (n : ℕ) : qCoeff (heckeT k p f) n = coeffHeckeT k p (qCoeff f) n :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  qCoeff_heckeT_bare hp (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (holo f)
+    (bdd_at_infty f) k n
+
+end QExpAction
+
+end M4cP1W2
+
+end
+
+theorem solution {f : UpperHalfPlane → ℂ}
+    (hper : Function.Periodic (f ∘ UpperHalfPlane.ofComplex) 1)
+    (hhol : MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) f)
+    (hbdd : UpperHalfPlane.IsBoundedAtImInfty f) (k : ℤ) {p : ℕ} (hp : p ≠ 0) (n : ℕ) :
+    ModularFormClass.qCoeff (ModularForm.heckeT k p f) n = ModularForm.coeffHeckeT k p
+      (ModularFormClass.qCoeff f) n :=
+  M4cP1W2.qCoeff_heckeT_bare hp hper hhol hbdd k n
+
+end S_UpperHalfPlane_qCoeff_heckeT
+end P2MW
+export P2MW.S_UpperHalfPlane_qCoeff_heckeT (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem UpperHalfPlane.qCoeff_heckeT {f : UpperHalfPlane → ℂ}
+    (hper : Function.Periodic (f ∘ UpperHalfPlane.ofComplex) 1)
+    (hhol : MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) f)
+    (hbdd : UpperHalfPlane.IsBoundedAtImInfty f) (k : ℤ) {p : ℕ} (hp : p ≠ 0) (n : ℕ) :
+    ModularFormClass.qCoeff (ModularForm.heckeT k p f) n = ModularForm.coeffHeckeT k p
+      (ModularFormClass.qCoeff f) n :=
+  solution hper hhol hbdd k hp n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_qCoeff_heckeU.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_qCoeff_heckeU.lean
new file mode 100644
index 0000000000..556bd5256d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_qCoeff_heckeU.lean
@@ -0,0 +1,416 @@
+/-
+Based on Prove2Me node UpperHalfPlane.qCoeff_heckeU
+(5e125770-bc42-5e19-840f-ad504c602b22) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a9cf84bb-713d-5b3c-a416-a26f714ffd84
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.CStarAlgebra.Classes
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularForm_HeckeOperator
+
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# q-expansion coefficients of Uₚ f: aₙ(Uₚf)=aₙₚ(f)
+
+Theorem statement: `UpperHalfPlane.qCoeff_heckeU` (`5e125770-bc42-5e19-840f-ad504c602b22`), by
+Claude, 2026-09-05.
+
+Proof: submission `a9cf84bb-713d-5b3c-a416-a26f714ffd84`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $f:\mathbb H\to\mathbb C$ be a function on the upper half-plane subject to three hypotheses: its
+extension to $\mathbb C$ by `UpperHalfPlane.ofComplex` is periodic of period $1$; $f$ is
+holomorphic, in the sense of being differentiable as a map of complex manifolds modelled on $\mathbb
+C$; and $f$ is bounded at $i\infty$. Let $k\in\mathbb Z$, let $p$ be a natural number with $p\neq
+0$, and let $n$ be a natural number. Here [`ModularFormClass.qCoeff f
+m`](def/FLTPrelim_Modularity.html#L19) denotes the $m$-th coefficient of the $q$-expansion of $f$
+taken with respect to the period $1$, and [`ModularForm.heckeU k p
+f`](def/ModularForm_HeckeOperator.html#L93) is the sum $\sum_{j<p} f\mid[k]\,\gamma_j$ of weight-$k$
+slash actions of the matrices $\gamma_j=\begin{pmatrix}1&j\\0&p\end{pmatrix}$ in
+$\mathrm{GL}_2(\mathbb R)$, for $j=0,\dots,p-1$; with the determinant normalisation of the slash
+action this is $\tau\mapsto p^{-1}\sum_{j<p} f((\tau+j)/p)$. The assertion is that the $n$-th
+$q$-expansion coefficient of [`ModularForm.heckeU k p f`](def/ModularForm_HeckeOperator.html#L93)
+equals [`ModularForm.coeffHeckeU p (qCoeff f) n`](def/ModularForm_HeckeOperator.html#L165), that is,
+the $(np)$-th $q$-expansion coefficient of $f$. No invariance of $f$ under any congruence subgroup
+is assumed, and the weight $k$ enters only through the slash action.
+
+This is the classical computation of the effect of the Hecke operator $U_p$ on $q$-expansions,
+$a_n(U_pf)=a_{np}(f)$, stated here for an arbitrary $1$-periodic holomorphic function bounded at
+$i\infty$ rather than only for modular forms. It serves as the coefficient-level input for the
+arguments about $U_p$- and $T_p$-eigenforms used in the level-lowering part of the development, for
+instance in the analysis of eigenforms after change of level and in the comparison of $U_p$ with
+degeneracy maps.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_UpperHalfPlane_qCoeff_heckeU.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_UpperHalfPlane_qCoeff_heckeU
+
+noncomputable section
+
+open Complex Function Filter
+p2m_open "UpperHalfPlane~I"
+open scoped Real MatrixGroups ModularForm Manifold Topology
+
+namespace M4cP1W2
+
+open ModularForm ModularFormClass
+
+section Matrices
+
+variable (p j : ℕ)
+
+theorem heckeMatrix_one_zero :
+    ((heckeMatrix p j : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) 1 0 = 0 := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  · rw [val_heckeMatrix hp]; rfl
+
+theorem heckeDiagMatrix_one_zero :
+    ((heckeDiagMatrix p : GL (Fin 2) ℝ) : Matrix (Fin 2) (Fin 2) ℝ) 1 0 = 0 := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp
+  · rw [val_heckeDiagMatrix hp]; rfl
+
+end Matrices
+
+section Regularity
+
+variable {f : ℍ → ℂ} (k : ℤ) (p : ℕ)
+
+theorem mdifferentiable_heckeU (hf : MDiff f) : MDiff (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => MDiff g) (fun _ _ ha hb => ha.add hb)
+    mdifferentiable_const (fun _ _ => hf.slash k _)
+
+theorem mdifferentiable_heckeT (hf : MDiff f) : MDiff (heckeT k p f) :=
+  (mdifferentiable_heckeU k p hf).add (hf.slash k _)
+
+theorem isBoundedAtImInfty_heckeU (hf : IsBoundedAtImInfty f) :
+    IsBoundedAtImInfty (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => IsBoundedAtImInfty g)
+    (fun _ _ ha hb => ha.add hb) UpperHalfPlane.zero_form_isBoundedAtImInfty
+    (fun j _ => hf.slash k (heckeMatrix_one_zero p j))
+
+theorem isBoundedAtImInfty_heckeT (hf : IsBoundedAtImInfty f) :
+    IsBoundedAtImInfty (heckeT k p f) :=
+  (isBoundedAtImInfty_heckeU k p hf).add (hf.slash k (heckeDiagMatrix_one_zero p))
+
+theorem isZeroAtImInfty_heckeU (hf : IsZeroAtImInfty f) :
+    IsZeroAtImInfty (heckeU k p f) :=
+  Finset.sum_induction _ (fun g : ℍ → ℂ => IsZeroAtImInfty g)
+    (fun _ _ ha hb => ha.add hb) (zero_zeroAtFilter atImInfty)
+    (fun j _ => hf.slash k (heckeMatrix_one_zero p j))
+
+theorem isZeroAtImInfty_heckeT (hf : IsZeroAtImInfty f) :
+    IsZeroAtImInfty (heckeT k p f) :=
+  (isZeroAtImInfty_heckeU k p hf).add (hf.slash k (heckeDiagMatrix_one_zero p))
+
+theorem apply_eq_of_coe_eq_add_nat (hf : Periodic (f ∘ ofComplex) 1) {τ₁ τ₂ : ℍ} (m : ℕ)
+    (h : (τ₁ : ℂ) = τ₂ + m) : f τ₁ = f τ₂ := by
+  have h1 : (f ∘ ofComplex) ((τ₂ : ℂ) + m) = (f ∘ ofComplex) (τ₂ : ℂ) := by
+    have := hf.nat_mul m
+    rw [mul_one] at this
+    exact this (τ₂ : ℂ)
+  simp only [comp_apply] at h1
+  rw [← h, ofComplex_apply, ofComplex_apply] at h1
+  exact h1
+
+variable {p} in
+theorem heckeMatrix_smul_vadd (hp : p ≠ 0) (j : ℕ) (τ : ℍ) :
+    heckeMatrix p j • ((1 : ℝ) +ᵥ τ) = heckeMatrix p (j + 1) • τ := by
+  apply UpperHalfPlane.ext
+  rw [coe_heckeMatrix_smul hp, coe_heckeMatrix_smul hp, coe_vadd]
+  push_cast
+  ring
+
+variable {p} in
+theorem coe_heckeMatrix_smul_self (hp : p ≠ 0) (τ : ℍ) :
+    ((heckeMatrix p p • τ : ℍ) : ℂ) = (heckeMatrix p 0 • τ : ℍ) + (1 : ℕ) := by
+  have hp' : (p : ℂ) ≠ 0 := by exact_mod_cast hp
+  rw [coe_heckeMatrix_smul hp, coe_heckeMatrix_smul hp]
+  field_simp
+  push_cast
+  ring
+
+variable {p} in
+theorem coe_heckeDiagMatrix_smul_vadd (hp : p ≠ 0) (τ : ℍ) :
+    ((heckeDiagMatrix p • ((1 : ℝ) +ᵥ τ) : ℍ) : ℂ) = (heckeDiagMatrix p • τ : ℍ) + (p : ℕ) := by
+  rw [coe_heckeDiagMatrix_smul hp, coe_heckeDiagMatrix_smul hp, coe_vadd]
+  push_cast
+  ring
+
+variable {p} in
+theorem sum_heckeMatrix_smul_vadd (hp : p ≠ 0) (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    ∑ j ∈ Finset.range p, f (heckeMatrix p j • ((1 : ℝ) +ᵥ τ))
+      = ∑ j ∈ Finset.range p, f (heckeMatrix p j • τ) := by
+  simp only [heckeMatrix_smul_vadd hp]
+  have h0 := Finset.sum_range_succ' (fun j => f (heckeMatrix p j • τ)) p
+  have h1 := Finset.sum_range_succ (fun j => f (heckeMatrix p j • τ)) p
+  rw [apply_eq_of_coe_eq_add_nat hf 1 (coe_heckeMatrix_smul_self hp τ)] at h1
+  exact add_right_cancel (h0.symm.trans h1)
+
+theorem heckeU_vadd (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    heckeU k p f ((1 : ℝ) +ᵥ τ) = heckeU k p f τ := by
+  by_cases hp : p = 0
+  · simp only [hp, heckeU_zero_left, Pi.zero_apply]
+  · rw [heckeU_apply k hp, heckeU_apply k hp, sum_heckeMatrix_smul_vadd hp hf]
+
+theorem heckeT_vadd (hf : Periodic (f ∘ ofComplex) 1) (τ : ℍ) :
+    heckeT k p f ((1 : ℝ) +ᵥ τ) = heckeT k p f τ := by
+  by_cases hp : p = 0
+  · simp only [hp, heckeT_zero_left]
+    exact apply_eq_of_coe_eq_add_nat hf 1 (by rw [coe_vadd]; push_cast; ring)
+  · rw [heckeT_apply k hp, heckeT_apply k hp, sum_heckeMatrix_smul_vadd hp hf,
+      apply_eq_of_coe_eq_add_nat hf p (coe_heckeDiagMatrix_smul_vadd hp τ)]
+
+theorem periodic_comp_ofComplex_of_vadd {g : ℍ → ℂ} (hg : ∀ τ : ℍ, g ((1 : ℝ) +ᵥ τ) = g τ) :
+    Periodic (g ∘ ofComplex) 1 := by
+  intro w
+  by_cases hw : 0 < im w
+  · have hw' : 0 < im (w + 1) := by simp [hw]
+    simp only [comp_apply, ofComplex_apply_of_im_pos hw', ofComplex_apply_of_im_pos hw]
+    convert hg ⟨w, hw⟩ using 2
+    apply UpperHalfPlane.ext
+    simp [add_comm]
+  · have hw1 : im (w + 1) ≤ 0 := by simpa using hw
+    have hw0 : im w ≤ 0 := not_lt.mp hw
+    simp only [comp_apply, ofComplex_apply_eq_of_im_nonpos hw1 hw0]
+
+theorem periodic_heckeU_comp_ofComplex (hf : Periodic (f ∘ ofComplex) 1) :
+    Periodic (heckeU k p f ∘ ofComplex) 1 :=
+  periodic_comp_ofComplex_of_vadd (heckeU_vadd k p hf)
+
+theorem periodic_heckeT_comp_ofComplex (hf : Periodic (f ∘ ofComplex) 1) :
+    Periodic (heckeT k p f ∘ ofComplex) 1 :=
+  periodic_comp_ofComplex_of_vadd (heckeT_vadd k p hf)
+
+end Regularity
+
+section Uniqueness
+
+theorem qExpansion_coeff_unique' {g : ℍ → ℂ} (hcont : Continuous g) {c : ℕ → ℂ}
+    (hg : AnalyticAt ℂ (cuspFunction 1 g) 0)
+    (hs : ∀ τ : ℍ, HasSum (fun m ↦ c m • Periodic.qParam 1 τ ^ m) (g τ)) (m : ℕ) :
+    c m = (qExpansion 1 g).coeff m :=
+  UpperHalfPlane.qExpansion_coeff_unique (ContinuousMap.mk g hcont) one_pos hg hs m
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+theorem hasSum_qCoeff [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods) (τ : ℍ) :
+    HasSum (fun m ↦ qCoeff f m • Periodic.qParam 1 τ ^ m) (f τ) := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  exact hasSum_qExpansion one_pos (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ)
+    (holo f) (bdd_at_infty f) τ
+
+theorem eq_of_forall_qCoeff_eq [ModularFormClass F Γ k] {f g : F} (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (h : ∀ n : ℕ, qCoeff f n = qCoeff g n) : f = g := by
+  refine DFunLike.ext f g fun τ => ?_
+  have hf := hasSum_qCoeff f hΓ τ
+  have hg := hasSum_qCoeff g hΓ τ
+  simp only [h] at hf
+  exact hf.unique hg
+
+end Uniqueness
+
+section QExpAction
+
+theorem qParam_one (z : ℂ) : Periodic.qParam 1 z = exp (2 * π * I * z) := by
+  simp [Periodic.qParam]
+
+variable {p : ℕ} (hp : p ≠ 0)
+
+include hp in
+theorem natCast_ne_zero' : (p : ℂ) ≠ 0 := by exact_mod_cast hp
+
+include hp in
+theorem qParam_heckeMatrix_smul (j : ℕ) (τ : ℍ) :
+    Periodic.qParam 1 ((heckeMatrix p j • τ : ℍ) : ℂ)
+      = exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j := by
+  rw [qParam_one, coe_heckeMatrix_smul hp, ← Complex.exp_nat_mul, ← Complex.exp_add]
+  congr 1
+  have := natCast_ne_zero' hp
+  field_simp
+
+include hp in
+theorem qParam_heckeDiagMatrix_smul (τ : ℍ) :
+    Periodic.qParam 1 ((heckeDiagMatrix p • τ : ℍ) : ℂ) = Periodic.qParam 1 τ ^ p := by
+  rw [qParam_one, qParam_one, coe_heckeDiagMatrix_smul hp, ← Complex.exp_nat_mul]
+  congr 1
+  ring
+
+include hp in
+theorem exp_div_pow (τ : ℍ) : exp (2 * π * I * τ / p) ^ p = Periodic.qParam 1 τ := by
+  rw [qParam_one, ← Complex.exp_nat_mul]
+  congr 1
+  have := natCast_ne_zero' hp
+  field_simp
+
+include hp in
+theorem sum_rootOfUnity_pow (m : ℕ) :
+    ∑ j ∈ Finset.range p, (exp (2 * π * I / p) ^ j) ^ m = if p ∣ m then (p : ℂ) else 0 := by
+  have hζ := Complex.isPrimitiveRoot_exp p hp
+  have hswap : ∀ j : ℕ, (exp (2 * π * I / p) ^ j) ^ m = (exp (2 * π * I / p) ^ m) ^ j := fun j => by
+    rw [← pow_mul, ← pow_mul, Nat.mul_comm j m]
+  simp only [hswap]
+  split_ifs with h
+  · rw [(hζ.pow_eq_one_iff_dvd m).mpr h]
+    simp
+  · have hne : exp (2 * π * I / p) ^ m ≠ 1 := fun h1 => h ((hζ.pow_eq_one_iff_dvd m).mp h1)
+    rw [geom_sum_eq hne, ← pow_mul, Nat.mul_comm m p, pow_mul, hζ.pow_eq_one, one_pow, sub_self,
+      zero_div]
+
+theorem not_dvd_of_not_mem_range {m : ℕ} (hm : m ∉ Set.range (fun l : ℕ ↦ l * p)) : ¬ p ∣ m := by
+  rintro ⟨l, rfl⟩
+  exact hm ⟨l, by simp [mul_comm]⟩
+
+variable {f : ℍ → ℂ} (hper : Periodic (f ∘ ofComplex) 1) (hhol : MDiff f)
+  (hbdd : IsBoundedAtImInfty f)
+
+include hp hper hhol hbdd in
+theorem hasSum_average (τ : ℍ) :
+    HasSum (fun l : ℕ ↦ qCoeff f (l * p) * Periodic.qParam 1 τ ^ l)
+      ((p : ℂ)⁻¹ * ∑ j ∈ Finset.range p, f (heckeMatrix p j • τ)) := by
+  have hF : ∀ τ' : ℍ, HasSum (fun m ↦ qCoeff f m • Periodic.qParam 1 τ' ^ m) (f τ') :=
+    hasSum_qExpansion one_pos hper hhol hbdd
+  have h1 : HasSum (fun m ↦ ∑ j ∈ Finset.range p,
+      qCoeff f m • (exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j) ^ m)
+      (∑ j ∈ Finset.range p, f (heckeMatrix p j • τ)) := by
+    refine hasSum_sum fun j _ => ?_
+    have := hF (heckeMatrix p j • τ)
+    rwa [qParam_heckeMatrix_smul hp j τ] at this
+  have h2 : (fun m ↦ ∑ j ∈ Finset.range p,
+      qCoeff f m • (exp (2 * π * I * τ / p) * exp (2 * π * I / p) ^ j) ^ m)
+      = fun m ↦ if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0 := by
+    funext m
+    simp only [mul_pow, smul_eq_mul, ← Finset.mul_sum, sum_rootOfUnity_pow hp m]
+    split_ifs <;> ring
+  rw [h2] at h1
+  have hinj : Function.Injective (fun l : ℕ ↦ l * p) := mul_left_injective₀ hp
+  have h3 := (hinj.hasSum_iff (f := fun m ↦
+      if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0)
+    (fun m hm => by simp [not_dvd_of_not_mem_range hm])).mpr h1
+  have h4 : ((fun m ↦ if p ∣ m then (p : ℂ) * qCoeff f m * exp (2 * π * I * τ / p) ^ m else 0) ∘
+      fun l : ℕ ↦ l * p) = fun l ↦ (p : ℂ) * (qCoeff f (l * p) * Periodic.qParam 1 τ ^ l) := by
+    funext l
+    simp only [comp_apply, ite_eq_left (dvd_mul_left p l)]
+    rw [mul_comm l p, pow_mul, exp_div_pow hp τ]
+    ring
+  rw [h4] at h3
+  have h5 := h3.mul_left ((p : ℂ)⁻¹)
+  simp only [← mul_assoc, inv_mul_cancel₀ (natCast_ne_zero' hp), one_mul] at h5
+  exact h5
+
+include hp hper hhol hbdd in
+theorem hasSum_diag (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ if p ∣ n then (p : ℂ) ^ (k - 1) * qCoeff f (n / p) * Periodic.qParam 1 τ ^ n
+        else 0)
+      ((p : ℂ) ^ (k - 1) * f (heckeDiagMatrix p • τ)) := by
+  have hD := (hasSum_qExpansion one_pos hper hhol hbdd (heckeDiagMatrix p • τ)).mul_left
+    ((p : ℂ) ^ (k - 1))
+  rw [qParam_heckeDiagMatrix_smul hp τ] at hD
+  have hinj : Function.Injective (fun l : ℕ ↦ l * p) := mul_left_injective₀ hp
+  refine (hinj.hasSum_iff (fun m hm => by simp [not_dvd_of_not_mem_range hm])).mp ?_
+  convert hD using 1
+  funext l
+  simp only [comp_apply, ite_eq_left (dvd_mul_left p l), Nat.mul_div_cancel _ (Nat.pos_of_ne_zero
+    hp),
+    smul_eq_mul]
+  rw [← pow_mul, mul_comm l p, mul_assoc]
+  rfl
+
+include hp hper hhol hbdd in
+theorem hasSum_heckeU (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ coeffHeckeU p (qCoeff f) n • Periodic.qParam 1 τ ^ n) (heckeU k p f τ) := by
+  rw [heckeU_apply k hp]
+  simpa only [coeffHeckeU_apply, smul_eq_mul] using hasSum_average hp hper hhol hbdd τ
+
+include hp hper hhol hbdd in
+theorem hasSum_heckeT (k : ℤ) (τ : ℍ) :
+    HasSum (fun n : ℕ ↦ coeffHeckeT k p (qCoeff f) n • Periodic.qParam 1 τ ^ n) (heckeT k p f τ) :=
+      by
+  rw [heckeT_apply k hp]
+  convert (hasSum_average hp hper hhol hbdd τ).add (hasSum_diag hp hper hhol hbdd k τ) using 1
+  funext n
+  rw [coeffHeckeT_apply, smul_eq_mul]
+  split_ifs <;> ring
+
+include hp hper hhol hbdd in
+theorem qCoeff_heckeU_bare (k : ℤ) (n : ℕ) :
+    qCoeff (heckeU k p f) n = coeffHeckeU p (qCoeff f) n :=
+  (qExpansion_coeff_unique' (mdifferentiable_heckeU k p hhol).continuous
+    (analyticAt_cuspFunction_zero one_pos (periodic_heckeU_comp_ofComplex k p hper)
+      (mdifferentiable_heckeU k p hhol) (isBoundedAtImInfty_heckeU k p hbdd))
+    (hasSum_heckeU hp hper hhol hbdd k) n).symm
+
+include hp hper hhol hbdd in
+theorem qCoeff_heckeT_bare (k : ℤ) (n : ℕ) :
+    qCoeff (heckeT k p f) n = coeffHeckeT k p (qCoeff f) n :=
+  (qExpansion_coeff_unique' (mdifferentiable_heckeT k p hhol).continuous
+    (analyticAt_cuspFunction_zero one_pos (periodic_heckeT_comp_ofComplex k p hper)
+      (mdifferentiable_heckeT k p hhol) (isBoundedAtImInfty_heckeT k p hbdd))
+    (hasSum_heckeT hp hper hhol hbdd k) n).symm
+
+variable {F : Type*} [FunLike F ℍ ℂ] {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ}
+
+include hp in
+theorem qCoeff_heckeU_class [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (n : ℕ) : qCoeff (heckeU k p f) n = coeffHeckeU p (qCoeff f) n :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  qCoeff_heckeU_bare hp (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (holo f)
+    (bdd_at_infty f) k n
+
+include hp in
+theorem qCoeff_heckeT_class [ModularFormClass F Γ k] (f : F) (hΓ : (1 : ℝ) ∈ Γ.strictPeriods)
+    (n : ℕ) : qCoeff (heckeT k p f) n = coeffHeckeT k p (qCoeff f) n :=
+  haveI : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos hΓ⟩
+  qCoeff_heckeT_bare hp (SlashInvariantFormClass.periodic_comp_ofComplex f hΓ) (holo f)
+    (bdd_at_infty f) k n
+
+end QExpAction
+
+end M4cP1W2
+
+end
+
+theorem solution {f : UpperHalfPlane → ℂ}
+    (hper : Function.Periodic (f ∘ UpperHalfPlane.ofComplex) 1)
+    (hhol : MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) f)
+    (hbdd : UpperHalfPlane.IsBoundedAtImInfty f) (k : ℤ) {p : ℕ} (hp : p ≠ 0) (n : ℕ) :
+    ModularFormClass.qCoeff (ModularForm.heckeU k p f) n = ModularForm.coeffHeckeU p
+      (ModularFormClass.qCoeff f) n :=
+  M4cP1W2.qCoeff_heckeU_bare hp hper hhol hbdd k n
+
+end S_UpperHalfPlane_qCoeff_heckeU
+end P2MW
+export P2MW.S_UpperHalfPlane_qCoeff_heckeU (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem UpperHalfPlane.qCoeff_heckeU {f : UpperHalfPlane → ℂ}
+    (hper : Function.Periodic (f ∘ UpperHalfPlane.ofComplex) 1)
+    (hhol : MDifferentiable (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) f)
+    (hbdd : UpperHalfPlane.IsBoundedAtImInfty f) (k : ℤ) {p : ℕ} (hp : p ≠ 0) (n : ℕ) :
+    ModularFormClass.qCoeff (ModularForm.heckeU k p f) n = ModularForm.coeffHeckeU p
+      (ModularFormClass.qCoeff f) n :=
+  solution hper hhol hbdd k hp n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_qExpansion_coeff_mul_width.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_qExpansion_coeff_mul_width.lean
new file mode 100644
index 0000000000..3f61b1c119
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_qExpansion_coeff_mul_width.lean
@@ -0,0 +1,160 @@
+/-
+Based on Prove2Me node UpperHalfPlane.qExpansion_coeff_mul_width
+(3609f650-c6e7-5cf2-ac9f-2477576a116f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d36e4570-d95c-553c-a699-ced78bb65b8c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.CStarAlgebra.Classes
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Change of width in a q-expansion
+
+Theorem statement: `UpperHalfPlane.qExpansion_coeff_mul_width`
+(`3609f650-c6e7-5cf2-ac9f-2477576a116f`), by Claude, 2026-09-05.
+
+Proof: submission `d36e4570-d95c-553c-a699-ced78bb65b8c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $f\colon\mathbb H\to\mathbb C$ be a function on the upper half-plane, let $h_0$ be a real number
+with $h_0>0$, assume that the extension $f\circ$ `UpperHalfPlane.ofComplex` of $f$ to $\mathbb C$ is
+periodic with period $h_0$, that $f$ is holomorphic in the sense of being `MDifferentiable` from the
+model $\mathcal I(\mathbb C)$ on $\mathbb H$ to $\mathcal I(\mathbb C)$, and that $f$ satisfies
+`UpperHalfPlane.IsBoundedAtImInfty`, i.e. $f$ is bounded on $\{\operatorname{Im}\tau\ge A\}$ for
+some $A$. Let $m'$ be a natural number with $m'>0$ and let $i$ be a natural number. Then the $i$-th
+coefficient of the $q$-expansion of $f$ of width $m'h_0$, `UpperHalfPlane.qExpansion ((m' : ℝ) * h₀)
+f`, equals the $(i/m')$-th coefficient (natural-number division) of the $q$-expansion of width $h_0$
+when $m'\mid i$, and equals $0$ otherwise. Here the width-$h$ $q$-expansion is the power series in
+$q_h=\exp(2\pi i\tau/h)$ attached to $f$ by the Taylor coefficients at $0$ of its cusp function.
+
+This is the standard comparison of Fourier expansions of a periodic holomorphic function taken with
+respect to two commensurable widths: an $h_0$-periodic function, read in the parameter $q_{m'h_0}$,
+has coefficients supported on the multiples of $m'$, with the same values. It is used to pass
+between a width $h$ arising from some $T^h$ lying in a congruence subgroup and the exact width
+$h_0\mid h$ of the cusp $\infty$, and is invoked in the analysis of $q$-expansions of Siegel units,
+of expansions of functions in the function field of a modular curve, and in the order-of-vanishing
+estimates at cusps.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_UpperHalfPlane_qExpansion_coeff_mul_width.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_UpperHalfPlane_qExpansion_coeff_mul_width
+
+noncomputable section
+
+namespace WidthChange
+
+open UpperHalfPlane Filter Function
+open scoped Real Topology Manifold
+
+structure FnWrap where
+  toFun : ℍ → ℂ
+
+scoped instance : FunLike FnWrap ℍ ℂ where
+  coe := FnWrap.toFun
+  coe_injective := by rintro ⟨f⟩ ⟨g⟩ h; congr
+
+theorem qParam_mul_width_pow {h₀ : ℝ} (hh₀ : 0 < h₀) {m' : ℕ} (hm' : 0 < m') (z : ℂ) :
+    Periodic.qParam ((m' : ℝ) * h₀) z ^ m' = Periodic.qParam h₀ z := by
+  simp only [Periodic.qParam]
+  rw [← Complex.exp_nat_mul]
+  congr 1
+  have h1 : (h₀ : ℂ) ≠ 0 := by exact_mod_cast hh₀.ne'
+  have h2 : (m' : ℂ) ≠ 0 := by exact_mod_cast hm'.ne'
+  push_cast
+  field_simp
+
+theorem main (f : ℍ → ℂ) (h₀ : ℝ) (hh₀ : 0 < h₀)
+    (hper : Periodic (f ∘ UpperHalfPlane.ofComplex) h₀)
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) (hbdd : IsBoundedAtImInfty f)
+    (m' : ℕ) (hm' : 0 < m') (i : ℕ) :
+    PowerSeries.coeff i (qExpansion ((m' : ℝ) * h₀) f) =
+      if m' ∣ i then PowerSeries.coeff (i / m') (qExpansion h₀ f) else 0 := by
+  have hper' : Periodic (f ∘ UpperHalfPlane.ofComplex) (Complex.ofReal ((m' : ℝ) * h₀)) := by
+    have e : Complex.ofReal ((m' : ℝ) * h₀) = (m' : ℕ) * (h₀ : ℂ) := by push_cast; ring
+    rw [e]
+    exact hper.nat_mul m'
+  have hh : 0 < (m' : ℝ) * h₀ := by positivity
+  let F : FnWrap := ⟨f⟩
+  let a : ℕ → ℂ := fun n => PowerSeries.coeff n (qExpansion h₀ f)
+  have hinj : Injective (fun n : ℕ => m' * n) := mul_right_injective₀ hm'.ne'
+  let c : ℕ → ℂ := extend (fun n : ℕ => m' * n) a 0
+  have hnot : ∀ i : ℕ, ¬ m' ∣ i → ¬ ∃ n, (fun n : ℕ => m' * n) n = i :=
+    fun i hdiv ⟨n, hn⟩ => hdiv ⟨n, hn.symm⟩
+  have hc : ∀ i, c i = if m' ∣ i then a (i / m') else 0 := by
+    intro i
+    split_ifs with hdiv
+    · obtain ⟨n, rfl⟩ := hdiv
+      change extend (fun n : ℕ => m' * n) a 0 (m' * n) = _
+      rw [hinj.extend_apply, Nat.mul_div_cancel_left _ hm']
+    · change extend (fun n : ℕ => m' * n) a 0 i = 0
+      rw [extend_apply' _ _ _ (hnot i hdiv), Pi.zero_apply]
+  have hsum : ∀ τ : ℍ, HasSum (fun i => c i • Periodic.qParam ((m' : ℝ) * h₀) τ ^ i) (F τ) := by
+    intro τ
+    have h1 := hasSum_qExpansion hh₀ hper hhol hbdd τ
+    have heq : (fun i => c i • Periodic.qParam ((m' : ℝ) * h₀) τ ^ i) =
+        extend (fun n : ℕ => m' * n) (fun n => a n • Periodic.qParam h₀ τ ^ n) 0 := by
+      funext i
+      rw [hc]
+      split_ifs with hdiv
+      · obtain ⟨n, rfl⟩ := hdiv
+        rw [hinj.extend_apply, Nat.mul_div_cancel_left _ hm', pow_mul, qParam_mul_width_pow hh₀ hm']
+      · rw [extend_apply' _ _ _ (hnot i hdiv), Pi.zero_apply, zero_smul]
+    rw [heq, hasSum_extend_zero hinj]
+    exact h1
+  have huniq :=
+    qExpansion_coeff_unique F hh (analyticAt_cuspFunction_zero hh hper' hhol hbdd) hsum i
+  change c i = PowerSeries.coeff i (qExpansion ((m' : ℝ) * h₀) f) at huniq
+  rw [← huniq, hc]
+
+end WidthChange
+end
+
+open UpperHalfPlane in
+open scoped Manifold in
+theorem solution (f : UpperHalfPlane → ℂ) (h₀ : ℝ) (hh₀ : 0 < h₀)
+    (hper : Function.Periodic (f ∘ UpperHalfPlane.ofComplex) h₀)
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) (hbdd : UpperHalfPlane.IsBoundedAtImInfty f)
+    (m' : ℕ) (hm' : 0 < m') (i : ℕ) :
+    PowerSeries.coeff i (UpperHalfPlane.qExpansion ((m' : ℝ) * h₀) f) =
+      if m' ∣ i then PowerSeries.coeff (i / m') (UpperHalfPlane.qExpansion h₀ f) else 0 :=
+  WidthChange.main f h₀ hh₀ hper hhol hbdd m' hm' i
+
+end S_UpperHalfPlane_qExpansion_coeff_mul_width
+end P2MW
+export P2MW.S_UpperHalfPlane_qExpansion_coeff_mul_width (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane in
+open scoped Manifold in
+theorem UpperHalfPlane.qExpansion_coeff_mul_width (f : UpperHalfPlane → ℂ) (h₀ : ℝ) (hh₀ : 0 < h₀)
+    (hper : Function.Periodic (f ∘ UpperHalfPlane.ofComplex) h₀)
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) (hbdd : UpperHalfPlane.IsBoundedAtImInfty f)
+    (m' : ℕ) (hm' : 0 < m') (i : ℕ) :
+    PowerSeries.coeff i (UpperHalfPlane.qExpansion ((m' : ℝ) * h₀) f) =
+      if m' ∣ i then PowerSeries.coeff (i / m') (UpperHalfPlane.qExpansion h₀ f) else 0 :=
+  solution f h₀ hh₀ hper hhol hbdd m' hm' i
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_qExpansion_prod.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_qExpansion_prod.lean
new file mode 100644
index 0000000000..071ccbab18
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_UpperHalfPlane_qExpansion_prod.lean
@@ -0,0 +1,111 @@
+/-
+Based on Prove2Me node UpperHalfPlane.qExpansion_prod
+(47495b29-4a54-5031-aeba-05cd6ce98b16) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b6ad8b51-5d7d-5710-a482-b68825033819
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# q-expansion of a finite product of functions on H
+
+Theorem statement: `UpperHalfPlane.qExpansion_prod` (`47495b29-4a54-5031-aeba-05cd6ce98b16`), by
+Claude, 2026-09-05.
+
+Proof: submission `b6ad8b51-5d7d-5710-a482-b68825033819`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a real number $h$ (the width of the $q$-parameter $q = e^{2\pi i \tau/h}$), an index type
+$\iota$, a finite subset $s$ of $\iota$, and a family $F : \iota \to \mathbb{H} \to \mathbb{C}$ of
+complex-valued functions on the upper half-plane. Assume that for every $i \in s$ the associated
+cusp function `cuspFunction h (F i)` — the function $q \mapsto F_i(\mathrm{invQParam}\ h\ q)$ on the
+punctured disc, extended to $q = 0$ by the limit of that function as $q \to 0$ — is analytic at $0$
+as a function of the complex variable $q$. The conclusion is an identity in the power series ring
+$\mathbb{C}[[q]]$: the $q$-expansion of the pointwise product $\prod_{i \in s} F_i$, namely the
+Taylor series at $q = 0$ whose $n$-th coefficient is the $n$-th iterated derivative of the cusp
+function at $0$ divided by $n!$, equals the product $\prod_{i \in s}$ `qExpansion h (F i)` of the
+individual $q$-expansions. No periodicity, holomorphy or modularity of the $F_i$ is assumed beyond
+analyticity of the cusp functions at $0$; the empty product is covered, the statement then reducing
+to $q$-expansion of the constant function $1$.
+
+This is the finite-product form of the two-factor multiplicativity of $q$-expansions,
+`qExpansion_mul`: the passage from a function on the upper half-plane to its Taylor series in the
+local parameter at the cusp is a ring homomorphism on functions whose cusp functions are analytic at
+the cusp. It is used in the vanishing criterion
+[`ModularForm.eq_zero_of_lt_order_qExpansion_of_isArithmetic`]
+(thm.html#ModularForm.eq_zero_of_lt_order_qExpansion_of_isArithmetic),
+where one compares the order of vanishing at $\infty$ of a modular form with that of a product of
+its translates.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_UpperHalfPlane_qExpansion_prod.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_UpperHalfPlane_qExpansion_prod
+
+noncomputable section
+
+open Complex Filter Function UpperHalfPlane ModularForm SlashInvariantFormClass ModularFormClass
+
+open scoped Real MatrixGroups Topology Manifold
+
+theorem solution {h : ℝ} {ι : Type*} (s : Finset ι) {F : ι → ℍ → ℂ}
+    (hF : ∀ i ∈ s, AnalyticAt ℂ (cuspFunction h (F i)) 0) :
+    qExpansion h (∏ i ∈ s, F i) = ∏ i ∈ s, qExpansion h (F i) := by
+  suffices H : qExpansion h (∏ i ∈ s, F i) = ∏ i ∈ s, qExpansion h (F i) ∧
+      AnalyticAt ℂ (cuspFunction h (∏ i ∈ s, F i)) 0 from H.1
+  induction s using Finset.cons_induction with
+  | empty =>
+    have h1 : cuspFunction h (1 : ℍ → ℂ) = 1 := by
+      ext q
+      rcases eq_or_ne q 0 with rfl | hq
+      · simp only [cuspFunction, Periodic.cuspFunction, Pi.one_comp, update_self, Pi.one_apply]
+        exact Filter.Tendsto.limUnder_eq tendsto_const_nhds
+      · simp [cuspFunction, Periodic.cuspFunction_eq_of_nonzero h _ hq]
+    refine ⟨by simpa using qExpansion_one h, ?_⟩
+    rw [Finset.prod_empty, h1]
+    exact analyticAt_const
+  | cons a s ha ih =>
+    have hFa : AnalyticAt ℂ (cuspFunction h (F a)) 0 := hF a (Finset.mem_cons_self a s)
+    obtain ⟨ih1, ih2⟩ := ih fun i hi ↦ hF i (Finset.mem_cons_of_mem hi)
+    rw [Finset.prod_cons, Finset.prod_cons, qExpansion_mul hFa ih2, ih1]
+    refine ⟨rfl, ?_⟩
+    rw [cuspFunction_mul hFa.continuousAt ih2.continuousAt]
+    exact hFa.mul ih2
+
+end
+
+end S_UpperHalfPlane_qExpansion_prod
+end P2MW
+export P2MW.S_UpperHalfPlane_qExpansion_prod (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane
+open scoped Manifold
+theorem UpperHalfPlane.qExpansion_prod {h : ℝ} {ι : Type*} (s : Finset ι) {F : ι → ℍ → ℂ}
+    (hF : ∀ i ∈ s, AnalyticAt ℂ (cuspFunction h (F i)) 0) :
+    qExpansion h (∏ i ∈ s, F i) = ∏ i ∈ s, qExpansion h (F i) :=
+  solution s hF
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ValuationSubring_IsFrobeniusAt_apply_eq_pow_of_pow_prime_pow_eq_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ValuationSubring_IsFrobeniusAt_apply_eq_pow_of_pow_prime_pow_eq_one.lean
new file mode 100644
index 0000000000..5a2b92e50f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ValuationSubring_IsFrobeniusAt_apply_eq_pow_of_pow_prime_pow_eq_one.lean
@@ -0,0 +1,166 @@
+/-
+Based on Prove2Me node ValuationSubring.IsFrobeniusAt.apply_eq_pow_of_pow_prime_pow_eq_one
+(c58ad5a7-6ae5-5475-aa55-66fbedd6bd4a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4caab809-578a-5097-a0b3-29955e59c5f1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Ramification
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusTrace
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Frobenius at q raises p^k-th roots of unity to the q-th power
+
+Theorem statement: `ValuationSubring.IsFrobeniusAt.apply_eq_pow_of_pow_prime_pow_eq_one`
+(`c58ad5a7-6ae5-5475-aa55-66fbedd6bd4a`), by Claude, 2026-09-05.
+
+Proof: submission `4caab809-578a-5097-a0b3-29955e59c5f1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $p$ and $q$ be primes with $q \neq p$, let $A$ be a valuation subring of $\overline{\mathbb{Q}}
+=$ `AlgebraicClosure ℚ` satisfying `A.LiesOverPrime q`, i.e. the image of $q$ in
+$\overline{\mathbb{Q}}$ lies in the set of nonunits of $A$, and let $\sigma$ be a
+$\mathbb{Q}$-algebra automorphism of $\overline{\mathbb{Q}}$ satisfying `A.IsFrobeniusAt σ q`, i.e.
+$\sigma$ belongs to the decomposition subgroup of $A$ over $\mathbb{Q}$ and the resulting action of
+$\sigma$ on the residue field of the local ring $A$ sends every element $x$ to $x^{q}$. Then for
+every natural number $k$ and every $\zeta \in \overline{\mathbb{Q}}$ with $\zeta^{p^{k}} = 1$ one
+has $\sigma(\zeta) = \zeta^{q}$. Thus the statement is not merely about the residue field: the
+identity holds on the nose in $\overline{\mathbb{Q}}$, for all $p^{k}$-th roots of unity at once,
+including $k = 0$ and $\zeta = 1$.
+
+This is the standard fact that a Frobenius element at a place above $q$ acts on roots of unity of
+order prime to $q$ by the $q$-th power map, here in the form needed for $p$-power roots of unity
+with $p \neq q$, which is what identifies the determinant of a $p$-adic Galois representation with a
+power of the cyclotomic character at unramified places. It is used in computing the determinant of
+the Tate module representation of an elliptic curve at Frobenius, and in the characteristic
+polynomial of inertia statement for newforms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ValuationSubring_IsFrobeniusAt_apply_eq_pow_of_pow_prime_pow_eq_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ValuationSubring_IsFrobeniusAt_apply_eq_pow_of_pow_prime_pow_eq_one
+
+private theorem apply_eq_pow_of_pow_eq_one_of_not_dvd
+    {q n : ℕ} (hq : q.Prime) (hn : ¬ q ∣ n)
+    (A : ValuationSubring (AlgebraicClosure ℚ)) (hA : A.LiesOverPrime q)
+    {σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ} (hσ : A.IsFrobeniusAt σ q)
+    (ζ : AlgebraicClosure ℚ) (hζ : ζ ^ n = 1) :
+    σ ζ = ζ ^ q := by
+  classical
+  have hn0 : n ≠ 0 := by
+    rintro rfl
+    exact hn (dvd_zero q)
+  have hζA : ζ ∈ A := by
+    rcases A.mem_or_inv_mem ζ with h | h
+    · exact h
+    · have h1 : ζ ^ (n - 1) * ζ = 1 := by
+        rw [← pow_succ, Nat.sub_add_cancel (Nat.one_le_iff_ne_zero.mpr hn0), hζ]
+      have h2 : ζ⁻¹ ^ (n - 1) = ζ := by
+        rw [inv_pow]
+        exact inv_eq_of_mul_eq_one_right h1
+      rw [← h2]
+      exact pow_mem h (n - 1)
+  have hu : σ ζ ∈ A :=
+    ((⟨σ, hσ.mem_decompositionSubgroup⟩ : A.decompositionSubgroup ℚ) • (⟨ζ, hζA⟩ : A)).2
+  have hw : ζ ^ q ∈ A := pow_mem hζA q
+  have hap : (⟨σ ζ, hu⟩ : A) ^ n = 1 := by
+    have h1 : (σ ζ) ^ n = 1 := by rw [← map_pow, hζ, map_one]
+    exact Subtype.ext (by push_cast; exact h1)
+  have hbp : (⟨ζ ^ q, hw⟩ : A) ^ n = 1 := by
+    have h1 : (ζ ^ q) ^ n = 1 := by rw [← pow_mul, mul_comm q n, pow_mul, hζ, one_pow]
+    exact Subtype.ext (by push_cast; exact h1)
+  have hres : IsLocalRing.residue A (⟨σ ζ, hu⟩ : A) =
+      IsLocalRing.residue A (⟨ζ ^ q, hw⟩ : A) := by
+    have h1 := hσ.smul_residue_eq (IsLocalRing.residue A (⟨ζ, hζA⟩ : A))
+    rw [← IsLocalRing.ResidueField.residue_smul] at h1
+    rw [show (⟨σ, hσ.mem_decompositionSubgroup⟩ : A.decompositionSubgroup ℚ) • (⟨ζ, hζA⟩ : A)
+        = ⟨σ ζ, hu⟩ from Subtype.ext rfl] at h1
+    rw [← map_pow] at h1
+    rw [show (⟨ζ, hζA⟩ : A) ^ q = ⟨ζ ^ q, hw⟩ from Subtype.ext (by push_cast; rfl)] at h1
+    exact h1
+  by_contra hne
+  have hab : (⟨σ ζ, hu⟩ : A) - ⟨ζ ^ q, hw⟩ ≠ 0 := by
+    intro h
+    exact hne (congrArg Subtype.val (sub_eq_zero.mp h))
+  have key : (∑ i ∈ Finset.range n, (⟨σ ζ, hu⟩ : A) ^ i * (⟨ζ ^ q, hw⟩ : A) ^ (n - 1 - i)) *
+      ((⟨σ ζ, hu⟩ : A) - ⟨ζ ^ q, hw⟩) = 0 := by
+    rw [geom_sum₂_mul, hap, hbp, sub_self]
+  have hS : (∑ i ∈ Finset.range n, (⟨σ ζ, hu⟩ : A) ^ i * (⟨ζ ^ q, hw⟩ : A) ^ (n - 1 - i)) = 0 :=
+    (mul_eq_zero.mp key).resolve_right hab
+  have hsum : (n : IsLocalRing.ResidueField A) *
+      IsLocalRing.residue A (⟨ζ ^ q, hw⟩ : A) ^ (n - 1) = 0 := by
+    have h0 := congrArg (IsLocalRing.residue A) hS
+    rw [map_sum, _root_.map_zero] at h0
+    have h1 : ∀ i ∈ Finset.range n,
+        IsLocalRing.residue A ((⟨σ ζ, hu⟩ : A) ^ i * (⟨ζ ^ q, hw⟩ : A) ^ (n - 1 - i))
+          = IsLocalRing.residue A (⟨ζ ^ q, hw⟩ : A) ^ (n - 1) := by
+      intro i hi
+      have hip : i + (n - 1 - i) = n - 1 := by
+        have := Finset.mem_range.mp hi
+        omega
+      rw [map_mul, map_pow, map_pow, hres, ← pow_add, hip]
+    rw [Finset.sum_congr rfl h1, Finset.sum_const, Finset.card_range, nsmul_eq_mul] at h0
+    exact h0
+  have htne : IsLocalRing.residue A (⟨ζ ^ q, hw⟩ : A) ^ (n - 1) ≠ 0 := by
+    apply pow_ne_zero
+    intro h0
+    have h1 : IsLocalRing.residue A (⟨ζ ^ q, hw⟩ : A) ^ n = 1 := by
+      rw [← map_pow, hbp, map_one]
+    rw [h0, zero_pow hn0] at h1
+    exact zero_ne_one h1
+  have hn' : (n : IsLocalRing.ResidueField A) = 0 := (mul_eq_zero.mp hsum).resolve_right htne
+  have hchar : CharP (IsLocalRing.ResidueField A) q := by
+    rw [CharP.charP_iff_prime_eq_zero hq]
+    have hqA : ((q : A) : AlgebraicClosure ℚ) ∈ A.nonunits := by
+      simp only [SubringClass.coe_natCast] at hA ⊢; exact hA
+    have hmax : (q : A) ∈ IsLocalRing.maximalIdeal A := A.coe_mem_nonunits_iff.mp hqA
+    have hc : ((q : ℕ) : IsLocalRing.ResidueField A) = IsLocalRing.residue A ((q : ℕ) : A) := by
+      simp
+    rw [hc]
+    exact Ideal.Quotient.eq_zero_iff_mem.mpr hmax
+  exact hn ((CharP.cast_eq_zero_iff _ q n).mp hn')
+
+theorem solution
+    {p q : ℕ} (hp : p.Prime) (hq : q.Prime) (hqp : q ≠ p)
+    (A : ValuationSubring (AlgebraicClosure ℚ)) (hA : A.LiesOverPrime q)
+    {σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ} (hσ : A.IsFrobeniusAt σ q)
+    (k : ℕ) (ζ : AlgebraicClosure ℚ) (hζ : ζ ^ p ^ k = 1) :
+    σ ζ = ζ ^ q :=
+  apply_eq_pow_of_pow_eq_one_of_not_dvd hq
+    (fun h => hqp ((Nat.prime_dvd_prime_iff_eq hq hp).mp (hq.dvd_of_dvd_pow h))) A hA hσ ζ hζ
+
+end S_ValuationSubring_IsFrobeniusAt_apply_eq_pow_of_pow_prime_pow_eq_one
+end P2MW
+export P2MW.S_ValuationSubring_IsFrobeniusAt_apply_eq_pow_of_pow_prime_pow_eq_one (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem ValuationSubring.IsFrobeniusAt.apply_eq_pow_of_pow_prime_pow_eq_one
+    {p q : ℕ} (hp : p.Prime) (hq : q.Prime) (hqp : q ≠ p)
+    (A : ValuationSubring (AlgebraicClosure ℚ)) (hA : A.LiesOverPrime q)
+    {σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ} (hσ : A.IsFrobeniusAt σ q)
+    (k : ℕ) (ζ : AlgebraicClosure ℚ) (hζ : ζ ^ p ^ k = 1) :
+    σ ζ = ζ ^ q :=
+  solution hp hq hqp A hA hσ k ζ hζ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ValuationSubring_exists_inertiaSubgroup_restrictNormal_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ValuationSubring_exists_inertiaSubgroup_restrictNormal_eq.lean
new file mode 100644
index 0000000000..d7fbaacdf3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ValuationSubring_exists_inertiaSubgroup_restrictNormal_eq.lean
@@ -0,0 +1,161 @@
+/-
+Based on Prove2Me node ValuationSubring.exists_inertiaSubgroup_restrictNormal_eq
+(1785ad56-b671-558c-b7b7-e21a9aa7a578) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d9ba24b2-3247-5d90-a2da-bf6603452bc1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.CharP.IntermediateField
+public import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure
+public import Mathlib.RingTheory.Valuation.RamificationGroup
+
+import Mathlib.RingTheory.Valuation.ValuationSubring
+import Mathlib.FieldTheory.Normal.Closure
+import Mathlib.FieldTheory.Normal.Defs
+import Mathlib.FieldTheory.IntermediateField.Basic
+import Mathlib.RingTheory.LocalRing.ResidueField.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Inertia subgroups restrict along finite normal subextensions of ℚ̄
+
+Theorem statement: `ValuationSubring.exists_inertiaSubgroup_restrictNormal_eq`
+(`1785ad56-b671-558c-b7b7-e21a9aa7a578`), by Claude, 2026-09-05.
+
+Proof: submission `d9ba24b2-3247-5d90-a2da-bf6603452bc1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be an intermediate field of $\overline{\mathbb{Q}}/\mathbb{Q}$ (written as
+`IntermediateField ℚ (AlgebraicClosure ℚ)`) which is finite-dimensional over $\mathbb{Q}$ and normal
+over $\mathbb{Q}$, let $A$ be a valuation subring of $\overline{\mathbb{Q}}$, and let $\sigma$ be an
+element of the inertia subgroup of $A$ over $\mathbb{Q}$, that is, an element of the stabiliser of
+$A$ under the action of $\mathrm{Aut}(\overline{\mathbb{Q}}/\mathbb{Q})$ on valuation subrings which
+acts as the identity on the residue field of $A$. Write $S$ for the valuation subring $A \cap L$ of
+$L$, formally the comap of $A$ along the structure map $L \to \overline{\mathbb{Q}}$. The assertion
+is that there exists an element $\tau$ of the inertia subgroup of $S$ over $\mathbb{Q}$ whose
+underlying $\mathbb{Q}$-algebra automorphism of $L$ is the image of the underlying automorphism of
+$\overline{\mathbb{Q}}$ attached to $\sigma$ under the restriction homomorphism
+`AlgEquiv.restrictNormalHom L`. In other words, $\sigma|_L$ lies in the inertia subgroup of $A \cap
+L$, the statement being phrased as existence of a preimage rather than as a homomorphism of groups.
+
+This is the functoriality of decomposition and inertia groups in a tower: inertia at a valuation of
+$\overline{\mathbb{Q}}$ restricts to inertia at the induced valuation of a finite normal
+subextension. It is used to verify that Galois representations with open kernel are unramified
+outside a finite set of places, and that the representation attached to an elliptic curve is
+unramified at primes of good reduction.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ValuationSubring_exists_inertiaSubgroup_restrictNormal_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ValuationSubring_exists_inertiaSubgroup_restrictNormal_eq
+
+open IsLocalRing
+open scoped Pointwise
+
+local notation "Qb" => AlgebraicClosure ℚ
+
+namespace InertiaRestrict
+
+theorem inertia_restrictNormal (L : IntermediateField ℚ Qb) [FiniteDimensional ℚ L]
+    [Normal ℚ L] (A : ValuationSubring Qb) (σ : A.inertiaSubgroup ℚ) :
+    ∃ τ : (A.comap (algebraMap L Qb)).inertiaSubgroup ℚ,
+      ((τ : (A.comap (algebraMap L Qb)).decompositionSubgroup ℚ) : L ≃ₐ[ℚ] L)
+        = AlgEquiv.restrictNormalHom L
+            ((σ : A.decompositionSubgroup ℚ) : Qb ≃ₐ[ℚ] Qb) := by
+  obtain ⟨⟨σ₀, hσdec⟩, hσin⟩ := σ
+  set S : ValuationSubring L := A.comap (algebraMap L Qb) with hS
+  set τ₀ : L ≃ₐ[ℚ] L := AlgEquiv.restrictNormalHom L σ₀ with hτ₀
+  have hσA : σ₀ • A = A := hσdec
+  have hcomm : ∀ x : L, algebraMap L Qb (τ₀ x) = σ₀ (algebraMap L Qb x) := fun x =>
+    AlgEquiv.restrictNormal_commutes σ₀ L x
+  have hcomm_inv : ∀ x : L, algebraMap L Qb (τ₀⁻¹ x) = σ₀⁻¹ (algebraMap L Qb x) := by
+    intro x
+    have : τ₀⁻¹ = AlgEquiv.restrictNormalHom L σ₀⁻¹ := by
+      rw [hτ₀, ← map_inv]
+    rw [this]
+    exact AlgEquiv.restrictNormal_commutes σ₀⁻¹ L x
+  have hτdec : τ₀ ∈ S.decompositionSubgroup ℚ := by
+    rw [MulAction.mem_stabilizer_iff]
+    ext x
+    rw [ValuationSubring.mem_pointwise_smul_iff_inv_smul_mem, ValuationSubring.mem_comap,
+      ValuationSubring.mem_comap]
+    have hx : algebraMap L Qb (τ₀⁻¹ • x) = σ₀⁻¹ • (algebraMap L Qb x) := hcomm_inv x
+    rw [hx, ← ValuationSubring.mem_pointwise_smul_iff_inv_smul_mem, hσA]
+  set ι : S →+* A :=
+    RingHom.codRestrict ((algebraMap L Qb).comp S.subtype) A.toSubring
+      (fun x => ValuationSubring.mem_comap.mp x.2) with hι
+  have hσres : ∀ b : A, IsLocalRing.residue A ((⟨σ₀, hσdec⟩ : A.decompositionSubgroup ℚ) • b)
+      = IsLocalRing.residue A b := by
+    intro b
+    have h1 : MulSemiringAction.toRingAut (A.decompositionSubgroup ℚ)
+        (IsLocalRing.ResidueField A) ⟨σ₀, hσdec⟩ = 1 := hσin
+    have h2 := RingEquiv.ext_iff.mp h1 (IsLocalRing.residue A b)
+    rw [IsLocalRing.ResidueField.residue_smul]
+    exact h2
+  have hτin : (⟨τ₀, hτdec⟩ : S.decompositionSubgroup ℚ) ∈ S.inertiaSubgroup ℚ := by
+    rw [ValuationSubring.inertiaSubgroup, MonoidHom.mem_ker]
+    apply RingEquiv.ext
+    intro r
+    obtain ⟨y, rfl⟩ := Ideal.Quotient.mk_surjective r
+    change (⟨τ₀, hτdec⟩ : S.decompositionSubgroup ℚ) • IsLocalRing.residue S y
+      = IsLocalRing.residue S y
+    rw [← IsLocalRing.ResidueField.residue_smul]
+    have key : (⟨τ₀, hτdec⟩ : S.decompositionSubgroup ℚ) • y - y ∈ IsLocalRing.maximalIdeal S := by
+      have himg : ι ((⟨τ₀, hτdec⟩ : S.decompositionSubgroup ℚ) • y - y)
+          ∈ IsLocalRing.maximalIdeal A := by
+        have hιsmul : ι ((⟨τ₀, hτdec⟩ : S.decompositionSubgroup ℚ) • y)
+            = (⟨σ₀, hσdec⟩ : A.decompositionSubgroup ℚ) • ι y := by
+          apply Subtype.ext
+          exact hcomm y.val
+        rw [map_sub, hιsmul]
+        have := hσres (ι y)
+        exact Ideal.Quotient.eq.mp this
+      rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff] at himg ⊢
+      exact fun h => himg (h.map ι)
+    exact Ideal.Quotient.eq.mpr key
+  exact ⟨⟨⟨τ₀, hτdec⟩, hτin⟩, rfl⟩
+
+end InertiaRestrict
+
+theorem solution
+    (L : IntermediateField ℚ (AlgebraicClosure ℚ)) [FiniteDimensional ℚ L] [Normal ℚ L]
+    (A : ValuationSubring (AlgebraicClosure ℚ)) (σ : A.inertiaSubgroup ℚ) :
+    ∃ τ : (A.comap (algebraMap L (AlgebraicClosure ℚ))).inertiaSubgroup ℚ,
+      ((τ : (A.comap (algebraMap L (AlgebraicClosure ℚ))).decompositionSubgroup ℚ) : L ≃ₐ[ℚ] L)
+        = AlgEquiv.restrictNormalHom L
+            ((σ : A.decompositionSubgroup ℚ) : (AlgebraicClosure ℚ) ≃ₐ[ℚ] (AlgebraicClosure ℚ)) :=
+  InertiaRestrict.inertia_restrictNormal L A σ
+
+end S_ValuationSubring_exists_inertiaSubgroup_restrictNormal_eq
+end P2MW
+export P2MW.S_ValuationSubring_exists_inertiaSubgroup_restrictNormal_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ValuationSubring.exists_inertiaSubgroup_restrictNormal_eq
+    (L : IntermediateField ℚ (AlgebraicClosure ℚ)) [FiniteDimensional ℚ L] [Normal ℚ L]
+    (A : ValuationSubring (AlgebraicClosure ℚ)) (σ : A.inertiaSubgroup ℚ) :
+    ∃ τ : (A.comap (algebraMap L (AlgebraicClosure ℚ))).inertiaSubgroup ℚ,
+      ((τ : (A.comap (algebraMap L (AlgebraicClosure ℚ))).decompositionSubgroup ℚ) : L ≃ₐ[ℚ] L)
+        = AlgEquiv.restrictNormalHom L
+            ((σ : A.decompositionSubgroup ℚ) : (AlgebraicClosure ℚ) ≃ₐ[ℚ] (AlgebraicClosure ℚ)) :=
+  solution L A σ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ValuationSubring_exists_liesOverPrime_algebraicClosure_rat.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ValuationSubring_exists_liesOverPrime_algebraicClosure_rat.lean
new file mode 100644
index 0000000000..cd478eb6f6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ValuationSubring_exists_liesOverPrime_algebraicClosure_rat.lean
@@ -0,0 +1,97 @@
+/-
+Based on Prove2Me node ValuationSubring.exists_liesOverPrime_algebraicClosure_rat
+(795b03fc-3cbd-5c73-b6fd-dece3e952452) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b4096d24-db4c-5f89-a827-0e0e0df72678
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Ramification
+
+import Mathlib.RingTheory.Valuation.LocalSubring
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of a place of ℚ̄ above each prime p
+
+Theorem statement: `ValuationSubring.exists_liesOverPrime_algebraicClosure_rat`
+(`795b03fc-3cbd-5c73-b6fd-dece3e952452`), by Claude, 2026-09-05.
+
+Proof: submission `b4096d24-db4c-5f89-a827-0e0e0df72678`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $p$ be a prime number (an element of `Nat.Primes`, so a natural number together with the witness
+that it is prime). The assertion is that there exists a valuation subring $A$ of the field
+$\mathrm{AlgebraicClosure}\ \mathbb{Q}$, i.e. a subring $A \subseteq \overline{\mathbb{Q}}$ such
+that for every $x \in \overline{\mathbb{Q}}$ either $x \in A$ or $x^{-1} \in A$, satisfying the
+project's predicate [`ValuationSubring.LiesOverPrime`](def/FLTPrelim_Ramification.html#L16) for the
+natural number underlying $p$. By definition this predicate says that the image of $p$ under the
+canonical map $\mathbb{N} \to \overline{\mathbb{Q}}$ lies in the set of nonunits of $A$: that is,
+$p$ belongs to $A$ and is not invertible in $A$, equivalently $p$ lies in the maximal ideal of the
+valuation ring $A$. No hypotheses beyond the primality of $p$ are imposed, and nothing is asserted
+about the value group of $A$, its residue field, or uniqueness of $A$.
+
+This is the existence of a place of $\overline{\mathbb{Q}}$ extending the $p$-adic place of
+$\mathbb{Q}$, in the weak form needed downstream: a valuation subring of $\overline{\mathbb{Q}}$ in
+whose maximal ideal $p$ lies. It serves as the source of $p$-adic places in the
+ramification-theoretic parts of the development, and is invoked widely (for instance in the
+conductor and Čerednik–Drinfel'd strands).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ValuationSubring_exists_liesOverPrime_algebraicClosure_rat.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ValuationSubring_exists_liesOverPrime_algebraicClosure_rat
+
+theorem solution (p : Nat.Primes) :
+    ∃ A : ValuationSubring (AlgebraicClosure ℚ), A.LiesOverPrime (p : ℕ) := by
+  have hq : (p : ℕ).Prime := p.2
+  set R : Subring (AlgebraicClosure ℚ) := ⊥ with hR
+  have hqR : ¬IsUnit (((p : ℕ) : ℕ) : R) := by
+    rw [isUnit_iff_exists_inv]
+    rintro ⟨y, hy⟩
+    have hy' : ((p : ℕ) : AlgebraicClosure ℚ) * (y : AlgebraicClosure ℚ) = 1 := by
+      have := congrArg (R.subtype) hy
+      simpa using this
+    obtain ⟨n, hn⟩ := Subring.mem_bot.mp y.2
+    rw [← hn] at hy'
+    have hqn : ((p : ℕ) : ℤ) * n = 1 := by
+      have : ((((p : ℕ) : ℤ) * n : ℤ) : AlgebraicClosure ℚ) = ((1 : ℤ) : AlgebraicClosure ℚ) := by
+        push_cast
+        linear_combination hy'
+      exact_mod_cast this
+    have h1 : ((p : ℕ) : ℤ) ≤ 1 := Int.le_of_dvd one_pos ⟨n, hqn.symm⟩
+    have h2 : 2 ≤ (p : ℕ) := hq.two_le
+    omega
+  obtain ⟨B, -, hB⟩ :=
+    Ideal.image_subset_nonunits_valuationSubring (Ideal.span {(((p : ℕ) : ℕ) : R)})
+      (fun h => hqR (Ideal.span_singleton_eq_top.mp h))
+  refine ⟨B, hB ⟨(((p : ℕ) : ℕ) : R), Ideal.subset_span rfl, ?_⟩⟩
+  simp
+
+end S_ValuationSubring_exists_liesOverPrime_algebraicClosure_rat
+end P2MW
+export P2MW.S_ValuationSubring_exists_liesOverPrime_algebraicClosure_rat (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ValuationSubring.exists_liesOverPrime_algebraicClosure_rat (p : Nat.Primes) :
+    ∃ A : ValuationSubring (AlgebraicClosure ℚ), A.LiesOverPrime (p : ℕ) :=
+  solution p
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ValuationSubring_exists_liesOverPrime_mem_inertiaSubgroupIn.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ValuationSubring_exists_liesOverPrime_mem_inertiaSubgroupIn.lean
new file mode 100644
index 0000000000..a6d8071e55
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ValuationSubring_exists_liesOverPrime_mem_inertiaSubgroupIn.lean
@@ -0,0 +1,374 @@
+/-
+Based on Prove2Me node ValuationSubring.exists_liesOverPrime_mem_inertiaSubgroupIn
+(72bd3f89-9448-5182-937f-7dc173982435) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a2590b5e-c56f-5f97-b4c6-9bbe6a5af10b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Ramification
+
+import Mathlib.Algebra.Algebra.Rat
+import Mathlib.NumberTheory.NumberField.Basic
+import Mathlib.RingTheory.DedekindDomain.Dvr
+import Mathlib.RingTheory.Valuation.ValuationRing
+import Mathlib.RingTheory.Valuation.ValuationSubring
+import Mathlib.RingTheory.Valuation.LocalSubring
+import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Inertial automorphism lies in inertia of a place above q
+
+Theorem statement: `ValuationSubring.exists_liesOverPrime_mem_inertiaSubgroupIn`
+(`72bd3f89-9448-5182-937f-7dc173982435`), by Claude, 2026-09-05.
+
+Proof: submission `a2590b5e-c56f-5f97-b4c6-9bbe6a5af10b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\overline{\mathbb Z}$ denote the integral closure of $\mathbb Z$ in $\overline{\mathbb Q} =$
+`AlgebraicClosure ℚ`, and let $\mathfrak Q$ be a maximal ideal of $\overline{\mathbb Z}$. Let $q$ be
+a prime number whose image in $\overline{\mathbb Z}$ lies in $\mathfrak Q$. Let $\sigma$ be a
+$\mathbb Q$-algebra automorphism of $\overline{\mathbb Q}$ such that for every $b \in
+\overline{\mathbb Z}$ there is some $c \in \mathfrak Q$ whose image in $\overline{\mathbb Q}$ equals
+$\sigma(b) - b$; that is, $\sigma$ acts trivially on $\overline{\mathbb Z}/\mathfrak Q$. The
+conclusion asserts the existence of a valuation subring $A$ of $\overline{\mathbb Q}$ with two
+properties: first, `A.LiesOverPrime q`, meaning that the image of $q$ in $\overline{\mathbb Q}$
+belongs to the nonunits of $A$, i.e. to the maximal ideal of $A$; and second, $\sigma$ belongs to
+`A.inertiaSubgroupIn ℚ`, the image in $\mathrm{Gal}(\overline{\mathbb Q}/\mathbb Q)$, under the
+inclusion of the decomposition subgroup of $A$ over $\mathbb Q$, of Mathlib's inertia subgroup of
+$A$ over $\mathbb Q$.
+
+This is the valuation-theoretic half of the comparison between Hilbert's ideal-theoretic
+ramification theory for $\overline{\mathbb Z}$ and the `ValuationSubring` formulation of
+decomposition and inertia groups: a maximal ideal $\mathfrak Q$ of $\overline{\mathbb Z}$ above $q$
+gives rise to a place of $\overline{\mathbb Q}$ above $q$ (the localisation of $\overline{\mathbb
+Z}$ at $\mathfrak Q$, $\overline{\mathbb Z}$ being a Prüfer domain), and an automorphism inertial at
+$\mathfrak Q$ is inertial at that place. It is used in the arguments bounding images of inertia and
+in identifying Galois subgroups generated by inertia subgroups, which enter the Mazur step of the
+Fermat argument.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ValuationSubring_exists_liesOverPrime_mem_inertiaSubgroupIn.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ValuationSubring_exists_liesOverPrime_mem_inertiaSubgroupIn
+
+open scoped NumberField
+
+namespace M3dS12D0
+
+variable {F : Type*} [Field F] [NumberField F]
+
+theorem exists_div_rep_or_inv_div_rep_of_ne_bot (P : Ideal (𝓞 F)) [P.IsPrime]
+    (hP : P ≠ ⊥) (x : F) (hx : x ≠ 0) :
+    (∃ a s : 𝓞 F, s ∉ P ∧ x = algebraMap (𝓞 F) F a / algebraMap (𝓞 F) F s) ∨
+      ∃ a s : 𝓞 F, a ∈ P ∧ s ∉ P ∧ x⁻¹ = algebraMap (𝓞 F) F a / algebraMap (𝓞 F) F s := by
+  obtain ⟨n, d, hd, hnd⟩ := IsFractionRing.div_surjective (A := 𝓞 F) x
+  have hφ : Function.Injective (algebraMap (𝓞 F) F) := IsFractionRing.injective (𝓞 F) F
+  have hd0 : d ≠ 0 := nonZeroDivisors.ne_zero hd
+  have hn0 : n ≠ 0 := by
+    rintro rfl
+    rw [map_zero, zero_div] at hnd
+    exact hx hnd.symm
+  have hnF : algebraMap (𝓞 F) F n ≠ 0 := fun h0 => hn0 (hφ (by rw [h0, map_zero]))
+  have hdF : algebraMap (𝓞 F) F d ≠ 0 := fun h0 => hd0 (hφ (by rw [h0, map_zero]))
+  have : IsDomain (Localization.AtPrime P) :=
+    IsLocalization.isDomain_of_local_atPrime ‹P.IsPrime›
+  have : IsDiscreteValuationRing (Localization.AtPrime P) :=
+    IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain (𝓞 F) hP _
+  obtain ⟨c, hc | hc⟩ :=
+    ValuationRing.cond (algebraMap (𝓞 F) (Localization.AtPrime P) n)
+      (algebraMap (𝓞 F) (Localization.AtPrime P) d)
+  · obtain ⟨⟨a, s⟩, rfl⟩ := IsLocalization.mk'_surjective P.primeCompl c
+    have hsP : (s : 𝓞 F) ∉ P := s.2
+    have hsF : algebraMap (𝓞 F) F (s : 𝓞 F) ≠ 0 := fun h0 =>
+      hsP (by rw [show (s : 𝓞 F) = 0 from hφ (by rw [h0, map_zero])]; exact P.zero_mem)
+    have key : algebraMap (𝓞 F) (Localization.AtPrime P) (n * a)
+        = algebraMap (𝓞 F) (Localization.AtPrime P) (d * s) := by
+      rw [map_mul, map_mul, ← IsLocalization.mk'_spec (Localization.AtPrime P) a s, ← hc]
+      ring
+    obtain ⟨t, ht⟩ :=
+      (IsLocalization.eq_iff_exists P.primeCompl (Localization.AtPrime P)).mp key
+    have ht0 : (t : 𝓞 F) ≠ 0 :=
+      nonZeroDivisors.ne_zero (P.primeCompl_le_nonZeroDivisors t.2)
+    have hEq : n * a = d * (s : 𝓞 F) := mul_left_cancel₀ ht0 ht
+    have hF : algebraMap (𝓞 F) F n * algebraMap (𝓞 F) F a
+        = algebraMap (𝓞 F) F d * algebraMap (𝓞 F) F (s : 𝓞 F) := by
+      rw [← map_mul, ← map_mul, hEq]
+    have hxinv : x⁻¹ = algebraMap (𝓞 F) F a / algebraMap (𝓞 F) F (s : 𝓞 F) := by
+      rw [← hnd, inv_div, div_eq_div_iff hnF hsF]
+      linear_combination -hF
+    by_cases haP : a ∈ P
+    · exact Or.inr ⟨a, s, haP, hsP, hxinv⟩
+    · refine Or.inl ⟨(s : 𝓞 F), a, haP, ?_⟩
+      rw [← inv_inv x, hxinv, inv_div]
+  · obtain ⟨⟨a, s⟩, rfl⟩ := IsLocalization.mk'_surjective P.primeCompl c
+    have hsP : (s : 𝓞 F) ∉ P := s.2
+    have hsF : algebraMap (𝓞 F) F (s : 𝓞 F) ≠ 0 := fun h0 =>
+      hsP (by rw [show (s : 𝓞 F) = 0 from hφ (by rw [h0, map_zero])]; exact P.zero_mem)
+    have key : algebraMap (𝓞 F) (Localization.AtPrime P) (d * a)
+        = algebraMap (𝓞 F) (Localization.AtPrime P) (n * s) := by
+      rw [map_mul, map_mul, ← IsLocalization.mk'_spec (Localization.AtPrime P) a s, ← hc]
+      ring
+    obtain ⟨t, ht⟩ :=
+      (IsLocalization.eq_iff_exists P.primeCompl (Localization.AtPrime P)).mp key
+    have ht0 : (t : 𝓞 F) ≠ 0 :=
+      nonZeroDivisors.ne_zero (P.primeCompl_le_nonZeroDivisors t.2)
+    have hEq : d * a = n * (s : 𝓞 F) := mul_left_cancel₀ ht0 ht
+    have hF : algebraMap (𝓞 F) F d * algebraMap (𝓞 F) F a
+        = algebraMap (𝓞 F) F n * algebraMap (𝓞 F) F (s : 𝓞 F) := by
+      rw [← map_mul, ← map_mul, hEq]
+    refine Or.inl ⟨a, s, hsP, ?_⟩
+    rw [← hnd, div_eq_div_iff hdF hsF]
+    linear_combination -hF
+
+end M3dS12D0
+
+theorem M3dS12D0.d0 (A : ValuationSubring (AlgebraicClosure ℚ)) {q : ℕ} (hq : q.Prime)
+    (hA : A.LiesOverPrime q) (a : AlgebraicClosure ℚ) (ha : a ∈ A) :
+    ∃ x s : integralClosure ℤ (AlgebraicClosure ℚ),
+      (s : AlgebraicClosure ℚ) ∉ A.nonunits ∧ a * s = x := by
+  classical
+  have halg : Algebra.IsAlgebraic ℚ (AlgebraicClosure ℚ) := by
+    have h : @Algebra.IsAlgebraic ℚ (AlgebraicClosure ℚ) _ _ (AlgebraicClosure.instAlgebra ℚ) :=
+      inferInstance
+    exact h
+  have int_mem : ∀ b : (AlgebraicClosure ℚ), IsIntegral ℤ b → b ∈ A := by
+    intro b hb
+    have hbA : IsIntegral A b := by
+      obtain ⟨p, hp, hpb⟩ := hb
+      refine ⟨p.map (Int.castRingHom A), hp.map _, ?_⟩
+      rw [Polynomial.eval₂_map]
+      have : (algebraMap A (AlgebraicClosure ℚ)).comp (Int.castRingHom A)
+          = algebraMap ℤ (AlgebraicClosure ℚ) := RingHom.ext_int _ _
+      rw [this]
+      exact hpb
+    obtain ⟨y, hy⟩ :=
+      (IsIntegrallyClosed.isIntegral_iff (R := A) (K := AlgebraicClosure ℚ)).mp hbA
+    rw [← hy]
+    exact y.2
+  by_cases ha0 : a = 0
+  · refine ⟨0, 1, ?_, by simp [ha0]⟩
+    rw [OneMemClass.coe_one, ValuationSubring.mem_nonunits_iff, map_one]
+    exact lt_irrefl 1
+  have haint : IsIntegral ℚ a := Algebra.IsIntegral.isIntegral a
+  let F : IntermediateField ℚ (AlgebraicClosure ℚ) := IntermediateField.adjoin ℚ {a}
+  have hFfd : FiniteDimensional ℚ F := IntermediateField.adjoin.finiteDimensional haint
+  have : NumberField F :=
+    { to_charZero := charZero_of_injective_algebraMap (algebraMap ℚ F).injective
+      to_finiteDimensional := hFfd }
+  have hOA : ∀ b : 𝓞 F, algebraMap F (AlgebraicClosure ℚ) (algebraMap (𝓞 F) F b) ∈ A := fun b =>
+    int_mem _ (map_isIntegral_int (algebraMap F (AlgebraicClosure ℚ))
+      (NumberField.RingOfIntegers.isIntegral_coe b))
+  let φ : 𝓞 F →+* A :=
+    ((algebraMap F (AlgebraicClosure ℚ)).comp (algebraMap (𝓞 F) F)).codRestrict A.toSubring (fun b
+      => hOA b)
+  have hφ : ∀ b : 𝓞 F, (φ b : (AlgebraicClosure ℚ)) = algebraMap F (AlgebraicClosure ℚ) (algebraMap
+    (𝓞 F) F b) :=
+    fun b => rfl
+  let P : Ideal (𝓞 F) := Ideal.comap φ (IsLocalRing.maximalIdeal A)
+  have hPprime : P.IsPrime := Ideal.IsPrime.comap φ
+  have hmemP : ∀ b : 𝓞 F, b ∈ P ↔ algebraMap F (AlgebraicClosure ℚ) (algebraMap (𝓞 F) F b) ∈
+    A.nonunits :=
+    by
+    intro b
+    rw [← hφ, ValuationSubring.coe_mem_nonunits_iff]
+    rfl
+  have hqP : (q : 𝓞 F) ∈ P := by
+    rw [hmemP, map_natCast, map_natCast]
+    exact hA
+  have hPbot : P ≠ ⊥ := by
+    intro hbot
+    rw [hbot, Ideal.mem_bot] at hqP
+    exact hq.ne_zero (Nat.cast_eq_zero.mp hqP)
+  have hval1 : ∀ s : 𝓞 F, s ∉ P → A.valuation (algebraMap F (AlgebraicClosure ℚ) (algebraMap (𝓞 F) F
+    s)) = 1 :=
+    by
+    intro s hs
+    refine le_antisymm ((A.valuation_le_one_iff _).mpr (hOA s)) (not_lt.mp fun hlt => hs ?_)
+    rw [hmemP, ValuationSubring.mem_nonunits_iff]
+    exact hlt
+  let a' : F := ⟨a, IntermediateField.mem_adjoin_simple_self ℚ a⟩
+  have ha' : algebraMap F (AlgebraicClosure ℚ) a' = a := rfl
+  have ha'0 : a' ≠ 0 := fun h => ha0 (by rw [← ha', h, map_zero])
+  have hint : ∀ b : 𝓞 F, IsIntegral ℤ (algebraMap F (AlgebraicClosure ℚ) (algebraMap (𝓞 F) F b)) :=
+    fun b =>
+    map_isIntegral_int (algebraMap F (AlgebraicClosure ℚ))
+      (NumberField.RingOfIntegers.isIntegral_coe b)
+  rcases exists_div_rep_or_inv_div_rep_of_ne_bot P hPbot a' ha'0 with
+    ⟨b, s, hs, hrep⟩ | ⟨b, s, hb, hs, hrep⟩
+  · have hsK : algebraMap F (AlgebraicClosure ℚ) (algebraMap (𝓞 F) F s) ≠ 0 := by
+      intro h0
+      have := hval1 s hs
+      rw [h0, map_zero] at this
+      exact zero_ne_one this
+    refine ⟨⟨_, hint b⟩, ⟨_, hint s⟩, ?_, ?_⟩
+    · change algebraMap F (AlgebraicClosure ℚ) (algebraMap (𝓞 F) F s) ∉ A.nonunits
+      rw [ValuationSubring.mem_nonunits_iff, hval1 s hs]
+      exact lt_irrefl 1
+    · change a * algebraMap F (AlgebraicClosure ℚ) (algebraMap (𝓞 F) F s) = algebraMap F
+        (AlgebraicClosure ℚ) (algebraMap (𝓞 F) F b)
+      rw [← ha', hrep, map_div₀, div_mul_cancel₀ _ hsK]
+  · exfalso
+    have hlt : A.valuation a⁻¹ < 1 := by
+      have : a⁻¹ = algebraMap F (AlgebraicClosure ℚ) (algebraMap (𝓞 F) F b) / algebraMap F
+        (AlgebraicClosure ℚ) (algebraMap (𝓞 F) F s) :=
+        by
+        rw [← ha', ← map_inv₀, hrep, map_div₀]
+      rw [this, map_div₀, hval1 s hs, div_one, ← ValuationSubring.mem_nonunits_iff, ← hmemP]
+      exact hb
+    have hle : A.valuation a ≤ 1 := (A.valuation_le_one_iff a).mpr ha
+    have hone : A.valuation a * A.valuation a⁻¹ = 1 := by
+      rw [← map_mul, mul_inv_cancel₀ ha0, map_one]
+    have hprod : A.valuation a * A.valuation a⁻¹ < 1 := by
+      calc A.valuation a * A.valuation a⁻¹ ≤ A.valuation a⁻¹ := mul_le_of_le_one_left' hle
+        _ < 1 := hlt
+    exact absurd hone (ne_of_lt hprod)
+
+open scoped Pointwise in
+open M3dS12D0 in
+theorem solution (𝔔 : Ideal (integralClosure ℤ (AlgebraicClosure ℚ))) [𝔔.IsMaximal] {q : ℕ}
+    (hq : q.Prime) (hq𝔔 : (q : integralClosure ℤ (AlgebraicClosure ℚ)) ∈ 𝔔)
+    (σ : (AlgebraicClosure ℚ) ≃ₐ[ℚ] (AlgebraicClosure ℚ))
+    (hσ : ∀ b : integralClosure ℤ (AlgebraicClosure ℚ),
+      ∃ c ∈ 𝔔, (c : AlgebraicClosure ℚ) = σ b - b) :
+    ∃ A : ValuationSubring (AlgebraicClosure ℚ), A.LiesOverPrime q ∧ σ ∈ A.inertiaSubgroupIn ℚ := by
+  classical
+  obtain ⟨A, hOA, h𝔔A⟩ := Ideal.image_subset_nonunits_valuationSubring
+    (A := (integralClosure ℤ (AlgebraicClosure ℚ)).toSubring) 𝔔 (Ideal.IsMaximal.ne_top ‹_›)
+  have hmemA : ∀ b : integralClosure ℤ (AlgebraicClosure ℚ), (b : AlgebraicClosure ℚ) ∈ A :=
+    fun b => hOA b.2
+  have h𝔔nu : ∀ c ∈ 𝔔, (c : AlgebraicClosure ℚ) ∈ A.nonunits := fun c hc =>
+    h𝔔A ⟨c, hc, rfl⟩
+  have hA : A.LiesOverPrime q := by
+    have := h𝔔nu _ hq𝔔
+    simp only [SubringClass.coe_natCast] at this
+    exact this
+  let φ : integralClosure ℤ (AlgebraicClosure ℚ) →+* A :=
+    (integralClosure ℤ (AlgebraicClosure ℚ)).val.toRingHom.codRestrict A.toSubring hmemA
+  let J : Ideal (integralClosure ℤ (AlgebraicClosure ℚ)) :=
+    Ideal.comap φ (IsLocalRing.maximalIdeal A)
+  have hmemJ : ∀ b, b ∈ J ↔ (b : AlgebraicClosure ℚ) ∈ A.nonunits := by
+    intro b
+    rw [Ideal.mem_comap, ← ValuationSubring.coe_mem_nonunits_iff]
+    rfl
+  have hJ : J = 𝔔 := by
+    refine (Ideal.IsMaximal.eq_of_le ‹𝔔.IsMaximal› ?_ ?_).symm
+    · exact (Ideal.IsPrime.comap φ).ne_top
+    · intro c hc
+      exact (hmemJ c).mpr (h𝔔nu c hc)
+  have hcenter : ∀ b : integralClosure ℤ (AlgebraicClosure ℚ),
+      (b : AlgebraicClosure ℚ) ∈ A.nonunits ↔ b ∈ 𝔔 := fun b => by rw [← hmemJ, hJ]
+  have key : ∀ ρ : (AlgebraicClosure ℚ) ≃ₐ[ℚ] (AlgebraicClosure ℚ),
+      (∀ b : integralClosure ℤ (AlgebraicClosure ℚ), ∃ c ∈ 𝔔, (c : AlgebraicClosure ℚ) = ρ b - b) →
+      ∀ a ∈ A, ρ a ∈ A ∧ ρ a - a ∈ A.nonunits := by
+    intro ρ hρ a ha
+    obtain ⟨x, s, hs, hax⟩ := d0 A hq hA a ha
+    have hs𝔔 : s ∉ 𝔔 := fun h => hs ((hcenter s).mpr h)
+    have hvs : A.valuation (s : AlgebraicClosure ℚ) = 1 :=
+      le_antisymm ((A.valuation_le_one_iff _).mpr (hmemA s))
+        (not_lt.mp fun hlt => hs ((ValuationSubring.mem_nonunits_iff _).mpr hlt))
+    have hvx : A.valuation (x : AlgebraicClosure ℚ) ≤ 1 := (A.valuation_le_one_iff _).mpr (hmemA x)
+    obtain ⟨c, hc, hcx⟩ := hρ x
+    obtain ⟨c', hc', hcs⟩ := hρ s
+    have hvc : A.valuation (c : AlgebraicClosure ℚ) < 1 :=
+      (ValuationSubring.mem_nonunits_iff _).mp (h𝔔nu c hc)
+    have hvc' : A.valuation (c' : AlgebraicClosure ℚ) < 1 :=
+      (ValuationSubring.mem_nonunits_iff _).mp (h𝔔nu c' hc')
+    have hρx : ρ x = x + c := by rw [hcx]; ring
+    have hρs : ρ s = s + c' := by rw [hcs]; ring
+    have hlt : A.valuation (c' : AlgebraicClosure ℚ) < A.valuation (s : AlgebraicClosure ℚ) := by
+      rw [hvs]; exact hvc'
+    have hvρs : A.valuation (ρ s) = 1 := by
+      rw [hρs, Valuation.map_add_eq_of_lt_left _ hlt, hvs]
+    have hs0 : (s : AlgebraicClosure ℚ) ≠ 0 := fun h => by
+      rw [h, map_zero] at hvs; exact zero_ne_one hvs
+    have hρs0 : ρ s ≠ 0 := fun h => by
+      rw [h, map_zero] at hvρs; exact zero_ne_one hvρs
+    have hρa : ρ a = ρ x / ρ s := by
+      rw [eq_div_iff hρs0, ← map_mul, hax]
+    have hvρx : A.valuation (ρ x) ≤ 1 := by
+      rw [hρx]
+      exact Valuation.map_add_le _ hvx hvc.le
+    refine ⟨?_, ?_⟩
+    · rw [← A.valuation_le_one_iff, hρa, map_div₀, hvρs, div_one]
+      exact hvρx
+    · have ha' : a = x / s := by rw [eq_div_iff hs0, hax]
+      have hdiff : ρ a - a = (c * s - x * c') / (ρ s * s) := by
+        rw [hρa, ha', hρx, hρs, div_sub_div _ _ (by rw [← hρs]; exact hρs0) hs0]
+        congr 1
+        ring
+      rw [ValuationSubring.mem_nonunits_iff, hdiff, map_div₀, map_mul, hvρs, hvs, one_mul,
+        div_one]
+      refine Valuation.map_sub_lt _ ?_ ?_
+      · rw [map_mul, hvs, mul_one]; exact hvc
+      · rw [map_mul]
+        calc A.valuation (x : AlgebraicClosure ℚ) * A.valuation (c' : AlgebraicClosure ℚ)
+            ≤ A.valuation (c' : AlgebraicClosure ℚ) := mul_le_of_le_one_left' hvx
+          _ < 1 := hvc'
+  have hσinv : ∀ b : integralClosure ℤ (AlgebraicClosure ℚ),
+      ∃ c ∈ 𝔔, (c : AlgebraicClosure ℚ) = σ⁻¹ b - b := by
+    intro b
+    have hb' : IsIntegral ℤ (σ⁻¹ (b : AlgebraicClosure ℚ)) := map_isIntegral_int _ b.2
+    obtain ⟨c, hc, hcb⟩ := hσ ⟨_, hb'⟩
+    refine ⟨-c, 𝔔.neg_mem hc, ?_⟩
+    rw [NegMemClass.coe_neg, hcb]
+    change -(σ (σ⁻¹ (b : AlgebraicClosure ℚ)) - σ⁻¹ (b : AlgebraicClosure ℚ))
+      = σ⁻¹ (b : AlgebraicClosure ℚ) - (b : AlgebraicClosure ℚ)
+    rw [← AlgEquiv.mul_apply, mul_inv_cancel, AlgEquiv.one_apply]
+    ring
+  have hstab : σ ∈ A.decompositionSubgroup ℚ := by
+    rw [ValuationSubring.decompositionSubgroup, MulAction.mem_stabilizer_iff]
+    ext x
+    rw [ValuationSubring.mem_pointwise_smul_iff_inv_smul_mem, AlgEquiv.smul_def]
+    constructor
+    · intro hx
+      have := (key σ hσ _ hx).1
+      rwa [← AlgEquiv.mul_apply, mul_inv_cancel, AlgEquiv.one_apply] at this
+    · intro hx
+      exact (key σ⁻¹ hσinv _ hx).1
+  refine ⟨A, hA, Subgroup.mem_map.mpr ⟨⟨σ, hstab⟩, ?_, rfl⟩⟩
+  rw [ValuationSubring.inertiaSubgroup, MonoidHom.mem_ker]
+  ext r
+  obtain ⟨a, rfl⟩ := IsLocalRing.residue_surjective r
+  rw [MulSemiringAction.toRingAut_apply, MulSemiringAction.toRingEquiv_apply_apply,
+    ← IsLocalRing.ResidueField.residue_smul, RingAut.one_apply, IsLocalRing.residue_def,
+    IsLocalRing.residue_def]
+  apply Ideal.Quotient.eq.mpr
+  rw [← ValuationSubring.coe_mem_nonunits_iff]
+  exact (key σ hσ a a.2).2
+
+end S_ValuationSubring_exists_liesOverPrime_mem_inertiaSubgroupIn
+end P2MW
+export P2MW.S_ValuationSubring_exists_liesOverPrime_mem_inertiaSubgroupIn (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem ValuationSubring.exists_liesOverPrime_mem_inertiaSubgroupIn
+    (𝔔 : Ideal (integralClosure ℤ (AlgebraicClosure ℚ))) [𝔔.IsMaximal] {q : ℕ} (hq : q.Prime)
+    (hq𝔔 : (q : integralClosure ℤ (AlgebraicClosure ℚ)) ∈ 𝔔)
+    (σ : (AlgebraicClosure ℚ) ≃ₐ[ℚ] (AlgebraicClosure ℚ))
+    (hσ : ∀ b : integralClosure ℤ (AlgebraicClosure ℚ), ∃ c ∈ 𝔔, (c : AlgebraicClosure ℚ) = σ b - b)
+    :
+    ∃ A : ValuationSubring (AlgebraicClosure ℚ), A.LiesOverPrime q ∧ σ ∈ A.inertiaSubgroupIn ℚ :=
+  solution 𝔔 hq hq𝔔 σ hσ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ValuationSubring_isDiscreteValuationRing_comap_of_liesOverPrime.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ValuationSubring_isDiscreteValuationRing_comap_of_liesOverPrime.lean
new file mode 100644
index 0000000000..f71e18fe75
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ValuationSubring_isDiscreteValuationRing_comap_of_liesOverPrime.lean
@@ -0,0 +1,231 @@
+/-
+Based on Prove2Me node ValuationSubring.isDiscreteValuationRing_comap_of_liesOverPrime
+(f9d2c7b0-3ee9-57e4-961e-19c9a3aa605e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1fa6a2aa-7d51-5d2d-9749-8239406ff45c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.DiscreteValuationRing.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Ramification
+
+import Mathlib.RingTheory.Valuation.RamificationGroup
+import Mathlib.RingTheory.Valuation.ValuationSubring
+import Mathlib.RingTheory.Valuation.Discrete.Basic
+import Mathlib.RingTheory.DedekindDomain.Dvr
+import Mathlib.RingTheory.DedekindDomain.AdicValuation
+import Mathlib.RingTheory.DedekindDomain.IntegralClosure
+import Mathlib.NumberTheory.NumberField.Basic
+import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure
+import Mathlib.FieldTheory.IntermediateField.Basic
+import Mathlib.RingTheory.Localization.AtPrime.Basic
+import Mathlib.RingTheory.Valuation.ValuationRing
+import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_FreyPackage
+import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_GaloisRep
+import Mathlib.RingTheory.Valuation.LocalSubring
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A place of ℚ̄ restricts to a DVR on a number field
+
+Theorem statement: `ValuationSubring.isDiscreteValuationRing_comap_of_liesOverPrime`
+(`f9d2c7b0-3ee9-57e4-961e-19c9a3aa605e`), by Claude, 2026-09-05.
+
+Proof: submission `1fa6a2aa-7d51-5d2d-9749-8239406ff45c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be an intermediate field of the extension $\mathbb{Q} \subseteq \overline{\mathbb{Q}}$ (the
+algebraic closure `AlgebraicClosure ℚ`) which is finite-dimensional over $\mathbb{Q}$, let $A$ be a
+valuation subring of $\overline{\mathbb{Q}}$, and let $q$ be a natural number which is prime. Assume
+`A.LiesOverPrime q`, that is, the image of $q$ in $\overline{\mathbb{Q}}$ lies in `A.nonunits`: its
+valuation is $<1$, equivalently $q$ belongs to $A$ but is not a unit of $A$, so $q$ lies in the
+maximal ideal of $A$. The conclusion is that the contraction of $A$ along the structure map $L \to
+\overline{\mathbb{Q}}$, namely the valuation subring `A.comap (algebraMap L (AlgebraicClosure ℚ))`
+of $L$ whose underlying set is $A \cap L$, is a discrete valuation ring. Thus a place of
+$\overline{\mathbb{Q}}$ whose maximal ideal contains a rational prime restricts on every number
+field inside $\overline{\mathbb{Q}}$ to a rank-one discrete valuation ring, equivalently to the
+localisation of the ring of integers of $L$ at a nonzero prime ideal.
+
+This is the finite-level statement underlying the passage from a place of $\overline{\mathbb{Q}}$ to
+the discretely valued local rings of the number fields it contains, used wherever reduction of
+arithmetic objects at a place of $\overline{\mathbb{Q}}$ is defined by descending to a finite level.
+It is invoked by the lemmas on localisations at primes and tensor products of valuation subrings and
+by the integrality statements for modular curves of full level.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ValuationSubring_isDiscreteValuationRing_comap_of_liesOverPrime.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ValuationSubring_isDiscreteValuationRing_comap_of_liesOverPrime
+
+open IsDiscreteValuationRing IsLocalRing IsDedekindDomain.HeightOneSpectrum
+open scoped NumberField Pointwise
+
+local notation "Qb" => AlgebraicClosure ℚ
+
+namespace ComapDVR
+
+set_option backward.isDefEq.respectTransparency false in
+set_option synthInstance.maxHeartbeats 800000 in
+theorem comap_isDiscreteValuationRing (L : IntermediateField ℚ Qb)
+    [FiniteDimensional ℚ L] (A : ValuationSubring Qb) (q : ℕ) (hq_prime : q.Prime)
+    (hA : A.valuation (q : Qb) < 1) :
+    IsDiscreteValuationRing (A.comap (algebraMap L Qb)) := by
+  have hA' : A.valuation (q : Qb) < 1 := hA
+  set S : ValuationSubring L := A.comap (algebraMap L Qb) with hSdef
+  have : CharZero ↥L := charZero_of_injective_algebraMap (algebraMap ℚ ↥L).injective
+  have : NumberField ↥L := ⟨⟩
+  have hOS : ∀ x : 𝓞 ↥L, algebraMap (𝓞 ↥L) ↥L x ∈ S := by
+    intro x
+    have h0 : IsIntegral ℤ (algebraMap (𝓞 ↥L) ↥L x) := x.isIntegral_coe
+    have hint : IsIntegral ↥S (algebraMap (𝓞 ↥L) ↥L x) := h0.tower_top
+    obtain ⟨y, hy⟩ := IsIntegrallyClosed.isIntegral_iff.mp hint
+    rw [← hy]; exact y.2
+  let f : 𝓞 ↥L →+* ↥S :=
+    { toFun := fun x => ⟨algebraMap (𝓞 ↥L) ↥L x, hOS x⟩
+      map_one' := Subtype.ext (map_one _)
+      map_mul' := fun a b => Subtype.ext (map_mul _ a b)
+      map_zero' := Subtype.ext (map_zero _)
+      map_add' := fun a b => Subtype.ext (map_add _ a b) }
+  have hf_inj : Function.Injective f := fun a b hab =>
+    IsFractionRing.injective (𝓞 ↥L) ↥L (congrArg (fun s : ↥S => (s : ↥L)) hab)
+  set p : Ideal (𝓞 ↥L) := Ideal.comap f (IsLocalRing.maximalIdeal ↥S) with hpdef
+  have : p.IsPrime := Ideal.IsPrime.comap f
+  have hqS : ¬ IsUnit ((q : ℕ) : ↥S) := by
+    intro h
+    obtain ⟨w, hw⟩ := h.exists_left_inv
+    have hw1 : (w : ↥L) * ((q : ℕ) : ↥L) = 1 := by
+      have := congrArg Subtype.val hw
+      push_cast at this
+      exact_mod_cast this
+    have hq1 : algebraMap ↥L Qb (w : ↥L) * ((q : ℕ) : Qb) = 1 := by
+      have := congrArg (algebraMap ↥L Qb) hw1
+      rwa [map_mul, map_natCast, map_one] at this
+    have hwA : algebraMap ↥L Qb (w : ↥L) ∈ A := ValuationSubring.mem_comap.mp w.2
+    have hv1 : A.valuation (algebraMap ↥L Qb (w : ↥L)) ≤ 1 :=
+      A.valuation_le_one ⟨_, hwA⟩
+    have h2 : (1 : A.ValueGroup) ≤ A.valuation ((q : ℕ) : Qb) := by
+      calc (1 : A.ValueGroup)
+          = A.valuation (algebraMap ↥L Qb (w : ↥L) * ((q : ℕ) : Qb)) := by
+            rw [hq1, map_one]
+        _ = A.valuation (algebraMap ↥L Qb (w : ↥L)) * A.valuation ((q : ℕ) : Qb) :=
+            map_mul _ _ _
+        _ ≤ 1 * A.valuation ((q : ℕ) : Qb) := mul_le_mul_left hv1 _
+        _ = A.valuation ((q : ℕ) : Qb) := one_mul _
+    exact absurd hA' (not_lt.mpr h2)
+  have hp_mem : ((q : ℕ) : 𝓞 ↥L) ∈ p := by
+    rw [hpdef, Ideal.mem_comap, map_natCast f, IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+    exact hqS
+  have hq0 : ((q : ℕ) : 𝓞 ↥L) ≠ 0 := Nat.cast_ne_zero.mpr hq_prime.ne_zero
+  have hp_ne : p ≠ ⊥ := fun h => hq0 (Ideal.mem_bot.mp (h ▸ hp_mem))
+
+  have hcompl_le : p.primeCompl ≤ nonZeroDivisors (𝓞 ↥L) := p.primeCompl_le_nonZeroDivisors
+  have hu : ∀ y : p.primeCompl, IsUnit (algebraMap (𝓞 ↥L) ↥L y) := by
+    rintro y
+    refine IsUnit.mk0 _ ?_
+    have hy0 : (y : 𝓞 ↥L) ≠ 0 := nonZeroDivisors.ne_zero (hcompl_le y.2)
+    exact (map_ne_zero_iff _ (IsFractionRing.injective (𝓞 ↥L) ↥L)).mpr hy0
+  let : Algebra (Localization.AtPrime p) ↥L := RingHom.toAlgebra (IsLocalization.lift hu)
+  have : IsScalarTower (𝓞 ↥L) (Localization.AtPrime p) ↥L :=
+    IsScalarTower.of_algebraMap_eq fun x => (IsLocalization.lift_eq hu x).symm
+  have : IsFractionRing (Localization.AtPrime p) ↥L :=
+    IsFractionRing.isFractionRing_of_isDomain_of_isLocalization p.primeCompl _ _
+  have hdvr_loc : IsDiscreteValuationRing (Localization.AtPrime p) :=
+    IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain (𝓞 ↥L) hp_ne _
+  let : Algebra (𝓞 ↥L) ↥S := f.toAlgebra
+  have : IsLocalization.AtPrime ↥S p := by
+    refine ⟨fun t => ?_, fun z => ?_, fun {x y} hxy => ?_⟩
+    · rw [RingHom.algebraMap_toAlgebra]
+      by_contra h
+      exact t.2 (Ideal.mem_comap.mpr ((IsLocalRing.mem_maximalIdeal _).mpr h))
+    · rw [RingHom.algebraMap_toAlgebra]
+      rcases eq_or_ne z 0 with rfl | hz0
+      · exact ⟨⟨0, 1⟩, by simp⟩
+      have hz : (z : ↥L) ≠ 0 := fun h => hz0 (Subtype.ext h)
+      suffices hint : IsLocalization.IsInteger (Localization.AtPrime p) ((z : ↥L)) by
+        obtain ⟨w, hw⟩ := hint
+        obtain ⟨⟨a, t⟩, ht⟩ := IsLocalization.mk'_surjective (M := p.primeCompl)
+          (S := Localization.AtPrime p) w
+        refine ⟨⟨a, t⟩, Subtype.ext ?_⟩
+        have hspec : w * algebraMap (𝓞 ↥L) (Localization.AtPrime p) ↑t
+            = algebraMap (𝓞 ↥L) (Localization.AtPrime p) a := by
+          rw [← ht]; exact IsLocalization.mk'_spec _ a t
+        have := congrArg (algebraMap (Localization.AtPrime p) ↥L) hspec
+        rw [map_mul, hw, ← IsScalarTower.algebraMap_apply, ← IsScalarTower.algebraMap_apply]
+          at this
+        exact this
+      rcases ValuationRing.isInteger_or_isInteger (Localization.AtPrime p) ((z : ↥L)) with h | h
+      · exact h
+      obtain ⟨w, hw⟩ := h
+      by_cases hu' : IsUnit w
+      · obtain ⟨u, rfl⟩ := hu'
+        refine ⟨(u⁻¹ : (Localization.AtPrime p)ˣ), ?_⟩
+        have h1 : algebraMap (Localization.AtPrime p) ↥L ↑u⁻¹
+            * algebraMap (Localization.AtPrime p) ↥L ↑u = 1 := by
+          rw [← map_mul, Units.inv_mul, map_one]
+        exact (eq_inv_of_mul_eq_one_left h1).trans (by rw [hw, inv_inv])
+      · exfalso
+        obtain ⟨⟨a', t'⟩, hmk⟩ := IsLocalization.mk'_surjective (M := p.primeCompl)
+          (S := Localization.AtPrime p) w
+        have hspec : w * algebraMap (𝓞 ↥L) (Localization.AtPrime p) ↑t'
+            = algebraMap (𝓞 ↥L) (Localization.AtPrime p) a' := by
+          rw [← hmk]; exact IsLocalization.mk'_spec _ a' t'
+        have ha' : a' ∈ p := by
+          by_contra ha'
+          apply hu'
+          have hua : IsUnit (algebraMap (𝓞 ↥L) (Localization.AtPrime p) a') :=
+            IsLocalization.map_units _ (⟨a', ha'⟩ : p.primeCompl)
+          rw [← hspec] at hua
+          exact isUnit_of_mul_isUnit_left hua
+        have hL := congrArg (algebraMap (Localization.AtPrime p) ↥L) hspec
+        rw [map_mul, hw, ← IsScalarTower.algebraMap_apply, ← IsScalarTower.algebraMap_apply]
+          at hL
+        have hL2 : algebraMap (𝓞 ↥L) ↥L ↑t' = (z : ↥L) * algebraMap (𝓞 ↥L) ↥L a' := by
+          have h3 := congrArg ((z : ↥L) * ·) hL
+          simpa [← mul_assoc, mul_inv_cancel₀ hz] using h3
+        have hfS : f ↑t' = z * f a' := Subtype.ext hL2
+        have ht'm : f ↑t' ∈ IsLocalRing.maximalIdeal ↥S := by
+          rw [hfS]
+          exact Ideal.mul_mem_left _ _ (Ideal.mem_comap.mp ha')
+        exact t'.2 (Ideal.mem_comap.mpr ht'm)
+    · rw [RingHom.algebraMap_toAlgebra] at hxy
+      exact ⟨1, by rw [hf_inj hxy]⟩
+  exact IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain (𝓞 ↥L) hp_ne ↥S
+
+end ComapDVR
+
+theorem solution
+    (L : IntermediateField ℚ (AlgebraicClosure ℚ)) [FiniteDimensional ℚ L]
+    (A : ValuationSubring (AlgebraicClosure ℚ)) {q : ℕ} (hq : q.Prime) (hA : A.LiesOverPrime q) :
+    IsDiscreteValuationRing (A.comap (algebraMap L (AlgebraicClosure ℚ))) :=
+  ComapDVR.comap_isDiscreteValuationRing L A q hq hA
+
+end S_ValuationSubring_isDiscreteValuationRing_comap_of_liesOverPrime
+end P2MW
+export P2MW.S_ValuationSubring_isDiscreteValuationRing_comap_of_liesOverPrime (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem ValuationSubring.isDiscreteValuationRing_comap_of_liesOverPrime
+    (L : IntermediateField ℚ (AlgebraicClosure ℚ)) [FiniteDimensional ℚ L]
+    (A : ValuationSubring (AlgebraicClosure ℚ)) {q : ℕ} (hq : q.Prime) (hA : A.LiesOverPrime q) :
+    IsDiscreteValuationRing (A.comap (algebraMap L (AlgebraicClosure ℚ))) :=
+  solution L A hq hA
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ValuationSubring_isFrobeniusAt_of_forall_smul_sub_pow_mem.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ValuationSubring_isFrobeniusAt_of_forall_smul_sub_pow_mem.lean
new file mode 100644
index 0000000000..0f434665cd
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ValuationSubring_isFrobeniusAt_of_forall_smul_sub_pow_mem.lean
@@ -0,0 +1,228 @@
+/-
+Based on Prove2Me node ValuationSubring.isFrobeniusAt_of_forall_smul_sub_pow_mem
+(03d79368-0508-5492-b23d-a95b29617616) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8fffc064-e7d5-5ce9-b4c3-d647c3d3c94b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusTrace
+public import Mathlib.NumberTheory.NumberField.Basic
+
+import Mathlib.RingTheory.LocalRing.ResidueField.Basic
+import Mathlib.Algebra.Lie.OfAssociative
+import Mathlib.Algebra.Algebra.Rat
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Localisation at a maximal ideal of ℤ̄ gives a Frobenius
+
+Theorem statement: `ValuationSubring.isFrobeniusAt_of_forall_smul_sub_pow_mem`
+(`03d79368-0508-5492-b23d-a95b29617616`), by Claude, 2026-09-05.
+
+Proof: submission `8fffc064-e7d5-5ce9-b4c3-d647c3d3c94b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\mathcal{O} = \mathcal{O}_{\overline{\mathbb{Q}}}$ be the ring of integers of
+$\overline{\mathbb{Q}} =$ `AlgebraicClosure ℚ`, let $Q$ be a maximal ideal of $\mathcal{O}$, let
+$\ell$ be a prime natural number with $\ell \in Q$, and let $\tau$ be a $\mathbb{Q}$-algebra
+automorphism of $\overline{\mathbb{Q}}$ such that, for every $x \in \mathcal{O}$, one has $\tau
+\cdot x \in Q$ if and only if $x \in Q$, and $\tau \cdot x - x^{\ell} \in Q$. Let $A$ be a valuation
+subring of $\overline{\mathbb{Q}}$ whose underlying set is exactly the localisation of $\mathcal{O}$
+at $Q$, in the sense that an element $x \in \overline{\mathbb{Q}}$ lies in $A$ precisely when there
+exist $s, a \in \mathcal{O}$ with $s \notin Q$ and $s x = a$ in $\overline{\mathbb{Q}}$. The
+conclusion is the conjunction of two assertions: first, `A.LiesOverPrime ℓ`, i.e. the image of
+$\ell$ in $\overline{\mathbb{Q}}$ is a non-unit of $A$; second, `A.IsFrobeniusAt τ ℓ`, i.e. $\tau$
+belongs to the decomposition subgroup of $A$ over $\mathbb{Q}$ (the stabiliser of $A$ under the
+action of $\mathrm{Aut}_{\mathbb{Q}}(\overline{\mathbb{Q}})$ on valuation subrings), and the
+resulting action of $\tau$ on the residue field of $A$ sends every element $y$ to $y^{\ell}$.
+
+This is the passage from the ideal-theoretic description of a Frobenius element at a maximal ideal
+of the ring of all algebraic integers to the language of places of $\overline{\mathbb{Q}}$, i.e.
+valuation subrings together with their decomposition groups and residue fields, which is the form in
+which Frobenius conditions on residual representations are stated. It is used in the construction of
+Frobenius elements of prescribed behaviour (including the selection of Taylor–Wiles primes and the
+statements about characteristic polynomials of Frobenius).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ValuationSubring_isFrobeniusAt_of_forall_smul_sub_pow_mem.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ValuationSubring_isFrobeniusAt_of_forall_smul_sub_pow_mem
+
+open scoped NumberField Pointwise
+
+namespace C6PortS10T3b
+
+variable {Qt : Ideal (𝓞 (AlgebraicClosure ℚ))} {A : ValuationSubring (AlgebraicClosure ℚ)}
+
+private def IsLoc (Qt : Ideal (𝓞 (AlgebraicClosure ℚ))) (A : ValuationSubring (AlgebraicClosure ℚ))
+    :
+    Prop :=
+  ∀ x : AlgebraicClosure ℚ, x ∈ A ↔ ∃ s : 𝓞 (AlgebraicClosure ℚ), s ∉ Qt ∧
+    ∃ a : 𝓞 (AlgebraicClosure ℚ), (s : AlgebraicClosure ℚ) * x = a
+
+private theorem coe_ne_zero_of_notMem {s : 𝓞 (AlgebraicClosure ℚ)} (hs : s ∉ Qt) :
+    (s : AlgebraicClosure ℚ) ≠ 0 := by
+  intro h
+  exact hs ((NumberField.RingOfIntegers.coe_eq_zero_iff.mp h).symm ▸ Qt.zero_mem)
+
+section
+
+variable [Qt.IsMaximal] (hA : IsLoc Qt A)
+include hA
+
+private theorem coe_mem (x : 𝓞 (AlgebraicClosure ℚ)) : (x : AlgebraicClosure ℚ) ∈ A :=
+  (hA x).2 ⟨1, (Ideal.ne_top_iff_one Qt).1 Ideal.IsPrime.ne_top', x, by simp⟩
+
+private noncomputable def ψ : 𝓞 (AlgebraicClosure ℚ) →+* A :=
+  (algebraMap (𝓞 (AlgebraicClosure ℚ)) (AlgebraicClosure ℚ)).codRestrict A (coe_mem hA)
+
+@[scoped simp] private theorem coe_ψ (x : 𝓞 (AlgebraicClosure ℚ)) :
+    ((ψ hA x : A) : AlgebraicClosure ℚ) = x := rfl
+
+private theorem isUnit_ψ {s : 𝓞 (AlgebraicClosure ℚ)} (hs : s ∉ Qt) : IsUnit (ψ hA s) := by
+  have hs0 := coe_ne_zero_of_notMem hs
+  have hinv : (s : AlgebraicClosure ℚ)⁻¹ ∈ A := (hA _).2 ⟨s, hs, 1, by simp [hs0]⟩
+  exact IsUnit.of_mul_eq_one (b := ⟨_, hinv⟩) (Subtype.ext (mul_inv_cancel₀ hs0))
+
+private theorem ψ_mem_maximalIdeal {z : 𝓞 (AlgebraicClosure ℚ)} (hz : z ∈ Qt) :
+    ψ hA z ∈ IsLocalRing.maximalIdeal A := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  rintro ⟨u, hu⟩
+  have hinvA : ((u⁻¹ : Aˣ) : A).1 ∈ A := ((u⁻¹ : Aˣ) : A).2
+  obtain ⟨s, hs, a, hsa⟩ := (hA _).1 hinvA
+  apply hs
+  have hzu : (z : AlgebraicClosure ℚ) * ((u⁻¹ : Aˣ) : A).1 = 1 := by
+    have := congrArg (fun v : A => (v : AlgebraicClosure ℚ)) u.mul_inv
+    simpa [hu] using this
+  have hs_eq : (s : AlgebraicClosure ℚ) = z * a := by
+    calc (s : AlgebraicClosure ℚ) = s * ((z : AlgebraicClosure ℚ) * ((u⁻¹ : Aˣ) : A).1) := by
+          rw [hzu, mul_one]
+      _ = z * ((s : AlgebraicClosure ℚ) * ((u⁻¹ : Aˣ) : A).1) := by ring
+      _ = z * a := by rw [hsa]
+  have : s = z * a := NumberField.RingOfIntegers.coe_injective (by simpa using hs_eq)
+  exact this ▸ Qt.mul_mem_right a hz
+
+omit [Qt.IsMaximal] in
+private theorem liesOverPrime {ℓ : ℕ} (hℓ : ℓ.Prime) (hℓQ : (ℓ : 𝓞 (AlgebraicClosure ℚ)) ∈ Qt) :
+    A.LiesOverPrime ℓ := by
+  rw [ValuationSubring.LiesOverPrime, ValuationSubring.mem_nonunits_iff_or]
+  refine Or.inr fun hinv => ?_
+  obtain ⟨s, hs, a, hsa⟩ := (hA _).1 hinv
+  apply hs
+  have hℓ0 : (ℓ : AlgebraicClosure ℚ) ≠ 0 := by exact_mod_cast hℓ.ne_zero
+  have hs_eq : (s : AlgebraicClosure ℚ) = (ℓ : AlgebraicClosure ℚ) * a := by
+    rw [← hsa, mul_left_comm, mul_inv_cancel₀ hℓ0, mul_one]
+  have : s = ℓ * a := NumberField.RingOfIntegers.coe_injective (by simpa using hs_eq)
+  exact this ▸ Qt.mul_mem_right a hℓQ
+
+omit [Qt.IsMaximal] in
+private theorem smul_mem {σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ}
+    (hσ : ∀ x : 𝓞 (AlgebraicClosure ℚ), σ • x ∈ Qt ↔ x ∈ Qt) {x : AlgebraicClosure ℚ} (hx : x ∈ A) :
+    σ • x ∈ A := by
+  obtain ⟨s, hs, a, hsa⟩ := (hA x).1 hx
+  refine (hA _).2 ⟨σ • s, fun h => hs ((hσ s).1 h), σ • a, ?_⟩
+  have : σ • ((s : AlgebraicClosure ℚ) * x) = σ • (a : AlgebraicClosure ℚ) := by rw [hsa]
+  rwa [smul_mul'] at this
+
+omit [Qt.IsMaximal] in
+private theorem mem_decompositionSubgroup {τ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ}
+    (hstab : ∀ x : 𝓞 (AlgebraicClosure ℚ), τ • x ∈ Qt ↔ x ∈ Qt) : τ ∈ A.decompositionSubgroup ℚ :=
+      by
+  have hstab' : ∀ x : 𝓞 (AlgebraicClosure ℚ), τ⁻¹ • x ∈ Qt ↔ x ∈ Qt := fun x => by
+    simpa using (hstab (τ⁻¹ • x)).symm
+  rw [MulAction.mem_stabilizer_iff]
+  ext x
+  rw [ValuationSubring.mem_pointwise_smul_iff_inv_smul_mem]
+  exact ⟨fun h => by simpa using smul_mem hA hstab h, fun h => smul_mem hA hstab' h⟩
+
+private theorem smul_ψ {τ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ}
+    (hτ : τ ∈ A.decompositionSubgroup ℚ)
+    (x : 𝓞 (AlgebraicClosure ℚ)) :
+    (⟨τ, hτ⟩ : A.decompositionSubgroup ℚ) • ψ hA x = ψ hA (τ • x) := rfl
+
+private theorem smul_residue {τ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ} {ℓ : ℕ}
+    (hτ : τ ∈ A.decompositionSubgroup ℚ) (hfrob : ∀ x : 𝓞 (AlgebraicClosure ℚ), τ • x - x ^ ℓ ∈ Qt)
+    (y : IsLocalRing.ResidueField A) :
+    (⟨τ, hτ⟩ : A.decompositionSubgroup ℚ) • y = y ^ ℓ := by
+  set g : A.decompositionSubgroup ℚ := ⟨τ, hτ⟩
+  have key : ∀ x : 𝓞 (AlgebraicClosure ℚ),
+      g • IsLocalRing.residue A (ψ hA x) = IsLocalRing.residue A (ψ hA x) ^ ℓ := fun x => by
+    rw [← IsLocalRing.ResidueField.residue_smul, smul_ψ hA hτ, ← map_pow, ← map_pow, ← sub_eq_zero,
+      ← map_sub, IsLocalRing.residue_eq_zero_iff, ← map_sub]
+    exact ψ_mem_maximalIdeal hA (hfrob x)
+  obtain ⟨r, rfl⟩ := Ideal.Quotient.mk_surjective y
+  change g • IsLocalRing.residue A r = IsLocalRing.residue A r ^ ℓ
+  obtain ⟨s, hs, a, hsa⟩ := (hA _).1 r.2
+  have hsr : ψ hA s * r = ψ hA a := Subtype.ext hsa
+  have hu : IsLocalRing.residue A (ψ hA s) ≠ 0 := by
+    rw [Ne, IsLocalRing.residue_eq_zero_iff, IsLocalRing.mem_maximalIdeal, mem_nonunits_iff,
+      not_not]
+    exact isUnit_ψ hA hs
+  have h1 : IsLocalRing.residue A (ψ hA s) * IsLocalRing.residue A r = IsLocalRing.residue A (ψ hA
+    a) :=
+    by
+    rw [← map_mul, hsr]
+  have h2 : g • (IsLocalRing.residue A (ψ hA s) * IsLocalRing.residue A r) =
+      IsLocalRing.residue A (ψ hA s) ^ ℓ * g • IsLocalRing.residue A r := by
+    rw [smul_mul', key]
+  rw [h1, key, ← h1, mul_pow] at h2
+  exact (mul_left_cancel₀ (pow_ne_zero ℓ hu) h2).symm
+
+end
+
+end C6PortS10T3b
+
+open C6PortS10T3b in
+theorem solution
+    (Qt : Ideal (𝓞 (AlgebraicClosure ℚ))) [Qt.IsMaximal] (ℓ : ℕ) (hℓ : ℓ.Prime)
+    (hℓQ : (ℓ : 𝓞 (AlgebraicClosure ℚ)) ∈ Qt) (τ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ)
+    (hstab : ∀ x : 𝓞 (AlgebraicClosure ℚ), τ • x ∈ Qt ↔ x ∈ Qt)
+    (hfrob : ∀ x : 𝓞 (AlgebraicClosure ℚ), τ • x - x ^ ℓ ∈ Qt)
+    (A : ValuationSubring (AlgebraicClosure ℚ))
+    (hA : ∀ x : AlgebraicClosure ℚ,
+      x ∈ A ↔ ∃ s : 𝓞 (AlgebraicClosure ℚ), s ∉ Qt ∧ ∃ a : 𝓞 (AlgebraicClosure ℚ), (s :
+        AlgebraicClosure ℚ) * x = a) :
+    A.LiesOverPrime ℓ ∧ A.IsFrobeniusAt τ ℓ := by
+  have hA' : C6PortS10T3b.IsLoc Qt A := hA
+  have hτ := mem_decompositionSubgroup hA' hstab
+  exact ⟨liesOverPrime hA' hℓ hℓQ, hτ, smul_residue hA' hτ hfrob⟩
+
+end S_ValuationSubring_isFrobeniusAt_of_forall_smul_sub_pow_mem
+end P2MW
+export P2MW.S_ValuationSubring_isFrobeniusAt_of_forall_smul_sub_pow_mem (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped NumberField Pointwise
+
+theorem ValuationSubring.isFrobeniusAt_of_forall_smul_sub_pow_mem
+    (Qt : Ideal (𝓞 (AlgebraicClosure ℚ))) [Qt.IsMaximal] (ℓ : ℕ) (hℓ : ℓ.Prime)
+    (hℓQ : (ℓ : 𝓞 (AlgebraicClosure ℚ)) ∈ Qt) (τ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ)
+    (hstab : ∀ x : 𝓞 (AlgebraicClosure ℚ), τ • x ∈ Qt ↔ x ∈ Qt)
+    (hfrob : ∀ x : 𝓞 (AlgebraicClosure ℚ), τ • x - x ^ ℓ ∈ Qt)
+    (A : ValuationSubring (AlgebraicClosure ℚ))
+    (hA : ∀ x : AlgebraicClosure ℚ,
+      x ∈ A ↔ ∃ s : 𝓞 (AlgebraicClosure ℚ), s ∉ Qt ∧ ∃ a : 𝓞 (AlgebraicClosure ℚ), (s :
+        AlgebraicClosure ℚ) * x = a) :
+    A.LiesOverPrime ℓ ∧ A.IsFrobeniusAt τ ℓ :=
+  solution Qt ℓ hℓ hℓQ τ hstab hfrob A hA
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_Valuation_eq_comap_of_valuationSubring_le_comap.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_Valuation_eq_comap_of_valuationSubring_le_comap.lean
new file mode 100644
index 0000000000..4c3508c5d9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_Valuation_eq_comap_of_valuationSubring_le_comap.lean
@@ -0,0 +1,160 @@
+/-
+Based on Prove2Me node Valuation.eq_comap_of_valuationSubring_le_comap
+(4afe1611-48d5-53ba-82a4-d533c11f9044) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission aa7f8c1b-46d2-530e-afb0-3dfca5789233
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.Valuation.ValuationSubring
+
+import Mathlib.RingTheory.Valuation.Discrete.Basic
+import Mathlib.RingTheory.KrullDimension.PID
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Normalised valuation determined by a one-sided inclusion of valuation rings
+
+Theorem statement: `Valuation.eq_comap_of_valuationSubring_le_comap`
+(`4afe1611-48d5-53ba-82a4-d533c11f9044`), by Claude, 2026-09-05.
+
+Proof: submission `aa7f8c1b-46d2-530e-afb0-3dfca5789233`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ and $L'$ be fields, let $v$ be a valuation on $L'$ and $w$ a valuation on $L$, both with
+values in $\mathbb{Z}^{m0} = \mathrm{WithZero}(\mathrm{Multiplicative}\,\mathbb{Z})$, and assume
+both are surjective as maps onto this value monoid (i.e. both are normalised discrete valuations,
+attaining every value $\exp(n)$, $n \in \mathbb{Z}$, as well as $0$). Let $\sigma : L \simeq_{+*}
+L'$ be a ring isomorphism. The single hypothesis relating the two valuations is the one-sided
+inclusion of valuation subrings $\mathcal{O}_w \le \sigma^{-1}(\mathcal{O}_v)$, where
+$\sigma^{-1}(\mathcal{O}_v)$ denotes the comap of `v.valuationSubring` along the ring homomorphism
+underlying $\sigma$; explicitly, $w(x) \le 1$ implies $v(\sigma x) \le 1$ for all $x \in L$. The
+conclusion is the equality of valuations $w = v \circ \sigma$ (the comap of $v$ along the ring
+homomorphism underlying $\sigma$), i.e. $w(x) = v(\sigma x)$ for every $x \in L$, so that in
+particular the inclusion of hypothesis is in fact an equality.
+
+This is the standard transport principle for normalised discrete valuations: a discrete valuation
+ring is a maximal proper subring of its fraction field, so a one-sided domination of valuation rings
+along an isomorphism forces equality of the normalised valuations. It is used in the function-field
+computations for elliptic curves, where the valuation at a point is compared with the valuation
+pulled back along an isomorphism of the function field, and is cited by
+[`WeierstrassCurve.Affine.valuation_transEquiv_weilFun`]
+(thm.html#WeierstrassCurve.Affine.valuation_transEquiv_weilFun).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_Valuation_eq_comap_of_valuationSubring_le_comap.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_Valuation_eq_comap_of_valuationSubring_le_comap
+
+open scoped WithZero
+
+namespace Valuation
+p2m_export "Valuation" "valuationSubring ext mem_valuationSubring_iff comap_apply ne_zero_iff \
+  IsNontrivial comap IsEquiv isEquiv_iff_valuationSubring"
+p2m_open "Valuation"
+
+variable {L : Type*} [Field L]
+
+theorem eq_of_valuationSubring_eq_aux (v w : Valuation L ℤᵐ⁰)
+    (hv : Function.Surjective v) (hw : Function.Surjective w)
+    (h : v.valuationSubring = w.valuationSubring) : v = w := by
+  have heq : v.IsEquiv w := (Valuation.isEquiv_iff_valuationSubring _ _).mpr h
+  obtain ⟨π, hπ⟩ := hv (WithZero.exp (-1))
+  obtain ⟨ρ, hρ⟩ := hw (WithZero.exp (-1))
+  have hπ0 : π ≠ 0 := fun h0 => by rw [h0, map_zero] at hπ; exact WithZero.exp_ne_zero hπ.symm
+  have hρ0 : ρ ≠ 0 := fun h0 => by rw [h0, map_zero] at hρ; exact WithZero.exp_ne_zero hρ.symm
+  have hwπ : w π = WithZero.exp (-1) := by
+    have hwπ1 : w π < 1 := heq.lt_one_iff_lt_one.mp (by rw [hπ]; decide)
+    have hwπ0 : w π ≠ 0 := (w.ne_zero_iff).mpr hπ0
+    have hle : w π ≤ w ρ := by
+      rw [hρ, ← WithZero.exp_log hwπ0, WithZero.exp_le_exp]
+      have : WithZero.log (w π) < 0 := by
+        rw [← WithZero.exp_lt_exp, WithZero.exp_log hwπ0]; exact hwπ1
+      omega
+    have hvle : v π ≤ v ρ := heq.le_iff_le.mpr hle
+    have hvρ1 : v ρ < 1 := heq.lt_one_iff_lt_one.mpr (by rw [hρ]; decide)
+    have hvρ0 : v ρ ≠ 0 := (v.ne_zero_iff).mpr hρ0
+    have hvρ : v ρ = v π := by
+      rw [hπ] at hvle ⊢
+      rw [← WithZero.exp_log hvρ0, WithZero.exp_le_exp] at hvle
+      rw [← WithZero.exp_log hvρ0, ← WithZero.exp_zero, WithZero.exp_lt_exp] at hvρ1
+      rw [← WithZero.exp_log hvρ0, WithZero.exp_inj]
+      omega
+    rw [← hρ]
+    exact (heq.eq_iff.mp hvρ).symm
+  ext x
+  by_cases hx : x = 0
+  · simp [hx]
+  have hvx0 : v x ≠ 0 := (v.ne_zero_iff).mpr hx
+  set k := WithZero.log (v x) with hk
+  have hvx : v x = v (π ^ (-k)) := by
+    rw [map_zpow₀, hπ, ← WithZero.exp_zsmul, smul_eq_mul, mul_neg, mul_one, neg_neg, hk,
+      WithZero.exp_log hvx0]
+  have hwx : w x = w (π ^ (-k)) := heq.eq_iff.mp hvx
+  rw [hwx, map_zpow₀, hwπ, hvx, map_zpow₀, hπ]
+
+lemma valuationSubring_comap {L' : Type*} [Field L'] (v : Valuation L' ℤᵐ⁰) (σ : L →+* L') :
+    (v.comap σ).valuationSubring = v.valuationSubring.comap σ := by
+  ext x
+  rw [mem_valuationSubring_iff, ValuationSubring.mem_comap, mem_valuationSubring_iff, comap_apply]
+
+theorem eq_comap_of_valuationSubring_le_comap_aux {L' : Type*} [Field L'] {v : Valuation L' ℤᵐ⁰}
+    {w : Valuation L ℤᵐ⁰} (hv : Function.Surjective v) (hw : Function.Surjective w) (σ : L ≃+* L')
+    (hle : w.valuationSubring ≤ v.valuationSubring.comap σ.toRingHom) : w = v.comap σ.toRingHom :=
+      by
+  have hvσ : Function.Surjective (v.comap σ.toRingHom) := fun γ => by
+    obtain ⟨y, hy⟩ := hv γ
+    exact ⟨σ.symm y, by rw [comap_apply, RingEquiv.toRingHom_eq_coe, RingEquiv.coe_toRingHom,
+      RingEquiv.apply_symm_apply, hy]⟩
+  have : w.IsNontrivial := by
+    obtain ⟨π, hπ⟩ := hw (WithZero.exp (-1))
+    exact ⟨π, by rw [hπ]; exact ⟨WithZero.exp_ne_zero, by decide⟩⟩
+  have hne : (v.comap σ.toRingHom).valuationSubring ≠ ⊤ := by
+    obtain ⟨x, hx⟩ := hvσ (WithZero.exp 1)
+    intro h
+    have hx' : x ∈ (v.comap σ.toRingHom).valuationSubring := h ▸ ValuationSubring.mem_top x
+    rw [mem_valuationSubring_iff, hx] at hx'
+    exact absurd hx' (by decide)
+  rw [← valuationSubring_comap] at hle
+  exact eq_of_valuationSubring_eq_aux w _ hw hvσ (ValuationSubring.eq_of_le_of_ne_top _ hle hne)
+
+end Valuation
+
+theorem solution {L L' : Type*} [Field L] [Field L']
+    {v : Valuation L' (WithZero (Multiplicative ℤ))} {w : Valuation L (WithZero (Multiplicative ℤ))}
+    (hv : Function.Surjective v) (hw : Function.Surjective w) (σ : L ≃+* L')
+    (hle : w.valuationSubring ≤ v.valuationSubring.comap σ.toRingHom) :
+    w = v.comap σ.toRingHom :=
+  Valuation.eq_comap_of_valuationSubring_le_comap_aux hv hw σ hle
+
+end S_Valuation_eq_comap_of_valuationSubring_le_comap
+end P2MW
+export P2MW.S_Valuation_eq_comap_of_valuationSubring_le_comap (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem Valuation.eq_comap_of_valuationSubring_le_comap {L L' : Type*} [Field L] [Field L']
+    {v : Valuation L' (WithZero (Multiplicative ℤ))} {w : Valuation L (WithZero (Multiplicative ℤ))}
+    (hv : Function.Surjective v) (hw : Function.Surjective w) (σ : L ≃+* L')
+    (hle : w.valuationSubring ≤ v.valuationSubring.comap σ.toRingHom) :
+    w = v.comap σ.toRingHom :=
+  solution hv hw σ hle
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_exists_analyticOnNhd_div_of_monicRel.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_exists_analyticOnNhd_div_of_monicRel.lean
new file mode 100644
index 0000000000..dfd550db80
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_exists_analyticOnNhd_div_of_monicRel.lean
@@ -0,0 +1,241 @@
+/-
+Based on Prove2Me node WLight.exists_analyticOnNhd_div_of_monicRel
+(abb58f54-78a6-5d86-b5be-f1cfead2bda8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 98f94e5e-a7cb-550f-b3a4-279b627a6ca2
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.SpecialFunctions.Elliptic.Weierstrass
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import Mathlib.Geometry.Manifold.Notation
+
+import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+import Mathlib.Analysis.Meromorphic.NormalForm
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Analytic divisibility from a monic relation with G-weighted coefficients
+
+Theorem statement: `WLight.exists_analyticOnNhd_div_of_monicRel`
+(`abb58f54-78a6-5d86-b5be-f1cfead2bda8`), by Claude, 2026-09-05.
+
+Proof: submission `98f94e5e-a7cb-550f-b3a4-279b627a6ca2`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\Bbbk$ be a nontrivially normed field and let $U \subseteq \Bbbk$ be a set that is open and
+preconnected. Let $F, G : \Bbbk \to \Bbbk$, let $c : \mathbb{N} \to (\Bbbk \to \Bbbk)$ be a family
+of coefficient functions, and let $n$ be a natural number. Assume that $F$ and $G$ are analytic on a
+neighbourhood of each point of $U$, that $G$ does not vanish identically on $U$ in the strong sense
+that there exists $z \in U$ with $G z \neq 0$, and that for each index $k < n$ the coefficient
+function $c_k$ is likewise analytic on a neighbourhood of each point of $U$. Assume finally the
+monic relation
+$$F^n + \sum_{k < n} c_k \, G^{\,n-k} F^k = 0$$
+holds pointwise at every point of $U$, the powers and products being taken in the ring of
+$\Bbbk$-valued functions. The conclusion is that there exists $H : \Bbbk \to \Bbbk$, analytic on a
+neighbourhood of each point of $U$, such that $F z = G z \cdot H z$ for all $z \in U$; that is, $G$
+divides $F$ in the ring of functions analytic near each point of $U$. Nothing is asserted about
+behaviour outside or on the boundary of $U$.
+
+This is the division engine behind arguments showing that a quotient $F/G$ is analytic once the
+quotient satisfies a monic algebraic relation whose lower coefficients carry compensating powers of
+$G$: the relation forces the vanishing order of $F$ to dominate that of $G$ at each point of $U$,
+the preconnectedness hypothesis and the identity principle ruling out identical vanishing of $G$. It
+is applied through its upper-half-plane counterpart
+[`WLight.exists_mdifferentiable_div_of_monicRel`]
+(thm.html#WLight.exists_mdifferentiable_div_of_monicRel).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WLight_exists_analyticOnNhd_div_of_monicRel.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WLight_exists_analyticOnNhd_div_of_monicRel
+
+noncomputable section
+
+p2m_open "Complex Real UpperHalfPlane ModularForm Polynomial Real.Polynomial"
+open scoped Topology Manifold MatrixGroups ModularForm
+
+namespace WLight
+
+section ValuationEngine
+
+theorem le_meromorphicOrderAt_sum {𝕜 : Type*} [NontriviallyNormedField 𝕜]
+    {ι : Type*} (s : Finset ι) {f : ι → 𝕜 → 𝕜} {x : 𝕜}
+    (hf : ∀ i ∈ s, MeromorphicAt (f i) x) (m : WithTop ℤ)
+    (hm : ∀ i ∈ s, m ≤ meromorphicOrderAt (f i) x) :
+    m ≤ meromorphicOrderAt (∑ i ∈ s, f i) x := by
+  classical
+  induction s using Finset.induction with
+  | empty => simp
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha]
+    calc m ≤ min (meromorphicOrderAt (f a) x) (meromorphicOrderAt (∑ i ∈ s, f i) x) := by
+            refine le_min (hm a (Finset.mem_insert_self a s)) ?_
+            exact ih (fun i hi ↦ hf i (Finset.mem_insert_of_mem hi))
+              (fun i hi ↦ hm i (Finset.mem_insert_of_mem hi))
+      _ ≤ meromorphicOrderAt (f a + ∑ i ∈ s, f i) x := by
+            apply meromorphicOrderAt_add (hf a (Finset.mem_insert_self a s))
+            exact MeromorphicAt.sum (fun i hi ↦ hf i (Finset.mem_insert_of_mem hi))
+
+theorem meromorphicOrderAt_le_of_monicRel {𝕜 : Type*} [NontriviallyNormedField 𝕜]
+    {F G : 𝕜 → 𝕜} {c : ℕ → 𝕜 → 𝕜} {n : ℕ} {τ : 𝕜}
+    (hF : AnalyticAt 𝕜 F τ) (hG : AnalyticAt 𝕜 G τ)
+    (hGord : meromorphicOrderAt G τ ≠ ⊤) (hc : ∀ k < n, AnalyticAt 𝕜 (c k) τ)
+    (hrel : F ^ n + (∑ k ∈ Finset.range n, c k * G ^ (n - k) * F ^ k) =ᶠ[𝓝 τ] 0) :
+    meromorphicOrderAt G τ ≤ meromorphicOrderAt F τ := by
+  by_contra hlt
+  rw [not_le] at hlt
+  lift meromorphicOrderAt G τ to ℤ using hGord with m hm
+  have hFord : meromorphicOrderAt F τ ≠ ⊤ := hlt.ne_top
+  lift meromorphicOrderAt F τ to ℤ using hFord with r hr
+  have hrm : r < m := WithTop.coe_lt_coe.mp hlt
+  set S := ∑ k ∈ Finset.range n, c k * G ^ (n - k) * F ^ k with hS
+  have hMerS : ∀ k ∈ Finset.range n, MeromorphicAt (c k * G ^ (n - k) * F ^ k) τ := by
+    intro k hk
+    exact (((hc k (Finset.mem_range.mp hk)).mul ((hG.pow _))).mul (hF.pow _)).meromorphicAt
+  have hsum_ord : (↑(n * r) + 1 : WithTop ℤ) ≤ meromorphicOrderAt S τ := by
+    refine le_meromorphicOrderAt_sum _ hMerS _ ?_
+    intro k hk
+    have hk' : k < n := Finset.mem_range.mp hk
+    have hterm : meromorphicOrderAt (c k * G ^ (n - k) * F ^ k) τ
+        = meromorphicOrderAt (c k) τ + ((n - k : ℕ) * meromorphicOrderAt G τ
+            + k * meromorphicOrderAt F τ) := by
+      rw [meromorphicOrderAt_mul (((hc k hk').mul (hG.pow (n - k))).meromorphicAt)
+            ((hF.pow k).meromorphicAt),
+          meromorphicOrderAt_mul (hc k hk').meromorphicAt ((hG.pow (n - k)).meromorphicAt),
+          meromorphicOrderAt_pow hG.meromorphicAt (n := n - k),
+          meromorphicOrderAt_pow hF.meromorphicAt (n := k), add_assoc]
+    rw [hterm, ← hm, ← hr]
+    have hc_ord : (0 : WithTop ℤ) ≤ meromorphicOrderAt (c k) τ :=
+      (hc k hk').meromorphicOrderAt_nonneg
+    have hnk : ((n - k : ℕ) : ℤ) = (n : ℤ) - k := by omega
+    have key : (↑(n * r) + 1 : WithTop ℤ)
+        ≤ (↑(n - k : ℕ) : WithTop ℤ) * ↑m + ↑k * ↑r := by
+      rw [show ((n - k : ℕ) : WithTop ℤ) = (((n - k : ℕ) : ℤ) : WithTop ℤ) by push_cast; rfl,
+          show ((k : ℕ) : WithTop ℤ) = (((k : ℕ) : ℤ) : WithTop ℤ) by push_cast; rfl,
+          ← WithTop.coe_mul, ← WithTop.coe_mul, ← WithTop.coe_add,
+          ← WithTop.coe_one, ← WithTop.coe_add, WithTop.coe_le_coe, hnk]
+      have h1 : (1 : ℤ) ≤ (n : ℤ) - k := by omega
+      nlinarith [h1, hrm]
+    calc (↑(n * r) + 1 : WithTop ℤ)
+        ≤ (↑(n - k : ℕ) : WithTop ℤ) * ↑m + ↑k * ↑r := key
+      _ = 0 + ((↑(n - k : ℕ) : WithTop ℤ) * ↑m + ↑k * ↑r) := (zero_add _).symm
+      _ ≤ meromorphicOrderAt (c k) τ + ((↑(n - k : ℕ) : WithTop ℤ) * ↑m + ↑k * ↑r) := by
+          gcongr
+  have hFn_ord : meromorphicOrderAt (F ^ n) τ = (↑(n * r) : WithTop ℤ) := by
+    rw [meromorphicOrderAt_pow hF.meromorphicAt, ← hr]; push_cast; ring_nf
+  have hlt2 : meromorphicOrderAt (F ^ n) τ < meromorphicOrderAt S τ := by
+    rw [hFn_ord]
+    refine lt_of_lt_of_le ?_ hsum_ord
+    exact_mod_cast lt_add_one (n * r)
+  have heq : meromorphicOrderAt (F ^ n + S) τ = meromorphicOrderAt (F ^ n) τ :=
+    meromorphicOrderAt_add_eq_left_of_lt
+      (MeromorphicAt.sum (fun i hi ↦ hMerS i hi)) hlt2
+  have hzero : (F ^ n + S) =ᶠ[𝓝[≠] τ] 0 :=
+    hrel.filter_mono nhdsWithin_le_nhds
+  have htop : meromorphicOrderAt (F ^ n + S) τ = ⊤ := by
+    rw [meromorphicOrderAt_eq_top_iff]; exact hzero
+  rw [heq, hFn_ord] at htop
+  exact WithTop.coe_ne_top htop
+
+open WithTop.LinearOrderedAddCommGroup in
+theorem meromorphicOrderAt_div_nonneg_of_monicRel {𝕜 : Type*} [NontriviallyNormedField 𝕜]
+    {F G : 𝕜 → 𝕜} {c : ℕ → 𝕜 → 𝕜} {n : ℕ} {τ : 𝕜}
+    (hF : AnalyticAt 𝕜 F τ) (hG : AnalyticAt 𝕜 G τ)
+    (hGord : meromorphicOrderAt G τ ≠ ⊤) (hc : ∀ k < n, AnalyticAt 𝕜 (c k) τ)
+    (hrel : F ^ n + (∑ k ∈ Finset.range n, c k * G ^ (n - k) * F ^ k) =ᶠ[𝓝 τ] 0) :
+    0 ≤ meromorphicOrderAt (F / G) τ := by
+  have hle := meromorphicOrderAt_le_of_monicRel hF hG hGord hc hrel
+  rw [meromorphicOrderAt_div hF.meromorphicAt hG.meromorphicAt,
+      ← LinearOrderedAddCommGroupWithTop.sub_self_eq_zero_of_ne_top hGord]
+  exact (LinearOrderedAddCommGroupWithTop.sub_le_sub_iff_left_of_ne_top hGord).mpr hle
+
+end ValuationEngine
+
+end WLight
+
+open WLight in
+open Filter in
+theorem solution {𝕜 : Type*} [NontriviallyNormedField 𝕜]
+    {U : Set 𝕜} (hU : IsOpen U) (hUc : IsPreconnected U)
+    {F G : 𝕜 → 𝕜} {c : ℕ → 𝕜 → 𝕜} {n : ℕ}
+    (hF : AnalyticOnNhd 𝕜 F U) (hG : AnalyticOnNhd 𝕜 G U) (hG0 : ∃ z ∈ U, G z ≠ 0)
+    (hc : ∀ k < n, AnalyticOnNhd 𝕜 (c k) U)
+    (hrel : Set.EqOn (F ^ n + ∑ k ∈ Finset.range n, c k * G ^ (n - k) * F ^ k) 0 U) :
+    ∃ H : 𝕜 → 𝕜, AnalyticOnNhd 𝕜 H U ∧ Set.EqOn F (G * H) U := by
+  obtain ⟨τ₀, hτ₀U, hGτ₀⟩ := hG0
+  have hGord0 : meromorphicOrderAt G τ₀ ≠ ⊤ := by
+    have h0 := (hG τ₀ hτ₀U).meromorphicNFAt.meromorphicOrderAt_eq_zero_iff.mpr hGτ₀
+    simp [h0]
+  have hGord : ∀ τ ∈ U, meromorphicOrderAt G τ ≠ ⊤ := fun τ hτ ↦
+    hG.meromorphicOn.meromorphicOrderAt_ne_top_of_isPreconnected hUc hτ₀U hτ hGord0
+  have hdiv_ord : ∀ τ ∈ U, 0 ≤ meromorphicOrderAt (F / G) τ := by
+    intro τ hτ
+    refine meromorphicOrderAt_div_nonneg_of_monicRel (hF τ hτ) (hG τ hτ) (hGord τ hτ)
+      (fun k hk ↦ hc k hk τ hτ) ?_
+    filter_upwards [hU.mem_nhds hτ] with z hz using hrel hz
+  have hmer : MeromorphicOn (F / G) U :=
+    fun τ hτ ↦ (hF τ hτ).meromorphicAt.div (hG τ hτ).meromorphicAt
+  set H := toMeromorphicNFOn (F / G) U with hH
+  have hHnf : MeromorphicNFOn H U := meromorphicNFOn_toMeromorphicNFOn (F / G) U
+  have hHan : AnalyticOnNhd 𝕜 H U := by
+    rw [← hHnf.divisor_nonneg_iff_analyticOnNhd]
+    intro z
+    by_cases hz : z ∈ U
+    · simp only [MeromorphicOn.divisor_apply hHnf.meromorphicOn hz,
+        Function.locallyFinsuppWithin.coe_zero, Pi.zero_apply]
+      rw [hH, meromorphicOrderAt_toMeromorphicNFOn hmer hz]
+      exact WithTop.untop₀_nonneg.mpr (hdiv_ord z hz)
+    · simp [hz]
+  refine ⟨H, hHan, ?_⟩
+  have hGHan : AnalyticOnNhd 𝕜 (G * H) U := hG.mul hHan
+  have heq_near : F =ᶠ[𝓝 τ₀] G * H := by
+    have hGopen : {z | G z ≠ 0} ∈ 𝓝 τ₀ :=
+      (hG τ₀ hτ₀U).continuousAt.preimage_mem_nhds (isOpen_ne.mem_nhds hGτ₀)
+    filter_upwards [hGopen, hU.mem_nhds hτ₀U] with z hGz hzU
+    have hanalz : AnalyticAt 𝕜 (F / G) z := (hF z hzU).div (hG z hzU) hGz
+    have : H z = (F / G) z := by
+      rw [hH, toMeromorphicNFOn_eq_toMeromorphicNFAt hmer hzU,
+          toMeromorphicNFAt_eq_self.mpr hanalz.meromorphicNFAt]
+    simp only [Pi.mul_apply, this, Pi.div_apply]
+    field_simp
+  have hfreq : ∃ᶠ z in 𝓝[≠] τ₀, F z = (G * H) z := by
+    refine (heq_near.filter_mono nhdsWithin_le_nhds).frequently
+  exact fun τ hτ ↦ hF.eqOn_of_preconnected_of_frequently_eq hGHan hUc hτ₀U hfreq hτ
+
+end
+end S_WLight_exists_analyticOnNhd_div_of_monicRel
+end P2MW
+export P2MW.S_WLight_exists_analyticOnNhd_div_of_monicRel (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Complex Real UpperHalfPlane
+open scoped Manifold MatrixGroups ModularForm
+theorem WLight.exists_analyticOnNhd_div_of_monicRel {𝕜 : Type*} [NontriviallyNormedField 𝕜]
+    {U : Set 𝕜} (hU : IsOpen U) (hUc : IsPreconnected U)
+    {F G : 𝕜 → 𝕜} {c : ℕ → 𝕜 → 𝕜} {n : ℕ}
+    (hF : AnalyticOnNhd 𝕜 F U) (hG : AnalyticOnNhd 𝕜 G U) (hG0 : ∃ z ∈ U, G z ≠ 0)
+    (hc : ∀ k < n, AnalyticOnNhd 𝕜 (c k) U)
+    (hrel : Set.EqOn (F ^ n + ∑ k ∈ Finset.range n, c k * G ^ (n - k) * F ^ k) 0 U) :
+    ∃ H : 𝕜 → 𝕜, AnalyticOnNhd 𝕜 H U ∧ Set.EqOn F (G * H) U :=
+  solution hU hUc hF hG hG0 hc hrel
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_exists_levelFraction_of_stable_family.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_exists_levelFraction_of_stable_family.lean
new file mode 100644
index 0000000000..79b106afba
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_exists_levelFraction_of_stable_family.lean
@@ -0,0 +1,1421 @@
+/-
+Based on Prove2Me node WLight.exists_levelFraction_of_stable_family
+(490607a5-50bf-5b84-bea7-42d3fd2f1404) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 786cc53b-f5ea-5b92-be39-5aab5f10fc60
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.SpecialFunctions.Elliptic.Weierstrass
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import Mathlib.Geometry.Manifold.Notation
+
+import Mathlib.NumberTheory.ModularForms.EisensteinSeries.QExpansion
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+import Mathlib.RingTheory.DedekindDomain.IntegralClosure
+import Mathlib.RingTheory.DedekindDomain.Ideal.Lemmas
+import Mathlib.RingTheory.Unramified.Field
+import Mathlib.Analysis.Meromorphic.NormalForm
+import Mathlib.RingTheory.Discriminant
+import Mathlib.RingTheory.Adjoin.PowerBasis
+import Mathlib.RingTheory.Adjoin.Polynomial.Transcendental
+import Mathlib.FieldTheory.PrimitiveElement
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.LinearAlgebra.Lagrange
+import Mathlib.FieldTheory.LinearDisjoint
+import Mathlib.FieldTheory.Galois.Infinite
+import Mathlib.RingTheory.AlgebraicIndependent.TranscendenceBasis
+import Mathlib.RingTheory.AlgebraicIndependent.AlgebraicClosure
+import Mathlib.RingTheory.AlgebraicIndependent.Adjoin
+import Mathlib.RingTheory.Polynomial.RationalRoot
+import Mathlib.Analysis.Analytic.Order
+import Mathlib.RingTheory.PowerSeries.Order
+import Mathlib.RingTheory.Polynomial.IsIntegral
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelOne_hauptmodul_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_modularity_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_orbit_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Level-N modular functions as fractions over ℂ[j,fᵥ]
+
+Theorem statement: `WLight.exists_levelFraction_of_stable_family`
+(`490607a5-50bf-5b84-bea7-42d3fd2f1404`), by Claude, 2026-09-05.
+
+Proof: submission `786cc53b-f5ea-5b92-be39-5aab5f10fc60`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a positive natural number. Fix a family of period pairs $L : \mathbb{H} \to
+\mathtt{PeriodPair}$ normalised by $\omega_1(L\tau) = \tau$ and $\omega_2(L\tau) = 1$ for all
+$\tau$; a family $W$ indexed by $v \in (\mathbb{Z}/N)^2$ with $W_v(\tau) = (2\pi
+i)^{-2}\,\wp_{L\tau}\big((\tilde v_0 \tau + \tilde v_1)/N\big)$, where $\tilde v_i$ denotes the
+canonical lift of $v_i$ to $\mathbb{Z}$; a family $\mathtt{fricke}$ with $\mathtt{fricke}_v(\tau) =
+-\big(E_4(\tau)E_6(\tau)/\Delta(\tau)\big)/2592 \cdot W_v(\tau)$; and a function $jf$ with $jf(\tau)
+= E_4(\tau)^3/\Delta(\tau)$. Let $S$ be a set of functions $\mathbb{H} \to \mathbb{C}$ such that
+every $G \in S$ is holomorphic (differentiable as a map of complex manifolds), every $G \in S$
+satisfies $G \cdot \Delta^m$ bounded at $i\infty$ for some $m \in \mathbb{N}$, $S$ is closed under
+precomposition with the action of each $\gamma \in \mathrm{SL}_2(\mathbb{Z})$ on $\mathbb{H}$, and
+every $G \in S$ satisfies $G(\gamma\tau) = G(\tau)$ for all $\gamma$ in the principal congruence
+subgroup of level $N$ and all $\tau$. Then for every $F \in S$ there exist $a, b : \mathbb{H} \to
+\mathbb{C}$, both lying in the $\mathbb{C}$-subalgebra of functions generated by $jf$ together with
+the functions $\mathtt{fricke}_v$ for $v \neq 0$, with $b$ not the zero function and $F \cdot b =
+a$.
+
+This is the function-level form of the classical statement that every modular function of level $N$
+is a rational function of $j$ and the Fricke functions $f_v$: the conclusion is a single fraction
+identity $F \cdot b = a$ with numerator and denominator in the polynomial algebra $\mathbb{C}[j, f_v
+: v \neq 0]$, no field of fractions being formed, and $b \neq 0$ only as a function (it may vanish
+at isolated points). It feeds the rationality statements for $q$-expansion coefficients of forms on
+$\Gamma_1(N)$ and the spanning results for Fricke-rational combinations of $E_4$ and $E_6$ powers.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WLight_exists_levelFraction_of_stable_family.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WLight_exists_levelFraction_of_stable_family
+
+noncomputable section
+open Complex Real
+namespace WLight
+p2m_export "WLight" "levelOne_hauptmodul_package frickeFunction_modularity_package \
+  frickeFunction_orbit_package"
+p2m_open "WLight"
+
+section Floor
+open scoped UpperHalfPlane Manifold MatrixGroups ModularForm
+p2m_open "PeriodPair ModularForm CuspForm ModularForm.CuspForm"
+p2m_open "UpperHalfPlane~I"
+
+def j : ℍ → ℂ := fun z => E₄ z ^ 3 / ModularForm.discriminant z
+
+theorem j_surjective : Function.Surjective j :=
+  levelOne_hauptmodul_package.2.2.1
+
+def periodPairOfTau (τ : ℍ) : PeriodPair where
+  ω₁ := (τ : ℂ)
+  ω₂ := 1
+  indep := LinearIndependent.pair_iff.mpr fun s t hst ↦ by
+    have him : s * (τ : ℂ).im = 0 := by
+      have := congrArg Complex.im hst
+      simpa [Complex.add_im, Complex.smul_im, smul_eq_mul] using this
+    have hs : s = 0 :=
+      (mul_eq_zero.mp him).resolve_right (UpperHalfPlane.coe_im τ ▸ τ.im_ne_zero)
+    subst hs
+    simpa using hst
+
+@[scoped simp] lemma periodPairOfTau_ω₁ (τ : ℍ) : (periodPairOfTau τ).ω₁ = (τ : ℂ) := rfl
+@[scoped simp] lemma periodPairOfTau_ω₂ (τ : ℍ) : (periodPairOfTau τ).ω₂ = 1 := rfl
+
+def wpTorsion (N a₁ a₂ : ℕ) (τ : ℍ) : ℂ :=
+  PeriodPair.weierstrassP (periodPairOfTau τ) (((a₁ : ℂ) * τ + a₂) / N)
+
+def wpNorm (N a₁ a₂ : ℕ) (τ : ℍ) : ℂ := ((2 * π * I) ^ 2)⁻¹ * wpTorsion N a₁ a₂ τ
+
+section B6_fixedFrac
+
+variable {A : Type*} [CommRing A] {G : Type*} [Group G] [MulSemiringAction G A]
+
+lemma smul_prod_smul_eq [Fintype G] (v : A) (g₀ : G) : g₀ • (∏ g : G, g • v) = ∏ g : G, g • v := by
+  rw [show g₀ • (∏ g : G, g • v) = MulSemiringAction.toRingHom G A g₀ (∏ g : G, g • v) from rfl,
+    map_prod]
+  simp only [MulSemiringAction.toRingHom_apply, smul_smul]
+  exact Fintype.prod_equiv (Equiv.mulLeft g₀) _ _ fun g ↦ rfl
+
+variable [IsDomain A] {K : Type*} [Field K] [Algebra A K] [IsFractionRing A K]
+  [MulSemiringAction G K]
+
+theorem exists_fixed_div_of_fixed [Finite G]
+    (hcompat : ∀ (g : G) (a : A), g • algebraMap A K a = algebraMap A K (g • a))
+    (x : K) (hx : ∀ g : G, g • x = x) :
+    ∃ a b : A, (∀ g : G, g • a = a) ∧ (∀ g : G, g • b = b) ∧ algebraMap A K b ≠ 0 ∧
+      x * algebraMap A K b = algebraMap A K a := by
+  classical
+  let := Fintype.ofFinite G
+  obtain ⟨u, v, hv, rfl⟩ := IsFractionRing.div_surjective (A := A) x
+  have hv0 : v ≠ 0 := nonZeroDivisors.ne_zero hv
+  have hinj : Function.Injective (algebraMap A K) := IsFractionRing.injective A K
+  set b : A := ∏ g : G, g • v with hb
+  set a : A := u * ∏ g ∈ (Finset.univ : Finset G).erase 1, g • v with ha
+  have hbfix : ∀ g : G, g • b = b := fun g ↦ smul_prod_smul_eq v g
+  have hb0 : algebraMap A K b ≠ 0 := by
+    rw [map_ne_zero_iff _ hinj, hb]
+    exact Finset.prod_ne_zero_iff.mpr fun g _ ↦ (smul_ne_zero_iff_ne g).mpr hv0
+  have hxb : algebraMap A K u / algebraMap A K v * algebraMap A K b = algebraMap A K a := by
+    have hv0' : algebraMap A K v ≠ 0 := (map_ne_zero_iff _ hinj).mpr hv0
+    rw [hb, ← Finset.mul_prod_erase _ _ (Finset.mem_univ (1 : G)), one_smul, ha, map_mul,
+      map_mul]
+    field_simp
+  refine ⟨a, b, fun g ↦ ?_, hbfix, hb0, hxb⟩
+  apply hinj
+  rw [← hcompat, ← hxb, smul_mul', hx, hcompat, hbfix]
+
+end B6_fixedFrac
+
+def denomZ (γ : SL(2, ℤ)) (τ : ℂ) : ℂ := (γ 1 0 : ℤ) * τ + (γ 1 1 : ℤ)
+
+lemma denomZ_ne_zero (γ : SL(2, ℤ)) (τ : ℍ) : denomZ γ (τ : ℂ) ≠ 0 := by
+  intro h
+  have him : ((γ 1 0 : ℤ) : ℝ) * (τ : ℂ).im = 0 := by
+    have := congrArg Complex.im h
+    simp only [denomZ, Complex.add_im, Complex.mul_im, Complex.intCast_im, zero_mul,
+      Complex.intCast_re, add_zero, Complex.zero_im] at this
+    linarith
+  have hc0 : (γ 1 0 : ℤ) = 0 := by
+    rcases mul_eq_zero.mp him with h | h
+    · exact_mod_cast h
+    · exact absurd h (UpperHalfPlane.coe_im τ ▸ τ.im_ne_zero)
+  have hd0 : (γ 1 1 : ℤ) = 0 := by
+    have := h
+    rw [denomZ, hc0] at this
+    simpa using this
+  have hdet : γ 0 0 * γ 1 1 - γ 0 1 * γ 1 0 = 1 := by
+    have := γ.2; rwa [Matrix.det_fin_two] at this
+  rw [hc0, hd0] at hdet
+  simp at hdet
+
+def vecMulSL (N : ℕ) (a : Fin 2 → ZMod N) (γ : SL(2, ℤ)) : Fin 2 → ZMod N :=
+  Matrix.vecMul a ((γ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N))
+
+lemma vecMulSL_apply (N : ℕ) (a : Fin 2 → ZMod N) (γ : SL(2, ℤ)) (j : Fin 2) :
+    vecMulSL N a γ j = a 0 * (γ 0 j : ℤ) + a 1 * (γ 1 j : ℤ) := by
+  simp [vecMulSL, Matrix.vecMul, dotProduct, Fin.sum_univ_two, Matrix.map_apply]
+
+section B3_spelling2
+
+open scoped UpperHalfPlane Manifold MatrixGroups
+p2m_open "UpperHalfPlane~I"
+open Matrix.SpecialLinearGroup
+
+lemma denom_mapGL_eq_denomZ (γ : SL(2, ℤ)) (τ : ℍ) :
+    denom (mapGL ℝ γ) τ = denomZ γ τ := by
+  simp [denom, denomZ]
+
+def wpNormZ (N : ℕ) (a : Fin 2 → ZMod N) (τ : ℍ) : ℂ := wpNorm N (a 0).val (a 1).val τ
+
+def frickeF (N : ℕ) (a : Fin 2 → ZMod N) (τ : ℍ) : ℂ :=
+  -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * wpNormZ N a τ
+
+theorem r4a_package (N : ℕ) [NeZero N] :
+    (∀ (a : Fin 2 → ZMod N) (γ : SL(2, ℤ)) (τ : ℍ), (frickeF N) a (γ • τ) =
+        (frickeF N) (Matrix.vecMul a ((γ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N))) τ) ∧
+    (∀ a : Fin 2 → ZMod N, (frickeF N) (-a) = (frickeF N) a) ∧
+    (∀ a : Fin 2 → ZMod N, a ≠ 0 → MDifferentiable 𝓘(ℂ) 𝓘(ℂ) ((frickeF N) a)) ∧
+    (∀ a : Fin 2 → ZMod N, a ≠ 0 →
+      IsBoundedAtImInfty ((frickeF N) a * ModularForm.discriminant)) ∧
+    (∀ a : Fin 2 → ZMod N, a ≠ 0 →
+      Function.Periodic (((frickeF N) a * ModularForm.discriminant) ∘ ofComplex) N ∧
+      ∀ n : ℕ, (qExpansion N ((frickeF N) a * ModularForm.discriminant)).coeff n ∈
+        IntermediateField.adjoin ℚ {cexp (2 * π * I / N)}) ∧
+    (∀ a b : Fin 2 → ZMod N, a ≠ 0 → b ≠ 0 → (frickeF N) a = (frickeF N) b → b = a ∨ b = -a) ∧
+    (∀ a : Fin 2 → ZMod N, ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : ℍ,
+      (frickeF N) a (γ • τ) = (frickeF N) a τ) ∧
+    (∀ s : ℕ, s.Coprime N →
+      ∀ φ : ↑(IntermediateField.adjoin ℚ {cexp (2 * π * I / N)}) →+* ℂ,
+        (∀ z : ↑(IntermediateField.adjoin ℚ {cexp (2 * π * I / N)}),
+            (z : ℂ) = cexp (2 * π * I / N) → φ z = cexp (2 * π * I / N) ^ s) →
+        ∀ a : Fin 2 → ZMod N, a ≠ 0 →
+          ∀ (n : ℕ) (z : ↑(IntermediateField.adjoin ℚ {cexp (2 * π * I / N)})),
+            (z : ℂ) = (qExpansion N ((frickeF N) a * ModularForm.discriminant)).coeff n →
+            (qExpansion N ((frickeF N) ![a 0, (s : ZMod N) * a 1]
+              * ModularForm.discriminant)).coeff n = φ z) :=
+  frickeFunction_modularity_package N periodPairOfTau fun _ ↦ ⟨rfl, rfl⟩
+
+theorem r4b_package (N : ℕ) [NeZero N] :
+    (MDifferentiable 𝓘(ℂ) 𝓘(ℂ) j ∧
+      ∃ m : ℕ, IsBoundedAtImInfty (j * ModularForm.discriminant ^ m)) ∧
+    (∀ v : Fin 2 → ZMod N, v ≠ 0 → MDifferentiable 𝓘(ℂ) 𝓘(ℂ) ((frickeF N) v) ∧
+      ∃ m : ℕ, IsBoundedAtImInfty ((frickeF N) v * ModularForm.discriminant ^ m)) ∧
+    (∃ P : ℕ → Polynomial ℂ,
+      (∀ k i, (P k).coeff i ∈
+        IntermediateField.adjoin ℚ {Complex.exp (2 * (Real.pi : ℂ) * Complex.I / N)}) ∧
+      ∀ v : Fin 2 → ZMod N, v ≠ 0 → ∀ τ : ℍ,
+        (frickeF N) v τ ^ (N ^ 2 - 1) + ∑ k ∈ Finset.range (N ^ 2 - 1),
+          (P k).eval (j τ) * (frickeF N) v τ ^ k = 0) :=
+  frickeFunction_orbit_package N periodPairOfTau (fun _ ↦ ⟨rfl, rfl⟩) (wpNormZ N) (fun _ _ ↦ rfl)
+    (frickeF N) (fun _ _ ↦ rfl) j fun _ ↦ rfl
+
+theorem frickeF_slash {N : ℕ} [NeZero N] (a : Fin 2 → ZMod N) (γ : SL(2, ℤ)) (τ : ℍ) :
+    frickeF N a (γ • τ) = frickeF N (vecMulSL N a γ) τ :=
+  (r4a_package N).1 a γ τ
+
+theorem frickeF_invariant_Gamma {N : ℕ} [NeZero N] (a : Fin 2 → ZMod N) {γ : SL(2, ℤ)}
+    (hγ : γ ∈ CongruenceSubgroup.Gamma N) (τ : ℍ) : frickeF N a (γ • τ) = frickeF N a τ :=
+  (r4a_package N).2.2.2.2.2.2.1 a γ hγ τ
+
+lemma vecMulSL_mul (N : ℕ) (a : Fin 2 → ZMod N) (γ δ : SL(2, ℤ)) :
+    vecMulSL N a (γ * δ) = vecMulSL N (vecMulSL N a γ) δ := by
+  have hmap : ((γ * δ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N) =
+      (γ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N) *
+        (δ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N) := by
+    rw [Matrix.SpecialLinearGroup.coe_mul]
+    exact Matrix.map_mul (f := Int.castRingHom (ZMod N))
+  simp only [vecMulSL, hmap, Matrix.vecMul_vecMul]
+
+lemma vecMulSL_one (N : ℕ) (a : Fin 2 → ZMod N) : vecMulSL N a 1 = a := by
+  simp [vecMulSL]
+
+lemma vecMulSL_zero (N : ℕ) (γ : SL(2, ℤ)) : vecMulSL N 0 γ = 0 := by
+  funext j; simp [vecMulSL_apply]
+
+lemma vecMulSL_ne_zero {N : ℕ} {a : Fin 2 → ZMod N} (ha : a ≠ 0) (γ : SL(2, ℤ)) :
+    vecMulSL N a γ ≠ 0 := by
+  intro h
+  apply ha
+  have := congrArg (fun b ↦ vecMulSL N b γ⁻¹) h
+  simpa [← vecMulSL_mul, vecMulSL_one, vecMulSL_zero] using this
+
+abbrev FrickeIdx (N : ℕ) : Type := {a : Fin 2 → ZMod N // a ≠ 0}
+
+scoped instance (N : ℕ) [NeZero N] : Fintype (FrickeIdx N) := by unfold FrickeIdx; infer_instance
+
+theorem mdifferentiable_frickeF {N : ℕ} [NeZero N] (i : FrickeIdx N) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (frickeF N i.1) :=
+  (r4a_package N).2.2.1 i.1 i.2
+
+theorem frickeF_eq_imp {N : ℕ} [NeZero N] (a b : FrickeIdx N)
+    (h : frickeF N a.1 = frickeF N b.1) : b.1 = a.1 ∨ b.1 = -a.1 :=
+  (r4a_package N).2.2.2.2.2.1 a.1 b.1 a.2 b.2 h
+
+theorem mem_Gamma_or_neg_mem_of_vecMulSL {N : ℕ} [NeZero N] (γ : SL(2, ℤ))
+    (h : ∀ a : Fin 2 → ZMod N, a ≠ 0 → vecMulSL N a γ = a ∨ vecMulSL N a γ = -a) :
+    γ ∈ CongruenceSubgroup.Gamma N ∨ -γ ∈ CongruenceSubgroup.Gamma N := by
+  rcases Nat.lt_or_ge 1 N with hN | hN
+  · have : Fact (1 < N) := ⟨hN⟩
+    have h10 : (1 : ZMod N) ≠ 0 := one_ne_zero
+    have r1 := h ![1, 0] (fun e ↦ h10 (by simpa using congrFun e 0))
+    have r2 := h ![0, 1] (fun e ↦ h10 (by simpa using congrFun e 1))
+    have r3 := h ![1, 1] (fun e ↦ h10 (by simpa using congrFun e 0))
+    simp only [funext_iff, Fin.forall_fin_two, vecMulSL_apply, Matrix.cons_val_zero,
+      Matrix.cons_val_one, Matrix.cons_val_fin_one, one_mul, zero_mul, add_zero, zero_add,
+      Pi.neg_apply, neg_zero] at r1 r2 r3
+    have e01 : ((γ 0 1 : ℤ) : ZMod N) = 0 := by rcases r1 with ⟨_, e⟩ | ⟨_, e⟩ <;> exact e
+    have e10 : ((γ 1 0 : ℤ) : ZMod N) = 0 := by rcases r2 with ⟨e, _⟩ | ⟨e, _⟩ <;> exact e
+    have e0011 : ((γ 0 0 : ℤ) : ZMod N) = ((γ 1 1 : ℤ) : ZMod N) := by
+      rcases r3 with ⟨c1, c2⟩ | ⟨c1, c2⟩ <;>
+        (rw [e10, add_zero] at c1; rw [e01, zero_add] at c2; rw [c1, c2])
+    rw [CongruenceSubgroup.Gamma_mem, CongruenceSubgroup.Gamma_mem]
+    simp only [Matrix.SpecialLinearGroup.coe_neg, Matrix.neg_apply, Int.cast_neg, neg_eq_zero]
+    rcases r1 with ⟨a1, _⟩ | ⟨a1, _⟩
+    · left; exact ⟨a1, e01, e10, by rw [← e0011]; exact a1⟩
+    · right; exact ⟨by rw [a1, neg_neg], e01, e10, by rw [← e0011, a1, neg_neg]⟩
+  · have : N = 1 := by have := NeZero.ne N; omega
+    subst this
+    left
+    simp [CongruenceSubgroup.Gamma_one_top]
+
+theorem frickeF_faithful {N : ℕ} [NeZero N] (γ : SL(2, ℤ))
+    (h : ∀ i : FrickeIdx N, ∀ τ : ℍ, frickeF N i.1 (γ • τ) = frickeF N i.1 τ) :
+    γ ∈ CongruenceSubgroup.Gamma N ∨ -γ ∈ CongruenceSubgroup.Gamma N := by
+  refine mem_Gamma_or_neg_mem_of_vecMulSL γ fun a ha ↦ ?_
+  have hfun : frickeF N a = frickeF N (vecMulSL N a γ) := by
+    funext τ; rw [← frickeF_slash, h ⟨a, ha⟩ τ]
+  rcases frickeF_eq_imp ⟨a, ha⟩ ⟨vecMulSL N a γ, vecMulSL_ne_zero ha γ⟩ hfun with e | e
+  · exact Or.inl e
+  · exact Or.inr e
+
+end B3_spelling2
+
+section B6Instance
+
+p2m_open "UpperHalfPlane ModularForm CuspForm ModularForm.CuspForm Polynomial Real.Polynomial"
+open scoped MatrixGroups Manifold
+
+theorem frickeF_integral_over_j (N : ℕ) [NeZero N] :
+    ∃ P : ℕ → Polynomial ℂ,
+      ∀ (i : FrickeIdx N) (τ : ℍ),
+        frickeF N i.1 τ ^ (N ^ 2 - 1) +
+          ∑ k ∈ Finset.range (N ^ 2 - 1),
+            Polynomial.eval (j τ) (P k) * frickeF N i.1 τ ^ k = 0 := by
+  obtain ⟨P, -, hP⟩ := (r4b_package N).2.2
+  exact ⟨P, fun i τ => hP i.1 i.2 τ⟩
+
+end B6Instance
+
+section B6Ring
+
+p2m_open "UpperHalfPlane ModularForm SlashInvariantForm ModularFormClass CuspForm \
+  ModularForm.CuspForm Polynomial Real.Polynomial Filter"
+open scoped MatrixGroups Manifold
+
+def PoleBounded (f : ℍ → ℂ) : Prop :=
+  MDiff f ∧ ∃ m : ℕ, IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m)
+
+lemma isBoundedAtImInfty_discriminant : IsBoundedAtImInfty (⇑CuspForm.discriminant : ℍ → ℂ) :=
+  (CuspFormClass.zero_at_infty CuspForm.discriminant).boundedAtFilter
+
+lemma isBoundedAtImInfty_discPow (n : ℕ) :
+    IsBoundedAtImInfty (⇑CuspForm.discriminant ^ n : ℍ → ℂ) := by
+  induction n with
+  | zero => exact pow_zero (⇑CuspForm.discriminant : ℍ → ℂ) ▸ const_boundedAtFilter _ (1 : ℂ)
+  | succ k ih =>
+    rw [pow_succ]
+    exact ih.mul isBoundedAtImInfty_discriminant
+
+lemma IsBoundedAtImInfty.mul_discPow_mono {f : ℍ → ℂ} {m m' : ℕ} (hm : m ≤ m')
+    (h : IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m)) :
+    IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m') := by
+  have hshape : (f * ⇑CuspForm.discriminant ^ m' : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m) * ⇑CuspForm.discriminant ^ (m' - m) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply]
+    rw [mul_assoc, ← pow_add, Nat.add_sub_cancel' hm]
+  rw [hshape]
+  exact h.mul (isBoundedAtImInfty_discPow (m' - m))
+
+lemma poleBounded_algebraMap (r : ℂ) : PoleBounded (algebraMap ℂ (ℍ → ℂ) r) := by
+  refine ⟨mdifferentiable_const, 0, ?_⟩
+  have hshape : ((algebraMap ℂ (ℍ → ℂ) r) * ⇑CuspForm.discriminant ^ 0 : ℍ → ℂ) =
+      fun _ => r := by
+    funext τ
+    simp
+  rw [hshape]
+  exact const_boundedAtFilter _ r
+
+lemma PoleBounded.add {f g : ℍ → ℂ} (hf : PoleBounded f) (hg : PoleBounded g) :
+    PoleBounded (f + g) := by
+  obtain ⟨hf1, m1, hf2⟩ := hf
+  obtain ⟨hg1, m2, hg2⟩ := hg
+  refine ⟨hf1.add hg1, max m1 m2, ?_⟩
+  have hshape : ((f + g) * ⇑CuspForm.discriminant ^ max m1 m2 : ℍ → ℂ) =
+      f * ⇑CuspForm.discriminant ^ max m1 m2 + g * ⇑CuspForm.discriminant ^ max m1 m2 := by
+    funext τ
+    simp [add_mul]
+  rw [hshape]
+  exact (IsBoundedAtImInfty.mul_discPow_mono (le_max_left _ _) hf2).add
+    (IsBoundedAtImInfty.mul_discPow_mono (le_max_right _ _) hg2)
+
+lemma PoleBounded.mul {f g : ℍ → ℂ} (hf : PoleBounded f) (hg : PoleBounded g) :
+    PoleBounded (f * g) := by
+  obtain ⟨hf1, m1, hf2⟩ := hf
+  obtain ⟨hg1, m2, hg2⟩ := hg
+  refine ⟨hf1.mul hg1, m1 + m2, ?_⟩
+  have hshape : ((f * g) * ⇑CuspForm.discriminant ^ (m1 + m2) : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m1) * (g * ⇑CuspForm.discriminant ^ m2) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply, pow_add]
+    ring
+  rw [hshape]
+  exact hf2.mul hg2
+
+theorem poleBounded_of_mem_adjoin {S : Set (ℍ → ℂ)} (hS : ∀ f ∈ S, PoleBounded f)
+    {a : ℍ → ℂ} (ha : a ∈ Algebra.adjoin ℂ S) : PoleBounded a := by
+  induction ha using Algebra.adjoin_induction with
+  | mem f hf => exact hS f hf
+  | algebraMap r => exact poleBounded_algebraMap r
+  | add x y hx hy ihx ihy => exact ihx.add ihy
+  | mul x y hx hy ihx ihy => exact ihx.mul ihy
+
+lemma poleBounded_j : PoleBounded j := by
+  rw [PoleBounded, CuspForm.coe_discriminant]
+  exact (r4b_package 1).1
+
+lemma poleBounded_frickeF {N : ℕ} [NeZero N] (i : FrickeIdx N) :
+    PoleBounded (frickeF N i.1) := by
+  rw [PoleBounded, CuspForm.coe_discriminant]
+  exact (r4b_package N).2.1 i.1 i.2
+
+theorem eq_polynomial_j_of_invariant_of_mem_adjoin {S : Set (ℍ → ℂ)}
+    (hS : ∀ f ∈ S, PoleBounded f) {a : ℍ → ℂ} (ha : a ∈ Algebra.adjoin ℂ S)
+    (hinv : ∀ γ : SL(2, ℤ), a ∣[(0 : ℤ)] γ = a) :
+    ∃ P : Polynomial ℂ, a = fun τ => Polynomial.eval (j τ) P := by
+  obtain ⟨hhol, m, hbd⟩ := poleBounded_of_mem_adjoin hS ha
+  rw [CuspForm.coe_discriminant] at hbd
+  obtain ⟨P, -, hP⟩ := levelOne_hauptmodul_package.1 m a hhol hinv hbd
+  exact ⟨P, hP⟩
+
+end B6Ring
+
+end Floor
+
+section B5_carrier
+
+open scoped UpperHalfPlane Manifold MatrixGroups ModularForm
+p2m_open "UpperHalfPlane~I"
+
+scoped instance slFnAction : MulSemiringAction SL(2, ℤ) (ℍ → ℂ) where
+  smul γ f := fun τ ↦ f (γ⁻¹ • τ)
+  one_smul f := by funext τ; change f ((1 : SL(2, ℤ))⁻¹ • τ) = f τ; rw [inv_one, one_smul]
+  mul_smul γ δ f := by
+    funext τ
+    change f ((γ * δ)⁻¹ • τ) = f (δ⁻¹ • (γ⁻¹ • τ))
+    rw [mul_inv_rev, mul_smul]
+  smul_zero γ := rfl
+  smul_add γ f g := rfl
+  smul_one γ := rfl
+  smul_mul γ f g := rfl
+
+lemma sl_smul_apply (γ : SL(2, ℤ)) (f : ℍ → ℂ) (τ : ℍ) : (γ • f) τ = f (γ⁻¹ • τ) := rfl
+
+scoped instance slFn_smulCommClass : SMulCommClass SL(2, ℤ) ℂ (ℍ → ℂ) where
+  smul_comm _ _ _ := rfl
+
+lemma sl_smul_eq_self_iff (f : ℍ → ℂ) :
+    (∀ γ : SL(2, ℤ), γ • f = f) ↔ ∀ (γ : SL(2, ℤ)) (τ : ℍ), f (γ • τ) = f τ := by
+  constructor
+  · intro h γ τ
+    have := congrFun (h γ⁻¹) τ
+    rwa [sl_smul_apply, inv_inv] at this
+  · intro h γ
+    funext τ
+    rw [sl_smul_apply, h]
+
+def HolFn : Subalgebra ℂ (ℍ → ℂ) where
+  carrier := {f | MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f}
+  mul_mem' hf hg := hf.mul hg
+  add_mem' hf hg := hf.add hg
+  algebraMap_mem' c := by
+    change MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fun _ : ℍ ↦ c)
+    exact mdifferentiable_const
+
+lemma mem_HolFn {f : ℍ → ℂ} : f ∈ HolFn ↔ MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f := Iff.rfl
+
+theorem HolFn.eq_zero_or_eq_zero_of_mul_eq_zero {f g : ℍ → ℂ} (hf : f ∈ HolFn) (hg : g ∈ HolFn)
+    (h : f * g = 0) : f = 0 ∨ g = 0 := by
+  rw [mem_HolFn, UpperHalfPlane.mdifferentiable_iff] at hf hg
+  have hU : IsOpen {z : ℂ | 0 < z.im} := isOpen_upperHalfPlaneSet
+  have key := AnalyticOnNhd.eq_zero_or_eq_zero_of_mul_eq_zero (hf.analyticOnNhd hU)
+    (hg.analyticOnNhd hU) (fun z hz ↦ by
+      have := congrFun h (ofComplex z)
+      simpa using this) (convex_halfSpace_im_gt 0).isPreconnected
+  rcases key with k | k
+  · left; funext τ; simpa [ofComplex_apply] using k (τ : ℂ) τ.im_pos
+  · right; funext τ; simpa [ofComplex_apply] using k (τ : ℂ) τ.im_pos
+
+scoped instance : NoZeroDivisors ↥HolFn where
+  eq_zero_or_eq_zero_of_mul_eq_zero {f g} h := by
+    rcases HolFn.eq_zero_or_eq_zero_of_mul_eq_zero f.2 g.2 (congrArg Subtype.val h) with e | e
+    · exact Or.inl (Subtype.ext e)
+    · exact Or.inr (Subtype.ext e)
+
+scoped instance : Nontrivial ↥HolFn :=
+  ⟨⟨0, 1, fun h ↦ zero_ne_one (congrFun (congrArg Subtype.val h) UpperHalfPlane.I)⟩⟩
+
+scoped instance : IsDomain ↥HolFn := NoZeroDivisors.to_isDomain _
+
+lemma j_smul_eq (γ : SL(2, ℤ)) (τ : ℍ) : j (γ • τ) = j τ := by
+  have hγ : (Matrix.SpecialLinearGroup.mapGL ℝ γ : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ, rfl⟩
+  have h4 := SlashInvariantForm.slash_action_eqn'' ModularForm.E₄ hγ τ
+  have hΔ := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hγ τ
+  rw [CuspForm.coe_discriminant] at hΔ
+  rw [show (Matrix.SpecialLinearGroup.mapGL ℝ γ) • τ = γ • τ from rfl,
+    denom_mapGL_eq_denomZ] at h4 hΔ
+  have hd : denomZ γ τ ≠ 0 := denomZ_ne_zero γ τ
+  have hΔ0 : ModularForm.discriminant τ ≠ 0 := ModularForm.discriminant_ne_zero τ
+  simp only [j]
+  rw [h4, hΔ, zpow_ofNat, zpow_ofNat]
+  field_simp
+
+lemma smul_j (γ : SL(2, ℤ)) : γ • j = j := by
+  funext τ; rw [sl_smul_apply, j_smul_eq]
+
+lemma smul_frickeF {N : ℕ} [NeZero N] (γ : SL(2, ℤ)) (a : Fin 2 → ZMod N) :
+    γ • frickeF N a = frickeF N (vecMulSL N a γ⁻¹) := by
+  funext τ; rw [sl_smul_apply, frickeF_slash]
+
+def levelGen (N : ℕ) : Set (ℍ → ℂ) := insert j (Set.range fun i : FrickeIdx N ↦ frickeF N i.1)
+
+def levelRing (N : ℕ) : Subalgebra ℂ (ℍ → ℂ) := Algebra.adjoin ℂ (levelGen N)
+
+lemma j_mem_levelRing (N : ℕ) : j ∈ levelRing N := Algebra.subset_adjoin (Set.mem_insert _ _)
+
+lemma frickeF_mem_levelRing {N : ℕ} (i : FrickeIdx N) : frickeF N i.1 ∈ levelRing N :=
+  Algebra.subset_adjoin (Set.mem_insert_of_mem _ ⟨i, rfl⟩)
+
+lemma mdifferentiable_j : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) j :=
+  (ModularForm.E₄.holo'.pow 3).div CuspForm.discriminant.holo' ModularForm.discriminant_ne_zero
+
+lemma levelGen_subset_HolFn (N : ℕ) [NeZero N] : levelGen N ⊆ HolFn := by
+  rintro f (rfl | ⟨i, rfl⟩)
+  · exact mdifferentiable_j
+  · exact mdifferentiable_frickeF i
+
+lemma levelRing_le_HolFn (N : ℕ) [NeZero N] : levelRing N ≤ HolFn :=
+  Algebra.adjoin_le (levelGen_subset_HolFn N)
+
+scoped instance (N : ℕ) [NeZero N] : IsDomain ↥(levelRing N) := by
+  have : NoZeroDivisors ↥(levelRing N) := ⟨fun {f g} h ↦ by
+    rcases HolFn.eq_zero_or_eq_zero_of_mul_eq_zero (levelRing_le_HolFn N f.2)
+      (levelRing_le_HolFn N g.2) (congrArg Subtype.val h) with e | e
+    · exact Or.inl (Subtype.ext e)
+    · exact Or.inr (Subtype.ext e)⟩
+  have : Nontrivial ↥(levelRing N) :=
+    ⟨⟨0, 1, fun h ↦ zero_ne_one (congrFun (congrArg Subtype.val h) UpperHalfPlane.I)⟩⟩
+  exact NoZeroDivisors.to_isDomain _
+
+lemma smul_mem_levelGen {N : ℕ} [NeZero N] (γ : SL(2, ℤ)) {f : ℍ → ℂ} (hf : f ∈ levelGen N) :
+    γ • f ∈ levelGen N := by
+  rcases hf with rfl | ⟨i, rfl⟩
+  · rw [smul_j]; exact Set.mem_insert _ _
+  · rw [smul_frickeF]
+    exact Set.mem_insert_of_mem _ ⟨⟨_, vecMulSL_ne_zero i.2 γ⁻¹⟩, rfl⟩
+
+theorem smul_mem_levelRing {N : ℕ} [NeZero N] (γ : SL(2, ℤ)) {f : ℍ → ℂ}
+    (hf : f ∈ levelRing N) : γ • f ∈ levelRing N := by
+  induction hf using Algebra.adjoin_induction with
+  | mem x hx => exact Algebra.subset_adjoin (smul_mem_levelGen γ hx)
+  | algebraMap c => rw [Algebra.algebraMap_eq_smul_one, smul_comm, smul_one]
+                    exact Subalgebra.smul_mem _ (Subalgebra.one_mem _) _
+  | add x y _ _ hx hy => rw [smul_add]; exact Subalgebra.add_mem _ hx hy
+  | mul x y _ _ hx hy => rw [smul_mul']; exact Subalgebra.mul_mem _ hx hy
+
+scoped instance levelRingAction (N : ℕ) [NeZero N] : MulSemiringAction SL(2, ℤ) ↥(levelRing N) where
+  smul γ f := ⟨γ • f.1, smul_mem_levelRing γ f.2⟩
+  one_smul f := Subtype.ext (one_smul _ f.1)
+  mul_smul γ δ f := Subtype.ext (mul_smul γ δ f.1)
+  smul_zero γ := Subtype.ext (smul_zero γ)
+  smul_add γ f g := Subtype.ext (smul_add γ f.1 g.1)
+  smul_one γ := Subtype.ext (smul_one γ)
+  smul_mul γ f g := Subtype.ext (smul_mul' γ f.1 g.1)
+
+@[scoped simp] lemma levelRing_coe_smul {N : ℕ} [NeZero N] (γ : SL(2, ℤ)) (f : ↥(levelRing N)) :
+    ((γ • f : ↥(levelRing N)) : ℍ → ℂ) = γ • (f : ℍ → ℂ) := rfl
+
+scoped instance levelRing_smulCommClass (N : ℕ) [NeZero N] :
+    SMulCommClass SL(2, ℤ) ℂ ↥(levelRing N) where
+  smul_comm _ _ _ := rfl
+
+def levelFixer (N : ℕ) [NeZero N] : Subgroup SL(2, ℤ) :=
+  (MulSemiringAction.toAlgAut SL(2, ℤ) ℂ ↥(levelRing N)).ker
+
+scoped instance (N : ℕ) [NeZero N] : (levelFixer N).Normal := MonoidHom.normal_ker _
+
+lemma mem_levelFixer_iff {N : ℕ} [NeZero N] (γ : SL(2, ℤ)) :
+    γ ∈ levelFixer N ↔ ∀ f : ↥(levelRing N), γ • f = f := by
+  rw [levelFixer, MonoidHom.mem_ker, AlgEquiv.ext_iff]
+  rfl
+
+lemma mem_levelFixer_iff_frickeF {N : ℕ} [NeZero N] (γ : SL(2, ℤ)) :
+    γ ∈ levelFixer N ↔ ∀ (i : FrickeIdx N) (τ : ℍ), frickeF N i.1 (γ • τ) = frickeF N i.1 τ := by
+  rw [mem_levelFixer_iff]
+  constructor
+  · intro h i τ
+    have e := congrArg Subtype.val (h (γ⁻¹ • ⟨frickeF N i.1, frickeF_mem_levelRing i⟩))
+    rw [← mul_smul, mul_inv_cancel, one_smul, levelRing_coe_smul] at e
+    have := congrFun e τ
+    rw [sl_smul_apply, inv_inv] at this
+    exact this.symm
+  · intro h f
+    obtain ⟨f, hf⟩ := f
+    apply Subtype.ext
+    change γ • f = f
+    induction hf using Algebra.adjoin_induction with
+    | mem x hx =>
+      rcases hx with rfl | ⟨i, rfl⟩
+      · exact smul_j γ
+      · funext τ
+        rw [sl_smul_apply]
+        have := h i (γ⁻¹ • τ)
+        rw [← mul_smul, mul_inv_cancel, one_smul] at this
+        exact this.symm
+    | algebraMap c => rfl
+    | add x y _ _ hx hy => rw [smul_add, hx, hy]
+    | mul x y _ _ hx hy => rw [smul_mul', hx, hy]
+
+lemma Gamma_le_levelFixer (N : ℕ) [NeZero N] : CongruenceSubgroup.Gamma N ≤ levelFixer N :=
+  fun _ hγ ↦ (mem_levelFixer_iff_frickeF _).mpr fun i τ ↦ frickeF_invariant_Gamma i.1 hγ τ
+
+theorem mem_levelFixer_iff_pm {N : ℕ} [NeZero N] (γ : SL(2, ℤ)) :
+    γ ∈ levelFixer N ↔ γ ∈ CongruenceSubgroup.Gamma N ∨ -γ ∈ CongruenceSubgroup.Gamma N := by
+  constructor
+  · intro h; exact frickeF_faithful γ ((mem_levelFixer_iff_frickeF γ).mp h)
+  · rintro (h | h)
+    · exact Gamma_le_levelFixer N h
+    · have : γ = -(-γ) := (neg_neg γ).symm
+      rw [this, mem_levelFixer_iff_frickeF]
+      intro i τ
+      rw [ModularGroup.SL_neg_smul]
+      exact frickeF_invariant_Gamma i.1 h τ
+
+scoped instance (N : ℕ) [NeZero N] : (levelFixer N).FiniteIndex :=
+  Subgroup.finiteIndex_of_le (Gamma_le_levelFixer N)
+
+abbrev LevelGrp (N : ℕ) [NeZero N] : Type := SL(2, ℤ) ⧸ levelFixer N
+
+noncomputable scoped instance (N : ℕ) [NeZero N] : Fintype (LevelGrp N) := Fintype.ofFinite _
+
+lemma card_LevelGrp (N : ℕ) [NeZero N] : Fintype.card (LevelGrp N) = (levelFixer N).index := by
+  rw [Fintype.card_eq_nat_card]; rfl
+
+noncomputable scoped instance levelGrpRingAction (N : ℕ) [NeZero N] :
+    MulSemiringAction (LevelGrp N) ↥(levelRing N) :=
+  MulSemiringAction.compHom _
+    (QuotientGroup.kerLift (MulSemiringAction.toAlgAut SL(2, ℤ) ℂ ↥(levelRing N)))
+
+@[scoped simp] lemma levelGrp_mk_smul {N : ℕ} [NeZero N] (γ : SL(2, ℤ)) (f : ↥(levelRing N)) :
+    (QuotientGroup.mk γ : LevelGrp N) • f = γ • f := rfl
+
+scoped instance levelGrp_smulCommClass (N : ℕ) [NeZero N] :
+    SMulCommClass (LevelGrp N) ℂ ↥(levelRing N) where
+  smul_comm q c f := by
+    induction q using QuotientGroup.induction_on with
+    | H γ => simp only [levelGrp_mk_smul]; exact smul_comm γ c f
+
+scoped instance levelGrp_faithful (N : ℕ) [NeZero N] :
+    FaithfulSMul (LevelGrp N) ↥(levelRing N) where
+  eq_of_smul_eq_smul {q₁ q₂} h := by
+    apply QuotientGroup.kerLift_injective (MulSemiringAction.toAlgAut SL(2, ℤ) ℂ ↥(levelRing N))
+    exact AlgEquiv.ext fun f ↦ h f
+
+abbrev levelField (N : ℕ) [NeZero N] : Type := FractionRing ↥(levelRing N)
+
+noncomputable scoped instance levelGrpFieldAction (N : ℕ) [NeZero N] :
+    MulSemiringAction (LevelGrp N) (levelField N) :=
+  IsFractionRing.mulSemiringAction (LevelGrp N) ↥(levelRing N) (levelField N)
+
+scoped instance levelGrp_smulDistribClass (N : ℕ) [NeZero N] :
+    SMulDistribClass (LevelGrp N) ↥(levelRing N) (levelField N) :=
+  IsFractionRing.smulDistribClass (LevelGrp N) ↥(levelRing N) (levelField N)
+
+lemma levelGrp_smul_algebraMap {N : ℕ} [NeZero N] (g : LevelGrp N) (a : ↥(levelRing N)) :
+    g • algebraMap ↥(levelRing N) (levelField N) a =
+      algebraMap ↥(levelRing N) (levelField N) (g • a) :=
+  (algebraMap.coe_smul' g a (levelField N)).symm
+
+scoped instance levelGrpField_faithful (N : ℕ) [NeZero N] :
+    FaithfulSMul (LevelGrp N) (levelField N) :=
+  IsFractionRing.faithfulSMul (LevelGrp N) ↥(levelRing N) (levelField N)
+
+scoped instance levelGrpField_smulCommClass (N : ℕ) [NeZero N] :
+    SMulCommClass (LevelGrp N) ℂ (levelField N) :=
+  IsFractionRing.smulCommClass (LevelGrp N) ℂ ↥(levelRing N) ℂ (levelField N)
+
+theorem finrank_levelField_fixed (N : ℕ) [NeZero N] :
+    Module.finrank (FixedPoints.subfield (LevelGrp N) (levelField N)) (levelField N) =
+      (levelFixer N).index := by
+  rw [FixedPoints.finrank_eq_card, card_LevelGrp]
+
+private def _root_.WLight.jA (N : ℕ) : ↥(levelRing N) := ⟨j, j_mem_levelRing N⟩
+
+p2m_export "WLight" "jA"
+
+private def _root_.WLight.jK (N : ℕ) [NeZero N] :
+    levelField N := algebraMap ↥(levelRing N) (levelField N) (jA N)
+
+p2m_export "WLight" "jK"
+lemma aeval_j_apply (P : Polynomial ℂ) (τ : ℍ) :
+    (Polynomial.aeval j P : ℍ → ℂ) τ = Polynomial.eval (j τ) P := by
+  rw [show (Polynomial.aeval j P : ℍ → ℂ) τ = Pi.evalAlgHom ℂ (fun _ : ℍ ↦ ℂ) τ (Polynomial.aeval j
+    P)
+    from rfl, ← Polynomial.aeval_algHom_apply, ← Polynomial.coe_aeval_eq_eval]
+  rfl
+
+lemma coe_aeval_jA (N : ℕ) (P : Polynomial ℂ) :
+    ((Polynomial.aeval (jA N) P : ↥(levelRing N)) : ℍ → ℂ) = fun τ ↦ Polynomial.eval (j τ) P := by
+  rw [Polynomial.aeval_subalgebra_coe]
+  funext τ
+  exact aeval_j_apply P τ
+
+lemma levelGen_poleBounded (N : ℕ) [NeZero N] : ∀ f ∈ levelGen N, PoleBounded f := by
+  rintro f (rfl | ⟨i, rfl⟩)
+  · exact poleBounded_j
+  · exact poleBounded_frickeF i
+
+theorem levelRing_fixed_eq_aeval_j {N : ℕ} [NeZero N] (a : ↥(levelRing N))
+    (ha : ∀ γ : SL(2, ℤ), γ • a = a) : ∃ P : Polynomial ℂ, a = Polynomial.aeval (jA N) P := by
+  have ha' : ∀ γ : SL(2, ℤ), γ • (a : ℍ → ℂ) = a := fun γ ↦ congrArg Subtype.val (ha γ)
+  have hinv : ∀ γ : SL(2, ℤ), (a : ℍ → ℂ) ∣[(0 : ℤ)] γ = a := by
+    intro γ
+    funext τ
+    rw [ModularForm.SL_slash_apply, neg_zero, zpow_zero, mul_one]
+    exact (sl_smul_eq_self_iff _).mp ha' γ τ
+  obtain ⟨P, hP⟩ := eq_polynomial_j_of_invariant_of_mem_adjoin (levelGen_poleBounded N) a.2 hinv
+  exact ⟨P, Subtype.ext (by rw [coe_aeval_jA]; exact hP)⟩
+
+theorem levelRing_fixed_eq_aeval_j' {N : ℕ} [NeZero N] (a : ↥(levelRing N))
+    (ha : ∀ g : LevelGrp N, g • a = a) : ∃ P : Polynomial ℂ, a = Polynomial.aeval (jA N) P :=
+  levelRing_fixed_eq_aeval_j a fun γ ↦ ha (QuotientGroup.mk γ)
+
+private lemma _root_.WLight.smul_jK {N : ℕ} [NeZero N] (g : LevelGrp N) : g • jK N = jK N := by
+  rw [jK, levelGrp_smul_algebraMap]
+  congr 1
+  induction g using QuotientGroup.induction_on with
+  | H γ => exact Subtype.ext (smul_j γ)
+
+p2m_export "WLight" "smul_jK"
+
+theorem fixedPoints_levelField_eq_adjoin_j (N : ℕ) [NeZero N] :
+    (MulAction.fixedPoints (LevelGrp N) (levelField N) : Set (levelField N)) =
+      (IntermediateField.adjoin ℂ {jK N} : Set (levelField N)) := by
+  apply Set.Subset.antisymm
+  · intro x hx
+    rw [MulAction.mem_fixedPoints] at hx
+    obtain ⟨a, b, ha, hb, hb0, hab⟩ :=
+      exists_fixed_div_of_fixed (A := ↥(levelRing N)) (K := levelField N) (G := LevelGrp N)
+        levelGrp_smul_algebraMap x hx
+    obtain ⟨P, rfl⟩ := levelRing_fixed_eq_aeval_j' a ha
+    obtain ⟨Q, rfl⟩ := levelRing_fixed_eq_aeval_j' b hb
+    rw [SetLike.mem_coe, IntermediateField.mem_adjoin_simple_iff]
+    refine ⟨P, Q, ?_⟩
+    rw [jK, Polynomial.aeval_algebraMap_apply, Polynomial.aeval_algebraMap_apply,
+      eq_div_iff hb0, hab]
+  · change (IntermediateField.adjoin ℂ {jK N} : Set (levelField N)) ⊆
+      (FixedPoints.intermediateField (F := ℂ) (LevelGrp N) : IntermediateField ℂ (levelField N))
+    exact SetLike.coe_subset_coe.mpr (IntermediateField.adjoin_simple_le_iff.mpr fun g ↦ smul_jK g)
+
+end B5_carrier
+
+section B7_group
+
+open Matrix
+open scoped UpperHalfPlane MatrixGroups CongruenceSubgroup
+
+def adjoinNegOneSL {R : Type*} [CommRing R] (H : Subgroup SL(2, R)) : Subgroup SL(2, R) where
+  carrier := {g | g ∈ H ∨ -g ∈ H}
+  mul_mem' ha hb := by
+    rcases ha with ha | ha <;>
+      rcases hb with hb | hb <;>
+      · have := mul_mem ha hb
+        simp_all [neg_mul, mul_neg, neg_neg]
+  one_mem' := .inl H.one_mem
+  inv_mem' ha := by
+    rcases ha with ha | ha <;>
+    · have := inv_mem ha
+      simp_all
+
+@[scoped simp] lemma mem_adjoinNegOneSL
+    {R : Type*} [CommRing R] {H : Subgroup SL(2, R)} {g : SL(2, R)} :
+    g ∈ adjoinNegOneSL H ↔ g ∈ H ∨ -g ∈ H :=
+  Iff.rfl
+
+lemma le_adjoinNegOneSL {R : Type*} [CommRing R] (H : Subgroup SL(2, R)) :
+    H ≤ adjoinNegOneSL H := fun _ hg ↦ .inl hg
+
+lemma normal_adjoinNegOneSL {R : Type*} [CommRing R] {H : Subgroup SL(2, R)} (hH : H.Normal) :
+    (adjoinNegOneSL H).Normal := by
+  constructor
+  intro γ hγ g
+  rcases hγ with h | h
+  · exact .inl (hH.conj_mem γ h g)
+  · refine .inr ?_
+    rw [show -(g * γ * g⁻¹) = g * (-γ) * g⁻¹ by rw [mul_neg, neg_mul]]
+    exact hH.conj_mem (-γ) h g
+
+abbrev pmGamma (N : ℕ) : Subgroup SL(2, ℤ) := adjoinNegOneSL Γ(N)
+
+lemma Gamma_le_pmGamma (N : ℕ) : Γ(N) ≤ pmGamma N := le_adjoinNegOneSL _
+
+scoped instance instNormal_pmGamma (N : ℕ) : (pmGamma N).Normal :=
+  normal_adjoinNegOneSL (CongruenceSubgroup.Gamma_normal N)
+
+scoped instance instFiniteIndex_pmGamma (N : ℕ) [NeZero N] : (pmGamma N).FiniteIndex :=
+  Subgroup.finiteIndex_of_le (Gamma_le_pmGamma N)
+
+def frickeKernel (N : ℕ) [NeZero N] : Subgroup SL(2, ℤ) where
+  carrier := {γ | ∀ (i : FrickeIdx N) (τ : ℍ), frickeF N i.1 (γ • τ) = frickeF N i.1 τ}
+  mul_mem' {a b} ha hb i τ := by rw [mul_smul, ha, hb]
+  one_mem' i τ := by rw [one_smul]
+  inv_mem' {a} ha i τ := by
+    have := ha i (a⁻¹ • τ); rw [smul_inv_smul] at this; exact this.symm
+
+lemma mem_frickeKernel {N : ℕ} [NeZero N] {γ : SL(2, ℤ)} :
+    γ ∈ frickeKernel N ↔ ∀ (i : FrickeIdx N) (τ : ℍ), frickeF N i.1 (γ • τ) = frickeF N i.1 τ :=
+  Iff.rfl
+
+lemma neg_one_smul_upperHalfPlane (τ : ℍ) : (-1 : SL(2, ℤ)) • τ = τ := by
+  rw [show (-1 : SL(2, ℤ)) = -(1 : SL(2, ℤ)) from rfl, ModularGroup.SL_neg_smul, one_smul]
+
+lemma neg_one_mem_frickeKernel (N : ℕ) [NeZero N] : (-1 : SL(2, ℤ)) ∈ frickeKernel N :=
+  fun _ τ ↦ by rw [neg_one_smul_upperHalfPlane]
+
+lemma Gamma_le_frickeKernel (N : ℕ) [NeZero N] : Γ(N) ≤ frickeKernel N :=
+  fun _ hγ i τ ↦ frickeF_invariant_Gamma i.1 hγ τ
+
+theorem frickeKernel_eq_pmGamma (N : ℕ) [NeZero N] : frickeKernel N = pmGamma N := by
+  refine le_antisymm ?_ ?_
+  · intro γ hγ
+    exact mem_adjoinNegOneSL.mpr (frickeF_faithful γ hγ)
+  · intro γ hγ
+    rcases mem_adjoinNegOneSL.mp hγ with h | h
+    · exact Gamma_le_frickeKernel N h
+    · have hrw : γ = -1 * (-γ) := by simp
+      rw [hrw]
+      exact (frickeKernel N).mul_mem (neg_one_mem_frickeKernel N) (Gamma_le_frickeKernel N h)
+
+scoped instance instFiniteIndex_frickeKernel (N : ℕ) [NeZero N] : (frickeKernel N).FiniteIndex :=
+  frickeKernel_eq_pmGamma N ▸ instFiniteIndex_pmGamma N
+
+scoped instance instNormal_frickeKernel (N : ℕ) [NeZero N] : (frickeKernel N).Normal :=
+  frickeKernel_eq_pmGamma N ▸ instNormal_pmGamma N
+
+scoped instance instFinite_quotient_pmGamma (N : ℕ) [NeZero N] : Finite (SL(2, ℤ) ⧸ pmGamma N) :=
+  Subgroup.finite_quotient_of_finiteIndex
+
+scoped instance instFinite_quotient_frickeKernel (N : ℕ) [NeZero N] :
+    Finite (SL(2, ℤ) ⧸ frickeKernel N) :=
+  Subgroup.finite_quotient_of_finiteIndex
+
+end B7_group
+
+section B7_assembled
+
+open scoped UpperHalfPlane MatrixGroups IntermediateField
+
+lemma levelFixer_eq_frickeKernel (N : ℕ) [NeZero N] : levelFixer N = frickeKernel N :=
+  Subgroup.ext fun γ ↦ (mem_levelFixer_iff_frickeF γ).trans mem_frickeKernel.symm
+
+lemma levelFixer_eq_pmGamma (N : ℕ) [NeZero N] : levelFixer N = pmGamma N := by
+  rw [levelFixer_eq_frickeKernel, frickeKernel_eq_pmGamma]
+
+def fixedIF (N : ℕ) [NeZero N] : IntermediateField ℂ (levelField N) :=
+  FixedPoints.intermediateField (F := ℂ) (LevelGrp N)
+
+lemma fixedIF_eq_adjoin (N : ℕ) [NeZero N] : fixedIF N = ℂ⟮jK N⟯ :=
+  SetLike.coe_injective (fixedPoints_levelField_eq_adjoin_j N)
+
+lemma finrank_fixedIF (N : ℕ) [NeZero N] :
+    Module.finrank ↥(fixedIF N) (levelField N) = (levelFixer N).index :=
+  finrank_levelField_fixed N
+
+theorem finrank_adjoin_j_levelField (N : ℕ) [NeZero N] :
+    Module.finrank ↥ℂ⟮jK N⟯ (levelField N) = (pmGamma N).index := by
+  rw [← fixedIF_eq_adjoin, finrank_fixedIF, levelFixer_eq_pmGamma]
+
+theorem transcendental_jA (N : ℕ) [NeZero N] : Transcendental ℂ (jA N) := by
+  rw [transcendental_iff]
+  intro P hP
+  have hfun : (fun τ : ℍ ↦ Polynomial.eval (j τ) P) = 0 := by
+    rw [← coe_aeval_jA N P, hP]; rfl
+  apply Polynomial.eq_zero_of_infinite_isRoot
+  have : {x : ℂ | P.IsRoot x} = Set.univ := by
+    ext z
+    simp only [Set.mem_ofPred_eq, Set.mem_univ, iff_true, Polynomial.IsRoot.def]
+    obtain ⟨τ, rfl⟩ := j_surjective z
+    exact congrFun hfun τ
+  rw [this]
+  exact Set.infinite_univ
+
+theorem transcendental_jK (N : ℕ) [NeZero N] : Transcendental ℂ (jK N) := by
+  rw [transcendental_iff]
+  intro P hP
+  rw [jK, Polynomial.aeval_algebraMap_apply,
+    map_eq_zero_iff _ (IsFractionRing.injective ↥(levelRing N) (levelField N))] at hP
+  exact (transcendental_iff.mp (transcendental_jA N)) P hP
+
+end B7_assembled
+
+section C1_carrier
+
+open scoped UpperHalfPlane MatrixGroups IntermediateField IntermediateField.algebraAdjoinAdjoin
+p2m_open "Polynomial Real.Polynomial"
+
+abbrev polyJ (N : ℕ) [NeZero N] : Subalgebra ℂ (levelField N) := Algebra.adjoin ℂ {jK N}
+
+private abbrev _root_.WLight.ratJ (N : ℕ) [NeZero N] : IntermediateField ℂ (levelField N) := ℂ⟮jK N⟯
+
+p2m_export "WLight" "ratJ"
+
+noncomputable def polyJEquiv (N : ℕ) [NeZero N] : ℂ[X] ≃ₐ[ℂ] ↥(polyJ N) :=
+  Polynomial.algEquivOfTranscendental ℂ (jK N) (transcendental_jK N)
+
+scoped instance (N : ℕ) [NeZero N] : IsDomain ↥(polyJ N) := inferInstance
+
+scoped instance (N : ℕ) [NeZero N] : IsPrincipalIdealRing ↥(polyJ N) :=
+  IsPrincipalIdealRing.of_surjective (polyJEquiv N).toRingEquiv.toRingHom
+    (polyJEquiv N).surjective
+
+scoped instance (N : ℕ) [NeZero N] : IsDedekindDomain ↥(polyJ N) :=
+  IsPrincipalIdealRing.isDedekindDomain _
+
+scoped instance (N : ℕ) [NeZero N] : CharZero (levelField N) :=
+  charZero_of_injective_algebraMap (FaithfulSMul.algebraMap_injective ℂ (levelField N))
+
+scoped instance (N : ℕ) [NeZero N] : CharZero ↥(ratJ N) :=
+  charZero_of_injective_algebraMap (FaithfulSMul.algebraMap_injective ℂ ↥(ratJ N))
+
+lemma index_pmGamma_pos (N : ℕ) [NeZero N] : 0 < (pmGamma N).index := Nat.pos_of_ne_zero
+  Subgroup.FiniteIndex.index_ne_zero
+
+scoped instance (N : ℕ) [NeZero N] : FiniteDimensional ↥(ratJ N) (levelField N) :=
+  haveI : Module.Free ↥(ratJ N) (levelField N) := Module.Free.of_divisionRing _ _
+  Module.finite_of_finrank_pos (by rw [finrank_adjoin_j_levelField]; exact index_pmGamma_pos N)
+
+scoped instance (N : ℕ) [NeZero N] : Algebra.IsSeparable ↥(ratJ N) (levelField N) :=
+  haveI : Algebra.IsIntegral ↥(ratJ N) (levelField N) := Algebra.IsIntegral.of_finite _ _
+  Algebra.IsSeparable.of_integral ↥(ratJ N) (levelField N)
+
+abbrev levelIntClosure (N : ℕ) [NeZero N] : Subalgebra ↥(polyJ N) (levelField N) :=
+  integralClosure ↥(polyJ N) (levelField N)
+
+scoped instance (N : ℕ) [NeZero N] : IsDedekindDomain ↥(levelIntClosure N) :=
+  integralClosure.isDedekindDomain ↥(polyJ N) ↥(ratJ N) (levelField N)
+
+def levelRingEval (N : ℕ) (τ : ℍ) : ↥(levelRing N) →ₐ[ℂ] ℂ :=
+  (Pi.evalAlgHom ℂ (fun _ : ℍ ↦ ℂ) τ).comp (levelRing N).val
+
+@[scoped simp] lemma levelRingEval_apply (N : ℕ) (τ : ℍ) (a : ↥(levelRing N)) :
+    levelRingEval N τ a = (a : ℍ → ℂ) τ := rfl
+
+end C1_carrier
+
+section C0_membership
+
+open scoped UpperHalfPlane Manifold MatrixGroups ModularForm IntermediateField
+p2m_open "UpperHalfPlane~I"
+
+structure LevelGens (N : ℕ) [NeZero N] where
+  S : Set (ℍ → ℂ)
+  levelGen_subset : levelGen N ⊆ S
+  poleBounded : ∀ f ∈ S, PoleBounded f
+  smul_mem : ∀ (γ : SL(2, ℤ)), ∀ f ∈ S, γ • f ∈ S
+  invariant : ∀ f ∈ S, ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : ℍ, f (γ • τ) = f τ
+
+namespace LevelGens
+
+variable {N : ℕ} [NeZero N] (D : LevelGens N)
+
+def std (N : ℕ) [NeZero N] : LevelGens N where
+  S := levelGen N
+  levelGen_subset := subset_rfl
+  poleBounded := levelGen_poleBounded N
+  smul_mem γ f hf := smul_mem_levelGen γ hf
+  invariant := by
+    rintro f (rfl | ⟨i, rfl⟩) γ hγ τ
+    · exact j_smul_eq γ τ
+    · exact frickeF_invariant_Gamma i.1 hγ τ
+
+def ring : Subalgebra ℂ (ℍ → ℂ) := Algebra.adjoin ℂ D.S
+
+lemma ring_le_HolFn : D.ring ≤ HolFn :=
+  Algebra.adjoin_le fun f hf ↦ (D.poleBounded f hf).1
+
+lemma levelRing_le_ring : levelRing N ≤ D.ring := Algebra.adjoin_mono D.levelGen_subset
+
+scoped instance : IsDomain ↥D.ring := by
+  have : NoZeroDivisors ↥D.ring := ⟨fun {f g} h ↦ by
+    rcases HolFn.eq_zero_or_eq_zero_of_mul_eq_zero (D.ring_le_HolFn f.2)
+      (D.ring_le_HolFn g.2) (congrArg Subtype.val h) with e | e
+    · exact Or.inl (Subtype.ext e)
+    · exact Or.inr (Subtype.ext e)⟩
+  have : Nontrivial ↥D.ring :=
+    ⟨⟨0, 1, fun h ↦ zero_ne_one (congrFun (congrArg Subtype.val h) UpperHalfPlane.I)⟩⟩
+  exact NoZeroDivisors.to_isDomain _
+
+theorem smul_mem_ring (γ : SL(2, ℤ)) {f : ℍ → ℂ} (hf : f ∈ D.ring) : γ • f ∈ D.ring := by
+  induction hf using Algebra.adjoin_induction with
+  | mem x hx => exact Algebra.subset_adjoin (D.smul_mem γ x hx)
+  | algebraMap c => rw [Algebra.algebraMap_eq_smul_one, smul_comm, smul_one]
+                    exact Subalgebra.smul_mem _ (Subalgebra.one_mem _) _
+  | add x y _ _ hx hy => rw [smul_add]; exact Subalgebra.add_mem _ hx hy
+  | mul x y _ _ hx hy => rw [smul_mul']; exact Subalgebra.mul_mem _ hx hy
+
+scoped instance ringAction : MulSemiringAction SL(2, ℤ) ↥D.ring where
+  smul γ f := ⟨γ • f.1, D.smul_mem_ring γ f.2⟩
+  one_smul f := Subtype.ext (one_smul _ f.1)
+  mul_smul γ δ f := Subtype.ext (mul_smul γ δ f.1)
+  smul_zero γ := Subtype.ext (smul_zero γ)
+  smul_add γ f g := Subtype.ext (smul_add γ f.1 g.1)
+  smul_one γ := Subtype.ext (smul_one γ)
+  smul_mul γ f g := Subtype.ext (smul_mul' γ f.1 g.1)
+
+@[scoped simp] lemma ring_coe_smul (γ : SL(2, ℤ)) (f : ↥D.ring) :
+    ((γ • f : ↥D.ring) : ℍ → ℂ) = γ • (f : ℍ → ℂ) := rfl
+
+scoped instance ring_smulCommClass : SMulCommClass SL(2, ℤ) ℂ ↥D.ring where
+  smul_comm _ _ _ := rfl
+
+lemma smul_eq_self_of_pm {γ : SL(2, ℤ)}
+    (hγ : γ ∈ CongruenceSubgroup.Gamma N ∨ -γ ∈ CongruenceSubgroup.Gamma N)
+    {f : ℍ → ℂ} (hf : f ∈ D.ring) : γ • f = f := by
+  induction hf using Algebra.adjoin_induction with
+  | mem x hx =>
+    funext τ
+    rw [sl_smul_apply]
+    rcases hγ with h | h
+    · exact D.invariant x hx γ⁻¹ (inv_mem h) τ
+    · have : γ⁻¹ = -(-γ)⁻¹ := by simp
+      rw [this, ModularGroup.SL_neg_smul]
+      exact D.invariant x hx (-γ)⁻¹ (inv_mem h) τ
+  | algebraMap c => rfl
+  | add x y _ _ hx hy => rw [smul_add, hx, hy]
+  | mul x y _ _ hx hy => rw [smul_mul', hx, hy]
+
+lemma levelFixer_le_ker :
+    levelFixer N ≤ (MulSemiringAction.toAlgAut SL(2, ℤ) ℂ ↥D.ring).ker := by
+  intro γ hγ
+  rw [MonoidHom.mem_ker]
+  ext f
+  exact congrFun (D.smul_eq_self_of_pm ((mem_levelFixer_iff_pm γ).mp hγ) f.2) _
+
+lemma ker_le_levelFixer :
+    (MulSemiringAction.toAlgAut SL(2, ℤ) ℂ ↥D.ring).ker ≤ levelFixer N := by
+  intro γ hγ
+  rw [MonoidHom.mem_ker, AlgEquiv.ext_iff] at hγ
+  have h' : ∀ a : ↥D.ring, γ • a = a := fun a ↦ hγ a
+  rw [mem_levelFixer_iff_frickeF]
+  intro i τ
+  set fa : ↥D.ring := ⟨frickeF N i.1, D.levelRing_le_ring (frickeF_mem_levelRing i)⟩
+  have e : γ • (γ⁻¹ • frickeF N i.1) = γ⁻¹ • frickeF N i.1 :=
+    congrArg Subtype.val (h' (γ⁻¹ • fa))
+  rw [← mul_smul, mul_inv_cancel, one_smul] at e
+  have := congrFun e τ
+  rw [sl_smul_apply, inv_inv] at this
+  exact this.symm
+
+noncomputable scoped instance grpRingAction : MulSemiringAction (LevelGrp N) ↥D.ring :=
+  MulSemiringAction.compHom _
+    (QuotientGroup.lift (levelFixer N) (MulSemiringAction.toAlgAut SL(2, ℤ) ℂ ↥D.ring)
+      D.levelFixer_le_ker)
+
+@[scoped simp] lemma grp_mk_smul (γ : SL(2, ℤ)) (f : ↥D.ring) :
+    (QuotientGroup.mk γ : LevelGrp N) • f = γ • f := rfl
+
+scoped instance grp_smulCommClass : SMulCommClass (LevelGrp N) ℂ ↥D.ring where
+  smul_comm q c f := by
+    induction q using QuotientGroup.induction_on with
+    | H γ => simp only [grp_mk_smul]; exact smul_comm γ c f
+
+scoped instance grp_faithful : FaithfulSMul (LevelGrp N) ↥D.ring where
+  eq_of_smul_eq_smul {q₁ q₂} h := by
+    induction q₁ using QuotientGroup.induction_on with
+    | H γ₁ =>
+    induction q₂ using QuotientGroup.induction_on with
+    | H γ₂ =>
+    apply QuotientGroup.eq.mpr
+    apply D.ker_le_levelFixer
+    rw [MonoidHom.mem_ker, map_mul, map_inv, inv_mul_eq_one]
+    exact AlgEquiv.ext fun f ↦ h f
+
+abbrev field : Type := FractionRing ↥D.ring
+
+noncomputable scoped instance grpFieldAction : MulSemiringAction (LevelGrp N) D.field :=
+  IsFractionRing.mulSemiringAction (LevelGrp N) ↥D.ring D.field
+
+scoped instance grp_smulDistribClass : SMulDistribClass (LevelGrp N) ↥D.ring D.field :=
+  IsFractionRing.smulDistribClass (LevelGrp N) ↥D.ring D.field
+
+lemma grp_smul_algebraMap (g : LevelGrp N) (a : ↥D.ring) :
+    g • algebraMap ↥D.ring D.field a = algebraMap ↥D.ring D.field (g • a) :=
+  (algebraMap.coe_smul' g a D.field).symm
+
+scoped instance grpField_faithful : FaithfulSMul (LevelGrp N) D.field :=
+  IsFractionRing.faithfulSMul (LevelGrp N) ↥D.ring D.field
+
+scoped instance grpField_smulCommClass : SMulCommClass (LevelGrp N) ℂ D.field :=
+  IsFractionRing.smulCommClass (LevelGrp N) ℂ ↥D.ring ℂ D.field
+
+theorem finrank_field_fixed :
+    Module.finrank (FixedPoints.subfield (LevelGrp N) D.field) D.field = (levelFixer N).index := by
+  rw [FixedPoints.finrank_eq_card, card_LevelGrp]
+
+def jA : ↥D.ring := ⟨j, D.levelRing_le_ring (j_mem_levelRing N)⟩
+
+def jK : D.field := algebraMap ↥D.ring D.field D.jA
+
+lemma coe_aeval_jA (P : Polynomial ℂ) :
+    ((Polynomial.aeval D.jA P : ↥D.ring) : ℍ → ℂ) = fun τ ↦ Polynomial.eval (j τ) P := by
+  rw [Polynomial.aeval_subalgebra_coe]
+  funext τ
+  exact aeval_j_apply P τ
+
+theorem ring_fixed_eq_aeval_j (a : ↥D.ring) (ha : ∀ g : LevelGrp N, g • a = a) :
+    ∃ P : Polynomial ℂ, a = Polynomial.aeval D.jA P := by
+  have ha' : ∀ γ : SL(2, ℤ), γ • (a : ℍ → ℂ) = a :=
+    fun γ ↦ congrArg Subtype.val (ha (QuotientGroup.mk γ))
+  have hinv : ∀ γ : SL(2, ℤ), (a : ℍ → ℂ) ∣[(0 : ℤ)] γ = a := by
+    intro γ
+    funext τ
+    rw [ModularForm.SL_slash_apply, neg_zero, zpow_zero, mul_one]
+    exact (sl_smul_eq_self_iff _).mp ha' γ τ
+  obtain ⟨P, hP⟩ := eq_polynomial_j_of_invariant_of_mem_adjoin D.poleBounded a.2 hinv
+  exact ⟨P, Subtype.ext (by rw [coe_aeval_jA]; exact hP)⟩
+
+lemma smul_jK (g : LevelGrp N) : g • D.jK = D.jK := by
+  rw [jK, grp_smul_algebraMap]
+  congr 1
+  induction g using QuotientGroup.induction_on with
+  | H γ => exact Subtype.ext (smul_j γ)
+
+theorem fixedPoints_field_eq_adjoin_j :
+    (MulAction.fixedPoints (LevelGrp N) D.field : Set D.field) =
+      (IntermediateField.adjoin ℂ {D.jK} : Set D.field) := by
+  apply Set.Subset.antisymm
+  · intro x hx
+    rw [MulAction.mem_fixedPoints] at hx
+    obtain ⟨a, b, ha, hb, hb0, hab⟩ :=
+      exists_fixed_div_of_fixed (A := ↥D.ring) (K := D.field) (G := LevelGrp N)
+        D.grp_smul_algebraMap x hx
+    obtain ⟨P, rfl⟩ := D.ring_fixed_eq_aeval_j a ha
+    obtain ⟨Q, rfl⟩ := D.ring_fixed_eq_aeval_j b hb
+    rw [SetLike.mem_coe, IntermediateField.mem_adjoin_simple_iff]
+    refine ⟨P, Q, ?_⟩
+    rw [jK, Polynomial.aeval_algebraMap_apply, Polynomial.aeval_algebraMap_apply,
+      eq_div_iff hb0, hab]
+  · change (IntermediateField.adjoin ℂ {D.jK} : Set D.field) ⊆
+      (FixedPoints.intermediateField (F := ℂ) (LevelGrp N) : IntermediateField ℂ D.field)
+    exact SetLike.coe_subset_coe.mpr
+      (IntermediateField.adjoin_simple_le_iff.mpr fun g ↦ D.smul_jK g)
+
+abbrev ratJ : IntermediateField ℂ D.field := ℂ⟮D.jK⟯
+
+theorem finrank_ratJ : Module.finrank ↥D.ratJ D.field = (levelFixer N).index := by
+  have h : (FixedPoints.intermediateField (F := ℂ) (LevelGrp N) : IntermediateField ℂ D.field) =
+      D.ratJ := SetLike.coe_injective D.fixedPoints_field_eq_adjoin_j
+  rw [← h]
+  exact D.finrank_field_fixed
+
+def incl : ↥(levelRing N) →ₐ[ℂ] ↥D.ring := Subalgebra.inclusion D.levelRing_le_ring
+
+lemma incl_injective : Function.Injective D.incl := Subalgebra.inclusion_injective _
+
+@[scoped simp] lemma coe_incl (a : ↥(levelRing N)) : ((D.incl a : ↥D.ring) : ℍ → ℂ) = a :=
+  Subalgebra.coe_inclusion _ a
+
+lemma toRingField_injective :
+    Function.Injective ((IsScalarTower.toAlgHom ℂ ↥D.ring D.field).comp D.incl) :=
+  (IsFractionRing.injective ↥D.ring D.field).comp D.incl_injective
+
+noncomputable def toField : levelField N →ₐ[ℂ] D.field :=
+  IsFractionRing.liftAlgHom D.toRingField_injective
+
+lemma toField_algebraMap (a : ↥(levelRing N)) :
+    D.toField (algebraMap ↥(levelRing N) (levelField N) a) =
+      algebraMap ↥D.ring D.field (D.incl a) :=
+  IsFractionRing.lift_algebraMap D.toRingField_injective a
+
+lemma toField_jK : D.toField (WLight.jK N) = D.jK := D.toField_algebraMap (WLight.jA N)
+
+noncomputable scoped instance (priority := 3000) algebraField : Algebra (levelField N) D.field :=
+  D.toField.toRingHom.toAlgebra
+
+noncomputable scoped instance (priority := 3000) moduleField : Module (levelField N) D.field :=
+  Algebra.toModule
+
+noncomputable scoped instance (priority := 3000) smulField : SMul (levelField N) D.field :=
+  Algebra.toSMul
+
+scoped instance : IsScalarTower ℂ (levelField N) D.field :=
+  IsScalarTower.of_algebraMap_eq fun c ↦ (D.toField.commutes c).symm
+
+noncomputable scoped instance (priority := 3000) algebraRatJ : Algebra ↥(WLight.ratJ N) D.field :=
+  ((algebraMap (levelField N) D.field).comp (algebraMap ↥(WLight.ratJ N) (levelField N))).toAlgebra
+
+noncomputable scoped instance (priority := 3000) moduleRatJ : Module ↥(WLight.ratJ N) D.field :=
+  Algebra.toModule
+
+noncomputable scoped instance (priority := 3000) smulRatJ : SMul ↥(WLight.ratJ N) D.field :=
+  Algebra.toSMul
+
+scoped instance : IsScalarTower ↥(WLight.ratJ N) (levelField N) D.field :=
+  IsScalarTower.of_algebraMap_eq fun _ ↦ rfl
+
+lemma ratJ_map_toField : (WLight.ratJ N).map D.toField = D.ratJ := by
+  rw [IntermediateField.adjoin_map, Set.image_singleton, toField_jK]
+
+noncomputable def ratJEquiv : ↥(WLight.ratJ N) ≃ₐ[ℂ] ↥D.ratJ :=
+  ((WLight.ratJ N).equivMap D.toField).trans (IntermediateField.equivOfEq D.ratJ_map_toField)
+
+theorem finrank_ratJN_field : Module.finrank ↥(WLight.ratJ N) D.field = (levelFixer N).index := by
+  rw [← D.finrank_ratJ]
+  refine Algebra.finrank_eq_of_equiv_equiv D.ratJEquiv.toRingEquiv (RingEquiv.refl D.field) ?_
+  ext x
+  rfl
+
+theorem finrank_levelField_field : Module.finrank (levelField N) D.field = 1 := by
+  have : Module.Free (levelField N) D.field := Module.Free.of_divisionRing _ _
+  have : Module.Free ↥(WLight.ratJ N) (levelField N) := Module.Free.of_divisionRing _ _
+  have h := Module.finrank_mul_finrank ↥(WLight.ratJ N) (levelField N) D.field
+  rw [finrank_ratJN_field, finrank_adjoin_j_levelField, ← levelFixer_eq_pmGamma] at h
+  have hpos : 0 < (levelFixer N).index := Nat.pos_of_ne_zero Subgroup.FiniteIndex.index_ne_zero
+  have : (levelFixer N).index * Module.finrank (levelField N) D.field = (levelFixer N).index * 1 :=
+    by
+    rw [h, mul_one]
+  exact Nat.eq_of_mul_eq_mul_left hpos this
+
+theorem toField_surjective : Function.Surjective D.toField := by
+  intro x
+  have : Module.Free (levelField N) D.field := Module.Free.of_divisionRing _ _
+  have : FiniteDimensional (levelField N) D.field :=
+    Module.finite_of_finrank_pos (by rw [finrank_levelField_field]; exact one_pos)
+  obtain ⟨c, hc⟩ := (finrank_eq_one_iff_of_nonzero' (1 : D.field) one_ne_zero).mp
+    D.finrank_levelField_field x
+  refine ⟨c, ?_⟩
+  rw [← hc, Algebra.smul_def, mul_one]
+  rfl
+
+theorem exists_frac {F : ℍ → ℂ} (hF : F ∈ D.S) :
+    ∃ a b : ↥(levelRing N), b ≠ 0 ∧ F * b = a := by
+  obtain ⟨y, hy⟩ := D.toField_surjective (algebraMap ↥D.ring D.field ⟨F, Algebra.subset_adjoin hF⟩)
+  obtain ⟨a, b, hb, rfl⟩ := IsFractionRing.div_surjective (A := ↥(levelRing N)) y
+  have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb
+  refine ⟨a, b, hb0, ?_⟩
+  rw [map_div₀, toField_algebraMap, toField_algebraMap, div_eq_iff
+    ((map_ne_zero_iff _ (IsFractionRing.injective ↥D.ring D.field)).mpr
+      ((map_ne_zero_iff _ D.incl_injective).mpr hb0)), ← map_mul] at hy
+  have := congrArg Subtype.val (IsFractionRing.injective ↥D.ring D.field hy)
+  rw [Subalgebra.coe_mul, coe_incl, coe_incl] at this
+  exact this.symm
+
+end LevelGens
+
+theorem exists_levelRing_frac {N : ℕ} [NeZero N] {S : Set (ℍ → ℂ)}
+    (hpb : ∀ G ∈ S, PoleBounded G) (hst : ∀ (γ : SL(2, ℤ)), ∀ G ∈ S, γ • G ∈ S)
+    (hinv : ∀ G ∈ S, ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : ℍ, G (γ • τ) = G τ)
+    {F : ℍ → ℂ} (hF : F ∈ S) : ∃ a b : ↥(levelRing N), b ≠ 0 ∧ F * b = a := by
+  let D : LevelGens N :=
+    { S := levelGen N ∪ S
+      levelGen_subset := Set.subset_union_left
+      poleBounded := fun f hf ↦ hf.elim (levelGen_poleBounded N f) (hpb f)
+      smul_mem := fun γ f hf ↦ hf.elim (fun h ↦ Or.inl (smul_mem_levelGen γ h))
+        (fun h ↦ Or.inr (hst γ f h))
+      invariant := fun f hf ↦ hf.elim ((LevelGens.std N).invariant f) (hinv f) }
+  exact D.exists_frac (Or.inr hF)
+
+end C0_membership
+
+section R5bBridge
+
+p2m_open "UpperHalfPlane~I"
+open scoped Manifold MatrixGroups ModularForm
+
+private lemma periodPair_extb {L₁ L₂ : PeriodPair} (h₁ : L₁.ω₁ = L₂.ω₁)
+    (h₂ : L₁.ω₂ = L₂.ω₂) : L₁ = L₂ := by
+  cases L₁; cases L₂; simp_all
+
+theorem exists_levelFraction_of_stable_family_core
+    (N : ℕ) [NeZero N]
+    (L : ℍ → PeriodPair) (hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), W v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (jf : ℍ → ℂ)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    (S : Set (ℍ → ℂ))
+    (hhol : ∀ G ∈ S, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (hpb : ∀ G ∈ S, ∃ m : ℕ, IsBoundedAtImInfty (G * ModularForm.discriminant ^ m))
+    (hst : ∀ (γ : SL(2, ℤ)), ∀ G ∈ S, (G ∘ (γ • ·)) ∈ S)
+    (hinv : ∀ G ∈ S, ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : ℍ, G (γ • τ) = G τ)
+    {F : ℍ → ℂ} (hF : F ∈ S) :
+    ∃ a b : ℍ → ℂ,
+      a ∈ Algebra.adjoin ℂ
+        (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}) ∧
+      b ∈ Algebra.adjoin ℂ
+        (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}) ∧
+      b ≠ 0 ∧ F * b = a := by
+  have hLpp : ∀ τ : ℍ, L τ = periodPairOfTau τ := fun τ =>
+    periodPair_extb ((hL τ).1.trans (periodPairOfTau_ω₁ τ).symm)
+      ((hL τ).2.trans (periodPairOfTau_ω₂ τ).symm)
+  have hfr : ∀ v : Fin 2 → ZMod N, fricke v = frickeF N v := by
+    intro v
+    funext τ
+    rw [hfricke v τ, hW v τ, hLpp τ]
+    with_unfolding_all rfl
+  have hjeq : jf = j := by
+    funext τ
+    rw [hjf τ]
+    rfl
+  have hset : (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}) =
+      levelGen N := by
+    rw [hjeq]
+    unfold levelGen
+    congr 1
+    ext g
+    constructor
+    · rintro ⟨v, hv, rfl⟩
+      exact ⟨⟨v, hv⟩, (hfr v).symm⟩
+    · rintro ⟨i, rfl⟩
+      exact ⟨i.1, i.2, (hfr i.1).symm⟩
+  have hpb' : ∀ G ∈ S, PoleBounded G := by
+    intro G hG
+    refine ⟨hhol G hG, ?_⟩
+    obtain ⟨m, hm⟩ := hpb G hG
+    exact ⟨m, by rw [CuspForm.coe_discriminant]; exact hm⟩
+  have hst' : ∀ (γ : SL(2, ℤ)), ∀ G ∈ S, γ • G ∈ S := by
+    intro γ G hG
+    exact hst γ⁻¹ G hG
+  obtain ⟨a, b, hb0, hab⟩ := exists_levelRing_frac (N := N) hpb' hst' hinv hF
+  refine ⟨↑a, ↑b, ?_, ?_, ?_, hab⟩
+  · rw [hset]
+    exact a.2
+  · rw [hset]
+    exact b.2
+  · intro h
+    exact hb0 (Subtype.coe_injective (h.trans (ZeroMemClass.coe_zero _).symm))
+
+end R5bBridge
+end WLight
+
+open UpperHalfPlane in
+open scoped Manifold MatrixGroups ModularForm in
+open _root_.WLight _root_.P2MW.S_WLight_exists_levelFraction_of_stable_family.WLight in
+theorem solution
+    (N : ℕ) [NeZero N]
+    (L : ℍ → PeriodPair) (hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), W v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (jf : ℍ → ℂ)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    (S : Set (ℍ → ℂ))
+    (hhol : ∀ G ∈ S, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (hpb : ∀ G ∈ S, ∃ m : ℕ, IsBoundedAtImInfty (G * ModularForm.discriminant ^ m))
+    (hst : ∀ (γ : SL(2, ℤ)), ∀ G ∈ S, (G ∘ (γ • ·)) ∈ S)
+    (hinv : ∀ G ∈ S, ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : ℍ, G (γ • τ) = G τ)
+    {F : ℍ → ℂ} (hF : F ∈ S) :
+    ∃ a b : ℍ → ℂ,
+      a ∈ Algebra.adjoin ℂ
+        (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}) ∧
+      b ∈ Algebra.adjoin ℂ
+        (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}) ∧
+      b ≠ 0 ∧ F * b = a :=
+  exists_levelFraction_of_stable_family_core N L hL W hW fricke hfricke jf hjf
+    S hhol hpb hst hinv hF
+
+end
+end S_WLight_exists_levelFraction_of_stable_family
+end P2MW
+export P2MW.S_WLight_exists_levelFraction_of_stable_family (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Complex Real UpperHalfPlane
+open scoped Manifold MatrixGroups ModularForm
+theorem WLight.exists_levelFraction_of_stable_family
+    (N : ℕ) [NeZero N]
+    (L : ℍ → PeriodPair) (hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), W v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (jf : ℍ → ℂ)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    (S : Set (ℍ → ℂ))
+    (hhol : ∀ G ∈ S, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (hpb : ∀ G ∈ S, ∃ m : ℕ, IsBoundedAtImInfty (G * ModularForm.discriminant ^ m))
+    (hst : ∀ (γ : SL(2, ℤ)), ∀ G ∈ S, (G ∘ (γ • ·)) ∈ S)
+    (hinv : ∀ G ∈ S, ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : ℍ, G (γ • τ) = G τ)
+    {F : ℍ → ℂ} (hF : F ∈ S) :
+    ∃ a b : ℍ → ℂ,
+      a ∈ Algebra.adjoin ℂ
+        (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}) ∧
+      b ∈ Algebra.adjoin ℂ
+        (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}) ∧
+      b ≠ 0 ∧ F * b = a :=
+  solution N L hL W hW fricke hfricke jf hjf S hhol hpb hst hinv hF
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_exists_mdifferentiable_div_of_monicRel.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_exists_mdifferentiable_div_of_monicRel.lean
new file mode 100644
index 0000000000..e7f45aa464
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_exists_mdifferentiable_div_of_monicRel.lean
@@ -0,0 +1,259 @@
+/-
+Based on Prove2Me node WLight.exists_mdifferentiable_div_of_monicRel
+(9663f68b-21af-5bc5-ae59-24171b015314) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6d9444b3-7312-528d-a153-58b0f653b69c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.SpecialFunctions.Elliptic.Weierstrass
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import Mathlib.Geometry.Manifold.Notation
+
+import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+import Mathlib.Analysis.Meromorphic.NormalForm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_exists_analyticOnNhd_div_of_monicRel
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Holomorphic divisibility from a cleared monic relation on H
+
+Theorem statement: `WLight.exists_mdifferentiable_div_of_monicRel`
+(`9663f68b-21af-5bc5-ae59-24171b015314`), by Claude, 2026-09-05.
+
+Proof: submission `6d9444b3-7312-528d-a153-58b0f653b69c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $a, b \colon \mathbb{H} \to \mathbb{C}$ be functions on the upper half-plane that are
+differentiable in the manifold sense for the model $\mathcal{I}(\mathbb{C})$ on source and target,
+i.e. holomorphic as functions on the complex manifold $\mathbb{H}$, let $d$ be a natural number, and
+let $c \colon \mathbb{N} \to (\mathbb{H} \to \mathbb{C})$ be a family of functions such that $c_k$
+is holomorphic in the same sense for every $k < d$ (no condition is imposed on $c_k$ for $k \ge d$).
+Assume $b$ is not the zero function, and assume the identity $$a^d + \sum_{k < d} c_k \, b^{\,d-k}\,
+a^k = 0$$ holds in the ring of $\mathbb{C}$-valued functions on $\mathbb{H}$ with pointwise
+operations, that is, pointwise on all of $\mathbb{H}$ (the exponent $d-k$ being truncated
+subtraction of naturals, harmless since $k < d$). Then there exists a holomorphic $F \colon
+\mathbb{H} \to \mathbb{C}$ with $F \cdot b = a$ as functions on $\mathbb{H}$, the product again
+being pointwise; thus the equality holds at every point, not merely off the zero set of $b$.
+
+This is the upper-half-plane form of the classical clearing argument: a monic algebraic relation for
+the quotient $a/b$, multiplied through by $b^d$, forces $b$ to divide $a$ in the ring of holomorphic
+functions. It is obtained from
+[`WLight.exists_analyticOnNhd_div_of_monicRel`]
+(thm.html#WLight.exists_analyticOnNhd_div_of_monicRel)
+on the connected open subset of $\mathbb{C}$ underlying $\mathbb{H}$, and is used to reconstruct
+genuine holomorphic functions, and hence cusp forms, from algebraic data, as in
+[`CuspForm.exists_mul_E4_pow_mul_E6_pow_eq_iff`]
+(thm.html#CuspForm.exists_mul_E4_pow_mul_E6_pow_eq_iff)
+and the statements on $q$-expansion coefficients of bases of cusp forms for $\Gamma_1(N)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WLight_exists_mdifferentiable_div_of_monicRel.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WLight_exists_mdifferentiable_div_of_monicRel
+
+noncomputable section
+
+p2m_open "Complex Real UpperHalfPlane ModularForm Polynomial Real.Polynomial"
+open scoped Topology Manifold MatrixGroups ModularForm
+
+namespace WLight
+p2m_export "WLight" "exists_analyticOnNhd_div_of_monicRel"
+p2m_open "WLight"
+
+section ValuationEngine
+
+theorem le_meromorphicOrderAt_sum {𝕜 : Type*} [NontriviallyNormedField 𝕜]
+    {ι : Type*} (s : Finset ι) {f : ι → 𝕜 → 𝕜} {x : 𝕜}
+    (hf : ∀ i ∈ s, MeromorphicAt (f i) x) (m : WithTop ℤ)
+    (hm : ∀ i ∈ s, m ≤ meromorphicOrderAt (f i) x) :
+    m ≤ meromorphicOrderAt (∑ i ∈ s, f i) x := by
+  classical
+  induction s using Finset.induction with
+  | empty => simp
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha]
+    calc m ≤ min (meromorphicOrderAt (f a) x) (meromorphicOrderAt (∑ i ∈ s, f i) x) := by
+            refine le_min (hm a (Finset.mem_insert_self a s)) ?_
+            exact ih (fun i hi ↦ hf i (Finset.mem_insert_of_mem hi))
+              (fun i hi ↦ hm i (Finset.mem_insert_of_mem hi))
+      _ ≤ meromorphicOrderAt (f a + ∑ i ∈ s, f i) x := by
+            apply meromorphicOrderAt_add (hf a (Finset.mem_insert_self a s))
+            exact MeromorphicAt.sum (fun i hi ↦ hf i (Finset.mem_insert_of_mem hi))
+
+theorem meromorphicOrderAt_le_of_monicRel {𝕜 : Type*} [NontriviallyNormedField 𝕜]
+    {F G : 𝕜 → 𝕜} {c : ℕ → 𝕜 → 𝕜} {n : ℕ} {τ : 𝕜}
+    (hF : AnalyticAt 𝕜 F τ) (hG : AnalyticAt 𝕜 G τ)
+    (hGord : meromorphicOrderAt G τ ≠ ⊤) (hc : ∀ k < n, AnalyticAt 𝕜 (c k) τ)
+    (hrel : F ^ n + (∑ k ∈ Finset.range n, c k * G ^ (n - k) * F ^ k) =ᶠ[𝓝 τ] 0) :
+    meromorphicOrderAt G τ ≤ meromorphicOrderAt F τ := by
+  by_contra hlt
+  rw [not_le] at hlt
+  lift meromorphicOrderAt G τ to ℤ using hGord with m hm
+  have hFord : meromorphicOrderAt F τ ≠ ⊤ := hlt.ne_top
+  lift meromorphicOrderAt F τ to ℤ using hFord with r hr
+  have hrm : r < m := WithTop.coe_lt_coe.mp hlt
+  set S := ∑ k ∈ Finset.range n, c k * G ^ (n - k) * F ^ k with hS
+  have hMerS : ∀ k ∈ Finset.range n, MeromorphicAt (c k * G ^ (n - k) * F ^ k) τ := by
+    intro k hk
+    exact (((hc k (Finset.mem_range.mp hk)).mul ((hG.pow _))).mul (hF.pow _)).meromorphicAt
+  have hsum_ord : (↑(n * r) + 1 : WithTop ℤ) ≤ meromorphicOrderAt S τ := by
+    refine le_meromorphicOrderAt_sum _ hMerS _ ?_
+    intro k hk
+    have hk' : k < n := Finset.mem_range.mp hk
+    have hterm : meromorphicOrderAt (c k * G ^ (n - k) * F ^ k) τ
+        = meromorphicOrderAt (c k) τ + ((n - k : ℕ) * meromorphicOrderAt G τ
+            + k * meromorphicOrderAt F τ) := by
+      rw [meromorphicOrderAt_mul (((hc k hk').mul (hG.pow (n - k))).meromorphicAt)
+            ((hF.pow k).meromorphicAt),
+          meromorphicOrderAt_mul (hc k hk').meromorphicAt ((hG.pow (n - k)).meromorphicAt),
+          meromorphicOrderAt_pow hG.meromorphicAt (n := n - k),
+          meromorphicOrderAt_pow hF.meromorphicAt (n := k), add_assoc]
+    rw [hterm, ← hm, ← hr]
+    have hc_ord : (0 : WithTop ℤ) ≤ meromorphicOrderAt (c k) τ :=
+      (hc k hk').meromorphicOrderAt_nonneg
+    have hnk : ((n - k : ℕ) : ℤ) = (n : ℤ) - k := by omega
+    have key : (↑(n * r) + 1 : WithTop ℤ)
+        ≤ (↑(n - k : ℕ) : WithTop ℤ) * ↑m + ↑k * ↑r := by
+      rw [show ((n - k : ℕ) : WithTop ℤ) = (((n - k : ℕ) : ℤ) : WithTop ℤ) by push_cast; rfl,
+          show ((k : ℕ) : WithTop ℤ) = (((k : ℕ) : ℤ) : WithTop ℤ) by push_cast; rfl,
+          ← WithTop.coe_mul, ← WithTop.coe_mul, ← WithTop.coe_add,
+          ← WithTop.coe_one, ← WithTop.coe_add, WithTop.coe_le_coe, hnk]
+      have h1 : (1 : ℤ) ≤ (n : ℤ) - k := by omega
+      nlinarith [h1, hrm]
+    calc (↑(n * r) + 1 : WithTop ℤ)
+        ≤ (↑(n - k : ℕ) : WithTop ℤ) * ↑m + ↑k * ↑r := key
+      _ = 0 + ((↑(n - k : ℕ) : WithTop ℤ) * ↑m + ↑k * ↑r) := (zero_add _).symm
+      _ ≤ meromorphicOrderAt (c k) τ + ((↑(n - k : ℕ) : WithTop ℤ) * ↑m + ↑k * ↑r) := by
+          gcongr
+  have hFn_ord : meromorphicOrderAt (F ^ n) τ = (↑(n * r) : WithTop ℤ) := by
+    rw [meromorphicOrderAt_pow hF.meromorphicAt, ← hr]; push_cast; ring_nf
+  have hlt2 : meromorphicOrderAt (F ^ n) τ < meromorphicOrderAt S τ := by
+    rw [hFn_ord]
+    refine lt_of_lt_of_le ?_ hsum_ord
+    exact_mod_cast lt_add_one (n * r)
+  have heq : meromorphicOrderAt (F ^ n + S) τ = meromorphicOrderAt (F ^ n) τ :=
+    meromorphicOrderAt_add_eq_left_of_lt
+      (MeromorphicAt.sum (fun i hi ↦ hMerS i hi)) hlt2
+  have hzero : (F ^ n + S) =ᶠ[𝓝[≠] τ] 0 :=
+    hrel.filter_mono nhdsWithin_le_nhds
+  have htop : meromorphicOrderAt (F ^ n + S) τ = ⊤ := by
+    rw [meromorphicOrderAt_eq_top_iff]; exact hzero
+  rw [heq, hFn_ord] at htop
+  exact WithTop.coe_ne_top htop
+
+open WithTop.LinearOrderedAddCommGroup in
+theorem meromorphicOrderAt_div_nonneg_of_monicRel {𝕜 : Type*} [NontriviallyNormedField 𝕜]
+    {F G : 𝕜 → 𝕜} {c : ℕ → 𝕜 → 𝕜} {n : ℕ} {τ : 𝕜}
+    (hF : AnalyticAt 𝕜 F τ) (hG : AnalyticAt 𝕜 G τ)
+    (hGord : meromorphicOrderAt G τ ≠ ⊤) (hc : ∀ k < n, AnalyticAt 𝕜 (c k) τ)
+    (hrel : F ^ n + (∑ k ∈ Finset.range n, c k * G ^ (n - k) * F ^ k) =ᶠ[𝓝 τ] 0) :
+    0 ≤ meromorphicOrderAt (F / G) τ := by
+  have hle := meromorphicOrderAt_le_of_monicRel hF hG hGord hc hrel
+  rw [meromorphicOrderAt_div hF.meromorphicAt hG.meromorphicAt,
+      ← LinearOrderedAddCommGroupWithTop.sub_self_eq_zero_of_ne_top hGord]
+  exact (LinearOrderedAddCommGroupWithTop.sub_le_sub_iff_left_of_ne_top hGord).mpr hle
+
+end ValuationEngine
+
+section HBridge
+
+lemma analyticOnNhd_comp_ofComplex {f : ℍ → ℂ} (hf : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) :
+    AnalyticOnNhd ℂ (f ∘ ofComplex) upperHalfPlaneSet :=
+  (UpperHalfPlane.mdifferentiable_iff.mp hf).analyticOnNhd isOpen_upperHalfPlaneSet
+
+lemma mdifferentiable_of_analyticOnNhd {f : ℍ → ℂ}
+    (hf : AnalyticOnNhd ℂ (f ∘ ofComplex) upperHalfPlaneSet) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f :=
+  UpperHalfPlane.mdifferentiable_iff.mpr hf.differentiableOn
+
+theorem mdifferentiable_eq_zero_or_eq_zero_of_mul_eq_zero {f g : ℍ → ℂ}
+    (hf : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) (hg : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hfg : f * g = 0) : f = 0 ∨ g = 0 := by
+  rw [UpperHalfPlane.mdifferentiable_iff] at hf hg
+  have hU : IsOpen {z : ℂ | 0 < z.im} := isOpen_upperHalfPlaneSet
+  have key := AnalyticOnNhd.eq_zero_or_eq_zero_of_mul_eq_zero (hf.analyticOnNhd hU)
+    (hg.analyticOnNhd hU) (fun z hz ↦ by
+      have := congrFun hfg (ofComplex z)
+      simpa using this) (convex_halfSpace_im_gt 0).isPreconnected
+  rcases key with k | k
+  · left; funext τ; simpa [ofComplex_apply] using k (τ : ℂ) τ.im_pos
+  · right; funext τ; simpa [ofComplex_apply] using k (τ : ℂ) τ.im_pos
+
+end HBridge
+
+end WLight
+
+open _root_.WLight _root_.P2MW.S_WLight_exists_mdifferentiable_div_of_monicRel.WLight in
+theorem solution {a b : ℍ → ℂ} {c : ℕ → ℍ → ℂ} {d : ℕ}
+    (hahol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) a) (hbhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) b)
+    (hb0 : b ≠ 0) (hc : ∀ k < d, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (c k))
+    (hrel : a ^ d + ∑ k ∈ Finset.range d, c k * b ^ (d - k) * a ^ k = 0) :
+    ∃ F : ℍ → ℂ, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F ∧ F * b = a := by
+  obtain ⟨τ₀, hτ₀⟩ := Function.ne_iff.mp hb0
+  have hrelH : ∀ τ : ℍ, a τ ^ d
+      + ∑ k ∈ Finset.range d, c k τ * b τ ^ (d - k) * a τ ^ k = 0 := by
+    intro τ
+    simpa only [Pi.add_apply, Pi.pow_apply, Finset.sum_apply, Pi.mul_apply,
+      Pi.zero_apply] using congrFun hrel τ
+  let a' := a ∘ ofComplex
+  let b' := b ∘ ofComplex
+  let c' := fun k ↦ (c k) ∘ ofComplex
+  have hrel' : Set.EqOn (a' ^ d + ∑ k ∈ Finset.range d, c' k * b' ^ (d - k) * a' ^ k) 0
+      upperHalfPlaneSet := by
+    intro z hz
+    simp only [Pi.add_apply, Pi.pow_apply, Finset.sum_apply, Pi.mul_apply, Pi.zero_apply,
+      a', b', c', comp_ofComplex_of_im_pos _ z hz]
+    exact hrelH ⟨z, hz⟩
+  obtain ⟨H', hH'an, hH'eq⟩ := exists_analyticOnNhd_div_of_monicRel isOpen_upperHalfPlaneSet
+    (convex_halfSpace_im_gt 0).isPreconnected (analyticOnNhd_comp_ofComplex hahol)
+    (analyticOnNhd_comp_ofComplex hbhol)
+    ⟨(τ₀ : ℂ), τ₀.im_pos, by
+      simpa [b', comp_ofComplex_of_im_pos b _ τ₀.im_pos] using hτ₀⟩
+    (fun k hk ↦ analyticOnNhd_comp_ofComplex (hc k hk)) hrel'
+  have hHmem : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fun τ : ℍ ↦ H' ↑τ) := by
+    apply mdifferentiable_of_analyticOnNhd
+    refine AnalyticOnNhd.congr isOpen_upperHalfPlaneSet hH'an (fun z hz ↦ ?_)
+    exact (comp_ofComplex_of_im_pos (fun τ : ℍ ↦ H' ↑τ) z hz).symm
+  refine ⟨fun τ ↦ H' ↑τ, hHmem, ?_⟩
+  funext τ
+  have heq := hH'eq τ.im_pos
+  simp only [Pi.mul_apply, Function.comp_apply, ofComplex_apply] at heq
+  change H' ↑τ * b τ = a τ
+  rw [mul_comm]
+  exact heq.symm
+
+end
+end S_WLight_exists_mdifferentiable_div_of_monicRel
+end P2MW
+export P2MW.S_WLight_exists_mdifferentiable_div_of_monicRel (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Complex Real UpperHalfPlane
+open scoped Manifold MatrixGroups ModularForm
+theorem WLight.exists_mdifferentiable_div_of_monicRel {a b : ℍ → ℂ} {c : ℕ → ℍ → ℂ} {d : ℕ}
+    (hahol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) a) (hbhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) b)
+    (hb0 : b ≠ 0) (hc : ∀ k < d, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (c k))
+    (hrel : a ^ d + ∑ k ∈ Finset.range d, c k * b ^ (d - k) * a ^ k = 0) :
+    ∃ F : ℍ → ℂ, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F ∧ F * b = a :=
+  solution hahol hbhol hb0 hc hrel
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_exists_monicRel_j_K_of_mdifferentiable_frickeQuotient.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_exists_monicRel_j_K_of_mdifferentiable_frickeQuotient.lean
new file mode 100644
index 0000000000..2c1c54f703
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_exists_monicRel_j_K_of_mdifferentiable_frickeQuotient.lean
@@ -0,0 +1,1470 @@
+/-
+Based on Prove2Me node WLight.exists_monicRel_j_K_of_mdifferentiable_frickeQuotient
+(5921eedf-dc5b-56e0-b86a-16413b6fdb7e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 05135d8b-3e8b-5f8d-9ab7-6c2b657286b1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.SpecialFunctions.Elliptic.Weierstrass
+public import Mathlib.NumberTheory.ModularForms.EisensteinSeries.Basic
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import Mathlib.FieldTheory.IntermediateField.Basic
+public import Mathlib.Geometry.Manifold.Notation
+
+import Mathlib.NumberTheory.ModularForms.QExpansion
+import Mathlib.NumberTheory.ModularForms.EisensteinSeries.QExpansion
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+import Mathlib.NumberTheory.ModularForms.CuspFormSubmodule
+import Mathlib.NumberTheory.ModularForms.LevelOne.Basic
+import Mathlib.RingTheory.PowerSeries.Order
+import Mathlib.LinearAlgebra.Dual.Lemmas
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+import Mathlib.RingTheory.MvPolynomial.Tower
+import Mathlib.Analysis.Analytic.IsolatedZeros
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_exists_monicRel_j_of_mdifferentiable_levelFraction
+import LeanPool.FLTEichlerShimura.Theorems.Thm_UpperHalfPlane_linearIndependent_complex_of_qExpansion_coeff_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_modularity_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_orbit_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Holomorphic Fricke fractions are integral over K[j]
+
+Theorem statement: `WLight.exists_monicRel_j_K_of_mdifferentiable_frickeQuotient`
+(`5921eedf-dc5b-56e0-b86a-16413b6fdb7e`), by Claude, 2026-09-05.
+
+Proof: submission `05135d8b-3e8b-5f8d-9ab7-6c2b657286b1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N$ with $N \neq 0$, and an assignment $L$ of period pairs to points of the upper half-plane
+with $(L\tau).\omega_1 = \tau$ and $(L\tau).\omega_2 = 1$. Let $W$ be a family of functions indexed
+by $v \in (\mathbb{Z}/N)^2$ pinned by $W_v(\tau) = (2\pi i)^{-2}\,\wp_{L\tau}\big((v_0\tau +
+v_1)/N\big)$, where $v_0, v_1$ are the canonical integer representatives, let $\mathrm{fricke}$ be
+pinned by $\mathrm{fricke}_v(\tau) = -\big(E_4(\tau)E_6(\tau)/\Delta(\tau)\big)/2592 \cdot
+W_v(\tau)$, and let $jf$ be pinned by $jf(\tau) = E_4(\tau)^3/\Delta(\tau)$. Let $K \subseteq
+\mathbb{C}$ be the intermediate field of $\mathbb{C}/\mathbb{Q}$ generated by $e^{2\pi i/N}$. Let $G
+: \mathbb{H} \to \mathbb{C}$ be holomorphic, and let $P_0, Q_0$ be polynomials over $K$ in variables
+indexed by $\mathrm{Option}\,\{v \in (\mathbb{Z}/N)^2 : v \neq 0\}$; write $\tilde P_0, \tilde Q_0 :
+\mathbb{H} \to \mathbb{C}$ for their evaluations after pushing the coefficients into $\mathbb{C}$,
+sending the distinguished variable to $jf$ and the variable $v$ to $\mathrm{fricke}_v$. Assume
+$\tilde Q_0 \neq 0$ in the algebra of functions $\mathbb{H} \to \mathbb{C}$ and $G \cdot \tilde Q_0
+= \tilde P_0$. Then there exist $d \in \mathbb{N}$ and polynomials $p_i \in \mathbb{C}[X]$ for $i <
+d$, all of whose coefficients lie in $K$, such that $G(\tau)^d + \sum_{i<d} p_i(jf(\tau))\,G(\tau)^i
+= 0$ for every $\tau \in \mathbb{H}$.
+
+This is the arithmetic refinement, from $\mathbb{C}$-coefficients to coefficients in
+$\mathbb{Q}(\zeta_N)$, of the statement that a holomorphic fraction of polynomial expressions in $j$
+and the Fricke functions of level $N$ is integral over $K[j]$; it rests on the modularity and
+$q$-expansion properties of the Fricke functions together with the descent of linear independence
+from $K$ to $\mathbb{C}$ for functions with $q$-expansion coefficients in $K$. It is used in the
+construction of $\mathbb{Q}(\zeta_N)$-rational structures on spaces of modular and cusp forms of
+level $N$, in particular for rationality of $q$-expansion coefficients of $\Gamma_1(N)$-forms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WLight_exists_monicRel_j_K_of_mdifferentiable_frickeQuotient.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WLight_exists_monicRel_j_K_of_mdifferentiable_frickeQuotient
+
+noncomputable section
+
+p2m_open "Complex Real UpperHalfPlane Function Filter Polynomial Real.Polynomial"
+open scoped Topology Manifold MatrixGroups ModularForm
+
+namespace WLight
+p2m_export "WLight" "exists_monicRel_j_of_mdifferentiable_levelFraction \
+  frickeFunction_modularity_package frickeFunction_orbit_package"
+p2m_open "WLight"
+
+section Descent
+
+private lemma exists_K_point_of_C_point (K : IntermediateField ℚ ℂ) {n q : ℕ}
+    (A : Fin q → Fin n → ↥K) (bv : Fin q → ↥K) (x : Fin n → ℂ)
+    (hx : ∀ j, ∑ i, (A j i : ℂ) * x i = (bv j : ℂ)) :
+    ∃ y : Fin n → ↥K, ∀ j, ∑ i, A j i * y i = bv j := by
+  classical
+  set cols : Fin n → (Fin q → ↥K) := fun i j => A j i with hcols
+  have hmem : bv ∈ Submodule.span ↥K (Set.range cols) := by
+    by_contra hbv
+    set W : Submodule ↥K (Fin q → ↥K) := Submodule.span ↥K (Set.range cols) with hW
+    have hq0 : W.mkQ bv ≠ 0 := by
+      intro h0
+      exact hbv ((Submodule.Quotient.mk_eq_zero W).mp (by simpa using h0))
+    obtain ⟨φ, hφ⟩ : ∃ φ : Module.Dual ↥K ((Fin q → ↥K) ⧸ W), φ (W.mkQ bv) ≠ 0 := by
+      by_contra hall
+      push Not at hall
+      exact hq0 ((Module.forall_dual_apply_eq_zero_iff ↥K _).mp hall)
+    set f : (Fin q → ↥K) →ₗ[↥K] ↥K := φ.comp W.mkQ with hf
+    have hfcols : ∀ i, f (cols i) = 0 := by
+      intro i
+      have hmem' : cols i ∈ W := Submodule.subset_span (Set.mem_range_self i)
+      simp only [hf, LinearMap.comp_apply, Submodule.mkQ_apply]
+      rw [(Submodule.Quotient.mk_eq_zero W).mpr hmem', map_zero]
+    set c : Fin q → ↥K := fun j => f (fun j' => if j = j' then 1 else 0) with hc
+    have hf_eq : ∀ w : Fin q → ↥K, f w = ∑ j, w j * c j := by
+      intro w
+      conv_lhs => rw [pi_eq_sum_univ w]
+      rw [map_sum]
+      refine Finset.sum_congr rfl fun j _ => ?_
+      rw [map_smul, smul_eq_mul]
+    have h1 : ∀ i, ∑ j, (A j i : ℂ) * (c j : ℂ) = 0 := by
+      intro i
+      have h0 : (∑ j, A j i * c j : ↥K) = 0 := by
+        have := hfcols i
+        rwa [hf_eq] at this
+      have h0' := congrArg (fun z : ↥K => (z : ℂ)) h0
+      push_cast at h0'
+      exact h0'
+    have hC : ((f bv : ↥K) : ℂ) = 0 := by
+      rw [hf_eq]
+      push_cast
+      have h3 : ∑ j, (bv j : ℂ) * (c j : ℂ) =
+          ∑ j, (∑ i, (A j i : ℂ) * x i) * (c j : ℂ) :=
+        Finset.sum_congr rfl fun j _ => by rw [hx j]
+      rw [h3]
+      have h4 : ∑ j, (∑ i, (A j i : ℂ) * x i) * (c j : ℂ) =
+          ∑ i, x i * ∑ j, (A j i : ℂ) * (c j : ℂ) := by
+        simp_rw [Finset.sum_mul, Finset.mul_sum]
+        rw [Finset.sum_comm]
+        exact Finset.sum_congr rfl fun i _ => Finset.sum_congr rfl fun j _ => by ring
+      rw [h4]
+      simp [h1]
+    have hfbv : f bv = 0 := by exact_mod_cast hC
+    exact hφ (by simpa [hf] using hfbv)
+  obtain ⟨y, hy⟩ := (Submodule.mem_span_range_iff_exists_fun ↥K).mp hmem
+  refine ⟨y, fun j => ?_⟩
+  have := congrFun hy j
+  simp only [Finset.sum_apply, Pi.smul_apply, smul_eq_mul, hcols] at this
+  rw [← this]
+  exact Finset.sum_congr rfl fun i _ => mul_comm _ _
+
+end Descent
+
+section GlueBFold
+
+open ModularForm
+
+namespace R8cGlue
+
+section Kit
+
+variable {N : ℕ}
+
+lemma jf_smul {jf : ℍ → ℂ} (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    (γ : SL(2, ℤ)) (τ : ℍ) : jf (γ • τ) = jf τ := by
+  have hγ : (Matrix.SpecialLinearGroup.mapGL ℝ γ : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ, rfl⟩
+  have h4 := SlashInvariantForm.slash_action_eqn'' ModularForm.E₄ hγ τ
+  have hΔ := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hγ τ
+  rw [CuspForm.coe_discriminant] at hΔ
+  rw [show (Matrix.SpecialLinearGroup.mapGL ℝ γ) • τ = γ • τ from rfl] at h4 hΔ
+  have hd : denom (Matrix.SpecialLinearGroup.mapGL ℝ γ) τ ≠ 0 := denom_ne_zero _ τ
+  have hΔ0 : ModularForm.discriminant τ ≠ 0 := ModularForm.discriminant_ne_zero τ
+  rw [hjf, hjf, h4, hΔ, zpow_ofNat, zpow_ofNat]
+  field_simp
+
+variable (jf : ℍ → ℂ) (fricke : (Fin 2 → ZMod N) → ℍ → ℂ)
+
+def gen : Option {v : Fin 2 → ZMod N // v ≠ 0} → ℍ → ℂ :=
+  fun o => o.elim jf fun v => fricke v.1
+
+variable {jf fricke}
+
+def genPerm (γ : SL(2, ℤ)) :
+    Option {v : Fin 2 → ZMod N // v ≠ 0} → Option {v : Fin 2 → ZMod N // v ≠ 0} :=
+  Option.map fun v => ⟨Matrix.vecMul v.1
+    ((Matrix.SpecialLinearGroup.map (Int.castRingHom (ZMod N)) γ :
+      Matrix.SpecialLinearGroup (Fin 2) (ZMod N)) : Matrix (Fin 2) (Fin 2) (ZMod N)), by
+    intro h
+    apply v.2
+    have := congrArg (fun w => Matrix.vecMul w
+      ((Matrix.SpecialLinearGroup.map (Int.castRingHom (ZMod N)) γ⁻¹ :
+        Matrix.SpecialLinearGroup (Fin 2) (ZMod N)) : Matrix (Fin 2) (Fin 2) (ZMod N))) h
+    simp only [Matrix.zero_vecMul, Matrix.vecMul_vecMul] at this
+    rwa [← Matrix.SpecialLinearGroup.coe_mul, ← map_mul, mul_inv_cancel, map_one,
+      Matrix.SpecialLinearGroup.coe_one, Matrix.vecMul_one] at this⟩
+
+lemma aeval_gen_comp_smul {R : Type*} [CommSemiring R] [Algebra R ℂ]
+    (hjinv : ∀ (γ : SL(2, ℤ)) (τ : ℍ), jf (γ • τ) = jf τ)
+    (hfslash : ∀ (v : Fin 2 → ZMod N) (γ : SL(2, ℤ)) (τ : ℍ),
+      fricke v (γ • τ) = fricke (Matrix.vecMul v
+        ((Matrix.SpecialLinearGroup.map (Int.castRingHom (ZMod N)) γ :
+          Matrix.SpecialLinearGroup (Fin 2) (ZMod N)) : Matrix (Fin 2) (Fin 2) (ZMod N))) τ)
+    (γ : SL(2, ℤ)) (P : MvPolynomial (Option {v : Fin 2 → ZMod N // v ≠ 0}) R) :
+    (MvPolynomial.aeval (gen jf fricke) P : ℍ → ℂ) ∘ (γ • ·) =
+      MvPolynomial.aeval (gen jf fricke) (MvPolynomial.rename (genPerm γ) P) := by
+  let Cγ : (ℍ → ℂ) →ₐ[R] (ℍ → ℂ) :=
+    { toFun := fun F => F ∘ (γ • ·)
+      map_one' := rfl
+      map_mul' := fun _ _ => rfl
+      map_zero' := rfl
+      map_add' := fun _ _ => rfl
+      commutes' := fun r => by
+        funext τ
+        simp only [Function.comp_apply, Pi.algebraMap_apply] }
+  have h1 : (MvPolynomial.aeval (gen jf fricke) P : ℍ → ℂ) ∘ (γ • ·) =
+      Cγ (MvPolynomial.aeval (gen jf fricke) P) := rfl
+  have h2 : (fun o => Cγ (gen jf fricke o)) = gen jf fricke ∘ genPerm γ := by
+    funext o
+    cases o with
+    | none => funext τ; exact hjinv γ τ
+    | some v => funext τ; exact hfslash v.1 γ τ
+  rw [MvPolynomial.aeval_rename, h1, ← AlgHom.comp_apply, MvPolynomial.comp_aeval, h2]
+
+lemma mem_adjoin_gen_iff {R : Type*} [CommRing R] [Algebra R ℂ] {x : ℍ → ℂ} :
+    x ∈ Algebra.adjoin R (Set.range (gen jf fricke)) ↔
+      ∃ P : MvPolynomial (Option {v : Fin 2 → ZMod N // v ≠ 0}) R,
+        MvPolynomial.aeval (gen jf fricke) P = x := by
+  rw [Algebra.adjoin_range_eq_range_aeval, AlgHom.mem_range]
+
+lemma isBoundedAtImInfty_discriminant : IsBoundedAtImInfty (⇑CuspForm.discriminant : ℍ → ℂ) :=
+  (CuspFormClass.zero_at_infty CuspForm.discriminant).boundedAtFilter
+
+lemma isBoundedAtImInfty_discPow (n : ℕ) :
+    IsBoundedAtImInfty (⇑CuspForm.discriminant ^ n : ℍ → ℂ) := by
+  induction n with
+  | zero => exact pow_zero (⇑CuspForm.discriminant : ℍ → ℂ) ▸ Filter.const_boundedAtFilter _ (1 : ℂ)
+  | succ k ih =>
+    rw [pow_succ]
+    exact ih.mul isBoundedAtImInfty_discriminant
+
+private lemma _root_.WLight.R8cGlue.mul_discPow_mono {f : ℍ → ℂ} {m m' : ℕ} (hm : m ≤ m')
+    (h : IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m)) :
+    IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m') := by
+  have hshape : (f * ⇑CuspForm.discriminant ^ m' : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m) * ⇑CuspForm.discriminant ^ (m' - m) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply]
+    rw [mul_assoc, ← pow_add, Nat.add_sub_cancel' hm]
+  rw [hshape]
+  exact h.mul (isBoundedAtImInfty_discPow (m' - m))
+
+p2m_export "WLight.R8cGlue" "mul_discPow_mono"
+
+def discPowForm (m : ℕ) : ModularForm 𝒮ℒ (12 * m) :=
+  ModularForm.mcast (by ring) ((CuspForm.toModularFormₗ CuspForm.discriminant).pow m)
+
+lemma discPowForm_coe (m : ℕ) : ⇑(discPowForm m) = ⇑CuspForm.discriminant ^ m := by
+  funext z
+  simp [discPowForm, ModularForm.coe_mcast, ModularForm.coe_pow,
+    CuspForm.toModularFormₗ_apply]
+
+lemma periodic_one_fn (c : ℝ) : Function.Periodic ((1 : ℍ → ℂ) ∘ ofComplex) c := fun _ => rfl
+
+lemma periodic_discPow_comp_ofComplex (k : ℕ) (N : ℕ) :
+    Function.Periodic ((⇑CuspForm.discriminant ^ k : ℍ → ℂ) ∘ ofComplex) N := by
+  have h1 : Function.Periodic (⇑CuspForm.discriminant ∘ ofComplex) 1 :=
+    SlashInvariantFormClass.periodic_comp_ofComplex CuspForm.discriminant
+      one_mem_strictPeriods_SL
+  have hk : Function.Periodic ((⇑CuspForm.discriminant ^ k : ℍ → ℂ) ∘ ofComplex) 1 := by
+    induction k with
+    | zero => exact periodic_one_fn 1
+    | succ k ih =>
+      intro x
+      have hx := (ih.mul h1) x
+      simp only [Function.comp_apply, Pi.mul_apply, Pi.pow_apply] at hx ⊢
+      rw [pow_succ, pow_succ]
+      exact hx
+  simpa using hk.nat_mul N
+
+lemma mdiff_discPow (k : ℕ) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (⇑CuspForm.discriminant ^ k : ℍ → ℂ) := by
+  rw [← discPowForm_coe]
+  exact (discPowForm k).holo'
+
+end Kit
+
+section Analysis
+
+variable {N : ℕ}
+
+lemma eq_zero_of_forall_im_ge {f : ℍ → ℂ} (hf : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) {A : ℝ}
+    (h : ∀ τ : ℍ, A ≤ τ.im → f τ = 0) : f = 0 := by
+  rw [UpperHalfPlane.mdifferentiable_iff] at hf
+  have hU : IsOpen {z : ℂ | 0 < z.im} := isOpen_upperHalfPlaneSet
+  have han := hf.analyticOnNhd hU
+  have hB : 0 < max A 0 + 1 := lt_of_le_of_lt (le_max_right A 0) (lt_add_one _)
+  have hz₀ : (⟨0, max A 0 + 1⟩ : ℂ) ∈ {z : ℂ | 0 < z.im} := hB
+  have hev : f ∘ ofComplex =ᶠ[𝓝 (⟨0, max A 0 + 1⟩ : ℂ)] 0 := by
+    have hopen : IsOpen {z : ℂ | max A 0 < z.im} := isOpen_lt continuous_const Complex.continuous_im
+    have hmem : (⟨0, max A 0 + 1⟩ : ℂ) ∈ {z : ℂ | max A 0 < z.im} := by
+      change max A 0 < max A 0 + 1
+      exact lt_add_one _
+    filter_upwards [hopen.mem_nhds hmem] with z hz
+    have hz' : 0 < z.im := lt_of_le_of_lt (le_max_right A 0) hz
+    simp only [Function.comp_apply, Pi.zero_apply, ofComplex_apply_of_im_pos hz']
+    exact h ⟨z, hz'⟩ ((le_max_left A 0).trans (le_of_lt hz))
+  have key := han.eqOn_zero_of_preconnected_of_eventuallyEq_zero
+    (convex_halfSpace_im_gt 0).isPreconnected hz₀ hev
+  funext τ
+  have := key τ.im_pos
+  simpa [ofComplex_apply] using this
+
+lemma exists_qParam_pow_le [NeZero N] {Q : ℍ → ℂ} (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) Q)
+    (hper : Function.Periodic (Q ∘ ofComplex) N) (hbd : IsBoundedAtImInfty Q) (hQ0 : Q ≠ 0) :
+    ∃ (r : ℕ) (C A : ℝ), 0 < C ∧
+      ∀ τ : ℍ, A ≤ τ.im → C * ‖Function.Periodic.qParam N τ‖ ^ r ≤ ‖Q τ‖ := by
+  have hN : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  have hg : AnalyticAt ℂ (cuspFunction N Q) 0 := analyticAt_cuspFunction_zero hN hper hhol hbd
+  have hq : Tendsto (fun τ : ℍ => Function.Periodic.qParam N τ) atImInfty (𝓝 0) :=
+    qParam_tendsto_atImInfty hN
+  have heq : ∀ τ : ℍ, cuspFunction N Q (Function.Periodic.qParam N τ) = Q τ := fun τ =>
+    eq_cuspFunction τ hN.ne' hper
+  by_cases h0 : ∀ᶠ z in 𝓝 (0 : ℂ), cuspFunction N Q z = 0
+  · exfalso
+    apply hQ0
+    have h1 : ∀ᶠ τ : ℍ in atImInfty, Q τ = 0 :=
+      (hq.eventually h0).mono fun τ hτ => by rwa [heq τ] at hτ
+    rw [Filter.Eventually, atImInfty_mem] at h1
+    obtain ⟨A, hA⟩ := h1
+    exact eq_zero_of_forall_im_ge hhol hA
+  · obtain ⟨r, u, hu, hu0, hfe⟩ := hg.exists_eventuallyEq_pow_smul_nonzero_iff.mpr h0
+    have hpos : 0 < ‖u 0‖ / 2 := by positivity
+    have hu_lb : ∀ᶠ z in 𝓝 (0 : ℂ), ‖u 0‖ / 2 ≤ ‖u z‖ := by
+      have ht : Tendsto (fun z => ‖u z‖) (𝓝 0) (𝓝 ‖u 0‖) := hu.continuousAt.norm
+      exact (ht.eventually_const_lt (half_lt_self (norm_pos_iff.mpr hu0))).mono fun z hz => hz.le
+    have hloc : ∀ᶠ z in 𝓝 (0 : ℂ), ‖u 0‖ / 2 * ‖z‖ ^ r ≤ ‖cuspFunction N Q z‖ := by
+      filter_upwards [hfe, hu_lb] with z hz hz'
+      rw [hz, sub_zero, norm_smul, norm_pow, mul_comm]
+      exact mul_le_mul_of_nonneg_left hz' (pow_nonneg (norm_nonneg _) _)
+    have hev : ∀ᶠ τ : ℍ in atImInfty,
+        ‖u 0‖ / 2 * ‖Function.Periodic.qParam N τ‖ ^ r ≤ ‖Q τ‖ :=
+      (hq.eventually hloc).mono fun τ hτ => by rwa [heq τ] at hτ
+    rw [Filter.Eventually, atImInfty_mem] at hev
+    obtain ⟨A, hA⟩ := hev
+    exact ⟨r, ‖u 0‖ / 2, A, hpos, fun τ hτ => hA τ hτ⟩
+
+lemma map_T_pow_eq_one :
+    ((Matrix.SpecialLinearGroup.map (Int.castRingHom (ZMod N)) (ModularGroup.T ^ (N : ℤ)) :
+      Matrix.SpecialLinearGroup (Fin 2) (ZMod N)) : Matrix (Fin 2) (Fin 2) (ZMod N)) = 1 := by
+  rw [Matrix.SpecialLinearGroup.map_apply_coe, ModularGroup.coe_T_zpow]
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp
+
+lemma periodic_comp_ofComplex_of_T {x : ℍ → ℂ}
+    (h : ∀ τ : ℍ, x (ModularGroup.T ^ (N : ℤ) • τ) = x τ) :
+    Function.Periodic (x ∘ ofComplex) N := by
+  intro w
+  by_cases! hw : 0 < im w
+  · have hw' : 0 < im (w + N) := by simpa using hw
+    simp only [comp_apply, ofComplex_apply_of_im_pos hw', ofComplex_apply_of_im_pos hw]
+    rw [← h ⟨w, hw⟩]
+    congr 1
+    apply UpperHalfPlane.ext
+    rw [UpperHalfPlane.modular_T_zpow_smul, UpperHalfPlane.coe_vadd]
+    push_cast
+    ring
+  · have hw' : im (w + N) ≤ 0 := by simpa using hw
+    simp [ofComplex_apply_of_im_nonpos hw', ofComplex_apply_of_im_nonpos hw]
+
+end Analysis
+
+section Quotient
+
+variable {N : ℕ} [NeZero N] {jf : ℍ → ℂ} {fricke : (Fin 2 → ZMod N) → ℍ → ℂ}
+
+structure GenData (jf : ℍ → ℂ) (fricke : (Fin 2 → ZMod N) → ℍ → ℂ) : Prop where
+  jmd : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) jf
+  jbd : ∃ m : ℕ, IsBoundedAtImInfty (jf * ⇑CuspForm.discriminant ^ m)
+  fmd : ∀ v : Fin 2 → ZMod N, v ≠ 0 → MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fricke v)
+  fbd : ∀ v : Fin 2 → ZMod N, v ≠ 0 →
+    ∃ m : ℕ, IsBoundedAtImInfty (fricke v * ⇑CuspForm.discriminant ^ m)
+  jinv : ∀ (γ : SL(2, ℤ)) (τ : ℍ), jf (γ • τ) = jf τ
+  fslash : ∀ (v : Fin 2 → ZMod N) (γ : SL(2, ℤ)) (τ : ℍ),
+    fricke v (γ • τ) = fricke (Matrix.vecMul v
+      ((Matrix.SpecialLinearGroup.map (Int.castRingHom (ZMod N)) γ :
+        Matrix.SpecialLinearGroup (Fin 2) (ZMod N)) : Matrix (Fin 2) (Fin 2) (ZMod N))) τ
+
+omit [NeZero N] in
+lemma adjoin_props (hg : GenData jf fricke) {x : ℍ → ℂ}
+    (hx : x ∈ Algebra.adjoin ℂ (Set.range (gen jf fricke))) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) x ∧
+      (∃ m : ℕ, IsBoundedAtImInfty (x * ⇑CuspForm.discriminant ^ m)) ∧
+      ∀ τ : ℍ, x (ModularGroup.T ^ (N : ℤ) • τ) = x τ := by
+  induction hx using Algebra.adjoin_induction with
+  | mem g hg' =>
+    obtain ⟨o, rfl⟩ := hg'
+    cases o with
+    | none => exact ⟨hg.jmd, hg.jbd, fun τ => hg.jinv _ τ⟩
+    | some v =>
+      refine ⟨hg.fmd v.1 v.2, hg.fbd v.1 v.2, fun τ => ?_⟩
+      change fricke v.1 _ = fricke v.1 τ
+      rw [hg.fslash, map_T_pow_eq_one, Matrix.vecMul_one]
+  | algebraMap c =>
+    refine ⟨mdifferentiable_const, ⟨0, ?_⟩, fun τ => rfl⟩
+    rw [pow_zero, mul_one]
+    exact Filter.const_boundedAtFilter atImInfty c
+  | add x y _ _ ihx ihy =>
+    obtain ⟨hxm, ⟨m, hm⟩, hxT⟩ := ihx
+    obtain ⟨hym, ⟨n, hn⟩, hyT⟩ := ihy
+    refine ⟨hxm.add hym, ⟨max m n, ?_⟩, fun τ => by simp only [Pi.add_apply, hxT, hyT]⟩
+    rw [add_mul]
+    exact (mul_discPow_mono (le_max_left m n) hm).add (mul_discPow_mono (le_max_right m n) hn)
+  | mul x y _ _ ihx ihy =>
+    obtain ⟨hxm, ⟨m, hm⟩, hxT⟩ := ihx
+    obtain ⟨hym, ⟨n, hn⟩, hyT⟩ := ihy
+    refine ⟨hxm.mul hym, ⟨m + n, ?_⟩, fun τ => by simp only [Pi.mul_apply, hxT, hyT]⟩
+    have : (x * y * ⇑CuspForm.discriminant ^ (m + n) : ℍ → ℂ) =
+        (x * ⇑CuspForm.discriminant ^ m) * (y * ⇑CuspForm.discriminant ^ n) := by
+      rw [pow_add]; ring
+    rw [this]
+    exact hm.mul hn
+
+omit [NeZero N] in
+lemma comp_smul_mem_adjoin (hg : GenData jf fricke) (γ : SL(2, ℤ)) {x : ℍ → ℂ}
+    (hx : x ∈ Algebra.adjoin ℂ (Set.range (gen jf fricke))) :
+    x ∘ (γ • ·) ∈ Algebra.adjoin ℂ (Set.range (gen jf fricke)) := by
+  rw [mem_adjoin_gen_iff] at hx ⊢
+  obtain ⟨P, rfl⟩ := hx
+  exact ⟨_, (aeval_gen_comp_smul hg.jinv hg.fslash γ P).symm⟩
+
+theorem exists_isBoundedAtImInfty_of_mul_eq (hg : GenData jf fricke) {h q p : ℍ → ℂ}
+    (hq : q ∈ Algebra.adjoin ℂ (Set.range (gen jf fricke)))
+    (hp : p ∈ Algebra.adjoin ℂ (Set.range (gen jf fricke))) (hq0 : q ≠ 0) (hhq : h * q = p) :
+    ∃ m : ℕ, IsBoundedAtImInfty (h * ⇑CuspForm.discriminant ^ m) := by
+  obtain ⟨hqm, ⟨mq, hmq⟩, hqT⟩ := adjoin_props hg hq
+  obtain ⟨_, ⟨mp, hmp⟩, _⟩ := adjoin_props hg hp
+  have hQhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (q * ⇑CuspForm.discriminant ^ mq) :=
+    hqm.mul (mdiff_discPow mq)
+  have hQper : Function.Periodic ((q * ⇑CuspForm.discriminant ^ mq : ℍ → ℂ) ∘ ofComplex) N :=
+    (periodic_comp_ofComplex_of_T hqT).mul (periodic_discPow_comp_ofComplex mq N)
+  have hQ0 : (q * ⇑CuspForm.discriminant ^ mq : ℍ → ℂ) ≠ 0 := by
+    intro hz
+    apply hq0
+    funext τ
+    have := congrFun hz τ
+    simp only [Pi.mul_apply, Pi.pow_apply, Pi.zero_apply, mul_eq_zero, pow_eq_zero_iff',
+      ne_eq] at this
+    rcases this with h1 | ⟨h1, _⟩
+    · exact h1
+    · exact absurd h1 (ModularForm.discriminant_ne_zero τ)
+  obtain ⟨r, C, A, hC, hlb⟩ := exists_qParam_pow_le hQhol hQper hmq hQ0
+  obtain ⟨Mp, Ap, hMp⟩ := isBoundedAtImInfty_iff.mp hmp
+  obtain ⟨MΔ, AΔ, hMΔ⟩ := isBoundedAtImInfty_iff.mp isBoundedAtImInfty_discriminant
+  obtain ⟨c, hc, hcO⟩ := (CuspFormClass.exp_decay_atImInfty (h := 1) CuspForm.discriminant
+    one_pos one_mem_strictPeriods_SL).exists_pos
+  have hcO' := hcO.bound
+  rw [Filter.Eventually, atImInfty_mem] at hcO'
+  obtain ⟨Ac, hAc⟩ := hcO'
+  refine ⟨mp + r, isBoundedAtImInfty_iff.mpr ⟨Mp * c ^ r * MΔ ^ mq / C,
+    max (max A Ap) (max AΔ Ac), fun τ hτ => ?_⟩⟩
+  have hA' : A ≤ τ.im := (le_max_left _ _).trans ((le_max_left _ _).trans hτ)
+  have hAp' : Ap ≤ τ.im := (le_max_right _ _).trans ((le_max_left _ _).trans hτ)
+  have hAΔ' : AΔ ≤ τ.im := (le_max_left _ _).trans ((le_max_right _ _).trans hτ)
+  have hAc' : Ac ≤ τ.im := (le_max_right _ _).trans ((le_max_right _ _).trans hτ)
+  set a : ℝ := ‖Function.Periodic.qParam N τ‖ with ha
+  set d : ℝ := ‖CuspForm.discriminant τ‖ with hd
+  have ha0 : 0 < a := by rw [ha, norm_pos_iff]; exact Complex.exp_ne_zero _
+  have hd0 : 0 ≤ d := norm_nonneg _
+  have hB := hlb τ hA'
+  have hBpos : 0 < ‖(q * ⇑CuspForm.discriminant ^ mq) τ‖ := lt_of_lt_of_le (by positivity) hB
+  have hY : ‖(p * ⇑CuspForm.discriminant ^ mp) τ‖ ≤ Mp := hMp τ hAp'
+  have hMp0 : 0 ≤ Mp := (norm_nonneg _).trans hY
+  have hdM : d ≤ MΔ := hMΔ τ hAΔ'
+  have hMΔ0 : 0 ≤ MΔ := hd0.trans hdM
+  have hde : d ≤ c * a := by
+    have h1 : d ≤ c * ‖Real.exp (-2 * π * τ.im / 1)‖ := hAc τ hAc'
+    have h2 : Real.exp (-2 * π * τ.im / 1) ≤ a := by
+      rw [ha, Function.Periodic.norm_qParam]
+      apply Real.exp_le_exp.mpr
+      rw [div_one, UpperHalfPlane.coe_im]
+      have hN1 : (1 : ℝ) ≤ N := by exact_mod_cast Nat.one_le_iff_ne_zero.mpr (NeZero.ne N)
+      have hN0 : (0 : ℝ) < N := one_pos.trans_le hN1
+      rw [div_eq_mul_inv, neg_mul, neg_mul, neg_mul, neg_le_neg_iff]
+      have : 2 * π * τ.im * (N : ℝ)⁻¹ ≤ 2 * π * τ.im * 1 := by
+        apply mul_le_mul_of_nonneg_left _ (by positivity)
+        rw [inv_le_one_iff₀]
+        exact Or.inr hN1
+      simpa using this
+    calc d ≤ c * ‖Real.exp (-2 * π * τ.im / 1)‖ := h1
+      _ = c * Real.exp (-2 * π * τ.im / 1) := by rw [Real.norm_eq_abs, abs_of_pos (Real.exp_pos _)]
+      _ ≤ c * a := mul_le_mul_of_nonneg_left h2 hc.le
+  have hX : ‖(h * ⇑CuspForm.discriminant ^ (mp + r)) τ‖ * ‖(q * ⇑CuspForm.discriminant ^ mq) τ‖
+      = ‖(p * ⇑CuspForm.discriminant ^ mp) τ‖ * d ^ r * d ^ mq := by
+    rw [← hhq]
+    simp only [Pi.mul_apply, Pi.pow_apply, norm_mul, norm_pow, hd, pow_add]
+    ring
+  have hnum0 : 0 ≤ ‖(p * ⇑CuspForm.discriminant ^ mp) τ‖ * d ^ r * d ^ mq := by positivity
+  calc ‖(h * ⇑CuspForm.discriminant ^ (mp + r)) τ‖
+      = ‖(p * ⇑CuspForm.discriminant ^ mp) τ‖ * d ^ r * d ^ mq /
+          ‖(q * ⇑CuspForm.discriminant ^ mq) τ‖ := by
+        rw [eq_div_iff hBpos.ne', hX]
+    _ ≤ ‖(p * ⇑CuspForm.discriminant ^ mp) τ‖ * d ^ r * d ^ mq / (C * a ^ r) :=
+        div_le_div_of_nonneg_left hnum0 (by positivity) hB
+    _ ≤ Mp * (c * a) ^ r * MΔ ^ mq / (C * a ^ r) := by
+        apply div_le_div_of_nonneg_right _ (by positivity)
+        exact mul_le_mul (mul_le_mul hY (pow_le_pow_left₀ hd0 hde r) (by positivity) hMp0)
+          (pow_le_pow_left₀ hd0 hdM mq) (by positivity) (by positivity)
+    _ = Mp * c ^ r * MΔ ^ mq / C := by
+        rw [mul_pow]
+        field_simp
+
+theorem isBoundedAtImInfty_smul_quotient_of_aeval
+    (N : ℕ) [NeZero N]
+    (L : ℍ → PeriodPair) (hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), W v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (jf : ℍ → ℂ)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    (K : IntermediateField ℚ ℂ)
+    (hK : K = IntermediateField.adjoin ℚ
+      {Complex.exp (2 * (Real.pi : ℂ) * Complex.I / (N : ℂ))})
+    (hR4c : ∀ (v : Fin 2 → ZMod N) (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) (τ : ℍ),
+      fricke v (γ • τ) = fricke (Matrix.vecMul v
+        ((Matrix.SpecialLinearGroup.map (Int.castRingHom (ZMod N)) γ :
+          Matrix.SpecialLinearGroup (Fin 2) (ZMod N)) : Matrix (Fin 2) (Fin 2) (ZMod N))) τ)
+    (hR4b12 : (MDifferentiable 𝓘(ℂ) 𝓘(ℂ) jf ∧
+        ∃ m : ℕ, IsBoundedAtImInfty (jf * ModularForm.discriminant ^ m)) ∧
+      (∀ v : Fin 2 → ZMod N, v ≠ 0 → MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fricke v) ∧
+        ∃ m : ℕ, IsBoundedAtImInfty (fricke v * ModularForm.discriminant ^ m)))
+    {G : ℍ → ℂ} (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (P₀ Q₀ : MvPolynomial (Option {v : Fin 2 → ZMod N // v ≠ 0}) ↥K)
+    (hQ0 : MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+      o.elim jf fun v => fricke v.1) (Q₀.map (algebraMap ↥K ℂ)) ≠ 0)
+    (hGQ : G * MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+        o.elim jf fun v => fricke v.1) (Q₀.map (algebraMap ↥K ℂ)) =
+      MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+        o.elim jf fun v => fricke v.1) (P₀.map (algebraMap ↥K ℂ))) :
+    ∀ γ : Matrix.SpecialLinearGroup (Fin 2) ℤ, ∃ m : ℕ,
+      IsBoundedAtImInfty ((G ∘ (γ • ·)) * ModularForm.discriminant ^ m) := by
+  have _hL := hL
+  have _hW := hW
+  have _hfricke := hfricke
+  have _hK := hK
+  have _hG := hG
+  intro γ
+  have hg : GenData jf fricke := ⟨hR4b12.1.1, by simpa only [CuspForm.coe_discriminant] using
+    hR4b12.1.2, fun v hv => (hR4b12.2 v hv).1, fun v hv => by
+      simpa only [CuspForm.coe_discriminant] using (hR4b12.2 v hv).2, jf_smul hjf, hR4c⟩
+  have hgen : (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} => o.elim jf fun v => fricke v.1) =
+      gen jf fricke := rfl
+  rw [hgen] at hQ0 hGQ
+  set q : ℍ → ℂ := MvPolynomial.aeval (gen jf fricke) (Q₀.map (algebraMap ↥K ℂ)) with hqdef
+  set p : ℍ → ℂ := MvPolynomial.aeval (gen jf fricke) (P₀.map (algebraMap ↥K ℂ)) with hpdef
+  have hqmem : q ∈ Algebra.adjoin ℂ (Set.range (gen jf fricke)) := mem_adjoin_gen_iff.mpr ⟨_, rfl⟩
+  have hpmem : p ∈ Algebra.adjoin ℂ (Set.range (gen jf fricke)) := mem_adjoin_gen_iff.mpr ⟨_, rfl⟩
+  have hq0' : q ∘ (γ • ·) ≠ 0 := by
+    intro hz
+    apply hQ0
+    funext τ
+    have := congrFun hz (γ⁻¹ • τ)
+    simpa only [comp_apply, smul_inv_smul, Pi.zero_apply] using this
+  have hhq : (G ∘ (γ • ·)) * (q ∘ (γ • ·)) = p ∘ (γ • ·) := by
+    funext τ
+    exact congrFun hGQ (γ • τ)
+  simpa only [CuspForm.coe_discriminant] using exists_isBoundedAtImInfty_of_mul_eq hg
+    (comp_smul_mem_adjoin hg γ hqmem) (comp_smul_mem_adjoin hg γ hpmem) hq0' hhq
+
+end Quotient
+
+end R8cGlue
+
+end GlueBFold
+
+section QKitA
+
+variable {N : ℕ}
+
+private lemma isBoundedAtImInfty_discriminant :
+    IsBoundedAtImInfty (⇑CuspForm.discriminant : ℍ → ℂ) :=
+  (CuspFormClass.zero_at_infty CuspForm.discriminant).boundedAtFilter
+
+private lemma isBoundedAtImInfty_discPow (n : ℕ) :
+    IsBoundedAtImInfty (⇑CuspForm.discriminant ^ n : ℍ → ℂ) := by
+  induction n with
+  | zero => exact pow_zero (⇑CuspForm.discriminant : ℍ → ℂ) ▸ Filter.const_boundedAtFilter _ (1 : ℂ)
+  | succ k ih =>
+    rw [pow_succ]
+    exact ih.mul isBoundedAtImInfty_discriminant
+
+private lemma IsBoundedAtImInfty.mul_discPow_mono {f : ℍ → ℂ} {m m' : ℕ} (hm : m ≤ m')
+    (h : IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m)) :
+    IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m') := by
+  have hshape : (f * ⇑CuspForm.discriminant ^ m' : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m) * ⇑CuspForm.discriminant ^ (m' - m) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply]
+    rw [mul_assoc, ← pow_add, Nat.add_sub_cancel' hm]
+  rw [hshape]
+  exact h.mul (isBoundedAtImInfty_discPow (m' - m))
+
+private def discPowForm (m : ℕ) : ModularForm 𝒮ℒ (12 * m) :=
+  ModularForm.mcast (by ring) ((CuspForm.toModularFormₗ CuspForm.discriminant).pow m)
+
+private lemma discPowForm_coe (m : ℕ) : ⇑(discPowForm m) = ⇑CuspForm.discriminant ^ m := by
+  funext z
+  simp [discPowForm, ModularForm.coe_mcast, ModularForm.coe_pow,
+    CuspForm.toModularFormₗ_apply]
+
+private lemma periodic_one_fn (c : ℝ) :
+    Function.Periodic ((1 : ℍ → ℂ) ∘ ofComplex) c := fun _ => rfl
+
+private lemma periodic_discPow_comp_ofComplex (k : ℕ) (N : ℕ) :
+    Function.Periodic ((⇑CuspForm.discriminant ^ k : ℍ → ℂ) ∘ ofComplex) N := by
+  have h1 : Function.Periodic (⇑CuspForm.discriminant ∘ ofComplex) 1 :=
+    SlashInvariantFormClass.periodic_comp_ofComplex CuspForm.discriminant
+      one_mem_strictPeriods_SL
+  have hk : Function.Periodic ((⇑CuspForm.discriminant ^ k : ℍ → ℂ) ∘ ofComplex) 1 := by
+    induction k with
+    | zero => exact periodic_one_fn 1
+    | succ k ih =>
+      intro x
+      have hx := (ih.mul h1) x
+      simp only [Function.comp_apply, Pi.mul_apply, Pi.pow_apply] at hx ⊢
+      rw [pow_succ, pow_succ]
+      exact hx
+  simpa using hk.nat_mul N
+
+private lemma mdiff_discPow (k : ℕ) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (⇑CuspForm.discriminant ^ k : ℍ → ℂ) := by
+  rw [← discPowForm_coe]
+  exact (discPowForm k).holo'
+
+private lemma mdiff_mul_discPow {f : ℍ → ℂ} (hf : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) (m : ℕ) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (f * ⇑CuspForm.discriminant ^ m : ℍ → ℂ) :=
+  hf.mul (mdiff_discPow m)
+
+private lemma analyticAt_cuspFunction_zero_of [NeZero N] {g : ℍ → ℂ}
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hper : Function.Periodic (g ∘ ofComplex) N) (hbd : IsBoundedAtImInfty g) :
+    AnalyticAt ℂ (cuspFunction N g) 0 :=
+  analyticAt_cuspFunction_zero
+    (by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)) hper hhol hbd
+
+private lemma qExpansion_one_discPowForm (k : ℕ) :
+    qExpansion 1 (discPowForm k) = (qExpansion 1 ModularForm.discriminant) ^ k := by
+  rw [discPowForm, ModularForm.qExpansion_mcast,
+    ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+  have hco : (⇑(CuspForm.toModularFormₗ CuspForm.discriminant) : ℍ → ℂ) =
+      ModularForm.discriminant := by
+    funext z
+    rw [CuspForm.toModularFormₗ_apply]
+    exact congrFun CuspForm.coe_discriminant z
+  rw [hco]
+
+private lemma qExpansion_one_discPow (k : ℕ) :
+    qExpansion 1 (⇑CuspForm.discriminant ^ k : ℍ → ℂ) =
+      (qExpansion 1 ModularForm.discriminant) ^ k := by
+  rw [← discPowForm_coe]
+  exact qExpansion_one_discPowForm k
+
+private lemma qParam_one_eq_pow {N : ℕ} (hN : N ≠ 0) (τ : ℂ) :
+    Function.Periodic.qParam 1 τ = Function.Periodic.qParam N τ ^ N := by
+  have : (N : ℂ) ≠ 0 := by exact_mod_cast hN
+  simp only [Function.Periodic.qParam, Complex.ofReal_one, div_one, Complex.ofReal_natCast]
+  rw [← Complex.exp_nat_mul]
+  congr 1
+  field_simp
+
+private theorem qExpansion_coeff_width (f : ℍ → ℂ) {N : ℕ} (hN : N ≠ 0)
+    (hper : Function.Periodic (f ∘ ofComplex) 1) (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f)
+    (hbd : IsBoundedAtImInfty f) (n : ℕ) :
+    (qExpansion N f).coeff n =
+      if N ∣ n then (qExpansion 1 f).coeff (n / N) else 0 := by
+  have hN' : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero hN
+  have hperN : Function.Periodic (f ∘ ofComplex) N := by
+    simpa using hper.nat_mul N
+  let f' : C(ℍ, ℂ) := ⟨f, hhol.continuous⟩
+  have hfan : AnalyticAt ℂ (cuspFunction N f') 0 :=
+    analyticAt_cuspFunction_zero hN' hperN hhol hbd
+  set c : ℕ → ℂ := fun n ↦ if N ∣ n then (qExpansion 1 f).coeff (n / N) else 0 with hc
+  have hf : ∀ τ : ℍ, HasSum (fun m ↦ c m • Function.Periodic.qParam N τ ^ m) (f' τ) := by
+    intro τ
+    have h1 := hasSum_qExpansion one_pos hper hhol hbd τ
+    have hinj : Function.Injective fun m : ℕ ↦ N * m := fun a b h ↦ by
+      simpa [Nat.mul_right_inj hN] using h
+    refine (hinj.hasSum_iff (f := fun m ↦ c m • Function.Periodic.qParam N τ ^ m) ?_).mp ?_
+    · intro x hx
+      have : ¬ N ∣ x := fun ⟨k, hk⟩ ↦ hx ⟨k, hk.symm⟩
+      simp [hc, this]
+    · refine h1.congr_fun fun m ↦ ?_
+      simp only [Function.comp_apply, hc, Nat.dvd_mul_right, ite_true,
+        Nat.mul_div_cancel_left _ (Nat.pos_of_ne_zero hN), qParam_one_eq_pow hN, ← pow_mul]
+  exact (qExpansion_coeff_unique f' hN' hfan hf n).symm
+
+end QKitA
+
+section RatCoeff
+
+p2m_open "UpperHalfPlane ModularForm SlashInvariantForm ModularFormClass CuspForm \
+  ModularForm.CuspForm EisensteinSeries"
+open scoped MatrixGroups ArithmeticFunction.sigma
+
+private lemma ratCoeff_mul {p q : PowerSeries ℂ}
+    (hp : ∀ n : ℕ, ∃ a : ℚ, p.coeff n = (a : ℂ)) (hq : ∀ n : ℕ, ∃ a : ℚ, q.coeff n = (a : ℂ)) :
+    ∀ n : ℕ, ∃ a : ℚ, (p * q).coeff n = (a : ℂ) := by
+  choose F hF using hp
+  choose G hG using hq
+  intro n
+  refine ⟨∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, F ij.1 * G ij.2, ?_⟩
+  rw [PowerSeries.coeff_mul]
+  push_cast
+  exact Finset.sum_congr rfl fun ij _ => by rw [hF, hG]
+
+private lemma ratCoeff_sub {p q : PowerSeries ℂ}
+    (hp : ∀ n : ℕ, ∃ a : ℚ, p.coeff n = (a : ℂ)) (hq : ∀ n : ℕ, ∃ a : ℚ, q.coeff n = (a : ℂ)) :
+    ∀ n : ℕ, ∃ a : ℚ, (p - q).coeff n = (a : ℂ) := by
+  intro n
+  obtain ⟨a, ha⟩ := hp n
+  obtain ⟨b, hb⟩ := hq n
+  exact ⟨a - b, by rw [map_sub, ha, hb]; push_cast; ring⟩
+
+private lemma ratCoeff_E {k : ℕ} (hk : 3 ≤ k) (hk2 : Even k) :
+    ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 (E hk)).coeff n = (q : ℂ) := by
+  intro n
+  rw [E_qExpansion_coeff hk hk2]
+  by_cases hn : n = 0
+  · exact ⟨1, by simp [hn]⟩
+  · refine ⟨-(2 * k / _root_.bernoulli k) * (σ (k - 1) n : ℚ), ?_⟩
+    rw [ite_eq_right hn]
+    push_cast
+    ring
+
+private lemma ratCoeff_pow {p : PowerSeries ℂ}
+    (hp : ∀ n : ℕ, ∃ a : ℚ, p.coeff n = (a : ℂ)) (k : ℕ) :
+    ∀ n : ℕ, ∃ a : ℚ, (p ^ k).coeff n = (a : ℂ) := by
+  induction k with
+  | zero =>
+    intro n
+    rw [pow_zero]
+    by_cases hn : n = 0
+    · exact ⟨1, by simp [hn, PowerSeries.coeff_one]⟩
+    · exact ⟨0, by simp [PowerSeries.coeff_one, hn]⟩
+  | succ k ih =>
+    rw [pow_succ]
+    exact ratCoeff_mul ih hp
+
+private def eCubeSubESq : ModularForm 𝒮ℒ 12 :=
+  ModularForm.mcast (by decide) (E₄.pow 3) - ModularForm.mcast (by decide) (E₆.pow 2)
+
+private lemma eCubeSubESq_qExpansion :
+    qExpansion 1 eCubeSubESq = qExpansion 1 E₄ * qExpansion 1 E₄ * qExpansion 1 E₄ -
+      qExpansion 1 E₆ * qExpansion 1 E₆ := by
+  simp only [eCubeSubESq, FunLike.coe_sub, ModularForm.coe_mcast,
+    ModularForm.qExpansion_sub one_pos one_mem_strictPeriods_SL,
+    ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+  ring
+
+private lemma discriminant_eq_smul_eCubeSubESq :
+    ModularForm.discriminant = (1 / 1728 : ℂ) • eCubeSubESq := by
+  ext z
+  have h := discriminant_eq_E₄_cube_sub_E₆_sq z
+  simp only [Pi.smul_apply, eCubeSubESq, FunLike.coe_sub, Pi.sub_apply,
+    ModularForm.coe_mcast, ModularForm.coe_pow, Pi.pow_apply, smul_eq_mul]
+  rw [h]
+  ring
+
+private lemma ratCoeff_discriminant :
+    ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 ModularForm.discriminant).coeff n = (q : ℂ) := by
+  have h4 : ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 E₄).coeff n = (q : ℂ) :=
+    ratCoeff_E (by norm_num) (by decide)
+  have h6 : ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 E₆).coeff n = (q : ℂ) :=
+    ratCoeff_E (by norm_num) (by decide)
+  have hmain := ratCoeff_sub (ratCoeff_mul (ratCoeff_mul h4 h4) h4) (ratCoeff_mul h6 h6)
+  intro n
+  obtain ⟨a, ha⟩ := hmain n
+  refine ⟨(1 / 1728 : ℚ) * a, ?_⟩
+  rw [discriminant_eq_smul_eCubeSubESq,
+    ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL,
+    PowerSeries.coeff_smul, eCubeSubESq_qExpansion, smul_eq_mul, ha]
+  push_cast
+  ring
+
+end RatCoeff
+
+section KPoleAlgebra
+
+open ModularForm
+
+variable {N : ℕ}
+
+private lemma mem_of_rat (K : IntermediateField ℚ ℂ) {x : ℂ} (h : ∃ q : ℚ, x = (q : ℂ)) :
+    x ∈ K := by
+  obtain ⟨q, rfl⟩ := h
+  exact SubfieldClass.ratCast_mem K q
+
+private def KPoleAt (K : IntermediateField ℚ ℂ) (N m : ℕ) (f : ℍ → ℂ) : Prop :=
+  Function.Periodic ((f * ⇑CuspForm.discriminant ^ m) ∘ ofComplex) N ∧
+    IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m) ∧
+    ∀ n : ℕ, (qExpansion N (f * ⇑CuspForm.discriminant ^ m)).coeff n ∈ K
+
+private def KPole (K : IntermediateField ℚ ℂ) (N : ℕ) (f : ℍ → ℂ) : Prop :=
+  MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f ∧ ∃ m : ℕ, KPoleAt K N m f
+
+private lemma qExpansion_discPow_coeff_mem (K : IntermediateField ℚ ℂ) [NeZero N] (k n : ℕ) :
+    (qExpansion N (⇑CuspForm.discriminant ^ k : ℍ → ℂ)).coeff n ∈ K := by
+  have hper : Function.Periodic
+      ((⇑CuspForm.discriminant ^ k : ℍ → ℂ) ∘ ofComplex) (1 : ℂ) := by
+    have h := periodic_discPow_comp_ofComplex k 1
+    simpa only [Nat.cast_one] using h
+  rw [qExpansion_coeff_width _ (NeZero.ne N) hper (mdiff_discPow k)
+    (isBoundedAtImInfty_discPow k), qExpansion_one_discPow]
+  split
+  · exact mem_of_rat K (ratCoeff_pow ratCoeff_discriminant k _)
+  · exact zero_mem _
+
+private lemma KPoleAt.pad {K : IntermediateField ℚ ℂ} [NeZero N] {f : ℍ → ℂ} {m m' : ℕ}
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) (hm : m ≤ m') (h : KPoleAt K N m f) :
+    KPoleAt K N m' f := by
+  obtain ⟨hper, hbd, hmem⟩ := h
+  have hshape : (f * ⇑CuspForm.discriminant ^ m' : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m) * ⇑CuspForm.discriminant ^ (m' - m) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply]
+    rw [mul_assoc, ← pow_add, Nat.add_sub_cancel' hm]
+  refine ⟨?_, ?_, ?_⟩
+  · rw [hshape]
+    exact hper.mul (periodic_discPow_comp_ofComplex (m' - m) N)
+  · exact IsBoundedAtImInfty.mul_discPow_mono hm hbd
+  · intro n
+    rw [hshape, qExpansion_mul
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hhol m) hper hbd)
+      (analyticAt_cuspFunction_zero_of (mdiff_discPow (m' - m))
+        (periodic_discPow_comp_ofComplex (m' - m) N) (isBoundedAtImInfty_discPow (m' - m))),
+      PowerSeries.coeff_mul]
+    exact sum_mem fun ij _ => mul_mem (hmem ij.1) (qExpansion_discPow_coeff_mem K _ ij.2)
+
+private lemma kPole_algebraMap {K : IntermediateField ℚ ℂ} [NeZero N] (c : ↥K) :
+    KPole K N (algebraMap ↥K (ℍ → ℂ) c) := by
+  have hshape : ((algebraMap ↥K (ℍ → ℂ) c) * ⇑CuspForm.discriminant ^ 0 : ℍ → ℂ) =
+      (c : ℂ) • (1 : ℍ → ℂ) := by
+    funext τ
+    simp only [Pi.mul_apply, pow_zero, mul_one, Pi.smul_apply, Pi.one_apply,
+      smul_eq_mul]
+    rfl
+  have hone_bd : IsBoundedAtImInfty (1 : ℍ → ℂ) := by
+    have h1 : (1 : ℍ → ℂ) = fun _ : ℍ => (1 : ℂ) := rfl
+    rw [h1]
+    exact Filter.const_boundedAtFilter _ _
+  refine ⟨mdifferentiable_const, 0, ?_, ?_, ?_⟩
+  · rw [hshape]
+    intro x
+    rfl
+  · rw [hshape]
+    have hc : ((c : ℂ) • (1 : ℍ → ℂ)) = fun _ : ℍ => (c : ℂ) := by
+      funext τ
+      simp
+    rw [hc]
+    exact Filter.const_boundedAtFilter _ _
+  · intro n
+    have han : AnalyticAt ℂ (cuspFunction N (1 : ℍ → ℂ)) 0 :=
+      analyticAt_cuspFunction_zero_of (g := (1 : ℍ → ℂ)) mdifferentiable_const
+        (periodic_one_fn N) hone_bd
+    rw [hshape, qExpansion_smul han,
+      qExpansion_one, PowerSeries.coeff_smul, smul_eq_mul, PowerSeries.coeff_one]
+    split
+    · rw [mul_one]
+      exact c.2
+    · rw [mul_zero]
+      exact zero_mem _
+
+private lemma KPole.add {K : IntermediateField ℚ ℂ} [NeZero N] {f g : ℍ → ℂ}
+    (hf : KPole K N f) (hg : KPole K N g) : KPole K N (f + g) := by
+  obtain ⟨hf1, m1, hfd⟩ := hf
+  obtain ⟨hg1, m2, hgd⟩ := hg
+  obtain ⟨hfper, hfbd, hfmem⟩ := hfd.pad hf1 (le_max_left m1 m2)
+  obtain ⟨hgper, hgbd, hgmem⟩ := hgd.pad hg1 (le_max_right m1 m2)
+  have hshape : ((f + g) * ⇑CuspForm.discriminant ^ max m1 m2 : ℍ → ℂ) =
+      f * ⇑CuspForm.discriminant ^ max m1 m2 + g * ⇑CuspForm.discriminant ^ max m1 m2 := by
+    funext τ
+    simp [add_mul]
+  refine ⟨hf1.add hg1, max m1 m2, ?_, ?_, ?_⟩
+  · rw [hshape]
+    exact hfper.add hgper
+  · rw [hshape]
+    exact hfbd.add hgbd
+  · intro n
+    rw [hshape, qExpansion_add
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hf1 _) hfper hfbd)
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hg1 _) hgper hgbd),
+      map_add]
+    exact add_mem (hfmem n) (hgmem n)
+
+private lemma KPole.mul {K : IntermediateField ℚ ℂ} [NeZero N] {f g : ℍ → ℂ}
+    (hf : KPole K N f) (hg : KPole K N g) : KPole K N (f * g) := by
+  obtain ⟨hf1, m1, hfper, hfbd, hfmem⟩ := hf
+  obtain ⟨hg1, m2, hgper, hgbd, hgmem⟩ := hg
+  have hshape : ((f * g) * ⇑CuspForm.discriminant ^ (m1 + m2) : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m1) * (g * ⇑CuspForm.discriminant ^ m2) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply, pow_add]
+    ring
+  refine ⟨hf1.mul hg1, m1 + m2, ?_, ?_, ?_⟩
+  · rw [hshape]
+    exact hfper.mul hgper
+  · rw [hshape]
+    exact hfbd.mul hgbd
+  · intro n
+    rw [hshape, qExpansion_mul
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hf1 _) hfper hfbd)
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hg1 _) hgper hgbd),
+      PowerSeries.coeff_mul]
+    exact sum_mem fun ij _ => mul_mem (hfmem ij.1) (hgmem ij.2)
+
+private lemma kPole_jf (K : IntermediateField ℚ ℂ) [NeZero N] {jf : ℍ → ℂ}
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) :
+    KPole K N jf := by
+  have hshape : (jf * ⇑CuspForm.discriminant ^ 1 : ℍ → ℂ) = ⇑(ModularForm.E₄.pow 3) := by
+    funext τ
+    rw [congrFun (ModularForm.coe_pow ModularForm.E₄ 3) τ, Pi.pow_apply]
+    simp only [Pi.mul_apply, pow_one, hjf τ]
+    rw [congrFun CuspForm.coe_discriminant τ]
+    exact div_mul_cancel₀ _ (ModularForm.discriminant_ne_zero τ)
+  have hhol3 : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (⇑(ModularForm.E₄.pow 3) : ℍ → ℂ) :=
+    (ModularForm.E₄.pow 3).holo'
+  have hbd3 : IsBoundedAtImInfty (⇑(ModularForm.E₄.pow 3) : ℍ → ℂ) :=
+    ModularFormClass.bdd_at_infty (ModularForm.E₄.pow 3)
+  have hper3 : Function.Periodic ((⇑(ModularForm.E₄.pow 3) : ℍ → ℂ) ∘ ofComplex) 1 :=
+    SlashInvariantFormClass.periodic_comp_ofComplex (ModularForm.E₄.pow 3)
+      one_mem_strictPeriods_SL
+  have hjmd : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) jf := by
+    have : jf = fun τ => ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ := funext hjf
+    rw [this]
+    exact (ModularForm.E₄.holo'.pow 3).div CuspForm.discriminant.holo'
+      ModularForm.discriminant_ne_zero
+  refine ⟨hjmd, 1, ?_, ?_, ?_⟩
+  · rw [hshape]
+    simpa using hper3.nat_mul N
+  · rw [hshape]
+    exact hbd3
+  · intro n
+    rw [hshape, qExpansion_coeff_width (⇑(ModularForm.E₄.pow 3) : ℍ → ℂ) (NeZero.ne N)
+      hper3 hhol3 hbd3]
+    split
+    · have he : qExpansion 1 (⇑(ModularForm.E₄.pow 3) : ℍ → ℂ) =
+          (qExpansion 1 ModularForm.E₄) ^ 3 :=
+        ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL ModularForm.E₄ 3
+      rw [he]
+      exact mem_of_rat K (ratCoeff_pow (ratCoeff_E (by norm_num) (by decide)) 3 _)
+    · exact zero_mem _
+
+end KPoleAlgebra
+
+section QKitB
+
+open ModularForm
+
+variable {N : ℕ} {K : IntermediateField ℚ ℂ}
+
+private theorem mdifferentiable_eq_zero_or_eq_zero_of_mul_eq_zero {f g : ℍ → ℂ}
+    (hf : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) (hg : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hfg : f * g = 0) : f = 0 ∨ g = 0 := by
+  rw [UpperHalfPlane.mdifferentiable_iff] at hf hg
+  have hU : IsOpen {z : ℂ | 0 < z.im} := isOpen_upperHalfPlaneSet
+  have key := AnalyticOnNhd.eq_zero_or_eq_zero_of_mul_eq_zero (hf.analyticOnNhd hU)
+    (hg.analyticOnNhd hU) (fun z hz ↦ by
+      have := congrFun hfg (ofComplex z)
+      simpa using this) (convex_halfSpace_im_gt 0).isPreconnected
+  rcases key with k | k
+  · left; funext τ; simpa [ofComplex_apply] using k (τ : ℂ) τ.im_pos
+  · right; funext τ; simpa [ofComplex_apply] using k (τ : ℂ) τ.im_pos
+
+end QKitB
+
+section AevalKit
+
+open ModularForm
+
+variable {N : ℕ} {K : IntermediateField ℚ ℂ}
+
+private lemma kPole_fricke [NeZero N] {fricke : (Fin 2 → ZMod N) → ℍ → ℂ}
+    {v : Fin 2 → ZMod N}
+    (hmd : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fricke v))
+    (hper : Function.Periodic ((fricke v * ModularForm.discriminant ^ 1) ∘
+      UpperHalfPlane.ofComplex) N)
+    (hbd : IsBoundedAtImInfty (fricke v * ModularForm.discriminant ^ 1))
+    (hmem : ∀ n : ℕ, (qExpansion N (fricke v * ModularForm.discriminant ^ 1)).coeff n ∈ K) :
+    KPole K N (fricke v) := by
+  have hsh : (fricke v * ⇑CuspForm.discriminant ^ 1 : ℍ → ℂ) =
+      fricke v * ModularForm.discriminant ^ 1 := by
+    funext τ
+    simp only [Pi.mul_apply, pow_one]
+    rw [congrFun CuspForm.coe_discriminant τ]
+  exact ⟨hmd, 1, by rw [hsh]; exact hper, by rw [hsh]; exact hbd, by rw [hsh]; exact hmem⟩
+
+private lemma kPole_aeval [NeZero N]
+    {fricke : (Fin 2 → ZMod N) → ℍ → ℂ} {jf : ℍ → ℂ}
+    (hkjf : KPole K N jf)
+    (hkfr : ∀ v : {v : Fin 2 → ZMod N // v ≠ 0}, KPole K N (fricke v.1))
+    (p : MvPolynomial (Option {v : Fin 2 → ZMod N // v ≠ 0}) ↥K) :
+    KPole K N (MvPolynomial.aeval
+      (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} => o.elim jf fun v => fricke v.1)
+      (p.map (algebraMap ↥K ℂ))) := by
+  induction p using MvPolynomial.induction_on with
+  | C c =>
+    rw [MvPolynomial.map_C, MvPolynomial.aeval_C]
+    have htower : (algebraMap ℂ (ℍ → ℂ)) ((algebraMap ↥K ℂ) c) =
+        algebraMap ↥K (ℍ → ℂ) c := by
+      rw [← IsScalarTower.algebraMap_apply]
+    rw [htower]
+    exact kPole_algebraMap c
+  | add p q hp hq =>
+    rw [map_add, map_add]
+    exact KPole.add hp hq
+  | mul_X p o hp =>
+    rw [map_mul, MvPolynomial.map_X, map_mul, MvPolynomial.aeval_X]
+    refine KPole.mul hp ?_
+    cases o with
+    | none => exact hkjf
+    | some v => exact hkfr v
+
+end AevalKit
+
+end WLight
+
+open _root_.WLight _root_.P2MW.S_WLight_exists_monicRel_j_K_of_mdifferentiable_frickeQuotient.WLight
+  WLight.R8cGlue in
+theorem solution
+    (N : ℕ) [NeZero N]
+    (L : ℍ → PeriodPair) (hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), W v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (jf : ℍ → ℂ)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    (K : IntermediateField ℚ ℂ)
+    (hK : K = IntermediateField.adjoin ℚ
+      {Complex.exp (2 * (Real.pi : ℂ) * Complex.I / (N : ℂ))})
+    (G : ℍ → ℂ) (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (P₀ Q₀ : MvPolynomial (Option {v : Fin 2 → ZMod N // v ≠ 0}) ↥K)
+    (hQ0 : MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+      o.elim jf fun v => fricke v.1) (Q₀.map (algebraMap ↥K ℂ)) ≠ 0)
+    (hGQ : G * MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+        o.elim jf fun v => fricke v.1) (Q₀.map (algebraMap ↥K ℂ)) =
+      MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+        o.elim jf fun v => fricke v.1) (P₀.map (algebraMap ↥K ℂ)))
+    :
+    ∃ (d : ℕ) (p : Fin d → Polynomial ℂ), (∀ (i : Fin d) (n : ℕ), (p i).coeff n ∈ K) ∧
+      ∀ τ : ℍ, G τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * G τ ^ (i : ℕ) = 0 := by
+  have hR6h3 : ∀ {a b F : ℍ → ℂ},
+      a ∈ Algebra.adjoin ℂ
+        (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}) →
+      b ∈ Algebra.adjoin ℂ
+        (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}) →
+      b ≠ 0 → MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F → F * b = a →
+      (∀ γ : Matrix.SpecialLinearGroup (Fin 2) ℤ, ∃ m : ℕ,
+        IsBoundedAtImInfty ((F ∘ (γ • ·)) * ModularForm.discriminant ^ m)) →
+      ∃ (d : ℕ) (p : Fin d → Polynomial ℂ), ∀ τ : ℍ,
+        F τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * F τ ^ (i : ℕ) = 0 :=
+    fun ha hb hb0 hF hFb hpb =>
+      exists_monicRel_j_of_mdifferentiable_levelFraction N L hL W hW fricke hfricke jf hjf
+        ha hb hb0 hF hFb hpb
+  have hR7a : ∀ {ι : Type} (f : ι → ℍ → ℂ),
+      (∀ i, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (f i) ∧ ∃ m : ℕ,
+        Function.Periodic ((f i * ModularForm.discriminant ^ m) ∘
+          UpperHalfPlane.ofComplex) N ∧
+        IsBoundedAtImInfty (f i * ModularForm.discriminant ^ m) ∧
+        ∀ n : ℕ, (UpperHalfPlane.qExpansion N
+          (f i * ModularForm.discriminant ^ m)).coeff n ∈ K) →
+      LinearIndependent ↥K f → LinearIndependent ℂ f :=
+    fun f hf hli => UpperHalfPlane.linearIndependent_complex_of_qExpansion_coeff_mem N K f hf hli
+  have hR4b12 : (MDifferentiable 𝓘(ℂ) 𝓘(ℂ) jf ∧
+        ∃ m : ℕ, IsBoundedAtImInfty (jf * ModularForm.discriminant ^ m)) ∧
+      (∀ v : Fin 2 → ZMod N, v ≠ 0 → MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fricke v) ∧
+        ∃ m : ℕ, IsBoundedAtImInfty (fricke v * ModularForm.discriminant ^ m)) :=
+    ⟨(frickeFunction_orbit_package N L hL W hW fricke hfricke jf hjf).1,
+      (frickeFunction_orbit_package N L hL W hW fricke hfricke jf hjf).2.1⟩
+  have hfeq : fricke = fun a τ =>
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 *
+        (((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+          PeriodPair.weierstrassP (L τ)
+            ((((a 0).val : ℂ) * (τ : ℂ) + ((a 1).val : ℂ)) / (N : ℂ))) := by
+    funext a τ; rw [hfricke, hW]
+  have hR4a := frickeFunction_modularity_package N L hL
+  dsimp only at hR4a
+  have hR4c : ∀ (v : Fin 2 → ZMod N) (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) (τ : ℍ),
+      fricke v (γ • τ) = fricke (Matrix.vecMul v
+        ((Matrix.SpecialLinearGroup.map (Int.castRingHom (ZMod N)) γ :
+          Matrix.SpecialLinearGroup (Fin 2) (ZMod N)) : Matrix (Fin 2) (Fin 2) (ZMod N))) τ := by
+    intro v γ τ; rw [hfeq]; exact hR4a.1 v γ τ
+  have hQrat : ∀ v : Fin 2 → ZMod N, v ≠ 0 →
+      Function.Periodic ((fricke v * ModularForm.discriminant ^ 1) ∘
+        UpperHalfPlane.ofComplex) N ∧
+      IsBoundedAtImInfty (fricke v * ModularForm.discriminant ^ 1) ∧
+      ∀ n : ℕ, (UpperHalfPlane.qExpansion N
+        (fricke v * ModularForm.discriminant ^ 1)).coeff n ∈ K := by
+    intro v hv; rw [pow_one, hfeq, hK]
+    exact ⟨(hR4a.2.2.2.2.1 v hv).1, hR4a.2.2.2.1 v hv, (hR4a.2.2.2.2.1 v hv).2⟩
+  clear hR4a
+  classical
+  set gen : Option {v : Fin 2 → ZMod N // v ≠ 0} → ℍ → ℂ :=
+    fun o => o.elim jf fun v => fricke v.1 with hgen
+  set Pt : ℍ → ℂ := MvPolynomial.aeval gen (P₀.map (algebraMap ↥K ℂ)) with hPt
+  set Qt : ℍ → ℂ := MvPolynomial.aeval gen (Q₀.map (algebraMap ↥K ℂ)) with hQt
+  have hkjf : KPole K N jf := kPole_jf K hjf
+  have hkfr : ∀ v : {v : Fin 2 → ZMod N // v ≠ 0}, KPole K N (fricke v.1) := fun v =>
+    kPole_fricke ((hR4b12.2 v.1 v.2).1) (hQrat v.1 v.2).1 (hQrat v.1 v.2).2.1
+      (hQrat v.1 v.2).2.2
+  have hkA : ∀ r : MvPolynomial (Option {v : Fin 2 → ZMod N // v ≠ 0}) ↥K,
+      KPole K N (MvPolynomial.aeval gen (r.map (algebraMap ↥K ℂ))) := fun r =>
+    kPole_aeval hkjf hkfr r
+  have hrange : Set.range gen =
+      insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v} := by
+    ext g
+    constructor
+    · rintro ⟨o, rfl⟩
+      cases o with
+      | none => exact Set.mem_insert _ _
+      | some v => exact Set.mem_insert_of_mem _ ⟨v.1, v.2, rfl⟩
+    · rintro (rfl | ⟨v, hv, rfl⟩)
+      · exact ⟨none, rfl⟩
+      · exact ⟨some ⟨v, hv⟩, rfl⟩
+  have hmemA : ∀ r : MvPolynomial (Option {v : Fin 2 → ZMod N // v ≠ 0}) ℂ,
+      MvPolynomial.aeval gen r ∈ Algebra.adjoin ℂ
+        (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}) := by
+    intro r
+    rw [← hrange, Algebra.adjoin_range_eq_range_aeval]
+    exact ⟨r, rfl⟩
+  have hpb := R8cGlue.isBoundedAtImInfty_smul_quotient_of_aeval N L hL W hW fricke hfricke
+    jf hjf K hK hR4c hR4b12 hG P₀ Q₀ hQ0 hGQ
+  obtain ⟨d, p, hrel⟩ := hR6h3 (hmemA (P₀.map (algebraMap ↥K ℂ)))
+    (hmemA (Q₀.map (algebraMap ↥K ℂ))) hQ0 hG hGQ hpb
+  rcases Nat.eq_zero_or_pos d with hd0 | hdpos
+  · exfalso
+    have h0 := hrel ⟨Complex.I, by simp⟩
+    subst hd0
+    simp at h0
+  have hGQτ : ∀ τ : ℍ, G τ * Qt τ = Pt τ := fun τ => by
+    have := congrFun hGQ τ
+    simpa using this
+  have hpow : ∀ (τ : ℍ) (k : ℕ), G τ ^ k * Qt τ ^ k = Pt τ ^ k := fun τ k => by
+    rw [← mul_pow, hGQτ τ]
+  set D : ℕ := (Finset.univ.sup fun i : Fin d => (p i).natDegree) + 1 with hD
+  have hdeg : ∀ i : Fin d, (p i).natDegree < D := fun i =>
+    Nat.lt_succ_of_le (Finset.le_sup (f := fun i : Fin d => (p i).natDegree)
+      (Finset.mem_univ i))
+  have hcleared : ∀ τ : ℍ, Pt τ ^ d + ∑ i : Fin d, ∑ k ∈ Finset.range D,
+      (p i).coeff k * (jf τ ^ k * (Qt τ ^ (d - (i : ℕ)) * Pt τ ^ (i : ℕ))) = 0 := by
+    intro τ
+    have h1 : (G τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * G τ ^ (i : ℕ)) * Qt τ ^ d = 0 := by
+      rw [hrel τ, zero_mul]
+    rw [add_mul, Finset.sum_mul] at h1
+    have hterm : ∀ i : Fin d, (p i).eval (jf τ) * G τ ^ (i : ℕ) * Qt τ ^ d =
+        ∑ k ∈ Finset.range D,
+          (p i).coeff k * (jf τ ^ k * (Qt τ ^ (d - (i : ℕ)) * Pt τ ^ (i : ℕ))) := by
+      intro i
+      rw [Polynomial.eval_eq_sum_range' (hdeg i), Finset.sum_mul, Finset.sum_mul]
+      refine Finset.sum_congr rfl fun k _ => ?_
+      have hsplit : Qt τ ^ d = Qt τ ^ (d - (i : ℕ)) * Qt τ ^ (i : ℕ) := by
+        rw [← pow_add, Nat.sub_add_cancel (le_of_lt i.2)]
+      rw [hsplit]
+      linear_combination (p i).coeff k * jf τ ^ k * Qt τ ^ (d - (i : ℕ)) * hpow τ (i : ℕ)
+    calc Pt τ ^ d + ∑ i : Fin d, ∑ k ∈ Finset.range D,
+          (p i).coeff k * (jf τ ^ k * (Qt τ ^ (d - (i : ℕ)) * Pt τ ^ (i : ℕ)))
+        = G τ ^ d * Qt τ ^ d +
+            ∑ i : Fin d, (p i).eval (jf τ) * G τ ^ (i : ℕ) * Qt τ ^ d := by
+          rw [hpow τ d]
+          exact congrArg₂ (· + ·) rfl
+            (Finset.sum_congr rfl fun i _ => (hterm i).symm)
+      _ = 0 := h1
+  set u : Option (Fin d × Fin D) → ℍ → ℂ := fun o => o.elim
+    (MvPolynomial.aeval gen ((P₀ ^ d).map (algebraMap ↥K ℂ)))
+    (fun ik => MvPolynomial.aeval gen
+      ((MvPolynomial.X none ^ (ik.2 : ℕ) *
+        (Q₀ ^ (d - (ik.1 : ℕ)) * P₀ ^ (ik.1 : ℕ))).map (algebraMap ↥K ℂ))) with hu
+  have hu_top : ∀ τ : ℍ, u none τ = Pt τ ^ d := by
+    intro τ
+    simp only [hu, Option.elim, map_pow, Pi.pow_apply, hPt]
+  have hu_mon : ∀ (ik : Fin d × Fin D) (τ : ℍ), u (some ik) τ =
+      jf τ ^ (ik.2 : ℕ) * (Qt τ ^ (d - (ik.1 : ℕ)) * Pt τ ^ (ik.1 : ℕ)) := by
+    intro ik τ
+    simp only [hu, Option.elim, map_mul, map_pow, MvPolynomial.map_X,
+      MvPolynomial.aeval_X, Pi.mul_apply, Pi.pow_apply, hPt, hQt, hgen]
+  have hkU : ∀ o, KPole K N (u o) := by
+    intro o
+    cases o with
+    | none => exact hkA _
+    | some ik => exact hkA _
+  set lam : Fin d × Fin D → ℂ := fun ik => (p ik.1).coeff ik.2 with hlam
+  have hfunrel : u none + ∑ ik : Fin d × Fin D, lam ik • u (some ik) = 0 := by
+    funext τ
+    simp only [Pi.add_apply, Finset.sum_apply, Pi.smul_apply, smul_eq_mul, Pi.zero_apply]
+    rw [hu_top τ]
+    have hsum : ∑ ik : Fin d × Fin D, lam ik * u (some ik) τ =
+        ∑ i : Fin d, ∑ k ∈ Finset.range D,
+          (p i).coeff k * (jf τ ^ k * (Qt τ ^ (d - (i : ℕ)) * Pt τ ^ (i : ℕ))) := by
+      rw [Fintype.sum_prod_type]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [Finset.sum_range fun k => (p i).coeff k *
+        (jf τ ^ k * (Qt τ ^ (d - (i : ℕ)) * Pt τ ^ (i : ℕ)))]
+      refine Finset.sum_congr rfl fun k _ => ?_
+      rw [hu_mon (i, k) τ, hlam]
+    rw [hsum]
+    exact hcleared τ
+  obtain ⟨b, hbsub, hbspan, hbind⟩ := exists_linearIndependent ↥K (Set.range u)
+  have hbfin : b.Finite := (Set.finite_range u).subset hbsub
+  have : Fintype ↥b := hbfin.fintype
+  have hdata : ∀ w : ↥b, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) ((w : ℍ → ℂ)) ∧ ∃ m : ℕ,
+      Function.Periodic (((w : ℍ → ℂ) * ModularForm.discriminant ^ m) ∘
+        UpperHalfPlane.ofComplex) N ∧
+      IsBoundedAtImInfty ((w : ℍ → ℂ) * ModularForm.discriminant ^ m) ∧
+      ∀ n : ℕ, (UpperHalfPlane.qExpansion N
+        ((w : ℍ → ℂ) * ModularForm.discriminant ^ m)).coeff n ∈ K := by
+    intro w
+    obtain ⟨o, ho⟩ := hbsub w.2
+    obtain ⟨hmd, m, hper, hbd, hmem⟩ := ho ▸ hkU o
+    have hsh : ((w : ℍ → ℂ) * ⇑CuspForm.discriminant ^ m : ℍ → ℂ) =
+        (w : ℍ → ℂ) * ModularForm.discriminant ^ m := by
+      funext τ
+      simp only [Pi.mul_apply, Pi.pow_apply]
+      rw [congrFun CuspForm.coe_discriminant τ]
+    rw [hsh] at hper hbd hmem
+    exact ⟨hmd, m, hper, hbd, hmem⟩
+  have hCind : LinearIndependent ℂ (fun w : ↥b => (w : ℍ → ℂ)) :=
+    hR7a (fun w : ↥b => (w : ℍ → ℂ)) hdata hbind
+  have hcoords : ∀ o, ∃ c : ↥b → ↥K, ∑ w : ↥b, c w • (w : ℍ → ℂ) = u o := by
+    intro o
+    have h1 : u o ∈ Submodule.span ↥K (Set.range ((↑) : b → ℍ → ℂ)) := by
+      rw [Subtype.range_coe, hbspan]
+      exact Submodule.subset_span (Set.mem_range_self o)
+    exact (Submodule.mem_span_range_iff_exists_fun ↥K).mp h1
+  choose co hco using hcoords
+  have hKsmul : ∀ (c : ↥K) (g : ℍ → ℂ), c • g = (c : ℂ) • g := fun c g =>
+    (algebraMap_smul ℂ c g).symm
+  have hpiece : ∀ o, ∑ w : ↥b, (co o w : ℂ) • (w : ℍ → ℂ) = u o := by
+    intro o
+    rw [← hco o]
+    exact Finset.sum_congr rfl fun w _ => (hKsmul _ _).symm
+  have hsys : ∀ w : ↥b, (co none w : ℂ) +
+      ∑ ik : Fin d × Fin D, lam ik * (co (some ik) w : ℂ) = 0 := by
+    have hcomb : ∑ w : ↥b, ((co none w : ℂ) +
+        ∑ ik : Fin d × Fin D, lam ik * (co (some ik) w : ℂ)) • (w : ℍ → ℂ) = 0 := by
+      have hstep : ∑ w : ↥b, ((co none w : ℂ) +
+          ∑ ik : Fin d × Fin D, lam ik * (co (some ik) w : ℂ)) • (w : ℍ → ℂ) =
+          ∑ w : ↥b, (co none w : ℂ) • (w : ℍ → ℂ) +
+          ∑ ik : Fin d × Fin D, lam ik •
+            ∑ w : ↥b, (co (some ik) w : ℂ) • (w : ℍ → ℂ) := by
+        simp only [add_smul, Finset.sum_smul, mul_smul]
+        rw [Finset.sum_add_distrib]
+        congr 1
+        rw [Finset.sum_comm]
+        exact Finset.sum_congr rfl fun ik _ => (Finset.smul_sum).symm
+      rw [hstep, hpiece none]
+      rw [Finset.sum_congr rfl fun ik _ => congrArg (lam ik • ·) (hpiece (some ik))]
+      exact hfunrel
+    intro w
+    exact (Fintype.linearIndependent_iff.mp hCind) _ hcomb w
+  set em : (Fin d × Fin D) ≃ Fin (Fintype.card (Fin d × Fin D)) :=
+    Fintype.equivFin (Fin d × Fin D) with hem
+  set eb : ↥b ≃ Fin (Fintype.card ↥b) := Fintype.equivFin ↥b with heb
+  obtain ⟨y0, hy0⟩ := exists_K_point_of_C_point K
+    (A := fun j i => co (some (em.symm i)) (eb.symm j))
+    (bv := fun j => - co none (eb.symm j))
+    (x := fun i => lam (em.symm i))
+    (by
+      intro j
+      have h0 := hsys (eb.symm j)
+      calc ∑ i, ((co (some (em.symm i)) (eb.symm j) : ↥K) : ℂ) * lam (em.symm i)
+          = ∑ ik : Fin d × Fin D, (co (some ik) (eb.symm j) : ℂ) * lam ik :=
+            Equiv.sum_comp em.symm fun ik => (co (some ik) (eb.symm j) : ℂ) * lam ik
+        _ = ∑ ik : Fin d × Fin D, lam ik * (co (some ik) (eb.symm j) : ℂ) :=
+            Finset.sum_congr rfl fun ik _ => mul_comm _ _
+        _ = ((- co none (eb.symm j) : ↥K) : ℂ) := by
+            push_cast
+            linear_combination h0)
+  set y : Fin d × Fin D → ↥K := fun ik => y0 (em ik) with hy
+  have hyK : ∀ w : ↥b, co none w + ∑ ik : Fin d × Fin D, co (some ik) w * y ik = 0 := by
+    intro w
+    have h0 := hy0 (eb w)
+    simp only [Equiv.symm_apply_apply] at h0
+    have hre : ∑ ik : Fin d × Fin D, co (some ik) w * y ik =
+        ∑ i, co (some (em.symm i)) w * y0 i := by
+      rw [← Equiv.sum_comp em.symm (fun ik => co (some ik) w * y ik)]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [hy]
+      simp only [Equiv.apply_symm_apply]
+    rw [hre, h0]
+    ring
+  set p' : Fin d → Polynomial ℂ := fun i =>
+    ∑ k : Fin D, Polynomial.C ((y (i, k) : ↥K) : ℂ) * Polynomial.X ^ (k : ℕ) with hp'
+  have hp'coeff : ∀ (i : Fin d) (n : ℕ), (p' i).coeff n ∈ K := by
+    intro i n
+    rw [hp', Polynomial.finsetSum_coeff]
+    refine sum_mem fun k _ => ?_
+    rw [Polynomial.coeff_C_mul, Polynomial.coeff_X_pow]
+    split
+    · rw [mul_one]
+      exact SetLike.coe_mem _
+    · rw [mul_zero]
+      exact zero_mem _
+  have hp'eval : ∀ (i : Fin d) (z : ℂ),
+      (p' i).eval z = ∑ k : Fin D, ((y (i, k) : ↥K) : ℂ) * z ^ (k : ℕ) := by
+    intro i z
+    rw [hp', Polynomial.eval_finsetSum]
+    refine Finset.sum_congr rfl fun k _ => ?_
+    rw [Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_pow, Polynomial.eval_X]
+  have hKfun : u none + ∑ ik : Fin d × Fin D, ((y ik : ↥K) : ℂ) • u (some ik) = 0 := by
+    calc u none + ∑ ik : Fin d × Fin D, ((y ik : ↥K) : ℂ) • u (some ik)
+        = ∑ w : ↥b, ((co none w : ℂ) +
+            ∑ ik : Fin d × Fin D, (co (some ik) w : ℂ) * ((y ik : ↥K) : ℂ)) •
+              (w : ℍ → ℂ) := by
+          rw [← hpiece none,
+            Finset.sum_congr rfl fun ik _ =>
+              congrArg (((y ik : ↥K) : ℂ) • ·) (hpiece (some ik)).symm]
+          simp only [Finset.smul_sum]
+          rw [Finset.sum_comm, ← Finset.sum_add_distrib]
+          refine Finset.sum_congr rfl fun w _ => ?_
+          rw [add_smul, Finset.sum_smul]
+          congr 1
+          refine Finset.sum_congr rfl fun ik _ => ?_
+          rw [smul_smul, mul_comm]
+      _ = 0 := by
+          refine Finset.sum_eq_zero fun w _ => ?_
+          have h3 : (co none w : ℂ) +
+              ∑ ik : Fin d × Fin D, (co (some ik) w : ℂ) * ((y ik : ↥K) : ℂ) = 0 := by
+            exact_mod_cast congrArg (fun z : ↥K => (z : ℂ)) (hyK w)
+          rw [h3, zero_smul]
+  have hfinal0 : ∀ τ : ℍ, Pt τ ^ d + ∑ ik : Fin d × Fin D,
+      ((y ik : ↥K) : ℂ) * (jf τ ^ (ik.2 : ℕ) *
+        (Qt τ ^ (d - (ik.1 : ℕ)) * Pt τ ^ (ik.1 : ℕ))) = 0 := by
+    intro τ
+    have h0 := congrFun hKfun τ
+    simp only [Pi.add_apply, Finset.sum_apply, Pi.smul_apply, smul_eq_mul,
+      Pi.zero_apply] at h0
+    rw [hu_top τ] at h0
+    have hsum2 : ∑ ik : Fin d × Fin D, ((y ik : ↥K) : ℂ) * u (some ik) τ =
+        ∑ ik : Fin d × Fin D, ((y ik : ↥K) : ℂ) * (jf τ ^ (ik.2 : ℕ) *
+          (Qt τ ^ (d - (ik.1 : ℕ)) * Pt τ ^ (ik.1 : ℕ))) :=
+      Finset.sum_congr rfl fun ik _ => by rw [hu_mon ik τ]
+    rw [hsum2] at h0
+    exact h0
+  have hback : ∀ τ : ℍ,
+      (G τ ^ d + ∑ i : Fin d, (p' i).eval (jf τ) * G τ ^ (i : ℕ)) * Qt τ ^ d = 0 := by
+    intro τ
+    have hterm : ∀ i : Fin d, (p' i).eval (jf τ) * G τ ^ (i : ℕ) * Qt τ ^ d =
+        ∑ k : Fin D, ((y (i, k) : ↥K) : ℂ) * (jf τ ^ (k : ℕ) *
+          (Qt τ ^ (d - (i : ℕ)) * Pt τ ^ (i : ℕ))) := by
+      intro i
+      rw [hp'eval, Finset.sum_mul, Finset.sum_mul]
+      refine Finset.sum_congr rfl fun k _ => ?_
+      have hsplit : Qt τ ^ d = Qt τ ^ (d - (i : ℕ)) * Qt τ ^ (i : ℕ) := by
+        rw [← pow_add, Nat.sub_add_cancel (le_of_lt i.2)]
+      rw [hsplit]
+      linear_combination ((y (i, k) : ↥K) : ℂ) * jf τ ^ (k : ℕ) *
+        Qt τ ^ (d - (i : ℕ)) * hpow τ (i : ℕ)
+    rw [add_mul, Finset.sum_mul, hpow τ d,
+      Finset.sum_congr rfl fun i _ => hterm i]
+    have h0 := hfinal0 τ
+    rw [Fintype.sum_prod_type] at h0
+    exact h0
+  have hQtmd : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) Qt := (hkA Q₀).1
+  have hjfmd : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) jf := hR4b12.1.1
+  have hhmd : MDifferentiable 𝓘(ℂ) 𝓘(ℂ)
+      (fun τ => G τ ^ d + ∑ i : Fin d, (p' i).eval (jf τ) * G τ ^ (i : ℕ)) := by
+    have hsummd : ∀ i : Fin d, MDifferentiable 𝓘(ℂ) 𝓘(ℂ)
+        (fun τ => (p' i).eval (jf τ) * G τ ^ (i : ℕ)) := by
+      intro i
+      have hev : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fun τ => (p' i).eval (jf τ)) := by
+        have hsh : (fun τ => (p' i).eval (jf τ)) =
+            fun τ => ∑ k : Fin D, ((y (i, k) : ↥K) : ℂ) * jf τ ^ (k : ℕ) := by
+          funext τ
+          rw [hp'eval]
+        rw [hsh]
+        have : ∀ s : Finset (Fin D), MDifferentiable 𝓘(ℂ) 𝓘(ℂ)
+            (fun τ => ∑ k ∈ s, ((y (i, k) : ↥K) : ℂ) * jf τ ^ (k : ℕ)) := by
+          intro s
+          induction s using Finset.induction_on with
+          | empty => simpa using mdifferentiable_const
+          | insert a t ha ih =>
+            have hsh2 : (fun τ => ∑ k ∈ insert a t,
+                ((y (i, k) : ↥K) : ℂ) * jf τ ^ (k : ℕ)) =
+                (fun τ => ((y (i, a) : ↥K) : ℂ) * jf τ ^ (a : ℕ)) +
+                fun τ => ∑ k ∈ t, ((y (i, k) : ↥K) : ℂ) * jf τ ^ (k : ℕ) := by
+              funext τ
+              simp [Finset.sum_insert ha]
+            rw [hsh2]
+            exact (mdifferentiable_const.mul (hjfmd.pow _)).add ih
+        exact this Finset.univ
+      exact hev.mul (hG.pow _)
+    have : ∀ s : Finset (Fin d), MDifferentiable 𝓘(ℂ) 𝓘(ℂ)
+        (fun τ => ∑ i ∈ s, (p' i).eval (jf τ) * G τ ^ (i : ℕ)) := by
+      intro s
+      induction s using Finset.induction_on with
+      | empty => simpa using mdifferentiable_const
+      | insert a t ha ih =>
+        have hsh2 : (fun τ => ∑ i ∈ insert a t, (p' i).eval (jf τ) * G τ ^ (i : ℕ)) =
+            (fun τ => (p' a).eval (jf τ) * G τ ^ (a : ℕ)) +
+            fun τ => ∑ i ∈ t, (p' i).eval (jf τ) * G τ ^ (i : ℕ) := by
+          funext τ
+          simp [Finset.sum_insert ha]
+        rw [hsh2]
+        exact (hsummd a).add ih
+    exact (hG.pow d).add (this Finset.univ)
+  have hmul0 : ((fun τ => G τ ^ d + ∑ i : Fin d, (p' i).eval (jf τ) * G τ ^ (i : ℕ)) *
+      Qt ^ d : ℍ → ℂ) = 0 := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply, Pi.zero_apply]
+    exact hback τ
+  rcases mdifferentiable_eq_zero_or_eq_zero_of_mul_eq_zero hhmd (hQtmd.pow d) hmul0 with
+    hzero | hzero
+  · refine ⟨d, p', hp'coeff, fun τ => ?_⟩
+    exact congrFun hzero τ
+  · exfalso
+    apply hQ0
+    funext τ
+    have h1 := congrFun hzero τ
+    simp only [Pi.pow_apply, Pi.zero_apply] at h1
+    have h2 := pow_eq_zero_iff hdpos.ne' |>.mp h1
+    simpa using h2
+
+end
+end S_WLight_exists_monicRel_j_K_of_mdifferentiable_frickeQuotient
+end P2MW
+export P2MW.S_WLight_exists_monicRel_j_K_of_mdifferentiable_frickeQuotient (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Complex Real UpperHalfPlane
+open scoped Manifold MatrixGroups ModularForm
+theorem WLight.exists_monicRel_j_K_of_mdifferentiable_frickeQuotient
+    (N : ℕ) [NeZero N]
+    (L : ℍ → PeriodPair) (hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), W v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (jf : ℍ → ℂ)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    (K : IntermediateField ℚ ℂ)
+    (hK : K = IntermediateField.adjoin ℚ
+      {Complex.exp (2 * (Real.pi : ℂ) * Complex.I / (N : ℂ))})
+    (G : ℍ → ℂ) (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (P₀ Q₀ : MvPolynomial (Option {v : Fin 2 → ZMod N // v ≠ 0}) ↥K)
+    (hQ0 : MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+      o.elim jf fun v => fricke v.1) (Q₀.map (algebraMap ↥K ℂ)) ≠ 0)
+    (hGQ : G * MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+        o.elim jf fun v => fricke v.1) (Q₀.map (algebraMap ↥K ℂ)) =
+      MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+        o.elim jf fun v => fricke v.1) (P₀.map (algebraMap ↥K ℂ))) :
+    ∃ (d : ℕ) (p : Fin d → Polynomial ℂ), (∀ (i : Fin d) (n : ℕ), (p i).coeff n ∈ K) ∧
+      ∀ τ : ℍ, G τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * G τ ^ (i : ℕ) = 0 :=
+  solution N L hL W hW fricke hfricke jf hjf K hK G hG P₀ Q₀ hQ0 hGQ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_exists_monicRel_j_of_mdifferentiable_levelFraction.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_exists_monicRel_j_of_mdifferentiable_levelFraction.lean
new file mode 100644
index 0000000000..bfa03239b5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_exists_monicRel_j_of_mdifferentiable_levelFraction.lean
@@ -0,0 +1,643 @@
+/-
+Based on Prove2Me node WLight.exists_monicRel_j_of_mdifferentiable_levelFraction
+(384ea021-4486-5798-8a93-9d7cb91a90f0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 179980d2-28fa-5428-819a-d48ea8decd60
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.SpecialFunctions.Elliptic.Weierstrass
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import Mathlib.Geometry.Manifold.Notation
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_modularity_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelOne_hauptmodul_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Integrality over ℂ[j] of pole-bounded level-N quotients
+
+Theorem statement: `WLight.exists_monicRel_j_of_mdifferentiable_levelFraction`
+(`384ea021-4486-5798-8a93-9d7cb91a90f0`), by Claude, 2026-09-05.
+
+Proof: submission `179980d2-28fa-5428-819a-d48ea8decd60`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a natural number $N \neq 0$. Let $L$ assign to each $\tau \in \mathbb{H}$ a period pair, subject
+to $(L\tau).\omega_1 = \tau$ and $(L\tau).\omega_2 = 1$; let $W$ be a family of functions on
+$\mathbb{H}$ indexed by $v \in (\mathbb{Z}/N)^2$ pinned pointwise by $W_v(\tau) = (2\pi
+i)^{-2}\,\wp_{L\tau}\big((\tilde v_0\tau + \tilde v_1)/N\big)$, where $\tilde v_i$ denotes the
+natural-number representative of $v_i$; let $\mathrm{fricke}$ be pinned pointwise by
+$\mathrm{fricke}_v(\tau) = -\big(E_4(\tau)E_6(\tau)/\Delta(\tau)\big)/2592 \cdot W_v(\tau)$; and let
+$jf$ be pinned pointwise by $jf(\tau) = E_4(\tau)^3/\Delta(\tau)$. Let $a, b, F : \mathbb{H} \to
+\mathbb{C}$, with $a$ and $b$ both lying in the $\mathbb{C}$-subalgebra of the pointwise ring of
+functions $\mathbb{H} \to \mathbb{C}$ generated by $jf$ together with all $\mathrm{fricke}_v$ for $v
+\neq 0$, with $b$ not the zero function, with $F$ holomorphic on $\mathbb{H}$ (as a map of complex
+manifolds), with $F \cdot b = a$ pointwise, and with the pole bound: for every $\gamma \in
+\mathrm{SL}_2(\mathbb{Z})$ there is $m \in \mathbb{N}$ such that $\tau \mapsto F(\gamma \cdot
+\tau)\,\Delta(\tau)^m$ is bounded as $\operatorname{im}\tau \to \infty$. Then there exist $d \in
+\mathbb{N}$ and polynomials $p_0,\dots,p_{d-1} \in \mathbb{C}[X]$ with $F(\tau)^d + \sum_{i<d}
+p_i(jf(\tau))\,F(\tau)^i = 0$ for all $\tau \in \mathbb{H}$.
+
+This is the integrality half of the classical fact that a holomorphic modular function of level $N$
+whose poles are confined to the cusps is integral over $\mathbb{C}[j]$; here the pole bound on all
+$\mathrm{SL}_2(\mathbb{Z})$-translates of $F$ is assumed rather than deduced from membership in the
+level-$N$ modular function field, so the statement is weaker than the classical one and each
+consumer verifies the bound for its own $F$. It is used in the study of $q$-expansion coefficients
+and rationality of Fricke functions on modular curves, and its proof cites the level-one hauptmodul
+package and the modularity package for the Fricke functions $\mathrm{fricke}_v$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WLight_exists_monicRel_j_of_mdifferentiable_levelFraction.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_WLight_exists_monicRel_j_of_mdifferentiable_levelFraction
+
+noncomputable section
+
+p2m_open "Complex Real UpperHalfPlane ModularForm Polynomial Real.Polynomial"
+open scoped Topology Manifold MatrixGroups ModularForm
+
+namespace WLight
+p2m_export "WLight" "levelOne_hauptmodul_package frickeFunction_modularity_package"
+p2m_open "WLight"
+
+section HBridge
+
+theorem mdifferentiable_eq_zero_or_eq_zero_of_mul_eq_zero {f g : ℍ → ℂ}
+    (hf : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) (hg : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hfg : f * g = 0) : f = 0 ∨ g = 0 := by
+  rw [UpperHalfPlane.mdifferentiable_iff] at hf hg
+  have hU : IsOpen {z : ℂ | 0 < z.im} := isOpen_upperHalfPlaneSet
+  have key := AnalyticOnNhd.eq_zero_or_eq_zero_of_mul_eq_zero (hf.analyticOnNhd hU)
+    (hg.analyticOnNhd hU) (fun z hz ↦ by
+      have := congrFun hfg (ofComplex z)
+      simpa using this) (convex_halfSpace_im_gt 0).isPreconnected
+  rcases key with k | k
+  · left; funext τ; simpa [ofComplex_apply] using k (τ : ℂ) τ.im_pos
+  · right; funext τ; simpa [ofComplex_apply] using k (τ : ℂ) τ.im_pos
+
+end HBridge
+
+section JfFacts
+
+lemma isBoundedAtImInfty_discriminant : IsBoundedAtImInfty (⇑CuspForm.discriminant : ℍ → ℂ) :=
+  (CuspFormClass.zero_at_infty CuspForm.discriminant).boundedAtFilter
+
+lemma isBoundedAtImInfty_discPow (n : ℕ) :
+    IsBoundedAtImInfty (⇑CuspForm.discriminant ^ n : ℍ → ℂ) := by
+  induction n with
+  | zero => exact pow_zero (⇑CuspForm.discriminant : ℍ → ℂ) ▸ Filter.const_boundedAtFilter _ (1 : ℂ)
+  | succ k ih =>
+    rw [pow_succ]
+    exact ih.mul isBoundedAtImInfty_discriminant
+
+lemma IsBoundedAtImInfty.mul_discPow_mono {f : ℍ → ℂ} {m m' : ℕ} (hm : m ≤ m')
+    (h : IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m)) :
+    IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m') := by
+  have hshape : (f * ⇑CuspForm.discriminant ^ m' : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m) * ⇑CuspForm.discriminant ^ (m' - m) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply]
+    rw [mul_assoc, ← pow_add, Nat.add_sub_cancel' hm]
+  rw [hshape]
+  exact h.mul (isBoundedAtImInfty_discPow (m' - m))
+
+variable {jf : ℍ → ℂ}
+  (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+include hjf
+
+lemma mdiff_jf : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) jf := by
+  have : jf = fun τ => ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ := funext hjf
+  rw [this]
+  exact (ModularForm.E₄.holo'.pow 3).div CuspForm.discriminant.holo'
+    ModularForm.discriminant_ne_zero
+
+lemma jf_smul (γ : SL(2, ℤ)) (τ : ℍ) : jf (γ • τ) = jf τ := by
+  have hγ : (Matrix.SpecialLinearGroup.mapGL ℝ γ : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ, rfl⟩
+  have h4 := SlashInvariantForm.slash_action_eqn'' ModularForm.E₄ hγ τ
+  have hΔ := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hγ τ
+  rw [CuspForm.coe_discriminant] at hΔ
+  rw [show (Matrix.SpecialLinearGroup.mapGL ℝ γ) • τ = γ • τ from rfl] at h4 hΔ
+  have hd : denom (Matrix.SpecialLinearGroup.mapGL ℝ γ) τ ≠ 0 := denom_ne_zero _ τ
+  have hΔ0 : ModularForm.discriminant τ ≠ 0 := ModularForm.discriminant_ne_zero τ
+  rw [hjf, hjf, h4, hΔ, zpow_ofNat, zpow_ofNat]
+  field_simp
+
+end JfFacts
+
+section AdjoinFacts
+
+variable {N : ℕ} {jf : ℍ → ℂ} {fricke : (Fin 2 → ZMod N) → ℍ → ℂ}
+
+lemma map_castRingHom_eq_one {γ : Matrix.SpecialLinearGroup (Fin 2) ℤ}
+    (hγ : γ ∈ CongruenceSubgroup.Gamma N) :
+    ((Matrix.SpecialLinearGroup.map (Int.castRingHom (ZMod N)) γ :
+      Matrix.SpecialLinearGroup (Fin 2) (ZMod N)) : Matrix (Fin 2) (Fin 2) (ZMod N)) = 1 := by
+  rw [CongruenceSubgroup.Gamma_mem'] at hγ
+  rw [hγ, Matrix.SpecialLinearGroup.coe_one]
+
+lemma mdiff_of_mem_adjoin
+    (hjmd : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) jf)
+    (hfmd : ∀ v : Fin 2 → ZMod N, v ≠ 0 → MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fricke v))
+    {x : ℍ → ℂ}
+    (hx : x ∈ Algebra.adjoin ℂ
+      (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v})) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) x := by
+  induction hx using Algebra.adjoin_induction with
+  | mem g hg =>
+    rcases hg with rfl | ⟨v, hv, rfl⟩
+    · exact hjmd
+    · exact hfmd v hv
+  | algebraMap r => exact mdifferentiable_const
+  | add x y _ _ ihx ihy => exact ihx.add ihy
+  | mul x y _ _ ihx ihy => exact ihx.mul ihy
+
+lemma invariant_of_mem_adjoin
+    (hjinv : ∀ (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) (τ : ℍ), jf (γ • τ) = jf τ)
+    (hfslash : ∀ (v : Fin 2 → ZMod N) (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) (τ : ℍ),
+      fricke v (γ • τ) = fricke (Matrix.vecMul v
+        ((Matrix.SpecialLinearGroup.map (Int.castRingHom (ZMod N)) γ :
+          Matrix.SpecialLinearGroup (Fin 2) (ZMod N)) : Matrix (Fin 2) (Fin 2) (ZMod N))) τ)
+    {x : ℍ → ℂ}
+    (hx : x ∈ Algebra.adjoin ℂ
+      (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}))
+    {γ : Matrix.SpecialLinearGroup (Fin 2) ℤ} (hγ : γ ∈ CongruenceSubgroup.Gamma N) (τ : ℍ) :
+    x (γ • τ) = x τ := by
+  induction hx using Algebra.adjoin_induction with
+  | mem g hg =>
+    rcases hg with rfl | ⟨v, hv, rfl⟩
+    · exact hjinv γ τ
+    · rw [hfslash v γ τ, map_castRingHom_eq_one hγ, Matrix.vecMul_one]
+  | algebraMap r => rfl
+  | add x y _ _ ihx ihy => simp only [Pi.add_apply, ihx, ihy]
+  | mul x y _ _ ihx ihy => simp only [Pi.mul_apply, ihx, ihy]
+
+end AdjoinFacts
+
+section GammaOrbit
+
+variable {N : ℕ} [NeZero N]
+
+lemma mdiff_comp_smul {F : ℍ → ℂ} (hF : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F)
+    (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (F ∘ (γ • ·)) := by
+  have h1 : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (F ∣[(0 : ℤ)] γ) := hF.slash 0 _
+  have h2 : F ∣[(0 : ℤ)] γ = F ∘ (γ • ·) := by
+    funext τ
+    simp only [ModularForm.SL_slash_apply, neg_zero, zpow_zero, mul_one]
+    rfl
+  rwa [h2] at h1
+
+variable (N) in
+def gammaOrbit (F : ℍ → ℂ)
+    (hFinv : ∀ γ ∈ CongruenceSubgroup.Gamma N, F ∘ (γ • ·) = F) :
+    (Matrix.SpecialLinearGroup (Fin 2) ℤ ⧸ CongruenceSubgroup.Gamma N) → ℍ → ℂ :=
+  Quotient.lift (fun γ : Matrix.SpecialLinearGroup (Fin 2) ℤ => F ∘ (γ • ·)) (by
+    intro γ γ' hrel
+    replace hrel : γ⁻¹ * γ' ∈ CongruenceSubgroup.Gamma N :=
+      QuotientGroup.leftRel_apply.mp hrel
+    have hconj : γ * (γ⁻¹ * γ') * γ⁻¹ ∈ CongruenceSubgroup.Gamma N :=
+      (CongruenceSubgroup.Gamma_normal N).conj_mem _ hrel γ
+    funext τ
+    have h1 := congrFun (hFinv _ hconj) (γ • τ)
+    simp only [Function.comp_apply] at h1 ⊢
+    rw [← mul_smul, show γ * (γ⁻¹ * γ') * γ⁻¹ * γ = γ' by group] at h1
+    exact h1.symm)
+
+omit [NeZero N] in
+lemma gammaOrbit_mk (F : ℍ → ℂ)
+    (hFinv : ∀ γ ∈ CongruenceSubgroup.Gamma N, F ∘ (γ • ·) = F)
+    (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) :
+    gammaOrbit N F hFinv (QuotientGroup.mk γ) = F ∘ (γ • ·) := rfl
+
+omit [NeZero N] in
+lemma gammaOrbit_one (F : ℍ → ℂ)
+    (hFinv : ∀ γ ∈ CongruenceSubgroup.Gamma N, F ∘ (γ • ·) = F) :
+    gammaOrbit N F hFinv (QuotientGroup.mk 1) = F := by
+  rw [gammaOrbit_mk]
+  funext τ
+  simp [one_smul]
+
+variable (N) in
+def orbitPerm (γ₀ : Matrix.SpecialLinearGroup (Fin 2) ℤ) :
+    Equiv.Perm (Matrix.SpecialLinearGroup (Fin 2) ℤ ⧸ CongruenceSubgroup.Gamma N) where
+  toFun := Quotient.map (· * γ₀) (by
+    intro x y h
+    replace h : x⁻¹ * y ∈ CongruenceSubgroup.Gamma N := QuotientGroup.leftRel_apply.mp h
+    refine QuotientGroup.leftRel_apply.mpr ?_
+    have := (CongruenceSubgroup.Gamma_normal N).conj_mem _ h γ₀⁻¹
+    simpa [mul_assoc, mul_inv_rev] using this)
+  invFun := Quotient.map (· * γ₀⁻¹) (by
+    intro x y h
+    replace h : x⁻¹ * y ∈ CongruenceSubgroup.Gamma N := QuotientGroup.leftRel_apply.mp h
+    refine QuotientGroup.leftRel_apply.mpr ?_
+    have := (CongruenceSubgroup.Gamma_normal N).conj_mem _ h γ₀
+    simpa [mul_assoc, mul_inv_rev] using this)
+  left_inv := by
+    intro q
+    induction q using QuotientGroup.induction_on with
+    | H γ => simp [Quotient.map_mk, mul_assoc]
+  right_inv := by
+    intro q
+    induction q using QuotientGroup.induction_on with
+    | H γ => simp [Quotient.map_mk, mul_assoc]
+
+omit [NeZero N] in
+lemma orbitPerm_mk (γ₀ γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) :
+    orbitPerm N γ₀ (QuotientGroup.mk γ) = QuotientGroup.mk (γ * γ₀) := rfl
+
+omit [NeZero N] in
+lemma gammaOrbit_perm (F : ℍ → ℂ)
+    (hFinv : ∀ γ ∈ CongruenceSubgroup.Gamma N, F ∘ (γ • ·) = F)
+    (γ₀ : Matrix.SpecialLinearGroup (Fin 2) ℤ)
+    (q : Matrix.SpecialLinearGroup (Fin 2) ℤ ⧸ CongruenceSubgroup.Gamma N) (τ : ℍ) :
+    gammaOrbit N F hFinv q (γ₀ • τ) = gammaOrbit N F hFinv (orbitPerm N γ₀ q) τ := by
+  induction q using QuotientGroup.induction_on with
+  | H γ =>
+    rw [orbitPerm_mk, gammaOrbit_mk, gammaOrbit_mk]
+    simp only [Function.comp_apply, mul_smul]
+
+end GammaOrbit
+
+section OrbitEngine
+
+variable {I : Type*} [Fintype I] (h : I → ℍ → ℂ) (m : ℕ)
+
+def orbitCoeff (k : ℕ) : ℍ → ℂ := fun τ => (∏ i, (X - C (h i τ))).coeff k
+
+lemma coeff_X_sub_C_mul (a : ℂ) (p : Polynomial ℂ) (k : ℕ) :
+    ((X - C a) * p).coeff k = (if k = 0 then 0 else p.coeff (k - 1)) - a * p.coeff k := by
+  rw [sub_mul, Polynomial.coeff_sub, Polynomial.coeff_C_mul]
+  congr 1
+  cases k with
+  | zero => simp [Polynomial.mul_coeff_zero]
+  | succ k' => simp [Polynomial.coeff_X_mul]
+
+omit [Fintype I] in
+lemma mdiff_orbitCoeff_prod (hhol : ∀ i, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (h i)) (s : Finset I)
+    (k : ℕ) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) ((fun τ : ℍ => (∏ i ∈ s, (X - C (h i τ))).coeff k) : ℍ → ℂ) := by
+  induction s using Finset.cons_induction generalizing k with
+  | empty =>
+    simp only [Finset.prod_empty, Polynomial.coeff_one]
+    exact mdifferentiable_const
+  | cons a s ha ih =>
+    have hrw : ∀ τ : ℍ, (∏ i ∈ Finset.cons a s ha, (X - C (h i τ))).coeff k =
+        (if k = 0 then 0 else (∏ i ∈ s, (X - C (h i τ))).coeff (k - 1)) -
+          h a τ * (∏ i ∈ s, (X - C (h i τ))).coeff k := by
+      intro τ
+      rw [Finset.prod_cons, coeff_X_sub_C_mul]
+    simp only [hrw]
+    cases k with
+    | zero =>
+      exact mdifferentiable_const.sub ((hhol a).mul (ih 0))
+    | succ k' =>
+      simp only [ite_eq_right (Nat.succ_ne_zero k'), Nat.add_sub_cancel]
+      exact (ih k').sub ((hhol a).mul (ih (k' + 1)))
+
+omit [Fintype I] in
+lemma bounded_orbitCoeff_prod
+    (hbd : ∀ i, IsBoundedAtImInfty (h i * ⇑CuspForm.discriminant ^ m)) (s : Finset I) (k : ℕ) :
+    IsBoundedAtImInfty (fun τ =>
+      (∏ i ∈ s, (X - C (h i τ))).coeff k * CuspForm.discriminant τ ^ ((s.card - k) * m)) := by
+  induction s using Finset.cons_induction generalizing k with
+  | empty =>
+    simp only [Finset.prod_empty, Polynomial.coeff_one, Finset.card_empty, Nat.zero_sub,
+      Nat.zero_mul, pow_zero, mul_one]
+    exact Filter.const_boundedAtFilter _ _
+  | cons a s ha ih =>
+    have hdeg : ∀ τ : ℍ, (∏ i ∈ s, (X - C (h i τ))).natDegree = s.card := by
+      intro τ
+      rw [natDegree_prod_of_monic _ _ (fun i _ => monic_X_sub_C (h i τ))]
+      simp
+    cases k with
+    | zero =>
+      have hshape : (fun τ : ℍ =>
+          (∏ i ∈ Finset.cons a s ha, (X - C (h i τ))).coeff 0 *
+            CuspForm.discriminant τ ^ (((Finset.cons a s ha).card - 0) * m)) = fun τ : ℍ =>
+          -((h a τ * CuspForm.discriminant τ ^ m) *
+            ((∏ i ∈ s, (X - C (h i τ))).coeff 0 *
+              CuspForm.discriminant τ ^ ((s.card - 0) * m))) := by
+        funext τ
+        rw [Finset.prod_cons, coeff_X_sub_C_mul, ite_eq_left rfl, Finset.card_cons, Nat.sub_zero,
+          Nat.sub_zero, zero_sub, show (s.card + 1) * m = m + s.card * m by ring, pow_add]
+        ring
+      rw [hshape]
+      exact ((hbd a).mul (ih 0)).neg
+    | succ k' =>
+      rcases Nat.lt_or_ge s.card (k' + 1) with hk | hk
+      · have hzero : ∀ τ : ℍ, (∏ i ∈ s, (X - C (h i τ))).coeff (k' + 1) = 0 := fun τ =>
+          coeff_eq_zero_of_natDegree_lt (by rw [hdeg τ]; exact hk)
+        have hshape : (fun τ : ℍ =>
+            (∏ i ∈ Finset.cons a s ha, (X - C (h i τ))).coeff (k' + 1) *
+              CuspForm.discriminant τ ^ (((Finset.cons a s ha).card - (k' + 1)) * m)) =
+            fun τ : ℍ =>
+            (∏ i ∈ s, (X - C (h i τ))).coeff k' *
+              CuspForm.discriminant τ ^ ((s.card - k') * m) := by
+          funext τ
+          rw [Finset.prod_cons, coeff_X_sub_C_mul, ite_eq_right (Nat.succ_ne_zero k'),
+            Nat.add_sub_cancel, hzero τ, mul_zero, sub_zero, Finset.card_cons,
+            Nat.succ_sub_succ]
+        rw [hshape]
+        exact ih k'
+      · have he2 : (s.card - k') * m = m + (s.card - (k' + 1)) * m := by
+          have h1 : s.card - k' = 1 + (s.card - (k' + 1)) := by omega
+          rw [h1]
+          ring
+        have hshape : (fun τ : ℍ =>
+            (∏ i ∈ Finset.cons a s ha, (X - C (h i τ))).coeff (k' + 1) *
+              CuspForm.discriminant τ ^ (((Finset.cons a s ha).card - (k' + 1)) * m)) =
+            fun τ : ℍ =>
+            ((∏ i ∈ s, (X - C (h i τ))).coeff k' *
+              CuspForm.discriminant τ ^ ((s.card - k') * m)) -
+            ((h a τ * CuspForm.discriminant τ ^ m) *
+              ((∏ i ∈ s, (X - C (h i τ))).coeff (k' + 1) *
+                CuspForm.discriminant τ ^ ((s.card - (k' + 1)) * m))) := by
+          funext τ
+          rw [Finset.prod_cons, coeff_X_sub_C_mul, ite_eq_right (Nat.succ_ne_zero k'),
+            Nat.add_sub_cancel, Finset.card_cons, Nat.succ_sub_succ, sub_mul]
+          congr 1
+          rw [he2, pow_add]
+          ring
+        rw [hshape]
+        exact (ih k').sub ((hbd a).mul (ih (k' + 1)))
+
+theorem orbitCoeff_slash_invariant
+    (hperm : ∀ γ : Matrix.SpecialLinearGroup (Fin 2) ℤ,
+      ∃ σ : Equiv.Perm I, ∀ i τ, h i (γ • τ) = h (σ i) τ)
+    (k : ℕ) (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) :
+    orbitCoeff h k ∣[(0 : ℤ)] γ = orbitCoeff h k := by
+  obtain ⟨σ, hσ⟩ := hperm γ
+  funext τ
+  simp only [ModularForm.SL_slash_apply, neg_zero, zpow_zero, mul_one]
+  change (∏ i, (X - C (h i (γ • τ)))).coeff k = (∏ i, (X - C (h i τ))).coeff k
+  congr 2
+  calc ∏ i, (X - C (h i (γ • τ)))
+      = ∏ i, (X - C (h (σ i) τ)) := by
+        refine Finset.prod_congr rfl fun i _ => ?_
+        rw [hσ i τ]
+    _ = ∏ i, (X - C (h i τ)) := Equiv.prod_comp σ (fun i' => X - C (h i' τ))
+
+variable {jf : ℍ → ℂ}
+
+theorem exists_poly_j_orbitCoeff
+    (hR3 : ∀ (m' : ℕ) (g : ℍ → ℂ), MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g →
+      (∀ γ : Matrix.SpecialLinearGroup (Fin 2) ℤ, g ∣[(0 : ℤ)] γ = g) →
+      IsBoundedAtImInfty (g * ModularForm.discriminant ^ m') →
+      ∃ P : Polynomial ℂ, P.natDegree ≤ m' ∧ g = fun τ => P.eval (jf τ))
+    (hperm : ∀ γ : Matrix.SpecialLinearGroup (Fin 2) ℤ,
+      ∃ σ : Equiv.Perm I, ∀ i τ, h i (γ • τ) = h (σ i) τ)
+    (hhol : ∀ i, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (h i))
+    (hbd : ∀ i, IsBoundedAtImInfty (h i * ⇑CuspForm.discriminant ^ m)) (k : ℕ) :
+    ∃ P : Polynomial ℂ, P.natDegree ≤ (Fintype.card I - k) * m ∧
+      orbitCoeff h k = fun τ => P.eval (jf τ) := by
+  refine hR3 ((Fintype.card I - k) * m) (orbitCoeff h k)
+    (mdiff_orbitCoeff_prod h hhol Finset.univ k)
+    (orbitCoeff_slash_invariant h hperm k) ?_
+  have hb := bounded_orbitCoeff_prod h m hbd Finset.univ k
+  rw [Finset.card_univ] at hb
+  have hshape : ((orbitCoeff h k * ModularForm.discriminant ^ ((Fintype.card I - k) * m)
+      : ℍ → ℂ)) =
+      fun τ : ℍ => (∏ i, (X - C (h i τ))).coeff k *
+        CuspForm.discriminant τ ^ ((Fintype.card I - k) * m) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply, orbitCoeff, ← CuspForm.coe_discriminant]
+  rw [hshape]
+  exact hb
+
+theorem orbit_integral_over_j
+    (hR3 : ∀ (m' : ℕ) (g : ℍ → ℂ), MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g →
+      (∀ γ : Matrix.SpecialLinearGroup (Fin 2) ℤ, g ∣[(0 : ℤ)] γ = g) →
+      IsBoundedAtImInfty (g * ModularForm.discriminant ^ m') →
+      ∃ P : Polynomial ℂ, P.natDegree ≤ m' ∧ g = fun τ => P.eval (jf τ))
+    (hperm : ∀ γ : Matrix.SpecialLinearGroup (Fin 2) ℤ,
+      ∃ σ : Equiv.Perm I, ∀ i τ, h i (γ • τ) = h (σ i) τ)
+    (hhol : ∀ i, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (h i))
+    (hbd : ∀ i, IsBoundedAtImInfty (h i * ⇑CuspForm.discriminant ^ m)) :
+    ∃ P : ℕ → Polynomial ℂ, (∀ k, (P k).natDegree ≤ (Fintype.card I - k) * m) ∧
+      ∀ (i : I) (τ : ℍ), h i τ ^ Fintype.card I +
+        ∑ k ∈ Finset.range (Fintype.card I),
+          Polynomial.eval (jf τ) (P k) * h i τ ^ k = 0 := by
+  choose P hPdeg hP using fun k => exists_poly_j_orbitCoeff h m hR3 hperm hhol hbd k
+  refine ⟨P, hPdeg, fun i τ => ?_⟩
+  set Q : Polynomial ℂ := ∏ i', (X - C (h i' τ)) with hQ
+  have hQmonic : Q.Monic := monic_prod_of_monic _ _ fun i' _ => monic_X_sub_C (h i' τ)
+  have hQdeg : Q.natDegree = Fintype.card I := by
+    rw [hQ, natDegree_prod_of_monic _ _ (fun i' _ => monic_X_sub_C (h i' τ))]
+    simp
+  have hroot : Polynomial.eval (h i τ) Q = 0 := by
+    rw [hQ, Polynomial.eval_prod]
+    exact Finset.prod_eq_zero (Finset.mem_univ i) (by simp)
+  have hexp := Polynomial.eval_eq_sum_range' (n := Fintype.card I + 1)
+    (by rw [hQdeg]; exact Nat.lt_succ_self _) (h i τ) (p := Q)
+  rw [Finset.sum_range_succ] at hexp
+  have hlead : Q.coeff (Fintype.card I) = 1 := by
+    have := hQmonic.coeff_natDegree
+    rwa [hQdeg] at this
+  have hcoeffs : ∀ k, Q.coeff k = Polynomial.eval (jf τ) (P k) := by
+    intro k
+    have := congrFun (hP k) τ
+    simpa [orbitCoeff, hQ] using this
+  rw [hroot.symm, hexp, hlead, one_mul, add_comm]
+  congr 1
+  exact Finset.sum_congr rfl fun k _ => by rw [hcoeffs k]
+
+end OrbitEngine
+
+section HeadThree
+
+theorem exists_monicRel_j_of_mdifferentiable_levelFraction_of_deps
+    (N : ℕ) [NeZero N]
+    (L : ℍ → PeriodPair) (hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), W v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (jf : ℍ → ℂ)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    (hR3 : ∀ (m' : ℕ) (g : ℍ → ℂ), MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g →
+      (∀ γ : SL(2, ℤ), g ∣[(0 : ℤ)] γ = g) →
+      IsBoundedAtImInfty (g * ModularForm.discriminant ^ m') →
+      ∃ P : Polynomial ℂ, P.natDegree ≤ m' ∧ g = fun τ => P.eval (jf τ))
+    (hR4a : ∀ v : Fin 2 → ZMod N, v ≠ 0 → MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fricke v))
+    (hR4c : ∀ (v : Fin 2 → ZMod N) (γ : SL(2, ℤ)) (τ : ℍ),
+      fricke v (γ • τ) = fricke (Matrix.vecMul v
+        ((Matrix.SpecialLinearGroup.map (Int.castRingHom (ZMod N)) γ :
+          Matrix.SpecialLinearGroup (Fin 2) (ZMod N)) : Matrix (Fin 2) (Fin 2) (ZMod N))) τ)
+    {a b F : ℍ → ℂ}
+    (ha : a ∈ Algebra.adjoin ℂ
+      (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}))
+    (hb : b ∈ Algebra.adjoin ℂ
+      (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}))
+    (hb0 : b ≠ 0)
+    (hF : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F) (hFb : F * b = a)
+    (hpb : ∀ γ : SL(2, ℤ), ∃ m : ℕ,
+      IsBoundedAtImInfty ((F ∘ (γ • ·)) * ModularForm.discriminant ^ m)) :
+    ∃ (d : ℕ) (p : Fin d → Polynomial ℂ), ∀ τ : ℍ,
+      F τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * F τ ^ (i : ℕ) = 0 := by
+  have _hL := hL
+  have _hW := hW
+  have _hfricke := hfricke
+  classical
+  have hbmd : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) b := mdiff_of_mem_adjoin (mdiff_jf hjf) hR4a hb
+  have hainv : ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : ℍ, a (γ • τ) = a τ := fun γ hγ τ =>
+    invariant_of_mem_adjoin (fun γ' τ' => jf_smul hjf γ' τ') hR4c ha hγ τ
+  have hbinv : ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : ℍ, b (γ • τ) = b τ := fun γ hγ τ =>
+    invariant_of_mem_adjoin (fun γ' τ' => jf_smul hjf γ' τ') hR4c hb hγ τ
+  have hFinv : ∀ γ ∈ CongruenceSubgroup.Gamma N, F ∘ (γ • ·) = F := by
+    intro γ hγ
+    have hdiff : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (F ∘ (γ • ·) - F) :=
+      (mdiff_comp_smul hF γ).sub hF
+    have hprod : (F ∘ (γ • ·) - F) * b = 0 := by
+      funext τ
+      have h1 : F (γ • τ) * b (γ • τ) = a (γ • τ) := congrFun hFb (γ • τ)
+      have h2 : F τ * b τ = a τ := congrFun hFb τ
+      simp only [Pi.mul_apply, Pi.sub_apply, Pi.zero_apply, Function.comp_apply]
+      rw [sub_mul, h2]
+      rw [show F (γ • τ) * b τ = F (γ • τ) * b (γ • τ) by rw [hbinv γ hγ τ], h1,
+        hainv γ hγ τ, sub_self]
+    rcases mdifferentiable_eq_zero_or_eq_zero_of_mul_eq_zero hdiff hbmd hprod with h | h
+    · funext τ
+      have := congrFun h τ
+      simpa [sub_eq_zero] using this
+    · exact absurd h hb0
+  have : Fintype (Matrix.SpecialLinearGroup (Fin 2) ℤ ⧸ CongruenceSubgroup.Gamma N) :=
+    Fintype.ofFinite _
+  set orb := gammaOrbit N F (fun γ hγ => hFinv γ hγ) with horb
+  have hperm : ∀ γ : Matrix.SpecialLinearGroup (Fin 2) ℤ,
+      ∃ σ : Equiv.Perm (Matrix.SpecialLinearGroup (Fin 2) ℤ ⧸ CongruenceSubgroup.Gamma N),
+        ∀ q τ, orb q (γ • τ) = orb (σ q) τ :=
+    fun γ => ⟨orbitPerm N γ, fun q τ => gammaOrbit_perm F _ γ q τ⟩
+  have hhol : ∀ q, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (orb q) := by
+    intro q
+    induction q using QuotientGroup.induction_on with
+    | H γ => exact mdiff_comp_smul hF γ
+  choose mq hmq using fun q : Matrix.SpecialLinearGroup (Fin 2) ℤ ⧸ CongruenceSubgroup.Gamma N =>
+    hpb q.out
+  set M := Finset.univ.sup mq with hM
+  have hbd : ∀ q, IsBoundedAtImInfty (orb q * ⇑CuspForm.discriminant ^ M) := by
+    intro q
+    have hq : orb q = F ∘ (q.out • ·) := by
+      conv_lhs => rw [horb, ← Quotient.out_eq q]
+      rfl
+    have h1 : IsBoundedAtImInfty ((F ∘ (q.out • ·)) * ⇑CuspForm.discriminant ^ mq q) := by
+      rw [CuspForm.coe_discriminant]
+      exact hmq q
+    rw [hq]
+    exact IsBoundedAtImInfty.mul_discPow_mono (Finset.le_sup (Finset.mem_univ q)) h1
+  obtain ⟨P, -, hP⟩ := orbit_integral_over_j orb M hR3 hperm hhol hbd
+  set d := Fintype.card (Matrix.SpecialLinearGroup (Fin 2) ℤ ⧸ CongruenceSubgroup.Gamma N) with hd
+  refine ⟨d, fun i => P (i : ℕ), fun τ => ?_⟩
+  have h1 := hP (QuotientGroup.mk 1) τ
+  rw [show orb (QuotientGroup.mk 1) = F from gammaOrbit_one F _] at h1
+  have h2 : (∑ i : Fin d, (P (i : ℕ)).eval (jf τ) * F τ ^ (i : ℕ))
+      = ∑ k ∈ Finset.range d, Polynomial.eval (jf τ) (P k) * F τ ^ k :=
+    Fin.sum_univ_eq_sum_range (fun k => Polynomial.eval (jf τ) (P k) * F τ ^ k) d
+  rw [h2]
+  exact h1
+
+end HeadThree
+
+end WLight
+
+p2m_open "UpperHalfPlane~I" in
+open scoped UpperHalfPlane Manifold MatrixGroups ModularForm in
+open _root_.WLight _root_.P2MW.S_WLight_exists_monicRel_j_of_mdifferentiable_levelFraction.WLight in
+theorem solution
+    (N : ℕ) [NeZero N]
+    (L : ℍ → PeriodPair) (hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), W v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (jf : ℍ → ℂ)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    {a b F : ℍ → ℂ}
+    (ha : a ∈ Algebra.adjoin ℂ
+      (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}))
+    (hb : b ∈ Algebra.adjoin ℂ
+      (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}))
+    (hb0 : b ≠ 0)
+    (hF : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F) (hFb : F * b = a)
+    (hpb : ∀ γ : SL(2, ℤ), ∃ m : ℕ,
+      IsBoundedAtImInfty ((F ∘ (γ • ·)) * ModularForm.discriminant ^ m)) :
+    ∃ (d : ℕ) (p : Fin d → Polynomial ℂ), ∀ τ : ℍ,
+      F τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * F τ ^ (i : ℕ) = 0:= by
+  refine exists_monicRel_j_of_mdifferentiable_levelFraction_of_deps N L hL W hW fricke hfricke
+      jf hjf ?_ ?_ ?_ ha hb hb0 hF hFb hpb
+  · intro m' g hg hinv hbd
+    obtain ⟨P, hdeg, heq⟩ := levelOne_hauptmodul_package.1 m' g hg hinv hbd
+    refine ⟨P, hdeg, ?_⟩
+    rw [show (fun τ : ℍ => P.eval (jf τ))
+        = fun τ : ℍ => Polynomial.eval (ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) P from
+      funext fun τ => by rw [hjf τ]]
+    exact heq
+  · intro v hv
+    rw [show fricke v = fun τ : ℍ =>
+        -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 *
+          (((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ * PeriodPair.weierstrassP (L τ)
+            ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ))) from
+      funext fun τ => by rw [hfricke, hW]]
+    exact (frickeFunction_modularity_package N L hL).2.2.1 v hv
+  · intro v γ τ
+    have hfeq : ∀ w : Fin 2 → ZMod N, fricke w = fun τ : ℍ =>
+        -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 *
+          (((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ * PeriodPair.weierstrassP (L τ)
+            ((((w 0).val : ℂ) * (τ : ℂ) + ((w 1).val : ℂ)) / (N : ℂ))) :=
+      fun w => funext fun τ' => by rw [hfricke, hW]
+    rw [hfeq, hfeq]
+    exact (frickeFunction_modularity_package N L hL).1 v γ τ
+
+end
+end S_WLight_exists_monicRel_j_of_mdifferentiable_levelFraction
+end P2MW
+export P2MW.S_WLight_exists_monicRel_j_of_mdifferentiable_levelFraction (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Complex Real UpperHalfPlane
+open scoped Manifold MatrixGroups ModularForm
+theorem WLight.exists_monicRel_j_of_mdifferentiable_levelFraction
+    (N : ℕ) [NeZero N]
+    (L : ℍ → PeriodPair) (hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), W v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (jf : ℍ → ℂ)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    {a b F : ℍ → ℂ}
+    (ha : a ∈ Algebra.adjoin ℂ
+      (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}))
+    (hb : b ∈ Algebra.adjoin ℂ
+      (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}))
+    (hb0 : b ≠ 0)
+    (hF : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F) (hFb : F * b = a)
+    (hpb : ∀ γ : SL(2, ℤ), ∃ m : ℕ,
+      IsBoundedAtImInfty ((F ∘ (γ • ·)) * ModularForm.discriminant ^ m)) :
+    ∃ (d : ℕ) (p : Fin d → Polynomial ℂ), ∀ τ : ℍ,
+      F τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * F τ ^ (i : ℕ) = 0 :=
+  solution N L hL W hW fricke hfricke jf hjf ha hb hb0 hF hFb hpb
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_exists_qExpansion_coeff_mem_of_mdifferentiable_levelFraction.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_exists_qExpansion_coeff_mem_of_mdifferentiable_levelFraction.lean
new file mode 100644
index 0000000000..a49dc867bb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_exists_qExpansion_coeff_mem_of_mdifferentiable_levelFraction.lean
@@ -0,0 +1,1007 @@
+/-
+Based on Prove2Me node WLight.exists_qExpansion_coeff_mem_of_mdifferentiable_levelFraction
+(a6665bad-44cd-5e14-be80-bf84ddc2d50a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission abd11703-0175-5a71-9adc-66795939cca6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.SpecialFunctions.Elliptic.Weierstrass
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import Mathlib.Geometry.Manifold.Notation
+public import Mathlib.FieldTheory.IntermediateField.Basic
+
+import Mathlib.NumberTheory.ModularForms.CuspFormSubmodule
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_modularity_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# K-rational q-expansion for holomorphic fractions in j and Fricke functions
+
+Theorem statement: `WLight.exists_qExpansion_coeff_mem_of_mdifferentiable_levelFraction`
+(`a6665bad-44cd-5e14-be80-bf84ddc2d50a`), by Claude, 2026-09-05.
+
+Proof: submission `abd11703-0175-5a71-9adc-66795939cca6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix $N \ge 1$. Let $L$ assign to each $\tau \in \mathbb{H}$ a period pair, pinned by the hypothesis
+that $(L\tau).\omega_1 = \tau$ and $(L\tau).\omega_2 = 1$; let $W$ be a family of functions indexed
+by $v \in (\mathbb{Z}/N)^2$ pinned pointwise by $W_v(\tau) = (2\pi i)^{-2}\,\wp_{L\tau}\big((\tilde
+v_0 \tau + \tilde v_1)/N\big)$, where $\tilde v_i$ denotes the natural-number representative of
+$v_i$; let $\mathrm{fricke}$ be the family pinned by $\mathrm{fricke}_v(\tau) =
+-\big(E_4(\tau)E_6(\tau)/\Delta(\tau)\big)/2592 \cdot W_v(\tau)$, and let $jf$ be pinned by
+$jf(\tau) = E_4(\tau)^3/\Delta(\tau)$, with $E_4$, $E_6$, $\Delta$ the Mathlib Eisenstein series and
+discriminant. Let $K \subseteq \mathbb{C}$ be the intermediate field $\mathbb{Q}\big(e^{2\pi
+i/N}\big)$. Let $G \colon \mathbb{H} \to \mathbb{C}$ be holomorphic (in the sense of
+`MDifferentiable` for the trivial complex model on source and target), and let $P, Q$ be polynomials
+in the variables indexed by $\{*\} \sqcup \{v \in (\mathbb{Z}/N)^2 : v \ne 0\}$, all of whose
+coefficients lie in $K$. Write $\tilde P, \tilde Q$ for the evaluations of $P, Q$ at the system
+sending $*$ to $jf$ and $v$ to $\mathrm{fricke}_v$. Assume $\tilde Q \ne 0$ and $G \cdot \tilde Q =
+\tilde P$, and assume $G$ is integral over $K[j]$ in cleared form: for some $d$ there are
+polynomials $p_i \in \mathbb{C}[X]$, $i \in \mathrm{Fin}\,d$, with all coefficients in $K$, such
+that $G(\tau)^d + \sum_{i} p_i(jf(\tau))\,G(\tau)^i = 0$ for every $\tau$. Then there exists $m \in
+\mathbb{N}$ such that $G \cdot \Delta^m$, precomposed with `UpperHalfPlane.ofComplex`, is periodic
+of period $N$, the function $G \cdot \Delta^m$ is bounded as $\operatorname{Im}\tau \to \infty$, and
+every coefficient of its width-$N$ $q$-expansion lies in $K$.
+
+This is the rationality statement for $q$-expansions of modular functions of level $N$ built from
+the $j$-invariant and the Fricke functions, in the shape needed for a $q$-expansion-principle
+argument: a holomorphic function expressed as a $K$-rational fraction in $j$ and the $f_v$, and
+integral over $K[j]$, acquires after multiplication by a power of $\Delta$ a width-$N$ Fourier
+expansion with coefficients in $\mathbb{Q}(\zeta_N)$. It is used in the construction of
+$\mathbb{Q}(\zeta_N)$-rational bases of spaces of cusp forms and in the comparison of $q$-expansion
+coefficients under Galois action on modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WLight_exists_qExpansion_coeff_mem_of_mdifferentiable_levelFraction.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WLight_exists_qExpansion_coeff_mem_of_mdifferentiable_levelFraction
+
+noncomputable section
+
+p2m_open "Complex Real UpperHalfPlane Function Filter Polynomial Real.Polynomial"
+open scoped Topology Manifold MatrixGroups ModularForm
+
+namespace WLight
+p2m_export "WLight" "frickeFunction_modularity_package"
+p2m_open "WLight"
+
+section Division
+
+theorem powerSeries_coeff_mem_of_mul_eq {K : Type*} [Field K] (k : Subfield K)
+    {g h f : PowerSeries K} (heq : g * h = f) (hg0 : PowerSeries.constantCoeff g ≠ 0)
+    (hg : ∀ n, PowerSeries.coeff n g ∈ k) (hf : ∀ n, PowerSeries.coeff n f ∈ k) :
+    ∀ n, PowerSeries.coeff n h ∈ k := by
+  intro n
+  induction n using Nat.strong_induction_on with
+  | _ n ih =>
+  have hcm := PowerSeries.coeff_mul n g h
+  rw [heq] at hcm
+  have h0n : (0, n) ∈ Finset.HasAntidiagonal.antidiagonal n :=
+    Finset.HasAntidiagonal.mem_antidiagonal.mpr (zero_add n)
+  rw [← Finset.add_sum_erase _ _ h0n] at hcm
+  have hg0' : PowerSeries.coeff 0 g ≠ 0 := by
+    rwa [PowerSeries.coeff_zero_eq_constantCoeff_apply]
+  have hrest : (∑ p ∈ (Finset.HasAntidiagonal.antidiagonal n).erase (0, n),
+      PowerSeries.coeff p.1 g * PowerSeries.coeff p.2 h) ∈ k := by
+    refine sum_mem fun p hp ↦ mul_mem (hg p.1) (ih p.2 ?_)
+    obtain ⟨hpne, hpmem⟩ := Finset.mem_erase.mp hp
+    have hpsum : p.1 + p.2 = n := Finset.HasAntidiagonal.mem_antidiagonal.mp hpmem
+    rcases p with ⟨p1, p2⟩
+    simp only [Prod.mk.injEq, not_and, ne_eq] at hpne
+    dsimp only at hpsum
+    omega
+  have hn : PowerSeries.coeff n h = (PowerSeries.coeff 0 g)⁻¹ *
+      (PowerSeries.coeff n f - ∑ p ∈ (Finset.HasAntidiagonal.antidiagonal n).erase (0, n),
+        PowerSeries.coeff p.1 g * PowerSeries.coeff p.2 h) := by
+    rw [eq_inv_mul_iff_mul_eq₀ hg0', eq_sub_iff_add_eq]
+    exact hcm.symm
+  rw [hn]
+  exact mul_mem (inv_mem (hg 0)) (sub_mem (hf n) hrest)
+
+theorem powerSeries_coeff_mem_of_mul_eq' {K : Type*} [Field K] (k : Subfield K)
+    {g h f : PowerSeries K} (heq : g * h = f) (hg0 : g ≠ 0)
+    (hg : ∀ n, PowerSeries.coeff n g ∈ k) (hf : ∀ n, PowerSeries.coeff n f ∈ k) :
+    ∀ n, PowerSeries.coeff n h ∈ k := by
+  set r := (PowerSeries.order g).toNat with hr_def
+  obtain ⟨g', hg'⟩ : (PowerSeries.X : PowerSeries K) ^ r ∣ g := PowerSeries.X_pow_dvd_iff.mpr
+    (fun m hm ↦ PowerSeries.coeff_of_lt_order_toNat (φ := g) m hm)
+  have hg'_coeff : ∀ n, PowerSeries.coeff n g' ∈ k := fun n ↦ by
+    have h1 := hg (n + r)
+    rwa [hg', PowerSeries.coeff_X_pow_mul g' r n] at h1
+  have hg'_cc : PowerSeries.constantCoeff g' ≠ 0 := by
+    rw [← PowerSeries.coeff_zero_eq_constantCoeff_apply]
+    intro habs
+    refine (PowerSeries.coeff_order hg0) ?_
+    change PowerSeries.coeff r g = 0
+    rw [hg', PowerSeries.coeff_X_pow_mul', ite_eq_left le_rfl, Nat.sub_self, habs]
+  obtain ⟨f', hf'⟩ : PowerSeries.X ^ r ∣ f := ⟨g' * h, by rw [← heq, hg', mul_assoc]⟩
+  have hf'_coeff : ∀ n, PowerSeries.coeff n f' ∈ k := fun n ↦ by
+    have h1 := hf (n + r); rwa [hf', PowerSeries.coeff_X_pow_mul f' r n] at h1
+  have heq' : g' * h = f' := by
+    have hX : (PowerSeries.X : PowerSeries K) ^ r ≠ 0 := pow_ne_zero _ PowerSeries.X_ne_zero
+    have h2 := hf' ▸ hg' ▸ heq
+    rw [mul_assoc] at h2
+    exact mul_left_cancel₀ hX h2
+  exact powerSeries_coeff_mem_of_mul_eq k heq' hg'_cc hg'_coeff hf'_coeff
+
+theorem norm_le_of_monicRel {K : Type*} [NormedField K] {z : K} {a : ℕ → K} {d : ℕ}
+    (h : z ^ d + ∑ n ∈ Finset.range d, a n * z ^ n = 0) :
+    ‖z‖ ≤ 1 + ∑ n ∈ Finset.range d, ‖a n‖ := by
+  have hsum : ‖z‖ ^ d ≤ ∑ n ∈ Finset.range d, ‖a n‖ * ‖z‖ ^ n := by
+    calc ‖z‖ ^ d = ‖z ^ d‖ := (norm_pow _ _).symm
+      _ = ‖-∑ n ∈ Finset.range d, a n * z ^ n‖ :=
+          congrArg _ (eq_neg_of_add_eq_zero_left h)
+      _ = ‖∑ n ∈ Finset.range d, a n * z ^ n‖ := norm_neg _
+      _ ≤ ∑ n ∈ Finset.range d, ‖a n * z ^ n‖ := norm_sum_le _ _
+      _ = ∑ n ∈ Finset.range d, ‖a n‖ * ‖z‖ ^ n :=
+          Finset.sum_congr rfl fun n _ ↦ by rw [norm_mul, norm_pow]
+  rcases le_or_gt ‖z‖ 1 with h1 | h1
+  · exact h1.trans (le_add_of_nonneg_right (Finset.sum_nonneg fun _ _ ↦ norm_nonneg _))
+  · have hzpos : 0 < ‖z‖ := lt_of_lt_of_le one_pos h1.le
+    have hd : 0 < d := by
+      by_contra hd0
+      simp only [Nat.eq_zero_of_not_pos hd0, pow_zero, Finset.range_zero,
+        Finset.sum_empty] at hsum
+      exact absurd hsum (not_le.mpr one_pos)
+    have hpow : ∀ n ∈ Finset.range d, ‖z‖ ^ n ≤ ‖z‖ ^ (d - 1) := fun n hn ↦
+      pow_le_pow_right₀ h1.le (Nat.le_sub_one_of_lt (Finset.mem_range.mp hn))
+    have : ‖z‖ ^ d ≤ (∑ n ∈ Finset.range d, ‖a n‖) * ‖z‖ ^ (d - 1) := by
+      calc ‖z‖ ^ d ≤ ∑ n ∈ Finset.range d, ‖a n‖ * ‖z‖ ^ n := hsum
+        _ ≤ ∑ n ∈ Finset.range d, ‖a n‖ * ‖z‖ ^ (d - 1) :=
+            Finset.sum_le_sum fun n hn ↦ mul_le_mul_of_nonneg_left (hpow n hn) (norm_nonneg _)
+        _ = (∑ n ∈ Finset.range d, ‖a n‖) * ‖z‖ ^ (d - 1) := (Finset.sum_mul ..).symm
+    have hzd : ‖z‖ ^ d = ‖z‖ * ‖z‖ ^ (d - 1) := by
+      rw [← pow_succ', Nat.sub_add_cancel hd]
+    rw [hzd] at this
+    have := le_of_mul_le_mul_right (a := ‖z‖ ^ (d - 1)) this (pow_pos hzpos _)
+    linarith
+
+open Asymptotics in
+theorem isBoundedAtImInfty_of_monicRel {H : ℍ → ℂ} {c : ℕ → ℍ → ℂ} {d : ℕ}
+    (hc : ∀ n < d, IsBoundedAtImInfty (c n))
+    (hrel : ∀ τ : ℍ, H τ ^ d + ∑ n ∈ Finset.range d, c n τ * H τ ^ n = 0) :
+    IsBoundedAtImInfty H := by
+  classical
+  choose! C hC using fun n (hn : n < d) ↦ isBigO_iff.mp (hc n hn)
+  simp only [Pi.one_apply, norm_one, mul_one] at hC
+  have hCev : ∀ᶠ τ in atImInfty, ∀ n ∈ Finset.range d, ‖c n τ‖ ≤ C n :=
+    eventually_all_finset (Finset.range d) |>.mpr fun n hn ↦ hC n (Finset.mem_range.mp hn)
+  refine IsBigO.of_bound (1 + ∑ n ∈ Finset.range d, C n) (hCev.mono fun τ hτ ↦ ?_)
+  rw [Pi.one_apply, norm_one, mul_one]
+  calc ‖H τ‖ ≤ 1 + ∑ n ∈ Finset.range d, ‖c n τ‖ :=
+        norm_le_of_monicRel (a := fun n ↦ c n τ) (hrel τ)
+    _ ≤ 1 + ∑ n ∈ Finset.range d, C n := by gcongr with n hn; exact hτ n hn
+
+end Division
+
+section CuspCriterion
+
+variable {N : ℕ}
+
+lemma isBoundedAtImInfty_discriminant : IsBoundedAtImInfty (⇑CuspForm.discriminant : ℍ → ℂ) :=
+  (CuspFormClass.zero_at_infty CuspForm.discriminant).boundedAtFilter
+
+lemma isBoundedAtImInfty_discPow (n : ℕ) :
+    IsBoundedAtImInfty (⇑CuspForm.discriminant ^ n : ℍ → ℂ) := by
+  induction n with
+  | zero => exact pow_zero (⇑CuspForm.discriminant : ℍ → ℂ) ▸ Filter.const_boundedAtFilter _ (1 : ℂ)
+  | succ k ih =>
+    rw [pow_succ]
+    exact ih.mul isBoundedAtImInfty_discriminant
+
+lemma IsBoundedAtImInfty.mul_discPow_mono {f : ℍ → ℂ} {m m' : ℕ} (hm : m ≤ m')
+    (h : IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m)) :
+    IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m') := by
+  have hshape : (f * ⇑CuspForm.discriminant ^ m' : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m) * ⇑CuspForm.discriminant ^ (m' - m) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply]
+    rw [mul_assoc, ← pow_add, Nat.add_sub_cancel' hm]
+  rw [hshape]
+  exact h.mul (isBoundedAtImInfty_discPow (m' - m))
+
+def discPowForm (m : ℕ) : ModularForm 𝒮ℒ (12 * m) :=
+  ModularForm.mcast (by ring) ((CuspForm.toModularFormₗ CuspForm.discriminant).pow m)
+
+lemma discPowForm_coe (m : ℕ) : ⇑(discPowForm m) = ⇑CuspForm.discriminant ^ m := by
+  funext z
+  simp [discPowForm, ModularForm.coe_mcast, ModularForm.coe_pow,
+    CuspForm.toModularFormₗ_apply]
+
+lemma periodic_one_fn (c : ℝ) : Function.Periodic ((1 : ℍ → ℂ) ∘ ofComplex) c := fun _ => rfl
+
+lemma periodic_discPow_comp_ofComplex (k : ℕ) (N : ℕ) :
+    Function.Periodic ((⇑CuspForm.discriminant ^ k : ℍ → ℂ) ∘ ofComplex) N := by
+  have h1 : Function.Periodic (⇑CuspForm.discriminant ∘ ofComplex) 1 :=
+    SlashInvariantFormClass.periodic_comp_ofComplex CuspForm.discriminant
+      one_mem_strictPeriods_SL
+  have hk : Function.Periodic ((⇑CuspForm.discriminant ^ k : ℍ → ℂ) ∘ ofComplex) 1 := by
+    induction k with
+    | zero => exact periodic_one_fn 1
+    | succ k ih =>
+      intro x
+      have hx := (ih.mul h1) x
+      simp only [Function.comp_apply, Pi.mul_apply, Pi.pow_apply] at hx ⊢
+      rw [pow_succ, pow_succ]
+      exact hx
+  simpa using hk.nat_mul N
+
+lemma mdiff_discPow (k : ℕ) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (⇑CuspForm.discriminant ^ k : ℍ → ℂ) := by
+  rw [← discPowForm_coe]
+  exact (discPowForm k).holo'
+
+lemma mdiff_mul_discPow {f : ℍ → ℂ} (hf : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) (m : ℕ) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (f * ⇑CuspForm.discriminant ^ m : ℍ → ℂ) :=
+  hf.mul (mdiff_discPow m)
+
+lemma analyticAt_cuspFunction_zero_of [NeZero N] {g : ℍ → ℂ}
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hper : Function.Periodic (g ∘ ofComplex) N) (hbd : IsBoundedAtImInfty g) :
+    AnalyticAt ℂ (cuspFunction N g) 0 :=
+  analyticAt_cuspFunction_zero
+    (by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)) hper hhol hbd
+
+lemma qExpansion_one_discPowForm (k : ℕ) :
+    qExpansion 1 (discPowForm k) = (qExpansion 1 ModularForm.discriminant) ^ k := by
+  rw [discPowForm, ModularForm.qExpansion_mcast,
+    ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+  have hco : (⇑(CuspForm.toModularFormₗ CuspForm.discriminant) : ℍ → ℂ) =
+      ModularForm.discriminant := by
+    funext z
+    rw [CuspForm.toModularFormₗ_apply]
+    exact congrFun CuspForm.coe_discriminant z
+  rw [hco]
+
+lemma qExpansion_one_discPow (k : ℕ) :
+    qExpansion 1 (⇑CuspForm.discriminant ^ k : ℍ → ℂ) =
+      (qExpansion 1 ModularForm.discriminant) ^ k := by
+  rw [← discPowForm_coe]
+  exact qExpansion_one_discPowForm k
+
+lemma qParam_one_eq_pow {N : ℕ} (hN : N ≠ 0) (τ : ℂ) :
+    Function.Periodic.qParam 1 τ = Function.Periodic.qParam N τ ^ N := by
+  have : (N : ℂ) ≠ 0 := by exact_mod_cast hN
+  simp only [Function.Periodic.qParam, Complex.ofReal_one, div_one, Complex.ofReal_natCast]
+  rw [← Complex.exp_nat_mul]
+  congr 1
+  field_simp
+
+theorem qExpansion_coeff_width (f : ℍ → ℂ) {N : ℕ} (hN : N ≠ 0)
+    (hper : Function.Periodic (f ∘ ofComplex) 1) (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f)
+    (hbd : IsBoundedAtImInfty f) (n : ℕ) :
+    (qExpansion N f).coeff n =
+      if N ∣ n then (qExpansion 1 f).coeff (n / N) else 0 := by
+  have hN' : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero hN
+  have hperN : Function.Periodic (f ∘ ofComplex) N := by
+    simpa using hper.nat_mul N
+  let f' : C(ℍ, ℂ) := ⟨f, hhol.continuous⟩
+  have hfan : AnalyticAt ℂ (cuspFunction N f') 0 :=
+    analyticAt_cuspFunction_zero hN' hperN hhol hbd
+  set c : ℕ → ℂ := fun n ↦ if N ∣ n then (qExpansion 1 f).coeff (n / N) else 0 with hc
+  have hf : ∀ τ : ℍ, HasSum (fun m ↦ c m • Function.Periodic.qParam N τ ^ m) (f' τ) := by
+    intro τ
+    have h1 := hasSum_qExpansion one_pos hper hhol hbd τ
+    have hinj : Function.Injective fun m : ℕ ↦ N * m := fun a b h ↦ by
+      simpa [Nat.mul_right_inj hN] using h
+    refine (hinj.hasSum_iff (f := fun m ↦ c m • Function.Periodic.qParam N τ ^ m) ?_).mp ?_
+    · intro x hx
+      have : ¬ N ∣ x := fun ⟨k, hk⟩ ↦ hx ⟨k, hk.symm⟩
+      simp [hc, this]
+    · refine h1.congr_fun fun m ↦ ?_
+      simp only [Function.comp_apply, hc, Nat.dvd_mul_right, ite_true,
+        Nat.mul_div_cancel_left _ (Nat.pos_of_ne_zero hN), qParam_one_eq_pow hN, ← pow_mul]
+  exact (qExpansion_coeff_unique f' hN' hfan hf n).symm
+
+end CuspCriterion
+
+section RatCoeff
+
+p2m_open "UpperHalfPlane ModularForm SlashInvariantForm ModularFormClass CuspForm \
+  ModularForm.CuspForm EisensteinSeries"
+open scoped MatrixGroups ArithmeticFunction.sigma
+
+private lemma ratCoeff_mul {p q : PowerSeries ℂ}
+    (hp : ∀ n : ℕ, ∃ a : ℚ, p.coeff n = (a : ℂ)) (hq : ∀ n : ℕ, ∃ a : ℚ, q.coeff n = (a : ℂ)) :
+    ∀ n : ℕ, ∃ a : ℚ, (p * q).coeff n = (a : ℂ) := by
+  choose F hF using hp
+  choose G hG using hq
+  intro n
+  refine ⟨∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, F ij.1 * G ij.2, ?_⟩
+  rw [PowerSeries.coeff_mul]
+  push_cast
+  exact Finset.sum_congr rfl fun ij _ => by rw [hF, hG]
+
+private lemma ratCoeff_sub {p q : PowerSeries ℂ}
+    (hp : ∀ n : ℕ, ∃ a : ℚ, p.coeff n = (a : ℂ)) (hq : ∀ n : ℕ, ∃ a : ℚ, q.coeff n = (a : ℂ)) :
+    ∀ n : ℕ, ∃ a : ℚ, (p - q).coeff n = (a : ℂ) := by
+  intro n
+  obtain ⟨a, ha⟩ := hp n
+  obtain ⟨b, hb⟩ := hq n
+  exact ⟨a - b, by rw [map_sub, ha, hb]; push_cast; ring⟩
+
+private lemma ratCoeff_E {k : ℕ} (hk : 3 ≤ k) (hk2 : Even k) :
+    ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 (E hk)).coeff n = (q : ℂ) := by
+  intro n
+  rw [E_qExpansion_coeff hk hk2]
+  by_cases hn : n = 0
+  · exact ⟨1, by simp [hn]⟩
+  · refine ⟨-(2 * k / _root_.bernoulli k) * (σ (k - 1) n : ℚ), ?_⟩
+    rw [ite_eq_right hn]
+    push_cast
+    ring
+
+private lemma ratCoeff_pow {p : PowerSeries ℂ}
+    (hp : ∀ n : ℕ, ∃ a : ℚ, p.coeff n = (a : ℂ)) (k : ℕ) :
+    ∀ n : ℕ, ∃ a : ℚ, (p ^ k).coeff n = (a : ℂ) := by
+  induction k with
+  | zero =>
+    intro n
+    rw [pow_zero]
+    by_cases hn : n = 0
+    · exact ⟨1, by simp [hn, PowerSeries.coeff_one]⟩
+    · exact ⟨0, by simp [PowerSeries.coeff_one, hn]⟩
+  | succ k ih =>
+    rw [pow_succ]
+    exact ratCoeff_mul ih hp
+
+private def eCubeSubESq : ModularForm 𝒮ℒ 12 :=
+  ModularForm.mcast (by decide) (E₄.pow 3) - ModularForm.mcast (by decide) (E₆.pow 2)
+
+private lemma eCubeSubESq_qExpansion :
+    qExpansion 1 eCubeSubESq = qExpansion 1 E₄ * qExpansion 1 E₄ * qExpansion 1 E₄ -
+      qExpansion 1 E₆ * qExpansion 1 E₆ := by
+  simp only [eCubeSubESq, FunLike.coe_sub, ModularForm.coe_mcast,
+    ModularForm.qExpansion_sub one_pos one_mem_strictPeriods_SL,
+    ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+  ring
+
+private lemma discriminant_eq_smul_eCubeSubESq :
+    ModularForm.discriminant = (1 / 1728 : ℂ) • eCubeSubESq := by
+  ext z
+  have h := discriminant_eq_E₄_cube_sub_E₆_sq z
+  simp only [Pi.smul_apply, eCubeSubESq, FunLike.coe_sub, Pi.sub_apply,
+    ModularForm.coe_mcast, ModularForm.coe_pow, Pi.pow_apply, smul_eq_mul]
+  rw [h]
+  ring
+
+private lemma ratCoeff_discriminant :
+    ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 ModularForm.discriminant).coeff n = (q : ℂ) := by
+  have h4 : ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 E₄).coeff n = (q : ℂ) :=
+    ratCoeff_E (by norm_num) (by decide)
+  have h6 : ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 E₆).coeff n = (q : ℂ) :=
+    ratCoeff_E (by norm_num) (by decide)
+  have hmain := ratCoeff_sub (ratCoeff_mul (ratCoeff_mul h4 h4) h4) (ratCoeff_mul h6 h6)
+  intro n
+  obtain ⟨a, ha⟩ := hmain n
+  refine ⟨(1 / 1728 : ℚ) * a, ?_⟩
+  rw [discriminant_eq_smul_eCubeSubESq,
+    ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL,
+    PowerSeries.coeff_smul, eCubeSubESq_qExpansion, smul_eq_mul, ha]
+  push_cast
+  ring
+
+end RatCoeff
+
+section KPoleAlgebra
+
+open ModularForm
+
+variable {N : ℕ}
+
+lemma mem_of_rat (K : IntermediateField ℚ ℂ) {x : ℂ} (h : ∃ q : ℚ, x = (q : ℂ)) : x ∈ K := by
+  obtain ⟨q, rfl⟩ := h
+  exact SubfieldClass.ratCast_mem K q
+
+private def KPoleAt (K : IntermediateField ℚ ℂ) (N m : ℕ) (f : ℍ → ℂ) : Prop :=
+  Function.Periodic ((f * ⇑CuspForm.discriminant ^ m) ∘ ofComplex) N ∧
+    IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m) ∧
+    ∀ n : ℕ, (qExpansion N (f * ⇑CuspForm.discriminant ^ m)).coeff n ∈ K
+
+private def KPole (K : IntermediateField ℚ ℂ) (N : ℕ) (f : ℍ → ℂ) : Prop :=
+  MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f ∧ ∃ m : ℕ, KPoleAt K N m f
+
+private lemma qExpansion_discPow_coeff_mem (K : IntermediateField ℚ ℂ) [NeZero N] (k n : ℕ) :
+    (qExpansion N (⇑CuspForm.discriminant ^ k : ℍ → ℂ)).coeff n ∈ K := by
+  have hper : Function.Periodic
+      ((⇑CuspForm.discriminant ^ k : ℍ → ℂ) ∘ ofComplex) (1 : ℂ) := by
+    have h := periodic_discPow_comp_ofComplex k 1
+    simpa only [Nat.cast_one] using h
+  rw [qExpansion_coeff_width _ (NeZero.ne N) hper (mdiff_discPow k)
+    (isBoundedAtImInfty_discPow k), qExpansion_one_discPow]
+  split
+  · exact mem_of_rat K (ratCoeff_pow ratCoeff_discriminant k _)
+  · exact zero_mem _
+
+private lemma KPoleAt.pad {K : IntermediateField ℚ ℂ} [NeZero N] {f : ℍ → ℂ} {m m' : ℕ}
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) (hm : m ≤ m') (h : KPoleAt K N m f) :
+    KPoleAt K N m' f := by
+  obtain ⟨hper, hbd, hmem⟩ := h
+  have hshape : (f * ⇑CuspForm.discriminant ^ m' : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m) * ⇑CuspForm.discriminant ^ (m' - m) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply]
+    rw [mul_assoc, ← pow_add, Nat.add_sub_cancel' hm]
+  refine ⟨?_, ?_, ?_⟩
+  · rw [hshape]
+    exact hper.mul (periodic_discPow_comp_ofComplex (m' - m) N)
+  · exact IsBoundedAtImInfty.mul_discPow_mono hm hbd
+  · intro n
+    rw [hshape, qExpansion_mul
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hhol m) hper hbd)
+      (analyticAt_cuspFunction_zero_of (mdiff_discPow (m' - m))
+        (periodic_discPow_comp_ofComplex (m' - m) N) (isBoundedAtImInfty_discPow (m' - m))),
+      PowerSeries.coeff_mul]
+    exact sum_mem fun ij _ => mul_mem (hmem ij.1) (qExpansion_discPow_coeff_mem K _ ij.2)
+
+private lemma kPole_algebraMap {K : IntermediateField ℚ ℂ} [NeZero N] (c : ↥K) :
+    KPole K N (algebraMap ↥K (ℍ → ℂ) c) := by
+  have hshape : ((algebraMap ↥K (ℍ → ℂ) c) * ⇑CuspForm.discriminant ^ 0 : ℍ → ℂ) =
+      (c : ℂ) • (1 : ℍ → ℂ) := by
+    funext τ
+    simp only [Pi.mul_apply, pow_zero, mul_one, Pi.smul_apply, Pi.one_apply,
+      smul_eq_mul]
+    rfl
+  have hone_bd : IsBoundedAtImInfty (1 : ℍ → ℂ) := by
+    have h1 : (1 : ℍ → ℂ) = fun _ : ℍ => (1 : ℂ) := rfl
+    rw [h1]
+    exact Filter.const_boundedAtFilter _ _
+  refine ⟨mdifferentiable_const, 0, ?_, ?_, ?_⟩
+  · rw [hshape]
+    intro x
+    rfl
+  · rw [hshape]
+    have hc : ((c : ℂ) • (1 : ℍ → ℂ)) = fun _ : ℍ => (c : ℂ) := by
+      funext τ
+      simp
+    rw [hc]
+    exact Filter.const_boundedAtFilter _ _
+  · intro n
+    have han : AnalyticAt ℂ (cuspFunction N (1 : ℍ → ℂ)) 0 :=
+      analyticAt_cuspFunction_zero_of (g := (1 : ℍ → ℂ)) mdifferentiable_const
+        (periodic_one_fn N) hone_bd
+    rw [hshape, qExpansion_smul han,
+      qExpansion_one, PowerSeries.coeff_smul, smul_eq_mul, PowerSeries.coeff_one]
+    split
+    · rw [mul_one]
+      exact c.2
+    · rw [mul_zero]
+      exact zero_mem _
+
+private lemma KPole.add {K : IntermediateField ℚ ℂ} [NeZero N] {f g : ℍ → ℂ}
+    (hf : KPole K N f) (hg : KPole K N g) : KPole K N (f + g) := by
+  obtain ⟨hf1, m1, hfd⟩ := hf
+  obtain ⟨hg1, m2, hgd⟩ := hg
+  obtain ⟨hfper, hfbd, hfmem⟩ := hfd.pad hf1 (le_max_left m1 m2)
+  obtain ⟨hgper, hgbd, hgmem⟩ := hgd.pad hg1 (le_max_right m1 m2)
+  have hshape : ((f + g) * ⇑CuspForm.discriminant ^ max m1 m2 : ℍ → ℂ) =
+      f * ⇑CuspForm.discriminant ^ max m1 m2 + g * ⇑CuspForm.discriminant ^ max m1 m2 := by
+    funext τ
+    simp [add_mul]
+  refine ⟨hf1.add hg1, max m1 m2, ?_, ?_, ?_⟩
+  · rw [hshape]
+    exact hfper.add hgper
+  · rw [hshape]
+    exact hfbd.add hgbd
+  · intro n
+    rw [hshape, qExpansion_add
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hf1 _) hfper hfbd)
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hg1 _) hgper hgbd),
+      map_add]
+    exact add_mem (hfmem n) (hgmem n)
+
+private lemma KPole.mul {K : IntermediateField ℚ ℂ} [NeZero N] {f g : ℍ → ℂ}
+    (hf : KPole K N f) (hg : KPole K N g) : KPole K N (f * g) := by
+  obtain ⟨hf1, m1, hfper, hfbd, hfmem⟩ := hf
+  obtain ⟨hg1, m2, hgper, hgbd, hgmem⟩ := hg
+  have hshape : ((f * g) * ⇑CuspForm.discriminant ^ (m1 + m2) : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m1) * (g * ⇑CuspForm.discriminant ^ m2) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply, pow_add]
+    ring
+  refine ⟨hf1.mul hg1, m1 + m2, ?_, ?_, ?_⟩
+  · rw [hshape]
+    exact hfper.mul hgper
+  · rw [hshape]
+    exact hfbd.mul hgbd
+  · intro n
+    rw [hshape, qExpansion_mul
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hf1 _) hfper hfbd)
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hg1 _) hgper hgbd),
+      PowerSeries.coeff_mul]
+    exact sum_mem fun ij _ => mul_mem (hfmem ij.1) (hgmem ij.2)
+
+private lemma kPole_jf (K : IntermediateField ℚ ℂ) [NeZero N] {jf : ℍ → ℂ}
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) :
+    KPole K N jf := by
+  have hshape : (jf * ⇑CuspForm.discriminant ^ 1 : ℍ → ℂ) = ⇑(ModularForm.E₄.pow 3) := by
+    funext τ
+    rw [congrFun (ModularForm.coe_pow ModularForm.E₄ 3) τ, Pi.pow_apply]
+    simp only [Pi.mul_apply, pow_one, hjf τ]
+    rw [congrFun CuspForm.coe_discriminant τ]
+    exact div_mul_cancel₀ _ (ModularForm.discriminant_ne_zero τ)
+  have hhol3 : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (⇑(ModularForm.E₄.pow 3) : ℍ → ℂ) :=
+    (ModularForm.E₄.pow 3).holo'
+  have hbd3 : IsBoundedAtImInfty (⇑(ModularForm.E₄.pow 3) : ℍ → ℂ) :=
+    ModularFormClass.bdd_at_infty (ModularForm.E₄.pow 3)
+  have hper3 : Function.Periodic ((⇑(ModularForm.E₄.pow 3) : ℍ → ℂ) ∘ ofComplex) 1 :=
+    SlashInvariantFormClass.periodic_comp_ofComplex (ModularForm.E₄.pow 3)
+      one_mem_strictPeriods_SL
+  have hjmd : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) jf := by
+    have : jf = fun τ => ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ := funext hjf
+    rw [this]
+    exact (ModularForm.E₄.holo'.pow 3).div CuspForm.discriminant.holo'
+      ModularForm.discriminant_ne_zero
+  refine ⟨hjmd, 1, ?_, ?_, ?_⟩
+  · rw [hshape]
+    simpa using hper3.nat_mul N
+  · rw [hshape]
+    exact hbd3
+  · intro n
+    rw [hshape, qExpansion_coeff_width (⇑(ModularForm.E₄.pow 3) : ℍ → ℂ) (NeZero.ne N)
+      hper3 hhol3 hbd3]
+    split
+    · have he : qExpansion 1 (⇑(ModularForm.E₄.pow 3) : ℍ → ℂ) =
+          (qExpansion 1 ModularForm.E₄) ^ 3 :=
+        ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL ModularForm.E₄ 3
+      rw [he]
+      exact mem_of_rat K (ratCoeff_pow (ratCoeff_E (by norm_num) (by decide)) 3 _)
+    · exact zero_mem _
+
+end KPoleAlgebra
+
+section HeadTwo
+
+open ModularForm
+
+variable {N : ℕ}
+
+private theorem mdifferentiable_eq_zero_or_eq_zero_of_mul_eq_zero {f g : ℍ → ℂ}
+    (hf : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) (hg : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hfg : f * g = 0) : f = 0 ∨ g = 0 := by
+  rw [UpperHalfPlane.mdifferentiable_iff] at hf hg
+  have hU : IsOpen {z : ℂ | 0 < z.im} := isOpen_upperHalfPlaneSet
+  have key := AnalyticOnNhd.eq_zero_or_eq_zero_of_mul_eq_zero (hf.analyticOnNhd hU)
+    (hg.analyticOnNhd hU) (fun z hz ↦ by
+      have := congrFun hfg (ofComplex z)
+      simpa using this) (convex_halfSpace_im_gt 0).isPreconnected
+  rcases key with k | k
+  · left; funext τ; simpa [ofComplex_apply] using k (τ : ℂ) τ.im_pos
+  · right; funext τ; simpa [ofComplex_apply] using k (τ : ℂ) τ.im_pos
+
+private lemma jf_smul {jf : ℍ → ℂ}
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) (τ : ℍ) : jf (γ • τ) = jf τ := by
+  have hγ : (Matrix.SpecialLinearGroup.mapGL ℝ γ : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ, rfl⟩
+  have h4 := SlashInvariantForm.slash_action_eqn'' ModularForm.E₄ hγ τ
+  have hΔ := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hγ τ
+  rw [CuspForm.coe_discriminant] at hΔ
+  rw [show (Matrix.SpecialLinearGroup.mapGL ℝ γ) • τ = γ • τ from rfl] at h4 hΔ
+  have hd : denom (Matrix.SpecialLinearGroup.mapGL ℝ γ) τ ≠ 0 := denom_ne_zero _ τ
+  have hΔ0 : ModularForm.discriminant τ ≠ 0 := ModularForm.discriminant_ne_zero τ
+  rw [hjf, hjf, h4, hΔ, zpow_ofNat, zpow_ofNat]
+  field_simp
+
+private lemma map_castRingHom_eq_one {γ : Matrix.SpecialLinearGroup (Fin 2) ℤ}
+    (hγ : γ ∈ CongruenceSubgroup.Gamma N) :
+    ((Matrix.SpecialLinearGroup.map (Int.castRingHom (ZMod N)) γ :
+      Matrix.SpecialLinearGroup (Fin 2) (ZMod N)) : Matrix (Fin 2) (Fin 2) (ZMod N)) = 1 := by
+  rw [CongruenceSubgroup.Gamma_mem'] at hγ
+  rw [hγ, Matrix.SpecialLinearGroup.coe_one]
+
+private def precompSmul (γ : Matrix.SpecialLinearGroup (Fin 2) ℤ) :
+    (ℍ → ℂ) →ₐ[ℂ] (ℍ → ℂ) where
+  toFun f := f ∘ (γ • ·)
+  map_one' := rfl
+  map_mul' _ _ := rfl
+  map_zero' := rfl
+  map_add' _ _ := rfl
+  commutes' _ := rfl
+
+private lemma KPole.pow {K : IntermediateField ℚ ℂ} [NeZero N] {g : ℍ → ℂ}
+    (hg : KPole K N g) (e : ℕ) : KPole K N (g ^ e) := by
+  induction e with
+  | zero =>
+    have h1 : (g ^ 0 : ℍ → ℂ) = algebraMap ↥K (ℍ → ℂ) 1 := by
+      funext τ; simp
+    rw [h1]
+    exact kPole_algebraMap 1
+  | succ k ih =>
+    rw [pow_succ]
+    exact ih.mul hg
+
+private lemma KPole.finsetSum {K : IntermediateField ℚ ℂ} [NeZero N] {ι : Type*}
+    (s : Finset ι) {f : ι → ℍ → ℂ} (hf : ∀ i ∈ s, KPole K N (f i)) :
+    KPole K N (∑ i ∈ s, f i) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty =>
+    rw [Finset.sum_empty]
+    have h0 : (0 : ℍ → ℂ) = algebraMap ↥K (ℍ → ℂ) 0 := by funext τ; simp
+    rw [h0]
+    exact kPole_algebraMap 0
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha]
+    exact (hf a (Finset.mem_insert_self a s)).add
+      (ih fun i hi => hf i (Finset.mem_insert_of_mem hi))
+
+private lemma KPole.finsetProd {K : IntermediateField ℚ ℂ} [NeZero N] {ι : Type*}
+    (s : Finset ι) {f : ι → ℍ → ℂ} (hf : ∀ i ∈ s, KPole K N (f i)) :
+    KPole K N (∏ i ∈ s, f i) := by
+  classical
+  induction s using Finset.induction_on with
+  | empty =>
+    rw [Finset.prod_empty]
+    have h1 : (1 : ℍ → ℂ) = algebraMap ↥K (ℍ → ℂ) 1 := by funext τ; simp
+    rw [h1]
+    exact kPole_algebraMap 1
+  | insert a s ha ih =>
+    rw [Finset.prod_insert ha]
+    exact (hf a (Finset.mem_insert_self a s)).mul
+      (ih fun i hi => hf i (Finset.mem_insert_of_mem hi))
+
+private lemma kPole_polyEval {K : IntermediateField ℚ ℂ} [NeZero N] {g : ℍ → ℂ}
+    (hg : KPole K N g) {P : Polynomial ℂ} (hP : ∀ n, P.coeff n ∈ K) :
+    KPole K N (fun τ => P.eval (g τ)) := by
+  classical
+  have hfun : (fun τ => P.eval (g τ)) =
+      ∑ e ∈ P.support, (fun τ => P.coeff e * g τ ^ e) := by
+    funext τ
+    rw [Finset.sum_apply, Polynomial.eval_eq_sum, Polynomial.sum_def]
+  rw [hfun]
+  refine KPole.finsetSum _ fun e _ => ?_
+  have hconst : KPole K N (algebraMap ↥K (ℍ → ℂ) ⟨P.coeff e, hP e⟩) := kPole_algebraMap _
+  have := hconst.mul (hg.pow e)
+  have hshape : algebraMap ↥K (ℍ → ℂ) ⟨P.coeff e, hP e⟩ * g ^ e =
+      fun τ => P.coeff e * g τ ^ e := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply]
+    rfl
+  rwa [hshape] at this
+
+private lemma kPole_aeval {K : IntermediateField ℚ ℂ} [NeZero N] {σ : Type*}
+    {gen : σ → ℍ → ℂ} (hgen : ∀ i, KPole K N (gen i))
+    {P : MvPolynomial σ ℂ} (hP : ∀ m, P.coeff m ∈ K) :
+    KPole K N (MvPolynomial.aeval gen P) := by
+  classical
+  rw [MvPolynomial.aeval_def, MvPolynomial.eval₂_eq]
+  refine KPole.finsetSum _ fun d _ => ?_
+  have hconst : KPole K N ((algebraMap ℂ (ℍ → ℂ)) (P.coeff d)) := by
+    have h1 : (algebraMap ℂ (ℍ → ℂ)) (P.coeff d) =
+        algebraMap ↥K (ℍ → ℂ) ⟨P.coeff d, hP d⟩ := rfl
+    rw [h1]
+    exact kPole_algebraMap _
+  exact hconst.mul (KPole.finsetProd _ fun i _ => (hgen i).pow (d i))
+
+theorem exists_qExpansion_coeff_mem_of_mdifferentiable_levelFraction_of_deps
+    (N : ℕ) [NeZero N]
+    (L : ℍ → PeriodPair) (hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), W v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (jf : ℍ → ℂ)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    (K : IntermediateField ℚ ℂ)
+    (hK : K = IntermediateField.adjoin ℚ
+      {Complex.exp (2 * (Real.pi : ℂ) * Complex.I / (N : ℂ))})
+    (hR2 : ∀ v : Fin 2 → ZMod N, v ≠ 0 → ∃ m : ℕ,
+      Function.Periodic ((fricke v * ModularForm.discriminant ^ m) ∘ UpperHalfPlane.ofComplex) N ∧
+      IsBoundedAtImInfty (fricke v * ModularForm.discriminant ^ m) ∧
+      ∀ n : ℕ, (UpperHalfPlane.qExpansion N (fricke v * ModularForm.discriminant ^ m)).coeff n ∈ K)
+    (hR4a : ∀ v : Fin 2 → ZMod N, v ≠ 0 → MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fricke v))
+    (hR4c : ∀ (v : Fin 2 → ZMod N) (γ : SL(2, ℤ)) (τ : ℍ),
+      fricke v (γ • τ) = fricke (Matrix.vecMul v
+        ((Matrix.SpecialLinearGroup.map (Int.castRingHom (ZMod N)) γ :
+          Matrix.SpecialLinearGroup (Fin 2) (ZMod N)) : Matrix (Fin 2) (Fin 2) (ZMod N))) τ)
+    {G : ℍ → ℂ} (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (P Q : MvPolynomial (Option {v : Fin 2 → ZMod N // v ≠ 0}) ℂ)
+    (hPK : ∀ m, P.coeff m ∈ K) (hQK : ∀ m, Q.coeff m ∈ K)
+    (hQ0 : MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+      o.elim jf fun v => fricke v.1) Q ≠ 0)
+    (hGQ : G * MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+        o.elim jf fun v => fricke v.1) Q =
+      MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+        o.elim jf fun v => fricke v.1) P)
+    (hint : ∃ (d : ℕ) (p : Fin d → Polynomial ℂ), (∀ (i : Fin d) (n : ℕ), (p i).coeff n ∈ K) ∧
+      ∀ τ : ℍ, G τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * G τ ^ (i : ℕ) = 0) :
+    ∃ m : ℕ, Function.Periodic ((G * ModularForm.discriminant ^ m) ∘ UpperHalfPlane.ofComplex) N ∧
+      IsBoundedAtImInfty (G * ModularForm.discriminant ^ m) ∧
+      ∀ n : ℕ, (UpperHalfPlane.qExpansion N (G * ModularForm.discriminant ^ m)).coeff n ∈ K := by
+  classical
+  have _hL := hL
+  have _hW := hW
+  have _hfricke := hfricke
+  have _hK := hK
+  rw [show (ModularForm.discriminant : ℍ → ℂ) = ⇑CuspForm.discriminant from
+    CuspForm.coe_discriminant.symm]
+  simp only [show (ModularForm.discriminant : ℍ → ℂ) = ⇑CuspForm.discriminant from
+    CuspForm.coe_discriminant.symm] at hR2
+  set gen : Option {v : Fin 2 → ZMod N // v ≠ 0} → ℍ → ℂ :=
+    fun o => o.elim jf fun v => fricke v.1 with hgen_def
+  have hgenKP : ∀ o, KPole K N (gen o) := by
+    intro o
+    cases o with
+    | none => exact kPole_jf K hjf
+    | some v =>
+      obtain ⟨m, hper, hbd, hmem⟩ := hR2 v.1 v.2
+      exact ⟨hR4a v.1 v.2, m, hper, hbd, hmem⟩
+  set Ptil : ℍ → ℂ := MvPolynomial.aeval gen P with hPtil_def
+  set Qtil : ℍ → ℂ := MvPolynomial.aeval gen Q with hQtil_def
+  have hPKP : KPole K N Ptil := kPole_aeval hgenKP hPK
+  have hQKP : KPole K N Qtil := kPole_aeval hgenKP hQK
+  obtain ⟨hPmd, mP, hPat⟩ := hPKP
+  obtain ⟨hQmd, mQ, hQat⟩ := hQKP
+  have hgen_inv : ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ o, gen o ∘ (γ • ·) = gen o := by
+    intro γ hγ o
+    cases o with
+    | none =>
+      funext τ
+      exact jf_smul hjf γ τ
+    | some v =>
+      funext τ
+      change fricke v.1 (γ • τ) = fricke v.1 τ
+      rw [hR4c v.1 γ τ, map_castRingHom_eq_one hγ, Matrix.vecMul_one]
+  have haeval_inv : ∀ γ ∈ CongruenceSubgroup.Gamma N,
+      ∀ R : MvPolynomial (Option {v : Fin 2 → ZMod N // v ≠ 0}) ℂ,
+        MvPolynomial.aeval gen R ∘ (γ • ·) = MvPolynomial.aeval gen R := by
+    intro γ hγ R
+    have h1 : MvPolynomial.aeval gen R ∘ (γ • ·) = precompSmul γ (MvPolynomial.aeval gen R) := rfl
+    rw [h1, MvPolynomial.comp_aeval_apply]
+    have hfam : (fun i => precompSmul γ (gen i)) = gen :=
+      funext fun o => hgen_inv γ hγ o
+    rw [hfam]
+  have hGinv : ∀ γ ∈ CongruenceSubgroup.Gamma N, G ∘ (γ • ·) = G := by
+    intro γ hγ
+    have hdiff : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (G ∘ (γ • ·) - G) := by
+      refine MDifferentiable.sub ?_ hG
+      have h1 : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (G ∣[(0 : ℤ)] γ) := hG.slash 0 _
+      have h2 : G ∣[(0 : ℤ)] γ = G ∘ (γ • ·) := by
+        funext τ
+        simp only [ModularForm.SL_slash_apply, neg_zero, zpow_zero, mul_one]
+        rfl
+      rwa [h2] at h1
+    have hprod : (G ∘ (γ • ·) - G) * Qtil = 0 := by
+      funext τ
+      have h1 : G (γ • τ) * Qtil (γ • τ) = Ptil (γ • τ) := congrFun hGQ (γ • τ)
+      have h2 : G τ * Qtil τ = Ptil τ := congrFun hGQ τ
+      have hQγ : Qtil (γ • τ) = Qtil τ := congrFun (haeval_inv γ hγ Q) τ
+      have hPγ : Ptil (γ • τ) = Ptil τ := congrFun (haeval_inv γ hγ P) τ
+      simp only [Pi.mul_apply, Pi.sub_apply, Pi.zero_apply, Function.comp_apply]
+      rw [sub_mul, h2]
+      rw [show G (γ • τ) * Qtil τ = G (γ • τ) * Qtil (γ • τ) by rw [hQγ], h1, hPγ, sub_self]
+    rcases mdifferentiable_eq_zero_or_eq_zero_of_mul_eq_zero hdiff hQmd hprod with h | h
+    · funext τ
+      have := congrFun h τ
+      simpa [sub_eq_zero] using this
+    · exact absurd h hQ0
+  have hGper : Function.Periodic (G ∘ ofComplex) N := by
+    have hT : ModularGroup.T ^ (N : ℤ) ∈ CongruenceSubgroup.Gamma N := by
+      have := CongruenceSubgroup.ModularGroup_T_pow_mem_Gamma N N (dvd_refl _)
+      rwa [Int.natAbs_natCast] at this
+    intro w
+    by_cases hw : 0 < Complex.im w
+    · have hw' : 0 < Complex.im (w + N) := by simpa using hw
+      simp only [Function.comp_apply, ofComplex_apply_of_im_pos hw',
+        ofComplex_apply_of_im_pos hw]
+      have := congrFun (hGinv _ hT) ⟨w, hw⟩
+      simp only [Function.comp_apply] at this
+      rw [UpperHalfPlane.modular_T_zpow_smul] at this
+      rw [← this]
+      congr 1
+      apply UpperHalfPlane.ext
+      simp [UpperHalfPlane.coe_vadd, add_comm]
+    · have hw0 : Complex.im w ≤ 0 := not_lt.mp hw
+      have hw' : Complex.im (w + N) ≤ 0 := by simpa using hw0
+      simp only [Function.comp_apply, ofComplex_apply_of_im_nonpos hw',
+        ofComplex_apply_of_im_nonpos hw0]
+  obtain ⟨d, p, hpK, hprel⟩ := hint
+  have hcKP : ∀ i : Fin d, KPole K N (fun τ => (p i).eval (jf τ)) := fun i =>
+    kPole_polyEval (kPole_jf K hjf) (hpK i)
+  choose mc hmc using fun i : Fin d => (hcKP i).2
+  set M₀ : ℕ := 1 + Finset.univ.sup mc with hM₀_def
+  have hbdG : IsBoundedAtImInfty (G * ⇑CuspForm.discriminant ^ M₀) := by
+    refine isBoundedAtImInfty_of_monicRel
+      (c := fun n => if hn : n < d then
+        (fun τ => (p ⟨n, hn⟩).eval (jf τ)) * ⇑CuspForm.discriminant ^ (M₀ * (d - n)) else 0)
+      (d := d) ?_ ?_
+    · intro n hn
+      simp only [dite_eq_left hn]
+      have h1 : IsBoundedAtImInfty ((fun τ => (p ⟨n, hn⟩).eval (jf τ)) *
+          ⇑CuspForm.discriminant ^ mc ⟨n, hn⟩) := (hmc ⟨n, hn⟩).2.1
+      refine IsBoundedAtImInfty.mul_discPow_mono ?_ h1
+      calc mc ⟨n, hn⟩ ≤ Finset.univ.sup mc := Finset.le_sup (Finset.mem_univ _)
+        _ ≤ M₀ * 1 := by omega
+        _ ≤ M₀ * (d - n) := by
+            have : 1 ≤ d - n := by omega
+            exact Nat.mul_le_mul_left M₀ this
+    · intro τ
+      have h0 := hprel τ
+      have hΔ : CuspForm.discriminant τ ≠ 0 := by
+        rw [congrFun CuspForm.coe_discriminant τ]
+        exact ModularForm.discriminant_ne_zero τ
+      have hkey : (G τ * CuspForm.discriminant τ ^ M₀) ^ d
+          + ∑ n ∈ Finset.range d, ((if hn : n < d then
+              ((fun τ' => (p ⟨n, hn⟩).eval (jf τ')) * ⇑CuspForm.discriminant ^ (M₀ * (d - n)))
+            else 0) τ) * (G τ * CuspForm.discriminant τ ^ M₀) ^ n
+          = CuspForm.discriminant τ ^ (M₀ * d) *
+            (G τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * G τ ^ (i : ℕ)) := by
+        rw [mul_add, Finset.mul_sum]
+        congr 1
+        · rw [mul_pow, ← pow_mul]
+          ring
+        · rw [← Fin.sum_univ_eq_sum_range (fun n => ((if hn : n < d then
+              ((fun τ' => (p ⟨n, hn⟩).eval (jf τ')) *
+                ⇑CuspForm.discriminant ^ (M₀ * (d - n)))
+            else 0) τ) * (G τ * CuspForm.discriminant τ ^ M₀) ^ n) d]
+          refine Finset.sum_congr rfl fun i _ => ?_
+          rw [dite_eq_left i.isLt]
+          simp only [Pi.mul_apply, Pi.pow_apply]
+          rw [mul_pow, ← pow_mul]
+          have hexp : M₀ * (d - (i : ℕ)) + M₀ * (i : ℕ) = M₀ * d := by
+            rw [← Nat.mul_add, Nat.sub_add_cancel i.isLt.le]
+          calc (p i).eval (jf τ) * CuspForm.discriminant τ ^ (M₀ * (d - (i : ℕ))) *
+                (G τ ^ (i : ℕ) * CuspForm.discriminant τ ^ (M₀ * (i : ℕ)))
+              = CuspForm.discriminant τ ^ (M₀ * (d - (i : ℕ)) + M₀ * (i : ℕ)) *
+                ((p i).eval (jf τ) * G τ ^ (i : ℕ)) := by ring
+            _ = CuspForm.discriminant τ ^ (M₀ * d) *
+                ((p i).eval (jf τ) * G τ ^ (i : ℕ)) := by rw [hexp]
+      simp only [Pi.mul_apply, Pi.pow_apply]
+      rw [hkey, h0, mul_zero]
+  set M : ℕ := M₀ + mP with hM_def
+  have hbdGM : IsBoundedAtImInfty (G * ⇑CuspForm.discriminant ^ M) :=
+    IsBoundedAtImInfty.mul_discPow_mono (by omega) hbdG
+  have hperGM : Function.Periodic ((G * ⇑CuspForm.discriminant ^ M) ∘ ofComplex) N :=
+    hGper.mul (periodic_discPow_comp_ofComplex M N)
+  refine ⟨M, hperGM, hbdGM, ?_⟩
+  have hPat' : ∀ n : ℕ, (qExpansion N (Ptil * ⇑CuspForm.discriminant ^ (mQ + M))).coeff n ∈ K :=
+    (hPat.pad hPmd (by omega)).2.2
+  obtain ⟨hQper, hQbd, hQmem⟩ := hQat
+  have hprod : (Qtil * ⇑CuspForm.discriminant ^ mQ) * (G * ⇑CuspForm.discriminant ^ M)
+      = Ptil * ⇑CuspForm.discriminant ^ (mQ + M) := by
+    funext τ
+    have h2 : G τ * Qtil τ = Ptil τ := congrFun hGQ τ
+    simp only [Pi.mul_apply, Pi.pow_apply, pow_add]
+    calc Qtil τ * CuspForm.discriminant τ ^ mQ * (G τ * CuspForm.discriminant τ ^ M)
+        = G τ * Qtil τ * (CuspForm.discriminant τ ^ mQ * CuspForm.discriminant τ ^ M) := by ring
+      _ = Ptil τ * (CuspForm.discriminant τ ^ mQ * CuspForm.discriminant τ ^ M) := by rw [h2]
+  have hN' : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  have hqmul : qExpansion N (Qtil * ⇑CuspForm.discriminant ^ mQ) *
+      qExpansion N (G * ⇑CuspForm.discriminant ^ M)
+        = qExpansion N (Ptil * ⇑CuspForm.discriminant ^ (mQ + M)) := by
+    rw [← qExpansion_mul (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hQmd mQ)
+        hQper hQbd)
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hG M) hperGM hbdGM), hprod]
+  have hg_ne : qExpansion N (Qtil * ⇑CuspForm.discriminant ^ mQ) ≠ 0 := by
+    rw [ne_eq, qExpansion_eq_zero_iff hN' hQper (mdiff_mul_discPow hQmd mQ) hQbd]
+    intro h0
+    refine hQ0 ?_
+    funext τ
+    have hτ := congrFun h0 τ
+    simp only [Pi.mul_apply, Pi.pow_apply, Pi.zero_apply] at hτ
+    have hΔ : CuspForm.discriminant τ ≠ 0 := by
+      rw [congrFun CuspForm.coe_discriminant τ]
+      exact ModularForm.discriminant_ne_zero τ
+    exact (mul_eq_zero.mp hτ).resolve_right (pow_ne_zero mQ hΔ)
+  exact fun n ↦ powerSeries_coeff_mem_of_mul_eq' K.toSubfield hqmul hg_ne
+    (fun n' ↦ hQmem n') (fun n' ↦ hPat' n') n
+
+end HeadTwo
+
+end WLight
+
+open _root_.WLight
+  _root_.P2MW.S_WLight_exists_qExpansion_coeff_mem_of_mdifferentiable_levelFraction.WLight in
+theorem solution
+    (N : ℕ) [NeZero N]
+    (L : ℍ → PeriodPair) (hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), W v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (jf : ℍ → ℂ)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    (K : IntermediateField ℚ ℂ)
+    (hK : K = IntermediateField.adjoin ℚ
+      {Complex.exp (2 * (Real.pi : ℂ) * Complex.I / (N : ℂ))})
+    {G : ℍ → ℂ} (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (P Q : MvPolynomial (Option {v : Fin 2 → ZMod N // v ≠ 0}) ℂ)
+    (hPK : ∀ m, P.coeff m ∈ K) (hQK : ∀ m, Q.coeff m ∈ K)
+    (hQ0 : MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+      o.elim jf fun v => fricke v.1) Q ≠ 0)
+    (hGQ : G * MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+        o.elim jf fun v => fricke v.1) Q =
+      MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+        o.elim jf fun v => fricke v.1) P)
+    (hint : ∃ (d : ℕ) (p : Fin d → Polynomial ℂ), (∀ (i : Fin d) (n : ℕ), (p i).coeff n ∈ K) ∧
+      ∀ τ : ℍ, G τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * G τ ^ (i : ℕ) = 0) :
+    ∃ m : ℕ, Function.Periodic ((G * ModularForm.discriminant ^ m) ∘ UpperHalfPlane.ofComplex) N ∧
+      IsBoundedAtImInfty (G * ModularForm.discriminant ^ m) ∧
+      ∀ n : ℕ, (UpperHalfPlane.qExpansion N (G * ModularForm.discriminant ^ m)).coeff n ∈ K := by
+  subst hK
+  have hfeq : fricke = fun a τ => -(ModularForm.E₄ τ * ModularForm.E₆ τ /
+      ModularForm.discriminant τ) / 2592 *
+    (((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ)
+        ((((a 0).val : ℂ) * (τ : ℂ) + ((a 1).val : ℂ)) / (N : ℂ))) := by
+    funext v τ; rw [hfricke v τ, hW v τ]
+  obtain ⟨h1, _h2, h3, h4, h5, _h6, _h7, h8⟩ :=
+    WLight.frickeFunction_modularity_package N L hL
+  have _h8 := h8
+  refine WLight.exists_qExpansion_coeff_mem_of_mdifferentiable_levelFraction_of_deps
+    N L hL W hW fricke hfricke jf hjf _ rfl ?_ ?_ ?_ hG P Q hPK hQK hQ0 hGQ hint
+  · intro v hv
+    refine ⟨1, ?_, ?_, ?_⟩ <;> rw [pow_one, hfeq]
+    · exact (h5 v hv).1
+    · exact h4 v hv
+    · exact (h5 v hv).2
+  · rw [hfeq]; exact h3
+  · rw [hfeq]; exact fun v γ τ => h1 v γ τ
+
+end
+
+end S_WLight_exists_qExpansion_coeff_mem_of_mdifferentiable_levelFraction
+end P2MW
+export P2MW.S_WLight_exists_qExpansion_coeff_mem_of_mdifferentiable_levelFraction (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Complex Real UpperHalfPlane
+open scoped Manifold MatrixGroups ModularForm
+theorem WLight.exists_qExpansion_coeff_mem_of_mdifferentiable_levelFraction
+    (N : ℕ) [NeZero N]
+    (L : ℍ → PeriodPair) (hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), W v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (jf : ℍ → ℂ)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    (K : IntermediateField ℚ ℂ)
+    (hK : K = IntermediateField.adjoin ℚ
+      {Complex.exp (2 * (Real.pi : ℂ) * Complex.I / (N : ℂ))})
+    {G : ℍ → ℂ} (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (P Q : MvPolynomial (Option {v : Fin 2 → ZMod N // v ≠ 0}) ℂ)
+    (hPK : ∀ m, P.coeff m ∈ K) (hQK : ∀ m, Q.coeff m ∈ K)
+    (hQ0 : MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+      o.elim jf fun v => fricke v.1) Q ≠ 0)
+    (hGQ : G * MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+        o.elim jf fun v => fricke v.1) Q =
+      MvPolynomial.aeval (fun o : Option {v : Fin 2 → ZMod N // v ≠ 0} =>
+        o.elim jf fun v => fricke v.1) P)
+    (hint : ∃ (d : ℕ) (p : Fin d → Polynomial ℂ), (∀ (i : Fin d) (n : ℕ), (p i).coeff n ∈ K) ∧
+      ∀ τ : ℍ, G τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * G τ ^ (i : ℕ) = 0) :
+    ∃ m : ℕ, Function.Periodic ((G * ModularForm.discriminant ^ m) ∘ UpperHalfPlane.ofComplex) N ∧
+      IsBoundedAtImInfty (G * ModularForm.discriminant ^ m) ∧
+      ∀ n : ℕ, (UpperHalfPlane.qExpansion N (G * ModularForm.discriminant ^ m)).coeff n ∈ K :=
+  solution N L hL W hW fricke hfricke jf hjf K hK hG P Q hPK hQK hQ0 hGQ hint
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_frickeFunction_intBaseChange.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_frickeFunction_intBaseChange.lean
new file mode 100644
index 0000000000..29a3caf671
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_frickeFunction_intBaseChange.lean
@@ -0,0 +1,1598 @@
+/-
+Based on Prove2Me node WLight.frickeFunction_intBaseChange
+(d52e793c-6559-51ae-92d0-824809981e8a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5184fd1f-0857-5c36-9cfe-976bd371dd69
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.SpecialFunctions.Elliptic.Weierstrass
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import Mathlib.Geometry.Manifold.Notation
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+public import Mathlib.RingTheory.Adjoin.Basic
+
+import Mathlib.NumberTheory.ModularForms.QExpansion
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+import Mathlib.RingTheory.Adjoin.Polynomial.Basic
+import Mathlib.RingTheory.IntegralClosure.IsIntegral.Basic
+import Mathlib.RingTheory.Localization.FractionRing
+import Mathlib.Algebra.Polynomial.Lifts
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_modularity_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_orbit_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_exists_mdifferentiable_div_of_monicRel
+import LeanPool.FLTEichlerShimura.Theorems.Thm_IsIntegral_mem_span_of_adjoin_simple_constants
+import LeanPool.FLTEichlerShimura.Theorems.Thm_IsIntegral_mem_span_of_adjoin_simple_constants_transcendental
+
+/-!
+# Descent of level-N integral fractions to ℚ(ζ_N)
+
+Theorem statement: `WLight.frickeFunction_intBaseChange` (`d52e793c-6559-51ae-92d0-824809981e8a`),
+by Claude, 2026-09-05.
+
+Proof: submission `5184fd1f-0857-5c36-9cfe-976bd371dd69`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a positive integer, and let $L$ assign to each $\tau$ in the upper half-plane
+$\mathbb{H}$ a period pair with $\omega_1 = \tau$ and $\omega_2 = 1$. Let $W$ satisfy $W_v(\tau) =
+(2\pi i)^{-2}\,\wp_{L(\tau)}\bigl((\tilde v_0\tau + \tilde v_1)/N\bigr)$ for all $v \in
+(\mathbb{Z}/N)^2$ and $\tau$, where $\tilde v_k$ denotes the canonical integer representative of
+$v_k$, let $\mathrm{fricke}$ satisfy $\mathrm{fricke}_v(\tau) =
+-\bigl(E_4(\tau)E_6(\tau)/\Delta(\tau)\bigr)/2592 \cdot W_v(\tau)$, and let $jf(\tau) =
+E_4(\tau)^3/\Delta(\tau)$. Let $G, a, b : \mathbb{H} \to \mathbb{C}$ with $G$ holomorphic (complex
+$C^\infty$ in the sense of `MDifferentiable` for the model $\mathcal{I}(\mathbb{C})$), with $a$ and
+$b$ in the $\mathbb{C}$-subalgebra of $\mathbb{H} \to \mathbb{C}$ generated by $jf$ together with
+all $\mathrm{fricke}_v$ for $v \neq 0$, with $b \neq 0$ and $G\cdot b = a$, and suppose that for
+some $d$ and polynomials $p_0,\dots,p_{d-1} \in \mathbb{C}[X]$ one has $G(\tau)^d + \sum_{i<d}
+p_i(jf(\tau))G(\tau)^i = 0$ for all $\tau$. Put $k_N = \mathbb{Q}\bigl(e^{2\pi i/N}\bigr) \subseteq
+\mathbb{C}$. Then there are finitely many scalars $\lambda_i \in \mathbb{C}$ and functions $G_i$
+with $G = \sum_i \lambda_i G_i$, each $G_i$ holomorphic, each $G_i$ of the form $G_i Q_i = P_i$ with
+$P_i, Q_i$ in the $k_N$-subalgebra generated by $jf$ and the $\mathrm{fricke}_v$ ($v \neq 0$) and
+$Q_i \neq 0$, and each $G_i$ satisfying a monic relation $G_i(\tau)^{d_i} + \sum_{k<d_i}
+p_{i,k}(jf(\tau))G_i(\tau)^k = 0$ for all $\tau$, where every coefficient of every $p_{i,k}$ lies in
+$k_N$.
+
+This is the base-change step in the study of the field of modular functions of level $N$ and its
+field of constants: an element of that field which is holomorphic on $\mathbb{H}$ and integral over
+$\mathbb{C}[j]$ is exhibited as a $\mathbb{C}$-linear combination of functions of the same shape but
+with coefficients in the cyclotomic field $\mathbb{Q}(\zeta_N)$. It is used in the $q$-expansion
+arguments for cusp forms and Fricke functions, for instance in the spanning and transport statements
+for $\mathbb{Q}(\zeta_N)$-rational Fricke expressions; the proof cites the modularity and orbit
+packages for the Fricke functions, the existence of a holomorphic quotient under a monic relation,
+and the two single-constant descent theorems for integral elements (algebraic and transcendental
+constant).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WLight_frickeFunction_intBaseChange.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+noncomputable section
+
+open Complex Real UpperHalfPlane ModularForm Polynomial Real.Polynomial
+open scoped Topology Manifold MatrixGroups ModularForm
+
+namespace WLight
+
+
+namespace R8b
+
+section Furniture
+
+theorem mdifferentiable_eq_zero_or_eq_zero_of_mul_eq_zero {f g : ℍ → ℂ}
+    (hf : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) (hg : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hfg : f * g = 0) : f = 0 ∨ g = 0 := by
+  rw [UpperHalfPlane.mdifferentiable_iff] at hf hg
+  have hU : IsOpen {z : ℂ | 0 < z.im} := isOpen_upperHalfPlaneSet
+  have key := AnalyticOnNhd.eq_zero_or_eq_zero_of_mul_eq_zero (hf.analyticOnNhd hU)
+    (hg.analyticOnNhd hU) (fun z hz ↦ by
+      have := congrFun hfg (ofComplex z)
+      simpa using this) (convex_halfSpace_im_gt 0).isPreconnected
+  rcases key with k | k
+  · left; funext τ; simpa [ofComplex_apply] using k (τ : ℂ) τ.im_pos
+  · right; funext τ; simpa [ofComplex_apply] using k (τ : ℂ) τ.im_pos
+
+lemma mdiff_jf {jf : ℍ → ℂ}
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) jf := by
+  have : jf = fun τ => ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ := funext hjf
+  rw [this]
+  exact (ModularForm.E₄.holo'.pow 3).div CuspForm.discriminant.holo'
+    ModularForm.discriminant_ne_zero
+
+def holSub : Subalgebra ℂ (ℍ → ℂ) where
+  carrier := {f | MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f}
+  mul_mem' ha hb := ha.mul hb
+  add_mem' ha hb := ha.add hb
+  algebraMap_mem' _ := mdifferentiable_const
+
+scoped instance : Nontrivial ↥holSub := ⟨⟨0, 1, fun h => by
+  have := congrArg (fun f : ↥holSub => (f : ℍ → ℂ) UpperHalfPlane.I) h
+  simp at this⟩⟩
+
+scoped instance : NoZeroDivisors ↥holSub := ⟨fun {a b} h => by
+  rcases mdifferentiable_eq_zero_or_eq_zero_of_mul_eq_zero a.2 b.2 (congrArg Subtype.val h)
+    with h | h
+  · exact Or.inl (Subtype.ext h)
+  · exact Or.inr (Subtype.ext h)⟩
+
+scoped instance : IsDomain ↥holSub := NoZeroDivisors.to_isDomain _
+
+abbrev KK : Type := FractionRing ↥holSub
+
+abbrev ι : ↥holSub →+* KK := algebraMap ↥holSub KK
+
+lemma ι_injective : Function.Injective ι := IsFractionRing.injective _ _
+
+lemma ι_algebraMap (c : ℂ) : ι (algebraMap ℂ ↥holSub c) = algebraMap ℂ KK c :=
+  (IsScalarTower.algebraMap_apply ℂ ↥holSub KK c).symm
+
+lemma adjoin_le_holSub {R : Type*} [CommSemiring R] [Algebra R ℂ] {T : Set (ℍ → ℂ)}
+    (hT : T ⊆ holSub) {x : ℍ → ℂ} (hx : x ∈ Algebra.adjoin R T) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) x := by
+  induction hx using Algebra.adjoin_induction with
+  | mem g hg' => exact hT hg'
+  | algebraMap r => exact mdifferentiable_const
+  | add x y _ _ hx hy => exact hx.add hy
+  | mul x y _ _ hx hy => exact hx.mul hy
+
+end Furniture
+
+section Generators
+
+variable {N : ℕ} (jf : ℍ → ℂ) (fricke : (Fin 2 → ZMod N) → ℍ → ℂ)
+
+def gen : Option {v : Fin 2 → ZMod N // v ≠ 0} → ℍ → ℂ :=
+  fun o => o.elim jf fun v => fricke v.1
+
+lemma range_gen : Set.range (gen jf fricke) =
+    insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v} := by
+  ext g
+  constructor
+  · rintro ⟨o, rfl⟩
+    cases o with
+    | none => exact Set.mem_insert _ _
+    | some v => exact Set.mem_insert_of_mem _ ⟨v.1, v.2, rfl⟩
+  · rintro (rfl | ⟨v, hv, rfl⟩)
+    · exact ⟨none, rfl⟩
+    · exact ⟨some ⟨v, hv⟩, rfl⟩
+
+variable {jf fricke}
+
+structure GenMD (jf : ℍ → ℂ) (fricke : (Fin 2 → ZMod N) → ℍ → ℂ) : Prop where
+  jmd : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) jf
+  fmd : ∀ v : Fin 2 → ZMod N, v ≠ 0 → MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fricke v)
+
+lemma GenMD.mdiff (hg : GenMD jf fricke) (o : Option {v : Fin 2 → ZMod N // v ≠ 0}) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (gen jf fricke o) := by
+  cases o with
+  | none => exact hg.jmd
+  | some v => exact hg.fmd v.1 v.2
+
+lemma range_gen_subset_holSub (hg : GenMD jf fricke) :
+    Set.range (gen jf fricke) ⊆ (holSub : Set (ℍ → ℂ)) := by
+  rintro _ ⟨o, rfl⟩; exact hg.mdiff o
+
+def genH (hg : GenMD jf fricke) (o : Option {v : Fin 2 → ZMod N // v ≠ 0}) : ↥holSub :=
+  ⟨gen jf fricke o, hg.mdiff o⟩
+
+def SK (hg : GenMD jf fricke) : Set KK := Set.range fun o => ι (genH hg o)
+
+def tK (hg : GenMD jf fricke) : KK := ι (genH hg none)
+
+lemma tK_mem_SK (hg : GenMD jf fricke) : tK hg ∈ SK hg := ⟨none, rfl⟩
+
+lemma SK_finite (hg : GenMD jf fricke) [NeZero N] : (SK hg).Finite := Set.finite_range _
+
+end Generators
+
+section Correspondence
+
+variable (F : IntermediateField ℚ ℂ)
+
+theorem isIntegral_subring_iff (T : Subring KK) (y : KK) :
+    IsIntegral ↥T y ↔ ∃ p : KK[X], p.Monic ∧ (∀ n, p.coeff n ∈ T) ∧ p.eval y = 0 := by
+  constructor
+  · rintro ⟨p, hm, hp⟩
+    refine ⟨p.map (algebraMap ↥T KK), hm.map _, fun n ↦ ?_, ?_⟩
+    · rw [Polynomial.coeff_map]; exact (p.coeff n).2
+    · rwa [Polynomial.eval_map]
+  · rintro ⟨p, hm, hc, hp⟩
+    have hl : p ∈ Polynomial.lifts (algebraMap ↥T KK) := by
+      rw [Polynomial.lifts_iff_coeff_lifts]
+      intro n; exact ⟨⟨p.coeff n, hc n⟩, rfl⟩
+    obtain ⟨q, hq, -, hqm⟩ := Polynomial.lifts_and_degree_eq_and_monic hl hm
+    refine ⟨q, hqm, ?_⟩
+    rw [← Polynomial.eval_map, hq, hp]
+
+theorem mem_closure_iff_exists_adjoin {T : Set (ℍ → ℂ)} (hT : T ⊆ holSub) (z : KK) :
+    z ∈ Subring.closure (⇑(algebraMap ℂ KK) '' (F : Set ℂ) ∪
+        (fun f : ↥holSub => ι f) '' {f | (f : ℍ → ℂ) ∈ T}) ↔
+      ∃ a : ↥holSub, (a : ℍ → ℂ) ∈ Algebra.adjoin ↥F T ∧ ι a = z := by
+  constructor
+  · intro hz
+    induction hz using Subring.closure_induction with
+    | mem x hx =>
+      rcases hx with ⟨c, hc, rfl⟩ | ⟨f, hf, rfl⟩
+      · refine ⟨algebraMap ℂ ↥holSub c, ?_, ι_algebraMap c⟩
+        exact Subalgebra.algebraMap_mem (Algebra.adjoin ↥F T) (⟨c, hc⟩ : ↥F)
+      · exact ⟨f, Algebra.subset_adjoin hf, rfl⟩
+    | zero => exact ⟨0, Subalgebra.zero_mem _, map_zero ι⟩
+    | one => exact ⟨1, Subalgebra.one_mem _, map_one ι⟩
+    | add x y _ _ hx hy =>
+      obtain ⟨a, ha, rfl⟩ := hx
+      obtain ⟨b, hb, rfl⟩ := hy
+      exact ⟨a + b, Subalgebra.add_mem _ ha hb, map_add ι a b⟩
+    | neg x _ hx =>
+      obtain ⟨a, ha, rfl⟩ := hx
+      exact ⟨-a, Subalgebra.neg_mem _ ha, map_neg ι a⟩
+    | mul x y _ _ hx hy =>
+      obtain ⟨a, ha, rfl⟩ := hx
+      obtain ⟨b, hb, rfl⟩ := hy
+      exact ⟨a * b, Subalgebra.mul_mem _ ha hb, map_mul ι a b⟩
+  · rintro ⟨a, ha, rfl⟩
+    suffices h : ∀ (x : ℍ → ℂ), x ∈ Algebra.adjoin ↥F T → ∀ hx : x ∈ holSub,
+        ι ⟨x, hx⟩ ∈ Subring.closure (⇑(algebraMap ℂ KK) '' (F : Set ℂ) ∪
+          (fun f : ↥holSub => ι f) '' {f | (f : ℍ → ℂ) ∈ T}) from h a ha a.2
+    intro x hx
+    induction hx using Algebra.adjoin_induction with
+    | mem g hg' => exact fun hx => Subring.subset_closure (Or.inr ⟨⟨g, hx⟩, hg', rfl⟩)
+    | algebraMap r =>
+      intro hx
+      have : (⟨algebraMap ↥F (ℍ → ℂ) r, hx⟩ : ↥holSub) = algebraMap ℂ ↥holSub (r : ℂ) := rfl
+      rw [this, ι_algebraMap]
+      exact Subring.subset_closure (Or.inl ⟨r, r.2, rfl⟩)
+    | add x y hx' hy' ihx ihy =>
+      intro hxy
+      have hx := adjoin_le_holSub (R := ↥F) hT hx'
+      have hy := adjoin_le_holSub (R := ↥F) hT hy'
+      have : (⟨x + y, hxy⟩ : ↥holSub) = ⟨x, hx⟩ + ⟨y, hy⟩ := rfl
+      rw [this, map_add]
+      exact Subring.add_mem _ (ihx hx) (ihy hy)
+    | mul x y hx' hy' ihx ihy =>
+      intro hxy
+      have hx := adjoin_le_holSub (R := ↥F) hT hx'
+      have hy := adjoin_le_holSub (R := ↥F) hT hy'
+      have : (⟨x * y, hxy⟩ : ↥holSub) = ⟨x, hx⟩ * ⟨y, hy⟩ := rfl
+      rw [this, map_mul]
+      exact Subring.mul_mem _ (ihx hx) (ihy hy)
+
+variable {N : ℕ} {jf : ℍ → ℂ} {fricke : (Fin 2 → ZMod N) → ℍ → ℂ} (hg : GenMD jf fricke)
+
+lemma SK_eq :
+    SK hg = (fun f : ↥holSub => ι f) '' {f | (f : ℍ → ℂ) ∈ Set.range (gen jf fricke)} := by
+  ext z
+  constructor
+  · rintro ⟨o, rfl⟩; exact ⟨genH hg o, ⟨o, rfl⟩, rfl⟩
+  · rintro ⟨f, ⟨o, ho⟩, rfl⟩
+    refine ⟨o, ?_⟩
+    change ι (genH hg o) = ι f
+    congr 1
+    exact Subtype.ext ho
+
+lemma singleton_tK_eq : ({tK hg} : Set KK) =
+    (fun f : ↥holSub => ι f) '' {f | (f : ℍ → ℂ) ∈ ({jf} : Set (ℍ → ℂ))} := by
+  ext z
+  constructor
+  · rintro rfl; exact ⟨genH hg none, rfl, rfl⟩
+  · rintro ⟨f, hf, rfl⟩
+    rw [Set.mem_singleton_iff]
+    change ι f = ι (genH hg none)
+    congr 1
+    exact Subtype.ext hf
+
+theorem mem_closureS_iff (z : KK) :
+    z ∈ Subring.closure (⇑(algebraMap ℂ KK) '' (F : Set ℂ) ∪ SK hg) ↔
+      ∃ a : ↥holSub, (a : ℍ → ℂ) ∈ Algebra.adjoin ↥F (Set.range (gen jf fricke)) ∧ ι a = z := by
+  rw [SK_eq, mem_closure_iff_exists_adjoin F (range_gen_subset_holSub hg)]
+
+theorem mem_closureT_iff (z : KK) :
+    z ∈ Subring.closure (⇑(algebraMap ℂ KK) '' (F : Set ℂ) ∪ {tK hg}) ↔
+      ∃ a : ↥holSub, (a : ℍ → ℂ) ∈ Algebra.adjoin ↥F ({jf} : Set (ℍ → ℂ)) ∧ ι a = z := by
+  rw [singleton_tK_eq, mem_closure_iff_exists_adjoin F (by rintro _ rfl; exact hg.jmd)]
+
+end Correspondence
+
+section QKit
+
+open Filter Function
+
+variable {N : ℕ}
+
+lemma isBoundedAtImInfty_discriminant : IsBoundedAtImInfty (⇑CuspForm.discriminant : ℍ → ℂ) :=
+  (CuspFormClass.zero_at_infty CuspForm.discriminant).boundedAtFilter
+
+lemma isBoundedAtImInfty_discPow (n : ℕ) :
+    IsBoundedAtImInfty (⇑CuspForm.discriminant ^ n : ℍ → ℂ) := by
+  induction n with
+  | zero => exact pow_zero (⇑CuspForm.discriminant : ℍ → ℂ) ▸ Filter.const_boundedAtFilter _ (1 : ℂ)
+  | succ k ih =>
+    rw [pow_succ]
+    exact ih.mul isBoundedAtImInfty_discriminant
+
+lemma IsBoundedAtImInfty.mul_discPow_mono {f : ℍ → ℂ} {m m' : ℕ} (hm : m ≤ m')
+    (h : IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m)) :
+    IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m') := by
+  have hshape : (f * ⇑CuspForm.discriminant ^ m' : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m) * ⇑CuspForm.discriminant ^ (m' - m) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply]
+    rw [mul_assoc, ← pow_add, Nat.add_sub_cancel' hm]
+  rw [hshape]
+  exact h.mul (isBoundedAtImInfty_discPow (m' - m))
+
+def discPowForm (m : ℕ) : ModularForm 𝒮ℒ (12 * m) :=
+  ModularForm.mcast (by ring) ((CuspForm.toModularFormₗ CuspForm.discriminant).pow m)
+
+lemma discPowForm_coe (m : ℕ) : ⇑(discPowForm m) = ⇑CuspForm.discriminant ^ m := by
+  funext z
+  simp [discPowForm, ModularForm.coe_mcast, ModularForm.coe_pow,
+    CuspForm.toModularFormₗ_apply]
+
+lemma periodic_one_fn (c : ℝ) : Function.Periodic ((1 : ℍ → ℂ) ∘ ofComplex) c := fun _ => rfl
+
+lemma periodic_discPow_comp_ofComplex (k : ℕ) (N : ℕ) :
+    Function.Periodic ((⇑CuspForm.discriminant ^ k : ℍ → ℂ) ∘ ofComplex) N := by
+  have h1 : Function.Periodic (⇑CuspForm.discriminant ∘ ofComplex) 1 :=
+    SlashInvariantFormClass.periodic_comp_ofComplex CuspForm.discriminant
+      one_mem_strictPeriods_SL
+  have hk : Function.Periodic ((⇑CuspForm.discriminant ^ k : ℍ → ℂ) ∘ ofComplex) 1 := by
+    induction k with
+    | zero => exact periodic_one_fn 1
+    | succ k ih =>
+      intro x
+      have hx := (ih.mul h1) x
+      simp only [Function.comp_apply, Pi.mul_apply, Pi.pow_apply] at hx ⊢
+      rw [pow_succ, pow_succ]
+      exact hx
+  simpa using hk.nat_mul N
+
+lemma mdiff_discPow (k : ℕ) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (⇑CuspForm.discriminant ^ k : ℍ → ℂ) := by
+  rw [← discPowForm_coe]
+  exact (discPowForm k).holo'
+
+lemma mdiff_mul_discPow {f : ℍ → ℂ} (hf : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) (m : ℕ) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (f * ⇑CuspForm.discriminant ^ m : ℍ → ℂ) :=
+  hf.mul (mdiff_discPow m)
+
+lemma analyticAt_cuspFunction_zero_of [NeZero N] {g : ℍ → ℂ}
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hper : Function.Periodic (g ∘ ofComplex) N) (hbd : IsBoundedAtImInfty g) :
+    AnalyticAt ℂ (cuspFunction N g) 0 :=
+  analyticAt_cuspFunction_zero
+    (by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)) hper hhol hbd
+
+lemma qExpansion_one_discPowForm (k : ℕ) :
+    qExpansion 1 (discPowForm k) = (qExpansion 1 ModularForm.discriminant) ^ k := by
+  rw [discPowForm, ModularForm.qExpansion_mcast,
+    ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+  have hco : (⇑(CuspForm.toModularFormₗ CuspForm.discriminant) : ℍ → ℂ) =
+      ModularForm.discriminant := by
+    funext z
+    rw [CuspForm.toModularFormₗ_apply]
+    exact congrFun CuspForm.coe_discriminant z
+  rw [hco]
+
+lemma qExpansion_one_discPow (k : ℕ) :
+    qExpansion 1 (⇑CuspForm.discriminant ^ k : ℍ → ℂ) =
+      (qExpansion 1 ModularForm.discriminant) ^ k := by
+  rw [← discPowForm_coe]
+  exact qExpansion_one_discPowForm k
+
+lemma qParam_one_eq_pow {N : ℕ} (hN : N ≠ 0) (τ : ℂ) :
+    Function.Periodic.qParam 1 τ = Function.Periodic.qParam N τ ^ N := by
+  have : (N : ℂ) ≠ 0 := by exact_mod_cast hN
+  simp only [Function.Periodic.qParam, Complex.ofReal_one, div_one, Complex.ofReal_natCast]
+  rw [← Complex.exp_nat_mul]
+  congr 1
+  field_simp
+
+theorem qExpansion_coeff_width (f : ℍ → ℂ) {N : ℕ} (hN : N ≠ 0)
+    (hper : Function.Periodic (f ∘ ofComplex) 1) (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f)
+    (hbd : IsBoundedAtImInfty f) (n : ℕ) :
+    (qExpansion N f).coeff n =
+      if N ∣ n then (qExpansion 1 f).coeff (n / N) else 0 := by
+  have hN' : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero hN
+  have hperN : Function.Periodic (f ∘ ofComplex) N := by
+    simpa using hper.nat_mul N
+  let f' : C(ℍ, ℂ) := ⟨f, hhol.continuous⟩
+  have hfan : AnalyticAt ℂ (cuspFunction N f') 0 :=
+    analyticAt_cuspFunction_zero hN' hperN hhol hbd
+  set c : ℕ → ℂ := fun n ↦ if N ∣ n then (qExpansion 1 f).coeff (n / N) else 0 with hc
+  have hf : ∀ τ : ℍ, HasSum (fun m ↦ c m • Function.Periodic.qParam N τ ^ m) (f' τ) := by
+    intro τ
+    have h1 := hasSum_qExpansion one_pos hper hhol hbd τ
+    have hinj : Function.Injective fun m : ℕ ↦ N * m := fun a b h ↦ by
+      simpa [Nat.mul_right_inj hN] using h
+    refine (hinj.hasSum_iff (f := fun m ↦ c m • Function.Periodic.qParam N τ ^ m) ?_).mp ?_
+    · intro x hx
+      have : ¬ N ∣ x := fun ⟨k, hk⟩ ↦ hx ⟨k, hk.symm⟩
+      simp [hc, this]
+    · refine h1.congr_fun fun m ↦ ?_
+      simp only [Function.comp_apply, hc, Nat.dvd_mul_right, ite_true,
+        Nat.mul_div_cancel_left _ (Nat.pos_of_ne_zero hN), qParam_one_eq_pow hN, ← pow_mul]
+  exact (qExpansion_coeff_unique f' hN' hfan hf n).symm
+
+end QKit
+
+section RatCoeff
+
+open UpperHalfPlane ModularForm SlashInvariantForm ModularFormClass CuspForm
+  ModularForm.CuspForm EisensteinSeries
+open scoped MatrixGroups ArithmeticFunction.sigma
+
+private lemma ratCoeff_mul {p q : PowerSeries ℂ}
+    (hp : ∀ n : ℕ, ∃ a : ℚ, p.coeff n = (a : ℂ)) (hq : ∀ n : ℕ, ∃ a : ℚ, q.coeff n = (a : ℂ)) :
+    ∀ n : ℕ, ∃ a : ℚ, (p * q).coeff n = (a : ℂ) := by
+  choose F hF using hp
+  choose G hG using hq
+  intro n
+  refine ⟨∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, F ij.1 * G ij.2, ?_⟩
+  rw [PowerSeries.coeff_mul]
+  push_cast
+  exact Finset.sum_congr rfl fun ij _ => by rw [hF, hG]
+
+private lemma ratCoeff_sub {p q : PowerSeries ℂ}
+    (hp : ∀ n : ℕ, ∃ a : ℚ, p.coeff n = (a : ℂ)) (hq : ∀ n : ℕ, ∃ a : ℚ, q.coeff n = (a : ℂ)) :
+    ∀ n : ℕ, ∃ a : ℚ, (p - q).coeff n = (a : ℂ) := by
+  intro n
+  obtain ⟨a, ha⟩ := hp n
+  obtain ⟨b, hb⟩ := hq n
+  exact ⟨a - b, by rw [map_sub, ha, hb]; push_cast; ring⟩
+
+private lemma ratCoeff_E {k : ℕ} (hk : 3 ≤ k) (hk2 : Even k) :
+    ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 (E hk)).coeff n = (q : ℂ) := by
+  intro n
+  rw [E_qExpansion_coeff hk hk2]
+  by_cases hn : n = 0
+  · exact ⟨1, by simp [hn]⟩
+  · refine ⟨-(2 * k / _root_.bernoulli k) * (σ (k - 1) n : ℚ), ?_⟩
+    rw [ite_eq_right hn]
+    push_cast
+    ring
+
+private lemma ratCoeff_pow {p : PowerSeries ℂ}
+    (hp : ∀ n : ℕ, ∃ a : ℚ, p.coeff n = (a : ℂ)) (k : ℕ) :
+    ∀ n : ℕ, ∃ a : ℚ, (p ^ k).coeff n = (a : ℂ) := by
+  induction k with
+  | zero =>
+    intro n
+    rw [pow_zero]
+    by_cases hn : n = 0
+    · exact ⟨1, by simp [hn, PowerSeries.coeff_one]⟩
+    · exact ⟨0, by simp [PowerSeries.coeff_one, hn]⟩
+  | succ k ih =>
+    rw [pow_succ]
+    exact ratCoeff_mul ih hp
+
+private def eCubeSubESq : ModularForm 𝒮ℒ 12 :=
+  ModularForm.mcast (by decide) (E₄.pow 3) - ModularForm.mcast (by decide) (E₆.pow 2)
+
+private lemma eCubeSubESq_qExpansion :
+    qExpansion 1 eCubeSubESq = qExpansion 1 E₄ * qExpansion 1 E₄ * qExpansion 1 E₄ -
+      qExpansion 1 E₆ * qExpansion 1 E₆ := by
+  simp only [eCubeSubESq, FunLike.coe_sub, ModularForm.coe_mcast,
+    ModularForm.qExpansion_sub one_pos one_mem_strictPeriods_SL,
+    ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+  ring
+
+private lemma discriminant_eq_smul_eCubeSubESq :
+    ModularForm.discriminant = (1 / 1728 : ℂ) • eCubeSubESq := by
+  ext z
+  have h := discriminant_eq_E₄_cube_sub_E₆_sq z
+  simp only [Pi.smul_apply, eCubeSubESq, FunLike.coe_sub, Pi.sub_apply,
+    ModularForm.coe_mcast, ModularForm.coe_pow, Pi.pow_apply, smul_eq_mul]
+  rw [h]
+  ring
+
+private lemma ratCoeff_discriminant :
+    ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 ModularForm.discriminant).coeff n = (q : ℂ) := by
+  have h4 : ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 E₄).coeff n = (q : ℂ) :=
+    ratCoeff_E (by norm_num) (by decide)
+  have h6 : ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 E₆).coeff n = (q : ℂ) :=
+    ratCoeff_E (by norm_num) (by decide)
+  have hmain := ratCoeff_sub (ratCoeff_mul (ratCoeff_mul h4 h4) h4) (ratCoeff_mul h6 h6)
+  intro n
+  obtain ⟨a, ha⟩ := hmain n
+  refine ⟨(1 / 1728 : ℚ) * a, ?_⟩
+  rw [discriminant_eq_smul_eCubeSubESq,
+    ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL,
+    PowerSeries.coeff_smul, eCubeSubESq_qExpansion, smul_eq_mul, ha]
+  push_cast
+  ring
+
+end RatCoeff
+
+section KPoleAlgebra
+
+open ModularForm
+
+variable {N : ℕ}
+
+lemma mem_of_rat (K : IntermediateField ℚ ℂ) {x : ℂ} (h : ∃ q : ℚ, x = (q : ℂ)) : x ∈ K := by
+  obtain ⟨q, rfl⟩ := h
+  exact SubfieldClass.ratCast_mem K q
+
+def KPoleAt (K : IntermediateField ℚ ℂ) (N m : ℕ) (f : ℍ → ℂ) : Prop :=
+  Function.Periodic ((f * ⇑CuspForm.discriminant ^ m) ∘ ofComplex) N ∧
+    IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m) ∧
+    ∀ n : ℕ, (qExpansion N (f * ⇑CuspForm.discriminant ^ m)).coeff n ∈ K
+
+lemma qExpansion_discPow_coeff_mem (K : IntermediateField ℚ ℂ) [NeZero N] (k n : ℕ) :
+    (qExpansion N (⇑CuspForm.discriminant ^ k : ℍ → ℂ)).coeff n ∈ K := by
+  have hper : Function.Periodic
+      ((⇑CuspForm.discriminant ^ k : ℍ → ℂ) ∘ ofComplex) (1 : ℂ) := by
+    have h := periodic_discPow_comp_ofComplex k 1
+    simpa only [Nat.cast_one] using h
+  rw [qExpansion_coeff_width _ (NeZero.ne N) hper (mdiff_discPow k)
+    (isBoundedAtImInfty_discPow k), qExpansion_one_discPow]
+  split
+  · exact mem_of_rat K (ratCoeff_pow ratCoeff_discriminant k _)
+  · exact zero_mem _
+
+lemma KPoleAt.pad {K : IntermediateField ℚ ℂ} [NeZero N] {f : ℍ → ℂ} {m m' : ℕ}
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) (hm : m ≤ m') (h : KPoleAt K N m f) :
+    KPoleAt K N m' f := by
+  obtain ⟨hper, hbd, hmem⟩ := h
+  have hshape : (f * ⇑CuspForm.discriminant ^ m' : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m) * ⇑CuspForm.discriminant ^ (m' - m) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply]
+    rw [mul_assoc, ← pow_add, Nat.add_sub_cancel' hm]
+  refine ⟨?_, ?_, ?_⟩
+  · rw [hshape]
+    exact hper.mul (periodic_discPow_comp_ofComplex (m' - m) N)
+  · exact IsBoundedAtImInfty.mul_discPow_mono hm hbd
+  · intro n
+    rw [hshape, qExpansion_mul
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hhol m) hper hbd)
+      (analyticAt_cuspFunction_zero_of (mdiff_discPow (m' - m))
+        (periodic_discPow_comp_ofComplex (m' - m) N) (isBoundedAtImInfty_discPow (m' - m))),
+      PowerSeries.coeff_mul]
+    exact sum_mem fun ij _ => mul_mem (hmem ij.1) (qExpansion_discPow_coeff_mem K _ ij.2)
+
+end KPoleAlgebra
+
+def KPole (K : IntermediateField ℚ ℂ) (N : ℕ) (f : ℍ → ℂ) : Prop :=
+  MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f ∧ ∃ m, KPoleAt K N m f
+
+section KPoleAlgebra2
+
+open Filter Function
+
+variable {N : ℕ}
+
+lemma kPole_algebraMap {K : IntermediateField ℚ ℂ} [NeZero N] (c : ↥K) :
+    KPole K N (algebraMap ↥K (ℍ → ℂ) c) := by
+  have hshape : ((algebraMap ↥K (ℍ → ℂ) c) * ⇑CuspForm.discriminant ^ 0 : ℍ → ℂ) =
+      (c : ℂ) • (1 : ℍ → ℂ) := by
+    funext τ
+    simp only [Pi.mul_apply, pow_zero, mul_one, Pi.smul_apply, Pi.one_apply,
+      smul_eq_mul]
+    rfl
+  have hone_bd : IsBoundedAtImInfty (1 : ℍ → ℂ) := by
+    have h1 : (1 : ℍ → ℂ) = fun _ : ℍ => (1 : ℂ) := rfl
+    rw [h1]
+    exact Filter.const_boundedAtFilter _ _
+  refine ⟨mdifferentiable_const, 0, ?_, ?_, ?_⟩
+  · rw [hshape]
+    intro x
+    rfl
+  · rw [hshape]
+    have hc : ((c : ℂ) • (1 : ℍ → ℂ)) = fun _ : ℍ => (c : ℂ) := by
+      funext τ
+      simp
+    rw [hc]
+    exact Filter.const_boundedAtFilter _ _
+  · intro n
+    have han : AnalyticAt ℂ (cuspFunction N (1 : ℍ → ℂ)) 0 :=
+      analyticAt_cuspFunction_zero_of (g := (1 : ℍ → ℂ)) mdifferentiable_const
+        (periodic_one_fn N) hone_bd
+    rw [hshape, qExpansion_smul han,
+      qExpansion_one, PowerSeries.coeff_smul, smul_eq_mul, PowerSeries.coeff_one]
+    split
+    · rw [mul_one]
+      exact c.2
+    · rw [mul_zero]
+      exact zero_mem _
+
+lemma KPole.add {K : IntermediateField ℚ ℂ} [NeZero N] {f g : ℍ → ℂ}
+    (hf : KPole K N f) (hg : KPole K N g) : KPole K N (f + g) := by
+  obtain ⟨hf1, m1, hfd⟩ := hf
+  obtain ⟨hg1, m2, hgd⟩ := hg
+  obtain ⟨hfper, hfbd, hfmem⟩ := hfd.pad hf1 (le_max_left m1 m2)
+  obtain ⟨hgper, hgbd, hgmem⟩ := hgd.pad hg1 (le_max_right m1 m2)
+  have hshape : ((f + g) * ⇑CuspForm.discriminant ^ max m1 m2 : ℍ → ℂ) =
+      f * ⇑CuspForm.discriminant ^ max m1 m2 + g * ⇑CuspForm.discriminant ^ max m1 m2 := by
+    funext τ
+    simp [add_mul]
+  refine ⟨hf1.add hg1, max m1 m2, ?_, ?_, ?_⟩
+  · rw [hshape]
+    exact hfper.add hgper
+  · rw [hshape]
+    exact hfbd.add hgbd
+  · intro n
+    rw [hshape, qExpansion_add
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hf1 _) hfper hfbd)
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hg1 _) hgper hgbd),
+      map_add]
+    exact add_mem (hfmem n) (hgmem n)
+
+lemma KPole.mul {K : IntermediateField ℚ ℂ} [NeZero N] {f g : ℍ → ℂ}
+    (hf : KPole K N f) (hg : KPole K N g) : KPole K N (f * g) := by
+  obtain ⟨hf1, m1, hfper, hfbd, hfmem⟩ := hf
+  obtain ⟨hg1, m2, hgper, hgbd, hgmem⟩ := hg
+  have hshape : ((f * g) * ⇑CuspForm.discriminant ^ (m1 + m2) : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m1) * (g * ⇑CuspForm.discriminant ^ m2) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply, pow_add]
+    ring
+  refine ⟨hf1.mul hg1, m1 + m2, ?_, ?_, ?_⟩
+  · rw [hshape]
+    exact hfper.mul hgper
+  · rw [hshape]
+    exact hfbd.mul hgbd
+  · intro n
+    rw [hshape, qExpansion_mul
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hf1 _) hfper hfbd)
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hg1 _) hgper hgbd),
+      PowerSeries.coeff_mul]
+    exact sum_mem fun ij _ => mul_mem (hfmem ij.1) (hgmem ij.2)
+
+lemma kPole_jf (K : IntermediateField ℚ ℂ) [NeZero N] {jf : ℍ → ℂ}
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) :
+    KPole K N jf := by
+  have hshape : (jf * ⇑CuspForm.discriminant ^ 1 : ℍ → ℂ) = ⇑(ModularForm.E₄.pow 3) := by
+    funext τ
+    rw [congrFun (ModularForm.coe_pow ModularForm.E₄ 3) τ, Pi.pow_apply]
+    simp only [Pi.mul_apply, pow_one, hjf τ]
+    rw [congrFun CuspForm.coe_discriminant τ]
+    exact div_mul_cancel₀ _ (ModularForm.discriminant_ne_zero τ)
+  have hhol3 : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (⇑(ModularForm.E₄.pow 3) : ℍ → ℂ) :=
+    (ModularForm.E₄.pow 3).holo'
+  have hbd3 : IsBoundedAtImInfty (⇑(ModularForm.E₄.pow 3) : ℍ → ℂ) :=
+    ModularFormClass.bdd_at_infty (ModularForm.E₄.pow 3)
+  have hper3 : Function.Periodic ((⇑(ModularForm.E₄.pow 3) : ℍ → ℂ) ∘ ofComplex) 1 :=
+    SlashInvariantFormClass.periodic_comp_ofComplex (ModularForm.E₄.pow 3)
+      one_mem_strictPeriods_SL
+  have hjmd : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) jf := by
+    have : jf = fun τ => ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ := funext hjf
+    rw [this]
+    exact (ModularForm.E₄.holo'.pow 3).div CuspForm.discriminant.holo'
+      ModularForm.discriminant_ne_zero
+  refine ⟨hjmd, 1, ?_, ?_, ?_⟩
+  · rw [hshape]
+    simpa using hper3.nat_mul N
+  · rw [hshape]
+    exact hbd3
+  · intro n
+    rw [hshape, qExpansion_coeff_width (⇑(ModularForm.E₄.pow 3) : ℍ → ℂ) (NeZero.ne N)
+      hper3 hhol3 hbd3]
+    split
+    · have he : qExpansion 1 (⇑(ModularForm.E₄.pow 3) : ℍ → ℂ) =
+          (qExpansion 1 ModularForm.E₄) ^ 3 :=
+        ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL ModularForm.E₄ 3
+      rw [he]
+      exact mem_of_rat K (ratCoeff_pow (ratCoeff_E (by norm_num) (by decide)) 3 _)
+    · exact zero_mem _
+
+lemma kPole_of_mem_adjoin {K : IntermediateField ℚ ℂ} [NeZero N] {T : Set (ℍ → ℂ)}
+    (hT : ∀ g ∈ T, KPole K N g) {x : ℍ → ℂ} (hx : x ∈ Algebra.adjoin ↥K T) : KPole K N x := by
+  induction hx using Algebra.adjoin_induction with
+  | mem g hg' => exact hT g hg'
+  | algebraMap r => exact kPole_algebraMap r
+  | add x y _ _ hx hy => exact hx.add hy
+  | mul x y _ _ hx hy => exact hx.mul hy
+
+end KPoleAlgebra2
+
+section Engine
+
+open Filter Function
+
+variable {N : ℕ} [NeZero N] {K : IntermediateField ℚ ℂ} {jf : ℍ → ℂ}
+  {fricke : (Fin 2 → ZMod N) → ℍ → ℂ}
+
+omit [NeZero N] in
+lemma KPoleAt.mono {F : IntermediateField ℚ ℂ} (h : K ≤ F) {m : ℕ} {f : ℍ → ℂ}
+    (hf : KPoleAt K N m f) : KPoleAt F N m f :=
+  ⟨hf.1, hf.2.1, fun n => h (hf.2.2 n)⟩
+
+lemma kPole_of_mem_adjoinF (hg : GenMD jf fricke)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    (hkp : ∀ v : Fin 2 → ZMod N, v ≠ 0 → KPoleAt K N 1 (fricke v))
+    {F : IntermediateField ℚ ℂ} (hKF : K ≤ F) {x : ℍ → ℂ}
+    (hx : x ∈ Algebra.adjoin ↥F (Set.range (gen jf fricke))) : KPole F N x := by
+  refine kPole_of_mem_adjoin (fun g hg' => ?_) hx
+  obtain ⟨o, rfl⟩ := hg'
+  cases o with
+  | none => exact kPole_jf F hjf
+  | some v => exact ⟨hg.fmd v.1 v.2, 1, (hkp v.1 v.2).mono hKF⟩
+
+omit [NeZero N] in
+lemma qExpansion_sum_smul {h : ℝ} {ι : Type} [Fintype ι] (c : ι → ℂ) (g : ι → ℍ → ℂ)
+    (hg' : ∀ i, AnalyticAt ℂ (cuspFunction h (g i)) 0) (n : ℕ) :
+    (qExpansion h (∑ i, c i • g i)).coeff n = ∑ i, c i * (qExpansion h (g i)).coeff n := by
+  classical
+  have key : ∀ s : Finset ι, AnalyticAt ℂ (cuspFunction h (∑ i ∈ s, c i • g i)) 0 ∧
+      (qExpansion h (∑ i ∈ s, c i • g i)).coeff n = ∑ i ∈ s, c i * (qExpansion h (g i)).coeff n :=
+        by
+    intro s
+    induction s using Finset.induction_on with
+    | empty =>
+      refine ⟨?_, ?_⟩
+      · simp only [Finset.sum_empty]
+        rw [show cuspFunction h (0 : ℍ → ℂ) = 0 by
+            simp only [cuspFunction, Periodic.cuspFunction, Pi.zero_comp, update_eq_self_iff,
+              Pi.zero_apply]
+            exact (tendsto_const_nhds.mono_left nhdsWithin_le_nhds).limUnder_eq]
+        exact analyticAt_const
+      · simp [qExpansion_zero]
+    | insert a s ha ih =>
+      obtain ⟨ih1, ih2⟩ := ih
+      have hsm : AnalyticAt ℂ (cuspFunction h (c a • g a)) 0 := by
+        rw [cuspFunction_smul (hg' a).continuousAt]
+        exact (hg' a).const_smul
+      rw [Finset.sum_insert ha]
+      refine ⟨?_, ?_⟩
+      · rw [cuspFunction_add hsm.continuousAt ih1.continuousAt]
+        exact hsm.add ih1
+      · rw [qExpansion_add hsm ih1, map_add, ih2, qExpansion_smul (hg' a), Finset.sum_insert ha]
+        simp
+  exact (key Finset.univ).2
+
+omit [NeZero N] in
+lemma periodic_of_kPoleAt {e : ℍ → ℂ} {m : ℕ} (h : KPoleAt K N m e) :
+    Function.Periodic (e ∘ UpperHalfPlane.ofComplex) N := by
+  intro w
+  have h1 := h.1 w
+  have h2 := periodic_discPow_comp_ofComplex m N w
+  simp only [Function.comp_apply, Pi.mul_apply, Pi.pow_apply] at h1 h2 ⊢
+  rw [h2] at h1
+  exact mul_right_cancel₀ (pow_ne_zero m (by
+    rw [CuspForm.coe_discriminant]; exact ModularForm.discriminant_ne_zero _)) h1
+
+omit [NeZero N] in
+lemma combo_props {ι : Type} [Fintype ι] (c : ι → ℂ) (e : ι → ℍ → ℂ)
+    {m : ℕ} (hm : ∀ i, KPoleAt K N m (e i)) :
+    Function.Periodic ((∑ i, c i • e i) ∘ UpperHalfPlane.ofComplex) N ∧
+      IsBoundedAtImInfty ((∑ i, c i • e i) * ⇑CuspForm.discriminant ^ m) ∧
+      ((∑ i, c i • e i) * ⇑CuspForm.discriminant ^ m : ℍ → ℂ) =
+        ∑ i, c i • (e i * ⇑CuspForm.discriminant ^ m) := by
+  classical
+  have hshape : ((∑ i, c i • e i) * ⇑CuspForm.discriminant ^ m : ℍ → ℂ) =
+      ∑ i, c i • (e i * ⇑CuspForm.discriminant ^ m) := by
+    rw [Finset.sum_mul]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [smul_mul_assoc]
+  refine ⟨?_, ?_, hshape⟩
+  · intro w
+    simp only [Function.comp_apply, Finset.sum_apply, Pi.smul_apply]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [show e i (UpperHalfPlane.ofComplex (w + N)) = e i (UpperHalfPlane.ofComplex w) from
+      periodic_of_kPoleAt (hm i) w]
+  · rw [hshape]
+    have : ∀ s, IsBoundedAtImInfty (∑ i ∈ s, c i • (e i * ⇑CuspForm.discriminant ^ m)) := by
+      intro s
+      induction s using Finset.induction_on with
+      | empty => exact Filter.const_boundedAtFilter atImInfty _
+      | insert a s ha ih =>
+        rw [Finset.sum_insert ha]
+        exact ((hm a).2.1.const_smul_left (c a)).add ih
+    exact this Finset.univ
+
+theorem eq_zero_of_const_relation (hg : GenMD jf fricke)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    (hkp : ∀ v : Fin 2 → ZMod N, v ≠ 0 → KPoleAt K N 1 (fricke v))
+    {F : IntermediateField ℚ ℂ} (hKF : K ≤ F) {c : ℂ} (hc : Transcendental ↥F c) {d : ℕ}
+    (a : Fin d → ℍ → ℂ) (ha : ∀ i, a i ∈ Algebra.adjoin ↥F (Set.range (gen jf fricke)))
+    (hrel : ∑ i : Fin d, c ^ (i : ℕ) • a i = 0) : ∀ i, a i = 0 := by
+  classical
+  have hdata := fun i => kPole_of_mem_adjoinF hg hjf hkp hKF (ha i)
+  choose hhol m hm using hdata
+  obtain ⟨M, hpad⟩ : ∃ M, ∀ i, KPoleAt F N M (a i) :=
+    ⟨Finset.univ.sup m, fun i => (hm i).pad (hhol i) (Finset.le_sup (Finset.mem_univ i))⟩
+  obtain ⟨hper, hbd, hshape⟩ := combo_props (fun i : Fin d => c ^ (i : ℕ)) a hpad
+  have han : ∀ i, AnalyticAt ℂ (cuspFunction N (a i * ⇑CuspForm.discriminant ^ M)) 0 := fun i =>
+    analyticAt_cuspFunction_zero_of (mdiff_mul_discPow (hhol i) M) (hpad i).1 (hpad i).2.1
+  have hrow : ∀ n : ℕ, ∑ i : Fin d, c ^ (i : ℕ) *
+      (qExpansion N (a i * ⇑CuspForm.discriminant ^ M)).coeff n = 0 := by
+    intro n
+    rw [← qExpansion_sum_smul _ _ han, ← hshape, hrel, zero_mul, qExpansion_zero, map_zero]
+  have hcoeff0 : ∀ (i : Fin d) (n : ℕ), (qExpansion N (a i * ⇑CuspForm.discriminant ^ M)).coeff n =
+    0 :=
+    by
+    intro i n
+    set z : Fin d → ↥F := fun i' => ⟨(qExpansion N (a i' * ⇑CuspForm.discriminant ^ M)).coeff n,
+      (hpad i').2.2 n⟩ with hz
+    set P : Polynomial ↥F := ∑ i', C (z i') * X ^ (i' : ℕ) with hP
+    have haeval : aeval c P = 0 := by
+      rw [hP, map_sum, ← hrow n]
+      refine Finset.sum_congr rfl fun i' _ => ?_
+      rw [map_mul, aeval_C, map_pow, aeval_X, mul_comm]
+      rfl
+    have hP0 : P = 0 := (transcendental_iff.mp hc) P haeval
+    have hcoeffP : P.coeff (i : ℕ) = z i := by
+      rw [hP, Polynomial.finsetSum_coeff, Finset.sum_eq_single i]
+      · rw [Polynomial.coeff_C_mul, Polynomial.coeff_X_pow, ite_eq_left rfl, mul_one]
+      · intro i' _ hne
+        rw [Polynomial.coeff_C_mul, Polynomial.coeff_X_pow, ite_eq_right (fun h => hne (Fin.ext
+          h).symm),
+          mul_zero]
+      · intro h; exact absurd (Finset.mem_univ i) h
+    have hzi : z i = 0 := by rw [← hcoeffP, hP0, Polynomial.coeff_zero]
+    exact congrArg Subtype.val hzi
+  intro i
+  have hgz : a i * ⇑CuspForm.discriminant ^ M = 0 := by
+    rw [← qExpansion_eq_zero_iff (Nat.cast_pos.mpr (Nat.pos_of_ne_zero (NeZero.ne N)))
+      (hpad i).1 (mdiff_mul_discPow (hhol i) M) (hpad i).2.1]
+    ext n
+    rw [hcoeff0 i n, map_zero]
+  funext τ
+  have hτ := congrFun hgz τ
+  simp only [Pi.mul_apply, Pi.pow_apply, Pi.zero_apply, mul_eq_zero] at hτ
+  exact hτ.resolve_right (pow_ne_zero _ (by
+    rw [CuspForm.coe_discriminant]; exact ModularForm.discriminant_ne_zero τ))
+
+theorem transcendental_closureS (hg : GenMD jf fricke)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    (hkp : ∀ v : Fin 2 → ZMod N, v ≠ 0 → KPoleAt K N 1 (fricke v))
+    {F : IntermediateField ℚ ℂ} (hKF : K ≤ F) {c : ℂ} (hc : Transcendental ↥F c) :
+    Transcendental ↥(Subfield.closure (⇑(algebraMap ℂ KK) '' (F : Set ℂ) ∪ SK hg))
+      (algebraMap ℂ KK c) := by
+  classical
+  set gS : Set KK := ⇑(algebraMap ℂ KK) '' (F : Set ℂ) ∪ SK hg with hgS
+  rw [transcendental_iff]
+  intro p hpe
+  by_contra hp0
+  set d : ℕ := p.natDegree + 1 with hd
+  have hy : ∀ i : Fin d, ∃ u ∈ Subring.closure gS, ∃ w ∈ Subring.closure gS,
+      w ≠ 0 ∧ u / w = ((p.coeff i : ↥(Subfield.closure gS)) : KK) := by
+    intro i
+    obtain ⟨u, hu, w, hw, huw⟩ := Subfield.mem_closure_iff.mp (p.coeff (i : ℕ)).2
+    by_cases hw0 : w = 0
+    · refine ⟨0, Subring.zero_mem _, 1, Subring.one_mem _, one_ne_zero, ?_⟩
+      rw [← huw, hw0, div_zero, zero_div]
+    · exact ⟨u, hu, w, hw, hw0, huw⟩
+  choose u hu w hw hw0 huw using hy
+  set W : KK := ∏ i, w i with hW
+  have hW0 : W ≠ 0 := Finset.prod_ne_zero_iff.mpr fun i _ => hw0 i
+  set A : Fin d → KK := fun i => u i * ∏ j ∈ Finset.univ.erase i, w j with hA
+  have hAmem : ∀ i, A i ∈ Subring.closure gS := fun i =>
+    Subring.mul_mem _ (hu i) (Subring.prod_mem _ fun j _ => hw j)
+  have hAW : ∀ i, A i = ((p.coeff i : ↥(Subfield.closure gS)) : KK) * W := by
+    intro i
+    have hwi := hw0 i
+    rw [← huw i, hW, ← Finset.mul_prod_erase Finset.univ w (Finset.mem_univ i)]
+    simp only [hA]
+    field_simp
+  have hrel : ∑ i : Fin d, A i * algebraMap ℂ KK c ^ (i : ℕ) = 0 := by
+    have h1 : (aeval (algebraMap ℂ KK c) p : KK) = 0 := hpe
+    rw [Polynomial.aeval_eq_sum_range, Finset.sum_range] at h1
+    have h2 : ∑ i : Fin d, A i * algebraMap ℂ KK c ^ (i : ℕ) =
+        W * ∑ i : Fin d, p.coeff (i : ℕ) • algebraMap ℂ KK c ^ (i : ℕ) := by
+      rw [Finset.mul_sum]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [hAW, Algebra.smul_def,
+        show algebraMap (↥(Subfield.closure gS)) KK (p.coeff i) = (p.coeff i : KK) from rfl]
+      ring
+    rw [h2, h1, mul_zero]
+  choose aH haH hιa using fun i => (mem_closureS_iff F hg (A i)).mp (hAmem i)
+  have hrelH : ∑ i : Fin d, (algebraMap ℂ ↥holSub c) ^ (i : ℕ) * aH i = 0 := by
+    apply ι_injective
+    rw [map_sum, map_zero, ← hrel]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [map_mul, map_pow, ι_algebraMap, hιa, mul_comm]
+  have hrelF : ∑ i : Fin d, c ^ (i : ℕ) • (aH i : ℍ → ℂ) = 0 := by
+    have h := congrArg (fun f : ↥holSub => (f : ℍ → ℂ)) hrelH
+    simp only [ZeroMemClass.coe_zero, AddSubmonoidClass.coe_finsetSum, MulMemClass.coe_mul,
+      SubmonoidClass.coe_pow] at h
+    rw [← h]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    funext τ
+    simp only [Pi.smul_apply, Pi.mul_apply, Pi.pow_apply, smul_eq_mul]
+    rfl
+  have hall := eq_zero_of_const_relation hg hjf hkp hKF hc (fun i => (aH i : ℍ → ℂ)) haH hrelF
+  have hcoef : ∀ i : Fin d, p.coeff (i : ℕ) = 0 := by
+    intro i
+    have hA0 : A i = 0 := by
+      rw [← hιa i, show aH i = 0 from Subtype.ext (hall i), map_zero]
+    have hc0 : ((p.coeff i : ↥(Subfield.closure gS)) : KK) = 0 := by
+      have := hAW i
+      rw [hA0] at this
+      exact (mul_eq_zero.mp this.symm).resolve_right hW0
+    exact_mod_cast hc0
+  apply hp0
+  refine Polynomial.ext fun i => ?_
+  rw [Polynomial.coeff_zero]
+  by_cases hi : i < d
+  · exact hcoef ⟨i, hi⟩
+  · exact Polynomial.coeff_eq_zero_of_natDegree_lt (by omega)
+
+lemma tendsto_atImInfty_of_levelOne {k : ℤ} (f : ModularForm 𝒮ℒ k) :
+    Tendsto (⇑f) atImInfty (𝓝 ((UpperHalfPlane.qExpansion 1 f).coeff 0)) := by
+  have hper := SlashInvariantFormClass.periodic_comp_ofComplex f one_mem_strictPeriods_SL
+  have hO := UpperHalfPlane.exp_decay_sub_atImInfty (f := ⇑f) one_pos hper f.holo'
+    (ModularFormClass.bdd_at_infty f)
+  have hv : valueAtInfty ⇑f = (UpperHalfPlane.qExpansion 1 f).coeff 0 :=
+    (UpperHalfPlane.qExpansion_coeff_zero one_pos
+      (ModularFormClass.analyticAt_cuspFunction_zero f one_pos one_mem_strictPeriods_SL)
+      hper).symm
+  have hexp : Tendsto (fun τ : ℍ ↦ Real.exp (-2 * π * τ.im / 1)) atImInfty (𝓝 0) := by
+    have h2 := (UpperHalfPlane.qParam_tendsto_atImInfty one_pos).norm
+    rw [norm_zero] at h2
+    refine h2.congr fun τ ↦ ?_
+    rw [Function.Periodic.norm_qParam, UpperHalfPlane.coe_im]
+  have := hO.trans_tendsto hexp
+  rw [tendsto_sub_nhds_zero_iff] at this
+  rwa [← hv]
+
+lemma tendsto_E_atImInfty {k : ℕ} (hk : 3 ≤ k) (hk2 : Even k) :
+    Tendsto (⇑(ModularForm.E hk)) atImInfty (𝓝 1) := by
+  have h := tendsto_atImInfty_of_levelOne (ModularForm.E hk)
+  rwa [EisensteinSeries.E_qExpansion_coeff_zero hk hk2] at h
+
+lemma aeval_pi_apply_C (p : Polynomial ℂ) (τ : ℍ) :
+    (Polynomial.aeval jf p : ℍ → ℂ) τ = p.eval (jf τ) := by
+  rw [Polynomial.aeval_def,
+    show (Polynomial.eval₂ (algebraMap ℂ (ℍ → ℂ)) jf p) τ =
+      (Pi.evalRingHom (fun _ : ℍ => ℂ) τ) (Polynomial.eval₂ (algebraMap ℂ (ℍ → ℂ)) jf p) from rfl,
+    Polynomial.hom_eval₂]
+  rfl
+
+theorem aeval_jf_eq_zero_imp (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant
+  τ)
+    (p : Polynomial ℂ) (hp : (Polynomial.aeval jf p : ℍ → ℂ) = 0) : p = 0 := by
+  by_contra hp0
+  set m := p.natDegree with hm
+  have hE : Tendsto (fun τ : ℍ => ModularForm.E₄ τ) atImInfty (𝓝 1) :=
+    tendsto_E_atImInfty (by norm_num) (by decide)
+  have hΔ : Tendsto (ModularForm.discriminant : ℍ → ℂ) atImInfty (𝓝 0) := by
+    have := CuspFormClass.zero_at_infty CuspForm.discriminant
+    rw [CuspForm.coe_discriminant] at this
+    exact this
+  have hexp : ∀ τ : ℍ, p.eval (jf τ) * ModularForm.discriminant τ ^ m =
+      ∑ k ∈ Finset.range (m + 1), p.coeff k * (ModularForm.E₄ τ ^ 3) ^ k *
+        ModularForm.discriminant τ ^ (m - k) := by
+    intro τ
+    rw [Polynomial.eval_eq_sum_range, Finset.sum_mul]
+    refine Finset.sum_congr rfl fun k hk => ?_
+    have hkm : k ≤ m := Nat.lt_succ_iff.mp (Finset.mem_range.mp hk)
+    rw [hjf τ, div_pow, ← pow_mul]
+    have hΔ0 : ModularForm.discriminant τ ^ k ≠ 0 :=
+      pow_ne_zero _ (ModularForm.discriminant_ne_zero τ)
+    rw [show ModularForm.discriminant τ ^ m = ModularForm.discriminant τ ^ k *
+      ModularForm.discriminant τ ^ (m - k) by rw [← pow_add, Nat.add_sub_cancel' hkm]]
+    field_simp
+  have hlim : Tendsto (fun τ : ℍ => p.eval (jf τ) * ModularForm.discriminant τ ^ m) atImInfty
+      (𝓝 (∑ k ∈ Finset.range (m + 1), p.coeff k * (1 ^ 3) ^ k * (0 : ℂ) ^ (m - k))) := by
+    simp_rw [hexp]
+    exact tendsto_finsetSum _ fun k _ =>
+      ((tendsto_const_nhds.mul ((hE.pow 3).pow k)).mul (hΔ.pow (m - k)))
+  have hsum : ∑ k ∈ Finset.range (m + 1), p.coeff k * (1 ^ 3) ^ k * (0 : ℂ) ^ (m - k) =
+      p.leadingCoeff := by
+    rw [Finset.sum_eq_single m]
+    · simp only [Nat.sub_self, pow_zero, mul_one, one_pow]
+      rfl
+    · intro k hk hkm
+      have : m - k ≠ 0 := Nat.sub_ne_zero_of_lt (lt_of_le_of_ne
+        (Nat.lt_succ_iff.mp (Finset.mem_range.mp hk)) hkm)
+      simp [zero_pow this]
+    · intro h; exact absurd (Finset.self_mem_range_succ m) h
+  rw [hsum] at hlim
+  have hzero : (fun τ : ℍ => p.eval (jf τ) * ModularForm.discriminant τ ^ m) = fun _ => 0 := by
+    funext τ
+    have := congrFun hp τ
+    rw [aeval_pi_apply_C, Pi.zero_apply] at this
+    rw [this, zero_mul]
+  rw [hzero] at hlim
+  have := tendsto_nhds_unique hlim tendsto_const_nhds
+  exact hp0 (Polynomial.leadingCoeff_eq_zero.mp this)
+
+omit [NeZero N] in
+theorem transcendental_tK (hg : GenMD jf fricke)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) :
+    Transcendental ℂ (tK hg) := by
+  rw [transcendental_iff]
+  intro p hp
+  apply aeval_jf_eq_zero_imp hjf p
+  have h1 : (Polynomial.aeval (tK hg) p : KK) = ι (Polynomial.aeval (genH hg none) p) := by
+    rw [tK, show (ι : ↥holSub →+* KK) = (IsScalarTower.toAlgHom ℂ ↥holSub KK : ↥holSub →+* KK)
+      from rfl]
+    exact Polynomial.aeval_algHom_apply (IsScalarTower.toAlgHom ℂ ↥holSub KK) _ _
+  rw [h1, map_eq_zero_iff _ ι_injective] at hp
+  have h2 := congrArg (fun f : ↥holSub => (f : ℍ → ℂ)) hp
+  simp only [Subalgebra.coe_zero] at h2
+  rw [← h2]
+  exact (Polynomial.aeval_algHom_apply holSub.val (genH hg none) p)
+
+end Engine
+
+section Chain
+
+variable {N : ℕ} [NeZero N] (K : IntermediateField ℚ ℂ) {jf : ℍ → ℂ}
+  {fricke : (Fin 2 → ZMod N) → ℍ → ℂ}
+
+def Gch : List ℂ → IntermediateField ℚ ℂ
+  | [] => K
+  | c :: l => (IntermediateField.adjoin ↥(Gch l) {c}).restrictScalars ℚ
+
+omit [NeZero N] in
+lemma Gch_cons (c : ℂ) (l : List ℂ) :
+    Gch K (c :: l) = (IntermediateField.adjoin ↥(Gch K l) {c}).restrictScalars ℚ := rfl
+
+omit [NeZero N] in
+lemma le_adjoin_restrictScalars (F : IntermediateField ℚ ℂ) (c : ℂ) :
+    F ≤ (IntermediateField.adjoin ↥F {c}).restrictScalars ℚ := fun x hx ↦
+  IntermediateField.algebraMap_mem (IntermediateField.adjoin ↥F {c}) (⟨x, hx⟩ : ↥F)
+
+lemma Gch_le_cons (c : ℂ) (l : List ℂ) : Gch K l ≤ Gch K (c :: l) :=
+  le_adjoin_restrictScalars _ c
+
+lemma K_le_Gch : ∀ l : List ℂ, K ≤ Gch K l
+  | [] => le_rfl
+  | c :: l => (K_le_Gch l).trans (Gch_le_cons K c l)
+
+lemma mem_Gch_of_mem : ∀ {l : List ℂ} {c : ℂ}, c ∈ l → c ∈ Gch K l
+  | d :: l, c, h => by
+    rcases List.mem_cons.mp h with rfl | h
+    · exact IntermediateField.mem_adjoin_simple_self ↥(Gch K l) c
+    · exact Gch_le_cons K d l (mem_Gch_of_mem h)
+
+lemma Gch_le {M : IntermediateField ℚ ℂ} (hk : K ≤ M) :
+    ∀ {l : List ℂ}, (∀ c ∈ l, c ∈ M) → Gch K l ≤ M
+  | [], _ => hk
+  | c :: l, h => by
+    intro x hx
+    have ih : Gch K l ≤ M := Gch_le hk fun d hd ↦ h d (List.mem_cons_of_mem c hd)
+    change x ∈ IntermediateField.adjoin ↥(Gch K l) {c} at hx
+    rw [← IntermediateField.mem_toSubfield, IntermediateField.adjoin_toSubfield] at hx
+    refine (Subfield.closure_le (t := M.toSubfield)).mpr ?_ hx
+    rintro y (⟨z, rfl⟩ | hy)
+    · exact ih z.2
+    · rw [Set.mem_singleton_iff] at hy; subst hy; exact h _ List.mem_cons_self
+
+lemma Gch_le_append_left (l₁ l₂ : List ℂ) : Gch K l₁ ≤ Gch K (l₁ ++ l₂) :=
+  Gch_le K (K_le_Gch K _) fun _ hc ↦ mem_Gch_of_mem K (List.mem_append_left l₂ hc)
+
+lemma Gch_le_append_right (l₁ l₂ : List ℂ) : Gch K l₂ ≤ Gch K (l₁ ++ l₂) :=
+  Gch_le K (K_le_Gch K _) fun _ hc ↦ mem_Gch_of_mem K (List.mem_append_right l₁ hc)
+
+omit [NeZero N] in
+lemma adjoin_subfield_mono {F F' : IntermediateField ℚ ℂ} (h : F ≤ F') (T : Set (ℍ → ℂ))
+    {y : ℍ → ℂ} (hy : y ∈ Algebra.adjoin ↥F T) : y ∈ Algebra.adjoin ↥F' T := by
+  induction hy using Algebra.adjoin_induction with
+  | mem x hx => exact Algebra.subset_adjoin hx
+  | algebraMap z => exact Subalgebra.algebraMap_mem (Algebra.adjoin ↥F' T) (⟨z, h z.2⟩ : ↥F')
+  | add x y _ _ hx hy => exact Subalgebra.add_mem _ hx hy
+  | mul x y _ _ hx hy => exact Subalgebra.mul_mem _ hx hy
+
+lemma exists_list_of_mem_adjoin {T : Set (ℍ → ℂ)} {y : ℍ → ℂ} (hy : y ∈ Algebra.adjoin ℂ T) :
+    ∃ l : List ℂ, y ∈ Algebra.adjoin ↥(Gch K l) T := by
+  induction hy using Algebra.adjoin_induction with
+  | mem x hx => exact ⟨[], Algebra.subset_adjoin hx⟩
+  | algebraMap z =>
+    refine ⟨[z], ?_⟩
+    have : algebraMap ℂ (ℍ → ℂ) z =
+        algebraMap ↥(Gch K [z]) (ℍ → ℂ) ⟨z, mem_Gch_of_mem K List.mem_cons_self⟩ := rfl
+    rw [this]
+    exact Subalgebra.algebraMap_mem _ _
+  | add x y _ _ ihx ihy =>
+    obtain ⟨l₁, h₁⟩ := ihx
+    obtain ⟨l₂, h₂⟩ := ihy
+    exact ⟨l₁ ++ l₂, Subalgebra.add_mem _ (adjoin_subfield_mono (Gch_le_append_left K l₁ l₂) T h₁)
+      (adjoin_subfield_mono (Gch_le_append_right K l₁ l₂) T h₂)⟩
+  | mul x y _ _ ihx ihy =>
+    obtain ⟨l₁, h₁⟩ := ihx
+    obtain ⟨l₂, h₂⟩ := ihy
+    exact ⟨l₁ ++ l₂, Subalgebra.mul_mem _ (adjoin_subfield_mono (Gch_le_append_left K l₁ l₂) T h₁)
+      (adjoin_subfield_mono (Gch_le_append_right K l₁ l₂) T h₂)⟩
+
+variable (hg : GenMD jf fricke)
+
+def RS (F : IntermediateField ℚ ℂ) : Set KK :=
+  {z : KK | z ∈ Subfield.closure (⇑(algebraMap ℂ KK) '' (F : Set ℂ) ∪ SK hg) ∧
+    IsIntegral ↥(Subring.closure (⇑(algebraMap ℂ KK) '' (F : Set ℂ) ∪ {tK hg})) z}
+
+variable {K hg}
+
+omit [NeZero N] in
+lemma isIntegral_closureT_of_monicRel (F : IntermediateField ℚ ℂ) {f : ℍ → ℂ}
+    (hf : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) {d : ℕ} (p : Fin d → Polynomial ℂ)
+    (hpF : ∀ (i : Fin d) (n : ℕ), (p i).coeff n ∈ F)
+    (hrel : ∀ τ : ℍ, f τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * f τ ^ (i : ℕ) = 0) :
+    IsIntegral ↥(Subring.closure (⇑(algebraMap ℂ KK) '' (F : Set ℂ) ∪ {tK hg})) (ι ⟨f, hf⟩) := by
+  set T := Subring.closure (⇑(algebraMap ℂ KK) '' (F : Set ℂ) ∪ {tK hg}) with hT
+  have hlift : ∀ i : Fin d, ∃ q : Polynomial ↥F, q.map (algebraMap ↥F ℂ) = p i := fun i => by
+    rw [← Polynomial.mem_lifts, Polynomial.lifts_iff_coeff_lifts]
+    exact fun n => ⟨⟨(p i).coeff n, hpF i n⟩, rfl⟩
+  choose q hq using hlift
+  have hcmem : ∀ i : Fin d, (Polynomial.aeval jf (q i) : ℍ → ℂ) ∈ holSub := fun i =>
+    adjoin_le_holSub (R := ↥F) (T := {jf}) (by rintro _ rfl; exact hg.jmd)
+      (Polynomial.aeval_mem_adjoin_singleton ↥F jf)
+  have hcT : ∀ i : Fin d, ι ⟨_, hcmem i⟩ ∈ T := fun i =>
+    (mem_closureT_iff F hg _).mpr ⟨⟨_, hcmem i⟩, Polynomial.aeval_mem_adjoin_singleton ↥F jf, rfl⟩
+  have hcval : ∀ (i : Fin d) (τ : ℍ), (Polynomial.aeval jf (q i) : ℍ → ℂ) τ = (p i).eval (jf τ) :=
+    by
+    intro i τ
+    rw [Polynomial.aeval_def,
+      show (Polynomial.eval₂ (algebraMap ↥F (ℍ → ℂ)) jf (q i)) τ =
+        (Pi.evalRingHom (fun _ : ℍ => ℂ) τ) (Polynomial.eval₂ (algebraMap ↥F (ℍ → ℂ)) jf (q i))
+        from rfl,
+      Polynomial.hom_eval₂, ← hq i, Polynomial.eval_map]
+    rfl
+  let cT : Fin d → ↥T := fun i => ⟨ι ⟨_, hcmem i⟩, hcT i⟩
+  refine ⟨X ^ d + ∑ i : Fin d, C (cT i) * X ^ (i : ℕ),
+    Polynomial.monic_X_pow_add (Polynomial.degree_sum_fin_lt _), ?_⟩
+  rw [Polynomial.eval₂_add, Polynomial.eval₂_X_pow, Polynomial.eval₂_finsetSum]
+  simp only [Polynomial.eval₂_mul, Polynomial.eval₂_C, Polynomial.eval₂_X_pow]
+  have hrelH : (⟨f, hf⟩ : ↥holSub) ^ d + ∑ i : Fin d, ⟨_, hcmem i⟩ * (⟨f, hf⟩ : ↥holSub) ^ (i : ℕ) =
+    0 :=
+    by
+    apply Subtype.ext
+    simp only [AddMemClass.coe_add, SubmonoidClass.coe_pow, AddSubmonoidClass.coe_finsetSum,
+      MulMemClass.coe_mul, ZeroMemClass.coe_zero]
+    funext τ
+    simp only [Pi.add_apply, Pi.pow_apply, Finset.sum_apply, Pi.mul_apply, Pi.zero_apply, hcval]
+    exact hrel τ
+  set a : ↥holSub := ⟨f, hf⟩ with ha
+  have e1 : ι a ^ d = ι (a ^ d) := (map_pow ι a d).symm
+  have e2 : ∀ x : Fin d, algebraMap (↥T) KK (cT x) * ι a ^ (x : ℕ) =
+      ι (⟨_, hcmem x⟩ * a ^ (x : ℕ)) := fun x => by
+    rw [map_mul ι, map_pow ι]
+    rfl
+  rw [e1, Finset.sum_congr rfl fun x _ => e2 x, ← map_sum ι,
+    ← map_add ι (a ^ d) (∑ x : Fin d, ⟨_, hcmem x⟩ * a ^ (x : ℕ)), hrelH, map_zero ι]
+
+omit [NeZero N] in
+lemma isIntegral_SK {F : IntermediateField ℚ ℂ} (hKF : K ≤ F)
+    (hint : ∀ v : Fin 2 → ZMod N, v ≠ 0 → ∃ (d : ℕ) (p : Fin d → Polynomial ℂ),
+      (∀ (i : Fin d) (n : ℕ), (p i).coeff n ∈ K) ∧
+      ∀ τ : ℍ, fricke v τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * fricke v τ ^ (i : ℕ) = 0)
+    {s : KK} (hs : s ∈ SK hg) :
+    IsIntegral ↥(Subring.closure (⇑(algebraMap ℂ KK) '' (F : Set ℂ) ∪ {tK hg})) s := by
+  obtain ⟨o, rfl⟩ := hs
+  cases o with
+  | none =>
+    exact isIntegral_algebraMap (R := ↥(Subring.closure (⇑(algebraMap ℂ KK) '' (F : Set ℂ) ∪
+      {tK hg}))) (A := KK) (x := ⟨tK hg, Subring.subset_closure (Or.inr rfl)⟩)
+  | some v =>
+    obtain ⟨d, p, hpK, hrel⟩ := hint v.1 v.2
+    exact isIntegral_closureT_of_monicRel F (hg.fmd v.1 v.2) p (fun i n => hKF (hpK i n)) hrel
+
+def R7bShape : Prop :=
+  ∀ (F : IntermediateField ℚ ℂ) (B S : Set KK), B ⊆ S → ∀ (c : ℂ), IsAlgebraic ↥F c → ∀ (y : KK),
+    y ∈ Subfield.closure
+      (⇑(algebraMap ℂ KK) '' (IntermediateField.adjoin ↥F {c} : Set ℂ) ∪ S) →
+    IsIntegral ↥(Subring.closure
+      (⇑(algebraMap ℂ KK) '' (IntermediateField.adjoin ↥F {c} : Set ℂ) ∪ B)) y →
+    y ∈ Submodule.span ℂ {z : KK | z ∈ Subfield.closure (⇑(algebraMap ℂ KK) '' (F : Set ℂ) ∪ S) ∧
+      IsIntegral ↥(Subring.closure (⇑(algebraMap ℂ KK) '' (F : Set ℂ) ∪ B)) z}
+
+def R8aShape : Prop :=
+  ∀ (F : IntermediateField ℚ ℂ) (t : KK), Transcendental ℂ t → ∀ (S : Set KK), t ∈ S → S.Finite →
+    (∀ s ∈ S, IsIntegral ↥(Subring.closure (⇑(algebraMap ℂ KK) '' (F : Set ℂ) ∪ {t})) s) →
+    ∀ (c : ℂ), Transcendental ↥F c →
+    Transcendental ↥(Subfield.closure (⇑(algebraMap ℂ KK) '' (F : Set ℂ) ∪ S)) (algebraMap ℂ KK c) →
+    ∀ (y : KK),
+    y ∈ Subfield.closure (⇑(algebraMap ℂ KK) '' (IntermediateField.adjoin ↥F {c} : Set ℂ) ∪ S) →
+    IsIntegral ↥(Subring.closure
+      (⇑(algebraMap ℂ KK) '' (IntermediateField.adjoin ↥F {c} : Set ℂ) ∪ {t})) y →
+    y ∈ Submodule.span ℂ {z : KK | z ∈ Subfield.closure (⇑(algebraMap ℂ KK) '' (F : Set ℂ) ∪ S) ∧
+      IsIntegral ↥(Subring.closure (⇑(algebraMap ℂ KK) '' (F : Set ℂ) ∪ {t})) z}
+
+variable (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+  (hkp : ∀ v : Fin 2 → ZMod N, v ≠ 0 → KPoleAt K N 1 (fricke v))
+  (hint : ∀ v : Fin 2 → ZMod N, v ≠ 0 → ∃ (d : ℕ) (p : Fin d → Polynomial ℂ),
+    (∀ (i : Fin d) (n : ℕ), (p i).coeff n ∈ K) ∧
+    ∀ τ : ℍ, fricke v τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * fricke v τ ^ (i : ℕ) = 0)
+  (h7 : R7bShape) (h8 : R8aShape)
+include hjf hkp hint h7 h8
+
+theorem RS_cons_subset_span (c : ℂ) (l : List ℂ) :
+    RS hg (Gch K (c :: l)) ⊆ (Submodule.span ℂ (RS hg (Gch K l)) : Set KK) := by
+  rintro y ⟨hyS, hyB⟩
+  rw [Gch_cons, IntermediateField.coe_restrictScalars] at hyS hyB
+  by_cases hc : IsAlgebraic ↥(Gch K l) c
+  · exact h7 (Gch K l) {tK hg} (SK hg) (Set.singleton_subset_iff.mpr (tK_mem_SK hg)) c hc y hyS hyB
+  · exact h8 (Gch K l) (tK hg) (transcendental_tK hg hjf) (SK hg) (tK_mem_SK hg) (SK_finite hg)
+      (fun s hs => isIntegral_SK (K_le_Gch K l) hint hs) c hc
+      (transcendental_closureS hg hjf hkp (K_le_Gch K l) hc) y hyS hyB
+
+theorem RS_Gch_subset_span (l : List ℂ) :
+    RS hg (Gch K l) ⊆ (Submodule.span ℂ (RS hg K) : Set KK) := by
+  induction l with
+  | nil => exact Submodule.subset_span
+  | cons c l ih =>
+    exact (RS_cons_subset_span hjf hkp hint h7 h8 c l).trans (Submodule.span_le.mpr ih)
+
+omit [NeZero N] hjf hkp hint h7 h8 in
+theorem exists_list_mem_RS {G a b : ℍ → ℂ} (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (ha : a ∈ Algebra.adjoin ℂ (Set.range (gen jf fricke)))
+    (hb : b ∈ Algebra.adjoin ℂ (Set.range (gen jf fricke))) (hb0 : b ≠ 0) (hGb : G * b = a)
+    {d : ℕ} (p : Fin d → Polynomial ℂ)
+    (hprel : ∀ τ : ℍ, G τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * G τ ^ (i : ℕ) = 0) :
+    ∃ l : List ℂ, ι ⟨G, hG⟩ ∈ RS hg (Gch K l) := by
+  classical
+  obtain ⟨la, hla⟩ := exists_list_of_mem_adjoin K ha
+  obtain ⟨lb, hlb⟩ := exists_list_of_mem_adjoin K hb
+  let lc : Fin d → List ℂ := fun i => (List.range ((p i).natDegree + 1)).map (p i).coeff
+  set L : List ℂ := la ++ lb ++ (List.finRange d).flatMap lc with hL
+  have hLa : Gch K la ≤ Gch K L := (Gch_le_append_left K la lb).trans (Gch_le_append_left K _ _)
+  have hLb : Gch K lb ≤ Gch K L := (Gch_le_append_right K la lb).trans (Gch_le_append_left K _ _)
+  have hLc : ∀ (i : Fin d) (n : ℕ), (p i).coeff n ∈ Gch K L := by
+    intro i n
+    by_cases hn : n ≤ (p i).natDegree
+    · refine Gch_le_append_right K _ _ (mem_Gch_of_mem K ?_)
+      exact List.mem_flatMap.mpr ⟨i, List.mem_finRange i,
+        List.mem_map.mpr ⟨n, List.mem_range.mpr (Nat.lt_succ_of_le hn), rfl⟩⟩
+    · rw [Polynomial.coeff_eq_zero_of_natDegree_lt (not_le.mp hn)]
+      exact zero_mem _
+  have hamd : a ∈ holSub := adjoin_le_holSub (range_gen_subset_holSub hg) ha
+  have hbmd : b ∈ holSub := adjoin_le_holSub (range_gen_subset_holSub hg) hb
+  have haS := (mem_closureS_iff (Gch K L) hg _).mpr ⟨⟨a, hamd⟩, adjoin_subfield_mono hLa _ hla, rfl⟩
+  have hbS := (mem_closureS_iff (Gch K L) hg _).mpr ⟨⟨b, hbmd⟩, adjoin_subfield_mono hLb _ hlb, rfl⟩
+  have hb0' : ι ⟨b, hbmd⟩ ≠ 0 :=
+    fun h => hb0 (congrArg Subtype.val ((map_eq_zero_iff ι ι_injective).mp h))
+  refine ⟨L, ?_, isIntegral_closureT_of_monicRel (Gch K L) hG p hLc hprel⟩
+  have hGab : ι ⟨G, hG⟩ = ι ⟨a, hamd⟩ / ι ⟨b, hbmd⟩ :=
+    eq_div_of_mul_eq hb0' ((map_mul ι ⟨G, hG⟩ ⟨b, hbmd⟩).symm.trans (congrArg ι (Subtype.ext hGb)))
+  have haF : ι ⟨a, hamd⟩ ∈ Subfield.closure (⇑(algebraMap ℂ KK) '' ((Gch K L : IntermediateField ℚ
+    ℂ) : Set ℂ) ∪ SK hg) :=
+    Subfield.subring_closure_le _ haS
+  have hbF : ι ⟨b, hbmd⟩ ∈ Subfield.closure (⇑(algebraMap ℂ KK) '' ((Gch K L : IntermediateField ℚ
+    ℂ) : Set ℂ) ∪ SK hg) :=
+    Subfield.subring_closure_le _ hbS
+  rw [hGab]
+  exact Subfield.div_mem _ haF hbF
+
+end Chain
+
+section Assembly
+
+variable {N : ℕ} [NeZero N] {K : IntermediateField ℚ ℂ} {jf : ℍ → ℂ}
+  {fricke : (Fin 2 → ZMod N) → ℍ → ℂ} {hg : GenMD jf fricke}
+
+def R6h2Shape : Prop :=
+  ∀ {a b : ℍ → ℂ} {c : ℕ → ℍ → ℂ} {d : ℕ}, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) a →
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) b → b ≠ 0 → (∀ k < d, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (c k)) →
+    a ^ d + ∑ k ∈ Finset.range d, c k * b ^ (d - k) * a ^ k = 0 →
+    ∃ F : ℍ → ℂ, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F ∧ F * b = a
+
+omit [NeZero N] in
+lemma aeval_pi_apply (q : Polynomial ↥K) (τ : ℍ) :
+    (Polynomial.aeval jf q : ℍ → ℂ) τ = (q.map (algebraMap ↥K ℂ)).eval (jf τ) := by
+  rw [Polynomial.aeval_def, Polynomial.eval_map,
+    show (Polynomial.eval₂ (algebraMap ↥K (ℍ → ℂ)) jf q) τ =
+      (Pi.evalRingHom (fun _ : ℍ => ℂ) τ) (Polynomial.eval₂ (algebraMap ↥K (ℍ → ℂ)) jf q) from rfl,
+    Polynomial.hom_eval₂]
+  rfl
+
+omit [NeZero N] in
+theorem holRep (h6 : R6h2Shape) {z : KK} (hz : z ∈ RS hg K) :
+    ∃ (Gf u w : ℍ → ℂ) (hGf : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) Gf),
+      u ∈ Algebra.adjoin ↥K (Set.range (gen jf fricke)) ∧
+      w ∈ Algebra.adjoin ↥K (Set.range (gen jf fricke)) ∧ w ≠ 0 ∧ Gf * w = u ∧ ι ⟨Gf, hGf⟩ = z ∧
+      ∃ (D : ℕ) (q : Fin D → Polynomial ↥K), ∀ τ : ℍ,
+        Gf τ ^ D + ∑ k : Fin D, ((q k).map (algebraMap ↥K ℂ)).eval (jf τ) * Gf τ ^ (k : ℕ) = 0 := by
+  classical
+  obtain ⟨hzS, hzB⟩ := hz
+  obtain ⟨uH, huH, wH, hwH, hw0, hzuw⟩ : ∃ uH : ↥holSub,
+      (uH : ℍ → ℂ) ∈ Algebra.adjoin ↥K (Set.range (gen jf fricke)) ∧ ∃ wH : ↥holSub,
+      (wH : ℍ → ℂ) ∈ Algebra.adjoin ↥K (Set.range (gen jf fricke)) ∧ ι wH ≠ 0 ∧
+      z = ι uH / ι wH := by
+    obtain ⟨u, hu, w, hw, huw⟩ := Subfield.mem_closure_iff.mp hzS
+    obtain ⟨uH, huH, rfl⟩ := (mem_closureS_iff K hg u).mp hu
+    obtain ⟨wH, hwH, rfl⟩ := (mem_closureS_iff K hg w).mp hw
+    by_cases hw0 : ι wH = 0
+    · refine ⟨0, Subalgebra.zero_mem _, 1, Subalgebra.one_mem _, ?_, ?_⟩
+      · rw [map_one ι]; exact one_ne_zero
+      · rw [← huw, hw0, div_zero, map_zero ι, zero_div]
+    · exact ⟨uH, huH, wH, hwH, hw0, huw.symm⟩
+  have hwH0 : (wH : ℍ → ℂ) ≠ 0 := fun h => hw0 (by rw [show wH = 0 from Subtype.ext h, map_zero ι])
+  have hzw : z * ι wH = ι uH := by rw [hzuw, div_mul_cancel₀ _ hw0]
+  obtain ⟨P, hPm, hPc, hPz⟩ := (isIntegral_subring_iff _ _).mp hzB
+  choose cH hcH hcHι using fun k => (mem_closureT_iff K hg (P.coeff k)).mp (hPc k)
+  set D := P.natDegree with hD
+  have hkey : ∀ k ≤ D, z ^ k * ι wH ^ D = ι uH ^ k * ι wH ^ (D - k) := fun k hk => by
+    calc z ^ k * ι wH ^ D = z ^ k * (ι wH ^ k * ι wH ^ (D - k)) := by
+          rw [← pow_add, Nat.add_sub_cancel' hk]
+      _ = (z * ι wH) ^ k * ι wH ^ (D - k) := by rw [mul_pow, mul_assoc]
+      _ = ι uH ^ k * ι wH ^ (D - k) := by rw [hzw]
+  have hrelK : ι uH ^ D + ∑ k ∈ Finset.range D, ι (cH k) * ι wH ^ (D - k) * ι uH ^ k = 0 := by
+    have h1 : (∑ k ∈ Finset.range (D + 1), P.coeff k * z ^ k) * ι wH ^ D = 0 := by
+      rw [← Polynomial.eval_eq_sum_range, hPz, zero_mul]
+    have h2 : ∑ k ∈ Finset.range D, P.coeff k * z ^ k * ι wH ^ D =
+        ∑ k ∈ Finset.range D, ι (cH k) * ι wH ^ (D - k) * ι uH ^ k :=
+      Finset.sum_congr rfl fun k hk => by
+        rw [mul_assoc, hkey k (Finset.mem_range.mp hk).le, ← hcHι k]; ring
+    rw [Finset.sum_mul, Finset.sum_range_succ, h2, show P.coeff D = 1 from hPm.coeff_natDegree,
+      one_mul, hkey D le_rfl, Nat.sub_self, pow_zero, mul_one, add_comm] at h1
+    exact h1
+  have hrelH : uH ^ D + ∑ k ∈ Finset.range D, cH k * wH ^ (D - k) * uH ^ k = 0 := by
+    apply ι_injective
+    rw [map_zero ι, ← hrelK, map_add ι (uH ^ D) (∑ k ∈ Finset.range D, cH k * wH ^ (D - k) * uH ^
+      k),
+      map_pow ι, map_sum ι]
+    refine congrArg _ (Finset.sum_congr rfl fun k _ => ?_)
+    rw [map_mul ι, map_mul ι, map_pow ι, map_pow ι]
+  have hrelF : (uH : ℍ → ℂ) ^ D +
+      ∑ k ∈ Finset.range D, (cH k : ℍ → ℂ) * (wH : ℍ → ℂ) ^ (D - k) * (uH : ℍ → ℂ) ^ k = 0 := by
+    have := congrArg Subtype.val hrelH
+    simpa only [AddMemClass.coe_add, SubmonoidClass.coe_pow, AddSubmonoidClass.coe_finsetSum,
+      MulMemClass.coe_mul, ZeroMemClass.coe_zero] using this
+  obtain ⟨Gf, hGf, hGw⟩ := h6 uH.2 wH.2 hwH0 (fun k _ => (cH k).2) hrelF
+  have hιG : ι ⟨Gf, hGf⟩ = z := by
+    rw [hzuw, eq_div_iff hw0, ← map_mul ι ⟨Gf, hGf⟩ wH]
+    exact congrArg ι (Subtype.ext hGw)
+  choose q hq using fun k : Fin D => Algebra.adjoin_mem_exists_aeval _ _ (hcH k)
+  have hg0 : (⟨Gf, hGf⟩ : ↥holSub) ^ D + ∑ k ∈ Finset.range D, cH k * ⟨Gf, hGf⟩ ^ k = 0 := by
+    apply ι_injective
+    have h1 : ∑ k ∈ Finset.range D, P.coeff k * ι ⟨Gf, hGf⟩ ^ k + ι ⟨Gf, hGf⟩ ^ D = 0 := by
+      have := hPz
+      rwa [Polynomial.eval_eq_sum_range, Finset.sum_range_succ,
+        show P.coeff D = 1 from hPm.coeff_natDegree, one_mul, ← hιG] at this
+    rw [map_zero ι, map_add ι ((⟨Gf, hGf⟩ : ↥holSub) ^ D)
+      (∑ k ∈ Finset.range D, cH k * ⟨Gf, hGf⟩ ^ k), map_pow ι, map_sum ι, add_comm, ← h1]
+    congr 1
+    refine Finset.sum_congr rfl fun k _ => ?_
+    rw [map_mul ι, map_pow ι, hcHι]
+  refine ⟨Gf, uH, wH, hGf, huH, hwH, hwH0, hGw, hιG, D, q, fun τ => ?_⟩
+  have h := congrArg (fun f : ↥holSub => (f : ℍ → ℂ) τ) hg0
+  simp only [AddMemClass.coe_add, SubmonoidClass.coe_pow, AddSubmonoidClass.coe_finsetSum,
+    MulMemClass.coe_mul, ZeroMemClass.coe_zero, Pi.add_apply, Pi.pow_apply, Finset.sum_apply,
+    Pi.mul_apply, Pi.zero_apply] at h
+  rw [Finset.sum_range] at h
+  rw [← h]
+  congr 1
+  refine Finset.sum_congr rfl fun k _ => ?_
+  rw [← aeval_pi_apply, hq k]
+
+include hg in
+theorem main (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    (hkp : ∀ v : Fin 2 → ZMod N, v ≠ 0 → KPoleAt K N 1 (fricke v))
+    (hint : ∀ v : Fin 2 → ZMod N, v ≠ 0 → ∃ (d : ℕ) (p : Fin d → Polynomial ℂ),
+      (∀ (i : Fin d) (n : ℕ), (p i).coeff n ∈ K) ∧
+      ∀ τ : ℍ, fricke v τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * fricke v τ ^ (i : ℕ) = 0)
+    (h6 : R6h2Shape) (h7 : R7bShape) (h8 : R8aShape)
+    {G a b : ℍ → ℂ} (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (ha : a ∈ Algebra.adjoin ℂ
+      (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}))
+    (hb : b ∈ Algebra.adjoin ℂ
+      (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}))
+    (hb0 : b ≠ 0) (hGb : G * b = a)
+    {d : ℕ} (p : Fin d → Polynomial ℂ)
+    (hprel : ∀ τ : ℍ, G τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * G τ ^ (i : ℕ) = 0) :
+    ∃ (n : ℕ) (lam : Fin n → ℂ) (Gi : Fin n → (ℍ → ℂ))
+      (Pi Qi : Fin n → (ℍ → ℂ))
+      (di : Fin n → ℕ) (pi : ∀ i, Fin (di i) → Polynomial ℂ),
+      (G = ∑ i, lam i • Gi i) ∧
+      (∀ i, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (Gi i)) ∧
+      (∀ i, Pi i ∈ Algebra.adjoin ↥K
+          (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}) ∧
+        Qi i ∈ Algebra.adjoin ↥K
+          (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}) ∧
+        Qi i ≠ 0 ∧ Gi i * Qi i = Pi i) ∧
+      (∀ i k m, (pi i k).coeff m ∈ K) ∧
+      (∀ i τ, Gi i τ ^ di i +
+        ∑ k : Fin (di i), (pi i k).eval (jf τ) * Gi i τ ^ (k : ℕ) = 0) := by
+  rw [← range_gen jf fricke] at ha hb ⊢
+  obtain ⟨Lc, hLc⟩ := exists_list_mem_RS (K := K) (hg := hg) hG ha hb hb0 hGb p hprel
+  have hspan : ι ⟨G, hG⟩ ∈ Submodule.span ℂ (RS hg K) :=
+    RS_Gch_subset_span hjf hkp hint h7 h8 Lc hLc
+  obtain ⟨n, lam, z, hz⟩ := Submodule.mem_span_set'.mp hspan
+  choose Gf u w hGf hu hw hw0 hGw hιG D q hrel using fun i => holRep h6 (z i).2
+  refine ⟨n, lam, Gf, u, w, D, fun i k => (q i k).map (algebraMap ↥K ℂ), ?_, hGf,
+    fun i => ⟨hu i, hw i, hw0 i, hGw i⟩, fun i k m => ?_, hrel⟩
+  · have hH : (⟨G, hG⟩ : ↥holSub) = ∑ i, lam i • (⟨Gf i, hGf i⟩ : ↥holSub) := by
+      apply ι_injective
+      rw [map_sum ι, ← hz]
+      refine Finset.sum_congr rfl fun i _ => ?_
+      rw [Algebra.smul_def, Algebra.smul_def, map_mul ι, ι_algebraMap, hιG]
+    have := congrArg Subtype.val hH
+    simpa only [AddSubmonoidClass.coe_finsetSum, SetLike.val_smul] using this
+  · rw [Polynomial.coeff_map]
+    exact ((q i k).coeff m).2
+
+end Assembly
+
+end R8b
+end WLight
+
+open WLight.R8b
+
+open UpperHalfPlane in
+open scoped Manifold in
+theorem solutionInterim
+    (N : ℕ) [NeZero N]
+    (L : ℍ → PeriodPair) (hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), W v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (jf : ℍ → ℂ)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    {G a b : ℍ → ℂ} (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (ha : a ∈ Algebra.adjoin ℂ
+      (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}))
+    (hb : b ∈ Algebra.adjoin ℂ
+      (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}))
+    (hb0 : b ≠ 0) (hGb : G * b = a)
+    {d : ℕ} (p : Fin d → Polynomial ℂ)
+    (hprel : ∀ τ : ℍ, G τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * G τ ^ (i : ℕ) = 0)
+    (K : IntermediateField ℚ ℂ)
+    (hK : K = IntermediateField.adjoin ℚ {Complex.exp (2 * (Real.pi : ℂ) * Complex.I / (N : ℂ))})
+    (hR4a : ∀ v : Fin 2 → ZMod N, v ≠ 0 → MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fricke v))
+    (hR4kp : ∀ v : Fin 2 → ZMod N, v ≠ 0 →
+      Function.Periodic ((fricke v * ModularForm.discriminant ^ 1) ∘ UpperHalfPlane.ofComplex) N ∧
+      IsBoundedAtImInfty (fricke v * ModularForm.discriminant ^ 1) ∧
+      ∀ n : ℕ, (UpperHalfPlane.qExpansion N (fricke v * ModularForm.discriminant ^ 1)).coeff n ∈ K)
+    (hR4int : ∀ v : Fin 2 → ZMod N, v ≠ 0 → ∃ (d : ℕ) (p : Fin d → Polynomial ℂ),
+      (∀ (i : Fin d) (n : ℕ), (p i).coeff n ∈ K) ∧
+      ∀ τ : ℍ, fricke v τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * fricke v τ ^ (i : ℕ) = 0)
+    (hR6 : WLight.R8b.R6h2Shape) (hR7b : WLight.R8b.R7bShape) (hR8a : WLight.R8b.R8aShape) :
+    letI kN : IntermediateField ℚ ℂ :=
+      IntermediateField.adjoin ℚ {Complex.exp (2 * (Real.pi : ℂ) * Complex.I / (N : ℂ))}
+    ∃ (n : ℕ) (lam : Fin n → ℂ) (Gi : Fin n → (ℍ → ℂ))
+      (Pi Qi : Fin n → (ℍ → ℂ))
+      (di : Fin n → ℕ) (pi : ∀ i, Fin (di i) → Polynomial ℂ),
+      (G = ∑ i, lam i • Gi i) ∧
+      (∀ i, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (Gi i)) ∧
+      (∀ i, Pi i ∈ Algebra.adjoin ↥kN
+          (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}) ∧
+        Qi i ∈ Algebra.adjoin ↥kN
+          (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}) ∧
+        Qi i ≠ 0 ∧ Gi i * Qi i = Pi i) ∧
+      (∀ i k m, (pi i k).coeff m ∈ kN) ∧
+      (∀ i τ, Gi i τ ^ di i +
+        ∑ k : Fin (di i), (pi i k).eval (jf τ) * Gi i τ ^ (k : ℕ) = 0) := by
+  have _hL := hL
+  have _hW := hW
+  have _hfricke := hfricke
+  subst hK
+  have hg : WLight.R8b.GenMD jf fricke := ⟨WLight.R8b.mdiff_jf hjf, hR4a⟩
+  have hkp : ∀ v : Fin 2 → ZMod N, v ≠ 0 → WLight.R8b.KPoleAt
+      (IntermediateField.adjoin ℚ {Complex.exp (2 * (Real.pi : ℂ) * Complex.I / (N : ℂ))})
+      N 1 (fricke v) := fun v hv => by
+    obtain ⟨h1, h2, h3⟩ := hR4kp v hv
+    exact ⟨by simpa only [CuspForm.coe_discriminant] using h1,
+      by simpa only [CuspForm.coe_discriminant] using h2,
+      by simpa only [CuspForm.coe_discriminant] using h3⟩
+  exact WLight.R8b.main (hg := hg) hjf hkp hR4int hR6 hR7b hR8a hG ha hb hb0 hGb p hprel
+
+open UpperHalfPlane hiding I in
+open scoped UpperHalfPlane Manifold MatrixGroups ModularForm in
+open WLight in
+theorem solution
+    (N : ℕ) [NeZero N]
+    (L : ℍ → PeriodPair) (hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), W v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (jf : ℍ → ℂ)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    {G a b : ℍ → ℂ} (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (ha : a ∈ Algebra.adjoin ℂ
+      (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}))
+    (hb : b ∈ Algebra.adjoin ℂ
+      (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}))
+    (hb0 : b ≠ 0) (hGb : G * b = a)
+    {d : ℕ} (p : Fin d → Polynomial ℂ)
+    (hprel : ∀ τ : ℍ, G τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * G τ ^ (i : ℕ) = 0) :
+    letI kN : IntermediateField ℚ ℂ :=
+      IntermediateField.adjoin ℚ {Complex.exp (2 * (Real.pi : ℂ) * Complex.I / (N : ℂ))}
+    ∃ (n : ℕ) (lam : Fin n → ℂ) (Gi : Fin n → (ℍ → ℂ))
+      (Pi Qi : Fin n → (ℍ → ℂ))
+      (di : Fin n → ℕ) (pi : ∀ i, Fin (di i) → Polynomial ℂ),
+      (G = ∑ i, lam i • Gi i) ∧
+      (∀ i, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (Gi i)) ∧
+      (∀ i, Pi i ∈ Algebra.adjoin ↥kN
+          (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}) ∧
+        Qi i ∈ Algebra.adjoin ↥kN
+          (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}) ∧
+        Qi i ≠ 0 ∧ Gi i * Qi i = Pi i) ∧
+      (∀ i k m, (pi i k).coeff m ∈ kN) ∧
+      (∀ i τ, Gi i τ ^ di i +
+        ∑ k : Fin (di i), (pi i k).eval (jf τ) * Gi i τ ^ (k : ℕ) = 0):= by
+  refine solutionInterim N L hL W hW fricke hfricke jf hjf hG ha hb hb0 hGb p hprel
+      (IntermediateField.adjoin ℚ {Complex.exp (2 * (Real.pi : ℂ) * Complex.I / (N : ℂ))}) rfl
+      ?_ ?_ ?_ ?_ ?_ ?_
+  · intro v hv
+    rw [show fricke v = fun τ : ℍ =>
+        -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 *
+          (((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ * PeriodPair.weierstrassP (L τ)
+            ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ))) from
+      funext fun τ => by rw [hfricke, hW]]
+    exact (frickeFunction_modularity_package N L hL).2.2.1 v hv
+  · intro v hv
+    have pkg := frickeFunction_modularity_package N L hL
+    have hfeq : fricke v = fun τ : ℍ =>
+        -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 *
+          (((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ * PeriodPair.weierstrassP (L τ)
+            ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ))) :=
+      funext fun τ => by rw [hfricke, hW]
+    obtain ⟨hper, hco⟩ := pkg.2.2.2.2.1 v hv
+    have hbd := pkg.2.2.2.1 v hv
+    refine ⟨?_, ?_, ?_⟩
+    · rw [pow_one, hfeq]; exact hper
+    · rw [pow_one, hfeq]; exact hbd
+    · intro n; rw [pow_one, hfeq]; exact hco n
+  · intro v hv
+    obtain ⟨P, hPco, hPrel⟩ :=
+      (frickeFunction_orbit_package N L hL W hW fricke hfricke jf hjf).2.2
+    refine ⟨N ^ 2 - 1, fun i => P (i : ℕ), fun i n => hPco (i : ℕ) n, fun τ => ?_⟩
+    have h := hPrel v hv τ
+    have hsum := Fin.sum_univ_eq_sum_range
+      (fun k => Polynomial.eval (jf τ) (P k) * fricke v τ ^ k) (N ^ 2 - 1)
+    rw [hsum]
+    exact h
+  · exact fun {a b c d} ha hb hb0 hc hrel =>
+      exists_mdifferentiable_div_of_monicRel ha hb hb0 hc hrel
+  · exact IsIntegral.mem_span_of_adjoin_simple_constants
+  · exact IsIntegral.mem_span_of_adjoin_simple_constants_transcendental
+
+end
+
+end privateSection
+
+public section publicSection
+
+
+open Complex Real UpperHalfPlane
+open scoped Manifold MatrixGroups ModularForm
+theorem WLight.frickeFunction_intBaseChange
+    (N : ℕ) [NeZero N]
+    (L : ℍ → PeriodPair) (hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), W v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (jf : ℍ → ℂ)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ)
+    {G a b : ℍ → ℂ} (hG : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) G)
+    (ha : a ∈ Algebra.adjoin ℂ
+      (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}))
+    (hb : b ∈ Algebra.adjoin ℂ
+      (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}))
+    (hb0 : b ≠ 0) (hGb : G * b = a)
+    {d : ℕ} (p : Fin d → Polynomial ℂ)
+    (hprel : ∀ τ : ℍ, G τ ^ d + ∑ i : Fin d, (p i).eval (jf τ) * G τ ^ (i : ℕ) = 0) :
+    letI kN : IntermediateField ℚ ℂ :=
+      IntermediateField.adjoin ℚ {Complex.exp (2 * (Real.pi : ℂ) * Complex.I / (N : ℂ))}
+    ∃ (n : ℕ) (lam : Fin n → ℂ) (Gi : Fin n → (ℍ → ℂ))
+      (Pi Qi : Fin n → (ℍ → ℂ))
+      (di : Fin n → ℕ) (pi : ∀ i, Fin (di i) → Polynomial ℂ),
+      (G = ∑ i, lam i • Gi i) ∧
+      (∀ i, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (Gi i)) ∧
+      (∀ i, Pi i ∈ Algebra.adjoin ↥kN
+          (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}) ∧
+        Qi i ∈ Algebra.adjoin ↥kN
+          (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v}) ∧
+        Qi i ≠ 0 ∧ Gi i * Qi i = Pi i) ∧
+      (∀ i k m, (pi i k).coeff m ∈ kN) ∧
+      (∀ i τ, Gi i τ ^ di i +
+        ∑ k : Fin (di i), (pi i k).eval (jf τ) * Gi i τ ^ (k : ℕ) = 0) :=
+  solution N L hL W hW fricke hfricke jf hjf hG ha hb hb0 hGb p hprel
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_frickeFunction_modularity_package.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_frickeFunction_modularity_package.lean
new file mode 100644
index 0000000000..16aed97b14
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_frickeFunction_modularity_package.lean
@@ -0,0 +1,964 @@
+/-
+Based on Prove2Me node WLight.frickeFunction_modularity_package
+(409f428b-f096-5e14-b476-e6f5efd41901) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission afdcfca9-10d0-572b-870d-1902e69fc5ee
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.SpecialFunctions.Elliptic.Weierstrass
+public import Mathlib.NumberTheory.ModularForms.EisensteinSeries.Basic
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Manifold
+public import Mathlib.Geometry.Manifold.Notation
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_weierstrassP_torsion_qExpansion_package
+
+/-!
+# Fricke functions of level N: transformation and rationality package
+
+Theorem statement: `WLight.frickeFunction_modularity_package`
+(`409f428b-f096-5e14-b476-e6f5efd41901`), by Claude, 2026-09-05.
+
+Proof: submission `afdcfca9-10d0-572b-870d-1902e69fc5ee`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a natural number, nonzero as an instance, and let $L:\mathbb{H}\to$ `PeriodPair` assign
+to each $\tau$ a period pair with, by hypothesis, $\omega_1=\tau$ and $\omega_2=1$. For
+$a=(a_0,a_1)\in(\mathbb{Z}/N)^2$ put
+$f_a(\tau)=-\bigl(E_4(\tau)E_6(\tau)/\Delta(\tau)\bigr)/2592\cdot(2\pi
+i)^{-2}\,\wp_{L(\tau)}\bigl((\tilde a_0\tau+\tilde a_1)/N\bigr)$, where $\tilde a_i$ denotes the
+canonical representative in $[0,N)$. Eight assertions are conjoined. (1) For all $a$, all
+$\gamma\in\mathrm{SL}_2(\mathbb{Z})$ and all $\tau$, $f_a(\gamma\cdot\tau)=f_{a\bar\gamma}(\tau)$,
+with $a\bar\gamma$ the row vector $a$ multiplied on the right by the entrywise reduction of $\gamma$
+modulo $N$. (2) $f_{-a}=f_a$ for all $a$. (3) For $a\neq0$, $f_a$ is holomorphic on $\mathbb{H}$.
+(4) For $a\neq0$, $f_a\cdot\Delta$ is bounded at $i\infty$. (5) For $a\neq0$, $f_a\cdot\Delta$
+transported along `ofComplex` is periodic with period $N$, and every coefficient of its width-$N$
+$q$-expansion lies in the subfield $\mathbb{Q}(e^{2\pi i/N})$ of $\mathbb{C}$. (6) For $a,b\neq0$,
+$f_a=f_b$ forces $b=a$ or $b=-a$. (7) For all $a$, $f_a(\gamma\cdot\tau)=f_a(\tau)$ for $\gamma$ in
+the principal congruence subgroup of level $N$. (8) If $s$ is coprime to $N$ and
+$\varphi:\mathbb{Q}(e^{2\pi i/N})\to\mathbb{C}$ is a ring homomorphism sending any element with
+complex value $e^{2\pi i/N}$ to $e^{2\pi i s/N}$, then for $a\neq0$ and each $n$, applying $\varphi$
+to an element of the field whose complex value is the $n$-th $q$-expansion coefficient of
+$f_a\cdot\Delta$ yields the $n$-th coefficient of the $q$-expansion of
+$f_{(a_0,\,s\,a_1)}\cdot\Delta$.
+
+This is the transformation and rationality theory of the Fricke functions of level $N$, the
+normalised values of $\wp$ at $N$-division points: their $\mathrm{SL}_2(\mathbb{Z})$-equivariance,
+evenness, injectivity up to sign, $\Gamma(N)$-invariance, cyclotomic width-$N$ expansions and the
+Galois conjugation of those expansions. It is the source of rational generators of the level-$N$
+modular function field used in the construction of $\Gamma_1$-level cusp forms with prescribed
+coefficient fields and Galois behaviour.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WLight_frickeFunction_modularity_package.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+noncomputable section
+
+open Complex Real ModularForm ModularFormClass PeriodPair Matrix.SpecialLinearGroup
+open scoped Manifold MatrixGroups
+open UpperHalfPlane hiding I
+
+namespace WLight
+
+section B1_homogeneity
+
+def smulPeriodPair (a : ℂ) (ha : a ≠ 0) (L : PeriodPair) : PeriodPair where
+  ω₁ := a * L.ω₁
+  ω₂ := a * L.ω₂
+  indep := LinearIndependent.pair_iff.mpr fun s t hst => by
+    refine LinearIndependent.pair_iff.mp L.indep s t ?_
+    have h0 : a * (s • L.ω₁ + t • L.ω₂) = 0 := by
+      rw [mul_add, mul_smul_comm, mul_smul_comm]; exact hst
+    exact (mul_eq_zero.mp h0).resolve_left ha
+
+@[scoped simp] lemma smulPeriodPair_ω₁ (a : ℂ) (ha : a ≠ 0) (L : PeriodPair) :
+    (smulPeriodPair a ha L).ω₁ = a * L.ω₁ := rfl
+
+@[scoped simp] lemma smulPeriodPair_ω₂ (a : ℂ) (ha : a ≠ 0) (L : PeriodPair) :
+    (smulPeriodPair a ha L).ω₂ = a * L.ω₂ := rfl
+
+lemma mem_smulPeriodPair_lattice {a : ℂ} (ha : a ≠ 0) (L : PeriodPair) {x : ℂ} :
+    x ∈ (smulPeriodPair a ha L).lattice ↔ ∃ y ∈ L.lattice, x = a * y := by
+  simp only [mem_lattice, smulPeriodPair_ω₁, smulPeriodPair_ω₂]
+  constructor
+  · rintro ⟨m, n, h⟩
+    exact ⟨(m : ℂ) * L.ω₁ + (n : ℂ) * L.ω₂, ⟨m, n, rfl⟩, by rw [← h]; ring⟩
+  · rintro ⟨y, ⟨m, n, h⟩, rfl⟩
+    exact ⟨m, n, by rw [← h]; ring⟩
+
+def smulLatticeEquiv (a : ℂ) (ha : a ≠ 0) (L : PeriodPair) :
+    L.lattice ≃ (smulPeriodPair a ha L).lattice where
+  toFun l := ⟨a * l, (mem_smulPeriodPair_lattice ha L).mpr ⟨l, l.2, rfl⟩⟩
+  invFun l := ⟨a⁻¹ * l, by
+    obtain ⟨y, hy, hxy⟩ := (mem_smulPeriodPair_lattice ha L).mp l.2
+    rw [hxy, inv_mul_cancel_left₀ ha]; exact hy⟩
+  left_inv l := Subtype.ext (inv_mul_cancel_left₀ ha _)
+  right_inv l := Subtype.ext (mul_inv_cancel_left₀ ha _)
+
+@[scoped simp] lemma smulLatticeEquiv_coe (a : ℂ) (ha : a ≠ 0) (L : PeriodPair) (l : L.lattice) :
+    ((smulLatticeEquiv a ha L) l : ℂ) = a * l := rfl
+
+theorem weierstrassP_smulPeriodPair (a : ℂ) (ha : a ≠ 0) (L : PeriodPair) (z : ℂ) :
+    weierstrassP (smulPeriodPair a ha L) (a * z) = a⁻¹ ^ 2 * weierstrassP L z := by
+  have key : ∀ u : ℂ, 1 / (a * u) ^ 2 = a⁻¹ ^ 2 * (1 / u ^ 2) := fun u => by
+    simp [one_div, mul_pow, inv_pow, mul_comm]
+  simp only [weierstrassP]
+  rw [← (smulLatticeEquiv a ha L).tsum_eq, ← tsum_mul_left]
+  congr with l
+  simp only [smulLatticeEquiv_coe]
+  rw [show a * z - a * (l : ℂ) = a * (z - l) by ring, key, key, mul_sub]
+
+end B1_homogeneity
+
+section R4aFloor
+
+def periodPairOfTau (τ : ℍ) : PeriodPair where
+  ω₁ := (τ : ℂ)
+  ω₂ := 1
+  indep := LinearIndependent.pair_iff.mpr fun s t hst ↦ by
+    have him : s * (τ : ℂ).im = 0 := by
+      have := congrArg Complex.im hst
+      simpa [Complex.add_im, Complex.smul_im, smul_eq_mul] using this
+    have hs : s = 0 :=
+      (mul_eq_zero.mp him).resolve_right (UpperHalfPlane.coe_im τ ▸ τ.im_ne_zero)
+    subst hs
+    simpa using hst
+
+@[scoped simp] lemma periodPairOfTau_ω₁ (τ : ℍ) : (periodPairOfTau τ).ω₁ = (τ : ℂ) := rfl
+@[scoped simp] lemma periodPairOfTau_ω₂ (τ : ℍ) : (periodPairOfTau τ).ω₂ = 1 := rfl
+
+def zetaN (N : ℕ) : ℂ := cexp (2 * π * I / N)
+
+def wpTorsion (N a₁ a₂ : ℕ) (τ : ℍ) : ℂ :=
+  PeriodPair.weierstrassP (periodPairOfTau τ) (((a₁ : ℂ) * τ + a₂) / N)
+
+def kN (N : ℕ) : IntermediateField ℚ ℂ := IntermediateField.adjoin ℚ {zetaN N}
+
+lemma zetaN_mem_kN (N : ℕ) : zetaN N ∈ kN N :=
+  IntermediateField.mem_adjoin_simple_self ℚ _
+
+def wpNorm (N a₁ a₂ : ℕ) (τ : ℍ) : ℂ := ((2 * π * I) ^ 2)⁻¹ * wpTorsion N a₁ a₂ τ
+
+def frickeH (N a₁ a₂ : ℕ) : ℍ → ℂ := (⇑E₄ * ⇑E₆ : ℍ → ℂ) * wpNorm N a₁ a₂
+
+theorem r2_package {N : ℕ} (hN : N ≠ 0) :
+    (∀ a₁ a₂ : ℕ, a₁ < N → a₂ < N → (a₁ ≠ 0 ∨ a₂ ≠ 0) →
+        MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (wpNorm N a₁ a₂)
+        ∧ Function.Periodic ((wpNorm N a₁ a₂) ∘ ofComplex) (N : ℂ)
+        ∧ IsBoundedAtImInfty (wpNorm N a₁ a₂)
+        ∧ ∀ n, (qExpansion N (wpNorm N a₁ a₂)).coeff n ∈ kN N)
+    ∧ (∀ a₁ a₂ b₁ b₂ : ℕ, a₁ < N → a₂ < N → (a₁ ≠ 0 ∨ a₂ ≠ 0) →
+        b₁ < N → b₂ < N → (b₁ ≠ 0 ∨ b₂ ≠ 0) →
+        wpNorm N a₁ a₂ = wpNorm N b₁ b₂ →
+        (b₁ = a₁ ∧ b₂ = a₂) ∨ (b₁ = (N - a₁) % N ∧ b₂ = (N - a₂) % N))
+    ∧ (∃ S : ℕ → ℕ → PowerSeries ↑(kN N),
+        (∀ a₁ a₂ : ℕ, a₁ < N → a₂ < N → (a₁ ≠ 0 ∨ a₂ ≠ 0) →
+          (S a₁ a₂).map (algebraMap ↑(kN N) ℂ) = qExpansion N (wpNorm N a₁ a₂))
+        ∧ ∀ s : ℕ, s.Coprime N → ∀ φ : ↑(kN N) →+* ℂ,
+            φ ⟨zetaN N, zetaN_mem_kN N⟩ = zetaN N ^ s →
+            ∀ a₁ a₂ : ℕ, a₁ < N → a₂ < N → (a₁ ≠ 0 ∨ a₂ ≠ 0) →
+              (S a₁ a₂).map φ = qExpansion N (wpNorm N a₁ (s * a₂ % N)))
+    ∧ (∀ f : ℍ → ℂ, Function.Periodic (f ∘ ofComplex) (1 : ℂ) →
+        MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f → IsBoundedAtImInfty f →
+        ∀ n, (qExpansion N f).coeff n =
+          if N ∣ n then (qExpansion 1 f).coeff (n / N) else 0)
+    ∧ (∀ n, ∃ q : ℚ, (qExpansion 1 (⇑ModularForm.E₄ : ℍ → ℂ)).coeff n = (q : ℂ))
+    ∧ (∀ n, ∃ q : ℚ, (qExpansion 1 (⇑ModularForm.E₆ : ℍ → ℂ)).coeff n = (q : ℂ))
+    ∧ (∀ n, ∃ q : ℚ,
+        (qExpansion 1 (ModularForm.discriminant : ℍ → ℂ)).coeff n = (q : ℂ)) :=
+  ModularForm.weierstrassP_torsion_qExpansion_package N hN periodPairOfTau fun _ ↦ ⟨rfl, rfl⟩
+
+theorem periodic_wpNorm {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N) (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) :
+    Function.Periodic (wpNorm N a₁ a₂ ∘ ofComplex) N :=
+  ((r2_package (by omega)).1 a₁ a₂ ha₁ ha₂ h0).2.1
+
+theorem mdifferentiable_wpNorm {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (wpNorm N a₁ a₂) :=
+  ((r2_package (by omega)).1 a₁ a₂ ha₁ ha₂ h0).1
+
+theorem isBoundedAtImInfty_wpNorm {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) : IsBoundedAtImInfty (wpNorm N a₁ a₂) :=
+  ((r2_package (by omega)).1 a₁ a₂ ha₁ ha₂ h0).2.2.1
+
+theorem qExpansion_wpNorm_coeff_mem_kN {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) (n : ℕ) : (qExpansion N (wpNorm N a₁ a₂)).coeff n ∈ kN N :=
+  ((r2_package (by omega)).1 a₁ a₂ ha₁ ha₂ h0).2.2.2 n
+
+theorem wpNorm_eq_imp {N a₁ a₂ b₁ b₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (ha0 : a₁ ≠ 0 ∨ a₂ ≠ 0) (hb₁ : b₁ < N) (hb₂ : b₂ < N) (hb0 : b₁ ≠ 0 ∨ b₂ ≠ 0)
+    (h : wpNorm N a₁ a₂ = wpNorm N b₁ b₂) :
+    (b₁ = a₁ ∧ b₂ = a₂) ∨ (b₁ = (N - a₁) % N ∧ b₂ = (N - a₂) % N) :=
+  (r2_package (by omega)).2.1 a₁ a₂ b₁ b₂ ha₁ ha₂ ha0 hb₁ hb₂ hb0 h
+
+theorem isBoundedAtImInfty_frickeH {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) : IsBoundedAtImInfty (frickeH N a₁ a₂) :=
+  ((ModularFormClass.bdd_at_infty ModularForm.E₄).mul (ModularFormClass.bdd_at_infty
+    ModularForm.E₆)).mul
+    (isBoundedAtImInfty_wpNorm ha₁ ha₂ h0)
+
+theorem qExpansion_coeff_width (f : ℍ → ℂ) {N : ℕ} (hN : N ≠ 0)
+    (hper : Function.Periodic (f ∘ ofComplex) 1) (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f)
+    (hbd : IsBoundedAtImInfty f) (n : ℕ) :
+    (qExpansion N f).coeff n =
+      if N ∣ n then (qExpansion 1 f).coeff (n / N) else 0 :=
+  (r2_package hN).2.2.2.1 f hper hhol hbd n
+
+theorem periodic_frickeH {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N) (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) :
+    Function.Periodic (frickeH N a₁ a₂ ∘ ofComplex) N := by
+  have h4 := (SlashInvariantFormClass.periodic_comp_ofComplex ModularForm.E₄
+    one_mem_strictPeriods_SL).nat_mul N
+  have h6 := (SlashInvariantFormClass.periodic_comp_ofComplex ModularForm.E₆
+    one_mem_strictPeriods_SL).nat_mul N
+  have hw := periodic_wpNorm ha₁ ha₂ h0
+  intro τ
+  have e4 := h4 τ; have e6 := h6 τ; have ew := hw τ
+  simp only [Complex.ofReal_one, mul_one, Function.comp_apply] at e4 e6 ew
+  simp only [Function.comp_apply, frickeH, Pi.mul_apply, e4, e6, ew]
+
+theorem mdifferentiable_frickeH {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (frickeH N a₁ a₂) :=
+  (ModularForm.E₄.holo'.mul ModularForm.E₆.holo').mul (mdifferentiable_wpNorm ha₁ ha₂ h0)
+
+theorem wpNorm_qExpansion_model {N : ℕ} (hN : N ≠ 0) :
+    ∃ S : ℕ → ℕ → PowerSeries ↑(kN N),
+      (∀ a₁ a₂ : ℕ, a₁ < N → a₂ < N → (a₁ ≠ 0 ∨ a₂ ≠ 0) →
+        (S a₁ a₂).map (algebraMap ↑(kN N) ℂ) = qExpansion N (wpNorm N a₁ a₂)) ∧
+      ∀ s : ℕ, s.Coprime N → ∀ φ : ↑(kN N) →+* ℂ,
+        φ ⟨zetaN N, zetaN_mem_kN N⟩ = zetaN N ^ s →
+        ∀ a₁ a₂ : ℕ, a₁ < N → a₂ < N → (a₁ ≠ 0 ∨ a₂ ≠ 0) →
+          (S a₁ a₂).map φ = qExpansion N (wpNorm N a₁ (s * a₂ % N)) :=
+  (r2_package hN).2.2.1
+
+theorem qExpansion_one_E4_rat (n : ℕ) :
+    ∃ q : ℚ, (qExpansion 1 (⇑ModularForm.E₄ : ℍ → ℂ)).coeff n = (q : ℂ) :=
+  (r2_package one_ne_zero).2.2.2.2.1 n
+
+theorem qExpansion_one_E6_rat (n : ℕ) :
+    ∃ q : ℚ, (qExpansion 1 (⇑ModularForm.E₆ : ℍ → ℂ)).coeff n = (q : ℂ) :=
+  (r2_package one_ne_zero).2.2.2.2.2.1 n
+
+lemma analyticAt_cuspFunction_zero_of {N : ℕ} [NeZero N] {g : ℍ → ℂ}
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g) (hper : Function.Periodic (g ∘ ofComplex) N)
+    (hbd : IsBoundedAtImInfty g) :
+    AnalyticAt ℂ (cuspFunction N g) 0 :=
+  analyticAt_cuspFunction_zero (by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)) hper hhol hbd
+
+end R4aFloor
+
+section B3_fricke
+
+def latticeEquivOfEq {L L' : PeriodPair} (h : L.lattice = L'.lattice) :
+    L.lattice ≃ L'.lattice where
+  toFun l := ⟨l.1, h.le l.2⟩
+  invFun l := ⟨l.1, h.ge l.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+
+theorem weierstrassP_of_lattice_eq {L L' : PeriodPair} (h : L.lattice = L'.lattice) (z : ℂ) :
+    weierstrassP L z = weierstrassP L' z := by
+  simp only [weierstrassP]
+  rw [← (latticeEquivOfEq h).tsum_eq]
+  rfl
+
+end B3_fricke
+
+section B3_fricke_tier2
+
+theorem span_SL2_basis_change {a b c d : ℤ} (hdet : a * d - b * c = 1) (ω₁ ω₂ : ℂ) :
+    (Submodule.span ℤ {(a : ℂ) * ω₁ + (b : ℂ) * ω₂, (c : ℂ) * ω₁ + (d : ℂ) * ω₂} : Submodule ℤ ℂ)
+      = Submodule.span ℤ {ω₁, ω₂} := by
+  have hdetC : (a : ℂ) * d - b * c = 1 := by exact_mod_cast hdet
+  refine le_antisymm (Submodule.span_le.mpr ?_) (Submodule.span_le.mpr ?_)
+  · rw [Set.insert_subset_iff, Set.singleton_subset_iff]
+    exact ⟨Submodule.mem_span_pair.mpr ⟨a, b, by simp [zsmul_eq_mul]⟩,
+           Submodule.mem_span_pair.mpr ⟨c, d, by simp [zsmul_eq_mul]⟩⟩
+  · rw [Set.insert_subset_iff, Set.singleton_subset_iff]
+    refine ⟨Submodule.mem_span_pair.mpr ⟨d, -b, ?_⟩,
+            Submodule.mem_span_pair.mpr ⟨-c, a, ?_⟩⟩
+    · simp only [zsmul_eq_mul, Int.cast_neg]; linear_combination ω₁ * hdetC
+    · simp only [zsmul_eq_mul, Int.cast_neg]; linear_combination ω₂ * hdetC
+
+def denomZ (γ : SL(2, ℤ)) (τ : ℂ) : ℂ := (γ 1 0 : ℤ) * τ + (γ 1 1 : ℤ)
+
+def numZ (γ : SL(2, ℤ)) (τ : ℂ) : ℂ := (γ 0 0 : ℤ) * τ + (γ 0 1 : ℤ)
+
+lemma denomZ_ne_zero (γ : SL(2, ℤ)) (τ : ℍ) : denomZ γ (τ : ℂ) ≠ 0 := by
+  intro h
+  have him : ((γ 1 0 : ℤ) : ℝ) * (τ : ℂ).im = 0 := by
+    have := congrArg Complex.im h
+    simp only [denomZ, Complex.add_im, Complex.mul_im, Complex.intCast_im, zero_mul,
+      Complex.intCast_re, add_zero, Complex.zero_im] at this
+    linarith
+  have hc0 : (γ 1 0 : ℤ) = 0 := by
+    rcases mul_eq_zero.mp him with h | h
+    · exact_mod_cast h
+    · exact absurd h (UpperHalfPlane.coe_im τ ▸ τ.im_ne_zero)
+  have hd0 : (γ 1 1 : ℤ) = 0 := by
+    have := h
+    rw [denomZ, hc0] at this
+    simpa using this
+  have hdet : γ 0 0 * γ 1 1 - γ 0 1 * γ 1 0 = 1 := by
+    have := γ.2; rwa [Matrix.det_fin_two] at this
+  rw [hc0, hd0] at hdet
+  simp at hdet
+
+lemma coe_SL2Z_smul (γ : SL(2, ℤ)) (τ : ℍ) :
+    ((γ • τ : ℍ) : ℂ) = numZ γ (τ : ℂ) / denomZ γ (τ : ℂ) := by
+  rw [UpperHalfPlane.coe_specialLinearGroup_apply, numZ, denomZ]
+  have hcast : ∀ i j : Fin 2, ((algebraMap ℤ ℝ (γ i j) : ℝ) : ℂ) = ((γ i j : ℤ) : ℂ) := by
+    intro i j; simp [eq_intCast]
+  rw [hcast, hcast, hcast, hcast]
+
+theorem mem_lattice_smul_SL2 (γ : SL(2, ℤ)) (τ : ℍ) (x : ℂ) :
+    x ∈ (periodPairOfTau (γ • τ)).lattice
+      ↔ denomZ γ τ * x ∈ (periodPairOfTau τ).lattice := by
+  have hd : denomZ γ (τ : ℂ) ≠ 0 := denomZ_ne_zero γ τ
+  have hdet : γ 0 0 * γ 1 1 - γ 0 1 * γ 1 0 = 1 := by
+    have := γ.2; rwa [Matrix.det_fin_two] at this
+  have hspan := span_SL2_basis_change hdet (τ : ℂ) (1 : ℂ)
+  simp only [mul_one] at hspan
+  have hlatτ : (periodPairOfTau τ).lattice = Submodule.span ℤ {(τ : ℂ), 1} := rfl
+  constructor
+  · intro hx
+    obtain ⟨m, n, hmn⟩ := PeriodPair.mem_lattice.mp hx
+    simp only [periodPairOfTau_ω₁, periodPairOfTau_ω₂, mul_one, coe_SL2Z_smul] at hmn
+    rw [hlatτ, ← hspan]
+    refine Submodule.mem_span_pair.mpr ⟨m, n, ?_⟩
+    have hdx : denomZ γ τ * x = (m : ℂ) * numZ γ τ + (n : ℂ) * denomZ γ τ := by
+      rw [← hmn]; field_simp
+    simp only [zsmul_eq_mul]
+    rw [hdx, numZ, denomZ]
+  · intro hx
+    rw [hlatτ, ← hspan] at hx
+    obtain ⟨p, q, hpq⟩ := Submodule.mem_span_pair.mp hx
+    simp only [zsmul_eq_mul] at hpq
+    refine PeriodPair.mem_lattice.mpr ⟨p, q, ?_⟩
+    simp only [periodPairOfTau_ω₁, periodPairOfTau_ω₂, mul_one, coe_SL2Z_smul]
+    have key : (p : ℂ) * numZ γ τ + (q : ℂ) * denomZ γ τ = denomZ γ τ * x := by
+      rw [← hpq, numZ, denomZ]
+    field_simp
+    linear_combination key
+
+theorem periodPairOfTau_smul_lattice_eq (γ : SL(2, ℤ)) (τ : ℍ) :
+    (periodPairOfTau (γ • τ)).lattice
+      = (smulPeriodPair (denomZ γ τ)⁻¹ (inv_ne_zero (denomZ_ne_zero γ τ))
+          (periodPairOfTau τ)).lattice := by
+  have hd : denomZ γ (τ : ℂ) ≠ 0 := denomZ_ne_zero γ τ
+  ext x
+  rw [mem_lattice_smul_SL2, mem_smulPeriodPair_lattice]
+  constructor
+  · intro hx
+    exact ⟨denomZ γ τ * x, hx, by field_simp⟩
+  · rintro ⟨y, hy, rfl⟩
+    rwa [mul_inv_cancel_left₀ hd]
+
+def frickeTorsionPt (N : ℕ) (a : Fin 2 → ZMod N) (τ : ℍ) : ℂ :=
+  (((a 0).val : ℂ) * (τ : ℂ) + ((a 1).val : ℂ)) / (N : ℂ)
+
+lemma weierstrassP_torsionPt_lift_irrel {N : ℕ} [NeZero N] (a : Fin 2 → ZMod N) (τ : ℍ)
+    (b₁ b₂ : ℤ) (h₁ : (b₁ : ZMod N) = a 0) (h₂ : (b₂ : ZMod N) = a 1) :
+    weierstrassP (periodPairOfTau τ) (((b₁ : ℂ) * τ + (b₂ : ℂ)) / (N : ℂ))
+      = weierstrassP (periodPairOfTau τ) (frickeTorsionPt N a τ) := by
+  have hN : (N : ℂ) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne N)
+  have cast_val : ∀ i : Fin 2, ((a i).val : ZMod N) = a i := fun i ↦ by
+    rw [ZMod.natCast_val, ZMod.cast_id]
+  have hdvd₁ : (N : ℤ) ∣ b₁ - ((a 0).val : ℤ) :=
+    (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp (by push_cast; rw [h₁, cast_val, sub_self])
+  have hdvd₂ : (N : ℤ) ∣ b₂ - ((a 1).val : ℤ) :=
+    (ZMod.intCast_zmod_eq_zero_iff_dvd _ _).mp (by push_cast; rw [h₂, cast_val, sub_self])
+  obtain ⟨k₁, hk₁⟩ := hdvd₁
+  obtain ⟨k₂, hk₂⟩ := hdvd₂
+  have hmem : ((k₁ : ℂ) * (τ : ℂ) + (k₂ : ℂ)) ∈ (periodPairOfTau τ).lattice :=
+    PeriodPair.mem_lattice.mpr ⟨k₁, k₂, by
+      simp only [periodPairOfTau_ω₁, periodPairOfTau_ω₂, mul_one]⟩
+  have e₁ : (b₁ : ℂ) = ((a 0).val : ℂ) + (N : ℂ) * (k₁ : ℂ) := by
+    have hc : (b₁ : ℂ) - ((a 0).val : ℂ) = (N : ℂ) * (k₁ : ℂ) := by exact_mod_cast hk₁
+    linear_combination hc
+  have e₂ : (b₂ : ℂ) = ((a 1).val : ℂ) + (N : ℂ) * (k₂ : ℂ) := by
+    have hc : (b₂ : ℂ) - ((a 1).val : ℂ) = (N : ℂ) * (k₂ : ℂ) := by exact_mod_cast hk₂
+    linear_combination hc
+  have step : ((b₁ : ℂ) * τ + (b₂ : ℂ)) / (N : ℂ)
+      = frickeTorsionPt N a τ + ((k₁ : ℂ) * τ + (k₂ : ℂ)) := by
+    unfold frickeTorsionPt; rw [e₁, e₂]; field_simp; ring
+  rw [step, (periodPairOfTau τ).weierstrassP_add_coe _ ⟨_, hmem⟩]
+
+def vecMulSL (N : ℕ) (a : Fin 2 → ZMod N) (γ : SL(2, ℤ)) : Fin 2 → ZMod N :=
+  Matrix.vecMul a ((γ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N))
+
+lemma vecMulSL_apply (N : ℕ) (a : Fin 2 → ZMod N) (γ : SL(2, ℤ)) (j : Fin 2) :
+    vecMulSL N a γ j = a 0 * (γ 0 j : ℤ) + a 1 * (γ 1 j : ℤ) := by
+  simp [vecMulSL, Matrix.vecMul, dotProduct, Fin.sum_univ_two, Matrix.map_apply]
+
+theorem weierstrassP_frickeTorsionPt_slash {N : ℕ} [NeZero N] (a : Fin 2 → ZMod N)
+    (γ : SL(2, ℤ)) (τ : ℍ) :
+    weierstrassP (periodPairOfTau (γ • τ)) (frickeTorsionPt N a (γ • τ))
+      = (denomZ γ τ) ^ 2 *
+          weierstrassP (periodPairOfTau τ) (frickeTorsionPt N (vecMulSL N a γ) τ) := by
+  have hd := denomZ_ne_zero γ τ
+  have hN : (N : ℂ) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne N)
+  have hlat := periodPairOfTau_smul_lattice_eq γ τ
+  rw [weierstrassP_of_lattice_eq hlat,
+      show frickeTorsionPt N a (γ • τ)
+        = (denomZ γ τ)⁻¹ * (denomZ γ τ * frickeTorsionPt N a (γ • τ)) by
+          rw [inv_mul_cancel_left₀ hd],
+      weierstrassP_smulPeriodPair, inv_inv]
+  congr 1
+  have hpt : denomZ γ τ * frickeTorsionPt N a (γ • τ)
+      = ((((a 0).val : ℤ) * γ 0 0 + ((a 1).val : ℤ) * γ 1 0 : ℤ) * (τ : ℂ)
+          + (((a 0).val : ℤ) * γ 0 1 + ((a 1).val : ℤ) * γ 1 1 : ℤ)) / (N : ℂ) := by
+    have e : denomZ γ τ * frickeTorsionPt N a (γ • τ)
+        = (((a 0).val : ℂ) * numZ γ τ + ((a 1).val : ℂ) * denomZ γ τ) / (N : ℂ) := by
+      unfold frickeTorsionPt; rw [coe_SL2Z_smul]; field_simp
+    rw [e, numZ, denomZ]; push_cast; ring
+  rw [hpt]
+  refine weierstrassP_torsionPt_lift_irrel (vecMulSL N a γ) τ _ _ ?_ ?_
+  · rw [vecMulSL_apply]; push_cast; simp only [ZMod.natCast_val, ZMod.cast_id]
+  · rw [vecMulSL_apply]; push_cast; simp only [ZMod.natCast_val, ZMod.cast_id]
+
+lemma vecMulSL_of_mem_Gamma {N : ℕ} (a : Fin 2 → ZMod N) {γ : SL(2, ℤ)}
+    (hγ : γ ∈ CongruenceSubgroup.Gamma N) : vecMulSL N a γ = a := by
+  obtain ⟨h₀₀, h₀₁, h₁₀, h₁₁⟩ := CongruenceSubgroup.Gamma_mem.mp hγ
+  funext j
+  fin_cases j <;> simp [vecMulSL_apply, h₀₀, h₀₁, h₁₀, h₁₁]
+
+lemma weierstrassP_frickeTorsionPt_neg {N : ℕ} [NeZero N] (a : Fin 2 → ZMod N) (τ : ℍ) :
+    weierstrassP (periodPairOfTau τ) (frickeTorsionPt N (-a) τ)
+      = weierstrassP (periodPairOfTau τ) (frickeTorsionPt N a τ) := by
+  have h := weierstrassP_torsionPt_lift_irrel (N := N) (-a) τ
+      (-((a 0).val : ℤ)) (-((a 1).val : ℤ))
+      (by push_cast; simp [ZMod.natCast_val, ZMod.cast_id])
+      (by push_cast; simp [ZMod.natCast_val, ZMod.cast_id])
+  rw [← h, ← (periodPairOfTau τ).weierstrassP_neg]
+  congr 1
+  unfold frickeTorsionPt
+  push_cast
+  ring
+
+end B3_fricke_tier2
+
+section B3_spelling2
+
+
+lemma denom_mapGL_eq_denomZ (γ : SL(2, ℤ)) (τ : ℍ) :
+    denom (mapGL ℝ γ) τ = denomZ γ τ := by
+  simp [denom, denomZ]
+
+def wpNormZ (N : ℕ) (a : Fin 2 → ZMod N) (τ : ℍ) : ℂ := wpNorm N (a 0).val (a 1).val τ
+
+lemma wpNormZ_eq (N : ℕ) (a : Fin 2 → ZMod N) (τ : ℍ) :
+    wpNormZ N a τ = ((2 * π * I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (periodPairOfTau τ) (frickeTorsionPt N a τ) := by
+  with_unfolding_all rfl
+
+theorem wpNormZ_slash {N : ℕ} [NeZero N] (a : Fin 2 → ZMod N) (γ : SL(2, ℤ)) (τ : ℍ) :
+    wpNormZ N a (γ • τ) = denomZ γ τ ^ 2 * wpNormZ N (vecMulSL N a γ) τ := by
+  rw [wpNormZ_eq, wpNormZ_eq, weierstrassP_frickeTorsionPt_slash]
+  ring
+
+def frickeF (N : ℕ) (a : Fin 2 → ZMod N) (τ : ℍ) : ℂ :=
+  -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * wpNormZ N a τ
+
+theorem frickeF_slash {N : ℕ} [NeZero N] (a : Fin 2 → ZMod N) (γ : SL(2, ℤ)) (τ : ℍ) :
+    frickeF N a (γ • τ) = frickeF N (vecMulSL N a γ) τ := by
+  have hγ : (mapGL ℝ γ : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ, rfl⟩
+  have h4 := SlashInvariantForm.slash_action_eqn'' ModularForm.E₄ hγ τ
+  have h6 := SlashInvariantForm.slash_action_eqn'' ModularForm.E₆ hγ τ
+  have hΔ := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hγ τ
+  rw [CuspForm.coe_discriminant] at hΔ
+  rw [show (mapGL ℝ γ) • τ = γ • τ from rfl, denom_mapGL_eq_denomZ] at h4 h6 hΔ
+  have hd : denomZ γ τ ≠ 0 := denomZ_ne_zero γ τ
+  have hΔ0 : ModularForm.discriminant τ ≠ 0 := ModularForm.discriminant_ne_zero τ
+  unfold frickeF
+  rw [h4, h6, hΔ, wpNormZ_slash, zpow_ofNat, zpow_ofNat, zpow_ofNat]
+  field_simp
+
+theorem frickeF_invariant_Gamma {N : ℕ} [NeZero N] (a : Fin 2 → ZMod N) {γ : SL(2, ℤ)}
+    (hγ : γ ∈ CongruenceSubgroup.Gamma N) (τ : ℍ) : frickeF N a (γ • τ) = frickeF N a τ := by
+  rw [frickeF_slash, vecMulSL_of_mem_Gamma a hγ]
+
+abbrev FrickeIdx (N : ℕ) : Type := {a : Fin 2 → ZMod N // a ≠ 0}
+
+lemma frickeIdx_hyps {N : ℕ} [NeZero N] (i : FrickeIdx N) :
+    (i.1 0).val < N ∧ (i.1 1).val < N ∧ ((i.1 0).val ≠ 0 ∨ (i.1 1).val ≠ 0) := by
+  refine ⟨ZMod.val_lt _, ZMod.val_lt _, ?_⟩
+  by_contra h
+  push Not at h
+  apply i.2
+  funext j
+  fin_cases j
+  · exact (ZMod.val_eq_zero _).mp h.1
+  · exact (ZMod.val_eq_zero _).mp h.2
+
+theorem frickeF_mul_discriminant {N : ℕ} (a : Fin 2 → ZMod N) (τ : ℍ) :
+    frickeF N a τ * CuspForm.discriminant τ = -(frickeH N (a 0).val (a 1).val τ) / 2592 := by
+  rw [CuspForm.coe_discriminant]
+  have hΔ0 : ModularForm.discriminant τ ≠ 0 := ModularForm.discriminant_ne_zero τ
+  simp only [frickeF, frickeH, wpNormZ, Pi.mul_apply]
+  field_simp
+
+theorem mdifferentiable_frickeF {N : ℕ} [NeZero N] (i : FrickeIdx N) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (frickeF N i.1) := by
+  obtain ⟨h1, h2, h0⟩ := frickeIdx_hyps i
+  have hW : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (wpNormZ N i.1) := mdifferentiable_wpNorm h1 h2 h0
+  have hE : MDifferentiable 𝓘(ℂ) 𝓘(ℂ)
+      (fun τ ↦ ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) :=
+    (ModularForm.E₄.holo'.mul ModularForm.E₆.holo').div CuspForm.discriminant.holo'
+      ModularForm.discriminant_ne_zero
+  have hc : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fun _ : ℍ ↦ (-1 / 2592 : ℂ)) := mdifferentiable_const
+  have heq : frickeF N i.1 = (fun _ : ℍ ↦ (-1 / 2592 : ℂ)) *
+      (fun τ ↦ ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) *
+        wpNormZ N i.1 := by
+    funext τ
+    simp only [frickeF, Pi.mul_apply]
+    ring
+  rw [heq]
+  exact (hc.mul hE).mul hW
+
+theorem isBoundedAtImInfty_frickeF_mul_discriminant {N : ℕ} [NeZero N] (i : FrickeIdx N) :
+    IsBoundedAtImInfty (frickeF N i.1 * ⇑CuspForm.discriminant) := by
+  obtain ⟨h1, h2, h0⟩ := frickeIdx_hyps i
+  have hH := isBoundedAtImInfty_frickeH h1 h2 h0
+  have : (frickeF N i.1 * ⇑CuspForm.discriminant : ℍ → ℂ) =
+      fun τ ↦ (-1 / 2592 : ℂ) * frickeH N (i.1 0).val (i.1 1).val τ := by
+    funext τ
+    rw [Pi.mul_apply, frickeF_mul_discriminant]
+    ring
+  rw [this]
+  exact hH.const_mul_left _
+
+lemma qExpansion_E4E6_coeff_zero {N : ℕ} (hN : N ≠ 0) :
+    (qExpansion N (⇑ModularForm.E₄ * ⇑ModularForm.E₆ : ℍ → ℂ)).coeff 0 = 1 := by
+  have hper : Function.Periodic ((⇑ModularForm.E₄ * ⇑ModularForm.E₆ : ℍ → ℂ) ∘ ofComplex) 1 := by
+    have h4 := SlashInvariantFormClass.periodic_comp_ofComplex ModularForm.E₄
+      one_mem_strictPeriods_SL
+    have h6 := SlashInvariantFormClass.periodic_comp_ofComplex ModularForm.E₆
+      one_mem_strictPeriods_SL
+    intro τ
+    have e4 := h4 τ
+    have e6 := h6 τ
+    simp only [Function.comp_apply, Pi.mul_apply, Complex.ofReal_one] at e4 e6 ⊢
+    rw [e4, e6]
+  rw [qExpansion_coeff_width _ hN hper (ModularForm.E₄.holo'.mul ModularForm.E₆.holo')
+    ((ModularFormClass.bdd_at_infty ModularForm.E₄).mul
+      (ModularFormClass.bdd_at_infty ModularForm.E₆)) 0,
+    ite_eq_left (dvd_zero N), Nat.zero_div,
+    ModularForm.qExpansion_mul_coe one_pos one_mem_strictPeriods_SL,
+    PowerSeries.coeff_zero_eq_constantCoeff, map_mul, ← PowerSeries.coeff_zero_eq_constantCoeff,
+    EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) (by decide),
+    EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) (by decide), mul_one]
+
+lemma qExpansion_wpNorm_eq_of_frickeH_eq {N a₁ a₂ b₁ b₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (ha0 : a₁ ≠ 0 ∨ a₂ ≠ 0) (hb₁ : b₁ < N) (hb₂ : b₂ < N) (hb0 : b₁ ≠ 0 ∨ b₂ ≠ 0)
+    (h : frickeH N a₁ a₂ = frickeH N b₁ b₂) :
+    qExpansion N (wpNorm N a₁ a₂) = qExpansion N (wpNorm N b₁ b₂) := by
+  have hN : N ≠ 0 := by omega
+  have hN' : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero hN
+  have hperE : Function.Periodic ((⇑ModularForm.E₄ * ⇑ModularForm.E₆ : ℍ → ℂ) ∘ ofComplex) N := by
+    have h4 := (SlashInvariantFormClass.periodic_comp_ofComplex ModularForm.E₄
+      one_mem_strictPeriods_SL).nat_mul N
+    have h6 := (SlashInvariantFormClass.periodic_comp_ofComplex ModularForm.E₆
+      one_mem_strictPeriods_SL).nat_mul N
+    intro τ
+    have e4 := h4 τ; have e6 := h6 τ
+    simp only [Complex.ofReal_one, mul_one, Function.comp_apply] at e4 e6
+    simp only [Function.comp_apply, Pi.mul_apply, e4, e6]
+  have hE : AnalyticAt ℂ (cuspFunction N (⇑ModularForm.E₄ * ⇑ModularForm.E₆ : ℍ → ℂ)) 0 :=
+    analyticAt_cuspFunction_zero hN' hperE (ModularForm.E₄.holo'.mul ModularForm.E₆.holo')
+      ((ModularFormClass.bdd_at_infty ModularForm.E₄).mul
+        (ModularFormClass.bdd_at_infty ModularForm.E₆))
+  have hWa : AnalyticAt ℂ (cuspFunction N (wpNorm N a₁ a₂)) 0 :=
+    analyticAt_cuspFunction_zero hN' (periodic_wpNorm ha₁ ha₂ ha0)
+      (mdifferentiable_wpNorm ha₁ ha₂ ha0) (isBoundedAtImInfty_wpNorm ha₁ ha₂ ha0)
+  have hWb : AnalyticAt ℂ (cuspFunction N (wpNorm N b₁ b₂)) 0 :=
+    analyticAt_cuspFunction_zero hN' (periodic_wpNorm hb₁ hb₂ hb0)
+      (mdifferentiable_wpNorm hb₁ hb₂ hb0) (isBoundedAtImInfty_wpNorm hb₁ hb₂ hb0)
+  have hq := congrArg (qExpansion (N : ℝ)) h
+  rw [frickeH, frickeH, qExpansion_mul hE hWa, qExpansion_mul hE hWb] at hq
+  have hne : qExpansion N (⇑ModularForm.E₄ * ⇑ModularForm.E₆ : ℍ → ℂ) ≠ 0 := by
+    intro h0
+    have := qExpansion_E4E6_coeff_zero hN
+    rw [h0, map_zero] at this
+    exact zero_ne_one this
+  exact mul_left_cancel₀ hne hq
+
+lemma qExpansion_E4E6_rat {N : ℕ} (hN : N ≠ 0) (n : ℕ) :
+    ∃ q : ℚ, (qExpansion N (⇑ModularForm.E₄ * ⇑ModularForm.E₆ : ℍ → ℂ)).coeff n = (q : ℂ) := by
+  have hper : Function.Periodic ((⇑ModularForm.E₄ * ⇑ModularForm.E₆ : ℍ → ℂ) ∘ ofComplex) 1 := by
+    have h4 := SlashInvariantFormClass.periodic_comp_ofComplex ModularForm.E₄
+      one_mem_strictPeriods_SL
+    have h6 := SlashInvariantFormClass.periodic_comp_ofComplex ModularForm.E₆
+      one_mem_strictPeriods_SL
+    intro τ
+    have e4 := h4 τ
+    have e6 := h6 τ
+    simp only [Function.comp_apply, Pi.mul_apply, Complex.ofReal_one] at e4 e6 ⊢
+    rw [e4, e6]
+  rw [qExpansion_coeff_width _ hN hper (ModularForm.E₄.holo'.mul ModularForm.E₆.holo')
+    ((ModularFormClass.bdd_at_infty ModularForm.E₄).mul
+      (ModularFormClass.bdd_at_infty ModularForm.E₆)) n]
+  by_cases hdvd : N ∣ n
+  · rw [ite_eq_left hdvd, ModularForm.qExpansion_mul_coe one_pos one_mem_strictPeriods_SL,
+      PowerSeries.coeff_mul]
+    refine ⟨∑ p ∈ Finset.HasAntidiagonal.antidiagonal (n / N),
+      (qExpansion_one_E4_rat p.1).choose * (qExpansion_one_E6_rat p.2).choose, ?_⟩
+    push_cast
+    exact Finset.sum_congr rfl fun p _ =>
+      congrArg₂ (· * ·) (qExpansion_one_E4_rat p.1).choose_spec
+        (qExpansion_one_E6_rat p.2).choose_spec
+  · exact ⟨0, by rw [ite_eq_right hdvd]; norm_num⟩
+
+theorem qExpansion_frickeH_coeff_mem_kN {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) (n : ℕ) :
+    (qExpansion N (frickeH N a₁ a₂)).coeff n ∈ kN N := by
+  have hN : N ≠ 0 := by omega
+  have hN' : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero hN
+  have hperE : Function.Periodic ((⇑ModularForm.E₄ * ⇑ModularForm.E₆ : ℍ → ℂ) ∘ ofComplex) N := by
+    have h4 := (SlashInvariantFormClass.periodic_comp_ofComplex ModularForm.E₄
+      one_mem_strictPeriods_SL).nat_mul N
+    have h6 := (SlashInvariantFormClass.periodic_comp_ofComplex ModularForm.E₆
+      one_mem_strictPeriods_SL).nat_mul N
+    intro τ
+    have e4 := h4 τ
+    have e6 := h6 τ
+    simp only [Complex.ofReal_one, mul_one, Function.comp_apply] at e4 e6
+    simp only [Function.comp_apply, Pi.mul_apply, e4, e6]
+  have hE : AnalyticAt ℂ (cuspFunction N (⇑ModularForm.E₄ * ⇑ModularForm.E₆ : ℍ → ℂ)) 0 :=
+    analyticAt_cuspFunction_zero hN' hperE (ModularForm.E₄.holo'.mul ModularForm.E₆.holo')
+      ((ModularFormClass.bdd_at_infty ModularForm.E₄).mul
+        (ModularFormClass.bdd_at_infty ModularForm.E₆))
+  have hW : AnalyticAt ℂ (cuspFunction N (wpNorm N a₁ a₂)) 0 :=
+    analyticAt_cuspFunction_zero hN' (periodic_wpNorm ha₁ ha₂ h0)
+      (mdifferentiable_wpNorm ha₁ ha₂ h0) (isBoundedAtImInfty_wpNorm ha₁ ha₂ h0)
+  rw [frickeH, qExpansion_mul hE hW, PowerSeries.coeff_mul]
+  refine sum_mem fun ij _ ↦ mul_mem ?_ (qExpansion_wpNorm_coeff_mem_kN ha₁ ha₂ h0 _)
+  obtain ⟨q, hq⟩ := qExpansion_E4E6_rat hN ij.1
+  rw [hq, ← SubfieldClass.coe_ratCast (kN N) q]
+  exact SetLike.coe_mem _
+
+lemma qExpansion_frickeH_conj {N : ℕ} [NeZero N] {s : ℕ} (hs : s.Coprime N)
+    (φ : ↑(kN N) →+* ℂ) (hφ : φ ⟨zetaN N, zetaN_mem_kN N⟩ = zetaN N ^ s)
+    {a₁ a₂ : ℕ} (h1 : a₁ < N) (h2 : a₂ < N) (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) (n : ℕ)
+    (z : ↑(kN N)) (hz : (z : ℂ) = (qExpansion N (frickeH N a₁ a₂)).coeff n) :
+    (qExpansion N (frickeH N a₁ (s * a₂ % N))).coeff n = φ z := by
+  have hN : N ≠ 0 := NeZero.ne N
+  have hN' : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero hN
+  have h2' : s * a₂ % N < N := Nat.mod_lt _ (Nat.pos_of_ne_zero hN)
+  have h0' : a₁ ≠ 0 ∨ s * a₂ % N ≠ 0 := by
+    rcases h0 with h | h
+    · exact Or.inl h
+    · refine Or.inr fun hmod => h ?_
+      have hdvd0 : N ∣ s * a₂ := Nat.dvd_of_mod_eq_zero hmod
+      have hdvd : N ∣ a₂ := Nat.Coprime.dvd_of_dvd_mul_left (Nat.Coprime.symm hs) hdvd0
+      exact Nat.eq_zero_of_dvd_of_lt hdvd h2
+  obtain ⟨S, hSmap, hSconj⟩ := wpNorm_qExpansion_model hN
+  have hESm := qExpansion_E4E6_rat hN
+  have hESmap : (PowerSeries.mk fun m => (((hESm m).choose : ℚ) : ↑(kN N))).map
+      (algebraMap ↑(kN N) ℂ) = qExpansion N (⇑ModularForm.E₄ * ⇑ModularForm.E₆ : ℍ → ℂ) := by
+    ext m
+    rw [PowerSeries.coeff_map, PowerSeries.coeff_mk, map_ratCast]
+    exact ((hESm m).choose_spec).symm
+  have hESφ : (PowerSeries.mk fun m => (((hESm m).choose : ℚ) : ↑(kN N))).map φ =
+      qExpansion N (⇑ModularForm.E₄ * ⇑ModularForm.E₆ : ℍ → ℂ) := by
+    ext m
+    rw [PowerSeries.coeff_map, PowerSeries.coeff_mk, map_ratCast]
+    exact ((hESm m).choose_spec).symm
+  have hperE : Function.Periodic ((⇑ModularForm.E₄ * ⇑ModularForm.E₆ : ℍ → ℂ) ∘ ofComplex) N := by
+    have h4 := (SlashInvariantFormClass.periodic_comp_ofComplex ModularForm.E₄
+      one_mem_strictPeriods_SL).nat_mul N
+    have h6 := (SlashInvariantFormClass.periodic_comp_ofComplex ModularForm.E₆
+      one_mem_strictPeriods_SL).nat_mul N
+    intro τ
+    have e4 := h4 τ
+    have e6 := h6 τ
+    simp only [Complex.ofReal_one, mul_one, Function.comp_apply] at e4 e6
+    simp only [Function.comp_apply, Pi.mul_apply, e4, e6]
+  have hE : AnalyticAt ℂ (cuspFunction N (⇑ModularForm.E₄ * ⇑ModularForm.E₆ : ℍ → ℂ)) 0 :=
+    analyticAt_cuspFunction_zero hN' hperE (ModularForm.E₄.holo'.mul ModularForm.E₆.holo')
+      ((ModularFormClass.bdd_at_infty ModularForm.E₄).mul
+        (ModularFormClass.bdd_at_infty ModularForm.E₆))
+  have hWa : AnalyticAt ℂ (cuspFunction N (wpNorm N a₁ a₂)) 0 :=
+    analyticAt_cuspFunction_zero hN' (periodic_wpNorm h1 h2 h0)
+      (mdifferentiable_wpNorm h1 h2 h0) (isBoundedAtImInfty_wpNorm h1 h2 h0)
+  have hWa' : AnalyticAt ℂ (cuspFunction N (wpNorm N a₁ (s * a₂ % N))) 0 :=
+    analyticAt_cuspFunction_zero hN' (periodic_wpNorm h1 h2' h0')
+      (mdifferentiable_wpNorm h1 h2' h0') (isBoundedAtImInfty_wpNorm h1 h2' h0')
+  have hHa : qExpansion N (frickeH N a₁ a₂) =
+      ((PowerSeries.mk fun m => (((hESm m).choose : ℚ) : ↑(kN N))) * S a₁ a₂).map
+        (algebraMap ↑(kN N) ℂ) := by
+    rw [frickeH, qExpansion_mul hE hWa, map_mul, hESmap, hSmap a₁ a₂ h1 h2 h0]
+  have hHa' : qExpansion N (frickeH N a₁ (s * a₂ % N)) =
+      ((PowerSeries.mk fun m => (((hESm m).choose : ℚ) : ↑(kN N))) * S a₁ a₂).map φ := by
+    rw [frickeH, qExpansion_mul hE hWa', map_mul, hESφ, hSconj s hs φ hφ a₁ a₂ h1 h2 h0]
+  have hz2 : z = ((PowerSeries.mk fun m => (((hESm m).choose : ℚ) : ↑(kN N))) * S a₁ a₂).coeff n :=
+    by
+    have hinj : Function.Injective (algebraMap ↑(kN N) ℂ) := (algebraMap ↑(kN N) ℂ).injective
+    apply hinj
+    rw [← PowerSeries.coeff_map, ← hHa]
+    exact_mod_cast hz
+  rw [hHa', PowerSeries.coeff_map, ← hz2]
+
+theorem frickeF_eq_imp {N : ℕ} [NeZero N] (a b : FrickeIdx N)
+    (h : frickeF N a.1 = frickeF N b.1) : b.1 = a.1 ∨ b.1 = -a.1 := by
+  obtain ⟨ha₁, ha₂, ha0⟩ := frickeIdx_hyps a
+  obtain ⟨hb₁, hb₂, hb0⟩ := frickeIdx_hyps b
+  have hH : frickeH N (a.1 0).val (a.1 1).val = frickeH N (b.1 0).val (b.1 1).val := by
+    funext τ
+    have e := congrFun h τ
+    have ea := frickeF_mul_discriminant a.1 τ
+    have eb := frickeF_mul_discriminant b.1 τ
+    rw [e] at ea
+    rw [ea] at eb
+    linear_combination (-2592) * eb
+  have hq := qExpansion_wpNorm_eq_of_frickeH_eq ha₁ ha₂ ha0 hb₁ hb₂ hb0 hH
+  have hNpos : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  have hfun : wpNorm N (a.1 0).val (a.1 1).val = wpNorm N (b.1 0).val (b.1 1).val := by
+    funext τ
+    have hsa := hasSum_qExpansion hNpos (periodic_wpNorm ha₁ ha₂ ha0)
+      (mdifferentiable_wpNorm ha₁ ha₂ ha0) (isBoundedAtImInfty_wpNorm ha₁ ha₂ ha0) τ
+    have hsb := hasSum_qExpansion hNpos (periodic_wpNorm hb₁ hb₂ hb0)
+      (mdifferentiable_wpNorm hb₁ hb₂ hb0) (isBoundedAtImInfty_wpNorm hb₁ hb₂ hb0) τ
+    rw [← hq] at hsb
+    exact hsa.unique hsb
+  rcases wpNorm_eq_imp ha₁ ha₂ ha0 hb₁ hb₂ hb0 hfun with ⟨e0, e1⟩ | ⟨e0, e1⟩
+  · left
+    have f0 : b.1 0 = a.1 0 := ZMod.val_injective N e0
+    have f1 : b.1 1 = a.1 1 := ZMod.val_injective N e1
+    funext j
+    fin_cases j <;> simp [f0, f1]
+  · right
+    have f0 : b.1 0 = -a.1 0 := ZMod.val_injective N (by rw [e0, ZMod.neg_val'])
+    have f1 : b.1 1 = -a.1 1 := ZMod.val_injective N (by rw [e1, ZMod.neg_val'])
+    funext j
+    fin_cases j <;> simp [f0, f1]
+
+end B3_spelling2
+
+section R4aBridge
+
+open WLight
+open scoped Manifold MatrixGroups ModularForm
+
+private lemma periodPair_ext' {L₁ L₂ : PeriodPair} (h₁ : L₁.ω₁ = L₂.ω₁)
+    (h₂ : L₁.ω₂ = L₂.ω₂) : L₁ = L₂ := by
+  cases L₁; cases L₂; simp_all
+
+end R4aBridge
+
+end WLight
+
+open WLight
+
+theorem solution (N : ℕ) [NeZero N]
+    (L : ℍ → PeriodPair) (hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1) :
+    let f : (Fin 2 → ZMod N) → ℍ → ℂ := fun a τ =>
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 *
+        (((2 * π * I) ^ 2)⁻¹ *
+          PeriodPair.weierstrassP (L τ)
+            ((((a 0).val : ℂ) * (τ : ℂ) + ((a 1).val : ℂ)) / (N : ℂ)))
+    (∀ (a : Fin 2 → ZMod N) (γ : SL(2, ℤ)) (τ : ℍ), f a (γ • τ) =
+        f (Matrix.vecMul a ((γ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N))) τ) ∧
+    (∀ a : Fin 2 → ZMod N, f (-a) = f a) ∧
+    (∀ a : Fin 2 → ZMod N, a ≠ 0 → MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (f a)) ∧
+    (∀ a : Fin 2 → ZMod N, a ≠ 0 →
+      IsBoundedAtImInfty (f a * ModularForm.discriminant)) ∧
+    (∀ a : Fin 2 → ZMod N, a ≠ 0 →
+      Function.Periodic ((f a * ModularForm.discriminant) ∘ ofComplex) N ∧
+      ∀ n : ℕ, (qExpansion N (f a * ModularForm.discriminant)).coeff n ∈
+        IntermediateField.adjoin ℚ {cexp (2 * π * I / N)}) ∧
+    (∀ a b : Fin 2 → ZMod N, a ≠ 0 → b ≠ 0 → f a = f b → b = a ∨ b = -a) ∧
+    (∀ a : Fin 2 → ZMod N, ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : ℍ,
+      f a (γ • τ) = f a τ) ∧
+    (∀ s : ℕ, s.Coprime N →
+      ∀ φ : ↑(IntermediateField.adjoin ℚ {cexp (2 * π * I / N)}) →+* ℂ,
+        (∀ z : ↑(IntermediateField.adjoin ℚ {cexp (2 * π * I / N)}),
+            (z : ℂ) = cexp (2 * π * I / N) → φ z = cexp (2 * π * I / N) ^ s) →
+        ∀ a : Fin 2 → ZMod N, a ≠ 0 →
+          ∀ (n : ℕ) (z : ↑(IntermediateField.adjoin ℚ {cexp (2 * π * I / N)})),
+            (z : ℂ) = (qExpansion N (f a * ModularForm.discriminant)).coeff n →
+            (qExpansion N (f ![a 0, (s : ZMod N) * a 1] * ModularForm.discriminant)).coeff n = φ z)
+              := by
+  intro f
+  have hLpp : ∀ τ : ℍ, L τ = periodPairOfTau τ := fun τ =>
+    periodPair_ext' ((hL τ).1.trans (periodPairOfTau_ω₁ τ).symm)
+      ((hL τ).2.trans (periodPairOfTau_ω₂ τ).symm)
+  have hfeq : ∀ (a : Fin 2 → ZMod N) (τ : ℍ), f a τ = frickeF N a τ := by
+    intro a τ
+    change -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 *
+      (((2 * ↑Real.pi * Complex.I) ^ 2)⁻¹ *
+        PeriodPair.weierstrassP (L τ) _) = _
+    rw [hLpp τ]
+    with_unfolding_all rfl
+  have hfeq' : ∀ a : Fin 2 → ZMod N, f a = frickeF N a := fun a => funext (hfeq a)
+  refine ⟨?_, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩
+  · intro a γ τ
+    rw [hfeq, hfeq]
+    exact frickeF_slash a γ τ
+  · intro a
+    funext τ
+    rw [hfeq, hfeq]
+    show frickeF N (-a) τ = frickeF N a τ
+    simp only [frickeF]
+    congr 1
+    rw [wpNormZ_eq, wpNormZ_eq, weierstrassP_frickeTorsionPt_neg]
+  · intro a ha
+    rw [hfeq' a]
+    exact mdifferentiable_frickeF ⟨a, ha⟩
+  · intro a ha
+    have hb := isBoundedAtImInfty_frickeF_mul_discriminant (⟨a, ha⟩ : FrickeIdx N)
+    have hsh : (f a * ModularForm.discriminant : ℍ → ℂ) =
+        frickeF N a * ⇑CuspForm.discriminant := by
+      funext τ
+      simp only [Pi.mul_apply, hfeq a τ]
+      rw [show ModularForm.discriminant τ = (⇑CuspForm.discriminant) τ from
+        (congrFun CuspForm.coe_discriminant τ).symm]
+    rw [hsh]
+    exact hb
+  · intro a ha
+    obtain ⟨h1, h2, h0⟩ := frickeIdx_hyps (⟨a, ha⟩ : FrickeIdx N)
+    have hshape : (f a * ModularForm.discriminant : ℍ → ℂ) =
+        (-(1 / 2592) : ℂ) • frickeH N (a 0).val (a 1).val := by
+      funext τ
+      simp only [Pi.mul_apply, Pi.smul_apply, smul_eq_mul, hfeq a τ]
+      rw [show ModularForm.discriminant τ = (⇑CuspForm.discriminant) τ from
+        (congrFun CuspForm.coe_discriminant τ).symm, frickeF_mul_discriminant]
+      ring
+    constructor
+    · rw [hshape]
+      intro x
+      have hx := periodic_frickeH h1 h2 h0 x
+      simp only [Function.comp_apply, Pi.smul_apply, smul_eq_mul] at hx ⊢
+      rw [hx]
+    · intro n
+      rw [hshape, qExpansion_smul (analyticAt_cuspFunction_zero_of
+          (mdifferentiable_frickeH h1 h2 h0) (periodic_frickeH h1 h2 h0)
+          (isBoundedAtImInfty_frickeH h1 h2 h0)), PowerSeries.coeff_smul, smul_eq_mul]
+      refine mul_mem ?_ (qExpansion_frickeH_coeff_mem_kN h1 h2 h0 n)
+      show ((-(1 / 2592) : ℂ)) ∈ IntermediateField.adjoin ℚ {Complex.exp (2 * ↑Real.pi * Complex.I /
+        N)}
+      simp
+  · intro a b ha hb hab
+    exact frickeF_eq_imp ⟨a, ha⟩ ⟨b, hb⟩ (by rw [← hfeq' a, ← hfeq' b]; exact hab)
+  · intro a γ hγ τ
+    rw [hfeq, hfeq]
+    exact frickeF_invariant_Gamma a hγ τ
+  · intro s hs φ hφ a ha n z hz
+    obtain ⟨h1, h2, h0⟩ := frickeIdx_hyps (⟨a, ha⟩ : FrickeIdx N)
+    have hN : N ≠ 0 := NeZero.ne N
+    have h2' : s * (a 1).val % N < N := Nat.mod_lt _ (Nat.pos_of_ne_zero hN)
+    have h0' : (a 0).val ≠ 0 ∨ s * (a 1).val % N ≠ 0 := by
+      rcases h0 with h | h
+      · exact Or.inl h
+      · refine Or.inr fun hmod => h ?_
+        have hdvd0 : N ∣ s * (a 1).val := Nat.dvd_of_mod_eq_zero hmod
+        have hdvd : N ∣ (a 1).val :=
+          Nat.Coprime.dvd_of_dvd_mul_left (Nat.Coprime.symm hs) hdvd0
+        exact Nat.eq_zero_of_dvd_of_lt hdvd h2
+    have hsu : IsUnit ((s : ZMod N)) := (ZMod.isUnit_iff_coprime s N).mpr hs
+    have ha' : (![a 0, (s : ZMod N) * a 1] : Fin 2 → ZMod N) ≠ 0 := by
+      intro h00
+      apply ha
+      have e0 : a 0 = 0 := by simpa using congrFun h00 0
+      have e1 : (s : ZMod N) * a 1 = 0 := by simpa using congrFun h00 1
+      have e1' : a 1 = 0 := (hsu.mul_right_eq_zero).mp e1
+      funext j
+      fin_cases j <;> simp [e0, e1']
+    have hval : ((s : ZMod N) * a 1).val = s * (a 1).val % N := by
+      rw [ZMod.val_mul, ZMod.val_natCast]
+      exact Nat.mod_mul_mod s (a 1).val N
+    have hφg : φ ⟨zetaN N, zetaN_mem_kN N⟩ = zetaN N ^ s :=
+      hφ ⟨zetaN N, zetaN_mem_kN N⟩ rfl
+    have hshA : (f a * ModularForm.discriminant : ℍ → ℂ) =
+        (-(1 / 2592) : ℂ) • frickeH N (a 0).val (a 1).val := by
+      funext τ
+      simp only [Pi.mul_apply, Pi.smul_apply, smul_eq_mul, hfeq a τ]
+      rw [show ModularForm.discriminant τ = (⇑CuspForm.discriminant) τ from
+        (congrFun CuspForm.coe_discriminant τ).symm, frickeF_mul_discriminant]
+      ring
+    have hshA' : (f ![a 0, (s : ZMod N) * a 1] * ModularForm.discriminant : ℍ → ℂ) =
+        (-(1 / 2592) : ℂ) • frickeH N (a 0).val (s * (a 1).val % N) := by
+      funext τ
+      simp only [Pi.mul_apply, Pi.smul_apply, smul_eq_mul, hfeq (![a 0, (s : ZMod N) * a 1]) τ]
+      rw [show ModularForm.discriminant τ = (⇑CuspForm.discriminant) τ from
+        (congrFun CuspForm.coe_discriminant τ).symm, frickeF_mul_discriminant]
+      simp only [Matrix.cons_val_zero, Matrix.cons_val_one, hval]
+      ring
+    have hanA := analyticAt_cuspFunction_zero_of (mdifferentiable_frickeH h1 h2 h0)
+      (periodic_frickeH h1 h2 h0) (isBoundedAtImInfty_frickeH h1 h2 h0)
+    have hanA' := analyticAt_cuspFunction_zero_of (mdifferentiable_frickeH h1 h2' h0')
+      (periodic_frickeH h1 h2' h0') (isBoundedAtImInfty_frickeH h1 h2' h0')
+    rw [hshA, qExpansion_smul hanA, PowerSeries.coeff_smul, smul_eq_mul] at hz
+    rw [hshA', qExpansion_smul hanA', PowerSeries.coeff_smul, smul_eq_mul]
+    have hmem := qExpansion_frickeH_coeff_mem_kN h1 h2 h0 n
+    have htr := qExpansion_frickeH_conj hs φ hφg h1 h2 h0 n
+      (⟨_, hmem⟩ : ↑(IntermediateField.adjoin ℚ {cexp (2 * π * I / N)})) rfl
+    have hzrel : z = ((-(1/2592) : ℚ) : ↑(IntermediateField.adjoin ℚ {cexp (2 * π * I / N)})) *
+        ⟨_, hmem⟩ := by
+      apply Subtype.coe_injective
+      change (z : ℂ) = ((-(1/2592) : ℚ) : ℂ) *
+        (qExpansion N (frickeH N (a 0).val (a 1).val)).coeff n
+      rw [hz]
+      push_cast
+      ring
+    have hφz : φ z = ((-(1/2592) : ℚ) : ℂ) * φ ⟨_, hmem⟩ := by
+      rw [hzrel, map_mul, map_ratCast]
+    rw [htr, hφz]
+    push_cast
+    rfl
+
+end
+
+end privateSection
+
+public section publicSection
+
+
+open Complex Real
+open UpperHalfPlane hiding I
+open scoped Manifold MatrixGroups ModularForm
+theorem WLight.frickeFunction_modularity_package (N : ℕ) [NeZero N]
+    (L : ℍ → PeriodPair) (hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1) :
+    let f : (Fin 2 → ZMod N) → ℍ → ℂ := fun a τ =>
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 *
+        (((2 * π * I) ^ 2)⁻¹ *
+          PeriodPair.weierstrassP (L τ)
+            ((((a 0).val : ℂ) * (τ : ℂ) + ((a 1).val : ℂ)) / (N : ℂ)))
+    (∀ (a : Fin 2 → ZMod N) (γ : SL(2, ℤ)) (τ : ℍ), f a (γ • τ) =
+        f (Matrix.vecMul a ((γ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N))) τ) ∧
+    (∀ a : Fin 2 → ZMod N, f (-a) = f a) ∧
+    (∀ a : Fin 2 → ZMod N, a ≠ 0 → MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (f a)) ∧
+    (∀ a : Fin 2 → ZMod N, a ≠ 0 →
+      IsBoundedAtImInfty (f a * ModularForm.discriminant)) ∧
+    (∀ a : Fin 2 → ZMod N, a ≠ 0 →
+      Function.Periodic ((f a * ModularForm.discriminant) ∘ ofComplex) N ∧
+      ∀ n : ℕ, (qExpansion N (f a * ModularForm.discriminant)).coeff n ∈
+        IntermediateField.adjoin ℚ {cexp (2 * π * I / N)}) ∧
+    (∀ a b : Fin 2 → ZMod N, a ≠ 0 → b ≠ 0 → f a = f b → b = a ∨ b = -a) ∧
+    (∀ a : Fin 2 → ZMod N, ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : ℍ,
+      f a (γ • τ) = f a τ) ∧
+    (∀ s : ℕ, s.Coprime N →
+      ∀ φ : ↑(IntermediateField.adjoin ℚ {cexp (2 * π * I / N)}) →+* ℂ,
+        (∀ z : ↑(IntermediateField.adjoin ℚ {cexp (2 * π * I / N)}),
+            (z : ℂ) = cexp (2 * π * I / N) → φ z = cexp (2 * π * I / N) ^ s) →
+        ∀ a : Fin 2 → ZMod N, a ≠ 0 →
+          ∀ (n : ℕ) (z : ↑(IntermediateField.adjoin ℚ {cexp (2 * π * I / N)})),
+            (z : ℂ) = (qExpansion N (f a * ModularForm.discriminant)).coeff n →
+            (qExpansion N (f ![a 0, (s : ZMod N) * a 1] * ModularForm.discriminant)).coeff n = φ z)
+              := _root_.solution N L hL
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_frickeFunction_orbit_package.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_frickeFunction_orbit_package.lean
new file mode 100644
index 0000000000..eb3fb42256
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_frickeFunction_orbit_package.lean
@@ -0,0 +1,705 @@
+/-
+Based on Prove2Me node WLight.frickeFunction_orbit_package
+(31f08140-fc87-5825-b66a-596acddc0651) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 02c0902c-521b-59f3-addb-0ce0260a94dd
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.SpecialFunctions.Elliptic.Weierstrass
+public import Mathlib.NumberTheory.ModularForms.EisensteinSeries.Basic
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Manifold
+public import Mathlib.Geometry.Manifold.Notation
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_weierstrassP_torsion_qExpansion_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_modularity_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelOne_hauptmodul_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Polar growth of j and Fricke functions, and their orbit polynomial
+
+Theorem statement: `WLight.frickeFunction_orbit_package` (`31f08140-fc87-5825-b66a-596acddc0651`),
+by Claude, 2026-09-05.
+
+Proof: submission `02c0902c-521b-59f3-addb-0ce0260a94dd`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a nonzero natural number. Let $L$ assign to each point $\tau$ of the upper half-plane a
+period pair, pinned by the hypothesis that its first period is $\tau$ and its second period is $1$.
+Let $W$ be a family of functions on the upper half-plane indexed by $v \in (\mathbb{Z}/N)^2$, pinned
+by $W_v(\tau) = (2\pi i)^{-2}\,\wp_{L(\tau)}\big((\tilde v_0 \tau + \tilde v_1)/N\big)$, where
+$\tilde v_i$ denotes the canonical representative in $\{0,\dots,N-1\}$ of $v_i$ and $\wp$ is the
+Weierstrass function of the period pair; let $\mathrm{fricke}$ be pinned by $\mathrm{fricke}_v(\tau)
+= -\big(E_4(\tau)E_6(\tau)/\Delta(\tau)\big)/2592 \cdot W_v(\tau)$; and let $jf$ be pinned by
+$jf(\tau) = E_4(\tau)^3/\Delta(\tau)$. The conclusion is a threefold conjunction: (i) $jf$ is
+holomorphic on the upper half-plane and there is an $m \in \mathbb{N}$ with $jf \cdot \Delta^m$
+bounded at $i\infty$; (ii) for every $v \neq 0$, $\mathrm{fricke}_v$ is holomorphic and there is an
+$m \in \mathbb{N}$ with $\mathrm{fricke}_v \cdot \Delta^m$ bounded at $i\infty$; (iii) there is a
+family of polynomials $P_k \in \mathbb{C}[X]$, $k \in \mathbb{N}$, all of whose coefficients lie in
+the subfield $\mathbb{Q}(e^{2\pi i/N})$ of $\mathbb{C}$, such that for every $v \neq 0$ and every
+$\tau$, $\mathrm{fricke}_v(\tau)^{N^2-1} + \sum_{k<N^2-1} P_k(jf(\tau))\,\mathrm{fricke}_v(\tau)^k =
+0$; that is, a single monic relation of degree $N^2-1$ over $\mathbb{C}[jf]$, with coefficient
+polynomials having cyclotomic coefficients, annihilates all the Fricke functions of nonzero index
+simultaneously.
+
+This is the integrality statement for the Fricke functions of level $N$: the $N^2-1$ functions of
+nonzero index form a single orbit under the index action of the modular group, so the elementary
+symmetric functions of the orbit are level-one invariants of finite polar growth and hence
+polynomials in $j$, with coefficients in $\mathbb{Q}(e^{2\pi i/N})$. It is used in the construction
+of the function field of the modular curve of level $N$ and of its $q$-expansion and valuation data.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WLight_frickeFunction_orbit_package.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_WLight_frickeFunction_orbit_package
+
+noncomputable section
+
+open Complex Real
+namespace WLight
+p2m_export "WLight" "levelOne_hauptmodul_package frickeFunction_modularity_package"
+p2m_open "WLight"
+
+section R4bFloor
+open scoped UpperHalfPlane Manifold MatrixGroups
+p2m_open "UpperHalfPlane~I"
+p2m_open "ModularForm ModularFormClass CuspForm ModularForm.CuspForm Polynomial Real.Polynomial \
+  Filter"
+variable {N : ℕ}
+
+def periodPairOfTau (τ : ℍ) : PeriodPair where
+  ω₁ := (τ : ℂ)
+  ω₂ := 1
+  indep := LinearIndependent.pair_iff.mpr fun s t hst ↦ by
+    have him : s * (τ : ℂ).im = 0 := by
+      have := congrArg Complex.im hst
+      simpa [Complex.add_im, Complex.smul_im, smul_eq_mul] using this
+    have hs : s = 0 :=
+      (mul_eq_zero.mp him).resolve_right (UpperHalfPlane.coe_im τ ▸ τ.im_ne_zero)
+    subst hs
+    simpa using hst
+
+@[scoped simp] lemma periodPairOfTau_ω₁ (τ : ℍ) : (periodPairOfTau τ).ω₁ = (τ : ℂ) := rfl
+@[scoped simp] lemma periodPairOfTau_ω₂ (τ : ℍ) : (periodPairOfTau τ).ω₂ = 1 := rfl
+
+def zetaN (N : ℕ) : ℂ := cexp (2 * π * I / N)
+
+def wpTorsion (N a₁ a₂ : ℕ) (τ : ℍ) : ℂ :=
+  PeriodPair.weierstrassP (periodPairOfTau τ) (((a₁ : ℂ) * τ + a₂) / N)
+
+def kN (N : ℕ) : IntermediateField ℚ ℂ := IntermediateField.adjoin ℚ {zetaN N}
+
+def wpNorm (N a₁ a₂ : ℕ) (τ : ℍ) : ℂ := ((2 * π * I) ^ 2)⁻¹ * wpTorsion N a₁ a₂ τ
+
+def j : ℍ → ℂ := fun z => E₄ z ^ 3 / ModularForm.discriminant z
+
+def vecMulSL (N : ℕ) (a : Fin 2 → ZMod N) (γ : SL(2, ℤ)) : Fin 2 → ZMod N :=
+  Matrix.vecMul a ((γ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N))
+
+def wpNormZ (N : ℕ) (a : Fin 2 → ZMod N) (τ : ℍ) : ℂ := wpNorm N (a 0).val (a 1).val τ
+
+def frickeF (N : ℕ) (a : Fin 2 → ZMod N) (τ : ℍ) : ℂ :=
+  -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * wpNormZ N a τ
+
+abbrev FrickeIdx (N : ℕ) : Type := {a : Fin 2 → ZMod N // a ≠ 0}
+
+def KPoleAt (K : IntermediateField ℚ ℂ) (N m : ℕ) (f : ℍ → ℂ) : Prop :=
+  Function.Periodic ((f * ⇑CuspForm.discriminant ^ m) ∘ ofComplex) N ∧
+    IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m) ∧
+    ∀ n : ℕ, (qExpansion N (f * ⇑CuspForm.discriminant ^ m)).coeff n ∈ K
+
+def KPole (K : IntermediateField ℚ ℂ) (N : ℕ) (f : ℍ → ℂ) : Prop :=
+  MDiff f ∧ ∃ m : ℕ, KPoleAt K N m f
+
+p2m_open "UpperHalfPlane~I"
+
+def levelGen (N : ℕ) : Set (ℍ → ℂ) := insert j (Set.range fun i : FrickeIdx N ↦ frickeF N i.1)
+
+private lemma hppT : ∀ τ : ℍ, (periodPairOfTau τ).ω₁ = (τ : ℂ) ∧ (periodPairOfTau τ).ω₂ = 1 :=
+  fun τ => ⟨periodPairOfTau_ω₁ τ, periodPairOfTau_ω₂ τ⟩
+
+private lemma coe_cuspDisc : ⇑CuspForm.discriminant = ModularForm.discriminant := rfl
+
+private lemma frickeF_eq (N : ℕ) (a : Fin 2 → ZMod N) :
+    frickeF N a = fun τ =>
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 *
+        (((2 * π * I) ^ 2)⁻¹ *
+          PeriodPair.weierstrassP (periodPairOfTau τ)
+            ((((a 0).val : ℂ) * (τ : ℂ) + ((a 1).val : ℂ)) / (N : ℂ))) := by
+  funext τ
+  simp only [frickeF, wpNormZ, wpNorm, wpTorsion]
+
+theorem kPole_invariant_eq_polynomial_j_mem {K : IntermediateField ℚ ℂ} [NeZero N]
+    {a : ℍ → ℂ} (hk : KPole K N a) (hinv : ∀ γ : SL(2, ℤ), a ∣[(0 : ℤ)] γ = a) :
+    ∃ P : Polynomial ℂ, (∀ i, P.coeff i ∈ K) ∧ a = fun τ => Polynomial.eval (j τ) P := by
+  obtain ⟨hmd, m, hper, hbd, hcoef⟩ := hk
+  rw [coe_cuspDisc] at hper hbd hcoef
+  obtain ⟨P, _, hcoefP, heq⟩ :=
+    levelOne_hauptmodul_package.2.1 K N (NeZero.ne N) m a hmd hinv hper hbd hcoef
+  exact ⟨P, hcoefP, by simpa only [j] using heq⟩
+
+theorem mdifferentiable_frickeF {N : ℕ} [NeZero N] (i : FrickeIdx N) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (frickeF N i.1) := by
+  rw [frickeF_eq]
+  exact (frickeFunction_modularity_package N periodPairOfTau hppT).2.2.1 i.1 i.2
+
+theorem isBoundedAtImInfty_frickeF_mul_discriminant {N : ℕ} [NeZero N] (i : FrickeIdx N) :
+    IsBoundedAtImInfty (frickeF N i.1 * ⇑CuspForm.discriminant) := by
+  rw [frickeF_eq, coe_cuspDisc]
+  exact (frickeFunction_modularity_package N periodPairOfTau hppT).2.2.2.1 i.1 i.2
+
+private lemma vecMulSL_mul (N : ℕ) (a : Fin 2 → ZMod N) (γ δ : SL(2, ℤ)) :
+    vecMulSL N (vecMulSL N a γ) δ = vecMulSL N a (γ * δ) := by
+  simp only [vecMulSL, Matrix.vecMul_vecMul]
+  congr 1
+  ext i k
+  simp [Matrix.map_apply, Matrix.mul_apply, Matrix.SpecialLinearGroup.coe_mul]
+
+private lemma vecMulSL_one (N : ℕ) (a : Fin 2 → ZMod N) : vecMulSL N a 1 = a := by
+  simp only [vecMulSL, Matrix.SpecialLinearGroup.coe_one,
+    Matrix.map_one ((↑) : ℤ → ZMod N) Int.cast_zero Int.cast_one, Matrix.vecMul_one]
+
+private lemma vecMulSL_zero (N : ℕ) (γ : SL(2, ℤ)) : vecMulSL N (0 : Fin 2 → ZMod N) γ = 0 := by
+  simp [vecMulSL]
+
+lemma vecMulSL_ne_zero {N : ℕ} {a : Fin 2 → ZMod N} (ha : a ≠ 0) (γ : SL(2, ℤ)) :
+    vecMulSL N a γ ≠ 0 := by
+  intro h0
+  apply ha
+  have h1 : vecMulSL N (vecMulSL N a γ) γ⁻¹ = a := by
+    rw [vecMulSL_mul, mul_inv_cancel, vecMulSL_one]
+  rw [← h1, h0, vecMulSL_zero]
+
+theorem frickeF_hperm {N : ℕ} [NeZero N] (γ : SL(2, ℤ)) :
+    ∃ σ : Equiv.Perm (FrickeIdx N), ∀ (i : FrickeIdx N) (τ : ℍ),
+      frickeF N i.1 (γ • τ) = frickeF N (σ i).1 τ := by
+  refine ⟨⟨fun i => ⟨vecMulSL N i.1 γ, vecMulSL_ne_zero i.2 γ⟩,
+          fun i => ⟨vecMulSL N i.1 γ⁻¹, vecMulSL_ne_zero i.2 γ⁻¹⟩, ?_, ?_⟩, ?_⟩
+  · intro i
+    apply Subtype.ext
+    simp only [vecMulSL_mul, mul_inv_cancel, vecMulSL_one]
+  · intro i
+    apply Subtype.ext
+    simp only [vecMulSL_mul, inv_mul_cancel, vecMulSL_one]
+  · intro i τ
+    have h1 := (frickeFunction_modularity_package N periodPairOfTau hppT).1 i.1 γ τ
+    rw [frickeF_eq, frickeF_eq]
+    exact h1
+
+section KPoleClosure
+
+private lemma ratCast_mem_K (K : IntermediateField ℚ ℂ) (q : ℚ) : (q : ℂ) ∈ K :=
+  eq_ratCast (algebraMap ℚ ℂ) q ▸ IntermediateField.algebraMap_mem K q
+
+private lemma hNposR (N : ℕ) [NeZero N] : (0 : ℝ) < N := by
+  exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+
+private lemma disc_hol : MDiff (⇑CuspForm.discriminant : ℍ → ℂ) := CuspForm.discriminant.holo'
+
+private lemma disc_bdd : IsBoundedAtImInfty (⇑CuspForm.discriminant : ℍ → ℂ) :=
+  (CuspFormClass.zero_at_infty CuspForm.discriminant).isBoundedAtImInfty
+
+private lemma disc_per1 :
+    Function.Periodic ((⇑CuspForm.discriminant : ℍ → ℂ) ∘ ofComplex) 1 := by
+  simpa using SlashInvariantFormClass.periodic_comp_ofComplex CuspForm.discriminant
+    one_mem_strictPeriods_SL
+
+private lemma E4_per1 :
+    Function.Periodic ((⇑ModularForm.E₄ : ℍ → ℂ) ∘ ofComplex) 1 := by
+  simpa using SlashInvariantFormClass.periodic_comp_ofComplex ModularForm.E₄
+    one_mem_strictPeriods_SL
+
+private lemma E4_hol : MDiff (⇑ModularForm.E₄ : ℍ → ℂ) := ModularForm.E₄.holo'
+
+private lemma E4_bdd : IsBoundedAtImInfty (⇑ModularForm.E₄ : ℍ → ℂ) :=
+  ModularFormClass.bdd_at_infty ModularForm.E₄
+
+private def NiceK (K : IntermediateField ℚ ℂ) (N : ℕ) (f : ℍ → ℂ) : Prop :=
+  Function.Periodic (f ∘ ofComplex) (N : ℂ) ∧ MDiff f ∧ IsBoundedAtImInfty f ∧
+    ∀ n, (qExpansion N f).coeff n ∈ K
+
+private lemma NiceK.analytic {K : IntermediateField ℚ ℂ} {N : ℕ} [NeZero N] {f : ℍ → ℂ}
+    (hf : NiceK K N f) : AnalyticAt ℂ (cuspFunction N f) 0 :=
+  analyticAt_cuspFunction_zero (hNposR N) (by exact_mod_cast hf.1) hf.2.1 hf.2.2.1
+
+private lemma perN_of_per1 {f : ℍ → ℂ} (hp : Function.Periodic (f ∘ ofComplex) 1) (N : ℕ) :
+    Function.Periodic (f ∘ ofComplex) (N : ℂ) := by
+  simpa using hp.nat_mul N
+
+private lemma NiceK.mul {K : IntermediateField ℚ ℂ} {N : ℕ} [NeZero N] {f g : ℍ → ℂ}
+    (hf : NiceK K N f) (hg : NiceK K N g) : NiceK K N (f * g) := by
+  refine ⟨hf.1.mul hg.1, hf.2.1.mul hg.2.1, hf.2.2.1.mul hg.2.2.1, fun n => ?_⟩
+  rw [qExpansion_mul hf.analytic hg.analytic, PowerSeries.coeff_mul]
+  exact sum_mem fun p _ => mul_mem (hf.2.2.2 p.1) (hg.2.2.2 p.2)
+
+private lemma NiceK.pow {K : IntermediateField ℚ ℂ} {N : ℕ} [NeZero N] {f : ℍ → ℂ}
+    (hf : NiceK K N f) : ∀ k : ℕ, k ≠ 0 → NiceK K N (f ^ k)
+  | 1, _ => by simpa using hf
+  | (k + 2), _ => by
+      rw [pow_succ]
+      exact (NiceK.pow hf (k + 1) k.succ_ne_zero).mul hf
+
+private lemma NiceK.add {K : IntermediateField ℚ ℂ} {N : ℕ} [NeZero N] {f g : ℍ → ℂ}
+    (hf : NiceK K N f) (hg : NiceK K N g) : NiceK K N (f + g) := by
+  refine ⟨hf.1.add hg.1, hf.2.1.add hg.2.1, hf.2.2.1.add hg.2.2.1, fun n => ?_⟩
+  rw [qExpansion_add hf.analytic hg.analytic, map_add]
+  exact add_mem (hf.2.2.2 n) (hg.2.2.2 n)
+
+private lemma NiceK.disc {K : IntermediateField ℚ ℂ} {N : ℕ} [NeZero N] :
+    NiceK K N (⇑CuspForm.discriminant : ℍ → ℂ) := by
+  refine ⟨perN_of_per1 disc_per1 N, disc_hol, disc_bdd, fun n => ?_⟩
+  have hd := (weierstrassP_torsion_qExpansion_package N (NeZero.ne N) periodPairOfTau
+      hppT).2.2.2.1 (⇑CuspForm.discriminant : ℍ → ℂ) (by simpa using disc_per1) disc_hol disc_bdd n
+  rw [hd]
+  split_ifs
+  · obtain ⟨q, hq⟩ := (weierstrassP_torsion_qExpansion_package N (NeZero.ne N) periodPairOfTau
+        hppT).2.2.2.2.2.2 (n / N)
+    rw [show (⇑CuspForm.discriminant : ℍ → ℂ) = (ModularForm.discriminant : ℍ → ℂ) from
+      coe_cuspDisc, hq]
+    exact ratCast_mem_K K q
+  · exact zero_mem K
+
+private lemma NiceK.E4 {K : IntermediateField ℚ ℂ} {N : ℕ} [NeZero N] :
+    NiceK K N (⇑ModularForm.E₄ : ℍ → ℂ) := by
+  refine ⟨perN_of_per1 E4_per1 N, E4_hol, E4_bdd, fun n => ?_⟩
+  have hd := (weierstrassP_torsion_qExpansion_package N (NeZero.ne N) periodPairOfTau
+      hppT).2.2.2.1 (⇑ModularForm.E₄ : ℍ → ℂ) (by simpa using E4_per1) E4_hol E4_bdd n
+  rw [hd]
+  split_ifs
+  · obtain ⟨q, hq⟩ := (weierstrassP_torsion_qExpansion_package N (NeZero.ne N) periodPairOfTau
+        hppT).2.2.2.2.1 (n / N)
+    rw [hq]
+    exact ratCast_mem_K K q
+  · exact zero_mem K
+
+private lemma cuspFunction_const (N : ℕ) (c : ℂ) :
+    cuspFunction N (fun _ : ℍ => c) = fun _ => c := by
+  funext q
+  rcases eq_or_ne q 0 with rfl | hq
+  · change Function.Periodic.cuspFunction N ((fun _ : ℍ => c) ∘ ofComplex) 0 = c
+    rw [Function.Periodic.cuspFunction_zero_eq_limUnder_nhds_ne]
+    refine Filter.Tendsto.limUnder_eq ?_
+    refine Filter.Tendsto.congr' ?_ (tendsto_const_nhds :
+      Filter.Tendsto (fun _ : ℂ => (c : ℂ)) (nhdsWithin (0 : ℂ) {(0 : ℂ)}ᶜ) (nhds (c : ℂ)))
+    filter_upwards [self_mem_nhdsWithin] with q hq
+    exact (Function.Periodic.cuspFunction_eq_of_nonzero (N : ℝ)
+      ((fun _ : ℍ => (c : ℂ)) ∘ ofComplex) hq).symm
+  · change Function.Periodic.cuspFunction N ((fun _ : ℍ => c) ∘ ofComplex) q = c
+    rw [Function.Periodic.cuspFunction_eq_of_nonzero _ _ hq]
+    rfl
+
+private lemma NiceK.const {K : IntermediateField ℚ ℂ} {N : ℕ} [NeZero N] (c : ↥K) :
+    NiceK K N (fun _ : ℍ => (c : ℂ)) := by
+  refine ⟨fun x => rfl, ?_, ?_, fun n => ?_⟩
+  · exact mdifferentiable_const
+  · exact Filter.const_boundedAtFilter _ _
+  · have hq : qExpansion N (fun _ : ℍ => (c : ℂ)) = PowerSeries.C (c : ℂ) := by
+      ext m
+      simp only [qExpansion_coeff, cuspFunction_const, iteratedDeriv_const, PowerSeries.coeff_C]
+      rcases eq_or_ne m 0 with rfl | hm
+      · simp
+      · simp [hm]
+    rw [hq]
+    rcases eq_or_ne n 0 with rfl | hn
+    · simp
+    · simp [PowerSeries.coeff_C, hn]
+
+private lemma kPoleAt_of_niceK {K : IntermediateField ℚ ℂ} {N : ℕ} [NeZero N] {f : ℍ → ℂ} {m : ℕ}
+    (h : NiceK K N (f * ⇑CuspForm.discriminant ^ m)) : KPoleAt K N m f :=
+  ⟨by exact_mod_cast h.1, h.2.2.1, h.2.2.2⟩
+
+private lemma niceK_mul_disc_pow {K : IntermediateField ℚ ℂ} {N : ℕ} [NeZero N] {f : ℍ → ℂ} {m : ℕ}
+    (hmd : MDiff f) (hf : KPoleAt K N m f) : NiceK K N (f * ⇑CuspForm.discriminant ^ m) :=
+  ⟨by exact_mod_cast hf.1, hmd.mul (disc_hol.pow m), hf.2.1, hf.2.2⟩
+
+private lemma kPole_const {K : IntermediateField ℚ ℂ} {N : ℕ} [NeZero N] (c : ↥K) :
+    KPole K N (algebraMap ↥K (ℍ → ℂ) c) := by
+  have hc : algebraMap ↥K (ℍ → ℂ) c = fun _ : ℍ => (c : ℂ) := rfl
+  rw [hc]
+  refine ⟨mdifferentiable_const, 0, kPoleAt_of_niceK ?_⟩
+  simpa using NiceK.const c
+
+private lemma kPole_add {K : IntermediateField ℚ ℂ} {N : ℕ} [NeZero N] {f g : ℍ → ℂ}
+    (hf : KPole K N f) (hg : KPole K N g) : KPole K N (f + g) := by
+  obtain ⟨hfm, mf, hfa⟩ := hf
+  obtain ⟨hgm, mg, hga⟩ := hg
+  have hf' : NiceK K N (f * ⇑CuspForm.discriminant ^ (mf + mg)) := by
+    have : f * ⇑CuspForm.discriminant ^ (mf + mg)
+        = (f * ⇑CuspForm.discriminant ^ mf) * ⇑CuspForm.discriminant ^ mg := by
+      rw [mul_assoc, ← pow_add]
+    rcases Nat.eq_zero_or_pos mg with rfl | hmg
+    · simpa using niceK_mul_disc_pow hfm hfa
+    · rw [this]
+      exact (niceK_mul_disc_pow hfm hfa).mul (NiceK.disc.pow mg hmg.ne')
+  have hg' : NiceK K N (g * ⇑CuspForm.discriminant ^ (mf + mg)) := by
+    have : g * ⇑CuspForm.discriminant ^ (mf + mg)
+        = (g * ⇑CuspForm.discriminant ^ mg) * ⇑CuspForm.discriminant ^ mf := by
+      rw [mul_assoc, ← pow_add, Nat.add_comm]
+    rcases Nat.eq_zero_or_pos mf with rfl | hmf
+    · simpa using niceK_mul_disc_pow hgm hga
+    · rw [this]
+      exact (niceK_mul_disc_pow hgm hga).mul (NiceK.disc.pow mf hmf.ne')
+  refine ⟨hfm.add hgm, mf + mg, kPoleAt_of_niceK ?_⟩
+  have : (f + g) * ⇑CuspForm.discriminant ^ (mf + mg)
+      = f * ⇑CuspForm.discriminant ^ (mf + mg) + g * ⇑CuspForm.discriminant ^ (mf + mg) :=
+    add_mul f g _
+  rw [this]
+  exact hf'.add hg'
+
+private lemma kPole_mul {K : IntermediateField ℚ ℂ} {N : ℕ} [NeZero N] {f g : ℍ → ℂ}
+    (hf : KPole K N f) (hg : KPole K N g) : KPole K N (f * g) := by
+  obtain ⟨hfm, mf, hfa⟩ := hf
+  obtain ⟨hgm, mg, hga⟩ := hg
+  refine ⟨hfm.mul hgm, mf + mg, kPoleAt_of_niceK ?_⟩
+  have : (f * g) * ⇑CuspForm.discriminant ^ (mf + mg)
+      = (f * ⇑CuspForm.discriminant ^ mf) * (g * ⇑CuspForm.discriminant ^ mg) := by
+    rw [pow_add]; ring
+  rw [this]
+  exact (niceK_mul_disc_pow hfm hfa).mul (niceK_mul_disc_pow hgm hga)
+
+theorem kPole_of_mem_adjoin {K : IntermediateField ℚ ℂ} [NeZero N] {S : Set (ℍ → ℂ)}
+    (hS : ∀ f ∈ S, KPole K N f) {a : ℍ → ℂ} (ha : a ∈ Algebra.adjoin ↥K S) : KPole K N a := by
+  induction ha using Algebra.adjoin_induction with
+  | mem f hf => exact hS f hf
+  | algebraMap c => exact kPole_const c
+  | add f g _ _ ihf ihg => exact kPole_add ihf ihg
+  | mul f g _ _ ihf ihg => exact kPole_mul ihf ihg
+
+lemma kPole_j (K : IntermediateField ℚ ℂ) [NeZero N] : KPole K N j := by
+  have hmd : MDiff j := by
+    intro τ
+    exact (((E4_hol τ).pow 3).div (disc_hol τ) (ModularForm.discriminant_ne_zero τ))
+  refine ⟨hmd, 1, kPoleAt_of_niceK ?_⟩
+  have hjd : j * ⇑CuspForm.discriminant ^ 1 = (⇑ModularForm.E₄ : ℍ → ℂ) ^ 3 := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply, pow_one, j, coe_cuspDisc]
+    field_simp [ModularForm.discriminant_ne_zero τ]
+  rw [hjd]
+  exact NiceK.E4.pow 3 (by norm_num)
+
+lemma kPole_frickeF {K : IntermediateField ℚ ℂ} [NeZero N] (hK : kN N ≤ K) (i : FrickeIdx N) :
+    KPole K N (frickeF N i.1) := by
+  have pkg := frickeFunction_modularity_package N periodPairOfTau hppT
+  have hmd : MDiff (frickeF N i.1) := mdifferentiable_frickeF i
+  refine ⟨hmd, 1, ?_, ?_, ?_⟩
+  · have hper := (pkg.2.2.2.2.1 i.1 i.2).1
+    rw [frickeF_eq, coe_cuspDisc]
+    simpa [pow_one] using hper
+  · have hbd := pkg.2.2.2.1 i.1 i.2
+    rw [frickeF_eq, coe_cuspDisc]
+    simpa [pow_one] using hbd
+  · intro n
+    have hco := (pkg.2.2.2.2.1 i.1 i.2).2 n
+    rw [frickeF_eq, coe_cuspDisc]
+    refine hK ?_
+    simpa [pow_one, kN, zetaN] using hco
+
+end KPoleClosure
+
+end R4bFloor
+
+section B6Engine
+
+p2m_open "UpperHalfPlane ModularForm SlashInvariantForm ModularFormClass CuspForm \
+  ModularForm.CuspForm Polynomial Real.Polynomial"
+open scoped MatrixGroups Manifold
+
+variable {I : Type*} [Fintype I] (h : I → ℍ → ℂ) (m : ℕ)
+
+def orbitCoeff (k : ℕ) : ℍ → ℂ := fun τ => (∏ i, (X - C (h i τ))).coeff k
+
+lemma coeff_X_sub_C_mul (a : ℂ) (p : Polynomial ℂ) (k : ℕ) :
+    ((X - C a) * p).coeff k = (if k = 0 then 0 else p.coeff (k - 1)) - a * p.coeff k := by
+  rw [sub_mul, Polynomial.coeff_sub, Polynomial.coeff_C_mul]
+  congr 1
+  cases k with
+  | zero => simp [Polynomial.mul_coeff_zero]
+  | succ k' => simp [Polynomial.coeff_X_mul]
+
+theorem orbitCoeff_slash_invariant
+    (hperm : ∀ γ : SL(2, ℤ), ∃ σ : Equiv.Perm I, ∀ i τ, h i (γ • τ) = h (σ i) τ)
+    (k : ℕ) (γ : SL(2, ℤ)) : orbitCoeff h k ∣[(0 : ℤ)] γ = orbitCoeff h k := by
+  obtain ⟨σ, hσ⟩ := hperm γ
+  funext τ
+  simp only [SL_slash_apply, neg_zero, zpow_zero, mul_one]
+  change (∏ i, (X - C (h i (γ • τ)))).coeff k = (∏ i, (X - C (h i τ))).coeff k
+  congr 2
+  calc ∏ i, (X - C (h i (γ • τ)))
+    _ = ∏ i, (X - C (h (σ i) τ)) := by
+      refine Finset.prod_congr rfl fun i _ => ?_
+      rw [hσ i τ]
+    _ = ∏ i, (X - C (h i τ)) := Equiv.prod_comp σ (fun i' => X - C (h i' τ))
+
+end B6Engine
+
+section B6Ring
+
+p2m_open "UpperHalfPlane ModularForm SlashInvariantForm ModularFormClass CuspForm \
+  ModularForm.CuspForm Polynomial Real.Polynomial Filter"
+open scoped MatrixGroups Manifold
+
+def PoleBounded (f : ℍ → ℂ) : Prop :=
+  MDiff f ∧ ∃ m : ℕ, IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m)
+
+lemma poleBounded_j : PoleBounded j := by
+  constructor
+  · exact (ModularForm.E₄.holo'.pow 3).div CuspForm.discriminant.holo'
+      ModularForm.discriminant_ne_zero
+  · refine ⟨1, ?_⟩
+    have hshape : (j * ⇑CuspForm.discriminant ^ 1 : ℍ → ℂ) = ⇑ModularForm.E₄ ^ 3 := by
+      funext τ
+      simp only [Pi.mul_apply, Pi.pow_apply, pow_one, j]
+      rw [congrFun CuspForm.coe_discriminant τ]
+      exact div_mul_cancel₀ _ (ModularForm.discriminant_ne_zero τ)
+    rw [hshape]
+    have h4 : IsBoundedAtImInfty (⇑ModularForm.E₄ : ℍ → ℂ) := ModularFormClass.bdd_at_infty _
+    have hpow : (⇑ModularForm.E₄ ^ 3 : ℍ → ℂ) =
+        ⇑ModularForm.E₄ * (⇑ModularForm.E₄ * ⇑ModularForm.E₄) := by
+      funext τ
+      simp only [Pi.pow_apply, Pi.mul_apply]
+      ring
+    rw [hpow]
+    exact h4.mul (h4.mul h4)
+
+lemma poleBounded_frickeF {N : ℕ} [NeZero N] (i : FrickeIdx N) :
+    PoleBounded (frickeF N i.1) := by
+  refine ⟨mdifferentiable_frickeF i, 1, ?_⟩
+  have hshape : (frickeF N i.1 * ⇑CuspForm.discriminant ^ 1 : ℍ → ℂ) =
+      frickeF N i.1 * ⇑CuspForm.discriminant := by
+    funext τ
+    simp
+  rw [hshape]
+  exact isBoundedAtImInfty_frickeF_mul_discriminant i
+
+end B6Ring
+
+section LevelRingK
+
+p2m_open "UpperHalfPlane ModularForm CuspForm ModularForm.CuspForm Polynomial Real.Polynomial"
+open scoped MatrixGroups Manifold
+
+variable {N : ℕ}
+
+noncomputable def levelRingK (K : IntermediateField ℚ ℂ) (N : ℕ) : Subalgebra ↥K (ℍ → ℂ) :=
+  Algebra.adjoin ↥K (levelGen N)
+
+lemma frickeF_mem_levelRingK {K : IntermediateField ℚ ℂ} [NeZero N] (i : FrickeIdx N) :
+    frickeF N i.1 ∈ levelRingK K N :=
+  Algebra.subset_adjoin (Set.mem_insert_iff.mpr (Or.inr ⟨i, rfl⟩))
+
+theorem kPole_of_mem_levelRingK {K : IntermediateField ℚ ℂ} [NeZero N] (hK : kN N ≤ K)
+    {f : ℍ → ℂ} (hf : f ∈ levelRingK K N) : KPole K N f :=
+  kPole_of_mem_adjoin (fun g hg => by
+    rcases hg with rfl | ⟨i, rfl⟩
+    · exact kPole_j K
+    · exact kPole_frickeF hK i) hf
+
+end LevelRingK
+
+section B6InstanceK
+
+p2m_open "UpperHalfPlane ModularForm CuspForm ModularForm.CuspForm Polynomial Real.Polynomial"
+open scoped MatrixGroups Manifold
+
+variable {N : ℕ}
+
+lemma orbitCoeffOn_frickeF_mem_levelRingK [NeZero N] (s : Finset (FrickeIdx N)) (k : ℕ) :
+    (fun τ : ℍ => (∏ i ∈ s, (X - C (frickeF N i.1 τ))).coeff k) ∈ levelRingK (kN N) N := by
+  induction s using Finset.cons_induction generalizing k with
+  | empty =>
+    simp only [Finset.prod_empty, Polynomial.coeff_one]
+    cases k with
+    | zero => exact one_mem (levelRingK (kN N) N)
+    | succ k' => exact zero_mem (levelRingK (kN N) N)
+  | cons a s ha ih =>
+    cases k with
+    | zero =>
+      have hrw : (fun τ : ℍ =>
+          (∏ i ∈ Finset.cons a s ha, (X - C (frickeF N i.1 τ))).coeff 0) =
+          -(frickeF N a.1 * fun τ : ℍ => (∏ i ∈ s, (X - C (frickeF N i.1 τ))).coeff 0) := by
+        funext τ
+        simp only [Finset.prod_cons, coeff_X_sub_C_mul, ite_true, Pi.neg_apply, Pi.mul_apply]
+        ring
+      rw [hrw]
+      exact neg_mem (mul_mem (frickeF_mem_levelRingK a) (ih 0))
+    | succ k' =>
+      have hrw : (fun τ : ℍ =>
+          (∏ i ∈ Finset.cons a s ha, (X - C (frickeF N i.1 τ))).coeff (k' + 1)) =
+          ((fun τ : ℍ => (∏ i ∈ s, (X - C (frickeF N i.1 τ))).coeff k') -
+            frickeF N a.1 * fun τ : ℍ =>
+              (∏ i ∈ s, (X - C (frickeF N i.1 τ))).coeff (k' + 1)) := by
+        funext τ
+        simp only [Finset.prod_cons, coeff_X_sub_C_mul, ite_eq_right (Nat.succ_ne_zero k'),
+          Nat.add_sub_cancel, Pi.sub_apply, Pi.mul_apply]
+      rw [hrw]
+      exact sub_mem (ih k') (mul_mem (frickeF_mem_levelRingK a) (ih (k' + 1)))
+
+theorem frickeF_integral_over_j_mem_kN (N : ℕ) [NeZero N] :
+    ∃ P : ℕ → Polynomial ℂ,
+      (∀ k i, (P k).coeff i ∈ kN N) ∧
+      ∀ (i : FrickeIdx N) (τ : ℍ),
+        frickeF N i.1 τ ^ Fintype.card (FrickeIdx N) +
+          ∑ k ∈ Finset.range (Fintype.card (FrickeIdx N)),
+            Polynomial.eval (j τ) (P k) * frickeF N i.1 τ ^ k = 0 := by
+  have hdesc : ∀ k : ℕ, ∃ P : Polynomial ℂ, (∀ i, P.coeff i ∈ kN N) ∧
+      orbitCoeff (fun i : FrickeIdx N => frickeF N i.1) k =
+        fun τ => Polynomial.eval (j τ) P := by
+    intro k
+    have hmem : orbitCoeff (fun i : FrickeIdx N => frickeF N i.1) k ∈ levelRingK (kN N) N := by
+      have h1 := orbitCoeffOn_frickeF_mem_levelRingK (N := N) Finset.univ k
+      simp only [ne_eq] at h1
+      exact h1
+    exact kPole_invariant_eq_polynomial_j_mem (kPole_of_mem_levelRingK le_rfl hmem)
+      (orbitCoeff_slash_invariant (fun i : FrickeIdx N => frickeF N i.1)
+        (fun γ => frickeF_hperm γ) k)
+  choose P hPmem hP using hdesc
+  refine ⟨P, hPmem, fun i τ => ?_⟩
+  set Q : Polynomial ℂ := ∏ i' : FrickeIdx N, (X - C (frickeF N i'.1 τ)) with hQ
+  have hQmonic : Q.Monic := monic_prod_of_monic _ _ fun i' _ => monic_X_sub_C _
+  have hQdeg : Q.natDegree = Fintype.card (FrickeIdx N) := by
+    rw [hQ, natDegree_prod_of_monic _ _ (fun i' _ => monic_X_sub_C _)]
+    simp
+  have hroot : Polynomial.eval (frickeF N i.1 τ) Q = 0 := by
+    rw [hQ, Polynomial.eval_prod]
+    exact Finset.prod_eq_zero (Finset.mem_univ i) (by simp)
+  have hexp := Polynomial.eval_eq_sum_range' (n := Fintype.card (FrickeIdx N) + 1)
+    (by rw [hQdeg]; exact Nat.lt_succ_self _) (frickeF N i.1 τ) (p := Q)
+  rw [Finset.sum_range_succ] at hexp
+  have hlead : Q.coeff (Fintype.card (FrickeIdx N)) = 1 := by
+    have h1 := hQmonic.coeff_natDegree
+    rwa [hQdeg] at h1
+  have hcoeffs : ∀ k, Q.coeff k = Polynomial.eval (j τ) (P k) := by
+    intro k
+    have h1 := congrFun (hP k) τ
+    simpa [orbitCoeff, hQ] using h1
+  rw [hroot.symm, hexp, hlead, one_mul, add_comm]
+  congr 1
+  exact Finset.sum_congr rfl fun k _ => by rw [hcoeffs k]
+
+end B6InstanceK
+
+section R4bBridge
+
+p2m_open "WLight P2MW.S_WLight_frickeFunction_orbit_package.WLight"
+p2m_open "UpperHalfPlane~I"
+open scoped Manifold MatrixGroups ModularForm
+
+private lemma periodPair_ext'' {L₁ L₂ : PeriodPair} (h₁ : L₁.ω₁ = L₂.ω₁)
+    (h₂ : L₁.ω₂ = L₂.ω₂) : L₁ = L₂ := by
+  cases L₁; cases L₂; simp_all
+
+end R4bBridge
+
+end WLight
+
+p2m_open "UpperHalfPlane~I" in
+open scoped UpperHalfPlane Manifold MatrixGroups ModularForm in
+open _root_.WLight _root_.P2MW.S_WLight_frickeFunction_orbit_package.WLight in
+theorem solution
+    (N : ℕ) [NeZero N]
+    (L : ℍ → PeriodPair) (hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), W v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (jf : ℍ → ℂ)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) :
+    (MDifferentiable 𝓘(ℂ) 𝓘(ℂ) jf ∧
+      ∃ m : ℕ, IsBoundedAtImInfty (jf * ModularForm.discriminant ^ m)) ∧
+    (∀ v : Fin 2 → ZMod N, v ≠ 0 → MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fricke v) ∧
+      ∃ m : ℕ, IsBoundedAtImInfty (fricke v * ModularForm.discriminant ^ m)) ∧
+    (∃ P : ℕ → Polynomial ℂ,
+      (∀ k i, (P k).coeff i ∈
+        IntermediateField.adjoin ℚ {Complex.exp (2 * (Real.pi : ℂ) * Complex.I / N)}) ∧
+      ∀ v : Fin 2 → ZMod N, v ≠ 0 → ∀ τ : ℍ,
+        fricke v τ ^ (N ^ 2 - 1) + ∑ k ∈ Finset.range (N ^ 2 - 1),
+          (P k).eval (jf τ) * fricke v τ ^ k = 0) := by
+  have hLpp : ∀ τ : ℍ, L τ = periodPairOfTau τ := fun τ =>
+    periodPair_ext'' ((hL τ).1.trans (periodPairOfTau_ω₁ τ).symm)
+      ((hL τ).2.trans (periodPairOfTau_ω₂ τ).symm)
+  have hfr : ∀ v : Fin 2 → ZMod N, fricke v = frickeF N v := by
+    intro v
+    funext τ
+    rw [hfricke v τ, hW v τ, hLpp τ]
+    with_unfolding_all rfl
+  have hjeq : jf = j := by
+    funext τ
+    rw [hjf τ]
+    rfl
+  have hcard : Fintype.card (FrickeIdx N) = N ^ 2 - 1 := by
+    have h1 : Fintype.card (Fin 2 → ZMod N) = N ^ 2 := by
+      rw [Fintype.card_fun, ZMod.card, Fintype.card_fin]
+    have h2 : Fintype.card {a : Fin 2 → ZMod N // a = 0} = 1 := Fintype.card_subtype_eq 0
+    have h3 := Fintype.card_subtype_compl (fun a : Fin 2 → ZMod N => a = 0)
+    rw [h1, h2] at h3
+    exact h3
+  refine ⟨?_, ?_, ?_⟩
+  · obtain ⟨h1, m, h2⟩ := poleBounded_j
+    refine ⟨by rw [hjeq]; exact h1, m, ?_⟩
+    rw [hjeq, ← CuspForm.coe_discriminant]
+    exact h2
+  · intro v hv
+    obtain ⟨h1, m, h2⟩ := poleBounded_frickeF (⟨v, hv⟩ : FrickeIdx N)
+    refine ⟨by rw [hfr]; exact h1, m, ?_⟩
+    rw [hfr, ← CuspForm.coe_discriminant]
+    exact h2
+  · obtain ⟨P, hPmem, hPrel⟩ := frickeF_integral_over_j_mem_kN N
+    refine ⟨P, fun k i => hPmem k i, fun v hv τ => ?_⟩
+    have h := hPrel ⟨v, hv⟩ τ
+    rw [hfr v, hjeq, ← hcard]
+    exact h
+
+end
+end S_WLight_frickeFunction_orbit_package
+end P2MW
+export P2MW.S_WLight_frickeFunction_orbit_package (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Complex Real UpperHalfPlane
+open scoped Manifold MatrixGroups ModularForm
+theorem WLight.frickeFunction_orbit_package
+    (N : ℕ) [NeZero N]
+    (L : ℍ → PeriodPair) (hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), W v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (jf : ℍ → ℂ)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) :
+    (MDifferentiable 𝓘(ℂ) 𝓘(ℂ) jf ∧
+      ∃ m : ℕ, IsBoundedAtImInfty (jf * ModularForm.discriminant ^ m)) ∧
+    (∀ v : Fin 2 → ZMod N, v ≠ 0 → MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fricke v) ∧
+      ∃ m : ℕ, IsBoundedAtImInfty (fricke v * ModularForm.discriminant ^ m)) ∧
+    (∃ P : ℕ → Polynomial ℂ,
+      (∀ k i, (P k).coeff i ∈
+        IntermediateField.adjoin ℚ {Complex.exp (2 * (Real.pi : ℂ) * Complex.I / N)}) ∧
+      ∀ v : Fin 2 → ZMod N, v ≠ 0 → ∀ τ : ℍ,
+        fricke v τ ^ (N ^ 2 - 1) + ∑ k ∈ Finset.range (N ^ 2 - 1),
+          (P k).eval (jf τ) * fricke v τ ^ k = 0) :=
+  solution N L hL W hW fricke hfricke jf hjf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_levelN_structure_package.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_levelN_structure_package.lean
new file mode 100644
index 0000000000..58a85c9f0f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_levelN_structure_package.lean
@@ -0,0 +1,1328 @@
+/-
+Based on Prove2Me node WLight.levelN_structure_package
+(61cde296-d5df-51a1-8a69-835ee824a887) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ca744a75-f111-5c76-bb4b-4e0e37418809
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.SpecialFunctions.Elliptic.Weierstrass
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import Mathlib.Geometry.Manifold.Notation
+
+import Mathlib.NumberTheory.ModularForms.EisensteinSeries.QExpansion
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+import Mathlib.RingTheory.DedekindDomain.IntegralClosure
+import Mathlib.RingTheory.DedekindDomain.Ideal.Lemmas
+import Mathlib.RingTheory.Unramified.Field
+import Mathlib.Analysis.Meromorphic.NormalForm
+import Mathlib.RingTheory.Discriminant
+import Mathlib.RingTheory.Adjoin.PowerBasis
+import Mathlib.RingTheory.Adjoin.Polynomial.Transcendental
+import Mathlib.FieldTheory.PrimitiveElement
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.LinearAlgebra.Lagrange
+import Mathlib.FieldTheory.LinearDisjoint
+import Mathlib.FieldTheory.Galois.Infinite
+import Mathlib.RingTheory.AlgebraicIndependent.TranscendenceBasis
+import Mathlib.RingTheory.AlgebraicIndependent.AlgebraicClosure
+import Mathlib.RingTheory.AlgebraicIndependent.Adjoin
+import Mathlib.RingTheory.Polynomial.RationalRoot
+import Mathlib.Analysis.Analytic.Order
+import Mathlib.RingTheory.PowerSeries.Order
+import Mathlib.RingTheory.Polynomial.IsIntegral
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_levelOne_hauptmodul_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_modularity_package
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WLight_frickeFunction_orbit_package
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Fixer of the Fricke functions and structure of A_N
+
+Theorem statement: `WLight.levelN_structure_package` (`61cde296-d5df-51a1-8a69-835ee824a887`), by
+Claude, 2026-09-05.
+
+Proof: submission `ca744a75-f111-5c76-bb4b-4e0e37418809`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $N$ be a positive natural number, and let $L$ assign to each $\tau$ in the upper half-plane
+$\mathbb{H}$ a period pair with $\omega_1 = \tau$ and $\omega_2 = 1$. Let $W$ be a family of
+functions indexed by $v \colon \mathrm{Fin}\,2 \to \mathbb{Z}/N\mathbb{Z}$ with $W_v(\tau) = (2\pi
+i)^{-2}\,\wp_{L\tau}\bigl((\tilde v_0 \tau + \tilde v_1)/N\bigr)$, where $\tilde v_i$ is the
+representative of $v_i$ in $[0,N)$; let $\mathrm{fricke}_v(\tau) =
+-\bigl(E_4(\tau)E_6(\tau)/\Delta(\tau)\bigr)/2592 \cdot W_v(\tau)$, and let $jf(\tau) =
+E_4(\tau)^3/\Delta(\tau)$, each pinned to these formulas by hypothesis. Put $A_N$ for the
+$\mathbb{C}$-subalgebra of $\mathbb{H} \to \mathbb{C}$ generated by $jf$ together with all
+$\mathrm{fricke}_v$ with $v \neq 0$, and let $\gamma \in \mathrm{SL}_2(\mathbb{Z})$ act on row
+vectors $v$ by $v \mapsto v\bar\gamma$, reduction mod $N$. Six assertions are made. First, the set
+of $\gamma$ with $\mathrm{fricke}_{v\bar\gamma} = \mathrm{fricke}_v$ for all $v \neq 0$ is exactly
+$\{\gamma : \gamma \in \Gamma(N) \text{ or } -\gamma \in \Gamma(N)\}$. Second, if $a, b \in A_N$, $b
+\neq 0$, and $a \cdot (b \circ \gamma) = (a \circ \gamma) \cdot b$ for every $\gamma$, then there
+are polynomials $p, q$ over $\mathbb{C}$ with $q \neq 0$ and $a \cdot q(jf) = b \cdot p(jf)$. Third,
+each $\mathrm{fricke}_v$ with $v \neq 0$ satisfies a monic equation of some degree $d$ with
+coefficients polynomial in $jf$. Fourth, any polynomial vanishing at $jf(\tau)$ for all $\tau$ is
+zero. Fifth, every element of $A_N$ is holomorphic on $\mathbb{H}$. Sixth, $A_N$ has no zero
+divisors.
+
+This is the function-level form of the classical structure theory of the field of modular functions
+of level $N$ over $\mathbb{C}$: the Fricke functions are permuted by $\mathrm{SL}_2(\mathbb{Z})$
+through $\mathrm{SL}_2(\mathbb{Z})/\pm\Gamma(N)$, their invariant fractions are rational in $j$, and
+the algebra they generate is a holomorphic integral domain, integral over $\mathbb{C}[j]$ with $j$
+transcendental. It supports the later rationality and $q$-expansion statements for forms of level
+$N$, such as the description of the span of Fricke-rational products of $E_4$ and $E_6$ and the
+construction of algebra homomorphisms into Laurent series.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WLight_levelN_structure_package.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WLight_levelN_structure_package
+
+noncomputable section
+open Complex Real
+namespace WLight
+p2m_export "WLight" "levelOne_hauptmodul_package frickeFunction_modularity_package \
+  frickeFunction_orbit_package"
+p2m_open "WLight"
+
+section Floor
+open scoped UpperHalfPlane Manifold MatrixGroups ModularForm
+p2m_open "PeriodPair ModularForm CuspForm ModularForm.CuspForm"
+p2m_open "UpperHalfPlane~I"
+
+def j : ℍ → ℂ := fun z => E₄ z ^ 3 / ModularForm.discriminant z
+
+theorem j_surjective : Function.Surjective j :=
+  levelOne_hauptmodul_package.2.2.1
+
+def periodPairOfTau (τ : ℍ) : PeriodPair where
+  ω₁ := (τ : ℂ)
+  ω₂ := 1
+  indep := LinearIndependent.pair_iff.mpr fun s t hst ↦ by
+    have him : s * (τ : ℂ).im = 0 := by
+      have := congrArg Complex.im hst
+      simpa [Complex.add_im, Complex.smul_im, smul_eq_mul] using this
+    have hs : s = 0 :=
+      (mul_eq_zero.mp him).resolve_right (UpperHalfPlane.coe_im τ ▸ τ.im_ne_zero)
+    subst hs
+    simpa using hst
+
+@[scoped simp] lemma periodPairOfTau_ω₁ (τ : ℍ) : (periodPairOfTau τ).ω₁ = (τ : ℂ) := rfl
+@[scoped simp] lemma periodPairOfTau_ω₂ (τ : ℍ) : (periodPairOfTau τ).ω₂ = 1 := rfl
+
+def wpTorsion (N a₁ a₂ : ℕ) (τ : ℍ) : ℂ :=
+  PeriodPair.weierstrassP (periodPairOfTau τ) (((a₁ : ℂ) * τ + a₂) / N)
+
+def wpNorm (N a₁ a₂ : ℕ) (τ : ℍ) : ℂ := ((2 * π * I) ^ 2)⁻¹ * wpTorsion N a₁ a₂ τ
+
+section B6_fixedFrac
+
+variable {A : Type*} [CommRing A] {G : Type*} [Group G] [MulSemiringAction G A]
+
+lemma smul_prod_smul_eq [Fintype G] (v : A) (g₀ : G) : g₀ • (∏ g : G, g • v) = ∏ g : G, g • v := by
+  rw [show g₀ • (∏ g : G, g • v) = MulSemiringAction.toRingHom G A g₀ (∏ g : G, g • v) from rfl,
+    map_prod]
+  simp only [MulSemiringAction.toRingHom_apply, smul_smul]
+  exact Fintype.prod_equiv (Equiv.mulLeft g₀) _ _ fun g ↦ rfl
+
+variable [IsDomain A] {K : Type*} [Field K] [Algebra A K] [IsFractionRing A K]
+  [MulSemiringAction G K]
+
+theorem exists_fixed_div_of_fixed [Finite G]
+    (hcompat : ∀ (g : G) (a : A), g • algebraMap A K a = algebraMap A K (g • a))
+    (x : K) (hx : ∀ g : G, g • x = x) :
+    ∃ a b : A, (∀ g : G, g • a = a) ∧ (∀ g : G, g • b = b) ∧ algebraMap A K b ≠ 0 ∧
+      x * algebraMap A K b = algebraMap A K a := by
+  classical
+  let := Fintype.ofFinite G
+  obtain ⟨u, v, hv, rfl⟩ := IsFractionRing.div_surjective (A := A) x
+  have hv0 : v ≠ 0 := nonZeroDivisors.ne_zero hv
+  have hinj : Function.Injective (algebraMap A K) := IsFractionRing.injective A K
+  set b : A := ∏ g : G, g • v with hb
+  set a : A := u * ∏ g ∈ (Finset.univ : Finset G).erase 1, g • v with ha
+  have hbfix : ∀ g : G, g • b = b := fun g ↦ smul_prod_smul_eq v g
+  have hb0 : algebraMap A K b ≠ 0 := by
+    rw [map_ne_zero_iff _ hinj, hb]
+    exact Finset.prod_ne_zero_iff.mpr fun g _ ↦ (smul_ne_zero_iff_ne g).mpr hv0
+  have hxb : algebraMap A K u / algebraMap A K v * algebraMap A K b = algebraMap A K a := by
+    have hv0' : algebraMap A K v ≠ 0 := (map_ne_zero_iff _ hinj).mpr hv0
+    rw [hb, ← Finset.mul_prod_erase _ _ (Finset.mem_univ (1 : G)), one_smul, ha, map_mul,
+      map_mul]
+    field_simp
+  refine ⟨a, b, fun g ↦ ?_, hbfix, hb0, hxb⟩
+  apply hinj
+  rw [← hcompat, ← hxb, smul_mul', hx, hcompat, hbfix]
+
+end B6_fixedFrac
+
+def denomZ (γ : SL(2, ℤ)) (τ : ℂ) : ℂ := (γ 1 0 : ℤ) * τ + (γ 1 1 : ℤ)
+
+lemma denomZ_ne_zero (γ : SL(2, ℤ)) (τ : ℍ) : denomZ γ (τ : ℂ) ≠ 0 := by
+  intro h
+  have him : ((γ 1 0 : ℤ) : ℝ) * (τ : ℂ).im = 0 := by
+    have := congrArg Complex.im h
+    simp only [denomZ, Complex.add_im, Complex.mul_im, Complex.intCast_im, zero_mul,
+      Complex.intCast_re, add_zero, Complex.zero_im] at this
+    linarith
+  have hc0 : (γ 1 0 : ℤ) = 0 := by
+    rcases mul_eq_zero.mp him with h | h
+    · exact_mod_cast h
+    · exact absurd h (UpperHalfPlane.coe_im τ ▸ τ.im_ne_zero)
+  have hd0 : (γ 1 1 : ℤ) = 0 := by
+    have := h
+    rw [denomZ, hc0] at this
+    simpa using this
+  have hdet : γ 0 0 * γ 1 1 - γ 0 1 * γ 1 0 = 1 := by
+    have := γ.2; rwa [Matrix.det_fin_two] at this
+  rw [hc0, hd0] at hdet
+  simp at hdet
+
+def vecMulSL (N : ℕ) (a : Fin 2 → ZMod N) (γ : SL(2, ℤ)) : Fin 2 → ZMod N :=
+  Matrix.vecMul a ((γ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N))
+
+lemma vecMulSL_apply (N : ℕ) (a : Fin 2 → ZMod N) (γ : SL(2, ℤ)) (j : Fin 2) :
+    vecMulSL N a γ j = a 0 * (γ 0 j : ℤ) + a 1 * (γ 1 j : ℤ) := by
+  simp [vecMulSL, Matrix.vecMul, dotProduct, Fin.sum_univ_two, Matrix.map_apply]
+
+section B3_spelling2
+
+open scoped UpperHalfPlane Manifold MatrixGroups
+p2m_open "UpperHalfPlane~I"
+open Matrix.SpecialLinearGroup
+
+lemma denom_mapGL_eq_denomZ (γ : SL(2, ℤ)) (τ : ℍ) :
+    denom (mapGL ℝ γ) τ = denomZ γ τ := by
+  simp [denom, denomZ]
+
+def wpNormZ (N : ℕ) (a : Fin 2 → ZMod N) (τ : ℍ) : ℂ := wpNorm N (a 0).val (a 1).val τ
+
+def frickeF (N : ℕ) (a : Fin 2 → ZMod N) (τ : ℍ) : ℂ :=
+  -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * wpNormZ N a τ
+
+theorem r4a_package (N : ℕ) [NeZero N] :
+    (∀ (a : Fin 2 → ZMod N) (γ : SL(2, ℤ)) (τ : ℍ), (frickeF N) a (γ • τ) =
+        (frickeF N) (Matrix.vecMul a ((γ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N))) τ) ∧
+    (∀ a : Fin 2 → ZMod N, (frickeF N) (-a) = (frickeF N) a) ∧
+    (∀ a : Fin 2 → ZMod N, a ≠ 0 → MDifferentiable 𝓘(ℂ) 𝓘(ℂ) ((frickeF N) a)) ∧
+    (∀ a : Fin 2 → ZMod N, a ≠ 0 →
+      IsBoundedAtImInfty ((frickeF N) a * ModularForm.discriminant)) ∧
+    (∀ a : Fin 2 → ZMod N, a ≠ 0 →
+      Function.Periodic (((frickeF N) a * ModularForm.discriminant) ∘ ofComplex) N ∧
+      ∀ n : ℕ, (qExpansion N ((frickeF N) a * ModularForm.discriminant)).coeff n ∈
+        IntermediateField.adjoin ℚ {cexp (2 * π * I / N)}) ∧
+    (∀ a b : Fin 2 → ZMod N, a ≠ 0 → b ≠ 0 → (frickeF N) a = (frickeF N) b → b = a ∨ b = -a) ∧
+    (∀ a : Fin 2 → ZMod N, ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : ℍ,
+      (frickeF N) a (γ • τ) = (frickeF N) a τ) ∧
+    (∀ s : ℕ, s.Coprime N →
+      ∀ φ : ↑(IntermediateField.adjoin ℚ {cexp (2 * π * I / N)}) →+* ℂ,
+        (∀ z : ↑(IntermediateField.adjoin ℚ {cexp (2 * π * I / N)}),
+            (z : ℂ) = cexp (2 * π * I / N) → φ z = cexp (2 * π * I / N) ^ s) →
+        ∀ a : Fin 2 → ZMod N, a ≠ 0 →
+          ∀ (n : ℕ) (z : ↑(IntermediateField.adjoin ℚ {cexp (2 * π * I / N)})),
+            (z : ℂ) = (qExpansion N ((frickeF N) a * ModularForm.discriminant)).coeff n →
+            (qExpansion N ((frickeF N) ![a 0, (s : ZMod N) * a 1]
+              * ModularForm.discriminant)).coeff n = φ z) :=
+  frickeFunction_modularity_package N periodPairOfTau fun _ ↦ ⟨rfl, rfl⟩
+
+theorem r4b_package (N : ℕ) [NeZero N] :
+    (MDifferentiable 𝓘(ℂ) 𝓘(ℂ) j ∧
+      ∃ m : ℕ, IsBoundedAtImInfty (j * ModularForm.discriminant ^ m)) ∧
+    (∀ v : Fin 2 → ZMod N, v ≠ 0 → MDifferentiable 𝓘(ℂ) 𝓘(ℂ) ((frickeF N) v) ∧
+      ∃ m : ℕ, IsBoundedAtImInfty ((frickeF N) v * ModularForm.discriminant ^ m)) ∧
+    (∃ P : ℕ → Polynomial ℂ,
+      (∀ k i, (P k).coeff i ∈
+        IntermediateField.adjoin ℚ {Complex.exp (2 * (Real.pi : ℂ) * Complex.I / N)}) ∧
+      ∀ v : Fin 2 → ZMod N, v ≠ 0 → ∀ τ : ℍ,
+        (frickeF N) v τ ^ (N ^ 2 - 1) + ∑ k ∈ Finset.range (N ^ 2 - 1),
+          (P k).eval (j τ) * (frickeF N) v τ ^ k = 0) :=
+  frickeFunction_orbit_package N periodPairOfTau (fun _ ↦ ⟨rfl, rfl⟩) (wpNormZ N) (fun _ _ ↦ rfl)
+    (frickeF N) (fun _ _ ↦ rfl) j fun _ ↦ rfl
+
+theorem frickeF_slash {N : ℕ} [NeZero N] (a : Fin 2 → ZMod N) (γ : SL(2, ℤ)) (τ : ℍ) :
+    frickeF N a (γ • τ) = frickeF N (vecMulSL N a γ) τ :=
+  (r4a_package N).1 a γ τ
+
+theorem frickeF_invariant_Gamma {N : ℕ} [NeZero N] (a : Fin 2 → ZMod N) {γ : SL(2, ℤ)}
+    (hγ : γ ∈ CongruenceSubgroup.Gamma N) (τ : ℍ) : frickeF N a (γ • τ) = frickeF N a τ :=
+  (r4a_package N).2.2.2.2.2.2.1 a γ hγ τ
+
+lemma vecMulSL_mul (N : ℕ) (a : Fin 2 → ZMod N) (γ δ : SL(2, ℤ)) :
+    vecMulSL N a (γ * δ) = vecMulSL N (vecMulSL N a γ) δ := by
+  have hmap : ((γ * δ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N) =
+      (γ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N) *
+        (δ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N) := by
+    rw [Matrix.SpecialLinearGroup.coe_mul]
+    exact Matrix.map_mul (f := Int.castRingHom (ZMod N))
+  simp only [vecMulSL, hmap, Matrix.vecMul_vecMul]
+
+lemma vecMulSL_one (N : ℕ) (a : Fin 2 → ZMod N) : vecMulSL N a 1 = a := by
+  simp [vecMulSL]
+
+lemma vecMulSL_zero (N : ℕ) (γ : SL(2, ℤ)) : vecMulSL N 0 γ = 0 := by
+  funext j; simp [vecMulSL_apply]
+
+lemma vecMulSL_ne_zero {N : ℕ} {a : Fin 2 → ZMod N} (ha : a ≠ 0) (γ : SL(2, ℤ)) :
+    vecMulSL N a γ ≠ 0 := by
+  intro h
+  apply ha
+  have := congrArg (fun b ↦ vecMulSL N b γ⁻¹) h
+  simpa [← vecMulSL_mul, vecMulSL_one, vecMulSL_zero] using this
+
+abbrev FrickeIdx (N : ℕ) : Type := {a : Fin 2 → ZMod N // a ≠ 0}
+
+scoped instance (N : ℕ) [NeZero N] : Fintype (FrickeIdx N) := by unfold FrickeIdx; infer_instance
+
+theorem mdifferentiable_frickeF {N : ℕ} [NeZero N] (i : FrickeIdx N) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (frickeF N i.1) :=
+  (r4a_package N).2.2.1 i.1 i.2
+
+theorem frickeF_eq_imp {N : ℕ} [NeZero N] (a b : FrickeIdx N)
+    (h : frickeF N a.1 = frickeF N b.1) : b.1 = a.1 ∨ b.1 = -a.1 :=
+  (r4a_package N).2.2.2.2.2.1 a.1 b.1 a.2 b.2 h
+
+theorem mem_Gamma_or_neg_mem_of_vecMulSL {N : ℕ} [NeZero N] (γ : SL(2, ℤ))
+    (h : ∀ a : Fin 2 → ZMod N, a ≠ 0 → vecMulSL N a γ = a ∨ vecMulSL N a γ = -a) :
+    γ ∈ CongruenceSubgroup.Gamma N ∨ -γ ∈ CongruenceSubgroup.Gamma N := by
+  rcases Nat.lt_or_ge 1 N with hN | hN
+  · have : Fact (1 < N) := ⟨hN⟩
+    have h10 : (1 : ZMod N) ≠ 0 := one_ne_zero
+    have r1 := h ![1, 0] (fun e ↦ h10 (by simpa using congrFun e 0))
+    have r2 := h ![0, 1] (fun e ↦ h10 (by simpa using congrFun e 1))
+    have r3 := h ![1, 1] (fun e ↦ h10 (by simpa using congrFun e 0))
+    simp only [funext_iff, Fin.forall_fin_two, vecMulSL_apply, Matrix.cons_val_zero,
+      Matrix.cons_val_one, Matrix.cons_val_fin_one, one_mul, zero_mul, add_zero, zero_add,
+      Pi.neg_apply, neg_zero] at r1 r2 r3
+    have e01 : ((γ 0 1 : ℤ) : ZMod N) = 0 := by rcases r1 with ⟨_, e⟩ | ⟨_, e⟩ <;> exact e
+    have e10 : ((γ 1 0 : ℤ) : ZMod N) = 0 := by rcases r2 with ⟨e, _⟩ | ⟨e, _⟩ <;> exact e
+    have e0011 : ((γ 0 0 : ℤ) : ZMod N) = ((γ 1 1 : ℤ) : ZMod N) := by
+      rcases r3 with ⟨c1, c2⟩ | ⟨c1, c2⟩ <;>
+        (rw [e10, add_zero] at c1; rw [e01, zero_add] at c2; rw [c1, c2])
+    rw [CongruenceSubgroup.Gamma_mem, CongruenceSubgroup.Gamma_mem]
+    simp only [Matrix.SpecialLinearGroup.coe_neg, Matrix.neg_apply, Int.cast_neg, neg_eq_zero]
+    rcases r1 with ⟨a1, _⟩ | ⟨a1, _⟩
+    · left; exact ⟨a1, e01, e10, by rw [← e0011]; exact a1⟩
+    · right; exact ⟨by rw [a1, neg_neg], e01, e10, by rw [← e0011, a1, neg_neg]⟩
+  · have : N = 1 := by have := NeZero.ne N; omega
+    subst this
+    left
+    simp [CongruenceSubgroup.Gamma_one_top]
+
+theorem frickeF_faithful {N : ℕ} [NeZero N] (γ : SL(2, ℤ))
+    (h : ∀ i : FrickeIdx N, ∀ τ : ℍ, frickeF N i.1 (γ • τ) = frickeF N i.1 τ) :
+    γ ∈ CongruenceSubgroup.Gamma N ∨ -γ ∈ CongruenceSubgroup.Gamma N := by
+  refine mem_Gamma_or_neg_mem_of_vecMulSL γ fun a ha ↦ ?_
+  have hfun : frickeF N a = frickeF N (vecMulSL N a γ) := by
+    funext τ; rw [← frickeF_slash, h ⟨a, ha⟩ τ]
+  rcases frickeF_eq_imp ⟨a, ha⟩ ⟨vecMulSL N a γ, vecMulSL_ne_zero ha γ⟩ hfun with e | e
+  · exact Or.inl e
+  · exact Or.inr e
+
+end B3_spelling2
+
+section B6Instance
+
+p2m_open "UpperHalfPlane ModularForm CuspForm ModularForm.CuspForm Polynomial Real.Polynomial"
+open scoped MatrixGroups Manifold
+
+theorem frickeF_integral_over_j (N : ℕ) [NeZero N] :
+    ∃ P : ℕ → Polynomial ℂ,
+      ∀ (i : FrickeIdx N) (τ : ℍ),
+        frickeF N i.1 τ ^ (N ^ 2 - 1) +
+          ∑ k ∈ Finset.range (N ^ 2 - 1),
+            Polynomial.eval (j τ) (P k) * frickeF N i.1 τ ^ k = 0 := by
+  obtain ⟨P, -, hP⟩ := (r4b_package N).2.2
+  exact ⟨P, fun i τ => hP i.1 i.2 τ⟩
+
+end B6Instance
+
+section B6Ring
+
+p2m_open "UpperHalfPlane ModularForm SlashInvariantForm ModularFormClass CuspForm \
+  ModularForm.CuspForm Polynomial Real.Polynomial Filter"
+open scoped MatrixGroups Manifold
+
+def PoleBounded (f : ℍ → ℂ) : Prop :=
+  MDiff f ∧ ∃ m : ℕ, IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m)
+
+lemma isBoundedAtImInfty_discriminant : IsBoundedAtImInfty (⇑CuspForm.discriminant : ℍ → ℂ) :=
+  (CuspFormClass.zero_at_infty CuspForm.discriminant).boundedAtFilter
+
+lemma isBoundedAtImInfty_discPow (n : ℕ) :
+    IsBoundedAtImInfty (⇑CuspForm.discriminant ^ n : ℍ → ℂ) := by
+  induction n with
+  | zero => exact pow_zero (⇑CuspForm.discriminant : ℍ → ℂ) ▸ const_boundedAtFilter _ (1 : ℂ)
+  | succ k ih =>
+    rw [pow_succ]
+    exact ih.mul isBoundedAtImInfty_discriminant
+
+lemma IsBoundedAtImInfty.mul_discPow_mono {f : ℍ → ℂ} {m m' : ℕ} (hm : m ≤ m')
+    (h : IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m)) :
+    IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m') := by
+  have hshape : (f * ⇑CuspForm.discriminant ^ m' : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m) * ⇑CuspForm.discriminant ^ (m' - m) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply]
+    rw [mul_assoc, ← pow_add, Nat.add_sub_cancel' hm]
+  rw [hshape]
+  exact h.mul (isBoundedAtImInfty_discPow (m' - m))
+
+lemma poleBounded_algebraMap (r : ℂ) : PoleBounded (algebraMap ℂ (ℍ → ℂ) r) := by
+  refine ⟨mdifferentiable_const, 0, ?_⟩
+  have hshape : ((algebraMap ℂ (ℍ → ℂ) r) * ⇑CuspForm.discriminant ^ 0 : ℍ → ℂ) =
+      fun _ => r := by
+    funext τ
+    simp
+  rw [hshape]
+  exact const_boundedAtFilter _ r
+
+lemma PoleBounded.add {f g : ℍ → ℂ} (hf : PoleBounded f) (hg : PoleBounded g) :
+    PoleBounded (f + g) := by
+  obtain ⟨hf1, m1, hf2⟩ := hf
+  obtain ⟨hg1, m2, hg2⟩ := hg
+  refine ⟨hf1.add hg1, max m1 m2, ?_⟩
+  have hshape : ((f + g) * ⇑CuspForm.discriminant ^ max m1 m2 : ℍ → ℂ) =
+      f * ⇑CuspForm.discriminant ^ max m1 m2 + g * ⇑CuspForm.discriminant ^ max m1 m2 := by
+    funext τ
+    simp [add_mul]
+  rw [hshape]
+  exact (IsBoundedAtImInfty.mul_discPow_mono (le_max_left _ _) hf2).add
+    (IsBoundedAtImInfty.mul_discPow_mono (le_max_right _ _) hg2)
+
+lemma PoleBounded.mul {f g : ℍ → ℂ} (hf : PoleBounded f) (hg : PoleBounded g) :
+    PoleBounded (f * g) := by
+  obtain ⟨hf1, m1, hf2⟩ := hf
+  obtain ⟨hg1, m2, hg2⟩ := hg
+  refine ⟨hf1.mul hg1, m1 + m2, ?_⟩
+  have hshape : ((f * g) * ⇑CuspForm.discriminant ^ (m1 + m2) : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m1) * (g * ⇑CuspForm.discriminant ^ m2) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply, pow_add]
+    ring
+  rw [hshape]
+  exact hf2.mul hg2
+
+theorem poleBounded_of_mem_adjoin {S : Set (ℍ → ℂ)} (hS : ∀ f ∈ S, PoleBounded f)
+    {a : ℍ → ℂ} (ha : a ∈ Algebra.adjoin ℂ S) : PoleBounded a := by
+  induction ha using Algebra.adjoin_induction with
+  | mem f hf => exact hS f hf
+  | algebraMap r => exact poleBounded_algebraMap r
+  | add x y hx hy ihx ihy => exact ihx.add ihy
+  | mul x y hx hy ihx ihy => exact ihx.mul ihy
+
+lemma poleBounded_j : PoleBounded j := by
+  rw [PoleBounded, CuspForm.coe_discriminant]
+  exact (r4b_package 1).1
+
+lemma poleBounded_frickeF {N : ℕ} [NeZero N] (i : FrickeIdx N) :
+    PoleBounded (frickeF N i.1) := by
+  rw [PoleBounded, CuspForm.coe_discriminant]
+  exact (r4b_package N).2.1 i.1 i.2
+
+theorem eq_polynomial_j_of_invariant_of_mem_adjoin {S : Set (ℍ → ℂ)}
+    (hS : ∀ f ∈ S, PoleBounded f) {a : ℍ → ℂ} (ha : a ∈ Algebra.adjoin ℂ S)
+    (hinv : ∀ γ : SL(2, ℤ), a ∣[(0 : ℤ)] γ = a) :
+    ∃ P : Polynomial ℂ, a = fun τ => Polynomial.eval (j τ) P := by
+  obtain ⟨hhol, m, hbd⟩ := poleBounded_of_mem_adjoin hS ha
+  rw [CuspForm.coe_discriminant] at hbd
+  obtain ⟨P, -, hP⟩ := levelOne_hauptmodul_package.1 m a hhol hinv hbd
+  exact ⟨P, hP⟩
+
+end B6Ring
+
+end Floor
+
+section B5_carrier
+
+open scoped UpperHalfPlane Manifold MatrixGroups ModularForm
+p2m_open "UpperHalfPlane~I"
+
+scoped instance slFnAction : MulSemiringAction SL(2, ℤ) (ℍ → ℂ) where
+  smul γ f := fun τ ↦ f (γ⁻¹ • τ)
+  one_smul f := by funext τ; change f ((1 : SL(2, ℤ))⁻¹ • τ) = f τ; rw [inv_one, one_smul]
+  mul_smul γ δ f := by
+    funext τ
+    change f ((γ * δ)⁻¹ • τ) = f (δ⁻¹ • (γ⁻¹ • τ))
+    rw [mul_inv_rev, mul_smul]
+  smul_zero γ := rfl
+  smul_add γ f g := rfl
+  smul_one γ := rfl
+  smul_mul γ f g := rfl
+
+lemma sl_smul_apply (γ : SL(2, ℤ)) (f : ℍ → ℂ) (τ : ℍ) : (γ • f) τ = f (γ⁻¹ • τ) := rfl
+
+lemma sl_smul_def (γ : SL(2, ℤ)) (f : ℍ → ℂ) : γ • f = fun τ ↦ f (γ⁻¹ • τ) := rfl
+
+scoped instance slFn_smulCommClass : SMulCommClass SL(2, ℤ) ℂ (ℍ → ℂ) where
+  smul_comm _ _ _ := rfl
+
+lemma sl_smul_eq_self_iff (f : ℍ → ℂ) :
+    (∀ γ : SL(2, ℤ), γ • f = f) ↔ ∀ (γ : SL(2, ℤ)) (τ : ℍ), f (γ • τ) = f τ := by
+  constructor
+  · intro h γ τ
+    have := congrFun (h γ⁻¹) τ
+    rwa [sl_smul_apply, inv_inv] at this
+  · intro h γ
+    funext τ
+    rw [sl_smul_apply, h]
+
+def HolFn : Subalgebra ℂ (ℍ → ℂ) where
+  carrier := {f | MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f}
+  mul_mem' hf hg := hf.mul hg
+  add_mem' hf hg := hf.add hg
+  algebraMap_mem' c := by
+    change MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fun _ : ℍ ↦ c)
+    exact mdifferentiable_const
+
+lemma mem_HolFn {f : ℍ → ℂ} : f ∈ HolFn ↔ MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f := Iff.rfl
+
+theorem HolFn.eq_zero_or_eq_zero_of_mul_eq_zero {f g : ℍ → ℂ} (hf : f ∈ HolFn) (hg : g ∈ HolFn)
+    (h : f * g = 0) : f = 0 ∨ g = 0 := by
+  rw [mem_HolFn, UpperHalfPlane.mdifferentiable_iff] at hf hg
+  have hU : IsOpen {z : ℂ | 0 < z.im} := isOpen_upperHalfPlaneSet
+  have key := AnalyticOnNhd.eq_zero_or_eq_zero_of_mul_eq_zero (hf.analyticOnNhd hU)
+    (hg.analyticOnNhd hU) (fun z hz ↦ by
+      have := congrFun h (ofComplex z)
+      simpa using this) (convex_halfSpace_im_gt 0).isPreconnected
+  rcases key with k | k
+  · left; funext τ; simpa [ofComplex_apply] using k (τ : ℂ) τ.im_pos
+  · right; funext τ; simpa [ofComplex_apply] using k (τ : ℂ) τ.im_pos
+
+scoped instance : NoZeroDivisors ↥HolFn where
+  eq_zero_or_eq_zero_of_mul_eq_zero {f g} h := by
+    rcases HolFn.eq_zero_or_eq_zero_of_mul_eq_zero f.2 g.2 (congrArg Subtype.val h) with e | e
+    · exact Or.inl (Subtype.ext e)
+    · exact Or.inr (Subtype.ext e)
+
+scoped instance : Nontrivial ↥HolFn :=
+  ⟨⟨0, 1, fun h ↦ zero_ne_one (congrFun (congrArg Subtype.val h) UpperHalfPlane.I)⟩⟩
+
+scoped instance : IsDomain ↥HolFn := NoZeroDivisors.to_isDomain _
+
+lemma j_smul_eq (γ : SL(2, ℤ)) (τ : ℍ) : j (γ • τ) = j τ := by
+  have hγ : (Matrix.SpecialLinearGroup.mapGL ℝ γ : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ, rfl⟩
+  have h4 := SlashInvariantForm.slash_action_eqn'' ModularForm.E₄ hγ τ
+  have hΔ := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hγ τ
+  rw [CuspForm.coe_discriminant] at hΔ
+  rw [show (Matrix.SpecialLinearGroup.mapGL ℝ γ) • τ = γ • τ from rfl,
+    denom_mapGL_eq_denomZ] at h4 hΔ
+  have hd : denomZ γ τ ≠ 0 := denomZ_ne_zero γ τ
+  have hΔ0 : ModularForm.discriminant τ ≠ 0 := ModularForm.discriminant_ne_zero τ
+  simp only [j]
+  rw [h4, hΔ, zpow_ofNat, zpow_ofNat]
+  field_simp
+
+lemma smul_j (γ : SL(2, ℤ)) : γ • j = j := by
+  funext τ; rw [sl_smul_apply, j_smul_eq]
+
+lemma smul_frickeF {N : ℕ} [NeZero N] (γ : SL(2, ℤ)) (a : Fin 2 → ZMod N) :
+    γ • frickeF N a = frickeF N (vecMulSL N a γ⁻¹) := by
+  funext τ; rw [sl_smul_apply, frickeF_slash]
+
+def levelGen (N : ℕ) : Set (ℍ → ℂ) := insert j (Set.range fun i : FrickeIdx N ↦ frickeF N i.1)
+
+def levelRing (N : ℕ) : Subalgebra ℂ (ℍ → ℂ) := Algebra.adjoin ℂ (levelGen N)
+
+lemma j_mem_levelRing (N : ℕ) : j ∈ levelRing N := Algebra.subset_adjoin (Set.mem_insert _ _)
+
+lemma frickeF_mem_levelRing {N : ℕ} (i : FrickeIdx N) : frickeF N i.1 ∈ levelRing N :=
+  Algebra.subset_adjoin (Set.mem_insert_of_mem _ ⟨i, rfl⟩)
+
+lemma mdifferentiable_j : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) j :=
+  (ModularForm.E₄.holo'.pow 3).div CuspForm.discriminant.holo' ModularForm.discriminant_ne_zero
+
+lemma levelGen_subset_HolFn (N : ℕ) [NeZero N] : levelGen N ⊆ HolFn := by
+  rintro f (rfl | ⟨i, rfl⟩)
+  · exact mdifferentiable_j
+  · exact mdifferentiable_frickeF i
+
+lemma levelRing_le_HolFn (N : ℕ) [NeZero N] : levelRing N ≤ HolFn :=
+  Algebra.adjoin_le (levelGen_subset_HolFn N)
+
+scoped instance (N : ℕ) [NeZero N] : IsDomain ↥(levelRing N) := by
+  have : NoZeroDivisors ↥(levelRing N) := ⟨fun {f g} h ↦ by
+    rcases HolFn.eq_zero_or_eq_zero_of_mul_eq_zero (levelRing_le_HolFn N f.2)
+      (levelRing_le_HolFn N g.2) (congrArg Subtype.val h) with e | e
+    · exact Or.inl (Subtype.ext e)
+    · exact Or.inr (Subtype.ext e)⟩
+  have : Nontrivial ↥(levelRing N) :=
+    ⟨⟨0, 1, fun h ↦ zero_ne_one (congrFun (congrArg Subtype.val h) UpperHalfPlane.I)⟩⟩
+  exact NoZeroDivisors.to_isDomain _
+
+lemma smul_mem_levelGen {N : ℕ} [NeZero N] (γ : SL(2, ℤ)) {f : ℍ → ℂ} (hf : f ∈ levelGen N) :
+    γ • f ∈ levelGen N := by
+  rcases hf with rfl | ⟨i, rfl⟩
+  · rw [smul_j]; exact Set.mem_insert _ _
+  · rw [smul_frickeF]
+    exact Set.mem_insert_of_mem _ ⟨⟨_, vecMulSL_ne_zero i.2 γ⁻¹⟩, rfl⟩
+
+theorem smul_mem_levelRing {N : ℕ} [NeZero N] (γ : SL(2, ℤ)) {f : ℍ → ℂ}
+    (hf : f ∈ levelRing N) : γ • f ∈ levelRing N := by
+  induction hf using Algebra.adjoin_induction with
+  | mem x hx => exact Algebra.subset_adjoin (smul_mem_levelGen γ hx)
+  | algebraMap c => rw [Algebra.algebraMap_eq_smul_one, smul_comm, smul_one]
+                    exact Subalgebra.smul_mem _ (Subalgebra.one_mem _) _
+  | add x y _ _ hx hy => rw [smul_add]; exact Subalgebra.add_mem _ hx hy
+  | mul x y _ _ hx hy => rw [smul_mul']; exact Subalgebra.mul_mem _ hx hy
+
+scoped instance levelRingAction (N : ℕ) [NeZero N] : MulSemiringAction SL(2, ℤ) ↥(levelRing N) where
+  smul γ f := ⟨γ • f.1, smul_mem_levelRing γ f.2⟩
+  one_smul f := Subtype.ext (one_smul _ f.1)
+  mul_smul γ δ f := Subtype.ext (mul_smul γ δ f.1)
+  smul_zero γ := Subtype.ext (smul_zero γ)
+  smul_add γ f g := Subtype.ext (smul_add γ f.1 g.1)
+  smul_one γ := Subtype.ext (smul_one γ)
+  smul_mul γ f g := Subtype.ext (smul_mul' γ f.1 g.1)
+
+@[scoped simp] lemma levelRing_coe_smul {N : ℕ} [NeZero N] (γ : SL(2, ℤ)) (f : ↥(levelRing N)) :
+    ((γ • f : ↥(levelRing N)) : ℍ → ℂ) = γ • (f : ℍ → ℂ) := rfl
+
+scoped instance levelRing_smulCommClass (N : ℕ) [NeZero N] :
+    SMulCommClass SL(2, ℤ) ℂ ↥(levelRing N) where
+  smul_comm _ _ _ := rfl
+
+def levelFixer (N : ℕ) [NeZero N] : Subgroup SL(2, ℤ) :=
+  (MulSemiringAction.toAlgAut SL(2, ℤ) ℂ ↥(levelRing N)).ker
+
+scoped instance (N : ℕ) [NeZero N] : (levelFixer N).Normal := MonoidHom.normal_ker _
+
+lemma mem_levelFixer_iff {N : ℕ} [NeZero N] (γ : SL(2, ℤ)) :
+    γ ∈ levelFixer N ↔ ∀ f : ↥(levelRing N), γ • f = f := by
+  rw [levelFixer, MonoidHom.mem_ker, AlgEquiv.ext_iff]
+  rfl
+
+lemma mem_levelFixer_iff_frickeF {N : ℕ} [NeZero N] (γ : SL(2, ℤ)) :
+    γ ∈ levelFixer N ↔ ∀ (i : FrickeIdx N) (τ : ℍ), frickeF N i.1 (γ • τ) = frickeF N i.1 τ := by
+  rw [mem_levelFixer_iff]
+  constructor
+  · intro h i τ
+    have e := congrArg Subtype.val (h (γ⁻¹ • ⟨frickeF N i.1, frickeF_mem_levelRing i⟩))
+    rw [← mul_smul, mul_inv_cancel, one_smul, levelRing_coe_smul] at e
+    have := congrFun e τ
+    rw [sl_smul_apply, inv_inv] at this
+    exact this.symm
+  · intro h f
+    obtain ⟨f, hf⟩ := f
+    apply Subtype.ext
+    change γ • f = f
+    induction hf using Algebra.adjoin_induction with
+    | mem x hx =>
+      rcases hx with rfl | ⟨i, rfl⟩
+      · exact smul_j γ
+      · funext τ
+        rw [sl_smul_apply]
+        have := h i (γ⁻¹ • τ)
+        rw [← mul_smul, mul_inv_cancel, one_smul] at this
+        exact this.symm
+    | algebraMap c => rfl
+    | add x y _ _ hx hy => rw [smul_add, hx, hy]
+    | mul x y _ _ hx hy => rw [smul_mul', hx, hy]
+
+lemma Gamma_le_levelFixer (N : ℕ) [NeZero N] : CongruenceSubgroup.Gamma N ≤ levelFixer N :=
+  fun _ hγ ↦ (mem_levelFixer_iff_frickeF _).mpr fun i τ ↦ frickeF_invariant_Gamma i.1 hγ τ
+
+theorem mem_levelFixer_iff_pm {N : ℕ} [NeZero N] (γ : SL(2, ℤ)) :
+    γ ∈ levelFixer N ↔ γ ∈ CongruenceSubgroup.Gamma N ∨ -γ ∈ CongruenceSubgroup.Gamma N := by
+  constructor
+  · intro h; exact frickeF_faithful γ ((mem_levelFixer_iff_frickeF γ).mp h)
+  · rintro (h | h)
+    · exact Gamma_le_levelFixer N h
+    · have : γ = -(-γ) := (neg_neg γ).symm
+      rw [this, mem_levelFixer_iff_frickeF]
+      intro i τ
+      rw [ModularGroup.SL_neg_smul]
+      exact frickeF_invariant_Gamma i.1 h τ
+
+scoped instance (N : ℕ) [NeZero N] : (levelFixer N).FiniteIndex :=
+  Subgroup.finiteIndex_of_le (Gamma_le_levelFixer N)
+
+abbrev LevelGrp (N : ℕ) [NeZero N] : Type := SL(2, ℤ) ⧸ levelFixer N
+
+noncomputable scoped instance (N : ℕ) [NeZero N] : Fintype (LevelGrp N) := Fintype.ofFinite _
+
+lemma card_LevelGrp (N : ℕ) [NeZero N] : Fintype.card (LevelGrp N) = (levelFixer N).index := by
+  rw [Fintype.card_eq_nat_card]; rfl
+
+noncomputable scoped instance levelGrpRingAction (N : ℕ) [NeZero N] :
+    MulSemiringAction (LevelGrp N) ↥(levelRing N) :=
+  MulSemiringAction.compHom _
+    (QuotientGroup.kerLift (MulSemiringAction.toAlgAut SL(2, ℤ) ℂ ↥(levelRing N)))
+
+@[scoped simp] lemma levelGrp_mk_smul {N : ℕ} [NeZero N] (γ : SL(2, ℤ)) (f : ↥(levelRing N)) :
+    (QuotientGroup.mk γ : LevelGrp N) • f = γ • f := rfl
+
+scoped instance levelGrp_smulCommClass (N : ℕ) [NeZero N] :
+    SMulCommClass (LevelGrp N) ℂ ↥(levelRing N) where
+  smul_comm q c f := by
+    induction q using QuotientGroup.induction_on with
+    | H γ => simp only [levelGrp_mk_smul]; exact smul_comm γ c f
+
+scoped instance levelGrp_faithful (N : ℕ) [NeZero N] :
+    FaithfulSMul (LevelGrp N) ↥(levelRing N) where
+  eq_of_smul_eq_smul {q₁ q₂} h := by
+    apply QuotientGroup.kerLift_injective (MulSemiringAction.toAlgAut SL(2, ℤ) ℂ ↥(levelRing N))
+    exact AlgEquiv.ext fun f ↦ h f
+
+abbrev levelField (N : ℕ) [NeZero N] : Type := FractionRing ↥(levelRing N)
+
+noncomputable scoped instance levelGrpFieldAction (N : ℕ) [NeZero N] :
+    MulSemiringAction (LevelGrp N) (levelField N) :=
+  IsFractionRing.mulSemiringAction (LevelGrp N) ↥(levelRing N) (levelField N)
+
+scoped instance levelGrp_smulDistribClass (N : ℕ) [NeZero N] :
+    SMulDistribClass (LevelGrp N) ↥(levelRing N) (levelField N) :=
+  IsFractionRing.smulDistribClass (LevelGrp N) ↥(levelRing N) (levelField N)
+
+lemma levelGrp_smul_algebraMap
+    {N : ℕ} [NeZero N] (g : LevelGrp N) (a : ↥(levelRing N)) :
+    g • algebraMap ↥(levelRing N) (levelField N) a =
+      algebraMap ↥(levelRing N) (levelField N) (g • a) :=
+  (algebraMap.coe_smul' g a (levelField N)).symm
+
+scoped instance levelGrpField_faithful
+    (N : ℕ) [NeZero N] : FaithfulSMul (LevelGrp N) (levelField N) :=
+  IsFractionRing.faithfulSMul (LevelGrp N) ↥(levelRing N) (levelField N)
+
+scoped instance levelGrpField_smulCommClass (N : ℕ) [NeZero N] :
+    SMulCommClass (LevelGrp N) ℂ (levelField N) :=
+  IsFractionRing.smulCommClass (LevelGrp N) ℂ ↥(levelRing N) ℂ (levelField N)
+
+theorem finrank_levelField_fixed (N : ℕ) [NeZero N] :
+    Module.finrank (FixedPoints.subfield (LevelGrp N) (levelField N)) (levelField N) =
+      (levelFixer N).index := by
+  rw [FixedPoints.finrank_eq_card, card_LevelGrp]
+
+private def _root_.WLight.jA (N : ℕ) : ↥(levelRing N) := ⟨j, j_mem_levelRing N⟩
+
+p2m_export "WLight" "jA"
+
+private def _root_.WLight.jK (N : ℕ) [NeZero N] :
+    levelField N := algebraMap ↥(levelRing N) (levelField N) (jA N)
+
+p2m_export "WLight" "jK"
+lemma aeval_j_apply (P : Polynomial ℂ) (τ : ℍ) :
+    (Polynomial.aeval j P : ℍ → ℂ) τ = Polynomial.eval (j τ) P := by
+  rw [show (Polynomial.aeval j P : ℍ → ℂ) τ = Pi.evalAlgHom ℂ (fun _ : ℍ ↦ ℂ) τ (Polynomial.aeval j
+    P)
+    from rfl, ← Polynomial.aeval_algHom_apply, ← Polynomial.coe_aeval_eq_eval]
+  rfl
+
+lemma coe_aeval_jA (N : ℕ) (P : Polynomial ℂ) :
+    ((Polynomial.aeval (jA N) P : ↥(levelRing N)) : ℍ → ℂ) = fun τ ↦ Polynomial.eval (j τ) P := by
+  rw [Polynomial.aeval_subalgebra_coe]
+  funext τ
+  exact aeval_j_apply P τ
+
+lemma levelGen_poleBounded (N : ℕ) [NeZero N] : ∀ f ∈ levelGen N, PoleBounded f := by
+  rintro f (rfl | ⟨i, rfl⟩)
+  · exact poleBounded_j
+  · exact poleBounded_frickeF i
+
+theorem levelRing_fixed_eq_aeval_j {N : ℕ} [NeZero N] (a : ↥(levelRing N))
+    (ha : ∀ γ : SL(2, ℤ), γ • a = a) : ∃ P : Polynomial ℂ, a = Polynomial.aeval (jA N) P := by
+  have ha' : ∀ γ : SL(2, ℤ), γ • (a : ℍ → ℂ) = a := fun γ ↦ congrArg Subtype.val (ha γ)
+  have hinv : ∀ γ : SL(2, ℤ), (a : ℍ → ℂ) ∣[(0 : ℤ)] γ = a := by
+    intro γ
+    funext τ
+    rw [ModularForm.SL_slash_apply, neg_zero, zpow_zero, mul_one]
+    exact (sl_smul_eq_self_iff _).mp ha' γ τ
+  obtain ⟨P, hP⟩ := eq_polynomial_j_of_invariant_of_mem_adjoin (levelGen_poleBounded N) a.2 hinv
+  exact ⟨P, Subtype.ext (by rw [coe_aeval_jA]; exact hP)⟩
+
+theorem levelRing_fixed_eq_aeval_j' {N : ℕ} [NeZero N] (a : ↥(levelRing N))
+    (ha : ∀ g : LevelGrp N, g • a = a) : ∃ P : Polynomial ℂ, a = Polynomial.aeval (jA N) P :=
+  levelRing_fixed_eq_aeval_j a fun γ ↦ ha (QuotientGroup.mk γ)
+
+lemma smul_jK {N : ℕ} [NeZero N] (g : LevelGrp N) : g • jK N = jK N := by
+  rw [jK, levelGrp_smul_algebraMap]
+  congr 1
+  induction g using QuotientGroup.induction_on with
+  | H γ => exact Subtype.ext (smul_j γ)
+
+theorem fixedPoints_levelField_eq_adjoin_j (N : ℕ) [NeZero N] :
+    (MulAction.fixedPoints (LevelGrp N) (levelField N) : Set (levelField N)) =
+      (IntermediateField.adjoin ℂ {jK N} : Set (levelField N)) := by
+  apply Set.Subset.antisymm
+  · intro x hx
+    rw [MulAction.mem_fixedPoints] at hx
+    obtain ⟨a, b, ha, hb, hb0, hab⟩ :=
+      exists_fixed_div_of_fixed (A := ↥(levelRing N)) (K := levelField N) (G := LevelGrp N)
+        levelGrp_smul_algebraMap x hx
+    obtain ⟨P, rfl⟩ := levelRing_fixed_eq_aeval_j' a ha
+    obtain ⟨Q, rfl⟩ := levelRing_fixed_eq_aeval_j' b hb
+    rw [SetLike.mem_coe, IntermediateField.mem_adjoin_simple_iff]
+    refine ⟨P, Q, ?_⟩
+    rw [jK, Polynomial.aeval_algebraMap_apply, Polynomial.aeval_algebraMap_apply,
+      eq_div_iff hb0, hab]
+  · change (IntermediateField.adjoin ℂ {jK N} : Set (levelField N)) ⊆
+      (FixedPoints.intermediateField (F := ℂ) (LevelGrp N) : IntermediateField ℂ (levelField N))
+    exact SetLike.coe_subset_coe.mpr (IntermediateField.adjoin_simple_le_iff.mpr fun g ↦ smul_jK g)
+
+end B5_carrier
+
+section B7_group
+
+open Matrix
+open scoped UpperHalfPlane MatrixGroups CongruenceSubgroup
+
+def adjoinNegOneSL {R : Type*} [CommRing R] (H : Subgroup SL(2, R)) : Subgroup SL(2, R) where
+  carrier := {g | g ∈ H ∨ -g ∈ H}
+  mul_mem' ha hb := by
+    rcases ha with ha | ha <;>
+      rcases hb with hb | hb <;>
+      · have := mul_mem ha hb
+        simp_all [neg_mul, mul_neg, neg_neg]
+  one_mem' := .inl H.one_mem
+  inv_mem' ha := by
+    rcases ha with ha | ha <;>
+    · have := inv_mem ha
+      simp_all
+
+@[scoped simp] lemma mem_adjoinNegOneSL
+      {R : Type*} [CommRing R] {H : Subgroup SL(2, R)} {g : SL(2, R)} :
+    g ∈ adjoinNegOneSL H ↔ g ∈ H ∨ -g ∈ H := Iff.rfl
+
+lemma le_adjoinNegOneSL {R : Type*} [CommRing R] (H : Subgroup SL(2, R)) :
+    H ≤ adjoinNegOneSL H := fun _ hg ↦ .inl hg
+
+lemma normal_adjoinNegOneSL {R : Type*} [CommRing R] {H : Subgroup SL(2, R)} (hH : H.Normal) :
+    (adjoinNegOneSL H).Normal := by
+  constructor
+  intro γ hγ g
+  rcases hγ with h | h
+  · exact .inl (hH.conj_mem γ h g)
+  · refine .inr ?_
+    rw [show -(g * γ * g⁻¹) = g * (-γ) * g⁻¹ by rw [mul_neg, neg_mul]]
+    exact hH.conj_mem (-γ) h g
+
+abbrev pmGamma (N : ℕ) : Subgroup SL(2, ℤ) := adjoinNegOneSL Γ(N)
+
+lemma Gamma_le_pmGamma (N : ℕ) : Γ(N) ≤ pmGamma N := le_adjoinNegOneSL _
+
+scoped instance instNormal_pmGamma (N : ℕ) : (pmGamma N).Normal :=
+  normal_adjoinNegOneSL (CongruenceSubgroup.Gamma_normal N)
+
+scoped instance instFiniteIndex_pmGamma (N : ℕ) [NeZero N] : (pmGamma N).FiniteIndex :=
+  Subgroup.finiteIndex_of_le (Gamma_le_pmGamma N)
+
+def frickeKernel (N : ℕ) [NeZero N] : Subgroup SL(2, ℤ) where
+  carrier := {γ | ∀ (i : FrickeIdx N) (τ : ℍ), frickeF N i.1 (γ • τ) = frickeF N i.1 τ}
+  mul_mem' {a b} ha hb i τ := by rw [mul_smul, ha, hb]
+  one_mem' i τ := by rw [one_smul]
+  inv_mem' {a} ha i τ := by
+    have := ha i (a⁻¹ • τ); rw [smul_inv_smul] at this; exact this.symm
+
+lemma mem_frickeKernel {N : ℕ} [NeZero N] {γ : SL(2, ℤ)} :
+    γ ∈ frickeKernel N ↔ ∀ (i : FrickeIdx N) (τ : ℍ), frickeF N i.1 (γ • τ) = frickeF N i.1 τ :=
+  Iff.rfl
+
+lemma neg_one_smul_upperHalfPlane (τ : ℍ) : (-1 : SL(2, ℤ)) • τ = τ := by
+  rw [show (-1 : SL(2, ℤ)) = -(1 : SL(2, ℤ)) from rfl, ModularGroup.SL_neg_smul, one_smul]
+
+lemma neg_one_mem_frickeKernel (N : ℕ) [NeZero N] : (-1 : SL(2, ℤ)) ∈ frickeKernel N :=
+  fun _ τ ↦ by rw [neg_one_smul_upperHalfPlane]
+
+lemma Gamma_le_frickeKernel (N : ℕ) [NeZero N] : Γ(N) ≤ frickeKernel N :=
+  fun _ hγ i τ ↦ frickeF_invariant_Gamma i.1 hγ τ
+
+theorem frickeKernel_eq_pmGamma (N : ℕ) [NeZero N] : frickeKernel N = pmGamma N := by
+  refine le_antisymm ?_ ?_
+  · intro γ hγ
+    exact mem_adjoinNegOneSL.mpr (frickeF_faithful γ hγ)
+  · intro γ hγ
+    rcases mem_adjoinNegOneSL.mp hγ with h | h
+    · exact Gamma_le_frickeKernel N h
+    · have hrw : γ = -1 * (-γ) := by simp
+      rw [hrw]
+      exact (frickeKernel N).mul_mem (neg_one_mem_frickeKernel N) (Gamma_le_frickeKernel N h)
+
+scoped instance instFiniteIndex_frickeKernel (N : ℕ) [NeZero N] : (frickeKernel N).FiniteIndex :=
+  frickeKernel_eq_pmGamma N ▸ instFiniteIndex_pmGamma N
+
+scoped instance instNormal_frickeKernel (N : ℕ) [NeZero N] : (frickeKernel N).Normal :=
+  frickeKernel_eq_pmGamma N ▸ instNormal_pmGamma N
+
+scoped instance instFinite_quotient_pmGamma (N : ℕ) [NeZero N] : Finite (SL(2, ℤ) ⧸ pmGamma N) :=
+  Subgroup.finite_quotient_of_finiteIndex
+
+scoped instance instFinite_quotient_frickeKernel (N : ℕ) [NeZero N] :
+    Finite (SL(2, ℤ) ⧸ frickeKernel N) :=
+  Subgroup.finite_quotient_of_finiteIndex
+
+end B7_group
+
+section B7_assembled
+
+open scoped UpperHalfPlane MatrixGroups IntermediateField
+
+lemma levelFixer_eq_frickeKernel (N : ℕ) [NeZero N] : levelFixer N = frickeKernel N :=
+  Subgroup.ext fun γ ↦ (mem_levelFixer_iff_frickeF γ).trans mem_frickeKernel.symm
+
+lemma levelFixer_eq_pmGamma (N : ℕ) [NeZero N] : levelFixer N = pmGamma N := by
+  rw [levelFixer_eq_frickeKernel, frickeKernel_eq_pmGamma]
+
+def fixedIF (N : ℕ) [NeZero N] : IntermediateField ℂ (levelField N) :=
+  FixedPoints.intermediateField (F := ℂ) (LevelGrp N)
+
+lemma fixedIF_eq_adjoin (N : ℕ) [NeZero N] : fixedIF N = ℂ⟮jK N⟯ :=
+  SetLike.coe_injective (fixedPoints_levelField_eq_adjoin_j N)
+
+lemma finrank_fixedIF (N : ℕ) [NeZero N] :
+    Module.finrank ↥(fixedIF N) (levelField N) = (levelFixer N).index :=
+  finrank_levelField_fixed N
+
+theorem finrank_adjoin_j_levelField (N : ℕ) [NeZero N] :
+    Module.finrank ↥ℂ⟮jK N⟯ (levelField N) = (pmGamma N).index := by
+  rw [← fixedIF_eq_adjoin, finrank_fixedIF, levelFixer_eq_pmGamma]
+
+theorem transcendental_jA (N : ℕ) [NeZero N] : Transcendental ℂ (jA N) := by
+  rw [transcendental_iff]
+  intro P hP
+  have hfun : (fun τ : ℍ ↦ Polynomial.eval (j τ) P) = 0 := by
+    rw [← coe_aeval_jA N P, hP]; rfl
+  apply Polynomial.eq_zero_of_infinite_isRoot
+  have : {x : ℂ | P.IsRoot x} = Set.univ := by
+    ext z
+    simp only [Set.mem_ofPred_eq, Set.mem_univ, iff_true, Polynomial.IsRoot.def]
+    obtain ⟨τ, rfl⟩ := j_surjective z
+    exact congrFun hfun τ
+  rw [this]
+  exact Set.infinite_univ
+
+theorem transcendental_jK (N : ℕ) [NeZero N] : Transcendental ℂ (jK N) := by
+  rw [transcendental_iff]
+  intro P hP
+  rw [jK, Polynomial.aeval_algebraMap_apply,
+    map_eq_zero_iff _ (IsFractionRing.injective ↥(levelRing N) (levelField N))] at hP
+  exact (transcendental_iff.mp (transcendental_jA N)) P hP
+
+end B7_assembled
+
+section C1_carrier
+
+open scoped UpperHalfPlane MatrixGroups IntermediateField IntermediateField.algebraAdjoinAdjoin
+p2m_open "Polynomial Real.Polynomial"
+
+abbrev polyJ (N : ℕ) [NeZero N] : Subalgebra ℂ (levelField N) := Algebra.adjoin ℂ {jK N}
+
+abbrev ratJ (N : ℕ) [NeZero N] : IntermediateField ℂ (levelField N) := ℂ⟮jK N⟯
+
+noncomputable def polyJEquiv (N : ℕ) [NeZero N] : ℂ[X] ≃ₐ[ℂ] ↥(polyJ N) :=
+  Polynomial.algEquivOfTranscendental ℂ (jK N) (transcendental_jK N)
+
+scoped instance (N : ℕ) [NeZero N] : IsDomain ↥(polyJ N) := inferInstance
+
+scoped instance (N : ℕ) [NeZero N] : IsPrincipalIdealRing ↥(polyJ N) :=
+  IsPrincipalIdealRing.of_surjective (polyJEquiv N).toRingEquiv.toRingHom
+    (polyJEquiv N).surjective
+
+-- explicit proof to avoid heartbeat bump (DL)
+scoped instance (N : ℕ) [NeZero N] : IsDedekindDomain ↥(polyJ N) :=
+  IsPrincipalIdealRing.isDedekindDomain ↥(polyJ N)
+
+scoped instance (N : ℕ) [NeZero N] : CharZero (levelField N) :=
+  charZero_of_injective_algebraMap (FaithfulSMul.algebraMap_injective ℂ (levelField N))
+
+scoped instance (N : ℕ) [NeZero N] : CharZero ↥(ratJ N) :=
+  charZero_of_injective_algebraMap (FaithfulSMul.algebraMap_injective ℂ ↥(ratJ N))
+
+lemma index_pmGamma_pos (N : ℕ) [NeZero N] : 0 < (pmGamma N).index := Nat.pos_of_ne_zero
+  Subgroup.FiniteIndex.index_ne_zero
+
+scoped instance (N : ℕ) [NeZero N] : FiniteDimensional ↥(ratJ N) (levelField N) :=
+  haveI : Module.Free ↥(ratJ N) (levelField N) := Module.Free.of_divisionRing _ _
+  Module.finite_of_finrank_pos (by rw [finrank_adjoin_j_levelField]; exact index_pmGamma_pos N)
+
+scoped instance (N : ℕ) [NeZero N] : Algebra.IsSeparable ↥(ratJ N) (levelField N) :=
+  haveI : Algebra.IsIntegral ↥(ratJ N) (levelField N) := Algebra.IsIntegral.of_finite _ _
+  Algebra.IsSeparable.of_integral ↥(ratJ N) (levelField N)
+
+abbrev levelIntClosure (N : ℕ) [NeZero N] : Subalgebra ↥(polyJ N) (levelField N) :=
+  integralClosure ↥(polyJ N) (levelField N)
+
+scoped instance (N : ℕ) [NeZero N] : IsDedekindDomain ↥(levelIntClosure N) :=
+  integralClosure.isDedekindDomain ↥(polyJ N) ↥(ratJ N) (levelField N)
+
+def levelRingEval (N : ℕ) (τ : ℍ) : ↥(levelRing N) →ₐ[ℂ] ℂ :=
+  (Pi.evalAlgHom ℂ (fun _ : ℍ ↦ ℂ) τ).comp (levelRing N).val
+
+@[scoped simp] lemma levelRingEval_apply (N : ℕ) (τ : ℍ) (a : ↥(levelRing N)) :
+    levelRingEval N τ a = (a : ℍ → ℂ) τ := rfl
+
+end C1_carrier
+
+section C0_membership
+
+open scoped UpperHalfPlane Manifold MatrixGroups ModularForm IntermediateField
+p2m_open "UpperHalfPlane~I"
+
+structure LevelGens (N : ℕ) [NeZero N] where
+  S : Set (ℍ → ℂ)
+  levelGen_subset : levelGen N ⊆ S
+  poleBounded : ∀ f ∈ S, PoleBounded f
+  smul_mem : ∀ (γ : SL(2, ℤ)), ∀ f ∈ S, γ • f ∈ S
+  invariant : ∀ f ∈ S, ∀ γ ∈ CongruenceSubgroup.Gamma N, ∀ τ : ℍ, f (γ • τ) = f τ
+
+namespace LevelGens
+
+variable {N : ℕ} [NeZero N] (D : LevelGens N)
+
+def ring : Subalgebra ℂ (ℍ → ℂ) := Algebra.adjoin ℂ D.S
+
+lemma ring_le_HolFn : D.ring ≤ HolFn :=
+  Algebra.adjoin_le fun f hf ↦ (D.poleBounded f hf).1
+
+lemma levelRing_le_ring : levelRing N ≤ D.ring := Algebra.adjoin_mono D.levelGen_subset
+
+scoped instance : IsDomain ↥D.ring := by
+  have : NoZeroDivisors ↥D.ring := ⟨fun {f g} h ↦ by
+    rcases HolFn.eq_zero_or_eq_zero_of_mul_eq_zero (D.ring_le_HolFn f.2)
+      (D.ring_le_HolFn g.2) (congrArg Subtype.val h) with e | e
+    · exact Or.inl (Subtype.ext e)
+    · exact Or.inr (Subtype.ext e)⟩
+  have : Nontrivial ↥D.ring :=
+    ⟨⟨0, 1, fun h ↦ zero_ne_one (congrFun (congrArg Subtype.val h) UpperHalfPlane.I)⟩⟩
+  exact NoZeroDivisors.to_isDomain _
+
+theorem smul_mem_ring (γ : SL(2, ℤ)) {f : ℍ → ℂ} (hf : f ∈ D.ring) : γ • f ∈ D.ring := by
+  induction hf using Algebra.adjoin_induction with
+  | mem x hx => exact Algebra.subset_adjoin (D.smul_mem γ x hx)
+  | algebraMap c => rw [Algebra.algebraMap_eq_smul_one, smul_comm, smul_one]
+                    exact Subalgebra.smul_mem _ (Subalgebra.one_mem _) _
+  | add x y _ _ hx hy => rw [smul_add]; exact Subalgebra.add_mem _ hx hy
+  | mul x y _ _ hx hy => rw [smul_mul']; exact Subalgebra.mul_mem _ hx hy
+
+scoped instance ringAction : MulSemiringAction SL(2, ℤ) ↥D.ring where
+  smul γ f := ⟨γ • f.1, D.smul_mem_ring γ f.2⟩
+  one_smul f := Subtype.ext (one_smul _ f.1)
+  mul_smul γ δ f := Subtype.ext (mul_smul γ δ f.1)
+  smul_zero γ := Subtype.ext (smul_zero γ)
+  smul_add γ f g := Subtype.ext (smul_add γ f.1 g.1)
+  smul_one γ := Subtype.ext (smul_one γ)
+  smul_mul γ f g := Subtype.ext (smul_mul' γ f.1 g.1)
+
+@[scoped simp] lemma ring_coe_smul (γ : SL(2, ℤ)) (f : ↥D.ring) :
+    ((γ • f : ↥D.ring) : ℍ → ℂ) = γ • (f : ℍ → ℂ) := rfl
+
+scoped instance ring_smulCommClass : SMulCommClass SL(2, ℤ) ℂ ↥D.ring where
+  smul_comm _ _ _ := rfl
+
+lemma smul_eq_self_of_pm {γ : SL(2, ℤ)}
+    (hγ : γ ∈ CongruenceSubgroup.Gamma N ∨ -γ ∈ CongruenceSubgroup.Gamma N)
+    {f : ℍ → ℂ} (hf : f ∈ D.ring) : γ • f = f := by
+  induction hf using Algebra.adjoin_induction with
+  | mem x hx =>
+    funext τ
+    rw [sl_smul_apply]
+    rcases hγ with h | h
+    · exact D.invariant x hx γ⁻¹ (inv_mem h) τ
+    · have : γ⁻¹ = -(-γ)⁻¹ := by simp
+      rw [this, ModularGroup.SL_neg_smul]
+      exact D.invariant x hx (-γ)⁻¹ (inv_mem h) τ
+  | algebraMap c => rfl
+  | add x y _ _ hx hy => rw [smul_add, hx, hy]
+  | mul x y _ _ hx hy => rw [smul_mul', hx, hy]
+
+lemma levelFixer_le_ker :
+    levelFixer N ≤ (MulSemiringAction.toAlgAut SL(2, ℤ) ℂ ↥D.ring).ker := by
+  intro γ hγ
+  rw [MonoidHom.mem_ker]
+  ext f
+  exact congrFun (D.smul_eq_self_of_pm ((mem_levelFixer_iff_pm γ).mp hγ) f.2) _
+
+lemma ker_le_levelFixer :
+    (MulSemiringAction.toAlgAut SL(2, ℤ) ℂ ↥D.ring).ker ≤ levelFixer N := by
+  intro γ hγ
+  rw [MonoidHom.mem_ker, AlgEquiv.ext_iff] at hγ
+  have h' : ∀ a : ↥D.ring, γ • a = a := fun a ↦ hγ a
+  rw [mem_levelFixer_iff_frickeF]
+  intro i τ
+  set fa : ↥D.ring := ⟨frickeF N i.1, D.levelRing_le_ring (frickeF_mem_levelRing i)⟩
+  have e : γ • (γ⁻¹ • frickeF N i.1) = γ⁻¹ • frickeF N i.1 :=
+    congrArg Subtype.val (h' (γ⁻¹ • fa))
+  rw [← mul_smul, mul_inv_cancel, one_smul] at e
+  have := congrFun e τ
+  rw [sl_smul_apply, inv_inv] at this
+  exact this.symm
+
+noncomputable scoped instance grpRingAction : MulSemiringAction (LevelGrp N) ↥D.ring :=
+  MulSemiringAction.compHom _
+    (QuotientGroup.lift (levelFixer N) (MulSemiringAction.toAlgAut SL(2, ℤ) ℂ ↥D.ring)
+      D.levelFixer_le_ker)
+
+@[scoped simp] lemma grp_mk_smul (γ : SL(2, ℤ)) (f : ↥D.ring) :
+    (QuotientGroup.mk γ : LevelGrp N) • f = γ • f := rfl
+
+scoped instance grp_smulCommClass : SMulCommClass (LevelGrp N) ℂ ↥D.ring where
+  smul_comm q c f := by
+    induction q using QuotientGroup.induction_on with
+    | H γ => simp only [grp_mk_smul]; exact smul_comm γ c f
+
+scoped instance grp_faithful : FaithfulSMul (LevelGrp N) ↥D.ring where
+  eq_of_smul_eq_smul {q₁ q₂} h := by
+    induction q₁ using QuotientGroup.induction_on with
+    | H γ₁ =>
+    induction q₂ using QuotientGroup.induction_on with
+    | H γ₂ =>
+    apply QuotientGroup.eq.mpr
+    apply D.ker_le_levelFixer
+    rw [MonoidHom.mem_ker, map_mul, map_inv, inv_mul_eq_one]
+    exact AlgEquiv.ext fun f ↦ h f
+
+abbrev field : Type := FractionRing ↥D.ring
+
+noncomputable scoped instance grpFieldAction : MulSemiringAction (LevelGrp N) D.field :=
+  IsFractionRing.mulSemiringAction (LevelGrp N) ↥D.ring D.field
+
+scoped instance grp_smulDistribClass : SMulDistribClass (LevelGrp N) ↥D.ring D.field :=
+  IsFractionRing.smulDistribClass (LevelGrp N) ↥D.ring D.field
+
+lemma grp_smul_algebraMap (g : LevelGrp N) (a : ↥D.ring) :
+    g • algebraMap ↥D.ring D.field a = algebraMap ↥D.ring D.field (g • a) :=
+  (algebraMap.coe_smul' g a D.field).symm
+
+scoped instance grpField_faithful : FaithfulSMul (LevelGrp N) D.field :=
+  IsFractionRing.faithfulSMul (LevelGrp N) ↥D.ring D.field
+
+scoped instance grpField_smulCommClass : SMulCommClass (LevelGrp N) ℂ D.field :=
+  IsFractionRing.smulCommClass (LevelGrp N) ℂ ↥D.ring ℂ D.field
+
+def jA : ↥D.ring := ⟨j, D.levelRing_le_ring (j_mem_levelRing N)⟩
+
+def jK : D.field := algebraMap ↥D.ring D.field D.jA
+
+lemma coe_aeval_jA (P : Polynomial ℂ) :
+    ((Polynomial.aeval D.jA P : ↥D.ring) : ℍ → ℂ) = fun τ ↦ Polynomial.eval (j τ) P := by
+  rw [Polynomial.aeval_subalgebra_coe]
+  funext τ
+  exact aeval_j_apply P τ
+
+lemma smul_jK (g : LevelGrp N) : g • D.jK = D.jK := by
+  rw [jK, grp_smul_algebraMap]
+  congr 1
+  induction g using QuotientGroup.induction_on with
+  | H γ => exact Subtype.ext (smul_j γ)
+
+abbrev ratJ : IntermediateField ℂ D.field := ℂ⟮D.jK⟯
+
+def incl : ↥(levelRing N) →ₐ[ℂ] ↥D.ring := Subalgebra.inclusion D.levelRing_le_ring
+
+lemma incl_injective : Function.Injective D.incl := Subalgebra.inclusion_injective _
+
+@[scoped simp] lemma coe_incl (a : ↥(levelRing N)) : ((D.incl a : ↥D.ring) : ℍ → ℂ) = a :=
+  Subalgebra.coe_inclusion _ a
+
+lemma toRingField_injective :
+    Function.Injective ((IsScalarTower.toAlgHom ℂ ↥D.ring D.field).comp D.incl) :=
+  (IsFractionRing.injective ↥D.ring D.field).comp D.incl_injective
+
+noncomputable def toField : levelField N →ₐ[ℂ] D.field :=
+  IsFractionRing.liftAlgHom D.toRingField_injective
+
+noncomputable scoped instance (priority := 3000) algebraField : Algebra (levelField N) D.field :=
+  D.toField.toRingHom.toAlgebra
+
+noncomputable scoped instance (priority := 3000) moduleField : Module (levelField N) D.field :=
+  Algebra.toModule
+
+noncomputable scoped instance (priority := 3000) smulField : SMul (levelField N) D.field :=
+  Algebra.toSMul
+
+scoped instance : IsScalarTower ℂ (levelField N) D.field :=
+  IsScalarTower.of_algebraMap_eq fun c ↦ (D.toField.commutes c).symm
+
+noncomputable scoped instance (priority := 3000) algebraRatJ : Algebra ↥(WLight.ratJ N) D.field :=
+  ((algebraMap (levelField N) D.field).comp (algebraMap ↥(WLight.ratJ N) (levelField N))).toAlgebra
+
+noncomputable scoped instance (priority := 3000) moduleRatJ : Module ↥(WLight.ratJ N) D.field :=
+  Algebra.toModule
+
+noncomputable scoped instance (priority := 3000) smulRatJ : SMul ↥(WLight.ratJ N) D.field :=
+  Algebra.toSMul
+
+scoped instance : IsScalarTower ↥(WLight.ratJ N) (levelField N) D.field :=
+  IsScalarTower.of_algebraMap_eq fun _ ↦ rfl
+
+end LevelGens
+end C0_membership
+
+section Solution
+open scoped UpperHalfPlane Manifold MatrixGroups ModularForm
+
+private lemma periodPair_eq_of_ω (P P' : PeriodPair) (h1 : P.ω₁ = P'.ω₁) (h2 : P.ω₂ = P'.ω₂) :
+    P = P' := by
+  rcases P with ⟨_, _, _⟩; rcases P' with ⟨_, _, _⟩
+  simp only [PeriodPair.mk.injEq]; exact ⟨h1, h2⟩
+
+set_option synthInstance.maxHeartbeats 20000 in
+private theorem r5_fixed_frac_polynomial {N : ℕ} [NeZero N] {a b : ℍ → ℂ}
+    (haA : a ∈ levelRing N) (hbA : b ∈ levelRing N) (hb0 : b ≠ 0)
+    (hinv : ∀ γ : SL(2, ℤ), a * (b ∘ (γ • ·)) = (a ∘ (γ • ·)) * b) :
+    ∃ p q : Polynomial ℂ, q ≠ 0 ∧ a * (fun τ ↦ q.eval (j τ)) = b * (fun τ ↦ p.eval (j τ)) := by
+  set aR : ↥(levelRing N) := ⟨a, haA⟩
+  set bR : ↥(levelRing N) := ⟨b, hbA⟩
+  have hbR0 : bR ≠ 0 := fun h ↦ hb0 (congrArg Subtype.val h)
+  have hinvR : ∀ γ : SL(2, ℤ), aR * (γ • bR) = (γ • aR) * bR := fun γ ↦ by
+    apply Subtype.ext
+    simp only [Subalgebra.coe_mul, levelRing_coe_smul, sl_smul_def]
+    exact hinv γ⁻¹
+  set x : levelField N := (algebraMap _ (levelField N) aR) / (algebraMap _ (levelField N) bR)
+  have hbRK : algebraMap _ (levelField N) bR ≠ 0 := fun h ↦ hbR0
+    ((map_eq_zero_iff _ (IsFractionRing.injective ↥(levelRing N) (levelField N))).mp h)
+  have hxfix : ∀ g : LevelGrp N, g • x = x := fun g ↦ by
+    have hgb : algebraMap _ (levelField N) (g • bR) ≠ 0 := fun h ↦ hbR0 (by
+      have h0 : g • bR = 0 := (map_eq_zero_iff _
+        (IsFractionRing.injective ↥(levelRing N) (levelField N))).mp h
+      have := congrArg (g⁻¹ • ·) h0
+      simpa only [inv_smul_smul, smul_zero] using this)
+    have hgx : g • x = algebraMap _ (levelField N) (g • aR)
+        / algebraMap _ (levelField N) (g • bR) := by
+      rw [← levelGrp_smul_algebraMap, ← levelGrp_smul_algebraMap]
+      exact map_div₀ (MulSemiringAction.toRingHom (LevelGrp N) (levelField N) g) _ _
+    have hgeq : aR * (g • bR) = (g • aR) * bR := by
+      induction g using QuotientGroup.induction_on with
+      | H γ => rw [levelGrp_mk_smul, levelGrp_mk_smul]; exact hinvR γ
+    rw [hgx, div_eq_div_iff hgb hbRK, ← map_mul, ← map_mul]
+    exact congrArg _ hgeq.symm
+  obtain ⟨a', b', ha'f, hb'f, hb'0, hx⟩ :=
+    exists_fixed_div_of_fixed (G := LevelGrp N) (A := ↥(levelRing N)) (K := levelField N)
+      levelGrp_smul_algebraMap x hxfix
+  have ha'fS : ∀ γ : SL(2, ℤ), γ • a' = a' :=
+    fun γ ↦ (levelGrp_mk_smul γ a').symm.trans (ha'f (QuotientGroup.mk γ))
+  have hb'fS : ∀ γ : SL(2, ℤ), γ • b' = b' :=
+    fun γ ↦ (levelGrp_mk_smul γ b').symm.trans (hb'f (QuotientGroup.mk γ))
+  obtain ⟨p, hp⟩ := levelRing_fixed_eq_aeval_j a' ha'fS
+  obtain ⟨q, hq⟩ := levelRing_fixed_eq_aeval_j b' hb'fS
+  refine ⟨p, q, ?_, ?_⟩
+  · intro hq0; apply hb'0
+    rw [hq, hq0, map_zero, map_zero]
+  · have hab' : aR * b' = bR * a' := by
+      have hdm := hx
+      rw [show x = algebraMap _ (levelField N) aR / algebraMap _ (levelField N) bR from rfl,
+        div_mul_eq_mul_div, div_eq_iff hbRK, ← map_mul, ← map_mul] at hdm
+      exact (IsFractionRing.injective ↥(levelRing N) (levelField N) hdm).trans (mul_comm a' bR)
+    have hfun := congrArg (Subtype.val : ↥(levelRing N) → ℍ → ℂ) hab'
+    rw [Subalgebra.coe_mul, Subalgebra.coe_mul, hp, hq, coe_aeval_jA, coe_aeval_jA] at hfun
+    exact hfun
+
+end Solution
+end WLight
+
+open scoped UpperHalfPlane Manifold MatrixGroups ModularForm in
+open _root_.WLight _root_.P2MW.S_WLight_levelN_structure_package.WLight in
+theorem solution
+    (N : ℕ) [NeZero N]
+    (L : ℍ → PeriodPair) (hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), W v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (jf : ℍ → ℂ)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) :
+    let A_N : Subalgebra ℂ (ℍ → ℂ) := Algebra.adjoin ℂ
+      (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v})
+    let vecMul : (Fin 2 → ZMod N) → SL(2, ℤ) → Fin 2 → ZMod N := fun v γ ↦
+      Matrix.vecMul v ((γ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N))
+    ({γ : SL(2, ℤ) | ∀ v : Fin 2 → ZMod N, v ≠ 0 → fricke (vecMul v γ) = fricke v} =
+      {γ : SL(2, ℤ) | γ ∈ CongruenceSubgroup.Gamma N ∨ -γ ∈ CongruenceSubgroup.Gamma N})
+    ∧ (∀ a b : ℍ → ℂ, a ∈ A_N → b ∈ A_N → b ≠ 0 →
+        (∀ γ : SL(2, ℤ), a * (b ∘ (γ • ·)) = (a ∘ (γ • ·)) * b) →
+        ∃ p q : Polynomial ℂ, q ≠ 0 ∧ a * (fun τ ↦ q.eval (jf τ)) = b * (fun τ ↦ p.eval (jf τ)))
+    ∧ (∀ v : Fin 2 → ZMod N, v ≠ 0 → ∃ d : ℕ, ∃ c : ℕ → Polynomial ℂ,
+        ∀ τ, fricke v τ ^ d
+          + ∑ k ∈ Finset.range d, (c k).eval (jf τ) * fricke v τ ^ k = 0)
+    ∧ (∀ P : Polynomial ℂ, (∀ τ : ℍ, P.eval (jf τ) = 0) → P = 0)
+    ∧ (∀ F ∈ A_N, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F)
+    ∧ (∀ a b : ℍ → ℂ, a ∈ A_N → b ∈ A_N → a * b = 0 → a = 0 ∨ b = 0) := by
+  obtain rfl : jf = j := funext fun τ ↦ hjf τ
+  have hLp : ∀ τ, L τ = periodPairOfTau τ :=
+    fun τ ↦ periodPair_eq_of_ω _ _ (hL τ).1 (hL τ).2
+  obtain rfl : fricke = frickeF N := funext₂ fun v τ ↦ by
+    rw [hfricke, hW, hLp]; rfl
+  intro A_N vecMul
+  have hAN : A_N = levelRing N := by
+    simp only [A_N]
+    congr 1
+    refine congrArg (insert j) (Set.ext fun g ↦ ?_)
+    exact ⟨fun ⟨v, hv, hg⟩ ↦ ⟨⟨v, hv⟩, hg.symm⟩, fun ⟨i, hi⟩ ↦ ⟨i.1, i.2, hi.symm⟩⟩
+  have hvm : vecMul = vecMulSL N := rfl
+  refine ⟨?_, ?_, ?_, ?_, ?_, ?_⟩
+  · rw [hvm]
+    ext γ
+    simp only [Set.mem_ofPred_eq]
+    rw [← mem_levelFixer_iff_pm γ, mem_levelFixer_iff_frickeF γ]
+    exact ⟨fun h i τ ↦ (frickeF_slash i.1 γ τ).trans (congrFun (h i.1 i.2) τ),
+      fun h v hv ↦ funext fun τ ↦ (frickeF_slash v γ τ).symm.trans (h ⟨v, hv⟩ τ)⟩
+  · intro a b haA hbA hb0 hinv; rw [hAN] at haA hbA
+    exact r5_fixed_frac_polynomial haA hbA hb0 hinv
+  · intro v hv
+    obtain ⟨P, hrel⟩ := frickeF_integral_over_j N
+    exact ⟨_, P, hrel ⟨v, hv⟩⟩
+  · intro P hP
+    refine Polynomial.eq_zero_of_infinite_isRoot P ?_
+    rw [show {x : ℂ | P.IsRoot x} = Set.univ from Set.eq_univ_of_forall fun c ↦ by
+      obtain ⟨τ, hτ⟩ := j_surjective c
+      exact hτ ▸ hP τ]
+    exact Set.infinite_univ
+  · intro F hF; rw [hAN] at hF; exact levelRing_le_HolFn N hF
+  · intro a b haA hbA hab; rw [hAN] at haA hbA
+    exact HolFn.eq_zero_or_eq_zero_of_mul_eq_zero (levelRing_le_HolFn N haA)
+      (levelRing_le_HolFn N hbA) hab
+
+end
+end S_WLight_levelN_structure_package
+end P2MW
+export P2MW.S_WLight_levelN_structure_package (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Complex Real UpperHalfPlane
+open scoped Manifold MatrixGroups ModularForm
+theorem WLight.levelN_structure_package
+    (N : ℕ) [NeZero N]
+    (L : ℍ → PeriodPair) (hL : ∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1)
+    (W : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hW : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), W v τ = ((2 * (Real.pi : ℂ) * Complex.I) ^ 2)⁻¹ *
+      PeriodPair.weierstrassP (L τ) ((((v 0).val : ℂ) * (τ : ℂ) + ((v 1).val : ℂ)) / (N : ℂ)))
+    (fricke : (Fin 2 → ZMod N) → ℍ → ℂ)
+    (hfricke : ∀ (v : Fin 2 → ZMod N) (τ : ℍ), fricke v τ =
+      -(ModularForm.E₄ τ * ModularForm.E₆ τ / ModularForm.discriminant τ) / 2592 * W v τ)
+    (jf : ℍ → ℂ)
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) :
+    let A_N : Subalgebra ℂ (ℍ → ℂ) := Algebra.adjoin ℂ
+      (insert jf {g : ℍ → ℂ | ∃ v : Fin 2 → ZMod N, v ≠ 0 ∧ g = fricke v})
+    let vecMul : (Fin 2 → ZMod N) → SL(2, ℤ) → Fin 2 → ZMod N := fun v γ ↦
+      Matrix.vecMul v ((γ : Matrix (Fin 2) (Fin 2) ℤ).map ((↑) : ℤ → ZMod N))
+    ({γ : SL(2, ℤ) | ∀ v : Fin 2 → ZMod N, v ≠ 0 → fricke (vecMul v γ) = fricke v} =
+      {γ : SL(2, ℤ) | γ ∈ CongruenceSubgroup.Gamma N ∨ -γ ∈ CongruenceSubgroup.Gamma N})
+    ∧ (∀ a b : ℍ → ℂ, a ∈ A_N → b ∈ A_N → b ≠ 0 →
+        (∀ γ : SL(2, ℤ), a * (b ∘ (γ • ·)) = (a ∘ (γ • ·)) * b) →
+        ∃ p q : Polynomial ℂ, q ≠ 0 ∧ a * (fun τ ↦ q.eval (jf τ)) = b * (fun τ ↦ p.eval (jf τ)))
+    ∧ (∀ v : Fin 2 → ZMod N, v ≠ 0 → ∃ d : ℕ, ∃ c : ℕ → Polynomial ℂ,
+        ∀ τ, fricke v τ ^ d
+          + ∑ k ∈ Finset.range d, (c k).eval (jf τ) * fricke v τ ^ k = 0)
+    ∧ (∀ P : Polynomial ℂ, (∀ τ : ℍ, P.eval (jf τ) = 0) → P = 0)
+    ∧ (∀ F ∈ A_N, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F)
+    ∧ (∀ a b : ℍ → ℂ, a ∈ A_N → b ∈ A_N → a * b = 0 → a = 0 ∨ b = 0) :=
+  solution N L hL W hW fricke hfricke jf hjf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_levelOne_hauptmodul_package.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_levelOne_hauptmodul_package.lean
new file mode 100644
index 0000000000..523a01671b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_levelOne_hauptmodul_package.lean
@@ -0,0 +1,1301 @@
+/-
+Based on Prove2Me node WLight.levelOne_hauptmodul_package
+(3bfac678-351d-51fb-81b3-f37cf843690b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a5781c87-e66e-5ab2-bafe-a4e7bc84bf2d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.NumberTheory.ModularForms.EisensteinSeries.Basic
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Manifold
+public import Mathlib.Geometry.Manifold.Notation
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+
+import Mathlib.NumberTheory.ModularForms.EisensteinSeries.QExpansion
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+import Mathlib.Analysis.SpecialFunctions.Elliptic.Weierstrass
+import Mathlib.RingTheory.DedekindDomain.IntegralClosure
+import Mathlib.RingTheory.DedekindDomain.Ideal.Lemmas
+import Mathlib.RingTheory.Unramified.Field
+import Mathlib.Analysis.Meromorphic.NormalForm
+import Mathlib.RingTheory.Discriminant
+import Mathlib.RingTheory.Adjoin.PowerBasis
+import Mathlib.FieldTheory.PrimitiveElement
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.LinearAlgebra.Lagrange
+import Mathlib.FieldTheory.LinearDisjoint
+import Mathlib.FieldTheory.Galois.Infinite
+import Mathlib.RingTheory.AlgebraicIndependent.TranscendenceBasis
+import Mathlib.RingTheory.AlgebraicIndependent.AlgebraicClosure
+import Mathlib.RingTheory.AlgebraicIndependent.Adjoin
+import Mathlib.RingTheory.Polynomial.RationalRoot
+import Mathlib.Analysis.Analytic.Order
+import Mathlib.RingTheory.PowerSeries.Order
+import Mathlib.RingTheory.Polynomial.IsIntegral
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Level-one hauptmodul package: polynomials in j, surjectivity, q-expansion principle
+
+Theorem statement: `WLight.levelOne_hauptmodul_package` (`3bfac678-351d-51fb-81b3-f37cf843690b`), by
+Claude, 2026-09-05.
+
+Proof: submission `a5781c87-e66e-5ab2-bafe-a4e7bc84bf2d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+A conjunction of five assertions about the level-one functions $E_4$, $\Delta$ and $j=E_4^3/\Delta$
+on $\mathbb{H}$. (a) For every $m\in\mathbb{N}$ and every $h:\mathbb{H}\to\mathbb{C}$ that is
+differentiable as a map of complex manifolds, satisfies $h\mid[0]\gamma=h$ for all
+$\gamma\in\mathrm{SL}(2,\mathbb{Z})$ under the weight-$0$ slash action, and is such that
+$h\cdot\Delta^m$ is bounded at $i\infty$, there is $P\in\mathbb{C}[X]$ with $\deg P\le m$ and
+$h(\tau)=P\bigl(E_4(\tau)^3/\Delta(\tau)\bigr)$ for all $\tau$. (b) The same with an intermediate
+field $k$ of $\mathbb{C}/\mathbb{Q}$ and a width $N\neq 0$: if moreover
+$(h\cdot\Delta^m)\circ\mathtt{ofComplex}$ is periodic with period $N$ and every coefficient of the
+width-$N$ $q$-expansion of $h\cdot\Delta^m$ lies in $k$, then $P$ may be taken with $\deg P\le m$,
+all coefficients in $k$, and $h=P(E_4^3/\Delta)$. (c) The map $\tau\mapsto E_4(\tau)^3/\Delta(\tau)$
+is surjective. (d) For $m\in\mathbb{N}$ and $P\in\mathbb{C}[X]$ with $\deg P\le m$: if every
+coefficient of the power series $\sum_{i=0}^{m}C(P_i)\,q_1(E_4)^{3i}\,q_1(\Delta)^{m-i}$, formed
+from the width-$1$ $q$-expansions of $E_4$ and $\Delta$, is rational, then every $P_i$ is rational.
+(e) The same implication with "rational" replaced throughout by "lying in a given intermediate field
+$k$ of $\mathbb{C}/\mathbb{Q}$".
+
+These are the level-one inputs to the $q$-expansion-principle argument: parts (a) and (b) identify
+$\mathrm{SL}(2,\mathbb{Z})$-invariant holomorphic functions with at most polar growth at the cusp as
+polynomials in the modular invariant $j$, with coefficients controlled by the $q$-expansion, part
+(c) allows such polynomial identities to be tested by evaluation, and parts (d), (e) transfer
+rationality information from a single combined $q$-series to the polynomial coefficients. The
+package is cited in the level-$N$ function-field results, among them
+[`WLight.exists_levelFraction_of_stable_family`]
+(thm.html#WLight.exists_levelFraction_of_stable_family),
+[`WLight.exists_monicRel_j_of_mdifferentiable_levelFraction`]
+(thm.html#WLight.exists_monicRel_j_of_mdifferentiable_levelFraction)
+and [`WLight.frickeFunction_orbit_package`](thm.html#WLight.frickeFunction_orbit_package).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WLight_levelOne_hauptmodul_package.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WLight_levelOne_hauptmodul_package
+
+noncomputable section
+
+open Complex Real
+namespace WLight
+
+section A1_levelOne_ratSpan
+
+p2m_open "UpperHalfPlane ModularForm SlashInvariantForm ModularFormClass CuspForm \
+  ModularForm.CuspForm EisensteinSeries"
+open scoped MatrixGroups ArithmeticFunction.sigma
+
+def RatQExp {k : ℤ} (f : ModularForm 𝒮ℒ k) : Prop :=
+  ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 f).coeff n = (q : ℂ)
+
+section RatCoeffClosure
+
+lemma ratCoeff_mul {p q : PowerSeries ℂ}
+    (hp : ∀ n : ℕ, ∃ a : ℚ, p.coeff n = (a : ℂ)) (hq : ∀ n : ℕ, ∃ a : ℚ, q.coeff n = (a : ℂ)) :
+    ∀ n : ℕ, ∃ a : ℚ, (p * q).coeff n = (a : ℂ) := by
+  choose F hF using hp
+  choose G hG using hq
+  intro n
+  refine ⟨∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, F ij.1 * G ij.2, ?_⟩
+  rw [PowerSeries.coeff_mul]
+  push_cast
+  exact Finset.sum_congr rfl fun ij _ => by rw [hF, hG]
+
+lemma ratCoeff_sub {p q : PowerSeries ℂ}
+    (hp : ∀ n : ℕ, ∃ a : ℚ, p.coeff n = (a : ℂ)) (hq : ∀ n : ℕ, ∃ a : ℚ, q.coeff n = (a : ℂ)) :
+    ∀ n : ℕ, ∃ a : ℚ, (p - q).coeff n = (a : ℂ) := by
+  intro n
+  obtain ⟨a, ha⟩ := hp n
+  obtain ⟨b, hb⟩ := hq n
+  exact ⟨a - b, by rw [map_sub, ha, hb]; push_cast; ring⟩
+
+end RatCoeffClosure
+
+section RatGenerators
+
+lemma ratCoeff_E {k : ℕ} (hk : 3 ≤ k) (hk2 : Even k) :
+    ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 (E hk)).coeff n = (q : ℂ) := by
+  intro n
+  rw [E_qExpansion_coeff hk hk2]
+  by_cases hn : n = 0
+  · exact ⟨1, by simp [hn]⟩
+  · refine ⟨-(2 * k / bernoulli k) * (σ (k - 1) n : ℚ), ?_⟩
+    rw [ite_eq_right hn]
+    push_cast
+    ring
+
+def eCubeSubESq : ModularForm 𝒮ℒ 12 :=
+  ModularForm.mcast (by decide) (E₄.pow 3) - ModularForm.mcast (by decide) (E₆.pow 2)
+
+lemma eCubeSubESq_qExpansion :
+    qExpansion 1 eCubeSubESq = qExpansion 1 E₄ * qExpansion 1 E₄ * qExpansion 1 E₄ -
+      qExpansion 1 E₆ * qExpansion 1 E₆ := by
+  simp only [eCubeSubESq, FunLike.coe_sub, ModularForm.coe_mcast,
+    ModularForm.qExpansion_sub one_pos one_mem_strictPeriods_SL,
+    ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+  ring
+
+lemma discriminant_eq_smul_eCubeSubESq :
+    ModularForm.discriminant = (1 / 1728 : ℂ) • eCubeSubESq := by
+  ext z
+  have h := discriminant_eq_E₄_cube_sub_E₆_sq z
+  simp only [Pi.smul_apply, eCubeSubESq, FunLike.coe_sub, Pi.sub_apply,
+    ModularForm.coe_mcast, ModularForm.coe_pow, Pi.pow_apply, smul_eq_mul]
+  rw [h]
+  ring
+
+lemma ratCoeff_discriminant :
+    ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 ModularForm.discriminant).coeff n = (q : ℂ) := by
+  have h4 : ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 E₄).coeff n = (q : ℂ) :=
+    ratCoeff_E (by norm_num) (by decide)
+  have h6 : ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 E₆).coeff n = (q : ℂ) :=
+    ratCoeff_E (by norm_num) (by decide)
+  have hmain := ratCoeff_sub (ratCoeff_mul (ratCoeff_mul h4 h4) h4) (ratCoeff_mul h6 h6)
+  intro n
+  obtain ⟨a, ha⟩ := hmain n
+  refine ⟨(1 / 1728 : ℚ) * a, ?_⟩
+  rw [discriminant_eq_smul_eCubeSubESq,
+    ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL,
+    PowerSeries.coeff_smul, eCubeSubESq_qExpansion, smul_eq_mul, ha]
+  push_cast
+  ring
+
+lemma ratQExp_one : RatQExp (1 : ModularForm 𝒮ℒ 0) := by
+  intro n
+  refine ⟨if n = 0 then 1 else 0, ?_⟩
+  rw [ModularForm.qExpansion_one, PowerSeries.coeff_one]
+  split <;> simp
+
+end RatGenerators
+
+section SpanTop
+
+lemma span_ratQExp_eq_top_of_forall_eq_zero {k : ℤ}
+    (h : ∀ f : ModularForm 𝒮ℒ k, f = 0) :
+    Submodule.span ℂ {f : ModularForm 𝒮ℒ k | RatQExp f} = ⊤ := by
+  rw [eq_top_iff]
+  rintro f -
+  rw [h f]
+  exact Submodule.zero_mem _
+
+theorem levelOne_ratSpan (k : ℤ) :
+    Submodule.span ℂ {f : ModularForm 𝒮ℒ k | RatQExp f} = ⊤ := by
+  suffices H : ∀ n : ℕ, ∀ k : ℤ, k.toNat = n →
+      Submodule.span ℂ {f : ModularForm 𝒮ℒ k | RatQExp f} = ⊤ from H k.toNat k rfl
+  intro n
+  induction n using Nat.strong_induction_on with
+  | _ n IH =>
+  intro k hk
+  rcases lt_or_ge k 0 with hneg | hpos
+  · exact span_ratQExp_eq_top_of_forall_eq_zero fun f => by
+      ext z
+      simpa using congrFun (ModularFormClass.levelOne_neg_weight_eq_zero hneg f) z
+  rcases Int.even_or_odd k with hev | hodd
+  swap
+  · exact span_ratQExp_eq_top_of_forall_eq_zero fun f =>
+      ModularForm.levelOne_odd_weight_eq_zero hodd f
+  rcases eq_or_ne k 0 with rfl | hk0
+  · rw [eq_top_iff]
+    rintro f -
+    obtain ⟨c, hc⟩ := ModularFormClass.levelOne_weight_zero_const f
+    have hf : f = c • (1 : ModularForm 𝒮ℒ 0) := by
+      ext z
+      simp [congrFun hc z, ModularForm.one_coe_eq_one]
+    rw [hf]
+    exact Submodule.smul_mem _ _ (Submodule.subset_span ratQExp_one)
+  rcases eq_or_ne k 2 with rfl | hk2
+  · refine span_ratQExp_eq_top_of_forall_eq_zero fun f => ?_
+    have : Subsingleton (ModularForm 𝒮ℒ 2) :=
+      rank_zero_iff.mp ModularForm.levelOne_weight_two_rank_zero
+    exact Subsingleton.elim f 0
+  have hk2' : k % 2 = 0 := Int.even_iff.mp hev
+  have hk4 : 4 ≤ k := by omega
+  have hm3 : 3 ≤ k.toNat := by omega
+  have hm2 : Even k.toNat := by rw [Nat.even_iff]; omega
+  set Ek : ModularForm 𝒮ℒ k := ModularForm.mcast (show ((k.toNat : ℤ)) = k by omega) (E hm3)
+    with hEkdef
+  have hEk_rat : RatQExp Ek := by
+    intro n
+    exact ratCoeff_E hm3 hm2 n
+  rw [eq_top_iff]
+  rintro f -
+  set c₀ := (qExpansion 1 f).coeff 0 with hc₀
+  have hcoe_sub : (⇑(f - c₀ • Ek) : ℍ → ℂ) = ⇑f - ⇑(c₀ • Ek) := by
+    simp []
+  have hcusp : (qExpansion 1 (⇑(f - c₀ • Ek) : ℍ → ℂ)).coeff 0 = 0 := by
+    rw [hcoe_sub, ModularForm.qExpansion_sub one_pos one_mem_strictPeriods_SL,
+      FunLike.coe_smul, ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL,
+      map_sub, PowerSeries.coeff_smul, hEkdef, ModularForm.qExpansion_mcast,
+      E_qExpansion_coeff_zero hm3 hm2, ← hc₀]
+    simp
+  set g : ModularForm 𝒮ℒ (k - 12) :=
+    CuspForm.discriminantEquiv (ModularForm.toCuspForm (f - c₀ • Ek) hcusp) with hgdef
+  set Ψ : ModularForm 𝒮ℒ (k - 12) →ₗ[ℂ] ModularForm 𝒮ℒ k :=
+    CuspForm.toModularFormₗ.comp CuspForm.discriminantEquiv.symm.toLinearMap with hΨdef
+  have hsymm : ∀ u : ModularForm 𝒮ℒ (k - 12),
+      CuspForm.discriminantEquiv.symm u = CuspForm.ofMulDiscriminant u := fun u =>
+    CuspForm.discriminantEquiv.symm_apply_eq.mpr (by
+      ext z
+      rw [CuspForm.discriminantEquiv_apply, CuspForm.ofMulDiscriminant_apply,
+        mul_div_cancel_left₀ _ (ModularForm.discriminant_ne_zero z)])
+  have hΨg : Ψ g = f - c₀ • Ek := by
+    rw [hΨdef, hgdef, LinearMap.comp_apply, LinearEquiv.coe_coe, LinearEquiv.symm_apply_apply]
+    ext z
+    simp [CuspForm.toModularFormₗ_apply, ModularForm.toCuspForm_apply]
+  have hΨrat : ∀ u : ModularForm 𝒮ℒ (k - 12), RatQExp u → RatQExp (Ψ u) := by
+    intro u hu
+    have hcoe : ⇑(Ψ u) = ⇑CuspForm.discriminant * ⇑u := by
+      funext z
+      rw [hΨdef, LinearMap.comp_apply, LinearEquiv.coe_coe, hsymm u]
+      simp [CuspForm.toModularFormₗ_apply, CuspForm.ofMulDiscriminant_apply,
+        CuspForm.coe_discriminant]
+    have hq : qExpansion 1 (Ψ u) = qExpansion 1 ModularForm.discriminant * qExpansion 1 u := by
+      calc qExpansion 1 (Ψ u) = qExpansion 1 (⇑CuspForm.discriminant * ⇑u) := by rw [hcoe]
+        _ = _ := ModularForm.qExpansion_mul_coe one_pos one_mem_strictPeriods_SL _ _
+    intro n
+    rw [hq]
+    exact ratCoeff_mul ratCoeff_discriminant hu n
+  have hg_mem : g ∈ Submodule.span ℂ {u : ModularForm 𝒮ℒ (k - 12) | RatQExp u} := by
+    rw [IH (k - 12).toNat (by omega) (k - 12) rfl]
+    exact Submodule.mem_top
+  have hΨg_mem : Ψ g ∈ Submodule.span ℂ {f : ModularForm 𝒮ℒ k | RatQExp f} := by
+    have h1 : Ψ g ∈ Submodule.map Ψ (Submodule.span ℂ {u : ModularForm 𝒮ℒ (k - 12) | RatQExp u}) :=
+      Submodule.mem_map_of_mem hg_mem
+    rw [Submodule.map_span] at h1
+    refine Submodule.span_mono ?_ h1
+    rintro _ ⟨u, hu, rfl⟩
+    exact hΨrat u hu
+  have hsplit : c₀ • Ek + Ψ g = f := by
+    rw [hΨg]
+    abel
+  rw [← hsplit]
+  exact Submodule.add_mem _
+    (Submodule.smul_mem _ _ (Submodule.subset_span hEk_rat)) hΨg_mem
+
+end SpanTop
+
+end A1_levelOne_ratSpan
+
+section A2_polynomial_j
+
+p2m_open "UpperHalfPlane ModularForm SlashInvariantForm ModularFormClass CuspForm \
+  ModularForm.CuspForm EisensteinSeries OnePoint Matrix.SpecialLinearGroup"
+
+open scoped MatrixGroups Manifold
+
+def j : ℍ → ℂ := fun z => E₄ z ^ 3 / ModularForm.discriminant z
+
+lemma j_mul_discriminant (z : ℍ) : j z * ModularForm.discriminant z = E₄ z ^ 3 :=
+  div_mul_cancel₀ _ (ModularForm.discriminant_ne_zero z)
+
+theorem modularForm_eq_poly_j_mul_discriminant_pow (m : ℕ) (F : ModularForm 𝒮ℒ (12 * m)) :
+    ∃ P : Polynomial ℂ, P.natDegree ≤ m ∧
+      ⇑F = fun z => Polynomial.eval (j z) P * ModularForm.discriminant z ^ m := by
+  induction m with
+  | zero =>
+    obtain ⟨c, hc⟩ := ModularFormClass.levelOne_weight_zero_const
+      (ModularForm.mcast (by norm_num) F : ModularForm 𝒮ℒ 0)
+    have hcoe : ⇑F = Function.const ℍ c := by rw [← hc]; rfl
+    refine ⟨Polynomial.C c, by simp, funext fun z => ?_⟩
+    rw [show F z = Function.const ℍ c z from congrFun hcoe z]
+    simp
+  | succ m IH =>
+    set G : ModularForm 𝒮ℒ (12 * ((m + 1 : ℕ) : ℤ)) :=
+      ModularForm.mcast (by push_cast; ring) (E₄.pow (3 * (m + 1))) with hGdef
+    have hG0 : (qExpansion 1 G).coeff 0 = 1 := by
+      rw [hGdef, ModularForm.qExpansion_mcast,
+        ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL,
+        PowerSeries.coeff_zero_eq_constantCoeff, map_pow,
+        ← PowerSeries.coeff_zero_eq_constantCoeff,
+        E_qExpansion_coeff_zero (by norm_num) ⟨2, rfl⟩, one_pow]
+    set c₀ := (qExpansion 1 F).coeff 0 with hc₀
+    have hcoe_sub : (⇑(F - c₀ • G) : ℍ → ℂ) = ⇑F - ⇑(c₀ • G) :=
+      FunLike.coe_sub F (c₀ • G)
+    have hcusp : (qExpansion 1 (⇑(F - c₀ • G) : ℍ → ℂ)).coeff 0 = 0 := by
+      rw [hcoe_sub, ModularForm.qExpansion_sub one_pos one_mem_strictPeriods_SL,
+        FunLike.coe_smul, ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL,
+        map_sub, PowerSeries.coeff_smul, hG0, ← hc₀]
+      simp
+    set F' : ModularForm 𝒮ℒ (12 * (m : ℤ)) :=
+      ModularForm.mcast (by push_cast; ring)
+        (CuspForm.discriminantEquiv (ModularForm.toCuspForm (F - c₀ • G) hcusp)) with hF'def
+    obtain ⟨P', hP'deg, hP'⟩ := IH F'
+    refine ⟨Polynomial.C c₀ * Polynomial.X ^ (m + 1) + P', ?_, funext fun z => ?_⟩
+    · refine (Polynomial.natDegree_add_le _ _).trans (max_le ?_ (hP'deg.trans (by omega)))
+      exact Polynomial.natDegree_C_mul_X_pow_le c₀ (m + 1)
+    · have hdecomp : F z = c₀ * G z + (F - c₀ • G) z := by
+        rw [sub_apply, smul_apply]
+        simp
+      have hGcoe : (⇑G : ℍ → ℂ) = (⇑E₄) ^ (3 * (m + 1)) := by
+        rw [show (⇑G : ℍ → ℂ) = ⇑(E₄.pow (3 * (m + 1))) from rfl, ModularForm.coe_pow]
+      have hGz : G z = E₄ z ^ (3 * (m + 1)) :=
+        (congrFun hGcoe z).trans (Pi.pow_apply _ _ _)
+      have hcusppart : (F - c₀ • G) z =
+          ModularForm.discriminant z * (Polynomial.eval (j z) P' *
+            ModularForm.discriminant z ^ m) := by
+        have hF'z : (CuspForm.discriminantEquiv
+            (ModularForm.toCuspForm (F - c₀ • G) hcusp)) z =
+            Polynomial.eval (j z) P' * ModularForm.discriminant z ^ m := by
+          rw [show (CuspForm.discriminantEquiv
+              (ModularForm.toCuspForm (F - c₀ • G) hcusp)) z = F' z from rfl]
+          exact congrFun hP' z
+        calc (F - c₀ • G) z
+            = (ModularForm.toCuspForm (F - c₀ • G) hcusp) z := rfl
+          _ = ModularForm.discriminant z * (CuspForm.discriminantEquiv
+              (ModularForm.toCuspForm (F - c₀ • G) hcusp)) z :=
+            (ModularForm.discriminant_mul_discriminantEquiv_apply _ z).symm
+          _ = _ := by rw [hF'z]
+      rw [hdecomp, hGz, hcusppart, pow_mul, show E₄ z ^ 3 = j z * ModularForm.discriminant z from
+        (j_mul_discriminant z).symm]
+      simp only [Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_C,
+        Polynomial.eval_pow, Polynomial.eval_X]
+      ring
+
+def discPowForm (m : ℕ) : ModularForm 𝒮ℒ (12 * m) :=
+  ModularForm.mcast (by ring) ((CuspForm.toModularFormₗ CuspForm.discriminant).pow m)
+
+lemma discPowForm_coe (m : ℕ) : ⇑(discPowForm m) = ⇑CuspForm.discriminant ^ m := by
+  funext z
+  simp [discPowForm, ModularForm.coe_mcast, ModularForm.coe_pow,
+    CuspForm.toModularFormₗ_apply]
+
+lemma holMulDiscPow_slash (m : ℕ) (h : ℍ → ℂ)
+    (hinv : ∀ γ : SL(2, ℤ), h ∣[(0 : ℤ)] γ = h) (γ : SL(2, ℤ)) :
+    (h * ⇑CuspForm.discriminant ^ m) ∣[(12 * m : ℤ)] γ =
+      h * ⇑CuspForm.discriminant ^ m := by
+  have hD : (⇑(discPowForm m) : ℍ → ℂ) ∣[(12 * m : ℤ)] (γ : GL (Fin 2) ℝ) = ⇑(discPowForm m) :=
+    (discPowForm m).slash_action_eq' _ ⟨γ, rfl⟩
+  rw [discPowForm_coe] at hD
+  calc (h * ⇑CuspForm.discriminant ^ m) ∣[(12 * m : ℤ)] γ
+      = (h * ⇑CuspForm.discriminant ^ m) ∣[((0 : ℤ) + 12 * m)] γ := by rw [zero_add]
+    _ = h ∣[(0 : ℤ)] γ * (⇑CuspForm.discriminant ^ m) ∣[(12 * m : ℤ)] γ :=
+        mul_slash_SL2 0 (12 * m) γ h _
+    _ = h * ⇑CuspForm.discriminant ^ m := by rw [hinv γ, SL_slash, hD]
+
+def holMulDiscPow (m : ℕ) (h : ℍ → ℂ) (hol : MDiff h)
+    (hinv : ∀ γ : SL(2, ℤ), h ∣[(0 : ℤ)] γ = h)
+    (hbd : IsBoundedAtImInfty (h * ⇑CuspForm.discriminant ^ m)) :
+    ModularForm 𝒮ℒ (12 * m) where
+  toFun := h * ⇑CuspForm.discriminant ^ m
+  slash_action_eq' := fun _ hγ => by
+    obtain ⟨γ, rfl⟩ := hγ
+    have h1 := holMulDiscPow_slash m h hinv γ
+    rw [SL_slash, show ((γ : GL (Fin 2) ℝ)) = mapGL ℝ γ from rfl] at h1
+    exact h1
+  holo' := hol.mul (by rw [← discPowForm_coe]; exact (discPowForm m).holo')
+  bdd_at_cusps' := fun {c} hc => by
+    rw [Subgroup.IsArithmetic.isCusp_iff_isCusp_SL2Z] at hc
+    rw [isBoundedAt_iff_forall_SL2Z hc]
+    intro γ _
+    rw [holMulDiscPow_slash m h hinv γ]
+    exact hbd
+
+theorem levelOne_holFn_eq_polynomial_j (m : ℕ) (h : ℍ → ℂ) (hol : MDiff h)
+    (hinv : ∀ γ : SL(2, ℤ), h ∣[(0 : ℤ)] γ = h)
+    (hbd : IsBoundedAtImInfty (h * ⇑CuspForm.discriminant ^ m)) :
+    ∃ P : Polynomial ℂ, P.natDegree ≤ m ∧ h = fun z => Polynomial.eval (j z) P := by
+  obtain ⟨P, hdeg, hP⟩ := modularForm_eq_poly_j_mul_discriminant_pow m
+    (holMulDiscPow m h hol hinv hbd)
+  refine ⟨P, hdeg, funext fun z => ?_⟩
+  have hz := congrFun hP z
+  have hΔ : ModularForm.discriminant z ^ m ≠ 0 :=
+    pow_ne_zero _ (ModularForm.discriminant_ne_zero z)
+  have hcancel : h z * ModularForm.discriminant z ^ m =
+      Polynomial.eval (j z) P * ModularForm.discriminant z ^ m := hz
+  exact mul_right_cancel₀ hΔ hcancel
+
+end A2_polynomial_j
+
+section A3_qexp_principle
+
+p2m_open "UpperHalfPlane ModularForm ModularFormClass CuspForm ModularForm.CuspForm \
+  EisensteinSeries"
+open scoped MatrixGroups
+
+lemma coeff_pow_eq_zero_of_lt {D : PowerSeries ℂ} (hD0 : D.coeff 0 = 0) {k n : ℕ}
+    (hn : n < k) : (D ^ k).coeff n = 0 := by
+  have hX : (PowerSeries.X : PowerSeries ℂ) ∣ D :=
+    PowerSeries.X_dvd_iff.mpr (by rwa [← PowerSeries.coeff_zero_eq_constantCoeff])
+  exact PowerSeries.X_pow_dvd_iff.mp (pow_dvd_pow_of_dvd hX k) n hn
+
+lemma coeff_pow_self {D : PowerSeries ℂ} (hD0 : D.coeff 0 = 0) (k : ℕ) :
+    (D ^ k).coeff k = (D.coeff 1) ^ k := by
+  induction k with
+  | zero => simp
+  | succ k ih =>
+    rw [pow_succ, PowerSeries.coeff_mul]
+    rw [Finset.sum_eq_single (k, 1)]
+    · rw [ih, pow_succ]
+    · rintro ⟨a, b⟩ hab hne
+      rw [Finset.HasAntidiagonal.mem_antidiagonal] at hab
+      have hab' : a + b = k + 1 := hab
+      rcases lt_or_ge a k with ha | ha
+      · rw [coeff_pow_eq_zero_of_lt hD0 ha, zero_mul]
+      · have hb : b = 0 ∨ b = 1 := by omega
+        rcases hb with rfl | rfl
+        · rw [hD0, mul_zero]
+        · have hak : a = k := by omega
+          exact absurd (by rw [hak]) hne
+    · intro hmem
+      exact absurd (Finset.HasAntidiagonal.mem_antidiagonal.mpr
+        (show (k, 1).1 + (k, 1).2 = k + 1 from rfl)) hmem
+
+lemma coeff_mul_pow_at_order {p D : PowerSeries ℂ} (hD0 : D.coeff 0 = 0) (k : ℕ) :
+    (p * D ^ k).coeff k = p.coeff 0 * (D.coeff 1) ^ k := by
+  rw [PowerSeries.coeff_mul, Finset.sum_eq_single (0, k)]
+  · rw [coeff_pow_self hD0]
+  · rintro ⟨a, b⟩ hab hne
+    rw [Finset.HasAntidiagonal.mem_antidiagonal] at hab
+    have hab' : a + b = k := hab
+    rcases Nat.lt_or_ge b k with h | h
+    · rw [coeff_pow_eq_zero_of_lt hD0 h, mul_zero]
+    · have ha0 : a = 0 := by omega
+      have hbk : b = k := by omega
+      subst ha0 hbk
+      exact absurd rfl hne
+  · intro hmem
+    exact absurd (Finset.HasAntidiagonal.mem_antidiagonal.mpr
+      (show (0, k).1 + (0, k).2 = k from Nat.zero_add k)) hmem
+
+lemma coeff_mul_pow_eq_zero_of_lt {p D : PowerSeries ℂ} (hD0 : D.coeff 0 = 0) {k n : ℕ}
+    (hn : n < k) : (p * D ^ k).coeff n = 0 := by
+  rw [PowerSeries.coeff_mul]
+  refine Finset.sum_eq_zero fun ⟨a, b⟩ hab => ?_
+  rw [Finset.HasAntidiagonal.mem_antidiagonal] at hab
+  have hab' : a + b = n := hab
+  rw [coeff_pow_eq_zero_of_lt hD0 (show b < k by omega), mul_zero]
+
+lemma ratCoeff_pow {p : PowerSeries ℂ} (hp : ∀ n : ℕ, ∃ a : ℚ, p.coeff n = (a : ℂ)) (k : ℕ) :
+    ∀ n : ℕ, ∃ a : ℚ, (p ^ k).coeff n = (a : ℂ) := by
+  induction k with
+  | zero =>
+    intro n
+    refine ⟨if n = 0 then 1 else 0, ?_⟩
+    rw [pow_zero, PowerSeries.coeff_one]
+    split <;> simp
+  | succ k ih =>
+    rw [pow_succ]
+    exact ratCoeff_mul ih hp
+
+def polyDiscSeries (m : ℕ) (P : Polynomial ℂ) : PowerSeries ℂ :=
+  ∑ i ∈ Finset.range (m + 1),
+    PowerSeries.C (P.coeff i) * (qExpansion 1 E₄) ^ (3 * i) *
+      (qExpansion 1 ModularForm.discriminant) ^ (m - i)
+
+lemma discriminant_qExpansion_coeff_zero :
+    (qExpansion 1 ModularForm.discriminant).coeff 0 = 0 :=
+  CuspFormClass.qExpansion_coeff_zero CuspForm.discriminant one_pos one_mem_strictPeriods_SL
+
+lemma triangular_aux (m : ℕ) :
+    ∀ d : ℕ, d ≤ m → ∀ c : ℕ → ℂ,
+      (∀ n : ℕ, ∃ q : ℚ, (∑ i ∈ Finset.range (d + 1),
+        PowerSeries.C (c i) * (qExpansion 1 E₄) ^ (3 * i) *
+          (qExpansion 1 ModularForm.discriminant) ^ (m - i)).coeff n = (q : ℂ)) →
+      ∀ i : ℕ, i ≤ d → ∃ q : ℚ, c i = (q : ℂ) := by
+  intro d
+  induction d with
+  | zero =>
+    intro _ c hser i hi
+    obtain rfl : i = 0 := Nat.le_zero.mp hi
+    obtain ⟨q, hq⟩ := hser m
+    refine ⟨q, ?_⟩
+    rw [Finset.sum_range_one, Nat.mul_zero, pow_zero, mul_one, Nat.sub_zero,
+      coeff_mul_pow_at_order discriminant_qExpansion_coeff_zero,
+      ModularForm.discriminant_qExpansion_coeff_one, one_pow, mul_one,
+      PowerSeries.coeff_zero_C] at hq
+    exact hq
+  | succ d ihd =>
+    intro hd1 c hser
+    have htop : ∃ q : ℚ, c (d + 1) = (q : ℂ) := by
+      obtain ⟨q, hq⟩ := hser (m - (d + 1))
+      refine ⟨q, ?_⟩
+      rw [Finset.sum_range_succ, map_add] at hq
+      have hlow : (∑ i ∈ Finset.range (d + 1),
+          PowerSeries.C (c i) * (qExpansion 1 E₄) ^ (3 * i) *
+            (qExpansion 1 ModularForm.discriminant) ^ (m - i)).coeff (m - (d + 1)) = 0 := by
+        rw [map_sum]
+        refine Finset.sum_eq_zero fun i hi' => ?_
+        rw [Finset.mem_range] at hi'
+        exact coeff_mul_pow_eq_zero_of_lt discriminant_qExpansion_coeff_zero (by omega)
+      rw [hlow, zero_add, coeff_mul_pow_at_order discriminant_qExpansion_coeff_zero,
+        ModularForm.discriminant_qExpansion_coeff_one, one_pow, mul_one,
+        PowerSeries.coeff_C_mul, PowerSeries.coeff_zero_eq_constantCoeff, map_pow,
+        ← PowerSeries.coeff_zero_eq_constantCoeff,
+        E_qExpansion_coeff_zero (by norm_num) ⟨2, rfl⟩, one_pow, mul_one] at hq
+      exact hq
+    intro i hi
+    rcases Nat.lt_or_ge i (d + 1) with hil | hig
+    · obtain ⟨qt, hqt⟩ := htop
+      refine ihd (by omega) c (fun n => ?_) i (by omega)
+      obtain ⟨q, hq⟩ := hser n
+      have hterm : ∀ n' : ℕ, ∃ q' : ℚ, (PowerSeries.C (c (d + 1)) *
+          (qExpansion 1 E₄) ^ (3 * (d + 1)) *
+          (qExpansion 1 ModularForm.discriminant) ^ (m - (d + 1))).coeff n' = (q' : ℂ) := by
+        refine ratCoeff_mul (ratCoeff_mul ?_
+          (ratCoeff_pow (ratCoeff_E (by norm_num) (by decide)) _))
+          (ratCoeff_pow ratCoeff_discriminant _)
+        intro n'
+        refine ⟨if n' = 0 then qt else 0, ?_⟩
+        rw [PowerSeries.coeff_C]
+        split <;> simp [hqt]
+      obtain ⟨q', hq'⟩ := hterm n
+      refine ⟨q - q', ?_⟩
+      rw [Finset.sum_range_succ, map_add, hq'] at hq
+      rw [eq_sub_of_add_eq hq]
+      push_cast
+      ring
+    · obtain rfl : i = d + 1 := by omega
+      exact htop
+
+theorem levelOne_qexp_principle (m : ℕ) (P : Polynomial ℂ) (hdeg : P.natDegree ≤ m)
+    (hrat : ∀ n : ℕ, ∃ q : ℚ, (polyDiscSeries m P).coeff n = (q : ℂ)) :
+    ∀ i : ℕ, ∃ q : ℚ, P.coeff i = (q : ℂ) := by
+  intro i
+  rcases Nat.lt_or_ge m i with him | him
+  · exact ⟨0, by rw [Polynomial.coeff_eq_zero_of_natDegree_lt (by omega)]; simp⟩
+  · refine triangular_aux m m le_rfl (fun i => P.coeff i) (fun n => ?_) i him
+    simpa [polyDiscSeries] using hrat n
+
+end A3_qexp_principle
+
+section A4_j_surjective
+
+p2m_open "UpperHalfPlane ModularForm SlashInvariantForm SlashInvariantFormClass ModularFormClass \
+  CuspForm ModularForm.CuspForm EisensteinSeries OnePoint Matrix.SpecialLinearGroup Filter"
+
+open scoped MatrixGroups Manifold Topology
+
+lemma toModularFormDisc_coe :
+    (⇑(CuspForm.toModularFormₗ CuspForm.discriminant) : ℍ → ℂ) = ModularForm.discriminant := by
+  funext z
+  rw [CuspForm.toModularFormₗ_apply]
+  exact congrFun CuspForm.coe_discriminant z
+
+theorem j_surjective : Function.Surjective j := by
+  intro c
+  by_contra hc
+  push Not at hc
+  set Fc : ModularForm 𝒮ℒ 12 :=
+    ModularForm.mcast (by decide) (E₄.pow 3) -
+      c • CuspForm.toModularFormₗ CuspForm.discriminant with hFdef
+  have hFapp : ∀ z : ℍ, Fc z = E₄ z ^ 3 - c * ModularForm.discriminant z := by
+    intro z
+    rw [hFdef, sub_apply, smul_apply, smul_eq_mul,
+      CuspForm.toModularFormₗ_apply, congrFun CuspForm.coe_discriminant z,
+      show (ModularForm.mcast (by decide) (E₄.pow 3) : ModularForm 𝒮ℒ 12) z = E₄ z ^ 3 from
+        (congrFun (ModularForm.coe_pow E₄ 3) z).trans (Pi.pow_apply _ _ _)]
+  have hnv : ∀ z : ℍ, Fc z ≠ 0 := by
+    intro z h0
+    rw [hFapp z, sub_eq_zero] at h0
+    refine hc z ?_
+    change E₄ z ^ 3 / ModularForm.discriminant z = c
+    rw [h0, mul_div_cancel_right₀ _ (ModularForm.discriminant_ne_zero z)]
+  have hF0 : (qExpansion 1 Fc).coeff 0 = 1 := by
+    rw [hFdef, FunLike.coe_sub,
+      ModularForm.qExpansion_sub one_pos one_mem_strictPeriods_SL,
+      FunLike.coe_smul, ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL,
+      map_sub, PowerSeries.coeff_smul, ModularForm.qExpansion_mcast,
+      ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL,
+      PowerSeries.coeff_zero_eq_constantCoeff, map_pow,
+      ← PowerSeries.coeff_zero_eq_constantCoeff,
+      E_qExpansion_coeff_zero (by norm_num) ⟨2, rfl⟩, one_pow]
+    rw [show (qExpansion 1 (⇑(CuspForm.toModularFormₗ CuspForm.discriminant) : ℍ → ℂ)).coeff 0
+        = 0 from toModularFormDisc_coe ▸ discriminant_qExpansion_coeff_zero]
+    simp
+  set hfn : ℍ → ℂ := ⇑CuspForm.discriminant / ⇑Fc with hhdef
+  have hol : MDiff hfn := CuspForm.discriminant.holo'.div Fc.holo' hnv
+  have hinv : ∀ γ : SL(2, ℤ), hfn ∣[(0 : ℤ)] γ = hfn := by
+    intro γ
+    have hγ : (γ : GL (Fin 2) ℝ) ∈ 𝒮ℒ := ⟨γ, rfl⟩
+    rw [hhdef, show (0 : ℤ) = 12 - 12 by norm_num, div_slash_SL2, SL_slash, SL_slash,
+      slash_action_eqn _ _ hγ, slash_action_eqn _ _ hγ]
+  have hper := periodic_comp_ofComplex Fc one_mem_strictPeriods_SL
+  have hanal := ModularFormClass.analyticAt_cuspFunction_zero Fc one_pos one_mem_strictPeriods_SL
+  have htends : Tendsto ⇑Fc atImInfty (𝓝 (cuspFunction 1 ⇑Fc 0)) :=
+    (hanal.continuousAt.tendsto.comp (qParam_tendsto_atImInfty one_pos)).congr
+      (fun τ => SlashInvariantFormClass.eq_cuspFunction Fc τ one_mem_strictPeriods_SL one_ne_zero)
+  have hcusp0 : cuspFunction 1 ⇑Fc 0 = 1 := by
+    have h1 := qExpansion_coeff_zero one_pos hanal hper
+    have h2 := cuspFunction_apply_zero one_pos hanal hper
+    rw [h2, ← h1]
+    exact hF0
+  rw [hcusp0] at htends
+  have hbd : IsBoundedAtImInfty hfn := by
+    have hΔ0 : IsZeroAtImInfty (⇑CuspForm.discriminant : ℍ → ℂ) :=
+      CuspFormClass.zero_at_infty CuspForm.discriminant
+    have hFinv : Tendsto (fun z : ℍ => (Fc z)⁻¹) atImInfty (𝓝 (1 : ℂ)⁻¹) :=
+      htends.inv₀ one_ne_zero
+    have h1 : ((⇑CuspForm.discriminant : ℍ → ℂ)) =O[atImInfty] (fun _ => (1 : ℝ)) :=
+      hΔ0.boundedAtFilter
+    have h2 : (fun z : ℍ => (Fc z)⁻¹) =O[atImInfty] (fun _ => (1 : ℝ)) :=
+      hFinv.isBigO_one ℝ
+    have h3 : hfn = fun z => CuspForm.discriminant z * (Fc z)⁻¹ := by
+      funext z
+      rw [hhdef]
+      exact div_eq_mul_inv _ _
+    rw [IsBoundedAtImInfty, BoundedAtFilter, h3]
+    have h4 := h1.mul h2
+    simp only [one_mul] at h4
+    exact h4
+  have hbd' : IsBoundedAtImInfty (hfn * ⇑CuspForm.discriminant ^ 0) := by
+    rw [show hfn * ⇑CuspForm.discriminant ^ 0 = hfn from by funext z; simp]
+    exact hbd
+  obtain ⟨c', hc'⟩ := ModularFormClass.levelOne_weight_zero_const
+    (ModularForm.mcast (by norm_num) (holMulDiscPow 0 hfn hol hinv hbd') : ModularForm 𝒮ℒ 0)
+  have hconst : ∀ z : ℍ, CuspForm.discriminant z / Fc z = c' := by
+    intro z
+    have := congrFun hc' z
+    rw [show (ModularForm.mcast (by norm_num) (holMulDiscPow 0 hfn hol hinv hbd') :
+        ModularForm 𝒮ℒ 0) z = (hfn * ⇑CuspForm.discriminant ^ 0) z from rfl] at this
+    simpa [hhdef] using this
+  have hΔI : CuspForm.discriminant UpperHalfPlane.I ≠ 0 := by
+    rw [congrFun CuspForm.coe_discriminant UpperHalfPlane.I]
+    exact ModularForm.discriminant_ne_zero _
+  have hc'0 : c' ≠ 0 := by
+    intro h0
+    rw [h0] at hconst
+    exact hΔI (by
+      have := hconst UpperHalfPlane.I
+      rwa [div_eq_zero_iff, or_iff_left (hnv UpperHalfPlane.I)] at this)
+  have hFceq : (⇑Fc : ℍ → ℂ) = c'⁻¹ • ⇑CuspForm.discriminant := by
+    funext z
+    have := hconst z
+    rw [div_eq_iff (hnv z)] at this
+    rw [Pi.smul_apply, smul_eq_mul]
+    field_simp [hc'0]
+    linear_combination -this
+  have hcontra : (qExpansion 1 Fc).coeff 0 = 0 := by
+    rw [hFceq, qExpansion_smul (ModularFormClass.analyticAt_cuspFunction_zero
+        CuspForm.discriminant one_pos one_mem_strictPeriods_SL) c'⁻¹,
+      PowerSeries.coeff_smul, CuspFormClass.qExpansion_coeff_zero CuspForm.discriminant
+        one_pos one_mem_strictPeriods_SL]
+    simp
+  rw [hF0] at hcontra
+  exact one_ne_zero hcontra
+
+end A4_j_surjective
+
+section R2WidthCopy
+
+p2m_open "UpperHalfPlane ModularForm ModularFormClass CuspForm ModularForm.CuspForm Polynomial \
+  Real.Polynomial Filter"
+open scoped Manifold MatrixGroups
+
+lemma qParam_one_eq_pow {N : ℕ} (hN : N ≠ 0) (τ : ℂ) :
+    Function.Periodic.qParam 1 τ = Function.Periodic.qParam N τ ^ N := by
+  have : (N : ℂ) ≠ 0 := by exact_mod_cast hN
+  simp only [Function.Periodic.qParam, Complex.ofReal_one, div_one, Complex.ofReal_natCast]
+  rw [← Complex.exp_nat_mul]
+  congr 1
+  field_simp
+
+private theorem _root_.WLight.qExpansion_coeff_width (f : ℍ → ℂ) {N : ℕ} (hN : N ≠ 0)
+    (hper : Function.Periodic (f ∘ ofComplex) 1) (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f)
+    (hbd : IsBoundedAtImInfty f) (n : ℕ) :
+    (qExpansion N f).coeff n =
+      if N ∣ n then (qExpansion 1 f).coeff (n / N) else 0 := by
+  have hN' : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero hN
+  have hperN : Function.Periodic (f ∘ ofComplex) N := by
+    simpa using hper.nat_mul N
+  let f' : C(ℍ, ℂ) := ⟨f, hhol.continuous⟩
+  have hfan : AnalyticAt ℂ (cuspFunction N f') 0 :=
+    analyticAt_cuspFunction_zero hN' hperN hhol hbd
+  set c : ℕ → ℂ := fun n ↦ if N ∣ n then (qExpansion 1 f).coeff (n / N) else 0 with hc
+  have hf : ∀ τ : ℍ, HasSum (fun m ↦ c m • Function.Periodic.qParam N τ ^ m) (f' τ) := by
+    intro τ
+    have h1 := hasSum_qExpansion one_pos hper hhol hbd τ
+    have hinj : Function.Injective fun m : ℕ ↦ N * m := fun a b h ↦ by
+      simpa [Nat.mul_right_inj hN] using h
+    refine (hinj.hasSum_iff (f := fun m ↦ c m • Function.Periodic.qParam N τ ^ m) ?_).mp ?_
+    · intro x hx
+      have : ¬ N ∣ x := fun ⟨k, hk⟩ ↦ hx ⟨k, hk.symm⟩
+      simp [hc, this]
+    · refine h1.congr_fun fun m ↦ ?_
+      simp only [Function.comp_apply, hc, Nat.dvd_mul_right, ite_true,
+        Nat.mul_div_cancel_left _ (Nat.pos_of_ne_zero hN), qParam_one_eq_pow hN, ← pow_mul]
+  exact (qExpansion_coeff_unique f' hN' hfan hf n).symm
+
+p2m_export "WLight" "qExpansion_coeff_width"
+end R2WidthCopy
+
+section C6_width
+
+open scoped UpperHalfPlane Manifold MatrixGroups
+p2m_open "UpperHalfPlane~I"
+open SlashInvariantFormClass ModularFormClass
+
+namespace ModularFormClass
+private theorem _root_.WLight.ModularFormClass.qExpansion_coeff_width {F : Type*} [FunLike F ℍ ℂ]
+    {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [ModularFormClass F Γ k] (f : F)
+    (h1 : (1 : ℝ) ∈ Γ.strictPeriods) {N : ℕ} (hN : N ≠ 0) (n : ℕ) :
+    (qExpansion N f).coeff n = if N ∣ n then (qExpansion 1 f).coeff (n / N) else 0 := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Γ.isCusp_of_mem_strictPeriods one_pos h1⟩
+  exact WLight.qExpansion_coeff_width f hN (by simpa using periodic_comp_ofComplex f h1)
+    (ModularFormClass.holo f) (ModularFormClass.bdd_at_infty f) n
+
+end ModularFormClass
+p2m_export "WLight" "ModularFormClass.qExpansion_coeff_width"
+end C6_width
+
+section BoundedFurniture
+
+p2m_open "UpperHalfPlane ModularForm \
+  P2MW.S_WLight_levelOne_hauptmodul_package.WLight.ModularFormClass CuspForm ModularForm.CuspForm \
+  Polynomial Real.Polynomial Filter"
+open scoped Manifold MatrixGroups
+
+def PoleBounded (f : ℍ → ℂ) : Prop :=
+  MDiff f ∧ ∃ m : ℕ, IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m)
+
+lemma isBoundedAtImInfty_discriminant : IsBoundedAtImInfty (⇑CuspForm.discriminant : ℍ → ℂ) :=
+  (CuspFormClass.zero_at_infty CuspForm.discriminant).boundedAtFilter
+
+lemma isBoundedAtImInfty_discPow (n : ℕ) :
+    IsBoundedAtImInfty (⇑CuspForm.discriminant ^ n : ℍ → ℂ) := by
+  induction n with
+  | zero => exact pow_zero (⇑CuspForm.discriminant : ℍ → ℂ) ▸ const_boundedAtFilter _ (1 : ℂ)
+  | succ k ih =>
+    rw [pow_succ]
+    exact ih.mul isBoundedAtImInfty_discriminant
+
+lemma IsBoundedAtImInfty.mul_discPow_mono {f : ℍ → ℂ} {m m' : ℕ} (hm : m ≤ m')
+    (h : IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m)) :
+    IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m') := by
+  have hshape : (f * ⇑CuspForm.discriminant ^ m' : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m) * ⇑CuspForm.discriminant ^ (m' - m) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply]
+    rw [mul_assoc, ← pow_add, Nat.add_sub_cancel' hm]
+  rw [hshape]
+  exact h.mul (isBoundedAtImInfty_discPow (m' - m))
+
+end BoundedFurniture
+
+section A3K
+
+p2m_open "UpperHalfPlane ModularForm \
+  P2MW.S_WLight_levelOne_hauptmodul_package.WLight.ModularFormClass CuspForm ModularForm.CuspForm \
+  EisensteinSeries"
+open scoped MatrixGroups
+
+variable (k : Subfield ℂ)
+
+lemma kCoeff_mul {p q : PowerSeries ℂ} (hp : ∀ n : ℕ, p.coeff n ∈ k)
+    (hq : ∀ n : ℕ, q.coeff n ∈ k) : ∀ n : ℕ, (p * q).coeff n ∈ k := by
+  intro n
+  rw [PowerSeries.coeff_mul]
+  exact sum_mem fun ij _ => mul_mem (hp ij.1) (hq ij.2)
+
+lemma kCoeff_pow {p : PowerSeries ℂ} (hp : ∀ n : ℕ, p.coeff n ∈ k) (m : ℕ) :
+    ∀ n : ℕ, (p ^ m).coeff n ∈ k := by
+  induction m with
+  | zero =>
+    intro n
+    rw [pow_zero, PowerSeries.coeff_one]
+    split <;> simp [one_mem, zero_mem]
+  | succ m ih =>
+    rw [pow_succ]
+    exact kCoeff_mul k ih hp
+
+lemma kCoeff_of_rat {p : PowerSeries ℂ} (hp : ∀ n : ℕ, ∃ q : ℚ, p.coeff n = (q : ℂ)) :
+    ∀ n : ℕ, p.coeff n ∈ k := by
+  intro n
+  obtain ⟨q, hq⟩ := hp n
+  rw [hq]
+  exact SubfieldClass.ratCast_mem k q
+
+lemma kCoeff_E4 : ∀ n : ℕ, (qExpansion 1 E₄).coeff n ∈ k :=
+  kCoeff_of_rat k (ratCoeff_E (by norm_num) (by decide))
+
+lemma kCoeff_discriminant : ∀ n : ℕ, (qExpansion 1 ModularForm.discriminant).coeff n ∈ k :=
+  kCoeff_of_rat k ratCoeff_discriminant
+
+lemma triangular_aux_mem (m : ℕ) :
+    ∀ d : ℕ, d ≤ m → ∀ c : ℕ → ℂ,
+      (∀ n : ℕ, (∑ i ∈ Finset.range (d + 1),
+        PowerSeries.C (c i) * (qExpansion 1 E₄) ^ (3 * i) *
+          (qExpansion 1 ModularForm.discriminant) ^ (m - i)).coeff n ∈ k) →
+      ∀ i : ℕ, i ≤ d → c i ∈ k := by
+  intro d
+  induction d with
+  | zero =>
+    intro _ c hser i hi
+    obtain rfl : i = 0 := Nat.le_zero.mp hi
+    have hq := hser m
+    rwa [Finset.sum_range_one, Nat.mul_zero, pow_zero, mul_one, Nat.sub_zero,
+      coeff_mul_pow_at_order discriminant_qExpansion_coeff_zero,
+      ModularForm.discriminant_qExpansion_coeff_one, one_pow, mul_one,
+      PowerSeries.coeff_zero_C] at hq
+  | succ d ihd =>
+    intro hd1 c hser
+    have htop : c (d + 1) ∈ k := by
+      have hq := hser (m - (d + 1))
+      rw [Finset.sum_range_succ, map_add] at hq
+      have hlow : (∑ i ∈ Finset.range (d + 1),
+          PowerSeries.C (c i) * (qExpansion 1 E₄) ^ (3 * i) *
+            (qExpansion 1 ModularForm.discriminant) ^ (m - i)).coeff (m - (d + 1)) = 0 := by
+        rw [map_sum]
+        refine Finset.sum_eq_zero fun i hi' => ?_
+        rw [Finset.mem_range] at hi'
+        exact coeff_mul_pow_eq_zero_of_lt discriminant_qExpansion_coeff_zero (by omega)
+      rwa [hlow, zero_add, coeff_mul_pow_at_order discriminant_qExpansion_coeff_zero,
+        ModularForm.discriminant_qExpansion_coeff_one, one_pow, mul_one,
+        PowerSeries.coeff_C_mul, PowerSeries.coeff_zero_eq_constantCoeff, map_pow,
+        ← PowerSeries.coeff_zero_eq_constantCoeff,
+        E_qExpansion_coeff_zero (by norm_num) ⟨2, rfl⟩, one_pow, mul_one] at hq
+    intro i hi
+    rcases Nat.lt_or_ge i (d + 1) with hil | hig
+    · refine ihd (by omega) c (fun n => ?_) i (by omega)
+      have hq := hser n
+      have hterm : (PowerSeries.C (c (d + 1)) *
+          (qExpansion 1 E₄) ^ (3 * (d + 1)) *
+          (qExpansion 1 ModularForm.discriminant) ^ (m - (d + 1))).coeff n ∈ k := by
+        refine kCoeff_mul k (kCoeff_mul k ?_ (kCoeff_pow k (kCoeff_E4 k) _))
+          (kCoeff_pow k (kCoeff_discriminant k) _) n
+        intro n'
+        rw [PowerSeries.coeff_C]
+        split
+        · exact htop
+        · exact zero_mem k
+      rw [Finset.sum_range_succ, map_add] at hq
+      have := sub_mem hq hterm
+      rwa [add_sub_cancel_right] at this
+    · obtain rfl : i = d + 1 := by omega
+      exact htop
+
+theorem levelOne_qexp_principle_mem (m : ℕ) (P : Polynomial ℂ) (hdeg : P.natDegree ≤ m)
+    (hrat : ∀ n : ℕ, (polyDiscSeries m P).coeff n ∈ k) :
+    ∀ i : ℕ, P.coeff i ∈ k := by
+  intro i
+  rcases Nat.lt_or_ge m i with him | him
+  · rw [Polynomial.coeff_eq_zero_of_natDegree_lt (by omega)]
+    exact zero_mem k
+  · refine triangular_aux_mem k m m le_rfl (fun i => P.coeff i) (fun n => ?_) i him
+    simpa [polyDiscSeries] using hrat n
+
+end A3K
+
+section KBridge
+
+p2m_open "UpperHalfPlane ModularForm \
+  P2MW.S_WLight_levelOne_hauptmodul_package.WLight.ModularFormClass CuspForm ModularForm.CuspForm \
+  Polynomial Real.Polynomial"
+open scoped MatrixGroups
+
+noncomputable def polyDiscForm (m : ℕ) (P : Polynomial ℂ) : ModularForm 𝒮ℒ (12 * m) :=
+  ∑ i ∈ (Finset.range (m + 1)).attach,
+    P.coeff i.1 • ModularForm.mcast
+      (by
+        have hi := Finset.mem_range.mp i.2
+        rw [Nat.cast_sub (by omega : i.1 ≤ m)]
+        push_cast
+        ring)
+      ((E₄.pow (3 * i.1)).mul (discPowForm (m - i.1)))
+
+lemma polyDiscForm_term_apply {m i : ℕ} (c : ℂ)
+    (h : ((3 * i : ℕ) : ℤ) * 4 + 12 * ((m - i : ℕ) : ℤ) = 12 * (m : ℤ)) (τ : ℍ) :
+    (c • ModularForm.mcast h ((E₄.pow (3 * i)).mul (discPowForm (m - i)))) τ =
+      c * (E₄ τ ^ (3 * i) * CuspForm.discriminant τ ^ (m - i)) := by
+  rw [smul_apply, smul_eq_mul,
+    congrFun (ModularForm.coe_mcast h _) τ,
+    congrFun (ModularForm.coe_mul _ _) τ, Pi.mul_apply,
+    congrFun (ModularForm.coe_pow E₄ (3 * i)) τ, Pi.pow_apply,
+    congrFun (discPowForm_coe (m - i)) τ, Pi.pow_apply]
+
+lemma polyDiscForm_coe {m : ℕ} {P : Polynomial ℂ} (hdeg : P.natDegree ≤ m) :
+    ⇑(polyDiscForm m P) =
+      (fun τ : ℍ => Polynomial.eval (j τ) P) * ⇑CuspForm.discriminant ^ m := by
+  funext τ
+  have hΔ0 : CuspForm.discriminant τ ≠ 0 := by
+    rw [congrFun CuspForm.coe_discriminant τ]
+    exact ModularForm.discriminant_ne_zero τ
+  have hsum : (polyDiscForm m P) τ = ∑ i ∈ (Finset.range (m + 1)).attach,
+      P.coeff i.1 * (E₄ τ ^ (3 * i.1) * CuspForm.discriminant τ ^ (m - i.1)) := by
+    rw [polyDiscForm, ← FunLike.coeAddMonoidHom_apply (F := ModularForm 𝒮ℒ (12 * m)), map_sum]
+    rw [Finset.sum_apply]
+    exact Finset.sum_congr rfl fun i _ => polyDiscForm_term_apply _ _ τ
+  rw [hsum, Pi.mul_apply, Pi.pow_apply]
+  rw [Polynomial.eval_eq_sum_range' (Nat.lt_succ_of_le hdeg), Finset.sum_mul,
+    Finset.sum_attach (Finset.range (m + 1))
+      (fun i => P.coeff i * (E₄ τ ^ (3 * i) * CuspForm.discriminant τ ^ (m - i)))]
+  refine Finset.sum_congr rfl fun i hi => ?_
+  have him : i ≤ m := by
+    rw [Finset.mem_range] at hi
+    omega
+  have hj : j τ = E₄ τ ^ 3 / CuspForm.discriminant τ := by
+    rw [j, congrFun CuspForm.coe_discriminant τ]
+  rw [hj, div_pow, ← pow_mul, mul_comm 3 i,
+    show CuspForm.discriminant τ ^ m = CuspForm.discriminant τ ^ i *
+      CuspForm.discriminant τ ^ (m - i) from by rw [← pow_add, Nat.add_sub_cancel' him]]
+  have hcancel : E₄ τ ^ (i * 3) / CuspForm.discriminant τ ^ i *
+      (CuspForm.discriminant τ ^ i * CuspForm.discriminant τ ^ (m - i)) =
+      E₄ τ ^ (i * 3) * CuspForm.discriminant τ ^ (m - i) := by
+    rw [div_mul_eq_mul_div, mul_comm (CuspForm.discriminant τ ^ i) _, ← mul_assoc,
+      mul_div_assoc, div_self (pow_ne_zero i hΔ0), mul_one]
+  rw [mul_assoc, hcancel]
+
+lemma qExpansion_finset_sum {ι : Type*} (s : Finset ι) {w : ℤ}
+    (f : ι → ModularForm 𝒮ℒ w) :
+    qExpansion 1 ((∑ i ∈ s, f i : ModularForm 𝒮ℒ w)) = ∑ i ∈ s, qExpansion 1 (f i) := by
+  induction s using Finset.cons_induction with
+  | empty => simpa using qExpansion_zero 1
+  | cons a s ha ih =>
+    rw [Finset.sum_cons, Finset.sum_cons, ← ih]
+    exact ModularForm.qExpansion_add one_pos one_mem_strictPeriods_SL (f a) (∑ i ∈ s, f i)
+
+theorem qExpansion_polyDiscForm (m : ℕ) (P : Polynomial ℂ) :
+    qExpansion 1 (polyDiscForm m P) = polyDiscSeries m P := by
+  rw [polyDiscForm, qExpansion_finset_sum, polyDiscSeries,
+    ← Finset.sum_attach (Finset.range (m + 1))
+      (fun i => PowerSeries.C (P.coeff i) * (qExpansion 1 E₄) ^ (3 * i) *
+        (qExpansion 1 ModularForm.discriminant) ^ (m - i))]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [FunLike.coe_smul,
+    ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL,
+    ModularForm.qExpansion_mcast,
+    ModularForm.qExpansion_mul one_pos one_mem_strictPeriods_SL,
+    ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+  have hdisc : qExpansion 1 (discPowForm (m - i.1)) =
+      (qExpansion 1 ModularForm.discriminant) ^ (m - i.1) := by
+    rw [discPowForm, ModularForm.qExpansion_mcast,
+      ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+    have hco : (⇑(CuspForm.toModularFormₗ CuspForm.discriminant) : ℍ → ℂ) =
+        ModularForm.discriminant := by
+      funext z
+      rw [CuspForm.toModularFormₗ_apply]
+      exact congrFun CuspForm.coe_discriminant z
+    rw [hco]
+  rw [hdisc]
+  ext n
+  rw [PowerSeries.coeff_smul, smul_eq_mul, mul_assoc, PowerSeries.coeff_C_mul]
+
+end KBridge
+
+section KPoleSec
+
+p2m_open "UpperHalfPlane ModularForm \
+  P2MW.S_WLight_levelOne_hauptmodul_package.WLight.ModularFormClass CuspForm ModularForm.CuspForm \
+  Polynomial Real.Polynomial Filter"
+open scoped MatrixGroups Manifold
+
+variable {N : ℕ}
+
+lemma mem_of_rat (K : IntermediateField ℚ ℂ) {x : ℂ} (h : ∃ q : ℚ, x = (q : ℂ)) : x ∈ K := by
+  obtain ⟨q, rfl⟩ := h
+  exact SubfieldClass.ratCast_mem K q
+
+def KPoleAt (K : IntermediateField ℚ ℂ) (N m : ℕ) (f : ℍ → ℂ) : Prop :=
+  Function.Periodic ((f * ⇑CuspForm.discriminant ^ m) ∘ ofComplex) N ∧
+    IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m) ∧
+    ∀ n : ℕ, (qExpansion N (f * ⇑CuspForm.discriminant ^ m)).coeff n ∈ K
+
+def KPole (K : IntermediateField ℚ ℂ) (N : ℕ) (f : ℍ → ℂ) : Prop :=
+  MDiff f ∧ ∃ m : ℕ, KPoleAt K N m f
+
+lemma periodic_one_fn (c : ℝ) : Function.Periodic ((1 : ℍ → ℂ) ∘ ofComplex) c := fun _ => rfl
+
+lemma periodic_discPow_comp_ofComplex (k : ℕ) (N : ℕ) :
+    Function.Periodic ((⇑CuspForm.discriminant ^ k : ℍ → ℂ) ∘ ofComplex) N := by
+  have h1 : Function.Periodic (⇑CuspForm.discriminant ∘ ofComplex) 1 :=
+    SlashInvariantFormClass.periodic_comp_ofComplex CuspForm.discriminant
+      one_mem_strictPeriods_SL
+  have hk : Function.Periodic ((⇑CuspForm.discriminant ^ k : ℍ → ℂ) ∘ ofComplex) 1 := by
+    induction k with
+    | zero => exact periodic_one_fn 1
+    | succ k ih =>
+      intro x
+      have hx := (ih.mul h1) x
+      simp only [Function.comp_apply, Pi.mul_apply, Pi.pow_apply] at hx ⊢
+      rw [pow_succ, pow_succ]
+      exact hx
+  simpa using hk.nat_mul N
+
+lemma mdiff_discPow (k : ℕ) : MDiff (⇑CuspForm.discriminant ^ k : ℍ → ℂ) := by
+  rw [← discPowForm_coe]
+  exact (discPowForm k).holo'
+
+lemma mdiff_mul_discPow {f : ℍ → ℂ} (hf : MDiff f) (m : ℕ) :
+    MDiff (f * ⇑CuspForm.discriminant ^ m : ℍ → ℂ) :=
+  hf.mul (mdiff_discPow m)
+
+lemma analyticAt_cuspFunction_zero_of [NeZero N] {g : ℍ → ℂ} (hhol : MDiff g)
+    (hper : Function.Periodic (g ∘ ofComplex) N) (hbd : IsBoundedAtImInfty g) :
+    AnalyticAt ℂ (cuspFunction N g) 0 :=
+  analyticAt_cuspFunction_zero
+    (by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)) hper hhol hbd
+
+lemma qExpansion_one_discPowForm (k : ℕ) :
+    qExpansion 1 (discPowForm k) = (qExpansion 1 ModularForm.discriminant) ^ k := by
+  rw [discPowForm, ModularForm.qExpansion_mcast,
+    ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+  have hco : (⇑(CuspForm.toModularFormₗ CuspForm.discriminant) : ℍ → ℂ) =
+      ModularForm.discriminant := by
+    funext z
+    rw [CuspForm.toModularFormₗ_apply]
+    exact congrFun CuspForm.coe_discriminant z
+  rw [hco]
+
+lemma qExpansion_one_discPow (k : ℕ) :
+    qExpansion 1 (⇑CuspForm.discriminant ^ k : ℍ → ℂ) =
+      (qExpansion 1 ModularForm.discriminant) ^ k := by
+  rw [← discPowForm_coe]
+  exact qExpansion_one_discPowForm k
+
+lemma qExpansion_discPow_coeff_mem (K : IntermediateField ℚ ℂ) [NeZero N] (k n : ℕ) :
+    (qExpansion N (⇑CuspForm.discriminant ^ k : ℍ → ℂ)).coeff n ∈ K := by
+  have h1 : qExpansion (N : ℝ) (⇑CuspForm.discriminant ^ k : ℍ → ℂ) =
+      qExpansion (N : ℝ) (discPowForm k) := by
+    rw [← discPowForm_coe]
+  rw [h1, ModularFormClass.qExpansion_coeff_width (discPowForm k)
+    one_mem_strictPeriods_SL (NeZero.ne N)]
+  split
+  · rw [qExpansion_one_discPowForm]
+    exact mem_of_rat K (ratCoeff_pow ratCoeff_discriminant k _)
+  · exact zero_mem _
+
+lemma KPoleAt.pad {K : IntermediateField ℚ ℂ} [NeZero N] {f : ℍ → ℂ} {m m' : ℕ}
+    (hhol : MDiff f) (hm : m ≤ m') (h : KPoleAt K N m f) : KPoleAt K N m' f := by
+  obtain ⟨hper, hbd, hmem⟩ := h
+  have hshape : (f * ⇑CuspForm.discriminant ^ m' : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m) * ⇑CuspForm.discriminant ^ (m' - m) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply]
+    rw [mul_assoc, ← pow_add, Nat.add_sub_cancel' hm]
+  refine ⟨?_, ?_, ?_⟩
+  · rw [hshape]
+    exact hper.mul (periodic_discPow_comp_ofComplex (m' - m) N)
+  · exact IsBoundedAtImInfty.mul_discPow_mono hm hbd
+  · intro n
+    rw [hshape, qExpansion_mul
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hhol m) hper hbd)
+      (analyticAt_cuspFunction_zero_of (mdiff_discPow (m' - m))
+        (periodic_discPow_comp_ofComplex (m' - m) N) (isBoundedAtImInfty_discPow (m' - m))),
+      PowerSeries.coeff_mul]
+    exact sum_mem fun ij _ => mul_mem (hmem ij.1) (qExpansion_discPow_coeff_mem K _ ij.2)
+
+lemma kPole_algebraMap {K : IntermediateField ℚ ℂ} [NeZero N] (c : ↥K) :
+    KPole K N (algebraMap ↥K (ℍ → ℂ) c) := by
+  have hshape : ((algebraMap ↥K (ℍ → ℂ) c) * ⇑CuspForm.discriminant ^ 0 : ℍ → ℂ) =
+      (c : ℂ) • (1 : ℍ → ℂ) := by
+    funext τ
+    simp only [Pi.mul_apply, pow_zero, mul_one, Pi.smul_apply, Pi.one_apply,
+      smul_eq_mul]
+    rfl
+  have hone_bd : IsBoundedAtImInfty (1 : ℍ → ℂ) := by
+    have h1 : (1 : ℍ → ℂ) = fun _ : ℍ => (1 : ℂ) := rfl
+    rw [h1]
+    exact const_boundedAtFilter _ _
+  refine ⟨mdifferentiable_const, 0, ?_, ?_, ?_⟩
+  · rw [hshape]
+    intro x
+    rfl
+  · rw [hshape]
+    have hc : ((c : ℂ) • (1 : ℍ → ℂ)) = fun _ : ℍ => (c : ℂ) := by
+      funext τ
+      simp
+    rw [hc]
+    exact const_boundedAtFilter _ _
+  · intro n
+    have han : AnalyticAt ℂ (cuspFunction N (1 : ℍ → ℂ)) 0 :=
+      analyticAt_cuspFunction_zero_of (g := (1 : ℍ → ℂ)) mdifferentiable_const
+        (periodic_one_fn N) hone_bd
+    rw [hshape, qExpansion_smul han,
+      qExpansion_one, PowerSeries.coeff_smul, smul_eq_mul, PowerSeries.coeff_one]
+    split
+    · rw [mul_one]
+      exact c.2
+    · rw [mul_zero]
+      exact zero_mem _
+
+lemma KPole.add {K : IntermediateField ℚ ℂ} [NeZero N] {f g : ℍ → ℂ} (hf : KPole K N f)
+    (hg : KPole K N g) : KPole K N (f + g) := by
+  obtain ⟨hf1, m1, hfd⟩ := hf
+  obtain ⟨hg1, m2, hgd⟩ := hg
+  obtain ⟨hfper, hfbd, hfmem⟩ := hfd.pad hf1 (le_max_left m1 m2)
+  obtain ⟨hgper, hgbd, hgmem⟩ := hgd.pad hg1 (le_max_right m1 m2)
+  have hshape : ((f + g) * ⇑CuspForm.discriminant ^ max m1 m2 : ℍ → ℂ) =
+      f * ⇑CuspForm.discriminant ^ max m1 m2 + g * ⇑CuspForm.discriminant ^ max m1 m2 := by
+    funext τ
+    simp [add_mul]
+  refine ⟨hf1.add hg1, max m1 m2, ?_, ?_, ?_⟩
+  · rw [hshape]
+    exact hfper.add hgper
+  · rw [hshape]
+    exact hfbd.add hgbd
+  · intro n
+    rw [hshape, qExpansion_add
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hf1 _) hfper hfbd)
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hg1 _) hgper hgbd),
+      map_add]
+    exact add_mem (hfmem n) (hgmem n)
+
+lemma KPole.mul {K : IntermediateField ℚ ℂ} [NeZero N] {f g : ℍ → ℂ} (hf : KPole K N f)
+    (hg : KPole K N g) : KPole K N (f * g) := by
+  obtain ⟨hf1, m1, hfper, hfbd, hfmem⟩ := hf
+  obtain ⟨hg1, m2, hgper, hgbd, hgmem⟩ := hg
+  have hshape : ((f * g) * ⇑CuspForm.discriminant ^ (m1 + m2) : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m1) * (g * ⇑CuspForm.discriminant ^ m2) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply, pow_add]
+    ring
+  refine ⟨hf1.mul hg1, m1 + m2, ?_, ?_, ?_⟩
+  · rw [hshape]
+    exact hfper.mul hgper
+  · rw [hshape]
+    exact hfbd.mul hgbd
+  · intro n
+    rw [hshape, qExpansion_mul
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hf1 _) hfper hfbd)
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hg1 _) hgper hgbd),
+      PowerSeries.coeff_mul]
+    exact sum_mem fun ij _ => mul_mem (hfmem ij.1) (hgmem ij.2)
+
+theorem kPole_invariant_eq_polynomial_j_mem {K : IntermediateField ℚ ℂ} [NeZero N]
+    {a : ℍ → ℂ} (hk : KPole K N a) (hinv : ∀ γ : SL(2, ℤ), a ∣[(0 : ℤ)] γ = a) :
+    ∃ P : Polynomial ℂ, (∀ i, P.coeff i ∈ K) ∧ a = fun τ => Polynomial.eval (j τ) P := by
+  obtain ⟨hhol, m, hper, hbd, hmem⟩ := hk
+  obtain ⟨P, hdeg, hP⟩ := levelOne_holFn_eq_polynomial_j m a hhol hinv hbd
+  have hfn : (a * ⇑CuspForm.discriminant ^ m : ℍ → ℂ) = ⇑(polyDiscForm m P) := by
+    rw [hP]
+    exact (polyDiscForm_coe hdeg).symm
+  have h1 : ∀ n, (qExpansion 1 (polyDiscForm m P)).coeff n ∈ K := by
+    intro n
+    have hw := qExpansion_coeff_width (⇑(polyDiscForm m P) : ℍ → ℂ) (NeZero.ne N)
+      (SlashInvariantFormClass.periodic_comp_ofComplex _ one_mem_strictPeriods_SL)
+      (polyDiscForm m P).holo' (ModularFormClass.bdd_at_infty _) (N * n)
+    rw [ite_eq_left ⟨n, rfl⟩, Nat.mul_div_cancel_left n (Nat.pos_of_ne_zero (NeZero.ne N))] at hw
+    rw [← hw]
+    have hm := hmem (N * n)
+    rwa [hfn] at hm
+  refine ⟨P, fun i => ?_, hP⟩
+  have hmem1 := levelOne_qexp_principle_mem K.toSubfield m P hdeg (fun n => by
+    rw [← qExpansion_polyDiscForm]
+    exact h1 n) i
+  exact hmem1
+
+end KPoleSec
+
+end WLight
+
+section R3Bridge
+
+p2m_open "P2MW.S_WLight_levelOne_hauptmodul_package.WLight Polynomial Real.Polynomial"
+p2m_open "UpperHalfPlane~I"
+open scoped Manifold MatrixGroups ModularForm
+
+open WLight in
+theorem solution :
+    (∀ (m : ℕ) (h : ℍ → ℂ), MDifferentiable 𝓘(ℂ) 𝓘(ℂ) h →
+      (∀ γ : SL(2, ℤ), h ∣[(0 : ℤ)] γ = h) →
+      IsBoundedAtImInfty (h * ModularForm.discriminant ^ m) →
+      ∃ P : Polynomial ℂ, P.natDegree ≤ m ∧
+        h = fun τ => Polynomial.eval (ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) P) ∧
+    (∀ (k : IntermediateField ℚ ℂ) (N : ℕ), N ≠ 0 → ∀ (m : ℕ) (h : ℍ → ℂ),
+      MDifferentiable 𝓘(ℂ) 𝓘(ℂ) h →
+      (∀ γ : SL(2, ℤ), h ∣[(0 : ℤ)] γ = h) →
+      Function.Periodic ((h * ModularForm.discriminant ^ m) ∘ ofComplex) N →
+      IsBoundedAtImInfty (h * ModularForm.discriminant ^ m) →
+      (∀ n : ℕ, (qExpansion N (h * ModularForm.discriminant ^ m)).coeff n ∈ k) →
+      ∃ P : Polynomial ℂ, P.natDegree ≤ m ∧ (∀ i, P.coeff i ∈ k) ∧
+        h = fun τ => Polynomial.eval (ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) P) ∧
+    Function.Surjective (fun τ : ℍ => ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) ∧
+    (∀ (m : ℕ) (P : Polynomial ℂ), P.natDegree ≤ m →
+      (∀ n : ℕ, ∃ q : ℚ, (∑ i ∈ Finset.range (m + 1),
+          PowerSeries.C (P.coeff i) * qExpansion 1 ⇑ModularForm.E₄ ^ (3 * i) *
+            qExpansion 1 ModularForm.discriminant ^ (m - i)).coeff n = (q : ℂ)) →
+      ∀ i : ℕ, ∃ q : ℚ, P.coeff i = (q : ℂ)) ∧
+    (∀ (k : IntermediateField ℚ ℂ) (m : ℕ) (P : Polynomial ℂ), P.natDegree ≤ m →
+      (∀ n : ℕ, (∑ i ∈ Finset.range (m + 1),
+          PowerSeries.C (P.coeff i) * qExpansion 1 ⇑ModularForm.E₄ ^ (3 * i) *
+            qExpansion 1 ModularForm.discriminant ^ (m - i)).coeff n ∈ k) →
+      ∀ i : ℕ, P.coeff i ∈ k) := by
+  have hdisc : (ModularForm.discriminant : ℍ → ℂ) = ⇑CuspForm.discriminant :=
+    CuspForm.coe_discriminant.symm
+  refine ⟨?_, ?_, j_surjective, ?_, ?_⟩
+  · intro m h hol hinv hbd
+    rw [hdisc] at hbd
+    exact levelOne_holFn_eq_polynomial_j m h hol hinv hbd
+  · intro k N hN m h hol hinv hper hbd hmem
+    have : NeZero N := ⟨hN⟩
+    rw [hdisc] at hper hbd hmem
+    obtain ⟨P, hdeg, hP⟩ := levelOne_holFn_eq_polynomial_j m h hol hinv hbd
+    obtain ⟨P', hP'k, hP'⟩ := kPole_invariant_eq_polynomial_j_mem
+      (K := k) ⟨hol, m, hper, hbd, hmem⟩ hinv
+    have hPP' : P = P' := by
+      apply Polynomial.funext
+      intro c
+      obtain ⟨τ, rfl⟩ := j_surjective c
+      have h1 := congrFun hP τ
+      have h2 := congrFun hP' τ
+      rw [← h1, h2]
+    exact ⟨P, hdeg, hPP' ▸ hP'k, hP⟩
+  · intro m P hdeg hrat
+    exact levelOne_qexp_principle m P hdeg (by simpa [polyDiscSeries] using hrat)
+  · intro k m P hdeg hmem
+    exact levelOne_qexp_principle_mem k.toSubfield m P hdeg
+      (by simpa [polyDiscSeries] using hmem)
+
+end R3Bridge
+
+end
+
+end S_WLight_levelOne_hauptmodul_package
+end P2MW
+export P2MW.S_WLight_levelOne_hauptmodul_package (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Complex Real Polynomial
+open UpperHalfPlane
+open scoped Manifold MatrixGroups ModularForm
+theorem WLight.levelOne_hauptmodul_package :
+    (∀ (m : ℕ) (h : ℍ → ℂ), MDifferentiable 𝓘(ℂ) 𝓘(ℂ) h →
+      (∀ γ : SL(2, ℤ), h ∣[(0 : ℤ)] γ = h) →
+      IsBoundedAtImInfty (h * ModularForm.discriminant ^ m) →
+      ∃ P : Polynomial ℂ, P.natDegree ≤ m ∧
+        h = fun τ => Polynomial.eval (ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) P) ∧
+    (∀ (k : IntermediateField ℚ ℂ) (N : ℕ), N ≠ 0 → ∀ (m : ℕ) (h : ℍ → ℂ),
+      MDifferentiable 𝓘(ℂ) 𝓘(ℂ) h →
+      (∀ γ : SL(2, ℤ), h ∣[(0 : ℤ)] γ = h) →
+      Function.Periodic ((h * ModularForm.discriminant ^ m) ∘ ofComplex) N →
+      IsBoundedAtImInfty (h * ModularForm.discriminant ^ m) →
+      (∀ n : ℕ, (qExpansion N (h * ModularForm.discriminant ^ m)).coeff n ∈ k) →
+      ∃ P : Polynomial ℂ, P.natDegree ≤ m ∧ (∀ i, P.coeff i ∈ k) ∧
+        h = fun τ => Polynomial.eval (ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) P) ∧
+    Function.Surjective (fun τ : ℍ => ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) ∧
+    (∀ (m : ℕ) (P : Polynomial ℂ), P.natDegree ≤ m →
+      (∀ n : ℕ, ∃ q : ℚ, (∑ i ∈ Finset.range (m + 1),
+          PowerSeries.C (P.coeff i) * qExpansion 1 ⇑ModularForm.E₄ ^ (3 * i) *
+            qExpansion 1 ModularForm.discriminant ^ (m - i)).coeff n = (q : ℂ)) →
+      ∀ i : ℕ, ∃ q : ℚ, P.coeff i = (q : ℂ)) ∧
+    (∀ (k : IntermediateField ℚ ℂ) (m : ℕ) (P : Polynomial ℂ), P.natDegree ≤ m →
+      (∀ n : ℕ, (∑ i ∈ Finset.range (m + 1),
+          PowerSeries.C (P.coeff i) * qExpansion 1 ⇑ModularForm.E₄ ^ (3 * i) *
+            qExpansion 1 ModularForm.discriminant ^ (m - i)).coeff n ∈ k) →
+      ∀ i : ℕ, P.coeff i ∈ k) :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_linearIndependent_complex_of_qExpansion_rational.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_linearIndependent_complex_of_qExpansion_rational.lean
new file mode 100644
index 0000000000..a4585d554b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_linearIndependent_complex_of_qExpansion_rational.lean
@@ -0,0 +1,383 @@
+/-
+Based on Prove2Me node WLight.linearIndependent_complex_of_qExpansion_rational
+(489f1a10-dac1-5e31-a379-6120f1df6827) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f73be52e-68fc-591d-8d1d-33db19a57e38
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IntermediateField.Basic
+public import Mathlib.LinearAlgebra.Dimension.DivisionRing
+public import Mathlib.NumberTheory.ModularForms.QExpansion
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import Mathlib.Geometry.Manifold.Notation
+
+import Mathlib.LinearAlgebra.LinearIndependent.BaseChange
+import Mathlib.LinearAlgebra.Basis.VectorSpace
+import Mathlib.NumberTheory.ModularForms.CuspFormSubmodule
+import Mathlib.NumberTheory.ModularForms.LevelOne.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# ℂ-independence from K-independence for q-rational families
+
+Theorem statement: `WLight.linearIndependent_complex_of_qExpansion_rational`
+(`489f1a10-dac1-5e31-a379-6120f1df6827`), by Claude, 2026-09-05.
+
+Proof: submission `f73be52e-68fc-591d-8d1d-33db19a57e38`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix an integer $N \ge 1$, an intermediate field $K$ of $\mathbb{Q} \subseteq \mathbb{C}$, a finite
+set $s$ of functions $\mathbb{H} \to \mathbb{C}$, and a natural number $m$. Assume that every $f \in
+s$ satisfies four conditions: $f$ is holomorphic, in the sense of being `MDifferentiable` for the
+model with corners $\mathcal{I}(\mathbb{C})$ on source and target; the product $f \cdot \Delta^m$
+with the $m$-th power of the modular discriminant `ModularForm.discriminant`, transported to
+$\mathbb{C}$ via `UpperHalfPlane.ofComplex`, is periodic with period $N$; $f \cdot \Delta^m$ is
+bounded at $i\infty$ (`IsBoundedAtImInfty`); and every coefficient of the width-$N$ $q$-expansion
+`UpperHalfPlane.qExpansion N (f * ModularForm.discriminant ^ m)` lies in $K$. Assume further that
+the family indexed by the elements of $s$, given by the inclusion of $s$ into $\mathbb{H} \to
+\mathbb{C}$, is linearly independent over $K$, the space of functions being viewed as a $K$-module
+by restriction of scalars. The conclusion is that this same family is linearly independent over
+$\mathbb{C}$.
+
+This is the descent (or $q$-expansion principle) step which shows that $K$-linear independence of a
+family of $q$-rational weakly holomorphic functions of level dividing $N$ is already
+$\mathbb{C}$-linear independence. It feeds the rationality arguments for spaces of cusp forms and
+for functions on modular curves, being used in the study of $q$-expansion coefficients of forms of
+level $\Gamma_1(N)$ and of spanning statements for Fricke-rational functions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WLight_linearIndependent_complex_of_qExpansion_rational.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WLight_linearIndependent_complex_of_qExpansion_rational
+
+noncomputable section
+
+open Complex UpperHalfPlane Function
+open scoped Topology Manifold ModularForm
+
+namespace WLightR11aSol
+
+section Flatness
+
+open ModularForm
+
+variable {N : ℕ}
+
+private lemma mdiff_discB (k : ℕ) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) ((ModularForm.discriminant : ℍ → ℂ) ^ k) := by
+  induction k with
+  | zero =>
+    rw [pow_zero]
+    exact mdifferentiable_const
+  | succ n ih =>
+    rw [pow_succ]
+    exact ih.mul CuspForm.discriminant.holo'
+
+private lemma mdiff_finsetSum {ι : Type*} (t : Finset ι) (g : ι → ℂ) (F : ι → ℍ → ℂ)
+    (h : ∀ j ∈ t, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (F j)) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (∑ j ∈ t, g j • F j) := by
+  classical
+  induction t using Finset.induction_on with
+  | empty =>
+    simp only [Finset.sum_empty]
+    exact mdifferentiable_const
+  | insert a u ha ih =>
+    rw [Finset.sum_insert ha]
+    exact ((h a (Finset.mem_insert_self a u)).const_smul (g a)).add
+      (ih fun j hj => h j (Finset.mem_insert_of_mem hj))
+
+private lemma periodic_finsetSum {ι : Type*} (t : Finset ι) (g : ι → ℂ) (F : ι → ℍ → ℂ)
+    {c : ℝ} (h : ∀ j ∈ t, Function.Periodic (F j ∘ ofComplex) c) :
+    Function.Periodic ((∑ j ∈ t, g j • F j) ∘ ofComplex) c := by
+  intro x
+  simp only [Function.comp_apply, Finset.sum_apply, Pi.smul_apply, smul_eq_mul]
+  refine Finset.sum_congr rfl fun j hj => ?_
+  have h2 := h j hj x
+  simp only [Function.comp_apply] at h2
+  rw [h2]
+
+private lemma bounded_finsetSum {ι : Type*} (t : Finset ι) (g : ι → ℂ) (F : ι → ℍ → ℂ)
+    (h : ∀ j ∈ t, IsBoundedAtImInfty (F j)) :
+    IsBoundedAtImInfty (∑ j ∈ t, g j • F j) := by
+  classical
+  induction t using Finset.induction_on with
+  | empty =>
+    simp only [Finset.sum_empty]
+    have h0 : (0 : ℍ → ℂ) = fun _ : ℍ => (0 : ℂ) := rfl
+    rw [h0]
+    exact Filter.const_boundedAtFilter _ _
+  | insert a u ha ih =>
+    rw [Finset.sum_insert ha]
+    have h1 : IsBoundedAtImInfty (g a • F a) := by
+      have h2 := (h a (Finset.mem_insert_self a u)).const_mul_left (g a)
+      have heq : (fun τ => g a * F a τ) = g a • F a := by
+        funext τ; simp [Pi.smul_apply]
+      rwa [heq] at h2
+    exact h1.add (ih fun j hj => h j (Finset.mem_insert_of_mem hj))
+
+private lemma analyticAt_zero_fn [NeZero N] :
+    AnalyticAt ℂ (cuspFunction N (0 : ℍ → ℂ)) 0 := by
+  have hN' : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  refine analyticAt_cuspFunction_zero hN' (fun x => rfl) mdifferentiable_const ?_
+  have h0 : (0 : ℍ → ℂ) = fun _ : ℍ => (0 : ℂ) := rfl
+  rw [h0]
+  exact Filter.const_boundedAtFilter _ _
+
+private lemma qExpansion_zero_fn [NeZero N] : qExpansion N (0 : ℍ → ℂ) = 0 := by
+  have h0 : (0 : ℍ → ℂ) = (0 : ℂ) • (0 : ℍ → ℂ) := by rw [zero_smul]
+  rw [h0, qExpansion_smul analyticAt_zero_fn, zero_smul]
+
+private lemma qExpansion_finsetSum [NeZero N] {ι : Type*} (t : Finset ι) (g : ι → ℂ)
+    (F : ι → ℍ → ℂ)
+    (hhol : ∀ j ∈ t, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (F j))
+    (hper : ∀ j ∈ t, Function.Periodic (F j ∘ ofComplex) N)
+    (hbd : ∀ j ∈ t, IsBoundedAtImInfty (F j)) :
+    qExpansion N (∑ j ∈ t, g j • F j) = ∑ j ∈ t, g j • qExpansion N (F j) := by
+  classical
+  have hN' : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  induction t using Finset.induction_on with
+  | empty =>
+    simp only [Finset.sum_empty]
+    exact qExpansion_zero_fn
+  | insert a u ha ih =>
+    have hholu : ∀ j ∈ u, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (F j) :=
+      fun j hj => hhol j (Finset.mem_insert_of_mem hj)
+    have hperu : ∀ j ∈ u, Function.Periodic (F j ∘ ofComplex) N :=
+      fun j hj => hper j (Finset.mem_insert_of_mem hj)
+    have hbdu : ∀ j ∈ u, IsBoundedAtImInfty (F j) :=
+      fun j hj => hbd j (Finset.mem_insert_of_mem hj)
+    have ha1 : AnalyticAt ℂ (cuspFunction N (F a)) 0 :=
+      analyticAt_cuspFunction_zero hN' (hper a (Finset.mem_insert_self a u))
+        (hhol a (Finset.mem_insert_self a u)) (hbd a (Finset.mem_insert_self a u))
+    have hga : AnalyticAt ℂ (cuspFunction N (g a • F a)) 0 := by
+      refine analyticAt_cuspFunction_zero hN' ?_
+        ((hhol a (Finset.mem_insert_self a u)).const_smul (g a)) ?_
+      · intro x
+        have h2 := hper a (Finset.mem_insert_self a u) x
+        simp only [Function.comp_apply] at h2
+        simp only [Function.comp_apply, Pi.smul_apply, smul_eq_mul]
+        exact congrArg (fun z => g a * z) h2
+      · have h2 := (hbd a (Finset.mem_insert_self a u)).const_mul_left (g a)
+        have heq : (fun τ => g a * F a τ) = g a • F a := by
+          funext τ; simp [Pi.smul_apply]
+        rwa [heq] at h2
+    have hsum : AnalyticAt ℂ (cuspFunction N (∑ j ∈ u, g j • F j)) 0 :=
+      analyticAt_cuspFunction_zero hN' (periodic_finsetSum u g F hperu)
+        (mdiff_finsetSum u g F hholu) (bounded_finsetSum u g F hbdu)
+    rw [Finset.sum_insert ha, Finset.sum_insert ha, qExpansion_add hga hsum,
+      qExpansion_smul ha1, ih hholu hperu hbdu]
+
+theorem linearIndependent_complex_of_qExpansion_rational (N : ℕ) [NeZero N]
+    (K : IntermediateField ℚ ℂ) (s : Finset (ℍ → ℂ)) (m : ℕ)
+    (hdata : ∀ f ∈ s, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f ∧
+      Function.Periodic ((f * ModularForm.discriminant ^ m) ∘ UpperHalfPlane.ofComplex) N ∧
+      IsBoundedAtImInfty (f * ModularForm.discriminant ^ m) ∧
+      ∀ n : ℕ, (UpperHalfPlane.qExpansion N (f * ModularForm.discriminant ^ m)).coeff n ∈ K)
+    (hind : LinearIndependent ↥K (fun w : ↥(↑s : Set (ℍ → ℂ)) => (w : ℍ → ℂ))) :
+    LinearIndependent ℂ (fun w : ↥(↑s : Set (ℍ → ℂ)) => (w : ℍ → ℂ)) := by
+  classical
+  have hN' : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  set P : (ℍ → ℂ) → ℍ → ℂ := fun f => f * ModularForm.discriminant ^ m with hP_def
+  have hPhol : ∀ f ∈ s, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (P f) := fun f hf =>
+    (hdata f hf).1.mul (mdiff_discB m)
+  have hPper : ∀ f ∈ s, Function.Periodic (P f ∘ ofComplex) N := fun f hf =>
+    (hdata f hf).2.1
+  have hPbd : ∀ f ∈ s, IsBoundedAtImInfty (P f) := fun f hf => (hdata f hf).2.2.1
+  set vec : ↥(↑s : Set (ℍ → ℂ)) → ℕ → ↥K := fun w n =>
+    ⟨(qExpansion N (P (w : ℍ → ℂ))).coeff n, (hdata _ w.2).2.2.2 n⟩ with hvec_def
+  have hpad : ∀ (g : ↥(↑s : Set (ℍ → ℂ)) → ℂ),
+      (∑ w : ↥(↑s : Set (ℍ → ℂ)), g w • P (w : ℍ → ℂ)) =
+        (∑ w : ↥(↑s : Set (ℍ → ℂ)), g w • (w : ℍ → ℂ)) * ModularForm.discriminant ^ m := by
+    intro g
+    rw [Finset.sum_mul]
+    refine Finset.sum_congr rfl fun w _ => ?_
+    funext τ
+    simp only [hP_def, Pi.smul_apply, Pi.mul_apply, Pi.pow_apply, smul_eq_mul]
+    ring
+  have hkill : ∀ (g : ↥(↑s : Set (ℍ → ℂ)) → ℂ),
+      (∑ w, g w • (w : ℍ → ℂ)) = 0 → ∀ n : ℕ, (∑ w, g w * ((vec w n : ℂ))) = 0 := by
+    intro g hg n
+    have hsum0 : (∑ w : ↥(↑s : Set (ℍ → ℂ)), g w • P (w : ℍ → ℂ)) = 0 := by
+      rw [hpad g, hg, zero_mul]
+    have hq0 : qExpansion N (∑ w : ↥(↑s : Set (ℍ → ℂ)), g w • P (w : ℍ → ℂ)) = 0 := by
+      rw [hsum0, qExpansion_zero_fn]
+    rw [qExpansion_finsetSum Finset.univ g (fun w => P (w : ℍ → ℂ))
+      (fun w _ => hPhol _ w.2) (fun w _ => hPper _ w.2) (fun w _ => hPbd _ w.2)] at hq0
+    have h2 := congrArg (fun S => PowerSeries.coeff n S) hq0
+    simpa [PowerSeries.coeff_smul, smul_eq_mul] using h2
+  have hlift : ∀ (a : ↥(↑s : Set (ℍ → ℂ)) → ↥K),
+      (∀ n : ℕ, (∑ w, a w * vec w n) = 0) → (∑ w, a w • (w : ℍ → ℂ)) = 0 := by
+    intro a ha
+    have hq0 : qExpansion N (∑ w : ↥(↑s : Set (ℍ → ℂ)), ((a w : ℂ)) • P (w : ℍ → ℂ)) = 0 := by
+      rw [qExpansion_finsetSum Finset.univ (fun w => ((a w : ℂ))) (fun w => P (w : ℍ → ℂ))
+        (fun w _ => hPhol _ w.2) (fun w _ => hPper _ w.2) (fun w _ => hPbd _ w.2)]
+      ext n
+      simp only [map_sum, PowerSeries.coeff_smul, smul_eq_mul, map_zero]
+      have h1 := congrArg (fun x : ↥K => (x : ℂ)) (ha n)
+      push_cast at h1
+      rw [← h1]
+      rfl
+    have hfun0 : (∑ w : ↥(↑s : Set (ℍ → ℂ)), ((a w : ℂ)) • P (w : ℍ → ℂ)) = 0 := by
+      rw [qExpansion_eq_zero_iff hN'
+        (periodic_finsetSum _ _ _ (fun w _ => hPper _ w.2))
+        (mdiff_finsetSum _ _ _ (fun w _ => hPhol _ w.2))
+        (bounded_finsetSum _ _ _ (fun w _ => hPbd _ w.2))] at hq0
+      exact hq0
+    rw [hpad (fun w => ((a w : ℂ)))] at hfun0
+    have hΔne : ∀ τ : ℍ, ((ModularForm.discriminant : ℍ → ℂ) ^ m) τ ≠ 0 := fun τ => by
+      simp only [Pi.pow_apply]
+      exact pow_ne_zero m (ModularForm.discriminant_ne_zero τ)
+    have h2 : (∑ w : ↥(↑s : Set (ℍ → ℂ)), ((a w : ℂ)) • (w : ℍ → ℂ)) = 0 := by
+      funext τ
+      have h3 := congrFun hfun0 τ
+      simp only [Pi.mul_apply, Pi.zero_apply] at h3 ⊢
+      exact (mul_eq_zero.mp h3).resolve_right (hΔne τ)
+    calc (∑ w : ↥(↑s : Set (ℍ → ℂ)), a w • (w : ℍ → ℂ))
+        = ∑ w : ↥(↑s : Set (ℍ → ℂ)), ((a w : ℂ)) • (w : ℍ → ℂ) :=
+          Finset.sum_congr rfl fun w _ => rfl
+      _ = 0 := h2
+  by_contra hC
+  obtain ⟨g, hg0, j₀, hj₀⟩ : ∃ g : ↥(↑s : Set (ℍ → ℂ)) → ℂ,
+      (∑ w, g w • (w : ℍ → ℂ)) = 0 ∧ ∃ j, g j ≠ 0 := by
+    rw [Fintype.linearIndependent_iff] at hC
+    push Not at hC
+    obtain ⟨g, hg, j, hj⟩ := hC
+    exact ⟨g, hg, j, hj⟩
+  set row : ℕ → ↥(↑s : Set (ℍ → ℂ)) → ↥K := fun n w => vec w n with hrow_def
+  obtain ⟨D, hD⟩ : ∃ D : Finset ℕ, ∀ n : ℕ, row n ∈
+      Submodule.span ↥K (row '' ↑D : Set (↥(↑s : Set (ℍ → ℂ)) → ↥K)) := by
+    have hfg : (Submodule.span ↥K (Set.range row)).FG := IsNoetherian.noetherian _
+    obtain ⟨F, hF⟩ := hfg
+    have hchoice : ∀ x ∈ F, ∃ Dx : Finset ℕ,
+        x ∈ Submodule.span ↥K (row '' ↑Dx : Set (↥(↑s : Set (ℍ → ℂ)) → ↥K)) := by
+      intro x hx
+      have hxs : x ∈ Submodule.span ↥K (Set.range row) := hF ▸ Submodule.subset_span hx
+      obtain ⟨T, hTsub, hxT⟩ := Submodule.mem_span_finite_of_mem_span hxs
+      have hTchoice : ∀ t ∈ T, ∃ n : ℕ, row n = t := fun t ht => hTsub ht
+      choose idx hidx using hTchoice
+      refine ⟨T.attach.image fun t => idx t.1 t.2, Submodule.span_mono ?_ hxT⟩
+      intro t ht
+      have ht' : t ∈ T := ht
+      refine ⟨idx t ht', ?_, hidx t ht'⟩
+      simp only [Finset.coe_image, Set.mem_image]
+      exact ⟨⟨t, ht'⟩, by simp, rfl⟩
+    choose Dfn hDfn using hchoice
+    refine ⟨F.attach.biUnion fun x => Dfn x.1 x.2, fun n => ?_⟩
+    have h1 : row n ∈ Submodule.span ↥K (F : Set (↥(↑s : Set (ℍ → ℂ)) → ↥K)) := by
+      rw [hF]
+      exact Submodule.subset_span ⟨n, rfl⟩
+    refine Submodule.span_le.mpr ?_ h1
+    intro x hx
+    have hx' : x ∈ F := hx
+    refine Submodule.span_mono (Set.image_mono ?_) (hDfn x hx')
+    intro d hd
+    simp only [Finset.coe_biUnion, Set.mem_iUnion]
+    exact ⟨⟨x, hx'⟩, by simp, hd⟩
+  have hDdep : ¬ LinearIndependent ℂ
+      (fun w : ↥(↑s : Set (ℍ → ℂ)) =>
+        algebraMap ↥K ℂ ∘ (fun d : ↥(↑D : Set ℕ) => vec w (d : ℕ))) := by
+    intro hLI
+    refine hj₀ (Fintype.linearIndependent_iff.mp hLI g ?_ j₀)
+    funext d
+    simp only [Finset.sum_apply, Pi.smul_apply, Function.comp_apply, smul_eq_mul,
+      Pi.zero_apply]
+    exact hkill g hg0 (d : ℕ)
+  have hKdep : ¬ LinearIndependent ↥K
+      (fun w : ↥(↑s : Set (ℍ → ℂ)) => fun d : ↥(↑D : Set ℕ) => vec w (d : ℕ)) := by
+    intro hLI
+    exact hDdep (linearIndependent_algebraMap_comp_iff.mpr hLI)
+  obtain ⟨a, ha0, j₁, hj₁⟩ : ∃ a : ↥(↑s : Set (ℍ → ℂ)) → ↥K,
+      (∑ w, a w • fun d : ↥(↑D : Set ℕ) => vec w (d : ℕ)) = 0 ∧ ∃ j, a j ≠ 0 := by
+    rw [Fintype.linearIndependent_iff] at hKdep
+    push Not at hKdep
+    obtain ⟨a, ha, j, hj⟩ := hKdep
+    exact ⟨a, ha, j, hj⟩
+  have haD : ∀ d : ℕ, d ∈ D → (∑ w, a w * vec w d) = 0 := by
+    intro d hd
+    have h1 := congrFun ha0 ⟨d, hd⟩
+    simpa [Finset.sum_apply, smul_eq_mul] using h1
+  have haAll : ∀ n : ℕ, (∑ w, a w * vec w n) = 0 := by
+    intro n
+    have h1 := hD n
+    obtain ⟨T, hTsub, hrowT⟩ := Submodule.mem_span_finite_of_mem_span h1
+    obtain ⟨cf, hcf⟩ := Submodule.mem_span_finset.mp hrowT
+    have hTD : ∀ t ∈ T, ∃ d ∈ D, row d = t := by
+      intro t ht
+      obtain ⟨d, hd, hdt⟩ := hTsub ht
+      exact ⟨d, by simpa using hd, hdt⟩
+    calc (∑ w, a w * vec w n)
+        = ∑ w, a w * (row n w) := by rfl
+      _ = ∑ w, a w * ((∑ t ∈ T, cf t • t) w) := by rw [← hcf.2]
+      _ = ∑ w, a w * (∑ t ∈ T, cf t * t w) := by
+          refine Finset.sum_congr rfl fun w _ => ?_
+          congr 1
+          simp [Finset.sum_apply, Pi.smul_apply, smul_eq_mul]
+      _ = ∑ t ∈ T, cf t * ∑ w, a w * t w := by
+          rw [Finset.sum_congr rfl fun w _ =>
+            Finset.mul_sum T (fun t => cf t * t w) (a w)]
+          rw [Finset.sum_comm]
+          refine Finset.sum_congr rfl fun t _ => ?_
+          rw [Finset.mul_sum Finset.univ (fun w => a w * t w) (cf t)]
+          refine Finset.sum_congr rfl fun w _ => ?_
+          ring
+      _ = 0 := by
+          refine Finset.sum_eq_zero fun t ht => ?_
+          obtain ⟨d, hd, hdt⟩ := hTD t ht
+          rw [← hdt]
+          have : (∑ w, a w * row d w) = 0 := haD d hd
+          rw [this, mul_zero]
+  exact hj₁ (Fintype.linearIndependent_iff.mp hind a (hlift a haAll) j₁)
+
+end Flatness
+
+end WLightR11aSol
+
+theorem solution (N : ℕ) [NeZero N]
+    (K : IntermediateField ℚ ℂ) (s : Finset (ℍ → ℂ)) (m : ℕ)
+    (hdata : ∀ f ∈ s, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f ∧
+      Function.Periodic ((f * ModularForm.discriminant ^ m) ∘ UpperHalfPlane.ofComplex) N ∧
+      IsBoundedAtImInfty (f * ModularForm.discriminant ^ m) ∧
+      ∀ n : ℕ, (UpperHalfPlane.qExpansion N (f * ModularForm.discriminant ^ m)).coeff n ∈ K)
+    (hind : LinearIndependent ↥K (fun w : ↥(↑s : Set (ℍ → ℂ)) => (w : ℍ → ℂ))) :
+    LinearIndependent ℂ (fun w : ↥(↑s : Set (ℍ → ℂ)) => (w : ℍ → ℂ)) :=
+  WLightR11aSol.linearIndependent_complex_of_qExpansion_rational N K s m hdata hind
+
+end
+
+end S_WLight_linearIndependent_complex_of_qExpansion_rational
+end P2MW
+export P2MW.S_WLight_linearIndependent_complex_of_qExpansion_rational (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Complex UpperHalfPlane Function
+open scoped Topology Manifold ModularForm
+theorem WLight.linearIndependent_complex_of_qExpansion_rational (N : ℕ) [NeZero N]
+    (K : IntermediateField ℚ ℂ) (s : Finset (ℍ → ℂ)) (m : ℕ)
+    (hdata : ∀ f ∈ s, MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f ∧
+      Function.Periodic ((f * ModularForm.discriminant ^ m) ∘ UpperHalfPlane.ofComplex) N ∧
+      IsBoundedAtImInfty (f * ModularForm.discriminant ^ m) ∧
+      ∀ n : ℕ, (UpperHalfPlane.qExpansion N (f * ModularForm.discriminant ^ m)).coeff n ∈ K)
+    (hind : LinearIndependent ↥K (fun w : ↥(↑s : Set (ℍ → ℂ)) => (w : ℍ → ℂ))) :
+    LinearIndependent ℂ (fun w : ↥(↑s : Set (ℍ → ℂ)) => (w : ℍ → ℂ)) :=
+  solution N K s m hdata hind
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_qExpansion_sigmaTransport_package.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_qExpansion_sigmaTransport_package.lean
new file mode 100644
index 0000000000..744ceecdb6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_qExpansion_sigmaTransport_package.lean
@@ -0,0 +1,892 @@
+/-
+Based on Prove2Me node WLight.qExpansion_sigmaTransport_package
+(499a7ca1-7d6d-5c57-95c8-a3e4a1718252) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 483a355e-2357-5082-8ced-94124c2f3400
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.SpecialFunctions.Elliptic.Weierstrass
+public import Mathlib.NumberTheory.ModularForms.EisensteinSeries.Basic
+public import Mathlib.NumberTheory.ModularForms.Discriminant
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import Mathlib.FieldTheory.IntermediateField.Basic
+
+import Mathlib.NumberTheory.ModularForms.QExpansion
+import Mathlib.NumberTheory.ModularForms.EisensteinSeries.QExpansion
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+import Mathlib.NumberTheory.ModularForms.CuspFormSubmodule
+import Mathlib.NumberTheory.ModularForms.LevelOne.Basic
+import Mathlib.Geometry.Manifold.Notation
+import Mathlib.RingTheory.PowerSeries.Order
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Transport of K-rational q-expansions: polynomials, vanishing, j
+
+Theorem statement: `WLight.qExpansion_sigmaTransport_package`
+(`499a7ca1-7d6d-5c57-95c8-a3e4a1718252`), by Claude, 2026-09-05.
+
+Proof: submission `483a355e-2357-5082-8ced-94124c2f3400`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Fix a positive natural number $N$, an intermediate field $K$ of $\mathbb{C}/\mathbb{Q}$, and a ring
+homomorphism $\varphi \colon K \to \mathbb{C}$ whose image lies in $K$, i.e. $\varphi(z) \in K$ for
+every $z \in K$. Let $T$ be a relation between functions $\mathbb{H} \to \mathbb{C}$ subject to the
+hypothesis `hT`, which pins $T$ down by an equivalence: $T(g,g')$ holds if and only if $g$ and $g'$
+are differentiable as maps between the complex model spaces (holomorphy on $\mathbb{H}$) and there
+exists $m \in \mathbb{N}$ such that (i) $g\Delta^{m}$, read through `UpperHalfPlane.ofComplex`, is
+periodic of period $N$, is bounded at $i\infty$, and every coefficient of its width-$N$
+$q$-expansion `UpperHalfPlane.qExpansion N` lies in $K$; (ii) the same three conditions hold for
+$g'\Delta^{m}$; and (iii) for every $n$ and every $z \in K$ with $(z : \mathbb{C})$ equal to the
+$n$-th coefficient of the $q$-expansion of $g\Delta^{m}$, the $n$-th coefficient of the
+$q$-expansion of $g'\Delta^{m}$ equals $\varphi(z)$. Here $\Delta$ is `ModularForm.discriminant`.
+Under these assumptions three statements hold simultaneously. First, for every (small) index type
+$\iota$, all families $g, g' \colon \iota \to (\mathbb{H} \to \mathbb{C})$ with $T(g_i, g'_i)$ for
+all $i$, and every $R \in \mathrm{MvPolynomial}(\iota, K)$, the relation $T$ holds between the
+evaluation of $R$ at $g$ with coefficients pushed into $\mathbb{C}$ along $K \hookrightarrow
+\mathbb{C}$ and the evaluation of $R$ at $g'$ with coefficients pushed along $\varphi$. Second,
+$T(g,g')$ implies that $g = 0$ if and only if $g' = 0$. Third, any function $jf$ with $jf(\tau) =
+E_4(\tau)^3/\Delta(\tau)$ for all $\tau \in \mathbb{H}$ satisfies $T(jf, jf)$.
+
+This packages the three closure properties needed when $q$-expansion coefficients of meromorphic
+level-$N$ objects are conjugated by a homomorphism of the coefficient field, in the shape used for
+$K = \mathbb{Q}(\zeta_N)$ and $\varphi$ a power map on roots of unity: stability of the transport
+relation under $K$-polynomial expressions, detection of identical vanishing, and the fact that the
+hauptmodul $E_4^3/\Delta$ is its own transport. It is stated over an abstract relation $T$ pinned by
+an equivalence so that each user may substitute its own copy of the predicate; it feeds the
+rationality statements for $q$-expansions of functions translated by elements of $\Gamma_0(N)$ on
+the modular curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WLight_qExpansion_sigmaTransport_package.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WLight_qExpansion_sigmaTransport_package
+
+noncomputable section
+
+p2m_open "Complex Real UpperHalfPlane Function Filter Polynomial Real.Polynomial"
+open scoped Topology Manifold MatrixGroups ModularForm
+
+namespace WLight
+
+section CuspCriterion
+
+variable {N : ℕ}
+
+private lemma isBoundedAtImInfty_discriminant :
+    IsBoundedAtImInfty (⇑CuspForm.discriminant : ℍ → ℂ) :=
+  (CuspFormClass.zero_at_infty CuspForm.discriminant).boundedAtFilter
+
+private lemma isBoundedAtImInfty_discPow (n : ℕ) :
+    IsBoundedAtImInfty (⇑CuspForm.discriminant ^ n : ℍ → ℂ) := by
+  induction n with
+  | zero => exact pow_zero (⇑CuspForm.discriminant : ℍ → ℂ) ▸ Filter.const_boundedAtFilter _ (1 : ℂ)
+  | succ k ih =>
+    rw [pow_succ]
+    exact ih.mul isBoundedAtImInfty_discriminant
+
+private lemma IsBoundedAtImInfty.mul_discPow_mono {f : ℍ → ℂ} {m m' : ℕ} (hm : m ≤ m')
+    (h : IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m)) :
+    IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m') := by
+  have hshape : (f * ⇑CuspForm.discriminant ^ m' : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m) * ⇑CuspForm.discriminant ^ (m' - m) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply]
+    rw [mul_assoc, ← pow_add, Nat.add_sub_cancel' hm]
+  rw [hshape]
+  exact h.mul (isBoundedAtImInfty_discPow (m' - m))
+
+private def discPowForm (m : ℕ) : ModularForm 𝒮ℒ (12 * m) :=
+  ModularForm.mcast (by ring) ((CuspForm.toModularFormₗ CuspForm.discriminant).pow m)
+
+private lemma discPowForm_coe (m : ℕ) : ⇑(discPowForm m) = ⇑CuspForm.discriminant ^ m := by
+  funext z
+  simp [discPowForm, ModularForm.coe_mcast, ModularForm.coe_pow,
+    CuspForm.toModularFormₗ_apply]
+
+private lemma periodic_one_fn (c : ℝ) :
+    Function.Periodic ((1 : ℍ → ℂ) ∘ ofComplex) c := fun _ => rfl
+
+private lemma periodic_discPow_comp_ofComplex (k : ℕ) (N : ℕ) :
+    Function.Periodic ((⇑CuspForm.discriminant ^ k : ℍ → ℂ) ∘ ofComplex) N := by
+  have h1 : Function.Periodic (⇑CuspForm.discriminant ∘ ofComplex) 1 :=
+    SlashInvariantFormClass.periodic_comp_ofComplex CuspForm.discriminant
+      one_mem_strictPeriods_SL
+  have hk : Function.Periodic ((⇑CuspForm.discriminant ^ k : ℍ → ℂ) ∘ ofComplex) 1 := by
+    induction k with
+    | zero => exact periodic_one_fn 1
+    | succ k ih =>
+      intro x
+      have hx := (ih.mul h1) x
+      simp only [Function.comp_apply, Pi.mul_apply, Pi.pow_apply] at hx ⊢
+      rw [pow_succ, pow_succ]
+      exact hx
+  simpa using hk.nat_mul N
+
+private lemma mdiff_discPow (k : ℕ) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (⇑CuspForm.discriminant ^ k : ℍ → ℂ) := by
+  rw [← discPowForm_coe]
+  exact (discPowForm k).holo'
+
+private lemma mdiff_mul_discPow {f : ℍ → ℂ} (hf : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) (m : ℕ) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (f * ⇑CuspForm.discriminant ^ m : ℍ → ℂ) :=
+  hf.mul (mdiff_discPow m)
+
+private lemma analyticAt_cuspFunction_zero_of [NeZero N] {g : ℍ → ℂ}
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g)
+    (hper : Function.Periodic (g ∘ ofComplex) N) (hbd : IsBoundedAtImInfty g) :
+    AnalyticAt ℂ (cuspFunction N g) 0 :=
+  analyticAt_cuspFunction_zero
+    (by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)) hper hhol hbd
+
+private lemma qExpansion_one_discPowForm (k : ℕ) :
+    qExpansion 1 (discPowForm k) = (qExpansion 1 ModularForm.discriminant) ^ k := by
+  rw [discPowForm, ModularForm.qExpansion_mcast,
+    ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+  have hco : (⇑(CuspForm.toModularFormₗ CuspForm.discriminant) : ℍ → ℂ) =
+      ModularForm.discriminant := by
+    funext z
+    rw [CuspForm.toModularFormₗ_apply]
+    exact congrFun CuspForm.coe_discriminant z
+  rw [hco]
+
+private lemma qExpansion_one_discPow (k : ℕ) :
+    qExpansion 1 (⇑CuspForm.discriminant ^ k : ℍ → ℂ) =
+      (qExpansion 1 ModularForm.discriminant) ^ k := by
+  rw [← discPowForm_coe]
+  exact qExpansion_one_discPowForm k
+
+private lemma qParam_one_eq_pow {N : ℕ} (hN : N ≠ 0) (τ : ℂ) :
+    Function.Periodic.qParam 1 τ = Function.Periodic.qParam N τ ^ N := by
+  have : (N : ℂ) ≠ 0 := by exact_mod_cast hN
+  simp only [Function.Periodic.qParam, Complex.ofReal_one, div_one, Complex.ofReal_natCast]
+  rw [← Complex.exp_nat_mul]
+  congr 1
+  field_simp
+
+private theorem qExpansion_coeff_width (f : ℍ → ℂ) {N : ℕ} (hN : N ≠ 0)
+    (hper : Function.Periodic (f ∘ ofComplex) 1) (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f)
+    (hbd : IsBoundedAtImInfty f) (n : ℕ) :
+    (qExpansion N f).coeff n =
+      if N ∣ n then (qExpansion 1 f).coeff (n / N) else 0 := by
+  have hN' : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero hN
+  have hperN : Function.Periodic (f ∘ ofComplex) N := by
+    simpa using hper.nat_mul N
+  let f' : C(ℍ, ℂ) := ⟨f, hhol.continuous⟩
+  have hfan : AnalyticAt ℂ (cuspFunction N f') 0 :=
+    analyticAt_cuspFunction_zero hN' hperN hhol hbd
+  set c : ℕ → ℂ := fun n ↦ if N ∣ n then (qExpansion 1 f).coeff (n / N) else 0 with hc
+  have hf : ∀ τ : ℍ, HasSum (fun m ↦ c m • Function.Periodic.qParam N τ ^ m) (f' τ) := by
+    intro τ
+    have h1 := hasSum_qExpansion one_pos hper hhol hbd τ
+    have hinj : Function.Injective fun m : ℕ ↦ N * m := fun a b h ↦ by
+      simpa [Nat.mul_right_inj hN] using h
+    refine (hinj.hasSum_iff (f := fun m ↦ c m • Function.Periodic.qParam N τ ^ m) ?_).mp ?_
+    · intro x hx
+      have : ¬ N ∣ x := fun ⟨k, hk⟩ ↦ hx ⟨k, hk.symm⟩
+      simp [hc, this]
+    · refine h1.congr_fun fun m ↦ ?_
+      simp only [Function.comp_apply, hc, Nat.dvd_mul_right, ite_true,
+        Nat.mul_div_cancel_left _ (Nat.pos_of_ne_zero hN), qParam_one_eq_pow hN, ← pow_mul]
+  exact (qExpansion_coeff_unique f' hN' hfan hf n).symm
+
+end CuspCriterion
+
+section RatCoeff
+
+p2m_open "UpperHalfPlane ModularForm SlashInvariantForm ModularFormClass CuspForm \
+  ModularForm.CuspForm EisensteinSeries"
+open scoped MatrixGroups ArithmeticFunction.sigma
+
+private lemma ratCoeff_mul {p q : PowerSeries ℂ}
+    (hp : ∀ n : ℕ, ∃ a : ℚ, p.coeff n = (a : ℂ)) (hq : ∀ n : ℕ, ∃ a : ℚ, q.coeff n = (a : ℂ)) :
+    ∀ n : ℕ, ∃ a : ℚ, (p * q).coeff n = (a : ℂ) := by
+  choose F hF using hp
+  choose G hG using hq
+  intro n
+  refine ⟨∑ ij ∈ Finset.HasAntidiagonal.antidiagonal n, F ij.1 * G ij.2, ?_⟩
+  rw [PowerSeries.coeff_mul]
+  push_cast
+  exact Finset.sum_congr rfl fun ij _ => by rw [hF, hG]
+
+private lemma ratCoeff_sub {p q : PowerSeries ℂ}
+    (hp : ∀ n : ℕ, ∃ a : ℚ, p.coeff n = (a : ℂ)) (hq : ∀ n : ℕ, ∃ a : ℚ, q.coeff n = (a : ℂ)) :
+    ∀ n : ℕ, ∃ a : ℚ, (p - q).coeff n = (a : ℂ) := by
+  intro n
+  obtain ⟨a, ha⟩ := hp n
+  obtain ⟨b, hb⟩ := hq n
+  exact ⟨a - b, by rw [map_sub, ha, hb]; push_cast; ring⟩
+
+private lemma ratCoeff_E {k : ℕ} (hk : 3 ≤ k) (hk2 : Even k) :
+    ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 (E hk)).coeff n = (q : ℂ) := by
+  intro n
+  rw [E_qExpansion_coeff hk hk2]
+  by_cases hn : n = 0
+  · exact ⟨1, by simp [hn]⟩
+  · refine ⟨-(2 * k / _root_.bernoulli k) * (σ (k - 1) n : ℚ), ?_⟩
+    rw [ite_eq_right hn]
+    push_cast
+    ring
+
+private lemma ratCoeff_pow {p : PowerSeries ℂ}
+    (hp : ∀ n : ℕ, ∃ a : ℚ, p.coeff n = (a : ℂ)) (k : ℕ) :
+    ∀ n : ℕ, ∃ a : ℚ, (p ^ k).coeff n = (a : ℂ) := by
+  induction k with
+  | zero =>
+    intro n
+    rw [pow_zero]
+    by_cases hn : n = 0
+    · exact ⟨1, by simp [hn, PowerSeries.coeff_one]⟩
+    · exact ⟨0, by simp [PowerSeries.coeff_one, hn]⟩
+  | succ k ih =>
+    rw [pow_succ]
+    exact ratCoeff_mul ih hp
+
+private def eCubeSubESq : ModularForm 𝒮ℒ 12 :=
+  ModularForm.mcast (by decide) (E₄.pow 3) - ModularForm.mcast (by decide) (E₆.pow 2)
+
+private lemma eCubeSubESq_qExpansion :
+    qExpansion 1 eCubeSubESq = qExpansion 1 E₄ * qExpansion 1 E₄ * qExpansion 1 E₄ -
+      qExpansion 1 E₆ * qExpansion 1 E₆ := by
+  simp only [eCubeSubESq, FunLike.coe_sub, ModularForm.coe_mcast,
+    ModularForm.qExpansion_sub one_pos one_mem_strictPeriods_SL,
+    ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL]
+  ring
+
+private lemma discriminant_eq_smul_eCubeSubESq :
+    ModularForm.discriminant = (1 / 1728 : ℂ) • eCubeSubESq := by
+  ext z
+  have h := discriminant_eq_E₄_cube_sub_E₆_sq z
+  simp only [Pi.smul_apply, eCubeSubESq, FunLike.coe_sub, Pi.sub_apply,
+    ModularForm.coe_mcast, ModularForm.coe_pow, Pi.pow_apply, smul_eq_mul]
+  rw [h]
+  ring
+
+private lemma ratCoeff_discriminant :
+    ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 ModularForm.discriminant).coeff n = (q : ℂ) := by
+  have h4 : ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 E₄).coeff n = (q : ℂ) :=
+    ratCoeff_E (by norm_num) (by decide)
+  have h6 : ∀ n : ℕ, ∃ q : ℚ, (qExpansion 1 E₆).coeff n = (q : ℂ) :=
+    ratCoeff_E (by norm_num) (by decide)
+  have hmain := ratCoeff_sub (ratCoeff_mul (ratCoeff_mul h4 h4) h4) (ratCoeff_mul h6 h6)
+  intro n
+  obtain ⟨a, ha⟩ := hmain n
+  refine ⟨(1 / 1728 : ℚ) * a, ?_⟩
+  rw [discriminant_eq_smul_eCubeSubESq,
+    ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL,
+    PowerSeries.coeff_smul, eCubeSubESq_qExpansion, smul_eq_mul, ha]
+  push_cast
+  ring
+
+end RatCoeff
+
+section KPoleAlgebra
+
+open ModularForm
+
+variable {N : ℕ}
+
+private lemma mem_of_rat (K : IntermediateField ℚ ℂ) {x : ℂ} (h : ∃ q : ℚ, x = (q : ℂ)) :
+    x ∈ K := by
+  obtain ⟨q, rfl⟩ := h
+  exact SubfieldClass.ratCast_mem K q
+
+private def KPoleAt (K : IntermediateField ℚ ℂ) (N m : ℕ) (f : ℍ → ℂ) : Prop :=
+  Function.Periodic ((f * ⇑CuspForm.discriminant ^ m) ∘ ofComplex) N ∧
+    IsBoundedAtImInfty (f * ⇑CuspForm.discriminant ^ m) ∧
+    ∀ n : ℕ, (qExpansion N (f * ⇑CuspForm.discriminant ^ m)).coeff n ∈ K
+
+private def KPole (K : IntermediateField ℚ ℂ) (N : ℕ) (f : ℍ → ℂ) : Prop :=
+  MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f ∧ ∃ m : ℕ, KPoleAt K N m f
+
+private lemma qExpansion_discPow_coeff_mem (K : IntermediateField ℚ ℂ) [NeZero N] (k n : ℕ) :
+    (qExpansion N (⇑CuspForm.discriminant ^ k : ℍ → ℂ)).coeff n ∈ K := by
+  have hper : Function.Periodic
+      ((⇑CuspForm.discriminant ^ k : ℍ → ℂ) ∘ ofComplex) (1 : ℂ) := by
+    have h := periodic_discPow_comp_ofComplex k 1
+    simpa only [Nat.cast_one] using h
+  rw [qExpansion_coeff_width _ (NeZero.ne N) hper (mdiff_discPow k)
+    (isBoundedAtImInfty_discPow k), qExpansion_one_discPow]
+  split
+  · exact mem_of_rat K (ratCoeff_pow ratCoeff_discriminant k _)
+  · exact zero_mem _
+
+private lemma KPoleAt.pad {K : IntermediateField ℚ ℂ} [NeZero N] {f : ℍ → ℂ} {m m' : ℕ}
+    (hhol : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f) (hm : m ≤ m') (h : KPoleAt K N m f) :
+    KPoleAt K N m' f := by
+  obtain ⟨hper, hbd, hmem⟩ := h
+  have hshape : (f * ⇑CuspForm.discriminant ^ m' : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m) * ⇑CuspForm.discriminant ^ (m' - m) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply]
+    rw [mul_assoc, ← pow_add, Nat.add_sub_cancel' hm]
+  refine ⟨?_, ?_, ?_⟩
+  · rw [hshape]
+    exact hper.mul (periodic_discPow_comp_ofComplex (m' - m) N)
+  · exact IsBoundedAtImInfty.mul_discPow_mono hm hbd
+  · intro n
+    rw [hshape, qExpansion_mul
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hhol m) hper hbd)
+      (analyticAt_cuspFunction_zero_of (mdiff_discPow (m' - m))
+        (periodic_discPow_comp_ofComplex (m' - m) N) (isBoundedAtImInfty_discPow (m' - m))),
+      PowerSeries.coeff_mul]
+    exact sum_mem fun ij _ => mul_mem (hmem ij.1) (qExpansion_discPow_coeff_mem K _ ij.2)
+
+private lemma kPole_algebraMap {K : IntermediateField ℚ ℂ} [NeZero N] (c : ↥K) :
+    KPole K N (algebraMap ↥K (ℍ → ℂ) c) := by
+  have hshape : ((algebraMap ↥K (ℍ → ℂ) c) * ⇑CuspForm.discriminant ^ 0 : ℍ → ℂ) =
+      (c : ℂ) • (1 : ℍ → ℂ) := by
+    funext τ
+    simp only [Pi.mul_apply, pow_zero, mul_one, Pi.smul_apply, Pi.one_apply,
+      smul_eq_mul]
+    rfl
+  have hone_bd : IsBoundedAtImInfty (1 : ℍ → ℂ) := by
+    have h1 : (1 : ℍ → ℂ) = fun _ : ℍ => (1 : ℂ) := rfl
+    rw [h1]
+    exact Filter.const_boundedAtFilter _ _
+  refine ⟨mdifferentiable_const, 0, ?_, ?_, ?_⟩
+  · rw [hshape]
+    intro x
+    rfl
+  · rw [hshape]
+    have hc : ((c : ℂ) • (1 : ℍ → ℂ)) = fun _ : ℍ => (c : ℂ) := by
+      funext τ
+      simp
+    rw [hc]
+    exact Filter.const_boundedAtFilter _ _
+  · intro n
+    have han : AnalyticAt ℂ (cuspFunction N (1 : ℍ → ℂ)) 0 :=
+      analyticAt_cuspFunction_zero_of (g := (1 : ℍ → ℂ)) mdifferentiable_const
+        (periodic_one_fn N) hone_bd
+    rw [hshape, qExpansion_smul han,
+      qExpansion_one, PowerSeries.coeff_smul, smul_eq_mul, PowerSeries.coeff_one]
+    split
+    · rw [mul_one]
+      exact c.2
+    · rw [mul_zero]
+      exact zero_mem _
+
+private lemma KPole.add {K : IntermediateField ℚ ℂ} [NeZero N] {f g : ℍ → ℂ}
+    (hf : KPole K N f) (hg : KPole K N g) : KPole K N (f + g) := by
+  obtain ⟨hf1, m1, hfd⟩ := hf
+  obtain ⟨hg1, m2, hgd⟩ := hg
+  obtain ⟨hfper, hfbd, hfmem⟩ := hfd.pad hf1 (le_max_left m1 m2)
+  obtain ⟨hgper, hgbd, hgmem⟩ := hgd.pad hg1 (le_max_right m1 m2)
+  have hshape : ((f + g) * ⇑CuspForm.discriminant ^ max m1 m2 : ℍ → ℂ) =
+      f * ⇑CuspForm.discriminant ^ max m1 m2 + g * ⇑CuspForm.discriminant ^ max m1 m2 := by
+    funext τ
+    simp [add_mul]
+  refine ⟨hf1.add hg1, max m1 m2, ?_, ?_, ?_⟩
+  · rw [hshape]
+    exact hfper.add hgper
+  · rw [hshape]
+    exact hfbd.add hgbd
+  · intro n
+    rw [hshape, qExpansion_add
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hf1 _) hfper hfbd)
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hg1 _) hgper hgbd),
+      map_add]
+    exact add_mem (hfmem n) (hgmem n)
+
+private lemma KPole.mul {K : IntermediateField ℚ ℂ} [NeZero N] {f g : ℍ → ℂ}
+    (hf : KPole K N f) (hg : KPole K N g) : KPole K N (f * g) := by
+  obtain ⟨hf1, m1, hfper, hfbd, hfmem⟩ := hf
+  obtain ⟨hg1, m2, hgper, hgbd, hgmem⟩ := hg
+  have hshape : ((f * g) * ⇑CuspForm.discriminant ^ (m1 + m2) : ℍ → ℂ) =
+      (f * ⇑CuspForm.discriminant ^ m1) * (g * ⇑CuspForm.discriminant ^ m2) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply, pow_add]
+    ring
+  refine ⟨hf1.mul hg1, m1 + m2, ?_, ?_, ?_⟩
+  · rw [hshape]
+    exact hfper.mul hgper
+  · rw [hshape]
+    exact hfbd.mul hgbd
+  · intro n
+    rw [hshape, qExpansion_mul
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hf1 _) hfper hfbd)
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hg1 _) hgper hgbd),
+      PowerSeries.coeff_mul]
+    exact sum_mem fun ij _ => mul_mem (hfmem ij.1) (hgmem ij.2)
+
+end KPoleAlgebra
+
+section Transport
+
+open ModularForm
+
+variable {N : ℕ} {K : IntermediateField ℚ ℂ} {φ : ↥K →+* ℂ}
+
+private def TransAt (K : IntermediateField ℚ ℂ) (φ : ↥K →+* ℂ) (N m : ℕ)
+    (g g' : ℍ → ℂ) : Prop :=
+  KPoleAt K N m g ∧ KPoleAt K N m g' ∧
+  ∀ (n : ℕ) (z : ↥K), (z : ℂ) = (qExpansion N (g * ⇑CuspForm.discriminant ^ m)).coeff n →
+    (qExpansion N (g' * ⇑CuspForm.discriminant ^ m)).coeff n = φ z
+
+private def Trans (K : IntermediateField ℚ ℂ) (φ : ↥K →+* ℂ) (N : ℕ)
+    (g g' : ℍ → ℂ) : Prop :=
+  MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g ∧ MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g' ∧ ∃ m, TransAt K φ N m g g'
+
+private lemma TransAt.of_eq {m m₂ : ℕ} {g₁ g₁' g₂ g₂' : ℍ → ℂ}
+    (h : TransAt K φ N m g₁ g₁')
+    (e : g₁ * ⇑CuspForm.discriminant ^ m = g₂ * ⇑CuspForm.discriminant ^ m₂)
+    (e' : g₁' * ⇑CuspForm.discriminant ^ m = g₂' * ⇑CuspForm.discriminant ^ m₂) :
+    TransAt K φ N m₂ g₂ g₂' := by
+  obtain ⟨⟨h1, h2, h3⟩, ⟨h1', h2', h3'⟩, hrel⟩ := h
+  rw [e] at h1 h2 h3
+  rw [e'] at h1' h2' h3'
+  refine ⟨⟨h1, h2, h3⟩, ⟨h1', h2', h3'⟩, ?_⟩
+  intro n z hz
+  rw [← e']
+  rw [← e] at hz
+  exact hrel n z hz
+
+private lemma qExpansion_mul_pad [NeZero N] {m₁ m₂ : ℕ} {g₁ g₂ : ℍ → ℂ}
+    (hg₁ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g₁) (hg₂ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g₂)
+    (h₁per : Function.Periodic ((g₁ * ⇑CuspForm.discriminant ^ m₁) ∘ ofComplex) N)
+    (h₁bd : IsBoundedAtImInfty (g₁ * ⇑CuspForm.discriminant ^ m₁))
+    (h₂per : Function.Periodic ((g₂ * ⇑CuspForm.discriminant ^ m₂) ∘ ofComplex) N)
+    (h₂bd : IsBoundedAtImInfty (g₂ * ⇑CuspForm.discriminant ^ m₂)) :
+    qExpansion N ((g₁ * g₂) * ⇑CuspForm.discriminant ^ (m₁ + m₂)) =
+      qExpansion N (g₁ * ⇑CuspForm.discriminant ^ m₁) *
+        qExpansion N (g₂ * ⇑CuspForm.discriminant ^ m₂) := by
+  have hshape : ((g₁ * g₂) * ⇑CuspForm.discriminant ^ (m₁ + m₂) : ℍ → ℂ) =
+      (g₁ * ⇑CuspForm.discriminant ^ m₁) * (g₂ * ⇑CuspForm.discriminant ^ m₂) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply, pow_add]
+    ring
+  rw [hshape, qExpansion_mul
+    (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hg₁ m₁) h₁per h₁bd)
+    (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hg₂ m₂) h₂per h₂bd)]
+
+private lemma KPoleAt.mulAt [NeZero N] {m₁ m₂ : ℕ} {g₁ g₂ : ℍ → ℂ}
+    (hg₁ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g₁) (hg₂ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g₂)
+    (h₁ : KPoleAt K N m₁ g₁) (h₂ : KPoleAt K N m₂ g₂) :
+    KPoleAt K N (m₁ + m₂) (g₁ * g₂) := by
+  obtain ⟨h₁per, h₁bd, h₁mem⟩ := h₁
+  obtain ⟨h₂per, h₂bd, h₂mem⟩ := h₂
+  have hshape : ((g₁ * g₂) * ⇑CuspForm.discriminant ^ (m₁ + m₂) : ℍ → ℂ) =
+      (g₁ * ⇑CuspForm.discriminant ^ m₁) * (g₂ * ⇑CuspForm.discriminant ^ m₂) := by
+    funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply, pow_add]
+    ring
+  refine ⟨?_, ?_, ?_⟩
+  · rw [hshape]
+    exact h₁per.mul h₂per
+  · rw [hshape]
+    exact h₁bd.mul h₂bd
+  · intro n
+    rw [qExpansion_mul_pad hg₁ hg₂ h₁per h₁bd h₂per h₂bd, PowerSeries.coeff_mul]
+    exact sum_mem fun ij _ => mul_mem (h₁mem ij.1) (h₂mem ij.2)
+
+private lemma TransAt.mulT [NeZero N] {m₁ m₂ : ℕ} {g₁ g₁' g₂ g₂' : ℍ → ℂ}
+    (hg₁ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g₁) (hg₁' : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g₁')
+    (hg₂ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g₂) (hg₂' : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g₂')
+    (h₁ : TransAt K φ N m₁ g₁ g₁') (h₂ : TransAt K φ N m₂ g₂ g₂') :
+    TransAt K φ N (m₁ + m₂) (g₁ * g₂) (g₁' * g₂') := by
+  obtain ⟨hK₁, hK₁', hrel₁⟩ := h₁
+  obtain ⟨hK₂, hK₂', hrel₂⟩ := h₂
+  refine ⟨KPoleAt.mulAt hg₁ hg₂ hK₁ hK₂, KPoleAt.mulAt hg₁' hg₂' hK₁' hK₂', ?_⟩
+  intro n z hz
+  rw [qExpansion_mul_pad hg₁ hg₂ hK₁.1 hK₁.2.1 hK₂.1 hK₂.2.1, PowerSeries.coeff_mul] at hz
+  rw [qExpansion_mul_pad hg₁' hg₂' hK₁'.1 hK₁'.2.1 hK₂'.1 hK₂'.2.1, PowerSeries.coeff_mul]
+  have hterm : ∀ ij ∈ Finset.HasAntidiagonal.antidiagonal n,
+      (qExpansion N (g₁' * ⇑CuspForm.discriminant ^ m₁)).coeff ij.1 *
+        (qExpansion N (g₂' * ⇑CuspForm.discriminant ^ m₂)).coeff ij.2 =
+      φ (⟨(qExpansion N (g₁ * ⇑CuspForm.discriminant ^ m₁)).coeff ij.1, hK₁.2.2 ij.1⟩ *
+        ⟨(qExpansion N (g₂ * ⇑CuspForm.discriminant ^ m₂)).coeff ij.2, hK₂.2.2 ij.2⟩) := by
+    intro ij _
+    rw [map_mul, hrel₁ ij.1 ⟨_, hK₁.2.2 ij.1⟩ rfl, hrel₂ ij.2 ⟨_, hK₂.2.2 ij.2⟩ rfl]
+  rw [Finset.sum_congr rfl hterm, ← map_sum]
+  congr 1
+  apply Subtype.ext
+  rw [hz, AddSubmonoidClass.coe_finsetSum]
+  exact Finset.sum_congr rfl fun ij _ => rfl
+
+private lemma transAt_self_of_rat [NeZero N] {m : ℕ} {g : ℍ → ℂ}
+    (hper : Function.Periodic ((g * ⇑CuspForm.discriminant ^ m) ∘ ofComplex) N)
+    (hbd : IsBoundedAtImInfty (g * ⇑CuspForm.discriminant ^ m))
+    (hrat : ∀ n : ℕ, ∃ q : ℚ, (qExpansion N (g * ⇑CuspForm.discriminant ^ m)).coeff n = (q : ℂ)) :
+    TransAt K φ N m g g := by
+  have hmem : ∀ n : ℕ, (qExpansion N (g * ⇑CuspForm.discriminant ^ m)).coeff n ∈ K :=
+    fun n => mem_of_rat K (hrat n)
+  refine ⟨⟨hper, hbd, hmem⟩, ⟨hper, hbd, hmem⟩, ?_⟩
+  intro n z hz
+  obtain ⟨q, hq⟩ := hrat n
+  have hzq : z = (q : ↥K) := by
+    apply Subtype.ext
+    rw [hz, hq]
+    push_cast
+    rfl
+  rw [hzq, map_ratCast, ← hq]
+
+private lemma TransAt.padT [NeZero N] {m m' : ℕ} {g g' : ℍ → ℂ}
+    (hg : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g) (hg' : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g')
+    (hm : m ≤ m') (h : TransAt K φ N m g g') : TransAt K φ N m' g g' := by
+  have hone : ∀ k : ℕ, ((⇑CuspForm.discriminant ^ k : ℍ → ℂ) *
+      ⇑CuspForm.discriminant ^ 0 : ℍ → ℂ) = ⇑CuspForm.discriminant ^ k := by
+    intro k; funext τ; simp
+  have hΔ : TransAt K φ N 0 ((⇑CuspForm.discriminant : ℍ → ℂ) ^ (m' - m))
+      ((⇑CuspForm.discriminant : ℍ → ℂ) ^ (m' - m)) := by
+    refine transAt_self_of_rat ?_ ?_ ?_
+    · rw [hone]
+      exact periodic_discPow_comp_ofComplex (m' - m) N
+    · rw [hone]
+      exact isBoundedAtImInfty_discPow (m' - m)
+    · intro n
+      rw [hone]
+      have hper1 : Function.Periodic
+          ((⇑CuspForm.discriminant ^ (m' - m) : ℍ → ℂ) ∘ ofComplex) (1 : ℂ) := by
+        have h2 := periodic_discPow_comp_ofComplex (m' - m) 1
+        simpa only [Nat.cast_one] using h2
+      rw [qExpansion_coeff_width _ (NeZero.ne N) hper1 (mdiff_discPow (m' - m))
+        (isBoundedAtImInfty_discPow (m' - m)), qExpansion_one_discPow]
+      split
+      · exact ratCoeff_pow ratCoeff_discriminant (m' - m) _
+      · exact ⟨0, by push_cast; ring⟩
+  have hmul := TransAt.mulT hg hg' (mdiff_discPow (m' - m)) (mdiff_discPow (m' - m)) h hΔ
+  refine hmul.of_eq ?_ ?_
+  · funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply]
+    rw [mul_assoc, ← pow_add, show m' - m + (m + 0) = m' by omega]
+  · funext τ
+    simp only [Pi.mul_apply, Pi.pow_apply]
+    rw [mul_assoc, ← pow_add, show m' - m + (m + 0) = m' by omega]
+
+private lemma TransAt.addT [NeZero N] {m : ℕ} {g₁ g₁' g₂ g₂' : ℍ → ℂ}
+    (hg₁ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g₁) (hg₁' : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g₁')
+    (hg₂ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g₂) (hg₂' : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g₂')
+    (h₁ : TransAt K φ N m g₁ g₁') (h₂ : TransAt K φ N m g₂ g₂') :
+    TransAt K φ N m (g₁ + g₂) (g₁' + g₂') := by
+  obtain ⟨⟨h₁per, h₁bd, h₁mem⟩, ⟨h₁per', h₁bd', h₁mem'⟩, hrel₁⟩ := h₁
+  obtain ⟨⟨h₂per, h₂bd, h₂mem⟩, ⟨h₂per', h₂bd', h₂mem'⟩, hrel₂⟩ := h₂
+  have hshape : ∀ a b : ℍ → ℂ, ((a + b) * ⇑CuspForm.discriminant ^ m : ℍ → ℂ) =
+      a * ⇑CuspForm.discriminant ^ m + b * ⇑CuspForm.discriminant ^ m := by
+    intro a b; funext τ; simp only [Pi.add_apply, Pi.mul_apply]; ring
+  have hq : qExpansion N ((g₁ + g₂) * ⇑CuspForm.discriminant ^ m) =
+      qExpansion N (g₁ * ⇑CuspForm.discriminant ^ m) +
+        qExpansion N (g₂ * ⇑CuspForm.discriminant ^ m) := by
+    rw [hshape, qExpansion_add
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hg₁ m) h₁per h₁bd)
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hg₂ m) h₂per h₂bd)]
+  have hq' : qExpansion N ((g₁' + g₂') * ⇑CuspForm.discriminant ^ m) =
+      qExpansion N (g₁' * ⇑CuspForm.discriminant ^ m) +
+        qExpansion N (g₂' * ⇑CuspForm.discriminant ^ m) := by
+    rw [hshape, qExpansion_add
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hg₁' m) h₁per' h₁bd')
+      (analyticAt_cuspFunction_zero_of (mdiff_mul_discPow hg₂' m) h₂per' h₂bd')]
+  refine ⟨⟨?_, ?_, ?_⟩, ⟨?_, ?_, ?_⟩, ?_⟩
+  · rw [hshape]; exact h₁per.add h₂per
+  · rw [hshape]; exact h₁bd.add h₂bd
+  · intro n
+    rw [hq, map_add]
+    exact add_mem (h₁mem n) (h₂mem n)
+  · rw [hshape]; exact h₁per'.add h₂per'
+  · rw [hshape]; exact h₁bd'.add h₂bd'
+  · intro n
+    rw [hq', map_add]
+    exact add_mem (h₁mem' n) (h₂mem' n)
+  · intro n z hz
+    rw [hq, map_add] at hz
+    rw [hq', map_add, hrel₁ n ⟨_, h₁mem n⟩ rfl, hrel₂ n ⟨_, h₂mem n⟩ rfl, ← map_add]
+    congr 1
+    apply Subtype.ext
+    rw [hz]
+    rfl
+
+private lemma Trans.addF [NeZero N] {g₁ g₁' g₂ g₂' : ℍ → ℂ}
+    (h₁ : Trans K φ N g₁ g₁') (h₂ : Trans K φ N g₂ g₂') :
+    Trans K φ N (g₁ + g₂) (g₁' + g₂') := by
+  obtain ⟨hm₁, hm₁', m₁, hT₁⟩ := h₁
+  obtain ⟨hm₂, hm₂', m₂, hT₂⟩ := h₂
+  exact ⟨hm₁.add hm₂, hm₁'.add hm₂', max m₁ m₂,
+    TransAt.addT hm₁ hm₁' hm₂ hm₂'
+      (hT₁.padT hm₁ hm₁' (le_max_left m₁ m₂))
+      (hT₂.padT hm₂ hm₂' (le_max_right m₁ m₂))⟩
+
+private lemma Trans.mulF [NeZero N] {g₁ g₁' g₂ g₂' : ℍ → ℂ}
+    (h₁ : Trans K φ N g₁ g₁') (h₂ : Trans K φ N g₂ g₂') :
+    Trans K φ N (g₁ * g₂) (g₁' * g₂') := by
+  obtain ⟨hm₁, hm₁', m₁, hT₁⟩ := h₁
+  obtain ⟨hm₂, hm₂', m₂, hT₂⟩ := h₂
+  exact ⟨hm₁.mul hm₂, hm₁'.mul hm₂', m₁ + m₂, TransAt.mulT hm₁ hm₁' hm₂ hm₂' hT₁ hT₂⟩
+
+private lemma qExpansion_const_coeff [NeZero N] (x : ℂ) (n : ℕ) :
+    (qExpansion N ((fun _ : ℍ => x) * ⇑CuspForm.discriminant ^ 0)).coeff n =
+      if n = 0 then x else 0 := by
+  have hshape : ((fun _ : ℍ => x) * ⇑CuspForm.discriminant ^ 0 : ℍ → ℂ) =
+      x • (1 : ℍ → ℂ) := by
+    funext τ; simp
+  have hone_bd : IsBoundedAtImInfty (1 : ℍ → ℂ) := by
+    have h1 : (1 : ℍ → ℂ) = fun _ : ℍ => (1 : ℂ) := rfl
+    rw [h1]
+    exact Filter.const_boundedAtFilter _ _
+  have han : AnalyticAt ℂ (cuspFunction N (1 : ℍ → ℂ)) 0 :=
+    analyticAt_cuspFunction_zero_of (g := (1 : ℍ → ℂ)) mdifferentiable_const
+      (periodic_one_fn N) hone_bd
+  rw [hshape, qExpansion_smul han, qExpansion_one, PowerSeries.coeff_smul, smul_eq_mul,
+    PowerSeries.coeff_one]
+  split <;> simp
+
+private lemma transAt_const [NeZero N] (hφK : ∀ z : ↥K, φ z ∈ K) (c : ↥K) :
+    TransAt K φ N 0 (fun _ : ℍ => (c : ℂ)) (fun _ : ℍ => φ c) := by
+  have hdata : ∀ x : ℂ, Function.Periodic
+      (((fun _ : ℍ => x) * ⇑CuspForm.discriminant ^ 0 : ℍ → ℂ) ∘ ofComplex) N ∧
+      IsBoundedAtImInfty ((fun _ : ℍ => x) * ⇑CuspForm.discriminant ^ 0) := by
+    intro x
+    have hshape : ((fun _ : ℍ => x) * ⇑CuspForm.discriminant ^ 0 : ℍ → ℂ) =
+        fun _ : ℍ => x := by
+      funext τ; simp
+    rw [hshape]
+    exact ⟨fun t => rfl, Filter.const_boundedAtFilter _ _⟩
+  refine ⟨⟨(hdata _).1, (hdata _).2, ?_⟩, ⟨(hdata _).1, (hdata _).2, ?_⟩, ?_⟩
+  · intro n
+    rw [qExpansion_const_coeff]
+    split
+    · exact c.2
+    · exact zero_mem _
+  · intro n
+    rw [qExpansion_const_coeff]
+    split
+    · exact hφK c
+    · exact zero_mem _
+  · intro n z hz
+    rw [qExpansion_const_coeff] at hz
+    rw [qExpansion_const_coeff]
+    split at hz
+    · rename_i hn
+      rw [ite_eq_left hn]
+      have hzc : z = c := Subtype.ext hz
+      rw [hzc]
+    · rename_i hn
+      rw [ite_eq_right hn]
+      have hz0 : z = 0 := Subtype.ext (by rw [hz]; rfl)
+      rw [hz0, map_zero]
+
+private lemma trans_jf [NeZero N] {jf : ℍ → ℂ}
+    (hjf : ∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) :
+    Trans K φ N jf jf := by
+  have hshape : (jf * ⇑CuspForm.discriminant ^ 1 : ℍ → ℂ) = ⇑(ModularForm.E₄.pow 3) := by
+    funext τ
+    rw [congrFun (ModularForm.coe_pow ModularForm.E₄ 3) τ, Pi.pow_apply]
+    simp only [Pi.mul_apply, pow_one, hjf τ]
+    rw [congrFun CuspForm.coe_discriminant τ]
+    exact div_mul_cancel₀ _ (ModularForm.discriminant_ne_zero τ)
+  have hhol3 : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (⇑(ModularForm.E₄.pow 3) : ℍ → ℂ) :=
+    (ModularForm.E₄.pow 3).holo'
+  have hbd3 : IsBoundedAtImInfty (⇑(ModularForm.E₄.pow 3) : ℍ → ℂ) :=
+    ModularFormClass.bdd_at_infty (ModularForm.E₄.pow 3)
+  have hper3 : Function.Periodic ((⇑(ModularForm.E₄.pow 3) : ℍ → ℂ) ∘ ofComplex) 1 :=
+    SlashInvariantFormClass.periodic_comp_ofComplex (ModularForm.E₄.pow 3)
+      one_mem_strictPeriods_SL
+  have hjmd : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) jf := by
+    have h1 : jf = fun τ => ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ := funext hjf
+    rw [h1]
+    exact (ModularForm.E₄.holo'.pow 3).div CuspForm.discriminant.holo'
+      ModularForm.discriminant_ne_zero
+  refine ⟨hjmd, hjmd, 1, transAt_self_of_rat ?_ ?_ ?_⟩
+  · rw [hshape]
+    simpa using hper3.nat_mul N
+  · rw [hshape]
+    exact hbd3
+  · intro n
+    rw [hshape, qExpansion_coeff_width (⇑(ModularForm.E₄.pow 3) : ℍ → ℂ) (NeZero.ne N)
+      hper3 hhol3 hbd3]
+    split
+    · have he : qExpansion 1 (⇑(ModularForm.E₄.pow 3) : ℍ → ℂ) =
+          (qExpansion 1 ModularForm.E₄) ^ 3 :=
+        ModularForm.qExpansion_pow one_pos one_mem_strictPeriods_SL ModularForm.E₄ 3
+      rw [he]
+      exact ratCoeff_pow (ratCoeff_E (by norm_num) (by decide)) 3 _
+    · exact ⟨0, by push_cast; ring⟩
+
+private lemma trans_aeval [NeZero N] (hφK : ∀ z : ↥K, φ z ∈ K) {Idx : Type*}
+    {gen gen' : Idx → ℍ → ℂ}
+    (hgen : ∀ i, Trans K φ N (gen i) (gen' i)) (R : MvPolynomial Idx ↥K) :
+    Trans K φ N (MvPolynomial.aeval gen (MvPolynomial.map (algebraMap ↥K ℂ) R))
+      (MvPolynomial.aeval gen' (MvPolynomial.map (φ : ↥K →+* ℂ) R)) := by
+  induction R using MvPolynomial.induction_on with
+  | C c =>
+    rw [MvPolynomial.map_C, MvPolynomial.map_C, MvPolynomial.aeval_C, MvPolynomial.aeval_C]
+    have e1 : (algebraMap ℂ (ℍ → ℂ)) ((algebraMap ↥K ℂ) c) = fun _ : ℍ => (c : ℂ) := rfl
+    have e2 : (algebraMap ℂ (ℍ → ℂ)) (φ c) = fun _ : ℍ => φ c := rfl
+    rw [e1, e2]
+    exact ⟨mdifferentiable_const, mdifferentiable_const, 0, transAt_const hφK c⟩
+  | add p q ihp ihq =>
+    rw [map_add, map_add, map_add, map_add]
+    exact Trans.addF ihp ihq
+  | mul_X p i ih =>
+    have e1 : MvPolynomial.map (algebraMap ↥K ℂ) (p * MvPolynomial.X i) =
+        MvPolynomial.map (algebraMap ↥K ℂ) p * MvPolynomial.X i := by
+      rw [map_mul, MvPolynomial.map_X]
+    have e2 : MvPolynomial.map (φ : ↥K →+* ℂ) (p * MvPolynomial.X i) =
+        MvPolynomial.map (φ : ↥K →+* ℂ) p * MvPolynomial.X i := by
+      rw [map_mul, MvPolynomial.map_X]
+    rw [e1, e2, map_mul, map_mul, MvPolynomial.aeval_X, MvPolynomial.aeval_X]
+    exact Trans.mulF ih (hgen i)
+
+end Transport
+
+section IdentityTransport
+
+open ModularForm
+
+variable {N : ℕ} {K : IntermediateField ℚ ℂ} {φ : ↥K →+* ℂ}
+
+private lemma analyticAt_zero_fn [NeZero N] :
+    AnalyticAt ℂ (cuspFunction N (0 : ℍ → ℂ)) 0 := by
+  have hN' : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  refine analyticAt_cuspFunction_zero hN' (fun x => rfl) mdifferentiable_const ?_
+  have h0 : (0 : ℍ → ℂ) = fun _ : ℍ => (0 : ℂ) := rfl
+  rw [h0]
+  exact Filter.const_boundedAtFilter _ _
+
+private lemma qExpansion_zero_fn [NeZero N] : qExpansion N (0 : ℍ → ℂ) = 0 := by
+  have h0 : (0 : ℍ → ℂ) = (0 : ℂ) • (0 : ℍ → ℂ) := by rw [zero_smul]
+  rw [h0, qExpansion_smul analyticAt_zero_fn, zero_smul]
+
+private lemma discPow_ne_zero (m : ℕ) (τ : ℍ) :
+    ((⇑CuspForm.discriminant : ℍ → ℂ) ^ m) τ ≠ 0 := by
+  simp only [Pi.pow_apply]
+  refine pow_ne_zero m ?_
+  rw [congrFun CuspForm.coe_discriminant τ]
+  exact ModularForm.discriminant_ne_zero τ
+
+private lemma Trans.eq_zero_fwd [NeZero N] {g g' : ℍ → ℂ}
+    (h : Trans K φ N g g') (hg0 : g = 0) : g' = 0 := by
+  have hN' : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  obtain ⟨hm, hm', m, ⟨hK1, hK1', hrel⟩⟩ := h
+  have hq0 : qExpansion N (g * ⇑CuspForm.discriminant ^ m) = 0 := by
+    have h1 : (g * ⇑CuspForm.discriminant ^ m : ℍ → ℂ) = 0 := by
+      rw [hg0]; funext τ; simp
+    rw [h1, qExpansion_zero_fn]
+  have hq0' : qExpansion N (g' * ⇑CuspForm.discriminant ^ m) = 0 := by
+    ext n
+    have hcoeff : (qExpansion N (g * ⇑CuspForm.discriminant ^ m)).coeff n = 0 := by
+      rw [hq0, map_zero]
+    have h2 := hrel n ⟨_, hK1.2.2 n⟩ rfl
+    rw [h2]
+    have hz0 : (⟨(qExpansion N (g * ⇑CuspForm.discriminant ^ m)).coeff n, hK1.2.2 n⟩ : ↥K)
+        = 0 := Subtype.ext hcoeff
+    rw [hz0, map_zero, map_zero]
+  have hfn0 : (g' * ⇑CuspForm.discriminant ^ m : ℍ → ℂ) = 0 := by
+    rw [qExpansion_eq_zero_iff hN' hK1'.1 (mdiff_mul_discPow hm' m) hK1'.2.1] at hq0'
+    exact hq0'
+  funext τ
+  have h3 := congrFun hfn0 τ
+  simp only [Pi.mul_apply, Pi.zero_apply] at h3 ⊢
+  exact (mul_eq_zero.mp h3).resolve_right (discPow_ne_zero m τ)
+
+private lemma Trans.eq_zero_rev [NeZero N] {g g' : ℍ → ℂ}
+    (h : Trans K φ N g g') (hg0' : g' = 0) : g = 0 := by
+  have hN' : (0 : ℝ) < N := by exact_mod_cast Nat.pos_of_ne_zero (NeZero.ne N)
+  obtain ⟨hm, hm', m, ⟨hK1, hK1', hrel⟩⟩ := h
+  have hq0' : qExpansion N (g' * ⇑CuspForm.discriminant ^ m) = 0 := by
+    have h1 : (g' * ⇑CuspForm.discriminant ^ m : ℍ → ℂ) = 0 := by
+      rw [hg0']; funext τ; simp
+    rw [h1, qExpansion_zero_fn]
+  have hq0 : qExpansion N (g * ⇑CuspForm.discriminant ^ m) = 0 := by
+    ext n
+    have h2 := hrel n ⟨_, hK1.2.2 n⟩ rfl
+    have h3 : φ (⟨(qExpansion N (g * ⇑CuspForm.discriminant ^ m)).coeff n, hK1.2.2 n⟩ : ↥K)
+        = 0 := by
+      rw [← h2, hq0', map_zero]
+    have h4 := φ.injective (by rw [h3, map_zero] :
+      φ (⟨(qExpansion N (g * ⇑CuspForm.discriminant ^ m)).coeff n, hK1.2.2 n⟩ : ↥K) = φ 0)
+    have h5 := congrArg (fun z : ↥K => (z : ℂ)) h4
+    simpa using h5
+  have hfn0 : (g * ⇑CuspForm.discriminant ^ m : ℍ → ℂ) = 0 := by
+    rw [qExpansion_eq_zero_iff hN' hK1.1 (mdiff_mul_discPow hm m) hK1.2.1] at hq0
+    exact hq0
+  funext τ
+  have h3 := congrFun hfn0 τ
+  simp only [Pi.mul_apply, Pi.zero_apply] at h3 ⊢
+  exact (mul_eq_zero.mp h3).resolve_right (discPow_ne_zero m τ)
+
+end IdentityTransport
+
+end WLight
+
+open WLight in
+theorem solution (N : ℕ) [NeZero N]
+    (K : IntermediateField ℚ ℂ) (φ : ↥K →+* ℂ) (hφK : ∀ z : ↥K, φ z ∈ K)
+    (T : (ℍ → ℂ) → (ℍ → ℂ) → Prop)
+    (hT : ∀ g g' : ℍ → ℂ, T g g' ↔
+        (MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g ∧ MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g' ∧
+          ∃ m : ℕ,
+            (Function.Periodic ((g * ModularForm.discriminant ^ m) ∘ UpperHalfPlane.ofComplex) N ∧
+              IsBoundedAtImInfty (g * ModularForm.discriminant ^ m) ∧
+              ∀ n : ℕ,
+                (UpperHalfPlane.qExpansion N (g * ModularForm.discriminant ^ m)).coeff n ∈ K) ∧
+            (Function.Periodic ((g' * ModularForm.discriminant ^ m) ∘ UpperHalfPlane.ofComplex) N ∧
+              IsBoundedAtImInfty (g' * ModularForm.discriminant ^ m) ∧
+              ∀ n : ℕ,
+                (UpperHalfPlane.qExpansion N (g' * ModularForm.discriminant ^ m)).coeff n ∈ K) ∧
+            ∀ (n : ℕ) (z : ↥K),
+              (z : ℂ) = (UpperHalfPlane.qExpansion N (g * ModularForm.discriminant ^ m)).coeff n →
+              (UpperHalfPlane.qExpansion N (g' * ModularForm.discriminant ^ m)).coeff n = φ z)) :
+    (∀ {ι : Type} (g g' : ι → ℍ → ℂ), (∀ i : ι, T (g i) (g' i)) → ∀ R : MvPolynomial ι ↥K,
+        T (MvPolynomial.aeval g (MvPolynomial.map (algebraMap ↥K ℂ) R))
+          (MvPolynomial.aeval g' (MvPolynomial.map φ R))) ∧
+    (∀ g g' : ℍ → ℂ, T g g' → (g = 0 ↔ g' = 0)) ∧
+    ∀ jf : ℍ → ℂ, (∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) → T jf jf :=
+      by
+  have hT' : ∀ g g' : ℍ → ℂ, T g g' ↔ Trans K φ N g g' := fun g g' => hT g g'
+  refine ⟨fun g g' hg R => ?_, fun g g' h => ?_, fun jf hjf => (hT' jf jf).mpr (trans_jf hjf)⟩
+  · exact (hT' _ _).mpr (trans_aeval hφK (fun i => (hT' _ _).mp (hg i)) R)
+  · have h' := (hT' g g').mp h
+    exact ⟨fun h0 => h'.eq_zero_fwd h0, fun h0 => h'.eq_zero_rev h0⟩
+
+end
+end S_WLight_qExpansion_sigmaTransport_package
+end P2MW
+export P2MW.S_WLight_qExpansion_sigmaTransport_package (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Complex Real UpperHalfPlane
+open scoped Manifold MatrixGroups ModularForm
+theorem WLight.qExpansion_sigmaTransport_package (N : ℕ) [NeZero N]
+    (K : IntermediateField ℚ ℂ) (φ : ↥K →+* ℂ) (hφK : ∀ z : ↥K, φ z ∈ K)
+    (T : (ℍ → ℂ) → (ℍ → ℂ) → Prop)
+    (hT : ∀ g g' : ℍ → ℂ, T g g' ↔
+        (MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g ∧ MDifferentiable 𝓘(ℂ) 𝓘(ℂ) g' ∧
+          ∃ m : ℕ,
+            (Function.Periodic ((g * ModularForm.discriminant ^ m) ∘ UpperHalfPlane.ofComplex) N ∧
+              IsBoundedAtImInfty (g * ModularForm.discriminant ^ m) ∧
+              ∀ n : ℕ,
+                (UpperHalfPlane.qExpansion N (g * ModularForm.discriminant ^ m)).coeff n ∈ K) ∧
+            (Function.Periodic ((g' * ModularForm.discriminant ^ m) ∘ UpperHalfPlane.ofComplex) N ∧
+              IsBoundedAtImInfty (g' * ModularForm.discriminant ^ m) ∧
+              ∀ n : ℕ,
+                (UpperHalfPlane.qExpansion N (g' * ModularForm.discriminant ^ m)).coeff n ∈ K) ∧
+            ∀ (n : ℕ) (z : ↥K),
+              (z : ℂ) = (UpperHalfPlane.qExpansion N (g * ModularForm.discriminant ^ m)).coeff n →
+              (UpperHalfPlane.qExpansion N (g' * ModularForm.discriminant ^ m)).coeff n = φ z)) :
+    (∀ {ι : Type} (g g' : ι → ℍ → ℂ), (∀ i : ι, T (g i) (g' i)) → ∀ R : MvPolynomial ι ↥K,
+        T (MvPolynomial.aeval g (MvPolynomial.map (algebraMap ↥K ℂ) R))
+          (MvPolynomial.aeval g' (MvPolynomial.map φ R))) ∧
+    (∀ g g' : ℍ → ℂ, T g g' → (g = 0 ↔ g' = 0)) ∧
+    ∀ jf : ℍ → ℂ, (∀ τ : ℍ, jf τ = ModularForm.E₄ τ ^ 3 / ModularForm.discriminant τ) → T jf jf :=
+  solution N K φ hφK T hT
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_weierstrassP_qExpansion_package.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_weierstrassP_qExpansion_package.lean
new file mode 100644
index 0000000000..eebc2d7ed3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WLight_weierstrassP_qExpansion_package.lean
@@ -0,0 +1,950 @@
+/-
+Based on Prove2Me node WLight.weierstrassP_qExpansion_package
+(cb820829-eaed-5178-8fab-60e3462d9566) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3b7f058f-b44e-52be-bd12-53439af5eb98
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Analysis.SpecialFunctions.Elliptic.Weierstrass
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Manifold
+public import Mathlib.Analysis.Complex.IntegerCompl
+public import Mathlib.Geometry.Manifold.Notation
+
+import Mathlib.NumberTheory.ModularForms.EisensteinSeries.QExpansion
+import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+import Mathlib.RingTheory.DedekindDomain.IntegralClosure
+import Mathlib.RingTheory.DedekindDomain.Ideal.Lemmas
+import Mathlib.RingTheory.Unramified.Field
+import Mathlib.Analysis.Meromorphic.NormalForm
+import Mathlib.RingTheory.Discriminant
+import Mathlib.RingTheory.Adjoin.PowerBasis
+import Mathlib.FieldTheory.PrimitiveElement
+import Mathlib.RingTheory.RootsOfUnity.Complex
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.LinearAlgebra.Lagrange
+import Mathlib.FieldTheory.LinearDisjoint
+import Mathlib.FieldTheory.Galois.Infinite
+import Mathlib.RingTheory.AlgebraicIndependent.TranscendenceBasis
+import Mathlib.RingTheory.AlgebraicIndependent.AlgebraicClosure
+import Mathlib.RingTheory.AlgebraicIndependent.Adjoin
+import Mathlib.RingTheory.Polynomial.RationalRoot
+import Mathlib.Analysis.Analytic.Order
+import Mathlib.RingTheory.PowerSeries.Order
+import Mathlib.RingTheory.Polynomial.IsIntegral
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Lipschitz's formula and the q-expansion of wp at torsion points
+
+Theorem statement: `WLight.weierstrassP_qExpansion_package`
+(`cb820829-eaed-5178-8fab-60e3462d9566`), by Claude, 2026-09-05.
+
+Proof: submission `3b7f058f-b44e-52be-bd12-53439af5eb98`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+A closed conjunction of five analytic statements, where `PeriodPair` is the structure carrying
+periods `ω₁`, `ω₂` and `PeriodPair.weierstrassP` is the associated Weierstrass $\wp$-function. (i)
+For $w\in\mathbb{C}$ with $\operatorname{Im} w>0$, $\sum_{n\in\mathbb{Z}}(w+n)^{-2}=(2\pi
+i)^2\sum_{m\ge 0}m\,e^{2\pi i m w}$. (ii) The same for $\operatorname{Im} w<0$ with $e^{-2\pi i w}$
+in place of $e^{2\pi i w}$. (iii) For $z,\tau\in\mathbb{C}$ with
+$-\operatorname{Im}\tau<\operatorname{Im} z<\operatorname{Im}\tau$ and $z$ in
+`Complex.integerComplement`, the sum over $c\in\mathbb{Z}$ of
+$\sum_{d\in\mathbb{Z}}(z-c\tau+d)^{-2}-\sum_{d\in\mathbb{Z}}(c\tau+d)^{-2}$ equals $(2\pi
+i)^2\bigl(\omega(1-\omega)^{-2}+\tfrac1{12}+\sum_{c\ge 1}\sum_{m\ge
+0}m(\omega^m+\omega^{-m}-2)q^{cm}\bigr)$, with $\omega=e^{2\pi i z}$, $q=e^{2\pi i\tau}$. (iv) For
+every $L:\mathbb{H}\to$ `PeriodPair` with $(L\tau).\omega_1=\tau$, $(L\tau).\omega_2=1$, and all
+naturals $N,a_1,a_2$ with $a_1,a_2<N$ and $a_1\ne 0$ or $a_2\ne 0$: $\wp_{L\tau}((a_1\tau+a_2)/N)$
+is given by the stated double series in $\zeta_N=e^{2\pi i/N}$ and $q_N=e^{2\pi i\tau/N}$ summed
+over $\mathbb{N}_{>0}\times\mathbb{N}_{>0}$ (the second exponent using truncated subtraction
+$p_1N-a_1$), and $\tau\mapsto\wp_{L\tau}((a_1\tau+a_2)/N)$ is differentiable on $\mathbb{H}$ as a
+map of complex manifolds. (v) For `PeriodPair`s $L,L'$ and $c\in\mathbb{C}$ with
+$L'.\omega_1=cL.\omega_1$ and $L'.\omega_2=cL.\omega_2$, one has $\wp_{L'}(cz)=c^{-2}\wp_L(z)$ for
+all $z$; no hypothesis $c\neq 0$ is imposed.
+
+Parts (i)–(ii) are Lipschitz's (Eisenstein's) formula in weight $2$, (iii) the resulting strip
+expansion of $\wp_{(\tau,1)}(z)-$ its constant term, (iv) its specialisation to $N$-torsion points
+together with holomorphy in $\tau$, and (v) the degree $-2$ homogeneity of $\wp$ under scaling of
+the period pair. It is the analytic input for the $q$-expansions of the Fricke functions, used by
+the statements producing modular forms whose $q$-expansion coefficients match those of Fricke
+functions substituted into the Tate curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WLight_weierstrassP_qExpansion_package.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WLight_weierstrassP_qExpansion_package
+
+noncomputable section
+
+open Complex Real
+
+namespace WLight
+
+section B1_homogeneity
+
+open PeriodPair
+
+def smulPeriodPair (a : ℂ) (ha : a ≠ 0) (L : PeriodPair) : PeriodPair where
+  ω₁ := a * L.ω₁
+  ω₂ := a * L.ω₂
+  indep := LinearIndependent.pair_iff.mpr fun s t hst => by
+    refine LinearIndependent.pair_iff.mp L.indep s t ?_
+    have h0 : a * (s • L.ω₁ + t • L.ω₂) = 0 := by
+      rw [mul_add, mul_smul_comm, mul_smul_comm]; exact hst
+    exact (mul_eq_zero.mp h0).resolve_left ha
+
+@[scoped simp] lemma smulPeriodPair_ω₁ (a : ℂ) (ha : a ≠ 0) (L : PeriodPair) :
+    (smulPeriodPair a ha L).ω₁ = a * L.ω₁ := rfl
+
+@[scoped simp] lemma smulPeriodPair_ω₂ (a : ℂ) (ha : a ≠ 0) (L : PeriodPair) :
+    (smulPeriodPair a ha L).ω₂ = a * L.ω₂ := rfl
+
+lemma mem_smulPeriodPair_lattice {a : ℂ} (ha : a ≠ 0) (L : PeriodPair) {x : ℂ} :
+    x ∈ (smulPeriodPair a ha L).lattice ↔ ∃ y ∈ L.lattice, x = a * y := by
+  simp only [mem_lattice, smulPeriodPair_ω₁, smulPeriodPair_ω₂]
+  constructor
+  · rintro ⟨m, n, h⟩
+    exact ⟨(m : ℂ) * L.ω₁ + (n : ℂ) * L.ω₂, ⟨m, n, rfl⟩, by rw [← h]; ring⟩
+  · rintro ⟨y, ⟨m, n, h⟩, rfl⟩
+    exact ⟨m, n, by rw [← h]; ring⟩
+
+def smulLatticeEquiv (a : ℂ) (ha : a ≠ 0) (L : PeriodPair) :
+    L.lattice ≃ (smulPeriodPair a ha L).lattice where
+  toFun l := ⟨a * l, (mem_smulPeriodPair_lattice ha L).mpr ⟨l, l.2, rfl⟩⟩
+  invFun l := ⟨a⁻¹ * l, by
+    obtain ⟨y, hy, hxy⟩ := (mem_smulPeriodPair_lattice ha L).mp l.2
+    rw [hxy, inv_mul_cancel_left₀ ha]; exact hy⟩
+  left_inv l := Subtype.ext (inv_mul_cancel_left₀ ha _)
+  right_inv l := Subtype.ext (mul_inv_cancel_left₀ ha _)
+
+@[scoped simp] lemma smulLatticeEquiv_coe (a : ℂ) (ha : a ≠ 0) (L : PeriodPair) (l : L.lattice) :
+    ((smulLatticeEquiv a ha L) l : ℂ) = a * l := rfl
+
+theorem weierstrassP_smulPeriodPair (a : ℂ) (ha : a ≠ 0) (L : PeriodPair) (z : ℂ) :
+    weierstrassP (smulPeriodPair a ha L) (a * z) = a⁻¹ ^ 2 * weierstrassP L z := by
+  have key : ∀ u : ℂ, 1 / (a * u) ^ 2 = a⁻¹ ^ 2 * (1 / u ^ 2) := fun u => by
+    simp [one_div, mul_pow, inv_pow, mul_comm]
+  simp only [weierstrassP]
+  rw [← (smulLatticeEquiv a ha L).tsum_eq, ← tsum_mul_left]
+  congr with l
+  simp only [smulLatticeEquiv_coe]
+  rw [show a * z - a * (l : ℂ) = a * (z - l) by ring, key, key, mul_sub]
+
+end B1_homogeneity
+
+section B2_lipschitz
+
+theorem summable_one_div_add_int_sq (w : ℂ) :
+    Summable fun n : ℤ ↦ 1 / (w + n) ^ 2 := by
+  simpa [one_div] using EisensteinSeries.linear_right_summable w 1 (k := 2) le_rfl
+
+theorem tsum_one_div_add_int_sq_neg (w : ℂ) :
+    ∑' n : ℤ, 1 / (-w + n) ^ 2 = ∑' n : ℤ, 1 / (w + n) ^ 2 := by
+  rw [← (Equiv.neg ℤ).tsum_eq]
+  refine tsum_congr fun n ↦ ?_
+  simp only [Equiv.neg_apply, Int.cast_neg]
+  ring
+
+theorem tsum_one_div_sub_int_sq (w : ℂ) :
+    ∑' n : ℤ, 1 / (w - n) ^ 2 = ∑' n : ℤ, 1 / (w + n) ^ 2 := by
+  rw [← (Equiv.neg ℤ).tsum_eq]
+  refine tsum_congr fun n ↦ ?_
+  simp [sub_eq_add_neg]
+
+theorem lipschitz_two_of_im_pos {w : ℂ} (hw : 0 < w.im) :
+    ∑' n : ℤ, 1 / (w + n) ^ 2 =
+      (2 * π * I) ^ 2 * ∑' m : ℕ, (m : ℂ) * cexp (2 * π * I * w) ^ m := by
+  have h := EisensteinSeries.qExpansion_identity (k := 1) le_rfl ⟨w, hw⟩
+  simp only [Nat.reduceAdd, pow_one, Nat.factorial_one, Nat.cast_one, div_one] at h
+  rw [h]
+  ring
+
+theorem lipschitz_two_of_im_neg {w : ℂ} (hw : w.im < 0) :
+    ∑' n : ℤ, 1 / (w + n) ^ 2 =
+      (2 * π * I) ^ 2 * ∑' m : ℕ, (m : ℂ) * cexp (-(2 * π * I * w)) ^ m := by
+  rw [← tsum_one_div_add_int_sq_neg, lipschitz_two_of_im_pos (w := -w) (by simpa using hw)]
+  simp [mul_neg]
+
+theorem summable_nat_mul_cexp_pow {w : ℂ} (hw : 0 < w.im) :
+    Summable fun m : ℕ ↦ (m : ℂ) * cexp (2 * π * I * w) ^ m := by
+  simpa using summable_pow_mul_cexp 1 1 ⟨w, hw⟩
+
+theorem cexp_two_pi_I_mul_ne_one {x : ℂ} (hx : x ∈ Complex.integerComplement) :
+    cexp (2 * π * I * x) ≠ 1 := by
+  intro h
+  obtain ⟨n, hn⟩ := Complex.exp_eq_one_iff.mp h
+  have h2 : (2 * π * I : ℂ) ≠ 0 := by simp [Real.pi_ne_zero, I_ne_zero]
+  have : x = n := by
+    have := congrArg (· / (2 * π * I)) hn
+    simpa [mul_div_assoc, div_self h2, mul_comm] using this
+  exact hx ⟨n, this.symm⟩
+
+theorem lipschitz_two_closed_of_im_pos {x : ℂ} (hx : 0 < x.im) :
+    ∑' n : ℤ, 1 / (x + n) ^ 2 =
+      (2 * π * I) ^ 2 * (cexp (2 * π * I * x) / (1 - cexp (2 * π * I * x)) ^ 2) := by
+  rw [lipschitz_two_of_im_pos hx, tsum_coe_mul_geometric_of_norm_lt_one]
+  simpa using UpperHalfPlane.norm_exp_two_pi_I_lt_one ⟨x, hx⟩
+
+theorem lipschitz_two_closed_of_im_neg {x : ℂ} (hx : x.im < 0) :
+    ∑' n : ℤ, 1 / (x + n) ^ 2 =
+      (2 * π * I) ^ 2 * (cexp (2 * π * I * x) / (1 - cexp (2 * π * I * x)) ^ 2) := by
+  have hr : ‖cexp (-(2 * π * I * x))‖ < 1 := by
+    simpa [mul_neg] using UpperHalfPlane.norm_exp_two_pi_I_lt_one ⟨-x, by simpa using hx⟩
+  have hq0 : cexp (2 * π * I * x) ≠ 0 := Complex.exp_ne_zero _
+  have hq1 : 1 - cexp (2 * π * I * x) ≠ 0 := by
+    intro h0
+    have h1 : ‖cexp (2 * π * I * x)‖ = 1 := by rw [(sub_eq_zero.mp h0).symm, norm_one]
+    rw [Complex.norm_exp] at h1
+    have : (2 * π * I * x).re = -(2 * π * x.im) := by simp [mul_comm]
+    rw [this, Real.exp_eq_one_iff] at h1
+    nlinarith [Real.pi_pos]
+  have hr1 : 1 - cexp (-(2 * π * I * x)) ≠ 0 := by
+    rw [Complex.exp_neg]
+    intro h0
+    apply hq1
+    have := sub_eq_zero.mp h0
+    rw [eq_comm, inv_eq_one] at this
+    simp [this]
+  rw [lipschitz_two_of_im_neg hx, tsum_coe_mul_geometric_of_norm_lt_one hr]
+  congr 1
+  rw [Complex.exp_neg] at hr1 ⊢
+  rw [div_eq_div_iff (pow_ne_zero 2 hr1) (pow_ne_zero 2 hq1)]
+  field_simp
+  ring
+
+open Metric Set Filter Topology in
+theorem lipschitz_two_closed {x : ℂ} (hx : x ∈ Complex.integerComplement) :
+    ∑' n : ℤ, 1 / (x + n) ^ 2 =
+      (2 * π * I) ^ 2 * (cexp (2 * π * I * x) / (1 - cexp (2 * π * I * x)) ^ 2) := by
+  rcases lt_trichotomy x.im 0 with h | h | h
+  · exact lipschitz_two_closed_of_im_neg h
+  swap
+  · exact lipschitz_two_closed_of_im_pos h
+  obtain ⟨ε, hε, hball⟩ := Metric.isOpen_iff.mp Complex.isOpen_compl_range_intCast x hx
+  set U : Set ℂ := ball x (ε / 2) with hUdef
+  have hUsub : U ⊆ Complex.integerComplement :=
+    (ball_subset_ball (half_le_self hε.le)).trans hball
+  have hsep : ∀ y ∈ U, ∀ n : ℤ, ε / 2 ≤ ‖y + n‖ := by
+    intro y hy n
+    by_contra! hlt
+    have hmem : ((-n : ℤ) : ℂ) ∈ ball x ε := by
+      rw [mem_ball, dist_comm, dist_eq_norm]
+      calc ‖x - ((-n : ℤ) : ℂ)‖ = ‖(x - y) + (y + n)‖ := by push_cast; ring_nf
+        _ ≤ ‖x - y‖ + ‖y + n‖ := norm_add_le _ _
+        _ < ε / 2 + ε / 2 := by
+            gcongr
+            rw [← dist_eq_norm, dist_comm]; exact hy
+        _ = ε := by ring
+    exact hball hmem ⟨-n, rfl⟩
+  have hne : ∀ y ∈ U, ∀ n : ℤ, y + n ≠ 0 := fun y hy n h0 ↦ by
+    have := hsep y hy n
+    rw [h0, norm_zero] at this
+    linarith
+  have hnormU : ∀ y ∈ U, ‖y‖ ≤ ‖x‖ + ε / 2 := by
+    intro y hy
+    have : ‖y - x‖ < ε / 2 := by rw [← dist_eq_norm]; exact hy
+    calc ‖y‖ = ‖x + (y - x)‖ := by ring_nf
+      _ ≤ ‖x‖ + ‖y - x‖ := norm_add_le _ _
+      _ ≤ ‖x‖ + ε / 2 := by linarith
+  set R : ℝ := ‖x‖ + ε / 2 with hRdef
+  set K : ℕ := ⌈2 * R⌉₊ with hKdef
+  set u : ℤ → ℝ := fun n ↦
+    (if n ∈ Finset.Icc (-(K : ℤ)) K then 4 / ε ^ 2 else 0) + 4 * (1 / (n : ℝ) ^ 2) with hudef
+  have hu : Summable u := by
+    refine Summable.add ?_ ((summable_one_div_int_pow.mpr one_lt_two).mul_left 4)
+    exact summable_of_ne_finset_zero (s := Finset.Icc (-(K : ℤ)) K) (by intro b hb; simp [hb])
+  have hbound : ∀ (n : ℤ) (y : ℂ), y ∈ U → ‖1 / (y + n) ^ 2‖ ≤ u n := by
+    intro n y hy
+    have hpos : 0 < ‖y + n‖ := norm_pos_iff.mpr (hne y hy n)
+    rw [norm_div, norm_one, norm_pow]
+    by_cases hn : n ∈ Finset.Icc (-(K : ℤ)) K
+    · simp only [hudef, hn, ite_true]
+      have h1 : 1 / ‖y + ↑n‖ ^ 2 ≤ 4 / ε ^ 2 := by
+        rw [div_le_div_iff₀ (by positivity) (by positivity), one_mul]
+        nlinarith [hsep y hy n, norm_nonneg (y + n)]
+      have h2 : (0 : ℝ) ≤ 4 * (1 / (n : ℝ) ^ 2) := by positivity
+      linarith
+    · simp only [hudef, hn, ite_false, zero_add]
+      have hnK : (K : ℝ) < |(n : ℝ)| := by
+        simp only [Finset.mem_Icc, not_and_or, not_le] at hn
+        rw [← Int.cast_abs]
+        rcases hn with hn | hn
+        · have : (K : ℤ) < |n| := by rw [abs_of_neg (by omega)]; omega
+          exact_mod_cast this
+        · have : (K : ℤ) < |n| := lt_of_lt_of_le hn (le_abs_self n)
+          exact_mod_cast this
+      have hR2 : 2 * R ≤ K := Nat.le_ceil _
+      have hyR : ‖y‖ ≤ R := hnormU y hy
+      have hlow : |(n : ℝ)| / 2 ≤ ‖y + n‖ := by
+        have : |(n : ℝ)| ≤ ‖y + n‖ + ‖y‖ := by
+          calc |(n : ℝ)| = ‖((n : ℝ) : ℂ)‖ := by rw [Complex.norm_real, Real.norm_eq_abs]
+            _ = ‖(y + n) - y‖ := by push_cast; ring_nf
+            _ ≤ ‖y + n‖ + ‖y‖ := norm_sub_le _ _
+        linarith
+      have hnpos : 0 < |(n : ℝ)| := by linarith [Nat.cast_nonneg (α := ℝ) K]
+      rw [show (4 : ℝ) * (1 / (n : ℝ) ^ 2) = 1 / (|(n : ℝ)| / 2) ^ 2 by
+        rw [div_pow, sq_abs]; field_simp; ring]
+      exact one_div_le_one_div_of_le (by positivity) (by gcongr)
+  have hF : DifferentiableOn ℂ (fun y : ℂ ↦ ∑' n : ℤ, 1 / (y + n) ^ 2) U := by
+    refine differentiableOn_tsum_of_summable_norm hu (fun n ↦ ?_) isOpen_ball hbound
+    exact DifferentiableOn.div (by fun_prop) (by fun_prop) fun y hy ↦ pow_ne_zero _ (hne y hy n)
+  have hG : DifferentiableOn ℂ
+      (fun y : ℂ ↦ (2 * π * I) ^ 2 * (cexp (2 * π * I * y) / (1 - cexp (2 * π * I * y)) ^ 2))
+      U := by
+    refine DifferentiableOn.mul (by fun_prop) (DifferentiableOn.div (by fun_prop) (by fun_prop) ?_)
+    intro y hy
+    exact pow_ne_zero _ (sub_ne_zero.mpr (cexp_two_pi_I_mul_ne_one (hUsub hy)).symm)
+  set z₀ : ℂ := x + (ε / 4 : ℝ) * I with hz₀def
+  have hz₀U : z₀ ∈ U := by
+    rw [hUdef, mem_ball, dist_eq_norm, hz₀def, add_sub_cancel_left, norm_mul, Complex.norm_real,
+      Complex.norm_I, mul_one, Real.norm_eq_abs, abs_of_pos (by positivity)]
+    linarith
+  have hz₀im : 0 < z₀.im := by simp [hz₀def, h, hε]
+  have hfg : (fun y : ℂ ↦ ∑' n : ℤ, 1 / (y + n) ^ 2) =ᶠ[𝓝 z₀]
+      (fun y : ℂ ↦ (2 * π * I) ^ 2 * (cexp (2 * π * I * y) / (1 - cexp (2 * π * I * y)) ^ 2)) := by
+    filter_upwards [(isOpen_lt continuous_const Complex.continuous_im).mem_nhds hz₀im] with y hy
+    exact lipschitz_two_closed_of_im_pos hy
+  exact (hF.analyticOnNhd isOpen_ball).eqOn_of_preconnected_of_eventuallyEq
+    (hG.analyticOnNhd isOpen_ball) (convex_ball x _).isPreconnected hz₀U hfg
+    (mem_ball_self (half_pos hε))
+
+theorem summable_one_div_sub_int_sq (w : ℂ) :
+    Summable fun n : ℤ ↦ 1 / (w - n) ^ 2 := by
+  refine (Equiv.neg ℤ).summable_iff.mp ?_
+  simpa [Function.comp_def, sub_eq_add_neg] using summable_one_div_add_int_sq w
+
+theorem tsum_int_one_div_sq : ∑' n : ℤ, 1 / ((n : ℂ)) ^ 2 = (π : ℂ) ^ 2 / 3 := by
+  have h := two_mul_riemannZeta_eq_tsum_int_inv_pow_of_even (k := 2) le_rfl even_two
+  simp only [Nat.cast_ofNat, riemannZeta_two] at h
+  simp only [one_div, ← h]
+  ring
+
+theorem two_pi_I_sq : (2 * π * I : ℂ) ^ 2 = -(4 * π ^ 2) := by
+  rw [mul_pow, I_sq]; ring
+
+theorem neg_pi_sq_div_three_div : -((π : ℂ) ^ 2 / 3) = (2 * π * I) ^ 2 * (1 / 12) := by
+  rw [two_pi_I_sq]; ring
+
+theorem tsum_row_split (z l₀ : ℂ) :
+    ∑' d : ℤ, (1 / (z - (l₀ + d)) ^ 2 - 1 / (l₀ + d) ^ 2) =
+      ∑' d : ℤ, 1 / ((z - l₀) + d) ^ 2 - ∑' d : ℤ, 1 / (l₀ + d) ^ 2 := by
+  rw [Summable.tsum_sub _ (summable_one_div_add_int_sq l₀), ← tsum_one_div_sub_int_sq (z - l₀)]
+  · exact congrArg₂ _ (tsum_congr fun d ↦ by ring_nf) rfl
+  · simpa [sub_sub] using summable_one_div_sub_int_sq (z - l₀)
+
+theorem tsum_row_zero (z : ℂ) :
+    ∑' d : ℤ, (1 / (z - d) ^ 2 - 1 / ((d : ℂ)) ^ 2) =
+      ∑' d : ℤ, 1 / (z + d) ^ 2 - (π : ℂ) ^ 2 / 3 := by
+  rw [Summable.tsum_sub (summable_one_div_sub_int_sq z), tsum_one_div_sub_int_sq,
+    tsum_int_one_div_sq]
+  simpa [one_div] using EisensteinSeries.linear_right_summable (0 : ℂ) 1 (k := 2) le_rfl
+
+theorem lipschitz_two_of_im_neg' {w : ℂ} (hw : w.im < 0) :
+    ∑' n : ℤ, 1 / (w + n) ^ 2 =
+      (2 * π * I) ^ 2 * ∑' m : ℕ, (m : ℂ) * cexp (2 * π * I * (-w)) ^ m := by
+  rw [lipschitz_two_of_im_neg hw]
+  simp [mul_neg]
+
+theorem cexp_two_pi_I_mul_add (a b : ℂ) :
+    cexp (2 * π * I * (a + b)) = cexp (2 * π * I * a) * cexp (2 * π * I * b) := by
+  rw [mul_add, Complex.exp_add]
+
+theorem cexp_two_pi_I_mul_nat_mul (c : ℕ) (τ : ℂ) :
+    cexp (2 * π * I * (c * τ)) = cexp (2 * π * I * τ) ^ c := by
+  rw [← Complex.exp_nat_mul]
+  ring_nf
+
+theorem cexp_two_pi_I_mul_neg (z : ℂ) :
+    cexp (2 * π * I * (-z)) = (cexp (2 * π * I * z))⁻¹ := by
+  rw [mul_neg, Complex.exp_neg]
+
+theorem lipschitz_row_pair {z τ : ℂ} (hτ : 0 < τ.im) (hz₁ : -τ.im < z.im) (hz₂ : z.im < τ.im)
+    {c : ℕ} (hc : 0 < c) :
+    ((∑' d : ℤ, 1 / ((z - c * τ) + d) ^ 2) - ∑' d : ℤ, 1 / (c * τ + d) ^ 2) +
+      ((∑' d : ℤ, 1 / ((z - (-(c : ℂ)) * τ) + d) ^ 2) - ∑' d : ℤ, 1 / ((-(c : ℂ)) * τ + d) ^ 2) =
+      (2 * π * I) ^ 2 * ∑' m : ℕ, (m : ℂ) *
+        (cexp (2 * π * I * z) ^ m + (cexp (2 * π * I * z))⁻¹ ^ m - 2) *
+          cexp (2 * π * I * τ) ^ (c * m) := by
+  have hc1 : (1 : ℝ) ≤ c := by exact_mod_cast hc
+  have hcτ : τ.im ≤ c * τ.im := by nlinarith
+  have hA : (z - c * τ).im < 0 := by
+    simp only [Complex.sub_im, Complex.mul_im, Complex.natCast_re, Complex.natCast_im, zero_mul,
+      add_zero]
+    linarith
+  have hB : 0 < ((c : ℂ) * τ).im := by
+    simp only [Complex.mul_im, Complex.natCast_re, Complex.natCast_im, zero_mul, add_zero]
+    linarith
+  have hC : 0 < (z - (-(c : ℂ)) * τ).im := by
+    simp only [Complex.sub_im, Complex.mul_im, Complex.neg_re, Complex.neg_im, Complex.natCast_re,
+      Complex.natCast_im, neg_zero, zero_mul, add_zero]
+    linarith
+  have hD : ((-(c : ℂ)) * τ).im < 0 := by
+    simp only [Complex.mul_im, Complex.neg_re, Complex.neg_im, Complex.natCast_re,
+      Complex.natCast_im, neg_zero, zero_mul, add_zero]
+    linarith
+  have sA := summable_nat_mul_cexp_pow (w := -(z - c * τ)) (by simpa using hA)
+  have sB := summable_nat_mul_cexp_pow hB
+  have sC := summable_nat_mul_cexp_pow hC
+  have sD := summable_nat_mul_cexp_pow (w := -((-(c : ℂ)) * τ)) (by simpa using hD)
+  rw [lipschitz_two_of_im_neg' hA, lipschitz_two_of_im_pos hB, lipschitz_two_of_im_pos hC,
+    lipschitz_two_of_im_neg' hD, ← mul_sub, ← mul_sub, ← mul_add, ← sA.tsum_sub sB,
+    ← sC.tsum_sub sD, ← (sA.sub sB).tsum_add (sC.sub sD)]
+  congr 1
+  refine tsum_congr fun m ↦ ?_
+  rw [show -(z - c * τ) = c * τ + -z by ring, show z - (-(c : ℂ)) * τ = c * τ + z by ring,
+    show -((-(c : ℂ)) * τ) = c * τ by ring, cexp_two_pi_I_mul_add, cexp_two_pi_I_mul_add,
+    cexp_two_pi_I_mul_neg, cexp_two_pi_I_mul_nat_mul]
+  ring
+
+theorem lipschitz_row_zero {z : ℂ} (hz : z ∈ Complex.integerComplement) :
+    (∑' d : ℤ, 1 / (z + d) ^ 2) - ∑' d : ℤ, 1 / ((d : ℂ)) ^ 2 =
+      (2 * π * I) ^ 2 * (cexp (2 * π * I * z) / (1 - cexp (2 * π * I * z)) ^ 2 + 1 / 12) := by
+  rw [lipschitz_two_closed hz, tsum_int_one_div_sq, sub_eq_add_neg, neg_pi_sq_div_three_div]
+  ring
+
+theorem lipschitz_rows_qExpansion {z τ : ℂ} (hτ : 0 < τ.im) (hz₁ : -τ.im < z.im)
+    (hz₂ : z.im < τ.im) (hz : z ∈ Complex.integerComplement)
+    (hS : Summable fun c : ℤ ↦
+      (∑' d : ℤ, 1 / ((z - c * τ) + d) ^ 2) - ∑' d : ℤ, 1 / (c * τ + d) ^ 2) :
+    ∑' c : ℤ, ((∑' d : ℤ, 1 / ((z - c * τ) + d) ^ 2) - ∑' d : ℤ, 1 / (c * τ + d) ^ 2) =
+      (2 * π * I) ^ 2 *
+        (cexp (2 * π * I * z) / (1 - cexp (2 * π * I * z)) ^ 2 + 1 / 12 +
+          ∑' c : ℕ+, ∑' m : ℕ, (m : ℂ) *
+            (cexp (2 * π * I * z) ^ m + (cexp (2 * π * I * z))⁻¹ ^ m - 2) *
+              cexp (2 * π * I * τ) ^ ((c : ℕ) * m)) := by
+  have h3 : Summable fun c : ℕ+ ↦
+      (∑' d : ℤ, 1 / ((z - ((c : ℤ) : ℂ) * τ) + d) ^ 2) -
+        ∑' d : ℤ, 1 / (((c : ℤ) : ℂ) * τ + d) ^ 2 :=
+    hS.comp_injective fun a b h ↦ by exact_mod_cast h
+  have h4 : Summable fun c : ℕ+ ↦
+      (∑' d : ℤ, 1 / ((z - ((-(c : ℤ) : ℤ) : ℂ) * τ) + d) ^ 2) -
+        ∑' d : ℤ, 1 / (((-(c : ℤ) : ℤ) : ℂ) * τ + d) ^ 2 :=
+    hS.comp_injective (f := fun c ↦ _) fun a b h ↦ by simpa using h
+  rw [tsum_int_eq_zero_add_tsum_pnat hS, add_assoc, ← h3.tsum_add h4]
+  simp only [Int.cast_zero, zero_mul, sub_zero, zero_add]
+  rw [lipschitz_row_zero hz, mul_add _ _ (∑' c : ℕ+, _), ← tsum_mul_left]
+  congr 1
+  refine tsum_congr fun c ↦ ?_
+  have := lipschitz_row_pair hτ hz₁ hz₂ c.pos
+  push_cast at this ⊢
+  exact this
+
+end B2_lipschitz
+
+section B2_rearrange
+
+open PeriodPair
+open scoped UpperHalfPlane
+
+def periodPairOfTau (τ : ℍ) : PeriodPair where
+  ω₁ := (τ : ℂ)
+  ω₂ := 1
+  indep := LinearIndependent.pair_iff.mpr fun s t hst ↦ by
+    have him : s * (τ : ℂ).im = 0 := by
+      have := congrArg Complex.im hst
+      simpa [Complex.add_im, Complex.smul_im, smul_eq_mul] using this
+    have hs : s = 0 :=
+      (mul_eq_zero.mp him).resolve_right (UpperHalfPlane.coe_im τ ▸ τ.im_ne_zero)
+    subst hs
+    simpa using hst
+
+@[scoped simp] lemma periodPairOfTau_ω₁ (τ : ℍ) : (periodPairOfTau τ).ω₁ = (τ : ℂ) := rfl
+@[scoped simp] lemma periodPairOfTau_ω₂ (τ : ℍ) : (periodPairOfTau τ).ω₂ = 1 := rfl
+
+abbrev wpSummand (L : PeriodPair) (z : ℂ) (p : ℤ × ℤ) : ℂ :=
+  1 / (z - (p.1 * L.ω₁ + p.2 * L.ω₂)) ^ 2 - 1 / (p.1 * L.ω₁ + p.2 * L.ω₂) ^ 2
+
+theorem hasSum_weierstrassP_prod (L : PeriodPair) (z : ℂ) :
+    HasSum (wpSummand L z) (weierstrassP L z) := by
+  have h := (L.latticeEquivProd.symm.toEquiv.hasSum_iff (f := fun l : L.lattice ↦
+      1 / (z - (l : ℂ)) ^ 2 - 1 / (l : ℂ) ^ 2)).mpr (L.hasSum_weierstrassP z)
+  refine h.congr_fun fun p ↦ ?_
+  simp only [Function.comp_apply, LinearEquiv.coe_toEquiv, wpSummand]
+  have hcoe : ((L.latticeEquivProd.symm p : L.lattice) : ℂ) = p.1 * L.ω₁ + p.2 * L.ω₂ :=
+    L.latticeEquiv_symm_apply p
+  rw [hcoe]
+
+theorem summable_weierstrassP_prod (L : PeriodPair) (z : ℂ) :
+    Summable (wpSummand L z) :=
+  (hasSum_weierstrassP_prod L z).summable
+
+theorem weierstrassP_eq_tsum_tsum (L : PeriodPair) (z : ℂ) :
+    weierstrassP L z =
+      ∑' c : ℤ, ∑' d : ℤ,
+        (1 / (z - (c * L.ω₁ + d * L.ω₂)) ^ 2 - 1 / (c * L.ω₁ + d * L.ω₂) ^ 2) := by
+  rw [← (hasSum_weierstrassP_prod L z).tsum_eq]
+  exact (summable_weierstrassP_prod L z).tsum_prod
+
+theorem summable_weierstrassP_row (L : PeriodPair) (z : ℂ) :
+    Summable fun c : ℤ ↦
+      ∑' d : ℤ, (1 / (z - (c * L.ω₁ + d * L.ω₂)) ^ 2 - 1 / (c * L.ω₁ + d * L.ω₂) ^ 2) :=
+  (summable_weierstrassP_prod L z).prod
+
+theorem wpRow_periodPairOfTau_split (τ : ℍ) (z : ℂ) (c : ℤ) :
+    ∑' d : ℤ, wpSummand (periodPairOfTau τ) z (c, d) =
+      (∑' d : ℤ, 1 / ((z - c * (τ : ℂ)) + d) ^ 2) - ∑' d : ℤ, 1 / (c * (τ : ℂ) + d) ^ 2 := by
+  have hA : Summable fun d : ℤ ↦ (1 : ℂ) / ((z - c * (τ : ℂ)) - d) ^ 2 := by
+    have := summable_one_div_add_int_sq (z - c * (τ : ℂ))
+    refine ((Equiv.neg ℤ).summable_iff.mpr this).congr fun d ↦ ?_
+    simp [sub_eq_add_neg]
+  have hB : Summable fun d : ℤ ↦ (1 : ℂ) / (c * (τ : ℂ) + d) ^ 2 :=
+    summable_one_div_add_int_sq (c * (τ : ℂ))
+  have step : (∑' d : ℤ, wpSummand (periodPairOfTau τ) z (c, d)) =
+      (∑' d : ℤ, 1 / ((z - c * (τ : ℂ)) - d) ^ 2) - ∑' d : ℤ, 1 / (c * (τ : ℂ) + d) ^ 2 := by
+    rw [← hA.tsum_sub hB]
+    refine tsum_congr fun d ↦ ?_
+    simp only [wpSummand, periodPairOfTau_ω₁, periodPairOfTau_ω₂, mul_one]
+    ring
+  rw [step, tsum_one_div_sub_int_sq]
+
+theorem weierstrassP_periodPairOfTau_eq_row_sum (τ : ℍ) (z : ℂ) :
+    weierstrassP (periodPairOfTau τ) z =
+      ∑' c : ℤ, ((∑' d : ℤ, 1 / ((z - c * (τ : ℂ)) + d) ^ 2)
+                  - ∑' d : ℤ, 1 / (c * (τ : ℂ) + d) ^ 2) := by
+  rw [weierstrassP_eq_tsum_tsum]
+  exact tsum_congr fun c ↦ by
+    simpa [wpSummand, periodPairOfTau_ω₁, periodPairOfTau_ω₂, mul_one]
+      using wpRow_periodPairOfTau_split τ z c
+
+end B2_rearrange
+
+section B2_assembly
+
+open scoped UpperHalfPlane in
+theorem weierstrassP_periodPairOfTau_qExpansion (τ : ℍ) {z : ℂ}
+    (hz₁ : -τ.im < z.im) (hz₂ : z.im < τ.im) (hz : z ∈ Complex.integerComplement) :
+    PeriodPair.weierstrassP (periodPairOfTau τ) z =
+      (2 * π * I) ^ 2 *
+        (cexp (2 * π * I * z) / (1 - cexp (2 * π * I * z)) ^ 2 + 1 / 12 +
+          ∑' c : ℕ+, ∑' m : ℕ, (m : ℂ) *
+            (cexp (2 * π * I * z) ^ m + (cexp (2 * π * I * z))⁻¹ ^ m - 2) *
+              cexp (2 * π * I * (τ : ℂ)) ^ ((c : ℕ) * m)) := by
+  rw [weierstrassP_periodPairOfTau_eq_row_sum]
+  refine lipschitz_rows_qExpansion τ.im_pos hz₁ hz₂ hz ?_
+  exact (summable_weierstrassP_row (periodPairOfTau τ) z).congr
+    fun c ↦ wpRow_periodPairOfTau_split τ z c
+
+end B2_assembly
+
+section B2_torsion
+
+def zetaN (N : ℕ) : ℂ := cexp (2 * π * I / N)
+
+def qN (N : ℕ) (τ : ℂ) : ℂ := cexp (2 * π * I * τ / N)
+
+lemma zetaN_ne_zero (N : ℕ) : zetaN N ≠ 0 := Complex.exp_ne_zero _
+lemma qN_ne_zero (N : ℕ) (τ : ℂ) : qN N τ ≠ 0 := Complex.exp_ne_zero _
+
+lemma qN_pow_self {N : ℕ} (hN : N ≠ 0) (τ : ℂ) : qN N τ ^ N = cexp (2 * π * I * τ) := by
+  have : (N : ℂ) ≠ 0 := by exact_mod_cast hN
+  rw [qN, ← Complex.exp_nat_mul]
+  congr 1
+  field_simp
+
+lemma cexp_two_pi_I_mul_torsionPt {N : ℕ} (hN : N ≠ 0) (a₁ a₂ : ℕ) (τ : ℂ) :
+    cexp (2 * π * I * ((a₁ * τ + a₂) / N)) = zetaN N ^ a₂ * qN N τ ^ a₁ := by
+  have : (N : ℂ) ≠ 0 := by exact_mod_cast hN
+  rw [zetaN, qN, ← Complex.exp_nat_mul, ← Complex.exp_nat_mul, ← Complex.exp_add]
+  congr 1
+  field_simp
+  ring
+
+lemma norm_qN (N : ℕ) (τ : ℂ) : ‖qN N τ‖ = Real.exp (-(2 * π * τ.im / N)) := by
+  rw [qN, Complex.norm_exp]
+  congr 1
+  rw [show 2 * (π : ℂ) * I * τ / N = (2 * π * I * τ) / (N : ℕ) from rfl, Complex.div_natCast_re]
+  simp [mul_comm]
+  ring
+
+private lemma torsion_term_aux (ζ q : ℂ) (hq : q ≠ 0) (a₁ a₂ k m : ℕ) :
+    ((ζ ^ a₂ * q ^ a₁) ^ m + (ζ ^ a₂ * q ^ a₁)⁻¹ ^ m - 2) * q ^ ((a₁ + k) * m) =
+      ζ ^ (a₂ * m) * q ^ ((a₁ + k + a₁) * m) + ζ⁻¹ ^ (a₂ * m) * q ^ (k * m) -
+        2 * q ^ ((a₁ + k) * m) := by
+  have h2 : (ζ ^ a₂ * q ^ a₁)⁻¹ ^ m * q ^ ((a₁ + k) * m) = ζ⁻¹ ^ (a₂ * m) * q ^ (k * m) := by
+    rw [mul_inv, mul_pow, ← inv_pow, ← inv_pow, ← pow_mul, ← pow_mul, add_mul, pow_add,
+      mul_assoc]
+    congr 1
+    rw [← mul_assoc, inv_pow, inv_mul_cancel₀ (pow_ne_zero _ hq), one_mul]
+  linear_combination h2
+
+open scoped UpperHalfPlane in
+lemma torsionPt_hyps (τ : ℍ) {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) :
+    -τ.im < (((a₁ : ℂ) * τ + a₂) / N).im ∧ (((a₁ : ℂ) * τ + a₂) / N).im < τ.im ∧
+      ((a₁ : ℂ) * τ + a₂) / N ∈ Complex.integerComplement := by
+  have hN : 0 < N := lt_of_le_of_lt (Nat.zero_le _) ha₁
+  have hNr : (0 : ℝ) < N := by exact_mod_cast hN
+  have hτ : 0 < τ.im := τ.im_pos
+  have him : (((a₁ : ℂ) * τ + a₂) / N).im = a₁ * τ.im / N := by
+    rw [Complex.div_natCast_im]
+    simp
+  refine ⟨?_, ?_, ?_⟩
+  · rw [him]
+    have : (0 : ℝ) ≤ a₁ * τ.im / N := by positivity
+    linarith
+  · rw [him, div_lt_iff₀ hNr]
+    have : (a₁ : ℝ) < N := by exact_mod_cast ha₁
+    nlinarith
+  · rintro ⟨n, hn⟩
+    have hre := congrArg Complex.re hn
+    have him' := congrArg Complex.im hn
+    rw [him] at him'
+    simp only [Complex.intCast_im] at him'
+    have ha₁0 : a₁ = 0 := by
+      rcases mul_eq_zero.mp ((div_eq_zero_iff.mp him'.symm).resolve_right hNr.ne') with h | h
+      · exact_mod_cast h
+      · exact absurd h hτ.ne'
+    have ha₂0 : a₂ ≠ 0 := h0.resolve_left (not_not.mpr ha₁0)
+    subst ha₁0
+    rw [Complex.div_natCast_re] at hre
+    simp only [Complex.intCast_re, Nat.cast_zero, zero_mul, zero_add, Complex.natCast_re] at hre
+    rw [eq_div_iff hNr.ne'] at hre
+    have h1 : (0 : ℝ) < n := by
+      have : (0 : ℝ) < a₂ := by exact_mod_cast Nat.pos_of_ne_zero ha₂0
+      nlinarith
+    have h2 : (n : ℝ) < 1 := by
+      have : (a₂ : ℝ) < N := by exact_mod_cast ha₂
+      nlinarith
+    have h1' : (0 : ℤ) < n := by exact_mod_cast h1
+    have h2' : n < (1 : ℤ) := by exact_mod_cast h2
+    omega
+
+open scoped UpperHalfPlane in
+theorem weierstrassP_torsionPt_qExpansion (τ : ℍ) {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) :
+    PeriodPair.weierstrassP (periodPairOfTau τ) (((a₁ : ℂ) * τ + a₂) / N) =
+      (2 * π * I) ^ 2 *
+        (zetaN N ^ a₂ * qN N τ ^ a₁ / (1 - zetaN N ^ a₂ * qN N τ ^ a₁) ^ 2 + 1 / 12 +
+          ∑' c : ℕ+, ∑' m : ℕ, (m : ℂ) *
+            (zetaN N ^ (a₂ * m) * qN N τ ^ (((c : ℕ) * N + a₁) * m) +
+              (zetaN N)⁻¹ ^ (a₂ * m) * qN N τ ^ (((c : ℕ) * N - a₁) * m) -
+                2 * qN N τ ^ ((c : ℕ) * N * m))) := by
+  have hN : N ≠ 0 := by omega
+  obtain ⟨hz₁, hz₂, hz⟩ := torsionPt_hyps τ ha₁ ha₂ h0
+  rw [weierstrassP_periodPairOfTau_qExpansion τ hz₁ hz₂ hz, cexp_two_pi_I_mul_torsionPt hN,
+    ← qN_pow_self hN]
+  congr 2
+  refine tsum_congr fun c ↦ tsum_congr fun m ↦ ?_
+  obtain ⟨k, hk⟩ : ∃ k : ℕ, (c : ℕ) * N = a₁ + k :=
+    ⟨(c : ℕ) * N - a₁, (Nat.add_sub_cancel' (le_trans ha₁.le (Nat.le_mul_of_pos_left N
+      c.pos))).symm⟩
+  rw [← pow_mul (qN N τ) N, show N * ((c : ℕ) * m) = ((c : ℕ) * N) * m by ring, hk,
+    Nat.add_sub_cancel_left, mul_assoc, torsion_term_aux _ _ (qN_ne_zero N τ)]
+
+end B2_torsion
+
+section B3_holo
+
+open scoped UpperHalfPlane Manifold
+
+lemma norm_zetaN (N : ℕ) : ‖zetaN N‖ = 1 := by
+  rw [zetaN, Complex.norm_exp, show 2 * (π : ℂ) * I / N = (2 * π * I) / (N : ℕ) from rfl,
+    Complex.div_natCast_re]
+  simp
+
+lemma norm_qN_le_one (N : ℕ) {τ : ℂ} (hτ : 0 ≤ τ.im) : ‖qN N τ‖ ≤ 1 := by
+  rw [norm_qN, Real.exp_le_one_iff, neg_nonpos]
+  positivity
+
+lemma norm_qN_lt_one {N : ℕ} (hN : 0 < N) {τ : ℂ} (hτ : 0 < τ.im) : ‖qN N τ‖ < 1 := by
+  rw [norm_qN, Real.exp_lt_one_iff, neg_lt_zero]
+  have : (0 : ℝ) < N := by exact_mod_cast hN
+  positivity
+
+lemma norm_qN_le_of_le_im (N : ℕ) {B : ℝ} {τ : ℂ} (hτ : B ≤ τ.im) :
+    ‖qN N τ‖ ≤ Real.exp (-(2 * π * B / N)) := by
+  rw [norm_qN, Real.exp_le_exp, neg_le_neg_iff]
+  rcases Nat.eq_zero_or_pos N with hN | hN
+  · simp [hN]
+  · have : (0 : ℝ) < N := by exact_mod_cast hN
+    gcongr
+
+def wpTail (N a₁ a₂ : ℕ) (p : ℕ+ × ℕ+) (τ : ℂ) : ℂ :=
+  ((p.2 : ℕ) : ℂ) *
+    (zetaN N ^ (a₂ * (p.2 : ℕ)) * qN N τ ^ (((p.1 : ℕ) * N + a₁) * (p.2 : ℕ)) +
+      (zetaN N)⁻¹ ^ (a₂ * (p.2 : ℕ)) * qN N τ ^ (((p.1 : ℕ) * N - a₁) * (p.2 : ℕ)) -
+        2 * qN N τ ^ ((p.1 : ℕ) * N * (p.2 : ℕ)))
+
+lemma norm_wpTail_le {N a₁ : ℕ} (ha₁ : a₁ < N) (a₂ : ℕ) (p : ℕ+ × ℕ+) {τ : ℂ} (hτ : 0 ≤ τ.im) :
+    ‖wpTail N a₁ a₂ p τ‖ ≤ 4 * ((p.2 : ℕ) * ‖qN N τ‖ ^ ((p.1 : ℕ) * (p.2 : ℕ))) := by
+  obtain ⟨c, m⟩ := p
+  have hq1 := norm_qN_le_one N hτ
+  have hcN : (c : ℕ) ≤ (c : ℕ) * N - a₁ := by
+    have h1 : (c : ℕ) * (a₁ + 1) ≤ (c : ℕ) * N := Nat.mul_le_mul_left _ ha₁
+    have h2 : a₁ ≤ (c : ℕ) * a₁ := Nat.le_mul_of_pos_left _ c.pos
+    rw [mul_add, mul_one] at h1
+    omega
+  have e1 : (c : ℕ) * (m : ℕ) ≤ ((c : ℕ) * N + a₁) * (m : ℕ) :=
+    Nat.mul_le_mul_right _ (by nlinarith)
+  have e2 : (c : ℕ) * (m : ℕ) ≤ ((c : ℕ) * N - a₁) * (m : ℕ) := Nat.mul_le_mul_right _ hcN
+  have e3 : (c : ℕ) * (m : ℕ) ≤ (c : ℕ) * N * (m : ℕ) := Nat.mul_le_mul_right _ (by nlinarith)
+  have b1 : ‖qN N τ‖ ^ (((c : ℕ) * N + a₁) * (m : ℕ)) ≤ ‖qN N τ‖ ^ ((c : ℕ) * (m : ℕ)) :=
+    pow_le_pow_of_le_one (norm_nonneg _) hq1 e1
+  have b2 : ‖qN N τ‖ ^ (((c : ℕ) * N - a₁) * (m : ℕ)) ≤ ‖qN N τ‖ ^ ((c : ℕ) * (m : ℕ)) :=
+    pow_le_pow_of_le_one (norm_nonneg _) hq1 e2
+  have b3 : ‖qN N τ‖ ^ ((c : ℕ) * N * (m : ℕ)) ≤ ‖qN N τ‖ ^ ((c : ℕ) * (m : ℕ)) :=
+    pow_le_pow_of_le_one (norm_nonneg _) hq1 e3
+  have hz : ‖zetaN N‖ = 1 := norm_zetaN N
+  set ρ : ℝ := ‖qN N τ‖ with hρ
+  set A : ℂ := zetaN N ^ (a₂ * (m : ℕ)) * qN N τ ^ (((c : ℕ) * N + a₁) * (m : ℕ)) with hAdef
+  set B : ℂ := (zetaN N)⁻¹ ^ (a₂ * (m : ℕ)) * qN N τ ^ (((c : ℕ) * N - a₁) * (m : ℕ)) with hBdef
+  set C : ℂ := qN N τ ^ ((c : ℕ) * N * (m : ℕ)) with hCdef
+  have hA : ‖A‖ ≤ ρ ^ ((c : ℕ) * (m : ℕ)) := by
+    rw [hAdef, norm_mul, norm_pow, hz, one_pow, one_mul, norm_pow]; exact b1
+  have hB : ‖B‖ ≤ ρ ^ ((c : ℕ) * (m : ℕ)) := by
+    rw [hBdef, norm_mul, norm_pow, norm_inv, hz, inv_one, one_pow, one_mul, norm_pow]; exact b2
+  have hC : ‖(2 : ℂ) * C‖ ≤ 2 * ρ ^ ((c : ℕ) * (m : ℕ)) := by
+    rw [norm_mul, Complex.norm_ofNat, hCdef, norm_pow]; linarith
+  have hst : ‖A + B - 2 * C‖ ≤ 4 * ρ ^ ((c : ℕ) * (m : ℕ)) := by
+    linarith [norm_sub_le (A + B) (2 * C), norm_add_le A B]
+  change ‖((m : ℕ) : ℂ) * (A + B - 2 * C)‖ ≤ 4 * ((m : ℕ) * ρ ^ ((c : ℕ) * (m : ℕ)))
+  rw [norm_mul, Complex.norm_natCast]
+  calc ((m : ℕ) : ℝ) * ‖A + B - 2 * C‖ ≤ (m : ℕ) * (4 * ρ ^ ((c : ℕ) * (m : ℕ))) := by gcongr
+    _ = 4 * ((m : ℕ) * ρ ^ ((c : ℕ) * (m : ℕ))) := by ring
+
+lemma summable_wpTail_majorant {r : ℝ} (hr0 : 0 ≤ r) (hr : r < 1) :
+    Summable fun p : ℕ+ × ℕ+ ↦ 4 * ((p.2 : ℕ) * r ^ ((p.1 : ℕ) * (p.2 : ℕ))) := by
+  have h := summable_prod_mul_pow 1 (r := r) (by rwa [Real.norm_eq_abs, abs_of_nonneg hr0])
+  refine (h.mul_left 4).congr fun p ↦ ?_
+  simp
+
+lemma summable_wpTail {N a₁ : ℕ} (ha₁ : a₁ < N) (a₂ : ℕ) {τ : ℂ} (hτ : 0 < τ.im) :
+    Summable fun p ↦ wpTail N a₁ a₂ p τ :=
+  Summable.of_norm_bounded
+    (summable_wpTail_majorant (norm_nonneg _) (norm_qN_lt_one (by omega) hτ))
+    fun p ↦ norm_wpTail_le ha₁ a₂ p hτ.le
+
+theorem weierstrassP_torsionPt_eq_tsum_prod (τ : ℍ) {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) :
+    PeriodPair.weierstrassP (periodPairOfTau τ) (((a₁ : ℂ) * τ + a₂) / N) =
+      (2 * π * I) ^ 2 *
+        (zetaN N ^ a₂ * qN N τ ^ a₁ / (1 - zetaN N ^ a₂ * qN N τ ^ a₁) ^ 2 + 1 / 12 +
+          ∑' p : ℕ+ × ℕ+, wpTail N a₁ a₂ p τ) := by
+  have hS := summable_wpTail ha₁ a₂ (τ := (τ : ℂ)) τ.im_pos
+  rw [weierstrassP_torsionPt_qExpansion τ ha₁ ha₂ h0, hS.tsum_prod]
+  congr 2
+  refine tsum_congr fun c ↦ ?_
+  set F : ℕ → ℂ := fun m ↦ (m : ℂ) *
+    (zetaN N ^ (a₂ * m) * qN N τ ^ (((c : ℕ) * N + a₁) * m) +
+      (zetaN N)⁻¹ ^ (a₂ * m) * qN N τ ^ (((c : ℕ) * N - a₁) * m) -
+        2 * qN N τ ^ ((c : ℕ) * N * m)) with hF
+  have hs : Summable F := summable_pnat_iff_summable_nat.mp (hS.prod_factor c)
+  change ∑' m : ℕ, F m = ∑' m : ℕ+, F m
+  rw [← tsum_zero_pnat_eq_tsum_nat hs]
+  simp [hF]
+
+def wpTorsion (N a₁ a₂ : ℕ) (τ : ℍ) : ℂ :=
+  PeriodPair.weierstrassP (periodPairOfTau τ) (((a₁ : ℂ) * τ + a₂) / N)
+
+def wpTorsionSeries (N a₁ a₂ : ℕ) (τ : ℂ) : ℂ :=
+  (2 * π * I) ^ 2 *
+    (zetaN N ^ a₂ * qN N τ ^ a₁ / (1 - zetaN N ^ a₂ * qN N τ ^ a₁) ^ 2 + 1 / 12 +
+      ∑' p : ℕ+ × ℕ+, wpTail N a₁ a₂ p τ)
+
+lemma wpTorsion_eq_wpTorsionSeries {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) (τ : ℍ) :
+    wpTorsion N a₁ a₂ τ = wpTorsionSeries N a₁ a₂ τ :=
+  weierstrassP_torsionPt_eq_tsum_prod τ ha₁ ha₂ h0
+
+lemma one_sub_zetaN_pow_mul_qN_pow_ne_zero {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) {τ : ℂ} (hτ : 0 < τ.im) :
+    1 - zetaN N ^ a₂ * qN N τ ^ a₁ ≠ 0 := by
+  obtain ⟨-, -, hz⟩ := torsionPt_hyps ⟨τ, hτ⟩ ha₁ ha₂ h0
+  rw [← cexp_two_pi_I_mul_torsionPt (by omega), sub_ne_zero]
+  exact (cexp_two_pi_I_mul_ne_one hz).symm
+
+lemma differentiable_qN (N : ℕ) : Differentiable ℂ (qN N) := by
+  unfold qN; fun_prop
+
+lemma differentiable_wpTail (N a₁ a₂ : ℕ) (p : ℕ+ × ℕ+) :
+    Differentiable ℂ (wpTail N a₁ a₂ p) := by
+  unfold wpTail
+  have := differentiable_qN N
+  fun_prop
+
+open Complex in
+theorem differentiableOn_wpTorsionSeries {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) :
+    DifferentiableOn ℂ (wpTorsionSeries N a₁ a₂) {τ : ℂ | 0 < τ.im} := by
+  intro τ₀ hτ₀
+  set B : ℝ := τ₀.im / 2 with hB
+  have hB0 : 0 < B := by simp only [Set.mem_ofPred_eq] at hτ₀; positivity
+  set U : Set ℂ := {τ : ℂ | B < τ.im} with hU
+  have hUopen : IsOpen U := isOpen_lt continuous_const Complex.continuous_im
+  have hτ₀U : τ₀ ∈ U := by
+    simp only [hU, Set.mem_ofPred_eq, hB]; simp only [Set.mem_ofPred_eq] at hτ₀; linarith
+  have hUsub : U ⊆ {τ : ℂ | 0 < τ.im} := fun τ hτ ↦ lt_trans hB0 hτ
+  set ρ : ℝ := Real.exp (-(2 * π * B / N)) with hρ
+  have hN : 0 < N := by omega
+  have hρ1 : ρ < 1 := by
+    rw [hρ, Real.exp_lt_one_iff, neg_lt_zero]
+    have : (0 : ℝ) < N := by exact_mod_cast hN
+    positivity
+  have htail : DifferentiableOn ℂ (fun τ ↦ ∑' p : ℕ+ × ℕ+, wpTail N a₁ a₂ p τ) U := by
+    refine differentiableOn_tsum_of_summable_norm
+      (summable_wpTail_majorant (Real.exp_pos _).le hρ1)
+      (fun p ↦ (differentiable_wpTail N a₁ a₂ p).differentiableOn) hUopen ?_
+    intro p τ hτ
+    refine (norm_wpTail_le ha₁ a₂ p (lt_trans hB0 hτ).le).trans ?_
+    gcongr
+    exact norm_qN_le_of_le_im N (le_of_lt hτ)
+  have hhead : DifferentiableOn ℂ
+      (fun τ ↦ zetaN N ^ a₂ * qN N τ ^ a₁ / (1 - zetaN N ^ a₂ * qN N τ ^ a₁) ^ 2) U := by
+    have := differentiable_qN N
+    refine DifferentiableOn.div (by fun_prop) (by fun_prop) fun τ hτ ↦ pow_ne_zero _ ?_
+    exact one_sub_zetaN_pow_mul_qN_pow_ne_zero ha₁ ha₂ h0 (hUsub hτ)
+  have hall : DifferentiableOn ℂ (wpTorsionSeries N a₁ a₂) U := by
+    unfold wpTorsionSeries
+    exact DifferentiableOn.mul (differentiableOn_const _)
+      ((hhead.add (differentiableOn_const _)).add htail)
+  exact ((hall τ₀ hτ₀U).differentiableAt (hUopen.mem_nhds hτ₀U)).differentiableWithinAt
+
+theorem mdifferentiable_wpTorsion {N a₁ a₂ : ℕ} (ha₁ : a₁ < N) (ha₂ : a₂ < N)
+    (h0 : a₁ ≠ 0 ∨ a₂ ≠ 0) :
+    MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (wpTorsion N a₁ a₂) := by
+  rw [UpperHalfPlane.mdifferentiable_iff]
+  refine (differentiableOn_wpTorsionSeries ha₁ ha₂ h0).congr fun τ hτ ↦ ?_
+  simp only [Function.comp_apply, UpperHalfPlane.ofComplex_apply_of_im_pos hτ]
+  exact wpTorsion_eq_wpTorsionSeries ha₁ ha₂ h0 ⟨τ, hτ⟩
+
+end B3_holo
+
+section R1Bridge
+
+open scoped UpperHalfPlane Manifold
+
+lemma PeriodPair.ext_omega {L L' : PeriodPair} (h1 : L.ω₁ = L'.ω₁) (h2 : L.ω₂ = L'.ω₂) :
+    L = L' := by
+  cases L; cases L'; simp_all
+
+end R1Bridge
+
+end WLight
+end
+
+open Complex Real in
+open scoped UpperHalfPlane Manifold in
+open WLight in
+theorem solution :
+    (∀ w : ℂ, 0 < w.im →
+      ∑' n : ℤ, 1 / (w + n) ^ 2 =
+        (2 * π * I) ^ 2 * ∑' m : ℕ, (m : ℂ) * cexp (2 * π * I * w) ^ m) ∧
+    (∀ w : ℂ, w.im < 0 →
+      ∑' n : ℤ, 1 / (w + n) ^ 2 =
+        (2 * π * I) ^ 2 * ∑' m : ℕ, (m : ℂ) * cexp (-(2 * π * I * w)) ^ m) ∧
+    (∀ z τ : ℂ, -τ.im < z.im → z.im < τ.im → z ∈ Complex.integerComplement →
+      ∑' c : ℤ, ((∑' d : ℤ, 1 / ((z - c * τ) + d) ^ 2) - ∑' d : ℤ, 1 / (c * τ + d) ^ 2) =
+        (2 * π * I) ^ 2 *
+          (cexp (2 * π * I * z) / (1 - cexp (2 * π * I * z)) ^ 2 + 1 / 12 +
+            ∑' c : ℕ+, ∑' m : ℕ, (m : ℂ) *
+              (cexp (2 * π * I * z) ^ m + (cexp (2 * π * I * z))⁻¹ ^ m - 2) *
+                cexp (2 * π * I * τ) ^ ((c : ℕ) * m))) ∧
+    (∀ L : ℍ → PeriodPair, (∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1) →
+      ∀ N a₁ a₂ : ℕ, a₁ < N → a₂ < N → (a₁ ≠ 0 ∨ a₂ ≠ 0) →
+        (∀ τ : ℍ, PeriodPair.weierstrassP (L τ) (((a₁ : ℂ) * τ + a₂) / N) =
+          (2 * π * I) ^ 2 *
+            (cexp (2 * π * I / N) ^ a₂ * cexp (2 * π * I * (τ : ℂ) / N) ^ a₁ /
+                (1 - cexp (2 * π * I / N) ^ a₂ * cexp (2 * π * I * (τ : ℂ) / N) ^ a₁) ^ 2 +
+              1 / 12 +
+              ∑' p : ℕ+ × ℕ+, ((p.2 : ℕ) : ℂ) *
+                (cexp (2 * π * I / N) ^ (a₂ * (p.2 : ℕ)) *
+                    cexp (2 * π * I * (τ : ℂ) / N) ^ (((p.1 : ℕ) * N + a₁) * (p.2 : ℕ)) +
+                  (cexp (2 * π * I / N))⁻¹ ^ (a₂ * (p.2 : ℕ)) *
+                    cexp (2 * π * I * (τ : ℂ) / N) ^ (((p.1 : ℕ) * N - a₁) * (p.2 : ℕ)) -
+                  2 * cexp (2 * π * I * (τ : ℂ) / N) ^ ((p.1 : ℕ) * N * (p.2 : ℕ))))) ∧
+        MDifferentiable 𝓘(ℂ) 𝓘(ℂ)
+          (fun τ : ℍ => PeriodPair.weierstrassP (L τ) (((a₁ : ℂ) * τ + a₂) / N))) ∧
+    (∀ L L' : PeriodPair, ∀ c : ℂ, L'.ω₁ = c * L.ω₁ → L'.ω₂ = c * L.ω₂ →
+      ∀ z : ℂ, PeriodPair.weierstrassP L' (c * z) =
+        c⁻¹ ^ 2 * PeriodPair.weierstrassP L z) := by
+  refine ⟨fun w hw => lipschitz_two_of_im_pos hw, fun w hw => lipschitz_two_of_im_neg hw,
+    fun z τ hz₁ hz₂ hz => ?_, ?_, ?_⟩
+  · have hτpos : 0 < τ.im := by linarith
+    have hS : Summable fun c : ℤ ↦
+        (∑' d : ℤ, 1 / ((z - c * τ) + d) ^ 2) - ∑' d : ℤ, 1 / (c * τ + d) ^ 2 :=
+      (summable_weierstrassP_row (periodPairOfTau ⟨τ, hτpos⟩) z).congr
+        fun c ↦ wpRow_periodPairOfTau_split ⟨τ, hτpos⟩ z c
+    exact lipschitz_rows_qExpansion hτpos hz₁ hz₂ hz hS
+  · intro L hL N a₁ a₂ ha₁ ha₂ h0
+    have hLeq : ∀ τ : ℍ, L τ = periodPairOfTau τ := fun τ =>
+      PeriodPair.ext_omega (hL τ).1 (hL τ).2
+    constructor
+    · intro τ
+      rw [hLeq τ]
+      simpa only [zetaN, qN, wpTail] using weierstrassP_torsionPt_eq_tsum_prod τ ha₁ ha₂ h0
+    · have hfun : (fun τ : ℍ => PeriodPair.weierstrassP (L τ) (((a₁ : ℂ) * τ + a₂) / N)) =
+          wpTorsion N a₁ a₂ := funext fun τ => by rw [wpTorsion, hLeq τ]
+      rw [hfun]
+      exact mdifferentiable_wpTorsion ha₁ ha₂ h0
+  · intro L L' c hω₁ hω₂ z
+    have hc : c ≠ 0 := by
+      rintro rfl
+      have h0 : L'.ω₁ = 0 := by rw [hω₁, zero_mul]
+      have h1 := L'.indep.ne_zero 0
+      simp only [Matrix.cons_val_zero] at h1
+      exact h1 h0
+    have hL' : L' = smulPeriodPair c hc L := by
+      refine PeriodPair.ext_omega ?_ ?_ <;> simp [smulPeriodPair, hω₁, hω₂]
+    rw [hL']
+    exact weierstrassP_smulPeriodPair c hc L z
+
+end S_WLight_weierstrassP_qExpansion_package
+end P2MW
+export P2MW.S_WLight_weierstrassP_qExpansion_package (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Complex Real
+open scoped UpperHalfPlane Manifold
+theorem WLight.weierstrassP_qExpansion_package :
+    (∀ w : ℂ, 0 < w.im →
+      ∑' n : ℤ, 1 / (w + n) ^ 2 =
+        (2 * π * I) ^ 2 * ∑' m : ℕ, (m : ℂ) * cexp (2 * π * I * w) ^ m) ∧
+    (∀ w : ℂ, w.im < 0 →
+      ∑' n : ℤ, 1 / (w + n) ^ 2 =
+        (2 * π * I) ^ 2 * ∑' m : ℕ, (m : ℂ) * cexp (-(2 * π * I * w)) ^ m) ∧
+    (∀ z τ : ℂ, -τ.im < z.im → z.im < τ.im → z ∈ Complex.integerComplement →
+      ∑' c : ℤ, ((∑' d : ℤ, 1 / ((z - c * τ) + d) ^ 2) - ∑' d : ℤ, 1 / (c * τ + d) ^ 2) =
+        (2 * π * I) ^ 2 *
+          (cexp (2 * π * I * z) / (1 - cexp (2 * π * I * z)) ^ 2 + 1 / 12 +
+            ∑' c : ℕ+, ∑' m : ℕ, (m : ℂ) *
+              (cexp (2 * π * I * z) ^ m + (cexp (2 * π * I * z))⁻¹ ^ m - 2) *
+                cexp (2 * π * I * τ) ^ ((c : ℕ) * m))) ∧
+    (∀ L : ℍ → PeriodPair, (∀ τ : ℍ, (L τ).ω₁ = (τ : ℂ) ∧ (L τ).ω₂ = 1) →
+      ∀ N a₁ a₂ : ℕ, a₁ < N → a₂ < N → (a₁ ≠ 0 ∨ a₂ ≠ 0) →
+        (∀ τ : ℍ, PeriodPair.weierstrassP (L τ) (((a₁ : ℂ) * τ + a₂) / N) =
+          (2 * π * I) ^ 2 *
+            (cexp (2 * π * I / N) ^ a₂ * cexp (2 * π * I * (τ : ℂ) / N) ^ a₁ /
+                (1 - cexp (2 * π * I / N) ^ a₂ * cexp (2 * π * I * (τ : ℂ) / N) ^ a₁) ^ 2 +
+              1 / 12 +
+              ∑' p : ℕ+ × ℕ+, ((p.2 : ℕ) : ℂ) *
+                (cexp (2 * π * I / N) ^ (a₂ * (p.2 : ℕ)) *
+                    cexp (2 * π * I * (τ : ℂ) / N) ^ (((p.1 : ℕ) * N + a₁) * (p.2 : ℕ)) +
+                  (cexp (2 * π * I / N))⁻¹ ^ (a₂ * (p.2 : ℕ)) *
+                    cexp (2 * π * I * (τ : ℂ) / N) ^ (((p.1 : ℕ) * N - a₁) * (p.2 : ℕ)) -
+                  2 * cexp (2 * π * I * (τ : ℂ) / N) ^ ((p.1 : ℕ) * N * (p.2 : ℕ))))) ∧
+        MDifferentiable 𝓘(ℂ) 𝓘(ℂ)
+          (fun τ : ℍ => PeriodPair.weierstrassP (L τ) (((a₁ : ℂ) * τ + a₂) / N))) ∧
+    (∀ L L' : PeriodPair, ∀ c : ℂ, L'.ω₁ = c * L.ω₁ → L'.ω₂ = c * L.ω₂ →
+      ∀ z : ℂ, PeriodPair.weierstrassP L' (c * z) =
+        c⁻¹ ^ 2 * PeriodPair.weierstrassP L z) :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_eq_XYIdeal_iff.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_eq_XYIdeal_iff.lean
new file mode 100644
index 0000000000..ff9a0d428e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_eq_XYIdeal_iff.lean
@@ -0,0 +1,132 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.CoordinateRing.XYIdeal_eq_XYIdeal_iff
+(0b9a22c4-27e0-5527-8114-51326c8a5ad7) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 167f3628-0cf7-58a1-9a98-1ac1c13d4c8a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Point ideals of a Weierstrass curve determine the point
+
+Theorem statement: `WeierstrassCurve.Affine.CoordinateRing.XYIdeal_eq_XYIdeal_iff`
+(`0b9a22c4-27e0-5527-8114-51326c8a5ad7`), by Claude, 2026-09-05.
+
+Proof: submission `167f3628-0cf7-58a1-9a98-1ac1c13d4c8a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field and let $W$ be a Weierstrass curve over $F$ in affine coordinates, with
+associated bivariate polynomial $W.\mathrm{polynomial} \in F[X][Y]$ and coordinate ring $F[W] =
+F[X][Y]/(W.\mathrm{polynomial})$, the quotient map being `mk W`. For $x \in F$ and $y \in F[X]$,
+`XYIdeal W x y` denotes the ideal of $F[W]$ generated by the classes of $C(X - C\,x)$ and of $Y -
+C\,y$. Assume $x_1, y_1 \in F$ satisfy the Weierstrass equation of $W$, i.e. `W.Equation x₁ y₁`, and
+let $x_2, y_2 \in F$ be arbitrary elements, with no assumption that $(x_2,y_2)$ lies on $W$. The
+assertion is the equivalence: the ideals $\big(X - x_1,\, Y - y_1\big)$ and $\big(X - x_2,\, Y -
+y_2\big)$ of $F[W]$ coincide if and only if $x_1 = x_2$ and $y_1 = y_2$. Note that the second
+coordinates are taken to be the constant polynomials $C\,y_1$ and $C\,y_2$, so both ideals are the
+ideals attached to $F$-rational points.
+
+This is the injectivity half of the classical correspondence between $F$-rational affine points of a
+plane curve and the maximal ideals of its coordinate ring that they cut out. It is used in the
+construction of a centred place datum for a genus-one Weierstrass curve in
+[`WeierstrassCurve.Affine.exists_genusOnePlaceGate_isCentred_abelTheorem`]
+(thm.html#WeierstrassCurve.Affine.exists_genusOnePlaceGate_isCentred_abelTheorem).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_eq_XYIdeal_iff.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_eq_XYIdeal_iff
+
+p2m_open "Polynomial WeierstrassCurve \
+  P2MW.S_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_eq_XYIdeal_iff.WeierstrassCurve \
+  WeierstrassCurve.Affine \
+  P2MW.S_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_eq_XYIdeal_iff.WeierstrassCurve.Affine \
+  WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_eq_XYIdeal_iff.WeierstrassCurve.Affine.Coor\
+  dinateRing"
+open scoped Polynomial.Bivariate
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map Affine.CoordinateRing mk Affine.Point"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation CoordinateRing map Point polynomial"
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "XYIdeal YClass mk map XClass"
+namespace DetInfra
+p2m_open "WeierstrassCurve.Affine.CoordinateRing WeierstrassCurve.Affine WeierstrassCurve"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+lemma XYIdeal_eq_map (x : F) (y : F[X]) :
+    XYIdeal W x y = Ideal.map (mk W) (Ideal.span {C (X - C x), Y - C y}) := by
+  simp only [XYIdeal, XClass, YClass, ← Set.image_pair, ← Ideal.map_span]
+
+lemma mk_mem_XYIdeal_of_evalEval_eq_zero (x y : F) {p : F[X][Y]} (hp : p.evalEval x y = 0) :
+    mk W p ∈ XYIdeal W x (C y) := by
+  rw [XYIdeal_eq_map]
+  exact Ideal.mem_map_of_mem _ (mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero.mpr hp)
+
+lemma mk_mem_XYIdeal_iff' {x y : F} (h : W.Equation x y) (p : F[X][Y]) :
+    mk W p ∈ XYIdeal W x (C y) ↔ p.evalEval x y = 0 := by
+  refine ⟨fun hp => ?_, mk_mem_XYIdeal_of_evalEval_eq_zero x y⟩
+  rw [XYIdeal_eq_map, Ideal.mem_map_iff_of_surjective _ AdjoinRoot.mk_surjective] at hp
+  obtain ⟨q, hq, hqp⟩ := hp
+  obtain ⟨r, hr⟩ := AdjoinRoot.mk_eq_mk.mp hqp
+  have hW : W.polynomial ∈ Ideal.span {C (X - C x), Y - C (C y)} :=
+    mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero.mpr h
+  have : p = q - W.polynomial * r := by rw [← hr]; ring
+  rw [this]
+  exact mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero.mp
+    (Ideal.sub_mem _ hq (Ideal.mul_mem_right _ _ hW))
+
+end WeierstrassCurve.Affine.CoordinateRing.DetInfra
+
+open WeierstrassCurve.Affine.CoordinateRing.DetInfra
+
+theorem solution {F : Type*} [Field F] {W : Affine F} {x₁ y₁ : F} (h : W.Equation x₁ y₁) (x₂ y₂ : F)
+    :
+    XYIdeal W x₁ (C y₁) = XYIdeal W x₂ (C y₂) ↔ x₁ = x₂ ∧ y₁ = y₂ := by
+  refine ⟨fun he => ?_, by rintro ⟨rfl, rfl⟩; rfl⟩
+  have hx : XClass W x₂ ∈ XYIdeal W x₁ (C y₁) := he ▸ Ideal.subset_span (by simp)
+  have hy : YClass W (C y₂) ∈ XYIdeal W x₁ (C y₁) := he ▸ Ideal.subset_span (by simp)
+  rw [XClass, mk_mem_XYIdeal_iff' h] at hx
+  rw [YClass, mk_mem_XYIdeal_iff' h] at hy
+  simp only [evalEval_C, eval_sub, eval_X, eval_C] at hx
+  simp only [evalEval_sub, evalEval_X, evalEval_CC] at hy
+  exact ⟨sub_eq_zero.mp hx, sub_eq_zero.mp hy⟩
+
+end S_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_eq_XYIdeal_iff
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_eq_XYIdeal_iff (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Polynomial WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.CoordinateRing
+open scoped Polynomial.Bivariate
+theorem WeierstrassCurve.Affine.CoordinateRing.XYIdeal_eq_XYIdeal_iff {F : Type*} [Field F]
+    {W : Affine F} {x₁ y₁ : F} (h : W.Equation x₁ y₁) (x₂ y₂ : F) :
+    XYIdeal W x₁ (C y₁) = XYIdeal W x₂ (C y₂) ↔ x₁ = x₂ ∧ y₁ = y₂ :=
+  solution h x₂ y₂
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot.lean
new file mode 100644
index 0000000000..793a4cbfe4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot.lean
@@ -0,0 +1,81 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.CoordinateRing.XYIdeal_ne_bot
+(43222cf5-702e-5313-9f7d-1a3bedce0936) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 004f37df-618f-5a67-aaad-9288f3791c2b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Nonvanishing of the ideals (X-x, Y-y) in R[W]
+
+Theorem statement: `WeierstrassCurve.Affine.CoordinateRing.XYIdeal_ne_bot`
+(`43222cf5-702e-5313-9f7d-1a3bedce0936`), by Claude, 2026-09-05.
+
+Proof: submission `004f37df-618f-5a67-aaad-9288f3791c2b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a nontrivial commutative ring and let $W$ be a Weierstrass curve over $R$ in affine form,
+with affine coordinate ring $R[W] = R[X][Y]/(Y^2 + a_1XY + a_3Y - (X^3 + a_2X^2 + a_4X + a_6))$. For
+any element $x \in R$ and any univariate polynomial $y \in R[X]$, the ideal `XYIdeal W x y` of
+$R[W]$ — the ideal generated by the class of $X - x$ and the class of $Y - y(X)$, i.e. by `XClass W
+x` and `YClass W y` — is not the zero ideal. No hypothesis is imposed relating $x$ and $y$ to the
+curve: the pair need not be a point of $W$, and indeed $y$ is allowed to be an arbitrary polynomial
+rather than a constant, so the conclusion is the purely algebraic assertion that these two
+generators do not both vanish in $R[W]$.
+
+For an affine point $P = (x, y)$ of $W$ this is the statement that the point ideal $\mathfrak m_P
+\subset R[W]$ is nonzero; combined with its maximality it is what places $\mathfrak m_P$ in the
+height-one spectrum of the coordinate ring, that is, exhibits $P$ as a finite place of the function
+field of the curve. It is used throughout the development of places and divisors on genus-one curves
+in this formalisation.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot
+
+open Polynomial WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.CoordinateRing
+open scoped Polynomial.Bivariate
+
+theorem solution {R : Type*} [CommRing R] [Nontrivial R] {W : Affine R} (x : R) (y : R[X]) :
+    XYIdeal W x y ≠ ⊥ := fun h0 =>
+  XClass_ne_zero (W' := W) x <| by
+    have : XClass W x ∈ XYIdeal W x y := Ideal.subset_span (by simp)
+    rwa [h0, Ideal.mem_bot] at this
+
+end S_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Polynomial WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.CoordinateRing
+open scoped Polynomial.Bivariate
+theorem WeierstrassCurve.Affine.CoordinateRing.XYIdeal_ne_bot {R : Type*} [CommRing R]
+    [Nontrivial R] {W : Affine R} (x : R) (y : R[X]) :
+    XYIdeal W x y ≠ ⊥ :=
+  solution x y
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain.lean
new file mode 100644
index 0000000000..3c3043e06e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain.lean
@@ -0,0 +1,255 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.CoordinateRing.isDedekindDomain
+(68c20482-e092-5448-9a28-d0e09fba3eb8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 64a9d5c5-cba3-540c-9046-bf7ed3b09d5e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+
+import Mathlib.RingTheory.DedekindDomain.Dvr
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Coordinate ring of an elliptic curve is Dedekind
+
+Theorem statement: `WeierstrassCurve.Affine.CoordinateRing.isDedekindDomain`
+(`68c20482-e092-5448-9a28-d0e09fba3eb8`), by Claude, 2026-09-05.
+
+Proof: submission `64a9d5c5-cba3-540c-9046-bf7ed3b09d5e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field and let $W$ be a Weierstrass curve over $K$, that is, a
+tuple of coefficients $(a_1,a_2,a_3,a_4,a_6)$ defining the equation $Y^2 + a_1XY + a_3Y = X^3 +
+a_2X^2 + a_4X + a_6$, subject to the hypothesis `W.IsElliptic`, i.e. the discriminant $\Delta$ of
+$W$ is a unit of $K$, hence nonzero. The assertion is that the affine coordinate ring of $W$, namely
+the quotient of the bivariate polynomial ring $K[X][Y]$ by the principal ideal generated by the
+Weierstrass polynomial $Y^2 + a_1XY + a_3Y - (X^3 + a_2X^2 + a_4X + a_6)$, is a Dedekind domain: it
+is an integral domain which is Noetherian, of Krull dimension at most one, and integrally closed in
+its fraction field. No further hypotheses are imposed; in particular the characteristic of $K$ is
+arbitrary.
+
+This is the ring-theoretic form of the statement that a nonsingular affine plane curve has Dedekind
+coordinate ring, specialised to Weierstrass cubics with nonvanishing discriminant over an
+algebraically closed field. It makes the height-one spectrum and the associated valuations available
+on the coordinate ring, which is the basis for orders of vanishing and divisors of rational
+functions on the curve, and it is used throughout the treatment of torsion, the Weil pairing and the
+geometry of modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+
+p2m_open "Polynomial WeierstrassCurve \
+  P2MW.S_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain.WeierstrassCurve \
+  WeierstrassCurve.Affine \
+  P2MW.S_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain.WeierstrassCurve.Affine \
+  WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain.WeierstrassCurve.Affine.Coordinate\
+  Ring"
+open scoped Polynomial.Bivariate
+
+local macro "C_simp" : tactic =>
+  `(tactic| simp only [map_ofNat, C_0, C_1, C_neg, C_add, C_sub, C_mul, C_pow])
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine a₃ a₁ map Affine.CoordinateRing mk a₄ a₂ toAffine \
+  Affine.Point Δ"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing map evalEval_polynomialX \
+  Nonsingular Point evalEval_polynomialY equation_iff_nonsingular CoordinateRing.basis \
+  equation_iff polynomial"
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "XYIdeal quotientXYIdealEquiv XClass_ne_zero \
+  YClass mk map XClass"
+namespace DetInfra
+p2m_open "WeierstrassCurve.Affine.CoordinateRing WeierstrassCurve.Affine WeierstrassCurve"
+
+open IsLocalRing
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+lemma XYIdeal_eq_map (x : F) (y : F[X]) :
+    XYIdeal W x y = Ideal.map (mk W) (Ideal.span {C (X - C x), Y - C y}) := by
+  simp only [XYIdeal, XClass, YClass, ← Set.image_pair, ← Ideal.map_span]
+
+lemma mk_mem_XYIdeal_of_evalEval_eq_zero (x y : F) {p : F[X][Y]} (hp : p.evalEval x y = 0) :
+    mk W p ∈ XYIdeal W x (C y) := by
+  rw [XYIdeal_eq_map]
+  exact Ideal.mem_map_of_mem _ (mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero.mpr hp)
+
+lemma mk_mem_XYIdeal_iff' {x y : F} (h : W.Equation x y) (p : F[X][Y]) :
+    mk W p ∈ XYIdeal W x (C y) ↔ p.evalEval x y = 0 := by
+  refine ⟨fun hp => ?_, mk_mem_XYIdeal_of_evalEval_eq_zero x y⟩
+  rw [XYIdeal_eq_map, Ideal.mem_map_iff_of_surjective _ AdjoinRoot.mk_surjective] at hp
+  obtain ⟨q, hq, hqp⟩ := hp
+  obtain ⟨r, hr⟩ := AdjoinRoot.mk_eq_mk.mp hqp
+  have hW : W.polynomial ∈ Ideal.span {C (X - C x), Y - C (C y)} :=
+    mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero.mpr h
+  have : p = q - W.polynomial * r := by grind
+  rw [this]
+  exact mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero.mp
+    (Ideal.sub_mem _ hq (Ideal.mul_mem_right _ _ hW))
+
+lemma isMaximal_XYIdeal' {x y : F} (h : W.Equation x y) : (XYIdeal W x (C y)).IsMaximal :=
+  Ideal.Quotient.maximal_of_isField _ <|
+    MulEquiv.isField (Field.toIsField F) (quotientXYIdealEquiv (W' := W) h).toMulEquiv
+
+lemma XYIdeal_ne_bot (x : F) (y : F[X]) : XYIdeal W x y ≠ ⊥ := fun h0 =>
+  XClass_ne_zero (W' := W) x <| by
+    have : XClass W x ∈ XYIdeal W x y := Ideal.subset_span (by simp)
+    rwa [h0, Ideal.mem_bot] at this
+
+theorem isMaximal_iff_exists_eq_XYIdeal' [IsAlgClosed F] (I : Ideal W.CoordinateRing) :
+    I.IsMaximal ↔ ∃ x y : F, W.Equation x y ∧ I = XYIdeal W x (C y) := by
+  constructor
+  · intro hI
+    let := Ideal.Quotient.field I
+    have : Module.Finite F (W.CoordinateRing ⧸ I) :=
+      finite_of_finite_type_of_isJacobsonRing F _
+    have hbij := IsAlgClosed.algebraMap_bijective_of_isIntegral (k := F)
+      (K := W.CoordinateRing ⧸ I)
+    obtain ⟨x, hx⟩ := hbij.2 (Ideal.Quotient.mk I (mk W (C X)))
+    obtain ⟨y, hy⟩ := hbij.2 (Ideal.Quotient.mk I (mk W Y))
+    have hxI : XClass W x ∈ I := by
+      rw [← Ideal.Quotient.eq_zero_iff_mem]
+      simp only [XClass, map_sub, ← hx, sub_eq_zero]
+      rfl
+    have hyI : YClass W (C y) ∈ I := by
+      rw [← Ideal.Quotient.eq_zero_iff_mem]
+      simp only [YClass, map_sub, ← hy, sub_eq_zero]
+      rfl
+    have hle : XYIdeal W x (C y) ≤ I :=
+      Ideal.span_le.mpr (Set.insert_subset_iff.mpr ⟨hxI, Set.singleton_subset_iff.mpr hyI⟩)
+    have heq : W.Equation x y := by
+      by_contra hne
+      refine hI.ne_top (I.eq_top_of_isUnit_mem (hle <| mk_mem_XYIdeal_of_evalEval_eq_zero x y
+        (p := W.polynomial - C (C (W.polynomial.evalEval x y))) ?_) ?_)
+      · simp only [evalEval_sub, evalEval_CC, sub_self]
+      · rw [map_sub, AdjoinRoot.mk_self, zero_sub, IsUnit.neg_iff]
+        exact (Ne.isUnit hne).map (algebraMap F W.CoordinateRing)
+    exact ⟨x, y, heq, ((isMaximal_XYIdeal' heq).eq_of_le hI.ne_top hle).symm⟩
+  · rintro ⟨x, y, h, rfl⟩
+    exact isMaximal_XYIdeal' h
+
+lemma span_pair_eq_span_singleton_of_mul_eq {R : Type*} [CommRing R] {a b c u : R}
+    (hu : IsUnit u) (h : b * u = a * c) : Ideal.span {a, b} = Ideal.span {a} := by
+  refine le_antisymm (Ideal.span_le.mpr <| Set.insert_subset_iff.mpr
+    ⟨Ideal.mem_span_singleton_self a, Set.singleton_subset_iff.mpr ?_⟩)
+    (Ideal.span_mono <| Set.singleton_subset_iff.mpr <| Set.mem_insert _ _)
+  obtain ⟨u, rfl⟩ := hu
+  exact Ideal.mem_span_singleton'.mpr ⟨c * ↑u⁻¹, by
+    rw [show c * ↑u⁻¹ * a = a * c * ↑u⁻¹ by ring, ← h, Units.mul_inv_cancel_right]⟩
+
+lemma map_XYIdeal {S : Type*} [CommRing S] (f : W.CoordinateRing →+* S) (x : F) (y : F[X]) :
+    (XYIdeal W x y).map f = Ideal.span {f (XClass W x), f (YClass W y)} := by
+  rw [XYIdeal, Ideal.map_span, Set.image_pair]
+
+theorem isPrincipal_maximalIdeal_localization {x y : F} (h : W.Nonsingular x y)
+    [(XYIdeal W x (C y)).IsPrime] :
+    (maximalIdeal (Localization.AtPrime (XYIdeal W x (C y)))).IsPrincipal := by
+  set L := Localization.AtPrime (XYIdeal W x (C y))
+  have hI : maximalIdeal L =
+      Ideal.span {algebraMap _ L (XClass W x), algebraMap _ L (YClass W (C y))} := by
+    rw [← Localization.AtPrime.map_eq_maximalIdeal, map_XYIdeal]
+  set g : F[X][Y] := C (X ^ 2 + C (x + W.a₂) * X + C (x ^ 2 + W.a₂ * x + W.a₄)) - C (C W.a₁) * Y
+    with hg
+  have key : YClass W (C y) * YClass W (C (W.negY x y)) = XClass W x * mk W g := by
+    simp only [YClass, XClass, ← map_mul]
+    exact AdjoinRoot.mk_eq_mk.mpr ⟨1, by
+      linear_combination (norm := (rw [hg, negY, polynomial]; C_simp; ring1))
+        congr_arg C (congr_arg C ((equation_iff ..).mp h.left).symm)⟩
+  have key' : algebraMap _ L (YClass W (C y)) * algebraMap _ L (YClass W (C (W.negY x y))) =
+      algebraMap _ L (XClass W x) * algebraMap _ L (mk W g) := by
+    rw [← map_mul, ← map_mul, key]
+  have hmem : ∀ p : F[X][Y], mk W p ∈ XYIdeal W x (C y) ↔ p.evalEval x y = 0 :=
+    mk_mem_XYIdeal_iff' h.left
+  rcases h.right with hx | hy
+  · have hgu : IsUnit (algebraMap _ L (mk W g)) := by
+      rw [IsLocalization.AtPrime.isUnit_to_map_iff L (XYIdeal W x (C y))]
+      intro (hgI : mk W g ∈ XYIdeal W x (C y))
+      apply hx
+      have h0 := (hmem g).mp hgI
+      rw [evalEval_polynomialX]
+      simp only [hg, evalEval_sub, evalEval_mul, evalEval_C, evalEval_X, eval_add, eval_mul,
+        eval_pow, eval_C, eval_X] at h0
+      linear_combination -h0
+    refine ⟨⟨algebraMap _ L (YClass W (C y)), ?_⟩⟩
+    rw [hI, Ideal.span_insert, sup_comm, ← Ideal.span_insert]
+    exact span_pair_eq_span_singleton_of_mul_eq hgu key'.symm
+  · have hyu : IsUnit (algebraMap _ L (YClass W (C (W.negY x y)))) := by
+      rw [IsLocalization.AtPrime.isUnit_to_map_iff L (XYIdeal W x (C y))]
+      intro (hyI : mk W (Y - C (C (W.negY x y))) ∈ XYIdeal W x (C y))
+      apply hy
+      have h0 := (hmem _).mp hyI
+      grind [evalEval_polynomialY, evalEval_sub, evalEval_CC, evalEval_X, negY]
+    refine ⟨⟨algebraMap _ L (XClass W x), ?_⟩⟩
+    rw [hI]
+    exact span_pair_eq_span_singleton_of_mul_eq hyu key'
+
+theorem isDiscreteValuationRing_localization_XYIdeal' {x y : F} (h : W.Nonsingular x y)
+    [(XYIdeal W x (C y)).IsPrime] :
+    IsDiscreteValuationRing (Localization.AtPrime (XYIdeal W x (C y))) := by
+  have hnf := IsLocalization.AtPrime.not_isField W.CoordinateRing (XYIdeal_ne_bot x (C y))
+    (Localization.AtPrime (XYIdeal W x (C y)))
+  have : IsNoetherianRing (Localization.AtPrime (XYIdeal W x (C y))) :=
+    IsLocalization.isNoetherianRing (XYIdeal W x (C y)).primeCompl _ inferInstance
+  exact ((IsDiscreteValuationRing.TFAE _ hnf).out 1 5).mpr
+    (isPrincipal_maximalIdeal_localization h)
+
+scoped instance : Module.Finite F[X] W.CoordinateRing := Module.Finite.of_basis
+  (CoordinateRing.basis W)
+
+lemma isMaximal_of_isPrime_of_ne_bot (P : Ideal W.CoordinateRing) [P.IsPrime] (hP : P ≠ ⊥) :
+    P.IsMaximal :=
+  Ideal.isMaximal_of_isIntegral_of_isMaximal_under (R := F[X]) P <|
+    IsPrime.to_maximal_ideal (Ideal.under_ne_bot F[X] hP)
+
+theorem isDedekindDomain_of_isAlgClosed' [IsAlgClosed F] [W.IsElliptic] :
+    IsDedekindDomain W.CoordinateRing := by
+  rw [isDedekindDomain_iff_isDiscreteValuationRing_atPrime]
+  refine ⟨inferInstance, fun P hP hPp => ?_⟩
+  have hmax : P.IsMaximal := isMaximal_of_isPrime_of_ne_bot P hP
+  obtain ⟨x, y, hxy, rfl⟩ := (isMaximal_iff_exists_eq_XYIdeal' P).mp hmax
+  exact isDiscreteValuationRing_localization_XYIdeal' (equation_iff_nonsingular.mp hxy)
+
+end WeierstrassCurve.Affine.CoordinateRing.DetInfra
+
+open WeierstrassCurve.Affine.CoordinateRing.DetInfra
+
+theorem solution {K : Type*} [Field K] [IsAlgClosed K] (W : WeierstrassCurve K) [W.IsElliptic] :
+    IsDedekindDomain W.toAffine.CoordinateRing :=
+  isDedekindDomain_of_isAlgClosed' (W := W.toAffine)
+
+end S_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Polynomial WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.CoordinateRing
+open scoped Polynomial.Bivariate
+theorem WeierstrassCurve.Affine.CoordinateRing.isDedekindDomain {K : Type*} [Field K]
+    [IsAlgClosed K] (W : WeierstrassCurve K) [W.IsElliptic] :
+    IsDedekindDomain W.toAffine.CoordinateRing :=
+  solution W
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_CoordinateRing_isPrincipal_prod_XYIdeal_zpow_iff.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_CoordinateRing_isPrincipal_prod_XYIdeal_zpow_iff.lean
new file mode 100644
index 0000000000..e6214bb685
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_CoordinateRing_isPrincipal_prod_XYIdeal_zpow_iff.lean
@@ -0,0 +1,99 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.CoordinateRing.isPrincipal_prod_XYIdeal_zpow_iff
+(4786f617-f117-588c-bf77-9a1284619e9e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3ad29414-b8b3-5ea6-b1c8-eee65a2dade7
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Principality of prod 𝔪_{P_i}^{mᵢ} versus sum mᵢ Pᵢ = O
+
+Theorem statement: `WeierstrassCurve.Affine.CoordinateRing.isPrincipal_prod_XYIdeal_zpow_iff`
+(`4786f617-f117-588c-bf77-9a1284619e9e`), by Claude, 2026-09-05.
+
+Proof: submission `3ad29414-b8b3-5ea6-b1c8-eee65a2dade7`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field, $W$ a Weierstrass curve over $F$, and let $\iota$ be a type with a finite subset
+$s \subseteq \iota$. Given families $x, y : \iota \to F$ and a hypothesis $h$ asserting that for
+every $i$ the pair $(x_i, y_i)$ is a nonsingular point of the affine curve attached to $W$, together
+with a family of integers $m : \iota \to \mathbb{Z}$, form the element $\prod_{i \in s}
+\mathtt{XYIdeal'}(h_i)^{m_i}$ of the unit group of the fractional ideals of the coordinate ring
+$F[W]$ inside the function field $F(W)$, where $\mathtt{XYIdeal'}(h_i)$ is the invertible fractional
+ideal attached to the point $(x_i, y_i)$, namely the ideal generated by $X - x_i$ and $Y - y_i$; the
+powers are integer powers taken in that unit group. The assertion is that the underlying
+$F[W]$-submodule of $F(W)$ of this product is principal if and only if $\sum_{i \in s} m_i \cdot
+\mathtt{Point.some}\,(x_i)\,(y_i)\,(h_i) = 0$, the sum being taken in the group of points of $W$
+with its group law, with $\mathbb{Z}$-scalar multiplication. No injectivity is required of $i
+\mapsto (x_i, y_i)$, and the $m_i$ are arbitrary integers.
+
+This is the elliptic-curve case of the Abel–Jacobi criterion for principal divisors: a divisor
+supported on affine points is the affine part of a principal divisor exactly when the corresponding
+sum of points vanishes in the group law. It is used in the construction of the functions whose
+divisors are supported on torsion points, and is cited here in the computation of the valuation of
+the Weil numerator,
+[`WeierstrassCurve.Affine.valuation_weilNum`](thm.html#WeierstrassCurve.Affine.valuation_weilNum).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_CoordinateRing_isPrincipal_prod_XYIdeal_zpow_iff.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_CoordinateRing_isPrincipal_prod_XYIdeal_zpow_iff
+
+open WeierstrassCurve WeierstrassCurve.Affine
+open scoped nonZeroDivisors
+
+theorem solution {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F} {ι : Type*}
+    (s : Finset ι) (x y : ι → F) (h : ∀ i, W.toAffine.Nonsingular (x i) (y i)) (m : ι → ℤ) :
+    ((∏ i ∈ s, CoordinateRing.XYIdeal' (h i) ^ m i : (FractionalIdeal W.toAffine.CoordinateRing⁰
+      W.toAffine.FunctionField)ˣ) : Submodule W.toAffine.CoordinateRing
+      W.toAffine.FunctionField).IsPrincipal ↔ ∑ i ∈ s, m i • Point.some (x i) (y i) (h i) = 0 := by
+  rw [← ClassGroup.mk_eq_one_iff, ← Point.toClass_eq_zero, map_sum]
+  have key : Additive.toMul (∑ i ∈ s, Point.toClass (m i • Point.some (x i) (y i) (h i))) =
+      ClassGroup.mk W.toAffine.FunctionField (∏ i ∈ s, CoordinateRing.XYIdeal' (h i) ^ m i) := by
+    rw [map_prod, toMul_sum]
+    refine Finset.prod_congr rfl fun i _ => ?_
+    rw [map_zsmul, toMul_zsmul, map_zpow, Point.toClass_some]
+    rfl
+  rw [← key]
+  exact Additive.toMul.eq_symm_apply.symm
+
+end S_WeierstrassCurve_Affine_CoordinateRing_isPrincipal_prod_XYIdeal_zpow_iff
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_CoordinateRing_isPrincipal_prod_XYIdeal_zpow_iff (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine
+open scoped nonZeroDivisors
+
+theorem WeierstrassCurve.Affine.CoordinateRing.isPrincipal_prod_XYIdeal_zpow_iff {F : Type*}
+    [Field F] [DecidableEq F] {W : WeierstrassCurve F} {ι : Type*} (s : Finset ι) (x y : ι → F)
+    (h : ∀ i, W.toAffine.Nonsingular (x i) (y i)) (m : ι → ℤ) :
+    ((∏ i ∈ s, CoordinateRing.XYIdeal' (h i) ^ m i : (FractionalIdeal W.toAffine.CoordinateRing⁰
+      W.toAffine.FunctionField)ˣ) : Submodule W.toAffine.CoordinateRing
+      W.toAffine.FunctionField).IsPrincipal ↔ ∑ i ∈ s, m i • Point.some (x i) (y i) (h i) = 0 :=
+  solution s x y h m
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_CoordinateRing_natDegree_norm_eq_finsum_count.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_CoordinateRing_natDegree_norm_eq_finsum_count.lean
new file mode 100644
index 0000000000..10172ada7c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_CoordinateRing_natDegree_norm_eq_finsum_count.lean
@@ -0,0 +1,266 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.CoordinateRing.natDegree_norm_eq_finsum_count
+(68d22913-543d-5543-87af-56accd991d03) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8e86cef3-7601-59a5-8e6a-6f0e0d7fd352
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.RingTheory.DedekindDomain.Factorization
+public import Mathlib.RingTheory.SimpleRing.Principal
+
+import Mathlib.RingTheory.Ideal.Norm.AbsNorm
+import Mathlib.LinearAlgebra.FiniteDimensional.Lemmas
+import Mathlib.LinearAlgebra.FreeModule.Norm
+import Mathlib.FieldTheory.IsAlgClosed.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree of the norm equals the sum of local multiplicities
+
+Theorem statement: `WeierstrassCurve.Affine.CoordinateRing.natDegree_norm_eq_finsum_count`
+(`68d22913-543d-5543-87af-56accd991d03`), by Claude, 2026-09-05.
+
+Proof: submission `8e86cef3-7601-59a5-8e6a-6f0e0d7fd352`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field and let $W$ be a Weierstrass curve over $K$, and assume
+that its affine coordinate ring $K[W]$ — the quotient of $K[X][Y]$ by the Weierstrass polynomial, a
+free $K[X]$-algebra of rank $2$ — is a Dedekind domain. Let $a \in K[W]$ be nonzero. Then the degree
+(`natDegree`) of the norm $N_{K[W]/K[X]}(a) \in K[X]$, regarded as an integer, equals the sum over
+all height-one primes $v$ of $K[W]$ of the $v$-adic multiplicity $\mathrm{count}_v$ of the principal
+fractional ideal generated by the image of $a$ in the function field $K(W)$, i.e. of the $v$-adic
+valuation of $a$; the sum is taken as a finite sum over the (possibly infinite) index type of the
+height-one spectrum, which is legitimate because only finitely many terms are nonzero. Thus the
+degree of the norm of $a$ counts, with multiplicity and with no residue-degree factors since $K$ is
+algebraically closed, the zeros of $a$ on the affine curve.
+
+This is the affine half of the statement that a nonzero polynomial function on a nonsingular
+Weierstrass curve has as many zeros as poles, the pole order at the point at infinity being read off
+from the degree of the norm over $K[X]$. It underlies the construction of principal divisors and the
+computation of valuations of Weil functions on the curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_CoordinateRing_natDegree_norm_eq_finsum_count.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_CoordinateRing_natDegree_norm_eq_finsum_count
+
+p2m_open "IsDedekindDomain \
+  P2MW.S_WeierstrassCurve_Affine_CoordinateRing_natDegree_norm_eq_finsum_count.IsDedekindDomain \
+  Module"
+
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "HeightOneSpectrum.quotientEquivPiOfProdEq quotientEquivPiOfProdEq \
+  mk HeightOneSpectrum"
+p2m_open "IsDedekindDomain"
+
+variable (K : Type*) {R : Type*} [Field K] [CommRing R] [IsDedekindDomain R] [Algebra K R]
+
+section Filtration
+
+variable {P : Ideal R} [P.IsPrime]
+
+theorem finrank_quotient_pow_succ (hP : P ≠ ⊥) (c : ℕ) [Module.Finite K (R ⧸ P ^ (c + 1))] :
+    finrank K (R ⧸ P ^ (c + 1)) = finrank K (R ⧸ P ^ c) + finrank K (R ⧸ P) := by
+  obtain ⟨a, ha, ha'⟩ := IsConcreteLE.exists_of_lt (Ideal.pow_succ_lt_pow hP c)
+  let π : (R ⧸ P ^ (c + 1)) →ₐ[K] R ⧸ P ^ c :=
+    Ideal.Quotient.factorₐ K (Ideal.pow_le_pow_right c.le_succ)
+  have hπ : Function.Surjective π := fun x => by
+    obtain ⟨y, rfl⟩ := Ideal.Quotient.mk_surjective x
+    exact ⟨Ideal.Quotient.mk _ y, rfl⟩
+  let m : (R ⧸ P) →ₗ[R] R ⧸ P ^ (c + 1) :=
+    Submodule.liftQ P ((Submodule.mkQ (P ^ (c + 1))) ∘ₗ LinearMap.mulLeft R a) (by
+      intro x hx
+      rw [LinearMap.mem_ker, LinearMap.comp_apply, LinearMap.mulLeft_apply, Submodule.mkQ_apply,
+        Submodule.Quotient.mk_eq_zero, pow_succ]
+      exact Ideal.mul_mem_mul ha hx)
+  have hm_mk : ∀ x : R, m (Ideal.Quotient.mk P x) = Ideal.Quotient.mk (P ^ (c + 1)) (a * x) :=
+    fun _ => rfl
+  have hm : Function.Injective (m.restrictScalars K) := by
+    rw [← LinearMap.ker_eq_bot, Submodule.eq_bot_iff]
+    intro x hx
+    obtain ⟨x, rfl⟩ := Ideal.Quotient.mk_surjective x
+    rw [LinearMap.mem_ker, LinearMap.restrictScalars_apply, hm_mk,
+      Ideal.Quotient.eq_zero_iff_mem] at hx
+    exact Ideal.Quotient.eq_zero_iff_mem.mpr (Ideal.mem_prime_of_mul_mem_pow hP ha' hx)
+  have hrange : LinearMap.range (m.restrictScalars K) = LinearMap.ker π.toLinearMap := by
+    ext x
+    obtain ⟨x, rfl⟩ := Ideal.Quotient.mk_surjective x
+    rw [LinearMap.mem_ker, AlgHom.toLinearMap_apply, Ideal.Quotient.factorₐ_apply_mk,
+      Ideal.Quotient.eq_zero_iff_mem, LinearMap.mem_range]
+    constructor
+    · rintro ⟨y, hy⟩
+      obtain ⟨y, rfl⟩ := Ideal.Quotient.mk_surjective y
+      rw [LinearMap.restrictScalars_apply, hm_mk, Ideal.Quotient.eq] at hy
+      have := sub_mem (Ideal.mul_mem_right y _ ha) (Ideal.pow_le_pow_right c.le_succ hy)
+      rwa [sub_sub_cancel] at this
+    · intro hx
+      obtain ⟨d, e, he, hde⟩ := Ideal.exists_mul_add_mem_pow_succ hP a x ha ha' hx
+      refine ⟨Ideal.Quotient.mk P d, ?_⟩
+      rw [LinearMap.restrictScalars_apply, hm_mk, Ideal.Quotient.eq, ← hde]
+      simpa using he
+  rw [← (LinearMap.finrank_range_add_finrank_ker π.toLinearMap), LinearMap.range_eq_top.mpr hπ,
+    finrank_top, ← hrange, LinearMap.finrank_range_of_inj hm]
+
+theorem finrank_quotient_pow (hP : P ≠ ⊥) :
+    ∀ (c : ℕ) [Module.Finite K (R ⧸ P ^ c)], finrank K (R ⧸ P ^ c) = c * finrank K (R ⧸ P)
+  | 0, _ => by
+    have : Subsingleton (R ⧸ P ^ 0) :=
+      Ideal.Quotient.subsingleton_iff.mpr ((pow_zero P).trans Ideal.one_eq_top)
+    rw [zero_mul, finrank_zero_of_subsingleton]
+  | c + 1, _ => by
+    have : Module.Finite K (R ⧸ P ^ c) := Module.Finite.of_surjective
+      (Ideal.Quotient.factorₐ K (Ideal.pow_le_pow_right c.le_succ) :
+        (R ⧸ P ^ (c + 1)) →ₐ[K] R ⧸ P ^ c).toLinearMap
+      (fun x => by
+        obtain ⟨y, rfl⟩ := Ideal.Quotient.mk_surjective x
+        exact ⟨Ideal.Quotient.mk _ y, rfl⟩)
+    rw [finrank_quotient_pow_succ K hP c, finrank_quotient_pow hP c, add_mul, one_mul]
+
+end Filtration
+
+open scoped Classical in
+theorem finrank_quotient_eq_finsum {I : Ideal R} (hI : I ≠ ⊥) [Module.Finite K (R ⧸ I)] :
+    finrank K (R ⧸ I) = ∑ᶠ v : HeightOneSpectrum R,
+      (Associates.mk v.asIdeal).count (Associates.mk I).factors * finrank K (R ⧸ v.asIdeal) := by
+  set c : HeightOneSpectrum R → ℕ := fun v => (Associates.mk v.asIdeal).count (Associates.mk
+    I).factors
+    with hc
+  set T := (Ideal.finite_factors hI).toFinset with hT
+  have hcT : ∀ v, c v ≠ 0 → v ∈ T := fun v hv =>
+    (Ideal.finite_factors hI).mem_toFinset.mpr ((Associates.count_ne_zero_iff_dvd hI
+      v.irreducible).mp hv)
+  have hprod : ∏ v : T, (v : HeightOneSpectrum R).asIdeal ^ c v = I := by
+    rw [Finset.prod_coe_sort T fun v => v.asIdeal ^ c v, ←
+      Ideal.finprod_heightOneSpectrum_factorization hI]
+    refine (finprod_eq_prod_of_mulSupport_subset _ fun v hv => ?_).symm
+    refine hcT v fun h0 => hv ?_
+    simp only [h0, pow_zero]
+  let e : (R ⧸ I) ≃ₐ[K] ∀ v : T, R ⧸ (v : HeightOneSpectrum R).asIdeal ^ c v :=
+    AlgEquiv.ofRingEquiv (f := HeightOneSpectrum.quotientEquivPiOfProdEq I (fun v : T => v.1) (fun v
+      => c v)
+      (fun _ _ h => Subtype.coe_injective.ne h) hprod) (fun _ => rfl)
+  have : Module.Finite K (∀ v : T, R ⧸ (v : HeightOneSpectrum R).asIdeal ^ c v) :=
+    Module.Finite.equiv e.toLinearEquiv
+  have hφ : ∀ v : T, Function.Surjective
+      (LinearMap.proj (R := K) (φ := fun w : T => R ⧸ (w : HeightOneSpectrum R).asIdeal ^ c w) v) :=
+    fun v => LinearMap.proj_surjective v
+  have : ∀ v : T, Module.Finite K (R ⧸ (v : HeightOneSpectrum R).asIdeal ^ c v) := fun v =>
+    Module.Finite.of_surjective _ (hφ v)
+  rw [e.toLinearEquiv.finrank_eq,
+    finsum_eq_sum_of_support_subset _ (s := T) fun v hv =>
+      hcT v (left_ne_zero_of_mul (Function.mem_support.mp hv))]
+  calc finrank K (∀ v : T, R ⧸ (v : HeightOneSpectrum R).asIdeal ^ c v)
+      = ∑ v : T, finrank K (R ⧸ (v : HeightOneSpectrum R).asIdeal ^ c v) :=
+        Module.finrank_pi_fintype K
+    _ = ∑ v : T, c v * finrank K (R ⧸ (v : HeightOneSpectrum R).asIdeal) :=
+        Finset.sum_congr rfl fun v _ => finrank_quotient_pow K v.1.ne_bot (c v)
+    _ = ∑ v ∈ T, c v * finrank K (R ⧸ v.asIdeal) :=
+        Finset.sum_coe_sort T fun v => c v * finrank K (R ⧸ v.asIdeal)
+
+open scoped Classical in
+theorem finrank_quotient_eq_finsum_of_isAlgClosed [IsAlgClosed K] {I : Ideal R} (hI : I ≠ ⊥)
+    [Module.Finite K (R ⧸ I)] :
+    finrank K (R ⧸ I) =
+      ∑ᶠ v : HeightOneSpectrum R, (Associates.mk v.asIdeal).count (Associates.mk I).factors := by
+  rw [finrank_quotient_eq_finsum K hI]
+  refine finsum_congr fun v => ?_
+  by_cases hv : (Associates.mk v.asIdeal).count (Associates.mk I).factors = 0
+  · rw [hv, zero_mul]
+  · have hle : I ≤ v.asIdeal :=
+      Ideal.le_of_dvd ((Associates.count_ne_zero_iff_dvd hI v.irreducible).mp hv)
+    have : Module.Finite K (R ⧸ v.asIdeal) := Module.Finite.of_surjective
+      (Ideal.Quotient.factorₐ K hle : (R ⧸ I) →ₐ[K] R ⧸ v.asIdeal).toLinearMap
+      (fun x => by
+        obtain ⟨y, rfl⟩ := Ideal.Quotient.mk_surjective x
+        exact ⟨Ideal.Quotient.mk _ y, rfl⟩)
+    have : Algebra.IsIntegral K (R ⧸ v.asIdeal) := Algebra.IsIntegral.of_finite K _
+    rw [← (LinearEquiv.ofBijective (Algebra.linearMap K (R ⧸ v.asIdeal))
+      (IsAlgClosed.algebraMap_bijective_of_isIntegral (k := K))).finrank_eq, Module.finrank_self,
+      mul_one]
+
+end IsDedekindDomain
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.CoordinateRing mk IsIntegral toAffine Affine.Point"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "CoordinateRing FunctionField Point CoordinateRing.basis"
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "mk"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing WeierstrassCurve.Affine WeierstrassCurve"
+
+open scoped nonZeroDivisors Polynomial
+p2m_open "IsDedekindDomain \
+  P2MW.S_WeierstrassCurve_Affine_CoordinateRing_natDegree_norm_eq_finsum_count.IsDedekindDomain"
+
+variable {K : Type*} [Field K] [IsAlgClosed K] (W : Affine K) [IsDedekindDomain W.CoordinateRing]
+
+open scoped Classical in
+theorem natDegree_norm_eq_finsum_count_aux {a : W.CoordinateRing} (ha : a ≠ 0) :
+    ((Algebra.norm K[X] a).natDegree : ℤ) =
+      ∑ᶠ v : HeightOneSpectrum W.CoordinateRing, FractionalIdeal.count W.FunctionField v
+        (FractionalIdeal.spanSingleton W.CoordinateRing⁰
+          (algebraMap W.CoordinateRing W.FunctionField a)) := by
+  have hI : Ideal.span {a} ≠ ⊥ := by rwa [Ne, Ideal.span_singleton_eq_bot]
+  have : Module.Finite K (W.CoordinateRing ⧸ Ideal.span {a}) :=
+    Module.Finite.equiv
+      ((Ideal.quotientEquivPiSpan (Ideal.span {a}) (CoordinateRing.basis W) hI).restrictScalars
+        K).symm
+  have hfin : Function.HasFiniteSupport fun v : HeightOneSpectrum W.CoordinateRing =>
+      (Associates.mk v.asIdeal).count (Associates.mk (Ideal.span {a})).factors :=
+    (Ideal.finite_factors hI).subset fun v hv =>
+      (Associates.count_ne_zero_iff_dvd hI v.irreducible).mp (Function.mem_support.mp hv)
+  have hcast := map_finsum (Nat.castAddMonoidHom ℤ) hfin
+  rw [Nat.coe_castAddMonoidHom] at hcast
+  rw [← finrank_quotient_span_eq_natDegree_norm (CoordinateRing.basis W) ha,
+    finrank_quotient_eq_finsum_of_isAlgClosed K hI, hcast]
+  refine finsum_congr fun v => ?_
+  rw [← FractionalIdeal.coeIdeal_span_singleton, FractionalIdeal.count_coe _ _ hI]
+
+end WeierstrassCurve.Affine.CoordinateRing
+
+open scoped nonZeroDivisors
+
+theorem solution {K : Type*} [Field K] [IsAlgClosed K] (W : WeierstrassCurve K)
+    [IsDedekindDomain W.toAffine.CoordinateRing] {a : W.toAffine.CoordinateRing} (ha : a ≠ 0) :
+    ((Algebra.norm (Polynomial K) a).natDegree : ℤ) = ∑ᶠ v : IsDedekindDomain.HeightOneSpectrum
+      W.toAffine.CoordinateRing, FractionalIdeal.count W.toAffine.FunctionField v
+      (FractionalIdeal.spanSingleton W.toAffine.CoordinateRing⁰ (algebraMap
+      W.toAffine.CoordinateRing W.toAffine.FunctionField a)) :=
+  WeierstrassCurve.Affine.CoordinateRing.natDegree_norm_eq_finsum_count_aux W.toAffine ha
+
+end S_WeierstrassCurve_Affine_CoordinateRing_natDegree_norm_eq_finsum_count
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_CoordinateRing_natDegree_norm_eq_finsum_count (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped nonZeroDivisors
+theorem WeierstrassCurve.Affine.CoordinateRing.natDegree_norm_eq_finsum_count {K : Type*} [Field K]
+    [IsAlgClosed K] (W : WeierstrassCurve K) [IsDedekindDomain W.toAffine.CoordinateRing]
+    {a : W.toAffine.CoordinateRing} (ha : a ≠ 0) :
+    ((Algebra.norm (Polynomial K) a).natDegree : ℤ) = ∑ᶠ v : IsDedekindDomain.HeightOneSpectrum
+      W.toAffine.CoordinateRing, FractionalIdeal.count W.toAffine.FunctionField v
+      (FractionalIdeal.spanSingleton W.toAffine.CoordinateRing⁰ (algebraMap
+      W.toAffine.CoordinateRing W.toAffine.FunctionField a)) :=
+  solution W ha
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_FunctionField_addX_addY_specialize_at_place.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_FunctionField_addX_addY_specialize_at_place.lean
new file mode 100644
index 0000000000..09bcd47fbd
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_FunctionField_addX_addY_specialize_at_place.lean
@@ -0,0 +1,2700 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.FunctionField.addX_addY_specialize_at_place
+(f58c5978-d547-516d-a9e3-289d999f1464) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e3d8f47b-533a-536c-9f5e-46190529b051
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FunctionFieldQuadratic
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorPushPull
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_min_ord_le_ord_add_v2
+
+/-!
+# Chord formulas on generic points specialise to the group law
+
+Theorem statement: `WeierstrassCurve.Affine.FunctionField.addX_addY_specialize_at_place`
+(`f58c5978-d547-516d-a9e3-289d999f1464`), by Claude, 2026-09-05.
+
+Proof: submission `e3d8f47b-533a-536c-9f5e-46190529b051`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field of characteristic zero with decidable equality, let $W$ be
+an affine Weierstrass curve over $F$ which is elliptic, and fix decidable equality on its function
+field $K = W.\mathrm{FunctionField}$. Write $x$ for the image of $X$ under $F[X] \to
+W.\mathrm{CoordinateRing} \to K$ and $y$ for the image of $Y \in W.\mathrm{CoordinateRing}$ in $K$,
+and let $W_K$ denote the base change of $W$ along $F \to K$. Let $\varphi_1, \varphi_2$ be
+$F$-algebra endomorphisms of $K$, and set $x_i = \varphi_i(x)$, $y_i = \varphi_i(y)$, $\lambda =
+\mathrm{slope}_{W_K}(x_1,x_2,y_1,y_2)$, $x_3 = \mathrm{addX}_{W_K}(x_1,x_2,\lambda)$, $y_3 =
+\mathrm{addY}_{W_K}(x_1,x_2,y_1,\lambda)$. Assume it is not the case that both $x_1 = x_2$ and $y_1
+= \mathrm{negY}_{W_K}(x_2,y_2)$, and that $x_3$ is not the image of any $c \in F$. Let $v$ be a
+place of $K$ over $F$, that is, a valuation subring $\mathcal{O}_v \subsetneq K$ containing the
+image of $F$ and whose ring is a principal ideal ring, with $\mathrm{ord}_v$ the negative logarithm
+of the associated adic valuation. Let $Q_1, Q_2$ be $F$-points of $W$ such that for $i = 1,2$: if
+$Q_i = 0$ then $x_i \notin \mathcal{O}_v$, and if $Q_i = (a,b)$ with $(a,b)$ nonsingular then
+$\mathrm{ord}_v(x_i - a) > 0$ and $\mathrm{ord}_v(y_i - b) > 0$. Then the same holds for the sum: if
+$Q_1 + Q_2 = 0$ then $x_3 \notin \mathcal{O}_v$, and if $Q_1 + Q_2 = (a,b)$ with $(a,b)$ nonsingular
+then $\mathrm{ord}_v(x_3 - a) > 0$ and $\mathrm{ord}_v(y_3 - b) > 0$.
+
+This is the statement that the rational chord-and-tangent addition formulas, applied to the two
+$K$-points of $W$ obtained from a pair of $F$-algebra endomorphisms of the function field, are
+compatible with reduction at an arbitrary place of $K/F$, including the places where the formulas
+degenerate (an input at a pole, a vertical chord, or the tangent case). It is used in the
+construction of dual endomorphism data for isogenies, in
+[`WeierstrassCurve.Affine.IsogenyEndDatum.exists_dualEndData_dual_mem_and_norm_eq_finrankAlong`]
+(thm.html#WeierstrassCurve.Affine.IsogenyEndDatum.
+exists_dualEndData_dual_mem_and_norm_eq_finrankAlong).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_FunctionField_addX_addY_specialize_at_place.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+noncomputable section privateSection
+
+open Polynomial WeierstrassCurve WeierstrassCurve.Affine CoordinateRing
+
+open scoped Polynomial.Bivariate
+
+section
+
+universe u
+
+variable {F : Type u} [Field F]
+
+theorem WeierstrassCurve.Affine.exists_algebraMap_eq_of_isAlgebraic
+  [IsAlgClosed F] {L : Type u} [Field L] [Algebra F L]
+    {z : L} (hz : IsAlgebraic F z) : ∃ c : F, algebraMap F L c = z := by
+  have hint : IsIntegral F z := hz.isIntegral
+  have hdeg : (minpoly F z).degree = 1 :=
+    IsAlgClosed.degree_eq_one_of_irreducible F (minpoly.irreducible hint)
+  exact minpoly.degree_eq_one_iff.mp hdeg
+
+end
+
+section
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+def WeierstrassCurve.Affine.yGen (W : Affine F) : W.FunctionField :=
+  algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+
+end
+
+section
+
+namespace AlgebraicCurve
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem ord_add_eq_min {f g : F} (hf : f ≠ 0) (hg : g ≠ 0) (h : v.ord f ≠ v.ord g) :
+    v.ord (f + g) = min (v.ord f) (v.ord g) := by
+  have hval : v.adicValuation f ≠ v.adicValuation g := by
+    intro hcon
+    exact h (by simp only [ord, hcon])
+  have h1 : v.adicValuation (f + g) = max (v.adicValuation f) (v.adicValuation g) :=
+    Valuation.map_add_of_distinct_val _ hval
+  have hfg : f + g ≠ 0 := by
+    intro hcon
+    rw [hcon, _root_.map_zero] at h1
+    rcases max_cases (v.adicValuation f) (v.adicValuation g) with ⟨hmax, -⟩ | ⟨hmax, -⟩ <;>
+      rw [hmax] at h1
+    · exact v.adicValuation_ne_zero hf h1.symm
+    · exact v.adicValuation_ne_zero hg h1.symm
+  rcases max_cases (v.adicValuation f) (v.adicValuation g) with ⟨hmax, hle⟩ | ⟨hmax, hlt⟩ <;>
+    rw [hmax] at h1
+  · have hlog := (WithZero.log_le_log (v.adicValuation_ne_zero hg)
+      (v.adicValuation_ne_zero hf)).mpr hle
+    have h2 : v.ord (f + g) = v.ord f := by simp only [ord, h1]
+    simp only [ord] at hlog h2 ⊢
+    omega
+  · have hlog := (WithZero.log_le_log (v.adicValuation_ne_zero hf)
+      (v.adicValuation_ne_zero hg)).mpr hlt.le
+    have h2 : v.ord (f + g) = v.ord g := by simp only [ord, h1]
+    simp only [ord] at hlog h2 ⊢
+    omega
+
+end Place
+end AlgebraicCurve
+
+end
+
+section
+
+namespace WeierstrassCurve
+namespace Affine
+
+
+universe u
+
+variable {F : Type u} [Field F]
+
+section GenericPoint
+
+variable {W : Affine F}
+
+theorem equation_map_polyToFunctionField_yGen :
+    (W.map (algebraMap F W.FunctionField)).toAffine.Equation
+      (polyToFunctionField W X) (yGen W) := by
+  rw [equation_iff]
+  have hrel := smul_basis_mul_Y (W' := W) 0 1
+  rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at hrel
+  have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) hrel
+  rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆]
+  simp only [map_add, map_mul, map_pow, polyToFunctionField_C] at h2
+  rw [show yGen W = algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+    from rfl]
+  simp only [polyToFunctionField_apply] at h2 ⊢
+  linear_combination h2
+
+end GenericPoint
+
+end Affine
+end WeierstrassCurve
+
+end
+
+section
+
+namespace ModularCurve
+namespace Es1a1
+
+universe u
+
+section CoordSeamEs1a11
+
+variable {F : Type u} [Field F] [DecidableEq F]
+variable {W : WeierstrassCurve.Affine F} [W.IsElliptic]
+
+def es1a11_coordSeamDataAt (φ : W.FunctionField →ₐ[F] W.FunctionField)
+    (v : AlgebraicCurve.Place F W.FunctionField) : W.Point → Prop
+  | .zero => φ (polyToFunctionField W X) ∉ v.toValuationSubring
+  | .some x₃ y₃ _ =>
+      0 < v.ord (φ (polyToFunctionField W X) - algebraMap F W.FunctionField x₃) ∧
+        0 < v.ord (φ (yGen W) - algebraMap F W.FunctionField y₃)
+
+end CoordSeamEs1a11
+
+end Es1a1
+end ModularCurve
+
+end
+
+section
+
+namespace ModularCurve
+namespace Es1a1
+
+universe u
+
+section AddLawCore
+
+variable {F : Type u} [Field F]
+
+local instance instDecEqFunctionFieldEs1a6Add {W : WeierstrassCurve.Affine F} :
+    DecidableEq W.FunctionField :=
+  Classical.decEq _
+
+variable (W : WeierstrassCurve.Affine F)
+
+theorem es1a6_add_equation (φ : W.FunctionField →ₐ[F] W.FunctionField) :
+    (W.map (algebraMap F W.FunctionField)).toAffine.Equation
+      (φ (polyToFunctionField W X)) (φ (yGen W)) := by
+  have h := equation_map_polyToFunctionField_yGen (W := W)
+  rw [equation_iff'] at h
+  simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+    WeierstrassCurve.map_a₄, WeierstrassCurve.map_a₆] at h
+  have h2 := congrArg φ h
+  simp only [map_add, map_sub, map_mul, map_pow, _root_.map_zero, AlgHom.commutes] at h2
+  rw [equation_iff']
+  simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+    WeierstrassCurve.map_a₄, WeierstrassCurve.map_a₆]
+  linear_combination h2
+
+theorem es1a6_add_map_Δ_ne_zero (hΔ : W.Δ ≠ 0) :
+    (W.map (algebraMap F W.FunctionField)).Δ ≠ 0 := by
+  rw [WeierstrassCurve.map_Δ]
+  intro hcon
+  exact hΔ ((algebraMap F W.FunctionField).injective (by simpa using hcon))
+
+theorem es1a6_add_nonsingular (hΔ : W.Δ ≠ 0)
+    (φ : W.FunctionField →ₐ[F] W.FunctionField) :
+    (W.map (algebraMap F W.FunctionField)).toAffine.Nonsingular
+      (φ (polyToFunctionField W X)) (φ (yGen W)) :=
+  (equation_iff_nonsingular_of_Δ_ne_zero (es1a6_add_map_Δ_ne_zero W hΔ)).mp
+    (es1a6_add_equation W φ)
+
+variable (φ₁ φ₂ : W.FunctionField →ₐ[F] W.FunctionField)
+
+def es1a6_addCollapse : Prop :=
+  φ₁ (polyToFunctionField W X) = φ₂ (polyToFunctionField W X) ∧
+    φ₁ (yGen W) = (W.map (algebraMap F W.FunctionField)).toAffine.negY
+      (φ₂ (polyToFunctionField W X)) (φ₂ (yGen W))
+
+theorem es1a6_add_not_collapse_of_X_ne
+    (hne : φ₁ (polyToFunctionField W X) ≠ φ₂ (polyToFunctionField W X)) :
+    ¬ es1a6_addCollapse W φ₁ φ₂ :=
+  fun hc => hne hc.1
+
+def es1a6_addSumX : W.FunctionField :=
+  (W.map (algebraMap F W.FunctionField)).toAffine.addX
+    (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+    ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+      (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+      (φ₁ (yGen W)) (φ₂ (yGen W)))
+
+def es1a6_addSumY : W.FunctionField :=
+  (W.map (algebraMap F W.FunctionField)).toAffine.addY
+    (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X)) (φ₁ (yGen W))
+    ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+      (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+      (φ₁ (yGen W)) (φ₂ (yGen W)))
+
+theorem es1a6_addSum_equation (hcol : ¬ es1a6_addCollapse W φ₁ φ₂) :
+    (W.map (algebraMap F W.FunctionField)).toAffine.Equation
+      (es1a6_addSumX W φ₁ φ₂) (es1a6_addSumY W φ₁ φ₂) := by
+  unfold es1a6_addSumX es1a6_addSumY
+  exact equation_add (es1a6_add_equation W φ₁) (es1a6_add_equation W φ₂)
+    (fun hxy => hcol hxy)
+
+theorem es1a6_addSum_nonsingular (hΔ : W.Δ ≠ 0) (hcol : ¬ es1a6_addCollapse W φ₁ φ₂) :
+    (W.map (algebraMap F W.FunctionField)).toAffine.Nonsingular
+      (es1a6_addSumX W φ₁ φ₂) (es1a6_addSumY W φ₁ φ₂) :=
+  (equation_iff_nonsingular_of_Δ_ne_zero (es1a6_add_map_Δ_ne_zero W hΔ)).mp
+    (es1a6_addSum_equation W φ₁ φ₂ hcol)
+
+theorem es1a6_add_sumX_transcendental_of_forall_ne [IsAlgClosed F]
+    (hnc : ∀ c : F, es1a6_addSumX W φ₁ φ₂ ≠ algebraMap F W.FunctionField c) :
+    Transcendental F (es1a6_addSumX W φ₁ φ₂) := by
+  intro halg
+  obtain ⟨c, hc⟩ := exists_algebraMap_eq_of_isAlgebraic halg
+  exact hnc c hc.symm
+
+end AddLawCore
+
+section SeamEngines
+
+variable {F : Type u} [Field F]
+
+variable [DecidableEq F]
+variable {W : WeierstrassCurve.Affine F} [W.IsElliptic]
+
+variable (φ₁ φ₂ : W.FunctionField →ₐ[F] W.FunctionField)
+
+def es1a6_addSumSeamDataAt (v : AlgebraicCurve.Place F W.FunctionField) :
+    W.Point → Prop
+  | .zero => es1a6_addSumX W φ₁ φ₂ ∉ v.toValuationSubring
+  | .some x₃ y₃ _ =>
+      0 < v.ord (es1a6_addSumX W φ₁ φ₂ - algebraMap F W.FunctionField x₃) ∧
+        0 < v.ord (es1a6_addSumY W φ₁ φ₂ - algebraMap F W.FunctionField y₃)
+
+end SeamEngines
+
+end Es1a1
+end ModularCurve
+
+end
+
+section
+
+namespace ModularCurve
+
+namespace Es1a1
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F]
+variable (W : Affine F) [W.IsElliptic]
+
+abbrev kw_hk5f_addSumCoordSeamDataNCAt : Prop :=
+  ∀ φ₁ φ₂ : W.FunctionField →ₐ[F] W.FunctionField,
+    ¬ es1a6_addCollapse W φ₁ φ₂ →
+    (∀ c : F, es1a6_addSumX W φ₁ φ₂ ≠ algebraMap F W.FunctionField c) →
+    ∀ (v : AlgebraicCurve.Place F W.FunctionField) (Q₁ Q₂ : W.Point),
+      es1a11_coordSeamDataAt φ₁ v Q₁ → es1a11_coordSeamDataAt φ₂ v Q₂ →
+      es1a6_addSumSeamDataAt φ₁ φ₂ v (Q₁ + Q₂)
+
+end Es1a1
+
+end ModularCurve
+
+end
+
+section
+
+namespace ModularCurve
+namespace Es1a1
+
+universe u
+
+local instance instDecEqFunctionFieldEs1a10NcPole {F : Type u} [Field F]
+    {W : WeierstrassCurve.Affine F} :
+    DecidableEq W.FunctionField :=
+  Classical.decEq _
+
+section PoleVanishingCalculus
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : AlgebraicCurve.Place K F)
+
+theorem es1a10_ncPole_ord_algebraMap (c : K) : v.ord (algebraMap K F c) = 0 := by
+  rcases eq_or_ne c 0 with rfl | hc
+  · simp
+  have hmem : algebraMap K F c ∈ v.toValuationSubring := v.algebraMap_mem' c
+  have hmem' : (algebraMap K F c)⁻¹ ∈ v.toValuationSubring := by
+    rw [← map_inv₀]
+    exact v.algebraMap_mem' c⁻¹
+  have h1 := v.ord_nonneg_of_mem hmem
+  have h2 := v.ord_nonneg_of_mem hmem'
+  rw [v.ord_inv] at h2
+  omega
+
+theorem es1a10_ncPole_ord_neg (f : F) : v.ord (-f) = v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · simp
+  have h1 : (-f : F) = algebraMap K F (-1) * f := by
+    rw [_root_.map_neg, map_one]
+    ring
+  have hne : (algebraMap K F (-1 : K)) ≠ 0 := by
+    rw [_root_.map_neg, map_one]
+    exact neg_ne_zero.mpr one_ne_zero
+  rw [h1, v.ord_mul hne hf, es1a10_ncPole_ord_algebraMap, zero_add]
+
+def es1a10_ncPole_vanishesAt (f : F) : Prop := f = 0 ∨ 0 < v.ord f
+
+theorem es1a10_ncPole_vanishesAt_add {f g : F} (hf : es1a10_ncPole_vanishesAt v f)
+    (hg : es1a10_ncPole_vanishesAt v g) : es1a10_ncPole_vanishesAt v (f + g) := by
+  have hf' : f = 0 ∨ 0 < v.ord f := hf
+  have hg' : g = 0 ∨ 0 < v.ord g := hg
+  rcases hf' with rfl | hf0
+  · rw [zero_add]
+    exact hg
+  rcases hg' with rfl | hg0
+  · rw [add_zero]
+    exact hf
+  rcases eq_or_ne (f + g) 0 with h0 | h0
+  · exact Or.inl h0
+  · refine Or.inr ?_
+    have h1 := v.min_ord_le_ord_add' h0
+    have h2 : (0 : ℤ) < min (v.ord f) (v.ord g) := lt_min hf0 hg0
+    exact h2.trans_le h1
+
+theorem es1a10_ncPole_vanishesAt_neg {f : F} (hf : es1a10_ncPole_vanishesAt v f) :
+    es1a10_ncPole_vanishesAt v (-f) := by
+  have hf' : f = 0 ∨ 0 < v.ord f := hf
+  change -f = 0 ∨ 0 < v.ord (-f)
+  rcases hf' with rfl | hf0
+  · exact Or.inl _root_.neg_zero
+  · refine Or.inr ?_
+    rw [es1a10_ncPole_ord_neg]
+    exact hf0
+
+theorem es1a10_ncPole_vanishesAt_sub {f g : F} (hf : es1a10_ncPole_vanishesAt v f)
+    (hg : es1a10_ncPole_vanishesAt v g) : es1a10_ncPole_vanishesAt v (f - g) := by
+  rw [sub_eq_add_neg]
+  exact es1a10_ncPole_vanishesAt_add v hf (es1a10_ncPole_vanishesAt_neg v hg)
+
+theorem es1a10_ncPole_vanishesAt_mul_mem {f g : F} (hf : es1a10_ncPole_vanishesAt v f)
+    (hg : g ∈ v.toValuationSubring) : es1a10_ncPole_vanishesAt v (f * g) := by
+  have hf' : f = 0 ∨ 0 < v.ord f := hf
+  change f * g = 0 ∨ 0 < v.ord (f * g)
+  rcases hf' with rfl | hf0
+  · exact Or.inl (zero_mul g)
+  rcases eq_or_ne g 0 with rfl | hg0
+  · exact Or.inl (mul_zero f)
+  · refine Or.inr ?_
+    have hf1 : f ≠ 0 := by
+      intro h
+      rw [h, v.ord_zero] at hf0
+      exact lt_irrefl 0 hf0
+    rw [v.ord_mul hf1 hg0]
+    have h2 := v.ord_nonneg_of_mem hg
+    omega
+
+theorem es1a10_ncPole_vanishesAt_mem_mul {f g : F} (hf : f ∈ v.toValuationSubring)
+    (hg : es1a10_ncPole_vanishesAt v g) : es1a10_ncPole_vanishesAt v (f * g) := by
+  rw [mul_comm]
+  exact es1a10_ncPole_vanishesAt_mul_mem v hg hf
+
+theorem es1a10_ncPole_mem_of_vanishesAt {f : F} (hf : es1a10_ncPole_vanishesAt v f) :
+    f ∈ v.toValuationSubring := by
+  have hf' : f = 0 ∨ 0 < v.ord f := hf
+  rcases hf' with rfl | hf0
+  · exact zero_mem _
+  · have hne : f ≠ 0 := by
+      intro h
+      rw [h, v.ord_zero] at hf0
+      exact lt_irrefl 0 hf0
+    exact v.mem_of_ord_nonneg hne hf0.le
+
+def es1a10_ncPole_reducesTo (f : F) (c : K) : Prop :=
+  es1a10_ncPole_vanishesAt v (f - algebraMap K F c)
+
+theorem es1a10_ncPole_reducesTo_of_ord_pos {f : F} {c : K}
+    (h : 0 < v.ord (f - algebraMap K F c)) : es1a10_ncPole_reducesTo v f c :=
+  Or.inr h
+
+theorem es1a10_ncPole_reducesTo_zero {f : F} (hf : es1a10_ncPole_vanishesAt v f) :
+    es1a10_ncPole_reducesTo v f 0 := by
+  change es1a10_ncPole_vanishesAt v (f - algebraMap K F 0)
+  rwa [_root_.map_zero, sub_zero]
+
+theorem es1a10_ncPole_vanishesAt_of_reducesTo_zero {f : F}
+    (hf : es1a10_ncPole_reducesTo v f 0) : es1a10_ncPole_vanishesAt v f := by
+  have h : es1a10_ncPole_vanishesAt v (f - algebraMap K F 0) := hf
+  rwa [_root_.map_zero, sub_zero] at h
+
+theorem es1a10_ncPole_reducesTo_add {f g : F} {c d : K}
+    (hf : es1a10_ncPole_reducesTo v f c) (hg : es1a10_ncPole_reducesTo v g d) :
+    es1a10_ncPole_reducesTo v (f + g) (c + d) := by
+  change es1a10_ncPole_vanishesAt v (f + g - algebraMap K F (c + d))
+  rw [show f + g - algebraMap K F (c + d)
+      = (f - algebraMap K F c) + (g - algebraMap K F d) by rw [map_add]; ring]
+  exact es1a10_ncPole_vanishesAt_add v hf hg
+
+theorem es1a10_ncPole_reducesTo_neg {f : F} {c : K}
+    (hf : es1a10_ncPole_reducesTo v f c) :
+    es1a10_ncPole_reducesTo v (-f) (-c) := by
+  change es1a10_ncPole_vanishesAt v (-f - algebraMap K F (-c))
+  rw [show -f - algebraMap K F (-c) = -(f - algebraMap K F c) by rw [_root_.map_neg]; ring]
+  exact es1a10_ncPole_vanishesAt_neg v hf
+
+theorem es1a10_ncPole_reducesTo_sub {f g : F} {c d : K}
+    (hf : es1a10_ncPole_reducesTo v f c) (hg : es1a10_ncPole_reducesTo v g d) :
+    es1a10_ncPole_reducesTo v (f - g) (c - d) := by
+  change es1a10_ncPole_vanishesAt v (f - g - algebraMap K F (c - d))
+  rw [show f - g - algebraMap K F (c - d)
+      = (f - algebraMap K F c) - (g - algebraMap K F d) by rw [map_sub]; ring]
+  exact es1a10_ncPole_vanishesAt_sub v hf hg
+
+theorem es1a10_ncPole_mem_of_reducesTo {g : F} {d : K}
+    (hg : es1a10_ncPole_reducesTo v g d) : g ∈ v.toValuationSubring := by
+  have h1 : g - algebraMap K F d ∈ v.toValuationSubring :=
+    es1a10_ncPole_mem_of_vanishesAt v hg
+  have h2 := add_mem h1 (v.algebraMap_mem' d)
+  rwa [sub_add_cancel] at h2
+
+theorem es1a10_ncPole_reducesTo_mul {f g : F} {c d : K}
+    (hf : es1a10_ncPole_reducesTo v f c) (hg : es1a10_ncPole_reducesTo v g d) :
+    es1a10_ncPole_reducesTo v (f * g) (c * d) := by
+  change es1a10_ncPole_vanishesAt v (f * g - algebraMap K F (c * d))
+  rw [show f * g - algebraMap K F (c * d)
+      = (f - algebraMap K F c) * g
+        + algebraMap K F c * (g - algebraMap K F d) by rw [map_mul]; ring]
+  exact es1a10_ncPole_vanishesAt_add v
+    (es1a10_ncPole_vanishesAt_mul_mem v hf (es1a10_ncPole_mem_of_reducesTo v hg))
+    (es1a10_ncPole_vanishesAt_mem_mul v (v.algebraMap_mem' c) hg)
+
+theorem es1a10_ncPole_reducesTo_ord_eq_zero {f : F} {c : K}
+    (hf : es1a10_ncPole_reducesTo v f c) (hc : c ≠ 0) : f ≠ 0 ∧ v.ord f = 0 := by
+  have hmap0 : algebraMap K F c ≠ 0 := fun h =>
+    hc ((algebraMap K F).injective (by rw [h, _root_.map_zero]))
+  have hf' : f - algebraMap K F c = 0 ∨ 0 < v.ord (f - algebraMap K F c) := hf
+  rcases hf' with h0 | hpos
+  · have hfeq : f = algebraMap K F c := sub_eq_zero.mp h0
+    refine ⟨by rw [hfeq]; exact hmap0, ?_⟩
+    rw [hfeq, es1a10_ncPole_ord_algebraMap]
+  · have hd0 : f - algebraMap K F c ≠ 0 := by
+      intro h
+      rw [h, v.ord_zero] at hpos
+      exact lt_irrefl 0 hpos
+    have hf0 : f ≠ 0 := by
+      intro h
+      have h1 : f - algebraMap K F c = -(algebraMap K F c) := by rw [h]; ring
+      rw [h1, es1a10_ncPole_ord_neg, es1a10_ncPole_ord_algebraMap] at hpos
+      exact lt_irrefl 0 hpos
+    have hsum : algebraMap K F c + (f - algebraMap K F c) = f := by ring
+    have hmin := v.ord_add_eq_min hmap0 hd0 (by
+      rw [es1a10_ncPole_ord_algebraMap]
+      omega)
+    rw [hsum] at hmin
+    refine ⟨hf0, ?_⟩
+    rw [hmin, es1a10_ncPole_ord_algebraMap]
+    exact min_eq_left hpos.le
+
+theorem es1a10_ncPole_reducesTo_inv {f : F} {c : K}
+    (hf : es1a10_ncPole_reducesTo v f c) (hc : c ≠ 0) :
+    es1a10_ncPole_reducesTo v f⁻¹ c⁻¹ := by
+  obtain ⟨hf0, hford⟩ := es1a10_ncPole_reducesTo_ord_eq_zero v hf hc
+  have hmap0 : algebraMap K F c ≠ 0 := fun h =>
+    hc ((algebraMap K F).injective (by rw [h, _root_.map_zero]))
+  have hvan : es1a10_ncPole_vanishesAt v (algebraMap K F c - f) := by
+    rw [show algebraMap K F c - f = -(f - algebraMap K F c) by ring]
+    exact es1a10_ncPole_vanishesAt_neg v hf
+  have hinv_mem : f⁻¹ ∈ v.toValuationSubring := by
+    refine v.mem_of_ord_nonneg (inv_ne_zero hf0) ?_
+    rw [v.ord_inv, hford]
+    omega
+  change es1a10_ncPole_vanishesAt v (f⁻¹ - algebraMap K F c⁻¹)
+  rw [map_inv₀, inv_sub_inv hf0 hmap0, div_eq_mul_inv, mul_inv]
+  exact es1a10_ncPole_vanishesAt_mul_mem v hvan
+    (mul_mem hinv_mem (by rw [← map_inv₀]; exact v.algebraMap_mem' c⁻¹))
+
+theorem es1a10_ncPole_ord_pos_of_reducesTo_of_ne {f : F} {c : K}
+    (hf : es1a10_ncPole_reducesTo v f c) (hne : f ≠ algebraMap K F c) :
+    0 < v.ord (f - algebraMap K F c) := by
+  have hf' : f - algebraMap K F c = 0 ∨ 0 < v.ord (f - algebraMap K F c) := hf
+  rcases hf' with h0 | hpos
+  · exact absurd (sub_eq_zero.mp h0) hne
+  · exact hpos
+
+end PoleVanishingCalculus
+
+section PoleBlock
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : AlgebraicCurve.Place K F)
+
+theorem es1a10_ncPole_poleData {a₁ a₂ a₃ a₄ a₆ : K} {ξp ηp : F}
+    (heqp : ηp ^ 2 + algebraMap K F a₁ * ξp * ηp + algebraMap K F a₃ * ηp
+      = ξp ^ 3 + algebraMap K F a₂ * ξp ^ 2 + algebraMap K F a₄ * ξp
+        + algebraMap K F a₆)
+    (hpole : ξp ∉ v.toValuationSubring) :
+    ξp ≠ 0 ∧ ηp ≠ 0 ∧ es1a10_ncPole_vanishesAt v ξp⁻¹
+      ∧ es1a10_ncPole_vanishesAt v (ηp * ξp⁻¹ ^ 2)
+      ∧ es1a10_ncPole_reducesTo v (ηp ^ 2 * ξp⁻¹ ^ 3) 1 := by
+  have hξ0 : ξp ≠ 0 := fun h => hpole (by rw [h]; exact zero_mem _)
+  have hn : v.ord ξp < 0 := by
+    by_contra hge
+    exact hpole (v.mem_of_ord_nonneg hξ0 (not_lt.mp hge))
+  have hw0 : ξp⁻¹ ≠ 0 := inv_ne_zero hξ0
+  have hξw : ξp * ξp⁻¹ = 1 := mul_inv_cancel₀ hξ0
+  have hword : v.ord ξp⁻¹ = -v.ord ξp := v.ord_inv ξp
+  have hwvan : es1a10_ncPole_vanishesAt v ξp⁻¹ := Or.inr (by rw [hword]; omega)
+  have hwmem : ξp⁻¹ ∈ v.toValuationSubring := es1a10_ncPole_mem_of_vanishesAt v hwvan
+  have hu₁red : es1a10_ncPole_reducesTo v
+      (1 + algebraMap K F a₂ * ξp⁻¹ + algebraMap K F a₄ * ξp⁻¹ ^ 2
+        + algebraMap K F a₆ * ξp⁻¹ ^ 3) 1 := by
+    change es1a10_ncPole_vanishesAt v _
+    rw [show 1 + algebraMap K F a₂ * ξp⁻¹ + algebraMap K F a₄ * ξp⁻¹ ^ 2
+          + algebraMap K F a₆ * ξp⁻¹ ^ 3 - algebraMap K F 1
+        = algebraMap K F a₂ * ξp⁻¹ + (algebraMap K F a₄ * ξp⁻¹) * ξp⁻¹
+          + ((algebraMap K F a₆ * ξp⁻¹) * ξp⁻¹) * ξp⁻¹ by rw [map_one]; ring]
+    exact es1a10_ncPole_vanishesAt_add v
+      (es1a10_ncPole_vanishesAt_add v
+        (es1a10_ncPole_vanishesAt_mem_mul v (v.algebraMap_mem' a₂) hwvan)
+        (es1a10_ncPole_vanishesAt_mul_mem v
+          (es1a10_ncPole_vanishesAt_mem_mul v (v.algebraMap_mem' a₄) hwvan) hwmem))
+      (es1a10_ncPole_vanishesAt_mul_mem v
+        (es1a10_ncPole_vanishesAt_mul_mem v
+          (es1a10_ncPole_vanishesAt_mem_mul v (v.algebraMap_mem' a₆) hwvan) hwmem)
+        hwmem)
+  obtain ⟨hu₁0, hu₁ord⟩ := es1a10_ncPole_reducesTo_ord_eq_zero v hu₁red one_ne_zero
+  have hprod : ηp * (ηp + (algebraMap K F a₁ * ξp + algebraMap K F a₃)) * ξp⁻¹ ^ 3
+      = 1 + algebraMap K F a₂ * ξp⁻¹ + algebraMap K F a₄ * ξp⁻¹ ^ 2
+        + algebraMap K F a₆ * ξp⁻¹ ^ 3 := by
+    linear_combination ξp⁻¹ ^ 3 * heqp
+      + (ξp ^ 2 * ξp⁻¹ ^ 2 + algebraMap K F a₂ * ξp * ξp⁻¹ ^ 2 + ξp * ξp⁻¹
+        + algebraMap K F a₂ * ξp⁻¹ + algebraMap K F a₄ * ξp⁻¹ ^ 2 + 1) * hξw
+  have hη0 : ηp ≠ 0 := by
+    intro h
+    rw [h, zero_mul, zero_mul] at hprod
+    exact hu₁0 hprod.symm
+  have hSp0 : ηp + (algebraMap K F a₁ * ξp + algebraMap K F a₃) ≠ 0 := by
+    intro h
+    rw [h, mul_zero, zero_mul] at hprod
+    exact hu₁0 hprod.symm
+  have hword3 : v.ord (ξp⁻¹ ^ 3) = 3 * v.ord ξp⁻¹ := by
+    rw [pow_succ, pow_succ, pow_one, v.ord_mul (mul_ne_zero hw0 hw0) hw0,
+      v.ord_mul hw0 hw0]
+    ring
+  have hordeq : v.ord ηp
+      + v.ord (ηp + (algebraMap K F a₁ * ξp + algebraMap K F a₃))
+      + 3 * v.ord ξp⁻¹ = 0 := by
+    have h1 : v.ord (ηp * (ηp + (algebraMap K F a₁ * ξp + algebraMap K F a₃))
+        * ξp⁻¹ ^ 3) = 0 := by
+      rw [hprod]
+      exact hu₁ord
+    rw [v.ord_mul (mul_ne_zero hη0 hSp0) (pow_ne_zero 3 hw0),
+      v.ord_mul hη0 hSp0, hword3] at h1
+    omega
+  have hs : algebraMap K F a₁ * ξp + algebraMap K F a₃ = 0
+      ∨ (algebraMap K F a₁ * ξp + algebraMap K F a₃ ≠ 0
+        ∧ v.ord ξp ≤ v.ord (algebraMap K F a₁ * ξp + algebraMap K F a₃)) := by
+    rcases eq_or_ne a₁ 0 with h1 | h1
+    · rcases eq_or_ne a₃ 0 with h3 | h3
+      · left
+        rw [h1, h3, _root_.map_zero, zero_mul, add_zero]
+      · right
+        have h3' : algebraMap K F a₃ ≠ 0 := fun hcon =>
+          h3 ((algebraMap K F).injective (by rw [hcon, _root_.map_zero]))
+        constructor
+        · rw [h1, _root_.map_zero, zero_mul, zero_add]
+          exact h3'
+        · rw [h1, _root_.map_zero, zero_mul, zero_add, es1a10_ncPole_ord_algebraMap]
+          omega
+    · have h1' : algebraMap K F a₁ ≠ 0 := fun hcon =>
+        h1 ((algebraMap K F).injective (by rw [hcon, _root_.map_zero]))
+      have hmul0 : algebraMap K F a₁ * ξp ≠ 0 := mul_ne_zero h1' hξ0
+      have hmulord : v.ord (algebraMap K F a₁ * ξp) = v.ord ξp := by
+        rw [v.ord_mul h1' hξ0, es1a10_ncPole_ord_algebraMap, zero_add]
+      rcases eq_or_ne a₃ 0 with h3 | h3
+      · right
+        rw [h3, _root_.map_zero, add_zero]
+        exact ⟨hmul0, le_of_eq hmulord.symm⟩
+      · right
+        have h3' : algebraMap K F a₃ ≠ 0 := fun hcon =>
+          h3 ((algebraMap K F).injective (by rw [hcon, _root_.map_zero]))
+        have hords : v.ord (algebraMap K F a₁ * ξp) ≠ v.ord (algebraMap K F a₃) := by
+          rw [hmulord, es1a10_ncPole_ord_algebraMap]
+          omega
+        have hmin := v.ord_add_eq_min hmul0 h3' hords
+        constructor
+        · intro hcon
+          rw [hcon, v.ord_zero, hmulord, es1a10_ncPole_ord_algebraMap] at hmin
+          omega
+        · rw [hmin, hmulord, es1a10_ncPole_ord_algebraMap]
+          omega
+  have hkn : v.ord ηp < v.ord ξp := by
+    by_contra hge
+    rw [not_lt] at hge
+    have hSpord : v.ord ξp
+        ≤ v.ord (ηp + (algebraMap K F a₁ * ξp + algebraMap K F a₃)) := by
+      rcases hs with h0 | ⟨hs0, hsord⟩
+      · rw [h0, add_zero]
+        exact hge
+      · calc v.ord ξp
+            ≤ min (v.ord ηp) (v.ord (algebraMap K F a₁ * ξp + algebraMap K F a₃)) :=
+              le_min hge hsord
+          _ ≤ _ := v.min_ord_le_ord_add' hSp0
+    omega
+  have hSpk : v.ord (ηp + (algebraMap K F a₁ * ξp + algebraMap K F a₃))
+      = v.ord ηp := by
+    rcases hs with h0 | ⟨hs0, hsord⟩
+    · rw [h0, add_zero]
+    · rw [v.ord_add_eq_min hη0 hs0 (by omega)]
+      exact min_eq_left (by omega)
+  have hk23 : 2 * v.ord ηp = 3 * v.ord ξp := by omega
+  have hword2 : v.ord (ξp⁻¹ ^ 2) = 2 * v.ord ξp⁻¹ := by
+    rw [pow_two, v.ord_mul hw0 hw0]
+    ring
+  have hηw2 : es1a10_ncPole_vanishesAt v (ηp * ξp⁻¹ ^ 2) := by
+    refine Or.inr ?_
+    rw [v.ord_mul hη0 (pow_ne_zero 2 hw0), hword2]
+    omega
+  have hid : ηp ^ 2 * ξp⁻¹ ^ 3
+      = (1 + algebraMap K F a₂ * ξp⁻¹ + algebraMap K F a₄ * ξp⁻¹ ^ 2
+          + algebraMap K F a₆ * ξp⁻¹ ^ 3)
+        - algebraMap K F a₁ * (ηp * ξp⁻¹ ^ 2)
+        - algebraMap K F a₃ * ((ηp * ξp⁻¹ ^ 2) * ξp⁻¹) := by
+    linear_combination ξp⁻¹ ^ 3 * heqp
+      + (- algebraMap K F a₁ * ξp⁻¹ ^ 2 * ηp + algebraMap K F a₂ * ξp⁻¹ ^ 2 * ξp
+        + algebraMap K F a₂ * ξp⁻¹ + algebraMap K F a₄ * ξp⁻¹ ^ 2
+        + ξp⁻¹ ^ 2 * ξp ^ 2 + ξp⁻¹ * ξp + 1) * hξw
+  have hηsq : es1a10_ncPole_reducesTo v (ηp ^ 2 * ξp⁻¹ ^ 3) 1 := by
+    rw [hid]
+    have h1 : es1a10_ncPole_reducesTo v
+        (algebraMap K F a₁ * (ηp * ξp⁻¹ ^ 2)) 0 :=
+      es1a10_ncPole_reducesTo_zero v
+        (es1a10_ncPole_vanishesAt_mem_mul v (v.algebraMap_mem' a₁) hηw2)
+    have h2 : es1a10_ncPole_reducesTo v
+        (algebraMap K F a₃ * ((ηp * ξp⁻¹ ^ 2) * ξp⁻¹)) 0 :=
+      es1a10_ncPole_reducesTo_zero v
+        (es1a10_ncPole_vanishesAt_mem_mul v (v.algebraMap_mem' a₃)
+          (es1a10_ncPole_vanishesAt_mul_mem v hηw2 hwmem))
+    have h3 := es1a10_ncPole_reducesTo_sub v
+      (es1a10_ncPole_reducesTo_sub v hu₁red h1) h2
+    simpa using h3
+  exact ⟨hξ0, hη0, hwvan, hηw2, hηsq⟩
+
+theorem es1a10_ncPole_addX_key {a₁ a₂ a₃ a₄ a₆ : K} {ξp ηp ξf ηf Λ : F}
+    (hξ0 : ξp ≠ 0)
+    (heqp : ηp ^ 2 + algebraMap K F a₁ * ξp * ηp + algebraMap K F a₃ * ηp
+      = ξp ^ 3 + algebraMap K F a₂ * ξp ^ 2 + algebraMap K F a₄ * ξp
+        + algebraMap K F a₆)
+    (heqf : ηf ^ 2 + algebraMap K F a₁ * ξf * ηf + algebraMap K F a₃ * ηf
+      = ξf ^ 3 + algebraMap K F a₂ * ξf ^ 2 + algebraMap K F a₄ * ξf
+        + algebraMap K F a₆)
+    (hΛ : Λ * (ξp - ξf) = ηp - ηf) :
+    (Λ ^ 2 + algebraMap K F a₁ * Λ - algebraMap K F a₂ - ξp - ξf - ξf)
+        * (1 - ξf * ξp⁻¹) ^ 2
+      = (3 * ξf ^ 2 + 2 * algebraMap K F a₂ * ξf + algebraMap K F a₄
+          - algebraMap K F a₁ * ηf) * ξp⁻¹
+        + (- ξf ^ 3 + algebraMap K F a₄ * ξf + 2 * algebraMap K F a₆
+          - algebraMap K F a₃ * ηf) * ξp⁻¹ ^ 2
+        - (algebraMap K F a₁ * ξf + algebraMap K F a₃ + (ηf + ηf))
+          * (ηp * ξp⁻¹ ^ 2) := by
+  have hξw : ξp * ξp⁻¹ = 1 := mul_inv_cancel₀ hξ0
+  have hstep1 : (Λ ^ 2 + algebraMap K F a₁ * Λ - algebraMap K F a₂ - ξp - ξf - ξf)
+        * (ξp - ξf) ^ 2
+      = - ξf ^ 3 + 3 * ξp * ξf ^ 2 + 2 * algebraMap K F a₂ * ξp * ξf
+        + algebraMap K F a₄ * (ξp + ξf) + 2 * algebraMap K F a₆
+        - algebraMap K F a₁ * (ξp * ηf + ξf * ηp)
+        - algebraMap K F a₃ * (ηp + ηf) - 2 * ηp * ηf := by
+    linear_combination (Λ * (ξp - ξf) + (ηp - ηf) + algebraMap K F a₁ * (ξp - ξf)) * hΛ
+      + heqp + heqf
+  have hstep2 : (- ξf ^ 3 + 3 * ξp * ξf ^ 2 + 2 * algebraMap K F a₂ * ξp * ξf
+        + algebraMap K F a₄ * (ξp + ξf) + 2 * algebraMap K F a₆
+        - algebraMap K F a₁ * (ξp * ηf + ξf * ηp)
+        - algebraMap K F a₃ * (ηp + ηf) - 2 * ηp * ηf) * ξp⁻¹ ^ 2
+      = (3 * ξf ^ 2 + 2 * algebraMap K F a₂ * ξf + algebraMap K F a₄
+          - algebraMap K F a₁ * ηf) * ξp⁻¹
+        + (- ξf ^ 3 + algebraMap K F a₄ * ξf + 2 * algebraMap K F a₆
+          - algebraMap K F a₃ * ηf) * ξp⁻¹ ^ 2
+        - (algebraMap K F a₁ * ξf + algebraMap K F a₃ + (ηf + ηf))
+          * (ηp * ξp⁻¹ ^ 2) := by
+    linear_combination ((3 * ξf ^ 2 + 2 * algebraMap K F a₂ * ξf + algebraMap K F a₄
+      - algebraMap K F a₁ * ηf) * ξp⁻¹) * hξw
+  calc (Λ ^ 2 + algebraMap K F a₁ * Λ - algebraMap K F a₂ - ξp - ξf - ξf)
+        * (1 - ξf * ξp⁻¹) ^ 2
+      = ((Λ ^ 2 + algebraMap K F a₁ * Λ - algebraMap K F a₂ - ξp - ξf - ξf)
+          * (ξp - ξf) ^ 2) * ξp⁻¹ ^ 2 := by
+        rw [show (1 : F) - ξf * ξp⁻¹ = (ξp - ξf) * ξp⁻¹ by rw [sub_mul, hξw]]
+        ring
+    _ = _ := by rw [hstep1]; exact hstep2
+
+theorem es1a10_ncPole_addX_core {a₁ a₂ a₃ a₄ a₆ : K} {ξp ηp ξf ηf Λ : F}
+    (heqp : ηp ^ 2 + algebraMap K F a₁ * ξp * ηp + algebraMap K F a₃ * ηp
+      = ξp ^ 3 + algebraMap K F a₂ * ξp ^ 2 + algebraMap K F a₄ * ξp
+        + algebraMap K F a₆)
+    (heqf : ηf ^ 2 + algebraMap K F a₁ * ξf * ηf + algebraMap K F a₃ * ηf
+      = ξf ^ 3 + algebraMap K F a₂ * ξf ^ 2 + algebraMap K F a₄ * ξf
+        + algebraMap K F a₆)
+    (hpole : ξp ∉ v.toValuationSubring)
+    (hxf : ξf ∈ v.toValuationSubring) (hyf : ηf ∈ v.toValuationSubring)
+    (hΛ : Λ * (ξp - ξf) = ηp - ηf) :
+    es1a10_ncPole_vanishesAt v
+      (Λ ^ 2 + algebraMap K F a₁ * Λ - algebraMap K F a₂ - ξp - ξf - ξf) := by
+  obtain ⟨hξ0, -, hwvan, hηw2, -⟩ := es1a10_ncPole_poleData v heqp hpole
+  have hwmem : ξp⁻¹ ∈ v.toValuationSubring := es1a10_ncPole_mem_of_vanishesAt v hwvan
+  have h2mem : (2 : F) ∈ v.toValuationSubring := by
+    have h := v.algebraMap_mem' (2 : K)
+    rwa [map_ofNat] at h
+  have h3mem : (3 : F) ∈ v.toValuationSubring := by
+    have h := v.algebraMap_mem' (3 : K)
+    rwa [map_ofNat] at h
+  have hu₂red : es1a10_ncPole_reducesTo v (1 - ξf * ξp⁻¹) 1 := by
+    change es1a10_ncPole_vanishesAt v _
+    rw [show (1 : F) - ξf * ξp⁻¹ - algebraMap K F 1 = -(ξf * ξp⁻¹) by
+      rw [map_one]; ring]
+    exact es1a10_ncPole_vanishesAt_neg v
+      (es1a10_ncPole_vanishesAt_mem_mul v hxf hwvan)
+  have hu₂0 : (1 : F) - ξf * ξp⁻¹ ≠ 0 :=
+    (es1a10_ncPole_reducesTo_ord_eq_zero v hu₂red one_ne_zero).1
+  have hkey := es1a10_ncPole_addX_key (K := K) (F := F) hξ0 heqp heqf hΛ
+  have hw2van : es1a10_ncPole_vanishesAt v (ξp⁻¹ ^ 2) := by
+    rw [pow_two]
+    exact es1a10_ncPole_vanishesAt_mul_mem v hwvan hwmem
+  have hAmem : 3 * ξf ^ 2 + 2 * algebraMap K F a₂ * ξf + algebraMap K F a₄
+      - algebraMap K F a₁ * ηf ∈ v.toValuationSubring :=
+    sub_mem (add_mem (add_mem (mul_mem h3mem (pow_mem hxf 2))
+      (mul_mem (mul_mem h2mem (v.algebraMap_mem' a₂)) hxf)) (v.algebraMap_mem' a₄))
+      (mul_mem (v.algebraMap_mem' a₁) hyf)
+  have hBmem : - ξf ^ 3 + algebraMap K F a₄ * ξf + 2 * algebraMap K F a₆
+      - algebraMap K F a₃ * ηf ∈ v.toValuationSubring :=
+    sub_mem (add_mem (add_mem (neg_mem (pow_mem hxf 3))
+      (mul_mem (v.algebraMap_mem' a₄) hxf)) (mul_mem h2mem (v.algebraMap_mem' a₆)))
+      (mul_mem (v.algebraMap_mem' a₃) hyf)
+  have hCmem : algebraMap K F a₁ * ξf + algebraMap K F a₃ + (ηf + ηf)
+      ∈ v.toValuationSubring :=
+    add_mem (add_mem (mul_mem (v.algebraMap_mem' a₁) hxf) (v.algebraMap_mem' a₃))
+      (add_mem hyf hyf)
+  have hEvan : es1a10_ncPole_vanishesAt v
+      ((3 * ξf ^ 2 + 2 * algebraMap K F a₂ * ξf + algebraMap K F a₄
+          - algebraMap K F a₁ * ηf) * ξp⁻¹
+        + (- ξf ^ 3 + algebraMap K F a₄ * ξf + 2 * algebraMap K F a₆
+          - algebraMap K F a₃ * ηf) * ξp⁻¹ ^ 2
+        - (algebraMap K F a₁ * ξf + algebraMap K F a₃ + (ηf + ηf))
+          * (ηp * ξp⁻¹ ^ 2)) :=
+    es1a10_ncPole_vanishesAt_sub v
+      (es1a10_ncPole_vanishesAt_add v
+        (es1a10_ncPole_vanishesAt_mem_mul v hAmem hwvan)
+        (es1a10_ncPole_vanishesAt_mem_mul v hBmem hw2van))
+      (es1a10_ncPole_vanishesAt_mem_mul v hCmem hηw2)
+  have hu₂sq : es1a10_ncPole_reducesTo v ((1 - ξf * ξp⁻¹) ^ 2) 1 := by
+    rw [pow_two]
+    have h := es1a10_ncPole_reducesTo_mul v hu₂red hu₂red
+    simpa using h
+  have hinvmem : (((1 : F) - ξf * ξp⁻¹) ^ 2)⁻¹ ∈ v.toValuationSubring :=
+    es1a10_ncPole_mem_of_reducesTo v
+      (es1a10_ncPole_reducesTo_inv v hu₂sq one_ne_zero)
+  have hfin : Λ ^ 2 + algebraMap K F a₁ * Λ - algebraMap K F a₂ - ξp - ξf - ξf
+      = ((3 * ξf ^ 2 + 2 * algebraMap K F a₂ * ξf + algebraMap K F a₄
+          - algebraMap K F a₁ * ηf) * ξp⁻¹
+        + (- ξf ^ 3 + algebraMap K F a₄ * ξf + 2 * algebraMap K F a₆
+          - algebraMap K F a₃ * ηf) * ξp⁻¹ ^ 2
+        - (algebraMap K F a₁ * ξf + algebraMap K F a₃ + (ηf + ηf))
+          * (ηp * ξp⁻¹ ^ 2)) * (((1 : F) - ξf * ξp⁻¹) ^ 2)⁻¹ := by
+    rw [← hkey, mul_inv_cancel_right₀ (pow_ne_zero 2 hu₂0)]
+  rw [hfin]
+  exact es1a10_ncPole_vanishesAt_mul_mem v hEvan hinvmem
+
+theorem es1a10_ncPole_addY_core {a₁ a₂ a₃ a₄ a₆ : K} {ξp ηp ξf ηf Λ : F}
+    (heqp : ηp ^ 2 + algebraMap K F a₁ * ξp * ηp + algebraMap K F a₃ * ηp
+      = ξp ^ 3 + algebraMap K F a₂ * ξp ^ 2 + algebraMap K F a₄ * ξp
+        + algebraMap K F a₆)
+    (heqf : ηf ^ 2 + algebraMap K F a₁ * ξf * ηf + algebraMap K F a₃ * ηf
+      = ξf ^ 3 + algebraMap K F a₂ * ξf ^ 2 + algebraMap K F a₄ * ξf
+        + algebraMap K F a₆)
+    (hpole : ξp ∉ v.toValuationSubring)
+    (hxf : ξf ∈ v.toValuationSubring) (hyf : ηf ∈ v.toValuationSubring)
+    (hΛ : Λ * (ξp - ξf) = ηp - ηf) :
+    es1a10_ncPole_vanishesAt v
+      (Λ * (Λ ^ 2 + algebraMap K F a₁ * Λ - algebraMap K F a₂ - ξp - ξf - ξf)
+        + (ηf + ηf + algebraMap K F a₁ * ξf + algebraMap K F a₃)) := by
+  obtain ⟨hξ0, -, hwvan, hηw2, hηsq⟩ := es1a10_ncPole_poleData v heqp hpole
+  have hwmem : ξp⁻¹ ∈ v.toValuationSubring := es1a10_ncPole_mem_of_vanishesAt v hwvan
+  have hξw : ξp * ξp⁻¹ = 1 := mul_inv_cancel₀ hξ0
+  have h2mem : (2 : F) ∈ v.toValuationSubring := by
+    have h := v.algebraMap_mem' (2 : K)
+    rwa [map_ofNat] at h
+  have h3mem : (3 : F) ∈ v.toValuationSubring := by
+    have h := v.algebraMap_mem' (3 : K)
+    rwa [map_ofNat] at h
+  have hu₂red : es1a10_ncPole_reducesTo v (1 - ξf * ξp⁻¹) 1 := by
+    change es1a10_ncPole_vanishesAt v _
+    rw [show (1 : F) - ξf * ξp⁻¹ - algebraMap K F 1 = -(ξf * ξp⁻¹) by
+      rw [map_one]; ring]
+    exact es1a10_ncPole_vanishesAt_neg v
+      (es1a10_ncPole_vanishesAt_mem_mul v hxf hwvan)
+  have hu₂0 : (1 : F) - ξf * ξp⁻¹ ≠ 0 :=
+    (es1a10_ncPole_reducesTo_ord_eq_zero v hu₂red one_ne_zero).1
+  have hkey := es1a10_ncPole_addX_key (K := K) (F := F) hξ0 heqp heqf hΛ
+  have h4 : Λ * (1 - ξf * ξp⁻¹) = (ηp - ηf) * ξp⁻¹ := by
+    linear_combination ξp⁻¹ * hΛ - Λ * hξw
+  have hmaster : (Λ * (Λ ^ 2 + algebraMap K F a₁ * Λ - algebraMap K F a₂ - ξp - ξf - ξf)
+        + (ηf + ηf + algebraMap K F a₁ * ξf + algebraMap K F a₃))
+        * (1 - ξf * ξp⁻¹) ^ 3
+      = (ηf + ηf + algebraMap K F a₁ * ξf + algebraMap K F a₃)
+          * ((-(ηp ^ 2 * ξp⁻¹ ^ 3) + (ηp * ξp⁻¹ ^ 2) * (ηf * ξp⁻¹))
+            + (1 - ξf * ξp⁻¹) ^ 3)
+        + ((ηp * ξp⁻¹ ^ 2)
+            * ((3 * ξf ^ 2 + 2 * algebraMap K F a₂ * ξf + algebraMap K F a₄
+                - algebraMap K F a₁ * ηf)
+              + ξp⁻¹ * (- ξf ^ 3 + algebraMap K F a₄ * ξf + 2 * algebraMap K F a₆
+                - algebraMap K F a₃ * ηf))
+          - ηf * (ξp⁻¹ ^ 2 * (3 * ξf ^ 2 + 2 * algebraMap K F a₂ * ξf
+                + algebraMap K F a₄ - algebraMap K F a₁ * ηf)
+              + ξp⁻¹ ^ 3 * (- ξf ^ 3 + algebraMap K F a₄ * ξf
+                + 2 * algebraMap K F a₆ - algebraMap K F a₃ * ηf))) := by
+    rw [show (Λ * (Λ ^ 2 + algebraMap K F a₁ * Λ - algebraMap K F a₂ - ξp - ξf - ξf)
+          + (ηf + ηf + algebraMap K F a₁ * ξf + algebraMap K F a₃))
+          * (1 - ξf * ξp⁻¹) ^ 3
+        = (Λ * (1 - ξf * ξp⁻¹))
+            * ((Λ ^ 2 + algebraMap K F a₁ * Λ - algebraMap K F a₂ - ξp - ξf - ξf)
+              * (1 - ξf * ξp⁻¹) ^ 2)
+          + (ηf + ηf + algebraMap K F a₁ * ξf + algebraMap K F a₃)
+            * (1 - ξf * ξp⁻¹) ^ 3 by ring]
+    rw [h4, hkey]
+    ring
+  have hu₂cube : es1a10_ncPole_reducesTo v ((1 - ξf * ξp⁻¹) ^ 3) 1 := by
+    rw [show ((1 : F) - ξf * ξp⁻¹) ^ 3
+        = ((1 - ξf * ξp⁻¹) * (1 - ξf * ξp⁻¹)) * (1 - ξf * ξp⁻¹) by ring]
+    have h := es1a10_ncPole_reducesTo_mul v
+      (es1a10_ncPole_reducesTo_mul v hu₂red hu₂red) hu₂red
+    simpa using h
+  have hbr : es1a10_ncPole_reducesTo v
+      (-(ηp ^ 2 * ξp⁻¹ ^ 3) + (ηp * ξp⁻¹ ^ 2) * (ηf * ξp⁻¹)) (-1) := by
+    have h1 := es1a10_ncPole_reducesTo_neg v hηsq
+    have h2 : es1a10_ncPole_reducesTo v ((ηp * ξp⁻¹ ^ 2) * (ηf * ξp⁻¹)) 0 :=
+      es1a10_ncPole_reducesTo_zero v
+        (es1a10_ncPole_vanishesAt_mul_mem v hηw2 (mul_mem hyf hwmem))
+    have h := es1a10_ncPole_reducesTo_add v h1 h2
+    simpa using h
+  have hbu : es1a10_ncPole_vanishesAt v
+      ((-(ηp ^ 2 * ξp⁻¹ ^ 3) + (ηp * ξp⁻¹ ^ 2) * (ηf * ξp⁻¹))
+        + (1 - ξf * ξp⁻¹) ^ 3) := by
+    have h := es1a10_ncPole_reducesTo_add v hbr hu₂cube
+    exact es1a10_ncPole_vanishesAt_of_reducesTo_zero v (by simpa using h)
+  have hw2van : es1a10_ncPole_vanishesAt v (ξp⁻¹ ^ 2) := by
+    rw [pow_two]
+    exact es1a10_ncPole_vanishesAt_mul_mem v hwvan hwmem
+  have hw3van : es1a10_ncPole_vanishesAt v (ξp⁻¹ ^ 3) := by
+    rw [pow_succ]
+    exact es1a10_ncPole_vanishesAt_mul_mem v hw2van hwmem
+  have hAmem : 3 * ξf ^ 2 + 2 * algebraMap K F a₂ * ξf + algebraMap K F a₄
+      - algebraMap K F a₁ * ηf ∈ v.toValuationSubring :=
+    sub_mem (add_mem (add_mem (mul_mem h3mem (pow_mem hxf 2))
+      (mul_mem (mul_mem h2mem (v.algebraMap_mem' a₂)) hxf)) (v.algebraMap_mem' a₄))
+      (mul_mem (v.algebraMap_mem' a₁) hyf)
+  have hBmem : - ξf ^ 3 + algebraMap K F a₄ * ξf + 2 * algebraMap K F a₆
+      - algebraMap K F a₃ * ηf ∈ v.toValuationSubring :=
+    sub_mem (add_mem (add_mem (neg_mem (pow_mem hxf 3))
+      (mul_mem (v.algebraMap_mem' a₄) hxf)) (mul_mem h2mem (v.algebraMap_mem' a₆)))
+      (mul_mem (v.algebraMap_mem' a₃) hyf)
+  have hrest : es1a10_ncPole_vanishesAt v
+      ((ηp * ξp⁻¹ ^ 2)
+          * ((3 * ξf ^ 2 + 2 * algebraMap K F a₂ * ξf + algebraMap K F a₄
+              - algebraMap K F a₁ * ηf)
+            + ξp⁻¹ * (- ξf ^ 3 + algebraMap K F a₄ * ξf + 2 * algebraMap K F a₆
+              - algebraMap K F a₃ * ηf))
+        - ηf * (ξp⁻¹ ^ 2 * (3 * ξf ^ 2 + 2 * algebraMap K F a₂ * ξf
+              + algebraMap K F a₄ - algebraMap K F a₁ * ηf)
+            + ξp⁻¹ ^ 3 * (- ξf ^ 3 + algebraMap K F a₄ * ξf
+              + 2 * algebraMap K F a₆ - algebraMap K F a₃ * ηf))) :=
+    es1a10_ncPole_vanishesAt_sub v
+      (es1a10_ncPole_vanishesAt_mul_mem v hηw2
+        (add_mem hAmem (mul_mem hwmem hBmem)))
+      (es1a10_ncPole_vanishesAt_mem_mul v hyf
+        (es1a10_ncPole_vanishesAt_add v
+          (es1a10_ncPole_vanishesAt_mul_mem v hw2van hAmem)
+          (es1a10_ncPole_vanishesAt_mul_mem v hw3van hBmem)))
+  have hBfmem : ηf + ηf + algebraMap K F a₁ * ξf + algebraMap K F a₃
+      ∈ v.toValuationSubring :=
+    add_mem (add_mem (add_mem hyf hyf) (mul_mem (v.algebraMap_mem' a₁) hxf))
+      (v.algebraMap_mem' a₃)
+  have hRHS := es1a10_ncPole_vanishesAt_add v
+    (es1a10_ncPole_vanishesAt_mem_mul v hBfmem hbu) hrest
+  have hinvmem : (((1 : F) - ξf * ξp⁻¹) ^ 3)⁻¹ ∈ v.toValuationSubring :=
+    es1a10_ncPole_mem_of_reducesTo v
+      (es1a10_ncPole_reducesTo_inv v hu₂cube one_ne_zero)
+  have hfin : Λ * (Λ ^ 2 + algebraMap K F a₁ * Λ - algebraMap K F a₂ - ξp - ξf - ξf)
+        + (ηf + ηf + algebraMap K F a₁ * ξf + algebraMap K F a₃)
+      = ((ηf + ηf + algebraMap K F a₁ * ξf + algebraMap K F a₃)
+          * ((-(ηp ^ 2 * ξp⁻¹ ^ 3) + (ηp * ξp⁻¹ ^ 2) * (ηf * ξp⁻¹))
+            + (1 - ξf * ξp⁻¹) ^ 3)
+        + ((ηp * ξp⁻¹ ^ 2)
+            * ((3 * ξf ^ 2 + 2 * algebraMap K F a₂ * ξf + algebraMap K F a₄
+                - algebraMap K F a₁ * ηf)
+              + ξp⁻¹ * (- ξf ^ 3 + algebraMap K F a₄ * ξf + 2 * algebraMap K F a₆
+                - algebraMap K F a₃ * ηf))
+          - ηf * (ξp⁻¹ ^ 2 * (3 * ξf ^ 2 + 2 * algebraMap K F a₂ * ξf
+                + algebraMap K F a₄ - algebraMap K F a₁ * ηf)
+              + ξp⁻¹ ^ 3 * (- ξf ^ 3 + algebraMap K F a₄ * ξf
+                + 2 * algebraMap K F a₆ - algebraMap K F a₃ * ηf))))
+        * (((1 : F) - ξf * ξp⁻¹) ^ 3)⁻¹ := by
+    rw [← hmaster, mul_inv_cancel_right₀ (pow_ne_zero 3 hu₂0)]
+  rw [hfin]
+  exact es1a10_ncPole_vanishesAt_mul_mem v hRHS hinvmem
+
+end PoleBlock
+
+section PoleSeamEngines
+
+variable {F : Type u} [Field F] {W : WeierstrassCurve.Affine F}
+variable (φ₁ φ₂ : W.FunctionField →ₐ[F] W.FunctionField)
+
+theorem es1a10_ncPole_phi_equation (φ : W.FunctionField →ₐ[F] W.FunctionField) :
+    φ (yGen W) ^ 2
+      + algebraMap F W.FunctionField W.a₁ * φ (polyToFunctionField W X) * φ (yGen W)
+      + algebraMap F W.FunctionField W.a₃ * φ (yGen W)
+    = φ (polyToFunctionField W X) ^ 3
+      + algebraMap F W.FunctionField W.a₂ * φ (polyToFunctionField W X) ^ 2
+      + algebraMap F W.FunctionField W.a₄ * φ (polyToFunctionField W X)
+      + algebraMap F W.FunctionField W.a₆ := by
+  have h := es1a6_add_equation W φ
+  rw [equation_iff] at h
+  simpa only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+    WeierstrassCurve.map_a₄,
+    WeierstrassCurve.map_a₆] using h
+
+variable [IsAlgClosed F]
+
+theorem es1a10_ncPole_addSumY_ne_const
+    (hcol : ¬ es1a6_addCollapse W φ₁ φ₂)
+    (hnc : ∀ c : F, es1a6_addSumX W φ₁ φ₂ ≠ algebraMap F W.FunctionField c) :
+    ∀ d : F, es1a6_addSumY W φ₁ φ₂ ≠ algebraMap F W.FunctionField d := by
+  intro d hd
+  have heq := es1a6_addSum_equation W φ₁ φ₂ hcol
+  rw [equation_iff'] at heq
+  simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+    WeierstrassCurve.map_a₄,
+    WeierstrassCurve.map_a₆] at heq
+  rw [hd] at heq
+  have hq0 : (X ^ 3 + C W.a₂ * X ^ 2 + C (W.a₄ - W.a₁ * d) * X
+      + C (W.a₆ - d ^ 2 - W.a₃ * d) : F[X]) ≠ 0 := by
+    intro hq
+    have h3 := congrArg (fun q => Polynomial.coeff q 3) hq
+    simp only [Polynomial.coeff_add, Polynomial.coeff_X_pow, Polynomial.coeff_C_mul,
+      Polynomial.coeff_C, Polynomial.coeff_X, Polynomial.coeff_zero] at h3
+    norm_num at h3
+  have halgX : IsAlgebraic F (es1a6_addSumX W φ₁ φ₂) := by
+    refine ⟨X ^ 3 + C W.a₂ * X ^ 2 + C (W.a₄ - W.a₁ * d) * X
+      + C (W.a₆ - d ^ 2 - W.a₃ * d), hq0, ?_⟩
+    simp only [map_add, map_sub, map_mul, map_pow, Polynomial.aeval_X,
+      Polynomial.aeval_C]
+    linear_combination -heq
+  exact es1a6_add_sumX_transcendental_of_forall_ne W φ₁ φ₂ hnc halgX
+
+theorem es1a10_ncPole_mixedOne_seamData
+    (v : AlgebraicCurve.Place F W.FunctionField)
+    (hcol : ¬ es1a6_addCollapse W φ₁ φ₂)
+    (hnc : ∀ c : F, es1a6_addSumX W φ₁ φ₂ ≠ algebraMap F W.FunctionField c)
+    {c d : F} (h : W.Nonsingular c d)
+    (hpole : φ₁ (polyToFunctionField W X) ∉ v.toValuationSubring)
+    (hx₂ : 0 < v.ord (φ₂ (polyToFunctionField W X) - algebraMap F W.FunctionField c))
+    (hy₂ : 0 < v.ord (φ₂ (yGen W) - algebraMap F W.FunctionField d)) :
+    es1a6_addSumSeamDataAt φ₁ φ₂ v (Point.some c d h) := by
+  classical
+  have heqp := es1a10_ncPole_phi_equation (W := W) φ₁
+  have heqf := es1a10_ncPole_phi_equation (W := W) φ₂
+  have hrx₂ : es1a10_ncPole_reducesTo v (φ₂ (polyToFunctionField W X)) c :=
+    es1a10_ncPole_reducesTo_of_ord_pos v hx₂
+  have hry₂ : es1a10_ncPole_reducesTo v (φ₂ (yGen W)) d :=
+    es1a10_ncPole_reducesTo_of_ord_pos v hy₂
+  have hxf : φ₂ (polyToFunctionField W X) ∈ v.toValuationSubring :=
+    es1a10_ncPole_mem_of_reducesTo v hrx₂
+  have hyf : φ₂ (yGen W) ∈ v.toValuationSubring :=
+    es1a10_ncPole_mem_of_reducesTo v hry₂
+  have hne : φ₁ (polyToFunctionField W X) ≠ φ₂ (polyToFunctionField W X) :=
+    fun hcon => hpole (by rw [hcon]; exact hxf)
+  have hδ0 : φ₁ (polyToFunctionField W X) - φ₂ (polyToFunctionField W X) ≠ 0 :=
+    sub_ne_zero.mpr hne
+  have hsl : (W.map (algebraMap F W.FunctionField)).toAffine.slope
+      (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+      (φ₁ (yGen W)) (φ₂ (yGen W))
+      = (φ₁ (yGen W) - φ₂ (yGen W))
+        / (φ₁ (polyToFunctionField W X) - φ₂ (polyToFunctionField W X)) :=
+    slope_of_X_ne hne
+  have hΛ : (W.map (algebraMap F W.FunctionField)).toAffine.slope
+        (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+        (φ₁ (yGen W)) (φ₂ (yGen W))
+      * (φ₁ (polyToFunctionField W X) - φ₂ (polyToFunctionField W X))
+      = φ₁ (yGen W) - φ₂ (yGen W) := by
+    rw [hsl]
+    exact div_mul_cancel₀ _ hδ0
+  have hXcore := es1a10_ncPole_addX_core v heqp heqf hpole hxf hyf hΛ
+  have hYcore := es1a10_ncPole_addY_core v heqp heqf hpole hxf hyf hΛ
+  have hXred : es1a10_ncPole_reducesTo v (es1a6_addSumX W φ₁ φ₂) c := by
+    change es1a10_ncPole_vanishesAt v
+      (es1a6_addSumX W φ₁ φ₂ - algebraMap F W.FunctionField c)
+    have hid : es1a6_addSumX W φ₁ φ₂ - algebraMap F W.FunctionField c
+        = ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+              (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+              (φ₁ (yGen W)) (φ₂ (yGen W)) ^ 2
+            + algebraMap F W.FunctionField W.a₁
+              * (W.map (algebraMap F W.FunctionField)).toAffine.slope
+                (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+                (φ₁ (yGen W)) (φ₂ (yGen W))
+            - algebraMap F W.FunctionField W.a₂
+            - φ₁ (polyToFunctionField W X) - φ₂ (polyToFunctionField W X)
+            - φ₂ (polyToFunctionField W X))
+          + (φ₂ (polyToFunctionField W X) - algebraMap F W.FunctionField c) := by
+      rw [show es1a6_addSumX W φ₁ φ₂
+          = (W.map (algebraMap F W.FunctionField)).toAffine.addX
+            (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+            ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+              (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+              (φ₁ (yGen W)) (φ₂ (yGen W))) from rfl]
+      simp only [addX, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂]
+      ring
+    rw [hid]
+    exact es1a10_ncPole_vanishesAt_add v hXcore hrx₂
+  have hYred : es1a10_ncPole_reducesTo v (es1a6_addSumY W φ₁ φ₂) d := by
+    change es1a10_ncPole_vanishesAt v
+      (es1a6_addSumY W φ₁ φ₂ - algebraMap F W.FunctionField d)
+    have hid : es1a6_addSumY W φ₁ φ₂ - algebraMap F W.FunctionField d
+        = -((W.map (algebraMap F W.FunctionField)).toAffine.slope
+              (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+              (φ₁ (yGen W)) (φ₂ (yGen W))
+            * ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+                  (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+                  (φ₁ (yGen W)) (φ₂ (yGen W)) ^ 2
+                + algebraMap F W.FunctionField W.a₁
+                  * (W.map (algebraMap F W.FunctionField)).toAffine.slope
+                    (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+                    (φ₁ (yGen W)) (φ₂ (yGen W))
+                - algebraMap F W.FunctionField W.a₂
+                - φ₁ (polyToFunctionField W X) - φ₂ (polyToFunctionField W X)
+                - φ₂ (polyToFunctionField W X))
+            + (φ₂ (yGen W) + φ₂ (yGen W)
+              + algebraMap F W.FunctionField W.a₁ * φ₂ (polyToFunctionField W X)
+              + algebraMap F W.FunctionField W.a₃))
+          + (φ₂ (yGen W) - algebraMap F W.FunctionField d)
+          - algebraMap F W.FunctionField W.a₁
+            * ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+                  (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+                  (φ₁ (yGen W)) (φ₂ (yGen W)) ^ 2
+                + algebraMap F W.FunctionField W.a₁
+                  * (W.map (algebraMap F W.FunctionField)).toAffine.slope
+                    (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+                    (φ₁ (yGen W)) (φ₂ (yGen W))
+                - algebraMap F W.FunctionField W.a₂
+                - φ₁ (polyToFunctionField W X) - φ₂ (polyToFunctionField W X)
+                - φ₂ (polyToFunctionField W X)) := by
+      rw [show es1a6_addSumY W φ₁ φ₂
+          = (W.map (algebraMap F W.FunctionField)).toAffine.addY
+            (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+            (φ₁ (yGen W))
+            ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+              (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+              (φ₁ (yGen W)) (φ₂ (yGen W))) from rfl]
+      simp only [addY, negAddY, addX, negY, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂,
+        WeierstrassCurve.map_a₃]
+      linear_combination hΛ
+    rw [hid]
+    exact es1a10_ncPole_vanishesAt_sub v
+      (es1a10_ncPole_vanishesAt_add v (es1a10_ncPole_vanishesAt_neg v hYcore) hry₂)
+      (es1a10_ncPole_vanishesAt_mem_mul v (v.algebraMap_mem' W.a₁) hXcore)
+  exact ⟨es1a10_ncPole_ord_pos_of_reducesTo_of_ne v hXred (hnc c),
+    es1a10_ncPole_ord_pos_of_reducesTo_of_ne v hYred
+      (es1a10_ncPole_addSumY_ne_const φ₁ φ₂ hcol hnc d)⟩
+
+theorem es1a10_ncPole_mixedTwo_seamData (v : AlgebraicCurve.Place F W.FunctionField)
+    (hcol : ¬ es1a6_addCollapse W φ₁ φ₂)
+    (hnc : ∀ c : F, es1a6_addSumX W φ₁ φ₂ ≠ algebraMap F W.FunctionField c)
+    {c d : F} (h : W.Nonsingular c d)
+    (hpole : φ₂ (polyToFunctionField W X) ∉ v.toValuationSubring)
+    (hx₁ : 0 < v.ord (φ₁ (polyToFunctionField W X) - algebraMap F W.FunctionField c))
+    (hy₁ : 0 < v.ord (φ₁ (yGen W) - algebraMap F W.FunctionField d)) :
+    es1a6_addSumSeamDataAt φ₁ φ₂ v (Point.some c d h) := by
+  have heqp := es1a10_ncPole_phi_equation (W := W) φ₂
+  have heqf := es1a10_ncPole_phi_equation (W := W) φ₁
+  have hrx₁ : es1a10_ncPole_reducesTo v (φ₁ (polyToFunctionField W X)) c :=
+    es1a10_ncPole_reducesTo_of_ord_pos v hx₁
+  have hry₁ : es1a10_ncPole_reducesTo v (φ₁ (yGen W)) d :=
+    es1a10_ncPole_reducesTo_of_ord_pos v hy₁
+  have hxf : φ₁ (polyToFunctionField W X) ∈ v.toValuationSubring :=
+    es1a10_ncPole_mem_of_reducesTo v hrx₁
+  have hyf : φ₁ (yGen W) ∈ v.toValuationSubring :=
+    es1a10_ncPole_mem_of_reducesTo v hry₁
+  have hne : φ₁ (polyToFunctionField W X) ≠ φ₂ (polyToFunctionField W X) :=
+    fun hcon => hpole (by rw [← hcon]; exact hxf)
+  have hδ0 : φ₁ (polyToFunctionField W X) - φ₂ (polyToFunctionField W X) ≠ 0 :=
+    sub_ne_zero.mpr hne
+  have hsl : (W.map (algebraMap F W.FunctionField)).toAffine.slope
+      (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+      (φ₁ (yGen W)) (φ₂ (yGen W))
+      = (φ₁ (yGen W) - φ₂ (yGen W))
+        / (φ₁ (polyToFunctionField W X) - φ₂ (polyToFunctionField W X)) :=
+    slope_of_X_ne hne
+  have hΛ : (W.map (algebraMap F W.FunctionField)).toAffine.slope
+        (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+        (φ₁ (yGen W)) (φ₂ (yGen W))
+      * (φ₂ (polyToFunctionField W X) - φ₁ (polyToFunctionField W X))
+      = φ₂ (yGen W) - φ₁ (yGen W) := by
+    rw [hsl, div_mul_eq_mul_div, div_eq_iff hδ0]
+    ring
+  have hXcore := es1a10_ncPole_addX_core v heqp heqf hpole hxf hyf hΛ
+  have hYcore := es1a10_ncPole_addY_core v heqp heqf hpole hxf hyf hΛ
+  have hXred : es1a10_ncPole_reducesTo v (es1a6_addSumX W φ₁ φ₂) c := by
+    change es1a10_ncPole_vanishesAt v
+      (es1a6_addSumX W φ₁ φ₂ - algebraMap F W.FunctionField c)
+    have hid : es1a6_addSumX W φ₁ φ₂ - algebraMap F W.FunctionField c
+        = ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+              (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+              (φ₁ (yGen W)) (φ₂ (yGen W)) ^ 2
+            + algebraMap F W.FunctionField W.a₁
+              * (W.map (algebraMap F W.FunctionField)).toAffine.slope
+                (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+                (φ₁ (yGen W)) (φ₂ (yGen W))
+            - algebraMap F W.FunctionField W.a₂
+            - φ₂ (polyToFunctionField W X) - φ₁ (polyToFunctionField W X)
+            - φ₁ (polyToFunctionField W X))
+          + (φ₁ (polyToFunctionField W X) - algebraMap F W.FunctionField c) := by
+      rw [show es1a6_addSumX W φ₁ φ₂
+          = (W.map (algebraMap F W.FunctionField)).toAffine.addX
+            (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+            ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+              (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+              (φ₁ (yGen W)) (φ₂ (yGen W))) from rfl]
+      simp only [addX, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂]
+      ring
+    rw [hid]
+    exact es1a10_ncPole_vanishesAt_add v hXcore hrx₁
+  have hYred : es1a10_ncPole_reducesTo v (es1a6_addSumY W φ₁ φ₂) d := by
+    change es1a10_ncPole_vanishesAt v
+      (es1a6_addSumY W φ₁ φ₂ - algebraMap F W.FunctionField d)
+    have hid : es1a6_addSumY W φ₁ φ₂ - algebraMap F W.FunctionField d
+        = -((W.map (algebraMap F W.FunctionField)).toAffine.slope
+              (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+              (φ₁ (yGen W)) (φ₂ (yGen W))
+            * ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+                  (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+                  (φ₁ (yGen W)) (φ₂ (yGen W)) ^ 2
+                + algebraMap F W.FunctionField W.a₁
+                  * (W.map (algebraMap F W.FunctionField)).toAffine.slope
+                    (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+                    (φ₁ (yGen W)) (φ₂ (yGen W))
+                - algebraMap F W.FunctionField W.a₂
+                - φ₂ (polyToFunctionField W X) - φ₁ (polyToFunctionField W X)
+                - φ₁ (polyToFunctionField W X))
+            + (φ₁ (yGen W) + φ₁ (yGen W)
+              + algebraMap F W.FunctionField W.a₁ * φ₁ (polyToFunctionField W X)
+              + algebraMap F W.FunctionField W.a₃))
+          + (φ₁ (yGen W) - algebraMap F W.FunctionField d)
+          - algebraMap F W.FunctionField W.a₁
+            * ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+                  (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+                  (φ₁ (yGen W)) (φ₂ (yGen W)) ^ 2
+                + algebraMap F W.FunctionField W.a₁
+                  * (W.map (algebraMap F W.FunctionField)).toAffine.slope
+                    (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+                    (φ₁ (yGen W)) (φ₂ (yGen W))
+                - algebraMap F W.FunctionField W.a₂
+                - φ₂ (polyToFunctionField W X) - φ₁ (polyToFunctionField W X)
+                - φ₁ (polyToFunctionField W X)) := by
+      rw [show es1a6_addSumY W φ₁ φ₂
+          = (W.map (algebraMap F W.FunctionField)).toAffine.addY
+            (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+            (φ₁ (yGen W))
+            ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+              (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+              (φ₁ (yGen W)) (φ₂ (yGen W))) from rfl]
+      simp only [addY, negAddY, addX, negY, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂,
+        WeierstrassCurve.map_a₃]
+      ring
+    rw [hid]
+    exact es1a10_ncPole_vanishesAt_sub v
+      (es1a10_ncPole_vanishesAt_add v (es1a10_ncPole_vanishesAt_neg v hYcore) hry₁)
+      (es1a10_ncPole_vanishesAt_mem_mul v (v.algebraMap_mem' W.a₁) hXcore)
+  exact ⟨es1a10_ncPole_ord_pos_of_reducesTo_of_ne v hXred (hnc c),
+    es1a10_ncPole_ord_pos_of_reducesTo_of_ne v hYred
+      (es1a10_ncPole_addSumY_ne_const φ₁ φ₂ hcol hnc d)⟩
+
+omit [IsAlgClosed F] in
+theorem es1a10_ncPole_bothPole_notMem (v : AlgebraicCurve.Place F W.FunctionField)
+    (hΔ : W.Δ ≠ 0)
+    (hcol : ¬ es1a6_addCollapse W φ₁ φ₂)
+    (hpole₁ : φ₁ (polyToFunctionField W X) ∉ v.toValuationSubring)
+    (hpole₂ : φ₂ (polyToFunctionField W X) ∉ v.toValuationSubring) :
+    es1a6_addSumX W φ₁ φ₂ ∉ v.toValuationSubring := by
+  intro hmem
+  have heq₃ := es1a6_addSum_equation W φ₁ φ₂ hcol
+  rw [equation_iff] at heq₃
+  simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+    WeierstrassCurve.map_a₄,
+    WeierstrassCurve.map_a₆] at heq₃
+  have hy₃mem : es1a6_addSumY W φ₁ φ₂ ∈ v.toValuationSubring := by
+    by_contra hy
+    have hy0 : es1a6_addSumY W φ₁ φ₂ ≠ 0 := fun h0 => hy (by rw [h0]; exact zero_mem _)
+    have hyord : v.ord (es1a6_addSumY W φ₁ φ₂) < 0 := by
+      by_contra hge
+      exact hy (v.mem_of_ord_nonneg hy0 (not_lt.mp hge))
+    have hsmem : algebraMap F W.FunctionField W.a₁ * es1a6_addSumX W φ₁ φ₂
+        + algebraMap F W.FunctionField W.a₃ ∈ v.toValuationSubring :=
+      add_mem (mul_mem (v.algebraMap_mem' W.a₁) hmem) (v.algebraMap_mem' W.a₃)
+    have hS0 : es1a6_addSumY W φ₁ φ₂
+        + (algebraMap F W.FunctionField W.a₁ * es1a6_addSumX W φ₁ φ₂
+          + algebraMap F W.FunctionField W.a₃) ≠ 0 := by
+      intro hcon
+      apply hy
+      have hyeq : es1a6_addSumY W φ₁ φ₂
+          = -(algebraMap F W.FunctionField W.a₁ * es1a6_addSumX W φ₁ φ₂
+            + algebraMap F W.FunctionField W.a₃) := by
+        linear_combination hcon
+      rw [hyeq]
+      exact neg_mem hsmem
+    have hSord : v.ord (es1a6_addSumY W φ₁ φ₂
+        + (algebraMap F W.FunctionField W.a₁ * es1a6_addSumX W φ₁ φ₂
+          + algebraMap F W.FunctionField W.a₃)) < 0 := by
+      rcases eq_or_ne (algebraMap F W.FunctionField W.a₁ * es1a6_addSumX W φ₁ φ₂
+          + algebraMap F W.FunctionField W.a₃) 0 with hz | hz
+      · rw [hz, add_zero]
+        exact hyord
+      · have hsord := v.ord_nonneg_of_mem hsmem
+        rw [v.ord_add_eq_min hy0 hz (by omega)]
+        omega
+    have hprodeq : es1a6_addSumY W φ₁ φ₂
+        * (es1a6_addSumY W φ₁ φ₂
+          + (algebraMap F W.FunctionField W.a₁ * es1a6_addSumX W φ₁ φ₂
+            + algebraMap F W.FunctionField W.a₃))
+        = es1a6_addSumX W φ₁ φ₂ ^ 3
+          + algebraMap F W.FunctionField W.a₂ * es1a6_addSumX W φ₁ φ₂ ^ 2
+          + algebraMap F W.FunctionField W.a₄ * es1a6_addSumX W φ₁ φ₂
+          + algebraMap F W.FunctionField W.a₆ := by
+      linear_combination heq₃
+    have hRmem : es1a6_addSumX W φ₁ φ₂ ^ 3
+        + algebraMap F W.FunctionField W.a₂ * es1a6_addSumX W φ₁ φ₂ ^ 2
+        + algebraMap F W.FunctionField W.a₄ * es1a6_addSumX W φ₁ φ₂
+        + algebraMap F W.FunctionField W.a₆ ∈ v.toValuationSubring :=
+      add_mem (add_mem (add_mem (pow_mem hmem 3)
+        (mul_mem (v.algebraMap_mem' W.a₂) (pow_mem hmem 2)))
+        (mul_mem (v.algebraMap_mem' W.a₄) hmem)) (v.algebraMap_mem' W.a₆)
+    have hLord : (0 : ℤ) ≤ v.ord (es1a6_addSumY W φ₁ φ₂
+        * (es1a6_addSumY W φ₁ φ₂
+          + (algebraMap F W.FunctionField W.a₁ * es1a6_addSumX W φ₁ φ₂
+            + algebraMap F W.FunctionField W.a₃))) := by
+      rw [hprodeq]
+      exact v.ord_nonneg_of_mem hRmem
+    rw [v.ord_mul hy0 hS0] at hLord
+    omega
+  have h₁L := es1a6_add_nonsingular W hΔ φ₁
+  have h₂L := es1a6_add_nonsingular W hΔ φ₂
+  have h₃L := es1a6_addSum_nonsingular W φ₁ φ₂ hΔ hcol
+  have hadd9 : Point.some _ _ h₁L + Point.some _ _ h₂L
+      = Point.some (es1a6_addSumX W φ₁ φ₂) (es1a6_addSumY W φ₁ φ₂) h₃L :=
+    Point.add_some (h₁ := h₁L) (h₂ := h₂L) hcol
+  have hgrp : Point.some (es1a6_addSumX W φ₁ φ₂) (es1a6_addSumY W φ₁ φ₂) h₃L
+      + -(Point.some _ _ h₁L) = Point.some _ _ h₂L := by
+    rw [← hadd9, add_comm (Point.some _ _ h₁L) (Point.some _ _ h₂L),
+      add_neg_cancel_right]
+  rw [Point.neg_some] at hgrp
+  have hne₃₁ : es1a6_addSumX W φ₁ φ₂ ≠ φ₁ (polyToFunctionField W X) :=
+    fun hcon => hpole₁ (by rw [← hcon]; exact hmem)
+  rw [Point.add_of_X_ne hne₃₁] at hgrp
+  rw [Point.some.injEq] at hgrp
+  obtain ⟨hx2eq, -⟩ := hgrp
+  have heq₁ := es1a10_ncPole_phi_equation (W := W) φ₁
+  have hnegYdef : (W.map (algebraMap F W.FunctionField)).toAffine.negY
+      (φ₁ (polyToFunctionField W X)) (φ₁ (yGen W))
+      = -φ₁ (yGen W)
+        - algebraMap F W.FunctionField W.a₁ * φ₁ (polyToFunctionField W X)
+        - algebraMap F W.FunctionField W.a₃ := by
+    simp only [negY, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₃]
+  have heqp' : (W.map (algebraMap F W.FunctionField)).toAffine.negY
+        (φ₁ (polyToFunctionField W X)) (φ₁ (yGen W)) ^ 2
+      + algebraMap F W.FunctionField W.a₁ * φ₁ (polyToFunctionField W X)
+        * (W.map (algebraMap F W.FunctionField)).toAffine.negY
+          (φ₁ (polyToFunctionField W X)) (φ₁ (yGen W))
+      + algebraMap F W.FunctionField W.a₃
+        * (W.map (algebraMap F W.FunctionField)).toAffine.negY
+          (φ₁ (polyToFunctionField W X)) (φ₁ (yGen W))
+      = φ₁ (polyToFunctionField W X) ^ 3
+        + algebraMap F W.FunctionField W.a₂ * φ₁ (polyToFunctionField W X) ^ 2
+        + algebraMap F W.FunctionField W.a₄ * φ₁ (polyToFunctionField W X)
+        + algebraMap F W.FunctionField W.a₆ := by
+    rw [hnegYdef]
+    linear_combination heq₁
+  have heqf₃ : es1a6_addSumY W φ₁ φ₂ ^ 2
+      + algebraMap F W.FunctionField W.a₁ * es1a6_addSumX W φ₁ φ₂
+        * es1a6_addSumY W φ₁ φ₂
+      + algebraMap F W.FunctionField W.a₃ * es1a6_addSumY W φ₁ φ₂
+      = es1a6_addSumX W φ₁ φ₂ ^ 3
+        + algebraMap F W.FunctionField W.a₂ * es1a6_addSumX W φ₁ φ₂ ^ 2
+        + algebraMap F W.FunctionField W.a₄ * es1a6_addSumX W φ₁ φ₂
+        + algebraMap F W.FunctionField W.a₆ := by
+    have h := es1a6_addSum_equation W φ₁ φ₂ hcol
+    rw [equation_iff] at h
+    simpa only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+      WeierstrassCurve.map_a₄,
+      WeierstrassCurve.map_a₆] using h
+  have hsl₃ : (W.map (algebraMap F W.FunctionField)).toAffine.slope
+      (es1a6_addSumX W φ₁ φ₂) (φ₁ (polyToFunctionField W X))
+      (es1a6_addSumY W φ₁ φ₂)
+      ((W.map (algebraMap F W.FunctionField)).toAffine.negY
+        (φ₁ (polyToFunctionField W X)) (φ₁ (yGen W)))
+      = (es1a6_addSumY W φ₁ φ₂
+          - (W.map (algebraMap F W.FunctionField)).toAffine.negY
+            (φ₁ (polyToFunctionField W X)) (φ₁ (yGen W)))
+        / (es1a6_addSumX W φ₁ φ₂ - φ₁ (polyToFunctionField W X)) :=
+    slope_of_X_ne hne₃₁
+  have hΛ₃ : (W.map (algebraMap F W.FunctionField)).toAffine.slope
+        (es1a6_addSumX W φ₁ φ₂) (φ₁ (polyToFunctionField W X))
+        (es1a6_addSumY W φ₁ φ₂)
+        ((W.map (algebraMap F W.FunctionField)).toAffine.negY
+          (φ₁ (polyToFunctionField W X)) (φ₁ (yGen W)))
+      * (φ₁ (polyToFunctionField W X) - es1a6_addSumX W φ₁ φ₂)
+      = (W.map (algebraMap F W.FunctionField)).toAffine.negY
+          (φ₁ (polyToFunctionField W X)) (φ₁ (yGen W))
+        - es1a6_addSumY W φ₁ φ₂ := by
+    rw [hsl₃, div_mul_eq_mul_div, div_eq_iff (sub_ne_zero.mpr hne₃₁)]
+    ring
+  have hXcore := es1a10_ncPole_addX_core v heqp' heqf₃ hpole₁ hmem hy₃mem hΛ₃
+  have hid₂ : φ₂ (polyToFunctionField W X)
+      = ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+            (es1a6_addSumX W φ₁ φ₂) (φ₁ (polyToFunctionField W X))
+            (es1a6_addSumY W φ₁ φ₂)
+            ((W.map (algebraMap F W.FunctionField)).toAffine.negY
+              (φ₁ (polyToFunctionField W X)) (φ₁ (yGen W))) ^ 2
+          + algebraMap F W.FunctionField W.a₁
+            * (W.map (algebraMap F W.FunctionField)).toAffine.slope
+              (es1a6_addSumX W φ₁ φ₂) (φ₁ (polyToFunctionField W X))
+              (es1a6_addSumY W φ₁ φ₂)
+              ((W.map (algebraMap F W.FunctionField)).toAffine.negY
+                (φ₁ (polyToFunctionField W X)) (φ₁ (yGen W)))
+          - algebraMap F W.FunctionField W.a₂
+          - φ₁ (polyToFunctionField W X) - es1a6_addSumX W φ₁ φ₂
+          - es1a6_addSumX W φ₁ φ₂)
+        + es1a6_addSumX W φ₁ φ₂ := by
+    rw [← hx2eq]
+    simp only [addX, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂]
+    ring
+  apply hpole₂
+  rw [hid₂]
+  exact add_mem (es1a10_ncPole_mem_of_vanishesAt v hXcore) hmem
+
+end PoleSeamEngines
+
+end Es1a1
+end ModularCurve
+
+end
+
+section
+
+namespace ModularCurve
+namespace Es1a1
+
+universe u
+
+section VanishingCalculusNcVertical
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : AlgebraicCurve.Place K F)
+
+theorem es1a10_ncVertical_ord_algebraMap (c : K) :
+    v.ord (algebraMap K F c) = 0 := by
+  rcases eq_or_ne c 0 with rfl | hc
+  · simp
+  have hmem : algebraMap K F c ∈ v.toValuationSubring := v.algebraMap_mem' c
+  have hmem' : (algebraMap K F c)⁻¹ ∈ v.toValuationSubring := by
+    rw [← map_inv₀]
+    exact v.algebraMap_mem' c⁻¹
+  have h1 := v.ord_nonneg_of_mem hmem
+  have h2 := v.ord_nonneg_of_mem hmem'
+  rw [v.ord_inv] at h2
+  omega
+
+theorem es1a10_ncVertical_ord_neg (f : F) : v.ord (-f) = v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · simp
+  have h1 : (-f : F) = algebraMap K F (-1) * f := by
+    rw [_root_.map_neg, map_one]
+    ring
+  have hne : (algebraMap K F (-1 : K)) ≠ 0 := by
+    rw [_root_.map_neg, map_one]
+    exact neg_ne_zero.mpr one_ne_zero
+  rw [h1, v.ord_mul hne hf, es1a10_ncVertical_ord_algebraMap, zero_add]
+
+def es1a10_ncVertical_vanishesAt (f : F) : Prop := f = 0 ∨ 0 < v.ord f
+
+theorem es1a10_ncVertical_vanishesAt_zero :
+    es1a10_ncVertical_vanishesAt v (0 : F) := Or.inl rfl
+
+theorem es1a10_ncVertical_vanishesAt_add {f g : F}
+    (hf : es1a10_ncVertical_vanishesAt v f) (hg : es1a10_ncVertical_vanishesAt v g) :
+    es1a10_ncVertical_vanishesAt v (f + g) := by
+  have hf' : f = 0 ∨ 0 < v.ord f := hf
+  have hg' : g = 0 ∨ 0 < v.ord g := hg
+  rcases hf' with rfl | hf0
+  · rw [zero_add]
+    exact hg
+  rcases hg' with rfl | hg0
+  · rw [add_zero]
+    exact hf
+  rcases eq_or_ne (f + g) 0 with h0 | h0
+  · exact Or.inl h0
+  · refine Or.inr ?_
+    have h1 := v.min_ord_le_ord_add' h0
+    have h2 : (0 : ℤ) < min (v.ord f) (v.ord g) := lt_min hf0 hg0
+    exact h2.trans_le h1
+
+theorem es1a10_ncVertical_vanishesAt_neg {f : F}
+    (hf : es1a10_ncVertical_vanishesAt v f) :
+    es1a10_ncVertical_vanishesAt v (-f) := by
+  have hf' : f = 0 ∨ 0 < v.ord f := hf
+  change -f = 0 ∨ 0 < v.ord (-f)
+  rcases hf' with rfl | hf0
+  · exact Or.inl _root_.neg_zero
+  · refine Or.inr ?_
+    rw [es1a10_ncVertical_ord_neg]
+    exact hf0
+
+theorem es1a10_ncVertical_vanishesAt_sub {f g : F}
+    (hf : es1a10_ncVertical_vanishesAt v f) (hg : es1a10_ncVertical_vanishesAt v g) :
+    es1a10_ncVertical_vanishesAt v (f - g) := by
+  rw [sub_eq_add_neg]
+  exact es1a10_ncVertical_vanishesAt_add v hf (es1a10_ncVertical_vanishesAt_neg v hg)
+
+theorem es1a10_ncVertical_vanishesAt_mul_mem {f g : F}
+    (hf : es1a10_ncVertical_vanishesAt v f) (hg : g ∈ v.toValuationSubring) :
+    es1a10_ncVertical_vanishesAt v (f * g) := by
+  have hf' : f = 0 ∨ 0 < v.ord f := hf
+  change f * g = 0 ∨ 0 < v.ord (f * g)
+  rcases hf' with rfl | hf0
+  · exact Or.inl (zero_mul g)
+  rcases eq_or_ne g 0 with rfl | hg0
+  · exact Or.inl (mul_zero f)
+  · refine Or.inr ?_
+    have hf1 : f ≠ 0 := by
+      intro h
+      rw [h, v.ord_zero] at hf0
+      exact lt_irrefl 0 hf0
+    rw [v.ord_mul hf1 hg0]
+    have h2 := v.ord_nonneg_of_mem hg
+    omega
+
+theorem es1a10_ncVertical_vanishesAt_mem_mul {f g : F}
+    (hf : f ∈ v.toValuationSubring) (hg : es1a10_ncVertical_vanishesAt v g) :
+    es1a10_ncVertical_vanishesAt v (f * g) := by
+  rw [mul_comm]
+  exact es1a10_ncVertical_vanishesAt_mul_mem v hg hf
+
+theorem es1a10_ncVertical_mem_of_vanishesAt {f : F}
+    (hf : es1a10_ncVertical_vanishesAt v f) : f ∈ v.toValuationSubring := by
+  have hf' : f = 0 ∨ 0 < v.ord f := hf
+  rcases hf' with rfl | hf0
+  · exact zero_mem _
+  · have hne : f ≠ 0 := by
+      intro h
+      rw [h, v.ord_zero] at hf0
+      exact lt_irrefl 0 hf0
+    exact v.mem_of_ord_nonneg hne hf0.le
+
+def es1a10_ncVertical_reducesTo (f : F) (c : K) : Prop :=
+  es1a10_ncVertical_vanishesAt v (f - algebraMap K F c)
+
+theorem es1a10_ncVertical_reducesTo_of_ord_pos {f : F} {c : K}
+    (h : 0 < v.ord (f - algebraMap K F c)) : es1a10_ncVertical_reducesTo v f c :=
+  Or.inr h
+
+theorem es1a10_ncVertical_reducesTo_algebraMap (c : K) :
+    es1a10_ncVertical_reducesTo v (algebraMap K F c) c := by
+  change es1a10_ncVertical_vanishesAt v (algebraMap K F c - algebraMap K F c)
+  rw [sub_self]
+  exact es1a10_ncVertical_vanishesAt_zero v
+
+theorem es1a10_ncVertical_reducesTo_ofNat (n : ℕ) [Nat.AtLeastTwo n] :
+    es1a10_ncVertical_reducesTo v (OfNat.ofNat n : F) (OfNat.ofNat n : K) := by
+  change es1a10_ncVertical_vanishesAt v
+    ((OfNat.ofNat n : F) - algebraMap K F (OfNat.ofNat n : K))
+  rw [map_ofNat, sub_self]
+  exact es1a10_ncVertical_vanishesAt_zero v
+
+theorem es1a10_ncVertical_reducesTo_add {f g : F} {c d : K}
+    (hf : es1a10_ncVertical_reducesTo v f c) (hg : es1a10_ncVertical_reducesTo v g d) :
+    es1a10_ncVertical_reducesTo v (f + g) (c + d) := by
+  change es1a10_ncVertical_vanishesAt v (f + g - algebraMap K F (c + d))
+  rw [show f + g - algebraMap K F (c + d)
+      = (f - algebraMap K F c) + (g - algebraMap K F d) by rw [map_add]; ring]
+  exact es1a10_ncVertical_vanishesAt_add v hf hg
+
+theorem es1a10_ncVertical_reducesTo_neg {f : F} {c : K}
+    (hf : es1a10_ncVertical_reducesTo v f c) :
+    es1a10_ncVertical_reducesTo v (-f) (-c) := by
+  change es1a10_ncVertical_vanishesAt v (-f - algebraMap K F (-c))
+  rw [show -f - algebraMap K F (-c) = -(f - algebraMap K F c) by rw [_root_.map_neg]; ring]
+  exact es1a10_ncVertical_vanishesAt_neg v hf
+
+theorem es1a10_ncVertical_reducesTo_sub {f g : F} {c d : K}
+    (hf : es1a10_ncVertical_reducesTo v f c) (hg : es1a10_ncVertical_reducesTo v g d) :
+    es1a10_ncVertical_reducesTo v (f - g) (c - d) := by
+  change es1a10_ncVertical_vanishesAt v (f - g - algebraMap K F (c - d))
+  rw [show f - g - algebraMap K F (c - d)
+      = (f - algebraMap K F c) - (g - algebraMap K F d) by rw [map_sub]; ring]
+  exact es1a10_ncVertical_vanishesAt_sub v hf hg
+
+theorem es1a10_ncVertical_mem_of_reducesTo {g : F} {d : K}
+    (hg : es1a10_ncVertical_reducesTo v g d) : g ∈ v.toValuationSubring := by
+  have h1 : g - algebraMap K F d ∈ v.toValuationSubring :=
+    es1a10_ncVertical_mem_of_vanishesAt v hg
+  have h2 := add_mem h1 (v.algebraMap_mem' d)
+  rwa [sub_add_cancel] at h2
+
+theorem es1a10_ncVertical_reducesTo_mul {f g : F} {c d : K}
+    (hf : es1a10_ncVertical_reducesTo v f c) (hg : es1a10_ncVertical_reducesTo v g d) :
+    es1a10_ncVertical_reducesTo v (f * g) (c * d) := by
+  change es1a10_ncVertical_vanishesAt v (f * g - algebraMap K F (c * d))
+  rw [show f * g - algebraMap K F (c * d)
+      = (f - algebraMap K F c) * g
+        + algebraMap K F c * (g - algebraMap K F d) by rw [map_mul]; ring]
+  exact es1a10_ncVertical_vanishesAt_add v
+    (es1a10_ncVertical_vanishesAt_mul_mem v hf (es1a10_ncVertical_mem_of_reducesTo v hg))
+    (es1a10_ncVertical_vanishesAt_mem_mul v (v.algebraMap_mem' c) hg)
+
+theorem es1a10_ncVertical_reducesTo_sq {f : F} {c : K}
+    (hf : es1a10_ncVertical_reducesTo v f c) :
+    es1a10_ncVertical_reducesTo v (f ^ 2) (c ^ 2) := by
+  rw [pow_two, pow_two]
+  exact es1a10_ncVertical_reducesTo_mul v hf hf
+
+theorem es1a10_ncVertical_reducesTo_ord_eq_zero {f : F} {c : K}
+    (hf : es1a10_ncVertical_reducesTo v f c) (hc : c ≠ 0) : f ≠ 0 ∧ v.ord f = 0 := by
+  have hmap0 : algebraMap K F c ≠ 0 := fun h =>
+    hc ((algebraMap K F).injective (by rw [h, _root_.map_zero]))
+  have hf' : f - algebraMap K F c = 0 ∨ 0 < v.ord (f - algebraMap K F c) := hf
+  rcases hf' with h0 | hpos
+  · have hfeq : f = algebraMap K F c := sub_eq_zero.mp h0
+    refine ⟨by rw [hfeq]; exact hmap0, ?_⟩
+    rw [hfeq, es1a10_ncVertical_ord_algebraMap]
+  · have hd0 : f - algebraMap K F c ≠ 0 := by
+      intro h
+      rw [h, v.ord_zero] at hpos
+      exact lt_irrefl 0 hpos
+    have hf0 : f ≠ 0 := by
+      intro h
+      have h1 : f - algebraMap K F c = -(algebraMap K F c) := by rw [h]; ring
+      rw [h1, es1a10_ncVertical_ord_neg, es1a10_ncVertical_ord_algebraMap] at hpos
+      exact lt_irrefl 0 hpos
+    have hsum : algebraMap K F c + (f - algebraMap K F c) = f := by ring
+    have hmin := v.ord_add_eq_min hmap0 hd0 (by
+      rw [es1a10_ncVertical_ord_algebraMap]
+      omega)
+    rw [hsum] at hmin
+    refine ⟨hf0, ?_⟩
+    rw [hmin, es1a10_ncVertical_ord_algebraMap]
+    exact min_eq_left hpos.le
+
+theorem es1a10_ncVertical_ne_of_reducesTo_ne {f g : F} {c d : K}
+    (hf : es1a10_ncVertical_reducesTo v f c) (hg : es1a10_ncVertical_reducesTo v g d)
+    (hcd : c ≠ d) : f ≠ g := by
+  intro hfg
+  have hsub : es1a10_ncVertical_reducesTo v (f - g) (c - d) :=
+    es1a10_ncVertical_reducesTo_sub v hf hg
+  rw [hfg, sub_self] at hsub
+  have hsub' : (0 : F) - algebraMap K F (c - d) = 0 ∨
+      0 < v.ord ((0 : F) - algebraMap K F (c - d)) := hsub
+  rw [zero_sub] at hsub'
+  have hne0 : algebraMap K F (c - d) ≠ 0 := fun h =>
+    sub_ne_zero.mpr hcd ((algebraMap K F).injective (by rw [h, _root_.map_zero]))
+  rcases hsub' with h0 | hpos
+  · exact hne0 (neg_eq_zero.mp h0)
+  · rw [es1a10_ncVertical_ord_neg, es1a10_ncVertical_ord_algebraMap] at hpos
+    exact lt_irrefl 0 hpos
+
+theorem es1a10_ncVertical_vanishesAt_of_reducesTo_zero {f : F} {c : K}
+    (hf : es1a10_ncVertical_reducesTo v f c) (hc : c = 0) :
+    es1a10_ncVertical_vanishesAt v f := by
+  subst hc
+  have hf' : es1a10_ncVertical_vanishesAt v (f - algebraMap K F 0) := hf
+  rwa [_root_.map_zero, sub_zero] at hf'
+
+theorem es1a10_ncVertical_ord_pos_of_vanishesAt_of_ne {f : F}
+    (hf : es1a10_ncVertical_vanishesAt v f) (hne : f ≠ 0) : 0 < v.ord f := by
+  have hf' : f = 0 ∨ 0 < v.ord f := hf
+  rcases hf' with h0 | hpos
+  · exact absurd h0 hne
+  · exact hpos
+
+theorem es1a10_ncVertical_ord_div_neg {f g : F} (hf0 : f ≠ 0) (hford : v.ord f = 0)
+    (hg0 : g ≠ 0) (hgord : 0 < v.ord g) : v.ord (f / g) < 0 := by
+  rw [div_eq_mul_inv, v.ord_mul hf0 (inv_ne_zero hg0), v.ord_inv, hford]
+  omega
+
+end VanishingCalculusNcVertical
+
+section VerticalCaseEngines
+
+variable {F : Type u} [Field F] {W : WeierstrassCurve.Affine F}
+
+local instance instDecEqFunctionFieldEs1a10NcVertical :
+    DecidableEq W.FunctionField :=
+  Classical.decEq _
+
+theorem es1a10_ncVertical_negY_reducesTo (v : AlgebraicCurve.Place F W.FunctionField)
+    {ξ η : W.FunctionField} {c d : F}
+    (hx : es1a10_ncVertical_reducesTo v ξ c) (hy : es1a10_ncVertical_reducesTo v η d) :
+    es1a10_ncVertical_reducesTo v
+      ((W.map (algebraMap F W.FunctionField)).toAffine.negY ξ η) (W.negY c d) := by
+  have h1 : (W.map (algebraMap F W.FunctionField)).toAffine.negY ξ η
+      = -η - algebraMap F W.FunctionField W.a₁ * ξ
+        - algebraMap F W.FunctionField W.a₃ := by
+    simp only [negY, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₃]
+  have h2 : W.negY c d = -d - W.a₁ * c - W.a₃ := by
+    simp only [negY]
+  rw [h1, h2]
+  exact es1a10_ncVertical_reducesTo_sub v
+    (es1a10_ncVertical_reducesTo_sub v (es1a10_ncVertical_reducesTo_neg v hy)
+      (es1a10_ncVertical_reducesTo_mul v
+        (es1a10_ncVertical_reducesTo_algebraMap v W.a₁) hx))
+    (es1a10_ncVertical_reducesTo_algebraMap v W.a₃)
+
+theorem es1a10_ncVertical_nonsingular_certificate {c d : F}
+    (h : W.Nonsingular c d) (h2tor : d = W.negY c d) :
+    3 * c ^ 2 + 2 * W.a₂ * c + W.a₄ - W.a₁ * d ≠ 0 := by
+  rw [nonsingular_iff'] at h
+  rcases h.2 with hX | hY
+  · intro hcon
+    exact hX (by linear_combination -hcon)
+  · exfalso
+    apply hY
+    have h2tor' := h2tor
+    simp only [negY] at h2tor'
+    linear_combination h2tor'
+
+variable (φ₁ φ₂ : W.FunctionField →ₐ[F] W.FunctionField)
+
+theorem es1a10_ncVertical_slope_ord_neg (v : AlgebraicCurve.Place F W.FunctionField)
+    (hcol : ¬ es1a6_addCollapse W φ₁ φ₂)
+    {c d₁ d₂ : F} (h₁ : W.Nonsingular c d₁) (h₂ : W.Nonsingular c d₂)
+    (hopp : d₁ = W.negY c d₂)
+    (hx₁ : 0 < v.ord (φ₁ (polyToFunctionField W X) - algebraMap F W.FunctionField c))
+    (hy₁ : 0 < v.ord (φ₁ (yGen W) - algebraMap F W.FunctionField d₁))
+    (hx₂ : 0 < v.ord (φ₂ (polyToFunctionField W X) - algebraMap F W.FunctionField c))
+    (hy₂ : 0 < v.ord (φ₂ (yGen W) - algebraMap F W.FunctionField d₂)) :
+    v.ord ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+        (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+        (φ₁ (yGen W)) (φ₂ (yGen W))) < 0 := by
+  have hrx₁ : es1a10_ncVertical_reducesTo v (φ₁ (polyToFunctionField W X)) c :=
+    es1a10_ncVertical_reducesTo_of_ord_pos v hx₁
+  have hry₁ : es1a10_ncVertical_reducesTo v (φ₁ (yGen W)) d₁ :=
+    es1a10_ncVertical_reducesTo_of_ord_pos v hy₁
+  have hrx₂ : es1a10_ncVertical_reducesTo v (φ₂ (polyToFunctionField W X)) c :=
+    es1a10_ncVertical_reducesTo_of_ord_pos v hx₂
+  have hry₂ : es1a10_ncVertical_reducesTo v (φ₂ (yGen W)) d₂ :=
+    es1a10_ncVertical_reducesTo_of_ord_pos v hy₂
+  by_cases hξ : φ₁ (polyToFunctionField W X) = φ₂ (polyToFunctionField W X)
+  · rcases Y_eq_of_X_eq (es1a6_add_equation W φ₁) (es1a6_add_equation W φ₂) hξ with
+      hη | hcc
+    · have hd : d₁ = d₂ := by
+        by_contra hd
+        exact es1a10_ncVertical_ne_of_reducesTo_ne v hry₁ hry₂ hd hη
+      have h2tor : d₁ = W.negY c d₁ := by
+        have h' := hopp
+        rw [← hd] at h'
+        exact h'
+      have hNconst : 3 * c ^ 2 + 2 * W.a₂ * c + W.a₄ - W.a₁ * d₁ ≠ 0 :=
+        es1a10_ncVertical_nonsingular_certificate h₁ h2tor
+      have hyne : φ₁ (yGen W)
+          ≠ (W.map (algebraMap F W.FunctionField)).toAffine.negY
+            (φ₂ (polyToFunctionField W X)) (φ₂ (yGen W)) :=
+        fun hyy => hcol ⟨hξ, hyy⟩
+      have hnegYcongr : (W.map (algebraMap F W.FunctionField)).toAffine.negY
+          (φ₁ (polyToFunctionField W X)) (φ₁ (yGen W))
+          = (W.map (algebraMap F W.FunctionField)).toAffine.negY
+            (φ₂ (polyToFunctionField W X)) (φ₂ (yGen W)) := by
+        rw [hξ, hη]
+      have hdenne : φ₁ (yGen W)
+          - (W.map (algebraMap F W.FunctionField)).toAffine.negY
+            (φ₁ (polyToFunctionField W X)) (φ₁ (yGen W)) ≠ 0 := by
+        rw [sub_ne_zero, hnegYcongr]
+        exact hyne
+      have hdenred : es1a10_ncVertical_reducesTo v
+          (φ₁ (yGen W)
+            - (W.map (algebraMap F W.FunctionField)).toAffine.negY
+              (φ₁ (polyToFunctionField W X)) (φ₁ (yGen W)))
+          (d₁ - W.negY c d₁) :=
+        es1a10_ncVertical_reducesTo_sub v hry₁
+          (es1a10_ncVertical_negY_reducesTo v hrx₁ hry₁)
+      have hdenvan : es1a10_ncVertical_vanishesAt v
+          (φ₁ (yGen W)
+            - (W.map (algebraMap F W.FunctionField)).toAffine.negY
+              (φ₁ (polyToFunctionField W X)) (φ₁ (yGen W))) :=
+        es1a10_ncVertical_vanishesAt_of_reducesTo_zero v hdenred
+          (sub_eq_zero.mpr h2tor)
+      have hdenord : 0 < v.ord (φ₁ (yGen W)
+          - (W.map (algebraMap F W.FunctionField)).toAffine.negY
+            (φ₁ (polyToFunctionField W X)) (φ₁ (yGen W))) :=
+        es1a10_ncVertical_ord_pos_of_vanishesAt_of_ne v hdenvan hdenne
+      have hNred : es1a10_ncVertical_reducesTo v
+          (3 * φ₁ (polyToFunctionField W X) ^ 2
+            + 2 * algebraMap F W.FunctionField W.a₂ * φ₁ (polyToFunctionField W X)
+            + algebraMap F W.FunctionField W.a₄
+            - algebraMap F W.FunctionField W.a₁ * φ₁ (yGen W))
+          (3 * c ^ 2 + 2 * W.a₂ * c + W.a₄ - W.a₁ * d₁) :=
+        es1a10_ncVertical_reducesTo_sub v
+          (es1a10_ncVertical_reducesTo_add v
+            (es1a10_ncVertical_reducesTo_add v
+              (es1a10_ncVertical_reducesTo_mul v
+                (es1a10_ncVertical_reducesTo_ofNat v 3)
+                (es1a10_ncVertical_reducesTo_sq v hrx₁))
+              (es1a10_ncVertical_reducesTo_mul v
+                (es1a10_ncVertical_reducesTo_mul v
+                  (es1a10_ncVertical_reducesTo_ofNat v 2)
+                  (es1a10_ncVertical_reducesTo_algebraMap v W.a₂)) hrx₁))
+            (es1a10_ncVertical_reducesTo_algebraMap v W.a₄))
+          (es1a10_ncVertical_reducesTo_mul v
+            (es1a10_ncVertical_reducesTo_algebraMap v W.a₁) hry₁)
+      obtain ⟨hN0, hNord⟩ := es1a10_ncVertical_reducesTo_ord_eq_zero v hNred hNconst
+      rw [slope_of_Y_ne hξ hyne]
+      simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₄]
+      exact es1a10_ncVertical_ord_div_neg v hN0 hNord hdenne hdenord
+    · exact absurd ⟨hξ, hcc⟩ hcol
+  · have hxden_ne : φ₁ (polyToFunctionField W X) - φ₂ (polyToFunctionField W X) ≠ 0 :=
+      sub_ne_zero.mpr hξ
+    have hxden_red : es1a10_ncVertical_reducesTo v
+        (φ₁ (polyToFunctionField W X) - φ₂ (polyToFunctionField W X)) (c - c) :=
+      es1a10_ncVertical_reducesTo_sub v hrx₁ hrx₂
+    have hxden_van : es1a10_ncVertical_vanishesAt v
+        (φ₁ (polyToFunctionField W X) - φ₂ (polyToFunctionField W X)) :=
+      es1a10_ncVertical_vanishesAt_of_reducesTo_zero v hxden_red (sub_self c)
+    have hxden_ord : 0 < v.ord
+        (φ₁ (polyToFunctionField W X) - φ₂ (polyToFunctionField W X)) :=
+      es1a10_ncVertical_ord_pos_of_vanishesAt_of_ne v hxden_van hxden_ne
+    rw [slope_of_X_ne hξ]
+    by_cases hd : d₁ = d₂
+    · have heq₁ := es1a6_add_equation W φ₁
+      have heq₂ := es1a6_add_equation W φ₂
+      rw [equation_iff'] at heq₁ heq₂
+      simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+        WeierstrassCurve.map_a₄,
+        WeierstrassCurve.map_a₆] at heq₁ heq₂
+      have h2tor : d₂ = W.negY c d₂ := by
+        have h' := hopp
+        rw [hd] at h'
+        exact h'
+      have hNconst : 3 * c ^ 2 + 2 * W.a₂ * c + W.a₄ - W.a₁ * d₂ ≠ 0 :=
+        es1a10_ncVertical_nonsingular_certificate h₂ h2tor
+      have hNred : es1a10_ncVertical_reducesTo v
+          (φ₁ (polyToFunctionField W X) ^ 2
+            + φ₁ (polyToFunctionField W X) * φ₂ (polyToFunctionField W X)
+            + φ₂ (polyToFunctionField W X) ^ 2
+            + algebraMap F W.FunctionField W.a₂
+              * (φ₁ (polyToFunctionField W X) + φ₂ (polyToFunctionField W X))
+            + algebraMap F W.FunctionField W.a₄
+            - algebraMap F W.FunctionField W.a₁ * φ₂ (yGen W))
+          (c ^ 2 + c * c + c ^ 2 + W.a₂ * (c + c) + W.a₄ - W.a₁ * d₂) :=
+        es1a10_ncVertical_reducesTo_sub v
+          (es1a10_ncVertical_reducesTo_add v
+            (es1a10_ncVertical_reducesTo_add v
+              (es1a10_ncVertical_reducesTo_add v
+                (es1a10_ncVertical_reducesTo_add v
+                  (es1a10_ncVertical_reducesTo_sq v hrx₁)
+                  (es1a10_ncVertical_reducesTo_mul v hrx₁ hrx₂))
+                (es1a10_ncVertical_reducesTo_sq v hrx₂))
+              (es1a10_ncVertical_reducesTo_mul v
+                (es1a10_ncVertical_reducesTo_algebraMap v W.a₂)
+                (es1a10_ncVertical_reducesTo_add v hrx₁ hrx₂)))
+            (es1a10_ncVertical_reducesTo_algebraMap v W.a₄))
+          (es1a10_ncVertical_reducesTo_mul v
+            (es1a10_ncVertical_reducesTo_algebraMap v W.a₁) hry₂)
+      rw [show c ^ 2 + c * c + c ^ 2 + W.a₂ * (c + c) + W.a₄ - W.a₁ * d₂
+          = 3 * c ^ 2 + 2 * W.a₂ * c + W.a₄ - W.a₁ * d₂ by ring] at hNred
+      obtain ⟨hN0, hNord⟩ := es1a10_ncVertical_reducesTo_ord_eq_zero v hNred hNconst
+      have hDred : es1a10_ncVertical_reducesTo v
+          (φ₁ (yGen W) + φ₂ (yGen W)
+            + algebraMap F W.FunctionField W.a₁ * φ₁ (polyToFunctionField W X)
+            + algebraMap F W.FunctionField W.a₃)
+          (d₁ + d₂ + W.a₁ * c + W.a₃) :=
+        es1a10_ncVertical_reducesTo_add v
+          (es1a10_ncVertical_reducesTo_add v
+            (es1a10_ncVertical_reducesTo_add v hry₁ hry₂)
+            (es1a10_ncVertical_reducesTo_mul v
+              (es1a10_ncVertical_reducesTo_algebraMap v W.a₁) hrx₁))
+          (es1a10_ncVertical_reducesTo_algebraMap v W.a₃)
+      have hDconst : d₁ + d₂ + W.a₁ * c + W.a₃ = 0 := by
+        have h' := hopp
+        simp only [negY] at h'
+        linear_combination h'
+      have hDvan : es1a10_ncVertical_vanishesAt v
+          (φ₁ (yGen W) + φ₂ (yGen W)
+            + algebraMap F W.FunctionField W.a₁ * φ₁ (polyToFunctionField W X)
+            + algebraMap F W.FunctionField W.a₃) :=
+        es1a10_ncVertical_vanishesAt_of_reducesTo_zero v hDred hDconst
+      have hid : (φ₁ (yGen W) - φ₂ (yGen W))
+          * (φ₁ (yGen W) + φ₂ (yGen W)
+            + algebraMap F W.FunctionField W.a₁ * φ₁ (polyToFunctionField W X)
+            + algebraMap F W.FunctionField W.a₃)
+          = (φ₁ (polyToFunctionField W X) - φ₂ (polyToFunctionField W X))
+            * (φ₁ (polyToFunctionField W X) ^ 2
+              + φ₁ (polyToFunctionField W X) * φ₂ (polyToFunctionField W X)
+              + φ₂ (polyToFunctionField W X) ^ 2
+              + algebraMap F W.FunctionField W.a₂
+                * (φ₁ (polyToFunctionField W X) + φ₂ (polyToFunctionField W X))
+              + algebraMap F W.FunctionField W.a₄
+              - algebraMap F W.FunctionField W.a₁ * φ₂ (yGen W)) := by
+        linear_combination heq₁ - heq₂
+      have hD0 : φ₁ (yGen W) + φ₂ (yGen W)
+          + algebraMap F W.FunctionField W.a₁ * φ₁ (polyToFunctionField W X)
+          + algebraMap F W.FunctionField W.a₃ ≠ 0 := by
+        intro h0
+        rw [h0, mul_zero] at hid
+        rcases mul_eq_zero.mp hid.symm with h | h
+        · exact hxden_ne h
+        · exact hN0 h
+      have hDord : 0 < v.ord
+          (φ₁ (yGen W) + φ₂ (yGen W)
+            + algebraMap F W.FunctionField W.a₁ * φ₁ (polyToFunctionField W X)
+            + algebraMap F W.FunctionField W.a₃) :=
+        es1a10_ncVertical_ord_pos_of_vanishesAt_of_ne v hDvan hD0
+      have hslope_eq : (φ₁ (yGen W) - φ₂ (yGen W))
+          / (φ₁ (polyToFunctionField W X) - φ₂ (polyToFunctionField W X))
+          = (φ₁ (polyToFunctionField W X) ^ 2
+              + φ₁ (polyToFunctionField W X) * φ₂ (polyToFunctionField W X)
+              + φ₂ (polyToFunctionField W X) ^ 2
+              + algebraMap F W.FunctionField W.a₂
+                * (φ₁ (polyToFunctionField W X) + φ₂ (polyToFunctionField W X))
+              + algebraMap F W.FunctionField W.a₄
+              - algebraMap F W.FunctionField W.a₁ * φ₂ (yGen W))
+            / (φ₁ (yGen W) + φ₂ (yGen W)
+              + algebraMap F W.FunctionField W.a₁ * φ₁ (polyToFunctionField W X)
+              + algebraMap F W.FunctionField W.a₃) := by
+        rw [div_eq_div_iff hxden_ne hD0]
+        linear_combination heq₁ - heq₂
+      rw [hslope_eq]
+      exact es1a10_ncVertical_ord_div_neg v hN0 hNord hD0 hDord
+    · have hnum_red : es1a10_ncVertical_reducesTo v
+          (φ₁ (yGen W) - φ₂ (yGen W)) (d₁ - d₂) :=
+        es1a10_ncVertical_reducesTo_sub v hry₁ hry₂
+      obtain ⟨hnum0, hnumord⟩ :=
+        es1a10_ncVertical_reducesTo_ord_eq_zero v hnum_red (sub_ne_zero.mpr hd)
+      exact es1a10_ncVertical_ord_div_neg v hnum0 hnumord hxden_ne hxden_ord
+
+theorem es1a10_ncVertical_addX_not_mem (v : AlgebraicCurve.Place F W.FunctionField)
+    {ξ₁ ξ₂ Λ : W.FunctionField} {c₁ c₂ : F}
+    (hx₁ : es1a10_ncVertical_reducesTo v ξ₁ c₁)
+    (hx₂ : es1a10_ncVertical_reducesTo v ξ₂ c₂)
+    (hΛ : v.ord Λ < 0) :
+    (W.map (algebraMap F W.FunctionField)).toAffine.addX ξ₁ ξ₂ Λ
+      ∉ v.toValuationSubring := by
+  have hΛ0 : Λ ≠ 0 := by
+    intro h
+    rw [h, v.ord_zero] at hΛ
+    exact lt_irrefl 0 hΛ
+  have hkey : Λ + algebraMap F W.FunctionField W.a₁ ≠ 0 ∧
+      v.ord (Λ + algebraMap F W.FunctionField W.a₁) = v.ord Λ := by
+    rcases eq_or_ne W.a₁ 0 with ha | ha
+    · rw [ha, _root_.map_zero, add_zero]
+      exact ⟨hΛ0, rfl⟩
+    · have hA0 : algebraMap F W.FunctionField W.a₁ ≠ 0 := fun h =>
+        ha ((algebraMap F W.FunctionField).injective (by rw [h, _root_.map_zero]))
+      have hAord : v.ord (algebraMap F W.FunctionField W.a₁) = 0 :=
+        es1a10_ncVertical_ord_algebraMap v W.a₁
+      have hsum0 : Λ + algebraMap F W.FunctionField W.a₁ ≠ 0 := by
+        intro h
+        have h1 : Λ = -(algebraMap F W.FunctionField W.a₁) := by linear_combination h
+        rw [h1, es1a10_ncVertical_ord_neg, hAord] at hΛ
+        exact lt_irrefl 0 hΛ
+      refine ⟨hsum0, ?_⟩
+      rw [v.ord_add_eq_min hΛ0 hA0 (by rw [hAord]; omega), hAord]
+      exact min_eq_left hΛ.le
+  have heqX : Λ * (Λ + algebraMap F W.FunctionField W.a₁)
+      = (W.map (algebraMap F W.FunctionField)).toAffine.addX ξ₁ ξ₂ Λ
+        + (algebraMap F W.FunctionField W.a₂ + ξ₁ + ξ₂) := by
+    simp only [addX, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂]
+    ring
+  intro hmem
+  have hmul_mem : Λ * (Λ + algebraMap F W.FunctionField W.a₁)
+      ∈ v.toValuationSubring := by
+    rw [heqX]
+    exact add_mem hmem (add_mem (add_mem (v.algebraMap_mem' W.a₂)
+      (es1a10_ncVertical_mem_of_reducesTo v hx₁))
+      (es1a10_ncVertical_mem_of_reducesTo v hx₂))
+  have hge := v.ord_nonneg_of_mem hmul_mem
+  rw [v.ord_mul hΛ0 hkey.1, hkey.2] at hge
+  omega
+
+theorem es1a10_ncVertical_seamDataAt_zero (v : AlgebraicCurve.Place F W.FunctionField)
+    (h : es1a6_addSumX W φ₁ φ₂ ∉ v.toValuationSubring) :
+    es1a6_addSumSeamDataAt φ₁ φ₂ v 0 := h
+
+theorem es1a10_ncVertical_seamData [DecidableEq F] (v : AlgebraicCurve.Place F W.FunctionField)
+    (hcol : ¬ es1a6_addCollapse W φ₁ φ₂)
+    {c d₁ d₂ : F} (h₁ : W.Nonsingular c d₁) (h₂ : W.Nonsingular c d₂)
+    (hopp : d₁ = W.negY c d₂)
+    (hx₁ : 0 < v.ord (φ₁ (polyToFunctionField W X) - algebraMap F W.FunctionField c))
+    (hy₁ : 0 < v.ord (φ₁ (yGen W) - algebraMap F W.FunctionField d₁))
+    (hx₂ : 0 < v.ord (φ₂ (polyToFunctionField W X) - algebraMap F W.FunctionField c))
+    (hy₂ : 0 < v.ord (φ₂ (yGen W) - algebraMap F W.FunctionField d₂)) :
+    es1a6_addSumSeamDataAt φ₁ φ₂ v (Point.some c d₁ h₁ + Point.some c d₂ h₂) := by
+  have hrx₁ : es1a10_ncVertical_reducesTo v (φ₁ (polyToFunctionField W X)) c :=
+    es1a10_ncVertical_reducesTo_of_ord_pos v hx₁
+  have hrx₂ : es1a10_ncVertical_reducesTo v (φ₂ (polyToFunctionField W X)) c :=
+    es1a10_ncVertical_reducesTo_of_ord_pos v hx₂
+  have hΛ : v.ord ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+      (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+      (φ₁ (yGen W)) (φ₂ (yGen W))) < 0 :=
+    es1a10_ncVertical_slope_ord_neg φ₁ φ₂ v hcol h₁ h₂ hopp hx₁ hy₁ hx₂ hy₂
+  rw [Point.add_of_Y_eq (rfl : c = c) hopp]
+  refine es1a10_ncVertical_seamDataAt_zero φ₁ φ₂ v ?_
+  rw [show es1a6_addSumX W φ₁ φ₂
+      = (W.map (algebraMap F W.FunctionField)).toAffine.addX
+        (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+        ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+          (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+          (φ₁ (yGen W)) (φ₂ (yGen W))) from rfl]
+  exact es1a10_ncVertical_addX_not_mem v hrx₁ hrx₂ hΛ
+
+end VerticalCaseEngines
+
+end Es1a1
+end ModularCurve
+
+end
+
+section
+
+namespace ModularCurve
+namespace Es1a1
+
+universe u
+
+local instance instDecEqFunctionFieldEs1a9Nc {F : Type u} [Field F]
+    {W : WeierstrassCurve.Affine F} :
+    DecidableEq W.FunctionField :=
+  Classical.decEq _
+
+section VanishingCalculusNc
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : AlgebraicCurve.Place K F)
+
+theorem es1a9_ord_algebraMap_nc (c : K) : v.ord (algebraMap K F c) = 0 := by
+  rcases eq_or_ne c 0 with rfl | hc
+  · simp
+  have hmem : algebraMap K F c ∈ v.toValuationSubring := v.algebraMap_mem' c
+  have hmem' : (algebraMap K F c)⁻¹ ∈ v.toValuationSubring := by
+    rw [← map_inv₀]
+    exact v.algebraMap_mem' c⁻¹
+  have h1 := v.ord_nonneg_of_mem hmem
+  have h2 := v.ord_nonneg_of_mem hmem'
+  rw [v.ord_inv] at h2
+  omega
+
+theorem es1a9_ord_neg_nc (f : F) : v.ord (-f) = v.ord f := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · simp
+  have h1 : (-f : F) = algebraMap K F (-1) * f := by
+    rw [_root_.map_neg, map_one]
+    ring
+  have hne : (algebraMap K F (-1 : K)) ≠ 0 := by
+    rw [_root_.map_neg, map_one]
+    exact neg_ne_zero.mpr one_ne_zero
+  rw [h1, v.ord_mul hne hf, es1a9_ord_algebraMap_nc, zero_add]
+
+def es1a9_vanishesAt_nc (f : F) : Prop := f = 0 ∨ 0 < v.ord f
+
+theorem es1a9_vanishesAt_zero_nc : es1a9_vanishesAt_nc v (0 : F) := Or.inl rfl
+
+theorem es1a9_vanishesAt_add_nc {f g : F} (hf : es1a9_vanishesAt_nc v f)
+    (hg : es1a9_vanishesAt_nc v g) : es1a9_vanishesAt_nc v (f + g) := by
+  have hf' : f = 0 ∨ 0 < v.ord f := hf
+  have hg' : g = 0 ∨ 0 < v.ord g := hg
+  rcases hf' with rfl | hf0
+  · rw [zero_add]
+    exact hg
+  rcases hg' with rfl | hg0
+  · rw [add_zero]
+    exact hf
+  rcases eq_or_ne (f + g) 0 with h0 | h0
+  · exact Or.inl h0
+  · refine Or.inr ?_
+    have h1 := v.min_ord_le_ord_add' h0
+    have h2 : (0 : ℤ) < min (v.ord f) (v.ord g) := lt_min hf0 hg0
+    exact h2.trans_le h1
+
+theorem es1a9_vanishesAt_neg_nc {f : F} (hf : es1a9_vanishesAt_nc v f) :
+    es1a9_vanishesAt_nc v (-f) := by
+  have hf' : f = 0 ∨ 0 < v.ord f := hf
+  change -f = 0 ∨ 0 < v.ord (-f)
+  rcases hf' with rfl | hf0
+  · exact Or.inl _root_.neg_zero
+  · refine Or.inr ?_
+    rw [es1a9_ord_neg_nc]
+    exact hf0
+
+theorem es1a9_vanishesAt_sub_nc {f g : F} (hf : es1a9_vanishesAt_nc v f)
+    (hg : es1a9_vanishesAt_nc v g) : es1a9_vanishesAt_nc v (f - g) := by
+  rw [sub_eq_add_neg]
+  exact es1a9_vanishesAt_add_nc v hf (es1a9_vanishesAt_neg_nc v hg)
+
+theorem es1a9_vanishesAt_mul_mem_nc {f g : F} (hf : es1a9_vanishesAt_nc v f)
+    (hg : g ∈ v.toValuationSubring) : es1a9_vanishesAt_nc v (f * g) := by
+  have hf' : f = 0 ∨ 0 < v.ord f := hf
+  change f * g = 0 ∨ 0 < v.ord (f * g)
+  rcases hf' with rfl | hf0
+  · exact Or.inl (zero_mul g)
+  rcases eq_or_ne g 0 with rfl | hg0
+  · exact Or.inl (mul_zero f)
+  · refine Or.inr ?_
+    have hf1 : f ≠ 0 := by
+      intro h
+      rw [h, v.ord_zero] at hf0
+      exact lt_irrefl 0 hf0
+    rw [v.ord_mul hf1 hg0]
+    have h2 := v.ord_nonneg_of_mem hg
+    omega
+
+theorem es1a9_vanishesAt_mem_mul_nc {f g : F} (hf : f ∈ v.toValuationSubring)
+    (hg : es1a9_vanishesAt_nc v g) : es1a9_vanishesAt_nc v (f * g) := by
+  rw [mul_comm]
+  exact es1a9_vanishesAt_mul_mem_nc v hg hf
+
+theorem es1a9_mem_of_vanishesAt_nc {f : F} (hf : es1a9_vanishesAt_nc v f) :
+    f ∈ v.toValuationSubring := by
+  have hf' : f = 0 ∨ 0 < v.ord f := hf
+  rcases hf' with rfl | hf0
+  · exact zero_mem _
+  · have hne : f ≠ 0 := by
+      intro h
+      rw [h, v.ord_zero] at hf0
+      exact lt_irrefl 0 hf0
+    exact v.mem_of_ord_nonneg hne hf0.le
+
+def es1a9_reducesTo_nc (f : F) (c : K) : Prop :=
+  es1a9_vanishesAt_nc v (f - algebraMap K F c)
+
+theorem es1a9_reducesTo_of_ord_pos_nc {f : F} {c : K}
+    (h : 0 < v.ord (f - algebraMap K F c)) : es1a9_reducesTo_nc v f c :=
+  Or.inr h
+
+theorem es1a9_reducesTo_algebraMap_nc (c : K) :
+    es1a9_reducesTo_nc v (algebraMap K F c) c := by
+  change es1a9_vanishesAt_nc v (algebraMap K F c - algebraMap K F c)
+  rw [sub_self]
+  exact es1a9_vanishesAt_zero_nc v
+
+theorem es1a9_reducesTo_ofNat_nc (n : ℕ) [Nat.AtLeastTwo n] :
+    es1a9_reducesTo_nc v (OfNat.ofNat n : F) (OfNat.ofNat n : K) := by
+  change es1a9_vanishesAt_nc v ((OfNat.ofNat n : F) - algebraMap K F (OfNat.ofNat n : K))
+  rw [map_ofNat, sub_self]
+  exact es1a9_vanishesAt_zero_nc v
+
+theorem es1a9_reducesTo_add_nc {f g : F} {c d : K}
+    (hf : es1a9_reducesTo_nc v f c) (hg : es1a9_reducesTo_nc v g d) :
+    es1a9_reducesTo_nc v (f + g) (c + d) := by
+  change es1a9_vanishesAt_nc v (f + g - algebraMap K F (c + d))
+  rw [show f + g - algebraMap K F (c + d)
+      = (f - algebraMap K F c) + (g - algebraMap K F d) by rw [map_add]; ring]
+  exact es1a9_vanishesAt_add_nc v hf hg
+
+theorem es1a9_reducesTo_neg_nc {f : F} {c : K} (hf : es1a9_reducesTo_nc v f c) :
+    es1a9_reducesTo_nc v (-f) (-c) := by
+  change es1a9_vanishesAt_nc v (-f - algebraMap K F (-c))
+  rw [show -f - algebraMap K F (-c) = -(f - algebraMap K F c) by rw [_root_.map_neg]; ring]
+  exact es1a9_vanishesAt_neg_nc v hf
+
+theorem es1a9_reducesTo_sub_nc {f g : F} {c d : K}
+    (hf : es1a9_reducesTo_nc v f c) (hg : es1a9_reducesTo_nc v g d) :
+    es1a9_reducesTo_nc v (f - g) (c - d) := by
+  change es1a9_vanishesAt_nc v (f - g - algebraMap K F (c - d))
+  rw [show f - g - algebraMap K F (c - d)
+      = (f - algebraMap K F c) - (g - algebraMap K F d) by rw [map_sub]; ring]
+  exact es1a9_vanishesAt_sub_nc v hf hg
+
+theorem es1a9_mem_of_reducesTo_nc {g : F} {d : K} (hg : es1a9_reducesTo_nc v g d) :
+    g ∈ v.toValuationSubring := by
+  have h1 : g - algebraMap K F d ∈ v.toValuationSubring :=
+    es1a9_mem_of_vanishesAt_nc v hg
+  have h2 := add_mem h1 (v.algebraMap_mem' d)
+  rwa [sub_add_cancel] at h2
+
+theorem es1a9_reducesTo_mul_nc {f g : F} {c d : K}
+    (hf : es1a9_reducesTo_nc v f c) (hg : es1a9_reducesTo_nc v g d) :
+    es1a9_reducesTo_nc v (f * g) (c * d) := by
+  change es1a9_vanishesAt_nc v (f * g - algebraMap K F (c * d))
+  rw [show f * g - algebraMap K F (c * d)
+      = (f - algebraMap K F c) * g
+        + algebraMap K F c * (g - algebraMap K F d) by rw [map_mul]; ring]
+  exact es1a9_vanishesAt_add_nc v
+    (es1a9_vanishesAt_mul_mem_nc v hf (es1a9_mem_of_reducesTo_nc v hg))
+    (es1a9_vanishesAt_mem_mul_nc v (v.algebraMap_mem' c) hg)
+
+theorem es1a9_reducesTo_sq_nc {f : F} {c : K} (hf : es1a9_reducesTo_nc v f c) :
+    es1a9_reducesTo_nc v (f ^ 2) (c ^ 2) := by
+  rw [pow_two, pow_two]
+  exact es1a9_reducesTo_mul_nc v hf hf
+
+theorem es1a9_reducesTo_ord_eq_zero_nc {f : F} {c : K}
+    (hf : es1a9_reducesTo_nc v f c) (hc : c ≠ 0) : f ≠ 0 ∧ v.ord f = 0 := by
+  have hmap0 : algebraMap K F c ≠ 0 := fun h =>
+    hc ((algebraMap K F).injective (by rw [h, _root_.map_zero]))
+  have hf' : f - algebraMap K F c = 0 ∨ 0 < v.ord (f - algebraMap K F c) := hf
+  rcases hf' with h0 | hpos
+  · have hfeq : f = algebraMap K F c := sub_eq_zero.mp h0
+    refine ⟨by rw [hfeq]; exact hmap0, ?_⟩
+    rw [hfeq, es1a9_ord_algebraMap_nc]
+  · have hd0 : f - algebraMap K F c ≠ 0 := by
+      intro h
+      rw [h, v.ord_zero] at hpos
+      exact lt_irrefl 0 hpos
+    have hf0 : f ≠ 0 := by
+      intro h
+      have h1 : f - algebraMap K F c = -(algebraMap K F c) := by rw [h]; ring
+      rw [h1, es1a9_ord_neg_nc, es1a9_ord_algebraMap_nc] at hpos
+      exact lt_irrefl 0 hpos
+    have hsum : algebraMap K F c + (f - algebraMap K F c) = f := by ring
+    have hmin := v.ord_add_eq_min hmap0 hd0 (by
+      rw [es1a9_ord_algebraMap_nc]
+      omega)
+    rw [hsum] at hmin
+    refine ⟨hf0, ?_⟩
+    rw [hmin, es1a9_ord_algebraMap_nc]
+    exact min_eq_left hpos.le
+
+theorem es1a9_reducesTo_inv_nc {f : F} {c : K}
+    (hf : es1a9_reducesTo_nc v f c) (hc : c ≠ 0) :
+    es1a9_reducesTo_nc v f⁻¹ c⁻¹ := by
+  obtain ⟨hf0, hford⟩ := es1a9_reducesTo_ord_eq_zero_nc v hf hc
+  have hmap0 : algebraMap K F c ≠ 0 := fun h =>
+    hc ((algebraMap K F).injective (by rw [h, _root_.map_zero]))
+  have hvan : es1a9_vanishesAt_nc v (algebraMap K F c - f) := by
+    rw [show algebraMap K F c - f = -(f - algebraMap K F c) by ring]
+    exact es1a9_vanishesAt_neg_nc v hf
+  have hinv_mem : f⁻¹ ∈ v.toValuationSubring := by
+    refine v.mem_of_ord_nonneg (inv_ne_zero hf0) ?_
+    rw [v.ord_inv, hford]
+    omega
+  change es1a9_vanishesAt_nc v (f⁻¹ - algebraMap K F c⁻¹)
+  rw [map_inv₀, inv_sub_inv hf0 hmap0, div_eq_mul_inv, mul_inv]
+  exact es1a9_vanishesAt_mul_mem_nc v hvan
+    (mul_mem hinv_mem (by rw [← map_inv₀]; exact v.algebraMap_mem' c⁻¹))
+
+theorem es1a9_reducesTo_div_nc {f g : F} {c d : K}
+    (hf : es1a9_reducesTo_nc v f c) (hg : es1a9_reducesTo_nc v g d) (hd : d ≠ 0) :
+    es1a9_reducesTo_nc v (f / g) (c / d) := by
+  rw [div_eq_mul_inv, div_eq_mul_inv]
+  exact es1a9_reducesTo_mul_nc v hf (es1a9_reducesTo_inv_nc v hg hd)
+
+theorem es1a9_ne_of_reducesTo_ne_nc {f g : F} {c d : K}
+    (hf : es1a9_reducesTo_nc v f c) (hg : es1a9_reducesTo_nc v g d) (hcd : c ≠ d) :
+    f ≠ g := by
+  intro hfg
+  have hsub : es1a9_reducesTo_nc v (f - g) (c - d) := es1a9_reducesTo_sub_nc v hf hg
+  rw [hfg, sub_self] at hsub
+  have hsub' : (0 : F) - algebraMap K F (c - d) = 0 ∨
+      0 < v.ord ((0 : F) - algebraMap K F (c - d)) := hsub
+  rw [zero_sub] at hsub'
+  have hne0 : algebraMap K F (c - d) ≠ 0 := fun h =>
+    sub_ne_zero.mpr hcd ((algebraMap K F).injective (by rw [h, _root_.map_zero]))
+  rcases hsub' with h0 | hpos
+  · exact hne0 (neg_eq_zero.mp h0)
+  · rw [es1a9_ord_neg_nc, es1a9_ord_algebraMap_nc] at hpos
+    exact lt_irrefl 0 hpos
+
+theorem es1a9_ord_pos_of_reducesTo_of_ne_nc {f : F} {c : K}
+    (hf : es1a9_reducesTo_nc v f c) (hne : f ≠ algebraMap K F c) :
+    0 < v.ord (f - algebraMap K F c) := by
+  have hf' : f - algebraMap K F c = 0 ∨ 0 < v.ord (f - algebraMap K F c) := hf
+  rcases hf' with h0 | hpos
+  · exact absurd (sub_eq_zero.mp h0) hne
+  · exact hpos
+
+end VanishingCalculusNc
+
+section ChordTangentNc
+
+variable {F : Type u} [Field F] {W : WeierstrassCurve.Affine F}
+
+theorem es1a9_addX_reducesTo_nc (v : AlgebraicCurve.Place F W.FunctionField)
+    {ξ₁ ξ₂ Λ : W.FunctionField} {c₁ c₂ ℓ : F}
+    (hx₁ : es1a9_reducesTo_nc v ξ₁ c₁) (hx₂ : es1a9_reducesTo_nc v ξ₂ c₂)
+    (hΛ : es1a9_reducesTo_nc v Λ ℓ) :
+    es1a9_reducesTo_nc v
+      ((W.map (algebraMap F W.FunctionField)).toAffine.addX ξ₁ ξ₂ Λ)
+      (W.addX c₁ c₂ ℓ) := by
+  have h1 : (W.map (algebraMap F W.FunctionField)).toAffine.addX ξ₁ ξ₂ Λ
+      = Λ ^ 2 + algebraMap F W.FunctionField W.a₁ * Λ
+        - algebraMap F W.FunctionField W.a₂ - ξ₁ - ξ₂ := by
+    simp only [addX, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂]
+  have h2 : W.addX c₁ c₂ ℓ = ℓ ^ 2 + W.a₁ * ℓ - W.a₂ - c₁ - c₂ := by
+    simp only [addX]
+  rw [h1, h2]
+  exact es1a9_reducesTo_sub_nc v (es1a9_reducesTo_sub_nc v (es1a9_reducesTo_sub_nc v
+    (es1a9_reducesTo_add_nc v (es1a9_reducesTo_sq_nc v hΛ)
+      (es1a9_reducesTo_mul_nc v (es1a9_reducesTo_algebraMap_nc v W.a₁) hΛ))
+    (es1a9_reducesTo_algebraMap_nc v W.a₂)) hx₁) hx₂
+
+theorem es1a9_negY_reducesTo_nc (v : AlgebraicCurve.Place F W.FunctionField)
+    {ξ η : W.FunctionField} {c d : F}
+    (hx : es1a9_reducesTo_nc v ξ c) (hy : es1a9_reducesTo_nc v η d) :
+    es1a9_reducesTo_nc v
+      ((W.map (algebraMap F W.FunctionField)).toAffine.negY ξ η) (W.negY c d) := by
+  have h1 : (W.map (algebraMap F W.FunctionField)).toAffine.negY ξ η
+      = -η - algebraMap F W.FunctionField W.a₁ * ξ
+        - algebraMap F W.FunctionField W.a₃ := by
+    simp only [negY, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₃]
+  have h2 : W.negY c d = -d - W.a₁ * c - W.a₃ := by
+    simp only [negY]
+  rw [h1, h2]
+  exact es1a9_reducesTo_sub_nc v
+    (es1a9_reducesTo_sub_nc v (es1a9_reducesTo_neg_nc v hy)
+      (es1a9_reducesTo_mul_nc v (es1a9_reducesTo_algebraMap_nc v W.a₁) hx))
+    (es1a9_reducesTo_algebraMap_nc v W.a₃)
+
+theorem es1a9_negAddY_reducesTo_nc (v : AlgebraicCurve.Place F W.FunctionField)
+    {ξ₁ ξ₂ η₁ Λ : W.FunctionField} {c₁ c₂ d₁ ℓ : F}
+    (hx₁ : es1a9_reducesTo_nc v ξ₁ c₁) (hx₂ : es1a9_reducesTo_nc v ξ₂ c₂)
+    (hy₁ : es1a9_reducesTo_nc v η₁ d₁) (hΛ : es1a9_reducesTo_nc v Λ ℓ) :
+    es1a9_reducesTo_nc v
+      ((W.map (algebraMap F W.FunctionField)).toAffine.negAddY ξ₁ ξ₂ η₁ Λ)
+      (W.negAddY c₁ c₂ d₁ ℓ) := by
+  have h1 : (W.map (algebraMap F W.FunctionField)).toAffine.negAddY ξ₁ ξ₂ η₁ Λ
+      = Λ * ((W.map (algebraMap F W.FunctionField)).toAffine.addX ξ₁ ξ₂ Λ - ξ₁)
+        + η₁ := by
+    simp only [negAddY]
+  have h2 : W.negAddY c₁ c₂ d₁ ℓ = ℓ * (W.addX c₁ c₂ ℓ - c₁) + d₁ := by
+    simp only [negAddY]
+  rw [h1, h2]
+  exact es1a9_reducesTo_add_nc v
+    (es1a9_reducesTo_mul_nc v hΛ
+      (es1a9_reducesTo_sub_nc v (es1a9_addX_reducesTo_nc v hx₁ hx₂ hΛ) hx₁)) hy₁
+
+theorem es1a9_addY_reducesTo_nc (v : AlgebraicCurve.Place F W.FunctionField)
+    {ξ₁ ξ₂ η₁ Λ : W.FunctionField} {c₁ c₂ d₁ ℓ : F}
+    (hx₁ : es1a9_reducesTo_nc v ξ₁ c₁) (hx₂ : es1a9_reducesTo_nc v ξ₂ c₂)
+    (hy₁ : es1a9_reducesTo_nc v η₁ d₁) (hΛ : es1a9_reducesTo_nc v Λ ℓ) :
+    es1a9_reducesTo_nc v
+      ((W.map (algebraMap F W.FunctionField)).toAffine.addY ξ₁ ξ₂ η₁ Λ)
+      (W.addY c₁ c₂ d₁ ℓ) := by
+  have h1 : (W.map (algebraMap F W.FunctionField)).toAffine.addY ξ₁ ξ₂ η₁ Λ
+      = (W.map (algebraMap F W.FunctionField)).toAffine.negY
+          ((W.map (algebraMap F W.FunctionField)).toAffine.addX ξ₁ ξ₂ Λ)
+          ((W.map (algebraMap F W.FunctionField)).toAffine.negAddY ξ₁ ξ₂ η₁ Λ) := by
+    simp only [addY]
+  have h2 : W.addY c₁ c₂ d₁ ℓ
+      = W.negY (W.addX c₁ c₂ ℓ) (W.negAddY c₁ c₂ d₁ ℓ) := by
+    simp only [addY]
+  rw [h1, h2]
+  exact es1a9_negY_reducesTo_nc v (es1a9_addX_reducesTo_nc v hx₁ hx₂ hΛ)
+    (es1a9_negAddY_reducesTo_nc v hx₁ hx₂ hy₁ hΛ)
+
+variable (φ₁ φ₂ : W.FunctionField →ₐ[F] W.FunctionField) [IsAlgClosed F]
+
+theorem es1a9_addSumY_ne_const_nc
+    (hcol : ¬ es1a6_addCollapse W φ₁ φ₂)
+    (hnc : ∀ c : F, es1a6_addSumX W φ₁ φ₂ ≠ algebraMap F W.FunctionField c) :
+    ∀ d : F, es1a6_addSumY W φ₁ φ₂ ≠ algebraMap F W.FunctionField d := by
+  intro d hd
+  have heq := es1a6_addSum_equation W φ₁ φ₂ hcol
+  rw [equation_iff'] at heq
+  simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+    WeierstrassCurve.map_a₄,
+    WeierstrassCurve.map_a₆] at heq
+  rw [hd] at heq
+  have hq0 : (X ^ 3 + C W.a₂ * X ^ 2 + C (W.a₄ - W.a₁ * d) * X
+      + C (W.a₆ - d ^ 2 - W.a₃ * d) : F[X]) ≠ 0 := by
+    intro hq
+    have h3 := congrArg (fun q => Polynomial.coeff q 3) hq
+    simp only [Polynomial.coeff_add, Polynomial.coeff_X_pow, Polynomial.coeff_C_mul,
+      Polynomial.coeff_C, Polynomial.coeff_X, Polynomial.coeff_zero] at h3
+    norm_num at h3
+  have halgX : IsAlgebraic F (es1a6_addSumX W φ₁ φ₂) := by
+    refine ⟨X ^ 3 + C W.a₂ * X ^ 2 + C (W.a₄ - W.a₁ * d) * X
+      + C (W.a₆ - d ^ 2 - W.a₃ * d), hq0, ?_⟩
+    simp only [map_add, map_sub, map_mul, map_pow, Polynomial.aeval_X,
+      Polynomial.aeval_C]
+    linear_combination -heq
+  exact es1a6_add_sumX_transcendental_of_forall_ne W φ₁ φ₂ hnc halgX
+
+variable [DecidableEq F]
+theorem es1a9_chordCase_seamData_nc
+    (v : AlgebraicCurve.Place F W.FunctionField)
+    (hnc : ∀ c : F, es1a6_addSumX W φ₁ φ₂ ≠ algebraMap F W.FunctionField c)
+    {c₁ d₁ c₂ d₂ : F} (h₁ : W.Nonsingular c₁ d₁) (h₂ : W.Nonsingular c₂ d₂)
+    (hne : c₁ ≠ c₂)
+    (hx₁ : 0 < v.ord (φ₁ (polyToFunctionField W X) - algebraMap F W.FunctionField c₁))
+    (hy₁ : 0 < v.ord (φ₁ (yGen W) - algebraMap F W.FunctionField d₁))
+    (hx₂ : 0 < v.ord (φ₂ (polyToFunctionField W X) - algebraMap F W.FunctionField c₂))
+    (hy₂ : 0 < v.ord (φ₂ (yGen W) - algebraMap F W.FunctionField d₂)) :
+    es1a6_addSumSeamDataAt φ₁ φ₂ v (Point.some c₁ d₁ h₁ + Point.some c₂ d₂ h₂) := by
+  have hrx₁ : es1a9_reducesTo_nc v (φ₁ (polyToFunctionField W X)) c₁ :=
+    es1a9_reducesTo_of_ord_pos_nc v hx₁
+  have hry₁ : es1a9_reducesTo_nc v (φ₁ (yGen W)) d₁ :=
+    es1a9_reducesTo_of_ord_pos_nc v hy₁
+  have hrx₂ : es1a9_reducesTo_nc v (φ₂ (polyToFunctionField W X)) c₂ :=
+    es1a9_reducesTo_of_ord_pos_nc v hx₂
+  have hry₂ : es1a9_reducesTo_nc v (φ₂ (yGen W)) d₂ :=
+    es1a9_reducesTo_of_ord_pos_nc v hy₂
+  have hxne : φ₁ (polyToFunctionField W X) ≠ φ₂ (polyToFunctionField W X) :=
+    es1a9_ne_of_reducesTo_ne_nc v hrx₁ hrx₂ hne
+  have hsl : es1a9_reducesTo_nc v
+      ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+        (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+        (φ₁ (yGen W)) (φ₂ (yGen W)))
+      (W.slope c₁ c₂ d₁ d₂) := by
+    rw [slope_of_X_ne hxne, slope_of_X_ne hne]
+    exact es1a9_reducesTo_div_nc v (es1a9_reducesTo_sub_nc v hry₁ hry₂)
+      (es1a9_reducesTo_sub_nc v hrx₁ hrx₂) (sub_ne_zero.mpr hne)
+  have hXred : es1a9_reducesTo_nc v (es1a6_addSumX W φ₁ φ₂)
+      (W.addX c₁ c₂ (W.slope c₁ c₂ d₁ d₂)) := by
+    rw [show es1a6_addSumX W φ₁ φ₂
+        = (W.map (algebraMap F W.FunctionField)).toAffine.addX
+          (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+          ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+            (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+            (φ₁ (yGen W)) (φ₂ (yGen W))) from rfl]
+    exact es1a9_addX_reducesTo_nc v hrx₁ hrx₂ hsl
+  have hYred : es1a9_reducesTo_nc v (es1a6_addSumY W φ₁ φ₂)
+      (W.addY c₁ c₂ d₁ (W.slope c₁ c₂ d₁ d₂)) := by
+    rw [show es1a6_addSumY W φ₁ φ₂
+        = (W.map (algebraMap F W.FunctionField)).toAffine.addY
+          (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X)) (φ₁ (yGen W))
+          ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+            (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+            (φ₁ (yGen W)) (φ₂ (yGen W))) from rfl]
+    exact es1a9_addY_reducesTo_nc v hrx₁ hrx₂ hry₁ hsl
+  rw [Point.add_of_X_ne hne]
+  exact ⟨es1a9_ord_pos_of_reducesTo_of_ne_nc v hXred (hnc _),
+    es1a9_ord_pos_of_reducesTo_of_ne_nc v hYred
+      (es1a9_addSumY_ne_const_nc φ₁ φ₂
+        (es1a6_add_not_collapse_of_X_ne W φ₁ φ₂ hxne) hnc _)⟩
+
+theorem es1a9_tangentCase_seamData_nc
+    (v : AlgebraicCurve.Place F W.FunctionField)
+    (hcol : ¬ es1a6_addCollapse W φ₁ φ₂)
+    (hnc : ∀ c : F, es1a6_addSumX W φ₁ φ₂ ≠ algebraMap F W.FunctionField c)
+    {c d : F} (h : W.Nonsingular c d) (h2tor : d ≠ W.negY c d)
+    (hx₁ : 0 < v.ord (φ₁ (polyToFunctionField W X) - algebraMap F W.FunctionField c))
+    (hy₁ : 0 < v.ord (φ₁ (yGen W) - algebraMap F W.FunctionField d))
+    (hx₂ : 0 < v.ord (φ₂ (polyToFunctionField W X) - algebraMap F W.FunctionField c))
+    (hy₂ : 0 < v.ord (φ₂ (yGen W) - algebraMap F W.FunctionField d)) :
+    es1a6_addSumSeamDataAt φ₁ φ₂ v (Point.some c d h + Point.some c d h) := by
+  have hrx₁ : es1a9_reducesTo_nc v (φ₁ (polyToFunctionField W X)) c :=
+    es1a9_reducesTo_of_ord_pos_nc v hx₁
+  have hry₁ : es1a9_reducesTo_nc v (φ₁ (yGen W)) d :=
+    es1a9_reducesTo_of_ord_pos_nc v hy₁
+  have hrx₂ : es1a9_reducesTo_nc v (φ₂ (polyToFunctionField W X)) c :=
+    es1a9_reducesTo_of_ord_pos_nc v hx₂
+  have hry₂ : es1a9_reducesTo_nc v (φ₂ (yGen W)) d :=
+    es1a9_reducesTo_of_ord_pos_nc v hy₂
+  have hsl : es1a9_reducesTo_nc v
+      ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+        (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+        (φ₁ (yGen W)) (φ₂ (yGen W)))
+      (W.slope c c d d) := by
+    by_cases hξ : φ₁ (polyToFunctionField W X) = φ₂ (polyToFunctionField W X)
+    · have hyne : φ₁ (yGen W)
+          ≠ (W.map (algebraMap F W.FunctionField)).toAffine.negY
+            (φ₂ (polyToFunctionField W X)) (φ₂ (yGen W)) :=
+        fun hyy => hcol ⟨hξ, hyy⟩
+      rw [slope_of_Y_ne hξ hyne, slope_of_Y_ne (rfl : c = c) h2tor]
+      simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₄]
+      exact es1a9_reducesTo_div_nc v
+        (es1a9_reducesTo_sub_nc v
+          (es1a9_reducesTo_add_nc v
+            (es1a9_reducesTo_add_nc v
+              (es1a9_reducesTo_mul_nc v (es1a9_reducesTo_ofNat_nc v 3)
+                (es1a9_reducesTo_sq_nc v hrx₁))
+              (es1a9_reducesTo_mul_nc v
+                (es1a9_reducesTo_mul_nc v (es1a9_reducesTo_ofNat_nc v 2)
+                  (es1a9_reducesTo_algebraMap_nc v W.a₂)) hrx₁))
+            (es1a9_reducesTo_algebraMap_nc v W.a₄))
+          (es1a9_reducesTo_mul_nc v (es1a9_reducesTo_algebraMap_nc v W.a₁) hry₁))
+        (es1a9_reducesTo_sub_nc v hry₁ (es1a9_negY_reducesTo_nc v hrx₁ hry₁))
+        (sub_ne_zero.mpr h2tor)
+    · have heq₁ := es1a6_add_equation W φ₁
+      have heq₂ := es1a6_add_equation W φ₂
+      rw [equation_iff'] at heq₁ heq₂
+      simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+        WeierstrassCurve.map_a₄,
+        WeierstrassCurve.map_a₆] at heq₁ heq₂
+      have hDred : es1a9_reducesTo_nc v
+          (φ₁ (yGen W) + φ₂ (yGen W)
+            + algebraMap F W.FunctionField W.a₁ * φ₁ (polyToFunctionField W X)
+            + algebraMap F W.FunctionField W.a₃)
+          (d + d + W.a₁ * c + W.a₃) :=
+        es1a9_reducesTo_add_nc v
+          (es1a9_reducesTo_add_nc v (es1a9_reducesTo_add_nc v hry₁ hry₂)
+            (es1a9_reducesTo_mul_nc v (es1a9_reducesTo_algebraMap_nc v W.a₁) hrx₁))
+          (es1a9_reducesTo_algebraMap_nc v W.a₃)
+      have hDconst : d + d + W.a₁ * c + W.a₃ ≠ 0 := by
+        have h1 : d + d + W.a₁ * c + W.a₃ = d - W.negY c d := by
+          simp only [negY]
+          ring
+        rw [h1]
+        exact sub_ne_zero.mpr h2tor
+      have hD0 : φ₁ (yGen W) + φ₂ (yGen W)
+          + algebraMap F W.FunctionField W.a₁ * φ₁ (polyToFunctionField W X)
+          + algebraMap F W.FunctionField W.a₃ ≠ 0 :=
+        (es1a9_reducesTo_ord_eq_zero_nc v hDred hDconst).1
+      have hslopeEq : (W.map (algebraMap F W.FunctionField)).toAffine.slope
+          (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+          (φ₁ (yGen W)) (φ₂ (yGen W))
+          = (φ₁ (polyToFunctionField W X) ^ 2
+              + φ₁ (polyToFunctionField W X) * φ₂ (polyToFunctionField W X)
+              + φ₂ (polyToFunctionField W X) ^ 2
+              + algebraMap F W.FunctionField W.a₂
+                * (φ₁ (polyToFunctionField W X) + φ₂ (polyToFunctionField W X))
+              + algebraMap F W.FunctionField W.a₄
+              - algebraMap F W.FunctionField W.a₁ * φ₂ (yGen W))
+            / (φ₁ (yGen W) + φ₂ (yGen W)
+              + algebraMap F W.FunctionField W.a₁ * φ₁ (polyToFunctionField W X)
+              + algebraMap F W.FunctionField W.a₃) := by
+        rw [slope_of_X_ne hξ, div_eq_div_iff (sub_ne_zero.mpr hξ) hD0]
+        linear_combination heq₁ - heq₂
+      rw [hslopeEq, slope_of_Y_ne (rfl : c = c) h2tor]
+      have hNred : es1a9_reducesTo_nc v
+          (φ₁ (polyToFunctionField W X) ^ 2
+            + φ₁ (polyToFunctionField W X) * φ₂ (polyToFunctionField W X)
+            + φ₂ (polyToFunctionField W X) ^ 2
+            + algebraMap F W.FunctionField W.a₂
+              * (φ₁ (polyToFunctionField W X) + φ₂ (polyToFunctionField W X))
+            + algebraMap F W.FunctionField W.a₄
+            - algebraMap F W.FunctionField W.a₁ * φ₂ (yGen W))
+          (c ^ 2 + c * c + c ^ 2 + W.a₂ * (c + c) + W.a₄ - W.a₁ * d) :=
+        es1a9_reducesTo_sub_nc v
+          (es1a9_reducesTo_add_nc v
+            (es1a9_reducesTo_add_nc v
+              (es1a9_reducesTo_add_nc v
+                (es1a9_reducesTo_add_nc v (es1a9_reducesTo_sq_nc v hrx₁)
+                  (es1a9_reducesTo_mul_nc v hrx₁ hrx₂))
+                (es1a9_reducesTo_sq_nc v hrx₂))
+              (es1a9_reducesTo_mul_nc v (es1a9_reducesTo_algebraMap_nc v W.a₂)
+                (es1a9_reducesTo_add_nc v hrx₁ hrx₂)))
+            (es1a9_reducesTo_algebraMap_nc v W.a₄))
+          (es1a9_reducesTo_mul_nc v (es1a9_reducesTo_algebraMap_nc v W.a₁) hry₂)
+      rw [show c ^ 2 + c * c + c ^ 2 + W.a₂ * (c + c) + W.a₄ - W.a₁ * d
+          = 3 * c ^ 2 + 2 * W.a₂ * c + W.a₄ - W.a₁ * d by ring] at hNred
+      have hDred' : es1a9_reducesTo_nc v
+          (φ₁ (yGen W) + φ₂ (yGen W)
+            + algebraMap F W.FunctionField W.a₁ * φ₁ (polyToFunctionField W X)
+            + algebraMap F W.FunctionField W.a₃)
+          (d - W.negY c d) := by
+        rwa [show d + d + W.a₁ * c + W.a₃ = d - W.negY c d by
+          simp only [negY]; ring] at hDred
+      exact es1a9_reducesTo_div_nc v hNred hDred' (sub_ne_zero.mpr h2tor)
+  have hXred : es1a9_reducesTo_nc v (es1a6_addSumX W φ₁ φ₂)
+      (W.addX c c (W.slope c c d d)) := by
+    rw [show es1a6_addSumX W φ₁ φ₂
+        = (W.map (algebraMap F W.FunctionField)).toAffine.addX
+          (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+          ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+            (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+            (φ₁ (yGen W)) (φ₂ (yGen W))) from rfl]
+    exact es1a9_addX_reducesTo_nc v hrx₁ hrx₂ hsl
+  have hYred : es1a9_reducesTo_nc v (es1a6_addSumY W φ₁ φ₂)
+      (W.addY c c d (W.slope c c d d)) := by
+    rw [show es1a6_addSumY W φ₁ φ₂
+        = (W.map (algebraMap F W.FunctionField)).toAffine.addY
+          (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X)) (φ₁ (yGen W))
+          ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+            (φ₁ (polyToFunctionField W X)) (φ₂ (polyToFunctionField W X))
+            (φ₁ (yGen W)) (φ₂ (yGen W))) from rfl]
+    exact es1a9_addY_reducesTo_nc v hrx₁ hrx₂ hry₁ hsl
+  rw [Point.add_of_Y_ne h2tor]
+  exact ⟨es1a9_ord_pos_of_reducesTo_of_ne_nc v hXred (hnc _),
+    es1a9_ord_pos_of_reducesTo_of_ne_nc v hYred
+      (es1a9_addSumY_ne_const_nc φ₁ φ₂ hcol hnc _)⟩
+
+end ChordTangentNc
+
+end Es1a1
+end ModularCurve
+
+end
+
+section
+
+namespace ModularCurve
+
+namespace Es1a1
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F]
+variable (W : Affine F) [W.IsElliptic]
+
+theorem kw_hk5f_addSumCoordSeamDataNCAt_proved : kw_hk5f_addSumCoordSeamDataNCAt W := by
+  intro φ₁ φ₂ hcol hnc v Q₁ Q₂ h1 h2
+  have hΔ : W.Δ ≠ 0 := W.isUnit_Δ.ne_zero
+  cases Q₁ with
+  | zero =>
+      cases Q₂ with
+      | zero =>
+          rw [show (Point.zero : W.Point) + Point.zero = (0 : W.Point) from rfl]
+          exact es1a10_ncVertical_seamDataAt_zero φ₁ φ₂ v
+            (es1a10_ncPole_bothPole_notMem φ₁ φ₂ v hΔ hcol h1 h2)
+      | some c d hns =>
+          rw [show (Point.zero : W.Point) = 0 from rfl, zero_add]
+          exact es1a10_ncPole_mixedOne_seamData φ₁ φ₂ v hcol hnc hns h1 h2.1 h2.2
+  | some c₁ d₁ hP₁ =>
+      cases Q₂ with
+      | zero =>
+          rw [show (Point.zero : W.Point) = 0 from rfl, add_zero]
+          exact es1a10_ncPole_mixedTwo_seamData φ₁ φ₂ v hcol hnc hP₁ h2 h1.1 h1.2
+      | some c₂ d₂ hP₂ =>
+          by_cases hx : c₁ = c₂
+          · by_cases hy : d₁ = W.negY c₂ d₂
+            · subst hx
+              exact es1a10_ncVertical_seamData φ₁ φ₂ v hcol hP₁ hP₂ hy
+                h1.1 h1.2 h2.1 h2.2
+            · have hyy : d₁ = d₂ :=
+                (Y_eq_of_X_eq hP₁.left hP₂.left hx).resolve_right hy
+              subst hx
+              subst hyy
+              exact es1a9_tangentCase_seamData_nc φ₁ φ₂ v hcol hnc hP₁ hy
+                h1.1 h1.2 h2.1 h2.2
+          · exact es1a9_chordCase_seamData_nc φ₁ φ₂ v hnc hP₁ hP₂ hx
+              h1.1 h1.2 h2.1 h2.2
+
+end Es1a1
+
+end ModularCurve
+
+end
+
+open ModularCurve.Es1a1 in
+universe u in
+theorem solution
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F]
+    (W : WeierstrassCurve.Affine F) [W.IsElliptic] [inst : DecidableEq W.FunctionField]
+    (φ₁ φ₂ : W.FunctionField →ₐ[F] W.FunctionField)
+    (hcol : ¬ (φ₁ (polyToFunctionField W Polynomial.X) = φ₂ (polyToFunctionField W Polynomial.X) ∧
+      φ₁ (yCoord W) = (W.map (algebraMap F W.FunctionField)).toAffine.negY
+        (φ₂ (polyToFunctionField W Polynomial.X)) (φ₂ (yCoord W))))
+    (hnc : ∀ c : F,
+      (W.map (algebraMap F W.FunctionField)).toAffine.addX
+          (φ₁ (polyToFunctionField W Polynomial.X)) (φ₂ (polyToFunctionField W Polynomial.X))
+          ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+            (φ₁ (polyToFunctionField W Polynomial.X)) (φ₂ (polyToFunctionField W Polynomial.X))
+            (φ₁ (yCoord W)) (φ₂ (yCoord W)))
+        ≠ algebraMap F W.FunctionField c)
+    (v : AlgebraicCurve.Place F W.FunctionField) (Q₁ Q₂ : W.Point)
+    (h₁0 : Q₁ = 0 → φ₁ (polyToFunctionField W Polynomial.X) ∉ v.toValuationSubring)
+    (h₁s : ∀ (a b : F) (h : W.Nonsingular a b), Q₁ = .some a b h →
+      0 < v.ord (φ₁ (polyToFunctionField W Polynomial.X) - algebraMap F W.FunctionField a) ∧
+        0 < v.ord (φ₁ (yCoord W) - algebraMap F W.FunctionField b))
+    (h₂0 : Q₂ = 0 → φ₂ (polyToFunctionField W Polynomial.X) ∉ v.toValuationSubring)
+    (h₂s : ∀ (a b : F) (h : W.Nonsingular a b), Q₂ = .some a b h →
+      0 < v.ord (φ₂ (polyToFunctionField W Polynomial.X) - algebraMap F W.FunctionField a) ∧
+        0 < v.ord (φ₂ (yCoord W) - algebraMap F W.FunctionField b)) :
+    (Q₁ + Q₂ = 0 →
+      (W.map (algebraMap F W.FunctionField)).toAffine.addX
+          (φ₁ (polyToFunctionField W Polynomial.X)) (φ₂ (polyToFunctionField W Polynomial.X))
+          ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+            (φ₁ (polyToFunctionField W Polynomial.X)) (φ₂ (polyToFunctionField W Polynomial.X))
+            (φ₁ (yCoord W)) (φ₂ (yCoord W)))
+        ∉ v.toValuationSubring) ∧
+    (∀ (a b : F) (h : W.Nonsingular a b), Q₁ + Q₂ = .some a b h →
+      0 < v.ord ((W.map (algebraMap F W.FunctionField)).toAffine.addX
+          (φ₁ (polyToFunctionField W Polynomial.X)) (φ₂ (polyToFunctionField W Polynomial.X))
+          ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+            (φ₁ (polyToFunctionField W Polynomial.X)) (φ₂ (polyToFunctionField W Polynomial.X))
+            (φ₁ (yCoord W)) (φ₂ (yCoord W)))
+        - algebraMap F W.FunctionField a) ∧
+      0 < v.ord ((W.map (algebraMap F W.FunctionField)).toAffine.addY
+          (φ₁ (polyToFunctionField W Polynomial.X)) (φ₂ (polyToFunctionField W Polynomial.X))
+          (φ₁ (yCoord W))
+          ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+            (φ₁ (polyToFunctionField W Polynomial.X)) (φ₂ (polyToFunctionField W Polynomial.X))
+            (φ₁ (yCoord W)) (φ₂ (yCoord W)))
+        - algebraMap F W.FunctionField b)) := by
+  have hinst : inst = Classical.decEq _ := Subsingleton.elim _ _
+  subst hinst
+  have h1 : es1a11_coordSeamDataAt φ₁ v Q₁ := by
+    cases Q₁ with
+    | zero => exact h₁0 rfl
+    | some a b h => exact h₁s a b h rfl
+  have h2 : es1a11_coordSeamDataAt φ₂ v Q₂ := by
+    cases Q₂ with
+    | zero => exact h₂0 rfl
+    | some a b h => exact h₂s a b h rfl
+  have H : es1a6_addSumSeamDataAt φ₁ φ₂ v (Q₁ + Q₂) :=
+    kw_hk5f_addSumCoordSeamDataNCAt_proved W φ₁ φ₂ (fun hc => hcol hc) hnc v Q₁ Q₂ h1 h2
+  refine ⟨fun h0 => ?_, fun a b h hs => ?_⟩
+  · rw [h0] at H; exact H
+  · rw [hs] at H; exact H
+
+end privateSection
+
+public section publicSection
+
+open WeierstrassCurve Affine AlgebraicCurve
+
+universe u
+theorem WeierstrassCurve.Affine.FunctionField.addX_addY_specialize_at_place
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F]
+    (W : WeierstrassCurve.Affine F) [W.IsElliptic] [DecidableEq W.FunctionField]
+    (φ₁ φ₂ : W.FunctionField →ₐ[F] W.FunctionField)
+    (hcol : ¬ (φ₁ (polyToFunctionField W Polynomial.X) = φ₂ (polyToFunctionField W Polynomial.X) ∧
+      φ₁ (yCoord W) = (W.map (algebraMap F W.FunctionField)).toAffine.negY
+        (φ₂ (polyToFunctionField W Polynomial.X)) (φ₂ (yCoord W))))
+    (hnc : ∀ c : F,
+      (W.map (algebraMap F W.FunctionField)).toAffine.addX
+          (φ₁ (polyToFunctionField W Polynomial.X)) (φ₂ (polyToFunctionField W Polynomial.X))
+          ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+            (φ₁ (polyToFunctionField W Polynomial.X)) (φ₂ (polyToFunctionField W Polynomial.X))
+            (φ₁ (yCoord W)) (φ₂ (yCoord W)))
+        ≠ algebraMap F W.FunctionField c)
+    (v : AlgebraicCurve.Place F W.FunctionField) (Q₁ Q₂ : W.Point)
+    (h₁0 : Q₁ = 0 → φ₁ (polyToFunctionField W Polynomial.X) ∉ v.toValuationSubring)
+    (h₁s : ∀ (a b : F) (h : W.Nonsingular a b), Q₁ = .some a b h →
+      0 < v.ord (φ₁ (polyToFunctionField W Polynomial.X) - algebraMap F W.FunctionField a) ∧
+        0 < v.ord (φ₁ (yCoord W) - algebraMap F W.FunctionField b))
+    (h₂0 : Q₂ = 0 → φ₂ (polyToFunctionField W Polynomial.X) ∉ v.toValuationSubring)
+    (h₂s : ∀ (a b : F) (h : W.Nonsingular a b), Q₂ = .some a b h →
+      0 < v.ord (φ₂ (polyToFunctionField W Polynomial.X) - algebraMap F W.FunctionField a) ∧
+        0 < v.ord (φ₂ (yCoord W) - algebraMap F W.FunctionField b)) :
+    (Q₁ + Q₂ = 0 →
+      (W.map (algebraMap F W.FunctionField)).toAffine.addX
+          (φ₁ (polyToFunctionField W Polynomial.X)) (φ₂ (polyToFunctionField W Polynomial.X))
+          ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+            (φ₁ (polyToFunctionField W Polynomial.X)) (φ₂ (polyToFunctionField W Polynomial.X))
+            (φ₁ (yCoord W)) (φ₂ (yCoord W)))
+        ∉ v.toValuationSubring) ∧
+    (∀ (a b : F) (h : W.Nonsingular a b), Q₁ + Q₂ = .some a b h →
+      0 < v.ord ((W.map (algebraMap F W.FunctionField)).toAffine.addX
+          (φ₁ (polyToFunctionField W Polynomial.X)) (φ₂ (polyToFunctionField W Polynomial.X))
+          ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+            (φ₁ (polyToFunctionField W Polynomial.X)) (φ₂ (polyToFunctionField W Polynomial.X))
+            (φ₁ (yCoord W)) (φ₂ (yCoord W)))
+        - algebraMap F W.FunctionField a) ∧
+      0 < v.ord ((W.map (algebraMap F W.FunctionField)).toAffine.addY
+          (φ₁ (polyToFunctionField W Polynomial.X)) (φ₂ (polyToFunctionField W Polynomial.X))
+          (φ₁ (yCoord W))
+          ((W.map (algebraMap F W.FunctionField)).toAffine.slope
+            (φ₁ (polyToFunctionField W Polynomial.X)) (φ₂ (polyToFunctionField W Polynomial.X))
+            (φ₁ (yCoord W)) (φ₂ (yCoord W)))
+        - algebraMap F W.FunctionField b)) :=
+  solution W φ₁ φ₂ hcol hnc v Q₁ Q₂ h₁0 h₁s h₂0 h₂s
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_FunctionField_adjoin_X_Y_eq_top.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_FunctionField_adjoin_X_Y_eq_top.lean
new file mode 100644
index 0000000000..d242d3f5bc
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_FunctionField_adjoin_X_Y_eq_top.lean
@@ -0,0 +1,145 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.FunctionField.adjoin_X_Y_eq_top
+(76a7f793-52a9-5d4b-9edd-47ed8f4898fa) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e2686d34-6332-5d00-a75c-a46b6ff22811
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Defs
+public import Mathlib.RingTheory.SimpleRing.Principal
+
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+
+/-!
+# The function field of a Weierstrass curve is K(x,y)
+
+Theorem statement: `WeierstrassCurve.Affine.FunctionField.adjoin_X_Y_eq_top`
+(`76a7f793-52a9-5d4b-9edd-47ed8f4898fa`), by Claude, 2026-09-05.
+
+Proof: submission `e2686d34-6332-5d00-a75c-a46b6ff22811`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $W$ be a Weierstrass curve over $K$, i.e. a tuple of coefficients
+$a_1,a_2,a_3,a_4,a_6$; no nonsingularity hypothesis is imposed. Write $W.\mathrm{toAffine}$ for the
+associated affine Weierstrass curve, $W.\mathrm{toAffine.CoordinateRing}$ for its coordinate ring,
+the quotient of the bivariate polynomial ring $K[X][Y]$ by the ideal generated by the Weierstrass
+polynomial $Y^2+a_1XY+a_3Y-(X^3+a_2X^2+a_4X+a_6)$, with quotient map
+`WeierstrassCurve.Affine.CoordinateRing.mk`, and $W.\mathrm{toAffine.FunctionField}$ for the
+fraction field of this coordinate ring. Let $\bar x$ and $\bar y$ be the images in the function
+field, under the structure map from the coordinate ring, of the classes of `Polynomial.C
+Polynomial.X` and of `Polynomial.X`, which are the inner and outer variables $X$ and $Y$ of
+$K[X][Y]$ respectively. The assertion is that the intermediate field of
+$W.\mathrm{toAffine.FunctionField}/K$ generated by the two-element set $\{\bar x,\bar y\}$, in the
+sense of `IntermediateField.adjoin`, is the whole function field: $K(\bar x,\bar y)=\top$.
+
+This is the standard fact $K(W)=K(x,y)$ for a curve given by a Weierstrass equation: the function
+field is generated over the base field by the two coordinate functions. It is the tool by which
+$K$-algebra maps out of the function field are pinned down by their values on $\bar x$ and $\bar y$,
+and it is used in the project in the bound on the degree of the function field over the subfield
+pulled back along multiplication-type maps,
+[`WeierstrassCurve.Affine.finrank_fieldRange_mulPull_le`]
+(thm.html#WeierstrassCurve.Affine.finrank_fieldRange_mulPull_le).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_FunctionField_adjoin_X_Y_eq_top.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+open Polynomial
+open scoped Bivariate
+
+namespace WeierstrassCurve
+
+namespace Affine
+
+variable {K : Type*} [Field K] (W : WeierstrassCurve K)
+
+theorem CoordinateRing.adjoin_mk_X_mk_Y :
+    Algebra.adjoin K {CoordinateRing.mk W.toAffine (C X), CoordinateRing.mk W.toAffine Y} = ⊤ := by
+  set x := CoordinateRing.mk W.toAffine (C X) with hx
+  set y := CoordinateRing.mk W.toAffine Y with hy
+  apply Algebra.eq_top_iff.mpr
+  intro r
+  induction r using AdjoinRoot.induction_on with
+  | ih p =>
+    have hC : ∀ c : K[X], CoordinateRing.mk W.toAffine (C c) ∈ Algebra.adjoin K {x, y} := by
+      intro c
+      have : CoordinateRing.mk W.toAffine (C c) = aeval x c := by
+        have h1 : (CoordinateRing.mk W.toAffine).comp C = (aeval x : K[X] →ₐ[K] _).toRingHom := by
+          apply Polynomial.ringHom_ext
+          · intro k
+            rw [RingHom.comp_apply, AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom, aeval_C]
+            rfl
+          · rw [RingHom.comp_apply, AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom, aeval_X]
+        exact congrArg (fun f : K[X] →+* _ => f c) h1
+      rw [this]
+      exact Algebra.adjoin_mono (Set.singleton_subset_iff.mpr (Set.mem_insert _ _))
+        (Polynomial.aeval_mem_adjoin_singleton K x)
+    induction p using Polynomial.induction_on with
+    | C c => exact hC c
+    | add p q hp hq => rw [map_add]; exact add_mem hp hq
+    | monomial n c _ =>
+      rw [map_mul, map_pow]
+      exact mul_mem (hC c)
+        (pow_mem (Algebra.subset_adjoin (Set.mem_insert_of_mem x (Set.mem_singleton y))) _)
+
+end WeierstrassCurve.Affine
+
+open WeierstrassCurve WeierstrassCurve.Affine in
+theorem solution {K : Type*} [Field K] (W : WeierstrassCurve K) :
+    IntermediateField.adjoin K
+    { algebraMap W.toAffine.CoordinateRing W.toAffine.FunctionField
+        (WeierstrassCurve.Affine.CoordinateRing.mk W.toAffine (Polynomial.C Polynomial.X)),
+      algebraMap W.toAffine.CoordinateRing W.toAffine.FunctionField
+        (WeierstrassCurve.Affine.CoordinateRing.mk W.toAffine Polynomial.X)} = ⊤ := by
+  set x := CoordinateRing.mk W.toAffine (C X)
+  set y := CoordinateRing.mk W.toAffine Y
+  set S : IntermediateField K W.toAffine.FunctionField := IntermediateField.adjoin K
+    {algebraMap W.toAffine.CoordinateRing W.toAffine.FunctionField x,
+      algebraMap W.toAffine.CoordinateRing W.toAffine.FunctionField y} with hS
+  have hR : ∀ r : W.toAffine.CoordinateRing,
+      algebraMap W.toAffine.CoordinateRing W.toAffine.FunctionField r ∈ S := by
+    intro r
+    let φ : W.toAffine.CoordinateRing →ₐ[K] W.toAffine.FunctionField :=
+      IsScalarTower.toAlgHom K W.toAffine.CoordinateRing W.toAffine.FunctionField
+    have hr : r ∈ (⊤ : Subalgebra K W.toAffine.CoordinateRing) := Algebra.mem_top
+    rw [← CoordinateRing.adjoin_mk_X_mk_Y W] at hr
+    have himg : φ r ∈ (Algebra.adjoin K {x, y}).map φ := Subalgebra.mem_map.mpr ⟨r, hr, rfl⟩
+    rw [AlgHom.map_adjoin] at himg
+    have hle : Algebra.adjoin K (φ '' {x, y}) ≤ S.toSubalgebra := by
+      rw [Set.image_pair]
+      exact IntermediateField.algebra_adjoin_le_adjoin K _
+    exact hle himg
+  apply eq_top_iff.mpr
+  intro z _
+  obtain ⟨a, b, -, rfl⟩ := IsFractionRing.div_surjective (A := W.toAffine.CoordinateRing) z
+  exact div_mem (hR a) (hR b)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.Affine.FunctionField.adjoin_X_Y_eq_top {K : Type*} [Field K]
+    (W : WeierstrassCurve K) :
+    IntermediateField.adjoin K
+    { algebraMap W.toAffine.CoordinateRing W.toAffine.FunctionField
+        (WeierstrassCurve.Affine.CoordinateRing.mk W.toAffine (Polynomial.C Polynomial.X)),
+      algebraMap W.toAffine.CoordinateRing W.toAffine.FunctionField
+        (WeierstrassCurve.Affine.CoordinateRing.mk W.toAffine Polynomial.X)} = ⊤ :=
+  solution W
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_FunctionField_eq_valuationSubring_of_X_not_mem.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_FunctionField_eq_valuationSubring_of_X_not_mem.lean
new file mode 100644
index 0000000000..7ff73ef686
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_FunctionField_eq_valuationSubring_of_X_not_mem.lean
@@ -0,0 +1,340 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.FunctionField.eq_valuationSubring_of_X_not_mem
+(bff6a520-dc9f-5b24-835e-8bcc33de64d9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4641f4d0-4caa-5cb4-8802-9b2a4c39f633
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import Mathlib.RingTheory.Valuation.ValuationSubring
+
+import Mathlib.RingTheory.Norm.Basic
+import Mathlib.Algebra.Polynomial.Degree.SmallDegree
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The place at infinity of a Weierstrass function field
+
+Theorem statement: `WeierstrassCurve.Affine.FunctionField.eq_valuationSubring_of_X_not_mem`
+(`bff6a520-dc9f-5b24-835e-8bcc33de64d9`), by Claude, 2026-09-05.
+
+Proof: submission `4641f4d0-4caa-5cb4-8802-9b2a4c39f633`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and $W$ a Weierstrass curve over $K$, with affine coordinate ring $K[W] =
+(K[X])[Y]/(W\text{-polynomial})$ and function field $K(W)$, the fraction field of $K[W]$. Let $O$ be
+a valuation subring of $K(W)$ such that (i) the image of every constant $c \in K$ under the
+structure map $K \to K(W)$ lies in $O$, and (ii) the image in $K(W)$ of the class of $\mathrm{C}\,X
+\in (K[X])[Y]$ — that is, the coordinate function $x$ — does not lie in $O$. Let $v$ be a valuation
+on $K(W)$ with values in $\mathbb{Z} \cup \{0\}$ written multiplicatively as
+$\mathrm{WithZero}(\mathrm{Multiplicative}\,\mathbb{Z})$, satisfying $v(f) = \exp\bigl(\deg
+N(f)\bigr)$ for every nonzero $f \in K[W]$, where $N = \mathrm{Algebra.norm}$ for the extension
+$K[W]/K[X]$ and $\deg$ is the degree of the resulting polynomial in $K[X]$. Then $O$ coincides with
+the valuation subring $\{g \in K(W) : v(g) \le 1\}$ of $v$.
+
+This identifies the unique place of the function field of a Weierstrass curve at which the
+coordinate function $x$ has a pole, namely the place of the point at infinity, characterised here as
+the valuation subring of the degree-of-norm valuation; together with the description of the places
+containing $x$ it classifies the places of $K(W)$ trivial on $K$. It is used in the construction of
+places attached to points and in establishing that divisors of degree zero on a Weierstrass curve
+over an algebraically closed field are principal.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_FunctionField_eq_valuationSubring_of_X_not_mem.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_FunctionField_eq_valuationSubring_of_X_not_mem
+
+open scoped Polynomial.Bivariate WithZero nonZeroDivisors
+p2m_open "Polynomial Polynomial.Bivariate.Polynomial"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine a₃ a₁ Affine.CoordinateRing mk a₄ a₂ a₆ Affine.FunctionField \
+  toAffine Affine.Point Affine.CoordinateRing.mk Affine.polynomial"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "CoordinateRing CoordinateRing.smul FunctionField Point \
+  CoordinateRing.mk CoordinateRing.exists_smul_basis_eq CoordinateRing.basis polynomial"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+variable {K : Type*} [Field K] (W : Affine K)
+
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "smul mk degree_norm_smul_basis \
+  exists_smul_basis_eq"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing"
+
+lemma natDegree_norm_smul_basis_of_eq_zero (p : K[X]) :
+    (Algebra.norm K[X] (p • (1 : W.CoordinateRing) + (0 : K[X]) • mk W Y)).natDegree =
+      2 * p.natDegree := by
+  by_cases hp : p = 0
+  · subst hp
+    have : (0 : K[X]) • (1 : W.CoordinateRing) + (0 : K[X]) • mk W Y = 0 := by simp
+    rw [this, (Algebra.norm_eq_zero_iff_of_basis (CoordinateRing.basis W)).mpr rfl,
+      natDegree_zero]
+  · have h := degree_norm_smul_basis (W' := W) p 0
+    rw [degree_zero, degree_eq_natDegree hp, two_nsmul, two_nsmul, WithBot.bot_add,
+      WithBot.bot_add, max_bot_right] at h
+    apply natDegree_eq_of_degree_eq_some
+    rw [h, two_mul]
+    rfl
+
+lemma natDegree_norm_smul_basis_of_ne_zero (p q : K[X]) (hq : q ≠ 0) :
+    (Algebra.norm K[X] (p • (1 : W.CoordinateRing) + q • mk W Y)).natDegree =
+      max (2 * p.natDegree) (2 * q.natDegree + 3) := by
+  have h := degree_norm_smul_basis (W' := W) p q
+  apply natDegree_eq_of_degree_eq_some
+  rw [h, degree_eq_natDegree hq]
+  by_cases hp : p = 0
+  · subst hp
+    rw [degree_zero, two_nsmul, WithBot.bot_add, max_bot_left, natDegree_zero, mul_zero,
+      Nat.zero_max, two_nsmul, two_mul]
+    rfl
+  · rw [degree_eq_natDegree hp, two_nsmul, two_nsmul, two_mul, two_mul]
+    rfl
+
+lemma mk_Y_mul_mk_Y_add :
+    mk W Y * (mk W Y + mk W (C (C W.a₁ * X + C W.a₃))) =
+      mk W (C (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆)) := by
+  have h : mk W (Y ^ 2 + C (C W.a₁ * X + C W.a₃) * Y) =
+      mk W (C (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆)) :=
+    AdjoinRoot.mk_eq_mk.mpr ⟨1, by rw [WeierstrassCurve.Affine.polynomial]; ring1⟩
+  rw [map_add, map_mul, map_pow] at h
+  rw [← h]
+  ring
+
+end CoordinateRing
+
+private lemma _root_.Valuation.map_aeval_eq_pow_of_one_lt {K L Γ : Type*} [Field K] [CommRing L]
+    [Algebra K L] [LinearOrderedCommGroupWithZero Γ] (w : Valuation L Γ)
+    (hK : ∀ c : K, c ≠ 0 → w (algebraMap K L c) = 1) {z : L} (hz : 1 < w z) {p : K[X]}
+    (hp : p ≠ 0) : w (aeval z p) = w z ^ p.natDegree := by
+  classical
+  have hz0 : w z ≠ 0 := ne_of_gt (lt_trans zero_lt_one hz)
+  have hterm : ∀ i, w (p.coeff i • z ^ i) = if p.coeff i = 0 then 0 else w z ^ i := by
+    intro i
+    split_ifs with hc
+    · rw [hc, zero_smul, map_zero]
+    · rw [Algebra.smul_def, map_mul, map_pow, hK _ hc, one_mul]
+  rw [aeval_eq_sum_range]
+  have hlc : p.coeff p.natDegree ≠ 0 := mt leadingCoeff_eq_zero.mp hp
+  have hn : w (p.coeff p.natDegree • z ^ p.natDegree) = w z ^ p.natDegree := by
+    rw [hterm, ite_eq_right hlc]
+  rw [← hn]
+  apply w.map_sum_eq_of_lt (Finset.self_mem_range_succ _)
+  intro i hi
+  rw [Finset.mem_sdiff, Finset.mem_range, Finset.mem_singleton] at hi
+  have hi' : i < p.natDegree := lt_of_le_of_ne (Nat.lt_succ_iff.mp hi.1) hi.2
+  rw [hn, hterm]
+  split_ifs
+  · exact pow_pos (lt_trans zero_lt_one hz) _
+  · exact pow_lt_pow_right₀ hz hi'
+
+namespace FunctionField
+
+lemma algebraMap_mk_C_C (c : K) :
+    algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W (C (C c))) =
+      algebraMap K W.FunctionField c := by
+  rw [IsScalarTower.algebraMap_apply K W.CoordinateRing W.FunctionField]
+  rfl
+
+lemma algebraMap_mk_C (p : K[X]) :
+    algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W (C p)) =
+      aeval (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W (C X))) p := by
+  have : (algebraMap W.CoordinateRing W.FunctionField).comp ((CoordinateRing.mk W).comp C) =
+      (aeval (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W (C X))) :
+        K[X] →ₐ[K] W.FunctionField).toRingHom := by
+    apply Polynomial.ringHom_ext
+    · intro c
+      simp only [RingHom.comp_apply, AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom, aeval_C]
+      exact algebraMap_mk_C_C W c
+    · simp only [RingHom.comp_apply, AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom, aeval_X]
+  exact RingHom.congr_fun this p
+
+section InftyPlace
+
+variable {W}
+variable {O : ValuationSubring W.FunctionField}
+  (hK : ∀ c : K, algebraMap K W.FunctionField c ∈ O)
+  (hx : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W (C X)) ∉ O)
+
+include hK in
+lemma valuation_algebraMap_K {c : K} (hc : c ≠ 0) :
+    O.valuation (algebraMap K W.FunctionField c) = 1 := by
+  have hc0 : algebraMap K W.FunctionField c ≠ 0 := by simpa using hc
+  refine le_antisymm ((O.valuation_le_one_iff _).mpr (hK c)) ?_
+  rw [Valuation.one_le_val_iff _ hc0, ← map_inv₀]
+  exact (O.valuation_le_one_iff _).mpr (hK c⁻¹)
+
+include hK hx in
+lemma valuation_algebraMap_sq {f : W.CoordinateRing} (hf : f ≠ 0) :
+    O.valuation (algebraMap W.CoordinateRing W.FunctionField f) ^ 2 =
+      O.valuation (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W (C X))) ^
+        (Algebra.norm K[X] f).natDegree := by
+  classical
+  have hγ1 : 1 < O.valuation
+      (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W (C X))) := by
+    rw [← not_le, O.valuation_le_one_iff]; exact hx
+  set ι := algebraMap W.CoordinateRing W.FunctionField with hι
+  set w := O.valuation with hw
+  set γ := w (ι (CoordinateRing.mk W (C X))) with hγ
+  set δ := w (ι (CoordinateRing.mk W Y)) with hδdef
+  have hK' : ∀ c : K, c ≠ 0 → w (algebraMap K W.FunctionField c) = 1 :=
+    fun c hc => valuation_algebraMap_K hK hc
+  have hC : ∀ {p : K[X]}, p ≠ 0 → w (ι (CoordinateRing.mk W (C p))) = γ ^ p.natDegree := by
+    intro p hp
+    rw [hι, algebraMap_mk_C]
+    exact w.map_aeval_eq_pow_of_one_lt hK' hγ1 hp
+  have hC0 : ∀ p : K[X], w (ι (CoordinateRing.mk W (C p))) ≤ γ ^ p.natDegree := by
+    intro p
+    by_cases hp : p = 0
+    · rw [hp, map_zero, map_zero, map_zero]; exact zero_le
+    · exact (hC hp).le
+  have hδ : δ ^ 2 = γ ^ 3 := by
+    have hrel : w (ι (CoordinateRing.mk W Y)) *
+        w (ι (CoordinateRing.mk W Y) + ι (CoordinateRing.mk W (C (C W.a₁ * X + C W.a₃)))) =
+        w (ι (CoordinateRing.mk W (C (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆)))) := by
+      rw [← map_add ι, ← map_mul w, ← map_mul ι, CoordinateRing.mk_Y_mul_mk_Y_add]
+    have h3 : (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ : K[X]).natDegree = 3 := by
+      rw [← one_mul (X ^ 3 : K[X]), ← C_1]; exact natDegree_cubic one_ne_zero
+    have hne : (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ : K[X]) ≠ 0 := by
+      intro h; rw [h, natDegree_zero] at h3; exact absurd h3 (by norm_num)
+    have hd : w (ι (CoordinateRing.mk W (C (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆)))) =
+        γ ^ 3 := by rw [hC hne, h3]
+    have hc : w (ι (CoordinateRing.mk W (C (C W.a₁ * X + C W.a₃)))) ≤ γ := by
+      refine (hC0 _).trans ?_
+      calc γ ^ (C W.a₁ * X + C W.a₃).natDegree ≤ γ ^ 1 :=
+            pow_le_pow_right₀ hγ1.le natDegree_linear_le
+        _ = γ := pow_one γ
+    rw [hd] at hrel
+    have hγδ : γ < δ := by
+      by_contra hle
+      rw [not_lt] at hle
+      have h1 : w (ι (CoordinateRing.mk W Y) + ι (CoordinateRing.mk W (C (C W.a₁ * X + C W.a₃))))
+          ≤ γ := (w.map_add _ _).trans (max_le hle hc)
+      have h2 : γ ^ 3 ≤ γ * γ := hrel ▸ mul_le_mul' hle h1
+      have h3 : γ * γ < γ ^ 3 := by rw [← pow_two]; exact pow_lt_pow_right₀ hγ1 (by norm_num)
+      exact absurd h2 (not_le.mpr h3)
+    have hadd : w (ι (CoordinateRing.mk W Y) + ι (CoordinateRing.mk W (C (C W.a₁ * X + C W.a₃))))
+        = δ := w.map_add_eq_of_lt_left (lt_of_le_of_lt hc hγδ)
+    rw [hadd, ← pow_two] at hrel
+    exact hrel
+  obtain ⟨p, q, rfl⟩ := CoordinateRing.exists_smul_basis_eq f
+  have hsplit : ι (p • (1 : W.CoordinateRing) + q • CoordinateRing.mk W Y) =
+      ι (CoordinateRing.mk W (C p)) + ι (CoordinateRing.mk W (C q)) * ι (CoordinateRing.mk W Y) :=
+        by
+    rw [CoordinateRing.smul, CoordinateRing.smul, mul_one, map_add, map_mul]
+  rw [hsplit]
+  by_cases hq : q = 0
+  · subst hq
+    have hp : p ≠ 0 := by rintro rfl; exact hf (by simp)
+    rw [CoordinateRing.natDegree_norm_smul_basis_of_eq_zero]
+    rw [map_zero, map_zero, map_zero, zero_mul, add_zero, hC hp, ← pow_mul, mul_comm]
+  · rw [CoordinateRing.natDegree_norm_smul_basis_of_ne_zero _ _ _ hq]
+    have hB : w (ι (CoordinateRing.mk W (C q)) * ι (CoordinateRing.mk W Y)) =
+        γ ^ q.natDegree * δ := by rw [map_mul, hC hq]
+    have hB2 : (γ ^ q.natDegree * δ) ^ 2 = γ ^ (2 * q.natDegree + 3) := by
+      rw [mul_pow, hδ, ← pow_mul, ← pow_add]; ring_nf
+    by_cases hp : p = 0
+    · subst hp
+      rw [map_zero, map_zero, map_zero, zero_add, natDegree_zero, mul_zero, Nat.zero_max, hB,
+        hB2]
+    · have hA : w (ι (CoordinateRing.mk W (C p))) = γ ^ p.natDegree := hC hp
+      have hA2 : (γ ^ p.natDegree) ^ 2 = γ ^ (2 * p.natDegree) := by rw [← pow_mul, mul_comm]
+      have hne : w (ι (CoordinateRing.mk W (C p))) ≠
+          w (ι (CoordinateRing.mk W (C q)) * ι (CoordinateRing.mk W Y)) := by
+        rw [hA, hB]
+        intro h
+        have h2 := congrArg (· ^ 2) h
+        simp only [hA2, hB2] at h2
+        have := (pow_right_strictMono₀ hγ1).injective h2
+        omega
+      rw [w.map_add_of_distinct_val hne, hA, hB]
+      rcases le_total (γ ^ p.natDegree) (γ ^ q.natDegree * δ) with h | h
+      · rw [max_eq_right h, hB2]
+        have h2 : (γ ^ p.natDegree) ^ 2 ≤ (γ ^ q.natDegree * δ) ^ 2 :=
+          pow_le_pow_left₀ zero_le h 2
+        rw [hA2, hB2, pow_le_pow_iff_right₀ hγ1] at h2
+        rw [max_eq_right h2]
+      · rw [max_eq_left h, hA2]
+        have h2 : (γ ^ q.natDegree * δ) ^ 2 ≤ (γ ^ p.natDegree) ^ 2 :=
+          pow_le_pow_left₀ zero_le h 2
+        rw [hA2, hB2, pow_le_pow_iff_right₀ hγ1] at h2
+        rw [max_eq_left h2]
+
+end InftyPlace
+
+theorem eq_valuationSubring_of_X_not_mem_aux (O : ValuationSubring W.FunctionField)
+    (hK : ∀ c : K, algebraMap K W.FunctionField c ∈ O)
+    (hx : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W (C X)) ∉ O)
+    (v : Valuation W.FunctionField ℤᵐ⁰)
+    (hv : ∀ f : W.CoordinateRing, f ≠ 0 → v (algebraMap W.CoordinateRing W.FunctionField f) =
+      WithZero.exp ((Algebra.norm K[X] f).natDegree : ℤ)) :
+    O = v.valuationSubring := by
+  classical
+  have hγ1 : 1 < O.valuation
+      (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W (C X))) := by
+    rw [← not_le, O.valuation_le_one_iff]; exact hx
+  have hι : ∀ {f : W.CoordinateRing}, f ≠ 0 →
+      algebraMap W.CoordinateRing W.FunctionField f ≠ 0 := fun hf h =>
+    hf (IsFractionRing.injective W.CoordinateRing W.FunctionField (by rwa [map_zero]))
+  ext z
+  obtain ⟨a, b, hb, rfl⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb
+  rw [Valuation.mem_valuationSubring_iff, ← O.valuation_le_one_iff]
+  by_cases ha : a = 0
+  · subst ha; simp
+  rw [map_div₀, map_div₀, hv a ha, hv b hb0,
+    div_le_one₀ ((Valuation.pos_iff _).mpr (hι hb0)), div_le_one₀ WithZero.exp_pos,
+    WithZero.exp_le_exp, Nat.cast_le, ← pow_le_pow_iff_right₀ hγ1,
+    ← valuation_algebraMap_sq hK hx ha, ← valuation_algebraMap_sq hK hx hb0]
+  exact ⟨fun h => pow_le_pow_left₀ zero_le h 2,
+    fun h => le_of_pow_le_pow_left₀ two_ne_zero zero_le h⟩
+
+end FunctionField
+
+end WeierstrassCurve.Affine
+
+theorem solution {K : Type*} [Field K] (W : WeierstrassCurve K) (O : ValuationSubring
+  W.toAffine.FunctionField) (hK : ∀ c : K, algebraMap K W.toAffine.FunctionField c ∈ O) (hX :
+  algebraMap W.toAffine.CoordinateRing W.toAffine.FunctionField
+  (WeierstrassCurve.Affine.CoordinateRing.mk W.toAffine (Polynomial.C Polynomial.X)) ∉ O) (v :
+  Valuation W.toAffine.FunctionField (WithZero (Multiplicative ℤ))) (hv : ∀ f :
+  W.toAffine.CoordinateRing, f ≠ 0 → v (algebraMap W.toAffine.CoordinateRing
+  W.toAffine.FunctionField f) = WithZero.exp ((Algebra.norm (Polynomial K) f).natDegree : ℤ)) :
+    O = v.valuationSubring :=
+  WeierstrassCurve.Affine.FunctionField.eq_valuationSubring_of_X_not_mem_aux W.toAffine O hK hX v hv
+
+end S_WeierstrassCurve_Affine_FunctionField_eq_valuationSubring_of_X_not_mem
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_FunctionField_eq_valuationSubring_of_X_not_mem (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.Affine.FunctionField.eq_valuationSubring_of_X_not_mem {K : Type*} [Field K]
+  (W : WeierstrassCurve K) (O : ValuationSubring W.toAffine.FunctionField) (hK : ∀ c : K, algebraMap
+  K W.toAffine.FunctionField c ∈ O) (hX : algebraMap W.toAffine.CoordinateRing
+  W.toAffine.FunctionField (WeierstrassCurve.Affine.CoordinateRing.mk W.toAffine (Polynomial.C
+  Polynomial.X)) ∉ O) (v : Valuation W.toAffine.FunctionField (WithZero (Multiplicative ℤ))) (hv : ∀
+  f : W.toAffine.CoordinateRing, f ≠ 0 → v (algebraMap W.toAffine.CoordinateRing
+  W.toAffine.FunctionField f) = WithZero.exp ((Algebra.norm (Polynomial K) f).natDegree : ℤ)) :
+    O = v.valuationSubring :=
+  solution W O hK hX v hv
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_FunctionField_exists_eq_algebraMap_of_valuation_eq_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_FunctionField_exists_eq_algebraMap_of_valuation_eq_one.lean
new file mode 100644
index 0000000000..8e86fa18ba
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_FunctionField_exists_eq_algebraMap_of_valuation_eq_one.lean
@@ -0,0 +1,180 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.Affine.FunctionField.exists_eq_algebraMap_of_valuation_eq_one
+(3180b122-1bc0-5283-bc24-20ba69c94aeb) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission dbe9c74f-476c-5ddf-badb-85457ebaf495
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.RingTheory.DedekindDomain.AdicValuation
+public import Mathlib.RingTheory.SimpleRing.Principal
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Everywhere trivial valuation forces a constant function
+
+Theorem statement: `WeierstrassCurve.Affine.FunctionField.exists_eq_algebraMap_of_valuation_eq_one`
+(`3180b122-1bc0-5283-bc24-20ba69c94aeb`), by Claude, 2026-09-05.
+
+Proof: submission `dbe9c74f-476c-5ddf-badb-85457ebaf495`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field and $W$ a Weierstrass curve over $F$, and assume the affine coordinate ring
+`W.toAffine.CoordinateRing`, i.e. $F[X,Y]$ modulo the Weierstrass polynomial of $W$, is a Dedekind
+domain. Let $f$ be an element of the function field `W.toAffine.FunctionField`, the fraction field
+of that coordinate ring. Suppose that for every $v$ in the height-one spectrum of the coordinate
+ring — that is, every nonzero prime ideal — the associated $v$-adic valuation of $f$, taken in the
+multiplicative value group $\mathbb{Z}_{m_0}$ attached to $v$ by
+`IsDedekindDomain.HeightOneSpectrum.valuation`, is equal to $1$; equivalently, $f$ has order $0$ at
+every such $v$, so neither a zero nor a pole. The conclusion is that there exists $c \in F$ with $c
+\neq 0$ and $f$ equal to the image of $c$ under the structure map $F \to$
+`W.toAffine.FunctionField`. No condition at the point at infinity is imposed.
+
+This is the form of the classical statement that a rational function on an elliptic curve with
+trivial divisor is constant (Silverman, AEC II.1.2, II.3.1), phrased purely in terms of the
+height-one valuations of the affine coordinate ring. It is used in the construction of the Weil
+pairing, where ratios of translated functions are shown to be constant: among the results citing it
+are
+[`WeierstrassCurve.Affine.exists_map_weilFun_eq_mul_weilFun_map_of_algHom`]
+(thm.html#WeierstrassCurve.Affine.exists_map_weilFun_eq_mul_weilFun_map_of_algHom),
+[`WeierstrassCurve.Affine.exists_map_weilFun_eq_mul_weilFun_smul`]
+(thm.html#WeierstrassCurve.Affine.exists_map_weilFun_eq_mul_weilFun_smul)
+and
+[`WeierstrassCurve.Affine.exists_transEquiv_weilFun_eq`]
+(thm.html#WeierstrassCurve.Affine.exists_transEquiv_weilFun_eq).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_FunctionField_exists_eq_algebraMap_of_valuation_eq_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_FunctionField_exists_eq_algebraMap_of_valuation_eq_one
+
+p2m_open "Polynomial WeierstrassCurve \
+  P2MW.S_WeierstrassCurve_Affine_FunctionField_exists_eq_algebraMap_of_valuation_eq_one.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_WeierstrassCurve_Affine_FunctionField_exists_eq_algebraMap_of_valuation_eq_one.Weierstrass\
+  Curve.Affine"
+open scoped Polynomial.Bivariate nonZeroDivisors
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map Affine.CoordinateRing mk toAffine Affine.Point"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "CoordinateRing.smul_basis_eq_zero \
+  CoordinateRing.XClass_ne_zero CoordinateRing.norm_smul_basis CoordinateRing CoordinateRing.smul \
+  map FunctionField Point CoordinateRing.mk CoordinateRing.degree_norm_smul_basis \
+  CoordinateRing.exists_smul_basis_eq CoordinateRing.XClass"
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "smul_basis_eq_zero XClass_ne_zero \
+  norm_smul_basis smul mk map degree_norm_smul_basis exists_smul_basis_eq XClass"
+namespace DetInfra
+p2m_open "WeierstrassCurve.Affine.CoordinateRing WeierstrassCurve.Affine WeierstrassCurve"
+
+theorem isUnit_iff_eq_algebraMap' {F : Type*} [Field F] {W : WeierstrassCurve F}
+    (f : W.toAffine.CoordinateRing) :
+    IsUnit f ↔ ∃ c : F, c ≠ 0 ∧ f = algebraMap F W.toAffine.CoordinateRing c := by
+  constructor
+  · intro hf
+    obtain ⟨p, q, rfl⟩ := CoordinateRing.exists_smul_basis_eq f
+    have hnu : IsUnit (Algebra.norm F[X] (p • (1 : W.toAffine.CoordinateRing) +
+        q • CoordinateRing.mk W.toAffine Y)) := hf.map _
+    have hdeg := Polynomial.degree_eq_zero_of_isUnit hnu
+    rw [CoordinateRing.degree_norm_smul_basis] at hdeg
+    have hq : q = 0 := by
+      by_contra hq
+      have h3 : (2 • q.degree + 3 : WithBot ℕ) = ((2 * q.natDegree + 3 : ℕ) : WithBot ℕ) := by
+        rw [Polynomial.degree_eq_natDegree hq]
+        norm_cast
+      have hle : ((2 * q.natDegree + 3 : ℕ) : WithBot ℕ) ≤ (0 : WithBot ℕ) := by
+        rw [← h3, ← hdeg]
+        exact le_max_right _ _
+      have hle' : 2 * q.natDegree + 3 ≤ 0 := by exact_mod_cast hle
+      omega
+    subst hq
+    rw [zero_smul, add_zero] at hnu ⊢
+    have hnp : Algebra.norm F[X] (p • (1 : W.toAffine.CoordinateRing)) = p ^ 2 := by
+      have := CoordinateRing.norm_smul_basis (W' := W.toAffine) p 0
+      rw [zero_smul, add_zero] at this
+      rw [this]
+      ring
+    rw [hnp, isUnit_pow_iff two_ne_zero, Polynomial.isUnit_iff] at hnu
+    obtain ⟨c, hc, rfl⟩ := hnu
+    refine ⟨c, hc.ne_zero, ?_⟩
+    rw [CoordinateRing.smul, mul_one]
+    rfl
+  · rintro ⟨c, hc, rfl⟩
+    exact (IsUnit.mk0 c hc).map _
+
+theorem XClass_not_isUnit {F : Type*} [Field F] {W : WeierstrassCurve F} (x : F) :
+    ¬IsUnit (CoordinateRing.XClass W.toAffine x) := by
+  rw [isUnit_iff_eq_algebraMap']
+  rintro ⟨c, -, hc⟩
+  have h1 : (X - C x - C c) • (1 : W.toAffine.CoordinateRing) + (0 : F[X]) • CoordinateRing.mk
+    W.toAffine Y = 0 :=
+    by
+    rw [zero_smul, add_zero, sub_smul, CoordinateRing.smul, mul_one, CoordinateRing.smul, mul_one,
+      sub_eq_zero]
+    exact hc
+  have := (CoordinateRing.smul_basis_eq_zero h1).1
+  have h2 := congrArg Polynomial.natDegree this
+  rw [sub_sub, ← C_add, natDegree_X_sub_C, natDegree_zero] at h2
+  exact one_ne_zero h2
+
+end WeierstrassCurve.Affine.CoordinateRing.DetInfra
+
+open WeierstrassCurve.Affine.CoordinateRing.DetInfra
+
+theorem solution {F : Type*} [Field F] {W : WeierstrassCurve F} [IsDedekindDomain
+  W.toAffine.CoordinateRing] {f : W.toAffine.FunctionField} (hf : ∀ v :
+  IsDedekindDomain.HeightOneSpectrum W.toAffine.CoordinateRing, v.valuation W.toAffine.FunctionField
+  f = 1) :
+    ∃ c : F, c ≠ 0 ∧ f = algebraMap F W.toAffine.FunctionField c := by
+  obtain ⟨M, hMmax, hXM⟩ := exists_max_ideal_of_mem_nonunits (XClass_not_isUnit (W := W) 0)
+  have hM0 : M ≠ ⊥ := fun h =>
+    CoordinateRing.XClass_ne_zero (W' := W.toAffine) 0 (by rwa [h, Ideal.mem_bot] at hXM)
+  let v₀ : IsDedekindDomain.HeightOneSpectrum W.toAffine.CoordinateRing := ⟨M, hMmax.isPrime, hM0⟩
+  have hf0 : f ≠ 0 := fun h => by simpa [h] using hf v₀
+  obtain ⟨g, hg⟩ := IsDedekindDomain.HeightOneSpectrum.mem_integers_of_valuation_le_one
+    W.toAffine.FunctionField f (fun v => (hf v).le)
+  obtain ⟨g', hg'⟩ := IsDedekindDomain.HeightOneSpectrum.mem_integers_of_valuation_le_one
+    W.toAffine.FunctionField f⁻¹ (fun v => by rw [map_inv₀, hf v, inv_one])
+  have hgg' : g * g' = 1 := by
+    apply IsFractionRing.injective W.toAffine.CoordinateRing W.toAffine.FunctionField
+    rw [map_mul, hg, hg', map_one, mul_inv_cancel₀ hf0]
+  obtain ⟨c, hc, hgc⟩ := (isUnit_iff_eq_algebraMap' g).mp (IsUnit.of_mul_eq_one g' hgg')
+  refine ⟨c, hc, ?_⟩
+  rw [← hg, hgc, ← IsScalarTower.algebraMap_apply]
+
+end S_WeierstrassCurve_Affine_FunctionField_exists_eq_algebraMap_of_valuation_eq_one
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_FunctionField_exists_eq_algebraMap_of_valuation_eq_one
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem WeierstrassCurve.Affine.FunctionField.exists_eq_algebraMap_of_valuation_eq_one {F : Type*}
+  [Field F] {W : WeierstrassCurve F} [IsDedekindDomain W.toAffine.CoordinateRing] {f :
+  W.toAffine.FunctionField} (hf : ∀ v : IsDedekindDomain.HeightOneSpectrum
+  W.toAffine.CoordinateRing, v.valuation W.toAffine.FunctionField f = 1) :
+    ∃ c : F, c ≠ 0 ∧ f = algebraMap F W.toAffine.FunctionField c :=
+  solution hf
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_FunctionField_exists_eq_valuationSubring_of_X_mem.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_FunctionField_exists_eq_valuationSubring_of_X_mem.lean
new file mode 100644
index 0000000000..552eb3faf4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_FunctionField_exists_eq_valuationSubring_of_X_mem.lean
@@ -0,0 +1,201 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.FunctionField.exists_eq_valuationSubring_of_X_mem
+(c94ee531-818b-58a6-a89d-826b093bfee8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 61507dd4-3a20-5ddb-a72f-5d0553eeb794
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.RingTheory.DedekindDomain.AdicValuation
+public import Mathlib.RingTheory.SimpleRing.Principal
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Valuation rings of K(W) containing x are finite places
+
+Theorem statement: `WeierstrassCurve.Affine.FunctionField.exists_eq_valuationSubring_of_X_mem`
+(`c94ee531-818b-58a6-a89d-826b093bfee8`), by Claude, 2026-09-05.
+
+Proof: submission `61507dd4-3a20-5ddb-a72f-5d0553eeb794`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and $W$ a Weierstrass curve over $K$, and assume that the coordinate ring
+$W.\mathrm{toAffine}.\mathrm{CoordinateRing}$ of its affine model — the quotient of $K[X][Y]$ by the
+Weierstrass polynomial — is a Dedekind domain; write $K(W)$ for the associated function field, i.e.
+the fraction field of that coordinate ring. Let $O$ be a valuation subring of $K(W)$ subject to
+three hypotheses: $O \neq \top$, so $O$ is a proper subring of $K(W)$; every constant lies in $O$,
+i.e. $\mathrm{algebraMap}\,K\,K(W)\,c \in O$ for all $c \in K$; and the image in $K(W)$ of the class
+of $C\,X$ in the coordinate ring, that is the coordinate function $x$, lies in $O$. The conclusion
+is that $O$ is a finite place: there exists $v$ in the height-one spectrum of the coordinate ring,
+i.e. a nonzero prime ideal $\mathfrak p$ of $K[W]$, such that $O$ coincides with the valuation
+subring of the $\mathfrak p$-adic valuation $v.\mathrm{valuation}$ on $K(W)$. Nothing is asserted
+about uniqueness of $v$.
+
+This is the affine half of the classification of the places of the function field of a Weierstrass
+curve over $K$: a proper valuation subring containing the constants and the coordinate function $x$
+is the localisation of the affine coordinate ring at a nonzero prime, the remaining case being the
+place at infinity. It is used in the project's development of places of genus-one curves, for
+instance to identify the place attached to an affine point and in the verification that $x$ is not
+in the valuation subring of the place at the origin, and hence in the Abel-theorem machinery for
+genus-one curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_FunctionField_exists_eq_valuationSubring_of_X_mem.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_FunctionField_exists_eq_valuationSubring_of_X_mem
+
+open scoped Polynomial.Bivariate nonZeroDivisors
+p2m_open "Polynomial Polynomial.Bivariate.Polynomial IsDedekindDomain"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine a₃ a₁ Affine.CoordinateRing mk a₄ a₂ a₆ Affine.FunctionField \
+  toAffine Affine.Point Affine.CoordinateRing.mk Affine.polynomial"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "CoordinateRing CoordinateRing.smul FunctionField Point \
+  CoordinateRing.mk CoordinateRing.exists_smul_basis_eq polynomial"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+variable {K : Type*} [Field K] (W : Affine K)
+
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "smul YClass mk exists_smul_basis_eq \
+  YClass_ne_zero"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing"
+
+lemma mk_Y_ne_zero : mk W Y ≠ 0 := by
+  simpa [YClass] using YClass_ne_zero (W' := W) 0
+
+lemma mk_Y_mul_mk_Y_add :
+    mk W Y * (mk W Y + mk W (C (C W.a₁ * X + C W.a₃))) =
+      mk W (C (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆)) := by
+  have h : mk W (Y ^ 2 + C (C W.a₁ * X + C W.a₃) * Y) =
+      mk W (C (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆)) :=
+    AdjoinRoot.mk_eq_mk.mpr ⟨1, by rw [WeierstrassCurve.Affine.polynomial]; ring1⟩
+  rw [map_add, map_mul, map_pow] at h
+  rw [← h]
+  ring
+
+end CoordinateRing
+
+namespace FunctionField
+
+lemma algebraMap_mk_C_C (c : K) :
+    algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W (C (C c))) =
+      algebraMap K W.FunctionField c := by
+  rw [IsScalarTower.algebraMap_apply K W.CoordinateRing W.FunctionField]
+  rfl
+
+theorem exists_eq_valuationSubring_of_X_mem_aux [IsDedekindDomain W.CoordinateRing]
+    (O : ValuationSubring W.FunctionField) (hO : O ≠ ⊤)
+    (hK : ∀ c : K, algebraMap K W.FunctionField c ∈ O)
+    (hx : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W (C X)) ∈ O) :
+    ∃ v : HeightOneSpectrum W.CoordinateRing,
+      O = (v.valuation W.FunctionField).valuationSubring := by
+  classical
+  set ι := algebraMap W.CoordinateRing W.FunctionField with hι
+  have hCX : ∀ p : K[X], ι (CoordinateRing.mk W (C p)) ∈ O := by
+    intro p
+    induction p using Polynomial.induction_on with
+    | C c => rw [hι, algebraMap_mk_C_C]; exact hK c
+    | add p q hp hq => rw [map_add, map_add, map_add]; exact add_mem hp hq
+    | monomial n c h =>
+      rw [pow_succ, ← mul_assoc, map_mul, map_mul, map_mul]
+      exact mul_mem h hx
+  have hY : ι (CoordinateRing.mk W Y) ∈ O := by
+    by_contra hY
+    have hYinv : (ι (CoordinateRing.mk W Y))⁻¹ ∈ O := (O.mem_or_inv_mem _).resolve_left hY
+    have hY0 : ι (CoordinateRing.mk W Y) ≠ 0 := fun h =>
+      CoordinateRing.mk_Y_ne_zero W
+        (IsFractionRing.injective W.CoordinateRing W.FunctionField (by rwa [map_zero]))
+    have key := congrArg ι (CoordinateRing.mk_Y_mul_mk_Y_add W)
+    rw [map_mul, map_add] at key
+    have : ι (CoordinateRing.mk W Y) =
+        ι (CoordinateRing.mk W (C (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆))) *
+          (ι (CoordinateRing.mk W Y))⁻¹ -
+        ι (CoordinateRing.mk W (C (C W.a₁ * X + C W.a₃))) := by
+      rw [← key]; field_simp; ring
+    exact hY (this ▸ sub_mem (mul_mem (hCX _) hYinv) (hCX _))
+  have hR : ∀ f : W.CoordinateRing, ι f ∈ O := by
+    intro f
+    obtain ⟨p, q, rfl⟩ := CoordinateRing.exists_smul_basis_eq f
+    rw [CoordinateRing.smul, CoordinateRing.smul, mul_one, map_add, map_mul]
+    exact add_mem (hCX p) (mul_mem (hCX q) hY)
+  let φ : W.CoordinateRing →+* O := ι.codRestrict O.toSubring hR
+  have hinv : ∀ s : W.CoordinateRing, IsUnit (φ s) → (ι s)⁻¹ ∈ O := by
+    intro s hs
+    obtain ⟨c, hc⟩ := hs.exists_right_inv
+    have hc' : ι s * (c : W.FunctionField) = 1 := by
+      have := congrArg ((↑) : O → W.FunctionField) hc
+      rw [MulMemClass.coe_mul, OneMemClass.coe_one] at this
+      exact this
+    rw [← eq_inv_of_mul_eq_one_right hc']
+    exact c.2
+  let 𝔭 : Ideal W.CoordinateRing := (IsLocalRing.maximalIdeal O).comap φ
+  have hmem : ∀ f : W.CoordinateRing, f ∉ 𝔭 ↔ IsUnit (φ f) := fun f =>
+    IsLocalRing.notMem_maximalIdeal
+  have h𝔭 : 𝔭 ≠ ⊥ := by
+    intro h
+    apply hO
+    rw [eq_top_iff]
+    intro z _
+    obtain ⟨a, b, hb, rfl⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+    have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb
+    have hbu : IsUnit (φ b) := (hmem b).mp (by rw [h, Ideal.mem_bot]; exact hb0)
+    rw [div_eq_mul_inv]
+    exact mul_mem (hR a) (hinv b hbu)
+  let v : HeightOneSpectrum W.CoordinateRing := ⟨𝔭, Ideal.comap_isPrime φ _, h𝔭⟩
+  refine ⟨v, ?_⟩
+  have hle : HeightOneSpectrum.valuationSubringAtPrime W.FunctionField v ≤ O := by
+    rintro z ⟨a, s, hs, rfl⟩
+    exact mul_mem (hR a) (hinv s ((hmem s).mp hs))
+  rw [← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+  exact (ValuationSubring.eq_of_le_of_ne_top _ hle hO).symm
+
+end FunctionField
+
+end WeierstrassCurve.Affine
+
+theorem solution {K : Type*} [Field K] (W : WeierstrassCurve K) [IsDedekindDomain
+  W.toAffine.CoordinateRing] (O : ValuationSubring W.toAffine.FunctionField) (hO : O ≠ ⊤) (hK : ∀ c
+  : K, algebraMap K W.toAffine.FunctionField c ∈ O) (hX : algebraMap W.toAffine.CoordinateRing
+  W.toAffine.FunctionField (WeierstrassCurve.Affine.CoordinateRing.mk W.toAffine (Polynomial.C
+  Polynomial.X)) ∈ O) :
+    ∃ v : IsDedekindDomain.HeightOneSpectrum W.toAffine.CoordinateRing, O = (v.valuation
+      W.toAffine.FunctionField).valuationSubring :=
+  WeierstrassCurve.Affine.FunctionField.exists_eq_valuationSubring_of_X_mem_aux W.toAffine O hO hK
+    hX
+
+end S_WeierstrassCurve_Affine_FunctionField_exists_eq_valuationSubring_of_X_mem
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_FunctionField_exists_eq_valuationSubring_of_X_mem (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.Affine.FunctionField.exists_eq_valuationSubring_of_X_mem {K : Type*} [Field
+  K] (W : WeierstrassCurve K) [IsDedekindDomain W.toAffine.CoordinateRing] (O : ValuationSubring
+  W.toAffine.FunctionField) (hO : O ≠ ⊤) (hK : ∀ c : K, algebraMap K W.toAffine.FunctionField c ∈ O)
+  (hX : algebraMap W.toAffine.CoordinateRing W.toAffine.FunctionField
+  (WeierstrassCurve.Affine.CoordinateRing.mk W.toAffine (Polynomial.C Polynomial.X)) ∈ O) :
+    ∃ v : IsDedekindDomain.HeightOneSpectrum W.toAffine.CoordinateRing, O = (v.valuation
+      W.toAffine.FunctionField).valuationSubring :=
+  solution W O hO hK hX
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_FunctionField_exists_valuation_eq_exp_natDegree_norm.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_FunctionField_exists_valuation_eq_exp_natDegree_norm.lean
new file mode 100644
index 0000000000..6138fea073
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_FunctionField_exists_valuation_eq_exp_natDegree_norm.lean
@@ -0,0 +1,189 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.FunctionField.exists_valuation_eq_exp_natDegree_norm
+(26f883b5-3611-54d4-a82b-d13d46679f76) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 31b75c61-a07e-5933-8990-f5c3d40254e1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.RingTheory.Valuation.Basic
+
+import Mathlib.RingTheory.Valuation.ExtendToLocalization
+import Mathlib.RingTheory.Norm.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The valuation at infinity on a Weierstrass function field
+
+Theorem statement: `WeierstrassCurve.Affine.FunctionField.exists_valuation_eq_exp_natDegree_norm`
+(`26f883b5-3611-54d4-a82b-d13d46679f76`), by Claude, 2026-09-05.
+
+Proof: submission `31b75c61-a07e-5933-8990-f5c3d40254e1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and $W$ a Weierstrass curve over $K$, with associated affine curve `W.toAffine`,
+affine coordinate ring $R =$ `W.toAffine.CoordinateRing` (the quotient of $K[X][Y]$ by the
+Weierstrass polynomial, a free $K[X]$-module of rank $2$) and function field $F =$
+`W.toAffine.FunctionField`, the field of fractions of $R$. The assertion is that there exists a
+valuation $v$ on $F$ with values in $\mathbb{Z}^{m0} = \mathrm{WithZero}(\mathrm{Multiplicative}\
+\mathbb{Z})$ — that is, a multiplicative map satisfying $v(0)=0$, $v(1)=1$ and the ultrametric
+inequality — such that for every nonzero $f \in R$, the value of $v$ at the image of $f$ in $F$
+under the structure map is $\exp\bigl(\deg N(f)\bigr)$, where $N =$ `Algebra.norm (Polynomial K)` is
+the norm of the rank-two extension $K[X] \to R$, $\deg$ is the `natDegree` of the resulting
+polynomial in $K[X]$, cast into $\mathbb{Z}$, and $\exp$ is the canonical embedding of $\mathbb{Z}$
+into $\mathbb{Z}^{m0}$. Only the existence of such a $v$ is asserted; no uniqueness or normalisation
+statement is made, and the value of $v$ on elements of $F$ not in the image of $R$ is not described.
+
+This is the valuation $\mathrm{ord}_{\mathcal{O}}$ at the point at infinity of a Weierstrass curve,
+in the multiplicative normalisation $v = \exp \circ (-\mathrm{ord}_{\mathcal{O}})$, so that $x$ and
+$y$ (of norm degrees $2$ and $3$) have poles at infinity. It supplies the place at infinity in the
+divisor theory of the function field of a Weierstrass curve, and is used in
+[`WeierstrassCurve.Affine.exists_infinitePlace_deg_eq_one`]
+(thm.html#WeierstrassCurve.Affine.exists_infinitePlace_deg_eq_one),
+[`WeierstrassCurve.Affine.hasPrincipalDivisors_of_isAlgClosed`]
+(thm.html#WeierstrassCurve.Affine.hasPrincipalDivisors_of_isAlgClosed)
+and
+[`WeierstrassCurve.Affine.valuation_placeOf_neg_transEquiv_algebraMap`]
+(thm.html#WeierstrassCurve.Affine.valuation_placeOf_neg_transEquiv_algebraMap).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_FunctionField_exists_valuation_eq_exp_natDegree_norm.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_FunctionField_exists_valuation_eq_exp_natDegree_norm
+
+open scoped Polynomial.Bivariate WithZero nonZeroDivisors
+p2m_open "Polynomial Polynomial.Bivariate.Polynomial"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine mk Affine.FunctionField toAffine Affine.Point"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "CoordinateRing FunctionField Point CoordinateRing.basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+variable {K : Type*} [Field K] (W : Affine K)
+
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "mk degree_norm_smul_basis exists_smul_basis_eq"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing"
+
+lemma norm_ne_zero {f : W.CoordinateRing} (hf : f ≠ 0) : Algebra.norm K[X] f ≠ 0 :=
+  (Algebra.norm_ne_zero_iff_of_basis (CoordinateRing.basis W)).mpr hf
+
+open scoped Classical in
+noncomputable def valuationInftyDef (f : W.CoordinateRing) : ℤᵐ⁰ :=
+  if f = 0 then 0 else WithZero.exp ((Algebra.norm K[X] f).natDegree : ℤ)
+
+lemma degree_norm_add_le (f g : W.CoordinateRing) :
+    (Algebra.norm K[X] (f + g)).degree ≤
+      max (Algebra.norm K[X] f).degree (Algebra.norm K[X] g).degree := by
+  obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq f
+  obtain ⟨p', q', rfl⟩ := exists_smul_basis_eq g
+  have : p • (1 : W.CoordinateRing) + q • mk W Y + (p' • 1 + q' • mk W Y) =
+      (p + p') • 1 + (q + q') • mk W Y := by
+    rw [add_smul, add_smul]; abel
+  rw [this, degree_norm_smul_basis, degree_norm_smul_basis, degree_norm_smul_basis]
+  refine max_le ?_ ?_
+  · rcases le_max_iff.mp (degree_add_le p p') with h | h
+    · exact le_max_of_le_left (le_max_of_le_left (nsmul_le_nsmul_right h 2))
+    · exact le_max_of_le_right (le_max_of_le_left (nsmul_le_nsmul_right h 2))
+  · rcases le_max_iff.mp (degree_add_le q q') with h | h
+    · exact le_max_of_le_left (le_max_of_le_right
+        (add_le_add_left (nsmul_le_nsmul_right h 2) 3))
+    · exact le_max_of_le_right (le_max_of_le_right
+        (add_le_add_left (nsmul_le_nsmul_right h 2) 3))
+
+noncomputable def valuationInftyInt : Valuation W.CoordinateRing ℤᵐ⁰ where
+  toFun := valuationInftyDef W
+  map_zero' := ite_eq_left rfl
+  map_one' := by
+    simp [valuationInftyDef]
+  map_mul' f g := by
+    classical
+    by_cases hf : f = 0
+    · simp [valuationInftyDef, hf]
+    by_cases hg : g = 0
+    · simp [valuationInftyDef, hg]
+    simp only [valuationInftyDef, ite_eq_right hf, ite_eq_right hg, ite_eq_right (mul_ne_zero hf
+      hg), map_mul,
+      natDegree_mul (norm_ne_zero W hf) (norm_ne_zero W hg), Nat.cast_add, WithZero.exp_add]
+  map_add_le_max' f g := by
+    classical
+    by_cases hfg : f + g = 0
+    · simp [valuationInftyDef, hfg]
+    by_cases hf : f = 0
+    · simp [valuationInftyDef, hf]
+    by_cases hg : g = 0
+    · simp [valuationInftyDef, hg]
+    simp only [valuationInftyDef, ite_eq_right hf, ite_eq_right hg, ite_eq_right hfg, le_max_iff,
+      WithZero.exp_le_exp, Nat.cast_le]
+    have h := degree_norm_add_le W f g
+    rw [degree_eq_natDegree (norm_ne_zero W hfg), degree_eq_natDegree (norm_ne_zero W hf),
+      degree_eq_natDegree (norm_ne_zero W hg)] at h
+    rcases le_max_iff.mp h with h | h
+    · exact Or.inl (by exact_mod_cast h)
+    · exact Or.inr (by exact_mod_cast h)
+
+lemma valuationInftyInt_apply (f : W.CoordinateRing) :
+    valuationInftyInt W f = valuationInftyDef W f := rfl
+
+lemma nonZeroDivisors_le_supp_primeCompl :
+    W.CoordinateRing⁰ ≤ (valuationInftyInt W).supp.primeCompl := fun _ hs => by
+  simp [valuationInftyInt_apply, valuationInftyDef, nonZeroDivisors.ne_zero hs]
+
+end CoordinateRing
+
+noncomputable def valuationInfty : Valuation W.FunctionField ℤᵐ⁰ :=
+  (CoordinateRing.valuationInftyInt W).extendToLocalization
+    (CoordinateRing.nonZeroDivisors_le_supp_primeCompl W) W.FunctionField
+
+lemma valuationInfty_algebraMap (f : W.CoordinateRing) :
+    valuationInfty W (algebraMap W.CoordinateRing W.FunctionField f) =
+      CoordinateRing.valuationInftyDef W f :=
+  Valuation.extendToLocalization_apply_map_apply ..
+
+lemma valuationInfty_algebraMap_of_ne_zero {f : W.CoordinateRing} (hf : f ≠ 0) :
+    valuationInfty W (algebraMap W.CoordinateRing W.FunctionField f) =
+      WithZero.exp ((Algebra.norm K[X] f).natDegree : ℤ) := by
+  rw [valuationInfty_algebraMap, CoordinateRing.valuationInftyDef, ite_eq_right hf]
+
+end WeierstrassCurve.Affine
+
+theorem solution {K : Type*} [Field K] (W : WeierstrassCurve K) :
+    ∃ v : Valuation W.toAffine.FunctionField (WithZero (Multiplicative ℤ)), ∀ f :
+      W.toAffine.CoordinateRing, f ≠ 0 → v (algebraMap W.toAffine.CoordinateRing
+      W.toAffine.FunctionField f) = WithZero.exp ((Algebra.norm (Polynomial K) f).natDegree : ℤ) :=
+  ⟨WeierstrassCurve.Affine.valuationInfty W.toAffine, fun _ hf =>
+    WeierstrassCurve.Affine.valuationInfty_algebraMap_of_ne_zero W.toAffine hf⟩
+
+end S_WeierstrassCurve_Affine_FunctionField_exists_valuation_eq_exp_natDegree_norm
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_FunctionField_exists_valuation_eq_exp_natDegree_norm
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.Affine.FunctionField.exists_valuation_eq_exp_natDegree_norm {K : Type*}
+    [Field K] (W : WeierstrassCurve K) :
+    ∃ v : Valuation W.toAffine.FunctionField (WithZero (Multiplicative ℤ)), ∀ f :
+      W.toAffine.CoordinateRing, f ≠ 0 → v (algebraMap W.toAffine.CoordinateRing
+      W.toAffine.FunctionField f) = WithZero.exp ((Algebra.norm (Polynomial K) f).natDegree : ℤ) :=
+  solution W
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_GenusOnePlaceGate_ext_of_isCentred.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_GenusOnePlaceGate_ext_of_isCentred.lean
new file mode 100644
index 0000000000..9cfb5515dd
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_GenusOnePlaceGate_ext_of_isCentred.lean
@@ -0,0 +1,141 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.GenusOnePlaceGate.ext_of_isCentred
+(f9a9c9d9-e9be-523b-9157-20b943b6e623) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3fe733e0-97f8-5daf-9b8e-f42b0f7e036d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Uniqueness of the centred genus-one place gate
+
+Theorem statement: `WeierstrassCurve.Affine.GenusOnePlaceGate.ext_of_isCentred`
+(`f9a9c9d9-e9be-523b-9157-20b943b6e623`), by Claude, 2026-09-05.
+
+Proof: submission `3fe733e0-97f8-5daf-9b8e-f42b0f7e036d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field and let $W$ be an affine Weierstrass curve over $F$ whose coordinate ring
+$W.\mathrm{CoordinateRing}$ is a Dedekind domain. A term of
+[`WeierstrassCurve.Affine.GenusOnePlaceGate W`](def/WeierstrassCurve_GenusOnePic0.html#L18) consists
+of a bijection `pointEquivPlace` between the group of points $W.\mathrm{Point}$ and the type of
+places of the function field $W.\mathrm{FunctionField}$ over $F$ — a place being a valuation subring
+of the function field which contains the image of $F$, is not the whole field, and is a principal
+ideal ring — together with the assertion that every such place has degree $1$. Such a gate $g$ is
+called `IsCentred` when for all $x,y \in F$ and every proof that $(x,y)$ is a nonsingular point of
+$W$, the images in the function field of the coordinate-ring classes $X - x$ (that is,
+`CoordinateRing.XClass W x`) and $Y - y$ (that is, `CoordinateRing.YClass W (Polynomial.C y)`) both
+lie in the nonunits of the valuation subring of the place attached by $g$ to the affine point
+$(x,y)$. The theorem asserts: if $g_1$ and $g_2$ are gates on $W$ and each is centred, then $g_1 =
+g_2$.
+
+This is the rigidity statement behind the classical dictionary between points of a smooth curve and
+the places of its function field: once the normalisation that the local coordinates $X-x$, $Y-y$
+vanish at the place of $(x,y)$ is imposed, the point–place bijection is determined, so the type of
+centred gates on $W$ is a subsingleton. It is used to pass from existential statements about a
+centred gate to statements about an arbitrary one, in particular in the results on intermediate
+fields for points with cyclic kernel and in the construction of Vélu function-field homomorphisms
+compatible with places.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_GenusOnePlaceGate_ext_of_isCentred.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_GenusOnePlaceGate_ext_of_isCentred
+
+open AlgebraicCurve WeierstrassCurve WeierstrassCurve.Affine
+
+universe u
+
+theorem solution
+    {F : Type u} [Field F] {W : WeierstrassCurve.Affine F}
+    [IsDedekindDomain W.CoordinateRing]
+    (g₁ g₂ : WeierstrassCurve.Affine.GenusOnePlaceGate W)
+    (h₁ : @WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred F _ W g₁)
+    (h₂ : @WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred F _ W g₂) :
+    g₁ = g₂ := by
+  classical
+  have hw : ∀ {x y : F} (h : W.Nonsingular x y),
+      ∃ w : IsDedekindDomain.HeightOneSpectrum W.CoordinateRing,
+        w.asIdeal = CoordinateRing.XYIdeal W x (Polynomial.C y) := fun {x y} h =>
+    ⟨⟨CoordinateRing.XYIdeal W x (Polynomial.C y),
+        (CoordinateRing.XYIdeal_isMaximal h.left).isPrime,
+        CoordinateRing.XYIdeal_ne_bot x (Polynomial.C y)⟩, rfl⟩
+  have hsome : ∀ {x y : F} (h : W.Nonsingular x y),
+      g₁.pointEquivPlace (Point.some x y h) = g₂.pointEquivPlace (Point.some x y h) := by
+    intro x y h
+    obtain ⟨w, hw⟩ := hw h
+    have e1 := @placeOfPoint_some_eq_ofHeightOneSpectrum F _ W g₁ h₁ _ x y h w hw
+    have e2 := @placeOfPoint_some_eq_ofHeightOneSpectrum F _ W g₂ h₂ _ x y h w hw
+    exact e1.trans e2.symm
+  have hall : ∀ P : W.Point, g₁.pointEquivPlace P = g₂.pointEquivPlace P := by
+    intro P
+    cases P with
+    | some x y h => exact hsome h
+    | zero =>
+      have key : g₁.pointEquivPlace.symm (g₂.pointEquivPlace 0) = 0 := by
+        rcases hP : g₁.pointEquivPlace.symm (g₂.pointEquivPlace 0) with _ | ⟨x, y, h⟩
+        · rfl
+        · exfalso
+          have h3 : g₂.pointEquivPlace 0 = g₁.pointEquivPlace (Point.some x y h) := by
+            rw [← hP, Equiv.apply_symm_apply]
+          have h5 : (Point.some x y h : W.Point) = 0 :=
+            g₂.pointEquivPlace.injective ((h3.trans (hsome h)).symm)
+          exact Point.some_ne_zero h h5
+      have := congrArg g₁.pointEquivPlace key
+      rw [Equiv.apply_symm_apply] at this
+      first
+        | exact this.symm
+  cases g₁ with
+  | mk e₁ d₁ =>
+    cases g₂ with
+    | mk e₂ d₂ =>
+      congr
+      exact Equiv.ext hall
+
+end S_WeierstrassCurve_Affine_GenusOnePlaceGate_ext_of_isCentred
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_GenusOnePlaceGate_ext_of_isCentred (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve WeierstrassCurve WeierstrassCurve.Affine
+
+universe u
+theorem WeierstrassCurve.Affine.GenusOnePlaceGate.ext_of_isCentred
+    {F : Type u} [Field F] {W : WeierstrassCurve.Affine F}
+    [IsDedekindDomain W.CoordinateRing]
+    (g₁ g₂ : WeierstrassCurve.Affine.GenusOnePlaceGate W)
+    (h₁ : @WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred F _ W g₁)
+    (h₂ : @WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred F _ W g₂) :
+    g₁ = g₂ := by
+  classical
+  exact
+    solution g₁ g₂ h₁ h₂
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_aeval_j_diag_eq_zero_of_finrankAlong_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_aeval_j_diag_eq_zero_of_finrankAlong_eq.lean
new file mode 100644
index 0000000000..a0c2dc9287
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_aeval_j_diag_eq_zero_of_finrankAlong_eq.lean
@@ -0,0 +1,737 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.Affine.IsogenyEndDatum.aeval_j_diag_eq_zero_of_finrankAlong_eq
+(93fd7e0a-3705-57ba-bebe-bf48e6f46962) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 19ad62a3-f786-52d3-87d0-a6dda5e2bda1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import Mathlib.AlgebraicTopology.FundamentalGroupoid.SimplyConnected
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.RingTheory.Algebraic.Cardinality
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_IsAddCyclic_of_squarefree_natCard
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jLattice_eq_zero_of_isAddCyclic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_discriminant_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_and_isAddCyclic_sublatticeQuotient
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_exists_variableChange_smul_weierstrassCurve_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_isUniformization_toPoint
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_algHom_functionField_baseChange_finrankAlong_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_and_abelTheorem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_natCard_ker_pointMapOfPushforward_eq_finrankAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_intermediateField_countable_map_eq_and_finrankAlong_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_nonempty_functionField_algEquiv_of_variableChange
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree-N endomorphism forces Φ_N(j(E),j(E))=0
+
+Theorem statement: `WeierstrassCurve.Affine.IsogenyEndDatum.aeval_j_diag_eq_zero_of_finrankAlong_eq`
+(`93fd7e0a-3705-57ba-bebe-bf48e6f46962`), by Claude, 2026-09-05.
+
+Proof: submission `19ad62a3-f786-52d3-87d0-a6dda5e2bda1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field in universe $u$, equipped with decidable equality, algebraically closed and of
+characteristic $0$, and let $W$ be a Weierstrass curve over $K$ which is elliptic. Let $N$ be a
+natural number with `NeZero N` which is squarefree, and let `data` be a
+[`ModularCurve.ModularPolynomialData N`](def/ModularCurve_X0.html#L215): a polynomial $\Phi \in
+(\mathbb{Z}[X])[Y]$ that is monic, whose degree in $Y$ equals $\sum_{d \mid N,\ d \text{
+squarefree}} N/d$, and which vanishes when its coefficients are evaluated through the ring
+homomorphism $\mathbb{Z}[X] \to \mathrm{LaurentSeries}\,\mathbb{Q}$ sending $X$ to the $q$-expansion
+of $j$ and $Y$ is sent to the Laurent series `jqN N`. Let $D$ be an `IsogenyEndDatum` for the affine
+model of $W$, that is: a $K$-algebra endomorphism $\iota = D.\iota$ of the function field $K(W)$,
+integral as a ring homomorphism, and such that $K(W)$ is a finite module over itself via $\iota$;
+assume moreover that this module has rank exactly $N$, i.e. $\operatorname{finrankAlong} K\, D.\iota
+= N$. The conclusion is that the diagonal polynomial $\Phi(X,X) \in \mathbb{Z}[X]$, obtained from
+$\Phi$ by substituting $X$ for the outer variable with coefficients mapped by the identity of
+$\mathbb{Z}[X]$, vanishes when evaluated at $j(W) \in K$.
+
+This is the classical assertion that an elliptic curve carrying a self-isogeny of degree $N$ (here
+presented field-theoretically, as a finite integral self-embedding of the function field of index
+$N$) yields a point of $X_0(N)$ lying over $(j(E),j(E))$, so that $j(E)$ is a root of the diagonal
+modular polynomial $\Phi_N(X,X)$. It is used to rule out endomorphisms of degree $N>1$ when $j(W)$
+is transcendental or non-integral, in
+[`WeierstrassCurve.Affine.IsogenyEndDatum.exists_forall_pointEnd_eq_zsmul_of_transcendental_j`]
+(thm.html#WeierstrassCurve.Affine.IsogenyEndDatum.
+exists_forall_pointEnd_eq_zsmul_of_transcendental_j)
+and
+[`WeierstrassCurve.Affine.IsogenyEndDatum.exists_forall_pointEnd_eq_zsmul_of_not_isIntegral_j`]
+(thm.html#WeierstrassCurve.Affine.IsogenyEndDatum.
+exists_forall_pointEnd_eq_zsmul_of_not_isIntegral_j).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_IsogenyEndDatum_aeval_j_diag_eq_zero_of_finrankAlong_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_e162e25a
+
+
+noncomputable section
+
+universe u
+
+namespace ModularCurve
+p2m_export "ModularCurve" "ModularPolynomialData \
+  ModularPolynomialData.eval_jLattice_eq_zero_of_isAddCyclic"
+p2m_open "ModularCurve"
+open Cardinal IntermediateField
+
+private def kw_d5eu_ratEquivStrip {A B : Type*} [Semiring A] [Semiring B]
+    {iA : Algebra ℚ A} {iB : Algebra ℚ B} (e : @AlgEquiv ℚ A B _ _ _ iA iB) :
+    A ≃+* B :=
+  @AlgEquiv.toRingEquiv ℚ A B _ _ _ iA iB e
+
+theorem kw_countable_algebraicClosure (K₀ : Type u) [Field K₀] [Countable K₀] :
+    Countable (AlgebraicClosure K₀) :=
+  Cardinal.mk_le_aleph0_iff.mp
+    ((Algebra.IsAlgebraic.cardinalMk_le_max K₀ (AlgebraicClosure K₀)).trans
+      (max_le Cardinal.mk_le_aleph0 le_rfl))
+
+theorem kw_aleph0_lt_mk_transcendenceBasis_complex
+    {t : Set ℂ} (ht : IsTranscendenceBasis ℚ ((↑) : t → ℂ)) : ℵ₀ < #t := by
+  rw [← not_le]
+  intro h
+  have : Algebra.IsAlgebraic
+      (IntermediateField.adjoin ℚ (Set.range ((↑) : t → ℂ))) ℂ := ht.isAlgebraic_field
+  have hadj : #(IntermediateField.adjoin ℚ (Set.range ((↑) : t → ℂ))) ≤ ℵ₀ :=
+    (IntermediateField.cardinalMk_adjoin_le ℚ _).trans
+      (max_le (max_le Cardinal.mk_le_aleph0 (Cardinal.mk_range_le.trans h)) le_rfl)
+  have hℂ : #ℂ ≤ ℵ₀ :=
+    (Algebra.IsAlgebraic.cardinalMk_le_max _ ℂ).trans (max_le hadj le_rfl)
+  exact absurd hℂ <| not_le.mpr <| Cardinal.aleph0_lt_continuum.trans_le
+    (Cardinal.mk_real ▸ Cardinal.mk_le_of_injective Complex.ofReal_injective)
+
+set_option synthInstance.maxHeartbeats 6400000 in
+theorem kw_nonempty_ringHom_algebraicClosure_complex (K₀ : Type u) [Field K₀] [Algebra ℚ K₀]
+    [Countable K₀] : Nonempty (AlgebraicClosure K₀ →+* ℂ) := by
+  let ACK := AlgebraicClosure K₀
+  have : Countable ACK := kw_countable_algebraicClosure K₀
+  obtain ⟨s, hs⟩ := exists_isTranscendenceBasis ℚ (A := ACK)
+  obtain ⟨t, ht⟩ := exists_isTranscendenceBasis ℚ (A := ℂ)
+  have hcard : Cardinal.lift.{0, u} #s ≤ Cardinal.lift.{u, 0} #t := by
+    have h1 : Cardinal.lift.{0, u} #s ≤ ℵ₀ := Cardinal.lift_le_aleph0.mpr Cardinal.mk_le_aleph0
+    have h2 : ℵ₀ ≤ Cardinal.lift.{u, 0} #t :=
+      Cardinal.aleph0_le_lift.mpr (le_of_lt (kw_aleph0_lt_mk_transcendenceBasis_complex ht))
+    exact h1.trans h2
+  obtain ⟨f⟩ := Cardinal.lift_mk_le'.mp hcard
+  have hf_indep : AlgebraicIndependent ℚ (fun i : s => ((f i : t) : ℂ)) :=
+    ht.1.comp f f.injective
+  let Qs : IntermediateField ℚ ACK := adjoin ℚ (Set.range ((↑) : s → ACK))
+  let φQs : Qs →+* ℂ :=
+    ((adjoin ℚ (Set.range (fun i : s => ((f i : t) : ℂ)))).val.toRingHom.comp
+      (kw_d5eu_ratEquivStrip hf_indep.aevalEquivField).toRingHom).comp
+        (kw_d5eu_ratEquivStrip hs.1.aevalEquivField).symm.toRingHom
+  let : Algebra Qs ℂ := φQs.toAlgebra
+  have : Algebra.IsAlgebraic Qs ACK := hs.isAlgebraic_field
+  exact ⟨(IsAlgClosed.lift (R := Qs) (M := ℂ) (S := ACK)).toRingHom⟩
+
+end ModularCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY variableChange_j a₃ a₁ map Affine.CoordinateRing \
+  coe_Δ' map_j mk Affine.Point.some Affine.Point.some.injEq reduction IsIntegral toAffine \
+  Affine.Point Δ Affine.Point.neg_some baseChange j \
+  exists_intermediateField_countable_map_eq_and_finrankAlong_eq \
+  Affine.exists_algHom_functionField_baseChange_finrankAlong_eq \
+  Affine.natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  nonempty_functionField_algEquiv_of_variableChange \
+  Affine.exists_genusOnePlaceGate_isCentred_and_abelTheorem Affine.CoordinateRing.isDedekindDomain \
+  Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "negY CoordinateRing map baseChange Point.some \
+  Point.some.injEq FunctionField Point polynomial Point.neg_some pointMapOfPushforward \
+  IsogenyEndDatum exists_algHom_functionField_baseChange_finrankAlong_eq \
+  natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  exists_genusOnePlaceGate_isCentred_and_abelTheorem CoordinateRing.isDedekindDomain \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+open AlgebraicCurve
+
+scoped instance instHasPrincipalDivisorsFunctionField_s13 {F : Type*} [Field F] [CharZero F]
+    {W : Affine F} : HasPrincipalDivisors F W.FunctionField :=
+  hasPrincipalDivisors_functionField W
+
+section AutoNorm
+variable {F : Type*} [Field F] [CharZero F]
+variable {V W : Affine F} [V.IsElliptic] [W.IsElliptic]
+
+omit [WeierstrassCurve.IsElliptic V] [WeierstrassCurve.IsElliptic W] in
+theorem normFormulaAlong_of_elliptic (ι : V.FunctionField →ₐ[F] W.FunctionField)
+    (hfin : FiniteAlong F ι) : NormFormulaAlong F ι hfin := by
+  classical
+  have : HasPrincipalDivisors F W.FunctionField := hasPrincipalDivisors_functionField W
+  have : CharZero V.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap F V.FunctionField).injective
+  have hsep : SeparableAlong F ι := by
+    let := algebraAlong ι
+    have := isScalarTower_along ι
+    have : Module.Finite V.FunctionField W.FunctionField := hfin
+    change Algebra.IsSeparable V.FunctionField W.FunctionField
+    infer_instance
+  exact AlgebraicCurve.normFormulaAlong ι hfin hsep
+
+end AutoNorm
+
+end WeierstrassCurve.Affine
+
+namespace ModularCurve
+p2m_export "ModularCurve" "ModularPolynomialData \
+  ModularPolynomialData.eval_jLattice_eq_zero_of_isAddCyclic"
+p2m_open "ModularCurve"
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_e162e25a.Weierstras\
+  sCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_e162e25a.Weierstras\
+  sCurve.Affine AlgebraicCurve"
+
+section ConjHelpers
+
+variable {K : Type*} [Field K]
+variable {E E' F F' : WeierstrassCurve.Affine K}
+
+def kw_fdn2_qephod_hend21_conjSeam
+    (eE : F.FunctionField ≃ₐ[K] E.FunctionField)
+    (eE' : F'.FunctionField ≃ₐ[K] E'.FunctionField)
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField) :
+    F'.FunctionField →ₐ[K] F.FunctionField :=
+  (eE.symm.toAlgHom.comp ι).comp eE'.toAlgHom
+
+theorem kw_fdn2_qephod_hend21_conjSeam_isIntegral
+    (eE : F.FunctionField ≃ₐ[K] E.FunctionField)
+    (eE' : F'.FunctionField ≃ₐ[K] E'.FunctionField)
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField) (hι : ι.toRingHom.IsIntegral) :
+    (kw_fdn2_qephod_hend21_conjSeam eE eE' ι).toRingHom.IsIntegral :=
+  RingHom.IsIntegral.trans eE'.toAlgHom.toRingHom (eE.symm.toAlgHom.comp ι).toRingHom
+    (RingHom.isIntegral_of_surjective _ eE'.surjective)
+    (RingHom.IsIntegral.trans ι.toRingHom eE.symm.toAlgHom.toRingHom hι
+      (RingHom.isIntegral_of_surjective _ eE.symm.surjective))
+
+theorem kw_fdn2_qephod_hend21_conjSeam_finiteAlong
+    (eE : F.FunctionField ≃ₐ[K] E.FunctionField)
+    (eE' : F'.FunctionField ≃ₐ[K] E'.FunctionField)
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField) (hfin : FiniteAlong K ι) :
+    FiniteAlong K (kw_fdn2_qephod_hend21_conjSeam eE eE' ι) := by
+  have hfin' : RingHom.Finite ι.toRingHom := hfin
+  have h1 : RingHom.Finite eE'.toAlgHom.toRingHom :=
+    RingHom.Finite.of_surjective _ eE'.surjective
+  have h2 : RingHom.Finite eE.symm.toAlgHom.toRingHom :=
+    RingHom.Finite.of_surjective _ eE.symm.surjective
+  have hcomp : RingHom.Finite
+      (kw_fdn2_qephod_hend21_conjSeam eE eE' ι).toRingHom :=
+    RingHom.Finite.comp (g := (eE.symm.toAlgHom.comp ι).toRingHom)
+      (RingHom.Finite.comp (g := eE.symm.toAlgHom.toRingHom) h2 hfin') h1
+  exact hcomp
+
+theorem kw_fdn2_qephod_hend21_finrankAlong_conj
+    (eE : F.FunctionField ≃ₐ[K] E.FunctionField)
+    (eE' : F'.FunctionField ≃ₐ[K] E'.FunctionField)
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField) :
+    finrankAlong K (kw_fdn2_qephod_hend21_conjSeam eE eE' ι) = finrankAlong K ι := by
+  refine @Algebra.finrank_eq_of_equiv_equiv F'.FunctionField F.FunctionField _ _
+    (algebraAlong (kw_fdn2_qephod_hend21_conjSeam eE eE' ι))
+    E'.FunctionField E.FunctionField _ _ (algebraAlong ι)
+    eE'.toRingEquiv eE.toRingEquiv (RingHom.ext fun x => ?_)
+  change ι (eE' x) = eE (eE.symm (ι (eE' x)))
+  exact (eE.apply_symm_apply _).symm
+
+end ConjHelpers
+end ModularCurve
+
+
+section
+open Complex Filter Set
+
+p2m_open_scoped "PeriodPair \
+  P2MW.S_OVERLONG_e162e25a.PeriodPair"
+
+namespace PeriodPair
+p2m_export "PeriodPair" "derivWeierstrassP_neg weierstrassP_neg lattice weierstrassP_add_coe \
+  lattice_eq_span_range_basis ω₁ mk g₃ ω₂ derivWeierstrassP_add_coe mem_lattice G g₂ \
+  weierstrassCurve weierstrassCurve_a₁ weierstrassCurve_a₃ DiscriminantNeZero toPoint \
+  toPoint_of_mem toPoint_zero toPoint_of_notMem IsUniformization jLattice \
+  jLattice_eq_c₄_pow_three_div_Δ scale_indep scale discriminant_ne_zero isUniformization_toPoint \
+  exists_variableChange_smul_weierstrassCurve_eq \
+  exists_scale_lattice_subset_and_sublatticeIndex_eq_and_isAddCyclic_sublatticeQuotient"
+p2m_open "PeriodPair"
+
+variable (L : PeriodPair)
+
+private theorem _root_.PeriodPair.kw_discriminantNeZero :
+    L.DiscriminantNeZero := L.discriminant_ne_zero
+
+p2m_export "PeriodPair" "kw_discriminantNeZero"
+
+private theorem _root_.PeriodPair.kw_isUniformization :
+    L.IsUniformization L.kw_discriminantNeZero :=
+  L.isUniformization_toPoint _
+
+p2m_export "PeriodPair" "kw_isUniformization"
+
+private theorem _root_.PeriodPair.kw_toPoint_add (hD : L.DiscriminantNeZero) (z w : ℂ) :
+    L.toPoint hD (z + w) = L.toPoint hD z + L.toPoint hD w :=
+  (L.isUniformization_toPoint hD).1 z w
+
+p2m_export "PeriodPair" "kw_toPoint_add"
+
+theorem kw_toPoint_surjective (hD : L.DiscriminantNeZero) : Function.Surjective (L.toPoint hD) :=
+  (L.isUniformization_toPoint hD).2.1
+
+theorem kw_toPoint_eq_zero_iff (hD : L.DiscriminantNeZero) (z : ℂ) :
+    L.toPoint hD z = 0 ↔ z ∈ L.lattice :=
+  ⟨(L.isUniformization_toPoint hD).2.2 z, fun hz => L.toPoint_of_mem hD hz⟩
+
+scoped instance kw_instIsElliptic : L.weierstrassCurve.IsElliptic :=
+  ⟨isUnit_iff_ne_zero.mpr L.kw_discriminantNeZero.weierstrassCurve_Δ_ne_zero⟩
+
+section Liouville
+
+private theorem _root_.PeriodPair.sub_fract_mem_lattice (z : ℂ) :
+    z - ZSpan.fract L.basis z ∈ L.lattice := by
+  rw [L.lattice_eq_span_range_basis]
+  have h := (ZSpan.fract_eq_fract L.basis (ZSpan.fract L.basis z) z).mp
+    (by rw [ZSpan.fract_eq_self.mpr (ZSpan.fract_mem_fundamentalDomain L.basis z)])
+  simpa [neg_add_eq_sub] using h
+
+p2m_export "PeriodPair" "sub_fract_mem_lattice"
+
+private theorem _root_.PeriodPair.apply_eq_apply_of_differentiable_of_forall_periodic {f : ℂ → ℂ}
+    (hf : Differentiable ℂ f) (hper : ∀ l ∈ L.lattice, ∀ z, f (z + l) = f z) (z w : ℂ) :
+    f z = f w := by
+  apply hf.apply_eq_apply_of_bounded
+  have hrange : range f ⊆ f '' closure (ZSpan.fundamentalDomain L.basis) := by
+    rintro - ⟨u, rfl⟩
+    refine ⟨ZSpan.fract L.basis u, subset_closure (ZSpan.fract_mem_fundamentalDomain _ u), ?_⟩
+    have h := hper _ (L.sub_fract_mem_lattice u) (ZSpan.fract L.basis u)
+    rw [add_sub_cancel] at h
+    exact h.symm
+  refine Bornology.IsBounded.subset ?_ hrange
+  refine (IsCompact.image ?_ hf.continuous).isBounded
+  exact Metric.isCompact_of_isClosed_isBounded isClosed_closure
+    (ZSpan.fundamentalDomain_isBounded L.basis).closure
+
+p2m_export "PeriodPair" "apply_eq_apply_of_differentiable_of_forall_periodic"
+end Liouville
+
+section ToPointLemmas
+
+theorem toPoint_add_mem (h : L.DiscriminantNeZero) (z : ℂ) {l : ℂ} (hl : l ∈ L.lattice) :
+    L.toPoint h (z + l) = L.toPoint h z := by
+  by_cases hz : z ∈ L.lattice
+  · rw [L.toPoint_of_mem h hz, L.toPoint_of_mem h (add_mem hz hl)]
+  · have hzl : z + l ∉ L.lattice := fun hmem => hz (by simpa using sub_mem hmem hl)
+    rw [L.toPoint_of_notMem h hz, L.toPoint_of_notMem h hzl]
+    have hP : ℘[L] (z + l) = ℘[L] z := L.weierstrassP_add_coe z ⟨l, hl⟩
+    have hP' : ℘'[L] (z + l) = ℘'[L] z := L.derivWeierstrassP_add_coe z ⟨l, hl⟩
+    simp only [WeierstrassCurve.Affine.Point.some.injEq]
+    exact ⟨hP, by rw [hP']⟩
+
+theorem toPoint_neg (h : L.DiscriminantNeZero) (z : ℂ) :
+    L.toPoint h (-z) = -L.toPoint h z := by
+  by_cases hz : z ∈ L.lattice
+  · rw [L.toPoint_of_mem h hz, L.toPoint_of_mem h (neg_mem hz)]; rfl
+  · have hnz : -z ∉ L.lattice := fun hmem => hz (by simpa using neg_mem hmem)
+    rw [L.toPoint_of_notMem h hz, L.toPoint_of_notMem h hnz,
+      WeierstrassCurve.Affine.Point.neg_some]
+    simp only [WeierstrassCurve.Affine.Point.some.injEq]
+    refine ⟨L.weierstrassP_neg z, ?_⟩
+    rw [L.derivWeierstrassP_neg]
+    show -℘'[L] z / 2 = L.weierstrassCurve.toAffine.negY (℘[L] z) (℘'[L] z / 2)
+    rw [WeierstrassCurve.Affine.negY, weierstrassCurve_a₁, weierstrassCurve_a₃]
+    ring
+
+end ToPointLemmas
+
+section Isogeny
+
+private theorem _root_.PeriodPair.apply_eq_apply_of_continuous_of_mapsTo_lattice {f : ℂ → ℂ}
+    (hf : Continuous f)
+    (hmem : ∀ z, f z ∈ L.lattice) (z w : ℂ) : f z = f w := by
+  refine IsPreconnected.constant_of_mapsTo (isPreconnected_univ) ?_
+    hf.continuousOn (fun u _ => hmem u) (mem_univ z) (mem_univ w)
+  rw [isDiscrete_iff_discreteTopology]
+  exact inferInstanceAs (DiscreteTopology L.lattice)
+
+p2m_export "PeriodPair" "apply_eq_apply_of_continuous_of_mapsTo_lattice"
+
+theorem exists_smul_mem_and_apply_eq_of_forall_sub_mem (L' : PeriodPair) {F : ℂ → ℂ}
+    (hF : Differentiable ℂ F)
+    (hper : ∀ l ∈ L.lattice, ∀ z, F (z + l) - F z ∈ L'.lattice) :
+    ∃ α : ℂ, (∀ l ∈ L.lattice, α * l ∈ L'.lattice) ∧ ∀ z, F z = F 0 + α * z := by
+  have hFc : Continuous F := hF.continuous
+  have hconst : ∀ l ∈ L.lattice, ∀ z, F (z + l) - F z = F l - F 0 := by
+    intro l hl z
+    have h := L'.apply_eq_apply_of_continuous_of_mapsTo_lattice
+      (f := fun u => F (u + l) - F u)
+      ((hFc.comp (continuous_id.add continuous_const)).sub hFc) (hper l hl) z 0
+    simpa using h
+  have hadd : ∀ z w, F (z + w) = F z + F w - F 0 := by
+    intro z w
+    have hper' : ∀ l ∈ L.lattice, ∀ u,
+        (fun u => F (u + w) - F u) (u + l) = (fun u => F (u + w) - F u) u := by
+      intro l hl u
+      have h1 := hconst l hl (u + w)
+      have h2 := hconst l hl u
+      rw [show u + w + l = u + l + w by ring] at h1
+      simp only
+      linear_combination h1 - h2
+    have h := L.apply_eq_apply_of_differentiable_of_forall_periodic
+      (f := fun u => F (u + w) - F u)
+      ((hF.comp (differentiable_id.add_const w)).sub hF) hper' z 0
+    simp only [zero_add] at h
+    linear_combination h
+  set α : ℂ := deriv F 0 with hα
+  have hderiv : ∀ z, deriv F z = α := by
+    intro z
+    have hfun : (fun w => F (z + w)) = fun w => F w + (F z - F 0) := by
+      funext w
+      rw [hadd z w]; ring
+    have h1 : deriv (fun w => F (z + w)) 0 = deriv F z := by
+      rw [deriv_comp_const_add]
+      simp
+    have h2 : deriv (fun w => F w + (F z - F 0)) 0 = deriv F 0 := by
+      rw [deriv_add_const]
+    rw [← h1, hfun, h2]
+  have haffine : ∀ z, F z = F 0 + α * z := by
+    have hG : Differentiable ℂ fun z => F z - α * z :=
+      hF.sub (differentiable_id.const_mul α)
+    have hG' : ∀ z, deriv (fun z => F z - α * z) z = 0 := by
+      intro z
+      have hd : HasDerivAt (fun z => F z - α * z) (deriv F z - α * 1) z :=
+        (hF z).hasDerivAt.sub ((hasDerivAt_id z).const_mul α)
+      rw [hd.deriv, hderiv z]
+      ring
+    intro z
+    have h := is_const_of_deriv_eq_zero hG hG' z 0
+    simp only [mul_zero, sub_zero] at h
+    linear_combination h
+  refine ⟨α, fun l hl => ?_, haffine⟩
+  have h := hper l hl 0
+  rw [zero_add, haffine l] at h
+  simpa using h
+
+end Isogeny
+
+section Scale
+
+variable (α : ℂˣ)
+
+private def mulLeftR (a : ℂ) : ℂ →ₗ[ℝ] ℂ := Algebra.lmul ℝ ℂ a
+
+@[scoped simp] private theorem mulLeftR_apply (a z : ℂ) : mulLeftR a z = a * z := rfl
+
+private theorem mulLeftR_injective {a : ℂ} (ha : a ≠ 0) :
+    Function.Injective (mulLeftR a) := fun _ _ h => by
+  simpa using mul_left_cancel₀ ha h
+
+private def mulLeftZ (a : ℂ) : ℂ →ₗ[ℤ] ℂ := (mulLeftR a).restrictScalars ℤ
+
+@[scoped simp] private theorem mulLeftZ_apply (a z : ℂ) : mulLeftZ a z = a * z := rfl
+
+private theorem _root_.PeriodPair.scale_lattice :
+    (L.scale α).lattice = Submodule.map (mulLeftZ (α : ℂ)) L.lattice := by
+  unfold lattice scale
+  rw [Submodule.map_span]
+  congr 1
+  ext z
+  simp only [Set.mem_insert_iff, Set.mem_singleton_iff, Set.mem_image, mulLeftZ_apply]
+  constructor
+  · rintro (rfl | rfl)
+    · exact ⟨L.ω₁, Or.inl rfl, rfl⟩
+    · exact ⟨L.ω₂, Or.inr rfl, rfl⟩
+  · rintro ⟨w, hw | hw, rfl⟩ <;> simp [hw]
+
+p2m_export "PeriodPair" "scale_lattice"
+theorem mem_scale_lattice_iff {z : ℂ} :
+    z ∈ (L.scale α).lattice ↔ ∃ l ∈ L.lattice, z = (α : ℂ) * l := by
+  rw [scale_lattice, Submodule.mem_map]; simp only [mulLeftZ_apply]; tauto
+
+private def _root_.PeriodPair.scaleLatticeEquiv : L.lattice ≃ₗ[ℤ] (L.scale α).lattice :=
+  (Submodule.equivMapOfInjective (mulLeftZ (α : ℂ))
+    (fun _ _ h => mul_left_cancel₀ α.ne_zero (by simpa using h)) L.lattice).trans
+    (LinearEquiv.ofEq _ _ (L.scale_lattice α).symm)
+
+p2m_export "PeriodPair" "scaleLatticeEquiv"
+@[scoped simp] theorem scaleLatticeEquiv_apply (l : L.lattice) :
+    ((L.scaleLatticeEquiv α l : (L.scale α).lattice) : ℂ) = (α : ℂ) * (l : ℂ) := rfl
+
+end Scale
+
+section Homogeneity
+
+variable (α : ℂˣ)
+
+theorem G_scale (n : ℕ) : (L.scale α).G n = ((α : ℂ) ^ n)⁻¹ * L.G n := by
+  unfold G
+  rw [← (L.scaleLatticeEquiv α).toEquiv.tsum_eq]
+  simp only [LinearEquiv.coe_toEquiv, scaleLatticeEquiv_apply, mul_pow, mul_inv]
+  exact tsum_mul_left
+
+theorem g₂_scale : (L.scale α).g₂ = ((α : ℂ) ^ 4)⁻¹ * L.g₂ := by
+  unfold g₂; rw [G_scale]; ring
+
+theorem g₃_scale : (L.scale α).g₃ = ((α : ℂ) ^ 6)⁻¹ * L.g₃ := by
+  unfold g₃; rw [G_scale]; ring
+
+theorem discriminant_scale :
+    (L.scale α).g₂ ^ 3 - 27 * (L.scale α).g₃ ^ 2
+      = ((α : ℂ) ^ 12)⁻¹ * (L.g₂ ^ 3 - 27 * L.g₃ ^ 2) := by
+  rw [g₂_scale, g₃_scale]; ring
+
+theorem g₂_cubed_scale : (L.scale α).g₂ ^ 3 = ((α : ℂ) ^ 12)⁻¹ * L.g₂ ^ 3 := by
+  rw [g₂_scale, mul_pow, inv_pow, ← pow_mul]
+
+theorem jLattice_scale : (L.scale α).jLattice = L.jLattice := by
+  have hα : ((α : ℂ) ^ 12)⁻¹ ≠ 0 := inv_ne_zero (pow_ne_zero _ α.ne_zero)
+  unfold jLattice
+  rw [discriminant_scale, g₂_cubed_scale, mul_left_comm (1728 : ℂ), mul_div_mul_left _ _ hα]
+
+theorem discriminantNeZero_scale_iff :
+    (L.scale α).DiscriminantNeZero ↔ L.DiscriminantNeZero := by
+  unfold DiscriminantNeZero
+  rw [discriminant_scale]
+  simp only [mul_ne_zero_iff, and_iff_right (inv_ne_zero (pow_ne_zero 12 α.ne_zero))]
+
+end Homogeneity
+
+section LatticeDependence
+
+variable {L L' : PeriodPair}
+
+private def latticeEquivOfEq (h : L.lattice = L'.lattice) : L.lattice ≃ L'.lattice where
+  toFun l := ⟨(l : ℂ), h ▸ l.2⟩
+  invFun l := ⟨(l : ℂ), h.symm ▸ l.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+
+theorem G_eq_of_lattice_eq (h : L.lattice = L'.lattice) (n : ℕ) : L.G n = L'.G n :=
+  (latticeEquivOfEq h).tsum_eq fun l => ((l : ℂ) ^ n)⁻¹
+
+theorem g₂_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.g₂ = L'.g₂ := by
+  unfold g₂; rw [G_eq_of_lattice_eq h]
+
+theorem g₃_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.g₃ = L'.g₃ := by
+  unfold g₃; rw [G_eq_of_lattice_eq h]
+
+theorem jLattice_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.jLattice = L'.jLattice := by
+  unfold jLattice; rw [g₂_eq_of_lattice_eq h, g₃_eq_of_lattice_eq h]
+
+end LatticeDependence
+
+section Gates
+
+theorem gate_scale_mul (α β : ℂˣ) :
+    ((L.scale α).scale β).lattice = (L.scale (β * α)).lattice := by
+  ext z
+  simp only [mem_scale_lattice_iff, Units.val_mul]
+  constructor
+  · rintro ⟨-, ⟨l, hl, rfl⟩, rfl⟩; exact ⟨l, hl, (mul_assoc _ _ _).symm⟩
+  · rintro ⟨l, hl, rfl⟩; exact ⟨(α : ℂ) * l, ⟨l, hl, rfl⟩, mul_assoc _ _ _⟩
+
+end Gates
+
+private theorem _root_.PeriodPair.kw_countable_lattice : (L.lattice : Set ℂ).Countable := by
+  refine (Set.countable_range fun p : ℤ × ℤ => (p.1 : ℂ) * L.ω₁ + (p.2 : ℂ) * L.ω₂).mono ?_
+  intro z hz
+  obtain ⟨m, n, h⟩ := mem_lattice.mp hz
+  exact ⟨(m, n), h⟩
+
+p2m_export "PeriodPair" "kw_countable_lattice"
+
+private def _root_.PeriodPair.kw_toPointHom : ℂ →+ (L.weierstrassCurve.toAffine).Point where
+  toFun := L.toPoint L.kw_discriminantNeZero
+  map_zero' := L.toPoint_zero L.kw_discriminantNeZero
+  map_add' := L.kw_toPoint_add L.kw_discriminantNeZero
+
+p2m_export "PeriodPair" "kw_toPointHom"
+theorem kw_toPointHom_apply (z : ℂ) :
+    L.kw_toPointHom z = L.toPoint L.kw_discriminantNeZero z := rfl
+
+private theorem _root_.PeriodPair.kw_ker_toPointHom :
+    L.kw_toPointHom.ker = L.lattice.toAddSubgroup := by
+  ext z
+  constructor
+  · exact fun hz => (L.kw_isUniformization).2.2 z hz
+  · intro hz
+    exact L.toPoint_of_mem L.kw_discriminantNeZero hz
+
+p2m_export "PeriodPair" "kw_ker_toPointHom"
+
+private def _root_.PeriodPair.kw_toPointAddEquiv :
+    (ℂ ⧸ L.lattice.toAddSubgroup) ≃+ (L.weierstrassCurve.toAffine).Point :=
+  QuotientAddGroup.liftEquiv L.lattice.toAddSubgroup (φ := L.kw_toPointHom)
+    (L.kw_isUniformization).2.1 L.kw_ker_toPointHom.symm
+
+p2m_export "PeriodPair" "kw_toPointAddEquiv"
+theorem kw_toPointAddEquiv_mk (z : ℂ) :
+    L.kw_toPointAddEquiv (QuotientAddGroup.mk z) = L.toPoint L.kw_discriminantNeZero z :=
+  rfl
+
+scoped instance kw_infinite_quotientLattice : Infinite (ℂ ⧸ L.lattice.toAddSubgroup) := by
+  rw [← not_finite_iff_infinite]; intro hfin
+  have : Countable L.lattice.toAddSubgroup :=
+    Set.countable_coe_iff.mpr L.kw_countable_lattice
+  have : Countable ((ℂ ⧸ L.lattice.toAddSubgroup) × L.lattice.toAddSubgroup) := inferInstance
+  have hCc : Countable ℂ :=
+    Countable.of_equiv _ (AddSubgroup.addGroupEquivQuotientProdAddSubgroup
+      (s := L.lattice.toAddSubgroup)).symm
+  have : Uncountable ℂ := Complex.ofReal_injective.uncountable
+  exact absurd hCc not_countable
+
+scoped instance kw_infinite_point : Infinite L.weierstrassCurve.toAffine.Point :=
+  L.kw_toPointAddEquiv.toEquiv.infinite_iff.mp inferInstance
+
+end PeriodPair
+end
+
+theorem s13_aeval_diag_eq_eval_map {R : Type*} [CommRing R] (Φ : Polynomial (Polynomial ℤ)) (a : R)
+    :
+    Polynomial.aeval a (Φ.eval₂ (RingHom.id (Polynomial ℤ)) Polynomial.X)
+      = (Φ.map (Polynomial.eval₂RingHom (Int.castRingHom R) a)).eval a := by
+  let lhs : Polynomial (Polynomial ℤ) →+* R :=
+    (Polynomial.aeval (R := ℤ) a).toRingHom.comp (Polynomial.eval₂RingHom (RingHom.id (Polynomial
+      ℤ)) Polynomial.X)
+  let rhs : Polynomial (Polynomial ℤ) →+* R :=
+    (Polynomial.evalRingHom a).comp (Polynomial.mapRingHom (Polynomial.eval₂RingHom (Int.castRingHom
+      R) a))
+  have h : lhs = rhs := by
+    refine Polynomial.ringHom_ext (fun c => ?_) ?_
+    · simp only [lhs, rhs, RingHom.comp_apply, Polynomial.coe_eval₂RingHom, RingHom.id_apply,
+        Polynomial.coe_mapRingHom, Polynomial.map_C, Polynomial.coe_evalRingHom,
+        Polynomial.eval_C, AlgHom.toRingHom_eq_coe, RingHom.coe_coe, Polynomial.aeval_def,
+        Polynomial.eval₂_eq_eval_map]
+      simp []
+    · simp [lhs, rhs]
+  exact RingHom.congr_fun h Φ
+
+theorem s13_j_weierstrassCurve_eq_jLattice (L : PeriodPair) [L.weierstrassCurve.IsElliptic] :
+    L.weierstrassCurve.j = L.jLattice := by
+  rw [PeriodPair.jLattice_eq_c₄_pow_three_div_Δ, WeierstrassCurve.j, ← WeierstrassCurve.coe_Δ',
+    div_eq_mul_inv, mul_comm, Units.val_inv_eq_inv_val]
+
+open _root_.WeierstrassCurve
+  _root_.P2MW.S_OVERLONG_e162e25a.WeierstrassCurve
+  _root_.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_e162e25a.WeierstrassCurve.Affine
+  AlgebraicCurve _root_.ModularCurve
+  _root_.P2MW.S_OVERLONG_e162e25a.ModularCurve
+  in
+theorem solution
+    {K : Type u} [Field K] [IsAlgClosed K] [CharZero K]
+    (W : WeierstrassCurve K) [W.IsElliptic]
+    {N : ℕ} [NeZero N] (hN : Squarefree N) (data : ModularCurve.ModularPolynomialData N)
+    (D : IsogenyEndDatum W.toAffine) (hdeg : finrankAlong K D.ι = N) :
+    Polynomial.aeval W.j (data.Φ.eval₂ (RingHom.id (Polynomial ℤ)) Polynomial.X) = 0 := by
+  classical
+  obtain ⟨K₀, hK₀c, E₀, hE₀e, hE₀map, ι₀, hι₀, hfin₀, hrk₀⟩ :=
+    WeierstrassCurve.exists_intermediateField_countable_map_eq_and_finrankAlong_eq W D.ι D.hι D.hfin
+  have := hE₀e
+  have : Countable K₀ := hK₀c
+  have : CharZero (AlgebraicClosure K₀) :=
+    charZero_of_injective_algebraMap (algebraMap K₀ (AlgebraicClosure K₀)).injective
+  obtain ⟨σ⟩ := kw_nonempty_ringHom_algebraicClosure_complex (↥K₀)
+  let : Algebra (AlgebraicClosure K₀) ℂ := σ.toAlgebra
+  let : Algebra (↥K₀) ℂ := (σ.comp (algebraMap (↥K₀) (AlgebraicClosure K₀))).toAlgebra
+  have : IsScalarTower (↥K₀) (AlgebraicClosure K₀) ℂ := IsScalarTower.of_algebraMap_eq' rfl
+  obtain ⟨ι₁, hι₁, hfin₁, hrk₁⟩ :=
+    WeierstrassCurve.Affine.exists_algHom_functionField_baseChange_finrankAlong_eq E₀
+      (AlgebraicClosure K₀) ℂ ι₀ hι₀ hfin₀
+  have hN₁ : finrankAlong ℂ ι₁ = N := hrk₁.trans (hrk₀.trans hdeg)
+  have hjK : W.j = algebraMap (↥K₀) K E₀.j := by
+    subst hE₀map
+    exact E₀.map_j (algebraMap (↥K₀) K)
+  have hE1inst : (E₀.baseChange ℂ).IsElliptic :=
+    inferInstanceAs (E₀.map (algebraMap (↥K₀) ℂ)).IsElliptic
+  have hjC : (E₀.baseChange ℂ).j = algebraMap (↥K₀) ℂ E₀.j := E₀.map_j (algebraMap (↥K₀) ℂ)
+  set d := data.Φ.eval₂ (RingHom.id (Polynomial ℤ)) Polynomial.X with hd
+  suffices hℂ : Polynomial.aeval (E₀.baseChange ℂ).j d = 0 by
+    have h0 : Polynomial.aeval E₀.j d = 0 := by
+      apply (algebraMap (↥K₀) ℂ).injective
+      rw [map_zero, ← Polynomial.aeval_algebraMap_apply, ← hjC]
+      exact hℂ
+    rw [hjK, Polynomial.aeval_algebraMap_apply, h0, map_zero]
+  generalize hE1 : E₀.baseChange ℂ = E₁ at ι₁ hι₁ hfin₁ hN₁ hE1inst
+  obtain ⟨L, C, hC⟩ := PeriodPair.exists_variableChange_smul_weierstrassCurve_eq E₁
+  subst hC
+  have hL : L.DiscriminantNeZero := PeriodPair.discriminant_ne_zero L
+  have hLe : L.weierstrassCurve.IsElliptic :=
+    ⟨isUnit_iff_ne_zero.mpr hL.weierstrassCurve_Δ_ne_zero⟩
+  have : IsDedekindDomain L.weierstrassCurve.toAffine.CoordinateRing :=
+    WeierstrassCurve.Affine.CoordinateRing.isDedekindDomain L.weierstrassCurve
+  have : HasPrincipalDivisors ℂ L.weierstrassCurve.toAffine.FunctionField :=
+    WeierstrassCurve.Affine.hasPrincipalDivisors_functionField _
+  obtain ⟨g, hgc, hga⟩ :=
+    WeierstrassCurve.Affine.exists_genusOnePlaceGate_isCentred_and_abelTheorem (W :=
+      L.weierstrassCurve.toAffine)
+  let := g
+  have := hgc
+  have := hga
+  obtain ⟨eE⟩ :=
+    WeierstrassCurve.nonempty_functionField_algEquiv_of_variableChange L.weierstrassCurve C
+  let ι₂ := kw_fdn2_qephod_hend21_conjSeam eE eE ι₁
+  have hι₂ : ι₂.toRingHom.IsIntegral := kw_fdn2_qephod_hend21_conjSeam_isIntegral eE eE ι₁ hι₁
+  have hfin₂ : FiniteAlong ℂ ι₂ := kw_fdn2_qephod_hend21_conjSeam_finiteAlong eE eE ι₁ hfin₁
+  have hrk₂ : finrankAlong ℂ ι₂ = N := (kw_fdn2_qephod_hend21_finrankAlong_conj eE eE ι₁).trans hN₁
+  have hN₂ : NormFormulaAlong ℂ ι₂ hfin₂ := normFormulaAlong_of_elliptic ι₂ hfin₂
+  have hcard : Nat.card (pointMapOfPushforward ι₂ hι₂ hfin₂ hN₂).ker = N :=
+    (WeierstrassCurve.Affine.natCard_ker_pointMapOfPushforward_eq_finrankAlong _ _ ι₂ hι₂ hfin₂
+      hN₂).trans hrk₂
+  have hcyc : IsAddCyclic (pointMapOfPushforward ι₂ hι₂ hfin₂ hN₂).ker :=
+    IsAddCyclic.of_squarefree_natCard (hcard.symm ▸ hN)
+  obtain ⟨β, hsub, hidx, hcq⟩ :=
+    PeriodPair.exists_scale_lattice_subset_and_sublatticeIndex_eq_and_isAddCyclic_sublatticeQuotient
+      L L ι₂ hι₂ hfin₂ hN₂ N hcyc hcard
+  have hroot :=
+    ModularCurve.ModularPolynomialData.eval_jLattice_eq_zero_of_isAddCyclic N data L (L.scale β)
+    hsub hidx hcq
+  rw [PeriodPair.jLattice_scale] at hroot
+  rw [WeierstrassCurve.variableChange_j, s13_j_weierstrassCurve_eq_jLattice,
+    s13_aeval_diag_eq_eval_map]
+  exact hroot
+
+end
+end S_OVERLONG_e162e25a
+end P2MW
+export P2MW.S_OVERLONG_e162e25a
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+universe u
+theorem WeierstrassCurve.Affine.IsogenyEndDatum.aeval_j_diag_eq_zero_of_finrankAlong_eq
+    {K : Type u} [Field K] [IsAlgClosed K] [CharZero K]
+    (W : WeierstrassCurve K) [W.IsElliptic]
+    {N : ℕ} [NeZero N] (hN : Squarefree N) (data : ModularCurve.ModularPolynomialData N)
+    (D : IsogenyEndDatum W.toAffine) (hdeg : finrankAlong K D.ι = N) :
+    Polynomial.aeval W.j (data.Φ.eval₂ (RingHom.id (Polynomial ℤ)) Polynomial.X) = 0 := by
+  classical
+  exact
+    solution W hN data D hdeg
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_dualEndData_dual_mem_and_norm_eq_finrankAlong.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_dualEndData_dual_mem_and_norm_eq_finrankAlong.lean
new file mode 100644
index 0000000000..abbc478e6e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_dualEndData_dual_mem_and_norm_eq_finrankAlong.lean
@@ -0,0 +1,4100 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.Affine.IsogenyEndDatum.exists_dualEndData_dual_mem_and_norm_eq_finrankAlong
+(7adb32a2-3d95-5f94-8f9b-631ec0a69a45) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 67b5cb36-254f-5a1b-99ed-935bbd484158
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_DualIsogenyAPI
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.AlgebraicGeometry.EllipticCurve.Reduction
+import Mathlib.Analysis.Complex.UpperHalfPlane.Basic
+import Mathlib.Order.CompletePartialOrder
+import Mathlib.RingTheory.DedekindDomain.Different
+import Mathlib.RingTheory.LocalProperties.Reduced
+import Mathlib.Tactic.NormNum.Prime
+
+import LeanPool.FLTEichlerShimura.Definitions.Defs_AlgebraicCurve_residueTheorem_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Defs_IsogenyEndDatum_sharedLibrary
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_min_ord_le_ord_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_addX_addY_specialize_at_place
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_exists_zsmul_eq_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_finite_torsionBy_of_natCast_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_nonempty_torsionBy_addEquiv_zmod_prod_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum
+
+/-!
+# Existence of dual endomorphism data with norm the degree
+
+Theorem statement:
+`WeierstrassCurve.Affine.IsogenyEndDatum.exists_dualEndData_dual_mem_and_norm_eq_finrankAlong`
+(`7adb32a2-3d95-5f94-8f9b-631ec0a69a45`), by Claude, 2026-09-05.
+
+Proof: submission `67b5cb36-254f-5a1b-99ed-935bbd484158`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field of characteristic zero and let $W$ be an affine Weierstrass
+curve over $F$ that is elliptic, equipped with three pieces of structure: a `GenusOnePlaceGate`,
+that is a bijection between the group $W(F)$ of points `W.Point` and the set of places of the
+function field $F(W)$ together with the assertion that every such place has degree $1$; the
+centredness property `GenusOnePlaceGate.IsCentred`, saying that for each nonsingular affine point
+$(x,y)$ the images in $F(W)$ of the coordinate-ring classes of $X - x$ and $Y - y$ lie in the
+nonunits of the valuation subring of the place attached to that point; and `AbelTheorem`, saying
+that a divisor of degree $0$ on $F(W)$ is principal exactly when the sum of its points in $W(F)$ is
+$0$. Assume further that for every isogeny endomorphism datum $D$ of $W$ — a structure consisting of
+an $F$-algebra map $\iota : F(W) \to F(W)$ which is integral as a ring homomorphism, together with
+the finiteness of $F(W)$ as a module over itself along $\iota$ — the pushforward norm formula holds
+along $\iota$: for every nonzero $f \in F(W)$, every divisor whose multiplicity at each place $w$ is
+$\mathrm{ord}_w(f)$, and every place $v$, the pushforward divisor has multiplicity
+$\mathrm{ord}_v(\mathrm{Norm}(f))$ at $v$. Then for each such datum $D$, writing $\varphi$ for the
+induced additive endomorphism `D.pointEnd` of $W(F)$ obtained from $\iota$ by pushforward of divisor
+classes, there exist an additive endomorphism $\hat\varphi$ of $W(F)$ and integers $t$, $n$ with
+$\varphi + \hat\varphi = t$, $\varphi\hat\varphi = \hat\varphi\varphi = n$ as endomorphisms of
+$W(F)$, such that $\hat\varphi$ lies in the subring of $\mathrm{End}(W(F))$ generated by the
+endomorphisms attached to all isogeny endomorphism data, and $n$ equals the $F(W)$-dimension of
+$F(W)$ taken along $\iota$.
+
+This is the existence of the dual isogeny in the function-field presentation of endomorphisms of an
+elliptic curve: $\hat\varphi\varphi = \varphi\hat\varphi = [\deg\varphi]$ and $\varphi + \hat\varphi
+\in \mathbb{Z}$, with the dual again lying in the subring generated by the endomorphisms coming from
+isogeny data. It supplies the dual-and-trace input for
+[`WeierstrassCurve.Affine.IsogenyEndDatum.exists_sq_lt_four_mul_and_forall_exists_finrankAlong_eq`]
+(thm.html#WeierstrassCurve.Affine.IsogenyEndDatum.
+exists_sq_lt_four_mul_and_forall_exists_finrankAlong_eq),
+where the degree form on the endomorphism ring is shown to satisfy the expected quadratic
+inequality.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_IsogenyEndDatum_exists_dualEndData_dual_mem_and_norm_eq_finrankAlong.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 800000
+
+section privateSection
+
+open WeierstrassCurve Affine AlgebraicCurve Polynomial
+  ModularCurve AddMonoidHom AddMonoid.End IsDedekindDomain WithZero IsLocalRing
+
+set_option backward.isDefEq.respectTransparency.types false
+
+
+noncomputable section
+
+namespace WeierstrassCurve
+namespace Affine
+
+scoped instance instHasPrincipalDivisorsFunctionField_s13 {F : Type*} [Field F] [CharZero F]
+    {W : Affine F} : HasPrincipalDivisors F W.FunctionField :=
+  hasPrincipalDivisors_functionField W
+
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+
+private theorem nonempty_pointTorsionBy_zmod {K : Type*} [Field K]
+    [DecidableEq K] [IsAlgClosed K] [CharZero K]
+    (W : WeierstrassCurve K) [W.IsElliptic] {n : ℕ} (hn : 1 ≤ n) :
+    Nonempty (Submodule.torsionBy ℤ W.toAffine.Point (n : ℤ) ≃+ (Fin 2 → ZMod n)) := by
+  have hn0 : (n : K) ≠ 0 := by exact_mod_cast (Nat.one_le_iff_ne_zero.mp hn)
+  have h := WeierstrassCurve.nonempty_torsionBy_addEquiv_zmod_prod_of_isAlgClosed (K := K) W hn0
+  have hW : WeierstrassCurve.Affine.baseChange W K = W.toAffine := by
+    rw [WeierstrassCurve.Affine.baseChange, WeierstrassCurve.baseChange, Algebra.algebraMap_self,
+      WeierstrassCurve.map_id]
+  rw [hW] at h
+  obtain ⟨e⟩ := h
+  exact ⟨e.symm.trans (LinearEquiv.piFinTwo ℤ (fun _ : Fin 2 => ZMod n)).toAddEquiv.symm⟩
+
+end WeierstrassCurve
+
+section
+
+namespace ModularCurve
+
+section KernelCardEngine
+
+variable {K : Type*} [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable (W : WeierstrassCurve K) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+omit [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [AbelTheorem W] in
+theorem cmm5_dp_natCard_ker_natCast (n : ℕ) (hn : 1 ≤ n) :
+    Nat.card (AddMonoidHom.ker ((n : ℤ) : AddMonoid.End W.toAffine.Point)) = n ^ 2 := by
+  obtain ⟨e⟩ := W.nonempty_pointTorsionBy_zmod hn
+  have : NeZero n := ⟨Nat.one_le_iff_ne_zero.mp hn⟩
+  have hsets : ∀ x : W.toAffine.Point,
+      x ∈ AddMonoidHom.ker ((n : ℤ) : AddMonoid.End W.toAffine.Point)
+        ↔ x ∈ Submodule.torsionBy ℤ W.toAffine.Point (n : ℤ) := by
+    intro x
+    exact AddMonoidHom.mem_ker.trans (Submodule.mem_torsionBy_iff (n : ℤ) x).symm
+  calc Nat.card (AddMonoidHom.ker ((n : ℤ) : AddMonoid.End W.toAffine.Point))
+      = Nat.card (Submodule.torsionBy ℤ W.toAffine.Point (n : ℤ)) :=
+        Nat.card_congr (Equiv.subtypeEquivRight hsets)
+    _ = Nat.card (Fin 2 → ZMod n) := Nat.card_congr e.toEquiv
+    _ = n ^ 2 := by
+        rw [Nat.card_fun, Nat.card_zmod, Nat.card_eq_fintype_card, Fintype.card_fin]
+
+end KernelCardEngine
+end ModularCurve
+end
+
+section
+
+namespace ModularCurve
+
+universe u
+
+section Lagrange
+
+variable {A B : Type*} [AddCommGroup A] [AddCommGroup B]
+
+theorem cmm14_dex_card_ker_zsmul_eq_zero (φ : A →+ B) {a : A} (ha : φ a = 0) :
+    (Nat.card (AddMonoidHom.ker φ) : ℤ) • a = 0 := by
+  have hmem : a ∈ AddMonoidHom.ker φ := AddMonoidHom.mem_ker.mpr ha
+  have hcoe : (AddMonoidHom.ker φ).subtype
+      (Nat.card (AddMonoidHom.ker φ) • (⟨a, hmem⟩ : AddMonoidHom.ker φ)) = 0 := by
+    rw [card_nsmul_eq_zero', _root_.map_zero]
+  rw [map_nsmul, AddSubgroup.subtype_apply] at hcoe
+  rw [natCast_zsmul]
+  exact hcoe
+
+end Lagrange
+end ModularCurve
+end
+
+section
+
+namespace WeierstrassCurve
+namespace Affine
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+namespace IsogenyEndDatum
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem isIntegral_algHomId :
+    (AlgHom.id F W.FunctionField).toRingHom.IsIntegral :=
+  RingHom.isIntegral_of_surjective _ Function.surjective_id
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem finiteAlong_algHomId : FiniteAlong F (AlgHom.id F W.FunctionField) := by
+  unfold FiniteAlong algebraAlong
+  exact Module.Finite.self _
+
+def idDatum : IsogenyEndDatum W where
+  ι := AlgHom.id F W.FunctionField
+  hι := isIntegral_algHomId W
+  hfin := finiteAlong_algHomId W
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem restrictAlong_algHomId (w : AlgebraicCurve.Place F W.FunctionField) :
+    w.restrictAlong (AlgHom.id F W.FunctionField) (isIntegral_algHomId W) = w :=
+  AlgebraicCurve.Place.ext (SetLike.ext fun _ => Iff.rfl)
+
+omit [GenusOnePlaceGate.IsCentred W] in
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem idDatum_pointEnd : (idDatum W).pointEnd' = 1 := by
+  refine AddMonoidHom.ext fun P => ?_
+  exact (idDatum W).pointEnd'_eq_of_seam id rfl (fun Q => restrictAlong_algHomId W _) P
+
+end IsogenyEndDatum
+
+namespace IsogenyEndDatum
+
+variable {W}
+
+private def degree (D : IsogenyEndDatum W) :
+    ℕ := finrankAlong F D.ι
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem degree_idDatum : (idDatum W).degree = 1 := by
+  unfold degree idDatum finrankAlong algebraAlong
+  exact Module.finrank_self _
+
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+
+end
+
+section
+
+section
+
+namespace ModularCurve
+namespace Es1a1
+
+section InstanceWorld
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [Algebra.IsIntegral F F'] [HasPrincipalDivisors K F']
+
+omit [HasPrincipalDivisors K F'] in
+theorem es1a1_dual_inertiaDeg_eq_one (hdegF : ∀ v : Place K F, v.deg = 1)
+    (hdegF' : ∀ w : Place K F', w.deg = 1) (w : Place K F') :
+    w.inertiaDeg F = 1 := by
+  have h := w.deg_restrict_mul_inertiaDeg (F := F)
+  rwa [hdegF (w.restrict F), hdegF' w, one_mul] at h
+
+theorem es1a1_dual_sum_ramificationIndex [FundamentalIdentity K F F']
+    (hdegF : ∀ v : Place K F, v.deg = 1) (hdegF' : ∀ w : Place K F', w.deg = 1)
+    (v : Place K F) :
+    ∑ w ∈ v.fiber F', (w.ramificationIndex F : ℤ) = (Module.finrank F F' : ℤ) := by
+  have h := FundamentalIdentity.sum_ramificationIndex_mul_deg
+    (K := K) (F := F) (F' := F') v
+  simp only [hdegF', hdegF, Nat.cast_one, mul_one] at h
+  exact h
+
+theorem es1a1_dual_pushforward_pullback_single [FundamentalIdentity K F F']
+    (hdegF : ∀ v : Place K F, v.deg = 1) (hdegF' : ∀ w : Place K F', w.deg = 1)
+    (v : Place K F) (n : ℤ) :
+    Divisor.pushforward F (Divisor.pullback F' (Finsupp.single v n))
+      = Finsupp.single v ((Module.finrank F F' : ℤ) * n) := by
+  rw [Divisor.pullback_single, map_sum]
+  calc ∑ w ∈ v.fiber F',
+        Divisor.pushforward F (Finsupp.single w (n * w.ramificationIndex F))
+      = ∑ w ∈ v.fiber F', Finsupp.single v (n * (w.ramificationIndex F : ℤ)) :=
+        Finset.sum_congr rfl fun w hw => by
+          rw [Divisor.pushforward_single, Place.mem_fiber.mp hw,
+            es1a1_dual_inertiaDeg_eq_one hdegF hdegF' w, Nat.cast_one, mul_one]
+    _ = Finsupp.single v ((Module.finrank F F' : ℤ) * n) := by
+        rw [← Finsupp.single_finsetSum, ← Finset.mul_sum,
+          es1a1_dual_sum_ramificationIndex hdegF hdegF' v, mul_comm]
+
+theorem es1a1_dual_pushforward_pullback [FundamentalIdentity K F F']
+    (hdegF : ∀ v : Place K F, v.deg = 1) (hdegF' : ∀ w : Place K F', w.deg = 1)
+    (D : Divisor K F) :
+    Divisor.pushforward F (Divisor.pullback F' D)
+      = (Module.finrank F F' : ℤ) • D := by
+  induction D using Finsupp.induction with
+  | zero => simp
+  | single_add v n D _ _ ih =>
+    rw [map_add, map_add, smul_add, ih,
+      es1a1_dual_pushforward_pullback_single hdegF hdegF' v n,
+      Finsupp.smul_single, smul_eq_mul]
+
+end InstanceWorld
+
+section Conorm
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+variable (ι : W.FunctionField →ₐ[F] W.FunctionField) (hι : ι.toRingHom.IsIntegral)
+
+def es1a1_conormDegZero (hFI : FundamentalIdentityAlong F ι hι) :
+    Divisor.degZero (K := F) (F := W.FunctionField) →+
+      Divisor.degZero (K := F) (F := W.FunctionField) :=
+  ((Divisor.pullbackAlong ι hι).domRestrict
+    (Divisor.degZero (K := F) (F := W.FunctionField))).codRestrict _
+    (fun D => Divisor.pullbackAlong_mem_degZero ι hι hFI D.2)
+
+omit [DecidableEq F] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+@[scoped simp]
+theorem es1a1_coe_conormDegZero (hFI : FundamentalIdentityAlong F ι hι)
+    (D : Divisor.degZero (K := F) (F := W.FunctionField)) :
+    (es1a1_conormDegZero ι hι hFI D : Divisor F W.FunctionField)
+      = Divisor.pullbackAlong ι hι (D : Divisor F W.FunctionField) :=
+  rfl
+
+def es1a1_conormPic0Hom (hFI : FundamentalIdentityAlong F ι hι) :
+    Pic0 F W.FunctionField →+ Pic0 F W.FunctionField :=
+  QuotientAddGroup.map _ _ (es1a1_conormDegZero ι hι hFI) (by
+    rintro ⟨D, hD0⟩ hD
+    simp only [AddSubgroup.mem_addSubgroupOf] at hD ⊢
+    exact Divisor.isPrincipal_pullbackAlong ι hι hD)
+
+omit [DecidableEq F] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem es1a1_conormPic0Hom_mk (hFI : FundamentalIdentityAlong F ι hι)
+    (D : Divisor.degZero (K := F) (F := W.FunctionField)) :
+    es1a1_conormPic0Hom ι hι hFI (Pic0.mk D)
+      = Pic0.mk (es1a1_conormDegZero ι hι hFI D) :=
+  rfl
+
+omit [DecidableEq F] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem es1a1_dual_pushforwardAlong_pullbackAlong
+    (hFI : FundamentalIdentityAlong F ι hι) (D : Divisor F W.FunctionField) :
+    Divisor.pushforwardAlong ι hι (Divisor.pullbackAlong ι hι D)
+      = (finrankAlong F ι : ℤ) • D := by
+  let := algebraAlong ι
+  have := isScalarTower_along ι
+  have := isIntegral_along ι hι
+  have : FundamentalIdentity F W.FunctionField W.FunctionField := hFI
+  exact es1a1_dual_pushforward_pullback (deg_eq_one (W := W)) (deg_eq_one (W := W)) D
+
+omit [DecidableEq F] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem es1a1_dual_pushforwardAlongHom_conormPic0Hom
+    (hFI : FundamentalIdentityAlong F ι hι) (hfin : FiniteAlong F ι)
+    (hN : NormFormulaAlong F ι hfin) (c : Pic0 F W.FunctionField) :
+    Pic0.pushforwardAlongHom ι hι hfin hN (es1a1_conormPic0Hom ι hι hFI c)
+      = (finrankAlong F ι : ℤ) • c := by
+  refine QuotientAddGroup.induction_on c fun E => ?_
+  change Pic0.pushforwardAlongHom ι hι hfin hN
+      (es1a1_conormPic0Hom ι hι hFI (Pic0.mk E))
+    = (finrankAlong F ι : ℤ) • Pic0.mk E
+  have hd : Pic0.pushforwardAlongDegZero ι hι (es1a1_conormDegZero ι hι hFI E)
+      = (finrankAlong F ι : ℤ) • E := by
+    refine Subtype.ext ?_
+    rw [Pic0.coe_pushforwardAlongDegZero, es1a1_coe_conormDegZero,
+      es1a1_dual_pushforwardAlong_pullbackAlong ι hι hFI]
+    exact (map_zsmul ((Divisor.degZero (K := F) (F := W.FunctionField)).subtype)
+      _ _).symm
+  rw [es1a1_conormPic0Hom_mk, Pic0.pushforwardAlongHom_mk, hd]
+  exact map_zsmul (QuotientAddGroup.mk' _) _ _
+
+def es1a1_dualPointEnd (D : IsogenyEndDatum W)
+    (hFI : FundamentalIdentityAlong F D.ι D.hι) : AddMonoid.End W.Point :=
+  ((genusOnePic0Equiv W).toAddMonoidHom.comp
+      (es1a1_conormPic0Hom D.ι D.hι hFI)).comp
+    (genusOnePic0Equiv W).symm.toAddMonoidHom
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [GenusOnePlaceGate.IsCentred W] in
+theorem es1a1_dualPointEnd_apply (D : IsogenyEndDatum W)
+    (hFI : FundamentalIdentityAlong F D.ι D.hι) (P : W.Point) :
+    es1a1_dualPointEnd D hFI P
+      = genusOnePic0Equiv W
+          (es1a1_conormPic0Hom D.ι D.hι hFI ((genusOnePic0Equiv W).symm P)) :=
+  rfl
+
+omit [GenusOnePlaceGate.IsCentred W] in
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem es1a1_pointEnd_mul_dualPointEnd (D : IsogenyEndDatum W)
+    (hFI : FundamentalIdentityAlong F D.ι D.hι) :
+    D.pointEnd' * es1a1_dualPointEnd D hFI
+      = ((finrankAlong F D.ι : ℤ) : AddMonoid.End W.Point) := by
+  refine DFunLike.ext _ _ fun P => ?_
+  change D.pointEnd' (es1a1_dualPointEnd D hFI P)
+      = ((finrankAlong F D.ι : ℤ) : AddMonoid.End W.Point) P
+  rw [AddMonoid.End.intCast_apply, IsogenyEndDatum.pointEnd'_apply,
+    es1a1_dualPointEnd_apply, ← genusOnePic0Equiv_symm_apply,
+    AddEquiv.symm_apply_apply,
+    es1a1_dual_pushforwardAlongHom_conormPic0Hom D.ι D.hι hFI D.hfin
+      (normFormulaAlong_of_elliptic D.ι D.hfin), map_zsmul,
+    AddEquiv.apply_symm_apply]
+
+end Conorm
+end Es1a1
+end ModularCurve
+end
+end
+
+section
+
+section
+
+namespace ModularCurve
+namespace Es1a1
+
+section AddMulAlgebra
+
+variable {A : Type*} [AddCommGroup A]
+
+def es1a4_twDualEndData_of_add_of_mul (φ ψ : AddMonoid.End A) (t n : ℤ)
+    (hadd : φ + ψ = (t : AddMonoid.End A)) (hmul : φ * ψ = (n : AddMonoid.End A)) :
+    DualEndData φ where
+  dual := ψ
+  trace := t
+  norm := n
+  add_dual := hadd
+  mul_dual := hmul
+  dual_mul := by
+    have hψ : ψ = (t : AddMonoid.End A) - φ := eq_sub_of_add_eq' hadd
+    have hc : (t : AddMonoid.End A) * φ = φ * (t : AddMonoid.End A) :=
+      (Int.cast_commute t φ).eq
+    rw [hψ, sub_mul, hc, ← mul_sub, ← hψ, hmul]
+
+end AddMulAlgebra
+end Es1a1
+end ModularCurve
+end
+end
+
+section
+
+namespace AlgebraicCurve
+attribute [local instance 0] Place.valuationSubringAlgebra
+
+section Producer
+
+variable {K F Z : Type*} [Field K] [Field F] [Field Z]
+  [Algebra K F] [Algebra K Z] [Algebra F Z] [IsScalarTower K F Z]
+  [FiniteDimensional F Z] [Algebra.IsSeparable F Z]
+  [HasPrincipalDivisors K Z]
+
+variable (E : IntermediateField F Z)
+
+def IntegralAt (v : Place K F) (q : Polynomial F) : Prop :=
+  ∀ i, q.coeff i ∈ v.toValuationSubring
+
+theorem mem_lifts_of_integralAt {v : Place K F} {q : Polynomial F}
+    (hq : IntegralAt v q) :
+    q ∈ Polynomial.lifts (algebraMap v.toValuationSubring F) :=
+  (Polynomial.lifts_iff_coeff_lifts q).mpr fun n => ⟨⟨q.coeff n, hq n⟩, rfl⟩
+
+end Producer
+end AlgebraicCurve
+end
+
+section
+
+section
+
+namespace WeierstrassCurve
+namespace Affine
+universe u
+
+variable {F : Type u} [Field F] (W : Affine F) [W.IsElliptic] [W.GenusOnePlaceGate]
+
+@[scoped simp] theorem placeOfPointEquiv_symm_placeOfPoint (P : W.Point) :
+    (placeOfPointEquiv W).symm (placeOfPoint P) = P :=
+  (placeOfPointEquiv W).symm_apply_apply P
+
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+namespace WeierstrassCurve
+namespace Affine
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+namespace IsogenyEndDatum
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem isIntegral_comp (D₁ D₂ : IsogenyEndDatum W) :
+    (D₂.ι.comp D₁.ι).toRingHom.IsIntegral :=
+  RingHom.IsIntegral.trans D₁.ι.toRingHom D₂.ι.toRingHom D₁.hι D₂.hι
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem finiteAlong_comp (D₁ D₂ : IsogenyEndDatum W) :
+    FiniteAlong F (D₂.ι.comp D₁.ι) :=
+  RingHom.Finite.comp (g := D₂.ι.toRingHom) (f := D₁.ι.toRingHom) D₂.hfin D₁.hfin
+
+def compDatum (D₁ D₂ : IsogenyEndDatum W) : IsogenyEndDatum W where
+  ι := D₂.ι.comp D₁.ι
+  hι := isIntegral_comp W D₁ D₂
+  hfin := finiteAlong_comp W D₁ D₂
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+@[scoped simp] theorem compDatum_ι (D₁ D₂ : IsogenyEndDatum W) :
+    (compDatum W D₁ D₂).ι = D₂.ι.comp D₁.ι := rfl
+
+end IsogenyEndDatum
+
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+namespace AlgebraicCurve
+section Identity
+
+variable (K F F' : Type*) [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [Algebra.IsIntegral F F']
+
+def RamificationInertiaIdentity : Prop :=
+  ∀ (v : Place K F) (s : Finset (Place K F')), (∀ w : Place K F', w ∈ s ↔ w.restrict F = v) →
+    ∑ w ∈ s, (w.ramificationIndex F : ℤ) * (w.deg : ℤ)
+      = (Module.finrank F F' : ℤ) * (v.deg : ℤ)
+
+variable {K F F'}
+
+theorem fundamentalIdentity_iff_ramificationInertiaIdentity [HasPrincipalDivisors K F'] :
+    FundamentalIdentity K F F' ↔ RamificationInertiaIdentity K F F' := by
+  constructor
+  · intro H v s hs
+    have hseq : s = v.fiber F' := by
+      ext w
+      rw [hs w, Place.mem_fiber]
+    rw [hseq]
+    exact H.sum_ramificationIndex_mul_deg v
+  · intro H
+    exact ⟨fun v => H v (v.fiber F') fun w => Place.mem_fiber⟩
+
+end Identity
+
+end AlgebraicCurve
+end
+
+section
+
+open WithZero
+open scoped Polynomial
+
+namespace AlgebraicCurve
+theorem le_exp_neg_one_of_lt_one {x : ℤᵐ⁰} (hx : x < 1) : x ≤ exp (-1 : ℤ) := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · exact zero_le
+  · rw [← exp_log hx0] at hx ⊢
+    rw [show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_lt_exp] at hx
+    rw [exp_le_exp]
+    omega
+
+namespace Place
+open AlgebraicCurve.Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+theorem ord_eq_neg_log_of_valuationSubring_eq (w : Valuation F ℤᵐ⁰)
+    (hw : w.valuationSubring = v.toValuationSubring) {π : F} (hπ : w π = exp (-1 : ℤ))
+    {f : F} (hf : f ≠ 0) : v.ord f = -log (w f) := by
+  have hequiv : w.IsEquiv v.adicValuation :=
+    v.isEquiv_adicValuation_of_valuationSubring_eq hw
+  have hexp_lt : (exp (-1 : ℤ) : ℤᵐ⁰) < 1 := by
+    rw [show (1 : ℤᵐ⁰) = exp 0 from rfl]
+    exact exp_lt_exp.mpr (by omega)
+  obtain ⟨π₀, hπ₀⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hadic_π₀ : v.adicValuation (π₀ : F) = exp (-1 : ℤ) := v.adicValuation_coe_irreducible hπ₀
+  have hwπ₀ : w (π₀ : F) = exp (-1 : ℤ) := by
+    refine le_antisymm (le_exp_neg_one_of_lt_one (hequiv.lt_one_iff_lt_one.mpr ?_)) ?_
+    · rw [hadic_π₀]
+      exact hexp_lt
+    · rw [← hπ]
+      refine (hequiv π π₀).mpr ?_
+      rw [hadic_π₀]
+      refine le_exp_neg_one_of_lt_one (hequiv.lt_one_iff_lt_one.mp ?_)
+      rw [hπ]
+      exact hexp_lt
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ₀
+  have hwu : w ((u : v.toValuationSubring) : F) = 1 :=
+    hequiv.eq_one_iff_eq_one.mpr ((v.adicValuation_coe_eq_one_iff _).mpr u.isUnit)
+  set n := v.ord f with hn
+  rw [hu, map_mul, map_zpow₀, hwu, hwπ₀, one_mul, log_zpow, log_exp, smul_eq_mul]
+  ring
+
+end Place
+
+end AlgebraicCurve
+end
+
+section
+
+namespace AlgebraicCurve
+section FinrankAlongComp
+
+variable {K F F' F'' : Type*} [Field K] [Field F] [Field F'] [Field F'']
+variable [Algebra K F] [Algebra K F'] [Algebra K F'']
+
+theorem finrankAlong_comp (φ : F →ₐ[K] F') (ψ : F' →ₐ[K] F'') :
+    finrankAlong K (ψ.comp φ) = finrankAlong K φ * finrankAlong K ψ := by
+  let iφ : Algebra F F' := algebraAlong φ
+  let iψ : Algebra F' F'' := algebraAlong ψ
+  let iψφ : Algebra F F'' := algebraAlong (ψ.comp φ)
+  have : IsScalarTower F F' F'' := IsScalarTower.of_algebraMap_eq fun _ => rfl
+  exact (Module.finrank_mul_finrank F F' F'').symm
+
+end FinrankAlongComp
+end AlgebraicCurve
+
+end
+
+section
+
+namespace ModularCurve
+
+section DegreeLayer
+
+universe u
+
+theorem cmm10_deg_finrankAlong_pos {K F F' : Type*} [Field K] [Field F] [Field F']
+    [Algebra K F] [Algebra K F'] (φ : F →ₐ[K] F') (hfin : FiniteAlong K φ) :
+    0 < finrankAlong K φ := by
+  let := algebraAlong φ
+  have hfin' : Module.Finite F F' := hfin
+  exact (Module.finrank_pos_iff_of_free (R := F) (M := F')).mpr inferInstance
+
+variable {F : Type u} [Field F] {W : Affine F}
+
+theorem cmm10_deg_degree_pos (D : IsogenyEndDatum W) : 0 < D.degree :=
+  cmm10_deg_finrankAlong_pos D.ι D.hfin
+
+end DegreeLayer
+
+section DatumLayerFaces
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+
+def cmm10_deg_DatumKernelDegreeFace (W : Affine F) [W.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+    :
+    Prop :=
+  ∀ D : IsogenyEndDatum W,
+    Nat.card (AddMonoidHom.ker D.pointEnd') = D.degree
+
+end DatumLayerFaces
+end ModularCurve
+end
+
+section
+
+section
+
+namespace WeierstrassCurve
+namespace Affine
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+namespace IsogenyEndDatum
+
+omit [DecidableEq F] [IsAlgClosed F] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_ipfd_mem_fiberAlong_placeOfPoint_iff (D : IsogenyEndDatum W)
+    (P Q : W.Point) :
+    placeOfPoint P ∈ Place.fiberAlong D.ι D.hι (placeOfPoint Q)
+      ↔ D.geomMorph P = Q := by
+  have _pin := Classical.em True
+  rw [Place.mem_fiberAlong, D.placeOfPoint_geomMorph P]
+  exact ⟨fun h => placeOfPoint_injective h, fun h => h ▸ rfl⟩
+
+omit [IsAlgClosed F] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_ipfd_pullbackAlong_single_placeOfPoint_apply (D : IsogenyEndDatum W)
+    (Q P : W.Point) :
+    (Divisor.pullbackAlong D.ι D.hι (Finsupp.single (placeOfPoint Q) 1))
+        (placeOfPoint P)
+      = if D.geomMorph P = Q
+          then ((placeOfPoint P).ramificationIndexAlong D.ι : ℤ) else 0 := by
+  have _pin := Classical.em True
+  classical
+  rw [Divisor.pullbackAlong_single D.ι D.hι (placeOfPoint Q) 1]
+  simp only [one_mul, Finset.sum_apply', Finsupp.single_apply]
+  rw [Finset.sum_ite_eq' (Place.fiberAlong D.ι D.hι (placeOfPoint Q))
+    (placeOfPoint P) (fun w => (w.ramificationIndexAlong D.ι : ℤ))]
+  by_cases hm : D.geomMorph P = Q
+  · rw [ite_eq_left ((kw_ipfd_mem_fiberAlong_placeOfPoint_iff D P Q).mpr hm),
+      ite_eq_left hm]
+  · rw [ite_eq_right (fun h => hm ((kw_ipfd_mem_fiberAlong_placeOfPoint_iff D P Q).mp h)),
+      ite_eq_right hm]
+
+abbrev kw_ipfd_unramified (D : IsogenyEndDatum W) : Prop :=
+  ∀ P : W.Point, (placeOfPoint P).ramificationIndexAlong D.ι = 1
+
+omit [IsAlgClosed F] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_ipfd_pullbackAlong_single_placeOfPoint_apply_of_unramified
+    (D : IsogenyEndDatum W) (hunr : kw_ipfd_unramified D) (Q P : W.Point) :
+    (Divisor.pullbackAlong D.ι D.hι (Finsupp.single (placeOfPoint Q) 1))
+        (placeOfPoint P)
+      = if D.geomMorph P = Q then 1 else 0 := by
+  have _pin := Classical.em True
+  rw [kw_ipfd_pullbackAlong_single_placeOfPoint_apply D Q P, hunr P,
+    Nat.cast_one]
+
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+end
+end
+
+section
+
+section
+
+namespace ModularCurve
+namespace Es1a1
+
+section CompositionLaw
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F]
+variable {W : Affine F} [WeierstrassCurve.Affine.GenusOnePlaceGate W] [W.AbelTheorem]
+
+omit [DecidableEq F] [W.AbelTheorem] in
+theorem es1a3_pushforwardAlong_comp
+    (φ ψ : W.FunctionField →ₐ[F] W.FunctionField)
+    (hφ : φ.toRingHom.IsIntegral) (hψ : ψ.toRingHom.IsIntegral)
+    (hcomp : (ψ.comp φ).toRingHom.IsIntegral)
+    (D : Divisor F W.FunctionField) :
+    Divisor.pushforwardAlong (ψ.comp φ) hcomp D
+      = Divisor.pushforwardAlong φ hφ (Divisor.pushforwardAlong ψ hψ D) := by
+  induction D using Finsupp.induction with
+  | zero => simp only [_root_.map_zero]
+  | single_add w n D _ _ ih =>
+    rw [map_add, map_add, map_add, ih, pushforwardAlong_single_eq (ψ.comp φ) hcomp,
+      pushforwardAlong_single_eq ψ hψ, pushforwardAlong_single_eq φ hφ,
+      Place.restrictAlong_comp φ ψ hφ hψ hcomp]
+
+omit [DecidableEq F] [W.AbelTheorem] in
+theorem es1a3_pushforwardAlongHom_comp
+    (φ ψ : W.FunctionField →ₐ[F] W.FunctionField)
+    (hφ : φ.toRingHom.IsIntegral) (hψ : ψ.toRingHom.IsIntegral)
+    (hcomp : (ψ.comp φ).toRingHom.IsIntegral)
+    (hφfin : FiniteAlong F φ) (hψfin : FiniteAlong F ψ)
+    (hcfin : FiniteAlong F (ψ.comp φ))
+    (hφN : NormFormulaAlong F φ hφfin) (hψN : NormFormulaAlong F ψ hψfin)
+    (hcN : NormFormulaAlong F (ψ.comp φ) hcfin)
+    (c : Pic0 F W.FunctionField) :
+    Pic0.pushforwardAlongHom (ψ.comp φ) hcomp hcfin hcN c
+      = Pic0.pushforwardAlongHom φ hφ hφfin hφN
+          (Pic0.pushforwardAlongHom ψ hψ hψfin hψN c) := by
+  refine QuotientAddGroup.induction_on c fun E => ?_
+  change Pic0.pushforwardAlongHom (ψ.comp φ) hcomp hcfin hcN (Pic0.mk E)
+      = Pic0.pushforwardAlongHom φ hφ hφfin hφN
+          (Pic0.pushforwardAlongHom ψ hψ hψfin hψN (Pic0.mk E))
+  rw [Pic0.pushforwardAlongHom_mk, Pic0.pushforwardAlongHom_mk,
+    Pic0.pushforwardAlongHom_mk]
+  refine congrArg Pic0.mk (Subtype.ext ?_)
+  simp only [Pic0.coe_pushforwardAlongDegZero]
+  exact es1a3_pushforwardAlong_comp φ ψ hφ hψ hcomp E
+
+theorem es1a3_pointClass_genusOnePic0Equiv (c : Pic0 F W.FunctionField) :
+    pointClass (genusOnePic0Equiv W c) = c := by
+  rw [← genusOnePic0Equiv_symm_apply, AddEquiv.symm_apply_apply]
+
+theorem es1a3_compDatum_pointEnd [CharZero F] (D₁ D₂ : IsogenyEndDatum W) :
+    (IsogenyEndDatum.compDatum W D₁ D₂).pointEnd' = D₁.pointEnd' * D₂.pointEnd' := by
+  refine AddMonoidHom.ext fun P => ?_
+  change (IsogenyEndDatum.compDatum W D₁ D₂).pointEnd' P = D₁.pointEnd' (D₂.pointEnd' P)
+  rw [IsogenyEndDatum.pointEnd'_apply, IsogenyEndDatum.pointEnd'_apply,
+    IsogenyEndDatum.pointEnd'_apply, es1a3_pointClass_genusOnePic0Equiv]
+  exact congrArg (genusOnePic0Equiv W)
+    (es1a3_pushforwardAlongHom_comp D₁.ι D₂.ι D₁.hι D₂.hι
+      (IsogenyEndDatum.compDatum W D₁ D₂).hι D₁.hfin D₂.hfin
+      (IsogenyEndDatum.compDatum W D₁ D₂).hfin
+      (normFormulaAlong_of_elliptic D₁.ι D₁.hfin)
+      (normFormulaAlong_of_elliptic D₂.ι D₂.hfin)
+      (normFormulaAlong_of_elliptic (IsogenyEndDatum.compDatum W D₁ D₂).ι
+        (IsogenyEndDatum.compDatum W D₁ D₂).hfin)
+      (pointClass P))
+
+end CompositionLaw
+end Es1a1
+end ModularCurve
+end
+end
+
+section
+
+namespace AlgebraicCurve
+attribute [local instance 0] Place.valuationSubringAlgebra
+
+section PolarLocus
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] [HasPrincipalDivisors K F]
+
+theorem finite_setOf_ord_ne_zero_of_hasPrincipalDivisors {f : F} (hf : f ≠ 0) :
+    {v : Place K F | v.ord f ≠ 0}.Finite := by
+  obtain ⟨D, hD, -⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf
+  refine D.support.finite_toSet.subset fun v hv => Finsupp.mem_support_iff.mpr ?_
+  rw [hD v]
+  exact hv
+
+theorem finite_setOf_notMem_toValuationSubring (f : F) :
+    {v : Place K F | f ∉ v.toValuationSubring}.Finite := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · refine Set.finite_empty.subset fun v hv => ?_
+    exact absurd (v.toValuationSubring.zero_mem) hv
+  · refine (finite_setOf_ord_ne_zero_of_hasPrincipalDivisors (K := K) hf).subset
+      fun v hv => ?_
+    intro h0
+    exact hv (AlgebraicCurve.Place.mem_of_ord_nonneg v hf h0.ge)
+
+end PolarLocus
+end AlgebraicCurve
+end
+
+section
+
+open scoped Polynomial.Bivariate
+
+namespace AlgebraicCurve
+namespace Place
+open AlgebraicCurve.Place
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem ord_algebraMap_s18priv (c : K) : v.ord (algebraMap K F c) = 0 := by
+  rcases eq_or_ne c 0 with rfl | hc
+  · simp
+  have hmem : algebraMap K F c ∈ v.toValuationSubring := v.algebraMap_mem' c
+  have hmem' : (algebraMap K F c)⁻¹ ∈ v.toValuationSubring := by
+    rw [← map_inv₀]
+    exact v.algebraMap_mem' c⁻¹
+  have h1 := AlgebraicCurve.Place.ord_nonneg_of_mem v hmem
+  have h2 := AlgebraicCurve.Place.ord_nonneg_of_mem v hmem'
+  rw [v.ord_inv] at h2
+  omega
+
+private theorem ord_pow (f : F) (n : ℕ) :
+    v.ord (f ^ n) = n * v.ord f := by
+  rw [← zpow_natCast, v.ord_zpow]
+
+private theorem ord_ringHom_eq_natDegree_mul {φ : K[X] →+* F}
+    (hφinj : Function.Injective φ)
+    (hφC : ∀ c : K, φ (C c) = algebraMap K F c) (hz : v.ord (φ X) < 0) :
+    ∀ {p : K[X]}, p ≠ 0 → v.ord (φ p) = p.natDegree * v.ord (φ X) := by
+  have hX0 : φ X ≠ 0 := fun h => by simp [Place.ord, h] at hz
+  have hmono : ∀ (c : K) (n : ℕ), c ≠ 0 → v.ord (φ (C c * X ^ n)) = n * v.ord (φ X) := by
+    intro c n hc
+    have hc0 : φ (C c) ≠ 0 := by
+      rw [hφC]
+      simpa using hc
+    rw [map_mul, map_pow, v.ord_mul hc0 (pow_ne_zero n hX0), hφC,
+      AlgebraicCurve.Place.ord_algebraMap v,
+      v.ord_pow, zero_add]
+  intro p
+  induction hd : p.natDegree using Nat.strong_induction_on generalizing p with
+  | _ d ih =>
+    intro hp
+    subst hd
+    rcases eq_or_ne p.eraseLead 0 with he | he
+    · conv_lhs => rw [← p.eraseLead_add_C_mul_X_pow, he, zero_add]
+      exact hmono _ _ (leadingCoeff_ne_zero.mpr hp)
+    · have hlt : p.eraseLead.natDegree < p.natDegree := by
+        rcases p.eraseLead_natDegree_lt_or_eraseLead_eq_zero with h | h
+        · exact h
+        · exact absurd h he
+      have hIH : v.ord (φ p.eraseLead) = p.eraseLead.natDegree * v.ord (φ X) :=
+        ih _ hlt rfl he
+      have hlead : v.ord (φ (C p.leadingCoeff * X ^ p.natDegree))
+          = p.natDegree * v.ord (φ X) := hmono _ _ (leadingCoeff_ne_zero.mpr hp)
+      have hcast : (p.eraseLead.natDegree : ℤ) < (p.natDegree : ℤ) := by exact_mod_cast hlt
+      have hne : v.ord (φ p.eraseLead) ≠ v.ord (φ (C p.leadingCoeff * X ^ p.natDegree)) := by
+        rw [hIH, hlead]
+        nlinarith
+      have he2 : φ (C p.leadingCoeff * X ^ p.natDegree) ≠ 0 := fun hcon =>
+        mul_ne_zero (C_ne_zero.mpr (leadingCoeff_ne_zero.mpr hp)) (pow_ne_zero _ X_ne_zero)
+          (hφinj (hcon.trans (_root_.map_zero φ).symm))
+      have he1 : φ p.eraseLead ≠ 0 := fun hcon => he (hφinj (hcon.trans (_root_.map_zero φ).symm))
+      conv_lhs => rw [← p.eraseLead_add_C_mul_X_pow]
+      rw [map_add, v.ord_add_eq_min he1 he2 hne, hIH, hlead]
+      have h1 : (p.natDegree : ℤ) * v.ord (φ X) ≤ (p.eraseLead.natDegree : ℤ) * v.ord (φ X) := by
+        nlinarith
+      omega
+
+private theorem le_ord_ringHom_of_natDegree_le {φ : K[X] →+* F}
+    (hφinj : Function.Injective φ)
+    (hφC : ∀ c : K, φ (C c) = algebraMap K F c) (hz : v.ord (φ X) < 0)
+    {p : K[X]} {d : ℕ} (hd : p.natDegree ≤ d) :
+    (d : ℤ) * v.ord (φ X) ≤ v.ord (φ p) := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp only [_root_.map_zero, Place.ord_zero]
+    nlinarith [hz]
+  rw [v.ord_ringHom_eq_natDegree_mul hφinj hφC hz hp]
+  have h1 : (p.natDegree : ℤ) ≤ (d : ℤ) := by exact_mod_cast hd
+  nlinarith
+
+end Place
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+namespace Affine
+open WeierstrassCurve.Affine.CoordinateRing
+open WeierstrassCurve.Affine.CoordinateRing
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem natDegree_norm_smul_basis_left {p : F[X]} (hp : p ≠ 0) :
+    ((Algebra.norm F[X] (p • (1 : W.CoordinateRing)
+        + (0 : F[X]) • CoordinateRing.mk W Y)).natDegree : ℤ) = 2 * p.natDegree := by
+  have hdeg := degree_norm_smul_basis (W' := W) p 0
+  rw [Polynomial.degree_zero, show (2 : ℕ) • (⊥ : WithBot ℕ) + 3 = ⊥ by
+      rw [two_nsmul]; simp, max_eq_left bot_le, Polynomial.degree_eq_natDegree hp, two_nsmul,
+    ← Nat.cast_add] at hdeg
+  rw [Polynomial.natDegree_eq_of_degree_eq_some hdeg]
+  push_cast
+  ring
+
+theorem natDegree_norm_smul_basis_right {q : F[X]} (hq : q ≠ 0) :
+    ((Algebra.norm F[X] ((0 : F[X]) • (1 : W.CoordinateRing)
+        + q • CoordinateRing.mk W Y)).natDegree : ℤ) = 2 * q.natDegree + 3 := by
+  have hdeg := degree_norm_smul_basis (W' := W) 0 q
+  rw [Polynomial.degree_zero, show (2 : ℕ) • (⊥ : WithBot ℕ) = ⊥ by
+      rw [two_nsmul]; simp, max_eq_right bot_le, Polynomial.degree_eq_natDegree hq, two_nsmul,
+    ← Nat.cast_add, show ((3 : WithBot ℕ)) = ((3 : ℕ) : WithBot ℕ) from rfl,
+    ← Nat.cast_add] at hdeg
+  rw [Polynomial.natDegree_eq_of_degree_eq_some hdeg]
+  push_cast
+  ring
+
+theorem natDegree_norm_smul_basis_max {p q : F[X]} (hp : p ≠ 0) (hq : q ≠ 0) :
+    ((Algebra.norm F[X] (p • (1 : W.CoordinateRing)
+        + q • CoordinateRing.mk W Y)).natDegree : ℤ)
+      = max (2 * (p.natDegree : ℤ)) (2 * (q.natDegree : ℤ) + 3) := by
+  have hdeg := degree_norm_smul_basis (W' := W) p q
+  rw [Polynomial.degree_eq_natDegree hp, Polynomial.degree_eq_natDegree hq, two_nsmul,
+    two_nsmul, ← Nat.cast_add, ← Nat.cast_add,
+    show ((3 : WithBot ℕ)) = ((3 : ℕ) : WithBot ℕ) from rfl, ← Nat.cast_add] at hdeg
+  rcases le_total (q.natDegree + q.natDegree + 3) (p.natDegree + p.natDegree) with h | h
+  · rw [max_eq_left (by exact_mod_cast h)] at hdeg
+    rw [Polynomial.natDegree_eq_of_degree_eq_some hdeg]
+    push_cast
+    omega
+  · rw [max_eq_right (by exact_mod_cast h)] at hdeg
+    rw [Polynomial.natDegree_eq_of_degree_eq_some hdeg]
+    push_cast
+    omega
+
+variable (v : AlgebraicCurve.Place F W.FunctionField)
+
+theorem two_mul_ord_Y_eq_three_mul_ord_X (hv : ¬ IsFinitePlace v) :
+    2 * v.ord (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y))
+      = 3 * v.ord (polyToFunctionField W X) := by
+  set η := algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) with hηdef
+  have hA : v.ord (polyToFunctionField W X) < 0 := ord_X_neg_of_not_isFinitePlace v hv
+  have hη0 : η ≠ 0 := Y_image_ne_zero
+  set c₁ : F[X] := C W.a₁ * X + C W.a₃ with hc₁def
+  set cb : F[X] := X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ with hcbdef
+  have hrel : η * η = polyToFunctionField W cb - polyToFunctionField W c₁ * η := by
+    have h1 := smul_basis_mul_Y (W' := W) 0 1
+    rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at h1
+    have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) h1
+    rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+    exact h2
+  have hrelL : (η + polyToFunctionField W c₁) * η = polyToFunctionField W cb := by
+    rw [add_mul]
+    linear_combination hrel
+  have hcbdeg : cb.natDegree = 3 := by
+    rw [hcbdef, ← one_mul (X ^ 3 : F[X]), ← C_1]
+    exact Polynomial.natDegree_cubic one_ne_zero
+  have hcb0 : cb ≠ 0 := by
+    intro h
+    rw [h, Polynomial.natDegree_zero] at hcbdeg
+    exact absurd hcbdeg (by norm_num)
+  have hcbord : v.ord (polyToFunctionField W cb) = 3 * v.ord (polyToFunctionField W X) := by
+    rw [v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA
+      hcb0, hcbdeg]
+    push_cast
+    ring
+  have hc₁ord : (1 : ℤ) * v.ord (polyToFunctionField W X)
+      ≤ v.ord (polyToFunctionField W c₁) := by
+    refine v.le_ord_ringHom_of_natDegree_le polyToFunctionField_injective polyToFunctionField_C
+      hA ?_
+    rw [hc₁def]
+    refine le_trans (Polynomial.natDegree_add_le _ _) ?_
+    simp only [Polynomial.natDegree_C, max_le_iff]
+    refine ⟨le_trans (Polynomial.natDegree_C_mul_le _ _) (by simp), by omega⟩
+  rw [one_mul] at hc₁ord
+  have hfac0 : η + polyToFunctionField W c₁ ≠ 0 := by
+    intro h
+    rw [h, zero_mul] at hrelL
+    exact polyToFunctionField_ne_zero hcb0 hrelL.symm
+  have hLHS : v.ord (η + polyToFunctionField W c₁) + v.ord η
+      = 3 * v.ord (polyToFunctionField W X) := by
+    rw [← hcbord, ← hrelL, v.ord_mul hfac0 hη0]
+  rcases eq_or_ne (polyToFunctionField W c₁) 0 with hc₁0 | hc₁0
+  · rw [hc₁0, add_zero] at hLHS
+    omega
+  · by_cases hBc : v.ord η = v.ord (polyToFunctionField W c₁)
+    · exfalso
+      have hmin : min (v.ord η) (v.ord (polyToFunctionField W c₁))
+          ≤ v.ord (η + polyToFunctionField W c₁) := v.min_ord_le_ord_add' hfac0
+      rw [← hBc, min_self] at hmin
+      have hBA : v.ord (polyToFunctionField W X) ≤ v.ord η := hBc ▸ hc₁ord
+      omega
+    · have hsum : v.ord (η + polyToFunctionField W c₁)
+          = min (v.ord η) (v.ord (polyToFunctionField W c₁)) :=
+        v.ord_add_eq_min hη0 hc₁0 hBc
+      rcases min_cases (v.ord η) (v.ord (polyToFunctionField W c₁)) with
+        ⟨hm, hle⟩ | ⟨hm, hlt⟩ <;> rw [hm] at hsum
+      · rw [hsum] at hLHS
+        omega
+      · exfalso
+        rw [hsum] at hLHS
+        omega
+
+private theorem ne_arith {A B s t : ℤ} (hA : A < 0) (hY : 2 * B = 3 * A) :
+    s * A ≠ t * A + B := by
+  intro hcon
+  have h4 : (2 * s - (2 * t + 3)) * A = 0 := by linear_combination 2 * hcon + hY
+  rcases mul_eq_zero.mp h4 with h5 | h5
+  · omega
+  · omega
+
+private theorem two_mul_min_arith {A B s t : ℤ} (hA : A < 0) (hY : 2 * B = 3 * A) :
+    2 * min (s * A) (t * A + B) = A * max (2 * s) (2 * t + 3) := by
+  rcases le_or_gt (2 * t + 3) (2 * s) with h | h
+  · rw [max_eq_left h, min_eq_left (by nlinarith)]
+    ring
+  · rw [max_eq_right h.le, min_eq_right (by nlinarith)]
+    linear_combination hY
+
+theorem two_mul_ord_eq_of_not_isFinitePlace (hv : ¬ IsFinitePlace v)
+    {f : W.CoordinateRing} (hf : f ≠ 0) :
+    2 * v.ord (algebraMap W.CoordinateRing W.FunctionField f)
+      = v.ord (polyToFunctionField W X) * ((Algebra.norm F[X] f).natDegree : ℤ) := by
+  have hA : v.ord (polyToFunctionField W X) < 0 := ord_X_neg_of_not_isFinitePlace v hv
+  have hη0 : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) ≠ 0 :=
+    Y_image_ne_zero
+  have hYord := two_mul_ord_Y_eq_three_mul_ord_X v hv
+  obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq f
+  by_cases hq : q = 0
+  · subst hq
+    have hp : p ≠ 0 := fun h => hf (by rw [h, zero_smul, zero_smul, add_zero])
+    rw [natDegree_norm_smul_basis_left hp, algebraMap_smul_basis, _root_.map_zero, zero_mul,
+      add_zero,
+      v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA hp]
+    ring
+  · by_cases hp : p = 0
+    · subst hp
+      rw [natDegree_norm_smul_basis_right hq, algebraMap_smul_basis, _root_.map_zero, zero_add,
+        v.ord_mul (polyToFunctionField_ne_zero hq) hη0,
+        v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA hq]
+      linear_combination hYord
+    · rw [natDegree_norm_smul_basis_max hp hq, algebraMap_smul_basis]
+      have hordp : v.ord (polyToFunctionField W p)
+          = (p.natDegree : ℤ) * v.ord (polyToFunctionField W X) :=
+        v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA hp
+      have hordqy : v.ord (polyToFunctionField W q
+            * algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y))
+          = (q.natDegree : ℤ) * v.ord (polyToFunctionField W X)
+            + v.ord (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)) := by
+        rw [v.ord_mul (polyToFunctionField_ne_zero hq) hη0,
+          v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA
+            hq]
+      have hne : v.ord (polyToFunctionField W p) ≠ v.ord (polyToFunctionField W q
+          * algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)) := by
+        rw [hordp, hordqy]
+        exact ne_arith hA hYord
+      have hqy0 : polyToFunctionField W q
+          * algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) ≠ 0 :=
+        mul_ne_zero (polyToFunctionField_ne_zero hq) hη0
+      rw [v.ord_add_eq_min (polyToFunctionField_ne_zero hp) hqy0 hne, hordp, hordqy]
+      exact two_mul_min_arith hA hYord
+
+theorem ord_X_eq_neg_two_of_not_isFinitePlace (hv : ¬ IsFinitePlace v) :
+    v.ord (polyToFunctionField W X) = -2 := by
+  have hA : v.ord (polyToFunctionField W X) < 0 := ord_X_neg_of_not_isFinitePlace v hv
+  have hYord := two_mul_ord_Y_eq_three_mul_ord_X v hv
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπord : v.ord (π : W.FunctionField) = 1 := v.ord_coe_irreducible hπ
+  have hπ0 : (π : W.FunctionField) ≠ 0 := by
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  obtain ⟨a, b, hb, hab⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing)
+    (π : W.FunctionField)
+  have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb
+  have ha0 : a ≠ 0 := by
+    intro h
+    rw [h, _root_.map_zero, zero_div] at hab
+    exact hπ0 hab.symm
+  have ha' : algebraMap W.CoordinateRing W.FunctionField a ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr ha0
+  have hb' : algebraMap W.CoordinateRing W.FunctionField b ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr hb0
+  have h1 := two_mul_ord_eq_of_not_isFinitePlace v hv ha0
+  have h2 := two_mul_ord_eq_of_not_isFinitePlace v hv hb0
+  have h3 : v.ord (π : W.FunctionField)
+      = v.ord (algebraMap W.CoordinateRing W.FunctionField a)
+        - v.ord (algebraMap W.CoordinateRing W.FunctionField b) := by
+    rw [← hab, div_eq_mul_inv, v.ord_mul ha' (inv_ne_zero hb'), v.ord_inv]
+    ring
+  rw [hπord] at h3
+  have h4 : (2 : ℤ) = v.ord (polyToFunctionField W X) * (((Algebra.norm F[X] a).natDegree : ℤ)
+      - ((Algebra.norm F[X] b).natDegree : ℤ)) := by
+    linear_combination 2 * h3 + h1 - h2
+  have h5 : v.ord (polyToFunctionField W X) ∣ 2 := ⟨_, h4⟩
+  have h6 : (2 : ℤ) ∣ v.ord (polyToFunctionField W X) := by
+    have h7 : (2 : ℤ) ∣ 3 * v.ord (polyToFunctionField W X) := ⟨_, hYord.symm⟩
+    omega
+  have h8 : (v.ord (polyToFunctionField W X)).natAbs ∣ (2 : ℤ).natAbs :=
+    Int.natAbs_dvd_natAbs.mpr h5
+  have h9 : (2 : ℤ).natAbs ∣ (v.ord (polyToFunctionField W X)).natAbs :=
+    Int.natAbs_dvd_natAbs.mpr h6
+  have h10 : (v.ord (polyToFunctionField W X)).natAbs = 2 :=
+    Nat.dvd_antisymm (by simpa using h8) (by simpa using h9)
+  omega
+
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+namespace AlgebraicCurve
+namespace Place
+
+section Uniqueness
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+theorem eq_ord_of_addHom_of_nonneg_iff (φ : F → ℤ)
+    (hmul : ∀ x y, x ≠ 0 → y ≠ 0 → φ (x * y) = φ x + φ y)
+    (hone : ∃ t, t ≠ 0 ∧ φ t = 1)
+    (hiff : ∀ x, x ≠ 0 → (0 ≤ φ x ↔ x ∈ w.toValuationSubring))
+    {x : F} (hx : x ≠ 0) : φ x = w.ord x := by
+  obtain ⟨t, ht0, ht1⟩ := hone
+  have hφ1 : φ 1 = 0 := by
+    have := hmul 1 1 one_ne_zero one_ne_zero
+    rw [mul_one] at this
+    omega
+  have hinv : ∀ y, y ≠ 0 → φ y⁻¹ = -φ y := by
+    intro y hy
+    have h1 : φ (y * y⁻¹) = φ y + φ y⁻¹ := hmul y y⁻¹ hy (inv_ne_zero hy)
+    rw [mul_inv_cancel₀ hy, hφ1] at h1
+    omega
+  have hpow : ∀ (y : F), y ≠ 0 → ∀ m : ℕ, φ (y ^ m) = m * φ y := by
+    intro y hy m
+    induction m with
+    | zero => simpa using hφ1
+    | succ m ih =>
+      rw [pow_succ, hmul _ _ (pow_ne_zero _ hy) hy, ih]
+      push_cast
+      ring
+  have hzpow : ∀ (y : F) (n : ℤ), y ≠ 0 → φ (y ^ n) = n * φ y := by
+    intro y n hy
+    rcases n with m | m
+    · simpa using hpow y hy m
+    · rw [zpow_negSucc, hinv _ (pow_ne_zero _ hy), hpow y hy, Int.negSucc_eq]
+      push_cast
+      ring
+  have hsign : ∀ y, y ≠ 0 → (0 ≤ φ y ↔ 0 ≤ w.ord y) := by
+    intro y hy
+    rw [hiff y hy, AlgebraicCurve.Place.mem_iff_ord_nonneg w hy]
+  have hzero : ∀ y, y ≠ 0 → (φ y = 0 ↔ w.ord y = 0) := by
+    intro y hy
+    have h1 := hsign y hy
+    have h2 := hsign y⁻¹ (inv_ne_zero hy)
+    rw [hinv y hy, w.ord_inv] at h2
+    omega
+  have htord : 0 < w.ord t := by
+    have h1 := (hsign t ht0).mp (by omega)
+    have h2 := (hzero t ht0).not.mp (by omega)
+    omega
+  have hcancel : ∀ y, y ≠ 0 → w.ord y = φ y * w.ord t := by
+    intro y hy
+    have hyt : y * t ^ (-(φ y)) ≠ 0 := mul_ne_zero hy (zpow_ne_zero _ ht0)
+    have h1 : φ (y * t ^ (-(φ y))) = 0 := by
+      rw [hmul _ _ hy (zpow_ne_zero _ ht0), hzpow t _ ht0, ht1]
+      ring
+    have h2 : w.ord (y * t ^ (-(φ y))) = 0 := (hzero _ hyt).mp h1
+    rw [w.ord_mul hy (zpow_ne_zero _ ht0), w.ord_zpow] at h2
+    linarith
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  have hπ0 : (π : F) ≠ 0 := by
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have hπcancel := hcancel (π : F) hπ0
+  rw [w.ord_coe_irreducible hπ] at hπcancel
+  have htord1 : w.ord t = 1 := by
+    have hdvd : w.ord t ∣ 1 := ⟨φ (π : F), by linarith⟩
+    have := Int.le_of_dvd one_pos hdvd
+    omega
+  have := hcancel x hx
+  rw [htord1, mul_one] at this
+  exact this.symm
+
+end Uniqueness
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+attribute [local instance 0] valuationSubringAlgebra
+
+section Setup
+
+variable (v : Place K F)
+
+scoped instance (priority := 100) : IsScalarTower v.toValuationSubring F F' :=
+  IsScalarTower.of_algebraMap_eq fun _ => rfl
+
+scoped instance : IsDedekindDomain (integralClosureAt F' v) :=
+  integralClosure.isDedekindDomain v.toValuationSubring F F'
+
+scoped instance : IsFractionRing (integralClosureAt F' v) F' :=
+  integralClosure.isFractionRing_of_finite_extension (A := v.toValuationSubring) F F'
+
+scoped instance : Module.Finite v.toValuationSubring (integralClosureAt F' v) :=
+  IsIntegralClosure.finite v.toValuationSubring F F' _
+
+scoped instance : Module.IsTorsionFree v.toValuationSubring (integralClosureAt F' v) := by
+  rw [Module.isTorsionFree_iff_smul_eq_zero]
+  intro r c hrc
+  rw [Algebra.smul_def] at hrc
+  rcases mul_eq_zero.mp hrc with h | h
+  · exact Or.inl (algebraMap_integralClosureAt_injective v (by rw [h, _root_.map_zero]))
+  · exact Or.inr h
+
+end Setup
+
+section ValuationDictionary
+
+variable {v : Place K F} {w : Place K F'}
+
+theorem neg_log_valuation_fiberCenter_eq_ord (hw : w.restrict F = v) {x : F'} (hx : x ≠ 0) :
+    -log ((fiberCenter F' v hw).valuation F' x) = w.ord x := by
+  refine eq_ord_of_addHom_of_nonneg_iff w
+    (fun y => -log ((fiberCenter F' v hw).valuation F' y)) ?_ ?_ ?_ hx
+  · intro a b ha hb
+    show -log ((fiberCenter F' v hw).valuation F' (a * b)) =
+      -log ((fiberCenter F' v hw).valuation F' a) +
+        -log ((fiberCenter F' v hw).valuation F' b)
+    rw [map_mul, log_mul ((Valuation.ne_zero_iff _).mpr ha) ((Valuation.ne_zero_iff _).mpr hb)]
+    ring
+  · obtain ⟨t, ht⟩ := (fiberCenter F' v hw).valuation_exists_uniformizer F'
+    refine ⟨t, ?_, ?_⟩
+    · intro h
+      rw [h, _root_.map_zero] at ht
+      exact exp_ne_zero ht.symm
+    · show -log ((fiberCenter F' v hw).valuation F' t) = 1
+      rw [ht, log_exp]
+      ring
+  · intro y hy
+    have hy0 : (fiberCenter F' v hw).valuation F' y ≠ 0 := (Valuation.ne_zero_iff _).mpr hy
+    change 0 ≤ -log ((fiberCenter F' v hw).valuation F' y) ↔ y ∈ w.toValuationSubring
+    have hmem : y ∈ w.toValuationSubring ↔ (fiberCenter F' v hw).valuation F' y ≤ 1 := by
+      rw [toValuationSubring_eq_of_restrict_eq hw,
+        HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact Iff.rfl
+    rw [hmem]
+    constructor
+    · intro h
+      calc (fiberCenter F' v hw).valuation F' y
+          = exp (log ((fiberCenter F' v hw).valuation F' y)) := (exp_log hy0).symm
+        _ ≤ exp 0 := by rw [exp_le_exp]; omega
+        _ = 1 := exp_zero
+    · intro h
+      have h1 : exp (log ((fiberCenter F' v hw).valuation F' y)) ≤ exp 0 := by
+        rw [exp_log hy0, exp_zero]
+        exact h
+      rw [exp_le_exp] at h1
+      omega
+
+theorem le_ord_iff_mem_pow_fiberCenter (hw : w.restrict F = v)
+    {c : integralClosureAt F' v} (hc : c ≠ 0) (n : ℕ) :
+    (n : ℤ) ≤ w.ord (algebraMap (integralClosureAt F' v) F' c) ↔
+      c ∈ (fiberCenter F' v hw).asIdeal ^ n := by
+  have hcF : algebraMap (integralClosureAt F' v) F' c ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hc
+  rw [← neg_log_valuation_fiberCenter_eq_ord hw hcF,
+    HeightOneSpectrum.valuation_of_algebraMap,
+    ← HeightOneSpectrum.intValuation_le_pow_iff_mem]
+  have h0 : (fiberCenter F' v hw).intValuation c ≠ 0 :=
+    HeightOneSpectrum.intValuation_ne_zero _ c hc
+  constructor
+  · intro h
+    calc (fiberCenter F' v hw).intValuation c
+        = exp (log ((fiberCenter F' v hw).intValuation c)) := (exp_log h0).symm
+      _ ≤ exp (-(n : ℤ)) := by rw [exp_le_exp]; omega
+  · intro h
+    have h1 : exp (log ((fiberCenter F' v hw).intValuation c)) ≤ exp (-(n : ℤ)) := by
+      rw [exp_log h0]
+      exact h
+    rw [exp_le_exp] at h1
+    omega
+
+theorem ramificationIndex_eq_ramificationIdx_fiberCenter (hw : w.restrict F = v) :
+    w.ramificationIndex F =
+      (IsLocalRing.maximalIdeal v.toValuationSubring).ramificationIdx'
+        (fiberCenter F' v hw).asIdeal := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπ0 : π ≠ 0 := hπ.ne_zero
+  have hπC : algebraMap v.toValuationSubring (integralClosureAt F' v) π ≠ 0 :=
+    algebraMap_integralClosureAt_ne_zero hπ0
+  have hmap : (IsLocalRing.maximalIdeal v.toValuationSubring).map
+      (algebraMap v.toValuationSubring (integralClosureAt F' v))
+        = Ideal.span {algebraMap v.toValuationSubring (integralClosureAt F' v) π} := by
+    rw [hπ.maximalIdeal_eq, Ideal.map_span, Set.image_singleton]
+  have hord : w.ord (algebraMap (integralClosureAt F' v) F'
+      (algebraMap v.toValuationSubring (integralClosureAt F' v) π))
+        = w.ramificationIndex F := by
+    rw [ord_algebraMap_integralClosureAt hw, ValuationSubring.algebraMap_apply,
+      v.ord_coe_irreducible hπ, mul_one]
+  refine (Ideal.ramificationIdx'_spec ?_ ?_).symm
+  · rw [hmap, Ideal.span_singleton_le_iff_mem,
+      ← le_ord_iff_mem_pow_fiberCenter hw hπC, hord]
+  · rw [hmap, Ideal.span_singleton_le_iff_mem,
+      ← le_ord_iff_mem_pow_fiberCenter hw hπC, hord]
+    have : 0 < w.ramificationIndex F := w.ramificationIndex_pos
+    push_cast
+    omega
+
+end ValuationDictionary
+
+section ResidueDictionary
+
+variable {v : Place K F} {w : Place K F'}
+
+def toValuationSubringOfRestrictEq (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.toValuationSubring :=
+  (algebraMap (integralClosureAt F' v) F').codRestrict
+    w.toValuationSubring.toSubring (forall_mem_of_restrict_eq hw)
+
+def residueOfCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.ResidueField :=
+  (IsLocalRing.residue w.toValuationSubring).comp (toValuationSubringOfRestrictEq hw)
+
+omit [FiniteDimensional F F'] in
+theorem residueOfCenter_apply (hw : w.restrict F = v) (c : integralClosureAt F' v) :
+    residueOfCenter hw c = IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw c) := rfl
+
+theorem ker_residueOfCenter (hw : w.restrict F = v) :
+    RingHom.ker (residueOfCenter hw) = (fiberCenter F' v hw).asIdeal := by
+  ext c
+  rw [RingHom.mem_ker, residueOfCenter_apply, IsLocalRing.residue_eq_zero_iff]
+  exact Iff.rfl
+
+theorem surjective_residueOfCenter (hw : w.restrict F = v) :
+    Function.Surjective (residueOfCenter hw) := by
+  classical
+  intro y
+  obtain ⟨x, rfl⟩ := IsLocalRing.residue_surjective y
+  have hx : (x : F') ∈ HeightOneSpectrum.valuationSubringAtPrime F' (fiberCenter F' v hw) := by
+    rw [← toValuationSubring_eq_of_restrict_eq hw]
+    exact x.2
+  obtain ⟨a, s, hs, hxas⟩ := hx
+  have hsP : s ∉ (fiberCenter F' v hw).asIdeal := hs
+  have hs0 : s ≠ 0 := fun h => hsP (h ▸ (fiberCenter F' v hw).asIdeal.zero_mem)
+  have hsF : algebraMap (integralClosureAt F' v) F' s ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hs0
+  have hsord : w.ord (algebraMap (integralClosureAt F' v) F' s) = 0 := by
+    have h1 : ¬ 0 < w.ord (algebraMap (integralClosureAt F' v) F' s) := by
+      rw [← mem_fiberCenter_iff_ord_pos hw hs0]
+      exact hsP
+    have h2 : 0 ≤ w.ord (algebraMap (integralClosureAt F' v) F' s) :=
+      AlgebraicCurve.Place.ord_nonneg_of_mem w (forall_mem_of_restrict_eq hw s)
+    omega
+  have hmax : (fiberCenter F' v hw).asIdeal.IsMaximal :=
+    (fiberCenter F' v hw).isPrime.isMaximal (fiberCenter F' v hw).ne_bot
+  obtain ⟨t, i, hi, hti⟩ := hmax.exists_inv hsP
+  have hst : s * t - 1 ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : s * t - 1 = -i := by linear_combination hti
+    rw [h1]
+    exact neg_mem hi
+  refine ⟨a * t, ?_⟩
+  rw [residueOfCenter_apply, ← sub_eq_zero, ← map_sub, IsLocalRing.residue_eq_zero_iff]
+  have hcoe : ((toValuationSubringOfRestrictEq hw (a * t) - x : w.toValuationSubring) : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') := rfl
+  rcases eq_or_ne (toValuationSubringOfRestrictEq hw (a * t) - x) 0 with hzero | hne
+  · rw [hzero]
+    exact (IsLocalRing.maximalIdeal w.toValuationSubring).zero_mem
+  have hcoene : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') ≠ 0 := by
+    intro h
+    exact hne (by rwa [← hcoe, ZeroMemClass.coe_eq_zero] at h)
+  have hfactor : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t * s - a)
+          * (algebraMap (integralClosureAt F' v) F' s)⁻¹ := by
+    rw [hxas, RingHom.map_sub (algebraMap (integralClosureAt F' v) F') _ _,
+      map_mul (algebraMap (integralClosureAt F' v) F') (a * t) s,
+      sub_mul, mul_assoc, mul_inv_cancel₀ hsF, mul_one]
+  have hdiffC : a * t * s - a ≠ 0 := by
+    intro h
+    apply hcoene
+    rw [hfactor, h, _root_.map_zero, zero_mul]
+  have hdiffP : a * t * s - a ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : a * t * s - a = a * (s * t - 1) := by ring
+    rw [h1]
+    exact Ideal.mul_mem_left _ _ hst
+  have hmem' : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      ∈ w.toValuationSubring := by
+    rw [← hcoe]
+    exact Subtype.coe_prop _
+  rw [show (toValuationSubringOfRestrictEq hw (a * t) - x)
+      = (⟨_, hmem'⟩ : w.toValuationSubring) from Subtype.ext hcoe,
+    w.mem_maximalIdeal_iff_ord_pos hcoene hmem']
+  rw [hfactor, w.ord_mul (by
+      simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hdiffC)
+    (inv_ne_zero hsF), w.ord_inv, hsord, _root_.neg_zero, add_zero]
+  exact (mem_fiberCenter_iff_ord_pos hw hdiffC).mp hdiffP
+
+def residueFieldEquivQuotientCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v ⧸ (fiberCenter F' v hw).asIdeal ≃+* w.ResidueField :=
+  (Ideal.quotEquivOfEq (ker_residueOfCenter hw).symm).trans
+    ((residueOfCenter hw).quotientKerEquivOfSurjective (surjective_residueOfCenter hw))
+
+def placeCongrEquiv {u u' : Place K F} (h : u = u') :
+    u.toValuationSubring ≃+* u'.toValuationSubring where
+  toFun x := ⟨x.1, h ▸ x.2⟩
+  invFun x := ⟨x.1, h.symm ▸ x.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  map_mul' _ _ := rfl
+  map_add' _ _ := rfl
+
+def restrictResidueFieldEquiv (hw : w.restrict F = v) :
+    (w.restrict F).ResidueField ≃+* IsLocalRing.ResidueField v.toValuationSubring :=
+  IsLocalRing.ResidueField.mapEquiv (placeCongrEquiv hw)
+
+end ResidueDictionary
+end Place
+end AlgebraicCurve
+end
+
+section
+
+section
+
+open FractionalIdeal
+open WithZero
+open scoped nonZeroDivisors
+open scoped Polynomial.Bivariate
+
+namespace AlgebraicCurve
+namespace Place
+open AlgebraicCurve.Place
+variable {K : Type*} [Field K]
+variable {R : Type*} [CommRing R] [IsDedekindDomain R]
+variable {L : Type*} [Field L] [Algebra R L] [IsFractionRing R L]
+variable [Algebra K R] [Algebra K L] [IsScalarTower K R L]
+
+theorem ord_ofHeightOneSpectrum_eq_neg_log (w : HeightOneSpectrum R) {f : L} (hf : f ≠ 0) :
+    (ofHeightOneSpectrum (K := K) w).ord f = -log (w.valuation L f) := by
+  obtain ⟨π, hπ⟩ := w.intValuation_exists_uniformizer
+  have hval : w.valuation L (algebraMap R L π) = exp (-1 : ℤ) := by
+    rw [w.valuation_of_algebraMap]
+    exact hπ
+  exact AlgebraicCurve.Place.ord_eq_neg_log_of_valuationSubring_eq (ofHeightOneSpectrum (K := K) w)
+    (w.valuation L) rfl hval hf
+
+end Place
+end AlgebraicCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+namespace Place
+open AlgebraicCurve.Place
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+attribute [local instance 0] valuationSubringAlgebra
+
+variable {v : Place K F} {w : Place K F'}
+
+theorem ord_deriv_pos_of_ramificationIndex_ne_one
+    (hw : w.restrict F = v) (θ : F')
+    (hgen : IntermediateField.adjoin F {θ} = ⊤)
+    (hθint : _root_.IsIntegral v.toValuationSubring θ)
+    (hram : w.ramificationIndex F ≠ 1) :
+    0 < w.ord (aeval θ (derivative (minpoly F θ))) := by
+  obtain ⟨c, rfl⟩ : ∃ c : integralClosureAt F' v,
+      algebraMap (integralClosureAt F' v) F' c = θ := ⟨⟨θ, hθint⟩, rfl⟩
+  have hAc : _root_.IsIntegral v.toValuationSubring c := Algebra.IsIntegral.isIntegral c
+  have hadjF : Algebra.adjoin F {algebraMap (integralClosureAt F' v) F' c} = ⊤ := by
+    rw [← IntermediateField.adjoin_toSubalgebra, hgen, IntermediateField.top_toSubalgebra]
+  have hmem : aeval c (derivative (minpoly v.toValuationSubring c))
+      ∈ differentIdeal v.toValuationSubring (integralClosureAt F' v) :=
+    aeval_derivative_mem_differentIdeal (A := v.toValuationSubring) (K := F) (L := F')
+      (B := integralClosureAt F' v) c hadjF
+  have himg : aeval (algebraMap (integralClosureAt F' v) F' c)
+        (derivative (minpoly F (algebraMap (integralClosureAt F' v) F' c)))
+      = algebraMap (integralClosureAt F' v) F'
+          (aeval c (derivative (minpoly v.toValuationSubring c))) := by
+    rw [minpoly.isIntegrallyClosed_eq_field_fractions F F' hAc, derivative_map,
+      aeval_map_algebraMap, aeval_algebraMap_apply]
+  have hg0 : aeval (algebraMap (integralClosureAt F' v) F' c)
+      (derivative (minpoly F (algebraMap (integralClosureAt F' v) F' c))) ≠ 0 :=
+    (Algebra.IsSeparable.isSeparable F _).aeval_derivative_ne_zero (minpoly.aeval F _)
+  have hc0 : aeval c (derivative (minpoly v.toValuationSubring c)) ≠ 0 := by
+    intro h; exact hg0 (by rw [himg, h, _root_.map_zero])
+  have : FaithfulSMul v.toValuationSubring (integralClosureAt F' v) :=
+    (faithfulSMul_iff_algebraMap_injective v.toValuationSubring (integralClosureAt F' v)).mpr
+      (algebraMap_integralClosureAt_injective v)
+  let : Algebra (FractionRing v.toValuationSubring) (FractionRing (integralClosureAt F' v)) :=
+    FractionRing.liftAlgebra v.toValuationSubring (FractionRing (integralClosureAt F' v))
+  have : IsScalarTower v.toValuationSubring (FractionRing v.toValuationSubring)
+      (FractionRing (integralClosureAt F' v)) :=
+    FractionRing.isScalarTower_liftAlgebra (R := v.toValuationSubring)
+      (K := FractionRing (integralClosureAt F' v))
+  have : Algebra.IsSeparable (FractionRing v.toValuationSubring)
+      (FractionRing (integralClosureAt F' v)) := by
+    refine Algebra.IsSeparable.of_equiv_equiv
+      (FractionRing.algEquiv v.toValuationSubring F).symm.toRingEquiv
+      (FractionRing.algEquiv (integralClosureAt F' v) F').symm.toRingEquiv ?_
+    ext _
+    exact IsFractionRing.algEquiv_commutes
+      (FractionRing.algEquiv v.toValuationSubring F).symm
+      (FractionRing.algEquiv (integralClosureAt F' v) F').symm _
+  have := (fiberCenter F' v hw).isPrime
+  have hdvd : (fiberCenter F' v hw).asIdeal
+      ∣ differentIdeal v.toValuationSubring (integralClosureAt F' v) := by
+    by_contra hnd
+    have : Algebra.IsUnramifiedAt v.toValuationSubring (fiberCenter F' v hw).asIdeal :=
+      not_dvd_differentIdeal_iff.mp hnd
+    have he1 : Ideal.ramificationIdx'
+        ((fiberCenter F' v hw).asIdeal.under v.toValuationSubring)
+        (fiberCenter F' v hw).asIdeal = 1 :=
+      (Ideal.ramificationIdx'_eq_ramificationIdx _ _
+          (Ideal.under_ne_bot (A := v.toValuationSubring) (fiberCenter F' v hw).ne_bot)).trans
+        Ideal.ramificationIdx_eq_one_of_isUnramifiedAt
+    exact hram <| by
+      rw [ramificationIndex_eq_ramificationIdx_fiberCenter hw,
+        (fiberCenter_liesOver hw).over, he1]
+  have hmem2 : aeval c (derivative (minpoly v.toValuationSubring c))
+      ∈ (fiberCenter F' v hw).asIdeal := Ideal.le_of_dvd hdvd hmem
+  rw [himg]
+  exact (mem_fiberCenter_iff_ord_pos hw hc0).mp hmem2
+
+end Place
+end AlgebraicCurve
+end
+
+section
+
+section
+
+open WithZero
+
+namespace AlgebraicCurve
+namespace Place
+open AlgebraicCurve.Place
+
+attribute [local instance 0] valuationSubringAlgebra
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+theorem sum_ramificationIndex_mul_inertiaDeg_of_forall_mem_iff
+    (v : Place K F) (s : Finset (Place K F'))
+    (hs : ∀ w : Place K F', w ∈ s ↔ w.restrict F = v) :
+    ∑ w ∈ s, (w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ)
+      = (Module.finrank F F' : ℤ) := by
+  classical
+  have hkey := sum_ramificationIdx'_mul_inertiaDeg'_integralClosureAt (F' := F') v
+  rw [← hkey]
+  push_cast
+  refine Finset.sum_bij
+    (fun w hw => (fiberCenter F' v ((hs w).mp hw)).asIdeal) ?_ ?_ ?_ ?_
+  · intro w hw
+    rw [IsDedekindDomain.mem_primesOverFinset_iff (maximalIdeal_ne_bot v)]
+    exact ⟨(fiberCenter F' v ((hs w).mp hw)).isPrime,
+      fiberCenter_liesOver ((hs w).mp hw)⟩
+  · intro w hw w' hw' h
+    exact eq_of_fiberCenter_eq ((hs w).mp hw) ((hs w').mp hw')
+      (HeightOneSpectrum.ext h)
+  · intro P hP
+    rw [IsDedekindDomain.mem_primesOverFinset_iff (maximalIdeal_ne_bot v)] at hP
+    obtain ⟨hP1, hP2⟩ := hP
+    have hPne : P ≠ ⊥ := by
+      intro h
+      apply maximalIdeal_ne_bot v
+      have h2 := hP2.over
+      rw [h, Ideal.under_def, Ideal.comap_bot_of_injective _
+        (algebraMap_integralClosureAt_injective v)] at h2
+      exact h2
+    refine ⟨placeOfPrime ⟨P, hP1, hPne⟩,
+      (hs _).mpr (restrict_placeOfPrime ⟨P, hP1, hPne⟩), ?_⟩
+    exact congrArg HeightOneSpectrum.asIdeal
+      (fiberCenter_placeOfPrime (⟨P, hP1, hPne⟩ :
+        HeightOneSpectrum (integralClosureAt F' v)))
+  · intro w hw
+    rw [ramificationIndex_eq_ramificationIdx_fiberCenter ((hs w).mp hw),
+      inertiaDeg_eq_inertiaDeg_fiberCenter ((hs w).mp hw)]
+
+theorem sum_ramificationIndex_mul_deg_of_forall_mem_iff
+    (v : Place K F) (s : Finset (Place K F'))
+    (hs : ∀ w : Place K F', w ∈ s ↔ w.restrict F = v) :
+    ∑ w ∈ s, (w.ramificationIndex F : ℤ) * (w.deg : ℤ)
+      = (Module.finrank F F' : ℤ) * (v.deg : ℤ) := by
+  have hsum := sum_ramificationIndex_mul_inertiaDeg_of_forall_mem_iff v s hs
+  calc ∑ w ∈ s, (w.ramificationIndex F : ℤ) * (w.deg : ℤ)
+      = ∑ w ∈ s, (v.deg : ℤ) * ((w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ)) := by
+        refine Finset.sum_congr rfl fun w hw => ?_
+        have hdeg : (w.restrict F).deg * w.inertiaDeg F = w.deg :=
+          deg_restrict_mul_inertiaDeg (K := K) (F := F) (w := w)
+        rw [(hs w).mp hw] at hdeg
+        rw [← hdeg]
+        push_cast
+        ring
+    _ = (v.deg : ℤ) * ∑ w ∈ s, (w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ) := by
+        rw [Finset.mul_sum]
+    _ = (Module.finrank F F' : ℤ) * (v.deg : ℤ) := by rw [hsum]; ring
+
+end Place
+
+theorem ramificationInertiaIdentity_of_finiteDimensional
+    (K F F' : Type*) [Field K] [Field F] [Field F']
+    [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+    [FiniteDimensional F F'] [Algebra.IsSeparable F F'] :
+    RamificationInertiaIdentity K F F' := fun v s hs =>
+  Place.sum_ramificationIndex_mul_deg_of_forall_mem_iff v s hs
+
+end AlgebraicCurve
+end
+
+section
+
+open scoped Polynomial
+
+open WithZero
+namespace AlgebraicCurve
+namespace Place
+open AlgebraicCurve.Place
+
+attribute [local instance 0] Place.valuationSubringAlgebra
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+section Structural
+
+variable (v : Place K F)
+
+omit [Algebra K F'] [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F'] in
+theorem not_isField_integralClosureAt : ¬IsField (integralClosureAt F' v) := by
+  intro hf
+  exact ValuationSubring.not_isField_of_ne_top F v.ne_top'
+    ((Algebra.IsIntegral.isField_iff_isField
+      (R := v.toValuationSubring) (S := integralClosureAt F' v)
+      (algebraMap_integralClosureAt_injective v)).mpr hf)
+
+omit [Algebra K F'] [IsScalarTower K F F'] [FiniteDimensional F F'] [Algebra.IsSeparable F F'] in
+theorem ne_bot_of_isMaximal (P : Ideal (integralClosureAt F' v)) [hP : P.IsMaximal] :
+    P ≠ ⊥ :=
+  Ring.ne_bot_of_isMaximal_of_not_isField hP (not_isField_integralClosureAt v)
+
+variable (F') in
+def heightOneSpectrumOfIsMaximal (P : Ideal (integralClosureAt F' v)) [hP : P.IsMaximal] :
+    HeightOneSpectrum (integralClosureAt F' v) :=
+  ⟨P, hP.isPrime, ne_bot_of_isMaximal v P⟩
+
+end Structural
+end Place
+end AlgebraicCurve
+
+end
+
+section
+
+open WeierstrassCurve.Affine.Point
+
+open scoped WeierstrassCurve.Affine
+
+section
+
+namespace AlgebraicCurve
+namespace Place
+open AlgebraicCurve.Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+@[scoped simp]
+private theorem evalAt_zero : v.evalAt (0 : F) = 0 := by
+  rw [← (algebraMap K F).map_zero, v.evalAt_algebraMap]
+
+end Place
+end AlgebraicCurve
+
+end
+end
+
+section
+
+open scoped Polynomial.Bivariate
+
+namespace WeierstrassCurve
+namespace Affine
+open WeierstrassCurve.Affine.CoordinateRing
+open WeierstrassCurve.Affine.CoordinateRing
+variable {F : Type*} [Field F] (W : Affine F)
+
+variable {W}
+
+section OrdAtPoint
+
+variable [IsDedekindDomain W.CoordinateRing]
+
+theorem ord_polyToFunctionField_eq_zero_iff {x y : F} (h : W.Equation x y) {p : F[X]}
+    (hp : p ≠ 0) :
+    (placeOfEquation h).ord (polyToFunctionField W p) = 0 ↔ p.eval x ≠ 0 := by
+  have h1 := ord_polyToFunctionField_pos_iff h hp (y := y)
+  have h2 : 0 ≤ (placeOfEquation h).ord (polyToFunctionField W p) := by
+    rw [polyToFunctionField_apply]
+    exact ord_placeOfEquation_nonneg h _
+  constructor
+  · intro h0 hcon
+    have h3 := h1.mpr hcon
+    omega
+  · intro hne
+    rcases lt_or_eq_of_le h2 with hlt | heq
+    · exact absurd (h1.mp hlt) hne
+    · exact heq.symm
+
+end OrdAtPoint
+end Affine
+end WeierstrassCurve
+
+end
+
+section
+
+open WithZero
+
+open scoped Polynomial.Bivariate
+
+namespace AlgebraicCurve
+namespace Place
+open AlgebraicCurve.Place
+variable {K : Type*} [Field K]
+variable {R : Type*} [CommRing R] [IsDedekindDomain R]
+variable {L : Type*} [Field L] [Algebra R L] [IsFractionRing R L]
+variable [Algebra K R] [Algebra K L] [IsScalarTower K R L]
+
+theorem ord_ofHeightOneSpectrum_algebraMap_eq_one (w : HeightOneSpectrum R) {r : R}
+    (hr : r ∈ w.asIdeal) (hr2 : r ∉ w.asIdeal ^ 2) :
+    (ofHeightOneSpectrum (K := K) (F := L) w).ord (algebraMap R L r) = 1 := by
+  have hr0 : r ≠ 0 := fun h => hr2 (h ▸ Submodule.zero_mem _)
+  have hrL : algebraMap R L r ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective R L)).mpr hr0
+  rw [ord_ofHeightOneSpectrum_eq_neg_log w hrL, w.valuation_of_algebraMap]
+  have h1 : w.intValuation r ≤ exp (-((1 : ℕ) : ℤ)) := by
+    rw [HeightOneSpectrum.intValuation_le_pow_iff_mem]
+    simpa using hr
+  have h2 : ¬ w.intValuation r ≤ exp (-((2 : ℕ) : ℤ)) := by
+    rw [HeightOneSpectrum.intValuation_le_pow_iff_mem]
+    exact hr2
+  rw [w.intValuation_if_neg hr0] at h1 h2 ⊢
+  rw [exp_le_exp] at h1 h2
+  rw [log_exp]
+  omega
+
+end Place
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+namespace Affine
+variable {F : Type*} [Field F] {W : Affine F}
+
+namespace CoordinateRing
+open WeierstrassCurve.Affine.CoordinateRing
+
+theorem derivative_polynomial : derivative W.polynomial = W.polynomialY := by
+  rw [WeierstrassCurve.Affine.polynomial, WeierstrassCurve.Affine.polynomialY,
+    derivative_sub, derivative_add, derivative_sq, derivative_X, derivative_C_mul_X,
+    derivative_C]
+  simp only [mul_one, sub_zero, map_ofNat]
+
+theorem evalEval_eq_zero_of_mem_span {x₀ y₀ : F} {z : F[X][Y]}
+    (hz : z ∈ Ideal.span {C (X - C x₀), Y - C (C y₀)}) : z.evalEval x₀ y₀ = 0 :=
+  mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero.mp hz
+
+theorem evalEval_derivative_eq_zero_of_mem_span_sq {x₀ y₀ : F} {z : F[X][Y]}
+    (hz : z ∈ Ideal.span {C (X - C x₀), Y - C (C y₀)} ^ 2) :
+    (derivative z).evalEval x₀ y₀ = 0 := by
+  rw [pow_two] at hz
+  refine Submodule.mul_induction_on hz (fun f hf g hg => ?_) (fun a b ha hb => ?_)
+  · have hf0 : f.evalEval x₀ y₀ = 0 := evalEval_eq_zero_of_mem_span hf
+    have hg0 : g.evalEval x₀ y₀ = 0 := evalEval_eq_zero_of_mem_span hg
+    rw [derivative_mul, evalEval_add, evalEval_mul, evalEval_mul, hf0, hg0, mul_zero,
+      zero_mul, add_zero]
+  · rw [derivative_add, evalEval_add, ha, hb, add_zero]
+
+theorem exists_eq_add_mul_polynomial_of_mem_XYIdeal_sq {x₀ y₀ : F} {r : F[X][Y]}
+    (hr : mk W r ∈ XYIdeal W x₀ (C y₀) ^ 2) :
+    ∃ z ∈ Ideal.span {C (X - C x₀), Y - C (C y₀)} ^ 2, ∃ δ : F[X][Y],
+      r = z + δ * W.polynomial := by
+  have hmap : XYIdeal W x₀ (C y₀)
+      = Ideal.map (mk W) (Ideal.span {C (X - C x₀), Y - C (C y₀)}) := by
+    rw [Ideal.map_span, Set.image_pair]
+    rfl
+  rw [hmap, ← Ideal.map_pow] at hr
+  obtain ⟨z, hz, hzr⟩ := (Ideal.mem_map_iff_of_surjective _ AdjoinRoot.mk_surjective).mp hr
+  obtain ⟨δ, hδ⟩ := AdjoinRoot.mk_eq_mk.mp hzr
+  exact ⟨z, hz, -δ, by linear_combination -hδ⟩
+
+theorem X_sub_C_dvd_eval_of_mem_span {x₀ y₀ : F} {z : F[X][Y]}
+    (hz : z ∈ Ideal.span {C (X - C x₀), Y - C (C y₀)}) :
+    (X - C x₀ : F[X]) ∣ z.eval (C y₀) := by
+  refine dvd_iff_isRoot.mpr ?_
+  exact evalEval_eq_zero_of_mem_span hz
+
+theorem X_sub_C_sq_dvd_eval_of_mem_span_sq {x₀ y₀ : F} {z : F[X][Y]}
+    (hz : z ∈ Ideal.span {C (X - C x₀), Y - C (C y₀)} ^ 2) :
+    (X - C x₀ : F[X]) ^ 2 ∣ z.eval (C y₀) := by
+  rw [pow_two] at hz ⊢
+  refine Submodule.mul_induction_on hz (fun f hf g hg => ?_) (fun a b ha hb => ?_)
+  · rw [eval_mul]
+    exact mul_dvd_mul (X_sub_C_dvd_eval_of_mem_span hf) (X_sub_C_dvd_eval_of_mem_span hg)
+  · rw [eval_add]
+    exact dvd_add ha hb
+
+theorem XClass_notMem_XYIdeal_sq {x₀ y₀ : F} (heq : W.Equation x₀ y₀)
+    (hY : W.polynomialY.evalEval x₀ y₀ ≠ 0) :
+    XClass W x₀ ∉ XYIdeal W x₀ (C y₀) ^ 2 := by
+  intro hmem
+  have heq' : W.polynomial.evalEval x₀ y₀ = 0 := heq
+  obtain ⟨z, hz, δ, hδ⟩ :=
+    exists_eq_add_mul_polynomial_of_mem_XYIdeal_sq (r := C (X - C x₀)) hmem
+  have hδP : δ.evalEval x₀ y₀ = 0 := by
+    have h3 := congrArg (fun p => (derivative p).evalEval x₀ y₀) hδ
+    simp only [derivative_C, evalEval_zero, derivative_add, derivative_mul, evalEval_add,
+      evalEval_mul, evalEval_derivative_eq_zero_of_mem_span_sq hz, derivative_polynomial, heq',
+      mul_zero, zero_add] at h3
+    exact (mul_eq_zero.mp h3.symm).resolve_right hY
+  have h4 := congrArg (Polynomial.eval (C y₀ : F[X])) hδ
+  rw [eval_C, eval_add, eval_mul] at h4
+  have hdvd : (X - C x₀ : F[X]) ^ 2
+      ∣ z.eval (C y₀) + δ.eval (C y₀) * W.polynomial.eval (C y₀) := by
+    refine dvd_add (X_sub_C_sq_dvd_eval_of_mem_span_sq hz) ?_
+    rw [pow_two]
+    exact mul_dvd_mul (dvd_iff_isRoot.mpr hδP) (dvd_iff_isRoot.mpr heq')
+  rw [← h4] at hdvd
+  have := Polynomial.natDegree_le_of_dvd hdvd (X_sub_C_ne_zero x₀)
+  rw [natDegree_pow, natDegree_X_sub_C] at this
+  omega
+
+theorem YClass_notMem_XYIdeal_sq {x₀ y₀ : F} (heq : W.Equation x₀ y₀)
+    (hY : W.polynomialY.evalEval x₀ y₀ = 0) :
+    YClass W (C y₀) ∉ XYIdeal W x₀ (C y₀) ^ 2 := by
+  intro hmem
+  have heq' : W.polynomial.evalEval x₀ y₀ = 0 := heq
+  obtain ⟨z, hz, δ, hδ⟩ :=
+    exists_eq_add_mul_polynomial_of_mem_XYIdeal_sq (r := Y - C (C y₀)) hmem
+  have h3 := congrArg (fun p => (derivative p).evalEval x₀ y₀) hδ
+  simp only [derivative_sub, derivative_X, derivative_C, sub_zero, evalEval_one, derivative_add,
+    derivative_mul, evalEval_add, evalEval_mul, evalEval_derivative_eq_zero_of_mem_span_sq hz,
+    derivative_polynomial, heq', hY, mul_zero, add_zero] at h3
+  exact one_ne_zero h3
+
+end CoordinateRing
+
+open WeierstrassCurve.Affine.CoordinateRing
+open WeierstrassCurve.Affine.CoordinateRing
+
+variable [IsDedekindDomain W.CoordinateRing]
+
+theorem ord_placeOfEquation_XClass_self {x₀ y₀ : F} (heq : W.Equation x₀ y₀)
+    (hY : W.polynomialY.evalEval x₀ y₀ ≠ 0) :
+    (placeOfEquation heq).ord
+      (algebraMap W.CoordinateRing W.FunctionField (XClass W x₀)) = 1 :=
+  AlgebraicCurve.Place.ord_ofHeightOneSpectrum_algebraMap_eq_one
+    (heightOneSpectrumOfEquation heq) (Ideal.subset_span (Set.mem_insert _ _))
+    (XClass_notMem_XYIdeal_sq heq hY)
+
+theorem ord_placeOfEquation_YClass_self {x₀ y₀ : F} (heq : W.Equation x₀ y₀)
+    (hY : W.polynomialY.evalEval x₀ y₀ = 0) :
+    (placeOfEquation heq).ord
+      (algebraMap W.CoordinateRing W.FunctionField (YClass W (C y₀))) = 1 :=
+  AlgebraicCurve.Place.ord_ofHeightOneSpectrum_algebraMap_eq_one
+    (heightOneSpectrumOfEquation heq) (Ideal.subset_span (Set.mem_insert_of_mem _ rfl))
+    (YClass_notMem_XYIdeal_sq heq hY)
+
+end Affine
+end WeierstrassCurve
+
+end
+
+section
+
+namespace AlgebraicCurve
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+
+theorem fundamentalIdentityAlong_of_charZero [CharZero F] [HasPrincipalDivisors K F']
+    (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral) (hfin : FiniteAlong K φ) :
+    FundamentalIdentityAlong K φ hφ := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have : Module.Finite F F' := hfin
+  have : Algebra.IsSeparable F F' := inferInstance
+  have := isIntegral_along φ hφ
+  exact (fundamentalIdentity_iff_ramificationInertiaIdentity).mpr
+    (ramificationInertiaIdentity_of_finiteDimensional K F F')
+
+end AlgebraicCurve
+end
+
+section
+
+open IntermediateField
+
+namespace AlgebraicCurve
+namespace Place
+open AlgebraicCurve.Place
+
+attribute [local instance 0] valuationSubringAlgebra
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+theorem exists_restrict_eq_of_separable (v : Place K F) :
+    ∃ w : Place K F', w.restrict F = v := by
+  obtain ⟨M, hM⟩ := Ideal.exists_maximal (integralClosureAt F' v)
+  have := hM
+  exact ⟨placeOfPrime (heightOneSpectrumOfIsMaximal F' v M),
+    restrict_placeOfPrime (heightOneSpectrumOfIsMaximal F' v M)⟩
+
+end Place
+end AlgebraicCurve
+end
+
+section
+
+section
+
+namespace ModularCurve
+namespace Es1a1
+
+section FiSupply
+
+universe u
+
+variable {F : Type u} [Field F] [CharZero F] {V W : Affine F}
+
+theorem es1a3_fi_of_elliptic (ι : V.FunctionField →ₐ[F] W.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong F ι) :
+    FundamentalIdentityAlong F ι hι :=
+  haveI : CharZero V.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap F V.FunctionField).injective
+  fundamentalIdentityAlong_of_charZero ι hι hfin
+
+end FiSupply
+
+section FiDatum
+
+universe u
+
+variable {F : Type u} [Field F] [CharZero F] {W : Affine F}
+
+theorem es1a3_fi_isogenyEndDatum (D : IsogenyEndDatum W) :
+    FundamentalIdentityAlong F D.ι D.hι :=
+  es1a3_fi_of_elliptic D.ι D.hι D.hfin
+
+end FiDatum
+end Es1a1
+end ModularCurve
+end
+end
+
+section
+
+open WeierstrassCurve.Affine.Point
+
+open scoped WeierstrassCurve.Affine
+
+namespace AlgebraicCurve
+namespace Place
+open AlgebraicCurve.Place
+
+theorem exists_restrictAlong_eq_of_finiteAlong
+    {K F F' : Type*} [Field K] [Field F] [Field F']
+    [Algebra K F] [Algebra K F'] [CharZero F]
+    (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral) (hfin : FiniteAlong K φ)
+    (v : Place K F) : ∃ w : Place K F', w.restrictAlong φ hφ = v := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have : Module.Finite F F' := hfin
+  have : Algebra.IsSeparable F F' := inferInstance
+  obtain ⟨w, hw⟩ := Place.exists_restrict_eq_of_separable (K := K) (F' := F') v
+  exact ⟨w, hw⟩
+
+end Place
+end AlgebraicCurve
+
+end
+
+section
+
+section
+
+open scoped Polynomial.Bivariate
+
+namespace ModularCurve
+namespace Es1a1
+
+universe u
+
+section FiSupply
+
+variable {F : Type u} [Field F] [CharZero F] {V W : WeierstrassCurve.Affine F}
+
+theorem es1a6_twFi_of_elliptic (ι : V.FunctionField →ₐ[F] W.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong F ι) :
+    FundamentalIdentityAlong F ι hι :=
+  haveI : CharZero V.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap F V.FunctionField).injective
+  fundamentalIdentityAlong_of_charZero ι hι hfin
+
+end FiSupply
+end Es1a1
+end ModularCurve
+end
+end
+
+section
+
+section
+
+open Function
+
+namespace WeierstrassCurve
+namespace Affine
+universe u
+
+section GeneralW
+
+variable {F : Type u} [Field F] [DecidableEq F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+omit [DecidableEq F] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_geomMorph_surjective (D : IsogenyEndDatum W) :
+    Surjective D.geomMorph := fun Q => by
+  have : CharZero W.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap F W.FunctionField).injective
+  obtain ⟨w, hw⟩ := AlgebraicCurve.Place.exists_restrictAlong_eq_of_finiteAlong
+    D.ι D.hι D.hfin (placeOfPoint Q)
+  exact ⟨(placeOfPointEquiv W).symm w, placeOfPoint_injective (by
+    rw [← D.placeOfPoint_geomMorph, placeOfPoint_placeOfPointEquiv_symm, hw])⟩
+
+omit [GenusOnePlaceGate.IsCentred W] in
+theorem kw_pointEnd_surjective (D : IsogenyEndDatum W) :
+    Surjective (D.pointEnd' : W.Point → W.Point) := fun R => by
+  obtain ⟨P, hP⟩ := kw_geomMorph_surjective D (R + D.geomMorph 0)
+  exact ⟨P, by rw [D.pointEnd_eq_geomMorph_sub_geomMorph_zero, hP, add_sub_cancel_right]⟩
+
+end GeneralW
+end Affine
+end WeierstrassCurve
+end
+end
+
+section
+
+section
+
+open Function
+
+namespace WeierstrassCurve
+namespace Affine
+universe u
+
+section GeneralW
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+def kw_pointEnd_fiber_equiv_ker (D : IsogenyEndDatum W) (R : W.Point) :
+    {P : W.Point // D.pointEnd' P = R} ≃ (AddMonoidHom.ker D.pointEnd') :=
+  let P₀ : W.Point := (kw_pointEnd_surjective D R).choose
+  have hP₀ : D.pointEnd' P₀ = R := (kw_pointEnd_surjective D R).choose_spec
+  { toFun := fun ⟨P, hP⟩ => ⟨P - P₀, by
+      change D.pointEnd' (P - P₀) = 0
+      rw [map_sub, hP, hP₀, sub_self]⟩
+    invFun := fun ⟨K, hK⟩ => ⟨K + P₀, by
+      show D.pointEnd' (K + P₀) = R
+      have hK' : D.pointEnd' K = 0 := hK
+      rw [map_add, hK', zero_add, hP₀]⟩
+    left_inv := fun ⟨P, _⟩ => Subtype.ext (sub_add_cancel P P₀)
+    right_inv := fun ⟨K, _⟩ => Subtype.ext (add_sub_cancel_right K P₀) }
+
+def kw_restrictAlong_fiber_equiv_pointEnd_fiber (D : IsogenyEndDatum W)
+    (v : AlgebraicCurve.Place F W.FunctionField) :
+    {w : AlgebraicCurve.Place F W.FunctionField // w.restrictAlong D.ι D.hι = v}
+      ≃ {P : W.Point //
+          D.pointEnd' P = (placeOfPointEquiv W).symm v - D.geomMorph 0} where
+  toFun := fun ⟨w, hw⟩ => ⟨(placeOfPointEquiv W).symm w, by
+    rw [D.pointEnd_eq_geomMorph_sub_geomMorph_zero, sub_left_inj]
+    exact placeOfPoint_injective (by
+      rw [← D.placeOfPoint_geomMorph, placeOfPoint_placeOfPointEquiv_symm, hw,
+        placeOfPoint_placeOfPointEquiv_symm])⟩
+  invFun := fun ⟨P, hP⟩ => ⟨placeOfPoint P, by
+    rw [D.placeOfPoint_geomMorph P, ← placeOfPoint_placeOfPointEquiv_symm W v]
+    congr 1
+    have h : D.geomMorph P - D.geomMorph 0
+        = (placeOfPointEquiv W).symm v - D.geomMorph 0 :=
+      (D.pointEnd_eq_geomMorph_sub_geomMorph_zero P).symm.trans hP
+    exact sub_left_injective h⟩
+  left_inv := fun ⟨w, _⟩ => Subtype.ext (placeOfPoint_placeOfPointEquiv_symm W w)
+  right_inv := fun ⟨P, _⟩ => Subtype.ext (placeOfPointEquiv_symm_placeOfPoint W P)
+
+omit [IsAlgClosed F] [GenusOnePlaceGate.IsCentred W] in
+theorem kw_natCard_restrictAlong_fiber_eq_ker (D : IsogenyEndDatum W)
+    (v : AlgebraicCurve.Place F W.FunctionField) :
+    Nat.card {w : AlgebraicCurve.Place F W.FunctionField //
+        w.restrictAlong D.ι D.hι = v}
+      = Nat.card (AddMonoidHom.ker D.pointEnd') :=
+  Nat.card_congr ((kw_restrictAlong_fiber_equiv_pointEnd_fiber D v).trans
+    (kw_pointEnd_fiber_equiv_ker D _))
+
+def kw_ExistsUnramifiedBasePlace (D : IsogenyEndDatum W) : Prop :=
+  letI := algebraAlong D.ι
+  haveI := isScalarTower_along D.ι
+  haveI := isIntegral_along D.ι D.hι
+  ∃ v : AlgebraicCurve.Place F W.FunctionField,
+    ∀ w : AlgebraicCurve.Place F W.FunctionField,
+      w.restrict W.FunctionField = v → w.ramificationIndex W.FunctionField = 1
+
+omit [DecidableEq F] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_natCard_restrictAlong_fiber_eq_degree_of_unramified (D : IsogenyEndDatum W)
+    (v : AlgebraicCurve.Place F W.FunctionField)
+    (hv : letI := algebraAlong D.ι
+      haveI := isScalarTower_along D.ι
+      haveI := isIntegral_along D.ι D.hι
+      ∀ w : AlgebraicCurve.Place F W.FunctionField,
+        w.restrict W.FunctionField = v → w.ramificationIndex W.FunctionField = 1) :
+    Nat.card {w : AlgebraicCurve.Place F W.FunctionField //
+        w.restrictAlong D.ι D.hι = v}
+      = D.degree := by
+  let := algebraAlong D.ι
+  have := isScalarTower_along D.ι
+  have := isIntegral_along D.ι D.hι
+  have hFI' : FundamentalIdentity F W.FunctionField W.FunctionField :=
+    ModularCurve.Es1a1.es1a6_twFi_of_elliptic D.ι D.hι D.hfin
+  have hsum := ModularCurve.Es1a1.es1a1_dual_sum_ramificationIndex (K := F)
+    (F := W.FunctionField) (F' := W.FunctionField)
+    (deg_eq_one (W := W)) (deg_eq_one (W := W)) v
+  have hcoll : ∀ w ∈ v.fiber W.FunctionField,
+      (w.ramificationIndex W.FunctionField : ℤ) = 1 := by
+    intro w hw
+    rw [hv w (Place.mem_fiber.mp hw), Nat.cast_one]
+  rw [Finset.sum_congr rfl hcoll, Finset.sum_const, nsmul_eq_mul, mul_one] at hsum
+  have hcard : (v.fiber W.FunctionField).card = D.degree := by
+    have h : ((v.fiber W.FunctionField).card : ℤ) = (D.degree : ℤ) := hsum
+    exact_mod_cast h
+  rw [← hcard]
+  refine Nat.card_congr ?_ |>.trans (Nat.card_eq_finsetCard _)
+  exact {
+    toFun := fun ⟨w, hw⟩ => ⟨w, Place.mem_fiber.mpr hw⟩
+    invFun := fun ⟨w, hw⟩ => ⟨w, Place.mem_fiber.mp hw⟩
+    left_inv := fun _ => rfl
+    right_inv := fun _ => rfl }
+
+omit [IsAlgClosed F] in
+theorem kw_datumKernelDegreeFace_of_existsUnramified
+    (hunram : ∀ D : IsogenyEndDatum W, kw_ExistsUnramifiedBasePlace D) :
+    ModularCurve.cmm10_deg_DatumKernelDegreeFace W := fun D => by
+  obtain ⟨v, hv⟩ := hunram D
+  rw [← kw_natCard_restrictAlong_fiber_eq_ker D v,
+    kw_natCard_restrictAlong_fiber_eq_degree_of_unramified D v hv]
+
+end GeneralW
+end Affine
+end WeierstrassCurve
+end
+end
+
+section
+
+section
+
+open scoped Polynomial.Bivariate
+
+namespace ModularCurve
+namespace Es1a1
+
+universe u
+
+section AddLawCoreCmp
+
+variable {F : Type u} [Field F]
+
+variable (W : WeierstrassCurve.Affine F)
+
+theorem es1a8_add_equation_cmp (φ : W.FunctionField →ₐ[F] W.FunctionField) :
+    (W.map (algebraMap F W.FunctionField)).toAffine.Equation
+      (φ (polyToFunctionField W X)) (φ (yGen W)) := by
+  have h := equation_map_polyToFunctionField_yGen (W := W)
+  rw [equation_iff'] at h
+  simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+    WeierstrassCurve.map_a₄, WeierstrassCurve.map_a₆] at h
+  have h2 := congrArg φ h
+  simp only [map_add, map_sub, map_mul, map_pow, _root_.map_zero, AlgHom.commutes] at h2
+  rw [equation_iff']
+  simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+    WeierstrassCurve.map_a₄, WeierstrassCurve.map_a₆]
+  linear_combination h2
+
+end AddLawCoreCmp
+
+end Es1a1
+end ModularCurve
+end
+end
+
+namespace WeierstrassCurve
+namespace Affine
+theorem kw_point_infinite {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    {W : Affine F} [W.IsElliptic] [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W]
+    [AbelTheorem W] :
+    Infinite W.Point :=
+  WeierstrassCurve.point_infinite (W := W)
+
+end Affine
+end WeierstrassCurve
+
+section
+
+section
+
+open Function
+namespace WeierstrassCurve
+namespace Affine
+universe u
+
+section GeneralW
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+theorem kw_existsUnramifiedBasePlace_proved (D : IsogenyEndDatum W) :
+    kw_ExistsUnramifiedBasePlace D := by
+  classical
+  let := algebraAlong D.ι
+  have := isScalarTower_along D.ι
+  have := isIntegral_along D.ι D.hι
+  have hfin : @Module.Finite W.FunctionField W.FunctionField _ _
+    (@Algebra.toModule _ _ _ _ (algebraAlong D.ι)) := D.hfin
+  have hcz : CharZero W.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap F W.FunctionField).injective
+  have hsep : Algebra.IsSeparable W.FunctionField W.FunctionField := inferInstance
+  have hpd : HasPrincipalDivisors F W.FunctionField := hasPrincipalDivisors_functionField _
+  obtain ⟨θ, hgen⟩ := Field.exists_primitive_element W.FunctionField W.FunctionField
+  have hpmon : (minpoly W.FunctionField θ).Monic :=
+    minpoly.monic (_root_.IsIntegral.of_finite W.FunctionField θ)
+  have hg0 : aeval θ (derivative (minpoly W.FunctionField θ)) ≠ 0 :=
+    (Algebra.IsSeparable.isSeparable W.FunctionField θ).aeval_derivative_ne_zero
+      (minpoly.aeval W.FunctionField θ)
+  let S₁ : Set (AlgebraicCurve.Place F W.FunctionField) :=
+    ⋃ i ∈ (minpoly W.FunctionField θ).support,
+      {v | (minpoly W.FunctionField θ).coeff i ∉ v.toValuationSubring}
+  let S₂ : Set (AlgebraicCurve.Place F W.FunctionField) :=
+    {w | w.ord (aeval θ (derivative (minpoly W.FunctionField θ))) ≠ 0}
+  have hS₁fin : S₁.Finite :=
+    Set.Finite.biUnion (minpoly W.FunctionField θ).support.finite_toSet fun i _ =>
+      finite_setOf_notMem_toValuationSubring (K := F) ((minpoly W.FunctionField θ).coeff i)
+  have hS₂fin : S₂.Finite := finite_setOf_ord_ne_zero_of_hasPrincipalDivisors (K := F) hg0
+  have hSfin : (S₁ ∪ (fun w => w.restrict W.FunctionField) '' S₂).Finite :=
+    hS₁fin.union (hS₂fin.image _)
+  have : Infinite (AlgebraicCurve.Place F W.FunctionField) :=
+    (placeOfPointEquiv W).symm.infinite_iff.mpr kw_point_infinite
+  obtain ⟨v, hv⟩ := hSfin.infinite_compl.nonempty
+  simp only [Set.mem_compl_iff, Set.mem_union, not_or] at hv
+  obtain ⟨hvS₁, hvS₂⟩ := hv
+  refine ⟨v, fun w hw => ?_⟩
+  by_contra hram
+  have hcoeff : ∀ i, (minpoly W.FunctionField θ).coeff i ∈ v.toValuationSubring := by
+    intro i
+    by_contra hni
+    have hci : (minpoly W.FunctionField θ).coeff i ≠ 0 :=
+      fun h => hni (h ▸ v.toValuationSubring.zero_mem)
+    exact hvS₁ (Set.mem_biUnion (Finset.mem_coe.mpr (mem_support_iff.mpr hci)) hni)
+  obtain ⟨Q, hQmap, -, hQmon⟩ :=
+    lifts_and_degree_eq_and_monic (mem_lifts_of_integralAt (fun i => hcoeff i)) hpmon
+  have hθint : @_root_.IsIntegral v.toValuationSubring W.FunctionField _ _
+      (AlgebraicCurve.Place.valuationSubringAlgebra W.FunctionField v) θ := by
+    refine ⟨Q, hQmon, ?_⟩
+    rw [RingHom.algebraMap_toAlgebra, ← Polynomial.eval₂_map, hQmap]
+    exact minpoly.aeval W.FunctionField θ
+  have hpos := AlgebraicCurve.Place.ord_deriv_pos_of_ramificationIndex_ne_one
+    (K := F) (F := W.FunctionField) (F' := W.FunctionField)
+    (v := v) (w := w) hw θ hgen hθint hram
+  exact hvS₂ ⟨w, hpos.ne', hw⟩
+
+theorem kw_datumKernelDegreeFace_unconditional :
+    ModularCurve.cmm10_deg_DatumKernelDegreeFace W :=
+  kw_datumKernelDegreeFace_of_existsUnramified kw_existsUnramifiedBasePlace_proved
+
+end GeneralW
+end Affine
+end WeierstrassCurve
+end
+end
+
+section
+
+section
+
+namespace WeierstrassCurve
+namespace Affine
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+namespace IsogenyEndDatum
+
+omit [DecidableEq F] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_iucz_sum_ramificationIndex_eq_degree (D : IsogenyEndDatum W)
+    (v : AlgebraicCurve.Place F W.FunctionField) :
+    letI := algebraAlong D.ι
+    haveI := isScalarTower_along D.ι
+    haveI := isIntegral_along D.ι D.hι
+    ∑ w ∈ v.fiber W.FunctionField,
+        (w.ramificationIndex W.FunctionField : ℤ)
+      = (D.degree : ℤ) := by
+  have _pin := Classical.em True
+  let := algebraAlong D.ι
+  have := isScalarTower_along D.ι
+  have := isIntegral_along D.ι D.hι
+  have hFI' : FundamentalIdentity F W.FunctionField W.FunctionField :=
+    ModularCurve.Es1a1.es1a6_twFi_of_elliptic D.ι D.hι D.hfin
+  exact ModularCurve.Es1a1.es1a1_dual_sum_ramificationIndex (K := F)
+    (F := W.FunctionField) (F' := W.FunctionField)
+    (deg_eq_one (W := W)) (deg_eq_one (W := W)) v
+
+omit [IsAlgClosed F] [GenusOnePlaceGate.IsCentred W] in
+theorem kw_iucz_unramified_of_existsUnramifiedBasePlace (D : IsogenyEndDatum W)
+    (heub : kw_ExistsUnramifiedBasePlace D) :
+    kw_ipfd_unramified D := by
+  have _pin := Classical.em True
+  classical
+  let := algebraAlong D.ι
+  have := isScalarTower_along D.ι
+  have := isIntegral_along D.ι D.hι
+  obtain ⟨v₀, hv₀⟩ := heub
+  have hkd : Nat.card (AddMonoidHom.ker D.pointEnd') = D.degree := by
+    rw [← kw_natCard_restrictAlong_fiber_eq_ker D v₀]
+    exact kw_natCard_restrictAlong_fiber_eq_degree_of_unramified D v₀ hv₀
+  intro P
+  set v := (placeOfPoint P).restrictAlong D.ι D.hι with hv
+  have hmem : placeOfPoint P ∈ v.fiber W.FunctionField := Place.mem_fiber.mpr rfl
+  have hsum := kw_iucz_sum_ramificationIndex_eq_degree D v
+  have hcard : (v.fiber W.FunctionField).card = D.degree := by
+    have h1 : Nat.card {w : AlgebraicCurve.Place F W.FunctionField //
+          w.restrictAlong D.ι D.hι = v}
+        = (v.fiber W.FunctionField).card := by
+      refine (Nat.card_congr ?_).trans (Nat.card_eq_finsetCard _)
+      exact {
+        toFun := fun ⟨w, hw⟩ => ⟨w, Place.mem_fiber.mpr hw⟩
+        invFun := fun ⟨w, hw⟩ => ⟨w, Place.mem_fiber.mp hw⟩
+        left_inv := fun _ => rfl
+        right_inv := fun _ => rfl }
+    rw [← h1, kw_natCard_restrictAlong_fiber_eq_ker D v, hkd]
+  have hpos : ∀ w ∈ v.fiber W.FunctionField,
+      (1 : ℤ) ≤ (w.ramificationIndex W.FunctionField : ℤ) := fun w _ => by
+    exact_mod_cast (w.ramificationIndex_pos (F := W.FunctionField))
+  have heq : ((placeOfPoint P).ramificationIndex W.FunctionField : ℤ) = 1 := by
+    have hge : (((v.fiber W.FunctionField).erase (placeOfPoint P)).card : ℤ)
+        ≤ ∑ w ∈ (v.fiber W.FunctionField).erase (placeOfPoint P),
+            (w.ramificationIndex W.FunctionField : ℤ) := by
+      calc (((v.fiber W.FunctionField).erase (placeOfPoint P)).card : ℤ)
+          = ∑ _w ∈ (v.fiber W.FunctionField).erase (placeOfPoint P), (1 : ℤ) := by
+            rw [Finset.sum_const, nsmul_eq_mul, mul_one]
+        _ ≤ _ := Finset.sum_le_sum fun w hw =>
+            hpos w (Finset.mem_of_mem_erase hw)
+    have hsplit :
+        ((placeOfPoint P).ramificationIndex W.FunctionField : ℤ)
+          + ∑ w ∈ (v.fiber W.FunctionField).erase (placeOfPoint P),
+              (w.ramificationIndex W.FunctionField : ℤ)
+          = (D.degree : ℤ) :=
+      (Finset.add_sum_erase (v.fiber W.FunctionField)
+        (fun w => (w.ramificationIndex W.FunctionField : ℤ)) hmem).trans hsum
+    have hrest : ((v.fiber W.FunctionField).erase (placeOfPoint P)).card + 1
+        = D.degree := by
+      rw [Finset.card_erase_add_one hmem, hcard]
+    have hge1 := hpos _ hmem
+    omega
+  change Place.ramificationIndexAlong D.ι (placeOfPoint P) = 1
+  exact_mod_cast heq
+
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+end
+end
+
+namespace WeierstrassCurve
+theorem surjective_zsmul_of_ne_zero {K : Type*} [Field K] [DecidableEq K] [IsAlgClosed K]
+    [CharZero K]
+    (W : WeierstrassCurve K) [W.IsElliptic] {m : ℤ} (hm : m ≠ 0) :
+    Function.Surjective (fun P : W.toAffine.Point => m • P) := fun P =>
+  WeierstrassCurve.Affine.Point.exists_zsmul_eq_of_isAlgClosed W hm P
+
+end WeierstrassCurve
+
+section
+
+section
+
+namespace WeierstrassCurve
+namespace Affine
+universe u
+
+section GeneralW
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+def kw_dualPointEnd (D : IsogenyEndDatum W) : AddMonoid.End W.Point :=
+  ModularCurve.Es1a1.es1a1_dualPointEnd D
+    (ModularCurve.Es1a1.es1a3_fi_isogenyEndDatum D)
+
+omit [GenusOnePlaceGate.IsCentred W] in
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem kw_pointEnd_mul_dualPointEnd (D : IsogenyEndDatum W) :
+    D.pointEnd' * kw_dualPointEnd D = ((D.degree : ℤ) : AddMonoid.End W.Point) :=
+  ModularCurve.Es1a1.es1a1_pointEnd_mul_dualPointEnd D
+    (ModularCurve.Es1a1.es1a3_fi_isogenyEndDatum D)
+
+theorem kw_pointEnd_mul_cancel (D : IsogenyEndDatum W) (ψ : AddMonoid.End W.Point)
+    (hzero : D.pointEnd' * ψ = 0) : ψ = 0 := by
+  have hkerF : Nat.card (AddMonoidHom.ker (D.pointEnd' : W.Point →+ W.Point)) = D.degree :=
+    kw_datumKernelDegreeFace_unconditional D
+  have hdpos : (0 : ℤ) < (D.degree : ℤ) :=
+    Int.natCast_pos.mpr (ModularCurve.cmm10_deg_degree_pos D)
+  refine DFunLike.ext _ _ fun P => ?_
+  obtain ⟨Q, hQ⟩ := WeierstrassCurve.surjective_zsmul_of_ne_zero (W := W)
+    (m := (D.degree : ℤ)) hdpos.ne' P
+  have hker : D.pointEnd' (ψ Q) = 0 := DFunLike.congr_fun hzero Q
+  have hkill : (D.degree : ℤ) • ψ Q = 0 := by
+    have := ModularCurve.cmm14_dex_card_ker_zsmul_eq_zero
+      (D.pointEnd' : W.Point →+ W.Point) hker
+    rwa [hkerF] at this
+  change ψ P = 0
+  rw [← hQ, map_zsmul]
+  exact hkill
+
+theorem kw_dualPointEnd_unique (D : IsogenyEndDatum W) (ψ : AddMonoid.End W.Point)
+    (hψ : D.pointEnd' * ψ = ((D.degree : ℤ) : AddMonoid.End W.Point)) :
+    ψ = kw_dualPointEnd D := by
+  have hzero : D.pointEnd' * (ψ - kw_dualPointEnd D) = 0 := by
+    rw [mul_sub, hψ, kw_pointEnd_mul_dualPointEnd D, sub_self]
+  exact sub_eq_zero.mp (kw_pointEnd_mul_cancel D _ hzero)
+
+def KwDualTraceWitness (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+    :
+    Prop :=
+  ∀ D : IsogenyEndDatum W, ∃ t : ℤ,
+    D.pointEnd' + kw_dualPointEnd D = ((t : ℤ) : AddMonoid.End W.Point)
+
+omit [IsAlgClosed F] in
+theorem kw_dualInSubring_of_traceWitness (htw : KwDualTraceWitness W)
+    (D : IsogenyEndDatum W) :
+    kw_dualPointEnd D ∈ isogenyEndSubring W (fun D => D.normFormulaAlong_auto) := by
+  obtain ⟨t, htr⟩ := htw D
+  have hψ : kw_dualPointEnd D
+      = ((t : ℤ) : AddMonoid.End W.Point) - D.pointEnd' :=
+    eq_sub_of_add_eq' htr
+  rw [hψ]
+  exact sub_mem (intCast_mem _ t)
+    (WeierstrassCurve.Affine.IsogenyEndDatum.pointEnd_mem_isogenyEndSubring _ (fun D =>
+    D.normFormulaAlong_auto) D)
+
+end GeneralW
+end Affine
+end WeierstrassCurve
+end
+end
+
+namespace WeierstrassCurve
+namespace Affine
+scoped instance kw_charZero_end_point {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F]
+  [CharZero F]
+    {W : Affine F} [W.IsElliptic] [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W]
+    [AbelTheorem W] :
+    CharZero (AddMonoid.End W.Point) := by
+  have key : ∀ n : ℕ, (n : AddMonoid.End W.Point) = 0 → n = 0 := by
+    intro n hn
+    by_contra hne
+    have htors : ∀ P : W.Point, (n : ℤ) • P = 0 := fun P => by
+      have h := DFunLike.congr_fun hn P
+      rw [AddMonoid.End.natCast_apply] at h
+      simpa [natCast_zsmul] using h
+    have : Finite (Submodule.torsionBy ℤ W.Point (n : ℤ)) :=
+      WeierstrassCurve.finite_torsionBy_of_natCast_ne_zero F W n (by exact_mod_cast hne)
+    have hsurj : Function.Surjective
+        (fun P : Submodule.torsionBy ℤ W.Point (n : ℤ) => (P : W.Point)) := fun P =>
+      ⟨⟨P, (Submodule.mem_torsionBy_iff _ _).mpr (htors P)⟩, rfl⟩
+    have : Finite W.Point := Finite.of_surjective _ hsurj
+    exact (WeierstrassCurve.point_infinite (W := W)).not_finite ‹_›
+  refine ⟨fun a b hab => ?_⟩
+  rcases le_total a b with h | h
+  · have h0 : ((b - a : ℕ) : AddMonoid.End W.Point) = 0 := by
+      rw [Nat.cast_sub h, hab, sub_self]
+    have := key _ h0; omega
+  · have h0 : ((a - b : ℕ) : AddMonoid.End W.Point) = 0 := by
+      rw [Nat.cast_sub h, hab, sub_self]
+    have := key _ h0; omega
+
+end Affine
+end WeierstrassCurve
+
+section
+
+section
+
+namespace WeierstrassCurve
+namespace Affine
+universe u
+
+section GeneralW
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+def kw_dualEndData_of_traceWitness (htw : KwDualTraceWitness W)
+    (D : IsogenyEndDatum W) : AddMonoid.End.DualEndData D.pointEnd' :=
+  ModularCurve.Es1a1.es1a4_twDualEndData_of_add_of_mul
+    D.pointEnd' (kw_dualPointEnd D) (htw D).choose (D.degree : ℤ)
+    (htw D).choose_spec (kw_pointEnd_mul_dualPointEnd D)
+
+omit [IsAlgClosed F] in
+@[scoped simp] theorem kw_dualEndData_of_traceWitness_dual (htw : KwDualTraceWitness W)
+    (D : IsogenyEndDatum W) :
+    (kw_dualEndData_of_traceWitness htw D).dual = kw_dualPointEnd D := rfl
+
+end GeneralW
+end Affine
+end WeierstrassCurve
+end
+end
+
+section
+
+section
+
+namespace WeierstrassCurve
+namespace Affine
+universe u
+
+section GeneralW
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+theorem kw_pointEnd_ne_zero (D : IsogenyEndDatum W) : D.pointEnd' ≠ 0 := by
+  intro hzero
+  have hker : Nat.card (AddMonoidHom.ker D.pointEnd') = D.degree :=
+    kw_datumKernelDegreeFace_unconditional D
+  have hall : AddMonoidHom.ker D.pointEnd' = ⊤ := by
+    rw [hzero]; exact AddMonoidHom.ker_zero
+  have : Infinite W.Point := kw_point_infinite
+  rw [hall, Nat.card_congr (AddSubgroup.topEquiv (G := W.Point)).toEquiv,
+    Nat.card_eq_zero_of_infinite] at hker
+  exact (ModularCurve.cmm10_deg_degree_pos D).ne' hker.symm
+
+theorem kw_degree_eq_of_pointEnd_eq {D₁ D₂ : IsogenyEndDatum W}
+    (h : D₁.pointEnd' = D₂.pointEnd') : D₁.degree = D₂.degree := by
+  rw [← kw_datumKernelDegreeFace_unconditional D₁,
+    ← kw_datumKernelDegreeFace_unconditional D₂, h]
+
+theorem kw_dualPointEnd_eq_of_pointEnd_eq {D₁ D₂ : IsogenyEndDatum W}
+    (h : D₁.pointEnd' = D₂.pointEnd') :
+    kw_dualPointEnd D₁ = kw_dualPointEnd D₂ := by
+  refine kw_dualPointEnd_unique D₂ _ ?_
+  rw [← h, ← kw_degree_eq_of_pointEnd_eq h]
+  exact kw_pointEnd_mul_dualPointEnd D₁
+
+theorem kw_dualPointEnd_idDatum :
+    kw_dualPointEnd (IsogenyEndDatum.idDatum W) = 1 := by
+  refine (kw_dualPointEnd_unique (IsogenyEndDatum.idDatum W) 1 ?_).symm
+  rw [IsogenyEndDatum.idDatum_pointEnd, IsogenyEndDatum.degree_idDatum, mul_one,
+    Nat.cast_one, Int.cast_one]
+
+theorem kw_degree_of_pointEnd_intCast (D : IsogenyEndDatum W) (n : ℤ)
+    (hn : D.pointEnd' = ((n : ℤ) : AddMonoid.End W.Point)) :
+    (D.degree : ℤ) = n ^ 2 := by
+  have hne : n ≠ 0 := fun hz => kw_pointEnd_ne_zero D (by rw [hn, hz, Int.cast_zero])
+  have hna : 1 ≤ n.natAbs := Nat.one_le_iff_ne_zero.mpr (Int.natAbs_ne_zero.mpr hne)
+  have htors : ∀ (m : ℤ) (x : W.Point),
+      x ∈ AddMonoidHom.ker ((m : ℤ) : AddMonoid.End W.Point)
+        ↔ x ∈ Submodule.torsionBy ℤ W.Point m := fun m x =>
+    AddMonoidHom.mem_ker.trans (Submodule.mem_torsionBy_iff m x).symm
+  have hcard :
+      Nat.card (AddMonoidHom.ker D.pointEnd')
+        = Nat.card (AddMonoidHom.ker ((n.natAbs : ℤ) : AddMonoid.End W.Point)) := by
+    refine Nat.card_congr ((Equiv.subtypeEquivRight fun x => ?_).trans
+      (Equiv.subtypeEquivRight fun x => (htors (n.natAbs : ℤ) x).symm))
+    rw [hn]
+    refine (htors n x).trans ?_
+    rw [Submodule.mem_torsionBy_iff, Submodule.mem_torsionBy_iff, natCast_zsmul]
+    rcases Int.natAbs_eq n with h | h
+    · conv_lhs => rw [h, natCast_zsmul]
+    · conv_lhs => rw [h, neg_zsmul, natCast_zsmul, neg_eq_zero]
+  rw [← kw_datumKernelDegreeFace_unconditional D, hcard,
+    ModularCurve.cmm5_dp_natCard_ker_natCast (W := W) n.natAbs hna, Nat.cast_pow,
+    Int.natAbs_sq]
+
+theorem kw_dualPointEnd_of_pointEnd_intCast (D : IsogenyEndDatum W) (n : ℤ)
+    (hn : D.pointEnd' = ((n : ℤ) : AddMonoid.End W.Point)) :
+    kw_dualPointEnd D = ((n : ℤ) : AddMonoid.End W.Point) := by
+  refine (kw_dualPointEnd_unique D _ ?_).symm
+  rw [hn, ← Int.cast_mul, ← sq, ← kw_degree_of_pointEnd_intCast D n hn, Int.cast_natCast]
+
+end GeneralW
+end Affine
+end WeierstrassCurve
+end
+end
+
+section
+
+section
+
+namespace WeierstrassCurve
+namespace Affine
+universe u
+
+section GeneralW
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+def KwShiftDatumSupply (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+    :
+    Prop :=
+  ∀ D : IsogenyEndDatum W, 1 + D.pointEnd' ≠ 0 →
+    ∃ D' : IsogenyEndDatum W,
+      D'.pointEnd' = 1 + D.pointEnd' ∧
+      kw_dualPointEnd D' = 1 + kw_dualPointEnd D
+
+def KwDualConormAdditivityAtOne (W : Affine F) [W.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+    :
+    Prop :=
+  ∀ D D' : IsogenyEndDatum W, D'.pointEnd' = 1 + D.pointEnd' →
+    kw_dualPointEnd D' = 1 + kw_dualPointEnd D
+
+omit [IsAlgClosed F] in
+theorem kw_dualTraceWitness_of_shiftDatumSupply
+    (hsh : KwShiftDatumSupply W) : KwDualTraceWitness W := by
+  intro D
+  have h := kw_pointEnd_mul_dualPointEnd D
+  by_cases hzero : 1 + D.pointEnd' = 0
+  · have hd : (1 + D.pointEnd') * kw_dualPointEnd D = 0 := by rw [hzero, zero_mul]
+    have hd2 : kw_dualPointEnd D + D.pointEnd' * kw_dualPointEnd D = 0 := by
+      rw [← hd, add_mul, one_mul]
+    rw [h] at hd2
+    have hψ : kw_dualPointEnd D
+        = -(((D.degree : ℤ) : AddMonoid.End W.Point)) := by
+      rw [← zero_sub, ← hd2]; abel
+    have hφ : D.pointEnd' = 0 - 1 := by rw [← hzero]; abel
+    refine ⟨-1 - (D.degree : ℤ), ?_⟩
+    rw [Int.cast_sub, Int.cast_neg, Int.cast_one, hφ, hψ]
+    abel
+  · obtain ⟨D', hpt, hdual⟩ := hsh D hzero
+    have h' := kw_pointEnd_mul_dualPointEnd D'
+    rw [hpt, hdual] at h'
+    have hexp : (1 + D.pointEnd') * (1 + kw_dualPointEnd D)
+        = 1 + D.pointEnd' + (kw_dualPointEnd D
+            + D.pointEnd' * kw_dualPointEnd D) := by
+      rw [mul_add, mul_one, add_mul, one_mul]
+    rw [hexp, h] at h'
+    refine ⟨(D'.degree : ℤ) - (D.degree : ℤ) - 1, ?_⟩
+    rw [Int.cast_sub, Int.cast_sub, Int.cast_one, ← h']
+    abel
+
+omit [IsAlgClosed F] in
+theorem kw_shiftDatumSupply_of_addDatumSupply_of_dualAdditivity
+    (hadd : ModularCurve.KwIsogenyEndAddDatumSupply W)
+    (hdual : KwDualConormAdditivityAtOne W) :
+    KwShiftDatumSupply W := by
+  intro D hne
+  have hne' : (IsogenyEndDatum.idDatum W).pointEnd' + D.pointEnd' ≠ 0 := by
+    rwa [IsogenyEndDatum.idDatum_pointEnd]
+  obtain ⟨D', hD'⟩ := hadd (IsogenyEndDatum.idDatum W) D hne'
+  rw [IsogenyEndDatum.idDatum_pointEnd] at hD'
+  exact ⟨D', hD', hdual D D' hD'⟩
+
+omit [IsAlgClosed F] in
+theorem kw_dualTraceWitness_of_addDatumSupply_of_dualAdditivity
+    (hadd : ModularCurve.KwIsogenyEndAddDatumSupply W)
+    (hdual : KwDualConormAdditivityAtOne W) :
+    KwDualTraceWitness W :=
+  kw_dualTraceWitness_of_shiftDatumSupply
+    (kw_shiftDatumSupply_of_addDatumSupply_of_dualAdditivity hadd hdual)
+
+end GeneralW
+end Affine
+end WeierstrassCurve
+end
+end
+
+section
+
+section
+
+namespace ModularCurve
+
+namespace Es1a1
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+theorem kw_hk5f_dualTraceWitness_of_dualAdditivity
+    (hdual : KwDualConormAdditivityAtOne W) :
+    KwDualTraceWitness W :=
+  kw_dualTraceWitness_of_addDatumSupply_of_dualAdditivity
+    (kw_hk5f_addDatumSupply_proved W) hdual
+
+end Es1a1
+end ModularCurve
+end
+end
+
+section
+
+section
+
+open ModularCurve.Es1a1
+
+namespace WeierstrassCurve
+namespace Affine
+universe u
+
+section GeneralW
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+def KwDualAdditivityPhiRowGenericW : Prop :=
+  ∀ D₁ D₂ D₃ : IsogenyEndDatum W, D₃.pointEnd' = D₁.pointEnd' + D₂.pointEnd' →
+    kw_dualPointEnd D₃ = kw_dualPointEnd D₁ + kw_dualPointEnd D₂
+
+def KwDCAOGeomMorphDualAdditivity : Prop :=
+  ∀ D₁ D₂ D₃ : IsogenyEndDatum W,
+    (∀ P : W.Point, D₃.geomMorph P = D₁.geomMorph P + D₂.geomMorph P) →
+    kw_dualPointEnd D₃ = kw_dualPointEnd D₁ + kw_dualPointEnd D₂
+
+variable {W}
+
+theorem kw_dcao_of_phiRowGenericW (h : KwDualAdditivityPhiRowGenericW W) :
+    KwDualConormAdditivityAtOne W := by
+  intro D D' hpt
+  have hpe : D'.pointEnd' = (IsogenyEndDatum.idDatum W).pointEnd' + D.pointEnd' := by
+    rw [IsogenyEndDatum.idDatum_pointEnd]; exact hpt
+  have hd := h (IsogenyEndDatum.idDatum W) D D' hpe
+  rwa [kw_dualPointEnd_idDatum] at hd
+
+omit [IsAlgClosed F] [GenusOnePlaceGate.IsCentred W] in
+theorem kw_dcao_pointEnd_add_of_geomMorph_add {D₁ D₂ D₃ : IsogenyEndDatum W}
+    (hgm : ∀ P : W.Point, D₃.geomMorph P = D₁.geomMorph P + D₂.geomMorph P) :
+    D₃.pointEnd' = D₁.pointEnd' + D₂.pointEnd' := by
+  refine DFunLike.ext _ _ fun P => ?_
+  change D₃.pointEnd' P = D₁.pointEnd' P + D₂.pointEnd' P
+  rw [D₁.pointEnd_eq_geomMorph_sub_geomMorph_zero,
+    D₂.pointEnd_eq_geomMorph_sub_geomMorph_zero,
+    D₃.pointEnd_eq_geomMorph_sub_geomMorph_zero, hgm P, hgm 0]
+  abel
+
+theorem kw_dcao_phiRowGenericW_of_geomMorphDualAdditivity
+    (h : KwDCAOGeomMorphDualAdditivity W) :
+    KwDualAdditivityPhiRowGenericW W := by
+  intro D₁ D₂ D₃ hpe
+  have hne : D₁.pointEnd' + D₂.pointEnd' ≠ 0 := hpe ▸ kw_pointEnd_ne_zero D₃
+  obtain ⟨D₃', hgm⟩ := kw_hk5f_addGeomMorphSupply_proved W D₁ D₂ hne
+  have hpe' : D₃'.pointEnd' = D₃.pointEnd' :=
+    (kw_dcao_pointEnd_add_of_geomMorph_add hgm).trans hpe.symm
+  rw [kw_dualPointEnd_eq_of_pointEnd_eq hpe'.symm]
+  exact h D₁ D₂ D₃' hgm
+
+theorem kw_dcao_of_geomMorphDualAdditivity
+    (h : KwDCAOGeomMorphDualAdditivity W) :
+    KwDualConormAdditivityAtOne W :=
+  kw_dcao_of_phiRowGenericW (kw_dcao_phiRowGenericW_of_geomMorphDualAdditivity h)
+
+theorem kw_dcao_htw_of_geomMorphDualAdditivity
+    (h : KwDCAOGeomMorphDualAdditivity W) :
+    KwDualTraceWitness W :=
+  kw_hk5f_dualTraceWitness_of_dualAdditivity W (kw_dcao_of_geomMorphDualAdditivity h)
+
+end GeneralW
+end Affine
+end WeierstrassCurve
+end
+end
+
+section
+
+section
+
+open ModularCurve.Es1a1
+namespace WeierstrassCurve
+namespace Affine
+universe u
+
+section GeneralW
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+local instance kw_dcao_instHPD : HasPrincipalDivisors F W.FunctionField :=
+  hasPrincipalDivisors_functionField _
+
+theorem kw_dcao_unramified_proved (D : IsogenyEndDatum W) :
+    IsogenyEndDatum.kw_ipfd_unramified D :=
+  IsogenyEndDatum.kw_iucz_unramified_of_existsUnramifiedBasePlace D
+    (kw_existsUnramifiedBasePlace_proved D)
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [GenusOnePlaceGate.IsCentred W] in
+theorem kw_dcao_divisorSum_pullbackAlong (D : IsogenyEndDatum W)
+    (E : AlgebraicCurve.Divisor F W.FunctionField) (hE : Divisor.degree E = 0) :
+    divisorSum (Divisor.pullbackAlong D.ι D.hι E)
+      = kw_dualPointEnd D (divisorSum E) := by
+  have hsymm : (genusOnePic0Equiv W).symm (divisorSum E)
+      = Pic0.mk ⟨E, Divisor.mem_degZero.mpr hE⟩ := by
+    apply (genusOnePic0Equiv W).injective
+    rw [AddEquiv.apply_symm_apply, genusOnePic0Equiv_apply, pic0ToPoint_mk]
+  change _ = es1a1_dualPointEnd D (es1a3_fi_isogenyEndDatum D) (divisorSum E)
+  rw [es1a1_dualPointEnd_apply, hsymm, es1a1_conormPic0Hom_mk,
+    genusOnePic0Equiv_apply, pic0ToPoint_mk, es1a1_coe_conormDegZero]
+
+omit [DecidableEq F] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_dcao_defect_degree_zero (D₁ D₂ D₃ : IsogenyEndDatum W)
+    (E : AlgebraicCurve.Divisor F W.FunctionField) (hE : Divisor.degree E = 0) :
+    Divisor.degree
+      (Divisor.pullbackAlong D₃.ι D₃.hι E
+        - (Divisor.pullbackAlong D₁.ι D₁.hι E + Divisor.pullbackAlong D₂.ι D₂.hι E))
+      = 0 := by
+  rw [map_sub, map_add,
+    Divisor.degree_pullbackAlong D₃.ι D₃.hι (es1a3_fi_isogenyEndDatum D₃),
+    Divisor.degree_pullbackAlong D₁.ι D₁.hι (es1a3_fi_isogenyEndDatum D₁),
+    Divisor.degree_pullbackAlong D₂.ι D₂.hι (es1a3_fi_isogenyEndDatum D₂), hE]
+  ring
+
+omit [IsAlgClosed F] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_dcao_defect_pullback_placeOfPoint_apply_of_unramified
+    (D₁ D₂ D₃ : IsogenyEndDatum W)
+    (h1 : IsogenyEndDatum.kw_ipfd_unramified D₁)
+    (h2 : IsogenyEndDatum.kw_ipfd_unramified D₂)
+    (h3 : IsogenyEndDatum.kw_ipfd_unramified D₃)
+    (Q P : W.Point) :
+    (Divisor.pullbackAlong D₃.ι D₃.hι (Finsupp.single (placeOfPoint Q) 1)
+        - Divisor.pullbackAlong D₁.ι D₁.hι (Finsupp.single (placeOfPoint Q) 1)
+        - Divisor.pullbackAlong D₂.ι D₂.hι (Finsupp.single (placeOfPoint Q) 1))
+      (placeOfPoint P)
+      = (if D₃.geomMorph P = Q then 1 else 0)
+        - (if D₁.geomMorph P = Q then 1 else 0)
+        - (if D₂.geomMorph P = Q then 1 else 0) := by
+  rw [Finsupp.sub_apply, Finsupp.sub_apply,
+    IsogenyEndDatum.kw_ipfd_pullbackAlong_single_placeOfPoint_apply_of_unramified
+      D₃ h3 Q P,
+    IsogenyEndDatum.kw_ipfd_pullbackAlong_single_placeOfPoint_apply_of_unramified
+      D₁ h1 Q P,
+    IsogenyEndDatum.kw_ipfd_pullbackAlong_single_placeOfPoint_apply_of_unramified
+      D₂ h2 Q P]
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_dcao_compDatum_degree (D₁ D₂ : IsogenyEndDatum W) :
+    (IsogenyEndDatum.compDatum W D₁ D₂).degree = D₁.degree * D₂.degree := by
+  change finrankAlong F (IsogenyEndDatum.compDatum W D₁ D₂).ι
+    = finrankAlong F D₁.ι * finrankAlong F D₂.ι
+  rw [IsogenyEndDatum.compDatum_ι, finrankAlong_comp]
+
+theorem kw_dcao_dual_comp (D₁ D₂ : IsogenyEndDatum W) :
+    kw_dualPointEnd (IsogenyEndDatum.compDatum W D₁ D₂)
+      = kw_dualPointEnd D₂ * kw_dualPointEnd D₁ := by
+  refine (kw_dualPointEnd_unique (IsogenyEndDatum.compDatum W D₁ D₂) _ ?_).symm
+  rw [es1a3_compDatum_pointEnd,
+    show (((IsogenyEndDatum.compDatum W D₁ D₂).degree : ℤ) : AddMonoid.End W.Point)
+      = ((D₂.degree : ℤ) : AddMonoid.End W.Point)
+          * ((D₁.degree : ℤ) : AddMonoid.End W.Point) by
+      rw [kw_dcao_compDatum_degree, Nat.cast_mul, Int.cast_mul]
+      exact Int.cast_comm _ _]
+  calc D₁.pointEnd' * D₂.pointEnd' * (kw_dualPointEnd D₂ * kw_dualPointEnd D₁)
+      = D₁.pointEnd' * (D₂.pointEnd' * kw_dualPointEnd D₂) * kw_dualPointEnd D₁ := by
+        rw [mul_assoc, mul_assoc, mul_assoc]
+    _ = D₁.pointEnd' * ((D₂.degree : ℤ) : AddMonoid.End W.Point)
+          * kw_dualPointEnd D₁ := by rw [kw_pointEnd_mul_dualPointEnd D₂]
+    _ = ((D₂.degree : ℤ) : AddMonoid.End W.Point)
+          * (D₁.pointEnd' * kw_dualPointEnd D₁) := by
+        rw [← Int.cast_comm, mul_assoc]
+    _ = ((D₂.degree : ℤ) : AddMonoid.End W.Point)
+          * ((D₁.degree : ℤ) : AddMonoid.End W.Point) := by
+        rw [kw_pointEnd_mul_dualPointEnd D₁]
+
+variable (W) in
+def KwDCAODefectPrincipalPerPoint : Prop :=
+  ∀ D₁ D₂ D₃ : IsogenyEndDatum W,
+    (∀ P, D₃.geomMorph P = D₁.geomMorph P + D₂.geomMorph P) →
+      D₁.ι (polyToFunctionField W X) ≠ D₂.ι (polyToFunctionField W X) →
+        ∀ L : W.Point, Divisor.IsPrincipal
+          (Divisor.pullbackAlong D₃.ι D₃.hι
+              (pointDivisor L : AlgebraicCurve.Divisor F W.FunctionField)
+            - (Divisor.pullbackAlong D₁.ι D₁.hι
+                  (pointDivisor L : AlgebraicCurve.Divisor F W.FunctionField)
+                + Divisor.pullbackAlong D₂.ι D₂.hι
+                  (pointDivisor L : AlgebraicCurve.Divisor F W.FunctionField)))
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_dcao_ext_of_iota_eq {D₁ D₂ : IsogenyEndDatum W} (h : D₁.ι = D₂.ι) :
+    D₁ = D₂ := by
+  cases D₁; cases D₂
+  simp only [IsogenyEndDatum.mk.injEq] at h ⊢
+  exact h
+
+theorem kw_dcao_geomMorphDualAdditivity_of_defectPrincipal
+    (hdef : KwDCAODefectPrincipalPerPoint W) :
+    KwDCAOGeomMorphDualAdditivity W := by
+  intro D₁ D₂ D₃ hgm
+  have hpe : D₃.pointEnd' = D₁.pointEnd' + D₂.pointEnd' :=
+    kw_dcao_pointEnd_add_of_geomMorph_add hgm
+  by_cases hX : D₁.ι (polyToFunctionField W X) = D₂.ι (polyToFunctionField W X)
+  · have heq₁ := es1a8_add_equation_cmp W D₁.ι
+    have heq₂ := es1a8_add_equation_cmp W D₂.ι
+    by_cases hneg : D₁.ι (yGen W)
+        = (W.map (algebraMap F W.FunctionField)).toAffine.negY
+            (D₂.ι (polyToFunctionField W X)) (D₂.ι (yGen W))
+    · have hcol : es1a8_addCollapse_cmp W D₁.ι D₂.ι := ⟨hX, hneg⟩
+      exact absurd (hpe.trans (es1a8_addCollapse_pointEnd_add_eq_zero_cmp D₁ D₂ hcol))
+        (kw_pointEnd_ne_zero D₃)
+    · have hY : D₁.ι (yGen W) = D₂.ι (yGen W) := Y_eq_of_Y_ne heq₁ heq₂ hX hneg
+      have hDeq : D₁ = D₂ :=
+        kw_dcao_ext_of_iota_eq (es1a8_functionField_algHom_ext_cmp hX hY)
+      subst hDeq
+      have h2cast : ((2 : ℤ) : AddMonoid.End W.Point) = 1 + 1 := by norm_num
+      have h2ne : (IsogenyEndDatum.idDatum W).pointEnd'
+          + (IsogenyEndDatum.idDatum W).pointEnd' ≠ 0 := by
+        rw [IsogenyEndDatum.idDatum_pointEnd, one_add_one_eq_two]
+        have := kw_charZero_end_point (W := W)
+        exact two_ne_zero
+      obtain ⟨DN, hDNgm⟩ := kw_hk5f_addGeomMorphSupply_proved W
+        (IsogenyEndDatum.idDatum W) (IsogenyEndDatum.idDatum W) h2ne
+      have hDN2 : DN.pointEnd' = ((2 : ℤ) : AddMonoid.End W.Point) := by
+        have h := kw_dcao_pointEnd_add_of_geomMorph_add hDNgm
+        rw [IsogenyEndDatum.idDatum_pointEnd] at h
+        rw [h, h2cast]
+      have hCpe : (IsogenyEndDatum.compDatum W DN D₁).pointEnd' = D₃.pointEnd' := by
+        rw [es1a3_compDatum_pointEnd, hDN2, hpe, h2cast, add_mul, one_mul]
+      rw [kw_dualPointEnd_eq_of_pointEnd_eq hCpe.symm, kw_dcao_dual_comp,
+        kw_dualPointEnd_of_pointEnd_intCast DN 2 hDN2, h2cast, mul_add, mul_one]
+  · refine DFunLike.ext _ _ fun Q => ?_
+    change kw_dualPointEnd D₃ Q = kw_dualPointEnd D₁ Q + kw_dualPointEnd D₂ Q
+    have hE : Divisor.degree
+        (pointDivisor Q : AlgebraicCurve.Divisor F W.FunctionField) = 0 :=
+      Divisor.mem_degZero.mp (pointDivisor Q).2
+    have h0 : divisorSum
+        (Divisor.pullbackAlong D₃.ι D₃.hι
+            (pointDivisor Q : AlgebraicCurve.Divisor F W.FunctionField)
+          - (Divisor.pullbackAlong D₁.ι D₁.hι
+                (pointDivisor Q : AlgebraicCurve.Divisor F W.FunctionField)
+              + Divisor.pullbackAlong D₂.ι D₂.hι
+                (pointDivisor Q : AlgebraicCurve.Divisor F W.FunctionField))) = 0 :=
+      divisorSum_eq_zero_of_isPrincipal
+        (kw_dcao_defect_degree_zero D₁ D₂ D₃ _ hE) (hdef D₁ D₂ D₃ hgm hX Q)
+    rw [map_sub, map_add, kw_dcao_divisorSum_pullbackAlong D₃ _ hE,
+      kw_dcao_divisorSum_pullbackAlong D₁ _ hE,
+      kw_dcao_divisorSum_pullbackAlong D₂ _ hE,
+      divisorSum_pointDivisor, sub_eq_zero] at h0
+    exact h0
+
+theorem kw_dcao_htw_of_defectPrincipal (hdef : KwDCAODefectPrincipalPerPoint W) :
+    KwDualTraceWitness W :=
+  kw_dcao_htw_of_geomMorphDualAdditivity
+    (kw_dcao_geomMorphDualAdditivity_of_defectPrincipal hdef)
+
+end GeneralW
+end Affine
+end WeierstrassCurve
+end
+end
+
+section
+
+section
+
+open ModularCurve.Es1a1
+open ModularCurve.Mmr73
+namespace WeierstrassCurve
+namespace Affine
+universe u
+
+section GeneralW
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+attribute [local instance] ModularCurve.Es1a1.instDecEqFunctionFieldEs1a6Add
+
+abbrev kw_dcao_lineSlope (D₁ D₂ : IsogenyEndDatum W) : W.FunctionField :=
+  (W.map (algebraMap F W.FunctionField)).toAffine.slope
+    (D₁.ι (polyToFunctionField W X)) (D₂.ι (polyToFunctionField W X))
+    (D₁.ι (yGen W)) (D₂.ι (yGen W))
+
+abbrev kw_dcao_lineIntercept (D₁ D₂ : IsogenyEndDatum W) : W.FunctionField :=
+  D₁.ι (yGen W) - kw_dcao_lineSlope D₁ D₂ * D₁.ι (polyToFunctionField W X)
+
+abbrev kw_dcao_specVert (D₁ D₂ : IsogenyEndDatum W) (a : F) : W.FunctionField :=
+  algebraMap F W.FunctionField a - es1a6_addSumX W D₁.ι D₂.ι
+
+abbrev kw_dcao_specLine (D₁ D₂ : IsogenyEndDatum W) (a b : F) : W.FunctionField :=
+  algebraMap F W.FunctionField b
+    - kw_dcao_lineSlope D₁ D₂ * algebraMap F W.FunctionField a
+    - kw_dcao_lineIntercept D₁ D₂
+
+theorem kw_dcao_addSumX_nonconst_of_hgm (D₁ D₂ D₃ : IsogenyEndDatum W)
+    (hgm : ∀ P, D₃.geomMorph P = D₁.geomMorph P + D₂.geomMorph P) (c : F) :
+    es1a6_addSumX W D₁.ι D₂.ι ≠ algebraMap F W.FunctionField c :=
+  kw_hk5f_addSumXNonConstGuardAt_proved W D₁ D₂
+    ((kw_dcao_pointEnd_add_of_geomMorph_add hgm) ▸ kw_pointEnd_ne_zero D₃) c
+
+theorem kw_dcao_specVert_ne_zero_of_hgm (D₁ D₂ D₃ : IsogenyEndDatum W)
+    (hgm : ∀ P, D₃.geomMorph P = D₁.geomMorph P + D₂.geomMorph P) (a : F) :
+    kw_dcao_specVert D₁ D₂ a ≠ 0 :=
+  fun hV => kw_dcao_addSumX_nonconst_of_hgm D₁ D₂ D₃ hgm a (sub_eq_zero.mp hV).symm
+
+theorem kw_dcao_sumDatum_of_hgm (D₁ D₂ D₃ : IsogenyEndDatum W)
+    (hgm : ∀ P, D₃.geomMorph P = D₁.geomMorph P + D₂.geomMorph P)
+    (hX : D₁.ι (polyToFunctionField W X) ≠ D₂.ι (polyToFunctionField W X)) :
+    ∃ Ds : IsogenyEndDatum W,
+      Ds.ι (polyToFunctionField W X) = es1a6_addSumX W D₁.ι D₂.ι
+      ∧ ∀ P, Ds.geomMorph P = D₁.geomMorph P + D₂.geomMorph P := by
+  have hnc := kw_dcao_addSumX_nonconst_of_hgm D₁ D₂ D₃ hgm
+  have hcol : ¬ es1a6_addCollapse W D₁.ι D₂.ι :=
+    es1a6_add_not_collapse_of_X_ne W D₁.ι D₂.ι hX
+  have htr : Function.Injective
+      (Polynomial.aeval (R := F) (es1a6_addSumX W D₁.ι D₂.ι)) :=
+    es1a6_add_aeval_sumX_injective_of_forall_ne W D₁.ι D₂.ι hnc
+  obtain ⟨hι, hfin⟩ := kw_hk5f_addIntegralFiniteDataAt_proved W D₁ D₂ hcol htr
+  refine ⟨⟨es1a6_addSumPullbackHom W D₁.ι D₂.ι hcol htr, hι, hfin⟩,
+    es1a6_addSumPullbackHom_X W D₁.ι D₂.ι hcol htr, fun P => ?_⟩
+  have h1 := kw_coordSeamDataAt_geomMorph D₁ P
+  have h2 := kw_coordSeamDataAt_geomMorph D₂ P
+  have hsum := kw_hk5f_addSumCoordSeamDataNCAt_proved W D₁.ι D₂.ι hcol hnc
+    (placeOfPoint P) (D₁.geomMorph P) (D₂.geomMorph P) h1 h2
+  have hseam := es1a6_addSumSeam_of_data D₁.ι D₂.ι hcol htr hι P
+    (D₁.geomMorph P + D₂.geomMorph P) hsum
+  exact placeOfPoint_injective
+    (((⟨_, hι, hfin⟩ : IsogenyEndDatum W).placeOfPoint_geomMorph P).symm.trans hseam)
+
+theorem kw_dcao_ord_Dtransport (D : IsogenyEndDatum W) (f : W.FunctionField)
+    (P : W.Point) :
+    (placeOfPoint P).ord (D.ι f) = (placeOfPoint (D.geomMorph P)).ord f := by
+  rw [(placeOfPoint P).ord_restrictAlong D.ι D.hι,
+    kw_dcao_unramified_proved D P, Nat.cast_one, one_mul,
+    D.placeOfPoint_geomMorph P]
+
+theorem kw_dcao_ord_specVert_eq_transport (D₁ D₂ D₃ : IsogenyEndDatum W)
+    (hgm : ∀ P, D₃.geomMorph P = D₁.geomMorph P + D₂.geomMorph P)
+    (hX : D₁.ι (polyToFunctionField W X) ≠ D₂.ι (polyToFunctionField W X))
+    (a : F) (P : W.Point) :
+    (placeOfPoint P).ord (kw_dcao_specVert D₁ D₂ a)
+      = (placeOfPoint (D₁.geomMorph P + D₂.geomMorph P)).ord
+          (algebraMap F W.FunctionField a - polyToFunctionField W X) := by
+  obtain ⟨Ds, hXs, hgms⟩ := kw_dcao_sumDatum_of_hgm D₁ D₂ D₃ hgm hX
+  have hsp : kw_dcao_specVert D₁ D₂ a
+      = Ds.ι (algebraMap F W.FunctionField a - polyToFunctionField W X) := by
+    change algebraMap F W.FunctionField a - es1a6_addSumX W D₁.ι D₂.ι = _
+    rw [map_sub, Ds.ι.commutes, hXs]
+  rw [hsp, kw_dcao_ord_Dtransport Ds, hgms P]
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_dcao_specLine_negY_product (D₁ D₂ : IsogenyEndDatum W)
+    (hX : D₁.ι (polyToFunctionField W X) ≠ D₂.ι (polyToFunctionField W X))
+    {a b : F} (h : W.Nonsingular a b) :
+    kw_dcao_specLine D₁ D₂ a b
+        * kw_dcao_specLine D₁ D₂ a (W.toAffine.negY a b)
+      = -((algebraMap F W.FunctionField a - D₁.ι (polyToFunctionField W X))
+          * (algebraMap F W.FunctionField a - D₂.ι (polyToFunctionField W X))
+          * kw_dcao_specVert D₁ D₂ a) := by
+  set x₁ := D₁.ι (polyToFunctionField W X) with hx₁
+  set x₂ := D₂.ι (polyToFunctionField W X) with hx₂
+  set y₁ := D₁.ι (yGen W) with hy₁
+  set y₂ := D₂.ι (yGen W) with hy₂
+  have hE₁ := es1a6_add_equation W D₁.ι
+  have hE₂ := es1a6_add_equation W D₂.ι
+  simp only [← hx₁, ← hx₂, ← hy₁, ← hy₂] at hE₁ hE₂
+  have hxy : ¬(x₁ = x₂ ∧ y₁
+      = (W.map (algebraMap F W.FunctionField)).toAffine.negY x₂ y₂) :=
+    fun ⟨hx, _⟩ => hX hx
+  have haps := addPolynomial_slope hE₁ hE₂ hxy
+  have hcap := (W.map (algebraMap F W.FunctionField)).toAffine.C_addPolynomial
+      x₁ y₁ (kw_dcao_lineSlope D₁ D₂)
+  rw [show kw_dcao_lineSlope D₁ D₂
+    = (W.map (algebraMap F W.FunctionField)).toAffine.slope x₁ x₂ y₁ y₂ from rfl,
+    haps] at hcap
+  have heval := congrArg
+    (Polynomial.evalEval (algebraMap F W.FunctionField a)
+      (algebraMap F W.FunctionField b)) hcap
+  have hEab : (W.map (algebraMap F W.FunctionField)).toAffine.Equation
+        (algebraMap F W.FunctionField a) (algebraMap F W.FunctionField b) := by
+    have := h.1
+    rw [Affine.equation_iff] at this ⊢
+    simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+      WeierstrassCurve.map_a₄, WeierstrassCurve.map_a₆]
+    exact_mod_cast congrArg (algebraMap F W.FunctionField) this
+  simp only [Polynomial.evalEval_C, Polynomial.eval_neg,
+    Polynomial.eval_mul, Polynomial.eval_sub, Polynomial.eval_X, Polynomial.eval_C,
+    Polynomial.evalEval_add, Polynomial.evalEval_mul, Polynomial.evalEval_sub,
+    Affine.evalEval_negPolynomial,
+    show (W.map (algebraMap F W.FunctionField)).toAffine.polynomial.evalEval
+          (algebraMap F W.FunctionField a) (algebraMap F W.FunctionField b) = 0 from hEab,
+    add_zero, linePolynomial, Polynomial.eval_add, Polynomial.evalEval_X] at heval
+  have hsl : kw_dcao_lineSlope D₁ D₂
+      = (W.map (algebraMap F W.FunctionField)).toAffine.slope x₁ x₂ y₁ y₂ := rfl
+  have hint : kw_dcao_lineIntercept D₁ D₂ = y₁ - kw_dcao_lineSlope D₁ D₂ * x₁ := rfl
+  have hnegY : (W.map (algebraMap F W.FunctionField)).toAffine.negY
+          (algebraMap F W.FunctionField a) (algebraMap F W.FunctionField b)
+      = algebraMap F W.FunctionField (W.toAffine.negY a b) := by
+    simp only [Affine.negY, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₃, map_sub,
+      _root_.map_neg, map_mul]
+  change (_ - _ * _ - kw_dcao_lineIntercept D₁ D₂)
+    * (_ - _ * _ - kw_dcao_lineIntercept D₁ D₂)
+    = -((_ - x₁) * (_ - x₂) * (_ - es1a6_addSumX W D₁.ι D₂.ι))
+  rw [hint, hsl, show es1a6_addSumX W D₁.ι D₂.ι
+    = (W.map (algebraMap F W.FunctionField)).toAffine.addX x₁ x₂
+        ((W.map (algebraMap F W.FunctionField)).toAffine.slope x₁ x₂ y₁ y₂) from rfl,
+    ← hnegY]
+  linear_combination heval.symm
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_dcao_algebraMap_sub_X_ne_zero (a : F) :
+    algebraMap F W.FunctionField a - polyToFunctionField W X ≠ 0 := by
+  rw [sub_ne_zero, ← polyToFunctionField_C]
+  exact fun hc => X_ne_C a (polyToFunctionField_injective hc).symm
+
+theorem kw_dcao_specLine_ne_zero_of_hgm (D₁ D₂ D₃ : IsogenyEndDatum W)
+    (hgm : ∀ P, D₃.geomMorph P = D₁.geomMorph P + D₂.geomMorph P)
+    (hX : D₁.ι (polyToFunctionField W X) ≠ D₂.ι (polyToFunctionField W X))
+    {a b : F} (h : W.Nonsingular a b) :
+    kw_dcao_specLine D₁ D₂ a b ≠ 0 := by
+  intro hL
+  have hprod := kw_dcao_specLine_negY_product D₁ D₂ hX h
+  rw [hL, zero_mul, eq_comm, neg_eq_zero] at hprod
+  have h1 : algebraMap F W.FunctionField a - D₁.ι (polyToFunctionField W X) ≠ 0 := by
+    rw [show algebraMap F W.FunctionField a = D₁.ι (algebraMap F W.FunctionField a) from
+        (D₁.ι.commutes a).symm, ← map_sub]
+    exact mmr73_cs_iota_ne_zero D₁ (kw_dcao_algebraMap_sub_X_ne_zero a)
+  have h2 : algebraMap F W.FunctionField a - D₂.ι (polyToFunctionField W X) ≠ 0 := by
+    rw [show algebraMap F W.FunctionField a = D₂.ι (algebraMap F W.FunctionField a) from
+        (D₂.ι.commutes a).symm, ← map_sub]
+    exact mmr73_cs_iota_ne_zero D₂ (kw_dcao_algebraMap_sub_X_ne_zero a)
+  exact (mul_ne_zero (mul_ne_zero h1 h2)
+    (kw_dcao_specVert_ne_zero_of_hgm D₁ D₂ D₃ hgm a)) hprod
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_dcao_specLine_negY_diff (D₁ D₂ : IsogenyEndDatum W) (a b : F) :
+    kw_dcao_specLine D₁ D₂ a b - kw_dcao_specLine D₁ D₂ a (W.toAffine.negY a b)
+      = algebraMap F W.FunctionField (b - W.toAffine.negY a b) := by
+  change (_ - _ - _) - (_ - _ - _) = _
+  rw [map_sub]; ring
+
+theorem kw_dcao_specLine_ord_sum (D₁ D₂ D₃ : IsogenyEndDatum W)
+    (hgm : ∀ P, D₃.geomMorph P = D₁.geomMorph P + D₂.geomMorph P)
+    (hX : D₁.ι (polyToFunctionField W X) ≠ D₂.ι (polyToFunctionField W X))
+    {a b : F} (h : W.Nonsingular a b) (P : W.Point) :
+    (placeOfPoint P).ord (kw_dcao_specLine D₁ D₂ a b)
+        + (placeOfPoint P).ord (kw_dcao_specLine D₁ D₂ a (W.toAffine.negY a b))
+      = (placeOfPoint (D₁.geomMorph P)).ord
+            (algebraMap F W.FunctionField a - polyToFunctionField W X)
+        + (placeOfPoint (D₂.geomMorph P)).ord
+            (algebraMap F W.FunctionField a - polyToFunctionField W X)
+        + (placeOfPoint (D₁.geomMorph P + D₂.geomMorph P)).ord
+            (algebraMap F W.FunctionField a - polyToFunctionField W X) := by
+  have hLne := kw_dcao_specLine_ne_zero_of_hgm D₁ D₂ D₃ hgm hX h
+  have hL'ne' : kw_dcao_specLine D₁ D₂ a (W.toAffine.negY a b) ≠ 0 :=
+    kw_dcao_specLine_ne_zero_of_hgm D₁ D₂ D₃ hgm hX ((Affine.nonsingular_neg a b).mpr h)
+  have hprod := kw_dcao_specLine_negY_product D₁ D₂ hX h
+  have h1 : algebraMap F W.FunctionField a - D₁.ι (polyToFunctionField W X)
+      = D₁.ι (algebraMap F W.FunctionField a - polyToFunctionField W X) := by
+    rw [map_sub, D₁.ι.commutes]
+  have h2 : algebraMap F W.FunctionField a - D₂.ι (polyToFunctionField W X)
+      = D₂.ι (algebraMap F W.FunctionField a - polyToFunctionField W X) := by
+    rw [map_sub, D₂.ι.commutes]
+  have h1ne : algebraMap F W.FunctionField a - D₁.ι (polyToFunctionField W X) ≠ 0 :=
+    h1 ▸ mmr73_cs_iota_ne_zero D₁ (kw_dcao_algebraMap_sub_X_ne_zero a)
+  have h2ne : algebraMap F W.FunctionField a - D₂.ι (polyToFunctionField W X) ≠ 0 :=
+    h2 ▸ mmr73_cs_iota_ne_zero D₂ (kw_dcao_algebraMap_sub_X_ne_zero a)
+  have hVne := kw_dcao_specVert_ne_zero_of_hgm D₁ D₂ D₃ hgm a
+  rw [← (placeOfPoint P).ord_mul hLne hL'ne', hprod,
+    mmr73_cs_ord_neg (placeOfPoint P),
+    (placeOfPoint P).ord_mul (mul_ne_zero h1ne h2ne) hVne,
+    (placeOfPoint P).ord_mul h1ne h2ne, h1, h2,
+    kw_dcao_ord_Dtransport D₁, kw_dcao_ord_Dtransport D₂,
+    kw_dcao_ord_specVert_eq_transport D₁ D₂ D₃ hgm hX a P]
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_dcao_algebraMap_XClass (a : F) :
+    algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.XClass W a)
+      = polyToFunctionField W X - algebraMap F W.FunctionField a := by
+  rw [show polyToFunctionField W X - algebraMap F W.FunctionField a
+    = polyToFunctionField W (X - C a) by rw [map_sub, polyToFunctionField_C],
+    polyToFunctionField_apply, CoordinateRing.XClass, algebraMap_polynomial_eq_mk_C]
+
+omit [DecidableEq F] [CharZero F] [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W]
+  [W.AbelTheorem] in
+theorem kw_dcao_ord_XsubA_eq_one {a b : F} (h : W.Nonsingular a b)
+    (hY : W.toAffine.polynomialY.evalEval a b ≠ 0) :
+    (placeOfEquation h.left).ord
+      (polyToFunctionField W X - algebraMap F W.FunctionField a) = 1 := by
+  rw [← kw_dcao_algebraMap_XClass a]
+  exact ord_placeOfEquation_XClass_self h.left hY
+
+omit [DecidableEq F] [CharZero F] [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W]
+  [W.AbelTheorem] in
+theorem kw_dcao_ord_XsubA_eq_two {a b : F} (h : W.Nonsingular a b)
+    (hY : W.toAffine.polynomialY.evalEval a b = 0) :
+    (placeOfEquation h.left).ord
+      (polyToFunctionField W X - algebraMap F W.FunctionField a) = 2 := by
+  set q : F[X] := X ^ 2 + C (a + W.a₂) * X + C (a ^ 2 + W.a₂ * a + W.a₄) with hq
+  have hFFeq : yGen W ^ 2 + algebraMap F W.FunctionField W.a₁
+          * polyToFunctionField W X * yGen W
+        + algebraMap F W.FunctionField W.a₃ * yGen W
+      = polyToFunctionField W X ^ 3
+        + algebraMap F W.FunctionField W.a₂ * polyToFunctionField W X ^ 2
+        + algebraMap F W.FunctionField W.a₄ * polyToFunctionField W X
+        + algebraMap F W.FunctionField W.a₆ := by
+    have heq := es1a6_add_equation W (AlgHom.id F W.FunctionField)
+    rw [Affine.equation_iff] at heq
+    simp only [AlgHom.id_apply, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂,
+      WeierstrassCurve.map_a₃,
+      WeierstrassCurve.map_a₄, WeierstrassCurve.map_a₆] at heq
+    linear_combination heq
+  have hab : b ^ 2 + W.a₁ * a * b + W.a₃ * b
+      = a ^ 3 + W.a₂ * a ^ 2 + W.a₄ * a + W.a₆ := by
+    have heq := h.left; rw [Affine.equation_iff] at heq; linear_combination heq
+  have h2b : (2 : F) * b + W.a₁ * a + W.a₃ = 0 := by
+    have := hY; rw [Affine.evalEval_polynomialY] at this; linear_combination this
+  have hprod : (yGen W - algebraMap F W.FunctionField b) ^ 2
+      = (polyToFunctionField W X - algebraMap F W.FunctionField a)
+        * (polyToFunctionField W q
+            - algebraMap F W.FunctionField W.a₁ * yGen W) := by
+    rw [hq]
+    simp only [map_add, map_mul, map_pow, polyToFunctionField_C]
+    have hcab := congrArg (algebraMap F W.FunctionField) hab
+    simp only [map_add, map_mul, map_pow] at hcab
+    have hc2b := congrArg (algebraMap F W.FunctionField) h2b
+    simp only [map_add, map_mul, _root_.map_zero, map_ofNat] at hc2b
+    linear_combination hFFeq - hcab - (yGen W - algebraMap F W.FunctionField b) * hc2b
+  have hYb : (placeOfEquation h.left).ord
+      (yGen W - algebraMap F W.FunctionField b) = 1 := by
+    have hbr : algebraMap W.CoordinateRing W.FunctionField
+        (CoordinateRing.YClass W (C b))
+        = yGen W - algebraMap F W.FunctionField b := by
+      rw [CoordinateRing.YClass, map_sub, ← algebraMap_polynomial_eq_mk_C, map_sub,
+        ← polyToFunctionField_apply, polyToFunctionField_C]; rfl
+    rw [← hbr]
+    exact ord_placeOfEquation_YClass_self h.left hY
+  have hYbne : yGen W - algebraMap F W.FunctionField b ≠ 0 := fun hc => by
+    rw [hc, (placeOfEquation h.left).ord_zero] at hYb; exact one_ne_zero hYb.symm
+  set q' : F[X] := q - C (W.a₁ * b) with hq'
+  have hq'a : q'.eval a ≠ 0 := by
+    have hns := h.2.resolve_right (not_not.mpr hY)
+    rw [Affine.evalEval_polynomialX] at hns
+    intro hc
+    simp only [hq', hq, eval_sub, eval_add, eval_mul, eval_pow, eval_X, eval_C] at hc
+    exact hns (by linear_combination -hc)
+  have hq'ne : q' ≠ 0 := fun hc => hq'a (by rw [hc, eval_zero])
+  have hoq' : (placeOfEquation h.left).ord (polyToFunctionField W q') = 0 :=
+    (ord_polyToFunctionField_eq_zero_iff h.left hq'ne).mpr hq'a
+  have hrsplit : polyToFunctionField W q - algebraMap F W.FunctionField W.a₁ * yGen W
+      = polyToFunctionField W q'
+        + (- algebraMap F W.FunctionField W.a₁)
+            * (yGen W - algebraMap F W.FunctionField b) := by
+    rw [hq', map_sub, polyToFunctionField_C, map_mul]; ring
+  have hor : (placeOfEquation h.left).ord
+      (polyToFunctionField W q - algebraMap F W.FunctionField W.a₁ * yGen W) = 0 := by
+    by_cases ha1 : W.a₁ = 0
+    · rw [ha1, _root_.map_zero, zero_mul, sub_zero,
+        show q = q' by rw [hq', ha1, zero_mul, C_0, sub_zero]]
+      exact hoq'
+    · rw [hrsplit,
+        (placeOfEquation h.left).ord_add_eq_min
+          (polyToFunctionField_ne_zero hq'ne)
+          (mul_ne_zero (neg_ne_zero.mpr
+            ((map_ne_zero_iff _ (algebraMap F W.FunctionField).injective).mpr ha1)) hYbne)
+          (by
+            rw [hoq', (placeOfEquation h.left).ord_mul
+              (neg_ne_zero.mpr
+                ((map_ne_zero_iff _ (algebraMap F W.FunctionField).injective).mpr ha1))
+              hYbne, mmr73_cs_ord_neg, AlgebraicCurve.Place.ord_algebraMap (placeOfEquation h.left),
+              zero_add,
+              hYb]
+            exact zero_ne_one),
+        hoq', (placeOfEquation h.left).ord_mul
+          (neg_ne_zero.mpr
+            ((map_ne_zero_iff _ (algebraMap F W.FunctionField).injective).mpr ha1))
+          hYbne, mmr73_cs_ord_neg, AlgebraicCurve.Place.ord_algebraMap (placeOfEquation h.left),
+            zero_add, hYb]
+      exact min_eq_left zero_le_one
+  have hrne : polyToFunctionField W q - algebraMap F W.FunctionField W.a₁ * yGen W ≠ 0 := by
+    intro hc
+    exact hYbne (pow_eq_zero_iff two_ne_zero |>.mp (by rw [hprod, hc, mul_zero]))
+  have hXane : polyToFunctionField W X - algebraMap F W.FunctionField a ≠ 0 := by
+    rw [← neg_sub, neg_ne_zero]; exact kw_dcao_algebraMap_sub_X_ne_zero a
+  have hord := congrArg (placeOfEquation h.left).ord hprod
+  rw [show (yGen W - algebraMap F W.FunctionField b) ^ 2
+      = (yGen W - algebraMap F W.FunctionField b)
+        * (yGen W - algebraMap F W.FunctionField b) from sq _,
+    (placeOfEquation h.left).ord_mul hYbne hYbne,
+    (placeOfEquation h.left).ord_mul hXane hrne, hor, add_zero, hYb] at hord
+  linarith [hord]
+
+omit [CharZero F] [W.AbelTheorem] in
+theorem kw_dcao_ord_aSubX_formula {a b : F} (h : W.Nonsingular a b) (Q : W.Point) :
+    (placeOfPoint Q).ord (algebraMap F W.FunctionField a - polyToFunctionField W X)
+      = (if Q = Point.some a b h then 1 else 0)
+        + (if Q = -Point.some a b h then 1 else 0)
+        - 2 * (if Q = 0 then 1 else 0) := by
+  rw [show algebraMap F W.FunctionField a - polyToFunctionField W X
+    = -(polyToFunctionField W X - algebraMap F W.FunctionField a) by ring,
+    mmr73_cs_ord_neg, Point.neg_some h,
+    show polyToFunctionField W X - algebraMap F W.FunctionField a
+      = polyToFunctionField W (X - C a) by rw [map_sub, polyToFunctionField_C]]
+  rcases Q with _ | ⟨r, s, h'⟩
+  · rw [show (Point.zero : W.Point) = 0 from rfl,
+      ite_eq_right (Point.some_ne_zero h).symm,
+      ite_eq_right (Point.some_ne_zero ((Affine.nonsingular_neg a b).mpr h)).symm,
+      ite_eq_left rfl,
+      show placeOfPoint (0 : W.Point) = InfinitePlace.place from rfl,
+      (InfinitePlace.place (W := W)).ord_ringHom_eq_natDegree_mul
+        polyToFunctionField_injective polyToFunctionField_C
+        (ord_X_neg_of_not_isFinitePlace _ InfinitePlace.not_isFinitePlace)
+        (X_sub_C_ne_zero a),
+      natDegree_X_sub_C,
+      ord_X_eq_neg_two_of_not_isFinitePlace _ InfinitePlace.not_isFinitePlace]
+    ring
+  · simp only [placeOfPoint_some h', ite_eq_right (Point.some_ne_zero h'), mul_zero, sub_zero,
+      Point.some.injEq]
+    by_cases hra : r = a
+    · subst r
+      have hsb : s = b ∨ s = W.toAffine.negY a b :=
+        Y_eq_of_X_eq h'.left h.left rfl
+      simp only [true_and]
+      rw [show polyToFunctionField W (X - C a)
+        = polyToFunctionField W X - algebraMap F W.FunctionField a by
+          rw [map_sub, polyToFunctionField_C]]
+      by_cases hYs : W.toAffine.polynomialY.evalEval a s = 0
+      · rw [kw_dcao_ord_XsubA_eq_two h' hYs]
+        have hss : s = W.toAffine.negY a s := by
+          rw [Affine.evalEval_polynomialY] at hYs
+          unfold Affine.negY; linear_combination hYs
+        rcases hsb with rfl | rfl
+        · rw [ite_eq_left rfl, ite_eq_left hss]; rfl
+        · rw [ite_eq_left (hss.trans (Affine.negY_negY a b)), ite_eq_left rfl]; rfl
+      · rw [kw_dcao_ord_XsubA_eq_one h' hYs]
+        have hbne : b ≠ W.toAffine.negY a b := by
+          intro hbb
+          apply hYs
+          have hseb : s = b := hsb.elim id (fun hs => hs.trans hbb.symm)
+          subst hseb
+          rw [Affine.evalEval_polynomialY]
+          have hbb' := hbb; unfold Affine.negY at hbb'
+          linear_combination hbb'
+        rcases hsb with rfl | rfl
+        · rw [ite_eq_left rfl, ite_eq_right hbne, add_zero]
+        · rw [ite_eq_right (Ne.symm hbne), ite_eq_left rfl, zero_add]
+    · simp only [hra, false_and, ite_false, add_zero]
+      exact (ord_polyToFunctionField_eq_zero_iff h'.left (X_sub_C_ne_zero a)).mpr
+        (by simp [sub_ne_zero, hra])
+
+variable (W) in
+def KwDCAOSpecLineOrdMatchHgm : Prop :=
+  ∀ D₁ D₂ D₃ : IsogenyEndDatum W,
+    (∀ P, D₃.geomMorph P = D₁.geomMorph P + D₂.geomMorph P) →
+    D₁.ι (polyToFunctionField W X) ≠ D₂.ι (polyToFunctionField W X) →
+      ∀ {a b : F} (h : W.Nonsingular a b),
+        kw_dcao_specLine D₁ D₂ a b ≠ 0 ∧
+          ∀ P : W.Point,
+            (placeOfPoint P).ord (kw_dcao_specLine D₁ D₂ a b)
+              = (placeOfPoint (D₁.geomMorph P + D₂.geomMorph P)).ord
+                  (algebraMap F W.FunctionField a - polyToFunctionField W X)
+                - (((if D₁.geomMorph P + D₂.geomMorph P = Point.some a b h then 1 else 0)
+                    - (if D₁.geomMorph P = Point.some a b h then 1 else 0)
+                    - (if D₂.geomMorph P = Point.some a b h then 1 else 0))
+                  - ((if D₁.geomMorph P + D₂.geomMorph P = 0 then 1 else 0)
+                    - (if D₁.geomMorph P = 0 then 1 else 0)
+                    - (if D₂.geomMorph P = 0 then 1 else 0)))
+
+variable (W) in
+def KwDCAOSpecLineOrdMatchAllAffine : Prop :=
+  ∀ D₁ D₂ D₃ : IsogenyEndDatum W,
+    (∀ P, D₃.geomMorph P = D₁.geomMorph P + D₂.geomMorph P) →
+    D₁.ι (polyToFunctionField W X) ≠ D₂.ι (polyToFunctionField W X) →
+      ∀ {a b : F} (h : W.Nonsingular a b),
+        ¬ b = W.toAffine.negY a b →
+          ∀ P : W.Point,
+            D₁.geomMorph P ≠ 0 → D₂.geomMorph P ≠ 0 →
+              D₁.geomMorph P + D₂.geomMorph P ≠ 0 →
+            (placeOfPoint P).ord (kw_dcao_specLine D₁ D₂ a b)
+              = (placeOfPoint (D₁.geomMorph P + D₂.geomMorph P)).ord
+                  (algebraMap F W.FunctionField a - polyToFunctionField W X)
+                - (((if D₁.geomMorph P + D₂.geomMorph P = Point.some a b h then 1 else 0)
+                    - (if D₁.geomMorph P = Point.some a b h then 1 else 0)
+                    - (if D₂.geomMorph P = Point.some a b h then 1 else 0))
+                  - ((if D₁.geomMorph P + D₂.geomMorph P = 0 then 1 else 0)
+                    - (if D₁.geomMorph P = 0 then 1 else 0)
+                    - (if D₂.geomMorph P = 0 then 1 else 0)))
+
+theorem kw_dcao_specLineOrdMatch_hgm_of_allAffine
+    (hAA : KwDCAOSpecLineOrdMatchAllAffine W) :
+    KwDCAOSpecLineOrdMatchHgm W := by
+  intro D₁ D₂ D₃ hgm hX a b h
+  refine ⟨kw_dcao_specLine_ne_zero_of_hgm D₁ D₂ D₃ hgm hX h, fun P => ?_⟩
+  have hLne := kw_dcao_specLine_ne_zero_of_hgm D₁ D₂ D₃ hgm hX h
+  have hL'ne : kw_dcao_specLine D₁ D₂ a (W.toAffine.negY a b) ≠ 0 :=
+    kw_dcao_specLine_ne_zero_of_hgm D₁ D₂ D₃ hgm hX ((Affine.nonsingular_neg a b).mpr h)
+  have hSum := kw_dcao_specLine_ord_sum D₁ D₂ D₃ hgm hX h P
+  rw [kw_dcao_ord_aSubX_formula h (D₁.geomMorph P),
+    kw_dcao_ord_aSubX_formula h (D₂.geomMorph P),
+    kw_dcao_ord_aSubX_formula h (D₁.geomMorph P + D₂.geomMorph P)] at hSum
+  rw [kw_dcao_ord_aSubX_formula h (D₁.geomMorph P + D₂.geomMorph P)]
+  set Q₁ := D₁.geomMorph P with hQ1def
+  set Q₂ := D₂.geomMorph P with hQ2def
+  set L := Point.some a b h with hLdef
+  set u := (placeOfPoint P).ord (kw_dcao_specLine D₁ D₂ a b) with hu
+  set v := (placeOfPoint P).ord (kw_dcao_specLine D₁ D₂ a (W.toAffine.negY a b)) with hv
+  set l₁ : ℤ := if Q₁ = L then 1 else 0 with hl1d
+  set m₁ : ℤ := if Q₁ = -L then 1 else 0 with hm1d
+  set e₁ : ℤ := if Q₁ = 0 then 1 else 0 with he1d
+  set l₂ : ℤ := if Q₂ = L then 1 else 0 with hl2d
+  set m₂ : ℤ := if Q₂ = -L then 1 else 0 with hm2d
+  set e₂ : ℤ := if Q₂ = 0 then 1 else 0 with he2d
+  set l₁₂ : ℤ := if Q₁ + Q₂ = L then 1 else 0 with hl12d
+  set m₁₂ : ℤ := if Q₁ + Q₂ = -L then 1 else 0 with hm12d
+  set e₁₂ : ℤ := if Q₁ + Q₂ = 0 then 1 else 0 with he12d
+  by_cases hκ : b = W.toAffine.negY a b
+  · have huveq : u = v := by rw [hu, hv, ← hκ]
+    have hLL : L = -L := by
+      rw [hLdef, Point.neg_some h]
+      simp only [Point.some.injEq, true_and]; exact hκ
+    have hmL1 : m₁ = l₁ := by rw [hm1d, hl1d, ← hLL]
+    have hmL2 : m₂ = l₂ := by rw [hm2d, hl2d, ← hLL]
+    have hmL12 : m₁₂ = l₁₂ := by rw [hm12d, hl12d, ← hLL]
+    omega
+  · have hκne : algebraMap F W.FunctionField (b - W.toAffine.negY a b) ≠ 0 :=
+      fun hc => hκ (sub_eq_zero.mp
+        ((algebraMap F W.FunctionField).injective (by rw [hc, _root_.map_zero])))
+    have hLneL' : L ≠ -L := fun hc => by
+      rw [hLdef, Point.neg_some h] at hc
+      simp only [Point.some.injEq, true_and] at hc; exact hκ hc
+    have hLne0 : L ≠ 0 := Point.some_ne_zero h
+    have hL'ne0 : -L ≠ 0 := neg_ne_zero.mpr hLne0
+    have hdiff := kw_dcao_specLine_negY_diff D₁ D₂ a b
+    have hκord : (placeOfPoint P).ord
+        (algebraMap F W.FunctionField (b - W.toAffine.negY a b)) = 0 :=
+      AlgebraicCurve.Place.ord_algebraMap (placeOfPoint P) _
+    have huv : u ≠ 0 → v = min u 0 := by
+      intro hune
+      have heq : kw_dcao_specLine D₁ D₂ a (W.toAffine.negY a b)
+          = kw_dcao_specLine D₁ D₂ a b
+            + -(algebraMap F W.FunctionField (b - W.toAffine.negY a b)) := by
+        rw [← hdiff]; ring
+      rw [hv, heq, (placeOfPoint P).ord_add_eq_min hLne (neg_ne_zero.mpr hκne)
+        (by rw [mmr73_cs_ord_neg, hκord]; exact hune), mmr73_cs_ord_neg, hκord, ← hu]
+    have hvu : v ≠ 0 → u = min v 0 := by
+      intro hvne
+      have heq : kw_dcao_specLine D₁ D₂ a b
+          = kw_dcao_specLine D₁ D₂ a (W.toAffine.negY a b)
+            + algebraMap F W.FunctionField (b - W.toAffine.negY a b) := by
+        rw [← hdiff]; ring
+      rw [hu, heq, (placeOfPoint P).ord_add_eq_min hL'ne hκne
+        (by rw [hκord]; exact hvne), hκord, ← hv]
+    have hbnd : ∀ Q : W.Point,
+        (if Q = L then (1:ℤ) else 0) + (if Q = -L then (1:ℤ) else 0)
+            + (if Q = 0 then (1:ℤ) else 0) ≤ 1
+          ∧ (0:ℤ) ≤ (if Q = L then (1:ℤ) else 0)
+          ∧ (0:ℤ) ≤ (if Q = -L then (1:ℤ) else 0)
+          ∧ (0:ℤ) ≤ (if Q = 0 then (1:ℤ) else 0) := by
+      intro Q
+      refine ⟨?_, by split_ifs <;> omega, by split_ifs <;> omega,
+        by split_ifs <;> omega⟩
+      by_cases hQL : Q = L
+      · rw [ite_eq_left hQL, ite_eq_right (hQL ▸ hLneL'), ite_eq_right (hQL ▸ hLne0)]; omega
+      · by_cases hQL' : Q = -L
+        · rw [ite_eq_right hQL, ite_eq_left hQL', ite_eq_right (hQL' ▸ hL'ne0)]; omega
+        · rw [ite_eq_right hQL, ite_eq_right hQL']; split_ifs <;> omega
+    have hb1 : l₁ + m₁ + e₁ ≤ 1 ∧ 0 ≤ l₁ ∧ 0 ≤ m₁ ∧ 0 ≤ e₁ := by
+      rw [hl1d, hm1d, he1d]; exact hbnd Q₁
+    have hb2 : l₂ + m₂ + e₂ ≤ 1 ∧ 0 ≤ l₂ ∧ 0 ≤ m₂ ∧ 0 ≤ e₂ := by
+      rw [hl2d, hm2d, he2d]; exact hbnd Q₂
+    have hb12 : l₁₂ + m₁₂ + e₁₂ ≤ 1 ∧ 0 ≤ l₁₂ ∧ 0 ≤ m₁₂ ∧ 0 ≤ e₁₂ := by
+      rw [hl12d, hm12d, he12d]; exact hbnd (Q₁+Q₂)
+    by_cases hQ1z : Q₁ = 0
+    · have hge : e₁ = 1 := by rw [he1d, ite_eq_left hQ1z]
+      have hgl12 : l₁₂ = l₂ := by rw [hl12d, hl2d, hQ1z, zero_add]
+      have hgm12 : m₁₂ = m₂ := by rw [hm12d, hm2d, hQ1z, zero_add]
+      have hge12 : e₁₂ = e₂ := by rw [he12d, he2d, hQ1z, zero_add]
+      omega
+    by_cases hQ2z : Q₂ = 0
+    · have hge : e₂ = 1 := by rw [he2d, ite_eq_left hQ2z]
+      have hgl12 : l₁₂ = l₁ := by rw [hl12d, hl1d, hQ2z, add_zero]
+      have hgm12 : m₁₂ = m₁ := by rw [hm12d, hm1d, hQ2z, add_zero]
+      have hge12 : e₁₂ = e₁ := by rw [he12d, he1d, hQ2z, add_zero]
+      omega
+    by_cases hQ12z : Q₁ + Q₂ = 0
+    · have hge : e₁₂ = 1 := by rw [he12d, ite_eq_left hQ12z]
+      have hQ2neg : Q₂ = -Q₁ := (neg_eq_of_add_eq_zero_right hQ12z).symm
+      have hgl2 : l₂ = m₁ := by
+        rw [hl2d, hm1d]; congr 1
+        exact propext ⟨fun h' => by rw [hQ2neg] at h'; rw [← h', neg_neg],
+          fun h' => by rw [hQ2neg, h', neg_neg]⟩
+      have hgm2 : m₂ = l₁ := by
+        rw [hm2d, hl1d]; congr 1
+        exact propext ⟨fun h' => by rw [hQ2neg] at h'; exact neg_inj.mp h',
+          fun h' => by rw [hQ2neg, h']⟩
+      have hge2 : e₂ = e₁ := by
+        rw [he2d, he1d]; congr 1
+        exact propext ⟨fun h' => by rw [hQ2neg] at h'; exact neg_eq_zero.mp h',
+          fun h' => by rw [hQ2neg, h', _root_.neg_zero]⟩
+      omega
+    have := hAA D₁ D₂ D₃ hgm hX h hκ P (hQ1def ▸ hQ1z) (hQ2def ▸ hQ2z)
+      (hQ1def ▸ hQ2def ▸ hQ12z)
+    rw [kw_dcao_ord_aSubX_formula h (D₁.geomMorph P + D₂.geomMorph P)] at this
+    simp only [← hQ1def, ← hQ2def, ← hLdef] at this
+    linarith [this]
+
+end GeneralW
+end Affine
+end WeierstrassCurve
+end
+end
+
+section
+
+section
+
+open ModularCurve.Es1a1
+open ModularCurve.Mmr73
+namespace WeierstrassCurve
+namespace Affine
+universe u
+
+section GeneralW
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+attribute [local instance] ModularCurve.Es1a1.instDecEqFunctionFieldEs1a6Add
+
+theorem kw_dcao_sumDatum_Y_of_hgm (D₁ D₂ D₃ : IsogenyEndDatum W)
+    (hgm : ∀ P, D₃.geomMorph P = D₁.geomMorph P + D₂.geomMorph P)
+    (hX : D₁.ι (polyToFunctionField W X) ≠ D₂.ι (polyToFunctionField W X)) :
+    ∃ Ds : IsogenyEndDatum W,
+      Ds.ι (polyToFunctionField W X) = es1a6_addSumX W D₁.ι D₂.ι
+      ∧ Ds.ι (yGen W) = es1a6_addSumY W D₁.ι D₂.ι
+      ∧ ∀ P, Ds.geomMorph P = D₁.geomMorph P + D₂.geomMorph P := by
+  have _pin := Classical.em True
+  have hnc := kw_dcao_addSumX_nonconst_of_hgm D₁ D₂ D₃ hgm
+  have hcol : ¬ es1a6_addCollapse W D₁.ι D₂.ι :=
+    es1a6_add_not_collapse_of_X_ne W D₁.ι D₂.ι hX
+  have htr : Function.Injective
+      (Polynomial.aeval (R := F) (es1a6_addSumX W D₁.ι D₂.ι)) :=
+    es1a6_add_aeval_sumX_injective_of_forall_ne W D₁.ι D₂.ι hnc
+  obtain ⟨hι, hfin⟩ := kw_hk5f_addIntegralFiniteDataAt_proved W D₁ D₂ hcol htr
+  refine ⟨⟨es1a6_addSumPullbackHom W D₁.ι D₂.ι hcol htr, hι, hfin⟩,
+    es1a6_addSumPullbackHom_X W D₁.ι D₂.ι hcol htr,
+    es1a6_addSumPullbackHom_yGen W D₁.ι D₂.ι hcol htr, fun P => ?_⟩
+  have h1 := kw_coordSeamDataAt_geomMorph D₁ P
+  have h2 := kw_coordSeamDataAt_geomMorph D₂ P
+  have hsum := kw_hk5f_addSumCoordSeamDataNCAt_proved W D₁.ι D₂.ι hcol hnc
+    (placeOfPoint P) (D₁.geomMorph P) (D₂.geomMorph P) h1 h2
+  have hseam := es1a6_addSumSeam_of_data D₁.ι D₂.ι hcol htr hι P
+    (D₁.geomMorph P + D₂.geomMorph P) hsum
+  exact placeOfPoint_injective
+    (((⟨_, hι, hfin⟩ : IsogenyEndDatum W).placeOfPoint_geomMorph P).symm.trans hseam)
+
+theorem kw_dcao_specLineOrdMatch_allAffine_proved :
+    KwDCAOSpecLineOrdMatchAllAffine W := by
+  have _pin := Classical.em True
+  intro D₁ D₂ D₃ hgm hX a b h hκ P hQ1 hQ2 hQ12
+  have hrat : (placeOfPoint P).IsRational :=
+    (placeOfPoint P).isRational_of_deg_eq_one (deg_placeOfPoint P)
+  set x₁ := D₁.ι (polyToFunctionField W X) with hx1d
+  set x₂ := D₂.ι (polyToFunctionField W X) with hx2d
+  set y₁ := D₁.ι (yGen W) with hy1d
+  set y₂ := D₂.ι (yGen W) with hy2d
+  set Λ := kw_dcao_lineSlope D₁ D₂ with hΛd
+  have hXne : x₁ ≠ x₂ := hX
+  have hδne : x₁ - x₂ ≠ 0 := sub_ne_zero.mpr hXne
+  set b' := W.toAffine.negY a b with hb'd
+  have hLne := kw_dcao_specLine_ne_zero_of_hgm D₁ D₂ D₃ hgm hX h
+  have hL'ne : kw_dcao_specLine D₁ D₂ a b' ≠ 0 :=
+    kw_dcao_specLine_ne_zero_of_hgm D₁ D₂ D₃ hgm hX
+      ((Affine.nonsingular_neg a b).mpr h)
+  have hVne := kw_dcao_specVert_ne_zero_of_hgm D₁ D₂ D₃ hgm a
+  have hmemOfD : ∀ (D : IsogenyEndDatum W) {r s hns},
+      D.geomMorph P = Point.some r s hns →
+      D.ι (polyToFunctionField W X) ∈ (placeOfPoint P).toValuationSubring
+        ∧ D.ι (yGen W) ∈ (placeOfPoint P).toValuationSubring := by
+    intro D r s hns hDeq
+    have hmem : ∀ g : W.CoordinateRing,
+        D.ι (algebraMap _ _ g) ∈ (placeOfPoint P).toValuationSubring := by
+      intro g
+      rcases eq_or_ne (D.ι (algebraMap _ _ g)) 0 with h0 | hne
+      · exact h0 ▸ zero_mem _
+      · refine AlgebraicCurve.Place.mem_of_ord_nonneg (placeOfPoint P) hne ?_
+        rw [kw_dcao_ord_Dtransport D, hDeq, placeOfPoint_some]
+        exact ord_placeOfEquation_nonneg hns.left g
+    exact ⟨by rw [polyToFunctionField_apply, algebraMap_polynomial_eq_mk_C]; exact hmem _,
+      hmem _⟩
+  obtain ⟨r₁, s₁, hns₁, hQ1eq⟩ : ∃ r s hns, D₁.geomMorph P = Point.some r s hns := by
+    rcases hQ : D₁.geomMorph P with _ | ⟨r, s, hns⟩
+    · exact absurd (show D₁.geomMorph P = 0 by exact_mod_cast hQ) hQ1
+    · exact ⟨r, s, hns, rfl⟩
+  obtain ⟨r₂, s₂, hns₂, hQ2eq⟩ : ∃ r s hns, D₂.geomMorph P = Point.some r s hns := by
+    rcases hQ : D₂.geomMorph P with _ | ⟨r, s, hns⟩
+    · exact absurd (show D₂.geomMorph P = 0 by exact_mod_cast hQ) hQ2
+    · exact ⟨r, s, hns, rfl⟩
+  obtain ⟨hx1m, hy1m⟩ := hmemOfD D₁ hQ1eq
+  obtain ⟨hx2m, hy2m⟩ := hmemOfD D₂ hQ2eq
+  obtain ⟨hex1, hey1⟩ := mmr73_cs_geomMorph_some_coords D₁ P hQ1eq hx1m hy1m
+  obtain ⟨hex2, hey2⟩ := mmr73_cs_geomMorph_some_coords D₂ P hQ2eq hx2m hy2m
+  rw [← hx1d] at hx1m hex1; rw [← hy1d] at hy1m hey1
+  rw [← hx2d] at hx2m hex2; rw [← hy2d] at hy2m hey2
+  obtain ⟨Ds, hXs, hYs, hgms⟩ := kw_dcao_sumDatum_Y_of_hgm D₁ D₂ D₃ hgm hX
+  obtain ⟨rs, ss, hnss, hQseq⟩ : ∃ r s hns, Ds.geomMorph P = Point.some r s hns := by
+    rcases hQ : Ds.geomMorph P with _ | ⟨r, s, hns⟩
+    · exact absurd ((hgms P).symm.trans (show Ds.geomMorph P = 0 by exact_mod_cast hQ)) hQ12
+    · exact ⟨r, s, hns, rfl⟩
+  obtain ⟨hxsm, hysm⟩ := hmemOfD Ds hQseq
+  obtain ⟨hexs, heys⟩ := mmr73_cs_geomMorph_some_coords Ds P hQseq hxsm hysm
+  rw [hXs] at hexs hxsm; rw [hYs] at heys hysm
+  have hQsum : D₁.geomMorph P + D₂.geomMorph P = Point.some rs ss hnss :=
+    (hgms P).symm.trans hQseq
+  have hΛeq : Λ = (y₁ - y₂) / (x₁ - x₂) := Affine.slope_of_X_ne hXne
+  have hΛδ : Λ * (x₁ - x₂) = y₁ - y₂ := by rw [hΛeq, div_mul_cancel₀ _ hδne]
+  set σ := y₁ + y₂ + algebraMap F W.FunctionField W.a₁ * x₁
+      + algebraMap F W.FunctionField W.a₃ with hσd
+  have ha1m : algebraMap F W.FunctionField W.a₁
+      ∈ (placeOfPoint P).toValuationSubring := (placeOfPoint P).algebraMap_mem' W.a₁
+  have ha3m : algebraMap F W.FunctionField W.a₃
+      ∈ (placeOfPoint P).toValuationSubring := (placeOfPoint P).algebraMap_mem' W.a₃
+  have hcsub : ∃ ξ, Λ * σ = ξ ∧ ξ ∈ (placeOfPoint P).toValuationSubring := by
+    set ξ' := x₁ * x₁ + x₁ * x₂ + x₂ * x₂
+        + algebraMap F W.FunctionField W.a₂ * (x₁ + x₂)
+        + algebraMap F W.FunctionField W.a₄
+        - algebraMap F W.FunctionField W.a₁ * y₂ with hξd
+    refine ⟨ξ', ?_, ?_⟩
+    · have hE₁ := es1a6_add_equation W D₁.ι
+      have hE₂ := es1a6_add_equation W D₂.ι
+      rw [Affine.equation_iff] at hE₁ hE₂
+      simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+        WeierstrassCurve.map_a₄,
+        WeierstrassCurve.map_a₆, ← hx1d, ← hy1d] at hE₁
+      simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+        WeierstrassCurve.map_a₄,
+        WeierstrassCurve.map_a₆, ← hx2d, ← hy2d] at hE₂
+      have hcub : (y₁ - y₂) * σ = (x₁ - x₂) * ξ' := by
+        rw [hσd, hξd]; linear_combination hE₁ - hE₂
+      have heq : (x₁ - x₂) * (Λ * σ) = (x₁ - x₂) * ξ' := by
+        rw [← mul_assoc, mul_comm (x₁ - x₂) Λ, hΛδ, hcub]
+      exact mul_left_cancel₀ hδne heq
+    · rw [hξd]
+      exact sub_mem (add_mem (add_mem (add_mem (add_mem (mul_mem hx1m hx1m)
+        (mul_mem hx1m hx2m)) (mul_mem hx2m hx2m))
+        (mul_mem ((placeOfPoint P).algebraMap_mem' _) (add_mem hx1m hx2m)))
+        ((placeOfPoint P).algebraMap_mem' _))
+        (mul_mem ha1m hy2m)
+  obtain ⟨ξ, hΛσ, hξm⟩ := hcsub
+  have hσm : σ ∈ (placeOfPoint P).toValuationSubring :=
+    add_mem (add_mem (add_mem hy1m hy2m) (mul_mem ha1m hx1m)) ha3m
+  have hδm : x₁ - x₂ ∈ (placeOfPoint P).toValuationSubring := sub_mem hx1m hx2m
+  have hy12m : y₁ - y₂ ∈ (placeOfPoint P).toValuationSubring := sub_mem hy1m hy2m
+  have hevz : ∀ {f}, f ∈ (placeOfPoint P).toValuationSubring →
+      0 < (placeOfPoint P).ord f → (placeOfPoint P).evalAt f = 0 := fun hfm hpos =>
+    mmr73_cs_evalAt_eq_of_ord_sub_pos (placeOfPoint P) hrat hfm
+      (a := 0) (by rwa [_root_.map_zero, sub_zero])
+  have hopz : ∀ {f}, f ≠ 0 → f ∈ (placeOfPoint P).toValuationSubring →
+      (placeOfPoint P).evalAt f = 0 → 0 < (placeOfPoint P).ord f := fun hfne hfm he0 =>
+    lt_of_le_of_ne (AlgebraicCurve.Place.ord_nonneg_of_mem (placeOfPoint P) hfm)
+      (fun h0 => (placeOfPoint P).evalAt_ne_zero hrat hfne h0.symm he0)
+  have hnotBoth : (placeOfPoint P).evalAt (x₁ - x₂) ≠ 0
+      ∨ (placeOfPoint P).evalAt σ ≠ 0 := by
+    rw [or_iff_not_imp_left, not_not]; intro hδ0
+    rw [(placeOfPoint P).evalAt_sub hrat hx1m hx2m, hex1, hex2, sub_eq_zero] at hδ0
+    intro hσ0
+    rw [hσd, (placeOfPoint P).evalAt_add hrat
+        (add_mem (add_mem hy1m hy2m) (mul_mem ha1m hx1m)) ha3m,
+      (placeOfPoint P).evalAt_add hrat (add_mem hy1m hy2m) (mul_mem ha1m hx1m),
+      (placeOfPoint P).evalAt_add hrat hy1m hy2m,
+      (placeOfPoint P).evalAt_mul hrat ha1m hx1m, hey1, hey2, hex1,
+      (placeOfPoint P).evalAt_algebraMap, (placeOfPoint P).evalAt_algebraMap] at hσ0
+    refine hQ12 ?_
+    rw [hQ1eq, hQ2eq]
+    exact Point.add_of_Y_eq hδ0
+      (by unfold Affine.negY; linear_combination hσ0 - W.a₁ * hδ0)
+  have hΛm : Λ ∈ (placeOfPoint P).toValuationSubring := by
+    rcases hnotBoth with hδnz | hσnz
+    · have hδord : (placeOfPoint P).ord (x₁ - x₂) = 0 := by
+        by_contra hne; exact hδnz (hevz hδm (lt_of_le_of_ne
+          (AlgebraicCurve.Place.ord_nonneg_of_mem (placeOfPoint P) hδm) (Ne.symm hne)))
+      have hδinv : (x₁ - x₂)⁻¹ ∈ (placeOfPoint P).toValuationSubring :=
+        AlgebraicCurve.Place.mem_of_ord_nonneg (placeOfPoint P) (inv_ne_zero hδne)
+          (by rw [(placeOfPoint P).ord_inv, hδord]; omega)
+      rw [hΛeq, div_eq_mul_inv]; exact mul_mem hy12m hδinv
+    · have hσne : σ ≠ 0 := fun h0 => hσnz (h0 ▸ (placeOfPoint P).evalAt_zero)
+      have hσord : (placeOfPoint P).ord σ = 0 := by
+        by_contra hne; exact hσnz (hevz hσm (lt_of_le_of_ne
+          (AlgebraicCurve.Place.ord_nonneg_of_mem (placeOfPoint P) hσm) (Ne.symm hne)))
+      have hσinv : σ⁻¹ ∈ (placeOfPoint P).toValuationSubring :=
+        AlgebraicCurve.Place.mem_of_ord_nonneg (placeOfPoint P) (inv_ne_zero hσne)
+          (by rw [(placeOfPoint P).ord_inv, hσord]; omega)
+      rw [show Λ = ξ * σ⁻¹ by field_simp; linear_combination hΛσ]
+      exact mul_mem hξm hσinv
+  set u := (placeOfPoint P).ord (kw_dcao_specLine D₁ D₂ a b) with hud
+  set v := (placeOfPoint P).ord (kw_dcao_specLine D₁ D₂ a b') with hvd
+  have hLform1 : ∀ c : F, kw_dcao_specLine D₁ D₂ a c
+      = (algebraMap F W.FunctionField c - y₁)
+        - Λ * (algebraMap F W.FunctionField a - x₁) := by
+    intro c
+    change (_ - _ - _ : W.FunctionField) = _
+    rw [show kw_dcao_lineIntercept D₁ D₂ = y₁ - Λ * x₁ from rfl]; ring
+  have hLform2 : ∀ c : F, kw_dcao_specLine D₁ D₂ a c
+      = (algebraMap F W.FunctionField c - y₂)
+        - Λ * (algebraMap F W.FunctionField a - x₂) := by
+    intro c; rw [hLform1 c]; linear_combination hΛδ
+  have hLform3 : ∀ c : F, kw_dcao_specLine D₁ D₂ a c
+      = (es1a6_addSumY W D₁.ι D₂.ι + algebraMap F W.FunctionField (c + W.a₃)
+          + algebraMap F W.FunctionField W.a₁ * es1a6_addSumX W D₁.ι D₂.ι)
+        - Λ * (algebraMap F W.FunctionField a - es1a6_addSumX W D₁.ι D₂.ι) := by
+    intro c; rw [hLform1 c]
+    simp only [es1a6_addSumY, es1a6_addSumX, ← hx1d, ← hx2d, ← hy1d, ← hy2d,
+      Affine.addY, Affine.negY, Affine.negAddY, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₃,
+      map_add]
+    ring
+  have ham : algebraMap F W.FunctionField a
+      ∈ (placeOfPoint P).toValuationSubring := (placeOfPoint P).algebraMap_mem' a
+  have hLmem : ∀ c : F, kw_dcao_specLine D₁ D₂ a c
+      ∈ (placeOfPoint P).toValuationSubring := fun c => by
+    rw [hLform1 c]
+    exact sub_mem (sub_mem ((placeOfPoint P).algebraMap_mem' c) hy1m)
+      (mul_mem hΛm (sub_mem ham hx1m))
+  have hunn : 0 ≤ u := AlgebraicCurve.Place.ord_nonneg_of_mem (placeOfPoint P) (hLmem b)
+  have hvnn : 0 ≤ v := AlgebraicCurve.Place.ord_nonneg_of_mem (placeOfPoint P) (hLmem b')
+  have hκne : algebraMap F W.FunctionField (b - b') ≠ 0 :=
+    fun hc => hκ (sub_eq_zero.mp
+      ((algebraMap F W.FunctionField).injective (by rw [hc, _root_.map_zero])))
+  have hdiff := kw_dcao_specLine_negY_diff D₁ D₂ a b
+  have hκord : (placeOfPoint P).ord (algebraMap F W.FunctionField (b - b')) = 0 :=
+    AlgebraicCurve.Place.ord_algebraMap (placeOfPoint P) _
+  have huv0 : u = 0 ∨ v = 0 := by
+    by_contra hno; rw [not_or] at hno
+    have hup : 0 < u := lt_of_le_of_ne hunn (Ne.symm hno.1)
+    have heq : kw_dcao_specLine D₁ D₂ a b'
+        = kw_dcao_specLine D₁ D₂ a b
+          + -(algebraMap F W.FunctionField (b - b')) := by rw [← hdiff]; ring
+    have hvcalc : v = min u 0 := by
+      rw [hvd, heq, (placeOfPoint P).ord_add_eq_min hLne (neg_ne_zero.mpr hκne)
+        (by rw [mmr73_cs_ord_neg, hκord]; exact hno.1),
+        mmr73_cs_ord_neg, hκord, ← hud]
+    omega
+  set L := Point.some a b h with hLdef
+  have hnegL : -L = Point.some a b' ((Affine.nonsingular_neg a b).mpr h) := by
+    rw [hLdef, Point.neg_some]
+  have hforce : ∀ (xj yj : W.FunctionField)
+      (hxjm : xj ∈ (placeOfPoint P).toValuationSubring)
+      (hyjm : yj ∈ (placeOfPoint P).toValuationSubring)
+      (hexj : (placeOfPoint P).evalAt xj = a)
+      (c : F)
+      (heyj : (placeOfPoint P).evalAt yj = c)
+      (hform : kw_dcao_specLine D₁ D₂ a c
+        = (algebraMap F W.FunctionField c - yj)
+          - Λ * (algebraMap F W.FunctionField a - xj)),
+      (placeOfPoint P).evalAt (kw_dcao_specLine D₁ D₂ a c) = 0 := by
+    intro xj yj hxjm hyjm hexj c heyj hform
+    rw [hform,
+      (placeOfPoint P).evalAt_sub hrat
+        (sub_mem ((placeOfPoint P).algebraMap_mem' c) hyjm)
+        (mul_mem hΛm (sub_mem ham hxjm)),
+      (placeOfPoint P).evalAt_sub hrat ((placeOfPoint P).algebraMap_mem' c) hyjm,
+      (placeOfPoint P).evalAt_mul hrat hΛm (sub_mem ham hxjm),
+      (placeOfPoint P).evalAt_sub hrat ham hxjm,
+      (placeOfPoint P).evalAt_algebraMap, (placeOfPoint P).evalAt_algebraMap,
+      heyj, hexj, sub_self, sub_self, mul_zero, sub_zero]
+  have hZF1 : D₁.geomMorph P ≠ L ∨ 0 < u := by
+    rcases eq_or_ne (D₁.geomMorph P) L with heq | hne
+    · right
+      rw [hQ1eq, hLdef] at heq
+      simp only [Point.some.injEq] at heq
+      exact hopz hLne (hLmem b)
+        (hforce x₁ y₁ hx1m hy1m (hex1.trans heq.1) b (hey1.trans heq.2)
+          (hLform1 b))
+    · left; exact hne
+  have hZF2 : D₂.geomMorph P ≠ L ∨ 0 < u := by
+    rcases eq_or_ne (D₂.geomMorph P) L with heq | hne
+    · right
+      rw [hQ2eq, hLdef] at heq
+      simp only [Point.some.injEq] at heq
+      exact hopz hLne (hLmem b)
+        (hforce x₂ y₂ hx2m hy2m (hex2.trans heq.1) b (hey2.trans heq.2)
+          (hLform2 b))
+    · left; exact hne
+  have hZF1' : D₁.geomMorph P ≠ -L ∨ 0 < v := by
+    rcases eq_or_ne (D₁.geomMorph P) (-L) with heq | hne
+    · right
+      rw [hQ1eq, hnegL] at heq
+      simp only [Point.some.injEq] at heq
+      exact hopz hL'ne (hLmem b')
+        (hforce x₁ y₁ hx1m hy1m (hex1.trans heq.1) b' (hey1.trans heq.2)
+          (hLform1 b'))
+    · left; exact hne
+  have hZF2' : D₂.geomMorph P ≠ -L ∨ 0 < v := by
+    rcases eq_or_ne (D₂.geomMorph P) (-L) with heq | hne
+    · right
+      rw [hQ2eq, hnegL] at heq
+      simp only [Point.some.injEq] at heq
+      exact hopz hL'ne (hLmem b')
+        (hforce x₂ y₂ hx2m hy2m (hex2.trans heq.1) b' (hey2.trans heq.2)
+          (hLform2 b'))
+    · left; exact hne
+  have hbb' : b + b' + W.a₁ * a + W.a₃ = 0 := by
+    rw [hb'd]; unfold Affine.negY; ring
+  have hforce3 : ∀ c : F, rs = a → ss + c + W.a₁ * a + W.a₃ = 0 →
+      (placeOfPoint P).evalAt (kw_dcao_specLine D₁ D₂ a c) = 0 := by
+    intro c hrsa hssc
+    rw [hLform3 c,
+      (placeOfPoint P).evalAt_sub hrat
+        (add_mem (add_mem hysm ((placeOfPoint P).algebraMap_mem' _))
+          (mul_mem ha1m hxsm))
+        (mul_mem hΛm (sub_mem ham hxsm)),
+      (placeOfPoint P).evalAt_add hrat
+        (add_mem hysm ((placeOfPoint P).algebraMap_mem' _)) (mul_mem ha1m hxsm),
+      (placeOfPoint P).evalAt_add hrat hysm ((placeOfPoint P).algebraMap_mem' _),
+      (placeOfPoint P).evalAt_mul hrat ha1m hxsm,
+      (placeOfPoint P).evalAt_mul hrat hΛm (sub_mem ham hxsm),
+      (placeOfPoint P).evalAt_sub hrat ham hxsm,
+      (placeOfPoint P).evalAt_algebraMap, (placeOfPoint P).evalAt_algebraMap,
+      (placeOfPoint P).evalAt_algebraMap,
+      heys, hexs, hrsa, sub_self, mul_zero, sub_zero]
+    linear_combination hssc
+  have hZF12 : D₁.geomMorph P + D₂.geomMorph P ≠ L ∨ 0 < v := by
+    rcases eq_or_ne (D₁.geomMorph P + D₂.geomMorph P) L with heq | hne
+    · right
+      rw [hQsum, hLdef] at heq
+      simp only [Point.some.injEq] at heq
+      refine hopz hL'ne (hLmem b') (hforce3 b' heq.1 ?_)
+      linear_combination hbb' + heq.2
+    · left; exact hne
+  have hZF12' : D₁.geomMorph P + D₂.geomMorph P ≠ -L ∨ 0 < u := by
+    rcases eq_or_ne (D₁.geomMorph P + D₂.geomMorph P) (-L) with heq | hne
+    · right
+      rw [hQsum, hnegL] at heq
+      simp only [Point.some.injEq] at heq
+      refine hopz hLne (hLmem b) (hforce3 b heq.1 ?_)
+      linear_combination hbb' + heq.2
+    · left; exact hne
+  have hSum := kw_dcao_specLine_ord_sum D₁ D₂ D₃ hgm hX h P
+  rw [kw_dcao_ord_aSubX_formula h (D₁.geomMorph P),
+    kw_dcao_ord_aSubX_formula h (D₂.geomMorph P),
+    kw_dcao_ord_aSubX_formula h (D₁.geomMorph P + D₂.geomMorph P)] at hSum
+  simp only [ite_eq_right hQ1, ite_eq_right hQ2, ite_eq_right hQ12, mul_zero, sub_zero,
+    ← hb'd] at hSum
+  rw [kw_dcao_ord_aSubX_formula h (D₁.geomMorph P + D₂.geomMorph P),
+    ite_eq_right hQ1, ite_eq_right hQ2, ite_eq_right hQ12]
+  simp only [mul_zero, sub_zero, ← hLdef, ← hud, ← hvd] at hSum ⊢
+  set l₁ : ℤ := if D₁.geomMorph P = L then 1 else 0 with hl1d
+  set m₁ : ℤ := if D₁.geomMorph P = -L then 1 else 0 with hm1d
+  set l₂ : ℤ := if D₂.geomMorph P = L then 1 else 0 with hl2d
+  set m₂ : ℤ := if D₂.geomMorph P = -L then 1 else 0 with hm2d
+  set l₁₂ : ℤ := if D₁.geomMorph P + D₂.geomMorph P = L then 1 else 0 with hl12d
+  set m₁₂ : ℤ := if D₁.geomMorph P + D₂.geomMorph P = -L then 1 else 0 with hm12d
+  have hF1 : l₁ = 0 ∨ 0 < u := hZF1.imp (fun h => by rw [hl1d, ite_eq_right h]) id
+  have hF2 : l₂ = 0 ∨ 0 < u := hZF2.imp (fun h => by rw [hl2d, ite_eq_right h]) id
+  have hF1' : m₁ = 0 ∨ 0 < v := hZF1'.imp (fun h => by rw [hm1d, ite_eq_right h]) id
+  have hF2' : m₂ = 0 ∨ 0 < v := hZF2'.imp (fun h => by rw [hm2d, ite_eq_right h]) id
+  have hF12 : l₁₂ = 0 ∨ 0 < v := hZF12.imp (fun h => by rw [hl12d, ite_eq_right h]) id
+  have hF12' : m₁₂ = 0 ∨ 0 < u := hZF12'.imp (fun h => by rw [hm12d, ite_eq_right h]) id
+  have hb1 : 0 ≤ l₁ ∧ 0 ≤ m₁ := ⟨by rw [hl1d]; split_ifs <;> omega,
+    by rw [hm1d]; split_ifs <;> omega⟩
+  have hb2 : 0 ≤ l₂ ∧ 0 ≤ m₂ := ⟨by rw [hl2d]; split_ifs <;> omega,
+    by rw [hm2d]; split_ifs <;> omega⟩
+  have hb12 : 0 ≤ l₁₂ ∧ 0 ≤ m₁₂ := ⟨by rw [hl12d]; split_ifs <;> omega,
+    by rw [hm12d]; split_ifs <;> omega⟩
+  omega
+
+end GeneralW
+end Affine
+end WeierstrassCurve
+end
+end
+
+section
+
+section
+
+namespace WeierstrassCurve
+namespace Affine
+universe u
+
+section GeneralW
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+local instance kw_dcao_wire_instHPD : HasPrincipalDivisors F W.FunctionField :=
+  hasPrincipalDivisors_functionField _
+
+abbrev kw_dcao_specExplicit (D₁ D₂ : IsogenyEndDatum W) (a b : F) : W.FunctionField :=
+  kw_dcao_specVert D₁ D₂ a * (kw_dcao_specLine D₁ D₂ a b)⁻¹
+
+theorem kw_dcao_defect_pointDivisor_coeff (D₁ D₂ D₃ : IsogenyEndDatum W)
+    (hgm : ∀ P, D₃.geomMorph P = D₁.geomMorph P + D₂.geomMorph P) (L P : W.Point) :
+    (Divisor.pullbackAlong D₃.ι D₃.hι
+        (pointDivisor L : Divisor F W.FunctionField)
+      - (Divisor.pullbackAlong D₁.ι D₁.hι
+            (pointDivisor L : Divisor F W.FunctionField)
+          + Divisor.pullbackAlong D₂.ι D₂.hι
+            (pointDivisor L : Divisor F W.FunctionField)))
+      (placeOfPoint P)
+      = ((if D₁.geomMorph P + D₂.geomMorph P = L then 1 else 0)
+          - (if D₁.geomMorph P = L then 1 else 0)
+          - (if D₂.geomMorph P = L then 1 else 0))
+        - ((if D₁.geomMorph P + D₂.geomMorph P = 0 then 1 else 0)
+          - (if D₁.geomMorph P = 0 then 1 else 0)
+          - (if D₂.geomMorph P = 0 then 1 else 0)) := by
+  have h1 := kw_dcao_unramified_proved D₁
+  have h2 := kw_dcao_unramified_proved D₂
+  have h3 := kw_dcao_unramified_proved D₃
+  have hL := kw_dcao_defect_pullback_placeOfPoint_apply_of_unramified D₁ D₂ D₃ h1 h2 h3 L P
+  have h0 := kw_dcao_defect_pullback_placeOfPoint_apply_of_unramified D₁ D₂ D₃ h1 h2 h3 0 P
+  rw [hgm P] at hL h0
+  simp only [coe_pointDivisor, map_sub, ← sub_sub, Finsupp.sub_apply] at *
+  linear_combination hL - h0
+
+theorem kw_dcao_defectPrincipalPerPoint_of_specLineOrdMatchHgm
+    (hSLO : KwDCAOSpecLineOrdMatchHgm W) :
+    KwDCAODefectPrincipalPerPoint W := by
+  intro D₁ D₂ D₃ hgm hX L
+  rcases L with _ | ⟨a, b, h⟩
+  · have h0 : (pointDivisor (0 : W.Point) : Divisor F W.FunctionField) = 0 := by
+      rw [coe_pointDivisor, sub_self]
+    change Divisor.IsPrincipal _
+    rw [show (Point.zero : W.Point) = 0 from rfl,
+      h0, _root_.map_zero, _root_.map_zero, _root_.map_zero, zero_add, sub_zero]
+    exact Divisor.principal.zero_mem
+  · have hVne := kw_dcao_specVert_ne_zero_of_hgm D₁ D₂ D₃ hgm a
+    obtain ⟨hLne, hLord⟩ := hSLO D₁ D₂ D₃ hgm hX h
+    have hne : kw_dcao_specExplicit D₁ D₂ a b ≠ 0 :=
+      mul_ne_zero hVne (inv_ne_zero hLne)
+    refine ⟨kw_dcao_specExplicit D₁ D₂ a b, hne, fun v => ?_⟩
+    set P := (placeOfPointEquiv W).symm v with hP
+    have hv : v = placeOfPoint P := (placeOfPoint_placeOfPointEquiv_symm W v).symm
+    have hcoeff := kw_dcao_defect_pointDivisor_coeff D₁ D₂ D₃ hgm (Point.some a b h) P
+    rw [hv, hcoeff,
+      show kw_dcao_specExplicit D₁ D₂ a b
+        = kw_dcao_specVert D₁ D₂ a * (kw_dcao_specLine D₁ D₂ a b)⁻¹ from rfl,
+      (placeOfPoint P).ord_mul hVne (inv_ne_zero hLne), (placeOfPoint P).ord_inv,
+      kw_dcao_ord_specVert_eq_transport D₁ D₂ D₃ hgm hX a P, hLord P]
+    ring
+
+theorem kw_dcao_htw_of_specLineOrdMatchHgm (hSLO : KwDCAOSpecLineOrdMatchHgm W) :
+    KwDualTraceWitness W :=
+  kw_dcao_htw_of_defectPrincipal
+    (kw_dcao_defectPrincipalPerPoint_of_specLineOrdMatchHgm hSLO)
+
+theorem kw_dcao_htw_of_allAffine (hAA : KwDCAOSpecLineOrdMatchAllAffine W) :
+    KwDualTraceWitness W :=
+  kw_dcao_htw_of_specLineOrdMatchHgm
+    (kw_dcao_specLineOrdMatch_hgm_of_allAffine hAA)
+
+end GeneralW
+end Affine
+end WeierstrassCurve
+end
+end
+
+section
+
+section
+
+namespace WeierstrassCurve
+namespace Affine
+universe u
+
+section GeneralW
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+theorem kw_dcao_htw_proved : KwDualTraceWitness W :=
+  kw_dcao_htw_of_allAffine kw_dcao_specLineOrdMatch_allAffine_proved
+
+end GeneralW
+end Affine
+end WeierstrassCurve
+end
+end
+
+open WeierstrassCurve WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine
+  AlgebraicCurve in
+universe u in
+theorem solution
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    {W : WeierstrassCurve.Affine F} [W.IsElliptic]
+    [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [AbelTheorem W]
+    (hNs : ∀ D : IsogenyEndDatum W, NormFormulaAlong F D.ι D.hfin) (D : IsogenyEndDatum W) :
+    ∃ DD : AddMonoid.End.DualEndData (D.pointEnd (hNs D)),
+      DD.dual ∈ isogenyEndSubring W hNs ∧ DD.norm = finrankAlong F D.ι := by
+  have htw : KwDualTraceWitness W := kw_dcao_htw_proved
+  have hfun : hNs = fun D => D.normFormulaAlong_auto := rfl
+  subst hfun
+  exact ⟨kw_dualEndData_of_traceWitness htw D, kw_dualInSubring_of_traceWitness htw D, rfl⟩
+
+end
+end
+end
+end
+
+end privateSection
+
+public section publicSection
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+universe u
+theorem WeierstrassCurve.Affine.IsogenyEndDatum.exists_dualEndData_dual_mem_and_norm_eq_finrankAlong
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    {W : WeierstrassCurve.Affine F} [W.IsElliptic]
+    [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [AbelTheorem W]
+    (hNs : ∀ D : IsogenyEndDatum W, NormFormulaAlong F D.ι D.hfin) (D : IsogenyEndDatum W) :
+    ∃ DD : AddMonoid.End.DualEndData (D.pointEnd (hNs D)),
+      DD.dual ∈ isogenyEndSubring W hNs ∧ DD.norm = finrankAlong F D.ι := _root_.solution hNs D
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_forall_pointEnd_eq_zsmul_of_transcendental_j.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_forall_pointEnd_eq_zsmul_of_transcendental_j.lean
new file mode 100644
index 0000000000..d2ee2be236
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_forall_pointEnd_eq_zsmul_of_transcendental_j.lean
@@ -0,0 +1,139 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.Affine.IsogenyEndDatum.exists_forall_pointEnd_eq_zsmul_of_transcendental_j
+(6dd2c674-31b5-5cc3-a8b5-7b0ca8e877c2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6070a9c7-1ec2-518c-ace4-b2ff7e195a0c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Int_exists_squarefree_sq_add_mul_add_mul_sq_of_sq_lt_four_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_isUnit_leadingCoeff_diag
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_nonempty_modularPolynomialData
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyEndDatum_aeval_j_diag_eq_zero_of_finrankAlong_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_sq_lt_four_mul_and_forall_exists_finrankAlong_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Transcendental j forces every isogeny endomorphism to be an integer
+
+Theorem statement:
+`WeierstrassCurve.Affine.IsogenyEndDatum.exists_forall_pointEnd_eq_zsmul_of_transcendental_j`
+(`6dd2c674-31b5-5cc3-a8b5-7b0ca8e877c2`), by Claude, 2026-09-05.
+
+Proof: submission `6070a9c7-1ec2-518c-ace4-b2ff7e195a0c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field of characteristic zero and $W$ an elliptic Weierstrass
+curve over $F$, equipped with the three structural hypotheses of the project's divisor-theoretic
+framework for $W$ in affine form: a `GenusOnePlaceGate`, i.e. a bijection between the points
+$W.\mathrm{Point}$ and the places of the function field $F(W)$ over $F$, all of which have degree
+$1$; the centring condition `GenusOnePlaceGate.IsCentred`, asserting that for every nonsingular pair
+$(x,y)$ the images in $F(W)$ of the coordinate-ring classes of $X - x$ and of $Y - y$ lie in the
+nonunits of the valuation subring of the place attached to the point $(x,y)$; and `AbelTheorem`,
+asserting that a divisor of degree $0$ on $F(W)$ is principal exactly when its point-sum vanishes.
+Assume further that every isogeny endomorphism datum $D$ of $W$ — a pair consisting of an integral
+$F$-algebra endomorphism $\iota$ of $F(W)$ making $F(W)$ a finite module over itself along $\iota$ —
+satisfies the pushforward norm formula along $\iota$, i.e. the divisor pushforward of the divisor of
+any nonzero $f \in F(W)$ is the divisor of $\mathrm{N}(f)$. Finally assume $W.j$ is transcendental
+over $\mathbb{Q}$. Then for every isogeny endomorphism datum $D_0$ there is an integer $m$ with
+$D_0.\mathrm{pointEnd}(P) = m \cdot P$ for all $P \in W.\mathrm{Point}$, where $\mathrm{pointEnd}$
+is the endomorphism of the group of points induced, via the isomorphism with $\mathrm{Pic}^0$, by
+pushforward along $\iota$.
+
+This is the statement that an elliptic curve with transcendental $j$-invariant has no complex
+multiplication: its ring of isogeny endomorphisms, as realised here by pushforward along finite
+self-embeddings of the function field, reduces to $\mathbb{Z}$. It is used in the treatment of
+modular polynomials and of Tate points, in particular for identifying the subgroups generated by a
+point and for injectivity statements on kernels.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_IsogenyEndDatum_exists_forall_pointEnd_eq_zsmul_of_transcendental_j.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_9616a762
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+universe u
+
+theorem solution
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    (W : WeierstrassCurve F) [W.IsElliptic]
+    [GenusOnePlaceGate W.toAffine] [GenusOnePlaceGate.IsCentred W.toAffine] [AbelTheorem W.toAffine]
+    (hNs : ∀ D : IsogenyEndDatum W.toAffine, NormFormulaAlong F D.ι D.hfin)
+    (ht : Transcendental ℚ W.j) (D₀ : IsogenyEndDatum W.toAffine) :
+    ∃ m : ℤ, ∀ P : W.toAffine.Point, D₀.pointEnd (hNs D₀) P = m • P := by
+  by_contra hD₀
+  obtain ⟨t, n, hdisc, hlift⟩ :=
+    IsogenyEndDatum.exists_sq_lt_four_mul_and_forall_exists_finrankAlong_eq W.toAffine hNs D₀ hD₀
+  obtain ⟨a, b, hb, hsf, h2⟩ :=
+    Int.exists_squarefree_sq_add_mul_add_mul_sq_of_sq_lt_four_mul t n hdisc
+  obtain ⟨D, hDdeg⟩ := hlift a b hb
+  set N : ℕ := (a ^ 2 + t * a * b + n * b ^ 2).toNat with hNdef
+  have hdegN : finrankAlong F D.ι = N := by
+    have h := congrArg Int.toNat hDdeg
+    rwa [Int.toNat_natCast] at h
+  have : NeZero N := ⟨by omega⟩
+  obtain ⟨data⟩ := ModularCurve.nonempty_modularPolynomialData N
+  have hjroot : Polynomial.aeval W.j (data.Φ.eval₂ (RingHom.id (Polynomial ℤ)) Polynomial.X) = 0 :=
+    IsogenyEndDatum.aeval_j_diag_eq_zero_of_finrankAlong_eq W hsf data D hdegN
+  have hNns : ¬ IsSquare N := by
+    rintro ⟨m, hm⟩
+    have hunit := Nat.isUnit_iff.mp (hsf m (hm ▸ dvd_refl N))
+    subst hunit
+    omega
+  have hint : IsIntegral ℤ W.j := by
+    rcases Int.isUnit_iff.mp
+        (ModularCurve.ModularPolynomialData.isUnit_leadingCoeff_diag N h2 hNns data) with h1 | h1
+    · exact ⟨data.Φ.eval₂ (RingHom.id (Polynomial ℤ)) Polynomial.X, h1, hjroot⟩
+    · refine ⟨-(data.Φ.eval₂ (RingHom.id (Polynomial ℤ)) Polynomial.X), ?_, ?_⟩
+      · change (-(data.Φ.eval₂ (RingHom.id (Polynomial ℤ)) Polynomial.X)).leadingCoeff = 1
+        rw [Polynomial.leadingCoeff_neg, h1]; ring
+      · rw [Polynomial.eval₂_neg, neg_eq_zero]; exact hjroot
+  obtain ⟨p, hpm, hpe⟩ := hint
+  exact ht ⟨p.map (Int.castRingHom ℚ), (hpm.map _).ne_zero, by
+    rw [Polynomial.aeval_def, Polynomial.eval₂_map,
+      show (algebraMap ℚ F).comp (Int.castRingHom ℚ) = algebraMap ℤ F from Subsingleton.elim _ _]
+    exact hpe⟩
+
+end S_OVERLONG_9616a762
+end P2MW
+export
+  P2MW.S_OVERLONG_9616a762
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+universe u
+theorem WeierstrassCurve.Affine.IsogenyEndDatum.exists_forall_pointEnd_eq_zsmul_of_transcendental_j
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    (W : WeierstrassCurve F) [W.IsElliptic]
+    [GenusOnePlaceGate W.toAffine] [GenusOnePlaceGate.IsCentred W.toAffine] [AbelTheorem W.toAffine]
+    (hNs : ∀ D : IsogenyEndDatum W.toAffine, NormFormulaAlong F D.ι D.hfin)
+    (ht : Transcendental ℚ W.j) (D₀ : IsogenyEndDatum W.toAffine) :
+    ∃ m : ℤ, ∀ P : W.toAffine.Point, D₀.pointEnd (hNs D₀) P = m • P :=
+  solution W hNs ht D₀
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_pointEnd_eq_add.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_pointEnd_eq_add.lean
new file mode 100644
index 0000000000..e060804939
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_pointEnd_eq_add.lean
@@ -0,0 +1,139 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.IsogenyEndDatum.exists_pointEnd_eq_add
+(36178d2d-ea81-5440-be7d-d627e2eb8fb6) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a24dbee0-0d9f-543d-87f2-417d05609f01
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_restrictAlong_placeOfPoint_eq_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyEndDatum_pointEnd_apply_eq_sub
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Isogeny-induced endomorphisms of E(F) are closed under addition
+
+Theorem statement: `WeierstrassCurve.Affine.IsogenyEndDatum.exists_pointEnd_eq_add`
+(`36178d2d-ea81-5440-be7d-d627e2eb8fb6`), by Claude, 2026-09-05.
+
+Proof: submission `a24dbee0-0d9f-543d-87f2-417d05609f01`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field in a fixed universe with decidable equality, algebraically closed and of
+characteristic zero, and let $W$ be an affine Weierstrass curve over $F$ satisfying `W.IsElliptic`,
+equipped with three gate hypotheses: `GenusOnePlaceGate W`, supplying a bijection `pointEquivPlace`
+between $W.\mathrm{Point}$ and the places of $W.\mathrm{FunctionField}$ over $F$ (a place being a
+proper valuation subring containing the image of $F$ whose valuation ring is a principal ideal ring)
+together with the statement that every such place has degree $1$; `GenusOnePlaceGate.IsCentred W`,
+asserting that for each nonsingular affine point the classes of $X$ and of $Y - y$ in the coordinate
+ring lie in the nonunits of the valuation subring attached to that point; and `AbelTheorem W`,
+asserting that a divisor of degree $0$ is principal exactly when its divisor sum in
+$W.\mathrm{Point}$ vanishes. Let $D_1$ and $D_2$ be data of type `IsogenyEndDatum W`, each
+consisting of an $F$-algebra endomorphism $\iota$ of $W.\mathrm{FunctionField}$, a proof that
+$\iota$ is integral, and a proof that $W.\mathrm{FunctionField}$ is a finite module over itself
+along $\iota$; let $hN_1, hN_2$ witness `NormFormulaAlong` for them, i.e. that for every nonzero $f$
+in the target and every divisor whose value at each place $w$ is $w.\mathrm{ord}(f)$, the
+pushforward divisor takes at each place $v$ the value $v.\mathrm{ord}(\mathrm{Norm}(f))$. Assume the
+induced additive endomorphisms of $W.\mathrm{Point}$ — obtained by transporting the $\mathrm{Pic}^0$
+pushforward along $\iota$ through the genus-one isomorphism — have nonzero sum. Then there exist
+$D_3 :$ `IsogenyEndDatum W` and a norm-formula witness $hN_3$ for it whose associated endomorphism
+of $W.\mathrm{Point}$ equals the sum of those of $D_1$ and $D_2$.
+
+This is the function-field model of the classical fact that the sum $\varphi + \psi = \mu \circ
+(\varphi \times \psi) \circ \Delta$ of two isogenies of an elliptic curve is again an isogeny unless
+it is the zero map, so that the endomorphisms of $E(F)$ coming from finite self-embeddings of the
+function field are closed under addition. It is the additive closure step used in assembling those
+endomorphisms into a subring of $\operatorname{End}_{\mathbb{Z}}(E(F))$, and is cited by
+[`WeierstrassCurve.Affine.IsogenyEndDatum.exists_pointEnd_eq_of_mem_isogenyEndSubring`]
+(thm.html#WeierstrassCurve.Affine.IsogenyEndDatum.exists_pointEnd_eq_of_mem_isogenyEndSubring).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_IsogenyEndDatum_exists_pointEnd_eq_add.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_IsogenyEndDatum_exists_pointEnd_eq_add
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+universe u
+
+theorem normFormulaAlong_of_finiteAlong_aux
+    {F : Type u} [Field F] [CharZero F] {V W : WeierstrassCurve.Affine F}
+    [HasPrincipalDivisors F W.FunctionField]
+    (ι : V.FunctionField →ₐ[F] W.FunctionField) (hfin : FiniteAlong F ι) :
+    NormFormulaAlong F ι hfin := by
+  have : CharZero V.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap F V.FunctionField).injective
+  have hsep : SeparableAlong F ι := by
+    let := algebraAlong ι
+    have := isScalarTower_along ι
+    have : Module.Finite V.FunctionField W.FunctionField := hfin
+    change Algebra.IsSeparable V.FunctionField W.FunctionField
+    infer_instance
+  exact AlgebraicCurve.normFormulaAlong ι hfin hsep
+
+theorem solution
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    {W : WeierstrassCurve.Affine F} [W.IsElliptic]
+    [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [AbelTheorem W]
+    (D₁ : IsogenyEndDatum W) (hN₁ : NormFormulaAlong F D₁.ι D₁.hfin)
+    (D₂ : IsogenyEndDatum W) (hN₂ : NormFormulaAlong F D₂.ι D₂.hfin)
+    (h : D₁.pointEnd hN₁ + D₂.pointEnd hN₂ ≠ 0) :
+    ∃ (D₃ : IsogenyEndDatum W) (hN₃ : NormFormulaAlong F D₃.ι D₃.hfin),
+      D₃.pointEnd hN₃ = D₁.pointEnd hN₁ + D₂.pointEnd hN₂ := by
+  obtain ⟨D₃, hD₃⟩ :=
+    IsogenyEndDatum.exists_restrictAlong_placeOfPoint_eq_add D₁ hN₁ D₂ hN₂ h
+  have : HasPrincipalDivisors F W.FunctionField := hasPrincipalDivisors_functionField W
+  have hN₃ : NormFormulaAlong F D₃.ι D₃.hfin := normFormulaAlong_of_finiteAlong_aux D₃.ι D₃.hfin
+  refine ⟨D₃, hN₃, ?_⟩
+  refine AddMonoidHom.ext fun P => ?_
+  change D₃.pointEnd hN₃ P = D₁.pointEnd hN₁ P + D₂.pointEnd hN₂ P
+  rw [IsogenyEndDatum.pointEnd_apply_eq_sub D₃ hN₃, IsogenyEndDatum.pointEnd_apply_eq_sub D₁ hN₁,
+    IsogenyEndDatum.pointEnd_apply_eq_sub D₂ hN₂, hD₃ P, hD₃ 0,
+    pointEquivPlace_symm_placeOfPoint, pointEquivPlace_symm_placeOfPoint]
+  abel
+
+end S_WeierstrassCurve_Affine_IsogenyEndDatum_exists_pointEnd_eq_add
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_IsogenyEndDatum_exists_pointEnd_eq_add (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+universe u
+theorem WeierstrassCurve.Affine.IsogenyEndDatum.exists_pointEnd_eq_add
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    {W : WeierstrassCurve.Affine F} [W.IsElliptic]
+    [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [AbelTheorem W]
+    (D₁ : IsogenyEndDatum W) (hN₁ : NormFormulaAlong F D₁.ι D₁.hfin)
+    (D₂ : IsogenyEndDatum W) (hN₂ : NormFormulaAlong F D₂.ι D₂.hfin)
+    (h : D₁.pointEnd hN₁ + D₂.pointEnd hN₂ ≠ 0) :
+    ∃ (D₃ : IsogenyEndDatum W) (hN₃ : NormFormulaAlong F D₃.ι D₃.hfin),
+      D₃.pointEnd hN₃ = D₁.pointEnd hN₁ + D₂.pointEnd hN₂ :=
+  solution D₁ hN₁ D₂ hN₂ h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_pointEnd_eq_of_mem_isogenyEndSubring.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_pointEnd_eq_of_mem_isogenyEndSubring.lean
new file mode 100644
index 0000000000..4fba7b551b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_pointEnd_eq_of_mem_isogenyEndSubring.lean
@@ -0,0 +1,2674 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.Affine.IsogenyEndDatum.exists_pointEnd_eq_of_mem_isogenyEndSubring
+(3b1add86-45bc-5c3b-a1e2-8c4b164ae447) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6c806b92-5290-58e5-b799-540ebb4a176a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.Analysis.Normed.Ring.Lemmas
+import Mathlib.Tactic.NormNum.Prime
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_pointEnd_eq_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Nonzero elements of the isogeny subring come from isogeny data
+
+Theorem statement:
+`WeierstrassCurve.Affine.IsogenyEndDatum.exists_pointEnd_eq_of_mem_isogenyEndSubring`
+(`3b1add86-45bc-5c3b-a1e2-8c4b164ae447`), by Claude, 2026-09-05.
+
+Proof: submission `6c806b92-5290-58e5-b799-540ebb4a176a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field of characteristic $0$ and $W$ an affine Weierstrass curve
+over $F$ that is elliptic, equipped with the three interface assumptions of the project: a bijection
+between $W.\mathrm{Point}$ and the places of $W.\mathrm{FunctionField}$ over $F$ under which every
+place has degree $1$ (`GenusOnePlaceGate`), the centring condition that at the place attached to a
+nonsingular affine point $(x,y)$ both coordinate classes $X$ and $Y-y$ lie in the nonunits of the
+associated valuation subring (`GenusOnePlaceGate.IsCentred`), and Abel's theorem in the form that a
+divisor of degree $0$ is principal exactly when its sum in $W.\mathrm{Point}$ vanishes
+(`AbelTheorem`). Assume $hNs$: for every isogeny endomorphism datum $D$ on $W$ — an $F$-algebra
+endomorphism $\iota$ of $W.\mathrm{FunctionField}$ that is integral and makes the function field
+finite over itself along $\iota$ — the push-forward norm formula holds along $\iota$, i.e. for every
+nonzero $f$ and every divisor cut out by $\operatorname{ord}(f)$, the push-forward of that divisor
+at a place $v$ equals $v.\mathrm{ord}$ of the algebra norm of $f$. Then for every additive
+endomorphism $\psi$ of $W.\mathrm{Point}$ lying in the subring of
+$\mathrm{AddMonoid.End}\,W.\mathrm{Point}$ generated by the endomorphisms $D.\mathrm{pointEnd}$ (the
+transport of the $\mathrm{Pic}^0$ push-forward along $\iota$ through the genus-one isomorphism
+$W.\mathrm{Point}\cong\mathrm{Pic}^0$), and with $\psi\neq 0$, there exists a datum $D$ with
+$D.\mathrm{pointEnd}=\psi$.
+
+This is the statement that the ring generated by isogeny-induced endomorphisms of the group of
+points adds nothing new: apart from $0$, every element of it is again induced by a single isogeny
+datum, the function-field counterpart of the classical fact that $\operatorname{End}(E)$ consists of
+$0$ together with the isogenies $E\to E$. It is used to transfer degree and norm computations to
+arbitrary nonzero elements of the endomorphism ring, in particular in the results bounding traces
+and degrees by a quadratic form and in the identification of kernels of point maps attached to
+curves with equal $j$-invariant.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_IsogenyEndDatum_exists_pointEnd_eq_of_mem_isogenyEndSubring.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_7915af21
+
+
+noncomputable section
+
+scoped instance instFactNatPrime7_s13e2 : Fact (Nat.Prime 7) := ⟨by norm_num⟩
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  equation_iff' equation_neg CoordinateRing.XYIdeal map_a₃ CoordinateRing CoordinateRing.smul map \
+  CoordinateRing.YClass Nonsingular map_a₆ negY_negY FunctionField map_a₂ Point CoordinateRing.mk \
+  map_a₁ nonsingular_neg map_a₄ CoordinateRing.exists_smul_basis_eq CoordinateRing.XClass \
+  CoordinateRing.basis equation_iff polynomial Point.zero Point.neg_some \
+  pushforwardAlong_single_eq pushforwardAlongHom_pointClass pointMapOfPushforward IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField IsogenyEndDatum.exists_pointEnd_eq_add"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_7915af21.Polyno\
+  mial IsDedekindDomain \
+  P2MW.S_OVERLONG_7915af21.IsDede\
+  kindDomain WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine.CoordinateRing AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg \
+  P2MW.S_OVERLONG_7915af21.Algebr\
+  aicCurve"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_7915af21.Polyno\
+  mial.Bivariate"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem S13_ofHeightOneSpectrum_injective {R : Type*} [CommRing R] [IsDedekindDomain R]
+    [Algebra R W.FunctionField] [IsFractionRing R W.FunctionField] [Algebra F R]
+    [IsScalarTower F R W.FunctionField] :
+    Function.Injective (AlgebraicCurve.Place.ofHeightOneSpectrum (K := F) (R := R) (F :=
+      W.FunctionField)) := by
+  intro w₁ w₂ h
+  refine HeightOneSpectrum.eq_of_valuation_isEquiv_valuation (K := W.FunctionField) ?_
+  rw [Valuation.isEquiv_iff_valuationSubring]
+  exact congrArg AlgebraicCurve.Place.toValuationSubring h
+
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "smul_basis_eq_zero XYIdeal \
+  quotientXYIdealEquiv XClass_ne_zero smul YClass mk map exists_smul_basis_eq XClass \
+  smul_basis_mul_Y YClass_ne_zero isDedekindDomain exists_eq_XYIdeal XYIdeal_isMaximal \
+  XYIdeal_ne_bot"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing"
+
+theorem algebraMap_eq_mk_C_C (a : F) :
+    algebraMap F W.CoordinateRing a = CoordinateRing.mk W (C (C a)) := by
+  rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+    Algebra.algebraMap_self_apply]
+  rfl
+
+theorem eq_of_XYIdeal_eq {x₁ y₁ x₂ y₂ : F} (h₂ : W.Equation x₂ y₂)
+    (h : XYIdeal W x₁ (C y₁) = XYIdeal W x₂ (C y₂)) : x₁ = x₂ ∧ y₁ = y₂ := by
+  have hne : XYIdeal W x₂ (C y₂) ≠ ⊤ := (XYIdeal_isMaximal h₂).ne_top
+  have hX₁ : XClass W x₁ ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert _ _)
+  have hX₂ : XClass W x₂ ∈ XYIdeal W x₂ (C y₂) := Ideal.subset_span (Set.mem_insert _ _)
+  have hY₁ : YClass W (C y₁) ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  have hY₂ : YClass W (C y₂) ∈ XYIdeal W x₂ (C y₂) :=
+    Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  constructor
+  · by_contra hx
+    apply hne
+    have hsub : XClass W x₁ - XClass W x₂ = algebraMap F W.CoordinateRing (x₂ - x₁) := by
+      rw [XClass, XClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      rw [← map_sub]
+      congr 1
+      rw [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hX₁ hX₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hx hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+  · by_contra hy
+    apply hne
+    have hsub : YClass W (C y₁) - YClass W (C y₂) = algebraMap F W.CoordinateRing (y₂ - y₁) := by
+      rw [YClass, YClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      simp only [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hY₁ hY₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hy hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+
+def heightOneSpectrumOfEquation {x y : F} (h : W.Equation x y) :
+    HeightOneSpectrum W.CoordinateRing where
+  asIdeal := XYIdeal W x (C y)
+  isPrime := (XYIdeal_isMaximal h).isPrime
+  ne_bot := XYIdeal_ne_bot x (C y)
+
+@[scoped simp]
+theorem heightOneSpectrumOfEquation_asIdeal {x y : F} (h : W.Equation x y) :
+    (heightOneSpectrumOfEquation h).asIdeal = XYIdeal W x (C y) := rfl
+
+theorem exists_sub_algebraMap_mem {x y : F} (h : W.Equation x y) (r : W.CoordinateRing) :
+    ∃ c : F, r - algebraMap F W.CoordinateRing c ∈ XYIdeal W x (C y) := by
+  set e := quotientXYIdealEquiv (W' := W) (x := x) (y := C y) h
+  refine ⟨e (Ideal.Quotient.mk _ r), ?_⟩
+  rw [← Ideal.Quotient.eq_zero_iff_mem, map_sub, sub_eq_zero]
+  apply e.injective
+  rw [← Ideal.Quotient.algebraMap_eq, ← IsScalarTower.algebraMap_apply, AlgEquiv.commutes,
+    Algebra.algebraMap_self_apply]
+
+end CoordinateRing
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine.CoordinateRing"
+
+def IsFinitePlace (v : AlgebraicCurve.Place F W.FunctionField) : Prop :=
+  ∀ r : W.CoordinateRing, algebraMap W.CoordinateRing W.FunctionField r ∈ v.toValuationSubring
+
+def IsFinitePlace.ringHom {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    W.CoordinateRing →+* v.toValuationSubring where
+  toFun r := ⟨algebraMap W.CoordinateRing W.FunctionField r, hv r⟩
+  map_one' := Subtype.ext (map_one _)
+  map_mul' a b := Subtype.ext (map_mul _ a b)
+  map_zero' := Subtype.ext (map_zero _)
+  map_add' a b := Subtype.ext (map_add _ a b)
+
+@[scoped simp]
+theorem IsFinitePlace.coe_ringHom_apply {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) (r : W.CoordinateRing) :
+    (hv.ringHom r : W.FunctionField) = algebraMap W.CoordinateRing W.FunctionField r := rfl
+
+
+def IsFinitePlace.centre {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    Ideal W.CoordinateRing :=
+  (IsLocalRing.maximalIdeal v.toValuationSubring).comap hv.ringHom
+
+theorem IsFinitePlace.centre_isPrime {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre.IsPrime :=
+  Ideal.IsPrime.comap _
+
+theorem IsFinitePlace.inv_mem {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) {r : W.CoordinateRing} (hr : r ∉ hv.centre) :
+    (algebraMap W.CoordinateRing W.FunctionField r)⁻¹ ∈ v.toValuationSubring := by
+  have hunit : IsUnit (hv.ringHom r) := by
+    rw [IsFinitePlace.centre, Ideal.mem_comap, IsLocalRing.mem_maximalIdeal,
+      mem_nonunits_iff, not_not] at hr
+    exact hr
+  obtain ⟨t, ht⟩ := hunit.exists_right_inv
+  have ht' : algebraMap W.CoordinateRing W.FunctionField r * (t : W.FunctionField) = 1 := by
+    have := congrArg (fun a : v.toValuationSubring => (a : W.FunctionField)) ht
+    simpa using this
+  rw [inv_eq_of_mul_eq_one_right ht']
+  exact t.2
+
+theorem IsFinitePlace.centre_ne_bot {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre ≠ ⊥ := by
+  intro hbot
+  apply v.ne_top'
+  rw [eq_top_iff]
+  rintro z -
+  obtain ⟨r, s, hs, hz⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  have hs0 : s ∉ hv.centre := by
+    rw [hbot, Ideal.mem_bot]
+    exact fun h => nonZeroDivisors.ne_zero hs h
+  rw [← hz, div_eq_mul_inv]
+  exact mul_mem (hv r) (hv.inv_mem hs0)
+
+variable [IsDedekindDomain W.CoordinateRing]
+
+def placeOfEquation {x y : F} (h : W.Equation x y) :
+    AlgebraicCurve.Place F W.FunctionField :=
+  AlgebraicCurve.Place.ofHeightOneSpectrum (heightOneSpectrumOfEquation h)
+
+theorem placeOfEquation_injective {x₁ y₁ x₂ y₂ : F} (h₁ : W.Equation x₁ y₁)
+    (h₂ : W.Equation x₂ y₂) (h : placeOfEquation h₁ = placeOfEquation h₂) :
+    x₁ = x₂ ∧ y₁ = y₂ :=
+  eq_of_XYIdeal_eq h₂
+    (congrArg HeightOneSpectrum.asIdeal (S13_ofHeightOneSpectrum_injective h))
+
+theorem isFinitePlace_placeOfEquation {x y : F} (h : W.Equation x y) :
+    IsFinitePlace (placeOfEquation h) := fun r =>
+  (heightOneSpectrumOfEquation h).valuation_le_one r
+
+theorem isFinitePlace_iff_exists_placeOfEquation [IsAlgClosed F]
+    (v : AlgebraicCurve.Place F W.FunctionField) :
+    IsFinitePlace v ↔ ∃ (x y : F) (h : W.Equation x y), v = placeOfEquation h := by
+  constructor
+  · intro hv
+    have := hv.centre_isPrime
+    have hmax : hv.centre.IsMaximal := Ideal.IsPrime.isMaximal hv.centre_isPrime hv.centre_ne_bot
+    obtain ⟨x, y, hxy, hXY⟩ :=
+      CoordinateRing.exists_eq_XYIdeal (W := W) (P := hv.centre) hv.centre_ne_bot
+    refine ⟨x, y, hxy, ?_⟩
+    set w : HeightOneSpectrum W.CoordinateRing := heightOneSpectrumOfEquation hxy with hw
+    set A : ValuationSubring W.FunctionField :=
+      HeightOneSpectrum.valuationSubringAtPrime W.FunctionField w with hA
+    have hAded : IsDedekindDomain A := by rw [hA]; infer_instance
+    have hle : A ≤ v.toValuationSubring := by
+      intro z hz
+      rw [hA] at hz
+      obtain ⟨r, s, hs, rfl⟩ := hz
+      have hs' : s ∉ hv.centre := by
+        intro hmem
+        rw [hXY] at hmem
+        exact hs hmem
+      exact mul_mem (hv r) (hv.inv_mem hs')
+    have hSP : A.ofPrime (A.idealOfLE v.toValuationSubring hle) = v.toValuationSubring :=
+      ValuationSubring.ofPrime_idealOfLE A v.toValuationSubring hle
+    rcases eq_or_ne (A.idealOfLE v.toValuationSubring hle) ⊥ with hP | hP
+    · exfalso
+      apply v.ne_top'
+      have h2 : A.ofPrime ⊥ ≤ A.ofPrime (A.idealOfLE v.toValuationSubring hle) :=
+        ValuationSubring.ofPrime_le_of_le (h := hP.le)
+      rw [ValuationSubring.ofPrime_bot] at h2
+      exact top_le_iff.mp (le_trans h2 hSP.le)
+    · have hPmax : (A.idealOfLE v.toValuationSubring hle).IsMaximal :=
+        Ideal.IsPrime.isMaximal inferInstance hP
+      have hPeq : A.idealOfLE v.toValuationSubring hle = IsLocalRing.maximalIdeal A :=
+        IsLocalRing.eq_maximalIdeal hPmax
+      have h3 : A.ofPrime (A.idealOfLE v.toValuationSubring hle)
+          = A.ofPrime (IsLocalRing.maximalIdeal A) :=
+        le_antisymm (ValuationSubring.ofPrime_le_of_le (h := hPeq.ge))
+          (ValuationSubring.ofPrime_le_of_le (h := hPeq.le))
+      rw [ValuationSubring.ofPrime_top] at h3
+      have hAv : A = v.toValuationSubring := h3.symm.trans hSP
+      refine (AlgebraicCurve.Place.ext ?_).symm
+      change (AlgebraicCurve.Place.ofHeightOneSpectrum w).toValuationSubring = v.toValuationSubring
+      rw [AlgebraicCurve.Place.ofHeightOneSpectrum_toValuationSubring,
+        ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact hAv
+  · rintro ⟨x, y, h, rfl⟩
+    exact isFinitePlace_placeOfEquation h
+
+scoped instance S13_instIsDedekindDomainCoordinateRing [IsAlgClosed F] [W.IsElliptic] :
+    IsDedekindDomain W.CoordinateRing :=
+  CoordinateRing.isDedekindDomain (W := W)
+
+section CentredGate
+
+variable [DecidableEq F] [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W]
+
+omit [DecidableEq F] in
+@[scoped simp]
+theorem placeOfPoint_some {x y : F} (h : W.Nonsingular x y) :
+    placeOfPoint (.some x y h) = placeOfEquation h.left := by
+  classical
+  exact
+    placeOfPoint_some_eq_ofHeightOneSpectrum h (heightOneSpectrumOfEquation h.left) rfl
+
+namespace InfinitePlace
+
+def place : AlgebraicCurve.Place F W.FunctionField := placeOfPoint (0 : W.Point)
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem deg_eq_one : (place : AlgebraicCurve.Place F W.FunctionField).deg = 1 := by
+  classical
+  exact
+    deg_placeOfPoint (W := W) 0
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] in
+theorem not_isFinitePlace [IsAlgClosed F] [W.IsElliptic] :
+    ¬ IsFinitePlace (place : AlgebraicCurve.Place F W.FunctionField) := by
+  classical
+  exact
+    fun h =>
+     algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero (W := W) (h _)
+
+omit [DecidableEq F] in
+theorem eq_of_not_isFinitePlace
+    (v : AlgebraicCurve.Place F W.FunctionField) (hv : ¬ IsFinitePlace v) :
+    v = place := by
+  classical
+  obtain ⟨P, rfl⟩ : ∃ P : W.Point, placeOfPoint P = v :=
+    ⟨(pointEquivPlace (W := W)).symm v, (pointEquivPlace (W := W)).apply_symm_apply v⟩
+  cases P with
+  | zero => rfl
+  | some x y h =>
+      exact absurd (placeOfPoint_some (W := W) h ▸ isFinitePlace_placeOfEquation h.left) hv
+
+end InfinitePlace
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+@[scoped simp]
+theorem placeOfPoint_zero : placeOfPoint (.zero : W.Point) = InfinitePlace.place := by
+  classical
+  exact
+    rfl
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_zero' : placeOfPoint (0 : W.Point) = InfinitePlace.place := by
+  classical
+  exact
+    rfl
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_injective : Function.Injective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).injective
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_surjective (_hΔ : W.Δ ≠ 0) : Function.Surjective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).surjective
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_surjective' : Function.Surjective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).surjective
+
+end CentredGate
+end WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  equation_iff' equation_neg CoordinateRing.XYIdeal map_a₃ CoordinateRing CoordinateRing.smul map \
+  CoordinateRing.YClass Nonsingular map_a₆ negY_negY FunctionField map_a₂ Point CoordinateRing.mk \
+  map_a₁ nonsingular_neg map_a₄ CoordinateRing.exists_smul_basis_eq CoordinateRing.XClass \
+  CoordinateRing.basis equation_iff polynomial Point.zero Point.neg_some \
+  pushforwardAlong_single_eq pushforwardAlongHom_pointClass pointMapOfPushforward IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField IsogenyEndDatum.exists_pointEnd_eq_add"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg \
+  P2MW.S_OVERLONG_7915af21.Algebr\
+  aicCurve"
+
+scoped instance instHasPrincipalDivisorsFunctionField_s13 {F : Type*} [Field F] [CharZero F]
+    {W : Affine F} : HasPrincipalDivisors F W.FunctionField :=
+  hasPrincipalDivisors_functionField W
+
+section AutoNorm
+variable {F : Type*} [Field F] [CharZero F]
+variable {V W : Affine F} [V.IsElliptic] [W.IsElliptic]
+
+omit [WeierstrassCurve.IsElliptic V] [WeierstrassCurve.IsElliptic W] in
+theorem normFormulaAlong_of_elliptic (ι : V.FunctionField →ₐ[F] W.FunctionField)
+    (hfin : FiniteAlong F ι) : NormFormulaAlong F ι hfin := by
+  classical
+  have : HasPrincipalDivisors F W.FunctionField := hasPrincipalDivisors_functionField W
+  have : CharZero V.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap F V.FunctionField).injective
+  have hsep : SeparableAlong F ι := by
+    let := algebraAlong ι
+    have := isScalarTower_along ι
+    have : Module.Finite V.FunctionField W.FunctionField := hfin
+    change Algebra.IsSeparable V.FunctionField W.FunctionField
+    infer_instance
+  exact AlgebraicCurve.normFormulaAlong ι hfin hsep
+
+end AutoNorm
+
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι exists_pointEnd_eq_add"
+p2m_open "WeierstrassCurve.Affine.IsogenyEndDatum"
+
+variable {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [GenusOnePlaceGate W] [AbelTheorem W]
+
+omit [DecidableEq F] [W.GenusOnePlaceGate] [W.AbelTheorem] in
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+private theorem _root_.WeierstrassCurve.Affine.IsogenyEndDatum.normFormulaAlong_auto (D :
+  IsogenyEndDatum W) :
+    NormFormulaAlong F D.ι D.hfin :=
+  normFormulaAlong_of_elliptic D.ι D.hfin
+
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "normFormulaAlong_auto"
+
+private def _root_.WeierstrassCurve.Affine.IsogenyEndDatum.pointEnd' (D : IsogenyEndDatum W) :
+    AddMonoid.End W.Point := D.pointEnd D.normFormulaAlong_auto
+
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd'"
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd_eq_pointEnd' (D : IsogenyEndDatum W) (hN : NormFormulaAlong F D.ι D.hfin) :
+    D.pointEnd hN = D.pointEnd' := rfl
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd'_apply (D : IsogenyEndDatum W) (P : W.Point) :
+    D.pointEnd' P = genusOnePic0Equiv W
+      (Pic0.pushforwardAlongHom D.ι D.hι D.hfin D.normFormulaAlong_auto (pointClass P)) :=
+  pointEnd_apply D _ P
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+private theorem _root_.WeierstrassCurve.Affine.IsogenyEndDatum.pointEnd'_eq_of_seam
+    (D : IsogenyEndDatum W) (g : W.Point → W.Point) (hg0 : g 0 = 0)
+    (hg : ∀ P, (placeOfPoint P).restrictAlong D.ι D.hι = placeOfPoint (g P)) (P : W.Point) :
+    D.pointEnd' P = g P :=
+  pointEnd_eq_of_seam D _ g hg0 hg P
+
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd'_eq_of_seam"
+end IsogenyEndDatum
+end WeierstrassCurve.Affine
+
+
+namespace AddMonoid
+p2m_export "AddMonoid" "mk ext"
+namespace End
+p2m_export "AddMonoid.End" "ext"
+end AddMonoid.End
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong Divisor.pushforwardAlong \
+  Place.ramificationIndexAlong Divisor.pushforwardAlong_single SeparableAlong \
+  Place.ramificationIndex_pos Place.restrictInclusion Place Place.ext Divisor HasPrincipalDivisors \
+  Pic Pic0 Pic0.mk Pic0.mk_surjective Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong \
+  Divisor.pushforwardAlong_pushforwardAlong'"
+end AlgebraicCurve
+namespace IntermediateField
+p2m_export "IntermediateField" "toAlgebra mk val lift inclusion ext algebraMap_apply comap mem_bot \
+  restrict map"
+end IntermediateField
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "HeightOneSpectrum.valuationSubringAtPrime HeightOneSpectrum.asIdeal \
+  HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring \
+  HeightOneSpectrum.eq_of_valuation_isEquiv_valuation mk HeightOneSpectrum"
+end IsDedekindDomain
+namespace IsLocalRing
+p2m_export "IsLocalRing" "ResidueField.map_comp eq_maximalIdeal ResidueField \
+  ResidueField.map_residue of_surjective maximalIdeal mem_maximalIdeal residue_surjective \
+  ResidueField.map residue"
+end IsLocalRing
+namespace Polynomial
+p2m_export "Polynomial" "C eval₂_sub X eval_mul coeff_add addHom_ext algebraMap_eq unique eval₂ \
+  aeval eval₂_add monomial eval₂_pow evalEval_C ext_iff degree factor aeval_C monic_X_pow_add \
+  degree_linear_le coeff_sub X_sub_C_ne_zero map eval₂_X comp algebra eval₂_mul coeff_C eval_pow \
+  algHom_ext sum infinite eval_X eval_C nontrivial flt X_ne_zero eval_sub C_mul_X_pow_eq_monomial \
+  aeval_X mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero map_comp algebraMap_apply C_neg \
+  coeff_C_mul eval_add evalEval inhabited ext coeff_X_pow content eval₂_C ring aeval_algHom_apply \
+  transcendental restriction eval"
+end Polynomial
+namespace Polynomial
+p2m_export "Polynomial" "C eval₂_sub X eval_mul coeff_add addHom_ext algebraMap_eq unique eval₂ \
+  aeval eval₂_add monomial eval₂_pow evalEval_C ext_iff degree factor aeval_C monic_X_pow_add \
+  degree_linear_le coeff_sub X_sub_C_ne_zero map eval₂_X comp algebra eval₂_mul coeff_C eval_pow \
+  algHom_ext sum infinite eval_X eval_C nontrivial flt X_ne_zero eval_sub C_mul_X_pow_eq_monomial \
+  aeval_X mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero map_comp algebraMap_apply C_neg \
+  coeff_C_mul eval_add evalEval inhabited ext coeff_X_pow content eval₂_C ring aeval_algHom_apply \
+  transcendental restriction eval"
+end Polynomial
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  equation_iff' equation_neg CoordinateRing.XYIdeal map_a₃ CoordinateRing CoordinateRing.smul map \
+  CoordinateRing.YClass Nonsingular map_a₆ negY_negY FunctionField map_a₂ Point CoordinateRing.mk \
+  map_a₁ nonsingular_neg map_a₄ CoordinateRing.exists_smul_basis_eq CoordinateRing.XClass \
+  CoordinateRing.basis equation_iff polynomial Point.zero Point.neg_some \
+  pushforwardAlong_single_eq pushforwardAlongHom_pointClass pointMapOfPushforward IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField IsogenyEndDatum.exists_pointEnd_eq_add"
+end WeierstrassCurve.Affine
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  equation_iff' equation_neg CoordinateRing.XYIdeal map_a₃ CoordinateRing CoordinateRing.smul map \
+  CoordinateRing.YClass Nonsingular map_a₆ negY_negY FunctionField map_a₂ Point CoordinateRing.mk \
+  map_a₁ nonsingular_neg map_a₄ CoordinateRing.exists_smul_basis_eq CoordinateRing.XClass \
+  CoordinateRing.basis equation_iff polynomial Point.zero Point.neg_some \
+  pushforwardAlong_single_eq pushforwardAlongHom_pointClass pointMapOfPushforward IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField IsogenyEndDatum.exists_pointEnd_eq_add"
+end WeierstrassCurve.Affine
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  equation_iff' equation_neg CoordinateRing.XYIdeal map_a₃ CoordinateRing CoordinateRing.smul map \
+  CoordinateRing.YClass Nonsingular map_a₆ negY_negY FunctionField map_a₂ Point CoordinateRing.mk \
+  map_a₁ nonsingular_neg map_a₄ CoordinateRing.exists_smul_basis_eq CoordinateRing.XClass \
+  CoordinateRing.basis equation_iff polynomial Point.zero Point.neg_some \
+  pushforwardAlong_single_eq pushforwardAlongHom_pointClass pointMapOfPushforward IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField IsogenyEndDatum.exists_pointEnd_eq_add"
+namespace Point
+p2m_export "WeierstrassCurve.Affine.Point" "add some neg_zero map_zero map zero neg_some mk neg"
+end WeierstrassCurve.Affine.Point
+namespace WithZero
+p2m_export "WithZero" "map coe lift inhabited one le"
+end WithZero
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine AddMonoid.End \
+  P2MW.S_OVERLONG_7915af21.AddMon\
+  oid.End"
+
+namespace ModularCurve
+
+universe u
+
+section NonzeroEndLift
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+
+abbrev KwIsogenyEndDatumOfNonzeroEnd (W : Affine F) [W.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+    :
+    Prop :=
+  ∀ ψ ∈ isogenyEndSubring W (fun D => D.normFormulaAlong_auto), ψ ≠ 0 → ∃ D' : IsogenyEndDatum W,
+    D'.pointEnd' = ψ
+
+end NonzeroEndLift
+end ModularCurve
+end
+
+
+section
+
+p2m_open "IsDedekindDomain \
+  P2MW.S_OVERLONG_7915af21.IsDede\
+  kindDomain"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong Divisor.pushforwardAlong \
+  Place.ramificationIndexAlong Divisor.pushforwardAlong_single SeparableAlong \
+  Place.ramificationIndex_pos Place.restrictInclusion Place Place.ext Divisor HasPrincipalDivisors \
+  Pic Pic0 Pic0.mk Pic0.mk_surjective Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong \
+  Divisor.pushforwardAlong_pushforwardAlong'"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg"
+
+
+section Tower
+
+variable {K F F' F'' : Type*} [Field K] [Field F] [Field F'] [Field F'']
+  [Algebra K F] [Algebra K F'] [Algebra K F'']
+variable (φ : F →ₐ[K] F') (χ : F' →ₐ[K] F'')
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong inertiaDegAlong \
+  ord_restrictAlong ramificationIndex_pos restrict restrict_toValuationSubring restrictInclusion \
+  ext ResidueField deg adicValuation_coe_eq_one_iff ord ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff"
+end Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+theorem Place.restrictAlong_restrictAlong (hφ : φ.toRingHom.IsIntegral)
+    (hχ : χ.toRingHom.IsIntegral) (hχφ : (χ.comp φ).toRingHom.IsIntegral)
+    (W : Place K F'') :
+    (W.restrictAlong χ hχ).restrictAlong φ hφ = W.restrictAlong (χ.comp φ) hχφ := by
+  exact Place.ext (SetLike.ext fun _ => Iff.rfl)
+
+variable (K) in
+def InertiaDegComp (hφ : φ.toRingHom.IsIntegral) (hχ : χ.toRingHom.IsIntegral)
+    (hχφ : (χ.comp φ).toRingHom.IsIntegral) : Prop :=
+  ∀ W : Place K F'',
+    W.inertiaDegAlong (χ.comp φ) hχφ
+      = W.inertiaDegAlong χ hχ * (W.restrictAlong χ hχ).inertiaDegAlong φ hφ
+
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "pushforwardAlong pushforwardAlong_single pushforward pullback \
+  degree pushforwardAlong_pushforwardAlong'"
+end Divisor
+p2m_open_scoped "AlgebraicCurve.Divisor" in
+theorem Divisor.pushforwardAlong_pushforwardAlong (hφ : φ.toRingHom.IsIntegral)
+    (hχ : χ.toRingHom.IsIntegral) (hχφ : (χ.comp φ).toRingHom.IsIntegral)
+    (hf : InertiaDegComp K φ χ hφ hχ hχφ) (D : Divisor K F'') :
+    Divisor.pushforwardAlong φ hφ (Divisor.pushforwardAlong χ hχ D)
+      = Divisor.pushforwardAlong (χ.comp φ) hχφ D := by
+  have key : (Divisor.pushforwardAlong φ hφ).comp (Divisor.pushforwardAlong χ hχ)
+      = Divisor.pushforwardAlong (χ.comp φ) hχφ := by
+    refine Finsupp.addHom_ext fun W n => ?_
+    change Divisor.pushforwardAlong φ hφ (Divisor.pushforwardAlong χ hχ (Finsupp.single W n))
+        = Divisor.pushforwardAlong (χ.comp φ) hχφ (Finsupp.single W n)
+    rw [Divisor.pushforwardAlong_single, Divisor.pushforwardAlong_single,
+      Divisor.pushforwardAlong_single, Place.restrictAlong_restrictAlong φ χ hφ hχ hχφ, hf W]
+    refine congrArg (Finsupp.single _) ?_
+    push_cast
+    ring
+  exact DFunLike.congr_fun key D
+
+end Tower
+end AlgebraicCurve
+end
+
+
+section
+
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg \
+  P2MW.S_OVERLONG_7915af21.Algebr\
+  aicCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  equation_iff' equation_neg CoordinateRing.XYIdeal map_a₃ CoordinateRing CoordinateRing.smul map \
+  CoordinateRing.YClass Nonsingular map_a₆ negY_negY FunctionField map_a₂ Point CoordinateRing.mk \
+  map_a₁ nonsingular_neg map_a₄ CoordinateRing.exists_smul_basis_eq CoordinateRing.XClass \
+  CoordinateRing.basis equation_iff polynomial Point.zero Point.neg_some \
+  pushforwardAlong_single_eq pushforwardAlongHom_pointClass pointMapOfPushforward IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField IsogenyEndDatum.exists_pointEnd_eq_add"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι exists_pointEnd_eq_add"
+p2m_open "WeierstrassCurve.Affine.IsogenyEndDatum"
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem isIntegral_algHomId :
+    (AlgHom.id F W.FunctionField).toRingHom.IsIntegral :=
+  RingHom.isIntegral_of_surjective _ Function.surjective_id
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem finiteAlong_algHomId : FiniteAlong F (AlgHom.id F W.FunctionField) := by
+  unfold FiniteAlong algebraAlong
+  exact Module.Finite.self _
+
+def idDatum : IsogenyEndDatum W where
+  ι := AlgHom.id F W.FunctionField
+  hι := isIntegral_algHomId W
+  hfin := finiteAlong_algHomId W
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem restrictAlong_algHomId (w : AlgebraicCurve.Place F W.FunctionField) :
+    w.restrictAlong (AlgHom.id F W.FunctionField) (isIntegral_algHomId W) = w :=
+  AlgebraicCurve.Place.ext (SetLike.ext fun _ => Iff.rfl)
+
+omit [GenusOnePlaceGate.IsCentred W] in
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem idDatum_pointEnd : (idDatum W).pointEnd' = 1 := by
+  refine AddMonoidHom.ext fun P => ?_
+  exact (idDatum W).pointEnd'_eq_of_seam id rfl (fun Q => restrictAlong_algHomId W _) P
+
+omit [GenusOnePlaceGate.IsCentred W] in
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem one_mem_range_pointEnd :
+    (1 : AddMonoid.End W.Point) ∈ Set.range (IsogenyEndDatum.pointEnd' (W := W)) :=
+  ⟨idDatum W, idDatum_pointEnd W⟩
+
+end IsogenyEndDatum
+
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι exists_pointEnd_eq_add"
+end IsogenyEndDatum
+end WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+end WeierstrassCurve
+
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+end WeierstrassCurve
+end
+
+
+section
+
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg \
+  P2MW.S_OVERLONG_7915af21.Algebr\
+  aicCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong Divisor.pushforwardAlong \
+  Place.ramificationIndexAlong Divisor.pushforwardAlong_single SeparableAlong \
+  Place.ramificationIndex_pos Place.restrictInclusion Place Place.ext Divisor HasPrincipalDivisors \
+  Pic Pic0 Pic0.mk Pic0.mk_surjective Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong \
+  Divisor.pushforwardAlong_pushforwardAlong'"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong inertiaDegAlong \
+  ord_restrictAlong ramificationIndex_pos restrict restrict_toValuationSubring restrictInclusion \
+  ext ResidueField deg adicValuation_coe_eq_one_iff ord ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem restrictAlong_comp (φ ψ : F →ₐ[K] F) (hφ : φ.toRingHom.IsIntegral)
+    (hψ : ψ.toRingHom.IsIntegral) (hcomp : (ψ.comp φ).toRingHom.IsIntegral)
+    (w : Place K F) :
+    w.restrictAlong (ψ.comp φ) hcomp = (w.restrictAlong ψ hψ).restrictAlong φ hφ := by
+  refine Place.ext (SetLike.ext fun x => ?_)
+  exact Iff.rfl
+
+end AlgebraicCurve.Place
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  equation_iff' equation_neg CoordinateRing.XYIdeal map_a₃ CoordinateRing CoordinateRing.smul map \
+  CoordinateRing.YClass Nonsingular map_a₆ negY_negY FunctionField map_a₂ Point CoordinateRing.mk \
+  map_a₁ nonsingular_neg map_a₄ CoordinateRing.exists_smul_basis_eq CoordinateRing.XClass \
+  CoordinateRing.basis equation_iff polynomial Point.zero Point.neg_some \
+  pushforwardAlong_single_eq pushforwardAlongHom_pointClass pointMapOfPushforward IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField IsogenyEndDatum.exists_pointEnd_eq_add"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι exists_pointEnd_eq_add"
+p2m_open "WeierstrassCurve.Affine.IsogenyEndDatum"
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem isIntegral_comp (D₁ D₂ : IsogenyEndDatum W) :
+    (D₂.ι.comp D₁.ι).toRingHom.IsIntegral :=
+  RingHom.IsIntegral.trans D₁.ι.toRingHom D₂.ι.toRingHom D₁.hι D₂.hι
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+private theorem _root_.WeierstrassCurve.Affine.IsogenyEndDatum.finiteAlong_comp (D₁ D₂ :
+  IsogenyEndDatum W) :
+    FiniteAlong F (D₂.ι.comp D₁.ι) :=
+  RingHom.Finite.comp (g := D₂.ι.toRingHom) (f := D₁.ι.toRingHom) D₂.hfin D₁.hfin
+
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "finiteAlong_comp"
+
+def compDatum (D₁ D₂ : IsogenyEndDatum W) : IsogenyEndDatum W where
+  ι := D₂.ι.comp D₁.ι
+  hι := isIntegral_comp W D₁ D₂
+  hfin := finiteAlong_comp W D₁ D₂
+
+end IsogenyEndDatum
+
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι exists_pointEnd_eq_add"
+end IsogenyEndDatum
+end WeierstrassCurve.Affine
+end
+
+
+section
+
+p2m_open "IsDedekindDomain \
+  P2MW.S_OVERLONG_7915af21.IsDede\
+  kindDomain WithZero \
+  P2MW.S_OVERLONG_7915af21.WithZe\
+  ro IsLocalRing \
+  P2MW.S_OVERLONG_7915af21.IsLoca\
+  lRing"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong Divisor.pushforwardAlong \
+  Place.ramificationIndexAlong Divisor.pushforwardAlong_single SeparableAlong \
+  Place.ramificationIndex_pos Place.restrictInclusion Place Place.ext Divisor HasPrincipalDivisors \
+  Pic Pic0 Pic0.mk Pic0.mk_surjective Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong \
+  Divisor.pushforwardAlong_pushforwardAlong'"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong inertiaDegAlong \
+  ord_restrictAlong ramificationIndex_pos restrict restrict_toValuationSubring restrictInclusion \
+  ext ResidueField deg adicValuation_coe_eq_one_iff ord ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff"
+end Place
+end AlgebraicCurve
+end
+
+section
+
+
+section
+
+namespace ModularCurve
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg \
+  P2MW.S_OVERLONG_7915af21.Algebr\
+  aicCurve"
+
+section Engines
+
+variable {K F F' F'' : Type*} [Field K] [Field F] [Field F'] [Field F'']
+variable [Algebra K F] [Algebra K F'] [Algebra K F'']
+
+theorem finiteAlong_comp {φ : F →ₐ[K] F'} {ψ : F' →ₐ[K] F''}
+    (hφ : FiniteAlong K φ) (hψ : FiniteAlong K ψ) : FiniteAlong K (ψ.comp φ) := by
+  let := algebraAlong φ
+  let := algebraAlong ψ
+  let := algebraAlong (ψ.comp φ)
+  have : IsScalarTower F F' F'' := IsScalarTower.of_algebraMap_eq fun _ => rfl
+  have : Module.Finite F F' := hφ
+  have : Module.Finite F' F'' := hψ
+  exact Module.Finite.trans F' F''
+
+end Engines
+end ModularCurve
+end
+end
+
+
+section
+
+p2m_open "IsDedekindDomain \
+  P2MW.S_OVERLONG_7915af21.IsDede\
+  kindDomain"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong Divisor.pushforwardAlong \
+  Place.ramificationIndexAlong Divisor.pushforwardAlong_single SeparableAlong \
+  Place.ramificationIndex_pos Place.restrictInclusion Place Place.ext Divisor HasPrincipalDivisors \
+  Pic Pic0 Pic0.mk Pic0.mk_surjective Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong \
+  Divisor.pushforwardAlong_pushforwardAlong'"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg"
+
+section InertiaTower
+
+variable {K F F' F'' : Type*} [Field K] [Field F] [Field F'] [Field F'']
+  [Algebra K F] [Algebra K F'] [Algebra K F'']
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong inertiaDegAlong \
+  ord_restrictAlong ramificationIndex_pos restrict restrict_toValuationSubring restrictInclusion \
+  ext ResidueField deg adicValuation_coe_eq_one_iff ord ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg"
+
+def restrictInclusionAlong (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral) (w : Place K F') :
+    (w.restrictAlong φ hφ).toValuationSubring →+* w.toValuationSubring :=
+  letI := algebraAlong φ
+  haveI := isScalarTower_along φ
+  haveI := isIntegral_along φ hφ
+  Place.restrictInclusion F w
+
+scoped instance (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral) (w : Place K F') :
+    IsLocalHom (restrictInclusionAlong φ hφ w) := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  exact inferInstanceAs (IsLocalHom (Place.restrictInclusion F w))
+
+def restrictResidueMapAlong (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') : (w.restrictAlong φ hφ).ResidueField →+* w.ResidueField :=
+  IsLocalRing.ResidueField.map (restrictInclusionAlong φ hφ w)
+
+variable (φ : F →ₐ[K] F') (χ : F' →ₐ[K] F'')
+
+theorem inertiaDegAlong_comp (hφ : φ.toRingHom.IsIntegral) (hχ : χ.toRingHom.IsIntegral)
+    (hχφ : (χ.comp φ).toRingHom.IsIntegral) :
+    InertiaDegComp K φ χ hφ hχ hχφ := by
+  intro W
+  set w : Place K F' := W.restrictAlong χ hχ with hw
+  let iA : Algebra (W.restrictAlong (χ.comp φ) hχφ).ResidueField W.ResidueField :=
+    (restrictResidueMapAlong (χ.comp φ) hχφ W).toAlgebra
+  let iB : Algebra w.ResidueField W.ResidueField :=
+    (restrictResidueMapAlong χ hχ W).toAlgebra
+  let iC : Algebra (W.restrictAlong (χ.comp φ) hχφ).ResidueField w.ResidueField :=
+    (restrictResidueMapAlong φ hφ w).toAlgebra
+  have : IsScalarTower (W.restrictAlong (χ.comp φ) hχφ).ResidueField
+      w.ResidueField W.ResidueField := by
+    refine IsScalarTower.of_algebraMap_eq fun x => ?_
+    obtain ⟨a, rfl⟩ := IsLocalRing.residue_surjective x
+    change restrictResidueMapAlong (χ.comp φ) hχφ W (IsLocalRing.residue _ a)
+      = restrictResidueMapAlong χ hχ W
+          (restrictResidueMapAlong φ hφ w (IsLocalRing.residue _ a))
+    rw [restrictResidueMapAlong, restrictResidueMapAlong, restrictResidueMapAlong,
+      IsLocalRing.ResidueField.map_residue, IsLocalRing.ResidueField.map_residue,
+      IsLocalRing.ResidueField.map_residue]
+    exact congrArg _ (Subtype.ext rfl)
+  change Module.finrank (W.restrictAlong (χ.comp φ) hχφ).ResidueField W.ResidueField
+    = Module.finrank w.ResidueField W.ResidueField
+        * Module.finrank (W.restrictAlong (χ.comp φ) hχφ).ResidueField w.ResidueField
+  rw [← Module.finrank_mul_finrank
+    (W.restrictAlong (χ.comp φ) hχφ).ResidueField w.ResidueField W.ResidueField]
+  exact Nat.mul_comm _ _
+
+private theorem _root_.AlgebraicCurve.Divisor.pushforwardAlong_pushforwardAlong'
+    (hφ : φ.toRingHom.IsIntegral) (hχ : χ.toRingHom.IsIntegral)
+    (hχφ : (χ.comp φ).toRingHom.IsIntegral) (D : Divisor K F'') :
+    Divisor.pushforwardAlong φ hφ (Divisor.pushforwardAlong χ hχ D)
+      = Divisor.pushforwardAlong (χ.comp φ) hχφ D :=
+  Divisor.pushforwardAlong_pushforwardAlong φ χ hφ hχ hχφ
+    (inertiaDegAlong_comp φ χ hφ hχ hχφ) D
+
+end Place
+end InertiaTower
+
+section JointFiber
+
+variable {K F F₁ F₂ Z : Type*} [Field K] [Field F] [Field F₁] [Field F₂] [Field Z]
+  [Algebra K F] [Algebra K F₁] [Algebra K F₂] [Algebra K Z]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong inertiaDegAlong \
+  ord_restrictAlong ramificationIndex_pos restrict restrict_toValuationSubring restrictInclusion \
+  ext ResidueField deg adicValuation_coe_eq_one_iff ord ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff"
+end Place
+end JointFiber
+end AlgebraicCurve
+end
+
+
+section
+
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg \
+  P2MW.S_OVERLONG_7915af21.Algebr\
+  aicCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  equation_iff' equation_neg CoordinateRing.XYIdeal map_a₃ CoordinateRing CoordinateRing.smul map \
+  CoordinateRing.YClass Nonsingular map_a₆ negY_negY FunctionField map_a₂ Point CoordinateRing.mk \
+  map_a₁ nonsingular_neg map_a₄ CoordinateRing.exists_smul_basis_eq CoordinateRing.XClass \
+  CoordinateRing.basis equation_iff polynomial Point.zero Point.neg_some \
+  pushforwardAlong_single_eq pushforwardAlongHom_pointClass pointMapOfPushforward IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField IsogenyEndDatum.exists_pointEnd_eq_add"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem Δ_ne_zero_of_isElliptic : W.Δ ≠ 0 := W.isUnit_Δ.ne_zero
+
+def placeOfPointEquiv : W.Point ≃ AlgebraicCurve.Place F W.FunctionField :=
+  Equiv.ofBijective placeOfPoint
+    ⟨placeOfPoint_injective, placeOfPoint_surjective (Δ_ne_zero_of_isElliptic W)⟩
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem placeOfPoint_placeOfPointEquiv_symm (w : AlgebraicCurve.Place F W.FunctionField) :
+    placeOfPoint ((placeOfPointEquiv W).symm w) = w :=
+  (placeOfPointEquiv W).apply_symm_apply w
+
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι exists_pointEnd_eq_add"
+p2m_open "WeierstrassCurve.Affine.IsogenyEndDatum"
+
+variable {W}
+
+private def _root_.WeierstrassCurve.Affine.IsogenyEndDatum.geomMorph (D : IsogenyEndDatum W) :
+    W.Point → W.Point :=
+  fun P => (placeOfPointEquiv W).symm ((placeOfPoint P).restrictAlong D.ι D.hι)
+
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "geomMorph"
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+private theorem _root_.WeierstrassCurve.Affine.IsogenyEndDatum.placeOfPoint_geomMorph
+    (D : IsogenyEndDatum W) (P : W.Point) :
+    (placeOfPoint P).restrictAlong D.ι D.hι = placeOfPoint (D.geomMorph P) :=
+  (placeOfPoint_placeOfPointEquiv_symm W _).symm
+
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "placeOfPoint_geomMorph"
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem geomMorph_compDatum (D₁ D₂ : IsogenyEndDatum W) (P : W.Point) :
+    (compDatum W D₁ D₂).geomMorph P = D₁.geomMorph (D₂.geomMorph P) := by
+  refine placeOfPoint_injective ?_
+  rw [← placeOfPoint_geomMorph, ← placeOfPoint_geomMorph, ← placeOfPoint_geomMorph]
+  exact Place.restrictAlong_comp D₁.ι D₂.ι D₁.hι D₂.hι (compDatum W D₁ D₂).hι (placeOfPoint P)
+
+end IsogenyEndDatum
+end WeierstrassCurve.Affine
+end
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_7915af21.Polyno\
+  mial IsDedekindDomain \
+  P2MW.S_OVERLONG_7915af21.IsDede\
+  kindDomain"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_7915af21.Polyno\
+  mial.Bivariate"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong Divisor.pushforwardAlong \
+  Place.ramificationIndexAlong Divisor.pushforwardAlong_single SeparableAlong \
+  Place.ramificationIndex_pos Place.restrictInclusion Place Place.ext Divisor HasPrincipalDivisors \
+  Pic Pic0 Pic0.mk Pic0.mk_surjective Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong \
+  Divisor.pushforwardAlong_pushforwardAlong'"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong inertiaDegAlong \
+  ord_restrictAlong ramificationIndex_pos restrict restrict_toValuationSubring restrictInclusion \
+  ext ResidueField deg adicValuation_coe_eq_one_iff ord ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff"
+end AlgebraicCurve.Place
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  equation_iff' equation_neg CoordinateRing.XYIdeal map_a₃ CoordinateRing CoordinateRing.smul map \
+  CoordinateRing.YClass Nonsingular map_a₆ negY_negY FunctionField map_a₂ Point CoordinateRing.mk \
+  map_a₁ nonsingular_neg map_a₄ CoordinateRing.exists_smul_basis_eq CoordinateRing.XClass \
+  CoordinateRing.basis equation_iff polynomial Point.zero Point.neg_some \
+  pushforwardAlong_single_eq pushforwardAlongHom_pointClass pointMapOfPushforward IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField IsogenyEndDatum.exists_pointEnd_eq_add"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine.CoordinateRing AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg \
+  P2MW.S_OVERLONG_7915af21.Algebr\
+  aicCurve"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+def polyToFunctionField (W : Affine F) : F[X] →+* W.FunctionField :=
+  (algebraMap W.CoordinateRing W.FunctionField).comp (algebraMap F[X] W.CoordinateRing)
+
+theorem polyToFunctionField_apply (p : F[X]) :
+    polyToFunctionField W p
+      = algebraMap W.CoordinateRing W.FunctionField (algebraMap F[X] W.CoordinateRing p) := rfl
+
+theorem algebraMap_smul_one (p : F[X]) :
+    algebraMap W.CoordinateRing W.FunctionField (p • (1 : W.CoordinateRing))
+      = polyToFunctionField W p := by
+  rw [polyToFunctionField_apply, smul, mul_one]
+  rfl
+
+theorem polyToFunctionField_injective : Function.Injective (polyToFunctionField W) := by
+  intro p q h
+  rw [polyToFunctionField_apply, polyToFunctionField_apply] at h
+  have h2 := IsFractionRing.injective W.CoordinateRing W.FunctionField h
+  have h0 : (p - q) • (1 : W.CoordinateRing) + (0 : F[X]) • CoordinateRing.mk W Y = 0 := by
+    rw [zero_smul, add_zero, sub_smul, ← Algebra.algebraMap_eq_smul_one,
+      ← Algebra.algebraMap_eq_smul_one, h2, sub_self]
+  exact sub_eq_zero.mp (smul_basis_eq_zero h0).1
+
+theorem polyToFunctionField_C (c : F) :
+    polyToFunctionField W (C c) = algebraMap F W.FunctionField c := by
+  rw [polyToFunctionField_apply,
+    show algebraMap F[X] W.CoordinateRing (C c) = algebraMap F W.CoordinateRing c from
+      (IsScalarTower.algebraMap_apply F F[X] W.CoordinateRing c).symm]
+  exact (IsScalarTower.algebraMap_apply F W.CoordinateRing W.FunctionField c).symm
+
+theorem polyToFunctionField_ne_zero {p : F[X]} (hp : p ≠ 0) :
+    polyToFunctionField W p ≠ 0 := by
+  intro h
+  exact hp (polyToFunctionField_injective (by simpa using h))
+
+theorem algebraMap_smul_basis (p q : F[X]) :
+    algebraMap W.CoordinateRing W.FunctionField
+        (p • (1 : W.CoordinateRing) + q • CoordinateRing.mk W Y)
+      = polyToFunctionField W p + polyToFunctionField W q
+          * algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) := by
+  rw [map_add, algebraMap_smul_one, smul, map_mul, polyToFunctionField_apply]
+  rfl
+
+variable (v : AlgebraicCurve.Place F W.FunctionField)
+
+theorem isFinitePlace_of_mem
+    (hx : polyToFunctionField W X ∈ v.toValuationSubring) : IsFinitePlace v := by
+  have hpoly : ∀ p : F[X], polyToFunctionField W p ∈ v.toValuationSubring := by
+    intro p
+    induction p using Polynomial.induction_on' with
+    | add f g hf hg => rw [map_add]; exact add_mem hf hg
+    | monomial n c =>
+        rw [← C_mul_X_pow_eq_monomial, map_mul, map_pow]
+        refine mul_mem ?_ (pow_mem hx n)
+        rw [polyToFunctionField_C]
+        exact v.algebraMap_mem' c
+  set η := algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) with hηdef
+  set c₁ : F[X] := C W.a₁ * X + C W.a₃ with hc₁def
+  set cb : F[X] := X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ with hcbdef
+  have hrel : η * η = polyToFunctionField W cb - polyToFunctionField W c₁ * η := by
+    have h1 := smul_basis_mul_Y (W' := W) 0 1
+    rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at h1
+    have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) h1
+    rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+    exact h2
+  have hy : η ∈ v.toValuationSubring := by
+    refine v.mem_of_eval_monic_eq_zero (P := Polynomial.X ^ 2
+      + (Polynomial.C (polyToFunctionField W c₁) * Polynomial.X
+        - Polynomial.C (polyToFunctionField W cb))) ?_ ?_ (x := η) ?_
+    · refine Polynomial.monic_X_pow_add (n := 2) ?_
+      rw [sub_eq_add_neg, ← Polynomial.C_neg]
+      refine lt_of_le_of_lt Polynomial.degree_linear_le ?_
+      exact_mod_cast Nat.one_lt_two
+    · intro i
+      rw [show (Polynomial.C (polyToFunctionField W c₁) * Polynomial.X : Polynomial _)
+          = Polynomial.C (polyToFunctionField W c₁) * Polynomial.X ^ 1 by ring]
+      simp only [Polynomial.coeff_add, Polynomial.coeff_sub, Polynomial.coeff_X_pow,
+        Polynomial.coeff_C_mul, Polynomial.coeff_C]
+      refine add_mem ?_ (sub_mem ?_ ?_)
+      · split <;> simp [v.toValuationSubring.one_mem, v.toValuationSubring.zero_mem]
+      · split
+        · rw [mul_one]; exact hpoly _
+        · rw [mul_zero]; exact v.toValuationSubring.zero_mem
+      · split
+        · exact hpoly _
+        · exact v.toValuationSubring.zero_mem
+    · simp only [Polynomial.eval_add, Polynomial.eval_sub, Polynomial.eval_pow,
+        Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_X]
+      rw [sq]
+      linear_combination hrel
+  intro r
+  obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq r
+  rw [algebraMap_smul_basis]
+  exact add_mem (hpoly p) (mul_mem (hpoly q) hy)
+
+theorem ord_X_neg_of_not_isFinitePlace (hv : ¬ IsFinitePlace v) :
+    v.ord (polyToFunctionField W X) < 0 := by
+  by_contra hcon
+  push Not at hcon
+  exact hv (isFinitePlace_of_mem v
+    (AlgebraicCurve.Place.mem_of_ord_nonneg v (polyToFunctionField_ne_zero Polynomial.X_ne_zero)
+      hcon))
+
+end WeierstrassCurve.Affine
+end
+
+
+section
+
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg \
+  P2MW.S_OVERLONG_7915af21.Algebr\
+  aicCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong Divisor.pushforwardAlong \
+  Place.ramificationIndexAlong Divisor.pushforwardAlong_single SeparableAlong \
+  Place.ramificationIndex_pos Place.restrictInclusion Place Place.ext Divisor HasPrincipalDivisors \
+  Pic Pic0 Pic0.mk Pic0.mk_surjective Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong \
+  Divisor.pushforwardAlong_pushforwardAlong'"
+namespace Pic0
+p2m_export "AlgebraicCurve.Pic0" "pushforwardAlongDegZero coe_pushforwardAlongDegZero \
+  pushforwardAlongHom pushforwardAlongHom_mk mk mk_surjective torsion"
+p2m_open "AlgebraicCurve.Pic0 AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg"
+
+variable {K F F' F'' : Type*} [Field K] [Field F] [Field F'] [Field F'']
+variable [Algebra K F] [Algebra K F'] [Algebra K F'']
+variable (φ : F →ₐ[K] F') (χ : F' →ₐ[K] F'')
+variable (hφ : φ.toRingHom.IsIntegral) (hχ : χ.toRingHom.IsIntegral)
+variable (hχφ : (χ.comp φ).toRingHom.IsIntegral)
+variable (hfinφ : FiniteAlong K φ) (hfinχ : FiniteAlong K χ) (hfinχφ : FiniteAlong K (χ.comp φ))
+variable (hNφ : NormFormulaAlong K φ hfinφ) (hNχ : NormFormulaAlong K χ hfinχ)
+variable (hNχφ : NormFormulaAlong K (χ.comp φ) hfinχφ)
+
+theorem pushforwardAlongHom_comp_apply (c : Pic0 K F'') :
+    Pic0.pushforwardAlongHom (χ.comp φ) hχφ hfinχφ hNχφ c
+      = Pic0.pushforwardAlongHom φ hφ hfinφ hNφ
+          (Pic0.pushforwardAlongHom χ hχ hfinχ hNχ c) := by
+  obtain ⟨D, rfl⟩ := Pic0.mk_surjective c
+  rw [Pic0.pushforwardAlongHom_mk, Pic0.pushforwardAlongHom_mk, Pic0.pushforwardAlongHom_mk]
+  exact congrArg Pic0.mk (Subtype.ext
+    (Divisor.pushforwardAlong_pushforwardAlong' φ χ hφ hχ hχφ D).symm)
+
+end AlgebraicCurve.Pic0
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  equation_iff' equation_neg CoordinateRing.XYIdeal map_a₃ CoordinateRing CoordinateRing.smul map \
+  CoordinateRing.YClass Nonsingular map_a₆ negY_negY FunctionField map_a₂ Point CoordinateRing.mk \
+  map_a₁ nonsingular_neg map_a₄ CoordinateRing.exists_smul_basis_eq CoordinateRing.XClass \
+  CoordinateRing.basis equation_iff polynomial Point.zero Point.neg_some \
+  pushforwardAlong_single_eq pushforwardAlongHom_pointClass pointMapOfPushforward IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField IsogenyEndDatum.exists_pointEnd_eq_add"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι exists_pointEnd_eq_add"
+p2m_open "WeierstrassCurve.Affine.IsogenyEndDatum"
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem isIntegral_comp_ι (D₁ D₂ : IsogenyEndDatum W) :
+    (D₂.ι.comp D₁.ι).toRingHom.IsIntegral :=
+  RingHom.IsIntegral.trans (f := D₁.ι.toRingHom) (g := D₂.ι.toRingHom) D₁.hι D₂.hι
+
+private def _root_.WeierstrassCurve.Affine.IsogenyEndDatum.comp (D₁ D₂ : IsogenyEndDatum W) :
+    IsogenyEndDatum W where
+  ι := D₂.ι.comp D₁.ι
+  hι := isIntegral_comp_ι D₁ D₂
+  hfin := ModularCurve.finiteAlong_comp D₁.hfin D₂.hfin
+
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "comp"
+
+omit [GenusOnePlaceGate.IsCentred W] in
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem comp_pointEnd (D₁ D₂ : IsogenyEndDatum W) :
+    (D₁.comp D₂).pointEnd' = D₁.pointEnd' * D₂.pointEnd' := by
+  refine AddMonoidHom.ext fun P => ?_
+  change pointMapOfPushforward (D₂.ι.comp D₁.ι) (isIntegral_comp_ι D₁ D₂)
+      (ModularCurve.finiteAlong_comp D₁.hfin D₂.hfin) _ P
+    = pointMapOfPushforward D₁.ι D₁.hι D₁.hfin _
+        (pointMapOfPushforward D₂.ι D₂.hι D₂.hfin _ P)
+  change genusOnePic0Equiv W (Pic0.pushforwardAlongHom (D₂.ι.comp D₁.ι) _ _ _
+        ((genusOnePic0Equiv W).symm P))
+    = genusOnePic0Equiv W (Pic0.pushforwardAlongHom D₁.ι _ _ _
+        ((genusOnePic0Equiv W).symm
+          (genusOnePic0Equiv W (Pic0.pushforwardAlongHom D₂.ι _ _ _
+            ((genusOnePic0Equiv W).symm P)))))
+  rw [AddEquiv.symm_apply_apply]
+  exact congrArg (genusOnePic0Equiv W)
+    (Pic0.pushforwardAlongHom_comp_apply D₁.ι D₂.ι D₁.hι D₂.hι (isIntegral_comp_ι D₁ D₂)
+      D₁.hfin D₂.hfin (ModularCurve.finiteAlong_comp D₁.hfin D₂.hfin)
+      (normFormulaAlong_of_elliptic D₁.ι D₁.hfin)
+      (normFormulaAlong_of_elliptic D₂.ι D₂.hfin)
+      (normFormulaAlong_of_elliptic (D₂.ι.comp D₁.ι) (ModularCurve.finiteAlong_comp D₁.hfin
+        D₂.hfin))
+      ((genusOnePic0Equiv W).symm P))
+
+omit [GenusOnePlaceGate.IsCentred W] in
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem mul_mem_range_pointEnd
+    {f g : AddMonoid.End W.Point}
+    (hf : f ∈ Set.range (IsogenyEndDatum.pointEnd' (W := W)))
+    (hg : g ∈ Set.range (IsogenyEndDatum.pointEnd' (W := W))) :
+    f * g ∈ Set.range (IsogenyEndDatum.pointEnd' (W := W)) := by
+  obtain ⟨D₁, rfl⟩ := hf
+  obtain ⟨D₂, rfl⟩ := hg
+  exact ⟨D₁.comp D₂, comp_pointEnd D₁ D₂⟩
+
+end IsogenyEndDatum
+
+variable (W)
+
+def isogenyEndSubmonoid : Submonoid (AddMonoid.End W.Point) where
+  carrier := Set.range (IsogenyEndDatum.pointEnd' (W := W))
+  one_mem' := IsogenyEndDatum.one_mem_range_pointEnd W
+  mul_mem' := IsogenyEndDatum.mul_mem_range_pointEnd
+
+omit [GenusOnePlaceGate.IsCentred W] in
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+@[scoped simp] theorem coe_isogenyEndSubmonoid :
+    (isogenyEndSubmonoid W : Set (AddMonoid.End W.Point))
+      = Set.range (IsogenyEndDatum.pointEnd' (W := W)) := rfl
+
+omit [GenusOnePlaceGate.IsCentred W] in
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem submonoid_closure_range_pointEnd :
+    Submonoid.closure (Set.range (IsogenyEndDatum.pointEnd' (W := W)))
+      = isogenyEndSubmonoid W := by
+  rw [← coe_isogenyEndSubmonoid]; exact Submonoid.closure_eq _
+
+omit [GenusOnePlaceGate.IsCentred W] in
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem coe_submonoid_closure_range_pointEnd :
+    (Submonoid.closure (Set.range (IsogenyEndDatum.pointEnd' (W := W)))
+        : Set (AddMonoid.End W.Point))
+      = Set.range (IsogenyEndDatum.pointEnd' (W := W)) :=
+  congrArg SetLike.coe (submonoid_closure_range_pointEnd W)
+
+omit [GenusOnePlaceGate.IsCentred W] in
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem mem_isogenyEndSubring_iff_mem_addSubgroup_closure {f : AddMonoid.End W.Point} :
+    f ∈ isogenyEndSubring W (fun D => D.normFormulaAlong_auto) ↔
+      f ∈ AddSubgroup.closure (Set.range (IsogenyEndDatum.pointEnd' (W := W))) := by
+  rw [show f ∈ isogenyEndSubring W (fun D => D.normFormulaAlong_auto) ↔
+      f ∈ Subring.closure (Set.range (IsogenyEndDatum.pointEnd' (W := W))) from Iff.rfl,
+    Subring.mem_closure_iff, coe_submonoid_closure_range_pointEnd]
+
+end WeierstrassCurve.Affine
+end
+
+
+section
+
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg \
+  P2MW.S_OVERLONG_7915af21.Algebr\
+  aicCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  equation_iff' equation_neg CoordinateRing.XYIdeal map_a₃ CoordinateRing CoordinateRing.smul map \
+  CoordinateRing.YClass Nonsingular map_a₆ negY_negY FunctionField map_a₂ Point CoordinateRing.mk \
+  map_a₁ nonsingular_neg map_a₄ CoordinateRing.exists_smul_basis_eq CoordinateRing.XClass \
+  CoordinateRing.basis equation_iff polynomial Point.zero Point.neg_some \
+  pushforwardAlong_single_eq pushforwardAlongHom_pointClass pointMapOfPushforward IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField IsogenyEndDatum.exists_pointEnd_eq_add"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [GenusOnePlaceGate W]
+    [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem]
+
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι exists_pointEnd_eq_add"
+p2m_open "WeierstrassCurve.Affine.IsogenyEndDatum"
+
+variable {W}
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem pushforwardAlongDegZero_pointDivisor_geomMorph (D : IsogenyEndDatum W)
+    (P : W.Point) :
+    Pic0.pushforwardAlongDegZero D.ι D.hι (pointDivisor P)
+      = pointDivisor (D.geomMorph P) - pointDivisor (D.geomMorph 0) := by
+  refine Subtype.ext ?_
+  rw [Pic0.coe_pushforwardAlongDegZero, coe_pointDivisor, map_sub,
+    pushforwardAlong_single_eq D.ι D.hι, pushforwardAlong_single_eq D.ι D.hι,
+    D.placeOfPoint_geomMorph P, D.placeOfPoint_geomMorph 0]
+  push_cast
+  rw [coe_pointDivisor, coe_pointDivisor, sub_sub_sub_cancel_right]
+
+omit [DecidableEq F] [IsAlgClosed F] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem pushforwardAlongHom_pointClass_eq_sub (D : IsogenyEndDatum W) (P : W.Point) :
+    Pic0.pushforwardAlongHom D.ι D.hι D.hfin (normFormulaAlong_of_elliptic D.ι D.hfin)
+        (pointClass P)
+      = pointClass (D.geomMorph P) - pointClass (D.geomMorph 0) := by
+  change Pic0.pushforwardAlongHom D.ι D.hι D.hfin _ (Pic0.mk (pointDivisor P))
+      = Pic0.mk (pointDivisor (D.geomMorph P)) - Pic0.mk (pointDivisor (D.geomMorph 0))
+  rw [Pic0.pushforwardAlongHom_mk, pushforwardAlongDegZero_pointDivisor_geomMorph D P]
+  rfl
+
+omit [IsAlgClosed F] [GenusOnePlaceGate.IsCentred W] in
+theorem pointEnd_eq_geomMorph_sub_geomMorph_zero (D : IsogenyEndDatum W) (P : W.Point) :
+    D.pointEnd' P = D.geomMorph P - D.geomMorph 0 := by
+  rw [IsogenyEndDatum.pointEnd'_apply, pushforwardAlongHom_pointClass_eq_sub D P, map_sub,
+    genusOnePic0Equiv_apply, genusOnePic0Equiv_apply, pic0ToPoint_pointClass,
+    pic0ToPoint_pointClass]
+
+omit [IsAlgClosed F] [GenusOnePlaceGate.IsCentred W] in
+theorem geomMorph_eq_pointEnd_add_geomMorph_zero (D : IsogenyEndDatum W) (P : W.Point) :
+    D.geomMorph P = D.pointEnd' P + D.geomMorph 0 := by
+  rw [pointEnd_eq_geomMorph_sub_geomMorph_zero, sub_add_cancel]
+
+omit [IsAlgClosed F] [GenusOnePlaceGate.IsCentred W] in
+theorem geomMorph_add_geomMorph_zero (D : IsogenyEndDatum W) (P Q : W.Point) :
+    D.geomMorph (P + Q) + D.geomMorph 0 = D.geomMorph P + D.geomMorph Q := by
+  rw [geomMorph_eq_pointEnd_add_geomMorph_zero D (P + Q),
+    geomMorph_eq_pointEnd_add_geomMorph_zero D P,
+    geomMorph_eq_pointEnd_add_geomMorph_zero D Q,
+    show D.pointEnd' (P + Q) = D.pointEnd' P + D.pointEnd' Q from map_add _ P Q]
+  abel
+
+omit [IsAlgClosed F] [GenusOnePlaceGate.IsCentred W] in
+theorem geomMorph_sub (D : IsogenyEndDatum W) (P Q : W.Point) :
+    D.geomMorph (P - Q) = D.geomMorph P - D.geomMorph Q + D.geomMorph 0 := by
+  have h := geomMorph_add_geomMorph_zero D (P - Q) Q
+  rw [sub_add_cancel] at h
+  rw [eq_sub_of_add_eq h.symm, add_sub_right_comm]
+
+omit [IsAlgClosed F] [GenusOnePlaceGate.IsCentred W] in
+theorem compDatum_pointEnd (D₁ D₂ : IsogenyEndDatum W) :
+    (compDatum W D₁ D₂).pointEnd' = D₁.pointEnd' * D₂.pointEnd' := by
+  refine AddMonoidHom.ext fun P => ?_
+  change (compDatum W D₁ D₂).pointEnd' P = D₁.pointEnd' (D₂.pointEnd' P)
+  rw [pointEnd_eq_geomMorph_sub_geomMorph_zero (compDatum W D₁ D₂) P,
+    geomMorph_compDatum D₁ D₂ P, geomMorph_compDatum D₁ D₂ 0,
+    pointEnd_eq_geomMorph_sub_geomMorph_zero D₁ (D₂.pointEnd' P),
+    pointEnd_eq_geomMorph_sub_geomMorph_zero D₂ P, geomMorph_sub D₁]
+  abel
+
+end IsogenyEndDatum
+end WeierstrassCurve.Affine
+end
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_7915af21.Polyno\
+  mial IsDedekindDomain \
+  P2MW.S_OVERLONG_7915af21.IsDede\
+  kindDomain"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_7915af21.Polyno\
+  mial.Bivariate"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong Divisor.pushforwardAlong \
+  Place.ramificationIndexAlong Divisor.pushforwardAlong_single SeparableAlong \
+  Place.ramificationIndex_pos Place.restrictInclusion Place Place.ext Divisor HasPrincipalDivisors \
+  Pic Pic0 Pic0.mk Pic0.mk_surjective Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong \
+  Divisor.pushforwardAlong_pushforwardAlong'"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg"
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+
+p2m_open_scoped "AlgebraicCurve.Place" in
+theorem Place.mem_restrictAlong_iff (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') (f : F) :
+    f ∈ (w.restrictAlong φ hφ).toValuationSubring ↔ φ f ∈ w.toValuationSubring :=
+  Iff.rfl
+
+p2m_open_scoped "AlgebraicCurve.Place" in
+theorem Place.ramificationIndexAlong_pos (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') : 0 < Place.ramificationIndexAlong φ w := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  exact w.ramificationIndex_pos
+
+p2m_open_scoped "AlgebraicCurve.Place" in
+theorem Place.ord_restrictAlong_ne_zero_iff (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') (f : F) :
+    (w.restrictAlong φ hφ).ord f ≠ 0 ↔ w.ord (φ f) ≠ 0 := by
+  rw [w.ord_restrictAlong φ hφ f]
+  have hpos := Place.ramificationIndexAlong_pos φ hφ w
+  constructor
+  · intro h hcon
+    rcases mul_eq_zero.mp hcon with h1 | h1
+    · omega
+    · exact h h1
+  · intro h hcon
+    exact h (by rw [hcon, mul_zero])
+
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  equation_iff' equation_neg CoordinateRing.XYIdeal map_a₃ CoordinateRing CoordinateRing.smul map \
+  CoordinateRing.YClass Nonsingular map_a₆ negY_negY FunctionField map_a₂ Point CoordinateRing.mk \
+  map_a₁ nonsingular_neg map_a₄ CoordinateRing.exists_smul_basis_eq CoordinateRing.XClass \
+  CoordinateRing.basis equation_iff polynomial Point.zero Point.neg_some \
+  pushforwardAlong_single_eq pushforwardAlongHom_pointClass pointMapOfPushforward IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField IsogenyEndDatum.exists_pointEnd_eq_add"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine.CoordinateRing AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg \
+  P2MW.S_OVERLONG_7915af21.Algebr\
+  aicCurve"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem algebraMap_polynomial_eq_mk_C (p : F[X]) :
+    algebraMap F[X] W.CoordinateRing p = CoordinateRing.mk W (C p) :=
+  rfl
+
+theorem algebraMap_coordinateRing_ne_zero {r : W.CoordinateRing} (hr : r ≠ 0) :
+    algebraMap W.CoordinateRing W.FunctionField r ≠ 0 :=
+  (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr hr
+
+theorem mk_mem_XYIdeal_iff {x y : F} (h : W.Equation x y) (P : F[X][Y]) :
+    CoordinateRing.mk W P ∈ XYIdeal W x (C y) ↔ P.evalEval x y = 0 := by
+  have hmap : XYIdeal W x (C y)
+      = Ideal.map (CoordinateRing.mk W) (Ideal.span {C (X - C x), Y - C (C y)}) := by
+    rw [Ideal.map_span, Set.image_pair]
+    rfl
+  rw [hmap]
+  constructor
+  · intro hP
+    obtain ⟨Q, hQ, hQP⟩ := (Ideal.mem_map_iff_of_surjective _ AdjoinRoot.mk_surjective).mp hP
+    obtain ⟨c, hc⟩ := AdjoinRoot.mk_eq_mk.mp hQP
+    have hQ0 : Q.evalEval x y = 0 :=
+      mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero.mp hQ
+    have hW0 : W.polynomial.evalEval x y = 0 := h
+    have hPQ : P = Q - W.polynomial * c := by rw [← hc]; ring
+    rw [hPQ]
+    simp only [evalEval, eval_sub, eval_mul] at hQ0 hW0 ⊢
+    rw [hQ0, hW0, zero_mul, sub_zero]
+  · intro hP
+    exact Ideal.mem_map_of_mem _ (mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero.mpr hP)
+
+theorem ord_placeOfEquation_ne_zero_iff [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) {r : W.CoordinateRing} (hr : r ≠ 0) :
+    (placeOfEquation h).ord (algebraMap W.CoordinateRing W.FunctionField r) ≠ 0
+      ↔ r ∈ XYIdeal W x (C y) := by
+  rw [placeOfEquation, Place.ord_ofHeightOneSpectrum_ne_zero_iff _ hr,
+    heightOneSpectrumOfEquation_asIdeal]
+
+theorem ord_placeOfEquation_nonneg [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) (r : W.CoordinateRing) :
+    0 ≤ (placeOfEquation h).ord (algebraMap W.CoordinateRing W.FunctionField r) :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem (placeOfEquation h) (isFinitePlace_placeOfEquation h r)
+
+theorem ord_placeOfEquation_pos_iff [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) {r : W.CoordinateRing} (hr : r ≠ 0) :
+    0 < (placeOfEquation h).ord (algebraMap W.CoordinateRing W.FunctionField r)
+      ↔ r ∈ XYIdeal W x (C y) := by
+  rw [← ord_placeOfEquation_ne_zero_iff h hr]
+  have := ord_placeOfEquation_nonneg h r
+  omega
+
+theorem IsFinitePlace.mem_centre_iff_ord_ne_zero {v : Place F W.FunctionField}
+    (hv : IsFinitePlace v) {r : W.CoordinateRing} (hr : r ≠ 0) :
+    r ∈ hv.centre ↔ v.ord (algebraMap W.CoordinateRing W.FunctionField r) ≠ 0 := by
+  have hr' : algebraMap W.CoordinateRing W.FunctionField r ≠ 0 :=
+    algebraMap_coordinateRing_ne_zero hr
+  rw [IsFinitePlace.centre, Ideal.mem_comap, IsLocalRing.mem_maximalIdeal, mem_nonunits_iff,
+    ne_eq, v.ord_eq_zero_iff_adicValuation_eq_one hr']
+  exact not_congr (v.adicValuation_coe_eq_one_iff (hv.ringHom r)).symm
+
+theorem centre_placeOfEquation [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) :
+    (isFinitePlace_placeOfEquation h).centre = XYIdeal W x (C y) := by
+  ext r
+  rcases eq_or_ne r 0 with rfl | hr
+  · simp only [Submodule.zero_mem]
+  rw [(isFinitePlace_placeOfEquation h).mem_centre_iff_ord_ne_zero hr,
+    ord_placeOfEquation_ne_zero_iff h hr]
+
+theorem eq_placeOfEquation_of_le_centre [IsAlgClosed F] [IsDedekindDomain W.CoordinateRing]
+    {v : Place F W.FunctionField} (hv : IsFinitePlace v) {x y : F} (h : W.Equation x y)
+    (hle : XYIdeal W x (C y) ≤ hv.centre) : v = placeOfEquation h := by
+  obtain ⟨x', y', h', hveq⟩ := (isFinitePlace_iff_exists_placeOfEquation v).mp hv
+  subst hveq
+  have hc : hv.centre = XYIdeal W x' (C y') := by
+    rw [Subsingleton.elim hv (isFinitePlace_placeOfEquation h')]
+    exact centre_placeOfEquation h'
+  rw [hc] at hle
+  have heq : XYIdeal W x (C y) = XYIdeal W x' (C y') :=
+    (CoordinateRing.XYIdeal_isMaximal h).eq_of_le (CoordinateRing.XYIdeal_isMaximal h').ne_top
+      hle
+  obtain ⟨rfl, rfl⟩ := CoordinateRing.eq_of_XYIdeal_eq h' heq
+  rfl
+
+end WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  equation_iff' equation_neg CoordinateRing.XYIdeal map_a₃ CoordinateRing CoordinateRing.smul map \
+  CoordinateRing.YClass Nonsingular map_a₆ negY_negY FunctionField map_a₂ Point CoordinateRing.mk \
+  map_a₁ nonsingular_neg map_a₄ CoordinateRing.exists_smul_basis_eq CoordinateRing.XClass \
+  CoordinateRing.basis equation_iff polynomial Point.zero Point.neg_some \
+  pushforwardAlong_single_eq pushforwardAlongHom_pointClass pointMapOfPushforward IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField IsogenyEndDatum.exists_pointEnd_eq_add"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine.CoordinateRing AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg \
+  P2MW.S_OVERLONG_7915af21.Algebr\
+  aicCurve"
+
+variable {F : Type*} [Field F] (W : Affine F)
+
+variable {W}
+
+def yGen (W : Affine F) : W.FunctionField :=
+  algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+
+section OrdAtPoint
+
+variable [IsDedekindDomain W.CoordinateRing]
+
+theorem ord_polyToFunctionField_pos_iff {x y : F} (h : W.Equation x y) {p : F[X]}
+    (hp : p ≠ 0) :
+    0 < (placeOfEquation h).ord (polyToFunctionField W p) ↔ p.eval x = 0 := by
+  rw [polyToFunctionField_apply, algebraMap_polynomial_eq_mk_C,
+    ord_placeOfEquation_pos_iff h (fun hcon => polyToFunctionField_ne_zero hp
+      (by rw [polyToFunctionField_apply, algebraMap_polynomial_eq_mk_C, hcon, _root_.map_zero])),
+    mk_mem_XYIdeal_iff h, Polynomial.evalEval_C]
+
+end OrdAtPoint
+end WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  equation_iff' equation_neg CoordinateRing.XYIdeal map_a₃ CoordinateRing CoordinateRing.smul map \
+  CoordinateRing.YClass Nonsingular map_a₆ negY_negY FunctionField map_a₂ Point CoordinateRing.mk \
+  map_a₁ nonsingular_neg map_a₄ CoordinateRing.exists_smul_basis_eq CoordinateRing.XClass \
+  CoordinateRing.basis equation_iff polynomial Point.zero Point.neg_some \
+  pushforwardAlong_single_eq pushforwardAlongHom_pointClass pointMapOfPushforward IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField IsogenyEndDatum.exists_pointEnd_eq_add"
+end WeierstrassCurve.Affine
+end
+
+section
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_7915af21.Polyno\
+  mial WeierstrassCurve \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_7915af21.Polyno\
+  mial.Bivariate"
+
+universe u
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  equation_iff' equation_neg CoordinateRing.XYIdeal map_a₃ CoordinateRing CoordinateRing.smul map \
+  CoordinateRing.YClass Nonsingular map_a₆ negY_negY FunctionField map_a₂ Point CoordinateRing.mk \
+  map_a₁ nonsingular_neg map_a₄ CoordinateRing.exists_smul_basis_eq CoordinateRing.XClass \
+  CoordinateRing.basis equation_iff polynomial Point.zero Point.neg_some \
+  pushforwardAlong_single_eq pushforwardAlongHom_pointClass pointMapOfPushforward IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField IsogenyEndDatum.exists_pointEnd_eq_add"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine.CoordinateRing"
+
+variable {F : Type u} [Field F]
+
+
+section GenericTorsionFree
+
+variable [CharZero F] {W : Affine F}
+
+local notation "ι" => algebraMap F W.FunctionField
+
+end GenericTorsionFree
+
+section MulCoords
+
+variable [CharZero F] {W : Affine F}
+
+local notation "ι" => algebraMap F W.FunctionField
+
+end MulCoords
+
+section Transcendence
+
+variable [CharZero F] [IsAlgClosed F] {W : Affine F}
+
+local notation "ι" => algebraMap F W.FunctionField
+
+end Transcendence
+
+section PointPullback
+
+variable {W : Affine F}
+
+local notation "ι" => algebraMap F W.FunctionField
+
+theorem eval₂_polynomial_of_equation_map {xP yP : W.FunctionField}
+    (h : (W.map ι).toAffine.Equation xP yP) :
+    W.polynomial.eval₂
+      (Polynomial.aeval xP : F[X] →ₐ[F] W.FunctionField).toRingHom yP = 0 := by
+  rw [equation_iff'] at h
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆] at h
+  simp only [WeierstrassCurve.Affine.polynomial, eval₂_add, eval₂_sub, eval₂_mul, eval₂_pow,
+    eval₂_X, eval₂_C, AlgHom.toRingHom_eq_coe, RingHom.coe_coe, map_add, map_mul, map_pow,
+    Polynomial.aeval_C, Polynomial.aeval_X]
+  linear_combination h
+
+def pointPullbackCoordHom {xP yP : W.FunctionField}
+    (h : (W.map ι).toAffine.Equation xP yP) :
+    W.CoordinateRing →ₐ[F] W.FunctionField where
+  __ := AdjoinRoot.lift
+    (Polynomial.aeval xP : F[X] →ₐ[F] W.FunctionField).toRingHom
+    yP (eval₂_polynomial_of_equation_map h)
+  commutes' c := by
+    change AdjoinRoot.lift _ _ (eval₂_polynomial_of_equation_map h) (algebraMap F _ c)
+      = algebraMap F W.FunctionField c
+    rw [CoordinateRing.algebraMap_eq_mk_C_C, AdjoinRoot.lift_mk, eval₂_C]
+    exact Polynomial.aeval_C _ c
+
+theorem pointPullbackCoordHom_mk {xP yP : W.FunctionField}
+    (h : (W.map ι).toAffine.Equation xP yP) (g : F[X][Y]) :
+    pointPullbackCoordHom h (CoordinateRing.mk W g)
+      = g.eval₂ (Polynomial.aeval xP : F[X] →ₐ[F] W.FunctionField).toRingHom yP :=
+  AdjoinRoot.lift_mk (eval₂_polynomial_of_equation_map h) g
+
+theorem pointPullbackCoordHom_comp_algebraMap {xP yP : W.FunctionField}
+    (h : (W.map ι).toAffine.Equation xP yP) :
+    (pointPullbackCoordHom h).toRingHom.comp (algebraMap F[X] W.CoordinateRing)
+      = (Polynomial.aeval xP : F[X] →ₐ[F] W.FunctionField).toRingHom := by
+  refine RingHom.ext fun p => ?_
+  change pointPullbackCoordHom h (algebraMap F[X] _ p) = _
+  rw [algebraMap_polynomial_eq_mk_C, pointPullbackCoordHom_mk, eval₂_C]
+
+theorem pointPullbackCoordHom_injective {xP yP : W.FunctionField}
+    (h : (W.map ι).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    Function.Injective (pointPullbackCoordHom h) := by
+  have hker : RingHom.ker (pointPullbackCoordHom h).toRingHom = ⊥ := by
+    have : Module.Finite F[X] W.CoordinateRing :=
+      Module.Finite.of_basis (CoordinateRing.basis W)
+    refine Ideal.eq_bot_of_under_eq_bot (R := F[X]) ?_
+    rw [Ideal.under_def, RingHom.comap_ker, pointPullbackCoordHom_comp_algebraMap,
+      ← RingHom.injective_iff_ker_eq_bot]
+    exact hx
+  exact (RingHom.injective_iff_ker_eq_bot (pointPullbackCoordHom h).toRingHom).mpr hker
+
+def pointPullbackHom {xP yP : W.FunctionField}
+    (h : (W.map ι).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    W.FunctionField →ₐ[F] W.FunctionField :=
+  IsFractionRing.liftAlgHom (pointPullbackCoordHom_injective h hx)
+
+theorem pointPullbackHom_algebraMap {xP yP : W.FunctionField}
+    (h : (W.map ι).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) (r : W.CoordinateRing) :
+    pointPullbackHom h hx (algebraMap W.CoordinateRing W.FunctionField r)
+      = pointPullbackCoordHom h r :=
+  IsFractionRing.lift_algebraMap (pointPullbackCoordHom_injective h hx) r
+
+theorem pointPullbackHom_polyToFunctionField_X {xP yP : W.FunctionField}
+    (h : (W.map ι).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    pointPullbackHom h hx (polyToFunctionField W X) = xP := by
+  rw [polyToFunctionField_apply, pointPullbackHom_algebraMap,
+    algebraMap_polynomial_eq_mk_C, pointPullbackCoordHom_mk, eval₂_C]
+  exact Polynomial.aeval_X _
+
+theorem pointPullbackHom_yGen {xP yP : W.FunctionField}
+    (h : (W.map ι).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    pointPullbackHom h hx (yGen W) = yP := by
+  change pointPullbackHom h hx (algebraMap _ _ (CoordinateRing.mk W Y)) = _
+  rw [pointPullbackHom_algebraMap, pointPullbackCoordHom_mk]
+  exact eval₂_X _ _
+
+end PointPullback
+
+section MulPullback
+
+variable [CharZero F] [IsAlgClosed F] {W : Affine F}
+
+local notation "ι" => algebraMap F W.FunctionField
+
+end MulPullback
+end WeierstrassCurve.Affine
+end
+end
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_7915af21.Polyno\
+  mial IsDedekindDomain \
+  P2MW.S_OVERLONG_7915af21.IsDede\
+  kindDomain"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_7915af21.Polyno\
+  mial.Bivariate"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  equation_iff' equation_neg CoordinateRing.XYIdeal map_a₃ CoordinateRing CoordinateRing.smul map \
+  CoordinateRing.YClass Nonsingular map_a₆ negY_negY FunctionField map_a₂ Point CoordinateRing.mk \
+  map_a₁ nonsingular_neg map_a₄ CoordinateRing.exists_smul_basis_eq CoordinateRing.XClass \
+  CoordinateRing.basis equation_iff polynomial Point.zero Point.neg_some \
+  pushforwardAlong_single_eq pushforwardAlongHom_pointClass pointMapOfPushforward IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField IsogenyEndDatum.exists_pointEnd_eq_add"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine.CoordinateRing AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg \
+  P2MW.S_OVERLONG_7915af21.Algebr\
+  aicCurve"
+
+universe u
+
+variable {F : Type u} [Field F]
+
+section GenericPoint
+
+variable {W : Affine F}
+
+theorem polyToFunctionField_eq_aeval (p : F[X]) :
+    polyToFunctionField W p = Polynomial.aeval (polyToFunctionField W X) p := by
+  have h1 : (polyToFunctionField W : F[X] →+* W.FunctionField)
+      = algebraMap F[X] W.FunctionField :=
+    (IsScalarTower.algebraMap_eq F[X] W.CoordinateRing W.FunctionField).symm
+  have h2 : (IsScalarTower.toAlgHom F F[X] W.FunctionField : F[X] →ₐ[F] W.FunctionField)
+      = Polynomial.aeval (polyToFunctionField W X) := by
+    refine Polynomial.algHom_ext ?_
+    rw [Polynomial.aeval_X, IsScalarTower.coe_toAlgHom', ← h1]
+  calc polyToFunctionField W p = algebraMap F[X] W.FunctionField p := by rw [h1]
+    _ = (IsScalarTower.toAlgHom F F[X] W.FunctionField : F[X] →ₐ[F] W.FunctionField) p := rfl
+    _ = Polynomial.aeval (polyToFunctionField W X) p := by rw [h2]
+
+theorem equation_map_polyToFunctionField_yGen :
+    (W.map (algebraMap F W.FunctionField)).toAffine.Equation
+      (polyToFunctionField W X) (yGen W) := by
+  rw [equation_iff]
+  have hrel := smul_basis_mul_Y (W' := W) 0 1
+  rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at hrel
+  have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) hrel
+  rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆]
+  simp only [map_add, map_mul, map_pow, polyToFunctionField_C] at h2
+  rw [show yGen W = algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+    from rfl]
+  simp only [polyToFunctionField_apply] at h2 ⊢
+  linear_combination h2
+
+end GenericPoint
+end WeierstrassCurve.Affine
+end
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_7915af21.Polyno\
+  mial IsDedekindDomain \
+  P2MW.S_OVERLONG_7915af21.IsDede\
+  kindDomain"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_7915af21.Polyno\
+  mial.Bivariate"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  equation_iff' equation_neg CoordinateRing.XYIdeal map_a₃ CoordinateRing CoordinateRing.smul map \
+  CoordinateRing.YClass Nonsingular map_a₆ negY_negY FunctionField map_a₂ Point CoordinateRing.mk \
+  map_a₁ nonsingular_neg map_a₄ CoordinateRing.exists_smul_basis_eq CoordinateRing.XClass \
+  CoordinateRing.basis equation_iff polynomial Point.zero Point.neg_some \
+  pushforwardAlong_single_eq pushforwardAlongHom_pointClass pointMapOfPushforward IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField IsogenyEndDatum.exists_pointEnd_eq_add"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine.CoordinateRing AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg \
+  P2MW.S_OVERLONG_7915af21.Algebr\
+  aicCurve"
+
+universe u
+
+variable {F : Type u} [Field F]
+
+namespace AbstractSeam
+
+variable {W : Affine F} {V : Affine F}
+variable (ι : V.FunctionField →ₐ[F] W.FunctionField)
+  (hι : ι.toRingHom.IsIntegral)
+  {ξ η : W.FunctionField}
+  (hX : ι (polyToFunctionField V (X : F[X])) = ξ)
+  (hY : ι (yGen V) = η)
+
+include hX in
+theorem map_XClass (c : F) :
+    ι (algebraMap V.CoordinateRing V.FunctionField (XClass V c))
+      = ξ - algebraMap F W.FunctionField c := by
+  have h1 : algebraMap V.CoordinateRing V.FunctionField (XClass V c)
+      = polyToFunctionField V (X : F[X]) - algebraMap F V.FunctionField c := by
+    rw [← polyToFunctionField_C, ← map_sub]
+    rfl
+  rw [h1, map_sub, hX, AlgHom.commutes]
+
+include hY in
+theorem map_YClass (c : F) :
+    ι (algebraMap V.CoordinateRing V.FunctionField (YClass V (C c)))
+      = η - algebraMap F W.FunctionField c := by
+  have h1 : algebraMap V.CoordinateRing V.FunctionField (YClass V (C c))
+      = yGen V - algebraMap F V.FunctionField c := by
+    rw [YClass, map_sub, map_sub, yGen]
+    congr 1
+  rw [h1, map_sub, hY, AlgHom.commutes]
+
+section Cases
+
+variable [IsDedekindDomain V.CoordinateRing]
+
+include hX hY in
+theorem restrictAlong_placeOfEquation [IsAlgClosed F] [W.IsElliptic]
+    {x y : F} (h : W.Equation x y) {a b : F} (h' : V.Equation a b)
+    (hreg : ξ ∈ (placeOfEquation h).toValuationSubring)
+    (hdx : 0 < (placeOfEquation h).ord (ξ - algebraMap F W.FunctionField a))
+    (hdy : 0 < (placeOfEquation h).ord (η - algebraMap F W.FunctionField b)) :
+    (placeOfEquation h).restrictAlong ι hι = placeOfEquation h' := by
+  have hfin : IsFinitePlace ((placeOfEquation h).restrictAlong ι hι) :=
+    isFinitePlace_of_mem _ (by
+      rw [Place.mem_restrictAlong_iff, hX]
+      exact hreg)
+  refine eq_placeOfEquation_of_le_centre hfin h' ?_
+  rw [XYIdeal, Ideal.span_le]
+  intro r hr
+  simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hr
+  rcases hr with rfl | rfl
+  · rw [SetLike.mem_coe, hfin.mem_centre_iff_ord_ne_zero (XClass_ne_zero _),
+      Place.ord_restrictAlong_ne_zero_iff, map_XClass ι hX]
+    omega
+  · rw [SetLike.mem_coe, hfin.mem_centre_iff_ord_ne_zero (YClass_ne_zero _),
+      Place.ord_restrictAlong_ne_zero_iff, map_YClass ι hY]
+    omega
+
+include hX in
+theorem restrictAlong_eq_infinitePlace [V.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred V]
+    (v : AlgebraicCurve.Place F W.FunctionField)
+    (hpole : ξ ∉ v.toValuationSubring) :
+    v.restrictAlong ι hι = InfinitePlace.place := by
+  refine InfinitePlace.eq_of_not_isFinitePlace _ ?_
+  intro hfin
+  refine hpole ?_
+  rw [← hX]
+  exact hfin (algebraMap F[X] V.CoordinateRing (X : F[X]))
+
+end Cases
+end AbstractSeam
+end WeierstrassCurve.Affine
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_7915af21.Polyno\
+  mial Polynomial.Bivariate.Polynomial \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg \
+  P2MW.S_OVERLONG_7915af21.Algebr\
+  aicCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+end WeierstrassCurve
+end
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_7915af21.Polyno\
+  mial WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine WeierstrassCurve.Affine.Point \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine.Point"
+
+p2m_open_scoped "WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine Polynomial.Bivariate \
+  P2MW.S_OVERLONG_7915af21.Polyno\
+  mial.Bivariate"
+
+section
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ a₁ map mk a₄ Jacobian a₂ a₆ reduction IsIntegral \
+  toAffine Affine.Point map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ map_a₃ \
+  Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing.smul_basis_eq_zero \
+  equation_iff' equation_neg CoordinateRing.XYIdeal map_a₃ CoordinateRing CoordinateRing.smul map \
+  CoordinateRing.YClass Nonsingular map_a₆ negY_negY FunctionField map_a₂ Point CoordinateRing.mk \
+  map_a₁ nonsingular_neg map_a₄ CoordinateRing.exists_smul_basis_eq CoordinateRing.XClass \
+  CoordinateRing.basis equation_iff polynomial Point.zero Point.neg_some \
+  pushforwardAlong_single_eq pushforwardAlongHom_pointClass pointMapOfPushforward IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem \
+  pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField IsogenyEndDatum.exists_pointEnd_eq_add"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine.CoordinateRing AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg \
+  P2MW.S_OVERLONG_7915af21.Algebr\
+  aicCurve"
+
+universe u
+
+variable {F : Type u} [Field F]
+
+section TranslationCoords
+
+variable (W : Affine F) (a b : F)
+
+local notation "ι" => algebraMap F W.FunctionField
+
+end TranslationCoords
+
+section GenericPointGroup
+
+variable {W : Affine F}
+
+local notation "ι" => algebraMap F W.FunctionField
+
+end GenericPointGroup
+
+
+section AdjoinSurjective
+
+variable {W : Affine F} (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b)
+
+local notation "ι" => algebraMap F W.FunctionField
+
+theorem transcendental_polyToFunctionField_X :
+    Transcendental F (polyToFunctionField W X) := by
+  rw [transcendental_iff]
+  intro p hp
+  rw [← polyToFunctionField_eq_aeval] at hp
+  exact polyToFunctionField_injective (by simpa using hp)
+
+end AdjoinSurjective
+end WeierstrassCurve.Affine
+end
+end
+
+section
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_7915af21.Polyno\
+  mial AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg \
+  P2MW.S_OVERLONG_7915af21.Algebr\
+  aicCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine AddMonoid.End \
+  P2MW.S_OVERLONG_7915af21.AddMon\
+  oid.End"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_7915af21.Polyno\
+  mial.Bivariate"
+
+namespace ModularCurve
+namespace Es1a1
+
+
+section NegPullback
+
+universe u
+
+variable {F : Type u} [Field F]
+
+def es1a4_negYGen (W : Affine F) : W.FunctionField :=
+  (W.map (algebraMap F W.FunctionField)).toAffine.negY
+    (polyToFunctionField W X) (yGen W)
+
+theorem es1a4_negYGen_eq (W : Affine F) :
+    es1a4_negYGen W
+      = -(yGen W) - algebraMap F W.FunctionField W.a₁ * polyToFunctionField W X
+          - algebraMap F W.FunctionField W.a₃ := rfl
+
+theorem es1a4_negYGen_equation (W : Affine F) :
+    (W.map (algebraMap F W.FunctionField)).toAffine.Equation
+      (polyToFunctionField W X) (es1a4_negYGen W) :=
+  (equation_neg _ _).mpr equation_map_polyToFunctionField_yGen
+
+theorem es1a4_neg_aeval_injective (W : Affine F) :
+    Function.Injective (Polynomial.aeval (R := F) (polyToFunctionField W X)) :=
+  (injective_iff_map_eq_zero _).mpr fun p hp =>
+    transcendental_iff.mp transcendental_polyToFunctionField_X p hp
+
+def es1a4_negPullbackHom (W : Affine F) : W.FunctionField →ₐ[F] W.FunctionField :=
+  pointPullbackHom (es1a4_negYGen_equation W) (es1a4_neg_aeval_injective W)
+
+theorem es1a4_negPullbackHom_X (W : Affine F) :
+    es1a4_negPullbackHom W (polyToFunctionField W X) = polyToFunctionField W X :=
+  pointPullbackHom_polyToFunctionField_X _ _
+
+theorem es1a4_negPullbackHom_yGen (W : Affine F) :
+    es1a4_negPullbackHom W (yGen W) = es1a4_negYGen W :=
+  pointPullbackHom_yGen _ _
+
+theorem es1a4_negPullbackHom_polyToFunctionField (W : Affine F) (p : F[X]) :
+    es1a4_negPullbackHom W (polyToFunctionField W p) = polyToFunctionField W p := by
+  have h := polyToFunctionField_eq_aeval (W := W) p
+  rw [h, ← Polynomial.aeval_algHom_apply, es1a4_negPullbackHom_X]
+
+theorem es1a4_negPullbackHom_negYGen (W : Affine F) :
+    es1a4_negPullbackHom W (es1a4_negYGen W) = yGen W := by
+  rw [es1a4_negYGen_eq, map_sub, map_sub, _root_.map_neg, map_mul, AlgHom.commutes,
+    AlgHom.commutes, es1a4_negPullbackHom_yGen, es1a4_negPullbackHom_X,
+    es1a4_negYGen_eq]
+  ring
+
+theorem es1a4_negPullbackHom_sq_algebraMap (W : Affine F) (r : W.CoordinateRing) :
+    es1a4_negPullbackHom W (es1a4_negPullbackHom W
+        (algebraMap W.CoordinateRing W.FunctionField r))
+      = algebraMap W.CoordinateRing W.FunctionField r := by
+  obtain ⟨p, q, rfl⟩ := CoordinateRing.exists_smul_basis_eq r
+  rw [algebraMap_smul_basis,
+    show algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) = yGen W
+      from rfl]
+  simp only [map_add, map_mul, es1a4_negPullbackHom_polyToFunctionField,
+    es1a4_negPullbackHom_yGen, es1a4_negPullbackHom_negYGen]
+
+theorem es1a4_negPullbackHom_involution (W : Affine F) (z : W.FunctionField) :
+    es1a4_negPullbackHom W (es1a4_negPullbackHom W z) = z := by
+  obtain ⟨r, s, _, hrs⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  rw [← hrs, map_div₀, map_div₀, es1a4_negPullbackHom_sq_algebraMap,
+    es1a4_negPullbackHom_sq_algebraMap]
+
+theorem es1a4_negPullbackHom_surjective (W : Affine F) :
+    Function.Surjective (es1a4_negPullbackHom W) := fun z =>
+  ⟨es1a4_negPullbackHom W z, es1a4_negPullbackHom_involution W z⟩
+
+theorem es1a4_negPullbackHom_isIntegral (W : Affine F) :
+    (es1a4_negPullbackHom W).toRingHom.IsIntegral :=
+  RingHom.isIntegral_of_surjective _ (es1a4_negPullbackHom_surjective W)
+
+theorem es1a4_negPullbackHom_finiteAlong (W : Affine F) :
+    FiniteAlong F (es1a4_negPullbackHom W) :=
+  RingHom.Finite.of_surjective (es1a4_negPullbackHom W).toRingHom
+    (es1a4_negPullbackHom_surjective W)
+
+end NegPullback
+
+section NegDatum
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+
+def es1a4_negDatum (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+    :
+    IsogenyEndDatum W where
+  ι := es1a4_negPullbackHom W
+  hι := es1a4_negPullbackHom_isIntegral W
+  hfin := es1a4_negPullbackHom_finiteAlong W
+
+variable {W : Affine F} [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+omit [CharZero F] in
+omit [DecidableEq F] [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem es1a4_negDatum_seam_some {x₀ y₀ : F} (h : W.Nonsingular x₀ y₀) :
+    (placeOfEquation h.left).restrictAlong (es1a4_negPullbackHom W)
+        (es1a4_negPullbackHom_isIntegral W)
+      = placeOfEquation ((nonsingular_neg x₀ y₀).mpr h).left := by
+  have hreg : polyToFunctionField W X ∈ (placeOfEquation h.left).toValuationSubring :=
+    isFinitePlace_placeOfEquation h.left (algebraMap F[X] W.CoordinateRing X)
+  have hdx : 0 < (placeOfEquation h.left).ord
+      (polyToFunctionField W X - algebraMap F W.FunctionField x₀) := by
+    rw [show polyToFunctionField W X - algebraMap F W.FunctionField x₀
+        = polyToFunctionField W (X - C x₀) by rw [map_sub, polyToFunctionField_C]]
+    refine (ord_polyToFunctionField_pos_iff h.left (X_sub_C_ne_zero x₀)).mpr ?_
+    simp
+  have hdy : 0 < (placeOfEquation h.left).ord
+      (es1a4_negYGen W - algebraMap F W.FunctionField (W.negY x₀ y₀)) := by
+    have hrbasis : -(CoordinateRing.YClass W (C y₀))
+          - CoordinateRing.mk W (C (C W.a₁)) * CoordinateRing.XClass W x₀
+        = (C y₀ - C W.a₁ * (X - C x₀)) • (1 : W.CoordinateRing)
+          + (-1 : F[X]) • CoordinateRing.mk W Y := by
+      simp only [CoordinateRing.smul, CoordinateRing.YClass, CoordinateRing.XClass,
+        map_sub, map_mul, _root_.map_neg, map_one]
+      ring
+    have hr0 : -(CoordinateRing.YClass W (C y₀))
+          - CoordinateRing.mk W (C (C W.a₁)) * CoordinateRing.XClass W x₀ ≠ 0 := by
+      rw [hrbasis]
+      intro hcon
+      simpa using (CoordinateRing.smul_basis_eq_zero hcon).2
+    have hrmem : -(CoordinateRing.YClass W (C y₀))
+          - CoordinateRing.mk W (C (C W.a₁)) * CoordinateRing.XClass W x₀
+        ∈ CoordinateRing.XYIdeal W x₀ (C y₀) :=
+      sub_mem (neg_mem (Ideal.subset_span (Set.mem_insert_of_mem _ rfl)))
+        (Ideal.mul_mem_left _ _ (Ideal.subset_span (Set.mem_insert _ _)))
+    have himg : es1a4_negYGen W - algebraMap F W.FunctionField (W.negY x₀ y₀)
+        = algebraMap W.CoordinateRing W.FunctionField
+            (-(CoordinateRing.YClass W (C y₀))
+              - CoordinateRing.mk W (C (C W.a₁)) * CoordinateRing.XClass W x₀) := by
+      rw [hrbasis, algebraMap_smul_basis,
+        show algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+          = yGen W from rfl, es1a4_negYGen_eq]
+      simp only [negY, map_sub, _root_.map_neg, map_mul, map_one, polyToFunctionField_C]
+      ring
+    rw [himg]
+    exact (ord_placeOfEquation_pos_iff h.left hr0).mpr hrmem
+  exact AbstractSeam.restrictAlong_placeOfEquation (es1a4_negPullbackHom W)
+    (es1a4_negPullbackHom_isIntegral W) (es1a4_negPullbackHom_X W)
+    (es1a4_negPullbackHom_yGen W) h.left ((nonsingular_neg x₀ y₀).mpr h).left
+    hreg hdx hdy
+
+omit [CharZero F] in
+omit [DecidableEq F] [W.AbelTheorem] in
+theorem es1a4_negDatum_seam_zero :
+    (InfinitePlace.place : AlgebraicCurve.Place F W.FunctionField).restrictAlong
+        (es1a4_negPullbackHom W) (es1a4_negPullbackHom_isIntegral W)
+      = InfinitePlace.place := by
+  refine AbstractSeam.restrictAlong_eq_infinitePlace (es1a4_negPullbackHom W)
+    (es1a4_negPullbackHom_isIntegral W) (es1a4_negPullbackHom_X W) _ ?_
+  intro hmem
+  have h1 : (0 : ℤ) ≤ (InfinitePlace.place : AlgebraicCurve.Place F W.FunctionField).ord
+      (polyToFunctionField W X) :=
+    AlgebraicCurve.Place.ord_nonneg_of_mem _ hmem
+  have h2 : (InfinitePlace.place : AlgebraicCurve.Place F W.FunctionField).ord
+      (polyToFunctionField W X) < 0 :=
+    ord_X_neg_of_not_isFinitePlace _ InfinitePlace.not_isFinitePlace
+  omega
+
+omit [CharZero F] in
+theorem es1a4_negDatum_seam (P : W.Point) :
+    (placeOfPoint P).restrictAlong (es1a4_negDatum W).ι (es1a4_negDatum W).hι
+      = placeOfPoint (-P) := by
+  cases P with
+  | zero =>
+      rw [show -(Point.zero : W.Point) = Point.zero from rfl, placeOfPoint_zero]
+      exact es1a4_negDatum_seam_zero
+  | some x₀ y₀ h =>
+      rw [Point.neg_some, placeOfPoint_some, placeOfPoint_some]
+      exact es1a4_negDatum_seam_some h
+
+theorem es1a4_negDatum_pointEnd : (es1a4_negDatum W).pointEnd' = -1 := by
+  refine AddMonoidHom.ext fun P => ?_
+  exact (es1a4_negDatum W).pointEnd'_eq_of_seam (fun Q => -Q) _root_.neg_zero
+    (fun Q => es1a4_negDatum_seam Q) P
+
+end NegDatum
+end ModularCurve.Es1a1
+end
+end
+
+section
+
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_7915af21.Weiers\
+  trassCurve.Affine AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg \
+  P2MW.S_OVERLONG_7915af21.Algebr\
+  aicCurve"
+
+namespace ModularCurve
+
+universe u
+
+section Foundation
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+theorem kw_neg_mem_range_pointEnd {f : AddMonoid.End W.Point}
+    (hf : f ∈ Set.range (IsogenyEndDatum.pointEnd' (W := W))) :
+    -f ∈ Set.range (IsogenyEndDatum.pointEnd' (W := W)) := by
+  obtain ⟨D, rfl⟩ := hf
+  refine ⟨IsogenyEndDatum.compDatum W (Es1a1.es1a4_negDatum W) D, ?_⟩
+  rw [IsogenyEndDatum.compDatum_pointEnd, Es1a1.es1a4_negDatum_pointEnd]
+  exact neg_one_mul D.pointEnd'
+
+abbrev KwIsogenyEndAddDatumSupply : Prop :=
+  ∀ D₁ D₂ : IsogenyEndDatum W, D₁.pointEnd' + D₂.pointEnd' ≠ 0 →
+    ∃ D₃ : IsogenyEndDatum W, D₃.pointEnd' = D₁.pointEnd' + D₂.pointEnd'
+
+theorem kw_zero_or_mem_range_pointEnd_of_mem_addSubgroup_closure
+    (hadd : KwIsogenyEndAddDatumSupply W) {ψ : AddMonoid.End W.Point}
+    (hψ : ψ ∈ AddSubgroup.closure (Set.range (IsogenyEndDatum.pointEnd' (W := W)))) :
+    ψ = 0 ∨ ψ ∈ Set.range (IsogenyEndDatum.pointEnd' (W := W)) := by
+  refine AddSubgroup.closure_induction ?_ ?_ ?_ ?_ hψ
+  · exact fun y hy => Or.inr hy
+  · exact Or.inl rfl
+  · rintro x y - - (rfl | ⟨D₁, rfl⟩) hy
+    · simpa using hy
+    · rcases hy with rfl | ⟨D₂, rfl⟩
+      · exact Or.inr ⟨D₁, (add_zero _).symm⟩
+      · by_cases h0 : D₁.pointEnd' + D₂.pointEnd' = 0
+        · exact Or.inl h0
+        · exact Or.inr (hadd D₁ D₂ h0)
+  · rintro x - (rfl | hx)
+    · exact Or.inl _root_.neg_zero
+    · exact Or.inr (kw_neg_mem_range_pointEnd W hx)
+
+theorem kw_isogenyEndDatumOfNonzeroEnd_of_addDatumSupply
+    (hadd : KwIsogenyEndAddDatumSupply W) :
+    KwIsogenyEndDatumOfNonzeroEnd W := by
+  intro ψ hψ hne
+  have hcl := (mem_isogenyEndSubring_iff_mem_addSubgroup_closure W).mp hψ
+  rcases kw_zero_or_mem_range_pointEnd_of_mem_addSubgroup_closure W hadd hcl with h0 | hD
+  · exact absurd h0 hne
+  · exact hD
+
+end Foundation
+end ModularCurve
+end
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg\
+  " in
+open _root_.WeierstrassCurve
+  _root_.P2MW.S_OVERLONG_7915af21.WeierstrassCurve
+  _root_.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_7915af21.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_7915af21.AlgebraicCurve
+  in
+universe u in
+theorem solution
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    {W : WeierstrassCurve.Affine F} [W.IsElliptic]
+    [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [AbelTheorem W]
+    (hNs : ∀ D : IsogenyEndDatum W, NormFormulaAlong F D.ι D.hfin)
+    (ψ : AddMonoid.End W.Point) (hψ : ψ ∈ isogenyEndSubring W hNs) (hne : ψ ≠ 0) :
+    ∃ D : IsogenyEndDatum W, D.pointEnd (hNs D) = ψ := by
+  have hadd : ModularCurve.KwIsogenyEndAddDatumSupply W := by
+    intro D₁ D₂ h0
+    obtain ⟨D₃, hN₃, h3⟩ :=
+      IsogenyEndDatum.exists_pointEnd_eq_add D₁ (hNs D₁) D₂ (hNs D₂) h0
+    exact ⟨D₃, h3⟩
+  exact ModularCurve.kw_isogenyEndDatumOfNonzeroEnd_of_addDatumSupply W hadd ψ hψ hne
+
+end
+end S_OVERLONG_7915af21
+end P2MW
+export P2MW.S_OVERLONG_7915af21
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+universe u
+theorem WeierstrassCurve.Affine.IsogenyEndDatum.exists_pointEnd_eq_of_mem_isogenyEndSubring
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    {W : WeierstrassCurve.Affine F} [W.IsElliptic]
+    [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [AbelTheorem W]
+    (hNs : ∀ D : IsogenyEndDatum W, NormFormulaAlong F D.ι D.hfin)
+    (ψ : AddMonoid.End W.Point) (hψ : ψ ∈ isogenyEndSubring W hNs) (hne : ψ ≠ 0) :
+    ∃ D : IsogenyEndDatum W, D.pointEnd (hNs D) = ψ :=
+  solution hNs ψ hψ hne
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_restrictAlong_placeOfPoint_eq_add.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_restrictAlong_placeOfPoint_eq_add.lean
new file mode 100644
index 0000000000..c1c534ec26
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_restrictAlong_placeOfPoint_eq_add.lean
@@ -0,0 +1,144 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.Affine.IsogenyEndDatum.exists_restrictAlong_placeOfPoint_eq_add
+(f8a39c1e-1459-50cb-893b-11563e5e5727) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 52dbf7a5-8da4-5f91-a7ee-93f5d4b10c7e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Analysis.Normed.Ring.Lemmas
+import Mathlib.Order.CompletePartialOrder
+import Mathlib.Tactic.NormNum.Prime
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Definitions.Defs_IsogenyEndDatum_sharedLibrary
+
+/-!
+# Pointwise sum of two isogeny end data is realised
+
+Theorem statement:
+`WeierstrassCurve.Affine.IsogenyEndDatum.exists_restrictAlong_placeOfPoint_eq_add`
+(`f8a39c1e-1459-50cb-893b-11563e5e5727`), by Claude, 2026-09-05.
+
+Proof: submission `52dbf7a5-8da4-5f91-a7ee-93f5d4b10c7e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field of characteristic zero (with decidable equality) and let
+$W$ be an affine Weierstrass curve over $F$ that is elliptic. Assume the place gate data
+`GenusOnePlaceGate W`: a bijection `pointEquivPlace` between the group $W(F)$ of points `W.Point`
+and the places of $F$ in the function field `W.FunctionField`, all of whose places have degree $1$,
+with `placeOfPoint` denoting this bijection; assume it is centred, i.e. for each nonsingular pair
+$(x,y)$ the images in the function field of the coordinate classes `XClass W x` and `YClass W (C y)`
+lie in the nonunits of the valuation subring of the place attached to `Point.some x y h`; and assume
+`AbelTheorem W`, i.e. a divisor of degree $0$ is principal exactly when its sum of points
+`divisorSum` vanishes. Let $D_1, D_2$ be isogeny end data: each consists of an $F$-algebra
+endomorphism $\iota$ of `W.FunctionField` whose underlying ring map is integral, together with the
+finiteness of `W.FunctionField` as a module over itself along $\iota$. Assume further norm formulae
+$hN_1, hN_2$, i.e. the divisor push-forward norm formula `NormFormulaAlong F Dᵢ.ι Dᵢ.hfin` for each,
+and that the sum `D₁.pointEnd hN₁ + D₂.pointEnd hN₂` of the two induced additive endomorphisms of
+`W.Point` (obtained by push-forward transport) is nonzero. Then there exists an isogeny end datum
+$D_3$ on $W$ such that for every point $P$ of $W$, the place obtained by pulling back `placeOfPoint
+P` along $D_3.\iota$ is the place of the point $Q_1 + Q_2$, where $Q_i$ is the point corresponding
+under `pointEquivPlace` to the pullback of `placeOfPoint P` along $D_i.\iota$. Note that $D_3$ is
+produced without an accompanying norm formula, and the assertion is the pointwise identity of
+places, not an identity of induced endomorphisms.
+
+This is the closure under pointwise addition of the set of maps $E \to E$ realised by finite
+$F$-algebra self-embeddings of the function field, in the place-theoretic formulation of the
+curves–fields correspondence: the new embedding is given by chord-and-tangent addition of the two
+generic points, and the content is that the compatibility with places holds at every point,
+including those where the addition formulae degenerate. It is used by
+[`WeierstrassCurve.Affine.IsogenyEndDatum.exists_pointEnd_eq_add`]
+(thm.html#WeierstrassCurve.Affine.IsogenyEndDatum.exists_pointEnd_eq_add),
+which upgrades it to the statement that the sum of the two induced endomorphisms of $W(F)$ is again
+induced by an isogeny end datum.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_IsogenyEndDatum_exists_restrictAlong_placeOfPoint_eq_add.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+open WeierstrassCurve Affine AlgebraicCurve
+
+namespace WeierstrassCurve
+namespace Affine
+
+theorem placeOfPointEquiv_symm_eq {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    (W : Affine F) [W.IsElliptic] [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W]
+    [AbelTheorem W]
+    (v : AlgebraicCurve.Place F W.FunctionField) :
+    (placeOfPointEquiv W).symm v = (pointEquivPlace (W := W)).symm v := by
+  apply placeOfPoint_injective (W := W)
+  rw [placeOfPoint_placeOfPointEquiv_symm]
+  exact ((pointEquivPlace (W := W)).apply_symm_apply v).symm
+
+end Affine
+end WeierstrassCurve
+
+universe u
+
+theorem solution
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    {W : WeierstrassCurve.Affine F} [W.IsElliptic]
+    [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [AbelTheorem W]
+    (D₁ : IsogenyEndDatum W) (hN₁ : NormFormulaAlong F D₁.ι D₁.hfin)
+    (D₂ : IsogenyEndDatum W) (hN₂ : NormFormulaAlong F D₂.ι D₂.hfin)
+    (h : D₁.pointEnd hN₁ + D₂.pointEnd hN₂ ≠ 0) :
+    ∃ D₃ : IsogenyEndDatum W, ∀ P : W.Point,
+      (placeOfPoint P).restrictAlong D₃.ι D₃.hι
+        = placeOfPoint
+            ((pointEquivPlace (W := W)).symm ((placeOfPoint P).restrictAlong D₁.ι D₁.hι)
+              + (pointEquivPlace (W := W)).symm ((placeOfPoint P).restrictAlong D₂.ι D₂.hι)) := by
+  have h' : D₁.pointEnd' + D₂.pointEnd' ≠ 0 := h
+  obtain ⟨D₃, hD₃⟩ := ModularCurve.Es1a1.kw_hk5f_addGeomMorphSupply_proved W D₁ D₂ h'
+  refine ⟨D₃, fun P => ?_⟩
+  rw [D₃.placeOfPoint_geomMorph P, hD₃ P]
+  simp only [IsogenyEndDatum.geomMorph, placeOfPointEquiv_symm_eq]
+
+end privateSection
+
+public section publicSection
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+universe u
+
+theorem WeierstrassCurve.Affine.IsogenyEndDatum.exists_restrictAlong_placeOfPoint_eq_add
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    {W : WeierstrassCurve.Affine F} [W.IsElliptic]
+    [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [AbelTheorem W]
+    (D₁ : IsogenyEndDatum W) (hN₁ : NormFormulaAlong F D₁.ι D₁.hfin)
+    (D₂ : IsogenyEndDatum W) (hN₂ : NormFormulaAlong F D₂.ι D₂.hfin)
+    (h : D₁.pointEnd hN₁ + D₂.pointEnd hN₂ ≠ 0) :
+    ∃ D₃ : IsogenyEndDatum W, ∀ P : W.Point,
+      (placeOfPoint P).restrictAlong D₃.ι D₃.hι
+        = placeOfPoint
+            ((pointEquivPlace (W := W)).symm ((placeOfPoint P).restrictAlong D₁.ι D₁.hι)
+              + (pointEquivPlace (W := W)).symm ((placeOfPoint P).restrictAlong D₂.ι D₂.hι)) :=
+                _root_.solution D₁ hN₁ D₂ hN₂ h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_sq_lt_four_mul_and_forall_exists_finrankAlong_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_sq_lt_four_mul_and_forall_exists_finrankAlong_eq.lean
new file mode 100644
index 0000000000..7bbb20ee69
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_sq_lt_four_mul_and_forall_exists_finrankAlong_eq.lean
@@ -0,0 +1,580 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.Affine.IsogenyEndDatum.exists_sq_lt_four_mul_and_forall_exists_finrankAlong_eq
+(cac63699-df2c-5ce8-9951-0c3825b27434) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 33c4bf56-590f-52d2-ba2d-6ada0775b790
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.Algebra.Ring.IsFormallyReal
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_dualEndData_dual_mem_and_norm_eq_finrankAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_pointEnd_eq_of_mem_isogenyEndSubring
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_exists_zsmul_eq_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsionBy_eq_sq_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Non-integral isogeny endomorphism forces an imaginary quadratic degree form
+
+Theorem statement:
+`WeierstrassCurve.Affine.IsogenyEndDatum.exists_sq_lt_four_mul_and_forall_exists_finrankAlong_eq`
+(`cac63699-df2c-5ce8-9951-0c3825b27434`), by Claude, 2026-09-05.
+
+Proof: submission `33c4bf56-590f-52d2-ba2d-6ada0775b790`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field of characteristic zero with decidable equality which is algebraically closed, and
+let $W$ be an affine Weierstrass curve over $F$ which is elliptic, equipped with the gates
+`GenusOnePlaceGate W` (a bijection between $W.Point$ and the places of $W.FunctionField$ over $F$,
+all of which have degree $1$), `AbelTheorem W` (a degree-zero divisor is principal exactly when its
+image under `divisorSum` vanishes) and `GenusOnePlaceGate.IsCentred W` (for each nonsingular affine
+point the classes of $X$ and of $Y - y$ lie in the nonunits of the valuation subring of the place
+attached to that point). An `IsogenyEndDatum W` consists of an $F$-algebra endomorphism $\iota$ of
+$W.FunctionField$ which is integral and finite, i.e. makes $W.FunctionField$ a finite-dimensional
+module over itself along $\iota$; its degree is `finrankAlong F D.ι`, that dimension, and
+`D.pointEnd` is the induced endomorphism of $W.Point$ obtained from the Picard pushforward. Assume
+`hNs`: every isogeny end datum satisfies the pushforward norm formula, i.e. for every nonzero $f$
+the pushforward of the principal divisor of $f$ is the divisor of $\mathrm{N}(f)$. Assume given one
+datum $D_0$ whose endomorphism of $W.Point$ is not $P \mapsto m \cdot P$ for any integer $m$. Then
+there are integers $t, n$ with $t^2 < 4n$ such that for all integers $a$ and $b$ with $b \neq 0$
+some isogeny end datum $D$ has degree exactly $a^2 + tab + nb^2$. Only the realisation of these
+degrees is asserted, not that the corresponding endomorphism is $a + b\,[D_0]$.
+
+This is the degree-form half of the classical statement that an elliptic curve carrying a
+non-integral endomorphism has complex multiplication by an order in an imaginary quadratic field,
+the degree being the (positive definite) norm form of that order. It is used in the proofs that,
+under suitable hypotheses on the $j$-invariant, every isogeny end datum acts on points as
+multiplication by an integer.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_IsogenyEndDatum_exists_sq_lt_four_mul_and_forall_exists_finrankAlong_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_e21b3de7
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+universe u
+
+noncomputable section
+
+namespace Ws13S7
+
+
+open AddMonoid.End
+
+section PureAlgebra
+
+variable {A : Type*} [AddCommGroup A]
+
+theorem mem_bot_addMonoidEnd_iff (φ : AddMonoid.End A) :
+    φ ∈ (⊥ : Subring (AddMonoid.End A)) ↔ ∃ n : ℤ, ∀ x : A, φ x = n • x := by
+  rw [Subring.mem_bot]
+  refine ⟨fun ⟨n, hn⟩ => ⟨n, fun x => hn ▸ (AddMonoid.End.intCast_apply n x)⟩,
+    fun ⟨n, hn⟩ => ⟨n, ?_⟩⟩
+  exact AddMonoidHom.ext fun x => (AddMonoid.End.intCast_apply n x).trans (hn x).symm
+
+theorem dd_charPoly_eq {φ : AddMonoid.End A} (D : DualEndData φ) :
+    φ * φ = (D.trace : AddMonoid.End A) * φ - (D.norm : AddMonoid.End A) := by
+  have h := D.charPoly
+  rwa [sub_add, sub_eq_zero] at h
+
+theorem dd_intLinComb_norm_pos_of_disc_neg {φ : AddMonoid.End A} (D : DualEndData φ)
+    (hdisc : D.trace ^ 2 < 4 * D.norm) {a b : ℤ} (hb : b ≠ 0) :
+    0 < (D.intLinComb a b).norm := by
+  rw [DualEndData.intLinComb_norm]
+  have key : 4 * (a ^ 2 + D.trace * a * b + D.norm * b ^ 2)
+      = (2 * a + D.trace * b) ^ 2 + (4 * D.norm - D.trace ^ 2) * b ^ 2 := by ring
+  have hbsq : (0 : ℤ) < b ^ 2 := by positivity
+  nlinarith [sq_nonneg (2 * a + D.trace * b)]
+
+theorem dd_intLinComb_norm_pos_of_b_eq_zero {φ : AddMonoid.End A} (D : DualEndData φ)
+    {a : ℤ} (ha : a ≠ 0) :
+    0 < (D.intLinComb a 0).norm := by
+  rw [DualEndData.intLinComb_norm]
+  have : a ^ 2 + D.trace * a * 0 + D.norm * 0 ^ 2 = a ^ 2 := by ring
+  rw [this]; positivity
+
+theorem dd_intLinComb_norm_pos_of_disc_neg_of_ne_zero {φ : AddMonoid.End A}
+    (D : DualEndData φ) (hdisc : D.trace ^ 2 < 4 * D.norm) {a b : ℤ}
+    (hne : (a : AddMonoid.End A) + (b : AddMonoid.End A) * φ ≠ 0) :
+    0 < (D.intLinComb a b).norm := by
+  rcases eq_or_ne b 0 with rfl | hb
+  · have ha : a ≠ 0 := by
+      rintro rfl
+      exact hne (by simp)
+    exact dd_intLinComb_norm_pos_of_b_eq_zero D ha
+  · exact dd_intLinComb_norm_pos_of_disc_neg D hdisc hb
+
+theorem binaryQuadForm_pos_of_neg_disc {t n a b : ℤ} (hdisc : t ^ 2 < 4 * n)
+    (hform : a ^ 2 + t * a * b + n * b ^ 2 = 0) : a = 0 ∧ b = 0 := by
+  have hb : b = 0 := by nlinarith [sq_nonneg (2 * a + t * b), sq_nonneg b]
+  subst hb
+  have ha : a = 0 := by nlinarith [sq_nonneg a]
+  exact ⟨ha, rfl⟩
+
+theorem linearIndependent_one_of_quadCharPoly_neg_disc
+    (hinj : Function.Injective (Int.cast : ℤ → AddMonoid.End A))
+    {φ : AddMonoid.End A} {t n : ℤ}
+    (hquad : φ * φ = (t : AddMonoid.End A) * φ - (n : AddMonoid.End A))
+    (hdisc : t ^ 2 < 4 * n) :
+    ∀ a b : ℤ, (a : AddMonoid.End A) + (b : AddMonoid.End A) * φ = 0 → a = 0 ∧ b = 0 := by
+  intro a b hrel
+  have hpt : ∀ x : A, b • φ x = -(a • x) := by
+    intro x
+    have h : a • x + b • φ x = 0 := calc
+      a • x + b • φ x
+          = (a : AddMonoid.End A) x + (b : AddMonoid.End A) (φ x) := by
+            rw [AddMonoid.End.intCast_apply, AddMonoid.End.intCast_apply]
+        _ = ((a : AddMonoid.End A) + (b : AddMonoid.End A) * φ) x := rfl
+        _ = (0 : AddMonoid.End A) x := DFunLike.congr_fun hrel x
+        _ = 0 := rfl
+    exact eq_neg_of_add_eq_zero_right h
+  have hq : ∀ x : A, φ (φ x) = t • φ x - n • x := by
+    intro x
+    calc φ (φ x) = (φ * φ) x := rfl
+      _ = ((t : AddMonoid.End A) * φ - (n : AddMonoid.End A)) x := DFunLike.congr_fun hquad x
+      _ = (t : AddMonoid.End A) (φ x) - (n : AddMonoid.End A) x := rfl
+      _ = t • φ x - n • x := by rw [AddMonoid.End.intCast_apply, AddMonoid.End.intCast_apply]
+  have hkey : ∀ x : A, (a ^ 2 + t * a * b + n * b ^ 2) • x = 0 := by
+    intro x
+    have hb2 : (b * b) • φ (φ x) = (-(t * a * b) - n * (b * b)) • x := by
+      rw [hq, smul_sub, ← mul_smul, show (b * b) * t = (t * b) * b from by ring, mul_smul,
+        hpt, smul_neg, ← mul_smul, ← mul_smul, ← neg_smul, ← sub_smul]
+      congr 1; ring
+    have hb2' : (b * b) • φ (φ x) = (a * a) • x := by
+      rw [mul_smul, hpt (φ x), smul_neg, ← mul_smul, mul_comm b a, mul_smul, hpt, smul_neg,
+        neg_neg, ← mul_smul]
+    rw [show a ^ 2 + t * a * b + n * b ^ 2 = a * a - (-(t * a * b) - n * (b * b)) from by ring,
+      sub_smul, ← hb2, ← hb2', sub_self]
+  have hcast : ((a ^ 2 + t * a * b + n * b ^ 2 : ℤ) : AddMonoid.End A) = 0 :=
+    AddMonoidHom.ext fun x => (AddMonoid.End.intCast_apply _ x).trans (hkey x)
+  have hint : a ^ 2 + t * a * b + n * b ^ 2 = 0 :=
+    hinj (show ((a ^ 2 + t * a * b + n * b ^ 2 : ℤ) : AddMonoid.End A)
+      = ((0 : ℤ) : AddMonoid.End A) by rw [Int.cast_zero]; exact hcast)
+  exact binaryQuadForm_pos_of_neg_disc hdisc hint
+
+end PureAlgebra
+
+section Curve
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : WeierstrassCurve.Affine F) [W.IsElliptic]
+
+theorem charZero_addMonoidEnd_point : CharZero (AddMonoid.End W.Point) := by
+  refine charZero_of_inj_zero fun n hn => ?_
+  by_contra hn0
+  have htop : ∀ k : ℕ, n ∣ k → Submodule.torsionBy ℤ W.Point (k : ℤ) = ⊤ := by
+    rintro k ⟨c, rfl⟩
+    refine eq_top_iff.mpr fun P _ => ?_
+    rw [Submodule.mem_torsionBy_iff]
+    have hP : (n : ℤ) • P = 0 := by
+      have h := DFunLike.congr_fun hn P
+      rw [AddMonoid.End.natCast_apply] at h
+      rw [natCast_zsmul]; exact h
+    rw [Nat.cast_mul, mul_comm, mul_zsmul, hP, zsmul_zero]
+  have hcard : ∀ k : ℕ, n ∣ k → k ≠ 0 → Nat.card W.Point = k ^ 2 := by
+    intro k hk hk0
+    have h : Nat.card (Submodule.torsionBy ℤ W.Point (k : ℤ)) = k ^ 2 :=
+      WeierstrassCurve.card_torsionBy_eq_sq_of_isAlgClosed W (n := k)
+        (Nat.cast_ne_zero.mpr hk0)
+    rw [htop k hk] at h
+    rwa [Nat.card_congr (Submodule.topEquiv (R := ℤ) (M := W.Point)).toEquiv] at h
+  have h1 := hcard n dvd_rfl hn0
+  have h2 := hcard (2 * n) (dvd_mul_left n 2) (by omega)
+  have h3 : n ^ 2 = (2 * n) ^ 2 := h1.symm.trans h2
+  have h4 : 3 * n ^ 2 = 0 := by nlinarith
+  have h5 : n = 0 := by
+    have : n ^ 2 = 0 := by omega
+    exact pow_eq_zero_iff (n := 2) (by norm_num) |>.mp this
+  exact hn0 h5
+
+theorem intCast_addMonoidEnd_point_injective :
+    Function.Injective (Int.cast : ℤ → AddMonoid.End W.Point) :=
+  haveI := charZero_addMonoidEnd_point W
+  Int.cast_injective
+
+theorem finrankAlong_pos {K L L' : Type*} [Field K] [Field L] [Field L']
+    [Algebra K L] [Algebra K L'] (φ : L →ₐ[K] L') (hfin : FiniteAlong K φ) :
+    0 < finrankAlong K φ := by
+  let := algebraAlong φ
+  have hfin' : Module.Finite L L' := hfin
+  exact (Module.finrank_pos_iff_of_free (R := L) (M := L')).mpr inferInstance
+
+variable [GenusOnePlaceGate W] [AbelTheorem W] [GenusOnePlaceGate.IsCentred W]
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [W.AbelTheorem] [GenusOnePlaceGate.IsCentred W] in
+theorem finrankAlong_datum_pos (D : IsogenyEndDatum W) : 0 < finrankAlong F D.ι :=
+  finrankAlong_pos D.ι D.hfin
+
+theorem isogenyEndSubring_mul_left_cancel
+    (hNs : ∀ D : IsogenyEndDatum W, NormFormulaAlong F D.ι D.hfin)
+    {φ : AddMonoid.End W.Point} (hφS : φ ∈ isogenyEndSubring W hNs) (hφ0 : φ ≠ 0)
+    {ψ : AddMonoid.End W.Point} (hzero : φ * ψ = 0) : ψ = 0 := by
+  obtain ⟨D, rfl⟩ :=
+    IsogenyEndDatum.exists_pointEnd_eq_of_mem_isogenyEndSubring hNs φ hφS hφ0
+  obtain ⟨DD, -, hnorm⟩ :=
+    IsogenyEndDatum.exists_dualEndData_dual_mem_and_norm_eq_finrankAlong hNs D
+  have hdeg : (0 : ℤ) < DD.norm := by
+    rw [hnorm]; exact_mod_cast finrankAlong_datum_pos W D
+  have hNψ : ((DD.norm : ℤ) : AddMonoid.End W.Point) * ψ = 0 := by
+    rw [← DD.dual_mul, mul_assoc, hzero, mul_zero]
+  refine AddMonoidHom.ext fun P => ?_
+  obtain ⟨Q, rfl⟩ : ∃ Q : W.Point, DD.norm • Q = P :=
+    WeierstrassCurve.Affine.Point.exists_zsmul_eq_of_isAlgClosed W (n := DD.norm) hdeg.ne' P
+  have h := DFunLike.congr_fun hNψ Q
+  change (DD.norm : AddMonoid.End W.Point) (ψ Q) = 0 at h
+  rw [AddMonoid.End.intCast_apply] at h
+  change ψ (DD.norm • Q) = 0
+  rw [map_zsmul ψ DD.norm Q, h]
+
+end Curve
+
+section CurveD
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : WeierstrassCurve.Affine F) [W.IsElliptic]
+variable [GenusOnePlaceGate W] [AbelTheorem W] [GenusOnePlaceGate.IsCentred W]
+
+theorem sq_eq_intCast_nonneg_isSquare
+    (hNs : ∀ D : IsogenyEndDatum W, NormFormulaAlong F D.ι D.hfin)
+    {ξ : AddMonoid.End W.Point} (hξS : ξ ∈ isogenyEndSubring W hNs)
+    {d : ℤ} (hd_nn : 0 ≤ d)
+    (hξsq : ξ * ξ = ((d : ℤ) : AddMonoid.End W.Point)) :
+    ∃ e : ℤ, d = e ^ 2 := by
+  rcases eq_or_ne ξ 0 with hξ0 | hξ0
+  · have : ((d : ℤ) : AddMonoid.End W.Point) = ((0 : ℤ) : AddMonoid.End W.Point) := by
+      rw [← hξsq, hξ0, mul_zero, Int.cast_zero]
+    exact ⟨0, by simpa using intCast_addMonoidEnd_point_injective W this⟩
+  · obtain ⟨Dξ, hDξ⟩ :=
+      IsogenyEndDatum.exists_pointEnd_eq_of_mem_isogenyEndSubring hNs ξ hξS hξ0
+    obtain ⟨DDξ, -, hnormξ⟩ :=
+      IsogenyEndDatum.exists_dualEndData_dual_mem_and_norm_eq_finrankAlong hNs Dξ
+    have hnξ_pos : (0 : ℤ) < DDξ.norm := by
+      rw [hnormξ]; exact_mod_cast finrankAlong_datum_pos W Dξ
+    have htξ : ξ + DDξ.dual = ((DDξ.trace : ℤ) : AddMonoid.End W.Point) := by
+      rw [← hDξ]; exact DDξ.add_dual
+    have hmul : ξ * DDξ.dual = ((DDξ.norm : ℤ) : AddMonoid.End W.Point) := by
+      rw [← hDξ]; exact DDξ.mul_dual
+    have hlin : ξ * ((DDξ.trace : ℤ) : AddMonoid.End W.Point)
+        = (((d + DDξ.norm) : ℤ) : AddMonoid.End W.Point) := by
+      rw [← htξ, mul_add, hξsq, hmul, ← Int.cast_add]
+    set c : ℤ := d + DDξ.norm with hc_def
+    have hc_pos : 0 < c := by omega
+    have hsq : DDξ.trace ^ 2 * d = c ^ 2 := by
+      have L : ξ * ((DDξ.trace : ℤ) : AddMonoid.End W.Point)
+          * (ξ * ((DDξ.trace : ℤ) : AddMonoid.End W.Point))
+            = (((DDξ.trace ^ 2 * d : ℤ)) : AddMonoid.End W.Point) := by
+        rw [mul_assoc, ← mul_assoc ((DDξ.trace : ℤ) : AddMonoid.End W.Point),
+          (Int.cast_commute DDξ.trace ξ).eq, mul_assoc ξ, ← mul_assoc, hξsq,
+          ← Int.cast_mul, ← Int.cast_mul]
+        exact congrArg Int.cast (by ring)
+      have key : (((DDξ.trace ^ 2 * d : ℤ)) : AddMonoid.End W.Point)
+          = (((c ^ 2 : ℤ)) : AddMonoid.End W.Point) := by
+        rw [← L, hlin, ← Int.cast_mul, sq]
+      exact intCast_addMonoidEnd_point_injective W key
+    have htξ_ne : DDξ.trace ≠ 0 := by
+      intro h0; rw [h0, zero_pow (by omega), zero_mul] at hsq
+      exact (pow_eq_zero_iff (n := 2) (by omega) |>.mp hsq.symm |> hc_pos.ne').elim
+    obtain ⟨k, hk⟩ : DDξ.trace ∣ c :=
+      (Int.pow_dvd_pow_iff (n := 2) (by omega)).mp ⟨d, hsq.symm⟩
+    refine ⟨k, ?_⟩
+    have : DDξ.trace ^ 2 * d = DDξ.trace ^ 2 * k ^ 2 := by rw [hsq, hk]; ring
+    exact mul_left_cancel₀ (pow_ne_zero 2 htξ_ne) this
+
+theorem dualEndData_disc_neg_of_notBot
+    (hNs : ∀ D : IsogenyEndDatum W, NormFormulaAlong F D.ι D.hfin)
+    {φ : AddMonoid.End W.Point} (hφS : φ ∈ isogenyEndSubring W hNs)
+    (hbot : φ ∉ (⊥ : Subring (AddMonoid.End W.Point)))
+    (DD : DualEndData φ) :
+    DD.trace ^ 2 < 4 * DD.norm := by
+  by_contra hcontra
+  set t : ℤ := DD.trace with ht_def
+  set n : ℤ := DD.norm with hn_def
+  set d : ℤ := t ^ 2 - 4 * n with hd_def
+  have hd_nn : 0 ≤ d := by
+    rw [not_lt] at hcontra; omega
+  set ξ : AddMonoid.End W.Point :=
+    ((2 : ℤ) : AddMonoid.End W.Point) * φ
+      - ((t : ℤ) : AddMonoid.End W.Point) with hξ_def
+  have hξS : ξ ∈ isogenyEndSubring W hNs :=
+    sub_mem (mul_mem (intCast_mem _ 2) hφS) (intCast_mem _ t)
+  have hξsq : ξ * ξ = ((d : ℤ) : AddMonoid.End W.Point) := by
+    have hφφ : φ * φ
+        = ((t : ℤ) : AddMonoid.End W.Point) * φ - ((n : ℤ) : AddMonoid.End W.Point) := by
+      have h := DD.charPoly
+      rw [← ht_def, ← hn_def, sub_add, sub_eq_zero] at h; exact h
+    rw [hξ_def, sub_mul, mul_sub, mul_sub,
+      show ((2 : ℤ) : AddMonoid.End W.Point) * φ
+        * (((2 : ℤ) : AddMonoid.End W.Point) * φ)
+          = (((2 * 2 : ℤ)) : AddMonoid.End W.Point) * (φ * φ) by
+        rw [mul_assoc, ← mul_assoc φ,
+          ← (Int.cast_commute (2 : ℤ) φ).eq, mul_assoc,
+          ← mul_assoc ((2 : ℤ) : AddMonoid.End W.Point), ← Int.cast_mul],
+      show ((2 : ℤ) : AddMonoid.End W.Point) * φ
+        * ((t : ℤ) : AddMonoid.End W.Point)
+          = (((2 * t : ℤ)) : AddMonoid.End W.Point) * φ by
+        rw [mul_assoc, ← (Int.cast_commute t φ).eq, ← mul_assoc, ← Int.cast_mul],
+      show ((t : ℤ) : AddMonoid.End W.Point)
+        * (((2 : ℤ) : AddMonoid.End W.Point) * φ)
+          = (((t * 2 : ℤ)) : AddMonoid.End W.Point) * φ by
+        rw [← mul_assoc, ← Int.cast_mul],
+      hφφ, mul_sub,
+      ← mul_assoc (((2 * 2 : ℤ)) : AddMonoid.End W.Point)
+        ((t : ℤ) : AddMonoid.End W.Point),
+      ← Int.cast_mul (2 * 2) t, ← Int.cast_mul t t,
+      show ((2 * 2 : ℤ) : AddMonoid.End W.Point) * ((n : ℤ) : AddMonoid.End W.Point)
+          = (((4 * n : ℤ)) : AddMonoid.End W.Point) by
+        rw [← Int.cast_mul]; norm_num,
+      show ((2 * 2 * t : ℤ) : AddMonoid.End W.Point)
+        = ((2 * t : ℤ) : AddMonoid.End W.Point)
+          + ((t * 2 : ℤ) : AddMonoid.End W.Point) by
+        rw [← Int.cast_add]; congr 1; ring,
+      add_mul, hd_def,
+      show ((t ^ 2 - 4 * n : ℤ) : AddMonoid.End W.Point)
+        = ((t * t : ℤ) : AddMonoid.End W.Point)
+          - ((4 * n : ℤ) : AddMonoid.End W.Point) by
+        rw [← Int.cast_sub]; congr 1; ring]
+    abel
+  obtain ⟨e, he⟩ := sq_eq_intCast_nonneg_isSquare W hNs hξS hd_nn hξsq
+  have hfact : (ξ - ((e : ℤ) : AddMonoid.End W.Point))
+      * (ξ + ((e : ℤ) : AddMonoid.End W.Point)) = 0 := by
+    have expand : (ξ - ((e : ℤ) : AddMonoid.End W.Point))
+        * (ξ + ((e : ℤ) : AddMonoid.End W.Point))
+          = ξ * ξ - ((e : ℤ) : AddMonoid.End W.Point)
+            * ((e : ℤ) : AddMonoid.End W.Point) := by
+      rw [sub_mul, mul_add, mul_add, (Int.cast_commute e ξ).eq]
+      abel
+    rw [expand, hξsq, ← Int.cast_mul, ← Int.cast_sub, he, sq,
+      sub_self, Int.cast_zero]
+  have hξbot : ξ ∈ (⊥ : Subring (AddMonoid.End W.Point)) := by
+    rcases eq_or_ne (ξ - ((e : ℤ) : AddMonoid.End W.Point)) 0 with h | h
+    · exact Subring.mem_bot.mpr ⟨e, (sub_eq_zero.mp h).symm⟩
+    · have h0 := isogenyEndSubring_mul_left_cancel W hNs
+        (sub_mem hξS (intCast_mem _ e)) h hfact
+      exact Subring.mem_bot.mpr ⟨-e, by
+        rw [Int.cast_neg]; exact neg_eq_of_add_eq_zero_left h0⟩
+  obtain ⟨s, hs⟩ := Subring.mem_bot.mp hξbot
+  have h2φ : ((2 : ℤ) : AddMonoid.End W.Point) * φ
+      = (((t + s : ℤ)) : AddMonoid.End W.Point) := by
+    have : ((2 : ℤ) : AddMonoid.End W.Point) * φ
+        = ((t : ℤ) : AddMonoid.End W.Point) + ξ := by rw [hξ_def]; abel
+    rw [this, ← hs, ← Int.cast_add]
+  have hs_sq : s ^ 2 = d := by
+    have : (((s ^ 2 : ℤ)) : AddMonoid.End W.Point)
+        = ((d : ℤ) : AddMonoid.End W.Point) := by
+      rw [← hξsq, ← hs, sq, Int.cast_mul]
+    exact intCast_addMonoidEnd_point_injective W this
+  have hprod : (t + s) * (t - s) = 4 * n := by
+    have : t ^ 2 - s ^ 2 = 4 * n := by rw [hs_sq, hd_def]; ring
+    linarith [sq_sub_sq t s]
+  have hts_even : 2 ∣ (t + s) := by
+    by_contra hndvd
+    have h1 : (t + s) % 2 = 1 := by omega
+    have h2 : (t - s) % 2 = 1 := by omega
+    have h3 : ((t + s) * (t - s)) % 2 = 1 := by
+      rw [Int.mul_emod, h1, h2]; norm_num
+    rw [hprod] at h3
+    omega
+  obtain ⟨m, hm⟩ := hts_even
+  have hcancel : ((2 : ℤ) : AddMonoid.End W.Point)
+      * (φ - ((m : ℤ) : AddMonoid.End W.Point)) = 0 := by
+    rw [mul_sub, h2φ, ← Int.cast_mul, ← Int.cast_sub, hm, sub_self, Int.cast_zero]
+  have h2ne : ((2 : ℤ) : AddMonoid.End W.Point) ≠ 0 := by
+    intro h
+    exact two_ne_zero
+      (intCast_addMonoidEnd_point_injective W (h.trans Int.cast_zero.symm))
+  have hφm : φ - ((m : ℤ) : AddMonoid.End W.Point) = 0 :=
+    isogenyEndSubring_mul_left_cancel W hNs (intCast_mem _ 2) h2ne hcancel
+  exact hbot (Subring.mem_bot.mpr ⟨m, (sub_eq_zero.mp hφm).symm⟩)
+
+theorem s7_exists_dualEndData_dual_mem_and_intLinComb_norm_pos
+    (hNs : ∀ D : IsogenyEndDatum W, NormFormulaAlong F D.ι D.hfin)
+    (φ : AddMonoid.End W.Point) (hφ : φ ∈ isogenyEndSubring W hNs) :
+    ∃ D : AddMonoid.End.DualEndData φ, D.dual ∈ isogenyEndSubring W hNs ∧
+      ∀ a b : ℤ, (a : AddMonoid.End W.Point) + (b : AddMonoid.End W.Point) * φ ≠ 0 →
+        0 < (D.intLinComb a b).norm := by
+  by_cases hbot : φ ∈ (⊥ : Subring (AddMonoid.End W.Point))
+  · obtain ⟨m, rfl⟩ := Subring.mem_bot.mp hbot
+    refine ⟨dualEndData_intCast m, intCast_mem _ m, fun a b hne => ?_⟩
+    rw [DualEndData.intLinComb_norm, dualEndData_intCast_trace, dualEndData_intCast_norm]
+    have hcast : (a : AddMonoid.End W.Point)
+        + (b : AddMonoid.End W.Point) * ((m : ℤ) : AddMonoid.End W.Point)
+          = ((a + b * m : ℤ) : AddMonoid.End W.Point) := by
+      rw [Int.cast_add, Int.cast_mul]
+    have habm : a + b * m ≠ 0 := by
+      rintro habm
+      exact hne (by rw [hcast, habm, Int.cast_zero])
+    have hsq : a ^ 2 + 2 * m * a * b + m ^ 2 * b ^ 2 = (a + b * m) ^ 2 := by ring
+    rw [hsq]; positivity
+  · have hφ0 : φ ≠ 0 := by
+      intro h; apply hbot; rw [h]; exact zero_mem _
+    obtain ⟨D, rfl⟩ :=
+      IsogenyEndDatum.exists_pointEnd_eq_of_mem_isogenyEndSubring hNs φ hφ hφ0
+    obtain ⟨DD, hdual, -⟩ :=
+      IsogenyEndDatum.exists_dualEndData_dual_mem_and_norm_eq_finrankAlong hNs D
+    have hdisc := dualEndData_disc_neg_of_notBot W hNs hφ hbot DD
+    exact ⟨DD, hdual, fun a b hne =>
+      dd_intLinComb_norm_pos_of_disc_neg_of_ne_zero DD hdisc hne⟩
+
+theorem dd_norm_trace_unique {A : Type*} [AddCommGroup A]
+    (hinj : Function.Injective (Int.cast : ℤ → AddMonoid.End A))
+    {φ : AddMonoid.End A} (DD DD₀ : DualEndData φ)
+    (hdisc : DD.trace ^ 2 < 4 * DD.norm) :
+    DD.norm = DD₀.norm ∧ DD.trace = DD₀.trace := by
+  have hcp := DD.charPoly
+  have hcp₀ := DD₀.charPoly
+  have e1 : φ * φ + (↑DD.norm : AddMonoid.End A) = ↑DD.trace * φ := by
+    have h := hcp; rw [sub_add_eq_add_sub, sub_eq_zero] at h; exact h
+  have e2 : φ * φ + (↑DD₀.norm : AddMonoid.End A) = ↑DD₀.trace * φ := by
+    have h := hcp₀; rw [sub_add_eq_add_sub, sub_eq_zero] at h; exact h
+  have hsub : (↑(DD.trace - DD₀.trace) : AddMonoid.End A) * φ
+      = ↑(DD.norm - DD₀.norm) := by
+    rw [Int.cast_sub, Int.cast_sub, sub_mul, ← e1, ← e2]
+    abel
+  set k : ℤ := DD.trace - DD₀.trace with hk_def
+  set ℓ : ℤ := DD.norm - DD₀.norm with hℓ_def
+  rcases eq_or_ne k 0 with hk | hk
+  · rw [hk, Int.cast_zero, zero_mul] at hsub
+    have hℓ0 : (↑ℓ : AddMonoid.End A) = ↑(0 : ℤ) := by
+      rw [Int.cast_zero]; exact hsub.symm
+    have hℓ : ℓ = 0 := hinj hℓ0
+    refine ⟨?_, ?_⟩
+    · rw [hℓ_def] at hℓ; linarith
+    · rw [hk_def] at hk; linarith
+  · exfalso
+    have hcent : Commute (↑k : AddMonoid.End A) φ := Int.cast_commute k φ
+    have hA : (↑k : AddMonoid.End A) ^ 2 * φ ^ 2 = (↑ℓ : AddMonoid.End A) ^ 2 := by
+      rw [← hcent.mul_pow, hsub]
+    have hB : (↑k : AddMonoid.End A) ^ 2 * (↑DD.trace * φ)
+        = (↑DD.trace : AddMonoid.End A) * ↑k * ↑ℓ := by
+      rw [sq, mul_assoc,
+        ← mul_assoc (↑k : AddMonoid.End A) (↑DD.trace) φ,
+        (Int.cast_commute k (↑DD.trace : AddMonoid.End A)).eq,
+        mul_assoc (↑DD.trace : AddMonoid.End A), hsub, ← mul_assoc,
+        (Int.cast_commute k (↑DD.trace : AddMonoid.End A)).eq]
+    have hZ : ℓ ^ 2 - DD.trace * k * ℓ + k ^ 2 * DD.norm = 0 := by
+      have h0 : (↑k : AddMonoid.End A) ^ 2
+          * (φ * φ - ↑DD.trace * φ + ↑DD.norm) = 0 := by
+        rw [hcp, mul_zero]
+      rw [mul_add, mul_sub, ← sq, hA, hB] at h0
+      have h1 : ((ℓ ^ 2 - DD.trace * k * ℓ + k ^ 2 * DD.norm : ℤ) : AddMonoid.End A)
+          = ↑(0 : ℤ) := by
+        rw [Int.cast_zero]; push_cast; exact h0
+      exact hinj h1
+    have hk2 : (0 : ℤ) < k ^ 2 := by positivity
+    nlinarith [sq_nonneg (2 * ℓ - DD.trace * k), hZ, hk2, hdisc]
+
+theorem s7_dualEndData_norm_eq_finrankAlong
+    (hNs : ∀ D : IsogenyEndDatum W, NormFormulaAlong F D.ι D.hfin)
+    (D : IsogenyEndDatum W) (DD : AddMonoid.End.DualEndData (D.pointEnd (hNs D)))
+    (hdisc : DD.trace ^ 2 < 4 * DD.norm) :
+    DD.norm = finrankAlong F D.ι := by
+  obtain ⟨DD₀, -, hd⟩ :=
+    IsogenyEndDatum.exists_dualEndData_dual_mem_and_norm_eq_finrankAlong hNs D
+  rw [← hd]
+  exact (dd_norm_trace_unique (intCast_addMonoidEnd_point_injective W) DD DD₀ hdisc).1
+
+theorem s7_exists_sq_lt_four_mul_and_forall_exists_finrankAlong_eq
+    (hNs : ∀ D : IsogenyEndDatum W, NormFormulaAlong F D.ι D.hfin)
+    (D₀ : IsogenyEndDatum W)
+    (hD₀ : ¬ ∃ m : ℤ, ∀ P : W.Point, D₀.pointEnd (hNs D₀) P = m • P) :
+    ∃ t n : ℤ, t ^ 2 < 4 * n ∧
+      ∀ a b : ℤ, b ≠ 0 → ∃ D : IsogenyEndDatum W,
+        (finrankAlong F D.ι : ℤ) = a ^ 2 + t * a * b + n * b ^ 2 := by
+  have hφS : D₀.pointEnd (hNs D₀) ∈ isogenyEndSubring W hNs :=
+    IsogenyEndDatum.pointEnd_mem_isogenyEndSubring W hNs D₀
+  have hφnb : D₀.pointEnd (hNs D₀) ∉ (⊥ : Subring (AddMonoid.End W.Point)) :=
+    fun hmem => hD₀ ((mem_bot_addMonoidEnd_iff _).mp hmem)
+  obtain ⟨DD, -, -⟩ :=
+    IsogenyEndDatum.exists_dualEndData_dual_mem_and_norm_eq_finrankAlong hNs D₀
+  have hdisc : DD.trace ^ 2 < 4 * DD.norm :=
+    dualEndData_disc_neg_of_notBot W hNs hφS hφnb DD
+  refine ⟨DD.trace, DD.norm, hdisc, fun a b hb => ?_⟩
+  have hψmem :
+      (a : AddMonoid.End W.Point) + (b : AddMonoid.End W.Point) * D₀.pointEnd (hNs D₀)
+        ∈ isogenyEndSubring W hNs :=
+    add_mem (intCast_mem _ a) (mul_mem (intCast_mem _ b) hφS)
+  have hlin := linearIndependent_one_of_quadCharPoly_neg_disc
+    (intCast_addMonoidEnd_point_injective W) (dd_charPoly_eq DD) hdisc
+  have hψne :
+      (a : AddMonoid.End W.Point) + (b : AddMonoid.End W.Point) * D₀.pointEnd (hNs D₀) ≠ 0 :=
+    fun heq => hb (hlin a b heq).2
+  obtain ⟨D', hD'pt⟩ :=
+    IsogenyEndDatum.exists_pointEnd_eq_of_mem_isogenyEndSubring hNs _ hψmem hψne
+  have hdisc' : (DD.intLinComb a b).trace ^ 2 < 4 * (DD.intLinComb a b).norm :=
+    DD.intLinComb_disc_neg hb hdisc
+  have hcast : ∀ {φ ψ : AddMonoid.End W.Point} (h : φ = ψ) (E : AddMonoid.End.DualEndData ψ),
+      (h ▸ E).norm = E.norm ∧ (h ▸ E).trace = E.trace := by
+    intro φ ψ h E; subst h; exact ⟨rfl, rfl⟩
+  have hnorm : (DD.intLinComb a b).norm = finrankAlong F D'.ι := by
+    have h := s7_dualEndData_norm_eq_finrankAlong W hNs D' (hD'pt ▸ DD.intLinComb a b)
+      (by rw [(hcast hD'pt _).1, (hcast hD'pt _).2]; exact hdisc')
+    rwa [(hcast hD'pt _).1] at h
+  refine ⟨D', ?_⟩
+  rw [← hnorm, DualEndData.intLinComb_norm]
+
+end CurveD
+
+end Ws13S7
+
+end
+
+theorem solution
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    (W : WeierstrassCurve.Affine F) [W.IsElliptic] [GenusOnePlaceGate W] [AbelTheorem W]
+    [GenusOnePlaceGate.IsCentred W]
+    (hNs : ∀ D : IsogenyEndDatum W, NormFormulaAlong F D.ι D.hfin)
+    (D₀ : IsogenyEndDatum W) (hD₀ : ¬ ∃ m : ℤ, ∀ P : W.Point, D₀.pointEnd (hNs D₀) P = m • P) :
+    ∃ t n : ℤ, t ^ 2 < 4 * n ∧
+      ∀ a b : ℤ, b ≠ 0 → ∃ D : IsogenyEndDatum W,
+        (finrankAlong F D.ι : ℤ) = a ^ 2 + t * a * b + n * b ^ 2 :=
+  Ws13S7.s7_exists_sq_lt_four_mul_and_forall_exists_finrankAlong_eq W hNs D₀ hD₀
+
+end S_OVERLONG_e21b3de7
+end P2MW
+export
+  P2MW.S_OVERLONG_e21b3de7
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+universe u
+theorem
+  WeierstrassCurve.Affine.IsogenyEndDatum.exists_sq_lt_four_mul_and_forall_exists_finrankAlong_eq
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    (W : WeierstrassCurve.Affine F) [W.IsElliptic] [GenusOnePlaceGate W] [AbelTheorem W]
+    [GenusOnePlaceGate.IsCentred W]
+    (hNs : ∀ D : IsogenyEndDatum W, NormFormulaAlong F D.ι D.hfin)
+    (D₀ : IsogenyEndDatum W) (hD₀ : ¬ ∃ m : ℤ, ∀ P : W.Point, D₀.pointEnd (hNs D₀) P = m • P) :
+    ∃ t n : ℤ, t ^ 2 < 4 * n ∧
+      ∀ a b : ℤ, b ≠ 0 → ∃ D : IsogenyEndDatum W,
+        (finrankAlong F D.ι : ℤ) = a ^ 2 + t * a * b + n * b ^ 2 :=
+  solution W hNs D₀ hD₀
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_pointEnd_apply_eq_sub.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_pointEnd_apply_eq_sub.lean
new file mode 100644
index 0000000000..c415730db6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyEndDatum_pointEnd_apply_eq_sub.lean
@@ -0,0 +1,116 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.IsogenyEndDatum.pointEnd_apply_eq_sub
+(2a48382c-2930-5c17-be93-7b0083958996) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 412fe9f9-b1d7-5d9d-ba2d-1f0ded8b5588
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Point endomorphism of an isogeny datum equals h(P)-h(O)
+
+Theorem statement: `WeierstrassCurve.Affine.IsogenyEndDatum.pointEnd_apply_eq_sub`
+(`2a48382c-2930-5c17-be93-7b0083958996`), by Claude, 2026-09-05.
+
+Proof: submission `412fe9f9-b1d7-5d9d-ba2d-1f0ded8b5588`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field of characteristic $0$ and let $W$ be an affine Weierstrass
+curve over $F$ which is elliptic, equipped with two structures: `GenusOnePlaceGate W`, consisting of
+a bijection `pointEquivPlace` between the group $W(F)$ of points `W.Point` and the set of places of
+the function field `W.FunctionField` over $F$ (a place being a proper valuation subring containing
+the image of $F$ and having principal ideals) together with the assertion that every such place has
+degree $1$; and `AbelTheorem W`, the assertion that a divisor of degree $0$ on `W.FunctionField` is
+principal exactly when its `divisorSum`, the image of its point support under the dictionary,
+vanishes. Let $D$ be an `IsogenyEndDatum` for $W$, i.e. an $F$-algebra endomorphism $\iota =
+D.\iota$ of `W.FunctionField` whose underlying ring map is integral and which makes
+`W.FunctionField` a finite module over itself, and assume `hN`, the push-forward norm formula along
+$\iota$: for every nonzero $f$ and every divisor equal to $\operatorname{div}(f)$ upstairs, the
+push-forward takes at each place $v$ downstairs the value $v(\mathrm{N}(f))$. Then for every point
+$P$ the additive endomorphism `D.pointEnd hN` of `W.Point` satisfies $$D.\text{pointEnd}\,hN\,(P) =
+\iota^{*}(v_P) - \iota^{*}(v_O),$$ where $v_Q$ denotes `placeOfPoint Q`, $\iota^{*}$ is
+`Place.restrictAlong D.ι D.hι` (the valuation subring pulled back along $\iota$), and both places
+are carried back to points by the inverse of `pointEquivPlace`; here $O$ is the zero point.
+
+This is the rigidity statement in the conditional place-theoretic set-up: the group endomorphism of
+$W(F)$ obtained by transporting push-forward of degree-zero divisors along $\iota$ through the
+Abel–Jacobi dictionary is the geometric self-map $h$ determined by $\iota$ on places, corrected by
+subtracting $h(O)$, so that $h$ is a translation composed with an isogeny. It is used by
+[`WeierstrassCurve.Affine.IsogenyEndDatum.exists_pointEnd_eq_add`]
+(thm.html#WeierstrassCurve.Affine.IsogenyEndDatum.exists_pointEnd_eq_add),
+which passes between morphism-level identities for $\iota$ and additive identities for `pointEnd`.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_IsogenyEndDatum_pointEnd_apply_eq_sub.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_IsogenyEndDatum_pointEnd_apply_eq_sub
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+universe u
+
+theorem solution
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    {W : WeierstrassCurve.Affine F} [W.IsElliptic] [GenusOnePlaceGate W] [AbelTheorem W]
+    (D : IsogenyEndDatum W) (hN : NormFormulaAlong F D.ι D.hfin) (P : W.Point) :
+    D.pointEnd hN P
+      = (pointEquivPlace (W := W)).symm ((placeOfPoint P).restrictAlong D.ι D.hι)
+        - (pointEquivPlace (W := W)).symm ((placeOfPoint (0 : W.Point)).restrictAlong D.ι D.hι) :=
+          by
+  set Q : W.Point := (pointEquivPlace (W := W)).symm ((placeOfPoint P).restrictAlong D.ι D.hι) with
+    hQ
+  set Q₀ : W.Point :=
+    (pointEquivPlace (W := W)).symm ((placeOfPoint (0 : W.Point)).restrictAlong D.ι D.hι) with hQ₀
+  have hP : (placeOfPoint P).restrictAlong D.ι D.hι = placeOfPoint Q :=
+    ((pointEquivPlace (W := W)).apply_symm_apply _).symm
+  have h0 : (placeOfPoint (0 : W.Point)).restrictAlong D.ι D.hι = placeOfPoint Q₀ :=
+    ((pointEquivPlace (W := W)).apply_symm_apply _).symm
+  have hdiv : (Pic0.pushforwardAlongDegZero D.ι D.hι (pointDivisor P) :
+      AlgebraicCurve.Divisor F W.FunctionField)
+        = Finsupp.single (placeOfPoint Q) 1 - Finsupp.single (placeOfPoint Q₀) 1 := by
+    rw [Pic0.coe_pushforwardAlongDegZero, coe_pointDivisor, map_sub,
+      pushforwardAlong_single_eq D.ι D.hι, pushforwardAlong_single_eq D.ι D.hι, hP, h0]
+  rw [IsogenyEndDatum.pointEnd_apply, pointClass, Pic0.pushforwardAlongHom_mk,
+    genusOnePic0Equiv_apply, pic0ToPoint_mk, hdiv, map_sub, divisorSum_single_placeOfPoint,
+    divisorSum_single_placeOfPoint, one_smul, one_smul]
+
+end S_WeierstrassCurve_Affine_IsogenyEndDatum_pointEnd_apply_eq_sub
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_IsogenyEndDatum_pointEnd_apply_eq_sub (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+universe u
+theorem WeierstrassCurve.Affine.IsogenyEndDatum.pointEnd_apply_eq_sub
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    {W : WeierstrassCurve.Affine F} [W.IsElliptic] [GenusOnePlaceGate W] [AbelTheorem W]
+    (D : IsogenyEndDatum W) (hN : NormFormulaAlong F D.ι D.hfin) (P : W.Point) :
+    D.pointEnd hN P
+      = (pointEquivPlace (W := W)).symm ((placeOfPoint P).restrictAlong D.ι D.hι)
+        - (pointEquivPlace (W := W)).symm ((placeOfPoint (0 : W.Point)).restrictAlong D.ι D.hι) :=
+  solution D hN P
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyHomDatum_exists_pointHom_comp_eq_of_ker_le_of_isCentred.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyHomDatum_exists_pointHom_comp_eq_of_ker_le_of_isCentred.lean
new file mode 100644
index 0000000000..19349543df
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyHomDatum_exists_pointHom_comp_eq_of_ker_le_of_isCentred.lean
@@ -0,0 +1,480 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.Affine.IsogenyHomDatum.exists_pointHom_comp_eq_of_ker_le_of_isCentred
+(217861b0-b122-56d6-87cc-27a3f701a2a1) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 114a08cd-9b12-573a-8e8d-bb9fb4412caf
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.FieldTheory.Relrank
+import Mathlib.Order.CompletePartialOrder
+import Mathlib.RingTheory.Flat.TorsionFree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_restrictAlong_restrictAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyHomDatum_pointHom_apply_eq_sub
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_algHom_ext_of_forall_restrictAlong_placeOfPoint_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_algEquiv_restrictAlong_placeOfPoint_eq_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_natCard_ker_pointMapOfPushforward_eq_finrankAlong
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Factoring an isogeny through one with smaller kernel
+
+Theorem statement:
+`WeierstrassCurve.Affine.IsogenyHomDatum.exists_pointHom_comp_eq_of_ker_le_of_isCentred`
+(`217861b0-b122-56d6-87cc-27a3f701a2a1`), by Claude, 2026-09-05.
+
+Proof: submission `114a08cd-9b12-573a-8e8d-bb9fb4412caf`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field of characteristic zero and let $V_0, V_1, V_2$ be affine
+Weierstrass curves over $F$, each elliptic and each equipped with two pieces of structure: a
+`GenusOnePlaceGate`, i.e. a bijection between the group of points $V_i.\mathrm{Point}$ and the set
+of places of $F(V_i)$ over $F$ together with the assertion that every such place has degree $1$; and
+`AbelTheorem`, i.e. the assertion that a divisor of degree $0$ on $F(V_i)$ is principal (a divisor
+of some nonzero function, place by place) exactly when its divisor sum in the point group vanishes.
+Assume moreover that the gate on $V_0$ is centred (`GenusOnePlaceGate.IsCentred`): for every affine
+nonsingular point $(x,y)$ of $V_0$, the images in $F(V_0)$ of the coordinate-ring classes
+$\mathrm{XClass}\,x$ and $\mathrm{YClass}\,(C\,y)$ lie in the nonunits of the valuation subring of
+the place attached to `Point.some x y h`. Let $\varphi$ be an `IsogenyHomDatum V₀ V₁`, that is an
+$F$-algebra map $\iota_\varphi \colon F(V_1) \to F(V_0)$ which is integral and for which $F(V_0)$ is
+a finite module over $F(V_1)$ along $\iota_\varphi$, and let $h_{N\varphi}$ be a push-forward
+norm-formula witness for $\iota_\varphi$: for every nonzero $f \in F(V_0)$, every divisor $D$ with
+$D(w) = \mathrm{ord}_w f$ at all places $w$ of $F(V_0)$, and every place $v$ of $F(V_1)$, the
+push-forward of $D$ at $v$ equals $\mathrm{ord}_v(\mathrm{Norm}(f))$. Let $\psi$ together with
+$h_{N\psi}$ be such a datum for $V_0$ and $V_2$. Write $\varphi_*, \psi_*$ for the induced group
+homomorphisms $V_0.\mathrm{Point} \to V_1.\mathrm{Point}$, $V_2.\mathrm{Point}$ obtained by
+transporting the push-forward on degree-zero divisor classes through the gates. Assume that every
+$P$ with $\varphi_*(P) = 0$ also satisfies $\psi_*(P) = 0$. Then there exist an `IsogenyHomDatum V₁
+V₂`, that is an integral $F$-algebra map $F(V_2) \to F(V_1)$ making $F(V_1)$ finite over $F(V_2)$,
+and a norm-formula witness for it, whose induced homomorphism $\chi_* \colon V_1.\mathrm{Point} \to
+V_2.\mathrm{Point}$ satisfies $\chi_*(\varphi_*(P)) = \psi_*(P)$ for all $P \in V_0.\mathrm{Point}$.
+The conclusion is an equality of maps on points, not an equality of maps of function fields.
+
+This is the factorisation property of isogenies: if $\ker\varphi \subseteq \ker\psi$ then $\psi$
+factors as $\chi \circ \varphi$ for an isogeny $\chi$, here in the form tied to the place-gate
+presentation of the point group and requiring the gate on the source curve to be centred. It is used
+in the computation of kernels of push-forward maps and in the identification of the subgroup of
+multiples attached to Vélu quotients with equal $j$-invariants.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_IsogenyHomDatum_exists_pointHom_comp_eq_of_ker_le_of_isCentred.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_c76b33b5
+
+
+noncomputable section
+
+p2m_open "WeierstrassCurve WeierstrassCurve.Affine~pointHom AlgebraicCurve"
+
+universe u
+
+namespace S13CIII
+
+section Generic
+
+variable {K A B : Type*} [Field K] [Field A] [Field B] [Algebra K A] [Algebra K B]
+
+theorem exists_factor_of_range_le {C : Type*} [Field C] [Algebra K C]
+    (ι : A →ₐ[K] B) (μ : C →ₐ[K] B) (hrange : μ.range ≤ ι.range) :
+    ∃ ξ : C →ₐ[K] A, ι.comp ξ = μ := by
+  have hιinj : Function.Injective ι := RingHom.injective ι.toRingHom
+  let e : A ≃ₐ[K] ι.range := AlgEquiv.ofInjective ι hιinj
+  refine ⟨e.symm.toAlgHom.comp ((Subalgebra.inclusion hrange).comp μ.rangeRestrict), ?_⟩
+  ext b
+  have key : ∀ x : ι.range, ι (e.symm x) = ↑x := fun x => by
+    conv_rhs => rw [← e.apply_symm_apply x]
+    rfl
+  simp only [AlgHom.comp_apply]
+  exact key _
+
+theorem finiteAlong_factor {C : Type*} [Field C] [Algebra K C]
+    (ι : A →ₐ[K] B) (ξ : C →ₐ[K] A)
+    (hfin : FiniteAlong K (ι.comp ξ)) : FiniteAlong K ξ := by
+  let mCA : Module C A := (algebraAlong ξ).toModule
+  let mCB : Module C B := (algebraAlong (ι.comp ξ)).toModule
+  let ιLin : @LinearMap C C _ _ (RingHom.id C) A B _ _ mCA mCB :=
+    { toFun := ι
+      map_add' := map_add ι
+      map_smul' := fun r a => by
+        change ι (ξ r * a) = ι (ξ r) * ι a
+        exact map_mul ι (ξ r) a }
+  have hCB : @FiniteDimensional C B _ _ mCB := hfin
+  exact @FiniteDimensional.of_injective C A _ _ mCA B _ mCB ιLin
+    (RingHom.injective ι.toRingHom) hCB
+
+theorem isIntegral_of_finiteAlong {C : Type*} [Field C] [Algebra K C] (ξ : C →ₐ[K] A)
+    (hfin : FiniteAlong K ξ) : ξ.toRingHom.IsIntegral := by
+  let := algebraAlong ξ
+  have : Module.Finite C A := hfin
+  have h : Algebra.IsIntegral C A := Algebra.IsIntegral.of_finite C A
+  intro a
+  exact h.isIntegral a
+
+theorem finrankAlong_eq_finrank_fieldRange (φ : A →ₐ[K] B) :
+    finrankAlong K φ = Module.finrank φ.fieldRange B := by
+  change (letI := algebraAlong φ; Module.finrank A B) = Module.finrank φ.fieldRange B
+  let := algebraAlong φ
+  exact Algebra.finrank_eq_of_equiv_equiv
+    (AlgEquiv.ofInjectiveField φ).toRingEquiv (RingEquiv.refl B) (by ext x; rfl)
+
+theorem finrank_toSubfield_eq {L : Type*} [Field L] [Algebra K L] (E : IntermediateField K L) :
+    Module.finrank E.toSubfield L = Module.finrank E L :=
+  Algebra.finrank_eq_of_equiv_equiv
+    (⟨⟨fun x => ⟨x.1, x.2⟩, fun x => ⟨x.1, x.2⟩, fun _ => rfl, fun _ => rfl⟩,
+      fun _ _ => rfl, fun _ _ => rfl⟩ : E.toSubfield ≃+* E)
+    (RingEquiv.refl L) (by ext x; rfl)
+
+theorem restrictAlong_congr {φ₁ φ₂ : A →ₐ[K] B} (h : φ₁ = φ₂)
+    (h₁ : φ₁.toRingHom.IsIntegral) (h₂ : φ₂.toRingHom.IsIntegral) (w : Place K B) :
+    w.restrictAlong φ₁ h₁ = w.restrictAlong φ₂ h₂ := by subst h; rfl
+
+theorem restrictAlong_algHomId (w : Place K A) (h : (AlgHom.id K A).toRingHom.IsIntegral) :
+    w.restrictAlong (AlgHom.id K A) h = w :=
+  Place.ext (SetLike.ext fun _ => Iff.rfl)
+
+theorem isRational_of_deg_eq_one (v : Place K A) (h : v.deg = 1) : v.IsRational := by
+  intro x
+  have hbot : (⊥ : Subalgebra K v.ResidueField) = ⊤ :=
+    Subalgebra.bot_eq_top_iff_finrank_eq_one.mpr h
+  have hx : x ∈ (⊥ : Subalgebra K v.ResidueField) := by
+    rw [hbot]; exact Algebra.mem_top
+  exact Algebra.mem_bot.mp hx
+
+theorem normFormulaAlong_of_finiteAlong [CharZero K] [HasPrincipalDivisors K B]
+    (ι : A →ₐ[K] B) (hfin : FiniteAlong K ι) : NormFormulaAlong K ι hfin := by
+  have : CharZero A := charZero_of_injective_algebraMap (algebraMap K A).injective
+  have hsep : SeparableAlong K ι := by
+    let := algebraAlong ι
+    have := isScalarTower_along ι
+    have : Module.Finite A B := hfin
+    change Algebra.IsSeparable A B
+    infer_instance
+  exact AlgebraicCurve.normFormulaAlong ι hfin hsep
+
+end Generic
+
+section HMap
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {U V : WeierstrassCurve.Affine F}
+variable [U.IsElliptic] [GenusOnePlaceGate U] [AbelTheorem U]
+variable [V.IsElliptic] [GenusOnePlaceGate V] [AbelTheorem V]
+
+def hmap (η : IsogenyHomDatum U V) (P : U.Point) : V.Point :=
+  (pointEquivPlace (W := V)).symm ((placeOfPoint P).restrictAlong η.ι η.hι)
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic U] [U.AbelTheorem]
+  [WeierstrassCurve.IsElliptic V] [V.AbelTheorem] in
+theorem hmap_seam (η : IsogenyHomDatum U V) (P : U.Point) :
+    (placeOfPoint P).restrictAlong η.ι η.hι = placeOfPoint (hmap η P) :=
+  ((pointEquivPlace (W := V)).apply_symm_apply _).symm
+
+theorem pointHom_eq_hmap_sub (η : IsogenyHomDatum U V) (hN : NormFormulaAlong F η.ι η.hfin)
+    (P : U.Point) :
+    η.pointHom hN P = hmap η P - hmap η 0 :=
+  IsogenyHomDatum.pointHom_apply_eq_sub η hN P
+
+theorem hmap_add_of_ker (η : IsogenyHomDatum U V) (hN : NormFormulaAlong F η.ι η.hfin)
+    (P T : U.Point)
+    (hT : η.pointHom hN T = 0) : hmap η (P + T) = hmap η P := by
+  have h1 := pointHom_eq_hmap_sub η hN (P + T)
+  have h2 := pointHom_eq_hmap_sub η hN P
+  rw [map_add, hT, add_zero, h2] at h1
+  exact (sub_left_inj.mp h1).symm
+
+omit [DecidableEq F] in
+omit [IsAlgClosed F] [CharZero F] in
+theorem placeOfPoint_inj {W : WeierstrassCurve.Affine F} [GenusOnePlaceGate W] {P Q : W.Point}
+    (h : placeOfPoint P = placeOfPoint Q) : P = Q := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).injective h
+
+end HMap
+
+section Main
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {V₀ V₁ V₂ : WeierstrassCurve.Affine F}
+variable [V₀.IsElliptic] [GenusOnePlaceGate V₀] [AbelTheorem V₀]
+variable [V₁.IsElliptic] [GenusOnePlaceGate V₁] [AbelTheorem V₁]
+variable [V₂.IsElliptic] [GenusOnePlaceGate V₂] [AbelTheorem V₂]
+variable [GenusOnePlaceGate.IsCentred V₀]
+
+omit [DecidableEq F] in
+omit [IsAlgClosed F] [CharZero F] in
+theorem hrat_of_gate {V : WeierstrassCurve.Affine F} [V.IsElliptic] [GenusOnePlaceGate V] :
+    ∀ w : Place F V.FunctionField, w.IsRational := by
+  classical
+  exact
+    fun w => isRational_of_deg_eq_one w (GenusOnePlaceGate.deg_eq_one w)
+
+def τ (R : V₀.Point) : V₀.FunctionField ≃ₐ[F] V₀.FunctionField :=
+  (exists_algEquiv_restrictAlong_placeOfPoint_eq_add (W := V₀) R).choose
+
+theorem τ_isIntegral (R : V₀.Point) : (τ R).toAlgHom.toRingHom.IsIntegral :=
+  (exists_algEquiv_restrictAlong_placeOfPoint_eq_add (W := V₀) R).choose_spec.choose
+
+theorem τ_seam (R Q : V₀.Point) :
+    (placeOfPoint Q).restrictAlong (τ R).toAlgHom (τ_isIntegral R) = placeOfPoint (Q + R) :=
+  (exists_algEquiv_restrictAlong_placeOfPoint_eq_add (W := V₀) R).choose_spec.choose_spec Q
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic V₀]
+  [V₀.GenusOnePlaceGate] [V₀.AbelTheorem] [GenusOnePlaceGate.IsCentred V₀] in
+theorem algEquiv_isIntegral (e : V₀.FunctionField ≃ₐ[F] V₀.FunctionField) :
+    e.toAlgHom.toRingHom.IsIntegral :=
+  RingHom.isIntegral_of_surjective _ e.surjective
+
+theorem restrictAlong_congr_proof {K A B : Type*} [Field K] [Field A] [Field B] [Algebra K A]
+    [Algebra K B]
+    (φ : A →ₐ[K] B) (h h' : φ.toRingHom.IsIntegral) (w : Place K B) :
+    w.restrictAlong φ h = w.restrictAlong φ h' := rfl
+
+theorem τ_add (S T : V₀.Point) : τ (S + T) = (τ S) * (τ T) := by
+  apply AlgEquiv.ext
+  intro f
+  have hint : ((τ S).toAlgHom.comp (τ T).toAlgHom).toRingHom.IsIntegral :=
+    RingHom.IsIntegral.trans _ _ (τ_isIntegral T) (τ_isIntegral S)
+  have key : (τ (S + T)).toAlgHom = (τ S).toAlgHom.comp (τ T).toAlgHom := by
+    refine algHom_ext_of_forall_restrictAlong_placeOfPoint_eq (V := V₀) hrat_of_gate
+      (τ (S + T)).toAlgHom ((τ S).toAlgHom.comp (τ T).toAlgHom) (τ_isIntegral (S + T))
+      hint (fun P => ?_)
+    rw [τ_seam, ← Place.restrictAlong_restrictAlong (τ T).toAlgHom (τ S).toAlgHom (τ_isIntegral T)
+      (τ_isIntegral S) hint (placeOfPoint P), τ_seam, τ_seam, add_assoc]
+  exact DFunLike.congr_fun key f
+
+theorem τ_zero : τ (0 : V₀.Point) = 1 := by
+  apply AlgEquiv.ext
+  intro f
+  have key : (τ (0 : V₀.Point)).toAlgHom = (1 : V₀.FunctionField ≃ₐ[F] V₀.FunctionField).toAlgHom :=
+    by
+    refine algHom_ext_of_forall_restrictAlong_placeOfPoint_eq (V := V₀) hrat_of_gate
+      _ _ (τ_isIntegral 0) (algEquiv_isIntegral _) (fun P => ?_)
+    rw [τ_seam, add_zero]
+    exact (restrictAlong_algHomId (placeOfPoint P) _).symm
+  exact DFunLike.congr_fun key f
+
+theorem τ_eq_one_imp {T : V₀.Point} (h : τ T = 1) : T = 0 := by
+  have h1 := τ_seam T 0
+  have h2 : (placeOfPoint (0 : V₀.Point)).restrictAlong (τ T).toAlgHom (τ_isIntegral T)
+      = placeOfPoint (0 : V₀.Point) := by
+    have : (τ T).toAlgHom = AlgHom.id F V₀.FunctionField := by rw [h]; rfl
+    simp only [this]
+    exact restrictAlong_algHomId _ _
+  rw [h2, zero_add] at h1
+  exact ((placeOfPoint_injective' (W := V₀)) h1).symm
+where
+  placeOfPoint_injective' {W : WeierstrassCurve.Affine F} [GenusOnePlaceGate W] :
+      Function.Injective (placeOfPoint (W := W)) := (pointEquivPlace (W := W)).injective
+
+variable (φ : IsogenyHomDatum V₀ V₁) (hNφ : NormFormulaAlong F φ.ι φ.hfin)
+
+def kerActHom :
+    Multiplicative (φ.pointHom hNφ).ker →* (V₀.FunctionField ≃ₐ[F] V₀.FunctionField) where
+  toFun T := τ ((Multiplicative.toAdd T : (φ.pointHom hNφ).ker) : V₀.Point)
+  map_one' := by
+    change τ ((Multiplicative.toAdd 1 : (φ.pointHom hNφ).ker) : V₀.Point) = 1
+    rw [toAdd_one]; exact τ_zero
+  map_mul' S T := by
+    change τ (((Multiplicative.toAdd (S * T)) : (φ.pointHom hNφ).ker) : V₀.Point) = _
+    rw [toAdd_mul, AddSubgroup.coe_add, τ_add]
+
+omit [WeierstrassCurve.IsElliptic V₁] in
+theorem kerActHom_apply (T : (φ.pointHom hNφ).ker) :
+    kerActHom φ hNφ (Multiplicative.ofAdd T) = τ (T : V₀.Point) := rfl
+
+omit [WeierstrassCurve.IsElliptic V₁] in
+theorem kerActHom_injective : Function.Injective (kerActHom φ hNφ) := by
+  rw [injective_iff_map_eq_one]
+  intro T hT
+  have h0 : ((Multiplicative.toAdd T : (φ.pointHom hNφ).ker) : V₀.Point) = 0 := τ_eq_one_imp hT
+  have : Multiplicative.toAdd T = (0 : (φ.pointHom hNφ).ker) := Subtype.ext h0
+  exact Multiplicative.toAdd.injective this
+
+scoped instance instMulSemiringActionKer :
+    MulSemiringAction (Multiplicative (φ.pointHom hNφ).ker) V₀.FunctionField :=
+  MulSemiringAction.compHom _ (kerActHom φ hNφ)
+
+omit [WeierstrassCurve.IsElliptic V₁] in
+theorem ker_smul_def (T : Multiplicative (φ.pointHom hNφ).ker) (f : V₀.FunctionField) :
+    T • f = kerActHom φ hNφ T f := rfl
+
+scoped instance instFaithfulKer :
+    FaithfulSMul (Multiplicative (φ.pointHom hNφ).ker) V₀.FunctionField where
+  eq_of_smul_eq_smul h := kerActHom_injective φ hNφ (AlgEquiv.ext h)
+
+omit [WeierstrassCurve.IsElliptic V₁] in
+theorem mem_fixedPoints_iff (f : V₀.FunctionField) :
+    f ∈ FixedPoints.subfield (Multiplicative (φ.pointHom hNφ).ker) V₀.FunctionField ↔
+      ∀ T : V₀.Point, φ.pointHom hNφ T = 0 → τ T f = f := by
+  constructor
+  · intro hf T hT
+    exact hf (Multiplicative.ofAdd (⟨T, hT⟩ : (φ.pointHom hNφ).ker))
+  · intro hf g
+    exact hf ((Multiplicative.toAdd g : (φ.pointHom hNφ).ker) : V₀.Point) (Multiplicative.toAdd g).2
+
+theorem τ_comp_eq_of_ker {V : WeierstrassCurve.Affine F} [V.IsElliptic] [GenusOnePlaceGate V]
+    [AbelTheorem V]
+    (η : IsogenyHomDatum V₀ V) (hN : NormFormulaAlong F η.ι η.hfin) (T : V₀.Point)
+    (hT : η.pointHom hN T = 0) : (τ T).toAlgHom.comp η.ι = η.ι := by
+  have hint : ((τ T).toAlgHom.comp η.ι).toRingHom.IsIntegral :=
+    RingHom.IsIntegral.trans _ _ η.hι (τ_isIntegral T)
+  refine algHom_ext_of_forall_restrictAlong_placeOfPoint_eq (V := V₀) hrat_of_gate
+    _ _ hint η.hι (fun P => ?_)
+  rw [← Place.restrictAlong_restrictAlong η.ι (τ T).toAlgHom η.hι (τ_isIntegral T) hint,
+    τ_seam, hmap_seam, hmap_seam, hmap_add_of_ker η hN P T hT]
+
+theorem fieldRange_le_fixedPoints :
+    φ.ι.fieldRange.toSubfield
+      ≤ FixedPoints.subfield (Multiplicative (φ.pointHom hNφ).ker) V₀.FunctionField := by
+  intro f hf
+  rw [mem_fixedPoints_iff]
+  intro T hT
+  obtain ⟨g, rfl⟩ : ∃ g, φ.ι g = f := by
+    simpa [AlgHom.fieldRange, IntermediateField.mem_toSubfield] using hf
+  exact DFunLike.congr_fun (τ_comp_eq_of_ker φ hNφ T hT) g
+
+omit [GenusOnePlaceGate.IsCentred V₀] in
+theorem natCard_ker : Nat.card (φ.pointHom hNφ).ker = finrankAlong F φ.ι :=
+  natCard_ker_pointMapOfPushforward_eq_finrankAlong V₀ V₁ φ.ι φ.hι φ.hfin hNφ
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic V₀]
+  [V₀.GenusOnePlaceGate] [V₀.AbelTheorem] [WeierstrassCurve.IsElliptic V₁] [V₁.GenusOnePlaceGate]
+  [V₁.AbelTheorem] [GenusOnePlaceGate.IsCentred V₀] in
+theorem finrankAlong_pos : 0 < finrankAlong F φ.ι := by
+  let := algebraAlong φ.ι
+  have : Module.Finite V₁.FunctionField V₀.FunctionField := φ.hfin
+  exact Module.finrank_pos
+
+scoped instance instFiniteKer : Finite (φ.pointHom hNφ).ker :=
+  Nat.finite_of_card_ne_zero (by rw [natCard_ker]; exact (finrankAlong_pos φ).ne')
+
+scoped instance instFintypeKer : Fintype (φ.pointHom hNφ).ker := Fintype.ofFinite _
+
+scoped instance instFintypeKerMul : Fintype (Multiplicative (φ.pointHom hNφ).ker) :=
+  Fintype.ofFinite _
+
+theorem fieldRange_eq_fixedPoints :
+    φ.ι.fieldRange.toSubfield
+      = FixedPoints.subfield (Multiplicative (φ.pointHom hNφ).ker) V₀.FunctionField := by
+  set A : Subfield V₀.FunctionField := φ.ι.fieldRange.toSubfield with hA
+  set B : Subfield V₀.FunctionField :=
+    FixedPoints.subfield (Multiplicative (φ.pointHom hNφ).ker) V₀.FunctionField with hB
+  have hAB : A ≤ B := fieldRange_le_fixedPoints φ hNφ
+  have hcard : Fintype.card (Multiplicative (φ.pointHom hNφ).ker) = finrankAlong F φ.ι := by
+    rw [← Nat.card_eq_fintype_card, Nat.card_congr (Multiplicative.toAdd : Multiplicative
+      (φ.pointHom hNφ).ker ≃ _),
+      natCard_ker]
+  have hfA : Module.finrank A V₀.FunctionField = finrankAlong F φ.ι := by
+    rw [hA, finrank_toSubfield_eq, ← finrankAlong_eq_finrank_fieldRange]
+  have hfB : Module.finrank B V₀.FunctionField = finrankAlong F φ.ι := by
+    rw [hB, FixedPoints.finrank_eq_card (Multiplicative (φ.pointHom hNφ).ker) V₀.FunctionField,
+      hcard]
+  have htower := Subfield.relfinrank_mul_finrank_top hAB
+  rw [hfA, hfB] at htower
+  have hpos := finrankAlong_pos φ
+  have hrel : Subfield.relfinrank A B = 1 :=
+    Nat.eq_of_mul_eq_mul_right hpos (htower.trans (one_mul _).symm)
+  exact le_antisymm hAB (Subfield.relfinrank_eq_one_iff.mp hrel)
+
+variable (ψ : IsogenyHomDatum V₀ V₂) (hNψ : NormFormulaAlong F ψ.ι ψ.hfin)
+variable (hker : ∀ P : V₀.Point, φ.pointHom hNφ P = 0 → ψ.pointHom hNψ P = 0)
+
+include hker in
+theorem psi_range_le : ψ.ι.range ≤ φ.ι.range := by
+  intro f hf
+  obtain ⟨g, rfl⟩ := (AlgHom.mem_range ψ.ι).mp hf
+  have hfix : ψ.ι g ∈ FixedPoints.subfield (Multiplicative (φ.pointHom hNφ).ker) V₀.FunctionField :=
+    by
+    rw [mem_fixedPoints_iff]
+    intro T hT
+    exact DFunLike.congr_fun (τ_comp_eq_of_ker ψ hNψ T (hker T hT)) g
+  rw [← fieldRange_eq_fixedPoints φ hNφ] at hfix
+  obtain ⟨g', hg'⟩ : ∃ g', φ.ι g' = ψ.ι g := by
+    simpa [AlgHom.fieldRange, IntermediateField.mem_toSubfield] using hfix
+  exact (AlgHom.mem_range φ.ι).mpr ⟨g', hg'⟩
+
+end Main
+
+end S13CIII
+
+open S13CIII in
+theorem solution
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    {V₀ V₁ V₂ : WeierstrassCurve.Affine F} [V₀.IsElliptic] [GenusOnePlaceGate V₀] [AbelTheorem V₀]
+    [V₁.IsElliptic] [GenusOnePlaceGate V₁] [AbelTheorem V₁] [V₂.IsElliptic] [GenusOnePlaceGate V₂]
+    [AbelTheorem V₂]
+    [GenusOnePlaceGate.IsCentred V₀]
+    (φ : IsogenyHomDatum V₀ V₁) (hNφ : NormFormulaAlong F φ.ι φ.hfin)
+    (ψ : IsogenyHomDatum V₀ V₂) (hNψ : NormFormulaAlong F ψ.ι ψ.hfin)
+    (hker : ∀ P : V₀.Point, φ.pointHom hNφ P = 0 → ψ.pointHom hNψ P = 0) :
+    ∃ (χ : IsogenyHomDatum V₁ V₂) (hNχ : NormFormulaAlong F χ.ι χ.hfin),
+      ∀ P : V₀.Point, χ.pointHom hNχ (φ.pointHom hNφ P) = ψ.pointHom hNψ P := by
+  obtain ⟨ξ, hξ⟩ := exists_factor_of_range_le φ.ι ψ.ι (psi_range_le φ hNφ ψ hNψ hker)
+  have hξfin : FiniteAlong F ξ := finiteAlong_factor φ.ι ξ (by rw [hξ]; exact ψ.hfin)
+  have hξint : ξ.toRingHom.IsIntegral := isIntegral_of_finiteAlong ξ hξfin
+  let χ : IsogenyHomDatum V₁ V₂ := ⟨ξ, hξint, hξfin⟩
+  have : HasPrincipalDivisors F V₁.FunctionField := hasPrincipalDivisors_functionField V₁
+  have hNχ : NormFormulaAlong F χ.ι χ.hfin := normFormulaAlong_of_finiteAlong ξ hξfin
+  refine ⟨χ, hNχ, fun P => ?_⟩
+  have hcomp : ∀ Q : V₀.Point, hmap ψ Q = hmap χ (hmap φ Q) := by
+    intro Q
+    have hint : (φ.ι.comp ξ).toRingHom.IsIntegral := RingHom.IsIntegral.trans _ _ hξint φ.hι
+    apply placeOfPoint_inj
+    rw [← hmap_seam ψ Q, restrictAlong_congr hξ.symm ψ.hι hint (placeOfPoint Q),
+      ← Place.restrictAlong_restrictAlong ξ φ.ι hξint φ.hι hint (placeOfPoint Q), hmap_seam φ Q]
+    exact hmap_seam χ (hmap φ Q)
+  rw [pointHom_eq_hmap_sub ψ hNψ P, pointHom_eq_hmap_sub φ hNφ P, map_sub,
+    pointHom_eq_hmap_sub χ hNχ, pointHom_eq_hmap_sub χ hNχ, hcomp P, hcomp 0]
+  abel
+
+end
+end S_OVERLONG_c76b33b5
+end P2MW
+export P2MW.S_OVERLONG_c76b33b5
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve AlgebraicCurve
+open WeierstrassCurve.Affine
+
+universe u
+theorem WeierstrassCurve.Affine.IsogenyHomDatum.exists_pointHom_comp_eq_of_ker_le_of_isCentred
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    {V₀ V₁ V₂ : WeierstrassCurve.Affine F} [V₀.IsElliptic] [GenusOnePlaceGate V₀] [AbelTheorem V₀]
+    [V₁.IsElliptic] [GenusOnePlaceGate V₁] [AbelTheorem V₁] [V₂.IsElliptic] [GenusOnePlaceGate V₂]
+    [AbelTheorem V₂]
+    [GenusOnePlaceGate.IsCentred V₀]
+    (φ : IsogenyHomDatum V₀ V₁) (hNφ : NormFormulaAlong F φ.ι φ.hfin)
+    (ψ : IsogenyHomDatum V₀ V₂) (hNψ : NormFormulaAlong F ψ.ι ψ.hfin)
+    (hker : ∀ P : V₀.Point, φ.pointHom hNφ P = 0 → ψ.pointHom hNψ P = 0) :
+    ∃ (χ : IsogenyHomDatum V₁ V₂) (hNχ : NormFormulaAlong F χ.ι χ.hfin),
+      ∀ P : V₀.Point, χ.pointHom hNχ (φ.pointHom hNφ P) = ψ.pointHom hNψ P :=
+  solution φ hNφ ψ hNψ hker
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyHomDatum_pointHom_apply_eq_sub.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyHomDatum_pointHom_apply_eq_sub.lean
new file mode 100644
index 0000000000..ce1665dba7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_IsogenyHomDatum_pointHom_apply_eq_sub.lean
@@ -0,0 +1,118 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.IsogenyHomDatum.pointHom_apply_eq_sub
+(556105d3-e357-5169-99d1-8c4e73af1d36) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission cc15f7dc-ed18-5c54-a0f5-558566a83239
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Point map of an isogeny datum: restriction minus value at O
+
+Theorem statement: `WeierstrassCurve.Affine.IsogenyHomDatum.pointHom_apply_eq_sub`
+(`556105d3-e357-5169-99d1-8c4e73af1d36`), by Claude, 2026-09-05.
+
+Proof: submission `cc15f7dc-ed18-5c54-a0f5-558566a83239`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field of characteristic zero and let $V_0, V_1$ be affine
+Weierstrass curves over $F$, both elliptic, both equipped with a `GenusOnePlaceGate` structure — an
+equivalence `pointEquivPlace` between the points of the curve and the places of its function field
+over $F$ (places being valuation subrings containing the image of $F$, proper, with principal ideal
+ring structure), together with the assertion that every such place has degree $1$ — and both
+satisfying `AbelTheorem`, i.e. a degree-zero divisor is principal exactly when its `divisorSum`
+vanishes. Let $\varphi$ be an `IsogenyHomDatum` from $V_0$ to $V_1$: an $F$-algebra map $\iota
+\colon F(V_1) \to F(V_0)$ which is integral and makes $F(V_0)$ a finite module over $F(V_1)$ along
+$\iota$. Let $hN$ witness the pushforward norm formula along $\iota$: for every nonzero $f \in
+F(V_0)$, every divisor $D$ on $F(V_0)$ with $D(w) = \operatorname{ord}_w(f)$ for all $w$, and every
+place $v$ of $F(V_1)$, the pushforward of $D$ at $v$ equals
+$\operatorname{ord}_v(\mathrm{N}_{F(V_1)}(f))$. Then for every point $P$ of $V_0$, the value at $P$
+of the additive map `φ.pointHom hN` equals the point of $V_1$ corresponding to the restriction along
+$\iota$ of the place of $P$, minus the point of $V_1$ corresponding to the restriction along $\iota$
+of the place of the origin $0$ of $V_0$.
+
+This is the rigidity statement that a map of points induced by a pushforward of divisors along a
+finite map of function fields differs from the set-theoretic place-restriction map by the constant
+translation by its value at the origin, in the classical form 'a morphism of elliptic curves is an
+isogeny followed by a translation'. It is used in deducing the existence of a factorisation of one
+point homomorphism through another when kernels are contained in one another.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_IsogenyHomDatum_pointHom_apply_eq_sub.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_IsogenyHomDatum_pointHom_apply_eq_sub
+
+noncomputable section
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+universe u
+
+theorem solution
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    {V₀ V₁ : WeierstrassCurve.Affine F} [V₀.IsElliptic] [GenusOnePlaceGate V₀] [AbelTheorem V₀]
+    [V₁.IsElliptic] [GenusOnePlaceGate V₁] [AbelTheorem V₁]
+    (φ : IsogenyHomDatum V₀ V₁) (hN : NormFormulaAlong F φ.ι φ.hfin) (P : V₀.Point) :
+    φ.pointHom hN P
+      = (pointEquivPlace (W := V₁)).symm ((placeOfPoint P).restrictAlong φ.ι φ.hι)
+        - (pointEquivPlace (W := V₁)).symm ((placeOfPoint (0 : V₀.Point)).restrictAlong φ.ι φ.hι) :=
+          by
+  set Q : V₁.Point := (pointEquivPlace (W := V₁)).symm ((placeOfPoint P).restrictAlong φ.ι φ.hι)
+    with hQ
+  set Q₀ : V₁.Point :=
+    (pointEquivPlace (W := V₁)).symm ((placeOfPoint (0 : V₀.Point)).restrictAlong φ.ι φ.hι) with hQ₀
+  have hP : (placeOfPoint P).restrictAlong φ.ι φ.hι = placeOfPoint Q :=
+    ((pointEquivPlace (W := V₁)).apply_symm_apply _).symm
+  have h0 : (placeOfPoint (0 : V₀.Point)).restrictAlong φ.ι φ.hι = placeOfPoint Q₀ :=
+    ((pointEquivPlace (W := V₁)).apply_symm_apply _).symm
+  have hdiv : (Pic0.pushforwardAlongDegZero φ.ι φ.hι (pointDivisor P) :
+      AlgebraicCurve.Divisor F V₁.FunctionField)
+        = Finsupp.single (placeOfPoint Q) 1 - Finsupp.single (placeOfPoint Q₀) 1 := by
+    rw [Pic0.coe_pushforwardAlongDegZero, coe_pointDivisor, map_sub,
+      pushforwardAlong_single_eq φ.ι φ.hι, pushforwardAlong_single_eq φ.ι φ.hι, hP, h0]
+  rw [IsogenyHomDatum.pointHom_apply, pointClass, Pic0.pushforwardAlongHom_mk,
+    genusOnePic0Equiv_apply, pic0ToPoint_mk, hdiv, map_sub, divisorSum_single_placeOfPoint,
+    divisorSum_single_placeOfPoint, one_smul, one_smul]
+
+end
+end S_WeierstrassCurve_Affine_IsogenyHomDatum_pointHom_apply_eq_sub
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_IsogenyHomDatum_pointHom_apply_eq_sub (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+universe u
+theorem WeierstrassCurve.Affine.IsogenyHomDatum.pointHom_apply_eq_sub
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    {V₀ V₁ : WeierstrassCurve.Affine F} [V₀.IsElliptic] [GenusOnePlaceGate V₀] [AbelTheorem V₀]
+    [V₁.IsElliptic] [GenusOnePlaceGate V₁] [AbelTheorem V₁]
+    (φ : IsogenyHomDatum V₀ V₁) (hN : NormFormulaAlong F φ.ι φ.hfin) (P : V₀.Point) :
+    φ.pointHom hN P
+      = (pointEquivPlace (W := V₁)).symm ((placeOfPoint P).restrictAlong φ.ι φ.hι)
+        - (pointEquivPlace (W := V₁)).symm ((placeOfPoint (0 : V₀.Point)).restrictAlong φ.ι φ.hι) :=
+  solution φ hN P
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_card_ker_eq_max_natDegree.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_card_ker_eq_max_natDegree.lean
new file mode 100644
index 0000000000..8d2f38b236
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_card_ker_eq_max_natDegree.lean
@@ -0,0 +1,358 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.Point.card_ker_eq_max_natDegree
+(cbe3a241-7687-58cc-a578-d49e3342986f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 477ca999-2def-5f36-a3a9-6ac857380199
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.Algebra.Polynomial.Derivative
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+import Mathlib.Algebra.Polynomial.FieldDivision
+import Mathlib.Algebra.Polynomial.Roots
+import Mathlib.Algebra.Polynomial.Splits
+import Mathlib.SetTheory.Cardinal.Finite
+import Mathlib.Tactic.LinearCombination
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Kernel size equals degree of a separable abscissa map
+
+Theorem statement: `WeierstrassCurve.Affine.Point.card_ker_eq_max_natDegree`
+(`cbe3a241-7687-58cc-a578-d49e3342986f`), by Claude, 2026-09-05.
+
+Proof: submission `477ca999-2def-5f36-a3a9-6ac857380199`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $k$ be an algebraically closed field with decidable equality, and let $W$ be a Weierstrass curve
+over $k$ which is elliptic (invertible discriminant). Let $\psi$ be an additive endomorphism of the
+group $W(k)$ of points of the associated affine curve, let $B$ be a finite set of such points, and
+let $g, h \in k[X]$ be coprime polynomials whose Wronskian $g'h - gh'$ is nonzero. Assume two
+compatibility conditions relating $\psi$ to the rational function $g/h$ outside $B$: first, for
+every affine point $P = (x,y)$ of $W$ (given with a proof that $(x,y)$ is a nonsingular point of the
+affine equation) with $P \notin B$ and $h(x) \neq 0$, one has $\psi(P) \neq O$; second, for every
+such $P \notin B$ and every affine point $(x',y')$ of $W$, if $\psi(P) = (x',y')$ then $x' \, h(x) =
+g(x)$. The conclusion is that the kernel of $\psi$, as a subgroup of $W(k)$, has cardinality exactly
+$\max(\deg g, \deg h)$, where $\mathrm{Nat.card}$ is used, so the assertion includes the finiteness
+of the kernel (the degrees being natural-number degrees).
+
+This is the fibre-counting step in Manin's elementary treatment of the Hasse bound: a separable
+endomorphism whose effect on abscissae is given by a coprime pair $(g,h)$ with nonvanishing
+Wronskian has kernel of size equal to the degree $\max(\deg g, \deg h)$ of that rational map, the
+finite set $B$ absorbing the points where the explicit addition formulas degenerate. It is used to
+compute the kernel size of $[m] - \pi$ for the Frobenius endomorphism $\pi$ over a finite field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_Point_card_ker_eq_max_natDegree.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_Point_card_ker_eq_max_natDegree
+
+open Polynomial WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+namespace M4cP4T3C
+
+def fiberEquivKer {A A' : Type*} [AddCommGroup A] [AddCommGroup A'] (f : A →+ A') {y : A'}
+    {x₀ : A} (hx₀ : f x₀ = y) : {x : A // f x = y} ≃ f.ker where
+  toFun P := ⟨P.1 - x₀, show f (P.1 - x₀) = 0 by rw [map_sub, P.2, hx₀, sub_self]⟩
+  invFun z := ⟨z.1 + x₀, by
+    have hz : f z.1 = 0 := z.2
+    rw [map_add, hz, hx₀, zero_add]⟩
+  left_inv P := Subtype.ext (show (P : A) - x₀ + x₀ = (P : A) by abel)
+  right_inv z := Subtype.ext (show (z : A) + x₀ - x₀ = (z : A) by abel)
+
+section Curve
+
+variable {k : Type*} [Field k] {W : WeierstrassCurve k}
+
+def xc : W.toAffine.Point → k
+  | .zero => 0
+  | .some x _ _ => x
+
+@[scoped simp] lemma xc_some {x y : k} (h : W.toAffine.Nonsingular x y) :
+    xc (Point.some x y h) = x :=
+  rfl
+
+lemma eval_Ψ₂Sq (x : k) :
+    W.Ψ₂Sq.eval x = 4 * x ^ 3 + W.b₂ * x ^ 2 + 2 * W.b₄ * x + W.b₆ := by
+  simp [Ψ₂Sq]
+
+lemma sq_sub_negY_eq_eval_Ψ₂Sq {x y : k} (h : W.toAffine.Equation x y) :
+    (y - W.toAffine.negY x y) ^ 2 = W.Ψ₂Sq.eval x := by
+  rw [equation_iff] at h
+  rw [eval_Ψ₂Sq, negY, b₂, b₄, b₆]
+  linear_combination 4 * h
+
+lemma Ψ₂Sq_ne_zero [W.IsElliptic] : W.Ψ₂Sq ≠ 0 := by
+  intro h0
+  have h3 : (4 : k) = 0 := by rw [← W.coeff_Ψ₂Sq, h0, coeff_zero]
+  have h2 : W.b₂ = 0 := by
+    have h := congrArg (fun p : k[X] => p.coeff 2) h0
+    simpa [Ψ₂Sq, coeff_X, coeff_C, coeff_X_pow] using h
+  have h0' : W.b₆ = 0 := by
+    have h := congrArg (fun p : k[X] => p.coeff 0) h0
+    simpa [Ψ₂Sq, coeff_X, coeff_C, coeff_X_pow] using h
+  apply W.isUnit_Δ.ne_zero
+  rw [Δ, h2, h0']
+  linear_combination (-2 * W.b₄ ^ 3) * h3
+
+lemma exists_equation [IsAlgClosed k] (x : k) : ∃ y : k, W.toAffine.Equation x y := by
+  obtain ⟨y, hy⟩ := IsAlgClosed.exists_root
+    (C 1 * X ^ 2 + C (W.a₁ * x + W.a₃) * X +
+      C (-(x ^ 3 + W.a₂ * x ^ 2 + W.a₄ * x + W.a₆)))
+    (natDegree_pos_iff_degree_pos.mp (by rw [natDegree_quadratic one_ne_zero]; norm_num)).ne'
+  refine ⟨y, (W.toAffine.equation_iff x y).mpr ?_⟩
+  simp only [IsRoot, eval_add, eval_mul, eval_pow, eval_C, eval_X, one_mul] at hy
+  linear_combination hy
+
+end Curve
+
+theorem card_ker_eq_max_natDegree {k : Type*} [Field k] [DecidableEq k] [IsAlgClosed k]
+    (W : WeierstrassCurve k) [W.IsElliptic] (ψ : W.toAffine.Point →+ W.toAffine.Point)
+    {B : Set W.toAffine.Point} (hB : B.Finite) {g h : Polynomial k} (hgh : IsCoprime g h)
+    (hsep : Polynomial.derivative g * h - g * Polynomial.derivative h ≠ 0)
+    (hker : ∀ {x y : k} (hP : W.toAffine.Nonsingular x y),
+      Point.some x y hP ∉ B → h.eval x ≠ 0 → ψ (Point.some x y hP) ≠ 0)
+    (hx : ∀ {x y : k} (hP : W.toAffine.Nonsingular x y) {x' y' : k}
+      (hP' : W.toAffine.Nonsingular x' y'),
+      Point.some x y hP ∉ B → ψ (Point.some x y hP) = Point.some x' y' hP' →
+        x' * h.eval x = g.eval x) :
+    Nat.card ψ.ker = max g.natDegree h.natDegree := by
+  have hΨ₂ : W.Ψ₂Sq ≠ 0 := Ψ₂Sq_ne_zero
+  have hx' : ∀ {x y : k} (hP : W.toAffine.Nonsingular x y), Point.some x y hP ∉ B →
+      ψ (Point.some x y hP) ≠ 0 → xc (ψ (Point.some x y hP)) * h.eval x = g.eval x := by
+    intro x y hP hPB hne
+    rcases hq : ψ (Point.some x y hP) with _ | ⟨x', y', hP'⟩
+    · exact absurd hq hne
+    · rw [xc_some]
+      exact hx hP hP' hPB hq
+  set d : ℕ := max g.natDegree h.natDegree with hd
+  have hh : h ≠ 0 := fun h0 => hsep (by rw [h0, derivative_zero, mul_zero, mul_zero, sub_zero])
+  have hd1 : 1 ≤ d := by
+    by_contra hlt
+    have h1 := le_max_left g.natDegree h.natDegree
+    have h2 := le_max_right g.natDegree h.natDegree
+    have hg0 : g.natDegree = 0 := by omega
+    have hh0 : h.natDegree = 0 := by omega
+    apply hsep
+    rw [Polynomial.eq_C_of_natDegree_eq_zero hg0, Polynomial.eq_C_of_natDegree_eq_zero hh0,
+      derivative_C, derivative_C, zero_mul, mul_zero, sub_zero]
+  have hnocommon : ∀ t : k, g.eval t = 0 → h.eval t = 0 → False := by
+    intro t hg0 hh0
+    obtain ⟨u, v, huv⟩ := hgh
+    have h1 := congrArg (Polynomial.eval t) huv
+    simp only [eval_add, eval_mul, eval_one, hg0, hh0, mul_zero, add_zero] at h1
+    exact zero_ne_one h1
+  have hdeg_of_coeff : ∀ a : k, g.coeff d - a * h.coeff d ≠ 0 → (g - C a * h).natDegree = d := by
+    intro a hca
+    refine le_antisymm ((natDegree_sub_le _ _).trans ?_) (le_natDegree_of_ne_zero ?_)
+    · exact (max_le_max le_rfl (natDegree_C_mul_le a h)).trans (le_of_eq hd.symm)
+    · rwa [coeff_sub, coeff_C_mul]
+  have hnotboth : ¬ (g.coeff d = 0 ∧ h.coeff d = 0) := by
+    rintro ⟨hgc, hhc⟩
+    by_cases hcase : g.natDegree ≤ h.natDegree
+    · have hdh : d = h.natDegree := by rw [hd]; exact max_eq_right hcase
+      have hcoe : h.coeff d = h.leadingCoeff := by rw [hdh, coeff_natDegree]
+      exact (Polynomial.leadingCoeff_ne_zero.mpr hh) (hcoe ▸ hhc)
+    · have hle : h.natDegree ≤ g.natDegree := by omega
+      have hdg : d = g.natDegree := by rw [hd]; exact max_eq_left hle
+      have hg0 : g ≠ 0 := by
+        intro h0
+        rw [h0, natDegree_zero] at hcase
+        omega
+      have hcoe : g.coeff d = g.leadingCoeff := by rw [hdg, coeff_natDegree]
+      exact (Polynomial.leadingCoeff_ne_zero.mpr hg0) (hcoe ▸ hgc)
+  have hbadfin : ((({g.coeff d / h.coeff d} : Set k) ∪
+      ↑(((derivative g * h - g * derivative h).roots.toFinset).image
+        fun t => g.eval t / h.eval t) ∪ ↑(W.Ψ₂Sq.roots.toFinset)) ∪
+      ((fun P : W.toAffine.Point => xc (ψ P)) '' B) ∪
+      ((fun P : W.toAffine.Point => g.eval (xc P) / h.eval (xc P)) '' B)).Finite := by
+    refine Set.Finite.union (Set.Finite.union ?_ (hB.image _)) (hB.image _)
+    exact ((Set.finite_singleton _).union (Finset.finite_toSet _)).union (Finset.finite_toSet _)
+  obtain ⟨a, ha⟩ := hbadfin.infinite_compl.nonempty
+  simp only [Set.mem_compl_iff, Set.mem_union, not_or] at ha
+  obtain ⟨⟨⟨⟨ha₁, ha₂⟩, ha₃⟩, ha₄⟩, ha₅⟩ := ha
+  have hcoeffa : g.coeff d - a * h.coeff d ≠ 0 := by
+    intro hca
+    rcases eq_or_ne (h.coeff d) 0 with hcd | hcd
+    · exact hnotboth ⟨by rwa [hcd, mul_zero, sub_zero] at hca, hcd⟩
+    · exact ha₁ (Set.mem_singleton_iff.mpr ((eq_div_iff hcd).mpr (sub_eq_zero.mp hca).symm))
+  have hadeg : (g - C a * h).natDegree = d := hdeg_of_coeff a hcoeffa
+  have hpane : g - C a * h ≠ 0 := fun h0 => by rw [h0, natDegree_zero] at hadeg; omega
+  have hanodup : (g - C a * h).roots.Nodup := by
+    rw [Multiset.nodup_iff_count_le_one]
+    intro t
+    rw [count_roots]
+    by_contra hlt
+    have hlt' : 1 < (g - C a * h).rootMultiplicity t := by omega
+    obtain ⟨ht, htd⟩ := (one_lt_rootMultiplicity_iff_isRoot hpane).mp hlt'
+    rw [IsRoot, eval_sub, eval_mul, eval_C, sub_eq_zero] at ht
+    rw [derivative_sub, derivative_C_mul, IsRoot, eval_sub, eval_mul, eval_C, sub_eq_zero] at htd
+    have hht : h.eval t ≠ 0 := fun hh0 => hnocommon t (by rw [ht, hh0, mul_zero]) hh0
+    have hWr : t ∈ (derivative g * h - g * derivative h).roots.toFinset := by
+      refine Multiset.mem_toFinset.mpr ((mem_roots hsep).mpr ?_)
+      rw [IsRoot, eval_sub, eval_mul, eval_mul, ht, htd]
+      ring
+    exact ha₂ (Finset.mem_coe.mpr (Finset.mem_image.mpr
+      ⟨t, hWr, (div_eq_iff hht).mpr ht⟩))
+  have hΨ₂a : W.Ψ₂Sq.eval a ≠ 0 := fun h0 =>
+    ha₃ (Finset.mem_coe.mpr (Multiset.mem_toFinset.mpr ((mem_roots hΨ₂).mpr h0)))
+  have hB_image : ∀ P ∈ B, xc (ψ P) ≠ a := fun P hP hPa => ha₄ ⟨P, hP, hPa⟩
+  have hB_xmap : ∀ P ∈ B, g.eval (xc P) / h.eval (xc P) ≠ a := fun P hP hPa =>
+    ha₅ ⟨P, hP, hPa⟩
+  have htf : (g - C a * h).roots.toFinset.card = d := by
+    rw [Multiset.toFinset_card_of_nodup hanodup,
+      splits_iff_card_roots.mp (IsAlgClosed.splits (g - C a * h)), hadeg]
+  obtain ⟨b, hb⟩ := exists_equation (W := W) a
+  have hbns : W.toAffine.Nonsingular a b := (equation_iff_nonsingular (W := W)).mp hb
+  have hbne : b ≠ W.toAffine.negY a b := fun hbeq => hΨ₂a (by
+    rw [← sq_sub_negY_eq_eval_Ψ₂Sq (W := W) hb, ← hbeq, sub_self, zero_pow two_ne_zero])
+  set Q₀ : W.toAffine.Point := Point.some a b hbns with hQ₀
+  have hQ₀ne : Q₀ ≠ 0 := Point.some_ne_zero hbns
+  have hQ₀neg : Q₀ ≠ -Q₀ := by
+    rw [hQ₀, Point.neg_some, ne_eq, Point.some.injEq, not_and]
+    exact fun _ => hbne
+  have hdichot : ∀ T : W.toAffine.Point, T ≠ 0 → xc T = a → T = Q₀ ∨ T = -Q₀ := by
+    rintro (_ | ⟨xT, yT, hT⟩) hT0 hxT
+    · exact absurd rfl hT0
+    · rw [xc_some] at hxT
+      subst hxT
+      rcases Y_eq_of_X_eq hT.left hb rfl with hy | hy
+      · left; rw [hQ₀, Point.some.injEq]; exact ⟨rfl, hy⟩
+      · right; rw [hQ₀, Point.neg_some, Point.some.injEq]; exact ⟨rfl, hy⟩
+  have hnotB : ∀ P : W.toAffine.Point, ψ P = Q₀ → P ∉ B := by
+    intro P hPQ hPB
+    refine hB_image P hPB ?_
+    rw [hPQ, hQ₀, xc_some]
+  have hmem : ∀ P : W.toAffine.Point, ψ P = Q₀ → (g - C a * h).eval (xc P) = 0 := by
+    intro P hPQ
+    have hP0 : P ≠ 0 := fun h0 => hQ₀ne (by rw [← hPQ, h0, _root_.map_zero])
+    have hPB : P ∉ B := hnotB P hPQ
+    rcases P with _ | ⟨xP, yP, hP⟩
+    · exact absurd rfl hP0
+    · have hψne : ψ (Point.some xP yP hP) ≠ 0 := by rw [hPQ]; exact hQ₀ne
+      have hxeq := hx' hP hPB hψne
+      have hxa : xc (ψ (Point.some xP yP hP)) = a := by
+        rw [hPQ, hQ₀, xc_some]
+      rw [xc_some, eval_sub, eval_mul, eval_C, ← hxa, hxeq, sub_self]
+  have hbij : Function.Bijective (fun P : {P : W.toAffine.Point // ψ P = Q₀} =>
+      (⟨xc P.1, hmem P.1 P.2⟩ : {x : k // (g - C a * h).eval x = 0})) := by
+    constructor
+    · rintro ⟨P₁, hP₁⟩ ⟨P₂, hP₂⟩ h12
+      simp only [Subtype.mk.injEq] at h12
+      have hP₁0 : P₁ ≠ 0 := fun h0 => hQ₀ne (by rw [← hP₁, h0, _root_.map_zero])
+      have hP₂0 : P₂ ≠ 0 := fun h0 => hQ₀ne (by rw [← hP₂, h0, _root_.map_zero])
+      rcases P₁ with _ | ⟨x₁, y₁, h₁⟩
+      · exact absurd rfl hP₁0
+      rcases P₂ with _ | ⟨x₂, y₂, h₂⟩
+      · exact absurd rfl hP₂0
+      rw [xc_some, xc_some] at h12
+      subst h12
+      rcases Y_eq_of_X_eq h₂.left h₁.left rfl with hy | hy
+      · refine Subtype.ext ?_
+        rw [Point.some.injEq]
+        exact ⟨rfl, hy.symm⟩
+      · exfalso
+        have h21 : (Point.some x₁ y₂ h₂ : W.toAffine.Point) = -(Point.some x₁ y₁ h₁) := by
+          rw [Point.neg_some, Point.some.injEq]
+          exact ⟨rfl, hy⟩
+        apply hQ₀neg
+        calc Q₀ = ψ (Point.some x₁ y₂ h₂) := hP₂.symm
+          _ = ψ (-(Point.some x₁ y₁ h₁)) := by rw [h21]
+          _ = -ψ (Point.some x₁ y₁ h₁) := _root_.map_neg ψ _
+          _ = -Q₀ := by rw [hP₁]
+    · rintro ⟨x₀, hx₀⟩
+      have hgx₀ : g.eval x₀ = a * h.eval x₀ := by
+        have h1 := hx₀
+        rw [eval_sub, eval_mul, eval_C, sub_eq_zero] at h1
+        exact h1
+      have hhx₀ : h.eval x₀ ≠ 0 := fun hh0 => hnocommon x₀ (by rw [hgx₀, hh0, mul_zero]) hh0
+      obtain ⟨y₀, hy₀⟩ := exists_equation (W := W) x₀
+      have hns₀ : W.toAffine.Nonsingular x₀ y₀ := (equation_iff_nonsingular (W := W)).mp hy₀
+      have hKB : (Point.some x₀ y₀ hns₀ : W.toAffine.Point) ∉ B := by
+        intro hKmem
+        refine hB_xmap _ hKmem ?_
+        rw [xc_some]
+        exact (div_eq_iff hhx₀).mpr hgx₀
+      have hψ₀ : ψ (Point.some x₀ y₀ hns₀) ≠ 0 := hker hns₀ hKB hhx₀
+      have hxeq₀ := hx' hns₀ hKB hψ₀
+      have hxa₀ : xc (ψ (Point.some x₀ y₀ hns₀)) = a :=
+        mul_right_cancel₀ hhx₀ (by rw [hxeq₀, hgx₀])
+      rcases hdichot _ hψ₀ hxa₀ with hQ | hQ
+      · exact ⟨⟨_, hQ⟩, Subtype.ext (xc_some hns₀)⟩
+      · refine ⟨⟨-(Point.some x₀ y₀ hns₀), ?_⟩, ?_⟩
+        · rw [_root_.map_neg, hQ, neg_neg]
+        · refine Subtype.ext ?_
+          change xc (-(Point.some x₀ y₀ hns₀)) = x₀
+          rw [Point.neg_some, xc_some]
+  have hroot_ex : ∃ x : k, (g - C a * h).eval x = 0 := by
+    have hpos : 0 < (g - C a * h).roots.toFinset.card := by rw [htf]; omega
+    obtain ⟨x₀, hx₀⟩ := Finset.card_pos.mp hpos
+    exact ⟨x₀, by rw [← IsRoot, ← mem_roots hpane, ← Multiset.mem_toFinset]; exact hx₀⟩
+  obtain ⟨x₀, hx₀⟩ := hroot_ex
+  obtain ⟨P₀, -⟩ := hbij.2 ⟨x₀, hx₀⟩
+  calc Nat.card ψ.ker
+      = Nat.card {P : W.toAffine.Point // ψ P = Q₀} :=
+        (Nat.card_congr (fiberEquivKer ψ P₀.2)).symm
+    _ = Nat.card {x : k // (g - C a * h).eval x = 0} := Nat.card_eq_of_bijective _ hbij
+    _ = Nat.card ((g - C a * h).roots.toFinset : Finset k) :=
+        Nat.card_congr ((Equiv.refl k).subtypeEquiv fun x => by
+          rw [Multiset.mem_toFinset, mem_roots hpane, IsRoot]
+          exact Iff.rfl)
+    _ = ((g - C a * h).roots.toFinset).card := Nat.card_eq_finsetCard _
+    _ = d := htf
+
+end M4cP4T3C
+
+theorem solution {k : Type*} [Field k] [DecidableEq k] [IsAlgClosed k] (W : WeierstrassCurve k)
+    [W.IsElliptic] (ψ : W.toAffine.Point →+ W.toAffine.Point) {B : Set W.toAffine.Point}
+    (hB : B.Finite) {g h : Polynomial k} (hgh : IsCoprime g h)
+    (hsep : Polynomial.derivative g * h - g * Polynomial.derivative h ≠ 0)
+    (hker : ∀ {x y : k} (hP : W.toAffine.Nonsingular x y),
+      Point.some x y hP ∉ B → h.eval x ≠ 0 → ψ (Point.some x y hP) ≠ 0)
+    (hx : ∀ {x y : k} (hP : W.toAffine.Nonsingular x y) {x' y' : k}
+      (hP' : W.toAffine.Nonsingular x' y'),
+      Point.some x y hP ∉ B → ψ (Point.some x y hP) = Point.some x' y' hP' →
+        x' * h.eval x = g.eval x) :
+    Nat.card ψ.ker = max g.natDegree h.natDegree :=
+  M4cP4T3C.card_ker_eq_max_natDegree W ψ hB hgh hsep hker hx
+
+end S_WeierstrassCurve_Affine_Point_card_ker_eq_max_natDegree
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_Point_card_ker_eq_max_natDegree (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+theorem WeierstrassCurve.Affine.Point.card_ker_eq_max_natDegree {k : Type*} [Field k] [DecidableEq
+  k] [IsAlgClosed k] (W : WeierstrassCurve k) [W.IsElliptic] (ψ : W.toAffine.Point →+
+  W.toAffine.Point) {B : Set W.toAffine.Point} (hB : B.Finite) {g h : Polynomial k} (hgh : IsCoprime
+  g h) (hsep : Polynomial.derivative g * h - g * Polynomial.derivative h ≠ 0) (hker : ∀ {x y : k}
+  (hP : W.toAffine.Nonsingular x y), Point.some x y hP ∉ B → h.eval x ≠ 0 → ψ (Point.some x y hP) ≠
+  0) (hx : ∀ {x y : k} (hP : W.toAffine.Nonsingular x y) {x' y' : k} (hP' : W.toAffine.Nonsingular
+  x' y'), Point.some x y hP ∉ B → ψ (Point.some x y hP) = Point.some x' y' hP' → x' * h.eval x =
+  g.eval x) :
+    Nat.card ψ.ker = max g.natDegree h.natDegree :=
+  solution W ψ hB hgh hsep hker hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_exists_zsmul_eq_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_exists_zsmul_eq_of_isAlgClosed.lean
new file mode 100644
index 0000000000..6adb6cbd54
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_exists_zsmul_eq_of_isAlgClosed.lean
@@ -0,0 +1,439 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.Point.exists_zsmul_eq_of_isAlgClosed
+(1d8c7b68-f0ad-51eb-9206-a061eb7dd198) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7ca68070-cc9d-5e89-8eef-ee3e87bfa9b9
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+
+import Mathlib.NumberTheory.EllipticDivisibilitySequence
+import Mathlib.Algebra.Ring.NegOnePow
+import Mathlib.Data.Fin.VecNotation
+import Mathlib.Data.Fin.Tuple.Sort
+import Mathlib.Algebra.GroupWithZero.NonZeroDivisors
+import Mathlib.Algebra.MvPolynomial.CommRing
+import Mathlib.Algebra.MvPolynomial.Basic
+import Mathlib.Tactic.LinearCombination
+import Mathlib.Tactic.Ring
+import Mathlib.Tactic.Abel
+import Mathlib.Tactic.IntervalCases
+import Mathlib.Tactic.FieldSimp
+import Mathlib.GroupTheory.Perm.Basic
+import Mathlib.GroupTheory.Perm.Sign
+import Mathlib.GroupTheory.Perm.Cycle.Type
+import Mathlib.Algebra.Polynomial.Bivariate
+import Mathlib.AlgebraicGeometry.EllipticCurve.Jacobian.Point
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+import Mathlib.FieldTheory.Separable
+import Mathlib.Data.Nat.Factorization.Induction
+import Mathlib.Logic.Embedding.Set
+import Mathlib.SetTheory.Cardinal.Finite
+import Mathlib.Data.Set.Card
+import Mathlib.Algebra.Module.Torsion.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_EDSEngine
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Divisibility of E(K) for K algebraically closed
+
+Theorem statement: `WeierstrassCurve.Affine.Point.exists_zsmul_eq_of_isAlgClosed`
+(`1d8c7b68-f0ad-51eb-9206-a061eb7dd198`), by Claude, 2026-09-05.
+
+Proof: submission `7ca68070-cc9d-5e89-8eef-ee3e87bfa9b9`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field, $E$ a Weierstrass curve over $K$ which is elliptic (i.e.
+carries the `IsElliptic` property: invertible discriminant), and let $n$ be a nonzero integer. Then
+for every point $P$ of the group $E(K)$ of $K$-points of the associated affine Weierstrass curve —
+that is, the affine points satisfying the Weierstrass equation together with the point at infinity,
+with the usual chord-and-tangent group law — there exists a point $Q$ of $E(K)$ with $n \cdot Q =
+P$, the scalar action being the integer scalar multiplication of the additive group $E(K)$.
+Equivalently, $E(K)$ is a divisible abelian group: multiplication by any nonzero integer is
+surjective on the $K$-points of an elliptic curve over an algebraically closed field. No assumption
+is made on the characteristic of $K$, and in particular $n$ is allowed to be divisible by it.
+
+This is the classical statement that multiplication by $n \neq 0$ is surjective on the points of an
+elliptic curve over an algebraically closed field, the map $[n]$ being a non-constant, hence
+surjective, morphism of curves. It is used in the treatment of endomorphisms and isogenies of
+elliptic curves, for instance in the construction of dual isogeny data and in the analysis of the
+rank of endomorphism rings.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_Point_exists_zsmul_eq_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_Point_exists_zsmul_eq_of_isAlgClosed
+
+section PortGenNetIdentities
+
+namespace Deep
+namespace Gen
+
+open WeierstrassCurve Polynomial
+
+variable {F K : Type*} [Field F] [Field K] [Algebra F K]
+variable (W : WeierstrassCurve F)
+
+theorem ΨSq_eval_eq_zero_of_preΨ {m : ℕ} {x₀ : K}
+    (h : ((W.baseChange K).preΨ (m : ℤ)).eval x₀ = 0) :
+    ((W.baseChange K).ΨSq m).eval x₀ = 0 := by
+  rw [preΨ_ofNat] at h
+  rw [ΨSq_ofNat, eval_mul, eval_pow, h, zero_pow two_ne_zero, zero_mul]
+
+variable [IsAlgClosed K]
+
+theorem isCoprime_ΨSq_succ [W.IsElliptic] (n : ℕ) :
+    IsCoprime ((W.baseChange K).ΨSq n) ((W.baseChange K).ΨSq (n + 1)) := by
+  classical
+  rw [Polynomial.isCoprime_iff_aeval_ne_zero_of_isAlgClosed (k := K) (K := K)]
+  intro x₀
+  by_contra hcon
+  push Not at hcon
+  obtain ⟨hn0, hn1⟩ := hcon
+  rw [coe_aeval_eq_eval] at hn0 hn1
+  obtain ⟨y₀, hy₀⟩ := IsAlgClosed.exists_root
+    (C (1 : K) * X ^ 2 + C ((W.baseChange K).a₁ * x₀ + (W.baseChange K).a₃) * X +
+      C (-(x₀ ^ 3 + (W.baseChange K).a₂ * x₀ ^ 2 + (W.baseChange K).a₄ * x₀ +
+        (W.baseChange K).a₆)))
+    (by rw [Polynomial.degree_quadratic one_ne_zero]; decide)
+  have heq : (W.baseChange K).toAffine.Equation x₀ y₀ := by
+    rw [Affine.equation_iff]
+    simp only [IsRoot.def, eval_add, eval_mul, eval_pow, eval_C, eval_X] at hy₀
+    linear_combination hy₀
+  have hns : (W.baseChange K).toAffine.Nonsingular x₀ y₀ :=
+    (Affine.equation_iff_nonsingular).mp heq
+  have hψ0 : ((W.baseChange K).ψ (n : ℤ)).evalEval x₀ y₀ = 0 := by
+    have h2 := evalEval_ψ_sq (W.baseChange K) heq (n : ℤ)
+    rw [hn0] at h2
+    exact (pow_eq_zero_iff two_ne_zero).mp h2
+  have hψ1 : ((W.baseChange K).ψ ((n : ℤ) + 1)).evalEval x₀ y₀ = 0 := by
+    have h2 := evalEval_ψ_sq (W.baseChange K) heq ((n : ℤ) + 1)
+    rw [hn1] at h2
+    exact (pow_eq_zero_iff two_ne_zero).mp h2
+  have h0 : (n : ℤ) • (Affine.Point.some x₀ y₀ hns) = 0 :=
+    (smul_eq_zero_iff_evalEval_ψ (W.baseChange K) hns (n : ℤ)).mpr hψ0
+  have h1 : ((n : ℤ) + 1) • (Affine.Point.some x₀ y₀ hns) = 0 :=
+    (smul_eq_zero_iff_evalEval_ψ (W.baseChange K) hns ((n : ℤ) + 1)).mpr hψ1
+  have hP : (Affine.Point.some x₀ y₀ hns : (W.baseChange K).toAffine.Point) = 0 := by
+    have hsub := sub_smul ((n : ℤ) + 1) (n : ℤ) (Affine.Point.some x₀ y₀ hns)
+    rw [h1, h0, sub_zero, add_sub_cancel_left, one_smul] at hsub
+    exact hsub
+  exact Affine.Point.some_ne_zero hns hP
+
+end Deep.Gen
+
+end PortGenNetIdentities
+
+section PortGenInduction
+
+namespace Deep
+namespace Gen
+
+open WeierstrassCurve WeierstrassCurve.Affine Polynomial
+
+open scoped WeierstrassCurve.Affine
+
+variable {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K]
+variable (W : WeierstrassCurve F)
+
+theorem smul_formula_or_zero [W.IsElliptic] {n : ℕ} (_hn : 0 < n) {x₀ y₀ : K}
+    (h : (W.baseChange K).toAffine.Nonsingular x₀ y₀) :
+    (((W.baseChange K).ΨSq n).eval x₀ ≠ 0 →
+      ∃ (x' y' : K) (h' : (W.baseChange K).toAffine.Nonsingular x' y'),
+        n • (Point.some x₀ y₀ h : W.toAffine⟮K⟯) = Point.some x' y' h' ∧
+          x' * ((W.baseChange K).ΨSq n).eval x₀ = ((W.baseChange K).Φ n).eval x₀) ∧
+    (((W.baseChange K).ΨSq n).eval x₀ = 0 →
+      n • (Point.some x₀ y₀ h : W.toAffine⟮K⟯) = 0) := by
+  have heq : (W.baseChange K).toAffine.Equation x₀ y₀ := h.left
+  have hψsq := (W.baseChange K).evalEval_ψ_sq heq (n : ℤ)
+  constructor
+  · intro hΨ
+    have hψ : ((W.baseChange K).ψ (n : ℤ)).evalEval x₀ y₀ ≠ 0 := by
+      intro h0
+      exact hΨ (by rw [← hψsq, h0]; exact zero_pow two_ne_zero)
+    have key := zsmul_eq_smulEval (W.baseChange K) h (n : ℤ)
+    have hVz : smulEval (W.baseChange K) x₀ y₀ (n : ℤ) 2 ≠ 0 := hψ
+    have hV := key ▸ ((n : ℤ) • Jacobian.Point.fromAffine (Point.some x₀ y₀ h)).nonsingular
+    have hQeq : ((n : ℤ) • Jacobian.Point.fromAffine (Point.some x₀ y₀ h)) =
+        Jacobian.Point.mk hV := Jacobian.Point.ext key
+    refine ⟨smulEval (W.baseChange K) x₀ y₀ (n : ℤ) 0 /
+        smulEval (W.baseChange K) x₀ y₀ (n : ℤ) 2 ^ 2,
+      smulEval (W.baseChange K) x₀ y₀ (n : ℤ) 1 /
+        smulEval (W.baseChange K) x₀ y₀ (n : ℤ) 2 ^ 3,
+      (Jacobian.nonsingular_of_Z_ne_zero hVz).mp hV, ?_, ?_⟩
+    · calc n • (Point.some x₀ y₀ h : W.toAffine⟮K⟯)
+          = Jacobian.Point.toAffineAddEquiv (W.baseChange K)
+            ((n : ℤ) • Jacobian.Point.fromAffine (Point.some x₀ y₀ h)) := by
+            rw [map_zsmul, ← Jacobian.Point.toAffineAddEquiv_symm_apply,
+              AddEquiv.apply_symm_apply, natCast_zsmul]
+        _ = _ := by
+            rw [hQeq, Jacobian.Point.toAffineAddEquiv_apply]
+            exact Jacobian.Point.toAffineLift_of_Z_ne_zero hVz
+    · change ((W.baseChange K).φ (n : ℤ)).evalEval x₀ y₀ /
+          ((W.baseChange K).ψ (n : ℤ)).evalEval x₀ y₀ ^ 2 *
+          ((W.baseChange K).ΨSq (n : ℤ)).eval x₀ =
+          ((W.baseChange K).Φ (n : ℤ)).eval x₀
+      rw [← hψsq, div_mul_cancel₀ _ (pow_ne_zero 2 hψ),
+        (W.baseChange K).evalEval_φ heq]
+  · intro hΨ
+    have hψ0 : ((W.baseChange K).ψ (n : ℤ)).evalEval x₀ y₀ = 0 :=
+      sq_eq_zero_iff.mp (hψsq.trans hΨ)
+    rw [← natCast_zsmul]
+    exact ((W.baseChange K).smul_eq_zero_iff_evalEval_ψ h (n : ℤ)).mpr hψ0
+
+end Deep.Gen
+
+end PortGenInduction
+
+section PortGenSmulFormula
+
+namespace Deep
+namespace Gen
+
+open WeierstrassCurve WeierstrassCurve.Affine Polynomial
+
+open scoped WeierstrassCurve.Affine
+
+variable {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K]
+variable (W : WeierstrassCurve F)
+
+theorem smul_x_eq [W.IsElliptic] {n : ℕ} (hn : 0 < n) {x₀ y₀ : K}
+    (h : (W.baseChange K).toAffine.Nonsingular x₀ y₀)
+    (hns : ((W.baseChange K).ΨSq n).eval x₀ ≠ 0) :
+    ∃ (x' y' : K) (h' : (W.baseChange K).toAffine.Nonsingular x' y'),
+      n • (Point.some x₀ y₀ h : W.toAffine⟮K⟯) = Point.some x' y' h' ∧
+        x' * ((W.baseChange K).ΨSq n).eval x₀ = ((W.baseChange K).Φ n).eval x₀ :=
+  (smul_formula_or_zero W hn h).1 hns
+
+omit [DecidableEq K] in
+private lemma eval_ne_of_isCoprime {f g : Polynomial K} (h : IsCoprime f g) {x₀ : K}
+    (hf : f.eval x₀ = 0) (hg : g.eval x₀ = 0) : False := by
+  obtain ⟨a, b, hab⟩ := h
+  have h1 := congrArg (Polynomial.eval x₀) hab
+  simp only [eval_add, eval_mul, hf, hg, mul_zero, add_zero, eval_one] at h1
+  exact zero_ne_one h1
+
+omit [DecidableEq K] in
+theorem isCoprime_Φ_ΨSq [IsAlgClosed K] [W.IsElliptic] {n : ℕ} (hn : 0 < n) :
+    IsCoprime ((W.baseChange K).Φ n) ((W.baseChange K).ΨSq n) := by
+  classical
+  rw [Polynomial.isCoprime_iff_aeval_ne_zero_of_isAlgClosed (k := K) (K := K)]
+  intro x₀
+  by_contra hcon
+  push Not at hcon
+  obtain ⟨hΦ0, hΨ0⟩ := hcon
+  rw [coe_aeval_eq_eval] at hΦ0 hΨ0
+  have hΦdef : (W.baseChange K).Φ (n : ℤ) =
+      X * (W.baseChange K).ΨSq (n : ℤ) -
+        (W.baseChange K).preΨ ((n : ℤ) + 1) * (W.baseChange K).preΨ ((n : ℤ) - 1) *
+          (if Even (n : ℤ) then 1 else (W.baseChange K).Ψ₂Sq) := rfl
+  have h0 : ((W.baseChange K).preΨ ((n : ℤ) + 1)).eval x₀ *
+      ((W.baseChange K).preΨ ((n : ℤ) - 1)).eval x₀ *
+      (if Even (n : ℤ) then (1 : K) else ((W.baseChange K).Ψ₂Sq).eval x₀) = 0 := by
+    have h1 := congrArg (Polynomial.eval x₀) hΦdef
+    rw [hΦ0] at h1
+    simp only [eval_sub, eval_mul, eval_X, apply_ite (Polynomial.eval x₀), eval_one, hΨ0,
+      mul_zero, zero_sub] at h1
+    linear_combination h1
+  rcases mul_eq_zero.mp h0 with h12 | hG
+  · rcases mul_eq_zero.mp h12 with hE | hF
+    · have hb : ((W.baseChange K).ΨSq ((n : ℤ) + 1)).eval x₀ = 0 := by
+        have h2 := ΨSq_eval_eq_zero_of_preΨ W (m := n + 1) (K := K)
+          (by rwa [Nat.cast_add, Nat.cast_one])
+        rwa [Nat.cast_add, Nat.cast_one] at h2
+      exact eval_ne_of_isCoprime (isCoprime_ΨSq_succ W n) hΨ0 hb
+    · have hb : ((W.baseChange K).ΨSq ((n - 1 : ℕ) : ℤ)).eval x₀ = 0 :=
+        ΨSq_eval_eq_zero_of_preΨ W (m := n - 1) (K := K)
+          (by rwa [Nat.cast_sub hn, Nat.cast_one])
+      have hA := isCoprime_ΨSq_succ W (K := K) (n - 1)
+      have hc : ((n - 1 : ℕ) : ℤ) + 1 = (n : ℤ) := by omega
+      rw [hc] at hA
+      exact eval_ne_of_isCoprime hA hb hΨ0
+  · by_cases hev : Even (n : ℤ)
+    · rw [ite_eq_left hev] at hG
+      exact one_ne_zero hG
+    · rw [ite_eq_right hev] at hG
+      have hnodd : ¬Even n := fun h => hev (by exact_mod_cast h)
+      have hb : ((W.baseChange K).ΨSq ((n : ℤ) + 1)).eval x₀ = 0 := by
+        have h2 : ((W.baseChange K).ΨSq ((n + 1 : ℕ) : ℤ)).eval x₀ = 0 := by
+          rw [ΨSq_ofNat, ite_eq_left (Nat.even_add_one.mpr hnodd), eval_mul, hG, mul_zero]
+        rwa [Nat.cast_add, Nat.cast_one] at h2
+      exact eval_ne_of_isCoprime (isCoprime_ΨSq_succ W n) hΨ0 hb
+
+theorem smul_eq_zero_of_ΨSq_eval_eq_zero [W.IsElliptic] {n : ℕ} (hn : 0 < n)
+    {x₀ y₀ : K} (h : (W.baseChange K).toAffine.Nonsingular x₀ y₀)
+    (hz : ((W.baseChange K).ΨSq n).eval x₀ = 0) :
+    n • (Point.some x₀ y₀ h : W.toAffine⟮K⟯) = 0 :=
+  (smul_formula_or_zero W hn h).2 hz
+
+omit [DecidableEq K] in
+theorem ΨSq_odd_eq_sq {n : ℕ} (hodd : Odd n) :
+    (W.baseChange K).ΨSq n = ((W.baseChange K).preΨ' n) ^ 2 := by
+  rw [ΨSq_ofNat, ite_eq_right (Nat.not_even_iff_odd.mpr hodd), mul_one]
+
+theorem smul_eq_zero_iff_preΨ'_eval [W.IsElliptic] {n : ℕ} (hodd : Odd n)
+    (hn : 0 < n) {x y : K} (h : (W.baseChange K).toAffine.Nonsingular x y) :
+    n • (Point.some x y h : W.toAffine⟮K⟯) = 0 ↔
+      ((W.baseChange K).preΨ' n).eval x = 0 := by
+  constructor
+  · intro hsmul
+    by_contra hne
+    have hns : ((W.baseChange K).ΨSq n).eval x ≠ 0 := by
+      rw [ΨSq_odd_eq_sq W hodd, eval_pow]
+      exact pow_ne_zero 2 hne
+    obtain ⟨x', y', h', heq, -⟩ := smul_x_eq W hn h hns
+    rw [hsmul] at heq
+    exact Point.some_ne_zero h' heq.symm
+  · intro hz
+    have hz' : ((W.baseChange K).ΨSq n).eval x = 0 := by
+      rw [ΨSq_odd_eq_sq W hodd, eval_pow, hz]
+      exact zero_pow two_ne_zero
+    exact smul_eq_zero_of_ΨSq_eval_eq_zero W hn h hz'
+
+end Deep.Gen
+
+end PortGenSmulFormula
+
+section PortCardSurj
+
+namespace Deep
+namespace Gen
+
+open WeierstrassCurve WeierstrassCurve.Affine Polynomial
+
+open scoped WeierstrassCurve.Affine
+
+variable {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K]
+variable (W : WeierstrassCurve F)
+
+theorem nsmul_surjective_charfree [IsAlgClosed K] [W.IsElliptic] {n : ℕ} (hpos : 0 < n) :
+    Function.Surjective (fun P : W.toAffine⟮K⟯ => n • P) := by
+  intro Q
+  rcases Q with _ | ⟨xQ, yQ, hQ⟩
+  · refine ⟨0, ?_⟩
+    change n • (0 : W.toAffine⟮K⟯) = Point.zero
+    rw [nsmul_zero]
+    exact Point.zero_def
+  set F' := (W.baseChange K).Φ n with hFdef
+  set G := (W.baseChange K).ΨSq n with hGdef
+  have hFdeg : F'.natDegree = n ^ 2 := by
+    have h := WeierstrassCurve.natDegree_Φ (W.baseChange K) (n : ℤ)
+    rw [Int.natAbs_natCast] at h
+    rw [hFdef, h]
+  have hGdeg : G.natDegree ≤ n ^ 2 - 1 := by
+    have h := WeierstrassCurve.natDegree_ΨSq_le (W.baseChange K) (n : ℤ)
+    rw [Int.natAbs_natCast] at h
+    rw [hGdef]; exact h
+  have h1n : 1 ≤ n ^ 2 := Nat.one_le_iff_ne_zero.mpr (pow_ne_zero 2 hpos.ne')
+  set p : K[X] := F' - C xQ * G with hpdef
+  have hpdeg : p.natDegree = n ^ 2 := by
+    rw [hpdef]
+    rw [natDegree_sub_eq_left_of_natDegree_lt, hFdeg]
+    refine lt_of_le_of_lt (natDegree_C_mul_le xQ G) ?_
+    rw [hFdeg]
+    omega
+  have hpdegne : p.degree ≠ 0 := by
+    have hpos' : 0 < p.natDegree := by rw [hpdeg]; omega
+    exact (natDegree_pos_iff_degree_pos.mp hpos').ne'
+  obtain ⟨x₀, hx₀⟩ := IsAlgClosed.exists_root p hpdegne
+  have hpx : p.eval x₀ = 0 := hx₀
+  have hroot : F'.eval x₀ = xQ * G.eval x₀ := by
+    rw [hpdef, eval_sub, eval_mul, eval_C, sub_eq_zero] at hpx
+    exact hpx
+  have hGx : G.eval x₀ ≠ 0 := by
+    intro hG0
+    have hF0 : F'.eval x₀ = 0 := by rw [hroot, hG0, mul_zero]
+    obtain ⟨a, b, hab⟩ := isCoprime_Φ_ΨSq W (K := K) hpos
+    rw [← hFdef, ← hGdef] at hab
+    have h1 := congrArg (Polynomial.eval x₀) hab
+    rw [eval_add, eval_mul, eval_mul, eval_one, hF0, hG0, mul_zero, mul_zero,
+      add_zero] at h1
+    exact zero_ne_one h1
+  obtain ⟨y₀, hy₀⟩ : ∃ y : K, (W.baseChange K).toAffine.Equation x₀ y := by
+    obtain ⟨y, hy⟩ := IsAlgClosed.exists_root
+      (C 1 * X ^ 2 + C ((W.baseChange K).a₁ * x₀ + (W.baseChange K).a₃) * X
+        + C (-(x₀ ^ 3 + (W.baseChange K).a₂ * x₀ ^ 2 + (W.baseChange K).a₄ * x₀ +
+            (W.baseChange K).a₆)))
+      (by rw [degree_quadratic one_ne_zero]; norm_num)
+    refine ⟨y, ?_⟩
+    rw [WeierstrassCurve.Affine.equation_iff]
+    simp only [IsRoot, eval_add, eval_mul, eval_pow, eval_C, eval_X, one_mul] at hy
+    linear_combination hy
+  have h₀ : (W.baseChange K).toAffine.Nonsingular x₀ y₀ :=
+    WeierstrassCurve.Affine.equation_iff_nonsingular.mp hy₀
+  obtain ⟨x', y', h', hsmul, hx'⟩ := smul_x_eq W hpos h₀ hGx
+  rw [← hFdef, ← hGdef] at hx'
+  have hx'Q : x' = xQ := by
+    rw [hroot] at hx'
+    exact mul_right_cancel₀ hGx hx'
+  subst hx'Q
+  rcases WeierstrassCurve.Affine.Y_eq_of_X_eq h'.1 hQ.1 rfl with rfl | rfl
+  · exact ⟨Point.some x₀ y₀ h₀, hsmul⟩
+  · have hnegQ : -(Point.some x' yQ hQ : W.toAffine⟮K⟯) =
+        Point.some x' ((W.baseChange K).toAffine.negY x' yQ)
+          ((WeierstrassCurve.Affine.nonsingular_neg ..).mpr hQ) := Point.neg_some hQ
+    have hprev : n • (Point.some x₀ y₀ h₀ : W.toAffine⟮K⟯) =
+        -(Point.some x' yQ hQ) := by
+      rw [hnegQ]
+      exact hsmul
+    have hsn : n • -(Point.some x₀ y₀ h₀ : W.toAffine⟮K⟯) =
+        -(n • (Point.some x₀ y₀ h₀ : W.toAffine⟮K⟯)) :=
+      neg_nsmul (Point.some x₀ y₀ h₀ : W.toAffine⟮K⟯) n
+    refine ⟨-(Point.some x₀ y₀ h₀), ?_⟩
+    change n • -(Point.some x₀ y₀ h₀ : W.toAffine⟮K⟯) = Point.some x' yQ hQ
+    rw [hsn, hprev, neg_neg]
+
+theorem exists_zsmul_eq [IsAlgClosed K] [W.IsElliptic] {n : ℤ} (hn : n ≠ 0)
+    (P : W.toAffine⟮K⟯) : ∃ Q : W.toAffine⟮K⟯, n • Q = P := by
+  have hpos : 0 < n.natAbs := Int.natAbs_pos.mpr hn
+  obtain ⟨Q, hQ⟩ := nsmul_surjective_charfree W (K := K) hpos P
+  rcases Int.natAbs_eq n with h | h
+  · exact ⟨Q, by rw [h, natCast_zsmul]; exact hQ⟩
+  · exact ⟨-Q, by rw [h, neg_zsmul, zsmul_neg, neg_neg, natCast_zsmul]; exact hQ⟩
+
+end Deep.Gen
+
+theorem PortCard.exists_zsmul_eq_of_isAlgClosed {K : Type*} [Field K] [IsAlgClosed K]
+    [DecidableEq K] (E : WeierstrassCurve K) [E.IsElliptic] {n : ℤ} (hn : n ≠ 0)
+    (P : E.toAffine.Point) : ∃ Q : E.toAffine.Point, n • Q = P :=
+  Deep.Gen.exists_zsmul_eq (F := K) (K := K) E hn P
+
+end PortCardSurj
+
+theorem solution {K : Type*} [Field K] [IsAlgClosed K] [DecidableEq K] (E : WeierstrassCurve K)
+    [E.IsElliptic] {n : ℤ} (hn : n ≠ 0) (P : E.toAffine.Point) :
+    ∃ Q : E.toAffine.Point, n • Q = P :=
+  PortCard.exists_zsmul_eq_of_isAlgClosed E hn P
+
+end S_WeierstrassCurve_Affine_Point_exists_zsmul_eq_of_isAlgClosed
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_Point_exists_zsmul_eq_of_isAlgClosed (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.Affine.Point.exists_zsmul_eq_of_isAlgClosed {K : Type*} [Field K]
+    [IsAlgClosed K] [DecidableEq K] (E : WeierstrassCurve K) [E.IsElliptic] {n : ℤ} (hn : n ≠ 0)
+    (P : E.toAffine.Point) :
+    ∃ Q : E.toAffine.Point, n • Q = P :=
+  solution E hn P
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_exists_zsmul_some_eq_some_baseChange.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_exists_zsmul_some_eq_some_baseChange.lean
new file mode 100644
index 0000000000..094c4668fe
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_exists_zsmul_some_eq_some_baseChange.lean
@@ -0,0 +1,193 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.Point.exists_zsmul_some_eq_some_baseChange
+(2098c45a-1264-59ac-a1e4-8401808ef3c9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c6f43190-738e-5d94-8e4d-f66649925800
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_EDSEngine
+import Mathlib.NumberTheory.EllipticDivisibilitySequence
+import Mathlib.Algebra.Ring.NegOnePow
+import Mathlib.Data.Fin.VecNotation
+import Mathlib.Data.Fin.Tuple.Sort
+import Mathlib.Algebra.GroupWithZero.NonZeroDivisors
+import Mathlib.Algebra.MvPolynomial.CommRing
+import Mathlib.Algebra.MvPolynomial.Basic
+import Mathlib.Tactic.LinearCombination
+import Mathlib.Tactic.Ring
+import Mathlib.Tactic.Abel
+import Mathlib.Tactic.IntervalCases
+import Mathlib.Tactic.FieldSimp
+import Mathlib.GroupTheory.Perm.Basic
+import Mathlib.GroupTheory.Perm.Sign
+import Mathlib.GroupTheory.Perm.Cycle.Type
+import Mathlib.Algebra.Polynomial.Bivariate
+import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+import Mathlib.AlgebraicGeometry.EllipticCurve.Jacobian.Point
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+import Mathlib.FieldTheory.IsAlgClosed.Basic
+import Mathlib.FieldTheory.Separable
+import Mathlib.Data.Nat.Factorization.Induction
+import Mathlib.Logic.Embedding.Set
+import Mathlib.SetTheory.Cardinal.Finite
+import Mathlib.Data.Set.Card
+import Mathlib.Algebra.Module.Torsion.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Universal two-coordinate multiplication-by-n formula for Weierstrass curves
+
+Theorem statement: `WeierstrassCurve.Affine.Point.exists_zsmul_some_eq_some_baseChange`
+(`2098c45a-1264-59ac-a1e4-8401808ef3c9`), by Claude, 2026-09-05.
+
+Proof: submission `c6f43190-738e-5d94-8e4d-f66649925800`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring, $W$ a Weierstrass curve over $R$, and $n$ an integer. The assertion
+is that there exists a single bivariate polynomial $\omega \in R[X][Y]$, depending only on $W$ and
+$n$, with the following property: for every field $F$ (with decidable equality) carrying an
+$R$-algebra structure, and all $x, y \in F$ such that $(x,y)$ is a nonsingular point of the affine
+model of the base change $W_F =$ `W.baseChange F`, and such that the value $\psi_n(x,y)$ of the
+$n$-th division polynomial of $W_F$ at $(x,y)$ is nonzero, the pair
+$$\left(\frac{\Phi_n(x)}{\Psi_n^2(x)},\ \frac{\omega_F(x,y)}{\psi_n(x,y)^3}\right)$$ is again a
+nonsingular point of the affine model of $W_F$ — the existence of the nonsingularity witness is part
+of the conclusion — and the $n$-fold multiple $n \cdot \mathtt{some}\,x\,y\,h$ in the group of
+affine points of $W_F$ equals the point with these coordinates. Here $\Phi_n$, $\Psi_n^2$ are the
+univariate division polynomials of $W_F$ evaluated at $x$, and $\omega_F$ denotes the image of
+$\omega$ under the coefficientwise map induced by `algebraMap R F`. Thus $\omega$ is universal: one
+polynomial over the base ring serves all $R$-algebra fields $F$ simultaneously.
+
+This is the classical two-coordinate multiplication-by-$n$ formula $nP = (\phi_n/\psi_n^2,
+\omega_n/\psi_n^3)$ for a Weierstrass curve, in the form $n(x:y:1) = (\phi_n : \omega_n : \psi_n)$
+in Jacobian coordinates read affinely, with the third family $\omega_n$ of division polynomials
+produced over the base ring so that it specialises compatibly to every field extension. The
+universality in $F$ is what makes the formula usable both for points over a fixed field and for the
+generic point over the function field; it is used in the analysis of valuations of the coordinates
+of $nP$, in
+[`WeierstrassCurve.Affine.valuation_mulPull_le_of_ne_zero`]
+(thm.html#WeierstrassCurve.Affine.valuation_mulPull_le_of_ne_zero).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_Point_exists_zsmul_some_eq_some_baseChange.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_Point_exists_zsmul_some_eq_some_baseChange
+
+section PortCardMulXY
+
+namespace PortCard
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point Polynomial
+open scoped Polynomial.Bivariate
+
+theorem zsmul_some_eq_some_jac {F : Type*} [Field F] [DecidableEq F] (V : WeierstrassCurve F)
+    {x y : F} (h : V.toAffine.Nonsingular x y) {n : ℤ} (hψ : (V.ψ n).evalEval x y ≠ 0) :
+    ∃ h' : V.toAffine.Nonsingular ((V.φ n).evalEval x y / (V.ψ n).evalEval x y ^ 2)
+        ((V.ωe n).evalEval x y / (V.ψ n).evalEval x y ^ 3),
+      n • Point.some x y h = Point.some ((V.φ n).evalEval x y / (V.ψ n).evalEval x y ^ 2)
+        ((V.ωe n).evalEval x y / (V.ψ n).evalEval x y ^ 3) h' := by
+  have key := zsmul_eq_smulEval V h n
+  have hVz : smulEval V x y n 2 ≠ 0 := hψ
+  have hV := key ▸ (n • Jacobian.Point.fromAffine (Point.some x y h)).nonsingular
+  have hQeq : (n • Jacobian.Point.fromAffine (Point.some x y h)) =
+      Jacobian.Point.mk hV := Jacobian.Point.ext key
+  refine ⟨(Jacobian.nonsingular_of_Z_ne_zero hVz).mp hV, ?_⟩
+  calc n • Point.some x y h
+      = Jacobian.Point.toAffineAddEquiv V
+          (n • Jacobian.Point.fromAffine (Point.some x y h)) := by
+        rw [map_zsmul, ← Jacobian.Point.toAffineAddEquiv_symm_apply,
+          AddEquiv.apply_symm_apply]
+    _ = _ := by
+        rw [hQeq, Jacobian.Point.toAffineAddEquiv_apply]
+        exact Jacobian.Point.toAffineLift_of_Z_ne_zero hVz
+
+theorem some_congr {F : Type*} [CommRing F] {V : Affine F} {x₁ x₂ y₁ y₂ : F} (ex : x₁ = x₂)
+    (ey : y₁ = y₂) (h₁ : V.Nonsingular x₁ y₁) :
+    ∃ h₂ : V.Nonsingular x₂ y₂, Point.some x₁ y₁ h₁ = Point.some x₂ y₂ h₂ := by
+  subst ex ey; exact ⟨h₁, rfl⟩
+
+universe u v in
+theorem exists_zsmul_some_eq_some_baseChange {R : Type u} [CommRing R] (W : WeierstrassCurve R)
+    (n : ℤ) : ∃ ω : R[X][Y], ∀ {F : Type v} [Field F] [DecidableEq F] [Algebra R F] {x y : F}
+      (h : (W.baseChange F).toAffine.Nonsingular x y),
+      ((W.baseChange F).ψ n).evalEval x y ≠ 0 →
+        ∃ h' : (W.baseChange F).toAffine.Nonsingular
+            (((W.baseChange F).Φ n).eval x / ((W.baseChange F).ΨSq n).eval x)
+            ((ω.map (mapRingHom (algebraMap R F))).evalEval x y /
+              ((W.baseChange F).ψ n).evalEval x y ^ 3),
+          n • Point.some x y h =
+            Point.some (((W.baseChange F).Φ n).eval x / ((W.baseChange F).ΨSq n).eval x)
+              ((ω.map (mapRingHom (algebraMap R F))).evalEval x y /
+                ((W.baseChange F).ψ n).evalEval x y ^ 3) h' := by
+  refine ⟨W.ωe n, ?_⟩
+  intro F _ _ _ x y h hψ
+  have hω : (W.baseChange F).ωe n = (W.ωe n).map (mapRingHom (algebraMap R F)) := by
+    rw [WeierstrassCurve.baseChange, map_ωe]
+  obtain ⟨h₁, e₁⟩ := zsmul_some_eq_some_jac (W.baseChange F) h hψ
+  have ex : ((W.baseChange F).φ n).evalEval x y / ((W.baseChange F).ψ n).evalEval x y ^ 2 =
+      ((W.baseChange F).Φ n).eval x / ((W.baseChange F).ΨSq n).eval x := by
+    rw [(W.baseChange F).evalEval_φ h.left n, (W.baseChange F).evalEval_ψ_sq h.left n]
+  have ey : ((W.baseChange F).ωe n).evalEval x y / ((W.baseChange F).ψ n).evalEval x y ^ 3 =
+      ((W.ωe n).map (mapRingHom (algebraMap R F))).evalEval x y /
+        ((W.baseChange F).ψ n).evalEval x y ^ 3 := by
+    rw [hω]
+  obtain ⟨h₂, e₂⟩ := some_congr ex ey h₁
+  exact ⟨h₂, e₁.trans e₂⟩
+
+end PortCard
+
+end PortCardMulXY
+
+universe u v
+
+theorem solution {R : Type u} [CommRing R] (W : WeierstrassCurve R) (n : ℤ) :
+    ∃ ω : Polynomial (Polynomial R), ∀ {F : Type v} [Field F] [DecidableEq F] [Algebra R F] {x y :
+      F} (h : (W.baseChange F).toAffine.Nonsingular x y), ((W.baseChange F).ψ n).evalEval x y ≠ 0 →
+      ∃ h' : (W.baseChange F).toAffine.Nonsingular (((W.baseChange F).Φ n).eval x / ((W.baseChange
+      F).ΨSq n).eval x) ((ω.map (Polynomial.mapRingHom (algebraMap R F))).evalEval x y /
+      ((W.baseChange F).ψ n).evalEval x y ^ 3), n • WeierstrassCurve.Affine.Point.some x y h =
+      WeierstrassCurve.Affine.Point.some (((W.baseChange F).Φ n).eval x / ((W.baseChange F).ΨSq
+      n).eval x) ((ω.map (Polynomial.mapRingHom (algebraMap R F))).evalEval x y / ((W.baseChange
+      F).ψ n).evalEval x y ^ 3) h' :=
+  PortCard.exists_zsmul_some_eq_some_baseChange W n
+
+end S_WeierstrassCurve_Affine_Point_exists_zsmul_some_eq_some_baseChange
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_Point_exists_zsmul_some_eq_some_baseChange (solution)
+
+end privateSection
+
+public section publicSection
+
+
+universe u v
+
+theorem WeierstrassCurve.Affine.Point.exists_zsmul_some_eq_some_baseChange {R : Type u} [CommRing R]
+    (W : WeierstrassCurve R) (n : ℤ) :
+    ∃ ω : Polynomial (Polynomial R), ∀ {F : Type v} [Field F] [DecidableEq F] [Algebra R F] {x y :
+      F} (h : (W.baseChange F).toAffine.Nonsingular x y), ((W.baseChange F).ψ n).evalEval x y ≠ 0 →
+      ∃ h' : (W.baseChange F).toAffine.Nonsingular (((W.baseChange F).Φ n).eval x / ((W.baseChange
+      F).ΨSq n).eval x) ((ω.map (Polynomial.mapRingHom (algebraMap R F))).evalEval x y /
+      ((W.baseChange F).ψ n).evalEval x y ^ 3), n • WeierstrassCurve.Affine.Point.some x y h =
+      WeierstrassCurve.Affine.Point.some (((W.baseChange F).Φ n).eval x / ((W.baseChange F).ΨSq
+      n).eval x) ((ω.map (Polynomial.mapRingHom (algebraMap R F))).evalEval x y / ((W.baseChange
+      F).ψ n).evalEval x y ^ 3) h' :=
+  solution W n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_natDegree_parallelogram_law.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_natDegree_parallelogram_law.lean
new file mode 100644
index 0000000000..439d733164
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_natDegree_parallelogram_law.lean
@@ -0,0 +1,566 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.Point.natDegree_parallelogram_law
+(d8d46a03-b886-547a-a5fe-43d7385287f3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8f0e45ff-0859-57cc-9267-ce703131fc2a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Parallelogram law for degrees of abscissa maps
+
+Theorem statement: `WeierstrassCurve.Affine.Point.natDegree_parallelogram_law`
+(`d8d46a03-b886-547a-a5fe-43d7385287f3`), by Claude, 2026-09-05.
+
+Proof: submission `8f0e45ff-0859-57cc-9267-ce703131fc2a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $k$ be an algebraically closed field with decidable equality, and let $W$ be a Weierstrass curve
+over $k$ which is elliptic (invertible discriminant). Let $S \subseteq k$ be a finite set and let
+$u,v,s,t,u_1,v_1,u_2,v_2 \in k[X]$ satisfy: $u,v$ coprime, $s,t$ coprime, $u_1,v_1$ coprime,
+$u_2,v_2$ coprime, with $u \ne 0$, $v \ne 0$, $t \ne 0$, $v_1 \ne 0$, $v_2 \ne 0$, and the degree
+conditions $\deg v \le \deg u$ and $\deg t < \deg s$. Assume that for every $x \in k$ outside $S$
+there are field elements $x_a,y_a,x_b,y_b,x_p,y_p,x_m,y_m$ which are nonsingular points of the
+affine curve $W$, such that, in the group of affine points of $W$ (with point at infinity),
+$(x_a,y_a) + (x_b,y_b) = (x_p,y_p)$ and $(x_a,y_a) - (x_b,y_b) = (x_m,y_m)$, and such that
+$x_a\,v(x) = u(x)$, $x_b\,t(x) = s(x)$, $x_p\,v_1(x) = u_1(x)$, $x_m\,v_2(x) = u_2(x)$. Then $u_1
+\ne 0$, $u_2 \ne 0$, $$\deg u_1 + \deg u_2 = 2(\deg u + \deg s), \qquad \deg v_1 + \deg v_2 =
+2\deg(ut - sv),$$ all degrees being `natDegree`.
+
+This is the second-difference step in Manin's elementary treatment of the Hasse bound: writing $d$
+for the degree of the numerator of an abscissa map, it expresses $d(A+B) + d(A-B) = 2d(A) + 2d(B)$
+for families of points parametrised by $x$, in a form valid in every characteristic. It feeds the
+degree recursion for the kernel degrees of $[m] - \pi$ with $\pi$ the Frobenius endomorphism, and
+the construction of dual isogenies on the ring of rational endomorphisms.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_Point_natDegree_parallelogram_law.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_Point_natDegree_parallelogram_law
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+open Polynomial
+
+namespace ParallelogramLaw
+
+section AddFormula
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : Affine F}
+
+lemma addX_mul_sq_of_X_ne {x₁ x₂ : F} (y₁ y₂ : F) (hx : x₁ ≠ x₂) :
+    W.addX x₁ x₂ (W.slope x₁ x₂ y₁ y₂) * (x₁ - x₂) ^ 2 =
+      (y₁ - y₂) ^ 2 + W.a₁ * (y₁ - y₂) * (x₁ - x₂) - (W.a₂ + x₁ + x₂) * (x₁ - x₂) ^ 2 := by
+  have hd : x₁ - x₂ ≠ 0 := sub_ne_zero.mpr hx
+  have e : (y₁ - y₂) / (x₁ - x₂) * (x₁ - x₂) = y₁ - y₂ := div_mul_cancel₀ _ hd
+  rw [slope_of_X_ne hx, addX]
+  linear_combination
+    ((y₁ - y₂) / (x₁ - x₂) * (x₁ - x₂) + (y₁ - y₂) + W.a₁ * (x₁ - x₂)) * e
+
+theorem addX_add_addX_negY_mul_sq {x₁ x₂ y₁ y₂ : F} (h₁ : W.Equation x₁ y₁)
+    (h₂ : W.Equation x₂ y₂) (hx : x₁ ≠ x₂) :
+    (W.addX x₁ x₂ (W.slope x₁ x₂ y₁ y₂) +
+        W.addX x₁ x₂ (W.slope x₁ x₂ y₁ (W.negY x₂ y₂))) * (x₁ - x₂) ^ 2 =
+      2 * (x₁ * x₂) * (x₁ + x₂) + W.b₂ * (x₁ * x₂) + W.b₄ * (x₁ + x₂) + W.b₆ := by
+  have e₁ := addX_mul_sq_of_X_ne (W := W) y₁ y₂ hx
+  have e₂ := addX_mul_sq_of_X_ne (W := W) y₁ (W.negY x₂ y₂) hx
+  rw [equation_iff] at h₁ h₂
+  rw [add_mul, e₁, e₂, negY, b₂, b₄, b₆]
+  linear_combination 2 * h₁ + 2 * h₂
+
+theorem addX_mul_addX_negY_mul_sq {x₁ x₂ y₁ y₂ : F} (h₁ : W.Equation x₁ y₁)
+    (h₂ : W.Equation x₂ y₂) (hx : x₁ ≠ x₂) :
+    W.addX x₁ x₂ (W.slope x₁ x₂ y₁ y₂) *
+        W.addX x₁ x₂ (W.slope x₁ x₂ y₁ (W.negY x₂ y₂)) * (x₁ - x₂) ^ 2 =
+      (x₁ * x₂) ^ 2 - W.b₄ * (x₁ * x₂) - W.b₆ * (x₁ + x₂) - W.b₈ := by
+  have hd : x₁ - x₂ ≠ 0 := sub_ne_zero.mpr hx
+  have hd2 : (x₁ - x₂) ^ 2 ≠ 0 := pow_ne_zero 2 hd
+  have e₁ := addX_mul_sq_of_X_ne (W := W) y₁ y₂ hx
+  have e₂ := addX_mul_sq_of_X_ne (W := W) y₁ (W.negY x₂ y₂) hx
+  have key : ((y₁ - y₂) ^ 2 + W.a₁ * (y₁ - y₂) * (x₁ - x₂) -
+        (W.a₂ + x₁ + x₂) * (x₁ - x₂) ^ 2) *
+      ((y₁ - W.negY x₂ y₂) ^ 2 + W.a₁ * (y₁ - W.negY x₂ y₂) * (x₁ - x₂) -
+        (W.a₂ + x₁ + x₂) * (x₁ - x₂) ^ 2) =
+      ((x₁ * x₂) ^ 2 - W.b₄ * (x₁ * x₂) - W.b₆ * (x₁ + x₂) - W.b₈) * (x₁ - x₂) ^ 2 := by
+    rw [equation_iff] at h₁ h₂
+    rw [negY, b₄, b₆, b₈]
+    linear_combination
+      (W.a₁ ^ 2 * x₁ * x₂ - W.a₁ ^ 2 * x₂ ^ 2 + W.a₁ * W.a₃ * x₁ - W.a₁ * W.a₃ * x₂ +
+          W.a₁ * x₁ * y₁ - 2 * W.a₁ * x₂ * y₂ - W.a₂ * x₁ ^ 2 + 4 * W.a₂ * x₁ * x₂ -
+          2 * W.a₂ * x₂ ^ 2 + W.a₃ * y₁ - 2 * W.a₃ * y₂ + W.a₄ * x₁ + W.a₆ - x₁ ^ 3 +
+          2 * x₁ ^ 2 * x₂ + 2 * x₁ * x₂ ^ 2 - 2 * x₂ ^ 3 + y₁ ^ 2 - 2 * y₂ ^ 2) * h₁ +
+      (-W.a₁ ^ 2 * x₁ ^ 2 + W.a₁ ^ 2 * x₁ * x₂ - W.a₁ * W.a₃ * x₁ + W.a₁ * W.a₃ * x₂ +
+          W.a₁ * x₂ * y₂ - 4 * W.a₂ * x₁ ^ 2 + 4 * W.a₂ * x₁ * x₂ - W.a₂ * x₂ ^ 2 +
+          W.a₃ * y₂ - 2 * W.a₄ * x₁ + W.a₄ * x₂ - W.a₆ - 4 * x₁ ^ 3 + 2 * x₁ ^ 2 * x₂ +
+          2 * x₁ * x₂ ^ 2 - x₂ ^ 3 + y₂ ^ 2) * h₂
+  apply mul_left_cancel₀ hd2
+  calc (x₁ - x₂) ^ 2 * (W.addX x₁ x₂ (W.slope x₁ x₂ y₁ y₂) *
+          W.addX x₁ x₂ (W.slope x₁ x₂ y₁ (W.negY x₂ y₂)) * (x₁ - x₂) ^ 2)
+      = (W.addX x₁ x₂ (W.slope x₁ x₂ y₁ y₂) * (x₁ - x₂) ^ 2) *
+          (W.addX x₁ x₂ (W.slope x₁ x₂ y₁ (W.negY x₂ y₂)) * (x₁ - x₂) ^ 2) := by ring
+    _ = ((y₁ - y₂) ^ 2 + W.a₁ * (y₁ - y₂) * (x₁ - x₂) -
+            (W.a₂ + x₁ + x₂) * (x₁ - x₂) ^ 2) *
+          ((y₁ - W.negY x₂ y₂) ^ 2 + W.a₁ * (y₁ - W.negY x₂ y₂) * (x₁ - x₂) -
+            (W.a₂ + x₁ + x₂) * (x₁ - x₂) ^ 2) := by rw [e₁, e₂]
+    _ = ((x₁ * x₂) ^ 2 - W.b₄ * (x₁ * x₂) - W.b₆ * (x₁ + x₂) - W.b₈) * (x₁ - x₂) ^ 2 := key
+    _ = (x₁ - x₂) ^ 2 *
+          ((x₁ * x₂) ^ 2 - W.b₄ * (x₁ * x₂) - W.b₆ * (x₁ + x₂) - W.b₈) := by ring
+
+theorem X_ne_and_eq_addX_of_add_sub {xa ya xb yb xp yp xm ym : F}
+    {ha : W.Nonsingular xa ya} {hb : W.Nonsingular xb yb}
+    {hp : W.Nonsingular xp yp} {hm : W.Nonsingular xm ym}
+    (hadd : Point.some xa ya ha + Point.some xb yb hb = Point.some xp yp hp)
+    (hsub : Point.some xa ya ha - Point.some xb yb hb = Point.some xm ym hm) :
+    xa ≠ xb ∧ xp = W.addX xa xb (W.slope xa xb ya yb)
+      ∧ xm = W.addX xa xb (W.slope xa xb ya (W.negY xb yb)) := by
+  have hsub' : Point.some xa ya ha + Point.some xb (W.negY xb yb) ((nonsingular_neg xb yb).mpr hb)
+      = Point.some xm ym hm := by
+    rw [← hsub, sub_eq_add_neg, neg_some]
+  have hne : xa ≠ xb := by
+    intro hx
+    rcases Y_eq_of_X_eq ha.left hb.left hx with hy | hy
+    · have hy' : ya = W.negY xb (W.negY xb yb) := by rw [negY_negY]; exact hy
+      rw [add_of_Y_eq hx hy'] at hsub'
+      exact some_ne_zero hm hsub'.symm
+    · rw [add_of_Y_eq hx hy] at hadd
+      exact some_ne_zero hp hadd.symm
+  refine ⟨hne, ?_, ?_⟩
+  · rw [add_of_X_ne hne] at hadd
+    exact (Point.some.inj hadd).left.symm
+  · rw [add_of_X_ne hne] at hsub'
+    exact (Point.some.inj hsub').left.symm
+
+end AddFormula
+
+section Bezout
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+def bezF (x : F) : F :=
+  (8 * W.b₂ ^ 3 * W.b₆ - 8 * W.b₂ ^ 2 * W.b₄ ^ 2 + 16 * W.b₂ ^ 2 * W.b₈ -
+      336 * W.b₂ * W.b₄ * W.b₆ + 288 * W.b₄ ^ 3 - 384 * W.b₄ * W.b₈ + 1296 * W.b₆ ^ 2) * x ^ 2 +
+    (2 * W.b₂ ^ 4 * W.b₆ - 2 * W.b₂ ^ 3 * W.b₄ ^ 2 - 80 * W.b₂ ^ 2 * W.b₄ * W.b₆ +
+      72 * W.b₂ * W.b₄ ^ 3 + 32 * W.b₂ * W.b₄ * W.b₈ + 360 * W.b₂ * W.b₆ ^ 2 -
+      144 * W.b₄ ^ 2 * W.b₆ - 576 * W.b₆ * W.b₈) * x +
+    (-W.b₂ ^ 4 * W.b₈ + 5 * W.b₂ ^ 3 * W.b₄ * W.b₆ - 4 * W.b₂ ^ 2 * W.b₄ ^ 3 +
+      48 * W.b₂ ^ 2 * W.b₄ * W.b₈ + W.b₂ ^ 2 * W.b₆ ^ 2 - 204 * W.b₂ * W.b₄ ^ 2 * W.b₆ -
+      176 * W.b₂ * W.b₆ * W.b₈ + 144 * W.b₄ ^ 4 - 384 * W.b₄ ^ 2 * W.b₈ +
+      864 * W.b₄ * W.b₆ ^ 2 + 256 * W.b₈ ^ 2)
+
+def bezG (x : F) : F :=
+  (-2 * W.b₂ ^ 3 * W.b₆ + 2 * W.b₂ ^ 2 * W.b₄ ^ 2 - 4 * W.b₂ ^ 2 * W.b₈ +
+      84 * W.b₂ * W.b₄ * W.b₆ - 72 * W.b₄ ^ 3 + 96 * W.b₄ * W.b₈ - 324 * W.b₆ ^ 2) * x ^ 3 +
+    (W.b₂ ^ 3 * W.b₈ - W.b₂ ^ 2 * W.b₄ * W.b₆ - 32 * W.b₂ * W.b₄ * W.b₈ - 9 * W.b₂ * W.b₆ ^ 2 +
+      36 * W.b₄ ^ 2 * W.b₆ + 144 * W.b₆ * W.b₈) * x ^ 2 +
+    (2 * W.b₂ ^ 3 * W.b₄ * W.b₆ - 2 * W.b₂ ^ 2 * W.b₄ ^ 3 + 2 * W.b₂ ^ 2 * W.b₄ * W.b₈ +
+      2 * W.b₂ ^ 2 * W.b₆ ^ 2 - 84 * W.b₂ * W.b₄ ^ 2 * W.b₆ + 8 * W.b₂ * W.b₆ * W.b₈ +
+      72 * W.b₄ ^ 4 - 48 * W.b₄ ^ 2 * W.b₈ + 270 * W.b₄ * W.b₆ ^ 2 - 64 * W.b₈ ^ 2) * x +
+    (-W.b₂ ^ 3 * W.b₄ * W.b₈ + 4 * W.b₂ ^ 3 * W.b₆ ^ 2 - 3 * W.b₂ ^ 2 * W.b₄ ^ 2 * W.b₆ +
+      7 * W.b₂ ^ 2 * W.b₆ * W.b₈ + 36 * W.b₂ * W.b₄ ^ 2 * W.b₈ - 162 * W.b₂ * W.b₄ * W.b₆ ^ 2 +
+      16 * W.b₂ * W.b₈ ^ 2 + 108 * W.b₄ ^ 3 * W.b₆ - 432 * W.b₄ * W.b₆ * W.b₈ +
+      729 * W.b₆ ^ 3)
+
+theorem bezF_mul_add_bezG_mul (x : F) :
+    bezF W x * (x ^ 4 - W.b₄ * x ^ 2 - 2 * W.b₆ * x - W.b₈)
+      + bezG W x * (4 * x ^ 3 + W.b₂ * x ^ 2 + 2 * W.b₄ * x + W.b₆) = W.Δ ^ 2 := by
+  rw [bezF, bezG]
+  simp only [Δ]
+  linear_combination (-12 * W.b₂ ^ 2 * W.b₄ * W.b₈ - 4 * W.b₂ ^ 2 * W.b₆ ^ 2 +
+    80 * W.b₂ * W.b₄ ^ 2 * W.b₆ + 32 * W.b₂ * W.b₆ * W.b₈ - 64 * W.b₄ ^ 4 +
+    112 * W.b₄ ^ 2 * W.b₈ - 324 * W.b₄ * W.b₆ ^ 2 - 64 * W.b₈ ^ 2) * W.b_relation
+
+theorem not_common_root_two_torsion [W.IsElliptic] {x : F}
+    (hΦ : x ^ 4 - W.b₄ * x ^ 2 - 2 * W.b₆ * x - W.b₈ = 0)
+    (hΨ : 4 * x ^ 3 + W.b₂ * x ^ 2 + 2 * W.b₄ * x + W.b₆ = 0) : False := by
+  have h := bezF_mul_add_bezG_mul W x
+  rw [hΦ, hΨ, mul_zero, mul_zero, add_zero] at h
+  exact pow_ne_zero 2 W.isUnit_Δ.ne_zero h.symm
+
+end Bezout
+
+section Poly
+
+variable {K : Type*} [Field K]
+
+lemma not_isRoot_left_of_isCoprime {u v : K[X]} (hcop : IsCoprime u v) {r : K}
+    (hv : v.IsRoot r) : ¬ u.IsRoot r := by
+  intro hu
+  obtain ⟨a, b, hab⟩ := hcop
+  have h := congrArg (Polynomial.eval r) hab
+  have hu0 : u.eval r = 0 := hu
+  have hv0 : v.eval r = 0 := hv
+  rw [Polynomial.eval_add, Polynomial.eval_mul, Polynomial.eval_mul, Polynomial.eval_one,
+    hu0, hv0, mul_zero, mul_zero, add_zero] at h
+  exact zero_ne_one h
+
+lemma eval_ne_zero_of_isCoprime {u v : K[X]} (hcop : IsCoprime u v) {r : K}
+    (hv : v.eval r = 0) : u.eval r ≠ 0 :=
+  fun hu => not_isRoot_left_of_isCoprime hcop hv hu
+
+lemma exists_common_cofactor [IsAlgClosed K]
+    {uP vP uM vM Cm A B : K[X]}
+    (hcopP : IsCoprime uP vP) (hcopM : IsCoprime uM vM)
+    (hup : uP ≠ 0) (hum : uM ≠ 0) (hvp : vP ≠ 0) (hvm : vM ≠ 0) (hCm : Cm ≠ 0)
+    (hP : uP * uM * Cm ^ 2 = vP * vM * A)
+    (hS : (uP * vM + uM * vP) * Cm ^ 2 = vP * vM * B) :
+    ∃ h : K[X], h ≠ 0 ∧ Cm ^ 2 = vP * vM * h ∧ A = uP * uM * h
+      ∧ B = (uP * vM + uM * vP) * h := by
+  classical
+  have hCm2 : Cm ^ 2 ≠ 0 := pow_ne_zero 2 hCm
+  have hvv : vP * vM ≠ 0 := mul_ne_zero hvp hvm
+  have huu : uP * uM ≠ 0 := mul_ne_zero hup hum
+  have hA : A ≠ 0 := by
+    intro h0
+    rw [h0, mul_zero] at hP
+    exact mul_ne_zero huu hCm2 hP
+  have hkey : ∀ r : K, rootMultiplicity r vP + rootMultiplicity r vM
+      ≤ rootMultiplicity r (Cm ^ 2) := by
+    intro r
+    have hmulP : rootMultiplicity r uP + rootMultiplicity r uM + rootMultiplicity r (Cm ^ 2)
+        = rootMultiplicity r vP + rootMultiplicity r vM + rootMultiplicity r A := by
+      have h := congrArg (rootMultiplicity r) hP
+      rwa [Polynomial.rootMultiplicity_mul (mul_ne_zero huu hCm2),
+        Polynomial.rootMultiplicity_mul huu,
+        Polynomial.rootMultiplicity_mul (mul_ne_zero hvv hA),
+        Polynomial.rootMultiplicity_mul hvv] at h
+    by_cases hvpRoot : vP.IsRoot r
+    · by_cases hvmRoot : vM.IsRoot r
+      · have hupr : rootMultiplicity r uP = 0 :=
+          Polynomial.rootMultiplicity_eq_zero (not_isRoot_left_of_isCoprime hcopP hvpRoot)
+        have humr : rootMultiplicity r uM = 0 :=
+          Polynomial.rootMultiplicity_eq_zero (not_isRoot_left_of_isCoprime hcopM hvmRoot)
+        omega
+      · have hupr : rootMultiplicity r uP = 0 :=
+          Polynomial.rootMultiplicity_eq_zero (not_isRoot_left_of_isCoprime hcopP hvpRoot)
+        have hvmr : rootMultiplicity r vM = 0 := Polynomial.rootMultiplicity_eq_zero hvmRoot
+        by_cases humRoot : uM.IsRoot r
+        · have hsum_eval : (uP * vM + uM * vP).eval r ≠ 0 := by
+            have hvp0 : vP.eval r = 0 := hvpRoot
+            have hup0 : uP.eval r ≠ 0 :=
+              fun h => (not_isRoot_left_of_isCoprime hcopP hvpRoot) h
+            have hvme0 : vM.eval r ≠ 0 := fun h => hvmRoot h
+            rw [eval_add, eval_mul, eval_mul, hvp0, mul_zero, add_zero]
+            exact mul_ne_zero hup0 hvme0
+          have hsum_ne : uP * vM + uM * vP ≠ 0 := by
+            intro h0
+            rw [h0, eval_zero] at hsum_eval
+            exact hsum_eval rfl
+          have hB : B ≠ 0 := by
+            intro h0
+            rw [h0, mul_zero] at hS
+            exact mul_ne_zero hsum_ne hCm2 hS
+          have hmulS : rootMultiplicity r (uP * vM + uM * vP) + rootMultiplicity r (Cm ^ 2)
+              = rootMultiplicity r vP + rootMultiplicity r vM + rootMultiplicity r B := by
+            have h := congrArg (rootMultiplicity r) hS
+            rwa [Polynomial.rootMultiplicity_mul (mul_ne_zero hsum_ne hCm2),
+              Polynomial.rootMultiplicity_mul (mul_ne_zero hvv hB),
+              Polynomial.rootMultiplicity_mul hvv] at h
+          have hsum_rm : rootMultiplicity r (uP * vM + uM * vP) = 0 :=
+            Polynomial.rootMultiplicity_eq_zero (fun h => hsum_eval h)
+          omega
+        · have humr : rootMultiplicity r uM = 0 := Polynomial.rootMultiplicity_eq_zero humRoot
+          omega
+    · have hvpr : rootMultiplicity r vP = 0 := Polynomial.rootMultiplicity_eq_zero hvpRoot
+      by_cases hvmRoot : vM.IsRoot r
+      · have humr : rootMultiplicity r uM = 0 :=
+          Polynomial.rootMultiplicity_eq_zero (not_isRoot_left_of_isCoprime hcopM hvmRoot)
+        by_cases hupRoot : uP.IsRoot r
+        · have hsum_eval : (uP * vM + uM * vP).eval r ≠ 0 := by
+            have hvm0 : vM.eval r = 0 := hvmRoot
+            have hum0 : uM.eval r ≠ 0 :=
+              fun h => (not_isRoot_left_of_isCoprime hcopM hvmRoot) h
+            have hvpe0 : vP.eval r ≠ 0 := fun h => hvpRoot h
+            rw [eval_add, eval_mul, eval_mul, hvm0, mul_zero, zero_add]
+            exact mul_ne_zero hum0 hvpe0
+          have hsum_ne : uP * vM + uM * vP ≠ 0 := by
+            intro h0
+            rw [h0, eval_zero] at hsum_eval
+            exact hsum_eval rfl
+          have hB : B ≠ 0 := by
+            intro h0
+            rw [h0, mul_zero] at hS
+            exact mul_ne_zero hsum_ne hCm2 hS
+          have hmulS : rootMultiplicity r (uP * vM + uM * vP) + rootMultiplicity r (Cm ^ 2)
+              = rootMultiplicity r vP + rootMultiplicity r vM + rootMultiplicity r B := by
+            have h := congrArg (rootMultiplicity r) hS
+            rwa [Polynomial.rootMultiplicity_mul (mul_ne_zero hsum_ne hCm2),
+              Polynomial.rootMultiplicity_mul (mul_ne_zero hvv hB),
+              Polynomial.rootMultiplicity_mul hvv] at h
+          have hsum_rm : rootMultiplicity r (uP * vM + uM * vP) = 0 :=
+            Polynomial.rootMultiplicity_eq_zero (fun h => hsum_eval h)
+          omega
+        · have hupr : rootMultiplicity r uP = 0 := Polynomial.rootMultiplicity_eq_zero hupRoot
+          omega
+      · have hvmr : rootMultiplicity r vM = 0 := Polynomial.rootMultiplicity_eq_zero hvmRoot
+        omega
+  have hdvd : vP * vM ∣ Cm ^ 2 := by
+    rw [IsAlgClosed.dvd_iff_roots_le_roots hvv hCm2, Multiset.le_iff_count]
+    intro a
+    rw [Polynomial.count_roots, Polynomial.count_roots, Polynomial.rootMultiplicity_mul hvv]
+    exact hkey a
+  obtain ⟨h, hh⟩ := hdvd
+  have hhne : h ≠ 0 := by
+    intro h0
+    rw [h0, mul_zero] at hh
+    exact hCm2 hh
+  refine ⟨h, hhne, hh, ?_, ?_⟩
+  · apply mul_left_cancel₀ hvv
+    calc vP * vM * A = uP * uM * Cm ^ 2 := hP.symm
+      _ = uP * uM * (vP * vM * h) := by rw [hh]
+      _ = vP * vM * (uP * uM * h) := by ring
+  · apply mul_left_cancel₀ hvv
+    calc vP * vM * B = (uP * vM + uM * vP) * Cm ^ 2 := hS.symm
+      _ = (uP * vM + uM * vP) * (vP * vM * h) := by rw [hh]
+      _ = vP * vM * ((uP * vM + uM * vP) * h) := by ring
+
+end Poly
+
+section Sym
+
+variable {k : Type*} [Field k] (W : WeierstrassCurve k)
+
+noncomputable def symProd (u v s t : k[X]) : k[X] :=
+  u ^ 2 * s ^ 2 - C W.b₄ * u * s * v * t - C W.b₆ * (u * t + s * v) * v * t
+    - C W.b₈ * v ^ 2 * t ^ 2
+
+noncomputable def symSum (u v s t : k[X]) : k[X] :=
+  C 2 * u * s * (u * t + s * v) + C W.b₂ * u * s * v * t + C W.b₄ * (u * t + s * v) * v * t
+    + C W.b₆ * v ^ 2 * t ^ 2
+
+lemma natDegree_symProd {u v s t : k[X]} (hu : u ≠ 0) (hs : s ≠ 0)
+    (hvu : v.natDegree ≤ u.natDegree) (hts : t.natDegree < s.natDegree) :
+    (symProd W u v s t).natDegree = 2 * (u.natDegree + s.natDegree) := by
+  unfold symProd
+  have h1 : (u ^ 2 * s ^ 2).natDegree = 2 * (u.natDegree + s.natDegree) := by
+    rw [natDegree_mul (pow_ne_zero 2 hu) (pow_ne_zero 2 hs), natDegree_pow, natDegree_pow]
+    ring
+  have h2 : (C W.b₄ * u * s * v * t).natDegree < 2 * (u.natDegree + s.natDegree) := by
+    have e1 : (C W.b₄ * u * s * v * t).natDegree ≤ (C W.b₄ * u * s * v).natDegree + t.natDegree :=
+      natDegree_mul_le
+    have e2 : (C W.b₄ * u * s * v).natDegree ≤ (C W.b₄ * u * s).natDegree + v.natDegree :=
+      natDegree_mul_le
+    have e3 : (C W.b₄ * u * s).natDegree ≤ (C W.b₄ * u).natDegree + s.natDegree :=
+      natDegree_mul_le
+    have e4 : (C W.b₄ * u).natDegree ≤ u.natDegree := natDegree_C_mul_le _ _
+    omega
+  have h3 : (C W.b₆ * (u * t + s * v) * v * t).natDegree < 2 * (u.natDegree + s.natDegree) := by
+    have e1 : (C W.b₆ * (u * t + s * v) * v * t).natDegree
+        ≤ (C W.b₆ * (u * t + s * v) * v).natDegree + t.natDegree := natDegree_mul_le
+    have e2 : (C W.b₆ * (u * t + s * v) * v).natDegree
+        ≤ (C W.b₆ * (u * t + s * v)).natDegree + v.natDegree := natDegree_mul_le
+    have e3 : (C W.b₆ * (u * t + s * v)).natDegree ≤ (u * t + s * v).natDegree :=
+      natDegree_C_mul_le _ _
+    have e5 : (u * t).natDegree ≤ u.natDegree + s.natDegree :=
+      natDegree_mul_le.trans (by omega)
+    have e6 : (s * v).natDegree ≤ u.natDegree + s.natDegree :=
+      natDegree_mul_le.trans (by omega)
+    have e4 : (u * t + s * v).natDegree ≤ u.natDegree + s.natDegree :=
+      natDegree_add_le_of_degree_le e5 e6
+    omega
+  have h4 : (C W.b₈ * v ^ 2 * t ^ 2).natDegree < 2 * (u.natDegree + s.natDegree) := by
+    have e1 : (C W.b₈ * v ^ 2 * t ^ 2).natDegree ≤ (C W.b₈ * v ^ 2).natDegree + (t ^ 2).natDegree :=
+      natDegree_mul_le
+    have e2 : (C W.b₈ * v ^ 2).natDegree ≤ (v ^ 2).natDegree := natDegree_C_mul_le _ _
+    have e3 : (v ^ 2).natDegree ≤ 2 * v.natDegree := natDegree_pow_le
+    have e4 : (t ^ 2).natDegree ≤ 2 * t.natDegree := natDegree_pow_le
+    omega
+  have d1 : (u ^ 2 * s ^ 2 - C W.b₄ * u * s * v * t).natDegree
+      = 2 * (u.natDegree + s.natDegree) := by
+    rw [natDegree_sub_eq_left_of_natDegree_lt (by rw [h1]; exact h2), h1]
+  have d2 : (u ^ 2 * s ^ 2 - C W.b₄ * u * s * v * t - C W.b₆ * (u * t + s * v) * v * t).natDegree
+      = 2 * (u.natDegree + s.natDegree) := by
+    rw [natDegree_sub_eq_left_of_natDegree_lt (by rw [d1]; exact h3), d1]
+  rw [natDegree_sub_eq_left_of_natDegree_lt (by rw [d2]; exact h4), d2]
+
+theorem eval_prod_and_sum [DecidableEq k] {u v s t u₁ v₁ u₂ v₂ : k[X]}
+    {x xa ya xb yb xp yp xm ym : k}
+    {ha : W.toAffine.Nonsingular xa ya} {hb : W.toAffine.Nonsingular xb yb}
+    {hp : W.toAffine.Nonsingular xp yp} {hm : W.toAffine.Nonsingular xm ym}
+    (hadd : Point.some xa ya ha + Point.some xb yb hb = Point.some xp yp hp)
+    (hsub : Point.some xa ya ha - Point.some xb yb hb = Point.some xm ym hm)
+    (hxa : xa * v.eval x = u.eval x) (hxb : xb * t.eval x = s.eval x)
+    (hxp : xp * v₁.eval x = u₁.eval x) (hxm : xm * v₂.eval x = u₂.eval x) :
+    (u₁ * u₂ * (u * t - s * v) ^ 2).eval x = (v₁ * v₂ * symProd W u v s t).eval x ∧
+      ((u₁ * v₂ + u₂ * v₁) * (u * t - s * v) ^ 2).eval x
+        = (v₁ * v₂ * symSum W u v s t).eval x := by
+  obtain ⟨hne, hxp', hxm'⟩ := X_ne_and_eq_addX_of_add_sub hadd hsub
+  have hQp : xp * xm * (xa - xb) ^ 2
+      = (xa * xb) ^ 2 - W.b₄ * (xa * xb) - W.b₆ * (xa + xb) - W.b₈ := by
+    rw [hxp', hxm']
+    exact addX_mul_addX_negY_mul_sq ha.left hb.left hne
+  have hQs : (xp + xm) * (xa - xb) ^ 2
+      = 2 * (xa * xb) * (xa + xb) + W.b₂ * (xa * xb) + W.b₄ * (xa + xb) + W.b₆ := by
+    rw [hxp', hxm']
+    exact addX_add_addX_negY_mul_sq ha.left hb.left hne
+  constructor
+  · simp only [symProd, eval_mul, eval_sub, eval_add, eval_pow, eval_C]
+    rw [← hxa, ← hxb, ← hxp, ← hxm]
+    linear_combination
+      (v₁.eval x * v₂.eval x * (v.eval x) ^ 2 * (t.eval x) ^ 2) * hQp
+  · simp only [symSum, eval_mul, eval_sub, eval_add, eval_pow, eval_C]
+    rw [← hxa, ← hxb, ← hxp, ← hxm]
+    linear_combination
+      (v₁.eval x * v₂.eval x * (v.eval x) ^ 2 * (t.eval x) ^ 2) * hQs
+
+theorem false_of_common_root [W.IsElliptic] {u v s t : k[X]} (huv : IsCoprime u v)
+    (hst : IsCoprime s t) {r : k}
+    (hCr : (u * t - s * v).eval r = 0) (hAr : (symProd W u v s t).eval r = 0)
+    (hBr : (symSum W u v s t).eval r = 0) : False := by
+  rw [eval_sub, eval_mul, eval_mul, sub_eq_zero] at hCr
+  simp only [symProd, eval_mul, eval_sub, eval_add, eval_pow, eval_C] at hAr
+  simp only [symSum, eval_mul, eval_add, eval_pow, eval_C] at hBr
+  by_cases htr : t.eval r = 0
+  · have hsr : s.eval r ≠ 0 := eval_ne_zero_of_isCoprime hst htr
+    have hvr : v.eval r = 0 := by
+      rw [htr, mul_zero] at hCr
+      rcases mul_eq_zero.mp hCr.symm with h' | h'
+      · exact absurd h' hsr
+      · exact h'
+    have hur : u.eval r ≠ 0 := eval_ne_zero_of_isCoprime huv hvr
+    rw [htr, hvr] at hAr
+    have h0 : (u.eval r) ^ 2 * (s.eval r) ^ 2 = 0 := by linear_combination hAr
+    exact mul_ne_zero (pow_ne_zero 2 hur) (pow_ne_zero 2 hsr) h0
+  · by_cases hvr : v.eval r = 0
+    · have hur : u.eval r ≠ 0 := eval_ne_zero_of_isCoprime huv hvr
+      rw [hvr, mul_zero] at hCr
+      exact mul_ne_zero hur htr hCr
+    · obtain ⟨ξ, hU⟩ : ∃ ξ : k, u.eval r = ξ * v.eval r :=
+        ⟨u.eval r / v.eval r, (div_mul_cancel₀ _ hvr).symm⟩
+      have hSx : s.eval r = ξ * t.eval r := by
+        apply mul_right_cancel₀ hvr
+        rw [hU] at hCr
+        linear_combination hCr.symm
+      rw [hU, hSx] at hAr hBr
+      have hVT : v.eval r * t.eval r ≠ 0 := mul_ne_zero hvr htr
+      have hΦ : (ξ ^ 4 - W.b₄ * ξ ^ 2 - 2 * W.b₆ * ξ - W.b₈) * (v.eval r * t.eval r) ^ 2 = 0 := by
+        linear_combination hAr
+      have hΨ : (4 * ξ ^ 3 + W.b₂ * ξ ^ 2 + 2 * W.b₄ * ξ + W.b₆) * (v.eval r * t.eval r) ^ 2
+          = 0 := by
+        linear_combination hBr
+      exact not_common_root_two_torsion W
+        ((mul_eq_zero.mp hΦ).resolve_right (pow_ne_zero 2 hVT))
+        ((mul_eq_zero.mp hΨ).resolve_right (pow_ne_zero 2 hVT))
+
+end Sym
+
+end ParallelogramLaw
+
+open ParallelogramLaw in
+theorem solution {k : Type*} [Field k] [DecidableEq k] [IsAlgClosed k] (W : WeierstrassCurve k)
+  [W.IsElliptic] {S : Set k} (hS : S.Finite) {u v s t u₁ v₁ u₂ v₂ : Polynomial k} (huv : IsCoprime u
+  v) (hst : IsCoprime s t) (huv₁ : IsCoprime u₁ v₁) (huv₂ : IsCoprime u₂ v₂) (hu : u ≠ 0) (hv : v ≠
+  0) (ht : t ≠ 0) (hv₁ : v₁ ≠ 0) (hv₂ : v₂ ≠ 0) (hvu : v.natDegree ≤ u.natDegree) (hts : t.natDegree
+  < s.natDegree) (H : ∀ x : k, x ∉ S → ∃ (xa ya xb yb xp yp xm ym : k) (ha : W.toAffine.Nonsingular
+  xa ya) (hb : W.toAffine.Nonsingular xb yb) (hp : W.toAffine.Nonsingular xp yp) (hm :
+  W.toAffine.Nonsingular xm ym), Point.some xa ya ha + Point.some xb yb hb = Point.some xp yp hp ∧
+  Point.some xa ya ha - Point.some xb yb hb = Point.some xm ym hm ∧ xa * v.eval x = u.eval x ∧ xb *
+  t.eval x = s.eval x ∧ xp * v₁.eval x = u₁.eval x ∧ xm * v₂.eval x = u₂.eval x) :
+    u₁ ≠ 0 ∧ u₂ ≠ 0 ∧ u₁.natDegree + u₂.natDegree = 2 * (u.natDegree + s.natDegree) ∧ v₁.natDegree +
+      v₂.natDegree = 2 * (u * t - s * v).natDegree := by
+  obtain ⟨-, -⟩ : v ≠ 0 ∧ t ≠ 0 := ⟨hv, ht⟩
+  clear hv ht
+  have hs : s ≠ 0 := by
+    rintro rfl
+    rw [natDegree_zero] at hts
+    exact Nat.not_lt_zero _ hts
+  have hP : u₁ * u₂ * (u * t - s * v) ^ 2 = v₁ * v₂ * symProd W u v s t := by
+    apply Polynomial.eq_of_infinite_eval_eq
+    refine Set.Infinite.mono ?_ hS.infinite_compl
+    intro x hx
+    rw [Set.mem_compl_iff] at hx
+    obtain ⟨xa, ya, xb, yb, xp, yp, xm, ym, ha, hb, hp, hm, hadd, hsub, hxa, hxb, hxp, hxm⟩ :=
+      H x hx
+    exact (eval_prod_and_sum W hadd hsub hxa hxb hxp hxm).1
+  have hSum : (u₁ * v₂ + u₂ * v₁) * (u * t - s * v) ^ 2 = v₁ * v₂ * symSum W u v s t := by
+    apply Polynomial.eq_of_infinite_eval_eq
+    refine Set.Infinite.mono ?_ hS.infinite_compl
+    intro x hx
+    rw [Set.mem_compl_iff] at hx
+    obtain ⟨xa, ya, xb, yb, xp, yp, xm, ym, ha, hb, hp, hm, hadd, hsub, hxa, hxb, hxp, hxm⟩ :=
+      H x hx
+    exact (eval_prod_and_sum W hadd hsub hxa hxb hxp hxm).2
+  have hAdeg : (symProd W u v s t).natDegree = 2 * (u.natDegree + s.natDegree) :=
+    natDegree_symProd W hu hs hvu hts
+  have hAne : symProd W u v s t ≠ 0 := by
+    intro h0
+    rw [h0, natDegree_zero] at hAdeg
+    omega
+  have hvv : v₁ * v₂ ≠ 0 := mul_ne_zero hv₁ hv₂
+  have hu₁ : u₁ ≠ 0 := by
+    intro h0
+    rw [h0, zero_mul, zero_mul] at hP
+    exact mul_ne_zero hvv hAne hP.symm
+  have hu₂ : u₂ ≠ 0 := by
+    intro h0
+    rw [h0, mul_zero, zero_mul] at hP
+    exact mul_ne_zero hvv hAne hP.symm
+  have hCm : u * t - s * v ≠ 0 := by
+    intro h0
+    rw [h0, zero_pow two_ne_zero, mul_zero] at hP
+    exact mul_ne_zero hvv hAne hP.symm
+  obtain ⟨g, hgne, hCC, hAA, hBB⟩ :=
+    exists_common_cofactor huv₁ huv₂ hu₁ hu₂ hv₁ hv₂ hCm hP hSum
+  have hgdeg : g.natDegree = 0 := by
+    by_contra hne
+    obtain ⟨r, hr⟩ := IsAlgClosed.exists_root g
+      ((Polynomial.natDegree_pos_iff_degree_pos.mp (Nat.pos_of_ne_zero hne)).ne')
+    have hr0 : g.eval r = 0 := hr
+    have hCr : (u * t - s * v).eval r = 0 := by
+      have h1 : ((u * t - s * v) ^ 2).eval r = 0 := by rw [hCC, eval_mul, hr0, mul_zero]
+      rw [eval_pow] at h1
+      exact pow_eq_zero_iff two_ne_zero |>.mp h1
+    have hAr : (symProd W u v s t).eval r = 0 := by rw [hAA, eval_mul, hr0, mul_zero]
+    have hBr : (symSum W u v s t).eval r = 0 := by rw [hBB, eval_mul, hr0, mul_zero]
+    exact false_of_common_root W huv hst hCr hAr hBr
+  refine ⟨hu₁, hu₂, ?_, ?_⟩
+  · have e := congrArg Polynomial.natDegree hAA
+    rw [hAdeg, natDegree_mul (mul_ne_zero hu₁ hu₂) hgne, natDegree_mul hu₁ hu₂, hgdeg] at e
+    omega
+  · have e := congrArg Polynomial.natDegree hCC
+    rw [natDegree_pow, natDegree_mul hvv hgne, natDegree_mul hv₁ hv₂, hgdeg] at e
+    omega
+
+end S_WeierstrassCurve_Affine_Point_natDegree_parallelogram_law
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_Point_natDegree_parallelogram_law (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+theorem WeierstrassCurve.Affine.Point.natDegree_parallelogram_law {k : Type*} [Field k] [DecidableEq
+  k] [IsAlgClosed k] (W : WeierstrassCurve k) [W.IsElliptic] {S : Set k} (hS : S.Finite) {u v s t u₁
+  v₁ u₂ v₂ : Polynomial k} (huv : IsCoprime u v) (hst : IsCoprime s t) (huv₁ : IsCoprime u₁ v₁)
+  (huv₂ : IsCoprime u₂ v₂) (hu : u ≠ 0) (hv : v ≠ 0) (ht : t ≠ 0) (hv₁ : v₁ ≠ 0) (hv₂ : v₂ ≠ 0) (hvu
+  : v.natDegree ≤ u.natDegree) (hts : t.natDegree < s.natDegree) (H : ∀ x : k, x ∉ S → ∃ (xa ya xb
+  yb xp yp xm ym : k) (ha : W.toAffine.Nonsingular xa ya) (hb : W.toAffine.Nonsingular xb yb) (hp :
+  W.toAffine.Nonsingular xp yp) (hm : W.toAffine.Nonsingular xm ym), Point.some xa ya ha +
+  Point.some xb yb hb = Point.some xp yp hp ∧ Point.some xa ya ha - Point.some xb yb hb = Point.some
+  xm ym hm ∧ xa * v.eval x = u.eval x ∧ xb * t.eval x = s.eval x ∧ xp * v₁.eval x = u₁.eval x ∧ xm *
+  v₂.eval x = u₂.eval x) :
+    u₁ ≠ 0 ∧ u₂ ≠ 0 ∧ u₁.natDegree + u₂.natDegree = 2 * (u.natDegree + s.natDegree) ∧ v₁.natDegree +
+      v₂.natDegree = 2 * (u * t - s * v).natDegree :=
+  solution W hS huv hst huv₁ huv₂ hu hv ht hv₁ hv₂ hvu hts H
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_smul_some_eq_zero_iff.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_smul_some_eq_zero_iff.lean
new file mode 100644
index 0000000000..3f7338cf81
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_smul_some_eq_zero_iff.lean
@@ -0,0 +1,95 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.Point.smul_some_eq_zero_iff
+(e530f3fb-5431-5292-ae33-fcf0cdb4287f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a15b7fc5-6b1f-5e03-ad93-03383906d5b5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+
+import Mathlib.NumberTheory.EllipticDivisibilitySequence
+import Mathlib.Algebra.Ring.NegOnePow
+import Mathlib.Data.Fin.VecNotation
+import Mathlib.Data.Fin.Tuple.Sort
+import Mathlib.Algebra.GroupWithZero.NonZeroDivisors
+import Mathlib.Algebra.MvPolynomial.CommRing
+import Mathlib.Algebra.MvPolynomial.Basic
+import Mathlib.Tactic.LinearCombination
+import Mathlib.Tactic.Ring
+import Mathlib.Tactic.Abel
+import Mathlib.Tactic.IntervalCases
+import Mathlib.Tactic.FieldSimp
+import Mathlib.GroupTheory.Perm.Basic
+import Mathlib.GroupTheory.Perm.Sign
+import Mathlib.Algebra.Polynomial.Bivariate
+import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+import Mathlib.AlgebraicGeometry.EllipticCurve.Jacobian.Point
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_EDSEngine
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# nP=O if and only if ψₙ(P)=0
+
+Theorem statement: `WeierstrassCurve.Affine.Point.smul_some_eq_zero_iff`
+(`e530f3fb-5431-5292-ae33-fcf0cdb4287f`), by Claude, 2026-09-05.
+
+Proof: submission `a15b7fc5-6b1f-5e03-ad93-03383906d5b5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field and let $W$ be a Weierstrass curve over $F$, given by its five coefficients and
+not assumed to be nonsingular as a curve. Let $x,y \in F$ satisfy `W.toAffine.Nonsingular x y`, i.e.
+$(x,y)$ lies on the affine Weierstrass equation of $W$ and is a nonsingular point of it, so that it
+determines an element `WeierstrassCurve.Affine.Point.some x y h` of the group `W.toAffine.Point` of
+affine points of $W$, whose zero element is the point at infinity. Let $n$ be an arbitrary integer.
+The assertion is that the $n$-fold multiple $n \cdot (x,y)$ of this point, formed in the group of
+points, equals the point at infinity if and only if the $n$-th division polynomial $\psi_n$ of $W$,
+a bivariate polynomial over $F$ in the variables conventionally written $X$ and $Y$, vanishes when
+$X$ is evaluated at $x$ and $Y$ at $y$. No restriction is placed on the characteristic of $F$, on
+$n$ (negative and zero values included), or on the discriminant of $W$.
+
+This is the standard characterisation of the $n$-torsion of a Weierstrass curve as the zero locus of
+the $n$-th division polynomial, in the form convenient for computing with explicit points. It is the
+basic bridge between the group law and division-polynomial algebra used throughout the study of
+Frobenius endomorphisms and of torsion subschemes, for instance in the computations of degrees of
+kernels of Frobenius-type endomorphisms and in comparisons of Galois actions on torsion.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_Point_smul_some_eq_zero_iff.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_Point_smul_some_eq_zero_iff
+
+theorem solution {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+    {x y : F} (h : W.toAffine.Nonsingular x y) (n : ℤ) :
+    n • (WeierstrassCurve.Affine.Point.some x y h) = 0 ↔ (W.ψ n).evalEval x y = 0 :=
+  W.smul_eq_zero_iff_evalEval_ψ h n
+
+end S_WeierstrassCurve_Affine_Point_smul_some_eq_zero_iff
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_Point_smul_some_eq_zero_iff (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.Affine.Point.smul_some_eq_zero_iff
+    {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+    {x y : F} (h : W.toAffine.Nonsingular x y) (n : ℤ) :
+    n • (WeierstrassCurve.Affine.Point.some x y h) = 0 ↔ (W.ψ n).evalEval x y = 0 :=
+  solution W h n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_some_add_some_eq_neg_some_of_pow_three_eq_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_some_add_some_eq_neg_some_of_pow_three_eq_one.lean
new file mode 100644
index 0000000000..036417cf8d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_some_add_some_eq_neg_some_of_pow_three_eq_one.lean
@@ -0,0 +1,122 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.Point.some_add_some_eq_neg_some_of_pow_three_eq_one
+(e940c092-8bae-5df8-a824-04ad1216a8fb) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 628d508c-e808-5190-abbe-572d179fd07d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Collinear points (x,y),(ω x,y),(ω² x,y) on y²=x³+B
+
+Theorem statement: `WeierstrassCurve.Affine.Point.some_add_some_eq_neg_some_of_pow_three_eq_one`
+(`e940c092-8bae-5df8-a824-04ad1216a8fb`), by Claude, 2026-09-05.
+
+Proof: submission `628d508c-e808-5190-abbe-572d179fd07d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $k$ be a field with decidable equality, let $B,\omega \in k$, and consider the Weierstrass curve
+over $k$ with coefficients $a_1=a_2=a_3=a_4=0$ and $a_6=B$, i.e. $y^2 = x^3 + B$, viewed in its
+affine model. Assume $\omega^3 = 1$ and $\omega \neq 1$, so that $\omega$ is a primitive cube root
+of unity. Let $x,y \in k$ and assume that each of the three pairs $(x,y)$, $(\omega x, y)$ and
+$(\omega^2 x, y)$ satisfies Mathlib's `Nonsingular` predicate for this affine curve (lying on the
+curve, with the two partial derivatives of the Weierstrass polynomial not both vanishing), and
+assume $x \neq 0$. Then, in the group of affine points of the curve, the sum of the points $(x,y)$
+and $(\omega x, y)$ equals the negative of the point $(\omega^2 x, y)$; equivalently, the three
+points add up to the point at infinity. The three nonsingularity hypotheses are taken as separate
+assumptions, although the second and third are consequences of the first.
+
+This is the statement that the horizontal line $Y = y$ cuts the curve $y^2 = x^3 + B$ in the three
+points whose $x$-coordinates are $x$, $\omega x$, $\omega^2 x$, and that three collinear points sum
+to zero; in endomorphism terms it is the relation $1 + [\omega] + [\omega^2] = 0$ for the
+order-three automorphism $(x,y) \mapsto (\omega x, y)$ of a curve with $j = 0$. It is used in the
+analysis of the three-torsion and of the automorphism of order three on such curves, in
+[`WeierstrassCurve.exists_j_eq_zero_torsion_basis_heq_vcInvFun_of_order_three`]
+(thm.html#WeierstrassCurve.exists_j_eq_zero_torsion_basis_heq_vcInvFun_of_order_three)
+and in the two counting statements
+[`WeierstrassCurve.natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuThree`]
+(thm.html#WeierstrassCurve.natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuThree)
+and its variant for nonzero argument.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_Point_some_add_some_eq_neg_some_of_pow_three_eq_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_Point_some_add_some_eq_neg_some_of_pow_three_eq_one
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+theorem ws13_some_congr {k : Type*} [Field k] {V : Affine k} {x₁ x₂ y₁ y₂ : k}
+    {h₁ : V.Nonsingular x₁ y₁} {h₂ : V.Nonsingular x₂ y₂} (hx : x₁ = x₂) (hy : y₁ = y₂) :
+    (Point.some x₁ y₁ h₁ : V.Point) = Point.some x₂ y₂ h₂ := by
+  subst hx; subst hy; rfl
+
+theorem solution
+    {k : Type*} [Field k] [DecidableEq k] (B w : k) (hw : w ^ 3 = 1) (hw1 : w ≠ 1) {x y : k}
+    (h : (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve k).toAffine.Nonsingular x y)
+    (hwx : (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve k).toAffine.Nonsingular (w * x) y)
+    (hw2x : (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve k).toAffine.Nonsingular (w ^ 2 * x) y) (hx : x ≠ 0)
+    :
+    (WeierstrassCurve.Affine.Point.some x y h : (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve
+      k).toAffine.Point)
+      + WeierstrassCurve.Affine.Point.some (w * x) y hwx
+      = -(WeierstrassCurve.Affine.Point.some (w ^ 2 * x) y hw2x) := by
+  have hsum : 1 + w + w ^ 2 = 0 := by
+    have h0 : (w - 1) * (1 + w + w ^ 2) = 0 := by linear_combination hw
+    rcases mul_eq_zero.mp h0 with h1 | h1
+    · exact absurd (sub_eq_zero.mp h1) hw1
+    · exact h1
+  have hxne : x ≠ w * x := by
+    intro heq
+    have h0 : (1 - w) * x = 0 := by linear_combination heq
+    rcases mul_eq_zero.mp h0 with h1 | h1
+    · exact hw1 (by linear_combination -h1)
+    · exact hx h1
+  rw [Point.add_of_X_ne hxne, Point.neg_some]
+  refine ws13_some_congr ?_ ?_
+  · rw [slope_of_X_ne hxne, sub_self, zero_div]
+    simp only [Affine.addX]
+    linear_combination -x * hsum
+  · rw [slope_of_X_ne hxne, sub_self, zero_div]
+    simp only [Affine.addY, Affine.negY, Affine.negAddY, Affine.addX]
+    ring
+
+end S_WeierstrassCurve_Affine_Point_some_add_some_eq_neg_some_of_pow_three_eq_one
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_Point_some_add_some_eq_neg_some_of_pow_three_eq_one (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.Affine.Point.some_add_some_eq_neg_some_of_pow_three_eq_one
+    {k : Type*} [Field k] [DecidableEq k] (B w : k) (hw : w ^ 3 = 1) (hw1 : w ≠ 1) {x y : k}
+    (h : (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve k).toAffine.Nonsingular x y)
+    (hwx : (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve k).toAffine.Nonsingular (w * x) y)
+    (hw2x : (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve k).toAffine.Nonsingular (w ^ 2 * x) y) (hx : x ≠ 0)
+    :
+    (WeierstrassCurve.Affine.Point.some x y h : (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve
+      k).toAffine.Point)
+      + WeierstrassCurve.Affine.Point.some (w * x) y hwx
+      = -(WeierstrassCurve.Affine.Point.some (w ^ 2 * x) y hw2x) :=
+  solution B w hw hw1 h hwx hw2x hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_some_zero_add_self_eq_neg_of_a6_model.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_some_zero_add_self_eq_neg_of_a6_model.lean
new file mode 100644
index 0000000000..e7edc4b0a0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_some_zero_add_self_eq_neg_of_a6_model.lean
@@ -0,0 +1,110 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.Point.some_zero_add_self_eq_neg_of_a6_model
+(d439f6e7-8f94-5d50-843c-e6b0444e5bf0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8bc78b3a-8f54-5ff0-add9-07be06f2f223
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The points (0,y) on y²=x³+B are flexes
+
+Theorem statement: `WeierstrassCurve.Affine.Point.some_zero_add_self_eq_neg_of_a6_model`
+(`d439f6e7-8f94-5d50-843c-e6b0444e5bf0`), by Claude, 2026-09-05.
+
+Proof: submission `8bc78b3a-8f54-5ff0-add9-07be06f2f223`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $k$ be a field with decidable equality, let $B \in k$, and assume $2 \neq 0$ in $k$. Let $y \in
+k$ be nonzero, and suppose $(0,y)$ is a nonsingular point of the affine Weierstrass curve with
+coefficients $a_1 = a_2 = a_3 = a_4 = 0$ and $a_6 = B$, i.e. of $y^2 = x^3 + B$; here `Nonsingular`
+means that the Weierstrass equation holds at $(0,y)$ and that the two partial derivatives of the
+defining polynomial do not both vanish there. Writing $P$ for the corresponding element `Point.some
+0 y h` of the group of points of this affine curve (rational points together with the point at
+infinity), the assertion is $P + P = -P$ in that group. Equivalently, $P$ is a point of order
+dividing three, although the statement is phrased purely as the displayed identity between the
+double of $P$ and the negative of $P$, not as a torsion statement.
+
+This is the classical fact that the points with $x = 0$ on a curve $y^2 = x^3 + B$ are inflection
+points, hence three-torsion: the tangent there is horizontal and meets the curve at the same point
+again. It is used in the analysis of the three-torsion and of the action of the cube-root-of-unity
+automorphism on curves with $j = 0$, in particular by
+[`WeierstrassCurve.exists_j_eq_zero_torsion_basis_heq_vcInvFun_of_order_three`]
+(thm.html#WeierstrassCurve.exists_j_eq_zero_torsion_basis_heq_vcInvFun_of_order_three)
+and the two counting statements
+[`WeierstrassCurve.natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuThree`]
+(thm.html#WeierstrassCurve.natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuThree)
+and its variant.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_Point_some_zero_add_self_eq_neg_of_a6_model.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_Point_some_zero_add_self_eq_neg_of_a6_model
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+theorem ws13_some_congr' {k : Type*} [Field k] {V : Affine k} {x₁ x₂ y₁ y₂ : k}
+    {h₁ : V.Nonsingular x₁ y₁} {h₂ : V.Nonsingular x₂ y₂} (hx : x₁ = x₂) (hy : y₁ = y₂) :
+    (Point.some x₁ y₁ h₁ : V.Point) = Point.some x₂ y₂ h₂ := by
+  subst hx; subst hy; rfl
+
+theorem solution
+    {k : Type*} [Field k] [DecidableEq k] (B : k) (h2 : (2 : k) ≠ 0) {y : k} (hy0 : y ≠ 0)
+    (h : (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve k).toAffine.Nonsingular 0 y) :
+    (WeierstrassCurve.Affine.Point.some 0 y h : (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve
+      k).toAffine.Point)
+      + WeierstrassCurve.Affine.Point.some 0 y h
+      = -(WeierstrassCurve.Affine.Point.some 0 y h) := by
+  have hyne : y ≠ Affine.negY (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve k) 0 y := by
+    simp only [Affine.negY]
+    intro heq
+    have : (2 : k) * y = 0 := by linear_combination heq
+    rcases mul_eq_zero.mp this with h' | h'
+    · exact h2 h'
+    · exact hy0 h'
+  rw [Point.add_of_Y_ne hyne, Point.neg_some]
+  refine ws13_some_congr' ?_ ?_
+  · rw [slope_of_Y_ne rfl hyne]
+    simp only [Affine.addX, Affine.negY]
+    ring
+  · rw [slope_of_Y_ne rfl hyne]
+    simp only [Affine.addY, Affine.negY, Affine.negAddY, Affine.addX]
+    ring
+
+end S_WeierstrassCurve_Affine_Point_some_zero_add_self_eq_neg_of_a6_model
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_Point_some_zero_add_self_eq_neg_of_a6_model (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.Affine.Point.some_zero_add_self_eq_neg_of_a6_model
+    {k : Type*} [Field k] [DecidableEq k] (B : k) (h2 : (2 : k) ≠ 0) {y : k} (hy0 : y ≠ 0)
+    (h : (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve k).toAffine.Nonsingular 0 y) :
+    (WeierstrassCurve.Affine.Point.some 0 y h : (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve
+      k).toAffine.Point)
+      + WeierstrassCurve.Affine.Point.some 0 y h
+      = -(WeierstrassCurve.Affine.Point.some 0 y h) :=
+  solution B h2 hy0 h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_two_smul_some_eq_zero_iff.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_two_smul_some_eq_zero_iff.lean
new file mode 100644
index 0000000000..21a89c05c5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_two_smul_some_eq_zero_iff.lean
@@ -0,0 +1,115 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.Point.two_smul_some_eq_zero_iff
+(4a97bf48-6b69-52ce-8cff-90d549d4705d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 306e4823-bb30-571b-a36e-e18c09453a24
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+
+import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+import Mathlib.Tactic.LinearCombination
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# 2P=O iff x is a root of Ψ₂²
+
+Theorem statement: `WeierstrassCurve.Affine.Point.two_smul_some_eq_zero_iff`
+(`4a97bf48-6b69-52ce-8cff-90d549d4705d`), by Claude, 2026-09-05.
+
+Proof: submission `306e4823-bb30-571b-a36e-e18c09453a24`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field and let $W$ be a Weierstrass curve over $F$, given by coefficients
+$a_1,a_2,a_3,a_4,a_6$. Let $x,y \in F$ and suppose $h$ witnesses that $(x,y)$ is a nonsingular point
+of the affine Weierstrass model $W$, i.e. that the Weierstrass equation holds at $(x,y)$ and that
+the two partial derivatives of the equation do not both vanish there. Writing $P$ for the
+corresponding point `WeierstrassCurve.Affine.Point.some x y h` in the group of points of the affine
+model, with identity the point at infinity $0$, the assertion is the equivalence
+$$2 \cdot P = 0 \iff \Psi_2^2(x) = 0,$$
+where $\Psi_2^2$ is the Mathlib polynomial `WeierstrassCurve.Ψ₂Sq` attached to $W$, namely $4X^3 +
+b_2X^2 + 2b_4X + b_6$ in terms of the usual quantities $b_2 = a_1^2 + 4a_2$, $b_4 = 2a_4 + a_1a_3$,
+$b_6 = a_3^2 + 4a_6$, and $\Psi_2^2(x)$ denotes its evaluation at $x$. No restriction on the
+characteristic of $F$ is imposed, and $W$ is not assumed to be elliptic (no invertibility of the
+discriminant is required).
+
+This is the standard characterisation of the nontrivial $2$-torsion points of a Weierstrass curve as
+the affine points whose $x$-coordinate is a root of the $2$-division polynomial. It is used
+throughout the torsion-theoretic parts of the development, for instance in the analysis of
+$2$-torsion on moduli points and in computations with torsion point rings.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_Point_two_smul_some_eq_zero_iff.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_Point_two_smul_some_eq_zero_iff
+
+open Polynomial
+
+theorem PortCard.sub_negY_sq_eq_eval_Ψ₂Sq {R : Type*} [CommRing R] (W : WeierstrassCurve R)
+    {x y : R} (e : W.toAffine.Equation x y) :
+    (y - W.toAffine.negY x y) ^ 2 = W.Ψ₂Sq.eval x := by
+  rw [WeierstrassCurve.Affine.equation_iff] at e
+  simp only [WeierstrassCurve.Affine.negY, WeierstrassCurve.Ψ₂Sq, WeierstrassCurve.b₂,
+    WeierstrassCurve.b₄, WeierstrassCurve.b₆, eval_add, eval_mul, eval_pow, eval_C, eval_X]
+  linear_combination 4 * e
+
+theorem PortCard.two_smul_some_eq_zero_iff {F : Type*} [Field F] [DecidableEq F]
+    (W : WeierstrassCurve F) {x y : F} (h : W.toAffine.Nonsingular x y) :
+    2 • WeierstrassCurve.Affine.Point.some x y h = 0 ↔ W.Ψ₂Sq.eval x = 0 := by
+  have key : 2 • WeierstrassCurve.Affine.Point.some x y h = 0 ↔ y = W.toAffine.negY x y := by
+    rw [two_nsmul, add_eq_zero_iff_eq_neg, WeierstrassCurve.Affine.Point.neg_some,
+      WeierstrassCurve.Affine.Point.some.injEq]
+    simp
+  rw [key, ← PortCard.sub_negY_sq_eq_eval_Ψ₂Sq W h.left, pow_eq_zero_iff two_ne_zero, sub_eq_zero]
+
+theorem PortCard.Ψ₂Sq_ne_zero_of_isElliptic {F : Type*} [Field F] (W : WeierstrassCurve F)
+    [W.IsElliptic] : W.Ψ₂Sq ≠ 0 := by
+  intro h0
+  rw [WeierstrassCurve.Ψ₂Sq_eq, Cubic.toPoly_eq_zero_iff] at h0
+  have h4 : (4 : F) = 0 := congrArg Cubic.a h0
+  have hb₂ : W.b₂ = 0 := congrArg Cubic.b h0
+  have hb₆ : W.b₆ = 0 := congrArg Cubic.d h0
+  have h2 : (2 : F) = 0 := by
+    have h22 : (2 : F) * 2 = 0 := by linear_combination h4
+    rcases mul_eq_zero.mp h22 with h | h <;> exact h
+  have hΔ : W.Δ = 0 := by
+    rw [show W.Δ = -W.b₂ ^ 2 * W.b₈ - 8 * W.b₄ ^ 3 - 27 * W.b₆ ^ 2 + 9 * W.b₂ * W.b₄ * W.b₆
+      from rfl]
+    linear_combination (-W.b₂ * W.b₈ + 9 * W.b₄ * W.b₆) * hb₂ + (-27 * W.b₆) * hb₆ +
+      (-4 * W.b₄ ^ 3) * h2
+  exact W.isUnit_Δ.ne_zero hΔ
+
+theorem solution {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F) {x y : F}
+    (h : W.toAffine.Nonsingular x y) :
+    2 • WeierstrassCurve.Affine.Point.some x y h = 0 ↔ W.Ψ₂Sq.eval x = 0 :=
+  PortCard.two_smul_some_eq_zero_iff W h
+
+end S_WeierstrassCurve_Affine_Point_two_smul_some_eq_zero_iff
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_Point_two_smul_some_eq_zero_iff (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.Affine.Point.two_smul_some_eq_zero_iff {F : Type*} [Field F]
+    [DecidableEq F] (W : WeierstrassCurve F) {x y : F} (h : W.toAffine.Nonsingular x y) :
+    2 • WeierstrassCurve.Affine.Point.some x y h = 0 ↔ W.Ψ₂Sq.eval x = 0 :=
+  solution W h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_vcInvFun_add.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_vcInvFun_add.lean
new file mode 100644
index 0000000000..4db93ed746
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_vcInvFun_add.lean
@@ -0,0 +1,265 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.Point.vcInvFun_add
+(4ddad617-8257-58a8-be57-9d8de3fa1d43) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8622b831-aaa8-55ed-a946-76a535fd5d90
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VariableChangePointEquiv
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Additivity of the variable-change map on points
+
+Theorem statement: `WeierstrassCurve.Affine.Point.vcInvFun_add`
+(`4ddad617-8257-58a8-be57-9d8de3fa1d43`), by Claude, 2026-09-05.
+
+Proof: submission `8622b831-aaa8-55ed-a946-76a535fd5d90`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field and let $C$ be a variable change of Weierstrass data over $K$, that is, a
+quadruple $(u,r,s,t)$ with $u \in K^\times$ and $r,s,t \in K$, and let $W$ be a Weierstrass curve
+over $K$ in affine form. The map [`WeierstrassCurve.Affine.Point.vcInvFun C
+W`](def/WeierstrassCurve_VariableChangePointEquiv.html#L119) sends the points of $W$ to the points
+of the transformed curve $C \bullet W$: the point at infinity goes to the point at infinity, and an
+affine point $(x,y)$ satisfying the nonsingularity condition for $W$ goes to the affine point with
+coordinates $u^{-2}(x-r)$ and $u^{-3}\bigl(y-t-s(x-r)\bigr)$, which satisfies the nonsingularity
+condition for $C \bullet W$. The assertion is that for all points $P$ and $Q$ of $W$ this map
+respects the chord–tangent addition, $$\mathrm{vcInvFun}(P+Q) = \mathrm{vcInvFun}(P) +
+\mathrm{vcInvFun}(Q),$$ the left-hand sum being formed in the group of points of $W$ and the
+right-hand one in the group of points of $C \bullet W$.
+
+This is the statement that an admissible change of Weierstrass coordinates induces a homomorphism,
+and hence with bijectivity an isomorphism, between the groups of points of the two models; the group
+law is thus intrinsic to the curve rather than to the chosen equation. It is used throughout to
+transport points, subgroups, torsion and level structures along changes of model, for instance when
+passing to a good model over a local base or to a special fibre.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_Point_vcInvFun_add.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_Point_vcInvFun_add
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine a₃ a₁ map variableChange_a₃ a₄ a₂ variableChange_a₂ toAffine \
+  Affine.Point variableChange_a₁ variableChange_a₄ VariableChange Affine.Point.vcInvFun"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY slope_of_X_ne slope map Point.some Nonsingular \
+  negAddY slope_of_Y_ne Point addX addY Y_eq_of_X_eq vcX vcY Point.vcInvFun"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+variable {K : Type*} [Field K]
+
+section Formulas
+
+variable (C : VariableChange K) (W : WeierstrassCurve.Affine K)
+
+variable {C W}
+
+theorem vcAdd_u_ne_zero : (C.u : K) ≠ 0 := C.u.ne_zero
+
+theorem vcX_injective : Function.Injective (vcX C) := by
+  intro a b h
+  have hu : (C.u : K) ≠ 0 := vcAdd_u_ne_zero
+  simp only [vcX] at h
+  have : (C.u : K) ^ 2 * a = (C.u : K) ^ 2 * b := by linear_combination h
+  exact mul_left_cancel₀ (pow_ne_zero 2 hu) this
+
+theorem vcY_injective (x' : K) : Function.Injective (vcY C x') := by
+  intro a b h
+  have hu : (C.u : K) ≠ 0 := vcAdd_u_ne_zero
+  simp only [vcY] at h
+  have : (C.u : K) ^ 3 * a = (C.u : K) ^ 3 * b := by linear_combination h
+  exact mul_left_cancel₀ (pow_ne_zero 3 hu) this
+
+theorem vcAdd_partialX_aux (x' y' : K) :
+    W.a₁ * vcY C x' y' - (3 * vcX C x' ^ 2 + 2 * W.a₂ * vcX C x' + W.a₄)
+      + C.s * (2 * vcY C x' y' + W.a₁ * vcX C x' + W.a₃)
+    = (C.u : K) ^ 4 *
+      ((C • W).a₁ * y' - (3 * x' ^ 2 + 2 * (C • W).a₂ * x' + (C • W).a₄)) := by
+  have hu : (C.u : K) ≠ 0 := vcAdd_u_ne_zero
+  simp only [vcX, vcY, variableChange_a₁, variableChange_a₂, variableChange_a₄,
+    Units.val_inv_eq_inv_val]
+  field_simp; ring
+
+theorem vcAdd_partialY_aux (x' y' : K) :
+    2 * vcY C x' y' + W.a₁ * vcX C x' + W.a₃
+      = (C.u : K) ^ 3 * (2 * y' + (C • W).a₁ * x' + (C • W).a₃) := by
+  have hu : (C.u : K) ≠ 0 := vcAdd_u_ne_zero
+  simp only [vcX, vcY, variableChange_a₁, variableChange_a₃, Units.val_inv_eq_inv_val]
+  field_simp; ring
+
+theorem negY_variableChange (x' y' : K) :
+    W.negY (vcX C x') (vcY C x' y') = vcY C x' ((C • W).toAffine.negY x' y') := by
+  have hu : (C.u : K) ≠ 0 := vcAdd_u_ne_zero
+  simp only [negY, vcX, vcY, variableChange_a₁, variableChange_a₃, Units.val_inv_eq_inv_val]
+  field_simp
+  ring
+
+theorem Yeq_variableChange_iff (x₁' x₂' y₁' y₂' : K) :
+    (vcX C x₁' = vcX C x₂' ∧ vcY C x₁' y₁' = W.negY (vcX C x₂') (vcY C x₂' y₂'))
+      ↔ (x₁' = x₂' ∧ y₁' = (C • W).toAffine.negY x₂' y₂') := by
+  constructor
+  · rintro ⟨hx, hy⟩
+    have hx' : x₁' = x₂' := vcX_injective hx
+    subst hx'
+    refine ⟨rfl, ?_⟩
+    rw [negY_variableChange x₁' y₂'] at hy
+    exact vcY_injective x₁' hy
+  · rintro ⟨hx, hy⟩
+    subst hx
+    exact ⟨rfl, by rw [negY_variableChange x₁' y₂', hy]⟩
+
+theorem slope_variableChange [DecidableEq K] (x₁' x₂' y₁' y₂' : K)
+    (h₁ : (C • W).toAffine.Equation x₁' y₁') (h₂ : (C • W).toAffine.Equation x₂' y₂')
+    (hxy : ¬(x₁' = x₂' ∧ y₁' = (C • W).toAffine.negY x₂' y₂')) :
+    W.slope (vcX C x₁') (vcX C x₂') (vcY C x₁' y₁') (vcY C x₂' y₂')
+      = (C.u : K) * (C • W).toAffine.slope x₁' x₂' y₁' y₂' + C.s := by
+  have hu : (C.u : K) ≠ 0 := vcAdd_u_ne_zero
+  by_cases hx : x₁' = x₂'
+  · have hy : y₁' ≠ (C • W).toAffine.negY x₂' y₂' := fun h => hxy ⟨hx, h⟩
+    have hyy : y₁' = y₂' := (Y_eq_of_X_eq h₁ h₂ hx).resolve_right hy
+    subst hx
+    subst hyy
+    have hyW : vcY C x₁' y₁' ≠ W.negY (vcX C x₁') (vcY C x₁' y₁') := by
+      intro h
+      exact hy ((Yeq_variableChange_iff x₁' x₁' y₁' y₁').mp ⟨rfl, h⟩).2
+    rw [slope_of_Y_ne rfl hyW, slope_of_Y_ne rfl hy]
+    have hd : vcY C x₁' y₁' - W.negY (vcX C x₁') (vcY C x₁' y₁')
+        = (C.u : K) ^ 3 * (y₁' - (C • W).toAffine.negY x₁' y₁') := by
+      rw [negY_variableChange x₁' y₁']
+      simp only [vcY]
+      ring
+    have hPYden : y₁' - (C • W).toAffine.negY x₁' y₁'
+        = 2 * y₁' + (C • W).a₁ * x₁' + (C • W).a₃ := by
+      simp only [negY]
+      ring
+    have hn : 3 * vcX C x₁' ^ 2 + 2 * W.a₂ * vcX C x₁' + W.a₄ - W.a₁ * vcY C x₁' y₁'
+        = (C.u : K) ^ 4 * (3 * x₁' ^ 2 + 2 * (C • W).a₂ * x₁'
+            + (C • W).a₄ - (C • W).a₁ * y₁')
+          + C.s * ((C.u : K) ^ 3 * (y₁' - (C • W).toAffine.negY x₁' y₁')) := by
+      have hX := vcAdd_partialX_aux (C := C) (W := W) x₁' y₁'
+      have hY := vcAdd_partialY_aux (C := C) (W := W) x₁' y₁'
+      rw [hPYden]
+      linear_combination (-1 : K) * hX + C.s * hY
+    have hden' : y₁' - (C • W).toAffine.negY x₁' y₁' ≠ 0 := sub_ne_zero_of_ne hy
+    rw [hd, hn]
+    field_simp
+  · have hxW : vcX C x₁' ≠ vcX C x₂' := fun h => hx (vcX_injective h)
+    rw [slope_of_X_ne hxW, slope_of_X_ne hx]
+    have hd : vcX C x₁' - vcX C x₂' = (C.u : K) ^ 2 * (x₁' - x₂') := by
+      simp only [vcX]; ring
+    have hn : vcY C x₁' y₁' - vcY C x₂' y₂'
+        = (C.u : K) ^ 3 * (y₁' - y₂') + (C.u : K) ^ 2 * C.s * (x₁' - x₂') := by
+      simp only [vcY]; ring
+    rw [hd, hn]
+    have hxne : x₁' - x₂' ≠ 0 := sub_ne_zero_of_ne hx
+    field_simp
+
+theorem addX_variableChange (x₁' x₂' L : K) :
+    W.addX (vcX C x₁') (vcX C x₂') ((C.u : K) * L + C.s)
+      = vcX C ((C • W).toAffine.addX x₁' x₂' L) := by
+  have hu : (C.u : K) ≠ 0 := vcAdd_u_ne_zero
+  simp only [addX, vcX, variableChange_a₁, variableChange_a₂, Units.val_inv_eq_inv_val]
+  field_simp
+  ring
+
+theorem addY_variableChange (x₁' x₂' y₁' L : K) :
+    W.addY (vcX C x₁') (vcX C x₂') (vcY C x₁' y₁') ((C.u : K) * L + C.s)
+      = vcY C ((C • W).toAffine.addX x₁' x₂' L) ((C • W).toAffine.addY x₁' x₂' y₁' L) := by
+  have hu : (C.u : K) ≠ 0 := vcAdd_u_ne_zero
+  simp only [addY, negAddY, addX, negY, vcX, vcY, variableChange_a₁, variableChange_a₂,
+    variableChange_a₃, Units.val_inv_eq_inv_val]
+  field_simp
+  ring
+
+end Formulas
+
+namespace Point
+p2m_export "WeierstrassCurve.Affine.Point" "add_of_Y_eq some add_some map vcFun vcInvFun \
+  vcFun_zero vcFun_leftInverse vcFun_rightInverse"
+p2m_open "WeierstrassCurve.Affine.Point"
+
+variable {C : VariableChange K} {W : WeierstrassCurve.Affine K}
+
+theorem some_of_eq_of_eq' {V : WeierstrassCurve.Affine K} {x₁ y₁ x₂ y₂ : K}
+    {h₁ : V.Nonsingular x₁ y₁} {h₂ : V.Nonsingular x₂ y₂} (hx : x₁ = x₂) (hy : y₁ = y₂) :
+    (Point.some x₁ y₁ h₁ : V.Point) = Point.some x₂ y₂ h₂ := by
+  subst hx
+  subst hy
+  rfl
+
+variable [DecidableEq K]
+
+theorem vcFun_add (P Q : (C • W).toAffine.Point) :
+    vcFun C W (P + Q) = vcFun C W P + vcFun C W Q := by
+  rcases P with _ | ⟨x₁, y₁, h₁⟩
+  · rfl
+  rcases Q with _ | ⟨x₂, y₂, h₂⟩
+  · rfl
+  by_cases hxy : x₁ = x₂ ∧ y₁ = (C • W).toAffine.negY x₂ y₂
+  · rw [add_of_Y_eq hxy.1 hxy.2, vcFun_zero]
+    change (0 : W.Point) = Point.some (vcX C x₁) (vcY C x₁ y₁) _ + Point.some (vcX C x₂) (vcY C x₂
+      y₂) _
+    have hxyW := (Yeq_variableChange_iff (W := W) x₁ x₂ y₁ y₂).mpr hxy
+    exact (add_of_Y_eq hxyW.1 hxyW.2).symm
+  · have hxyW : ¬(vcX C x₁ = vcX C x₂ ∧ vcY C x₁ y₁ = W.negY (vcX C x₂) (vcY C x₂ y₂)) :=
+      fun h => hxy ((Yeq_variableChange_iff x₁ x₂ y₁ y₂).mp h)
+    have hslope := slope_variableChange (W := W) x₁ x₂ y₁ y₂ h₁.1 h₂.1 hxy
+    rw [add_some hxy]
+    change Point.some _ _ _ = Point.some (vcX C x₁) (vcY C x₁ y₁) _ + Point.some (vcX C x₂) (vcY C
+      x₂ y₂) _
+    rw [add_some hxyW]
+    refine some_of_eq_of_eq' ?_ ?_
+    · rw [hslope, addX_variableChange]
+    · rw [hslope, addY_variableChange]
+
+theorem vcInvFun_add' (P Q : W.Point) :
+    vcInvFun C W (P + Q) = vcInvFun C W P + vcInvFun C W Q := by
+  apply vcFun_leftInverse.injective
+  rw [vcFun_add, vcFun_rightInverse P, vcFun_rightInverse Q, vcFun_rightInverse (P + Q)]
+
+end Point
+
+end WeierstrassCurve.Affine
+
+theorem solution {K : Type*} [Field K] [DecidableEq K]
+    (C : WeierstrassCurve.VariableChange K) (W : WeierstrassCurve.Affine K) (P Q : W.Point) :
+    WeierstrassCurve.Affine.Point.vcInvFun C W (P + Q) =
+      WeierstrassCurve.Affine.Point.vcInvFun C W P + WeierstrassCurve.Affine.Point.vcInvFun C W Q :=
+  WeierstrassCurve.Affine.Point.vcInvFun_add' P Q
+
+end S_WeierstrassCurve_Affine_Point_vcInvFun_add
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_Point_vcInvFun_add (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.Affine.Point.vcInvFun_add {K : Type*} [Field K] [DecidableEq K]
+    (C : WeierstrassCurve.VariableChange K) (W : WeierstrassCurve.Affine K) (P Q : W.Point) :
+    WeierstrassCurve.Affine.Point.vcInvFun C W (P + Q) =
+      WeierstrassCurve.Affine.Point.vcInvFun C W P + WeierstrassCurve.Affine.Point.vcInvFun C W Q :=
+  solution C W P Q
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_vcInvFun_neg_heq_neg.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_vcInvFun_neg_heq_neg.lean
new file mode 100644
index 0000000000..427f1f6d3b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_vcInvFun_neg_heq_neg.lean
@@ -0,0 +1,129 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.Point.vcInvFun_neg_heq_neg
+(691b27e9-1392-5e2c-93dd-4c11fbdcd810) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6add0dd0-a373-56c5-a150-85e9f5ac18c3
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VariableChangePointEquiv
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_ModuliPoint
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The variable change (-1,0,-a₁,-a₃) acts as negation on points
+
+Theorem statement: `WeierstrassCurve.Affine.Point.vcInvFun_neg_heq_neg`
+(`691b27e9-1392-5e2c-93dd-4c11fbdcd810`), by Claude, 2026-09-05.
+
+Proof: submission `6add0dd0-a373-56c5-a150-85e9f5ac18c3`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field with decidable equality and let $W$ be a Weierstrass curve over $F$, with
+coefficients $a_1,\dots,a_6$. Consider the variable change $C=\langle u,r,s,t\rangle=\langle
+-1,0,-a_1,-a_3\rangle$ over $F$. For every point $P$ of the affine curve `W.toAffine`, the assertion
+is the heterogeneous equality of `Point.vcInvFun C W.toAffine P`, a point of the affine curve
+attached to $C \bullet W$, with $-P$, a point of `W.toAffine`. Here `vcInvFun` is defined by cases:
+the point at infinity is sent to the point at infinity, and an affine point $(x,y)$ is sent to the
+pair $\bigl(\mathrm{vcXInv}\,x,\ \mathrm{vcYInv}\,x\,y\bigr)=\bigl((u^{-1})^2(x-r),\
+(u^{-1})^3(y-t-s(x-r))\bigr)$, together with the proof that this pair is nonsingular on $C \bullet
+W$. For the present $C$ these formulae read $(x,y)\mapsto (x,\,-y-a_1x-a_3)$, the negation on a
+Weierstrass curve. The two sides lie in types that are only propositionally equal, whence the use of
+`HEq`.
+
+This records that the inverse substitution attached to the variable change $[-1]$, which fixes $W$,
+acts on points as $P\mapsto -P$. It is used in the embedding–moduli dictionary for $X_0(N)$, where
+it shows that the automorphism $-1$ preserves each cyclic subgroup, so that the orbit relation of
+the automorphism group on cyclic $N$-subgroups factors through $\mathrm{Aut}/\{\pm 1\}$; it is cited
+in the counting of moduli points with given $j$-invariant and in the analysis of stabilisers of
+order two.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_Point_vcInvFun_neg_heq_neg.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_Point_vcInvFun_neg_heq_neg
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_WeierstrassCurve_Affine_Point_vcInvFun_neg_heq_neg.WeierstrassCurve \
+  WeierstrassCurve.Affine \
+  P2MW.S_WeierstrassCurve_Affine_Point_vcInvFun_neg_heq_neg.WeierstrassCurve.Affine"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ a₁ variableChange_a₃ variableChange_a₆ \
+  variableChange_a₂ toAffine Affine.Point variableChange_a₁ variableChange_a₄ VariableChange \
+  Affine.Point.neg_some"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "negY Point Point.neg_some vcXInv vcYInv Point.vcInvFun"
+namespace Point
+p2m_export "WeierstrassCurve.Affine.Point" "some zero neg_some vcInvFun"
+p2m_open "WeierstrassCurve.Affine.Point WeierstrassCurve.Affine WeierstrassCurve"
+
+variable {F : Type*} [Field F]
+
+theorem negVariableChange_smul' (W : WeierstrassCurve F) :
+    (⟨-1, 0, -W.a₁, -W.a₃⟩ : VariableChange F) • W = W := by
+  ext
+  · simp only [variableChange_a₁, inv_neg, inv_one, Units.val_neg, Units.val_one]; ring
+  · simp only [variableChange_a₂, inv_neg, inv_one, Units.val_neg, Units.val_one]; ring
+  · simp only [variableChange_a₃, inv_neg, inv_one, Units.val_neg, Units.val_one]; ring
+  · simp only [variableChange_a₄, inv_neg, inv_one, Units.val_neg, Units.val_one]; ring
+  · simp only [variableChange_a₆, inv_neg, inv_one, Units.val_neg, Units.val_one]; ring
+
+end WeierstrassCurve.Affine.Point
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_WeierstrassCurve_Affine_Point_vcInvFun_neg_heq_neg.WeierstrassCurve \
+  WeierstrassCurve.Affine \
+  P2MW.S_WeierstrassCurve_Affine_Point_vcInvFun_neg_heq_neg.WeierstrassCurve.Affine \
+  WeierstrassCurve.Affine.Point \
+  P2MW.S_WeierstrassCurve_Affine_Point_vcInvFun_neg_heq_neg.WeierstrassCurve.Affine.Point"
+
+theorem solution {F : Type*} [Field F] (W : WeierstrassCurve F)
+    (P : W.toAffine.Point) :
+    HEq (vcInvFun (⟨-1, 0, -W.a₁, -W.a₃⟩ : VariableChange F) W.toAffine P) (-P) := by
+  classical
+  have hW : ((⟨-1, 0, -W.a₁, -W.a₃⟩ : VariableChange F) • W).toAffine = W.toAffine :=
+    negVariableChange_smul' W
+  cases P with
+  | zero => exact ModularCurve.Point.heq_zero hW
+  | some x y h =>
+    rw [Affine.Point.neg_some]
+    simp only [vcInvFun]
+    refine ModularCurve.Point.heq_some hW ?_ ?_
+    · simp [vcXInv]
+    · simp only [vcYInv, Affine.negY, inv_neg, inv_one, Units.val_neg, Units.val_one, sub_zero]
+      ring
+
+end S_WeierstrassCurve_Affine_Point_vcInvFun_neg_heq_neg
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_Point_vcInvFun_neg_heq_neg (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine
+theorem WeierstrassCurve.Affine.Point.vcInvFun_neg_heq_neg {F : Type*} [Field F]
+    (W : WeierstrassCurve F) (P : W.toAffine.Point) :
+    HEq (Point.vcInvFun (⟨-1, 0, -W.a₁, -W.a₃⟩ : VariableChange F) W.toAffine P) (-P) := by
+  classical
+  exact
+    solution W P
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_zsmul_some_eq_some_div.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_zsmul_some_eq_some_div.lean
new file mode 100644
index 0000000000..73647ee664
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_zsmul_some_eq_some_div.lean
@@ -0,0 +1,177 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.Point.zsmul_some_eq_some_div
+(fe33ebe9-0d1c-5f57-8a6e-d0da19a58dae) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b36ea32d-f312-570b-bb72-33a56c8cce61
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_EDSEngine
+import Mathlib.NumberTheory.EllipticDivisibilitySequence
+import Mathlib.Algebra.Ring.NegOnePow
+import Mathlib.Data.Fin.VecNotation
+import Mathlib.Data.Fin.Tuple.Sort
+import Mathlib.Algebra.GroupWithZero.NonZeroDivisors
+import Mathlib.Algebra.MvPolynomial.CommRing
+import Mathlib.Algebra.MvPolynomial.Basic
+import Mathlib.Tactic.LinearCombination
+import Mathlib.Tactic.Ring
+import Mathlib.Tactic.Abel
+import Mathlib.Tactic.IntervalCases
+import Mathlib.Tactic.FieldSimp
+import Mathlib.GroupTheory.Perm.Basic
+import Mathlib.GroupTheory.Perm.Sign
+import Mathlib.GroupTheory.Perm.Cycle.Type
+import Mathlib.Algebra.Polynomial.Bivariate
+import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+import Mathlib.AlgebraicGeometry.EllipticCurve.Jacobian.Point
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+import Mathlib.FieldTheory.IsAlgClosed.Basic
+import Mathlib.FieldTheory.Separable
+import Mathlib.Data.Nat.Factorization.Induction
+import Mathlib.Logic.Embedding.Set
+import Mathlib.SetTheory.Cardinal.Finite
+import Mathlib.Data.Set.Card
+import Mathlib.Algebra.Module.Torsion.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Abscissa of nP via division polynomials: x(nP)=Φₙ(x)/Ψₙ²(x)
+
+Theorem statement: `WeierstrassCurve.Affine.Point.zsmul_some_eq_some_div`
+(`fe33ebe9-0d1c-5f57-8a6e-d0da19a58dae`), by Claude, 2026-09-05.
+
+Proof: submission `b36ea32d-f312-570b-bb72-33a56c8cce61`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field and let $W$ be a Weierstrass curve over $F$, given by its usual coefficients. Let
+$x,y \in F$ be such that $(x,y)$ is a nonsingular point of the associated affine curve `W.toAffine`,
+i.e. it satisfies the Weierstrass equation and the two partial derivatives do not both vanish there,
+and write `Point.some x y h` for the corresponding element of the group of affine points. Let $n$ be
+an integer and assume that the $n$-th division polynomial $\psi_n \in F[X][Y]$ of $W$ does not
+vanish at $(x,y)$, that is, `(W.ψ n).evalEval x y ≠ 0`. The conclusion asserts the existence of an
+ordinate $y' \in F$ together with a proof that the pair $\bigl(\Phi_n(x)/\Psi_n^2(x),\, y'\bigr)$ is
+again a nonsingular point of the affine curve — here $\Phi_n$ and $\Psi_n^2$ are the univariate
+division polynomials `W.Φ n` and `W.ΨSq n`, both evaluated at $x$ — such that $n \cdot
+\mathtt{some}\,x\,y\,h = \mathtt{some}\,\bigl(\Phi_n(x)/\Psi_n^2(x)\bigr)\,y'$ in the group of
+affine points. In particular the multiple $n P$ is an affine point and its abscissa is the quotient
+$\Phi_n(x)/\Psi_n^2(x)$; the ordinate of $nP$ is only asserted to exist, not computed.
+
+This is the classical multiplication-by-$n$ formula for the $x$-coordinate of a multiple of a point
+on a Weierstrass curve, in the form needed whenever a point is known not to be annihilated by $n$.
+It is used in the project's work with torsion points, isogenies and Frobenius on points, for
+instance in the treatment of the Čerednik–Drinfeld fibres and of Frobenius endomorphisms acting on
+torsion.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_Point_zsmul_some_eq_some_div.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_Point_zsmul_some_eq_some_div
+
+section PortCardMulX
+
+namespace PortCard
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point Polynomial
+open scoped Polynomial.Bivariate
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+theorem zsmul_some_eq_some_of_evalEval_ψ_ne_zero {x y : F} (h : W.toAffine.Nonsingular x y)
+    {n : ℤ} (hψ : (W.ψ n).evalEval x y ≠ 0) :
+    ∃ (x' y' : F) (h' : W.toAffine.Nonsingular x' y'),
+      n • Point.some x y h = Point.some x' y' h' ∧
+        x' * (W.ψ n).evalEval x y ^ 2 = (W.φ n).evalEval x y ∧
+        x' * (W.ΨSq n).eval x = (W.Φ n).eval x := by
+  have heq : W.toAffine.Equation x y := h.left
+  have hψsq := W.evalEval_ψ_sq heq n
+  have key := zsmul_eq_smulEval W h n
+  have hVz : smulEval W x y n 2 ≠ 0 := hψ
+  have hV := key ▸ (n • Jacobian.Point.fromAffine (Point.some x y h)).nonsingular
+  have hQeq : (n • Jacobian.Point.fromAffine (Point.some x y h)) =
+      Jacobian.Point.mk hV := Jacobian.Point.ext key
+  refine ⟨smulEval W x y n 0 / smulEval W x y n 2 ^ 2,
+    smulEval W x y n 1 / smulEval W x y n 2 ^ 3,
+    (Jacobian.nonsingular_of_Z_ne_zero hVz).mp hV, ?_, ?_, ?_⟩
+  · calc n • Point.some x y h
+        = Jacobian.Point.toAffineAddEquiv W
+            (n • Jacobian.Point.fromAffine (Point.some x y h)) := by
+          rw [map_zsmul, ← Jacobian.Point.toAffineAddEquiv_symm_apply,
+            AddEquiv.apply_symm_apply]
+      _ = _ := by
+          rw [hQeq, Jacobian.Point.toAffineAddEquiv_apply]
+          exact Jacobian.Point.toAffineLift_of_Z_ne_zero hVz
+  · change (W.φ n).evalEval x y / (W.ψ n).evalEval x y ^ 2 * (W.ψ n).evalEval x y ^ 2 =
+        (W.φ n).evalEval x y
+    rw [div_mul_cancel₀ _ (pow_ne_zero 2 hψ)]
+  · change (W.φ n).evalEval x y / (W.ψ n).evalEval x y ^ 2 * (W.ΨSq n).eval x = (W.Φ n).eval x
+    rw [← hψsq, div_mul_cancel₀ _ (pow_ne_zero 2 hψ), W.evalEval_φ heq]
+
+theorem zsmul_some_eq_some_of_eval_ΨSq_ne_zero {x y : F} (h : W.toAffine.Nonsingular x y)
+    {n : ℤ} (hn : (W.ΨSq n).eval x ≠ 0) :
+    ∃ (x' y' : F) (h' : W.toAffine.Nonsingular x' y'),
+      n • Point.some x y h = Point.some x' y' h' ∧ x' * (W.ΨSq n).eval x = (W.Φ n).eval x := by
+  have hψ : (W.ψ n).evalEval x y ≠ 0 := fun h0 =>
+    hn (by rw [← W.evalEval_ψ_sq h.left n, h0]; exact zero_pow two_ne_zero)
+  obtain ⟨x', y', h', hP, -, hx⟩ := zsmul_some_eq_some_of_evalEval_ψ_ne_zero W h hψ
+  exact ⟨x', y', h', hP, hx⟩
+
+theorem zsmul_some_eq_zero_iff_eval_ΨSq {x y : F} (h : W.toAffine.Nonsingular x y) (n : ℤ) :
+    n • Point.some x y h = 0 ↔ (W.ΨSq n).eval x = 0 := by
+  rw [W.smul_eq_zero_iff_evalEval_ψ h n, ← W.evalEval_ψ_sq h.left n]
+  exact ⟨fun h0 => by rw [h0]; exact zero_pow two_ne_zero, fun h0 => (sq_eq_zero_iff).mp h0⟩
+
+theorem zsmul_some_eq_some_div {x y : F} (h : W.toAffine.Nonsingular x y) {n : ℤ}
+    (hψ : (W.ψ n).evalEval x y ≠ 0) :
+    ∃ (y' : F) (h' : W.toAffine.Nonsingular ((W.Φ n).eval x / (W.ΨSq n).eval x) y'),
+      n • Point.some x y h = Point.some ((W.Φ n).eval x / (W.ΨSq n).eval x) y' h' := by
+  obtain ⟨x', y', h', hP, -, hx⟩ := zsmul_some_eq_some_of_evalEval_ψ_ne_zero W h hψ
+  have hΨ : (W.ΨSq n).eval x ≠ 0 := by
+    rw [← W.evalEval_ψ_sq h.left n]; exact pow_ne_zero 2 hψ
+  obtain rfl : x' = (W.Φ n).eval x / (W.ΨSq n).eval x := by rw [eq_div_iff hΨ]; exact hx
+  exact ⟨y', h', hP⟩
+
+end PortCard
+
+end PortCardMulX
+
+theorem solution {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F) {x y : F}
+    (h : W.toAffine.Nonsingular x y) {n : ℤ} (hψ : (W.ψ n).evalEval x y ≠ 0) :
+    ∃ (y' : F) (h' : W.toAffine.Nonsingular ((W.Φ n).eval x / (W.ΨSq n).eval x) y'), n •
+      WeierstrassCurve.Affine.Point.some x y h = WeierstrassCurve.Affine.Point.some ((W.Φ n).eval x
+      / (W.ΨSq n).eval x) y' h' :=
+  PortCard.zsmul_some_eq_some_div W h hψ
+
+end S_WeierstrassCurve_Affine_Point_zsmul_some_eq_some_div
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_Point_zsmul_some_eq_some_div (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.Affine.Point.zsmul_some_eq_some_div {F : Type*} [Field F] [DecidableEq F]
+    (W : WeierstrassCurve F) {x y : F} (h : W.toAffine.Nonsingular x y) {n : ℤ}
+    (hψ : (W.ψ n).evalEval x y ≠ 0) :
+    ∃ (y' : F) (h' : W.toAffine.Nonsingular ((W.Φ n).eval x / (W.ΨSq n).eval x) y'), n •
+      WeierstrassCurve.Affine.Point.some x y h = WeierstrassCurve.Affine.Point.some ((W.Φ n).eval x
+      / (W.ΨSq n).eval x) y' h' :=
+  solution W h hψ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_zsmul_x_mul_psi_sq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_zsmul_x_mul_psi_sq.lean
new file mode 100644
index 0000000000..89c7470c20
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_zsmul_x_mul_psi_sq.lean
@@ -0,0 +1,257 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.Point.zsmul_x_mul_psi_sq
+(4e980a47-c6f1-516e-9c4a-8bd6da366a06) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 44471165-6627-5684-ae52-50311e9d6d31
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_DivisionPolynomialOmega
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_smul_some_eq_zero_iff
+import Mathlib.NumberTheory.EllipticDivisibilitySequence
+import Mathlib.Algebra.Ring.NegOnePow
+import Mathlib.Data.Fin.VecNotation
+import Mathlib.Data.Fin.Tuple.Sort
+import Mathlib.Algebra.GroupWithZero.NonZeroDivisors
+import Mathlib.Algebra.MvPolynomial.CommRing
+import Mathlib.Algebra.MvPolynomial.Basic
+import Mathlib.Tactic.LinearCombination
+import Mathlib.Tactic.Ring
+import Mathlib.Tactic.Abel
+import Mathlib.Tactic.IntervalCases
+import Mathlib.Tactic.FieldSimp
+import Mathlib.GroupTheory.Perm.Basic
+import Mathlib.GroupTheory.Perm.Sign
+import Mathlib.GroupTheory.Perm.Cycle.Type
+import Mathlib.Algebra.Polynomial.Bivariate
+import Mathlib.AlgebraicGeometry.EllipticCurve.Jacobian.Point
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+import Mathlib.FieldTheory.IsAlgClosed.Basic
+import Mathlib.FieldTheory.Separable
+import Mathlib.Data.Nat.Factorization.Induction
+import Mathlib.Logic.Embedding.Set
+import Mathlib.SetTheory.Cardinal.Finite
+import Mathlib.Data.Set.Card
+import Mathlib.Algebra.Module.Torsion.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_EDSEngine
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# x([n]P) ψₙ(P)²=φₙ(P) for affine points
+
+Theorem statement: `WeierstrassCurve.Affine.Point.zsmul_x_mul_psi_sq`
+(`4e980a47-c6f1-516e-9c4a-8bd6da366a06`), by Claude, 2026-09-05.
+
+Proof: submission `44471165-6627-5684-ae52-50311e9d6d31`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field and let $W$ be a Weierstrass curve over $F$ whose discriminant is a unit, and let
+$n\in\mathbb{Z}$. Suppose $x,y\in F$ are such that $(x,y)$ is a nonsingular point of the affine
+curve `W.toAffine`, with associated group element `WeierstrassCurve.Affine.Point.some x y h`, and
+likewise $x',y'\in F$ with `W.toAffine.Nonsingular x' y'`. Assume that the $n$-fold multiple of
+$(x,y)$ in the group of affine points equals $(x',y')$, that is $n \bullet$ `some x y h` $=$ `some
+x' y' h'` (in particular $[n]$ applied to the point is not the point at infinity, since it is given
+in affine form). Then $$x' \cdot \big(\psi_n(x,y)\big)^2 = \varphi_n(x,y),$$ where $\psi_n =$ `W.ψ
+n` and $\varphi_n =$ `W.φ n` are the bivariate division polynomials in $F[X][Y]$ attached to $W$ and
+evaluation is `Polynomial.evalEval x y`. Equivalently $x([n]P)=\varphi_n(P)/\psi_n(P)^2$, stated in
+cleared-denominator form; negative $n$ are included.
+
+This is the multiplication-by-$n$ formula for the $x$-coordinate in terms of division polynomials,
+in the form with denominators cleared. It is used throughout the study of the Frobenius endomorphism
+over finite fields, where degrees of the rational functions $\varphi_n/\psi_n^2$ control kernels of
+$[m]-\pi$ and torsion counts.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_Point_zsmul_x_mul_psi_sq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_Point_zsmul_x_mul_psi_sq
+
+section PortCardMulXY
+
+namespace PortCard
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_WeierstrassCurve_Affine_Point_zsmul_x_mul_psi_sq.WeierstrassCurve WeierstrassCurve.Affine \
+  WeierstrassCurve.Affine.Point Polynomial"
+open scoped Polynomial.Bivariate
+
+theorem zsmul_some_eq_some_jac {F : Type*} [Field F] [DecidableEq F] (V : WeierstrassCurve F)
+    {x y : F} (h : V.toAffine.Nonsingular x y) {n : ℤ} (hψ : (V.ψ n).evalEval x y ≠ 0) :
+    ∃ h' : V.toAffine.Nonsingular ((V.φ n).evalEval x y / (V.ψ n).evalEval x y ^ 2)
+        ((V.ωe n).evalEval x y / (V.ψ n).evalEval x y ^ 3),
+      n • Point.some x y h = Point.some ((V.φ n).evalEval x y / (V.ψ n).evalEval x y ^ 2)
+        ((V.ωe n).evalEval x y / (V.ψ n).evalEval x y ^ 3) h' := by
+  have key := zsmul_eq_smulEval V h n
+  have hVz : smulEval V x y n 2 ≠ 0 := hψ
+  have hV := key ▸ (n • Jacobian.Point.fromAffine (Point.some x y h)).nonsingular
+  have hQeq : (n • Jacobian.Point.fromAffine (Point.some x y h)) =
+      Jacobian.Point.mk hV := Jacobian.Point.ext key
+  refine ⟨(Jacobian.nonsingular_of_Z_ne_zero hVz).mp hV, ?_⟩
+  calc n • Point.some x y h
+      = Jacobian.Point.toAffineAddEquiv V
+          (n • Jacobian.Point.fromAffine (Point.some x y h)) := by
+        rw [map_zsmul, ← Jacobian.Point.toAffineAddEquiv_symm_apply,
+          AddEquiv.apply_symm_apply]
+    _ = _ := by
+        rw [hQeq, Jacobian.Point.toAffineAddEquiv_apply]
+        exact Jacobian.Point.toAffineLift_of_Z_ne_zero hVz
+
+theorem some_congr {F : Type*} [CommRing F] {V : Affine F} {x₁ x₂ y₁ y₂ : F} (ex : x₁ = x₂)
+    (ey : y₁ = y₂) (h₁ : V.Nonsingular x₁ y₁) :
+    ∃ h₂ : V.Nonsingular x₂ y₂, Point.some x₁ y₁ h₁ = Point.some x₂ y₂ h₂ := by
+  subst ex ey; exact ⟨h₁, rfl⟩
+
+universe u v in
+theorem exists_zsmul_some_eq_some_baseChange {R : Type u} [CommRing R] (W : WeierstrassCurve R)
+    (n : ℤ) : ∃ ωe : R[X][Y], ∀ {F : Type v} [Field F] [DecidableEq F] [Algebra R F] {x y : F}
+      (h : (W.baseChange F).toAffine.Nonsingular x y),
+      ((W.baseChange F).ψ n).evalEval x y ≠ 0 →
+        ∃ h' : (W.baseChange F).toAffine.Nonsingular
+            (((W.baseChange F).Φ n).eval x / ((W.baseChange F).ΨSq n).eval x)
+            ((ωe.map (mapRingHom (algebraMap R F))).evalEval x y /
+              ((W.baseChange F).ψ n).evalEval x y ^ 3),
+          n • Point.some x y h =
+            Point.some (((W.baseChange F).Φ n).eval x / ((W.baseChange F).ΨSq n).eval x)
+              ((ωe.map (mapRingHom (algebraMap R F))).evalEval x y /
+                ((W.baseChange F).ψ n).evalEval x y ^ 3) h' := by
+  refine ⟨W.ωe n, ?_⟩
+  intro F _ _ _ x y h hψ
+  have hω : (W.baseChange F).ωe n = (W.ωe n).map (mapRingHom (algebraMap R F)) := by
+    rw [WeierstrassCurve.baseChange, map_ωe]
+  obtain ⟨h₁, e₁⟩ := zsmul_some_eq_some_jac (W.baseChange F) h hψ
+  have ex : ((W.baseChange F).φ n).evalEval x y / ((W.baseChange F).ψ n).evalEval x y ^ 2 =
+      ((W.baseChange F).Φ n).eval x / ((W.baseChange F).ΨSq n).eval x := by
+    rw [(W.baseChange F).evalEval_φ h.left n, (W.baseChange F).evalEval_ψ_sq h.left n]
+  have ey : ((W.baseChange F).ωe n).evalEval x y / ((W.baseChange F).ψ n).evalEval x y ^ 3 =
+      ((W.ωe n).map (mapRingHom (algebraMap R F))).evalEval x y /
+        ((W.baseChange F).ψ n).evalEval x y ^ 3 := by
+    rw [hω]
+  obtain ⟨h₂, e₂⟩ := some_congr ex ey h₁
+  exact ⟨h₂, e₁.trans e₂⟩
+
+end PortCard
+
+end PortCardMulXY
+
+universe u v
+
+section M4WilesOmega
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map Jacobian.nonsingular_of_Z_ne_zero \
+  Jacobian.Point.toAffineAddEquiv_symm_apply mk Jacobian Affine.Point.some Jacobian.Point.ext \
+  Jacobian.Point.fromAffine Jacobian.Point.toAffineAddEquiv_apply ΨSq toAffine Affine.Point \
+  Jacobian.Point.toAffineAddEquiv Jacobian.Point baseChange \
+  Jacobian.Point.toAffineLift_of_Z_ne_zero Jacobian.Point.mk ψDbl twoω Universal.curve \
+  Universal.map_specialize ω ω_eq_map_of_twoω_eq two_mul_ω_of_twoω_universal_eq \
+  Affine.Point.smul_some_eq_zero_iff map_specialize ψc ωe two_mul_ωe map_ωe smulEval \
+  zsmul_eq_smulEval evalEval_ψ_sq evalEval_φ"
+p2m_open "WeierstrassCurve"
+
+open Polynomial
+open scoped Polynomial.Bivariate
+
+variable {R : Type*} [CommRing R] (W : WeierstrassCurve R)
+
+lemma ψc_eq_ψDbl (n : ℤ) : W.ψc n = W.ψDbl n := rfl
+
+lemma twoω_eq_two_mul_ωe (n : ℤ) : W.twoω n = 2 * W.ωe n := by
+  rw [two_mul_ωe, ψc_eq_ψDbl, twoω]
+  ring
+
+namespace Universal
+p2m_export "WeierstrassCurve.Universal" "curve map_specialize"
+end Universal
+p2m_open_scoped "WeierstrassCurve.Universal" in
+lemma Universal.twoω_curve_eq (n : ℤ) : Universal.curve.twoω n = 2 * Universal.curve.ωe n :=
+  twoω_eq_two_mul_ωe _ n
+
+theorem ω_eq_ωe (n : ℤ) : W.ω n = W.ωe n := by
+  rw [W.ω_eq_map_of_twoω_eq (Universal.twoω_curve_eq n), ← map_ωe, Universal.map_specialize]
+
+theorem two_mul_ω_eq_twoω (n : ℤ) : 2 * W.ω n = W.twoω n :=
+  W.two_mul_ω_of_twoω_universal_eq (Universal.twoω_curve_eq n)
+
+end WeierstrassCurve
+
+end M4WilesOmega
+
+section M4WilesOmegaXY
+
+namespace M4Wiles
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_WeierstrassCurve_Affine_Point_zsmul_x_mul_psi_sq.WeierstrassCurve WeierstrassCurve.Affine \
+  WeierstrassCurve.Affine.Point Polynomial"
+open scoped Polynomial.Bivariate
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+theorem zsmul_coords {n : ℤ} {x y : F} (h : W.toAffine.Nonsingular x y) {x' y' : F}
+    (h' : W.toAffine.Nonsingular x' y')
+    (hn : n • Point.some x y h = Point.some x' y' h') :
+    (W.ψ n).evalEval x y ≠ 0 ∧ x' * (W.ψ n).evalEval x y ^ 2 = (W.φ n).evalEval x y ∧
+      y' * (W.ψ n).evalEval x y ^ 3 = (W.ω n).evalEval x y := by
+  have hψ : (W.ψ n).evalEval x y ≠ 0 := by
+    intro h0
+    have := (WeierstrassCurve.Affine.Point.smul_some_eq_zero_iff W h n).mpr h0
+    rw [hn] at this
+    exact absurd this (by rintro ⟨⟩)
+  obtain ⟨h₁, e₁⟩ := PortCard.zsmul_some_eq_some_jac W h hψ
+  rw [hn] at e₁
+  simp only [Point.some.injEq] at e₁
+  obtain ⟨ex, ey⟩ := e₁
+  refine ⟨hψ, ?_, ?_⟩
+  · rw [ex, div_mul_cancel₀ _ (pow_ne_zero 2 hψ)]
+  · rw [ey, div_mul_cancel₀ _ (pow_ne_zero 3 hψ), ω_eq_ωe]
+
+end M4Wiles
+
+end M4WilesOmegaXY
+
+open Polynomial
+open scoped Polynomial.Bivariate
+
+theorem solution {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F) [W.IsElliptic] (n :
+  ℤ) {x y : F} (h : W.toAffine.Nonsingular x y) {x' y' : F} (h' : W.toAffine.Nonsingular x' y') (hn
+  : n • WeierstrassCurve.Affine.Point.some x y h = WeierstrassCurve.Affine.Point.some x' y' h') :
+    x' * ((W.ψ n).evalEval x y) ^ 2 = (W.φ n).evalEval x y :=
+  (M4Wiles.zsmul_coords W h h' hn).2.1
+
+end S_WeierstrassCurve_Affine_Point_zsmul_x_mul_psi_sq
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_Point_zsmul_x_mul_psi_sq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Polynomial
+open scoped Polynomial.Bivariate
+
+theorem WeierstrassCurve.Affine.Point.zsmul_x_mul_psi_sq {F : Type*} [Field F] [DecidableEq F] (W :
+  WeierstrassCurve F) [W.IsElliptic] (n : ℤ) {x y : F} (h : W.toAffine.Nonsingular x y) {x' y' : F}
+  (h' : W.toAffine.Nonsingular x' y') (hn : n • WeierstrassCurve.Affine.Point.some x y h =
+  WeierstrassCurve.Affine.Point.some x' y' h') :
+    x' * ((W.ψ n).evalEval x y) ^ 2 = (W.φ n).evalEval x y :=
+  solution W n h h' hn
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_zsmul_y_mul_psi_cube.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_zsmul_y_mul_psi_cube.lean
new file mode 100644
index 0000000000..743bf1c2ff
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_Point_zsmul_y_mul_psi_cube.lean
@@ -0,0 +1,265 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.Point.zsmul_y_mul_psi_cube
+(4fdd4635-b19d-59ac-890e-7c8f296bee29) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ce334005-cc78-5d27-94bb-65d2679dd7dc
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_DivisionPolynomialOmega
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_smul_some_eq_zero_iff
+import Mathlib.NumberTheory.EllipticDivisibilitySequence
+import Mathlib.Algebra.Ring.NegOnePow
+import Mathlib.Data.Fin.VecNotation
+import Mathlib.Data.Fin.Tuple.Sort
+import Mathlib.Algebra.GroupWithZero.NonZeroDivisors
+import Mathlib.Algebra.MvPolynomial.CommRing
+import Mathlib.Algebra.MvPolynomial.Basic
+import Mathlib.Tactic.LinearCombination
+import Mathlib.Tactic.Ring
+import Mathlib.Tactic.Abel
+import Mathlib.Tactic.IntervalCases
+import Mathlib.Tactic.FieldSimp
+import Mathlib.GroupTheory.Perm.Basic
+import Mathlib.GroupTheory.Perm.Sign
+import Mathlib.GroupTheory.Perm.Cycle.Type
+import Mathlib.Algebra.Polynomial.Bivariate
+import Mathlib.AlgebraicGeometry.EllipticCurve.Jacobian.Point
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+import Mathlib.FieldTheory.IsAlgClosed.Basic
+import Mathlib.FieldTheory.Separable
+import Mathlib.Data.Nat.Factorization.Induction
+import Mathlib.Logic.Embedding.Set
+import Mathlib.SetTheory.Cardinal.Finite
+import Mathlib.Data.Set.Card
+import Mathlib.Algebra.Module.Torsion.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_EDSEngine
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# y([n]P) ψₙ(P)³=ωₙ(P) for affine points
+
+Theorem statement: `WeierstrassCurve.Affine.Point.zsmul_y_mul_psi_cube`
+(`4fdd4635-b19d-59ac-890e-7c8f296bee29`), by Claude, 2026-09-05.
+
+Proof: submission `ce334005-cc78-5d27-94bb-65d2679dd7dc`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field and $W$ a Weierstrass curve over $F$ whose associated elliptic-curve condition
+`W.IsElliptic` holds (discriminant a unit), let $n$ be an integer, and let $(x,y)$ and $(x',y')$ be
+pairs of elements of $F$ together with proofs $h$, $h'$ that each is a nonsingular point of the
+affine curve `W.toAffine`, so that `Point.some x y h` and `Point.some x' y' h'` are elements of the
+group $W(F)$ of affine points. Assume $n \cdot (x,y) = (x',y')$ in that group, computed with the
+Mathlib group law on `WeierstrassCurve.Affine.Point`; note that this hypothesis in particular
+encodes that $[n]P$ is not the point at infinity. The conclusion is the single identity
+$$y' \cdot \bigl(\psi_n(x,y)\bigr)^3 = \omega_n(x,y),$$
+where $\psi_n$ is the Mathlib division polynomial `WeierstrassCurve.ψ` of $W$, $\omega_n$ is the
+project's division polynomial
+[`WeierstrassCurve.ω`](def/EllipticCurve_DivisionPolynomialOmega.html#L86) (the halved polynomial of
+the module `EllipticCurve_DivisionPolynomialOmega`, available in every characteristic), and
+`evalEval x y` denotes evaluation of a bivariate polynomial in $F[X][Y]$ at $X = x$, $Y = y$. No
+nonvanishing of $\psi_n(x,y)$ and no companion identity for the $x$-coordinate are part of the
+conclusion, although both are established en route.
+
+This is the $y$-coordinate half of the classical multiplication-by-$n$ formula $[n]P =
+\bigl(\phi_n(P)/\psi_n(P)^2,\ \omega_n(P)/\psi_n(P)^3\bigr)$, stated here with the
+characteristic-free $\omega_n$ so that characteristic $2$ is included. It is used in the treatment
+of Frobenius and isogeny endomorphisms, for instance by
+[`FrobeniusEndo.exists_x_linePencil_frobEnd_mul_collision_sq`]
+(thm.html#FrobeniusEndo.exists_x_linePencil_frobEnd_mul_collision_sq)
+and by the results on Weil numbers and on restricting isogeny data along places of points.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_Point_zsmul_y_mul_psi_cube.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_Point_zsmul_y_mul_psi_cube
+
+section PortCardMulXY
+
+namespace PortCard
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_WeierstrassCurve_Affine_Point_zsmul_y_mul_psi_cube.WeierstrassCurve \
+  WeierstrassCurve.Affine WeierstrassCurve.Affine.Point Polynomial"
+open scoped Polynomial.Bivariate
+
+theorem zsmul_some_eq_some_jac {F : Type*} [Field F] [DecidableEq F] (V : WeierstrassCurve F)
+    {x y : F} (h : V.toAffine.Nonsingular x y) {n : ℤ} (hψ : (V.ψ n).evalEval x y ≠ 0) :
+    ∃ h' : V.toAffine.Nonsingular ((V.φ n).evalEval x y / (V.ψ n).evalEval x y ^ 2)
+        ((V.ωe n).evalEval x y / (V.ψ n).evalEval x y ^ 3),
+      n • Point.some x y h = Point.some ((V.φ n).evalEval x y / (V.ψ n).evalEval x y ^ 2)
+        ((V.ωe n).evalEval x y / (V.ψ n).evalEval x y ^ 3) h' := by
+  have key := zsmul_eq_smulEval V h n
+  have hVz : smulEval V x y n 2 ≠ 0 := hψ
+  have hV := key ▸ (n • Jacobian.Point.fromAffine (Point.some x y h)).nonsingular
+  have hQeq : (n • Jacobian.Point.fromAffine (Point.some x y h)) =
+      Jacobian.Point.mk hV := Jacobian.Point.ext key
+  refine ⟨(Jacobian.nonsingular_of_Z_ne_zero hVz).mp hV, ?_⟩
+  calc n • Point.some x y h
+      = Jacobian.Point.toAffineAddEquiv V
+          (n • Jacobian.Point.fromAffine (Point.some x y h)) := by
+        rw [map_zsmul, ← Jacobian.Point.toAffineAddEquiv_symm_apply,
+          AddEquiv.apply_symm_apply]
+    _ = _ := by
+        rw [hQeq, Jacobian.Point.toAffineAddEquiv_apply]
+        exact Jacobian.Point.toAffineLift_of_Z_ne_zero hVz
+
+theorem some_congr {F : Type*} [CommRing F] {V : Affine F} {x₁ x₂ y₁ y₂ : F} (ex : x₁ = x₂)
+    (ey : y₁ = y₂) (h₁ : V.Nonsingular x₁ y₁) :
+    ∃ h₂ : V.Nonsingular x₂ y₂, Point.some x₁ y₁ h₁ = Point.some x₂ y₂ h₂ := by
+  subst ex ey; exact ⟨h₁, rfl⟩
+
+universe u v in
+theorem exists_zsmul_some_eq_some_baseChange {R : Type u} [CommRing R] (W : WeierstrassCurve R)
+    (n : ℤ) : ∃ ωe : R[X][Y], ∀ {F : Type v} [Field F] [DecidableEq F] [Algebra R F] {x y : F}
+      (h : (W.baseChange F).toAffine.Nonsingular x y),
+      ((W.baseChange F).ψ n).evalEval x y ≠ 0 →
+        ∃ h' : (W.baseChange F).toAffine.Nonsingular
+            (((W.baseChange F).Φ n).eval x / ((W.baseChange F).ΨSq n).eval x)
+            ((ωe.map (mapRingHom (algebraMap R F))).evalEval x y /
+              ((W.baseChange F).ψ n).evalEval x y ^ 3),
+          n • Point.some x y h =
+            Point.some (((W.baseChange F).Φ n).eval x / ((W.baseChange F).ΨSq n).eval x)
+              ((ωe.map (mapRingHom (algebraMap R F))).evalEval x y /
+                ((W.baseChange F).ψ n).evalEval x y ^ 3) h' := by
+  refine ⟨W.ωe n, ?_⟩
+  intro F _ _ _ x y h hψ
+  have hω : (W.baseChange F).ωe n = (W.ωe n).map (mapRingHom (algebraMap R F)) := by
+    rw [WeierstrassCurve.baseChange, map_ωe]
+  obtain ⟨h₁, e₁⟩ := zsmul_some_eq_some_jac (W.baseChange F) h hψ
+  have ex : ((W.baseChange F).φ n).evalEval x y / ((W.baseChange F).ψ n).evalEval x y ^ 2 =
+      ((W.baseChange F).Φ n).eval x / ((W.baseChange F).ΨSq n).eval x := by
+    rw [(W.baseChange F).evalEval_φ h.left n, (W.baseChange F).evalEval_ψ_sq h.left n]
+  have ey : ((W.baseChange F).ωe n).evalEval x y / ((W.baseChange F).ψ n).evalEval x y ^ 3 =
+      ((W.ωe n).map (mapRingHom (algebraMap R F))).evalEval x y /
+        ((W.baseChange F).ψ n).evalEval x y ^ 3 := by
+    rw [hω]
+  obtain ⟨h₂, e₂⟩ := some_congr ex ey h₁
+  exact ⟨h₂, e₁.trans e₂⟩
+
+end PortCard
+
+end PortCardMulXY
+
+universe u v
+
+section M4WilesOmega
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map Jacobian.nonsingular_of_Z_ne_zero \
+  Jacobian.Point.toAffineAddEquiv_symm_apply mk Jacobian Affine.Point.some Jacobian.Point.ext \
+  Jacobian.Point.fromAffine Jacobian.Point.toAffineAddEquiv_apply ΨSq toAffine Affine.Point \
+  Jacobian.Point.toAffineAddEquiv Jacobian.Point baseChange \
+  Jacobian.Point.toAffineLift_of_Z_ne_zero Jacobian.Point.mk ψDbl twoω Universal.curve \
+  Universal.map_specialize ω ω_eq_map_of_twoω_eq two_mul_ω_of_twoω_universal_eq \
+  Affine.Point.smul_some_eq_zero_iff map_specialize ψc ωe two_mul_ωe map_ωe smulEval \
+  zsmul_eq_smulEval evalEval_ψ_sq evalEval_φ"
+p2m_open "WeierstrassCurve"
+
+open Polynomial
+open scoped Polynomial.Bivariate
+
+variable {R : Type*} [CommRing R] (W : WeierstrassCurve R)
+
+lemma ψc_eq_ψDbl (n : ℤ) : W.ψc n = W.ψDbl n := rfl
+
+lemma twoω_eq_two_mul_ωe (n : ℤ) : W.twoω n = 2 * W.ωe n := by
+  rw [two_mul_ωe, ψc_eq_ψDbl, twoω]
+  ring
+
+namespace Universal
+p2m_export "WeierstrassCurve.Universal" "curve map_specialize"
+end Universal
+p2m_open_scoped "WeierstrassCurve.Universal" in
+lemma Universal.twoω_curve_eq (n : ℤ) : Universal.curve.twoω n = 2 * Universal.curve.ωe n :=
+  twoω_eq_two_mul_ωe _ n
+
+theorem ω_eq_ωe (n : ℤ) : W.ω n = W.ωe n := by
+  rw [W.ω_eq_map_of_twoω_eq (Universal.twoω_curve_eq n), ← map_ωe, Universal.map_specialize]
+
+theorem two_mul_ω_eq_twoω (n : ℤ) : 2 * W.ω n = W.twoω n :=
+  W.two_mul_ω_of_twoω_universal_eq (Universal.twoω_curve_eq n)
+
+end WeierstrassCurve
+
+end M4WilesOmega
+
+section M4WilesOmegaXY
+
+namespace M4Wiles
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_WeierstrassCurve_Affine_Point_zsmul_y_mul_psi_cube.WeierstrassCurve \
+  WeierstrassCurve.Affine WeierstrassCurve.Affine.Point Polynomial"
+open scoped Polynomial.Bivariate
+
+variable {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+
+theorem zsmul_coords {n : ℤ} {x y : F} (h : W.toAffine.Nonsingular x y) {x' y' : F}
+    (h' : W.toAffine.Nonsingular x' y')
+    (hn : n • Point.some x y h = Point.some x' y' h') :
+    (W.ψ n).evalEval x y ≠ 0 ∧ x' * (W.ψ n).evalEval x y ^ 2 = (W.φ n).evalEval x y ∧
+      y' * (W.ψ n).evalEval x y ^ 3 = (W.ω n).evalEval x y := by
+  have hψ : (W.ψ n).evalEval x y ≠ 0 := by
+    intro h0
+    have := (WeierstrassCurve.Affine.Point.smul_some_eq_zero_iff W h n).mpr h0
+    rw [hn] at this
+    exact absurd this (by rintro ⟨⟩)
+  obtain ⟨h₁, e₁⟩ := PortCard.zsmul_some_eq_some_jac W h hψ
+  rw [hn] at e₁
+  simp only [Point.some.injEq] at e₁
+  obtain ⟨ex, ey⟩ := e₁
+  refine ⟨hψ, ?_, ?_⟩
+  · rw [ex, div_mul_cancel₀ _ (pow_ne_zero 2 hψ)]
+  · rw [ey, div_mul_cancel₀ _ (pow_ne_zero 3 hψ), ω_eq_ωe]
+
+end M4Wiles
+
+end M4WilesOmegaXY
+
+open Polynomial
+open scoped Polynomial.Bivariate
+
+theorem solution {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F) [W.IsElliptic] (n :
+  ℤ) {x y : F} (h : W.toAffine.Nonsingular x y) {x' y' : F} (h' : W.toAffine.Nonsingular x' y') (hn
+  : n • WeierstrassCurve.Affine.Point.some x y h = WeierstrassCurve.Affine.Point.some x' y' h') :
+    y' * ((W.ψ n).evalEval x y) ^ 3 = (W.ω n).evalEval x y :=
+  (M4Wiles.zsmul_coords W h h' hn).2.2
+
+end S_WeierstrassCurve_Affine_Point_zsmul_y_mul_psi_cube
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_Point_zsmul_y_mul_psi_cube (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Polynomial
+open scoped Polynomial.Bivariate
+
+theorem WeierstrassCurve.Affine.Point.zsmul_y_mul_psi_cube {F : Type*} [Field F] [DecidableEq F] (W
+  : WeierstrassCurve F) [W.IsElliptic] (n : ℤ) {x y : F} (h : W.toAffine.Nonsingular x y) {x' y' :
+  F} (h' : W.toAffine.Nonsingular x' y') (hn : n • WeierstrassCurve.Affine.Point.some x y h =
+  WeierstrassCurve.Affine.Point.some x' y' h') :
+    y' * ((W.ψ n).evalEval x y) ^ 3 = (W.ω n).evalEval x y :=
+  solution W n h h' hn
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_adjoin_yCoord_eq_top.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_adjoin_yCoord_eq_top.lean
new file mode 100644
index 0000000000..93ba9d8cfc
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_adjoin_yCoord_eq_top.lean
@@ -0,0 +1,98 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.adjoin_yCoord_eq_top
+(79d01350-dee8-5e1f-8179-7f315d731441) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 987c4a87-b02f-5d37-828f-3c45b69ae14c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IntermediateField.Adjoin.Defs
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FunctionFieldQuadratic
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The function field is generated over F(x) by y
+
+Theorem statement: `WeierstrassCurve.Affine.adjoin_yCoord_eq_top`
+(`79d01350-dee8-5e1f-8179-7f315d731441`), by Claude, 2026-09-05.
+
+Proof: submission `987c4a87-b02f-5d37-828f-3c45b69ae14c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field and let $W$ be an affine Weierstrass curve over $F$, with coordinate ring
+$W.\mathrm{CoordinateRing}$ and function field $W.\mathrm{FunctionField}$, the latter carrying its
+algebra structure over the rational function field $\mathrm{RatFunc}\,F$ (the $x$-coordinate
+subfield) as set up in the definition module. Write $\mathrm{yCoord}\,W$ for the element of
+$W.\mathrm{FunctionField}$ obtained by taking the class of the variable $Y$ in the coordinate ring
+and mapping it along the structure map $W.\mathrm{CoordinateRing} \to W.\mathrm{FunctionField}$. The
+assertion, with no further hypotheses on $F$ or on $W$, is that the intermediate field of
+$W.\mathrm{FunctionField}/\mathrm{RatFunc}\,F$ generated by the single element $\mathrm{yCoord}\,W$
+is the top intermediate field, i.e. equals all of $W.\mathrm{FunctionField}$: in classical notation,
+$F(W) = F(x)(y)$, so that $F(W)$ is a simple extension of $F(x)$ generated by the $y$-coordinate
+function.
+
+This is the standard fact that the function field of a plane Weierstrass curve is generated over the
+field of rational functions in $x$ by the coordinate function $y$. Combined with the integrality of
+$\mathrm{yCoord}\,W$ over $\mathrm{RatFunc}\,F$, it yields the finite-dimensionality of
+$W.\mathrm{FunctionField}$ over $\mathrm{RatFunc}\,F$ (of degree at most $2$), and it is used
+further in the construction of principal divisors on the function field and in the descent to a
+countable intermediate field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_adjoin_yCoord_eq_top.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_adjoin_yCoord_eq_top
+
+open Polynomial WeierstrassCurve.Affine in
+theorem solution {F : Type*} [Field F] {W : WeierstrassCurve.Affine F} :
+    IntermediateField.adjoin (RatFunc F) {WeierstrassCurve.Affine.yCoord W} = ⊤ := by
+  rw [eq_top_iff]
+  rintro z -
+  have hpoly : ∀ p : F[X],
+      polyToFunctionField W p ∈ IntermediateField.adjoin (RatFunc F) {yCoord W} := by
+    intro p
+    rw [← algebraMap_polynomial_eq_polyToFunctionField,
+      IsScalarTower.algebraMap_apply F[X] (RatFunc F) W.FunctionField]
+    exact IntermediateField.algebraMap_mem _ _
+  have hcoord : ∀ r : W.CoordinateRing,
+      algebraMap W.CoordinateRing W.FunctionField r
+        ∈ IntermediateField.adjoin (RatFunc F) {yCoord W} := by
+    intro r
+    obtain ⟨p, q, rfl⟩ := WeierstrassCurve.Affine.CoordinateRing.exists_smul_basis_eq r
+    rw [algebraMap_smul_basis]
+    exact add_mem (hpoly p)
+      (mul_mem (hpoly q) (IntermediateField.mem_adjoin_simple_self _ _))
+  obtain ⟨a, b, hb, hab⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  rw [← hab]
+  exact div_mem (hcoord a) (hcoord b)
+
+end S_WeierstrassCurve_Affine_adjoin_yCoord_eq_top
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_adjoin_yCoord_eq_top (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.Affine.adjoin_yCoord_eq_top {F : Type*} [Field F]
+    {W : WeierstrassCurve.Affine F} :
+    IntermediateField.adjoin (RatFunc F) {WeierstrassCurve.Affine.yCoord W} = ⊤ :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_algHom_ext_of_forall_restrictAlong_placeOfPoint_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_algHom_ext_of_forall_restrictAlong_placeOfPoint_eq.lean
new file mode 100644
index 0000000000..517f8f4e33
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_algHom_ext_of_forall_restrictAlong_placeOfPoint_eq.lean
@@ -0,0 +1,727 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.algHom_ext_of_forall_restrictAlong_placeOfPoint_eq
+(00c8479e-a9de-523d-aa65-d8e112a1ca60) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission df941fb7-1835-5792-a704-641189212b6d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Tactic.NormNum.Prime
+import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum
+
+/-!
+# Integral maps into K(E) determined by action on places
+
+Theorem statement: `WeierstrassCurve.Affine.algHom_ext_of_forall_restrictAlong_placeOfPoint_eq`
+(`00c8479e-a9de-523d-aa65-d8e112a1ca60`), by Claude, 2026-09-05.
+
+Proof: submission `df941fb7-1835-5792-a704-641189212b6d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field of characteristic zero and let $V$ be an affine Weierstrass
+curve over $K$ which is elliptic. Assume $V$ carries a genus-one place gate: a bijection
+`placeOfPoint` between the point group $V.\mathrm{Point}$ and the set of places of
+$V.\mathrm{FunctionField}$ over $K$ (a place being a valuation subring, distinct from the whole
+field, containing the image of $K$ and having principal ideals), all of whose places have degree
+$1$; assume the gate is centred, i.e. for every nonsingular affine point $(x,y)$ the classes of
+$X-x$ and $Y-y$ in the coordinate ring map into the nonunits of the valuation subring attached to
+$(x,y)$; and assume the Abel theorem holds for $V$, i.e. a divisor of degree $0$ is principal
+precisely when its image under `divisorSum` is $0$. Let $F'$ be a field with a $K$-algebra structure
+such that every place $w$ of $F'$ over $K$ is rational, meaning $K \to \kappa(w)$ is surjective onto
+the residue field. Let $\varphi_1,\varphi_2 : F' \to V.\mathrm{FunctionField}$ be $K$-algebra
+homomorphisms whose underlying ring homomorphisms are integral. If for every point $P$ of $V$ the
+pull-backs along $\varphi_1$ and along $\varphi_2$ of the place `placeOfPoint P` agree as places of
+$F'$ — that is, the two preimage valuation subrings coincide — then $\varphi_1 = \varphi_2$.
+
+This is a rigidity statement: an integral $K$-embedding of a field into the function field of an
+elliptic curve is determined by the induced map on places, the pull-back of the place at each point
+of the curve. It is used in the construction of point homomorphisms from isogeny data, where
+equality of actions on places must be upgraded to equality of the corresponding pull-back maps on
+function fields.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_algHom_ext_of_forall_restrictAlong_placeOfPoint_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open WeierstrassCurve Affine CoordinateRing AlgebraicCurve Place Polynomial IsDedekindDomain
+
+open scoped Bivariate
+
+--set_option linter.unusedSectionVars false
+
+noncomputable section
+
+namespace WeierstrassCurve
+
+namespace Affine
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem S13_ofHeightOneSpectrum_injective {R : Type*} [CommRing R] [IsDedekindDomain R]
+    [Algebra R W.FunctionField] [IsFractionRing R W.FunctionField] [Algebra F R]
+    [IsScalarTower F R W.FunctionField] :
+    Function.Injective (AlgebraicCurve.Place.ofHeightOneSpectrum (K := F) (R := R) (F :=
+      W.FunctionField)) := by
+  intro w₁ w₂ h
+  refine HeightOneSpectrum.eq_of_valuation_isEquiv_valuation (K := W.FunctionField) ?_
+  rw [Valuation.isEquiv_iff_valuationSubring]
+  exact congrArg AlgebraicCurve.Place.toValuationSubring h
+
+namespace CoordinateRing
+
+theorem algebraMap_eq_mk_C_C (a : F) :
+    algebraMap F W.CoordinateRing a = CoordinateRing.mk W (C (C a)) := by
+  rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+    Algebra.algebraMap_self_apply]
+  rfl
+
+theorem eq_of_XYIdeal_eq {x₁ y₁ x₂ y₂ : F} (h₂ : W.Equation x₂ y₂)
+    (h : XYIdeal W x₁ (C y₁) = XYIdeal W x₂ (C y₂)) : x₁ = x₂ ∧ y₁ = y₂ := by
+  have hne : XYIdeal W x₂ (C y₂) ≠ ⊤ := (XYIdeal_isMaximal h₂).ne_top
+  have hX₁ : XClass W x₁ ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert _ _)
+  have hX₂ : XClass W x₂ ∈ XYIdeal W x₂ (C y₂) := Ideal.subset_span (Set.mem_insert _ _)
+  have hY₁ : YClass W (C y₁) ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  have hY₂ : YClass W (C y₂) ∈ XYIdeal W x₂ (C y₂) :=
+    Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  constructor
+  · by_contra hx
+    apply hne
+    have hsub : XClass W x₁ - XClass W x₂ = algebraMap F W.CoordinateRing (x₂ - x₁) := by
+      rw [XClass, XClass, ← map_sub, algebraMap_eq_mk_C_C]
+      grind
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hX₁ hX₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hx hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+  · by_contra hy
+    apply hne
+    have hsub : YClass W (C y₁) - YClass W (C y₂) = algebraMap F W.CoordinateRing (y₂ - y₁) := by
+      rw [YClass, YClass, ← map_sub, algebraMap_eq_mk_C_C]
+      grind
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hY₁ hY₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hy hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+
+def heightOneSpectrumOfEquation {x y : F} (h : W.Equation x y) :
+    HeightOneSpectrum W.CoordinateRing where
+  asIdeal := XYIdeal W x (C y)
+  isPrime := (XYIdeal_isMaximal h).isPrime
+  ne_bot := XYIdeal_ne_bot x (C y)
+
+@[scoped simp]
+theorem heightOneSpectrumOfEquation_asIdeal {x y : F} (h : W.Equation x y) :
+    (heightOneSpectrumOfEquation h).asIdeal = XYIdeal W x (C y) := rfl
+
+theorem exists_sub_algebraMap_mem {x y : F} (h : W.Equation x y) (r : W.CoordinateRing) :
+    ∃ c : F, r - algebraMap F W.CoordinateRing c ∈ XYIdeal W x (C y) := by
+  set e := quotientXYIdealEquiv (W' := W) (x := x) (y := C y) h
+  refine ⟨e (Ideal.Quotient.mk _ r), ?_⟩
+  rw [← Ideal.Quotient.eq_zero_iff_mem, map_sub, sub_eq_zero]
+  apply e.injective
+  rw [← Ideal.Quotient.algebraMap_eq, ← IsScalarTower.algebraMap_apply, AlgEquiv.commutes,
+    Algebra.algebraMap_self_apply]
+
+end CoordinateRing
+
+def IsFinitePlace (v : AlgebraicCurve.Place F W.FunctionField) : Prop :=
+  ∀ r : W.CoordinateRing, algebraMap W.CoordinateRing W.FunctionField r ∈ v.toValuationSubring
+
+def IsFinitePlace.ringHom {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    W.CoordinateRing →+* v.toValuationSubring where
+  toFun r := ⟨algebraMap W.CoordinateRing W.FunctionField r, hv r⟩
+  map_one' := Subtype.ext (map_one _)
+  map_mul' a b := Subtype.ext (map_mul _ a b)
+  map_zero' := Subtype.ext (map_zero _)
+  map_add' a b := Subtype.ext (map_add _ a b)
+
+@[scoped simp]
+theorem IsFinitePlace.coe_ringHom_apply {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) (r : W.CoordinateRing) :
+    (hv.ringHom r : W.FunctionField) = algebraMap W.CoordinateRing W.FunctionField r := rfl
+
+def IsFinitePlace.centre {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    Ideal W.CoordinateRing :=
+  (IsLocalRing.maximalIdeal v.toValuationSubring).comap hv.ringHom
+
+theorem IsFinitePlace.centre_isPrime {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre.IsPrime :=
+  Ideal.IsPrime.comap _
+
+theorem IsFinitePlace.inv_mem {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) {r : W.CoordinateRing} (hr : r ∉ hv.centre) :
+    (algebraMap W.CoordinateRing W.FunctionField r)⁻¹ ∈ v.toValuationSubring := by
+  have hunit : IsUnit (hv.ringHom r) := by
+    simpa [IsFinitePlace.centre, IsLocalRing.mem_maximalIdeal] using hr
+  obtain ⟨t, ht⟩ := hunit.exists_right_inv
+  have ht' : algebraMap W.CoordinateRing W.FunctionField r * (t : W.FunctionField) = 1 := by
+    simpa using congrArg (fun a : v.toValuationSubring => (a : W.FunctionField)) ht
+  grind
+
+theorem IsFinitePlace.centre_ne_bot {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre ≠ ⊥ := by
+  intro hbot
+  apply v.ne_top'
+  rw [eq_top_iff]
+  rintro z -
+  obtain ⟨r, s, hs, hz⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  have hs0 : s ∉ hv.centre := by
+    rw [hbot, Ideal.mem_bot]
+    exact fun h => nonZeroDivisors.ne_zero hs h
+  rw [← hz, div_eq_mul_inv]
+  exact mul_mem (hv r) (hv.inv_mem hs0)
+
+variable [IsDedekindDomain W.CoordinateRing]
+
+def placeOfEquation {x y : F} (h : W.Equation x y) :
+    AlgebraicCurve.Place F W.FunctionField :=
+  AlgebraicCurve.Place.ofHeightOneSpectrum (heightOneSpectrumOfEquation h)
+
+theorem placeOfEquation_injective {x₁ y₁ x₂ y₂ : F} (h₁ : W.Equation x₁ y₁)
+    (h₂ : W.Equation x₂ y₂) (h : placeOfEquation h₁ = placeOfEquation h₂) :
+    x₁ = x₂ ∧ y₁ = y₂ :=
+  eq_of_XYIdeal_eq h₂
+    (congrArg HeightOneSpectrum.asIdeal (S13_ofHeightOneSpectrum_injective h))
+
+theorem isFinitePlace_placeOfEquation {x y : F} (h : W.Equation x y) :
+    IsFinitePlace (placeOfEquation h) := fun r =>
+  (heightOneSpectrumOfEquation h).valuation_le_one r
+
+theorem isFinitePlace_iff_exists_placeOfEquation [IsAlgClosed F]
+    (v : AlgebraicCurve.Place F W.FunctionField) :
+    IsFinitePlace v ↔ ∃ (x y : F) (h : W.Equation x y), v = placeOfEquation h := by
+  constructor
+  · intro hv
+    have := hv.centre_isPrime
+    have hmax : hv.centre.IsMaximal := Ideal.IsPrime.isMaximal hv.centre_isPrime hv.centre_ne_bot
+    obtain ⟨x, y, hxy, hXY⟩ :=
+      CoordinateRing.exists_eq_XYIdeal (W := W) (P := hv.centre) hv.centre_ne_bot
+    refine ⟨x, y, hxy, ?_⟩
+    set w : HeightOneSpectrum W.CoordinateRing := heightOneSpectrumOfEquation hxy with hw
+    set A : ValuationSubring W.FunctionField :=
+      HeightOneSpectrum.valuationSubringAtPrime W.FunctionField w with hA
+    have hAded : IsDedekindDomain A := by rw [hA]; infer_instance
+    have hle : A ≤ v.toValuationSubring := by
+      intro z hz
+      rw [hA] at hz
+      obtain ⟨r, s, hs, rfl⟩ := hz
+      have hs' : s ∉ hv.centre := by
+        intro hmem
+        rw [hXY] at hmem
+        exact hs hmem
+      exact mul_mem (hv r) (hv.inv_mem hs')
+    have hSP : A.ofPrime (A.idealOfLE v.toValuationSubring hle) = v.toValuationSubring :=
+      ValuationSubring.ofPrime_idealOfLE A v.toValuationSubring hle
+    rcases eq_or_ne (A.idealOfLE v.toValuationSubring hle) ⊥ with hP | hP
+    · exfalso
+      apply v.ne_top'
+      have h2 : A.ofPrime ⊥ ≤ A.ofPrime (A.idealOfLE v.toValuationSubring hle) :=
+        ValuationSubring.ofPrime_le_of_le (h := hP.le)
+      rw [ValuationSubring.ofPrime_bot] at h2
+      grind
+    · have hPmax : (A.idealOfLE v.toValuationSubring hle).IsMaximal :=
+        Ideal.IsPrime.isMaximal inferInstance hP
+      have hPeq : A.idealOfLE v.toValuationSubring hle = IsLocalRing.maximalIdeal A :=
+        IsLocalRing.eq_maximalIdeal hPmax
+      have h3 : A.ofPrime (A.idealOfLE v.toValuationSubring hle)
+          = A.ofPrime (IsLocalRing.maximalIdeal A) :=
+        le_antisymm (ValuationSubring.ofPrime_le_of_le (h := hPeq.ge))
+          (ValuationSubring.ofPrime_le_of_le (h := hPeq.le))
+      rw [ValuationSubring.ofPrime_top] at h3
+      have hAv : A = v.toValuationSubring := h3.symm.trans hSP
+      refine (AlgebraicCurve.Place.ext ?_).symm
+      change (AlgebraicCurve.Place.ofHeightOneSpectrum w).toValuationSubring = v.toValuationSubring
+      rw [AlgebraicCurve.Place.ofHeightOneSpectrum_toValuationSubring,
+        ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact hAv
+  · rintro ⟨x, y, h, rfl⟩
+    exact isFinitePlace_placeOfEquation h
+
+scoped instance S13_instIsDedekindDomainCoordinateRing [IsAlgClosed F] [W.IsElliptic] :
+    IsDedekindDomain W.CoordinateRing :=
+  CoordinateRing.isDedekindDomain (W := W)
+
+section CentredGate
+
+variable [DecidableEq F] [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W]
+
+omit [DecidableEq F] in
+@[scoped simp]
+theorem placeOfPoint_some {x y : F} (h : W.Nonsingular x y) :
+    placeOfPoint (.some x y h) = placeOfEquation h.left := by
+  classical
+  exact
+    placeOfPoint_some_eq_ofHeightOneSpectrum h (heightOneSpectrumOfEquation h.left) rfl
+
+namespace InfinitePlace
+
+def place : AlgebraicCurve.Place F W.FunctionField := placeOfPoint (0 : W.Point)
+
+omit [DecidableEq F] [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem deg_eq_one : (place : AlgebraicCurve.Place F W.FunctionField).deg = 1 := by
+  classical
+  exact
+    deg_placeOfPoint (W := W) 0
+
+omit [DecidableEq F] [IsDedekindDomain W.CoordinateRing] in
+theorem not_isFinitePlace [IsAlgClosed F] [W.IsElliptic] :
+    ¬ IsFinitePlace (place : AlgebraicCurve.Place F W.FunctionField) := by
+  classical
+  exact
+    fun h =>
+     algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero (W := W) (h _)
+
+omit [DecidableEq F] in
+theorem eq_of_not_isFinitePlace
+    (v : AlgebraicCurve.Place F W.FunctionField) (hv : ¬ IsFinitePlace v) :
+    v = place := by
+  classical
+  obtain ⟨P, rfl⟩ : ∃ P : W.Point, placeOfPoint P = v :=
+    ⟨(pointEquivPlace (W := W)).symm v, (pointEquivPlace (W := W)).apply_symm_apply v⟩
+  cases P with
+  | zero => rfl
+  | some x y h =>
+      exact absurd (placeOfPoint_some (W := W) h ▸ isFinitePlace_placeOfEquation h.left) hv
+
+end InfinitePlace
+
+omit [DecidableEq F] [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+@[scoped simp]
+theorem placeOfPoint_zero : placeOfPoint (.zero : W.Point) = InfinitePlace.place :=
+  rfl
+
+omit [DecidableEq F] [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_zero' : placeOfPoint (0 : W.Point) = InfinitePlace.place :=
+  rfl
+
+omit [DecidableEq F] [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_injective : Function.Injective (placeOfPoint (W := W)) :=
+  (pointEquivPlace (W := W)).injective
+
+omit [DecidableEq F] [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_surjective (_hΔ : W.Δ ≠ 0) : Function.Surjective (placeOfPoint (W := W)) :=
+  (pointEquivPlace (W := W)).surjective
+
+omit [DecidableEq F] [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_surjective' : Function.Surjective (placeOfPoint (W := W)) :=
+  (pointEquivPlace (W := W)).surjective
+
+end CentredGate
+end WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+
+namespace Affine
+
+open WeierstrassCurve.Affine WeierstrassCurve
+
+scoped instance instHasPrincipalDivisorsFunctionField_s13 {F : Type*} [Field F] [CharZero F]
+    {W : Affine F} : HasPrincipalDivisors F W.FunctionField :=
+  hasPrincipalDivisors_functionField W
+
+section AutoNorm
+variable {F : Type*} [Field F] [CharZero F]
+variable {V W : Affine F} [V.IsElliptic] [W.IsElliptic]
+
+omit [WeierstrassCurve.IsElliptic V]
+  [WeierstrassCurve.IsElliptic W] in
+theorem normFormulaAlong_of_elliptic (ι : V.FunctionField →ₐ[F] W.FunctionField)
+    (hfin : FiniteAlong F ι) : NormFormulaAlong F ι hfin := by
+  classical
+  have : HasPrincipalDivisors F W.FunctionField := hasPrincipalDivisors_functionField W
+  have : CharZero V.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap F V.FunctionField).injective
+  have hsep : SeparableAlong F ι := by
+    let := algebraAlong ι
+    have := isScalarTower_along ι
+    have : Module.Finite V.FunctionField W.FunctionField := hfin
+    change Algebra.IsSeparable V.FunctionField W.FunctionField
+    infer_instance
+  exact AlgebraicCurve.normFormulaAlong ι hfin hsep
+
+end AutoNorm
+
+namespace IsogenyEndDatum
+
+open WeierstrassCurve.Affine.IsogenyEndDatum
+
+variable {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [GenusOnePlaceGate W] [AbelTheorem W]
+
+omit [DecidableEq F] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate]
+  [W.AbelTheorem] in
+private theorem normFormulaAlong_auto
+    (D : IsogenyEndDatum W) :
+    NormFormulaAlong F D.ι D.hfin :=
+  normFormulaAlong_of_elliptic D.ι D.hfin
+
+private def _root_.WeierstrassCurve.Affine.IsogenyEndDatum.pointEnd' (D : IsogenyEndDatum W) :
+    AddMonoid.End W.Point := D.pointEnd D.normFormulaAlong_auto
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd_eq_pointEnd' (D : IsogenyEndDatum W) (hN : NormFormulaAlong F D.ι D.hfin) :
+    D.pointEnd hN = D.pointEnd' := rfl
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd'_apply (D : IsogenyEndDatum W) (P : W.Point) :
+    D.pointEnd' P = genusOnePic0Equiv W
+      (Pic0.pushforwardAlongHom D.ι D.hι D.hfin D.normFormulaAlong_auto (pointClass P)) :=
+  pointEnd_apply D _ P
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd'_eq_of_seam (D : IsogenyEndDatum W) (g : W.Point → W.Point) (hg0 : g 0 = 0)
+    (hg : ∀ P, (placeOfPoint P).restrictAlong D.ι D.hι = placeOfPoint (g P)) (P : W.Point) :
+    D.pointEnd' P = g P :=
+  pointEnd_eq_of_seam D _ g hg0 hg P
+
+end IsogenyEndDatum
+
+end WeierstrassCurve.Affine
+
+section
+
+namespace WeierstrassCurve
+
+namespace Affine
+
+variable {F : Type*} [Field F] {W : Affine F} (v : AlgebraicCurve.Place F W.FunctionField)
+
+theorem exists_equation [IsAlgClosed F] (W : Affine F) (x₀ : F) :
+    ∃ y₀ : F, W.Equation x₀ y₀ := by
+  set P : F[X] := Polynomial.X ^ 2 + Polynomial.C (W.a₁ * x₀ + W.a₃) * Polynomial.X
+    - Polynomial.C (x₀ ^ 3 + W.a₂ * x₀ ^ 2 + W.a₄ * x₀ + W.a₆) with hPdef
+  have hPdeg : P.degree ≠ 0 := by
+    have hcoeff : P.coeff 2 = 1 := by
+      rw [hPdef]
+      simp only [Polynomial.coeff_sub, Polynomial.coeff_add, Polynomial.coeff_X_pow,
+        Polynomial.coeff_C_mul, Polynomial.coeff_X, Polynomial.coeff_C]
+      norm_num
+    intro hcon
+    have h2 : P.coeff 2 = 0 := by
+      refine Polynomial.coeff_eq_zero_of_degree_lt ?_
+      rw [hcon]
+      norm_num
+    grind
+  obtain ⟨y₀, hy₀⟩ := IsAlgClosed.exists_root P hPdeg
+  refine ⟨y₀, ?_⟩
+  rw [equation_iff]
+  have h3 : P.eval y₀ = 0 := hy₀
+  rw [hPdef] at h3
+  simp only [Polynomial.eval_sub, Polynomial.eval_add, Polynomial.eval_pow,
+    Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_X] at h3
+  linear_combination h3
+
+end WeierstrassCurve.Affine
+end
+
+section
+
+open Polynomial
+
+universe u r s v
+
+namespace WeierstrassCurve
+
+open WeierstrassCurve
+
+variable {F : Type u} [Field F] [IsAlgClosed F] (W : WeierstrassCurve F) [W.IsElliptic]
+
+lemma point_infinite : Infinite W.toAffine.Point := by
+  refine Infinite.of_injective
+    (fun x => .some x _ (equation_iff_nonsingular.mp (exists_equation W x).choose_spec))
+    (fun x x' hxx' => by grind)
+
+end WeierstrassCurve
+
+end
+
+section
+
+open IsLocalRing
+
+namespace AlgebraicCurve
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.isUnit_mk_of_ord_eq_zero {f : F} (hf : f ≠ 0)
+    (h : v.ord f = 0) :
+    IsUnit (⟨f, AlgebraicCurve.Place.mem_of_ord_nonneg v hf h.ge⟩ : v.toValuationSubring) := by
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ
+  rw [h, zpow_zero, mul_one] at hu
+  have huf : (⟨f, AlgebraicCurve.Place.mem_of_ord_nonneg v hf h.ge⟩ : v.toValuationSubring)
+      = (u : v.toValuationSubring) := Subtype.ext hu
+  rw [huf]
+  exact u.isUnit
+
+private theorem _root_.AlgebraicCurve.Place.residue_ne_zero_of_ord_eq_zero {f : F} (hf : f ≠ 0)
+    (h : v.ord f = 0) :
+    residue v.toValuationSubring (⟨f, AlgebraicCurve.Place.mem_of_ord_nonneg v hf h.ge⟩ :
+      v.toValuationSubring)
+      ≠ 0 :=
+  (residue_ne_zero_iff_isUnit _).mpr (v.isUnit_mk_of_ord_eq_zero hf h)
+
+private theorem _root_.AlgebraicCurve.Place.evalAt_ne_zero (hv : v.IsRational) {f : F} (hf : f ≠ 0)
+    (h : v.ord f = 0) :
+    v.evalAt f ≠ 0 := by
+  intro h0
+  have hres := v.algebraMap_evalAt hv (AlgebraicCurve.Place.mem_of_ord_nonneg v hf h.ge)
+  rw [h0, _root_.map_zero] at hres
+  exact v.residue_ne_zero_of_ord_eq_zero hf h hres.symm
+
+end Place
+
+end AlgebraicCurve
+end
+
+section
+
+open IsLocalRing
+
+namespace AlgebraicCurve
+
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.ord_sub_evalAt_pos (hrat : v.IsRational) {f : F}
+    (hf : f ∈ v.toValuationSubring)
+    (hne : f - algebraMap K F (v.evalAt f) ≠ 0) :
+    0 < v.ord (f - algebraMap K F (v.evalAt f)) := by
+  have hmem : f - algebraMap K F (v.evalAt f) ∈ v.toValuationSubring :=
+    sub_mem hf (v.algebraMap_mem' _)
+  rcases eq_or_ne (v.ord (f - algebraMap K F (v.evalAt f))) 0 with h0 | h0
+  · exfalso
+    refine v.evalAt_ne_zero hrat hne h0 ?_
+    have hres : algebraMap K v.ResidueField
+        (v.evalAt (f - algebraMap K F (v.evalAt f))) = 0 := by
+      rw [v.algebraMap_evalAt hrat hmem]
+      have hcoe : (⟨f - algebraMap K F (v.evalAt f), hmem⟩ : v.toValuationSubring)
+          = ⟨f, hf⟩ - algebraMap K v.toValuationSubring (v.evalAt f) := by
+        refine Subtype.ext ?_
+        change f - algebraMap K F (v.evalAt f)
+          = f - (algebraMap K v.toValuationSubring (v.evalAt f) : F)
+        rw [Place.coe_algebraMap]
+      rw [hcoe, map_sub, sub_eq_zero, ← v.algebraMap_evalAt hrat hf,
+        IsScalarTower.algebraMap_apply K v.toValuationSubring v.ResidueField,
+        IsLocalRing.ResidueField.algebraMap_eq]
+    exact (map_eq_zero_iff _ (algebraMap K v.ResidueField).injective).mp hres
+  · have hnonneg := AlgebraicCurve.Place.ord_nonneg_of_mem v hmem
+    omega
+
+end Place
+end AlgebraicCurve
+end
+
+namespace AlgebraicCurve
+
+theorem finite_setOf_ord_ne_zero_of_finiteDimensional {K : Type*} [Field K] {F' : Type*} [Field F']
+    [Algebra K F'] [HasPrincipalDivisors K F'] {f : F'} (hf : f ≠ 0) :
+    {w : Place K F' | w.ord f ≠ 0}.Finite := by
+  obtain ⟨D, hD, -⟩ := HasPrincipalDivisors.exists_divisor (K := K) (F := F') f hf
+  refine (D.support.finite_toSet).subset ?_
+  grind
+
+end AlgebraicCurve
+
+section
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+namespace WeierstrassCurve
+
+namespace KwNo3aHbadRiqsucrA1a
+
+section RouteEta
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+
+theorem no3ahbad_riqsucr_a1a_ord_pos_of_restrictAlong_ord_pos
+    (φ : F' →ₐ[K] F) (hφ : φ.toRingHom.IsIntegral) (v : Place K F)
+    (f : F') (c : K) (hord : (v.restrictAlong φ hφ).ord (f - algebraMap K F' c) > 0) :
+    v.ord (φ f - algebraMap K F c) > 0 := by
+  have hrw : φ f - algebraMap K F c = φ (f - algebraMap K F' c) := by
+    rw [map_sub, AlgHom.commutes]
+  rw [hrw, Place.ord_restrictAlong φ hφ v (f - algebraMap K F' c)]
+  refine mul_pos ?_ hord
+  unfold Place.ramificationIndexAlong
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  exact_mod_cast v.ramificationIndex_pos (F := F')
+
+end RouteEta
+
+section FiniteZeros
+
+variable {F : Type*} [Field F] [CharZero F] {V : Affine F}
+  [WeierstrassCurve.Affine.GenusOnePlaceGate V]
+
+theorem no3ahbad_riqsucr_a1a_finite_ord_ne_zero (h : V.FunctionField) (hne : h ≠ 0) :
+    {P : V.Point | (placeOfPoint P).ord h ≠ 0}.Finite := by
+  have hfin : {v : Place F V.FunctionField | v.ord h ≠ 0}.Finite :=
+    finite_setOf_ord_ne_zero_of_finiteDimensional hne
+  refine .of_finite_image (hfin.subset ?_) (Set.injOn_of_injective placeOfPoint_injective)
+  grind
+
+end FiniteZeros
+
+section Ext
+
+variable {K F' : Type*} [Field K] [Field F'] [Algebra K F']
+variable {V : Affine K} [WeierstrassCurve.Affine.GenusOnePlaceGate V]
+
+theorem no3ahbad_riqsucr_a1a_exists_residue (w : Place K F')
+    (hsurj : Function.Surjective (algebraMap K w.ResidueField))
+    (f : F') (hf : w.ord f ≥ 0) :
+    ∃ c : K, f = algebraMap K F' c ∨ w.ord (f - algebraMap K F' c) > 0 := by
+  classical
+  rcases eq_or_ne f 0 with rfl | hf0
+  · exact ⟨0, Or.inl (algebraMap K F').map_zero.symm⟩
+  refine ⟨w.evalAt f, ?_⟩
+  rcases eq_or_ne (f - algebraMap K F' (w.evalAt f)) 0 with heq | hne
+  · grind
+  · exact Or.inr (w.ord_sub_evalAt_pos hsurj (AlgebraicCurve.Place.mem_of_ord_nonneg w hf0 hf) hne)
+
+theorem no3ahbad_riqsucr_a1a_ord_sub_pos_of_pos
+    (v : Place K F') {a b : F'} (ha : v.ord a > 0) (hb : v.ord b > 0) (hab : a ≠ b) :
+    v.ord (a - b) > 0 := by
+  classical
+  have ha0 : a ≠ 0 := fun h => absurd (h ▸ ha) (by simp [v.ord_zero])
+  have hb0 : b ≠ 0 := fun h => absurd (h ▸ hb) (by simp [v.ord_zero])
+  have hne : a - b ≠ 0 := sub_ne_zero.mpr hab
+  have hval : v.adicValuation (a - b) ≤ max (v.adicValuation a) (v.adicValuation b) := by
+    have h := v.adicValuation.map_add a (-b)
+    rwa [← sub_eq_add_neg, Valuation.map_neg] at h
+  rcases max_cases (v.adicValuation a) (v.adicValuation b) with ⟨hmax, -⟩ | ⟨hmax, -⟩ <;>
+    rw [hmax] at hval
+  · have := (WithZero.log_le_log (v.adicValuation_ne_zero hne)
+      (v.adicValuation_ne_zero ha0)).mpr hval
+    grind [Place.ord]
+  · have := (WithZero.log_le_log (v.adicValuation_ne_zero hne)
+      (v.adicValuation_ne_zero hb0)).mpr hval
+    grind [Place.ord]
+
+theorem no3ahbad_riqsucr_a1a_algHom_ext_of_restrictAlong_placeOfPoint_eq [CharZero K]
+    (hVinf : Infinite V.Point) (hrat : ∀ w : Place K F', w.IsRational)
+    (φ₁ φ₂ : F' →ₐ[K] V.FunctionField)
+    (hφ₁ : φ₁.toRingHom.IsIntegral) (hφ₂ : φ₂.toRingHom.IsIntegral)
+    (hres : ∀ P : V.Point,
+      (placeOfPoint P).restrictAlong φ₁ hφ₁ = (placeOfPoint P).restrictAlong φ₂ hφ₂) :
+    φ₁ = φ₂ := by
+  ext f
+  by_contra hne
+  have hne' : φ₁ f - φ₂ f ≠ 0 := sub_ne_zero.mpr hne
+  have hfin := no3ahbad_riqsucr_a1a_finite_ord_ne_zero (V := V) (φ₁ f - φ₂ f) hne'
+  have hpoles : {P : V.Point |
+      ((placeOfPoint P).restrictAlong φ₁ hφ₁).ord f < 0}.Finite := by
+    rcases eq_or_ne (φ₁ f) 0 with h0 | h0
+    · exact absurd (by
+        have hf0 : f = 0 := φ₁.injective (by simp [h0])
+        simp [hf0]) hne'
+    · refine (no3ahbad_riqsucr_a1a_finite_ord_ne_zero (V := V) (φ₁ f) h0).subset ?_
+      intro P hP
+      simp only [Set.mem_ofPred_eq] at hP ⊢
+      rw [Place.ord_restrictAlong φ₁ hφ₁ (placeOfPoint P) f]
+      exact ne_of_lt (mul_neg_of_pos_of_neg (by
+        unfold Place.ramificationIndexAlong
+        let := algebraAlong φ₁; have := isScalarTower_along φ₁
+        have := isIntegral_along φ₁ hφ₁
+        exact_mod_cast (placeOfPoint P).ramificationIndex_pos (F := F')) hP)
+  have hcofin : {P : V.Point | (placeOfPoint P).ord (φ₁ f - φ₂ f) > 0}ᶜ ⊆
+      {P | ((placeOfPoint P).restrictAlong φ₁ hφ₁).ord f < 0} := by
+    intro P hP
+    simp only [Set.mem_compl_iff, Set.mem_ofPred_eq, not_lt] at hP ⊢
+    by_contra hge
+    simp only [not_lt] at hge
+    obtain ⟨c, hc⟩ := no3ahbad_riqsucr_a1a_exists_residue
+      ((placeOfPoint P).restrictAlong φ₁ hφ₁) (hrat _) f hge
+    rcases hc with heq | hc
+    · exact absurd (heq ▸ (φ₁.commutes c).trans (φ₂.commutes c).symm) hne
+    have h1 := no3ahbad_riqsucr_a1a_ord_pos_of_restrictAlong_ord_pos φ₁ hφ₁
+      (placeOfPoint P) f c hc
+    have h2 := no3ahbad_riqsucr_a1a_ord_pos_of_restrictAlong_ord_pos φ₂ hφ₂
+      (placeOfPoint P) f c (hres P ▸ hc)
+    have h12 := no3ahbad_riqsucr_a1a_ord_sub_pos_of_pos (placeOfPoint P) h1 h2
+      (fun heq => hne (sub_left_inj.mp heq))
+    grind
+  have hcof_fin : {P : V.Point | (placeOfPoint P).ord (φ₁ f - φ₂ f) > 0}ᶜ.Finite :=
+    hpoles.subset hcofin
+  have hset_fin : (Set.univ : Set V.Point).Finite := by
+    rw [← Set.compl_union_self {P | (placeOfPoint P).ord (φ₁ f - φ₂ f) > 0}]
+    exact hcof_fin.union (hfin.subset (fun P hP => ne_of_gt hP))
+  exact hVinf.not_finite (Set.finite_univ_iff.mp hset_fin)
+
+end Ext
+end KwNo3aHbadRiqsucrA1a
+end WeierstrassCurve
+end
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve Place in
+universe u in
+theorem solution
+    {K : Type u} [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+    {V : WeierstrassCurve.Affine K} [V.IsElliptic]
+    [GenusOnePlaceGate V] [GenusOnePlaceGate.IsCentred V] [AbelTheorem V]
+    {F' : Type*} [Field F'] [Algebra K F'] (hrat : ∀ w : AlgebraicCurve.Place K F', w.IsRational)
+    (φ₁ φ₂ : F' →ₐ[K] V.FunctionField)
+    (hφ₁ : φ₁.toRingHom.IsIntegral) (hφ₂ : φ₂.toRingHom.IsIntegral)
+    (hres : ∀ P : V.Point,
+      (placeOfPoint P).restrictAlong φ₁ hφ₁ = (placeOfPoint P).restrictAlong φ₂ hφ₂) :
+    φ₁ = φ₂ :=
+  KwNo3aHbadRiqsucrA1a.no3ahbad_riqsucr_a1a_algHom_ext_of_restrictAlong_placeOfPoint_eq
+    (WeierstrassCurve.point_infinite (W := V)) hrat φ₁ φ₂ hφ₁ hφ₂ hres
+
+end
+
+end privateSection
+
+public section publicSection
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+universe u
+theorem WeierstrassCurve.Affine.algHom_ext_of_forall_restrictAlong_placeOfPoint_eq
+    {K : Type u} [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+    {V : WeierstrassCurve.Affine K} [V.IsElliptic]
+    [GenusOnePlaceGate V] [GenusOnePlaceGate.IsCentred V] [AbelTheorem V]
+    {F' : Type*} [Field F'] [Algebra K F'] (hrat : ∀ w : AlgebraicCurve.Place K F', w.IsRational)
+    (φ₁ φ₂ : F' →ₐ[K] V.FunctionField)
+    (hφ₁ : φ₁.toRingHom.IsIntegral) (hφ₂ : φ₂.toRingHom.IsIntegral)
+    (hres : ∀ P : V.Point,
+      (placeOfPoint P).restrictAlong φ₁ hφ₁ = (placeOfPoint P).restrictAlong φ₂ hφ₂) :
+    φ₁ = φ₂ :=
+  solution hrat φ₁ φ₂ hφ₁ hφ₂ hres
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero.lean
new file mode 100644
index 0000000000..f929b19c5a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero.lean
@@ -0,0 +1,120 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.Affine.algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero
+(c0a1c72a-34d3-562d-a713-786175bd2ec5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission fb20e9c2-8602-5b92-9b42-285529e5adc3
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_exists_eq_valuationSubring_of_X_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# At the place of the origin, x is not integral
+
+Theorem statement:
+`WeierstrassCurve.Affine.algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero`
+(`c0a1c72a-34d3-562d-a713-786175bd2ec5`), by Claude, 2026-09-05.
+
+Proof: submission `fb20e9c2-8602-5b92-9b42-285529e5adc3`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field and let $W$ be an affine Weierstrass curve over $F$ which
+is elliptic, equipped with two pieces of data: a `GenusOnePlaceGate` structure, consisting of a
+bijection `pointEquivPlace` between the group $W(F)$ of points `W.Point` and the set of places of
+`W.FunctionField` over $F$ (a place being a valuation subring of the function field which contains
+the image of $F$, is not the whole field, and is a principal ideal ring) together with the assertion
+that every such place has degree $1$, and the mixin `GenusOnePlaceGate.IsCentred`, which asserts
+that for all $x, y \in F$ with $(x,y)$ a nonsingular point of $W$ the images in the function field
+of the classes `CoordinateRing.XClass W x` and `CoordinateRing.YClass W (C y)` lie in the non-units
+of the valuation subring attached by the bijection to `Point.some x y h`. Write `placeOfPoint` for
+the map $W(F) \to \{\text{places}\}$ given by this bijection. The assertion is that the image in
+`W.FunctionField` of the class of $C X$ in the coordinate ring of $W$ — that is, the coordinate
+function $x$ — does not belong to the valuation subring of the place attached to the origin $0$ of
+`W.Point`.
+
+This identifies the place attached to the origin as the place at infinity of the Weierstrass model:
+the affine coordinate function $x$ has a pole there, so the place is not centred on the coordinate
+ring. It is used wherever the point–place dictionary has to be combined with the classification of
+the finite places of an elliptic function field, for instance in the construction of differentials
+and in the study of isogenies and period lattices.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_b3f4ad70
+
+open AlgebraicCurve WeierstrassCurve WeierstrassCurve.Affine
+
+universe u
+
+theorem solution
+    {F : Type u} [Field F] [IsAlgClosed F] {W : WeierstrassCurve.Affine F}
+    [W.IsElliptic]
+    [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] :
+    algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W (Polynomial.C Polynomial.X))
+      ∉ (placeOfPoint (0 : W.Point)).toValuationSubring := by
+  classical
+  intro hXO
+  have : IsDedekindDomain W.CoordinateRing := CoordinateRing.isDedekindDomain W
+  obtain ⟨w, hw⟩ := WeierstrassCurve.Affine.FunctionField.exists_eq_valuationSubring_of_X_mem W
+    (placeOfPoint (0 : W.Point)).toValuationSubring (placeOfPoint (0 : W.Point)).ne_top'
+    (placeOfPoint (0 : W.Point)).algebraMap_mem' hXO
+  have := w.isPrime
+  obtain ⟨a, b, hab, hwI⟩ := CoordinateRing.exists_eq_XYIdeal (W := W) (P := w.asIdeal) w.ne_bot
+  have hns : W.Nonsingular a b := (equation_iff_nonsingular (W := W)).mp hab
+  have h1 : placeOfPoint (Point.some a b hns) = Place.ofHeightOneSpectrum (K := F) w :=
+    WeierstrassCurve.Affine.placeOfPoint_some_eq_ofHeightOneSpectrum hns w hwI
+  have h2 : placeOfPoint (0 : W.Point) = Place.ofHeightOneSpectrum (K := F) w :=
+    AlgebraicCurve.Place.ext (by rw [Place.ofHeightOneSpectrum_toValuationSubring]; exact hw)
+  have h3 : (Point.some a b hns : W.Point) = 0 :=
+    (pointEquivPlace (W := W)).injective (by rw [pointEquivPlace_apply, pointEquivPlace_apply, h1,
+      h2])
+  exact absurd h3 (by rintro ⟨⟩)
+
+end S_OVERLONG_b3f4ad70
+end P2MW
+export P2MW.S_OVERLONG_b3f4ad70
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve WeierstrassCurve WeierstrassCurve.Affine
+
+universe u
+theorem WeierstrassCurve.Affine.algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero
+    {F : Type u} [Field F] [IsAlgClosed F] {W : WeierstrassCurve.Affine F}
+    [W.IsElliptic]
+    [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] :
+    algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W (Polynomial.C Polynomial.X))
+      ∉ (placeOfPoint (0 : W.Point)).toValuationSubring := by
+  classical
+  exact
+    solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_deg_ofHeightOneSpectrum_eq_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_deg_ofHeightOneSpectrum_eq_one.lean
new file mode 100644
index 0000000000..c86d6be222
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_deg_ofHeightOneSpectrum_eq_one.lean
@@ -0,0 +1,202 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.deg_ofHeightOneSpectrum_eq_one
+(d6fc8981-f5b1-59e0-abbf-95e2ae840c17) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2b7a655a-03f8-57c2-a44b-e5b19497f820
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.RingTheory.SimpleRing.Principal
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+
+/-!
+# Places of a Weierstrass function field over ̄ F have degree one
+
+Theorem statement: `WeierstrassCurve.Affine.deg_ofHeightOneSpectrum_eq_one`
+(`d6fc8981-f5b1-59e0-abbf-95e2ae840c17`), by Claude, 2026-09-05.
+
+Proof: submission `2b7a655a-03f8-57c2-a44b-e5b19497f820`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field and let $W$ be an affine Weierstrass curve over $F$ whose
+coordinate ring $W.\mathrm{CoordinateRing}$ is assumed to be a Dedekind domain, and let $w$ be a
+height-one prime of that coordinate ring. Consider the place of the function field
+$W.\mathrm{FunctionField}$ over $F$ attached to $w$ by
+[`AlgebraicCurve.Place.ofHeightOneSpectrum`](def/AlgebraicCurve_DivisorClassGroup.html#L465), that
+is, the datum consisting of the valuation subring of the $w$-adic valuation on the function field,
+together with the verifications that it contains the image of $F$, that it is not the whole field,
+and that it is a principal ideal ring. The assertion is that the degree of this place is $1$, where
+by definition the degree of a place is the $F$-dimension $\mathrm{Module.finrank}$ of the residue
+field of its valuation subring, i.e. of the quotient of the valuation ring by its maximal ideal.
+Equivalently, the residue field of the $w$-adic place is $F$ itself.
+
+This is the statement that over an algebraically closed base field all finite places of the function
+field of an affine Weierstrass curve are rational, i.e. of residue degree one; it is the degree
+computation needed when the divisor-theoretic formalism on Weierstrass curves is set up. It is used
+in the construction of principal divisors on such curves
+([`WeierstrassCurve.Affine.hasPrincipalDivisors_of_isAlgClosed`]
+(thm.html#WeierstrassCurve.Affine.hasPrincipalDivisors_of_isAlgClosed))
+and in the genus-one place argument
+[`WeierstrassCurve.Affine.exists_genusOnePlaceGate_isCentred_abelTheorem`]
+(thm.html#WeierstrassCurve.Affine.exists_genusOnePlaceGate_isCentred_abelTheorem).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_deg_ofHeightOneSpectrum_eq_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open AlgebraicCurve IsDedekindDomain Polynomial WeierstrassCurve WeierstrassCurve.Affine
+open WeierstrassCurve.Affine.CoordinateRing
+open scoped Polynomial.Bivariate
+
+noncomputable section
+
+namespace D5S
+
+section GenericPlace
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem deg_eq_one_of_surjective (v : Place K F)
+    (h : Function.Surjective (algebraMap K v.ResidueField)) : v.deg = 1 := by
+  have hbij : Function.Bijective (algebraMap K v.ResidueField) :=
+    ⟨(algebraMap K v.ResidueField).injective, h⟩
+  change Module.finrank K v.ResidueField = 1
+  rw [← Module.finrank_self K]
+  exact ((AlgEquiv.ofBijective (Algebra.ofId K v.ResidueField) hbij).toLinearEquiv.finrank_eq).symm
+
+end GenericPlace
+
+section GenericDedekind
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R F] [IsFractionRing R F]
+variable [Algebra K R] [IsScalarTower K R F]
+
+theorem deg_ofHeightOneSpectrum_eq_one (w : HeightOneSpectrum R)
+    (hw : ∀ r : R, ∃ c : K, r - algebraMap K R c ∈ w.asIdeal) :
+    (Place.ofHeightOneSpectrum (K := K) (F := F) w).deg = 1 := by
+  set v : Place K F := Place.ofHeightOneSpectrum (K := K) w with hv
+  apply deg_eq_one_of_surjective
+  intro z
+  obtain ⟨a, rfl⟩ := Ideal.Quotient.mk_surjective z
+  obtain ⟨n, d, hd, hnd⟩ : ∃ (n d : R) (_ : d ∈ w.asIdeal.primeCompl),
+      (a : F) * algebraMap R F d = algebraMap R F n := by
+    obtain ⟨n, d, hcase | hcase⟩ := w.exists_primeCompl_mul_eq_or_mul_eq (K := F) (a : F)
+    · exact ⟨n, d, d.2, hcase⟩
+    · refine ⟨(d : R), n, ?_, hcase⟩
+      intro hn
+      refine d.2 ?_
+      replace hn : n ∈ w.asIdeal := hn
+      change (d : R) ∈ w.asIdeal
+      rw [← w.valuation_lt_one_iff_mem (K := F)] at hn ⊢
+      calc w.valuation F (algebraMap R F (d : R))
+          = w.valuation F (a : F) * w.valuation F (algebraMap R F n) := by
+            rw [← map_mul, hcase]
+        _ ≤ 1 * w.valuation F (algebraMap R F n) := mul_le_mul_left a.2 _
+        _ = w.valuation F (algebraMap R F n) := one_mul _
+        _ < 1 := hn
+  obtain ⟨cn, hcn⟩ := hw n
+  obtain ⟨cd, hcd⟩ := hw d
+  have hcd0 : cd ≠ 0 := by
+    rintro rfl
+    rw [map_zero, sub_zero] at hcd
+    exact hd hcd
+  have hcdR : algebraMap K R cd ∉ w.asIdeal := fun hmem =>
+    hd (by simpa using w.asIdeal.add_mem hcd hmem)
+  have hvd : w.valuation F (algebraMap R F d) = 1 :=
+    le_antisymm (w.valuation_le_one d)
+      (not_lt.mp fun hlt => hd ((w.valuation_lt_one_iff_mem (K := F) d).mp hlt))
+  have hvcd : w.valuation F (algebraMap K F cd) = 1 := by
+    rw [IsScalarTower.algebraMap_apply K R F]
+    exact le_antisymm (w.valuation_le_one _)
+      (not_lt.mp fun hlt => hcdR ((w.valuation_lt_one_iff_mem (K := F) _).mp hlt))
+  have hcdF : algebraMap K F cd ≠ 0 := by
+    simpa using hcd0
+  refine ⟨cn / cd, ?_⟩
+  rw [IsScalarTower.algebraMap_apply K v.toValuationSubring v.ResidueField,
+    IsLocalRing.ResidueField.algebraMap_eq]
+  refine (Ideal.Quotient.eq (I := IsLocalRing.maximalIdeal v.toValuationSubring)).mpr ?_
+  have hmem : algebraMap K R cn * d - algebraMap K R cd * n ∈ w.asIdeal := by
+    have heq : algebraMap K R cn * d - algebraMap K R cd * n
+        = -((n - algebraMap K R cn) * d) + n * (d - algebraMap K R cd) := by ring
+    rw [heq]
+    exact w.asIdeal.add_mem (w.asIdeal.neg_mem (w.asIdeal.mul_mem_right _ hcn))
+      (w.asIdeal.mul_mem_left _ hcd)
+  have key : ((algebraMap K v.toValuationSubring (cn / cd) : F) - (a : F))
+      * (algebraMap K F cd * algebraMap R F d)
+      = algebraMap R F (algebraMap K R cn * d - algebraMap K R cd * n) := by
+    rw [Place.coe_algebraMap, map_div₀, map_sub, map_mul, map_mul]
+    simp only [← IsScalarTower.algebraMap_apply K R F]
+    field_simp
+    linear_combination (-(algebraMap K F cd)) * hnd
+  refine (Valuation.mem_maximalIdeal_iff (v := w.valuation F)).mpr ?_
+  change w.valuation F ((algebraMap K v.toValuationSubring (cn / cd) : F) - (a : F)) < 1
+  calc w.valuation F ((algebraMap K v.toValuationSubring (cn / cd) : F) - (a : F))
+      = w.valuation F ((algebraMap K v.toValuationSubring (cn / cd) : F) - (a : F))
+        * (w.valuation F (algebraMap K F cd) * w.valuation F (algebraMap R F d)) := by
+          rw [hvcd, hvd, one_mul, mul_one]
+    _ = w.valuation F (((algebraMap K v.toValuationSubring (cn / cd) : F) - (a : F))
+        * (algebraMap K F cd * algebraMap R F d)) := by rw [map_mul, map_mul]
+    _ = w.valuation F (algebraMap R F (algebraMap K R cn * d - algebraMap K R cd * n)) := by
+          rw [key]
+    _ < 1 := (w.valuation_lt_one_iff_mem (K := F) _).mpr hmem
+
+end GenericDedekind
+
+section Weierstrass
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve.Affine F)
+
+theorem exists_sub_algebraMap_mem {x y : F} (h : W.Equation x y) (r : W.CoordinateRing) :
+    ∃ c : F, r - algebraMap F W.CoordinateRing c ∈ XYIdeal W x (C y) := by
+  set e := CoordinateRing.quotientXYIdealEquiv (W' := W) (x := x) (y := C y) h
+  refine ⟨e (Ideal.Quotient.mk _ r), ?_⟩
+  rw [← Ideal.Quotient.eq_zero_iff_mem, map_sub, sub_eq_zero]
+  apply e.injective
+  rw [← Ideal.Quotient.algebraMap_eq, ← IsScalarTower.algebraMap_apply, AlgEquiv.commutes,
+    Algebra.algebraMap_self_apply]
+
+end Weierstrass
+
+end D5S
+
+theorem solution {F : Type*} [Field F] [IsAlgClosed F] (W : WeierstrassCurve.Affine F)
+    [IsDedekindDomain W.CoordinateRing] (w : IsDedekindDomain.HeightOneSpectrum W.CoordinateRing) :
+    (AlgebraicCurve.Place.ofHeightOneSpectrum (K := F) (F := W.FunctionField) w).deg = 1 := by
+  apply D5S.deg_ofHeightOneSpectrum_eq_one (K := F) (R := W.CoordinateRing)
+  intro r
+  obtain ⟨a, b, hab, hw⟩ :=
+    WeierstrassCurve.Affine.CoordinateRing.exists_eq_XYIdeal (W := W) (P := w.asIdeal) w.ne_bot
+  obtain ⟨c, hc⟩ := D5S.exists_sub_algebraMap_mem W hab r
+  exact ⟨c, hw ▸ hc⟩
+
+end
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.Affine.deg_ofHeightOneSpectrum_eq_one {F : Type*} [Field F] [IsAlgClosed F]
+    (W : WeierstrassCurve.Affine F) [IsDedekindDomain W.CoordinateRing]
+    (w : IsDedekindDomain.HeightOneSpectrum W.CoordinateRing) :
+    (AlgebraicCurve.Place.ofHeightOneSpectrum (K := F) (F := W.FunctionField) w).deg = 1 :=
+  solution W w
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_eq_placeOfPoint_some_of_XClass_mem_nonunits_of_YClass_mem_nonunits.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_eq_placeOfPoint_some_of_XClass_mem_nonunits_of_YClass_mem_nonunits.lean
new file mode 100644
index 0000000000..bbc3df615e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_eq_placeOfPoint_some_of_XClass_mem_nonunits_of_YClass_mem_nonunits.lean
@@ -0,0 +1,121 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.Affine.eq_placeOfPoint_some_of_XClass_mem_nonunits_of_YClass_mem_nonunits
+(ea6ca28e-5425-5a6f-b3c4-b511c0ce9cf4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 27bec31f-bafa-5013-a176-befc6fbbfbc9
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_eq_ofHeightOneSpectrum_of_XClass_mem_nonunits_of_YClass_mem_nonunits
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# A place centred at (x,y) is the gate's place of (x,y)
+
+Theorem statement:
+`WeierstrassCurve.Affine.eq_placeOfPoint_some_of_XClass_mem_nonunits_of_YClass_mem_nonunits`
+(`ea6ca28e-5425-5a6f-b3c4-b511c0ce9cf4`), by Claude, 2026-09-05.
+
+Proof: submission `27bec31f-bafa-5013-a176-befc6fbbfbc9`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field with decidable equality and let $W$ be an affine Weierstrass curve over $F$,
+subject to three instance hypotheses: a `GenusOnePlaceGate` structure on $W$, that is, a bijection
+`pointEquivPlace` between the point set `W.Point` and the places of the function field
+`W.FunctionField` over $F$ (a place being a valuation subring containing the image of $F$, distinct
+from the whole field and a principal ideal ring) all of whose places have degree $1$, with
+`placeOfPoint` denoting this bijection; the centring mixin `GenusOnePlaceGate.IsCentred`, which
+requires that for every nonsingular affine point $(x,y)$ the images in the function field of the
+coordinate-ring classes `CoordinateRing.XClass W x` and `CoordinateRing.YClass W (Polynomial.C y)`
+lie in the nonunits of the valuation subring of `placeOfPoint (Point.some x y h)`; and that
+`W.CoordinateRing` is a Dedekind domain. Let $x,y\in F$ with `h : W.Nonsingular x y`, and let $v$ be
+a place of `W.FunctionField` over $F$ whose valuation subring contains both of those images among
+its nonunits. Then $v$ equals `placeOfPoint (Point.some x y h)`.
+
+This is the uniqueness half of the dictionary between affine points and places: a place centred at a
+nonsingular affine point, in the sense that $X-x$ and $Y-y$ both lie in its maximal ideal, is forced
+to be the place attached to that point by the genus-one gate. It is used when identifying the places
+obtained by restricting along isogenies and Vélu-type maps, in
+[`WeierstrassCurve.Affine.exists_isogenyEndDatum_restrictAlong_placeOfPoint_eq_smul`]
+(thm.html#WeierstrassCurve.Affine.exists_isogenyEndDatum_restrictAlong_placeOfPoint_eq_smul)
+and
+[`WeierstrassCurve.exists_velu2FunctionFieldHom_restrictAlong_placeOfPoint_veluPointMap2`]
+(thm.html#WeierstrassCurve.exists_velu2FunctionFieldHom_restrictAlong_placeOfPoint_veluPointMap2).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_eq_placeOfPoint_some_of_XClass_mem_nonunits_of_YClass_mem_nonunits.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_44eaa769
+
+open AlgebraicCurve WeierstrassCurve WeierstrassCurve.Affine
+
+universe u
+
+theorem solution
+    {F : Type u} [Field F] {W : WeierstrassCurve.Affine F}
+    [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [IsDedekindDomain W.CoordinateRing]
+    {x y : F} (h : W.Nonsingular x y) (v : AlgebraicCurve.Place F W.FunctionField)
+    (hX : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.XClass W x)
+      ∈ v.toValuationSubring.nonunits)
+    (hY : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.YClass W (Polynomial.C y))
+      ∈ v.toValuationSubring.nonunits) :
+    v = placeOfPoint (Point.some x y h) := by
+  classical
+  let w : IsDedekindDomain.HeightOneSpectrum W.CoordinateRing :=
+    ⟨CoordinateRing.XYIdeal W x (Polynomial.C y), (CoordinateRing.XYIdeal_isMaximal h.left).isPrime,
+      CoordinateRing.XYIdeal_ne_bot x (Polynomial.C y)⟩
+  have hw : w.asIdeal = CoordinateRing.XYIdeal W x (Polynomial.C y) := rfl
+  rw [AlgebraicCurve.Place.eq_ofHeightOneSpectrum_of_XClass_mem_nonunits_of_YClass_mem_nonunits v hX
+    hY w hw,
+    WeierstrassCurve.Affine.placeOfPoint_some_eq_ofHeightOneSpectrum h w hw]
+
+end S_OVERLONG_44eaa769
+end P2MW
+export
+  P2MW.S_OVERLONG_44eaa769
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve WeierstrassCurve WeierstrassCurve.Affine
+
+universe u
+theorem WeierstrassCurve.Affine.eq_placeOfPoint_some_of_XClass_mem_nonunits_of_YClass_mem_nonunits
+    {F : Type u} [Field F] {W : WeierstrassCurve.Affine F}
+    [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [IsDedekindDomain W.CoordinateRing]
+    {x y : F} (h : W.Nonsingular x y) (v : AlgebraicCurve.Place F W.FunctionField)
+    (hX : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.XClass W x)
+      ∈ v.toValuationSubring.nonunits)
+    (hY : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.YClass W (Polynomial.C y))
+      ∈ v.toValuationSubring.nonunits) :
+    v = placeOfPoint (Point.some x y h) := by
+  classical
+  exact
+    solution h v hX hY
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_eq_zero_of_forall_transEquiv_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_eq_zero_of_forall_transEquiv_eq.lean
new file mode 100644
index 0000000000..cfa485568b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_eq_zero_of_forall_transEquiv_eq.lean
@@ -0,0 +1,243 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.eq_zero_of_forall_transEquiv_eq
+(73d318fd-3370-5750-925f-852a3b538767) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b825725e-234e-5db3-a01e-582aba96efd5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+
+import Mathlib.FieldTheory.Galois.Basic
+import Mathlib.FieldTheory.Fixed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsion_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_IsDedekindDomain_HeightOneSpectrum_exists_eq_span_singleton_of_map_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_finrank_fieldRange_mulPull_le
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_exists_zsmul_eq_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_zsmul_genericPoint_good
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Invariant function with divisor on an [n]-fibre forces T=0
+
+Theorem statement: `WeierstrassCurve.Affine.eq_zero_of_forall_transEquiv_eq`
+(`73d318fd-3370-5750-925f-852a3b538767`), by Claude, 2026-09-05.
+
+Proof: submission `b825725e-234e-5db3-a01e-582aba96efd5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra and $K$ algebraically closed, let $W$ be a
+Weierstrass curve over $F$ that is elliptic, and assume the coordinate ring of the base change $W⁄K$
+is a Dedekind domain (routine decidability and instance assumptions are grouped here). Let $n$ be a
+natural number whose image in $K$ is nonzero. For a nonzero affine point $P$ of $W⁄K$, `placeOf W K
+P hP` denotes the height-one prime of the coordinate ring cut out by $P$, namely the ideal generated
+by $x-x_P$ and $y-y_P$, with its induced valuation on the function field; and `mulPull W K n`
+denotes the $K$-algebra endomorphism of the function field obtained by pulling back along the
+multiplication-by-$n$ image of the generic point (the identity if that point fails the genericity
+condition `MulGood`). Assume: (i) `hpull`, that for all $P\ne 0$ with $nP\ne 0$, every function $h$
+and every $k\in\mathbb N$, if $h$ has valuation at most $\exp(-k)$ at the place of $nP$ then
+`mulPull W K n h` has valuation at most $\exp(-k)$ at the place of $P$; (ii) for a point $T$ of
+$W⁄K$ and a function $g$, that $g$ has valuation $\exp(-1)$ at the place of every $P\ne 0$ with
+$nP\ne 0$ and $nP=T$, and valuation $1$ at the place of every other such $P$; (iii) that $g$ is
+fixed by the translation automorphism `transEquiv W K S` for every $S$ with $nS=0$. Then $T=0$.
+
+This is the arithmetic core of the non-degeneracy argument for the Weil pairing (Silverman III.8):
+an $E[n]$-invariant function is a pullback along $[n]$, and if its divisor were concentrated on a
+single fibre of $[n]$ the maximal ideal of the affine point $T$ would be principal, which is
+impossible unless $T=0$. It feeds the non-degeneracy statement
+[`WeierstrassCurve.Affine.eq_zero_of_forall_weilPairing0_eq_one`]
+(thm.html#WeierstrassCurve.Affine.eq_zero_of_forall_weilPairing0_eq_one)
+and the construction
+[`WeierstrassCurve.exists_pairing_torsionBy`](thm.html#WeierstrassCurve.exists_pairing_torsionBy) of
+the pairing on $n$-torsion.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_eq_zero_of_forall_transEquiv_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_eq_zero_of_forall_transEquiv_eq
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+open IsDedekindDomain IsDedekindDomain.HeightOneSpectrum WithZero
+
+namespace WeilND
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+variable {R : Type*} [Field R] (W : WeierstrassCurve R) (K : Type*) [Field K] [Algebra R K]
+
+lemma placeOf_congr {P Q : (W⁄K).Point} (hP : P ≠ 0) (hQ : Q ≠ 0) (h : P = Q) :
+    placeOf W K P hP = placeOf W K Q hQ := by subst h; rfl
+
+end WeilND
+
+theorem solution {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K] (W
+  : WeierstrassCurve F) [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ} (hnK : (n :
+  K) ≠ 0) (hpull : ∀ (P : (W⁄K).Point) (hP : P ≠ 0) (hnP : (n : ℤ) • P ≠ 0) (h :
+  (W⁄K).FunctionField) (k : ℕ), (placeOf W K ((n : ℤ) • P) hnP).valuation (W⁄K).FunctionField h ≤
+  WithZero.exp (-(k : ℤ)) → (placeOf W K P hP).valuation (W⁄K).FunctionField (mulPull W K n h) ≤
+  WithZero.exp (-(k : ℤ))) {T : (W⁄K).Point} (g : (W⁄K).FunctionField) (hg : ∀ (P : (W⁄K).Point) (hP
+  : P ≠ 0), (n : ℤ) • P ≠ 0 → (placeOf W K P hP).valuation (W⁄K).FunctionField g = if (n : ℤ) • P =
+  T then WithZero.exp (-1) else 1) (hinv : ∀ S : (W⁄K).Point, (n : ℤ) • S = 0 → transEquiv W K S g =
+  g) :
+    T = 0 := by
+  classical
+  by_contra hT0
+  have hn0 : (n : ℤ) ≠ 0 := by
+    have : n ≠ 0 := fun h => hnK (by rw [h, Nat.cast_zero])
+    exact_mod_cast this
+  have hnK' : ((n : ℤ) : K) ≠ 0 := by exact_mod_cast hnK
+  have hEK : (W⁄K).IsElliptic := by
+    dsimp only [Affine.baseChange, WeierstrassCurve.baseChange]; infer_instance
+  have hgood : MulGood W K (n : ℤ) := WeierstrassCurve.Affine.zsmul_genericPoint_good W K hnK'
+  obtain ⟨hfd, hdeg⟩ := WeierstrassCurve.Affine.finrank_fieldRange_mulPull_le (K := K) W hgood
+  rw [Int.natAbs_natCast] at hdeg
+  have := hfd
+  have hsurj : ∀ P : (W⁄K).Point, ∃ Q : (W⁄K).Point, (n : ℤ) • Q = P := fun P =>
+    WeierstrassCurve.Affine.Point.exists_zsmul_eq_of_isAlgClosed (W⁄K) hn0 P
+  let φ : Multiplicative (W⁄K).Point →* ((W⁄K).FunctionField ≃ₐ[K] (W⁄K).FunctionField) :=
+    { toFun := fun S => transEquiv W K (Multiplicative.toAdd S)
+      map_one' := by
+        change transEquiv W K 0 = 1
+        rw [transEquiv_zero]; rfl
+      map_mul' := fun S S' => by
+        change transEquiv W K (Multiplicative.toAdd S + Multiplicative.toAdd S') = _
+        rw [transEquiv_add]; rfl }
+  have hφ : Function.Injective φ := fun S S' h =>
+    Multiplicative.toAdd.injective (transEquiv_injective W K h)
+  let En : Subgroup (Multiplicative (W⁄K).Point) :=
+    AddSubgroup.toSubgroup (Submodule.torsionBy ℤ (W⁄K).Point (n : ℤ)).toAddSubgroup
+  have hmemEn : ∀ S, S ∈ En ↔ (n : ℤ) • Multiplicative.toAdd S = 0 := fun S => by
+    change Multiplicative.toAdd S ∈ (Submodule.torsionBy ℤ (W⁄K).Point (n : ℤ)).toAddSubgroup ↔ _
+    rw [Submodule.mem_toAddSubgroup, Submodule.mem_torsionBy_iff]
+  let H : Subgroup ((W⁄K).FunctionField ≃ₐ[K] (W⁄K).FunctionField) := En.map φ
+  have hmemH : ∀ σ, σ ∈ H ↔ ∃ S : (W⁄K).Point, (n : ℤ) • S = 0 ∧ transEquiv W K S = σ := by
+    intro σ
+    constructor
+    · rintro ⟨S, hS, rfl⟩
+      exact ⟨Multiplicative.toAdd S, (hmemEn S).mp hS, rfl⟩
+    · rintro ⟨S, hS, rfl⟩
+      exact ⟨Multiplicative.ofAdd S, (hmemEn _).mpr hS, rfl⟩
+  have hcardEn : Nat.card En = n ^ 2 := by
+    rw [← WeierstrassCurve.card_torsion_of_isAlgClosed W hnK]
+    exact Nat.card_congr (Equiv.subtypeEquiv Multiplicative.toAdd fun S =>
+      (hmemEn S).trans (Submodule.mem_torsionBy_iff (n : ℤ) (Multiplicative.toAdd S)).symm)
+  have hcardH : Nat.card H = n ^ 2 := by
+    rw [← hcardEn]
+    exact Subgroup.card_map_of_injective hφ
+  have : Finite H :=
+    Nat.finite_of_card_ne_zero (by rw [hcardH]; exact pow_ne_zero _ (by exact_mod_cast hn0))
+  have : Fintype H := Fintype.ofFinite H
+  have hfix : Module.finrank (IntermediateField.fixedField H) (W⁄K).FunctionField = n ^ 2 := by
+    rw [show Module.finrank (IntermediateField.fixedField H) (W⁄K).FunctionField =
+        Module.finrank (FixedPoints.subfield H (W⁄K).FunctionField) (W⁄K).FunctionField from rfl,
+      FixedPoints.finrank_eq_card, Fintype.card_eq_nat_card, hcardH]
+  have hM : (mulPull W K (n : ℤ)).fieldRange ≤ IntermediateField.fixedField H := by
+    rintro x ⟨h, rfl⟩
+    rw [IntermediateField.mem_fixedField_iff]
+    intro σ hσ
+    obtain ⟨S, hS, rfl⟩ := (hmemH σ).mp hσ
+    exact transEquiv_mulPull' W K hgood hS h
+  have hEq : (mulPull W K (n : ℤ)).fieldRange = IntermediateField.fixedField H :=
+    IntermediateField.eq_of_le_of_finrank_le' hM (by rw [hfix]; exact hdeg)
+  have hgM : g ∈ (mulPull W K (n : ℤ)).fieldRange := by
+    rw [hEq, IntermediateField.mem_fixedField_iff]
+    intro σ hσ
+    obtain ⟨S, hS, rfl⟩ := (hmemH σ).mp hσ
+    exact hinv S hS
+  obtain ⟨h, hh⟩ := hgM
+  let pt : HeightOneSpectrum (W⁄K).CoordinateRing → (W⁄K).Point := fun v =>
+    Classical.choose (placeOf_surjective W K v)
+  have hpt0 : ∀ v, pt v ≠ 0 :=
+    fun v => Classical.choose (Classical.choose_spec (placeOf_surjective W K v))
+  have hptv : ∀ v, placeOf W K (pt v) (hpt0 v) = v := fun v =>
+    Classical.choose_spec (Classical.choose_spec (placeOf_surjective W K v))
+  let N : HeightOneSpectrum (W⁄K).CoordinateRing → Option (HeightOneSpectrum (W⁄K).CoordinateRing)
+    :=
+    fun v => if hv : (n : ℤ) • pt v = 0 then none else Option.some (placeOf W K ((n : ℤ) • pt v) hv)
+  have hNsome : ∀ v w, N v = Option.some w → ∃ hv : (n : ℤ) • pt v ≠ 0, placeOf W K ((n : ℤ) • pt v)
+    hv = w :=
+    by
+    intro v w hvw
+    by_cases hv : (n : ℤ) • pt v = 0
+    · simp only [N, hv, dite_true] at hvw; exact absurd hvw (by simp)
+    · simp only [N, hv, dite_false, Option.some.injEq] at hvw
+      exact ⟨hv, hvw⟩
+  have hpt_of_place : ∀ {P : (W⁄K).Point} (hP : P ≠ 0), pt (placeOf W K P hP) = P := fun hP =>
+    placeOf_injective W K _ _ (hptv _)
+  have hN : ∀ w, ∃ v, N v = Option.some w := by
+    intro w
+    obtain ⟨U, hU, rfl⟩ := placeOf_surjective W K w
+    obtain ⟨Q, hQ⟩ := hsurj U
+    have hQ0 : Q ≠ 0 := by rintro rfl; exact hU (by rw [← hQ, smul_zero])
+    refine ⟨placeOf W K Q hQ0, ?_⟩
+    have hv : (n : ℤ) • pt (placeOf W K Q hQ0) ≠ 0 := by rw [hpt_of_place]; rwa [hQ]
+    simp only [N, hv, dite_false, Option.some.injEq]
+    exact WeilND.placeOf_congr W K _ _ (by rw [hpt_of_place, hQ])
+  have key :=
+    IsDedekindDomain.HeightOneSpectrum.exists_eq_span_singleton_of_map_eq (R :=
+      (W⁄K).CoordinateRing) (K := (W⁄K).FunctionField)
+    (mulPull W K (n : ℤ) : (W⁄K).FunctionField →+* (W⁄K).FunctionField) N hN ?_ g (placeOf W K T
+      hT0) ?_ ?_ ⟨h, hh⟩
+  rotate_left
+  · intro v w hvw x k hx
+    obtain ⟨hv, rfl⟩ := hNsome v w hvw
+    rw [← hptv v]
+    exact hpull (pt v) (hpt0 v) hv x k hx
+  · intro v hv
+    obtain ⟨hv', hw⟩ := hNsome v _ hv
+    have hPT : (n : ℤ) • pt v = T := placeOf_injective W K _ _ hw
+    rw [← hptv v, hg (pt v) (hpt0 v) hv', ite_eq_left hPT]
+  · intro v w hvw hw
+    obtain ⟨hv', rfl⟩ := hNsome v w hvw
+    have hPT : (n : ℤ) • pt v ≠ T := fun h' => hw (WeilND.placeOf_congr W K _ _ h')
+    rw [← hptv v, hg (pt v) (hpt0 v) hv', ite_eq_right hPT]
+  obtain ⟨r, hr⟩ := key
+  have hr0 : r ≠ 0 := by
+    intro h0
+    apply (placeOf W K T hT0).ne_bot
+    rw [hr, h0, Ideal.span_singleton_eq_bot]
+  have hTs := Point.eq_some_xc_yc hT0
+  have hcls : Point.toClass T = 0 := by
+    rw [hTs, Point.toClass_some]
+    exact (ClassGroup.mk_eq_one_of_coe_ideal (by rfl)).mpr ⟨r, hr0, hr⟩
+  exact hT0 ((Point.toClass_eq_zero T).mp hcls)
+
+end S_WeierstrassCurve_Affine_eq_zero_of_forall_transEquiv_eq
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_eq_zero_of_forall_transEquiv_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+theorem WeierstrassCurve.Affine.eq_zero_of_forall_transEquiv_eq {F K : Type*} [Field F] [Field K]
+  [Algebra F K] [DecidableEq K] [IsAlgClosed K] (W : WeierstrassCurve F) [W.IsElliptic]
+  [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ} (hnK : (n : K) ≠ 0) (hpull : ∀ (P : (W⁄K).Point)
+  (hP : P ≠ 0) (hnP : (n : ℤ) • P ≠ 0) (h : (W⁄K).FunctionField) (k : ℕ), (placeOf W K ((n : ℤ) • P)
+  hnP).valuation (W⁄K).FunctionField h ≤ WithZero.exp (-(k : ℤ)) → (placeOf W K P hP).valuation
+  (W⁄K).FunctionField (mulPull W K n h) ≤ WithZero.exp (-(k : ℤ))) {T : (W⁄K).Point} (g :
+  (W⁄K).FunctionField) (hg : ∀ (P : (W⁄K).Point) (hP : P ≠ 0), (n : ℤ) • P ≠ 0 → (placeOf W K P
+  hP).valuation (W⁄K).FunctionField g = if (n : ℤ) • P = T then WithZero.exp (-1) else 1) (hinv : ∀
+  S : (W⁄K).Point, (n : ℤ) • S = 0 → transEquiv W K S g = g) :
+    T = 0 :=
+  solution W hnK hpull g hg hinv
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_evalEval_psi_sq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_evalEval_psi_sq.lean
new file mode 100644
index 0000000000..2d73140290
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_evalEval_psi_sq.lean
@@ -0,0 +1,100 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.evalEval_psi_sq
+(1ef4e8be-1ef8-5cfe-b53b-d1d6ef272cd4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 18f2ff74-9ae9-5b07-9916-c2112e27fa25
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Division polynomial identity ψₙ(x,y)²=Ψ²ₙ(x) on the curve
+
+Theorem statement: `WeierstrassCurve.Affine.evalEval_psi_sq`
+(`1ef4e8be-1ef8-5cfe-b53b-d1d6ef272cd4`), by Claude, 2026-09-05.
+
+Proof: submission `18f2ff74-9ae9-5b07-9916-c2112e27fa25`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring and let $W$ be a Weierstrass curve over $R$, with coefficients
+$a_1,\dots,a_6$. Let $x,y\in R$ be elements satisfying the affine Weierstrass equation of $W$, that
+is, the bivariate Weierstrass polynomial $W^{\mathrm{aff}}$ vanishes when its two variables are
+evaluated at $x$ and $y$ (this is the predicate `WeierstrassCurve.Affine.Equation`). Then for every
+integer $n$ the square of the value at $(x,y)$ of the bivariate division polynomial $\psi_n$ of $W$,
+an element of $R[X][Y]$ evaluated by `evalEval x y`, equals the value at $x$ of the univariate
+polynomial $\Psi^2_n\in R[X]$ of $W$: $$\big(\psi_n\big)(x,y)^2=\Psi^2_n(x).$$ Thus the congruence
+$\psi_n^2\equiv\Psi^2_n$ modulo the Weierstrass polynomial, which in Mathlib is recorded as an
+identity in the affine coordinate ring of $W$, is here transported to an identity of values at any
+point of the affine Weierstrass curve over $R$. No invertibility, reducedness or integrality
+assumption is made on $R$, and $n$ is allowed to be any integer, positive, negative or zero.
+
+The statement is the pointwise form, valid at any solution of the Weierstrass equation over an
+arbitrary commutative ring, of the standard relation between the bivariate division polynomials
+$\psi_n$ and their univariate substitutes $\Psi^2_n$. It is used throughout the parts of the
+development that compute with $n$-torsion of elliptic curves, for instance in the analysis of
+Frobenius on points and in the Čerednik–Drinfeld material.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_evalEval_psi_sq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_evalEval_psi_sq
+
+open Polynomial
+open scoped Polynomial.Bivariate
+
+theorem PortCard.evalEval_ψ_sq {R : Type*} [CommRing R] (W : WeierstrassCurve R) {x y : R}
+    (h : W.toAffine.Equation x y) (n : ℤ) : (W.ψ n).evalEval x y ^ 2 = (W.ΨSq n).eval x := by
+  have hmk : WeierstrassCurve.Affine.CoordinateRing.mk W (W.ψ n ^ 2) =
+      WeierstrassCurve.Affine.CoordinateRing.mk W (C (W.ΨSq n)) := by
+    rw [map_pow, WeierstrassCurve.Affine.CoordinateRing.mk_ψ,
+      WeierstrassCurve.Affine.CoordinateRing.mk_Ψ_sq]
+  obtain ⟨p, hp⟩ := AdjoinRoot.mk_eq_mk.mp hmk
+  have h0 : (W.toAffine.polynomial).evalEval x y = 0 := h
+  have h1 := congrArg (evalEval x y) hp
+  rw [evalEval_sub, evalEval_mul, h0, zero_mul, sub_eq_zero, evalEval_pow, evalEval_C] at h1
+  exact h1
+
+theorem PortCard.evalEval_φ {R : Type*} [CommRing R] (W : WeierstrassCurve R) {x y : R}
+    (h : W.toAffine.Equation x y) (n : ℤ) : (W.φ n).evalEval x y = (W.Φ n).eval x := by
+  obtain ⟨p, hp⟩ := AdjoinRoot.mk_eq_mk.mp (WeierstrassCurve.Affine.CoordinateRing.mk_φ W n)
+  have h0 : (W.toAffine.polynomial).evalEval x y = 0 := h
+  have h1 := congrArg (evalEval x y) hp
+  rw [evalEval_sub, evalEval_mul, h0, zero_mul, sub_eq_zero, evalEval_C] at h1
+  exact h1
+
+theorem solution {R : Type*} [CommRing R] (W : WeierstrassCurve R) {x y : R}
+    (h : W.toAffine.Equation x y) (n : ℤ) :
+    (W.ψ n).evalEval x y ^ 2 = (W.ΨSq n).eval x :=
+  PortCard.evalEval_ψ_sq W h n
+
+end S_WeierstrassCurve_Affine_evalEval_psi_sq
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_evalEval_psi_sq (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.Affine.evalEval_psi_sq {R : Type*} [CommRing R] (W : WeierstrassCurve R)
+    {x y : R} (h : W.toAffine.Equation x y) (n : ℤ) :
+    (W.ψ n).evalEval x y ^ 2 = (W.ΨSq n).eval x :=
+  solution W h n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward.lean
new file mode 100644
index 0000000000..574f8a6988
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward.lean
@@ -0,0 +1,480 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.Affine.
+eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward
+(0ba6c717-ebcf-50c6-806e-c735eb48a2e9) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 285a9016-3821-511c-ba86-36440e5c0200
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.Analysis.Complex.Polynomial.Basic
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Field_nonempty_ringHom_complex_of_countable
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_ModularPolynomialData_eval_jLattice_eq_zero_of_isAddCyclic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_discriminant_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_exists_scale_lattice_subset_and_sublatticeIndex_eq_and_isAddCyclic_sublatticeQuotient
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_exists_variableChange_smul_weierstrassCurve_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_algHom_baseChange_of_isAddCyclic_ker_pointMapOfPushforward
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_and_abelTheorem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_intermediateField_countable_map_eq_of_isAddCyclic_ker_pointMapOfPushforward
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_isAddCyclic_ker_pointMapOfPushforward_of_algEquiv_conj
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_nonempty_functionField_algEquiv_of_variableChange
+
+/-!
+# Cyclic kernel of order N forces Φ_N(j(E),j(E'))=0
+
+Theorem statement:
+`WeierstrassCurve.Affine.
+eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward`
+(`0ba6c717-ebcf-50c6-806e-c735eb48a2e9`), by Claude, 2026-09-05.
+
+Proof: submission `285a9016-3821-511c-ba86-36440e5c0200`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field of characteristic $0$, and let $E,E'$ be affine Weierstrass
+curves over $K$ which are elliptic. For each of $E$ and $E'$ assume the genus-one gate data: a
+bijection between the points of the curve and the places of its function field over $K$, all of
+which have degree $1$; the centring condition that for every nonsingular affine point $(x,y)$ the
+classes of $X-x$ and $Y-y$ lie in the nonunits of the valuation subring of the place attached to
+that point; and Abel's theorem, that a divisor of degree $0$ is principal exactly when its divisor
+sum vanishes. Let $\iota : K(E') \to K(E)$ be a $K$-algebra homomorphism which is integral, makes
+$K(E)$ a finite module over $K(E')$, and satisfies the pushforward norm formula (for nonzero $f \in
+K(E)$ and a divisor $D$ with $D(w)=\operatorname{ord}_w f$ at every place $w$ of $K(E)$, the
+pushforward of $D$ has value $\operatorname{ord}_v(\mathrm{N}_{K(E)/K(E')} f)$ at every place $v$ of
+$K(E')$). Let $N$ be a nonzero natural number and suppose the kernel of the induced homomorphism
+$E(K) \to E'(K)$ — obtained by transporting divisor-class pushforward along $\iota$ through the
+identifications of the points of a curve with its degree-zero divisor class group — is cyclic of
+cardinality $N$. Then for any datum consisting of a monic $\Phi \in \mathbb{Z}[X][Y]$ of degree
+$\sum_{d \mid N,\ d \text{ squarefree}} N/d$ in $Y$ whose $q$-expansion identity $\Phi(j(q), j(q^N))
+= 0$ holds, one has $\Phi(j(E), j(E')) = 0$, the coefficients being specialised at $j(E)$ and the
+resulting polynomial over $K$ evaluated at $j(E')$.
+
+This is the forward half of the moduli interpretation of $X_0(N)$: a cyclic $N$-isogeny between
+elliptic curves gives a point on the modular curve, i.e. the pair of $j$-invariants is a root of the
+modular polynomial of level $N$. It is used by the statements identifying $j$ of a Vélu quotient by
+a cyclic subgroup of order $N$ as a root of $\Phi_N(j(E), \cdot)$, and thence by the
+transcendence-based criterion for membership in the modular curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+
+noncomputable section
+
+namespace PeriodPair
+
+open Complex
+variable (L : PeriodPair)
+section Scale
+
+variable (α : ℂˣ)
+
+private def mulLeftR (a : ℂ) : ℂ →ₗ[ℝ] ℂ := Algebra.lmul ℝ ℂ a
+
+@[scoped simp] private theorem mulLeftR_apply (a z : ℂ) : mulLeftR a z = a * z := rfl
+
+private theorem mulLeftR_injective {a : ℂ} (ha : a ≠ 0) :
+    Function.Injective (mulLeftR a) := fun _ _ h => by
+  simpa using mul_left_cancel₀ ha h
+
+private def mulLeftZ (a : ℂ) : ℂ →ₗ[ℤ] ℂ := (mulLeftR a).restrictScalars ℤ
+
+@[scoped simp] private theorem mulLeftZ_apply (a z : ℂ) : mulLeftZ a z = a * z := rfl
+
+private theorem _root_.PeriodPair.scale_lattice :
+    (L.scale α).lattice = Submodule.map (mulLeftZ (α : ℂ)) L.lattice := by
+  unfold lattice scale
+  rw [Submodule.map_span]
+  congr 1
+  ext z
+  simp only [Set.mem_insert_iff, Set.mem_singleton_iff, Set.mem_image, mulLeftZ_apply]
+  constructor
+  · rintro (rfl | rfl)
+    · exact ⟨L.ω₁, Or.inl rfl, rfl⟩
+    · exact ⟨L.ω₂, Or.inr rfl, rfl⟩
+  · rintro ⟨w, hw | hw, rfl⟩ <;> simp [hw]
+
+theorem mem_scale_lattice_iff {z : ℂ} :
+    z ∈ (L.scale α).lattice ↔ ∃ l ∈ L.lattice, z = (α : ℂ) * l := by
+  rw [scale_lattice, Submodule.mem_map]; simp only [mulLeftZ_apply]; tauto
+
+private def _root_.PeriodPair.scaleLatticeEquiv : L.lattice ≃ₗ[ℤ] (L.scale α).lattice :=
+  (Submodule.equivMapOfInjective (mulLeftZ (α : ℂ))
+    (fun _ _ h => mul_left_cancel₀ α.ne_zero (by simpa using h)) L.lattice).trans
+    (LinearEquiv.ofEq _ _ (L.scale_lattice α).symm)
+
+@[scoped simp] theorem scaleLatticeEquiv_apply (l : L.lattice) :
+    ((L.scaleLatticeEquiv α l : (L.scale α).lattice) : ℂ) = (α : ℂ) * (l : ℂ) := rfl
+
+end Scale
+
+section Homogeneity
+
+variable (α : ℂˣ)
+
+theorem G_scale (n : ℕ) : (L.scale α).G n = ((α : ℂ) ^ n)⁻¹ * L.G n := by
+  unfold G
+  rw [← (L.scaleLatticeEquiv α).toEquiv.tsum_eq]
+  simp only [LinearEquiv.coe_toEquiv, scaleLatticeEquiv_apply, mul_pow, mul_inv]
+  exact tsum_mul_left
+
+theorem g₂_scale : (L.scale α).g₂ = ((α : ℂ) ^ 4)⁻¹ * L.g₂ := by
+  unfold g₂; rw [G_scale]; ring
+
+theorem g₃_scale : (L.scale α).g₃ = ((α : ℂ) ^ 6)⁻¹ * L.g₃ := by
+  unfold g₃; rw [G_scale]; ring
+
+theorem discriminant_scale :
+    (L.scale α).g₂ ^ 3 - 27 * (L.scale α).g₃ ^ 2
+      = ((α : ℂ) ^ 12)⁻¹ * (L.g₂ ^ 3 - 27 * L.g₃ ^ 2) := by
+  rw [g₂_scale, g₃_scale]; ring
+
+theorem g₂_cubed_scale : (L.scale α).g₂ ^ 3 = ((α : ℂ) ^ 12)⁻¹ * L.g₂ ^ 3 := by
+  rw [g₂_scale, mul_pow, inv_pow, ← pow_mul]
+
+theorem jLattice_scale : (L.scale α).jLattice = L.jLattice := by
+  have hα : ((α : ℂ) ^ 12)⁻¹ ≠ 0 := inv_ne_zero (pow_ne_zero _ α.ne_zero)
+  unfold jLattice
+  rw [discriminant_scale, g₂_cubed_scale, mul_left_comm (1728 : ℂ), mul_div_mul_left _ _ hα]
+
+theorem discriminantNeZero_scale_iff :
+    (L.scale α).DiscriminantNeZero ↔ L.DiscriminantNeZero := by
+  unfold DiscriminantNeZero
+  rw [discriminant_scale]
+  simp only [mul_ne_zero_iff, and_iff_right (inv_ne_zero (pow_ne_zero 12 α.ne_zero))]
+
+end Homogeneity
+end PeriodPair
+
+namespace F4Proof
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+section ConjHelpers
+variable {K : Type*} [Field K]
+variable {E E' F F' : WeierstrassCurve.Affine K}
+
+def conjSeam
+    (eE : F.FunctionField ≃ₐ[K] E.FunctionField)
+    (eE' : F'.FunctionField ≃ₐ[K] E'.FunctionField)
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField) :
+    F'.FunctionField →ₐ[K] F.FunctionField :=
+  (eE.symm.toAlgHom.comp ι).comp eE'.toAlgHom
+
+theorem conjSeam_apply (eE : F.FunctionField ≃ₐ[K] E.FunctionField)
+    (eE' : F'.FunctionField ≃ₐ[K] E'.FunctionField)
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField) (x : F'.FunctionField) :
+    conjSeam eE eE' ι x = eE.symm (ι (eE' x)) := rfl
+
+theorem conjSeam_isIntegral
+    (eE : F.FunctionField ≃ₐ[K] E.FunctionField)
+    (eE' : F'.FunctionField ≃ₐ[K] E'.FunctionField)
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField) (hι : ι.toRingHom.IsIntegral) :
+    (conjSeam eE eE' ι).toRingHom.IsIntegral :=
+  RingHom.IsIntegral.trans eE'.toAlgHom.toRingHom (eE.symm.toAlgHom.comp ι).toRingHom
+    (RingHom.isIntegral_of_surjective _ eE'.surjective)
+    (RingHom.IsIntegral.trans ι.toRingHom eE.symm.toAlgHom.toRingHom hι
+      (RingHom.isIntegral_of_surjective _ eE.symm.surjective))
+
+theorem conjSeam_finiteAlong
+    (eE : F.FunctionField ≃ₐ[K] E.FunctionField)
+    (eE' : F'.FunctionField ≃ₐ[K] E'.FunctionField)
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField) (hfin : FiniteAlong K ι) :
+    FiniteAlong K (conjSeam eE eE' ι) := by
+  have hfin' : RingHom.Finite ι.toRingHom := hfin
+  have h1 : RingHom.Finite eE'.toAlgHom.toRingHom :=
+    RingHom.Finite.of_surjective _ eE'.surjective
+  have h2 : RingHom.Finite eE.symm.toAlgHom.toRingHom :=
+    RingHom.Finite.of_surjective _ eE.symm.surjective
+  have hcomp : RingHom.Finite (conjSeam eE eE' ι).toRingHom :=
+    RingHom.Finite.comp (g := (eE.symm.toAlgHom.comp ι).toRingHom)
+      (RingHom.Finite.comp (g := eE.symm.toAlgHom.toRingHom) h2 hfin') h1
+  exact hcomp
+
+end ConjHelpers
+
+section AutoNorm
+variable {K : Type*} [Field K] [CharZero K]
+
+theorem separableAlong_of_charZero {E E' : WeierstrassCurve.Affine K}
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField) (hfin : FiniteAlong K ι) :
+    SeparableAlong K ι := by
+  let := algebraAlong ι
+  have := isScalarTower_along ι
+  have : Module.Finite E'.FunctionField E.FunctionField := hfin
+  have : CharZero E'.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap K E'.FunctionField).injective
+  change Algebra.IsSeparable E'.FunctionField E.FunctionField
+  infer_instance
+
+theorem normFormulaAlong_of_charZero {E E' : WeierstrassCurve.Affine K}
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField) (hfin : FiniteAlong K ι) :
+    NormFormulaAlong K ι hfin := by
+  have : HasPrincipalDivisors K E.FunctionField :=
+    WeierstrassCurve.Affine.hasPrincipalDivisors_functionField E
+  have : CharZero E'.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap K E'.FunctionField).injective
+  exact AlgebraicCurve.normFormulaAlong ι hfin (separableAlong_of_charZero ι hfin)
+
+end AutoNorm
+
+theorem map_eval_map_Φ {R S : Type*} [CommRing R] [CommRing S] (φ : R →+* S)
+    {N : ℕ} [NeZero N] (data : ModularCurve.ModularPolynomialData N) (a b : R) :
+    φ ((data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom R) a)).eval b) =
+      (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom S) (φ a))).eval (φ b) := by
+  rw [Polynomial.eval_map, Polynomial.eval_map, Polynomial.hom_eval₂]
+  congr 1
+  refine Polynomial.ringHom_ext' (RingHom.ext_int _ _) ?_
+  simp
+
+theorem isElliptic_map {R S : Type*} [CommRing R] [CommRing S] (W : WeierstrassCurve R)
+    [W.IsElliptic]
+    (f : R →+* S) : (W.map f).IsElliptic :=
+  ⟨by rw [WeierstrassCurve.map_Δ]; exact (W.isUnit_Δ).map f⟩
+
+theorem j_eq_div {F : Type*} [Field F] (W : WeierstrassCurve F) [W.IsElliptic] :
+    W.j = W.c₄ ^ 3 / W.Δ := by
+  rw [WeierstrassCurve.j, ← WeierstrassCurve.coe_Δ', div_eq_inv_mul, Units.val_inv_eq_inv_val]
+
+scoped instance instIsEllipticWeierstrassCurve (L : PeriodPair) : L.weierstrassCurve.IsElliptic :=
+  ⟨isUnit_iff_ne_zero.mpr (PeriodPair.discriminant_ne_zero L).weierstrassCurve_Δ_ne_zero⟩
+
+theorem jLattice_eq_j (L : PeriodPair) : L.jLattice = L.weierstrassCurve.j := by
+  rw [PeriodPair.jLattice_eq_c₄_pow_three_div_Δ, j_eq_div]
+
+set_option synthInstance.maxHeartbeats 1600000 in
+theorem complexCase (E E' : WeierstrassCurve.Affine ℂ) [E.IsElliptic] [E'.IsElliptic]
+    [GenusOnePlaceGate E] [GenusOnePlaceGate.IsCentred E] [AbelTheorem E]
+    [GenusOnePlaceGate E'] [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[ℂ] E.FunctionField) (hι : ι.toRingHom.IsIntegral)
+    (hfin : FiniteAlong ℂ ι)
+    (hN : NormFormulaAlong ℂ ι hfin) (N : ℕ) [NeZero N]
+    (hcyc : IsAddCyclic (pointMapOfPushforward ι hι hfin hN).ker)
+    (hcard : Nat.card (pointMapOfPushforward ι hι hfin hN).ker = N)
+    (data : ModularCurve.ModularPolynomialData N) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom ℂ) E.j)).eval E'.j = 0 := by
+  obtain ⟨L, C, hE⟩ :=
+    PeriodPair.exists_variableChange_smul_weierstrassCurve_eq (E : WeierstrassCurve ℂ)
+  obtain ⟨L', C', hE'⟩ :=
+    PeriodPair.exists_variableChange_smul_weierstrassCurve_eq (E' : WeierstrassCurve ℂ)
+  subst hE hE'
+  have : IsDedekindDomain L.weierstrassCurve.toAffine.CoordinateRing :=
+    WeierstrassCurve.Affine.CoordinateRing.isDedekindDomain L.weierstrassCurve
+  have : IsDedekindDomain L'.weierstrassCurve.toAffine.CoordinateRing :=
+    WeierstrassCurve.Affine.CoordinateRing.isDedekindDomain L'.weierstrassCurve
+  have : HasPrincipalDivisors ℂ L.weierstrassCurve.toAffine.FunctionField :=
+    WeierstrassCurve.Affine.hasPrincipalDivisors_functionField L.weierstrassCurve.toAffine
+  have : HasPrincipalDivisors ℂ L'.weierstrassCurve.toAffine.FunctionField :=
+    WeierstrassCurve.Affine.hasPrincipalDivisors_functionField L'.weierstrassCurve.toAffine
+  obtain ⟨gL, hcL, haL⟩ :=
+    WeierstrassCurve.Affine.exists_genusOnePlaceGate_isCentred_and_abelTheorem
+      (W := L.weierstrassCurve.toAffine)
+  obtain ⟨gL', hcL', haL'⟩ :=
+    WeierstrassCurve.Affine.exists_genusOnePlaceGate_isCentred_and_abelTheorem
+      (W := L'.weierstrassCurve.toAffine)
+  let := gL
+  let := gL'
+  have := hcL
+  have := haL
+  have := hcL'
+  have := haL'
+  obtain ⟨eE⟩ :=
+    WeierstrassCurve.nonempty_functionField_algEquiv_of_variableChange L.weierstrassCurve C
+  obtain ⟨eE'⟩ :=
+    WeierstrassCurve.nonempty_functionField_algEquiv_of_variableChange L'.weierstrassCurve C'
+  have hι'' := conjSeam_isIntegral eE eE' ι hι
+  have hfin'' := conjSeam_finiteAlong eE eE' ι hfin
+  have hN'' : NormFormulaAlong ℂ (conjSeam eE eE' ι) hfin'' := normFormulaAlong_of_charZero _ hfin''
+  obtain ⟨hcyc'', hcard''⟩ :=
+    WeierstrassCurve.Affine.isAddCyclic_ker_pointMapOfPushforward_of_algEquiv_conj
+      (C • L.weierstrassCurve).toAffine (C' • L'.weierstrassCurve).toAffine
+      L.weierstrassCurve.toAffine L'.weierstrassCurve.toAffine
+      ι hι hfin hN eE eE' (conjSeam eE eE' ι) (fun x => by
+        rw [conjSeam_apply, AlgEquiv.apply_symm_apply]) hι'' hfin'' hN'' hcyc
+  rw [hcard] at hcard''
+  obtain ⟨β, hsub, hidx, hcycq⟩ :=
+    PeriodPair.exists_scale_lattice_subset_and_sublatticeIndex_eq_and_isAddCyclic_sublatticeQuotient
+      L L' (conjSeam eE eE' ι) hι'' hfin'' hN'' N hcyc'' hcard''
+  have hroot := ModularCurve.ModularPolynomialData.eval_jLattice_eq_zero_of_isAddCyclic
+    N data L (L'.scale β) hsub hidx hcycq
+  rw [PeriodPair.jLattice_scale, jLattice_eq_j, jLattice_eq_j] at hroot
+  have hj : WeierstrassCurve.j (C • L.weierstrassCurve) = L.weierstrassCurve.j :=
+    WeierstrassCurve.variableChange_j _ _
+  have hj' : WeierstrassCurve.j (C' • L'.weierstrassCurve) = L'.weierstrassCurve.j :=
+    WeierstrassCurve.variableChange_j _ _
+  have hjE : (show WeierstrassCurve.Affine ℂ from C • L.weierstrassCurve).j = L.weierstrassCurve.j
+    :=
+    hj
+  have hjE' : (show WeierstrassCurve.Affine ℂ from C' • L'.weierstrassCurve).j =
+    L'.weierstrassCurve.j :=
+    hj'
+  rw [hjE, hjE']
+  exact hroot
+
+end F4Proof
+
+namespace F4Proof
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+set_option synthInstance.maxHeartbeats 1600000 in
+theorem solution0
+    {K : Type} [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+    (E E' : WeierstrassCurve.Affine K) [E.IsElliptic] [E'.IsElliptic]
+    [GenusOnePlaceGate E] [GenusOnePlaceGate.IsCentred E] [AbelTheorem E]
+    [GenusOnePlaceGate E'] [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField) (hι : ι.toRingHom.IsIntegral)
+    (hfin : FiniteAlong K ι)
+    (hN : NormFormulaAlong K ι hfin) (N : ℕ) [NeZero N]
+    (hcyc : IsAddCyclic (pointMapOfPushforward ι hι hfin hN).ker)
+    (hcard : Nat.card (pointMapOfPushforward ι hι hfin hN).ker = N)
+    (data : ModularCurve.ModularPolynomialData N) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom K) E.j)).eval E'.j = 0 := by
+  let : Algebra ℚ K := DivisionRing.toRatAlgebra
+  obtain ⟨K₀, hK₀, E₀, E₀', hE₀, hE₀', hE, hE', hEb, hEb', ι₀, hι₀, hfin₀, H⟩ :=
+    exists_intermediateField_countable_map_eq_of_isAddCyclic_ker_pointMapOfPushforward
+      E E' ι hι hfin hN N hcyc hcard
+  have := hE₀
+  have := hE₀'
+  have := hEb
+  have := hEb'
+  have : Countable K₀ := hK₀
+  have : CharZero K₀ := (algebraMap K₀ K).charZero
+  have : CharZero (AlgebraicClosure K₀) :=
+    charZero_of_injective_algebraMap (algebraMap K₀ (AlgebraicClosure K₀)).injective
+  have : DecidableEq (AlgebraicClosure K₀) := Classical.decEq _
+  have : IsDedekindDomain (E₀.baseChange (AlgebraicClosure K₀)).toAffine.CoordinateRing :=
+    WeierstrassCurve.Affine.CoordinateRing.isDedekindDomain _
+  have : IsDedekindDomain (E₀'.baseChange (AlgebraicClosure K₀)).toAffine.CoordinateRing :=
+    WeierstrassCurve.Affine.CoordinateRing.isDedekindDomain _
+  have : HasPrincipalDivisors (AlgebraicClosure K₀) (E₀.baseChange (AlgebraicClosure
+    K₀)).toAffine.FunctionField :=
+    WeierstrassCurve.Affine.hasPrincipalDivisors_functionField _
+  have : HasPrincipalDivisors (AlgebraicClosure K₀) (E₀'.baseChange (AlgebraicClosure
+    K₀)).toAffine.FunctionField :=
+    WeierstrassCurve.Affine.hasPrincipalDivisors_functionField _
+  obtain ⟨g₁, c₁, a₁⟩ := WeierstrassCurve.Affine.exists_genusOnePlaceGate_isCentred_and_abelTheorem
+    (W := (E₀.baseChange (AlgebraicClosure K₀)).toAffine)
+  obtain ⟨g₂, c₂, a₂⟩ := WeierstrassCurve.Affine.exists_genusOnePlaceGate_isCentred_and_abelTheorem
+    (W := (E₀'.baseChange (AlgebraicClosure K₀)).toAffine)
+  let := g₁
+  let := g₂
+  have := c₁
+  have := a₁
+  have := c₂
+  have := a₂
+  have hN₀ : NormFormulaAlong (AlgebraicClosure K₀) ι₀ hfin₀ :=
+    normFormulaAlong_of_charZero ι₀ hfin₀
+  obtain ⟨hcyc₀, hcard₀⟩ := H hN₀
+  obtain ⟨φ₀⟩ := Field.nonempty_ringHom_complex_of_countable K₀
+  let : Algebra K₀ ℂ := φ₀.toAlgebra
+  have : Module.IsTorsionFree K₀ ℂ :=
+    Module.isTorsionFree_iff_algebraMap_injective.mpr φ₀.injective
+  have : Module.IsTorsionFree K₀ (AlgebraicClosure K₀) :=
+    Module.isTorsionFree_iff_algebraMap_injective.mpr (algebraMap K₀ (AlgebraicClosure
+      K₀)).injective
+  let σ : AlgebraicClosure K₀ →ₐ[K₀] ℂ := IsAlgClosed.lift
+  have : (E₀.baseChange ℂ).IsElliptic := isElliptic_map E₀ _
+  have : (E₀'.baseChange ℂ).IsElliptic := isElliptic_map E₀' _
+  have : IsDedekindDomain (E₀.baseChange ℂ).toAffine.CoordinateRing :=
+    WeierstrassCurve.Affine.CoordinateRing.isDedekindDomain _
+  have : IsDedekindDomain (E₀'.baseChange ℂ).toAffine.CoordinateRing :=
+    WeierstrassCurve.Affine.CoordinateRing.isDedekindDomain _
+  have : HasPrincipalDivisors ℂ (E₀.baseChange ℂ).toAffine.FunctionField :=
+    WeierstrassCurve.Affine.hasPrincipalDivisors_functionField _
+  have : HasPrincipalDivisors ℂ (E₀'.baseChange ℂ).toAffine.FunctionField :=
+    WeierstrassCurve.Affine.hasPrincipalDivisors_functionField _
+  obtain ⟨g₃, c₃, a₃⟩ := WeierstrassCurve.Affine.exists_genusOnePlaceGate_isCentred_and_abelTheorem
+    (W := (E₀.baseChange ℂ).toAffine)
+  obtain ⟨g₄, c₄, a₄⟩ := WeierstrassCurve.Affine.exists_genusOnePlaceGate_isCentred_and_abelTheorem
+    (W := (E₀'.baseChange ℂ).toAffine)
+  let := g₃
+  let := g₄
+  have := c₃
+  have := a₃
+  have := c₄
+  have := a₄
+  obtain ⟨ι₁, hι₁, hfin₁, H₁⟩ :=
+    WeierstrassCurve.Affine.exists_algHom_baseChange_of_isAddCyclic_ker_pointMapOfPushforward
+      K₀ E₀ E₀' (AlgebraicClosure K₀) ℂ σ ι₀ hι₀ hfin₀ hN₀ N hcyc₀ hcard₀
+  have hN₁ : NormFormulaAlong ℂ ι₁ hfin₁ := normFormulaAlong_of_charZero ι₁ hfin₁
+  obtain ⟨hcyc₁, hcard₁⟩ := H₁ hN₁
+  have hC := complexCase (E₀.baseChange ℂ).toAffine (E₀'.baseChange ℂ).toAffine
+    ι₁ hι₁ hfin₁ hN₁ N hcyc₁ hcard₁ data
+  have hjC : WeierstrassCurve.j (E₀.baseChange ℂ).toAffine = φ₀ E₀.j := E₀.map_j φ₀
+  have hjC' : WeierstrassCurve.j (E₀'.baseChange ℂ).toAffine = φ₀ E₀'.j := E₀'.map_j φ₀
+  rw [hjC, hjC', ← map_eval_map_Φ] at hC
+  have hK₀ : (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom K₀) E₀.j)).eval E₀'.j = 0 :=
+    φ₀.injective (hC.trans (map_zero φ₀).symm)
+  subst hE hE'
+  have hjK : WeierstrassCurve.j (show WeierstrassCurve.Affine K from E₀.map (algebraMap K₀ K)) =
+      algebraMap K₀ K E₀.j := E₀.map_j _
+  have hjK' : WeierstrassCurve.j (show WeierstrassCurve.Affine K from E₀'.map (algebraMap K₀ K)) =
+      algebraMap K₀ K E₀'.j := E₀'.map_j _
+  rw [hjK, hjK', ← map_eval_map_Φ, hK₀, map_zero]
+
+end F4Proof
+end
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+theorem solution
+    (K : Type) [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+    (E E' : WeierstrassCurve.Affine K) [E.IsElliptic] [E'.IsElliptic]
+    [GenusOnePlaceGate E] [GenusOnePlaceGate.IsCentred E] [AbelTheorem E]
+    [GenusOnePlaceGate E'] [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField) (hι : ι.toRingHom.IsIntegral)
+    (hfin : FiniteAlong K ι)
+    (hN : NormFormulaAlong K ι hfin) (N : ℕ) [NeZero N]
+    (hcyc : IsAddCyclic (pointMapOfPushforward ι hι hfin hN).ker)
+    (hcard : Nat.card (pointMapOfPushforward ι hι hfin hN).ker = N)
+    (data : ModularCurve.ModularPolynomialData N) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom K) E.j)).eval E'.j = 0 :=
+  F4Proof.solution0 E E' ι hι hfin hN N hcyc hcard data
+
+end privateSection
+
+public section publicSection
+
+namespace WeierstrassCurve.Affine
+open AlgebraicCurve
+
+theorem
+  eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward
+    (K : Type) [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+    (E E' : WeierstrassCurve.Affine K) [E.IsElliptic] [E'.IsElliptic]
+    [GenusOnePlaceGate E] [GenusOnePlaceGate.IsCentred E] [AbelTheorem E]
+    [GenusOnePlaceGate E'] [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField) (hι : ι.toRingHom.IsIntegral)
+    (hfin : FiniteAlong K ι)
+    (hN : NormFormulaAlong K ι hfin) (N : ℕ) [NeZero N]
+    (hcyc : IsAddCyclic (pointMapOfPushforward ι hι hfin hN).ker)
+    (hcard : Nat.card (pointMapOfPushforward ι hι hfin hN).ker = N)
+    (data : ModularCurve.ModularPolynomialData N) :
+    (data.Φ.map (Polynomial.eval₂RingHom (Int.castRingHom K) E.j)).eval E'.j = 0 :=
+  solution K E E' ι hι hfin hN N hcyc hcard data
+
+end WeierstrassCurve.Affine
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_algEquiv_restrictAlong_placeOfPoint_eq_add.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_algEquiv_restrictAlong_placeOfPoint_eq_add.lean
new file mode 100644
index 0000000000..349c21311d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_algEquiv_restrictAlong_placeOfPoint_eq_add.lean
@@ -0,0 +1,4459 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.exists_algEquiv_restrictAlong_placeOfPoint_eq_add
+(097a6011-2a0d-5fc7-ac08-6af7721d7d7f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f229f4f6-a3a7-5def-ad3c-25b56254a8c5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Analysis.Complex.UpperHalfPlane.Basic
+import Mathlib.Analysis.Normed.Ring.Lemmas
+import Mathlib.Data.Int.Star
+import Mathlib.RingTheory.LocalProperties.Reduced
+import Mathlib.Tactic.NormNum.Prime
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_min_ord_le_ord_add_v2
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Translation by R as a function-field automorphism on places
+
+Theorem statement: `WeierstrassCurve.Affine.exists_algEquiv_restrictAlong_placeOfPoint_eq_add`
+(`097a6011-2a0d-5fc7-ac08-6af7721d7d7f`), by Claude, 2026-09-05.
+
+Proof: submission `f229f4f6-a3a7-5def-ad3c-25b56254a8c5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field of characteristic zero and let $W$ be an affine Weierstrass
+curve over $F$ which is elliptic. Assume $W$ carries the data and properties packaged by three
+project classes: `GenusOnePlaceGate W`, consisting of a bijection `pointEquivPlace` between the
+group $W.\mathrm{Point}$ and the places of $W.\mathrm{FunctionField}$ over $F$ (a place being a
+valuation subring, not the whole field, containing the image of $F$ and a principal ideal ring)
+together with the assertion that every such place has degree $1$, where `placeOfPoint` denotes this
+bijection; `GenusOnePlaceGate.IsCentred W`, which says that for every nonsingular affine point
+$(x,y)$ the images in the function field of the coordinate-ring classes `CoordinateRing.XClass W x`
+and `CoordinateRing.YClass W (C y)` lie in the nonunits of the valuation subring of `placeOfPoint
+(Point.some x y h)`; and `AbelTheorem W`, which says that a divisor of degree $0$ is principal
+exactly when its image under `divisorSum` — the sum in $W.\mathrm{Point}$ of the points
+corresponding to its places, with multiplicities — is $0$. Then for every point $R$ of $W$ there
+exist an $F$-algebra automorphism $\tau$ of $W.\mathrm{FunctionField}$ and a proof that the
+underlying ring homomorphism of $\tau$ is integral, such that for every point $Q$ the restriction of
+`placeOfPoint Q` along $\tau$ — the place whose valuation subring is the preimage under $\tau$ of
+that of `placeOfPoint Q` — equals `placeOfPoint (Q + R)`.
+
+This is the function-field form of translation by a point on an elliptic curve: the automorphism
+$\tau$ is the pull-back along $P \mapsto P + R$, and the conclusion records that it moves the place
+attached to $Q$ to the place attached to $Q+R$. It is used in the construction of homomorphisms of
+points from isogeny data, via
+[`WeierstrassCurve.Affine.IsogenyHomDatum.exists_pointHom_comp_eq_of_ker_le_of_isCentred`]
+(thm.html#WeierstrassCurve.Affine.IsogenyHomDatum.exists_pointHom_comp_eq_of_ker_le_of_isCentred).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_exists_algEquiv_restrictAlong_placeOfPoint_eq_add.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_e431601d
+
+
+noncomputable section
+
+scoped instance instFactNatPrime7_s13e2 : Fact (Nat.Prime 7) := ⟨by norm_num⟩
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine~genericPoint WeierstrassCurve~Affine.genericPoint"
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_e431601d.Polynomial \
+  IsDedekindDomain \
+  P2MW.S_OVERLONG_e431601d.IsDedekindDomai\
+  n WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~Place.ord\
+  _algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq \
+  P2MW.S_OVERLONG_e431601d.AlgebraicCurve"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_e431601d.Polynomial.Bivar\
+  iate"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem S13_ofHeightOneSpectrum_injective {R : Type*} [CommRing R] [IsDedekindDomain R]
+    [Algebra R W.FunctionField] [IsFractionRing R W.FunctionField] [Algebra F R]
+    [IsScalarTower F R W.FunctionField] :
+    Function.Injective (AlgebraicCurve.Place.ofHeightOneSpectrum (K := F) (R := R) (F :=
+      W.FunctionField)) := by
+  intro w₁ w₂ h
+  refine HeightOneSpectrum.eq_of_valuation_isEquiv_valuation (K := W.FunctionField) ?_
+  rw [Valuation.isEquiv_iff_valuationSubring]
+  exact congrArg AlgebraicCurve.Place.toValuationSubring h
+
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "smul_basis_eq_zero XYIdeal \
+  quotientXYIdealEquiv XClass_ne_zero smul YClass mk map degree_norm_smul_basis \
+  exists_smul_basis_eq XClass smul_basis_mul_Y YClass_ne_zero isDedekindDomain exists_eq_XYIdeal \
+  XYIdeal_isMaximal XYIdeal_ne_bot"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing"
+
+theorem algebraMap_eq_mk_C_C (a : F) :
+    algebraMap F W.CoordinateRing a = CoordinateRing.mk W (C (C a)) := by
+  rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+    Algebra.algebraMap_self_apply]
+  rfl
+
+theorem eq_of_XYIdeal_eq {x₁ y₁ x₂ y₂ : F} (h₂ : W.Equation x₂ y₂)
+    (h : XYIdeal W x₁ (C y₁) = XYIdeal W x₂ (C y₂)) : x₁ = x₂ ∧ y₁ = y₂ := by
+  have hne : XYIdeal W x₂ (C y₂) ≠ ⊤ := (XYIdeal_isMaximal h₂).ne_top
+  have hX₁ : XClass W x₁ ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert _ _)
+  have hX₂ : XClass W x₂ ∈ XYIdeal W x₂ (C y₂) := Ideal.subset_span (Set.mem_insert _ _)
+  have hY₁ : YClass W (C y₁) ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  have hY₂ : YClass W (C y₂) ∈ XYIdeal W x₂ (C y₂) :=
+    Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  constructor
+  · by_contra hx
+    apply hne
+    have hsub : XClass W x₁ - XClass W x₂ = algebraMap F W.CoordinateRing (x₂ - x₁) := by
+      rw [XClass, XClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      rw [← map_sub]
+      congr 1
+      rw [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hX₁ hX₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hx hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+  · by_contra hy
+    apply hne
+    have hsub : YClass W (C y₁) - YClass W (C y₂) = algebraMap F W.CoordinateRing (y₂ - y₁) := by
+      rw [YClass, YClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      simp only [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hY₁ hY₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hy hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+
+def heightOneSpectrumOfEquation {x y : F} (h : W.Equation x y) :
+    HeightOneSpectrum W.CoordinateRing where
+  asIdeal := XYIdeal W x (C y)
+  isPrime := (XYIdeal_isMaximal h).isPrime
+  ne_bot := XYIdeal_ne_bot x (C y)
+
+@[scoped simp]
+theorem heightOneSpectrumOfEquation_asIdeal {x y : F} (h : W.Equation x y) :
+    (heightOneSpectrumOfEquation h).asIdeal = XYIdeal W x (C y) := rfl
+
+theorem exists_sub_algebraMap_mem {x y : F} (h : W.Equation x y) (r : W.CoordinateRing) :
+    ∃ c : F, r - algebraMap F W.CoordinateRing c ∈ XYIdeal W x (C y) := by
+  set e := quotientXYIdealEquiv (W' := W) (x := x) (y := C y) h
+  refine ⟨e (Ideal.Quotient.mk _ r), ?_⟩
+  rw [← Ideal.Quotient.eq_zero_iff_mem, map_sub, sub_eq_zero]
+  apply e.injective
+  rw [← Ideal.Quotient.algebraMap_eq, ← IsScalarTower.algebraMap_apply, AlgEquiv.commutes,
+    Algebra.algebraMap_self_apply]
+
+end CoordinateRing
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine.CoordinateRing"
+
+def IsFinitePlace (v : AlgebraicCurve.Place F W.FunctionField) : Prop :=
+  ∀ r : W.CoordinateRing, algebraMap W.CoordinateRing W.FunctionField r ∈ v.toValuationSubring
+
+def IsFinitePlace.ringHom {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    W.CoordinateRing →+* v.toValuationSubring where
+  toFun r := ⟨algebraMap W.CoordinateRing W.FunctionField r, hv r⟩
+  map_one' := Subtype.ext (map_one _)
+  map_mul' a b := Subtype.ext (map_mul _ a b)
+  map_zero' := Subtype.ext (map_zero _)
+  map_add' a b := Subtype.ext (map_add _ a b)
+
+@[scoped simp]
+theorem IsFinitePlace.coe_ringHom_apply {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) (r : W.CoordinateRing) :
+    (hv.ringHom r : W.FunctionField) = algebraMap W.CoordinateRing W.FunctionField r := rfl
+
+
+def IsFinitePlace.centre {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    Ideal W.CoordinateRing :=
+  (IsLocalRing.maximalIdeal v.toValuationSubring).comap hv.ringHom
+
+theorem IsFinitePlace.centre_isPrime {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre.IsPrime :=
+  Ideal.IsPrime.comap _
+
+theorem IsFinitePlace.inv_mem {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) {r : W.CoordinateRing} (hr : r ∉ hv.centre) :
+    (algebraMap W.CoordinateRing W.FunctionField r)⁻¹ ∈ v.toValuationSubring := by
+  have hunit : IsUnit (hv.ringHom r) := by
+    rw [IsFinitePlace.centre, Ideal.mem_comap, IsLocalRing.mem_maximalIdeal,
+      mem_nonunits_iff, not_not] at hr
+    exact hr
+  obtain ⟨t, ht⟩ := hunit.exists_right_inv
+  have ht' : algebraMap W.CoordinateRing W.FunctionField r * (t : W.FunctionField) = 1 := by
+    have := congrArg (fun a : v.toValuationSubring => (a : W.FunctionField)) ht
+    simpa using this
+  rw [inv_eq_of_mul_eq_one_right ht']
+  exact t.2
+
+theorem IsFinitePlace.centre_ne_bot {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre ≠ ⊥ := by
+  intro hbot
+  apply v.ne_top'
+  rw [eq_top_iff]
+  rintro z -
+  obtain ⟨r, s, hs, hz⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  have hs0 : s ∉ hv.centre := by
+    rw [hbot, Ideal.mem_bot]
+    exact fun h => nonZeroDivisors.ne_zero hs h
+  rw [← hz, div_eq_mul_inv]
+  exact mul_mem (hv r) (hv.inv_mem hs0)
+
+variable [IsDedekindDomain W.CoordinateRing]
+
+def placeOfEquation {x y : F} (h : W.Equation x y) :
+    AlgebraicCurve.Place F W.FunctionField :=
+  AlgebraicCurve.Place.ofHeightOneSpectrum (heightOneSpectrumOfEquation h)
+
+theorem placeOfEquation_injective {x₁ y₁ x₂ y₂ : F} (h₁ : W.Equation x₁ y₁)
+    (h₂ : W.Equation x₂ y₂) (h : placeOfEquation h₁ = placeOfEquation h₂) :
+    x₁ = x₂ ∧ y₁ = y₂ :=
+  eq_of_XYIdeal_eq h₂
+    (congrArg HeightOneSpectrum.asIdeal (S13_ofHeightOneSpectrum_injective h))
+
+theorem isFinitePlace_placeOfEquation {x y : F} (h : W.Equation x y) :
+    IsFinitePlace (placeOfEquation h) := fun r =>
+  (heightOneSpectrumOfEquation h).valuation_le_one r
+
+theorem isFinitePlace_iff_exists_placeOfEquation [IsAlgClosed F]
+    (v : AlgebraicCurve.Place F W.FunctionField) :
+    IsFinitePlace v ↔ ∃ (x y : F) (h : W.Equation x y), v = placeOfEquation h := by
+  constructor
+  · intro hv
+    have := hv.centre_isPrime
+    have hmax : hv.centre.IsMaximal := Ideal.IsPrime.isMaximal hv.centre_isPrime hv.centre_ne_bot
+    obtain ⟨x, y, hxy, hXY⟩ :=
+      CoordinateRing.exists_eq_XYIdeal (W := W) (P := hv.centre) hv.centre_ne_bot
+    refine ⟨x, y, hxy, ?_⟩
+    set w : HeightOneSpectrum W.CoordinateRing := heightOneSpectrumOfEquation hxy with hw
+    set A : ValuationSubring W.FunctionField :=
+      HeightOneSpectrum.valuationSubringAtPrime W.FunctionField w with hA
+    have hAded : IsDedekindDomain A := by rw [hA]; infer_instance
+    have hle : A ≤ v.toValuationSubring := by
+      intro z hz
+      rw [hA] at hz
+      obtain ⟨r, s, hs, rfl⟩ := hz
+      have hs' : s ∉ hv.centre := by
+        intro hmem
+        rw [hXY] at hmem
+        exact hs hmem
+      exact mul_mem (hv r) (hv.inv_mem hs')
+    have hSP : A.ofPrime (A.idealOfLE v.toValuationSubring hle) = v.toValuationSubring :=
+      ValuationSubring.ofPrime_idealOfLE A v.toValuationSubring hle
+    rcases eq_or_ne (A.idealOfLE v.toValuationSubring hle) ⊥ with hP | hP
+    · exfalso
+      apply v.ne_top'
+      have h2 : A.ofPrime ⊥ ≤ A.ofPrime (A.idealOfLE v.toValuationSubring hle) :=
+        ValuationSubring.ofPrime_le_of_le (h := hP.le)
+      rw [ValuationSubring.ofPrime_bot] at h2
+      exact top_le_iff.mp (le_trans h2 hSP.le)
+    · have hPmax : (A.idealOfLE v.toValuationSubring hle).IsMaximal :=
+        Ideal.IsPrime.isMaximal inferInstance hP
+      have hPeq : A.idealOfLE v.toValuationSubring hle = IsLocalRing.maximalIdeal A :=
+        IsLocalRing.eq_maximalIdeal hPmax
+      have h3 : A.ofPrime (A.idealOfLE v.toValuationSubring hle)
+          = A.ofPrime (IsLocalRing.maximalIdeal A) :=
+        le_antisymm (ValuationSubring.ofPrime_le_of_le (h := hPeq.ge))
+          (ValuationSubring.ofPrime_le_of_le (h := hPeq.le))
+      rw [ValuationSubring.ofPrime_top] at h3
+      have hAv : A = v.toValuationSubring := h3.symm.trans hSP
+      refine (AlgebraicCurve.Place.ext ?_).symm
+      change (AlgebraicCurve.Place.ofHeightOneSpectrum w).toValuationSubring = v.toValuationSubring
+      rw [AlgebraicCurve.Place.ofHeightOneSpectrum_toValuationSubring,
+        ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact hAv
+  · rintro ⟨x, y, h, rfl⟩
+    exact isFinitePlace_placeOfEquation h
+
+scoped instance S13_instIsDedekindDomainCoordinateRing [IsAlgClosed F] [W.IsElliptic] :
+    IsDedekindDomain W.CoordinateRing :=
+  CoordinateRing.isDedekindDomain (W := W)
+
+section CentredGate
+
+variable [DecidableEq F] [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W]
+
+omit [DecidableEq F] in
+@[scoped simp]
+theorem placeOfPoint_some {x y : F} (h : W.Nonsingular x y) :
+    placeOfPoint (.some x y h) = placeOfEquation h.left := by
+  classical
+  exact
+    placeOfPoint_some_eq_ofHeightOneSpectrum h (heightOneSpectrumOfEquation h.left) rfl
+
+namespace InfinitePlace
+
+def place : AlgebraicCurve.Place F W.FunctionField := placeOfPoint (0 : W.Point)
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem deg_eq_one : (place : AlgebraicCurve.Place F W.FunctionField).deg = 1 := by
+  classical
+  exact
+    deg_placeOfPoint (W := W) 0
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] in
+theorem not_isFinitePlace [IsAlgClosed F] [W.IsElliptic] :
+    ¬ IsFinitePlace (place : AlgebraicCurve.Place F W.FunctionField) := by
+  classical
+  exact
+    fun h =>
+     algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero (W := W) (h _)
+
+omit [DecidableEq F] in
+theorem eq_of_not_isFinitePlace
+    (v : AlgebraicCurve.Place F W.FunctionField) (hv : ¬ IsFinitePlace v) :
+    v = place := by
+  classical
+  obtain ⟨P, rfl⟩ : ∃ P : W.Point, placeOfPoint P = v :=
+    ⟨(pointEquivPlace (W := W)).symm v, (pointEquivPlace (W := W)).apply_symm_apply v⟩
+  cases P with
+  | zero => rfl
+  | some x y h =>
+      exact absurd (placeOfPoint_some (W := W) h ▸ isFinitePlace_placeOfEquation h.left) hv
+
+end InfinitePlace
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+@[scoped simp]
+theorem placeOfPoint_zero : placeOfPoint (.zero : W.Point) = InfinitePlace.place := by
+  classical
+  exact
+    rfl
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_zero' : placeOfPoint (0 : W.Point) = InfinitePlace.place := by
+  classical
+  exact
+    rfl
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_injective : Function.Injective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).injective
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_surjective (_hΔ : W.Δ ≠ 0) : Function.Surjective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).surjective
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_surjective' : Function.Surjective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).surjective
+
+end CentredGate
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine~genericPoint WeierstrassCurve~Affine.genericPoint"
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~P\
+  lace.ord_algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq \
+  P2MW.S_OVERLONG_e431601d.AlgebraicCurve"
+
+scoped instance instHasPrincipalDivisorsFunctionField_s13 {F : Type*} [Field F] [CharZero F]
+    {W : Affine F} : HasPrincipalDivisors F W.FunctionField :=
+  hasPrincipalDivisors_functionField W
+
+section AutoNorm
+variable {F : Type*} [Field F] [CharZero F]
+variable {V W : Affine F} [V.IsElliptic] [W.IsElliptic]
+
+omit [WeierstrassCurve.IsElliptic V] [WeierstrassCurve.IsElliptic W] in
+theorem normFormulaAlong_of_elliptic (ι : V.FunctionField →ₐ[F] W.FunctionField)
+    (hfin : FiniteAlong F ι) : NormFormulaAlong F ι hfin := by
+  classical
+  have : HasPrincipalDivisors F W.FunctionField := hasPrincipalDivisors_functionField W
+  have : CharZero V.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap F V.FunctionField).injective
+  have hsep : SeparableAlong F ι := by
+    let := algebraAlong ι
+    have := isScalarTower_along ι
+    have : Module.Finite V.FunctionField W.FunctionField := hfin
+    change Algebra.IsSeparable V.FunctionField W.FunctionField
+    infer_instance
+  exact AlgebraicCurve.normFormulaAlong ι hfin hsep
+
+end AutoNorm
+
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι rec mk ι"
+p2m_open "WeierstrassCurve.Affine.IsogenyEndDatum"
+
+variable {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [GenusOnePlaceGate W] [AbelTheorem W]
+
+omit [DecidableEq F] [W.GenusOnePlaceGate] [W.AbelTheorem] in
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+private theorem _root_.WeierstrassCurve.Affine.IsogenyEndDatum.normFormulaAlong_auto (D :
+  IsogenyEndDatum W) :
+    NormFormulaAlong F D.ι D.hfin :=
+  normFormulaAlong_of_elliptic D.ι D.hfin
+
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "normFormulaAlong_auto"
+
+private def _root_.WeierstrassCurve.Affine.IsogenyEndDatum.pointEnd' (D : IsogenyEndDatum W) :
+    AddMonoid.End W.Point := D.pointEnd D.normFormulaAlong_auto
+
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd'"
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd_eq_pointEnd' (D : IsogenyEndDatum W) (hN : NormFormulaAlong F D.ι D.hfin) :
+    D.pointEnd hN = D.pointEnd' := rfl
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd'_apply (D : IsogenyEndDatum W) (P : W.Point) :
+    D.pointEnd' P = genusOnePic0Equiv W
+      (Pic0.pushforwardAlongHom D.ι D.hι D.hfin D.normFormulaAlong_auto (pointClass P)) :=
+  pointEnd_apply D _ P
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd'_eq_of_seam (D : IsogenyEndDatum W) (g : W.Point → W.Point) (hg0 : g 0 = 0)
+    (hg : ∀ P, (placeOfPoint P).restrictAlong D.ι D.hι = placeOfPoint (g P)) (P : W.Point) :
+    D.pointEnd' P = g P :=
+  pointEnd_eq_of_seam D _ g hg0 hg P
+
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+
+
+namespace AdjoinRoot
+p2m_export "AdjoinRoot" "lift mk_self algebraMap_eq' algebraMap_eq of mk_surjective mk_eq_mk \
+  liftAlgHom lift_mk algHom_ext root mk map evalEval"
+end AdjoinRoot
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongHom algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong Place.ramificationIndexAlong SeparableAlong Place \
+  Place.ext Place.ord Place.ord_zero HasPrincipalDivisors Pic0 Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+end AlgebraicCurve
+namespace Complex
+p2m_export "Complex" "log_exp re log_one lift algHom_ext rec coe_algebraMap exp mk exp_log log ext \
+  I"
+end Complex
+namespace FractionalIdeal
+p2m_export "FractionalIdeal" "mul_mem_mul zero_mem ext map mem_coe num"
+end FractionalIdeal
+namespace Function
+p2m_export "Function" "Surjective algebra surjective_id Injective comp Pullback nontrivial \
+  comp_apply eval"
+end Function
+namespace Ideal
+p2m_export "Ideal" "height Quotient.algebraMap_eq Quotient.eq_zero_iff_mem IsPrime.comap \
+  mul_mem_right map_span mem_bot span leadingCoeff eq_top_of_isUnit_mem mul_mem_mul IsMaximal \
+  Quotient.mk mul_mem_left map IsPrime.isMaximal ext IsPrime eq_bot_of_comap_eq_bot mem_map_of_mem \
+  span_le pow_le_self mem_comap pow_mem_pow under comap subset_span mem_map_iff_of_surjective"
+end Ideal
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "HeightOneSpectrum.intValuation_eq_one_iff \
+  HeightOneSpectrum.valuationSubringAtPrime HeightOneSpectrum.intValuation_le_pow_iff_mem \
+  HeightOneSpectrum.asIdeal rec HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring \
+  HeightOneSpectrum.eq_of_valuation_isEquiv_valuation mk HeightOneSpectrum"
+end IsDedekindDomain
+namespace IsLocalRing
+p2m_export "IsLocalRing" "eq_maximalIdeal rec maximalIdeal mem_maximalIdeal residue"
+end IsLocalRing
+namespace Matrix
+p2m_export "Matrix" "J ext add sub zero comp smul single ext_iff comp_apply of map one IsElliptic"
+end Matrix
+namespace ModularForm
+p2m_export "ModularForm" "mk pow add rec ext"
+end ModularForm
+namespace Module
+p2m_export "Module" "Injective rec Finite.of_basis mk End"
+end Module
+namespace Polynomial
+p2m_export "Polynomial" "C eval₂_sub X eval_mul derivative_C C_sub natDegree_zero coeff_add C_mul \
+  leadingCoeff derivative_add algebraMap_eq eraseLead_natDegree_lt_or_eraseLead_eq_zero \
+  natDegree_add_le eval₂ aeval eval₂_add eraseLead_add_C_mul_X_pow monomial natDegree_cubic \
+  derivative_C_mul_X eval₂_pow evalEval_C evalEval_add ext_iff C_add degree C_0 aeval_C \
+  monic_X_pow_add degree_linear_le toSubring coeff_sub X_sub_C_ne_zero C_pow map eval₂_X \
+  derivative_X comp algebra eval₂_mul coeff_C eval_pow natDegree_pow algHom_ext derivative_mul \
+  natDegree eval_X eval₂_map eval_C nontrivial flt X_ne_zero rec derivative_sq C_1 eval_sub \
+  X_sub_C_dvd_sub_C_eval natDegree_eq_of_degree_eq_some derivative_sub pow evalEval_zero \
+  C_mul_X_pow_eq_monomial derivative aeval_X mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero \
+  dvd_iff_isRoot algebraMap_apply C_neg coeff_C_mul natDegree_C eval_add evalEval \
+  natDegree_X_sub_C eraseLead ext degree_eq_natDegree C_ne_zero coeff_X_pow IsRoot eval₂_C ring \
+  evalEval_mul leadingCoeff_ne_zero eval natDegree_C_mul_le natDegree_le_of_dvd degree_zero"
+end Polynomial
+namespace Polynomial
+p2m_export "Polynomial" "C eval₂_sub X eval_mul derivative_C C_sub natDegree_zero coeff_add C_mul \
+  leadingCoeff derivative_add algebraMap_eq eraseLead_natDegree_lt_or_eraseLead_eq_zero \
+  natDegree_add_le eval₂ aeval eval₂_add eraseLead_add_C_mul_X_pow monomial natDegree_cubic \
+  derivative_C_mul_X eval₂_pow evalEval_C evalEval_add ext_iff C_add degree C_0 aeval_C \
+  monic_X_pow_add degree_linear_le toSubring coeff_sub X_sub_C_ne_zero C_pow map eval₂_X \
+  derivative_X comp algebra eval₂_mul coeff_C eval_pow natDegree_pow algHom_ext derivative_mul \
+  natDegree eval_X eval₂_map eval_C nontrivial flt X_ne_zero rec derivative_sq C_1 eval_sub \
+  X_sub_C_dvd_sub_C_eval natDegree_eq_of_degree_eq_some derivative_sub pow evalEval_zero \
+  C_mul_X_pow_eq_monomial derivative aeval_X mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero \
+  dvd_iff_isRoot algebraMap_apply C_neg coeff_C_mul natDegree_C eval_add evalEval \
+  natDegree_X_sub_C eraseLead ext degree_eq_natDegree C_ne_zero coeff_X_pow IsRoot eval₂_C ring \
+  evalEval_mul leadingCoeff_ne_zero eval natDegree_C_mul_le natDegree_le_of_dvd degree_zero"
+end Polynomial
+namespace Real
+p2m_export "Real" "norm log_exp log_one exp log_zpow exp_le_exp log mk rec exp_log exp_lt_exp \
+  log_le_log"
+end Real
+namespace Set
+p2m_export "Set" "codRestrict image ext pow_mem_pow mem_singleton_iff mul_mem_mul \
+  mem_insert_of_mem mem_insert_iff inclusion mem_insert image_pair"
+end Set
+namespace Subgroup
+p2m_export "Subgroup" "one rec mem_bot inclusion ext mem_map_of_mem mem_comap comap map mk"
+end Subgroup
+namespace UpperHalfPlane
+p2m_export "UpperHalfPlane" "ne_zero upperHalfPlaneSet I J mk re num rec"
+end UpperHalfPlane
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+end Affine
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+end Affine
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "smul_basis_eq_zero XYIdeal \
+  quotientXYIdealEquiv XClass_ne_zero smul YClass mk map degree_norm_smul_basis \
+  exists_smul_basis_eq XClass smul_basis_mul_Y YClass_ne_zero isDedekindDomain exists_eq_XYIdeal \
+  XYIdeal_isMaximal XYIdeal_ne_bot"
+end CoordinateRing
+end Affine
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+namespace Point
+p2m_export "WeierstrassCurve.Affine.Point" "add baseChange some some.injEq neg_zero some.inj \
+  map_zero add_some map some_ne_zero rec add_of_X_ne zero neg_some add_self_of_Y_ne mk"
+end Point
+end Affine
+end WeierstrassCurve
+namespace WithZero
+p2m_export "WithZero" "log_le_log map exp_lt_exp log_zpow log_exp log exp lift pow one le log_one \
+  exp_le_exp exp_log"
+end WithZero
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_e431601d.Polynomial \
+  Ideal P2MW.S_OVERLONG_e431601d.Ideal"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_e431601d.Polynomial.Bivar\
+  iate"
+
+local macro "C_simp" : tactic =>
+  `(tactic| simp only [map_ofNat, C_0, C_1, C_neg, C_add, C_sub, C_mul, C_pow])
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine~genericPoint WeierstrassCurve~Affine.genericPoint"
+
+universe r u
+
+variable {R : Type r} [CommRing R] {W : Affine R}
+variable {F : Type u} [Field F] {WF : Affine F}
+
+section TaylorIdentity
+
+variable (W)
+
+private def _root_.WeierstrassCurve.Affine.taylorRemainder₂ (x₀ y₀ : R) : R[X][Y] :=
+  (Y - C (C y₀)) ^ 2 + C (C W.a₁ * (X - C x₀)) * (Y - C (C y₀))
+    - C ((X - C x₀) ^ 2 * (X + C (2 * x₀ + W.a₂)))
+
+p2m_export "WeierstrassCurve.Affine" "taylorRemainder₂"
+private theorem _root_.WeierstrassCurve.Affine.taylor₂_polynomial (x₀ y₀ : R) :
+    W.polynomial =
+      C (C (W.polynomial.evalEval x₀ y₀))
+        + C (C (W.polynomialX.evalEval x₀ y₀) * (X - C x₀))
+        + C (C (W.polynomialY.evalEval x₀ y₀)) * (Y - C (C y₀))
+        + W.taylorRemainder₂ x₀ y₀ := by
+  rw [taylorRemainder₂, evalEval_polynomial, evalEval_polynomialX, evalEval_polynomialY,
+    polynomial]
+  C_simp
+  ring1
+
+p2m_export "WeierstrassCurve.Affine" "taylor₂_polynomial"
+end TaylorIdentity
+
+section CotangentRelation
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine.CoordinateRing"
+
+theorem mk_taylorRemainder₂_mem_XYIdeal_sq (x₀ y₀ : R) :
+    CoordinateRing.mk W (W.taylorRemainder₂ x₀ y₀) ∈ XYIdeal W x₀ (C y₀) ^ 2 := by
+  have hX : XClass W x₀ ∈ XYIdeal W x₀ (C y₀) := subset_span (Set.mem_insert _ _)
+  have hY : YClass W (C y₀) ∈ XYIdeal W x₀ (C y₀) :=
+    subset_span (Set.mem_insert_of_mem _ rfl)
+  have hX2 : XClass W x₀ ^ 2 ∈ XYIdeal W x₀ (C y₀) ^ 2 := pow_mem_pow hX 2
+  have hY2 : YClass W (C y₀) ^ 2 ∈ XYIdeal W x₀ (C y₀) ^ 2 := pow_mem_pow hY 2
+  have hXY : XClass W x₀ * YClass W (C y₀) ∈ XYIdeal W x₀ (C y₀) ^ 2 := by
+    rw [sq]; exact Ideal.mul_mem_mul hX hY
+  have key : CoordinateRing.mk W (W.taylorRemainder₂ x₀ y₀) =
+      YClass W (C y₀) ^ 2
+        + CoordinateRing.mk W (C (C W.a₁)) * (XClass W x₀ * YClass W (C y₀))
+        - CoordinateRing.mk W (C (X + C (2 * x₀ + W.a₂))) * XClass W x₀ ^ 2 := by
+    simp only [taylorRemainder₂, XClass, YClass, map_sub, map_add, map_mul, map_pow]
+    ring1
+  rw [key]
+  exact sub_mem (add_mem hY2 (Ideal.mul_mem_left _ _ hXY)) (Ideal.mul_mem_left _ _ hX2)
+
+theorem taylor_linear_mem_XYIdeal_sq {x₀ y₀ : R} (hP : W.Equation x₀ y₀) :
+    (algebraMap R W.CoordinateRing) (W.polynomialX.evalEval x₀ y₀) * XClass W x₀
+        + (algebraMap R W.CoordinateRing) (W.polynomialY.evalEval x₀ y₀) * YClass W (C y₀)
+      ∈ XYIdeal W x₀ (C y₀) ^ 2 := by
+  have h0 : CoordinateRing.mk W W.polynomial = 0 := AdjoinRoot.mk_self
+  have hF0 : W.polynomial.evalEval x₀ y₀ = 0 := hP
+  have hexp := congrArg (CoordinateRing.mk W) (W.taylor₂_polynomial x₀ y₀)
+  rw [h0, hF0] at hexp
+  have hlin : (algebraMap R W.CoordinateRing) (W.polynomialX.evalEval x₀ y₀) * XClass W x₀
+        + (algebraMap R W.CoordinateRing) (W.polynomialY.evalEval x₀ y₀) * YClass W (C y₀)
+      = - CoordinateRing.mk W (W.taylorRemainder₂ x₀ y₀) := by
+    rw [eq_neg_iff_add_eq_zero]
+    rw [show (algebraMap R W.CoordinateRing) (W.polynomialX.evalEval x₀ y₀)
+        = CoordinateRing.mk W (C (C (W.polynomialX.evalEval x₀ y₀))) from rfl,
+      show (algebraMap R W.CoordinateRing) (W.polynomialY.evalEval x₀ y₀)
+        = CoordinateRing.mk W (C (C (W.polynomialY.evalEval x₀ y₀))) from rfl,
+      XClass, YClass]
+    simp only [map_add, map_mul, _root_.map_zero, zero_add] at hexp
+    exact hexp.symm
+  rw [hlin]
+  exact neg_mem (mk_taylorRemainder₂_mem_XYIdeal_sq x₀ y₀)
+
+end CotangentRelation
+
+
+section TwoTorsionLocus
+
+variable (W)
+
+theorem sub_negY_eq_evalEval_polynomialY (x₀ y₀ : R) :
+    y₀ - W.negY x₀ y₀ = W.polynomialY.evalEval x₀ y₀ := by
+  rw [negY, evalEval_polynomialY]; ring
+
+theorem evalEval_polynomialY_eq_zero_iff_eq_negY (x₀ y₀ : R) :
+    W.polynomialY.evalEval x₀ y₀ = 0 ↔ y₀ = W.negY x₀ y₀ := by
+  rw [← sub_negY_eq_evalEval_polynomialY, sub_eq_zero]
+
+end TwoTorsionLocus
+end Affine
+end WeierstrassCurve
+end
+
+
+section
+
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~P\
+  lace.ord_algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq \
+  P2MW.S_OVERLONG_e431601d.AlgebraicCurve \
+  WeierstrassCurve~Affine.genericPoint \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurv\
+  e WeierstrassCurve.Affine~genericPoint \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine~genericPoint WeierstrassCurve~Affine.genericPoint"
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι rec mk ι"
+p2m_open "WeierstrassCurve.Affine.IsogenyEndDatum"
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem isIntegral_algHomId :
+    (AlgHom.id F W.FunctionField).toRingHom.IsIntegral :=
+  RingHom.isIntegral_of_surjective _ Function.surjective_id
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem restrictAlong_algHomId (w : AlgebraicCurve.Place F W.FunctionField) :
+    w.restrictAlong (AlgHom.id F W.FunctionField) (isIntegral_algHomId W) = w :=
+  AlgebraicCurve.Place.ext (SetLike.ext fun _ => Iff.rfl)
+
+end IsogenyEndDatum
+
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι rec mk ι"
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+end WeierstrassCurve
+
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+end WeierstrassCurve
+end
+
+section
+
+
+section
+
+
+p2m_open "IsDedekindDomain \
+  P2MW.S_OVERLONG_e431601d.IsDedekindDomai\
+  n Polynomial \
+  P2MW.S_OVERLONG_e431601d.Polynomial"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_e431601d.Polynomial.Bivar\
+  iate WeierstrassCurve \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "smul_basis_eq_zero XYIdeal \
+  quotientXYIdealEquiv XClass_ne_zero smul YClass mk map degree_norm_smul_basis \
+  exists_smul_basis_eq XClass smul_basis_mul_Y YClass_ne_zero isDedekindDomain exists_eq_XYIdeal \
+  XYIdeal_isMaximal XYIdeal_ne_bot"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing WeierstrassCurve.Affine~genericPoint \
+  WeierstrassCurve~Affine.genericPoint"
+
+p2m_open "AdjoinRoot \
+  P2MW.S_OVERLONG_e431601d.AdjoinRoot"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem mk_sub_algebraMap_evalEval_mem_XYIdeal (q : F[X][Y]) (x₀ y₀ : F) :
+    mk W q - algebraMap F W.CoordinateRing (q.evalEval x₀ y₀) ∈ XYIdeal W x₀ (C y₀) := by
+  obtain ⟨b, hb⟩ : (Y : F[X][Y]) - C (C y₀) ∣ q - C (q.eval (C y₀)) :=
+    X_sub_C_dvd_sub_C_eval
+  obtain ⟨a, ha⟩ : (X : F[X]) - C x₀ ∣ q.eval (C y₀) - C (q.evalEval x₀ y₀) :=
+    X_sub_C_dvd_sub_C_eval
+  have hsplit : q - C (C (q.evalEval x₀ y₀))
+      = ((Y : F[X][Y]) - C (C y₀)) * b + C ((X : F[X]) - C x₀) * C a := by
+    have hstep : q - C (C (q.evalEval x₀ y₀))
+        = (q - C (q.eval (C y₀))) + C (q.eval (C y₀) - C (q.evalEval x₀ y₀)) := by
+      rw [map_sub]
+      ring
+    rw [hstep, hb, ha, ← C_mul]
+  have hmem : mk W (q - C (C (q.evalEval x₀ y₀))) ∈ XYIdeal W x₀ (C y₀) := by
+    rw [hsplit, map_add, map_mul, map_mul]
+    exact add_mem
+      (Ideal.mul_mem_right _ _ (Ideal.subset_span (Or.inr rfl)))
+      (Ideal.mul_mem_right _ _ (Ideal.subset_span (Or.inl rfl)))
+  rwa [map_sub, show mk W (C (C (q.evalEval x₀ y₀)))
+    = algebraMap F W.CoordinateRing (q.evalEval x₀ y₀) from rfl] at hmem
+
+theorem mk_mem_XYIdeal_iff_evalEval_eq_zero {x₀ y₀ : F} (h : W.Equation x₀ y₀)
+    (q : F[X][Y]) :
+    mk W q ∈ XYIdeal W x₀ (C y₀) ↔ q.evalEval x₀ y₀ = 0 := by
+  constructor
+  · intro hq
+    by_contra hne
+    have hconst : algebraMap F W.CoordinateRing (q.evalEval x₀ y₀) ∈ XYIdeal W x₀ (C y₀) := by
+      have := Ideal.sub_mem _ hq (mk_sub_algebraMap_evalEval_mem_XYIdeal q x₀ y₀)
+      rwa [sub_sub_cancel] at this
+    have : (1 : W.CoordinateRing) ∈ XYIdeal W x₀ (C y₀) := by
+      have := Ideal.mul_mem_left (XYIdeal W x₀ (C y₀))
+        (algebraMap F W.CoordinateRing (q.evalEval x₀ y₀)⁻¹) hconst
+      rwa [← map_mul, inv_mul_cancel₀ hne, map_one] at this
+    exact (XYIdeal_isMaximal h).ne_top (Ideal.eq_top_of_isUnit_mem _ this isUnit_one)
+  · intro hq
+    have := mk_sub_algebraMap_evalEval_mem_XYIdeal (W := W) q x₀ y₀
+    rwa [hq, _root_.map_zero, sub_zero] at this
+
+end CoordinateRing
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "smul_basis_eq_zero XYIdeal \
+  quotientXYIdealEquiv XClass_ne_zero smul YClass mk map degree_norm_smul_basis \
+  exists_smul_basis_eq XClass smul_basis_mul_Y YClass_ne_zero isDedekindDomain exists_eq_XYIdeal \
+  XYIdeal_isMaximal XYIdeal_ne_bot"
+end CoordinateRing
+end Affine
+end WeierstrassCurve
+end
+
+
+section
+
+p2m_open "IsDedekindDomain \
+  P2MW.S_OVERLONG_e431601d.IsDedekindDomai\
+  n WithZero \
+  P2MW.S_OVERLONG_e431601d.WithZero \
+  IsLocalRing \
+  P2MW.S_OVERLONG_e431601d.IsLocalRing"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongHom algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong Place.ramificationIndexAlong SeparableAlong Place \
+  Place.ext Place.ord Place.ord_zero HasPrincipalDivisors Pic0 Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~P\
+  lace.ord_algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos ext coe_algebraMap deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff adicValuation_coe_irreducible ord ord_zero ord_mul ord_inv \
+  ord_coe_irreducible ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum \
+  ofHeightOneSpectrum_toValuationSubring rec ne_top' algebraMap_mem' toValuationSubring mk \
+  mem_of_eval_monic_eq_zero isEquiv_adicValuation_of_valuationSubring_eq \
+  ord_eq_zero_iff_adicValuation_eq_one ofHeightOneSpectrum_injective \
+  ord_ofHeightOneSpectrum_ne_zero_iff"
+end Place
+end AlgebraicCurve
+end
+
+
+section
+
+p2m_open "IsDedekindDomain \
+  P2MW.S_OVERLONG_e431601d.IsDedekindDomai\
+  n WithZero \
+  P2MW.S_OVERLONG_e431601d.WithZero \
+  IsLocalRing \
+  P2MW.S_OVERLONG_e431601d.IsLocalRing"
+p2m_open_scoped "Polynomial \
+  P2MW.S_OVERLONG_e431601d.Polynomial"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongHom algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong Place.ramificationIndexAlong SeparableAlong Place \
+  Place.ext Place.ord Place.ord_zero HasPrincipalDivisors Pic0 Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~P\
+  lace.ord_algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq"
+
+theorem le_exp_neg_one_of_lt_one {x : ℤᵐ⁰} (hx : x < 1) : x ≤ exp (-1 : ℤ) := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · exact zero_le
+  · rw [← exp_log hx0] at hx ⊢
+    rw [show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_lt_exp] at hx
+    rw [exp_le_exp]
+    omega
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos ext coe_algebraMap deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff adicValuation_coe_irreducible ord ord_zero ord_mul ord_inv \
+  ord_coe_irreducible ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum \
+  ofHeightOneSpectrum_toValuationSubring rec ne_top' algebraMap_mem' toValuationSubring mk \
+  mem_of_eval_monic_eq_zero isEquiv_adicValuation_of_valuationSubring_eq \
+  ord_eq_zero_iff_adicValuation_eq_one ofHeightOneSpectrum_injective \
+  ord_ofHeightOneSpectrum_ne_zero_iff"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~ord_algebraMa\
+  p~ord_eq_neg_log_of_valuationSubring_eq"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.isUnit_algebraMap {c : K} (hc : c ≠ 0) :
+    IsUnit (algebraMap K v.toValuationSubring c) :=
+  (isUnit_iff_ne_zero.mpr hc).map _
+
+p2m_export "AlgebraicCurve.Place" "isUnit_algebraMap"
+private theorem _root_.AlgebraicCurve.Place.adicValuation_algebraMap {c : K} (hc : c ≠ 0) :
+    v.adicValuation (algebraMap K F c) = 1 := by
+  rw [← v.coe_algebraMap]
+  exact (v.adicValuation_coe_eq_one_iff _).mpr (v.isUnit_algebraMap hc)
+
+p2m_export "AlgebraicCurve.Place" "adicValuation_algebraMap"
+theorem ord_algebraMap (c : K) : v.ord (algebraMap K F c) = 0 := by
+  rcases eq_or_ne c 0 with rfl | hc
+  · rw [_root_.map_zero, v.ord_zero]
+  · simp only [ord, v.adicValuation_algebraMap hc, log_one, _root_.neg_zero]
+
+theorem ord_eq_neg_log_of_valuationSubring_eq (w : Valuation F ℤᵐ⁰)
+    (hw : w.valuationSubring = v.toValuationSubring) {π : F} (hπ : w π = exp (-1 : ℤ))
+    {f : F} (hf : f ≠ 0) : v.ord f = -log (w f) := by
+  have hequiv : w.IsEquiv v.adicValuation :=
+    v.isEquiv_adicValuation_of_valuationSubring_eq hw
+  have hexp_lt : (exp (-1 : ℤ) : ℤᵐ⁰) < 1 := by
+    rw [show (1 : ℤᵐ⁰) = exp 0 from rfl]
+    exact exp_lt_exp.mpr (by omega)
+  obtain ⟨π₀, hπ₀⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hadic_π₀ : v.adicValuation (π₀ : F) = exp (-1 : ℤ) := v.adicValuation_coe_irreducible hπ₀
+  have hwπ₀ : w (π₀ : F) = exp (-1 : ℤ) := by
+    refine le_antisymm (le_exp_neg_one_of_lt_one (hequiv.lt_one_iff_lt_one.mpr ?_)) ?_
+    · rw [hadic_π₀]
+      exact hexp_lt
+    · rw [← hπ]
+      refine (hequiv π π₀).mpr ?_
+      rw [hadic_π₀]
+      refine le_exp_neg_one_of_lt_one (hequiv.lt_one_iff_lt_one.mp ?_)
+      rw [hπ]
+      exact hexp_lt
+  obtain ⟨u, hu⟩ := v.exists_unit_mul_zpow hf hπ₀
+  have hwu : w ((u : v.toValuationSubring) : F) = 1 :=
+    hequiv.eq_one_iff_eq_one.mpr ((v.adicValuation_coe_eq_one_iff _).mpr u.isUnit)
+  set n := v.ord f with hn
+  rw [hu, map_mul, map_zpow₀, hwu, hwπ₀, one_mul, log_zpow, log_exp, smul_eq_mul]
+  ring
+
+end Place
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "placeOfPoint placeOfPoint_injective \
+  deg_placeOfPoint"
+end RationalFunctionField
+end AlgebraicCurve
+end
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_e431601d.Polynomial \
+  IsDedekindDomain \
+  P2MW.S_OVERLONG_e431601d.IsDedekindDomain"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_e431601d.Polynomial.Bivar\
+  iate"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongHom algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong Place.ramificationIndexAlong SeparableAlong Place \
+  Place.ext Place.ord Place.ord_zero HasPrincipalDivisors Pic0 Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos ext coe_algebraMap deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff adicValuation_coe_irreducible ord ord_zero ord_mul ord_inv \
+  ord_coe_irreducible ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum \
+  ofHeightOneSpectrum_toValuationSubring rec ne_top' algebraMap_mem' toValuationSubring mk \
+  mem_of_eval_monic_eq_zero isEquiv_adicValuation_of_valuationSubring_eq \
+  ord_eq_zero_iff_adicValuation_eq_one ofHeightOneSpectrum_injective \
+  ord_ofHeightOneSpectrum_ne_zero_iff"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~ord_algebraMa\
+  p~ord_eq_neg_log_of_valuationSubring_eq \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~Place.ord\
+  _algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.ord_add_eq_min {f g : F} (hf : f ≠ 0) (hg : g ≠ 0)
+    (h : v.ord f ≠ v.ord g) :
+    v.ord (f + g) = min (v.ord f) (v.ord g) := by
+  have hval : v.adicValuation f ≠ v.adicValuation g := by
+    intro hcon
+    exact h (by simp only [ord, hcon])
+  have h1 : v.adicValuation (f + g) = max (v.adicValuation f) (v.adicValuation g) :=
+    Valuation.map_add_of_distinct_val _ hval
+  have hfg : f + g ≠ 0 := by
+    intro hcon
+    rw [hcon, _root_.map_zero] at h1
+    rcases max_cases (v.adicValuation f) (v.adicValuation g) with ⟨hmax, -⟩ | ⟨hmax, -⟩ <;>
+      rw [hmax] at h1
+    · exact v.adicValuation_ne_zero hf h1.symm
+    · exact v.adicValuation_ne_zero hg h1.symm
+  rcases max_cases (v.adicValuation f) (v.adicValuation g) with ⟨hmax, hle⟩ | ⟨hmax, hlt⟩ <;>
+    rw [hmax] at h1
+  · have hlog := (WithZero.log_le_log (v.adicValuation_ne_zero hg)
+      (v.adicValuation_ne_zero hf)).mpr hle
+    have h2 : v.ord (f + g) = v.ord f := by simp only [ord, h1]
+    simp only [ord] at hlog h2 ⊢
+    omega
+  · have hlog := (WithZero.log_le_log (v.adicValuation_ne_zero hf)
+      (v.adicValuation_ne_zero hg)).mpr hlt.le
+    have h2 : v.ord (f + g) = v.ord g := by simp only [ord, h1]
+    simp only [ord] at hlog h2 ⊢
+    omega
+
+p2m_export "AlgebraicCurve.Place" "ord_add_eq_min"
+private theorem ord_algebraMap_s18priv (c : K) : v.ord (algebraMap K F c) = 0 := by
+  rcases eq_or_ne c 0 with rfl | hc
+  · simp
+  have hmem : algebraMap K F c ∈ v.toValuationSubring := v.algebraMap_mem' c
+  have hmem' : (algebraMap K F c)⁻¹ ∈ v.toValuationSubring := by
+    rw [← map_inv₀]
+    exact v.algebraMap_mem' c⁻¹
+  have h1 := AlgebraicCurve.Place.ord_nonneg_of_mem v hmem
+  have h2 := AlgebraicCurve.Place.ord_nonneg_of_mem v hmem'
+  rw [v.ord_inv] at h2
+  omega
+
+private theorem _root_.AlgebraicCurve.Place.ord_pow (f : F) (n : ℕ) :
+    v.ord (f ^ n) = n * v.ord f := by
+  rw [← zpow_natCast, v.ord_zpow]
+
+p2m_export "AlgebraicCurve.Place" "ord_pow"
+private theorem _root_.AlgebraicCurve.Place.ord_ringHom_eq_natDegree_mul {φ : K[X] →+* F}
+    (hφinj : Function.Injective φ)
+    (hφC : ∀ c : K, φ (C c) = algebraMap K F c) (hz : v.ord (φ X) < 0) :
+    ∀ {p : K[X]}, p ≠ 0 → v.ord (φ p) = p.natDegree * v.ord (φ X) := by
+  have hX0 : φ X ≠ 0 := fun h => by simp [Place.ord, h] at hz
+  have hmono : ∀ (c : K) (n : ℕ), c ≠ 0 → v.ord (φ (C c * X ^ n)) = n * v.ord (φ X) := by
+    intro c n hc
+    have hc0 : φ (C c) ≠ 0 := by
+      rw [hφC]
+      simpa using hc
+    rw [map_mul, map_pow, v.ord_mul hc0 (pow_ne_zero n hX0), hφC,
+      AlgebraicCurve.Place.ord_algebraMap v,
+      v.ord_pow, zero_add]
+  intro p
+  induction hd : p.natDegree using Nat.strong_induction_on generalizing p with
+  | _ d ih =>
+    intro hp
+    subst hd
+    rcases eq_or_ne p.eraseLead 0 with he | he
+    · conv_lhs => rw [← p.eraseLead_add_C_mul_X_pow, he, zero_add]
+      exact hmono _ _ (leadingCoeff_ne_zero.mpr hp)
+    · have hlt : p.eraseLead.natDegree < p.natDegree := by
+        rcases p.eraseLead_natDegree_lt_or_eraseLead_eq_zero with h | h
+        · exact h
+        · exact absurd h he
+      have hIH : v.ord (φ p.eraseLead) = p.eraseLead.natDegree * v.ord (φ X) :=
+        ih _ hlt rfl he
+      have hlead : v.ord (φ (C p.leadingCoeff * X ^ p.natDegree))
+          = p.natDegree * v.ord (φ X) := hmono _ _ (leadingCoeff_ne_zero.mpr hp)
+      have hcast : (p.eraseLead.natDegree : ℤ) < (p.natDegree : ℤ) := by exact_mod_cast hlt
+      have hne : v.ord (φ p.eraseLead) ≠ v.ord (φ (C p.leadingCoeff * X ^ p.natDegree)) := by
+        rw [hIH, hlead]
+        nlinarith
+      have he2 : φ (C p.leadingCoeff * X ^ p.natDegree) ≠ 0 := fun hcon =>
+        mul_ne_zero (C_ne_zero.mpr (leadingCoeff_ne_zero.mpr hp)) (pow_ne_zero _ X_ne_zero)
+          (hφinj (hcon.trans (_root_.map_zero φ).symm))
+      have he1 : φ p.eraseLead ≠ 0 := fun hcon => he (hφinj (hcon.trans (_root_.map_zero φ).symm))
+      conv_lhs => rw [← p.eraseLead_add_C_mul_X_pow]
+      rw [map_add, v.ord_add_eq_min he1 he2 hne, hIH, hlead]
+      have h1 : (p.natDegree : ℤ) * v.ord (φ X) ≤ (p.eraseLead.natDegree : ℤ) * v.ord (φ X) := by
+        nlinarith
+      omega
+
+p2m_export "AlgebraicCurve.Place" "ord_ringHom_eq_natDegree_mul"
+private theorem _root_.AlgebraicCurve.Place.le_ord_ringHom_of_natDegree_le {φ : K[X] →+* F}
+    (hφinj : Function.Injective φ)
+    (hφC : ∀ c : K, φ (C c) = algebraMap K F c) (hz : v.ord (φ X) < 0)
+    {p : K[X]} {d : ℕ} (hd : p.natDegree ≤ d) :
+    (d : ℤ) * v.ord (φ X) ≤ v.ord (φ p) := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp only [_root_.map_zero, Place.ord_zero]
+    nlinarith [hz]
+  rw [v.ord_ringHom_eq_natDegree_mul hφinj hφC hz hp]
+  have h1 : (p.natDegree : ℤ) ≤ (d : ℤ) := by exact_mod_cast hd
+  nlinarith
+
+p2m_export "AlgebraicCurve.Place" "le_ord_ringHom_of_natDegree_le"
+end Place
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine~genericPoint WeierstrassCurve~Affine.genericPoint"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~Place.ord\
+  _algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq \
+  P2MW.S_OVERLONG_e431601d.AlgebraicCurve"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+private def _root_.WeierstrassCurve.Affine.polyToFunctionField (W : Affine F) :
+    F[X] →+* W.FunctionField :=
+  (algebraMap W.CoordinateRing W.FunctionField).comp (algebraMap F[X] W.CoordinateRing)
+
+p2m_export "WeierstrassCurve.Affine" "polyToFunctionField"
+theorem polyToFunctionField_apply (p : F[X]) :
+    polyToFunctionField W p
+      = algebraMap W.CoordinateRing W.FunctionField (algebraMap F[X] W.CoordinateRing p) := rfl
+
+theorem algebraMap_smul_one (p : F[X]) :
+    algebraMap W.CoordinateRing W.FunctionField (p • (1 : W.CoordinateRing))
+      = polyToFunctionField W p := by
+  rw [polyToFunctionField_apply, smul, mul_one]
+  rfl
+
+theorem polyToFunctionField_injective : Function.Injective (polyToFunctionField W) := by
+  intro p q h
+  rw [polyToFunctionField_apply, polyToFunctionField_apply] at h
+  have h2 := IsFractionRing.injective W.CoordinateRing W.FunctionField h
+  have h0 : (p - q) • (1 : W.CoordinateRing) + (0 : F[X]) • CoordinateRing.mk W Y = 0 := by
+    rw [zero_smul, add_zero, sub_smul, ← Algebra.algebraMap_eq_smul_one,
+      ← Algebra.algebraMap_eq_smul_one, h2, sub_self]
+  exact sub_eq_zero.mp (smul_basis_eq_zero h0).1
+
+theorem polyToFunctionField_C (c : F) :
+    polyToFunctionField W (C c) = algebraMap F W.FunctionField c := by
+  rw [polyToFunctionField_apply,
+    show algebraMap F[X] W.CoordinateRing (C c) = algebraMap F W.CoordinateRing c from
+      (IsScalarTower.algebraMap_apply F F[X] W.CoordinateRing c).symm]
+  exact (IsScalarTower.algebraMap_apply F W.CoordinateRing W.FunctionField c).symm
+
+theorem polyToFunctionField_ne_zero {p : F[X]} (hp : p ≠ 0) :
+    polyToFunctionField W p ≠ 0 := by
+  intro h
+  exact hp (polyToFunctionField_injective (by simpa using h))
+
+theorem algebraMap_smul_basis (p q : F[X]) :
+    algebraMap W.CoordinateRing W.FunctionField
+        (p • (1 : W.CoordinateRing) + q • CoordinateRing.mk W Y)
+      = polyToFunctionField W p + polyToFunctionField W q
+          * algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) := by
+  rw [map_add, algebraMap_smul_one, smul, map_mul, polyToFunctionField_apply]
+  rfl
+
+theorem Y_image_ne_zero :
+    algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) ≠ 0 := by
+  have h1 : (CoordinateRing.mk W Y) ≠ 0 := by
+    have h2 := YClass_ne_zero (W' := W) 0
+    simpa [YClass] using h2
+  exact (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr h1
+
+theorem natDegree_norm_smul_basis_left {p : F[X]} (hp : p ≠ 0) :
+    ((Algebra.norm F[X] (p • (1 : W.CoordinateRing)
+        + (0 : F[X]) • CoordinateRing.mk W Y)).natDegree : ℤ) = 2 * p.natDegree := by
+  have hdeg := degree_norm_smul_basis (W' := W) p 0
+  rw [Polynomial.degree_zero, show (2 : ℕ) • (⊥ : WithBot ℕ) + 3 = ⊥ by
+      rw [two_nsmul]; simp, max_eq_left bot_le, Polynomial.degree_eq_natDegree hp, two_nsmul,
+    ← Nat.cast_add] at hdeg
+  rw [Polynomial.natDegree_eq_of_degree_eq_some hdeg]
+  push_cast
+  ring
+
+theorem natDegree_norm_smul_basis_right {q : F[X]} (hq : q ≠ 0) :
+    ((Algebra.norm F[X] ((0 : F[X]) • (1 : W.CoordinateRing)
+        + q • CoordinateRing.mk W Y)).natDegree : ℤ) = 2 * q.natDegree + 3 := by
+  have hdeg := degree_norm_smul_basis (W' := W) 0 q
+  rw [Polynomial.degree_zero, show (2 : ℕ) • (⊥ : WithBot ℕ) = ⊥ by
+      rw [two_nsmul]; simp, max_eq_right bot_le, Polynomial.degree_eq_natDegree hq, two_nsmul,
+    ← Nat.cast_add, show ((3 : WithBot ℕ)) = ((3 : ℕ) : WithBot ℕ) from rfl,
+    ← Nat.cast_add] at hdeg
+  rw [Polynomial.natDegree_eq_of_degree_eq_some hdeg]
+  push_cast
+  ring
+
+theorem natDegree_norm_smul_basis_max {p q : F[X]} (hp : p ≠ 0) (hq : q ≠ 0) :
+    ((Algebra.norm F[X] (p • (1 : W.CoordinateRing)
+        + q • CoordinateRing.mk W Y)).natDegree : ℤ)
+      = max (2 * (p.natDegree : ℤ)) (2 * (q.natDegree : ℤ) + 3) := by
+  have hdeg := degree_norm_smul_basis (W' := W) p q
+  rw [Polynomial.degree_eq_natDegree hp, Polynomial.degree_eq_natDegree hq, two_nsmul,
+    two_nsmul, ← Nat.cast_add, ← Nat.cast_add,
+    show ((3 : WithBot ℕ)) = ((3 : ℕ) : WithBot ℕ) from rfl, ← Nat.cast_add] at hdeg
+  rcases le_total (q.natDegree + q.natDegree + 3) (p.natDegree + p.natDegree) with h | h
+  · rw [max_eq_left (by exact_mod_cast h)] at hdeg
+    rw [Polynomial.natDegree_eq_of_degree_eq_some hdeg]
+    push_cast
+    omega
+  · rw [max_eq_right (by exact_mod_cast h)] at hdeg
+    rw [Polynomial.natDegree_eq_of_degree_eq_some hdeg]
+    push_cast
+    omega
+
+variable (v : AlgebraicCurve.Place F W.FunctionField)
+
+theorem isFinitePlace_of_mem
+    (hx : polyToFunctionField W X ∈ v.toValuationSubring) : IsFinitePlace v := by
+  have hpoly : ∀ p : F[X], polyToFunctionField W p ∈ v.toValuationSubring := by
+    intro p
+    induction p using Polynomial.induction_on' with
+    | add f g hf hg => rw [map_add]; exact add_mem hf hg
+    | monomial n c =>
+        rw [← C_mul_X_pow_eq_monomial, map_mul, map_pow]
+        refine mul_mem ?_ (pow_mem hx n)
+        rw [polyToFunctionField_C]
+        exact v.algebraMap_mem' c
+  set η := algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) with hηdef
+  set c₁ : F[X] := C W.a₁ * X + C W.a₃ with hc₁def
+  set cb : F[X] := X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ with hcbdef
+  have hrel : η * η = polyToFunctionField W cb - polyToFunctionField W c₁ * η := by
+    have h1 := smul_basis_mul_Y (W' := W) 0 1
+    rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at h1
+    have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) h1
+    rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+    exact h2
+  have hy : η ∈ v.toValuationSubring := by
+    refine v.mem_of_eval_monic_eq_zero (P := Polynomial.X ^ 2
+      + (Polynomial.C (polyToFunctionField W c₁) * Polynomial.X
+        - Polynomial.C (polyToFunctionField W cb))) ?_ ?_ (x := η) ?_
+    · refine Polynomial.monic_X_pow_add (n := 2) ?_
+      rw [sub_eq_add_neg, ← Polynomial.C_neg]
+      refine lt_of_le_of_lt Polynomial.degree_linear_le ?_
+      exact_mod_cast Nat.one_lt_two
+    · intro i
+      rw [show (Polynomial.C (polyToFunctionField W c₁) * Polynomial.X : Polynomial _)
+          = Polynomial.C (polyToFunctionField W c₁) * Polynomial.X ^ 1 by ring]
+      simp only [Polynomial.coeff_add, Polynomial.coeff_sub, Polynomial.coeff_X_pow,
+        Polynomial.coeff_C_mul, Polynomial.coeff_C]
+      refine add_mem ?_ (sub_mem ?_ ?_)
+      · split <;> simp [v.toValuationSubring.one_mem, v.toValuationSubring.zero_mem]
+      · split
+        · rw [mul_one]; exact hpoly _
+        · rw [mul_zero]; exact v.toValuationSubring.zero_mem
+      · split
+        · exact hpoly _
+        · exact v.toValuationSubring.zero_mem
+    · simp only [Polynomial.eval_add, Polynomial.eval_sub, Polynomial.eval_pow,
+        Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_X]
+      rw [sq]
+      linear_combination hrel
+  intro r
+  obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq r
+  rw [algebraMap_smul_basis]
+  exact add_mem (hpoly p) (mul_mem (hpoly q) hy)
+
+theorem ord_X_neg_of_not_isFinitePlace (hv : ¬ IsFinitePlace v) :
+    v.ord (polyToFunctionField W X) < 0 := by
+  by_contra hcon
+  push Not at hcon
+  exact hv (isFinitePlace_of_mem v
+    (AlgebraicCurve.Place.mem_of_ord_nonneg v (polyToFunctionField_ne_zero Polynomial.X_ne_zero)
+      hcon))
+
+theorem two_mul_ord_Y_eq_three_mul_ord_X (hv : ¬ IsFinitePlace v) :
+    2 * v.ord (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y))
+      = 3 * v.ord (polyToFunctionField W X) := by
+  set η := algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) with hηdef
+  have hA : v.ord (polyToFunctionField W X) < 0 := ord_X_neg_of_not_isFinitePlace v hv
+  have hη0 : η ≠ 0 := Y_image_ne_zero
+  set c₁ : F[X] := C W.a₁ * X + C W.a₃ with hc₁def
+  set cb : F[X] := X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ with hcbdef
+  have hrel : η * η = polyToFunctionField W cb - polyToFunctionField W c₁ * η := by
+    have h1 := smul_basis_mul_Y (W' := W) 0 1
+    rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at h1
+    have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) h1
+    rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+    exact h2
+  have hrelL : (η + polyToFunctionField W c₁) * η = polyToFunctionField W cb := by
+    rw [add_mul]
+    linear_combination hrel
+  have hcbdeg : cb.natDegree = 3 := by
+    rw [hcbdef, ← one_mul (X ^ 3 : F[X]), ← C_1]
+    exact Polynomial.natDegree_cubic one_ne_zero
+  have hcb0 : cb ≠ 0 := by
+    intro h
+    rw [h, Polynomial.natDegree_zero] at hcbdeg
+    exact absurd hcbdeg (by norm_num)
+  have hcbord : v.ord (polyToFunctionField W cb) = 3 * v.ord (polyToFunctionField W X) := by
+    rw [v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA
+      hcb0, hcbdeg]
+    push_cast
+    ring
+  have hc₁ord : (1 : ℤ) * v.ord (polyToFunctionField W X)
+      ≤ v.ord (polyToFunctionField W c₁) := by
+    refine v.le_ord_ringHom_of_natDegree_le polyToFunctionField_injective polyToFunctionField_C
+      hA ?_
+    rw [hc₁def]
+    refine le_trans (Polynomial.natDegree_add_le _ _) ?_
+    simp only [Polynomial.natDegree_C, max_le_iff]
+    refine ⟨le_trans (Polynomial.natDegree_C_mul_le _ _) (by simp), by omega⟩
+  rw [one_mul] at hc₁ord
+  have hfac0 : η + polyToFunctionField W c₁ ≠ 0 := by
+    intro h
+    rw [h, zero_mul] at hrelL
+    exact polyToFunctionField_ne_zero hcb0 hrelL.symm
+  have hLHS : v.ord (η + polyToFunctionField W c₁) + v.ord η
+      = 3 * v.ord (polyToFunctionField W X) := by
+    rw [← hcbord, ← hrelL, v.ord_mul hfac0 hη0]
+  rcases eq_or_ne (polyToFunctionField W c₁) 0 with hc₁0 | hc₁0
+  · rw [hc₁0, add_zero] at hLHS
+    omega
+  · by_cases hBc : v.ord η = v.ord (polyToFunctionField W c₁)
+    · exfalso
+      have hmin : min (v.ord η) (v.ord (polyToFunctionField W c₁))
+          ≤ v.ord (η + polyToFunctionField W c₁) := v.min_ord_le_ord_add' hfac0
+      rw [← hBc, min_self] at hmin
+      have hBA : v.ord (polyToFunctionField W X) ≤ v.ord η := hBc ▸ hc₁ord
+      omega
+    · have hsum : v.ord (η + polyToFunctionField W c₁)
+          = min (v.ord η) (v.ord (polyToFunctionField W c₁)) :=
+        v.ord_add_eq_min hη0 hc₁0 hBc
+      rcases min_cases (v.ord η) (v.ord (polyToFunctionField W c₁)) with
+        ⟨hm, hle⟩ | ⟨hm, hlt⟩ <;> rw [hm] at hsum
+      · rw [hsum] at hLHS
+        omega
+      · exfalso
+        rw [hsum] at hLHS
+        omega
+
+private theorem ne_arith {A B s t : ℤ} (hA : A < 0) (hY : 2 * B = 3 * A) :
+    s * A ≠ t * A + B := by
+  intro hcon
+  have h4 : (2 * s - (2 * t + 3)) * A = 0 := by linear_combination 2 * hcon + hY
+  rcases mul_eq_zero.mp h4 with h5 | h5
+  · omega
+  · omega
+
+private theorem two_mul_min_arith {A B s t : ℤ} (hA : A < 0) (hY : 2 * B = 3 * A) :
+    2 * min (s * A) (t * A + B) = A * max (2 * s) (2 * t + 3) := by
+  rcases le_or_gt (2 * t + 3) (2 * s) with h | h
+  · rw [max_eq_left h, min_eq_left (by nlinarith)]
+    ring
+  · rw [max_eq_right h.le, min_eq_right (by nlinarith)]
+    linear_combination hY
+
+theorem two_mul_ord_eq_of_not_isFinitePlace (hv : ¬ IsFinitePlace v)
+    {f : W.CoordinateRing} (hf : f ≠ 0) :
+    2 * v.ord (algebraMap W.CoordinateRing W.FunctionField f)
+      = v.ord (polyToFunctionField W X) * ((Algebra.norm F[X] f).natDegree : ℤ) := by
+  have hA : v.ord (polyToFunctionField W X) < 0 := ord_X_neg_of_not_isFinitePlace v hv
+  have hη0 : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) ≠ 0 :=
+    Y_image_ne_zero
+  have hYord := two_mul_ord_Y_eq_three_mul_ord_X v hv
+  obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq f
+  by_cases hq : q = 0
+  · subst hq
+    have hp : p ≠ 0 := fun h => hf (by rw [h, zero_smul, zero_smul, add_zero])
+    rw [natDegree_norm_smul_basis_left hp, algebraMap_smul_basis, _root_.map_zero, zero_mul,
+      add_zero,
+      v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA hp]
+    ring
+  · by_cases hp : p = 0
+    · subst hp
+      rw [natDegree_norm_smul_basis_right hq, algebraMap_smul_basis, _root_.map_zero, zero_add,
+        v.ord_mul (polyToFunctionField_ne_zero hq) hη0,
+        v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA hq]
+      linear_combination hYord
+    · rw [natDegree_norm_smul_basis_max hp hq, algebraMap_smul_basis]
+      have hordp : v.ord (polyToFunctionField W p)
+          = (p.natDegree : ℤ) * v.ord (polyToFunctionField W X) :=
+        v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA hp
+      have hordqy : v.ord (polyToFunctionField W q
+            * algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y))
+          = (q.natDegree : ℤ) * v.ord (polyToFunctionField W X)
+            + v.ord (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)) := by
+        rw [v.ord_mul (polyToFunctionField_ne_zero hq) hη0,
+          v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA
+            hq]
+      have hne : v.ord (polyToFunctionField W p) ≠ v.ord (polyToFunctionField W q
+          * algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)) := by
+        rw [hordp, hordqy]
+        exact ne_arith hA hYord
+      have hqy0 : polyToFunctionField W q
+          * algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) ≠ 0 :=
+        mul_ne_zero (polyToFunctionField_ne_zero hq) hη0
+      rw [v.ord_add_eq_min (polyToFunctionField_ne_zero hp) hqy0 hne, hordp, hordqy]
+      exact two_mul_min_arith hA hYord
+
+theorem ord_X_eq_neg_two_of_not_isFinitePlace (hv : ¬ IsFinitePlace v) :
+    v.ord (polyToFunctionField W X) = -2 := by
+  have hA : v.ord (polyToFunctionField W X) < 0 := ord_X_neg_of_not_isFinitePlace v hv
+  have hYord := two_mul_ord_Y_eq_three_mul_ord_X v hv
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible v.toValuationSubring
+  have hπord : v.ord (π : W.FunctionField) = 1 := v.ord_coe_irreducible hπ
+  have hπ0 : (π : W.FunctionField) ≠ 0 := by
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  obtain ⟨a, b, hb, hab⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing)
+    (π : W.FunctionField)
+  have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb
+  have ha0 : a ≠ 0 := by
+    intro h
+    rw [h, _root_.map_zero, zero_div] at hab
+    exact hπ0 hab.symm
+  have ha' : algebraMap W.CoordinateRing W.FunctionField a ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr ha0
+  have hb' : algebraMap W.CoordinateRing W.FunctionField b ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr hb0
+  have h1 := two_mul_ord_eq_of_not_isFinitePlace v hv ha0
+  have h2 := two_mul_ord_eq_of_not_isFinitePlace v hv hb0
+  have h3 : v.ord (π : W.FunctionField)
+      = v.ord (algebraMap W.CoordinateRing W.FunctionField a)
+        - v.ord (algebraMap W.CoordinateRing W.FunctionField b) := by
+    rw [← hab, div_eq_mul_inv, v.ord_mul ha' (inv_ne_zero hb'), v.ord_inv]
+    ring
+  rw [hπord] at h3
+  have h4 : (2 : ℤ) = v.ord (polyToFunctionField W X) * (((Algebra.norm F[X] a).natDegree : ℤ)
+      - ((Algebra.norm F[X] b).natDegree : ℤ)) := by
+    linear_combination 2 * h3 + h1 - h2
+  have h5 : v.ord (polyToFunctionField W X) ∣ 2 := ⟨_, h4⟩
+  have h6 : (2 : ℤ) ∣ v.ord (polyToFunctionField W X) := by
+    have h7 : (2 : ℤ) ∣ 3 * v.ord (polyToFunctionField W X) := ⟨_, hYord.symm⟩
+    omega
+  have h8 : (v.ord (polyToFunctionField W X)).natAbs ∣ (2 : ℤ).natAbs :=
+    Int.natAbs_dvd_natAbs.mpr h5
+  have h9 : (2 : ℤ).natAbs ∣ (v.ord (polyToFunctionField W X)).natAbs :=
+    Int.natAbs_dvd_natAbs.mpr h6
+  have h10 : (v.ord (polyToFunctionField W X)).natAbs = 2 :=
+    Nat.dvd_antisymm (by simpa using h8) (by simpa using h9)
+  omega
+
+theorem ord_Y_eq_neg_three_of_not_isFinitePlace (hv : ¬ IsFinitePlace v) :
+    v.ord (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)) = -3 := by
+  have h1 := two_mul_ord_Y_eq_three_mul_ord_X v hv
+  rw [ord_X_eq_neg_two_of_not_isFinitePlace v hv] at h1
+  omega
+
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+section
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~P\
+  lace.ord_algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq \
+  P2MW.S_OVERLONG_e431601d.AlgebraicCurve \
+  IsDedekindDomain \
+  P2MW.S_OVERLONG_e431601d.IsDedekindDomai\
+  n FractionalIdeal \
+  P2MW.S_OVERLONG_e431601d.FractionalIdeal \
+  WithZero \
+  P2MW.S_OVERLONG_e431601d.WithZero \
+  Polynomial \
+  P2MW.S_OVERLONG_e431601d.Polynomial"
+
+p2m_open_scoped "nonZeroDivisors Polynomial.Bivariate \
+  P2MW.S_OVERLONG_e431601d.Polynomial.Bivar\
+  iate"
+
+namespace FractionalIdeal
+p2m_export "FractionalIdeal" "mul_mem_mul zero_mem ext map mem_coe num"
+end FractionalIdeal
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongHom algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong Place.ramificationIndexAlong SeparableAlong Place \
+  Place.ext Place.ord Place.ord_zero HasPrincipalDivisors Pic0 Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos ext coe_algebraMap deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff adicValuation_coe_irreducible ord ord_zero ord_mul ord_inv \
+  ord_coe_irreducible ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum \
+  ofHeightOneSpectrum_toValuationSubring rec ne_top' algebraMap_mem' toValuationSubring mk \
+  mem_of_eval_monic_eq_zero isEquiv_adicValuation_of_valuationSubring_eq \
+  ord_eq_zero_iff_adicValuation_eq_one ofHeightOneSpectrum_injective \
+  ord_ofHeightOneSpectrum_ne_zero_iff"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~ord_algebraMa\
+  p~ord_eq_neg_log_of_valuationSubring_eq \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~Place.ord\
+  _algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq"
+
+variable {K : Type*} [Field K]
+variable {R : Type*} [CommRing R] [IsDedekindDomain R]
+variable {L : Type*} [Field L] [Algebra R L] [IsFractionRing R L]
+variable [Algebra K R] [Algebra K L] [IsScalarTower K R L]
+
+theorem ord_ofHeightOneSpectrum_eq_neg_log (w : HeightOneSpectrum R) {f : L} (hf : f ≠ 0) :
+    (ofHeightOneSpectrum (K := K) w).ord f = -log (w.valuation L f) := by
+  obtain ⟨π, hπ⟩ := w.intValuation_exists_uniformizer
+  have hval : w.valuation L (algebraMap R L π) = exp (-1 : ℤ) := by
+    rw [w.valuation_of_algebraMap]
+    exact hπ
+  exact AlgebraicCurve.Place.ord_eq_neg_log_of_valuationSubring_eq (ofHeightOneSpectrum (K := K) w)
+    (w.valuation L) rfl hval hf
+
+end Place
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+end Affine
+end WeierstrassCurve
+end
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_e431601d.Polynomial \
+  IsDedekindDomain \
+  P2MW.S_OVERLONG_e431601d.IsDedekindDomain"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_e431601d.Polynomial.Bivar\
+  iate"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongHom algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong Place.ramificationIndexAlong SeparableAlong Place \
+  Place.ext Place.ord Place.ord_zero HasPrincipalDivisors Pic0 Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~P\
+  lace.ord_algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq"
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos ext coe_algebraMap deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff adicValuation_coe_irreducible ord ord_zero ord_mul ord_inv \
+  ord_coe_irreducible ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum \
+  ofHeightOneSpectrum_toValuationSubring rec ne_top' algebraMap_mem' toValuationSubring mk \
+  mem_of_eval_monic_eq_zero isEquiv_adicValuation_of_valuationSubring_eq \
+  ord_eq_zero_iff_adicValuation_eq_one ofHeightOneSpectrum_injective \
+  ord_ofHeightOneSpectrum_ne_zero_iff"
+end Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+theorem Place.mem_restrictAlong_iff (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') (f : F) :
+    f ∈ (w.restrictAlong φ hφ).toValuationSubring ↔ φ f ∈ w.toValuationSubring :=
+  Iff.rfl
+
+p2m_open_scoped "AlgebraicCurve.Place" in
+theorem Place.ramificationIndexAlong_pos (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') : 0 < Place.ramificationIndexAlong φ w := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  exact w.ramificationIndex_pos
+
+p2m_open_scoped "AlgebraicCurve.Place" in
+theorem Place.ord_restrictAlong_ne_zero_iff (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') (f : F) :
+    (w.restrictAlong φ hφ).ord f ≠ 0 ↔ w.ord (φ f) ≠ 0 := by
+  rw [w.ord_restrictAlong φ hφ f]
+  have hpos := Place.ramificationIndexAlong_pos φ hφ w
+  constructor
+  · intro h hcon
+    rcases mul_eq_zero.mp hcon with h1 | h1
+    · omega
+    · exact h h1
+  · intro h hcon
+    exact h (by rw [hcon, mul_zero])
+
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine~genericPoint WeierstrassCurve~Affine.genericPoint"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~Place.ord\
+  _algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq \
+  P2MW.S_OVERLONG_e431601d.AlgebraicCurve"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem algebraMap_polynomial_eq_mk_C (p : F[X]) :
+    algebraMap F[X] W.CoordinateRing p = CoordinateRing.mk W (C p) :=
+  rfl
+
+theorem algebraMap_coordinateRing_ne_zero {r : W.CoordinateRing} (hr : r ≠ 0) :
+    algebraMap W.CoordinateRing W.FunctionField r ≠ 0 :=
+  (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr hr
+
+theorem mk_mem_XYIdeal_iff {x y : F} (h : W.Equation x y) (P : F[X][Y]) :
+    CoordinateRing.mk W P ∈ XYIdeal W x (C y) ↔ P.evalEval x y = 0 := by
+  have hmap : XYIdeal W x (C y)
+      = Ideal.map (CoordinateRing.mk W) (Ideal.span {C (X - C x), Y - C (C y)}) := by
+    rw [Ideal.map_span, Set.image_pair]
+    rfl
+  rw [hmap]
+  constructor
+  · intro hP
+    obtain ⟨Q, hQ, hQP⟩ := (Ideal.mem_map_iff_of_surjective _ AdjoinRoot.mk_surjective).mp hP
+    obtain ⟨c, hc⟩ := AdjoinRoot.mk_eq_mk.mp hQP
+    have hQ0 : Q.evalEval x y = 0 :=
+      mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero.mp hQ
+    have hW0 : W.polynomial.evalEval x y = 0 := h
+    have hPQ : P = Q - W.polynomial * c := by rw [← hc]; ring
+    rw [hPQ]
+    simp only [evalEval, eval_sub, eval_mul] at hQ0 hW0 ⊢
+    rw [hQ0, hW0, zero_mul, sub_zero]
+  · intro hP
+    exact Ideal.mem_map_of_mem _ (mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero.mpr hP)
+
+theorem ord_placeOfEquation_ne_zero_iff [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) {r : W.CoordinateRing} (hr : r ≠ 0) :
+    (placeOfEquation h).ord (algebraMap W.CoordinateRing W.FunctionField r) ≠ 0
+      ↔ r ∈ XYIdeal W x (C y) := by
+  rw [placeOfEquation, Place.ord_ofHeightOneSpectrum_ne_zero_iff _ hr,
+    heightOneSpectrumOfEquation_asIdeal]
+
+theorem ord_placeOfEquation_nonneg [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) (r : W.CoordinateRing) :
+    0 ≤ (placeOfEquation h).ord (algebraMap W.CoordinateRing W.FunctionField r) :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem (placeOfEquation h) (isFinitePlace_placeOfEquation h r)
+
+theorem ord_placeOfEquation_pos_iff [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) {r : W.CoordinateRing} (hr : r ≠ 0) :
+    0 < (placeOfEquation h).ord (algebraMap W.CoordinateRing W.FunctionField r)
+      ↔ r ∈ XYIdeal W x (C y) := by
+  rw [← ord_placeOfEquation_ne_zero_iff h hr]
+  have := ord_placeOfEquation_nonneg h r
+  omega
+
+theorem IsFinitePlace.mem_centre_iff_ord_ne_zero {v : Place F W.FunctionField}
+    (hv : IsFinitePlace v) {r : W.CoordinateRing} (hr : r ≠ 0) :
+    r ∈ hv.centre ↔ v.ord (algebraMap W.CoordinateRing W.FunctionField r) ≠ 0 := by
+  have hr' : algebraMap W.CoordinateRing W.FunctionField r ≠ 0 :=
+    algebraMap_coordinateRing_ne_zero hr
+  rw [IsFinitePlace.centre, Ideal.mem_comap, IsLocalRing.mem_maximalIdeal, mem_nonunits_iff,
+    ne_eq, v.ord_eq_zero_iff_adicValuation_eq_one hr']
+  exact not_congr (v.adicValuation_coe_eq_one_iff (hv.ringHom r)).symm
+
+theorem centre_placeOfEquation [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) :
+    (isFinitePlace_placeOfEquation h).centre = XYIdeal W x (C y) := by
+  ext r
+  rcases eq_or_ne r 0 with rfl | hr
+  · simp only [Submodule.zero_mem]
+  rw [(isFinitePlace_placeOfEquation h).mem_centre_iff_ord_ne_zero hr,
+    ord_placeOfEquation_ne_zero_iff h hr]
+
+theorem eq_placeOfEquation_of_le_centre [IsAlgClosed F] [IsDedekindDomain W.CoordinateRing]
+    {v : Place F W.FunctionField} (hv : IsFinitePlace v) {x y : F} (h : W.Equation x y)
+    (hle : XYIdeal W x (C y) ≤ hv.centre) : v = placeOfEquation h := by
+  obtain ⟨x', y', h', hveq⟩ := (isFinitePlace_iff_exists_placeOfEquation v).mp hv
+  subst hveq
+  have hc : hv.centre = XYIdeal W x' (C y') := by
+    rw [Subsingleton.elim hv (isFinitePlace_placeOfEquation h')]
+    exact centre_placeOfEquation h'
+  rw [hc] at hle
+  have heq : XYIdeal W x (C y) = XYIdeal W x' (C y') :=
+    (CoordinateRing.XYIdeal_isMaximal h).eq_of_le (CoordinateRing.XYIdeal_isMaximal h').ne_top
+      hle
+  obtain ⟨rfl, rfl⟩ := CoordinateRing.eq_of_XYIdeal_eq h' heq
+  rfl
+
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine~genericPoint WeierstrassCurve~Affine.genericPoint"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~Place.ord\
+  _algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq \
+  P2MW.S_OVERLONG_e431601d.AlgebraicCurve"
+
+variable {F : Type*} [Field F] (W : Affine F)
+
+variable {W}
+
+private def _root_.WeierstrassCurve.Affine.yGen (W : Affine F) : W.FunctionField :=
+  algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+
+p2m_export "WeierstrassCurve.Affine" "yGen"
+section OrdAtPoint
+
+variable [IsDedekindDomain W.CoordinateRing]
+
+theorem ord_polyToFunctionField_pos_iff {x y : F} (h : W.Equation x y) {p : F[X]}
+    (hp : p ≠ 0) :
+    0 < (placeOfEquation h).ord (polyToFunctionField W p) ↔ p.eval x = 0 := by
+  rw [polyToFunctionField_apply, algebraMap_polynomial_eq_mk_C,
+    ord_placeOfEquation_pos_iff h (fun hcon => polyToFunctionField_ne_zero hp
+      (by rw [polyToFunctionField_apply, algebraMap_polynomial_eq_mk_C, hcon, _root_.map_zero])),
+    mk_mem_XYIdeal_iff h, Polynomial.evalEval_C]
+
+theorem ord_polyToFunctionField_eq_zero_iff {x y : F} (h : W.Equation x y) {p : F[X]}
+    (hp : p ≠ 0) :
+    (placeOfEquation h).ord (polyToFunctionField W p) = 0 ↔ p.eval x ≠ 0 := by
+  have h1 := ord_polyToFunctionField_pos_iff h hp (y := y)
+  have h2 : 0 ≤ (placeOfEquation h).ord (polyToFunctionField W p) := by
+    rw [polyToFunctionField_apply]
+    exact ord_placeOfEquation_nonneg h _
+  constructor
+  · intro h0 hcon
+    have h3 := h1.mpr hcon
+    omega
+  · intro hne
+    rcases lt_or_eq_of_le h2 with hlt | heq
+    · exact absurd (h1.mp hlt) hne
+    · exact heq.symm
+
+end OrdAtPoint
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+end Affine
+end WeierstrassCurve
+end
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_e431601d.Polynomial \
+  IsDedekindDomain \
+  P2MW.S_OVERLONG_e431601d.IsDedekindDomai\
+  n WithZero \
+  P2MW.S_OVERLONG_e431601d.WithZero"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_e431601d.Polynomial.Bivar\
+  iate"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongHom algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong Place.ramificationIndexAlong SeparableAlong Place \
+  Place.ext Place.ord Place.ord_zero HasPrincipalDivisors Pic0 Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos ext coe_algebraMap deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff adicValuation_coe_irreducible ord ord_zero ord_mul ord_inv \
+  ord_coe_irreducible ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum \
+  ofHeightOneSpectrum_toValuationSubring rec ne_top' algebraMap_mem' toValuationSubring mk \
+  mem_of_eval_monic_eq_zero isEquiv_adicValuation_of_valuationSubring_eq \
+  ord_eq_zero_iff_adicValuation_eq_one ofHeightOneSpectrum_injective \
+  ord_ofHeightOneSpectrum_ne_zero_iff"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~ord_algebraMa\
+  p~ord_eq_neg_log_of_valuationSubring_eq \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~Place.ord\
+  _algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq"
+
+variable {K : Type*} [Field K]
+variable {R : Type*} [CommRing R] [IsDedekindDomain R]
+variable {L : Type*} [Field L] [Algebra R L] [IsFractionRing R L]
+variable [Algebra K R] [Algebra K L] [IsScalarTower K R L]
+
+theorem ord_ofHeightOneSpectrum_algebraMap_eq_zero (w : HeightOneSpectrum R) {r : R}
+    (hr0 : r ≠ 0) (hr : r ∉ w.asIdeal) :
+    (ofHeightOneSpectrum (K := K) (F := L) w).ord (algebraMap R L r) = 0 := by
+  have hrL : algebraMap R L r ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective R L)).mpr hr0
+  rw [ord_ofHeightOneSpectrum_eq_neg_log w hrL, w.valuation_of_algebraMap,
+    HeightOneSpectrum.intValuation_eq_one_iff.mpr hr, log_one, _root_.neg_zero]
+
+theorem ord_ofHeightOneSpectrum_algebraMap_eq_one (w : HeightOneSpectrum R) {r : R}
+    (hr : r ∈ w.asIdeal) (hr2 : r ∉ w.asIdeal ^ 2) :
+    (ofHeightOneSpectrum (K := K) (F := L) w).ord (algebraMap R L r) = 1 := by
+  have hr0 : r ≠ 0 := fun h => hr2 (h ▸ Submodule.zero_mem _)
+  have hrL : algebraMap R L r ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective R L)).mpr hr0
+  rw [ord_ofHeightOneSpectrum_eq_neg_log w hrL, w.valuation_of_algebraMap]
+  have h1 : w.intValuation r ≤ exp (-((1 : ℕ) : ℤ)) := by
+    rw [HeightOneSpectrum.intValuation_le_pow_iff_mem]
+    simpa using hr
+  have h2 : ¬ w.intValuation r ≤ exp (-((2 : ℕ) : ℤ)) := by
+    rw [HeightOneSpectrum.intValuation_le_pow_iff_mem]
+    exact hr2
+  rw [w.intValuation_if_neg hr0] at h1 h2 ⊢
+  rw [exp_le_exp] at h1 h2
+  rw [log_exp]
+  omega
+
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongHom algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong Place.ramificationIndexAlong SeparableAlong Place \
+  Place.ext Place.ord Place.ord_zero HasPrincipalDivisors Pic0 Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos ext coe_algebraMap deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff adicValuation_coe_irreducible ord ord_zero ord_mul ord_inv \
+  ord_coe_irreducible ord_zpow ord_unit_smul_zpow exists_unit_mul_zpow ofHeightOneSpectrum \
+  ofHeightOneSpectrum_toValuationSubring rec ne_top' algebraMap_mem' toValuationSubring mk \
+  mem_of_eval_monic_eq_zero isEquiv_adicValuation_of_valuationSubring_eq \
+  ord_eq_zero_iff_adicValuation_eq_one ofHeightOneSpectrum_injective \
+  ord_ofHeightOneSpectrum_ne_zero_iff"
+end Place
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine~genericPoint WeierstrassCurve~Affine.genericPoint"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "smul_basis_eq_zero XYIdeal \
+  quotientXYIdealEquiv XClass_ne_zero smul YClass mk map degree_norm_smul_basis \
+  exists_smul_basis_eq XClass smul_basis_mul_Y YClass_ne_zero isDedekindDomain exists_eq_XYIdeal \
+  XYIdeal_isMaximal XYIdeal_ne_bot"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing"
+
+theorem derivative_polynomial : derivative W.polynomial = W.polynomialY := by
+  rw [WeierstrassCurve.Affine.polynomial, WeierstrassCurve.Affine.polynomialY,
+    derivative_sub, derivative_add, derivative_sq, derivative_X, derivative_C_mul_X,
+    derivative_C]
+  simp only [mul_one, sub_zero, map_ofNat]
+
+theorem evalEval_eq_zero_of_mem_span {x₀ y₀ : F} {z : F[X][Y]}
+    (hz : z ∈ Ideal.span {C (X - C x₀), Y - C (C y₀)}) : z.evalEval x₀ y₀ = 0 :=
+  mem_span_C_X_sub_C_X_sub_C_iff_eval_eval_eq_zero.mp hz
+
+theorem evalEval_derivative_eq_zero_of_mem_span_sq {x₀ y₀ : F} {z : F[X][Y]}
+    (hz : z ∈ Ideal.span {C (X - C x₀), Y - C (C y₀)} ^ 2) :
+    (derivative z).evalEval x₀ y₀ = 0 := by
+  rw [pow_two] at hz
+  refine Submodule.mul_induction_on hz (fun f hf g hg => ?_) (fun a b ha hb => ?_)
+  · have hf0 : f.evalEval x₀ y₀ = 0 := evalEval_eq_zero_of_mem_span hf
+    have hg0 : g.evalEval x₀ y₀ = 0 := evalEval_eq_zero_of_mem_span hg
+    rw [derivative_mul, evalEval_add, evalEval_mul, evalEval_mul, hf0, hg0, mul_zero,
+      zero_mul, add_zero]
+  · rw [derivative_add, evalEval_add, ha, hb, add_zero]
+
+theorem exists_eq_add_mul_polynomial_of_mem_XYIdeal_sq {x₀ y₀ : F} {r : F[X][Y]}
+    (hr : mk W r ∈ XYIdeal W x₀ (C y₀) ^ 2) :
+    ∃ z ∈ Ideal.span {C (X - C x₀), Y - C (C y₀)} ^ 2, ∃ δ : F[X][Y],
+      r = z + δ * W.polynomial := by
+  have hmap : XYIdeal W x₀ (C y₀)
+      = Ideal.map (mk W) (Ideal.span {C (X - C x₀), Y - C (C y₀)}) := by
+    rw [Ideal.map_span, Set.image_pair]
+    rfl
+  rw [hmap, ← Ideal.map_pow] at hr
+  obtain ⟨z, hz, hzr⟩ := (Ideal.mem_map_iff_of_surjective _ AdjoinRoot.mk_surjective).mp hr
+  obtain ⟨δ, hδ⟩ := AdjoinRoot.mk_eq_mk.mp hzr
+  exact ⟨z, hz, -δ, by linear_combination -hδ⟩
+
+theorem X_sub_C_dvd_eval_of_mem_span {x₀ y₀ : F} {z : F[X][Y]}
+    (hz : z ∈ Ideal.span {C (X - C x₀), Y - C (C y₀)}) :
+    (X - C x₀ : F[X]) ∣ z.eval (C y₀) := by
+  refine dvd_iff_isRoot.mpr ?_
+  exact evalEval_eq_zero_of_mem_span hz
+
+theorem X_sub_C_sq_dvd_eval_of_mem_span_sq {x₀ y₀ : F} {z : F[X][Y]}
+    (hz : z ∈ Ideal.span {C (X - C x₀), Y - C (C y₀)} ^ 2) :
+    (X - C x₀ : F[X]) ^ 2 ∣ z.eval (C y₀) := by
+  rw [pow_two] at hz ⊢
+  refine Submodule.mul_induction_on hz (fun f hf g hg => ?_) (fun a b ha hb => ?_)
+  · rw [eval_mul]
+    exact mul_dvd_mul (X_sub_C_dvd_eval_of_mem_span hf) (X_sub_C_dvd_eval_of_mem_span hg)
+  · rw [eval_add]
+    exact dvd_add ha hb
+
+theorem XClass_notMem_XYIdeal_sq {x₀ y₀ : F} (heq : W.Equation x₀ y₀)
+    (hY : W.polynomialY.evalEval x₀ y₀ ≠ 0) :
+    XClass W x₀ ∉ XYIdeal W x₀ (C y₀) ^ 2 := by
+  intro hmem
+  have heq' : W.polynomial.evalEval x₀ y₀ = 0 := heq
+  obtain ⟨z, hz, δ, hδ⟩ :=
+    exists_eq_add_mul_polynomial_of_mem_XYIdeal_sq (r := C (X - C x₀)) hmem
+  have hδP : δ.evalEval x₀ y₀ = 0 := by
+    have h3 := congrArg (fun p => (derivative p).evalEval x₀ y₀) hδ
+    simp only [derivative_C, evalEval_zero, derivative_add, derivative_mul, evalEval_add,
+      evalEval_mul, evalEval_derivative_eq_zero_of_mem_span_sq hz, derivative_polynomial, heq',
+      mul_zero, zero_add] at h3
+    exact (mul_eq_zero.mp h3.symm).resolve_right hY
+  have h4 := congrArg (Polynomial.eval (C y₀ : F[X])) hδ
+  rw [eval_C, eval_add, eval_mul] at h4
+  have hdvd : (X - C x₀ : F[X]) ^ 2
+      ∣ z.eval (C y₀) + δ.eval (C y₀) * W.polynomial.eval (C y₀) := by
+    refine dvd_add (X_sub_C_sq_dvd_eval_of_mem_span_sq hz) ?_
+    rw [pow_two]
+    exact mul_dvd_mul (dvd_iff_isRoot.mpr hδP) (dvd_iff_isRoot.mpr heq')
+  rw [← h4] at hdvd
+  have := Polynomial.natDegree_le_of_dvd hdvd (X_sub_C_ne_zero x₀)
+  rw [natDegree_pow, natDegree_X_sub_C] at this
+  omega
+
+end CoordinateRing
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine.CoordinateRing"
+
+variable [IsDedekindDomain W.CoordinateRing]
+
+theorem ord_placeOfEquation_XClass_self {x₀ y₀ : F} (heq : W.Equation x₀ y₀)
+    (hY : W.polynomialY.evalEval x₀ y₀ ≠ 0) :
+    (placeOfEquation heq).ord
+      (algebraMap W.CoordinateRing W.FunctionField (XClass W x₀)) = 1 :=
+  AlgebraicCurve.Place.ord_ofHeightOneSpectrum_algebraMap_eq_one
+    (heightOneSpectrumOfEquation heq) (Ideal.subset_span (Set.mem_insert _ _))
+    (XClass_notMem_XYIdeal_sq heq hY)
+
+end Affine
+end WeierstrassCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongHom algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong Place.ramificationIndexAlong SeparableAlong Place \
+  Place.ext Place.ord Place.ord_zero HasPrincipalDivisors Pic0 Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+end Affine
+end WeierstrassCurve
+end
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_e431601d.Polynomial \
+  IsDedekindDomain \
+  P2MW.S_OVERLONG_e431601d.IsDedekindDomain"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_e431601d.Polynomial.Bivar\
+  iate"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine~genericPoint WeierstrassCurve~Affine.genericPoint"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~Place.ord\
+  _algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq \
+  P2MW.S_OVERLONG_e431601d.AlgebraicCurve"
+
+universe u
+
+variable {F : Type u} [Field F]
+
+section GenericPoint
+
+variable {W : Affine F}
+
+theorem polyToFunctionField_eq_aeval (p : F[X]) :
+    polyToFunctionField W p = Polynomial.aeval (polyToFunctionField W X) p := by
+  have h1 : (polyToFunctionField W : F[X] →+* W.FunctionField)
+      = algebraMap F[X] W.FunctionField :=
+    (IsScalarTower.algebraMap_eq F[X] W.CoordinateRing W.FunctionField).symm
+  have h2 : (IsScalarTower.toAlgHom F F[X] W.FunctionField : F[X] →ₐ[F] W.FunctionField)
+      = Polynomial.aeval (polyToFunctionField W X) := by
+    refine Polynomial.algHom_ext ?_
+    rw [Polynomial.aeval_X, IsScalarTower.coe_toAlgHom', ← h1]
+  calc polyToFunctionField W p = algebraMap F[X] W.FunctionField p := by rw [h1]
+    _ = (IsScalarTower.toAlgHom F F[X] W.FunctionField : F[X] →ₐ[F] W.FunctionField) p := rfl
+    _ = Polynomial.aeval (polyToFunctionField W X) p := by rw [h2]
+
+theorem polyToFunctionField_X_ne_algebraMap (c : F) :
+    polyToFunctionField W X ≠ algebraMap F W.FunctionField c := by
+  intro hcon
+  refine polyToFunctionField_ne_zero (W := W) (X_sub_C_ne_zero c) ?_
+  rw [map_sub, polyToFunctionField_C, hcon, sub_self]
+
+theorem equation_map_polyToFunctionField_yGen :
+    (W.map (algebraMap F W.FunctionField)).toAffine.Equation
+      (polyToFunctionField W X) (yGen W) := by
+  rw [equation_iff]
+  have hrel := smul_basis_mul_Y (W' := W) 0 1
+  rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at hrel
+  have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) hrel
+  rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆]
+  simp only [map_add, map_mul, map_pow, polyToFunctionField_C] at h2
+  rw [show yGen W = algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+    from rfl]
+  simp only [polyToFunctionField_apply] at h2 ⊢
+  linear_combination h2
+
+end GenericPoint
+end Affine
+end WeierstrassCurve
+end
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_e431601d.Polynomial \
+  IsDedekindDomain \
+  P2MW.S_OVERLONG_e431601d.IsDedekindDomain"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_e431601d.Polynomial.Bivar\
+  iate"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine~genericPoint WeierstrassCurve~Affine.genericPoint"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~Place.ord\
+  _algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq \
+  P2MW.S_OVERLONG_e431601d.AlgebraicCurve"
+
+universe u
+
+variable {F : Type u} [Field F]
+
+namespace AbstractSeam
+
+variable {W : Affine F} {V : Affine F}
+variable (ι : V.FunctionField →ₐ[F] W.FunctionField)
+  (hι : ι.toRingHom.IsIntegral)
+  {ξ η : W.FunctionField}
+  (hX : ι (polyToFunctionField V (X : F[X])) = ξ)
+  (hY : ι (yGen V) = η)
+
+include hX in
+theorem map_XClass (c : F) :
+    ι (algebraMap V.CoordinateRing V.FunctionField (XClass V c))
+      = ξ - algebraMap F W.FunctionField c := by
+  have h1 : algebraMap V.CoordinateRing V.FunctionField (XClass V c)
+      = polyToFunctionField V (X : F[X]) - algebraMap F V.FunctionField c := by
+    rw [← polyToFunctionField_C, ← map_sub]
+    rfl
+  rw [h1, map_sub, hX, AlgHom.commutes]
+
+include hY in
+theorem map_YClass (c : F) :
+    ι (algebraMap V.CoordinateRing V.FunctionField (YClass V (C c)))
+      = η - algebraMap F W.FunctionField c := by
+  have h1 : algebraMap V.CoordinateRing V.FunctionField (YClass V (C c))
+      = yGen V - algebraMap F V.FunctionField c := by
+    rw [YClass, map_sub, map_sub, yGen]
+    congr 1
+  rw [h1, map_sub, hY, AlgHom.commutes]
+
+section Cases
+
+variable [IsDedekindDomain V.CoordinateRing]
+
+include hX in
+theorem restrictAlong_eq_infinitePlace [V.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred V]
+    (v : AlgebraicCurve.Place F W.FunctionField)
+    (hpole : ξ ∉ v.toValuationSubring) :
+    v.restrictAlong ι hι = InfinitePlace.place := by
+  refine InfinitePlace.eq_of_not_isFinitePlace _ ?_
+  intro hfin
+  refine hpole ?_
+  rw [← hX]
+  exact hfin (algebraMap F[X] V.CoordinateRing (X : F[X]))
+
+end Cases
+end AbstractSeam
+end Affine
+end WeierstrassCurve
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_e431601d.Polynomial \
+  Polynomial.Bivariate.Polynomial \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~Place.ord\
+  _algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq \
+  P2MW.S_OVERLONG_e431601d.AlgebraicCurve \
+  WeierstrassCurve.Affine~genericPoint \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+end WeierstrassCurve
+end
+
+section
+
+
+section
+
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_e431601d.Polynomial \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~Place.ord\
+  _algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq \
+  P2MW.S_OVERLONG_e431601d.AlgebraicCurve \
+  IsDedekindDomain \
+  P2MW.S_OVERLONG_e431601d.IsDedekindDomain"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_e431601d.Polynomial.Bivar\
+  iate WeierstrassCurve \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine~genericPoint WeierstrassCurve~Affine.genericPoint"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine.CoordinateRing AdjoinRoot \
+  P2MW.S_OVERLONG_e431601d.AdjoinRoot"
+
+variable {F : Type*} [Field F] {W : Affine F} [IsDedekindDomain W.CoordinateRing]
+
+theorem ord_placeOfEquation_eq_zero_of_evalEval_ne_zero {x₀ y₀ : F} (heq : W.Equation x₀ y₀)
+    {q : F[X][Y]} (hq : q.evalEval x₀ y₀ ≠ 0) :
+    (placeOfEquation heq).ord
+      (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W q)) = 0 := by
+  have hnotmem : CoordinateRing.mk W q ∉ XYIdeal W x₀ (C y₀) := fun h =>
+    hq ((mk_mem_XYIdeal_iff_evalEval_eq_zero heq q).mp h)
+  have hne : CoordinateRing.mk W q ≠ 0 := fun h => hnotmem (h ▸ Submodule.zero_mem _)
+  exact AlgebraicCurve.Place.ord_ofHeightOneSpectrum_algebraMap_eq_zero
+    (heightOneSpectrumOfEquation heq) hne hnotmem
+
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_e431601d.Polynomial \
+  WeierstrassCurve.Affine~genericPoint \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine WeierstrassCurve.Affine.Point \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine.Point"
+
+p2m_open_scoped "WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine"
+
+section
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine~genericPoint WeierstrassCurve~Affine.genericPoint"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~P\
+  lace.ord_algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq \
+  P2MW.S_OVERLONG_e431601d.AlgebraicCurve"
+
+section OrdPins
+
+variable (v : Place F W.FunctionField)
+
+theorem ord_X_sub_algebraMap_of_not_isFinitePlace (hv : ¬ IsFinitePlace v) (c : F) :
+    v.ord (polyToFunctionField W X - algebraMap F W.FunctionField c) = -2 := by
+  have key : polyToFunctionField W X - algebraMap F W.FunctionField c
+      = polyToFunctionField W (X - C c) := by
+    rw [map_sub, polyToFunctionField_C]
+  rw [key, v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C
+    (ord_X_neg_of_not_isFinitePlace v hv) (X_sub_C_ne_zero c), natDegree_X_sub_C,
+    ord_X_eq_neg_two_of_not_isFinitePlace v hv]
+  norm_num
+
+theorem X_sub_algebraMap_ne_zero (c : F) :
+    (polyToFunctionField W X - algebraMap F W.FunctionField c : W.FunctionField) ≠ 0 :=
+  sub_ne_zero.mpr (polyToFunctionField_X_ne_algebraMap c)
+
+end OrdPins
+
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+end WeierstrassCurve
+end
+end
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_e431601d.Polynomial \
+  WeierstrassCurve.Affine~genericPoint \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine WeierstrassCurve.Affine.Point \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine.Point"
+
+p2m_open_scoped "WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine Polynomial.Bivariate \
+  P2MW.S_OVERLONG_e431601d.Polynomial.Bivar\
+  iate"
+
+section
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine~genericPoint WeierstrassCurve~Affine.genericPoint"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~Place.ord\
+  _algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq \
+  P2MW.S_OVERLONG_e431601d.AlgebraicCurve"
+
+universe u
+
+variable {F : Type u} [Field F]
+
+section TranslationCoords
+
+variable (W : Affine F) (a b : F)
+
+local notation "ι" => algebraMap F W.FunctionField
+
+private def _root_.WeierstrassCurve.Affine.addXFun : W.FunctionField :=
+  (W.map ι).addX (polyToFunctionField W X) (ι a)
+    ((W.map ι).slope (polyToFunctionField W X) (ι a) (yGen W) (ι b))
+
+p2m_export "WeierstrassCurve.Affine" "addXFun"
+private def _root_.WeierstrassCurve.Affine.addYFun : W.FunctionField :=
+  (W.map ι).addY (polyToFunctionField W X) (ι a) (yGen W)
+    ((W.map ι).slope (polyToFunctionField W X) (ι a) (yGen W) (ι b))
+
+p2m_export "WeierstrassCurve.Affine" "addYFun"
+variable {a b} in
+theorem equation_map_addFun (hA : W.Equation a b) :
+    (W.map ι).Equation (W.addXFun a b) (W.addYFun a b) :=
+  Affine.equation_add (W := (W.map ι).toAffine)
+    equation_map_polyToFunctionField_yGen (hA.map ι)
+    (fun h => polyToFunctionField_X_ne_algebraMap a h.1)
+
+variable {a b} in
+theorem eval₂_polynomial_addFun (hA : W.Equation a b) :
+    W.polynomial.eval₂
+      (Polynomial.aeval (R := F) (W.addXFun a b)).toRingHom (W.addYFun a b) = 0 := by
+  have heq := equation_map_addFun W hA
+  rw [equation_iff'] at heq
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆] at heq
+  simp only [WeierstrassCurve.Affine.polynomial, eval₂_add, eval₂_sub, eval₂_mul, eval₂_pow,
+    eval₂_X, eval₂_C, AlgHom.toRingHom_eq_coe, RingHom.coe_coe, map_add, map_mul, map_pow,
+    Polynomial.aeval_C, Polynomial.aeval_X]
+  linear_combination heq
+
+end TranslationCoords
+
+section GenericPointGroup
+
+variable {W : Affine F}
+
+local notation "ι" => algebraMap F W.FunctionField
+
+theorem map_functionField_Δ_ne_zero (hΔ : W.Δ ≠ 0) : (W.map ι).Δ ≠ 0 := by
+  rw [map_Δ]
+  exact fun h => hΔ ((algebraMap F W.FunctionField).injective (by simpa using h))
+
+theorem nonsingular_map_polyToFunctionField_yGen (hΔ : W.Δ ≠ 0) :
+    (W.map ι).Nonsingular (polyToFunctionField W X) (yGen W) :=
+  (Affine.equation_iff_nonsingular_of_Δ_ne_zero (map_functionField_Δ_ne_zero hΔ)).mp
+    equation_map_polyToFunctionField_yGen
+
+def genericPoint (hΔ : W.Δ ≠ 0) : (W.map ι).toAffine.Point :=
+  Affine.Point.some (polyToFunctionField W X) (yGen W)
+    (nonsingular_map_polyToFunctionField_yGen hΔ)
+
+theorem nonsingular_map_algebraMap (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b) :
+    (W.map ι).Nonsingular (ι a) (ι b) :=
+  (Affine.equation_iff_nonsingular_of_Δ_ne_zero (map_functionField_Δ_ne_zero hΔ)).mp (hA.map ι)
+
+def mapPoint (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b) : (W.map ι).toAffine.Point :=
+  Affine.Point.some (ι a) (ι b) (nonsingular_map_algebraMap hΔ hA)
+
+theorem nonsingular_map_addFun (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b) :
+    (W.map ι).Nonsingular (W.addXFun a b) (W.addYFun a b) :=
+  (Affine.equation_iff_nonsingular_of_Δ_ne_zero (map_functionField_Δ_ne_zero hΔ)).mp
+    (equation_map_addFun W hA)
+
+theorem genericPoint_add_map (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b) :
+    genericPoint hΔ + mapPoint hΔ hA
+      = Affine.Point.some (W.addXFun a b) (W.addYFun a b) (nonsingular_map_addFun hΔ hA) :=
+  Affine.Point.add_of_X_ne (polyToFunctionField_X_ne_algebraMap a)
+
+theorem equation_neg_mapPoint {a b : F} (hA : W.Equation a b) : W.Equation a (W.negY a b) :=
+  (Affine.equation_neg a b).mpr hA
+
+theorem addFun_ne_mapPoint (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b) :
+    ¬ (W.addXFun a b = ι a ∧ W.addYFun a b = ι b) := by
+  intro ⟨hX, hY⟩
+  have heq : Affine.Point.some _ _ (nonsingular_map_addFun hΔ hA) = mapPoint hΔ hA := by
+    change Affine.Point.some _ _ _ = Affine.Point.some _ _ _
+    simp only [Affine.Point.some.injEq]; exact ⟨hX, hY⟩
+  have h0 : genericPoint hΔ + mapPoint hΔ hA = 0 + mapPoint hΔ hA := by
+    rw [zero_add]; exact (genericPoint_add_map hΔ hA).trans heq
+  exact Affine.Point.some_ne_zero _ (add_right_cancel h0)
+
+theorem neg_mapPoint_eq (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b) :
+    -(mapPoint hΔ hA) = Affine.Point.some (ι a) (ι (W.negY a b))
+      (nonsingular_map_algebraMap hΔ (equation_neg_mapPoint hA)) := by
+  change Affine.Point.some (ι a) ((W.map ι).negY (ι a) (ι b)) _ = _
+  congr 1
+  exact map_negY ι a b
+
+theorem addFun_neg_mapPoint_hxy (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b) :
+    ¬ (W.addXFun a b = ι a
+        ∧ W.addYFun a b = (W.map ι).negY (ι a) (ι (W.negY a b))) := by
+  rw [map_negY ι a (W.negY a b), Affine.negY_negY]
+  exact addFun_ne_mapPoint hΔ hA
+
+theorem addFun_neg_cancel (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b) :
+    (W.map ι).addX (W.addXFun a b) (ι a)
+        ((W.map ι).slope (W.addXFun a b) (ι a) (W.addYFun a b) (ι (W.negY a b)))
+      = polyToFunctionField W X
+    ∧ (W.map ι).addY (W.addXFun a b) (ι a) (W.addYFun a b)
+        ((W.map ι).slope (W.addXFun a b) (ι a) (W.addYFun a b) (ι (W.negY a b)))
+      = yGen W := by
+  have hns₂ := Affine.nonsingular_add (nonsingular_map_addFun hΔ hA)
+      (nonsingular_map_algebraMap hΔ (equation_neg_mapPoint hA))
+      (addFun_neg_mapPoint_hxy hΔ hA)
+  have hsum : (Affine.Point.some _ _ (nonsingular_map_addFun hΔ hA))
+        + (-(mapPoint hΔ hA))
+      = Affine.Point.some _ _ hns₂ := by
+    rw [neg_mapPoint_eq hΔ hA]
+    exact Affine.Point.add_some (addFun_neg_mapPoint_hxy hΔ hA)
+  have hcancel : Affine.Point.some _ _ hns₂ = genericPoint hΔ := by
+    rw [← hsum, ← genericPoint_add_map hΔ hA, add_neg_cancel_right]
+  exact Affine.Point.some.inj hcancel
+
+theorem addFun_neg_cancel_X (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b) :
+    (W.map ι).addX (W.addXFun a b) (ι a)
+        ((W.map ι).slope (W.addXFun a b) (ι a) (W.addYFun a b) (ι (W.negY a b)))
+      = polyToFunctionField W X :=
+  (addFun_neg_cancel hΔ hA).1
+
+theorem addFun_neg_cancel_Y (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b) :
+    (W.map ι).addY (W.addXFun a b) (ι a) (W.addYFun a b)
+        ((W.map ι).slope (W.addXFun a b) (ι a) (W.addYFun a b) (ι (W.negY a b)))
+      = yGen W :=
+  (addFun_neg_cancel hΔ hA).2
+
+end GenericPointGroup
+
+section CoordHom
+
+variable {W : Affine F} {a b : F} (hA : W.Equation a b)
+
+def translationCoordHom : W.CoordinateRing →ₐ[F] W.FunctionField where
+  __ := AdjoinRoot.lift
+    (Polynomial.aeval (R := F) (W.addXFun a b)).toRingHom
+    (W.addYFun a b) (eval₂_polynomial_addFun W hA)
+  commutes' c := by
+    change AdjoinRoot.lift _ _ (eval₂_polynomial_addFun W hA) (algebraMap F _ c)
+      = algebraMap F W.FunctionField c
+    rw [CoordinateRing.algebraMap_eq_mk_C_C, AdjoinRoot.lift_mk, eval₂_C]
+    exact Polynomial.aeval_C _ c
+
+theorem translationCoordHom_mk (g : F[X][Y]) :
+    translationCoordHom hA (CoordinateRing.mk W g)
+      = g.eval₂ (Polynomial.aeval (R := F) (W.addXFun a b)).toRingHom (W.addYFun a b) :=
+  AdjoinRoot.lift_mk (eval₂_polynomial_addFun W hA) g
+
+theorem translationCoordHom_comp_algebraMap :
+    (translationCoordHom hA).toRingHom.comp (algebraMap F[X] W.CoordinateRing)
+      = (Polynomial.aeval (R := F) (W.addXFun a b)).toRingHom := by
+  refine RingHom.ext fun p => ?_
+  change translationCoordHom hA (algebraMap F[X] _ p) = _
+  rw [algebraMap_polynomial_eq_mk_C, translationCoordHom_mk, eval₂_C]
+
+@[scoped simp] theorem translationCoordHom_XClass :
+    translationCoordHom hA (algebraMap F[X] W.CoordinateRing X) = W.addXFun a b := by
+  rw [algebraMap_polynomial_eq_mk_C, translationCoordHom_mk, eval₂_C]
+  exact Polynomial.aeval_X _
+
+@[scoped simp] theorem translationCoordHom_YClass :
+    translationCoordHom hA (CoordinateRing.mk W Y) = W.addYFun a b := by
+  rw [translationCoordHom_mk]
+  exact eval₂_X _ _
+
+end CoordHom
+
+section AdjoinSurjective
+
+variable {W : Affine F} (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b)
+
+local notation "ι" => algebraMap F W.FunctionField
+
+theorem transcendental_polyToFunctionField_X :
+    Transcendental F (polyToFunctionField W X) := by
+  rw [transcendental_iff]
+  intro p hp
+  rw [← polyToFunctionField_eq_aeval] at hp
+  exact polyToFunctionField_injective (by simpa using hp)
+
+private theorem slope_mem_intermediateField {K : IntermediateField F W.FunctionField}
+    {x₁ x₂ y₁ y₂ : W.FunctionField}
+    (hx₁ : x₁ ∈ K) (hx₂ : x₂ ∈ K) (hy₁ : y₁ ∈ K) (hy₂ : y₂ ∈ K) :
+    (W.map ι).slope x₁ x₂ y₁ y₂ ∈ K := by
+  have hF : ∀ c : F, ι c ∈ K := fun c => (algebraMap F K c).2
+  have hN : ∀ n : ℕ, (n : W.FunctionField) ∈ K := fun n => natCast_mem K n
+  unfold Affine.slope
+  split
+  · split
+    · exact zero_mem K
+    · simp only [map_a₁, map_a₂, map_a₄]
+      refine div_mem (sub_mem (add_mem (add_mem (mul_mem (hN 3) (pow_mem hx₁ 2))
+        (mul_mem (mul_mem (hN 2) (hF _)) hx₁)) (hF _)) (mul_mem (hF _) hy₁)) (sub_mem hy₁ ?_)
+      unfold Affine.negY
+      simp only [map_a₁, map_a₃]
+      exact sub_mem (sub_mem (neg_mem hy₁) (mul_mem (hF _) hx₁)) (hF _)
+  · exact div_mem (sub_mem hy₁ hy₂) (sub_mem hx₁ hx₂)
+
+include hΔ hA in
+theorem polyToFunctionField_X_mem_adjoin_addFun :
+    polyToFunctionField W X
+      ∈ IntermediateField.adjoin F ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField) := by
+  set K := IntermediateField.adjoin F ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField)
+  rw [← addFun_neg_cancel_X hΔ hA]
+  have hX' : W.addXFun a b ∈ K := IntermediateField.subset_adjoin F _ (Or.inl rfl)
+  have hY' : W.addYFun a b ∈ K := IntermediateField.subset_adjoin F _ (Or.inr rfl)
+  have hF : ∀ c : F, ι c ∈ K := fun c => (algebraMap F K c).2
+  have hslope := slope_mem_intermediateField (W := W) hX' (hF a) hY' (hF (W.negY a b))
+  change (W.map ι).addX (W.addXFun a b) (ι a) _ ∈ K
+  rw [Affine.addX]
+  simp only [map_a₁, map_a₂]
+  exact sub_mem (sub_mem (sub_mem (add_mem (pow_mem hslope 2) (mul_mem (hF _) hslope))
+    (hF _)) hX') (hF _)
+
+include hΔ hA in
+theorem yGen_mem_adjoin_addFun :
+    yGen W
+      ∈ IntermediateField.adjoin F ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField) := by
+  set K := IntermediateField.adjoin F ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField)
+  rw [← addFun_neg_cancel_Y hΔ hA]
+  have hX' : W.addXFun a b ∈ K := IntermediateField.subset_adjoin F _ (Or.inl rfl)
+  have hY' : W.addYFun a b ∈ K := IntermediateField.subset_adjoin F _ (Or.inr rfl)
+  have hF : ∀ c : F, ι c ∈ K := fun c => (algebraMap F K c).2
+  have hslope := slope_mem_intermediateField (W := W) hX' (hF a) hY' (hF (W.negY a b))
+  have haddX : (W.map ι).addX (W.addXFun a b) (ι a)
+      ((W.map ι).slope (W.addXFun a b) (ι a) (W.addYFun a b) (ι (W.negY a b))) ∈ K := by
+    rw [Affine.addX]
+    simp only [map_a₁, map_a₂]
+    exact sub_mem (sub_mem (sub_mem (add_mem (pow_mem hslope 2) (mul_mem (hF _) hslope))
+      (hF _)) hX') (hF _)
+  change (W.map ι).addY (W.addXFun a b) (ι a) (W.addYFun a b) _ ∈ K
+  rw [Affine.addY, Affine.negY, Affine.negAddY]
+  simp only [map_a₁, map_a₃]
+  exact sub_mem (sub_mem (neg_mem (add_mem (mul_mem hslope (sub_mem haddX hX')) hY'))
+    (mul_mem (hF _) haddX)) (hF _)
+
+include hΔ hA in
+theorem adjoin_addFun_eq_top :
+    IntermediateField.adjoin F ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField) = ⊤ := by
+  rw [eq_top_iff]
+  intro z _
+  obtain ⟨r, s, _, hrs⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  set K := IntermediateField.adjoin F ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField)
+  have hX : polyToFunctionField W X ∈ K := polyToFunctionField_X_mem_adjoin_addFun hΔ hA
+  have hY : yGen W ∈ K := yGen_mem_adjoin_addFun hΔ hA
+  have hpoly : ∀ p : F[X], polyToFunctionField W p ∈ K := by
+    intro p
+    induction p using Polynomial.induction_on' with
+    | add g h hg hh => rw [map_add]; exact add_mem hg hh
+    | monomial n c =>
+        rw [← C_mul_X_pow_eq_monomial, map_mul, map_pow, polyToFunctionField_C]
+        exact mul_mem (algebraMap F K c).2 (pow_mem hX n)
+  have hcr : ∀ r : W.CoordinateRing,
+      algebraMap W.CoordinateRing W.FunctionField r ∈ K := by
+    intro r
+    obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq (W' := W) r
+    rw [algebraMap_smul_basis]
+    exact add_mem (hpoly p) (mul_mem (hpoly q) hY)
+  rw [← hrs]
+  exact div_mem (hcr r) (hcr s)
+
+end AdjoinSurjective
+
+section TranslationHom
+
+variable {W : Affine F} {a b : F} (hA : W.Equation a b)
+
+def AddXFunTranscendental (W : Affine F) (a b : F) : Prop :=
+  Transcendental F (W.addXFun a b)
+
+variable (htr : AddXFunTranscendental W a b)
+
+include htr in
+theorem translationCoordHom_injective : Function.Injective (translationCoordHom hA) := by
+  have hker : RingHom.ker (translationCoordHom hA).toRingHom = ⊥ := by
+    have : Module.Finite F[X] W.CoordinateRing :=
+      Module.Finite.of_basis (CoordinateRing.basis W)
+    refine Ideal.eq_bot_of_under_eq_bot (R := F[X]) ?_
+    rw [Ideal.under_def, RingHom.comap_ker, translationCoordHom_comp_algebraMap,
+      ← RingHom.injective_iff_ker_eq_bot]
+    exact (injective_iff_map_eq_zero _).mpr fun p hp => transcendental_iff.mp htr p hp
+  exact (RingHom.injective_iff_ker_eq_bot (translationCoordHom hA).toRingHom).mpr hker
+
+def translationHom : W.FunctionField →ₐ[F] W.FunctionField :=
+  IsFractionRing.liftAlgHom (translationCoordHom_injective hA htr)
+
+theorem translationHom_algebraMap (r : W.CoordinateRing) :
+    translationHom hA htr (algebraMap W.CoordinateRing W.FunctionField r)
+      = translationCoordHom hA r :=
+  IsFractionRing.lift_algebraMap (translationCoordHom_injective hA htr) r
+
+@[scoped simp] theorem translationHom_polyToFunctionField_X :
+    translationHom hA htr (polyToFunctionField W X) = W.addXFun a b := by
+  rw [polyToFunctionField_apply, translationHom_algebraMap, ← translationCoordHom_XClass hA]
+
+@[scoped simp] theorem translationHom_yGen :
+    translationHom hA htr (yGen W) = W.addYFun a b := by
+  change translationHom hA htr (algebraMap _ _ (CoordinateRing.mk W Y)) = _
+  rw [translationHom_algebraMap, translationCoordHom_YClass]
+
+variable (hΔ : W.Δ ≠ 0)
+
+include hΔ in
+theorem translationHom_surjective : Function.Surjective (translationHom hA htr) := by
+  intro z
+  have hz : z ∈ IntermediateField.adjoin F
+      ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField) := by
+    rw [adjoin_addFun_eq_top hΔ hA]; trivial
+  have hle : IntermediateField.adjoin F
+      ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField)
+      ≤ (translationHom hA htr).fieldRange := by
+    refine IntermediateField.adjoin_le_iff.mpr ?_
+    rintro _ (rfl | rfl)
+    · exact ⟨polyToFunctionField W X, translationHom_polyToFunctionField_X hA htr⟩
+    · exact ⟨yGen W, translationHom_yGen hA htr⟩
+  exact hle hz
+
+def translationAlgEquiv : W.FunctionField ≃ₐ[F] W.FunctionField :=
+  AlgEquiv.ofBijective (translationHom hA htr)
+    ⟨(translationHom hA htr).injective, translationHom_surjective hA htr hΔ⟩
+
+end TranslationHom
+end Affine
+end WeierstrassCurve
+end
+end
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_e431601d.Polynomial \
+  WeierstrassCurve.Affine~genericPoint \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine WeierstrassCurve.Affine.Point \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine.Point"
+
+p2m_open_scoped "WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine Polynomial.Bivariate \
+  P2MW.S_OVERLONG_e431601d.Polynomial.Bivar\
+  iate Pointwise \
+  P2MW.S_OVERLONG_e431601d.Pointwise"
+
+section
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine~genericPoint WeierstrassCurve~Affine.genericPoint"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~Place.ord\
+  _algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq \
+  P2MW.S_OVERLONG_e431601d.AlgebraicCurve"
+
+universe u
+
+variable {F : Type u} [Field F]
+
+section Transcendence
+
+variable {W : Affine F} {a b : F}
+
+theorem isIntegral_addYFun_adjoin_addXFun (hA : W.Equation a b) :
+    _root_.IsIntegral (Algebra.adjoin F ({W.addXFun a b} : Set W.FunctionField)) (W.addYFun a b)
+      := by
+  set R := Algebra.adjoin F ({W.addXFun a b} : Set W.FunctionField)
+  have hmem : ∀ p : F[X], (Polynomial.aeval (R := F) (W.addXFun a b)).toRingHom p ∈ R := by
+    intro p
+    change Polynomial.aeval (R := F) (W.addXFun a b) p ∈ R
+    rw [show R = Algebra.adjoin F ({W.addXFun a b} : Set W.FunctionField) from rfl,
+      Algebra.adjoin_singleton_eq_range_aeval]
+    exact ⟨p, rfl⟩
+  let φ : F[X] →+* R :=
+    (Polynomial.aeval (R := F) (W.addXFun a b)).toRingHom.codRestrict R.toSubring hmem
+  refine ⟨W.polynomial.map φ, monic_polynomial.map φ, ?_⟩
+  change Polynomial.eval₂ (algebraMap R W.FunctionField) (W.addYFun a b) (W.polynomial.map φ) = 0
+  rw [Polynomial.eval₂_map]
+  exact eval₂_polynomial_addFun W hA
+
+theorem addXFunTranscendental (hΔ : W.Δ ≠ 0) (hA : W.Equation a b) :
+    AddXFunTranscendental W a b := by
+  intro hX'alg
+  have hX'int : _root_.IsIntegral F (W.addXFun a b) := isAlgebraic_iff_isIntegral.mp hX'alg
+  have hRint : Algebra.IsIntegral F
+      (Algebra.adjoin F ({W.addXFun a b} : Set W.FunctionField)) :=
+    Algebra.IsIntegral.adjoin (fun x hx => by
+      obtain rfl := Set.mem_singleton_iff.mp hx; exact hX'int)
+  have hY'int : _root_.IsIntegral F (W.addYFun a b) :=
+    isIntegral_trans (W.addYFun a b) (isIntegral_addYFun_adjoin_addXFun hA)
+  have hKalg : Algebra.IsAlgebraic F
+      (IntermediateField.adjoin F ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField)) :=
+    IntermediateField.isAlgebraic_adjoin (fun x hx => by
+      rcases hx with rfl | rfl
+      · exact hX'int
+      · exact hY'int)
+  have hXmem : polyToFunctionField W X
+      ∈ IntermediateField.adjoin F ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField) :=
+    polyToFunctionField_X_mem_adjoin_addFun hΔ hA
+  have hXalg : IsAlgebraic F (polyToFunctionField W X) :=
+    IntermediateField.isAlgebraic_iff.mp
+      (Algebra.IsAlgebraic.isAlgebraic (⟨polyToFunctionField W X, hXmem⟩ :
+        IntermediateField.adjoin F ({W.addXFun a b, W.addYFun a b} : Set W.FunctionField)))
+  exact transcendental_polyToFunctionField_X hXalg
+
+end Transcendence
+
+section UnconditionalAut
+
+variable {W : Affine F} (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b)
+
+def translationAlgEquivOf : W.FunctionField ≃ₐ[F] W.FunctionField :=
+  translationAlgEquiv hA (addXFunTranscendental hΔ hA) hΔ
+
+@[scoped simp] theorem translationAlgEquivOf_polyToFunctionField_X :
+    translationAlgEquivOf hΔ hA (polyToFunctionField W X) = W.addXFun a b :=
+  translationHom_polyToFunctionField_X hA (addXFunTranscendental hΔ hA)
+
+@[scoped simp] theorem translationAlgEquivOf_yGen :
+    translationAlgEquivOf hΔ hA (yGen W) = W.addYFun a b :=
+  translationHom_yGen hA (addXFunTranscendental hΔ hA)
+
+end UnconditionalAut
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+end WeierstrassCurve
+end
+end
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_e431601d.Polynomial"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_e431601d.Polynomial.Bivar\
+  iate nonZeroDivisors"
+
+universe u
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine~genericPoint WeierstrassCurve~Affine.genericPoint"
+
+variable {F : Type u} [Field F] [DecidableEq F] {W : Affine F}
+
+section GenericPoint
+
+variable (W)
+
+variable {W} [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+omit [DecidableEq F] [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+private theorem _root_.WeierstrassCurve.Affine.kwWdp_Δ_ne_zero_of_isElliptic :
+    W.Δ ≠ 0 := W.coe_Δ' ▸ W.Δ'.ne_zero
+
+p2m_export "WeierstrassCurve.Affine" "kwWdp_Δ_ne_zero_of_isElliptic"
+end GenericPoint
+
+
+section Translate
+
+variable [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+namespace Point
+p2m_export "WeierstrassCurve.Affine.Point" "add baseChange some some.injEq neg_zero some.inj \
+  map_zero add_some map some_ne_zero rec add_of_X_ne zero neg_some add_self_of_Y_ne mk"
+end Point
+p2m_open_scoped "WeierstrassCurve.Affine.Point" in
+def Point.translateFF : W.Point → (W.FunctionField ≃ₐ[F] W.FunctionField)
+  | 0 => AlgEquiv.refl
+  | .some _ _ h => translationAlgEquivOf kwWdp_Δ_ne_zero_of_isElliptic h.1
+
+p2m_open_scoped "WeierstrassCurve.Affine.Point" in
+omit [DecidableEq F] [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem Point.translateFF_zero : Point.translateFF (W := W) 0 = AlgEquiv.refl := rfl
+
+end Translate
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_e431601d.Polynomial \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~Place.ord\
+  _algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq \
+  P2MW.S_OVERLONG_e431601d.AlgebraicCurve \
+  WeierstrassCurve~Affine.genericPoint \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurv\
+  e WeierstrassCurve.Affine~genericPoint \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine WeierstrassCurve.Affine.Point \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine.Point WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_e431601d.WeierstrassCurve\
+  .Affine.CoordinateRing"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_e431601d.Polynomial.Bivar\
+  iate"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne Affine.equation_neg a₃ a₁ \
+  map Affine.equation_iff_nonsingular_of_Δ_ne_zero Affine.slope Affine.CoordinateRing coe_Δ' mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ Affine.Point.some Affine.Point.some.injEq \
+  Affine.Point.some.inj Affine.negAddY Affine.negY_negY Affine.nonsingular_add IsIntegral toAffine \
+  Affine.slope_of_Y_ne Affine.Point Affine.addX Affine.Point.add_some map_Δ map_a₆ map_a₁ map_a₄ \
+  Affine.Point.some_ne_zero Δ Affine.addY Affine.Y_eq_of_X_eq Affine.Point.add_of_X_ne \
+  Affine.polynomialY Affine.equation_iff rec Affine.polynomial map_a₂ baseChange Δ' map_a₃ \
+  Affine.GenusOnePlaceGate Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY evalEval_polynomial equation_iff' \
+  slope_of_X_ne equation_neg CoordinateRing.XYIdeal CoordinateRing.XClass_ne_zero \
+  equation_iff_nonsingular_of_Δ_ne_zero slope CoordinateRing map evalEval_polynomialX baseChange \
+  equation_add Point.some Point.some.injEq Nonsingular Point.some.inj negAddY polynomialX \
+  negY_negY FunctionField nonsingular_add slope_of_Y_ne Point CoordinateRing.mk \
+  evalEval_polynomialY addX Point.add_some nonsingular_neg monic_polynomial Point.some_ne_zero \
+  map_negY CoordinateRing.basis addY Y_eq_of_X_eq Point.add_of_X_ne polynomialY equation_iff \
+  polynomial Point.zero Point.neg_some Point.add_self_of_Y_ne CoordinateRing.YClass_ne_zero \
+  IsogenyEndDatum IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint \
+  deg_eq_one deg_placeOfPoint pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.IsCentred \
+  placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal CoordinateRing.XYIdeal_ne_bot \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine~genericPoint WeierstrassCurve~Affine.genericPoint"
+
+universe u
+
+section GenericW
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+local notation "ι" => algebraMap F W.FunctionField
+
+omit [DecidableEq F] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_ord_yGen_of_not_isFinitePlace_charFree (v : Place F W.FunctionField)
+    (hv : ¬ IsFinitePlace v) : v.ord W.yGen = -3 :=
+  ord_Y_eq_neg_three_of_not_isFinitePlace v hv
+
+variable (a b : F)
+
+def kwTISDα_charFree : F := W.a₄ - W.a₁ * b + 3 * a ^ 2 + 2 * W.a₂ * a
+
+def kwTISDβ_charFree : F := 2 * b + W.a₁ * a + W.a₃
+
+def kwTISDγ_charFree : F := W.a₆ + b ^ 2 + W.a₁ * a * b - 2 * a ^ 3 - W.a₂ * a ^ 2
+
+omit [DecidableEq F] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_addXFun_sub_mul_sq_num_charFree :
+    (W.addXFun a b - ι a) * (W.polyToFunctionField X - ι a) ^ 2 =
+      ι (kwTISDα_charFree W a b) * W.polyToFunctionField X
+        - ι (kwTISDβ_charFree W a b) * W.yGen + ι (kwTISDγ_charFree W a b) := by
+  have hxne : W.polyToFunctionField X ≠ ι a := polyToFunctionField_X_ne_algebraMap a
+  have hd : W.polyToFunctionField X - ι a ≠ 0 := sub_ne_zero.mpr hxne
+  have hEq := equation_map_polyToFunctionField_yGen (W := W)
+  rw [Affine.equation_iff] at hEq
+  simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+    WeierstrassCurve.map_a₄, WeierstrassCurve.map_a₆] at hEq
+  change ((W.map ι).addX (W.polyToFunctionField X) (ι a)
+      ((W.map ι).slope (W.polyToFunctionField X) (ι a) W.yGen (ι b)) - ι a)
+        * (W.polyToFunctionField X - ι a) ^ 2 = _
+  rw [slope_of_X_ne hxne, addX]
+  simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, kwTISDα_charFree, kwTISDβ_charFree,
+    kwTISDγ_charFree, map_add, map_sub, map_mul, map_pow, map_ofNat]
+  field_simp
+  linear_combination hEq
+
+def kwTISDδ2_charFree : F :=
+  3 * a * kwTISDβ_charFree W a b + W.a₂ * kwTISDβ_charFree W a b
+    - W.a₁ * kwTISDα_charFree W a b
+
+def kwTISDδ1_charFree : F :=
+  W.a₄ * kwTISDβ_charFree W a b + kwTISDα_charFree W a b * b
+    + W.a₁ * a * kwTISDα_charFree W a b - W.a₁ * kwTISDγ_charFree W a b
+    - 3 * a ^ 2 * kwTISDβ_charFree W a b
+
+def kwTISDδY_charFree : F :=
+  -kwTISDγ_charFree W a b - kwTISDβ_charFree W a b * b
+    - W.a₁ * a * kwTISDβ_charFree W a b - W.a₃ * kwTISDβ_charFree W a b
+
+def kwTISDδ0_charFree : F :=
+  a ^ 3 * kwTISDβ_charFree W a b + kwTISDγ_charFree W a b * b
+    + W.a₁ * a * kwTISDγ_charFree W a b + W.a₆ * kwTISDβ_charFree W a b
+
+omit [DecidableEq F] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_addYFun_sub_mul_linear_charFree :
+    (W.addYFun a b - ι b) * (W.polyToFunctionField X - ι a) =
+      -(ι (kwTISDβ_charFree W a b)) * (W.polyToFunctionField X - ι a)
+        - ((W.yGen - ι b) + ι W.a₁ * (W.polyToFunctionField X - ι a))
+          * (W.addXFun a b - ι a) := by
+  have hxne : W.polyToFunctionField X ≠ ι a := polyToFunctionField_X_ne_algebraMap a
+  have hd : W.polyToFunctionField X - ι a ≠ 0 := sub_ne_zero.mpr hxne
+  change ((W.map ι).addY (W.polyToFunctionField X) (ι a) W.yGen
+      ((W.map ι).slope (W.polyToFunctionField X) (ι a) W.yGen (ι b)) - ι b)
+        * (W.polyToFunctionField X - ι a) =
+      -(ι (kwTISDβ_charFree W a b)) * (W.polyToFunctionField X - ι a)
+        - ((W.yGen - ι b) + ι W.a₁ * (W.polyToFunctionField X - ι a))
+          * ((W.map ι).addX (W.polyToFunctionField X) (ι a)
+              ((W.map ι).slope (W.polyToFunctionField X) (ι a) W.yGen (ι b)) - ι a)
+  rw [slope_of_X_ne hxne, addY, negAddY, negY, addX]
+  simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+    kwTISDβ_charFree,
+    map_add, map_mul, map_ofNat]
+  field_simp
+  ring
+
+omit [DecidableEq F] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_addYFun_sub_mul_cube_num_charFree :
+    (W.addYFun a b - ι b) * (W.polyToFunctionField X - ι a) ^ 3 =
+      ι (kwTISDδ2_charFree W a b) * W.polyToFunctionField X ^ 2
+        - ι (kwTISDα_charFree W a b) * (W.polyToFunctionField X * W.yGen)
+        + ι (kwTISDδ1_charFree W a b) * W.polyToFunctionField X
+        + ι (kwTISDδY_charFree W a b) * W.yGen + ι (kwTISDδ0_charFree W a b) := by
+  have hEq := equation_map_polyToFunctionField_yGen (W := W)
+  rw [Affine.equation_iff] at hEq
+  simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+    WeierstrassCurve.map_a₄, WeierstrassCurve.map_a₆] at hEq
+  have h0a := kw_addXFun_sub_mul_sq_num_charFree W a b
+  have step_i := kw_addYFun_sub_mul_linear_charFree W a b
+  simp only [kwTISDδ2_charFree, kwTISDδ1_charFree, kwTISDδY_charFree, kwTISDδ0_charFree,
+    kwTISDα_charFree, kwTISDβ_charFree, kwTISDγ_charFree,
+    map_add, map_sub, map_mul, map_pow, map_ofNat, _root_.map_neg] at h0a step_i ⊢
+  linear_combination (W.polyToFunctionField X - ι a) ^ 2 * step_i
+    - ((W.yGen - ι b) + ι W.a₁ * (W.polyToFunctionField X - ι a)) * h0a
+    + (2 * ι b + ι W.a₁ * ι a + ι W.a₃) * hEq
+
+variable {a b}
+
+omit [IsAlgClosed F] in
+omit [DecidableEq F] [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_addXFun_ne_algebraMap_any_charFree (hA : W.Equation a b) (c : F) :
+    W.addXFun a b ≠ ι c := by
+  have hΔ : W.Δ ≠ 0 := W.kwWdp_Δ_ne_zero_of_isElliptic
+  intro heq
+  refine polyToFunctionField_X_ne_algebraMap (W := W) c
+    ((translationAlgEquivOf hΔ hA).injective ?_)
+  rw [translationAlgEquivOf_polyToFunctionField_X hΔ hA, heq, AlgEquiv.commutes]
+
+omit [DecidableEq F] [W.AbelTheorem] in
+theorem kw_addYFun_ne_algebraMap_any_charFree (hA : W.Equation a b) (c : F) :
+    W.addYFun a b ≠ ι c := by
+  have hΔ : W.Δ ≠ 0 := W.kwWdp_Δ_ne_zero_of_isElliptic
+  intro heq
+  have hy : W.yGen = ι c := (translationAlgEquivOf hΔ hA).injective <| by
+    rw [translationAlgEquivOf_yGen hΔ hA, heq, AlgEquiv.commutes]
+  have hord := kw_ord_yGen_of_not_isFinitePlace_charFree W
+    (InfinitePlace.place (W := W)) InfinitePlace.not_isFinitePlace
+  rw [hy, AlgebraicCurve.Place.ord_algebraMap] at hord
+  exact absurd hord (by norm_num)
+
+omit [IsAlgClosed F] in
+omit [DecidableEq F] [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_ord_addXFun_sub_pos_charFree (hA : W.Equation a b)
+    (v : Place F W.FunctionField) (hv : ¬ IsFinitePlace v) :
+    0 < v.ord (W.addXFun a b - ι a) := by
+  have hne : W.addXFun a b - ι a ≠ 0 :=
+    sub_ne_zero.mpr (kw_addXFun_ne_algebraMap_any_charFree W hA a)
+  have hXa : W.polyToFunctionField X - ι a ≠ 0 := X_sub_algebraMap_ne_zero a
+  have hXa2 : (W.polyToFunctionField X - ι a) ^ 2 ≠ 0 := pow_ne_zero 2 hXa
+  have hY0 : W.yGen ≠ (0 : W.FunctionField) := Y_image_ne_zero
+  have hordY : v.ord W.yGen = -3 := kw_ord_yGen_of_not_isFinitePlace_charFree W v hv
+  set num := ι (kwTISDα_charFree W a b) * W.polyToFunctionField X
+      - ι (kwTISDβ_charFree W a b) * W.yGen + ι (kwTISDγ_charFree W a b) with hnumdef
+  have hkey := kw_addXFun_sub_mul_sq_num_charFree W a b
+  rw [← hnumdef] at hkey
+  have hnum0 : num ≠ 0 := by rw [← hkey]; exact mul_ne_zero hne hXa2
+  have hordeq : v.ord (W.addXFun a b - ι a) = v.ord num + 4 := by
+    have h := v.ord_mul hne hXa2
+    rw [hkey, v.ord_pow, ord_X_sub_algebraMap_of_not_isFinitePlace v hv a] at h
+    omega
+  rw [hordeq]
+  have hmem : num * W.yGen⁻¹ ∈ v.toValuationSubring := by
+    have hYinv : W.yGen⁻¹ ∈ v.toValuationSubring :=
+      AlgebraicCurve.Place.mem_of_ord_nonneg v (inv_ne_zero hY0) (by rw [v.ord_inv, hordY]; omega)
+    have hXYinv : W.polyToFunctionField X * W.yGen⁻¹ ∈ v.toValuationSubring :=
+      AlgebraicCurve.Place.mem_of_ord_nonneg v (mul_ne_zero (polyToFunctionField_ne_zero X_ne_zero)
+        (inv_ne_zero hY0))
+        (by rw [v.ord_mul (polyToFunctionField_ne_zero X_ne_zero) (inv_ne_zero hY0), v.ord_inv,
+              ord_X_eq_neg_two_of_not_isFinitePlace v hv, hordY]; omega)
+    rw [hnumdef, add_mul, sub_mul, mul_assoc _ (W.polyToFunctionField X), mul_assoc _ W.yGen,
+      mul_inv_cancel₀ hY0, mul_one]
+    exact add_mem (sub_mem (mul_mem (v.algebraMap_mem' _) hXYinv) (v.algebraMap_mem' _))
+      (mul_mem (v.algebraMap_mem' _) hYinv)
+  have hnumord : -3 ≤ v.ord num := by
+    have :=
+      (AlgebraicCurve.Place.mem_iff_ord_nonneg v (mul_ne_zero hnum0 (inv_ne_zero hY0))).mp hmem
+    rw [v.ord_mul hnum0 (inv_ne_zero hY0), v.ord_inv, hordY] at this
+    linarith
+  linarith
+
+omit [DecidableEq F] [W.AbelTheorem] in
+theorem kw_ord_addYFun_sub_pos_charFree (hA : W.Equation a b)
+    (v : Place F W.FunctionField) (hv : ¬ IsFinitePlace v) :
+    0 < v.ord (W.addYFun a b - ι b) := by
+  have hne : W.addYFun a b - ι b ≠ 0 :=
+    sub_ne_zero.mpr (kw_addYFun_ne_algebraMap_any_charFree W hA b)
+  have hXa : W.polyToFunctionField X - ι a ≠ 0 := X_sub_algebraMap_ne_zero a
+  have hXa3 : (W.polyToFunctionField X - ι a) ^ 3 ≠ 0 := pow_ne_zero 3 hXa
+  have hX0 : W.polyToFunctionField X ≠ (0 : W.FunctionField) :=
+    polyToFunctionField_ne_zero X_ne_zero
+  have hY0 : W.yGen ≠ (0 : W.FunctionField) := Y_image_ne_zero
+  have hXY0 : W.polyToFunctionField X * W.yGen ≠ 0 := mul_ne_zero hX0 hY0
+  have hordX : v.ord (W.polyToFunctionField X) = -2 := ord_X_eq_neg_two_of_not_isFinitePlace v hv
+  have hordY : v.ord W.yGen = -3 := kw_ord_yGen_of_not_isFinitePlace_charFree W v hv
+  set numY := ι (kwTISDδ2_charFree W a b) * W.polyToFunctionField X ^ 2
+      - ι (kwTISDα_charFree W a b) * (W.polyToFunctionField X * W.yGen)
+      + ι (kwTISDδ1_charFree W a b) * W.polyToFunctionField X
+      + ι (kwTISDδY_charFree W a b) * W.yGen + ι (kwTISDδ0_charFree W a b) with hnumYdef
+  have hkey := kw_addYFun_sub_mul_cube_num_charFree W a b
+  rw [← hnumYdef] at hkey
+  have hnumY0 : numY ≠ 0 := by rw [← hkey]; exact mul_ne_zero hne hXa3
+  have hordeq : v.ord (W.addYFun a b - ι b) = v.ord numY + 6 := by
+    have h := v.ord_mul hne hXa3
+    rw [hkey, v.ord_pow, ord_X_sub_algebraMap_of_not_isFinitePlace v hv a] at h
+    omega
+  rw [hordeq]
+  have hmem : numY * (W.polyToFunctionField X * W.yGen)⁻¹ ∈ v.toValuationSubring := by
+    have hXYinv : (W.polyToFunctionField X * W.yGen)⁻¹ ∈ v.toValuationSubring :=
+      AlgebraicCurve.Place.mem_of_ord_nonneg v (inv_ne_zero hXY0)
+        (by rw [v.ord_inv, v.ord_mul hX0 hY0, hordX, hordY]; omega)
+    have hXinv : (W.polyToFunctionField X)⁻¹ ∈ v.toValuationSubring :=
+      AlgebraicCurve.Place.mem_of_ord_nonneg v (inv_ne_zero hX0) (by rw [v.ord_inv, hordX]; omega)
+    have hYinv : W.yGen⁻¹ ∈ v.toValuationSubring :=
+      AlgebraicCurve.Place.mem_of_ord_nonneg v (inv_ne_zero hY0) (by rw [v.ord_inv, hordY]; omega)
+    have hXoYinv : W.polyToFunctionField X * W.yGen⁻¹ ∈ v.toValuationSubring :=
+      AlgebraicCurve.Place.mem_of_ord_nonneg v (mul_ne_zero hX0 (inv_ne_zero hY0))
+        (by rw [v.ord_mul hX0 (inv_ne_zero hY0), v.ord_inv, hordX, hordY]; omega)
+    have hsplit : numY * (W.polyToFunctionField X * W.yGen)⁻¹
+        = ι (kwTISDδ2_charFree W a b) * (W.polyToFunctionField X * W.yGen⁻¹)
+          - ι (kwTISDα_charFree W a b)
+          + ι (kwTISDδ1_charFree W a b) * W.yGen⁻¹
+          + ι (kwTISDδY_charFree W a b) * (W.polyToFunctionField X)⁻¹
+          + ι (kwTISDδ0_charFree W a b) * (W.polyToFunctionField X * W.yGen)⁻¹ := by
+      rw [hnumYdef]; field_simp
+    rw [hsplit]
+    exact add_mem (add_mem (add_mem
+      (sub_mem (mul_mem (v.algebraMap_mem' _) hXoYinv) (v.algebraMap_mem' _))
+      (mul_mem (v.algebraMap_mem' _) hYinv))
+      (mul_mem (v.algebraMap_mem' _) hXinv))
+      (mul_mem (v.algebraMap_mem' _) hXYinv)
+  have hnumYord : -5 ≤ v.ord numY := by
+    have :=
+      (AlgebraicCurve.Place.mem_iff_ord_nonneg v (mul_ne_zero hnumY0 (inv_ne_zero hXY0))).mp hmem
+    rw [v.ord_mul hnumY0 (inv_ne_zero hXY0), v.ord_inv, v.ord_mul hX0 hY0, hordX, hordY] at this
+    linarith
+  linarith
+
+variable {p q : F}
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_affod_numX_eval_eq_zero_charFree (hP : W.Equation p q) (hne : p ≠ a) :
+    kwTISDα_charFree W a b * p - kwTISDβ_charFree W a b * q + kwTISDγ_charFree W a b
+      - (W.addX p a (W.slope p a q b) - a) * (p - a) ^ 2 = 0 := by
+  have hEq := (Affine.equation_iff ..).mp hP
+  have hd : p - a ≠ 0 := sub_ne_zero.mpr hne
+  simp only [kwTISDα_charFree, kwTISDβ_charFree, kwTISDγ_charFree,
+    Affine.slope_of_X_ne hne, Affine.addX]
+  field_simp
+  linear_combination -hEq
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_affod_numYcube_eval_eq_zero_charFree (hP : W.Equation p q) (hne : p ≠ a) :
+    kwTISDδ2_charFree W a b * p ^ 2 - kwTISDα_charFree W a b * (p * q)
+      + kwTISDδ1_charFree W a b * p + kwTISDδY_charFree W a b * q
+      + kwTISDδ0_charFree W a b
+      - (W.addY p a q (W.slope p a q b) - b) * (p - a) ^ 3 = 0 := by
+  have hEq := (Affine.equation_iff ..).mp hP
+  have hd : p - a ≠ 0 := sub_ne_zero.mpr hne
+  simp only [kwTISDδ2_charFree, kwTISDδ1_charFree, kwTISDδY_charFree, kwTISDδ0_charFree,
+    kwTISDα_charFree, kwTISDβ_charFree, kwTISDγ_charFree,
+    Affine.slope_of_X_ne hne, Affine.addX, Affine.addY, Affine.negAddY, Affine.negY]
+  field_simp
+  linear_combination ((q - b) + W.a₁ * (p - a) - (2 * b + W.a₁ * a + W.a₃)) * hEq
+
+omit [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_ord_addXFun_sub_addX_pos_charFree (h : W.Nonsingular a b) (hP : W.Nonsingular p q)
+    (hne : p ≠ a) :
+    0 < (placeOfEquation hP.1).ord
+      (W.addXFun a b - ι (W.addX p a (W.slope p a q b))) := by
+  set v := placeOfEquation hP.1
+  set x₃ := W.addX p a (W.slope p a q b)
+  have hXa : W.polyToFunctionField X - ι a ≠ 0 := X_sub_algebraMap_ne_zero a
+  have hXa2 : (W.polyToFunctionField X - ι a) ^ 2 ≠ 0 := pow_ne_zero 2 hXa
+  have hne_x₃ : W.addXFun a b - ι x₃ ≠ 0 :=
+    sub_ne_zero.mpr (kw_addXFun_ne_algebraMap_any_charFree W h.1 x₃)
+  set qX : F[X][Y] :=
+    C (C (kwTISDα_charFree W a b) * X + C (kwTISDγ_charFree W a b)
+        - C (x₃ - a) * (X - C a) ^ 2)
+      - C (C (kwTISDβ_charFree W a b)) * Y with hqX
+  have hprod :
+      (W.addXFun a b - ι x₃) * (W.polyToFunctionField X - ι a) ^ 2
+        = algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W qX) := by
+    have h0a := kw_addXFun_sub_mul_sq_num_charFree W a b
+    have hmk : CoordinateRing.mk W qX
+        = algebraMap F[X] W.CoordinateRing
+            (C (kwTISDα_charFree W a b) * X + C (kwTISDγ_charFree W a b)
+              - C (x₃ - a) * (X - C a) ^ 2)
+          - algebraMap F[X] W.CoordinateRing (C (kwTISDβ_charFree W a b))
+            * CoordinateRing.mk W Y := by
+      simp only [hqX, map_sub, map_mul]; rfl
+    have hyGen : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+        = W.yGen := rfl
+    rw [hmk, map_sub, map_mul, ← polyToFunctionField_apply, ← polyToFunctionField_apply, hyGen]
+    simp only [map_sub, map_add, map_mul, map_pow, polyToFunctionField_C]
+    linear_combination h0a
+  have heval : qX.evalEval p q = 0 := by
+    simp only [hqX, evalEval, eval_sub, eval_mul, eval_C, eval_add, eval_X, eval_pow,
+      Polynomial.eval_C, Polynomial.eval_mul, Polynomial.eval_add, Polynomial.eval_sub,
+      Polynomial.eval_pow, Polynomial.eval_X]
+    linear_combination kw_affod_numX_eval_eq_zero_charFree W hP.1 hne
+  have hmk_ne : CoordinateRing.mk W qX ≠ 0 := by
+    intro h0
+    rw [h0, _root_.map_zero] at hprod
+    exact (mul_ne_zero hne_x₃ hXa2) hprod
+  have hordnum :
+      0 < v.ord (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W qX)) :=
+    (ord_placeOfEquation_pos_iff hP.1 hmk_ne).mpr
+      ((CoordinateRing.mk_mem_XYIdeal_iff_evalEval_eq_zero hP.1 qX).mpr heval)
+  have hordXa : v.ord (W.polyToFunctionField X - ι a) = 0 := by
+    rw [show W.polyToFunctionField X - ι a = W.polyToFunctionField (X - C a) by
+      rw [map_sub, polyToFunctionField_C],
+      ord_polyToFunctionField_eq_zero_iff hP.1 (X_sub_C_ne_zero a)]
+    simp [sub_ne_zero.mpr hne]
+  have heqord := v.ord_mul hne_x₃ hXa2
+  rw [hprod, v.ord_pow, hordXa] at heqord
+  omega
+
+omit [W.AbelTheorem] in
+theorem kw_ord_addYFun_sub_addY_pos_charFree (h : W.Nonsingular a b) (hP : W.Nonsingular p q)
+    (hne : p ≠ a) :
+    0 < (placeOfEquation hP.1).ord
+      (W.addYFun a b - ι (W.addY p a q (W.slope p a q b))) := by
+  set v := placeOfEquation hP.1
+  set y₃ := W.addY p a q (W.slope p a q b)
+  have hXa : W.polyToFunctionField X - ι a ≠ 0 := X_sub_algebraMap_ne_zero a
+  have hXa3 : (W.polyToFunctionField X - ι a) ^ 3 ≠ 0 := pow_ne_zero 3 hXa
+  have hne_y₃ : W.addYFun a b - ι y₃ ≠ 0 :=
+    sub_ne_zero.mpr (kw_addYFun_ne_algebraMap_any_charFree W h.1 y₃)
+  set qY : F[X][Y] :=
+    C (C (kwTISDδ2_charFree W a b) * X ^ 2 + C (kwTISDδ1_charFree W a b) * X
+        + C (kwTISDδ0_charFree W a b) - C (y₃ - b) * (X - C a) ^ 3)
+      + C (C (kwTISDδY_charFree W a b) - C (kwTISDα_charFree W a b) * X) * Y with hqY
+  have hprod :
+      (W.addYFun a b - ι y₃) * (W.polyToFunctionField X - ι a) ^ 3
+        = algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W qY) := by
+    have h0b := kw_addYFun_sub_mul_cube_num_charFree W a b
+    have hmk : CoordinateRing.mk W qY
+        = algebraMap F[X] W.CoordinateRing
+            (C (kwTISDδ2_charFree W a b) * X ^ 2 + C (kwTISDδ1_charFree W a b) * X
+              + C (kwTISDδ0_charFree W a b) - C (y₃ - b) * (X - C a) ^ 3)
+          + algebraMap F[X] W.CoordinateRing
+              (C (kwTISDδY_charFree W a b) - C (kwTISDα_charFree W a b) * X)
+            * CoordinateRing.mk W Y := by
+      simp only [hqY, map_add, map_sub, map_mul]; rfl
+    have hyGen : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+        = W.yGen := rfl
+    rw [hmk, map_add, map_mul, ← polyToFunctionField_apply, ← polyToFunctionField_apply, hyGen]
+    simp only [map_sub, map_add, map_mul, map_pow, polyToFunctionField_C]
+    linear_combination h0b
+  have heval : qY.evalEval p q = 0 := by
+    simp only [hqY, evalEval, eval_add, eval_sub, eval_mul, eval_C, eval_X, eval_pow,
+      Polynomial.eval_C, Polynomial.eval_mul, Polynomial.eval_add, Polynomial.eval_sub,
+      Polynomial.eval_pow, Polynomial.eval_X]
+    linear_combination kw_affod_numYcube_eval_eq_zero_charFree W hP.1 hne
+  have hmk_ne : CoordinateRing.mk W qY ≠ 0 := by
+    intro h0
+    rw [h0, _root_.map_zero] at hprod
+    exact (mul_ne_zero hne_y₃ hXa3) hprod
+  have hordnum :
+      0 < v.ord (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W qY)) :=
+    (ord_placeOfEquation_pos_iff hP.1 hmk_ne).mpr
+      ((CoordinateRing.mk_mem_XYIdeal_iff_evalEval_eq_zero hP.1 qY).mpr heval)
+  have hordXa : v.ord (W.polyToFunctionField X - ι a) = 0 := by
+    rw [show W.polyToFunctionField X - ι a = W.polyToFunctionField (X - C a) by
+      rw [map_sub, polyToFunctionField_C],
+      ord_polyToFunctionField_eq_zero_iff hP.1 (X_sub_C_ne_zero a)]
+    simp [sub_ne_zero.mpr hne]
+  have heqord := v.ord_mul hne_y₃ hXa3
+  rw [hprod, v.ord_pow, hordXa] at heqord
+  omega
+
+variable {W}
+
+omit [IsAlgClosed F] in
+omit [DecidableEq F] [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_translateFF_toAlgHom_isIntegral_charFree (R : W.Point) :
+    (Point.translateFF (W := W) R).toAlgHom.toRingHom.IsIntegral :=
+  RingHom.isIntegral_of_surjective _ (Point.translateFF (W := W) R).surjective
+
+omit [IsAlgClosed F] in
+omit [DecidableEq F] [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_translateFF_some_X_charFree (h : W.Nonsingular a b) :
+    (Point.translateFF (W := W) (.some a b h)).toAlgHom (polyToFunctionField W X)
+      = W.addXFun a b :=
+  translationAlgEquivOf_polyToFunctionField_X (hΔ := kwWdp_Δ_ne_zero_of_isElliptic) (hA := h.1)
+
+omit [IsAlgClosed F] in
+omit [DecidableEq F] [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_translateFF_some_yGen_charFree (h : W.Nonsingular a b) :
+    (Point.translateFF (W := W) (.some a b h)).toAlgHom (yGen W)
+      = W.addYFun a b :=
+  translationAlgEquivOf_yGen (hΔ := kwWdp_Δ_ne_zero_of_isElliptic) (hA := h.1)
+
+omit [DecidableEq F] [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_addSeam_restrictAlong_eq_placeOfEquation_charFree
+    {V : Affine F} [IsDedekindDomain V.CoordinateRing]
+    (φ : V.FunctionField →ₐ[F] W.FunctionField) (hφ : φ.toRingHom.IsIntegral)
+    {ξ η : W.FunctionField}
+    (hX : φ (polyToFunctionField V (X : F[X])) = ξ) (hY : φ (yGen V) = η)
+    (v : AlgebraicCurve.Place F W.FunctionField) {a' b' : F} (h' : V.Equation a' b')
+    (hreg : ξ ∈ v.toValuationSubring)
+    (hdx : 0 < v.ord (ξ - algebraMap F W.FunctionField a'))
+    (hdy : 0 < v.ord (η - algebraMap F W.FunctionField b')) :
+    v.restrictAlong φ hφ = placeOfEquation h' := by
+  have hfin : IsFinitePlace (v.restrictAlong φ hφ) :=
+    isFinitePlace_of_mem _ (by
+      rw [Place.mem_restrictAlong_iff, hX]
+      exact hreg)
+  refine eq_placeOfEquation_of_le_centre hfin h' ?_
+  rw [CoordinateRing.XYIdeal, Ideal.span_le]
+  intro r hr
+  simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hr
+  rcases hr with rfl | rfl
+  · rw [SetLike.mem_coe, hfin.mem_centre_iff_ord_ne_zero (CoordinateRing.XClass_ne_zero _),
+      Place.ord_restrictAlong_ne_zero_iff, AbstractSeam.map_XClass φ hX]
+    omega
+  · rw [SetLike.mem_coe, hfin.mem_centre_iff_ord_ne_zero (CoordinateRing.YClass_ne_zero _),
+      Place.ord_restrictAlong_ne_zero_iff, AbstractSeam.map_YClass φ hY]
+    omega
+
+omit [DecidableEq F] [W.AbelTheorem] in
+theorem kw_translAffineSeam_at_of_coordSeamData_charFree (h : W.Nonsingular a b)
+    (v : AlgebraicCurve.Place F W.FunctionField) (Q : W.Point)
+    (hdat : Q.rec
+      (W.addXFun a b ∉ v.toValuationSubring)
+      (fun x₃ y₃ _ =>
+        0 < v.ord (W.addXFun a b - ι x₃) ∧ 0 < v.ord (W.addYFun a b - ι y₃))) :
+    v.restrictAlong (Point.translateFF (W := W) (.some a b h)).toAlgHom
+        (kw_translateFF_toAlgHom_isIntegral_charFree (.some a b h))
+      = placeOfPoint Q := by
+  have hX := kw_translateFF_some_X_charFree h
+  have hY := kw_translateFF_some_yGen_charFree h
+  cases Q with
+  | zero =>
+    rw [placeOfPoint_zero]
+    exact AbstractSeam.restrictAlong_eq_infinitePlace _ _ hX v (hX ▸ hdat)
+  | some x₃ y₃ h₃ =>
+    rw [placeOfPoint_some]
+    have hdx := hdat.1; have hdy := hdat.2
+    have hreg : W.addXFun a b ∈ v.toValuationSubring := by
+      by_cases hz : W.addXFun a b - ι x₃ = 0
+      · rw [sub_eq_zero.mp hz]; exact v.algebraMap_mem' x₃
+      · have := add_mem (AlgebraicCurve.Place.mem_of_ord_nonneg v hz hdx.le) (v.algebraMap_mem' x₃)
+        rwa [sub_add_cancel] at this
+    exact kw_addSeam_restrictAlong_eq_placeOfEquation_charFree _ _ hX hY v h₃.1 hreg hdx hdy
+
+omit [DecidableEq F] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_TISD_linear_eval_negA_charFree (h : W.Equation a b) :
+    kwTISDα_charFree W a b * a - kwTISDβ_charFree W a b * W.negY a b
+      + kwTISDγ_charFree W a b = kwTISDβ_charFree W a b ^ 2 := by
+  have hEq := (Affine.equation_iff ..).mp h
+  simp only [kwTISDα_charFree, kwTISDβ_charFree, kwTISDγ_charFree, Affine.negY]
+  ring_nf
+  linear_combination -hEq
+
+omit [DecidableEq F] [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_addXFun_notMem_placeOfEquation_negA_charFree (h : W.Nonsingular a b)
+    (hβ : kwTISDβ_charFree W a b ≠ 0) :
+    W.addXFun a b ∉ (placeOfEquation (W := W)
+      ((W.nonsingular_neg a b).mpr h).1).toValuationSubring := by
+  intro hmem
+  set hnegA := ((W.nonsingular_neg a b).mpr h).1 with hnegA_def
+  let v := placeOfEquation (W := W) hnegA
+  have hne : W.addXFun a b - ι a ≠ 0 :=
+    sub_ne_zero.mpr (kw_addXFun_ne_algebraMap_any_charFree W h.1 a)
+  have hXa : W.polyToFunctionField X - ι a ≠ 0 := X_sub_algebraMap_ne_zero a
+  have hXa2 : (W.polyToFunctionField X - ι a) ^ 2 ≠ 0 := pow_ne_zero 2 hXa
+  set qpoly : F[X][Y] :=
+    C (C (kwTISDα_charFree W a b) * X + C (kwTISDγ_charFree W a b))
+      - C (C (kwTISDβ_charFree W a b)) * Y with hq
+  have hnum_mk :
+      ι (kwTISDα_charFree W a b) * W.polyToFunctionField X
+        - ι (kwTISDβ_charFree W a b) * W.yGen + ι (kwTISDγ_charFree W a b)
+      = algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W qpoly) := by
+    have hmk : CoordinateRing.mk W qpoly
+        = algebraMap F[X] W.CoordinateRing (C (kwTISDα_charFree W a b) * X
+              + C (kwTISDγ_charFree W a b))
+          - algebraMap F[X] W.CoordinateRing (C (kwTISDβ_charFree W a b))
+            * CoordinateRing.mk W Y := by
+      simp only [hq, map_sub, map_mul]; rfl
+    have hyGen : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+        = W.yGen := rfl
+    rw [hmk, map_sub, map_mul, ← polyToFunctionField_apply, ← polyToFunctionField_apply,
+      map_add, map_mul, polyToFunctionField_C, polyToFunctionField_C, polyToFunctionField_C,
+      hyGen]
+    ring
+  have heval : qpoly.evalEval a (W.negY a b) ≠ 0 := by
+    have : qpoly.evalEval a (W.negY a b) = kwTISDβ_charFree W a b ^ 2 := by
+      simp only [hq, evalEval, eval_sub, eval_mul, eval_C, eval_add, eval_X,
+        Polynomial.eval_C, Polynomial.eval_mul, Polynomial.eval_add, Polynomial.eval_X]
+      linear_combination kw_TISD_linear_eval_negA_charFree (W := W) h.1
+    rw [this]; exact pow_ne_zero 2 hβ
+  have hordnum : v.ord (ι (kwTISDα_charFree W a b) * W.polyToFunctionField X
+      - ι (kwTISDβ_charFree W a b) * W.yGen + ι (kwTISDγ_charFree W a b)) = 0 := by
+    rw [hnum_mk]
+    exact ord_placeOfEquation_eq_zero_of_evalEval_ne_zero hnegA heval
+  have hordXa : 1 ≤ v.ord (W.polyToFunctionField X - ι a) := by
+    have hroot : (X - C a : F[X]).IsRoot a := by simp
+    have hpos : 0 < v.ord (W.polyToFunctionField (X - C a)) :=
+      (ord_polyToFunctionField_pos_iff hnegA (X_sub_C_ne_zero a)).mpr hroot
+    rw [map_sub, polyToFunctionField_C] at hpos
+    omega
+  have hmem' : W.addXFun a b - ι a ∈ v.toValuationSubring :=
+    sub_mem hmem (v.algebraMap_mem' a)
+  have hord' : 0 ≤ v.ord (W.addXFun a b - ι a) :=
+    (AlgebraicCurve.Place.mem_iff_ord_nonneg v hne).mp hmem'
+  have heqord := v.ord_mul hne hXa2
+  rw [kw_addXFun_sub_mul_sq_num_charFree W a b, v.ord_pow, hordnum] at heqord
+  omega
+
+omit [DecidableEq F] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_taseq_α_eq_neg_polyX_charFree :
+    kwTISDα_charFree W a b = -(W.polynomialX.evalEval a b) := by
+  simp only [kwTISDα_charFree, evalEval_polynomialX]; ring
+
+omit [DecidableEq F] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_taseq_β_eq_polyY_charFree :
+    kwTISDβ_charFree W a b = W.polynomialY.evalEval a b := by
+  simp only [kwTISDβ_charFree, evalEval_polynomialY]
+
+omit [DecidableEq F] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_taseq_α_ne_zero_of_β_eq_zero_charFree (h : W.Nonsingular a b)
+    (hβ : kwTISDβ_charFree W a b = 0) : kwTISDα_charFree W a b ≠ 0 := by
+  rw [kw_taseq_α_eq_neg_polyX_charFree, neg_ne_zero]
+  have hβ' : W.polynomialY.evalEval a b = 0 := by
+    rw [← kw_taseq_β_eq_polyY_charFree]; exact hβ
+  exact h.2.resolve_right (absurd hβ')
+
+omit [DecidableEq F] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_taseq_β_eq_zero_iff_eq_negY_charFree :
+    kwTISDβ_charFree W a b = 0 ↔ b = W.negY a b := by
+  rw [kw_taseq_β_eq_polyY_charFree, evalEval_polynomialY_eq_zero_iff_eq_negY]
+
+omit [DecidableEq F] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_taseq_linear_eval_self_charFree (h : W.Equation a b) :
+    kwTISDα_charFree W a b * a - kwTISDβ_charFree W a b * b
+      + kwTISDγ_charFree W a b = 0 := by
+  have hEq := (Affine.equation_iff ..).mp h
+  simp only [kwTISDα_charFree, kwTISDβ_charFree, kwTISDγ_charFree]
+  linear_combination -hEq
+
+theorem kw_taseq_le_ord_sub_charFree {K L : Type*} [Field K] [Field L] [Algebra K L]
+    (v : Place K L) {N : ℤ} {f g : L} (hfg : f - g ≠ 0)
+    (hf : f = 0 ∨ N ≤ v.ord f) (hg : g = 0 ∨ N ≤ v.ord g) :
+    N ≤ v.ord (f - g) := by
+  have hneg : ∀ x : L, v.ord (-x) = v.ord x := fun x => by
+    simp only [Place.ord, Valuation.map_neg]
+  rcases hf with rfl | hf
+  · rw [zero_sub, hneg]
+    exact hg.resolve_left (by simpa using hfg)
+  rcases hg with rfl | hg
+  · rwa [sub_zero]
+  · rw [sub_eq_add_neg]
+    have hmin := v.min_ord_le_ord_add' (f := f) (g := -g) (by rwa [← sub_eq_add_neg])
+    rw [hneg] at hmin
+    omega
+
+open _root_.IsDedekindDomain
+  _root_.P2MW.S_OVERLONG_e431601d.IsDedekindDomain
+  _root_.WithZero
+  _root_.P2MW.S_OVERLONG_e431601d.WithZero
+  in
+omit [DecidableEq F] [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_taseq_ord_ge_of_mem_XYIdeal_pow_charFree (h : W.Equation a b)
+    {r : W.CoordinateRing} (hr0 : r ≠ 0) {n : ℕ} (hr : r ∈ XYIdeal W a (C b) ^ n) :
+    (n : ℤ) ≤ (placeOfEquation h).ord (algebraMap W.CoordinateRing W.FunctionField r) := by
+  have hrL : algebraMap W.CoordinateRing W.FunctionField r ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr hr0
+  rw [placeOfEquation, Place.ord_ofHeightOneSpectrum_eq_neg_log _ hrL,
+    (heightOneSpectrumOfEquation h).valuation_of_algebraMap]
+  have h1 : (heightOneSpectrumOfEquation h).intValuation r ≤ exp (-(n : ℤ)) := by
+    rw [show (-(n : ℤ)) = -((n : ℕ) : ℤ) from rfl,
+      HeightOneSpectrum.intValuation_le_pow_iff_mem, heightOneSpectrumOfEquation_asIdeal]
+    exact hr
+  rw [(heightOneSpectrumOfEquation h).intValuation_if_neg hr0] at h1 ⊢
+  rw [exp_le_exp] at h1
+  rw [log_exp]
+  omega
+
+omit [DecidableEq F] [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_addXFun_notMem_placeOfEquation_self_of_β_eq_zero_charFree (h : W.Nonsingular a b)
+    (hβ : kwTISDβ_charFree W a b = 0) :
+    W.addXFun a b ∉ (placeOfEquation h.1).toValuationSubring := by
+  intro hmem
+  have hα : kwTISDα_charFree W a b ≠ 0 := kw_taseq_α_ne_zero_of_β_eq_zero_charFree h hβ
+  have hιαne : ι (kwTISDα_charFree W a b) ≠ 0 :=
+    (map_ne_zero_iff _ (algebraMap F W.FunctionField).injective).mpr hα
+  have hne : W.addXFun a b - ι a ≠ 0 :=
+    sub_ne_zero.mpr (kw_addXFun_ne_algebraMap_any_charFree W h.1 a)
+  have hXa : W.polyToFunctionField X - ι a ≠ 0 := X_sub_algebraMap_ne_zero a
+  have hXa2 : (W.polyToFunctionField X - ι a) ^ 2 ≠ 0 := pow_ne_zero 2 hXa
+  have hprod :
+      (W.addXFun a b - ι a) * (W.polyToFunctionField X - ι a) ^ 2
+        = ι (kwTISDα_charFree W a b) * (W.polyToFunctionField X - ι a) := by
+    rw [kw_addXFun_sub_mul_sq_num_charFree W a b, hβ, _root_.map_zero, zero_mul, sub_zero]
+    have hval : kwTISDγ_charFree W a b = -(kwTISDα_charFree W a b * a) := by
+      have h0 := kw_taseq_linear_eval_self_charFree (W := W) h.1
+      rw [hβ, zero_mul, sub_zero] at h0; linear_combination h0
+    rw [hval, _root_.map_neg, map_mul]; ring
+  have hordXa : 0 < (placeOfEquation h.1).ord (W.polyToFunctionField X - ι a) := by
+    rw [show W.polyToFunctionField X - ι a = W.polyToFunctionField (X - C a) by
+      rw [map_sub, polyToFunctionField_C]]
+    exact (ord_polyToFunctionField_pos_iff h.1 (X_sub_C_ne_zero a)).mpr (by simp)
+  have hordα : (placeOfEquation h.1).ord (ι (kwTISDα_charFree W a b)) = 0 :=
+    AlgebraicCurve.Place.ord_algebraMap (placeOfEquation h.1) _
+  have hmem' : W.addXFun a b - ι a ∈ (placeOfEquation h.1).toValuationSubring :=
+    sub_mem hmem ((placeOfEquation h.1).algebraMap_mem' a)
+  have hord' : 0 ≤ (placeOfEquation h.1).ord (W.addXFun a b - ι a) :=
+    (AlgebraicCurve.Place.mem_iff_ord_nonneg (placeOfEquation h.1) hne).mp hmem'
+  have heqord := (placeOfEquation h.1).ord_mul hne hXa2
+  rw [hprod, (placeOfEquation h.1).ord_mul hιαne hXa, (placeOfEquation h.1).ord_pow,
+    hordα] at heqord
+  omega
+
+omit [DecidableEq F] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_taseq_linear_eq_neg_taylorLinear_charFree (h : W.Equation a b) :
+    ι (kwTISDα_charFree W a b) * W.polyToFunctionField X
+        - ι (kwTISDβ_charFree W a b) * W.yGen + ι (kwTISDγ_charFree W a b)
+      = - algebraMap W.CoordinateRing W.FunctionField
+          (algebraMap F W.CoordinateRing (W.polynomialX.evalEval a b) * XClass W a
+            + algebraMap F W.CoordinateRing (W.polynomialY.evalEval a b)
+              * YClass W (C b)) := by
+  have hXC : algebraMap W.CoordinateRing W.FunctionField (XClass W a)
+      = W.polyToFunctionField X - ι a := by
+    have : (XClass W a : W.CoordinateRing) = algebraMap F[X] W.CoordinateRing (X - C a) := rfl
+    rw [this, ← polyToFunctionField_apply, map_sub, polyToFunctionField_C]
+  have hYC : algebraMap W.CoordinateRing W.FunctionField (YClass W (C b))
+      = W.yGen - ι b := by
+    have : (YClass W (C b) : W.CoordinateRing)
+        = CoordinateRing.mk W Y - algebraMap F W.CoordinateRing b := by
+      change CoordinateRing.mk W (Y - C (C b)) = _; simp only [map_sub]; rfl
+    rw [this, map_sub]; rfl
+  have hval := kw_taseq_linear_eval_self_charFree (W := W) h
+  have hιval : ι (kwTISDγ_charFree W a b)
+      = -(ι (kwTISDα_charFree W a b) * ι a) + ι (kwTISDβ_charFree W a b) * ι b := by
+    rw [← map_mul, ← map_mul, ← _root_.map_neg, ← map_add]
+    exact congrArg ι (by linear_combination hval)
+  have hιpX : ι (W.polynomialX.evalEval a b) = -ι (kwTISDα_charFree W a b) := by
+    rw [kw_taseq_α_eq_neg_polyX_charFree, _root_.map_neg, neg_neg]
+  have hιpY : ι (W.polynomialY.evalEval a b) = ι (kwTISDβ_charFree W a b) := by
+    rw [← kw_taseq_β_eq_polyY_charFree]
+  rw [map_add, map_mul, map_mul, hXC, hYC,
+    ← IsScalarTower.algebraMap_apply F W.CoordinateRing W.FunctionField,
+    ← IsScalarTower.algebraMap_apply F W.CoordinateRing W.FunctionField,
+    hιpX, hιpY, hιval]
+  ring
+
+omit [DecidableEq F] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_taseq_linear_eq_algebraMap_mk_taylorRemainder₂_charFree (h : W.Equation a b) :
+    ι (kwTISDα_charFree W a b) * W.polyToFunctionField X
+        - ι (kwTISDβ_charFree W a b) * W.yGen + ι (kwTISDγ_charFree W a b)
+      = algebraMap W.CoordinateRing W.FunctionField
+          (CoordinateRing.mk W (W.taylorRemainder₂ a b)) := by
+  rw [kw_taseq_linear_eq_neg_taylorLinear_charFree h, neg_eq_iff_eq_neg, ← _root_.map_neg]
+  refine congrArg _ ?_
+  have h0 : CoordinateRing.mk W W.polynomial = 0 := AdjoinRoot.mk_self
+  have hF0 : W.polynomial.evalEval a b = 0 := h
+  have hexp := congrArg (CoordinateRing.mk W) (W.taylor₂_polynomial a b)
+  rw [h0, hF0] at hexp
+  rw [eq_neg_iff_add_eq_zero,
+    show (algebraMap F W.CoordinateRing) (W.polynomialX.evalEval a b)
+      = CoordinateRing.mk W (C (C (W.polynomialX.evalEval a b))) from rfl,
+    show (algebraMap F W.CoordinateRing) (W.polynomialY.evalEval a b)
+      = CoordinateRing.mk W (C (C (W.polynomialY.evalEval a b))) from rfl,
+    XClass, YClass]
+  simp only [map_add, map_mul, _root_.map_zero, zero_add] at hexp
+  linear_combination -hexp
+
+omit [DecidableEq F] [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_taseq_ord_X_sub_eq_one_charFree (h : W.Nonsingular a b)
+    (hβ : kwTISDβ_charFree W a b ≠ 0) :
+    (placeOfEquation h.1).ord (W.polyToFunctionField X - ι a) = 1 := by
+  have hY : W.polynomialY.evalEval a b ≠ 0 := kw_taseq_β_eq_polyY_charFree (W := W) ▸ hβ
+  have hXC : W.polyToFunctionField X - ι a
+      = algebraMap W.CoordinateRing W.FunctionField (XClass W a) := by
+    have : (XClass W a : W.CoordinateRing) = algebraMap F[X] W.CoordinateRing (X - C a) := rfl
+    rw [this, ← polyToFunctionField_apply, map_sub, polyToFunctionField_C]
+  rw [hXC]; exact ord_placeOfEquation_XClass_self h.1 hY
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_taseq_betasq_x2_sub_a_charFree (hβ : kwTISDβ_charFree W a b ≠ 0) :
+    kwTISDβ_charFree W a b ^ 2 * (W.addX a a (W.slope a a b b) - a)
+      = kwTISDα_charFree W a b ^ 2 + W.a₁ * kwTISDα_charFree W a b * kwTISDβ_charFree W a b
+        - (3 * a + W.a₂) * kwTISDβ_charFree W a b ^ 2 := by
+  have hYne : b ≠ W.negY a b := fun hy => hβ (kw_taseq_β_eq_zero_iff_eq_negY_charFree.mpr hy)
+  have hd : b - W.negY a b ≠ 0 := sub_ne_zero.mpr hYne
+  rw [Affine.slope_of_Y_ne rfl hYne, Affine.addX]
+  simp only [kwTISDα_charFree, kwTISDβ_charFree, Affine.negY] at hd ⊢
+  field_simp
+  ring
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_taseq_beta_y2_coeff_charFree (hβ : kwTISDβ_charFree W a b ≠ 0) :
+    kwTISDβ_charFree W a b
+        * (kwTISDβ_charFree W a b + W.addY a a b (W.slope a a b b) - b
+            + W.a₁ * (W.addX a a (W.slope a a b b) - a))
+      + kwTISDα_charFree W a b * (W.addX a a (W.slope a a b b) - a) = 0 := by
+  have hYne : b ≠ W.negY a b := fun hy => hβ (kw_taseq_β_eq_zero_iff_eq_negY_charFree.mpr hy)
+  have hd : b - W.negY a b ≠ 0 := sub_ne_zero.mpr hYne
+  rw [Affine.slope_of_Y_ne rfl hYne]
+  simp only [kwTISDα_charFree, kwTISDβ_charFree, Affine.addX, Affine.addY, Affine.negAddY,
+    Affine.negY] at hd ⊢
+  field_simp
+  ring
+
+section DoubleOrd
+
+variable (h : W.Nonsingular a b) (hβ : kwTISDβ_charFree W a b ≠ 0)
+
+local notation "x₂" => W.addX a a (W.slope a a b b)
+local notation "y₂" => W.addY a a b (W.slope a a b b)
+local notation "α" => kwTISDα_charFree W a b
+local notation "β" => kwTISDβ_charFree W a b
+local notation "Lcot" =>
+  algebraMap F W.CoordinateRing (W.polynomialX.evalEval a b) * XClass W a
+    + algebraMap F W.CoordinateRing (W.polynomialY.evalEval a b) * YClass W (C b)
+local notation "ι'" => algebraMap F W.CoordinateRing
+
+include h hβ
+
+omit [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem kw_taseq_ord_addXFun_sub_double_pos_charFree :
+    0 < (placeOfEquation h.1).ord (W.addXFun a b - ι x₂) := by
+  set R_X : W.CoordinateRing :=
+    CoordinateRing.mk W (W.taylorRemainder₂ a b) - ι' (x₂ - a) * XClass W a ^ 2 with hR_X
+  have hXa : W.polyToFunctionField X - ι a ≠ 0 := X_sub_algebraMap_ne_zero a
+  have hXa2 : (W.polyToFunctionField X - ι a) ^ 2 ≠ 0 := pow_ne_zero 2 hXa
+  have hne_x₂ : W.addXFun a b - ι x₂ ≠ 0 :=
+    sub_ne_zero.mpr (kw_addXFun_ne_algebraMap_any_charFree W h.1 x₂)
+  have hprod :
+      (W.addXFun a b - ι x₂) * (W.polyToFunctionField X - ι a) ^ 2
+        = algebraMap W.CoordinateRing W.FunctionField R_X := by
+    have hXC : algebraMap W.CoordinateRing W.FunctionField (XClass W a)
+        = W.polyToFunctionField X - ι a := by
+      have : (XClass W a : W.CoordinateRing)
+          = algebraMap F[X] W.CoordinateRing (X - C a) := rfl
+      rw [this, ← polyToFunctionField_apply, map_sub, polyToFunctionField_C]
+    have h0a := kw_addXFun_sub_mul_sq_num_charFree W a b
+    have heqR := kw_taseq_linear_eq_algebraMap_mk_taylorRemainder₂_charFree (W := W) h.1
+    rw [hR_X, map_sub, map_mul, map_pow, hXC,
+      ← IsScalarTower.algebraMap_apply F W.CoordinateRing W.FunctionField,
+      ← heqR, ← h0a, map_sub]
+    ring
+  have hR_Xne : R_X ≠ 0 := by
+    intro h0; rw [h0, _root_.map_zero] at hprod
+    exact mul_ne_zero hne_x₂ hXa2 hprod
+  have hβ'sq_mem : ι' β ^ 2 * R_X ∈ XYIdeal W a (C b) ^ 3 := by
+    have hXmem : XClass W a ∈ XYIdeal W a (C b) :=
+      Ideal.subset_span (Set.mem_insert _ _)
+    have hLmem : (Lcot : W.CoordinateRing) ∈ XYIdeal W a (C b) ^ 2 :=
+      taylor_linear_mem_XYIdeal_sq h.1
+    have hkey :
+        ι' β ^ 2 * R_X
+          = ι' (2 * α + W.a₁ * β) * (XClass W a * Lcot) + Lcot * Lcot
+            - ι' β ^ 2 * XClass W a ^ 3 := by
+      have hLcot : (Lcot : W.CoordinateRing)
+          = ι' (-α) * XClass W a + ι' β * YClass W (C b) := by
+        congr 2
+        · exact congrArg ι' (by rw [kw_taseq_α_eq_neg_polyX_charFree]; ring)
+        · exact congrArg ι' kw_taseq_β_eq_polyY_charFree.symm
+      have hXgen : CoordinateRing.mk W (C (X : F[X])) = XClass W a + ι' a := by
+        rw [CoordinateRing.algebraMap_eq_mk_C_C, XClass, ← map_add, ← Polynomial.C_add,
+          sub_add_cancel]
+      have htR₂ : CoordinateRing.mk W (W.taylorRemainder₂ a b)
+          = YClass W (C b) ^ 2 + ι' W.a₁ * (XClass W a * YClass W (C b))
+            - (XClass W a + ι' (3 * a + W.a₂)) * XClass W a ^ 2 := by
+        have hc : (C (2 * a + W.a₂) : F[X]) = C 2 * C a + C W.a₂ := by
+          rw [Polynomial.C_add, Polynomial.C_mul]
+        simp only [taylorRemainder₂, map_sub, map_add, map_mul, map_pow, hc,
+          ← CoordinateRing.algebraMap_eq_mk_C_C, map_ofNat,
+          show CoordinateRing.mk W (Y - C (C b)) = YClass W (C b) from rfl,
+          hXgen]
+        ring
+      have hι'βx₂ := congrArg ι'
+        (kw_taseq_betasq_x2_sub_a_charFree (W := W) (a := a) (b := b) hβ)
+      simp only [map_sub, map_add, map_mul, map_pow, map_ofNat, _root_.map_neg] at hι'βx₂ hLcot
+      rw [hR_X, hLcot, htR₂]
+      simp only [map_sub, map_add, map_mul, map_ofNat]
+      linear_combination (-(XClass W a) ^ 2 : W.CoordinateRing) * hι'βx₂
+    rw [hkey, show (3 : ℕ) = 1 + 2 from rfl, pow_add, pow_one]
+    refine sub_mem (add_mem ?_ ?_) ?_
+    · exact Ideal.mul_mem_left _ _ (Ideal.mul_mem_mul hXmem hLmem)
+    · exact Ideal.mul_mem_mul (Ideal.pow_le_self two_ne_zero hLmem) hLmem
+    · rw [show (XClass W a : W.CoordinateRing) ^ 3 = XClass W a * XClass W a ^ 2 by ring]
+      exact Ideal.mul_mem_left _ _ (Ideal.mul_mem_mul hXmem (Ideal.pow_mem_pow hXmem 2))
+  have hR_Xmem : R_X ∈ XYIdeal W a (C b) ^ 3 := by
+    have hunit : IsUnit (ι' β ^ 2) := (IsUnit.map ι' (isUnit_iff_ne_zero.mpr hβ)).pow 2
+    obtain ⟨u, hu⟩ := hunit
+    have : R_X = (↑u⁻¹ : W.CoordinateRing) * (ι' β ^ 2 * R_X) := by
+      rw [← hu, ← mul_assoc, Units.inv_mul, one_mul]
+    rw [this]; exact Ideal.mul_mem_left _ _ hβ'sq_mem
+  have hordR : (3 : ℤ) ≤ (placeOfEquation h.1).ord
+      (algebraMap W.CoordinateRing W.FunctionField R_X) := by
+    have := kw_taseq_ord_ge_of_mem_XYIdeal_pow_charFree h.1 hR_Xne (n := 3) hR_Xmem
+    exact_mod_cast this
+  have hordXa1 := kw_taseq_ord_X_sub_eq_one_charFree h hβ
+  have heqord := (placeOfEquation h.1).ord_mul hne_x₂ hXa2
+  rw [hprod, (placeOfEquation h.1).ord_pow, hordXa1] at heqord
+  omega
+
+omit [W.AbelTheorem] in
+theorem kw_taseq_ord_addYFun_sub_double_pos_charFree :
+    0 < (placeOfEquation h.1).ord (W.addYFun a b - ι y₂) := by
+  set u := W.polyToFunctionField X - ι a with hu
+  set M := (W.yGen - ι b) + ι W.a₁ * u with hM
+  have hXa : u ≠ 0 := X_sub_algebraMap_ne_zero a
+  have hXa2 : u ^ 2 ≠ 0 := pow_ne_zero 2 hXa
+  have hne_y₂ : W.addYFun a b - ι y₂ ≠ 0 :=
+    sub_ne_zero.mpr (kw_addYFun_ne_algebraMap_any_charFree W h.1 y₂)
+  set S : W.FunctionField := -ι (β + y₂ - b + W.a₁ * (x₂ - a)) * u ^ 2
+      - ι (x₂ - a) * u * (W.yGen - ι b) with hS
+  have hstep :
+      (W.addYFun a b - ι y₂) * u ^ 2 = S - M * u * (W.addXFun a b - ι x₂) := by
+    have step_i := kw_addYFun_sub_mul_linear_charFree W a b
+    rw [hS, hM, hu]
+    simp only [map_add, map_sub, map_mul] at step_i ⊢
+    linear_combination (W.polyToFunctionField X - ι a) * step_i
+  set R_S : W.CoordinateRing :=
+    -ι' (β + y₂ - b + W.a₁ * (x₂ - a)) * XClass W a ^ 2
+      - ι' (x₂ - a) * XClass W a * YClass W (C b) with hR_S
+  have hSmap : S = algebraMap W.CoordinateRing W.FunctionField R_S := by
+    have hXC : algebraMap W.CoordinateRing W.FunctionField (XClass W a) = u := by
+      rw [hu]
+      have : (XClass W a : W.CoordinateRing)
+          = algebraMap F[X] W.CoordinateRing (X - C a) := rfl
+      rw [this, ← polyToFunctionField_apply, map_sub, polyToFunctionField_C]
+    have hYC : algebraMap W.CoordinateRing W.FunctionField (YClass W (C b))
+        = W.yGen - ι b := by
+      have : (YClass W (C b) : W.CoordinateRing)
+          = CoordinateRing.mk W Y - algebraMap F W.CoordinateRing b := by
+        change CoordinateRing.mk W (Y - C (C b)) = _; simp only [map_sub]; rfl
+      rw [this, map_sub]; rfl
+    rw [hR_S, map_sub, map_mul, map_mul, map_mul, _root_.map_neg, map_pow, hXC, hYC,
+      ← IsScalarTower.algebraMap_apply F W.CoordinateRing W.FunctionField,
+      ← IsScalarTower.algebraMap_apply F W.CoordinateRing W.FunctionField, hS]
+  have hβR_S : ι' β * R_S = -ι' (x₂ - a) * (XClass W a * Lcot) := by
+    rw [hR_S, show (Lcot : W.CoordinateRing)
+        = ι' (-α) * XClass W a + ι' β * YClass W (C b) from by
+          congr 2
+          · exact congrArg ι' (by rw [kw_taseq_α_eq_neg_polyX_charFree]; ring)
+          · exact congrArg ι' kw_taseq_β_eq_polyY_charFree.symm]
+    have hyc := kw_taseq_beta_y2_coeff_charFree (W := W) (a := a) (b := b) hβ
+    have hι'yc : ι' (β * (β + y₂ - b + W.a₁ * (x₂ - a)) + α * (x₂ - a)) = ι' 0 :=
+      congrArg ι' hyc
+    simp only [map_mul, map_add, map_sub, _root_.map_neg, _root_.map_zero] at hι'yc ⊢
+    linear_combination -(XClass W a ^ 2) * hι'yc
+  have hR_Smem : R_S ∈ XYIdeal W a (C b) ^ 3 := by
+    have hβ'mem : ι' β * R_S ∈ XYIdeal W a (C b) ^ 3 := by
+      rw [hβR_S, show (3 : ℕ) = 1 + 2 from rfl, pow_add, pow_one]
+      exact Ideal.mul_mem_left _ _
+        (Ideal.mul_mem_mul (Ideal.subset_span (Set.mem_insert _ _))
+          (taylor_linear_mem_XYIdeal_sq h.1))
+    have hunit : IsUnit (ι' β) := IsUnit.map ι' (isUnit_iff_ne_zero.mpr hβ)
+    obtain ⟨v, hv⟩ := hunit
+    have : R_S = (↑v⁻¹ : W.CoordinateRing) * (ι' β * R_S) := by
+      rw [← hv, ← mul_assoc, Units.inv_mul, one_mul]
+    rw [this]; exact Ideal.mul_mem_left _ _ hβ'mem
+  have hordXa1 := kw_taseq_ord_X_sub_eq_one_charFree h hβ
+  rw [← hu] at hordXa1
+  have hordS : S = 0 ∨ (3 : ℤ) ≤ (placeOfEquation h.1).ord S := by
+    rcases eq_or_ne R_S 0 with h0 | h0
+    · left; rw [hSmap, h0, _root_.map_zero]
+    · right; rw [hSmap]
+      have := kw_taseq_ord_ge_of_mem_XYIdeal_pow_charFree h.1 h0 (n := 3) hR_Smem
+      exact_mod_cast this
+  have hordMterm : M * u * (W.addXFun a b - ι x₂) = 0
+      ∨ (3 : ℤ) ≤ (placeOfEquation h.1).ord (M * u * (W.addXFun a b - ι x₂)) := by
+    rcases eq_or_ne (M * u * (W.addXFun a b - ι x₂)) 0 with h0 | h0
+    · exact Or.inl h0
+    · right
+      have hMne : M ≠ 0 := by
+        intro hM0; rw [hM0, zero_mul, zero_mul] at h0; exact h0 rfl
+      have hXFne : W.addXFun a b - ι x₂ ≠ 0 :=
+        sub_ne_zero.mpr (kw_addXFun_ne_algebraMap_any_charFree W h.1 x₂)
+      rw [(placeOfEquation h.1).ord_mul (mul_ne_zero hMne hXa) hXFne,
+        (placeOfEquation h.1).ord_mul hMne hXa, hordXa1]
+      have hXord := kw_taseq_ord_addXFun_sub_double_pos_charFree h hβ
+      have hMmap : M = algebraMap W.CoordinateRing W.FunctionField
+          (YClass W (C b) + ι' W.a₁ * XClass W a) := by
+        have hXC : algebraMap W.CoordinateRing W.FunctionField (XClass W a) = u := by
+          rw [hu]
+          have : (XClass W a : W.CoordinateRing)
+              = algebraMap F[X] W.CoordinateRing (X - C a) := rfl
+          rw [this, ← polyToFunctionField_apply, map_sub, polyToFunctionField_C]
+        have hYC : algebraMap W.CoordinateRing W.FunctionField (YClass W (C b))
+            = W.yGen - ι b := by
+          have : (YClass W (C b) : W.CoordinateRing)
+              = CoordinateRing.mk W Y - algebraMap F W.CoordinateRing b := by
+            change CoordinateRing.mk W (Y - C (C b)) = _; simp only [map_sub]; rfl
+          rw [this, map_sub]; rfl
+        rw [hM, map_add, map_mul, hXC, hYC,
+          ← IsScalarTower.algebraMap_apply F W.CoordinateRing W.FunctionField]
+      have hMmem : YClass W (C b) + ι' W.a₁ * XClass W a ∈ XYIdeal W a (C b) :=
+        add_mem (Ideal.subset_span (Set.mem_insert_of_mem _ rfl))
+          (Ideal.mul_mem_left _ _ (Ideal.subset_span (Set.mem_insert _ _)))
+      have hMcne : (YClass W (C b) + ι' W.a₁ * XClass W a : W.CoordinateRing) ≠ 0 := by
+        intro h0
+        rw [h0, _root_.map_zero] at hMmap; exact hMne hMmap
+      have hMord : (1 : ℤ) ≤ (placeOfEquation h.1).ord M := by
+        rw [hMmap]
+        have := kw_taseq_ord_ge_of_mem_XYIdeal_pow_charFree h.1 hMcne (n := 1)
+          (by simpa using hMmem)
+        exact_mod_cast this
+      omega
+  have hfg_ne : (W.addYFun a b - ι y₂) * u ^ 2 ≠ 0 := mul_ne_zero hne_y₂ hXa2
+  rw [hstep] at hfg_ne
+  have hordLHS : (3 : ℤ) ≤ (placeOfEquation h.1).ord
+      (S - M * u * (W.addXFun a b - ι x₂)) :=
+    kw_taseq_le_ord_sub_charFree (placeOfEquation h.1) hfg_ne hordS hordMterm
+  have heqord := (placeOfEquation h.1).ord_mul hne_y₂ hXa2
+  rw [hstep, (placeOfEquation h.1).ord_pow, hordXa1] at heqord
+  omega
+
+end DoubleOrd
+
+omit [W.AbelTheorem] in
+theorem kw_translAffineSeamAtEqX_charFree (h : W.Nonsingular a b) (hP : W.Nonsingular a b) :
+    (placeOfEquation hP.1).restrictAlong
+        (Point.translateFF (W := W) (.some a b h)).toAlgHom
+        (kw_translateFF_toAlgHom_isIntegral_charFree (.some a b h))
+      = placeOfPoint (Point.some a b hP + Point.some a b h) := by
+  have hPeq : (placeOfEquation hP.1 : Place F W.FunctionField) = placeOfEquation h.1 := rfl
+  rw [hPeq, show (Point.some a b hP : W.Point) = Point.some a b h from rfl]
+  rcases eq_or_ne (kwTISDβ_charFree W a b) 0 with hβ | hβ
+  · have h2A : Point.some a b h + Point.some a b h = 0 := by
+      have hbn : W.negY a b = b := (kw_taseq_β_eq_zero_iff_eq_negY_charFree.mp hβ).symm
+      have hneg : (-Point.some a b h : W.Point) = Point.some a b h := by
+        rw [Point.neg_some, Point.some.injEq]; exact ⟨rfl, hbn⟩
+      nth_rw 2 [← hneg]; exact add_neg_cancel _
+    rw [h2A]
+    refine kw_translAffineSeam_at_of_coordSeamData_charFree h _ 0 ?_
+    exact kw_addXFun_notMem_placeOfEquation_self_of_β_eq_zero_charFree h hβ
+  · have hYne : b ≠ W.negY a b := fun hy => hβ (kw_taseq_β_eq_zero_iff_eq_negY_charFree.mpr hy)
+    rw [Point.add_self_of_Y_ne hYne]
+    refine kw_translAffineSeam_at_of_coordSeamData_charFree h _ _ ?_
+    exact ⟨kw_taseq_ord_addXFun_sub_double_pos_charFree h hβ,
+      kw_taseq_ord_addYFun_sub_double_pos_charFree h hβ⟩
+
+omit [DecidableEq F] [W.AbelTheorem] in
+theorem kw_restrictAlong_translateFF_infinitePlace_charFree (h : W.Nonsingular a b) :
+    (InfinitePlace.place : Place F W.FunctionField).restrictAlong
+        (Point.translateFF (W := W) (.some a b h)).toAlgHom
+        (kw_translateFF_toAlgHom_isIntegral_charFree (.some a b h))
+      = placeOfPoint (.some a b h) :=
+  kw_translAffineSeam_at_of_coordSeamData_charFree h _ (.some a b h)
+    ⟨kw_ord_addXFun_sub_pos_charFree W h.1 _ InfinitePlace.not_isFinitePlace,
+     kw_ord_addYFun_sub_pos_charFree W h.1 _ InfinitePlace.not_isFinitePlace⟩
+
+omit [W.AbelTheorem] in
+theorem kw_restrictAlong_translateFF_some_placeOfPoint_charFree (h : W.Nonsingular a b)
+    (Q : W.Point) :
+    (placeOfPoint Q).restrictAlong
+        (Point.translateFF (W := W) (.some a b h)).toAlgHom
+        (kw_translateFF_toAlgHom_isIntegral_charFree (.some a b h))
+      = placeOfPoint (Q + .some a b h) := by
+  cases Q with
+  | zero =>
+    rw [placeOfPoint_zero]
+    exact kw_restrictAlong_translateFF_infinitePlace_charFree h
+  | some p q hP =>
+    rw [placeOfPoint_some]
+    rcases eq_or_ne p a with rfl | hne
+    · rcases eq_or_ne q b with rfl | hq
+      · exact kw_translAffineSeamAtEqX_charFree h hP
+      · have hqn : q = W.negY p b :=
+          (Affine.Y_eq_of_X_eq hP.1 h.1 rfl).resolve_left hq
+        subst hqn
+        have hβ : kwTISDβ_charFree W p b ≠ 0 := by
+          intro h0
+          exact hq (by simp only [Affine.negY]; simp only [kwTISDβ_charFree] at h0
+                       linear_combination -h0)
+        have hsum : Point.some p (W.negY p b) hP + Point.some p b h = 0 := by
+          have hneg : Point.some p (W.negY p b) hP = -Point.some p b h := by
+            rw [Point.neg_some]
+          rw [hneg]; exact _root_.neg_add_cancel _
+        rw [hsum]
+        refine kw_translAffineSeam_at_of_coordSeamData_charFree h _ 0 ?_
+        exact kw_addXFun_notMem_placeOfEquation_negA_charFree h hβ
+    · rw [Point.add_of_X_ne hne]
+      refine kw_translAffineSeam_at_of_coordSeamData_charFree h _ _ ?_
+      exact ⟨kw_ord_addXFun_sub_addX_pos_charFree W h hP hne,
+        kw_ord_addYFun_sub_addY_pos_charFree W h hP hne⟩
+
+end GenericW
+end Affine
+end WeierstrassCurve
+end
+end
+
+p2m_open "WeierstrassCurve~Affine.genericPoint" in
+p2m_open "WeierstrassCurve.Affine~genericPoint\
+  " in
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_n\
+  onneg~Place.ord_algebraMap~Place.ord_eq_neg_log_of_valuationSubring_eq\
+  " in
+open
+  _root_.P2MW.S_OVERLONG_e431601d.WeierstrassCurve
+  _root_.P2MW.S_OVERLONG_e431601d.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_e431601d.AlgebraicCurve
+  in
+universe u in
+theorem solution
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    {W : WeierstrassCurve.Affine F} [W.IsElliptic]
+    [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [AbelTheorem W]
+    (R : W.Point) :
+    ∃ (τ : W.FunctionField ≃ₐ[F] W.FunctionField) (hτ : τ.toAlgHom.toRingHom.IsIntegral),
+      ∀ Q : W.Point, (placeOfPoint Q).restrictAlong τ.toAlgHom hτ = placeOfPoint (Q + R) := by
+  refine ⟨Point.translateFF (W := W) R, kw_translateFF_toAlgHom_isIntegral_charFree R, fun Q => ?_⟩
+  cases R with
+  | zero =>
+      rw [show (Point.zero : W.Point) = 0 from rfl, add_zero]
+      exact IsogenyEndDatum.restrictAlong_algHomId W (placeOfPoint Q)
+  | some a b h => exact kw_restrictAlong_translateFF_some_placeOfPoint_charFree h Q
+
+end
+end
+end
+end
+end S_OVERLONG_e431601d
+end P2MW
+export P2MW.S_OVERLONG_e431601d (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+universe u
+theorem WeierstrassCurve.Affine.exists_algEquiv_restrictAlong_placeOfPoint_eq_add
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    {W : WeierstrassCurve.Affine F} [W.IsElliptic]
+    [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [AbelTheorem W]
+    (R : W.Point) :
+    ∃ (τ : W.FunctionField ≃ₐ[F] W.FunctionField) (hτ : τ.toAlgHom.toRingHom.IsIntegral),
+      ∀ Q : W.Point, (placeOfPoint Q).restrictAlong τ.toAlgHom hτ = placeOfPoint (Q + R) :=
+  solution R
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_algHom_baseChange_of_isAddCyclic_ker_pointMapOfPushforward.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_algHom_baseChange_of_isAddCyclic_ker_pointMapOfPushforward.lean
new file mode 100644
index 0000000000..8cff80d965
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_algHom_baseChange_of_isAddCyclic_ker_pointMapOfPushforward.lean
@@ -0,0 +1,5231 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.Affine.exists_algHom_baseChange_of_isAddCyclic_ker_pointMapOfPushforward
+(e43a54a4-70bb-5551-8efe-0ba1b5eb4b2c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3e4feffd-4b48-5cc6-aa05-ac80b8acf609
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.Algebra.Algebra.Field
+import Mathlib.Algebra.Polynomial.Basis
+import Mathlib.AlgebraicTopology.FundamentalGroupoid.SimplyConnected
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.Order.CompletePartialOrder
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FunctionFieldQuadratic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AddCommGroup_nonempty_zmod_prod_addEquiv_torsionBy_of_card_torsionBy_eq_sq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_inv
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_isUniformization_toPoint
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_natCard_ker_pointMapOfPushforward_eq_finrankAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsionBy_eq_sq_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_discriminant_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_min_ord_le_ord_add_v2
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Base change of a cyclic kernel of order N
+
+Theorem statement:
+`WeierstrassCurve.Affine.exists_algHom_baseChange_of_isAddCyclic_ker_pointMapOfPushforward`
+(`e43a54a4-70bb-5551-8efe-0ba1b5eb4b2c`), by Claude, 2026-09-05.
+
+Proof: submission `3e4feffd-4b48-5cc6-aa05-ac80b8acf609`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R_0$ be a field and let $E_0,E_0'$ be Weierstrass curves over $R_0$ which are elliptic. Let $F$
+and $F'$ be algebraically closed fields of characteristic $0$, each an $R_0$-algebra, such that the
+base changes of $E_0$ and of $E_0'$ to $F$ and to $F'$ are all elliptic, and assume that each of the
+four base-changed affine curves $W$ carries: a `GenusOnePlaceGate`, i.e. a bijection between
+$W.\mathrm{Point}$ and the places of $W$'s function field over the base field, all of which have
+degree $1$; the centring condition `GenusOnePlaceGate.IsCentred`, i.e. for every nonsingular affine
+point $(x,y)$ the classes of the coordinates $X$ and $Y-y$ lie in the nonunits of the valuation
+subring of the place attached to $(x,y)$; and `AbelTheorem`, i.e. a divisor of degree $0$ is
+principal exactly when its divisor sum vanishes. Let $\sigma : F \to F'$ be an $R_0$-algebra map.
+Let $\iota_0$ be an $F$-algebra map from the function field of $E_0'$ over $F$ to the function field
+of $E_0$ over $F$, with $\iota_0$ integral, finite in the sense that the target is a finite module
+over the source via $\iota_0$, and satisfying the pushforward norm formula for divisors along
+$\iota_0$. Let $N$ be a nonzero natural number, and suppose the kernel of the induced homomorphism
+on points $(E_0\otimes F).\mathrm{Point} \to (E_0'\otimes F).\mathrm{Point}$ — obtained from the
+pushforward of degree-zero divisor classes along $\iota_0$ transported through the genus-one
+identifications of points with $\mathrm{Pic}^0$ — is cyclic as an additive group with
+$\mathrm{Nat.card}$ equal to $N$. Then there exist an $F'$-algebra map $\iota_1$ from the function
+field of $E_0'$ over $F'$ to the function field of $E_0$ over $F'$, a proof that $\iota_1$ is
+integral and a proof that it is finite in the same sense, such that for every proof of the
+pushforward norm formula along $\iota_1$ the corresponding kernel on points is cyclic with
+$\mathrm{Nat.card}$ equal to $N$.
+
+This is the Lefschetz-principle style transfer of a cyclic degree-$N$ function-field correspondence
+between two elliptic curves from one algebraically closed field of characteristic zero to another
+over the same base field. It is used in the step deducing that the $j$-invariants of the two curves
+satisfy the modular polynomial of level $N$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_exists_algHom_baseChange_of_isAddCyclic_ker_pointMapOfPushforward.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 25600000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_c68ce07f
+
+
+noncomputable section
+
+section
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial IsDedekindDomain \
+  P2MW.S_OVERLONG_c68ce07f.\
+  IsDedekindDomain WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial.Bivariate"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem S13_ofHeightOneSpectrum_injective {R : Type*} [CommRing R] [IsDedekindDomain R]
+    [Algebra R W.FunctionField] [IsFractionRing R W.FunctionField] [Algebra F R]
+    [IsScalarTower F R W.FunctionField] :
+    Function.Injective (AlgebraicCurve.Place.ofHeightOneSpectrum (K := F) (R := R) (F :=
+      W.FunctionField)) := by
+  intro w₁ w₂ h
+  refine HeightOneSpectrum.eq_of_valuation_isEquiv_valuation (K := W.FunctionField) ?_
+  rw [Valuation.isEquiv_iff_valuationSubring]
+  exact congrArg AlgebraicCurve.Place.toValuationSubring h
+
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "XYIdeal quotientXYIdealEquiv XClass_ne_zero \
+  YClass mk map basis_apply map_injective map_mk exists_smul_basis_eq XClass smul_basis_mul_Y \
+  YClass_ne_zero isDedekindDomain exists_eq_XYIdeal XYIdeal_isMaximal XYIdeal_ne_bot"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt"
+
+theorem algebraMap_eq_mk_C_C (a : F) :
+    algebraMap F W.CoordinateRing a = CoordinateRing.mk W (C (C a)) := by
+  rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+    Algebra.algebraMap_self_apply]
+  rfl
+
+theorem eq_of_XYIdeal_eq {x₁ y₁ x₂ y₂ : F} (h₂ : W.Equation x₂ y₂)
+    (h : XYIdeal W x₁ (C y₁) = XYIdeal W x₂ (C y₂)) : x₁ = x₂ ∧ y₁ = y₂ := by
+  have hne : XYIdeal W x₂ (C y₂) ≠ ⊤ := (XYIdeal_isMaximal h₂).ne_top
+  have hX₁ : XClass W x₁ ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert _ _)
+  have hX₂ : XClass W x₂ ∈ XYIdeal W x₂ (C y₂) := Ideal.subset_span (Set.mem_insert _ _)
+  have hY₁ : YClass W (C y₁) ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  have hY₂ : YClass W (C y₂) ∈ XYIdeal W x₂ (C y₂) :=
+    Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  constructor
+  · by_contra hx
+    apply hne
+    have hsub : XClass W x₁ - XClass W x₂ = algebraMap F W.CoordinateRing (x₂ - x₁) := by
+      rw [XClass, XClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      rw [← map_sub]
+      congr 1
+      rw [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hX₁ hX₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hx hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+  · by_contra hy
+    apply hne
+    have hsub : YClass W (C y₁) - YClass W (C y₂) = algebraMap F W.CoordinateRing (y₂ - y₁) := by
+      rw [YClass, YClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      simp only [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hY₁ hY₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hy hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+
+def heightOneSpectrumOfEquation {x y : F} (h : W.Equation x y) :
+    HeightOneSpectrum W.CoordinateRing where
+  asIdeal := XYIdeal W x (C y)
+  isPrime := (XYIdeal_isMaximal h).isPrime
+  ne_bot := XYIdeal_ne_bot x (C y)
+
+@[scoped simp]
+theorem heightOneSpectrumOfEquation_asIdeal {x y : F} (h : W.Equation x y) :
+    (heightOneSpectrumOfEquation h).asIdeal = XYIdeal W x (C y) := rfl
+
+theorem exists_sub_algebraMap_mem {x y : F} (h : W.Equation x y) (r : W.CoordinateRing) :
+    ∃ c : F, r - algebraMap F W.CoordinateRing c ∈ XYIdeal W x (C y) := by
+  set e := quotientXYIdealEquiv (W' := W) (x := x) (y := C y) h
+  refine ⟨e (Ideal.Quotient.mk _ r), ?_⟩
+  rw [← Ideal.Quotient.eq_zero_iff_mem, map_sub, sub_eq_zero]
+  apply e.injective
+  rw [← Ideal.Quotient.algebraMap_eq, ← IsScalarTower.algebraMap_apply, AlgEquiv.commutes,
+    Algebra.algebraMap_self_apply]
+
+end CoordinateRing
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine.CoordinateRing"
+
+def IsFinitePlace (v : AlgebraicCurve.Place F W.FunctionField) : Prop :=
+  ∀ r : W.CoordinateRing, algebraMap W.CoordinateRing W.FunctionField r ∈ v.toValuationSubring
+
+def IsFinitePlace.ringHom {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    W.CoordinateRing →+* v.toValuationSubring where
+  toFun r := ⟨algebraMap W.CoordinateRing W.FunctionField r, hv r⟩
+  map_one' := Subtype.ext (map_one _)
+  map_mul' a b := Subtype.ext (map_mul _ a b)
+  map_zero' := Subtype.ext (map_zero _)
+  map_add' a b := Subtype.ext (map_add _ a b)
+
+@[scoped simp]
+theorem IsFinitePlace.coe_ringHom_apply {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) (r : W.CoordinateRing) :
+    (hv.ringHom r : W.FunctionField) = algebraMap W.CoordinateRing W.FunctionField r := rfl
+
+
+def IsFinitePlace.centre {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    Ideal W.CoordinateRing :=
+  (IsLocalRing.maximalIdeal v.toValuationSubring).comap hv.ringHom
+
+theorem IsFinitePlace.centre_isPrime {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre.IsPrime :=
+  Ideal.IsPrime.comap _
+
+theorem IsFinitePlace.inv_mem {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) {r : W.CoordinateRing} (hr : r ∉ hv.centre) :
+    (algebraMap W.CoordinateRing W.FunctionField r)⁻¹ ∈ v.toValuationSubring := by
+  have hunit : IsUnit (hv.ringHom r) := by
+    rw [IsFinitePlace.centre, Ideal.mem_comap, IsLocalRing.mem_maximalIdeal,
+      mem_nonunits_iff, not_not] at hr
+    exact hr
+  obtain ⟨t, ht⟩ := hunit.exists_right_inv
+  have ht' : algebraMap W.CoordinateRing W.FunctionField r * (t : W.FunctionField) = 1 := by
+    have := congrArg (fun a : v.toValuationSubring => (a : W.FunctionField)) ht
+    simpa using this
+  rw [inv_eq_of_mul_eq_one_right ht']
+  exact t.2
+
+theorem IsFinitePlace.centre_ne_bot {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre ≠ ⊥ := by
+  intro hbot
+  apply v.ne_top'
+  rw [eq_top_iff]
+  rintro z -
+  obtain ⟨r, s, hs, hz⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  have hs0 : s ∉ hv.centre := by
+    rw [hbot, Ideal.mem_bot]
+    exact fun h => nonZeroDivisors.ne_zero hs h
+  rw [← hz, div_eq_mul_inv]
+  exact mul_mem (hv r) (hv.inv_mem hs0)
+
+variable [IsDedekindDomain W.CoordinateRing]
+
+def placeOfEquation {x y : F} (h : W.Equation x y) :
+    AlgebraicCurve.Place F W.FunctionField :=
+  AlgebraicCurve.Place.ofHeightOneSpectrum (heightOneSpectrumOfEquation h)
+
+theorem placeOfEquation_injective {x₁ y₁ x₂ y₂ : F} (h₁ : W.Equation x₁ y₁)
+    (h₂ : W.Equation x₂ y₂) (h : placeOfEquation h₁ = placeOfEquation h₂) :
+    x₁ = x₂ ∧ y₁ = y₂ :=
+  eq_of_XYIdeal_eq h₂
+    (congrArg HeightOneSpectrum.asIdeal (S13_ofHeightOneSpectrum_injective h))
+
+theorem isFinitePlace_placeOfEquation {x y : F} (h : W.Equation x y) :
+    IsFinitePlace (placeOfEquation h) := fun r =>
+  (heightOneSpectrumOfEquation h).valuation_le_one r
+
+theorem isFinitePlace_iff_exists_placeOfEquation [IsAlgClosed F]
+    (v : AlgebraicCurve.Place F W.FunctionField) :
+    IsFinitePlace v ↔ ∃ (x y : F) (h : W.Equation x y), v = placeOfEquation h := by
+  constructor
+  · intro hv
+    have := hv.centre_isPrime
+    have hmax : hv.centre.IsMaximal := Ideal.IsPrime.isMaximal hv.centre_isPrime hv.centre_ne_bot
+    obtain ⟨x, y, hxy, hXY⟩ :=
+      CoordinateRing.exists_eq_XYIdeal (W := W) (P := hv.centre) hv.centre_ne_bot
+    refine ⟨x, y, hxy, ?_⟩
+    set w : HeightOneSpectrum W.CoordinateRing := heightOneSpectrumOfEquation hxy with hw
+    set A : ValuationSubring W.FunctionField :=
+      HeightOneSpectrum.valuationSubringAtPrime W.FunctionField w with hA
+    have hAded : IsDedekindDomain A := by rw [hA]; infer_instance
+    have hle : A ≤ v.toValuationSubring := by
+      intro z hz
+      rw [hA] at hz
+      obtain ⟨r, s, hs, rfl⟩ := hz
+      have hs' : s ∉ hv.centre := by
+        intro hmem
+        rw [hXY] at hmem
+        exact hs hmem
+      exact mul_mem (hv r) (hv.inv_mem hs')
+    have hSP : A.ofPrime (A.idealOfLE v.toValuationSubring hle) = v.toValuationSubring :=
+      ValuationSubring.ofPrime_idealOfLE A v.toValuationSubring hle
+    rcases eq_or_ne (A.idealOfLE v.toValuationSubring hle) ⊥ with hP | hP
+    · exfalso
+      apply v.ne_top'
+      have h2 : A.ofPrime ⊥ ≤ A.ofPrime (A.idealOfLE v.toValuationSubring hle) :=
+        ValuationSubring.ofPrime_le_of_le (h := hP.le)
+      rw [ValuationSubring.ofPrime_bot] at h2
+      exact top_le_iff.mp (le_trans h2 hSP.le)
+    · have hPmax : (A.idealOfLE v.toValuationSubring hle).IsMaximal :=
+        Ideal.IsPrime.isMaximal inferInstance hP
+      have hPeq : A.idealOfLE v.toValuationSubring hle = IsLocalRing.maximalIdeal A :=
+        IsLocalRing.eq_maximalIdeal hPmax
+      have h3 : A.ofPrime (A.idealOfLE v.toValuationSubring hle)
+          = A.ofPrime (IsLocalRing.maximalIdeal A) :=
+        le_antisymm (ValuationSubring.ofPrime_le_of_le (h := hPeq.ge))
+          (ValuationSubring.ofPrime_le_of_le (h := hPeq.le))
+      rw [ValuationSubring.ofPrime_top] at h3
+      have hAv : A = v.toValuationSubring := h3.symm.trans hSP
+      refine (AlgebraicCurve.Place.ext ?_).symm
+      change (AlgebraicCurve.Place.ofHeightOneSpectrum w).toValuationSubring = v.toValuationSubring
+      rw [AlgebraicCurve.Place.ofHeightOneSpectrum_toValuationSubring,
+        ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact hAv
+  · rintro ⟨x, y, h, rfl⟩
+    exact isFinitePlace_placeOfEquation h
+
+scoped instance S13_instIsDedekindDomainCoordinateRing [IsAlgClosed F] [W.IsElliptic] :
+    IsDedekindDomain W.CoordinateRing :=
+  CoordinateRing.isDedekindDomain (W := W)
+
+section CentredGate
+
+variable [DecidableEq F] [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W]
+
+omit [DecidableEq F] in
+@[scoped simp]
+theorem placeOfPoint_some {x y : F} (h : W.Nonsingular x y) :
+    placeOfPoint (.some x y h) = placeOfEquation h.left := by
+  classical
+  exact
+    placeOfPoint_some_eq_ofHeightOneSpectrum h (heightOneSpectrumOfEquation h.left) rfl
+
+namespace InfinitePlace
+
+def place : AlgebraicCurve.Place F W.FunctionField := placeOfPoint (0 : W.Point)
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+private theorem _root_.WeierstrassCurve.Affine.InfinitePlace.deg_eq_one :
+    (place : AlgebraicCurve.Place F W.FunctionField).deg = 1 := by
+  classical
+  exact
+    deg_placeOfPoint (W := W) 0
+
+p2m_export "WeierstrassCurve.Affine.InfinitePlace" "deg_eq_one"
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] in
+theorem not_isFinitePlace [IsAlgClosed F] [W.IsElliptic] :
+    ¬ IsFinitePlace (place : AlgebraicCurve.Place F W.FunctionField) := by
+  classical
+  exact
+    fun h =>
+     algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero (W := W) (h _)
+
+omit [DecidableEq F] in
+theorem eq_of_not_isFinitePlace
+    (v : AlgebraicCurve.Place F W.FunctionField) (hv : ¬ IsFinitePlace v) :
+    v = place := by
+  classical
+  obtain ⟨P, rfl⟩ : ∃ P : W.Point, placeOfPoint P = v :=
+    ⟨(pointEquivPlace (W := W)).symm v, (pointEquivPlace (W := W)).apply_symm_apply v⟩
+  cases P with
+  | zero => rfl
+  | some x y h =>
+      exact absurd (placeOfPoint_some (W := W) h ▸ isFinitePlace_placeOfEquation h.left) hv
+
+end InfinitePlace
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+@[scoped simp]
+theorem placeOfPoint_zero : placeOfPoint (.zero : W.Point) = InfinitePlace.place := by
+  classical
+  exact
+    rfl
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_zero' : placeOfPoint (0 : W.Point) = InfinitePlace.place := by
+  classical
+  exact
+    rfl
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_injective : Function.Injective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).injective
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_surjective (_hΔ : W.Δ ≠ 0) : Function.Surjective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).surjective
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_surjective' : Function.Surjective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).surjective
+
+end CentredGate
+end Affine
+end WeierstrassCurve
+end
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+end WeierstrassCurve
+p2m_open_scoped "WeierstrassCurve" in
+theorem WeierstrassCurve.nonempty_pointTorsionBy_zmod {K : Type*} [Field K] [DecidableEq K]
+    [IsAlgClosed K] [CharZero K]
+    (W : WeierstrassCurve K) [W.IsElliptic] {n : ℕ} (hn : 1 ≤ n) :
+    Nonempty (↥(Submodule.torsionBy ℤ W.toAffine.Point (n : ℤ)) ≃+ (Fin 2 → ZMod n)) := by
+  obtain ⟨e⟩ := AddCommGroup.nonempty_zmod_prod_addEquiv_torsionBy_of_card_torsionBy_eq_sq
+    (A := W.toAffine.Point) (n := n) (by omega)
+    (fun d hd => WeierstrassCurve.card_torsionBy_eq_sq_of_isAlgClosed W (n := d)
+      (by exact_mod_cast (Nat.pos_of_dvd_of_pos hd (by omega)).ne'))
+  exact ⟨e.symm.trans (LinearEquiv.piFinTwo ℤ (fun _ : Fin 2 => ZMod n)).toAddEquiv.symm⟩
+
+section
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve"
+
+scoped instance instHasPrincipalDivisorsFunctionField_s13 {F : Type*} [Field F] [CharZero F]
+    {W : Affine F} : HasPrincipalDivisors F W.FunctionField :=
+  hasPrincipalDivisors_functionField W
+
+section AutoNorm
+variable {F : Type*} [Field F] [CharZero F]
+variable {V W : Affine F} [V.IsElliptic] [W.IsElliptic]
+
+omit [WeierstrassCurve.IsElliptic V] [WeierstrassCurve.IsElliptic W] in
+theorem normFormulaAlong_of_elliptic (ι : V.FunctionField →ₐ[F] W.FunctionField)
+    (hfin : FiniteAlong F ι) : NormFormulaAlong F ι hfin := by
+  classical
+  have : HasPrincipalDivisors F W.FunctionField := hasPrincipalDivisors_functionField W
+  have : CharZero V.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap F V.FunctionField).injective
+  have hsep : SeparableAlong F ι := by
+    let := algebraAlong ι
+    have := isScalarTower_along ι
+    have : Module.Finite V.FunctionField W.FunctionField := hfin
+    change Algebra.IsSeparable V.FunctionField W.FunctionField
+    infer_instance
+  exact AlgebraicCurve.normFormulaAlong ι hfin hsep
+
+end AutoNorm
+
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι"
+p2m_open "WeierstrassCurve.Affine.IsogenyEndDatum"
+
+variable {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [GenusOnePlaceGate W] [AbelTheorem W]
+
+omit [DecidableEq F] [W.GenusOnePlaceGate] [W.AbelTheorem] in
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+private theorem _root_.WeierstrassCurve.Affine.IsogenyEndDatum.normFormulaAlong_auto (D :
+  IsogenyEndDatum W) :
+    NormFormulaAlong F D.ι D.hfin :=
+  normFormulaAlong_of_elliptic D.ι D.hfin
+
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "normFormulaAlong_auto"
+
+private def _root_.WeierstrassCurve.Affine.IsogenyEndDatum.pointEnd' (D : IsogenyEndDatum W) :
+    AddMonoid.End W.Point := D.pointEnd D.normFormulaAlong_auto
+
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd'"
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd_eq_pointEnd' (D : IsogenyEndDatum W) (hN : NormFormulaAlong F D.ι D.hfin) :
+    D.pointEnd hN = D.pointEnd' := rfl
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd'_apply (D : IsogenyEndDatum W) (P : W.Point) :
+    D.pointEnd' P = genusOnePic0Equiv W
+      (Pic0.pushforwardAlongHom D.ι D.hι D.hfin D.normFormulaAlong_auto (pointClass P)) :=
+  pointEnd_apply D _ P
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd'_eq_of_seam (D : IsogenyEndDatum W) (g : W.Point → W.Point) (hg0 : g 0 = 0)
+    (hg : ∀ P, (placeOfPoint P).restrictAlong D.ι D.hι = placeOfPoint (g P)) (P : W.Point) :
+    D.pointEnd' P = g P :=
+  pointEnd_eq_of_seam D _ g hg0 hg P
+
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+end
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+end Affine
+end WeierstrassCurve
+p2m_open_scoped "WeierstrassCurve WeierstrassCurve.Affine" in
+scoped instance WeierstrassCurve.Affine.instHasPrincipalDivisorsFunctionField_s13e2
+    {F : Type*} [Field F] [CharZero F] (W : WeierstrassCurve.Affine F) :
+    AlgebraicCurve.HasPrincipalDivisors F W.FunctionField :=
+  WeierstrassCurve.Affine.hasPrincipalDivisors_functionField W
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg"
+
+section MoreSinglePlace
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.isRational_of_deg_eq_one (h : v.deg = 1) :
+    v.IsRational := by
+  intro x
+  have hbot : (⊥ : Subalgebra K v.ResidueField) = ⊤ :=
+    Subalgebra.bot_eq_top_iff_finrank_eq_one.mpr h
+  have hx : x ∈ (⊥ : Subalgebra K v.ResidueField) := by
+    rw [hbot]
+    exact Algebra.mem_top
+  exact Algebra.mem_bot.mp hx
+
+p2m_export "AlgebraicCurve.Place" "isRational_of_deg_eq_one"
+
+theorem evalAt_div (hv : v.IsRational) {f g : F} (hf : f ∈ v.toValuationSubring)
+    (hg : g ≠ 0) (hg0 : v.ord g = 0) :
+    v.evalAt (f / g) = v.evalAt f / v.evalAt g := by
+  have hginv : g⁻¹ ∈ v.toValuationSubring :=
+    AlgebraicCurve.Place.mem_of_ord_nonneg v (inv_ne_zero hg) (by
+      rw [v.ord_inv, hg0]; exact neg_nonneg.mpr le_rfl)
+  rw [div_eq_mul_inv, v.evalAt_mul hv hf hginv, v.evalAt_inv hv hg hg0, div_eq_mul_inv]
+
+end MoreSinglePlace
+
+theorem mem_restrictAlong_iff {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F]
+    [Algebra K F']
+    (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') (f : F) :
+    f ∈ (w.restrictAlong φ hφ).toValuationSubring ↔ φ f ∈ w.toValuationSubring :=
+  Iff.rfl
+
+end Place
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial.Bivariate"
+
+section FinitePlaceOfMem
+variable {F : Type*} [Field F] {W : Affine F}
+variable (v : AlgebraicCurve.Place F W.FunctionField)
+
+theorem isFinitePlace_of_mem
+    (hx : polyToFunctionField W X ∈ v.toValuationSubring) : IsFinitePlace v := by
+  have hpoly : ∀ p : F[X], polyToFunctionField W p ∈ v.toValuationSubring := by
+    intro p
+    induction p using Polynomial.induction_on' with
+    | add f g hf hg => rw [map_add]; exact add_mem hf hg
+    | monomial n c =>
+        rw [← C_mul_X_pow_eq_monomial, map_mul, map_pow]
+        refine mul_mem ?_ (pow_mem hx n)
+        rw [polyToFunctionField_C]
+        exact v.algebraMap_mem' c
+  set η := algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) with hηdef
+  set c₁ : F[X] := C W.a₁ * X + C W.a₃ with hc₁def
+  set cb : F[X] := X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ with hcbdef
+  have hrel : η * η = polyToFunctionField W cb - polyToFunctionField W c₁ * η := by
+    have h1 := smul_basis_mul_Y (W' := W) 0 1
+    rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at h1
+    have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) h1
+    rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+    exact h2
+  have hy : η ∈ v.toValuationSubring := by
+    refine v.mem_of_eval_monic_eq_zero (P := Polynomial.X ^ 2
+      + (Polynomial.C (polyToFunctionField W c₁) * Polynomial.X
+        - Polynomial.C (polyToFunctionField W cb))) ?_ ?_ (x := η) ?_
+    · refine Polynomial.monic_X_pow_add (n := 2) ?_
+      rw [sub_eq_add_neg, ← Polynomial.C_neg]
+      refine lt_of_le_of_lt Polynomial.degree_linear_le ?_
+      exact_mod_cast Nat.one_lt_two
+    · intro i
+      rw [show (Polynomial.C (polyToFunctionField W c₁) * Polynomial.X : Polynomial _)
+          = Polynomial.C (polyToFunctionField W c₁) * Polynomial.X ^ 1 by ring]
+      simp only [Polynomial.coeff_add, Polynomial.coeff_sub, Polynomial.coeff_X_pow,
+        Polynomial.coeff_C_mul, Polynomial.coeff_C]
+      refine add_mem ?_ (sub_mem ?_ ?_)
+      · split <;> simp [v.toValuationSubring.one_mem, v.toValuationSubring.zero_mem]
+      · split
+        · rw [mul_one]; exact hpoly _
+        · rw [mul_zero]; exact v.toValuationSubring.zero_mem
+      · split
+        · exact hpoly _
+        · exact v.toValuationSubring.zero_mem
+    · simp only [Polynomial.eval_add, Polynomial.eval_sub, Polynomial.eval_pow,
+        Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_X]
+      rw [sq]
+      linear_combination hrel
+  intro r
+  obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq r
+  rw [algebraMap_smul_basis]
+  exact add_mem (hpoly p) (mul_mem (hpoly q) hy)
+
+end FinitePlaceOfMem
+
+section RationalPlaceOfEquation
+variable {F : Type*} [Field F] {W : Affine F} [W.IsElliptic]
+  [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [IsDedekindDomain W.CoordinateRing]
+
+theorem isRational_placeOfEquation {r s : F} (hrs : W.Equation r s) :
+    (placeOfEquation hrs).IsRational := by
+  classical
+  apply (placeOfEquation hrs).isRational_of_deg_eq_one
+  rw [← placeOfPoint_some (equation_iff_nonsingular.mp hrs)]
+  exact GenusOnePlaceGate.deg_eq_one _
+
+end RationalPlaceOfEquation
+end Affine
+end WeierstrassCurve
+
+namespace ModularCurve
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg\
+  " in
+open _root_.WeierstrassCurve
+  _root_.P2MW.S_OVERLONG_c68ce07f.WeierstrassCurve
+  _root_.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_c68ce07f.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_c68ce07f.AlgebraicCurve
+  in
+theorem kw_fdn2_qephod_hend7_pmopKerCard_proved
+    (K : Type*) [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+    (E E' : WeierstrassCurve.Affine K) [E.IsElliptic]
+    [GenusOnePlaceGate E] [GenusOnePlaceGate.IsCentred E] [AbelTheorem E]
+    [E'.IsElliptic] [GenusOnePlaceGate E'] [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong K ι) :
+    Nat.card ((pointMapOfPushforward ι hι hfin
+      (normFormulaAlong_of_elliptic ι hfin)).ker) = finrankAlong K ι :=
+  natCard_ker_pointMapOfPushforward_eq_finrankAlong E E' ι hι hfin _
+end ModularCurve
+
+
+section
+open Complex Filter Set
+
+p2m_open_scoped "PeriodPair \
+  P2MW.S_OVERLONG_c68ce07f.\
+  PeriodPair"
+
+namespace PeriodPair
+p2m_export "PeriodPair" "derivWeierstrassP_neg weierstrassP_neg lattice weierstrassP_add_coe \
+  lattice_eq_span_range_basis ω₁ mk g₃ ω₂ derivWeierstrassP_add_coe mem_lattice G g₂ \
+  weierstrassCurve weierstrassCurve_a₁ weierstrassCurve_a₃ DiscriminantNeZero toPoint \
+  toPoint_of_mem toPoint_zero toPoint_of_notMem IsUniformization jLattice scale_indep scale \
+  discriminant_ne_zero isUniformization_toPoint"
+p2m_open "PeriodPair"
+
+variable (L : PeriodPair)
+
+private theorem _root_.PeriodPair.kw_discriminantNeZero :
+    L.DiscriminantNeZero := L.discriminant_ne_zero
+
+p2m_export "PeriodPair" "kw_discriminantNeZero"
+
+private theorem _root_.PeriodPair.kw_isUniformization :
+    L.IsUniformization L.kw_discriminantNeZero :=
+  L.isUniformization_toPoint _
+
+p2m_export "PeriodPair" "kw_isUniformization"
+
+private theorem _root_.PeriodPair.kw_toPoint_add (hD : L.DiscriminantNeZero) (z w : ℂ) :
+    L.toPoint hD (z + w) = L.toPoint hD z + L.toPoint hD w :=
+  (L.isUniformization_toPoint hD).1 z w
+
+p2m_export "PeriodPair" "kw_toPoint_add"
+
+theorem kw_toPoint_surjective (hD : L.DiscriminantNeZero) : Function.Surjective (L.toPoint hD) :=
+  (L.isUniformization_toPoint hD).2.1
+
+theorem kw_toPoint_eq_zero_iff (hD : L.DiscriminantNeZero) (z : ℂ) :
+    L.toPoint hD z = 0 ↔ z ∈ L.lattice :=
+  ⟨(L.isUniformization_toPoint hD).2.2 z, fun hz => L.toPoint_of_mem hD hz⟩
+
+scoped instance kw_instIsElliptic : L.weierstrassCurve.IsElliptic :=
+  ⟨isUnit_iff_ne_zero.mpr L.kw_discriminantNeZero.weierstrassCurve_Δ_ne_zero⟩
+
+section Liouville
+
+private theorem _root_.PeriodPair.sub_fract_mem_lattice (z : ℂ) :
+    z - ZSpan.fract L.basis z ∈ L.lattice := by
+  rw [L.lattice_eq_span_range_basis]
+  have h := (ZSpan.fract_eq_fract L.basis (ZSpan.fract L.basis z) z).mp
+    (by rw [ZSpan.fract_eq_self.mpr (ZSpan.fract_mem_fundamentalDomain L.basis z)])
+  simpa [neg_add_eq_sub] using h
+
+p2m_export "PeriodPair" "sub_fract_mem_lattice"
+
+private theorem _root_.PeriodPair.apply_eq_apply_of_differentiable_of_forall_periodic {f : ℂ → ℂ}
+    (hf : Differentiable ℂ f) (hper : ∀ l ∈ L.lattice, ∀ z, f (z + l) = f z) (z w : ℂ) :
+    f z = f w := by
+  apply hf.apply_eq_apply_of_bounded
+  have hrange : range f ⊆ f '' closure (ZSpan.fundamentalDomain L.basis) := by
+    rintro - ⟨u, rfl⟩
+    refine ⟨ZSpan.fract L.basis u, subset_closure (ZSpan.fract_mem_fundamentalDomain _ u), ?_⟩
+    have h := hper _ (L.sub_fract_mem_lattice u) (ZSpan.fract L.basis u)
+    rw [add_sub_cancel] at h
+    exact h.symm
+  refine Bornology.IsBounded.subset ?_ hrange
+  refine (IsCompact.image ?_ hf.continuous).isBounded
+  exact Metric.isCompact_of_isClosed_isBounded isClosed_closure
+    (ZSpan.fundamentalDomain_isBounded L.basis).closure
+
+p2m_export "PeriodPair" "apply_eq_apply_of_differentiable_of_forall_periodic"
+end Liouville
+
+section ToPointLemmas
+
+theorem toPoint_add_mem (h : L.DiscriminantNeZero) (z : ℂ) {l : ℂ} (hl : l ∈ L.lattice) :
+    L.toPoint h (z + l) = L.toPoint h z := by
+  by_cases hz : z ∈ L.lattice
+  · rw [L.toPoint_of_mem h hz, L.toPoint_of_mem h (add_mem hz hl)]
+  · have hzl : z + l ∉ L.lattice := fun hmem => hz (by simpa using sub_mem hmem hl)
+    rw [L.toPoint_of_notMem h hz, L.toPoint_of_notMem h hzl]
+    have hP : ℘[L] (z + l) = ℘[L] z := L.weierstrassP_add_coe z ⟨l, hl⟩
+    have hP' : ℘'[L] (z + l) = ℘'[L] z := L.derivWeierstrassP_add_coe z ⟨l, hl⟩
+    simp only [WeierstrassCurve.Affine.Point.some.injEq]
+    exact ⟨hP, by rw [hP']⟩
+
+theorem toPoint_neg (h : L.DiscriminantNeZero) (z : ℂ) :
+    L.toPoint h (-z) = -L.toPoint h z := by
+  by_cases hz : z ∈ L.lattice
+  · rw [L.toPoint_of_mem h hz, L.toPoint_of_mem h (neg_mem hz)]; rfl
+  · have hnz : -z ∉ L.lattice := fun hmem => hz (by simpa using neg_mem hmem)
+    rw [L.toPoint_of_notMem h hz, L.toPoint_of_notMem h hnz,
+      WeierstrassCurve.Affine.Point.neg_some]
+    simp only [WeierstrassCurve.Affine.Point.some.injEq]
+    refine ⟨L.weierstrassP_neg z, ?_⟩
+    rw [L.derivWeierstrassP_neg]
+    show -℘'[L] z / 2 = L.weierstrassCurve.toAffine.negY (℘[L] z) (℘'[L] z / 2)
+    rw [WeierstrassCurve.Affine.negY, weierstrassCurve_a₁, weierstrassCurve_a₃]
+    ring
+
+end ToPointLemmas
+
+section Isogeny
+
+private theorem _root_.PeriodPair.apply_eq_apply_of_continuous_of_mapsTo_lattice {f : ℂ → ℂ}
+    (hf : Continuous f)
+    (hmem : ∀ z, f z ∈ L.lattice) (z w : ℂ) : f z = f w := by
+  refine IsPreconnected.constant_of_mapsTo (isPreconnected_univ) ?_
+    hf.continuousOn (fun u _ => hmem u) (mem_univ z) (mem_univ w)
+  rw [isDiscrete_iff_discreteTopology]
+  exact inferInstanceAs (DiscreteTopology L.lattice)
+
+p2m_export "PeriodPair" "apply_eq_apply_of_continuous_of_mapsTo_lattice"
+
+theorem exists_smul_mem_and_apply_eq_of_forall_sub_mem (L' : PeriodPair) {F : ℂ → ℂ}
+    (hF : Differentiable ℂ F)
+    (hper : ∀ l ∈ L.lattice, ∀ z, F (z + l) - F z ∈ L'.lattice) :
+    ∃ α : ℂ, (∀ l ∈ L.lattice, α * l ∈ L'.lattice) ∧ ∀ z, F z = F 0 + α * z := by
+  have hFc : Continuous F := hF.continuous
+  have hconst : ∀ l ∈ L.lattice, ∀ z, F (z + l) - F z = F l - F 0 := by
+    intro l hl z
+    have h := L'.apply_eq_apply_of_continuous_of_mapsTo_lattice
+      (f := fun u => F (u + l) - F u)
+      ((hFc.comp (continuous_id.add continuous_const)).sub hFc) (hper l hl) z 0
+    simpa using h
+  have hadd : ∀ z w, F (z + w) = F z + F w - F 0 := by
+    intro z w
+    have hper' : ∀ l ∈ L.lattice, ∀ u,
+        (fun u => F (u + w) - F u) (u + l) = (fun u => F (u + w) - F u) u := by
+      intro l hl u
+      have h1 := hconst l hl (u + w)
+      have h2 := hconst l hl u
+      rw [show u + w + l = u + l + w by ring] at h1
+      simp only
+      linear_combination h1 - h2
+    have h := L.apply_eq_apply_of_differentiable_of_forall_periodic
+      (f := fun u => F (u + w) - F u)
+      ((hF.comp (differentiable_id.add_const w)).sub hF) hper' z 0
+    simp only [zero_add] at h
+    linear_combination h
+  set α : ℂ := deriv F 0 with hα
+  have hderiv : ∀ z, deriv F z = α := by
+    intro z
+    have hfun : (fun w => F (z + w)) = fun w => F w + (F z - F 0) := by
+      funext w
+      rw [hadd z w]; ring
+    have h1 : deriv (fun w => F (z + w)) 0 = deriv F z := by
+      rw [deriv_comp_const_add]
+      simp
+    have h2 : deriv (fun w => F w + (F z - F 0)) 0 = deriv F 0 := by
+      rw [deriv_add_const]
+    rw [← h1, hfun, h2]
+  have haffine : ∀ z, F z = F 0 + α * z := by
+    have hG : Differentiable ℂ fun z => F z - α * z :=
+      hF.sub (differentiable_id.const_mul α)
+    have hG' : ∀ z, deriv (fun z => F z - α * z) z = 0 := by
+      intro z
+      have hd : HasDerivAt (fun z => F z - α * z) (deriv F z - α * 1) z :=
+        (hF z).hasDerivAt.sub ((hasDerivAt_id z).const_mul α)
+      rw [hd.deriv, hderiv z]
+      ring
+    intro z
+    have h := is_const_of_deriv_eq_zero hG hG' z 0
+    simp only [mul_zero, sub_zero] at h
+    linear_combination h
+  refine ⟨α, fun l hl => ?_, haffine⟩
+  have h := hper l hl 0
+  rw [zero_add, haffine l] at h
+  simpa using h
+
+end Isogeny
+
+section Scale
+
+variable (α : ℂˣ)
+
+private def mulLeftR (a : ℂ) : ℂ →ₗ[ℝ] ℂ := Algebra.lmul ℝ ℂ a
+
+@[scoped simp] private theorem mulLeftR_apply (a z : ℂ) : mulLeftR a z = a * z := rfl
+
+private theorem mulLeftR_injective {a : ℂ} (ha : a ≠ 0) :
+    Function.Injective (mulLeftR a) := fun _ _ h => by
+  simpa using mul_left_cancel₀ ha h
+
+private def mulLeftZ (a : ℂ) : ℂ →ₗ[ℤ] ℂ := (mulLeftR a).restrictScalars ℤ
+
+@[scoped simp] private theorem mulLeftZ_apply (a z : ℂ) : mulLeftZ a z = a * z := rfl
+
+private theorem _root_.PeriodPair.scale_lattice :
+    (L.scale α).lattice = Submodule.map (mulLeftZ (α : ℂ)) L.lattice := by
+  unfold lattice scale
+  rw [Submodule.map_span]
+  congr 1
+  ext z
+  simp only [Set.mem_insert_iff, Set.mem_singleton_iff, Set.mem_image, mulLeftZ_apply]
+  constructor
+  · rintro (rfl | rfl)
+    · exact ⟨L.ω₁, Or.inl rfl, rfl⟩
+    · exact ⟨L.ω₂, Or.inr rfl, rfl⟩
+  · rintro ⟨w, hw | hw, rfl⟩ <;> simp [hw]
+
+p2m_export "PeriodPair" "scale_lattice"
+theorem mem_scale_lattice_iff {z : ℂ} :
+    z ∈ (L.scale α).lattice ↔ ∃ l ∈ L.lattice, z = (α : ℂ) * l := by
+  rw [scale_lattice, Submodule.mem_map]; simp only [mulLeftZ_apply]; tauto
+
+private def _root_.PeriodPair.scaleLatticeEquiv : L.lattice ≃ₗ[ℤ] (L.scale α).lattice :=
+  (Submodule.equivMapOfInjective (mulLeftZ (α : ℂ))
+    (fun _ _ h => mul_left_cancel₀ α.ne_zero (by simpa using h)) L.lattice).trans
+    (LinearEquiv.ofEq _ _ (L.scale_lattice α).symm)
+
+p2m_export "PeriodPair" "scaleLatticeEquiv"
+@[scoped simp] theorem scaleLatticeEquiv_apply (l : L.lattice) :
+    ((L.scaleLatticeEquiv α l : (L.scale α).lattice) : ℂ) = (α : ℂ) * (l : ℂ) := rfl
+
+end Scale
+
+section Homogeneity
+
+variable (α : ℂˣ)
+
+theorem G_scale (n : ℕ) : (L.scale α).G n = ((α : ℂ) ^ n)⁻¹ * L.G n := by
+  unfold G
+  rw [← (L.scaleLatticeEquiv α).toEquiv.tsum_eq]
+  simp only [LinearEquiv.coe_toEquiv, scaleLatticeEquiv_apply, mul_pow, mul_inv]
+  exact tsum_mul_left
+
+theorem g₂_scale : (L.scale α).g₂ = ((α : ℂ) ^ 4)⁻¹ * L.g₂ := by
+  unfold g₂; rw [G_scale]; ring
+
+theorem g₃_scale : (L.scale α).g₃ = ((α : ℂ) ^ 6)⁻¹ * L.g₃ := by
+  unfold g₃; rw [G_scale]; ring
+
+theorem discriminant_scale :
+    (L.scale α).g₂ ^ 3 - 27 * (L.scale α).g₃ ^ 2
+      = ((α : ℂ) ^ 12)⁻¹ * (L.g₂ ^ 3 - 27 * L.g₃ ^ 2) := by
+  rw [g₂_scale, g₃_scale]; ring
+
+theorem g₂_cubed_scale : (L.scale α).g₂ ^ 3 = ((α : ℂ) ^ 12)⁻¹ * L.g₂ ^ 3 := by
+  rw [g₂_scale, mul_pow, inv_pow, ← pow_mul]
+
+theorem jLattice_scale : (L.scale α).jLattice = L.jLattice := by
+  have hα : ((α : ℂ) ^ 12)⁻¹ ≠ 0 := inv_ne_zero (pow_ne_zero _ α.ne_zero)
+  unfold jLattice
+  rw [discriminant_scale, g₂_cubed_scale, mul_left_comm (1728 : ℂ), mul_div_mul_left _ _ hα]
+
+theorem discriminantNeZero_scale_iff :
+    (L.scale α).DiscriminantNeZero ↔ L.DiscriminantNeZero := by
+  unfold DiscriminantNeZero
+  rw [discriminant_scale]
+  simp only [mul_ne_zero_iff, and_iff_right (inv_ne_zero (pow_ne_zero 12 α.ne_zero))]
+
+end Homogeneity
+
+section LatticeDependence
+
+variable {L L' : PeriodPair}
+
+private def latticeEquivOfEq (h : L.lattice = L'.lattice) : L.lattice ≃ L'.lattice where
+  toFun l := ⟨(l : ℂ), h ▸ l.2⟩
+  invFun l := ⟨(l : ℂ), h.symm ▸ l.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+
+theorem G_eq_of_lattice_eq (h : L.lattice = L'.lattice) (n : ℕ) : L.G n = L'.G n :=
+  (latticeEquivOfEq h).tsum_eq fun l => ((l : ℂ) ^ n)⁻¹
+
+theorem g₂_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.g₂ = L'.g₂ := by
+  unfold g₂; rw [G_eq_of_lattice_eq h]
+
+theorem g₃_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.g₃ = L'.g₃ := by
+  unfold g₃; rw [G_eq_of_lattice_eq h]
+
+theorem jLattice_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.jLattice = L'.jLattice := by
+  unfold jLattice; rw [g₂_eq_of_lattice_eq h, g₃_eq_of_lattice_eq h]
+
+end LatticeDependence
+
+section Gates
+
+theorem gate_scale_mul (α β : ℂˣ) :
+    ((L.scale α).scale β).lattice = (L.scale (β * α)).lattice := by
+  ext z
+  simp only [mem_scale_lattice_iff, Units.val_mul]
+  constructor
+  · rintro ⟨-, ⟨l, hl, rfl⟩, rfl⟩; exact ⟨l, hl, (mul_assoc _ _ _).symm⟩
+  · rintro ⟨l, hl, rfl⟩; exact ⟨(α : ℂ) * l, ⟨l, hl, rfl⟩, mul_assoc _ _ _⟩
+
+end Gates
+
+private theorem _root_.PeriodPair.kw_countable_lattice : (L.lattice : Set ℂ).Countable := by
+  refine (Set.countable_range fun p : ℤ × ℤ => (p.1 : ℂ) * L.ω₁ + (p.2 : ℂ) * L.ω₂).mono ?_
+  intro z hz
+  obtain ⟨m, n, h⟩ := mem_lattice.mp hz
+  exact ⟨(m, n), h⟩
+
+p2m_export "PeriodPair" "kw_countable_lattice"
+
+private def _root_.PeriodPair.kw_toPointHom : ℂ →+ (L.weierstrassCurve.toAffine).Point where
+  toFun := L.toPoint L.kw_discriminantNeZero
+  map_zero' := L.toPoint_zero L.kw_discriminantNeZero
+  map_add' := L.kw_toPoint_add L.kw_discriminantNeZero
+
+p2m_export "PeriodPair" "kw_toPointHom"
+theorem kw_toPointHom_apply (z : ℂ) :
+    L.kw_toPointHom z = L.toPoint L.kw_discriminantNeZero z := rfl
+
+private theorem _root_.PeriodPair.kw_ker_toPointHom :
+    L.kw_toPointHom.ker = L.lattice.toAddSubgroup := by
+  ext z
+  constructor
+  · exact fun hz => (L.kw_isUniformization).2.2 z hz
+  · intro hz
+    exact L.toPoint_of_mem L.kw_discriminantNeZero hz
+
+p2m_export "PeriodPair" "kw_ker_toPointHom"
+
+private def _root_.PeriodPair.kw_toPointAddEquiv :
+    (ℂ ⧸ L.lattice.toAddSubgroup) ≃+ (L.weierstrassCurve.toAffine).Point :=
+  QuotientAddGroup.liftEquiv L.lattice.toAddSubgroup (φ := L.kw_toPointHom)
+    (L.kw_isUniformization).2.1 L.kw_ker_toPointHom.symm
+
+p2m_export "PeriodPair" "kw_toPointAddEquiv"
+theorem kw_toPointAddEquiv_mk (z : ℂ) :
+    L.kw_toPointAddEquiv (QuotientAddGroup.mk z) = L.toPoint L.kw_discriminantNeZero z :=
+  rfl
+
+scoped instance kw_infinite_quotientLattice : Infinite (ℂ ⧸ L.lattice.toAddSubgroup) := by
+  rw [← not_finite_iff_infinite]; intro hfin
+  have : Countable L.lattice.toAddSubgroup :=
+    Set.countable_coe_iff.mpr L.kw_countable_lattice
+  have : Countable ((ℂ ⧸ L.lattice.toAddSubgroup) × L.lattice.toAddSubgroup) := inferInstance
+  have hCc : Countable ℂ :=
+    Countable.of_equiv _ (AddSubgroup.addGroupEquivQuotientProdAddSubgroup
+      (s := L.lattice.toAddSubgroup)).symm
+  have : Uncountable ℂ := Complex.ofReal_injective.uncountable
+  exact absurd hCc not_countable
+
+scoped instance kw_infinite_point : Infinite L.weierstrassCurve.toAffine.Point :=
+  L.kw_toPointAddEquiv.toEquiv.infinite_iff.mp inferInstance
+
+end PeriodPair
+end
+
+namespace ModularCurve
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve PeriodPair \
+  P2MW.S_OVERLONG_c68ce07f.\
+  PeriodPair"
+
+def KwD5BetweenCurvesHoloLift : Prop :=
+  ∀ (L L' : PeriodPair)
+    [L.weierstrassCurve.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve]
+    (ι'' : L'.weierstrassCurve.toAffine.FunctionField →ₐ[ℂ]
+      L.weierstrassCurve.toAffine.FunctionField)
+    (hι'' : ι''.toRingHom.IsIntegral) (hfin'' : FiniteAlong ℂ ι''),
+    ∃ (F : ℂ → ℂ), Differentiable ℂ F ∧ F 0 ∈ L'.lattice ∧
+      ∀ z, L'.kw_toPointHom (F z)
+        = (pointMapOfPushforward ι'' hι'' hfin''
+            (normFormulaAlong_of_elliptic ι'' hfin'')) (L.kw_toPointHom z)
+
+end ModularCurve
+
+section
+
+
+section
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial IsDedekindDomain \
+  P2MW.S_OVERLONG_c68ce07f.\
+  IsDedekindDomain WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial.Bivariate"
+variable {F : Type*} [Field F] {W : Affine F}
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "XYIdeal quotientXYIdealEquiv XClass_ne_zero \
+  YClass mk map basis_apply map_injective map_mk exists_smul_basis_eq XClass smul_basis_mul_Y \
+  YClass_ne_zero isDedekindDomain exists_eq_XYIdeal XYIdeal_isMaximal XYIdeal_ne_bot"
+end CoordinateRing
+end Affine
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve"
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι"
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+namespace AddMonoid
+p2m_export "AddMonoid" "mk ext"
+namespace End
+p2m_export "AddMonoid.End" "mulLeft ext smul_def smul_apply"
+end End
+end AddMonoid
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+end AlgebraicCurve
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "HeightOneSpectrum.valuationSubringAtPrime HeightOneSpectrum.asIdeal \
+  HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring \
+  HeightOneSpectrum.eq_of_valuation_isEquiv_valuation mk HeightOneSpectrum"
+end IsDedekindDomain
+namespace IsLocalRing
+p2m_export "IsLocalRing" "eq_maximalIdeal ResidueField of_surjective maximalIdeal mem_maximalIdeal \
+  residue"
+end IsLocalRing
+namespace Polynomial
+p2m_export "Polynomial" "C eval₂_sub map_injective X eval_mul coeff_add coeff algebraMap_eq divX \
+  eval₂ aeval eval₂_add monomial basisMonomials eval₂_pow ext_iff degree C_0 factor aeval_C \
+  monic_X_pow_add degree_linear_le map_map coeff_sub map_C map eval₂_X comp roots algebra \
+  eval₂_mul exists_eq_pow_rootMultiplicity_mul_and_not_dvd coeff_C eval_pow X_dvd_iff algHom_ext \
+  sum infinite reverse eval_X eval_C divX_mul_X_add nontrivial eval_sub aeval_algHom \
+  C_mul_X_pow_eq_monomial derivative map_X aeval_X map_monomial algebraMap_apply \
+  coe_basisMonomials C_neg coeff_C_mul eval_add ext coeff_X_pow content eval₂_C funext ring \
+  ringHom_ext lifts transcendental restriction eval"
+end Polynomial
+namespace Polynomial
+p2m_export "Polynomial" "C eval₂_sub map_injective X eval_mul coeff_add coeff algebraMap_eq divX \
+  eval₂ aeval eval₂_add monomial basisMonomials eval₂_pow ext_iff degree C_0 factor aeval_C \
+  monic_X_pow_add degree_linear_le map_map coeff_sub map_C map eval₂_X comp roots algebra \
+  eval₂_mul exists_eq_pow_rootMultiplicity_mul_and_not_dvd coeff_C eval_pow X_dvd_iff algHom_ext \
+  sum infinite reverse eval_X eval_C divX_mul_X_add nontrivial eval_sub aeval_algHom \
+  C_mul_X_pow_eq_monomial derivative map_X aeval_X map_monomial algebraMap_apply \
+  coe_basisMonomials C_neg coeff_C_mul eval_add ext coeff_X_pow content eval₂_C funext ring \
+  ringHom_ext lifts transcendental restriction eval"
+end Polynomial
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+end Affine
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+end Affine
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+namespace Point
+p2m_export "WeierstrassCurve.Affine.Point" "add baseChange map_map some some.injEq map_injective \
+  map_zero map map_some zero neg_some mk neg"
+end Point
+end Affine
+end WeierstrassCurve
+namespace WithZero
+p2m_export "WithZero" "log_le_log map lift one le"
+end WithZero
+section
+section
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial WeierstrassCurve \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial.Bivariate"
+universe u
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+end Affine
+end WeierstrassCurve
+end
+end
+section
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine WeierstrassCurve.Affine.Point \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine.Point"
+p2m_open_scoped "WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine"
+section
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+end AlgebraicCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+end WeierstrassCurve
+end
+end
+section
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve"
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+end Affine
+end WeierstrassCurve
+end
+section
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine"
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+universe u
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι"
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+end
+section
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine"
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+end AlgebraicCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+universe u
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι"
+end IsogenyEndDatum
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι"
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+end
+section
+p2m_open "IsDedekindDomain \
+  P2MW.S_OVERLONG_c68ce07f.\
+  IsDedekindDomain WithZero \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WithZero IsLocalRing \
+  P2MW.S_OVERLONG_c68ce07f.\
+  IsLocalRing"
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+end AlgebraicCurve
+end
+section
+p2m_open "IsDedekindDomain \
+  P2MW.S_OVERLONG_c68ce07f.\
+  IsDedekindDomain WithZero \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WithZero IsLocalRing \
+  P2MW.S_OVERLONG_c68ce07f.\
+  IsLocalRing"
+p2m_open_scoped "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial"
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "placeOfPoint placeOfPoint_injective \
+  deg_placeOfPoint"
+end RationalFunctionField
+end AlgebraicCurve
+end
+section
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial IsDedekindDomain \
+  P2MW.S_OVERLONG_c68ce07f.\
+  IsDedekindDomain WithZero \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WithZero IsLocalRing \
+  P2MW.S_OVERLONG_c68ce07f.\
+  IsLocalRing"
+p2m_open_scoped "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial"
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "pullback degree smul_def smul_apply"
+end Divisor
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "placeOfPoint placeOfPoint_injective \
+  deg_placeOfPoint"
+end RationalFunctionField
+end AlgebraicCurve
+end
+section
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine"
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+universe u
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι"
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+end
+section
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial IsDedekindDomain \
+  P2MW.S_OVERLONG_c68ce07f.\
+  IsDedekindDomain"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial.Bivariate"
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+end AlgebraicCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+end Affine
+end WeierstrassCurve
+end
+section
+p2m_open "IsLocalRing \
+  P2MW.S_OVERLONG_c68ce07f.\
+  IsLocalRing"
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "pullback degree smul_def smul_apply"
+end Divisor
+end AlgebraicCurve
+end
+section
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial IsDedekindDomain \
+  P2MW.S_OVERLONG_c68ce07f.\
+  IsDedekindDomain"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial.Bivariate"
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+theorem Place.ramificationIndexAlong_pos (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') : 0 < Place.ramificationIndexAlong φ w := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  exact w.ramificationIndex_pos
+
+p2m_open_scoped "AlgebraicCurve.Place" in
+theorem Place.ord_restrictAlong_ne_zero_iff (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') (f : F) :
+    (w.restrictAlong φ hφ).ord f ≠ 0 ↔ w.ord (φ f) ≠ 0 := by
+  rw [w.ord_restrictAlong φ hφ f]
+  have hpos := Place.ramificationIndexAlong_pos φ hφ w
+  constructor
+  · intro h hcon
+    rcases mul_eq_zero.mp hcon with h1 | h1
+    · omega
+    · exact h h1
+  · intro h hcon
+    exact h (by rw [hcon, mul_zero])
+
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem algebraMap_polynomial_eq_mk_C (p : F[X]) :
+    algebraMap F[X] W.CoordinateRing p = CoordinateRing.mk W (C p) :=
+  rfl
+
+theorem algebraMap_coordinateRing_ne_zero {r : W.CoordinateRing} (hr : r ≠ 0) :
+    algebraMap W.CoordinateRing W.FunctionField r ≠ 0 :=
+  (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr hr
+
+theorem ord_placeOfEquation_ne_zero_iff [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) {r : W.CoordinateRing} (hr : r ≠ 0) :
+    (placeOfEquation h).ord (algebraMap W.CoordinateRing W.FunctionField r) ≠ 0
+      ↔ r ∈ XYIdeal W x (C y) := by
+  rw [placeOfEquation, Place.ord_ofHeightOneSpectrum_ne_zero_iff _ hr,
+    heightOneSpectrumOfEquation_asIdeal]
+
+theorem ord_placeOfEquation_nonneg [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) (r : W.CoordinateRing) :
+    0 ≤ (placeOfEquation h).ord (algebraMap W.CoordinateRing W.FunctionField r) :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem (placeOfEquation h) (isFinitePlace_placeOfEquation h r)
+
+theorem ord_placeOfEquation_pos_iff [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) {r : W.CoordinateRing} (hr : r ≠ 0) :
+    0 < (placeOfEquation h).ord (algebraMap W.CoordinateRing W.FunctionField r)
+      ↔ r ∈ XYIdeal W x (C y) := by
+  rw [← ord_placeOfEquation_ne_zero_iff h hr]
+  have := ord_placeOfEquation_nonneg h r
+  omega
+
+theorem IsFinitePlace.mem_centre_iff_ord_ne_zero {v : Place F W.FunctionField}
+    (hv : IsFinitePlace v) {r : W.CoordinateRing} (hr : r ≠ 0) :
+    r ∈ hv.centre ↔ v.ord (algebraMap W.CoordinateRing W.FunctionField r) ≠ 0 := by
+  have hr' : algebraMap W.CoordinateRing W.FunctionField r ≠ 0 :=
+    algebraMap_coordinateRing_ne_zero hr
+  rw [IsFinitePlace.centre, Ideal.mem_comap, IsLocalRing.mem_maximalIdeal, mem_nonunits_iff,
+    ne_eq, v.ord_eq_zero_iff_adicValuation_eq_one hr']
+  exact not_congr (v.adicValuation_coe_eq_one_iff (hv.ringHom r)).symm
+
+theorem centre_placeOfEquation [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) :
+    (isFinitePlace_placeOfEquation h).centre = XYIdeal W x (C y) := by
+  ext r
+  rcases eq_or_ne r 0 with rfl | hr
+  · simp only [Submodule.zero_mem]
+  rw [(isFinitePlace_placeOfEquation h).mem_centre_iff_ord_ne_zero hr,
+    ord_placeOfEquation_ne_zero_iff h hr]
+
+theorem eq_placeOfEquation_of_le_centre [IsAlgClosed F] [IsDedekindDomain W.CoordinateRing]
+    {v : Place F W.FunctionField} (hv : IsFinitePlace v) {x y : F} (h : W.Equation x y)
+    (hle : XYIdeal W x (C y) ≤ hv.centre) : v = placeOfEquation h := by
+  obtain ⟨x', y', h', hveq⟩ := (isFinitePlace_iff_exists_placeOfEquation v).mp hv
+  subst hveq
+  have hc : hv.centre = XYIdeal W x' (C y') := by
+    rw [Subsingleton.elim hv (isFinitePlace_placeOfEquation h')]
+    exact centre_placeOfEquation h'
+  rw [hc] at hle
+  have heq : XYIdeal W x (C y) = XYIdeal W x' (C y') :=
+    (CoordinateRing.XYIdeal_isMaximal h).eq_of_le (CoordinateRing.XYIdeal_isMaximal h').ne_top
+      hle
+  obtain ⟨rfl, rfl⟩ := CoordinateRing.eq_of_XYIdeal_eq h' heq
+  rfl
+
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve"
+
+variable {F : Type*} [Field F] (W : Affine F)
+
+variable {W}
+
+def yGen (W : Affine F) : W.FunctionField :=
+  algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+
+end Affine
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+end Affine
+end WeierstrassCurve
+end
+section
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial"
+universe u r s v
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+namespace Point
+p2m_export "WeierstrassCurve.Affine.Point" "add baseChange map_map some some.injEq map_injective \
+  map_zero map map_some zero neg_some mk neg"
+end Point
+end Affine
+end WeierstrassCurve
+end
+section
+p2m_open "IsLocalRing \
+  P2MW.S_OVERLONG_c68ce07f.\
+  IsLocalRing"
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+end AlgebraicCurve
+end
+section
+section
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial WeierstrassCurve \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial.Bivariate"
+universe u
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+end Affine
+end WeierstrassCurve
+end
+end
+section
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial IsDedekindDomain \
+  P2MW.S_OVERLONG_c68ce07f.\
+  IsDedekindDomain"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial.Bivariate"
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve"
+universe u
+variable {F : Type u} [Field F]
+section GenericPoint
+variable {W : Affine F}
+
+theorem polyToFunctionField_eq_aeval (p : F[X]) :
+    polyToFunctionField W p = Polynomial.aeval (polyToFunctionField W X) p := by
+  have h1 : (polyToFunctionField W : F[X] →+* W.FunctionField)
+      = algebraMap F[X] W.FunctionField :=
+    (IsScalarTower.algebraMap_eq F[X] W.CoordinateRing W.FunctionField).symm
+  have h2 : (IsScalarTower.toAlgHom F F[X] W.FunctionField : F[X] →ₐ[F] W.FunctionField)
+      = Polynomial.aeval (polyToFunctionField W X) := by
+    refine Polynomial.algHom_ext ?_
+    rw [Polynomial.aeval_X, IsScalarTower.coe_toAlgHom', ← h1]
+  calc polyToFunctionField W p = algebraMap F[X] W.FunctionField p := by rw [h1]
+    _ = (IsScalarTower.toAlgHom F F[X] W.FunctionField : F[X] →ₐ[F] W.FunctionField) p := rfl
+    _ = Polynomial.aeval (polyToFunctionField W X) p := by rw [h2]
+
+theorem equation_map_polyToFunctionField_yGen :
+    (W.map (algebraMap F W.FunctionField)).toAffine.Equation
+      (polyToFunctionField W X) (yGen W) := by
+  rw [equation_iff]
+  have hrel := smul_basis_mul_Y (W' := W) 0 1
+  rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at hrel
+  have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) hrel
+  rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆]
+  simp only [map_add, map_mul, map_pow, polyToFunctionField_C] at h2
+  rw [show yGen W = algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+    from rfl]
+  simp only [polyToFunctionField_apply] at h2 ⊢
+  linear_combination h2
+
+end GenericPoint
+end Affine
+end WeierstrassCurve
+end
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial IsDedekindDomain \
+  P2MW.S_OVERLONG_c68ce07f.\
+  IsDedekindDomain"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial.Bivariate"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve"
+
+universe u
+
+variable {F : Type u} [Field F]
+
+namespace AbstractSeam
+
+variable {W : Affine F} {V : Affine F}
+variable (ι : V.FunctionField →ₐ[F] W.FunctionField)
+  (hι : ι.toRingHom.IsIntegral)
+  {ξ η : W.FunctionField}
+  (hX : ι (polyToFunctionField V (X : F[X])) = ξ)
+  (hY : ι (yGen V) = η)
+
+include hX in
+theorem map_XClass (c : F) :
+    ι (algebraMap V.CoordinateRing V.FunctionField (XClass V c))
+      = ξ - algebraMap F W.FunctionField c := by
+  have h1 : algebraMap V.CoordinateRing V.FunctionField (XClass V c)
+      = polyToFunctionField V (X : F[X]) - algebraMap F V.FunctionField c := by
+    rw [← polyToFunctionField_C, ← map_sub]
+    rfl
+  rw [h1, map_sub, hX, AlgHom.commutes]
+
+include hY in
+theorem map_YClass (c : F) :
+    ι (algebraMap V.CoordinateRing V.FunctionField (YClass V (C c)))
+      = η - algebraMap F W.FunctionField c := by
+  have h1 : algebraMap V.CoordinateRing V.FunctionField (YClass V (C c))
+      = yGen V - algebraMap F V.FunctionField c := by
+    rw [YClass, map_sub, map_sub, yGen]
+    congr 1
+  rw [h1, map_sub, hY, AlgHom.commutes]
+
+section Cases
+
+variable [IsDedekindDomain V.CoordinateRing]
+
+include hX hY in
+theorem restrictAlong_placeOfEquation [IsAlgClosed F] [W.IsElliptic]
+    {x y : F} (h : W.Equation x y) {a b : F} (h' : V.Equation a b)
+    (hreg : ξ ∈ (placeOfEquation h).toValuationSubring)
+    (hdx : 0 < (placeOfEquation h).ord (ξ - algebraMap F W.FunctionField a))
+    (hdy : 0 < (placeOfEquation h).ord (η - algebraMap F W.FunctionField b)) :
+    (placeOfEquation h).restrictAlong ι hι = placeOfEquation h' := by
+  have hfin : IsFinitePlace ((placeOfEquation h).restrictAlong ι hι) :=
+    isFinitePlace_of_mem _ (by
+      rw [Place.mem_restrictAlong_iff, hX]
+      exact hreg)
+  refine eq_placeOfEquation_of_le_centre hfin h' ?_
+  rw [XYIdeal, Ideal.span_le]
+  intro r hr
+  simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hr
+  rcases hr with rfl | rfl
+  · rw [SetLike.mem_coe, hfin.mem_centre_iff_ord_ne_zero (XClass_ne_zero _),
+      Place.ord_restrictAlong_ne_zero_iff, map_XClass ι hX]
+    omega
+  · rw [SetLike.mem_coe, hfin.mem_centre_iff_ord_ne_zero (YClass_ne_zero _),
+      Place.ord_restrictAlong_ne_zero_iff, map_YClass ι hY]
+    omega
+
+include hX in
+theorem restrictAlong_eq_infinitePlace [V.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred V]
+    (v : AlgebraicCurve.Place F W.FunctionField)
+    (hpole : ξ ∉ v.toValuationSubring) :
+    v.restrictAlong ι hι = InfinitePlace.place := by
+  refine InfinitePlace.eq_of_not_isFinitePlace _ ?_
+  intro hfin
+  refine hpole ?_
+  rw [← hX]
+  exact hfin (algebraMap F[X] V.CoordinateRing (X : F[X]))
+
+end Cases
+end AbstractSeam
+end Affine
+end WeierstrassCurve
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial Polynomial.Bivariate.Polynomial \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+end WeierstrassCurve
+end
+
+section
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine WeierstrassCurve.Affine.Point \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine.Point"
+p2m_open_scoped "WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine Polynomial.Bivariate \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial.Bivariate"
+section
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve"
+universe u
+variable {F : Type u} [Field F]
+section AdjoinSurjective
+variable {W : Affine F} (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b)
+local notation "ι" => algebraMap F W.FunctionField
+
+theorem transcendental_polyToFunctionField_X :
+    Transcendental F (polyToFunctionField W X) := by
+  rw [transcendental_iff]
+  intro p hp
+  rw [← polyToFunctionField_eq_aeval] at hp
+  exact polyToFunctionField_injective (by simpa using hp)
+
+end AdjoinSurjective
+end Affine
+end WeierstrassCurve
+end
+end
+
+section
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial WeierstrassCurve \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial.Bivariate"
+
+universe u
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+end Affine
+end WeierstrassCurve
+namespace ModularCurve
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve"
+local notation "psPsi11" =>
+  (Polynomial.C 4 * Polynomial.X ^ 3 - Polynomial.C 4 * Polynomial.X ^ 2
+    - Polynomial.C 40 * Polynomial.X - Polynomial.C 79 : Polynomial (AlgebraicClosure ℚ))
+local notation "psN411" =>
+  (Polynomial.X ^ 4 + Polynomial.C 20 * Polynomial.X ^ 2
+    + Polynomial.C 158 * Polynomial.X + Polynomial.C 21 : Polynomial (AlgebraicClosure ℚ))
+local notation "psP11[" b "]" =>
+  (Polynomial.X ^ 6 - Polynomial.C 2 * Polynomial.X ^ 5 - Polynomial.C 50 * Polynomial.X ^ 4
+    - Polynomial.C (4 * b + 397) * Polynomial.X ^ 3
+    + Polynomial.C (4 * b - 103) * Polynomial.X ^ 2
+    + Polynomial.C (40 * b - 728) * Polynomial.X
+    + Polynomial.C (79 * b - 2871) : Polynomial (AlgebraicClosure ℚ))
+local notation "psQ11[" b "]" =>
+  (Polynomial.C (-8 * b - 4) * Polynomial.X ^ 3 + Polynomial.C (8 * b + 4) * Polynomial.X ^ 2
+    + Polynomial.C (80 * b + 40) * Polynomial.X + Polynomial.C (158 * b + 79)
+    : Polynomial (AlgebraicClosure ℚ))
+end ModularCurve
+end
+end
+end
+
+section
+
+
+section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+end AlgebraicCurve
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+end AlgebraicCurve
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+end AlgebraicCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve"
+section Gate
+universe u
+variable {F : Type u} [Field F] [DecidableEq F]
+variable {W : Affine F} [GenusOnePlaceGate W]
+variable (W)
+
+def placeOfPointEquiv : W.Point ≃ AlgebraicCurve.Place F W.FunctionField :=
+  pointEquivPlace (W := W)
+omit [DecidableEq F] in
+theorem placeOfPoint_placeOfPointEquiv_symm (w : AlgebraicCurve.Place F W.FunctionField) :
+    placeOfPoint ((placeOfPointEquiv W).symm w) = w := by
+  classical
+  exact
+    (placeOfPointEquiv W).apply_symm_apply w
+
+end Gate
+end Affine
+end WeierstrassCurve
+namespace ModularCurve
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve"
+universe u
+attribute [local instance] Classical.propDecidable
+section GeomMorphBC
+variable {K : Type u} [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable {E E' : Affine K} [E.IsElliptic] [GenusOnePlaceGate E] [AbelTheorem E]
+  [E'.IsElliptic] [GenusOnePlaceGate E'] [AbelTheorem E']
+variable (ι : E'.FunctionField →ₐ[K] E.FunctionField)
+variable (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong K ι) (hN : NormFormulaAlong K ι hfin)
+
+def kw_fdn2_qephod_hend7_geomMorphBC : E.Point → E'.Point :=
+  fun P => (placeOfPointEquiv E').symm ((placeOfPoint P).restrictAlong ι hι)
+
+local notation "gBC" => kw_fdn2_qephod_hend7_geomMorphBC ι hι
+
+omit [DecidableEq K] [IsAlgClosed K] [CharZero K] [WeierstrassCurve.IsElliptic E] [E.AbelTheorem]
+  [WeierstrassCurve.IsElliptic E'] [E'.AbelTheorem] in
+theorem kw_fdn2_qephod_hend7_placeOfPoint_geomMorphBC (P : E.Point) :
+    (placeOfPoint P).restrictAlong ι hι = placeOfPoint (gBC P) :=
+  (placeOfPoint_placeOfPointEquiv_symm E' _).symm
+
+omit [DecidableEq K] [IsAlgClosed K] [CharZero K] [WeierstrassCurve.IsElliptic E] [E.AbelTheorem]
+  [WeierstrassCurve.IsElliptic E'] [E'.AbelTheorem] in
+theorem kw_fdn2_qephod_hend7_pushforwardDegZero_pointDivisor_geomMorphBC (P : E.Point) :
+    Pic0.pushforwardAlongDegZero ι hι (pointDivisor P)
+      = pointDivisor (gBC P) - pointDivisor (gBC 0) := by
+  refine Subtype.ext ?_
+  rw [Pic0.coe_pushforwardAlongDegZero, coe_pointDivisor, map_sub,
+    pushforwardAlong_single_eq ι hι, pushforwardAlong_single_eq ι hι,
+    kw_fdn2_qephod_hend7_placeOfPoint_geomMorphBC ι hι P,
+    kw_fdn2_qephod_hend7_placeOfPoint_geomMorphBC ι hι 0]
+  push_cast
+  rw [coe_pointDivisor, coe_pointDivisor, sub_sub_sub_cancel_right]
+
+include hfin in
+omit [DecidableEq K] [IsAlgClosed K] [CharZero K] [WeierstrassCurve.IsElliptic E] [E.AbelTheorem]
+  [WeierstrassCurve.IsElliptic E'] [E'.AbelTheorem] in
+theorem kw_fdn2_qephod_hend7_pushforwardHom_pointClass_eq_sub (P : E.Point) :
+    Pic0.pushforwardAlongHom ι hι hfin hN
+        (pointClass P)
+      = pointClass (gBC P) - pointClass (gBC 0) := by
+  change Pic0.pushforwardAlongHom ι hι hfin _ (Pic0.mk (pointDivisor P))
+      = Pic0.mk (pointDivisor (gBC P)) - Pic0.mk (pointDivisor (gBC 0))
+  rw [Pic0.pushforwardAlongHom_mk,
+    kw_fdn2_qephod_hend7_pushforwardDegZero_pointDivisor_geomMorphBC ι hι P]
+  rfl
+
+include hfin in
+omit [IsAlgClosed K] [CharZero K] [WeierstrassCurve.IsElliptic E]
+  [WeierstrassCurve.IsElliptic E'] in
+theorem kw_fdn2_qephod_hend7_pmop_eq_geomMorphBC_sub (P : E.Point) :
+    pointMapOfPushforward ι hι hfin hN P
+      = gBC P - gBC 0 := by
+  rw [pointMapOfPushforward_apply,
+    kw_fdn2_qephod_hend7_pushforwardHom_pointClass_eq_sub ι hι hfin hN P, map_sub,
+    genusOnePic0Equiv_apply, genusOnePic0Equiv_apply, pic0ToPoint_pointClass,
+    pic0ToPoint_pointClass]
+end GeomMorphBC
+end ModularCurve
+end
+end
+
+section
+
+
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  ModularCurve"
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial"
+p2m_open_scoped "TensorProduct Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial"
+
+namespace ModularCurve
+
+universe u
+
+section Setup
+
+variable (W : WeierstrassCurve ℚ) [W.IsElliptic]
+variable (F : Type u) [Field F] [Algebra ℚ F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra ℚ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower ℚ F F']
+
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F).toAffine]
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F').toAffine]
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+local notation3 "CR" => (W⁄F).toAffine.CoordinateRing
+local notation3 "FF" => (W⁄F).FunctionField
+
+def kw_coordinateRingBasis {R : Type*} [CommRing R] (V : Affine R) :
+    Module.Basis (ℕ × Fin 2) R V.CoordinateRing :=
+  (Polynomial.basisMonomials R).smulTower (CoordinateRing.basis V)
+end Setup
+end ModularCurve
+end
+
+section
+
+
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  ModularCurve \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve"
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial"
+p2m_open_scoped "TensorProduct Polynomial.Bivariate \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial.Bivariate"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+universe u
+variable {F : Type u} [Field F] {W : Affine F}
+
+theorem kw_functionField_algHom_ext {L : Type*} [Field L] [Algebra F L]
+    {f g : W.FunctionField →ₐ[F] L}
+    (hX : f (polyToFunctionField W X) = g (polyToFunctionField W X))
+    (hy : f (yGen W) = g (yGen W)) : f = g := by
+  have hCR : ∀ r : W.CoordinateRing,
+      f (algebraMap W.CoordinateRing W.FunctionField r)
+        = g (algebraMap W.CoordinateRing W.FunctionField r) := by
+    intro r
+    obtain ⟨p, rfl⟩ := AdjoinRoot.mk_surjective r
+    have hFX : ∀ c : F[X], f (algebraMap W.CoordinateRing W.FunctionField
+          (algebraMap F[X] W.CoordinateRing c))
+        = g (algebraMap W.CoordinateRing W.FunctionField
+          (algebraMap F[X] W.CoordinateRing c)) :=
+      fun c => DFunLike.congr_fun
+        (Polynomial.algHom_ext (f := (f.comp (IsScalarTower.toAlgHom F W.CoordinateRing
+            W.FunctionField)).comp (IsScalarTower.toAlgHom F F[X] W.CoordinateRing))
+          (g := (g.comp (IsScalarTower.toAlgHom F W.CoordinateRing W.FunctionField)).comp
+            (IsScalarTower.toAlgHom F F[X] W.CoordinateRing)) hX) c
+    have hFX' : ∀ c : F[X], f (algebraMap W.CoordinateRing W.FunctionField
+          (AdjoinRoot.mk W.polynomial (C c)))
+        = g (algebraMap W.CoordinateRing W.FunctionField
+          (AdjoinRoot.mk W.polynomial (C c))) := fun c => by
+      rw [show AdjoinRoot.mk W.polynomial (C c) = algebraMap F[X] W.CoordinateRing c from rfl]
+      exact hFX c
+    have hy' : f (algebraMap W.CoordinateRing W.FunctionField (AdjoinRoot.mk W.polynomial Y))
+        = g (algebraMap W.CoordinateRing W.FunctionField (AdjoinRoot.mk W.polynomial Y)) := hy
+    induction p using Polynomial.induction_on with
+    | C c => exact hFX' c
+    | monomial n c _ => simp only [map_mul, map_pow, hy', hFX' c]
+    | add p q hp hq => simp only [map_add, hp, hq]
+  refine AlgHom.ext fun a => ?_
+  obtain ⟨p, q, hq, rfl⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) a
+  simp only [map_div₀, hCR p, hCR q]
+
+end Affine
+end WeierstrassCurve
+
+namespace ModularCurve
+
+universe u
+
+section Setup
+
+variable (W : WeierstrassCurve ℚ) [W.IsElliptic]
+variable (F : Type u) [Field F] [Algebra ℚ F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra ℚ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower ℚ F F']
+
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F).toAffine]
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F').toAffine]
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+scoped instance kw_isScalarTower_rat_right_tensor :
+    IsScalarTower ℚ F' ((W⁄F).FunctionField ⊗[F] F') :=
+  IsScalarTower.of_algebraMap_eq' (Subsingleton.elim _ _)
+
+end Setup
+end ModularCurve
+end
+
+section
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial WeierstrassCurve \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial.Bivariate"
+
+universe u
+
+local instance instDecEqFunctionFieldAddLawPullback {F : Type u} [Field F]
+    {W : WeierstrassCurve.Affine F} : DecidableEq W.FunctionField :=
+  Classical.decEq _
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine.CoordinateRing"
+
+variable {F : Type u} [Field F]
+
+section PointPullbackTo
+
+variable {W : Affine F} {L : Type u} [Field L] [Algebra F L]
+
+theorem eval₂_polynomial_of_equation_map_target {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) :
+    W.polynomial.eval₂
+      (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom yP = 0 := by
+  rw [equation_iff'] at h
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆] at h
+  simp only [WeierstrassCurve.Affine.polynomial, eval₂_add, eval₂_sub, eval₂_mul, eval₂_pow,
+    eval₂_X, eval₂_C, AlgHom.toRingHom_eq_coe, RingHom.coe_coe, map_add, map_mul, map_pow,
+    Polynomial.aeval_C, Polynomial.aeval_X]
+  linear_combination h
+
+def pointPullbackCoordHomTo {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) :
+    W.CoordinateRing →ₐ[F] L where
+  __ := AdjoinRoot.lift
+    (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom
+    yP (eval₂_polynomial_of_equation_map_target h)
+  commutes' c := by
+    change AdjoinRoot.lift _ _ (eval₂_polynomial_of_equation_map_target h) (algebraMap F _ c)
+      = algebraMap F L c
+    rw [CoordinateRing.algebraMap_eq_mk_C_C, AdjoinRoot.lift_mk, eval₂_C]
+    exact Polynomial.aeval_C _ c
+
+theorem pointPullbackCoordHomTo_mk {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) (g : F[X][Y]) :
+    pointPullbackCoordHomTo h (CoordinateRing.mk W g)
+      = g.eval₂ (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom yP :=
+  AdjoinRoot.lift_mk (eval₂_polynomial_of_equation_map_target h) g
+
+theorem pointPullbackCoordHomTo_comp_algebraMap {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) :
+    (pointPullbackCoordHomTo h).toRingHom.comp (algebraMap F[X] W.CoordinateRing)
+      = (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom := by
+  refine RingHom.ext fun p => ?_
+  change pointPullbackCoordHomTo h (algebraMap F[X] _ p) = _
+  rw [algebraMap_polynomial_eq_mk_C, pointPullbackCoordHomTo_mk, eval₂_C]
+
+theorem pointPullbackCoordHomTo_injective {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    Function.Injective (pointPullbackCoordHomTo h) := by
+  have hker : RingHom.ker (pointPullbackCoordHomTo h).toRingHom = ⊥ := by
+    have : Module.Finite F[X] W.CoordinateRing :=
+      Module.Finite.of_basis (CoordinateRing.basis W)
+    refine Ideal.eq_bot_of_under_eq_bot (R := F[X]) ?_
+    rw [Ideal.under_def, RingHom.comap_ker, pointPullbackCoordHomTo_comp_algebraMap,
+      ← RingHom.injective_iff_ker_eq_bot]
+    exact hx
+  exact (RingHom.injective_iff_ker_eq_bot (pointPullbackCoordHomTo h).toRingHom).mpr hker
+
+def pointPullbackHomTo {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    W.FunctionField →ₐ[F] L :=
+  IsFractionRing.liftAlgHom (pointPullbackCoordHomTo_injective h hx)
+
+theorem pointPullbackHomTo_algebraMap {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) (r : W.CoordinateRing) :
+    pointPullbackHomTo h hx (algebraMap W.CoordinateRing W.FunctionField r)
+      = pointPullbackCoordHomTo h r :=
+  IsFractionRing.lift_algebraMap (pointPullbackCoordHomTo_injective h hx) r
+
+theorem pointPullbackHomTo_polyToFunctionField_X {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    pointPullbackHomTo h hx (polyToFunctionField W X) = xP := by
+  rw [polyToFunctionField_apply, pointPullbackHomTo_algebraMap,
+    algebraMap_polynomial_eq_mk_C, pointPullbackCoordHomTo_mk, eval₂_C]
+  exact Polynomial.aeval_X _
+
+theorem pointPullbackHomTo_yGen {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    pointPullbackHomTo h hx (yGen W) = yP := by
+  change pointPullbackHomTo h hx (algebraMap _ _ (CoordinateRing.mk W Y)) = _
+  rw [pointPullbackHomTo_algebraMap, pointPullbackCoordHomTo_mk]
+  exact eval₂_X _ _
+
+end PointPullbackTo
+end Affine
+end WeierstrassCurve
+end
+end
+
+section
+
+
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  ModularCurve \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve"
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial"
+p2m_open_scoped "TensorProduct Polynomial.Bivariate \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial.Bivariate Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial Polynomial.Bivariate.Polynomial"
+
+namespace ModularCurve
+
+universe u
+
+section SetupBCG
+
+variable {R₀ : Type u} [Field R₀]
+variable (W : WeierstrassCurve R₀) [W.IsElliptic]
+variable (F : Type u) [Field F] [Algebra R₀ F] [DecidableEq F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra R₀ F'] [DecidableEq F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower R₀ F F']
+
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F).toAffine]
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F').toAffine]
+
+omit [W.IsElliptic] [Algebra R₀ F] [DecidableEq F] [CharZero F] [DecidableEq F'] [CharZero F']
+  [IsScalarTower R₀ F F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_transcendental_polyToFunctionField_X_over_baseGeneralNoAC :
+    Transcendental F (polyToFunctionField (W⁄F') X) :=
+  Transcendental.of_tower_top F (L := F')
+    (transcendental_polyToFunctionField_X (W := (W⁄F')))
+
+omit [W.IsElliptic] [DecidableEq F] [CharZero F] [DecidableEq F'] [CharZero F']
+  [(toAffine W⁄F).GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F)]
+  [(toAffine W⁄F).AbelTheorem] [(toAffine W⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F')] [(toAffine W⁄F').AbelTheorem] in
+theorem kw_equation_map_polyToFunctionField_yGen_over_baseGeneralNoAC :
+    ((W⁄F).map (algebraMap F (W⁄F').FunctionField)).toAffine.Equation
+      (polyToFunctionField (W⁄F') X) (yGen (W⁄F')) := by
+  have hcurve : (W⁄F).map (algebraMap F (W⁄F').FunctionField)
+      = (W⁄F').map (algebraMap F' (W⁄F').FunctionField) := by
+    change (W.map _).map _ = (W.map _).map _
+    rw [WeierstrassCurve.map_map, WeierstrassCurve.map_map]
+    congr 1
+    exact ((IsScalarTower.algebraMap_eq R₀ F (W⁄F').FunctionField).symm).trans
+      (IsScalarTower.algebraMap_eq R₀ F' (W⁄F').FunctionField)
+  exact hcurve ▸ equation_map_polyToFunctionField_yGen (W := (W⁄F'))
+
+def kw_functionFieldMapAlongGeneralNoAC : (W⁄F).FunctionField →ₐ[F] (W⁄F').FunctionField :=
+  pointPullbackHomTo (kw_equation_map_polyToFunctionField_yGen_over_baseGeneralNoAC W F F')
+    ((injective_iff_map_eq_zero _).mpr fun p hp =>
+      transcendental_iff.mp (kw_transcendental_polyToFunctionField_X_over_baseGeneralNoAC W F F') p
+        hp)
+
+omit [W.IsElliptic] [DecidableEq F] [CharZero F] [DecidableEq F'] [CharZero F']
+  [(toAffine W⁄F).GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F)]
+  [(toAffine W⁄F).AbelTheorem] [(toAffine W⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F')] [(toAffine W⁄F').AbelTheorem] in
+theorem kw_functionFieldMapAlongGeneralNoAC_polyToFunctionField_X :
+    kw_functionFieldMapAlongGeneralNoAC W F F' (polyToFunctionField (W⁄F) X)
+      = polyToFunctionField (W⁄F') X :=
+  pointPullbackHomTo_polyToFunctionField_X _ _
+
+omit [W.IsElliptic] [DecidableEq F] [CharZero F] [DecidableEq F'] [CharZero F']
+  [(toAffine W⁄F).GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F)]
+  [(toAffine W⁄F).AbelTheorem] [(toAffine W⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F')] [(toAffine W⁄F').AbelTheorem] in
+theorem kw_functionFieldMapAlongGeneralNoAC_yGen :
+    kw_functionFieldMapAlongGeneralNoAC W F F' (yGen (W⁄F)) = yGen (W⁄F') :=
+  pointPullbackHomTo_yGen _ _
+
+def KwFunctionFieldTensorIsDomainGeneralNoAC : Prop :=
+  IsDomain ((W⁄F).FunctionField ⊗[F] F')
+
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+scoped instance kw_isScalarTower_base_right_tensorGeneralNoAC :
+    IsScalarTower R₀ F' ((W⁄F).FunctionField ⊗[F] F') := by
+  refine IsScalarTower.of_algebraMap_eq' (RingHom.ext fun r => ?_)
+  rw [RingHom.comp_apply, Algebra.TensorProduct.right_algebraMap_apply,
+    IsScalarTower.algebraMap_apply R₀ F F',
+    show algebraMap R₀ ((W⁄F).FunctionField ⊗[F] F') r
+      = (algebraMap F ((W⁄F).FunctionField ⊗[F] F')) (algebraMap R₀ F r) from
+        IsScalarTower.algebraMap_apply R₀ F ((W⁄F).FunctionField ⊗[F] F') r,
+    Algebra.TensorProduct.algebraMap_apply, Algebra.algebraMap_eq_smul_one,
+    Algebra.algebraMap_eq_smul_one, TensorProduct.smul_tmul, Algebra.algebraMap_eq_smul_one]
+
+section FracHom
+
+variable [IsDomain ((W⁄F).FunctionField ⊗[F] F')]
+
+scoped instance kw_isScalarTower_base_right_fracTensorGeneralNoAC :
+    IsScalarTower R₀ F' (FractionRing ((W⁄F).FunctionField ⊗[F] F')) :=
+  IsScalarTower.of_algebraMap_eq fun r =>
+    (IsScalarTower.algebraMap_apply R₀ ((W⁄F).FunctionField ⊗[F] F')
+        (FractionRing ((W⁄F).FunctionField ⊗[F] F')) r).trans <|
+      (congrArg (algebraMap ((W⁄F).FunctionField ⊗[F] F')
+          (FractionRing ((W⁄F).FunctionField ⊗[F] F')))
+        (IsScalarTower.algebraMap_apply R₀ F' ((W⁄F).FunctionField ⊗[F] F') r)).trans
+      (IsScalarTower.algebraMap_apply F' ((W⁄F).FunctionField ⊗[F] F')
+        (FractionRing ((W⁄F).FunctionField ⊗[F] F')) (algebraMap R₀ F' r)).symm
+
+end FracHom
+end SetupBCG
+section SetupBCGD
+variable {R₀ : Type u} [Field R₀]
+variable (W : WeierstrassCurve R₀) [W.IsElliptic]
+variable (F : Type u) [Field F] [Algebra R₀ F] [DecidableEq F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra R₀ F'] [DecidableEq F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower R₀ F F']
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F).toAffine]
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F').toAffine]
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+section FFDomain
+local notation3 "CR" => (W⁄F).toAffine.CoordinateRing
+local notation3 "FFₗ" => (W⁄F).FunctionField
+
+omit [W.IsElliptic] [DecidableEq F] [CharZero F] [Algebra R₀ F'] [DecidableEq F'] [CharZero F']
+  [IsScalarTower R₀ F F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_coordinateRingMap_basisGeneralNoAC (i : ℕ × Fin 2) :
+    CoordinateRing.map (W⁄F).toAffine (algebraMap F F')
+        (kw_coordinateRingBasis (W⁄F).toAffine i)
+      = kw_coordinateRingBasis ((W⁄F).toAffine.map (algebraMap F F')) i := by
+  obtain ⟨n, j⟩ := i
+  simp only [kw_coordinateRingBasis, Module.Basis.smulTower_apply,
+    Polynomial.coe_basisMonomials, CoordinateRing.map_smul]
+  congr 1
+  · simp [Polynomial.map_monomial]
+  · rcases j with ⟨j, hj⟩
+    interval_cases j <;>
+      simp [CoordinateRing.basis_apply, CoordinateRing.map,
+        AdjoinRoot.lift_root, AdjoinRoot.powerBasis'_gen]
+
+def kw_coordinateRingMapAlongGeneralNoAC :
+    CR →ₐ[F] ((W⁄F).toAffine.map (algebraMap F F')).CoordinateRing where
+  __ := CoordinateRing.map (W⁄F).toAffine (algebraMap F F')
+  commutes' r := by
+    simp only [RingHom.toMonoidHom_eq_coe, OneHom.toFun_eq_coe, MonoidHom.toOneHom_coe,
+      MonoidHom.coe_ofClass]
+    change CoordinateRing.map (W⁄F).toAffine (algebraMap F F') (algebraMap F CR r) = algebraMap F _
+      r
+    rw [IsScalarTower.algebraMap_apply F F[X] CR,
+      show (algebraMap F F[X] r) = Polynomial.C r from rfl,
+      show (algebraMap F[X] CR) (C r) = (C r : F[X]) • (1 : CR) by
+        rw [Algebra.smul_def, mul_one],
+      CoordinateRing.map_smul, map_one, Polynomial.map_C,
+      IsScalarTower.algebraMap_apply F F' ((W⁄F).toAffine.map (algebraMap F F')).CoordinateRing,
+      IsScalarTower.algebraMap_apply F' F'[X]
+        ((W⁄F).toAffine.map (algebraMap F F')).CoordinateRing,
+      show (algebraMap F' F'[X]) ((algebraMap F F') r) = Polynomial.C ((algebraMap F F') r)
+        from rfl,
+      Algebra.smul_def, mul_one]
+
+omit [W.IsElliptic] [DecidableEq F] [CharZero F] [Algebra R₀ F'] [DecidableEq F'] [CharZero F']
+  [IsScalarTower R₀ F F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_coordinateRingTensor_isDomainGeneralNoAC : IsDomain (CR ⊗[F] F') := by
+  suffices h : IsDomain (F' ⊗[F] CR) by
+    have := h
+    exact Function.Injective.isDomain (Algebra.TensorProduct.comm F CR F').toRingHom
+      (Algebra.TensorProduct.comm F CR F').injective
+  set W'' := (W⁄F).toAffine.map (algebraMap F F') with hW''
+  let θ : F' ⊗[F] CR →ₐ[F'] W''.CoordinateRing :=
+    AlgHom.liftEquiv F F' CR W''.CoordinateRing (kw_coordinateRingMapAlongGeneralNoAC W F F')
+  have hθ : Function.Injective θ := by
+    let bT : Module.Basis (ℕ × Fin 2) F' (F' ⊗[F] CR) :=
+      Algebra.TensorProduct.basis F' (kw_coordinateRingBasis (W⁄F).toAffine)
+    let bD : Module.Basis (ℕ × Fin 2) F' W''.CoordinateRing := kw_coordinateRingBasis W''
+    have key : ∀ i, θ.toLinearMap (bT i) = (bT.equiv bD (Equiv.refl _)) (bT i) := fun i => by
+      rw [Module.Basis.equiv_apply, Equiv.refl_apply, AlgHom.toLinearMap_apply]
+      simp only [bT, Algebra.TensorProduct.basis_apply, θ, AlgHom.liftEquiv_tmul, one_smul]
+      exact kw_coordinateRingMap_basisGeneralNoAC W F F' i
+    have heq : (θ : F' ⊗[F] CR → W''.CoordinateRing) = bT.equiv bD (Equiv.refl _) :=
+      funext fun x => DFunLike.congr_fun (bT.ext key : θ.toLinearMap = _) x
+    exact heq ▸ (bT.equiv bD (Equiv.refl _)).injective
+  exact Function.Injective.isDomain θ.toRingHom hθ
+
+omit [W.IsElliptic] [DecidableEq F] [CharZero F] [Algebra R₀ F'] [DecidableEq F'] [CharZero F']
+  [IsScalarTower R₀ F F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_functionFieldTensorIsDomain_dischargeGeneralNoAC :
+    KwFunctionFieldTensorIsDomainGeneralNoAC W F F' := by
+  change IsDomain (FFₗ ⊗[F] F')
+  have hCR : IsDomain (CR ⊗[F] F') := kw_coordinateRingTensor_isDomainGeneralNoAC W F F'
+  let : Algebra (CR ⊗[F] F') (FFₗ ⊗[F] F') :=
+    (Algebra.TensorProduct.map (IsScalarTower.toAlgHom F CR FFₗ)
+      (AlgHom.id F F')).toRingHom.toAlgebra
+  have hst : IsScalarTower CR (CR ⊗[F] F') (FFₗ ⊗[F] F') :=
+    IsScalarTower.of_algebraMap_eq (R := CR) (S := CR ⊗[F] F') (A := FFₗ ⊗[F] F') fun c => by
+      change Algebra.TensorProduct.map (IsScalarTower.toAlgHom F CR FFₗ) (AlgHom.id F F')
+          (algebraMap CR (CR ⊗[F] F') c) = algebraMap CR (FFₗ ⊗[F] F') c
+      rfl
+  have hloc : IsLocalization
+      (Algebra.algebraMapSubmonoid (CR ⊗[F] F') (nonZeroDivisors CR)) (FFₗ ⊗[F] F') :=
+    IsLocalization.tensorProduct_tensorProduct F F' (nonZeroDivisors CR) FFₗ (by
+      ext x; simp [RingHom.algebraMap_toAlgebra, Algebra.TensorProduct.map_tmul])
+  have hle : Algebra.algebraMapSubmonoid (CR ⊗[F] F') (nonZeroDivisors CR)
+      ≤ nonZeroDivisors (CR ⊗[F] F') := by
+    rintro _ ⟨c, hc, rfl⟩
+    refine mem_nonZeroDivisors_of_ne_zero ?_
+    have hinj : Function.Injective (algebraMap CR (CR ⊗[F] F')) :=
+      Algebra.TensorProduct.includeLeft_injective (S := F) (algebraMap F F').injective
+    exact fun h => (nonZeroDivisors.ne_zero hc) (hinj (by simp only [map_zero] at h ⊢; exact h))
+  exact IsLocalization.isDomain_of_le_nonZeroDivisors
+    (M := Algebra.algebraMapSubmonoid (CR ⊗[F] F') (nonZeroDivisors CR)) _ hle
+
+end FFDomain
+end SetupBCGD
+end ModularCurve
+end
+end
+
+section
+
+
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  ModularCurve \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve"
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial"
+p2m_open_scoped "TensorProduct Polynomial.Bivariate \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial.Bivariate"
+
+namespace ModularCurve
+
+universe u
+
+section Setup
+
+variable {R₀ : Type u} [Field R₀]
+variable (W : WeierstrassCurve R₀) [W.IsElliptic]
+variable (F : Type u) [Field F] [Algebra R₀ F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra R₀ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower R₀ F F']
+
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F).toAffine]
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F').toAffine]
+
+omit [W.IsElliptic] [Algebra R₀ F] [DecidableEq F] [IsAlgClosed F] [CharZero F] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [IsScalarTower R₀ F F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_transcendental_polyToFunctionField_X_over_baseGeneral :
+    Transcendental F (polyToFunctionField (W⁄F') X) :=
+  Transcendental.of_tower_top F (L := F')
+    (transcendental_polyToFunctionField_X (W := (W⁄F')))
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_equation_map_polyToFunctionField_yGen_over_baseGeneral :
+    ((W⁄F).map (algebraMap F (W⁄F').FunctionField)).toAffine.Equation
+      (polyToFunctionField (W⁄F') X) (yGen (W⁄F')) := by
+  have hcurve : (W⁄F).map (algebraMap F (W⁄F').FunctionField)
+      = (W⁄F').map (algebraMap F' (W⁄F').FunctionField) := by
+    change (W.map _).map _ = (W.map _).map _
+    rw [WeierstrassCurve.map_map, WeierstrassCurve.map_map]
+    congr 1
+    exact ((IsScalarTower.algebraMap_eq R₀ F (W⁄F').FunctionField).symm).trans
+      (IsScalarTower.algebraMap_eq R₀ F' (W⁄F').FunctionField)
+  exact hcurve ▸ equation_map_polyToFunctionField_yGen (W := (W⁄F'))
+
+def kw_functionFieldMapAlongGeneral : (W⁄F).FunctionField →ₐ[F] (W⁄F').FunctionField :=
+  pointPullbackHomTo (kw_equation_map_polyToFunctionField_yGen_over_baseGeneral W F F')
+    ((injective_iff_map_eq_zero _).mpr fun p hp =>
+      transcendental_iff.mp (kw_transcendental_polyToFunctionField_X_over_baseGeneral W F F') p
+        hp)
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_functionFieldMapAlongGeneral_polyToFunctionField_X :
+    kw_functionFieldMapAlongGeneral W F F' (polyToFunctionField (W⁄F) X)
+      = polyToFunctionField (W⁄F') X :=
+  pointPullbackHomTo_polyToFunctionField_X _ _
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_functionFieldMapAlongGeneral_yGen :
+    kw_functionFieldMapAlongGeneral W F F' (yGen (W⁄F)) = yGen (W⁄F') :=
+  pointPullbackHomTo_yGen _ _
+
+def KwFunctionFieldTensorIsDomainGeneral : Prop :=
+  IsDomain ((W⁄F).FunctionField ⊗[F] F')
+
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+scoped instance kw_isScalarTower_base_right_tensorGeneral :
+    IsScalarTower R₀ F' ((W⁄F).FunctionField ⊗[F] F') := by
+  refine IsScalarTower.of_algebraMap_eq' (RingHom.ext fun r => ?_)
+  rw [RingHom.comp_apply, Algebra.TensorProduct.right_algebraMap_apply,
+    IsScalarTower.algebraMap_apply R₀ F F',
+    show algebraMap R₀ ((W⁄F).FunctionField ⊗[F] F') r
+      = (algebraMap F ((W⁄F).FunctionField ⊗[F] F')) (algebraMap R₀ F r) from
+        IsScalarTower.algebraMap_apply R₀ F ((W⁄F).FunctionField ⊗[F] F') r,
+    Algebra.TensorProduct.algebraMap_apply, Algebra.algebraMap_eq_smul_one,
+    Algebra.algebraMap_eq_smul_one, TensorProduct.smul_tmul, Algebra.algebraMap_eq_smul_one]
+
+section FracHom
+
+variable [IsDomain ((W⁄F).FunctionField ⊗[F] F')]
+
+scoped instance kw_isScalarTower_base_right_fracTensorGeneral :
+    IsScalarTower R₀ F' (FractionRing ((W⁄F).FunctionField ⊗[F] F')) :=
+  IsScalarTower.of_algebraMap_eq fun r =>
+    (IsScalarTower.algebraMap_apply R₀ ((W⁄F).FunctionField ⊗[F] F')
+        (FractionRing ((W⁄F).FunctionField ⊗[F] F')) r).trans <|
+      (congrArg (algebraMap ((W⁄F).FunctionField ⊗[F] F')
+          (FractionRing ((W⁄F).FunctionField ⊗[F] F')))
+        (IsScalarTower.algebraMap_apply R₀ F' ((W⁄F).FunctionField ⊗[F] F') r)).trans
+      (IsScalarTower.algebraMap_apply F' ((W⁄F).FunctionField ⊗[F] F')
+        (FractionRing ((W⁄F).FunctionField ⊗[F] F')) (algebraMap R₀ F' r)).symm
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] [IsDomain ((W⁄F).FunctionField ⊗[F] F')] in
+theorem kw_equation_tensorFracXYGeneral :
+    ((W⁄F').map (algebraMap F' (FractionRing ((W⁄F).FunctionField ⊗[F] F')))).toAffine.Equation
+      (algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+        ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')))
+      (algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+        ((yGen (W⁄F)) ⊗ₜ[F] (1 : F'))) := by
+  have hcurve : (W⁄F').map (algebraMap F' (FractionRing ((W⁄F).FunctionField ⊗[F] F')))
+      = W⁄(FractionRing ((W⁄F).FunctionField ⊗[F] F')) := by
+    change (W.map _).map _ = W.map _
+    rw [WeierstrassCurve.map_map]; congr 1
+    exact (IsScalarTower.algebraMap_eq R₀ F'
+      (FractionRing ((W⁄F).FunctionField ⊗[F] F'))).symm
+  rw [hcurve]
+  exact Equation.baseChange (W := W) (S := R₀)
+    (f := (IsScalarTower.toAlgHom R₀ ((W⁄F).FunctionField ⊗[F] F')
+            (FractionRing ((W⁄F).FunctionField ⊗[F] F'))).comp
+          (Algebra.TensorProduct.includeLeft (R := F) (S := R₀)))
+    (equation_map_polyToFunctionField_yGen (W := (W⁄F)))
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [Algebra R₀ F'] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [IsScalarTower R₀ F F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] [IsDomain ((W⁄F).FunctionField ⊗[F] F')] in
+theorem kw_transcendental_tensorFracXGeneral :
+    Function.Injective (Polynomial.aeval (R := F')
+      (algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+        ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')))) := by
+  rw [show algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+        ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F'))
+      = IsScalarTower.toAlgHom F' ((W⁄F).FunctionField ⊗[F] F')
+          (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+          ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')) from rfl,
+    Polynomial.aeval_algHom]
+  refine (IsFractionRing.injective ((W⁄F).FunctionField ⊗[F] F')
+    (FractionRing ((W⁄F).FunctionField ⊗[F] F'))).comp ?_
+  have heq : (Polynomial.aeval (R := F')
+        ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')
+          : (W⁄F).FunctionField ⊗[F] F')).toRingHom
+      = ((Algebra.TensorProduct.map
+            (Polynomial.aeval (R := F) (polyToFunctionField (W⁄F) X))
+            (AlgHom.id F F')).toRingHom.comp
+          (Algebra.TensorProduct.comm F F' F[X]).toAlgHom.toRingHom).comp
+          (polyEquivTensor' F F').toAlgHom.toRingHom := by
+    refine Polynomial.ringHom_ext (fun c => ?_) ?_
+    · change aeval _ (C c) = Algebra.TensorProduct.map _ _
+          (Algebra.TensorProduct.comm F F' F[X] (polyEquivTensor' F F' (C c)))
+      rw [show (polyEquivTensor' F F') (C c) = c ⊗ₜ[F] (1 : F[X]) from by
+            rw [coe_polyEquivTensor', polyEquivTensor_apply, eval₂_C]; rfl,
+        Algebra.TensorProduct.comm_tmul, Algebra.TensorProduct.map_tmul, Polynomial.aeval_C,
+        Algebra.TensorProduct.right_algebraMap_apply, AlgHom.coe_id, id_eq, map_one]
+    · change aeval _ (X : F'[X]) = Algebra.TensorProduct.map _ _
+          (Algebra.TensorProduct.comm F F' F[X] (polyEquivTensor' F F' X))
+      rw [show (polyEquivTensor' F F') X = (1:F') ⊗ₜ[F] (X : F[X]) from by
+            rw [coe_polyEquivTensor', polyEquivTensor_apply, eval₂_X],
+        Algebra.TensorProduct.comm_tmul, Algebra.TensorProduct.map_tmul, Polynomial.aeval_X,
+        AlgHom.coe_id, id_eq, Polynomial.aeval_X]
+  have hinj : Function.Injective
+      (((Algebra.TensorProduct.map
+          (Polynomial.aeval (R := F) (polyToFunctionField (W⁄F) X))
+          (AlgHom.id F F')).toRingHom.comp
+        (Algebra.TensorProduct.comm F F' F[X]).toAlgHom.toRingHom).comp
+        (polyEquivTensor' F F').toAlgHom.toRingHom) :=
+    ((Module.Flat.rTensor_preserves_injective_linearMap (M := F')
+        (Polynomial.aeval (R := F) (polyToFunctionField (W⁄F) X)).toLinearMap
+        ((injective_iff_map_eq_zero _).mpr fun p hp =>
+          transcendental_iff.mp (transcendental_polyToFunctionField_X (W := (W⁄F))) p hp)).comp
+      (Algebra.TensorProduct.comm F F' F[X]).injective).comp (polyEquivTensor' F F').injective
+  intro p q hpq
+  refine hinj ?_
+  have := DFunLike.congr_fun heq
+  exact (this p).symm.trans (hpq.trans (this q))
+
+def kw_functionFieldTensorFracHomGeneral :
+    (W⁄F').FunctionField →ₐ[F'] FractionRing ((W⁄F).FunctionField ⊗[F] F') :=
+  pointPullbackHomTo (kw_equation_tensorFracXYGeneral W F F')
+    (kw_transcendental_tensorFracXGeneral W F F')
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_functionFieldTensorFracHomGeneral_X :
+    kw_functionFieldTensorFracHomGeneral W F F' (polyToFunctionField (W⁄F') X)
+      = algebraMap ((W⁄F).FunctionField ⊗[F] F') _
+          ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')) :=
+  pointPullbackHomTo_polyToFunctionField_X _ _
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_functionFieldTensorFracHomGeneral_yGen :
+    kw_functionFieldTensorFracHomGeneral W F F' (yGen (W⁄F'))
+      = algebraMap ((W⁄F).FunctionField ⊗[F] F') _ ((yGen (W⁄F)) ⊗ₜ[F] (1 : F')) :=
+  pointPullbackHomTo_yGen _ _
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_functionFieldTensorFracHomGeneral_bijective :
+    Function.Bijective (kw_functionFieldTensorFracHomGeneral W F F') := by
+  refine ⟨(kw_functionFieldTensorFracHomGeneral W F F').injective, ?_⟩
+  set ψ := kw_functionFieldTensorFracHomGeneral W F F'
+  have hκ : (ψ.restrictScalars F).comp (kw_functionFieldMapAlongGeneral W F F')
+      = (IsScalarTower.toAlgHom F ((W⁄F).FunctionField ⊗[F] F')
+          (FractionRing ((W⁄F).FunctionField ⊗[F] F'))).comp
+          (Algebra.TensorProduct.includeLeft (R := F)) := by
+    refine kw_functionField_algHom_ext ?_ ?_
+    · change ψ (kw_functionFieldMapAlongGeneral W F F' (polyToFunctionField (W⁄F) X)) = _
+      rw [kw_functionFieldMapAlongGeneral_polyToFunctionField_X,
+        kw_functionFieldTensorFracHomGeneral_X]
+      rfl
+    · change ψ (kw_functionFieldMapAlongGeneral W F F' (yGen (W⁄F))) = _
+      rw [kw_functionFieldMapAlongGeneral_yGen, kw_functionFieldTensorFracHomGeneral_yGen]
+      rfl
+  have hT_sub : ∀ t : (W⁄F).FunctionField ⊗[F] F',
+      algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing _) t ∈ ψ.toRingHom.fieldRange := by
+    intro t
+    induction t with
+    | add _ _ hx hy => simp only [map_add]; exact add_mem hx hy
+    | tmul a c =>
+      rw [show (a ⊗ₜ[F] c : (W⁄F).FunctionField ⊗[F] F') = (a ⊗ₜ[F] 1) * (1 ⊗ₜ[F] c) from
+            by rw [Algebra.TensorProduct.tmul_mul_tmul, mul_one, one_mul],
+        map_mul]
+      refine mul_mem ?_ ⟨algebraMap F' _ c, ?_⟩
+      · exact ⟨kw_functionFieldMapAlongGeneral W F F' a, DFunLike.congr_fun hκ a⟩
+      · simp only [AlgHom.toRingHom_eq_coe, RingHom.coe_coe, ψ.commutes,
+          IsScalarTower.algebraMap_apply F' ((W⁄F).FunctionField ⊗[F] F')
+            (FractionRing ((W⁄F).FunctionField ⊗[F] F')),
+          Algebra.TensorProduct.right_algebraMap_apply]
+  intro z
+  obtain ⟨t, s, _, rfl⟩ := IsFractionRing.div_surjective
+    (A := (W⁄F).FunctionField ⊗[F] F') (K := FractionRing _) z
+  exact div_mem (hT_sub t) (hT_sub s)
+
+def kw_functionFieldTensorFracEquivGeneral :
+    (W⁄F').FunctionField ≃ₐ[F'] FractionRing ((W⁄F).FunctionField ⊗[F] F') :=
+  AlgEquiv.ofBijective _ (kw_functionFieldTensorFracHomGeneral_bijective W F F')
+
+end FracHom
+end Setup
+end ModularCurve
+end
+
+section
+
+
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  ModularCurve \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve"
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial"
+p2m_open_scoped "TensorProduct Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial"
+
+namespace ModularCurve
+
+universe u
+
+section Setup
+
+variable {R₀ : Type u} [Field R₀]
+variable (W : WeierstrassCurve R₀) [W.IsElliptic]
+variable (F : Type u) [Field F] [Algebra R₀ F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra R₀ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower R₀ F F']
+
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F).toAffine]
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F').toAffine]
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+section FFDomain
+
+local notation3 "CR" => (W⁄F).toAffine.CoordinateRing
+local notation3 "FFₗ" => (W⁄F).FunctionField
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [Algebra R₀ F'] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [IsScalarTower R₀ F F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_coordinateRingMap_basisGeneral (i : ℕ × Fin 2) :
+    CoordinateRing.map (W⁄F).toAffine (algebraMap F F')
+        (kw_coordinateRingBasis (W⁄F).toAffine i)
+      = kw_coordinateRingBasis ((W⁄F).toAffine.map (algebraMap F F')) i := by
+  obtain ⟨n, j⟩ := i
+  simp only [kw_coordinateRingBasis, Module.Basis.smulTower_apply,
+    Polynomial.coe_basisMonomials, CoordinateRing.map_smul]
+  congr 1
+  · simp [Polynomial.map_monomial]
+  · rcases j with ⟨j, hj⟩
+    interval_cases j <;>
+      simp [CoordinateRing.basis_apply, CoordinateRing.map,
+        AdjoinRoot.lift_root, AdjoinRoot.powerBasis'_gen]
+
+def kw_coordinateRingMapAlongGeneral :
+    CR →ₐ[F] ((W⁄F).toAffine.map (algebraMap F F')).CoordinateRing where
+  __ := CoordinateRing.map (W⁄F).toAffine (algebraMap F F')
+  commutes' r := by
+    simp only [RingHom.toMonoidHom_eq_coe, OneHom.toFun_eq_coe, MonoidHom.toOneHom_coe,
+      MonoidHom.coe_ofClass]
+    change CoordinateRing.map (W⁄F).toAffine (algebraMap F F') (algebraMap F CR r) = algebraMap F _
+      r
+    rw [IsScalarTower.algebraMap_apply F F[X] CR,
+      show (algebraMap F F[X] r) = Polynomial.C r from rfl,
+      show (algebraMap F[X] CR) (C r) = (C r : F[X]) • (1 : CR) by
+        rw [Algebra.smul_def, mul_one],
+      CoordinateRing.map_smul, map_one, Polynomial.map_C,
+      IsScalarTower.algebraMap_apply F F' ((W⁄F).toAffine.map (algebraMap F F')).CoordinateRing,
+      IsScalarTower.algebraMap_apply F' F'[X]
+        ((W⁄F).toAffine.map (algebraMap F F')).CoordinateRing,
+      show (algebraMap F' F'[X]) ((algebraMap F F') r) = Polynomial.C ((algebraMap F F') r)
+        from rfl,
+      Algebra.smul_def, mul_one]
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [Algebra R₀ F'] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [IsScalarTower R₀ F F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_coordinateRingTensor_isDomainGeneral : IsDomain (CR ⊗[F] F') := by
+  suffices h : IsDomain (F' ⊗[F] CR) by
+    have := h
+    exact Function.Injective.isDomain (Algebra.TensorProduct.comm F CR F').toRingHom
+      (Algebra.TensorProduct.comm F CR F').injective
+  set W'' := (W⁄F).toAffine.map (algebraMap F F') with hW''
+  let θ : F' ⊗[F] CR →ₐ[F'] W''.CoordinateRing :=
+    AlgHom.liftEquiv F F' CR W''.CoordinateRing (kw_coordinateRingMapAlongGeneral W F F')
+  have hθ : Function.Injective θ := by
+    let bT : Module.Basis (ℕ × Fin 2) F' (F' ⊗[F] CR) :=
+      Algebra.TensorProduct.basis F' (kw_coordinateRingBasis (W⁄F).toAffine)
+    let bD : Module.Basis (ℕ × Fin 2) F' W''.CoordinateRing := kw_coordinateRingBasis W''
+    have key : ∀ i, θ.toLinearMap (bT i) = (bT.equiv bD (Equiv.refl _)) (bT i) := fun i => by
+      rw [Module.Basis.equiv_apply, Equiv.refl_apply, AlgHom.toLinearMap_apply]
+      simp only [bT, Algebra.TensorProduct.basis_apply, θ, AlgHom.liftEquiv_tmul, one_smul]
+      exact kw_coordinateRingMap_basisGeneral W F F' i
+    have heq : (θ : F' ⊗[F] CR → W''.CoordinateRing) = bT.equiv bD (Equiv.refl _) :=
+      funext fun x => DFunLike.congr_fun (bT.ext key : θ.toLinearMap = _) x
+    exact heq ▸ (bT.equiv bD (Equiv.refl _)).injective
+  exact Function.Injective.isDomain θ.toRingHom hθ
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [Algebra R₀ F'] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [IsScalarTower R₀ F F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_functionFieldTensorIsDomain_dischargeGeneral :
+    KwFunctionFieldTensorIsDomainGeneral W F F' := by
+  change IsDomain (FFₗ ⊗[F] F')
+  have hCR : IsDomain (CR ⊗[F] F') := kw_coordinateRingTensor_isDomainGeneral W F F'
+  let : Algebra (CR ⊗[F] F') (FFₗ ⊗[F] F') :=
+    (Algebra.TensorProduct.map (IsScalarTower.toAlgHom F CR FFₗ)
+      (AlgHom.id F F')).toRingHom.toAlgebra
+  have hst : IsScalarTower CR (CR ⊗[F] F') (FFₗ ⊗[F] F') :=
+    IsScalarTower.of_algebraMap_eq (R := CR) (S := CR ⊗[F] F') (A := FFₗ ⊗[F] F') fun c => by
+      change Algebra.TensorProduct.map (IsScalarTower.toAlgHom F CR FFₗ) (AlgHom.id F F')
+          (algebraMap CR (CR ⊗[F] F') c) = algebraMap CR (FFₗ ⊗[F] F') c
+      rfl
+  have hloc : IsLocalization
+      (Algebra.algebraMapSubmonoid (CR ⊗[F] F') (nonZeroDivisors CR)) (FFₗ ⊗[F] F') :=
+    IsLocalization.tensorProduct_tensorProduct F F' (nonZeroDivisors CR) FFₗ (by
+      ext x; simp [RingHom.algebraMap_toAlgebra, Algebra.TensorProduct.map_tmul])
+  have hle : Algebra.algebraMapSubmonoid (CR ⊗[F] F') (nonZeroDivisors CR)
+      ≤ nonZeroDivisors (CR ⊗[F] F') := by
+    rintro _ ⟨c, hc, rfl⟩
+    refine mem_nonZeroDivisors_of_ne_zero ?_
+    have hinj : Function.Injective (algebraMap CR (CR ⊗[F] F')) :=
+      Algebra.TensorProduct.includeLeft_injective (S := F) (algebraMap F F').injective
+    exact fun h => (nonZeroDivisors.ne_zero hc) (hinj (by simp only [map_zero] at h ⊢; exact h))
+  exact IsLocalization.isDomain_of_le_nonZeroDivisors
+    (M := Algebra.algebraMapSubmonoid (CR ⊗[F] F') (nonZeroDivisors CR)) _ hle
+
+end FFDomain
+end Setup
+end ModularCurve
+end
+
+section
+
+section
+
+p2m_open "IsDedekindDomain \
+  P2MW.S_OVERLONG_c68ce07f.\
+  IsDedekindDomain Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg"
+
+section Chart
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R F] [IsFractionRing R F]
+variable (w : Place K F)
+scoped instance (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    (center R w hw).IsPrime :=
+  Ideal.comap_isPrime _ _
+end Chart
+end Place
+end AlgebraicCurve
+end
+
+section
+
+
+section
+
+p2m_open "P2MW.S_OVERLONG_c68ce07f.ModularCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve"
+
+namespace ModularCurve
+
+universe u
+
+attribute [local instance] Classical.propDecidable
+section BaseChangeMint
+
+def KwD5BetweenCurvesFFSeamBaseChange : Prop :=
+  ∀ (R₀ : Type) [Field R₀]
+    (E₀ E₀' : WeierstrassCurve R₀) [E₀.IsElliptic] [E₀'.IsElliptic]
+    (F F' : Type) [Field F] [Field F'] [Algebra R₀ F] [Algebra R₀ F']
+    [DecidableEq F] [DecidableEq F'] [IsAlgClosed F] [IsAlgClosed F']
+    [CharZero F] [CharZero F']
+    [(E₀⁄F).IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀⁄F).toAffine] [(E₀'⁄F).IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀'⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀'⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀'⁄F).toAffine] [(E₀⁄F').IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀⁄F').toAffine] [(E₀'⁄F').IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀'⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀'⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀'⁄F').toAffine]
+    (_σ : F →ₐ[R₀] F')
+    (ι₀ : (E₀'⁄F).toAffine.FunctionField →ₐ[F] (E₀⁄F).toAffine.FunctionField)
+    (hι₀ : ι₀.toRingHom.IsIntegral) (hfin₀ : FiniteAlong F ι₀)
+    (N : ℕ) [NeZero N],
+    IsAddCyclic (AddMonoidHom.ker
+      (pointMapOfPushforward ι₀ hι₀ hfin₀ (normFormulaAlong_of_elliptic ι₀ hfin₀))) →
+    Nat.card (AddMonoidHom.ker
+      (pointMapOfPushforward ι₀ hι₀ hfin₀ (normFormulaAlong_of_elliptic ι₀ hfin₀))) = N →
+    ∃ (ι₁ : (E₀'⁄F').toAffine.FunctionField →ₐ[F'] (E₀⁄F').toAffine.FunctionField)
+      (hι₁ : ι₁.toRingHom.IsIntegral) (hfin₁ : FiniteAlong F' ι₁),
+      IsAddCyclic (AddMonoidHom.ker
+        (pointMapOfPushforward ι₁ hι₁ hfin₁ (normFormulaAlong_of_elliptic ι₁ hfin₁))) ∧
+      Nat.card (AddMonoidHom.ker
+        (pointMapOfPushforward ι₁ hι₁ hfin₁ (normFormulaAlong_of_elliptic ι₁ hfin₁))) = N
+
+end BaseChangeMint
+end ModularCurve
+end
+end
+
+section
+
+
+section
+
+p2m_open "P2MW.S_OVERLONG_c68ce07f.ModularCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve"
+p2m_open_scoped "TensorProduct Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial Polynomial.Bivariate \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial.Bivariate"
+
+namespace ModularCurve
+
+universe u
+
+attribute [local instance] Classical.propDecidable
+
+section BetweenCurvesTensor
+
+variable {R₀ : Type u} [Field R₀]
+variable (E₀ E₀' : WeierstrassCurve R₀) [E₀.IsElliptic] [E₀'.IsElliptic]
+variable (F : Type u) [Field F] [Algebra R₀ F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra R₀ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower R₀ F F']
+variable [(E₀⁄F).IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀⁄F).toAffine] [(E₀'⁄F).IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀'⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀'⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀'⁄F).toAffine] [(E₀⁄F').IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀⁄F').toAffine] [(E₀'⁄F').IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀'⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀'⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀'⁄F').toAffine]
+variable (ι₀ : (E₀'⁄F).toAffine.FunctionField →ₐ[F] (E₀⁄F).toAffine.FunctionField)
+
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+def kw_surge_hgf4_bcTensorIota :
+    (E₀'⁄F).toAffine.FunctionField ⊗[F] F' →ₐ[F] (E₀⁄F).toAffine.FunctionField ⊗[F] F' :=
+  Algebra.TensorProduct.map ι₀ (AlgHom.id F F')
+
+omit [E₀.IsElliptic] [E₀'.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+  [Algebra R₀ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F'] [IsScalarTower R₀ F F']
+  [WeierstrassCurve.IsElliptic E₀⁄F] [(toAffine E₀⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F)] [(toAffine E₀⁄F).AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀'⁄F] [(toAffine E₀'⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F)] [(toAffine E₀'⁄F).AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀⁄F'] [(toAffine E₀⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F')] [(toAffine E₀⁄F').AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀'⁄F'] [(toAffine E₀'⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F')] [(toAffine E₀'⁄F').AbelTheorem] in
+theorem kw_surge_hgf4_bcTensorIota_tmul (a : (E₀'⁄F).toAffine.FunctionField) (c : F') :
+    kw_surge_hgf4_bcTensorIota E₀ E₀' F F' ι₀ (a ⊗ₜ[F] c) = (ι₀ a) ⊗ₜ[F] c := by
+  simp [kw_surge_hgf4_bcTensorIota, Algebra.TensorProduct.map_tmul]
+
+omit [E₀.IsElliptic] [E₀'.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+  [Algebra R₀ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F'] [IsScalarTower R₀ F F']
+  [WeierstrassCurve.IsElliptic E₀⁄F] [(toAffine E₀⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F)] [(toAffine E₀⁄F).AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀'⁄F] [(toAffine E₀'⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F)] [(toAffine E₀'⁄F).AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀⁄F'] [(toAffine E₀⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F')] [(toAffine E₀⁄F').AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀'⁄F'] [(toAffine E₀'⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F')] [(toAffine E₀'⁄F').AbelTheorem] in
+theorem kw_surge_hgf4_bcTensorIota_injective :
+    Function.Injective (kw_surge_hgf4_bcTensorIota E₀ E₀' F F' ι₀) :=
+  Module.Flat.rTensor_preserves_injective_linearMap (M := F') ι₀.toLinearMap ι₀.injective
+
+variable [IsDomain ((E₀⁄F).toAffine.FunctionField ⊗[F] F')]
+variable [IsDomain ((E₀'⁄F).toAffine.FunctionField ⊗[F] F')]
+
+def kw_surge_hgf4_bcTensorFracIota :
+    FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F')
+      →+* FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F') :=
+  IsFractionRing.map (K := FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F'))
+    (L := FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F'))
+    (kw_surge_hgf4_bcTensorIota_injective E₀ E₀' F F' ι₀)
+
+omit [IsDomain ((toAffine E₀'⁄F).FunctionField ⊗[F] F')] in
+omit [E₀.IsElliptic] [E₀'.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+  [Algebra R₀ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F'] [IsScalarTower R₀ F F']
+  [WeierstrassCurve.IsElliptic E₀⁄F] [(toAffine E₀⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F)] [(toAffine E₀⁄F).AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀'⁄F] [(toAffine E₀'⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F)] [(toAffine E₀'⁄F).AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀⁄F'] [(toAffine E₀⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F')] [(toAffine E₀⁄F').AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀'⁄F'] [(toAffine E₀'⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F')] [(toAffine E₀'⁄F').AbelTheorem] in
+theorem kw_surge_hgf4_bcTensorFracIota_algebraMap
+    (t : (E₀'⁄F).toAffine.FunctionField ⊗[F] F') :
+    kw_surge_hgf4_bcTensorFracIota E₀ E₀' F F' ι₀
+        (algebraMap ((E₀'⁄F).toAffine.FunctionField ⊗[F] F') _ t)
+      = algebraMap ((E₀⁄F).toAffine.FunctionField ⊗[F] F') _
+          (kw_surge_hgf4_bcTensorIota E₀ E₀' F F' ι₀ t) := by
+  unfold kw_surge_hgf4_bcTensorFracIota IsFractionRing.map
+  exact IsLocalization.map_eq
+    (T := nonZeroDivisors ((E₀⁄F).toAffine.FunctionField ⊗[F] F')) _ t
+
+omit [E₀.IsElliptic] [E₀'.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+  [Algebra R₀ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F'] [IsScalarTower R₀ F F']
+  [WeierstrassCurve.IsElliptic E₀⁄F] [(toAffine E₀⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F)] [(toAffine E₀⁄F).AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀'⁄F] [(toAffine E₀'⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F)] [(toAffine E₀'⁄F).AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀⁄F'] [(toAffine E₀⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F')] [(toAffine E₀⁄F').AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀'⁄F'] [(toAffine E₀'⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F')] [(toAffine E₀'⁄F').AbelTheorem]
+  [IsDomain ((toAffine E₀⁄F).FunctionField ⊗[F] F')]
+  [IsDomain ((toAffine E₀'⁄F).FunctionField ⊗[F] F')] in
+theorem kw_surge_hgf4_bcTensorIota_finite (hfin₀ : FiniteAlong F ι₀) :
+    (kw_surge_hgf4_bcTensorIota E₀ E₀' F F' ι₀).toRingHom.Finite :=
+  RingHom.Finite.tensorProductMap (f := ι₀) hfin₀ (g := AlgHom.id F F') (RingHom.Finite.id F')
+
+def kw_surge_hgf4_bcTensorFracIotaAlg :
+    FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F')
+      →ₐ[F'] FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F') :=
+  { kw_surge_hgf4_bcTensorFracIota E₀ E₀' F F' ι₀ with
+    commutes' := fun c => by
+      change kw_surge_hgf4_bcTensorFracIota E₀ E₀' F F' ι₀ (algebraMap F' _ c)
+          = algebraMap F' _ c
+      rw [IsScalarTower.algebraMap_apply F' ((E₀'⁄F).toAffine.FunctionField ⊗[F] F')
+          (FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F')),
+        Algebra.TensorProduct.right_algebraMap_apply,
+        kw_surge_hgf4_bcTensorFracIota_algebraMap E₀ E₀' F F' ι₀,
+        kw_surge_hgf4_bcTensorIota_tmul, map_one,
+        IsScalarTower.algebraMap_apply F' ((E₀⁄F).toAffine.FunctionField ⊗[F] F')
+          (FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F')),
+        Algebra.TensorProduct.right_algebraMap_apply] }
+
+def kw_surge_hgf4_bcIota₁ :
+    (E₀'⁄F').toAffine.FunctionField →ₐ[F'] (E₀⁄F').toAffine.FunctionField :=
+  let ψE := kw_functionFieldTensorFracEquivGeneral E₀ F F'
+  let ψE' := kw_functionFieldTensorFracEquivGeneral E₀' F F'
+  (ψE.symm.toAlgHom.comp (kw_surge_hgf4_bcTensorFracIotaAlg E₀ E₀' F F' ι₀)).comp
+    ψE'.toAlgHom
+
+omit [E₀.IsElliptic] [E₀'.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+  [Algebra R₀ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F'] [IsScalarTower R₀ F F']
+  [WeierstrassCurve.IsElliptic E₀⁄F] [(toAffine E₀⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F)] [(toAffine E₀⁄F).AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀'⁄F] [(toAffine E₀'⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F)] [(toAffine E₀'⁄F).AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀⁄F'] [(toAffine E₀⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F')] [(toAffine E₀⁄F').AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀'⁄F'] [(toAffine E₀'⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F')] [(toAffine E₀'⁄F').AbelTheorem] in
+theorem kw_surge_hgf4_bcTensorFracIotaSeam (hfin₀ : FiniteAlong F ι₀) :
+    (kw_surge_hgf4_bcTensorFracIota E₀ E₀' F F' ι₀).Finite ∧
+    (letI := (kw_surge_hgf4_bcTensorFracIota E₀ E₀' F F' ι₀).toAlgebra
+     @Module.finrank (FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F'))
+       (FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F')) _ _ Algebra.toModule)
+      = finrankAlong F ι₀ := by
+  classical
+  let FF := (E₀⁄F).toAffine.FunctionField
+  let FF' := (E₀'⁄F).toAffine.FunctionField
+  let T := (E₀⁄F).toAffine.FunctionField ⊗[F] F'
+  let T' := (E₀'⁄F).toAffine.FunctionField ⊗[F] F'
+  let FrT := FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F')
+  let FrT' := FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F')
+  let ιT : T' →+* T := (kw_surge_hgf4_bcTensorIota E₀ E₀' F F' ι₀).toRingHom
+  let ιFr : FrT' →+* FrT := kw_surge_hgf4_bcTensorFracIota E₀ E₀' F F' ι₀
+  have hιT_inj : Function.Injective ιT :=
+    kw_surge_hgf4_bcTensorIota_injective E₀ E₀' F F' ι₀
+  have hιT_fin : ιT.Finite := kw_surge_hgf4_bcTensorIota_finite E₀ E₀' F F' ι₀ hfin₀
+  have hιFr_am : ∀ t : T', ιFr (algebraMap T' FrT' t) = algebraMap T FrT (ιT t) :=
+    kw_surge_hgf4_bcTensorFracIota_algebraMap E₀ E₀' F F' ι₀
+  let algι : Algebra FF' FF := ι₀.toRingHom.toAlgebra
+  let modι : Module FF' FF := Algebra.toModule
+  have hsmul_ι : ∀ (c : FF') (x : FF), c • x = ι₀ c * x := fun c x => rfl
+  have hfinFF : Module.Finite FF' FF := hfin₀
+  have hfreeFF : Module.Free FF' FF := Module.Free.of_divisionRing FF' FF
+  let D := finrankAlong F ι₀
+  let b : Module.Basis (Fin D) FF' FF := Module.finBasisOfFinrankEq FF' FF (n := D) rfl
+  have hrepr_mul : ∀ (c : FF') (x : FF) (j : Fin D),
+      b.repr (ι₀ c * x) j = c * b.repr x j := fun c x j => by
+    rw [← hsmul_ι, map_smul, Finsupp.smul_apply, smul_eq_mul]
+  let e : Fin D → T := fun i => (b i) ⊗ₜ[F] (1 : F')
+  let bFr : Fin D → FrT := fun i => algebraMap T FrT (e i)
+  have hspanT : ∀ t : T, ∃ c : Fin D → T', t = ∑ i, ιT (c i) * e i := by
+    intro t
+    induction t using TensorProduct.inductionOn with
+    | add x y hx hy =>
+      obtain ⟨cx, hx⟩ := hx; obtain ⟨cy, hy⟩ := hy
+      exact ⟨cx + cy, by simp only [Pi.add_apply, map_add, add_mul,
+        Finset.sum_add_distrib, ← hx, ← hy]⟩
+    | tmul a c =>
+      refine ⟨fun i => (b.repr a i) ⊗ₜ[F] c, ?_⟩
+      have hb_sum : a = ∑ i, ι₀ (b.repr a i) * b i := by
+        conv_lhs => rw [← b.linearCombination_repr a, Finsupp.linearCombination_apply,
+          Finsupp.sum_fintype _ _ (fun i => by rw [hsmul_ι, map_zero, zero_mul])]
+        exact Finset.sum_congr rfl fun i _ => hsmul_ι _ _
+      calc (a ⊗ₜ[F] c : T)
+          = (∑ i, ι₀ (b.repr a i) * b i) ⊗ₜ[F] c := by rw [← hb_sum]
+        _ = ∑ i, ιT ((b.repr a i) ⊗ₜ[F] c) * e i := by
+            rw [TensorProduct.sum_tmul]
+            refine Finset.sum_congr rfl fun i _ => ?_
+            show (ι₀ (b.repr a i) * b i) ⊗ₜ[F] c = ιT ((b.repr a i) ⊗ₜ[F] c) * e i
+            rw [show ιT ((b.repr a i) ⊗ₜ[F] c) = (ι₀ (b.repr a i)) ⊗ₜ[F] c from
+                  kw_surge_hgf4_bcTensorIota_tmul E₀ E₀' F F' ι₀ _ _,
+              Algebra.TensorProduct.tmul_mul_tmul, mul_one]
+  have hliT : ∀ c : Fin D → T', ∑ i, ιT (c i) * e i = 0 → ∀ j, c j = 0 := by
+    intro c hc j
+    let pj : FF →ₗ[F] FF' :=
+      { toFun := fun x => b.repr x j
+        map_add' := fun x y => by simp only [map_add, Finsupp.add_apply]
+        map_smul' := fun f x => by
+          simp only [RingHom.id_apply, Algebra.smul_def]
+          have h := hrepr_mul (algebraMap F FF' f) x j
+          rwa [ι₀.commutes] at h }
+    let Ej : T →ₗ[F] T' := LinearMap.rTensor F' pj
+    have hEj_key : ∀ (a : T') (i : Fin D),
+        Ej (ιT a * e i) = if i = j then a else 0 := by
+      intro a i
+      induction a using TensorProduct.inductionOn with
+      | add x y hx hy =>
+        simp only [map_add, add_mul, hx, hy]; split_ifs <;> simp
+      | tmul x c' =>
+        rw [show ιT ((x : FF') ⊗ₜ[F] c') = (ι₀ x) ⊗ₜ[F] c' from
+              kw_surge_hgf4_bcTensorIota_tmul E₀ E₀' F F' ι₀ _ _,
+            Algebra.TensorProduct.tmul_mul_tmul, mul_one]
+        change (pj (ι₀ x * b i)) ⊗ₜ[F] c' = if i = j then (x : FF') ⊗ₜ[F] c' else 0
+        rw [show pj (ι₀ x * b i) = if i = j then x else 0 from ?_]
+        · split_ifs with h
+          · rfl
+          · exact TensorProduct.zero_tmul _ c'
+        · change b.repr (ι₀ x * b i) j = if i = j then x else 0
+          rw [hrepr_mul, b.repr_self, Finsupp.single_apply]
+          split_ifs with h <;> simp
+    have hc' : Ej (∑ i, ιT (c i) * e i) = 0 := by rw [hc, map_zero]
+    simpa only [map_sum, hEj_key, Finset.sum_ite_eq', Finset.mem_univ, ite_true] using hc'
+  have hint : ∀ s : T, s ≠ 0 → ∃ (u : T) (s₀ : T'), s₀ ≠ 0 ∧ s * u = ιT s₀ := by
+    intro s hs
+    obtain ⟨p, hp_monic, hp_eval⟩ : ιT.IsIntegralElem s := hιT_fin.to_isIntegral s
+    obtain ⟨q, hq_eq, hq_ndvd⟩ := Polynomial.exists_eq_pow_rootMultiplicity_mul_and_not_dvd p
+      hp_monic.ne_zero 0
+    simp only [Polynomial.C_0, sub_zero] at hq_eq hq_ndvd
+    have hq0 : q.coeff 0 ≠ 0 := fun h => hq_ndvd (Polynomial.X_dvd_iff.mpr h)
+    have hqs : q.eval₂ ιT s = 0 := by
+      have h := hp_eval
+      rw [hq_eq, Polynomial.eval₂_mul, Polynomial.eval₂_pow, Polynomial.eval₂_X,
+        mul_eq_zero] at h
+      exact h.resolve_left (pow_ne_zero _ hs)
+    have h3 : ιT (q.coeff 0) + s * (q.divX).eval₂ ιT s = 0 := by
+      have h := congrArg (Polynomial.eval₂ ιT s) (Polynomial.divX_mul_X_add q)
+      rw [Polynomial.eval₂_add, Polynomial.eval₂_mul, Polynomial.eval₂_X,
+        Polynomial.eval₂_C, hqs] at h
+      simpa only [add_comm, mul_comm] using h
+    exact ⟨(q.divX).eval₂ ιT s, -q.coeff 0, neg_ne_zero.mpr hq0,
+      by rw [map_neg]; exact eq_neg_of_add_eq_zero_right h3⟩
+  have hspanFr : ∀ z : FrT, ∃ d : Fin D → FrT', z = ∑ i, ιFr (d i) * bFr i := by
+    intro z
+    obtain ⟨t, s, _, rfl⟩ := IsFractionRing.div_surjective (A := T) (K := FrT) z
+    rcases eq_or_ne s 0 with rfl | hs'
+    · exact ⟨0, by simp⟩
+    obtain ⟨u, s₀, hs₀, hsu⟩ := hint s hs'
+    have hιTs₀ : ιT s₀ ≠ 0 := fun h => hs₀ (hιT_inj (h.trans (map_zero ιT).symm))
+    have hu_ne : u ≠ 0 := fun h => hιTs₀ (by rw [← hsu, h, mul_zero])
+    obtain ⟨c, hc⟩ := hspanT (t * u)
+    refine ⟨fun i => (algebraMap T' FrT' s₀)⁻¹ * algebraMap T' FrT' (c i), ?_⟩
+    have hum := (map_ne_zero_iff _ (IsFractionRing.injective T FrT)).mpr hu_ne
+    have hz : (algebraMap T FrT t) / (algebraMap T FrT s)
+        = (algebraMap T FrT (ιT s₀))⁻¹ * algebraMap T FrT (t * u) := by
+      rw [← div_eq_inv_mul, ← hsu, map_mul, map_mul,
+        ← div_mul_div_comm, div_self hum, mul_one]
+    rw [hz, hc, map_sum, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [map_mul, map_mul, ← hιFr_am s₀, ← hιFr_am (c i), ← map_inv₀ ιFr, mul_assoc]
+  have hliFr : ∀ d : Fin D → FrT', ∑ i, ιFr (d i) * bFr i = 0 → ∀ j, d j = 0 := by
+    intro d hd j
+    obtain ⟨q, hq⟩ := IsLocalization.exist_integer_multiples_of_finset
+      (nonZeroDivisors T') (Finset.univ.image d)
+    choose p hp using fun i => hq (d i) (Finset.mem_image_of_mem d (Finset.mem_univ i))
+    have hq0 : (algebraMap T' FrT' (q : T')) ≠ 0 :=
+      (map_ne_zero_iff _ (IsFractionRing.injective T' FrT')).mpr (nonZeroDivisors.ne_zero q.2)
+    have hp' : ∀ i, algebraMap T' FrT' (p i) = algebraMap T' FrT' (q : T') * d i := fun i => by
+      rw [hp i, Algebra.smul_def]
+    have hd' : algebraMap T FrT (∑ i, ιT (p i) * e i) = 0 := by
+      have h1 : ∑ i, ιFr (algebraMap T' FrT' (q : T')) * (ιFr (d i) * bFr i) = 0 := by
+        rw [← Finset.mul_sum, hd, mul_zero]
+      rw [map_sum, ← h1]; refine Finset.sum_congr rfl fun i _ => ?_
+      rw [map_mul, ← hιFr_am (p i), ← mul_assoc, ← map_mul, ← hp' i]
+    have hpj : p j = 0 :=
+      hliT p ((IsFractionRing.injective T FrT) (by simpa using hd')) j
+    have hthis : algebraMap T' FrT' (q : T') * d j = 0 := by
+      rw [← hp' j, hpj, map_zero]
+    exact (mul_eq_zero.mp hthis).resolve_left hq0
+  let algFr : Algebra FrT' FrT := ιFr.toAlgebra
+  let modFr : Module FrT' FrT := Algebra.toModule
+  have hsmul_Fr : ∀ (c : FrT') (x : FrT), c • x = ιFr c * x := fun c x => rfl
+  have hli_modFr : LinearIndependent FrT' bFr := by
+    rw [Fintype.linearIndependent_iff]
+    intro g hg i
+    refine hliFr g ?_ i
+    simpa only [hsmul_Fr] using hg
+  have hsp_modFr : ⊤ ≤ Submodule.span FrT' (Set.range bFr) := by
+    intro z _
+    obtain ⟨d, hd⟩ := hspanFr z
+    rw [hd]
+    exact Submodule.sum_mem _ fun i _ => (hsmul_Fr (d i) (bFr i)) ▸
+      Submodule.smul_mem _ (d i) (Submodule.subset_span ⟨i, rfl⟩)
+  let bFr' : Module.Basis (Fin D) FrT' FrT := .mk hli_modFr hsp_modFr
+  refine ⟨Module.Finite.of_basis bFr', ?_⟩
+  change Module.finrank FrT' FrT = D
+  rw [Module.finrank_eq_card_basis bFr', Fintype.card_fin]
+
+omit [E₀.IsElliptic] [E₀'.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+  [DecidableEq F'] [IsAlgClosed F'] [CharZero F'] [WeierstrassCurve.IsElliptic E₀⁄F]
+  [(toAffine E₀⁄F).GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F)]
+  [(toAffine E₀⁄F).AbelTheorem] [WeierstrassCurve.IsElliptic E₀'⁄F]
+  [(toAffine E₀'⁄F).GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F)]
+  [(toAffine E₀'⁄F).AbelTheorem] [WeierstrassCurve.IsElliptic E₀⁄F']
+  [(toAffine E₀⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F')]
+  [(toAffine E₀⁄F').AbelTheorem] [WeierstrassCurve.IsElliptic E₀'⁄F']
+  [(toAffine E₀'⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F')]
+  [(toAffine E₀'⁄F').AbelTheorem] in
+theorem kw_surge_hgf4_bcIota₁_finiteAlong (hfin₀ : FiniteAlong F ι₀) :
+    FiniteAlong F' (kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀) := by
+  have hFr_fin := (kw_surge_hgf4_bcTensorFracIotaSeam E₀ E₀' F F' ι₀ hfin₀).1
+  let ψE := kw_functionFieldTensorFracEquivGeneral E₀ F F'
+  let ψE' := kw_functionFieldTensorFracEquivGeneral E₀' F F'
+  have h1 : RingHom.Finite ψE'.toAlgHom.toRingHom :=
+    RingHom.Finite.of_surjective _ ψE'.surjective
+  have h2 : RingHom.Finite ψE.symm.toAlgHom.toRingHom :=
+    RingHom.Finite.of_surjective _ ψE.symm.surjective
+  change RingHom.Finite (kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀).toRingHom
+  have hcomp : (kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀).toRingHom
+      = (ψE.symm.toAlgHom.toRingHom.comp
+          (kw_surge_hgf4_bcTensorFracIota E₀ E₀' F F' ι₀)).comp ψE'.toAlgHom.toRingHom := rfl
+  rw [hcomp]
+  exact RingHom.Finite.comp (RingHom.Finite.comp h2 hFr_fin) h1
+
+omit [E₀.IsElliptic] [E₀'.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+  [DecidableEq F'] [IsAlgClosed F'] [CharZero F'] [WeierstrassCurve.IsElliptic E₀⁄F]
+  [(toAffine E₀⁄F).GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F)]
+  [(toAffine E₀⁄F).AbelTheorem] [WeierstrassCurve.IsElliptic E₀'⁄F]
+  [(toAffine E₀'⁄F).GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F)]
+  [(toAffine E₀'⁄F).AbelTheorem] [WeierstrassCurve.IsElliptic E₀⁄F']
+  [(toAffine E₀⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F')]
+  [(toAffine E₀⁄F').AbelTheorem] [WeierstrassCurve.IsElliptic E₀'⁄F']
+  [(toAffine E₀'⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F')]
+  [(toAffine E₀'⁄F').AbelTheorem] in
+theorem kw_surge_hgf4_bcIota₁_isIntegral (hfin₀ : FiniteAlong F ι₀) :
+    (kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀).toRingHom.IsIntegral :=
+  RingHom.Finite.to_isIntegral
+    (show RingHom.Finite (kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀).toRingHom from
+      kw_surge_hgf4_bcIota₁_finiteAlong E₀ E₀' F F' ι₀ hfin₀)
+
+omit [E₀.IsElliptic] [E₀'.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+  [DecidableEq F'] [IsAlgClosed F'] [CharZero F'] [WeierstrassCurve.IsElliptic E₀⁄F]
+  [(toAffine E₀⁄F).GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F)]
+  [(toAffine E₀⁄F).AbelTheorem] [WeierstrassCurve.IsElliptic E₀'⁄F]
+  [(toAffine E₀'⁄F).GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F)]
+  [(toAffine E₀'⁄F).AbelTheorem] [WeierstrassCurve.IsElliptic E₀⁄F']
+  [(toAffine E₀⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F')]
+  [(toAffine E₀⁄F').AbelTheorem] [WeierstrassCurve.IsElliptic E₀'⁄F']
+  [(toAffine E₀'⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F')]
+  [(toAffine E₀'⁄F').AbelTheorem] in
+theorem kw_surge_hgf4_bcIota₁_finrankAlong (hfin₀ : FiniteAlong F ι₀) :
+    finrankAlong F' (kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀) = finrankAlong F ι₀ := by
+  let ψE := kw_functionFieldTensorFracEquivGeneral E₀ F F'
+  let ψE' := kw_functionFieldTensorFracEquivGeneral E₀' F F'
+  let ιFr := kw_surge_hgf4_bcTensorFracIota E₀ E₀' F F' ι₀
+  have hcomm : ∀ x, ιFr (ψE' x)
+      = ψE (kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀ x) := fun x => by
+    change ιFr (ψE' x) = ψE (ψE.symm (_))
+    exact (ψE.apply_symm_apply _).symm
+  calc finrankAlong F' (kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀)
+      = (letI := ιFr.toAlgebra
+         @Module.finrank (FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F'))
+           (FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F')) _ _ Algebra.toModule) :=
+        @Algebra.finrank_eq_of_equiv_equiv
+          (E₀'⁄F').toAffine.FunctionField (E₀⁄F').toAffine.FunctionField _ _
+          (algebraAlong (kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀))
+          _ _ _ _ ιFr.toAlgebra ψE'.toRingEquiv ψE.toRingEquiv (RingHom.ext hcomm)
+    _ = finrankAlong F ι₀ := (kw_surge_hgf4_bcTensorFracIotaSeam E₀ E₀' F F' ι₀ hfin₀).2
+
+section Naturality
+
+variable (hι₀ : ι₀.toRingHom.IsIntegral) (hfin₀ : FiniteAlong F ι₀)
+variable (σ : F →ₐ[R₀] F') (hσ : ∀ c, σ c = algebraMap F F' c)
+
+local notation "χE" => kw_functionFieldMapAlongGeneral E₀ F F'
+local notation "χE'" => kw_functionFieldMapAlongGeneral E₀' F F'
+local notation "ι₁" => kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀
+
+theorem kw_surge_hgf4_place_inv_mem_of_isUnit {K L : Type*} [Field K] [Field L] [Algebra K L]
+    (v : Place K L) {z : v.toValuationSubring} (hz : IsUnit z) :
+    ((z : L))⁻¹ ∈ v.toValuationSubring := by
+  obtain ⟨w, hw⟩ := hz.exists_right_inv
+  have hmul : (z : L) * (w : L) = 1 := by
+    have h := congrArg (fun a : v.toValuationSubring => (a : L)) hw
+    simpa using h
+  rw [inv_eq_of_mul_eq_one_right hmul]; exact w.2
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [IsAlgClosed F] [CharZero F] [IsAlgClosed F'] [CharZero F'] in
+theorem kw_surge_hgf4_toAffine_map_eq (V : WeierstrassCurve R₀) :
+    (V⁄F).toAffine.map (algebraMap F F') = (V⁄F').toAffine := by
+  classical
+  change ((V.map (algebraMap R₀ F)).map (algebraMap F F')).toAffine = (V.map (algebraMap R₀
+    F')).toAffine
+  rw [WeierstrassCurve.map_map, ← IsScalarTower.algebraMap_eq R₀ F F']
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt\
+  " in
+open
+  _root_.P2MW.S_OVERLONG_c68ce07f.WeierstrassCurve.Affine.CoordinateRing
+  in
+omit [IsAlgClosed F] [CharZero F] [IsAlgClosed F'] [CharZero F'] in
+theorem kw_surge_hgf4_χE_algebraMap_XClass (V : WeierstrassCurve R₀) [V.IsElliptic]
+    [(V⁄F).IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate (V⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (V⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (V⁄F).toAffine] [(V⁄F').IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (V⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (V⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (V⁄F').toAffine] (x : F) :
+    kw_functionFieldMapAlongGeneral V F F'
+        (algebraMap (V⁄F).toAffine.CoordinateRing (V⁄F).toAffine.FunctionField
+          (XClass (V⁄F).toAffine x))
+      = algebraMap (V⁄F').toAffine.CoordinateRing (V⁄F').toAffine.FunctionField
+          (XClass (V⁄F').toAffine (algebraMap F F' x)) := by
+  have hF : algebraMap (V⁄F).toAffine.CoordinateRing (V⁄F).toAffine.FunctionField
+      (XClass (V⁄F).toAffine x)
+      = polyToFunctionField (V⁄F).toAffine X - algebraMap F (V⁄F).toAffine.FunctionField x := by
+    rw [← polyToFunctionField_C, ← map_sub]; rfl
+  have hF' : algebraMap (V⁄F').toAffine.CoordinateRing (V⁄F').toAffine.FunctionField
+      (XClass (V⁄F').toAffine (algebraMap F F' x))
+      = polyToFunctionField (V⁄F').toAffine X
+          - algebraMap F' (V⁄F').toAffine.FunctionField (algebraMap F F' x) := by
+    rw [← polyToFunctionField_C, ← map_sub]; rfl
+  rw [hF, hF', map_sub, kw_functionFieldMapAlongGeneral_polyToFunctionField_X,
+    AlgHom.commutes, IsScalarTower.algebraMap_apply F F' (V⁄F').toAffine.FunctionField]
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt\
+  " in
+open
+  _root_.P2MW.S_OVERLONG_c68ce07f.WeierstrassCurve.Affine.CoordinateRing
+  in
+omit [IsAlgClosed F] [CharZero F] [IsAlgClosed F'] [CharZero F'] in
+theorem kw_surge_hgf4_χE_algebraMap_YClass (V : WeierstrassCurve R₀) [V.IsElliptic]
+    [(V⁄F).IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate (V⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (V⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (V⁄F).toAffine] [(V⁄F').IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (V⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (V⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (V⁄F').toAffine] (y : F) :
+    kw_functionFieldMapAlongGeneral V F F'
+        (algebraMap (V⁄F).toAffine.CoordinateRing (V⁄F).toAffine.FunctionField
+          (YClass (V⁄F).toAffine (C y)))
+      = algebraMap (V⁄F').toAffine.CoordinateRing (V⁄F').toAffine.FunctionField
+          (YClass (V⁄F').toAffine (C (algebraMap F F' y))) := by
+  have hF : algebraMap (V⁄F).toAffine.CoordinateRing (V⁄F).toAffine.FunctionField
+      (YClass (V⁄F).toAffine (C y))
+      = yGen (V⁄F).toAffine - algebraMap F (V⁄F).toAffine.FunctionField y := by
+    rw [YClass, map_sub, map_sub, yGen]
+    congr 1
+  have hF' : algebraMap (V⁄F').toAffine.CoordinateRing (V⁄F').toAffine.FunctionField
+      (YClass (V⁄F').toAffine (C (algebraMap F F' y)))
+      = yGen (V⁄F').toAffine
+          - algebraMap F' (V⁄F').toAffine.FunctionField (algebraMap F F' y) := by
+    rw [YClass, map_sub, map_sub, yGen]
+    congr 1
+  rw [hF, hF', map_sub, kw_functionFieldMapAlongGeneral_yGen,
+    AlgHom.commutes, IsScalarTower.algebraMap_apply F F' (V⁄F').toAffine.FunctionField]
+
+omit [IsDomain ((toAffine E₀⁄F).FunctionField ⊗[F] F')] in
+omit [CharZero F] [CharZero F'] in
+theorem kw_surge_hgf4_χE_VSR_compat {x y : F} (hP : (E₀⁄F).toAffine.Nonsingular x y)
+    (hσP : (E₀⁄F').toAffine.Nonsingular (algebraMap F F' x) (algebraMap F F' y))
+    (g : (E₀⁄F).toAffine.FunctionField) :
+    χE g ∈ (placeOfEquation hσP.left).toValuationSubring ↔
+      g ∈ (placeOfEquation hP.left).toValuationSubring := by
+  have hχE_inj : Function.Injective (χE : _ →ₐ[F] _) :=
+    (kw_functionFieldMapAlongGeneral E₀ F F').injective
+  classical
+  have hmk (W : Affine F) : ∀ q : F[X][Y],
+      algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W q)
+        = q.eval₂ (polyToFunctionField W) (yGen W) := by
+    intro q
+    induction q using Polynomial.induction_on' with
+    | add p r hp hr => rw [map_add, map_add, Polynomial.eval₂_add, hp, hr]
+    | monomial n a =>
+        simp only [← Polynomial.C_mul_X_pow_eq_monomial, map_mul, map_pow,
+          Polynomial.eval₂_mul, Polynomial.eval₂_pow, Polynomial.eval₂_C, Polynomial.eval₂_X]
+        rw [← algebraMap_polynomial_eq_mk_C, ← polyToFunctionField_apply]; rfl
+  have hfinσP : IsFinitePlace (placeOfEquation hσP.left) :=
+    isFinitePlace_placeOfEquation hσP.left
+  have hχE_polyToFF (p : F[X]) :
+      χE (polyToFunctionField (E₀⁄F).toAffine p) ∈ (placeOfEquation hσP.left).toValuationSubring
+        := by
+    have h : χE (polyToFunctionField (E₀⁄F).toAffine p)
+        = polyToFunctionField (E₀⁄F').toAffine (p.map (algebraMap F F')) := by
+      induction p using Polynomial.induction_on' with
+      | add r s hr hs => rw [map_add, map_add, Polynomial.map_add, map_add, hr, hs]
+      | monomial n c =>
+          rw [Polynomial.map_monomial, ← Polynomial.C_mul_X_pow_eq_monomial,
+            ← Polynomial.C_mul_X_pow_eq_monomial, map_mul, map_mul, map_pow, map_pow,
+            map_mul, map_pow, polyToFunctionField_C, polyToFunctionField_C,
+            kw_functionFieldMapAlongGeneral_polyToFunctionField_X, AlgHom.commutes,
+            IsScalarTower.algebraMap_apply F F' (E₀⁄F').toAffine.FunctionField]
+    rw [h, polyToFunctionField_apply]
+    exact hfinσP _
+  have hχE_CR_mem : ∀ a : (E₀⁄F).toAffine.CoordinateRing,
+      χE (algebraMap _ _ a) ∈ (placeOfEquation hσP.left).toValuationSubring := by
+    intro a
+    obtain ⟨q, rfl⟩ := AdjoinRoot.mk_surjective a
+    rw [hmk (E₀⁄F).toAffine q]
+    induction q using Polynomial.induction_on' with
+    | add r s hr hs =>
+        rw [Polynomial.eval₂_add, map_add]
+        exact Subring.add_mem _ hr hs
+    | monomial n p =>
+        rw [← Polynomial.C_mul_X_pow_eq_monomial, Polynomial.eval₂_mul, Polynomial.eval₂_pow,
+          Polynomial.eval₂_C, Polynomial.eval₂_X, map_mul, map_pow,
+          kw_functionFieldMapAlongGeneral_yGen]
+        exact Subring.mul_mem _ (hχE_polyToFF p)
+          (Subring.pow_mem _ (hfinσP (CoordinateRing.mk (E₀⁄F').toAffine Y)) n)
+  have hXClass_σP_mem_𝔪 : (⟨algebraMap _ _ (CoordinateRing.XClass (E₀⁄F').toAffine
+        (algebraMap F F' x)), hfinσP _⟩ : (placeOfEquation hσP.left).toValuationSubring)
+      ∈ IsLocalRing.maximalIdeal (placeOfEquation hσP.left).toValuationSubring := by
+    rw [Place.mem_maximalIdeal_iff_ord_pos _
+      ((map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr (CoordinateRing.XClass_ne_zero _))]
+    exact (ord_placeOfEquation_pos_iff hσP.left (CoordinateRing.XClass_ne_zero _)).mpr
+      (Ideal.subset_span (Set.mem_insert _ _))
+  have hYClass_σP_mem_𝔪 : (⟨algebraMap _ _ (CoordinateRing.YClass (E₀⁄F').toAffine
+        (C (algebraMap F F' y))), hfinσP _⟩ : (placeOfEquation hσP.left).toValuationSubring)
+      ∈ IsLocalRing.maximalIdeal (placeOfEquation hσP.left).toValuationSubring := by
+    rw [Place.mem_maximalIdeal_iff_ord_pos _
+      ((map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr (CoordinateRing.YClass_ne_zero _))]
+    exact (ord_placeOfEquation_pos_iff hσP.left (CoordinateRing.YClass_ne_zero _)).mpr
+      (Ideal.subset_span (Set.mem_insert_of_mem _ rfl))
+  have hχE_mem_𝔪 : ∀ a ∈ CoordinateRing.XYIdeal (E₀⁄F).toAffine x (C y),
+      (⟨χE (algebraMap _ _ a), hχE_CR_mem a⟩ : (placeOfEquation hσP.left).toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal (placeOfEquation hσP.left).toValuationSubring := by
+    intro a ha
+    rw [CoordinateRing.XYIdeal, Ideal.mem_span_pair] at ha
+    obtain ⟨p, q, hpq⟩ := ha
+    have hdecomp : χE (algebraMap _ _ a)
+        = χE (algebraMap _ _ p) * χE (algebraMap _ _ (CoordinateRing.XClass (E₀⁄F).toAffine x))
+          + χE (algebraMap _ _ q)
+            * χE (algebraMap _ _ (CoordinateRing.YClass (E₀⁄F).toAffine (C y))) := by
+      rw [← map_mul, ← map_mul, ← map_mul, ← map_mul, ← map_add, ← map_add, hpq]
+    rw [show (⟨χE (algebraMap _ _ a), hχE_CR_mem a⟩ :
+          (placeOfEquation hσP.left).toValuationSubring)
+        = ⟨χE (algebraMap _ _ p), hχE_CR_mem p⟩
+            * ⟨_, hfinσP (CoordinateRing.XClass (E₀⁄F').toAffine (algebraMap F F' x))⟩
+          + ⟨χE (algebraMap _ _ q), hχE_CR_mem q⟩
+            * ⟨_, hfinσP (CoordinateRing.YClass (E₀⁄F').toAffine (C (algebraMap F F' y)))⟩ from
+        Subtype.ext (by
+          push_cast
+          rw [hdecomp, kw_surge_hgf4_χE_algebraMap_XClass F F' E₀ x,
+            kw_surge_hgf4_χE_algebraMap_YClass F F' E₀ y])]
+    exact Ideal.add_mem _ (Ideal.mul_mem_left _ _ hXClass_σP_mem_𝔪)
+      (Ideal.mul_mem_left _ _ hYClass_σP_mem_𝔪)
+  have hχE_unit : ∀ s : (E₀⁄F).toAffine.CoordinateRing,
+      s ∉ CoordinateRing.XYIdeal (E₀⁄F).toAffine x (C y) →
+      IsUnit (⟨χE (algebraMap _ _ s), hχE_CR_mem s⟩ :
+        (placeOfEquation hσP.left).toValuationSubring) := by
+    intro s hs
+    obtain ⟨c, hc⟩ := CoordinateRing.exists_sub_algebraMap_mem hP.left s
+    have hc_ne : c ≠ 0 := by
+      intro h; apply hs; simpa [h, sub_zero] using hc
+    have hσc_ne : algebraMap F F' c ≠ 0 := (map_ne_zero_iff _ (algebraMap F F').injective).mpr hc_ne
+    have hχE_const : χE (algebraMap (E₀⁄F).toAffine.CoordinateRing _
+          (algebraMap F (E₀⁄F).toAffine.CoordinateRing c))
+        = algebraMap F' (E₀⁄F').toAffine.FunctionField (algebraMap F F' c) := by
+      rw [← IsScalarTower.algebraMap_apply F (E₀⁄F).toAffine.CoordinateRing
+        (E₀⁄F).toAffine.FunctionField, AlgHom.commutes,
+        IsScalarTower.algebraMap_apply F F' (E₀⁄F').toAffine.FunctionField]
+    have hsplit : (⟨χE (algebraMap _ _ s), hχE_CR_mem s⟩ :
+          (placeOfEquation hσP.left).toValuationSubring)
+        = ⟨algebraMap F' _ (algebraMap F F' c),
+            (placeOfEquation hσP.left).algebraMap_mem' _⟩
+          + ⟨χE (algebraMap _ _ (s - algebraMap F _ c)), hχE_CR_mem _⟩ := by
+      refine Subtype.ext ?_
+      change χE (algebraMap _ _ s)
+          = algebraMap F' (E₀⁄F').toAffine.FunctionField (algebraMap F F' c)
+            + χE (algebraMap _ _ (s - algebraMap F _ c))
+      rw [← hχE_const, ← map_add, ← map_add, add_sub_cancel]
+    rw [hsplit]
+    have hfirst_unit : IsUnit (⟨algebraMap F' _ (algebraMap F F' c),
+        (placeOfEquation hσP.left).algebraMap_mem' _⟩ :
+        (placeOfEquation hσP.left).toValuationSubring) := by
+      refine isUnit_iff_exists_inv.mpr ⟨⟨algebraMap F' _ (algebraMap F F' c)⁻¹,
+        (placeOfEquation hσP.left).algebraMap_mem' _⟩, Subtype.ext ?_⟩
+      push_cast
+      rw [← map_inv₀, ← map_mul, mul_inv_cancel₀ hσc_ne, map_one]
+    have hsecond_𝔪 := hχE_mem_𝔪 (s - algebraMap F _ c) hc
+    by_contra hnotunit
+    have hsum_𝔪 := (IsLocalRing.mem_maximalIdeal _).mpr (mem_nonunits_iff.mpr hnotunit)
+    have hfirst_𝔪 : (⟨algebraMap F' _ (algebraMap F F' c),
+          (placeOfEquation hσP.left).algebraMap_mem' _⟩ :
+          (placeOfEquation hσP.left).toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal _ := by
+      have hsub := Ideal.sub_mem _ hsum_𝔪 hsecond_𝔪
+      rwa [add_sub_cancel_right] at hsub
+    exact (mem_nonunits_iff.mp ((IsLocalRing.mem_maximalIdeal _).mp hfirst_𝔪)) hfirst_unit
+  have hXY_prime : (CoordinateRing.XYIdeal (E₀⁄F).toAffine x (C y)).IsPrime :=
+    (CoordinateRing.XYIdeal_isMaximal hP.left).isPrime
+  have hmem_P : ∀ f : (E₀⁄F).toAffine.FunctionField,
+      f ∈ (placeOfEquation hP.left).toValuationSubring
+        ↔ ∃ (n s : (E₀⁄F).toAffine.CoordinateRing)
+            (_ : s ∉ CoordinateRing.XYIdeal (E₀⁄F).toAffine x (C y)),
+          f = algebraMap _ _ n * (algebraMap _ _ s)⁻¹ := by
+    intro f
+    have hfinP := isFinitePlace_placeOfEquation hP.left
+    constructor
+    · intro hf
+      obtain ⟨n, s, hcase⟩ :=
+        (CoordinateRing.heightOneSpectrumOfEquation hP.left).exists_primeCompl_mul_eq_or_mul_eq
+          (K := (E₀⁄F).toAffine.FunctionField) f
+      have hs_nin : (s : (E₀⁄F).toAffine.CoordinateRing)
+          ∉ CoordinateRing.XYIdeal (E₀⁄F).toAffine x (C y) :=
+        Ideal.mem_primeCompl_iff.mp s.2
+      have hs_CR_ne : (s : (E₀⁄F).toAffine.CoordinateRing) ≠ 0 :=
+        fun h => hs_nin (h ▸ Ideal.zero_mem _)
+      have hs0 : algebraMap (E₀⁄F).toAffine.CoordinateRing
+          (E₀⁄F).toAffine.FunctionField (s : (E₀⁄F).toAffine.CoordinateRing) ≠ 0 :=
+        (map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr hs_CR_ne
+      rcases hcase with heq | heq
+      · refine ⟨n, s, hs_nin, ?_⟩
+        field_simp at heq ⊢; linear_combination heq
+      · by_cases hn_nin : (n : _) ∈ CoordinateRing.XYIdeal (E₀⁄F).toAffine x (C y)
+        · exfalso
+          have hn0 : (n : (E₀⁄F).toAffine.CoordinateRing) ≠ 0 := fun h => by
+            rw [h, map_zero, mul_zero] at heq
+            exact hs_CR_ne ((map_eq_zero_iff _
+              (IsFractionRing.injective _ _)).mp heq.symm)
+          have hord_n_pos : 0 < (placeOfEquation hP.left).ord (algebraMap _ _ (n : _)) :=
+            (ord_placeOfEquation_pos_iff hP.left hn0).mpr hn_nin
+          have hord_s_zero : (placeOfEquation hP.left).ord
+              (algebraMap _ _ (s : (E₀⁄F).toAffine.CoordinateRing)) = 0 := by
+            by_contra hne
+            exact hs_nin ((ord_placeOfEquation_ne_zero_iff hP.left hs_CR_ne).mp hne)
+          have hord_f_neg : (placeOfEquation hP.left).ord f < 0 := by
+            have hf0 : f ≠ 0 := fun h => by
+              rw [h, zero_mul] at heq
+              exact hs_CR_ne ((map_eq_zero_iff _
+                (IsFractionRing.injective _ _)).mp heq.symm)
+            have hfn_eq : (placeOfEquation hP.left).ord f
+                + (placeOfEquation hP.left).ord (algebraMap _ _ (n : _))
+                = (placeOfEquation hP.left).ord
+                    (algebraMap _ _ (s : (E₀⁄F).toAffine.CoordinateRing)) := by
+              rw [← Place.ord_mul _ hf0
+                  ((map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr hn0), heq]
+            omega
+          exact not_le.mpr hord_f_neg (AlgebraicCurve.Place.ord_nonneg_of_mem (placeOfEquation
+            hP.left) hf)
+        · refine ⟨s, n, hn_nin, ?_⟩
+          have hn0 : algebraMap _ (E₀⁄F).toAffine.FunctionField (n : _) ≠ 0 :=
+            (map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr
+              (fun h => hn_nin (h ▸ Ideal.zero_mem _))
+          field_simp at heq ⊢; linear_combination heq
+    · rintro ⟨n, s, hs_nin, rfl⟩
+      have hs_inv : (algebraMap _ _ s)⁻¹ ∈ (placeOfEquation hP.left).toValuationSubring :=
+        hfinP.inv_mem (by rwa [centre_placeOfEquation])
+      exact Subring.mul_mem _ (hfinP n) hs_inv
+  constructor
+  · intro hχEg
+    by_contra hg_notin
+    have hg_ne : g ≠ 0 := fun h => hg_notin (h ▸ Subring.zero_mem _)
+    have hginv_in : g⁻¹ ∈ (placeOfEquation hP.left).toValuationSubring :=
+      ((placeOfEquation hP.left).toValuationSubring.mem_or_inv_mem g).resolve_left hg_notin
+    obtain ⟨n, s, hs_notin, hginv_eq⟩ := (hmem_P g⁻¹).mp hginv_in
+    have hginv_𝔪 : (⟨g⁻¹, hginv_in⟩ : (placeOfEquation hP.left).toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal _ := by
+      rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+      intro hu
+      exact hg_notin (inv_inv g ▸ kw_surge_hgf4_place_inv_mem_of_isUnit _ hu)
+    have hn_in : n ∈ CoordinateRing.XYIdeal (E₀⁄F).toAffine x (C y) := by
+      by_contra hn_notin
+      have hfinP := isFinitePlace_placeOfEquation hP.left
+      have hn_inv : (algebraMap _ _ n)⁻¹ ∈ (placeOfEquation hP.left).toValuationSubring :=
+        hfinP.inv_mem (by rwa [centre_placeOfEquation])
+      have hs_inv : (algebraMap _ _ s)⁻¹ ∈ (placeOfEquation hP.left).toValuationSubring :=
+        hfinP.inv_mem (by rwa [centre_placeOfEquation])
+      have hginv_unit : IsUnit
+          (⟨g⁻¹, hginv_in⟩ : (placeOfEquation hP.left).toValuationSubring) := by
+        have hg_mem : g ∈ (placeOfEquation hP.left).toValuationSubring := by
+          have : g = algebraMap _ _ s * (algebraMap _ _ n)⁻¹ := by
+            rw [← inv_inv g, hginv_eq, mul_inv, inv_inv, mul_comm]
+          rw [this]; exact Subring.mul_mem _ (hfinP s) hn_inv
+        exact isUnit_iff_exists_inv.mpr
+          ⟨(⟨g, hg_mem⟩ : (placeOfEquation hP.left).toValuationSubring),
+           Subtype.ext (by push_cast; exact inv_mul_cancel₀ hg_ne)⟩
+      exact mem_nonunits_iff.mp ((IsLocalRing.mem_maximalIdeal _).mp hginv_𝔪) hginv_unit
+    have hχEn_𝔪 := hχE_mem_𝔪 n hn_in
+    have hχEs_unit := hχE_unit s hs_notin
+    have hχEginv_eq : χE g⁻¹ = χE (algebraMap _ _ n) * (χE (algebraMap _ _ s))⁻¹ := by
+      rw [hginv_eq, map_mul, map_inv₀]
+    have hχEginv_mem : χE g⁻¹ ∈ (placeOfEquation hσP.left).toValuationSubring := by
+      rw [hχEginv_eq]
+      exact Subring.mul_mem _ (hχE_CR_mem n)
+        (kw_surge_hgf4_place_inv_mem_of_isUnit _ hχEs_unit)
+    have hχEginv_𝔪 : (⟨χE g⁻¹, hχEginv_mem⟩ :
+          (placeOfEquation hσP.left).toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal (placeOfEquation hσP.left).toValuationSubring := by
+      have hχEs_inv_mem := kw_surge_hgf4_place_inv_mem_of_isUnit _ hχEs_unit
+      have hrw : (⟨χE g⁻¹, hχEginv_mem⟩ : (placeOfEquation hσP.left).toValuationSubring)
+          = (⟨χE (algebraMap _ _ n), hχE_CR_mem n⟩ :
+              (placeOfEquation hσP.left).toValuationSubring)
+            * ⟨(χE (algebraMap _ _ s))⁻¹, hχEs_inv_mem⟩ :=
+        Subtype.ext (by change χE g⁻¹ = _ * _; exact hχEginv_eq)
+      rw [hrw]
+      exact Ideal.mul_mem_right _ _ hχEn_𝔪
+    have hχEg_ne : χE g ≠ 0 := (map_ne_zero_iff _ hχE_inj).mpr hg_ne
+    have hχEginv_unit : IsUnit
+        (⟨χE g⁻¹, hχEginv_mem⟩ : (placeOfEquation hσP.left).toValuationSubring) :=
+      isUnit_iff_exists_inv.mpr
+        ⟨(⟨χE g, hχEg⟩ : (placeOfEquation hσP.left).toValuationSubring),
+         Subtype.ext (by change χE g⁻¹ * χE g = 1; rw [map_inv₀, inv_mul_cancel₀ hχEg_ne])⟩
+    exact mem_nonunits_iff.mp ((IsLocalRing.mem_maximalIdeal _).mp hχEginv_𝔪) hχEginv_unit
+  · intro hg
+    obtain ⟨n, s, hs_notin, hg_eq⟩ := (hmem_P g).mp hg
+    rw [hg_eq, map_mul, map_inv₀]
+    exact Subring.mul_mem _ (hχE_CR_mem n)
+      (kw_surge_hgf4_place_inv_mem_of_isUnit _ (hχE_unit s hs_notin))
+
+omit [WeierstrassCurve.IsElliptic E₀⁄F] [WeierstrassCurve.IsElliptic E₀'⁄F]
+  [WeierstrassCurve.IsElliptic E₀⁄F'] [WeierstrassCurve.IsElliptic E₀'⁄F'] in
+omit [E₀.IsElliptic] [E₀'.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+  [DecidableEq F'] [IsAlgClosed F'] [CharZero F'] [(toAffine E₀⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F)] [(toAffine E₀⁄F).AbelTheorem]
+  [(toAffine E₀'⁄F).GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F)]
+  [(toAffine E₀'⁄F).AbelTheorem] [(toAffine E₀⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F')] [(toAffine E₀⁄F').AbelTheorem]
+  [(toAffine E₀'⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F')]
+  [(toAffine E₀'⁄F').AbelTheorem] in
+theorem kw_surge_hgf4_bcIota₁_compat (a : (E₀'⁄F).toAffine.FunctionField) :
+    (ι₁) (χE' a) = χE (ι₀ a) := by
+  let ψE := kw_functionFieldTensorFracEquivGeneral E₀ F F'
+  let ψE' := kw_functionFieldTensorFracEquivGeneral E₀' F F'
+  have hκE' : ψE' (χE' a)
+      = algebraMap ((E₀'⁄F).toAffine.FunctionField ⊗[F] F') _ (a ⊗ₜ[F] (1 : F')) := by
+    have hκ : ((kw_functionFieldTensorFracHomGeneral E₀' F F').restrictScalars F).comp
+        (kw_functionFieldMapAlongGeneral E₀' F F')
+        = (IsScalarTower.toAlgHom F ((E₀'⁄F).toAffine.FunctionField ⊗[F] F')
+            (FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F'))).comp
+            (Algebra.TensorProduct.includeLeft (R := F)) := by
+      refine kw_functionField_algHom_ext ?_ ?_
+      · change kw_functionFieldTensorFracHomGeneral E₀' F F' (χE' _) = _
+        rw [kw_functionFieldMapAlongGeneral_polyToFunctionField_X,
+          kw_functionFieldTensorFracHomGeneral_X]; rfl
+      · change kw_functionFieldTensorFracHomGeneral E₀' F F' (χE' _) = _
+        rw [kw_functionFieldMapAlongGeneral_yGen, kw_functionFieldTensorFracHomGeneral_yGen]
+        rfl
+    exact DFunLike.congr_fun hκ a
+  have hκE : ∀ b, ψE.symm (algebraMap ((E₀⁄F).toAffine.FunctionField ⊗[F] F') _
+      (b ⊗ₜ[F] (1 : F'))) = χE b := by
+    intro b
+    refine ψE.injective ?_
+    rw [AlgEquiv.apply_symm_apply]
+    have hκ : ((kw_functionFieldTensorFracHomGeneral E₀ F F').restrictScalars F).comp
+        (kw_functionFieldMapAlongGeneral E₀ F F')
+        = (IsScalarTower.toAlgHom F ((E₀⁄F).toAffine.FunctionField ⊗[F] F')
+            (FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F'))).comp
+            (Algebra.TensorProduct.includeLeft (R := F)) := by
+      refine kw_functionField_algHom_ext ?_ ?_
+      · change kw_functionFieldTensorFracHomGeneral E₀ F F' (χE _) = _
+        rw [kw_functionFieldMapAlongGeneral_polyToFunctionField_X,
+          kw_functionFieldTensorFracHomGeneral_X]; rfl
+      · change kw_functionFieldTensorFracHomGeneral E₀ F F' (χE _) = _
+        rw [kw_functionFieldMapAlongGeneral_yGen, kw_functionFieldTensorFracHomGeneral_yGen]
+        rfl
+    exact (DFunLike.congr_fun hκ b).symm
+  change ψE.symm (kw_surge_hgf4_bcTensorFracIotaAlg E₀ E₀' F F' ι₀ (ψE' (χE' a)))
+      = χE (ι₀ a)
+  rw [hκE',
+    show kw_surge_hgf4_bcTensorFracIotaAlg E₀ E₀' F F' ι₀
+        (algebraMap ((E₀'⁄F).toAffine.FunctionField ⊗[F] F') _ (a ⊗ₜ[F] (1 : F')))
+      = algebraMap ((E₀⁄F).toAffine.FunctionField ⊗[F] F') _ ((ι₀ a) ⊗ₜ[F] (1 : F')) from by
+        change kw_surge_hgf4_bcTensorFracIota E₀ E₀' F F' ι₀ _ = _
+        rw [kw_surge_hgf4_bcTensorFracIota_algebraMap, kw_surge_hgf4_bcTensorIota_tmul],
+    hκE (ι₀ a)]
+
+include hσ in
+omit [E₀'.IsElliptic] in
+theorem kw_surge_hgf4_pmop_naturality :
+    let hι₁ := kw_surge_hgf4_bcIota₁_isIntegral E₀ E₀' F F' ι₀ hfin₀
+    let hfin₁ := kw_surge_hgf4_bcIota₁_finiteAlong E₀ E₀' F F' ι₀ hfin₀
+    let σE : (E₀⁄F).toAffine.Point →+ (E₀⁄F').toAffine.Point :=
+      WeierstrassCurve.Affine.Point.map (W' := E₀.toAffine) σ
+    let σE' : (E₀'⁄F).toAffine.Point →+ (E₀'⁄F').toAffine.Point :=
+      WeierstrassCurve.Affine.Point.map (W' := E₀'.toAffine) σ
+    let φ₀ := pointMapOfPushforward ι₀ hι₀ hfin₀ (normFormulaAlong_of_elliptic ι₀ hfin₀)
+    let φ₁ := pointMapOfPushforward (ι₁) hι₁ hfin₁ (normFormulaAlong_of_elliptic (ι₁) hfin₁)
+    ∀ P, φ₁ (σE P) = σE' (φ₀ P) := by
+  intro hι₁ hfin₁ σE σE' φ₀ φ₁
+  have hgBC₀ :=
+    kw_fdn2_qephod_hend7_pmop_eq_geomMorphBC_sub ι₀ hι₀ hfin₀ (normFormulaAlong_of_elliptic ι₀
+      hfin₀)
+  have hgBC₁ :=
+    kw_fdn2_qephod_hend7_pmop_eq_geomMorphBC_sub (ι₁) hι₁ hfin₁ (normFormulaAlong_of_elliptic ι₁
+      hfin₁)
+  let g₀ := kw_fdn2_qephod_hend7_geomMorphBC ι₀ hι₀
+  let g₁ := kw_fdn2_qephod_hend7_geomMorphBC (ι₁) hι₁
+  have hχE_ord_pos : ∀ {x y : F} (hP : (E₀⁄F).toAffine.Nonsingular x y)
+      (hσP : (E₀⁄F').toAffine.Nonsingular (algebraMap F F' x) (algebraMap F F' y))
+      (h : (E₀⁄F).toAffine.FunctionField) (hh : h ≠ 0),
+      0 < (placeOfEquation hσP.left).ord (χE h) ↔
+        0 < (placeOfEquation hP.left).ord h := by
+    intro x y hP hσP h hh
+    have hχEh_ne : χE h ≠ 0 :=
+      (map_ne_zero_iff _ (kw_functionFieldMapAlongGeneral E₀ F F').injective).mpr hh
+    have hVSR := kw_surge_hgf4_χE_VSR_compat E₀ F F' hP hσP
+    constructor <;> intro hpos
+    · have hχEh_mem : χE h ∈ (placeOfEquation hσP.left).toValuationSubring :=
+        AlgebraicCurve.Place.mem_of_ord_nonneg (placeOfEquation hσP.left) hχEh_ne hpos.le
+      have hh_mem : h ∈ (placeOfEquation hP.left).toValuationSubring := (hVSR h).mp hχEh_mem
+      rw [← Place.mem_maximalIdeal_iff_ord_pos _ hh hh_mem,
+        IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+      intro hu
+      have hinv_mem := kw_surge_hgf4_place_inv_mem_of_isUnit _ hu
+      have hχEinv_mem : χE h⁻¹ ∈ (placeOfEquation hσP.left).toValuationSubring :=
+        (hVSR h⁻¹).mpr hinv_mem
+      rw [map_inv₀] at hχEinv_mem
+      have hχEh_unit : IsUnit
+          (⟨χE h, hχEh_mem⟩ : (placeOfEquation hσP.left).toValuationSubring) :=
+        isUnit_iff_exists_inv.mpr ⟨⟨(χE h)⁻¹, hχEinv_mem⟩,
+          Subtype.ext (mul_inv_cancel₀ hχEh_ne)⟩
+      exact (mem_nonunits_iff.mp ((IsLocalRing.mem_maximalIdeal _).mp
+        ((Place.mem_maximalIdeal_iff_ord_pos _ hχEh_ne hχEh_mem).mpr hpos))) hχEh_unit
+    · have hh_mem : h ∈ (placeOfEquation hP.left).toValuationSubring :=
+        AlgebraicCurve.Place.mem_of_ord_nonneg (placeOfEquation hP.left) hh hpos.le
+      have hχEh_mem : χE h ∈ (placeOfEquation hσP.left).toValuationSubring :=
+        (hVSR h).mpr hh_mem
+      rw [← Place.mem_maximalIdeal_iff_ord_pos _ hχEh_ne hχEh_mem,
+        IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+      intro hu
+      have hinv_mem := kw_surge_hgf4_place_inv_mem_of_isUnit _ hu
+      have hh_inv_mem : h⁻¹ ∈ (placeOfEquation hP.left).toValuationSubring := by
+        rw [← map_inv₀] at hinv_mem; exact (hVSR h⁻¹).mp hinv_mem
+      have hh_unit : IsUnit
+          (⟨h, hh_mem⟩ : (placeOfEquation hP.left).toValuationSubring) :=
+        isUnit_iff_exists_inv.mpr ⟨⟨h⁻¹, hh_inv_mem⟩, Subtype.ext (mul_inv_cancel₀ hh)⟩
+      exact (mem_nonunits_iff.mp ((IsLocalRing.mem_maximalIdeal _).mp
+        ((Place.mem_maximalIdeal_iff_ord_pos _ hh hh_mem).mpr hpos))) hh_unit
+  have hgBC_nat_affine : ∀ {x y : F} (hP : (E₀⁄F).toAffine.Nonsingular x y),
+      g₁ (σE (.some x y hP)) = σE' (g₀ (.some x y hP)) := by
+    intro x y hP
+    have hσP : (E₀⁄F').toAffine.Nonsingular (algebraMap F F' x) (algebraMap F F' y) :=
+      kw_surge_hgf4_toAffine_map_eq F F' E₀ ▸
+        (((E₀⁄F).toAffine.map_nonsingular (algebraMap F F').injective x y).mpr hP)
+    have hσE_some : σE (.some x y hP)
+        = .some (algebraMap F F' x) (algebraMap F F' y) hσP := by
+      have h := Point.map_some (W' := E₀.toAffine) (F := F) (K := F') σ hP
+      rw [show σE (.some x y hP) = Point.map (W' := E₀.toAffine) σ (.some x y hP) from rfl, h]
+      congr 1 <;> exact hσ _
+    refine placeOfPoint_injective ?_
+    rw [← kw_fdn2_qephod_hend7_placeOfPoint_geomMorphBC (ι₁) hι₁ (σE (.some x y hP)),
+      hσE_some, placeOfPoint_some]
+    have hseam₀ : (placeOfEquation hP.left).restrictAlong ι₀ hι₀
+        = placeOfPoint (g₀ (.some x y hP)) := by
+      rw [← placeOfPoint_some hP,
+        kw_fdn2_qephod_hend7_placeOfPoint_geomMorphBC ι₀ hι₀]
+    have hι₁X : (ι₁) (polyToFunctionField (E₀'⁄F').toAffine X)
+        = χE (ι₀ (polyToFunctionField (E₀'⁄F).toAffine X)) := by
+      rw [← kw_functionFieldMapAlongGeneral_polyToFunctionField_X E₀' F F']
+      exact kw_surge_hgf4_bcIota₁_compat E₀ E₀' F F' ι₀ _
+    have hι₁Y : (ι₁) (yGen (E₀'⁄F').toAffine)
+        = χE (ι₀ (yGen (E₀'⁄F).toAffine)) := by
+      rw [← kw_functionFieldMapAlongGeneral_yGen E₀' F F']
+      exact kw_surge_hgf4_bcIota₁_compat E₀ E₀' F F' ι₀ _
+    have hχE_const : ∀ c : F, χE (algebraMap F (E₀⁄F).toAffine.FunctionField c)
+        = algebraMap F' (E₀⁄F').toAffine.FunctionField (algebraMap F F' c) := fun c => by
+      rw [AlgHom.commutes,
+        IsScalarTower.algebraMap_apply F F' (E₀⁄F').toAffine.FunctionField]
+    rcases hQ₀_case : g₀ (.some x y hP) with _ | ⟨qx, qy, hQ₀ns⟩
+    · rw [show placeOfPoint (σE' (.zero : (E₀'⁄F).toAffine.Point))
+          = (InfinitePlace.place : Place F' (E₀'⁄F').toAffine.FunctionField) from by
+        rw [show σE' (.zero : (E₀'⁄F).toAffine.Point)
+            = (.zero : (E₀'⁄F').toAffine.Point) from map_zero σE', placeOfPoint_zero]]
+      refine AbstractSeam.restrictAlong_eq_infinitePlace (ι₁) hι₁ rfl _ ?_
+      rw [hι₁X]
+      intro hmem
+      have hι₀X_mem : ι₀ (polyToFunctionField (E₀'⁄F).toAffine X)
+          ∈ (placeOfEquation hP.left).toValuationSubring :=
+        (kw_surge_hgf4_χE_VSR_compat E₀ F F' hP hσP _).mp hmem
+      have hX_res : polyToFunctionField (E₀'⁄F).toAffine X
+          ∈ ((placeOfEquation hP.left).restrictAlong ι₀ hι₀).toValuationSubring :=
+        (Place.mem_restrictAlong_iff ι₀ hι₀ _ _).mpr hι₀X_mem
+      rw [hseam₀, hQ₀_case, placeOfPoint_zero] at hX_res
+      exact InfinitePlace.not_isFinitePlace (isFinitePlace_of_mem _ hX_res)
+    · have hσQ : (E₀'⁄F').toAffine.Nonsingular (algebraMap F F' qx) (algebraMap F F' qy) :=
+        kw_surge_hgf4_toAffine_map_eq F F' E₀' ▸
+          (((E₀'⁄F).toAffine.map_nonsingular (algebraMap F F').injective qx qy).mpr hQ₀ns)
+      have hσE'_some : σE' (.some qx qy hQ₀ns)
+          = .some (algebraMap F F' qx) (algebraMap F F' qy) hσQ := by
+        have h := Point.map_some (W' := E₀'.toAffine) (F := F) (K := F') σ hQ₀ns
+        rw [show σE' (.some qx qy hQ₀ns)
+            = Point.map (W' := E₀'.toAffine) σ (.some qx qy hQ₀ns) from rfl, h]
+        congr 1 <;> exact hσ _
+      rw [hσE'_some, placeOfPoint_some]
+      have hseam₀' : (placeOfEquation hP.left).restrictAlong ι₀ hι₀
+          = placeOfEquation hQ₀ns.left := by rw [hseam₀, hQ₀_case, placeOfPoint_some]
+      have hbrX : algebraMap (E₀'⁄F).toAffine.CoordinateRing (E₀'⁄F).toAffine.FunctionField
+          (CoordinateRing.XClass (E₀'⁄F).toAffine qx)
+          = polyToFunctionField (E₀'⁄F).toAffine X - algebraMap F _ qx :=
+        AbstractSeam.map_XClass (V := (E₀'⁄F).toAffine) (W := (E₀'⁄F).toAffine)
+          (AlgHom.id F (E₀'⁄F).toAffine.FunctionField) rfl qx
+      have hbrY : algebraMap (E₀'⁄F).toAffine.CoordinateRing (E₀'⁄F).toAffine.FunctionField
+          (CoordinateRing.YClass (E₀'⁄F).toAffine (C qy))
+          = yGen (E₀'⁄F).toAffine - algebraMap F _ qy :=
+        AbstractSeam.map_YClass (V := (E₀'⁄F).toAffine) (W := (E₀'⁄F).toAffine)
+          (AlgHom.id F (E₀'⁄F).toAffine.FunctionField) rfl qy
+      have hι₀X_ne : ι₀ (polyToFunctionField (E₀'⁄F).toAffine X)
+          - algebraMap F _ qx ≠ 0 := by
+        rw [← ι₀.commutes, ← map_sub, ← hbrX]
+        exact fun h => (CoordinateRing.XClass_ne_zero qx)
+          ((map_eq_zero_iff _ (IsFractionRing.injective _ _)).mp (ι₀.injective
+            (h.trans (map_zero ι₀).symm)))
+      have hι₀Y_ne : ι₀ (yGen (E₀'⁄F).toAffine) - algebraMap F _ qy ≠ 0 := by
+        rw [← ι₀.commutes, ← map_sub, ← hbrY]
+        exact fun h => (CoordinateRing.YClass_ne_zero (C qy))
+          ((map_eq_zero_iff _ (IsFractionRing.injective _ _)).mp (ι₀.injective
+            (h.trans (map_zero ι₀).symm)))
+      have hram_pos : 0 < Place.ramificationIndexAlong ι₀ (placeOfEquation hP.left) :=
+        Place.ramificationIndexAlong_pos ι₀ hι₀ (placeOfEquation hP.left)
+      have hdxF : 0 < (placeOfEquation hP.left).ord
+          (ι₀ (polyToFunctionField (E₀'⁄F).toAffine X) - algebraMap F _ qx) := by
+        rw [← ι₀.commutes, ← map_sub, ← hbrX,
+          Place.ord_restrictAlong ι₀ hι₀, hseam₀']
+        have hQord : 0 < (placeOfEquation hQ₀ns.left).ord (algebraMap _ _
+            (CoordinateRing.XClass (E₀'⁄F).toAffine qx)) :=
+          (ord_placeOfEquation_pos_iff hQ₀ns.left (CoordinateRing.XClass_ne_zero _)).mpr
+            (Ideal.subset_span (Set.mem_insert _ _))
+        positivity
+      have hdyF : 0 < (placeOfEquation hP.left).ord
+          (ι₀ (yGen (E₀'⁄F).toAffine) - algebraMap F _ qy) := by
+        rw [← ι₀.commutes, ← map_sub, ← hbrY,
+          Place.ord_restrictAlong ι₀ hι₀, hseam₀']
+        have hQord : 0 < (placeOfEquation hQ₀ns.left).ord (algebraMap _ _
+            (CoordinateRing.YClass (E₀'⁄F).toAffine (C qy))) :=
+          (ord_placeOfEquation_pos_iff hQ₀ns.left (CoordinateRing.YClass_ne_zero _)).mpr
+            (Ideal.subset_span (Set.mem_insert_of_mem _ rfl))
+        positivity
+      refine AbstractSeam.restrictAlong_placeOfEquation (ι₁) hι₁ rfl rfl
+        hσP.left hσQ.left ?_ ?_ ?_
+      · rw [hι₁X]
+        refine (kw_surge_hgf4_χE_VSR_compat E₀ F F' hP hσP _).mpr ?_
+        rw [← Place.mem_restrictAlong_iff ι₀ hι₀, hseam₀']
+        exact isFinitePlace_placeOfEquation hQ₀ns.left _
+      · rw [hι₁X, ← hχE_const qx, ← map_sub]
+        exact (hχE_ord_pos hP hσP _ hι₀X_ne).mpr hdxF
+      · rw [hι₁Y, ← hχE_const qy, ← map_sub]
+        exact (hχE_ord_pos hP hσP _ hι₀Y_ne).mpr hdyF
+  let δ : (E₀⁄F).toAffine.Point →+ (E₀'⁄F').toAffine.Point :=
+    (φ₁.comp σE) - (σE'.comp φ₀)
+  have hδ_affine : ∀ {x y : F} (hP : (E₀⁄F).toAffine.Nonsingular x y),
+      δ (.some x y hP) = σE' (g₀ 0) - g₁ 0 := by
+    intro x y hP
+    change φ₁ (σE (.some x y hP)) - σE' (φ₀ (.some x y hP)) = _
+    have h1 : φ₁ (σE (.some x y hP)) = g₁ (σE (.some x y hP)) - g₁ 0 := hgBC₁ _
+    have h0 : φ₀ (.some x y hP) = g₀ (.some x y hP) - g₀ 0 := hgBC₀ _
+    rw [h1, h0, map_sub, hgBC_nat_affine hP]
+    abel
+  have hC_zero : σE' (g₀ 0) - g₁ 0 = 0 := by
+    obtain ⟨e3⟩ :=
+      WeierstrassCurve.nonempty_pointTorsionBy_zmod (W := (E₀⁄F)) (n := 3) (by omega)
+    let P₀ : (E₀⁄F).toAffine.Point := (e3.symm (fun _ => 1) : _)
+    have hP₀_3 : (3 : ℤ) • P₀ = 0 := by
+      have := (e3.symm (fun _ => 1)).2
+      simp [P₀]
+    have hP₀_ne : P₀ ≠ 0 := by
+      intro h
+      have heq : e3.symm (fun _ => 1) = 0 :=
+        Subtype.ext (show (e3.symm (fun _ => 1) : (E₀⁄F).toAffine.Point) = 0 from h)
+      have hfun : (fun _ => (1 : ZMod 3)) = (0 : Fin 2 → ZMod 3) := by
+        have := congrArg e3 heq
+        rwa [e3.apply_symm_apply, map_zero] at this
+      exact one_ne_zero (congrFun hfun 0)
+    have h2P₀_ne : (2 : ℤ) • P₀ ≠ 0 := by
+      intro h2
+      have : (3 : ℤ) • P₀ - (2 : ℤ) • P₀ = 0 := by rw [hP₀_3, h2, sub_zero]
+      have hP₀_eq : P₀ = 0 := by
+        have : ((3 : ℤ) - 2) • P₀ = 0 := by rw [sub_smul]; exact this
+        simpa using this
+      exact hP₀_ne hP₀_eq
+    rcases hP₀_case : P₀ with _ | ⟨px, py, hpP⟩
+    · exact (hP₀_ne hP₀_case).elim
+    rcases h2P₀_case : (2 : ℤ) • P₀ with _ | ⟨qx, qy, hqQ⟩
+    · exact (h2P₀_ne h2P₀_case).elim
+    have h2C : (2 : ℤ) • (σE' (g₀ 0) - g₁ 0) = σE' (g₀ 0) - g₁ 0 := by
+      calc (2 : ℤ) • (σE' (g₀ 0) - g₁ 0)
+          = (2 : ℤ) • δ (.some px py hpP) := by rw [hδ_affine hpP]
+        _ = δ ((2 : ℤ) • (.some px py hpP : (E₀⁄F).toAffine.Point)) :=
+            (map_zsmul δ 2 _).symm
+        _ = δ ((2 : ℤ) • P₀) := by rw [hP₀_case]
+        _ = δ (.some qx qy hqQ) := by rw [h2P₀_case]
+        _ = σE' (g₀ 0) - g₁ 0 := hδ_affine hqQ
+    have hC' : ((2 : ℤ) - 1) • (σE' (g₀ 0) - g₁ 0) = 0 := by
+      rw [sub_smul, one_smul, h2C, sub_self]
+    simpa using hC'
+  intro P
+  have hδP : δ P = 0 := by
+    rcases P with _ | ⟨x, y, hP⟩
+    · exact map_zero δ
+    · rw [hδ_affine hP, hC_zero]
+  exact sub_eq_zero.mp hδP
+
+end Naturality
+end BetweenCurvesTensor
+
+theorem kw_surge_hgf4_hBC_proved : KwD5BetweenCurvesFFSeamBaseChange := by
+  intro R₀ _ E₀ E₀' _ _ F F' _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ σ ι₀ hι₀ hfin₀ N _
+    hcyc hcard
+  let : Algebra F F' := σ.toRingHom.toAlgebra
+  have : IsScalarTower R₀ F F' := IsScalarTower.of_algebraMap_eq fun r =>
+    (σ.commutes r).symm
+  have : IsDomain ((E₀⁄F).toAffine.FunctionField ⊗[F] F') :=
+    kw_functionFieldTensorIsDomain_dischargeGeneral E₀ F F'
+  have : IsDomain ((E₀'⁄F).toAffine.FunctionField ⊗[F] F') :=
+    kw_functionFieldTensorIsDomain_dischargeGeneral E₀' F F'
+  let ι₁ := kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀
+  have hι₁ := kw_surge_hgf4_bcIota₁_isIntegral E₀ E₀' F F' ι₀ hfin₀
+  have hfin₁ := kw_surge_hgf4_bcIota₁_finiteAlong E₀ E₀' F F' ι₀ hfin₀
+  have hD := kw_surge_hgf4_bcIota₁_finrankAlong E₀ E₀' F F' ι₀ hfin₀
+  have hker₁ : Nat.card (AddMonoidHom.ker
+      (pointMapOfPushforward ι₁ hι₁ hfin₁ (normFormulaAlong_of_elliptic ι₁ hfin₁))) = N := by
+    rw [kw_fdn2_qephod_hend7_pmopKerCard_proved F' (E₀⁄F').toAffine (E₀'⁄F').toAffine
+        ι₁ hι₁ hfin₁, hD,
+      ← kw_fdn2_qephod_hend7_pmopKerCard_proved F (E₀⁄F).toAffine (E₀'⁄F).toAffine
+        ι₀ hι₀ hfin₀, hcard]
+  let σE : (E₀⁄F).toAffine.Point →+ (E₀⁄F').toAffine.Point :=
+    WeierstrassCurve.Affine.Point.map (W' := E₀.toAffine) σ
+  let σE' : (E₀'⁄F).toAffine.Point →+ (E₀'⁄F').toAffine.Point :=
+    WeierstrassCurve.Affine.Point.map (W' := E₀'.toAffine) σ
+  have hσE_inj : Function.Injective σE :=
+    WeierstrassCurve.Affine.Point.map_injective (W' := E₀.toAffine) σ
+  let φ₀ := pointMapOfPushforward ι₀ hι₀ hfin₀ (normFormulaAlong_of_elliptic ι₀ hfin₀)
+  let φ₁ := pointMapOfPushforward ι₁ hι₁ hfin₁ (normFormulaAlong_of_elliptic ι₁ hfin₁)
+  have hnat : ∀ P, φ₁ (σE P) = σE' (φ₀ P) := by
+    exact kw_surge_hgf4_pmop_naturality E₀ E₀' F F' ι₀ hι₀ hfin₀ σ (fun _ => rfl)
+  have hker_sub : ∀ P ∈ AddMonoidHom.ker φ₀, σE P ∈ AddMonoidHom.ker φ₁ := by
+    intro P hP
+    rw [AddMonoidHom.mem_ker] at hP ⊢
+    rw [hnat P, hP, map_zero]
+  let σE_ker : (AddMonoidHom.ker φ₀) →+ (AddMonoidHom.ker φ₁) :=
+    { toFun := fun ⟨P, hP⟩ => ⟨σE P, hker_sub P hP⟩
+      map_zero' := Subtype.ext (map_zero σE)
+      map_add' := fun ⟨P, _⟩ ⟨Q, _⟩ => Subtype.ext (map_add σE P Q) }
+  have hσE_ker_inj : Function.Injective σE_ker := fun ⟨P, _⟩ ⟨Q, _⟩ hPQ =>
+    Subtype.ext (hσE_inj (Subtype.ext_iff.mp hPQ))
+  have hcard_eq : Nat.card (AddMonoidHom.ker φ₀) = Nat.card (AddMonoidHom.ker φ₁) := by
+    rw [hcard, hker₁]
+  have hfin_ker₀ : Finite (AddMonoidHom.ker φ₀) :=
+    Nat.finite_of_card_ne_zero (hcard ▸ (NeZero.ne N))
+  have hfin_ker₁ : Finite (AddMonoidHom.ker φ₁) :=
+    Nat.finite_of_card_ne_zero (hker₁ ▸ (NeZero.ne N))
+  have hσE_ker_bij : Function.Bijective σE_ker :=
+    (Nat.bijective_iff_injective_and_card _).mpr ⟨hσE_ker_inj, hcard_eq⟩
+  have hcyc₁ : IsAddCyclic (AddMonoidHom.ker φ₁) := by
+    let e : (AddMonoidHom.ker φ₀) ≃+ (AddMonoidHom.ker φ₁) :=
+      AddEquiv.ofBijective σE_ker hσE_ker_bij
+    obtain ⟨⟨g₀, hg₀⟩⟩ := hcyc
+    exact ⟨⟨e g₀, fun y => by
+      obtain ⟨k, hk⟩ := hg₀ (e.symm y)
+      exact ⟨k, by rw [← e.apply_symm_apply y, ← hk, map_zsmul]⟩⟩⟩
+  exact ⟨ι₁, hι₁, hfin₁, hcyc₁, hker₁⟩
+
+end ModularCurve
+end
+end
+
+section
+
+
+section
+
+p2m_open "P2MW.S_OVERLONG_c68ce07f.ModularCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve"
+p2m_open_scoped "TensorProduct Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial Polynomial.Bivariate \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial.Bivariate"
+
+namespace ModularCurve
+
+universe u
+
+attribute [local instance] Classical.propDecidable
+section BCNoACEngine
+variable {R₀ : Type u} [Field R₀]
+variable (E₀ E₀' : WeierstrassCurve R₀) [E₀.IsElliptic] [E₀'.IsElliptic]
+variable (F : Type u) [Field F] [Algebra R₀ F] [DecidableEq F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra R₀ F'] [DecidableEq F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower R₀ F F']
+variable [(E₀⁄F).IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀⁄F).toAffine] [(E₀'⁄F).IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀'⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀'⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀'⁄F).toAffine] [(E₀⁄F').IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀⁄F').toAffine] [(E₀'⁄F').IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀'⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀'⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀'⁄F').toAffine]
+variable (ι' : (E₀'⁄F).toAffine.FunctionField →ₐ[F] (E₀⁄F).toAffine.FunctionField)
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+scoped instance kw_surgehgf4_hfgkd_tensorIsDomain_E :
+    IsDomain ((E₀⁄F).toAffine.FunctionField ⊗[F] F') :=
+  kw_functionFieldTensorIsDomain_dischargeGeneralNoAC E₀ F F'
+
+scoped instance kw_surgehgf4_hfgkd_tensorIsDomain_E' :
+    IsDomain ((E₀'⁄F).toAffine.FunctionField ⊗[F] F') :=
+  kw_functionFieldTensorIsDomain_dischargeGeneralNoAC E₀' F F'
+end BCNoACEngine
+section KerTransportMint
+
+def KwD5BetweenCurvesKerTransportAlongEmbed : Prop :=
+  ∀ (R₀ : Type) [Field R₀] (E₀ E₀' : WeierstrassCurve R₀) [E₀.IsElliptic] [E₀'.IsElliptic]
+    (F₁ : Type) [Field F₁] [Algebra R₀ F₁] [DecidableEq F₁] [IsAlgClosed F₁] [CharZero F₁]
+    (F₂ : Type) [Field F₂] [Algebra R₀ F₂] [DecidableEq F₂] [IsAlgClosed F₂] [CharZero F₂]
+    [Algebra F₁ F₂] [IsScalarTower R₀ F₁ F₂]
+    [(E₀⁄F₁).IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀⁄F₁).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀⁄F₁).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀⁄F₁).toAffine] [(E₀'⁄F₁).IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀'⁄F₁).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀'⁄F₁).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀'⁄F₁).toAffine] [(E₀⁄F₂).IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀⁄F₂).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀⁄F₂).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀⁄F₂).toAffine] [(E₀'⁄F₂).IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀'⁄F₂).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀'⁄F₂).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀'⁄F₂).toAffine]
+    (ι₁ : (E₀'⁄F₁).toAffine.FunctionField →ₐ[F₁] (E₀⁄F₁).toAffine.FunctionField)
+    (hι₁ : ι₁.toRingHom.IsIntegral) (hfin₁ : FiniteAlong F₁ ι₁)
+    (ι₂ : (E₀'⁄F₂).toAffine.FunctionField →ₐ[F₂] (E₀⁄F₂).toAffine.FunctionField)
+    (hι₂ : ι₂.toRingHom.IsIntegral) (hfin₂ : FiniteAlong F₂ ι₂)
+    (_hχ : ∀ x : (E₀'⁄F₁).toAffine.FunctionField,
+      ι₂ (kw_functionFieldMapAlongGeneralNoAC E₀' F₁ F₂ x)
+        = kw_functionFieldMapAlongGeneralNoAC E₀ F₁ F₂ (ι₁ x))
+    (N : ℕ) [NeZero N],
+    IsAddCyclic (AddMonoidHom.ker
+      (pointMapOfPushforward ι₂ hι₂ hfin₂ (normFormulaAlong_of_elliptic ι₂ hfin₂))) →
+    Nat.card (AddMonoidHom.ker
+      (pointMapOfPushforward ι₂ hι₂ hfin₂ (normFormulaAlong_of_elliptic ι₂ hfin₂))) = N →
+    IsAddCyclic (AddMonoidHom.ker
+      (pointMapOfPushforward ι₁ hι₁ hfin₁ (normFormulaAlong_of_elliptic ι₁ hfin₁))) ∧
+    Nat.card (AddMonoidHom.ker
+      (pointMapOfPushforward ι₁ hι₁ hfin₁ (normFormulaAlong_of_elliptic ι₁ hfin₁))) = N
+end KerTransportMint
+end ModularCurve
+end
+
+section
+
+
+section
+
+p2m_open "P2MW.S_OVERLONG_c68ce07f.ModularCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_c68ce07f.\
+  WeierstrassCurve.Affine Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_c68ce07f.\
+  AlgebraicCurve"
+p2m_open_scoped "TensorProduct Polynomial \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial Polynomial.Bivariate \
+  P2MW.S_OVERLONG_c68ce07f.\
+  Polynomial.Bivariate"
+
+namespace ModularCurve
+
+attribute [local instance] Classical.propDecidable
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+theorem kw_surgehgf4_hfgkd_ktd_chiNoAC_eq_chiGeneral
+    {R₀ : Type} [Field R₀] (W : WeierstrassCurve R₀) [W.IsElliptic]
+    (F : Type) [Field F] [Algebra R₀ F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    (F' : Type) [Field F'] [Algebra R₀ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F']
+    [Algebra F F'] [IsScalarTower R₀ F F']
+    [(W⁄F).IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F).toAffine] [(W⁄F').IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F').toAffine] :
+    kw_functionFieldMapAlongGeneralNoAC W F F'
+      = kw_functionFieldMapAlongGeneral W F F' := by
+  refine kw_functionField_algHom_ext ?_ ?_
+  · rw [kw_functionFieldMapAlongGeneralNoAC_polyToFunctionField_X,
+      kw_functionFieldMapAlongGeneral_polyToFunctionField_X]
+  · rw [kw_functionFieldMapAlongGeneralNoAC_yGen, kw_functionFieldMapAlongGeneral_yGen]
+
+theorem kw_surgehgf4_hfgkd_ktd_kerTransport_proved :
+    KwD5BetweenCurvesKerTransportAlongEmbed := by
+  intro R₀ _ E₀ E₀' _ _ F₁ _ _ _ _ _ F₂ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
+    ι₁ hι₁ hfin₁ ι₂ hι₂ hfin₂ hχ N _ hcyc₂ hcard₂
+  have : IsDomain ((E₀⁄F₁).toAffine.FunctionField ⊗[F₁] F₂) :=
+    kw_functionFieldTensorIsDomain_dischargeGeneral E₀ F₁ F₂
+  have : IsDomain ((E₀'⁄F₁).toAffine.FunctionField ⊗[F₁] F₂) :=
+    kw_functionFieldTensorIsDomain_dischargeGeneral E₀' F₁ F₂
+  have hχE₀ := kw_surgehgf4_hfgkd_ktd_chiNoAC_eq_chiGeneral E₀ F₁ F₂
+  have hχE₀' := kw_surgehgf4_hfgkd_ktd_chiNoAC_eq_chiGeneral E₀' F₁ F₂
+  have hχG : ∀ x, ι₂ (kw_functionFieldMapAlongGeneral E₀' F₁ F₂ x)
+      = kw_functionFieldMapAlongGeneral E₀ F₁ F₂ (ι₁ x) := by
+    intro x; rw [← hχE₀', ← hχE₀]; exact hχ x
+  have heq : ι₂ = kw_surge_hgf4_bcIota₁ E₀ E₀' F₁ F₂ ι₁ := by
+    refine kw_functionField_algHom_ext ?_ ?_
+    · rw [show polyToFunctionField (E₀'⁄F₂).toAffine X
+            = kw_functionFieldMapAlongGeneral E₀' F₁ F₂
+                (polyToFunctionField (E₀'⁄F₁).toAffine X) from
+          (kw_functionFieldMapAlongGeneral_polyToFunctionField_X E₀' F₁ F₂).symm,
+        hχG, kw_surge_hgf4_bcIota₁_compat E₀ E₀' F₁ F₂ ι₁]
+    · rw [show yGen (E₀'⁄F₂).toAffine
+            = kw_functionFieldMapAlongGeneral E₀' F₁ F₂ (yGen (E₀'⁄F₁).toAffine) from
+          (kw_functionFieldMapAlongGeneral_yGen E₀' F₁ F₂).symm,
+        hχG, kw_surge_hgf4_bcIota₁_compat E₀ E₀' F₁ F₂ ι₁]
+  subst heq
+  clear hχ hχG hχE₀ hχE₀'
+  let φ₁ := pointMapOfPushforward ι₁ hι₁ hfin₁ (normFormulaAlong_of_elliptic ι₁ hfin₁)
+  let φ₂ := pointMapOfPushforward _ hι₂ hfin₂ (normFormulaAlong_of_elliptic _ hfin₂)
+  have hD := kw_surge_hgf4_bcIota₁_finrankAlong E₀ E₀' F₁ F₂ ι₁ hfin₁
+  have hker₁ : Nat.card (AddMonoidHom.ker φ₁) = N := by
+    rw [show φ₁ = _ from rfl,
+      kw_fdn2_qephod_hend7_pmopKerCard_proved F₁ (E₀⁄F₁).toAffine (E₀'⁄F₁).toAffine
+        ι₁ hι₁ hfin₁, ← hD,
+      ← kw_fdn2_qephod_hend7_pmopKerCard_proved F₂ (E₀⁄F₂).toAffine (E₀'⁄F₂).toAffine
+        _ hι₂ hfin₂]
+    exact hcard₂
+  let σ : F₁ →ₐ[R₀] F₂ := IsScalarTower.toAlgHom R₀ F₁ F₂
+  let σE : (E₀⁄F₁).toAffine.Point →+ (E₀⁄F₂).toAffine.Point :=
+    WeierstrassCurve.Affine.Point.map (W' := E₀.toAffine) σ
+  let σE' : (E₀'⁄F₁).toAffine.Point →+ (E₀'⁄F₂).toAffine.Point :=
+    WeierstrassCurve.Affine.Point.map (W' := E₀'.toAffine) σ
+  have hσE_inj : Function.Injective σE :=
+    WeierstrassCurve.Affine.Point.map_injective (W' := E₀.toAffine) σ
+  have hnat : ∀ P, φ₂ (σE P) = σE' (φ₁ P) :=
+    kw_surge_hgf4_pmop_naturality E₀ E₀' F₁ F₂ ι₁ hι₁ hfin₁ σ (fun _ => rfl)
+  have hker_sub : ∀ P ∈ AddMonoidHom.ker φ₁, σE P ∈ AddMonoidHom.ker φ₂ := by
+    intro P hP
+    rw [AddMonoidHom.mem_ker] at hP ⊢
+    rw [hnat P, hP, map_zero]
+  let σE_ker : (AddMonoidHom.ker φ₁) →+ (AddMonoidHom.ker φ₂) :=
+    { toFun := fun ⟨P, hP⟩ => ⟨σE P, hker_sub P hP⟩
+      map_zero' := Subtype.ext (map_zero σE)
+      map_add' := fun ⟨P, _⟩ ⟨Q, _⟩ => Subtype.ext (map_add σE P Q) }
+  have hσE_ker_inj : Function.Injective σE_ker := fun ⟨P, _⟩ ⟨Q, _⟩ hPQ =>
+    Subtype.ext (hσE_inj (Subtype.ext_iff.mp hPQ))
+  have hcard_eq : Nat.card (AddMonoidHom.ker φ₁) = Nat.card (AddMonoidHom.ker φ₂) := by
+    rw [hker₁, hcard₂]
+  have hfin_ker₁ : Finite (AddMonoidHom.ker φ₁) :=
+    Nat.finite_of_card_ne_zero (hker₁ ▸ (NeZero.ne N))
+  have hfin_ker₂ : Finite (AddMonoidHom.ker φ₂) :=
+    Nat.finite_of_card_ne_zero (hcard₂ ▸ (NeZero.ne N))
+  have hσE_ker_bij : Function.Bijective σE_ker :=
+    (Nat.bijective_iff_injective_and_card _).mpr ⟨hσE_ker_inj, hcard_eq⟩
+  let e : (AddMonoidHom.ker φ₁) ≃+ (AddMonoidHom.ker φ₂) :=
+    AddEquiv.ofBijective σE_ker hσE_ker_bij
+  have hcyc₁ : IsAddCyclic (AddMonoidHom.ker φ₁) := by
+    obtain ⟨⟨g₂, hg₂⟩⟩ := hcyc₂
+    exact ⟨⟨e.symm g₂, fun y => by
+      obtain ⟨k, hk⟩ := hg₂ (e y)
+      exact ⟨k, e.injective (by rw [map_zsmul, e.apply_symm_apply]; exact hk)⟩⟩⟩
+  exact ⟨hcyc₁, hker₁⟩
+
+end ModularCurve
+end
+end
+
+theorem hBC_s17 :
+    ModularCurve.KwD5BetweenCurvesFFSeamBaseChange := ModularCurve.kw_surge_hgf4_hBC_proved
+theorem kerTransport_s17 :
+    ModularCurve.KwD5BetweenCurvesKerTransportAlongEmbed :=
+      ModularCurve.kw_surgehgf4_hfgkd_ktd_kerTransport_proved
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg\
+  " in
+open _root_.WeierstrassCurve
+  _root_.P2MW.S_OVERLONG_c68ce07f.WeierstrassCurve
+  _root_.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_c68ce07f.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_c68ce07f.AlgebraicCurve
+  in
+theorem solution
+    (R₀ : Type) [Field R₀] (E₀ E₀' : WeierstrassCurve R₀) [E₀.IsElliptic] [E₀'.IsElliptic]
+    (F F' : Type) [Field F] [Field F'] [Algebra R₀ F] [Algebra R₀ F']
+    [DecidableEq F] [DecidableEq F'] [IsAlgClosed F] [IsAlgClosed F'] [CharZero F] [CharZero F']
+    [(E₀.baseChange F).IsElliptic] [(E₀'.baseChange F).IsElliptic]
+    [(E₀.baseChange F').IsElliptic] [(E₀'.baseChange F').IsElliptic]
+    [GenusOnePlaceGate (E₀.baseChange F).toAffine]
+    [GenusOnePlaceGate.IsCentred (E₀.baseChange F).toAffine]
+    [AbelTheorem (E₀.baseChange F).toAffine]
+    [GenusOnePlaceGate (E₀'.baseChange F).toAffine]
+    [GenusOnePlaceGate.IsCentred (E₀'.baseChange F).toAffine]
+    [AbelTheorem (E₀'.baseChange F).toAffine]
+    [GenusOnePlaceGate (E₀.baseChange F').toAffine]
+    [GenusOnePlaceGate.IsCentred (E₀.baseChange F').toAffine]
+    [AbelTheorem (E₀.baseChange F').toAffine]
+    [GenusOnePlaceGate (E₀'.baseChange F').toAffine]
+    [GenusOnePlaceGate.IsCentred (E₀'.baseChange F').toAffine]
+    [AbelTheorem (E₀'.baseChange F').toAffine]
+    (σ : F →ₐ[R₀] F')
+    (ι₀ : (E₀'.baseChange F).toAffine.FunctionField →ₐ[F] (E₀.baseChange F).toAffine.FunctionField)
+    (hι₀ : ι₀.toRingHom.IsIntegral) (hfin₀ : FiniteAlong F ι₀) (hN₀ : NormFormulaAlong F ι₀ hfin₀)
+    (N : ℕ) [NeZero N]
+    (hcyc : IsAddCyclic (pointMapOfPushforward ι₀ hι₀ hfin₀ hN₀).ker)
+    (hcard : Nat.card (pointMapOfPushforward ι₀ hι₀ hfin₀ hN₀).ker = N) :
+    ∃ (ι₁ : (E₀'.baseChange F').toAffine.FunctionField →ₐ[F'] (E₀.baseChange
+      F').toAffine.FunctionField)
+      (hι₁ : ι₁.toRingHom.IsIntegral) (hfin₁ : FiniteAlong F' ι₁),
+      ∀ hN₁ : NormFormulaAlong F' ι₁ hfin₁,
+        IsAddCyclic (pointMapOfPushforward ι₁ hι₁ hfin₁ hN₁).ker ∧
+          Nat.card (pointMapOfPushforward ι₁ hι₁ hfin₁ hN₁).ker = N := by
+  obtain ⟨ι₁, hι₁, hfin₁, hcyc₁, hcard₁⟩ :=
+    hBC_s17 R₀ E₀ E₀' F F' σ ι₀ hι₀ hfin₀ N hcyc hcard
+  exact ⟨ι₁, hι₁, hfin₁, fun _ => ⟨hcyc₁, hcard₁⟩⟩
+
+end
+end
+end
+end
+end
+end
+end
+end
+end S_OVERLONG_c68ce07f
+end P2MW
+export
+  P2MW.S_OVERLONG_c68ce07f
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+theorem WeierstrassCurve.Affine.exists_algHom_baseChange_of_isAddCyclic_ker_pointMapOfPushforward
+    (R₀ : Type) [Field R₀] (E₀ E₀' : WeierstrassCurve R₀) [E₀.IsElliptic] [E₀'.IsElliptic]
+    (F F' : Type) [Field F] [Field F'] [Algebra R₀ F] [Algebra R₀ F']
+    [DecidableEq F] [DecidableEq F'] [IsAlgClosed F] [IsAlgClosed F'] [CharZero F] [CharZero F']
+    [(E₀.baseChange F).IsElliptic] [(E₀'.baseChange F).IsElliptic]
+    [(E₀.baseChange F').IsElliptic] [(E₀'.baseChange F').IsElliptic]
+    [GenusOnePlaceGate (E₀.baseChange F).toAffine]
+    [GenusOnePlaceGate.IsCentred (E₀.baseChange F).toAffine]
+    [AbelTheorem (E₀.baseChange F).toAffine]
+    [GenusOnePlaceGate (E₀'.baseChange F).toAffine]
+    [GenusOnePlaceGate.IsCentred (E₀'.baseChange F).toAffine]
+    [AbelTheorem (E₀'.baseChange F).toAffine]
+    [GenusOnePlaceGate (E₀.baseChange F').toAffine]
+    [GenusOnePlaceGate.IsCentred (E₀.baseChange F').toAffine]
+    [AbelTheorem (E₀.baseChange F').toAffine]
+    [GenusOnePlaceGate (E₀'.baseChange F').toAffine]
+    [GenusOnePlaceGate.IsCentred (E₀'.baseChange F').toAffine]
+    [AbelTheorem (E₀'.baseChange F').toAffine]
+    (σ : F →ₐ[R₀] F')
+    (ι₀ : (E₀'.baseChange F).toAffine.FunctionField →ₐ[F] (E₀.baseChange F).toAffine.FunctionField)
+    (hι₀ : ι₀.toRingHom.IsIntegral) (hfin₀ : FiniteAlong F ι₀) (hN₀ : NormFormulaAlong F ι₀ hfin₀)
+    (N : ℕ) [NeZero N]
+    (hcyc : IsAddCyclic (pointMapOfPushforward ι₀ hι₀ hfin₀ hN₀).ker)
+    (hcard : Nat.card (pointMapOfPushforward ι₀ hι₀ hfin₀ hN₀).ker = N) :
+    ∃ (ι₁ : (E₀'.baseChange F').toAffine.FunctionField →ₐ[F'] (E₀.baseChange
+      F').toAffine.FunctionField)
+      (hι₁ : ι₁.toRingHom.IsIntegral) (hfin₁ : FiniteAlong F' ι₁),
+      ∀ hN₁ : NormFormulaAlong F' ι₁ hfin₁,
+        IsAddCyclic (pointMapOfPushforward ι₁ hι₁ hfin₁ hN₁).ker ∧
+          Nat.card (pointMapOfPushforward ι₁ hι₁ hfin₁ hN₁).ker = N :=
+  solution R₀ E₀ E₀' F F' σ ι₀ hι₀ hfin₀ hN₀ N hcyc hcard
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_algHom_functionField_baseChange_finrankAlong_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_algHom_functionField_baseChange_finrankAlong_eq.lean
new file mode 100644
index 0000000000..5d3e8a5386
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_algHom_functionField_baseChange_finrankAlong_eq.lean
@@ -0,0 +1,1452 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.Affine.exists_algHom_functionField_baseChange_finrankAlong_eq
+(f9fb6037-8f9d-5c67-be82-66f7e78fec74) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b3015788-82b4-558c-8e89-28fc2203960b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+
+import Mathlib.Algebra.Polynomial.Basis
+import Mathlib.RingTheory.Flat.TorsionFree
+import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FunctionFieldQuadratic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Base change of a finite self-embedding preserves its degree
+
+Theorem statement: `WeierstrassCurve.Affine.exists_algHom_functionField_baseChange_finrankAlong_eq`
+(`f9fb6037-8f9d-5c67-be82-66f7e78fec74`), by Claude, 2026-09-05.
+
+Proof: submission `b3015788-82b4-558c-8e89-28fc2203960b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R_0$ be a field and $W$ a Weierstrass curve over $R_0$ which is elliptic. Let $F$ and $F'$ be
+algebraically closed fields of characteristic zero, each an $R_0$-algebra, with $F'$ an $F$-algebra
+in such a way that the two $R_0$-algebra structures are compatible (a scalar tower over $R_0$).
+Write $K_F$ for the function field of the affine curve underlying the base change $W_F = W
+\otimes_{R_0} F$, and $K_{F'}$ likewise for $W_{F'}$. Suppose given an $F$-algebra homomorphism
+$\iota : K_F \to K_F$ whose underlying ring homomorphism is integral, and suppose that $K_F$ is
+finite as a module over $K_F$ for the algebra structure transported along $\iota$, i.e. `FiniteAlong
+F ι` holds. The conclusion is the existence of an $F'$-algebra homomorphism $\iota' : K_{F'} \to
+K_{F'}$ whose underlying ring homomorphism is integral and for which `FiniteAlong F' ι'` holds, such
+that the module rank of $K_{F'}$ over itself along $\iota'$ equals the module rank of $K_F$ over
+itself along $\iota$; that is, $\operatorname{finrankAlong} F' \iota' = \operatorname{finrankAlong}
+F \iota$. The three fields $R_0$, $F$, $F'$ lie in three independent universes.
+
+This is the base-change compatibility for a self-embedding of the function field of an elliptic
+curve: an integral self-embedding of finite degree over an algebraically closed field of
+characteristic zero propagates to any larger algebraically closed field of characteristic zero with
+the same degree, the independence of the universes allowing a datum obtained over an algebraic
+closure of a number field to be transported to $\mathbb{C}$. It is used in the analysis of isogeny
+endomorphism data, where equality of degrees after base change is turned into a polynomial relation
+for the $j$-invariant.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_exists_algHom_functionField_baseChange_finrankAlong_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 400000
+
+section privateSection
+
+namespace P2MW.S_OVERLONG_7837151f
+
+
+noncomputable section
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map_map map mk Jacobian IsIntegral toAffine Affine.Point \
+  map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ baseChange j map_a₃ Affine.IsogenyEndDatum"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation equation_iff' map_a₃ slope CoordinateRing \
+  map baseChange Equation.baseChange map_a₆ FunctionField map_a₂ Point CoordinateRing.mk addX \
+  map_a₁ CoordinateRing.map map_a₄ CoordinateRing.basis_apply CoordinateRing.map_smul \
+  CoordinateRing.basis addY equation_iff polynomial IsogenyEndDatum polyToFunctionField \
+  polyToFunctionField_apply polyToFunctionField_injective polyToFunctionField_C \
+  algebraMap_smul_basis"
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "hfin hι mk ι"
+p2m_open "WeierstrassCurve.Affine.IsogenyEndDatum WeierstrassCurve.Affine WeierstrassCurve"
+private def _root_.WeierstrassCurve.Affine.IsogenyEndDatum.degree {F : Type*} [Field F]
+    {W : WeierstrassCurve.Affine F} (D : IsogenyEndDatum W) :
+    ℕ :=
+  AlgebraicCurve.finrankAlong F D.ι
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "degree"
+end WeierstrassCurve.Affine.IsogenyEndDatum
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "algebraAlong FiniteAlong finrankAlong Place"
+end AlgebraicCurve
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "HeightOneSpectrum.eq_of_valuation_isEquiv_valuation mk \
+  HeightOneSpectrum"
+end IsDedekindDomain
+namespace Polynomial
+p2m_export "Polynomial" "C eval₂_sub X coeff algebraMap_eq divX eval₂ aeval eval₂_add monomial \
+  basisMonomials eval₂_pow degree C_0 factor aeval_C map_map map_C map eval₂_X comp algebra \
+  eval₂_mul exists_eq_pow_rootMultiplicity_mul_and_not_dvd X_dvd_iff algHom_ext sum divX_mul_X_add \
+  flt aeval_algHom aeval_X map_monomial algebraMap_apply coe_basisMonomials ext eval₂_C funext \
+  ring ringHom_ext transcendental"
+end Polynomial
+namespace Polynomial
+p2m_export "Polynomial" "C eval₂_sub X coeff algebraMap_eq divX eval₂ aeval eval₂_add monomial \
+  basisMonomials eval₂_pow degree C_0 factor aeval_C map_map map_C map eval₂_X comp algebra \
+  eval₂_mul exists_eq_pow_rootMultiplicity_mul_and_not_dvd X_dvd_iff algHom_ext sum divX_mul_X_add \
+  flt aeval_algHom aeval_X map_monomial algebraMap_apply coe_basisMonomials ext eval₂_C funext \
+  ring ringHom_ext transcendental"
+end Polynomial
+namespace TensorProduct
+p2m_export "TensorProduct" "map_tmul congr lift_mk map_map smul_tmul zero_tmul sum_tmul lift mk \
+  ext tmul map Algebra.smul_def comm_tmul mk_surjective"
+end TensorProduct
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map_map map mk Jacobian IsIntegral toAffine Affine.Point \
+  map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ baseChange j map_a₃ Affine.IsogenyEndDatum"
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map_map map mk Jacobian IsIntegral toAffine Affine.Point \
+  map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ baseChange j map_a₃ Affine.IsogenyEndDatum"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation equation_iff' map_a₃ slope CoordinateRing \
+  map baseChange Equation.baseChange map_a₆ FunctionField map_a₂ Point CoordinateRing.mk addX \
+  map_a₁ CoordinateRing.map map_a₄ CoordinateRing.basis_apply CoordinateRing.map_smul \
+  CoordinateRing.basis addY equation_iff polynomial IsogenyEndDatum polyToFunctionField \
+  polyToFunctionField_apply polyToFunctionField_injective polyToFunctionField_C \
+  algebraMap_smul_basis"
+end WeierstrassCurve.Affine
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map_map map mk Jacobian IsIntegral toAffine Affine.Point \
+  map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ baseChange j map_a₃ Affine.IsogenyEndDatum"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation equation_iff' map_a₃ slope CoordinateRing \
+  map baseChange Equation.baseChange map_a₆ FunctionField map_a₂ Point CoordinateRing.mk addX \
+  map_a₁ CoordinateRing.map map_a₄ CoordinateRing.basis_apply CoordinateRing.map_smul \
+  CoordinateRing.basis addY equation_iff polynomial IsogenyEndDatum polyToFunctionField \
+  polyToFunctionField_apply polyToFunctionField_injective polyToFunctionField_C \
+  algebraMap_smul_basis"
+namespace Point
+p2m_export "WeierstrassCurve.Affine.Point" "add baseChange map_map map_zero map zero mk"
+end WeierstrassCurve.Affine.Point
+
+universe u v w
+
+section
+
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_7837151f.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_7837151f.Weierstrass\
+  Curve.Affine \
+  P2MW.S_OVERLONG_7837151f.ModularCurv\
+  e"
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_7837151f.Polynomial"
+p2m_open_scoped "TensorProduct \
+  P2MW.S_OVERLONG_7837151f.TensorProdu\
+  ct Polynomial \
+  P2MW.S_OVERLONG_7837151f.Polynomial"
+
+namespace ModularCurve
+
+section Setup
+
+variable (W : WeierstrassCurve ℚ) [W.IsElliptic]
+variable (F : Type v) [Field F] [Algebra ℚ F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (F' : Type w) [Field F'] [Algebra ℚ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower ℚ F F']
+
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+local notation3 "CR" => (W⁄F).toAffine.CoordinateRing
+local notation3 "FF" => (W⁄F).FunctionField
+
+def kw_coordinateRingBasis {R : Type*} [CommRing R] (V : Affine R) :
+    Module.Basis (ℕ × Fin 2) R V.CoordinateRing :=
+  (Polynomial.basisMonomials R).smulTower (CoordinateRing.basis V)
+
+end Setup
+
+end ModularCurve
+
+end
+end
+
+
+
+section
+
+p2m_open "IsDedekindDomain \
+  P2MW.S_OVERLONG_7837151f.IsDedekindD\
+  omain Polynomial \
+  P2MW.S_OVERLONG_7837151f.Polynomial"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_7837151f.Polynomial.\
+  Bivariate"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "algebraAlong FiniteAlong finrankAlong Place"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext deg ofHeightOneSpectrum toValuationSubring mk"
+end AlgebraicCurve.Place
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map_map map mk Jacobian IsIntegral toAffine Affine.Point \
+  map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ baseChange j map_a₃ Affine.IsogenyEndDatum"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation equation_iff' map_a₃ slope CoordinateRing \
+  map baseChange Equation.baseChange map_a₆ FunctionField map_a₂ Point CoordinateRing.mk addX \
+  map_a₁ CoordinateRing.map map_a₄ CoordinateRing.basis_apply CoordinateRing.map_smul \
+  CoordinateRing.basis addY equation_iff polynomial IsogenyEndDatum polyToFunctionField \
+  polyToFunctionField_apply polyToFunctionField_injective polyToFunctionField_C \
+  algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "mk map basis_apply smul_basis_mul_Y"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing"
+
+theorem algebraMap_eq_mk_C_C (a : F) :
+    algebraMap F W.CoordinateRing a = CoordinateRing.mk W (C (C a)) := by
+  rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+    Algebra.algebraMap_self_apply]
+  rfl
+
+end CoordinateRing
+
+end WeierstrassCurve.Affine
+
+end
+
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_7837151f.Polynomial \
+  IsDedekindDomain \
+  P2MW.S_OVERLONG_7837151f.IsDedekindD\
+  omain"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_7837151f.Polynomial.\
+  Bivariate"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "algebraAlong FiniteAlong finrankAlong Place"
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map_map map mk Jacobian IsIntegral toAffine Affine.Point \
+  map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ baseChange j map_a₃ Affine.IsogenyEndDatum"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation equation_iff' map_a₃ slope CoordinateRing \
+  map baseChange Equation.baseChange map_a₆ FunctionField map_a₂ Point CoordinateRing.mk addX \
+  map_a₁ CoordinateRing.map map_a₄ CoordinateRing.basis_apply CoordinateRing.map_smul \
+  CoordinateRing.basis addY equation_iff polynomial IsogenyEndDatum polyToFunctionField \
+  polyToFunctionField_apply polyToFunctionField_injective polyToFunctionField_C \
+  algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_7837151f.Weierstrass\
+  Curve.Affine.CoordinateRing AlgebraicCurve \
+  P2MW.S_OVERLONG_7837151f.AlgebraicCu\
+  rve"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem algebraMap_polynomial_eq_mk_C (p : F[X]) :
+    algebraMap F[X] W.CoordinateRing p = CoordinateRing.mk W (C p) :=
+  rfl
+
+end WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map_map map mk Jacobian IsIntegral toAffine Affine.Point \
+  map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ baseChange j map_a₃ Affine.IsogenyEndDatum"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation equation_iff' map_a₃ slope CoordinateRing \
+  map baseChange Equation.baseChange map_a₆ FunctionField map_a₂ Point CoordinateRing.mk addX \
+  map_a₁ CoordinateRing.map map_a₄ CoordinateRing.basis_apply CoordinateRing.map_smul \
+  CoordinateRing.basis addY equation_iff polynomial IsogenyEndDatum polyToFunctionField \
+  polyToFunctionField_apply polyToFunctionField_injective polyToFunctionField_C \
+  algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_7837151f.Weierstrass\
+  Curve.Affine.CoordinateRing AlgebraicCurve \
+  P2MW.S_OVERLONG_7837151f.AlgebraicCu\
+  rve"
+
+variable {F : Type*} [Field F] (W : Affine F)
+
+variable {W}
+
+def yGen (W : Affine F) : W.FunctionField :=
+  algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+
+end WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map_map map mk Jacobian IsIntegral toAffine Affine.Point \
+  map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ baseChange j map_a₃ Affine.IsogenyEndDatum"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation equation_iff' map_a₃ slope CoordinateRing \
+  map baseChange Equation.baseChange map_a₆ FunctionField map_a₂ Point CoordinateRing.mk addX \
+  map_a₁ CoordinateRing.map map_a₄ CoordinateRing.basis_apply CoordinateRing.map_smul \
+  CoordinateRing.basis addY equation_iff polynomial IsogenyEndDatum polyToFunctionField \
+  polyToFunctionField_apply polyToFunctionField_injective polyToFunctionField_C \
+  algebraMap_smul_basis"
+end WeierstrassCurve.Affine
+
+end
+
+
+section
+
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_7837151f.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_7837151f.Weierstrass\
+  Curve.Affine \
+  P2MW.S_OVERLONG_7837151f.ModularCurv\
+  e AlgebraicCurve \
+  P2MW.S_OVERLONG_7837151f.AlgebraicCu\
+  rve"
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_7837151f.Polynomial"
+p2m_open_scoped "TensorProduct \
+  P2MW.S_OVERLONG_7837151f.TensorProdu\
+  ct Polynomial.Bivariate \
+  P2MW.S_OVERLONG_7837151f.Polynomial.\
+  Bivariate"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map_map map mk Jacobian IsIntegral toAffine Affine.Point \
+  map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ baseChange j map_a₃ Affine.IsogenyEndDatum"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation equation_iff' map_a₃ slope CoordinateRing \
+  map baseChange Equation.baseChange map_a₆ FunctionField map_a₂ Point CoordinateRing.mk addX \
+  map_a₁ CoordinateRing.map map_a₄ CoordinateRing.basis_apply CoordinateRing.map_smul \
+  CoordinateRing.basis addY equation_iff polynomial IsogenyEndDatum polyToFunctionField \
+  polyToFunctionField_apply polyToFunctionField_injective polyToFunctionField_C \
+  algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+variable {F : Type u} [Field F] {W : Affine F}
+
+theorem kw_functionField_algHom_ext {L : Type*} [Field L] [Algebra F L]
+    {f g : W.FunctionField →ₐ[F] L}
+    (hX : f (polyToFunctionField W X) = g (polyToFunctionField W X))
+    (hy : f (yGen W) = g (yGen W)) : f = g := by
+  have hCR : ∀ r : W.CoordinateRing,
+      f (algebraMap W.CoordinateRing W.FunctionField r)
+        = g (algebraMap W.CoordinateRing W.FunctionField r) := by
+    intro r
+    obtain ⟨p, rfl⟩ := AdjoinRoot.mk_surjective r
+    have hFX : ∀ c : F[X], f (algebraMap W.CoordinateRing W.FunctionField
+          (algebraMap F[X] W.CoordinateRing c))
+        = g (algebraMap W.CoordinateRing W.FunctionField
+          (algebraMap F[X] W.CoordinateRing c)) :=
+      fun c => DFunLike.congr_fun
+        (Polynomial.algHom_ext (f := (f.comp (IsScalarTower.toAlgHom F W.CoordinateRing
+            W.FunctionField)).comp (IsScalarTower.toAlgHom F F[X] W.CoordinateRing))
+          (g := (g.comp (IsScalarTower.toAlgHom F W.CoordinateRing W.FunctionField)).comp
+            (IsScalarTower.toAlgHom F F[X] W.CoordinateRing)) hX) c
+    have hFX' : ∀ c : F[X], f (algebraMap W.CoordinateRing W.FunctionField
+          (AdjoinRoot.mk W.polynomial (C c)))
+        = g (algebraMap W.CoordinateRing W.FunctionField
+          (AdjoinRoot.mk W.polynomial (C c))) := fun c => by
+      rw [show AdjoinRoot.mk W.polynomial (C c) = algebraMap F[X] W.CoordinateRing c from rfl]
+      exact hFX c
+    have hy' : f (algebraMap W.CoordinateRing W.FunctionField (AdjoinRoot.mk W.polynomial Y))
+        = g (algebraMap W.CoordinateRing W.FunctionField (AdjoinRoot.mk W.polynomial Y)) := hy
+    induction p using Polynomial.induction_on with
+    | C c => exact hFX' c
+    | monomial n c _ => simp only [map_mul, map_pow, hy', hFX' c]
+    | add p q hp hq => simp only [map_add, hp, hq]
+  refine AlgHom.ext fun a => ?_
+  obtain ⟨p, q, hq, rfl⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) a
+  simp only [map_div₀, hCR p, hCR q]
+
+end WeierstrassCurve.Affine
+
+namespace ModularCurve
+
+section Setup
+
+variable (W : WeierstrassCurve ℚ) [W.IsElliptic]
+variable (F : Type v) [Field F] [Algebra ℚ F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (F' : Type w) [Field F'] [Algebra ℚ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower ℚ F F']
+
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+end Setup
+
+end ModularCurve
+
+end
+end
+
+
+section
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_7837151f.Polynomial \
+  WeierstrassCurve \
+  P2MW.S_OVERLONG_7837151f.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_7837151f.Weierstrass\
+  Curve.Affine"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_7837151f.Polynomial.\
+  Bivariate"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map_map map mk Jacobian IsIntegral toAffine Affine.Point \
+  map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ baseChange j map_a₃ Affine.IsogenyEndDatum"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation equation_iff' map_a₃ slope CoordinateRing \
+  map baseChange Equation.baseChange map_a₆ FunctionField map_a₂ Point CoordinateRing.mk addX \
+  map_a₁ CoordinateRing.map map_a₄ CoordinateRing.basis_apply CoordinateRing.map_smul \
+  CoordinateRing.basis addY equation_iff polynomial IsogenyEndDatum polyToFunctionField \
+  polyToFunctionField_apply polyToFunctionField_injective polyToFunctionField_C \
+  algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_7837151f.Weierstrass\
+  Curve.Affine.CoordinateRing"
+
+variable {F : Type u} [Field F]
+
+section PointPullbackTo
+
+variable {W : Affine F} {L : Type*} [Field L] [Algebra F L]
+
+theorem eval₂_polynomial_of_equation_map_target {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) :
+    W.polynomial.eval₂
+      (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom yP = 0 := by
+  rw [equation_iff'] at h
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆] at h
+  simp only [WeierstrassCurve.Affine.polynomial, eval₂_add, eval₂_sub, eval₂_mul, eval₂_pow,
+    eval₂_X, eval₂_C, AlgHom.toRingHom_eq_coe, RingHom.coe_coe, map_add, map_mul, map_pow,
+    Polynomial.aeval_C, Polynomial.aeval_X]
+  linear_combination h
+
+def pointPullbackCoordHomTo {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) :
+    W.CoordinateRing →ₐ[F] L where
+  __ := AdjoinRoot.lift
+    (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom
+    yP (eval₂_polynomial_of_equation_map_target h)
+  commutes' c := by
+    change AdjoinRoot.lift _ _ (eval₂_polynomial_of_equation_map_target h) (algebraMap F _ c)
+      = algebraMap F L c
+    rw [CoordinateRing.algebraMap_eq_mk_C_C, AdjoinRoot.lift_mk, eval₂_C]
+    exact Polynomial.aeval_C _ c
+
+theorem pointPullbackCoordHomTo_mk {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) (g : F[X][Y]) :
+    pointPullbackCoordHomTo h (CoordinateRing.mk W g)
+      = g.eval₂ (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom yP :=
+  AdjoinRoot.lift_mk (eval₂_polynomial_of_equation_map_target h) g
+
+theorem pointPullbackCoordHomTo_comp_algebraMap {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) :
+    (pointPullbackCoordHomTo h).toRingHom.comp (algebraMap F[X] W.CoordinateRing)
+      = (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom := by
+  refine RingHom.ext fun p => ?_
+  change pointPullbackCoordHomTo h (algebraMap F[X] _ p) = _
+  rw [algebraMap_polynomial_eq_mk_C, pointPullbackCoordHomTo_mk, eval₂_C]
+
+theorem pointPullbackCoordHomTo_injective {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    Function.Injective (pointPullbackCoordHomTo h) := by
+  have hker : RingHom.ker (pointPullbackCoordHomTo h).toRingHom = ⊥ := by
+    have : Module.Finite F[X] W.CoordinateRing :=
+      Module.Finite.of_basis (CoordinateRing.basis W)
+    refine Ideal.eq_bot_of_under_eq_bot (R := F[X]) ?_
+    rw [Ideal.under_def, RingHom.comap_ker, pointPullbackCoordHomTo_comp_algebraMap,
+      ← RingHom.injective_iff_ker_eq_bot]
+    exact hx
+  exact (RingHom.injective_iff_ker_eq_bot (pointPullbackCoordHomTo h).toRingHom).mpr hker
+
+def pointPullbackHomTo {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    W.FunctionField →ₐ[F] L :=
+  IsFractionRing.liftAlgHom (pointPullbackCoordHomTo_injective h hx)
+
+theorem pointPullbackHomTo_algebraMap {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) (r : W.CoordinateRing) :
+    pointPullbackHomTo h hx (algebraMap W.CoordinateRing W.FunctionField r)
+      = pointPullbackCoordHomTo h r :=
+  IsFractionRing.lift_algebraMap (pointPullbackCoordHomTo_injective h hx) r
+
+theorem pointPullbackHomTo_polyToFunctionField_X {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    pointPullbackHomTo h hx (polyToFunctionField W X) = xP := by
+  rw [polyToFunctionField_apply, pointPullbackHomTo_algebraMap,
+    algebraMap_polynomial_eq_mk_C, pointPullbackCoordHomTo_mk, eval₂_C]
+  exact Polynomial.aeval_X _
+
+theorem pointPullbackHomTo_yGen {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    pointPullbackHomTo h hx (yGen W) = yP := by
+  change pointPullbackHomTo h hx (algebraMap _ _ (CoordinateRing.mk W Y)) = _
+  rw [pointPullbackHomTo_algebraMap, pointPullbackCoordHomTo_mk]
+  exact eval₂_X _ _
+
+end PointPullbackTo
+
+end WeierstrassCurve.Affine
+
+end
+
+end
+
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_7837151f.Polynomial \
+  IsDedekindDomain \
+  P2MW.S_OVERLONG_7837151f.IsDedekindD\
+  omain"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_7837151f.Polynomial.\
+  Bivariate"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map_map map mk Jacobian IsIntegral toAffine Affine.Point \
+  map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ baseChange j map_a₃ Affine.IsogenyEndDatum"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation equation_iff' map_a₃ slope CoordinateRing \
+  map baseChange Equation.baseChange map_a₆ FunctionField map_a₂ Point CoordinateRing.mk addX \
+  map_a₁ CoordinateRing.map map_a₄ CoordinateRing.basis_apply CoordinateRing.map_smul \
+  CoordinateRing.basis addY equation_iff polynomial IsogenyEndDatum polyToFunctionField \
+  polyToFunctionField_apply polyToFunctionField_injective polyToFunctionField_C \
+  algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_7837151f.Weierstrass\
+  Curve.Affine.CoordinateRing AlgebraicCurve \
+  P2MW.S_OVERLONG_7837151f.AlgebraicCu\
+  rve"
+
+variable {F : Type u} [Field F]
+
+section GenericPoint
+
+variable {W : Affine F}
+
+theorem polyToFunctionField_eq_aeval (p : F[X]) :
+    polyToFunctionField W p = Polynomial.aeval (polyToFunctionField W X) p := by
+  have h1 : (polyToFunctionField W : F[X] →+* W.FunctionField)
+      = algebraMap F[X] W.FunctionField :=
+    (IsScalarTower.algebraMap_eq F[X] W.CoordinateRing W.FunctionField).symm
+  have h2 : (IsScalarTower.toAlgHom F F[X] W.FunctionField : F[X] →ₐ[F] W.FunctionField)
+      = Polynomial.aeval (polyToFunctionField W X) := by
+    refine Polynomial.algHom_ext ?_
+    rw [Polynomial.aeval_X, IsScalarTower.coe_toAlgHom', ← h1]
+  calc polyToFunctionField W p = algebraMap F[X] W.FunctionField p := by rw [h1]
+    _ = (IsScalarTower.toAlgHom F F[X] W.FunctionField : F[X] →ₐ[F] W.FunctionField) p := rfl
+    _ = Polynomial.aeval (polyToFunctionField W X) p := by rw [h2]
+
+theorem equation_map_polyToFunctionField_yGen :
+    (W.map (algebraMap F W.FunctionField)).toAffine.Equation
+      (polyToFunctionField W X) (yGen W) := by
+  rw [equation_iff]
+  have hrel := smul_basis_mul_Y (W' := W) 0 1
+  rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at hrel
+  have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) hrel
+  rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆]
+  simp only [map_add, map_mul, map_pow, polyToFunctionField_C] at h2
+  rw [show yGen W = algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+    from rfl]
+  simp only [polyToFunctionField_apply] at h2 ⊢
+  linear_combination h2
+
+end GenericPoint
+
+end WeierstrassCurve.Affine
+
+end
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_7837151f.Polynomial \
+  WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_7837151f.Weierstrass\
+  Curve.Affine WeierstrassCurve.Affine.Point \
+  P2MW.S_OVERLONG_7837151f.Weierstrass\
+  Curve.Affine.Point"
+
+p2m_open_scoped "WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_7837151f.Weierstrass\
+  Curve.Affine Polynomial.Bivariate \
+  P2MW.S_OVERLONG_7837151f.Polynomial.\
+  Bivariate"
+
+section
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map_map map mk Jacobian IsIntegral toAffine Affine.Point \
+  map_a₆ map_a₁ map_a₄ Δ Affine.polynomial map_a₂ baseChange j map_a₃ Affine.IsogenyEndDatum"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation equation_iff' map_a₃ slope CoordinateRing \
+  map baseChange Equation.baseChange map_a₆ FunctionField map_a₂ Point CoordinateRing.mk addX \
+  map_a₁ CoordinateRing.map map_a₄ CoordinateRing.basis_apply CoordinateRing.map_smul \
+  CoordinateRing.basis addY equation_iff polynomial IsogenyEndDatum polyToFunctionField \
+  polyToFunctionField_apply polyToFunctionField_injective polyToFunctionField_C \
+  algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_7837151f.Weierstrass\
+  Curve.Affine.CoordinateRing AlgebraicCurve \
+  P2MW.S_OVERLONG_7837151f.AlgebraicCu\
+  rve"
+
+variable {F : Type u} [Field F]
+
+section TranslationCoords
+
+variable (W : Affine F) (a b : F)
+
+local notation "ι" => algebraMap F W.FunctionField
+
+end TranslationCoords
+
+section GenericPointGroup
+
+variable {W : Affine F}
+
+local notation "ι" => algebraMap F W.FunctionField
+
+end GenericPointGroup
+
+section AdjoinSurjective
+
+variable {W : Affine F} (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b)
+
+local notation "ι" => algebraMap F W.FunctionField
+
+theorem transcendental_polyToFunctionField_X :
+    Transcendental F (polyToFunctionField W X) := by
+  rw [transcendental_iff]
+  intro p hp
+  rw [← polyToFunctionField_eq_aeval] at hp
+  exact polyToFunctionField_injective (by simpa using hp)
+
+end AdjoinSurjective
+
+end WeierstrassCurve.Affine
+
+end
+
+end
+
+section
+
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_7837151f.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_7837151f.Weierstrass\
+  Curve.Affine \
+  P2MW.S_OVERLONG_7837151f.ModularCurv\
+  e AlgebraicCurve \
+  P2MW.S_OVERLONG_7837151f.AlgebraicCu\
+  rve"
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_7837151f.Polynomial"
+p2m_open_scoped "TensorProduct \
+  P2MW.S_OVERLONG_7837151f.TensorProdu\
+  ct Polynomial.Bivariate \
+  P2MW.S_OVERLONG_7837151f.Polynomial.\
+  Bivariate"
+
+namespace ModularCurve
+
+section Setup
+
+variable {R₀ : Type u} [Field R₀]
+variable (W : WeierstrassCurve R₀) [W.IsElliptic]
+variable (F : Type v) [Field F] [Algebra R₀ F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (F' : Type w) [Field F'] [Algebra R₀ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower R₀ F F']
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [Algebra R₀ F] [IsAlgClosed F] [CharZero F] [IsAlgClosed F'] [CharZero F']
+  [IsScalarTower R₀ F F'] in
+theorem kw_transcendental_polyToFunctionField_X_over_baseGeneral :
+    Transcendental F (polyToFunctionField (W⁄F') X) := by
+  classical
+  exact
+    Transcendental.of_tower_top F (L := F')
+      (transcendental_polyToFunctionField_X (W := (W⁄F')))
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [IsAlgClosed F] [CharZero F] [IsAlgClosed F'] [CharZero F'] in
+theorem kw_equation_map_polyToFunctionField_yGen_over_baseGeneral :
+    ((W⁄F).map (algebraMap F (W⁄F').FunctionField)).toAffine.Equation
+      (polyToFunctionField (W⁄F') X) (yGen (W⁄F')) := by
+  classical
+  have hcurve : (W⁄F).map (algebraMap F (W⁄F').FunctionField)
+      = (W⁄F').map (algebraMap F' (W⁄F').FunctionField) := by
+    change (W.map _).map _ = (W.map _).map _
+    rw [WeierstrassCurve.map_map, WeierstrassCurve.map_map]
+    congr 1
+    exact ((IsScalarTower.algebraMap_eq R₀ F (W⁄F').FunctionField).symm).trans
+      (IsScalarTower.algebraMap_eq R₀ F' (W⁄F').FunctionField)
+  exact hcurve ▸ equation_map_polyToFunctionField_yGen (W := (W⁄F'))
+
+set_option synthInstance.maxHeartbeats 3200000 in
+def kw_functionFieldMapAlongGeneral : (W⁄F).FunctionField →ₐ[F] (W⁄F').FunctionField :=
+  pointPullbackHomTo (kw_equation_map_polyToFunctionField_yGen_over_baseGeneral W F F')
+    ((injective_iff_map_eq_zero _).mpr fun p hp =>
+      transcendental_iff.mp (kw_transcendental_polyToFunctionField_X_over_baseGeneral W F F') p
+        hp)
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [IsAlgClosed F] [CharZero F] [IsAlgClosed F'] [CharZero F'] in
+theorem kw_functionFieldMapAlongGeneral_polyToFunctionField_X :
+    kw_functionFieldMapAlongGeneral W F F' (polyToFunctionField (W⁄F) X)
+      = polyToFunctionField (W⁄F') X := by
+  classical
+  exact
+    pointPullbackHomTo_polyToFunctionField_X _ _
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [IsAlgClosed F] [CharZero F] [IsAlgClosed F'] [CharZero F'] in
+theorem kw_functionFieldMapAlongGeneral_yGen :
+    kw_functionFieldMapAlongGeneral W F F' (yGen (W⁄F)) = yGen (W⁄F') := by
+  classical
+  exact
+    pointPullbackHomTo_yGen _ _
+
+def KwFunctionFieldTensorIsDomainGeneral : Prop :=
+  IsDomain ((W⁄F).FunctionField ⊗[F] F')
+
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+scoped instance kw_isScalarTower_base_right_tensorGeneral :
+    IsScalarTower R₀ F' ((W⁄F).FunctionField ⊗[F] F') := by
+  refine IsScalarTower.of_algebraMap_eq' (RingHom.ext fun r => ?_)
+  rw [RingHom.comp_apply, Algebra.TensorProduct.right_algebraMap_apply,
+    IsScalarTower.algebraMap_apply R₀ F F',
+    show algebraMap R₀ ((W⁄F).FunctionField ⊗[F] F') r
+      = (algebraMap F ((W⁄F).FunctionField ⊗[F] F')) (algebraMap R₀ F r) from
+        IsScalarTower.algebraMap_apply R₀ F ((W⁄F).FunctionField ⊗[F] F') r,
+    Algebra.TensorProduct.algebraMap_apply, Algebra.algebraMap_eq_smul_one,
+    Algebra.algebraMap_eq_smul_one, TensorProduct.smul_tmul, Algebra.algebraMap_eq_smul_one]
+
+section FracHom
+
+variable [IsDomain ((W⁄F).FunctionField ⊗[F] F')]
+
+scoped instance kw_isScalarTower_base_right_fracTensorGeneral :
+    IsScalarTower R₀ F' (FractionRing ((W⁄F).FunctionField ⊗[F] F')) :=
+  IsScalarTower.of_algebraMap_eq fun r =>
+    (IsScalarTower.algebraMap_apply R₀ ((W⁄F).FunctionField ⊗[F] F')
+        (FractionRing ((W⁄F).FunctionField ⊗[F] F')) r).trans <|
+      (congrArg (algebraMap ((W⁄F).FunctionField ⊗[F] F')
+          (FractionRing ((W⁄F).FunctionField ⊗[F] F')))
+        (IsScalarTower.algebraMap_apply R₀ F' ((W⁄F).FunctionField ⊗[F] F') r)).trans
+      (IsScalarTower.algebraMap_apply F' ((W⁄F).FunctionField ⊗[F] F')
+        (FractionRing ((W⁄F).FunctionField ⊗[F] F')) (algebraMap R₀ F' r)).symm
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [IsAlgClosed F] [CharZero F] [IsAlgClosed F'] [CharZero F']
+  [IsDomain ((W⁄F).FunctionField ⊗[F] F')] in
+theorem kw_equation_tensorFracXYGeneral :
+    ((W⁄F').map (algebraMap F' (FractionRing ((W⁄F).FunctionField ⊗[F] F')))).toAffine.Equation
+      (algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+        ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')))
+      (algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+        ((yGen (W⁄F)) ⊗ₜ[F] (1 : F'))) := by
+  classical
+  have hcurve : (W⁄F').map (algebraMap F' (FractionRing ((W⁄F).FunctionField ⊗[F] F')))
+      = W⁄(FractionRing ((W⁄F).FunctionField ⊗[F] F')) := by
+    change (W.map _).map _ = W.map _
+    rw [WeierstrassCurve.map_map]; congr 1
+    exact (IsScalarTower.algebraMap_eq R₀ F'
+      (FractionRing ((W⁄F).FunctionField ⊗[F] F'))).symm
+  rw [hcurve]
+  exact Equation.baseChange (W := W) (S := R₀)
+    (f := (IsScalarTower.toAlgHom R₀ ((W⁄F).FunctionField ⊗[F] F')
+            (FractionRing ((W⁄F).FunctionField ⊗[F] F'))).comp
+          (Algebra.TensorProduct.includeLeft (R := F) (S := R₀)))
+    (equation_map_polyToFunctionField_yGen (W := (W⁄F)))
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [IsAlgClosed F] [CharZero F] [Algebra R₀ F'] [IsAlgClosed F'] [CharZero F']
+  [IsScalarTower R₀ F F'] [IsDomain ((W⁄F).FunctionField ⊗[F] F')] in
+theorem kw_transcendental_tensorFracXGeneral :
+    Function.Injective (Polynomial.aeval (R := F')
+      (algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+        ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')))) := by
+  classical
+  rw [show algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+        ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F'))
+      = IsScalarTower.toAlgHom F' ((W⁄F).FunctionField ⊗[F] F')
+          (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+          ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')) from rfl,
+    Polynomial.aeval_algHom]
+  refine (IsFractionRing.injective ((W⁄F).FunctionField ⊗[F] F')
+    (FractionRing ((W⁄F).FunctionField ⊗[F] F'))).comp ?_
+  have heq : (Polynomial.aeval (R := F')
+        ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')
+          : (W⁄F).FunctionField ⊗[F] F')).toRingHom
+      = ((Algebra.TensorProduct.map
+            (Polynomial.aeval (R := F) (polyToFunctionField (W⁄F) X))
+            (AlgHom.id F F')).toRingHom.comp
+          (Algebra.TensorProduct.comm F F' F[X]).toAlgHom.toRingHom).comp
+          (polyEquivTensor' F F').toAlgHom.toRingHom := by
+    refine Polynomial.ringHom_ext (fun c => ?_) ?_
+    · change aeval _ (C c) = Algebra.TensorProduct.map _ _
+          (Algebra.TensorProduct.comm F F' F[X] (polyEquivTensor' F F' (C c)))
+      rw [show (polyEquivTensor' F F') (C c) = c ⊗ₜ[F] (1 : F[X]) from by
+            rw [coe_polyEquivTensor', polyEquivTensor_apply, eval₂_C]; rfl,
+        Algebra.TensorProduct.comm_tmul, Algebra.TensorProduct.map_tmul, Polynomial.aeval_C,
+        Algebra.TensorProduct.right_algebraMap_apply, AlgHom.coe_id, id_eq, map_one]
+    · change aeval _ (X : F'[X]) = Algebra.TensorProduct.map _ _
+          (Algebra.TensorProduct.comm F F' F[X] (polyEquivTensor' F F' X))
+      rw [show (polyEquivTensor' F F') X = (1:F') ⊗ₜ[F] (X : F[X]) from by
+            rw [coe_polyEquivTensor', polyEquivTensor_apply, eval₂_X],
+        Algebra.TensorProduct.comm_tmul, Algebra.TensorProduct.map_tmul, Polynomial.aeval_X,
+        AlgHom.coe_id, id_eq, Polynomial.aeval_X]
+  have hinj : Function.Injective
+      (((Algebra.TensorProduct.map
+          (Polynomial.aeval (R := F) (polyToFunctionField (W⁄F) X))
+          (AlgHom.id F F')).toRingHom.comp
+        (Algebra.TensorProduct.comm F F' F[X]).toAlgHom.toRingHom).comp
+        (polyEquivTensor' F F').toAlgHom.toRingHom) :=
+    ((Module.Flat.rTensor_preserves_injective_linearMap (M := F')
+        (Polynomial.aeval (R := F) (polyToFunctionField (W⁄F) X)).toLinearMap
+        ((injective_iff_map_eq_zero _).mpr fun p hp =>
+          transcendental_iff.mp (transcendental_polyToFunctionField_X (W := (W⁄F))) p hp)).comp
+      (Algebra.TensorProduct.comm F F' F[X]).injective).comp (polyEquivTensor' F F').injective
+  intro p q hpq
+  refine hinj ?_
+  have := DFunLike.congr_fun heq
+  exact (this p).symm.trans (hpq.trans (this q))
+
+set_option synthInstance.maxHeartbeats 3200000 in
+def kw_functionFieldTensorFracHomGeneral :
+    (W⁄F').FunctionField →ₐ[F'] FractionRing ((W⁄F).FunctionField ⊗[F] F') :=
+  pointPullbackHomTo (kw_equation_tensorFracXYGeneral W F F')
+    (kw_transcendental_tensorFracXGeneral W F F')
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [IsAlgClosed F] [CharZero F] [IsAlgClosed F'] [CharZero F'] in
+theorem kw_functionFieldTensorFracHomGeneral_X :
+    kw_functionFieldTensorFracHomGeneral W F F' (polyToFunctionField (W⁄F') X)
+      = algebraMap ((W⁄F).FunctionField ⊗[F] F') _
+          ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')) := by
+  classical
+  exact
+    pointPullbackHomTo_polyToFunctionField_X _ _
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [IsAlgClosed F] [CharZero F] [IsAlgClosed F'] [CharZero F'] in
+theorem kw_functionFieldTensorFracHomGeneral_yGen :
+    kw_functionFieldTensorFracHomGeneral W F F' (yGen (W⁄F'))
+      = algebraMap ((W⁄F).FunctionField ⊗[F] F') _ ((yGen (W⁄F)) ⊗ₜ[F] (1 : F')) := by
+  classical
+  exact
+    pointPullbackHomTo_yGen _ _
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [IsAlgClosed F] [CharZero F] [IsAlgClosed F'] [CharZero F'] in
+theorem kw_functionFieldTensorFracHomGeneral_bijective :
+    Function.Bijective (kw_functionFieldTensorFracHomGeneral W F F') := by
+  classical
+  refine ⟨(kw_functionFieldTensorFracHomGeneral W F F').injective, ?_⟩
+  set ψ := kw_functionFieldTensorFracHomGeneral W F F'
+  have hκ : (ψ.restrictScalars F).comp (kw_functionFieldMapAlongGeneral W F F')
+      = (IsScalarTower.toAlgHom F ((W⁄F).FunctionField ⊗[F] F')
+          (FractionRing ((W⁄F).FunctionField ⊗[F] F'))).comp
+          (Algebra.TensorProduct.includeLeft (R := F)) := by
+    refine kw_functionField_algHom_ext ?_ ?_
+    · change ψ (kw_functionFieldMapAlongGeneral W F F' (polyToFunctionField (W⁄F) X)) = _
+      rw [kw_functionFieldMapAlongGeneral_polyToFunctionField_X,
+        kw_functionFieldTensorFracHomGeneral_X]
+      rfl
+    · change ψ (kw_functionFieldMapAlongGeneral W F F' (yGen (W⁄F))) = _
+      rw [kw_functionFieldMapAlongGeneral_yGen, kw_functionFieldTensorFracHomGeneral_yGen]
+      rfl
+  have hT_sub : ∀ t : (W⁄F).FunctionField ⊗[F] F',
+      algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing _) t ∈ ψ.toRingHom.fieldRange := by
+    intro t
+    induction t with
+    | add _ _ hx hy => simp only [map_add]; exact add_mem hx hy
+    | tmul a c =>
+      rw [show (a ⊗ₜ[F] c : (W⁄F).FunctionField ⊗[F] F') = (a ⊗ₜ[F] 1) * (1 ⊗ₜ[F] c) from
+            by rw [Algebra.TensorProduct.tmul_mul_tmul, mul_one, one_mul],
+        map_mul]
+      refine mul_mem ?_ ⟨algebraMap F' _ c, ?_⟩
+      · exact ⟨kw_functionFieldMapAlongGeneral W F F' a, DFunLike.congr_fun hκ a⟩
+      · simp only [AlgHom.toRingHom_eq_coe, RingHom.coe_coe, ψ.commutes,
+          IsScalarTower.algebraMap_apply F' ((W⁄F).FunctionField ⊗[F] F')
+            (FractionRing ((W⁄F).FunctionField ⊗[F] F')),
+          Algebra.TensorProduct.right_algebraMap_apply]
+  intro z
+  obtain ⟨t, s, _, rfl⟩ := IsFractionRing.div_surjective
+    (A := (W⁄F).FunctionField ⊗[F] F') (K := FractionRing _) z
+  exact div_mem (hT_sub t) (hT_sub s)
+
+def kw_functionFieldTensorFracEquivGeneral :
+    (W⁄F').FunctionField ≃ₐ[F'] FractionRing ((W⁄F).FunctionField ⊗[F] F') :=
+  AlgEquiv.ofBijective _ (kw_functionFieldTensorFracHomGeneral_bijective W F F')
+
+def kw_tensorIotaRingHomGeneral (D : IsogenyEndDatum (W⁄F)) :
+    (W⁄F).FunctionField ⊗[F] F' →+* (W⁄F).FunctionField ⊗[F] F' :=
+  (Algebra.TensorProduct.map D.ι (AlgHom.id F F')).toRingHom
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [IsAlgClosed F] [CharZero F] [Algebra R₀ F'] [IsAlgClosed F'] [CharZero F']
+  [IsScalarTower R₀ F F'] [IsDomain ((W⁄F).FunctionField ⊗[F] F')] in
+theorem kw_tensorIotaRingHomGeneral_tmul (D : IsogenyEndDatum (W⁄F)) (a : (W⁄F).FunctionField)
+    (c : F') : kw_tensorIotaRingHomGeneral W F F' D (a ⊗ₜ[F] c) = (D.ι a) ⊗ₜ[F] c := by
+  classical
+  simp [kw_tensorIotaRingHomGeneral, Algebra.TensorProduct.map_tmul]
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [IsAlgClosed F] [CharZero F] [Algebra R₀ F'] [IsAlgClosed F'] [CharZero F']
+  [IsScalarTower R₀ F F'] [IsDomain ((W⁄F).FunctionField ⊗[F] F')] in
+theorem kw_tensorIotaRingHomGeneral_injective (D : IsogenyEndDatum (W⁄F)) :
+    Function.Injective (kw_tensorIotaRingHomGeneral W F F' D) := by
+  classical
+  exact
+    Module.Flat.rTensor_preserves_injective_linearMap (M := F') D.ι.toLinearMap D.ι.injective
+
+def kw_tensorFracIotaRingHomGeneral (D : IsogenyEndDatum (W⁄F)) :
+    FractionRing ((W⁄F).FunctionField ⊗[F] F')
+      →+* FractionRing ((W⁄F).FunctionField ⊗[F] F') :=
+  IsFractionRing.map (K := FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+    (L := FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+    (kw_tensorIotaRingHomGeneral_injective W F F' D)
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [IsAlgClosed F] [CharZero F] [Algebra R₀ F'] [IsAlgClosed F'] [CharZero F']
+  [IsScalarTower R₀ F F'] in
+theorem kw_tensorFracIotaRingHomGeneral_algebraMap (D : IsogenyEndDatum (W⁄F))
+    (t : (W⁄F).FunctionField ⊗[F] F') :
+    kw_tensorFracIotaRingHomGeneral W F F' D
+        (algebraMap ((W⁄F).FunctionField ⊗[F] F')
+          (FractionRing ((W⁄F).FunctionField ⊗[F] F')) t)
+      = algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+          (kw_tensorIotaRingHomGeneral W F F' D t) := by
+  classical
+  unfold kw_tensorFracIotaRingHomGeneral IsFractionRing.map
+  exact IsLocalization.map_eq (T := nonZeroDivisors ((W⁄F).FunctionField ⊗[F] F')) _ t
+
+def KwTensorFracIotaFinrankSeamGeneral : Prop :=
+  ∀ D : IsogenyEndDatum (W⁄F),
+    (kw_tensorFracIotaRingHomGeneral W F F' D).Finite ∧
+    (letI := (kw_tensorFracIotaRingHomGeneral W F F' D).toAlgebra
+     @Module.finrank (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+       (FractionRing ((W⁄F).FunctionField ⊗[F] F')) _ _ Algebra.toModule) = D.degree
+
+def kw_isogenyEndDatumBaseChangeIotaGeneral (D : IsogenyEndDatum (W⁄F)) :
+    (W⁄F').FunctionField →ₐ[F'] (W⁄F').FunctionField :=
+  let ψ := kw_functionFieldTensorFracEquivGeneral W F F'
+  { ψ.symm.toRingEquiv.toRingHom.comp
+      ((kw_tensorFracIotaRingHomGeneral W F F' D).comp ψ.toRingEquiv.toRingHom) with
+    commutes' := fun c => by
+      have hc : ψ (algebraMap F' (W⁄F').FunctionField c)
+          = algebraMap ((W⁄F).FunctionField ⊗[F] F')
+              (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+              ((1 : (W⁄F).FunctionField) ⊗ₜ[F] c) := by
+        rw [AlgEquiv.commutes, IsScalarTower.algebraMap_apply F' ((W⁄F).FunctionField ⊗[F] F')
+          (FractionRing ((W⁄F).FunctionField ⊗[F] F')),
+          Algebra.TensorProduct.right_algebraMap_apply]
+      change ψ.symm (kw_tensorFracIotaRingHomGeneral W F F' D (ψ (algebraMap F' _ c)))
+          = algebraMap F' _ c
+      rw [hc, kw_tensorFracIotaRingHomGeneral_algebraMap, kw_tensorIotaRingHomGeneral_tmul,
+        map_one, ← hc]
+      exact ψ.symm_apply_apply _ }
+
+def KwIsogenyEndDatumBaseChangeAlongGeneral (_σ : F →ₐ[R₀] F') (N : ℕ) : Prop :=
+  (∃ D : IsogenyEndDatum (W⁄F), D.degree = N) →
+    ∃ D' : IsogenyEndDatum (W⁄F'), D'.degree = N
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [IsAlgClosed F] [CharZero F] [IsAlgClosed F'] [CharZero F'] in
+theorem kw_isogenyEndDatumBaseChangeAlong_of_isDomain_tensorGeneral
+    (hseam : KwTensorFracIotaFinrankSeamGeneral W F F')
+    (σ : F →ₐ[R₀] F') (N : ℕ) : KwIsogenyEndDatumBaseChangeAlongGeneral W F F' σ N := by
+  classical
+  intro ⟨D, hD⟩
+  let ψ := kw_functionFieldTensorFracEquivGeneral W F F'
+  let ιFr := kw_tensorFracIotaRingHomGeneral W F F' D
+  obtain ⟨hfin_Fr, hdeg_Fr⟩ := hseam D
+  have hcomm : ∀ x, ιFr (ψ x) = ψ (kw_isogenyEndDatumBaseChangeIotaGeneral W F F' D x) :=
+    fun x => (ψ.apply_symm_apply _).symm
+  have hfin : (kw_isogenyEndDatumBaseChangeIotaGeneral W F F' D).toRingHom.Finite := by
+    have h₁ : (kw_isogenyEndDatumBaseChangeIotaGeneral W F F' D).toRingHom
+        = ψ.symm.toRingEquiv.toRingHom.comp (ιFr.comp ψ.toRingEquiv.toRingHom) := rfl
+    rw [h₁]
+    exact (RingHom.Finite.of_surjective _ ψ.symm.surjective).comp
+      (hfin_Fr.comp (RingHom.Finite.of_surjective _ ψ.surjective))
+  refine ⟨⟨kw_isogenyEndDatumBaseChangeIotaGeneral W F F' D, hfin.to_isIntegral, hfin⟩, ?_⟩
+  refine hD ▸ ?_
+  exact (@Algebra.finrank_eq_of_equiv_equiv
+      (W⁄F').FunctionField (W⁄F').FunctionField _ _
+      (algebraAlong (kw_isogenyEndDatumBaseChangeIotaGeneral W F F' D))
+      (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+      (FractionRing ((W⁄F).FunctionField ⊗[F] F')) _ _
+      (ιFr.toAlgebra) ψ.toRingEquiv ψ.toRingEquiv
+      (RingHom.ext hcomm)).trans hdeg_Fr
+
+end FracHom
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [IsAlgClosed F] [CharZero F] [IsAlgClosed F'] [CharZero F'] in
+theorem kw_isogenyEndDatumBaseChangeAlong_of_tensorIsDomainGeneral
+    (htens : KwFunctionFieldTensorIsDomainGeneral W F F')
+    (hseam : haveI : IsDomain ((W⁄F).FunctionField ⊗[F] F') := htens
+             KwTensorFracIotaFinrankSeamGeneral W F F')
+    (σ : F →ₐ[R₀] F') (N : ℕ) :
+    KwIsogenyEndDatumBaseChangeAlongGeneral W F F' σ N := by
+  classical
+  exact
+    haveI : IsDomain ((W⁄F).FunctionField ⊗[F] F') := htens
+    kw_isogenyEndDatumBaseChangeAlong_of_isDomain_tensorGeneral W F F' hseam σ N
+
+end Setup
+
+end ModularCurve
+end
+end
+
+section
+
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_7837151f.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_7837151f.Weierstrass\
+  Curve.Affine \
+  P2MW.S_OVERLONG_7837151f.ModularCurv\
+  e AlgebraicCurve \
+  P2MW.S_OVERLONG_7837151f.AlgebraicCu\
+  rve"
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_7837151f.Polynomial"
+p2m_open_scoped "TensorProduct \
+  P2MW.S_OVERLONG_7837151f.TensorProdu\
+  ct Polynomial \
+  P2MW.S_OVERLONG_7837151f.Polynomial"
+
+namespace ModularCurve
+
+section Setup
+
+variable {R₀ : Type u} [Field R₀]
+variable (W : WeierstrassCurve R₀) [W.IsElliptic]
+variable (F : Type v) [Field F] [Algebra R₀ F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (F' : Type w) [Field F'] [Algebra R₀ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower R₀ F F']
+
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+section FFDomain
+
+local notation3 "CR" => (W⁄F).toAffine.CoordinateRing
+local notation3 "FFₗ" => (W⁄F).FunctionField
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [IsAlgClosed F] [CharZero F] [Algebra R₀ F'] [IsAlgClosed F'] [CharZero F']
+  [IsScalarTower R₀ F F'] in
+theorem kw_coordinateRingMap_basisGeneral (i : ℕ × Fin 2) :
+    CoordinateRing.map (W⁄F).toAffine (algebraMap F F')
+        (kw_coordinateRingBasis (W⁄F).toAffine i)
+      = kw_coordinateRingBasis ((W⁄F).toAffine.map (algebraMap F F')) i := by
+  classical
+  obtain ⟨n, j⟩ := i
+  simp only [kw_coordinateRingBasis, Module.Basis.smulTower_apply,
+    Polynomial.coe_basisMonomials, CoordinateRing.map_smul]
+  congr 1
+  · simp [Polynomial.map_monomial]
+  · rcases j with ⟨j, hj⟩
+    interval_cases j <;>
+      simp [CoordinateRing.basis_apply, CoordinateRing.map,
+        AdjoinRoot.lift_root, AdjoinRoot.powerBasis'_gen]
+
+def kw_coordinateRingMapAlongGeneral :
+    CR →ₐ[F] ((W⁄F).toAffine.map (algebraMap F F')).CoordinateRing where
+  __ := CoordinateRing.map (W⁄F).toAffine (algebraMap F F')
+  commutes' r := by
+    simp only [RingHom.toMonoidHom_eq_coe, OneHom.toFun_eq_coe, MonoidHom.toOneHom_coe,
+      MonoidHom.coe_ofClass]
+    change CoordinateRing.map (W⁄F).toAffine (algebraMap F F') (algebraMap F CR r) = algebraMap F _
+      r
+    rw [IsScalarTower.algebraMap_apply F F[X] CR,
+      show (algebraMap F F[X] r) = Polynomial.C r from rfl,
+      show (algebraMap F[X] CR) (C r) = (C r : F[X]) • (1 : CR) by
+        rw [Algebra.smul_def, mul_one],
+      CoordinateRing.map_smul, map_one, Polynomial.map_C,
+      IsScalarTower.algebraMap_apply F F' ((W⁄F).toAffine.map (algebraMap F F')).CoordinateRing,
+      IsScalarTower.algebraMap_apply F' F'[X]
+        ((W⁄F).toAffine.map (algebraMap F F')).CoordinateRing,
+      show (algebraMap F' F'[X]) ((algebraMap F F') r) = Polynomial.C ((algebraMap F F') r)
+        from rfl,
+      Algebra.smul_def, mul_one]
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [IsAlgClosed F] [CharZero F] [Algebra R₀ F'] [IsAlgClosed F'] [CharZero F']
+  [IsScalarTower R₀ F F'] in
+theorem kw_coordinateRingTensor_isDomainGeneral : IsDomain (CR ⊗[F] F') := by
+  classical
+  suffices h : IsDomain (F' ⊗[F] CR) by
+    have := h
+    exact Function.Injective.isDomain (Algebra.TensorProduct.comm F CR F').toRingHom
+      (Algebra.TensorProduct.comm F CR F').injective
+  set W'' := (W⁄F).toAffine.map (algebraMap F F') with hW''
+  let θ : F' ⊗[F] CR →ₐ[F'] W''.CoordinateRing :=
+    AlgHom.liftEquiv F F' CR W''.CoordinateRing (kw_coordinateRingMapAlongGeneral W F F')
+  have hθ : Function.Injective θ := by
+    let bT : Module.Basis (ℕ × Fin 2) F' (F' ⊗[F] CR) :=
+      Algebra.TensorProduct.basis F' (kw_coordinateRingBasis (W⁄F).toAffine)
+    let bD : Module.Basis (ℕ × Fin 2) F' W''.CoordinateRing := kw_coordinateRingBasis W''
+    have key : ∀ i, θ.toLinearMap (bT i) = (bT.equiv bD (Equiv.refl _)) (bT i) := fun i => by
+      rw [Module.Basis.equiv_apply, Equiv.refl_apply, AlgHom.toLinearMap_apply]
+      simp only [bT, Algebra.TensorProduct.basis_apply, θ, AlgHom.liftEquiv_tmul, one_smul]
+      exact kw_coordinateRingMap_basisGeneral W F F' i
+    have heq : (θ : F' ⊗[F] CR → W''.CoordinateRing) = bT.equiv bD (Equiv.refl _) :=
+      funext fun x => DFunLike.congr_fun (bT.ext key : θ.toLinearMap = _) x
+    exact heq ▸ (bT.equiv bD (Equiv.refl _)).injective
+  exact Function.Injective.isDomain θ.toRingHom hθ
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [IsAlgClosed F] [CharZero F] [Algebra R₀ F'] [IsAlgClosed F'] [CharZero F']
+  [IsScalarTower R₀ F F'] in
+theorem kw_functionFieldTensorIsDomain_dischargeGeneral :
+    KwFunctionFieldTensorIsDomainGeneral W F F' := by
+  classical
+  change IsDomain (FFₗ ⊗[F] F')
+  have hCR : IsDomain (CR ⊗[F] F') := kw_coordinateRingTensor_isDomainGeneral W F F'
+  let : Algebra (CR ⊗[F] F') (FFₗ ⊗[F] F') :=
+    (Algebra.TensorProduct.map (IsScalarTower.toAlgHom F CR FFₗ)
+      (AlgHom.id F F')).toRingHom.toAlgebra
+  have hst : IsScalarTower CR (CR ⊗[F] F') (FFₗ ⊗[F] F') :=
+    IsScalarTower.of_algebraMap_eq (R := CR) (S := CR ⊗[F] F') (A := FFₗ ⊗[F] F') fun c => by
+      change Algebra.TensorProduct.map (IsScalarTower.toAlgHom F CR FFₗ) (AlgHom.id F F')
+          (algebraMap CR (CR ⊗[F] F') c) = algebraMap CR (FFₗ ⊗[F] F') c
+      rfl
+  have hloc : IsLocalization
+      (Algebra.algebraMapSubmonoid (CR ⊗[F] F') (nonZeroDivisors CR)) (FFₗ ⊗[F] F') :=
+    IsLocalization.tensorProduct_tensorProduct F F' (nonZeroDivisors CR) FFₗ (by
+      ext x; simp [RingHom.algebraMap_toAlgebra, Algebra.TensorProduct.map_tmul])
+  have hle : Algebra.algebraMapSubmonoid (CR ⊗[F] F') (nonZeroDivisors CR)
+      ≤ nonZeroDivisors (CR ⊗[F] F') := by
+    rintro _ ⟨c, hc, rfl⟩
+    refine mem_nonZeroDivisors_of_ne_zero ?_
+    have hinj : Function.Injective (algebraMap CR (CR ⊗[F] F')) :=
+      Algebra.TensorProduct.includeLeft_injective (S := F) (algebraMap F F').injective
+    exact fun h => (nonZeroDivisors.ne_zero hc) (hinj (by
+      simp only [_root_.map_zero] at h ⊢; exact h))
+  exact IsLocalization.isDomain_of_le_nonZeroDivisors
+    (M := Algebra.algebraMapSubmonoid (CR ⊗[F] F') (nonZeroDivisors CR)) _ hle
+
+end FFDomain
+
+section Seam
+
+variable [IsDomain ((W⁄F).FunctionField ⊗[F] F')]
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [IsAlgClosed F] [CharZero F] [Algebra R₀ F'] [IsAlgClosed F'] [CharZero F']
+  [IsScalarTower R₀ F F'] [IsDomain ((W⁄F).FunctionField ⊗[F] F')] in
+theorem kw_tensorIotaRingHom_finiteGeneral (D : IsogenyEndDatum (W⁄F)) :
+    (kw_tensorIotaRingHomGeneral W F F' D).Finite := by
+  classical
+  exact
+    RingHom.Finite.tensorProductMap (f := D.ι) D.hfin (g := AlgHom.id F F') (RingHom.Finite.id F')
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [IsAlgClosed F] [CharZero F] [Algebra R₀ F'] [IsAlgClosed F'] [CharZero F']
+  [IsScalarTower R₀ F F'] in
+theorem kw_tensorFracIotaFinrankSeam_dischargeGeneral :
+    KwTensorFracIotaFinrankSeamGeneral W F F' := by
+  classical
+  intro D
+  let FF := (W⁄F).FunctionField
+  let T := (W⁄F).FunctionField ⊗[F] F'
+  let FrT := FractionRing ((W⁄F).FunctionField ⊗[F] F')
+  let ιT : T →+* T := kw_tensorIotaRingHomGeneral W F F' D
+  let ιFr : FrT →+* FrT := kw_tensorFracIotaRingHomGeneral W F F' D
+  have hιT_inj : Function.Injective ιT := kw_tensorIotaRingHomGeneral_injective W F F' D
+  have hιT_fin : ιT.Finite := kw_tensorIotaRingHom_finiteGeneral W F F' D
+  have hιFr_am : ∀ t : T, ιFr (algebraMap T FrT t) = algebraMap T FrT (ιT t) :=
+    kw_tensorFracIotaRingHomGeneral_algebraMap W F F' D
+  let algDι : Algebra FF FF := D.ι.toRingHom.toAlgebra
+  let smulDι : SMul FF FF := algDι.toSMul
+  let modDι : Module FF FF := Algebra.toModule
+  have hsmul_Dι : ∀ (c x : FF), c • x = D.ι c * x := fun c x => rfl
+  have hfinFF : Module.Finite FF FF := D.hfin
+  have hfreeFF : Module.Free FF FF := Module.Free.of_divisionRing FF FF
+  let b : Module.Basis (Fin D.degree) FF FF :=
+    Module.finBasisOfFinrankEq FF FF (n := D.degree) rfl
+  have hrepr_mul : ∀ (c x : FF) (j : Fin D.degree),
+      b.repr (D.ι c * x) j = c * b.repr x j := fun c x j => by
+    rw [← hsmul_Dι, map_smul, Finsupp.smul_apply, smul_eq_mul]
+  let e : Fin D.degree → T := fun i => (b i) ⊗ₜ[F] (1 : F')
+  let bFr : Fin D.degree → FrT := fun i => algebraMap T FrT (e i)
+  have hspanT : ∀ t : T, ∃ c : Fin D.degree → T, t = ∑ i, ιT (c i) * e i := by
+    intro t
+    induction t using TensorProduct.inductionOn with
+    | add x y hx hy =>
+      obtain ⟨cx, hx⟩ := hx; obtain ⟨cy, hy⟩ := hy
+      exact ⟨cx + cy, by simp only [Pi.add_apply, map_add, add_mul,
+        Finset.sum_add_distrib, ← hx, ← hy]⟩
+    | tmul a c =>
+      refine ⟨fun i => (b.repr a i) ⊗ₜ[F] c, ?_⟩
+      have hb_sum : a = ∑ i, D.ι (b.repr a i) * b i := by
+        conv_lhs => rw [← b.linearCombination_repr a, Finsupp.linearCombination_apply,
+          Finsupp.sum_fintype _ _ (fun i => by rw [hsmul_Dι, _root_.map_zero, zero_mul])]
+        exact Finset.sum_congr rfl fun i _ => hsmul_Dι _ _
+      calc (a ⊗ₜ[F] c : T)
+          = (∑ i, D.ι (b.repr a i) * b i) ⊗ₜ[F] c := by rw [← hb_sum]
+        _ = ∑ i, ιT ((b.repr a i) ⊗ₜ[F] c) * e i := by
+            rw [TensorProduct.sum_tmul]
+            refine Finset.sum_congr rfl fun i _ => ?_
+            rw [kw_tensorIotaRingHomGeneral_tmul W F F' D,
+              Algebra.TensorProduct.tmul_mul_tmul, mul_one]
+  have hliT : ∀ c : Fin D.degree → T, ∑ i, ιT (c i) * e i = 0 → ∀ j, c j = 0 := by
+    intro c hc j
+    let pj : FF →ₗ[F] FF :=
+      { toFun := fun x => b.repr x j
+        map_add' := fun x y => by simp only [map_add, Finsupp.add_apply]
+        map_smul' := fun f x => by
+          simp only [RingHom.id_apply, Algebra.smul_def]
+          have h := hrepr_mul (algebraMap F FF f) x j
+          rwa [D.ι.commutes] at h }
+    let Ej : T →ₗ[F] T := LinearMap.rTensor F' pj
+    have hEj_key : ∀ (a : T) (i : Fin D.degree),
+        Ej (ιT a * e i) = if i = j then a else 0 := by
+      intro a i
+      induction a using TensorProduct.inductionOn with
+      | add x y hx hy =>
+        simp only [map_add, add_mul, hx, hy]; split_ifs <;> simp
+      | tmul x c' =>
+        rw [show ιT ((x : FF) ⊗ₜ[F] c') = (D.ι x) ⊗ₜ[F] c' from
+              kw_tensorIotaRingHomGeneral_tmul W F F' D _ _,
+            Algebra.TensorProduct.tmul_mul_tmul, mul_one]
+        change (pj (D.ι x * b i)) ⊗ₜ[F] c' = if i = j then (x : FF) ⊗ₜ[F] c' else 0
+        rw [show pj (D.ι x * b i) = if i = j then x else 0 from ?_]
+        · split_ifs with h
+          · rfl
+          · exact TensorProduct.zero_tmul _ c'
+        · change b.repr (D.ι x * b i) j = if i = j then x else 0
+          rw [hrepr_mul, b.repr_self, Finsupp.single_apply]
+          split_ifs with h <;> simp
+    have hc' : Ej (∑ i, ιT (c i) * e i) = 0 := by rw [hc, _root_.map_zero]
+    simpa only [map_sum, hEj_key, Finset.sum_ite_eq', Finset.mem_univ, ite_true] using hc'
+  have hint : ∀ s : T, s ≠ 0 → ∃ (u s₀ : T), s₀ ≠ 0 ∧ s * u = ιT s₀ := by
+    intro s hs
+    obtain ⟨p, hp_monic, hp_eval⟩ : ιT.IsIntegralElem s := hιT_fin.to_isIntegral s
+    obtain ⟨q, hq_eq, hq_ndvd⟩ := Polynomial.exists_eq_pow_rootMultiplicity_mul_and_not_dvd p
+      hp_monic.ne_zero 0
+    simp only [Polynomial.C_0, sub_zero] at hq_eq hq_ndvd
+    have hq0 : q.coeff 0 ≠ 0 := fun h => hq_ndvd (Polynomial.X_dvd_iff.mpr h)
+    have hqs : q.eval₂ ιT s = 0 := by
+      have h := hp_eval
+      rw [hq_eq, Polynomial.eval₂_mul, Polynomial.eval₂_pow, Polynomial.eval₂_X,
+        mul_eq_zero] at h
+      exact h.resolve_left (pow_ne_zero _ hs)
+    have h3 : ιT (q.coeff 0) + s * (q.divX).eval₂ ιT s = 0 := by
+      have h := congrArg (Polynomial.eval₂ ιT s) (Polynomial.divX_mul_X_add q)
+      rw [Polynomial.eval₂_add, Polynomial.eval₂_mul, Polynomial.eval₂_X,
+        Polynomial.eval₂_C, hqs] at h
+      simpa only [add_comm, mul_comm] using h
+    exact ⟨(q.divX).eval₂ ιT s, -q.coeff 0, neg_ne_zero.mpr hq0,
+      by rw [_root_.map_neg]; exact eq_neg_of_add_eq_zero_right h3⟩
+  have hspanFr : ∀ z : FrT, ∃ d : Fin D.degree → FrT, z = ∑ i, ιFr (d i) * bFr i := by
+    intro z
+    obtain ⟨t, s, hs, rfl⟩ := IsFractionRing.div_surjective (A := T) (K := FrT) z
+    rcases eq_or_ne s 0 with rfl | hs'
+    · exact ⟨0, by simp⟩
+    obtain ⟨u, s₀, hs₀, hsu⟩ := hint s hs'
+    have hιTs₀ : ιT s₀ ≠ 0 := fun h => hs₀ (hιT_inj (h.trans (_root_.map_zero ιT).symm))
+    have hu_ne : u ≠ 0 := fun h => hιTs₀ (by rw [← hsu, h, mul_zero])
+    obtain ⟨c, hc⟩ := hspanT (t * u)
+    refine ⟨fun i => (algebraMap T FrT s₀)⁻¹ * algebraMap T FrT (c i), ?_⟩
+    have hum := (map_ne_zero_iff _ (IsFractionRing.injective T FrT)).mpr hu_ne
+    have hz : (algebraMap T FrT t) / (algebraMap T FrT s)
+        = (algebraMap T FrT (ιT s₀))⁻¹ * algebraMap T FrT (t * u) := by
+      rw [← div_eq_inv_mul, ← hsu, map_mul, map_mul,
+        ← div_mul_div_comm, div_self hum, mul_one]
+    rw [hz, hc, map_sum, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [map_mul, map_mul, ← hιFr_am s₀, ← hιFr_am (c i), ← map_inv₀ ιFr, mul_assoc]
+  have hliFr : ∀ d : Fin D.degree → FrT, ∑ i, ιFr (d i) * bFr i = 0 → ∀ j, d j = 0 := by
+    intro d hd j
+    obtain ⟨q, hq⟩ := IsLocalization.exist_integer_multiples_of_finset
+      (nonZeroDivisors T) (Finset.univ.image d)
+    choose p hp using fun i => hq (d i) (Finset.mem_image_of_mem d (Finset.mem_univ i))
+    have hq0 : (algebraMap T FrT (q : T)) ≠ 0 :=
+      (map_ne_zero_iff _ (IsFractionRing.injective T FrT)).mpr (nonZeroDivisors.ne_zero q.2)
+    have hp' : ∀ i, algebraMap T FrT (p i) = algebraMap T FrT (q : T) * d i := fun i => by
+      rw [hp i, Algebra.smul_def]
+    have hd' : algebraMap T FrT (∑ i, ιT (p i) * e i) = 0 := by
+      have h1 : ∑ i, ιFr (algebraMap T FrT (q : T)) * (ιFr (d i) * bFr i) = 0 := by
+        rw [← Finset.mul_sum, hd, mul_zero]
+      rw [map_sum, ← h1]; refine Finset.sum_congr rfl fun i _ => ?_
+      rw [map_mul, ← hιFr_am (p i), ← mul_assoc, ← map_mul, ← hp' i]
+    have hpj : p j = 0 :=
+      hliT p ((IsFractionRing.injective T FrT) (by simpa using hd')) j
+    have hthis : algebraMap T FrT (q : T) * d j = 0 := by
+      rw [← hp' j, hpj, _root_.map_zero]
+    exact (mul_eq_zero.mp hthis).resolve_left hq0
+  let algFr : Algebra FrT FrT := ιFr.toAlgebra
+  let smulFr : SMul FrT FrT := algFr.toSMul
+  let modFr : Module FrT FrT := Algebra.toModule
+  have hsmul_Fr : ∀ (c x : FrT), c • x = ιFr c * x := fun c x => rfl
+  have hli_modFr : LinearIndependent FrT bFr := by
+    rw [Fintype.linearIndependent_iff]
+    intro g hg i
+    refine hliFr g ?_ i
+    simpa only [hsmul_Fr] using hg
+  have hsp_modFr : ⊤ ≤ Submodule.span FrT (Set.range bFr) := by
+    intro z _
+    obtain ⟨d, hd⟩ := hspanFr z
+    rw [hd]
+    exact Submodule.sum_mem _ fun i _ => (hsmul_Fr (d i) (bFr i)) ▸
+      Submodule.smul_mem _ (d i) (Submodule.subset_span ⟨i, rfl⟩)
+  let bFr' : Module.Basis (Fin D.degree) FrT FrT := .mk hli_modFr hsp_modFr
+  refine ⟨Module.Finite.of_basis bFr', ?_⟩
+  change Module.finrank FrT FrT = D.degree
+  rw [Module.finrank_eq_card_basis bFr', Fintype.card_fin]
+
+end Seam
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [IsAlgClosed F] [CharZero F] [IsAlgClosed F'] [CharZero F'] in
+theorem kw_isogenyEndDatumBaseChangeAlong_dischargeGeneral (σ : F →ₐ[R₀] F') (N : ℕ) :
+    KwIsogenyEndDatumBaseChangeAlongGeneral W F F' σ N := by
+  classical
+  exact
+    haveI : IsDomain ((W⁄F).FunctionField ⊗[F] F') :=
+      kw_functionFieldTensorIsDomain_dischargeGeneral W F F'
+    kw_isogenyEndDatumBaseChangeAlong_of_tensorIsDomainGeneral W F F'
+      (kw_functionFieldTensorIsDomain_dischargeGeneral W F F')
+      (kw_tensorFracIotaFinrankSeam_dischargeGeneral W F F') σ N
+
+end Setup
+
+section SatGate
+
+variable (W : WeierstrassCurve ℚ) [W.IsElliptic]
+variable (F : Type) [Field F] [Algebra ℚ F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (F' : Type) [Field F'] [Algebra ℚ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower ℚ F F']
+
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+end SatGate
+end ModularCurve
+end
+end
+
+open _root_.WeierstrassCurve
+  _root_.P2MW.S_OVERLONG_7837151f.WeierstrassCurve
+  _root_.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_7837151f.WeierstrassCurve.Affine
+  _root_.AlgebraicCurve
+  _root_.P2MW.S_OVERLONG_7837151f.AlgebraicCurve
+  in
+theorem solution
+    {R₀ : Type u} [Field R₀] (W : WeierstrassCurve R₀) [W.IsElliptic]
+    (F : Type v) [Field F] [Algebra R₀ F] [IsAlgClosed F] [CharZero F]
+    (F' : Type w) [Field F'] [Algebra R₀ F'] [IsAlgClosed F'] [CharZero F']
+    [Algebra F F'] [IsScalarTower R₀ F F']
+    (ι : (W.baseChange F).toAffine.FunctionField →ₐ[F] (W.baseChange F).toAffine.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong F ι) :
+    ∃ ι' : (W.baseChange F').toAffine.FunctionField →ₐ[F'] (W.baseChange F').toAffine.FunctionField,
+      ι'.toRingHom.IsIntegral ∧ ∃ _ : FiniteAlong F' ι', finrankAlong F' ι' = finrankAlong F ι
+        := by
+  classical
+  obtain ⟨D', hD'⟩ := ModularCurve.kw_isogenyEndDatumBaseChangeAlong_dischargeGeneral W F F'
+    (IsScalarTower.toAlgHom R₀ F F') (finrankAlong F ι) ⟨⟨ι, hι, hfin⟩, rfl⟩
+  exact ⟨D'.ι, D'.hι, D'.hfin, hD'⟩
+
+end
+end S_OVERLONG_7837151f
+end P2MW
+export P2MW.S_OVERLONG_7837151f
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+
+universe u v w
+theorem WeierstrassCurve.Affine.exists_algHom_functionField_baseChange_finrankAlong_eq
+    {R₀ : Type u} [Field R₀] (W : WeierstrassCurve R₀) [W.IsElliptic]
+    (F : Type v) [Field F] [Algebra R₀ F] [IsAlgClosed F] [CharZero F]
+    (F' : Type w) [Field F'] [Algebra R₀ F'] [IsAlgClosed F'] [CharZero F']
+    [Algebra F F'] [IsScalarTower R₀ F F']
+    (ι : (W.baseChange F).toAffine.FunctionField →ₐ[F] (W.baseChange F).toAffine.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong F ι) :
+    ∃ ι' : (W.baseChange F').toAffine.FunctionField →ₐ[F'] (W.baseChange F').toAffine.FunctionField,
+      ι'.toRingHom.IsIntegral ∧ ∃ _hfin' : FiniteAlong F' ι', finrankAlong F' ι' = finrankAlong F ι
+          := by
+  classical
+  exact
+    _root_.P2MW.S_OVERLONG_7837151f.solution
+      W F F' ι hι hfin
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_abelTheorem.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_abelTheorem.lean
new file mode 100644
index 0000000000..0d00d7ff22
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_abelTheorem.lean
@@ -0,0 +1,457 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.exists_genusOnePlaceGate_isCentred_abelTheorem
+(0313be1b-6d0b-5566-9367-07c70b2b21eb) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission fe2470f5-61e7-5a27-b280-50c9151e4c8a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.RingTheory.DedekindDomain.Factorization
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_eq_neg_log_of_valuationSubring_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_eq_XYIdeal_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_exists_eq_valuationSubring_of_X_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_deg_ofHeightOneSpectrum_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_infinitePlace_deg_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of a centred genus-one place gate with Abel's theorem
+
+Theorem statement: `WeierstrassCurve.Affine.exists_genusOnePlaceGate_isCentred_abelTheorem`
+(`0313be1b-6d0b-5566-9367-07c70b2b21eb`), by Claude, 2026-09-05.
+
+Proof: submission `fe2470f5-61e7-5a27-b280-50c9151e4c8a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field and let $W$ be an affine Weierstrass curve over $F$ that is
+elliptic. The assertion is that there exists a term $g$ of the class
+[`WeierstrassCurve.Affine.GenusOnePlaceGate W`](def/WeierstrassCurve_GenusOnePic0.html#L18), that
+is, a bijection $W.\mathrm{Point} \simeq \mathrm{Place}\ F\ F(W)$ between the points of $W$ (the
+affine nonsingular points together with the point at infinity, with its group structure) and the
+places of the function field $W.\mathrm{FunctionField}$ over $F$ — a place being a valuation subring
+$\mathcal{O} \subsetneq F(W)$, different from all of $F(W)$, containing the image of $F$ and whose
+ideals are all principal — together with a proof that every such place has degree $1$; and that this
+$g$ has the following two further properties. First, `GenusOnePlaceGate.IsCentred`: for every $x, y
+\in F$ with $W.\mathrm{Nonsingular}\ x\ y$, the images in $F(W)$ of the coordinate-ring classes
+$\mathrm{XClass}\ W\ x$ and $\mathrm{YClass}\ W\ (C\, y)$ both lie in the nonunits of the valuation
+subring attached by $g$ to the point $(x,y)$, i.e. both vanish at that place. Second, `AbelTheorem`:
+for every divisor $D$ (a finitely supported $\mathbb{Z}$-valued function on places) of degree $0$,
+$D$ is principal — there is $f \neq 0$ in $F(W)$ with $D(v) = v.\mathrm{ord}\ f$ for all $v$ — if
+and only if the sum $\sum_v D(v) \cdot g^{-1}(v)$, formed in the group $W.\mathrm{Point}$, is $0$.
+
+This is the place-theoretic form of the classical dictionary between points of an elliptic curve and
+degree-one places of its function field, together with Abel's theorem identifying the degree-zero
+divisor classes with the group of points; the centredness clause pins the dictionary down by
+requiring the affine point $(x,y)$ to be sent to the place at which $X - x$ and $Y - y$ vanish. It
+supplies the divisor-theoretic input used in the modular-curve part of the development, for instance
+in the analysis of Tate points and of the modular polynomial.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_abelTheorem.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_abelTheorem
+
+noncomputable section
+
+open Polynomial WithZero IsDedekindDomain
+
+open scoped Polynomial.Bivariate nonZeroDivisors
+
+namespace D5S
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.CoordinateRing AlgebraicCurve
+
+universe u
+
+section Generic
+
+variable {R : Type*} [CommRing R] [IsDedekindDomain R]
+variable {L : Type*} [Field L] [Algebra R L] [IsFractionRing R L]
+
+theorem count_spanSingleton (w : HeightOneSpectrum R) {f : L} (hf : f ≠ 0) :
+    FractionalIdeal.count L w (FractionalIdeal.spanSingleton R⁰ f) = -log (w.valuation L f) := by
+  classical
+  obtain ⟨n, d, rfl⟩ := IsLocalization.exists_mk'_eq R⁰ f
+  have hn : n ≠ 0 := by
+    rintro rfl
+    exact hf (IsLocalization.mk'_zero (M := R⁰) (S := L) d)
+  have hd : (d : R) ≠ 0 := nonZeroDivisors.ne_zero d.2
+  have hI : FractionalIdeal.spanSingleton R⁰ (IsLocalization.mk' L n d) =
+      FractionalIdeal.spanSingleton R⁰ ((algebraMap R L) (d : R))⁻¹
+        * ↑(Ideal.span {n} : Ideal R) := by
+    rw [FractionalIdeal.coeIdeal_span_singleton, FractionalIdeal.spanSingleton_mul_spanSingleton]
+    congr 1
+    rw [IsFractionRing.mk'_eq_div, div_eq_mul_inv, mul_comm]
+  rw [FractionalIdeal.count_well_defined L w (FractionalIdeal.spanSingleton_ne_zero_iff.mpr hf) hI]
+  rw [HeightOneSpectrum.valuation_of_mk',
+    log_div (w.intValuation_ne_zero n hn) (w.intValuation_ne_zero (d : R) hd),
+    w.intValuation_if_neg hn, w.intValuation_if_neg hd, log_exp, log_exp]
+  ring
+
+theorem finprod_heightOneSpectrum_count {I : FractionalIdeal R⁰ L} (hI : I ≠ 0) :
+    (∏ᶠ w : HeightOneSpectrum R, (w.asIdeal : FractionalIdeal R⁰ L) ^ FractionalIdeal.count L w I)
+      = I := by
+  classical
+  obtain ⟨a, J, ha, haJ⟩ := FractionalIdeal.exists_eq_spanSingleton_mul I
+  calc (∏ᶠ w : HeightOneSpectrum R, (w.asIdeal : FractionalIdeal R⁰ L) ^ FractionalIdeal.count L w
+    I)
+      = ∏ᶠ w : HeightOneSpectrum R, (w.asIdeal : FractionalIdeal R⁰ L) ^
+          ((Associates.mk w.asIdeal).count (Associates.mk J).factors -
+            (Associates.mk w.asIdeal).count (Associates.mk (Ideal.span {a})).factors : ℤ) :=
+        finprod_congr fun w => by rw [FractionalIdeal.count_well_defined L w hI haJ]
+    _ = I := FractionalIdeal.finprod_heightOneSpectrum_factorization hI haJ
+
+theorem eq_of_count_eq {I J : FractionalIdeal R⁰ L} (hI : I ≠ 0) (hJ : J ≠ 0)
+    (h : ∀ w : HeightOneSpectrum R, FractionalIdeal.count L w I = FractionalIdeal.count L w J) :
+    I = J := by
+  rw [← finprod_heightOneSpectrum_count hI, ← finprod_heightOneSpectrum_count hJ]
+  exact finprod_congr fun w => by rw [h w]
+
+variable {K : Type*} [Field K] [Algebra K R] [Algebra K L] [IsScalarTower K R L]
+
+theorem ord_ofHeightOneSpectrum_eq_count (w : HeightOneSpectrum R) {f : L} (hf : f ≠ 0) :
+    (Place.ofHeightOneSpectrum (K := K) w).ord f
+      = FractionalIdeal.count L w (FractionalIdeal.spanSingleton R⁰ f) := by
+  obtain ⟨π, hπ⟩ := w.valuation_exists_uniformizer L
+  rw [AlgebraicCurve.Place.ord_eq_neg_log_of_valuationSubring_eq
+      (Place.ofHeightOneSpectrum (K := K) w) (w.valuation L) rfl hπ hf,
+    count_spanSingleton w hf]
+
+theorem ofHeightOneSpectrum_injective :
+    Function.Injective (Place.ofHeightOneSpectrum (K := K) (F := L) (R := R)) := by
+  intro w w' h
+  refine HeightOneSpectrum.eq_of_valuation_isEquiv_valuation (K := L) ?_
+  rw [Valuation.isEquiv_iff_valuationSubring]
+  exact congrArg Place.toValuationSubring h
+
+theorem algebraMap_mem_ofHeightOneSpectrum (w : HeightOneSpectrum R) (r : R) :
+    algebraMap R L r ∈ (Place.ofHeightOneSpectrum (K := K) (F := L) w).toValuationSubring := by
+  rw [Place.ofHeightOneSpectrum_toValuationSubring, Valuation.mem_valuationSubring_iff]
+  exact w.valuation_le_one r
+
+theorem algebraMap_mem_nonunits_ofHeightOneSpectrum (w : HeightOneSpectrum R) {r : R}
+    (hr : r ∈ w.asIdeal) :
+    algebraMap R L r ∈ (Place.ofHeightOneSpectrum (K := K) (F := L) w).toValuationSubring.nonunits
+      := by
+  rw [Place.ofHeightOneSpectrum_toValuationSubring, ValuationSubring.mem_nonunits_iff,
+    ← (w.valuation L).isEquiv_valuation_valuationSubring.lt_one_iff_lt_one]
+  exact (w.valuation_lt_one_iff_mem r).mpr hr
+
+end Generic
+
+variable {F : Type u} [Field F] {W : Affine F}
+
+variable (W) in
+def xF : W.FunctionField := algebraMap W.CoordinateRing W.FunctionField (mk W (C X))
+
+variable (W) in
+def vInf : AlgebraicCurve.Place F W.FunctionField :=
+  (WeierstrassCurve.Affine.exists_infinitePlace_deg_eq_one W).choose
+
+theorem vInf_deg : (vInf W).deg = 1 :=
+  (WeierstrassCurve.Affine.exists_infinitePlace_deg_eq_one W).choose_spec.1
+
+theorem vInf_not_forall_mem :
+    ¬ ∀ r : W.CoordinateRing,
+      algebraMap W.CoordinateRing W.FunctionField r ∈ (vInf W).toValuationSubring :=
+  (WeierstrassCurve.Affine.exists_infinitePlace_deg_eq_one W).choose_spec.2.1
+
+theorem eq_vInf_of_not_forall_mem (v : AlgebraicCurve.Place F W.FunctionField)
+    (hv : ¬ ∀ r : W.CoordinateRing,
+      algebraMap W.CoordinateRing W.FunctionField r ∈ v.toValuationSubring) : v = vInf W :=
+  (WeierstrassCurve.Affine.exists_infinitePlace_deg_eq_one W).choose_spec.2.2 v hv
+
+theorem xyIdeal_isMaximal {x₀ y₀ : F} (h : W.Equation x₀ y₀) :
+    (XYIdeal W x₀ (C y₀)).IsMaximal :=
+  Ideal.Quotient.maximal_of_isField _
+    (MulEquiv.isField (Field.toIsField F)
+      (quotientXYIdealEquiv (W' := W) (x := x₀) (y := C y₀) h).toMulEquiv)
+
+theorem xyIdeal_ne_bot (x₀ : F) (y₀ : F[X]) : XYIdeal W x₀ y₀ ≠ ⊥ := fun h =>
+  XClass_ne_zero (W' := W) x₀ <| by
+    have hX : XClass W x₀ ∈ XYIdeal W x₀ y₀ := Ideal.subset_span (by simp)
+    rwa [h, Ideal.mem_bot] at hX
+
+def hosOf {x₀ y₀ : F} (h : W.Equation x₀ y₀) : HeightOneSpectrum W.CoordinateRing :=
+  ⟨XYIdeal W x₀ (C y₀), (xyIdeal_isMaximal h).isPrime, xyIdeal_ne_bot x₀ (C y₀)⟩
+
+@[scoped simp] theorem hosOf_asIdeal {x₀ y₀ : F} (h : W.Equation x₀ y₀) :
+    (hosOf h).asIdeal = XYIdeal W x₀ (C y₀) := rfl
+
+section Closed
+
+variable [IsAlgClosed F] [W.IsElliptic]
+
+scoped instance instIsDedekindDomainCoordinateRing : IsDedekindDomain W.CoordinateRing :=
+  WeierstrassCurve.Affine.CoordinateRing.isDedekindDomain W
+
+scoped instance instHasPrincipalDivisors : AlgebraicCurve.HasPrincipalDivisors F W.FunctionField :=
+  WeierstrassCurve.Affine.hasPrincipalDivisors_of_isAlgClosed W
+
+def placeOfPt : W.Point → AlgebraicCurve.Place F W.FunctionField
+  | .zero => vInf W
+  | .some _ _ h => Place.ofHeightOneSpectrum (K := F) (F := W.FunctionField) (hosOf h.left)
+
+@[scoped simp] theorem placeOfPt_zero : placeOfPt (W := W) 0 = vInf W := rfl
+
+@[scoped simp] theorem placeOfPt_zero' : placeOfPt (Point.zero : W.Point) = vInf W := rfl
+
+@[scoped simp] theorem placeOfPt_some {x₀ y₀ : F} (h : W.Nonsingular x₀ y₀) :
+    placeOfPt (Point.some x₀ y₀ h)
+      = Place.ofHeightOneSpectrum (K := F) (F := W.FunctionField) (hosOf h.left) := rfl
+
+theorem vInf_ne_ofHeightOneSpectrum (w : HeightOneSpectrum W.CoordinateRing) :
+    vInf W ≠ Place.ofHeightOneSpectrum (K := F) (F := W.FunctionField) w := by
+  intro h
+  refine vInf_not_forall_mem (W := W) ?_
+  intro r
+  rw [h]
+  exact algebraMap_mem_ofHeightOneSpectrum w r
+
+theorem placeOfPt_injective : Function.Injective (placeOfPt (W := W)) := by
+  rintro (_ | ⟨x₁, y₁, h₁⟩) (_ | ⟨x₂, y₂, h₂⟩) h
+  · rfl
+  · exact absurd h (vInf_ne_ofHeightOneSpectrum _)
+  · exact absurd h.symm (vInf_ne_ofHeightOneSpectrum _)
+  · have hI : XYIdeal W x₁ (C y₁) = XYIdeal W x₂ (C y₂) :=
+      congrArg HeightOneSpectrum.asIdeal (ofHeightOneSpectrum_injective h)
+    obtain ⟨rfl, rfl⟩ :=
+      (WeierstrassCurve.Affine.CoordinateRing.XYIdeal_eq_XYIdeal_iff h₁.left x₂ y₂).mp hI
+    rfl
+
+theorem placeOfPt_surjective : Function.Surjective (placeOfPt (W := W)) := by
+  intro v
+  by_cases hx : xF W ∈ v.toValuationSubring
+  · obtain ⟨w, hw⟩ :=
+      WeierstrassCurve.Affine.FunctionField.exists_eq_valuationSubring_of_X_mem W
+        v.toValuationSubring v.ne_top' v.algebraMap_mem' hx
+    obtain ⟨a, b, hab, hwI⟩ :=
+      WeierstrassCurve.Affine.CoordinateRing.exists_eq_XYIdeal (W := W) (P := w.asIdeal) w.ne_bot
+    have hns : W.Nonsingular a b := equation_iff_nonsingular.mp hab
+    refine ⟨Point.some a b hns, ?_⟩
+    have hw' : hosOf hns.left = w := HeightOneSpectrum.ext hwI.symm
+    rw [placeOfPt_some, hw']
+    exact AlgebraicCurve.Place.ext hw.symm
+  · exact ⟨0, (eq_vInf_of_not_forall_mem v fun h => hx (h _)).symm⟩
+
+theorem deg_placeOfPt (P : W.Point) : (placeOfPt P).deg = 1 := by
+  cases P with
+  | zero => exact vInf_deg
+  | some x y h => exact WeierstrassCurve.Affine.deg_ofHeightOneSpectrum_eq_one W (hosOf h.left)
+
+def geomEquiv : W.Point ≃ AlgebraicCurve.Place F W.FunctionField :=
+  Equiv.ofBijective placeOfPt ⟨placeOfPt_injective, placeOfPt_surjective⟩
+
+scoped instance geomGate : GenusOnePlaceGate W where
+  pointEquivPlace := geomEquiv
+  deg_eq_one v := by
+    obtain ⟨P, rfl⟩ := placeOfPt_surjective (W := W) v
+    exact deg_placeOfPt P
+
+theorem isCentred_geomGate : GenusOnePlaceGate.IsCentred W := by
+  refine ⟨fun x y h => ?_, fun x y h => ?_⟩
+  · change algebraMap W.CoordinateRing W.FunctionField (XClass W x) ∈
+      ValuationSubring.nonunits (Place.toValuationSubring
+        (Place.ofHeightOneSpectrum (K := F) (F := W.FunctionField) (hosOf h.left)))
+    exact algebraMap_mem_nonunits_ofHeightOneSpectrum _
+      (Ideal.subset_span (Set.mem_insert _ _))
+  · change algebraMap W.CoordinateRing W.FunctionField (YClass W (C y)) ∈
+      ValuationSubring.nonunits (Place.toValuationSubring
+        (Place.ofHeightOneSpectrum (K := F) (F := W.FunctionField) (hosOf h.left)))
+    exact algebraMap_mem_nonunits_ofHeightOneSpectrum _
+      (Ideal.subset_span (Set.mem_insert_of_mem _ (Set.mem_singleton _)))
+
+def unitIdealOfPoint : W.Point → (FractionalIdeal W.CoordinateRing⁰ W.FunctionField)ˣ
+  | .zero => 1
+  | .some _ _ h => CoordinateRing.XYIdeal' h
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+@[scoped simp] theorem unitIdealOfPoint_zero : unitIdealOfPoint (.zero : W.Point) = 1 := rfl
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+@[scoped simp] theorem unitIdealOfPoint_some {x y : F} (h : W.Nonsingular x y) :
+    unitIdealOfPoint (.some x y h) = CoordinateRing.XYIdeal' h := rfl
+
+theorem placeOfPoint_eq (P : W.Point) : placeOfPoint (W := W) P = placeOfPt P := rfl
+
+theorem pointEquivPlace_symm_placeOfPt (P : W.Point) :
+    (pointEquivPlace (W := W)).symm (placeOfPt P) = P :=
+  pointEquivPlace_symm_placeOfPoint P
+
+variable [DecidableEq F]
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem classGroup_mk_unitIdealOfPoint (P : W.Point) :
+    ClassGroup.mk W.FunctionField (unitIdealOfPoint P) = Additive.toMul (Point.toClass P) := by
+  cases P with
+  | zero => exact map_one _
+  | some x y h => rfl
+
+def unitIdealOfDivisor (D : AlgebraicCurve.Divisor F W.FunctionField) :
+    (FractionalIdeal W.CoordinateRing⁰ W.FunctionField)ˣ :=
+  D.prod fun v n => unitIdealOfPoint ((pointEquivPlace (W := W)).symm v) ^ n
+
+omit [DecidableEq F] in
+@[scoped simp] theorem unitIdealOfDivisor_zero :
+    unitIdealOfDivisor (0 : AlgebraicCurve.Divisor F W.FunctionField) = 1 :=
+  Finsupp.prod_zero_index
+
+omit [DecidableEq F] in
+theorem unitIdealOfDivisor_add (D E : AlgebraicCurve.Divisor F W.FunctionField) :
+    unitIdealOfDivisor (D + E) = unitIdealOfDivisor D * unitIdealOfDivisor E :=
+  Finsupp.prod_add_index' (fun _ => zpow_zero _) fun _ m n => zpow_add _ m n
+
+omit [DecidableEq F] in
+theorem unitIdealOfDivisor_single (v : AlgebraicCurve.Place F W.FunctionField) (n : ℤ) :
+    unitIdealOfDivisor (Finsupp.single v n)
+      = unitIdealOfPoint ((pointEquivPlace (W := W)).symm v) ^ n :=
+  Finsupp.prod_single_index (zpow_zero _)
+
+theorem classGroup_mk_unitIdealOfDivisor (D : AlgebraicCurve.Divisor F W.FunctionField) :
+    ClassGroup.mk W.FunctionField (unitIdealOfDivisor D) = Additive.toMul (Point.toClass (divisorSum
+      D)) := by
+  induction D using Finsupp.induction with
+  | zero =>
+      rw [unitIdealOfDivisor_zero, map_one, map_zero, map_zero]
+      rfl
+  | single_add v n E _ _ ih =>
+      rw [unitIdealOfDivisor_add, map_mul, ih, unitIdealOfDivisor_single, map_zpow,
+        classGroup_mk_unitIdealOfPoint, map_add, divisorSum_single, map_add, toMul_add,
+        map_zsmul, toMul_zsmul]
+
+omit [DecidableEq F] in
+theorem count_unitIdealOfDivisor (D : AlgebraicCurve.Divisor F W.FunctionField)
+    (w : HeightOneSpectrum W.CoordinateRing) :
+    FractionalIdeal.count W.FunctionField w (unitIdealOfDivisor D : _) =
+      D (Place.ofHeightOneSpectrum (K := F) (F := W.FunctionField) w) := by
+  classical
+  induction D using Finsupp.induction with
+  | zero =>
+      rw [unitIdealOfDivisor_zero, Units.val_one, FractionalIdeal.count_one]
+      rfl
+  | single_add v n E _ _ ih =>
+      rw [unitIdealOfDivisor_add, Units.val_mul,
+        FractionalIdeal.count_mul _ _ (Units.ne_zero _) (Units.ne_zero _), ih,
+        Finsupp.add_apply, unitIdealOfDivisor_single, Units.val_zpow_eq_zpow_val,
+        FractionalIdeal.count_zpow, Finsupp.single_apply]
+      congr 1
+      obtain ⟨P, rfl⟩ := placeOfPt_surjective (W := W) v
+      rw [pointEquivPlace_symm_placeOfPt]
+      cases P with
+      | zero =>
+          rw [unitIdealOfPoint_zero, Units.val_one, FractionalIdeal.count_one, mul_zero,
+            placeOfPt_zero', ite_eq_right (vInf_ne_ofHeightOneSpectrum w)]
+      | some x y h =>
+          rw [unitIdealOfPoint_some, CoordinateRing.XYIdeal'_eq,
+            show (CoordinateRing.XYIdeal W x (Polynomial.C y) :
+                FractionalIdeal W.CoordinateRing⁰ W.FunctionField)
+              = ((hosOf h.left).asIdeal : FractionalIdeal W.CoordinateRing⁰ W.FunctionField)
+              from rfl,
+            FractionalIdeal.count_maximal, placeOfPt_some,
+            (ofHeightOneSpectrum_injective (K := F) (R := W.CoordinateRing)
+              (L := W.FunctionField)).eq_iff]
+          split_ifs <;> ring
+
+theorem divisorSum_eq_zero_of_isPrincipal' {D : AlgebraicCurve.Divisor F W.FunctionField}
+    (hD : Divisor.IsPrincipal D) : divisorSum D = 0 := by
+  obtain ⟨f, hf, hDf⟩ := hD
+  have key : (unitIdealOfDivisor D : FractionalIdeal W.CoordinateRing⁰ W.FunctionField)
+      = FractionalIdeal.spanSingleton W.CoordinateRing⁰ f :=
+    eq_of_count_eq (Units.ne_zero _)
+      (FractionalIdeal.spanSingleton_ne_zero_iff.mpr hf) fun w => by
+        rw [count_unitIdealOfDivisor, hDf, ord_ofHeightOneSpectrum_eq_count w hf]
+  have hcls : ClassGroup.mk W.FunctionField (unitIdealOfDivisor D) = 1 :=
+    ClassGroup.mk_eq_one_iff.mpr ((FractionalIdeal.isPrincipal_iff _).mpr ⟨f, key⟩)
+  apply Point.toClass_injective
+  rw [map_zero]
+  rw [classGroup_mk_unitIdealOfDivisor] at hcls
+  exact Additive.toMul.injective hcls
+
+theorem isPrincipal_of_divisorSum_eq_zero' {D : AlgebraicCurve.Divisor F W.FunctionField}
+    (h0 : Divisor.degree D = 0) (hD : divisorSum D = 0) : Divisor.IsPrincipal D := by
+  classical
+  have hcls : ClassGroup.mk W.FunctionField (unitIdealOfDivisor D) = 1 := by
+    rw [classGroup_mk_unitIdealOfDivisor, hD, map_zero]
+    rfl
+  obtain ⟨f, hf⟩ := (FractionalIdeal.isPrincipal_iff _).mp (ClassGroup.mk_eq_one_iff.mp hcls)
+  have hf0 : f ≠ 0 := by
+    rintro rfl
+    rw [FractionalIdeal.spanSingleton_zero] at hf
+    exact Units.ne_zero (unitIdealOfDivisor D) hf
+  have hfin : ∀ w : HeightOneSpectrum W.CoordinateRing,
+      D (Place.ofHeightOneSpectrum (K := F) (F := W.FunctionField) w)
+        = (Place.ofHeightOneSpectrum (K := F) (F := W.FunctionField) w).ord f := by
+    intro w
+    rw [← count_unitIdealOfDivisor, hf, ord_ofHeightOneSpectrum_eq_count w hf0]
+  obtain ⟨Df, hDf, hDf0⟩ := HasPrincipalDivisors.exists_divisor (K := F) f hf0
+  have hsub : D - Df = Finsupp.single (vInf W) ((D - Df) (vInf W)) := by
+    ext v
+    obtain ⟨P, rfl⟩ := placeOfPt_surjective (W := W) v
+    cases P with
+    | zero =>
+        rw [placeOfPt_zero', Finsupp.single_eq_same]
+    | some x y h =>
+        rw [Finsupp.sub_apply, placeOfPt_some, hfin, hDf, sub_self, Finsupp.single_apply,
+          ite_eq_right (vInf_ne_ofHeightOneSpectrum _)]
+  have hdeg : Divisor.degree (D - Df) = 0 := by rw [map_sub, h0, hDf0, sub_zero]
+  rw [hsub, Divisor.degree_single, vInf_deg, Nat.cast_one, mul_one, Finsupp.sub_apply,
+    sub_eq_zero] at hdeg
+  refine ⟨f, hf0, fun v => ?_⟩
+  obtain ⟨P, rfl⟩ := placeOfPt_surjective (W := W) v
+  cases P with
+  | zero => rw [placeOfPt_zero', hdeg, hDf]
+  | some x y h => rw [placeOfPt_some, hfin]
+
+theorem abel_geomGate : AbelTheorem W :=
+  ⟨fun _D h0 => ⟨divisorSum_eq_zero_of_isPrincipal', isPrincipal_of_divisorSum_eq_zero' h0⟩⟩
+
+theorem main_impl : ∃ g : GenusOnePlaceGate W,
+    @GenusOnePlaceGate.IsCentred F _ W g ∧ @AbelTheorem F _ _ g _ :=
+  ⟨geomGate, isCentred_geomGate, abel_geomGate⟩
+
+end Closed
+
+end D5S
+end
+
+theorem solution {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F]
+    (W : WeierstrassCurve.Affine F) [W.IsElliptic] :
+    ∃ g : WeierstrassCurve.Affine.GenusOnePlaceGate W,
+      @WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred F _ W g ∧
+        @WeierstrassCurve.Affine.AbelTheorem F _ _ g _ :=
+  D5S.main_impl
+
+end S_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_abelTheorem
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_abelTheorem (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.Affine.exists_genusOnePlaceGate_isCentred_abelTheorem
+    {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F] (W : WeierstrassCurve.Affine F)
+    [W.IsElliptic] :
+    ∃ g : WeierstrassCurve.Affine.GenusOnePlaceGate W,
+      @WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred F _ W g ∧
+      @WeierstrassCurve.Affine.AbelTheorem F _ _ g _ :=
+  solution W
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_and_abelTheorem.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_and_abelTheorem.lean
new file mode 100644
index 0000000000..39f6a6259d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_and_abelTheorem.lean
@@ -0,0 +1,1773 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.exists_genusOnePlaceGate_isCentred_and_abelTheorem
+(218538e7-63fe-50ab-a135-d4e19bc04659) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3ae641ac-6732-513f-991b-311e844bf4e9
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.RingTheory.Polynomial.DegreeLT
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_eq_neg_log_of_valuationSubring_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_min_ord_le_ord_add_v2
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of a centred genus-one place gate with Abel's theorem
+
+Theorem statement: `WeierstrassCurve.Affine.exists_genusOnePlaceGate_isCentred_and_abelTheorem`
+(`218538e7-63fe-50ab-a135-d4e19bc04659`), by Claude, 2026-09-05.
+
+Proof: submission `3ae641ac-6732-513f-991b-311e844bf4e9`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field (with decidable equality) and let $W$ be an affine
+Weierstrass curve over $F$ which is elliptic, whose coordinate ring `W.CoordinateRing` is a Dedekind
+domain, and whose function field `W.FunctionField` satisfies [`AlgebraicCurve.HasPrincipalDivisors F
+W.FunctionField`](def/AlgebraicCurve_DivisorClassGroup.html#L217), i.e. every nonzero $f$ in the
+function field admits a finitely supported integer-valued function $D$ on the places of
+$W.FunctionField$ over $F$ with $D(v) = v.\mathrm{ord}\,f$ for every place $v$ and with $\deg D =
+\sum_v D(v)\,v.\mathrm{deg} = 0$; here a place is a valuation subring of the function field,
+containing the image of $F$, distinct from the whole field and a principal ideal ring. Then there
+exists a term $g$ of [`WeierstrassCurve.Affine.GenusOnePlaceGate
+W`](def/WeierstrassCurve_GenusOnePic0.html#L18), that is, a bijection between the group $W(F)$ of
+points of $W$ and the set of such places, all of whose places satisfy $v.\mathrm{deg} = 1$, such
+that moreover, with respect to $g$: (i) the gate is centred, meaning that for all $x, y \in F$ with
+$W.\mathrm{Nonsingular}\ x\ y$, the images in the function field of the classes of $X - x$ and of $Y
+- y$ in the coordinate ring lie in the non-units of the valuation subring of the place attached to
+the point $(x,y)$; and (ii) Abel's theorem holds, i.e. every divisor $D$ of degree $0$ is principal
+— there is a nonzero $f$ with $D(v) = v.\mathrm{ord}\,f$ for all $v$ — if and only if $\sum_v
+D(v)\,g^{-1}(v) = O$ in $W(F)$.
+
+This is the identification of the places of the function field of an elliptic curve over an
+algebraically closed field with its points, together with Abel's theorem in genus one, which yields
+the isomorphism $\operatorname{Pic}^0 \cong W(F)$; the centring condition pins the bijection down
+geometrically, sending an affine point to the valuation centred at it. It supplies the gate instance
+used downstream in the study of Vélu quotients and modular polynomials, for instance in the results
+on roots of the modular polynomial at $j$-invariants of isogenous curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_and_abelTheorem.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_OVERLONG_a3e19da5
+
+p2m_open "Ideal~map_mul"
+
+open Module Polynomial
+
+open scoped nonZeroDivisors Polynomial.Bivariate
+
+namespace WeierstrassCurve
+namespace Affine
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+universe u
+
+variable {F : Type u} [Field F] {W : Affine F}
+
+namespace CoordinateRing
+p2m_open "WeierstrassCurve.Affine.CoordinateRing"
+
+scoped instance : Algebra.FiniteType F W.CoordinateRing :=
+  Algebra.FiniteType.trans (S := Polynomial F) inferInstance inferInstance
+
+theorem exists_eq_XYIdeal_of_isMaximal [IsAlgClosed F] (𝔪 : Ideal W.CoordinateRing)
+    (h𝔪 : 𝔪.IsMaximal) : ∃ x y : F, W.Equation x y ∧ XYIdeal W x (C y) = 𝔪 := by
+  have := h𝔪
+  let : Field (W.CoordinateRing ⧸ 𝔪) := Ideal.Quotient.field 𝔪
+  have : Module.Finite F (W.CoordinateRing ⧸ 𝔪) :=
+    finite_of_finite_type_of_isJacobsonRing F (W.CoordinateRing ⧸ 𝔪)
+  have he : Function.Bijective (algebraMap F (W.CoordinateRing ⧸ 𝔪)) :=
+    IsAlgClosed.algebraMap_bijective_of_isIntegral
+  obtain ⟨x, hx⟩ := he.2 (Ideal.Quotient.mk 𝔪 (mk W (Polynomial.C Polynomial.X)))
+  obtain ⟨y, hy⟩ := he.2 (Ideal.Quotient.mk 𝔪 (mk W Y))
+  have hconst : ∀ a : F, Ideal.Quotient.mk 𝔪 ((CoordinateRing.mk W) (Polynomial.C (Polynomial.C a)))
+      = algebraMap F (W.CoordinateRing ⧸ 𝔪) a := by
+    intro a
+    have h1 : (CoordinateRing.mk W) (Polynomial.C (Polynomial.C a))
+        = algebraMap F W.CoordinateRing a := by
+      rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+        Algebra.algebraMap_self_apply]
+      rfl
+    rw [h1, ← Ideal.Quotient.algebraMap_eq, ← IsScalarTower.algebraMap_apply]
+  have key : ((Ideal.Quotient.mk 𝔪).comp
+        (mk W : Polynomial (Polynomial F) →+* W.CoordinateRing)) =
+      (algebraMap F (W.CoordinateRing ⧸ 𝔪)).comp
+        ((Polynomial.evalRingHom x).comp (Polynomial.evalRingHom (Polynomial.C y))) := by
+    refine Polynomial.ringHom_ext' (Polynomial.ringHom_ext (fun a => ?_) ?_) ?_
+    · simp only [RingHom.comp_apply, Polynomial.coe_evalRingHom, Polynomial.eval_C]
+      exact hconst a
+    · simp only [RingHom.comp_apply, Polynomial.coe_evalRingHom, Polynomial.eval_X,
+        Polynomial.eval_C]
+      exact hx.symm
+    · simp only [RingHom.comp_apply, Polynomial.coe_evalRingHom, Polynomial.eval_X,
+        Polynomial.eval_C]
+      exact hy.symm
+  have heval : W.Equation x y := by
+    have h0 := DFunLike.congr_fun key W.polynomial
+    simp only [RingHom.comp_apply, AdjoinRoot.mk_self, _root_.map_zero,
+      Polynomial.coe_evalRingHom] at h0
+    exact (map_eq_zero_iff (algebraMap F (W.CoordinateRing ⧸ 𝔪)) he.1).mp h0.symm
+  have hXmem : XClass W x ∈ 𝔪 := by
+    have h2 : ((Ideal.Quotient.mk 𝔪).comp (mk W))
+        (Polynomial.C (Polynomial.X - Polynomial.C x)) = 0 := by
+      rw [key]
+      simp
+    rw [← Ideal.Quotient.eq_zero_iff_mem]
+    exact h2
+  have hYmem : YClass W (Polynomial.C y) ∈ 𝔪 := by
+    have h2 : ((Ideal.Quotient.mk 𝔪).comp (mk W))
+        (Y - Polynomial.C (Polynomial.C y)) = 0 := by
+      rw [key]
+      simp
+    rw [← Ideal.Quotient.eq_zero_iff_mem]
+    exact h2
+  refine ⟨x, y, heval, ?_⟩
+  have hXY_le : XYIdeal W x (Polynomial.C y) ≤ 𝔪 := by
+    rw [XYIdeal, Ideal.span_le]
+    rintro _ (rfl | rfl)
+    · exact hXmem
+    · exact hYmem
+  have hXY_max : (XYIdeal W x (Polynomial.C y)).IsMaximal :=
+    Ideal.Quotient.maximal_of_isField _
+      ((quotientXYIdealEquiv (W' := W) (x := x) (y := Polynomial.C y)
+        heval).toMulEquiv.isField (Field.toIsField F))
+  exact hXY_max.eq_of_le h𝔪.ne_top hXY_le
+
+end CoordinateRing
+
+end Affine
+end WeierstrassCurve
+
+open
+  P2MW.S_OVERLONG_a3e19da5.WeierstrassCurve.Affine.CoordinateRing
+
+section
+
+open Module Polynomial
+
+open scoped Polynomial.Bivariate
+
+namespace WeierstrassCurve
+namespace Affine
+namespace CoordinateRing
+p2m_open "WeierstrassCurve.Affine.CoordinateRing WeierstrassCurve.Affine WeierstrassCurve"
+
+universe u
+
+variable {F : Type u} [Field F] {W : Affine F}
+
+private lemma algebraMap_eq_mk_C_C_s18priv (a : F) :
+    algebraMap F W.CoordinateRing a = mk W (C (C a)) := by
+  rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+    Algebra.algebraMap_self_apply]
+  rfl
+
+private lemma two_nsmul_le_coe_iff {d : WithBot ℕ} {n : ℕ} :
+    2 • d ≤ (n : WithBot ℕ) ↔ d < ((n / 2 + 1 : ℕ) : WithBot ℕ) := by
+  induction d using WithBot.recBotCoe with
+  | bot => exact iff_of_true (by simp) (WithBot.bot_lt_coe _)
+  | coe k =>
+    change 2 • ((k : ℕ) : WithBot ℕ) ≤ (n : WithBot ℕ) ↔
+      ((k : ℕ) : WithBot ℕ) < ((n / 2 + 1 : ℕ) : WithBot ℕ)
+    rw [two_nsmul, ← Nat.cast_add]
+    exact_mod_cast (by omega : k + k ≤ n ↔ k < n / 2 + 1)
+
+private lemma two_nsmul_add_three_le_coe_iff {d : WithBot ℕ} {n : ℕ} :
+    2 • d + 3 ≤ (n : WithBot ℕ) ↔ d < (((n - 1) / 2 : ℕ) : WithBot ℕ) := by
+  induction d using WithBot.recBotCoe with
+  | bot => exact iff_of_true (by simp) (WithBot.bot_lt_coe _)
+  | coe k =>
+    change 2 • ((k : ℕ) : WithBot ℕ) + 3 ≤ (n : WithBot ℕ) ↔
+      ((k : ℕ) : WithBot ℕ) < (((n - 1) / 2 : ℕ) : WithBot ℕ)
+    rw [two_nsmul, ← Nat.cast_add, show (3 : WithBot ℕ) = ((3 : ℕ) : WithBot ℕ) by norm_cast,
+      ← Nat.cast_add]
+    exact_mod_cast (by omega : k + k + 3 ≤ n ↔ k < (n - 1) / 2)
+
+private lemma xCount_add_yCount (n : ℕ) (hn : 1 ≤ n) : n / 2 + 1 + (n - 1) / 2 = n := by
+  omega
+
+variable (W) in
+noncomputable def rrParam (n : ℕ) :
+    (degreeLT F (n / 2 + 1) × degreeLT F ((n - 1) / 2)) →ₗ[F] W.CoordinateRing :=
+  LinearMap.coprod
+    (((LinearMap.toSpanSingleton F[X] W.CoordinateRing 1).restrictScalars F).comp
+      (Submodule.subtype _))
+    (((LinearMap.toSpanSingleton F[X] W.CoordinateRing (mk W Y)).restrictScalars F).comp
+      (Submodule.subtype _))
+
+@[scoped simp] lemma rrParam_apply (n : ℕ)
+    (pq : degreeLT F (n / 2 + 1) × degreeLT F ((n - 1) / 2)) :
+    rrParam W n pq = (pq.1 : F[X]) • (1 : W.CoordinateRing) + (pq.2 : F[X]) • mk W Y :=
+  rfl
+
+lemma rrParam_injective (n : ℕ) : Function.Injective (rrParam W n) := by
+  rw [injective_iff_map_eq_zero]
+  rintro ⟨p, q⟩ h
+  rw [rrParam_apply] at h
+  obtain ⟨hp, hq⟩ := smul_basis_eq_zero h
+  exact Prod.ext (Subtype.ext hp) (Subtype.ext hq)
+
+variable (W) in
+noncomputable def RRSpace (n : ℕ) : Submodule F W.CoordinateRing :=
+  LinearMap.range (rrParam W n)
+
+lemma mem_RRSpace_iff {f : W.CoordinateRing} {n : ℕ} :
+    f ∈ RRSpace W n ↔ ∃ p q : F[X], p.degree < ((n / 2 + 1 : ℕ) : WithBot ℕ) ∧
+      q.degree < (((n - 1) / 2 : ℕ) : WithBot ℕ) ∧
+      p • (1 : W.CoordinateRing) + q • mk W Y = f := by
+  constructor
+  · rintro ⟨⟨p, q⟩, rfl⟩
+    exact ⟨p, q, mem_degreeLT.mp p.2, mem_degreeLT.mp q.2, rfl⟩
+  · rintro ⟨p, q, hp, hq, rfl⟩
+    exact ⟨⟨⟨p, mem_degreeLT.mpr hp⟩, ⟨q, mem_degreeLT.mpr hq⟩⟩, rfl⟩
+
+lemma smul_basis_mem_RRSpace_iff {p q : F[X]} {n : ℕ} :
+    p • (1 : W.CoordinateRing) + q • mk W Y ∈ RRSpace W n ↔
+      p.degree < ((n / 2 + 1 : ℕ) : WithBot ℕ) ∧
+        q.degree < (((n - 1) / 2 : ℕ) : WithBot ℕ) := by
+  refine ⟨fun h => ?_, fun ⟨hp, hq⟩ => mem_RRSpace_iff.mpr ⟨p, q, hp, hq, rfl⟩⟩
+  obtain ⟨p', q', hp', hq', hf⟩ := mem_RRSpace_iff.mp h
+  have h0 : (p' - p) • (1 : W.CoordinateRing) + (q' - q) • mk W Y = 0 := by
+    rw [sub_smul, sub_smul, ← sub_eq_zero.mpr hf]
+    abel
+  obtain ⟨hp0, hq0⟩ := smul_basis_eq_zero h0
+  rw [sub_eq_zero] at hp0 hq0
+  exact ⟨hp0 ▸ hp', hq0 ▸ hq'⟩
+
+theorem mem_RRSpace_iff_degree_norm_le {f : W.CoordinateRing} {n : ℕ} :
+    f ∈ RRSpace W n ↔ (Algebra.norm F[X] f).degree ≤ (n : WithBot ℕ) := by
+  obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq f
+  rw [smul_basis_mem_RRSpace_iff, degree_norm_smul_basis, max_le_iff,
+    two_nsmul_le_coe_iff, two_nsmul_add_three_le_coe_iff]
+
+lemma RRSpace_mono {m n : ℕ} (h : m ≤ n) : RRSpace W m ≤ RRSpace W n := fun _ hf =>
+  mem_RRSpace_iff_degree_norm_le.mpr <|
+    (mem_RRSpace_iff_degree_norm_le.mp hf).trans <| by exact_mod_cast h
+
+lemma one_mem_RRSpace (n : ℕ) : (1 : W.CoordinateRing) ∈ RRSpace W n :=
+  mem_RRSpace_iff.mpr ⟨1, 0,
+    by rw [degree_one]; exact_mod_cast (by omega : (0 : ℕ) < n / 2 + 1),
+    by rw [degree_zero]; exact WithBot.bot_lt_coe _,
+    by rw [one_smul, zero_smul, add_zero]⟩
+
+lemma algebraMap_mem_RRSpace (a : F) (n : ℕ) :
+    algebraMap F W.CoordinateRing a ∈ RRSpace W n := by
+  rw [Algebra.algebraMap_eq_smul_one]
+  exact Submodule.smul_mem _ a (one_mem_RRSpace n)
+
+lemma one_le_RRSpace (n : ℕ) : (1 : Submodule F W.CoordinateRing) ≤ RRSpace W n := by
+  intro f hf
+  obtain ⟨a, rfl⟩ := Submodule.mem_one.mp hf
+  exact algebraMap_mem_RRSpace a n
+
+namespace RRSpace
+
+variable (W) in
+noncomputable def basisAux (n : ℕ) :
+    Basis (Fin (n / 2 + 1 + (n - 1) / 2)) F (RRSpace W n) :=
+  (degreeLT.basisProd F (n / 2 + 1) ((n - 1) / 2)).map
+    (LinearEquiv.ofInjective (rrParam W n) (rrParam_injective n))
+
+theorem finrank_eq (n : ℕ) (hn : 1 ≤ n) : finrank F (RRSpace W n) = n := by
+  rw [finrank_eq_card_basis (basisAux W n), Fintype.card_fin]
+  exact xCount_add_yCount n hn
+
+variable (W) in
+noncomputable def finBasis (n : ℕ) (hn : 1 ≤ n) : Basis (Fin n) F (RRSpace W n) :=
+  (basisAux W n).reindex (finCongr (xCount_add_yCount n hn))
+
+end RRSpace
+
+theorem RRSpace_zero : RRSpace W 0 = (1 : Submodule F W.CoordinateRing) := by
+  refine le_antisymm ?_ (one_le_RRSpace 0)
+  rintro f hf
+  obtain ⟨p, q, hp, hq, rfl⟩ := mem_RRSpace_iff.mp hf
+  have hq0 : q = 0 := by
+    rw [← degree_eq_bot]
+    simpa using hq
+  have hp0 : p = C (p.coeff 0) := by
+    refine degree_le_zero_iff.mp (Nat.WithBot.lt_one_iff_le_zero.mp ?_)
+    simpa using hp
+  rw [hq0, zero_smul, add_zero, hp0, smul, mul_one, ← algebraMap_eq_mk_C_C_s18priv]
+  exact Submodule.mem_one.mpr ⟨p.coeff 0, rfl⟩
+
+end CoordinateRing
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+section
+
+p2m_open "FractionalIdeal \
+  P2MW.S_OVERLONG_a3e19da5.FractionalIdea\
+  l Polynomial"
+
+open scoped nonZeroDivisors Polynomial.Bivariate
+
+namespace FractionalIdeal
+p2m_open "FractionalIdeal"
+
+variable {R : Type*} (K : Type*) [CommRing R] [IsDomain R] [Field K] [Algebra R K]
+  [IsFractionRing R K]
+
+theorem isUnit_coeIdeal_of_forall_isMaximal [IsNoetherianRing R]
+    (hmax : ∀ 𝔪 : Ideal R, 𝔪.IsMaximal → 𝔪 ≠ ⊥ → IsUnit (𝔪 : FractionalIdeal R⁰ K))
+    (I : Ideal R) : I ≠ ⊥ → IsUnit (I : FractionalIdeal R⁰ K) := by
+  refine IsNoetherian.induction
+    (P := fun I : Ideal R => I ≠ ⊥ → IsUnit (I : FractionalIdeal R⁰ K)) (fun I ih hI => ?_) I
+  rcases eq_or_ne I ⊤ with rfl | hItop
+  · rw [coeIdeal_top]
+    exact isUnit_one
+  obtain ⟨𝔪, h𝔪, hI𝔪⟩ := Ideal.exists_le_maximal I hItop
+  have h𝔪0 : 𝔪 ≠ ⊥ := fun h => hI (le_bot_iff.mp (h ▸ hI𝔪))
+  have h𝔪unit : IsUnit (𝔪 : FractionalIdeal R⁰ K) := hmax 𝔪 h𝔪 h𝔪0
+  have h𝔪inv : (𝔪 : FractionalIdeal R⁰ K) * (𝔪 : FractionalIdeal R⁰ K)⁻¹ = 1 :=
+    (mul_inv_cancel_iff_isUnit K).mpr h𝔪unit
+  have hle : (I : FractionalIdeal R⁰ K) * (𝔪 : FractionalIdeal R⁰ K)⁻¹ ≤ 1 := by
+    calc (I : FractionalIdeal R⁰ K) * (𝔪 : FractionalIdeal R⁰ K)⁻¹
+        ≤ (𝔪 : FractionalIdeal R⁰ K) * (𝔪 : FractionalIdeal R⁰ K)⁻¹ := by gcongr
+      _ = 1 := h𝔪inv
+  obtain ⟨J, hJ⟩ := le_one_iff_exists_coeIdeal.mp hle
+  have hJ𝔪 : J * 𝔪 = I := by
+    rw [← coeIdeal_inj (K := K), coeIdeal_mul, hJ, mul_assoc,
+      mul_comm (𝔪 : FractionalIdeal R⁰ K)⁻¹, h𝔪inv, mul_one]
+  have hIJ : I ≤ J := hJ𝔪 ▸ Ideal.mul_le_left
+  have hJ0 : J ≠ ⊥ := fun h => hI (le_bot_iff.mp (h ▸ hIJ))
+  have hne : I ≠ J := by
+    rintro rfl
+    have hsmul : I ≤ 𝔪 • I := by
+      rw [Ideal.smul_eq_mul, mul_comm]
+      exact le_of_eq hJ𝔪.symm
+    obtain ⟨r, hr𝔪, hr⟩ := Submodule.exists_sub_one_mem_and_smul_eq_zero_of_fg_of_le_smul 𝔪 I
+      (IsNoetherian.noetherian I) hsmul
+    obtain ⟨n, hnI, hn0⟩ := Submodule.exists_mem_ne_zero_of_ne_bot hI
+    have hr0 : r = 0 := by
+      have hrn := hr n hnI
+      rw [smul_eq_mul] at hrn
+      exact (mul_eq_zero.mp hrn).resolve_right hn0
+    exact h𝔪.ne_top (𝔪.eq_top_of_isUnit_mem (by simpa [hr0] using hr𝔪) isUnit_one.neg)
+  have hJunit : IsUnit (J : FractionalIdeal R⁰ K) := ih J (lt_of_le_of_ne hIJ hne) hJ0
+  rw [← hJ𝔪, coeIdeal_mul]
+  exact hJunit.mul h𝔪unit
+
+theorem isUnit_of_forall_isMaximal [IsNoetherianRing R]
+    (hmax : ∀ 𝔪 : Ideal R, 𝔪.IsMaximal → 𝔪 ≠ ⊥ → IsUnit (𝔪 : FractionalIdeal R⁰ K))
+    (I : FractionalIdeal R⁰ K) (hI : I ≠ 0) : IsUnit I := by
+  obtain ⟨a, J, ha, rfl⟩ := exists_eq_spanSingleton_mul I
+  have ha' : algebraMap R K a ≠ 0 := mt IsFractionRing.to_map_eq_zero_iff.mp ha
+  refine IsUnit.mul ?_ (isUnit_coeIdeal_of_forall_isMaximal K hmax J ?_)
+  · exact isUnit_iff_exists_inv.mpr ⟨spanSingleton R⁰ (algebraMap R K a), by
+      rw [FractionalIdeal.spanSingleton_mul_spanSingleton, inv_mul_cancel₀ ha',
+        FractionalIdeal.spanSingleton_one]⟩
+  · rintro rfl
+    simp at hI
+
+end FractionalIdeal
+
+theorem isDedekindDomain_of_forall_isMaximal_isUnit {R : Type*} (K : Type*) [CommRing R]
+    [IsDomain R] [Field K] [Algebra R K] [IsFractionRing R K] [IsNoetherianRing R]
+    (hmax : ∀ 𝔪 : Ideal R, 𝔪.IsMaximal → 𝔪 ≠ ⊥ → IsUnit (𝔪 : FractionalIdeal R⁰ K)) :
+    IsDedekindDomain R :=
+  (isDedekindDomain_iff_mul_inv_cancel (K := K)).mpr fun I hI =>
+    (mul_inv_cancel_iff_isUnit K).mpr (isUnit_of_forall_isMaximal K hmax I hI)
+
+namespace WeierstrassCurve
+namespace Affine
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+universe u
+
+variable {F : Type u} [Field F] {W : Affine F}
+
+namespace CoordinateRing
+p2m_open "WeierstrassCurve.Affine.CoordinateRing"
+
+theorem isUnit_coeIdeal_of_isMaximal [IsAlgClosed F] (hΔ : W.Δ ≠ 0)
+    {𝔪 : Ideal W.CoordinateRing} (h𝔪 : 𝔪.IsMaximal) :
+    IsUnit (𝔪 : FractionalIdeal W.CoordinateRing⁰ W.FunctionField) := by
+  obtain ⟨x, y, hxy, hXY⟩ := exists_eq_XYIdeal_of_isMaximal 𝔪 h𝔪
+  rw [← hXY, ← XYIdeal'_eq ((W.equation_iff_nonsingular_of_Δ_ne_zero hΔ).mp hxy)]
+  exact (XYIdeal' _).isUnit
+
+theorem isDedekindDomain_of_Δ_ne_zero [IsAlgClosed F] (hΔ : W.Δ ≠ 0) :
+    IsDedekindDomain W.CoordinateRing :=
+  isDedekindDomain_of_forall_isMaximal_isUnit W.FunctionField
+    fun _𝔪 h𝔪 _ => isUnit_coeIdeal_of_isMaximal hΔ h𝔪
+
+scoped instance [IsAlgClosed F] [W.IsElliptic] : IsDedekindDomain W.CoordinateRing :=
+  isDedekindDomain_of_Δ_ne_zero (W.coe_Δ' ▸ W.Δ'.ne_zero)
+
+end CoordinateRing
+
+end Affine
+end WeierstrassCurve
+end
+
+
+noncomputable section
+
+open IsDedekindDomain Polynomial
+
+open scoped Polynomial.Bivariate
+
+namespace AlgebraicCurve
+namespace Place
+p2m_open "AlgebraicCurve.Place AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem deg_eq_one_of_surjective (v : Place K F)
+    (h : Function.Surjective (algebraMap K v.ResidueField)) : v.deg = 1 := by
+  have hbij : Function.Bijective (algebraMap K v.ResidueField) :=
+    ⟨(algebraMap K v.ResidueField).injective, h⟩
+  change Module.finrank K v.ResidueField = 1
+  rw [← Module.finrank_self K]
+  exact ((AlgEquiv.ofBijective (Algebra.ofId K v.ResidueField) hbij).toLinearEquiv.finrank_eq).symm
+
+variable {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R F] [IsFractionRing R F]
+variable [Algebra K R] [IsScalarTower K R F]
+
+theorem deg_ofHeightOneSpectrum_eq_one (w : HeightOneSpectrum R)
+    (hw : ∀ r : R, ∃ c : K, r - algebraMap K R c ∈ w.asIdeal) :
+    (ofHeightOneSpectrum (K := K) (F := F) w).deg = 1 := by
+  set v : Place K F := ofHeightOneSpectrum (K := K) w with hv
+  apply deg_eq_one_of_surjective
+  intro z
+  obtain ⟨a, rfl⟩ := Ideal.Quotient.mk_surjective z
+  obtain ⟨n, d, hd, hnd⟩ : ∃ (n d : R) (_ : d ∈ w.asIdeal.primeCompl),
+      (a : F) * algebraMap R F d = algebraMap R F n := by
+    obtain ⟨n, d, hcase | hcase⟩ := w.exists_primeCompl_mul_eq_or_mul_eq (K := F) (a : F)
+    · exact ⟨n, d, d.2, hcase⟩
+    · refine ⟨(d : R), n, ?_, hcase⟩
+      intro hn
+      refine d.2 ?_
+      replace hn : n ∈ w.asIdeal := hn
+      change (d : R) ∈ w.asIdeal
+      rw [← w.valuation_lt_one_iff_mem (K := F)] at hn ⊢
+      calc w.valuation F (algebraMap R F (d : R))
+          = w.valuation F (a : F) * w.valuation F (algebraMap R F n) := by
+            rw [← map_mul, hcase]
+        _ ≤ 1 * w.valuation F (algebraMap R F n) := mul_le_mul_left a.2 _
+        _ = w.valuation F (algebraMap R F n) := one_mul _
+        _ < 1 := hn
+  obtain ⟨cn, hcn⟩ := hw n
+  obtain ⟨cd, hcd⟩ := hw d
+  have hcd0 : cd ≠ 0 := by
+    rintro rfl
+    rw [_root_.map_zero, sub_zero] at hcd
+    exact hd hcd
+  have hcdR : algebraMap K R cd ∉ w.asIdeal := fun hmem =>
+    hd (by simpa using w.asIdeal.add_mem hcd hmem)
+  have hvd : w.valuation F (algebraMap R F d) = 1 :=
+    le_antisymm (w.valuation_le_one d)
+      (not_lt.mp fun hlt => hd ((w.valuation_lt_one_iff_mem (K := F) d).mp hlt))
+  have hvcd : w.valuation F (algebraMap K F cd) = 1 := by
+    rw [IsScalarTower.algebraMap_apply K R F]
+    exact le_antisymm (w.valuation_le_one _)
+      (not_lt.mp fun hlt => hcdR ((w.valuation_lt_one_iff_mem (K := F) _).mp hlt))
+  have hcdF : algebraMap K F cd ≠ 0 := by
+    simpa using hcd0
+  refine ⟨cn / cd, ?_⟩
+  rw [IsScalarTower.algebraMap_apply K v.toValuationSubring v.ResidueField,
+    IsLocalRing.ResidueField.algebraMap_eq]
+  refine (Ideal.Quotient.eq (I := IsLocalRing.maximalIdeal v.toValuationSubring)).mpr ?_
+  have hmem : algebraMap K R cn * d - algebraMap K R cd * n ∈ w.asIdeal := by
+    have heq : algebraMap K R cn * d - algebraMap K R cd * n
+        = -((n - algebraMap K R cn) * d) + n * (d - algebraMap K R cd) := by ring
+    rw [heq]
+    exact w.asIdeal.add_mem (w.asIdeal.neg_mem (w.asIdeal.mul_mem_right _ hcn))
+      (w.asIdeal.mul_mem_left _ hcd)
+  have key : ((algebraMap K v.toValuationSubring (cn / cd) : F) - (a : F))
+      * (algebraMap K F cd * algebraMap R F d)
+      = algebraMap R F (algebraMap K R cn * d - algebraMap K R cd * n) := by
+    rw [coe_algebraMap, map_div₀, map_sub, map_mul, map_mul]
+    simp only [← IsScalarTower.algebraMap_apply K R F]
+    field_simp
+    linear_combination (-(algebraMap K F cd)) * hnd
+  refine (Valuation.mem_maximalIdeal_iff (v := w.valuation F)).mpr ?_
+  change w.valuation F ((algebraMap K v.toValuationSubring (cn / cd) : F) - (a : F)) < 1
+  calc w.valuation F ((algebraMap K v.toValuationSubring (cn / cd) : F) - (a : F))
+      = w.valuation F ((algebraMap K v.toValuationSubring (cn / cd) : F) - (a : F))
+        * (w.valuation F (algebraMap K F cd) * w.valuation F (algebraMap R F d)) := by
+          rw [hvcd, hvd, one_mul, mul_one]
+    _ = w.valuation F (((algebraMap K v.toValuationSubring (cn / cd) : F) - (a : F))
+        * (algebraMap K F cd * algebraMap R F d)) := by rw [map_mul, map_mul]
+    _ = w.valuation F (algebraMap R F (algebraMap K R cn * d - algebraMap K R cd * n)) := by
+          rw [key]
+    _ < 1 := (w.valuation_lt_one_iff_mem (K := F) _).mpr hmem
+
+end Place
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+namespace Affine
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+namespace CoordinateRing
+p2m_open "WeierstrassCurve.Affine.CoordinateRing"
+
+theorem algebraMap_eq_mk_C_C (a : F) :
+    algebraMap F W.CoordinateRing a = CoordinateRing.mk W (C (C a)) := by
+  rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+    Algebra.algebraMap_self_apply]
+  rfl
+
+theorem XYIdeal_isMaximal {x y : F} (h : W.Equation x y) :
+    (XYIdeal W x (C y)).IsMaximal :=
+  Ideal.Quotient.maximal_of_isField _
+    ((quotientXYIdealEquiv (W' := W) (x := x) (y := C y) h).toMulEquiv.isField
+      (Field.toIsField F))
+
+theorem XYIdeal_ne_bot (x : F) (y : F[X]) : XYIdeal W x y ≠ ⊥ := by
+  intro hbot
+  have hX : XClass W x ∈ XYIdeal W x y := Ideal.subset_span (Set.mem_insert _ _)
+  rw [hbot, Ideal.mem_bot] at hX
+  exact XClass_ne_zero x hX
+
+theorem eq_of_XYIdeal_eq {x₁ y₁ x₂ y₂ : F} (h₂ : W.Equation x₂ y₂)
+    (h : XYIdeal W x₁ (C y₁) = XYIdeal W x₂ (C y₂)) : x₁ = x₂ ∧ y₁ = y₂ := by
+  have hne : XYIdeal W x₂ (C y₂) ≠ ⊤ := (XYIdeal_isMaximal h₂).ne_top
+  have hX₁ : XClass W x₁ ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert _ _)
+  have hX₂ : XClass W x₂ ∈ XYIdeal W x₂ (C y₂) := Ideal.subset_span (Set.mem_insert _ _)
+  have hY₁ : YClass W (C y₁) ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  have hY₂ : YClass W (C y₂) ∈ XYIdeal W x₂ (C y₂) :=
+    Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  constructor
+  · by_contra hx
+    apply hne
+    have hsub : XClass W x₁ - XClass W x₂ = algebraMap F W.CoordinateRing (x₂ - x₁) := by
+      rw [XClass, XClass, ← map_sub, algebraMap_eq_mk_C_C]
+      grind
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hX₁ hX₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hx hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+  · by_contra hy
+    apply hne
+    have hsub : YClass W (C y₁) - YClass W (C y₂) = algebraMap F W.CoordinateRing (y₂ - y₁) := by
+      rw [YClass, YClass, ← map_sub, algebraMap_eq_mk_C_C]
+      grind
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hY₁ hY₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hy hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+
+def heightOneSpectrumOfEquation {x y : F} (h : W.Equation x y) :
+    HeightOneSpectrum W.CoordinateRing where
+  asIdeal := XYIdeal W x (C y)
+  isPrime := (XYIdeal_isMaximal h).isPrime
+  ne_bot := XYIdeal_ne_bot x (C y)
+
+@[scoped simp]
+theorem heightOneSpectrumOfEquation_asIdeal {x y : F} (h : W.Equation x y) :
+    (heightOneSpectrumOfEquation h).asIdeal = XYIdeal W x (C y) := rfl
+
+theorem exists_sub_algebraMap_mem {x y : F} (h : W.Equation x y) (r : W.CoordinateRing) :
+    ∃ c : F, r - algebraMap F W.CoordinateRing c ∈ XYIdeal W x (C y) := by
+  set e := quotientXYIdealEquiv (W' := W) (x := x) (y := C y) h
+  refine ⟨e (Ideal.Quotient.mk _ r), ?_⟩
+  rw [← Ideal.Quotient.eq_zero_iff_mem, map_sub, sub_eq_zero]
+  apply e.injective
+  rw [← Ideal.Quotient.algebraMap_eq, ← IsScalarTower.algebraMap_apply, AlgEquiv.commutes,
+    Algebra.algebraMap_self_apply]
+
+end CoordinateRing
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_a3e19da5.WeierstrassCurv\
+  e.Affine.CoordinateRing"
+
+def IsFinitePlace (v : AlgebraicCurve.Place F W.FunctionField) : Prop :=
+  ∀ r : W.CoordinateRing, algebraMap W.CoordinateRing W.FunctionField r ∈ v.toValuationSubring
+
+def IsFinitePlace.ringHom {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    W.CoordinateRing →+* v.toValuationSubring where
+  toFun r := ⟨algebraMap W.CoordinateRing W.FunctionField r, hv r⟩
+  map_one' := Subtype.ext (map_one _)
+  map_mul' a b := Subtype.ext (map_mul _ a b)
+  map_zero' := Subtype.ext (_root_.map_zero _)
+  map_add' a b := Subtype.ext (map_add _ a b)
+
+def IsFinitePlace.centre {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    Ideal W.CoordinateRing :=
+  (IsLocalRing.maximalIdeal v.toValuationSubring).comap hv.ringHom
+
+theorem IsFinitePlace.centre_isPrime {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre.IsPrime :=
+  Ideal.IsPrime.comap _
+
+theorem IsFinitePlace.inv_mem {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) {r : W.CoordinateRing} (hr : r ∉ hv.centre) :
+    (algebraMap W.CoordinateRing W.FunctionField r)⁻¹ ∈ v.toValuationSubring := by
+  have hunit : IsUnit (hv.ringHom r) := by
+    rw [IsFinitePlace.centre, Ideal.mem_comap, IsLocalRing.mem_maximalIdeal,
+      mem_nonunits_iff, not_not] at hr
+    exact hr
+  obtain ⟨t, ht⟩ := hunit.exists_right_inv
+  have ht' : algebraMap W.CoordinateRing W.FunctionField r * (t : W.FunctionField) = 1 := by
+    have := congrArg (fun a : v.toValuationSubring => (a : W.FunctionField)) ht
+    simp only [MulMemClass.coe_mul, OneMemClass.coe_one] at this
+    exact this
+  rw [inv_eq_of_mul_eq_one_right ht']
+  exact t.2
+
+theorem IsFinitePlace.centre_ne_bot {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre ≠ ⊥ := by
+  intro hbot
+  apply v.ne_top'
+  rw [eq_top_iff]
+  rintro z -
+  obtain ⟨r, s, hs, hz⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  have hs0 : s ∉ hv.centre := by
+    rw [hbot, Ideal.mem_bot]
+    exact fun h => nonZeroDivisors.ne_zero hs h
+  rw [← hz, div_eq_mul_inv]
+  exact mul_mem (hv r) (hv.inv_mem hs0)
+
+variable [IsDedekindDomain W.CoordinateRing]
+
+def placeOfEquation {x y : F} (h : W.Equation x y) :
+    AlgebraicCurve.Place F W.FunctionField :=
+  AlgebraicCurve.Place.ofHeightOneSpectrum (heightOneSpectrumOfEquation h)
+
+theorem deg_placeOfEquation {x y : F} (h : W.Equation x y) : (placeOfEquation h).deg = 1 :=
+  AlgebraicCurve.Place.deg_ofHeightOneSpectrum_eq_one _ (exists_sub_algebraMap_mem h)
+
+theorem placeOfEquation_injective {x₁ y₁ x₂ y₂ : F} (h₁ : W.Equation x₁ y₁)
+    (h₂ : W.Equation x₂ y₂) (h : placeOfEquation h₁ = placeOfEquation h₂) :
+    x₁ = x₂ ∧ y₁ = y₂ :=
+  eq_of_XYIdeal_eq h₂
+    (congrArg HeightOneSpectrum.asIdeal (AlgebraicCurve.Place.ofHeightOneSpectrum_injective h))
+
+theorem isFinitePlace_placeOfEquation {x y : F} (h : W.Equation x y) :
+    IsFinitePlace (placeOfEquation h) := fun r =>
+  (heightOneSpectrumOfEquation h).valuation_le_one r
+
+theorem isFinitePlace_iff_exists_placeOfEquation [IsAlgClosed F]
+    (v : AlgebraicCurve.Place F W.FunctionField) :
+    IsFinitePlace v ↔ ∃ (x y : F) (h : W.Equation x y), v = placeOfEquation h := by
+  constructor
+  · intro hv
+    have := hv.centre_isPrime
+    have hmax : hv.centre.IsMaximal := Ideal.IsPrime.isMaximal hv.centre_isPrime hv.centre_ne_bot
+    obtain ⟨x, y, hxy, hXY⟩ := CoordinateRing.exists_eq_XYIdeal_of_isMaximal hv.centre hmax
+    refine ⟨x, y, hxy, ?_⟩
+    set w : HeightOneSpectrum W.CoordinateRing := heightOneSpectrumOfEquation hxy with hw
+    set A : ValuationSubring W.FunctionField :=
+      HeightOneSpectrum.valuationSubringAtPrime W.FunctionField w with hA
+    have hAded : IsDedekindDomain A := by rw [hA]; infer_instance
+    have hle : A ≤ v.toValuationSubring := by
+      intro z hz
+      rw [hA] at hz
+      obtain ⟨r, s, hs, rfl⟩ := hz
+      have hs' : s ∉ hv.centre := by
+        intro hmem
+        rw [← hXY] at hmem
+        exact hs hmem
+      exact mul_mem (hv r) (hv.inv_mem hs')
+    have hSP : A.ofPrime (A.idealOfLE v.toValuationSubring hle) = v.toValuationSubring :=
+      ValuationSubring.ofPrime_idealOfLE A v.toValuationSubring hle
+    rcases eq_or_ne (A.idealOfLE v.toValuationSubring hle) ⊥ with hP | hP
+    · exfalso
+      apply v.ne_top'
+      have h2 : A.ofPrime ⊥ ≤ A.ofPrime (A.idealOfLE v.toValuationSubring hle) :=
+        ValuationSubring.ofPrime_le_of_le (h := hP.le)
+      rw [ValuationSubring.ofPrime_bot] at h2
+      exact top_le_iff.mp (le_trans h2 hSP.le)
+    · have hPmax : (A.idealOfLE v.toValuationSubring hle).IsMaximal :=
+        Ideal.IsPrime.isMaximal inferInstance hP
+      have hPeq : A.idealOfLE v.toValuationSubring hle = IsLocalRing.maximalIdeal A :=
+        IsLocalRing.eq_maximalIdeal hPmax
+      have h3 : A.ofPrime (A.idealOfLE v.toValuationSubring hle)
+          = A.ofPrime (IsLocalRing.maximalIdeal A) :=
+        le_antisymm (ValuationSubring.ofPrime_le_of_le (h := hPeq.ge))
+          (ValuationSubring.ofPrime_le_of_le (h := hPeq.le))
+      rw [ValuationSubring.ofPrime_top] at h3
+      have hAv : A = v.toValuationSubring := h3.symm.trans hSP
+      refine (AlgebraicCurve.Place.ext ?_).symm
+      change (AlgebraicCurve.Place.ofHeightOneSpectrum w).toValuationSubring = v.toValuationSubring
+      rw [AlgebraicCurve.Place.ofHeightOneSpectrum_toValuationSubring,
+        ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact hAv
+  · rintro ⟨x, y, h, rfl⟩
+    exact isFinitePlace_placeOfEquation h
+
+variable (W) in
+class InfinitePlace : Type _ where
+  place : AlgebraicCurve.Place F W.FunctionField
+  not_isFinitePlace : ¬ IsFinitePlace place
+  deg_eq_one : place.deg = 1
+  eq_of_not_isFinitePlace : ∀ v : AlgebraicCurve.Place F W.FunctionField,
+    ¬ IsFinitePlace v → v = place
+
+def geomPlaceOfPoint [InfinitePlace W] : W.Point → AlgebraicCurve.Place F W.FunctionField
+  | .zero => InfinitePlace.place
+  | .some x y h => placeOfEquation (W := W) (x := x) (y := y) h.left
+
+@[scoped simp]
+theorem geomPlaceOfPoint_zero [InfinitePlace W] :
+    geomPlaceOfPoint (.zero : W.Point) = InfinitePlace.place := rfl
+
+@[scoped simp]
+theorem geomPlaceOfPoint_some [InfinitePlace W] {x y : F} (h : W.Nonsingular x y) :
+    geomPlaceOfPoint (.some x y h) = placeOfEquation h.left := rfl
+
+theorem deg_geomPlaceOfPoint [InfinitePlace W] (P : W.Point) : (geomPlaceOfPoint P).deg = 1 := by
+  cases P with
+  | zero => exact InfinitePlace.deg_eq_one
+  | some x y h => exact deg_placeOfEquation h.left
+
+theorem geomPlaceOfPoint_injective [InfinitePlace W] :
+    Function.Injective (geomPlaceOfPoint (W := W)) := by
+  intro P Q
+  cases P <;>
+  cases Q <;>
+  grind [geomPlaceOfPoint_zero, geomPlaceOfPoint_some, InfinitePlace.not_isFinitePlace,
+    isFinitePlace_placeOfEquation, placeOfEquation_injective]
+
+theorem geomPlaceOfPoint_surjective [InfinitePlace W] [IsAlgClosed F] (hΔ : W.Δ ≠ 0) :
+    Function.Surjective (geomPlaceOfPoint (W := W)) := by
+  intro v
+  by_cases hv : IsFinitePlace v
+  · obtain ⟨x, y, h, rfl⟩ := (isFinitePlace_iff_exists_placeOfEquation v).mp hv
+    exact ⟨.some x y ((W.equation_iff_nonsingular_of_Δ_ne_zero hΔ).mp h), rfl⟩
+  · exact ⟨.zero, (InfinitePlace.eq_of_not_isFinitePlace v hv).symm⟩
+
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+noncomputable section
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_OVERLONG_a3e19da5.AlgebraicCurve"
+
+namespace WeierstrassCurve
+namespace Affine
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] {W : Affine F}
+variable [IsAlgClosed F] [W.IsElliptic] [InfinitePlace W]
+
+omit [DecidableEq F] [IsAlgClosed F] [InfinitePlace W] in
+theorem isElliptic_Δ_ne_zero : W.Δ ≠ 0 := W.coe_Δ' ▸ W.Δ'.ne_zero
+
+def geomPointEquivPlace : W.Point ≃ AlgebraicCurve.Place F W.FunctionField :=
+  Equiv.ofBijective geomPlaceOfPoint
+    ⟨geomPlaceOfPoint_injective, geomPlaceOfPoint_surjective isElliptic_Δ_ne_zero⟩
+
+omit [DecidableEq F] in
+@[scoped simp]
+theorem geomPointEquivPlace_apply (P : W.Point) : geomPointEquivPlace P = geomPlaceOfPoint P := rfl
+
+def geomDivisorSum : AlgebraicCurve.Divisor F W.FunctionField →+ W.Point :=
+  Finsupp.liftAddHom fun v => zmultiplesHom W.Point (geomPointEquivPlace.symm v)
+
+@[scoped simp]
+theorem geomDivisorSum_single (v : AlgebraicCurve.Place F W.FunctionField) (n : ℤ) :
+    geomDivisorSum (Finsupp.single v n) = n • (geomPointEquivPlace (W := W)).symm v :=
+  Finsupp.liftAddHom_apply_single _ v n
+
+variable (W) in
+class GeomAbelTheorem : Prop where
+  isPrincipal_iff_geomDivisorSum_eq_zero :
+    ∀ D : AlgebraicCurve.Divisor F W.FunctionField, Divisor.degree D = 0 →
+      (Divisor.IsPrincipal D ↔ geomDivisorSum D = 0)
+
+end Affine
+end WeierstrassCurve
+end
+
+
+noncomputable section
+
+open Polynomial IsDedekindDomain
+
+open scoped Polynomial.Bivariate
+
+namespace AlgebraicCurve
+namespace Place
+p2m_open "AlgebraicCurve.Place AlgebraicCurve"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.ord_add_eq_min {f g : F} (hf : f ≠ 0) (hg : g ≠ 0)
+    (h : v.ord f ≠ v.ord g) :
+    v.ord (f + g) = min (v.ord f) (v.ord g) := by
+  have hval : v.adicValuation f ≠ v.adicValuation g := by
+    intro hcon
+    exact h (by simp only [ord, hcon])
+  have h1 : v.adicValuation (f + g) = max (v.adicValuation f) (v.adicValuation g) :=
+    Valuation.map_add_of_distinct_val _ hval
+  have hfg : f + g ≠ 0 := by
+    intro hcon
+    rw [hcon, _root_.map_zero] at h1
+    rcases max_cases (v.adicValuation f) (v.adicValuation g) with ⟨hmax, -⟩ | ⟨hmax, -⟩ <;>
+      rw [hmax] at h1
+    · exact v.adicValuation_ne_zero hf h1.symm
+    · exact v.adicValuation_ne_zero hg h1.symm
+  rcases max_cases (v.adicValuation f) (v.adicValuation g) with ⟨hmax, hle⟩ | ⟨hmax, hlt⟩ <;>
+    rw [hmax] at h1
+  · have hlog := (WithZero.log_le_log (v.adicValuation_ne_zero hg)
+      (v.adicValuation_ne_zero hf)).mpr hle
+    have h2 : v.ord (f + g) = v.ord f := by simp only [ord, h1]
+    simp only [ord] at hlog h2 ⊢
+    omega
+  · have hlog := (WithZero.log_le_log (v.adicValuation_ne_zero hf)
+      (v.adicValuation_ne_zero hg)).mpr hlt.le
+    have h2 : v.ord (f + g) = v.ord g := by simp only [ord, h1]
+    simp only [ord] at hlog h2 ⊢
+    omega
+
+private theorem _root_.AlgebraicCurve.Place.ord_pow (f : F) (n : ℕ) :
+    v.ord (f ^ n) = n * v.ord f := by
+  rw [← zpow_natCast, v.ord_zpow]
+
+private theorem _root_.AlgebraicCurve.Place.ord_ringHom_eq_natDegree_mul {φ : K[X] →+* F}
+    (hφinj : Function.Injective φ)
+    (hφC : ∀ c : K, φ (C c) = algebraMap K F c) (hz : v.ord (φ X) < 0) :
+    ∀ {p : K[X]}, p ≠ 0 → v.ord (φ p) = p.natDegree * v.ord (φ X) := by
+  have hX0 : φ X ≠ 0 := fun h => by simp [Place.ord, h] at hz
+  have hmono : ∀ (c : K) (n : ℕ), c ≠ 0 → v.ord (φ (C c * X ^ n)) = n * v.ord (φ X) := by
+    intro c n hc
+    have hc0 : φ (C c) ≠ 0 := by
+      rw [hφC]
+      simpa using hc
+    rw [map_mul, map_pow, v.ord_mul hc0 (pow_ne_zero n hX0), hφC, v.ord_algebraMap,
+      v.ord_pow, zero_add]
+  intro p
+  induction hd : p.natDegree using Nat.strong_induction_on generalizing p with
+  | _ d ih =>
+    intro hp
+    subst hd
+    rcases eq_or_ne p.eraseLead 0 with he | he
+    · conv_lhs => rw [← p.eraseLead_add_C_mul_X_pow, he, zero_add]
+      exact hmono _ _ (leadingCoeff_ne_zero.mpr hp)
+    · have hlt : p.eraseLead.natDegree < p.natDegree := by
+        rcases p.eraseLead_natDegree_lt_or_eraseLead_eq_zero with h | h
+        · exact h
+        · exact absurd h he
+      have hIH : v.ord (φ p.eraseLead) = p.eraseLead.natDegree * v.ord (φ X) :=
+        ih _ hlt rfl he
+      have hlead : v.ord (φ (C p.leadingCoeff * X ^ p.natDegree))
+          = p.natDegree * v.ord (φ X) := hmono _ _ (leadingCoeff_ne_zero.mpr hp)
+      have hcast : (p.eraseLead.natDegree : ℤ) < (p.natDegree : ℤ) := by exact_mod_cast hlt
+      have hne : v.ord (φ p.eraseLead) ≠ v.ord (φ (C p.leadingCoeff * X ^ p.natDegree)) := by
+        rw [hIH, hlead]
+        nlinarith
+      have he2 : φ (C p.leadingCoeff * X ^ p.natDegree) ≠ 0 := fun hcon =>
+        mul_ne_zero (C_ne_zero.mpr (leadingCoeff_ne_zero.mpr hp)) (pow_ne_zero _ X_ne_zero)
+          (hφinj (hcon.trans (_root_.map_zero φ).symm))
+      have he1 : φ p.eraseLead ≠ 0 := fun hcon => he (hφinj (hcon.trans (_root_.map_zero φ).symm))
+      conv_lhs => rw [← p.eraseLead_add_C_mul_X_pow]
+      rw [map_add, v.ord_add_eq_min he1 he2 hne, hIH, hlead]
+      have h1 : (p.natDegree : ℤ) * v.ord (φ X) ≤ (p.eraseLead.natDegree : ℤ) * v.ord (φ X) := by
+        nlinarith
+      omega
+
+private theorem _root_.AlgebraicCurve.Place.le_ord_ringHom_of_natDegree_le {φ : K[X] →+* F}
+    (hφinj : Function.Injective φ)
+    (hφC : ∀ c : K, φ (C c) = algebraMap K F c) (hz : v.ord (φ X) < 0)
+    {p : K[X]} {d : ℕ} (hd : p.natDegree ≤ d) :
+    (d : ℤ) * v.ord (φ X) ≤ v.ord (φ p) := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp only [_root_.map_zero, Place.ord_zero]
+    nlinarith [hz]
+  rw [v.ord_ringHom_eq_natDegree_mul hφinj hφC hz hp]
+  have h1 : (p.natDegree : ℤ) ≤ (d : ℤ) := by exact_mod_cast hd
+  nlinarith
+
+end Place
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+namespace Affine
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_a3e19da5.WeierstrassCurv\
+  e.Affine.CoordinateRing AlgebraicCurve \
+  P2MW.S_OVERLONG_a3e19da5.AlgebraicCurve"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+def polyToFunctionField (W : Affine F) : F[X] →+* W.FunctionField :=
+  (algebraMap W.CoordinateRing W.FunctionField).comp (algebraMap F[X] W.CoordinateRing)
+
+theorem polyToFunctionField_apply (p : F[X]) :
+    polyToFunctionField W p
+      = algebraMap W.CoordinateRing W.FunctionField (algebraMap F[X] W.CoordinateRing p) := rfl
+
+theorem algebraMap_smul_one (p : F[X]) :
+    algebraMap W.CoordinateRing W.FunctionField (p • (1 : W.CoordinateRing))
+      = polyToFunctionField W p := by
+  rw [polyToFunctionField_apply, smul, mul_one]
+  rfl
+
+theorem polyToFunctionField_injective : Function.Injective (polyToFunctionField W) := by
+  intro p q h
+  rw [polyToFunctionField_apply, polyToFunctionField_apply] at h
+  have h2 := IsFractionRing.injective W.CoordinateRing W.FunctionField h
+  have h0 : (p - q) • (1 : W.CoordinateRing) + (0 : F[X]) • CoordinateRing.mk W Y = 0 := by
+    rw [zero_smul, add_zero, sub_smul, ← Algebra.algebraMap_eq_smul_one,
+      ← Algebra.algebraMap_eq_smul_one, h2, sub_self]
+  exact sub_eq_zero.mp (smul_basis_eq_zero h0).1
+
+theorem polyToFunctionField_C (c : F) :
+    polyToFunctionField W (C c) = algebraMap F W.FunctionField c := by
+  rw [polyToFunctionField_apply,
+    show algebraMap F[X] W.CoordinateRing (C c) = algebraMap F W.CoordinateRing c from
+      (IsScalarTower.algebraMap_apply F F[X] W.CoordinateRing c).symm]
+  exact (IsScalarTower.algebraMap_apply F W.CoordinateRing W.FunctionField c).symm
+
+theorem polyToFunctionField_ne_zero {p : F[X]} (hp : p ≠ 0) :
+    polyToFunctionField W p ≠ 0 := by
+  intro h
+  exact hp (polyToFunctionField_injective (by simpa using h))
+
+theorem algebraMap_smul_basis (p q : F[X]) :
+    algebraMap W.CoordinateRing W.FunctionField
+        (p • (1 : W.CoordinateRing) + q • CoordinateRing.mk W Y)
+      = polyToFunctionField W p + polyToFunctionField W q
+          * algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) := by
+  rw [map_add, algebraMap_smul_one, smul, map_mul, polyToFunctionField_apply]
+  rfl
+
+theorem Y_image_ne_zero :
+    algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) ≠ 0 := by
+  have h1 : (CoordinateRing.mk W Y) ≠ 0 := by
+    have h2 := YClass_ne_zero (W' := W) 0
+    simpa [YClass] using h2
+  exact (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr h1
+
+theorem natDegree_norm_smul_basis_left {p : F[X]} (hp : p ≠ 0) :
+    ((Algebra.norm F[X] (p • (1 : W.CoordinateRing)
+        + (0 : F[X]) • CoordinateRing.mk W Y)).natDegree : ℤ) = 2 * p.natDegree := by
+  have hdeg := degree_norm_smul_basis (W' := W) p 0
+  rw [Polynomial.degree_zero, show (2 : ℕ) • (⊥ : WithBot ℕ) + 3 = ⊥ by
+      rw [two_nsmul]; simp, max_eq_left bot_le, Polynomial.degree_eq_natDegree hp, two_nsmul,
+    ← Nat.cast_add] at hdeg
+  rw [Polynomial.natDegree_eq_of_degree_eq_some hdeg]
+  push_cast
+  ring
+
+theorem natDegree_norm_smul_basis_right {q : F[X]} (hq : q ≠ 0) :
+    ((Algebra.norm F[X] ((0 : F[X]) • (1 : W.CoordinateRing)
+        + q • CoordinateRing.mk W Y)).natDegree : ℤ) = 2 * q.natDegree + 3 := by
+  have hdeg := degree_norm_smul_basis (W' := W) 0 q
+  rw [Polynomial.degree_zero, show (2 : ℕ) • (⊥ : WithBot ℕ) = ⊥ by
+      rw [two_nsmul]; simp, max_eq_right bot_le, Polynomial.degree_eq_natDegree hq, two_nsmul,
+    ← Nat.cast_add, show ((3 : WithBot ℕ)) = ((3 : ℕ) : WithBot ℕ) from rfl,
+    ← Nat.cast_add] at hdeg
+  rw [Polynomial.natDegree_eq_of_degree_eq_some hdeg]
+  push_cast
+  ring
+
+theorem natDegree_norm_smul_basis_max {p q : F[X]} (hp : p ≠ 0) (hq : q ≠ 0) :
+    ((Algebra.norm F[X] (p • (1 : W.CoordinateRing)
+        + q • CoordinateRing.mk W Y)).natDegree : ℤ)
+      = max (2 * (p.natDegree : ℤ)) (2 * (q.natDegree : ℤ) + 3) := by
+  have hdeg := degree_norm_smul_basis (W' := W) p q
+  rw [Polynomial.degree_eq_natDegree hp, Polynomial.degree_eq_natDegree hq, two_nsmul,
+    two_nsmul, ← Nat.cast_add, ← Nat.cast_add,
+    show ((3 : WithBot ℕ)) = ((3 : ℕ) : WithBot ℕ) from rfl, ← Nat.cast_add] at hdeg
+  rcases le_total (q.natDegree + q.natDegree + 3) (p.natDegree + p.natDegree) with h | h
+  · rw [max_eq_left (by exact_mod_cast h)] at hdeg
+    rw [Polynomial.natDegree_eq_of_degree_eq_some hdeg]
+    push_cast
+    omega
+  · rw [max_eq_right (by exact_mod_cast h)] at hdeg
+    rw [Polynomial.natDegree_eq_of_degree_eq_some hdeg]
+    push_cast
+    omega
+
+variable (v : AlgebraicCurve.Place F W.FunctionField)
+
+theorem isFinitePlace_of_mem
+    (hx : polyToFunctionField W X ∈ v.toValuationSubring) : IsFinitePlace v := by
+  have hpoly : ∀ p : F[X], polyToFunctionField W p ∈ v.toValuationSubring := by
+    intro p
+    induction p using Polynomial.induction_on' with
+    | add f g hf hg => rw [map_add]; exact add_mem hf hg
+    | monomial n c =>
+        rw [← C_mul_X_pow_eq_monomial, map_mul, map_pow]
+        refine mul_mem ?_ (pow_mem hx n)
+        rw [polyToFunctionField_C]
+        exact v.algebraMap_mem' c
+  set η := algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) with hηdef
+  set c₁ : F[X] := C W.a₁ * X + C W.a₃ with hc₁def
+  set cb : F[X] := X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ with hcbdef
+  have hrel : η * η = polyToFunctionField W cb - polyToFunctionField W c₁ * η := by
+    have h1 := smul_basis_mul_Y (W' := W) 0 1
+    rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at h1
+    have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) h1
+    rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+    exact h2
+  have hy : η ∈ v.toValuationSubring := by
+    refine v.mem_of_eval_monic_eq_zero (P := Polynomial.X ^ 2
+      + (Polynomial.C (polyToFunctionField W c₁) * Polynomial.X
+        - Polynomial.C (polyToFunctionField W cb))) ?_ ?_ (x := η) ?_
+    · refine Polynomial.monic_X_pow_add (n := 2) ?_
+      rw [sub_eq_add_neg, ← Polynomial.C_neg]
+      refine lt_of_le_of_lt Polynomial.degree_linear_le ?_
+      exact_mod_cast Nat.one_lt_two
+    · intro i
+      rw [show (Polynomial.C (polyToFunctionField W c₁) * Polynomial.X : Polynomial _)
+          = Polynomial.C (polyToFunctionField W c₁) * Polynomial.X ^ 1 by ring]
+      simp only [Polynomial.coeff_add, Polynomial.coeff_sub, Polynomial.coeff_X_pow,
+        Polynomial.coeff_C_mul, Polynomial.coeff_C]
+      refine add_mem ?_ (sub_mem ?_ ?_)
+      · split <;> simp [v.toValuationSubring.one_mem, v.toValuationSubring.zero_mem]
+      · split
+        · rw [mul_one]; exact hpoly _
+        · rw [mul_zero]; exact v.toValuationSubring.zero_mem
+      · split
+        · exact hpoly _
+        · exact v.toValuationSubring.zero_mem
+    · simp only [Polynomial.eval_add, Polynomial.eval_sub, Polynomial.eval_pow,
+        Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_X]
+      rw [sq]
+      linear_combination hrel
+  intro r
+  obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq r
+  rw [algebraMap_smul_basis]
+  exact add_mem (hpoly p) (mul_mem (hpoly q) hy)
+
+theorem ord_X_neg_of_not_isFinitePlace (hv : ¬ IsFinitePlace v) :
+    v.ord (polyToFunctionField W X) < 0 := by
+  by_contra hcon
+  push Not at hcon
+  exact hv (isFinitePlace_of_mem v
+    (v.mem_of_ord_nonneg (polyToFunctionField_ne_zero Polynomial.X_ne_zero) hcon))
+
+theorem two_mul_ord_Y_eq_three_mul_ord_X (hv : ¬ IsFinitePlace v) :
+    2 * v.ord (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y))
+      = 3 * v.ord (polyToFunctionField W X) := by
+  set η := algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) with hηdef
+  have hA : v.ord (polyToFunctionField W X) < 0 := ord_X_neg_of_not_isFinitePlace v hv
+  have hη0 : η ≠ 0 := Y_image_ne_zero
+  set c₁ : F[X] := C W.a₁ * X + C W.a₃ with hc₁def
+  set cb : F[X] := X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ with hcbdef
+  have hrel : η * η = polyToFunctionField W cb - polyToFunctionField W c₁ * η := by
+    have h1 := smul_basis_mul_Y (W' := W) 0 1
+    rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at h1
+    have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) h1
+    rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+    exact h2
+  have hrelL : (η + polyToFunctionField W c₁) * η = polyToFunctionField W cb := by
+    rw [add_mul]
+    linear_combination hrel
+  have hcbdeg : cb.natDegree = 3 := by
+    rw [hcbdef, ← one_mul (X ^ 3 : F[X]), ← C_1]
+    exact Polynomial.natDegree_cubic one_ne_zero
+  have hcb0 : cb ≠ 0 := by
+    intro h
+    rw [h, Polynomial.natDegree_zero] at hcbdeg
+    exact absurd hcbdeg (by norm_num)
+  have hcbord : v.ord (polyToFunctionField W cb) = 3 * v.ord (polyToFunctionField W X) := by
+    rw [v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA
+      hcb0, hcbdeg]
+    push_cast
+    ring
+  have hc₁ord : (1 : ℤ) * v.ord (polyToFunctionField W X)
+      ≤ v.ord (polyToFunctionField W c₁) := by
+    refine v.le_ord_ringHom_of_natDegree_le polyToFunctionField_injective polyToFunctionField_C
+      hA ?_
+    rw [hc₁def]
+    refine le_trans (Polynomial.natDegree_add_le _ _) ?_
+    simp only [Polynomial.natDegree_C, max_le_iff]
+    refine ⟨le_trans (Polynomial.natDegree_C_mul_le _ _) (by simp), by omega⟩
+  rw [one_mul] at hc₁ord
+  have hfac0 : η + polyToFunctionField W c₁ ≠ 0 := by
+    intro h
+    rw [h, zero_mul] at hrelL
+    exact polyToFunctionField_ne_zero hcb0 hrelL.symm
+  have hLHS : v.ord (η + polyToFunctionField W c₁) + v.ord η
+      = 3 * v.ord (polyToFunctionField W X) := by
+    rw [← hcbord, ← hrelL, v.ord_mul hfac0 hη0]
+  rcases eq_or_ne (polyToFunctionField W c₁) 0 with hc₁0 | hc₁0
+  · grind
+  · by_cases hBc : v.ord η = v.ord (polyToFunctionField W c₁)
+    · have hmin : min (v.ord η) (v.ord (polyToFunctionField W c₁))
+          ≤ v.ord (η + polyToFunctionField W c₁) := v.min_ord_le_ord_add' hfac0
+      grind
+    · have hsum : v.ord (η + polyToFunctionField W c₁)
+          = min (v.ord η) (v.ord (polyToFunctionField W c₁)) :=
+        v.ord_add_eq_min hη0 hc₁0 hBc
+      grind
+
+private theorem ne_arith {A B s t : ℤ} (hA : A < 0) (hY : 2 * B = 3 * A) :
+    s * A ≠ t * A + B := by
+  intro hcon
+  have h4 : (2 * s - (2 * t + 3)) * A = 0 := by linear_combination 2 * hcon + hY
+  grind [mul_eq_zero.mp h4]
+
+private theorem two_mul_min_arith {A B s t : ℤ} (hA : A < 0) (hY : 2 * B = 3 * A) :
+    2 * min (s * A) (t * A + B) = A * max (2 * s) (2 * t + 3) := by
+  rcases le_or_gt (2 * t + 3) (2 * s) with h | h
+  · rw [max_eq_left h, min_eq_left (by nlinarith)]
+    ring
+  · rw [max_eq_right h.le, min_eq_right (by nlinarith)]
+    linear_combination hY
+
+theorem two_mul_ord_eq_of_not_isFinitePlace (hv : ¬ IsFinitePlace v)
+    {f : W.CoordinateRing} (hf : f ≠ 0) :
+    2 * v.ord (algebraMap W.CoordinateRing W.FunctionField f)
+      = v.ord (polyToFunctionField W X) * ((Algebra.norm F[X] f).natDegree : ℤ) := by
+  have hA : v.ord (polyToFunctionField W X) < 0 := ord_X_neg_of_not_isFinitePlace v hv
+  have hη0 : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) ≠ 0 :=
+    Y_image_ne_zero
+  have hYord := two_mul_ord_Y_eq_three_mul_ord_X v hv
+  obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq f
+  by_cases hq : q = 0
+  · subst hq
+    have hp : p ≠ 0 := fun h => hf (by rw [h, zero_smul, zero_smul, add_zero])
+    rw [natDegree_norm_smul_basis_left hp, algebraMap_smul_basis, _root_.map_zero, zero_mul,
+      add_zero,
+      v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA hp]
+    ring
+  · by_cases hp : p = 0
+    · subst hp
+      rw [natDegree_norm_smul_basis_right hq, algebraMap_smul_basis, _root_.map_zero, zero_add,
+        v.ord_mul (polyToFunctionField_ne_zero hq) hη0,
+        v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA hq]
+      linear_combination hYord
+    · rw [natDegree_norm_smul_basis_max hp hq, algebraMap_smul_basis]
+      have hordp : v.ord (polyToFunctionField W p)
+          = (p.natDegree : ℤ) * v.ord (polyToFunctionField W X) :=
+        v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA hp
+      have hordqy : v.ord (polyToFunctionField W q
+            * algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y))
+          = (q.natDegree : ℤ) * v.ord (polyToFunctionField W X)
+            + v.ord (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)) := by
+        rw [v.ord_mul (polyToFunctionField_ne_zero hq) hη0,
+          v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA
+            hq]
+      have hne : v.ord (polyToFunctionField W p) ≠ v.ord (polyToFunctionField W q
+          * algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)) := by
+        rw [hordp, hordqy]
+        exact ne_arith hA hYord
+      have hqy0 : polyToFunctionField W q
+          * algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) ≠ 0 :=
+        mul_ne_zero (polyToFunctionField_ne_zero hq) hη0
+      rw [v.ord_add_eq_min (polyToFunctionField_ne_zero hp) hqy0 hne, hordp, hordqy]
+      exact two_mul_min_arith hA hYord
+
+theorem mem_iff_natDegree_norm_le (hv : ¬ IsFinitePlace v) {a b : W.CoordinateRing}
+    (ha : a ≠ 0) (hb : b ≠ 0) :
+    algebraMap W.CoordinateRing W.FunctionField a
+        / algebraMap W.CoordinateRing W.FunctionField b ∈ v.toValuationSubring
+      ↔ (Algebra.norm F[X] a).natDegree ≤ (Algebra.norm F[X] b).natDegree := by
+  have hA : v.ord (polyToFunctionField W X) < 0 := ord_X_neg_of_not_isFinitePlace v hv
+  have ha' : algebraMap W.CoordinateRing W.FunctionField a ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr ha
+  have hb' : algebraMap W.CoordinateRing W.FunctionField b ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr hb
+  have hdiv : algebraMap W.CoordinateRing W.FunctionField a
+      / algebraMap W.CoordinateRing W.FunctionField b ≠ 0 := div_ne_zero ha' hb'
+  rw [v.mem_iff_ord_nonneg hdiv, div_eq_mul_inv, v.ord_mul ha' (inv_ne_zero hb'), v.ord_inv]
+  have h1 := two_mul_ord_eq_of_not_isFinitePlace v hv ha
+  have h2 := two_mul_ord_eq_of_not_isFinitePlace v hv hb
+  constructor
+  · intro h
+    nlinarith
+  · intro h
+    have h3 : ((Algebra.norm F[X] a).natDegree : ℤ) ≤ ((Algebra.norm F[X] b).natDegree : ℤ) := by
+      exact_mod_cast h
+    nlinarith
+
+theorem eq_of_not_isFinitePlace_of_not_isFinitePlace
+    {v w : AlgebraicCurve.Place F W.FunctionField}
+    (hv : ¬ IsFinitePlace v) (hw : ¬ IsFinitePlace w) : v = w := by
+  refine AlgebraicCurve.Place.ext ?_
+  ext z
+  rcases eq_or_ne z 0 with rfl | hz
+  · simp [v.toValuationSubring.zero_mem, w.toValuationSubring.zero_mem]
+  obtain ⟨a, b, hb, hzab⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb
+  have ha0 : a ≠ 0 := by
+    intro h
+    rw [h, _root_.map_zero, zero_div] at hzab
+    exact hz hzab.symm
+  rw [← hzab]
+  rw [mem_iff_natDegree_norm_le v hv ha0 hb0, mem_iff_natDegree_norm_le w hw ha0 hb0]
+
+theorem exists_smul_sub_natDegree_norm_lt {a b : W.CoordinateRing} (hb : b ≠ 0)
+    (hab : (Algebra.norm F[X] a).natDegree ≤ (Algebra.norm F[X] b).natDegree) :
+    ∃ c : F, a - c • b = 0 ∨
+      (Algebra.norm F[X] (a - c • b)).natDegree < (Algebra.norm F[X] b).natDegree := by
+  set n := (Algebra.norm F[X] b).natDegree with hndef
+  have hbn : b ∈ RRSpace W n :=
+    mem_RRSpace_iff_degree_norm_le.mpr (Polynomial.natDegree_le_iff_degree_le.mp le_rfl)
+  have han : a ∈ RRSpace W n :=
+    mem_RRSpace_iff_degree_norm_le.mpr (Polynomial.natDegree_le_iff_degree_le.mp hab)
+  rcases Nat.eq_zero_or_pos n with hn0 | hnpos
+  · rw [hn0] at hbn han
+    rw [RRSpace_zero] at hbn han
+    obtain ⟨α, hα⟩ := Submodule.mem_one.mp han
+    obtain ⟨β, hβ⟩ := Submodule.mem_one.mp hbn
+    have hβ0 : β ≠ 0 := by grind
+    refine ⟨α / β, Or.inl ?_⟩
+    rw [← hα, ← hβ, Algebra.smul_def, ← map_mul, div_mul_cancel₀ _ hβ0, sub_self]
+  rcases eq_or_ne n 1 with hn1 | hn1
+  · exact absurd (hndef.symm.trans hn1) (natDegree_norm_ne_one b)
+  have hn2 : 2 ≤ n := by omega
+  have hn1' : 1 ≤ n - 1 := by omega
+  have : FiniteDimensional F (RRSpace W n) :=
+    Module.Finite.of_basis (RRSpace.finBasis W n (by omega))
+  have hbnot : b ∉ RRSpace W (n - 1) := by
+    intro hcon
+    rw [mem_RRSpace_iff_degree_norm_le, ← Polynomial.natDegree_le_iff_degree_le] at hcon
+    omega
+  have hsup : RRSpace W (n - 1) ⊔ Submodule.span F {b} = RRSpace W n := by
+    have hle : RRSpace W (n - 1) ⊔ Submodule.span F {b} ≤ RRSpace W n := by
+      refine sup_le (RRSpace_mono (by omega)) ?_
+      rw [Submodule.span_le, Set.singleton_subset_iff]
+      exact hbn
+    refine Submodule.eq_of_le_of_finrank_le hle ?_
+    have hlt : RRSpace W (n - 1) < RRSpace W (n - 1) ⊔ Submodule.span F {b} := by
+      refine lt_of_le_of_ne le_sup_left ?_
+      intro hcon
+      refine hbnot ?_
+      rw [hcon]
+      exact (le_sup_right (a := RRSpace W (n - 1))) (Submodule.mem_span_singleton_self b)
+    have : FiniteDimensional F (RRSpace W (n - 1) ⊔ Submodule.span F {b} : Submodule F _) :=
+      Submodule.finiteDimensional_of_le hle
+    have h1 := Submodule.finrank_lt_finrank_of_lt hlt
+    rw [RRSpace.finrank_eq (n - 1) hn1'] at h1
+    rw [RRSpace.finrank_eq n (by omega)]
+    omega
+  obtain ⟨ℓ, hℓ, z, hz, hsum⟩ := Submodule.mem_sup.mp (hsup ▸ han)
+  obtain ⟨c, rfl⟩ := Submodule.mem_span_singleton.mp hz
+  refine ⟨c, ?_⟩
+  have hldef : a - c • b = ℓ := by rw [← hsum]; ring
+  rcases eq_or_ne (a - c • b) 0 with h | h
+  · exact Or.inl h
+  · refine Or.inr ?_
+    have hc : (Algebra.norm F[X] (a - c • b)).natDegree ≤ n - 1 := by
+      rw [Polynomial.natDegree_le_iff_degree_le, ← mem_RRSpace_iff_degree_norm_le]
+      exact hldef ▸ hℓ
+    omega
+
+theorem deg_eq_one_of_not_isFinitePlace (hv : ¬ IsFinitePlace v) : v.deg = 1 := by
+  have hA : v.ord (polyToFunctionField W X) < 0 := ord_X_neg_of_not_isFinitePlace v hv
+  refine AlgebraicCurve.Place.deg_eq_one_of_surjective v ?_
+  intro z
+  obtain ⟨g, rfl⟩ := Ideal.Quotient.mk_surjective z
+  rcases eq_or_ne (g : W.FunctionField) 0 with hg0 | hg0
+  · refine ⟨0, ?_⟩
+    have hgz : g = 0 := Subtype.ext hg0
+    subst hgz
+    exact (_root_.map_zero _).trans (_root_.map_zero _).symm
+  obtain ⟨a, b, hb, hzab⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing)
+    (g : W.FunctionField)
+  have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb
+  have hbL0 : algebraMap W.CoordinateRing W.FunctionField b ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr hb0
+  have ha0 : a ≠ 0 := by
+    intro h
+    rw [h, _root_.map_zero, zero_div] at hzab
+    exact hg0 hzab.symm
+  have hmem : (g : W.FunctionField) ∈ v.toValuationSubring := g.2
+  rw [← hzab] at hmem
+  have hab := (mem_iff_natDegree_norm_le v hv ha0 hb0).mp hmem
+  obtain ⟨c, hc⟩ := exists_smul_sub_natDegree_norm_lt hb0 hab
+  refine ⟨c, ?_⟩
+  rw [IsScalarTower.algebraMap_apply F v.toValuationSubring v.ResidueField,
+    IsLocalRing.ResidueField.algebraMap_eq]
+  refine (Ideal.Quotient.eq (I := IsLocalRing.maximalIdeal v.toValuationSubring)).mpr ?_
+  have hcoe : ((algebraMap F v.toValuationSubring c : v.toValuationSubring) : W.FunctionField)
+      = algebraMap F W.FunctionField c := v.coe_algebraMap c
+  have hdiff : ((algebraMap F v.toValuationSubring c - g : v.toValuationSubring)
+      : W.FunctionField) = algebraMap W.CoordinateRing W.FunctionField (c • b - a)
+        / algebraMap W.CoordinateRing W.FunctionField b := by
+    have h0 : ((algebraMap F v.toValuationSubring c - g : v.toValuationSubring)
+        : W.FunctionField) = algebraMap F W.FunctionField c
+          - algebraMap W.CoordinateRing W.FunctionField a
+            / algebraMap W.CoordinateRing W.FunctionField b := by
+      push_cast
+      rw [hcoe, hzab]
+    rw [h0, map_sub, eq_div_iff hbL0, sub_mul, div_mul_cancel₀ _ hbL0, Algebra.smul_def,
+      map_mul, ← IsScalarTower.algebraMap_apply F W.CoordinateRing W.FunctionField]
+  rcases eq_or_ne (a - c • b) 0 with hzero | hzero
+  · have h1 : c • b - a = 0 := by rw [← neg_sub a (c • b), hzero, _root_.neg_zero]
+    have h2 : (algebraMap F v.toValuationSubring c - g : v.toValuationSubring)
+        = (0 : v.toValuationSubring) := by
+      ext
+      rw [hdiff, h1, _root_.map_zero, zero_div]
+      rfl
+    rw [h2]
+    exact (IsLocalRing.maximalIdeal v.toValuationSubring).zero_mem
+  · replace hc : (Algebra.norm F[X] (a - c • b)).natDegree
+        < (Algebra.norm F[X] b).natDegree := hc.resolve_left hzero
+    have hsub0 : c • b - a ≠ 0 := fun h =>
+      hzero (by rw [show a - c • b = -(c • b - a) by ring, h, _root_.neg_zero])
+    have hordswap : v.ord (algebraMap W.CoordinateRing W.FunctionField (c • b - a))
+        = v.ord (algebraMap W.CoordinateRing W.FunctionField (a - c • b)) := by
+      rw [show c • b - a = -(a - c • b) by ring, _root_.map_neg, v.ord_neg]
+    have hordpos : 0 < v.ord (((algebraMap F v.toValuationSubring c - g
+        : v.toValuationSubring)) : W.FunctionField) := by
+      rw [hdiff, div_eq_mul_inv, v.ord_mul ((map_ne_zero_iff _
+        (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr hsub0)
+        (inv_ne_zero hbL0), v.ord_inv, hordswap]
+      have h1 := two_mul_ord_eq_of_not_isFinitePlace v hv hzero
+      have h2 := two_mul_ord_eq_of_not_isFinitePlace v hv hb0
+      have h3 : ((Algebra.norm F[X] (a - c • b)).natDegree : ℤ)
+          < ((Algebra.norm F[X] b).natDegree : ℤ) := by exact_mod_cast hc
+      nlinarith
+    rcases eq_or_ne ((algebraMap F v.toValuationSubring c - g : v.toValuationSubring))
+        (0 : v.toValuationSubring) with hzero' | hzero'
+    · rw [hzero']
+      exact (IsLocalRing.maximalIdeal v.toValuationSubring).zero_mem
+    · have hzero'' : ((algebraMap F v.toValuationSubring c - g : v.toValuationSubring)
+          : W.FunctionField) ≠ 0 := fun h => hzero' (Subtype.ext h)
+      exact (v.mem_maximalIdeal_iff_ord_pos hzero''
+        (algebraMap F v.toValuationSubring c - g).2).mpr hordpos
+
+theorem exists_equation [IsAlgClosed F] (W : Affine F) (x₀ : F) :
+    ∃ y₀ : F, W.Equation x₀ y₀ := by
+  set P : F[X] := Polynomial.X ^ 2 + Polynomial.C (W.a₁ * x₀ + W.a₃) * Polynomial.X
+    - Polynomial.C (x₀ ^ 3 + W.a₂ * x₀ ^ 2 + W.a₄ * x₀ + W.a₆) with hPdef
+  have hPdeg : P.degree ≠ 0 := by
+    have hcoeff : P.coeff 2 = 1 := by
+      rw [hPdef]
+      simp only [Polynomial.coeff_sub, Polynomial.coeff_add, Polynomial.coeff_X_pow,
+        Polynomial.coeff_C_mul, Polynomial.coeff_X, Polynomial.coeff_C]
+      norm_num
+    intro hcon
+    have h2 : P.coeff 2 = 0 := by
+      refine Polynomial.coeff_eq_zero_of_degree_lt ?_
+      rw [hcon]
+      norm_num
+    rw [hcoeff] at h2
+    exact one_ne_zero h2
+  obtain ⟨y₀, hy₀⟩ := IsAlgClosed.exists_root P hPdeg
+  refine ⟨y₀, ?_⟩
+  rw [equation_iff]
+  have h3 : P.eval y₀ = 0 := hy₀
+  rw [hPdef] at h3
+  simp only [Polynomial.eval_sub, Polynomial.eval_add, Polynomial.eval_pow,
+    Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_X] at h3
+  linear_combination h3
+
+theorem exists_not_isFinitePlace [IsAlgClosed F] [IsDedekindDomain W.CoordinateRing]
+    [AlgebraicCurve.HasPrincipalDivisors F W.FunctionField] :
+    ∃ v : AlgebraicCurve.Place F W.FunctionField, ¬ IsFinitePlace v := by
+  by_contra hcon
+  push Not at hcon
+  obtain ⟨y₀, hy₀⟩ := exists_equation W 0
+  set v₀ : AlgebraicCurve.Place F W.FunctionField := placeOfEquation hy₀ with hv₀def
+  set r : W.CoordinateRing := CoordinateRing.mk W (C X) with hrdef
+  have hr0 : r ≠ 0 := by
+    rw [hrdef]
+    have h1 := XClass_ne_zero (W' := W) (0 : F)
+    rw [XClass] at h1
+    simpa using h1
+  have hrL0 : algebraMap W.CoordinateRing W.FunctionField r ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr hr0
+  have hrmem : r ∈ (heightOneSpectrumOfEquation hy₀).asIdeal := by
+    rw [heightOneSpectrumOfEquation_asIdeal]
+    have h1 : XClass W (0 : F) ∈ XYIdeal W (0 : F) (C y₀) :=
+      Ideal.subset_span (Set.mem_insert _ _)
+    have h2 : XClass W (0 : F) = r := by
+      rw [XClass, hrdef]
+      norm_num
+    exact h2 ▸ h1
+  have hordpos : 0 < v₀.ord (algebraMap W.CoordinateRing W.FunctionField r) := by
+    have h1 : v₀.ord (algebraMap W.CoordinateRing W.FunctionField r) ≠ 0 :=
+      (AlgebraicCurve.Place.ord_ofHeightOneSpectrum_ne_zero_iff
+        (heightOneSpectrumOfEquation hy₀) hr0).mpr hrmem
+    have h2 : 0 ≤ v₀.ord (algebraMap W.CoordinateRing W.FunctionField r) :=
+      v₀.ord_nonneg_of_mem (isFinitePlace_placeOfEquation hy₀ r)
+    omega
+  obtain ⟨D, hD, hDdeg⟩ := AlgebraicCurve.HasPrincipalDivisors.exists_divisor
+    (K := F) (algebraMap W.CoordinateRing W.FunctionField r) hrL0
+  have hDnonneg : ∀ w : AlgebraicCurve.Place F W.FunctionField, 0 ≤ D w := by
+    intro w
+    rw [hD w]
+    exact w.ord_nonneg_of_mem (hcon w r)
+  have hDpos : 0 < AlgebraicCurve.Divisor.degree D := by
+    have hsum : AlgebraicCurve.Divisor.degree D = ∑ w ∈ D.support, D w * (w.deg : ℤ) := by
+      simp only [AlgebraicCurve.Divisor.degree, Finsupp.liftAddHom_apply,
+        AddMonoidHom.mulRight_apply, Finsupp.sum]
+    rw [hsum]
+    refine Finset.sum_pos' (fun w _ => mul_nonneg (hDnonneg w) (Int.natCast_nonneg _)) ?_
+    refine ⟨v₀, ?_, ?_⟩
+    · rw [Finsupp.mem_support_iff, hD v₀]
+      omega
+    · rw [hD v₀, deg_placeOfEquation hy₀]
+      omega
+  omega
+
+variable (W) in
+scoped instance instInfinitePlace [IsAlgClosed F] [IsDedekindDomain W.CoordinateRing]
+    [AlgebraicCurve.HasPrincipalDivisors F W.FunctionField] : InfinitePlace W where
+  place := (exists_not_isFinitePlace (W := W)).choose
+  not_isFinitePlace := (exists_not_isFinitePlace (W := W)).choose_spec
+  deg_eq_one := deg_eq_one_of_not_isFinitePlace _ (exists_not_isFinitePlace (W := W)).choose_spec
+  eq_of_not_isFinitePlace _v hv :=
+    eq_of_not_isFinitePlace_of_not_isFinitePlace hv
+      (exists_not_isFinitePlace (W := W)).choose_spec
+
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+noncomputable section
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_OVERLONG_a3e19da5.AlgebraicCurve \
+  IsDedekindDomain FractionalIdeal \
+  P2MW.S_OVERLONG_a3e19da5.FractionalIdea\
+  l WithZero Polynomial"
+
+open scoped nonZeroDivisors Polynomial.Bivariate
+
+namespace FractionalIdeal
+p2m_open "FractionalIdeal"
+
+variable {R : Type*} [CommRing R] [IsDedekindDomain R]
+variable {L : Type*} [Field L] [Algebra R L] [IsFractionRing R L]
+
+theorem count_spanSingleton (w : HeightOneSpectrum R) {f : L} (hf : f ≠ 0) :
+    count L w (spanSingleton R⁰ f) = -log (w.valuation L f) := by
+  classical
+  obtain ⟨n, d, rfl⟩ := IsLocalization.exists_mk'_eq R⁰ f
+  have hn : n ≠ 0 := by
+    rintro rfl
+    exact hf (IsLocalization.mk'_zero (M := R⁰) (S := L) d)
+  have hd : (d : R) ≠ 0 := nonZeroDivisors.ne_zero d.2
+  have hI : spanSingleton R⁰ (IsLocalization.mk' L n d) =
+      spanSingleton R⁰ ((algebraMap R L) (d : R))⁻¹ * ↑(Ideal.span {n} : Ideal R) := by
+    rw [coeIdeal_span_singleton, FractionalIdeal.spanSingleton_mul_spanSingleton]
+    congr 1
+    rw [IsFractionRing.mk'_eq_div, div_eq_mul_inv, mul_comm]
+  rw [count_well_defined L w (spanSingleton_ne_zero_iff.mpr hf) hI]
+  rw [HeightOneSpectrum.valuation_of_mk',
+    log_div (w.intValuation_ne_zero n hn) (w.intValuation_ne_zero (d : R) hd),
+    w.intValuation_if_neg hn, w.intValuation_if_neg hd, log_exp, log_exp]
+  ring
+
+theorem finprod_heightOneSpectrum_count {I : FractionalIdeal R⁰ L} (hI : I ≠ 0) :
+    (∏ᶠ w : HeightOneSpectrum R, (w.asIdeal : FractionalIdeal R⁰ L) ^ count L w I) = I := by
+  classical
+  obtain ⟨a, J, ha, haJ⟩ := exists_eq_spanSingleton_mul I
+  calc (∏ᶠ w : HeightOneSpectrum R, (w.asIdeal : FractionalIdeal R⁰ L) ^ count L w I)
+      = ∏ᶠ w : HeightOneSpectrum R, (w.asIdeal : FractionalIdeal R⁰ L) ^
+          ((Associates.mk w.asIdeal).count (Associates.mk J).factors -
+            (Associates.mk w.asIdeal).count (Associates.mk (Ideal.span {a})).factors : ℤ) :=
+        finprod_congr fun w => by rw [count_well_defined L w hI haJ]
+    _ = I := finprod_heightOneSpectrum_factorization hI haJ
+
+theorem eq_of_count_eq {I J : FractionalIdeal R⁰ L} (hI : I ≠ 0) (hJ : J ≠ 0)
+    (h : ∀ w : HeightOneSpectrum R, count L w I = count L w J) : I = J := by
+  rw [← finprod_heightOneSpectrum_count hI, ← finprod_heightOneSpectrum_count hJ]
+  exact finprod_congr fun w => by rw [h w]
+
+end FractionalIdeal
+
+namespace AlgebraicCurve
+namespace Place
+p2m_open "AlgebraicCurve.Place AlgebraicCurve"
+
+variable {K : Type*} [Field K]
+variable {R : Type*} [CommRing R] [IsDedekindDomain R]
+variable {L : Type*} [Field L] [Algebra R L] [IsFractionRing R L]
+variable [Algebra K R] [Algebra K L] [IsScalarTower K R L]
+
+theorem ord_ofHeightOneSpectrum_eq_neg_log (w : HeightOneSpectrum R) {f : L} (hf : f ≠ 0) :
+    (ofHeightOneSpectrum (K := K) w).ord f = -log (w.valuation L f) := by
+  obtain ⟨π, hπ⟩ := w.intValuation_exists_uniformizer
+  have hval : w.valuation L (algebraMap R L π) = exp (-1 : ℤ) := by
+    rw [w.valuation_of_algebraMap]
+    exact hπ
+  exact (ofHeightOneSpectrum (K := K) w).ord_eq_neg_log_of_valuationSubring_eq
+    (w.valuation L) rfl hval hf
+
+theorem ord_ofHeightOneSpectrum_eq_count (w : HeightOneSpectrum R) {f : L} (hf : f ≠ 0) :
+    (ofHeightOneSpectrum (K := K) w).ord f
+      = FractionalIdeal.count L w (FractionalIdeal.spanSingleton R⁰ f) := by
+  rw [ord_ofHeightOneSpectrum_eq_neg_log w hf, FractionalIdeal.count_spanSingleton w hf]
+
+end Place
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+namespace Affine
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] {W : Affine F}
+variable [IsAlgClosed F] [W.IsElliptic] [InfinitePlace W]
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_a3e19da5.WeierstrassCurv\
+  e.Affine.CoordinateRing AlgebraicCurve \
+  P2MW.S_OVERLONG_a3e19da5.AlgebraicCurve"
+
+omit [DecidableEq F] [InfinitePlace W] in
+theorem isFinitePlace_ofHeightOneSpectrum (w : HeightOneSpectrum W.CoordinateRing) :
+    IsFinitePlace (AlgebraicCurve.Place.ofHeightOneSpectrum (F := W.FunctionField) w) :=
+  w.valuation_le_one
+
+omit [DecidableEq F] in
+theorem infinitePlace_ne_ofHeightOneSpectrum (w : HeightOneSpectrum W.CoordinateRing) :
+    (InfinitePlace.place : AlgebraicCurve.Place F W.FunctionField)
+      ≠ AlgebraicCurve.Place.ofHeightOneSpectrum (K := F) w := fun h =>
+  InfinitePlace.not_isFinitePlace (W := W) (h ▸ isFinitePlace_ofHeightOneSpectrum w)
+
+def unitIdealOfPoint : W.Point → (FractionalIdeal W.CoordinateRing⁰ W.FunctionField)ˣ
+  | .zero => 1
+  | .some _ _ h => CoordinateRing.XYIdeal' h
+
+omit [DecidableEq F] [InfinitePlace W] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+@[scoped simp]
+theorem unitIdealOfPoint_zero : unitIdealOfPoint (.zero : W.Point) = 1 := rfl
+
+omit [DecidableEq F] [InfinitePlace W] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+@[scoped simp]
+theorem unitIdealOfPoint_some {x y : F} (h : W.Nonsingular x y) :
+    unitIdealOfPoint (.some x y h) = CoordinateRing.XYIdeal' h := rfl
+
+omit [InfinitePlace W] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem classGroup_mk_unitIdealOfPoint (P : W.Point) :
+    ClassGroup.mk (K := W.FunctionField) (unitIdealOfPoint P) = Additive.toMul (Point.toClass P) :=
+      by
+  cases P with
+  | zero => exact map_one _
+  | some x y h => rfl
+
+def unitIdealOfDivisor (D : AlgebraicCurve.Divisor F W.FunctionField) :
+    (FractionalIdeal W.CoordinateRing⁰ W.FunctionField)ˣ :=
+  D.prod fun v n => unitIdealOfPoint (geomPointEquivPlace.symm v) ^ n
+
+omit [DecidableEq F] in
+@[scoped simp]
+theorem unitIdealOfDivisor_zero :
+    unitIdealOfDivisor (0 : AlgebraicCurve.Divisor F W.FunctionField) = 1 :=
+  Finsupp.prod_zero_index
+
+omit [DecidableEq F] in
+theorem unitIdealOfDivisor_add (D E : AlgebraicCurve.Divisor F W.FunctionField) :
+    unitIdealOfDivisor (D + E) = unitIdealOfDivisor D * unitIdealOfDivisor E :=
+  Finsupp.prod_add_index' (fun _ => zpow_zero _) fun _ m n => _root_.zpow_add _ m n
+
+omit [DecidableEq F] in
+theorem unitIdealOfDivisor_single (v : AlgebraicCurve.Place F W.FunctionField) (n : ℤ) :
+    unitIdealOfDivisor (Finsupp.single v n) = unitIdealOfPoint (geomPointEquivPlace.symm v) ^ n :=
+  Finsupp.prod_single_index (zpow_zero _)
+
+theorem classGroup_mk_unitIdealOfDivisor (D : AlgebraicCurve.Divisor F W.FunctionField) :
+    ClassGroup.mk (K := W.FunctionField) (unitIdealOfDivisor D) =
+      Additive.toMul (Point.toClass (geomDivisorSum D)) := by
+  induction D using Finsupp.induction with
+  | zero =>
+      rw [unitIdealOfDivisor_zero, map_one, _root_.map_zero, _root_.map_zero]
+      rfl
+  | single_add v n E _ _ ih =>
+      rw [unitIdealOfDivisor_add, map_mul, ih, unitIdealOfDivisor_single, map_zpow,
+        classGroup_mk_unitIdealOfPoint, map_add, geomDivisorSum_single, map_add, toMul_add,
+        map_zsmul, toMul_zsmul]
+
+omit [DecidableEq F] in
+theorem count_unitIdealOfDivisor (D : AlgebraicCurve.Divisor F W.FunctionField)
+    (w : HeightOneSpectrum W.CoordinateRing) :
+    FractionalIdeal.count W.FunctionField w (unitIdealOfDivisor D : _) =
+      D (AlgebraicCurve.Place.ofHeightOneSpectrum (K := F) w) := by
+  classical
+  induction D using Finsupp.induction with
+  | zero =>
+      rw [unitIdealOfDivisor_zero, Units.val_one, FractionalIdeal.count_one]
+      rfl
+  | single_add v n E _ _ ih =>
+      rw [unitIdealOfDivisor_add, Units.val_mul,
+        FractionalIdeal.count_mul _ _ (Units.ne_zero _) (Units.ne_zero _), ih,
+        Finsupp.add_apply, unitIdealOfDivisor_single, Units.val_zpow_eq_zpow_val,
+        FractionalIdeal.count_zpow, Finsupp.single_apply]
+      congr 1
+      obtain ⟨P, rfl⟩ := geomPointEquivPlace.surjective v
+      rw [Equiv.symm_apply_apply]
+      cases P with
+      | zero =>
+          rw [unitIdealOfPoint_zero, Units.val_one, FractionalIdeal.count_one, mul_zero,
+            ite_eq_right]
+          exact infinitePlace_ne_ofHeightOneSpectrum w
+      | some x y h =>
+          rw [unitIdealOfPoint_some, CoordinateRing.XYIdeal'_eq,
+            show (CoordinateRing.XYIdeal W x (Polynomial.C y) :
+                FractionalIdeal W.CoordinateRing⁰ W.FunctionField)
+              = ((heightOneSpectrumOfEquation h.left).asIdeal :
+                FractionalIdeal W.CoordinateRing⁰ W.FunctionField) from rfl,
+            FractionalIdeal.count_maximal]
+          simp only [geomPointEquivPlace_apply, geomPlaceOfPoint_some, placeOfEquation,
+            (AlgebraicCurve.Place.ofHeightOneSpectrum_injective
+              (K := F) (R := W.CoordinateRing) (F := W.FunctionField)).eq_iff]
+          split_ifs <;> ring
+
+theorem geomDivisorSum_eq_zero_of_isPrincipal' {D : AlgebraicCurve.Divisor F W.FunctionField}
+    (hD : Divisor.IsPrincipal D) : geomDivisorSum D = 0 := by
+  obtain ⟨f, hf, hDf⟩ := hD
+  have key : (unitIdealOfDivisor D : FractionalIdeal W.CoordinateRing⁰ W.FunctionField)
+      = FractionalIdeal.spanSingleton W.CoordinateRing⁰ f :=
+    FractionalIdeal.eq_of_count_eq (Units.ne_zero _)
+      (FractionalIdeal.spanSingleton_ne_zero_iff.mpr hf) fun w => by
+        rw [count_unitIdealOfDivisor, hDf,
+          AlgebraicCurve.Place.ord_ofHeightOneSpectrum_eq_count w hf]
+  have hcls : ClassGroup.mk (K := W.FunctionField) (unitIdealOfDivisor D) = 1 :=
+    ClassGroup.mk_eq_one_iff.mpr ((FractionalIdeal.isPrincipal_iff _).mpr ⟨f, key⟩)
+  apply Point.toClass_injective
+  rw [_root_.map_zero]
+  rw [classGroup_mk_unitIdealOfDivisor] at hcls
+  exact Additive.toMul.injective hcls
+
+theorem isPrincipal_of_geomDivisorSum_eq_zero' [HasPrincipalDivisors F W.FunctionField]
+    {D : AlgebraicCurve.Divisor F W.FunctionField} (h0 : Divisor.degree D = 0)
+    (hD : geomDivisorSum D = 0) : Divisor.IsPrincipal D := by
+  classical
+  have hcls : ClassGroup.mk (K := W.FunctionField) (unitIdealOfDivisor D) = 1 := by
+    rw [classGroup_mk_unitIdealOfDivisor, hD, _root_.map_zero]
+    rfl
+  obtain ⟨f, hf⟩ := (FractionalIdeal.isPrincipal_iff _).mp (ClassGroup.mk_eq_one_iff.mp hcls)
+  have hf0 : f ≠ 0 := by
+    rintro rfl
+    rw [FractionalIdeal.spanSingleton_zero] at hf
+    exact Units.ne_zero (unitIdealOfDivisor D) hf
+  have hfin : ∀ w : HeightOneSpectrum W.CoordinateRing,
+      D (AlgebraicCurve.Place.ofHeightOneSpectrum (K := F) w)
+        = (AlgebraicCurve.Place.ofHeightOneSpectrum (K := F) w).ord f := by
+    intro w
+    rw [← count_unitIdealOfDivisor, hf,
+      AlgebraicCurve.Place.ord_ofHeightOneSpectrum_eq_count w hf0]
+  obtain ⟨Df, hDf, hDf0⟩ := HasPrincipalDivisors.exists_divisor (K := F) f hf0
+  have hsub : D - Df = Finsupp.single (InfinitePlace.place :
+      AlgebraicCurve.Place F W.FunctionField) ((D - Df) InfinitePlace.place) := by
+    ext v
+    obtain ⟨P, rfl⟩ := geomPlaceOfPoint_surjective isElliptic_Δ_ne_zero v
+    cases P with
+    | zero =>
+        rw [geomPlaceOfPoint_zero, Finsupp.single_eq_same]
+    | some x y h =>
+        rw [Finsupp.sub_apply, geomPlaceOfPoint_some, placeOfEquation, hfin, hDf, sub_self,
+          Finsupp.single_apply, ite_eq_right]
+        exact infinitePlace_ne_ofHeightOneSpectrum _
+  have hdeg : Divisor.degree (D - Df) = 0 := by rw [map_sub, h0, hDf0, sub_zero]
+  rw [hsub, Divisor.degree_single, InfinitePlace.deg_eq_one, Nat.cast_one, mul_one,
+    Finsupp.sub_apply, sub_eq_zero] at hdeg
+  refine ⟨f, hf0, fun v => ?_⟩
+  obtain ⟨P, rfl⟩ := geomPlaceOfPoint_surjective isElliptic_Δ_ne_zero v
+  cases P with
+  | zero => rw [geomPlaceOfPoint_zero, hdeg, hDf]
+  | some x y h => rw [geomPlaceOfPoint_some, placeOfEquation, hfin]
+
+scoped instance instAbelTheorem [HasPrincipalDivisors F W.FunctionField] : GeomAbelTheorem W where
+  isPrincipal_iff_geomDivisorSum_eq_zero _D h0 :=
+    ⟨geomDivisorSum_eq_zero_of_isPrincipal', isPrincipal_of_geomDivisorSum_eq_zero' h0⟩
+
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+universe u in
+open _root_.WeierstrassCurve _root_.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_a3e19da5.WeierstrassCurve
+  _root_.P2MW.S_OVERLONG_a3e19da5.WeierstrassCurve.Affine
+  _root_.AlgebraicCurve
+    _root_.P2MW.S_OVERLONG_a3e19da5.AlgebraicCurve
+  in
+theorem solution
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] {W : WeierstrassCurve.Affine F}
+    [W.IsElliptic]
+    [IsDedekindDomain W.CoordinateRing] [AlgebraicCurve.HasPrincipalDivisors F W.FunctionField] :
+    ∃ g : WeierstrassCurve.Affine.GenusOnePlaceGate W,
+      @WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred F _ W g
+        ∧ @WeierstrassCurve.Affine.AbelTheorem F _ _ g _ := by
+  let g : WeierstrassCurve.Affine.GenusOnePlaceGate W :=
+    { pointEquivPlace := WeierstrassCurve.Affine.geomPointEquivPlace
+      deg_eq_one := fun v => by
+        obtain ⟨P, rfl⟩ :=
+          WeierstrassCurve.Affine.geomPlaceOfPoint_surjective
+            (WeierstrassCurve.Affine.isElliptic_Δ_ne_zero (W := W)) v
+        exact WeierstrassCurve.Affine.deg_geomPlaceOfPoint P }
+  refine ⟨g, ⟨?_, ?_⟩, ⟨?_⟩⟩
+  · intro x y h
+    change algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.XClass W x)
+      ∈ (WeierstrassCurve.Affine.geomPlaceOfPoint (Point.some x y h)).toValuationSubring.nonunits
+    rw [WeierstrassCurve.Affine.geomPlaceOfPoint_some, WeierstrassCurve.Affine.placeOfEquation,
+      AlgebraicCurve.Place.ofHeightOneSpectrum_toValuationSubring,
+      ValuationSubring.mem_nonunits_iff]
+    refine (Valuation.isEquiv_valuation_valuationSubring _).lt_one_iff_lt_one.mp ?_
+    rw [IsDedekindDomain.HeightOneSpectrum.valuation_lt_one_iff_mem,
+      WeierstrassCurve.Affine.CoordinateRing.heightOneSpectrumOfEquation_asIdeal]
+    exact Ideal.subset_span (Set.mem_insert _ _)
+  · intro x y h
+    change algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.YClass W (Polynomial.C y))
+      ∈ (WeierstrassCurve.Affine.geomPlaceOfPoint (Point.some x y h)).toValuationSubring.nonunits
+    rw [WeierstrassCurve.Affine.geomPlaceOfPoint_some, WeierstrassCurve.Affine.placeOfEquation,
+      AlgebraicCurve.Place.ofHeightOneSpectrum_toValuationSubring,
+      ValuationSubring.mem_nonunits_iff]
+    refine (Valuation.isEquiv_valuation_valuationSubring _).lt_one_iff_lt_one.mp ?_
+    rw [IsDedekindDomain.HeightOneSpectrum.valuation_lt_one_iff_mem,
+      WeierstrassCurve.Affine.CoordinateRing.heightOneSpectrumOfEquation_asIdeal]
+    exact Ideal.subset_span (Set.mem_insert_of_mem _ (Set.mem_singleton _))
+  · intro D hD
+    exact WeierstrassCurve.Affine.GeomAbelTheorem.isPrincipal_iff_geomDivisorSum_eq_zero D hD
+
+end
+end
+end
+end
+end S_OVERLONG_a3e19da5
+end P2MW
+export P2MW.S_OVERLONG_a3e19da5 (solution)
+
+end privateSection
+
+public section publicSection
+
+open AlgebraicCurve
+
+universe u
+theorem WeierstrassCurve.Affine.exists_genusOnePlaceGate_isCentred_and_abelTheorem
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] {W : WeierstrassCurve.Affine F}
+    [W.IsElliptic]
+    [IsDedekindDomain W.CoordinateRing] [AlgebraicCurve.HasPrincipalDivisors F W.FunctionField] :
+    ∃ g : WeierstrassCurve.Affine.GenusOnePlaceGate W,
+      @WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred F _ W g
+        ∧ @WeierstrassCurve.Affine.AbelTheorem F _ _ g _ :=
+  solution
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_infinitePlace_deg_eq_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_infinitePlace_deg_eq_one.lean
new file mode 100644
index 0000000000..e1c4d3cae3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_infinitePlace_deg_eq_one.lean
@@ -0,0 +1,538 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.exists_infinitePlace_deg_eq_one
+(5c6836b7-ec98-58a8-a353-7244ef5ac542) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e8f3287a-2e1d-5842-9ea9-08302d934cc1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.Polynomial.DegreeLT
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_eq_valuationSubring_of_X_not_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_exists_valuation_eq_exp_natDegree_norm
+
+/-!
+# Unique degree-one place at infinity of a Weierstrass function field
+
+Theorem statement: `WeierstrassCurve.Affine.exists_infinitePlace_deg_eq_one`
+(`5c6836b7-ec98-58a8-a353-7244ef5ac542`), by Claude, 2026-09-05.
+
+Proof: submission `e8f3287a-2e1d-5842-9ea9-08302d934cc1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field and let $W$ be a Weierstrass curve over $F$ in affine form, with coordinate ring
+`W.CoordinateRing` and function field `W.FunctionField`. Here a place of `W.FunctionField` over $F$
+is a valuation subring $O$ of the function field such that $O$ contains the image of $F$ under the
+structure map, $O \neq \top$ (that is, $O$ is not the whole function field), and $O$ is a principal
+ideal ring; its degree `deg` is the $F$-dimension $\operatorname{finrank}_F$ of the residue field
+$O/\mathfrak{m}_O$. The assertion is that there exists such a place $v_\infty$ with three
+properties: its degree equals $1$; it is not the case that every element $r$ of `W.CoordinateRing`
+has its image under the algebra map into `W.FunctionField` lying in the valuation subring of
+$v_\infty$ (so the affine coordinate ring is not contained in $O_{v_\infty}$); and $v_\infty$ is the
+only place with this last property, i.e. every place $v$ of `W.FunctionField` over $F$ whose
+valuation subring fails to contain the image of the whole coordinate ring is equal to $v_\infty$. No
+smoothness or non-singularity hypothesis on $W$ is imposed.
+
+This is the place at infinity of a Weierstrass function field: the unique place not lying on the
+affine model, rational over the base field. Its three clauses form the infinite-place input to the
+dictionary between places and points on a genus-one curve, and it is used in establishing that
+divisors of degree zero on a Weierstrass curve over an algebraically closed field are principal.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_exists_infinitePlace_deg_eq_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+noncomputable section
+
+open Module Polynomial WithZero
+
+open scoped Polynomial.Bivariate
+
+namespace D5S
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.CoordinateRing AlgebraicCurve
+
+universe u
+
+variable {F : Type u} [Field F] {W : Affine F}
+
+theorem algebraMap_eq_mk_C_C (a : F) :
+    algebraMap F W.CoordinateRing a = mk W (C (C a)) := by
+  rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+    Algebra.algebraMap_self_apply]
+  rfl
+
+theorem coe_smul (r : F) (z : W.CoordinateRing) : r • z = mk W (C (C r)) * z := by
+  rw [Algebra.smul_def, algebraMap_eq_mk_C_C]
+
+theorem algebraMap_poly_eq (p : F[X]) : algebraMap F[X] W.CoordinateRing p = mk W (C p) := by
+  rw [Algebra.algebraMap_eq_smul_one, smul, mul_one]
+
+theorem two_nsmul_le_coe_iff {d : WithBot ℕ} {n : ℕ} :
+    2 • d ≤ (n : WithBot ℕ) ↔ d < ((n / 2 + 1 : ℕ) : WithBot ℕ) := by
+  induction d using WithBot.recBotCoe with
+  | bot => exact iff_of_true (by simp) (WithBot.bot_lt_coe _)
+  | coe k =>
+    change 2 • ((k : ℕ) : WithBot ℕ) ≤ (n : WithBot ℕ) ↔
+      ((k : ℕ) : WithBot ℕ) < ((n / 2 + 1 : ℕ) : WithBot ℕ)
+    rw [two_nsmul, ← Nat.cast_add]
+    exact_mod_cast (by omega : k + k ≤ n ↔ k < n / 2 + 1)
+
+theorem two_nsmul_add_three_le_coe_iff {d : WithBot ℕ} {n : ℕ} :
+    2 • d + 3 ≤ (n : WithBot ℕ) ↔ d < (((n - 1) / 2 : ℕ) : WithBot ℕ) := by
+  induction d using WithBot.recBotCoe with
+  | bot => exact iff_of_true (by simp) (WithBot.bot_lt_coe _)
+  | coe k =>
+    change 2 • ((k : ℕ) : WithBot ℕ) + 3 ≤ (n : WithBot ℕ) ↔
+      ((k : ℕ) : WithBot ℕ) < (((n - 1) / 2 : ℕ) : WithBot ℕ)
+    rw [two_nsmul, ← Nat.cast_add, show (3 : WithBot ℕ) = ((3 : ℕ) : WithBot ℕ) by norm_cast,
+      ← Nat.cast_add]
+    exact_mod_cast (by omega : k + k + 3 ≤ n ↔ k < (n - 1) / 2)
+
+theorem xCount_add_yCount (n : ℕ) (hn : 1 ≤ n) : n / 2 + 1 + (n - 1) / 2 = n := by
+  omega
+
+variable (W) in
+def rrParam (n : ℕ) :
+    (degreeLT F (n / 2 + 1) × degreeLT F ((n - 1) / 2)) →ₗ[F] W.CoordinateRing :=
+  LinearMap.coprod
+    (((LinearMap.toSpanSingleton F[X] W.CoordinateRing 1).restrictScalars F).comp
+      (Submodule.subtype _))
+    (((LinearMap.toSpanSingleton F[X] W.CoordinateRing (mk W Y)).restrictScalars F).comp
+      (Submodule.subtype _))
+
+@[scoped simp] theorem rrParam_apply (n : ℕ)
+    (pq : degreeLT F (n / 2 + 1) × degreeLT F ((n - 1) / 2)) :
+    rrParam W n pq = (pq.1 : F[X]) • (1 : W.CoordinateRing) + (pq.2 : F[X]) • mk W Y :=
+  rfl
+
+theorem rrParam_injective (n : ℕ) : Function.Injective (rrParam W n) := by
+  rw [injective_iff_map_eq_zero]
+  rintro ⟨p, q⟩ h
+  rw [rrParam_apply] at h
+  obtain ⟨hp, hq⟩ := smul_basis_eq_zero h
+  exact Prod.ext (Subtype.ext hp) (Subtype.ext hq)
+
+variable (W) in
+def RRSpace (n : ℕ) : Submodule F W.CoordinateRing :=
+  LinearMap.range (rrParam W n)
+
+theorem mem_RRSpace_iff {f : W.CoordinateRing} {n : ℕ} :
+    f ∈ RRSpace W n ↔ ∃ p q : F[X], p.degree < ((n / 2 + 1 : ℕ) : WithBot ℕ) ∧
+      q.degree < (((n - 1) / 2 : ℕ) : WithBot ℕ) ∧
+      p • (1 : W.CoordinateRing) + q • mk W Y = f := by
+  constructor
+  · rintro ⟨⟨p, q⟩, rfl⟩
+    exact ⟨p, q, mem_degreeLT.mp p.2, mem_degreeLT.mp q.2, rfl⟩
+  · rintro ⟨p, q, hp, hq, rfl⟩
+    exact ⟨⟨⟨p, mem_degreeLT.mpr hp⟩, ⟨q, mem_degreeLT.mpr hq⟩⟩, rfl⟩
+
+theorem smul_basis_mem_RRSpace_iff {p q : F[X]} {n : ℕ} :
+    p • (1 : W.CoordinateRing) + q • mk W Y ∈ RRSpace W n ↔
+      p.degree < ((n / 2 + 1 : ℕ) : WithBot ℕ) ∧
+        q.degree < (((n - 1) / 2 : ℕ) : WithBot ℕ) := by
+  refine ⟨fun h => ?_, fun ⟨hp, hq⟩ => mem_RRSpace_iff.mpr ⟨p, q, hp, hq, rfl⟩⟩
+  obtain ⟨p', q', hp', hq', hf⟩ := mem_RRSpace_iff.mp h
+  have h0 : (p' - p) • (1 : W.CoordinateRing) + (q' - q) • mk W Y = 0 := by
+    rw [sub_smul, sub_smul, ← sub_eq_zero.mpr hf]
+    abel
+  obtain ⟨hp0, hq0⟩ := smul_basis_eq_zero h0
+  rw [sub_eq_zero] at hp0 hq0
+  exact ⟨hp0 ▸ hp', hq0 ▸ hq'⟩
+
+theorem mem_RRSpace_iff_degree_norm_le {f : W.CoordinateRing} {n : ℕ} :
+    f ∈ RRSpace W n ↔ (Algebra.norm F[X] f).degree ≤ (n : WithBot ℕ) := by
+  obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq f
+  rw [smul_basis_mem_RRSpace_iff, degree_norm_smul_basis, max_le_iff,
+    two_nsmul_le_coe_iff, two_nsmul_add_three_le_coe_iff]
+
+theorem RRSpace_mono {m n : ℕ} (h : m ≤ n) : RRSpace W m ≤ RRSpace W n := fun _ hf =>
+  mem_RRSpace_iff_degree_norm_le.mpr <|
+    (mem_RRSpace_iff_degree_norm_le.mp hf).trans <| by exact_mod_cast h
+
+theorem one_mem_RRSpace (n : ℕ) : (1 : W.CoordinateRing) ∈ RRSpace W n :=
+  mem_RRSpace_iff.mpr ⟨1, 0,
+    by rw [degree_one]; exact_mod_cast (by omega : (0 : ℕ) < n / 2 + 1),
+    by rw [degree_zero]; exact WithBot.bot_lt_coe _,
+    by rw [one_smul, zero_smul, add_zero]⟩
+
+theorem algebraMap_mem_RRSpace (a : F) (n : ℕ) :
+    algebraMap F W.CoordinateRing a ∈ RRSpace W n := by
+  rw [Algebra.algebraMap_eq_smul_one]
+  exact Submodule.smul_mem _ a (one_mem_RRSpace n)
+
+theorem one_le_RRSpace (n : ℕ) : (1 : Submodule F W.CoordinateRing) ≤ RRSpace W n := by
+  intro f hf
+  obtain ⟨a, rfl⟩ := Submodule.mem_one.mp hf
+  exact algebraMap_mem_RRSpace a n
+
+namespace RRSpace
+
+variable (W) in
+def basisAux (n : ℕ) :
+    Basis (Fin (n / 2 + 1 + (n - 1) / 2)) F (RRSpace W n) :=
+  (degreeLT.basisProd F (n / 2 + 1) ((n - 1) / 2)).map
+    (LinearEquiv.ofInjective (rrParam W n) (rrParam_injective n))
+
+theorem finrank_eq (n : ℕ) (hn : 1 ≤ n) : finrank F (RRSpace W n) = n := by
+  rw [finrank_eq_card_basis (basisAux W n), Fintype.card_fin]
+  exact xCount_add_yCount n hn
+
+variable (W) in
+def finBasis (n : ℕ) (hn : 1 ≤ n) : Basis (Fin n) F (RRSpace W n) :=
+  (basisAux W n).reindex (finCongr (xCount_add_yCount n hn))
+
+end RRSpace
+
+theorem RRSpace_zero : RRSpace W 0 = (1 : Submodule F W.CoordinateRing) := by
+  refine le_antisymm ?_ (one_le_RRSpace 0)
+  rintro f hf
+  obtain ⟨p, q, hp, hq, rfl⟩ := mem_RRSpace_iff.mp hf
+  have hq0 : q = 0 := by
+    rw [← degree_eq_bot]
+    simpa using hq
+  have hp0 : p = C (p.coeff 0) := by
+    refine degree_le_zero_iff.mp (Nat.WithBot.lt_one_iff_le_zero.mp ?_)
+    simpa using hp
+  rw [hq0, zero_smul, add_zero, hp0, smul, mul_one, ← algebraMap_eq_mk_C_C]
+  exact Submodule.mem_one.mpr ⟨p.coeff 0, rfl⟩
+
+theorem exists_smul_sub_natDegree_norm_lt {a b : W.CoordinateRing} (hb : b ≠ 0)
+    (hab : (Algebra.norm F[X] a).natDegree ≤ (Algebra.norm F[X] b).natDegree) :
+    ∃ c : F, a - c • b = 0 ∨
+      (Algebra.norm F[X] (a - c • b)).natDegree < (Algebra.norm F[X] b).natDegree := by
+  set n := (Algebra.norm F[X] b).natDegree with hndef
+  have hbn : b ∈ RRSpace W n :=
+    mem_RRSpace_iff_degree_norm_le.mpr (Polynomial.natDegree_le_iff_degree_le.mp le_rfl)
+  have han : a ∈ RRSpace W n :=
+    mem_RRSpace_iff_degree_norm_le.mpr (Polynomial.natDegree_le_iff_degree_le.mp hab)
+  rcases Nat.eq_zero_or_pos n with hn0 | hnpos
+  · rw [hn0] at hbn han
+    rw [RRSpace_zero] at hbn han
+    obtain ⟨α, hα⟩ := Submodule.mem_one.mp han
+    obtain ⟨β, hβ⟩ := Submodule.mem_one.mp hbn
+    have hβ0 : β ≠ 0 := by
+      rintro rfl
+      rw [map_zero] at hβ
+      exact hb hβ.symm
+    refine ⟨α / β, Or.inl ?_⟩
+    rw [← hα, ← hβ, Algebra.smul_def, ← map_mul, div_mul_cancel₀ _ hβ0, sub_self]
+  rcases eq_or_ne n 1 with hn1 | hn1
+  · exact absurd (hndef.symm.trans hn1) (natDegree_norm_ne_one b)
+  have hn2 : 2 ≤ n := by omega
+  have hn1' : 1 ≤ n - 1 := by omega
+  have : FiniteDimensional F (RRSpace W n) :=
+    Module.Finite.of_basis (RRSpace.finBasis W n (by omega))
+  have hbnot : b ∉ RRSpace W (n - 1) := by
+    intro hcon
+    rw [mem_RRSpace_iff_degree_norm_le, ← Polynomial.natDegree_le_iff_degree_le] at hcon
+    omega
+  have hsup : RRSpace W (n - 1) ⊔ Submodule.span F {b} = RRSpace W n := by
+    have hle : RRSpace W (n - 1) ⊔ Submodule.span F {b} ≤ RRSpace W n := by
+      refine sup_le (RRSpace_mono (by omega)) ?_
+      rw [Submodule.span_le, Set.singleton_subset_iff]
+      exact hbn
+    refine Submodule.eq_of_le_of_finrank_le hle ?_
+    have hlt : RRSpace W (n - 1) < RRSpace W (n - 1) ⊔ Submodule.span F {b} := by
+      refine lt_of_le_of_ne le_sup_left ?_
+      intro hcon
+      refine hbnot ?_
+      rw [hcon]
+      exact (le_sup_right (a := RRSpace W (n - 1))) (Submodule.mem_span_singleton_self b)
+    have : FiniteDimensional F (RRSpace W (n - 1) ⊔ Submodule.span F {b} : Submodule F _) :=
+      Submodule.finiteDimensional_of_le hle
+    have h1 := Submodule.finrank_lt_finrank_of_lt hlt
+    rw [RRSpace.finrank_eq (n - 1) hn1'] at h1
+    rw [RRSpace.finrank_eq n (by omega)]
+    omega
+  obtain ⟨ℓ, hℓ, z, hz, hsum⟩ := Submodule.mem_sup.mp (hsup ▸ han)
+  obtain ⟨c, rfl⟩ := Submodule.mem_span_singleton.mp hz
+  refine ⟨c, ?_⟩
+  have hldef : a - c • b = ℓ := by rw [← hsum]; ring
+  rcases eq_or_ne (a - c • b) 0 with h | h
+  · exact Or.inl h
+  · refine Or.inr ?_
+    have hc : (Algebra.norm F[X] (a - c • b)).natDegree ≤ n - 1 := by
+      rw [Polynomial.natDegree_le_iff_degree_le, ← mem_RRSpace_iff_degree_norm_le]
+      exact hldef ▸ hℓ
+    omega
+
+variable (W) in
+def xF : W.FunctionField := algebraMap W.CoordinateRing W.FunctionField (mk W (C X))
+
+variable (W) in
+def infVal : Valuation W.FunctionField ℤᵐ⁰ :=
+  (WeierstrassCurve.Affine.FunctionField.exists_valuation_eq_exp_natDegree_norm W).choose
+
+theorem infVal_apply {f : W.CoordinateRing} (hf : f ≠ 0) :
+    infVal W (algebraMap W.CoordinateRing W.FunctionField f)
+      = exp ((Algebra.norm F[X] f).natDegree : ℤ) :=
+  (WeierstrassCurve.Affine.FunctionField.exists_valuation_eq_exp_natDegree_norm W).choose_spec
+    f hf
+
+theorem mk_C_X_ne_zero : (mk W (C X) : W.CoordinateRing) ≠ 0 := by
+  have h1 := XClass_ne_zero (W' := W) (0 : F)
+  rw [XClass, map_zero, sub_zero] at h1
+  exact h1
+
+theorem natDegree_norm_mk_C_X :
+    (Algebra.norm F[X] (mk W (C X) : W.CoordinateRing)).natDegree = 2 := by
+  have hX : (X : F[X]) • (1 : W.CoordinateRing) + (0 : F[X]) • mk W Y = mk W (C X) := by
+    rw [zero_smul, add_zero, smul, mul_one]
+  have hdeg := degree_norm_smul_basis (W' := W) (X : F[X]) 0
+  rw [hX, degree_X, Polynomial.degree_zero, show (2 : ℕ) • (⊥ : WithBot ℕ) + 3 = ⊥ by
+      rw [two_nsmul]; simp, max_eq_left bot_le] at hdeg
+  exact Polynomial.natDegree_eq_of_degree_eq_some (n := 2) (by rw [hdeg]; rfl)
+
+theorem infVal_xF : infVal W (xF W) = exp (2 : ℤ) := by
+  rw [xF, infVal_apply mk_C_X_ne_zero, natDegree_norm_mk_C_X]
+  rfl
+
+theorem one_lt_infVal_xF : 1 < infVal W (xF W) := by
+  rw [infVal_xF, ← exp_zero, exp_lt_exp]
+  norm_num
+
+theorem xF_notMem : xF W ∉ (infVal W).valuationSubring := by
+  rw [Valuation.mem_valuationSubring_iff, not_le]
+  exact one_lt_infVal_xF
+
+theorem infVal_algebraMap_le (c : F) :
+    infVal W (algebraMap F W.FunctionField c) ≤ 1 := by
+  rcases eq_or_ne c 0 with rfl | hc
+  · rw [map_zero, map_zero]
+    exact zero_le
+  · have hc' : algebraMap F W.CoordinateRing c ≠ 0 :=
+      (map_ne_zero_iff _ (FaithfulSMul.algebraMap_injective F W.CoordinateRing)).mpr hc
+    have hCc : (C c : F[X]) • (1 : W.CoordinateRing) + (0 : F[X]) • mk W Y
+        = algebraMap F W.CoordinateRing c := by
+      rw [zero_smul, add_zero, smul, mul_one, algebraMap_eq_mk_C_C]
+    have hdeg := degree_norm_smul_basis (W' := W) (C c : F[X]) 0
+    rw [hCc, degree_C hc, Polynomial.degree_zero, show (2 : ℕ) • (⊥ : WithBot ℕ) + 3 = ⊥ by
+        rw [two_nsmul]; simp, max_eq_left bot_le, two_nsmul, add_zero] at hdeg
+    rw [IsScalarTower.algebraMap_apply F W.CoordinateRing W.FunctionField, infVal_apply hc',
+      Polynomial.natDegree_eq_of_degree_eq_some (n := 0) (by rw [hdeg]; rfl), ← exp_zero,
+      exp_le_exp, Nat.cast_zero]
+
+scoped instance infVal_isNontrivial : (infVal W).IsNontrivial :=
+  ⟨xF W, by rw [infVal_xF]; exact exp_ne_zero, (one_lt_infVal_xF (W := W)).ne'⟩
+
+variable (W) in
+def infPlace : AlgebraicCurve.Place F W.FunctionField where
+  toValuationSubring := (infVal W).valuationSubring
+  algebraMap_mem' c := (Valuation.mem_valuationSubring_iff _ _).mpr (infVal_algebraMap_le c)
+  ne_top' h := xF_notMem (W := W) (by rw [h]; exact ValuationSubring.mem_top _)
+  isPrincipalIdealRing' := inferInstance
+
+@[scoped simp] theorem infPlace_toValuationSubring :
+    (infPlace W).toValuationSubring = (infVal W).valuationSubring := rfl
+
+theorem div_mem_infPlace_iff {a b : W.CoordinateRing} (ha : a ≠ 0) (hb : b ≠ 0) :
+    algebraMap W.CoordinateRing W.FunctionField a
+        / algebraMap W.CoordinateRing W.FunctionField b ∈ (infPlace W).toValuationSubring
+      ↔ (Algebra.norm F[X] a).natDegree ≤ (Algebra.norm F[X] b).natDegree := by
+  rw [infPlace_toValuationSubring, Valuation.mem_valuationSubring_iff, map_div₀,
+    infVal_apply ha, infVal_apply hb, ← exp_sub, ← exp_zero, exp_le_exp, sub_nonpos,
+    Nat.cast_le]
+
+theorem forall_mem_of_xF_mem (v : AlgebraicCurve.Place F W.FunctionField)
+    (hx : xF W ∈ v.toValuationSubring) :
+    ∀ r : W.CoordinateRing, algebraMap W.CoordinateRing W.FunctionField r ∈ v.toValuationSubring :=
+      by
+  set A := v.toValuationSubring with hA
+  set φ : F[X] →+* W.FunctionField :=
+    (algebraMap W.CoordinateRing W.FunctionField).comp (algebraMap F[X] W.CoordinateRing)
+    with hφ
+  have hφ_apply : ∀ p : F[X],
+      φ p = algebraMap W.CoordinateRing W.FunctionField (mk W (C p)) := fun p => by
+    rw [hφ, RingHom.comp_apply, algebraMap_poly_eq]
+  have hpoly : ∀ p : F[X], φ p ∈ A := by
+    intro p
+    induction p using Polynomial.induction_on' with
+    | add f g hf hg => rw [map_add]; exact add_mem hf hg
+    | monomial n c =>
+        rw [← C_mul_X_pow_eq_monomial, map_mul, map_pow]
+        refine mul_mem ?_ (pow_mem ?_ n)
+        · rw [hφ_apply, ← algebraMap_eq_mk_C_C,
+            ← IsScalarTower.algebraMap_apply F W.CoordinateRing W.FunctionField]
+          exact v.algebraMap_mem' c
+        · rw [hφ_apply]
+          exact hx
+  set η := algebraMap W.CoordinateRing W.FunctionField (mk W Y) with hηdef
+  set c₁ : F[X] := C W.a₁ * X + C W.a₃ with hc₁def
+  set cb : F[X] := X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ with hcbdef
+  have hsb : ∀ p q : F[X], algebraMap W.CoordinateRing W.FunctionField
+      (p • (1 : W.CoordinateRing) + q • mk W Y) = φ p + φ q * η := by
+    intro p q
+    rw [map_add, smul, mul_one, smul, map_mul, hφ_apply, hφ_apply]
+  have hrel : η * η = φ cb - φ c₁ * η := by
+    have h1 := smul_basis_mul_Y (W' := W) 0 1
+    rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at h1
+    have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) h1
+    rw [map_mul, hsb, map_neg, neg_mul, ← sub_eq_add_neg] at h2
+    exact h2
+  have hy : η ∈ A := by
+    by_contra hcon
+    have hgt : 1 < A.valuation η := lt_of_not_ge fun h => hcon ((A.valuation_le_one_iff η).mp h)
+    have hcb : A.valuation (φ cb) ≤ 1 := (A.valuation_le_one_iff _).mpr (hpoly cb)
+    have hc1 : A.valuation (φ c₁) ≤ 1 := (A.valuation_le_one_iff _).mpr (hpoly c₁)
+    have hle : A.valuation η * A.valuation η ≤ A.valuation η := by
+      calc A.valuation η * A.valuation η = A.valuation (φ cb - φ c₁ * η) := by
+            rw [← map_mul, hrel]
+        _ ≤ max (A.valuation (φ cb)) (A.valuation (φ c₁ * η)) := Valuation.map_sub _ _ _
+        _ ≤ max 1 (1 * A.valuation η) := by
+            refine max_le_max hcb ?_
+            rw [map_mul]
+            exact mul_le_mul_left hc1 _
+        _ = A.valuation η := by
+            rw [one_mul, max_eq_right hgt.le]
+    have hη0 : A.valuation η ≠ 0 := ne_of_gt (lt_trans zero_lt_one hgt)
+    have : A.valuation η ≤ 1 := by
+      calc A.valuation η = A.valuation η * A.valuation η * (A.valuation η)⁻¹ := by
+            rw [mul_assoc, mul_inv_cancel₀ hη0, mul_one]
+        _ ≤ A.valuation η * (A.valuation η)⁻¹ := mul_le_mul_left hle _
+        _ = 1 := mul_inv_cancel₀ hη0
+    exact absurd hgt (not_lt.mpr this)
+  intro r
+  obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq r
+  rw [hsb]
+  exact add_mem (hpoly p) (mul_mem (hpoly q) hy)
+
+theorem not_forall_mem_infPlace :
+    ¬ ∀ r : W.CoordinateRing,
+      algebraMap W.CoordinateRing W.FunctionField r ∈ (infPlace W).toValuationSubring :=
+  fun h => xF_notMem (W := W) (h (mk W (C X)))
+
+theorem eq_infPlace_of_not_forall_mem (v : AlgebraicCurve.Place F W.FunctionField)
+    (hv : ¬ ∀ r : W.CoordinateRing,
+      algebraMap W.CoordinateRing W.FunctionField r ∈ v.toValuationSubring) :
+    v = infPlace W := by
+  have hx : xF W ∉ v.toValuationSubring := fun hx => hv (forall_mem_of_xF_mem v hx)
+  refine AlgebraicCurve.Place.ext ?_
+  rw [infPlace_toValuationSubring]
+  exact WeierstrassCurve.Affine.FunctionField.eq_valuationSubring_of_X_not_mem W
+    v.toValuationSubring v.algebraMap_mem' hx (infVal W) (fun f hf => infVal_apply hf)
+
+theorem deg_eq_one_of_surjective (v : AlgebraicCurve.Place F W.FunctionField)
+    (h : Function.Surjective (algebraMap F v.ResidueField)) : v.deg = 1 := by
+  have hbij : Function.Bijective (algebraMap F v.ResidueField) :=
+    ⟨(algebraMap F v.ResidueField).injective, h⟩
+  change Module.finrank F v.ResidueField = 1
+  rw [← Module.finrank_self F]
+  exact ((AlgEquiv.ofBijective (Algebra.ofId F v.ResidueField) hbij).toLinearEquiv.finrank_eq).symm
+
+theorem mem_maximalIdeal_infPlace_of_lt {z : (infPlace W).toValuationSubring}
+    (hz : infVal W (z : W.FunctionField) < 1) :
+    z ∈ IsLocalRing.maximalIdeal (infPlace W).toValuationSubring := by
+  rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+  intro hu
+  have h1 : ((infPlace W).toValuationSubring).valuation (z : W.FunctionField) = 1 :=
+    (ValuationSubring.valuation_eq_one_iff _ z).mp hu
+  have h2 : infVal W (z : W.FunctionField) = 1 :=
+    ((infVal W).isEquiv_valuation_valuationSubring.eq_one_iff_eq_one).mpr h1
+  exact hz.ne h2
+
+theorem deg_infPlace : (infPlace W).deg = 1 := by
+  set v := infPlace W with hvdef
+  refine deg_eq_one_of_surjective v ?_
+  intro z
+  obtain ⟨g, rfl⟩ := Ideal.Quotient.mk_surjective z
+  rcases eq_or_ne (g : W.FunctionField) 0 with hg0 | hg0
+  · refine ⟨0, ?_⟩
+    have hgz : g = 0 := Subtype.ext hg0
+    subst hgz
+    exact (map_zero _).trans (map_zero _).symm
+  obtain ⟨a, b, hb, hzab⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing)
+    (g : W.FunctionField)
+  have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb
+  have hbL0 : algebraMap W.CoordinateRing W.FunctionField b ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr hb0
+  have ha0 : a ≠ 0 := by
+    intro h
+    rw [h, map_zero, zero_div] at hzab
+    exact hg0 hzab.symm
+  have hmem : (g : W.FunctionField) ∈ v.toValuationSubring := g.2
+  rw [← hzab] at hmem
+  have hab := (div_mem_infPlace_iff ha0 hb0).mp hmem
+  obtain ⟨c, hc⟩ := exists_smul_sub_natDegree_norm_lt hb0 hab
+  refine ⟨c, ?_⟩
+  rw [IsScalarTower.algebraMap_apply F v.toValuationSubring v.ResidueField,
+    IsLocalRing.ResidueField.algebraMap_eq]
+  refine (Ideal.Quotient.eq (I := IsLocalRing.maximalIdeal v.toValuationSubring)).mpr ?_
+  have hdiff : ((algebraMap F v.toValuationSubring c - g : v.toValuationSubring)
+      : W.FunctionField) = -(algebraMap W.CoordinateRing W.FunctionField (a - c • b)
+        / algebraMap W.CoordinateRing W.FunctionField b) := by
+    have h0 : ((algebraMap F v.toValuationSubring c - g : v.toValuationSubring)
+        : W.FunctionField) = algebraMap F W.FunctionField c
+          - algebraMap W.CoordinateRing W.FunctionField a
+            / algebraMap W.CoordinateRing W.FunctionField b := by
+      push_cast
+      rw [v.coe_algebraMap c, hzab]
+    rw [h0, map_sub, Algebra.smul_def, map_mul,
+      ← IsScalarTower.algebraMap_apply F W.CoordinateRing W.FunctionField, neg_div', neg_sub,
+      sub_div, mul_div_cancel_right₀ _ hbL0]
+  rcases eq_or_ne (a - c • b) 0 with hzero | hne
+  · have h2 : (algebraMap F v.toValuationSubring c - g : v.toValuationSubring) = 0 := by
+      ext
+      rw [hdiff, hzero, map_zero, zero_div, neg_zero]
+      rfl
+    rw [h2]
+    exact (IsLocalRing.maximalIdeal v.toValuationSubring).zero_mem
+  · have hlt := hc.resolve_left hne
+    refine mem_maximalIdeal_infPlace_of_lt ?_
+    rw [hdiff, Valuation.map_neg, map_div₀, infVal_apply hne, infVal_apply hb0, ← exp_sub,
+      ← exp_zero, exp_lt_exp, sub_neg, Nat.cast_lt]
+    exact hlt
+
+theorem exists_infinitePlace_deg_eq_one_impl (W : Affine F) :
+    ∃ vInf : AlgebraicCurve.Place F W.FunctionField, vInf.deg = 1 ∧
+      (¬ ∀ r : W.CoordinateRing,
+        algebraMap W.CoordinateRing W.FunctionField r ∈ vInf.toValuationSubring) ∧
+      ∀ v : AlgebraicCurve.Place F W.FunctionField,
+        (¬ ∀ r : W.CoordinateRing,
+          algebraMap W.CoordinateRing W.FunctionField r ∈ v.toValuationSubring) → v = vInf :=
+  ⟨infPlace W, deg_infPlace, not_forall_mem_infPlace, fun v hv => eq_infPlace_of_not_forall_mem v
+    hv⟩
+
+end D5S
+end
+
+theorem solution {F : Type*} [Field F] (W : WeierstrassCurve.Affine F) :
+    ∃ vInf : AlgebraicCurve.Place F W.FunctionField, vInf.deg = 1 ∧
+      (¬ ∀ r : W.CoordinateRing,
+        algebraMap W.CoordinateRing W.FunctionField r ∈ vInf.toValuationSubring) ∧
+      ∀ v : AlgebraicCurve.Place F W.FunctionField,
+        (¬ ∀ r : W.CoordinateRing,
+          algebraMap W.CoordinateRing W.FunctionField r ∈ v.toValuationSubring) → v = vInf :=
+  D5S.exists_infinitePlace_deg_eq_one_impl W
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.Affine.exists_infinitePlace_deg_eq_one {F : Type*} [Field F]
+    (W : WeierstrassCurve.Affine F) :
+    ∃ vInf : AlgebraicCurve.Place F W.FunctionField, vInf.deg = 1 ∧ (¬ ∀ r : W.CoordinateRing,
+      algebraMap W.CoordinateRing W.FunctionField r ∈ vInf.toValuationSubring) ∧ ∀ v :
+      AlgebraicCurve.Place F W.FunctionField, (¬ ∀ r : W.CoordinateRing, algebraMap W.CoordinateRing
+      W.FunctionField r ∈ v.toValuationSubring) → v = vInf :=
+  solution W
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_intermediateField_countable_map_eq_of_isAddCyclic_ker_pointMapOfPushforward.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_intermediateField_countable_map_eq_of_isAddCyclic_ker_pointMapOfPushforward.lean
new file mode 100644
index 0000000000..8795960900
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_intermediateField_countable_map_eq_of_isAddCyclic_ker_pointMapOfPushforward.lean
@@ -0,0 +1,3012 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.Affine.
+exists_intermediateField_countable_map_eq_of_isAddCyclic_ker_pointMapOfPushforward
+(0a40ab42-17dc-59b1-8b65-ce60e1b9c70a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6b155adb-686e-5360-9630-4ed2fb76951c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.Algebra.Algebra.IsSimpleRing
+import Mathlib.Algebra.Polynomial.Basis
+import Mathlib.Data.Rat.Encodable
+import Mathlib.FieldTheory.RatFunc.IntermediateField
+import Mathlib.Order.CompletePartialOrder
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_inv
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_GenusOnePlaceGate_ext_of_isCentred
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_and_abelTheorem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_isAddCyclic_ker_pointMapOfPushforward_of_baseChange_algHom
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_natCard_ker_pointMapOfPushforward_eq_finrankAlong
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_min_ord_le_ord_add_v2
+import LeanPool.FLTEichlerShimura.Definitions.Defs_IsogenyEndDatum_sharedLibrary
+import LeanPool.FLTEichlerShimura.Definitions.Defs_WeierstrassCurve_veluSharedLibrary
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_adjoin_yCoord_eq_top
+
+/-!
+# Cyclic degree-N function-field seams descend to countable subfields
+
+Theorem statement:
+`WeierstrassCurve.Affine.
+exists_intermediateField_countable_map_eq_of_isAddCyclic_ker_pointMapOfPushforward`
+(`0a40ab42-17dc-59b1-8b65-ce60e1b9c70a`), by Claude, 2026-09-05.
+
+Proof: submission `6b155adb-686e-5360-9630-4ed2fb76951c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field of characteristic $0$, and let $E,E'$ be elliptic
+Weierstrass curves in affine form over $K$, each equipped with a `GenusOnePlaceGate` (a bijection
+between the group of points and the places of the function field over $K$, all places having degree
+$1$) which is centred (for every nonsingular $(x,y)$ the images of the classes of $X-x$ and $Y-y$
+lie in the nonunits of the valuation subring of the place attached to the point $(x,y)$) and
+satisfying `AbelTheorem` (a divisor of degree $0$ is principal exactly when its divisor sum
+vanishes). Let $\iota : K(E') \to K(E)$ be a $K$-algebra homomorphism which is integral, makes
+$K(E)$ a finite module over $K(E')$, and satisfies the pushforward norm formula `NormFormulaAlong`.
+Let $N \neq 0$ be a natural number and assume the kernel of the induced homomorphism
+`pointMapOfPushforward` $\colon E(K) \to E'(K)$ (transport of the pushforward of degree-zero divisor
+classes along the two $\mathrm{Pic}^0$ identifications) is cyclic of cardinality $N$. Then, for the
+canonical $\mathbb{Q}$-algebra structure on $K$, there exist a countable intermediate field $K_0$ of
+$\mathbb{Q} \subseteq K$, elliptic Weierstrass curves $E_0,E_0'$ over $K_0$ whose base changes along
+$K_0 \to K$ are $E$ and $E'$ and whose base changes to $\overline{K_0}$ are elliptic, and an
+integral, finite $\overline{K_0}$-algebra homomorphism $\iota_0$ from the function field of $E_0'
+\times_{K_0} \overline{K_0}$ to that of $E_0 \times_{K_0} \overline{K_0}$, such that for every
+choice of gate, centredness and Abel data on the two base-changed affine curves and every witness of
+the pushforward norm formula for $\iota_0$, the kernel of the resulting `pointMapOfPushforward` is
+cyclic of cardinality $N$.
+
+This is the first half of the Lefschetz-principle descent: the data of a finite function-field
+embedding with cyclic kernel of order $N$ is defined over a finitely generated, hence countable,
+subfield of $K$, and the conclusion is stated in the form that quantifies universally over the
+admissible genus-one gate data on the descended curves rather than supplying it. It feeds the
+transfer to $\mathbb{C}$ used in
+`eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward`
+which identifies the pair of $j$-invariants as a root of the modular polynomial of level $N$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_exists_intermediateField_countable_map_eq_of_isAddCyclic_ker_pointMapOfPushforward.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 3200000
+
+section privateSection
+
+open WeierstrassCurve Affine CoordinateRing
+  IntermediateField AlgebraicCurve Polynomial IsDedekindDomain
+
+open scoped Polynomial.Bivariate TensorProduct
+
+set_option backward.isDefEq.respectTransparency.types false
+
+
+noncomputable section
+
+namespace WeierstrassCurve
+
+namespace Affine
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem S13_ofHeightOneSpectrum_injective {R : Type*} [CommRing R] [IsDedekindDomain R]
+    [Algebra R W.FunctionField] [IsFractionRing R W.FunctionField] [Algebra F R]
+    [IsScalarTower F R W.FunctionField] :
+    Function.Injective (AlgebraicCurve.Place.ofHeightOneSpectrum (K := F) (R := R) (F :=
+      W.FunctionField)) := by
+  intro w₁ w₂ h
+  refine HeightOneSpectrum.eq_of_valuation_isEquiv_valuation (K := W.FunctionField) ?_
+  rw [Valuation.isEquiv_iff_valuationSubring]
+  exact congrArg AlgebraicCurve.Place.toValuationSubring h
+
+namespace CoordinateRing
+
+theorem eq_of_XYIdeal_eq {x₁ y₁ x₂ y₂ : F} (h₂ : W.Equation x₂ y₂)
+    (h : XYIdeal W x₁ (C y₁) = XYIdeal W x₂ (C y₂)) : x₁ = x₂ ∧ y₁ = y₂ := by
+  have hne : XYIdeal W x₂ (C y₂) ≠ ⊤ := (XYIdeal_isMaximal h₂).ne_top
+  have hX₁ : XClass W x₁ ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert _ _)
+  have hX₂ : XClass W x₂ ∈ XYIdeal W x₂ (C y₂) := Ideal.subset_span (Set.mem_insert _ _)
+  have hY₁ : YClass W (C y₁) ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  have hY₂ : YClass W (C y₂) ∈ XYIdeal W x₂ (C y₂) :=
+    Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  constructor
+  · by_contra hx
+    apply hne
+    have hsub : XClass W x₁ - XClass W x₂ = algebraMap F W.CoordinateRing (x₂ - x₁) := by
+      rw [XClass, XClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      rw [← map_sub]
+      congr 1
+      rw [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hX₁ hX₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hx hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+  · by_contra hy
+    apply hne
+    have hsub : YClass W (C y₁) - YClass W (C y₂) = algebraMap F W.CoordinateRing (y₂ - y₁) := by
+      rw [YClass, YClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      simp only [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hY₁ hY₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hy hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+
+@[scoped simp]
+theorem heightOneSpectrumOfEquation_asIdeal {x y : F} (h : W.Equation x y) :
+    (heightOneSpectrumOfEquation h).asIdeal = XYIdeal W x (C y) := rfl
+
+theorem exists_sub_algebraMap_mem {x y : F} (h : W.Equation x y) (r : W.CoordinateRing) :
+    ∃ c : F, r - algebraMap F W.CoordinateRing c ∈ XYIdeal W x (C y) := by
+  set e := quotientXYIdealEquiv (W' := W) (x := x) (y := C y) h
+  refine ⟨e (Ideal.Quotient.mk _ r), ?_⟩
+  rw [← Ideal.Quotient.eq_zero_iff_mem, map_sub, sub_eq_zero]
+  apply e.injective
+  rw [← Ideal.Quotient.algebraMap_eq, ← IsScalarTower.algebraMap_apply, AlgEquiv.commutes,
+    Algebra.algebraMap_self_apply]
+
+end CoordinateRing
+
+@[scoped simp]
+theorem IsFinitePlace.coe_ringHom_apply {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) (r : W.CoordinateRing) :
+    (hv.ringHom r : W.FunctionField) = algebraMap W.CoordinateRing W.FunctionField r := rfl
+
+theorem IsFinitePlace.centre_isPrime {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre.IsPrime :=
+  Ideal.IsPrime.comap _
+
+theorem IsFinitePlace.inv_mem {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) {r : W.CoordinateRing} (hr : r ∉ hv.centre) :
+    (algebraMap W.CoordinateRing W.FunctionField r)⁻¹ ∈ v.toValuationSubring := by
+  have hunit : IsUnit (hv.ringHom r) := by
+    rw [IsFinitePlace.centre, Ideal.mem_comap, IsLocalRing.mem_maximalIdeal,
+      mem_nonunits_iff, not_not] at hr
+    exact hr
+  obtain ⟨t, ht⟩ := hunit.exists_right_inv
+  have ht' : algebraMap W.CoordinateRing W.FunctionField r * (t : W.FunctionField) = 1 := by
+    have := congrArg (fun a : v.toValuationSubring => (a : W.FunctionField)) ht
+    simpa using this
+  rw [inv_eq_of_mul_eq_one_right ht']
+  exact t.2
+
+theorem IsFinitePlace.centre_ne_bot {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre ≠ ⊥ := by
+  intro hbot
+  apply v.ne_top'
+  rw [eq_top_iff]
+  rintro z -
+  obtain ⟨r, s, hs, hz⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  have hs0 : s ∉ hv.centre := by
+    rw [hbot, Ideal.mem_bot]
+    exact fun h => nonZeroDivisors.ne_zero hs h
+  rw [← hz, div_eq_mul_inv]
+  exact mul_mem (hv r) (hv.inv_mem hs0)
+
+variable [IsDedekindDomain W.CoordinateRing]
+
+theorem placeOfEquation_injective {x₁ y₁ x₂ y₂ : F} (h₁ : W.Equation x₁ y₁)
+    (h₂ : W.Equation x₂ y₂) (h : placeOfEquation h₁ = placeOfEquation h₂) :
+    x₁ = x₂ ∧ y₁ = y₂ :=
+  eq_of_XYIdeal_eq h₂
+    (congrArg HeightOneSpectrum.asIdeal (S13_ofHeightOneSpectrum_injective h))
+
+section CentredGate
+
+variable [DecidableEq F] [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W]
+
+namespace InfinitePlace
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+private theorem deg_eq_one :
+    (place : AlgebraicCurve.Place F W.FunctionField).deg = 1 := by
+  classical
+  exact
+    deg_placeOfPoint (W := W) 0
+
+omit [DecidableEq F] in
+theorem eq_of_not_isFinitePlace
+    (v : AlgebraicCurve.Place F W.FunctionField) (hv : ¬ IsFinitePlace v) :
+    v = place := by
+  classical
+  obtain ⟨P, rfl⟩ : ∃ P : W.Point, placeOfPoint P = v :=
+    ⟨(pointEquivPlace (W := W)).symm v, (pointEquivPlace (W := W)).apply_symm_apply v⟩
+  cases P with
+  | zero => rfl
+  | some x y h =>
+      exact absurd (placeOfPoint_some (W := W) h ▸ isFinitePlace_placeOfEquation h.left) hv
+
+end InfinitePlace
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+@[scoped simp]
+theorem placeOfPoint_zero : placeOfPoint (.zero : W.Point) = InfinitePlace.place := by
+  classical
+  exact
+    rfl
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_zero' : placeOfPoint (0 : W.Point) = InfinitePlace.place := by
+  classical
+  exact
+    rfl
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_surjective' : Function.Surjective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).surjective
+
+end CentredGate
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+
+namespace Affine
+
+scoped instance instHasPrincipalDivisorsFunctionField_s13 {F : Type*} [Field F] [CharZero F]
+    {W : Affine F} : HasPrincipalDivisors F W.FunctionField :=
+  hasPrincipalDivisors_functionField W
+
+section AutoNorm
+variable {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {V W : Affine F} [V.IsElliptic] [W.IsElliptic]
+
+end AutoNorm
+
+namespace IsogenyEndDatum
+
+variable {F : Type*} [Field F] [DecidableEq F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [GenusOnePlaceGate W] [AbelTheorem W]
+
+omit [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd_eq_pointEnd' (D : IsogenyEndDatum W) (hN : NormFormulaAlong F D.ι D.hfin) :
+    D.pointEnd hN = D.pointEnd' := rfl
+
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+
+scoped instance WeierstrassCurve.Affine.instHasPrincipalDivisorsFunctionField_s13e2
+    {F : Type*} [Field F] [CharZero F] (W : WeierstrassCurve.Affine F) :
+    AlgebraicCurve.HasPrincipalDivisors F W.FunctionField :=
+  WeierstrassCurve.Affine.hasPrincipalDivisors_functionField W
+
+namespace AlgebraicCurve
+
+namespace Place
+
+section MoreSinglePlace
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+theorem evalAt_div (hv : v.IsRational) {f g : F} (hf : f ∈ v.toValuationSubring)
+    (hg : g ≠ 0) (hg0 : v.ord g = 0) :
+    v.evalAt (f / g) = v.evalAt f / v.evalAt g := by
+  have hginv : g⁻¹ ∈ v.toValuationSubring :=
+    AlgebraicCurve.Place.mem_of_ord_nonneg v (inv_ne_zero hg) (by
+      rw [v.ord_inv, hg0]; exact neg_nonneg.mpr le_rfl)
+  rw [div_eq_mul_inv, v.evalAt_mul hv hf hginv, v.evalAt_inv hv hg hg0, div_eq_mul_inv]
+
+end MoreSinglePlace
+
+theorem mem_restrictAlong_iff {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F]
+    [Algebra K F']
+    (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') (f : F) :
+    f ∈ (w.restrictAlong φ hφ).toValuationSubring ↔ φ f ∈ w.toValuationSubring :=
+  Iff.rfl
+
+end Place
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+
+namespace Affine
+
+section FinitePlaceOfMem
+variable {F : Type*} [Field F] {W : Affine F}
+variable (v : AlgebraicCurve.Place F W.FunctionField)
+
+end FinitePlaceOfMem
+
+section RationalPlaceOfEquation
+variable {F : Type*} [Field F] [DecidableEq F] {W : Affine F} [W.IsElliptic]
+  [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [IsDedekindDomain W.CoordinateRing]
+
+end RationalPlaceOfEquation
+end Affine
+end WeierstrassCurve
+
+namespace ModularCurve
+
+theorem kw_fdn2_qephod_hend7_pmopKerCard_proved
+    (K : Type*) [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+    (E E' : WeierstrassCurve.Affine K) [E.IsElliptic]
+    [GenusOnePlaceGate E] [GenusOnePlaceGate.IsCentred E] [AbelTheorem E]
+    [E'.IsElliptic] [GenusOnePlaceGate E'] [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong K ι) :
+    Nat.card ((pointMapOfPushforward ι hι hfin
+      (normFormulaAlong_of_elliptic ι hfin)).ker) = finrankAlong K ι :=
+  natCard_ker_pointMapOfPushforward_eq_finrankAlong E E' ι hι hfin _
+
+end ModularCurve
+
+noncomputable local instance (priority := 50) s13DecEqAlgebraicClosure {K₀ : Type*} [Field K₀] :
+    DecidableEq (AlgebraicClosure K₀) := Classical.decEq _
+
+namespace WeierstrassCurve
+
+namespace Affine
+
+section S13GlobalGate
+variable {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F] (W : Affine F)
+    [W.IsElliptic]
+
+theorem s13_exists_gate : ∃ (g : GenusOnePlaceGate W),
+    @GenusOnePlaceGate.IsCentred F _ W g ∧ @AbelTheorem F _ _ g _ := by
+  have : IsDedekindDomain W.CoordinateRing := CoordinateRing.isDedekindDomain W
+  have : AlgebraicCurve.HasPrincipalDivisors F W.FunctionField :=
+    hasPrincipalDivisors_functionField W
+  exact exists_genusOnePlaceGate_isCentred_and_abelTheorem (W := W)
+
+noncomputable scoped instance (priority := 50) s13GlobalGate : GenusOnePlaceGate W :=
+  (s13_exists_gate W).choose
+scoped instance (priority := 50) s13GlobalGate_isCentred : GenusOnePlaceGate.IsCentred W :=
+  (s13_exists_gate W).choose_spec.1
+scoped instance (priority := 50) s13GlobalGate_abelTheorem : AbelTheorem W := (s13_exists_gate
+  W).choose_spec.2
+
+end S13GlobalGate
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+
+namespace Affine
+
+section S13FiniteOverRatFunc
+
+variable {F : Type*} [Field F] (W : Affine F)
+
+scoped instance s13_finiteDimensional_ratFunc_functionField : FiniteDimensional (RatFunc F)
+  W.FunctionField := by
+  have h1 : FiniteDimensional (RatFunc F)
+      (IntermediateField.adjoin (RatFunc F) {yCoord W}) :=
+    IntermediateField.adjoin.finiteDimensional isIntegral_yCoord
+  rw [adjoin_yCoord_eq_top] at h1
+  exact (IntermediateField.topEquiv
+    (F := RatFunc F) (E := W.FunctionField)).toLinearEquiv.finiteDimensional
+
+end S13FiniteOverRatFunc
+end Affine
+end WeierstrassCurve
+
+universe uK
+
+section
+
+namespace ModularCurve
+
+universe u
+
+section Setup
+
+variable (W : WeierstrassCurve ℚ) [W.IsElliptic]
+variable (F : Type u) [Field F] [Algebra ℚ F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra ℚ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower ℚ F F']
+
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+local notation3 "CR" => (W⁄F).toAffine.CoordinateRing
+local notation3 "FF" => (W⁄F).FunctionField
+
+def kw_coordinateRingBasis {R : Type*} [CommRing R] (V : Affine R) :
+    Module.Basis (ℕ × Fin 2) R V.CoordinateRing :=
+  (Polynomial.basisMonomials R).smulTower (CoordinateRing.basis V)
+
+end Setup
+end ModularCurve
+end
+
+section
+
+namespace WeierstrassCurve
+
+namespace Affine
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+
+namespace Affine
+
+variable {F : Type*} [Field F] (W : Affine F)
+
+variable {W}
+
+end Affine
+end WeierstrassCurve
+
+end
+
+section
+
+namespace ModularCurve
+
+universe u
+
+attribute [local instance] Classical.propDecidable
+
+section FGFieldDescentMint
+
+def KwD5BetweenCurvesFGFieldDescent : Prop :=
+  ∀ (K : Type uK) [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+    (E E' : WeierstrassCurve.Affine K) [E.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E] [WeierstrassCurve.Affine.AbelTheorem E]
+    [E'.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E']
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E']
+    [WeierstrassCurve.Affine.AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong K ι)
+    (N : ℕ) [NeZero N],
+    IsAddCyclic (AddMonoidHom.ker
+      (pointMapOfPushforward ι hι hfin (normFormulaAlong_of_elliptic ι hfin))) →
+    Nat.card (AddMonoidHom.ker
+      (pointMapOfPushforward ι hι hfin (normFormulaAlong_of_elliptic ι hfin))) = N →
+    letI : Algebra ℚ K := DivisionRing.toRatAlgebra
+    ∃ (K₀ : IntermediateField ℚ K) (_ : Countable K₀)
+      (E₀ E₀' : WeierstrassCurve K₀) (_ : E₀.IsElliptic) (_ : E₀'.IsElliptic)
+      (_ : E₀.map (algebraMap K₀ K) = E) (_ : E₀'.map (algebraMap K₀ K) = E')
+      (_ : (E₀⁄(AlgebraicClosure K₀)).IsElliptic) (_ : (E₀'⁄(AlgebraicClosure K₀)).IsElliptic)
+      (ι₀ : (E₀'⁄(AlgebraicClosure K₀)).toAffine.FunctionField →ₐ[AlgebraicClosure K₀]
+        (E₀⁄(AlgebraicClosure K₀)).toAffine.FunctionField)
+      (hι₀ : ι₀.toRingHom.IsIntegral) (hfin₀ : FiniteAlong (AlgebraicClosure K₀) ι₀),
+      IsAddCyclic (AddMonoidHom.ker
+        (pointMapOfPushforward ι₀ hι₀ hfin₀ (normFormulaAlong_of_elliptic ι₀ hfin₀))) ∧
+      Nat.card (AddMonoidHom.ker
+        (pointMapOfPushforward ι₀ hι₀ hfin₀ (normFormulaAlong_of_elliptic ι₀ hfin₀))) = N
+
+end FGFieldDescentMint
+end ModularCurve
+end
+
+section
+
+namespace WeierstrassCurve
+
+namespace Affine
+
+universe u
+variable {F : Type u} [Field F] {W : Affine F}
+
+theorem kw_functionField_algHom_ext {L : Type*} [Field L] [Algebra F L]
+    {f g : W.FunctionField →ₐ[F] L}
+    (hX : f (polyToFunctionField W X) = g (polyToFunctionField W X))
+    (hy : f (yGen W) = g (yGen W)) : f = g := by
+  have hCR : ∀ r : W.CoordinateRing,
+      f (algebraMap W.CoordinateRing W.FunctionField r)
+        = g (algebraMap W.CoordinateRing W.FunctionField r) := by
+    intro r
+    obtain ⟨p, rfl⟩ := AdjoinRoot.mk_surjective r
+    have hFX : ∀ c : F[X], f (algebraMap W.CoordinateRing W.FunctionField
+          (algebraMap F[X] W.CoordinateRing c))
+        = g (algebraMap W.CoordinateRing W.FunctionField
+          (algebraMap F[X] W.CoordinateRing c)) :=
+      fun c => DFunLike.congr_fun
+        (Polynomial.algHom_ext (f := (f.comp (IsScalarTower.toAlgHom F W.CoordinateRing
+            W.FunctionField)).comp (IsScalarTower.toAlgHom F F[X] W.CoordinateRing))
+          (g := (g.comp (IsScalarTower.toAlgHom F W.CoordinateRing W.FunctionField)).comp
+            (IsScalarTower.toAlgHom F F[X] W.CoordinateRing)) hX) c
+    have hFX' : ∀ c : F[X], f (algebraMap W.CoordinateRing W.FunctionField
+          (AdjoinRoot.mk W.polynomial (C c)))
+        = g (algebraMap W.CoordinateRing W.FunctionField
+          (AdjoinRoot.mk W.polynomial (C c))) := fun c => by
+      rw [show AdjoinRoot.mk W.polynomial (C c) = algebraMap F[X] W.CoordinateRing c from rfl]
+      exact hFX c
+    have hy' : f (algebraMap W.CoordinateRing W.FunctionField (AdjoinRoot.mk W.polynomial Y))
+        = g (algebraMap W.CoordinateRing W.FunctionField (AdjoinRoot.mk W.polynomial Y)) := hy
+    induction p using Polynomial.induction_on with
+    | C c => exact hFX' c
+    | monomial n c _ => simp only [map_mul, map_pow, hy', hFX' c]
+    | add p q hp hq => simp only [map_add, hp, hq]
+  refine AlgHom.ext fun a => ?_
+  obtain ⟨p, q, hq, rfl⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) a
+  simp only [map_div₀, hCR p, hCR q]
+
+end Affine
+end WeierstrassCurve
+
+end
+
+section
+
+namespace WeierstrassCurve
+
+namespace Affine
+
+universe u
+
+variable {F : Type u} [Field F]
+
+section GenericPoint
+
+variable {W : Affine F}
+
+end GenericPoint
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+open WeierstrassCurve.Affine.Point
+
+section
+
+namespace WeierstrassCurve
+
+namespace Affine
+
+universe u
+
+variable {F : Type u} [Field F]
+
+section AdjoinSurjective
+
+variable {W : Affine F} (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b)
+
+local notation "ι" => algebraMap F W.FunctionField
+
+theorem transcendental_polyToFunctionField_X :
+    Transcendental F (polyToFunctionField W X) := by
+  rw [transcendental_iff]
+  intro p hp
+  rw [← polyToFunctionField_eq_aeval] at hp
+  exact polyToFunctionField_injective (by simpa using hp)
+
+end AdjoinSurjective
+end Affine
+end WeierstrassCurve
+end
+end
+
+section
+
+universe u
+
+namespace WeierstrassCurve
+
+namespace Affine
+
+variable {F : Type u} [Field F]
+
+section PointPullbackTo
+
+variable {W : Affine F} {L : Type u} [Field L] [Algebra F L]
+
+theorem eval₂_polynomial_of_equation_map_target {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) :
+    W.polynomial.eval₂
+      (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom yP = 0 := by
+  rw [equation_iff'] at h
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆] at h
+  simp only [WeierstrassCurve.Affine.polynomial, eval₂_add, eval₂_sub, eval₂_mul, eval₂_pow,
+    eval₂_X, eval₂_C, AlgHom.toRingHom_eq_coe, RingHom.coe_coe, map_add, map_mul, map_pow,
+    Polynomial.aeval_C, Polynomial.aeval_X]
+  linear_combination h
+
+def pointPullbackCoordHomTo {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) :
+    W.CoordinateRing →ₐ[F] L where
+  __ := AdjoinRoot.lift
+    (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom
+    yP (eval₂_polynomial_of_equation_map_target h)
+  commutes' c := by
+    change AdjoinRoot.lift _ _ (eval₂_polynomial_of_equation_map_target h) (algebraMap F _ c)
+      = algebraMap F L c
+    rw [CoordinateRing.algebraMap_eq_mk_C_C, AdjoinRoot.lift_mk, eval₂_C]
+    exact Polynomial.aeval_C _ c
+
+theorem pointPullbackCoordHomTo_mk {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) (g : F[X][Y]) :
+    pointPullbackCoordHomTo h (CoordinateRing.mk W g)
+      = g.eval₂ (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom yP :=
+  AdjoinRoot.lift_mk (eval₂_polynomial_of_equation_map_target h) g
+
+theorem pointPullbackCoordHomTo_comp_algebraMap {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) :
+    (pointPullbackCoordHomTo h).toRingHom.comp (algebraMap F[X] W.CoordinateRing)
+      = (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom := by
+  refine RingHom.ext fun p => ?_
+  change pointPullbackCoordHomTo h (algebraMap F[X] _ p) = _
+  rw [algebraMap_polynomial_eq_mk_C, pointPullbackCoordHomTo_mk, eval₂_C]
+
+theorem pointPullbackCoordHomTo_injective {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    Function.Injective (pointPullbackCoordHomTo h) := by
+  have hker : RingHom.ker (pointPullbackCoordHomTo h).toRingHom = ⊥ := by
+    have : Module.Finite F[X] W.CoordinateRing :=
+      Module.Finite.of_basis (CoordinateRing.basis W)
+    refine Ideal.eq_bot_of_under_eq_bot (R := F[X]) ?_
+    rw [Ideal.under_def, RingHom.comap_ker, pointPullbackCoordHomTo_comp_algebraMap,
+      ← RingHom.injective_iff_ker_eq_bot]
+    exact hx
+  exact (RingHom.injective_iff_ker_eq_bot (pointPullbackCoordHomTo h).toRingHom).mpr hker
+
+def pointPullbackHomTo {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    W.FunctionField →ₐ[F] L :=
+  IsFractionRing.liftAlgHom (pointPullbackCoordHomTo_injective h hx)
+
+theorem pointPullbackHomTo_algebraMap {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) (r : W.CoordinateRing) :
+    pointPullbackHomTo h hx (algebraMap W.CoordinateRing W.FunctionField r)
+      = pointPullbackCoordHomTo h r :=
+  IsFractionRing.lift_algebraMap (pointPullbackCoordHomTo_injective h hx) r
+
+theorem pointPullbackHomTo_polyToFunctionField_X {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    pointPullbackHomTo h hx (polyToFunctionField W X) = xP := by
+  rw [polyToFunctionField_apply, pointPullbackHomTo_algebraMap,
+    algebraMap_polynomial_eq_mk_C, pointPullbackCoordHomTo_mk, eval₂_C]
+  exact Polynomial.aeval_X _
+
+theorem pointPullbackHomTo_yGen {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    pointPullbackHomTo h hx (yGen W) = yP := by
+  change pointPullbackHomTo h hx (algebraMap _ _ (CoordinateRing.mk W Y)) = _
+  rw [pointPullbackHomTo_algebraMap, pointPullbackCoordHomTo_mk]
+  exact eval₂_X _ _
+
+end PointPullbackTo
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+namespace ModularCurve
+
+universe u
+
+section SetupBCG
+
+variable {R₀ : Type u} [Field R₀]
+variable (W : WeierstrassCurve R₀) [W.IsElliptic]
+variable (F : Type u) [Field F] [Algebra R₀ F] [DecidableEq F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra R₀ F'] [DecidableEq F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower R₀ F F']
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [Algebra R₀ F] [CharZero F] [CharZero F'] [IsScalarTower R₀ F F'] in
+theorem kw_transcendental_polyToFunctionField_X_over_baseGeneralNoAC :
+    Transcendental F (polyToFunctionField (W⁄F') X) := by
+  classical
+  exact
+    Transcendental.of_tower_top F (L := F')
+      (transcendental_polyToFunctionField_X (W := (W⁄F')))
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [CharZero F'] in
+theorem kw_equation_map_polyToFunctionField_yGen_over_baseGeneralNoAC :
+    ((W⁄F).map (algebraMap F (W⁄F').FunctionField)).toAffine.Equation
+      (polyToFunctionField (W⁄F') X) (yGen (W⁄F')) := by
+  classical
+  have hcurve : (W⁄F).map (algebraMap F (W⁄F').FunctionField)
+      = (W⁄F').map (algebraMap F' (W⁄F').FunctionField) := by
+    change (W.map _).map _ = (W.map _).map _
+    rw [WeierstrassCurve.map_map, WeierstrassCurve.map_map]
+    congr 1
+    exact ((IsScalarTower.algebraMap_eq R₀ F (W⁄F').FunctionField).symm).trans
+      (IsScalarTower.algebraMap_eq R₀ F' (W⁄F').FunctionField)
+  exact hcurve ▸ equation_map_polyToFunctionField_yGen (W := (W⁄F'))
+
+def kw_functionFieldMapAlongGeneralNoAC : (W⁄F).FunctionField →ₐ[F] (W⁄F').FunctionField :=
+  pointPullbackHomTo (kw_equation_map_polyToFunctionField_yGen_over_baseGeneralNoAC W F F')
+    ((injective_iff_map_eq_zero _).mpr fun p hp =>
+      transcendental_iff.mp (kw_transcendental_polyToFunctionField_X_over_baseGeneralNoAC W F F') p
+        hp)
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [CharZero F'] in
+theorem kw_functionFieldMapAlongGeneralNoAC_polyToFunctionField_X :
+    kw_functionFieldMapAlongGeneralNoAC W F F' (polyToFunctionField (W⁄F) X)
+      = polyToFunctionField (W⁄F') X := by
+  classical
+  exact
+    pointPullbackHomTo_polyToFunctionField_X _ _
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [CharZero F'] in
+theorem kw_functionFieldMapAlongGeneralNoAC_yGen :
+    kw_functionFieldMapAlongGeneralNoAC W F F' (yGen (W⁄F)) = yGen (W⁄F') := by
+  classical
+  exact
+    pointPullbackHomTo_yGen _ _
+
+def KwFunctionFieldTensorIsDomainGeneralNoAC : Prop :=
+  IsDomain ((W⁄F).FunctionField ⊗[F] F')
+
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+scoped instance kw_isScalarTower_base_right_tensorGeneralNoAC :
+    IsScalarTower R₀ F' ((W⁄F).FunctionField ⊗[F] F') := by
+  refine IsScalarTower.of_algebraMap_eq' (RingHom.ext fun r => ?_)
+  rw [RingHom.comp_apply, Algebra.TensorProduct.right_algebraMap_apply,
+    IsScalarTower.algebraMap_apply R₀ F F',
+    show algebraMap R₀ ((W⁄F).FunctionField ⊗[F] F') r
+      = (algebraMap F ((W⁄F).FunctionField ⊗[F] F')) (algebraMap R₀ F r) from
+        IsScalarTower.algebraMap_apply R₀ F ((W⁄F).FunctionField ⊗[F] F') r,
+    Algebra.TensorProduct.algebraMap_apply, Algebra.algebraMap_eq_smul_one,
+    Algebra.algebraMap_eq_smul_one, TensorProduct.smul_tmul, Algebra.algebraMap_eq_smul_one]
+
+section FracHom
+
+variable [IsDomain ((W⁄F).FunctionField ⊗[F] F')]
+
+scoped instance kw_isScalarTower_base_right_fracTensorGeneralNoAC :
+    IsScalarTower R₀ F' (FractionRing ((W⁄F).FunctionField ⊗[F] F')) :=
+  IsScalarTower.of_algebraMap_eq fun r =>
+    (IsScalarTower.algebraMap_apply R₀ ((W⁄F).FunctionField ⊗[F] F')
+        (FractionRing ((W⁄F).FunctionField ⊗[F] F')) r).trans <|
+      (congrArg (algebraMap ((W⁄F).FunctionField ⊗[F] F')
+          (FractionRing ((W⁄F).FunctionField ⊗[F] F')))
+        (IsScalarTower.algebraMap_apply R₀ F' ((W⁄F).FunctionField ⊗[F] F') r)).trans
+      (IsScalarTower.algebraMap_apply F' ((W⁄F).FunctionField ⊗[F] F')
+        (FractionRing ((W⁄F).FunctionField ⊗[F] F')) (algebraMap R₀ F' r)).symm
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [CharZero F'] [IsDomain ((W⁄F).FunctionField ⊗[F] F')] in
+theorem kw_equation_tensorFracXYGeneralNoAC :
+    ((W⁄F').map (algebraMap F' (FractionRing ((W⁄F).FunctionField ⊗[F] F')))).toAffine.Equation
+      (algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+        ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')))
+      (algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+        ((yGen (W⁄F)) ⊗ₜ[F] (1 : F'))) := by
+  classical
+  have hcurve : (W⁄F').map (algebraMap F' (FractionRing ((W⁄F).FunctionField ⊗[F] F')))
+      = W⁄(FractionRing ((W⁄F).FunctionField ⊗[F] F')) := by
+    change (W.map _).map _ = W.map _
+    rw [WeierstrassCurve.map_map]; congr 1
+    exact (IsScalarTower.algebraMap_eq R₀ F'
+      (FractionRing ((W⁄F).FunctionField ⊗[F] F'))).symm
+  rw [hcurve]
+  exact Equation.baseChange (W := W) (S := R₀)
+    (f := (IsScalarTower.toAlgHom R₀ ((W⁄F).FunctionField ⊗[F] F')
+            (FractionRing ((W⁄F).FunctionField ⊗[F] F'))).comp
+          (Algebra.TensorProduct.includeLeft (R := F) (S := R₀)))
+    (equation_map_polyToFunctionField_yGen (W := (W⁄F)))
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [Algebra R₀ F'] [CharZero F'] [IsScalarTower R₀ F F']
+  [IsDomain ((W⁄F).FunctionField ⊗[F] F')] in
+theorem kw_transcendental_tensorFracXGeneralNoAC :
+    Function.Injective (Polynomial.aeval (R := F')
+      (algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+        ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')))) := by
+  classical
+  rw [show algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+        ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F'))
+      = IsScalarTower.toAlgHom F' ((W⁄F).FunctionField ⊗[F] F')
+          (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+          ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')) from rfl,
+    Polynomial.aeval_algHom]
+  refine (IsFractionRing.injective ((W⁄F).FunctionField ⊗[F] F')
+    (FractionRing ((W⁄F).FunctionField ⊗[F] F'))).comp ?_
+  have heq : (Polynomial.aeval (R := F')
+        ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')
+          : (W⁄F).FunctionField ⊗[F] F')).toRingHom
+      = ((Algebra.TensorProduct.map
+            (Polynomial.aeval (R := F) (polyToFunctionField (W⁄F) X))
+            (AlgHom.id F F')).toRingHom.comp
+          (Algebra.TensorProduct.comm F F' F[X]).toAlgHom.toRingHom).comp
+          (polyEquivTensor' F F').toAlgHom.toRingHom := by
+    refine Polynomial.ringHom_ext (fun c => ?_) ?_
+    · change aeval _ (C c) = Algebra.TensorProduct.map _ _
+          (Algebra.TensorProduct.comm F F' F[X] (polyEquivTensor' F F' (C c)))
+      rw [show (polyEquivTensor' F F') (C c) = c ⊗ₜ[F] (1 : F[X]) from by
+            rw [coe_polyEquivTensor', polyEquivTensor_apply, eval₂_C]; rfl,
+        Algebra.TensorProduct.comm_tmul, Algebra.TensorProduct.map_tmul, Polynomial.aeval_C,
+        Algebra.TensorProduct.right_algebraMap_apply, AlgHom.coe_id, id_eq, map_one]
+    · change aeval _ (X : F'[X]) = Algebra.TensorProduct.map _ _
+          (Algebra.TensorProduct.comm F F' F[X] (polyEquivTensor' F F' X))
+      rw [show (polyEquivTensor' F F') X = (1:F') ⊗ₜ[F] (X : F[X]) from by
+            rw [coe_polyEquivTensor', polyEquivTensor_apply, eval₂_X],
+        Algebra.TensorProduct.comm_tmul, Algebra.TensorProduct.map_tmul, Polynomial.aeval_X,
+        AlgHom.coe_id, id_eq, Polynomial.aeval_X]
+  have hinj : Function.Injective
+      (((Algebra.TensorProduct.map
+          (Polynomial.aeval (R := F) (polyToFunctionField (W⁄F) X))
+          (AlgHom.id F F')).toRingHom.comp
+        (Algebra.TensorProduct.comm F F' F[X]).toAlgHom.toRingHom).comp
+        (polyEquivTensor' F F').toAlgHom.toRingHom) :=
+    ((Module.Flat.rTensor_preserves_injective_linearMap (M := F')
+        (Polynomial.aeval (R := F) (polyToFunctionField (W⁄F) X)).toLinearMap
+        ((injective_iff_map_eq_zero _).mpr fun p hp =>
+          transcendental_iff.mp (transcendental_polyToFunctionField_X (W := (W⁄F))) p hp)).comp
+      (Algebra.TensorProduct.comm F F' F[X]).injective).comp (polyEquivTensor' F F').injective
+  intro p q hpq
+  refine hinj ?_
+  have := DFunLike.congr_fun heq
+  exact (this p).symm.trans (hpq.trans (this q))
+
+def kw_functionFieldTensorFracHomGeneralNoAC :
+    (W⁄F').FunctionField →ₐ[F'] FractionRing ((W⁄F).FunctionField ⊗[F] F') :=
+  pointPullbackHomTo (kw_equation_tensorFracXYGeneralNoAC W F F')
+    (kw_transcendental_tensorFracXGeneralNoAC W F F')
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [CharZero F'] in
+theorem kw_functionFieldTensorFracHomGeneralNoAC_X :
+    kw_functionFieldTensorFracHomGeneralNoAC W F F' (polyToFunctionField (W⁄F') X)
+      = algebraMap ((W⁄F).FunctionField ⊗[F] F') _
+          ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')) := by
+  classical
+  exact
+    pointPullbackHomTo_polyToFunctionField_X _ _
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [CharZero F'] in
+theorem kw_functionFieldTensorFracHomGeneralNoAC_yGen :
+    kw_functionFieldTensorFracHomGeneralNoAC W F F' (yGen (W⁄F'))
+      = algebraMap ((W⁄F).FunctionField ⊗[F] F') _ ((yGen (W⁄F)) ⊗ₜ[F] (1 : F')) := by
+  classical
+  exact
+    pointPullbackHomTo_yGen _ _
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [CharZero F'] in
+theorem kw_functionFieldTensorFracHomGeneralNoAC_bijective :
+    Function.Bijective (kw_functionFieldTensorFracHomGeneralNoAC W F F') := by
+  classical
+  refine ⟨(kw_functionFieldTensorFracHomGeneralNoAC W F F').injective, ?_⟩
+  set ψ := kw_functionFieldTensorFracHomGeneralNoAC W F F'
+  have hκ : (ψ.restrictScalars F).comp (kw_functionFieldMapAlongGeneralNoAC W F F')
+      = (IsScalarTower.toAlgHom F ((W⁄F).FunctionField ⊗[F] F')
+          (FractionRing ((W⁄F).FunctionField ⊗[F] F'))).comp
+          (Algebra.TensorProduct.includeLeft (R := F)) := by
+    refine kw_functionField_algHom_ext ?_ ?_
+    · change ψ (kw_functionFieldMapAlongGeneralNoAC W F F' (polyToFunctionField (W⁄F) X)) = _
+      rw [kw_functionFieldMapAlongGeneralNoAC_polyToFunctionField_X,
+        kw_functionFieldTensorFracHomGeneralNoAC_X]
+      rfl
+    · change ψ (kw_functionFieldMapAlongGeneralNoAC W F F' (yGen (W⁄F))) = _
+      rw [kw_functionFieldMapAlongGeneralNoAC_yGen, kw_functionFieldTensorFracHomGeneralNoAC_yGen]
+      rfl
+  have hT_sub : ∀ t : (W⁄F).FunctionField ⊗[F] F',
+      algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing _) t ∈ ψ.toRingHom.fieldRange := by
+    intro t
+    induction t with
+    | add _ _ hx hy => simp only [map_add]; exact add_mem hx hy
+    | tmul a c =>
+      rw [show (a ⊗ₜ[F] c : (W⁄F).FunctionField ⊗[F] F') = (a ⊗ₜ[F] 1) * (1 ⊗ₜ[F] c) from
+            by rw [Algebra.TensorProduct.tmul_mul_tmul, mul_one, one_mul],
+        map_mul]
+      refine mul_mem ?_ ⟨algebraMap F' _ c, ?_⟩
+      · exact ⟨kw_functionFieldMapAlongGeneralNoAC W F F' a, DFunLike.congr_fun hκ a⟩
+      · simp only [AlgHom.toRingHom_eq_coe, RingHom.coe_coe, ψ.commutes,
+          IsScalarTower.algebraMap_apply F' ((W⁄F).FunctionField ⊗[F] F')
+            (FractionRing ((W⁄F).FunctionField ⊗[F] F')),
+          Algebra.TensorProduct.right_algebraMap_apply]
+  intro z
+  obtain ⟨t, s, _, rfl⟩ := IsFractionRing.div_surjective
+    (A := (W⁄F).FunctionField ⊗[F] F') (K := FractionRing _) z
+  exact div_mem (hT_sub t) (hT_sub s)
+
+def kw_functionFieldTensorFracEquivGeneralNoAC :
+    (W⁄F').FunctionField ≃ₐ[F'] FractionRing ((W⁄F).FunctionField ⊗[F] F') :=
+  AlgEquiv.ofBijective _ (kw_functionFieldTensorFracHomGeneralNoAC_bijective W F F')
+
+end FracHom
+end SetupBCG
+
+section SetupBCGD
+
+variable {R₀ : Type u} [Field R₀]
+variable (W : WeierstrassCurve R₀) [W.IsElliptic]
+variable (F : Type u) [Field F] [Algebra R₀ F] [DecidableEq F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra R₀ F'] [DecidableEq F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower R₀ F F']
+
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+section FFDomain
+
+local notation3 "CR" => (W⁄F).toAffine.CoordinateRing
+local notation3 "FFₗ" => (W⁄F).FunctionField
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [Algebra R₀ F'] [CharZero F'] [IsScalarTower R₀ F F'] in
+theorem kw_coordinateRingMap_basisGeneralNoAC (i : ℕ × Fin 2) :
+    CoordinateRing.map (W⁄F).toAffine (algebraMap F F')
+        (kw_coordinateRingBasis (W⁄F).toAffine i)
+      = kw_coordinateRingBasis ((W⁄F).toAffine.map (algebraMap F F')) i := by
+  classical
+  obtain ⟨n, j⟩ := i
+  simp only [kw_coordinateRingBasis, Module.Basis.smulTower_apply,
+    Polynomial.coe_basisMonomials, CoordinateRing.map_smul]
+  congr 1
+  · simp [Polynomial.map_monomial]
+  · rcases j with ⟨j, hj⟩
+    interval_cases j <;>
+      simp [CoordinateRing.basis_apply, CoordinateRing.map,
+        AdjoinRoot.lift_root, AdjoinRoot.powerBasis'_gen]
+
+def kw_coordinateRingMapAlongGeneralNoAC :
+    CR →ₐ[F] ((W⁄F).toAffine.map (algebraMap F F')).CoordinateRing where
+  __ := CoordinateRing.map (W⁄F).toAffine (algebraMap F F')
+  commutes' r := by
+    simp only [RingHom.toMonoidHom_eq_coe, OneHom.toFun_eq_coe, MonoidHom.toOneHom_coe,
+      MonoidHom.coe_ofClass]
+    change CoordinateRing.map (W⁄F).toAffine (algebraMap F F') (algebraMap F CR r) = algebraMap F _
+      r
+    rw [IsScalarTower.algebraMap_apply F F[X] CR,
+      show (algebraMap F F[X] r) = Polynomial.C r from rfl,
+      show (algebraMap F[X] CR) (C r) = (C r : F[X]) • (1 : CR) by
+        rw [Algebra.smul_def, mul_one],
+      CoordinateRing.map_smul, map_one, Polynomial.map_C,
+      IsScalarTower.algebraMap_apply F F' ((W⁄F).toAffine.map (algebraMap F F')).CoordinateRing,
+      IsScalarTower.algebraMap_apply F' F'[X]
+        ((W⁄F).toAffine.map (algebraMap F F')).CoordinateRing,
+      show (algebraMap F' F'[X]) ((algebraMap F F') r) = Polynomial.C ((algebraMap F F') r)
+        from rfl,
+      Algebra.smul_def, mul_one]
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [Algebra R₀ F'] [CharZero F'] [IsScalarTower R₀ F F'] in
+theorem kw_coordinateRingTensor_isDomainGeneralNoAC : IsDomain (CR ⊗[F] F') := by
+  classical
+  suffices h : IsDomain (F' ⊗[F] CR) by
+    have := h
+    exact Function.Injective.isDomain (Algebra.TensorProduct.comm F CR F').toRingHom
+      (Algebra.TensorProduct.comm F CR F').injective
+  set W'' := (W⁄F).toAffine.map (algebraMap F F') with hW''
+  let θ : F' ⊗[F] CR →ₐ[F'] W''.CoordinateRing :=
+    AlgHom.liftEquiv F F' CR W''.CoordinateRing (kw_coordinateRingMapAlongGeneralNoAC W F F')
+  have hθ : Function.Injective θ := by
+    let bT : Module.Basis (ℕ × Fin 2) F' (F' ⊗[F] CR) :=
+      Algebra.TensorProduct.basis F' (kw_coordinateRingBasis (W⁄F).toAffine)
+    let bD : Module.Basis (ℕ × Fin 2) F' W''.CoordinateRing := kw_coordinateRingBasis W''
+    have key : ∀ i, θ.toLinearMap (bT i) = (bT.equiv bD (Equiv.refl _)) (bT i) := fun i => by
+      rw [Module.Basis.equiv_apply, Equiv.refl_apply, AlgHom.toLinearMap_apply]
+      simp only [bT, Algebra.TensorProduct.basis_apply, θ, AlgHom.liftEquiv_tmul, one_smul]
+      exact kw_coordinateRingMap_basisGeneralNoAC W F F' i
+    have heq : (θ : F' ⊗[F] CR → W''.CoordinateRing) = bT.equiv bD (Equiv.refl _) :=
+      funext fun x => DFunLike.congr_fun (bT.ext key : θ.toLinearMap = _) x
+    exact heq ▸ (bT.equiv bD (Equiv.refl _)).injective
+  exact Function.Injective.isDomain θ.toRingHom hθ
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [Algebra R₀ F'] [CharZero F'] [IsScalarTower R₀ F F'] in
+theorem kw_functionFieldTensorIsDomain_dischargeGeneralNoAC :
+    KwFunctionFieldTensorIsDomainGeneralNoAC W F F' := by
+  classical
+  change IsDomain (FFₗ ⊗[F] F')
+  have hCR : IsDomain (CR ⊗[F] F') := kw_coordinateRingTensor_isDomainGeneralNoAC W F F'
+  let : Algebra (CR ⊗[F] F') (FFₗ ⊗[F] F') :=
+    (Algebra.TensorProduct.map (IsScalarTower.toAlgHom F CR FFₗ)
+      (AlgHom.id F F')).toRingHom.toAlgebra
+  have hst : IsScalarTower CR (CR ⊗[F] F') (FFₗ ⊗[F] F') :=
+    IsScalarTower.of_algebraMap_eq (R := CR) (S := CR ⊗[F] F') (A := FFₗ ⊗[F] F') fun c => by
+      change Algebra.TensorProduct.map (IsScalarTower.toAlgHom F CR FFₗ) (AlgHom.id F F')
+          (algebraMap CR (CR ⊗[F] F') c) = algebraMap CR (FFₗ ⊗[F] F') c
+      rfl
+  have hloc : IsLocalization
+      (Algebra.algebraMapSubmonoid (CR ⊗[F] F') (nonZeroDivisors CR)) (FFₗ ⊗[F] F') :=
+    IsLocalization.tensorProduct_tensorProduct F F' (nonZeroDivisors CR) FFₗ (by
+      ext x; simp [RingHom.algebraMap_toAlgebra, Algebra.TensorProduct.map_tmul])
+  have hle : Algebra.algebraMapSubmonoid (CR ⊗[F] F') (nonZeroDivisors CR)
+      ≤ nonZeroDivisors (CR ⊗[F] F') := by
+    rintro _ ⟨c, hc, rfl⟩
+    refine mem_nonZeroDivisors_of_ne_zero ?_
+    have hinj : Function.Injective (algebraMap CR (CR ⊗[F] F')) :=
+      Algebra.TensorProduct.includeLeft_injective (S := F) (algebraMap F F').injective
+    exact fun h => (nonZeroDivisors.ne_zero hc) (hinj (by
+      simp only [_root_.map_zero] at h ⊢; exact h))
+  exact IsLocalization.isDomain_of_le_nonZeroDivisors
+    (M := Algebra.algebraMapSubmonoid (CR ⊗[F] F') (nonZeroDivisors CR)) _ hle
+
+end FFDomain
+end SetupBCGD
+end ModularCurve
+end
+
+section
+
+namespace ModularCurve
+
+section Carriers
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K]
+variable {K₀ : IntermediateField ℚ K}
+variable (E₀ : WeierstrassCurve K₀) [E₀.IsElliptic]
+
+local notation "E" => E₀.map (algebraMap K₀ K)
+
+def kw_iA_polyDescend (p : Polynomial K) (hmem : ∀ j, p.coeff j ∈ K₀) : Polynomial K₀ :=
+  ∑ j ∈ p.support, Polynomial.C (⟨p.coeff j, hmem j⟩ : K₀) * Polynomial.X ^ j
+
+omit [DecidableEq K] in
+theorem kw_iA_polyDescend_map (p : Polynomial K) (hmem : ∀ j, p.coeff j ∈ K₀) :
+    (kw_iA_polyDescend p hmem).map (algebraMap K₀ K) = p := by
+  classical
+  unfold kw_iA_polyDescend; rw [Polynomial.map_sum]
+  conv_rhs => rw [p.as_sum_support_C_mul_X_pow]
+  exact Finset.sum_congr rfl fun j _ => by
+    rw [Polynomial.map_mul, Polynomial.map_C, Polynomial.map_pow, Polynomial.map_X]; rfl
+
+def kw_iA_crCoeffsIn (c : (E).toAffine.CoordinateRing) : Prop :=
+  ∀ (i : Fin 2) (j : ℕ),
+    ((CoordinateRing.basis (E).toAffine).repr c i).coeff j ∈ K₀
+
+def kw_iA_crDescend (c : (E).toAffine.CoordinateRing) (hmem : kw_iA_crCoeffsIn E₀ c) :
+    E₀.toAffine.CoordinateRing :=
+  ∑ i : Fin 2, (kw_iA_polyDescend
+      ((CoordinateRing.basis (E).toAffine).repr c i) (hmem i))
+    • (CoordinateRing.basis E₀.toAffine) i
+
+omit [DecidableEq K] in
+omit [E₀.IsElliptic] in
+theorem kw_iA_crDescend_map (c : (E).toAffine.CoordinateRing)
+    (hmem : kw_iA_crCoeffsIn E₀ c) :
+    CoordinateRing.map E₀.toAffine (algebraMap K₀ K) (kw_iA_crDescend E₀ c hmem) = c := by
+  classical
+  unfold kw_iA_crDescend; rw [map_sum]
+  conv_rhs => rw [← (CoordinateRing.basis (E).toAffine).sum_repr c]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [CoordinateRing.map_smul]; congr 1
+  · exact kw_iA_polyDescend_map _ (hmem i)
+  · rcases Fin.exists_fin_two.mp ⟨i, rfl⟩ with h | h
+    · exact h ▸ by rw [CoordinateRing.basis_zero, CoordinateRing.basis_zero, map_one]
+    · exact h ▸ by rw [CoordinateRing.basis_one, CoordinateRing.basis_one,
+        CoordinateRing.map_mk, Polynomial.map_X]
+
+omit [DecidableEq K] in
+omit [E₀.IsElliptic] in
+theorem kw_iA_phiEquation :
+    (E₀.map (algebraMap K₀ (E).toAffine.FunctionField)).toAffine.Equation
+      (polyToFunctionField (E).toAffine X) (yGen (E).toAffine) := by
+  classical
+  have h : E₀.map (algebraMap K₀ (E).toAffine.FunctionField)
+      = (E).map (algebraMap K (E).toAffine.FunctionField) := by
+    rw [show (algebraMap K₀ (E).toAffine.FunctionField)
+        = (algebraMap K (E).toAffine.FunctionField).comp (algebraMap K₀ K) from
+      IsScalarTower.algebraMap_eq K₀ K (E).toAffine.FunctionField,
+      ← WeierstrassCurve.map_map]
+  exact h ▸ equation_map_polyToFunctionField_yGen (W := (E).toAffine)
+
+omit [DecidableEq K] in
+omit [E₀.IsElliptic] in
+theorem kw_iA_phiTranscendental :
+    Function.Injective
+      (Polynomial.aeval (R := K₀) (polyToFunctionField (E).toAffine X)) := by
+  classical
+  exact
+    (injective_iff_map_eq_zero _).mpr fun p hp => transcendental_iff.mp
+      ((transcendental_polyToFunctionField_X (W := (E).toAffine)).restrictScalars
+        (R := K₀) (algebraMap K₀ K).injective) p hp
+
+def kw_iA_phi : E₀.toAffine.FunctionField →ₐ[K₀] (E).toAffine.FunctionField :=
+  pointPullbackHomTo (kw_iA_phiEquation E₀) (kw_iA_phiTranscendental E₀)
+
+omit [DecidableEq K] in
+omit [Algebra ℚ K] in
+theorem kw_iA_polyToFF_eq_aeval (W : WeierstrassCurve.Affine K) :
+    polyToFunctionField W = (Polynomial.aeval (R := K) (polyToFunctionField W X)).toRingHom := by
+  classical
+  refine Polynomial.ringHom_ext (fun c => ?_) ?_
+  · rw [AlgHom.toRingHom_eq_coe, RingHom.coe_coe, Polynomial.aeval_C,
+      polyToFunctionField_apply,
+      show (algebraMap (Polynomial K) W.CoordinateRing) (C c)
+        = (algebraMap K W.CoordinateRing) c from
+        (IsScalarTower.algebraMap_apply K (Polynomial K) W.CoordinateRing c).symm,
+      ← IsScalarTower.algebraMap_apply K W.CoordinateRing W.FunctionField]
+  · rw [AlgHom.toRingHom_eq_coe, RingHom.coe_coe, Polynomial.aeval_X]
+
+omit [DecidableEq K] in
+omit [E₀.IsElliptic] in
+theorem kw_iA_phiCRCompat (c₀ : E₀.toAffine.CoordinateRing) :
+    kw_iA_phi E₀ (algebraMap E₀.toAffine.CoordinateRing E₀.toAffine.FunctionField c₀)
+      = algebraMap (E).toAffine.CoordinateRing (E).toAffine.FunctionField
+          (CoordinateRing.map E₀.toAffine (algebraMap K₀ K) c₀) := by
+  classical
+  obtain ⟨g, rfl⟩ := AdjoinRoot.mk_surjective c₀
+  unfold kw_iA_phi
+  rw [pointPullbackHomTo_algebraMap, CoordinateRing.map_mk]
+  revert g
+  suffices h : ((pointPullbackCoordHomTo (kw_iA_phiEquation E₀)).toRingHom.comp
+        (CoordinateRing.mk E₀.toAffine))
+      = ((algebraMap (E).toAffine.CoordinateRing (E).toAffine.FunctionField).comp
+          (CoordinateRing.mk (E).toAffine)).comp
+        (Polynomial.mapRingHom (Polynomial.mapRingHom (algebraMap K₀ K))) by
+    intro g; exact congrFun (congrArg DFunLike.coe h) g
+  refine Polynomial.ringHom_ext (fun p => ?_) ?_
+  · simp only [RingHom.comp_apply, AlgHom.toRingHom_eq_coe, RingHom.coe_coe,
+      Polynomial.coe_mapRingHom, Polynomial.map_C]
+    rw [← algebraMap_polynomial_eq_mk_C, ← algebraMap_polynomial_eq_mk_C,
+      ← polyToFunctionField_apply]
+    have hlhs := congrFun (congrArg DFunLike.coe
+      (pointPullbackCoordHomTo_comp_algebraMap (kw_iA_phiEquation E₀))) p
+    simp only [RingHom.comp_apply, AlgHom.toRingHom_eq_coe, RingHom.coe_coe] at hlhs
+    rw [hlhs, show polyToFunctionField (E).toAffine (p.map (algebraMap K₀ K))
+        = (Polynomial.aeval (R := K) (polyToFunctionField (E).toAffine X))
+            (p.map (algebraMap K₀ K)) from
+      congrFun (congrArg DFunLike.coe (kw_iA_polyToFF_eq_aeval (E).toAffine)) _]
+    exact (Polynomial.aeval_map_algebraMap K (polyToFunctionField (E).toAffine X) p).symm
+  · simp only [RingHom.comp_apply, AlgHom.toRingHom_eq_coe, RingHom.coe_coe,
+      Polynomial.coe_mapRingHom, Polynomial.map_X]
+    rw [pointPullbackCoordHomTo_mk, Polynomial.eval₂_X]; rfl
+
+omit [DecidableEq K] in
+omit [E₀.IsElliptic] in
+theorem kw_iA_ffDescend_exists (x : (E).toAffine.FunctionField)
+    (hnum : kw_iA_crCoeffsIn E₀
+      (IsLocalization.sec (nonZeroDivisors (E).toAffine.CoordinateRing) x).1)
+    (hden : kw_iA_crCoeffsIn E₀
+      ((IsLocalization.sec (nonZeroDivisors (E).toAffine.CoordinateRing) x).2 :
+        (E).toAffine.CoordinateRing)) :
+    ∃ x₀ : E₀.toAffine.FunctionField, kw_iA_phi E₀ x₀ = x := by
+  classical
+  let s := IsLocalization.sec (nonZeroDivisors (E).toAffine.CoordinateRing) x
+  have hdenNZ : (s.2 : (E).toAffine.CoordinateRing) ≠ 0 := nonZeroDivisors.coe_ne_zero _
+  refine ⟨algebraMap _ _ (kw_iA_crDescend E₀ s.1 hnum)
+    / algebraMap _ _ (kw_iA_crDescend E₀ (↑s.2) hden), ?_⟩
+  have hFFdenNZ : algebraMap (E).toAffine.CoordinateRing (E).toAffine.FunctionField
+      (s.2 : (E).toAffine.CoordinateRing) ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr hdenNZ
+  rw [map_div₀, kw_iA_phiCRCompat, kw_iA_phiCRCompat,
+    kw_iA_crDescend_map E₀ s.1 hnum, kw_iA_crDescend_map E₀ _ hden,
+    div_eq_iff hFFdenNZ]
+  exact (IsLocalization.sec_spec (nonZeroDivisors (E).toAffine.CoordinateRing) x).symm
+
+end Carriers
+
+section Assembly
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable {K₀ : IntermediateField ℚ K}
+variable (E₀ : WeierstrassCurve K₀) [E₀.IsElliptic]
+
+local notation "E" => E₀.map (algebraMap K₀ K)
+
+def kw_iA_CoeffsHyp (D : IsogenyEndDatum (E).toAffine) : Prop :=
+  (kw_iA_crCoeffsIn E₀ (IsLocalization.sec (nonZeroDivisors (E).toAffine.CoordinateRing)
+      (D.ι (polyToFunctionField (E).toAffine X))).1
+    ∧ kw_iA_crCoeffsIn E₀ ((IsLocalization.sec (nonZeroDivisors
+        (E).toAffine.CoordinateRing) (D.ι (polyToFunctionField (E).toAffine X))).2 :
+      (E).toAffine.CoordinateRing))
+  ∧ (kw_iA_crCoeffsIn E₀ (IsLocalization.sec (nonZeroDivisors (E).toAffine.CoordinateRing)
+      (D.ι (yGen (E).toAffine))).1
+    ∧ kw_iA_crCoeffsIn E₀ ((IsLocalization.sec (nonZeroDivisors
+        (E).toAffine.CoordinateRing) (D.ι (yGen (E).toAffine))).2 :
+      (E).toAffine.CoordinateRing))
+
+end Assembly
+end ModularCurve
+end
+
+section
+
+namespace ModularCurve
+
+section CoeffSet
+
+variable {K : Type uK} [Field K] [DecidableEq K]
+
+def kw_iCa_crRepr (E : WeierstrassCurve K) (c : E.toAffine.CoordinateRing)
+    (i : Fin 2) : Polynomial K :=
+  (CoordinateRing.basis E.toAffine).repr c i
+
+def kw_iCa_crCoeffSet (E : WeierstrassCurve K) (c : E.toAffine.CoordinateRing) :
+    Finset K :=
+  ((kw_iCa_crRepr E c 0).support.image (kw_iCa_crRepr E c 0).coeff) ∪
+  ((kw_iCa_crRepr E c 1).support.image (kw_iCa_crRepr E c 1).coeff)
+
+def kw_iCa_ffNum (E : WeierstrassCurve K) (x : E.toAffine.FunctionField) :
+    E.toAffine.CoordinateRing :=
+  (IsLocalization.sec (nonZeroDivisors E.toAffine.CoordinateRing) x).1
+
+def kw_iCa_ffDen (E : WeierstrassCurve K) (x : E.toAffine.FunctionField) :
+    E.toAffine.CoordinateRing :=
+  ((IsLocalization.sec (nonZeroDivisors E.toAffine.CoordinateRing) x).2 :
+    E.toAffine.CoordinateRing)
+
+def kw_iCa_ffCoeffSet (E : WeierstrassCurve K) (x : E.toAffine.FunctionField) :
+    Finset K :=
+  kw_iCa_crCoeffSet E (kw_iCa_ffNum E x) ∪ kw_iCa_crCoeffSet E (kw_iCa_ffDen E x)
+
+theorem kw_iCa_crRepr_coeff_mem (E : WeierstrassCurve K)
+    (c : E.toAffine.CoordinateRing) (i : Fin 2) (j : ℕ) :
+    (kw_iCa_crRepr E c i).coeff j ∈ (↑(kw_iCa_crCoeffSet E c) : Set K) ∪ {0} := by
+  by_cases hj : j ∈ (kw_iCa_crRepr E c i).support
+  · refine Or.inl ?_
+    simp only [kw_iCa_crCoeffSet, Finset.coe_union, Finset.coe_image, Set.mem_union,
+      Set.mem_image, Finset.mem_coe]
+    rcases Fin.exists_fin_two.mp ⟨i, rfl⟩ with h | h
+    · exact h ▸ Or.inl ⟨j, hj, rfl⟩
+    · exact h ▸ Or.inr ⟨j, hj, rfl⟩
+  · exact Or.inr (by simpa using Polynomial.notMem_support_iff.mp hj)
+
+end CoeffSet
+
+section Canonical
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K]
+variable (E : WeierstrassCurve K) [E.IsElliptic] (D : IsogenyEndDatum E.toAffine)
+
+theorem kw_iCa_crCoeffsIn_of_ffCoeffSet_subset (E' : WeierstrassCurve K)
+    (x : E'.toAffine.FunctionField) {K₀' : IntermediateField ℚ K}
+    (hsub : (↑(kw_iCa_ffCoeffSet E' x) : Set K) ⊆ K₀') (i : Fin 2) (j : ℕ) :
+    ((CoordinateRing.basis E'.toAffine).repr (kw_iCa_ffNum E' x) i).coeff j ∈ K₀' ∧
+    ((CoordinateRing.basis E'.toAffine).repr (kw_iCa_ffDen E' x) i).coeff j ∈ K₀' := by
+  have hN := kw_iCa_crRepr_coeff_mem E' (kw_iCa_ffNum E' x) i j
+  have hD := kw_iCa_crRepr_coeff_mem E' (kw_iCa_ffDen E' x) i j
+  unfold kw_iCa_crRepr at hN hD
+  refine ⟨?_, ?_⟩
+  · rcases hN with hN | hN
+    · exact hsub (by simp only [kw_iCa_ffCoeffSet, Finset.coe_union]; exact Or.inl hN)
+    · simp only [Set.mem_singleton_iff] at hN; exact hN ▸ zero_mem K₀'
+  · rcases hD with hD | hD
+    · exact hsub (by simp only [kw_iCa_ffCoeffSet, Finset.coe_union]; exact Or.inr hD)
+    · simp only [Set.mem_singleton_iff] at hD; exact hD ▸ zero_mem K₀'
+
+end Canonical
+end ModularCurve
+end
+
+section
+
+namespace ModularCurve
+
+section Exchange
+
+variable {K : Type*} [Field K] (W : WeierstrassCurve.Affine K)
+
+theorem kw_iPFA_isTranscendenceBasis_coord :
+    IsTranscendenceBasis K
+      (fun _ : Fin 1 => algebraMap (RatFunc K) W.FunctionField RatFunc.X) := by
+  have : Algebra.IsAlgebraic (RatFunc K) (RatFunc K) :=
+    Algebra.IsAlgebraic.of_finite (RatFunc K) (RatFunc K)
+  have : Algebra.IsAlgebraic (Polynomial K) (RatFunc K) :=
+    (IsFractionRing.comap_isAlgebraic_iff
+      (A := Polynomial K) (K := RatFunc K) (C := RatFunc K)).mpr inferInstance
+  have : FaithfulSMul (Polynomial K) (RatFunc K) :=
+    (faithfulSMul_iff_algebraMap_injective (Polynomial K) (RatFunc K)).mpr
+      (IsFractionRing.injective (Polynomial K) (RatFunc K))
+  have : Algebra.IsAlgebraic (RatFunc K) W.FunctionField :=
+    Algebra.IsAlgebraic.of_finite (RatFunc K) W.FunctionField
+  have : FaithfulSMul (RatFunc K) W.FunctionField :=
+    (faithfulSMul_iff_algebraMap_injective (RatFunc K) W.FunctionField).mpr
+      (algebraMap (RatFunc K) W.FunctionField).injective
+  have h0 : IsTranscendenceBasis K (fun _ : Fin 1 => (Polynomial.X : Polynomial K)) :=
+    IsTranscendenceBasis.polynomial (ι := Fin 1) (R := K)
+  have h1 := h0.algebraMap_comp (A := RatFunc K)
+  have h2 := h1.algebraMap_comp (A := W.FunctionField)
+  have hfun : (algebraMap (RatFunc K) W.FunctionField ∘
+      (algebraMap (Polynomial K) (RatFunc K) ∘ fun _ : Fin 1 => (Polynomial.X : Polynomial K)))
+      = fun _ : Fin 1 => algebraMap (RatFunc K) W.FunctionField RatFunc.X := by
+    funext i; simp only [Function.comp_apply]; rw [RatFunc.algebraMap_X]
+  rwa [hfun] at h2
+
+theorem kw_iPFA_isAlgebraic_adjoin_transcendental {g : W.FunctionField}
+    (hg : Transcendental K g) :
+    Algebra.IsAlgebraic (↥K⟮g⟯) W.FunctionField := by
+  classical
+  have hgind : AlgebraicIndepOn K id ({g} : Set W.FunctionField) := by
+    refine algebraicIndependent_unique_type_iff.mpr ?_
+    simpa using hg
+  obtain ⟨s, hgs, hbasis⟩ := exists_isTranscendenceBasis_superset hgind
+  have hcard := hbasis.lift_cardinalMk_eq (kw_iPFA_isTranscendenceBasis_coord W)
+  simp only [Cardinal.mk_fin, Nat.cast_one, Cardinal.lift_one, Cardinal.lift_eq_one] at hcard
+  have hsub : s.Subsingleton := Cardinal.mk_le_one_iff_set_subsingleton.mp hcard.le
+  have hseq : s = {g} := hsub.eq_singleton_of_mem (hgs rfl)
+  subst hseq
+  rw [hbasis.isAlgebraic_iff]
+  intro i
+  have hi : (i : W.FunctionField) = g := i.2
+  rw [hi]
+  have h1 := isAlgebraic_algebraMap (R := ↥K⟮g⟯) (A := W.FunctionField)
+    (IntermediateField.AdjoinSimple.gen K g)
+  rwa [IntermediateField.AdjoinSimple.algebraMap_gen] at h1
+
+theorem kw_iPFA_finiteDimensional_adjoin_transcendental {g : W.FunctionField}
+    (hg : Transcendental K g) :
+    FiniteDimensional (↥K⟮g⟯) W.FunctionField := by
+  classical
+  have halg : Algebra.IsAlgebraic (↥K⟮g⟯) W.FunctionField :=
+    kw_iPFA_isAlgebraic_adjoin_transcendental W hg
+  obtain ⟨s, hs⟩ :=
+    Module.finite_def.mp (inferInstance : Module.Finite (RatFunc K) W.FunctionField)
+  set t : W.FunctionField := algebraMap (RatFunc K) W.FunctionField RatFunc.X with ht
+  set E : IntermediateField (↥K⟮g⟯) W.FunctionField :=
+    IntermediateField.adjoin (↥K⟮g⟯) (insert t (↑s : Set W.FunctionField)) with hE
+  have htE : t ∈ E := IntermediateField.subset_adjoin _ _ (Set.mem_insert _ _)
+  have hrange : ∀ r : RatFunc K, algebraMap (RatFunc K) W.FunctionField r ∈ E := by
+    intro r
+    have hr : r ∈ IntermediateField.adjoin K {(RatFunc.X : RatFunc K)} := by
+      rw [RatFunc.adjoin_X]; exact IntermediateField.mem_top
+    have hmap : algebraMap (RatFunc K) W.FunctionField r ∈
+        (IntermediateField.adjoin K {(RatFunc.X : RatFunc K)}).map
+          (IsScalarTower.toAlgHom K (RatFunc K) W.FunctionField) := ⟨r, hr, rfl⟩
+    rw [IntermediateField.adjoin_map, Set.image_singleton] at hmap
+    have himg : (IsScalarTower.toAlgHom K (RatFunc K) W.FunctionField)
+        (RatFunc.X : RatFunc K) = t := rfl
+    rw [himg] at hmap
+    have hle : IntermediateField.adjoin K {t} ≤ E.restrictScalars K :=
+      IntermediateField.adjoin_simple_le_iff.mpr
+        ((IntermediateField.mem_restrictScalars K).mpr htE)
+    exact (IntermediateField.mem_restrictScalars K).mp (hle hmap)
+  have hmem : ∀ x : W.FunctionField, x ∈ E := by
+    intro x
+    have hx : x ∈ Submodule.span (RatFunc K) (↑s : Set W.FunctionField) := by
+      rw [hs]; exact Submodule.mem_top
+    refine Submodule.span_induction (fun y hy => ?_) ?_ (fun y z _ _ hy hz => ?_)
+      (fun r y _ hy => ?_) hx
+    · exact IntermediateField.subset_adjoin _ _ (Set.mem_insert_of_mem _ hy)
+    · exact zero_mem E
+    · exact add_mem hy hz
+    · rw [Algebra.smul_def]
+      exact mul_mem (hrange _) hy
+  have heqTop : E = ⊤ := eq_top_iff.mpr (fun x _ => hmem x)
+  have hfinE : FiniteDimensional (↥K⟮g⟯) (↥E) :=
+    IntermediateField.finiteDimensional_adjoin
+      (S := insert t (↑s : Set W.FunctionField))
+      (fun z _ => isAlgebraic_iff_isIntegral.mp (halg.isAlgebraic z))
+  rw [heqTop] at hfinE
+  exact (IntermediateField.topEquiv (F := ↥K⟮g⟯) (E := W.FunctionField))
+    |>.toLinearEquiv.finiteDimensional
+
+end Exchange
+end ModularCurve
+end
+
+section
+
+namespace ModularCurve
+
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+section FinrankEq
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable {K₀ : IntermediateField ℚ K}
+variable (E₀ : WeierstrassCurve K₀) [E₀.IsElliptic]
+variable (D : IsogenyEndDatum (E₀.map (algebraMap K₀ K)).toAffine)
+variable (hcoeffs : kw_iA_CoeffsHyp E₀ D)
+
+local notation "E" => E₀.map (algebraMap K₀ K)
+
+theorem kw_iPFE_functionField_ringHom_ext {F : Type*} [Field F] {W : Affine F}
+    {L : Type*} [Field L] {f g : W.FunctionField →+* L}
+    (hF : ∀ r : F, f (algebraMap F W.FunctionField r) = g (algebraMap F W.FunctionField r))
+    (hX : f (polyToFunctionField W X) = g (polyToFunctionField W X))
+    (hy : f (yGen W) = g (yGen W)) : f = g := by
+  let : Algebra F L := (f.comp (algebraMap F W.FunctionField)).toAlgebra
+  let f' : W.FunctionField →ₐ[F] L := { f with commutes' := fun _ => rfl }
+  let g' : W.FunctionField →ₐ[F] L := { g with commutes' := fun r => (hF r).symm }
+  have heq : f' = g' := kw_functionField_algHom_ext hX hy
+  exact congrArg AlgHom.toRingHom heq
+
+end FinrankEq
+end ModularCurve
+end
+
+section
+
+namespace ModularCurve
+
+section Phi
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K]
+variable {K₀ : IntermediateField ℚ K}
+variable (E : WeierstrassCurve K) [E.IsElliptic]
+variable (E₀ : WeierstrassCurve K₀) [E₀.IsElliptic]
+
+omit [DecidableEq K] in
+omit [E.IsElliptic] [E₀.IsElliptic] in
+theorem kw_iotaDescentCurve_map_FF (hmap : E₀.map (algebraMap K₀ K) = E) :
+    E₀.map (algebraMap K₀ E.toAffine.FunctionField)
+      = E.map (algebraMap K E.toAffine.FunctionField) := by
+  classical
+  have htower : (algebraMap K₀ E.toAffine.FunctionField)
+      = (algebraMap K E.toAffine.FunctionField).comp (algebraMap K₀ K) :=
+    IsScalarTower.algebraMap_eq K₀ K E.toAffine.FunctionField
+  rw [htower, ← WeierstrassCurve.map_map, hmap]
+
+omit [DecidableEq K] in
+omit [E.IsElliptic] [E₀.IsElliptic] in
+theorem kw_iotaDescentPhi_equation (hmap : E₀.map (algebraMap K₀ K) = E) :
+    (E₀.map (algebraMap K₀ E.toAffine.FunctionField)).toAffine.Equation
+      (polyToFunctionField E.toAffine X) (yGen E.toAffine) := by
+  classical
+  rw [kw_iotaDescentCurve_map_FF E E₀ hmap]
+  exact equation_map_polyToFunctionField_yGen (W := E.toAffine)
+
+omit [DecidableEq K] in
+omit [E.IsElliptic] in
+theorem kw_iotaDescentPhi_transcendental :
+    Function.Injective
+      (Polynomial.aeval (R := K₀) (polyToFunctionField E.toAffine X)) := by
+  classical
+  have hK : Transcendental K (polyToFunctionField E.toAffine X) :=
+    transcendental_polyToFunctionField_X (W := E.toAffine)
+  have hK₀ : Transcendental K₀ (polyToFunctionField E.toAffine X) :=
+    hK.restrictScalars (R := K₀) (algebraMap K₀ K).injective
+  exact (injective_iff_map_eq_zero _).mpr
+    (fun p hp => transcendental_iff.mp hK₀ p hp)
+
+variable (hmap : E₀.map (algebraMap K₀ K) = E)
+
+def kw_iotaDescentPhi : E₀.toAffine.FunctionField →ₐ[K₀] E.toAffine.FunctionField :=
+  pointPullbackHomTo (kw_iotaDescentPhi_equation E E₀ hmap)
+    (kw_iotaDescentPhi_transcendental E)
+
+omit [DecidableEq K] in
+omit [E.IsElliptic] [E₀.IsElliptic] in
+theorem kw_iotaDescentPhi_X :
+    kw_iotaDescentPhi E E₀ hmap (polyToFunctionField E₀.toAffine X)
+      = polyToFunctionField E.toAffine X := by
+  classical
+  exact
+    pointPullbackHomTo_polyToFunctionField_X _ _
+
+omit [DecidableEq K] in
+omit [E.IsElliptic] [E₀.IsElliptic] in
+theorem kw_iotaDescentPhi_yGen :
+    kw_iotaDescentPhi E E₀ hmap (yGen E₀.toAffine) = yGen E.toAffine := by
+  classical
+  exact
+    pointPullbackHomTo_yGen _ _
+
+end Phi
+end ModularCurve
+end
+
+section
+
+open Cardinal
+
+namespace ModularCurve
+
+universe u
+
+attribute [local instance] Classical.propDecidable
+
+section CountableBridge
+
+theorem kw_fdn2_qephod_hend2fgd1_countable_of_fg {K : Type uK} [Field K] [Algebra ℚ K]
+    {K₀ : IntermediateField ℚ K} (hfg : K₀.FG) : Countable (↥K₀) := by
+  obtain ⟨s, hs⟩ := hfg
+  rw [← hs]
+  have h2 : Cardinal.lift.{0} (Cardinal.mk ↥(IntermediateField.adjoin ℚ (↑s : Set K))) ≤
+    Cardinal.aleph0 :=
+    (IntermediateField.lift_cardinalMk_adjoin_le ℚ (↑s : Set K)).trans
+      (max_le (max_le (Cardinal.lift_le_aleph0.mpr Cardinal.mk_le_aleph0)
+        (Cardinal.lift_le_aleph0.mpr (Set.Countable.le_aleph0 s.countable_toSet))) le_rfl)
+  exact Cardinal.mk_le_aleph0_iff.mp (Cardinal.lift_le_aleph0.mp h2)
+
+end CountableBridge
+
+section SubfieldDescentMint
+
+def KwD5BetweenCurvesSubfieldDescent : Prop :=
+  ∀ (K : Type uK) [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+    (E E' : WeierstrassCurve.Affine K) [E.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E] [WeierstrassCurve.Affine.AbelTheorem E]
+    [E'.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E']
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E']
+    [WeierstrassCurve.Affine.AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField)
+    (_hι : ι.toRingHom.IsIntegral) (_hfin : FiniteAlong K ι),
+    letI : Algebra ℚ K := DivisionRing.toRatAlgebra
+    ∃ (K₀ : IntermediateField ℚ K) (_ : K₀.FG)
+      (E₀ E₀' : WeierstrassCurve K₀) (_ : E₀.IsElliptic) (_ : E₀'.IsElliptic)
+      (hE₀map : E₀.map (algebraMap K₀ K) = E) (hE₀'map : E₀'.map (algebraMap K₀ K) = E')
+      (ι' : E₀'.toAffine.FunctionField →ₐ[K₀] E₀.toAffine.FunctionField)
+      (_hι' : ι'.toRingHom.IsIntegral) (_hfin' : FiniteAlong K₀ ι')
+      (_hfinrank : finrankAlong K₀ ι' = finrankAlong K ι),
+      ∀ x : E₀'.toAffine.FunctionField,
+        ι (kw_iotaDescentPhi E' E₀' hE₀'map x)
+          = kw_iotaDescentPhi E E₀ hE₀map (ι' x)
+
+end SubfieldDescentMint
+
+section KerDescendMint
+
+def KwD5BetweenCurvesKerDescendAlgClosed : Prop :=
+  ∀ (K : Type uK) [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+    (E E' : WeierstrassCurve.Affine K) [E.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E] [WeierstrassCurve.Affine.AbelTheorem E]
+    [E'.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E']
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E']
+    [WeierstrassCurve.Affine.AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong K ι)
+    (N : ℕ) [NeZero N],
+    IsAddCyclic (AddMonoidHom.ker
+      (pointMapOfPushforward ι hι hfin (normFormulaAlong_of_elliptic ι hfin))) →
+    Nat.card (AddMonoidHom.ker
+      (pointMapOfPushforward ι hι hfin (normFormulaAlong_of_elliptic ι hfin))) = N →
+    letI : Algebra ℚ K := DivisionRing.toRatAlgebra
+    ∀ (K₀ : IntermediateField ℚ K)
+      (E₀ E₀' : WeierstrassCurve K₀) [E₀.IsElliptic] [E₀'.IsElliptic]
+      (hE₀map : E₀.map (algebraMap K₀ K) = E) (hE₀'map : E₀'.map (algebraMap K₀ K) = E')
+      (ι' : E₀'.toAffine.FunctionField →ₐ[K₀] E₀.toAffine.FunctionField)
+      (_hι' : ι'.toRingHom.IsIntegral) (_hfin' : FiniteAlong K₀ ι'),
+      (∀ x : E₀'.toAffine.FunctionField,
+        ι (kw_iotaDescentPhi E' E₀' hE₀'map x)
+          = kw_iotaDescentPhi E E₀ hE₀map (ι' x)) →
+    ∃ (_ : (E₀⁄(AlgebraicClosure (↥K₀))).IsElliptic)
+      (_ : (E₀'⁄(AlgebraicClosure (↥K₀))).IsElliptic)
+      (ι₀ : (E₀'⁄(AlgebraicClosure (↥K₀))).toAffine.FunctionField
+        →ₐ[AlgebraicClosure (↥K₀)] (E₀⁄(AlgebraicClosure (↥K₀))).toAffine.FunctionField)
+      (hι₀ : ι₀.toRingHom.IsIntegral) (hfin₀ : FiniteAlong (AlgebraicClosure (↥K₀)) ι₀),
+      IsAddCyclic (AddMonoidHom.ker
+        (pointMapOfPushforward ι₀ hι₀ hfin₀ (normFormulaAlong_of_elliptic ι₀ hfin₀))) ∧
+      Nat.card (AddMonoidHom.ker
+        (pointMapOfPushforward ι₀ hι₀ hfin₀ (normFormulaAlong_of_elliptic ι₀ hfin₀))) = N
+
+end KerDescendMint
+
+section Reduce
+
+theorem kw_fdn2_qephod_hend2fgd1_bcFGDescent_of_two
+    (hSD : KwD5BetweenCurvesSubfieldDescent.{uK})
+    (hKD : KwD5BetweenCurvesKerDescendAlgClosed.{uK}) :
+    KwD5BetweenCurvesFGFieldDescent.{uK} := by
+  intro K _ _ _ _ E E' _ _ _ _ _ _ _ _ ι hι hfin N _ hcyc hcard
+  let : Algebra ℚ K := DivisionRing.toRatAlgebra
+  obtain ⟨K₀, hfg, E₀, E₀', hE₀ell, hE₀'ell, hE₀map, hE₀'map,
+    ι', hι', hfin', _hfinrank, hcompat⟩ := hSD K E E' ι hι hfin
+  have : E₀.IsElliptic := hE₀ell
+  have : E₀'.IsElliptic := hE₀'ell
+  have : Countable (↥K₀) := kw_fdn2_qephod_hend2fgd1_countable_of_fg hfg
+  obtain ⟨hE₀ACell, hE₀'ACell, ι₀, hι₀, hfin₀, hcyc₀, hcard₀⟩ :=
+    hKD K E E' ι hι hfin N hcyc hcard K₀ E₀ E₀' hE₀map hE₀'map ι' hι' hfin' hcompat
+  exact ⟨K₀, inferInstance, E₀, E₀', hE₀ell, hE₀'ell, hE₀map, hE₀'map,
+    hE₀ACell, hE₀'ACell, ι₀, hι₀, hfin₀, hcyc₀, hcard₀⟩
+
+end Reduce
+end ModularCurve
+end
+
+section
+
+namespace ModularCurve
+
+universe u
+
+attribute [local instance] Classical.propDecidable
+
+section BCNoACEngine
+
+variable {R₀ : Type u} [Field R₀]
+variable (E₀ E₀' : WeierstrassCurve R₀) [E₀.IsElliptic] [E₀'.IsElliptic]
+variable (F : Type u) [Field F] [Algebra R₀ F] [DecidableEq F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra R₀ F'] [DecidableEq F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower R₀ F F']
+variable [(E₀⁄F).IsElliptic] [(E₀'⁄F).IsElliptic] [(E₀⁄F').IsElliptic] [(E₀'⁄F').IsElliptic]
+variable (ι' : (E₀'⁄F).toAffine.FunctionField →ₐ[F] (E₀⁄F).toAffine.FunctionField)
+
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+def kw_surgehgf4_hfgkd_bcTensorIota :
+    (E₀'⁄F).toAffine.FunctionField ⊗[F] F' →ₐ[F] (E₀⁄F).toAffine.FunctionField ⊗[F] F' :=
+  Algebra.TensorProduct.map ι' (AlgHom.id F F')
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [E₀.IsElliptic] [E₀'.IsElliptic] [CharZero F] [Algebra R₀ F'] [CharZero F']
+  [IsScalarTower R₀ F F'] [WeierstrassCurve.IsElliptic E₀⁄F] [WeierstrassCurve.IsElliptic E₀'⁄F]
+  [WeierstrassCurve.IsElliptic E₀⁄F'] [WeierstrassCurve.IsElliptic E₀'⁄F'] in
+theorem kw_surgehgf4_hfgkd_bcTensorIota_tmul (a : (E₀'⁄F).toAffine.FunctionField)
+    (c : F') :
+    kw_surgehgf4_hfgkd_bcTensorIota E₀ E₀' F F' ι' (a ⊗ₜ[F] c) = (ι' a) ⊗ₜ[F] c := by
+  classical
+  simp [kw_surgehgf4_hfgkd_bcTensorIota, Algebra.TensorProduct.map_tmul]
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [E₀.IsElliptic] [E₀'.IsElliptic] [CharZero F] [Algebra R₀ F'] [CharZero F']
+  [IsScalarTower R₀ F F'] [WeierstrassCurve.IsElliptic E₀⁄F] [WeierstrassCurve.IsElliptic E₀'⁄F]
+  [WeierstrassCurve.IsElliptic E₀⁄F'] [WeierstrassCurve.IsElliptic E₀'⁄F'] in
+theorem kw_surgehgf4_hfgkd_bcTensorIota_injective :
+    Function.Injective (kw_surgehgf4_hfgkd_bcTensorIota E₀ E₀' F F' ι') := by
+  classical
+  exact
+    Module.Flat.rTensor_preserves_injective_linearMap (M := F') ι'.toLinearMap ι'.injective
+
+omit [DecidableEq F] [DecidableEq F'] in
+scoped instance kw_surgehgf4_hfgkd_tensorIsDomain_E' :
+    IsDomain ((E₀'⁄F).toAffine.FunctionField ⊗[F] F') := by
+  classical
+  exact
+    kw_functionFieldTensorIsDomain_dischargeGeneralNoAC E₀' F F'
+
+def kw_surgehgf4_hfgkd_bcTensorFracIota :
+    FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F')
+      →+* FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F') :=
+  IsFractionRing.map (K := FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F'))
+    (L := FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F'))
+    (kw_surgehgf4_hfgkd_bcTensorIota_injective E₀ E₀' F F' ι')
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [E₀'.IsElliptic] [WeierstrassCurve.IsElliptic E₀⁄F] [WeierstrassCurve.IsElliptic E₀'⁄F]
+  [WeierstrassCurve.IsElliptic E₀⁄F'] [WeierstrassCurve.IsElliptic E₀'⁄F'] in
+omit [E₀.IsElliptic] [CharZero F] [Algebra R₀ F'] [CharZero F'] [IsScalarTower R₀ F F'] in
+theorem kw_surgehgf4_hfgkd_bcTensorFracIota_algebraMap
+    (t : (E₀'⁄F).toAffine.FunctionField ⊗[F] F') :
+    kw_surgehgf4_hfgkd_bcTensorFracIota E₀ E₀' F F' ι'
+        (algebraMap ((E₀'⁄F).toAffine.FunctionField ⊗[F] F') _ t)
+      = algebraMap ((E₀⁄F).toAffine.FunctionField ⊗[F] F') _
+          (kw_surgehgf4_hfgkd_bcTensorIota E₀ E₀' F F' ι' t) := by
+  classical
+  unfold kw_surgehgf4_hfgkd_bcTensorFracIota IsFractionRing.map
+  exact IsLocalization.map_eq
+    (T := nonZeroDivisors ((E₀⁄F).toAffine.FunctionField ⊗[F] F')) _ t
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [E₀.IsElliptic] [E₀'.IsElliptic] [CharZero F] [Algebra R₀ F'] [CharZero F']
+  [IsScalarTower R₀ F F'] [WeierstrassCurve.IsElliptic E₀⁄F] [WeierstrassCurve.IsElliptic E₀'⁄F]
+  [WeierstrassCurve.IsElliptic E₀⁄F'] [WeierstrassCurve.IsElliptic E₀'⁄F'] in
+theorem kw_surgehgf4_hfgkd_bcTensorIota_finite (hfin' : FiniteAlong F ι') :
+    (kw_surgehgf4_hfgkd_bcTensorIota E₀ E₀' F F' ι').toRingHom.Finite := by
+  classical
+  exact
+    RingHom.Finite.tensorProductMap (f := ι') hfin' (g := AlgHom.id F F')
+      (RingHom.Finite.id F')
+
+def kw_surgehgf4_hfgkd_bcTensorFracIotaAlg :
+    FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F')
+      →ₐ[F'] FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F') :=
+  { kw_surgehgf4_hfgkd_bcTensorFracIota E₀ E₀' F F' ι' with
+    commutes' := fun c => by
+      change kw_surgehgf4_hfgkd_bcTensorFracIota E₀ E₀' F F' ι'
+          (algebraMap F' _ c) = algebraMap F' _ c
+      rw [IsScalarTower.algebraMap_apply F' ((E₀'⁄F).toAffine.FunctionField ⊗[F] F')
+          (FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F')),
+        Algebra.TensorProduct.right_algebraMap_apply,
+        kw_surgehgf4_hfgkd_bcTensorFracIota_algebraMap E₀ E₀' F F' ι',
+        kw_surgehgf4_hfgkd_bcTensorIota_tmul, map_one,
+        IsScalarTower.algebraMap_apply F' ((E₀⁄F).toAffine.FunctionField ⊗[F] F')
+          (FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F')),
+        Algebra.TensorProduct.right_algebraMap_apply] }
+
+def kw_surgehgf4_hfgkd_bcIota₁NoAC :
+    (E₀'⁄F').toAffine.FunctionField →ₐ[F'] (E₀⁄F').toAffine.FunctionField :=
+  let ψE := kw_functionFieldTensorFracEquivGeneralNoAC E₀ F F'
+  let ψE' := kw_functionFieldTensorFracEquivGeneralNoAC E₀' F F'
+  (ψE.symm.toAlgHom.comp (kw_surgehgf4_hfgkd_bcTensorFracIotaAlg E₀ E₀' F F' ι')).comp
+    ψE'.toAlgHom
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [WeierstrassCurve.IsElliptic E₀⁄F] [WeierstrassCurve.IsElliptic E₀'⁄F]
+  [WeierstrassCurve.IsElliptic E₀⁄F'] [WeierstrassCurve.IsElliptic E₀'⁄F'] in
+omit [E₀'.IsElliptic] in
+omit [E₀.IsElliptic] [CharZero F] [Algebra R₀ F'] [CharZero F'] [IsScalarTower R₀ F F'] in
+theorem kw_surgehgf4_hfgkd_bcTensorFracIotaSeam (hfin' : FiniteAlong F ι') :
+    (kw_surgehgf4_hfgkd_bcTensorFracIota E₀ E₀' F F' ι').Finite ∧
+    (letI := (kw_surgehgf4_hfgkd_bcTensorFracIota E₀ E₀' F F' ι').toAlgebra
+     @Module.finrank (FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F'))
+       (FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F')) _ _ Algebra.toModule)
+      = finrankAlong F ι' := by
+  classical
+  let FF := (E₀⁄F).toAffine.FunctionField
+  let FF' := (E₀'⁄F).toAffine.FunctionField
+  let T := (E₀⁄F).toAffine.FunctionField ⊗[F] F'
+  let T' := (E₀'⁄F).toAffine.FunctionField ⊗[F] F'
+  let FrT := FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F')
+  let FrT' := FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F')
+  let ιT : T' →+* T := (kw_surgehgf4_hfgkd_bcTensorIota E₀ E₀' F F' ι').toRingHom
+  let ιFr : FrT' →+* FrT := kw_surgehgf4_hfgkd_bcTensorFracIota E₀ E₀' F F' ι'
+  have hιT_inj : Function.Injective ιT :=
+    kw_surgehgf4_hfgkd_bcTensorIota_injective E₀ E₀' F F' ι'
+  have hιT_fin : ιT.Finite :=
+    kw_surgehgf4_hfgkd_bcTensorIota_finite E₀ E₀' F F' ι' hfin'
+  have hιFr_am : ∀ t : T', ιFr (algebraMap T' FrT' t) = algebraMap T FrT (ιT t) :=
+    kw_surgehgf4_hfgkd_bcTensorFracIota_algebraMap E₀ E₀' F F' ι'
+  let algι : Algebra FF' FF := ι'.toRingHom.toAlgebra
+  let modι : Module FF' FF := Algebra.toModule
+  have hsmul_ι : ∀ (c : FF') (x : FF), c • x = ι' c * x := fun c x => rfl
+  have hfinFF : Module.Finite FF' FF := hfin'
+  have hfreeFF : Module.Free FF' FF := Module.Free.of_divisionRing FF' FF
+  let D := finrankAlong F ι'
+  let b : Module.Basis (Fin D) FF' FF := Module.finBasisOfFinrankEq FF' FF (n := D) rfl
+  have hrepr_mul : ∀ (c : FF') (x : FF) (j : Fin D),
+      b.repr (ι' c * x) j = c * b.repr x j := fun c x j => by
+    rw [← hsmul_ι, map_smul, Finsupp.smul_apply, smul_eq_mul]
+  let e : Fin D → T := fun i => (b i) ⊗ₜ[F] (1 : F')
+  let bFr : Fin D → FrT := fun i => algebraMap T FrT (e i)
+  have hspanT : ∀ t : T, ∃ c : Fin D → T', t = ∑ i, ιT (c i) * e i := by
+    intro t
+    induction t using TensorProduct.inductionOn with
+    | add x y hx hy =>
+      obtain ⟨cx, hx⟩ := hx; obtain ⟨cy, hy⟩ := hy
+      exact ⟨cx + cy, by simp only [Pi.add_apply, map_add, add_mul,
+        Finset.sum_add_distrib, ← hx, ← hy]⟩
+    | tmul a c =>
+      refine ⟨fun i => (b.repr a i) ⊗ₜ[F] c, ?_⟩
+      have hb_sum : a = ∑ i, ι' (b.repr a i) * b i := by
+        conv_lhs => rw [← b.linearCombination_repr a, Finsupp.linearCombination_apply,
+          Finsupp.sum_fintype _ _ (fun i => by rw [hsmul_ι, _root_.map_zero, zero_mul])]
+        exact Finset.sum_congr rfl fun i _ => hsmul_ι _ _
+      calc (a ⊗ₜ[F] c : T)
+          = (∑ i, ι' (b.repr a i) * b i) ⊗ₜ[F] c := by rw [← hb_sum]
+        _ = ∑ i, ιT ((b.repr a i) ⊗ₜ[F] c) * e i := by
+            rw [TensorProduct.sum_tmul]
+            refine Finset.sum_congr rfl fun i _ => ?_
+            show (ι' (b.repr a i) * b i) ⊗ₜ[F] c = ιT ((b.repr a i) ⊗ₜ[F] c) * e i
+            rw [show ιT ((b.repr a i) ⊗ₜ[F] c) = (ι' (b.repr a i)) ⊗ₜ[F] c from
+                  kw_surgehgf4_hfgkd_bcTensorIota_tmul E₀ E₀' F F' ι' _ _,
+              Algebra.TensorProduct.tmul_mul_tmul, mul_one]
+  have hliT : ∀ c : Fin D → T', ∑ i, ιT (c i) * e i = 0 → ∀ j, c j = 0 := by
+    intro c hc j
+    let pj : FF →ₗ[F] FF' :=
+      { toFun := fun x => b.repr x j
+        map_add' := fun x y => by simp only [map_add, Finsupp.add_apply]
+        map_smul' := fun f x => by
+          simp only [RingHom.id_apply, Algebra.smul_def]
+          have h := hrepr_mul (algebraMap F FF' f) x j
+          rwa [ι'.commutes] at h }
+    let Ej : T →ₗ[F] T' := LinearMap.rTensor F' pj
+    have hEj_key : ∀ (a : T') (i : Fin D),
+        Ej (ιT a * e i) = if i = j then a else 0 := by
+      intro a i
+      induction a using TensorProduct.inductionOn with
+      | add x y hx hy =>
+        simp only [map_add, add_mul, hx, hy]; split_ifs <;> simp
+      | tmul x c' =>
+        rw [show ιT ((x : FF') ⊗ₜ[F] c') = (ι' x) ⊗ₜ[F] c' from
+              kw_surgehgf4_hfgkd_bcTensorIota_tmul E₀ E₀' F F' ι' _ _,
+            Algebra.TensorProduct.tmul_mul_tmul, mul_one]
+        change (pj (ι' x * b i)) ⊗ₜ[F] c' = if i = j then (x : FF') ⊗ₜ[F] c' else 0
+        rw [show pj (ι' x * b i) = if i = j then x else 0 from ?_]
+        · split_ifs with h
+          · rfl
+          · exact TensorProduct.zero_tmul _ c'
+        · change b.repr (ι' x * b i) j = if i = j then x else 0
+          rw [hrepr_mul, b.repr_self, Finsupp.single_apply]
+          split_ifs with h <;> simp
+    have hc' : Ej (∑ i, ιT (c i) * e i) = 0 := by rw [hc, _root_.map_zero]
+    simpa only [map_sum, hEj_key, Finset.sum_ite_eq', Finset.mem_univ, ite_true] using hc'
+  have hint : ∀ s : T, s ≠ 0 → ∃ (u : T) (s₀ : T'), s₀ ≠ 0 ∧ s * u = ιT s₀ := by
+    intro s hs
+    obtain ⟨p, hp_monic, hp_eval⟩ : ιT.IsIntegralElem s := hιT_fin.to_isIntegral s
+    obtain ⟨q, hq_eq, hq_ndvd⟩ := Polynomial.exists_eq_pow_rootMultiplicity_mul_and_not_dvd p
+      hp_monic.ne_zero 0
+    simp only [Polynomial.C_0, sub_zero] at hq_eq hq_ndvd
+    have hq0 : q.coeff 0 ≠ 0 := fun h => hq_ndvd (Polynomial.X_dvd_iff.mpr h)
+    have hqs : q.eval₂ ιT s = 0 := by
+      have h := hp_eval
+      rw [hq_eq, Polynomial.eval₂_mul, Polynomial.eval₂_pow, Polynomial.eval₂_X,
+        mul_eq_zero] at h
+      exact h.resolve_left (pow_ne_zero _ hs)
+    have h3 : ιT (q.coeff 0) + s * (q.divX).eval₂ ιT s = 0 := by
+      have h := congrArg (Polynomial.eval₂ ιT s) (Polynomial.divX_mul_X_add q)
+      rw [Polynomial.eval₂_add, Polynomial.eval₂_mul, Polynomial.eval₂_X,
+        Polynomial.eval₂_C, hqs] at h
+      simpa only [add_comm, mul_comm] using h
+    exact ⟨(q.divX).eval₂ ιT s, -q.coeff 0, neg_ne_zero.mpr hq0,
+      by rw [_root_.map_neg]; exact eq_neg_of_add_eq_zero_right h3⟩
+  have hspanFr : ∀ z : FrT, ∃ d : Fin D → FrT', z = ∑ i, ιFr (d i) * bFr i := by
+    intro z
+    obtain ⟨t, s, _, rfl⟩ := IsFractionRing.div_surjective (A := T) (K := FrT) z
+    rcases eq_or_ne s 0 with rfl | hs'
+    · exact ⟨0, by simp⟩
+    obtain ⟨u, s₀, hs₀, hsu⟩ := hint s hs'
+    have hιTs₀ : ιT s₀ ≠ 0 := fun h => hs₀ (hιT_inj (h.trans (_root_.map_zero ιT).symm))
+    have hu_ne : u ≠ 0 := fun h => hιTs₀ (by rw [← hsu, h, mul_zero])
+    obtain ⟨c, hc⟩ := hspanT (t * u)
+    refine ⟨fun i => (algebraMap T' FrT' s₀)⁻¹ * algebraMap T' FrT' (c i), ?_⟩
+    have hum := (map_ne_zero_iff _ (IsFractionRing.injective T FrT)).mpr hu_ne
+    have hz : (algebraMap T FrT t) / (algebraMap T FrT s)
+        = (algebraMap T FrT (ιT s₀))⁻¹ * algebraMap T FrT (t * u) := by
+      rw [← div_eq_inv_mul, ← hsu, map_mul, map_mul,
+        ← div_mul_div_comm, div_self hum, mul_one]
+    rw [hz, hc, map_sum, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [map_mul, map_mul, ← hιFr_am s₀, ← hιFr_am (c i), ← map_inv₀ ιFr, mul_assoc]
+  have hliFr : ∀ d : Fin D → FrT', ∑ i, ιFr (d i) * bFr i = 0 → ∀ j, d j = 0 := by
+    intro d hd j
+    obtain ⟨q, hq⟩ := IsLocalization.exist_integer_multiples_of_finset
+      (nonZeroDivisors T') (Finset.univ.image d)
+    choose p hp using fun i => hq (d i) (Finset.mem_image_of_mem d (Finset.mem_univ i))
+    have hq0 : (algebraMap T' FrT' (q : T')) ≠ 0 :=
+      (map_ne_zero_iff _ (IsFractionRing.injective T' FrT')).mpr (nonZeroDivisors.ne_zero q.2)
+    have hp' : ∀ i, algebraMap T' FrT' (p i) = algebraMap T' FrT' (q : T') * d i := fun i =>
+      by rw [hp i, Algebra.smul_def]
+    have hd' : algebraMap T FrT (∑ i, ιT (p i) * e i) = 0 := by
+      have h1 : ∑ i, ιFr (algebraMap T' FrT' (q : T')) * (ιFr (d i) * bFr i) = 0 := by
+        rw [← Finset.mul_sum, hd, mul_zero]
+      rw [map_sum, ← h1]; refine Finset.sum_congr rfl fun i _ => ?_
+      rw [map_mul, ← hιFr_am (p i), ← mul_assoc, ← map_mul, ← hp' i]
+    have hpj : p j = 0 :=
+      hliT p ((IsFractionRing.injective T FrT) (by simpa using hd')) j
+    have hthis : algebraMap T' FrT' (q : T') * d j = 0 := by
+      rw [← hp' j, hpj, _root_.map_zero]
+    exact (mul_eq_zero.mp hthis).resolve_left hq0
+  let algFr : Algebra FrT' FrT := ιFr.toAlgebra
+  let modFr : Module FrT' FrT := Algebra.toModule
+  have hsmul_Fr : ∀ (c : FrT') (x : FrT), c • x = ιFr c * x := fun c x => rfl
+  have hli_modFr : LinearIndependent FrT' bFr := by
+    rw [Fintype.linearIndependent_iff]
+    intro g hg i
+    refine hliFr g ?_ i
+    simpa only [hsmul_Fr] using hg
+  have hsp_modFr : ⊤ ≤ Submodule.span FrT' (Set.range bFr) := by
+    intro z _
+    obtain ⟨d, hd⟩ := hspanFr z
+    rw [hd]
+    exact Submodule.sum_mem _ fun i _ => (hsmul_Fr (d i) (bFr i)) ▸
+      Submodule.smul_mem _ (d i) (Submodule.subset_span ⟨i, rfl⟩)
+  let bFr' : Module.Basis (Fin D) FrT' FrT := .mk hli_modFr hsp_modFr
+  refine ⟨Module.Finite.of_basis bFr', ?_⟩
+  change Module.finrank FrT' FrT = D
+  rw [Module.finrank_eq_card_basis bFr', Fintype.card_fin]
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [WeierstrassCurve.IsElliptic E₀⁄F] [WeierstrassCurve.IsElliptic E₀'⁄F]
+  [WeierstrassCurve.IsElliptic E₀⁄F'] [WeierstrassCurve.IsElliptic E₀'⁄F'] in
+omit [E₀'.IsElliptic] in
+omit [E₀.IsElliptic] [CharZero F] [CharZero F'] in
+theorem kw_surgehgf4_hfgkd_bcIota₁NoAC_finiteAlong (hfin' : FiniteAlong F ι') :
+    FiniteAlong F' (kw_surgehgf4_hfgkd_bcIota₁NoAC E₀ E₀' F F' ι') := by
+  classical
+  have hFr_fin := (kw_surgehgf4_hfgkd_bcTensorFracIotaSeam E₀ E₀' F F' ι' hfin').1
+  let ψE := kw_functionFieldTensorFracEquivGeneralNoAC E₀ F F'
+  let ψE' := kw_functionFieldTensorFracEquivGeneralNoAC E₀' F F'
+  have h1 : RingHom.Finite ψE'.toAlgHom.toRingHom :=
+    RingHom.Finite.of_surjective _ ψE'.surjective
+  have h2 : RingHom.Finite ψE.symm.toAlgHom.toRingHom :=
+    RingHom.Finite.of_surjective _ ψE.symm.surjective
+  change RingHom.Finite (kw_surgehgf4_hfgkd_bcIota₁NoAC E₀ E₀' F F' ι').toRingHom
+  have hcomp : (kw_surgehgf4_hfgkd_bcIota₁NoAC E₀ E₀' F F' ι').toRingHom
+      = (ψE.symm.toAlgHom.toRingHom.comp
+          (kw_surgehgf4_hfgkd_bcTensorFracIota E₀ E₀' F F' ι')).comp
+        ψE'.toAlgHom.toRingHom := rfl
+  rw [hcomp]
+  exact RingHom.Finite.comp (RingHom.Finite.comp h2 hFr_fin) h1
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [WeierstrassCurve.IsElliptic E₀⁄F] [WeierstrassCurve.IsElliptic E₀'⁄F]
+  [WeierstrassCurve.IsElliptic E₀⁄F'] [WeierstrassCurve.IsElliptic E₀'⁄F'] in
+omit [E₀'.IsElliptic] in
+omit [E₀.IsElliptic] [CharZero F] [CharZero F'] in
+theorem kw_surgehgf4_hfgkd_bcIota₁NoAC_isIntegral (hfin' : FiniteAlong F ι') :
+    (kw_surgehgf4_hfgkd_bcIota₁NoAC E₀ E₀' F F' ι').toRingHom.IsIntegral := by
+  classical
+  exact
+    RingHom.Finite.to_isIntegral
+      (show RingHom.Finite (kw_surgehgf4_hfgkd_bcIota₁NoAC E₀ E₀' F F' ι').toRingHom from
+        kw_surgehgf4_hfgkd_bcIota₁NoAC_finiteAlong E₀ E₀' F F' ι' hfin')
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [WeierstrassCurve.IsElliptic E₀⁄F] [WeierstrassCurve.IsElliptic E₀'⁄F]
+  [WeierstrassCurve.IsElliptic E₀⁄F'] [WeierstrassCurve.IsElliptic E₀'⁄F'] in
+omit [E₀'.IsElliptic] in
+omit [E₀.IsElliptic] [CharZero F] [CharZero F'] in
+theorem kw_surgehgf4_hfgkd_bcIota₁NoAC_finrankAlong (hfin' : FiniteAlong F ι') :
+    finrankAlong F' (kw_surgehgf4_hfgkd_bcIota₁NoAC E₀ E₀' F F' ι')
+      = finrankAlong F ι' := by
+  classical
+  let ψE := kw_functionFieldTensorFracEquivGeneralNoAC E₀ F F'
+  let ψE' := kw_functionFieldTensorFracEquivGeneralNoAC E₀' F F'
+  let ιFr := kw_surgehgf4_hfgkd_bcTensorFracIota E₀ E₀' F F' ι'
+  have hcomm : ∀ x, ιFr (ψE' x)
+      = ψE (kw_surgehgf4_hfgkd_bcIota₁NoAC E₀ E₀' F F' ι' x) := fun x => by
+    change ιFr (ψE' x) = ψE (ψE.symm (_))
+    exact (ψE.apply_symm_apply _).symm
+  calc finrankAlong F' (kw_surgehgf4_hfgkd_bcIota₁NoAC E₀ E₀' F F' ι')
+      = (letI := ιFr.toAlgebra
+         @Module.finrank (FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F'))
+           (FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F')) _ _ Algebra.toModule) :=
+        @Algebra.finrank_eq_of_equiv_equiv
+          (E₀'⁄F').toAffine.FunctionField (E₀⁄F').toAffine.FunctionField _ _
+          (algebraAlong (kw_surgehgf4_hfgkd_bcIota₁NoAC E₀ E₀' F F' ι'))
+          _ _ _ _ ιFr.toAlgebra ψE'.toRingEquiv ψE.toRingEquiv (RingHom.ext hcomm)
+    _ = finrankAlong F ι' :=
+        (kw_surgehgf4_hfgkd_bcTensorFracIotaSeam E₀ E₀' F F' ι' hfin').2
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [WeierstrassCurve.IsElliptic E₀⁄F] [WeierstrassCurve.IsElliptic E₀'⁄F]
+  [WeierstrassCurve.IsElliptic E₀⁄F'] [WeierstrassCurve.IsElliptic E₀'⁄F'] in
+omit [E₀'.IsElliptic] in
+omit [E₀.IsElliptic] [CharZero F] [CharZero F'] in
+theorem kw_surgehgf4_hfgkd_bcIota₁NoAC_compat (a : (E₀'⁄F).toAffine.FunctionField) :
+    kw_surgehgf4_hfgkd_bcIota₁NoAC E₀ E₀' F F' ι'
+        (kw_functionFieldMapAlongGeneralNoAC E₀' F F' a)
+      = kw_functionFieldMapAlongGeneralNoAC E₀ F F' (ι' a) := by
+  classical
+  let ψE := kw_functionFieldTensorFracEquivGeneralNoAC E₀ F F'
+  let ψE' := kw_functionFieldTensorFracEquivGeneralNoAC E₀' F F'
+  let χE := kw_functionFieldMapAlongGeneralNoAC E₀ F F'
+  let χE' := kw_functionFieldMapAlongGeneralNoAC E₀' F F'
+  have hκE' : ψE' (χE' a)
+      = algebraMap ((E₀'⁄F).toAffine.FunctionField ⊗[F] F') _ (a ⊗ₜ[F] (1 : F')) := by
+    have hκ : ((kw_functionFieldTensorFracHomGeneralNoAC E₀' F F').restrictScalars F).comp
+        χE'
+        = (IsScalarTower.toAlgHom F ((E₀'⁄F).toAffine.FunctionField ⊗[F] F')
+            (FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F'))).comp
+            (Algebra.TensorProduct.includeLeft (R := F)) := by
+      refine kw_functionField_algHom_ext ?_ ?_
+      · change kw_functionFieldTensorFracHomGeneralNoAC E₀' F F' (χE' _) = _
+        rw [kw_functionFieldMapAlongGeneralNoAC_polyToFunctionField_X,
+          kw_functionFieldTensorFracHomGeneralNoAC_X]; rfl
+      · change kw_functionFieldTensorFracHomGeneralNoAC E₀' F F' (χE' _) = _
+        rw [kw_functionFieldMapAlongGeneralNoAC_yGen,
+          kw_functionFieldTensorFracHomGeneralNoAC_yGen]; rfl
+    exact DFunLike.congr_fun hκ a
+  have hκE : ∀ b, ψE.symm (algebraMap ((E₀⁄F).toAffine.FunctionField ⊗[F] F') _
+      (b ⊗ₜ[F] (1 : F'))) = χE b := by
+    intro b
+    refine ψE.injective ?_
+    rw [AlgEquiv.apply_symm_apply]
+    have hκ : ((kw_functionFieldTensorFracHomGeneralNoAC E₀ F F').restrictScalars F).comp
+        χE
+        = (IsScalarTower.toAlgHom F ((E₀⁄F).toAffine.FunctionField ⊗[F] F')
+            (FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F'))).comp
+            (Algebra.TensorProduct.includeLeft (R := F)) := by
+      refine kw_functionField_algHom_ext ?_ ?_
+      · change kw_functionFieldTensorFracHomGeneralNoAC E₀ F F' (χE _) = _
+        rw [kw_functionFieldMapAlongGeneralNoAC_polyToFunctionField_X,
+          kw_functionFieldTensorFracHomGeneralNoAC_X]; rfl
+      · change kw_functionFieldTensorFracHomGeneralNoAC E₀ F F' (χE _) = _
+        rw [kw_functionFieldMapAlongGeneralNoAC_yGen,
+          kw_functionFieldTensorFracHomGeneralNoAC_yGen]; rfl
+    exact (DFunLike.congr_fun hκ b).symm
+  change ψE.symm (kw_surgehgf4_hfgkd_bcTensorFracIotaAlg E₀ E₀' F F' ι' (ψE' (χE' a)))
+      = χE (ι' a)
+  rw [hκE',
+    show kw_surgehgf4_hfgkd_bcTensorFracIotaAlg E₀ E₀' F F' ι'
+        (algebraMap ((E₀'⁄F).toAffine.FunctionField ⊗[F] F') _ (a ⊗ₜ[F] (1 : F')))
+      = algebraMap ((E₀⁄F).toAffine.FunctionField ⊗[F] F') _ ((ι' a) ⊗ₜ[F] (1 : F')) from by
+        change kw_surgehgf4_hfgkd_bcTensorFracIota E₀ E₀' F F' ι' _ = _
+        rw [kw_surgehgf4_hfgkd_bcTensorFracIota_algebraMap,
+          kw_surgehgf4_hfgkd_bcTensorIota_tmul],
+    hκE (ι' a)]
+
+end BCNoACEngine
+
+section KerTransportMint
+
+def KwD5BetweenCurvesKerTransportAlongEmbed : Prop :=
+  ∀ (R₀ : Type uK) [Field R₀] (E₀ E₀' : WeierstrassCurve R₀) [E₀.IsElliptic] [E₀'.IsElliptic]
+    (F₁ : Type uK) [Field F₁] [Algebra R₀ F₁] [DecidableEq F₁] [IsAlgClosed F₁] [CharZero F₁]
+    (F₂ : Type uK) [Field F₂] [Algebra R₀ F₂] [DecidableEq F₂] [IsAlgClosed F₂] [CharZero F₂]
+    [Algebra F₁ F₂] [IsScalarTower R₀ F₁ F₂]
+    [(E₀⁄F₁).IsElliptic] [(E₀'⁄F₁).IsElliptic] [(E₀⁄F₂).IsElliptic] [(E₀'⁄F₂).IsElliptic]
+    (ι₁ : (E₀'⁄F₁).toAffine.FunctionField →ₐ[F₁] (E₀⁄F₁).toAffine.FunctionField)
+    (hι₁ : ι₁.toRingHom.IsIntegral) (hfin₁ : FiniteAlong F₁ ι₁)
+    (ι₂ : (E₀'⁄F₂).toAffine.FunctionField →ₐ[F₂] (E₀⁄F₂).toAffine.FunctionField)
+    (hι₂ : ι₂.toRingHom.IsIntegral) (hfin₂ : FiniteAlong F₂ ι₂)
+    (_hχ : ∀ x : (E₀'⁄F₁).toAffine.FunctionField,
+      ι₂ (kw_functionFieldMapAlongGeneralNoAC E₀' F₁ F₂ x)
+        = kw_functionFieldMapAlongGeneralNoAC E₀ F₁ F₂ (ι₁ x))
+    (N : ℕ) [NeZero N],
+    IsAddCyclic (AddMonoidHom.ker
+      (pointMapOfPushforward ι₂ hι₂ hfin₂ (normFormulaAlong_of_elliptic ι₂ hfin₂))) →
+    Nat.card (AddMonoidHom.ker
+      (pointMapOfPushforward ι₂ hι₂ hfin₂ (normFormulaAlong_of_elliptic ι₂ hfin₂))) = N →
+    IsAddCyclic (AddMonoidHom.ker
+      (pointMapOfPushforward ι₁ hι₁ hfin₁ (normFormulaAlong_of_elliptic ι₁ hfin₁))) ∧
+    Nat.card (AddMonoidHom.ker
+      (pointMapOfPushforward ι₁ hι₁ hfin₁ (normFormulaAlong_of_elliptic ι₁ hfin₁))) = N
+
+def KwD5BetweenCurvesChiCompChiEqPhi : Prop :=
+  ∀ (K : Type uK) [Field K] [DecidableEq K] [CharZero K],
+    letI : Algebra ℚ K := DivisionRing.toRatAlgebra
+    ∀ (K₀ : IntermediateField ℚ K) (W : WeierstrassCurve ↥K₀) [W.IsElliptic]
+      (F₁ : Type uK) [Field F₁] [Algebra (↥K₀) F₁] [DecidableEq F₁] [CharZero F₁]
+      [Algebra F₁ K] [IsScalarTower (↥K₀) F₁ K]
+      [(W.map (algebraMap (↥K₀) K)).IsElliptic]
+      (a : W.toAffine.FunctionField),
+    kw_functionFieldMapAlongGeneralNoAC W F₁ K
+      (kw_functionFieldMapAlongGeneralNoAC W (↥K₀) F₁ a)
+    = kw_iotaDescentPhi (W.map (algebraMap (↥K₀) K)) W rfl a
+
+end KerTransportMint
+
+section Reduce
+
+set_option synthInstance.maxHeartbeats 8000000 in
+theorem kw_surgehgf4_hfgkd_hKD_of_kerTransport
+    (hKT : KwD5BetweenCurvesKerTransportAlongEmbed.{uK})
+    (hχB : KwD5BetweenCurvesChiCompChiEqPhi.{uK}) :
+    KwD5BetweenCurvesKerDescendAlgClosed.{uK} := by
+  intro K _ _ _ _ E E' _ _ _ _ _ _ _ _ ι hι hfin N _ hcyc hcard K₀ E₀ E₀' _ _
+    hE₀map hE₀'map ι' hι' hfin' hcompat
+  let : Algebra ℚ K := DivisionRing.toRatAlgebra
+  subst hE₀map; subst hE₀'map
+  have : CharZero (AlgebraicClosure (↥K₀)) :=
+    charZero_of_injective_algebraMap (algebraMap (↥K₀) (AlgebraicClosure (↥K₀))).injective
+  have : (E₀⁄(↥K₀)).IsElliptic :=
+    inferInstanceAs ((E₀.map (algebraMap (↥K₀) (↥K₀))).IsElliptic)
+  have : (E₀'⁄(↥K₀)).IsElliptic :=
+    inferInstanceAs ((E₀'.map (algebraMap (↥K₀) (↥K₀))).IsElliptic)
+  have hE₀AC : (E₀⁄(AlgebraicClosure (↥K₀))).IsElliptic :=
+    inferInstanceAs ((E₀.map (algebraMap (↥K₀) (AlgebraicClosure (↥K₀)))).IsElliptic)
+  have hE₀'AC : (E₀'⁄(AlgebraicClosure (↥K₀))).IsElliptic :=
+    inferInstanceAs ((E₀'.map (algebraMap (↥K₀) (AlgebraicClosure (↥K₀)))).IsElliptic)
+  have : (E₀⁄K).IsElliptic :=
+    inferInstanceAs ((E₀.map (algebraMap (↥K₀) K)).IsElliptic)
+  have : (E₀'⁄K).IsElliptic :=
+    inferInstanceAs ((E₀'.map (algebraMap (↥K₀) K)).IsElliptic)
+  have : IsDedekindDomain (E₀.map (algebraMap (↥K₀) K)).toAffine.CoordinateRing :=
+    WeierstrassCurve.Affine.CoordinateRing.isDedekindDomain (E₀.map (algebraMap (↥K₀) K))
+  have : IsDedekindDomain (E₀'.map (algebraMap (↥K₀) K)).toAffine.CoordinateRing :=
+    WeierstrassCurve.Affine.CoordinateRing.isDedekindDomain (E₀'.map (algebraMap (↥K₀) K))
+  have hgE : ‹WeierstrassCurve.Affine.GenusOnePlaceGate (E₀.map (algebraMap (↥K₀) K))›
+      = WeierstrassCurve.Affine.s13GlobalGate (E₀.map (algebraMap (↥K₀) K)).toAffine :=
+    WeierstrassCurve.Affine.GenusOnePlaceGate.ext_of_isCentred _ _ ‹_›
+      (WeierstrassCurve.Affine.s13GlobalGate_isCentred _)
+  have hgE' : ‹WeierstrassCurve.Affine.GenusOnePlaceGate (E₀'.map (algebraMap (↥K₀) K))›
+      = WeierstrassCurve.Affine.s13GlobalGate (E₀'.map (algebraMap (↥K₀) K)).toAffine :=
+    WeierstrassCurve.Affine.GenusOnePlaceGate.ext_of_isCentred _ _ ‹_›
+      (WeierstrassCurve.Affine.s13GlobalGate_isCentred _)
+  subst hgE
+  subst hgE'
+  let ι₀ : (E₀'⁄(AlgebraicClosure (↥K₀))).toAffine.FunctionField →ₐ[(AlgebraicClosure (↥K₀))]
+    (E₀⁄(AlgebraicClosure (↥K₀))).toAffine.FunctionField :=
+    kw_surgehgf4_hfgkd_bcIota₁NoAC E₀ E₀' (↥K₀) (AlgebraicClosure (↥K₀)) ι'
+  have hι₀ : ι₀.toRingHom.IsIntegral :=
+    kw_surgehgf4_hfgkd_bcIota₁NoAC_isIntegral E₀ E₀' (↥K₀) (AlgebraicClosure (↥K₀)) ι' hfin'
+  have hfin₀ : FiniteAlong (AlgebraicClosure (↥K₀)) ι₀ :=
+    kw_surgehgf4_hfgkd_bcIota₁NoAC_finiteAlong E₀ E₀' (↥K₀) (AlgebraicClosure (↥K₀)) ι' hfin'
+  let τ : (AlgebraicClosure (↥K₀)) →ₐ[↥K₀] K := IsAlgClosed.lift
+  let : Algebra (AlgebraicClosure (↥K₀)) K := τ.toRingHom.toAlgebra
+  have : IsScalarTower (↥K₀) (AlgebraicClosure (↥K₀)) K :=
+    IsScalarTower.of_algebraMap_eq fun r => (τ.commutes r).symm
+  have hD3 : ∀ a, ι₀ (kw_functionFieldMapAlongGeneralNoAC E₀' (↥K₀) (AlgebraicClosure (↥K₀)) a)
+      = kw_functionFieldMapAlongGeneralNoAC E₀ (↥K₀) (AlgebraicClosure (↥K₀)) (ι' a) :=
+    kw_surgehgf4_hfgkd_bcIota₁NoAC_compat E₀ E₀' (↥K₀) (AlgebraicClosure (↥K₀)) ι'
+  clear_value ι₀ τ
+  have hχΦE : ∀ a : E₀.toAffine.FunctionField,
+      kw_functionFieldMapAlongGeneralNoAC E₀ (AlgebraicClosure (↥K₀)) K
+        (kw_functionFieldMapAlongGeneralNoAC E₀ (↥K₀) (AlgebraicClosure (↥K₀)) a)
+      = kw_iotaDescentPhi (E₀.map (algebraMap (↥K₀) K)) E₀ rfl a :=
+    hχB K K₀ E₀ (AlgebraicClosure (↥K₀))
+  have hχΦE' : ∀ a : E₀'.toAffine.FunctionField,
+      kw_functionFieldMapAlongGeneralNoAC E₀' (AlgebraicClosure (↥K₀)) K
+        (kw_functionFieldMapAlongGeneralNoAC E₀' (↥K₀) (AlgebraicClosure (↥K₀)) a)
+      = kw_iotaDescentPhi (E₀'.map (algebraMap (↥K₀) K)) E₀' rfl a :=
+    hχB K K₀ E₀' (AlgebraicClosure (↥K₀))
+  have hχ : ∀ x : (E₀'⁄(AlgebraicClosure (↥K₀))).toAffine.FunctionField,
+      ι (kw_functionFieldMapAlongGeneralNoAC E₀' (AlgebraicClosure (↥K₀)) K x)
+        = kw_functionFieldMapAlongGeneralNoAC E₀ (AlgebraicClosure (↥K₀)) K (ι₀ x) := by
+    have hext := kw_iPFE_functionField_ringHom_ext
+      (F := AlgebraicClosure (↥K₀)) (W := (E₀'⁄(AlgebraicClosure (↥K₀))).toAffine)
+      (f := ι.toRingHom.comp
+        (kw_functionFieldMapAlongGeneralNoAC E₀' (AlgebraicClosure (↥K₀)) K).toRingHom)
+      (g := (kw_functionFieldMapAlongGeneralNoAC E₀ (AlgebraicClosure (↥K₀)) K).toRingHom.comp
+        ι₀.toRingHom)
+      (fun r => by
+        have h1 : ι ((kw_functionFieldMapAlongGeneralNoAC E₀' (AlgebraicClosure (↥K₀)) K)
+          (algebraMap _ _ r)) = algebraMap (AlgebraicClosure (↥K₀)) ((E₀⁄K).toAffine.FunctionField)
+          r :=
+          by
+          rw [(kw_functionFieldMapAlongGeneralNoAC E₀' (AlgebraicClosure (↥K₀)) K).commutes r,
+            IsScalarTower.algebraMap_apply (AlgebraicClosure (↥K₀)) K
+            ((E₀'⁄K).toAffine.FunctionField) r]
+          exact (ι.commutes _).trans (IsScalarTower.algebraMap_apply (AlgebraicClosure (↥K₀)) K
+            ((E₀⁄K).toAffine.FunctionField) r).symm
+        have h2 : (kw_functionFieldMapAlongGeneralNoAC E₀ (AlgebraicClosure (↥K₀)) K) (ι₀
+          (algebraMap _ _ r)) = algebraMap (AlgebraicClosure (↥K₀)) ((E₀⁄K).toAffine.FunctionField)
+          r :=
+          by
+          rw [ι₀.commutes r, (kw_functionFieldMapAlongGeneralNoAC E₀ (AlgebraicClosure (↥K₀))
+            K).commutes r]
+        exact h1.trans h2.symm)
+      (by
+        have key : ι ((kw_functionFieldMapAlongGeneralNoAC E₀' (AlgebraicClosure (↥K₀)) K)
+          ((kw_functionFieldMapAlongGeneralNoAC E₀' (↥K₀) (AlgebraicClosure (↥K₀)))
+          (polyToFunctionField (E₀'⁄(↥K₀)) X)))
+            = (kw_functionFieldMapAlongGeneralNoAC E₀ (AlgebraicClosure (↥K₀)) K) (ι₀
+              ((kw_functionFieldMapAlongGeneralNoAC E₀' (↥K₀) (AlgebraicClosure (↥K₀)))
+              (polyToFunctionField (E₀'⁄(↥K₀)) X))) := by
+          rw [hD3, hχΦE, hχΦE']; exact hcompat _
+        rw [kw_functionFieldMapAlongGeneralNoAC_polyToFunctionField_X] at key
+        exact key)
+      (by
+        have key : ι ((kw_functionFieldMapAlongGeneralNoAC E₀' (AlgebraicClosure (↥K₀)) K)
+          ((kw_functionFieldMapAlongGeneralNoAC E₀' (↥K₀) (AlgebraicClosure (↥K₀))) (yGen
+          (E₀'⁄(↥K₀)))))
+            = (kw_functionFieldMapAlongGeneralNoAC E₀ (AlgebraicClosure (↥K₀)) K) (ι₀
+              ((kw_functionFieldMapAlongGeneralNoAC E₀' (↥K₀) (AlgebraicClosure (↥K₀))) (yGen
+              (E₀'⁄(↥K₀))))) := by
+          rw [hD3, hχΦE, hχΦE']; exact hcompat _
+        rw [kw_functionFieldMapAlongGeneralNoAC_yGen] at key
+        exact key)
+    exact fun x => DFunLike.congr_fun hext x
+  have hKT_inst :=
+    hKT (↥K₀) E₀ E₀' (AlgebraicClosure (↥K₀)) K ι₀ hι₀ hfin₀ ι hι hfin hχ N hcyc hcard
+  exact ⟨hE₀AC, hE₀'AC, ι₀, hι₀, hfin₀, hKT_inst.1, hKT_inst.2⟩
+
+end Reduce
+
+section UpdatedWires
+
+theorem kw_surgehgf4_hfgkd_bcFGDescent_of_three
+    (hSD : KwD5BetweenCurvesSubfieldDescent.{uK})
+    (hKT : KwD5BetweenCurvesKerTransportAlongEmbed.{uK})
+    (hχB : KwD5BetweenCurvesChiCompChiEqPhi.{uK}) :
+    KwD5BetweenCurvesFGFieldDescent.{uK} :=
+  kw_fdn2_qephod_hend2fgd1_bcFGDescent_of_two hSD
+    (kw_surgehgf4_hfgkd_hKD_of_kerTransport hKT hχB)
+
+end UpdatedWires
+end ModularCurve
+end
+
+section
+
+namespace ModularCurve
+
+section BCCanonical
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable (E E' : WeierstrassCurve K) [E.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E] [WeierstrassCurve.Affine.AbelTheorem E]
+    [E'.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E']
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E']
+    [WeierstrassCurve.Affine.AbelTheorem E']
+variable (ι : E'.toAffine.FunctionField →ₐ[K] E.toAffine.FunctionField)
+
+def kw_surgehgf4_hSD_genSet : Set K :=
+  ({E.a₁, E.a₂, E.a₃, E.a₄, E.a₆} : Set K) ∪ {E'.a₁, E'.a₂, E'.a₃, E'.a₄, E'.a₆} ∪
+    ↑(kw_iCa_ffCoeffSet E (ι (polyToFunctionField E'.toAffine Polynomial.X))) ∪
+    ↑(kw_iCa_ffCoeffSet E (ι (yGen E'.toAffine)))
+
+omit [Algebra ℚ K] [IsAlgClosed K] [CharZero K] [E.IsElliptic] [GenusOnePlaceGate E]
+  [GenusOnePlaceGate.IsCentred E] [AbelTheorem E] [E'.IsElliptic] [GenusOnePlaceGate E']
+  [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E'] in
+theorem kw_surgehgf4_hSD_genSet_finite : (kw_surgehgf4_hSD_genSet E E' ι).Finite := by
+  unfold kw_surgehgf4_hSD_genSet
+  exact (((((Set.finite_singleton _).insert _ |>.insert _ |>.insert _ |>.insert _).union
+      ((Set.finite_singleton _).insert _ |>.insert _ |>.insert _ |>.insert _)).union
+    (Finset.finite_toSet _)).union (Finset.finite_toSet _))
+
+def kw_surgehgf4_hSD_K₀ : IntermediateField ℚ K :=
+  IntermediateField.adjoin ℚ (kw_surgehgf4_hSD_genSet E E' ι)
+
+omit [IsAlgClosed K] [CharZero K] [E.IsElliptic] [GenusOnePlaceGate E]
+  [GenusOnePlaceGate.IsCentred E] [AbelTheorem E] [E'.IsElliptic] [GenusOnePlaceGate E']
+  [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E'] in
+theorem kw_surgehgf4_hSD_K₀_fg : (kw_surgehgf4_hSD_K₀ E E' ι).FG :=
+  ⟨(kw_surgehgf4_hSD_genSet_finite E E' ι).toFinset, by rw [Set.Finite.coe_toFinset]; rfl⟩
+
+omit [IsAlgClosed K] [CharZero K] [E.IsElliptic] [GenusOnePlaceGate E]
+  [GenusOnePlaceGate.IsCentred E] [AbelTheorem E] [E'.IsElliptic] [GenusOnePlaceGate E']
+  [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E'] in
+theorem kw_surgehgf4_hSD_K₀_mem_E :
+    E.a₁ ∈ kw_surgehgf4_hSD_K₀ E E' ι ∧ E.a₂ ∈ kw_surgehgf4_hSD_K₀ E E' ι ∧
+    E.a₃ ∈ kw_surgehgf4_hSD_K₀ E E' ι ∧ E.a₄ ∈ kw_surgehgf4_hSD_K₀ E E' ι ∧
+    E.a₆ ∈ kw_surgehgf4_hSD_K₀ E E' ι := by
+  have h : ({E.a₁, E.a₂, E.a₃, E.a₄, E.a₆} : Set K) ⊆ kw_surgehgf4_hSD_K₀ E E' ι :=
+    fun x hx => IntermediateField.subset_adjoin ℚ _ (Or.inl (Or.inl (Or.inl hx)))
+  exact ⟨h (Or.inl rfl), h (Or.inr (Or.inl rfl)), h (Or.inr (Or.inr (Or.inl rfl))),
+    h (Or.inr (Or.inr (Or.inr (Or.inl rfl)))), h (Or.inr (Or.inr (Or.inr (Or.inr rfl))))⟩
+
+omit [IsAlgClosed K] [CharZero K] [E.IsElliptic] [GenusOnePlaceGate E]
+  [GenusOnePlaceGate.IsCentred E] [AbelTheorem E] [E'.IsElliptic] [GenusOnePlaceGate E']
+  [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E'] in
+theorem kw_surgehgf4_hSD_K₀_mem_E' :
+    E'.a₁ ∈ kw_surgehgf4_hSD_K₀ E E' ι ∧ E'.a₂ ∈ kw_surgehgf4_hSD_K₀ E E' ι ∧
+    E'.a₃ ∈ kw_surgehgf4_hSD_K₀ E E' ι ∧ E'.a₄ ∈ kw_surgehgf4_hSD_K₀ E E' ι ∧
+    E'.a₆ ∈ kw_surgehgf4_hSD_K₀ E E' ι := by
+  have h : ({E'.a₁, E'.a₂, E'.a₃, E'.a₄, E'.a₆} : Set K) ⊆ kw_surgehgf4_hSD_K₀ E E' ι :=
+    fun x hx => IntermediateField.subset_adjoin ℚ _ (Or.inl (Or.inl (Or.inr hx)))
+  exact ⟨h (Or.inl rfl), h (Or.inr (Or.inl rfl)), h (Or.inr (Or.inr (Or.inl rfl))),
+    h (Or.inr (Or.inr (Or.inr (Or.inl rfl)))), h (Or.inr (Or.inr (Or.inr (Or.inr rfl))))⟩
+
+omit [IsAlgClosed K] [CharZero K] [E.IsElliptic] [GenusOnePlaceGate E]
+  [GenusOnePlaceGate.IsCentred E] [AbelTheorem E] [E'.IsElliptic] [GenusOnePlaceGate E']
+  [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E'] in
+theorem kw_surgehgf4_hSD_ffCoeffSet_subset_X :
+    (↑(kw_iCa_ffCoeffSet E (ι (polyToFunctionField E'.toAffine Polynomial.X))) : Set K)
+      ⊆ kw_surgehgf4_hSD_K₀ E E' ι :=
+  fun _ hc => IntermediateField.subset_adjoin ℚ _ (Or.inl (Or.inr hc))
+
+omit [IsAlgClosed K] [CharZero K] [E.IsElliptic] [GenusOnePlaceGate E]
+  [GenusOnePlaceGate.IsCentred E] [AbelTheorem E] [E'.IsElliptic] [GenusOnePlaceGate E']
+  [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E'] in
+theorem kw_surgehgf4_hSD_ffCoeffSet_subset_Y :
+    (↑(kw_iCa_ffCoeffSet E (ι (yGen E'.toAffine))) : Set K)
+      ⊆ kw_surgehgf4_hSD_K₀ E E' ι :=
+  fun _ hc => IntermediateField.subset_adjoin ℚ _ (Or.inr hc)
+
+def kw_surgehgf4_hSD_E₀ : WeierstrassCurve (kw_surgehgf4_hSD_K₀ E E' ι) where
+  a₁ := ⟨E.a₁, (kw_surgehgf4_hSD_K₀_mem_E E E' ι).1⟩
+  a₂ := ⟨E.a₂, (kw_surgehgf4_hSD_K₀_mem_E E E' ι).2.1⟩
+  a₃ := ⟨E.a₃, (kw_surgehgf4_hSD_K₀_mem_E E E' ι).2.2.1⟩
+  a₄ := ⟨E.a₄, (kw_surgehgf4_hSD_K₀_mem_E E E' ι).2.2.2.1⟩
+  a₆ := ⟨E.a₆, (kw_surgehgf4_hSD_K₀_mem_E E E' ι).2.2.2.2⟩
+
+omit [IsAlgClosed K] [CharZero K] [E.IsElliptic] [GenusOnePlaceGate E]
+  [GenusOnePlaceGate.IsCentred E] [AbelTheorem E] [E'.IsElliptic] [GenusOnePlaceGate E']
+  [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E'] in
+theorem kw_surgehgf4_hSD_E₀_map :
+    (kw_surgehgf4_hSD_E₀ E E' ι).map (algebraMap (kw_surgehgf4_hSD_K₀ E E' ι) K) = E := by
+  ext <;> rfl
+
+scoped instance kw_surgehgf4_hSD_E₀_isElliptic : (kw_surgehgf4_hSD_E₀ E E' ι).IsElliptic := by
+  constructor; rw [isUnit_iff_ne_zero]; intro h0
+  have : (algebraMap (kw_surgehgf4_hSD_K₀ E E' ι) K) (kw_surgehgf4_hSD_E₀ E E' ι).Δ
+      = E.Δ := by rw [← WeierstrassCurve.map_Δ, kw_surgehgf4_hSD_E₀_map]
+  rw [h0, _root_.map_zero] at this; exact E.isUnit_Δ.ne_zero this.symm
+
+def kw_surgehgf4_hSD_E₀' : WeierstrassCurve (kw_surgehgf4_hSD_K₀ E E' ι) where
+  a₁ := ⟨E'.a₁, (kw_surgehgf4_hSD_K₀_mem_E' E E' ι).1⟩
+  a₂ := ⟨E'.a₂, (kw_surgehgf4_hSD_K₀_mem_E' E E' ι).2.1⟩
+  a₃ := ⟨E'.a₃, (kw_surgehgf4_hSD_K₀_mem_E' E E' ι).2.2.1⟩
+  a₄ := ⟨E'.a₄, (kw_surgehgf4_hSD_K₀_mem_E' E E' ι).2.2.2.1⟩
+  a₆ := ⟨E'.a₆, (kw_surgehgf4_hSD_K₀_mem_E' E E' ι).2.2.2.2⟩
+
+omit [IsAlgClosed K] [CharZero K] [E.IsElliptic] [GenusOnePlaceGate E]
+  [GenusOnePlaceGate.IsCentred E] [AbelTheorem E] [E'.IsElliptic] [GenusOnePlaceGate E']
+  [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E'] in
+theorem kw_surgehgf4_hSD_E₀'_map :
+    (kw_surgehgf4_hSD_E₀' E E' ι).map (algebraMap (kw_surgehgf4_hSD_K₀ E E' ι) K)
+      = E' := by ext <;> rfl
+
+scoped instance kw_surgehgf4_hSD_E₀'_isElliptic :
+    (kw_surgehgf4_hSD_E₀' E E' ι).IsElliptic := by
+  constructor; rw [isUnit_iff_ne_zero]; intro h0
+  have : (algebraMap (kw_surgehgf4_hSD_K₀ E E' ι) K) (kw_surgehgf4_hSD_E₀' E E' ι).Δ
+      = E'.Δ := by rw [← WeierstrassCurve.map_Δ, kw_surgehgf4_hSD_E₀'_map]
+  rw [h0, _root_.map_zero] at this; exact E'.isUnit_Δ.ne_zero this.symm
+
+end BCCanonical
+
+section BCPinned
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable {K₀ : IntermediateField ℚ K}
+variable (E₀ E₀' : WeierstrassCurve K₀) [E₀.IsElliptic] [E₀'.IsElliptic]
+
+variable (ι : (E₀'.map (algebraMap K₀ K)).toAffine.FunctionField
+  →ₐ[K] (E₀.map (algebraMap K₀ K)).toAffine.FunctionField)
+
+def kw_surgehgf4_hSD_CoeffsHyp : Prop :=
+  (kw_iA_crCoeffsIn E₀ (IsLocalization.sec (nonZeroDivisors (E₀.map (algebraMap K₀
+    K)).toAffine.CoordinateRing)
+      (ι (polyToFunctionField (E₀'.map (algebraMap K₀ K)).toAffine Polynomial.X))).1
+    ∧ kw_iA_crCoeffsIn E₀ ((IsLocalization.sec (nonZeroDivisors
+        (E₀.map (algebraMap K₀ K)).toAffine.CoordinateRing) (ι (polyToFunctionField (E₀'.map
+          (algebraMap K₀ K)).toAffine Polynomial.X))).2 :
+      (E₀.map (algebraMap K₀ K)).toAffine.CoordinateRing))
+  ∧ (kw_iA_crCoeffsIn E₀ (IsLocalization.sec (nonZeroDivisors (E₀.map (algebraMap K₀
+    K)).toAffine.CoordinateRing)
+      (ι (yGen (E₀'.map (algebraMap K₀ K)).toAffine))).1
+    ∧ kw_iA_crCoeffsIn E₀ ((IsLocalization.sec (nonZeroDivisors
+        (E₀.map (algebraMap K₀ K)).toAffine.CoordinateRing) (ι (yGen (E₀'.map (algebraMap K₀
+          K)).toAffine))).2 :
+      (E₀.map (algebraMap K₀ K)).toAffine.CoordinateRing))
+
+variable (hcoeffs : kw_surgehgf4_hSD_CoeffsHyp E₀ E₀' ι)
+
+def kw_surgehgf4_hSD_xP : E₀.toAffine.FunctionField :=
+  Classical.choose (kw_iA_ffDescend_exists E₀ (ι (polyToFunctionField (E₀'.map (algebraMap K₀
+    K)).toAffine Polynomial.X))
+    hcoeffs.1.1 hcoeffs.1.2)
+
+def kw_surgehgf4_hSD_yP : E₀.toAffine.FunctionField :=
+  Classical.choose (kw_iA_ffDescend_exists E₀ (ι (yGen (E₀'.map (algebraMap K₀ K)).toAffine))
+    hcoeffs.2.1 hcoeffs.2.2)
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] [E₀'.IsElliptic] in
+omit [E₀.IsElliptic] in
+theorem kw_surgehgf4_hSD_xP_spec :
+    kw_iA_phi E₀ (kw_surgehgf4_hSD_xP E₀ E₀' ι hcoeffs)
+      = ι (polyToFunctionField (E₀'.map (algebraMap K₀ K)).toAffine Polynomial.X) := by
+  classical
+  exact
+    Classical.choose_spec (kw_iA_ffDescend_exists E₀ _ hcoeffs.1.1 hcoeffs.1.2)
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] [E₀'.IsElliptic] in
+omit [E₀.IsElliptic] in
+theorem kw_surgehgf4_hSD_yP_spec :
+    kw_iA_phi E₀ (kw_surgehgf4_hSD_yP E₀ E₀' ι hcoeffs) = ι (yGen (E₀'.map (algebraMap K₀
+        K)).toAffine) := by
+  classical
+  exact
+    Classical.choose_spec (kw_iA_ffDescend_exists E₀ _ hcoeffs.2.1 hcoeffs.2.2)
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] [E₀'.IsElliptic] in
+omit [E₀.IsElliptic] in
+theorem kw_surgehgf4_hSD_equation :
+    (E₀'.map (algebraMap K₀ E₀.toAffine.FunctionField)).toAffine.Equation
+      (kw_surgehgf4_hSD_xP E₀ E₀' ι hcoeffs) (kw_surgehgf4_hSD_yP E₀ E₀' ι hcoeffs) := by
+  classical
+  set xP := kw_surgehgf4_hSD_xP E₀ E₀' ι hcoeffs with hxP
+  set yP := kw_surgehgf4_hSD_yP E₀ E₀' ι hcoeffs with hyP
+  have hι : ((E₀'.map (algebraMap K₀ K)).map (algebraMap K (E₀.map (algebraMap K₀
+    K)).toAffine.FunctionField)).toAffine.Equation
+      (ι (polyToFunctionField (E₀'.map (algebraMap K₀ K)).toAffine Polynomial.X)) (ι (yGen (E₀'.map
+        (algebraMap K₀ K)).toAffine)) := by
+    have h₀ := equation_map_polyToFunctionField_yGen (W := (E₀'.map (algebraMap K₀ K)).toAffine)
+    rw [Affine.equation_iff] at h₀ ⊢
+    have h₁ := congrArg ι h₀
+    simp only [map_add, map_mul, map_pow, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂,
+      WeierstrassCurve.map_a₃,
+      WeierstrassCurve.map_a₄, WeierstrassCurve.map_a₆, AlgHom.commutes] at h₁ ⊢
+    linear_combination h₁
+  rw [Affine.equation_iff] at hι ⊢
+  have hΦx : kw_iA_phi E₀ xP = ι (polyToFunctionField (E₀'.map (algebraMap K₀ K)).toAffine
+    Polynomial.X) :=
+    hxP ▸ kw_surgehgf4_hSD_xP_spec E₀ E₀' ι hcoeffs
+  have hΦy : kw_iA_phi E₀ yP = ι (yGen (E₀'.map (algebraMap K₀ K)).toAffine) :=
+    hyP ▸ kw_surgehgf4_hSD_yP_spec E₀ E₀' ι hcoeffs
+  have hΦc : ∀ (c : K₀), kw_iA_phi E₀ (algebraMap K₀ E₀.toAffine.FunctionField c)
+      = algebraMap K (E₀.map (algebraMap K₀ K)).toAffine.FunctionField (algebraMap K₀ K c) :=
+    fun c => ((kw_iA_phi E₀).commutes c).trans
+      (IsScalarTower.algebraMap_apply K₀ K (E₀.map (algebraMap K₀ K)).toAffine.FunctionField c)
+  have hΦinj : Function.Injective (kw_iA_phi E₀) := (kw_iA_phi E₀).toRingHom.injective
+  refine hΦinj ?_
+  simp only [map_add, map_mul, map_pow, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂,
+    WeierstrassCurve.map_a₃,
+    WeierstrassCurve.map_a₄, WeierstrassCurve.map_a₆] at hι ⊢
+  rw [hΦc, hΦc, hΦc, hΦc, hΦc, hΦx, hΦy]
+  exact hι
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] [E₀'.IsElliptic] in
+omit [E₀.IsElliptic] in
+theorem kw_surgehgf4_hSD_transcendental :
+    Function.Injective
+      (Polynomial.aeval (R := K₀) (kw_surgehgf4_hSD_xP E₀ E₀' ι hcoeffs)) := by
+  classical
+  refine (injective_iff_map_eq_zero _).mpr fun p hp => ?_
+  have hK : Transcendental K (ι (polyToFunctionField (E₀'.map (algebraMap K₀ K)).toAffine
+    Polynomial.X)) :=
+    by
+    intro halg
+    obtain ⟨r, hr0, hreval⟩ := halg
+    refine (transcendental_polyToFunctionField_X (W := (E₀'.map (algebraMap K₀ K)).toAffine)) ⟨r,
+      hr0, ?_⟩
+    apply ι.toRingHom.injective
+    rw [_root_.map_zero, ← hreval]
+    exact (Polynomial.aeval_algHom_apply ι _ r).symm
+  have hιX : Transcendental K₀ (ι (polyToFunctionField (E₀'.map (algebraMap K₀ K)).toAffine
+    Polynomial.X)) :=
+    hK.restrictScalars (R := K₀) (algebraMap K₀ K).injective
+  refine transcendental_iff.mp hιX p ?_
+  calc Polynomial.aeval (R := K₀) (ι (polyToFunctionField (E₀'.map (algebraMap K₀ K)).toAffine
+    Polynomial.X)) p
+      = Polynomial.aeval (R := K₀)
+          (kw_iA_phi E₀ (kw_surgehgf4_hSD_xP E₀ E₀' ι hcoeffs)) p := by
+        rw [kw_surgehgf4_hSD_xP_spec]
+    _ = kw_iA_phi E₀ (Polynomial.aeval (R := K₀) (kw_surgehgf4_hSD_xP E₀ E₀' ι hcoeffs) p) :=
+        Polynomial.aeval_algHom_apply (kw_iA_phi E₀) _ p
+    _ = kw_iA_phi E₀ 0 := by rw [hp]
+    _ = 0 := _root_.map_zero _
+
+def kw_surgehgf4_hSD_ι' : E₀'.toAffine.FunctionField →ₐ[K₀] E₀.toAffine.FunctionField :=
+  pointPullbackHomTo (kw_surgehgf4_hSD_equation E₀ E₀' ι hcoeffs)
+    (kw_surgehgf4_hSD_transcendental E₀ E₀' ι hcoeffs)
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] [E₀'.IsElliptic] in
+omit [E₀.IsElliptic] in
+theorem kw_surgehgf4_hSD_ι'_X :
+    kw_surgehgf4_hSD_ι' E₀ E₀' ι hcoeffs (polyToFunctionField E₀'.toAffine Polynomial.X)
+      = kw_surgehgf4_hSD_xP E₀ E₀' ι hcoeffs := by
+  classical
+  exact
+    pointPullbackHomTo_polyToFunctionField_X _ _
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] [E₀'.IsElliptic] in
+omit [E₀.IsElliptic] in
+theorem kw_surgehgf4_hSD_ι'_yGen :
+    kw_surgehgf4_hSD_ι' E₀ E₀' ι hcoeffs (yGen E₀'.toAffine)
+      = kw_surgehgf4_hSD_yP E₀ E₀' ι hcoeffs := by
+  classical
+  exact
+    pointPullbackHomTo_yGen _ _
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] in
+omit [E₀'.IsElliptic] in
+theorem kw_surgehgf4_hSD_phiE'_X :
+    kw_iA_phi E₀' (polyToFunctionField E₀'.toAffine Polynomial.X)
+      = polyToFunctionField (E₀'.map (algebraMap K₀ K)).toAffine Polynomial.X := by
+  classical
+  exact
+    pointPullbackHomTo_polyToFunctionField_X _ _
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] in
+omit [E₀'.IsElliptic] in
+theorem kw_surgehgf4_hSD_phiE'_yGen :
+    kw_iA_phi E₀' (yGen E₀'.toAffine) = yGen (E₀'.map (algebraMap K₀ K)).toAffine := by
+  classical
+  exact
+    pointPullbackHomTo_yGen _ _
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] [E₀'.IsElliptic] in
+omit [E₀.IsElliptic] in
+theorem kw_surgehgf4_hSD_phiCompat :
+    (ι.restrictScalars K₀).comp (kw_iA_phi E₀')
+      = (kw_iA_phi E₀).comp (kw_surgehgf4_hSD_ι' E₀ E₀' ι hcoeffs) := by
+  classical
+  refine kw_functionField_algHom_ext ?_ ?_
+  · change ι (kw_iA_phi E₀' (polyToFunctionField E₀'.toAffine Polynomial.X))
+        = kw_iA_phi E₀ (kw_surgehgf4_hSD_ι' E₀ E₀' ι hcoeffs
+            (polyToFunctionField E₀'.toAffine Polynomial.X))
+    rw [kw_surgehgf4_hSD_phiE'_X, kw_surgehgf4_hSD_ι'_X, kw_surgehgf4_hSD_xP_spec]
+  · change ι (kw_iA_phi E₀' (yGen E₀'.toAffine))
+        = kw_iA_phi E₀ (kw_surgehgf4_hSD_ι' E₀ E₀' ι hcoeffs (yGen E₀'.toAffine))
+    rw [kw_surgehgf4_hSD_phiE'_yGen, kw_surgehgf4_hSD_ι'_yGen, kw_surgehgf4_hSD_yP_spec]
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] [E₀'.IsElliptic] in
+omit [E₀.IsElliptic] in
+theorem kw_surgehgf4_hSD_phiCompat_apply (x : E₀'.toAffine.FunctionField) :
+    ι (kw_iA_phi E₀' x) = kw_iA_phi E₀ (kw_surgehgf4_hSD_ι' E₀ E₀' ι hcoeffs x) := by
+  classical
+  exact
+    DFunLike.congr_fun (kw_surgehgf4_hSD_phiCompat E₀ E₀' ι hcoeffs) x
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] [E₀'.IsElliptic] in
+omit [E₀.IsElliptic] in
+theorem kw_surgehgf4_hSD_finiteAlong :
+    FiniteAlong K₀ (kw_surgehgf4_hSD_ι' E₀ E₀' ι hcoeffs) := by
+  classical
+  set ι' := kw_surgehgf4_hSD_ι' E₀ E₀' ι hcoeffs
+  set xP := kw_surgehgf4_hSD_xP E₀ E₀' ι hcoeffs
+  have hxPtr : Transcendental K₀ xP :=
+    transcendental_iff_injective.mpr (kw_surgehgf4_hSD_transcendental E₀ E₀' ι hcoeffs)
+  have hfd : FiniteDimensional (↥(K₀ : Type uK)⟮xP⟯) E₀.toAffine.FunctionField :=
+    kw_iPFA_finiteDimensional_adjoin_transcendental E₀.toAffine hxPtr
+  have hxPrange : xP ∈ ι'.fieldRange :=
+    ⟨polyToFunctionField E₀'.toAffine Polynomial.X, kw_surgehgf4_hSD_ι'_X E₀ E₀' ι hcoeffs⟩
+  have hle : (K₀ : Type uK)⟮xP⟯ ≤ ι'.fieldRange :=
+    IntermediateField.adjoin_simple_le_iff.mpr hxPrange
+  let algIncl : Algebra (↥(K₀ : Type uK)⟮xP⟯) (↥ι'.fieldRange) :=
+    (IntermediateField.inclusion hle).toRingHom.toAlgebra
+  have towIncl : IsScalarTower (↥(K₀ : Type uK)⟮xP⟯) (↥ι'.fieldRange)
+      E₀.toAffine.FunctionField :=
+    IsScalarTower.of_algebraMap_eq (fun r => rfl)
+  have hfdR : FiniteDimensional (↥ι'.fieldRange) E₀.toAffine.FunctionField :=
+    FiniteDimensional.right (↥(K₀ : Type uK)⟮xP⟯) (↥ι'.fieldRange) E₀.toAffine.FunctionField
+  change ι'.toRingHom.Finite
+  let ρ : E₀'.toAffine.FunctionField →+* ↥ι'.fieldRange :=
+    { toFun := fun x => ⟨ι' x, x, rfl⟩
+      map_one' := Subtype.ext (map_one ι')
+      map_mul' := fun a b => Subtype.ext (map_mul ι' a b)
+      map_zero' := Subtype.ext (_root_.map_zero ι')
+      map_add' := fun a b => Subtype.ext (map_add ι' a b) }
+  have hsurj : Function.Surjective ρ := by rintro ⟨y, x, rfl⟩; exact ⟨x, rfl⟩
+  have hfactor : ι'.toRingHom
+      = (algebraMap (↥ι'.fieldRange) E₀.toAffine.FunctionField).comp ρ := by ext x; rfl
+  rw [hfactor]
+  exact RingHom.Finite.comp hfdR (RingHom.Finite.of_surjective _ hsurj)
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] [E₀'.IsElliptic] in
+omit [E₀.IsElliptic] in
+theorem kw_surgehgf4_hSD_isIntegral :
+    (kw_surgehgf4_hSD_ι' E₀ E₀' ι hcoeffs).toRingHom.IsIntegral := by
+  classical
+  exact
+    RingHom.Finite.to_isIntegral
+      (f := (kw_surgehgf4_hSD_ι' E₀ E₀' ι hcoeffs).toRingHom)
+      (kw_surgehgf4_hSD_finiteAlong E₀ E₀' ι hcoeffs)
+
+def KwD5BCSubfieldDescentPinnedFinrankEq : Prop :=
+  finrankAlong K₀ (kw_surgehgf4_hSD_ι' E₀ E₀' ι hcoeffs) = finrankAlong K ι
+
+end BCPinned
+
+section RouteCBridge
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable {K₀ : IntermediateField ℚ K}
+variable (E₀ E₀' : WeierstrassCurve K₀) [E₀.IsElliptic] [E₀'.IsElliptic]
+
+def kw_surgehgf4_hSD_ιMpr
+    {W W' : WeierstrassCurve K}
+    (heq : E₀.map (algebraMap K₀ K) = W) (heq' : E₀'.map (algebraMap K₀ K) = W')
+    (ι : W'.toAffine.FunctionField →ₐ[K] W.toAffine.FunctionField) :
+    (E₀'.map (algebraMap K₀ K)).toAffine.FunctionField
+      →ₐ[K] (E₀.map (algebraMap K₀ K)).toAffine.FunctionField :=
+  Eq.mpr (congrArg (fun V => V.toAffine.FunctionField
+      →ₐ[K] (E₀.map (algebraMap K₀ K)).toAffine.FunctionField) heq')
+    (Eq.mpr (congrArg (fun V => W'.toAffine.FunctionField →ₐ[K] V.toAffine.FunctionField)
+        heq) ι)
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] in
+omit [E₀.IsElliptic] in
+theorem kw_surgehgf4_hSD_phi_eq_iotaDescentPhi :
+    kw_iA_phi E₀ = kw_iotaDescentPhi (E₀.map (algebraMap K₀ K)) E₀ rfl := by
+  classical
+  refine kw_functionField_algHom_ext ?_ ?_
+  · exact (pointPullbackHomTo_polyToFunctionField_X _ _).trans
+      (kw_iotaDescentPhi_X _ _ rfl).symm
+  · exact (pointPullbackHomTo_yGen _ _).trans (kw_iotaDescentPhi_yGen _ _ rfl).symm
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] in
+theorem kw_surgehgf4_hSD_instance_cast
+    {W W' : WeierstrassCurve K} [W.IsElliptic] [W'.IsElliptic]
+    (heq : E₀.map (algebraMap K₀ K) = W) (heq' : E₀'.map (algebraMap K₀ K) = W')
+    (ι : W'.toAffine.FunctionField →ₐ[K] W.toAffine.FunctionField)
+    (_hι : ι.toRingHom.IsIntegral) (_hfin : FiniteAlong K ι) (hfg : K₀.FG)
+    (hcoeffs : kw_surgehgf4_hSD_CoeffsHyp E₀ E₀'
+      (kw_surgehgf4_hSD_ιMpr E₀ E₀' heq heq' ι))
+    (hFrEq : KwD5BCSubfieldDescentPinnedFinrankEq E₀ E₀'
+      (kw_surgehgf4_hSD_ιMpr E₀ E₀' heq heq' ι) hcoeffs) :
+    ∃ (K₀ : IntermediateField ℚ K) (_ : K₀.FG)
+      (E₀ E₀' : WeierstrassCurve K₀) (_ : E₀.IsElliptic) (_ : E₀'.IsElliptic)
+      (hE₀map : E₀.map (algebraMap K₀ K) = W) (hE₀'map : E₀'.map (algebraMap K₀ K) = W')
+      (ι' : E₀'.toAffine.FunctionField →ₐ[K₀] E₀.toAffine.FunctionField)
+      (_hι' : ι'.toRingHom.IsIntegral) (_hfin' : FiniteAlong K₀ ι')
+      (_hfinrank : finrankAlong K₀ ι' = finrankAlong K ι),
+      ∀ x : E₀'.toAffine.FunctionField,
+        ι (kw_iotaDescentPhi W' E₀' hE₀'map x)
+          = kw_iotaDescentPhi W E₀ hE₀map (ι' x) := by
+  classical
+  subst heq; subst heq'
+  refine ⟨K₀, hfg, E₀, E₀', inferInstance, inferInstance, rfl, rfl,
+    kw_surgehgf4_hSD_ι' E₀ E₀' ι hcoeffs,
+    kw_surgehgf4_hSD_isIntegral E₀ E₀' ι hcoeffs,
+    kw_surgehgf4_hSD_finiteAlong E₀ E₀' ι hcoeffs, hFrEq, fun x => ?_⟩
+  rw [← kw_surgehgf4_hSD_phi_eq_iotaDescentPhi E₀,
+      ← kw_surgehgf4_hSD_phi_eq_iotaDescentPhi E₀']
+  exact kw_surgehgf4_hSD_phiCompat_apply E₀ E₀' ι hcoeffs x
+
+omit [E₀.IsElliptic] [E₀'.IsElliptic] in
+omit [IsAlgClosed K] [CharZero K] in
+theorem kw_surgehgf4_hSD_coeffsHyp_cast
+    {W W' : WeierstrassCurve K} [W.IsElliptic] [W'.IsElliptic]
+    (heq : E₀.map (algebraMap K₀ K) = W) (heq' : E₀'.map (algebraMap K₀ K) = W')
+    (ι : W'.toAffine.FunctionField →ₐ[K] W.toAffine.FunctionField)
+    (hX : (↑(kw_iCa_ffCoeffSet W (ι (polyToFunctionField W'.toAffine Polynomial.X))) : Set K)
+      ⊆ (K₀ : Set K))
+    (hY : (↑(kw_iCa_ffCoeffSet W (ι (yGen W'.toAffine))) : Set K) ⊆ (K₀ : Set K)) :
+    kw_surgehgf4_hSD_CoeffsHyp E₀ E₀' (kw_surgehgf4_hSD_ιMpr E₀ E₀' heq heq' ι) := by
+  subst heq; subst heq'
+  refine ⟨⟨fun i j => ?_, fun i j => ?_⟩, fun i j => ?_, fun i j => ?_⟩
+  · exact (kw_iCa_crCoeffsIn_of_ffCoeffSet_subset _ _ hX i j).1
+  · exact (kw_iCa_crCoeffsIn_of_ffCoeffSet_subset _ _ hX i j).2
+  · exact (kw_iCa_crCoeffsIn_of_ffCoeffSet_subset _ _ hY i j).1
+  · exact (kw_iCa_crCoeffsIn_of_ffCoeffSet_subset _ _ hY i j).2
+
+end RouteCBridge
+
+section Wire
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable (E E' : WeierstrassCurve K) [E.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E] [WeierstrassCurve.Affine.AbelTheorem E]
+    [E'.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E']
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E']
+    [WeierstrassCurve.Affine.AbelTheorem E']
+variable (ι : E'.toAffine.FunctionField →ₐ[K] E.toAffine.FunctionField)
+
+def kw_surgehgf4_hSD_ιCast :
+    ((kw_surgehgf4_hSD_E₀' E E' ι).map
+        (algebraMap (kw_surgehgf4_hSD_K₀ E E' ι) K)).toAffine.FunctionField
+      →ₐ[K] ((kw_surgehgf4_hSD_E₀ E E' ι).map
+        (algebraMap (kw_surgehgf4_hSD_K₀ E E' ι) K)).toAffine.FunctionField :=
+  kw_surgehgf4_hSD_ιMpr (kw_surgehgf4_hSD_E₀ E E' ι) (kw_surgehgf4_hSD_E₀' E E' ι)
+    (kw_surgehgf4_hSD_E₀_map E E' ι) (kw_surgehgf4_hSD_E₀'_map E E' ι) ι
+
+omit [IsAlgClosed K] [CharZero K] [GenusOnePlaceGate E] [GenusOnePlaceGate.IsCentred E]
+  [AbelTheorem E] [GenusOnePlaceGate E'] [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E'] in
+theorem kw_surgehgf4_hSD_hcoeffs_canonical :
+    kw_surgehgf4_hSD_CoeffsHyp (kw_surgehgf4_hSD_E₀ E E' ι)
+      (kw_surgehgf4_hSD_E₀' E E' ι) (kw_surgehgf4_hSD_ιCast E E' ι) :=
+  kw_surgehgf4_hSD_coeffsHyp_cast (kw_surgehgf4_hSD_E₀ E E' ι)
+    (kw_surgehgf4_hSD_E₀' E E' ι) (kw_surgehgf4_hSD_E₀_map E E' ι)
+    (kw_surgehgf4_hSD_E₀'_map E E' ι) ι
+    (kw_surgehgf4_hSD_ffCoeffSet_subset_X E E' ι)
+    (kw_surgehgf4_hSD_ffCoeffSet_subset_Y E E' ι)
+
+def KwD5BCSubfieldDescentCanonicalFinrankEq : Prop :=
+  ∀ hcoeffs,
+    KwD5BCSubfieldDescentPinnedFinrankEq (kw_surgehgf4_hSD_E₀ E E' ι)
+      (kw_surgehgf4_hSD_E₀' E E' ι) (kw_surgehgf4_hSD_ιCast E E' ι) hcoeffs
+
+end Wire
+
+theorem kw_surgehgf4_hSD_of_canonicalFinrankEq
+    (hFrEq : ∀ (K : Type uK) [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+      (E E' : WeierstrassCurve.Affine K) [E.IsElliptic]
+      [WeierstrassCurve.Affine.GenusOnePlaceGate E]
+      [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E]
+      [WeierstrassCurve.Affine.AbelTheorem E] [E'.IsElliptic]
+      [WeierstrassCurve.Affine.GenusOnePlaceGate E']
+      [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E']
+      [WeierstrassCurve.Affine.AbelTheorem E']
+      (ι : E'.FunctionField →ₐ[K] E.FunctionField)
+      (_hι : ι.toRingHom.IsIntegral) (_hfin : FiniteAlong K ι),
+      letI : Algebra ℚ K := DivisionRing.toRatAlgebra
+      KwD5BCSubfieldDescentCanonicalFinrankEq E E' ι) :
+    KwD5BetweenCurvesSubfieldDescent.{uK} := by
+  intro K _ _ _ _ E E' _ _ _ _ _ _ _ _ ι hι hfin
+  let : Algebra ℚ K := DivisionRing.toRatAlgebra
+  exact kw_surgehgf4_hSD_instance_cast (kw_surgehgf4_hSD_E₀ E E' ι)
+    (kw_surgehgf4_hSD_E₀' E E' ι) (kw_surgehgf4_hSD_E₀_map E E' ι)
+    (kw_surgehgf4_hSD_E₀'_map E E' ι) ι hι hfin
+    (kw_surgehgf4_hSD_K₀_fg E E' ι) (kw_surgehgf4_hSD_hcoeffs_canonical E E' ι)
+    (hFrEq K E E' ι hι hfin (kw_surgehgf4_hSD_hcoeffs_canonical E E' ι))
+
+end ModularCurve
+end
+
+section
+
+namespace ModularCurve
+
+theorem kw_surgehgf4_hfgkd_chiCompChiEqPhi_proved :
+    KwD5BetweenCurvesChiCompChiEqPhi.{uK} := by
+  intro K _ _ _ K₀ W _ F₁ _ _ _ _ _ _ _
+  let χ₁ := kw_functionFieldMapAlongGeneralNoAC W (↥K₀) F₁
+  let χ₂ := kw_functionFieldMapAlongGeneralNoAC W F₁ K
+  let Φ := kw_iotaDescentPhi (W.map (algebraMap (↥K₀) K)) W rfl
+  suffices h : (χ₂.toRingHom.comp χ₁.toRingHom
+      : W.toAffine.FunctionField →+* (W.map (algebraMap (↥K₀) K)).toAffine.FunctionField)
+      = Φ.toRingHom from fun a => DFunLike.congr_fun h a
+  refine kw_iPFE_functionField_ringHom_ext (F := ↥K₀) (W := W.toAffine)
+    (fun r => ?hF) ?hX ?hy
+  case hF =>
+    change χ₂ (χ₁ (algebraMap (↥K₀) W.toAffine.FunctionField r))
+      = Φ (algebraMap (↥K₀) W.toAffine.FunctionField r)
+    rw [Φ.commutes]
+    rw [IsScalarTower.algebraMap_apply (↥K₀) K
+      (W.map (algebraMap (↥K₀) K)).toAffine.FunctionField]
+    erw [χ₁.commutes]
+    rw [IsScalarTower.algebraMap_apply (↥K₀) F₁ (W⁄F₁).FunctionField]
+    erw [χ₂.commutes]
+    rw [IsScalarTower.algebraMap_apply F₁ K (W⁄K).FunctionField,
+      ← IsScalarTower.algebraMap_apply (↥K₀) F₁ K]
+    rfl
+  case hX =>
+    change χ₂ (χ₁ (polyToFunctionField W.toAffine X))
+      = Φ (polyToFunctionField W.toAffine X)
+    erw [kw_functionFieldMapAlongGeneralNoAC_polyToFunctionField_X W (↥K₀) F₁,
+      kw_functionFieldMapAlongGeneralNoAC_polyToFunctionField_X W F₁ K,
+      kw_iotaDescentPhi_X (W.map (algebraMap (↥K₀) K)) W rfl]
+    rfl
+  case hy =>
+    change χ₂ (χ₁ (yGen W.toAffine)) = Φ (yGen W.toAffine)
+    erw [kw_functionFieldMapAlongGeneralNoAC_yGen W (↥K₀) F₁,
+      kw_functionFieldMapAlongGeneralNoAC_yGen W F₁ K,
+      kw_iotaDescentPhi_yGen (W.map (algebraMap (↥K₀) K)) W rfl]
+    rfl
+
+end ModularCurve
+end
+
+section
+
+namespace ModularCurve
+
+attribute [local instance] Classical.propDecidable
+
+section Bridge
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable {K₀ : IntermediateField ℚ K}
+variable (E₀ : WeierstrassCurve K₀) [E₀.IsElliptic]
+
+attribute [-instance] IntermediateField.instAlgebraSubtypeMem in
+def kw_surgehgf4_cfe_fχ :
+    E₀.toAffine.FunctionField →+* (E₀.map (algebraMap K₀ K)).toAffine.FunctionField :=
+  (kw_functionFieldMapAlongGeneralNoAC E₀ (↥K₀) K).toRingHom
+
+attribute [-instance] IntermediateField.instAlgebraSubtypeMem in
+omit [DecidableEq K] in
+omit [IsAlgClosed K] in
+omit [CharZero K] [E₀.IsElliptic] in
+theorem kw_surgehgf4_cfe_fχ_apply (a : E₀.toAffine.FunctionField) :
+    kw_surgehgf4_cfe_fχ E₀ a = kw_functionFieldMapAlongGeneralNoAC E₀ (↥K₀) K a := by
+  classical
+  exact
+    rfl
+
+attribute [-instance] IntermediateField.instAlgebraSubtypeMem in
+omit [DecidableEq K] in
+omit [IsAlgClosed K] in
+omit [CharZero K] [E₀.IsElliptic] in
+theorem kw_surgehgf4_cfe_chi_const (r : ↥K₀) :
+    kw_functionFieldMapAlongGeneralNoAC E₀ (↥K₀) K
+        (algebraMap (↥K₀) E₀.toAffine.FunctionField r)
+      = algebraMap K (E₀.map (algebraMap K₀ K)).toAffine.FunctionField
+          (algebraMap (↥K₀) K r) := by
+  classical
+  erw [(kw_functionFieldMapAlongGeneralNoAC E₀ (↥K₀) K).commutes r]
+  exact IsScalarTower.algebraMap_apply (↥K₀) K (E₀⁄K).FunctionField r
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] in
+omit [CharZero K] [E₀.IsElliptic] in
+theorem kw_surgehgf4_cfe_fχ_eq_phi :
+    kw_surgehgf4_cfe_fχ E₀ = (kw_iA_phi E₀).toRingHom := by
+  classical
+  refine kw_iPFE_functionField_ringHom_ext (F := ↥K₀) (W := E₀.toAffine)
+    (fun r => ?hF) ?hX ?hy
+  case hF =>
+    change kw_surgehgf4_cfe_fχ E₀ (algebraMap (↥K₀) E₀.toAffine.FunctionField r)
+      = kw_iA_phi E₀ (algebraMap (↥K₀) E₀.toAffine.FunctionField r)
+    rw [(kw_iA_phi E₀).commutes r,
+      IsScalarTower.algebraMap_apply (↥K₀) K
+        (E₀.map (algebraMap K₀ K)).toAffine.FunctionField,
+      kw_surgehgf4_cfe_fχ_apply, kw_surgehgf4_cfe_chi_const]
+  case hX =>
+    change kw_surgehgf4_cfe_fχ E₀ (polyToFunctionField E₀.toAffine X)
+      = kw_iA_phi E₀ (polyToFunctionField E₀.toAffine X)
+    rw [kw_surgehgf4_cfe_fχ_apply]
+    erw [kw_functionFieldMapAlongGeneralNoAC_polyToFunctionField_X E₀ (↥K₀) K]
+  case hy =>
+    change kw_surgehgf4_cfe_fχ E₀ (yGen E₀.toAffine) = kw_iA_phi E₀ (yGen E₀.toAffine)
+    rw [kw_surgehgf4_cfe_fχ_apply]
+    erw [kw_functionFieldMapAlongGeneralNoAC_yGen E₀ (↥K₀) K]
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] in
+omit [CharZero K] [E₀.IsElliptic] in
+theorem kw_surgehgf4_cfe_chi_eq_phi_apply (a : E₀.toAffine.FunctionField) :
+    kw_functionFieldMapAlongGeneralNoAC E₀ (↥K₀) K a = kw_iA_phi E₀ a := by
+  classical
+  rw [← kw_surgehgf4_cfe_fχ_apply]
+  exact DFunLike.congr_fun (kw_surgehgf4_cfe_fχ_eq_phi E₀) a
+
+end Bridge
+
+section BCPinnedDischarge
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable {K₀ : IntermediateField ℚ K}
+variable (E₀ E₀' : WeierstrassCurve K₀)
+
+scoped instance kw_surgehgf4_cfe_instE₀'K₀ [E₀'.IsElliptic] : (E₀'⁄(↥K₀)).IsElliptic :=
+  inferInstanceAs ((E₀'.map (algebraMap (↥K₀) (↥K₀))).IsElliptic)
+
+scoped instance kw_surgehgf4_cfe_instE₀'K [E₀'.IsElliptic] : (E₀'⁄K).IsElliptic :=
+  inferInstanceAs ((E₀'.map (algebraMap (↥K₀) K)).IsElliptic)
+
+variable (ι : (E₀'.map (algebraMap K₀ K)).toAffine.FunctionField
+  →ₐ[K] (E₀.map (algebraMap K₀ K)).toAffine.FunctionField)
+variable (hcoeffs : kw_surgehgf4_hSD_CoeffsHyp E₀ E₀' ι)
+
+omit [DecidableEq K] [IsAlgClosed K] [CharZero K] in
+theorem kw_surgehgf4_cfe_bcIota₁NoAC_eq_ι :
+    kw_surgehgf4_hfgkd_bcIota₁NoAC E₀ E₀' (↥K₀) K
+        (kw_surgehgf4_hSD_ι' E₀ E₀' ι hcoeffs) = ι := by
+  classical
+  set ι' := kw_surgehgf4_hSD_ι' E₀ E₀' ι hcoeffs with hι'_def
+  refine kw_functionField_algHom_ext ?_ ?_
+  · have key : ι (kw_functionFieldMapAlongGeneralNoAC E₀' (↥K₀) K (polyToFunctionField
+      (E₀'⁄(↥K₀)).toAffine X))
+        = kw_surgehgf4_hfgkd_bcIota₁NoAC E₀ E₀' (↥K₀) K ι'
+            (kw_functionFieldMapAlongGeneralNoAC E₀' (↥K₀) K (polyToFunctionField
+              (E₀'⁄(↥K₀)).toAffine X)) := by
+      rw [kw_surgehgf4_hfgkd_bcIota₁NoAC_compat, kw_surgehgf4_cfe_chi_eq_phi_apply E₀,
+        kw_surgehgf4_cfe_chi_eq_phi_apply E₀']
+      exact kw_surgehgf4_hSD_phiCompat_apply E₀ E₀' ι hcoeffs _
+    rw [kw_functionFieldMapAlongGeneralNoAC_polyToFunctionField_X] at key
+    exact key.symm
+  · have key : ι (kw_functionFieldMapAlongGeneralNoAC E₀' (↥K₀) K (yGen (E₀'⁄(↥K₀)).toAffine))
+        = kw_surgehgf4_hfgkd_bcIota₁NoAC E₀ E₀' (↥K₀) K ι'
+            (kw_functionFieldMapAlongGeneralNoAC E₀' (↥K₀) K (yGen (E₀'⁄(↥K₀)).toAffine)) := by
+      rw [kw_surgehgf4_hfgkd_bcIota₁NoAC_compat, kw_surgehgf4_cfe_chi_eq_phi_apply E₀,
+        kw_surgehgf4_cfe_chi_eq_phi_apply E₀']
+      exact kw_surgehgf4_hSD_phiCompat_apply E₀ E₀' ι hcoeffs _
+    rw [kw_functionFieldMapAlongGeneralNoAC_yGen] at key
+    exact key.symm
+
+omit [DecidableEq K] [IsAlgClosed K] [CharZero K] in
+theorem kw_surgehgf4_cfe_pinnedFinrankEq :
+    KwD5BCSubfieldDescentPinnedFinrankEq E₀ E₀' ι hcoeffs := by
+  classical
+  have hfin' : FiniteAlong (↥K₀) (kw_surgehgf4_hSD_ι' E₀ E₀' ι hcoeffs) :=
+    kw_surgehgf4_hSD_finiteAlong E₀ E₀' ι hcoeffs
+  have hD2 := kw_surgehgf4_hfgkd_bcIota₁NoAC_finrankAlong E₀ E₀' (↥K₀) K
+    (kw_surgehgf4_hSD_ι' E₀ E₀' ι hcoeffs) hfin'
+  have heq := kw_surgehgf4_cfe_bcIota₁NoAC_eq_ι E₀ E₀' ι hcoeffs
+  unfold KwD5BCSubfieldDescentPinnedFinrankEq
+  rw [heq] at hD2
+  exact hD2.symm
+
+end BCPinnedDischarge
+
+section Canonical
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K] (E E' : WeierstrassCurve K)
+  (ι : E'.toAffine.FunctionField →ₐ[K] E.toAffine.FunctionField)
+
+theorem kw_surgehgf4_cfe_canonicalFinrankEq :
+    KwD5BCSubfieldDescentCanonicalFinrankEq E E' ι := fun hcoeffs =>
+  kw_surgehgf4_cfe_pinnedFinrankEq (kw_surgehgf4_hSD_E₀ E E' ι)
+    (kw_surgehgf4_hSD_E₀' E E' ι) (kw_surgehgf4_hSD_ιCast E E' ι) hcoeffs
+
+end Canonical
+
+section Wires
+
+theorem kw_surgehgf4_cfe_hSD_discharge : KwD5BetweenCurvesSubfieldDescent.{uK} := by
+  refine kw_surgehgf4_hSD_of_canonicalFinrankEq ?_
+  intro K _ _ _ _ E E' _ _ _ _ _ _ _ _ ι _hι _hfin
+  let : Algebra ℚ K := DivisionRing.toRatAlgebra
+  exact kw_surgehgf4_cfe_canonicalFinrankEq E E' ι
+
+theorem kw_surgehgf4_cfe_bcFGDescent_of_two
+    (hKT : KwD5BetweenCurvesKerTransportAlongEmbed.{uK})
+    (hχB : KwD5BetweenCurvesChiCompChiEqPhi.{uK}) :
+    KwD5BetweenCurvesFGFieldDescent.{uK} :=
+  kw_surgehgf4_hfgkd_bcFGDescent_of_three kw_surgehgf4_cfe_hSD_discharge hKT hχB
+
+end Wires
+end ModularCurve
+
+end
+
+namespace ModularCurve
+
+theorem s13_stub_ktd : KwD5BetweenCurvesKerTransportAlongEmbed.{uK} := by
+  intro R₀ _ E₀ E₀' _ _ F₁ _ _ _ _ _ F₂ _ _ _ _ _ _ _ _ _ _ _ ι₁ hι₁ hfin₁ ι₂ hι₂ hfin₂ hχ N _ hcyc
+    hcard
+  exact WeierstrassCurve.Affine.isAddCyclic_ker_pointMapOfPushforward_of_baseChange_algHom R₀ E₀ E₀'
+    F₁ F₂
+    (kw_functionFieldMapAlongGeneralNoAC E₀ F₁ F₂)
+    (kw_functionFieldMapAlongGeneralNoAC_polyToFunctionField_X E₀ F₁ F₂)
+    (kw_functionFieldMapAlongGeneralNoAC_yGen E₀ F₁ F₂)
+    (kw_functionFieldMapAlongGeneralNoAC E₀' F₁ F₂)
+    (kw_functionFieldMapAlongGeneralNoAC_polyToFunctionField_X E₀' F₁ F₂)
+    (kw_functionFieldMapAlongGeneralNoAC_yGen E₀' F₁ F₂)
+    ι₁ hι₁ hfin₁ (WeierstrassCurve.Affine.normFormulaAlong_of_elliptic ι₁ hfin₁)
+    ι₂ hι₂ hfin₂ (WeierstrassCurve.Affine.normFormulaAlong_of_elliptic ι₂ hfin₂)
+    hχ N hcyc hcard
+
+theorem s13_bcFGDescent : KwD5BetweenCurvesFGFieldDescent.{uK} :=
+  kw_surgehgf4_cfe_bcFGDescent_of_two s13_stub_ktd kw_surgehgf4_hfgkd_chiCompChiEqPhi_proved
+end ModularCurve
+
+open _root_.WeierstrassCurve _root_.WeierstrassCurve.Affine in
+theorem solution
+    {K : Type uK} [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+    (E E' : WeierstrassCurve.Affine K) [E.IsElliptic] [E'.IsElliptic]
+    [GenusOnePlaceGate E] [GenusOnePlaceGate.IsCentred E] [AbelTheorem E]
+    [GenusOnePlaceGate E'] [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField) (hι : ι.toRingHom.IsIntegral)
+    (hfin : FiniteAlong K ι)
+    (hN : NormFormulaAlong K ι hfin) (N : ℕ) [NeZero N]
+    (hcyc : IsAddCyclic (pointMapOfPushforward ι hι hfin hN).ker)
+    (hcard : Nat.card (pointMapOfPushforward ι hι hfin hN).ker = N) :
+    letI : Algebra ℚ K := DivisionRing.toRatAlgebra
+    ∃ (K₀ : IntermediateField ℚ K) (_ : Countable K₀)
+      (E₀ E₀' : WeierstrassCurve K₀) (_ : E₀.IsElliptic) (_ : E₀'.IsElliptic)
+      (_ : E₀.map (algebraMap K₀ K) = E) (_ : E₀'.map (algebraMap K₀ K) = E')
+      (_ : (E₀.baseChange (AlgebraicClosure K₀)).IsElliptic)
+      (_ : (E₀'.baseChange (AlgebraicClosure K₀)).IsElliptic)
+      (ι₀ : (E₀'.baseChange (AlgebraicClosure K₀)).toAffine.FunctionField →ₐ[AlgebraicClosure K₀]
+        (E₀.baseChange (AlgebraicClosure K₀)).toAffine.FunctionField)
+      (hι₀ : ι₀.toRingHom.IsIntegral) (hfin₀ : FiniteAlong (AlgebraicClosure K₀) ι₀),
+      ∀ [DecidableEq (AlgebraicClosure K₀)]
+        [GenusOnePlaceGate (E₀.baseChange (AlgebraicClosure K₀)).toAffine]
+        [GenusOnePlaceGate.IsCentred (E₀.baseChange (AlgebraicClosure K₀)).toAffine]
+        [AbelTheorem (E₀.baseChange (AlgebraicClosure K₀)).toAffine]
+        [GenusOnePlaceGate (E₀'.baseChange (AlgebraicClosure K₀)).toAffine]
+        [GenusOnePlaceGate.IsCentred (E₀'.baseChange (AlgebraicClosure K₀)).toAffine]
+        [AbelTheorem (E₀'.baseChange (AlgebraicClosure K₀)).toAffine]
+        (hN₀ : NormFormulaAlong (AlgebraicClosure K₀) ι₀ hfin₀),
+        IsAddCyclic (pointMapOfPushforward ι₀ hι₀ hfin₀ hN₀).ker ∧
+          Nat.card (pointMapOfPushforward ι₀ hι₀ hfin₀ hN₀).ker = N := by
+  classical
+  have hFG := ModularCurve.s13_bcFGDescent K E E' ι hι hfin N hcyc hcard
+  obtain ⟨K₀, hK₀, E₀, E₀', hE₀, hE₀', hmap, hmap', hAC, hAC', ι₀, hι₀, hfin₀, hcyc₀, hcard₀⟩ := hFG
+  refine ⟨K₀, hK₀, E₀, E₀', hE₀, hE₀', hmap, hmap', hAC, hAC', ι₀, hι₀, hfin₀, ?_⟩
+  intro instDec g gc ga g' gc' ga' hN₀
+  have hdec : instDec = s13DecEqAlgebraicClosure := Subsingleton.elim _ _
+  subst hdec
+  have : IsDedekindDomain (E₀.baseChange (AlgebraicClosure ↥K₀)).toAffine.CoordinateRing :=
+    @CoordinateRing.isDedekindDomain _ _ _ (E₀.baseChange (AlgebraicClosure ↥K₀)) hAC
+  have : IsDedekindDomain (E₀'.baseChange (AlgebraicClosure ↥K₀)).toAffine.CoordinateRing :=
+    @CoordinateRing.isDedekindDomain _ _ _ (E₀'.baseChange (AlgebraicClosure ↥K₀)) hAC'
+  have hg : g = @WeierstrassCurve.Affine.s13GlobalGate _ _ _ _ _ (E₀.baseChange (AlgebraicClosure
+    ↥K₀)).toAffine hAC :=
+    GenusOnePlaceGate.ext_of_isCentred _ _ gc
+      (@WeierstrassCurve.Affine.s13GlobalGate_isCentred _ _ _ _ _ (E₀.baseChange (AlgebraicClosure
+        ↥K₀)).toAffine hAC)
+  have hg' : g' = @WeierstrassCurve.Affine.s13GlobalGate _ _ _ _ _ (E₀'.baseChange (AlgebraicClosure
+    ↥K₀)).toAffine hAC' :=
+    GenusOnePlaceGate.ext_of_isCentred _ _ gc'
+      (@WeierstrassCurve.Affine.s13GlobalGate_isCentred _ _ _ _ _ (E₀'.baseChange (AlgebraicClosure
+        ↥K₀)).toAffine hAC')
+  subst hg
+  subst hg'
+  exact ⟨hcyc₀, hcard₀⟩
+
+end
+
+end privateSection
+
+public section publicSection
+
+open AlgebraicCurve
+
+namespace WeierstrassCurve.Affine
+
+universe u
+
+theorem exists_intermediateField_countable_map_eq_of_isAddCyclic_ker_pointMapOfPushforward
+    {K : Type u} [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+    (E E' : WeierstrassCurve.Affine K) [E.IsElliptic] [E'.IsElliptic]
+    [GenusOnePlaceGate E] [GenusOnePlaceGate.IsCentred E] [AbelTheorem E]
+    [GenusOnePlaceGate E'] [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField) (hι : ι.toRingHom.IsIntegral)
+    (hfin : FiniteAlong K ι)
+    (hN : NormFormulaAlong K ι hfin) (N : ℕ) [NeZero N]
+    (hcyc : IsAddCyclic (pointMapOfPushforward ι hι hfin hN).ker)
+    (hcard : Nat.card (pointMapOfPushforward ι hι hfin hN).ker = N) :
+    letI : Algebra ℚ K := DivisionRing.toRatAlgebra
+    ∃ (K₀ : IntermediateField ℚ K) (_ : Countable K₀)
+      (E₀ E₀' : WeierstrassCurve K₀) (_ : E₀.IsElliptic) (_ : E₀'.IsElliptic)
+      (_ : E₀.map (algebraMap K₀ K) = E) (_ : E₀'.map (algebraMap K₀ K) = E')
+      (_ : (E₀.baseChange (AlgebraicClosure K₀)).IsElliptic)
+      (_ : (E₀'.baseChange (AlgebraicClosure K₀)).IsElliptic)
+      (ι₀ : (E₀'.baseChange (AlgebraicClosure K₀)).toAffine.FunctionField →ₐ[AlgebraicClosure K₀]
+        (E₀.baseChange (AlgebraicClosure K₀)).toAffine.FunctionField)
+      (hι₀ : ι₀.toRingHom.IsIntegral) (hfin₀ : FiniteAlong (AlgebraicClosure K₀) ι₀),
+      ∀ [DecidableEq (AlgebraicClosure K₀)]
+        [GenusOnePlaceGate (E₀.baseChange (AlgebraicClosure K₀)).toAffine]
+        [GenusOnePlaceGate.IsCentred (E₀.baseChange (AlgebraicClosure K₀)).toAffine]
+        [AbelTheorem (E₀.baseChange (AlgebraicClosure K₀)).toAffine]
+        [GenusOnePlaceGate (E₀'.baseChange (AlgebraicClosure K₀)).toAffine]
+        [GenusOnePlaceGate.IsCentred (E₀'.baseChange (AlgebraicClosure K₀)).toAffine]
+        [AbelTheorem (E₀'.baseChange (AlgebraicClosure K₀)).toAffine]
+        (hN₀ : NormFormulaAlong (AlgebraicClosure K₀) ι₀ hfin₀),
+        IsAddCyclic (pointMapOfPushforward ι₀ hι₀ hfin₀ hN₀).ker ∧
+          Nat.card (pointMapOfPushforward ι₀ hι₀ hfin₀ hN₀).ker = N :=
+      solution E E' ι hι hfin hN N hcyc hcard
+
+end WeierstrassCurve.Affine
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_map_weilFun_eq_mul_weilFun_smul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_map_weilFun_eq_mul_weilFun_smul.lean
new file mode 100644
index 0000000000..0a01a95d87
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_map_weilFun_eq_mul_weilFun_smul.lean
@@ -0,0 +1,166 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.exists_map_weilFun_eq_mul_weilFun_smul
+(4cabc47d-2752-5485-b03e-065ffa2feb5d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 3704093c-f9b2-5808-8911-6ab21d347427
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_WeilPairingFun
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_GaloisRep
+
+import Mathlib.Tactic.Ring
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_placeOf_smul_of_algEquiv
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_weilFun
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_weilFun_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_exists_eq_algebraMap_of_valuation_eq_one
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Galois conjugation of the Weil function up to a constant
+
+Theorem statement: `WeierstrassCurve.Affine.exists_map_weilFun_eq_mul_weilFun_smul`
+(`4cabc47d-2752-5485-b03e-065ffa2feb5d`), by Claude, 2026-09-05.
+
+Proof: submission `3704093c-f9b2-5808-8911-6ab21d347427`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra, $K$ algebraically closed, and let $W$ be a
+Weierstrass curve over $F$ that is elliptic, such that the coordinate ring of the base change
+$W\!\restriction_K$ (written `W⁄K`) is a Dedekind domain. Let $n$ be a natural number whose image in
+$K$ is nonzero, let $\sigma$ be an $F$-algebra automorphism of $K$, and let $\Phi$ be a ring
+endomorphism of the function field of `W⁄K` which, on classes of bivariate polynomials, is
+coefficientwise conjugation by $\sigma$: for every $p \in K[X][Y]$, $\Phi$ sends the image in the
+function field of the coordinate-ring class of $p$ to the image of the class of the polynomial
+obtained by applying $\sigma$ to all coefficients of $p$. Finally let $T$ be a point of `W⁄K` with
+$n \cdot T = 0$. The assertion is that there exists a unit $c$ of $K$ with
+$\Phi(\mathtt{weilFun}\,W\,K\,n\,T) = c \cdot \mathtt{weilFun}\,W\,K\,n\,(\sigma \bullet T)$, where
+$\mathtt{weilFun}\,W\,K\,m\,S$ denotes the quotient, inside the function field, of the images of the
+chosen generators of the ideals `fibIdeal W K m S` and `fibIdeal W K m 0` (the generator being taken
+when the ideal is principal, and $1$ otherwise), and $\sigma \bullet T$ is the action of $\sigma$ on
+points.
+
+This is the statement that the function $g_T$ underlying the construction of the Weil pairing on
+$n$-torsion is Galois-equivariant up to a multiplicative constant: conjugating $g_T$ by $\sigma$
+yields a constant multiple of $g_{\sigma T}$. It is used in the proof of the Galois equivariance of
+the Weil pairing,
+[`WeierstrassCurve.Affine.weilPairing0_galois`]
+(thm.html#WeierstrassCurve.Affine.weilPairing0_galois).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_exists_map_weilFun_eq_mul_weilFun_smul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_exists_map_weilFun_eq_mul_weilFun_smul
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain IsDedekindDomain.HeightOneSpectrum
+  WithZero
+open Polynomial
+open scoped Polynomial.Bivariate
+
+namespace WeilGal
+
+variable {F : Type*} [Field F] {K : Type*} [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K]
+  (W : WeierstrassCurve F) [W.IsElliptic]
+
+omit [IsAlgClosed K] [W.IsElliptic] in
+theorem smul_point_ne_zero (σ : K ≃ₐ[F] K) {P : (W⁄K).Point} (hP : P ≠ 0) : σ • P ≠ 0 := by
+  intro h
+  apply hP
+  have : σ • (0 : (W⁄K).Point) = 0 := smul_zero σ
+  rw [← this] at h
+  exact Point.map_injective _ (by rw [Point.algEquiv_smul_def,
+    Point.algEquiv_smul_def] at h; exact h)
+
+omit [IsAlgClosed K] [W.IsElliptic] in
+theorem smul_point_eq_iff (σ : K ≃ₐ[F] K) {P Q : (W⁄K).Point} : σ • P = σ • Q ↔ P = Q :=
+  ⟨fun h => Point.map_injective _
+    (by rw [Point.algEquiv_smul_def, Point.algEquiv_smul_def] at h; exact h), fun h => by rw [h]⟩
+
+omit [DecidableEq K] in
+theorem exists_eq_algebraMap [IsDedekindDomain (W⁄K).CoordinateRing]
+    {f : (W⁄K).FunctionField}
+    (hf : ∀ (P : (W⁄K).Point) (hP : P ≠ 0), (placeOf W K P hP).valuation (W⁄K).FunctionField f =
+      1) :
+    ∃ c : K, c ≠ 0 ∧ f = algebraMap K (W⁄K).FunctionField c := by
+  classical
+  apply WeierstrassCurve.Affine.FunctionField.exists_eq_algebraMap_of_valuation_eq_one (W := W⁄K)
+  intro v
+  obtain ⟨P, hP, rfl⟩ := placeOf_surjective W K v
+  exact hf P hP
+
+end WeilGal
+
+theorem solution {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K] (W
+  : WeierstrassCurve F) [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ} (hn : (n : K)
+  ≠ 0) (σ : K ≃ₐ[F] K) (Φ : (W⁄K).FunctionField →+* (W⁄K).FunctionField) (hΦ : ∀ p : K[X][Y], Φ
+  (algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField (CoordinateRing.mk (W⁄K) p)) = algebraMap
+  (W⁄K).CoordinateRing (W⁄K).FunctionField (CoordinateRing.mk (W⁄K) (p.map (mapRingHom (σ : K →+*
+  K))))) {T : (W⁄K).Point} (hT : (n : ℤ) • T = 0) :
+    ∃ c : Kˣ, Φ (weilFun W K n T) = algebraMap K (W⁄K).FunctionField (c : K) * weilFun W K n (σ • T)
+      := by
+  have hσT : (n : ℤ) • (σ • T) = 0 := by rw [← Point.algEquiv_smul_zsmul, hT, smul_zero]
+  have hg0 := WeierstrassCurve.Affine.weilFun_ne_zero W hn hσT
+  suffices h : ∃ c : K, c ≠ 0 ∧ Φ (weilFun W K n T) / weilFun W K n (σ • T) = algebraMap K _ c by
+    obtain ⟨c, hc0, hc⟩ := h
+    exact ⟨Units.mk0 c hc0, by rw [Units.val_mk0, ← hc, div_mul_cancel₀ _ hg0]⟩
+  apply WeilGal.exists_eq_algebraMap W
+  intro Q hQ
+  set P := σ⁻¹ • Q with hPdef
+  have hP : P ≠ 0 := WeilGal.smul_point_ne_zero W σ⁻¹ hQ
+  have hQP : σ • P = Q := smul_inv_smul σ Q
+  have hσP : σ • P ≠ 0 := by rw [hQP]; exact hQ
+  have hplace : placeOf W K Q hQ = placeOf W K (σ • P) hσP := by
+    congr 1; exact hQP.symm
+  rw [map_div₀, hplace, WeierstrassCurve.Affine.valuation_placeOf_smul_of_algEquiv W σ Φ hΦ hP hσP,
+    WeierstrassCurve.Affine.valuation_weilFun W hn hT P hP,
+    WeierstrassCurve.Affine.valuation_weilFun W hn hσT (σ • P) hσP]
+  have e1 : ((n : ℤ) • (σ • P) = σ • T) = ((n : ℤ) • P = T) := by
+    rw [← Point.algEquiv_smul_zsmul, WeilGal.smul_point_eq_iff]
+  have e2 : ((n : ℤ) • (σ • P) = 0) = ((n : ℤ) • P = 0) := by
+    rw [← Point.algEquiv_smul_zsmul]
+    conv_lhs => rw [← smul_zero σ]
+    rw [WeilGal.smul_point_eq_iff]
+  simp only [e1, e2]
+  have hne : ∀ c : Prop, ∀ [Decidable c], (if c then (exp (-1 : ℤ) : ℤᵐ⁰) else 1) ≠ 0 := by
+    intro c _; split_ifs; exacts [WithZero.coe_ne_zero, one_ne_zero]
+  exact div_self (div_ne_zero (hne _) (hne _))
+
+end S_WeierstrassCurve_Affine_exists_map_weilFun_eq_mul_weilFun_smul
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_exists_map_weilFun_eq_mul_weilFun_smul (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain WithZero
+open Polynomial
+open scoped Polynomial.Bivariate
+
+theorem WeierstrassCurve.Affine.exists_map_weilFun_eq_mul_weilFun_smul {F K : Type*} [Field F]
+  [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K] (W : WeierstrassCurve F) [W.IsElliptic]
+  [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ} (hn : (n : K) ≠ 0) (σ : K ≃ₐ[F] K) (Φ :
+  (W⁄K).FunctionField →+* (W⁄K).FunctionField) (hΦ : ∀ p : K[X][Y], Φ (algebraMap
+  (W⁄K).CoordinateRing (W⁄K).FunctionField (CoordinateRing.mk (W⁄K) p)) = algebraMap
+  (W⁄K).CoordinateRing (W⁄K).FunctionField (CoordinateRing.mk (W⁄K) (p.map (mapRingHom (σ : K →+*
+  K))))) {T : (W⁄K).Point} (hT : (n : ℤ) • T = 0) :
+    ∃ c : Kˣ, Φ (weilFun W K n T) = algebraMap K (W⁄K).FunctionField (c : K) * weilFun W K n (σ • T)
+      :=
+  solution W hn σ Φ hΦ hT
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_transEquiv_weilFun_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_transEquiv_weilFun_eq.lean
new file mode 100644
index 0000000000..31d3f4b636
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_exists_transEquiv_weilFun_eq.lean
@@ -0,0 +1,105 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.exists_transEquiv_weilFun_eq
+(2444aae1-be93-5d1a-b696-00e31bad4857) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1455fb5f-e52c-5d9c-9e81-84decbf6b318
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_WeilPairingFun
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_transEquiv_weilFun
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_weilFun
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_weilFun_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_exists_eq_algebraMap_of_valuation_eq_one
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Translation invariance of the Weil function g_T up to a constant
+
+Theorem statement: `WeierstrassCurve.Affine.exists_transEquiv_weilFun_eq`
+(`2444aae1-be93-5d1a-b696-00e31bad4857`), by Claude, 2026-09-05.
+
+Proof: submission `1455fb5f-e52c-5d9c-9e81-84decbf6b318`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra, $K$ algebraically closed, and let $W$ be a
+Weierstrass curve over $F$ which is elliptic; assume the coordinate ring of the affine base-changed
+curve $W\!\!\upharpoonright\! K$ is a Dedekind domain. Let $n$ be a natural number whose image in
+$K$ is nonzero, and let $S$ and $T$ be points of the group of $K$-points of the affine curve with
+$(n : \mathbb{Z}) \cdot S = 0$ and $(n : \mathbb{Z}) \cdot T = 0$. Write $g_T$ for `weilFun W K n
+T`, the element of the function field obtained as the quotient of the image of `weilNum W K n T` by
+the image of `weilNum W K n 0`, where `weilNum W K n T` is a chosen generator of the ideal `fibIdeal
+W K n T` when that ideal is principal and $1$ otherwise; and write $\tau_S^*$ for `transEquiv W K
+S`, the $K$-algebra automorphism of the function field given by `transPull W K S` with inverse
+`transPull W K (-S)`. The conclusion asserts the existence of a unit $c \in K^\times$ with
+$\tau_S^*(g_T) = \iota(c)\, g_T$, where $\iota$ is the structure map $K \to (W\!\!\upharpoonright\!
+K).\mathrm{FunctionField}$.
+
+This is the invariance step in the construction of the Weil pairing: the function $g_T$ with divisor
+$[n]^*(T) - [n]^*(O)$ is, up to a multiplicative constant, unchanged by translation by an
+$n$-torsion point $S$, and that constant is the pairing value $e_n(S,T)$. It is used by the
+statements establishing the basic properties of `weilPairing0`, including bilinearity in the first
+variable and nondegeneracy.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_exists_transEquiv_weilFun_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_exists_transEquiv_weilFun_eq
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain WithZero
+
+theorem solution {F : Type*} {K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K]
+    [IsAlgClosed K] (W : WeierstrassCurve F) [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing]
+    {n : ℕ} (hn : (n : K) ≠ 0) (S T : (W⁄K).Point) (hS : (n : ℤ) • S = 0) (hT : (n : ℤ) • T = 0) :
+    ∃ c : Kˣ, transEquiv W K S (weilFun W K n T) = algebraMap K (W⁄K).FunctionField (c : K) *
+      weilFun W K n T := by
+  have hg0 := weilFun_ne_zero W hn hT
+  have hval : ∀ v : HeightOneSpectrum (W⁄K).CoordinateRing,
+      v.valuation (W⁄K).FunctionField (transEquiv W K S (weilFun W K n T) / weilFun W K n T) = 1
+        := by
+    intro v
+    obtain ⟨P, hP, rfl⟩ := placeOf_surjective W K v
+    rw [map_div₀, valuation_transEquiv_weilFun W hn S hT P hP, valuation_weilFun W hn hT P hP,
+      smul_add, hS,
+      add_zero, div_self]
+    refine div_ne_zero ?_ ?_ <;> split_ifs <;> simp
+  obtain ⟨c, hc0, hc⟩ :=
+    WeierstrassCurve.Affine.FunctionField.exists_eq_algebraMap_of_valuation_eq_one (W :=
+      W.baseChange K) hval
+  exact ⟨Units.mk0 c hc0, by rw [Units.val_mk0, ← hc, div_mul_cancel₀ _ hg0]⟩
+
+end S_WeierstrassCurve_Affine_exists_transEquiv_weilFun_eq
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_exists_transEquiv_weilFun_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain WithZero
+
+theorem WeierstrassCurve.Affine.exists_transEquiv_weilFun_eq {F : Type*} {K : Type*} [Field F]
+    [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K] (W : WeierstrassCurve F) [W.IsElliptic]
+    [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ} (hn : (n : K) ≠ 0) (S T : (W⁄K).Point)
+    (hS : (n : ℤ) • S = 0) (hT : (n : ℤ) • T = 0) :
+    ∃ c : Kˣ, transEquiv W K S (weilFun W K n T) = algebraMap K (W⁄K).FunctionField (c : K) *
+      weilFun W K n T :=
+  solution W hn S T hS hT
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_fibSet_finite.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_fibSet_finite.lean
new file mode 100644
index 0000000000..cd0b6b65b4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_fibSet_finite.lean
@@ -0,0 +1,130 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.fibSet_finite
+(d1b840cd-018f-5bca-9508-90b9fb006ef1) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6812f5c9-90dd-56c9-99cf-10d3c43d2e28
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_WeilPairingFun
+
+import Mathlib.Data.Set.Card
+import Mathlib.Algebra.BigOperators.Group.Finset.Piecewise
+import Mathlib.Tactic.Ring
+import Mathlib.Tactic.FieldSimp
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsion_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Fibres of multiplication by n are finite
+
+Theorem statement: `WeierstrassCurve.Affine.fibSet_finite` (`d1b840cd-018f-5bca-9508-90b9fb006ef1`),
+by Claude, 2026-09-05.
+
+Proof: submission `6812f5c9-90dd-56c9-99cf-10d3c43d2e28`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra and $K$ algebraically closed, let $W$ be a
+Weierstrass curve over $F$ which is elliptic, and let $n$ be a natural number whose image in $K$ is
+nonzero. Write $(W⁄K)$ for the base change of $W$ to $K$ and $(W⁄K)$`.Point` for its group of affine
+points together with the point at infinity. Then for every point $Q$ of $(W⁄K)$, the set `fibSet W K
+n Q`, that is $\{P : n \cdot P = Q\}$, the fibre over $Q$ of multiplication by the integer $n$ on
+$(W⁄K)$`.Point`, is finite. No claim is made about the cardinality of this fibre, nor about its
+non-emptiness; the assertion is finiteness alone, and in particular it holds vacuously when $Q$ is
+not divisible by $n$.
+
+This is the finiteness half of the classical description of the fibres of the isogeny $[n]$ on an
+elliptic curve over an algebraically closed field of residue characteristic prime to $n$: a fibre is
+empty or a translate of the $n$-torsion subgroup, which has $n^2$ elements. It underlies the
+counting and valuation statements used in the construction of the Weil pairing, being cited by
+[`WeierstrassCurve.Affine.ncard_fibSet`](thm.html#WeierstrassCurve.Affine.ncard_fibSet) and by the
+lemmas on valuations of Weil functions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_fibSet_finite.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_fibSet_finite
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain IsDedekindDomain.HeightOneSpectrum
+  WithZero
+open scoped nonZeroDivisors
+
+namespace WeilDiv
+
+variable {F : Type*} [Field F] {K : Type*} [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K]
+  (W : WeierstrassCurve F) [W.IsElliptic]
+
+theorem torsion_finite {n : ℕ} (hn : (n : K) ≠ 0) :
+    {S : (W⁄K).Point | (n : ℤ) • S = 0}.Finite := by
+  have hcard := WeierstrassCurve.card_torsion_of_isAlgClosed (K := K) W hn
+  have hn0 : n ≠ 0 := by rintro rfl; exact hn Nat.cast_zero
+  have : Finite (Submodule.torsionBy ℤ (W⁄K).Point n) :=
+    Nat.finite_of_card_ne_zero (by rw [hcard]; exact pow_ne_zero 2 hn0)
+  have hset : {S : (W⁄K).Point | (n : ℤ) • S = 0} =
+      ((Submodule.torsionBy ℤ (W⁄K).Point n : Submodule ℤ (W⁄K).Point) : Set (W⁄K).Point) := by
+    ext S
+    rw [Set.mem_ofPred_eq, SetLike.mem_coe, Submodule.mem_torsionBy_iff]
+  rw [hset]
+  exact Set.toFinite _
+
+theorem card_torsion_toFinset {n : ℕ} (hn : (n : K) ≠ 0) :
+    (torsion_finite W hn).toFinset.card = n ^ 2 := by
+  rw [← WeierstrassCurve.card_torsion_of_isAlgClosed (K := K) W hn, ←
+    Nat.card_eq_card_finite_toFinset]
+  have hset : {S : (W⁄K).Point | (n : ℤ) • S = 0} =
+      ((Submodule.torsionBy ℤ (W⁄K).Point n : Submodule ℤ (W⁄K).Point) : Set (W⁄K).Point) := by
+    ext S
+    rw [Set.mem_ofPred_eq, SetLike.mem_coe, Submodule.mem_torsionBy_iff]
+  rw [hset]
+  rfl
+
+theorem fibSet_finite' {n : ℕ} (hn : (n : K) ≠ 0) (Q : (W⁄K).Point) : (fibSet W K n Q).Finite := by
+  by_cases hne : ∃ P₀ : (W⁄K).Point, (n : ℤ) • P₀ = Q
+  · obtain ⟨P₀, hP₀⟩ := hne
+    refine ((torsion_finite W hn).image (· + P₀)).subset ?_
+    intro P hP
+    rw [mem_fibSet] at hP
+    refine ⟨P - P₀, ?_, sub_add_cancel P P₀⟩
+    change (n : ℤ) • (P - P₀) = 0
+    rw [smul_sub, hP, hP₀, sub_self]
+  · exact Set.finite_empty.subset fun P hP => (hne ⟨P, hP⟩).elim
+
+end WeilDiv
+
+theorem solution {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K]
+    (W : WeierstrassCurve F) [W.IsElliptic] {n : ℕ} (hn : (n : K) ≠ 0) (Q : (W⁄K).Point) :
+    (fibSet W K n Q).Finite := by
+  exact WeilDiv.fibSet_finite' W hn Q
+
+end S_WeierstrassCurve_Affine_fibSet_finite
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_fibSet_finite (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain WithZero
+
+theorem WeierstrassCurve.Affine.fibSet_finite {F K : Type*} [Field F] [Field K] [Algebra F K]
+    [DecidableEq K] [IsAlgClosed K] (W : WeierstrassCurve F) [W.IsElliptic] {n : ℕ}
+    (hn : (n : K) ≠ 0) (Q : (W⁄K).Point) :
+    (fibSet W K n Q).Finite :=
+  solution W hn Q
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_finiteDimensional_ratFunc_functionField.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_finiteDimensional_ratFunc_functionField.lean
new file mode 100644
index 0000000000..9d763dfe19
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_finiteDimensional_ratFunc_functionField.lean
@@ -0,0 +1,83 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.finiteDimensional_ratFunc_functionField
+(005f46f1-5de1-5f0a-9742-e0301c6626cf) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e9326b09-441a-502b-b043-42a3e6456029
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FunctionFieldQuadratic
+
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_adjoin_yCoord_eq_top
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The function field of a Weierstrass curve is finite over F(x)
+
+Theorem statement: `WeierstrassCurve.Affine.finiteDimensional_ratFunc_functionField`
+(`005f46f1-5de1-5f0a-9742-e0301c6626cf`), by Claude, 2026-09-05.
+
+Proof: submission `e9326b09-441a-502b-b043-42a3e6456029`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field and let $W$ be an affine Weierstrass curve over $F$, that is, a tuple of
+coefficients $a_1,a_2,a_3,a_4,a_6 \in F$ presenting the affine equation $Y^2 + a_1XY + a_3Y = X^3 +
+a_2X^2 + a_4X + a_6$. Its function field $W.FunctionField$ is the fraction field of the coordinate
+ring of $W$, the quotient of $F[X][Y]$ by the Weierstrass polynomial; it carries an algebra
+structure over the rational function field $RatFunc F$ in one variable, induced by sending the
+variable to the class of the $x$-coordinate. The assertion is that $W.FunctionField$ is
+finite-dimensional as a vector space over $RatFunc F$, i.e. that $F(W)$ is a finite extension of
+$F(x)$. Only finiteness is asserted: no bound on the degree is part of the conclusion, in particular
+the classical statement that the degree is at most $2$, with $F(W) = F(x)(y)$ and $y$ satisfying a
+quadratic equation over $F(x)$, is stronger than what is stated here.
+
+This is the standard finiteness of the function field of a plane Weierstrass model over the rational
+function field in the $x$-coordinate; in the development it supplies the finite-extension hypothesis
+used to produce principal divisors on $F(W)$, and it is invoked in the treatment of norms along the
+extension and in the construction of countable intermediate fields with prescribed finrank.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_finiteDimensional_ratFunc_functionField.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_finiteDimensional_ratFunc_functionField
+
+
+open WeierstrassCurve.Affine in
+theorem solution {F : Type*} [Field F] (W : WeierstrassCurve.Affine F) :
+    FiniteDimensional (RatFunc F) W.FunctionField := by
+  have h1 : FiniteDimensional (RatFunc F)
+      (IntermediateField.adjoin (RatFunc F) {yCoord W}) :=
+    IntermediateField.adjoin.finiteDimensional isIntegral_yCoord
+  rw [WeierstrassCurve.Affine.adjoin_yCoord_eq_top] at h1
+  exact (IntermediateField.topEquiv
+    (F := RatFunc F) (E := W.FunctionField)).toLinearEquiv.finiteDimensional
+
+end S_WeierstrassCurve_Affine_finiteDimensional_ratFunc_functionField
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_finiteDimensional_ratFunc_functionField (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.Affine.finiteDimensional_ratFunc_functionField {F : Type*} [Field F]
+    (W : WeierstrassCurve.Affine F) :
+    FiniteDimensional (RatFunc F) W.FunctionField :=
+  solution W
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_finrank_fieldRange_mulPull_le.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_finrank_fieldRange_mulPull_le.lean
new file mode 100644
index 0000000000..228994c658
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_finrank_fieldRange_mulPull_le.lean
@@ -0,0 +1,189 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.finrank_fieldRange_mulPull_le
+(451e3198-f700-591c-aa7d-fef28dfd663d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 649de834-7f94-51f9-bb61-ea7b1d25267f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.Henselian
+public import Mathlib.RingTheory.RegularLocalRing.Defs
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+
+import Mathlib.FieldTheory.IntermediateField.Adjoin.Basic
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_adjoin_X_Y_eq_top
+import LeanPool.FLTEichlerShimura.Theorems.Thm_IntermediateField_finrank_fieldRange_le_of_adjoin_pair_eq_top
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_smul_some_eq_zero_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_natDegree_Phi_sub_C_mul_PsiSq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_evalEval_psi_sq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Psi2Sq_ne_zero_of_isElliptic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_zsmul_some_eq_some_div
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_two_smul_some_eq_zero_iff
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Pull-back by [n] has index at most n²
+
+Theorem statement: `WeierstrassCurve.Affine.finrank_fieldRange_mulPull_le`
+(`451e3198-f700-591c-aa7d-fef28dfd663d`), by Claude, 2026-09-05.
+
+Proof: submission `649de834-7f94-51f9-bb61-ea7b1d25267f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra and $K$ algebraically closed, let $W$ be a
+Weierstrass curve over $F$ that is elliptic, and let $n$ be an integer. Write $L =
+(W⁄K).\mathrm{FunctionField}$ for the function field of the base change of $W$ to $K$, and let
+$\gamma =$ `genericPoint W K` be the point of $W$ over $L$ given by the generic coordinates. Assume
+`MulGood W K n`, that is: $n \bullet \gamma \neq 0$, and $n \bullet \gamma$ is not the image under
+base change from $K$ to $L$ of any point $P$ of $W⁄K$. Under this hypothesis the $K$-algebra
+endomorphism `mulPull W K n` of $L$ is the map obtained, by lifting to fraction fields, from the
+injective coordinate homomorphism attached to the point $n \bullet \gamma$. The conclusion is the
+conjunction of two assertions: $L$ is a finite-dimensional module over the subfield `(mulPull W K
+n).fieldRange`, the image of that endomorphism, and the degree $[L : (\text{mulPull }
+W\,K\,n).\mathrm{fieldRange}]$ is at most $|n|^2$. Only the upper bound is asserted, not the
+classical equality.
+
+This is the function-field form of the statement that multiplication by $n$ on an elliptic curve has
+degree $n^2$: the pull-back $[n]^*$ exhibits the function field as an extension of index at most
+$n^2$ of its image. It feeds the study of endomorphisms of the function field, being used in
+[`WeierstrassCurve.Affine.eq_zero_of_forall_transEquiv_eq`]
+(thm.html#WeierstrassCurve.Affine.eq_zero_of_forall_transEquiv_eq)
+and in
+[`WeierstrassCurve.Affine.exists_isogenyEndDatum_restrictAlong_placeOfPoint_eq_smul`]
+(thm.html#WeierstrassCurve.Affine.exists_isogenyEndDatum_restrictAlong_placeOfPoint_eq_smul).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_finrank_fieldRange_mulPull_le.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_finrank_fieldRange_mulPull_le
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+open Polynomial IntermediateField
+
+theorem solution {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K]
+    (W : WeierstrassCurve F) [W.IsElliptic] {n : ℤ} (hgood : MulGood W K n) :
+    FiniteDimensional (mulPull W K n).fieldRange (W⁄K).FunctionField ∧ Module.finrank (mulPull W K
+      n).fieldRange (W⁄K).FunctionField ≤ n.natAbs ^ 2 := by
+  classical
+  have hEK : (W⁄K).IsElliptic := by
+    dsimp only [Affine.baseChange, WeierstrassCurve.baseChange]; infer_instance
+  set L := (W⁄K).FunctionField with hL
+  set gX := genericX W K with hXdef
+  set gY := genericY W K with hYdef
+  have hn0 : n ≠ 0 := by
+    rintro rfl
+    exact hgood.1 (zero_zsmul _)
+  let f : K →ₐ[F] L := IsScalarTower.toAlgHom F K L
+  have hf : (f : K →+* L) = algebraMap K L := rfl
+  have hΦ : (W⁄L).Φ n = ((W⁄K).Φ n).map (algebraMap K L) := by
+    rw [← hf]; exact W.baseChange_Φ f n
+  have hΨSq : (W⁄L).ΨSq n = ((W⁄K).ΨSq n).map (algebraMap K L) := by
+    rw [← hf]; exact W.baseChange_ΨSq f n
+  have hΨ₂Sq : (W⁄L).Ψ₂Sq = (W⁄K).Ψ₂Sq.map (algebraMap K L) := by
+    rw [← hf]; exact W.baseChange_Ψ₂Sq f
+  have hγn : n • genericPoint W K ≠ 0 := hgood.1
+  have hψ : ((W⁄L).ψ n).evalEval gX gY ≠ 0 := fun h0 =>
+    hγn ((WeierstrassCurve.Affine.Point.smul_some_eq_zero_iff (W⁄L) (generic_nonsingular W K) n).mpr
+      h0)
+  have hΨX : ((W⁄L).ΨSq n).eval gX ≠ 0 := by
+    rw [← WeierstrassCurve.Affine.evalEval_psi_sq (W⁄L) (generic_equation W K) n]
+    exact pow_ne_zero _ hψ
+  obtain ⟨y', h', hmul⟩ :=
+    WeierstrassCurve.Affine.Point.zsmul_some_eq_some_div (W⁄L) (generic_nonsingular W K) hψ
+  have hxn : mulPull W K n gX = ((W⁄L).Φ n).eval gX / ((W⁄L).ΨSq n).eval gX := by
+    rw [hXdef, mulPull_genericX' W K hgood]
+    change (n • Point.some _ _ (generic_nonsingular W K)).xc = _
+    rw [hmul, Point.xc_some]
+  set A : L := (W⁄L).a₁ * gX + (W⁄L).a₃ with hA
+  set B : L := -(gX ^ 3 + (W⁄L).a₂ * gX ^ 2 + (W⁄L).a₄ * gX + (W⁄L).a₆) with hB
+  have hcoef : ∀ a : F, (algebraMap F L a) ∈ K⟮gX⟯ := fun a => by
+    rw [IsScalarTower.algebraMap_apply F K L]
+    exact IntermediateField.algebraMap_mem _ _
+  have ha₁ : (W⁄L).a₁ = algebraMap F L W.a₁ := rfl
+  have ha₂ : (W⁄L).a₂ = algebraMap F L W.a₂ := rfl
+  have ha₃ : (W⁄L).a₃ = algebraMap F L W.a₃ := rfl
+  have ha₄ : (W⁄L).a₄ = algebraMap F L W.a₄ := rfl
+  have ha₆ : (W⁄L).a₆ = algebraMap F L W.a₆ := rfl
+  have hXKX : gX ∈ K⟮gX⟯ := mem_adjoin_simple_self K gX
+  have hAmem : A ∈ K⟮gX⟯ := by
+    rw [hA, ha₁, ha₃]
+    exact add_mem (mul_mem (hcoef _) hXKX) (hcoef _)
+  have hBmem : B ∈ K⟮gX⟯ := by
+    rw [hB, ha₂, ha₄, ha₆]
+    refine neg_mem (add_mem (add_mem (add_mem (pow_mem hXKX 3) (mul_mem (hcoef _) (pow_mem hXKX 2)))
+      (mul_mem (hcoef _) hXKX)) (hcoef _))
+  have hYq : gY ^ 2 + A * gY + B = 0 := by
+    have h := (equation_iff _ _).mp (generic_equation W K)
+    rw [hA, hB]
+    linear_combination h
+  have hιX : (negEquiv W K : L →ₐ[K] L) gX = gX := negEquiv_genericX W K
+  have hιY' : (negEquiv W K : L →ₐ[K] L) gY = -gY - A := by
+    change negEquiv W K (genericY W K) = _
+    rw [negEquiv_genericY, WeierstrassCurve.Affine.negY, hA]
+    ring
+  have hιY : ((negEquiv W K : L →ₐ[K] L) gY) ^ 2 + A * (negEquiv W K : L →ₐ[K] L) gY + B = 0 := by
+    rw [hιY']
+    linear_combination hYq
+  have hιμ : (negEquiv W K : L →ₐ[K] L) (mulPull W K n gY) ≠ mulPull W K n gY := by
+    intro heq
+    change negEquiv W K (mulPull W K n (genericY W K)) = mulPull W K n (genericY W K) at heq
+    rw [negEquiv_mulPull_genericY' W K hgood, mulPull_genericY' W K hgood] at heq
+    have hP := Point.eq_some_xc_yc hγn
+    have h2 : (2 : ℕ) • (n • genericPoint W K) = 0 := by
+      rw [two_nsmul, add_eq_zero_iff_eq_neg]
+      conv_rhs => rw [hP, Point.neg_some]
+      conv_lhs => rw [hP]
+      congr 1
+      exact heq.symm
+    rw [hP, WeierstrassCurve.Affine.Point.two_smul_some_eq_zero_iff (W⁄L), hΨ₂Sq,
+      eval_map_algebraMap] at h2
+    apply not_isIntegral_xc_of_ne_baseChange (n • genericPoint W K) hgood.1 hgood.2
+    exact IsAlgebraic.isIntegral ⟨(W⁄K).Ψ₂Sq, WeierstrassCurve.Psi2Sq_ne_zero_of_isElliptic (W⁄K),
+      h2⟩
+  have hgen : IntermediateField.adjoin K {gX, gY} = ⊤ := FunctionField.adjoin_X_Y_eq_top (W⁄K)
+  have key :=
+    IntermediateField.finrank_fieldRange_le_of_adjoin_pair_eq_top gX gY hgen A B hAmem hBmem hYq
+      (mulPull W K n)
+    (negEquiv W K : L →ₐ[K] L) hιX hιY hιμ ((W⁄K).Φ n) ((W⁄K).ΨSq n)
+    (d := n.natAbs ^ 2) (pow_pos (Int.natAbs_pos.mpr hn0) 2) ?_ ?_
+  · exact key
+  · rw [← eval_map_algebraMap, ← eval_map_algebraMap, ← hΦ, ← hΨSq, hxn, div_mul_cancel₀ _ hΨX]
+  · intro M c
+    rw [← WeierstrassCurve.map_Φ, ← WeierstrassCurve.map_ΨSq]
+    exact WeierstrassCurve.natDegree_Phi_sub_C_mul_PsiSq _ n c
+
+end S_WeierstrassCurve_Affine_finrank_fieldRange_mulPull_le
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_finrank_fieldRange_mulPull_le (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+theorem WeierstrassCurve.Affine.finrank_fieldRange_mulPull_le {F K : Type*} [Field F] [Field K]
+    [Algebra F K] [DecidableEq K] [IsAlgClosed K] (W : WeierstrassCurve F) [W.IsElliptic] {n : ℤ}
+    (hgood : MulGood W K n) :
+    FiniteDimensional (mulPull W K n).fieldRange (W⁄K).FunctionField ∧ Module.finrank (mulPull W K
+      n).fieldRange (W⁄K).FunctionField ≤ n.natAbs ^ 2 :=
+  solution W hgood
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_forall_normFormulaAlong_of_isAlgClosed_of_charZero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_forall_normFormulaAlong_of_isAlgClosed_of_charZero.lean
new file mode 100644
index 0000000000..311a4fff8d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_forall_normFormulaAlong_of_isAlgClosed_of_charZero.lean
@@ -0,0 +1,100 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.forall_normFormulaAlong_of_isAlgClosed_of_charZero
+(9070c374-bae9-55ea-b367-f90a004aaed5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9726c289-bffc-5a11-a064-56741d6e758a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_separableAlong_of_charZero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Norm formula along isogeny endomorphism data in characteristic zero
+
+Theorem statement: `WeierstrassCurve.Affine.forall_normFormulaAlong_of_isAlgClosed_of_charZero`
+(`9070c374-bae9-55ea-b367-f90a004aaed5`), by Claude, 2026-09-05.
+
+Proof: submission `9726c289-bffc-5a11-a064-56741d6e758a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field of characteristic zero, and let $W$ be an affine
+Weierstrass curve over $F$ which is elliptic. Assume $W$ carries a `GenusOnePlaceGate`, that is, a
+bijection between the points $W.Point$ and the places of $F$ in the function field $F(W)$ (a place
+being a proper valuation subring of $F(W)$ containing $F$ and which is a principal ideal ring)
+together with the statement that every such place has degree $1$; assume this gate is centred, i.e.
+for every nonsingular affine point $(x,y)$ the classes of $X-x$ and $Y-y$ in the coordinate ring map
+into the non-units of the valuation subring attached to that point; and assume Abel's theorem for
+$W$, i.e. a divisor of degree $0$ is principal exactly when the associated sum of points in
+$W.Point$ vanishes. Then for every isogeny endomorphism datum $D$ on $W$ — an $F$-algebra map $\iota
+: F(W) \to F(W)$ which is integral and along which $F(W)$ is a finite module over itself — the
+pushforward norm formula holds along $\iota$: for every nonzero $f \in F(W)$, every divisor whose
+multiplicity at each place $w$ is $\operatorname{ord}_w(f)$ pushes forward along $\iota$ to the
+divisor with multiplicity $\operatorname{ord}_v(N(f))$ at each place $v$, where $N$ is the norm of
+the extension determined by $\iota$.
+
+This is the divisor-pushforward norm formula $\iota_*(\operatorname{div} f) = \operatorname{div}(N
+f)$, specialised to self-embeddings of the function field of an elliptic curve over an algebraically
+closed field of characteristic zero. It is the form of the norm formula consumed downstream, for
+instance by
+[`ModularCurve.ModularPolynomialData.separable_map_eval2_of_not_isIntegral_of_isAlgClosed`]
+(thm.html#ModularCurve.ModularPolynomialData.separable_map_eval2_of_not_isIntegral_of_isAlgClosed)
+and [`ModularCurve.TatePoint.fullKernelInjAt`](thm.html#ModularCurve.TatePoint.fullKernelInjAt).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_forall_normFormulaAlong_of_isAlgClosed_of_charZero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_forall_normFormulaAlong_of_isAlgClosed_of_charZero
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+theorem solution {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    (W : WeierstrassCurve.Affine F) [W.IsElliptic]
+    [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [AbelTheorem W] :
+    ∀ D : IsogenyEndDatum W, NormFormulaAlong F D.ι D.hfin := by
+  have : CharZero W.FunctionField :=
+    (RingHom.charZero_iff (algebraMap F W.FunctionField).injective).mp ‹CharZero F›
+  have : HasPrincipalDivisors F W.FunctionField := hasPrincipalDivisors_functionField W
+  intro D
+  exact AlgebraicCurve.normFormulaAlong D.ι D.hfin
+    (AlgebraicCurve.separableAlong_of_charZero D.ι D.hι)
+
+end S_WeierstrassCurve_Affine_forall_normFormulaAlong_of_isAlgClosed_of_charZero
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_forall_normFormulaAlong_of_isAlgClosed_of_charZero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+theorem WeierstrassCurve.Affine.forall_normFormulaAlong_of_isAlgClosed_of_charZero
+    {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    (W : WeierstrassCurve.Affine F) [W.IsElliptic]
+    [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [AbelTheorem W] :
+    ∀ D : IsogenyEndDatum W, NormFormulaAlong F D.ι D.hfin :=
+  solution W
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField.lean
new file mode 100644
index 0000000000..c8ab925c2d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField.lean
@@ -0,0 +1,2133 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.hasPrincipalDivisors_functionField
+(c0f259e5-85a4-5e9a-bc15-621436aa0746) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 71997f8e-42a1-5c8d-8da4-f9d0556bcf71
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Analysis.Normed.Ring.Lemmas
+import Mathlib.Data.Int.Star
+import Mathlib.FieldTheory.PurelyInseparable.Exponent
+import Mathlib.RingTheory.PicardGroup
+import Mathlib.RingTheory.Polynomial.DegreeLT
+import Mathlib.RingTheory.TotallySplit
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_eq_neg_log_of_valuationSubring_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_hasPrincipalDivisors_of_finiteDimensional_ratFunc
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_min_ord_le_ord_add_v2
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Principal divisors on a Weierstrass curve have degree zero
+
+Theorem statement: `WeierstrassCurve.Affine.hasPrincipalDivisors_functionField`
+(`c0f259e5-85a4-5e9a-bc15-621436aa0746`), by Claude, 2026-09-05.
+
+Proof: submission `71997f8e-42a1-5c8d-8da4-f9d0556bcf71`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field of characteristic $0$ and let $W$ be an affine Weierstrass curve over $F$, with
+function field $F(W) =$ `W.FunctionField`. The assertion is that $F(W)$, viewed as an extension of
+$F$, satisfies the class
+[`AlgebraicCurve.HasPrincipalDivisors`](def/AlgebraicCurve_DivisorClassGroup.html#L217): for every
+$f \in F(W)$ with $f \neq 0$ there is a divisor $D$, that is, a finitely supported function from the
+places of $F(W)/F$ to $\mathbb{Z}$, such that $D(v) = \operatorname{ord}_v(f)$ for every place $v$,
+and such that $\deg D = 0$. Here a place of $F(W)/F$ is a valuation subring $\mathcal{O}_v \subseteq
+F(W)$ which contains the image of $F$ under the structure map, is not the whole of $F(W)$, and is a
+principal ideal ring; $\deg D$ is the integer $\sum_v D(v)\,\deg v$, obtained from $D$ by summing
+its values weighted by the residue degrees $\deg v$. Thus the statement packages two facts at once:
+a nonzero $f$ has $\operatorname{ord}_v(f) = 0$ for all but finitely many places (so that the
+prescribed function is indeed finitely supported), and the resulting divisor of $f$ has degree zero.
+No smoothness or nonsingularity hypothesis is imposed on $W$.
+
+This is the degree-zero theorem for principal divisors, in the form needed for the function field of
+a plane Weierstrass model: $F(W)$ is a finite extension of the rational function field $F(x)$,
+generated by $y$ satisfying the monic Weierstrass quadratic, so the general result for finite
+extensions of $F(x)$ applies. It supplies the `HasPrincipalDivisors` instance used throughout the
+divisor-class-group layer, in particular in the analysis of modular polynomials and Vélu quotients.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_b3a5cd3d
+
+section
+
+section
+
+p2m_open "Ideal~map_mul"
+
+open Module Polynomial
+
+open scoped nonZeroDivisors Polynomial.Bivariate
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.Point.toClass a₃ a₁ map Affine.CoordinateRing coe_Δ' \
+  mk a₄ Jacobian a₂ a₆ reduction Affine.CoordinateRing.XYIdeal' IsIntegral Affine.Point Δ j Δ'"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation Point.toClass CoordinateRing.XYIdeal \
+  CoordinateRing.XYIdeal'_eq equation_iff_nonsingular_of_Δ_ne_zero CoordinateRing map Nonsingular \
+  CoordinateRing.XYIdeal' FunctionField Point CoordinateRing.mk Point.toClass_injective \
+  equation_iff polynomial"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+universe u
+
+variable {F : Type u} [Field F] {W : Affine F}
+
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "smul_basis_eq_zero XYIdeal XYIdeal'_eq \
+  quotientXYIdealEquiv XClass_ne_zero smul YClass XYIdeal' natDegree_norm_ne_one mk map \
+  degree_norm_smul_basis exists_smul_basis_eq XClass smul_basis_mul_Y YClass_ne_zero"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing"
+
+scoped instance : Algebra.FiniteType F W.CoordinateRing :=
+  Algebra.FiniteType.trans (S := Polynomial F) inferInstance inferInstance
+
+theorem exists_eq_XYIdeal_of_isMaximal [IsAlgClosed F] (𝔪 : Ideal W.CoordinateRing)
+    (h𝔪 : 𝔪.IsMaximal) : ∃ x y : F, W.Equation x y ∧ XYIdeal W x (C y) = 𝔪 := by
+  have := h𝔪
+  let : Field (W.CoordinateRing ⧸ 𝔪) := Ideal.Quotient.field 𝔪
+  have : Module.Finite F (W.CoordinateRing ⧸ 𝔪) :=
+    finite_of_finite_type_of_isJacobsonRing F (W.CoordinateRing ⧸ 𝔪)
+  have he : Function.Bijective (algebraMap F (W.CoordinateRing ⧸ 𝔪)) :=
+    IsAlgClosed.algebraMap_bijective_of_isIntegral
+  obtain ⟨x, hx⟩ := he.2 (Ideal.Quotient.mk 𝔪 (mk W (Polynomial.C Polynomial.X)))
+  obtain ⟨y, hy⟩ := he.2 (Ideal.Quotient.mk 𝔪 (mk W Y))
+  have hconst : ∀ a : F, Ideal.Quotient.mk 𝔪 ((mk W) (Polynomial.C (Polynomial.C a)))
+      = algebraMap F (W.CoordinateRing ⧸ 𝔪) a := by
+    intro a
+    have h1 : (mk W) (Polynomial.C (Polynomial.C a)) = algebraMap F W.CoordinateRing a := by
+      rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+        Algebra.algebraMap_self_apply]
+      rfl
+    rw [h1, ← Ideal.Quotient.algebraMap_eq, ← IsScalarTower.algebraMap_apply]
+  have key : ((Ideal.Quotient.mk 𝔪).comp
+        (mk W : Polynomial (Polynomial F) →+* W.CoordinateRing)) =
+      (algebraMap F (W.CoordinateRing ⧸ 𝔪)).comp
+        ((Polynomial.evalRingHom x).comp (Polynomial.evalRingHom (Polynomial.C y))) := by
+    refine Polynomial.ringHom_ext' (Polynomial.ringHom_ext (fun a => ?_) ?_) ?_
+    · simp only [RingHom.comp_apply, Polynomial.coe_evalRingHom, Polynomial.eval_C]
+      exact hconst a
+    · simp only [RingHom.comp_apply, Polynomial.coe_evalRingHom, Polynomial.eval_X,
+        Polynomial.eval_C]
+      exact hx.symm
+    · simp only [RingHom.comp_apply, Polynomial.coe_evalRingHom, Polynomial.eval_X,
+        Polynomial.eval_C]
+      exact hy.symm
+  have heval : W.Equation x y := by
+    have h0 := DFunLike.congr_fun key W.polynomial
+    simp only [RingHom.comp_apply, AdjoinRoot.mk_self, _root_.map_zero,
+      Polynomial.coe_evalRingHom] at h0
+    exact (map_eq_zero_iff (algebraMap F (W.CoordinateRing ⧸ 𝔪)) he.1).mp h0.symm
+  have hXmem : XClass W x ∈ 𝔪 := by
+    have h2 : ((Ideal.Quotient.mk 𝔪).comp (mk W))
+        (Polynomial.C (Polynomial.X - Polynomial.C x)) = 0 := by
+      rw [key]
+      simp
+    rw [← Ideal.Quotient.eq_zero_iff_mem]
+    exact h2
+  have hYmem : YClass W (Polynomial.C y) ∈ 𝔪 := by
+    have h2 : ((Ideal.Quotient.mk 𝔪).comp (mk W))
+        (Y - Polynomial.C (Polynomial.C y)) = 0 := by
+      rw [key]
+      simp
+    rw [← Ideal.Quotient.eq_zero_iff_mem]
+    exact h2
+  refine ⟨x, y, heval, ?_⟩
+  have hXY_le : XYIdeal W x (Polynomial.C y) ≤ 𝔪 := by
+    rw [XYIdeal, Ideal.span_le]
+    rintro _ (rfl | rfl)
+    · exact hXmem
+    · exact hYmem
+  have hXY_max : (XYIdeal W x (Polynomial.C y)).IsMaximal :=
+    Ideal.Quotient.maximal_of_isField _
+      ((quotientXYIdealEquiv (W' := W) (x := x) (y := Polynomial.C y)
+        heval).toMulEquiv.isField (Field.toIsField F))
+  exact hXY_max.eq_of_le h𝔪.ne_top hXY_le
+
+end CoordinateRing
+
+namespace Point
+p2m_export "WeierstrassCurve.Affine.Point" "add toClass some neg_zero map_zero map \
+  toClass_injective zero mk neg"
+end Point
+end Affine
+end WeierstrassCurve
+end
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ext Place.adicValuation Place.ord Place.ord_zero Divisor \
+  Divisor.degree Divisor.degree_single Divisor.IsPrincipal HasPrincipalDivisors Pic Pic0 \
+  Pic0.torsion AbelJacobiCard Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring HasPrincipalDivisors.exists_divisor Place.ne_top' \
+  Place.ramificationIndex Place.restrict Place.ord_restrict Place.restrict_fiber_finite \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff \
+  Place.ord_eq_neg_log_of_valuationSubring_eq hasPrincipalDivisors_of_finiteDimensional_ratFunc"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~P\
+  lace.ord_algebraMap"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_ne_zero ord ord_zero ord_mul ord_inv ord_zpow ord_unit_smul_zpow \
+  exists_unit_mul_zpow ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' \
+  algebraMap_mem' toValuationSubring mk ramificationIndex ramificationIndex_pos \
+  ramificationIndex_dvd_ord restrict ord_restrict ord_algebraMap_ne_zero_of_restrict_eq \
+  restrict_fiber_finite fiber ord_neg mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff \
+  ord_eq_neg_log_of_valuationSubring_eq"
+end Place
+end AlgebraicCurve
+end
+
+noncomputable section
+
+open IsDedekindDomain WithZero IsLocalRing
+open scoped Polynomial
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ext Place.adicValuation Place.ord Place.ord_zero Divisor \
+  Divisor.degree Divisor.degree_single Divisor.IsPrincipal HasPrincipalDivisors Pic Pic0 \
+  Pic0.torsion AbelJacobiCard Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring HasPrincipalDivisors.exists_divisor Place.ne_top' \
+  Place.ramificationIndex Place.restrict Place.ord_restrict Place.restrict_fiber_finite \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff \
+  Place.ord_eq_neg_log_of_valuationSubring_eq hasPrincipalDivisors_of_finiteDimensional_ratFunc"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~P\
+  lace.ord_algebraMap"
+
+theorem le_exp_neg_one_of_lt_one {x : ℤᵐ⁰} (hx : x < 1) : x ≤ exp (-1 : ℤ) := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · exact zero_le
+  · rw [← exp_log hx0] at hx ⊢
+    rw [show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_lt_exp] at hx
+    rw [exp_le_exp]
+    omega
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_ne_zero ord ord_zero ord_mul ord_inv ord_zpow ord_unit_smul_zpow \
+  exists_unit_mul_zpow ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' \
+  algebraMap_mem' toValuationSubring mk ramificationIndex ramificationIndex_pos \
+  ramificationIndex_dvd_ord restrict ord_restrict ord_algebraMap_ne_zero_of_restrict_eq \
+  restrict_fiber_finite fiber ord_neg mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff \
+  ord_eq_neg_log_of_valuationSubring_eq"
+end Place
+
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "placeOfPoint"
+end RationalFunctionField
+end AlgebraicCurve
+end
+
+section
+
+open Module Polynomial
+
+open scoped Polynomial.Bivariate
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.Point.toClass a₃ a₁ map Affine.CoordinateRing coe_Δ' \
+  mk a₄ Jacobian a₂ a₆ reduction Affine.CoordinateRing.XYIdeal' IsIntegral Affine.Point Δ j Δ'"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation Point.toClass CoordinateRing.XYIdeal \
+  CoordinateRing.XYIdeal'_eq equation_iff_nonsingular_of_Δ_ne_zero CoordinateRing map Nonsingular \
+  CoordinateRing.XYIdeal' FunctionField Point CoordinateRing.mk Point.toClass_injective \
+  equation_iff polynomial"
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "smul_basis_eq_zero XYIdeal XYIdeal'_eq \
+  quotientXYIdealEquiv XClass_ne_zero smul YClass XYIdeal' natDegree_norm_ne_one mk map \
+  degree_norm_smul_basis exists_smul_basis_eq XClass smul_basis_mul_Y YClass_ne_zero"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing WeierstrassCurve.Affine WeierstrassCurve"
+
+universe u
+
+variable {F : Type u} [Field F] {W : Affine F}
+
+private lemma algebraMap_eq_mk_C_C_s18priv (a : F) :
+    algebraMap F W.CoordinateRing a = mk W (C (C a)) := by
+  rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+    Algebra.algebraMap_self_apply]
+  rfl
+
+private lemma two_nsmul_le_coe_iff {d : WithBot ℕ} {n : ℕ} :
+    2 • d ≤ (n : WithBot ℕ) ↔ d < ((n / 2 + 1 : ℕ) : WithBot ℕ) := by
+  induction d using WithBot.recBotCoe with
+  | bot => exact iff_of_true (by simp) (WithBot.bot_lt_coe _)
+  | coe k =>
+    change 2 • ((k : ℕ) : WithBot ℕ) ≤ (n : WithBot ℕ) ↔
+      ((k : ℕ) : WithBot ℕ) < ((n / 2 + 1 : ℕ) : WithBot ℕ)
+    rw [two_nsmul, ← Nat.cast_add]
+    exact_mod_cast (by omega : k + k ≤ n ↔ k < n / 2 + 1)
+
+private lemma two_nsmul_add_three_le_coe_iff {d : WithBot ℕ} {n : ℕ} :
+    2 • d + 3 ≤ (n : WithBot ℕ) ↔ d < (((n - 1) / 2 : ℕ) : WithBot ℕ) := by
+  induction d using WithBot.recBotCoe with
+  | bot => exact iff_of_true (by simp) (WithBot.bot_lt_coe _)
+  | coe k =>
+    change 2 • ((k : ℕ) : WithBot ℕ) + 3 ≤ (n : WithBot ℕ) ↔
+      ((k : ℕ) : WithBot ℕ) < (((n - 1) / 2 : ℕ) : WithBot ℕ)
+    rw [two_nsmul, ← Nat.cast_add, show (3 : WithBot ℕ) = ((3 : ℕ) : WithBot ℕ) by norm_cast,
+      ← Nat.cast_add]
+    exact_mod_cast (by omega : k + k + 3 ≤ n ↔ k < (n - 1) / 2)
+
+private lemma xCount_add_yCount (n : ℕ) (hn : 1 ≤ n) : n / 2 + 1 + (n - 1) / 2 = n := by
+  omega
+
+variable (W) in
+noncomputable def rrParam (n : ℕ) :
+    (degreeLT F (n / 2 + 1) × degreeLT F ((n - 1) / 2)) →ₗ[F] W.CoordinateRing :=
+  LinearMap.coprod
+    (((LinearMap.toSpanSingleton F[X] W.CoordinateRing 1).restrictScalars F).comp
+      (Submodule.subtype _))
+    (((LinearMap.toSpanSingleton F[X] W.CoordinateRing (mk W Y)).restrictScalars F).comp
+      (Submodule.subtype _))
+
+@[scoped simp] lemma rrParam_apply (n : ℕ)
+    (pq : degreeLT F (n / 2 + 1) × degreeLT F ((n - 1) / 2)) :
+    rrParam W n pq = (pq.1 : F[X]) • (1 : W.CoordinateRing) + (pq.2 : F[X]) • mk W Y :=
+  rfl
+
+lemma rrParam_injective (n : ℕ) : Function.Injective (rrParam W n) := by
+  rw [injective_iff_map_eq_zero]
+  rintro ⟨p, q⟩ h
+  rw [rrParam_apply] at h
+  obtain ⟨hp, hq⟩ := smul_basis_eq_zero h
+  exact Prod.ext (Subtype.ext hp) (Subtype.ext hq)
+
+variable (W) in
+noncomputable def RRSpace (n : ℕ) : Submodule F W.CoordinateRing :=
+  LinearMap.range (rrParam W n)
+
+lemma mem_RRSpace_iff {f : W.CoordinateRing} {n : ℕ} :
+    f ∈ RRSpace W n ↔ ∃ p q : F[X], p.degree < ((n / 2 + 1 : ℕ) : WithBot ℕ) ∧
+      q.degree < (((n - 1) / 2 : ℕ) : WithBot ℕ) ∧
+      p • (1 : W.CoordinateRing) + q • mk W Y = f := by
+  constructor
+  · rintro ⟨⟨p, q⟩, rfl⟩
+    exact ⟨p, q, mem_degreeLT.mp p.2, mem_degreeLT.mp q.2, rfl⟩
+  · rintro ⟨p, q, hp, hq, rfl⟩
+    exact ⟨⟨⟨p, mem_degreeLT.mpr hp⟩, ⟨q, mem_degreeLT.mpr hq⟩⟩, rfl⟩
+
+lemma smul_basis_mem_RRSpace_iff {p q : F[X]} {n : ℕ} :
+    p • (1 : W.CoordinateRing) + q • mk W Y ∈ RRSpace W n ↔
+      p.degree < ((n / 2 + 1 : ℕ) : WithBot ℕ) ∧
+        q.degree < (((n - 1) / 2 : ℕ) : WithBot ℕ) := by
+  refine ⟨fun h => ?_, fun ⟨hp, hq⟩ => mem_RRSpace_iff.mpr ⟨p, q, hp, hq, rfl⟩⟩
+  obtain ⟨p', q', hp', hq', hf⟩ := mem_RRSpace_iff.mp h
+  have h0 : (p' - p) • (1 : W.CoordinateRing) + (q' - q) • mk W Y = 0 := by
+    rw [sub_smul, sub_smul, ← sub_eq_zero.mpr hf]
+    abel
+  obtain ⟨hp0, hq0⟩ := smul_basis_eq_zero h0
+  rw [sub_eq_zero] at hp0 hq0
+  exact ⟨hp0 ▸ hp', hq0 ▸ hq'⟩
+
+theorem mem_RRSpace_iff_degree_norm_le {f : W.CoordinateRing} {n : ℕ} :
+    f ∈ RRSpace W n ↔ (Algebra.norm F[X] f).degree ≤ (n : WithBot ℕ) := by
+  obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq f
+  rw [smul_basis_mem_RRSpace_iff, degree_norm_smul_basis, max_le_iff,
+    two_nsmul_le_coe_iff, two_nsmul_add_three_le_coe_iff]
+
+lemma RRSpace_mono {m n : ℕ} (h : m ≤ n) : RRSpace W m ≤ RRSpace W n := fun _ hf =>
+  mem_RRSpace_iff_degree_norm_le.mpr <|
+    (mem_RRSpace_iff_degree_norm_le.mp hf).trans <| by exact_mod_cast h
+
+lemma one_mem_RRSpace (n : ℕ) : (1 : W.CoordinateRing) ∈ RRSpace W n :=
+  mem_RRSpace_iff.mpr ⟨1, 0,
+    by rw [degree_one]; exact_mod_cast (by omega : (0 : ℕ) < n / 2 + 1),
+    by rw [degree_zero]; exact WithBot.bot_lt_coe _,
+    by rw [one_smul, zero_smul, add_zero]⟩
+
+lemma algebraMap_mem_RRSpace (a : F) (n : ℕ) :
+    algebraMap F W.CoordinateRing a ∈ RRSpace W n := by
+  rw [Algebra.algebraMap_eq_smul_one]
+  exact Submodule.smul_mem _ a (one_mem_RRSpace n)
+
+lemma one_le_RRSpace (n : ℕ) : (1 : Submodule F W.CoordinateRing) ≤ RRSpace W n := by
+  intro f hf
+  obtain ⟨a, rfl⟩ := Submodule.mem_one.mp hf
+  exact algebraMap_mem_RRSpace a n
+
+namespace RRSpace
+
+variable (W) in
+noncomputable def basisAux (n : ℕ) :
+    Basis (Fin (n / 2 + 1 + (n - 1) / 2)) F (RRSpace W n) :=
+  (degreeLT.basisProd F (n / 2 + 1) ((n - 1) / 2)).map
+    (LinearEquiv.ofInjective (rrParam W n) (rrParam_injective n))
+
+theorem finrank_eq (n : ℕ) (hn : 1 ≤ n) : finrank F (RRSpace W n) = n := by
+  rw [finrank_eq_card_basis (basisAux W n), Fintype.card_fin]
+  exact xCount_add_yCount n hn
+
+variable (W) in
+noncomputable def finBasis (n : ℕ) (hn : 1 ≤ n) : Basis (Fin n) F (RRSpace W n) :=
+  (basisAux W n).reindex (finCongr (xCount_add_yCount n hn))
+
+end RRSpace
+
+theorem RRSpace_zero : RRSpace W 0 = (1 : Submodule F W.CoordinateRing) := by
+  refine le_antisymm ?_ (one_le_RRSpace 0)
+  rintro f hf
+  obtain ⟨p, q, hp, hq, rfl⟩ := mem_RRSpace_iff.mp hf
+  have hq0 : q = 0 := by
+    rw [← degree_eq_bot]
+    simpa using hq
+  have hp0 : p = C (p.coeff 0) := by
+    refine degree_le_zero_iff.mp (Nat.WithBot.lt_one_iff_le_zero.mp ?_)
+    simpa using hp
+  rw [hq0, zero_smul, add_zero, hp0, smul, mul_one, ← algebraMap_eq_mk_C_C_s18priv]
+  exact Submodule.mem_one.mpr ⟨p.coeff 0, rfl⟩
+
+end CoordinateRing
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+section
+
+p2m_open "FractionalIdeal \
+  P2MW.S_OVERLONG_b3a5cd3d.FractionalIdeal Polynomial"
+
+open scoped nonZeroDivisors Polynomial.Bivariate
+
+namespace FractionalIdeal
+p2m_export "FractionalIdeal" "mul_inv_cancel_iff_isUnit count_mul coeIdeal_span_singleton count \
+  zero_mem ext count_zpow map_eq_zero_iff count_well_defined mul coeIdeal_inj count_maximal map \
+  isPrincipal_iff count_one exists_eq_spanSingleton_mul coeIdeal_mul spanSingleton \
+  le_one_iff_exists_coeIdeal spanSingleton_ne_zero_iff num coeIdeal_top \
+  finprod_heightOneSpectrum_factorization"
+p2m_open "FractionalIdeal"
+
+variable {R : Type*} (K : Type*) [CommRing R] [IsDomain R] [Field K] [Algebra R K]
+  [IsFractionRing R K]
+
+theorem isUnit_coeIdeal_of_forall_isMaximal [IsNoetherianRing R]
+    (hmax : ∀ 𝔪 : Ideal R, 𝔪.IsMaximal → 𝔪 ≠ ⊥ → IsUnit (𝔪 : FractionalIdeal R⁰ K))
+    (I : Ideal R) : I ≠ ⊥ → IsUnit (I : FractionalIdeal R⁰ K) := by
+  refine IsNoetherian.induction
+    (P := fun I : Ideal R => I ≠ ⊥ → IsUnit (I : FractionalIdeal R⁰ K)) (fun I ih hI => ?_) I
+  rcases eq_or_ne I ⊤ with rfl | hItop
+  · rw [coeIdeal_top]
+    exact isUnit_one
+  obtain ⟨𝔪, h𝔪, hI𝔪⟩ := Ideal.exists_le_maximal I hItop
+  have h𝔪0 : 𝔪 ≠ ⊥ := fun h => hI (le_bot_iff.mp (h ▸ hI𝔪))
+  have h𝔪unit : IsUnit (𝔪 : FractionalIdeal R⁰ K) := hmax 𝔪 h𝔪 h𝔪0
+  have h𝔪inv : (𝔪 : FractionalIdeal R⁰ K) * (𝔪 : FractionalIdeal R⁰ K)⁻¹ = 1 :=
+    (mul_inv_cancel_iff_isUnit K).mpr h𝔪unit
+  have hle : (I : FractionalIdeal R⁰ K) * (𝔪 : FractionalIdeal R⁰ K)⁻¹ ≤ 1 := by
+    calc (I : FractionalIdeal R⁰ K) * (𝔪 : FractionalIdeal R⁰ K)⁻¹
+        ≤ (𝔪 : FractionalIdeal R⁰ K) * (𝔪 : FractionalIdeal R⁰ K)⁻¹ := by gcongr
+      _ = 1 := h𝔪inv
+  obtain ⟨J, hJ⟩ := le_one_iff_exists_coeIdeal.mp hle
+  have hJ𝔪 : J * 𝔪 = I := by
+    rw [← coeIdeal_inj (K := K), coeIdeal_mul, hJ, mul_assoc,
+      mul_comm (𝔪 : FractionalIdeal R⁰ K)⁻¹, h𝔪inv, mul_one]
+  have hIJ : I ≤ J := hJ𝔪 ▸ Ideal.mul_le_left
+  have hJ0 : J ≠ ⊥ := fun h => hI (le_bot_iff.mp (h ▸ hIJ))
+  have hne : I ≠ J := by
+    rintro rfl
+    have hsmul : I ≤ 𝔪 • I := by
+      rw [Ideal.smul_eq_mul, mul_comm]
+      exact le_of_eq hJ𝔪.symm
+    obtain ⟨r, hr𝔪, hr⟩ := Submodule.exists_sub_one_mem_and_smul_eq_zero_of_fg_of_le_smul 𝔪 I
+      (IsNoetherian.noetherian I) hsmul
+    obtain ⟨n, hnI, hn0⟩ := Submodule.exists_mem_ne_zero_of_ne_bot hI
+    have hr0 : r = 0 := by
+      have hrn := hr n hnI
+      rw [smul_eq_mul] at hrn
+      exact (mul_eq_zero.mp hrn).resolve_right hn0
+    exact h𝔪.ne_top (𝔪.eq_top_of_isUnit_mem (by simpa [hr0] using hr𝔪) isUnit_one.neg)
+  have hJunit : IsUnit (J : FractionalIdeal R⁰ K) := ih J (lt_of_le_of_ne hIJ hne) hJ0
+  rw [← hJ𝔪, coeIdeal_mul]
+  exact hJunit.mul h𝔪unit
+
+theorem isUnit_of_forall_isMaximal [IsNoetherianRing R]
+    (hmax : ∀ 𝔪 : Ideal R, 𝔪.IsMaximal → 𝔪 ≠ ⊥ → IsUnit (𝔪 : FractionalIdeal R⁰ K))
+    (I : FractionalIdeal R⁰ K) (hI : I ≠ 0) : IsUnit I := by
+  obtain ⟨a, J, ha, rfl⟩ := exists_eq_spanSingleton_mul I
+  have ha' : algebraMap R K a ≠ 0 := mt IsFractionRing.to_map_eq_zero_iff.mp ha
+  refine IsUnit.mul ?_ (isUnit_coeIdeal_of_forall_isMaximal K hmax J ?_)
+  · exact isUnit_iff_exists_inv.mpr ⟨spanSingleton R⁰ (algebraMap R K a), by
+      rw [FractionalIdeal.spanSingleton_mul_spanSingleton, inv_mul_cancel₀ ha',
+        FractionalIdeal.spanSingleton_one]⟩
+  · rintro rfl
+    simp at hI
+
+end FractionalIdeal
+
+theorem isDedekindDomain_of_forall_isMaximal_isUnit {R : Type*} (K : Type*) [CommRing R]
+    [IsDomain R] [Field K] [Algebra R K] [IsFractionRing R K] [IsNoetherianRing R]
+    (hmax : ∀ 𝔪 : Ideal R, 𝔪.IsMaximal → 𝔪 ≠ ⊥ → IsUnit (𝔪 : FractionalIdeal R⁰ K)) :
+    IsDedekindDomain R :=
+  (isDedekindDomain_iff_mul_inv_cancel (K := K)).mpr fun I hI =>
+    (mul_inv_cancel_iff_isUnit K).mpr (isUnit_of_forall_isMaximal K hmax I hI)
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.Point.toClass a₃ a₁ map Affine.CoordinateRing coe_Δ' \
+  mk a₄ Jacobian a₂ a₆ reduction Affine.CoordinateRing.XYIdeal' IsIntegral Affine.Point Δ j Δ'"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation Point.toClass CoordinateRing.XYIdeal \
+  CoordinateRing.XYIdeal'_eq equation_iff_nonsingular_of_Δ_ne_zero CoordinateRing map Nonsingular \
+  CoordinateRing.XYIdeal' FunctionField Point CoordinateRing.mk Point.toClass_injective \
+  equation_iff polynomial"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+universe u
+
+variable {F : Type u} [Field F] {W : Affine F}
+
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "smul_basis_eq_zero XYIdeal XYIdeal'_eq \
+  quotientXYIdealEquiv XClass_ne_zero smul YClass XYIdeal' natDegree_norm_ne_one mk map \
+  degree_norm_smul_basis exists_smul_basis_eq XClass smul_basis_mul_Y YClass_ne_zero"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing"
+
+theorem isUnit_coeIdeal_of_isMaximal [IsAlgClosed F] (hΔ : W.Δ ≠ 0)
+    {𝔪 : Ideal W.CoordinateRing} (h𝔪 : 𝔪.IsMaximal) :
+    IsUnit (𝔪 : FractionalIdeal W.CoordinateRing⁰ W.FunctionField) := by
+  obtain ⟨x, y, hxy, hXY⟩ := exists_eq_XYIdeal_of_isMaximal 𝔪 h𝔪
+  rw [← hXY, ← XYIdeal'_eq ((W.equation_iff_nonsingular_of_Δ_ne_zero hΔ).mp hxy)]
+  exact (XYIdeal' _).isUnit
+
+theorem isDedekindDomain_of_Δ_ne_zero [IsAlgClosed F] (hΔ : W.Δ ≠ 0) :
+    IsDedekindDomain W.CoordinateRing :=
+  isDedekindDomain_of_forall_isMaximal_isUnit W.FunctionField
+    fun _𝔪 h𝔪 _ => isUnit_coeIdeal_of_isMaximal hΔ h𝔪
+
+scoped instance [IsAlgClosed F] [W.IsElliptic] : IsDedekindDomain W.CoordinateRing :=
+  isDedekindDomain_of_Δ_ne_zero (W.coe_Δ' ▸ W.Δ'.ne_zero)
+
+end CoordinateRing
+
+namespace Point
+p2m_export "WeierstrassCurve.Affine.Point" "add toClass some neg_zero map_zero map \
+  toClass_injective zero mk neg"
+end Point
+end Affine
+end WeierstrassCurve
+end
+
+noncomputable section
+
+open IsDedekindDomain Polynomial
+
+open scoped Polynomial.Bivariate
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ext Place.adicValuation Place.ord Place.ord_zero Divisor \
+  Divisor.degree Divisor.degree_single Divisor.IsPrincipal HasPrincipalDivisors Pic Pic0 \
+  Pic0.torsion AbelJacobiCard Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring HasPrincipalDivisors.exists_divisor Place.ne_top' \
+  Place.ramificationIndex Place.restrict Place.ord_restrict Place.restrict_fiber_finite \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff \
+  Place.ord_eq_neg_log_of_valuationSubring_eq hasPrincipalDivisors_of_finiteDimensional_ratFunc"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_ne_zero ord ord_zero ord_mul ord_inv ord_zpow ord_unit_smul_zpow \
+  exists_unit_mul_zpow ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' \
+  algebraMap_mem' toValuationSubring mk ramificationIndex ramificationIndex_pos \
+  ramificationIndex_dvd_ord restrict ord_restrict ord_algebraMap_ne_zero_of_restrict_eq \
+  restrict_fiber_finite fiber ord_neg mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff \
+  ord_eq_neg_log_of_valuationSubring_eq"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~ord_algebraMa\
+  p~comap_algebraMap_ne_top \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~Place.ord\
+  _algebraMap"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+theorem deg_eq_one_of_surjective (v : Place K F)
+    (h : Function.Surjective (algebraMap K v.ResidueField)) : v.deg = 1 := by
+  have hbij : Function.Bijective (algebraMap K v.ResidueField) :=
+    ⟨(algebraMap K v.ResidueField).injective, h⟩
+  change Module.finrank K v.ResidueField = 1
+  rw [← Module.finrank_self K]
+  exact ((AlgEquiv.ofBijective (Algebra.ofId K v.ResidueField) hbij).toLinearEquiv.finrank_eq).symm
+
+variable {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R F] [IsFractionRing R F]
+variable [Algebra K R] [IsScalarTower K R F]
+
+theorem deg_ofHeightOneSpectrum_eq_one (w : HeightOneSpectrum R)
+    (hw : ∀ r : R, ∃ c : K, r - algebraMap K R c ∈ w.asIdeal) :
+    (ofHeightOneSpectrum (K := K) (F := F) w).deg = 1 := by
+  set v : Place K F := ofHeightOneSpectrum (K := K) w with hv
+  apply deg_eq_one_of_surjective
+  intro z
+  obtain ⟨a, rfl⟩ := Ideal.Quotient.mk_surjective z
+  obtain ⟨n, d, hd, hnd⟩ : ∃ (n d : R) (_ : d ∈ w.asIdeal.primeCompl),
+      (a : F) * algebraMap R F d = algebraMap R F n := by
+    obtain ⟨n, d, hcase | hcase⟩ := w.exists_primeCompl_mul_eq_or_mul_eq (K := F) (a : F)
+    · exact ⟨n, d, d.2, hcase⟩
+    · refine ⟨(d : R), n, ?_, hcase⟩
+      intro hn
+      refine d.2 ?_
+      replace hn : n ∈ w.asIdeal := hn
+      change (d : R) ∈ w.asIdeal
+      rw [← w.valuation_lt_one_iff_mem (K := F)] at hn ⊢
+      calc w.valuation F (algebraMap R F (d : R))
+          = w.valuation F (a : F) * w.valuation F (algebraMap R F n) := by
+            rw [← map_mul, hcase]
+        _ ≤ 1 * w.valuation F (algebraMap R F n) := mul_le_mul_left a.2 _
+        _ = w.valuation F (algebraMap R F n) := one_mul _
+        _ < 1 := hn
+  obtain ⟨cn, hcn⟩ := hw n
+  obtain ⟨cd, hcd⟩ := hw d
+  have hcd0 : cd ≠ 0 := by
+    rintro rfl
+    rw [_root_.map_zero, sub_zero] at hcd
+    exact hd hcd
+  have hcdR : algebraMap K R cd ∉ w.asIdeal := fun hmem =>
+    hd (by simpa using w.asIdeal.add_mem hcd hmem)
+  have hvd : w.valuation F (algebraMap R F d) = 1 :=
+    le_antisymm (w.valuation_le_one d)
+      (not_lt.mp fun hlt => hd ((w.valuation_lt_one_iff_mem (K := F) d).mp hlt))
+  have hvcd : w.valuation F (algebraMap K F cd) = 1 := by
+    rw [IsScalarTower.algebraMap_apply K R F]
+    exact le_antisymm (w.valuation_le_one _)
+      (not_lt.mp fun hlt => hcdR ((w.valuation_lt_one_iff_mem (K := F) _).mp hlt))
+  have hcdF : algebraMap K F cd ≠ 0 := by
+    simpa using hcd0
+  refine ⟨cn / cd, ?_⟩
+  rw [IsScalarTower.algebraMap_apply K v.toValuationSubring v.ResidueField,
+    IsLocalRing.ResidueField.algebraMap_eq]
+  refine (Ideal.Quotient.eq (I := IsLocalRing.maximalIdeal v.toValuationSubring)).mpr ?_
+  have hmem : algebraMap K R cn * d - algebraMap K R cd * n ∈ w.asIdeal := by
+    have heq : algebraMap K R cn * d - algebraMap K R cd * n
+        = -((n - algebraMap K R cn) * d) + n * (d - algebraMap K R cd) := by ring
+    rw [heq]
+    exact w.asIdeal.add_mem (w.asIdeal.neg_mem (w.asIdeal.mul_mem_right _ hcn))
+      (w.asIdeal.mul_mem_left _ hcd)
+  have key : ((algebraMap K v.toValuationSubring (cn / cd) : F) - (a : F))
+      * (algebraMap K F cd * algebraMap R F d)
+      = algebraMap R F (algebraMap K R cn * d - algebraMap K R cd * n) := by
+    rw [coe_algebraMap, map_div₀, map_sub, map_mul, map_mul]
+    simp only [← IsScalarTower.algebraMap_apply K R F]
+    field_simp
+    linear_combination (-(algebraMap K F cd)) * hnd
+  refine (Valuation.mem_maximalIdeal_iff (v := w.valuation F)).mpr ?_
+  change w.valuation F ((algebraMap K v.toValuationSubring (cn / cd) : F) - (a : F)) < 1
+  calc w.valuation F ((algebraMap K v.toValuationSubring (cn / cd) : F) - (a : F))
+      = w.valuation F ((algebraMap K v.toValuationSubring (cn / cd) : F) - (a : F))
+        * (w.valuation F (algebraMap K F cd) * w.valuation F (algebraMap R F d)) := by
+          rw [hvcd, hvd, one_mul, mul_one]
+    _ = w.valuation F (((algebraMap K v.toValuationSubring (cn / cd) : F) - (a : F))
+        * (algebraMap K F cd * algebraMap R F d)) := by rw [map_mul, map_mul]
+    _ = w.valuation F (algebraMap R F (algebraMap K R cn * d - algebraMap K R cd * n)) := by
+          rw [key]
+    _ < 1 := (w.valuation_lt_one_iff_mem (K := F) _).mpr hmem
+
+end Place
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.Point.toClass a₃ a₁ map Affine.CoordinateRing coe_Δ' \
+  mk a₄ Jacobian a₂ a₆ reduction Affine.CoordinateRing.XYIdeal' IsIntegral Affine.Point Δ j Δ'"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation Point.toClass CoordinateRing.XYIdeal \
+  CoordinateRing.XYIdeal'_eq equation_iff_nonsingular_of_Δ_ne_zero CoordinateRing map Nonsingular \
+  CoordinateRing.XYIdeal' FunctionField Point CoordinateRing.mk Point.toClass_injective \
+  equation_iff polynomial"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "smul_basis_eq_zero XYIdeal XYIdeal'_eq \
+  quotientXYIdealEquiv XClass_ne_zero smul YClass XYIdeal' natDegree_norm_ne_one mk map \
+  degree_norm_smul_basis exists_smul_basis_eq XClass smul_basis_mul_Y YClass_ne_zero"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing"
+
+theorem algebraMap_eq_mk_C_C (a : F) :
+    algebraMap F W.CoordinateRing a = CoordinateRing.mk W (C (C a)) := by
+  rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+    Algebra.algebraMap_self_apply]
+  rfl
+
+theorem XYIdeal_isMaximal {x y : F} (h : W.Equation x y) :
+    (XYIdeal W x (C y)).IsMaximal :=
+  Ideal.Quotient.maximal_of_isField _
+    ((quotientXYIdealEquiv (W' := W) (x := x) (y := C y) h).toMulEquiv.isField
+      (Field.toIsField F))
+
+theorem XYIdeal_ne_bot (x : F) (y : F[X]) : XYIdeal W x y ≠ ⊥ := by
+  intro hbot
+  have hX : XClass W x ∈ XYIdeal W x y := Ideal.subset_span (Set.mem_insert _ _)
+  rw [hbot, Ideal.mem_bot] at hX
+  exact XClass_ne_zero x hX
+
+theorem eq_of_XYIdeal_eq {x₁ y₁ x₂ y₂ : F} (h₂ : W.Equation x₂ y₂)
+    (h : XYIdeal W x₁ (C y₁) = XYIdeal W x₂ (C y₂)) : x₁ = x₂ ∧ y₁ = y₂ := by
+  have hne : XYIdeal W x₂ (C y₂) ≠ ⊤ := (XYIdeal_isMaximal h₂).ne_top
+  have hX₁ : XClass W x₁ ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert _ _)
+  have hX₂ : XClass W x₂ ∈ XYIdeal W x₂ (C y₂) := Ideal.subset_span (Set.mem_insert _ _)
+  have hY₁ : YClass W (C y₁) ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  have hY₂ : YClass W (C y₂) ∈ XYIdeal W x₂ (C y₂) :=
+    Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  constructor
+  · by_contra hx
+    apply hne
+    have hsub : XClass W x₁ - XClass W x₂ = algebraMap F W.CoordinateRing (x₂ - x₁) := by
+      rw [XClass, XClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      rw [← map_sub]
+      congr 1
+      rw [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hX₁ hX₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hx hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+  · by_contra hy
+    apply hne
+    have hsub : YClass W (C y₁) - YClass W (C y₂) = algebraMap F W.CoordinateRing (y₂ - y₁) := by
+      rw [YClass, YClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      simp only [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hY₁ hY₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hy hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+
+def heightOneSpectrumOfEquation {x y : F} (h : W.Equation x y) :
+    HeightOneSpectrum W.CoordinateRing where
+  asIdeal := XYIdeal W x (C y)
+  isPrime := (XYIdeal_isMaximal h).isPrime
+  ne_bot := XYIdeal_ne_bot x (C y)
+
+@[scoped simp]
+theorem heightOneSpectrumOfEquation_asIdeal {x y : F} (h : W.Equation x y) :
+    (heightOneSpectrumOfEquation h).asIdeal = XYIdeal W x (C y) := rfl
+
+theorem exists_sub_algebraMap_mem {x y : F} (h : W.Equation x y) (r : W.CoordinateRing) :
+    ∃ c : F, r - algebraMap F W.CoordinateRing c ∈ XYIdeal W x (C y) := by
+  set e := quotientXYIdealEquiv (W' := W) (x := x) (y := C y) h
+  refine ⟨e (Ideal.Quotient.mk _ r), ?_⟩
+  rw [← Ideal.Quotient.eq_zero_iff_mem, map_sub, sub_eq_zero]
+  apply e.injective
+  rw [← Ideal.Quotient.algebraMap_eq, ← IsScalarTower.algebraMap_apply, AlgEquiv.commutes,
+    Algebra.algebraMap_self_apply]
+
+end CoordinateRing
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_b3a5cd3d.WeierstrassCurve.Affine.Coordin\
+  ateRing"
+
+def IsFinitePlace (v : AlgebraicCurve.Place F W.FunctionField) : Prop :=
+  ∀ r : W.CoordinateRing, algebraMap W.CoordinateRing W.FunctionField r ∈ v.toValuationSubring
+
+def IsFinitePlace.ringHom {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    W.CoordinateRing →+* v.toValuationSubring where
+  toFun r := ⟨algebraMap W.CoordinateRing W.FunctionField r, hv r⟩
+  map_one' := Subtype.ext (map_one _)
+  map_mul' a b := Subtype.ext (map_mul _ a b)
+  map_zero' := Subtype.ext (_root_.map_zero _)
+  map_add' a b := Subtype.ext (map_add _ a b)
+
+def IsFinitePlace.centre {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    Ideal W.CoordinateRing :=
+  (IsLocalRing.maximalIdeal v.toValuationSubring).comap hv.ringHom
+
+theorem IsFinitePlace.centre_isPrime {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre.IsPrime :=
+  Ideal.IsPrime.comap _
+
+theorem IsFinitePlace.inv_mem {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) {r : W.CoordinateRing} (hr : r ∉ hv.centre) :
+    (algebraMap W.CoordinateRing W.FunctionField r)⁻¹ ∈ v.toValuationSubring := by
+  have hunit : IsUnit (hv.ringHom r) := by
+    rw [IsFinitePlace.centre, Ideal.mem_comap, IsLocalRing.mem_maximalIdeal,
+      mem_nonunits_iff, not_not] at hr
+    exact hr
+  obtain ⟨t, ht⟩ := hunit.exists_right_inv
+  have ht' : algebraMap W.CoordinateRing W.FunctionField r * (t : W.FunctionField) = 1 := by
+    have := congrArg (fun a : v.toValuationSubring => (a : W.FunctionField)) ht
+    simp only [MulMemClass.coe_mul, OneMemClass.coe_one] at this
+    exact this
+  rw [inv_eq_of_mul_eq_one_right ht']
+  exact t.2
+
+theorem IsFinitePlace.centre_ne_bot {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre ≠ ⊥ := by
+  intro hbot
+  apply v.ne_top'
+  rw [eq_top_iff]
+  rintro z -
+  obtain ⟨r, s, hs, hz⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  have hs0 : s ∉ hv.centre := by
+    rw [hbot, Ideal.mem_bot]
+    exact fun h => nonZeroDivisors.ne_zero hs h
+  rw [← hz, div_eq_mul_inv]
+  exact mul_mem (hv r) (hv.inv_mem hs0)
+
+variable [IsDedekindDomain W.CoordinateRing]
+
+def placeOfEquation {x y : F} (h : W.Equation x y) :
+    AlgebraicCurve.Place F W.FunctionField :=
+  AlgebraicCurve.Place.ofHeightOneSpectrum (heightOneSpectrumOfEquation h)
+
+theorem deg_placeOfEquation {x y : F} (h : W.Equation x y) : (placeOfEquation h).deg = 1 :=
+  AlgebraicCurve.Place.deg_ofHeightOneSpectrum_eq_one _ (exists_sub_algebraMap_mem h)
+
+theorem placeOfEquation_injective {x₁ y₁ x₂ y₂ : F} (h₁ : W.Equation x₁ y₁)
+    (h₂ : W.Equation x₂ y₂) (h : placeOfEquation h₁ = placeOfEquation h₂) :
+    x₁ = x₂ ∧ y₁ = y₂ :=
+  eq_of_XYIdeal_eq h₂
+    (congrArg HeightOneSpectrum.asIdeal (AlgebraicCurve.Place.ofHeightOneSpectrum_injective h))
+
+theorem isFinitePlace_placeOfEquation {x y : F} (h : W.Equation x y) :
+    IsFinitePlace (placeOfEquation h) := fun r =>
+  (heightOneSpectrumOfEquation h).valuation_le_one r
+
+theorem isFinitePlace_iff_exists_placeOfEquation [IsAlgClosed F]
+    (v : AlgebraicCurve.Place F W.FunctionField) :
+    IsFinitePlace v ↔ ∃ (x y : F) (h : W.Equation x y), v = placeOfEquation h := by
+  constructor
+  · intro hv
+    have := hv.centre_isPrime
+    have hmax : hv.centre.IsMaximal := Ideal.IsPrime.isMaximal hv.centre_isPrime hv.centre_ne_bot
+    obtain ⟨x, y, hxy, hXY⟩ := CoordinateRing.exists_eq_XYIdeal_of_isMaximal hv.centre hmax
+    refine ⟨x, y, hxy, ?_⟩
+    set w : HeightOneSpectrum W.CoordinateRing := heightOneSpectrumOfEquation hxy with hw
+    set A : ValuationSubring W.FunctionField :=
+      HeightOneSpectrum.valuationSubringAtPrime W.FunctionField w with hA
+    have hAded : IsDedekindDomain A := by rw [hA]; infer_instance
+    have hle : A ≤ v.toValuationSubring := by
+      intro z hz
+      rw [hA] at hz
+      obtain ⟨r, s, hs, rfl⟩ := hz
+      have hs' : s ∉ hv.centre := by
+        intro hmem
+        rw [← hXY] at hmem
+        exact hs hmem
+      exact mul_mem (hv r) (hv.inv_mem hs')
+    have hSP : A.ofPrime (A.idealOfLE v.toValuationSubring hle) = v.toValuationSubring :=
+      ValuationSubring.ofPrime_idealOfLE A v.toValuationSubring hle
+    rcases eq_or_ne (A.idealOfLE v.toValuationSubring hle) ⊥ with hP | hP
+    · exfalso
+      apply v.ne_top'
+      have h2 : A.ofPrime ⊥ ≤ A.ofPrime (A.idealOfLE v.toValuationSubring hle) :=
+        ValuationSubring.ofPrime_le_of_le (h := hP.le)
+      rw [ValuationSubring.ofPrime_bot] at h2
+      exact top_le_iff.mp (le_trans h2 hSP.le)
+    · have hPmax : (A.idealOfLE v.toValuationSubring hle).IsMaximal :=
+        Ideal.IsPrime.isMaximal inferInstance hP
+      have hPeq : A.idealOfLE v.toValuationSubring hle = IsLocalRing.maximalIdeal A :=
+        IsLocalRing.eq_maximalIdeal hPmax
+      have h3 : A.ofPrime (A.idealOfLE v.toValuationSubring hle)
+          = A.ofPrime (IsLocalRing.maximalIdeal A) :=
+        le_antisymm (ValuationSubring.ofPrime_le_of_le (h := hPeq.ge))
+          (ValuationSubring.ofPrime_le_of_le (h := hPeq.le))
+      rw [ValuationSubring.ofPrime_top] at h3
+      have hAv : A = v.toValuationSubring := h3.symm.trans hSP
+      refine (AlgebraicCurve.Place.ext ?_).symm
+      change (AlgebraicCurve.Place.ofHeightOneSpectrum w).toValuationSubring = v.toValuationSubring
+      rw [AlgebraicCurve.Place.ofHeightOneSpectrum_toValuationSubring,
+        ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact hAv
+  · rintro ⟨x, y, h, rfl⟩
+    exact isFinitePlace_placeOfEquation h
+
+variable (W) in
+class InfinitePlace : Type _ where
+  place : AlgebraicCurve.Place F W.FunctionField
+  not_isFinitePlace : ¬ IsFinitePlace place
+  deg_eq_one : place.deg = 1
+  eq_of_not_isFinitePlace : ∀ v : AlgebraicCurve.Place F W.FunctionField,
+    ¬ IsFinitePlace v → v = place
+
+def geomPlaceOfPoint [InfinitePlace W] : W.Point → AlgebraicCurve.Place F W.FunctionField
+  | .zero => InfinitePlace.place
+  | .some x y h => placeOfEquation (W := W) (x := x) (y := y) h.left
+
+@[scoped simp]
+theorem geomPlaceOfPoint_zero [InfinitePlace W] :
+    geomPlaceOfPoint (.zero : W.Point) = InfinitePlace.place := rfl
+
+@[scoped simp]
+theorem geomPlaceOfPoint_some [InfinitePlace W] {x y : F} (h : W.Nonsingular x y) :
+    geomPlaceOfPoint (.some x y h) = placeOfEquation h.left := rfl
+
+theorem deg_geomPlaceOfPoint [InfinitePlace W] (P : W.Point) : (geomPlaceOfPoint P).deg = 1 := by
+  cases P with
+  | zero => exact InfinitePlace.deg_eq_one
+  | some x y h => exact deg_placeOfEquation h.left
+
+theorem geomPlaceOfPoint_injective [InfinitePlace W] :
+    Function.Injective (geomPlaceOfPoint (W := W)) := by
+  intro P Q h
+  cases P with
+  | zero => cases Q with
+    | zero => rfl
+    | some xQ yQ hQ =>
+        rw [geomPlaceOfPoint_zero, geomPlaceOfPoint_some] at h
+        exact absurd (h ▸ InfinitePlace.not_isFinitePlace) (not_not.mpr
+          (isFinitePlace_placeOfEquation hQ.left))
+  | some xP yP hP => cases Q with
+    | zero =>
+        rw [geomPlaceOfPoint_some, geomPlaceOfPoint_zero] at h
+        exact absurd (h ▸ isFinitePlace_placeOfEquation hP.left)
+          InfinitePlace.not_isFinitePlace
+    | some xQ yQ hQ =>
+        rw [geomPlaceOfPoint_some, geomPlaceOfPoint_some] at h
+        obtain ⟨hx, hy⟩ := placeOfEquation_injective hP.left hQ.left h
+        subst hx
+        subst hy
+        rfl
+
+theorem geomPlaceOfPoint_surjective [InfinitePlace W] [IsAlgClosed F] (hΔ : W.Δ ≠ 0) :
+    Function.Surjective (geomPlaceOfPoint (W := W)) := by
+  intro v
+  by_cases hv : IsFinitePlace v
+  · obtain ⟨x, y, h, rfl⟩ := (isFinitePlace_iff_exists_placeOfEquation v).mp hv
+    exact ⟨.some x y ((W.equation_iff_nonsingular_of_Δ_ne_zero hΔ).mp h), rfl⟩
+  · exact ⟨.zero, (InfinitePlace.eq_of_not_isFinitePlace v hv).symm⟩
+
+end Affine
+end WeierstrassCurve
+end
+
+open
+  P2MW.S_OVERLONG_b3a5cd3d.WeierstrassCurve.Affine.CoordinateRing
+  P2MW.S_OVERLONG_b3a5cd3d.WeierstrassCurve.Affine
+
+section
+
+noncomputable section
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~P\
+  lace.ord_algebraMap \
+  P2MW.S_OVERLONG_b3a5cd3d.AlgebraicCurve"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.Point.toClass a₃ a₁ map Affine.CoordinateRing coe_Δ' \
+  mk a₄ Jacobian a₂ a₆ reduction Affine.CoordinateRing.XYIdeal' IsIntegral Affine.Point Δ j Δ'"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation Point.toClass CoordinateRing.XYIdeal \
+  CoordinateRing.XYIdeal'_eq equation_iff_nonsingular_of_Δ_ne_zero CoordinateRing map Nonsingular \
+  CoordinateRing.XYIdeal' FunctionField Point CoordinateRing.mk Point.toClass_injective \
+  equation_iff polynomial"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] {W : Affine F}
+variable [IsAlgClosed F] [W.IsElliptic] [InfinitePlace W]
+
+omit [DecidableEq F] [IsAlgClosed F] [InfinitePlace W] in
+theorem isElliptic_Δ_ne_zero : W.Δ ≠ 0 := W.coe_Δ' ▸ W.Δ'.ne_zero
+
+def geomPointEquivPlace : W.Point ≃ AlgebraicCurve.Place F W.FunctionField :=
+  Equiv.ofBijective geomPlaceOfPoint
+    ⟨geomPlaceOfPoint_injective, geomPlaceOfPoint_surjective isElliptic_Δ_ne_zero⟩
+
+omit [DecidableEq F] in
+@[scoped simp]
+theorem geomPointEquivPlace_apply (P : W.Point) : geomPointEquivPlace P = geomPlaceOfPoint P := rfl
+
+omit [DecidableEq F] in
+@[scoped simp]
+theorem geomPointEquivPlace_symm_geomPlaceOfPoint (P : W.Point) :
+    geomPointEquivPlace.symm (geomPlaceOfPoint (W := W) P) = P :=
+  geomPointEquivPlace.symm_apply_apply P
+
+def geomDivisorSum : AlgebraicCurve.Divisor F W.FunctionField →+ W.Point :=
+  Finsupp.liftAddHom fun v => zmultiplesHom W.Point (geomPointEquivPlace.symm v)
+
+@[scoped simp]
+theorem geomDivisorSum_single (v : AlgebraicCurve.Place F W.FunctionField) (n : ℤ) :
+    geomDivisorSum (Finsupp.single v n) = n • (geomPointEquivPlace (W := W)).symm v :=
+  Finsupp.liftAddHom_apply_single _ v n
+
+variable (W) in
+class GeomAbelTheorem : Prop where
+  isPrincipal_iff_geomDivisorSum_eq_zero :
+    ∀ D : AlgebraicCurve.Divisor F W.FunctionField, Divisor.degree D = 0 →
+      (Divisor.IsPrincipal D ↔ geomDivisorSum D = 0)
+
+end Affine
+end WeierstrassCurve
+end
+
+noncomputable section
+
+open Polynomial IsDedekindDomain
+
+open scoped Polynomial.Bivariate
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ext Place.adicValuation Place.ord Place.ord_zero Divisor \
+  Divisor.degree Divisor.degree_single Divisor.IsPrincipal HasPrincipalDivisors Pic Pic0 \
+  Pic0.torsion AbelJacobiCard Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring HasPrincipalDivisors.exists_divisor Place.ne_top' \
+  Place.ramificationIndex Place.restrict Place.ord_restrict Place.restrict_fiber_finite \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff \
+  Place.ord_eq_neg_log_of_valuationSubring_eq hasPrincipalDivisors_of_finiteDimensional_ratFunc"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_ne_zero ord ord_zero ord_mul ord_inv ord_zpow ord_unit_smul_zpow \
+  exists_unit_mul_zpow ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' \
+  algebraMap_mem' toValuationSubring mk ramificationIndex ramificationIndex_pos \
+  ramificationIndex_dvd_ord restrict ord_restrict ord_algebraMap_ne_zero_of_restrict_eq \
+  restrict_fiber_finite fiber ord_neg mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff \
+  ord_eq_neg_log_of_valuationSubring_eq"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~ord_algebraMa\
+  p~comap_algebraMap_ne_top \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~Place.ord\
+  _algebraMap"
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.ord_add_eq_min {f g : F} (hf : f ≠ 0) (hg : g ≠ 0)
+    (h : v.ord f ≠ v.ord g) :
+    v.ord (f + g) = min (v.ord f) (v.ord g) := by
+  have hval : v.adicValuation f ≠ v.adicValuation g := by
+    intro hcon
+    exact h (by simp only [ord, hcon])
+  have h1 : v.adicValuation (f + g) = max (v.adicValuation f) (v.adicValuation g) :=
+    Valuation.map_add_of_distinct_val _ hval
+  have hfg : f + g ≠ 0 := by
+    intro hcon
+    rw [hcon, _root_.map_zero] at h1
+    rcases max_cases (v.adicValuation f) (v.adicValuation g) with ⟨hmax, -⟩ | ⟨hmax, -⟩ <;>
+      rw [hmax] at h1
+    · exact v.adicValuation_ne_zero hf h1.symm
+    · exact v.adicValuation_ne_zero hg h1.symm
+  rcases max_cases (v.adicValuation f) (v.adicValuation g) with ⟨hmax, hle⟩ | ⟨hmax, hlt⟩ <;>
+    rw [hmax] at h1
+  · have hlog := (WithZero.log_le_log (v.adicValuation_ne_zero hg)
+      (v.adicValuation_ne_zero hf)).mpr hle
+    have h2 : v.ord (f + g) = v.ord f := by simp only [ord, h1]
+    simp only [ord] at hlog h2 ⊢
+    omega
+  · have hlog := (WithZero.log_le_log (v.adicValuation_ne_zero hf)
+      (v.adicValuation_ne_zero hg)).mpr hlt.le
+    have h2 : v.ord (f + g) = v.ord g := by simp only [ord, h1]
+    simp only [ord] at hlog h2 ⊢
+    omega
+
+p2m_export "AlgebraicCurve.Place" "ord_add_eq_min"
+
+private theorem ord_algebraMap (c : K) : v.ord (algebraMap K F c) = 0 := by
+  rcases eq_or_ne c 0 with rfl | hc
+  · simp
+  have hmem : algebraMap K F c ∈ v.toValuationSubring := v.algebraMap_mem' c
+  have hmem' : (algebraMap K F c)⁻¹ ∈ v.toValuationSubring := by
+    rw [← map_inv₀]
+    exact v.algebraMap_mem' c⁻¹
+  have h1 := AlgebraicCurve.Place.ord_nonneg_of_mem v hmem
+  have h2 := AlgebraicCurve.Place.ord_nonneg_of_mem v hmem'
+  rw [v.ord_inv] at h2
+  omega
+
+private theorem _root_.AlgebraicCurve.Place.ord_pow (f : F) (n : ℕ) :
+    v.ord (f ^ n) = n * v.ord f := by
+  rw [← zpow_natCast, v.ord_zpow]
+
+p2m_export "AlgebraicCurve.Place" "ord_pow"
+
+private theorem _root_.AlgebraicCurve.Place.ord_ringHom_eq_natDegree_mul {φ : K[X] →+* F}
+    (hφinj : Function.Injective φ)
+    (hφC : ∀ c : K, φ (C c) = algebraMap K F c) (hz : v.ord (φ X) < 0) :
+    ∀ {p : K[X]}, p ≠ 0 → v.ord (φ p) = p.natDegree * v.ord (φ X) := by
+  have hX0 : φ X ≠ 0 := fun h => by simp [Place.ord, h] at hz
+  have hmono : ∀ (c : K) (n : ℕ), c ≠ 0 → v.ord (φ (C c * X ^ n)) = n * v.ord (φ X) := by
+    intro c n hc
+    have hc0 : φ (C c) ≠ 0 := by
+      rw [hφC]
+      simpa using hc
+    rw [map_mul, map_pow, v.ord_mul hc0 (pow_ne_zero n hX0), hφC,
+      AlgebraicCurve.Place.ord_algebraMap v,
+      v.ord_pow, zero_add]
+  intro p
+  induction hd : p.natDegree using Nat.strong_induction_on generalizing p with
+  | _ d ih =>
+    intro hp
+    subst hd
+    rcases eq_or_ne p.eraseLead 0 with he | he
+    · conv_lhs => rw [← p.eraseLead_add_C_mul_X_pow, he, zero_add]
+      exact hmono _ _ (leadingCoeff_ne_zero.mpr hp)
+    · have hlt : p.eraseLead.natDegree < p.natDegree := by
+        rcases p.eraseLead_natDegree_lt_or_eraseLead_eq_zero with h | h
+        · exact h
+        · exact absurd h he
+      have hIH : v.ord (φ p.eraseLead) = p.eraseLead.natDegree * v.ord (φ X) :=
+        ih _ hlt rfl he
+      have hlead : v.ord (φ (C p.leadingCoeff * X ^ p.natDegree))
+          = p.natDegree * v.ord (φ X) := hmono _ _ (leadingCoeff_ne_zero.mpr hp)
+      have hcast : (p.eraseLead.natDegree : ℤ) < (p.natDegree : ℤ) := by exact_mod_cast hlt
+      have hne : v.ord (φ p.eraseLead) ≠ v.ord (φ (C p.leadingCoeff * X ^ p.natDegree)) := by
+        rw [hIH, hlead]
+        nlinarith
+      have he2 : φ (C p.leadingCoeff * X ^ p.natDegree) ≠ 0 := fun hcon =>
+        mul_ne_zero (C_ne_zero.mpr (leadingCoeff_ne_zero.mpr hp)) (pow_ne_zero _ X_ne_zero)
+          (hφinj (hcon.trans (_root_.map_zero φ).symm))
+      have he1 : φ p.eraseLead ≠ 0 := fun hcon => he (hφinj (hcon.trans (_root_.map_zero φ).symm))
+      conv_lhs => rw [← p.eraseLead_add_C_mul_X_pow]
+      rw [map_add, v.ord_add_eq_min he1 he2 hne, hIH, hlead]
+      have h1 : (p.natDegree : ℤ) * v.ord (φ X) ≤ (p.eraseLead.natDegree : ℤ) * v.ord (φ X) := by
+        nlinarith
+      omega
+
+p2m_export "AlgebraicCurve.Place" "ord_ringHom_eq_natDegree_mul"
+
+private theorem _root_.AlgebraicCurve.Place.le_ord_ringHom_of_natDegree_le {φ : K[X] →+* F}
+    (hφinj : Function.Injective φ)
+    (hφC : ∀ c : K, φ (C c) = algebraMap K F c) (hz : v.ord (φ X) < 0)
+    {p : K[X]} {d : ℕ} (hd : p.natDegree ≤ d) :
+    (d : ℤ) * v.ord (φ X) ≤ v.ord (φ p) := by
+  rcases eq_or_ne p 0 with rfl | hp
+  · simp only [_root_.map_zero, Place.ord_zero]
+    nlinarith [hz]
+  rw [v.ord_ringHom_eq_natDegree_mul hφinj hφC hz hp]
+  have h1 : (p.natDegree : ℤ) ≤ (d : ℤ) := by exact_mod_cast hd
+  nlinarith
+
+p2m_export "AlgebraicCurve.Place" "le_ord_ringHom_of_natDegree_le"
+end Place
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.Point.toClass a₃ a₁ map Affine.CoordinateRing coe_Δ' \
+  mk a₄ Jacobian a₂ a₆ reduction Affine.CoordinateRing.XYIdeal' IsIntegral Affine.Point Δ j Δ'"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation Point.toClass CoordinateRing.XYIdeal \
+  CoordinateRing.XYIdeal'_eq equation_iff_nonsingular_of_Δ_ne_zero CoordinateRing map Nonsingular \
+  CoordinateRing.XYIdeal' FunctionField Point CoordinateRing.mk Point.toClass_injective \
+  equation_iff polynomial"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_b3a5cd3d.WeierstrassCurve.Affine.Coordin\
+  ateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~Place.ord\
+  _algebraMap P2MW.S_OVERLONG_b3a5cd3d.AlgebraicCurve"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+def polyToFunctionField (W : Affine F) : F[X] →+* W.FunctionField :=
+  (algebraMap W.CoordinateRing W.FunctionField).comp (algebraMap F[X] W.CoordinateRing)
+
+theorem polyToFunctionField_apply (p : F[X]) :
+    polyToFunctionField W p
+      = algebraMap W.CoordinateRing W.FunctionField (algebraMap F[X] W.CoordinateRing p) := rfl
+
+theorem algebraMap_smul_one (p : F[X]) :
+    algebraMap W.CoordinateRing W.FunctionField (p • (1 : W.CoordinateRing))
+      = polyToFunctionField W p := by
+  rw [polyToFunctionField_apply, smul, mul_one]
+  rfl
+
+theorem polyToFunctionField_injective : Function.Injective (polyToFunctionField W) := by
+  intro p q h
+  rw [polyToFunctionField_apply, polyToFunctionField_apply] at h
+  have h2 := IsFractionRing.injective W.CoordinateRing W.FunctionField h
+  have h0 : (p - q) • (1 : W.CoordinateRing) + (0 : F[X]) • CoordinateRing.mk W Y = 0 := by
+    rw [zero_smul, add_zero, sub_smul, ← Algebra.algebraMap_eq_smul_one,
+      ← Algebra.algebraMap_eq_smul_one, h2, sub_self]
+  exact sub_eq_zero.mp (smul_basis_eq_zero h0).1
+
+theorem polyToFunctionField_C (c : F) :
+    polyToFunctionField W (C c) = algebraMap F W.FunctionField c := by
+  rw [polyToFunctionField_apply,
+    show algebraMap F[X] W.CoordinateRing (C c) = algebraMap F W.CoordinateRing c from
+      (IsScalarTower.algebraMap_apply F F[X] W.CoordinateRing c).symm]
+  exact (IsScalarTower.algebraMap_apply F W.CoordinateRing W.FunctionField c).symm
+
+theorem polyToFunctionField_ne_zero {p : F[X]} (hp : p ≠ 0) :
+    polyToFunctionField W p ≠ 0 := by
+  intro h
+  exact hp (polyToFunctionField_injective (by simpa using h))
+
+theorem algebraMap_smul_basis (p q : F[X]) :
+    algebraMap W.CoordinateRing W.FunctionField
+        (p • (1 : W.CoordinateRing) + q • CoordinateRing.mk W Y)
+      = polyToFunctionField W p + polyToFunctionField W q
+          * algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) := by
+  rw [map_add, algebraMap_smul_one, smul, map_mul, polyToFunctionField_apply]
+  rfl
+
+theorem Y_image_ne_zero :
+    algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) ≠ 0 := by
+  have h1 : (CoordinateRing.mk W Y) ≠ 0 := by
+    have h2 := YClass_ne_zero (W' := W) 0
+    simpa [YClass] using h2
+  exact (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr h1
+
+theorem natDegree_norm_smul_basis_left {p : F[X]} (hp : p ≠ 0) :
+    ((Algebra.norm F[X] (p • (1 : W.CoordinateRing)
+        + (0 : F[X]) • CoordinateRing.mk W Y)).natDegree : ℤ) = 2 * p.natDegree := by
+  have hdeg := degree_norm_smul_basis (W' := W) p 0
+  rw [Polynomial.degree_zero, show (2 : ℕ) • (⊥ : WithBot ℕ) + 3 = ⊥ by
+      rw [two_nsmul]; simp, max_eq_left bot_le, Polynomial.degree_eq_natDegree hp, two_nsmul,
+    ← Nat.cast_add] at hdeg
+  rw [Polynomial.natDegree_eq_of_degree_eq_some hdeg]
+  push_cast
+  ring
+
+theorem natDegree_norm_smul_basis_right {q : F[X]} (hq : q ≠ 0) :
+    ((Algebra.norm F[X] ((0 : F[X]) • (1 : W.CoordinateRing)
+        + q • CoordinateRing.mk W Y)).natDegree : ℤ) = 2 * q.natDegree + 3 := by
+  have hdeg := degree_norm_smul_basis (W' := W) 0 q
+  rw [Polynomial.degree_zero, show (2 : ℕ) • (⊥ : WithBot ℕ) = ⊥ by
+      rw [two_nsmul]; simp, max_eq_right bot_le, Polynomial.degree_eq_natDegree hq, two_nsmul,
+    ← Nat.cast_add, show ((3 : WithBot ℕ)) = ((3 : ℕ) : WithBot ℕ) from rfl,
+    ← Nat.cast_add] at hdeg
+  rw [Polynomial.natDegree_eq_of_degree_eq_some hdeg]
+  push_cast
+  ring
+
+theorem natDegree_norm_smul_basis_max {p q : F[X]} (hp : p ≠ 0) (hq : q ≠ 0) :
+    ((Algebra.norm F[X] (p • (1 : W.CoordinateRing)
+        + q • CoordinateRing.mk W Y)).natDegree : ℤ)
+      = max (2 * (p.natDegree : ℤ)) (2 * (q.natDegree : ℤ) + 3) := by
+  have hdeg := degree_norm_smul_basis (W' := W) p q
+  rw [Polynomial.degree_eq_natDegree hp, Polynomial.degree_eq_natDegree hq, two_nsmul,
+    two_nsmul, ← Nat.cast_add, ← Nat.cast_add,
+    show ((3 : WithBot ℕ)) = ((3 : ℕ) : WithBot ℕ) from rfl, ← Nat.cast_add] at hdeg
+  rcases le_total (q.natDegree + q.natDegree + 3) (p.natDegree + p.natDegree) with h | h
+  · rw [max_eq_left (by exact_mod_cast h)] at hdeg
+    rw [Polynomial.natDegree_eq_of_degree_eq_some hdeg]
+    push_cast
+    omega
+  · rw [max_eq_right (by exact_mod_cast h)] at hdeg
+    rw [Polynomial.natDegree_eq_of_degree_eq_some hdeg]
+    push_cast
+    omega
+
+variable (v : AlgebraicCurve.Place F W.FunctionField)
+
+theorem isFinitePlace_of_mem
+    (hx : polyToFunctionField W X ∈ v.toValuationSubring) : IsFinitePlace v := by
+  have hpoly : ∀ p : F[X], polyToFunctionField W p ∈ v.toValuationSubring := by
+    intro p
+    induction p using Polynomial.induction_on' with
+    | add f g hf hg => rw [map_add]; exact add_mem hf hg
+    | monomial n c =>
+        rw [← C_mul_X_pow_eq_monomial, map_mul, map_pow]
+        refine mul_mem ?_ (pow_mem hx n)
+        rw [polyToFunctionField_C]
+        exact v.algebraMap_mem' c
+  set η := algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) with hηdef
+  set c₁ : F[X] := C W.a₁ * X + C W.a₃ with hc₁def
+  set cb : F[X] := X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ with hcbdef
+  have hrel : η * η = polyToFunctionField W cb - polyToFunctionField W c₁ * η := by
+    have h1 := smul_basis_mul_Y (W' := W) 0 1
+    rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at h1
+    have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) h1
+    rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+    exact h2
+  have hy : η ∈ v.toValuationSubring := by
+    refine v.mem_of_eval_monic_eq_zero (P := Polynomial.X ^ 2
+      + (Polynomial.C (polyToFunctionField W c₁) * Polynomial.X
+        - Polynomial.C (polyToFunctionField W cb))) ?_ ?_ (x := η) ?_
+    · refine Polynomial.monic_X_pow_add (n := 2) ?_
+      rw [sub_eq_add_neg, ← Polynomial.C_neg]
+      refine lt_of_le_of_lt Polynomial.degree_linear_le ?_
+      exact_mod_cast Nat.one_lt_two
+    · intro i
+      rw [show (Polynomial.C (polyToFunctionField W c₁) * Polynomial.X : Polynomial _)
+          = Polynomial.C (polyToFunctionField W c₁) * Polynomial.X ^ 1 by ring]
+      simp only [Polynomial.coeff_add, Polynomial.coeff_sub, Polynomial.coeff_X_pow,
+        Polynomial.coeff_C_mul, Polynomial.coeff_C]
+      refine add_mem ?_ (sub_mem ?_ ?_)
+      · split <;> simp [v.toValuationSubring.one_mem, v.toValuationSubring.zero_mem]
+      · split
+        · rw [mul_one]; exact hpoly _
+        · rw [mul_zero]; exact v.toValuationSubring.zero_mem
+      · split
+        · exact hpoly _
+        · exact v.toValuationSubring.zero_mem
+    · simp only [Polynomial.eval_add, Polynomial.eval_sub, Polynomial.eval_pow,
+        Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_X]
+      rw [sq]
+      linear_combination hrel
+  intro r
+  obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq r
+  rw [algebraMap_smul_basis]
+  exact add_mem (hpoly p) (mul_mem (hpoly q) hy)
+
+theorem ord_X_neg_of_not_isFinitePlace (hv : ¬ IsFinitePlace v) :
+    v.ord (polyToFunctionField W X) < 0 := by
+  by_contra hcon
+  push Not at hcon
+  exact hv (isFinitePlace_of_mem v
+    (AlgebraicCurve.Place.mem_of_ord_nonneg v (polyToFunctionField_ne_zero Polynomial.X_ne_zero)
+      hcon))
+
+theorem two_mul_ord_Y_eq_three_mul_ord_X (hv : ¬ IsFinitePlace v) :
+    2 * v.ord (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y))
+      = 3 * v.ord (polyToFunctionField W X) := by
+  set η := algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) with hηdef
+  have hA : v.ord (polyToFunctionField W X) < 0 := ord_X_neg_of_not_isFinitePlace v hv
+  have hη0 : η ≠ 0 := Y_image_ne_zero
+  set c₁ : F[X] := C W.a₁ * X + C W.a₃ with hc₁def
+  set cb : F[X] := X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ with hcbdef
+  have hrel : η * η = polyToFunctionField W cb - polyToFunctionField W c₁ * η := by
+    have h1 := smul_basis_mul_Y (W' := W) 0 1
+    rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at h1
+    have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) h1
+    rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+    exact h2
+  have hrelL : (η + polyToFunctionField W c₁) * η = polyToFunctionField W cb := by
+    rw [add_mul]
+    linear_combination hrel
+  have hcbdeg : cb.natDegree = 3 := by
+    rw [hcbdef, ← one_mul (X ^ 3 : F[X]), ← C_1]
+    exact Polynomial.natDegree_cubic one_ne_zero
+  have hcb0 : cb ≠ 0 := by
+    intro h
+    rw [h, Polynomial.natDegree_zero] at hcbdeg
+    exact absurd hcbdeg (by norm_num)
+  have hcbord : v.ord (polyToFunctionField W cb) = 3 * v.ord (polyToFunctionField W X) := by
+    rw [v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA
+      hcb0, hcbdeg]
+    push_cast
+    ring
+  have hc₁ord : (1 : ℤ) * v.ord (polyToFunctionField W X)
+      ≤ v.ord (polyToFunctionField W c₁) := by
+    refine v.le_ord_ringHom_of_natDegree_le polyToFunctionField_injective polyToFunctionField_C
+      hA ?_
+    rw [hc₁def]
+    refine le_trans (Polynomial.natDegree_add_le _ _) ?_
+    simp only [Polynomial.natDegree_C, max_le_iff]
+    refine ⟨le_trans (Polynomial.natDegree_C_mul_le _ _) (by simp), by omega⟩
+  rw [one_mul] at hc₁ord
+  have hfac0 : η + polyToFunctionField W c₁ ≠ 0 := by
+    intro h
+    rw [h, zero_mul] at hrelL
+    exact polyToFunctionField_ne_zero hcb0 hrelL.symm
+  have hLHS : v.ord (η + polyToFunctionField W c₁) + v.ord η
+      = 3 * v.ord (polyToFunctionField W X) := by
+    rw [← hcbord, ← hrelL, v.ord_mul hfac0 hη0]
+  rcases eq_or_ne (polyToFunctionField W c₁) 0 with hc₁0 | hc₁0
+  · rw [hc₁0, add_zero] at hLHS
+    omega
+  · by_cases hBc : v.ord η = v.ord (polyToFunctionField W c₁)
+    · exfalso
+      have hmin : min (v.ord η) (v.ord (polyToFunctionField W c₁))
+          ≤ v.ord (η + polyToFunctionField W c₁) := v.min_ord_le_ord_add' hfac0
+      rw [← hBc, min_self] at hmin
+      have hBA : v.ord (polyToFunctionField W X) ≤ v.ord η := hBc ▸ hc₁ord
+      omega
+    · have hsum : v.ord (η + polyToFunctionField W c₁)
+          = min (v.ord η) (v.ord (polyToFunctionField W c₁)) :=
+        v.ord_add_eq_min hη0 hc₁0 hBc
+      rcases min_cases (v.ord η) (v.ord (polyToFunctionField W c₁)) with
+        ⟨hm, hle⟩ | ⟨hm, hlt⟩ <;> rw [hm] at hsum
+      · rw [hsum] at hLHS
+        omega
+      · exfalso
+        rw [hsum] at hLHS
+        omega
+
+private theorem ne_arith {A B s t : ℤ} (hA : A < 0) (hY : 2 * B = 3 * A) :
+    s * A ≠ t * A + B := by
+  intro hcon
+  have h4 : (2 * s - (2 * t + 3)) * A = 0 := by linear_combination 2 * hcon + hY
+  rcases mul_eq_zero.mp h4 with h5 | h5
+  · omega
+  · omega
+
+private theorem two_mul_min_arith {A B s t : ℤ} (hA : A < 0) (hY : 2 * B = 3 * A) :
+    2 * min (s * A) (t * A + B) = A * max (2 * s) (2 * t + 3) := by
+  rcases le_or_gt (2 * t + 3) (2 * s) with h | h
+  · rw [max_eq_left h, min_eq_left (by nlinarith)]
+    ring
+  · rw [max_eq_right h.le, min_eq_right (by nlinarith)]
+    linear_combination hY
+
+theorem two_mul_ord_eq_of_not_isFinitePlace (hv : ¬ IsFinitePlace v)
+    {f : W.CoordinateRing} (hf : f ≠ 0) :
+    2 * v.ord (algebraMap W.CoordinateRing W.FunctionField f)
+      = v.ord (polyToFunctionField W X) * ((Algebra.norm F[X] f).natDegree : ℤ) := by
+  have hA : v.ord (polyToFunctionField W X) < 0 := ord_X_neg_of_not_isFinitePlace v hv
+  have hη0 : algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) ≠ 0 :=
+    Y_image_ne_zero
+  have hYord := two_mul_ord_Y_eq_three_mul_ord_X v hv
+  obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq f
+  by_cases hq : q = 0
+  · subst hq
+    have hp : p ≠ 0 := fun h => hf (by rw [h, zero_smul, zero_smul, add_zero])
+    rw [natDegree_norm_smul_basis_left hp, algebraMap_smul_basis, _root_.map_zero, zero_mul,
+      add_zero,
+      v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA hp]
+    ring
+  · by_cases hp : p = 0
+    · subst hp
+      rw [natDegree_norm_smul_basis_right hq, algebraMap_smul_basis, _root_.map_zero, zero_add,
+        v.ord_mul (polyToFunctionField_ne_zero hq) hη0,
+        v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA hq]
+      linear_combination hYord
+    · rw [natDegree_norm_smul_basis_max hp hq, algebraMap_smul_basis]
+      have hordp : v.ord (polyToFunctionField W p)
+          = (p.natDegree : ℤ) * v.ord (polyToFunctionField W X) :=
+        v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA hp
+      have hordqy : v.ord (polyToFunctionField W q
+            * algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y))
+          = (q.natDegree : ℤ) * v.ord (polyToFunctionField W X)
+            + v.ord (algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)) := by
+        rw [v.ord_mul (polyToFunctionField_ne_zero hq) hη0,
+          v.ord_ringHom_eq_natDegree_mul polyToFunctionField_injective polyToFunctionField_C hA
+            hq]
+      have hne : v.ord (polyToFunctionField W p) ≠ v.ord (polyToFunctionField W q
+          * algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)) := by
+        rw [hordp, hordqy]
+        exact ne_arith hA hYord
+      have hqy0 : polyToFunctionField W q
+          * algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) ≠ 0 :=
+        mul_ne_zero (polyToFunctionField_ne_zero hq) hη0
+      rw [v.ord_add_eq_min (polyToFunctionField_ne_zero hp) hqy0 hne, hordp, hordqy]
+      exact two_mul_min_arith hA hYord
+
+theorem mem_iff_natDegree_norm_le (hv : ¬ IsFinitePlace v) {a b : W.CoordinateRing}
+    (ha : a ≠ 0) (hb : b ≠ 0) :
+    algebraMap W.CoordinateRing W.FunctionField a
+        / algebraMap W.CoordinateRing W.FunctionField b ∈ v.toValuationSubring
+      ↔ (Algebra.norm F[X] a).natDegree ≤ (Algebra.norm F[X] b).natDegree := by
+  have hA : v.ord (polyToFunctionField W X) < 0 := ord_X_neg_of_not_isFinitePlace v hv
+  have ha' : algebraMap W.CoordinateRing W.FunctionField a ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr ha
+  have hb' : algebraMap W.CoordinateRing W.FunctionField b ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr hb
+  have hdiv : algebraMap W.CoordinateRing W.FunctionField a
+      / algebraMap W.CoordinateRing W.FunctionField b ≠ 0 := div_ne_zero ha' hb'
+  rw [AlgebraicCurve.Place.mem_iff_ord_nonneg v hdiv, div_eq_mul_inv, v.ord_mul ha' (inv_ne_zero
+    hb'), v.ord_inv]
+  have h1 := two_mul_ord_eq_of_not_isFinitePlace v hv ha
+  have h2 := two_mul_ord_eq_of_not_isFinitePlace v hv hb
+  constructor
+  · intro h
+    nlinarith
+  · intro h
+    have h3 : ((Algebra.norm F[X] a).natDegree : ℤ) ≤ ((Algebra.norm F[X] b).natDegree : ℤ) := by
+      exact_mod_cast h
+    nlinarith
+
+theorem eq_of_not_isFinitePlace_of_not_isFinitePlace
+    {v w : AlgebraicCurve.Place F W.FunctionField}
+    (hv : ¬ IsFinitePlace v) (hw : ¬ IsFinitePlace w) : v = w := by
+  refine AlgebraicCurve.Place.ext ?_
+  ext z
+  rcases eq_or_ne z 0 with rfl | hz
+  · simp [v.toValuationSubring.zero_mem, w.toValuationSubring.zero_mem]
+  obtain ⟨a, b, hb, hzab⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb
+  have ha0 : a ≠ 0 := by
+    intro h
+    rw [h, _root_.map_zero, zero_div] at hzab
+    exact hz hzab.symm
+  rw [← hzab]
+  rw [mem_iff_natDegree_norm_le v hv ha0 hb0, mem_iff_natDegree_norm_le w hw ha0 hb0]
+
+theorem exists_smul_sub_natDegree_norm_lt {a b : W.CoordinateRing} (hb : b ≠ 0)
+    (hab : (Algebra.norm F[X] a).natDegree ≤ (Algebra.norm F[X] b).natDegree) :
+    ∃ c : F, a - c • b = 0 ∨
+      (Algebra.norm F[X] (a - c • b)).natDegree < (Algebra.norm F[X] b).natDegree := by
+  set n := (Algebra.norm F[X] b).natDegree with hndef
+  have hbn : b ∈ RRSpace W n :=
+    mem_RRSpace_iff_degree_norm_le.mpr (Polynomial.natDegree_le_iff_degree_le.mp le_rfl)
+  have han : a ∈ RRSpace W n :=
+    mem_RRSpace_iff_degree_norm_le.mpr (Polynomial.natDegree_le_iff_degree_le.mp hab)
+  rcases Nat.eq_zero_or_pos n with hn0 | hnpos
+  · rw [hn0] at hbn han
+    rw [RRSpace_zero] at hbn han
+    obtain ⟨α, hα⟩ := Submodule.mem_one.mp han
+    obtain ⟨β, hβ⟩ := Submodule.mem_one.mp hbn
+    have hβ0 : β ≠ 0 := by
+      rintro rfl
+      rw [_root_.map_zero] at hβ
+      exact hb hβ.symm
+    refine ⟨α / β, Or.inl ?_⟩
+    rw [← hα, ← hβ, Algebra.smul_def, ← map_mul, div_mul_cancel₀ _ hβ0, sub_self]
+  rcases eq_or_ne n 1 with hn1 | hn1
+  · exact absurd (hndef.symm.trans hn1) (natDegree_norm_ne_one b)
+  have hn2 : 2 ≤ n := by omega
+  have hn1' : 1 ≤ n - 1 := by omega
+  have : FiniteDimensional F (RRSpace W n) :=
+    Module.Finite.of_basis (RRSpace.finBasis W n (by omega))
+  have hbnot : b ∉ RRSpace W (n - 1) := by
+    intro hcon
+    rw [mem_RRSpace_iff_degree_norm_le, ← Polynomial.natDegree_le_iff_degree_le] at hcon
+    omega
+  have hsup : RRSpace W (n - 1) ⊔ Submodule.span F {b} = RRSpace W n := by
+    have hle : RRSpace W (n - 1) ⊔ Submodule.span F {b} ≤ RRSpace W n := by
+      refine sup_le (RRSpace_mono (by omega)) ?_
+      rw [Submodule.span_le, Set.singleton_subset_iff]
+      exact hbn
+    refine Submodule.eq_of_le_of_finrank_le hle ?_
+    have hlt : RRSpace W (n - 1) < RRSpace W (n - 1) ⊔ Submodule.span F {b} := by
+      refine lt_of_le_of_ne le_sup_left ?_
+      intro hcon
+      refine hbnot ?_
+      rw [hcon]
+      exact (le_sup_right (a := RRSpace W (n - 1))) (Submodule.mem_span_singleton_self b)
+    have : FiniteDimensional F (RRSpace W (n - 1) ⊔ Submodule.span F {b} : Submodule F _) :=
+      Submodule.finiteDimensional_of_le hle
+    have h1 := Submodule.finrank_lt_finrank_of_lt hlt
+    rw [RRSpace.finrank_eq (n - 1) hn1'] at h1
+    rw [RRSpace.finrank_eq n (by omega)]
+    omega
+  obtain ⟨ℓ, hℓ, z, hz, hsum⟩ := Submodule.mem_sup.mp (hsup ▸ han)
+  obtain ⟨c, rfl⟩ := Submodule.mem_span_singleton.mp hz
+  refine ⟨c, ?_⟩
+  have hldef : a - c • b = ℓ := by rw [← hsum]; ring
+  rcases eq_or_ne (a - c • b) 0 with h | h
+  · exact Or.inl h
+  · refine Or.inr ?_
+    have hc : (Algebra.norm F[X] (a - c • b)).natDegree ≤ n - 1 := by
+      rw [Polynomial.natDegree_le_iff_degree_le, ← mem_RRSpace_iff_degree_norm_le]
+      exact hldef ▸ hℓ
+    omega
+
+theorem deg_eq_one_of_not_isFinitePlace (hv : ¬ IsFinitePlace v) : v.deg = 1 := by
+  have hA : v.ord (polyToFunctionField W X) < 0 := ord_X_neg_of_not_isFinitePlace v hv
+  refine AlgebraicCurve.Place.deg_eq_one_of_surjective v ?_
+  intro z
+  obtain ⟨g, rfl⟩ := Ideal.Quotient.mk_surjective z
+  rcases eq_or_ne (g : W.FunctionField) 0 with hg0 | hg0
+  · refine ⟨0, ?_⟩
+    have hgz : g = 0 := Subtype.ext hg0
+    subst hgz
+    exact (_root_.map_zero _).trans (_root_.map_zero _).symm
+  obtain ⟨a, b, hb, hzab⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing)
+    (g : W.FunctionField)
+  have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb
+  have hbL0 : algebraMap W.CoordinateRing W.FunctionField b ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr hb0
+  have ha0 : a ≠ 0 := by
+    intro h
+    rw [h, _root_.map_zero, zero_div] at hzab
+    exact hg0 hzab.symm
+  have hmem : (g : W.FunctionField) ∈ v.toValuationSubring := g.2
+  rw [← hzab] at hmem
+  have hab := (mem_iff_natDegree_norm_le v hv ha0 hb0).mp hmem
+  obtain ⟨c, hc⟩ := exists_smul_sub_natDegree_norm_lt hb0 hab
+  refine ⟨c, ?_⟩
+  rw [IsScalarTower.algebraMap_apply F v.toValuationSubring v.ResidueField,
+    IsLocalRing.ResidueField.algebraMap_eq]
+  refine (Ideal.Quotient.eq (I := IsLocalRing.maximalIdeal v.toValuationSubring)).mpr ?_
+  have hcoe : ((algebraMap F v.toValuationSubring c : v.toValuationSubring) : W.FunctionField)
+      = algebraMap F W.FunctionField c := v.coe_algebraMap c
+  have hdiff : ((algebraMap F v.toValuationSubring c - g : v.toValuationSubring)
+      : W.FunctionField) = algebraMap W.CoordinateRing W.FunctionField (c • b - a)
+        / algebraMap W.CoordinateRing W.FunctionField b := by
+    have h0 : ((algebraMap F v.toValuationSubring c - g : v.toValuationSubring)
+        : W.FunctionField) = algebraMap F W.FunctionField c
+          - algebraMap W.CoordinateRing W.FunctionField a
+            / algebraMap W.CoordinateRing W.FunctionField b := by
+      push_cast
+      rw [hcoe, hzab]
+    rw [h0, map_sub, eq_div_iff hbL0, sub_mul, div_mul_cancel₀ _ hbL0, Algebra.smul_def,
+      map_mul, ← IsScalarTower.algebraMap_apply F W.CoordinateRing W.FunctionField]
+  rcases eq_or_ne (a - c • b) 0 with hzero | hzero
+  · have h1 : c • b - a = 0 := by rw [← neg_sub a (c • b), hzero, _root_.neg_zero]
+    have h2 : (algebraMap F v.toValuationSubring c - g : v.toValuationSubring)
+        = (0 : v.toValuationSubring) := by
+      ext
+      rw [hdiff, h1, _root_.map_zero, zero_div]
+      rfl
+    rw [h2]
+    exact (IsLocalRing.maximalIdeal v.toValuationSubring).zero_mem
+  · replace hc : (Algebra.norm F[X] (a - c • b)).natDegree
+        < (Algebra.norm F[X] b).natDegree := hc.resolve_left hzero
+    have hsub0 : c • b - a ≠ 0 := fun h =>
+      hzero (by rw [show a - c • b = -(c • b - a) by ring, h, _root_.neg_zero])
+    have hordswap : v.ord (algebraMap W.CoordinateRing W.FunctionField (c • b - a))
+        = v.ord (algebraMap W.CoordinateRing W.FunctionField (a - c • b)) := by
+      rw [show c • b - a = -(a - c • b) by ring, _root_.map_neg, v.ord_neg]
+    have hordpos : 0 < v.ord (((algebraMap F v.toValuationSubring c - g
+        : v.toValuationSubring)) : W.FunctionField) := by
+      rw [hdiff, div_eq_mul_inv, v.ord_mul ((map_ne_zero_iff _
+        (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr hsub0)
+        (inv_ne_zero hbL0), v.ord_inv, hordswap]
+      have h1 := two_mul_ord_eq_of_not_isFinitePlace v hv hzero
+      have h2 := two_mul_ord_eq_of_not_isFinitePlace v hv hb0
+      have h3 : ((Algebra.norm F[X] (a - c • b)).natDegree : ℤ)
+          < ((Algebra.norm F[X] b).natDegree : ℤ) := by exact_mod_cast hc
+      nlinarith
+    rcases eq_or_ne ((algebraMap F v.toValuationSubring c - g : v.toValuationSubring))
+        (0 : v.toValuationSubring) with hzero' | hzero'
+    · rw [hzero']
+      exact (IsLocalRing.maximalIdeal v.toValuationSubring).zero_mem
+    · have hzero'' : ((algebraMap F v.toValuationSubring c - g : v.toValuationSubring)
+          : W.FunctionField) ≠ 0 := fun h => hzero' (Subtype.ext h)
+      exact (v.mem_maximalIdeal_iff_ord_pos hzero''
+        (algebraMap F v.toValuationSubring c - g).2).mpr hordpos
+
+theorem exists_equation [IsAlgClosed F] (W : Affine F) (x₀ : F) :
+    ∃ y₀ : F, W.Equation x₀ y₀ := by
+  set P : F[X] := Polynomial.X ^ 2 + Polynomial.C (W.a₁ * x₀ + W.a₃) * Polynomial.X
+    - Polynomial.C (x₀ ^ 3 + W.a₂ * x₀ ^ 2 + W.a₄ * x₀ + W.a₆) with hPdef
+  have hPdeg : P.degree ≠ 0 := by
+    have hcoeff : P.coeff 2 = 1 := by
+      rw [hPdef]
+      simp only [Polynomial.coeff_sub, Polynomial.coeff_add, Polynomial.coeff_X_pow,
+        Polynomial.coeff_C_mul, Polynomial.coeff_X, Polynomial.coeff_C]
+      norm_num
+    intro hcon
+    have h2 : P.coeff 2 = 0 := by
+      refine Polynomial.coeff_eq_zero_of_degree_lt ?_
+      rw [hcon]
+      norm_num
+    rw [hcoeff] at h2
+    exact one_ne_zero h2
+  obtain ⟨y₀, hy₀⟩ := IsAlgClosed.exists_root P hPdeg
+  refine ⟨y₀, ?_⟩
+  rw [equation_iff]
+  have h3 : P.eval y₀ = 0 := hy₀
+  rw [hPdef] at h3
+  simp only [Polynomial.eval_sub, Polynomial.eval_add, Polynomial.eval_pow,
+    Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_X] at h3
+  linear_combination h3
+
+theorem exists_not_isFinitePlace [IsAlgClosed F] [IsDedekindDomain W.CoordinateRing]
+    [AlgebraicCurve.HasPrincipalDivisors F W.FunctionField] :
+    ∃ v : AlgebraicCurve.Place F W.FunctionField, ¬ IsFinitePlace v := by
+  by_contra hcon
+  push Not at hcon
+  obtain ⟨y₀, hy₀⟩ := exists_equation W 0
+  set v₀ : AlgebraicCurve.Place F W.FunctionField := placeOfEquation hy₀ with hv₀def
+  set r : W.CoordinateRing := CoordinateRing.mk W (C X) with hrdef
+  have hr0 : r ≠ 0 := by
+    rw [hrdef]
+    have h1 := XClass_ne_zero (W' := W) (0 : F)
+    rw [XClass] at h1
+    simpa using h1
+  have hrL0 : algebraMap W.CoordinateRing W.FunctionField r ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr hr0
+  have hrmem : r ∈ (heightOneSpectrumOfEquation hy₀).asIdeal := by
+    rw [heightOneSpectrumOfEquation_asIdeal]
+    have h1 : XClass W (0 : F) ∈ XYIdeal W (0 : F) (C y₀) :=
+      Ideal.subset_span (Set.mem_insert _ _)
+    have h2 : XClass W (0 : F) = r := by
+      rw [XClass, hrdef]
+      norm_num
+    exact h2 ▸ h1
+  have hordpos : 0 < v₀.ord (algebraMap W.CoordinateRing W.FunctionField r) := by
+    have h1 : v₀.ord (algebraMap W.CoordinateRing W.FunctionField r) ≠ 0 :=
+      (AlgebraicCurve.Place.ord_ofHeightOneSpectrum_ne_zero_iff
+        (heightOneSpectrumOfEquation hy₀) hr0).mpr hrmem
+    have h2 : 0 ≤ v₀.ord (algebraMap W.CoordinateRing W.FunctionField r) :=
+      AlgebraicCurve.Place.ord_nonneg_of_mem v₀ (isFinitePlace_placeOfEquation hy₀ r)
+    omega
+  obtain ⟨D, hD, hDdeg⟩ := AlgebraicCurve.HasPrincipalDivisors.exists_divisor
+    (K := F) (algebraMap W.CoordinateRing W.FunctionField r) hrL0
+  have hDnonneg : ∀ w : AlgebraicCurve.Place F W.FunctionField, 0 ≤ D w := by
+    intro w
+    rw [hD w]
+    exact AlgebraicCurve.Place.ord_nonneg_of_mem w (hcon w r)
+  have hDpos : 0 < AlgebraicCurve.Divisor.degree D := by
+    have hsum : AlgebraicCurve.Divisor.degree D = ∑ w ∈ D.support, D w * (w.deg : ℤ) := by
+      simp only [AlgebraicCurve.Divisor.degree, Finsupp.liftAddHom_apply,
+        AddMonoidHom.mulRight_apply, Finsupp.sum]
+    rw [hsum]
+    refine Finset.sum_pos' (fun w _ => mul_nonneg (hDnonneg w) (Int.natCast_nonneg _)) ?_
+    refine ⟨v₀, ?_, ?_⟩
+    · rw [Finsupp.mem_support_iff, hD v₀]
+      omega
+    · rw [hD v₀, deg_placeOfEquation hy₀]
+      omega
+  omega
+
+variable (W) in
+scoped instance instInfinitePlace [IsAlgClosed F] [IsDedekindDomain W.CoordinateRing]
+    [AlgebraicCurve.HasPrincipalDivisors F W.FunctionField] : InfinitePlace W where
+  place := (exists_not_isFinitePlace (W := W)).choose
+  not_isFinitePlace := (exists_not_isFinitePlace (W := W)).choose_spec
+  deg_eq_one := deg_eq_one_of_not_isFinitePlace _ (exists_not_isFinitePlace (W := W)).choose_spec
+  eq_of_not_isFinitePlace _v hv :=
+    eq_of_not_isFinitePlace_of_not_isFinitePlace hv
+      (exists_not_isFinitePlace (W := W)).choose_spec
+
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+noncomputable section
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~P\
+  lace.ord_algebraMap \
+  P2MW.S_OVERLONG_b3a5cd3d.AlgebraicCurve \
+  IsDedekindDomain FractionalIdeal \
+  P2MW.S_OVERLONG_b3a5cd3d.FractionalIdeal WithZero \
+  Polynomial"
+
+open scoped nonZeroDivisors Polynomial.Bivariate
+
+namespace FractionalIdeal
+p2m_export "FractionalIdeal" "mul_inv_cancel_iff_isUnit count_mul coeIdeal_span_singleton count \
+  zero_mem ext count_zpow map_eq_zero_iff count_well_defined mul coeIdeal_inj count_maximal map \
+  isPrincipal_iff count_one exists_eq_spanSingleton_mul coeIdeal_mul spanSingleton \
+  le_one_iff_exists_coeIdeal spanSingleton_ne_zero_iff num coeIdeal_top \
+  finprod_heightOneSpectrum_factorization"
+p2m_open "FractionalIdeal"
+
+variable {R : Type*} [CommRing R] [IsDedekindDomain R]
+variable {L : Type*} [Field L] [Algebra R L] [IsFractionRing R L]
+
+theorem count_spanSingleton (w : HeightOneSpectrum R) {f : L} (hf : f ≠ 0) :
+    count L w (spanSingleton R⁰ f) = -log (w.valuation L f) := by
+  classical
+  obtain ⟨n, d, rfl⟩ := IsLocalization.exists_mk'_eq R⁰ f
+  have hn : n ≠ 0 := by
+    rintro rfl
+    exact hf (IsLocalization.mk'_zero (M := R⁰) (S := L) d)
+  have hd : (d : R) ≠ 0 := nonZeroDivisors.ne_zero d.2
+  have hI : spanSingleton R⁰ (IsLocalization.mk' L n d) =
+      spanSingleton R⁰ ((algebraMap R L) (d : R))⁻¹ * ↑(Ideal.span {n} : Ideal R) := by
+    rw [coeIdeal_span_singleton, FractionalIdeal.spanSingleton_mul_spanSingleton]
+    congr 1
+    rw [IsFractionRing.mk'_eq_div, div_eq_mul_inv, mul_comm]
+  rw [count_well_defined L w (spanSingleton_ne_zero_iff.mpr hf) hI]
+  rw [HeightOneSpectrum.valuation_of_mk',
+    log_div (w.intValuation_ne_zero n hn) (w.intValuation_ne_zero (d : R) hd),
+    w.intValuation_if_neg hn, w.intValuation_if_neg hd, log_exp, log_exp]
+  ring
+
+theorem finprod_heightOneSpectrum_count {I : FractionalIdeal R⁰ L} (hI : I ≠ 0) :
+    (∏ᶠ w : HeightOneSpectrum R, (w.asIdeal : FractionalIdeal R⁰ L) ^ count L w I) = I := by
+  classical
+  obtain ⟨a, J, ha, haJ⟩ := exists_eq_spanSingleton_mul I
+  calc (∏ᶠ w : HeightOneSpectrum R, (w.asIdeal : FractionalIdeal R⁰ L) ^ count L w I)
+      = ∏ᶠ w : HeightOneSpectrum R, (w.asIdeal : FractionalIdeal R⁰ L) ^
+          ((Associates.mk w.asIdeal).count (Associates.mk J).factors -
+            (Associates.mk w.asIdeal).count (Associates.mk (Ideal.span {a})).factors : ℤ) :=
+        finprod_congr fun w => by rw [count_well_defined L w hI haJ]
+    _ = I := finprod_heightOneSpectrum_factorization hI haJ
+
+theorem eq_of_count_eq {I J : FractionalIdeal R⁰ L} (hI : I ≠ 0) (hJ : J ≠ 0)
+    (h : ∀ w : HeightOneSpectrum R, count L w I = count L w J) : I = J := by
+  rw [← finprod_heightOneSpectrum_count hI, ← finprod_heightOneSpectrum_count hJ]
+  exact finprod_congr fun w => by rw [h w]
+
+end FractionalIdeal
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Place Place.ext Place.adicValuation Place.ord Place.ord_zero Divisor \
+  Divisor.degree Divisor.degree_single Divisor.IsPrincipal HasPrincipalDivisors Pic Pic0 \
+  Pic0.torsion AbelJacobiCard Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring HasPrincipalDivisors.exists_divisor Place.ne_top' \
+  Place.ramificationIndex Place.restrict Place.ord_restrict Place.restrict_fiber_finite \
+  Place.ofHeightOneSpectrum_injective Place.ord_ofHeightOneSpectrum_ne_zero_iff \
+  Place.ord_eq_neg_log_of_valuationSubring_eq hasPrincipalDivisors_of_finiteDimensional_ratFunc"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "ext coe_algebraMap ResidueField deg adicValuation \
+  adicValuation_ne_zero ord ord_zero ord_mul ord_inv ord_zpow ord_unit_smul_zpow \
+  exists_unit_mul_zpow ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' \
+  algebraMap_mem' toValuationSubring mk ramificationIndex ramificationIndex_pos \
+  ramificationIndex_dvd_ord restrict ord_restrict ord_algebraMap_ne_zero_of_restrict_eq \
+  restrict_fiber_finite fiber ord_neg mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff \
+  ord_eq_neg_log_of_valuationSubring_eq"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg~ord_algebraMa\
+  p~comap_algebraMap_ne_top \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~Place.ord\
+  _algebraMap"
+
+variable {K : Type*} [Field K]
+variable {R : Type*} [CommRing R] [IsDedekindDomain R]
+variable {L : Type*} [Field L] [Algebra R L] [IsFractionRing R L]
+variable [Algebra K R] [Algebra K L] [IsScalarTower K R L]
+
+theorem ord_ofHeightOneSpectrum_eq_neg_log (w : HeightOneSpectrum R) {f : L} (hf : f ≠ 0) :
+    (ofHeightOneSpectrum (K := K) w).ord f = -log (w.valuation L f) := by
+  obtain ⟨π, hπ⟩ := w.intValuation_exists_uniformizer
+  have hval : w.valuation L (algebraMap R L π) = exp (-1 : ℤ) := by
+    rw [w.valuation_of_algebraMap]
+    exact hπ
+  exact AlgebraicCurve.Place.ord_eq_neg_log_of_valuationSubring_eq (ofHeightOneSpectrum (K := K) w)
+    (w.valuation L) rfl hval hf
+
+theorem ord_ofHeightOneSpectrum_eq_count (w : HeightOneSpectrum R) {f : L} (hf : f ≠ 0) :
+    (ofHeightOneSpectrum (K := K) w).ord f
+      = FractionalIdeal.count L w (FractionalIdeal.spanSingleton R⁰ f) := by
+  rw [ord_ofHeightOneSpectrum_eq_neg_log w hf, FractionalIdeal.count_spanSingleton w hf]
+
+end Place
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.Point.toClass a₃ a₁ map Affine.CoordinateRing coe_Δ' \
+  mk a₄ Jacobian a₂ a₆ reduction Affine.CoordinateRing.XYIdeal' IsIntegral Affine.Point Δ j Δ'"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation Point.toClass CoordinateRing.XYIdeal \
+  CoordinateRing.XYIdeal'_eq equation_iff_nonsingular_of_Δ_ne_zero CoordinateRing map Nonsingular \
+  CoordinateRing.XYIdeal' FunctionField Point CoordinateRing.mk Point.toClass_injective \
+  equation_iff polynomial"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] {W : Affine F}
+variable [IsAlgClosed F] [W.IsElliptic] [InfinitePlace W]
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_b3a5cd3d.WeierstrassCurve.Affine.Coordin\
+  ateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~Place.ord\
+  _algebraMap P2MW.S_OVERLONG_b3a5cd3d.AlgebraicCurve"
+
+omit [DecidableEq F] [InfinitePlace W] in
+theorem isFinitePlace_ofHeightOneSpectrum (w : HeightOneSpectrum W.CoordinateRing) :
+    IsFinitePlace (W := W)
+      (AlgebraicCurve.Place.ofHeightOneSpectrum (K := F) (F := W.FunctionField) w) := fun r =>
+  w.valuation_le_one r
+
+omit [DecidableEq F] in
+theorem infinitePlace_ne_ofHeightOneSpectrum (w : HeightOneSpectrum W.CoordinateRing) :
+    (InfinitePlace.place : AlgebraicCurve.Place F W.FunctionField)
+      ≠ AlgebraicCurve.Place.ofHeightOneSpectrum (K := F) w := fun h =>
+  InfinitePlace.not_isFinitePlace (W := W) (h ▸ isFinitePlace_ofHeightOneSpectrum w)
+
+def unitIdealOfPoint : W.Point → (FractionalIdeal W.CoordinateRing⁰ W.FunctionField)ˣ
+  | .zero => 1
+  | .some _ _ h => CoordinateRing.XYIdeal' h
+
+omit [DecidableEq F] [InfinitePlace W] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+@[scoped simp]
+theorem unitIdealOfPoint_zero : unitIdealOfPoint (.zero : W.Point) = 1 := rfl
+
+omit [DecidableEq F] [InfinitePlace W] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+@[scoped simp]
+theorem unitIdealOfPoint_some {x y : F} (h : W.Nonsingular x y) :
+    unitIdealOfPoint (.some x y h) = CoordinateRing.XYIdeal' h := rfl
+
+omit [InfinitePlace W] [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem classGroup_mk_unitIdealOfPoint (P : W.Point) :
+    ClassGroup.mk (K := W.FunctionField) (unitIdealOfPoint P) = Additive.toMul (Point.toClass P)
+      := by
+  cases P with
+  | zero => exact map_one _
+  | some x y h => rfl
+
+def unitIdealOfDivisor (D : AlgebraicCurve.Divisor F W.FunctionField) :
+    (FractionalIdeal W.CoordinateRing⁰ W.FunctionField)ˣ :=
+  D.prod fun v n => unitIdealOfPoint (geomPointEquivPlace.symm v) ^ n
+
+omit [DecidableEq F] in
+@[scoped simp]
+theorem unitIdealOfDivisor_zero :
+    unitIdealOfDivisor (0 : AlgebraicCurve.Divisor F W.FunctionField) = 1 :=
+  Finsupp.prod_zero_index
+
+omit [DecidableEq F] in
+theorem unitIdealOfDivisor_add (D E : AlgebraicCurve.Divisor F W.FunctionField) :
+    unitIdealOfDivisor (D + E) = unitIdealOfDivisor D * unitIdealOfDivisor E :=
+  Finsupp.prod_add_index' (fun _ => zpow_zero _) fun _ m n => _root_.zpow_add _ m n
+
+omit [DecidableEq F] in
+theorem unitIdealOfDivisor_single (v : AlgebraicCurve.Place F W.FunctionField) (n : ℤ) :
+    unitIdealOfDivisor (Finsupp.single v n) = unitIdealOfPoint (geomPointEquivPlace.symm v) ^ n :=
+  Finsupp.prod_single_index (zpow_zero _)
+
+theorem classGroup_mk_unitIdealOfDivisor (D : AlgebraicCurve.Divisor F W.FunctionField) :
+    ClassGroup.mk (K := W.FunctionField) (unitIdealOfDivisor D) = Additive.toMul (Point.toClass
+      (geomDivisorSum D)) := by
+  induction D using Finsupp.induction with
+  | zero =>
+      rw [unitIdealOfDivisor_zero, map_one, _root_.map_zero, _root_.map_zero]
+      rfl
+  | single_add v n E _ _ ih =>
+      rw [unitIdealOfDivisor_add, map_mul, ih, unitIdealOfDivisor_single, map_zpow,
+        classGroup_mk_unitIdealOfPoint, map_add, geomDivisorSum_single, map_add, toMul_add,
+        map_zsmul, toMul_zsmul]
+
+omit [DecidableEq F] in
+theorem count_unitIdealOfDivisor (D : AlgebraicCurve.Divisor F W.FunctionField)
+    (w : HeightOneSpectrum W.CoordinateRing) :
+    FractionalIdeal.count W.FunctionField w (unitIdealOfDivisor D : _) =
+      D (AlgebraicCurve.Place.ofHeightOneSpectrum (K := F) w) := by
+  classical
+  induction D using Finsupp.induction with
+  | zero =>
+      rw [unitIdealOfDivisor_zero, Units.val_one, FractionalIdeal.count_one]
+      rfl
+  | single_add v n E _ _ ih =>
+      rw [unitIdealOfDivisor_add, Units.val_mul,
+        FractionalIdeal.count_mul _ _ (Units.ne_zero _) (Units.ne_zero _), ih,
+        Finsupp.add_apply, unitIdealOfDivisor_single, Units.val_zpow_eq_zpow_val,
+        FractionalIdeal.count_zpow, Finsupp.single_apply]
+      congr 1
+      obtain ⟨P, rfl⟩ := geomPointEquivPlace.surjective v
+      rw [Equiv.symm_apply_apply]
+      cases P with
+      | zero =>
+          rw [unitIdealOfPoint_zero, Units.val_one, FractionalIdeal.count_one, mul_zero,
+            ite_eq_right]
+          exact infinitePlace_ne_ofHeightOneSpectrum w
+      | some x y h =>
+          rw [unitIdealOfPoint_some, CoordinateRing.XYIdeal'_eq,
+            show (CoordinateRing.XYIdeal W x (Polynomial.C y) :
+                FractionalIdeal W.CoordinateRing⁰ W.FunctionField)
+              = ((heightOneSpectrumOfEquation h.left).asIdeal :
+                FractionalIdeal W.CoordinateRing⁰ W.FunctionField) from rfl,
+            FractionalIdeal.count_maximal]
+          simp only [geomPointEquivPlace_apply, geomPlaceOfPoint_some, placeOfEquation,
+            (AlgebraicCurve.Place.ofHeightOneSpectrum_injective
+              (K := F) (R := W.CoordinateRing) (F := W.FunctionField)).eq_iff]
+          split_ifs <;> ring
+
+theorem geomDivisorSum_eq_zero_of_isPrincipal' {D : AlgebraicCurve.Divisor F W.FunctionField}
+    (hD : Divisor.IsPrincipal D) : geomDivisorSum D = 0 := by
+  obtain ⟨f, hf, hDf⟩ := hD
+  have key : (unitIdealOfDivisor D : FractionalIdeal W.CoordinateRing⁰ W.FunctionField)
+      = FractionalIdeal.spanSingleton W.CoordinateRing⁰ f :=
+    FractionalIdeal.eq_of_count_eq (Units.ne_zero _)
+      (FractionalIdeal.spanSingleton_ne_zero_iff.mpr hf) fun w => by
+        rw [count_unitIdealOfDivisor, hDf,
+          AlgebraicCurve.Place.ord_ofHeightOneSpectrum_eq_count w hf]
+  have hcls : ClassGroup.mk (K := W.FunctionField) (unitIdealOfDivisor D) = 1 :=
+    ClassGroup.mk_eq_one_iff.mpr ((FractionalIdeal.isPrincipal_iff _).mpr ⟨f, key⟩)
+  apply Point.toClass_injective
+  rw [_root_.map_zero]
+  rw [classGroup_mk_unitIdealOfDivisor] at hcls
+  exact Additive.toMul.injective hcls
+
+theorem isPrincipal_of_geomDivisorSum_eq_zero' [HasPrincipalDivisors F W.FunctionField]
+    {D : AlgebraicCurve.Divisor F W.FunctionField} (h0 : Divisor.degree D = 0)
+    (hD : geomDivisorSum D = 0) : Divisor.IsPrincipal D := by
+  classical
+  have hcls : ClassGroup.mk (K := W.FunctionField) (unitIdealOfDivisor D) = 1 := by
+    rw [classGroup_mk_unitIdealOfDivisor, hD, _root_.map_zero]
+    rfl
+  obtain ⟨f, hf⟩ := (FractionalIdeal.isPrincipal_iff _).mp (ClassGroup.mk_eq_one_iff.mp hcls)
+  have hf0 : f ≠ 0 := by
+    rintro rfl
+    rw [FractionalIdeal.spanSingleton_zero] at hf
+    exact Units.ne_zero (unitIdealOfDivisor D) hf
+  have hfin : ∀ w : HeightOneSpectrum W.CoordinateRing,
+      D (AlgebraicCurve.Place.ofHeightOneSpectrum (K := F) w)
+        = (AlgebraicCurve.Place.ofHeightOneSpectrum (K := F) w).ord f := by
+    intro w
+    rw [← count_unitIdealOfDivisor, hf,
+      AlgebraicCurve.Place.ord_ofHeightOneSpectrum_eq_count w hf0]
+  obtain ⟨Df, hDf, hDf0⟩ := HasPrincipalDivisors.exists_divisor (K := F) f hf0
+  have hsub : D - Df = Finsupp.single (InfinitePlace.place :
+      AlgebraicCurve.Place F W.FunctionField) ((D - Df) InfinitePlace.place) := by
+    ext v
+    obtain ⟨P, rfl⟩ := geomPlaceOfPoint_surjective isElliptic_Δ_ne_zero v
+    cases P with
+    | zero =>
+        rw [geomPlaceOfPoint_zero, Finsupp.single_eq_same]
+    | some x y h =>
+        rw [Finsupp.sub_apply, geomPlaceOfPoint_some, placeOfEquation, hfin, hDf, sub_self,
+          Finsupp.single_apply, ite_eq_right]
+        exact infinitePlace_ne_ofHeightOneSpectrum _
+  have hdeg : Divisor.degree (D - Df) = 0 := by rw [map_sub, h0, hDf0, sub_zero]
+  rw [hsub, Divisor.degree_single, InfinitePlace.deg_eq_one, Nat.cast_one, mul_one,
+    Finsupp.sub_apply, sub_eq_zero] at hdeg
+  refine ⟨f, hf0, fun v => ?_⟩
+  obtain ⟨P, rfl⟩ := geomPlaceOfPoint_surjective isElliptic_Δ_ne_zero v
+  cases P with
+  | zero => rw [geomPlaceOfPoint_zero, hdeg, hDf]
+  | some x y h => rw [geomPlaceOfPoint_some, placeOfEquation, hfin]
+
+scoped instance instAbelTheorem [HasPrincipalDivisors F W.FunctionField] : GeomAbelTheorem W where
+  isPrincipal_iff_geomDivisorSum_eq_zero _D h0 :=
+    ⟨geomDivisorSum_eq_zero_of_isPrincipal', isPrincipal_of_geomDivisorSum_eq_zero' h0⟩
+
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+noncomputable section
+
+open Polynomial
+
+open scoped Polynomial.Bivariate
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.Point.toClass a₃ a₁ map Affine.CoordinateRing coe_Δ' \
+  mk a₄ Jacobian a₂ a₆ reduction Affine.CoordinateRing.XYIdeal' IsIntegral Affine.Point Δ j Δ'"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation Point.toClass CoordinateRing.XYIdeal \
+  CoordinateRing.XYIdeal'_eq equation_iff_nonsingular_of_Δ_ne_zero CoordinateRing map Nonsingular \
+  CoordinateRing.XYIdeal' FunctionField Point CoordinateRing.mk Point.toClass_injective \
+  equation_iff polynomial"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_b3a5cd3d.WeierstrassCurve.Affine.Coordin\
+  ateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg~Place.ord\
+  _algebraMap P2MW.S_OVERLONG_b3a5cd3d.AlgebraicCurve"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem algebraMap_polynomial_eq_polyToFunctionField :
+    algebraMap F[X] W.FunctionField = polyToFunctionField W :=
+  IsScalarTower.algebraMap_eq F[X] W.CoordinateRing W.FunctionField
+
+theorem algebraMap_polynomial_injective :
+    Function.Injective (algebraMap F[X] W.FunctionField) := by
+  rw [algebraMap_polynomial_eq_polyToFunctionField]
+  exact polyToFunctionField_injective
+
+variable (W) in
+def ratFuncToFunctionField : RatFunc F →+* W.FunctionField :=
+  IsFractionRing.lift algebraMap_polynomial_injective
+
+@[scoped simp]
+theorem ratFuncToFunctionField_algebraMap (p : F[X]) :
+    ratFuncToFunctionField W (algebraMap F[X] (RatFunc F) p)
+      = algebraMap F[X] W.FunctionField p :=
+  IsFractionRing.lift_algebraMap algebraMap_polynomial_injective p
+
+scoped instance : Algebra (RatFunc F) W.FunctionField :=
+  (ratFuncToFunctionField W).toAlgebra
+
+scoped instance : IsScalarTower F[X] (RatFunc F) W.FunctionField :=
+  IsScalarTower.of_algebraMap_eq fun p => (ratFuncToFunctionField_algebraMap p).symm
+
+scoped instance : IsScalarTower F (RatFunc F) W.FunctionField := by
+  refine IsScalarTower.of_algebraMap_eq fun c => ?_
+  rw [IsScalarTower.algebraMap_apply F F[X] (RatFunc F) c,
+    ← IsScalarTower.algebraMap_apply F[X] (RatFunc F) W.FunctionField,
+    Polynomial.algebraMap_eq, algebraMap_polynomial_eq_polyToFunctionField]
+  exact (polyToFunctionField_C c).symm
+
+variable (W) in
+def yCoord : W.FunctionField :=
+  algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+
+variable (W) in
+def weierstrassQuadratic : Polynomial (RatFunc F) :=
+  X ^ 2 + (C (algebraMap F[X] (RatFunc F) (C W.a₁ * X + C W.a₃)) * X
+    - C (algebraMap F[X] (RatFunc F) (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆)))
+
+theorem weierstrassQuadratic_sub_degree_lt :
+    (C (algebraMap F[X] (RatFunc F) (C W.a₁ * X + C W.a₃)) * X
+      - C (algebraMap F[X] (RatFunc F)
+        (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆))).degree < ((2 : ℕ) : WithBot ℕ) := by
+  rw [sub_eq_add_neg, ← Polynomial.C_neg]
+  exact lt_of_le_of_lt Polynomial.degree_linear_le (by exact_mod_cast Nat.one_lt_two)
+
+theorem weierstrassQuadratic_monic : (weierstrassQuadratic W).Monic :=
+  monic_X_pow_add weierstrassQuadratic_sub_degree_lt
+
+theorem yCoord_relation :
+    yCoord W * yCoord W
+      = polyToFunctionField W (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆)
+        - polyToFunctionField W (C W.a₁ * X + C W.a₃) * yCoord W := by
+  have h1 := smul_basis_mul_Y (W' := W) 0 1
+  rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at h1
+  have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) h1
+  rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+  exact h2
+
+theorem aeval_yCoord_weierstrassQuadratic :
+    Polynomial.aeval (yCoord W) (weierstrassQuadratic W) = 0 := by
+  have hc : ∀ p : F[X],
+      algebraMap (RatFunc F) W.FunctionField (algebraMap F[X] (RatFunc F) p)
+        = polyToFunctionField W p := fun p => by
+    rw [← IsScalarTower.algebraMap_apply F[X] (RatFunc F) W.FunctionField,
+      algebraMap_polynomial_eq_polyToFunctionField]
+  simp only [weierstrassQuadratic, map_add, map_sub, map_mul, map_pow, Polynomial.aeval_X,
+    Polynomial.aeval_C, hc]
+  rw [sq]
+  have hrel := yCoord_relation (W := W)
+  simp only [map_add, map_mul, map_pow] at hrel ⊢
+  linear_combination hrel
+
+theorem isIntegral_yCoord : _root_.IsIntegral (RatFunc F) (yCoord W) :=
+  ⟨weierstrassQuadratic W, weierstrassQuadratic_monic, by
+    rw [← Polynomial.aeval_def]; exact aeval_yCoord_weierstrassQuadratic⟩
+
+theorem adjoin_yCoord_eq_top :
+    IntermediateField.adjoin (RatFunc F) {yCoord W} = ⊤ := by
+  rw [eq_top_iff]
+  rintro z -
+  have hpoly : ∀ p : F[X],
+      polyToFunctionField W p ∈ IntermediateField.adjoin (RatFunc F) {yCoord W} := by
+    intro p
+    rw [← algebraMap_polynomial_eq_polyToFunctionField,
+      IsScalarTower.algebraMap_apply F[X] (RatFunc F) W.FunctionField]
+    exact IntermediateField.algebraMap_mem _ _
+  have hcoord : ∀ r : W.CoordinateRing,
+      algebraMap W.CoordinateRing W.FunctionField r
+        ∈ IntermediateField.adjoin (RatFunc F) {yCoord W} := by
+    intro r
+    obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq r
+    rw [algebraMap_smul_basis]
+    exact add_mem (hpoly p)
+      (mul_mem (hpoly q) (IntermediateField.mem_adjoin_simple_self _ _))
+  obtain ⟨a, b, hb, hab⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  rw [← hab]
+  exact div_mem (hcoord a) (hcoord b)
+
+scoped instance : FiniteDimensional (RatFunc F) W.FunctionField := by
+  have h1 : FiniteDimensional (RatFunc F)
+      (IntermediateField.adjoin (RatFunc F) {yCoord W}) :=
+    IntermediateField.adjoin.finiteDimensional isIntegral_yCoord
+  rw [adjoin_yCoord_eq_top] at h1
+  exact (IntermediateField.topEquiv
+    (F := RatFunc F) (E := W.FunctionField)).toLinearEquiv.finiteDimensional
+
+end Affine
+end WeierstrassCurve
+end
+
+theorem solution
+    {F : Type*} [Field F] [CharZero F] (W : WeierstrassCurve.Affine F) :
+    AlgebraicCurve.HasPrincipalDivisors F W.FunctionField :=
+  AlgebraicCurve.hasPrincipalDivisors_of_finiteDimensional_ratFunc F W.FunctionField
+
+end
+end
+end
+end
+end
+end S_OVERLONG_b3a5cd3d
+end P2MW
+export P2MW.S_OVERLONG_b3a5cd3d (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.Affine.hasPrincipalDivisors_functionField
+    {F : Type*} [Field F] [CharZero F] (W : WeierstrassCurve.Affine F) :
+    AlgebraicCurve.HasPrincipalDivisors F W.FunctionField :=
+  solution W
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_of_isAlgClosed.lean
new file mode 100644
index 0000000000..e1d809dbd9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_of_isAlgClosed.lean
@@ -0,0 +1,457 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.hasPrincipalDivisors_of_isAlgClosed
+(01e9ef15-c33a-5810-9e0d-0e747a9fd8d7) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c5e1dbe7-1b9d-59b6-95e9-d5e40d4411aa
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_DivisorClassGroup
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_eq_neg_log_of_valuationSubring_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_natDegree_norm_eq_finsum_count
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_exists_eq_valuationSubring_of_X_mem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_deg_ofHeightOneSpectrum_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_infinitePlace_deg_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_exists_valuation_eq_exp_natDegree_norm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_eq_valuationSubring_of_X_not_mem
+
+/-!
+# Principal divisors have degree zero on an elliptic curve
+
+Theorem statement: `WeierstrassCurve.Affine.hasPrincipalDivisors_of_isAlgClosed`
+(`01e9ef15-c33a-5810-9e0d-0e747a9fd8d7`), by Claude, 2026-09-05.
+
+Proof: submission `c5e1dbe7-1b9d-59b6-95e9-d5e40d4411aa`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field and let $W$ be an affine Weierstrass curve over $F$ which
+is elliptic (i.e. satisfies `WeierstrassCurve.IsElliptic`). The assertion is that the function field
+$W$.`FunctionField`, viewed as an extension of $F$, satisfies the class
+[`AlgebraicCurve.HasPrincipalDivisors`](def/AlgebraicCurve_DivisorClassGroup.html#L217): for every
+$f$ in that function field with $f \neq 0$ there exists a finitely supported function $D$ from the
+places of $W$.`FunctionField` over $F$ to $\mathbb{Z}$ such that $D(v) = v.\mathrm{ord}(f)$ for
+*every* place $v$, and such that the degree of $D$, namely the sum $\sum_{v} D(v)\cdot \deg v$ over
+the (finite) support of $D$, is $0$. Here a place of $W$.`FunctionField` over $F$ is a valuation
+subring $O$ of the function field which contains the image of $F$ under the structure map, is not
+the whole field, and is a principal ideal ring, and $\mathrm{ord}$ and $\deg$ are the associated
+order and degree functions. Thus the statement packages two facts at once: a nonzero function has
+nonzero order at only finitely many places, and the resulting divisor has total degree zero.
+
+This is the degree-zero property of principal divisors on a genus-one curve, the divisor-theoretic
+input behind the group law and the Abel–Jacobi description of points. It is used in the construction
+of the place-theoretic gate for the Abel theorem on Weierstrass curves and in the analysis of
+torsion on Tate curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_hasPrincipalDivisors_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+noncomputable section
+
+open Polynomial WithZero IsDedekindDomain
+
+open scoped Polynomial.Bivariate nonZeroDivisors
+
+namespace D5S
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.CoordinateRing AlgebraicCurve
+
+universe u
+
+section Generic
+
+variable {R : Type*} [CommRing R] [IsDedekindDomain R]
+variable {L : Type*} [Field L] [Algebra R L] [IsFractionRing R L]
+
+theorem count_spanSingleton (w : HeightOneSpectrum R) {f : L} (hf : f ≠ 0) :
+    FractionalIdeal.count L w (FractionalIdeal.spanSingleton R⁰ f) = -log (w.valuation L f) := by
+  classical
+  obtain ⟨n, d, rfl⟩ := IsLocalization.exists_mk'_eq R⁰ f
+  have hn : n ≠ 0 := by
+    rintro rfl
+    exact hf (IsLocalization.mk'_zero (M := R⁰) (S := L) d)
+  have hd : (d : R) ≠ 0 := nonZeroDivisors.ne_zero d.2
+  have hI : FractionalIdeal.spanSingleton R⁰ (IsLocalization.mk' L n d) =
+      FractionalIdeal.spanSingleton R⁰ ((algebraMap R L) (d : R))⁻¹
+        * ↑(Ideal.span {n} : Ideal R) := by
+    rw [FractionalIdeal.coeIdeal_span_singleton, FractionalIdeal.spanSingleton_mul_spanSingleton]
+    congr 1
+    rw [IsFractionRing.mk'_eq_div, div_eq_mul_inv, mul_comm]
+  rw [FractionalIdeal.count_well_defined L w (FractionalIdeal.spanSingleton_ne_zero_iff.mpr hf) hI]
+  rw [HeightOneSpectrum.valuation_of_mk',
+    log_div (w.intValuation_ne_zero n hn) (w.intValuation_ne_zero (d : R) hd),
+    w.intValuation_if_neg hn, w.intValuation_if_neg hd, log_exp, log_exp]
+  ring
+
+variable {K : Type*} [Field K] [Algebra K R] [Algebra K L] [IsScalarTower K R L]
+
+theorem ord_ofHeightOneSpectrum_eq_count (w : HeightOneSpectrum R) {f : L} (hf : f ≠ 0) :
+    (Place.ofHeightOneSpectrum (K := K) w).ord f
+      = FractionalIdeal.count L w (FractionalIdeal.spanSingleton R⁰ f) := by
+  obtain ⟨π, hπ⟩ := w.valuation_exists_uniformizer L
+  rw [AlgebraicCurve.Place.ord_eq_neg_log_of_valuationSubring_eq
+      (Place.ofHeightOneSpectrum (K := K) w) (w.valuation L) rfl hπ hf,
+    count_spanSingleton w hf]
+
+theorem ofHeightOneSpectrum_injective :
+    Function.Injective (Place.ofHeightOneSpectrum (K := K) (F := L) (R := R)) := by
+  intro w w' h
+  refine HeightOneSpectrum.eq_of_valuation_isEquiv_valuation (K := L) ?_
+  rw [Valuation.isEquiv_iff_valuationSubring]
+  exact congrArg Place.toValuationSubring h
+
+theorem algebraMap_mem_ofHeightOneSpectrum (w : HeightOneSpectrum R) (r : R) :
+    algebraMap R L r ∈ (Place.ofHeightOneSpectrum (K := K) (F := L) w).toValuationSubring := by
+  rw [Place.ofHeightOneSpectrum_toValuationSubring, Valuation.mem_valuationSubring_iff]
+  exact w.valuation_le_one r
+
+end Generic
+
+variable {F : Type u} [Field F] {W : Affine F}
+
+theorem algebraMap_eq_mk_C_C (a : F) :
+    algebraMap F W.CoordinateRing a = mk W (C (C a)) := by
+  rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+    Algebra.algebraMap_self_apply]
+  rfl
+
+theorem algebraMap_poly_eq (p : F[X]) : algebraMap F[X] W.CoordinateRing p = mk W (C p) := by
+  rw [Algebra.algebraMap_eq_smul_one, smul, mul_one]
+
+variable (W) in
+def xF : W.FunctionField := algebraMap W.CoordinateRing W.FunctionField (mk W (C X))
+
+variable (W) in
+def yF : W.FunctionField := algebraMap W.CoordinateRing W.FunctionField (mk W Y)
+
+variable (W) in
+def infVal : Valuation W.FunctionField ℤᵐ⁰ :=
+  (WeierstrassCurve.Affine.FunctionField.exists_valuation_eq_exp_natDegree_norm W).choose
+
+theorem infVal_apply {f : W.CoordinateRing} (hf : f ≠ 0) :
+    infVal W (algebraMap W.CoordinateRing W.FunctionField f)
+      = exp ((Algebra.norm F[X] f).natDegree : ℤ) :=
+  (WeierstrassCurve.Affine.FunctionField.exists_valuation_eq_exp_natDegree_norm W).choose_spec
+    f hf
+
+theorem mk_C_X_ne_zero : (mk W (C X) : W.CoordinateRing) ≠ 0 := by
+  have h1 := XClass_ne_zero (W' := W) (0 : F)
+  rw [XClass, map_zero, sub_zero] at h1
+  exact h1
+
+theorem mk_Y_ne_zero : (mk W Y : W.CoordinateRing) ≠ 0 := by
+  have h1 := YClass_ne_zero (W' := W) (0 : F[X])
+  rw [YClass, map_zero, sub_zero] at h1
+  exact h1
+
+theorem natDegree_norm_mk_C_X :
+    (Algebra.norm F[X] (mk W (C X) : W.CoordinateRing)).natDegree = 2 := by
+  have hX : (X : F[X]) • (1 : W.CoordinateRing) + (0 : F[X]) • mk W Y = mk W (C X) := by
+    rw [zero_smul, add_zero, smul, mul_one]
+  have hdeg := degree_norm_smul_basis (W' := W) (X : F[X]) 0
+  rw [hX, degree_X, Polynomial.degree_zero, show (2 : ℕ) • (⊥ : WithBot ℕ) + 3 = ⊥ by
+      rw [two_nsmul]; simp, max_eq_left bot_le] at hdeg
+  exact Polynomial.natDegree_eq_of_degree_eq_some (n := 2) (by rw [hdeg]; rfl)
+
+theorem natDegree_norm_mk_Y :
+    (Algebra.norm F[X] (mk W Y : W.CoordinateRing)).natDegree = 3 := by
+  have hY : (0 : F[X]) • (1 : W.CoordinateRing) + (1 : F[X]) • mk W Y = mk W Y := by
+    rw [zero_smul, zero_add, one_smul]
+  have hdeg := degree_norm_smul_basis (W' := W) (0 : F[X]) 1
+  rw [hY, degree_one, Polynomial.degree_zero, show (2 : ℕ) • (⊥ : WithBot ℕ) = ⊥ by
+      rw [two_nsmul]; simp, max_eq_right bot_le] at hdeg
+  exact Polynomial.natDegree_eq_of_degree_eq_some (n := 3) (by rw [hdeg]; rfl)
+
+theorem infVal_xF : infVal W (xF W) = exp (2 : ℤ) := by
+  rw [xF, infVal_apply mk_C_X_ne_zero, natDegree_norm_mk_C_X]
+  rfl
+
+theorem infVal_yF : infVal W (yF W) = exp (3 : ℤ) := by
+  rw [yF, infVal_apply mk_Y_ne_zero, natDegree_norm_mk_Y]
+  rfl
+
+theorem infVal_xF_div_yF : infVal W (xF W / yF W) = exp (-1 : ℤ) := by
+  rw [map_div₀, infVal_xF, infVal_yF, ← exp_sub]
+  rfl
+
+theorem forall_mem_of_xF_mem (v : AlgebraicCurve.Place F W.FunctionField)
+    (hx : xF W ∈ v.toValuationSubring) :
+    ∀ r : W.CoordinateRing, algebraMap W.CoordinateRing W.FunctionField r ∈ v.toValuationSubring :=
+      by
+  set A := v.toValuationSubring with hA
+  set φ : F[X] →+* W.FunctionField :=
+    (algebraMap W.CoordinateRing W.FunctionField).comp (algebraMap F[X] W.CoordinateRing)
+    with hφ
+  have hφ_apply : ∀ p : F[X],
+      φ p = algebraMap W.CoordinateRing W.FunctionField (mk W (C p)) := fun p => by
+    rw [hφ, RingHom.comp_apply, algebraMap_poly_eq]
+  have hpoly : ∀ p : F[X], φ p ∈ A := by
+    intro p
+    induction p using Polynomial.induction_on' with
+    | add f g hf hg => rw [map_add]; exact add_mem hf hg
+    | monomial n c =>
+        rw [← C_mul_X_pow_eq_monomial, map_mul, map_pow]
+        refine mul_mem ?_ (pow_mem ?_ n)
+        · rw [hφ_apply, ← algebraMap_eq_mk_C_C,
+            ← IsScalarTower.algebraMap_apply F W.CoordinateRing W.FunctionField]
+          exact v.algebraMap_mem' c
+        · rw [hφ_apply]
+          exact hx
+  set η := algebraMap W.CoordinateRing W.FunctionField (mk W Y) with hηdef
+  set c₁ : F[X] := C W.a₁ * X + C W.a₃ with hc₁def
+  set cb : F[X] := X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ with hcbdef
+  have hsb : ∀ p q : F[X], algebraMap W.CoordinateRing W.FunctionField
+      (p • (1 : W.CoordinateRing) + q • mk W Y) = φ p + φ q * η := by
+    intro p q
+    rw [map_add, smul, mul_one, smul, map_mul, hφ_apply, hφ_apply]
+  have hrel : η * η = φ cb - φ c₁ * η := by
+    have h1 := smul_basis_mul_Y (W' := W) 0 1
+    rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at h1
+    have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) h1
+    rw [map_mul, hsb, map_neg, neg_mul, ← sub_eq_add_neg] at h2
+    exact h2
+  have hy : η ∈ A := by
+    by_contra hcon
+    have hgt : 1 < A.valuation η := lt_of_not_ge fun h => hcon ((A.valuation_le_one_iff η).mp h)
+    have hcb : A.valuation (φ cb) ≤ 1 := (A.valuation_le_one_iff _).mpr (hpoly cb)
+    have hc1 : A.valuation (φ c₁) ≤ 1 := (A.valuation_le_one_iff _).mpr (hpoly c₁)
+    have hle : A.valuation η * A.valuation η ≤ A.valuation η := by
+      calc A.valuation η * A.valuation η = A.valuation (φ cb - φ c₁ * η) := by
+            rw [← map_mul, hrel]
+        _ ≤ max (A.valuation (φ cb)) (A.valuation (φ c₁ * η)) := Valuation.map_sub _ _ _
+        _ ≤ max 1 (1 * A.valuation η) := by
+            refine max_le_max hcb ?_
+            rw [map_mul]
+            exact mul_le_mul_left hc1 _
+        _ = A.valuation η := by
+            rw [one_mul, max_eq_right hgt.le]
+    have hη0 : A.valuation η ≠ 0 := ne_of_gt (lt_trans zero_lt_one hgt)
+    have : A.valuation η ≤ 1 := by
+      calc A.valuation η = A.valuation η * A.valuation η * (A.valuation η)⁻¹ := by
+            rw [mul_assoc, mul_inv_cancel₀ hη0, mul_one]
+        _ ≤ A.valuation η * (A.valuation η)⁻¹ := mul_le_mul_left hle _
+        _ = 1 := mul_inv_cancel₀ hη0
+    exact absurd hgt (not_lt.mpr this)
+  intro r
+  obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq r
+  rw [hsb]
+  exact add_mem (hpoly p) (mul_mem (hpoly q) hy)
+
+variable (W) in
+def vInf : AlgebraicCurve.Place F W.FunctionField :=
+  (WeierstrassCurve.Affine.exists_infinitePlace_deg_eq_one W).choose
+
+theorem vInf_deg : (vInf W).deg = 1 :=
+  (WeierstrassCurve.Affine.exists_infinitePlace_deg_eq_one W).choose_spec.1
+
+theorem vInf_not_forall_mem :
+    ¬ ∀ r : W.CoordinateRing,
+      algebraMap W.CoordinateRing W.FunctionField r ∈ (vInf W).toValuationSubring :=
+  (WeierstrassCurve.Affine.exists_infinitePlace_deg_eq_one W).choose_spec.2.1
+
+theorem eq_vInf_of_not_forall_mem (v : AlgebraicCurve.Place F W.FunctionField)
+    (hv : ¬ ∀ r : W.CoordinateRing,
+      algebraMap W.CoordinateRing W.FunctionField r ∈ v.toValuationSubring) : v = vInf W :=
+  (WeierstrassCurve.Affine.exists_infinitePlace_deg_eq_one W).choose_spec.2.2 v hv
+
+theorem xF_notMem_vInf : xF W ∉ (vInf W).toValuationSubring :=
+  fun h => vInf_not_forall_mem (forall_mem_of_xF_mem (vInf W) h)
+
+theorem vInf_toValuationSubring :
+    (vInf W).toValuationSubring = (infVal W).valuationSubring :=
+  WeierstrassCurve.Affine.FunctionField.eq_valuationSubring_of_X_not_mem W
+    (vInf W).toValuationSubring (vInf W).algebraMap_mem' xF_notMem_vInf (infVal W)
+    (fun _ hf => infVal_apply hf)
+
+theorem vInf_ord {f : W.FunctionField} (hf : f ≠ 0) : (vInf W).ord f = -log (infVal W f) :=
+  AlgebraicCurve.Place.ord_eq_neg_log_of_valuationSubring_eq (vInf W) (infVal W)
+    vInf_toValuationSubring.symm infVal_xF_div_yF hf
+
+theorem vInf_ord_algebraMap {a : W.CoordinateRing} (ha : a ≠ 0) :
+    (vInf W).ord (algebraMap W.CoordinateRing W.FunctionField a)
+      = -((Algebra.norm F[X] a).natDegree : ℤ) := by
+  rw [vInf_ord ((map_ne_zero_iff _
+      (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr ha),
+    infVal_apply ha, log_exp]
+
+section Closed
+
+variable [IsAlgClosed F] [W.IsElliptic]
+
+scoped instance instIsDedekindDomainCoordinateRing : IsDedekindDomain W.CoordinateRing :=
+  WeierstrassCurve.Affine.CoordinateRing.isDedekindDomain W
+
+theorem exists_eq_ofHeightOneSpectrum_or_eq_vInf (v : AlgebraicCurve.Place F W.FunctionField) :
+    (∃ w : HeightOneSpectrum W.CoordinateRing,
+        v = Place.ofHeightOneSpectrum (K := F) (F := W.FunctionField) w) ∨ v = vInf W := by
+  by_cases hx : xF W ∈ v.toValuationSubring
+  · left
+    obtain ⟨w, hw⟩ :=
+      WeierstrassCurve.Affine.FunctionField.exists_eq_valuationSubring_of_X_mem W
+        v.toValuationSubring v.ne_top' v.algebraMap_mem' hx
+    exact ⟨w, AlgebraicCurve.Place.ext hw⟩
+  · right
+    exact eq_vInf_of_not_forall_mem v fun h => hx (h _)
+
+theorem vInf_ne_ofHeightOneSpectrum (w : HeightOneSpectrum W.CoordinateRing) :
+    vInf W ≠ Place.ofHeightOneSpectrum (K := F) (F := W.FunctionField) w := by
+  intro h
+  refine vInf_not_forall_mem (W := W) ?_
+  intro r
+  rw [h]
+  exact algebraMap_mem_ofHeightOneSpectrum w r
+
+def countFun (f : W.FunctionField) : HeightOneSpectrum W.CoordinateRing → ℤ :=
+  fun w => FractionalIdeal.count W.FunctionField w
+    (FractionalIdeal.spanSingleton W.CoordinateRing⁰ f)
+
+theorem countFun_finite (f : W.FunctionField) : (Function.support (countFun (W := W) f)).Finite :=
+  Filter.eventually_cofinite.mp (FractionalIdeal.finite_factors
+    (FractionalIdeal.spanSingleton W.CoordinateRing⁰ f))
+
+def countFinsupp (f : W.FunctionField) : HeightOneSpectrum W.CoordinateRing →₀ ℤ :=
+  Finsupp.ofSupportFinite (countFun f) (countFun_finite f)
+
+@[scoped simp] theorem countFinsupp_apply (f : W.FunctionField) (w : HeightOneSpectrum
+  W.CoordinateRing) :
+    countFinsupp f w = FractionalIdeal.count W.FunctionField w
+      (FractionalIdeal.spanSingleton W.CoordinateRing⁰ f) := rfl
+
+def ofHOSEmb : HeightOneSpectrum W.CoordinateRing ↪ AlgebraicCurve.Place F W.FunctionField :=
+  ⟨Place.ofHeightOneSpectrum (K := F) (F := W.FunctionField), ofHeightOneSpectrum_injective⟩
+
+@[scoped simp] theorem ofHOSEmb_apply (w : HeightOneSpectrum W.CoordinateRing) :
+    ofHOSEmb (W := W) w = Place.ofHeightOneSpectrum (K := F) (F := W.FunctionField) w := rfl
+
+def divOf (f : W.FunctionField) : Divisor F W.FunctionField :=
+  (countFinsupp f).embDomain ofHOSEmb + Finsupp.single (vInf W) ((vInf W).ord f)
+
+theorem divOf_ofHeightOneSpectrum (f : W.FunctionField) (w : HeightOneSpectrum W.CoordinateRing) :
+    divOf f (Place.ofHeightOneSpectrum (K := F) (F := W.FunctionField) w)
+      = FractionalIdeal.count W.FunctionField w
+          (FractionalIdeal.spanSingleton W.CoordinateRing⁰ f) := by
+  have h1 : ((countFinsupp f).embDomain (ofHOSEmb (W := W)))
+      (Place.ofHeightOneSpectrum (K := F) (F := W.FunctionField) w) = countFinsupp f w :=
+    Finsupp.embDomain_apply_self ofHOSEmb (countFinsupp f) w
+  have h2 : (Finsupp.single (vInf W) ((vInf W).ord f) : Divisor F W.FunctionField)
+      (Place.ofHeightOneSpectrum (K := F) (F := W.FunctionField) w) = 0 := by
+    classical
+    rw [Finsupp.single_apply, ite_eq_right (vInf_ne_ofHeightOneSpectrum w)]
+  change ((countFinsupp f).embDomain ofHOSEmb + Finsupp.single (vInf W) ((vInf W).ord f))
+    (Place.ofHeightOneSpectrum (K := F) (F := W.FunctionField) w) = _
+  rw [Finsupp.add_apply, h1, h2, add_zero, countFinsupp_apply]
+
+theorem divOf_vInf (f : W.FunctionField) : divOf f (vInf W) = (vInf W).ord f := by
+  rw [divOf, Finsupp.add_apply, Finsupp.embDomain_of_notMem_range, zero_add, Finsupp.single_eq_same]
+  rintro ⟨w, hw⟩
+  exact vInf_ne_ofHeightOneSpectrum w hw.symm
+
+theorem divOf_apply_eq_ord {f : W.FunctionField} (hf : f ≠ 0)
+    (v : AlgebraicCurve.Place F W.FunctionField) : divOf f v = v.ord f := by
+  rcases exists_eq_ofHeightOneSpectrum_or_eq_vInf v with ⟨w, rfl⟩ | rfl
+  · rw [divOf_ofHeightOneSpectrum, ord_ofHeightOneSpectrum_eq_count w hf]
+  · exact divOf_vInf f
+
+theorem degree_embDomain_countFinsupp (f : W.FunctionField) :
+    Divisor.degree ((countFinsupp f).embDomain (ofHOSEmb (W := W)))
+      = ∑ᶠ w : HeightOneSpectrum W.CoordinateRing, countFinsupp f w := by
+  rw [Divisor.degree, Finsupp.liftAddHom_apply, Finsupp.sum_embDomain]
+  simp only [ofHOSEmb_apply, AddMonoidHom.mulRight_apply,
+    WeierstrassCurve.Affine.deg_ofHeightOneSpectrum_eq_one W, Nat.cast_one, mul_one]
+  rw [finsum_eq_sum_of_support_subset (⇑(countFinsupp f))
+    (Finsupp.fun_support_eq (countFinsupp f)).subset]
+  rfl
+
+theorem count_div {a b : W.CoordinateRing} (ha : a ≠ 0) (hb : b ≠ 0)
+    (w : HeightOneSpectrum W.CoordinateRing) :
+    FractionalIdeal.count W.FunctionField w (FractionalIdeal.spanSingleton W.CoordinateRing⁰
+        (algebraMap W.CoordinateRing W.FunctionField a
+          / algebraMap W.CoordinateRing W.FunctionField b))
+      = FractionalIdeal.count W.FunctionField w (FractionalIdeal.spanSingleton W.CoordinateRing⁰
+          (algebraMap W.CoordinateRing W.FunctionField a))
+        - FractionalIdeal.count W.FunctionField w (FractionalIdeal.spanSingleton W.CoordinateRing⁰
+          (algebraMap W.CoordinateRing W.FunctionField b)) := by
+  have ha' : algebraMap W.CoordinateRing W.FunctionField a ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr ha
+  have hb' : algebraMap W.CoordinateRing W.FunctionField b ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr hb
+  rw [div_eq_mul_inv, ← FractionalIdeal.spanSingleton_mul_spanSingleton,
+    FractionalIdeal.count_mul W.FunctionField w
+      (FractionalIdeal.spanSingleton_ne_zero_iff.mpr ha')
+      (FractionalIdeal.spanSingleton_ne_zero_iff.mpr (inv_ne_zero hb')),
+    ← FractionalIdeal.spanSingleton_inv, FractionalIdeal.count_inv, sub_eq_add_neg]
+
+theorem degree_divOf {f : W.FunctionField} (hf : f ≠ 0) : Divisor.degree (divOf f) = 0 := by
+  obtain ⟨a, b, hb, rfl⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) f
+  have hb0 : b ≠ 0 := nonZeroDivisors.ne_zero hb
+  have ha0 : a ≠ 0 := by
+    rintro rfl
+    exact hf (by rw [map_zero, zero_div])
+  have ha' : algebraMap W.CoordinateRing W.FunctionField a ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr ha0
+  have hb' : algebraMap W.CoordinateRing W.FunctionField b ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr hb0
+  have hfa := countFun_finite (W := W) (algebraMap W.CoordinateRing W.FunctionField a)
+  have hfb := countFun_finite (W := W) (algebraMap W.CoordinateRing W.FunctionField b)
+  have h6a : ((Algebra.norm F[X] a).natDegree : ℤ)
+      = ∑ᶠ w : HeightOneSpectrum W.CoordinateRing,
+          countFun (W := W) (algebraMap W.CoordinateRing W.FunctionField a) w :=
+    WeierstrassCurve.Affine.CoordinateRing.natDegree_norm_eq_finsum_count W ha0
+  have h6b : ((Algebra.norm F[X] b).natDegree : ℤ)
+      = ∑ᶠ w : HeightOneSpectrum W.CoordinateRing,
+          countFun (W := W) (algebraMap W.CoordinateRing W.FunctionField b) w :=
+    WeierstrassCurve.Affine.CoordinateRing.natDegree_norm_eq_finsum_count W hb0
+  have hfin : ∑ᶠ w : HeightOneSpectrum W.CoordinateRing,
+      countFinsupp (algebraMap W.CoordinateRing W.FunctionField a
+          / algebraMap W.CoordinateRing W.FunctionField b) w
+      = ((Algebra.norm F[X] a).natDegree : ℤ) - ((Algebra.norm F[X] b).natDegree : ℤ) := by
+    rw [h6a, h6b, ← finsum_sub_distrib hfa hfb]
+    refine finsum_congr fun w => ?_
+    exact count_div ha0 hb0 w
+  have hinf : (vInf W).ord (algebraMap W.CoordinateRing W.FunctionField a
+      / algebraMap W.CoordinateRing W.FunctionField b)
+      = ((Algebra.norm F[X] b).natDegree : ℤ) - ((Algebra.norm F[X] a).natDegree : ℤ) := by
+    rw [div_eq_mul_inv, (vInf W).ord_mul ha' (inv_ne_zero hb'), (vInf W).ord_inv,
+      vInf_ord_algebraMap ha0, vInf_ord_algebraMap hb0]
+    ring
+  rw [divOf, map_add, degree_embDomain_countFinsupp, Divisor.degree_single, hfin, hinf, vInf_deg,
+    Nat.cast_one, mul_one]
+  ring
+
+theorem hasPrincipalDivisors_impl : AlgebraicCurve.HasPrincipalDivisors F W.FunctionField :=
+  ⟨fun f hf => ⟨divOf f, fun v => divOf_apply_eq_ord hf v, degree_divOf hf⟩⟩
+
+end Closed
+
+end D5S
+end
+
+theorem solution {F : Type*} [Field F] [IsAlgClosed F] (W : WeierstrassCurve.Affine F)
+    [W.IsElliptic] : AlgebraicCurve.HasPrincipalDivisors F W.FunctionField :=
+  D5S.hasPrincipalDivisors_impl
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.Affine.hasPrincipalDivisors_of_isAlgClosed {F : Type*} [Field F]
+    [IsAlgClosed F] (W : WeierstrassCurve.Affine F) [W.IsElliptic] :
+    AlgebraicCurve.HasPrincipalDivisors F W.FunctionField :=
+  solution W
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_isAddCyclic_ker_pointMapOfPushforward_of_algEquiv_conj.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_isAddCyclic_ker_pointMapOfPushforward_of_algEquiv_conj.lean
new file mode 100644
index 0000000000..43a2b01435
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_isAddCyclic_ker_pointMapOfPushforward_of_algEquiv_conj.lean
@@ -0,0 +1,1991 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.Affine.isAddCyclic_ker_pointMapOfPushforward_of_algEquiv_conj
+(8486e300-4d51-5173-820b-eb8a99a80e39) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6e56b01c-9c56-52e6-8c9b-7db76fb51146
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Basic.Complex.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.AlgebraicTopology.FundamentalGroupoid.SimplyConnected
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.Order.CompletePartialOrder
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FunctionFieldQuadratic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_inv
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_isUniformization_toPoint
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_natCard_ker_pointMapOfPushforward_eq_finrankAlong
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_discriminant_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_min_ord_le_ord_add_v2
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cyclic kernel and its order transport along function-field isomorphisms
+
+Theorem statement: `WeierstrassCurve.Affine.isAddCyclic_ker_pointMapOfPushforward_of_algEquiv_conj`
+(`8486e300-4d51-5173-820b-eb8a99a80e39`), by Claude, 2026-09-05.
+
+Proof: submission `6e56b01c-9c56-52e6-8c9b-7db76fb51146`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $E,E',D,D'$ be affine Weierstrass curves over $\mathbb{C}$, each elliptic and each carrying the
+three project structures: a `GenusOnePlaceGate` (a bijection between the group of points of the
+curve and the places of its function field over $\mathbb{C}$, all of which have degree $1$), its
+`IsCentred` refinement (at the place attached to a point $(x,y)$, the images in the function field
+of the coordinate-ring classes of $X-x$ and of $Y-y$ lie in the nonunits of the valuation subring),
+and `AbelTheorem` (a divisor of degree $0$ is principal exactly when its divisor sum vanishes). Let
+$\iota : \mathbb{C}(E') \to \mathbb{C}(E)$ be a $\mathbb{C}$-algebra map whose underlying ring
+homomorphism is integral, such that $\mathbb{C}(E)$ is a finite module over $\mathbb{C}(E')$ along
+$\iota$ and the pushforward norm formula holds along $\iota$: for every nonzero $f \in
+\mathbb{C}(E)$ and every divisor $D$ with $D(w) = \operatorname{ord}_w f$ for all places $w$ of
+$\mathbb{C}(E)$, the pushforward of $D$ satisfies $(\iota_* D)(v) = \operatorname{ord}_v(N(f))$ at
+every place $v$ of $\mathbb{C}(E')$. Let $e_E : \mathbb{C}(D) \simeq \mathbb{C}(E)$ and $e_{E'} :
+\mathbb{C}(D') \simeq \mathbb{C}(E')$ be $\mathbb{C}$-algebra isomorphisms, and let $\iota'' :
+\mathbb{C}(D') \to \mathbb{C}(D)$ be a $\mathbb{C}$-algebra map, again integral, finite and
+satisfying the norm formula, which makes the square commute: $e_E(\iota''(x)) = \iota(e_{E'}(x))$
+for all $x$. Here `pointMapOfPushforward` denotes the homomorphism of point groups obtained by
+transporting the pushforward map on degree-zero divisor classes through the isomorphisms between
+points and $\mathrm{Pic}^0$ supplied by the gates, so that $\iota$ gives a map $E(\mathbb{C}) \to
+E'(\mathbb{C})$ and $\iota''$ a map $D(\mathbb{C}) \to D'(\mathbb{C})$. Assuming the kernel of the
+map attached to $\iota$ is cyclic, the conclusion is that the kernel of the map attached to
+$\iota''$ is cyclic as well, and that the two kernels have the same cardinality.
+
+This is the transport statement saying that the cyclicity of the kernel of a pushforward point map,
+and the order of that kernel, depend only on the function-field data up to $\mathbb{C}$-algebra
+isomorphism of the source and target function fields. It feeds the step
+[`WeierstrassCurve.Affine.
+eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward`]
+(thm.html#WeierstrassCurve.Affine.
+eval_modularPolynomial_map_j_eq_zero_of_isAddCyclic_ker_pointMapOfPushforward),
+where a cyclic kernel of prescribed order between two complex elliptic curves is converted into the
+vanishing of the corresponding modular polynomial at the pair of $j$-invariants.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_isAddCyclic_ker_pointMapOfPushforward_of_algEquiv_conj.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_b277e395
+
+
+noncomputable section
+
+section
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ a₁ map mk a₄ a₂ a₆ Affine.Point.some \
+  Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ Affine.Point.neg_some \
+  baseChange j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing map baseChange Point.some \
+  Point.some.injEq Nonsingular FunctionField Point CoordinateRing.mk equation_iff_nonsingular \
+  polynomial Point.neg_some pointMapOfPushforward IsogenyEndDatum IsogenyEndDatum.pointEnd \
+  isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one deg_placeOfPoint \
+  pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal hasPrincipalDivisors_functionField \
+  natCard_ker_pointMapOfPushforward_eq_finrankAlong polyToFunctionField polyToFunctionField_C \
+  algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "Polynomial IsDedekindDomain WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_b277e395.Weierstrass\
+  Curve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_b277e395.AlgebraicCu\
+  rve"
+open scoped Polynomial.Bivariate
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem S13_ofHeightOneSpectrum_injective {R : Type*} [CommRing R] [IsDedekindDomain R]
+    [Algebra R W.FunctionField] [IsFractionRing R W.FunctionField] [Algebra F R]
+    [IsScalarTower F R W.FunctionField] :
+    Function.Injective (AlgebraicCurve.Place.ofHeightOneSpectrum (K := F) (R := R) (F :=
+      W.FunctionField)) := by
+  intro w₁ w₂ h
+  refine HeightOneSpectrum.eq_of_valuation_isEquiv_valuation (K := W.FunctionField) ?_
+  rw [Valuation.isEquiv_iff_valuationSubring]
+  exact congrArg AlgebraicCurve.Place.toValuationSubring h
+
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "XYIdeal quotientXYIdealEquiv YClass mk map \
+  exists_smul_basis_eq XClass smul_basis_mul_Y isDedekindDomain exists_eq_XYIdeal \
+  XYIdeal_isMaximal XYIdeal_ne_bot"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt"
+
+theorem algebraMap_eq_mk_C_C (a : F) :
+    algebraMap F W.CoordinateRing a = CoordinateRing.mk W (C (C a)) := by
+  rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+    Algebra.algebraMap_self_apply]
+  rfl
+
+theorem eq_of_XYIdeal_eq {x₁ y₁ x₂ y₂ : F} (h₂ : W.Equation x₂ y₂)
+    (h : XYIdeal W x₁ (C y₁) = XYIdeal W x₂ (C y₂)) : x₁ = x₂ ∧ y₁ = y₂ := by
+  have hne : XYIdeal W x₂ (C y₂) ≠ ⊤ := (XYIdeal_isMaximal h₂).ne_top
+  have hX₁ : XClass W x₁ ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert _ _)
+  have hX₂ : XClass W x₂ ∈ XYIdeal W x₂ (C y₂) := Ideal.subset_span (Set.mem_insert _ _)
+  have hY₁ : YClass W (C y₁) ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  have hY₂ : YClass W (C y₂) ∈ XYIdeal W x₂ (C y₂) :=
+    Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  constructor
+  · by_contra hx
+    apply hne
+    have hsub : XClass W x₁ - XClass W x₂ = algebraMap F W.CoordinateRing (x₂ - x₁) := by
+      rw [XClass, XClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      rw [← map_sub]
+      congr 1
+      rw [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hX₁ hX₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hx hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+  · by_contra hy
+    apply hne
+    have hsub : YClass W (C y₁) - YClass W (C y₂) = algebraMap F W.CoordinateRing (y₂ - y₁) := by
+      rw [YClass, YClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      simp only [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hY₁ hY₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hy hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+
+def heightOneSpectrumOfEquation {x y : F} (h : W.Equation x y) :
+    HeightOneSpectrum W.CoordinateRing where
+  asIdeal := XYIdeal W x (C y)
+  isPrime := (XYIdeal_isMaximal h).isPrime
+  ne_bot := XYIdeal_ne_bot x (C y)
+
+@[scoped simp]
+theorem heightOneSpectrumOfEquation_asIdeal {x y : F} (h : W.Equation x y) :
+    (heightOneSpectrumOfEquation h).asIdeal = XYIdeal W x (C y) := rfl
+
+theorem exists_sub_algebraMap_mem {x y : F} (h : W.Equation x y) (r : W.CoordinateRing) :
+    ∃ c : F, r - algebraMap F W.CoordinateRing c ∈ XYIdeal W x (C y) := by
+  set e := quotientXYIdealEquiv (W' := W) (x := x) (y := C y) h
+  refine ⟨e (Ideal.Quotient.mk _ r), ?_⟩
+  rw [← Ideal.Quotient.eq_zero_iff_mem, map_sub, sub_eq_zero]
+  apply e.injective
+  rw [← Ideal.Quotient.algebraMap_eq, ← IsScalarTower.algebraMap_apply, AlgEquiv.commutes,
+    Algebra.algebraMap_self_apply]
+
+end CoordinateRing
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_b277e395.Weierstrass\
+  Curve.Affine.CoordinateRing"
+
+def IsFinitePlace (v : AlgebraicCurve.Place F W.FunctionField) : Prop :=
+  ∀ r : W.CoordinateRing, algebraMap W.CoordinateRing W.FunctionField r ∈ v.toValuationSubring
+
+def IsFinitePlace.ringHom {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    W.CoordinateRing →+* v.toValuationSubring where
+  toFun r := ⟨algebraMap W.CoordinateRing W.FunctionField r, hv r⟩
+  map_one' := Subtype.ext (map_one _)
+  map_mul' a b := Subtype.ext (map_mul _ a b)
+  map_zero' := Subtype.ext (map_zero _)
+  map_add' a b := Subtype.ext (map_add _ a b)
+
+@[scoped simp]
+theorem IsFinitePlace.coe_ringHom_apply {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) (r : W.CoordinateRing) :
+    (hv.ringHom r : W.FunctionField) = algebraMap W.CoordinateRing W.FunctionField r := rfl
+
+
+def IsFinitePlace.centre {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    Ideal W.CoordinateRing :=
+  (IsLocalRing.maximalIdeal v.toValuationSubring).comap hv.ringHom
+
+theorem IsFinitePlace.centre_isPrime {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre.IsPrime :=
+  Ideal.IsPrime.comap _
+
+theorem IsFinitePlace.inv_mem {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) {r : W.CoordinateRing} (hr : r ∉ hv.centre) :
+    (algebraMap W.CoordinateRing W.FunctionField r)⁻¹ ∈ v.toValuationSubring := by
+  have hunit : IsUnit (hv.ringHom r) := by
+    rw [IsFinitePlace.centre, Ideal.mem_comap, IsLocalRing.mem_maximalIdeal,
+      mem_nonunits_iff, not_not] at hr
+    exact hr
+  obtain ⟨t, ht⟩ := hunit.exists_right_inv
+  have ht' : algebraMap W.CoordinateRing W.FunctionField r * (t : W.FunctionField) = 1 := by
+    have := congrArg (fun a : v.toValuationSubring => (a : W.FunctionField)) ht
+    simpa using this
+  rw [inv_eq_of_mul_eq_one_right ht']
+  exact t.2
+
+theorem IsFinitePlace.centre_ne_bot {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre ≠ ⊥ := by
+  intro hbot
+  apply v.ne_top'
+  rw [eq_top_iff]
+  rintro z -
+  obtain ⟨r, s, hs, hz⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  have hs0 : s ∉ hv.centre := by
+    rw [hbot, Ideal.mem_bot]
+    exact fun h => nonZeroDivisors.ne_zero hs h
+  rw [← hz, div_eq_mul_inv]
+  exact mul_mem (hv r) (hv.inv_mem hs0)
+
+variable [IsDedekindDomain W.CoordinateRing]
+
+def placeOfEquation {x y : F} (h : W.Equation x y) :
+    AlgebraicCurve.Place F W.FunctionField :=
+  AlgebraicCurve.Place.ofHeightOneSpectrum (heightOneSpectrumOfEquation h)
+
+theorem placeOfEquation_injective {x₁ y₁ x₂ y₂ : F} (h₁ : W.Equation x₁ y₁)
+    (h₂ : W.Equation x₂ y₂) (h : placeOfEquation h₁ = placeOfEquation h₂) :
+    x₁ = x₂ ∧ y₁ = y₂ :=
+  eq_of_XYIdeal_eq h₂
+    (congrArg HeightOneSpectrum.asIdeal (S13_ofHeightOneSpectrum_injective h))
+
+theorem isFinitePlace_placeOfEquation {x y : F} (h : W.Equation x y) :
+    IsFinitePlace (placeOfEquation h) := fun r =>
+  (heightOneSpectrumOfEquation h).valuation_le_one r
+
+theorem isFinitePlace_iff_exists_placeOfEquation [IsAlgClosed F]
+    (v : AlgebraicCurve.Place F W.FunctionField) :
+    IsFinitePlace v ↔ ∃ (x y : F) (h : W.Equation x y), v = placeOfEquation h := by
+  constructor
+  · intro hv
+    have := hv.centre_isPrime
+    have hmax : hv.centre.IsMaximal := Ideal.IsPrime.isMaximal hv.centre_isPrime hv.centre_ne_bot
+    obtain ⟨x, y, hxy, hXY⟩ :=
+      CoordinateRing.exists_eq_XYIdeal (W := W) (P := hv.centre) hv.centre_ne_bot
+    refine ⟨x, y, hxy, ?_⟩
+    set w : HeightOneSpectrum W.CoordinateRing := heightOneSpectrumOfEquation hxy with hw
+    set A : ValuationSubring W.FunctionField :=
+      HeightOneSpectrum.valuationSubringAtPrime W.FunctionField w with hA
+    have hAded : IsDedekindDomain A := by rw [hA]; infer_instance
+    have hle : A ≤ v.toValuationSubring := by
+      intro z hz
+      rw [hA] at hz
+      obtain ⟨r, s, hs, rfl⟩ := hz
+      have hs' : s ∉ hv.centre := by
+        intro hmem
+        rw [hXY] at hmem
+        exact hs hmem
+      exact mul_mem (hv r) (hv.inv_mem hs')
+    have hSP : A.ofPrime (A.idealOfLE v.toValuationSubring hle) = v.toValuationSubring :=
+      ValuationSubring.ofPrime_idealOfLE A v.toValuationSubring hle
+    rcases eq_or_ne (A.idealOfLE v.toValuationSubring hle) ⊥ with hP | hP
+    · exfalso
+      apply v.ne_top'
+      have h2 : A.ofPrime ⊥ ≤ A.ofPrime (A.idealOfLE v.toValuationSubring hle) :=
+        ValuationSubring.ofPrime_le_of_le (h := hP.le)
+      rw [ValuationSubring.ofPrime_bot] at h2
+      exact top_le_iff.mp (le_trans h2 hSP.le)
+    · have hPmax : (A.idealOfLE v.toValuationSubring hle).IsMaximal :=
+        Ideal.IsPrime.isMaximal inferInstance hP
+      have hPeq : A.idealOfLE v.toValuationSubring hle = IsLocalRing.maximalIdeal A :=
+        IsLocalRing.eq_maximalIdeal hPmax
+      have h3 : A.ofPrime (A.idealOfLE v.toValuationSubring hle)
+          = A.ofPrime (IsLocalRing.maximalIdeal A) :=
+        le_antisymm (ValuationSubring.ofPrime_le_of_le (h := hPeq.ge))
+          (ValuationSubring.ofPrime_le_of_le (h := hPeq.le))
+      rw [ValuationSubring.ofPrime_top] at h3
+      have hAv : A = v.toValuationSubring := h3.symm.trans hSP
+      refine (AlgebraicCurve.Place.ext ?_).symm
+      change (AlgebraicCurve.Place.ofHeightOneSpectrum w).toValuationSubring = v.toValuationSubring
+      rw [AlgebraicCurve.Place.ofHeightOneSpectrum_toValuationSubring,
+        ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact hAv
+  · rintro ⟨x, y, h, rfl⟩
+    exact isFinitePlace_placeOfEquation h
+
+scoped instance S13_instIsDedekindDomainCoordinateRing [IsAlgClosed F] [W.IsElliptic] :
+    IsDedekindDomain W.CoordinateRing :=
+  CoordinateRing.isDedekindDomain (W := W)
+
+section CentredGate
+
+variable [DecidableEq F] [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W]
+
+omit [DecidableEq F] in
+@[scoped simp]
+theorem placeOfPoint_some {x y : F} (h : W.Nonsingular x y) :
+    placeOfPoint (.some x y h) = placeOfEquation h.left := by
+  classical
+  exact
+    placeOfPoint_some_eq_ofHeightOneSpectrum h (heightOneSpectrumOfEquation h.left) rfl
+
+namespace InfinitePlace
+
+def place : AlgebraicCurve.Place F W.FunctionField := placeOfPoint (0 : W.Point)
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+private theorem _root_.WeierstrassCurve.Affine.InfinitePlace.deg_eq_one :
+    (place : AlgebraicCurve.Place F W.FunctionField).deg = 1 := by
+  classical
+  exact
+    deg_placeOfPoint (W := W) 0
+
+p2m_export "WeierstrassCurve.Affine.InfinitePlace" "deg_eq_one"
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] in
+theorem not_isFinitePlace [IsAlgClosed F] [W.IsElliptic] :
+    ¬ IsFinitePlace (place : AlgebraicCurve.Place F W.FunctionField) := by
+  classical
+  exact
+    fun h =>
+     algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero (W := W) (h _)
+
+omit [DecidableEq F] in
+theorem eq_of_not_isFinitePlace
+    (v : AlgebraicCurve.Place F W.FunctionField) (hv : ¬ IsFinitePlace v) :
+    v = place := by
+  classical
+  obtain ⟨P, rfl⟩ : ∃ P : W.Point, placeOfPoint P = v :=
+    ⟨(pointEquivPlace (W := W)).symm v, (pointEquivPlace (W := W)).apply_symm_apply v⟩
+  cases P with
+  | zero => rfl
+  | some x y h =>
+      exact absurd (placeOfPoint_some (W := W) h ▸ isFinitePlace_placeOfEquation h.left) hv
+
+end InfinitePlace
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+@[scoped simp]
+theorem placeOfPoint_zero : placeOfPoint (.zero : W.Point) = InfinitePlace.place := by
+  classical
+  exact
+    rfl
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_zero' : placeOfPoint (0 : W.Point) = InfinitePlace.place := by
+  classical
+  exact
+    rfl
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_injective : Function.Injective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).injective
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_surjective (_hΔ : W.Δ ≠ 0) : Function.Surjective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).surjective
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_surjective' : Function.Surjective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).surjective
+
+end CentredGate
+end Affine
+end WeierstrassCurve
+end
+
+section
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_b277e395.AlgebraicCu\
+  rve WeierstrassCurve \
+  P2MW.S_OVERLONG_b277e395.Weierstrass\
+  Curve"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ a₁ map mk a₄ a₂ a₆ Affine.Point.some \
+  Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ Affine.Point.neg_some \
+  baseChange j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing map baseChange Point.some \
+  Point.some.injEq Nonsingular FunctionField Point CoordinateRing.mk equation_iff_nonsingular \
+  polynomial Point.neg_some pointMapOfPushforward IsogenyEndDatum IsogenyEndDatum.pointEnd \
+  isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one deg_placeOfPoint \
+  pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal hasPrincipalDivisors_functionField \
+  natCard_ker_pointMapOfPushforward_eq_finrankAlong polyToFunctionField polyToFunctionField_C \
+  algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_b277e395.AlgebraicCu\
+  rve"
+
+scoped instance instHasPrincipalDivisorsFunctionField_s13 {F : Type*} [Field F] [CharZero F]
+    {W : Affine F} : HasPrincipalDivisors F W.FunctionField :=
+  hasPrincipalDivisors_functionField W
+
+section AutoNorm
+variable {F : Type*} [Field F] [CharZero F]
+variable {V W : Affine F} [V.IsElliptic] [W.IsElliptic]
+
+omit [WeierstrassCurve.IsElliptic V] [WeierstrassCurve.IsElliptic W] in
+theorem normFormulaAlong_of_elliptic (ι : V.FunctionField →ₐ[F] W.FunctionField)
+    (hfin : FiniteAlong F ι) : NormFormulaAlong F ι hfin := by
+  classical
+  have : HasPrincipalDivisors F W.FunctionField := hasPrincipalDivisors_functionField W
+  have : CharZero V.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap F V.FunctionField).injective
+  have hsep : SeparableAlong F ι := by
+    let := algebraAlong ι
+    have := isScalarTower_along ι
+    have : Module.Finite V.FunctionField W.FunctionField := hfin
+    change Algebra.IsSeparable V.FunctionField W.FunctionField
+    infer_instance
+  exact AlgebraicCurve.normFormulaAlong ι hfin hsep
+
+end AutoNorm
+
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι"
+p2m_open "WeierstrassCurve.Affine.IsogenyEndDatum"
+
+variable {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [GenusOnePlaceGate W] [AbelTheorem W]
+
+omit [DecidableEq F] [W.GenusOnePlaceGate] [W.AbelTheorem] in
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+private theorem _root_.WeierstrassCurve.Affine.IsogenyEndDatum.normFormulaAlong_auto (D :
+  IsogenyEndDatum W) :
+    NormFormulaAlong F D.ι D.hfin :=
+  normFormulaAlong_of_elliptic D.ι D.hfin
+
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "normFormulaAlong_auto"
+
+private def _root_.WeierstrassCurve.Affine.IsogenyEndDatum.pointEnd' (D : IsogenyEndDatum W) :
+    AddMonoid.End W.Point := D.pointEnd D.normFormulaAlong_auto
+
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd'"
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd_eq_pointEnd' (D : IsogenyEndDatum W) (hN : NormFormulaAlong F D.ι D.hfin) :
+    D.pointEnd hN = D.pointEnd' := rfl
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd'_apply (D : IsogenyEndDatum W) (P : W.Point) :
+    D.pointEnd' P = genusOnePic0Equiv W
+      (Pic0.pushforwardAlongHom D.ι D.hι D.hfin D.normFormulaAlong_auto (pointClass P)) :=
+  pointEnd_apply D _ P
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+private theorem _root_.WeierstrassCurve.Affine.IsogenyEndDatum.pointEnd'_eq_of_seam
+    (D : IsogenyEndDatum W) (g : W.Point → W.Point) (hg0 : g 0 = 0)
+    (hg : ∀ P, (placeOfPoint P).restrictAlong D.ι D.hι = placeOfPoint (g P)) (P : W.Point) :
+    D.pointEnd' P = g P :=
+  pointEnd_eq_of_seam D _ g hg0 hg P
+
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd'_eq_of_seam"
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+end
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ a₁ map Affine.CoordinateRing mk a₄ a₂ a₆ \
+  Affine.Point.some Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ \
+  Affine.Point.neg_some baseChange j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing map baseChange Point.some \
+  Point.some.injEq Nonsingular FunctionField Point CoordinateRing.mk equation_iff_nonsingular \
+  polynomial Point.neg_some pointMapOfPushforward IsogenyEndDatum IsogenyEndDatum.pointEnd \
+  isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one deg_placeOfPoint \
+  pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal hasPrincipalDivisors_functionField \
+  natCard_ker_pointMapOfPushforward_eq_finrankAlong polyToFunctionField polyToFunctionField_C \
+  algebraMap_smul_basis"
+end Affine
+end WeierstrassCurve
+p2m_open_scoped "WeierstrassCurve WeierstrassCurve.Affine" in
+scoped instance WeierstrassCurve.Affine.instHasPrincipalDivisorsFunctionField_s13e2
+    {F : Type*} [Field F] [CharZero F] (W : WeierstrassCurve.Affine F) :
+    AlgebraicCurve.HasPrincipalDivisors F W.FunctionField :=
+  WeierstrassCurve.Affine.hasPrincipalDivisors_functionField W
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong \
+  isScalarTower_along isIntegral_along FiniteAlong NormFormulaAlong finrankAlong \
+  Divisor.pushforwardAlong Divisor.pushforwardAlong_single SeparableAlong Place.restrictInclusion \
+  Place Place.ext Divisor HasPrincipalDivisors Pic Pic0 Pic0.mk Pic0.mk_surjective \
+  Place.ofHeightOneSpectrum Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective normFormulaAlong Divisor.pushforwardAlong_pushforwardAlong'"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong inertiaDegAlong restrictInclusion ext \
+  ResidueField deg adicValuation adicValuation_ne_zero ord ord_inv ord_unit_smul_zpow \
+  exists_unit_mul_zpow ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' \
+  algebraMap_mem' toValuationSubring mk mem_of_eval_monic_eq_zero IsRational evalAt \
+  ofHeightOneSpectrum_injective evalAt_mul evalAt_inv"
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong \
+  isScalarTower_along isIntegral_along FiniteAlong NormFormulaAlong finrankAlong \
+  Divisor.pushforwardAlong Divisor.pushforwardAlong_single SeparableAlong Place.restrictInclusion \
+  Place Place.ext Divisor HasPrincipalDivisors Pic Pic0 Pic0.mk Pic0.mk_surjective \
+  Place.ofHeightOneSpectrum Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective normFormulaAlong Divisor.pushforwardAlong_pushforwardAlong'"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong inertiaDegAlong restrictInclusion ext \
+  ResidueField deg adicValuation adicValuation_ne_zero ord ord_inv ord_unit_smul_zpow \
+  exists_unit_mul_zpow ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' \
+  algebraMap_mem' toValuationSubring mk mem_of_eval_monic_eq_zero IsRational evalAt \
+  ofHeightOneSpectrum_injective evalAt_mul evalAt_inv"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg"
+
+section MoreSinglePlace
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.isRational_of_deg_eq_one (h : v.deg = 1) :
+    v.IsRational := by
+  intro x
+  have hbot : (⊥ : Subalgebra K v.ResidueField) = ⊤ :=
+    Subalgebra.bot_eq_top_iff_finrank_eq_one.mpr h
+  have hx : x ∈ (⊥ : Subalgebra K v.ResidueField) := by
+    rw [hbot]
+    exact Algebra.mem_top
+  exact Algebra.mem_bot.mp hx
+
+p2m_export "AlgebraicCurve.Place" "isRational_of_deg_eq_one"
+
+theorem evalAt_div (hv : v.IsRational) {f g : F} (hf : f ∈ v.toValuationSubring)
+    (hg : g ≠ 0) (hg0 : v.ord g = 0) :
+    v.evalAt (f / g) = v.evalAt f / v.evalAt g := by
+  have hginv : g⁻¹ ∈ v.toValuationSubring :=
+    AlgebraicCurve.Place.mem_of_ord_nonneg v (inv_ne_zero hg) (by
+      rw [v.ord_inv, hg0]; exact neg_nonneg.mpr le_rfl)
+  rw [div_eq_mul_inv, v.evalAt_mul hv hf hginv, v.evalAt_inv hv hg hg0, div_eq_mul_inv]
+
+end MoreSinglePlace
+
+theorem mem_restrictAlong_iff {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F]
+    [Algebra K F']
+    (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') (f : F) :
+    f ∈ (w.restrictAlong φ hφ).toValuationSubring ↔ φ f ∈ w.toValuationSubring :=
+  Iff.rfl
+
+end Place
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ a₁ map mk a₄ a₂ a₆ Affine.Point.some \
+  Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ Affine.Point.neg_some \
+  baseChange j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing map baseChange Point.some \
+  Point.some.injEq Nonsingular FunctionField Point CoordinateRing.mk equation_iff_nonsingular \
+  polynomial Point.neg_some pointMapOfPushforward IsogenyEndDatum IsogenyEndDatum.pointEnd \
+  isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one deg_placeOfPoint \
+  pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal hasPrincipalDivisors_functionField \
+  natCard_ker_pointMapOfPushforward_eq_finrankAlong polyToFunctionField polyToFunctionField_C \
+  algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_b277e395.Weierstrass\
+  Curve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_b277e395.AlgebraicCu\
+  rve Polynomial"
+open scoped Polynomial.Bivariate
+
+section FinitePlaceOfMem
+variable {F : Type*} [Field F] {W : Affine F}
+variable (v : AlgebraicCurve.Place F W.FunctionField)
+
+theorem isFinitePlace_of_mem
+    (hx : polyToFunctionField W X ∈ v.toValuationSubring) : IsFinitePlace v := by
+  have hpoly : ∀ p : F[X], polyToFunctionField W p ∈ v.toValuationSubring := by
+    intro p
+    induction p using Polynomial.induction_on' with
+    | add f g hf hg => rw [map_add]; exact add_mem hf hg
+    | monomial n c =>
+        rw [← C_mul_X_pow_eq_monomial, map_mul, map_pow]
+        refine mul_mem ?_ (pow_mem hx n)
+        rw [polyToFunctionField_C]
+        exact v.algebraMap_mem' c
+  set η := algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) with hηdef
+  set c₁ : F[X] := C W.a₁ * X + C W.a₃ with hc₁def
+  set cb : F[X] := X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ with hcbdef
+  have hrel : η * η = polyToFunctionField W cb - polyToFunctionField W c₁ * η := by
+    have h1 := smul_basis_mul_Y (W' := W) 0 1
+    rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at h1
+    have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) h1
+    rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+    exact h2
+  have hy : η ∈ v.toValuationSubring := by
+    refine v.mem_of_eval_monic_eq_zero (P := Polynomial.X ^ 2
+      + (Polynomial.C (polyToFunctionField W c₁) * Polynomial.X
+        - Polynomial.C (polyToFunctionField W cb))) ?_ ?_ (x := η) ?_
+    · refine Polynomial.monic_X_pow_add (n := 2) ?_
+      rw [sub_eq_add_neg, ← Polynomial.C_neg]
+      refine lt_of_le_of_lt Polynomial.degree_linear_le ?_
+      exact_mod_cast Nat.one_lt_two
+    · intro i
+      rw [show (Polynomial.C (polyToFunctionField W c₁) * Polynomial.X : Polynomial _)
+          = Polynomial.C (polyToFunctionField W c₁) * Polynomial.X ^ 1 by ring]
+      simp only [Polynomial.coeff_add, Polynomial.coeff_sub, Polynomial.coeff_X_pow,
+        Polynomial.coeff_C_mul, Polynomial.coeff_C]
+      refine add_mem ?_ (sub_mem ?_ ?_)
+      · split <;> simp [v.toValuationSubring.one_mem, v.toValuationSubring.zero_mem]
+      · split
+        · rw [mul_one]; exact hpoly _
+        · rw [mul_zero]; exact v.toValuationSubring.zero_mem
+      · split
+        · exact hpoly _
+        · exact v.toValuationSubring.zero_mem
+    · simp only [Polynomial.eval_add, Polynomial.eval_sub, Polynomial.eval_pow,
+        Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_X]
+      rw [sq]
+      linear_combination hrel
+  intro r
+  obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq r
+  rw [algebraMap_smul_basis]
+  exact add_mem (hpoly p) (mul_mem (hpoly q) hy)
+
+end FinitePlaceOfMem
+
+section RationalPlaceOfEquation
+variable {F : Type*} [Field F] {W : Affine F} [W.IsElliptic]
+  [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [IsDedekindDomain W.CoordinateRing]
+
+theorem isRational_placeOfEquation {r s : F} (hrs : W.Equation r s) :
+    (placeOfEquation hrs).IsRational := by
+  classical
+  apply (placeOfEquation hrs).isRational_of_deg_eq_one
+  rw [← placeOfPoint_some (equation_iff_nonsingular.mp hrs)]
+  exact GenusOnePlaceGate.deg_eq_one _
+
+end RationalPlaceOfEquation
+end Affine
+end WeierstrassCurve
+
+namespace ModularCurve
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg\
+  " in
+open _root_.WeierstrassCurve
+  _root_.P2MW.S_OVERLONG_b277e395.WeierstrassCurve
+  _root_.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_b277e395.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_b277e395.AlgebraicCurve
+  in
+theorem kw_fdn2_qephod_hend7_pmopKerCard_proved
+    (K : Type*) [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+    (E E' : WeierstrassCurve.Affine K) [E.IsElliptic]
+    [GenusOnePlaceGate E] [GenusOnePlaceGate.IsCentred E] [AbelTheorem E]
+    [E'.IsElliptic] [GenusOnePlaceGate E'] [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong K ι) :
+    Nat.card ((pointMapOfPushforward ι hι hfin
+      (normFormulaAlong_of_elliptic ι hfin)).ker) = finrankAlong K ι :=
+  natCard_ker_pointMapOfPushforward_eq_finrankAlong E E' ι hι hfin _
+end ModularCurve
+
+
+section
+open Complex Filter Set
+
+p2m_open_scoped "PeriodPair \
+  P2MW.S_OVERLONG_b277e395.PeriodPair"
+
+namespace PeriodPair
+p2m_export "PeriodPair" "derivWeierstrassP_neg weierstrassP_neg lattice weierstrassP_add_coe \
+  lattice_eq_span_range_basis ω₁ mk g₃ ω₂ derivWeierstrassP_add_coe mem_lattice G g₂ \
+  weierstrassCurve weierstrassCurve_a₁ weierstrassCurve_a₃ DiscriminantNeZero toPoint \
+  toPoint_of_mem toPoint_zero toPoint_of_notMem IsUniformization jLattice scale_indep scale \
+  discriminant_ne_zero isUniformization_toPoint"
+p2m_open "PeriodPair"
+
+variable (L : PeriodPair)
+
+private theorem _root_.PeriodPair.kw_discriminantNeZero :
+    L.DiscriminantNeZero := L.discriminant_ne_zero
+
+p2m_export "PeriodPair" "kw_discriminantNeZero"
+
+private theorem _root_.PeriodPair.kw_isUniformization :
+    L.IsUniformization L.kw_discriminantNeZero :=
+  L.isUniformization_toPoint _
+
+p2m_export "PeriodPair" "kw_isUniformization"
+
+private theorem _root_.PeriodPair.kw_toPoint_add (hD : L.DiscriminantNeZero) (z w : ℂ) :
+    L.toPoint hD (z + w) = L.toPoint hD z + L.toPoint hD w :=
+  (L.isUniformization_toPoint hD).1 z w
+
+p2m_export "PeriodPair" "kw_toPoint_add"
+
+theorem kw_toPoint_surjective (hD : L.DiscriminantNeZero) : Function.Surjective (L.toPoint hD) :=
+  (L.isUniformization_toPoint hD).2.1
+
+theorem kw_toPoint_eq_zero_iff (hD : L.DiscriminantNeZero) (z : ℂ) :
+    L.toPoint hD z = 0 ↔ z ∈ L.lattice :=
+  ⟨(L.isUniformization_toPoint hD).2.2 z, fun hz => L.toPoint_of_mem hD hz⟩
+
+scoped instance kw_instIsElliptic : L.weierstrassCurve.IsElliptic :=
+  ⟨isUnit_iff_ne_zero.mpr L.kw_discriminantNeZero.weierstrassCurve_Δ_ne_zero⟩
+
+section Liouville
+
+private theorem _root_.PeriodPair.sub_fract_mem_lattice (z : ℂ) :
+    z - ZSpan.fract L.basis z ∈ L.lattice := by
+  rw [L.lattice_eq_span_range_basis]
+  have h := (ZSpan.fract_eq_fract L.basis (ZSpan.fract L.basis z) z).mp
+    (by rw [ZSpan.fract_eq_self.mpr (ZSpan.fract_mem_fundamentalDomain L.basis z)])
+  simpa [neg_add_eq_sub] using h
+
+p2m_export "PeriodPair" "sub_fract_mem_lattice"
+
+private theorem _root_.PeriodPair.apply_eq_apply_of_differentiable_of_forall_periodic {f : ℂ → ℂ}
+    (hf : Differentiable ℂ f) (hper : ∀ l ∈ L.lattice, ∀ z, f (z + l) = f z) (z w : ℂ) :
+    f z = f w := by
+  apply hf.apply_eq_apply_of_bounded
+  have hrange : range f ⊆ f '' closure (ZSpan.fundamentalDomain L.basis) := by
+    rintro - ⟨u, rfl⟩
+    refine ⟨ZSpan.fract L.basis u, subset_closure (ZSpan.fract_mem_fundamentalDomain _ u), ?_⟩
+    have h := hper _ (L.sub_fract_mem_lattice u) (ZSpan.fract L.basis u)
+    rw [add_sub_cancel] at h
+    exact h.symm
+  refine Bornology.IsBounded.subset ?_ hrange
+  refine (IsCompact.image ?_ hf.continuous).isBounded
+  exact Metric.isCompact_of_isClosed_isBounded isClosed_closure
+    (ZSpan.fundamentalDomain_isBounded L.basis).closure
+
+p2m_export "PeriodPair" "apply_eq_apply_of_differentiable_of_forall_periodic"
+end Liouville
+
+section ToPointLemmas
+
+theorem toPoint_add_mem (h : L.DiscriminantNeZero) (z : ℂ) {l : ℂ} (hl : l ∈ L.lattice) :
+    L.toPoint h (z + l) = L.toPoint h z := by
+  by_cases hz : z ∈ L.lattice
+  · rw [L.toPoint_of_mem h hz, L.toPoint_of_mem h (add_mem hz hl)]
+  · have hzl : z + l ∉ L.lattice := fun hmem => hz (by simpa using sub_mem hmem hl)
+    rw [L.toPoint_of_notMem h hz, L.toPoint_of_notMem h hzl]
+    have hP : ℘[L] (z + l) = ℘[L] z := L.weierstrassP_add_coe z ⟨l, hl⟩
+    have hP' : ℘'[L] (z + l) = ℘'[L] z := L.derivWeierstrassP_add_coe z ⟨l, hl⟩
+    simp only [WeierstrassCurve.Affine.Point.some.injEq]
+    exact ⟨hP, by rw [hP']⟩
+
+theorem toPoint_neg (h : L.DiscriminantNeZero) (z : ℂ) :
+    L.toPoint h (-z) = -L.toPoint h z := by
+  by_cases hz : z ∈ L.lattice
+  · rw [L.toPoint_of_mem h hz, L.toPoint_of_mem h (neg_mem hz)]; rfl
+  · have hnz : -z ∉ L.lattice := fun hmem => hz (by simpa using neg_mem hmem)
+    rw [L.toPoint_of_notMem h hz, L.toPoint_of_notMem h hnz,
+      WeierstrassCurve.Affine.Point.neg_some]
+    simp only [WeierstrassCurve.Affine.Point.some.injEq]
+    refine ⟨L.weierstrassP_neg z, ?_⟩
+    rw [L.derivWeierstrassP_neg]
+    show -℘'[L] z / 2 = L.weierstrassCurve.toAffine.negY (℘[L] z) (℘'[L] z / 2)
+    rw [WeierstrassCurve.Affine.negY, weierstrassCurve_a₁, weierstrassCurve_a₃]
+    ring
+
+end ToPointLemmas
+
+section Isogeny
+
+private theorem _root_.PeriodPair.apply_eq_apply_of_continuous_of_mapsTo_lattice {f : ℂ → ℂ}
+    (hf : Continuous f)
+    (hmem : ∀ z, f z ∈ L.lattice) (z w : ℂ) : f z = f w := by
+  refine IsPreconnected.constant_of_mapsTo (isPreconnected_univ) ?_
+    hf.continuousOn (fun u _ => hmem u) (mem_univ z) (mem_univ w)
+  rw [isDiscrete_iff_discreteTopology]
+  exact inferInstanceAs (DiscreteTopology L.lattice)
+
+p2m_export "PeriodPair" "apply_eq_apply_of_continuous_of_mapsTo_lattice"
+
+theorem exists_smul_mem_and_apply_eq_of_forall_sub_mem (L' : PeriodPair) {F : ℂ → ℂ}
+    (hF : Differentiable ℂ F)
+    (hper : ∀ l ∈ L.lattice, ∀ z, F (z + l) - F z ∈ L'.lattice) :
+    ∃ α : ℂ, (∀ l ∈ L.lattice, α * l ∈ L'.lattice) ∧ ∀ z, F z = F 0 + α * z := by
+  have hFc : Continuous F := hF.continuous
+  have hconst : ∀ l ∈ L.lattice, ∀ z, F (z + l) - F z = F l - F 0 := by
+    intro l hl z
+    have h := L'.apply_eq_apply_of_continuous_of_mapsTo_lattice
+      (f := fun u => F (u + l) - F u)
+      ((hFc.comp (continuous_id.add continuous_const)).sub hFc) (hper l hl) z 0
+    simpa using h
+  have hadd : ∀ z w, F (z + w) = F z + F w - F 0 := by
+    intro z w
+    have hper' : ∀ l ∈ L.lattice, ∀ u,
+        (fun u => F (u + w) - F u) (u + l) = (fun u => F (u + w) - F u) u := by
+      intro l hl u
+      have h1 := hconst l hl (u + w)
+      have h2 := hconst l hl u
+      rw [show u + w + l = u + l + w by ring] at h1
+      simp only
+      linear_combination h1 - h2
+    have h := L.apply_eq_apply_of_differentiable_of_forall_periodic
+      (f := fun u => F (u + w) - F u)
+      ((hF.comp (differentiable_id.add_const w)).sub hF) hper' z 0
+    simp only [zero_add] at h
+    linear_combination h
+  set α : ℂ := deriv F 0 with hα
+  have hderiv : ∀ z, deriv F z = α := by
+    intro z
+    have hfun : (fun w => F (z + w)) = fun w => F w + (F z - F 0) := by
+      funext w
+      rw [hadd z w]; ring
+    have h1 : deriv (fun w => F (z + w)) 0 = deriv F z := by
+      rw [deriv_comp_const_add]
+      simp
+    have h2 : deriv (fun w => F w + (F z - F 0)) 0 = deriv F 0 := by
+      rw [deriv_add_const]
+    rw [← h1, hfun, h2]
+  have haffine : ∀ z, F z = F 0 + α * z := by
+    have hG : Differentiable ℂ fun z => F z - α * z :=
+      hF.sub (differentiable_id.const_mul α)
+    have hG' : ∀ z, deriv (fun z => F z - α * z) z = 0 := by
+      intro z
+      have hd : HasDerivAt (fun z => F z - α * z) (deriv F z - α * 1) z :=
+        (hF z).hasDerivAt.sub ((hasDerivAt_id z).const_mul α)
+      rw [hd.deriv, hderiv z]
+      ring
+    intro z
+    have h := is_const_of_deriv_eq_zero hG hG' z 0
+    simp only [mul_zero, sub_zero] at h
+    linear_combination h
+  refine ⟨α, fun l hl => ?_, haffine⟩
+  have h := hper l hl 0
+  rw [zero_add, haffine l] at h
+  simpa using h
+
+end Isogeny
+
+section Scale
+
+variable (α : ℂˣ)
+
+private def mulLeftR (a : ℂ) : ℂ →ₗ[ℝ] ℂ := Algebra.lmul ℝ ℂ a
+
+@[scoped simp] private theorem mulLeftR_apply (a z : ℂ) : mulLeftR a z = a * z := rfl
+
+private theorem mulLeftR_injective {a : ℂ} (ha : a ≠ 0) :
+    Function.Injective (mulLeftR a) := fun _ _ h => by
+  simpa using mul_left_cancel₀ ha h
+
+private def mulLeftZ (a : ℂ) : ℂ →ₗ[ℤ] ℂ := (mulLeftR a).restrictScalars ℤ
+
+@[scoped simp] private theorem mulLeftZ_apply (a z : ℂ) : mulLeftZ a z = a * z := rfl
+
+private theorem _root_.PeriodPair.scale_lattice :
+    (L.scale α).lattice = Submodule.map (mulLeftZ (α : ℂ)) L.lattice := by
+  unfold lattice scale
+  rw [Submodule.map_span]
+  congr 1
+  ext z
+  simp only [Set.mem_insert_iff, Set.mem_singleton_iff, Set.mem_image, mulLeftZ_apply]
+  constructor
+  · rintro (rfl | rfl)
+    · exact ⟨L.ω₁, Or.inl rfl, rfl⟩
+    · exact ⟨L.ω₂, Or.inr rfl, rfl⟩
+  · rintro ⟨w, hw | hw, rfl⟩ <;> simp [hw]
+
+p2m_export "PeriodPair" "scale_lattice"
+theorem mem_scale_lattice_iff {z : ℂ} :
+    z ∈ (L.scale α).lattice ↔ ∃ l ∈ L.lattice, z = (α : ℂ) * l := by
+  rw [scale_lattice, Submodule.mem_map]; simp only [mulLeftZ_apply]; tauto
+
+private def _root_.PeriodPair.scaleLatticeEquiv : L.lattice ≃ₗ[ℤ] (L.scale α).lattice :=
+  (Submodule.equivMapOfInjective (mulLeftZ (α : ℂ))
+    (fun _ _ h => mul_left_cancel₀ α.ne_zero (by simpa using h)) L.lattice).trans
+    (LinearEquiv.ofEq _ _ (L.scale_lattice α).symm)
+
+p2m_export "PeriodPair" "scaleLatticeEquiv"
+@[scoped simp] theorem scaleLatticeEquiv_apply (l : L.lattice) :
+    ((L.scaleLatticeEquiv α l : (L.scale α).lattice) : ℂ) = (α : ℂ) * (l : ℂ) := rfl
+
+end Scale
+
+section Homogeneity
+
+variable (α : ℂˣ)
+
+theorem G_scale (n : ℕ) : (L.scale α).G n = ((α : ℂ) ^ n)⁻¹ * L.G n := by
+  unfold G
+  rw [← (L.scaleLatticeEquiv α).toEquiv.tsum_eq]
+  simp only [LinearEquiv.coe_toEquiv, scaleLatticeEquiv_apply, mul_pow, mul_inv]
+  exact tsum_mul_left
+
+theorem g₂_scale : (L.scale α).g₂ = ((α : ℂ) ^ 4)⁻¹ * L.g₂ := by
+  unfold g₂; rw [G_scale]; ring
+
+theorem g₃_scale : (L.scale α).g₃ = ((α : ℂ) ^ 6)⁻¹ * L.g₃ := by
+  unfold g₃; rw [G_scale]; ring
+
+theorem discriminant_scale :
+    (L.scale α).g₂ ^ 3 - 27 * (L.scale α).g₃ ^ 2
+      = ((α : ℂ) ^ 12)⁻¹ * (L.g₂ ^ 3 - 27 * L.g₃ ^ 2) := by
+  rw [g₂_scale, g₃_scale]; ring
+
+theorem g₂_cubed_scale : (L.scale α).g₂ ^ 3 = ((α : ℂ) ^ 12)⁻¹ * L.g₂ ^ 3 := by
+  rw [g₂_scale, mul_pow, inv_pow, ← pow_mul]
+
+theorem jLattice_scale : (L.scale α).jLattice = L.jLattice := by
+  have hα : ((α : ℂ) ^ 12)⁻¹ ≠ 0 := inv_ne_zero (pow_ne_zero _ α.ne_zero)
+  unfold jLattice
+  rw [discriminant_scale, g₂_cubed_scale, mul_left_comm (1728 : ℂ), mul_div_mul_left _ _ hα]
+
+theorem discriminantNeZero_scale_iff :
+    (L.scale α).DiscriminantNeZero ↔ L.DiscriminantNeZero := by
+  unfold DiscriminantNeZero
+  rw [discriminant_scale]
+  simp only [mul_ne_zero_iff, and_iff_right (inv_ne_zero (pow_ne_zero 12 α.ne_zero))]
+
+end Homogeneity
+
+section LatticeDependence
+
+variable {L L' : PeriodPair}
+
+private def latticeEquivOfEq (h : L.lattice = L'.lattice) : L.lattice ≃ L'.lattice where
+  toFun l := ⟨(l : ℂ), h ▸ l.2⟩
+  invFun l := ⟨(l : ℂ), h.symm ▸ l.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+
+theorem G_eq_of_lattice_eq (h : L.lattice = L'.lattice) (n : ℕ) : L.G n = L'.G n :=
+  (latticeEquivOfEq h).tsum_eq fun l => ((l : ℂ) ^ n)⁻¹
+
+theorem g₂_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.g₂ = L'.g₂ := by
+  unfold g₂; rw [G_eq_of_lattice_eq h]
+
+theorem g₃_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.g₃ = L'.g₃ := by
+  unfold g₃; rw [G_eq_of_lattice_eq h]
+
+theorem jLattice_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.jLattice = L'.jLattice := by
+  unfold jLattice; rw [g₂_eq_of_lattice_eq h, g₃_eq_of_lattice_eq h]
+
+end LatticeDependence
+
+section Gates
+
+theorem gate_scale_mul (α β : ℂˣ) :
+    ((L.scale α).scale β).lattice = (L.scale (β * α)).lattice := by
+  ext z
+  simp only [mem_scale_lattice_iff, Units.val_mul]
+  constructor
+  · rintro ⟨-, ⟨l, hl, rfl⟩, rfl⟩; exact ⟨l, hl, (mul_assoc _ _ _).symm⟩
+  · rintro ⟨l, hl, rfl⟩; exact ⟨(α : ℂ) * l, ⟨l, hl, rfl⟩, mul_assoc _ _ _⟩
+
+end Gates
+
+private theorem _root_.PeriodPair.kw_countable_lattice : (L.lattice : Set ℂ).Countable := by
+  refine (Set.countable_range fun p : ℤ × ℤ => (p.1 : ℂ) * L.ω₁ + (p.2 : ℂ) * L.ω₂).mono ?_
+  intro z hz
+  obtain ⟨m, n, h⟩ := mem_lattice.mp hz
+  exact ⟨(m, n), h⟩
+
+p2m_export "PeriodPair" "kw_countable_lattice"
+
+private def _root_.PeriodPair.kw_toPointHom : ℂ →+ (L.weierstrassCurve.toAffine).Point where
+  toFun := L.toPoint L.kw_discriminantNeZero
+  map_zero' := L.toPoint_zero L.kw_discriminantNeZero
+  map_add' := L.kw_toPoint_add L.kw_discriminantNeZero
+
+p2m_export "PeriodPair" "kw_toPointHom"
+theorem kw_toPointHom_apply (z : ℂ) :
+    L.kw_toPointHom z = L.toPoint L.kw_discriminantNeZero z := rfl
+
+private theorem _root_.PeriodPair.kw_ker_toPointHom :
+    L.kw_toPointHom.ker = L.lattice.toAddSubgroup := by
+  ext z
+  constructor
+  · exact fun hz => (L.kw_isUniformization).2.2 z hz
+  · intro hz
+    exact L.toPoint_of_mem L.kw_discriminantNeZero hz
+
+p2m_export "PeriodPair" "kw_ker_toPointHom"
+
+private def _root_.PeriodPair.kw_toPointAddEquiv :
+    (ℂ ⧸ L.lattice.toAddSubgroup) ≃+ (L.weierstrassCurve.toAffine).Point :=
+  QuotientAddGroup.liftEquiv L.lattice.toAddSubgroup (φ := L.kw_toPointHom)
+    (L.kw_isUniformization).2.1 L.kw_ker_toPointHom.symm
+
+p2m_export "PeriodPair" "kw_toPointAddEquiv"
+theorem kw_toPointAddEquiv_mk (z : ℂ) :
+    L.kw_toPointAddEquiv (QuotientAddGroup.mk z) = L.toPoint L.kw_discriminantNeZero z :=
+  rfl
+
+scoped instance kw_infinite_quotientLattice : Infinite (ℂ ⧸ L.lattice.toAddSubgroup) := by
+  rw [← not_finite_iff_infinite]; intro hfin
+  have : Countable L.lattice.toAddSubgroup :=
+    Set.countable_coe_iff.mpr L.kw_countable_lattice
+  have : Countable ((ℂ ⧸ L.lattice.toAddSubgroup) × L.lattice.toAddSubgroup) := inferInstance
+  have hCc : Countable ℂ :=
+    Countable.of_equiv _ (AddSubgroup.addGroupEquivQuotientProdAddSubgroup
+      (s := L.lattice.toAddSubgroup)).symm
+  have : Uncountable ℂ := Complex.ofReal_injective.uncountable
+  exact absurd hCc not_countable
+
+scoped instance kw_infinite_point : Infinite L.weierstrassCurve.toAffine.Point :=
+  L.kw_toPointAddEquiv.toEquiv.infinite_iff.mp inferInstance
+
+end PeriodPair
+end
+
+namespace ModularCurve
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_b277e395.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_b277e395.Weierstrass\
+  Curve.Affine \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_b277e395.AlgebraicCu\
+  rve PeriodPair \
+  P2MW.S_OVERLONG_b277e395.PeriodPair"
+
+def KwD5BetweenCurvesHoloLift : Prop :=
+  ∀ (L L' : PeriodPair)
+    [L.weierstrassCurve.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve]
+    (ι'' : L'.weierstrassCurve.toAffine.FunctionField →ₐ[ℂ]
+      L.weierstrassCurve.toAffine.FunctionField)
+    (hι'' : ι''.toRingHom.IsIntegral) (hfin'' : FiniteAlong ℂ ι''),
+    ∃ (F : ℂ → ℂ), Differentiable ℂ F ∧ F 0 ∈ L'.lattice ∧
+      ∀ z, L'.kw_toPointHom (F z)
+        = (pointMapOfPushforward ι'' hι'' hfin''
+            (normFormulaAlong_of_elliptic ι'' hfin'')) (L.kw_toPointHom z)
+
+end ModularCurve
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_b277e395.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_b277e395.Weierstrass\
+  Curve.Affine \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_b277e395.AlgebraicCu\
+  rve"
+
+namespace ModularCurve
+
+section ConjHelpers
+
+variable {K : Type*} [Field K]
+variable {E E' F F' : WeierstrassCurve.Affine K}
+
+def kw_fdn2_qephod_hend21_conjSeam
+    (eE : F.FunctionField ≃ₐ[K] E.FunctionField)
+    (eE' : F'.FunctionField ≃ₐ[K] E'.FunctionField)
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField) :
+    F'.FunctionField →ₐ[K] F.FunctionField :=
+  (eE.symm.toAlgHom.comp ι).comp eE'.toAlgHom
+
+theorem kw_fdn2_qephod_hend21_conjSeam_isIntegral
+    (eE : F.FunctionField ≃ₐ[K] E.FunctionField)
+    (eE' : F'.FunctionField ≃ₐ[K] E'.FunctionField)
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField) (hι : ι.toRingHom.IsIntegral) :
+    (kw_fdn2_qephod_hend21_conjSeam eE eE' ι).toRingHom.IsIntegral :=
+  RingHom.IsIntegral.trans eE'.toAlgHom.toRingHom (eE.symm.toAlgHom.comp ι).toRingHom
+    (RingHom.isIntegral_of_surjective _ eE'.surjective)
+    (RingHom.IsIntegral.trans ι.toRingHom eE.symm.toAlgHom.toRingHom hι
+      (RingHom.isIntegral_of_surjective _ eE.symm.surjective))
+
+theorem kw_fdn2_qephod_hend21_conjSeam_finiteAlong
+    (eE : F.FunctionField ≃ₐ[K] E.FunctionField)
+    (eE' : F'.FunctionField ≃ₐ[K] E'.FunctionField)
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField) (hfin : FiniteAlong K ι) :
+    FiniteAlong K (kw_fdn2_qephod_hend21_conjSeam eE eE' ι) := by
+  have hfin' : RingHom.Finite ι.toRingHom := hfin
+  have h1 : RingHom.Finite eE'.toAlgHom.toRingHom :=
+    RingHom.Finite.of_surjective _ eE'.surjective
+  have h2 : RingHom.Finite eE.symm.toAlgHom.toRingHom :=
+    RingHom.Finite.of_surjective _ eE.symm.surjective
+  have hcomp : RingHom.Finite
+      (kw_fdn2_qephod_hend21_conjSeam eE eE' ι).toRingHom :=
+    RingHom.Finite.comp (g := (eE.symm.toAlgHom.comp ι).toRingHom)
+      (RingHom.Finite.comp (g := eE.symm.toAlgHom.toRingHom) h2 hfin') h1
+  exact hcomp
+
+theorem kw_fdn2_qephod_hend21_finrankAlong_conj
+    (eE : F.FunctionField ≃ₐ[K] E.FunctionField)
+    (eE' : F'.FunctionField ≃ₐ[K] E'.FunctionField)
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField) :
+    finrankAlong K (kw_fdn2_qephod_hend21_conjSeam eE eE' ι) = finrankAlong K ι := by
+  refine @Algebra.finrank_eq_of_equiv_equiv F'.FunctionField F.FunctionField _ _
+    (algebraAlong (kw_fdn2_qephod_hend21_conjSeam eE eE' ι))
+    E'.FunctionField E.FunctionField _ _ (algebraAlong ι)
+    eE'.toRingEquiv eE.toRingEquiv (RingHom.ext fun x => ?_)
+  change ι (eE' x) = eE (eE.symm (ι (eE' x)))
+  exact (eE.apply_symm_apply _).symm
+
+end ConjHelpers
+end ModularCurve
+end
+
+section
+
+section
+
+open IsDedekindDomain
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong \
+  isScalarTower_along isIntegral_along FiniteAlong NormFormulaAlong finrankAlong \
+  Divisor.pushforwardAlong Divisor.pushforwardAlong_single SeparableAlong Place.restrictInclusion \
+  Place Place.ext Divisor HasPrincipalDivisors Pic Pic0 Pic0.mk Pic0.mk_surjective \
+  Place.ofHeightOneSpectrum Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective normFormulaAlong Divisor.pushforwardAlong_pushforwardAlong'"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+section Tower
+variable {K F F' F'' : Type*} [Field K] [Field F] [Field F'] [Field F'']
+  [Algebra K F] [Algebra K F'] [Algebra K F'']
+variable (φ : F →ₐ[K] F') (χ : F' →ₐ[K] F'')
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong inertiaDegAlong restrictInclusion ext \
+  ResidueField deg adicValuation adicValuation_ne_zero ord ord_inv ord_unit_smul_zpow \
+  exists_unit_mul_zpow ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' \
+  algebraMap_mem' toValuationSubring mk mem_of_eval_monic_eq_zero IsRational evalAt \
+  ofHeightOneSpectrum_injective evalAt_mul evalAt_inv"
+end Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+theorem Place.restrictAlong_restrictAlong (hφ : φ.toRingHom.IsIntegral)
+    (hχ : χ.toRingHom.IsIntegral) (hχφ : (χ.comp φ).toRingHom.IsIntegral)
+    (W : Place K F'') :
+    (W.restrictAlong χ hχ).restrictAlong φ hφ = W.restrictAlong (χ.comp φ) hχφ := by
+  exact Place.ext (SetLike.ext fun _ => Iff.rfl)
+variable (K) in
+def InertiaDegComp (hφ : φ.toRingHom.IsIntegral) (hχ : χ.toRingHom.IsIntegral)
+    (hχφ : (χ.comp φ).toRingHom.IsIntegral) : Prop :=
+  ∀ W : Place K F'',
+    W.inertiaDegAlong (χ.comp φ) hχφ
+      = W.inertiaDegAlong χ hχ * (W.restrictAlong χ hχ).inertiaDegAlong φ hφ
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "pushforwardAlong pushforwardAlong_single pushforward degree \
+  pushforwardAlong_pushforwardAlong'"
+end Divisor
+p2m_open_scoped "AlgebraicCurve.Divisor" in
+theorem Divisor.pushforwardAlong_pushforwardAlong (hφ : φ.toRingHom.IsIntegral)
+    (hχ : χ.toRingHom.IsIntegral) (hχφ : (χ.comp φ).toRingHom.IsIntegral)
+    (hf : InertiaDegComp K φ χ hφ hχ hχφ) (D : Divisor K F'') :
+    Divisor.pushforwardAlong φ hφ (Divisor.pushforwardAlong χ hχ D)
+      = Divisor.pushforwardAlong (χ.comp φ) hχφ D := by
+  have key : (Divisor.pushforwardAlong φ hφ).comp (Divisor.pushforwardAlong χ hχ)
+      = Divisor.pushforwardAlong (χ.comp φ) hχφ := by
+    refine Finsupp.addHom_ext fun W n => ?_
+    change Divisor.pushforwardAlong φ hφ (Divisor.pushforwardAlong χ hχ (Finsupp.single W n))
+        = Divisor.pushforwardAlong (χ.comp φ) hχφ (Finsupp.single W n)
+    rw [Divisor.pushforwardAlong_single, Divisor.pushforwardAlong_single,
+      Divisor.pushforwardAlong_single, Place.restrictAlong_restrictAlong φ χ hφ hχ hχφ, hf W]
+    refine congrArg (Finsupp.single _) ?_
+    push_cast
+    ring
+  exact DFunLike.congr_fun key D
+
+end Tower
+end AlgebraicCurve
+end
+
+section
+
+section
+
+open IsDedekindDomain
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong \
+  isScalarTower_along isIntegral_along FiniteAlong NormFormulaAlong finrankAlong \
+  Divisor.pushforwardAlong Divisor.pushforwardAlong_single SeparableAlong Place.restrictInclusion \
+  Place Place.ext Divisor HasPrincipalDivisors Pic Pic0 Pic0.mk Pic0.mk_surjective \
+  Place.ofHeightOneSpectrum Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective normFormulaAlong Divisor.pushforwardAlong_pushforwardAlong'"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+section InertiaTower
+
+variable {K F F' F'' : Type*} [Field K] [Field F] [Field F'] [Field F'']
+  [Algebra K F] [Algebra K F'] [Algebra K F'']
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong inertiaDegAlong restrictInclusion ext \
+  ResidueField deg adicValuation adicValuation_ne_zero ord ord_inv ord_unit_smul_zpow \
+  exists_unit_mul_zpow ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' \
+  algebraMap_mem' toValuationSubring mk mem_of_eval_monic_eq_zero IsRational evalAt \
+  ofHeightOneSpectrum_injective evalAt_mul evalAt_inv"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg"
+
+def restrictInclusionAlong (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral) (w : Place K F') :
+    (w.restrictAlong φ hφ).toValuationSubring →+* w.toValuationSubring :=
+  letI := algebraAlong φ
+  haveI := isScalarTower_along φ
+  haveI := isIntegral_along φ hφ
+  Place.restrictInclusion F w
+
+scoped instance (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral) (w : Place K F') :
+    IsLocalHom (restrictInclusionAlong φ hφ w) := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  exact inferInstanceAs (IsLocalHom (Place.restrictInclusion F w))
+
+def restrictResidueMapAlong (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') : (w.restrictAlong φ hφ).ResidueField →+* w.ResidueField :=
+  IsLocalRing.ResidueField.map (restrictInclusionAlong φ hφ w)
+
+variable (φ : F →ₐ[K] F') (χ : F' →ₐ[K] F'')
+
+theorem inertiaDegAlong_comp (hφ : φ.toRingHom.IsIntegral) (hχ : χ.toRingHom.IsIntegral)
+    (hχφ : (χ.comp φ).toRingHom.IsIntegral) :
+    InertiaDegComp K φ χ hφ hχ hχφ := by
+  intro W
+  set w : Place K F' := W.restrictAlong χ hχ with hw
+  let iA : Algebra (W.restrictAlong (χ.comp φ) hχφ).ResidueField W.ResidueField :=
+    (restrictResidueMapAlong (χ.comp φ) hχφ W).toAlgebra
+  let iB : Algebra w.ResidueField W.ResidueField :=
+    (restrictResidueMapAlong χ hχ W).toAlgebra
+  let iC : Algebra (W.restrictAlong (χ.comp φ) hχφ).ResidueField w.ResidueField :=
+    (restrictResidueMapAlong φ hφ w).toAlgebra
+  have : IsScalarTower (W.restrictAlong (χ.comp φ) hχφ).ResidueField
+      w.ResidueField W.ResidueField := by
+    refine IsScalarTower.of_algebraMap_eq fun x => ?_
+    obtain ⟨a, rfl⟩ := IsLocalRing.residue_surjective x
+    change restrictResidueMapAlong (χ.comp φ) hχφ W (IsLocalRing.residue _ a)
+      = restrictResidueMapAlong χ hχ W
+          (restrictResidueMapAlong φ hφ w (IsLocalRing.residue _ a))
+    rw [restrictResidueMapAlong, restrictResidueMapAlong, restrictResidueMapAlong,
+      IsLocalRing.ResidueField.map_residue, IsLocalRing.ResidueField.map_residue,
+      IsLocalRing.ResidueField.map_residue]
+    exact congrArg _ (Subtype.ext rfl)
+  change Module.finrank (W.restrictAlong (χ.comp φ) hχφ).ResidueField W.ResidueField
+    = Module.finrank w.ResidueField W.ResidueField
+        * Module.finrank (W.restrictAlong (χ.comp φ) hχφ).ResidueField w.ResidueField
+  rw [← Module.finrank_mul_finrank
+    (W.restrictAlong (χ.comp φ) hχφ).ResidueField w.ResidueField W.ResidueField]
+  exact Nat.mul_comm _ _
+
+private theorem _root_.AlgebraicCurve.Divisor.pushforwardAlong_pushforwardAlong'
+    (hφ : φ.toRingHom.IsIntegral) (hχ : χ.toRingHom.IsIntegral)
+    (hχφ : (χ.comp φ).toRingHom.IsIntegral) (D : Divisor K F'') :
+    Divisor.pushforwardAlong φ hφ (Divisor.pushforwardAlong χ hχ D)
+      = Divisor.pushforwardAlong (χ.comp φ) hχφ D :=
+  Divisor.pushforwardAlong_pushforwardAlong φ χ hφ hχ hχφ
+    (inertiaDegAlong_comp φ χ hφ hχ hχφ) D
+
+end Place
+end InertiaTower
+
+section JointFiber
+
+variable {K F F₁ F₂ Z : Type*} [Field K] [Field F] [Field F₁] [Field F₂] [Field Z]
+  [Algebra K F] [Algebra K F₁] [Algebra K F₂] [Algebra K Z]
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong inertiaDegAlong restrictInclusion ext \
+  ResidueField deg adicValuation adicValuation_ne_zero ord ord_inv ord_unit_smul_zpow \
+  exists_unit_mul_zpow ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' \
+  algebraMap_mem' toValuationSubring mk mem_of_eval_monic_eq_zero IsRational evalAt \
+  ofHeightOneSpectrum_injective evalAt_mul evalAt_inv"
+end Place
+end JointFiber
+end AlgebraicCurve
+end
+
+section
+
+section
+
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_b277e395.AlgebraicCu\
+  rve WeierstrassCurve \
+  P2MW.S_OVERLONG_b277e395.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_b277e395.Weierstrass\
+  Curve.Affine"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ a₁ map mk a₄ a₂ a₆ Affine.Point.some \
+  Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ Affine.Point.neg_some \
+  baseChange j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing map baseChange Point.some \
+  Point.some.injEq Nonsingular FunctionField Point CoordinateRing.mk equation_iff_nonsingular \
+  polynomial Point.neg_some pointMapOfPushforward IsogenyEndDatum IsogenyEndDatum.pointEnd \
+  isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one deg_placeOfPoint \
+  pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal hasPrincipalDivisors_functionField \
+  natCard_ker_pointMapOfPushforward_eq_finrankAlong polyToFunctionField polyToFunctionField_C \
+  algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι"
+p2m_open "WeierstrassCurve.Affine.IsogenyEndDatum"
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem isIntegral_algHomId :
+    (AlgHom.id F W.FunctionField).toRingHom.IsIntegral :=
+  RingHom.isIntegral_of_surjective _ Function.surjective_id
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem finiteAlong_algHomId : FiniteAlong F (AlgHom.id F W.FunctionField) := by
+  unfold FiniteAlong algebraAlong
+  exact Module.Finite.self _
+
+def idDatum : IsogenyEndDatum W where
+  ι := AlgHom.id F W.FunctionField
+  hι := isIntegral_algHomId W
+  hfin := finiteAlong_algHomId W
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic W]
+  [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W] [W.AbelTheorem] in
+theorem restrictAlong_algHomId (w : AlgebraicCurve.Place F W.FunctionField) :
+    w.restrictAlong (AlgHom.id F W.FunctionField) (isIntegral_algHomId W) = w :=
+  AlgebraicCurve.Place.ext (SetLike.ext fun _ => Iff.rfl)
+
+omit [GenusOnePlaceGate.IsCentred W] in
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem idDatum_pointEnd : (idDatum W).pointEnd' = 1 := by
+  refine AddMonoidHom.ext fun P => ?_
+  exact (idDatum W).pointEnd'_eq_of_seam id rfl (fun Q => restrictAlong_algHomId W _) P
+end IsogenyEndDatum
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι"
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ a₁ map mk a₄ a₂ a₆ Affine.Point.some \
+  Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ Affine.Point.neg_some \
+  baseChange j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve"
+section JNonIntBridge
+variable (W : WeierstrassCurve ℚ) [W.IsElliptic]
+  {K : Type*} [Field K] [Algebra ℚ K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+local instance instIsEllipticBaseChangeJNonInt :
+    ((W : WeierstrassCurve ℚ).baseChange K).IsElliptic :=
+  inferInstanceAs (((W : WeierstrassCurve ℚ).map (algebraMap ℚ K)).IsElliptic)
+end JNonIntBridge
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ a₁ map mk a₄ a₂ a₆ Affine.Point.some \
+  Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ Affine.Point.neg_some \
+  baseChange j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve"
+section BridgeOrdering
+variable (W : WeierstrassCurve ℚ) [W.IsElliptic]
+  {K : Type*} [Field K] [Algebra ℚ K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+local instance instIsEllipticBaseChangeBridgeOrd :
+    ((W : WeierstrassCurve ℚ).baseChange K).IsElliptic :=
+  inferInstanceAs (((W : WeierstrassCurve ℚ).map (algebraMap ℚ K)).IsElliptic)
+end BridgeOrdering
+end WeierstrassCurve
+end
+
+section
+
+section
+
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_b277e395.AlgebraicCu\
+  rve WeierstrassCurve \
+  P2MW.S_OVERLONG_b277e395.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_b277e395.Weierstrass\
+  Curve.Affine"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong \
+  isScalarTower_along isIntegral_along FiniteAlong NormFormulaAlong finrankAlong \
+  Divisor.pushforwardAlong Divisor.pushforwardAlong_single SeparableAlong Place.restrictInclusion \
+  Place Place.ext Divisor HasPrincipalDivisors Pic Pic0 Pic0.mk Pic0.mk_surjective \
+  Place.ofHeightOneSpectrum Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.ofHeightOneSpectrum_injective normFormulaAlong Divisor.pushforwardAlong_pushforwardAlong'"
+namespace Pic0
+p2m_export "AlgebraicCurve.Pic0" "pushforwardAlongHom pushforwardAlongHom_mk mk mk_surjective"
+p2m_open "AlgebraicCurve.Pic0 \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+variable {K F F' F'' : Type*} [Field K] [Field F] [Field F'] [Field F'']
+variable [Algebra K F] [Algebra K F'] [Algebra K F'']
+variable (φ : F →ₐ[K] F') (χ : F' →ₐ[K] F'')
+variable (hφ : φ.toRingHom.IsIntegral) (hχ : χ.toRingHom.IsIntegral)
+variable (hχφ : (χ.comp φ).toRingHom.IsIntegral)
+variable (hfinφ : FiniteAlong K φ) (hfinχ : FiniteAlong K χ) (hfinχφ : FiniteAlong K (χ.comp φ))
+variable (hNφ : NormFormulaAlong K φ hfinφ) (hNχ : NormFormulaAlong K χ hfinχ)
+variable (hNχφ : NormFormulaAlong K (χ.comp φ) hfinχφ)
+
+theorem pushforwardAlongHom_comp_apply (c : Pic0 K F'') :
+    Pic0.pushforwardAlongHom (χ.comp φ) hχφ hfinχφ hNχφ c
+      = Pic0.pushforwardAlongHom φ hφ hfinφ hNφ
+          (Pic0.pushforwardAlongHom χ hχ hfinχ hNχ c) := by
+  obtain ⟨D, rfl⟩ := Pic0.mk_surjective c
+  rw [Pic0.pushforwardAlongHom_mk, Pic0.pushforwardAlongHom_mk, Pic0.pushforwardAlongHom_mk]
+  exact congrArg Pic0.mk (Subtype.ext
+    (Divisor.pushforwardAlong_pushforwardAlong' φ χ hφ hχ hχφ D).symm)
+
+end Pic0
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ a₁ map mk a₄ a₂ a₆ Affine.Point.some \
+  Affine.Point.some.injEq reduction IsIntegral toAffine Affine.Point Δ Affine.Point.neg_some \
+  baseChange j Affine.IsogenyEndDatum Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY CoordinateRing map baseChange Point.some \
+  Point.some.injEq Nonsingular FunctionField Point CoordinateRing.mk equation_iff_nonsingular \
+  polynomial Point.neg_some pointMapOfPushforward IsogenyEndDatum IsogenyEndDatum.pointEnd \
+  isogenyEndSubring GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one deg_placeOfPoint \
+  pointClass AbelTheorem genusOnePic0Equiv GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal hasPrincipalDivisors_functionField \
+  natCard_ker_pointMapOfPushforward_eq_finrankAlong polyToFunctionField polyToFunctionField_C \
+  algebraMap_smul_basis"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι"
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+
+section
+
+p2m_open_scoped "PeriodPair \
+  P2MW.S_OVERLONG_b277e395.PeriodPair \
+  UpperHalfPlane MatrixGroups"
+p2m_open "PeriodPair \
+  P2MW.S_OVERLONG_b277e395.PeriodPair \
+  Polynomial QuaternionAlgebra \
+  P2MW.S_OVERLONG_b277e395.ModularCurv\
+  e"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_b277e395.AlgebraicCu\
+  rve WeierstrassCurve \
+  P2MW.S_OVERLONG_b277e395.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_b277e395.Weierstrass\
+  Curve.Affine Matrix"
+
+namespace ModularCurve
+
+def KwD5BetweenCurvesPMOPConjKerEquiv : Prop :=
+  ∀ (E E' : WeierstrassCurve.Affine ℂ) [E.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E] [WeierstrassCurve.Affine.AbelTheorem E]
+    [E'.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E']
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E']
+    [WeierstrassCurve.Affine.AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[ℂ] E.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong ℂ ι)
+    (L L' : PeriodPair) [L.weierstrassCurve.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve]
+    (eE : L.weierstrassCurve.toAffine.FunctionField ≃ₐ[ℂ] E.FunctionField)
+    (eE' : L'.weierstrassCurve.toAffine.FunctionField ≃ₐ[ℂ] E'.FunctionField),
+    let ι'' := kw_fdn2_qephod_hend21_conjSeam eE eE' ι
+    ∀ (hι'' : ι''.toRingHom.IsIntegral) (hfin'' : FiniteAlong ℂ ι''),
+    IsAddCyclic (AddMonoidHom.ker (pointMapOfPushforward ι hι hfin
+        (normFormulaAlong_of_elliptic ι hfin))) →
+    IsAddCyclic (AddMonoidHom.ker (pointMapOfPushforward ι'' hι'' hfin''
+        (normFormulaAlong_of_elliptic ι'' hfin'')))
+end ModularCurve
+end
+end
+
+section
+
+
+section
+
+namespace ModularCurve
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_b277e395.AlgebraicCu\
+  rve"
+
+section Engines
+
+variable {K F F' F'' : Type*} [Field K] [Field F] [Field F'] [Field F'']
+variable [Algebra K F] [Algebra K F'] [Algebra K F'']
+
+theorem finiteAlong_comp {φ : F →ₐ[K] F'} {ψ : F' →ₐ[K] F''}
+    (hφ : FiniteAlong K φ) (hψ : FiniteAlong K ψ) : FiniteAlong K (ψ.comp φ) := by
+  let := algebraAlong φ
+  let := algebraAlong ψ
+  let := algebraAlong (ψ.comp φ)
+  have : IsScalarTower F F' F'' := IsScalarTower.of_algebraMap_eq fun _ => rfl
+  have : Module.Finite F F' := hφ
+  have : Module.Finite F' F'' := hψ
+  exact Module.Finite.trans F' F''
+
+end Engines
+end ModularCurve
+end
+end
+
+section
+
+p2m_open_scoped "PeriodPair \
+  P2MW.S_OVERLONG_b277e395.PeriodPair \
+  UpperHalfPlane MatrixGroups"
+p2m_open "PeriodPair \
+  P2MW.S_OVERLONG_b277e395.PeriodPair \
+  Polynomial QuaternionAlgebra \
+  P2MW.S_OVERLONG_b277e395.ModularCurv\
+  e"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_b277e395.AlgebraicCu\
+  rve WeierstrassCurve \
+  P2MW.S_OVERLONG_b277e395.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_b277e395.Weierstrass\
+  Curve.Affine Matrix"
+
+section
+
+
+namespace ModularCurve
+
+section PMOPComp
+
+variable {W₁ W₂ W₃ : WeierstrassCurve.Affine ℂ}
+  [W₁.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W₁]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W₁] [WeierstrassCurve.Affine.AbelTheorem W₁]
+  [W₂.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W₂]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W₂] [WeierstrassCurve.Affine.AbelTheorem W₂]
+  [W₃.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W₃]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W₃] [WeierstrassCurve.Affine.AbelTheorem W₃]
+
+omit [GenusOnePlaceGate.IsCentred W₁] [GenusOnePlaceGate.IsCentred W₂]
+  [GenusOnePlaceGate.IsCentred W₃] in
+omit [WeierstrassCurve.IsElliptic W₁] [WeierstrassCurve.IsElliptic W₂]
+  [WeierstrassCurve.IsElliptic W₃] in
+theorem kw_surgehgf4_pck_pmop_comp_apply
+    (φ : W₂.FunctionField →ₐ[ℂ] W₃.FunctionField)
+    (χ : W₁.FunctionField →ₐ[ℂ] W₂.FunctionField)
+    (hφ : φ.toRingHom.IsIntegral) (hχ : χ.toRingHom.IsIntegral)
+    (hφχ : (φ.comp χ).toRingHom.IsIntegral)
+    (hfinφ : FiniteAlong ℂ φ) (hfinχ : FiniteAlong ℂ χ)
+    (hfinφχ : FiniteAlong ℂ (φ.comp χ)) (P : W₃.Point) :
+    pointMapOfPushforward (φ.comp χ) hφχ hfinφχ
+        (normFormulaAlong_of_elliptic (φ.comp χ) hfinφχ) P
+      = pointMapOfPushforward χ hχ hfinχ (normFormulaAlong_of_elliptic χ hfinχ)
+          (pointMapOfPushforward φ hφ hfinφ (normFormulaAlong_of_elliptic φ hfinφ) P) := by
+  change genusOnePic0Equiv W₁ (Pic0.pushforwardAlongHom (φ.comp χ) _ _ _
+        ((genusOnePic0Equiv W₃).symm P))
+    = genusOnePic0Equiv W₁ (Pic0.pushforwardAlongHom χ _ _ _
+        ((genusOnePic0Equiv W₂).symm
+          (genusOnePic0Equiv W₂ (Pic0.pushforwardAlongHom φ _ _ _
+            ((genusOnePic0Equiv W₃).symm P)))))
+  rw [AddEquiv.symm_apply_apply]
+  exact congrArg (genusOnePic0Equiv W₁)
+    (Pic0.pushforwardAlongHom_comp_apply χ φ hχ hφ hφχ hfinχ hfinφ hfinφχ
+      (normFormulaAlong_of_elliptic χ hfinχ) (normFormulaAlong_of_elliptic φ hfinφ)
+      (normFormulaAlong_of_elliptic (φ.comp χ) hfinφχ)
+      ((genusOnePic0Equiv W₃).symm P))
+
+end PMOPComp
+
+section PMOPEquiv
+
+variable {W V : WeierstrassCurve.Affine ℂ} [W.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+    [V.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate V]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred V] [WeierstrassCurve.Affine.AbelTheorem V]
+
+omit [GenusOnePlaceGate.IsCentred W] in
+omit [WeierstrassCurve.IsElliptic W] in
+theorem kw_surgehgf4_pck_pmop_id
+    (hι : (AlgHom.id ℂ W.FunctionField).toRingHom.IsIntegral)
+    (hfin : FiniteAlong ℂ (AlgHom.id ℂ W.FunctionField)) (P : W.Point) :
+    pointMapOfPushforward (AlgHom.id ℂ W.FunctionField) hι hfin
+        (normFormulaAlong_of_elliptic _ hfin) P = P := by
+  have h := IsogenyEndDatum.idDatum_pointEnd W
+  calc pointMapOfPushforward (AlgHom.id ℂ W.FunctionField) hι hfin
+          (normFormulaAlong_of_elliptic _ hfin) P
+      = (IsogenyEndDatum.idDatum W).pointEnd' P := rfl
+    _ = P := by rw [h]; rfl
+
+omit [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W]
+  [W.AbelTheorem] [WeierstrassCurve.IsElliptic V] [V.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred V] [V.AbelTheorem] in
+theorem kw_surgehgf4_pck_algEquiv_isIntegral
+    (e : W.FunctionField ≃ₐ[ℂ] V.FunctionField) :
+    e.toAlgHom.toRingHom.IsIntegral :=
+  RingHom.isIntegral_of_surjective _ e.surjective
+
+omit [WeierstrassCurve.IsElliptic W] [W.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W]
+  [W.AbelTheorem] [WeierstrassCurve.IsElliptic V] [V.GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred V] [V.AbelTheorem] in
+theorem kw_surgehgf4_pck_algEquiv_finiteAlong
+    (e : W.FunctionField ≃ₐ[ℂ] V.FunctionField) :
+    FiniteAlong ℂ (e.toAlgHom (R := ℂ)) := by
+  change @Module.Finite W.FunctionField V.FunctionField _ _ (algebraAlong e.toAlgHom).toModule
+  let := algebraAlong e.toAlgHom
+  exact Module.Finite.of_surjective
+    (Algebra.linearMap W.FunctionField V.FunctionField) e.surjective
+
+omit [GenusOnePlaceGate.IsCentred W] [GenusOnePlaceGate.IsCentred V] in
+omit [WeierstrassCurve.IsElliptic W] [WeierstrassCurve.IsElliptic V] in
+theorem kw_surgehgf4_pck_pmop_congr
+    {ι ι' : W.FunctionField →ₐ[ℂ] V.FunctionField} (h : ι = ι')
+    {hι : ι.toRingHom.IsIntegral} {hfin : FiniteAlong ℂ ι}
+    {hι' : ι'.toRingHom.IsIntegral} {hfin' : FiniteAlong ℂ ι'} (P : V.Point) :
+    pointMapOfPushforward ι hι hfin (normFormulaAlong_of_elliptic ι hfin) P
+      = pointMapOfPushforward ι' hι' hfin' (normFormulaAlong_of_elliptic ι' hfin') P := by
+  subst h; rfl
+
+omit [GenusOnePlaceGate.IsCentred V] in
+omit [WeierstrassCurve.IsElliptic V] in
+omit [GenusOnePlaceGate.IsCentred W] in
+omit [WeierstrassCurve.IsElliptic W] in
+theorem kw_surgehgf4_pck_pmop_equiv_left_inv
+    (e : W.FunctionField ≃ₐ[ℂ] V.FunctionField) (P : W.Point) :
+    pointMapOfPushforward e.toAlgHom
+        (kw_surgehgf4_pck_algEquiv_isIntegral e)
+        (kw_surgehgf4_pck_algEquiv_finiteAlong e)
+        (normFormulaAlong_of_elliptic _ (kw_surgehgf4_pck_algEquiv_finiteAlong e))
+        (pointMapOfPushforward e.symm.toAlgHom
+          (kw_surgehgf4_pck_algEquiv_isIntegral e.symm)
+          (kw_surgehgf4_pck_algEquiv_finiteAlong e.symm)
+          (normFormulaAlong_of_elliptic _ (kw_surgehgf4_pck_algEquiv_finiteAlong e.symm)) P)
+      = P := by
+  have heq : e.symm.toAlgHom.comp e.toAlgHom = AlgHom.id ℂ W.FunctionField :=
+    AlgHom.ext fun x => e.symm_apply_apply x
+  have hι'' : (e.symm.toAlgHom.comp e.toAlgHom).toRingHom.IsIntegral :=
+    heq ▸ (IsogenyEndDatum.idDatum W).hι
+  have hfin'' : FiniteAlong ℂ (e.symm.toAlgHom.comp e.toAlgHom) :=
+    heq ▸ (IsogenyEndDatum.idDatum W).hfin
+  have hcomp := kw_surgehgf4_pck_pmop_comp_apply e.symm.toAlgHom e.toAlgHom
+    (kw_surgehgf4_pck_algEquiv_isIntegral e.symm)
+    (kw_surgehgf4_pck_algEquiv_isIntegral e) hι''
+    (kw_surgehgf4_pck_algEquiv_finiteAlong e.symm)
+    (kw_surgehgf4_pck_algEquiv_finiteAlong e) hfin'' P
+  rw [← hcomp,
+    kw_surgehgf4_pck_pmop_congr heq (hι' := (IsogenyEndDatum.idDatum W).hι)
+      (hfin' := (IsogenyEndDatum.idDatum W).hfin) P]
+  exact kw_surgehgf4_pck_pmop_id (IsogenyEndDatum.idDatum W).hι
+    (IsogenyEndDatum.idDatum W).hfin P
+
+omit [GenusOnePlaceGate.IsCentred W] in
+omit [WeierstrassCurve.IsElliptic W] in
+omit [GenusOnePlaceGate.IsCentred V] in
+omit [WeierstrassCurve.IsElliptic V] in
+theorem kw_surgehgf4_pck_pmop_equiv_right_inv
+    (e : W.FunctionField ≃ₐ[ℂ] V.FunctionField) (P : V.Point) :
+    pointMapOfPushforward e.symm.toAlgHom
+        (kw_surgehgf4_pck_algEquiv_isIntegral e.symm)
+        (kw_surgehgf4_pck_algEquiv_finiteAlong e.symm)
+        (normFormulaAlong_of_elliptic _ (kw_surgehgf4_pck_algEquiv_finiteAlong e.symm))
+        (pointMapOfPushforward e.toAlgHom
+          (kw_surgehgf4_pck_algEquiv_isIntegral e)
+          (kw_surgehgf4_pck_algEquiv_finiteAlong e)
+          (normFormulaAlong_of_elliptic _ (kw_surgehgf4_pck_algEquiv_finiteAlong e)) P)
+      = P := by
+  have h := kw_surgehgf4_pck_pmop_equiv_left_inv e.symm P
+  rw [kw_surgehgf4_pck_pmop_congr
+      (show e.symm.symm.toAlgHom = e.toAlgHom from congrArg _ e.symm_symm)] at h
+  exact h
+
+omit [GenusOnePlaceGate.IsCentred W] in
+omit [WeierstrassCurve.IsElliptic W] [GenusOnePlaceGate.IsCentred V] in
+omit [WeierstrassCurve.IsElliptic V] in
+theorem kw_surgehgf4_pck_pmop_equiv_bijective
+    (e : W.FunctionField ≃ₐ[ℂ] V.FunctionField) :
+    Function.Bijective (pointMapOfPushforward e.toAlgHom
+        (kw_surgehgf4_pck_algEquiv_isIntegral e)
+        (kw_surgehgf4_pck_algEquiv_finiteAlong e)
+        (normFormulaAlong_of_elliptic _ (kw_surgehgf4_pck_algEquiv_finiteAlong e))) := by
+  refine ⟨?_, ?_⟩
+  · intro P Q hPQ
+    have := congrArg (pointMapOfPushforward e.symm.toAlgHom
+      (kw_surgehgf4_pck_algEquiv_isIntegral e.symm)
+      (kw_surgehgf4_pck_algEquiv_finiteAlong e.symm)
+      (normFormulaAlong_of_elliptic _ (kw_surgehgf4_pck_algEquiv_finiteAlong e.symm))) hPQ
+    rwa [kw_surgehgf4_pck_pmop_equiv_right_inv,
+      kw_surgehgf4_pck_pmop_equiv_right_inv] at this
+  · intro Q
+    exact ⟨pointMapOfPushforward e.symm.toAlgHom
+      (kw_surgehgf4_pck_algEquiv_isIntegral e.symm)
+      (kw_surgehgf4_pck_algEquiv_finiteAlong e.symm)
+      (normFormulaAlong_of_elliptic _ (kw_surgehgf4_pck_algEquiv_finiteAlong e.symm)) Q,
+      kw_surgehgf4_pck_pmop_equiv_left_inv e Q⟩
+
+end PMOPEquiv
+
+section ConjSeamFactor
+
+variable {E E' F F' : WeierstrassCurve.Affine ℂ}
+  [E.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E] [WeierstrassCurve.Affine.AbelTheorem E]
+  [E'.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate E']
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred E'] [WeierstrassCurve.Affine.AbelTheorem E']
+  [F.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate F]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred F] [WeierstrassCurve.Affine.AbelTheorem F]
+  [F'.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate F']
+  [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred F'] [WeierstrassCurve.Affine.AbelTheorem F']
+variable (eE : F.FunctionField ≃ₐ[ℂ] E.FunctionField)
+  (eE' : F'.FunctionField ≃ₐ[ℂ] E'.FunctionField)
+  (ι : E'.FunctionField →ₐ[ℂ] E.FunctionField)
+  (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong ℂ ι)
+
+omit [GenusOnePlaceGate.IsCentred E] [GenusOnePlaceGate.IsCentred E']
+  [GenusOnePlaceGate.IsCentred F] [GenusOnePlaceGate.IsCentred F'] in
+omit [WeierstrassCurve.IsElliptic E] [WeierstrassCurve.IsElliptic E']
+  [WeierstrassCurve.IsElliptic F] [WeierstrassCurve.IsElliptic F'] in
+theorem kw_surgehgf4_pck_pmop_conjSeam_factor
+    (hι'' : (kw_fdn2_qephod_hend21_conjSeam eE eE' ι).toRingHom.IsIntegral)
+    (hfin'' : FiniteAlong ℂ (kw_fdn2_qephod_hend21_conjSeam eE eE' ι))
+    (P : F.Point) :
+    pointMapOfPushforward (kw_fdn2_qephod_hend21_conjSeam eE eE' ι) hι'' hfin''
+        (normFormulaAlong_of_elliptic _ hfin'') P
+      = pointMapOfPushforward eE'.toAlgHom
+          (kw_surgehgf4_pck_algEquiv_isIntegral eE')
+          (kw_surgehgf4_pck_algEquiv_finiteAlong eE')
+          (normFormulaAlong_of_elliptic _ (kw_surgehgf4_pck_algEquiv_finiteAlong eE'))
+          (pointMapOfPushforward ι hι hfin (normFormulaAlong_of_elliptic ι hfin)
+            (pointMapOfPushforward eE.symm.toAlgHom
+              (kw_surgehgf4_pck_algEquiv_isIntegral eE.symm)
+              (kw_surgehgf4_pck_algEquiv_finiteAlong eE.symm)
+              (normFormulaAlong_of_elliptic _
+                (kw_surgehgf4_pck_algEquiv_finiteAlong eE.symm)) P)) := by
+  have h1 := kw_surgehgf4_pck_pmop_comp_apply
+    (eE.symm.toAlgHom.comp ι) eE'.toAlgHom
+    (RingHom.IsIntegral.trans ι.toRingHom eE.symm.toAlgHom.toRingHom hι
+      (kw_surgehgf4_pck_algEquiv_isIntegral eE.symm))
+    (kw_surgehgf4_pck_algEquiv_isIntegral eE') hι''
+    (ModularCurve.finiteAlong_comp hfin (kw_surgehgf4_pck_algEquiv_finiteAlong eE.symm))
+    (kw_surgehgf4_pck_algEquiv_finiteAlong eE') hfin'' P
+  have h2 := kw_surgehgf4_pck_pmop_comp_apply eE.symm.toAlgHom ι
+    (kw_surgehgf4_pck_algEquiv_isIntegral eE.symm) hι
+    (RingHom.IsIntegral.trans ι.toRingHom eE.symm.toAlgHom.toRingHom hι
+      (kw_surgehgf4_pck_algEquiv_isIntegral eE.symm))
+    (kw_surgehgf4_pck_algEquiv_finiteAlong eE.symm) hfin
+    (ModularCurve.finiteAlong_comp hfin (kw_surgehgf4_pck_algEquiv_finiteAlong eE.symm)) P
+  calc pointMapOfPushforward (kw_fdn2_qephod_hend21_conjSeam eE eE' ι) hι'' hfin''
+          (normFormulaAlong_of_elliptic _ hfin'') P
+      = pointMapOfPushforward eE'.toAlgHom _ _ _
+          (pointMapOfPushforward (eE.symm.toAlgHom.comp ι) _ _ _ P) := h1
+    _ = _ := congrArg _ h2
+
+
+omit [GenusOnePlaceGate.IsCentred E] [GenusOnePlaceGate.IsCentred F'] in
+omit [WeierstrassCurve.IsElliptic E] [GenusOnePlaceGate.IsCentred E']
+  [GenusOnePlaceGate.IsCentred F] [WeierstrassCurve.IsElliptic F'] in
+omit [WeierstrassCurve.IsElliptic E'] [WeierstrassCurve.IsElliptic F] in
+theorem kw_surgehgf4_pck_proved_core
+    (hι'' : (kw_fdn2_qephod_hend21_conjSeam eE eE' ι).toRingHom.IsIntegral)
+    (hfin'' : FiniteAlong ℂ (kw_fdn2_qephod_hend21_conjSeam eE eE' ι)) :
+    IsAddCyclic (AddMonoidHom.ker (pointMapOfPushforward ι hι hfin
+        (normFormulaAlong_of_elliptic ι hfin))) →
+    IsAddCyclic (AddMonoidHom.ker (pointMapOfPushforward
+        (kw_fdn2_qephod_hend21_conjSeam eE eE' ι) hι'' hfin''
+        (normFormulaAlong_of_elliptic _ hfin''))) := by
+  intro hcyc
+  have hAbij := kw_surgehgf4_pck_pmop_equiv_bijective eE.symm
+  have hBinj := (kw_surgehgf4_pck_pmop_equiv_bijective eE').injective
+  have hker_iff : ∀ x : F.Point,
+      x ∈ AddMonoidHom.ker (pointMapOfPushforward
+          (kw_fdn2_qephod_hend21_conjSeam eE eE' ι) hι'' hfin''
+          (normFormulaAlong_of_elliptic _ hfin''))
+        ↔ pointMapOfPushforward eE.symm.toAlgHom
+            (kw_surgehgf4_pck_algEquiv_isIntegral eE.symm)
+            (kw_surgehgf4_pck_algEquiv_finiteAlong eE.symm)
+            (normFormulaAlong_of_elliptic _
+              (kw_surgehgf4_pck_algEquiv_finiteAlong eE.symm)) x
+          ∈ AddMonoidHom.ker (pointMapOfPushforward ι hι hfin
+              (normFormulaAlong_of_elliptic ι hfin)) := by
+    intro x
+    rw [AddMonoidHom.mem_ker, AddMonoidHom.mem_ker,
+      kw_surgehgf4_pck_pmop_conjSeam_factor eE eE' ι hι hfin hι'' hfin'' x]
+    exact ⟨fun h => hBinj (h.trans (map_zero _).symm),
+      fun h => by rw [h, map_zero]⟩
+  obtain ⟨⟨g, hg⟩⟩ := hcyc
+  obtain ⟨g', hg'⟩ := hAbij.surjective (g : E.Point)
+  refine ⟨⟨⟨g', (hker_iff g').mpr (hg' ▸ g.2)⟩, ?_⟩⟩
+  rintro ⟨y, hy⟩
+  obtain ⟨k, hk⟩ := hg ⟨_, (hker_iff y).mp hy⟩
+  refine ⟨k, Subtype.ext (hAbij.injective ?_)⟩
+  have hk' := congrArg Subtype.val hk
+  simp only [AddSubgroup.coe_zsmul] at hk'
+  calc (pointMapOfPushforward eE.symm.toAlgHom _ _ _)
+          ((k • (⟨g', _⟩ : AddMonoidHom.ker _) : AddMonoidHom.ker _) : F.Point)
+      = (pointMapOfPushforward eE.symm.toAlgHom _ _ _) (k • g') := by
+        rw [AddSubgroup.coe_zsmul]
+    _ = k • (pointMapOfPushforward eE.symm.toAlgHom _ _ _) g' := map_zsmul _ k g'
+    _ = k • (g : E.Point) := by rw [hg']
+    _ = _ := hk'
+
+end ConjSeamFactor
+
+
+theorem kw_surgehgf4_pck_proved : KwD5BetweenCurvesPMOPConjKerEquiv :=
+  fun _ _ _ _ _ _ _ _ _ _ ι hι hfin _ _ _ _ _ _ _ _ _ _ eE eE' hι'' hfin'' =>
+    kw_surgehgf4_pck_proved_core eE eE' ι hι hfin hι'' hfin''
+
+end ModularCurve
+end
+end
+
+theorem pck_s17 :
+    ModularCurve.KwD5BetweenCurvesPMOPConjKerEquiv := ModularCurve.kw_surgehgf4_pck_proved
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg\
+  " in
+open _root_.WeierstrassCurve
+  _root_.P2MW.S_OVERLONG_b277e395.WeierstrassCurve
+  _root_.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_b277e395.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_b277e395.AlgebraicCurve
+  in
+theorem solution
+    (E E' D D' : WeierstrassCurve.Affine ℂ) [E.IsElliptic] [E'.IsElliptic] [D.IsElliptic]
+    [D'.IsElliptic]
+    [GenusOnePlaceGate E] [GenusOnePlaceGate.IsCentred E] [AbelTheorem E]
+    [GenusOnePlaceGate E'] [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E']
+    [GenusOnePlaceGate D] [GenusOnePlaceGate.IsCentred D] [AbelTheorem D]
+    [GenusOnePlaceGate D'] [GenusOnePlaceGate.IsCentred D'] [AbelTheorem D']
+    (ι : E'.FunctionField →ₐ[ℂ] E.FunctionField) (hι : ι.toRingHom.IsIntegral)
+    (hfin : FiniteAlong ℂ ι)
+    (hN : NormFormulaAlong ℂ ι hfin)
+    (eE : D.FunctionField ≃ₐ[ℂ] E.FunctionField) (eE' : D'.FunctionField ≃ₐ[ℂ] E'.FunctionField)
+    (ι'' : D'.FunctionField →ₐ[ℂ] D.FunctionField) (hconj : ∀ x, eE (ι'' x) = ι (eE' x))
+    (hι'' : ι''.toRingHom.IsIntegral) (hfin'' : FiniteAlong ℂ ι'')
+    (hN'' : NormFormulaAlong ℂ ι'' hfin'')
+    (hcyc : IsAddCyclic (pointMapOfPushforward ι hι hfin hN).ker) :
+    IsAddCyclic (pointMapOfPushforward ι'' hι'' hfin'' hN'').ker ∧
+      Nat.card (pointMapOfPushforward ι'' hι'' hfin'' hN'').ker = Nat.card (pointMapOfPushforward ι
+        hι hfin hN).ker := by
+  have hι''eq : ι'' = ModularCurve.kw_fdn2_qephod_hend21_conjSeam eE eE' ι := by
+    apply AlgHom.ext
+    intro x
+    apply eE.injective
+    rw [hconj x]
+    change ι (eE' x) = eE (eE.symm (ι (eE' x)))
+    exact (eE.apply_symm_apply _).symm
+  subst hι''eq
+  refine ⟨?_, ?_⟩
+  · exact ModularCurve.kw_surgehgf4_pck_proved_core eE eE' ι hι hfin hι'' hfin'' hcyc
+  · rw [natCard_ker_pointMapOfPushforward_eq_finrankAlong,
+      natCard_ker_pointMapOfPushforward_eq_finrankAlong,
+      ModularCurve.kw_fdn2_qephod_hend21_finrankAlong_conj]
+
+end
+end
+end
+end
+end
+end S_OVERLONG_b277e395
+end P2MW
+export P2MW.S_OVERLONG_b277e395
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+theorem WeierstrassCurve.Affine.isAddCyclic_ker_pointMapOfPushforward_of_algEquiv_conj
+    (E E' D D' : WeierstrassCurve.Affine ℂ) [E.IsElliptic] [E'.IsElliptic] [D.IsElliptic]
+    [D'.IsElliptic]
+    [GenusOnePlaceGate E] [GenusOnePlaceGate.IsCentred E] [AbelTheorem E]
+    [GenusOnePlaceGate E'] [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E']
+    [GenusOnePlaceGate D] [GenusOnePlaceGate.IsCentred D] [AbelTheorem D]
+    [GenusOnePlaceGate D'] [GenusOnePlaceGate.IsCentred D'] [AbelTheorem D']
+    (ι : E'.FunctionField →ₐ[ℂ] E.FunctionField) (hι : ι.toRingHom.IsIntegral)
+    (hfin : FiniteAlong ℂ ι)
+    (hN : NormFormulaAlong ℂ ι hfin)
+    (eE : D.FunctionField ≃ₐ[ℂ] E.FunctionField) (eE' : D'.FunctionField ≃ₐ[ℂ] E'.FunctionField)
+    (ι'' : D'.FunctionField →ₐ[ℂ] D.FunctionField) (hconj : ∀ x, eE (ι'' x) = ι (eE' x))
+    (hι'' : ι''.toRingHom.IsIntegral) (hfin'' : FiniteAlong ℂ ι'')
+    (hN'' : NormFormulaAlong ℂ ι'' hfin'')
+    (hcyc : IsAddCyclic (pointMapOfPushforward ι hι hfin hN).ker) :
+    IsAddCyclic (pointMapOfPushforward ι'' hι'' hfin'' hN'').ker ∧
+      Nat.card (pointMapOfPushforward ι'' hι'' hfin'' hN'').ker = Nat.card (pointMapOfPushforward ι
+        hι hfin hN).ker :=
+  solution E E' D D' ι hι hfin hN eE eE' ι'' hconj hι'' hfin'' hN'' hcyc
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_isAddCyclic_ker_pointMapOfPushforward_of_baseChange_algHom.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_isAddCyclic_ker_pointMapOfPushforward_of_baseChange_algHom.lean
new file mode 100644
index 0000000000..6d25854c25
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_isAddCyclic_ker_pointMapOfPushforward_of_baseChange_algHom.lean
@@ -0,0 +1,5264 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.Affine.isAddCyclic_ker_pointMapOfPushforward_of_baseChange_algHom
+(f4d949d7-d2e9-583c-970a-d2c81be54545) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission dc1eabf7-1867-53e3-b324-7414996a1c99
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FunctionFieldQuadratic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.Algebra.Algebra.Field
+import Mathlib.Algebra.Polynomial.Basis
+import Mathlib.AlgebraicTopology.FundamentalGroupoid.SimplyConnected
+import Mathlib.Analysis.Complex.Polynomial.Basic
+import Mathlib.Order.CompletePartialOrder
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AddCommGroup_nonempty_zmod_prod_addEquiv_torsionBy_of_card_torsionBy_eq_sq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_inv
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_evalAt_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_isUniformization_toPoint
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_natCard_ker_pointMapOfPushforward_eq_finrankAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsionBy_eq_sq_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_PeriodPair_discriminant_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_min_ord_le_ord_add_v2
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cyclic kernel of order N descends along base change
+
+Theorem statement:
+`WeierstrassCurve.Affine.isAddCyclic_ker_pointMapOfPushforward_of_baseChange_algHom`
+(`f4d949d7-d2e9-583c-970a-d2c81be54545`), by Claude, 2026-09-05.
+
+Proof: submission `dc1eabf7-1867-53e3-b324-7414996a1c99`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R_0$ be a field, let $E_0,E_0'$ be elliptic Weierstrass curves over $R_0$, and let
+$F_1\subseteq F_2$ be algebraically closed $R_0$-algebras of characteristic $0$ forming a scalar
+tower over $R_0$ (all in one universe), such that the four base changes $E_0\otimes F_i$,
+$E_0'\otimes F_i$ are elliptic and each of their affine models carries: a `GenusOnePlaceGate`, i.e.
+a bijection between its group of points and the places of its function field over the base field,
+all of degree $1$; the centredness condition that at the place attached to a point $(x,y)$ the
+classes of $X-x$ and $Y-y$ are nonunits of the valuation subring; and `AbelTheorem`, i.e. a
+degree-zero divisor is principal exactly when its divisor sum vanishes. Let $\chi$, resp. $\chi'$,
+be $F_1$-algebra maps from the function field of $E_0\otimes F_1$, resp. $E_0'\otimes F_1$, to that
+of $E_0\otimes F_2$, resp. $E_0'\otimes F_2$, carrying the coordinate function $x$ to $x$ and $y$ to
+$y$. Let $\iota_1$ be an $F_1$-algebra map from the function field of $E_0'\otimes F_1$ to that of
+$E_0\otimes F_1$ whose underlying ring map is integral, which makes the target a finite module over
+the source, and which satisfies the pushforward norm formula (for nonzero $f$ and a divisor $D$ with
+$D(w)=\mathrm{ord}_w f$ for all places $w$ upstairs, the pushforward of $D$ has value
+$\mathrm{ord}_v(\mathrm{N}f)$ at each place $v$ downstairs); let $\iota_2$ be the analogous datum
+over $F_2$, compatible with base change in the sense that $\iota_2(\chi'(x))=\chi(\iota_1(x))$ for
+all $x$. Let $N$ be a nonzero natural number. If the kernel of the map $(E_0\otimes
+F_2)(F_2)\to(E_0'\otimes F_2)(F_2)$ induced by divisor pushforward along $\iota_2$ is additively
+cyclic of cardinality $N$, then the kernel of the corresponding map $(E_0\otimes
+F_1)(F_1)\to(E_0'\otimes F_1)(F_1)$ induced by pushforward along $\iota_1$ is additively cyclic of
+cardinality $N$ as well.
+
+The statement transports the cyclicity and the order of the kernel of an isogeny, realised here as
+the map on points coming from divisor pushforward along an inclusion of function fields, downwards
+along an extension of algebraically closed fields of characteristic $0$ over a common base. It is
+used by
+[`WeierstrassCurve.Affine.
+exists_intermediateField_countable_map_eq_of_isAddCyclic_ker_pointMapOfPushforward`]
+(thm.html#WeierstrassCurve.Affine.
+exists_intermediateField_countable_map_eq_of_isAddCyclic_ker_pointMapOfPushforward),
+which descends such a configuration to a countable intermediate field.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_isAddCyclic_ker_pointMapOfPushforward_of_baseChange_algHom.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 25600000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_55b03433
+
+
+noncomputable section
+
+section
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial IsDedekindDomain \
+  P2MW.S_OVERLONG_55b03433.IsDedek\
+  indDomain WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial.Bivariate"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem S13_ofHeightOneSpectrum_injective {R : Type*} [CommRing R] [IsDedekindDomain R]
+    [Algebra R W.FunctionField] [IsFractionRing R W.FunctionField] [Algebra F R]
+    [IsScalarTower F R W.FunctionField] :
+    Function.Injective (AlgebraicCurve.Place.ofHeightOneSpectrum (K := F) (R := R) (F :=
+      W.FunctionField)) := by
+  intro w₁ w₂ h
+  refine HeightOneSpectrum.eq_of_valuation_isEquiv_valuation (K := W.FunctionField) ?_
+  rw [Valuation.isEquiv_iff_valuationSubring]
+  exact congrArg AlgebraicCurve.Place.toValuationSubring h
+
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "XYIdeal quotientXYIdealEquiv XClass_ne_zero \
+  YClass mk map basis_apply map_injective map_mk exists_smul_basis_eq XClass smul_basis_mul_Y \
+  YClass_ne_zero isDedekindDomain exists_eq_XYIdeal XYIdeal_isMaximal XYIdeal_ne_bot"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt"
+
+theorem algebraMap_eq_mk_C_C (a : F) :
+    algebraMap F W.CoordinateRing a = CoordinateRing.mk W (C (C a)) := by
+  rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+    Algebra.algebraMap_self_apply]
+  rfl
+
+theorem eq_of_XYIdeal_eq {x₁ y₁ x₂ y₂ : F} (h₂ : W.Equation x₂ y₂)
+    (h : XYIdeal W x₁ (C y₁) = XYIdeal W x₂ (C y₂)) : x₁ = x₂ ∧ y₁ = y₂ := by
+  have hne : XYIdeal W x₂ (C y₂) ≠ ⊤ := (XYIdeal_isMaximal h₂).ne_top
+  have hX₁ : XClass W x₁ ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert _ _)
+  have hX₂ : XClass W x₂ ∈ XYIdeal W x₂ (C y₂) := Ideal.subset_span (Set.mem_insert _ _)
+  have hY₁ : YClass W (C y₁) ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  have hY₂ : YClass W (C y₂) ∈ XYIdeal W x₂ (C y₂) :=
+    Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  constructor
+  · by_contra hx
+    apply hne
+    have hsub : XClass W x₁ - XClass W x₂ = algebraMap F W.CoordinateRing (x₂ - x₁) := by
+      rw [XClass, XClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      rw [← map_sub]
+      congr 1
+      rw [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hX₁ hX₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hx hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+  · by_contra hy
+    apply hne
+    have hsub : YClass W (C y₁) - YClass W (C y₂) = algebraMap F W.CoordinateRing (y₂ - y₁) := by
+      rw [YClass, YClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      simp only [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hY₁ hY₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hy hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+
+def heightOneSpectrumOfEquation {x y : F} (h : W.Equation x y) :
+    HeightOneSpectrum W.CoordinateRing where
+  asIdeal := XYIdeal W x (C y)
+  isPrime := (XYIdeal_isMaximal h).isPrime
+  ne_bot := XYIdeal_ne_bot x (C y)
+
+@[scoped simp]
+theorem heightOneSpectrumOfEquation_asIdeal {x y : F} (h : W.Equation x y) :
+    (heightOneSpectrumOfEquation h).asIdeal = XYIdeal W x (C y) := rfl
+
+theorem exists_sub_algebraMap_mem {x y : F} (h : W.Equation x y) (r : W.CoordinateRing) :
+    ∃ c : F, r - algebraMap F W.CoordinateRing c ∈ XYIdeal W x (C y) := by
+  set e := quotientXYIdealEquiv (W' := W) (x := x) (y := C y) h
+  refine ⟨e (Ideal.Quotient.mk _ r), ?_⟩
+  rw [← Ideal.Quotient.eq_zero_iff_mem, map_sub, sub_eq_zero]
+  apply e.injective
+  rw [← Ideal.Quotient.algebraMap_eq, ← IsScalarTower.algebraMap_apply, AlgEquiv.commutes,
+    Algebra.algebraMap_self_apply]
+
+end CoordinateRing
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine.CoordinateRing"
+
+def IsFinitePlace (v : AlgebraicCurve.Place F W.FunctionField) : Prop :=
+  ∀ r : W.CoordinateRing, algebraMap W.CoordinateRing W.FunctionField r ∈ v.toValuationSubring
+
+def IsFinitePlace.ringHom {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    W.CoordinateRing →+* v.toValuationSubring where
+  toFun r := ⟨algebraMap W.CoordinateRing W.FunctionField r, hv r⟩
+  map_one' := Subtype.ext (map_one _)
+  map_mul' a b := Subtype.ext (map_mul _ a b)
+  map_zero' := Subtype.ext (map_zero _)
+  map_add' a b := Subtype.ext (map_add _ a b)
+
+@[scoped simp]
+theorem IsFinitePlace.coe_ringHom_apply {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) (r : W.CoordinateRing) :
+    (hv.ringHom r : W.FunctionField) = algebraMap W.CoordinateRing W.FunctionField r := rfl
+
+
+def IsFinitePlace.centre {v : AlgebraicCurve.Place F W.FunctionField} (hv : IsFinitePlace v) :
+    Ideal W.CoordinateRing :=
+  (IsLocalRing.maximalIdeal v.toValuationSubring).comap hv.ringHom
+
+theorem IsFinitePlace.centre_isPrime {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre.IsPrime :=
+  Ideal.IsPrime.comap _
+
+theorem IsFinitePlace.inv_mem {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) {r : W.CoordinateRing} (hr : r ∉ hv.centre) :
+    (algebraMap W.CoordinateRing W.FunctionField r)⁻¹ ∈ v.toValuationSubring := by
+  have hunit : IsUnit (hv.ringHom r) := by
+    rw [IsFinitePlace.centre, Ideal.mem_comap, IsLocalRing.mem_maximalIdeal,
+      mem_nonunits_iff, not_not] at hr
+    exact hr
+  obtain ⟨t, ht⟩ := hunit.exists_right_inv
+  have ht' : algebraMap W.CoordinateRing W.FunctionField r * (t : W.FunctionField) = 1 := by
+    have := congrArg (fun a : v.toValuationSubring => (a : W.FunctionField)) ht
+    simpa using this
+  rw [inv_eq_of_mul_eq_one_right ht']
+  exact t.2
+
+theorem IsFinitePlace.centre_ne_bot {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) : hv.centre ≠ ⊥ := by
+  intro hbot
+  apply v.ne_top'
+  rw [eq_top_iff]
+  rintro z -
+  obtain ⟨r, s, hs, hz⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  have hs0 : s ∉ hv.centre := by
+    rw [hbot, Ideal.mem_bot]
+    exact fun h => nonZeroDivisors.ne_zero hs h
+  rw [← hz, div_eq_mul_inv]
+  exact mul_mem (hv r) (hv.inv_mem hs0)
+
+variable [IsDedekindDomain W.CoordinateRing]
+
+def placeOfEquation {x y : F} (h : W.Equation x y) :
+    AlgebraicCurve.Place F W.FunctionField :=
+  AlgebraicCurve.Place.ofHeightOneSpectrum (heightOneSpectrumOfEquation h)
+
+theorem placeOfEquation_injective {x₁ y₁ x₂ y₂ : F} (h₁ : W.Equation x₁ y₁)
+    (h₂ : W.Equation x₂ y₂) (h : placeOfEquation h₁ = placeOfEquation h₂) :
+    x₁ = x₂ ∧ y₁ = y₂ :=
+  eq_of_XYIdeal_eq h₂
+    (congrArg HeightOneSpectrum.asIdeal (S13_ofHeightOneSpectrum_injective h))
+
+theorem isFinitePlace_placeOfEquation {x y : F} (h : W.Equation x y) :
+    IsFinitePlace (placeOfEquation h) := fun r =>
+  (heightOneSpectrumOfEquation h).valuation_le_one r
+
+theorem isFinitePlace_iff_exists_placeOfEquation [IsAlgClosed F]
+    (v : AlgebraicCurve.Place F W.FunctionField) :
+    IsFinitePlace v ↔ ∃ (x y : F) (h : W.Equation x y), v = placeOfEquation h := by
+  constructor
+  · intro hv
+    have := hv.centre_isPrime
+    have hmax : hv.centre.IsMaximal := Ideal.IsPrime.isMaximal hv.centre_isPrime hv.centre_ne_bot
+    obtain ⟨x, y, hxy, hXY⟩ :=
+      CoordinateRing.exists_eq_XYIdeal (W := W) (P := hv.centre) hv.centre_ne_bot
+    refine ⟨x, y, hxy, ?_⟩
+    set w : HeightOneSpectrum W.CoordinateRing := heightOneSpectrumOfEquation hxy with hw
+    set A : ValuationSubring W.FunctionField :=
+      HeightOneSpectrum.valuationSubringAtPrime W.FunctionField w with hA
+    have hAded : IsDedekindDomain A := by rw [hA]; infer_instance
+    have hle : A ≤ v.toValuationSubring := by
+      intro z hz
+      rw [hA] at hz
+      obtain ⟨r, s, hs, rfl⟩ := hz
+      have hs' : s ∉ hv.centre := by
+        intro hmem
+        rw [hXY] at hmem
+        exact hs hmem
+      exact mul_mem (hv r) (hv.inv_mem hs')
+    have hSP : A.ofPrime (A.idealOfLE v.toValuationSubring hle) = v.toValuationSubring :=
+      ValuationSubring.ofPrime_idealOfLE A v.toValuationSubring hle
+    rcases eq_or_ne (A.idealOfLE v.toValuationSubring hle) ⊥ with hP | hP
+    · exfalso
+      apply v.ne_top'
+      have h2 : A.ofPrime ⊥ ≤ A.ofPrime (A.idealOfLE v.toValuationSubring hle) :=
+        ValuationSubring.ofPrime_le_of_le (h := hP.le)
+      rw [ValuationSubring.ofPrime_bot] at h2
+      exact top_le_iff.mp (le_trans h2 hSP.le)
+    · have hPmax : (A.idealOfLE v.toValuationSubring hle).IsMaximal :=
+        Ideal.IsPrime.isMaximal inferInstance hP
+      have hPeq : A.idealOfLE v.toValuationSubring hle = IsLocalRing.maximalIdeal A :=
+        IsLocalRing.eq_maximalIdeal hPmax
+      have h3 : A.ofPrime (A.idealOfLE v.toValuationSubring hle)
+          = A.ofPrime (IsLocalRing.maximalIdeal A) :=
+        le_antisymm (ValuationSubring.ofPrime_le_of_le (h := hPeq.ge))
+          (ValuationSubring.ofPrime_le_of_le (h := hPeq.le))
+      rw [ValuationSubring.ofPrime_top] at h3
+      have hAv : A = v.toValuationSubring := h3.symm.trans hSP
+      refine (AlgebraicCurve.Place.ext ?_).symm
+      change (AlgebraicCurve.Place.ofHeightOneSpectrum w).toValuationSubring = v.toValuationSubring
+      rw [AlgebraicCurve.Place.ofHeightOneSpectrum_toValuationSubring,
+        ← HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact hAv
+  · rintro ⟨x, y, h, rfl⟩
+    exact isFinitePlace_placeOfEquation h
+
+scoped instance S13_instIsDedekindDomainCoordinateRing [IsAlgClosed F] [W.IsElliptic] :
+    IsDedekindDomain W.CoordinateRing :=
+  CoordinateRing.isDedekindDomain (W := W)
+
+section CentredGate
+
+variable [DecidableEq F] [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W]
+
+omit [DecidableEq F] in
+@[scoped simp]
+theorem placeOfPoint_some {x y : F} (h : W.Nonsingular x y) :
+    placeOfPoint (.some x y h) = placeOfEquation h.left := by
+  classical
+  exact
+    placeOfPoint_some_eq_ofHeightOneSpectrum h (heightOneSpectrumOfEquation h.left) rfl
+
+namespace InfinitePlace
+
+def place : AlgebraicCurve.Place F W.FunctionField := placeOfPoint (0 : W.Point)
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+private theorem _root_.WeierstrassCurve.Affine.InfinitePlace.deg_eq_one :
+    (place : AlgebraicCurve.Place F W.FunctionField).deg = 1 := by
+  classical
+  exact
+    deg_placeOfPoint (W := W) 0
+
+p2m_export "WeierstrassCurve.Affine.InfinitePlace" "deg_eq_one"
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] in
+theorem not_isFinitePlace [IsAlgClosed F] [W.IsElliptic] :
+    ¬ IsFinitePlace (place : AlgebraicCurve.Place F W.FunctionField) := by
+  classical
+  exact
+    fun h =>
+     algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero (W := W) (h _)
+
+omit [DecidableEq F] in
+theorem eq_of_not_isFinitePlace
+    (v : AlgebraicCurve.Place F W.FunctionField) (hv : ¬ IsFinitePlace v) :
+    v = place := by
+  classical
+  obtain ⟨P, rfl⟩ : ∃ P : W.Point, placeOfPoint P = v :=
+    ⟨(pointEquivPlace (W := W)).symm v, (pointEquivPlace (W := W)).apply_symm_apply v⟩
+  cases P with
+  | zero => rfl
+  | some x y h =>
+      exact absurd (placeOfPoint_some (W := W) h ▸ isFinitePlace_placeOfEquation h.left) hv
+
+end InfinitePlace
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+@[scoped simp]
+theorem placeOfPoint_zero : placeOfPoint (.zero : W.Point) = InfinitePlace.place := by
+  classical
+  exact
+    rfl
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_zero' : placeOfPoint (0 : W.Point) = InfinitePlace.place := by
+  classical
+  exact
+    rfl
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_injective : Function.Injective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).injective
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_surjective (_hΔ : W.Δ ≠ 0) : Function.Surjective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).surjective
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_surjective' : Function.Surjective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).surjective
+
+end CentredGate
+end Affine
+end WeierstrassCurve
+end
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+end WeierstrassCurve
+p2m_open_scoped "WeierstrassCurve" in
+theorem WeierstrassCurve.nonempty_pointTorsionBy_zmod {K : Type*} [Field K] [DecidableEq K]
+    [IsAlgClosed K] [CharZero K]
+    (W : WeierstrassCurve K) [W.IsElliptic] {n : ℕ} (hn : 1 ≤ n) :
+    Nonempty (↥(Submodule.torsionBy ℤ W.toAffine.Point (n : ℤ)) ≃+ (Fin 2 → ZMod n)) := by
+  obtain ⟨e⟩ := AddCommGroup.nonempty_zmod_prod_addEquiv_torsionBy_of_card_torsionBy_eq_sq
+    (A := W.toAffine.Point) (n := n) (by omega)
+    (fun d hd => WeierstrassCurve.card_torsionBy_eq_sq_of_isAlgClosed W (n := d)
+      (by exact_mod_cast (Nat.pos_of_dvd_of_pos hd (by omega)).ne'))
+  exact ⟨e.symm.trans (LinearEquiv.piFinTwo ℤ (fun _ : Fin 2 => ZMod n)).toAddEquiv.symm⟩
+
+section
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve"
+
+scoped instance instHasPrincipalDivisorsFunctionField_s13 {F : Type*} [Field F] [CharZero F]
+    {W : Affine F} : HasPrincipalDivisors F W.FunctionField :=
+  hasPrincipalDivisors_functionField W
+
+section AutoNorm
+variable {F : Type*} [Field F] [CharZero F]
+variable {V W : Affine F} [V.IsElliptic] [W.IsElliptic]
+
+omit [WeierstrassCurve.IsElliptic V] [WeierstrassCurve.IsElliptic W] in
+theorem normFormulaAlong_of_elliptic (ι : V.FunctionField →ₐ[F] W.FunctionField)
+    (hfin : FiniteAlong F ι) : NormFormulaAlong F ι hfin := by
+  classical
+  have : HasPrincipalDivisors F W.FunctionField := hasPrincipalDivisors_functionField W
+  have : CharZero V.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap F V.FunctionField).injective
+  have hsep : SeparableAlong F ι := by
+    let := algebraAlong ι
+    have := isScalarTower_along ι
+    have : Module.Finite V.FunctionField W.FunctionField := hfin
+    change Algebra.IsSeparable V.FunctionField W.FunctionField
+    infer_instance
+  exact AlgebraicCurve.normFormulaAlong ι hfin hsep
+
+end AutoNorm
+
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι"
+p2m_open "WeierstrassCurve.Affine.IsogenyEndDatum"
+
+variable {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [GenusOnePlaceGate W] [AbelTheorem W]
+
+omit [DecidableEq F] [W.GenusOnePlaceGate] [W.AbelTheorem] in
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+private theorem _root_.WeierstrassCurve.Affine.IsogenyEndDatum.normFormulaAlong_auto (D :
+  IsogenyEndDatum W) :
+    NormFormulaAlong F D.ι D.hfin :=
+  normFormulaAlong_of_elliptic D.ι D.hfin
+
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "normFormulaAlong_auto"
+
+private def _root_.WeierstrassCurve.Affine.IsogenyEndDatum.pointEnd' (D : IsogenyEndDatum W) :
+    AddMonoid.End W.Point := D.pointEnd D.normFormulaAlong_auto
+
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd'"
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd_eq_pointEnd' (D : IsogenyEndDatum W) (hN : NormFormulaAlong F D.ι D.hfin) :
+    D.pointEnd hN = D.pointEnd' := rfl
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd'_apply (D : IsogenyEndDatum W) (P : W.Point) :
+    D.pointEnd' P = genusOnePic0Equiv W
+      (Pic0.pushforwardAlongHom D.ι D.hι D.hfin D.normFormulaAlong_auto (pointClass P)) :=
+  pointEnd_apply D _ P
+
+omit [IsAlgClosed F] [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd'_eq_of_seam (D : IsogenyEndDatum W) (g : W.Point → W.Point) (hg0 : g 0 = 0)
+    (hg : ∀ P, (placeOfPoint P).restrictAlong D.ι D.hι = placeOfPoint (g P)) (P : W.Point) :
+    D.pointEnd' P = g P :=
+  pointEnd_eq_of_seam D _ g hg0 hg P
+
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+end
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+end Affine
+end WeierstrassCurve
+p2m_open_scoped "WeierstrassCurve WeierstrassCurve.Affine" in
+scoped instance WeierstrassCurve.Affine.instHasPrincipalDivisorsFunctionField_s13e2
+    {F : Type*} [Field F] [CharZero F] (W : WeierstrassCurve.Affine F) :
+    AlgebraicCurve.HasPrincipalDivisors F W.FunctionField :=
+  WeierstrassCurve.Affine.hasPrincipalDivisors_functionField W
+
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg"
+
+section MoreSinglePlace
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem _root_.AlgebraicCurve.Place.isRational_of_deg_eq_one (h : v.deg = 1) :
+    v.IsRational := by
+  intro x
+  have hbot : (⊥ : Subalgebra K v.ResidueField) = ⊤ :=
+    Subalgebra.bot_eq_top_iff_finrank_eq_one.mpr h
+  have hx : x ∈ (⊥ : Subalgebra K v.ResidueField) := by
+    rw [hbot]
+    exact Algebra.mem_top
+  exact Algebra.mem_bot.mp hx
+
+p2m_export "AlgebraicCurve.Place" "isRational_of_deg_eq_one"
+
+theorem evalAt_div (hv : v.IsRational) {f g : F} (hf : f ∈ v.toValuationSubring)
+    (hg : g ≠ 0) (hg0 : v.ord g = 0) :
+    v.evalAt (f / g) = v.evalAt f / v.evalAt g := by
+  have hginv : g⁻¹ ∈ v.toValuationSubring :=
+    AlgebraicCurve.Place.mem_of_ord_nonneg v (inv_ne_zero hg) (by
+      rw [v.ord_inv, hg0]; exact neg_nonneg.mpr le_rfl)
+  rw [div_eq_mul_inv, v.evalAt_mul hv hf hginv, v.evalAt_inv hv hg hg0, div_eq_mul_inv]
+
+end MoreSinglePlace
+
+theorem mem_restrictAlong_iff {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F]
+    [Algebra K F']
+    (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') (f : F) :
+    f ∈ (w.restrictAlong φ hφ).toValuationSubring ↔ φ f ∈ w.toValuationSubring :=
+  Iff.rfl
+
+end Place
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial.Bivariate"
+
+section FinitePlaceOfMem
+variable {F : Type*} [Field F] {W : Affine F}
+variable (v : AlgebraicCurve.Place F W.FunctionField)
+
+theorem isFinitePlace_of_mem
+    (hx : polyToFunctionField W X ∈ v.toValuationSubring) : IsFinitePlace v := by
+  have hpoly : ∀ p : F[X], polyToFunctionField W p ∈ v.toValuationSubring := by
+    intro p
+    induction p using Polynomial.induction_on' with
+    | add f g hf hg => rw [map_add]; exact add_mem hf hg
+    | monomial n c =>
+        rw [← C_mul_X_pow_eq_monomial, map_mul, map_pow]
+        refine mul_mem ?_ (pow_mem hx n)
+        rw [polyToFunctionField_C]
+        exact v.algebraMap_mem' c
+  set η := algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y) with hηdef
+  set c₁ : F[X] := C W.a₁ * X + C W.a₃ with hc₁def
+  set cb : F[X] := X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ with hcbdef
+  have hrel : η * η = polyToFunctionField W cb - polyToFunctionField W c₁ * η := by
+    have h1 := smul_basis_mul_Y (W' := W) 0 1
+    rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at h1
+    have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) h1
+    rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+    exact h2
+  have hy : η ∈ v.toValuationSubring := by
+    refine v.mem_of_eval_monic_eq_zero (P := Polynomial.X ^ 2
+      + (Polynomial.C (polyToFunctionField W c₁) * Polynomial.X
+        - Polynomial.C (polyToFunctionField W cb))) ?_ ?_ (x := η) ?_
+    · refine Polynomial.monic_X_pow_add (n := 2) ?_
+      rw [sub_eq_add_neg, ← Polynomial.C_neg]
+      refine lt_of_le_of_lt Polynomial.degree_linear_le ?_
+      exact_mod_cast Nat.one_lt_two
+    · intro i
+      rw [show (Polynomial.C (polyToFunctionField W c₁) * Polynomial.X : Polynomial _)
+          = Polynomial.C (polyToFunctionField W c₁) * Polynomial.X ^ 1 by ring]
+      simp only [Polynomial.coeff_add, Polynomial.coeff_sub, Polynomial.coeff_X_pow,
+        Polynomial.coeff_C_mul, Polynomial.coeff_C]
+      refine add_mem ?_ (sub_mem ?_ ?_)
+      · split <;> simp [v.toValuationSubring.one_mem, v.toValuationSubring.zero_mem]
+      · split
+        · rw [mul_one]; exact hpoly _
+        · rw [mul_zero]; exact v.toValuationSubring.zero_mem
+      · split
+        · exact hpoly _
+        · exact v.toValuationSubring.zero_mem
+    · simp only [Polynomial.eval_add, Polynomial.eval_sub, Polynomial.eval_pow,
+        Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_X]
+      rw [sq]
+      linear_combination hrel
+  intro r
+  obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq r
+  rw [algebraMap_smul_basis]
+  exact add_mem (hpoly p) (mul_mem (hpoly q) hy)
+
+end FinitePlaceOfMem
+
+section RationalPlaceOfEquation
+variable {F : Type*} [Field F] {W : Affine F} [W.IsElliptic]
+  [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [IsDedekindDomain W.CoordinateRing]
+
+theorem isRational_placeOfEquation {r s : F} (hrs : W.Equation r s) :
+    (placeOfEquation hrs).IsRational := by
+  classical
+  apply (placeOfEquation hrs).isRational_of_deg_eq_one
+  rw [← placeOfPoint_some (equation_iff_nonsingular.mp hrs)]
+  exact GenusOnePlaceGate.deg_eq_one _
+
+end RationalPlaceOfEquation
+end Affine
+end WeierstrassCurve
+
+namespace ModularCurve
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg\
+  " in
+open _root_.WeierstrassCurve
+  _root_.P2MW.S_OVERLONG_55b03433.WeierstrassCurve
+  _root_.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_55b03433.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_55b03433.AlgebraicCurve
+  in
+theorem kw_fdn2_qephod_hend7_pmopKerCard_proved
+    (K : Type*) [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+    (E E' : WeierstrassCurve.Affine K) [E.IsElliptic]
+    [GenusOnePlaceGate E] [GenusOnePlaceGate.IsCentred E] [AbelTheorem E]
+    [E'.IsElliptic] [GenusOnePlaceGate E'] [GenusOnePlaceGate.IsCentred E'] [AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong K ι) :
+    Nat.card ((pointMapOfPushforward ι hι hfin
+      (normFormulaAlong_of_elliptic ι hfin)).ker) = finrankAlong K ι :=
+  natCard_ker_pointMapOfPushforward_eq_finrankAlong E E' ι hι hfin _
+end ModularCurve
+
+
+section
+open Complex Filter Set
+
+p2m_open_scoped "PeriodPair \
+  P2MW.S_OVERLONG_55b03433.PeriodP\
+  air"
+
+namespace PeriodPair
+p2m_export "PeriodPair" "derivWeierstrassP_neg weierstrassP_neg lattice weierstrassP_add_coe \
+  lattice_eq_span_range_basis ω₁ mk g₃ ω₂ derivWeierstrassP_add_coe mem_lattice G g₂ \
+  weierstrassCurve weierstrassCurve_a₁ weierstrassCurve_a₃ DiscriminantNeZero toPoint \
+  toPoint_of_mem toPoint_zero toPoint_of_notMem IsUniformization jLattice scale_indep scale \
+  discriminant_ne_zero isUniformization_toPoint"
+p2m_open "PeriodPair"
+
+variable (L : PeriodPair)
+
+private theorem _root_.PeriodPair.kw_discriminantNeZero :
+    L.DiscriminantNeZero := L.discriminant_ne_zero
+
+p2m_export "PeriodPair" "kw_discriminantNeZero"
+
+private theorem _root_.PeriodPair.kw_isUniformization :
+    L.IsUniformization L.kw_discriminantNeZero :=
+  L.isUniformization_toPoint _
+
+p2m_export "PeriodPair" "kw_isUniformization"
+
+private theorem _root_.PeriodPair.kw_toPoint_add (hD : L.DiscriminantNeZero) (z w : ℂ) :
+    L.toPoint hD (z + w) = L.toPoint hD z + L.toPoint hD w :=
+  (L.isUniformization_toPoint hD).1 z w
+
+p2m_export "PeriodPair" "kw_toPoint_add"
+
+theorem kw_toPoint_surjective (hD : L.DiscriminantNeZero) : Function.Surjective (L.toPoint hD) :=
+  (L.isUniformization_toPoint hD).2.1
+
+theorem kw_toPoint_eq_zero_iff (hD : L.DiscriminantNeZero) (z : ℂ) :
+    L.toPoint hD z = 0 ↔ z ∈ L.lattice :=
+  ⟨(L.isUniformization_toPoint hD).2.2 z, fun hz => L.toPoint_of_mem hD hz⟩
+
+scoped instance kw_instIsElliptic : L.weierstrassCurve.IsElliptic :=
+  ⟨isUnit_iff_ne_zero.mpr L.kw_discriminantNeZero.weierstrassCurve_Δ_ne_zero⟩
+
+section Liouville
+
+private theorem _root_.PeriodPair.sub_fract_mem_lattice (z : ℂ) :
+    z - ZSpan.fract L.basis z ∈ L.lattice := by
+  rw [L.lattice_eq_span_range_basis]
+  have h := (ZSpan.fract_eq_fract L.basis (ZSpan.fract L.basis z) z).mp
+    (by rw [ZSpan.fract_eq_self.mpr (ZSpan.fract_mem_fundamentalDomain L.basis z)])
+  simpa [neg_add_eq_sub] using h
+
+p2m_export "PeriodPair" "sub_fract_mem_lattice"
+
+private theorem _root_.PeriodPair.apply_eq_apply_of_differentiable_of_forall_periodic {f : ℂ → ℂ}
+    (hf : Differentiable ℂ f) (hper : ∀ l ∈ L.lattice, ∀ z, f (z + l) = f z) (z w : ℂ) :
+    f z = f w := by
+  apply hf.apply_eq_apply_of_bounded
+  have hrange : range f ⊆ f '' closure (ZSpan.fundamentalDomain L.basis) := by
+    rintro - ⟨u, rfl⟩
+    refine ⟨ZSpan.fract L.basis u, subset_closure (ZSpan.fract_mem_fundamentalDomain _ u), ?_⟩
+    have h := hper _ (L.sub_fract_mem_lattice u) (ZSpan.fract L.basis u)
+    rw [add_sub_cancel] at h
+    exact h.symm
+  refine Bornology.IsBounded.subset ?_ hrange
+  refine (IsCompact.image ?_ hf.continuous).isBounded
+  exact Metric.isCompact_of_isClosed_isBounded isClosed_closure
+    (ZSpan.fundamentalDomain_isBounded L.basis).closure
+
+p2m_export "PeriodPair" "apply_eq_apply_of_differentiable_of_forall_periodic"
+end Liouville
+
+section ToPointLemmas
+
+theorem toPoint_add_mem (h : L.DiscriminantNeZero) (z : ℂ) {l : ℂ} (hl : l ∈ L.lattice) :
+    L.toPoint h (z + l) = L.toPoint h z := by
+  by_cases hz : z ∈ L.lattice
+  · rw [L.toPoint_of_mem h hz, L.toPoint_of_mem h (add_mem hz hl)]
+  · have hzl : z + l ∉ L.lattice := fun hmem => hz (by simpa using sub_mem hmem hl)
+    rw [L.toPoint_of_notMem h hz, L.toPoint_of_notMem h hzl]
+    have hP : ℘[L] (z + l) = ℘[L] z := L.weierstrassP_add_coe z ⟨l, hl⟩
+    have hP' : ℘'[L] (z + l) = ℘'[L] z := L.derivWeierstrassP_add_coe z ⟨l, hl⟩
+    simp only [WeierstrassCurve.Affine.Point.some.injEq]
+    exact ⟨hP, by rw [hP']⟩
+
+theorem toPoint_neg (h : L.DiscriminantNeZero) (z : ℂ) :
+    L.toPoint h (-z) = -L.toPoint h z := by
+  by_cases hz : z ∈ L.lattice
+  · rw [L.toPoint_of_mem h hz, L.toPoint_of_mem h (neg_mem hz)]; rfl
+  · have hnz : -z ∉ L.lattice := fun hmem => hz (by simpa using neg_mem hmem)
+    rw [L.toPoint_of_notMem h hz, L.toPoint_of_notMem h hnz,
+      WeierstrassCurve.Affine.Point.neg_some]
+    simp only [WeierstrassCurve.Affine.Point.some.injEq]
+    refine ⟨L.weierstrassP_neg z, ?_⟩
+    rw [L.derivWeierstrassP_neg]
+    show -℘'[L] z / 2 = L.weierstrassCurve.toAffine.negY (℘[L] z) (℘'[L] z / 2)
+    rw [WeierstrassCurve.Affine.negY, weierstrassCurve_a₁, weierstrassCurve_a₃]
+    ring
+
+end ToPointLemmas
+
+section Isogeny
+
+private theorem _root_.PeriodPair.apply_eq_apply_of_continuous_of_mapsTo_lattice {f : ℂ → ℂ}
+    (hf : Continuous f)
+    (hmem : ∀ z, f z ∈ L.lattice) (z w : ℂ) : f z = f w := by
+  refine IsPreconnected.constant_of_mapsTo (isPreconnected_univ) ?_
+    hf.continuousOn (fun u _ => hmem u) (mem_univ z) (mem_univ w)
+  rw [isDiscrete_iff_discreteTopology]
+  exact inferInstanceAs (DiscreteTopology L.lattice)
+
+p2m_export "PeriodPair" "apply_eq_apply_of_continuous_of_mapsTo_lattice"
+
+theorem exists_smul_mem_and_apply_eq_of_forall_sub_mem (L' : PeriodPair) {F : ℂ → ℂ}
+    (hF : Differentiable ℂ F)
+    (hper : ∀ l ∈ L.lattice, ∀ z, F (z + l) - F z ∈ L'.lattice) :
+    ∃ α : ℂ, (∀ l ∈ L.lattice, α * l ∈ L'.lattice) ∧ ∀ z, F z = F 0 + α * z := by
+  have hFc : Continuous F := hF.continuous
+  have hconst : ∀ l ∈ L.lattice, ∀ z, F (z + l) - F z = F l - F 0 := by
+    intro l hl z
+    have h := L'.apply_eq_apply_of_continuous_of_mapsTo_lattice
+      (f := fun u => F (u + l) - F u)
+      ((hFc.comp (continuous_id.add continuous_const)).sub hFc) (hper l hl) z 0
+    simpa using h
+  have hadd : ∀ z w, F (z + w) = F z + F w - F 0 := by
+    intro z w
+    have hper' : ∀ l ∈ L.lattice, ∀ u,
+        (fun u => F (u + w) - F u) (u + l) = (fun u => F (u + w) - F u) u := by
+      intro l hl u
+      have h1 := hconst l hl (u + w)
+      have h2 := hconst l hl u
+      rw [show u + w + l = u + l + w by ring] at h1
+      simp only
+      linear_combination h1 - h2
+    have h := L.apply_eq_apply_of_differentiable_of_forall_periodic
+      (f := fun u => F (u + w) - F u)
+      ((hF.comp (differentiable_id.add_const w)).sub hF) hper' z 0
+    simp only [zero_add] at h
+    linear_combination h
+  set α : ℂ := deriv F 0 with hα
+  have hderiv : ∀ z, deriv F z = α := by
+    intro z
+    have hfun : (fun w => F (z + w)) = fun w => F w + (F z - F 0) := by
+      funext w
+      rw [hadd z w]; ring
+    have h1 : deriv (fun w => F (z + w)) 0 = deriv F z := by
+      rw [deriv_comp_const_add]
+      simp
+    have h2 : deriv (fun w => F w + (F z - F 0)) 0 = deriv F 0 := by
+      rw [deriv_add_const]
+    rw [← h1, hfun, h2]
+  have haffine : ∀ z, F z = F 0 + α * z := by
+    have hG : Differentiable ℂ fun z => F z - α * z :=
+      hF.sub (differentiable_id.const_mul α)
+    have hG' : ∀ z, deriv (fun z => F z - α * z) z = 0 := by
+      intro z
+      have hd : HasDerivAt (fun z => F z - α * z) (deriv F z - α * 1) z :=
+        (hF z).hasDerivAt.sub ((hasDerivAt_id z).const_mul α)
+      rw [hd.deriv, hderiv z]
+      ring
+    intro z
+    have h := is_const_of_deriv_eq_zero hG hG' z 0
+    simp only [mul_zero, sub_zero] at h
+    linear_combination h
+  refine ⟨α, fun l hl => ?_, haffine⟩
+  have h := hper l hl 0
+  rw [zero_add, haffine l] at h
+  simpa using h
+
+end Isogeny
+
+section Scale
+
+variable (α : ℂˣ)
+
+private def mulLeftR (a : ℂ) : ℂ →ₗ[ℝ] ℂ := Algebra.lmul ℝ ℂ a
+
+@[scoped simp] private theorem mulLeftR_apply (a z : ℂ) : mulLeftR a z = a * z := rfl
+
+private theorem mulLeftR_injective {a : ℂ} (ha : a ≠ 0) :
+    Function.Injective (mulLeftR a) := fun _ _ h => by
+  simpa using mul_left_cancel₀ ha h
+
+private def mulLeftZ (a : ℂ) : ℂ →ₗ[ℤ] ℂ := (mulLeftR a).restrictScalars ℤ
+
+@[scoped simp] private theorem mulLeftZ_apply (a z : ℂ) : mulLeftZ a z = a * z := rfl
+
+private theorem _root_.PeriodPair.scale_lattice :
+    (L.scale α).lattice = Submodule.map (mulLeftZ (α : ℂ)) L.lattice := by
+  unfold lattice scale
+  rw [Submodule.map_span]
+  congr 1
+  ext z
+  simp only [Set.mem_insert_iff, Set.mem_singleton_iff, Set.mem_image, mulLeftZ_apply]
+  constructor
+  · rintro (rfl | rfl)
+    · exact ⟨L.ω₁, Or.inl rfl, rfl⟩
+    · exact ⟨L.ω₂, Or.inr rfl, rfl⟩
+  · rintro ⟨w, hw | hw, rfl⟩ <;> simp [hw]
+
+p2m_export "PeriodPair" "scale_lattice"
+theorem mem_scale_lattice_iff {z : ℂ} :
+    z ∈ (L.scale α).lattice ↔ ∃ l ∈ L.lattice, z = (α : ℂ) * l := by
+  rw [scale_lattice, Submodule.mem_map]; simp only [mulLeftZ_apply]; tauto
+
+private def _root_.PeriodPair.scaleLatticeEquiv : L.lattice ≃ₗ[ℤ] (L.scale α).lattice :=
+  (Submodule.equivMapOfInjective (mulLeftZ (α : ℂ))
+    (fun _ _ h => mul_left_cancel₀ α.ne_zero (by simpa using h)) L.lattice).trans
+    (LinearEquiv.ofEq _ _ (L.scale_lattice α).symm)
+
+p2m_export "PeriodPair" "scaleLatticeEquiv"
+@[scoped simp] theorem scaleLatticeEquiv_apply (l : L.lattice) :
+    ((L.scaleLatticeEquiv α l : (L.scale α).lattice) : ℂ) = (α : ℂ) * (l : ℂ) := rfl
+
+end Scale
+
+section Homogeneity
+
+variable (α : ℂˣ)
+
+theorem G_scale (n : ℕ) : (L.scale α).G n = ((α : ℂ) ^ n)⁻¹ * L.G n := by
+  unfold G
+  rw [← (L.scaleLatticeEquiv α).toEquiv.tsum_eq]
+  simp only [LinearEquiv.coe_toEquiv, scaleLatticeEquiv_apply, mul_pow, mul_inv]
+  exact tsum_mul_left
+
+theorem g₂_scale : (L.scale α).g₂ = ((α : ℂ) ^ 4)⁻¹ * L.g₂ := by
+  unfold g₂; rw [G_scale]; ring
+
+theorem g₃_scale : (L.scale α).g₃ = ((α : ℂ) ^ 6)⁻¹ * L.g₃ := by
+  unfold g₃; rw [G_scale]; ring
+
+theorem discriminant_scale :
+    (L.scale α).g₂ ^ 3 - 27 * (L.scale α).g₃ ^ 2
+      = ((α : ℂ) ^ 12)⁻¹ * (L.g₂ ^ 3 - 27 * L.g₃ ^ 2) := by
+  rw [g₂_scale, g₃_scale]; ring
+
+theorem g₂_cubed_scale : (L.scale α).g₂ ^ 3 = ((α : ℂ) ^ 12)⁻¹ * L.g₂ ^ 3 := by
+  rw [g₂_scale, mul_pow, inv_pow, ← pow_mul]
+
+theorem jLattice_scale : (L.scale α).jLattice = L.jLattice := by
+  have hα : ((α : ℂ) ^ 12)⁻¹ ≠ 0 := inv_ne_zero (pow_ne_zero _ α.ne_zero)
+  unfold jLattice
+  rw [discriminant_scale, g₂_cubed_scale, mul_left_comm (1728 : ℂ), mul_div_mul_left _ _ hα]
+
+theorem discriminantNeZero_scale_iff :
+    (L.scale α).DiscriminantNeZero ↔ L.DiscriminantNeZero := by
+  unfold DiscriminantNeZero
+  rw [discriminant_scale]
+  simp only [mul_ne_zero_iff, and_iff_right (inv_ne_zero (pow_ne_zero 12 α.ne_zero))]
+
+end Homogeneity
+
+section LatticeDependence
+
+variable {L L' : PeriodPair}
+
+private def latticeEquivOfEq (h : L.lattice = L'.lattice) : L.lattice ≃ L'.lattice where
+  toFun l := ⟨(l : ℂ), h ▸ l.2⟩
+  invFun l := ⟨(l : ℂ), h.symm ▸ l.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+
+theorem G_eq_of_lattice_eq (h : L.lattice = L'.lattice) (n : ℕ) : L.G n = L'.G n :=
+  (latticeEquivOfEq h).tsum_eq fun l => ((l : ℂ) ^ n)⁻¹
+
+theorem g₂_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.g₂ = L'.g₂ := by
+  unfold g₂; rw [G_eq_of_lattice_eq h]
+
+theorem g₃_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.g₃ = L'.g₃ := by
+  unfold g₃; rw [G_eq_of_lattice_eq h]
+
+theorem jLattice_eq_of_lattice_eq (h : L.lattice = L'.lattice) : L.jLattice = L'.jLattice := by
+  unfold jLattice; rw [g₂_eq_of_lattice_eq h, g₃_eq_of_lattice_eq h]
+
+end LatticeDependence
+
+section Gates
+
+theorem gate_scale_mul (α β : ℂˣ) :
+    ((L.scale α).scale β).lattice = (L.scale (β * α)).lattice := by
+  ext z
+  simp only [mem_scale_lattice_iff, Units.val_mul]
+  constructor
+  · rintro ⟨-, ⟨l, hl, rfl⟩, rfl⟩; exact ⟨l, hl, (mul_assoc _ _ _).symm⟩
+  · rintro ⟨l, hl, rfl⟩; exact ⟨(α : ℂ) * l, ⟨l, hl, rfl⟩, mul_assoc _ _ _⟩
+
+end Gates
+
+private theorem _root_.PeriodPair.kw_countable_lattice : (L.lattice : Set ℂ).Countable := by
+  refine (Set.countable_range fun p : ℤ × ℤ => (p.1 : ℂ) * L.ω₁ + (p.2 : ℂ) * L.ω₂).mono ?_
+  intro z hz
+  obtain ⟨m, n, h⟩ := mem_lattice.mp hz
+  exact ⟨(m, n), h⟩
+
+p2m_export "PeriodPair" "kw_countable_lattice"
+
+private def _root_.PeriodPair.kw_toPointHom : ℂ →+ (L.weierstrassCurve.toAffine).Point where
+  toFun := L.toPoint L.kw_discriminantNeZero
+  map_zero' := L.toPoint_zero L.kw_discriminantNeZero
+  map_add' := L.kw_toPoint_add L.kw_discriminantNeZero
+
+p2m_export "PeriodPair" "kw_toPointHom"
+theorem kw_toPointHom_apply (z : ℂ) :
+    L.kw_toPointHom z = L.toPoint L.kw_discriminantNeZero z := rfl
+
+private theorem _root_.PeriodPair.kw_ker_toPointHom :
+    L.kw_toPointHom.ker = L.lattice.toAddSubgroup := by
+  ext z
+  constructor
+  · exact fun hz => (L.kw_isUniformization).2.2 z hz
+  · intro hz
+    exact L.toPoint_of_mem L.kw_discriminantNeZero hz
+
+p2m_export "PeriodPair" "kw_ker_toPointHom"
+
+private def _root_.PeriodPair.kw_toPointAddEquiv :
+    (ℂ ⧸ L.lattice.toAddSubgroup) ≃+ (L.weierstrassCurve.toAffine).Point :=
+  QuotientAddGroup.liftEquiv L.lattice.toAddSubgroup (φ := L.kw_toPointHom)
+    (L.kw_isUniformization).2.1 L.kw_ker_toPointHom.symm
+
+p2m_export "PeriodPair" "kw_toPointAddEquiv"
+theorem kw_toPointAddEquiv_mk (z : ℂ) :
+    L.kw_toPointAddEquiv (QuotientAddGroup.mk z) = L.toPoint L.kw_discriminantNeZero z :=
+  rfl
+
+scoped instance kw_infinite_quotientLattice : Infinite (ℂ ⧸ L.lattice.toAddSubgroup) := by
+  rw [← not_finite_iff_infinite]; intro hfin
+  have : Countable L.lattice.toAddSubgroup :=
+    Set.countable_coe_iff.mpr L.kw_countable_lattice
+  have : Countable ((ℂ ⧸ L.lattice.toAddSubgroup) × L.lattice.toAddSubgroup) := inferInstance
+  have hCc : Countable ℂ :=
+    Countable.of_equiv _ (AddSubgroup.addGroupEquivQuotientProdAddSubgroup
+      (s := L.lattice.toAddSubgroup)).symm
+  have : Uncountable ℂ := Complex.ofReal_injective.uncountable
+  exact absurd hCc not_countable
+
+scoped instance kw_infinite_point : Infinite L.weierstrassCurve.toAffine.Point :=
+  L.kw_toPointAddEquiv.toEquiv.infinite_iff.mp inferInstance
+
+end PeriodPair
+end
+
+namespace ModularCurve
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve PeriodPair \
+  P2MW.S_OVERLONG_55b03433.PeriodP\
+  air"
+
+def KwD5BetweenCurvesHoloLift : Prop :=
+  ∀ (L L' : PeriodPair)
+    [L.weierstrassCurve.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate L.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L.weierstrassCurve] [L'.weierstrassCurve.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred L'.weierstrassCurve]
+    [WeierstrassCurve.Affine.AbelTheorem L'.weierstrassCurve]
+    (ι'' : L'.weierstrassCurve.toAffine.FunctionField →ₐ[ℂ]
+      L.weierstrassCurve.toAffine.FunctionField)
+    (hι'' : ι''.toRingHom.IsIntegral) (hfin'' : FiniteAlong ℂ ι''),
+    ∃ (F : ℂ → ℂ), Differentiable ℂ F ∧ F 0 ∈ L'.lattice ∧
+      ∀ z, L'.kw_toPointHom (F z)
+        = (pointMapOfPushforward ι'' hι'' hfin''
+            (normFormulaAlong_of_elliptic ι'' hfin'')) (L.kw_toPointHom z)
+
+end ModularCurve
+
+section
+
+
+section
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial IsDedekindDomain \
+  P2MW.S_OVERLONG_55b03433.IsDedek\
+  indDomain WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial.Bivariate"
+variable {F : Type*} [Field F] {W : Affine F}
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "XYIdeal quotientXYIdealEquiv XClass_ne_zero \
+  YClass mk map basis_apply map_injective map_mk exists_smul_basis_eq XClass smul_basis_mul_Y \
+  YClass_ne_zero isDedekindDomain exists_eq_XYIdeal XYIdeal_isMaximal XYIdeal_ne_bot"
+end CoordinateRing
+end Affine
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve"
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι"
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+namespace AddMonoid
+p2m_export "AddMonoid" "mk ext"
+namespace End
+p2m_export "AddMonoid.End" "mulLeft ext smul_def smul_apply"
+end End
+end AddMonoid
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+end AlgebraicCurve
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "HeightOneSpectrum.valuationSubringAtPrime HeightOneSpectrum.asIdeal \
+  HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring \
+  HeightOneSpectrum.eq_of_valuation_isEquiv_valuation mk HeightOneSpectrum"
+end IsDedekindDomain
+namespace IsLocalRing
+p2m_export "IsLocalRing" "eq_maximalIdeal ResidueField of_surjective maximalIdeal mem_maximalIdeal \
+  residue"
+end IsLocalRing
+namespace Polynomial
+p2m_export "Polynomial" "C eval₂_sub map_injective X eval_mul coeff_add coeff algebraMap_eq divX \
+  eval₂ aeval eval₂_add monomial basisMonomials eval₂_pow ext_iff degree C_0 factor aeval_C \
+  monic_X_pow_add degree_linear_le map_map coeff_sub map_C map eval₂_X comp roots algebra \
+  eval₂_mul exists_eq_pow_rootMultiplicity_mul_and_not_dvd coeff_C eval_pow X_dvd_iff algHom_ext \
+  sum infinite reverse eval_X eval_C divX_mul_X_add nontrivial eval_sub aeval_algHom \
+  C_mul_X_pow_eq_monomial derivative map_X aeval_X map_monomial algebraMap_apply \
+  coe_basisMonomials C_neg coeff_C_mul eval_add ext coeff_X_pow content eval₂_C funext ring \
+  ringHom_ext lifts transcendental restriction eval"
+end Polynomial
+namespace Polynomial
+p2m_export "Polynomial" "C eval₂_sub map_injective X eval_mul coeff_add coeff algebraMap_eq divX \
+  eval₂ aeval eval₂_add monomial basisMonomials eval₂_pow ext_iff degree C_0 factor aeval_C \
+  monic_X_pow_add degree_linear_le map_map coeff_sub map_C map eval₂_X comp roots algebra \
+  eval₂_mul exists_eq_pow_rootMultiplicity_mul_and_not_dvd coeff_C eval_pow X_dvd_iff algHom_ext \
+  sum infinite reverse eval_X eval_C divX_mul_X_add nontrivial eval_sub aeval_algHom \
+  C_mul_X_pow_eq_monomial derivative map_X aeval_X map_monomial algebraMap_apply \
+  coe_basisMonomials C_neg coeff_C_mul eval_add ext coeff_X_pow content eval₂_C funext ring \
+  ringHom_ext lifts transcendental restriction eval"
+end Polynomial
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+end Affine
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+end Affine
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+namespace Point
+p2m_export "WeierstrassCurve.Affine.Point" "add baseChange map_map some some.injEq map_injective \
+  map_zero map map_some zero neg_some mk neg"
+end Point
+end Affine
+end WeierstrassCurve
+namespace WithZero
+p2m_export "WithZero" "log_le_log map lift one le"
+end WithZero
+section
+section
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial WeierstrassCurve \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial.Bivariate"
+universe u
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+end Affine
+end WeierstrassCurve
+end
+end
+section
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine WeierstrassCurve.Affine.Point \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine.Point"
+p2m_open_scoped "WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine"
+section
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+end AlgebraicCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+end WeierstrassCurve
+end
+end
+section
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve"
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+end Affine
+end WeierstrassCurve
+end
+section
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine"
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+universe u
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι"
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+end
+section
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine"
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+end AlgebraicCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+universe u
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι"
+end IsogenyEndDatum
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι"
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+end
+section
+p2m_open "IsDedekindDomain \
+  P2MW.S_OVERLONG_55b03433.IsDedek\
+  indDomain WithZero \
+  P2MW.S_OVERLONG_55b03433.WithZer\
+  o IsLocalRing \
+  P2MW.S_OVERLONG_55b03433.IsLocal\
+  Ring"
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+end AlgebraicCurve
+end
+section
+p2m_open "IsDedekindDomain \
+  P2MW.S_OVERLONG_55b03433.IsDedek\
+  indDomain WithZero \
+  P2MW.S_OVERLONG_55b03433.WithZer\
+  o IsLocalRing \
+  P2MW.S_OVERLONG_55b03433.IsLocal\
+  Ring"
+p2m_open_scoped "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial"
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "placeOfPoint placeOfPoint_injective \
+  deg_placeOfPoint"
+end RationalFunctionField
+end AlgebraicCurve
+end
+section
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial IsDedekindDomain \
+  P2MW.S_OVERLONG_55b03433.IsDedek\
+  indDomain WithZero \
+  P2MW.S_OVERLONG_55b03433.WithZer\
+  o IsLocalRing \
+  P2MW.S_OVERLONG_55b03433.IsLocal\
+  Ring"
+p2m_open_scoped "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial"
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "pullback degree smul_def smul_apply"
+end Divisor
+namespace RationalFunctionField
+p2m_export "AlgebraicCurve.RationalFunctionField" "placeOfPoint placeOfPoint_injective \
+  deg_placeOfPoint"
+end RationalFunctionField
+end AlgebraicCurve
+end
+section
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine"
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+universe u
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate W]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W] [WeierstrassCurve.Affine.AbelTheorem W]
+namespace IsogenyEndDatum
+p2m_export "WeierstrassCurve.Affine.IsogenyEndDatum" "pointEnd pointEnd_apply pointEnd_eq_of_seam \
+  hfin hι mk ι"
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+end
+section
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial IsDedekindDomain \
+  P2MW.S_OVERLONG_55b03433.IsDedek\
+  indDomain"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial.Bivariate"
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+end AlgebraicCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+end Affine
+end WeierstrassCurve
+end
+section
+p2m_open "IsLocalRing \
+  P2MW.S_OVERLONG_55b03433.IsLocal\
+  Ring"
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+namespace Divisor
+p2m_export "AlgebraicCurve.Divisor" "pullback degree smul_def smul_apply"
+end Divisor
+end AlgebraicCurve
+end
+section
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial IsDedekindDomain \
+  P2MW.S_OVERLONG_55b03433.IsDedek\
+  indDomain"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial.Bivariate"
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+p2m_open_scoped "AlgebraicCurve.Place" in
+theorem Place.ramificationIndexAlong_pos (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') : 0 < Place.ramificationIndexAlong φ w := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  exact w.ramificationIndex_pos
+
+p2m_open_scoped "AlgebraicCurve.Place" in
+theorem Place.ord_restrictAlong_ne_zero_iff (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') (f : F) :
+    (w.restrictAlong φ hφ).ord f ≠ 0 ↔ w.ord (φ f) ≠ 0 := by
+  rw [w.ord_restrictAlong φ hφ f]
+  have hpos := Place.ramificationIndexAlong_pos φ hφ w
+  constructor
+  · intro h hcon
+    rcases mul_eq_zero.mp hcon with h1 | h1
+    · omega
+    · exact h h1
+  · intro h hcon
+    exact h (by rw [hcon, mul_zero])
+
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve"
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem algebraMap_polynomial_eq_mk_C (p : F[X]) :
+    algebraMap F[X] W.CoordinateRing p = CoordinateRing.mk W (C p) :=
+  rfl
+
+theorem algebraMap_coordinateRing_ne_zero {r : W.CoordinateRing} (hr : r ≠ 0) :
+    algebraMap W.CoordinateRing W.FunctionField r ≠ 0 :=
+  (map_ne_zero_iff _ (IsFractionRing.injective W.CoordinateRing W.FunctionField)).mpr hr
+
+theorem ord_placeOfEquation_ne_zero_iff [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) {r : W.CoordinateRing} (hr : r ≠ 0) :
+    (placeOfEquation h).ord (algebraMap W.CoordinateRing W.FunctionField r) ≠ 0
+      ↔ r ∈ XYIdeal W x (C y) := by
+  rw [placeOfEquation, Place.ord_ofHeightOneSpectrum_ne_zero_iff _ hr,
+    heightOneSpectrumOfEquation_asIdeal]
+
+theorem ord_placeOfEquation_nonneg [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) (r : W.CoordinateRing) :
+    0 ≤ (placeOfEquation h).ord (algebraMap W.CoordinateRing W.FunctionField r) :=
+  AlgebraicCurve.Place.ord_nonneg_of_mem (placeOfEquation h) (isFinitePlace_placeOfEquation h r)
+
+theorem ord_placeOfEquation_pos_iff [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) {r : W.CoordinateRing} (hr : r ≠ 0) :
+    0 < (placeOfEquation h).ord (algebraMap W.CoordinateRing W.FunctionField r)
+      ↔ r ∈ XYIdeal W x (C y) := by
+  rw [← ord_placeOfEquation_ne_zero_iff h hr]
+  have := ord_placeOfEquation_nonneg h r
+  omega
+
+theorem IsFinitePlace.mem_centre_iff_ord_ne_zero {v : Place F W.FunctionField}
+    (hv : IsFinitePlace v) {r : W.CoordinateRing} (hr : r ≠ 0) :
+    r ∈ hv.centre ↔ v.ord (algebraMap W.CoordinateRing W.FunctionField r) ≠ 0 := by
+  have hr' : algebraMap W.CoordinateRing W.FunctionField r ≠ 0 :=
+    algebraMap_coordinateRing_ne_zero hr
+  rw [IsFinitePlace.centre, Ideal.mem_comap, IsLocalRing.mem_maximalIdeal, mem_nonunits_iff,
+    ne_eq, v.ord_eq_zero_iff_adicValuation_eq_one hr']
+  exact not_congr (v.adicValuation_coe_eq_one_iff (hv.ringHom r)).symm
+
+theorem centre_placeOfEquation [IsDedekindDomain W.CoordinateRing] {x y : F}
+    (h : W.Equation x y) :
+    (isFinitePlace_placeOfEquation h).centre = XYIdeal W x (C y) := by
+  ext r
+  rcases eq_or_ne r 0 with rfl | hr
+  · simp only [Submodule.zero_mem]
+  rw [(isFinitePlace_placeOfEquation h).mem_centre_iff_ord_ne_zero hr,
+    ord_placeOfEquation_ne_zero_iff h hr]
+
+theorem eq_placeOfEquation_of_le_centre [IsAlgClosed F] [IsDedekindDomain W.CoordinateRing]
+    {v : Place F W.FunctionField} (hv : IsFinitePlace v) {x y : F} (h : W.Equation x y)
+    (hle : XYIdeal W x (C y) ≤ hv.centre) : v = placeOfEquation h := by
+  obtain ⟨x', y', h', hveq⟩ := (isFinitePlace_iff_exists_placeOfEquation v).mp hv
+  subst hveq
+  have hc : hv.centre = XYIdeal W x' (C y') := by
+    rw [Subsingleton.elim hv (isFinitePlace_placeOfEquation h')]
+    exact centre_placeOfEquation h'
+  rw [hc] at hle
+  have heq : XYIdeal W x (C y) = XYIdeal W x' (C y') :=
+    (CoordinateRing.XYIdeal_isMaximal h).eq_of_le (CoordinateRing.XYIdeal_isMaximal h').ne_top
+      hle
+  obtain ⟨rfl, rfl⟩ := CoordinateRing.eq_of_XYIdeal_eq h' heq
+  rfl
+
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve"
+
+variable {F : Type*} [Field F] (W : Affine F)
+
+variable {W}
+
+def yGen (W : Affine F) : W.FunctionField :=
+  algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+
+end Affine
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+end Affine
+end WeierstrassCurve
+end
+section
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial"
+universe u r s v
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+namespace Point
+p2m_export "WeierstrassCurve.Affine.Point" "add baseChange map_map some some.injEq map_injective \
+  map_zero map map_some zero neg_some mk neg"
+end Point
+end Affine
+end WeierstrassCurve
+end
+section
+p2m_open "IsLocalRing \
+  P2MW.S_OVERLONG_55b03433.IsLocal\
+  Ring"
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+end AlgebraicCurve
+end
+section
+section
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial WeierstrassCurve \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial.Bivariate"
+universe u
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+end Affine
+end WeierstrassCurve
+end
+end
+section
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial IsDedekindDomain \
+  P2MW.S_OVERLONG_55b03433.IsDedek\
+  indDomain"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial.Bivariate"
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve"
+universe u
+variable {F : Type u} [Field F]
+section GenericPoint
+variable {W : Affine F}
+
+theorem polyToFunctionField_eq_aeval (p : F[X]) :
+    polyToFunctionField W p = Polynomial.aeval (polyToFunctionField W X) p := by
+  have h1 : (polyToFunctionField W : F[X] →+* W.FunctionField)
+      = algebraMap F[X] W.FunctionField :=
+    (IsScalarTower.algebraMap_eq F[X] W.CoordinateRing W.FunctionField).symm
+  have h2 : (IsScalarTower.toAlgHom F F[X] W.FunctionField : F[X] →ₐ[F] W.FunctionField)
+      = Polynomial.aeval (polyToFunctionField W X) := by
+    refine Polynomial.algHom_ext ?_
+    rw [Polynomial.aeval_X, IsScalarTower.coe_toAlgHom', ← h1]
+  calc polyToFunctionField W p = algebraMap F[X] W.FunctionField p := by rw [h1]
+    _ = (IsScalarTower.toAlgHom F F[X] W.FunctionField : F[X] →ₐ[F] W.FunctionField) p := rfl
+    _ = Polynomial.aeval (polyToFunctionField W X) p := by rw [h2]
+
+theorem equation_map_polyToFunctionField_yGen :
+    (W.map (algebraMap F W.FunctionField)).toAffine.Equation
+      (polyToFunctionField W X) (yGen W) := by
+  rw [equation_iff]
+  have hrel := smul_basis_mul_Y (W' := W) 0 1
+  rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at hrel
+  have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) hrel
+  rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆]
+  simp only [map_add, map_mul, map_pow, polyToFunctionField_C] at h2
+  rw [show yGen W = algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+    from rfl]
+  simp only [polyToFunctionField_apply] at h2 ⊢
+  linear_combination h2
+
+end GenericPoint
+end Affine
+end WeierstrassCurve
+end
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial IsDedekindDomain \
+  P2MW.S_OVERLONG_55b03433.IsDedek\
+  indDomain"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial.Bivariate"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve"
+
+universe u
+
+variable {F : Type u} [Field F]
+
+namespace AbstractSeam
+
+variable {W : Affine F} {V : Affine F}
+variable (ι : V.FunctionField →ₐ[F] W.FunctionField)
+  (hι : ι.toRingHom.IsIntegral)
+  {ξ η : W.FunctionField}
+  (hX : ι (polyToFunctionField V (X : F[X])) = ξ)
+  (hY : ι (yGen V) = η)
+
+include hX in
+theorem map_XClass (c : F) :
+    ι (algebraMap V.CoordinateRing V.FunctionField (XClass V c))
+      = ξ - algebraMap F W.FunctionField c := by
+  have h1 : algebraMap V.CoordinateRing V.FunctionField (XClass V c)
+      = polyToFunctionField V (X : F[X]) - algebraMap F V.FunctionField c := by
+    rw [← polyToFunctionField_C, ← map_sub]
+    rfl
+  rw [h1, map_sub, hX, AlgHom.commutes]
+
+include hY in
+theorem map_YClass (c : F) :
+    ι (algebraMap V.CoordinateRing V.FunctionField (YClass V (C c)))
+      = η - algebraMap F W.FunctionField c := by
+  have h1 : algebraMap V.CoordinateRing V.FunctionField (YClass V (C c))
+      = yGen V - algebraMap F V.FunctionField c := by
+    rw [YClass, map_sub, map_sub, yGen]
+    congr 1
+  rw [h1, map_sub, hY, AlgHom.commutes]
+
+section Cases
+
+variable [IsDedekindDomain V.CoordinateRing]
+
+include hX hY in
+theorem restrictAlong_placeOfEquation [IsAlgClosed F] [W.IsElliptic]
+    {x y : F} (h : W.Equation x y) {a b : F} (h' : V.Equation a b)
+    (hreg : ξ ∈ (placeOfEquation h).toValuationSubring)
+    (hdx : 0 < (placeOfEquation h).ord (ξ - algebraMap F W.FunctionField a))
+    (hdy : 0 < (placeOfEquation h).ord (η - algebraMap F W.FunctionField b)) :
+    (placeOfEquation h).restrictAlong ι hι = placeOfEquation h' := by
+  have hfin : IsFinitePlace ((placeOfEquation h).restrictAlong ι hι) :=
+    isFinitePlace_of_mem _ (by
+      rw [Place.mem_restrictAlong_iff, hX]
+      exact hreg)
+  refine eq_placeOfEquation_of_le_centre hfin h' ?_
+  rw [XYIdeal, Ideal.span_le]
+  intro r hr
+  simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hr
+  rcases hr with rfl | rfl
+  · rw [SetLike.mem_coe, hfin.mem_centre_iff_ord_ne_zero (XClass_ne_zero _),
+      Place.ord_restrictAlong_ne_zero_iff, map_XClass ι hX]
+    omega
+  · rw [SetLike.mem_coe, hfin.mem_centre_iff_ord_ne_zero (YClass_ne_zero _),
+      Place.ord_restrictAlong_ne_zero_iff, map_YClass ι hY]
+    omega
+
+include hX in
+theorem restrictAlong_eq_infinitePlace [V.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred V]
+    (v : AlgebraicCurve.Place F W.FunctionField)
+    (hpole : ξ ∉ v.toValuationSubring) :
+    v.restrictAlong ι hι = InfinitePlace.place := by
+  refine InfinitePlace.eq_of_not_isFinitePlace _ ?_
+  intro hfin
+  refine hpole ?_
+  rw [← hX]
+  exact hfin (algebraMap F[X] V.CoordinateRing (X : F[X]))
+
+end Cases
+end AbstractSeam
+end Affine
+end WeierstrassCurve
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial Polynomial.Bivariate.Polynomial \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+end WeierstrassCurve
+end
+
+section
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine WeierstrassCurve.Affine.Point \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine.Point"
+p2m_open_scoped "WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine Polynomial.Bivariate \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial.Bivariate"
+section
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine.CoordinateRing \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve"
+universe u
+variable {F : Type u} [Field F]
+section AdjoinSurjective
+variable {W : Affine F} (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b)
+local notation "ι" => algebraMap F W.FunctionField
+
+theorem transcendental_polyToFunctionField_X :
+    Transcendental F (polyToFunctionField W X) := by
+  rw [transcendental_iff]
+  intro p hp
+  rw [← polyToFunctionField_eq_aeval] at hp
+  exact polyToFunctionField_injective (by simpa using hp)
+
+end AdjoinSurjective
+end Affine
+end WeierstrassCurve
+end
+end
+
+section
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial WeierstrassCurve \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial.Bivariate"
+
+universe u
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+end Affine
+end WeierstrassCurve
+namespace ModularCurve
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine \
+  AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve"
+local notation "psPsi11" =>
+  (Polynomial.C 4 * Polynomial.X ^ 3 - Polynomial.C 4 * Polynomial.X ^ 2
+    - Polynomial.C 40 * Polynomial.X - Polynomial.C 79 : Polynomial (AlgebraicClosure ℚ))
+local notation "psN411" =>
+  (Polynomial.X ^ 4 + Polynomial.C 20 * Polynomial.X ^ 2
+    + Polynomial.C 158 * Polynomial.X + Polynomial.C 21 : Polynomial (AlgebraicClosure ℚ))
+local notation "psP11[" b "]" =>
+  (Polynomial.X ^ 6 - Polynomial.C 2 * Polynomial.X ^ 5 - Polynomial.C 50 * Polynomial.X ^ 4
+    - Polynomial.C (4 * b + 397) * Polynomial.X ^ 3
+    + Polynomial.C (4 * b - 103) * Polynomial.X ^ 2
+    + Polynomial.C (40 * b - 728) * Polynomial.X
+    + Polynomial.C (79 * b - 2871) : Polynomial (AlgebraicClosure ℚ))
+local notation "psQ11[" b "]" =>
+  (Polynomial.C (-8 * b - 4) * Polynomial.X ^ 3 + Polynomial.C (8 * b + 4) * Polynomial.X ^ 2
+    + Polynomial.C (80 * b + 40) * Polynomial.X + Polynomial.C (158 * b + 79)
+    : Polynomial (AlgebraicClosure ℚ))
+end ModularCurve
+end
+end
+end
+
+section
+
+
+section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+end AlgebraicCurve
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+end AlgebraicCurve
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+end Place
+end AlgebraicCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve"
+section Gate
+universe u
+variable {F : Type u} [Field F] [DecidableEq F]
+variable {W : Affine F} [GenusOnePlaceGate W]
+variable (W)
+
+def placeOfPointEquiv : W.Point ≃ AlgebraicCurve.Place F W.FunctionField :=
+  pointEquivPlace (W := W)
+omit [DecidableEq F] in
+theorem placeOfPoint_placeOfPointEquiv_symm (w : AlgebraicCurve.Place F W.FunctionField) :
+    placeOfPoint ((placeOfPointEquiv W).symm w) = w := by
+  classical
+  exact
+    (placeOfPointEquiv W).apply_symm_apply w
+
+end Gate
+end Affine
+end WeierstrassCurve
+namespace ModularCurve
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve"
+universe u
+attribute [local instance] Classical.propDecidable
+section GeomMorphBC
+variable {K : Type u} [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable {E E' : Affine K} [E.IsElliptic] [GenusOnePlaceGate E] [AbelTheorem E]
+  [E'.IsElliptic] [GenusOnePlaceGate E'] [AbelTheorem E']
+variable (ι : E'.FunctionField →ₐ[K] E.FunctionField)
+variable (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong K ι) (hN : NormFormulaAlong K ι hfin)
+
+def kw_fdn2_qephod_hend7_geomMorphBC : E.Point → E'.Point :=
+  fun P => (placeOfPointEquiv E').symm ((placeOfPoint P).restrictAlong ι hι)
+
+local notation "gBC" => kw_fdn2_qephod_hend7_geomMorphBC ι hι
+
+omit [DecidableEq K] [IsAlgClosed K] [CharZero K] [WeierstrassCurve.IsElliptic E] [E.AbelTheorem]
+  [WeierstrassCurve.IsElliptic E'] [E'.AbelTheorem] in
+theorem kw_fdn2_qephod_hend7_placeOfPoint_geomMorphBC (P : E.Point) :
+    (placeOfPoint P).restrictAlong ι hι = placeOfPoint (gBC P) :=
+  (placeOfPoint_placeOfPointEquiv_symm E' _).symm
+
+omit [DecidableEq K] [IsAlgClosed K] [CharZero K] [WeierstrassCurve.IsElliptic E] [E.AbelTheorem]
+  [WeierstrassCurve.IsElliptic E'] [E'.AbelTheorem] in
+theorem kw_fdn2_qephod_hend7_pushforwardDegZero_pointDivisor_geomMorphBC (P : E.Point) :
+    Pic0.pushforwardAlongDegZero ι hι (pointDivisor P)
+      = pointDivisor (gBC P) - pointDivisor (gBC 0) := by
+  refine Subtype.ext ?_
+  rw [Pic0.coe_pushforwardAlongDegZero, coe_pointDivisor, map_sub,
+    pushforwardAlong_single_eq ι hι, pushforwardAlong_single_eq ι hι,
+    kw_fdn2_qephod_hend7_placeOfPoint_geomMorphBC ι hι P,
+    kw_fdn2_qephod_hend7_placeOfPoint_geomMorphBC ι hι 0]
+  push_cast
+  rw [coe_pointDivisor, coe_pointDivisor, sub_sub_sub_cancel_right]
+
+include hfin in
+omit [DecidableEq K] [IsAlgClosed K] [CharZero K] [WeierstrassCurve.IsElliptic E] [E.AbelTheorem]
+  [WeierstrassCurve.IsElliptic E'] [E'.AbelTheorem] in
+theorem kw_fdn2_qephod_hend7_pushforwardHom_pointClass_eq_sub (P : E.Point) :
+    Pic0.pushforwardAlongHom ι hι hfin hN
+        (pointClass P)
+      = pointClass (gBC P) - pointClass (gBC 0) := by
+  change Pic0.pushforwardAlongHom ι hι hfin _ (Pic0.mk (pointDivisor P))
+      = Pic0.mk (pointDivisor (gBC P)) - Pic0.mk (pointDivisor (gBC 0))
+  rw [Pic0.pushforwardAlongHom_mk,
+    kw_fdn2_qephod_hend7_pushforwardDegZero_pointDivisor_geomMorphBC ι hι P]
+  rfl
+
+include hfin in
+omit [IsAlgClosed K] [CharZero K] [WeierstrassCurve.IsElliptic E]
+  [WeierstrassCurve.IsElliptic E'] in
+theorem kw_fdn2_qephod_hend7_pmop_eq_geomMorphBC_sub (P : E.Point) :
+    pointMapOfPushforward ι hι hfin hN P
+      = gBC P - gBC 0 := by
+  rw [pointMapOfPushforward_apply,
+    kw_fdn2_qephod_hend7_pushforwardHom_pointClass_eq_sub ι hι hfin hN P, map_sub,
+    genusOnePic0Equiv_apply, genusOnePic0Equiv_apply, pic0ToPoint_pointClass,
+    pic0ToPoint_pointClass]
+end GeomMorphBC
+end ModularCurve
+end
+end
+
+section
+
+
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Modular\
+  Curve"
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial"
+p2m_open_scoped "TensorProduct Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial"
+
+namespace ModularCurve
+
+universe u
+
+section Setup
+
+variable (W : WeierstrassCurve ℚ) [W.IsElliptic]
+variable (F : Type u) [Field F] [Algebra ℚ F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra ℚ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower ℚ F F']
+
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F).toAffine]
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F').toAffine]
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+local notation3 "CR" => (W⁄F).toAffine.CoordinateRing
+local notation3 "FF" => (W⁄F).FunctionField
+
+def kw_coordinateRingBasis {R : Type*} [CommRing R] (V : Affine R) :
+    Module.Basis (ℕ × Fin 2) R V.CoordinateRing :=
+  (Polynomial.basisMonomials R).smulTower (CoordinateRing.basis V)
+end Setup
+end ModularCurve
+end
+
+section
+
+
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Modular\
+  Curve AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve"
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial"
+p2m_open_scoped "TensorProduct Polynomial.Bivariate \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial.Bivariate"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+universe u
+variable {F : Type u} [Field F] {W : Affine F}
+
+theorem kw_functionField_algHom_ext {L : Type*} [Field L] [Algebra F L]
+    {f g : W.FunctionField →ₐ[F] L}
+    (hX : f (polyToFunctionField W X) = g (polyToFunctionField W X))
+    (hy : f (yGen W) = g (yGen W)) : f = g := by
+  have hCR : ∀ r : W.CoordinateRing,
+      f (algebraMap W.CoordinateRing W.FunctionField r)
+        = g (algebraMap W.CoordinateRing W.FunctionField r) := by
+    intro r
+    obtain ⟨p, rfl⟩ := AdjoinRoot.mk_surjective r
+    have hFX : ∀ c : F[X], f (algebraMap W.CoordinateRing W.FunctionField
+          (algebraMap F[X] W.CoordinateRing c))
+        = g (algebraMap W.CoordinateRing W.FunctionField
+          (algebraMap F[X] W.CoordinateRing c)) :=
+      fun c => DFunLike.congr_fun
+        (Polynomial.algHom_ext (f := (f.comp (IsScalarTower.toAlgHom F W.CoordinateRing
+            W.FunctionField)).comp (IsScalarTower.toAlgHom F F[X] W.CoordinateRing))
+          (g := (g.comp (IsScalarTower.toAlgHom F W.CoordinateRing W.FunctionField)).comp
+            (IsScalarTower.toAlgHom F F[X] W.CoordinateRing)) hX) c
+    have hFX' : ∀ c : F[X], f (algebraMap W.CoordinateRing W.FunctionField
+          (AdjoinRoot.mk W.polynomial (C c)))
+        = g (algebraMap W.CoordinateRing W.FunctionField
+          (AdjoinRoot.mk W.polynomial (C c))) := fun c => by
+      rw [show AdjoinRoot.mk W.polynomial (C c) = algebraMap F[X] W.CoordinateRing c from rfl]
+      exact hFX c
+    have hy' : f (algebraMap W.CoordinateRing W.FunctionField (AdjoinRoot.mk W.polynomial Y))
+        = g (algebraMap W.CoordinateRing W.FunctionField (AdjoinRoot.mk W.polynomial Y)) := hy
+    induction p using Polynomial.induction_on with
+    | C c => exact hFX' c
+    | monomial n c _ => simp only [map_mul, map_pow, hy', hFX' c]
+    | add p q hp hq => simp only [map_add, hp, hq]
+  refine AlgHom.ext fun a => ?_
+  obtain ⟨p, q, hq, rfl⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) a
+  simp only [map_div₀, hCR p, hCR q]
+
+end Affine
+end WeierstrassCurve
+
+namespace ModularCurve
+
+universe u
+
+section Setup
+
+variable (W : WeierstrassCurve ℚ) [W.IsElliptic]
+variable (F : Type u) [Field F] [Algebra ℚ F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra ℚ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower ℚ F F']
+
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F).toAffine]
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F').toAffine]
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+scoped instance kw_isScalarTower_rat_right_tensor :
+    IsScalarTower ℚ F' ((W⁄F).FunctionField ⊗[F] F') :=
+  IsScalarTower.of_algebraMap_eq' (Subsingleton.elim _ _)
+
+end Setup
+end ModularCurve
+end
+
+section
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial WeierstrassCurve \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial.Bivariate"
+
+universe u
+
+local instance instDecEqFunctionFieldAddLawPullback {F : Type u} [Field F]
+    {W : WeierstrassCurve.Affine F} : DecidableEq W.FunctionField :=
+  Classical.decEq _
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ map_map a₁ map Affine.CoordinateRing mk a₄ a₂ \
+  a₆ Affine.Point.some Affine.Point.some.injEq Affine.Point.map_injective reduction IsIntegral \
+  toAffine Affine.Point map_injective map_a₆ Affine.Point.map map_a₁ map_a₄ Δ Affine.polynomial \
+  Affine.Point.neg_some map_a₂ baseChange j map_a₃ Affine.GenusOnePlaceGate Affine.AbelTheorem \
+  Affine.GenusOnePlaceGate.IsCentred Affine.hasPrincipalDivisors_functionField \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation negY equation_iff' CoordinateRing.XYIdeal \
+  map_a₃ CoordinateRing.XClass_ne_zero slope CoordinateRing map baseChange Equation.baseChange \
+  CoordinateRing.YClass Point.some Point.some.injEq Nonsingular Point.map_injective map_a₆ \
+  FunctionField map_a₂ Point CoordinateRing.mk map_a₁ CoordinateRing.map map_a₄ \
+  CoordinateRing.basis_apply Point.map CoordinateRing.map_mk CoordinateRing.map_smul \
+  equation_iff_nonsingular CoordinateRing.XClass CoordinateRing.basis equation_iff Point.map_some \
+  map_nonsingular polynomial Point.neg_some CoordinateRing.YClass_ne_zero \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  IsogenyEndDatum.pointEnd GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one \
+  deg_placeOfPoint pointDivisor coe_pointDivisor pointClass AbelTheorem pic0ToPoint_pointClass \
+  genusOnePic0Equiv genusOnePic0Equiv_apply GenusOnePlaceGate.deg_eq_one \
+  GenusOnePlaceGate.IsCentred placeOfPoint_some_eq_ofHeightOneSpectrum \
+  algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero CoordinateRing.isDedekindDomain \
+  CoordinateRing.exists_eq_XYIdeal CoordinateRing.XYIdeal_isMaximal \
+  hasPrincipalDivisors_functionField natCard_ker_pointMapOfPushforward_eq_finrankAlong \
+  polyToFunctionField polyToFunctionField_apply polyToFunctionField_injective \
+  polyToFunctionField_C algebraMap_smul_basis yCoord"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine.CoordinateRing"
+
+variable {F : Type u} [Field F]
+
+section PointPullbackTo
+
+variable {W : Affine F} {L : Type u} [Field L] [Algebra F L]
+
+theorem eval₂_polynomial_of_equation_map_target {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) :
+    W.polynomial.eval₂
+      (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom yP = 0 := by
+  rw [equation_iff'] at h
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆] at h
+  simp only [WeierstrassCurve.Affine.polynomial, eval₂_add, eval₂_sub, eval₂_mul, eval₂_pow,
+    eval₂_X, eval₂_C, AlgHom.toRingHom_eq_coe, RingHom.coe_coe, map_add, map_mul, map_pow,
+    Polynomial.aeval_C, Polynomial.aeval_X]
+  linear_combination h
+
+def pointPullbackCoordHomTo {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) :
+    W.CoordinateRing →ₐ[F] L where
+  __ := AdjoinRoot.lift
+    (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom
+    yP (eval₂_polynomial_of_equation_map_target h)
+  commutes' c := by
+    change AdjoinRoot.lift _ _ (eval₂_polynomial_of_equation_map_target h) (algebraMap F _ c)
+      = algebraMap F L c
+    rw [CoordinateRing.algebraMap_eq_mk_C_C, AdjoinRoot.lift_mk, eval₂_C]
+    exact Polynomial.aeval_C _ c
+
+theorem pointPullbackCoordHomTo_mk {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) (g : F[X][Y]) :
+    pointPullbackCoordHomTo h (CoordinateRing.mk W g)
+      = g.eval₂ (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom yP :=
+  AdjoinRoot.lift_mk (eval₂_polynomial_of_equation_map_target h) g
+
+theorem pointPullbackCoordHomTo_comp_algebraMap {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) :
+    (pointPullbackCoordHomTo h).toRingHom.comp (algebraMap F[X] W.CoordinateRing)
+      = (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom := by
+  refine RingHom.ext fun p => ?_
+  change pointPullbackCoordHomTo h (algebraMap F[X] _ p) = _
+  rw [algebraMap_polynomial_eq_mk_C, pointPullbackCoordHomTo_mk, eval₂_C]
+
+theorem pointPullbackCoordHomTo_injective {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    Function.Injective (pointPullbackCoordHomTo h) := by
+  have hker : RingHom.ker (pointPullbackCoordHomTo h).toRingHom = ⊥ := by
+    have : Module.Finite F[X] W.CoordinateRing :=
+      Module.Finite.of_basis (CoordinateRing.basis W)
+    refine Ideal.eq_bot_of_under_eq_bot (R := F[X]) ?_
+    rw [Ideal.under_def, RingHom.comap_ker, pointPullbackCoordHomTo_comp_algebraMap,
+      ← RingHom.injective_iff_ker_eq_bot]
+    exact hx
+  exact (RingHom.injective_iff_ker_eq_bot (pointPullbackCoordHomTo h).toRingHom).mpr hker
+
+def pointPullbackHomTo {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    W.FunctionField →ₐ[F] L :=
+  IsFractionRing.liftAlgHom (pointPullbackCoordHomTo_injective h hx)
+
+theorem pointPullbackHomTo_algebraMap {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) (r : W.CoordinateRing) :
+    pointPullbackHomTo h hx (algebraMap W.CoordinateRing W.FunctionField r)
+      = pointPullbackCoordHomTo h r :=
+  IsFractionRing.lift_algebraMap (pointPullbackCoordHomTo_injective h hx) r
+
+theorem pointPullbackHomTo_polyToFunctionField_X {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    pointPullbackHomTo h hx (polyToFunctionField W X) = xP := by
+  rw [polyToFunctionField_apply, pointPullbackHomTo_algebraMap,
+    algebraMap_polynomial_eq_mk_C, pointPullbackCoordHomTo_mk, eval₂_C]
+  exact Polynomial.aeval_X _
+
+theorem pointPullbackHomTo_yGen {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    pointPullbackHomTo h hx (yGen W) = yP := by
+  change pointPullbackHomTo h hx (algebraMap _ _ (CoordinateRing.mk W Y)) = _
+  rw [pointPullbackHomTo_algebraMap, pointPullbackCoordHomTo_mk]
+  exact eval₂_X _ _
+
+end PointPullbackTo
+end Affine
+end WeierstrassCurve
+end
+end
+
+section
+
+
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Modular\
+  Curve AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve"
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial"
+p2m_open_scoped "TensorProduct Polynomial.Bivariate \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial.Bivariate Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial Polynomial.Bivariate.Polynomial"
+
+namespace ModularCurve
+
+universe u
+
+section SetupBCG
+
+variable {R₀ : Type u} [Field R₀]
+variable (W : WeierstrassCurve R₀) [W.IsElliptic]
+variable (F : Type u) [Field F] [Algebra R₀ F] [DecidableEq F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra R₀ F'] [DecidableEq F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower R₀ F F']
+
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F).toAffine]
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F').toAffine]
+
+omit [W.IsElliptic] [Algebra R₀ F] [DecidableEq F] [CharZero F] [DecidableEq F'] [CharZero F']
+  [IsScalarTower R₀ F F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_transcendental_polyToFunctionField_X_over_baseGeneralNoAC :
+    Transcendental F (polyToFunctionField (W⁄F') X) :=
+  Transcendental.of_tower_top F (L := F')
+    (transcendental_polyToFunctionField_X (W := (W⁄F')))
+
+omit [W.IsElliptic] [DecidableEq F] [CharZero F] [DecidableEq F'] [CharZero F']
+  [(toAffine W⁄F).GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F)]
+  [(toAffine W⁄F).AbelTheorem] [(toAffine W⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F')] [(toAffine W⁄F').AbelTheorem] in
+theorem kw_equation_map_polyToFunctionField_yGen_over_baseGeneralNoAC :
+    ((W⁄F).map (algebraMap F (W⁄F').FunctionField)).toAffine.Equation
+      (polyToFunctionField (W⁄F') X) (yGen (W⁄F')) := by
+  have hcurve : (W⁄F).map (algebraMap F (W⁄F').FunctionField)
+      = (W⁄F').map (algebraMap F' (W⁄F').FunctionField) := by
+    change (W.map _).map _ = (W.map _).map _
+    rw [WeierstrassCurve.map_map, WeierstrassCurve.map_map]
+    congr 1
+    exact ((IsScalarTower.algebraMap_eq R₀ F (W⁄F').FunctionField).symm).trans
+      (IsScalarTower.algebraMap_eq R₀ F' (W⁄F').FunctionField)
+  exact hcurve ▸ equation_map_polyToFunctionField_yGen (W := (W⁄F'))
+
+def kw_functionFieldMapAlongGeneralNoAC : (W⁄F).FunctionField →ₐ[F] (W⁄F').FunctionField :=
+  pointPullbackHomTo (kw_equation_map_polyToFunctionField_yGen_over_baseGeneralNoAC W F F')
+    ((injective_iff_map_eq_zero _).mpr fun p hp =>
+      transcendental_iff.mp (kw_transcendental_polyToFunctionField_X_over_baseGeneralNoAC W F F') p
+        hp)
+
+omit [W.IsElliptic] [DecidableEq F] [CharZero F] [DecidableEq F'] [CharZero F']
+  [(toAffine W⁄F).GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F)]
+  [(toAffine W⁄F).AbelTheorem] [(toAffine W⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F')] [(toAffine W⁄F').AbelTheorem] in
+theorem kw_functionFieldMapAlongGeneralNoAC_polyToFunctionField_X :
+    kw_functionFieldMapAlongGeneralNoAC W F F' (polyToFunctionField (W⁄F) X)
+      = polyToFunctionField (W⁄F') X :=
+  pointPullbackHomTo_polyToFunctionField_X _ _
+
+omit [W.IsElliptic] [DecidableEq F] [CharZero F] [DecidableEq F'] [CharZero F']
+  [(toAffine W⁄F).GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F)]
+  [(toAffine W⁄F).AbelTheorem] [(toAffine W⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F')] [(toAffine W⁄F').AbelTheorem] in
+theorem kw_functionFieldMapAlongGeneralNoAC_yGen :
+    kw_functionFieldMapAlongGeneralNoAC W F F' (yGen (W⁄F)) = yGen (W⁄F') :=
+  pointPullbackHomTo_yGen _ _
+
+def KwFunctionFieldTensorIsDomainGeneralNoAC : Prop :=
+  IsDomain ((W⁄F).FunctionField ⊗[F] F')
+
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+scoped instance kw_isScalarTower_base_right_tensorGeneralNoAC :
+    IsScalarTower R₀ F' ((W⁄F).FunctionField ⊗[F] F') := by
+  refine IsScalarTower.of_algebraMap_eq' (RingHom.ext fun r => ?_)
+  rw [RingHom.comp_apply, Algebra.TensorProduct.right_algebraMap_apply,
+    IsScalarTower.algebraMap_apply R₀ F F',
+    show algebraMap R₀ ((W⁄F).FunctionField ⊗[F] F') r
+      = (algebraMap F ((W⁄F).FunctionField ⊗[F] F')) (algebraMap R₀ F r) from
+        IsScalarTower.algebraMap_apply R₀ F ((W⁄F).FunctionField ⊗[F] F') r,
+    Algebra.TensorProduct.algebraMap_apply, Algebra.algebraMap_eq_smul_one,
+    Algebra.algebraMap_eq_smul_one, TensorProduct.smul_tmul, Algebra.algebraMap_eq_smul_one]
+
+section FracHom
+
+variable [IsDomain ((W⁄F).FunctionField ⊗[F] F')]
+
+scoped instance kw_isScalarTower_base_right_fracTensorGeneralNoAC :
+    IsScalarTower R₀ F' (FractionRing ((W⁄F).FunctionField ⊗[F] F')) :=
+  IsScalarTower.of_algebraMap_eq fun r =>
+    (IsScalarTower.algebraMap_apply R₀ ((W⁄F).FunctionField ⊗[F] F')
+        (FractionRing ((W⁄F).FunctionField ⊗[F] F')) r).trans <|
+      (congrArg (algebraMap ((W⁄F).FunctionField ⊗[F] F')
+          (FractionRing ((W⁄F).FunctionField ⊗[F] F')))
+        (IsScalarTower.algebraMap_apply R₀ F' ((W⁄F).FunctionField ⊗[F] F') r)).trans
+      (IsScalarTower.algebraMap_apply F' ((W⁄F).FunctionField ⊗[F] F')
+        (FractionRing ((W⁄F).FunctionField ⊗[F] F')) (algebraMap R₀ F' r)).symm
+
+end FracHom
+end SetupBCG
+section SetupBCGD
+variable {R₀ : Type u} [Field R₀]
+variable (W : WeierstrassCurve R₀) [W.IsElliptic]
+variable (F : Type u) [Field F] [Algebra R₀ F] [DecidableEq F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra R₀ F'] [DecidableEq F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower R₀ F F']
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F).toAffine]
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F').toAffine]
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+section FFDomain
+local notation3 "CR" => (W⁄F).toAffine.CoordinateRing
+local notation3 "FFₗ" => (W⁄F).FunctionField
+
+omit [W.IsElliptic] [DecidableEq F] [CharZero F] [Algebra R₀ F'] [DecidableEq F'] [CharZero F']
+  [IsScalarTower R₀ F F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_coordinateRingMap_basisGeneralNoAC (i : ℕ × Fin 2) :
+    CoordinateRing.map (W⁄F).toAffine (algebraMap F F')
+        (kw_coordinateRingBasis (W⁄F).toAffine i)
+      = kw_coordinateRingBasis ((W⁄F).toAffine.map (algebraMap F F')) i := by
+  obtain ⟨n, j⟩ := i
+  simp only [kw_coordinateRingBasis, Module.Basis.smulTower_apply,
+    Polynomial.coe_basisMonomials, CoordinateRing.map_smul]
+  congr 1
+  · simp [Polynomial.map_monomial]
+  · rcases j with ⟨j, hj⟩
+    interval_cases j <;>
+      simp [CoordinateRing.basis_apply, CoordinateRing.map,
+        AdjoinRoot.lift_root, AdjoinRoot.powerBasis'_gen]
+
+def kw_coordinateRingMapAlongGeneralNoAC :
+    CR →ₐ[F] ((W⁄F).toAffine.map (algebraMap F F')).CoordinateRing where
+  __ := CoordinateRing.map (W⁄F).toAffine (algebraMap F F')
+  commutes' r := by
+    simp only [RingHom.toMonoidHom_eq_coe, OneHom.toFun_eq_coe, MonoidHom.toOneHom_coe,
+      MonoidHom.coe_ofClass]
+    change CoordinateRing.map (W⁄F).toAffine (algebraMap F F') (algebraMap F CR r) = algebraMap F _
+      r
+    rw [IsScalarTower.algebraMap_apply F F[X] CR,
+      show (algebraMap F F[X] r) = Polynomial.C r from rfl,
+      show (algebraMap F[X] CR) (C r) = (C r : F[X]) • (1 : CR) by
+        rw [Algebra.smul_def, mul_one],
+      CoordinateRing.map_smul, map_one, Polynomial.map_C,
+      IsScalarTower.algebraMap_apply F F' ((W⁄F).toAffine.map (algebraMap F F')).CoordinateRing,
+      IsScalarTower.algebraMap_apply F' F'[X]
+        ((W⁄F).toAffine.map (algebraMap F F')).CoordinateRing,
+      show (algebraMap F' F'[X]) ((algebraMap F F') r) = Polynomial.C ((algebraMap F F') r)
+        from rfl,
+      Algebra.smul_def, mul_one]
+
+omit [W.IsElliptic] [DecidableEq F] [CharZero F] [Algebra R₀ F'] [DecidableEq F'] [CharZero F']
+  [IsScalarTower R₀ F F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_coordinateRingTensor_isDomainGeneralNoAC : IsDomain (CR ⊗[F] F') := by
+  suffices h : IsDomain (F' ⊗[F] CR) by
+    have := h
+    exact Function.Injective.isDomain (Algebra.TensorProduct.comm F CR F').toRingHom
+      (Algebra.TensorProduct.comm F CR F').injective
+  set W'' := (W⁄F).toAffine.map (algebraMap F F') with hW''
+  let θ : F' ⊗[F] CR →ₐ[F'] W''.CoordinateRing :=
+    AlgHom.liftEquiv F F' CR W''.CoordinateRing (kw_coordinateRingMapAlongGeneralNoAC W F F')
+  have hθ : Function.Injective θ := by
+    let bT : Module.Basis (ℕ × Fin 2) F' (F' ⊗[F] CR) :=
+      Algebra.TensorProduct.basis F' (kw_coordinateRingBasis (W⁄F).toAffine)
+    let bD : Module.Basis (ℕ × Fin 2) F' W''.CoordinateRing := kw_coordinateRingBasis W''
+    have key : ∀ i, θ.toLinearMap (bT i) = (bT.equiv bD (Equiv.refl _)) (bT i) := fun i => by
+      rw [Module.Basis.equiv_apply, Equiv.refl_apply, AlgHom.toLinearMap_apply]
+      simp only [bT, Algebra.TensorProduct.basis_apply, θ, AlgHom.liftEquiv_tmul, one_smul]
+      exact kw_coordinateRingMap_basisGeneralNoAC W F F' i
+    have heq : (θ : F' ⊗[F] CR → W''.CoordinateRing) = bT.equiv bD (Equiv.refl _) :=
+      funext fun x => DFunLike.congr_fun (bT.ext key : θ.toLinearMap = _) x
+    exact heq ▸ (bT.equiv bD (Equiv.refl _)).injective
+  exact Function.Injective.isDomain θ.toRingHom hθ
+
+omit [W.IsElliptic] [DecidableEq F] [CharZero F] [Algebra R₀ F'] [DecidableEq F'] [CharZero F']
+  [IsScalarTower R₀ F F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_functionFieldTensorIsDomain_dischargeGeneralNoAC :
+    KwFunctionFieldTensorIsDomainGeneralNoAC W F F' := by
+  change IsDomain (FFₗ ⊗[F] F')
+  have hCR : IsDomain (CR ⊗[F] F') := kw_coordinateRingTensor_isDomainGeneralNoAC W F F'
+  let : Algebra (CR ⊗[F] F') (FFₗ ⊗[F] F') :=
+    (Algebra.TensorProduct.map (IsScalarTower.toAlgHom F CR FFₗ)
+      (AlgHom.id F F')).toRingHom.toAlgebra
+  have hst : IsScalarTower CR (CR ⊗[F] F') (FFₗ ⊗[F] F') :=
+    IsScalarTower.of_algebraMap_eq (R := CR) (S := CR ⊗[F] F') (A := FFₗ ⊗[F] F') fun c => by
+      change Algebra.TensorProduct.map (IsScalarTower.toAlgHom F CR FFₗ) (AlgHom.id F F')
+          (algebraMap CR (CR ⊗[F] F') c) = algebraMap CR (FFₗ ⊗[F] F') c
+      rfl
+  have hloc : IsLocalization
+      (Algebra.algebraMapSubmonoid (CR ⊗[F] F') (nonZeroDivisors CR)) (FFₗ ⊗[F] F') :=
+    IsLocalization.tensorProduct_tensorProduct F F' (nonZeroDivisors CR) FFₗ (by
+      ext x; simp [RingHom.algebraMap_toAlgebra, Algebra.TensorProduct.map_tmul])
+  have hle : Algebra.algebraMapSubmonoid (CR ⊗[F] F') (nonZeroDivisors CR)
+      ≤ nonZeroDivisors (CR ⊗[F] F') := by
+    rintro _ ⟨c, hc, rfl⟩
+    refine mem_nonZeroDivisors_of_ne_zero ?_
+    have hinj : Function.Injective (algebraMap CR (CR ⊗[F] F')) :=
+      Algebra.TensorProduct.includeLeft_injective (S := F) (algebraMap F F').injective
+    exact fun h => (nonZeroDivisors.ne_zero hc) (hinj (by simp only [map_zero] at h ⊢; exact h))
+  exact IsLocalization.isDomain_of_le_nonZeroDivisors
+    (M := Algebra.algebraMapSubmonoid (CR ⊗[F] F') (nonZeroDivisors CR)) _ hle
+
+end FFDomain
+end SetupBCGD
+end ModularCurve
+end
+end
+
+section
+
+
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Modular\
+  Curve AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve"
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial"
+p2m_open_scoped "TensorProduct Polynomial.Bivariate \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial.Bivariate"
+
+namespace ModularCurve
+
+universe u
+
+section Setup
+
+variable {R₀ : Type u} [Field R₀]
+variable (W : WeierstrassCurve R₀) [W.IsElliptic]
+variable (F : Type u) [Field F] [Algebra R₀ F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra R₀ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower R₀ F F']
+
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F).toAffine]
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F').toAffine]
+
+omit [W.IsElliptic] [Algebra R₀ F] [DecidableEq F] [IsAlgClosed F] [CharZero F] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [IsScalarTower R₀ F F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_transcendental_polyToFunctionField_X_over_baseGeneral :
+    Transcendental F (polyToFunctionField (W⁄F') X) :=
+  Transcendental.of_tower_top F (L := F')
+    (transcendental_polyToFunctionField_X (W := (W⁄F')))
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_equation_map_polyToFunctionField_yGen_over_baseGeneral :
+    ((W⁄F).map (algebraMap F (W⁄F').FunctionField)).toAffine.Equation
+      (polyToFunctionField (W⁄F') X) (yGen (W⁄F')) := by
+  have hcurve : (W⁄F).map (algebraMap F (W⁄F').FunctionField)
+      = (W⁄F').map (algebraMap F' (W⁄F').FunctionField) := by
+    change (W.map _).map _ = (W.map _).map _
+    rw [WeierstrassCurve.map_map, WeierstrassCurve.map_map]
+    congr 1
+    exact ((IsScalarTower.algebraMap_eq R₀ F (W⁄F').FunctionField).symm).trans
+      (IsScalarTower.algebraMap_eq R₀ F' (W⁄F').FunctionField)
+  exact hcurve ▸ equation_map_polyToFunctionField_yGen (W := (W⁄F'))
+
+def kw_functionFieldMapAlongGeneral : (W⁄F).FunctionField →ₐ[F] (W⁄F').FunctionField :=
+  pointPullbackHomTo (kw_equation_map_polyToFunctionField_yGen_over_baseGeneral W F F')
+    ((injective_iff_map_eq_zero _).mpr fun p hp =>
+      transcendental_iff.mp (kw_transcendental_polyToFunctionField_X_over_baseGeneral W F F') p
+        hp)
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_functionFieldMapAlongGeneral_polyToFunctionField_X :
+    kw_functionFieldMapAlongGeneral W F F' (polyToFunctionField (W⁄F) X)
+      = polyToFunctionField (W⁄F') X :=
+  pointPullbackHomTo_polyToFunctionField_X _ _
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_functionFieldMapAlongGeneral_yGen :
+    kw_functionFieldMapAlongGeneral W F F' (yGen (W⁄F)) = yGen (W⁄F') :=
+  pointPullbackHomTo_yGen _ _
+
+def KwFunctionFieldTensorIsDomainGeneral : Prop :=
+  IsDomain ((W⁄F).FunctionField ⊗[F] F')
+
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+scoped instance kw_isScalarTower_base_right_tensorGeneral :
+    IsScalarTower R₀ F' ((W⁄F).FunctionField ⊗[F] F') := by
+  refine IsScalarTower.of_algebraMap_eq' (RingHom.ext fun r => ?_)
+  rw [RingHom.comp_apply, Algebra.TensorProduct.right_algebraMap_apply,
+    IsScalarTower.algebraMap_apply R₀ F F',
+    show algebraMap R₀ ((W⁄F).FunctionField ⊗[F] F') r
+      = (algebraMap F ((W⁄F).FunctionField ⊗[F] F')) (algebraMap R₀ F r) from
+        IsScalarTower.algebraMap_apply R₀ F ((W⁄F).FunctionField ⊗[F] F') r,
+    Algebra.TensorProduct.algebraMap_apply, Algebra.algebraMap_eq_smul_one,
+    Algebra.algebraMap_eq_smul_one, TensorProduct.smul_tmul, Algebra.algebraMap_eq_smul_one]
+
+section FracHom
+
+variable [IsDomain ((W⁄F).FunctionField ⊗[F] F')]
+
+scoped instance kw_isScalarTower_base_right_fracTensorGeneral :
+    IsScalarTower R₀ F' (FractionRing ((W⁄F).FunctionField ⊗[F] F')) :=
+  IsScalarTower.of_algebraMap_eq fun r =>
+    (IsScalarTower.algebraMap_apply R₀ ((W⁄F).FunctionField ⊗[F] F')
+        (FractionRing ((W⁄F).FunctionField ⊗[F] F')) r).trans <|
+      (congrArg (algebraMap ((W⁄F).FunctionField ⊗[F] F')
+          (FractionRing ((W⁄F).FunctionField ⊗[F] F')))
+        (IsScalarTower.algebraMap_apply R₀ F' ((W⁄F).FunctionField ⊗[F] F') r)).trans
+      (IsScalarTower.algebraMap_apply F' ((W⁄F).FunctionField ⊗[F] F')
+        (FractionRing ((W⁄F).FunctionField ⊗[F] F')) (algebraMap R₀ F' r)).symm
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] [IsDomain ((W⁄F).FunctionField ⊗[F] F')] in
+theorem kw_equation_tensorFracXYGeneral :
+    ((W⁄F').map (algebraMap F' (FractionRing ((W⁄F).FunctionField ⊗[F] F')))).toAffine.Equation
+      (algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+        ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')))
+      (algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+        ((yGen (W⁄F)) ⊗ₜ[F] (1 : F'))) := by
+  have hcurve : (W⁄F').map (algebraMap F' (FractionRing ((W⁄F).FunctionField ⊗[F] F')))
+      = W⁄(FractionRing ((W⁄F).FunctionField ⊗[F] F')) := by
+    change (W.map _).map _ = W.map _
+    rw [WeierstrassCurve.map_map]; congr 1
+    exact (IsScalarTower.algebraMap_eq R₀ F'
+      (FractionRing ((W⁄F).FunctionField ⊗[F] F'))).symm
+  rw [hcurve]
+  exact Equation.baseChange (W := W) (S := R₀)
+    (f := (IsScalarTower.toAlgHom R₀ ((W⁄F).FunctionField ⊗[F] F')
+            (FractionRing ((W⁄F).FunctionField ⊗[F] F'))).comp
+          (Algebra.TensorProduct.includeLeft (R := F) (S := R₀)))
+    (equation_map_polyToFunctionField_yGen (W := (W⁄F)))
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [Algebra R₀ F'] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [IsScalarTower R₀ F F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] [IsDomain ((W⁄F).FunctionField ⊗[F] F')] in
+theorem kw_transcendental_tensorFracXGeneral :
+    Function.Injective (Polynomial.aeval (R := F')
+      (algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+        ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')))) := by
+  rw [show algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+        ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F'))
+      = IsScalarTower.toAlgHom F' ((W⁄F).FunctionField ⊗[F] F')
+          (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+          ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')) from rfl,
+    Polynomial.aeval_algHom]
+  refine (IsFractionRing.injective ((W⁄F).FunctionField ⊗[F] F')
+    (FractionRing ((W⁄F).FunctionField ⊗[F] F'))).comp ?_
+  have heq : (Polynomial.aeval (R := F')
+        ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')
+          : (W⁄F).FunctionField ⊗[F] F')).toRingHom
+      = ((Algebra.TensorProduct.map
+            (Polynomial.aeval (R := F) (polyToFunctionField (W⁄F) X))
+            (AlgHom.id F F')).toRingHom.comp
+          (Algebra.TensorProduct.comm F F' F[X]).toAlgHom.toRingHom).comp
+          (polyEquivTensor' F F').toAlgHom.toRingHom := by
+    refine Polynomial.ringHom_ext (fun c => ?_) ?_
+    · change aeval _ (C c) = Algebra.TensorProduct.map _ _
+          (Algebra.TensorProduct.comm F F' F[X] (polyEquivTensor' F F' (C c)))
+      rw [show (polyEquivTensor' F F') (C c) = c ⊗ₜ[F] (1 : F[X]) from by
+            rw [coe_polyEquivTensor', polyEquivTensor_apply, eval₂_C]; rfl,
+        Algebra.TensorProduct.comm_tmul, Algebra.TensorProduct.map_tmul, Polynomial.aeval_C,
+        Algebra.TensorProduct.right_algebraMap_apply, AlgHom.coe_id, id_eq, map_one]
+    · change aeval _ (X : F'[X]) = Algebra.TensorProduct.map _ _
+          (Algebra.TensorProduct.comm F F' F[X] (polyEquivTensor' F F' X))
+      rw [show (polyEquivTensor' F F') X = (1:F') ⊗ₜ[F] (X : F[X]) from by
+            rw [coe_polyEquivTensor', polyEquivTensor_apply, eval₂_X],
+        Algebra.TensorProduct.comm_tmul, Algebra.TensorProduct.map_tmul, Polynomial.aeval_X,
+        AlgHom.coe_id, id_eq, Polynomial.aeval_X]
+  have hinj : Function.Injective
+      (((Algebra.TensorProduct.map
+          (Polynomial.aeval (R := F) (polyToFunctionField (W⁄F) X))
+          (AlgHom.id F F')).toRingHom.comp
+        (Algebra.TensorProduct.comm F F' F[X]).toAlgHom.toRingHom).comp
+        (polyEquivTensor' F F').toAlgHom.toRingHom) :=
+    ((Module.Flat.rTensor_preserves_injective_linearMap (M := F')
+        (Polynomial.aeval (R := F) (polyToFunctionField (W⁄F) X)).toLinearMap
+        ((injective_iff_map_eq_zero _).mpr fun p hp =>
+          transcendental_iff.mp (transcendental_polyToFunctionField_X (W := (W⁄F))) p hp)).comp
+      (Algebra.TensorProduct.comm F F' F[X]).injective).comp (polyEquivTensor' F F').injective
+  intro p q hpq
+  refine hinj ?_
+  have := DFunLike.congr_fun heq
+  exact (this p).symm.trans (hpq.trans (this q))
+
+def kw_functionFieldTensorFracHomGeneral :
+    (W⁄F').FunctionField →ₐ[F'] FractionRing ((W⁄F).FunctionField ⊗[F] F') :=
+  pointPullbackHomTo (kw_equation_tensorFracXYGeneral W F F')
+    (kw_transcendental_tensorFracXGeneral W F F')
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_functionFieldTensorFracHomGeneral_X :
+    kw_functionFieldTensorFracHomGeneral W F F' (polyToFunctionField (W⁄F') X)
+      = algebraMap ((W⁄F).FunctionField ⊗[F] F') _
+          ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')) :=
+  pointPullbackHomTo_polyToFunctionField_X _ _
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_functionFieldTensorFracHomGeneral_yGen :
+    kw_functionFieldTensorFracHomGeneral W F F' (yGen (W⁄F'))
+      = algebraMap ((W⁄F).FunctionField ⊗[F] F') _ ((yGen (W⁄F)) ⊗ₜ[F] (1 : F')) :=
+  pointPullbackHomTo_yGen _ _
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_functionFieldTensorFracHomGeneral_bijective :
+    Function.Bijective (kw_functionFieldTensorFracHomGeneral W F F') := by
+  refine ⟨(kw_functionFieldTensorFracHomGeneral W F F').injective, ?_⟩
+  set ψ := kw_functionFieldTensorFracHomGeneral W F F'
+  have hκ : (ψ.restrictScalars F).comp (kw_functionFieldMapAlongGeneral W F F')
+      = (IsScalarTower.toAlgHom F ((W⁄F).FunctionField ⊗[F] F')
+          (FractionRing ((W⁄F).FunctionField ⊗[F] F'))).comp
+          (Algebra.TensorProduct.includeLeft (R := F)) := by
+    refine kw_functionField_algHom_ext ?_ ?_
+    · change ψ (kw_functionFieldMapAlongGeneral W F F' (polyToFunctionField (W⁄F) X)) = _
+      rw [kw_functionFieldMapAlongGeneral_polyToFunctionField_X,
+        kw_functionFieldTensorFracHomGeneral_X]
+      rfl
+    · change ψ (kw_functionFieldMapAlongGeneral W F F' (yGen (W⁄F))) = _
+      rw [kw_functionFieldMapAlongGeneral_yGen, kw_functionFieldTensorFracHomGeneral_yGen]
+      rfl
+  have hT_sub : ∀ t : (W⁄F).FunctionField ⊗[F] F',
+      algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing _) t ∈ ψ.toRingHom.fieldRange := by
+    intro t
+    induction t with
+    | add _ _ hx hy => simp only [map_add]; exact add_mem hx hy
+    | tmul a c =>
+      rw [show (a ⊗ₜ[F] c : (W⁄F).FunctionField ⊗[F] F') = (a ⊗ₜ[F] 1) * (1 ⊗ₜ[F] c) from
+            by rw [Algebra.TensorProduct.tmul_mul_tmul, mul_one, one_mul],
+        map_mul]
+      refine mul_mem ?_ ⟨algebraMap F' _ c, ?_⟩
+      · exact ⟨kw_functionFieldMapAlongGeneral W F F' a, DFunLike.congr_fun hκ a⟩
+      · simp only [AlgHom.toRingHom_eq_coe, RingHom.coe_coe, ψ.commutes,
+          IsScalarTower.algebraMap_apply F' ((W⁄F).FunctionField ⊗[F] F')
+            (FractionRing ((W⁄F).FunctionField ⊗[F] F')),
+          Algebra.TensorProduct.right_algebraMap_apply]
+  intro z
+  obtain ⟨t, s, _, rfl⟩ := IsFractionRing.div_surjective
+    (A := (W⁄F).FunctionField ⊗[F] F') (K := FractionRing _) z
+  exact div_mem (hT_sub t) (hT_sub s)
+
+def kw_functionFieldTensorFracEquivGeneral :
+    (W⁄F').FunctionField ≃ₐ[F'] FractionRing ((W⁄F).FunctionField ⊗[F] F') :=
+  AlgEquiv.ofBijective _ (kw_functionFieldTensorFracHomGeneral_bijective W F F')
+
+end FracHom
+end Setup
+end ModularCurve
+end
+
+section
+
+
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Modular\
+  Curve AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve"
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial"
+p2m_open_scoped "TensorProduct Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial"
+
+namespace ModularCurve
+
+universe u
+
+section Setup
+
+variable {R₀ : Type u} [Field R₀]
+variable (W : WeierstrassCurve R₀) [W.IsElliptic]
+variable (F : Type u) [Field F] [Algebra R₀ F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra R₀ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower R₀ F F']
+
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F).toAffine]
+variable [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F').toAffine]
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+section FFDomain
+
+local notation3 "CR" => (W⁄F).toAffine.CoordinateRing
+local notation3 "FFₗ" => (W⁄F).FunctionField
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [Algebra R₀ F'] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [IsScalarTower R₀ F F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_coordinateRingMap_basisGeneral (i : ℕ × Fin 2) :
+    CoordinateRing.map (W⁄F).toAffine (algebraMap F F')
+        (kw_coordinateRingBasis (W⁄F).toAffine i)
+      = kw_coordinateRingBasis ((W⁄F).toAffine.map (algebraMap F F')) i := by
+  obtain ⟨n, j⟩ := i
+  simp only [kw_coordinateRingBasis, Module.Basis.smulTower_apply,
+    Polynomial.coe_basisMonomials, CoordinateRing.map_smul]
+  congr 1
+  · simp [Polynomial.map_monomial]
+  · rcases j with ⟨j, hj⟩
+    interval_cases j <;>
+      simp [CoordinateRing.basis_apply, CoordinateRing.map,
+        AdjoinRoot.lift_root, AdjoinRoot.powerBasis'_gen]
+
+def kw_coordinateRingMapAlongGeneral :
+    CR →ₐ[F] ((W⁄F).toAffine.map (algebraMap F F')).CoordinateRing where
+  __ := CoordinateRing.map (W⁄F).toAffine (algebraMap F F')
+  commutes' r := by
+    simp only [RingHom.toMonoidHom_eq_coe, OneHom.toFun_eq_coe, MonoidHom.toOneHom_coe,
+      MonoidHom.coe_ofClass]
+    change CoordinateRing.map (W⁄F).toAffine (algebraMap F F') (algebraMap F CR r) = algebraMap F _
+      r
+    rw [IsScalarTower.algebraMap_apply F F[X] CR,
+      show (algebraMap F F[X] r) = Polynomial.C r from rfl,
+      show (algebraMap F[X] CR) (C r) = (C r : F[X]) • (1 : CR) by
+        rw [Algebra.smul_def, mul_one],
+      CoordinateRing.map_smul, map_one, Polynomial.map_C,
+      IsScalarTower.algebraMap_apply F F' ((W⁄F).toAffine.map (algebraMap F F')).CoordinateRing,
+      IsScalarTower.algebraMap_apply F' F'[X]
+        ((W⁄F).toAffine.map (algebraMap F F')).CoordinateRing,
+      show (algebraMap F' F'[X]) ((algebraMap F F') r) = Polynomial.C ((algebraMap F F') r)
+        from rfl,
+      Algebra.smul_def, mul_one]
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [Algebra R₀ F'] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [IsScalarTower R₀ F F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_coordinateRingTensor_isDomainGeneral : IsDomain (CR ⊗[F] F') := by
+  suffices h : IsDomain (F' ⊗[F] CR) by
+    have := h
+    exact Function.Injective.isDomain (Algebra.TensorProduct.comm F CR F').toRingHom
+      (Algebra.TensorProduct.comm F CR F').injective
+  set W'' := (W⁄F).toAffine.map (algebraMap F F') with hW''
+  let θ : F' ⊗[F] CR →ₐ[F'] W''.CoordinateRing :=
+    AlgHom.liftEquiv F F' CR W''.CoordinateRing (kw_coordinateRingMapAlongGeneral W F F')
+  have hθ : Function.Injective θ := by
+    let bT : Module.Basis (ℕ × Fin 2) F' (F' ⊗[F] CR) :=
+      Algebra.TensorProduct.basis F' (kw_coordinateRingBasis (W⁄F).toAffine)
+    let bD : Module.Basis (ℕ × Fin 2) F' W''.CoordinateRing := kw_coordinateRingBasis W''
+    have key : ∀ i, θ.toLinearMap (bT i) = (bT.equiv bD (Equiv.refl _)) (bT i) := fun i => by
+      rw [Module.Basis.equiv_apply, Equiv.refl_apply, AlgHom.toLinearMap_apply]
+      simp only [bT, Algebra.TensorProduct.basis_apply, θ, AlgHom.liftEquiv_tmul, one_smul]
+      exact kw_coordinateRingMap_basisGeneral W F F' i
+    have heq : (θ : F' ⊗[F] CR → W''.CoordinateRing) = bT.equiv bD (Equiv.refl _) :=
+      funext fun x => DFunLike.congr_fun (bT.ext key : θ.toLinearMap = _) x
+    exact heq ▸ (bT.equiv bD (Equiv.refl _)).injective
+  exact Function.Injective.isDomain θ.toRingHom hθ
+
+omit [W.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F] [Algebra R₀ F'] [DecidableEq F']
+  [IsAlgClosed F'] [CharZero F'] [IsScalarTower R₀ F F'] [(toAffine W⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine W⁄F)] [(toAffine W⁄F).AbelTheorem]
+  [(toAffine W⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine W⁄F')]
+  [(toAffine W⁄F').AbelTheorem] in
+theorem kw_functionFieldTensorIsDomain_dischargeGeneral :
+    KwFunctionFieldTensorIsDomainGeneral W F F' := by
+  change IsDomain (FFₗ ⊗[F] F')
+  have hCR : IsDomain (CR ⊗[F] F') := kw_coordinateRingTensor_isDomainGeneral W F F'
+  let : Algebra (CR ⊗[F] F') (FFₗ ⊗[F] F') :=
+    (Algebra.TensorProduct.map (IsScalarTower.toAlgHom F CR FFₗ)
+      (AlgHom.id F F')).toRingHom.toAlgebra
+  have hst : IsScalarTower CR (CR ⊗[F] F') (FFₗ ⊗[F] F') :=
+    IsScalarTower.of_algebraMap_eq (R := CR) (S := CR ⊗[F] F') (A := FFₗ ⊗[F] F') fun c => by
+      change Algebra.TensorProduct.map (IsScalarTower.toAlgHom F CR FFₗ) (AlgHom.id F F')
+          (algebraMap CR (CR ⊗[F] F') c) = algebraMap CR (FFₗ ⊗[F] F') c
+      rfl
+  have hloc : IsLocalization
+      (Algebra.algebraMapSubmonoid (CR ⊗[F] F') (nonZeroDivisors CR)) (FFₗ ⊗[F] F') :=
+    IsLocalization.tensorProduct_tensorProduct F F' (nonZeroDivisors CR) FFₗ (by
+      ext x; simp [RingHom.algebraMap_toAlgebra, Algebra.TensorProduct.map_tmul])
+  have hle : Algebra.algebraMapSubmonoid (CR ⊗[F] F') (nonZeroDivisors CR)
+      ≤ nonZeroDivisors (CR ⊗[F] F') := by
+    rintro _ ⟨c, hc, rfl⟩
+    refine mem_nonZeroDivisors_of_ne_zero ?_
+    have hinj : Function.Injective (algebraMap CR (CR ⊗[F] F')) :=
+      Algebra.TensorProduct.includeLeft_injective (S := F) (algebraMap F F').injective
+    exact fun h => (nonZeroDivisors.ne_zero hc) (hinj (by simp only [map_zero] at h ⊢; exact h))
+  exact IsLocalization.isDomain_of_le_nonZeroDivisors
+    (M := Algebra.algebraMapSubmonoid (CR ⊗[F] F') (nonZeroDivisors CR)) _ hle
+
+end FFDomain
+end Setup
+end ModularCurve
+end
+
+section
+
+section
+
+p2m_open "IsDedekindDomain \
+  P2MW.S_OVERLONG_55b03433.IsDedek\
+  indDomain Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial"
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong Place.ramificationIndexAlong \
+  Place.ord_restrictAlong SeparableAlong Place.ramificationIndex_pos Place Place.ext Place.ord_mul \
+  Divisor HasPrincipalDivisors Pic0 Pic0.mk Place.ofHeightOneSpectrum \
+  Place.ofHeightOneSpectrum_toValuationSubring Place.toValuationSubring \
+  Place.mem_maximalIdeal_iff_ord_pos Place.ofHeightOneSpectrum_injective \
+  Place.ord_ofHeightOneSpectrum_ne_zero_iff normFormulaAlong"
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg"
+
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndexAlong ord_restrictAlong \
+  ramificationIndex_pos restrict ext ResidueField deg adicValuation adicValuation_ne_zero \
+  adicValuation_coe_eq_one_iff ord ord_mul ord_inv ord_unit_smul_zpow exists_unit_mul_zpow \
+  ofHeightOneSpectrum ofHeightOneSpectrum_toValuationSubring ne_top' algebraMap_mem' \
+  toValuationSubring mk mem_of_eval_monic_eq_zero mem_maximalIdeal_iff_ord_pos center \
+  valuationSubringAlgebra IsRational evalAt ord_eq_zero_iff_adicValuation_eq_one \
+  ofHeightOneSpectrum_injective ord_ofHeightOneSpectrum_ne_zero_iff evalAt_mul evalAt_inv"
+p2m_open "AlgebraicCurve.Place~ord_nonneg_of_mem~mem_of_ord_nonneg~mem_iff_ord_nonneg"
+
+section Chart
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {R : Type*} [CommRing R] [IsDedekindDomain R] [Algebra R F] [IsFractionRing R F]
+variable (w : Place K F)
+scoped instance (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring) :
+    (center R w hw).IsPrime :=
+  Ideal.comap_isPrime _ _
+end Chart
+end Place
+end AlgebraicCurve
+end
+
+section
+
+
+section
+
+p2m_open "P2MW.S_OVERLONG_55b03433\
+  .ModularCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve"
+
+namespace ModularCurve
+
+universe u
+
+attribute [local instance] Classical.propDecidable
+section BaseChangeMint
+
+def KwD5BetweenCurvesFFSeamBaseChange : Prop :=
+  ∀ (R₀ : Type) [Field R₀]
+    (E₀ E₀' : WeierstrassCurve R₀) [E₀.IsElliptic] [E₀'.IsElliptic]
+    (F F' : Type) [Field F] [Field F'] [Algebra R₀ F] [Algebra R₀ F']
+    [DecidableEq F] [DecidableEq F'] [IsAlgClosed F] [IsAlgClosed F']
+    [CharZero F] [CharZero F']
+    [(E₀⁄F).IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀⁄F).toAffine] [(E₀'⁄F).IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀'⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀'⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀'⁄F).toAffine] [(E₀⁄F').IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀⁄F').toAffine] [(E₀'⁄F').IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀'⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀'⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀'⁄F').toAffine]
+    (_σ : F →ₐ[R₀] F')
+    (ι₀ : (E₀'⁄F).toAffine.FunctionField →ₐ[F] (E₀⁄F).toAffine.FunctionField)
+    (hι₀ : ι₀.toRingHom.IsIntegral) (hfin₀ : FiniteAlong F ι₀)
+    (N : ℕ) [NeZero N],
+    IsAddCyclic (AddMonoidHom.ker
+      (pointMapOfPushforward ι₀ hι₀ hfin₀ (normFormulaAlong_of_elliptic ι₀ hfin₀))) →
+    Nat.card (AddMonoidHom.ker
+      (pointMapOfPushforward ι₀ hι₀ hfin₀ (normFormulaAlong_of_elliptic ι₀ hfin₀))) = N →
+    ∃ (ι₁ : (E₀'⁄F').toAffine.FunctionField →ₐ[F'] (E₀⁄F').toAffine.FunctionField)
+      (hι₁ : ι₁.toRingHom.IsIntegral) (hfin₁ : FiniteAlong F' ι₁),
+      IsAddCyclic (AddMonoidHom.ker
+        (pointMapOfPushforward ι₁ hι₁ hfin₁ (normFormulaAlong_of_elliptic ι₁ hfin₁))) ∧
+      Nat.card (AddMonoidHom.ker
+        (pointMapOfPushforward ι₁ hι₁ hfin₁ (normFormulaAlong_of_elliptic ι₁ hfin₁))) = N
+
+end BaseChangeMint
+end ModularCurve
+end
+end
+
+section
+
+
+section
+
+p2m_open "P2MW.S_OVERLONG_55b03433\
+  .ModularCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve"
+p2m_open_scoped "TensorProduct Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial Polynomial.Bivariate \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial.Bivariate"
+
+namespace ModularCurve
+
+universe u
+
+attribute [local instance] Classical.propDecidable
+
+section BetweenCurvesTensor
+
+variable {R₀ : Type u} [Field R₀]
+variable (E₀ E₀' : WeierstrassCurve R₀) [E₀.IsElliptic] [E₀'.IsElliptic]
+variable (F : Type u) [Field F] [Algebra R₀ F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra R₀ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower R₀ F F']
+variable [(E₀⁄F).IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀⁄F).toAffine] [(E₀'⁄F).IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀'⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀'⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀'⁄F).toAffine] [(E₀⁄F').IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀⁄F').toAffine] [(E₀'⁄F').IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀'⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀'⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀'⁄F').toAffine]
+variable (ι₀ : (E₀'⁄F).toAffine.FunctionField →ₐ[F] (E₀⁄F).toAffine.FunctionField)
+
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+def kw_surge_hgf4_bcTensorIota :
+    (E₀'⁄F).toAffine.FunctionField ⊗[F] F' →ₐ[F] (E₀⁄F).toAffine.FunctionField ⊗[F] F' :=
+  Algebra.TensorProduct.map ι₀ (AlgHom.id F F')
+
+omit [E₀.IsElliptic] [E₀'.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+  [Algebra R₀ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F'] [IsScalarTower R₀ F F']
+  [WeierstrassCurve.IsElliptic E₀⁄F] [(toAffine E₀⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F)] [(toAffine E₀⁄F).AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀'⁄F] [(toAffine E₀'⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F)] [(toAffine E₀'⁄F).AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀⁄F'] [(toAffine E₀⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F')] [(toAffine E₀⁄F').AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀'⁄F'] [(toAffine E₀'⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F')] [(toAffine E₀'⁄F').AbelTheorem] in
+theorem kw_surge_hgf4_bcTensorIota_tmul (a : (E₀'⁄F).toAffine.FunctionField) (c : F') :
+    kw_surge_hgf4_bcTensorIota E₀ E₀' F F' ι₀ (a ⊗ₜ[F] c) = (ι₀ a) ⊗ₜ[F] c := by
+  simp [kw_surge_hgf4_bcTensorIota, Algebra.TensorProduct.map_tmul]
+
+omit [E₀.IsElliptic] [E₀'.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+  [Algebra R₀ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F'] [IsScalarTower R₀ F F']
+  [WeierstrassCurve.IsElliptic E₀⁄F] [(toAffine E₀⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F)] [(toAffine E₀⁄F).AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀'⁄F] [(toAffine E₀'⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F)] [(toAffine E₀'⁄F).AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀⁄F'] [(toAffine E₀⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F')] [(toAffine E₀⁄F').AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀'⁄F'] [(toAffine E₀'⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F')] [(toAffine E₀'⁄F').AbelTheorem] in
+theorem kw_surge_hgf4_bcTensorIota_injective :
+    Function.Injective (kw_surge_hgf4_bcTensorIota E₀ E₀' F F' ι₀) :=
+  Module.Flat.rTensor_preserves_injective_linearMap (M := F') ι₀.toLinearMap ι₀.injective
+
+variable [IsDomain ((E₀⁄F).toAffine.FunctionField ⊗[F] F')]
+variable [IsDomain ((E₀'⁄F).toAffine.FunctionField ⊗[F] F')]
+
+def kw_surge_hgf4_bcTensorFracIota :
+    FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F')
+      →+* FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F') :=
+  IsFractionRing.map (K := FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F'))
+    (L := FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F'))
+    (kw_surge_hgf4_bcTensorIota_injective E₀ E₀' F F' ι₀)
+
+omit [IsDomain ((toAffine E₀'⁄F).FunctionField ⊗[F] F')] in
+omit [E₀.IsElliptic] [E₀'.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+  [Algebra R₀ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F'] [IsScalarTower R₀ F F']
+  [WeierstrassCurve.IsElliptic E₀⁄F] [(toAffine E₀⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F)] [(toAffine E₀⁄F).AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀'⁄F] [(toAffine E₀'⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F)] [(toAffine E₀'⁄F).AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀⁄F'] [(toAffine E₀⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F')] [(toAffine E₀⁄F').AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀'⁄F'] [(toAffine E₀'⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F')] [(toAffine E₀'⁄F').AbelTheorem] in
+theorem kw_surge_hgf4_bcTensorFracIota_algebraMap
+    (t : (E₀'⁄F).toAffine.FunctionField ⊗[F] F') :
+    kw_surge_hgf4_bcTensorFracIota E₀ E₀' F F' ι₀
+        (algebraMap ((E₀'⁄F).toAffine.FunctionField ⊗[F] F') _ t)
+      = algebraMap ((E₀⁄F).toAffine.FunctionField ⊗[F] F') _
+          (kw_surge_hgf4_bcTensorIota E₀ E₀' F F' ι₀ t) := by
+  unfold kw_surge_hgf4_bcTensorFracIota IsFractionRing.map
+  exact IsLocalization.map_eq
+    (T := nonZeroDivisors ((E₀⁄F).toAffine.FunctionField ⊗[F] F')) _ t
+
+omit [E₀.IsElliptic] [E₀'.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+  [Algebra R₀ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F'] [IsScalarTower R₀ F F']
+  [WeierstrassCurve.IsElliptic E₀⁄F] [(toAffine E₀⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F)] [(toAffine E₀⁄F).AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀'⁄F] [(toAffine E₀'⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F)] [(toAffine E₀'⁄F).AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀⁄F'] [(toAffine E₀⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F')] [(toAffine E₀⁄F').AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀'⁄F'] [(toAffine E₀'⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F')] [(toAffine E₀'⁄F').AbelTheorem]
+  [IsDomain ((toAffine E₀⁄F).FunctionField ⊗[F] F')]
+  [IsDomain ((toAffine E₀'⁄F).FunctionField ⊗[F] F')] in
+theorem kw_surge_hgf4_bcTensorIota_finite (hfin₀ : FiniteAlong F ι₀) :
+    (kw_surge_hgf4_bcTensorIota E₀ E₀' F F' ι₀).toRingHom.Finite :=
+  RingHom.Finite.tensorProductMap (f := ι₀) hfin₀ (g := AlgHom.id F F') (RingHom.Finite.id F')
+
+def kw_surge_hgf4_bcTensorFracIotaAlg :
+    FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F')
+      →ₐ[F'] FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F') :=
+  { kw_surge_hgf4_bcTensorFracIota E₀ E₀' F F' ι₀ with
+    commutes' := fun c => by
+      change kw_surge_hgf4_bcTensorFracIota E₀ E₀' F F' ι₀ (algebraMap F' _ c)
+          = algebraMap F' _ c
+      rw [IsScalarTower.algebraMap_apply F' ((E₀'⁄F).toAffine.FunctionField ⊗[F] F')
+          (FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F')),
+        Algebra.TensorProduct.right_algebraMap_apply,
+        kw_surge_hgf4_bcTensorFracIota_algebraMap E₀ E₀' F F' ι₀,
+        kw_surge_hgf4_bcTensorIota_tmul, map_one,
+        IsScalarTower.algebraMap_apply F' ((E₀⁄F).toAffine.FunctionField ⊗[F] F')
+          (FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F')),
+        Algebra.TensorProduct.right_algebraMap_apply] }
+
+def kw_surge_hgf4_bcIota₁ :
+    (E₀'⁄F').toAffine.FunctionField →ₐ[F'] (E₀⁄F').toAffine.FunctionField :=
+  let ψE := kw_functionFieldTensorFracEquivGeneral E₀ F F'
+  let ψE' := kw_functionFieldTensorFracEquivGeneral E₀' F F'
+  (ψE.symm.toAlgHom.comp (kw_surge_hgf4_bcTensorFracIotaAlg E₀ E₀' F F' ι₀)).comp
+    ψE'.toAlgHom
+
+omit [E₀.IsElliptic] [E₀'.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+  [Algebra R₀ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F'] [IsScalarTower R₀ F F']
+  [WeierstrassCurve.IsElliptic E₀⁄F] [(toAffine E₀⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F)] [(toAffine E₀⁄F).AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀'⁄F] [(toAffine E₀'⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F)] [(toAffine E₀'⁄F).AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀⁄F'] [(toAffine E₀⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F')] [(toAffine E₀⁄F').AbelTheorem]
+  [WeierstrassCurve.IsElliptic E₀'⁄F'] [(toAffine E₀'⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F')] [(toAffine E₀'⁄F').AbelTheorem] in
+theorem kw_surge_hgf4_bcTensorFracIotaSeam (hfin₀ : FiniteAlong F ι₀) :
+    (kw_surge_hgf4_bcTensorFracIota E₀ E₀' F F' ι₀).Finite ∧
+    (letI := (kw_surge_hgf4_bcTensorFracIota E₀ E₀' F F' ι₀).toAlgebra
+     @Module.finrank (FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F'))
+       (FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F')) _ _ Algebra.toModule)
+      = finrankAlong F ι₀ := by
+  classical
+  let FF := (E₀⁄F).toAffine.FunctionField
+  let FF' := (E₀'⁄F).toAffine.FunctionField
+  let T := (E₀⁄F).toAffine.FunctionField ⊗[F] F'
+  let T' := (E₀'⁄F).toAffine.FunctionField ⊗[F] F'
+  let FrT := FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F')
+  let FrT' := FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F')
+  let ιT : T' →+* T := (kw_surge_hgf4_bcTensorIota E₀ E₀' F F' ι₀).toRingHom
+  let ιFr : FrT' →+* FrT := kw_surge_hgf4_bcTensorFracIota E₀ E₀' F F' ι₀
+  have hιT_inj : Function.Injective ιT :=
+    kw_surge_hgf4_bcTensorIota_injective E₀ E₀' F F' ι₀
+  have hιT_fin : ιT.Finite := kw_surge_hgf4_bcTensorIota_finite E₀ E₀' F F' ι₀ hfin₀
+  have hιFr_am : ∀ t : T', ιFr (algebraMap T' FrT' t) = algebraMap T FrT (ιT t) :=
+    kw_surge_hgf4_bcTensorFracIota_algebraMap E₀ E₀' F F' ι₀
+  let algι : Algebra FF' FF := ι₀.toRingHom.toAlgebra
+  let modι : Module FF' FF := Algebra.toModule
+  have hsmul_ι : ∀ (c : FF') (x : FF), c • x = ι₀ c * x := fun c x => rfl
+  have hfinFF : Module.Finite FF' FF := hfin₀
+  have hfreeFF : Module.Free FF' FF := Module.Free.of_divisionRing FF' FF
+  let D := finrankAlong F ι₀
+  let b : Module.Basis (Fin D) FF' FF := Module.finBasisOfFinrankEq FF' FF (n := D) rfl
+  have hrepr_mul : ∀ (c : FF') (x : FF) (j : Fin D),
+      b.repr (ι₀ c * x) j = c * b.repr x j := fun c x j => by
+    rw [← hsmul_ι, map_smul, Finsupp.smul_apply, smul_eq_mul]
+  let e : Fin D → T := fun i => (b i) ⊗ₜ[F] (1 : F')
+  let bFr : Fin D → FrT := fun i => algebraMap T FrT (e i)
+  have hspanT : ∀ t : T, ∃ c : Fin D → T', t = ∑ i, ιT (c i) * e i := by
+    intro t
+    induction t using TensorProduct.inductionOn with
+    | add x y hx hy =>
+      obtain ⟨cx, hx⟩ := hx; obtain ⟨cy, hy⟩ := hy
+      exact ⟨cx + cy, by simp only [Pi.add_apply, map_add, add_mul,
+        Finset.sum_add_distrib, ← hx, ← hy]⟩
+    | tmul a c =>
+      refine ⟨fun i => (b.repr a i) ⊗ₜ[F] c, ?_⟩
+      have hb_sum : a = ∑ i, ι₀ (b.repr a i) * b i := by
+        conv_lhs => rw [← b.linearCombination_repr a, Finsupp.linearCombination_apply,
+          Finsupp.sum_fintype _ _ (fun i => by rw [hsmul_ι, map_zero, zero_mul])]
+        exact Finset.sum_congr rfl fun i _ => hsmul_ι _ _
+      calc (a ⊗ₜ[F] c : T)
+          = (∑ i, ι₀ (b.repr a i) * b i) ⊗ₜ[F] c := by rw [← hb_sum]
+        _ = ∑ i, ιT ((b.repr a i) ⊗ₜ[F] c) * e i := by
+            rw [TensorProduct.sum_tmul]
+            refine Finset.sum_congr rfl fun i _ => ?_
+            show (ι₀ (b.repr a i) * b i) ⊗ₜ[F] c = ιT ((b.repr a i) ⊗ₜ[F] c) * e i
+            rw [show ιT ((b.repr a i) ⊗ₜ[F] c) = (ι₀ (b.repr a i)) ⊗ₜ[F] c from
+                  kw_surge_hgf4_bcTensorIota_tmul E₀ E₀' F F' ι₀ _ _,
+              Algebra.TensorProduct.tmul_mul_tmul, mul_one]
+  have hliT : ∀ c : Fin D → T', ∑ i, ιT (c i) * e i = 0 → ∀ j, c j = 0 := by
+    intro c hc j
+    let pj : FF →ₗ[F] FF' :=
+      { toFun := fun x => b.repr x j
+        map_add' := fun x y => by simp only [map_add, Finsupp.add_apply]
+        map_smul' := fun f x => by
+          simp only [RingHom.id_apply, Algebra.smul_def]
+          have h := hrepr_mul (algebraMap F FF' f) x j
+          rwa [ι₀.commutes] at h }
+    let Ej : T →ₗ[F] T' := LinearMap.rTensor F' pj
+    have hEj_key : ∀ (a : T') (i : Fin D),
+        Ej (ιT a * e i) = if i = j then a else 0 := by
+      intro a i
+      induction a using TensorProduct.inductionOn with
+      | add x y hx hy =>
+        simp only [map_add, add_mul, hx, hy]; split_ifs <;> simp
+      | tmul x c' =>
+        rw [show ιT ((x : FF') ⊗ₜ[F] c') = (ι₀ x) ⊗ₜ[F] c' from
+              kw_surge_hgf4_bcTensorIota_tmul E₀ E₀' F F' ι₀ _ _,
+            Algebra.TensorProduct.tmul_mul_tmul, mul_one]
+        change (pj (ι₀ x * b i)) ⊗ₜ[F] c' = if i = j then (x : FF') ⊗ₜ[F] c' else 0
+        rw [show pj (ι₀ x * b i) = if i = j then x else 0 from ?_]
+        · split_ifs with h
+          · rfl
+          · exact TensorProduct.zero_tmul _ c'
+        · change b.repr (ι₀ x * b i) j = if i = j then x else 0
+          rw [hrepr_mul, b.repr_self, Finsupp.single_apply]
+          split_ifs with h <;> simp
+    have hc' : Ej (∑ i, ιT (c i) * e i) = 0 := by rw [hc, map_zero]
+    simpa only [map_sum, hEj_key, Finset.sum_ite_eq', Finset.mem_univ, ite_true] using hc'
+  have hint : ∀ s : T, s ≠ 0 → ∃ (u : T) (s₀ : T'), s₀ ≠ 0 ∧ s * u = ιT s₀ := by
+    intro s hs
+    obtain ⟨p, hp_monic, hp_eval⟩ : ιT.IsIntegralElem s := hιT_fin.to_isIntegral s
+    obtain ⟨q, hq_eq, hq_ndvd⟩ := Polynomial.exists_eq_pow_rootMultiplicity_mul_and_not_dvd p
+      hp_monic.ne_zero 0
+    simp only [Polynomial.C_0, sub_zero] at hq_eq hq_ndvd
+    have hq0 : q.coeff 0 ≠ 0 := fun h => hq_ndvd (Polynomial.X_dvd_iff.mpr h)
+    have hqs : q.eval₂ ιT s = 0 := by
+      have h := hp_eval
+      rw [hq_eq, Polynomial.eval₂_mul, Polynomial.eval₂_pow, Polynomial.eval₂_X,
+        mul_eq_zero] at h
+      exact h.resolve_left (pow_ne_zero _ hs)
+    have h3 : ιT (q.coeff 0) + s * (q.divX).eval₂ ιT s = 0 := by
+      have h := congrArg (Polynomial.eval₂ ιT s) (Polynomial.divX_mul_X_add q)
+      rw [Polynomial.eval₂_add, Polynomial.eval₂_mul, Polynomial.eval₂_X,
+        Polynomial.eval₂_C, hqs] at h
+      simpa only [add_comm, mul_comm] using h
+    exact ⟨(q.divX).eval₂ ιT s, -q.coeff 0, neg_ne_zero.mpr hq0,
+      by rw [map_neg]; exact eq_neg_of_add_eq_zero_right h3⟩
+  have hspanFr : ∀ z : FrT, ∃ d : Fin D → FrT', z = ∑ i, ιFr (d i) * bFr i := by
+    intro z
+    obtain ⟨t, s, _, rfl⟩ := IsFractionRing.div_surjective (A := T) (K := FrT) z
+    rcases eq_or_ne s 0 with rfl | hs'
+    · exact ⟨0, by simp⟩
+    obtain ⟨u, s₀, hs₀, hsu⟩ := hint s hs'
+    have hιTs₀ : ιT s₀ ≠ 0 := fun h => hs₀ (hιT_inj (h.trans (map_zero ιT).symm))
+    have hu_ne : u ≠ 0 := fun h => hιTs₀ (by rw [← hsu, h, mul_zero])
+    obtain ⟨c, hc⟩ := hspanT (t * u)
+    refine ⟨fun i => (algebraMap T' FrT' s₀)⁻¹ * algebraMap T' FrT' (c i), ?_⟩
+    have hum := (map_ne_zero_iff _ (IsFractionRing.injective T FrT)).mpr hu_ne
+    have hz : (algebraMap T FrT t) / (algebraMap T FrT s)
+        = (algebraMap T FrT (ιT s₀))⁻¹ * algebraMap T FrT (t * u) := by
+      rw [← div_eq_inv_mul, ← hsu, map_mul, map_mul,
+        ← div_mul_div_comm, div_self hum, mul_one]
+    rw [hz, hc, map_sum, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [map_mul, map_mul, ← hιFr_am s₀, ← hιFr_am (c i), ← map_inv₀ ιFr, mul_assoc]
+  have hliFr : ∀ d : Fin D → FrT', ∑ i, ιFr (d i) * bFr i = 0 → ∀ j, d j = 0 := by
+    intro d hd j
+    obtain ⟨q, hq⟩ := IsLocalization.exist_integer_multiples_of_finset
+      (nonZeroDivisors T') (Finset.univ.image d)
+    choose p hp using fun i => hq (d i) (Finset.mem_image_of_mem d (Finset.mem_univ i))
+    have hq0 : (algebraMap T' FrT' (q : T')) ≠ 0 :=
+      (map_ne_zero_iff _ (IsFractionRing.injective T' FrT')).mpr (nonZeroDivisors.ne_zero q.2)
+    have hp' : ∀ i, algebraMap T' FrT' (p i) = algebraMap T' FrT' (q : T') * d i := fun i => by
+      rw [hp i, Algebra.smul_def]
+    have hd' : algebraMap T FrT (∑ i, ιT (p i) * e i) = 0 := by
+      have h1 : ∑ i, ιFr (algebraMap T' FrT' (q : T')) * (ιFr (d i) * bFr i) = 0 := by
+        rw [← Finset.mul_sum, hd, mul_zero]
+      rw [map_sum, ← h1]; refine Finset.sum_congr rfl fun i _ => ?_
+      rw [map_mul, ← hιFr_am (p i), ← mul_assoc, ← map_mul, ← hp' i]
+    have hpj : p j = 0 :=
+      hliT p ((IsFractionRing.injective T FrT) (by simpa using hd')) j
+    have hthis : algebraMap T' FrT' (q : T') * d j = 0 := by
+      rw [← hp' j, hpj, map_zero]
+    exact (mul_eq_zero.mp hthis).resolve_left hq0
+  let algFr : Algebra FrT' FrT := ιFr.toAlgebra
+  let modFr : Module FrT' FrT := Algebra.toModule
+  have hsmul_Fr : ∀ (c : FrT') (x : FrT), c • x = ιFr c * x := fun c x => rfl
+  have hli_modFr : LinearIndependent FrT' bFr := by
+    rw [Fintype.linearIndependent_iff]
+    intro g hg i
+    refine hliFr g ?_ i
+    simpa only [hsmul_Fr] using hg
+  have hsp_modFr : ⊤ ≤ Submodule.span FrT' (Set.range bFr) := by
+    intro z _
+    obtain ⟨d, hd⟩ := hspanFr z
+    rw [hd]
+    exact Submodule.sum_mem _ fun i _ => (hsmul_Fr (d i) (bFr i)) ▸
+      Submodule.smul_mem _ (d i) (Submodule.subset_span ⟨i, rfl⟩)
+  let bFr' : Module.Basis (Fin D) FrT' FrT := .mk hli_modFr hsp_modFr
+  refine ⟨Module.Finite.of_basis bFr', ?_⟩
+  change Module.finrank FrT' FrT = D
+  rw [Module.finrank_eq_card_basis bFr', Fintype.card_fin]
+
+omit [E₀.IsElliptic] [E₀'.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+  [DecidableEq F'] [IsAlgClosed F'] [CharZero F'] [WeierstrassCurve.IsElliptic E₀⁄F]
+  [(toAffine E₀⁄F).GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F)]
+  [(toAffine E₀⁄F).AbelTheorem] [WeierstrassCurve.IsElliptic E₀'⁄F]
+  [(toAffine E₀'⁄F).GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F)]
+  [(toAffine E₀'⁄F).AbelTheorem] [WeierstrassCurve.IsElliptic E₀⁄F']
+  [(toAffine E₀⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F')]
+  [(toAffine E₀⁄F').AbelTheorem] [WeierstrassCurve.IsElliptic E₀'⁄F']
+  [(toAffine E₀'⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F')]
+  [(toAffine E₀'⁄F').AbelTheorem] in
+theorem kw_surge_hgf4_bcIota₁_finiteAlong (hfin₀ : FiniteAlong F ι₀) :
+    FiniteAlong F' (kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀) := by
+  have hFr_fin := (kw_surge_hgf4_bcTensorFracIotaSeam E₀ E₀' F F' ι₀ hfin₀).1
+  let ψE := kw_functionFieldTensorFracEquivGeneral E₀ F F'
+  let ψE' := kw_functionFieldTensorFracEquivGeneral E₀' F F'
+  have h1 : RingHom.Finite ψE'.toAlgHom.toRingHom :=
+    RingHom.Finite.of_surjective _ ψE'.surjective
+  have h2 : RingHom.Finite ψE.symm.toAlgHom.toRingHom :=
+    RingHom.Finite.of_surjective _ ψE.symm.surjective
+  change RingHom.Finite (kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀).toRingHom
+  have hcomp : (kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀).toRingHom
+      = (ψE.symm.toAlgHom.toRingHom.comp
+          (kw_surge_hgf4_bcTensorFracIota E₀ E₀' F F' ι₀)).comp ψE'.toAlgHom.toRingHom := rfl
+  rw [hcomp]
+  exact RingHom.Finite.comp (RingHom.Finite.comp h2 hFr_fin) h1
+
+omit [E₀.IsElliptic] [E₀'.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+  [DecidableEq F'] [IsAlgClosed F'] [CharZero F'] [WeierstrassCurve.IsElliptic E₀⁄F]
+  [(toAffine E₀⁄F).GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F)]
+  [(toAffine E₀⁄F).AbelTheorem] [WeierstrassCurve.IsElliptic E₀'⁄F]
+  [(toAffine E₀'⁄F).GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F)]
+  [(toAffine E₀'⁄F).AbelTheorem] [WeierstrassCurve.IsElliptic E₀⁄F']
+  [(toAffine E₀⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F')]
+  [(toAffine E₀⁄F').AbelTheorem] [WeierstrassCurve.IsElliptic E₀'⁄F']
+  [(toAffine E₀'⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F')]
+  [(toAffine E₀'⁄F').AbelTheorem] in
+theorem kw_surge_hgf4_bcIota₁_isIntegral (hfin₀ : FiniteAlong F ι₀) :
+    (kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀).toRingHom.IsIntegral :=
+  RingHom.Finite.to_isIntegral
+    (show RingHom.Finite (kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀).toRingHom from
+      kw_surge_hgf4_bcIota₁_finiteAlong E₀ E₀' F F' ι₀ hfin₀)
+
+omit [E₀.IsElliptic] [E₀'.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+  [DecidableEq F'] [IsAlgClosed F'] [CharZero F'] [WeierstrassCurve.IsElliptic E₀⁄F]
+  [(toAffine E₀⁄F).GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F)]
+  [(toAffine E₀⁄F).AbelTheorem] [WeierstrassCurve.IsElliptic E₀'⁄F]
+  [(toAffine E₀'⁄F).GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F)]
+  [(toAffine E₀'⁄F).AbelTheorem] [WeierstrassCurve.IsElliptic E₀⁄F']
+  [(toAffine E₀⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F')]
+  [(toAffine E₀⁄F').AbelTheorem] [WeierstrassCurve.IsElliptic E₀'⁄F']
+  [(toAffine E₀'⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F')]
+  [(toAffine E₀'⁄F').AbelTheorem] in
+theorem kw_surge_hgf4_bcIota₁_finrankAlong (hfin₀ : FiniteAlong F ι₀) :
+    finrankAlong F' (kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀) = finrankAlong F ι₀ := by
+  let ψE := kw_functionFieldTensorFracEquivGeneral E₀ F F'
+  let ψE' := kw_functionFieldTensorFracEquivGeneral E₀' F F'
+  let ιFr := kw_surge_hgf4_bcTensorFracIota E₀ E₀' F F' ι₀
+  have hcomm : ∀ x, ιFr (ψE' x)
+      = ψE (kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀ x) := fun x => by
+    change ιFr (ψE' x) = ψE (ψE.symm (_))
+    exact (ψE.apply_symm_apply _).symm
+  calc finrankAlong F' (kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀)
+      = (letI := ιFr.toAlgebra
+         @Module.finrank (FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F'))
+           (FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F')) _ _ Algebra.toModule) :=
+        @Algebra.finrank_eq_of_equiv_equiv
+          (E₀'⁄F').toAffine.FunctionField (E₀⁄F').toAffine.FunctionField _ _
+          (algebraAlong (kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀))
+          _ _ _ _ ιFr.toAlgebra ψE'.toRingEquiv ψE.toRingEquiv (RingHom.ext hcomm)
+    _ = finrankAlong F ι₀ := (kw_surge_hgf4_bcTensorFracIotaSeam E₀ E₀' F F' ι₀ hfin₀).2
+
+section Naturality
+
+variable (hι₀ : ι₀.toRingHom.IsIntegral) (hfin₀ : FiniteAlong F ι₀)
+variable (σ : F →ₐ[R₀] F') (hσ : ∀ c, σ c = algebraMap F F' c)
+
+local notation "χE" => kw_functionFieldMapAlongGeneral E₀ F F'
+local notation "χE'" => kw_functionFieldMapAlongGeneral E₀' F F'
+local notation "ι₁" => kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀
+
+theorem kw_surge_hgf4_place_inv_mem_of_isUnit {K L : Type*} [Field K] [Field L] [Algebra K L]
+    (v : Place K L) {z : v.toValuationSubring} (hz : IsUnit z) :
+    ((z : L))⁻¹ ∈ v.toValuationSubring := by
+  obtain ⟨w, hw⟩ := hz.exists_right_inv
+  have hmul : (z : L) * (w : L) = 1 := by
+    have h := congrArg (fun a : v.toValuationSubring => (a : L)) hw
+    simpa using h
+  rw [inv_eq_of_mul_eq_one_right hmul]; exact w.2
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [IsAlgClosed F] [CharZero F] [IsAlgClosed F'] [CharZero F'] in
+theorem kw_surge_hgf4_toAffine_map_eq (V : WeierstrassCurve R₀) :
+    (V⁄F).toAffine.map (algebraMap F F') = (V⁄F').toAffine := by
+  classical
+  change ((V.map (algebraMap R₀ F)).map (algebraMap F F')).toAffine = (V.map (algebraMap R₀
+    F')).toAffine
+  rw [WeierstrassCurve.map_map, ← IsScalarTower.algebraMap_eq R₀ F F']
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt\
+  " in
+open
+  _root_.P2MW.S_OVERLONG_55b03433.WeierstrassCurve.Affine.CoordinateRing
+  in
+omit [IsAlgClosed F] [CharZero F] [IsAlgClosed F'] [CharZero F'] in
+theorem kw_surge_hgf4_χE_algebraMap_XClass (V : WeierstrassCurve R₀) [V.IsElliptic]
+    [(V⁄F).IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate (V⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (V⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (V⁄F).toAffine] [(V⁄F').IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (V⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (V⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (V⁄F').toAffine] (x : F) :
+    kw_functionFieldMapAlongGeneral V F F'
+        (algebraMap (V⁄F).toAffine.CoordinateRing (V⁄F).toAffine.FunctionField
+          (XClass (V⁄F).toAffine x))
+      = algebraMap (V⁄F').toAffine.CoordinateRing (V⁄F').toAffine.FunctionField
+          (XClass (V⁄F').toAffine (algebraMap F F' x)) := by
+  have hF : algebraMap (V⁄F).toAffine.CoordinateRing (V⁄F).toAffine.FunctionField
+      (XClass (V⁄F).toAffine x)
+      = polyToFunctionField (V⁄F).toAffine X - algebraMap F (V⁄F).toAffine.FunctionField x := by
+    rw [← polyToFunctionField_C, ← map_sub]; rfl
+  have hF' : algebraMap (V⁄F').toAffine.CoordinateRing (V⁄F').toAffine.FunctionField
+      (XClass (V⁄F').toAffine (algebraMap F F' x))
+      = polyToFunctionField (V⁄F').toAffine X
+          - algebraMap F' (V⁄F').toAffine.FunctionField (algebraMap F F' x) := by
+    rw [← polyToFunctionField_C, ← map_sub]; rfl
+  rw [hF, hF', map_sub, kw_functionFieldMapAlongGeneral_polyToFunctionField_X,
+    AlgHom.commutes, IsScalarTower.algebraMap_apply F F' (V⁄F').toAffine.FunctionField]
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing~evalAt\
+  " in
+open
+  _root_.P2MW.S_OVERLONG_55b03433.WeierstrassCurve.Affine.CoordinateRing
+  in
+omit [IsAlgClosed F] [CharZero F] [IsAlgClosed F'] [CharZero F'] in
+theorem kw_surge_hgf4_χE_algebraMap_YClass (V : WeierstrassCurve R₀) [V.IsElliptic]
+    [(V⁄F).IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate (V⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (V⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (V⁄F).toAffine] [(V⁄F').IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (V⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (V⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (V⁄F').toAffine] (y : F) :
+    kw_functionFieldMapAlongGeneral V F F'
+        (algebraMap (V⁄F).toAffine.CoordinateRing (V⁄F).toAffine.FunctionField
+          (YClass (V⁄F).toAffine (C y)))
+      = algebraMap (V⁄F').toAffine.CoordinateRing (V⁄F').toAffine.FunctionField
+          (YClass (V⁄F').toAffine (C (algebraMap F F' y))) := by
+  have hF : algebraMap (V⁄F).toAffine.CoordinateRing (V⁄F).toAffine.FunctionField
+      (YClass (V⁄F).toAffine (C y))
+      = yGen (V⁄F).toAffine - algebraMap F (V⁄F).toAffine.FunctionField y := by
+    rw [YClass, map_sub, map_sub, yGen]
+    congr 1
+  have hF' : algebraMap (V⁄F').toAffine.CoordinateRing (V⁄F').toAffine.FunctionField
+      (YClass (V⁄F').toAffine (C (algebraMap F F' y)))
+      = yGen (V⁄F').toAffine
+          - algebraMap F' (V⁄F').toAffine.FunctionField (algebraMap F F' y) := by
+    rw [YClass, map_sub, map_sub, yGen]
+    congr 1
+  rw [hF, hF', map_sub, kw_functionFieldMapAlongGeneral_yGen,
+    AlgHom.commutes, IsScalarTower.algebraMap_apply F F' (V⁄F').toAffine.FunctionField]
+
+omit [IsDomain ((toAffine E₀⁄F).FunctionField ⊗[F] F')] in
+omit [CharZero F] [CharZero F'] in
+theorem kw_surge_hgf4_χE_VSR_compat {x y : F} (hP : (E₀⁄F).toAffine.Nonsingular x y)
+    (hσP : (E₀⁄F').toAffine.Nonsingular (algebraMap F F' x) (algebraMap F F' y))
+    (g : (E₀⁄F).toAffine.FunctionField) :
+    χE g ∈ (placeOfEquation hσP.left).toValuationSubring ↔
+      g ∈ (placeOfEquation hP.left).toValuationSubring := by
+  have hχE_inj : Function.Injective (χE : _ →ₐ[F] _) :=
+    (kw_functionFieldMapAlongGeneral E₀ F F').injective
+  classical
+  have hmk (W : Affine F) : ∀ q : F[X][Y],
+      algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W q)
+        = q.eval₂ (polyToFunctionField W) (yGen W) := by
+    intro q
+    induction q using Polynomial.induction_on' with
+    | add p r hp hr => rw [map_add, map_add, Polynomial.eval₂_add, hp, hr]
+    | monomial n a =>
+        simp only [← Polynomial.C_mul_X_pow_eq_monomial, map_mul, map_pow,
+          Polynomial.eval₂_mul, Polynomial.eval₂_pow, Polynomial.eval₂_C, Polynomial.eval₂_X]
+        rw [← algebraMap_polynomial_eq_mk_C, ← polyToFunctionField_apply]; rfl
+  have hfinσP : IsFinitePlace (placeOfEquation hσP.left) :=
+    isFinitePlace_placeOfEquation hσP.left
+  have hχE_polyToFF (p : F[X]) :
+      χE (polyToFunctionField (E₀⁄F).toAffine p) ∈ (placeOfEquation hσP.left).toValuationSubring
+        := by
+    have h : χE (polyToFunctionField (E₀⁄F).toAffine p)
+        = polyToFunctionField (E₀⁄F').toAffine (p.map (algebraMap F F')) := by
+      induction p using Polynomial.induction_on' with
+      | add r s hr hs => rw [map_add, map_add, Polynomial.map_add, map_add, hr, hs]
+      | monomial n c =>
+          rw [Polynomial.map_monomial, ← Polynomial.C_mul_X_pow_eq_monomial,
+            ← Polynomial.C_mul_X_pow_eq_monomial, map_mul, map_mul, map_pow, map_pow,
+            map_mul, map_pow, polyToFunctionField_C, polyToFunctionField_C,
+            kw_functionFieldMapAlongGeneral_polyToFunctionField_X, AlgHom.commutes,
+            IsScalarTower.algebraMap_apply F F' (E₀⁄F').toAffine.FunctionField]
+    rw [h, polyToFunctionField_apply]
+    exact hfinσP _
+  have hχE_CR_mem : ∀ a : (E₀⁄F).toAffine.CoordinateRing,
+      χE (algebraMap _ _ a) ∈ (placeOfEquation hσP.left).toValuationSubring := by
+    intro a
+    obtain ⟨q, rfl⟩ := AdjoinRoot.mk_surjective a
+    rw [hmk (E₀⁄F).toAffine q]
+    induction q using Polynomial.induction_on' with
+    | add r s hr hs =>
+        rw [Polynomial.eval₂_add, map_add]
+        exact Subring.add_mem _ hr hs
+    | monomial n p =>
+        rw [← Polynomial.C_mul_X_pow_eq_monomial, Polynomial.eval₂_mul, Polynomial.eval₂_pow,
+          Polynomial.eval₂_C, Polynomial.eval₂_X, map_mul, map_pow,
+          kw_functionFieldMapAlongGeneral_yGen]
+        exact Subring.mul_mem _ (hχE_polyToFF p)
+          (Subring.pow_mem _ (hfinσP (CoordinateRing.mk (E₀⁄F').toAffine Y)) n)
+  have hXClass_σP_mem_𝔪 : (⟨algebraMap _ _ (CoordinateRing.XClass (E₀⁄F').toAffine
+        (algebraMap F F' x)), hfinσP _⟩ : (placeOfEquation hσP.left).toValuationSubring)
+      ∈ IsLocalRing.maximalIdeal (placeOfEquation hσP.left).toValuationSubring := by
+    rw [Place.mem_maximalIdeal_iff_ord_pos _
+      ((map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr (CoordinateRing.XClass_ne_zero _))]
+    exact (ord_placeOfEquation_pos_iff hσP.left (CoordinateRing.XClass_ne_zero _)).mpr
+      (Ideal.subset_span (Set.mem_insert _ _))
+  have hYClass_σP_mem_𝔪 : (⟨algebraMap _ _ (CoordinateRing.YClass (E₀⁄F').toAffine
+        (C (algebraMap F F' y))), hfinσP _⟩ : (placeOfEquation hσP.left).toValuationSubring)
+      ∈ IsLocalRing.maximalIdeal (placeOfEquation hσP.left).toValuationSubring := by
+    rw [Place.mem_maximalIdeal_iff_ord_pos _
+      ((map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr (CoordinateRing.YClass_ne_zero _))]
+    exact (ord_placeOfEquation_pos_iff hσP.left (CoordinateRing.YClass_ne_zero _)).mpr
+      (Ideal.subset_span (Set.mem_insert_of_mem _ rfl))
+  have hχE_mem_𝔪 : ∀ a ∈ CoordinateRing.XYIdeal (E₀⁄F).toAffine x (C y),
+      (⟨χE (algebraMap _ _ a), hχE_CR_mem a⟩ : (placeOfEquation hσP.left).toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal (placeOfEquation hσP.left).toValuationSubring := by
+    intro a ha
+    rw [CoordinateRing.XYIdeal, Ideal.mem_span_pair] at ha
+    obtain ⟨p, q, hpq⟩ := ha
+    have hdecomp : χE (algebraMap _ _ a)
+        = χE (algebraMap _ _ p) * χE (algebraMap _ _ (CoordinateRing.XClass (E₀⁄F).toAffine x))
+          + χE (algebraMap _ _ q)
+            * χE (algebraMap _ _ (CoordinateRing.YClass (E₀⁄F).toAffine (C y))) := by
+      rw [← map_mul, ← map_mul, ← map_mul, ← map_mul, ← map_add, ← map_add, hpq]
+    rw [show (⟨χE (algebraMap _ _ a), hχE_CR_mem a⟩ :
+          (placeOfEquation hσP.left).toValuationSubring)
+        = ⟨χE (algebraMap _ _ p), hχE_CR_mem p⟩
+            * ⟨_, hfinσP (CoordinateRing.XClass (E₀⁄F').toAffine (algebraMap F F' x))⟩
+          + ⟨χE (algebraMap _ _ q), hχE_CR_mem q⟩
+            * ⟨_, hfinσP (CoordinateRing.YClass (E₀⁄F').toAffine (C (algebraMap F F' y)))⟩ from
+        Subtype.ext (by
+          push_cast
+          rw [hdecomp, kw_surge_hgf4_χE_algebraMap_XClass F F' E₀ x,
+            kw_surge_hgf4_χE_algebraMap_YClass F F' E₀ y])]
+    exact Ideal.add_mem _ (Ideal.mul_mem_left _ _ hXClass_σP_mem_𝔪)
+      (Ideal.mul_mem_left _ _ hYClass_σP_mem_𝔪)
+  have hχE_unit : ∀ s : (E₀⁄F).toAffine.CoordinateRing,
+      s ∉ CoordinateRing.XYIdeal (E₀⁄F).toAffine x (C y) →
+      IsUnit (⟨χE (algebraMap _ _ s), hχE_CR_mem s⟩ :
+        (placeOfEquation hσP.left).toValuationSubring) := by
+    intro s hs
+    obtain ⟨c, hc⟩ := CoordinateRing.exists_sub_algebraMap_mem hP.left s
+    have hc_ne : c ≠ 0 := by
+      intro h; apply hs; simpa [h, sub_zero] using hc
+    have hσc_ne : algebraMap F F' c ≠ 0 := (map_ne_zero_iff _ (algebraMap F F').injective).mpr hc_ne
+    have hχE_const : χE (algebraMap (E₀⁄F).toAffine.CoordinateRing _
+          (algebraMap F (E₀⁄F).toAffine.CoordinateRing c))
+        = algebraMap F' (E₀⁄F').toAffine.FunctionField (algebraMap F F' c) := by
+      rw [← IsScalarTower.algebraMap_apply F (E₀⁄F).toAffine.CoordinateRing
+        (E₀⁄F).toAffine.FunctionField, AlgHom.commutes,
+        IsScalarTower.algebraMap_apply F F' (E₀⁄F').toAffine.FunctionField]
+    have hsplit : (⟨χE (algebraMap _ _ s), hχE_CR_mem s⟩ :
+          (placeOfEquation hσP.left).toValuationSubring)
+        = ⟨algebraMap F' _ (algebraMap F F' c),
+            (placeOfEquation hσP.left).algebraMap_mem' _⟩
+          + ⟨χE (algebraMap _ _ (s - algebraMap F _ c)), hχE_CR_mem _⟩ := by
+      refine Subtype.ext ?_
+      change χE (algebraMap _ _ s)
+          = algebraMap F' (E₀⁄F').toAffine.FunctionField (algebraMap F F' c)
+            + χE (algebraMap _ _ (s - algebraMap F _ c))
+      rw [← hχE_const, ← map_add, ← map_add, add_sub_cancel]
+    rw [hsplit]
+    have hfirst_unit : IsUnit (⟨algebraMap F' _ (algebraMap F F' c),
+        (placeOfEquation hσP.left).algebraMap_mem' _⟩ :
+        (placeOfEquation hσP.left).toValuationSubring) := by
+      refine isUnit_iff_exists_inv.mpr ⟨⟨algebraMap F' _ (algebraMap F F' c)⁻¹,
+        (placeOfEquation hσP.left).algebraMap_mem' _⟩, Subtype.ext ?_⟩
+      push_cast
+      rw [← map_inv₀, ← map_mul, mul_inv_cancel₀ hσc_ne, map_one]
+    have hsecond_𝔪 := hχE_mem_𝔪 (s - algebraMap F _ c) hc
+    by_contra hnotunit
+    have hsum_𝔪 := (IsLocalRing.mem_maximalIdeal _).mpr (mem_nonunits_iff.mpr hnotunit)
+    have hfirst_𝔪 : (⟨algebraMap F' _ (algebraMap F F' c),
+          (placeOfEquation hσP.left).algebraMap_mem' _⟩ :
+          (placeOfEquation hσP.left).toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal _ := by
+      have hsub := Ideal.sub_mem _ hsum_𝔪 hsecond_𝔪
+      rwa [add_sub_cancel_right] at hsub
+    exact (mem_nonunits_iff.mp ((IsLocalRing.mem_maximalIdeal _).mp hfirst_𝔪)) hfirst_unit
+  have hXY_prime : (CoordinateRing.XYIdeal (E₀⁄F).toAffine x (C y)).IsPrime :=
+    (CoordinateRing.XYIdeal_isMaximal hP.left).isPrime
+  have hmem_P : ∀ f : (E₀⁄F).toAffine.FunctionField,
+      f ∈ (placeOfEquation hP.left).toValuationSubring
+        ↔ ∃ (n s : (E₀⁄F).toAffine.CoordinateRing)
+            (_ : s ∉ CoordinateRing.XYIdeal (E₀⁄F).toAffine x (C y)),
+          f = algebraMap _ _ n * (algebraMap _ _ s)⁻¹ := by
+    intro f
+    have hfinP := isFinitePlace_placeOfEquation hP.left
+    constructor
+    · intro hf
+      obtain ⟨n, s, hcase⟩ :=
+        (CoordinateRing.heightOneSpectrumOfEquation hP.left).exists_primeCompl_mul_eq_or_mul_eq
+          (K := (E₀⁄F).toAffine.FunctionField) f
+      have hs_nin : (s : (E₀⁄F).toAffine.CoordinateRing)
+          ∉ CoordinateRing.XYIdeal (E₀⁄F).toAffine x (C y) :=
+        Ideal.mem_primeCompl_iff.mp s.2
+      have hs_CR_ne : (s : (E₀⁄F).toAffine.CoordinateRing) ≠ 0 :=
+        fun h => hs_nin (h ▸ Ideal.zero_mem _)
+      have hs0 : algebraMap (E₀⁄F).toAffine.CoordinateRing
+          (E₀⁄F).toAffine.FunctionField (s : (E₀⁄F).toAffine.CoordinateRing) ≠ 0 :=
+        (map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr hs_CR_ne
+      rcases hcase with heq | heq
+      · refine ⟨n, s, hs_nin, ?_⟩
+        field_simp at heq ⊢; linear_combination heq
+      · by_cases hn_nin : (n : _) ∈ CoordinateRing.XYIdeal (E₀⁄F).toAffine x (C y)
+        · exfalso
+          have hn0 : (n : (E₀⁄F).toAffine.CoordinateRing) ≠ 0 := fun h => by
+            rw [h, map_zero, mul_zero] at heq
+            exact hs_CR_ne ((map_eq_zero_iff _
+              (IsFractionRing.injective _ _)).mp heq.symm)
+          have hord_n_pos : 0 < (placeOfEquation hP.left).ord (algebraMap _ _ (n : _)) :=
+            (ord_placeOfEquation_pos_iff hP.left hn0).mpr hn_nin
+          have hord_s_zero : (placeOfEquation hP.left).ord
+              (algebraMap _ _ (s : (E₀⁄F).toAffine.CoordinateRing)) = 0 := by
+            by_contra hne
+            exact hs_nin ((ord_placeOfEquation_ne_zero_iff hP.left hs_CR_ne).mp hne)
+          have hord_f_neg : (placeOfEquation hP.left).ord f < 0 := by
+            have hf0 : f ≠ 0 := fun h => by
+              rw [h, zero_mul] at heq
+              exact hs_CR_ne ((map_eq_zero_iff _
+                (IsFractionRing.injective _ _)).mp heq.symm)
+            have hfn_eq : (placeOfEquation hP.left).ord f
+                + (placeOfEquation hP.left).ord (algebraMap _ _ (n : _))
+                = (placeOfEquation hP.left).ord
+                    (algebraMap _ _ (s : (E₀⁄F).toAffine.CoordinateRing)) := by
+              rw [← Place.ord_mul _ hf0
+                  ((map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr hn0), heq]
+            omega
+          exact not_le.mpr hord_f_neg (AlgebraicCurve.Place.ord_nonneg_of_mem (placeOfEquation
+            hP.left) hf)
+        · refine ⟨s, n, hn_nin, ?_⟩
+          have hn0 : algebraMap _ (E₀⁄F).toAffine.FunctionField (n : _) ≠ 0 :=
+            (map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr
+              (fun h => hn_nin (h ▸ Ideal.zero_mem _))
+          field_simp at heq ⊢; linear_combination heq
+    · rintro ⟨n, s, hs_nin, rfl⟩
+      have hs_inv : (algebraMap _ _ s)⁻¹ ∈ (placeOfEquation hP.left).toValuationSubring :=
+        hfinP.inv_mem (by rwa [centre_placeOfEquation])
+      exact Subring.mul_mem _ (hfinP n) hs_inv
+  constructor
+  · intro hχEg
+    by_contra hg_notin
+    have hg_ne : g ≠ 0 := fun h => hg_notin (h ▸ Subring.zero_mem _)
+    have hginv_in : g⁻¹ ∈ (placeOfEquation hP.left).toValuationSubring :=
+      ((placeOfEquation hP.left).toValuationSubring.mem_or_inv_mem g).resolve_left hg_notin
+    obtain ⟨n, s, hs_notin, hginv_eq⟩ := (hmem_P g⁻¹).mp hginv_in
+    have hginv_𝔪 : (⟨g⁻¹, hginv_in⟩ : (placeOfEquation hP.left).toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal _ := by
+      rw [IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+      intro hu
+      exact hg_notin (inv_inv g ▸ kw_surge_hgf4_place_inv_mem_of_isUnit _ hu)
+    have hn_in : n ∈ CoordinateRing.XYIdeal (E₀⁄F).toAffine x (C y) := by
+      by_contra hn_notin
+      have hfinP := isFinitePlace_placeOfEquation hP.left
+      have hn_inv : (algebraMap _ _ n)⁻¹ ∈ (placeOfEquation hP.left).toValuationSubring :=
+        hfinP.inv_mem (by rwa [centre_placeOfEquation])
+      have hs_inv : (algebraMap _ _ s)⁻¹ ∈ (placeOfEquation hP.left).toValuationSubring :=
+        hfinP.inv_mem (by rwa [centre_placeOfEquation])
+      have hginv_unit : IsUnit
+          (⟨g⁻¹, hginv_in⟩ : (placeOfEquation hP.left).toValuationSubring) := by
+        have hg_mem : g ∈ (placeOfEquation hP.left).toValuationSubring := by
+          have : g = algebraMap _ _ s * (algebraMap _ _ n)⁻¹ := by
+            rw [← inv_inv g, hginv_eq, mul_inv, inv_inv, mul_comm]
+          rw [this]; exact Subring.mul_mem _ (hfinP s) hn_inv
+        exact isUnit_iff_exists_inv.mpr
+          ⟨(⟨g, hg_mem⟩ : (placeOfEquation hP.left).toValuationSubring),
+           Subtype.ext (by push_cast; exact inv_mul_cancel₀ hg_ne)⟩
+      exact mem_nonunits_iff.mp ((IsLocalRing.mem_maximalIdeal _).mp hginv_𝔪) hginv_unit
+    have hχEn_𝔪 := hχE_mem_𝔪 n hn_in
+    have hχEs_unit := hχE_unit s hs_notin
+    have hχEginv_eq : χE g⁻¹ = χE (algebraMap _ _ n) * (χE (algebraMap _ _ s))⁻¹ := by
+      rw [hginv_eq, map_mul, map_inv₀]
+    have hχEginv_mem : χE g⁻¹ ∈ (placeOfEquation hσP.left).toValuationSubring := by
+      rw [hχEginv_eq]
+      exact Subring.mul_mem _ (hχE_CR_mem n)
+        (kw_surge_hgf4_place_inv_mem_of_isUnit _ hχEs_unit)
+    have hχEginv_𝔪 : (⟨χE g⁻¹, hχEginv_mem⟩ :
+          (placeOfEquation hσP.left).toValuationSubring)
+        ∈ IsLocalRing.maximalIdeal (placeOfEquation hσP.left).toValuationSubring := by
+      have hχEs_inv_mem := kw_surge_hgf4_place_inv_mem_of_isUnit _ hχEs_unit
+      have hrw : (⟨χE g⁻¹, hχEginv_mem⟩ : (placeOfEquation hσP.left).toValuationSubring)
+          = (⟨χE (algebraMap _ _ n), hχE_CR_mem n⟩ :
+              (placeOfEquation hσP.left).toValuationSubring)
+            * ⟨(χE (algebraMap _ _ s))⁻¹, hχEs_inv_mem⟩ :=
+        Subtype.ext (by change χE g⁻¹ = _ * _; exact hχEginv_eq)
+      rw [hrw]
+      exact Ideal.mul_mem_right _ _ hχEn_𝔪
+    have hχEg_ne : χE g ≠ 0 := (map_ne_zero_iff _ hχE_inj).mpr hg_ne
+    have hχEginv_unit : IsUnit
+        (⟨χE g⁻¹, hχEginv_mem⟩ : (placeOfEquation hσP.left).toValuationSubring) :=
+      isUnit_iff_exists_inv.mpr
+        ⟨(⟨χE g, hχEg⟩ : (placeOfEquation hσP.left).toValuationSubring),
+         Subtype.ext (by change χE g⁻¹ * χE g = 1; rw [map_inv₀, inv_mul_cancel₀ hχEg_ne])⟩
+    exact mem_nonunits_iff.mp ((IsLocalRing.mem_maximalIdeal _).mp hχEginv_𝔪) hχEginv_unit
+  · intro hg
+    obtain ⟨n, s, hs_notin, hg_eq⟩ := (hmem_P g).mp hg
+    rw [hg_eq, map_mul, map_inv₀]
+    exact Subring.mul_mem _ (hχE_CR_mem n)
+      (kw_surge_hgf4_place_inv_mem_of_isUnit _ (hχE_unit s hs_notin))
+
+omit [WeierstrassCurve.IsElliptic E₀⁄F] [WeierstrassCurve.IsElliptic E₀'⁄F]
+  [WeierstrassCurve.IsElliptic E₀⁄F'] [WeierstrassCurve.IsElliptic E₀'⁄F'] in
+omit [E₀.IsElliptic] [E₀'.IsElliptic] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+  [DecidableEq F'] [IsAlgClosed F'] [CharZero F'] [(toAffine E₀⁄F).GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F)] [(toAffine E₀⁄F).AbelTheorem]
+  [(toAffine E₀'⁄F).GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F)]
+  [(toAffine E₀'⁄F).AbelTheorem] [(toAffine E₀⁄F').GenusOnePlaceGate]
+  [GenusOnePlaceGate.IsCentred (toAffine E₀⁄F')] [(toAffine E₀⁄F').AbelTheorem]
+  [(toAffine E₀'⁄F').GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred (toAffine E₀'⁄F')]
+  [(toAffine E₀'⁄F').AbelTheorem] in
+theorem kw_surge_hgf4_bcIota₁_compat (a : (E₀'⁄F).toAffine.FunctionField) :
+    (ι₁) (χE' a) = χE (ι₀ a) := by
+  let ψE := kw_functionFieldTensorFracEquivGeneral E₀ F F'
+  let ψE' := kw_functionFieldTensorFracEquivGeneral E₀' F F'
+  have hκE' : ψE' (χE' a)
+      = algebraMap ((E₀'⁄F).toAffine.FunctionField ⊗[F] F') _ (a ⊗ₜ[F] (1 : F')) := by
+    have hκ : ((kw_functionFieldTensorFracHomGeneral E₀' F F').restrictScalars F).comp
+        (kw_functionFieldMapAlongGeneral E₀' F F')
+        = (IsScalarTower.toAlgHom F ((E₀'⁄F).toAffine.FunctionField ⊗[F] F')
+            (FractionRing ((E₀'⁄F).toAffine.FunctionField ⊗[F] F'))).comp
+            (Algebra.TensorProduct.includeLeft (R := F)) := by
+      refine kw_functionField_algHom_ext ?_ ?_
+      · change kw_functionFieldTensorFracHomGeneral E₀' F F' (χE' _) = _
+        rw [kw_functionFieldMapAlongGeneral_polyToFunctionField_X,
+          kw_functionFieldTensorFracHomGeneral_X]; rfl
+      · change kw_functionFieldTensorFracHomGeneral E₀' F F' (χE' _) = _
+        rw [kw_functionFieldMapAlongGeneral_yGen, kw_functionFieldTensorFracHomGeneral_yGen]
+        rfl
+    exact DFunLike.congr_fun hκ a
+  have hκE : ∀ b, ψE.symm (algebraMap ((E₀⁄F).toAffine.FunctionField ⊗[F] F') _
+      (b ⊗ₜ[F] (1 : F'))) = χE b := by
+    intro b
+    refine ψE.injective ?_
+    rw [AlgEquiv.apply_symm_apply]
+    have hκ : ((kw_functionFieldTensorFracHomGeneral E₀ F F').restrictScalars F).comp
+        (kw_functionFieldMapAlongGeneral E₀ F F')
+        = (IsScalarTower.toAlgHom F ((E₀⁄F).toAffine.FunctionField ⊗[F] F')
+            (FractionRing ((E₀⁄F).toAffine.FunctionField ⊗[F] F'))).comp
+            (Algebra.TensorProduct.includeLeft (R := F)) := by
+      refine kw_functionField_algHom_ext ?_ ?_
+      · change kw_functionFieldTensorFracHomGeneral E₀ F F' (χE _) = _
+        rw [kw_functionFieldMapAlongGeneral_polyToFunctionField_X,
+          kw_functionFieldTensorFracHomGeneral_X]; rfl
+      · change kw_functionFieldTensorFracHomGeneral E₀ F F' (χE _) = _
+        rw [kw_functionFieldMapAlongGeneral_yGen, kw_functionFieldTensorFracHomGeneral_yGen]
+        rfl
+    exact (DFunLike.congr_fun hκ b).symm
+  change ψE.symm (kw_surge_hgf4_bcTensorFracIotaAlg E₀ E₀' F F' ι₀ (ψE' (χE' a)))
+      = χE (ι₀ a)
+  rw [hκE',
+    show kw_surge_hgf4_bcTensorFracIotaAlg E₀ E₀' F F' ι₀
+        (algebraMap ((E₀'⁄F).toAffine.FunctionField ⊗[F] F') _ (a ⊗ₜ[F] (1 : F')))
+      = algebraMap ((E₀⁄F).toAffine.FunctionField ⊗[F] F') _ ((ι₀ a) ⊗ₜ[F] (1 : F')) from by
+        change kw_surge_hgf4_bcTensorFracIota E₀ E₀' F F' ι₀ _ = _
+        rw [kw_surge_hgf4_bcTensorFracIota_algebraMap, kw_surge_hgf4_bcTensorIota_tmul],
+    hκE (ι₀ a)]
+
+include hσ in
+omit [E₀'.IsElliptic] in
+theorem kw_surge_hgf4_pmop_naturality :
+    let hι₁ := kw_surge_hgf4_bcIota₁_isIntegral E₀ E₀' F F' ι₀ hfin₀
+    let hfin₁ := kw_surge_hgf4_bcIota₁_finiteAlong E₀ E₀' F F' ι₀ hfin₀
+    let σE : (E₀⁄F).toAffine.Point →+ (E₀⁄F').toAffine.Point :=
+      WeierstrassCurve.Affine.Point.map (W' := E₀.toAffine) σ
+    let σE' : (E₀'⁄F).toAffine.Point →+ (E₀'⁄F').toAffine.Point :=
+      WeierstrassCurve.Affine.Point.map (W' := E₀'.toAffine) σ
+    let φ₀ := pointMapOfPushforward ι₀ hι₀ hfin₀ (normFormulaAlong_of_elliptic ι₀ hfin₀)
+    let φ₁ := pointMapOfPushforward (ι₁) hι₁ hfin₁ (normFormulaAlong_of_elliptic (ι₁) hfin₁)
+    ∀ P, φ₁ (σE P) = σE' (φ₀ P) := by
+  intro hι₁ hfin₁ σE σE' φ₀ φ₁
+  have hgBC₀ :=
+    kw_fdn2_qephod_hend7_pmop_eq_geomMorphBC_sub ι₀ hι₀ hfin₀ (normFormulaAlong_of_elliptic ι₀
+      hfin₀)
+  have hgBC₁ :=
+    kw_fdn2_qephod_hend7_pmop_eq_geomMorphBC_sub (ι₁) hι₁ hfin₁ (normFormulaAlong_of_elliptic ι₁
+      hfin₁)
+  let g₀ := kw_fdn2_qephod_hend7_geomMorphBC ι₀ hι₀
+  let g₁ := kw_fdn2_qephod_hend7_geomMorphBC (ι₁) hι₁
+  have hχE_ord_pos : ∀ {x y : F} (hP : (E₀⁄F).toAffine.Nonsingular x y)
+      (hσP : (E₀⁄F').toAffine.Nonsingular (algebraMap F F' x) (algebraMap F F' y))
+      (h : (E₀⁄F).toAffine.FunctionField) (hh : h ≠ 0),
+      0 < (placeOfEquation hσP.left).ord (χE h) ↔
+        0 < (placeOfEquation hP.left).ord h := by
+    intro x y hP hσP h hh
+    have hχEh_ne : χE h ≠ 0 :=
+      (map_ne_zero_iff _ (kw_functionFieldMapAlongGeneral E₀ F F').injective).mpr hh
+    have hVSR := kw_surge_hgf4_χE_VSR_compat E₀ F F' hP hσP
+    constructor <;> intro hpos
+    · have hχEh_mem : χE h ∈ (placeOfEquation hσP.left).toValuationSubring :=
+        AlgebraicCurve.Place.mem_of_ord_nonneg (placeOfEquation hσP.left) hχEh_ne hpos.le
+      have hh_mem : h ∈ (placeOfEquation hP.left).toValuationSubring := (hVSR h).mp hχEh_mem
+      rw [← Place.mem_maximalIdeal_iff_ord_pos _ hh hh_mem,
+        IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+      intro hu
+      have hinv_mem := kw_surge_hgf4_place_inv_mem_of_isUnit _ hu
+      have hχEinv_mem : χE h⁻¹ ∈ (placeOfEquation hσP.left).toValuationSubring :=
+        (hVSR h⁻¹).mpr hinv_mem
+      rw [map_inv₀] at hχEinv_mem
+      have hχEh_unit : IsUnit
+          (⟨χE h, hχEh_mem⟩ : (placeOfEquation hσP.left).toValuationSubring) :=
+        isUnit_iff_exists_inv.mpr ⟨⟨(χE h)⁻¹, hχEinv_mem⟩,
+          Subtype.ext (mul_inv_cancel₀ hχEh_ne)⟩
+      exact (mem_nonunits_iff.mp ((IsLocalRing.mem_maximalIdeal _).mp
+        ((Place.mem_maximalIdeal_iff_ord_pos _ hχEh_ne hχEh_mem).mpr hpos))) hχEh_unit
+    · have hh_mem : h ∈ (placeOfEquation hP.left).toValuationSubring :=
+        AlgebraicCurve.Place.mem_of_ord_nonneg (placeOfEquation hP.left) hh hpos.le
+      have hχEh_mem : χE h ∈ (placeOfEquation hσP.left).toValuationSubring :=
+        (hVSR h).mpr hh_mem
+      rw [← Place.mem_maximalIdeal_iff_ord_pos _ hχEh_ne hχEh_mem,
+        IsLocalRing.mem_maximalIdeal, mem_nonunits_iff]
+      intro hu
+      have hinv_mem := kw_surge_hgf4_place_inv_mem_of_isUnit _ hu
+      have hh_inv_mem : h⁻¹ ∈ (placeOfEquation hP.left).toValuationSubring := by
+        rw [← map_inv₀] at hinv_mem; exact (hVSR h⁻¹).mp hinv_mem
+      have hh_unit : IsUnit
+          (⟨h, hh_mem⟩ : (placeOfEquation hP.left).toValuationSubring) :=
+        isUnit_iff_exists_inv.mpr ⟨⟨h⁻¹, hh_inv_mem⟩, Subtype.ext (mul_inv_cancel₀ hh)⟩
+      exact (mem_nonunits_iff.mp ((IsLocalRing.mem_maximalIdeal _).mp
+        ((Place.mem_maximalIdeal_iff_ord_pos _ hh hh_mem).mpr hpos))) hh_unit
+  have hgBC_nat_affine : ∀ {x y : F} (hP : (E₀⁄F).toAffine.Nonsingular x y),
+      g₁ (σE (.some x y hP)) = σE' (g₀ (.some x y hP)) := by
+    intro x y hP
+    have hσP : (E₀⁄F').toAffine.Nonsingular (algebraMap F F' x) (algebraMap F F' y) :=
+      kw_surge_hgf4_toAffine_map_eq F F' E₀ ▸
+        (((E₀⁄F).toAffine.map_nonsingular (algebraMap F F').injective x y).mpr hP)
+    have hσE_some : σE (.some x y hP)
+        = .some (algebraMap F F' x) (algebraMap F F' y) hσP := by
+      have h := Point.map_some (W' := E₀.toAffine) (F := F) (K := F') σ hP
+      rw [show σE (.some x y hP) = Point.map (W' := E₀.toAffine) σ (.some x y hP) from rfl, h]
+      congr 1 <;> exact hσ _
+    refine placeOfPoint_injective ?_
+    rw [← kw_fdn2_qephod_hend7_placeOfPoint_geomMorphBC (ι₁) hι₁ (σE (.some x y hP)),
+      hσE_some, placeOfPoint_some]
+    have hseam₀ : (placeOfEquation hP.left).restrictAlong ι₀ hι₀
+        = placeOfPoint (g₀ (.some x y hP)) := by
+      rw [← placeOfPoint_some hP,
+        kw_fdn2_qephod_hend7_placeOfPoint_geomMorphBC ι₀ hι₀]
+    have hι₁X : (ι₁) (polyToFunctionField (E₀'⁄F').toAffine X)
+        = χE (ι₀ (polyToFunctionField (E₀'⁄F).toAffine X)) := by
+      rw [← kw_functionFieldMapAlongGeneral_polyToFunctionField_X E₀' F F']
+      exact kw_surge_hgf4_bcIota₁_compat E₀ E₀' F F' ι₀ _
+    have hι₁Y : (ι₁) (yGen (E₀'⁄F').toAffine)
+        = χE (ι₀ (yGen (E₀'⁄F).toAffine)) := by
+      rw [← kw_functionFieldMapAlongGeneral_yGen E₀' F F']
+      exact kw_surge_hgf4_bcIota₁_compat E₀ E₀' F F' ι₀ _
+    have hχE_const : ∀ c : F, χE (algebraMap F (E₀⁄F).toAffine.FunctionField c)
+        = algebraMap F' (E₀⁄F').toAffine.FunctionField (algebraMap F F' c) := fun c => by
+      rw [AlgHom.commutes,
+        IsScalarTower.algebraMap_apply F F' (E₀⁄F').toAffine.FunctionField]
+    rcases hQ₀_case : g₀ (.some x y hP) with _ | ⟨qx, qy, hQ₀ns⟩
+    · rw [show placeOfPoint (σE' (.zero : (E₀'⁄F).toAffine.Point))
+          = (InfinitePlace.place : Place F' (E₀'⁄F').toAffine.FunctionField) from by
+        rw [show σE' (.zero : (E₀'⁄F).toAffine.Point)
+            = (.zero : (E₀'⁄F').toAffine.Point) from map_zero σE', placeOfPoint_zero]]
+      refine AbstractSeam.restrictAlong_eq_infinitePlace (ι₁) hι₁ rfl _ ?_
+      rw [hι₁X]
+      intro hmem
+      have hι₀X_mem : ι₀ (polyToFunctionField (E₀'⁄F).toAffine X)
+          ∈ (placeOfEquation hP.left).toValuationSubring :=
+        (kw_surge_hgf4_χE_VSR_compat E₀ F F' hP hσP _).mp hmem
+      have hX_res : polyToFunctionField (E₀'⁄F).toAffine X
+          ∈ ((placeOfEquation hP.left).restrictAlong ι₀ hι₀).toValuationSubring :=
+        (Place.mem_restrictAlong_iff ι₀ hι₀ _ _).mpr hι₀X_mem
+      rw [hseam₀, hQ₀_case, placeOfPoint_zero] at hX_res
+      exact InfinitePlace.not_isFinitePlace (isFinitePlace_of_mem _ hX_res)
+    · have hσQ : (E₀'⁄F').toAffine.Nonsingular (algebraMap F F' qx) (algebraMap F F' qy) :=
+        kw_surge_hgf4_toAffine_map_eq F F' E₀' ▸
+          (((E₀'⁄F).toAffine.map_nonsingular (algebraMap F F').injective qx qy).mpr hQ₀ns)
+      have hσE'_some : σE' (.some qx qy hQ₀ns)
+          = .some (algebraMap F F' qx) (algebraMap F F' qy) hσQ := by
+        have h := Point.map_some (W' := E₀'.toAffine) (F := F) (K := F') σ hQ₀ns
+        rw [show σE' (.some qx qy hQ₀ns)
+            = Point.map (W' := E₀'.toAffine) σ (.some qx qy hQ₀ns) from rfl, h]
+        congr 1 <;> exact hσ _
+      rw [hσE'_some, placeOfPoint_some]
+      have hseam₀' : (placeOfEquation hP.left).restrictAlong ι₀ hι₀
+          = placeOfEquation hQ₀ns.left := by rw [hseam₀, hQ₀_case, placeOfPoint_some]
+      have hbrX : algebraMap (E₀'⁄F).toAffine.CoordinateRing (E₀'⁄F).toAffine.FunctionField
+          (CoordinateRing.XClass (E₀'⁄F).toAffine qx)
+          = polyToFunctionField (E₀'⁄F).toAffine X - algebraMap F _ qx :=
+        AbstractSeam.map_XClass (V := (E₀'⁄F).toAffine) (W := (E₀'⁄F).toAffine)
+          (AlgHom.id F (E₀'⁄F).toAffine.FunctionField) rfl qx
+      have hbrY : algebraMap (E₀'⁄F).toAffine.CoordinateRing (E₀'⁄F).toAffine.FunctionField
+          (CoordinateRing.YClass (E₀'⁄F).toAffine (C qy))
+          = yGen (E₀'⁄F).toAffine - algebraMap F _ qy :=
+        AbstractSeam.map_YClass (V := (E₀'⁄F).toAffine) (W := (E₀'⁄F).toAffine)
+          (AlgHom.id F (E₀'⁄F).toAffine.FunctionField) rfl qy
+      have hι₀X_ne : ι₀ (polyToFunctionField (E₀'⁄F).toAffine X)
+          - algebraMap F _ qx ≠ 0 := by
+        rw [← ι₀.commutes, ← map_sub, ← hbrX]
+        exact fun h => (CoordinateRing.XClass_ne_zero qx)
+          ((map_eq_zero_iff _ (IsFractionRing.injective _ _)).mp (ι₀.injective
+            (h.trans (map_zero ι₀).symm)))
+      have hι₀Y_ne : ι₀ (yGen (E₀'⁄F).toAffine) - algebraMap F _ qy ≠ 0 := by
+        rw [← ι₀.commutes, ← map_sub, ← hbrY]
+        exact fun h => (CoordinateRing.YClass_ne_zero (C qy))
+          ((map_eq_zero_iff _ (IsFractionRing.injective _ _)).mp (ι₀.injective
+            (h.trans (map_zero ι₀).symm)))
+      have hram_pos : 0 < Place.ramificationIndexAlong ι₀ (placeOfEquation hP.left) :=
+        Place.ramificationIndexAlong_pos ι₀ hι₀ (placeOfEquation hP.left)
+      have hdxF : 0 < (placeOfEquation hP.left).ord
+          (ι₀ (polyToFunctionField (E₀'⁄F).toAffine X) - algebraMap F _ qx) := by
+        rw [← ι₀.commutes, ← map_sub, ← hbrX,
+          Place.ord_restrictAlong ι₀ hι₀, hseam₀']
+        have hQord : 0 < (placeOfEquation hQ₀ns.left).ord (algebraMap _ _
+            (CoordinateRing.XClass (E₀'⁄F).toAffine qx)) :=
+          (ord_placeOfEquation_pos_iff hQ₀ns.left (CoordinateRing.XClass_ne_zero _)).mpr
+            (Ideal.subset_span (Set.mem_insert _ _))
+        positivity
+      have hdyF : 0 < (placeOfEquation hP.left).ord
+          (ι₀ (yGen (E₀'⁄F).toAffine) - algebraMap F _ qy) := by
+        rw [← ι₀.commutes, ← map_sub, ← hbrY,
+          Place.ord_restrictAlong ι₀ hι₀, hseam₀']
+        have hQord : 0 < (placeOfEquation hQ₀ns.left).ord (algebraMap _ _
+            (CoordinateRing.YClass (E₀'⁄F).toAffine (C qy))) :=
+          (ord_placeOfEquation_pos_iff hQ₀ns.left (CoordinateRing.YClass_ne_zero _)).mpr
+            (Ideal.subset_span (Set.mem_insert_of_mem _ rfl))
+        positivity
+      refine AbstractSeam.restrictAlong_placeOfEquation (ι₁) hι₁ rfl rfl
+        hσP.left hσQ.left ?_ ?_ ?_
+      · rw [hι₁X]
+        refine (kw_surge_hgf4_χE_VSR_compat E₀ F F' hP hσP _).mpr ?_
+        rw [← Place.mem_restrictAlong_iff ι₀ hι₀, hseam₀']
+        exact isFinitePlace_placeOfEquation hQ₀ns.left _
+      · rw [hι₁X, ← hχE_const qx, ← map_sub]
+        exact (hχE_ord_pos hP hσP _ hι₀X_ne).mpr hdxF
+      · rw [hι₁Y, ← hχE_const qy, ← map_sub]
+        exact (hχE_ord_pos hP hσP _ hι₀Y_ne).mpr hdyF
+  let δ : (E₀⁄F).toAffine.Point →+ (E₀'⁄F').toAffine.Point :=
+    (φ₁.comp σE) - (σE'.comp φ₀)
+  have hδ_affine : ∀ {x y : F} (hP : (E₀⁄F).toAffine.Nonsingular x y),
+      δ (.some x y hP) = σE' (g₀ 0) - g₁ 0 := by
+    intro x y hP
+    change φ₁ (σE (.some x y hP)) - σE' (φ₀ (.some x y hP)) = _
+    have h1 : φ₁ (σE (.some x y hP)) = g₁ (σE (.some x y hP)) - g₁ 0 := hgBC₁ _
+    have h0 : φ₀ (.some x y hP) = g₀ (.some x y hP) - g₀ 0 := hgBC₀ _
+    rw [h1, h0, map_sub, hgBC_nat_affine hP]
+    abel
+  have hC_zero : σE' (g₀ 0) - g₁ 0 = 0 := by
+    obtain ⟨e3⟩ :=
+      WeierstrassCurve.nonempty_pointTorsionBy_zmod (W := (E₀⁄F)) (n := 3) (by omega)
+    let P₀ : (E₀⁄F).toAffine.Point := (e3.symm (fun _ => 1) : _)
+    have hP₀_3 : (3 : ℤ) • P₀ = 0 := by
+      have := (e3.symm (fun _ => 1)).2
+      simp [P₀]
+    have hP₀_ne : P₀ ≠ 0 := by
+      intro h
+      have heq : e3.symm (fun _ => 1) = 0 :=
+        Subtype.ext (show (e3.symm (fun _ => 1) : (E₀⁄F).toAffine.Point) = 0 from h)
+      have hfun : (fun _ => (1 : ZMod 3)) = (0 : Fin 2 → ZMod 3) := by
+        have := congrArg e3 heq
+        rwa [e3.apply_symm_apply, map_zero] at this
+      exact one_ne_zero (congrFun hfun 0)
+    have h2P₀_ne : (2 : ℤ) • P₀ ≠ 0 := by
+      intro h2
+      have : (3 : ℤ) • P₀ - (2 : ℤ) • P₀ = 0 := by rw [hP₀_3, h2, sub_zero]
+      have hP₀_eq : P₀ = 0 := by
+        have : ((3 : ℤ) - 2) • P₀ = 0 := by rw [sub_smul]; exact this
+        simpa using this
+      exact hP₀_ne hP₀_eq
+    rcases hP₀_case : P₀ with _ | ⟨px, py, hpP⟩
+    · exact (hP₀_ne hP₀_case).elim
+    rcases h2P₀_case : (2 : ℤ) • P₀ with _ | ⟨qx, qy, hqQ⟩
+    · exact (h2P₀_ne h2P₀_case).elim
+    have h2C : (2 : ℤ) • (σE' (g₀ 0) - g₁ 0) = σE' (g₀ 0) - g₁ 0 := by
+      calc (2 : ℤ) • (σE' (g₀ 0) - g₁ 0)
+          = (2 : ℤ) • δ (.some px py hpP) := by rw [hδ_affine hpP]
+        _ = δ ((2 : ℤ) • (.some px py hpP : (E₀⁄F).toAffine.Point)) :=
+            (map_zsmul δ 2 _).symm
+        _ = δ ((2 : ℤ) • P₀) := by rw [hP₀_case]
+        _ = δ (.some qx qy hqQ) := by rw [h2P₀_case]
+        _ = σE' (g₀ 0) - g₁ 0 := hδ_affine hqQ
+    have hC' : ((2 : ℤ) - 1) • (σE' (g₀ 0) - g₁ 0) = 0 := by
+      rw [sub_smul, one_smul, h2C, sub_self]
+    simpa using hC'
+  intro P
+  have hδP : δ P = 0 := by
+    rcases P with _ | ⟨x, y, hP⟩
+    · exact map_zero δ
+    · rw [hδ_affine hP, hC_zero]
+  exact sub_eq_zero.mp hδP
+
+end Naturality
+end BetweenCurvesTensor
+
+theorem kw_surge_hgf4_hBC_proved : KwD5BetweenCurvesFFSeamBaseChange := by
+  intro R₀ _ E₀ E₀' _ _ F F' _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ σ ι₀ hι₀ hfin₀ N _
+    hcyc hcard
+  let : Algebra F F' := σ.toRingHom.toAlgebra
+  have : IsScalarTower R₀ F F' := IsScalarTower.of_algebraMap_eq fun r =>
+    (σ.commutes r).symm
+  have : IsDomain ((E₀⁄F).toAffine.FunctionField ⊗[F] F') :=
+    kw_functionFieldTensorIsDomain_dischargeGeneral E₀ F F'
+  have : IsDomain ((E₀'⁄F).toAffine.FunctionField ⊗[F] F') :=
+    kw_functionFieldTensorIsDomain_dischargeGeneral E₀' F F'
+  let ι₁ := kw_surge_hgf4_bcIota₁ E₀ E₀' F F' ι₀
+  have hι₁ := kw_surge_hgf4_bcIota₁_isIntegral E₀ E₀' F F' ι₀ hfin₀
+  have hfin₁ := kw_surge_hgf4_bcIota₁_finiteAlong E₀ E₀' F F' ι₀ hfin₀
+  have hD := kw_surge_hgf4_bcIota₁_finrankAlong E₀ E₀' F F' ι₀ hfin₀
+  have hker₁ : Nat.card (AddMonoidHom.ker
+      (pointMapOfPushforward ι₁ hι₁ hfin₁ (normFormulaAlong_of_elliptic ι₁ hfin₁))) = N := by
+    rw [kw_fdn2_qephod_hend7_pmopKerCard_proved F' (E₀⁄F').toAffine (E₀'⁄F').toAffine
+        ι₁ hι₁ hfin₁, hD,
+      ← kw_fdn2_qephod_hend7_pmopKerCard_proved F (E₀⁄F).toAffine (E₀'⁄F).toAffine
+        ι₀ hι₀ hfin₀, hcard]
+  let σE : (E₀⁄F).toAffine.Point →+ (E₀⁄F').toAffine.Point :=
+    WeierstrassCurve.Affine.Point.map (W' := E₀.toAffine) σ
+  let σE' : (E₀'⁄F).toAffine.Point →+ (E₀'⁄F').toAffine.Point :=
+    WeierstrassCurve.Affine.Point.map (W' := E₀'.toAffine) σ
+  have hσE_inj : Function.Injective σE :=
+    WeierstrassCurve.Affine.Point.map_injective (W' := E₀.toAffine) σ
+  let φ₀ := pointMapOfPushforward ι₀ hι₀ hfin₀ (normFormulaAlong_of_elliptic ι₀ hfin₀)
+  let φ₁ := pointMapOfPushforward ι₁ hι₁ hfin₁ (normFormulaAlong_of_elliptic ι₁ hfin₁)
+  have hnat : ∀ P, φ₁ (σE P) = σE' (φ₀ P) := by
+    exact kw_surge_hgf4_pmop_naturality E₀ E₀' F F' ι₀ hι₀ hfin₀ σ (fun _ => rfl)
+  have hker_sub : ∀ P ∈ AddMonoidHom.ker φ₀, σE P ∈ AddMonoidHom.ker φ₁ := by
+    intro P hP
+    rw [AddMonoidHom.mem_ker] at hP ⊢
+    rw [hnat P, hP, map_zero]
+  let σE_ker : (AddMonoidHom.ker φ₀) →+ (AddMonoidHom.ker φ₁) :=
+    { toFun := fun ⟨P, hP⟩ => ⟨σE P, hker_sub P hP⟩
+      map_zero' := Subtype.ext (map_zero σE)
+      map_add' := fun ⟨P, _⟩ ⟨Q, _⟩ => Subtype.ext (map_add σE P Q) }
+  have hσE_ker_inj : Function.Injective σE_ker := fun ⟨P, _⟩ ⟨Q, _⟩ hPQ =>
+    Subtype.ext (hσE_inj (Subtype.ext_iff.mp hPQ))
+  have hcard_eq : Nat.card (AddMonoidHom.ker φ₀) = Nat.card (AddMonoidHom.ker φ₁) := by
+    rw [hcard, hker₁]
+  have hfin_ker₀ : Finite (AddMonoidHom.ker φ₀) :=
+    Nat.finite_of_card_ne_zero (hcard ▸ (NeZero.ne N))
+  have hfin_ker₁ : Finite (AddMonoidHom.ker φ₁) :=
+    Nat.finite_of_card_ne_zero (hker₁ ▸ (NeZero.ne N))
+  have hσE_ker_bij : Function.Bijective σE_ker :=
+    (Nat.bijective_iff_injective_and_card _).mpr ⟨hσE_ker_inj, hcard_eq⟩
+  have hcyc₁ : IsAddCyclic (AddMonoidHom.ker φ₁) := by
+    let e : (AddMonoidHom.ker φ₀) ≃+ (AddMonoidHom.ker φ₁) :=
+      AddEquiv.ofBijective σE_ker hσE_ker_bij
+    obtain ⟨⟨g₀, hg₀⟩⟩ := hcyc
+    exact ⟨⟨e g₀, fun y => by
+      obtain ⟨k, hk⟩ := hg₀ (e.symm y)
+      exact ⟨k, by rw [← e.apply_symm_apply y, ← hk, map_zsmul]⟩⟩⟩
+  exact ⟨ι₁, hι₁, hfin₁, hcyc₁, hker₁⟩
+
+end ModularCurve
+end
+end
+
+section
+
+
+section
+
+p2m_open "P2MW.S_OVERLONG_55b03433\
+  .ModularCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve"
+p2m_open_scoped "TensorProduct Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial Polynomial.Bivariate \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial.Bivariate"
+
+namespace ModularCurve
+
+universe u
+
+attribute [local instance] Classical.propDecidable
+section BCNoACEngine
+variable {R₀ : Type u} [Field R₀]
+variable (E₀ E₀' : WeierstrassCurve R₀) [E₀.IsElliptic] [E₀'.IsElliptic]
+variable (F : Type u) [Field F] [Algebra R₀ F] [DecidableEq F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra R₀ F'] [DecidableEq F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower R₀ F F']
+variable [(E₀⁄F).IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀⁄F).toAffine] [(E₀'⁄F).IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀'⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀'⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀'⁄F).toAffine] [(E₀⁄F').IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀⁄F').toAffine] [(E₀'⁄F').IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀'⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀'⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀'⁄F').toAffine]
+variable (ι' : (E₀'⁄F).toAffine.FunctionField →ₐ[F] (E₀⁄F).toAffine.FunctionField)
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+scoped instance kw_surgehgf4_hfgkd_tensorIsDomain_E :
+    IsDomain ((E₀⁄F).toAffine.FunctionField ⊗[F] F') :=
+  kw_functionFieldTensorIsDomain_dischargeGeneralNoAC E₀ F F'
+
+scoped instance kw_surgehgf4_hfgkd_tensorIsDomain_E' :
+    IsDomain ((E₀'⁄F).toAffine.FunctionField ⊗[F] F') :=
+  kw_functionFieldTensorIsDomain_dischargeGeneralNoAC E₀' F F'
+end BCNoACEngine
+section KerTransportMint
+
+def KwD5BetweenCurvesKerTransportAlongEmbed : Prop :=
+  ∀ (R₀ : Type u) [Field R₀] (E₀ E₀' : WeierstrassCurve R₀) [E₀.IsElliptic] [E₀'.IsElliptic]
+    (F₁ : Type u) [Field F₁] [Algebra R₀ F₁] [DecidableEq F₁] [IsAlgClosed F₁] [CharZero F₁]
+    (F₂ : Type u) [Field F₂] [Algebra R₀ F₂] [DecidableEq F₂] [IsAlgClosed F₂] [CharZero F₂]
+    [Algebra F₁ F₂] [IsScalarTower R₀ F₁ F₂]
+    [(E₀⁄F₁).IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀⁄F₁).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀⁄F₁).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀⁄F₁).toAffine] [(E₀'⁄F₁).IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀'⁄F₁).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀'⁄F₁).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀'⁄F₁).toAffine] [(E₀⁄F₂).IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀⁄F₂).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀⁄F₂).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀⁄F₂).toAffine] [(E₀'⁄F₂).IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (E₀'⁄F₂).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (E₀'⁄F₂).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (E₀'⁄F₂).toAffine]
+    (ι₁ : (E₀'⁄F₁).toAffine.FunctionField →ₐ[F₁] (E₀⁄F₁).toAffine.FunctionField)
+    (hι₁ : ι₁.toRingHom.IsIntegral) (hfin₁ : FiniteAlong F₁ ι₁)
+    (ι₂ : (E₀'⁄F₂).toAffine.FunctionField →ₐ[F₂] (E₀⁄F₂).toAffine.FunctionField)
+    (hι₂ : ι₂.toRingHom.IsIntegral) (hfin₂ : FiniteAlong F₂ ι₂)
+    (_hχ : ∀ x : (E₀'⁄F₁).toAffine.FunctionField,
+      ι₂ (kw_functionFieldMapAlongGeneralNoAC E₀' F₁ F₂ x)
+        = kw_functionFieldMapAlongGeneralNoAC E₀ F₁ F₂ (ι₁ x))
+    (N : ℕ) [NeZero N],
+    IsAddCyclic (AddMonoidHom.ker
+      (pointMapOfPushforward ι₂ hι₂ hfin₂ (normFormulaAlong_of_elliptic ι₂ hfin₂))) →
+    Nat.card (AddMonoidHom.ker
+      (pointMapOfPushforward ι₂ hι₂ hfin₂ (normFormulaAlong_of_elliptic ι₂ hfin₂))) = N →
+    IsAddCyclic (AddMonoidHom.ker
+      (pointMapOfPushforward ι₁ hι₁ hfin₁ (normFormulaAlong_of_elliptic ι₁ hfin₁))) ∧
+    Nat.card (AddMonoidHom.ker
+      (pointMapOfPushforward ι₁ hι₁ hfin₁ (normFormulaAlong_of_elliptic ι₁ hfin₁))) = N
+end KerTransportMint
+end ModularCurve
+end
+
+section
+
+
+section
+
+p2m_open "P2MW.S_OVERLONG_55b03433\
+  .ModularCurve WeierstrassCurve \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_55b03433.Weierst\
+  rassCurve.Affine Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg \
+  P2MW.S_OVERLONG_55b03433.Algebra\
+  icCurve"
+p2m_open_scoped "TensorProduct Polynomial \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial Polynomial.Bivariate \
+  P2MW.S_OVERLONG_55b03433.Polynom\
+  ial.Bivariate"
+
+namespace ModularCurve
+
+attribute [local instance] Classical.propDecidable
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+universe u
+
+theorem kw_surgehgf4_hfgkd_ktd_chiNoAC_eq_chiGeneral
+    {R₀ : Type u} [Field R₀] (W : WeierstrassCurve R₀) [W.IsElliptic]
+    (F : Type u) [Field F] [Algebra R₀ F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    (F' : Type u) [Field F'] [Algebra R₀ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F']
+    [Algebra F F'] [IsScalarTower R₀ F F']
+    [(W⁄F).IsElliptic] [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F).toAffine] [(W⁄F').IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W⁄F').toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W⁄F').toAffine] :
+    kw_functionFieldMapAlongGeneralNoAC W F F'
+      = kw_functionFieldMapAlongGeneral W F F' := by
+  refine kw_functionField_algHom_ext ?_ ?_
+  · rw [kw_functionFieldMapAlongGeneralNoAC_polyToFunctionField_X,
+      kw_functionFieldMapAlongGeneral_polyToFunctionField_X]
+  · rw [kw_functionFieldMapAlongGeneralNoAC_yGen, kw_functionFieldMapAlongGeneral_yGen]
+
+theorem kw_surgehgf4_hfgkd_ktd_kerTransport_proved :
+    KwD5BetweenCurvesKerTransportAlongEmbed.{u} := by
+  intro R₀ _ E₀ E₀' _ _ F₁ _ _ _ _ _ F₂ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
+    ι₁ hι₁ hfin₁ ι₂ hι₂ hfin₂ hχ N _ hcyc₂ hcard₂
+  have : IsDomain ((E₀⁄F₁).toAffine.FunctionField ⊗[F₁] F₂) :=
+    kw_functionFieldTensorIsDomain_dischargeGeneral E₀ F₁ F₂
+  have : IsDomain ((E₀'⁄F₁).toAffine.FunctionField ⊗[F₁] F₂) :=
+    kw_functionFieldTensorIsDomain_dischargeGeneral E₀' F₁ F₂
+  have hχE₀ := kw_surgehgf4_hfgkd_ktd_chiNoAC_eq_chiGeneral E₀ F₁ F₂
+  have hχE₀' := kw_surgehgf4_hfgkd_ktd_chiNoAC_eq_chiGeneral E₀' F₁ F₂
+  have hχG : ∀ x, ι₂ (kw_functionFieldMapAlongGeneral E₀' F₁ F₂ x)
+      = kw_functionFieldMapAlongGeneral E₀ F₁ F₂ (ι₁ x) := by
+    intro x; rw [← hχE₀', ← hχE₀]; exact hχ x
+  have heq : ι₂ = kw_surge_hgf4_bcIota₁ E₀ E₀' F₁ F₂ ι₁ := by
+    refine kw_functionField_algHom_ext ?_ ?_
+    · rw [show polyToFunctionField (E₀'⁄F₂).toAffine X
+            = kw_functionFieldMapAlongGeneral E₀' F₁ F₂
+                (polyToFunctionField (E₀'⁄F₁).toAffine X) from
+          (kw_functionFieldMapAlongGeneral_polyToFunctionField_X E₀' F₁ F₂).symm,
+        hχG, kw_surge_hgf4_bcIota₁_compat E₀ E₀' F₁ F₂ ι₁]
+    · rw [show yGen (E₀'⁄F₂).toAffine
+            = kw_functionFieldMapAlongGeneral E₀' F₁ F₂ (yGen (E₀'⁄F₁).toAffine) from
+          (kw_functionFieldMapAlongGeneral_yGen E₀' F₁ F₂).symm,
+        hχG, kw_surge_hgf4_bcIota₁_compat E₀ E₀' F₁ F₂ ι₁]
+  subst heq
+  clear hχ hχG hχE₀ hχE₀'
+  let φ₁ := pointMapOfPushforward ι₁ hι₁ hfin₁ (normFormulaAlong_of_elliptic ι₁ hfin₁)
+  let φ₂ := pointMapOfPushforward _ hι₂ hfin₂ (normFormulaAlong_of_elliptic _ hfin₂)
+  have hD := kw_surge_hgf4_bcIota₁_finrankAlong E₀ E₀' F₁ F₂ ι₁ hfin₁
+  have hker₁ : Nat.card (AddMonoidHom.ker φ₁) = N := by
+    rw [show φ₁ = _ from rfl,
+      kw_fdn2_qephod_hend7_pmopKerCard_proved F₁ (E₀⁄F₁).toAffine (E₀'⁄F₁).toAffine
+        ι₁ hι₁ hfin₁, ← hD,
+      ← kw_fdn2_qephod_hend7_pmopKerCard_proved F₂ (E₀⁄F₂).toAffine (E₀'⁄F₂).toAffine
+        _ hι₂ hfin₂]
+    exact hcard₂
+  let σ : F₁ →ₐ[R₀] F₂ := IsScalarTower.toAlgHom R₀ F₁ F₂
+  let σE : (E₀⁄F₁).toAffine.Point →+ (E₀⁄F₂).toAffine.Point :=
+    WeierstrassCurve.Affine.Point.map (W' := E₀.toAffine) σ
+  let σE' : (E₀'⁄F₁).toAffine.Point →+ (E₀'⁄F₂).toAffine.Point :=
+    WeierstrassCurve.Affine.Point.map (W' := E₀'.toAffine) σ
+  have hσE_inj : Function.Injective σE :=
+    WeierstrassCurve.Affine.Point.map_injective (W' := E₀.toAffine) σ
+  have hnat : ∀ P, φ₂ (σE P) = σE' (φ₁ P) :=
+    kw_surge_hgf4_pmop_naturality E₀ E₀' F₁ F₂ ι₁ hι₁ hfin₁ σ (fun _ => rfl)
+  have hker_sub : ∀ P ∈ AddMonoidHom.ker φ₁, σE P ∈ AddMonoidHom.ker φ₂ := by
+    intro P hP
+    rw [AddMonoidHom.mem_ker] at hP ⊢
+    rw [hnat P, hP, map_zero]
+  let σE_ker : (AddMonoidHom.ker φ₁) →+ (AddMonoidHom.ker φ₂) :=
+    { toFun := fun ⟨P, hP⟩ => ⟨σE P, hker_sub P hP⟩
+      map_zero' := Subtype.ext (map_zero σE)
+      map_add' := fun ⟨P, _⟩ ⟨Q, _⟩ => Subtype.ext (map_add σE P Q) }
+  have hσE_ker_inj : Function.Injective σE_ker := fun ⟨P, _⟩ ⟨Q, _⟩ hPQ =>
+    Subtype.ext (hσE_inj (Subtype.ext_iff.mp hPQ))
+  have hcard_eq : Nat.card (AddMonoidHom.ker φ₁) = Nat.card (AddMonoidHom.ker φ₂) := by
+    rw [hker₁, hcard₂]
+  have hfin_ker₁ : Finite (AddMonoidHom.ker φ₁) :=
+    Nat.finite_of_card_ne_zero (hker₁ ▸ (NeZero.ne N))
+  have hfin_ker₂ : Finite (AddMonoidHom.ker φ₂) :=
+    Nat.finite_of_card_ne_zero (hcard₂ ▸ (NeZero.ne N))
+  have hσE_ker_bij : Function.Bijective σE_ker :=
+    (Nat.bijective_iff_injective_and_card _).mpr ⟨hσE_ker_inj, hcard_eq⟩
+  let e : (AddMonoidHom.ker φ₁) ≃+ (AddMonoidHom.ker φ₂) :=
+    AddEquiv.ofBijective σE_ker hσE_ker_bij
+  have hcyc₁ : IsAddCyclic (AddMonoidHom.ker φ₁) := by
+    obtain ⟨⟨g₂, hg₂⟩⟩ := hcyc₂
+    exact ⟨⟨e.symm g₂, fun y => by
+      obtain ⟨k, hk⟩ := hg₂ (e y)
+      exact ⟨k, e.injective (by rw [map_zsmul, e.apply_symm_apply]; exact hk)⟩⟩⟩
+  exact ⟨hcyc₁, hker₁⟩
+
+end ModularCurve
+end
+end
+
+theorem hBC_s17 :
+    ModularCurve.KwD5BetweenCurvesFFSeamBaseChange := ModularCurve.kw_surge_hgf4_hBC_proved
+universe u_kt in
+theorem kerTransport_s17 :
+    ModularCurve.KwD5BetweenCurvesKerTransportAlongEmbed.{u_kt} :=
+      ModularCurve.kw_surgehgf4_hfgkd_ktd_kerTransport_proved.{u_kt}
+
+universe u_sol in
+p2m_open "AlgebraicCurve~Place.ord_nonneg_of_mem~Place.mem_of_ord_nonneg~Place.mem_iff_ord_nonneg\
+  " in
+open _root_.WeierstrassCurve
+  _root_.P2MW.S_OVERLONG_55b03433.WeierstrassCurve
+  _root_.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_55b03433.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_55b03433.AlgebraicCurve
+  in
+theorem solution
+    (R₀ : Type u_sol) [Field R₀] (E₀ E₀' : WeierstrassCurve R₀) [E₀.IsElliptic] [E₀'.IsElliptic]
+    (F₁ : Type u_sol) [Field F₁] [Algebra R₀ F₁] [DecidableEq F₁] [IsAlgClosed F₁] [CharZero F₁]
+    (F₂ : Type u_sol) [Field F₂] [Algebra R₀ F₂] [DecidableEq F₂] [IsAlgClosed F₂] [CharZero F₂]
+    [Algebra F₁ F₂] [IsScalarTower R₀ F₁ F₂]
+    [(E₀.baseChange F₁).IsElliptic] [(E₀'.baseChange F₁).IsElliptic]
+    [(E₀.baseChange F₂).IsElliptic] [(E₀'.baseChange F₂).IsElliptic]
+    [GenusOnePlaceGate (E₀.baseChange F₁).toAffine]
+    [GenusOnePlaceGate.IsCentred (E₀.baseChange F₁).toAffine]
+    [AbelTheorem (E₀.baseChange F₁).toAffine]
+    [GenusOnePlaceGate (E₀'.baseChange F₁).toAffine]
+    [GenusOnePlaceGate.IsCentred (E₀'.baseChange F₁).toAffine]
+    [AbelTheorem (E₀'.baseChange F₁).toAffine]
+    [GenusOnePlaceGate (E₀.baseChange F₂).toAffine]
+    [GenusOnePlaceGate.IsCentred (E₀.baseChange F₂).toAffine]
+    [AbelTheorem (E₀.baseChange F₂).toAffine]
+    [GenusOnePlaceGate (E₀'.baseChange F₂).toAffine]
+    [GenusOnePlaceGate.IsCentred (E₀'.baseChange F₂).toAffine]
+    [AbelTheorem (E₀'.baseChange F₂).toAffine]
+    (χ : (E₀.baseChange F₁).toAffine.FunctionField →ₐ[F₁] (E₀.baseChange F₂).toAffine.FunctionField)
+    (hχX : χ (polyToFunctionField (E₀.baseChange F₁).toAffine Polynomial.X)
+      = polyToFunctionField (E₀.baseChange F₂).toAffine Polynomial.X)
+    (hχY : χ (yCoord (E₀.baseChange F₁).toAffine) = yCoord (E₀.baseChange F₂).toAffine)
+    (χ' : (E₀'.baseChange F₁).toAffine.FunctionField →ₐ[F₁] (E₀'.baseChange
+      F₂).toAffine.FunctionField)
+    (hχ'X : χ' (polyToFunctionField (E₀'.baseChange F₁).toAffine Polynomial.X)
+      = polyToFunctionField (E₀'.baseChange F₂).toAffine Polynomial.X)
+    (hχ'Y : χ' (yCoord (E₀'.baseChange F₁).toAffine) = yCoord (E₀'.baseChange F₂).toAffine)
+    (ι₁ : (E₀'.baseChange F₁).toAffine.FunctionField →ₐ[F₁] (E₀.baseChange
+      F₁).toAffine.FunctionField)
+    (hι₁ : ι₁.toRingHom.IsIntegral) (hfin₁ : FiniteAlong F₁ ι₁) (hN₁ : NormFormulaAlong F₁ ι₁ hfin₁)
+    (ι₂ : (E₀'.baseChange F₂).toAffine.FunctionField →ₐ[F₂] (E₀.baseChange
+      F₂).toAffine.FunctionField)
+    (hι₂ : ι₂.toRingHom.IsIntegral) (hfin₂ : FiniteAlong F₂ ι₂) (hN₂ : NormFormulaAlong F₂ ι₂ hfin₂)
+    (hcompat : ∀ x, ι₂ (χ' x) = χ (ι₁ x))
+    (N : ℕ) [NeZero N]
+    (hcyc : IsAddCyclic (pointMapOfPushforward ι₂ hι₂ hfin₂ hN₂).ker)
+    (hcard : Nat.card (pointMapOfPushforward ι₂ hι₂ hfin₂ hN₂).ker = N) :
+    IsAddCyclic (pointMapOfPushforward ι₁ hι₁ hfin₁ hN₁).ker ∧
+      Nat.card (pointMapOfPushforward ι₁ hι₁ hfin₁ hN₁).ker = N := by
+  have hχE : χ = ModularCurve.kw_functionFieldMapAlongGeneralNoAC E₀ F₁ F₂ := by
+    refine WeierstrassCurve.Affine.kw_functionField_algHom_ext ?_ ?_
+    · rw [hχX, ModularCurve.kw_functionFieldMapAlongGeneralNoAC_polyToFunctionField_X]
+    · rw [ModularCurve.kw_functionFieldMapAlongGeneralNoAC_yGen]; exact hχY
+  have hχE' : χ' = ModularCurve.kw_functionFieldMapAlongGeneralNoAC E₀' F₁ F₂ := by
+    refine WeierstrassCurve.Affine.kw_functionField_algHom_ext ?_ ?_
+    · rw [hχ'X, ModularCurve.kw_functionFieldMapAlongGeneralNoAC_polyToFunctionField_X]
+    · rw [ModularCurve.kw_functionFieldMapAlongGeneralNoAC_yGen]; exact hχ'Y
+  subst hχE; subst hχE'
+  exact kerTransport_s17.{u_sol} R₀ E₀ E₀' F₁ F₂ ι₁ hι₁ hfin₁ ι₂ hι₂ hfin₂ hcompat N hcyc hcard
+
+end
+end
+end
+end
+end
+end
+end
+end
+end S_OVERLONG_55b03433
+end P2MW
+export P2MW.S_OVERLONG_55b03433
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+universe u
+theorem WeierstrassCurve.Affine.isAddCyclic_ker_pointMapOfPushforward_of_baseChange_algHom
+    (R₀ : Type u) [Field R₀] (E₀ E₀' : WeierstrassCurve R₀) [E₀.IsElliptic] [E₀'.IsElliptic]
+    (F₁ : Type u) [Field F₁] [Algebra R₀ F₁] [DecidableEq F₁] [IsAlgClosed F₁] [CharZero F₁]
+    (F₂ : Type u) [Field F₂] [Algebra R₀ F₂] [DecidableEq F₂] [IsAlgClosed F₂] [CharZero F₂]
+    [Algebra F₁ F₂] [IsScalarTower R₀ F₁ F₂]
+    [(E₀.baseChange F₁).IsElliptic] [(E₀'.baseChange F₁).IsElliptic]
+    [(E₀.baseChange F₂).IsElliptic] [(E₀'.baseChange F₂).IsElliptic]
+    [GenusOnePlaceGate (E₀.baseChange F₁).toAffine]
+    [GenusOnePlaceGate.IsCentred (E₀.baseChange F₁).toAffine]
+    [AbelTheorem (E₀.baseChange F₁).toAffine]
+    [GenusOnePlaceGate (E₀'.baseChange F₁).toAffine]
+    [GenusOnePlaceGate.IsCentred (E₀'.baseChange F₁).toAffine]
+    [AbelTheorem (E₀'.baseChange F₁).toAffine]
+    [GenusOnePlaceGate (E₀.baseChange F₂).toAffine]
+    [GenusOnePlaceGate.IsCentred (E₀.baseChange F₂).toAffine]
+    [AbelTheorem (E₀.baseChange F₂).toAffine]
+    [GenusOnePlaceGate (E₀'.baseChange F₂).toAffine]
+    [GenusOnePlaceGate.IsCentred (E₀'.baseChange F₂).toAffine]
+    [AbelTheorem (E₀'.baseChange F₂).toAffine]
+    (χ : (E₀.baseChange F₁).toAffine.FunctionField →ₐ[F₁] (E₀.baseChange F₂).toAffine.FunctionField)
+    (hχX : χ (polyToFunctionField (E₀.baseChange F₁).toAffine Polynomial.X)
+      = polyToFunctionField (E₀.baseChange F₂).toAffine Polynomial.X)
+    (hχY : χ (yCoord (E₀.baseChange F₁).toAffine) = yCoord (E₀.baseChange F₂).toAffine)
+    (χ' : (E₀'.baseChange F₁).toAffine.FunctionField →ₐ[F₁] (E₀'.baseChange
+      F₂).toAffine.FunctionField)
+    (hχ'X : χ' (polyToFunctionField (E₀'.baseChange F₁).toAffine Polynomial.X)
+      = polyToFunctionField (E₀'.baseChange F₂).toAffine Polynomial.X)
+    (hχ'Y : χ' (yCoord (E₀'.baseChange F₁).toAffine) = yCoord (E₀'.baseChange F₂).toAffine)
+    (ι₁ : (E₀'.baseChange F₁).toAffine.FunctionField →ₐ[F₁] (E₀.baseChange
+      F₁).toAffine.FunctionField)
+    (hι₁ : ι₁.toRingHom.IsIntegral) (hfin₁ : FiniteAlong F₁ ι₁) (hN₁ : NormFormulaAlong F₁ ι₁ hfin₁)
+    (ι₂ : (E₀'.baseChange F₂).toAffine.FunctionField →ₐ[F₂] (E₀.baseChange
+      F₂).toAffine.FunctionField)
+    (hι₂ : ι₂.toRingHom.IsIntegral) (hfin₂ : FiniteAlong F₂ ι₂) (hN₂ : NormFormulaAlong F₂ ι₂ hfin₂)
+    (hcompat : ∀ x, ι₂ (χ' x) = χ (ι₁ x))
+    (N : ℕ) [NeZero N]
+    (hcyc : IsAddCyclic (pointMapOfPushforward ι₂ hι₂ hfin₂ hN₂).ker)
+    (hcard : Nat.card (pointMapOfPushforward ι₂ hι₂ hfin₂ hN₂).ker = N) :
+    IsAddCyclic (pointMapOfPushforward ι₁ hι₁ hfin₁ hN₁).ker ∧
+      Nat.card (pointMapOfPushforward ι₁ hι₁ hfin₁ hN₁).ker = N :=
+  solution R₀ E₀ E₀' F₁ F₂ χ hχX hχY χ' hχ'X hχ'Y ι₁ hι₁ hfin₁ hN₁ ι₂ hι₂ hfin₂ hN₂ hcompat N hcyc
+    hcard
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_ker_pointMapOfPushforward_eq_of_j_eq_of_forall_pointEnd_eq_zsmul.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_ker_pointMapOfPushforward_eq_of_j_eq_of_forall_pointEnd_eq_zsmul.lean
new file mode 100644
index 0000000000..da38511007
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_ker_pointMapOfPushforward_eq_of_j_eq_of_forall_pointEnd_eq_zsmul.lean
@@ -0,0 +1,614 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.Affine.ker_pointMapOfPushforward_eq_of_j_eq_of_forall_pointEnd_eq_zsmul
+(102db63a-46f1-5a3e-a4bf-eb9199ece59e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a8b71afd-afb7-5df0-be34-30cd3f5422dd
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.AlgebraicGeometry.EllipticCurve.IsomOfJ
+import Mathlib.Data.Int.Star
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_pushforwardAlong_pushforwardAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteAlong_comp
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteAlong_of_surjective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_pointEnd_eq_of_mem_isogenyEndSubring
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyHomDatum_exists_pointHom_comp_eq_of_ker_le_of_isCentred
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_exists_zsmul_eq_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_natCard_ker_pointMapOfPushforward_eq_finrankAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_pointMapOfPushforward_surjective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsionBy_eq_sq_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_nonempty_functionField_algEquiv_of_variableChange
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Kernel rigidity for isogenies out of a curve with End=ℤ
+
+Theorem statement:
+`WeierstrassCurve.Affine.ker_pointMapOfPushforward_eq_of_j_eq_of_forall_pointEnd_eq_zsmul`
+(`102db63a-46f1-5a3e-a4bf-eb9199ece59e`), by Claude, 2026-09-05.
+
+Proof: submission `a8b71afd-afb7-5df0-be34-30cd3f5422dd`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field of characteristic zero and let $W$ be an elliptic
+Weierstrass curve over $F$ whose affine model carries the genus-one place structure (a bijection
+between $W(F)$ and the places of $F(W)$ over $F$, all of degree $1$), is centred at each point (the
+classes of $X$ and of $Y-y$ lie in the nonunits of the valuation subring of the place attached to
+$(x,y)$), and satisfies the Abel theorem (a divisor of degree $0$ is principal exactly when its
+divisor sum vanishes). Assume moreover: for every isogeny endomorphism datum of $W$, that is every
+integral, module-finite $F$-algebra embedding $F(W)\hookrightarrow F(W)$, the pushforward norm
+formula holds (the pushforward of the divisor of a nonzero $f$ has order at each place $v$ equal to
+$\operatorname{ord}_v$ of the norm of $f$), and the induced endomorphism of $W(F)$ — obtained by
+transporting through the identification $W(F)\cong\operatorname{Pic}^0$ and pushing divisor classes
+forward — is $m\cdot\mathrm{id}$ for some $m \in \mathbb{Z}$. Let $V,V'$ be elliptic Weierstrass
+curves over $F$ likewise equipped with the genus-one place structure and the Abel theorem, and let
+$\iota \colon F(V) \to F(W)$ and $\iota' \colon F(V') \to F(W)$ be $F$-algebra maps that are
+integral and module-finite and satisfy the pushforward norm formula. If the kernels of the
+associated pushforward maps $W(F) \to V(F)$ and $W(F) \to V'(F)$ have the same cardinality and $j(V)
+= j(V')$, then these two kernels coincide as subgroups of $W(F)$.
+
+This is the kernel rigidity statement for a curve without complex multiplication: two isogenies out
+of $W$ whose kernels have the same order and whose targets have equal $j$-invariant differ by an
+isomorphism of the targets, hence have the same kernel. It underlies the injectivity of $C \mapsto
+j(W/C)$ on subgroups of a fixed order, and is used in the analysis of the modular polynomial and of
+the Tate point kernels
+([`ModularCurve.ModularPolynomialData.mem_of_isRoot_map_j_of_transcendental`]
+(thm.html#ModularCurve.ModularPolynomialData.mem_of_isRoot_map_j_of_transcendental)
+and [`ModularCurve.TatePoint.fullKernelInjAt`](thm.html#ModularCurve.TatePoint.fullKernelInjAt)).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_ker_pointMapOfPushforward_eq_of_j_eq_of_forall_pointEnd_eq_zsmul.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_072510fc
+
+
+noncomputable section
+
+namespace ModularCurve
+
+theorem cmm5_dp_natCard_ker_comp {A B C : Type*} [AddCommGroup A] [AddCommGroup B]
+    [AddCommGroup C] (f : A →+ B) (g : B →+ C) (hf : Function.Surjective f) :
+    Nat.card (AddMonoidHom.ker (g.comp f))
+      = Nat.card (AddMonoidHom.ker g) * Nat.card (AddMonoidHom.ker f) := by
+  have hmem : ∀ x : AddMonoidHom.ker (g.comp f),
+      (f.domRestrict (AddMonoidHom.ker (g.comp f))) x ∈ AddMonoidHom.ker g := by
+    intro x
+    have hx := x.2
+    rw [AddMonoidHom.mem_ker] at hx
+    rw [AddMonoidHom.mem_ker]
+    exact hx
+  have hle : AddMonoidHom.ker f ≤ AddMonoidHom.ker (g.comp f) := by
+    intro x hx
+    rw [AddMonoidHom.mem_ker] at hx
+    rw [AddMonoidHom.mem_ker, AddMonoidHom.comp_apply, hx, map_zero]
+  have hφker : Nat.card (AddMonoidHom.ker
+        (AddMonoidHom.codRestrict (f.domRestrict (AddMonoidHom.ker (g.comp f)))
+          (AddMonoidHom.ker g) hmem))
+      = Nat.card (AddMonoidHom.ker f) := by
+    rw [AddMonoidHom.ker_codRestrict, AddMonoidHom.ker_domRestrict]
+    exact Nat.card_congr (AddSubgroup.addSubgroupOfEquivOfLe hle).toEquiv
+  have hφsurj : Function.Surjective
+      (AddMonoidHom.codRestrict (f.domRestrict (AddMonoidHom.ker (g.comp f)))
+        (AddMonoidHom.ker g) hmem) := by
+    intro y
+    have hy : g (y : B) = 0 := by
+      have h := y.2
+      rwa [AddMonoidHom.mem_ker] at h
+    obtain ⟨x, hx⟩ := hf (y : B)
+    have hxK : x ∈ AddMonoidHom.ker (g.comp f) := by
+      rw [AddMonoidHom.mem_ker, AddMonoidHom.comp_apply, hx]
+      exact hy
+    exact ⟨⟨x, hxK⟩, Subtype.ext hx⟩
+  calc Nat.card (AddMonoidHom.ker (g.comp f))
+      = Nat.card (AddMonoidHom.ker (g.comp f) ⧸ AddMonoidHom.ker
+            (AddMonoidHom.codRestrict (f.domRestrict (AddMonoidHom.ker (g.comp f)))
+              (AddMonoidHom.ker g) hmem))
+          * Nat.card (AddMonoidHom.ker
+            (AddMonoidHom.codRestrict (f.domRestrict (AddMonoidHom.ker (g.comp f)))
+              (AddMonoidHom.ker g) hmem)) :=
+        AddSubgroup.card_eq_card_quotient_mul_card_addSubgroup _
+    _ = Nat.card (AddMonoidHom.ker g) * Nat.card (AddMonoidHom.ker f) := by
+        rw [Nat.card_congr
+          (QuotientAddGroup.quotientKerEquivOfSurjective _ hφsurj).toEquiv, hφker]
+
+end ModularCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map exists_variableChange_of_j_eq IsIntegral toAffine \
+  Affine.Point j Affine.pointMapOfPushforward Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred \
+  Affine.Point.exists_zsmul_eq_of_isAlgClosed card_torsionBy_eq_sq_of_isAlgClosed \
+  nonempty_functionField_algEquiv_of_variableChange"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "map FunctionField Point pointMapOfPushforward \
+  pointMapOfPushforward_apply IsogenyEndDatum IsogenyHomDatum IsogenyHomDatum.ofEndDatum \
+  GenusOnePlaceGate pointClass AbelTheorem genusOnePic0Equiv genusOnePic0Equiv_symm_apply \
+  GenusOnePlaceGate.IsCentred IsogenyHomDatum.exists_pointHom_comp_eq_of_ker_le_of_isCentred \
+  natCard_ker_pointMapOfPushforward_eq_finrankAlong pointMapOfPushforward_surjective \
+  Point.exists_zsmul_eq_of_isAlgClosed IsogenyEndDatum.exists_pointEnd_eq_of_mem_isogenyEndSubring \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine~pointHom WeierstrassCurve"
+
+open AlgebraicCurve
+
+scoped instance instHasPrincipalDivisorsFunctionField_a68c2 {F : Type*} [Field F] [CharZero F]
+    {W : Affine F} : HasPrincipalDivisors F W.FunctionField :=
+  hasPrincipalDivisors_functionField W
+
+section AutoNorm
+
+variable {F : Type*} [Field F] [CharZero F]
+variable {V W : Affine F} [V.IsElliptic] [W.IsElliptic]
+
+omit [WeierstrassCurve.IsElliptic V] [WeierstrassCurve.IsElliptic W] in
+theorem normFormulaAlong_of_elliptic (ι : V.FunctionField →ₐ[F] W.FunctionField)
+    (hfin : FiniteAlong F ι) : NormFormulaAlong F ι hfin := by
+  classical
+  have : CharZero V.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap F V.FunctionField).injective
+  have hsep : SeparableAlong F ι := by
+    let := algebraAlong ι
+    have := isScalarTower_along ι
+    have : Module.Finite V.FunctionField W.FunctionField := hfin
+    change Algebra.IsSeparable V.FunctionField W.FunctionField
+    infer_instance
+  exact AlgebraicCurve.normFormulaAlong ι hfin hsep
+
+end AutoNorm
+
+section Torsion
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic]
+
+theorem charZero_addMonoidEnd_point : CharZero (AddMonoid.End W.Point) := by
+  refine charZero_of_inj_zero fun n hn => ?_
+  by_contra hn0
+  have htop : ∀ k : ℕ, n ∣ k → Submodule.torsionBy ℤ W.Point (k : ℤ) = ⊤ := by
+    rintro k ⟨c, rfl⟩
+    refine eq_top_iff.mpr fun P _ => ?_
+    rw [Submodule.mem_torsionBy_iff]
+    have hP : (n : ℤ) • P = 0 := by
+      have h := DFunLike.congr_fun hn P
+      rw [AddMonoid.End.natCast_apply] at h
+      rw [natCast_zsmul]; exact h
+    rw [Nat.cast_mul, mul_comm, mul_smul, hP, smul_zero]
+  have hcard : ∀ k : ℕ, n ∣ k → k ≠ 0 → Nat.card W.Point = k ^ 2 := by
+    intro k hk hk0
+    have h : Nat.card (Submodule.torsionBy ℤ W.Point (k : ℤ)) = k ^ 2 :=
+      WeierstrassCurve.card_torsionBy_eq_sq_of_isAlgClosed W (n := k)
+        (Nat.cast_ne_zero.mpr hk0)
+    rw [htop k hk] at h
+    rwa [Nat.card_congr (Submodule.topEquiv (R := ℤ) (M := W.Point)).toEquiv] at h
+  have h1 := hcard n dvd_rfl hn0
+  have h2 := hcard (2 * n) (dvd_mul_left n 2) (by omega)
+  have h3 : n ^ 2 = (2 * n) ^ 2 := h1.symm.trans h2
+  have h4 : 3 * n ^ 2 = 0 := by nlinarith
+  have h5 : n = 0 := by
+    have : n ^ 2 = 0 := by omega
+    exact pow_eq_zero_iff (n := 2) (by norm_num) |>.mp this
+  exact hn0 h5
+
+theorem intCast_addMonoidEnd_point_injective :
+    Function.Injective (Int.cast : ℤ → AddMonoid.End W.Point) :=
+  haveI := charZero_addMonoidEnd_point W
+  Int.cast_injective
+
+variable {W} in
+omit [DecidableEq F] in
+theorem kw_point_infinite : Infinite W.Point := by
+  classical
+  rw [← not_finite_iff_infinite]
+  intro hfinite
+  have : Finite W.Point := hfinite
+  set N : ℕ := Nat.card W.Point with hN
+  have hNpos : 0 < N := Nat.card_pos
+  have htop : ∀ k : ℕ, N ∣ k → Submodule.torsionBy ℤ W.Point (k : ℤ) = ⊤ := by
+    rintro k ⟨c, rfl⟩
+    refine eq_top_iff.mpr fun P _ => ?_
+    rw [Submodule.mem_torsionBy_iff]
+    have hP : (N : ℤ) • P = 0 := by
+      rw [natCast_zsmul, hN]; exact card_nsmul_eq_zero'
+    rw [Nat.cast_mul, mul_comm, mul_smul, hP, smul_zero]
+  have hcard : ∀ k : ℕ, N ∣ k → k ≠ 0 → N = k ^ 2 := by
+    intro k hk hk0
+    have h : Nat.card (Submodule.torsionBy ℤ W.Point (k : ℤ)) = k ^ 2 :=
+      WeierstrassCurve.card_torsionBy_eq_sq_of_isAlgClosed W (n := k)
+        (Nat.cast_ne_zero.mpr hk0)
+    rw [htop k hk] at h
+    rwa [Nat.card_congr (Submodule.topEquiv (R := ℤ) (M := W.Point)).toEquiv, ← hN] at h
+  have h1 := hcard N dvd_rfl hNpos.ne'
+  have h2 := hcard (2 * N) (dvd_mul_left N 2) (by omega)
+  have h3 : N ^ 2 = (2 * N) ^ 2 := h1.symm.trans h2
+  have h4 : N ^ 2 = 0 := by nlinarith
+  exact hNpos.ne' (pow_eq_zero_iff (n := 2) (by norm_num) |>.mp h4)
+
+variable {W} in
+theorem kw_nat_card_ker_of_zsmul {f : W.Point →+ W.Point} {N : ℤ}
+    (hN : N ≠ 0) (hf : ∀ P, f P = N • P) : Nat.card f.ker = N.natAbs ^ 2 := by
+  have hsets : ∀ P : W.Point,
+      P ∈ f.ker ↔ P ∈ Submodule.torsionBy ℤ W.Point (N.natAbs : ℤ) := by
+    intro P
+    rw [AddMonoidHom.mem_ker, hf, Submodule.mem_torsionBy_iff]
+    constructor
+    · intro hP
+      rcases Int.natAbs_eq N with h | h
+      · rwa [h] at hP
+      · rwa [h, neg_zsmul, neg_eq_zero] at hP
+    · intro hP
+      rcases Int.natAbs_eq N with h | h
+      · rw [h]; exact hP
+      · rw [h, neg_zsmul, neg_eq_zero]; exact hP
+  rw [Nat.card_congr (Equiv.subtypeEquivRight hsets)]
+  exact WeierstrassCurve.card_torsionBy_eq_sq_of_isAlgClosed W (n := N.natAbs)
+    (Nat.cast_ne_zero.mpr (Int.natAbs_ne_zero.mpr hN))
+
+variable {W} in
+omit [CharZero F] in
+theorem kw_eq_zero_of_zsmul_eq_zero {N : ℤ} (hN : N ≠ 0) {G : Type*} [AddCommGroup G]
+    (δ : W.Point →+ G) (hδ : ∀ P, N • δ P = 0) : δ = 0 := by
+  refine AddMonoidHom.ext fun P => ?_
+  obtain ⟨R, hR⟩ : ∃ R : W.Point, N • R = P :=
+    WeierstrassCurve.Affine.Point.exists_zsmul_eq_of_isAlgClosed W hN P
+  rw [← hR, map_zsmul]; exact hδ R
+
+end Torsion
+
+section Functoriality
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F]
+variable {A B C : Affine F}
+  [A.IsElliptic] [GenusOnePlaceGate A] [AbelTheorem A]
+  [B.IsElliptic] [GenusOnePlaceGate B] [AbelTheorem B]
+  [C.IsElliptic] [GenusOnePlaceGate C] [AbelTheorem C]
+
+omit [DecidableEq F] [WeierstrassCurve.IsElliptic A]
+  [A.GenusOnePlaceGate] [A.AbelTheorem] [WeierstrassCurve.IsElliptic B] [B.GenusOnePlaceGate]
+  [B.AbelTheorem] [WeierstrassCurve.IsElliptic C] [C.GenusOnePlaceGate] [C.AbelTheorem] in
+theorem Pic0_pushforwardAlongHom_comp
+    (f : B.FunctionField →ₐ[F] A.FunctionField) (hf : f.toRingHom.IsIntegral)
+    (hfinf : FiniteAlong F f) (hNf : NormFormulaAlong F f hfinf)
+    (g : C.FunctionField →ₐ[F] B.FunctionField) (hg : g.toRingHom.IsIntegral)
+    (hfing : FiniteAlong F g) (hNg : NormFormulaAlong F g hfing)
+    (hfg : (f.comp g).toRingHom.IsIntegral) (hfinfg : FiniteAlong F (f.comp g))
+    (hNfg : NormFormulaAlong F (f.comp g) hfinfg)
+    (x : Pic0 F A.FunctionField) :
+    Pic0.pushforwardAlongHom g hg hfing hNg (Pic0.pushforwardAlongHom f hf hfinf hNf x)
+      = Pic0.pushforwardAlongHom (f.comp g) hfg hfinfg hNfg x := by
+  obtain ⟨D, rfl⟩ := Pic0.mk_surjective x
+  rw [Pic0.pushforwardAlongHom_mk, Pic0.pushforwardAlongHom_mk, Pic0.pushforwardAlongHom_mk]
+  congr 1
+  refine Subtype.ext ?_
+  rw [Pic0.coe_pushforwardAlongDegZero, Pic0.coe_pushforwardAlongDegZero,
+    Pic0.coe_pushforwardAlongDegZero]
+  exact Divisor.pushforwardAlong_pushforwardAlong g f hg hf hfg (D : Divisor F A.FunctionField)
+
+omit [WeierstrassCurve.IsElliptic A] [WeierstrassCurve.IsElliptic B]
+  [WeierstrassCurve.IsElliptic C] in
+theorem pointMapOfPushforward_comp
+    (f : B.FunctionField →ₐ[F] A.FunctionField) (hf : f.toRingHom.IsIntegral)
+    (hfinf : FiniteAlong F f) (hNf : NormFormulaAlong F f hfinf)
+    (g : C.FunctionField →ₐ[F] B.FunctionField) (hg : g.toRingHom.IsIntegral)
+    (hfing : FiniteAlong F g) (hNg : NormFormulaAlong F g hfing)
+    (hfg : (f.comp g).toRingHom.IsIntegral) (hfinfg : FiniteAlong F (f.comp g))
+    (hNfg : NormFormulaAlong F (f.comp g) hfinfg) (P : A.Point) :
+    pointMapOfPushforward (f.comp g) hfg hfinfg hNfg P
+      = pointMapOfPushforward g hg hfing hNg (pointMapOfPushforward f hf hfinf hNf P) := by
+  have key : ∀ x : Pic0 F B.FunctionField, pointClass (genusOnePic0Equiv B x) = x := fun x => by
+    rw [← genusOnePic0Equiv_symm_apply, AddEquiv.symm_apply_apply]
+  rw [pointMapOfPushforward_apply, pointMapOfPushforward_apply, pointMapOfPushforward_apply, key,
+    Pic0_pushforwardAlongHom_comp f hf hfinf hNf g hg hfing hNg hfg hfinfg hNfg]
+
+end Functoriality
+
+section IsoInjective
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {A B : Affine F}
+  [A.IsElliptic] [GenusOnePlaceGate A] [AbelTheorem A]
+  [B.IsElliptic] [GenusOnePlaceGate B] [AbelTheorem B]
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic A]
+  [A.GenusOnePlaceGate] [A.AbelTheorem] [WeierstrassCurve.IsElliptic B] [B.GenusOnePlaceGate]
+  [B.AbelTheorem] in
+theorem finrankAlong_eq_one_of_bijective (τ : B.FunctionField →ₐ[F] A.FunctionField)
+    (hτ : Function.Bijective τ) : finrankAlong F τ = 1 := by
+  let := algebraAlong τ
+  let σ : B.FunctionField ≃+* A.FunctionField := RingEquiv.ofBijective τ hτ
+  let e : A.FunctionField ≃ₗ[B.FunctionField] B.FunctionField :=
+    { σ.symm.toAddEquiv with
+      map_smul' := fun b x => by
+        change σ.symm (b • x) = b * σ.symm x
+        rw [Algebra.smul_def, map_mul]
+        congr 1
+        exact σ.symm_apply_apply b }
+  change Module.finrank B.FunctionField A.FunctionField = 1
+  rw [e.finrank_eq, Module.finrank_self]
+
+theorem pointMapOfPushforward_injective_of_bijective
+    (τ : B.FunctionField →ₐ[F] A.FunctionField) (hτ : τ.toRingHom.IsIntegral)
+    (hfin : FiniteAlong F τ) (hN : NormFormulaAlong F τ hfin) (hbij : Function.Bijective τ) :
+    Function.Injective (pointMapOfPushforward τ hτ hfin hN) := by
+  have hcard : Nat.card (pointMapOfPushforward τ hτ hfin hN).ker = 1 := by
+    rw [natCard_ker_pointMapOfPushforward_eq_finrankAlong A B τ hτ hfin hN,
+      finrankAlong_eq_one_of_bijective τ hbij]
+  have : Finite (pointMapOfPushforward τ hτ hfin hN).ker :=
+    Nat.finite_of_card_ne_zero (by rw [hcard]; exact one_ne_zero)
+  have hbot : (pointMapOfPushforward τ hτ hfin hN).ker = ⊥ :=
+    AddSubgroup.eq_bot_of_card_eq _ hcard
+  exact (AddMonoidHom.ker_eq_bot_iff _).mp hbot
+
+end IsoInjective
+
+end WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map exists_variableChange_of_j_eq IsIntegral toAffine \
+  Affine.Point j Affine.pointMapOfPushforward Affine.IsogenyEndDatum Affine.GenusOnePlaceGate \
+  Affine.AbelTheorem Affine.GenusOnePlaceGate.IsCentred \
+  Affine.Point.exists_zsmul_eq_of_isAlgClosed card_torsionBy_eq_sq_of_isAlgClosed \
+  nonempty_functionField_algEquiv_of_variableChange"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "map FunctionField Point pointMapOfPushforward \
+  pointMapOfPushforward_apply IsogenyEndDatum IsogenyHomDatum IsogenyHomDatum.ofEndDatum \
+  GenusOnePlaceGate pointClass AbelTheorem genusOnePic0Equiv genusOnePic0Equiv_symm_apply \
+  GenusOnePlaceGate.IsCentred IsogenyHomDatum.exists_pointHom_comp_eq_of_ker_le_of_isCentred \
+  natCard_ker_pointMapOfPushforward_eq_finrankAlong pointMapOfPushforward_surjective \
+  Point.exists_zsmul_eq_of_isAlgClosed IsogenyEndDatum.exists_pointEnd_eq_of_mem_isogenyEndSubring \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine~pointHom WeierstrassCurve"
+
+open AlgebraicCurve
+
+universe u
+
+attribute [local instance] Classical.propDecidable
+
+theorem ker_pointMapOfPushforward_eq_of_j_eq_of_forall_pointEnd_eq_zsmul_a68
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    (W : WeierstrassCurve F) [W.IsElliptic]
+    [GenusOnePlaceGate W.toAffine] [GenusOnePlaceGate.IsCentred W.toAffine]
+    [AbelTheorem W.toAffine]
+    (hNs : ∀ D : IsogenyEndDatum W.toAffine, NormFormulaAlong F D.ι D.hfin)
+    (hEnd : ∀ D : IsogenyEndDatum W.toAffine, ∃ m : ℤ, ∀ P : W.toAffine.Point,
+      D.pointEnd (hNs D) P = m • P)
+    (V V' : WeierstrassCurve F) [V.IsElliptic] [V'.IsElliptic]
+    [GenusOnePlaceGate V.toAffine] [AbelTheorem V.toAffine]
+    [GenusOnePlaceGate V'.toAffine] [AbelTheorem V'.toAffine]
+    (ι : V.toAffine.FunctionField →ₐ[F] W.toAffine.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong F ι) (hN : NormFormulaAlong F ι hfin)
+    (ι' : V'.toAffine.FunctionField →ₐ[F] W.toAffine.FunctionField)
+    (hι' : ι'.toRingHom.IsIntegral) (hfin' : FiniteAlong F ι') (hN' : NormFormulaAlong F ι' hfin')
+    (hcard : Nat.card (pointMapOfPushforward ι hι hfin hN).ker
+      = Nat.card (pointMapOfPushforward ι' hι' hfin' hN').ker)
+    (hj : V.j = V'.j) :
+    (pointMapOfPushforward ι hι hfin hN).ker = (pointMapOfPushforward ι' hι' hfin' hN').ker := by
+  classical
+  obtain ⟨C, hC⟩ := WeierstrassCurve.exists_variableChange_of_j_eq V V' hj
+  obtain ⟨σ⟩ : Nonempty (V.toAffine.FunctionField ≃ₐ[F] V'.toAffine.FunctionField) :=
+    hC ▸ WeierstrassCurve.nonempty_functionField_algEquiv_of_variableChange V C
+  set τ : V'.toAffine.FunctionField →ₐ[F] V.toAffine.FunctionField := σ.symm.toAlgHom with hτ_def
+  have hτbij : Function.Bijective τ := σ.symm.bijective
+  have hτint : τ.toRingHom.IsIntegral := RingHom.isIntegral_of_surjective _ hτbij.2
+  have hτfin : FiniteAlong F τ := finiteAlong_of_surjective τ hτbij.2
+  have hNτ : NormFormulaAlong F τ hτfin := normFormulaAlong_of_elliptic τ hτfin
+  have hιτint : (ι.comp τ).toRingHom.IsIntegral := RingHom.IsIntegral.trans _ _ hτint hι
+  have hιτfin : FiniteAlong F (ι.comp τ) := finiteAlong_comp τ ι hτfin hfin
+  have hNιτ : NormFormulaAlong F (ι.comp τ) hιτfin := normFormulaAlong_of_elliptic _ hιτfin
+  set φ := pointMapOfPushforward ι hι hfin hN with hφ_def
+  set φ' := pointMapOfPushforward ι' hι' hfin' hN' with hφ'_def
+  set β := pointMapOfPushforward (ι.comp τ) hιτint hιτfin hNιτ with hβ_def
+  have hβ_comp : ∀ P, β P = pointMapOfPushforward τ hτint hτfin hNτ (φ P) := fun P =>
+    pointMapOfPushforward_comp ι hι hfin hN τ hτint hτfin hNτ hιτint hιτfin hNιτ P
+  have hτinj := pointMapOfPushforward_injective_of_bijective τ hτint hτfin hNτ hτbij
+  have hkerβ : β.ker = φ.ker := by
+    refine AddSubgroup.ext fun P => ?_
+    rw [AddMonoidHom.mem_ker, AddMonoidHom.mem_ker, hβ_comp]
+    refine ⟨fun h => hτinj (h.trans (map_zero _).symm), fun h => ?_⟩
+    rw [h, map_zero]
+  have hβs : Function.Surjective β :=
+    pointMapOfPushforward_surjective W.toAffine _ (ι.comp τ) hιτint hιτfin hNιτ
+  have hφ's : Function.Surjective φ' :=
+    pointMapOfPushforward_surjective W.toAffine _ ι' hι' hfin' hN'
+  set d : ℕ := Nat.card φ'.ker with hd_def
+  have hdpos : 0 < d := by
+    rw [hd_def, hφ'_def, natCard_ker_pointMapOfPushforward_eq_finrankAlong W.toAffine V'.toAffine
+      ι' hι' hfin' hN']
+    let := algebraAlong ι'
+    have : Module.Finite V'.toAffine.FunctionField W.toAffine.FunctionField := hfin'
+    change 0 < Module.finrank V'.toAffine.FunctionField W.toAffine.FunctionField
+    exact Module.finrank_pos
+  have hd0 : d ≠ 0 := hdpos.ne'
+  have hfinker : Finite φ'.ker := Nat.finite_of_card_ne_zero (hd_def ▸ hd0)
+  have hNne : ((d : ℤ) : AddMonoid.End W.toAffine.Point) ≠ 0 := by
+    intro h
+    have := intCast_addMonoidEnd_point_injective W.toAffine (h.trans Int.cast_zero.symm)
+    omega
+  obtain ⟨M, hM⟩ := IsogenyEndDatum.exists_pointEnd_eq_of_mem_isogenyEndSubring hNs
+    ((d : ℤ) : AddMonoid.End W.toAffine.Point) (intCast_mem _ _) hNne
+  have hMapp : ∀ P, M.pointEnd (hNs M) P = (d : ℤ) • P := fun P => by
+    rw [hM, AddMonoid.End.intCast_apply]
+  let φ'D : IsogenyHomDatum W.toAffine V'.toAffine := ⟨ι', hι', hfin'⟩
+  have hmem_of_ker : ∀ P, φ' P = 0 → (d : ℤ) • P = 0 := by
+    intro P hP
+    have hx : Nat.card φ'.ker • (⟨P, (AddMonoidHom.mem_ker).mpr hP⟩ : φ'.ker) = 0 :=
+      card_nsmul_eq_zero'
+    have hx' := congrArg Subtype.val hx
+    simp only [AddSubmonoidClass.coe_nsmul, ZeroMemClass.coe_zero] at hx'
+    rw [natCast_zsmul]
+    exact hx'
+  obtain ⟨χ, hNχ, hχ⟩ := IsogenyHomDatum.exists_pointHom_comp_eq_of_ker_le_of_isCentred φ'D hN'
+    (IsogenyHomDatum.ofEndDatum M) (hNs M) (fun P hP => by
+      change M.pointEnd (hNs M) P = 0
+      rw [hMapp]; exact hmem_of_ker P hP)
+  set ψ' := χ.pointHom hNχ with hψ'_def
+  have hdual₁ : ∀ P, ψ' (φ' P) = (d : ℤ) • P := fun P => by
+    have h := hχ P
+    rw [← hMapp P]; exact h
+  have hdual₂ : ∀ S, φ' (ψ' S) = (d : ℤ) • S := fun S => by
+    obtain ⟨P, rfl⟩ := hφ's S
+    rw [hdual₁, map_zsmul]
+  have hDint : ((ι.comp τ).comp χ.ι).toRingHom.IsIntegral :=
+    RingHom.IsIntegral.trans _ _ χ.hι hιτint
+  let D : IsogenyEndDatum W.toAffine :=
+    ⟨(ι.comp τ).comp χ.ι, hDint, finiteAlong_comp χ.ι (ι.comp τ) χ.hfin hιτfin⟩
+  have hD : ∀ P, D.pointEnd (hNs D) P = ψ' (β P) := fun P =>
+    pointMapOfPushforward_comp (ι.comp τ) hιτint hιτfin hNιτ χ.ι χ.hι χ.hfin hNχ
+      hDint D.hfin (hNs D) P
+  obtain ⟨m, hm⟩ := hEnd D
+  set θ := ψ'.comp β with hθ_def
+  have hθm : ∀ P, θ P = m • P := fun P => by
+    change ψ' (β P) = m • P
+    rw [← hD P]; exact hm P
+  have hkerψ' : Nat.card ψ'.ker = d := by
+    have hcomp : Nat.card (ψ'.comp φ').ker = d ^ 2 := by
+      have h := kw_nat_card_ker_of_zsmul (W := W.toAffine) (f := ψ'.comp φ')
+        (N := (d : ℤ)) (by exact_mod_cast hd0) (fun P => hdual₁ P)
+      rw [Int.natAbs_natCast] at h; exact h
+    have hsplit := ModularCurve.cmm5_dp_natCard_ker_comp φ' ψ' hφ's
+    rw [hcomp, ← hd_def, sq] at hsplit
+    exact (Nat.eq_of_mul_eq_mul_right hdpos hsplit).symm
+  have hkerθ : Nat.card θ.ker = d ^ 2 := by
+    have hsplit := ModularCurve.cmm5_dp_natCard_ker_comp β ψ' hβs
+    rw [hkerβ, hcard, hkerψ'] at hsplit
+    rw [hθ_def, hsplit]; ring
+  have hmne : m ≠ 0 := by
+    intro h0
+    have hall : ∀ P, θ P = 0 := fun P => by rw [hθm, h0, zero_zsmul]
+    have htop : θ.ker = ⊤ :=
+      AddSubgroup.ext fun P => ⟨fun _ => trivial, fun _ => AddMonoidHom.mem_ker.mpr (hall P)⟩
+    rw [htop] at hkerθ
+    have : Infinite W.toAffine.Point := kw_point_infinite
+    simp only [AddSubgroup.card_top, Nat.card_eq_zero_of_infinite] at hkerθ
+    exact absurd hkerθ.symm (by positivity)
+  have hm_abs : m.natAbs = d := by
+    have hcard' := kw_nat_card_ker_of_zsmul (W := W.toAffine) hmne hθm
+    rw [hkerθ, sq, sq] at hcard'
+    exact (Nat.mul_self_inj).mp hcard'.symm
+  have hkey : ∀ P, (d : ℤ) • β P = m • φ' P := fun P => by
+    have h1 : φ' (ψ' (β P)) = (d : ℤ) • β P := hdual₂ (β P)
+    have h2 : φ' (θ P) = m • φ' P := by rw [hθm, map_zsmul]
+    rw [← h1]; exact h2
+  have hmcases : m = (d : ℤ) ∨ m = -(d : ℤ) := by
+    rcases Int.natAbs_eq m with h | h <;> [left; right] <;> omega
+  have hNz : (d : ℤ) ≠ 0 := by exact_mod_cast hd0
+  have hkerβ' : β.ker = φ'.ker := by
+    rcases hmcases with hm' | hm'
+    · have hδ : β - φ' = 0 :=
+        kw_eq_zero_of_zsmul_eq_zero (W := W.toAffine) hNz (β - φ') fun P => by
+          rw [AddMonoidHom.sub_apply, smul_sub, hkey P, hm', sub_self]
+      have heq : β = φ' := sub_eq_zero.mp hδ
+      rw [heq]
+    · have hδ : β + φ' = 0 :=
+        kw_eq_zero_of_zsmul_eq_zero (W := W.toAffine) hNz (β + φ') fun P => by
+          rw [AddMonoidHom.add_apply, smul_add, hkey P, hm', ← add_smul, neg_add_cancel,
+            zero_smul]
+      have heq : β = -φ' := eq_neg_iff_add_eq_zero.mpr hδ
+      rw [heq]
+      exact AddSubgroup.ext fun P => by
+        simp only [AddMonoidHom.mem_ker, AddMonoidHom.neg_apply, neg_eq_zero]
+  exact hkerβ.symm.trans hkerβ'
+
+end WeierstrassCurve.Affine
+end
+
+universe u
+
+theorem solution
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    (W : WeierstrassCurve F) [W.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W.toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem W.toAffine]
+    (hNs : ∀ D : WeierstrassCurve.Affine.IsogenyEndDatum W.toAffine,
+      AlgebraicCurve.NormFormulaAlong F D.ι D.hfin)
+    (hEnd : ∀ D : WeierstrassCurve.Affine.IsogenyEndDatum W.toAffine,
+      ∃ m : ℤ, ∀ P : W.toAffine.Point, D.pointEnd (hNs D) P = m • P)
+    (V V' : WeierstrassCurve F) [V.IsElliptic] [V'.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate V.toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem V.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate V'.toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem V'.toAffine]
+    (ι : V.toAffine.FunctionField →ₐ[F] W.toAffine.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : AlgebraicCurve.FiniteAlong F ι)
+    (hN : AlgebraicCurve.NormFormulaAlong F ι hfin)
+    (ι' : V'.toAffine.FunctionField →ₐ[F] W.toAffine.FunctionField)
+    (hι' : ι'.toRingHom.IsIntegral) (hfin' : AlgebraicCurve.FiniteAlong F ι')
+    (hN' : AlgebraicCurve.NormFormulaAlong F ι' hfin')
+    (hcard : Nat.card (WeierstrassCurve.Affine.pointMapOfPushforward ι hι hfin hN).ker
+      = Nat.card (WeierstrassCurve.Affine.pointMapOfPushforward ι' hι' hfin' hN').ker)
+    (hj : V.j = V'.j) :
+    (WeierstrassCurve.Affine.pointMapOfPushforward ι hι hfin hN).ker
+      = (WeierstrassCurve.Affine.pointMapOfPushforward ι' hι' hfin' hN').ker :=
+  WeierstrassCurve.Affine.ker_pointMapOfPushforward_eq_of_j_eq_of_forall_pointEnd_eq_zsmul_a68
+    W hNs hEnd V V' ι hι hfin hN ι' hι' hfin' hN' hcard hj
+
+end S_OVERLONG_072510fc
+end P2MW
+export
+  P2MW.S_OVERLONG_072510fc
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+universe u
+theorem WeierstrassCurve.Affine.ker_pointMapOfPushforward_eq_of_j_eq_of_forall_pointEnd_eq_zsmul
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    (W : WeierstrassCurve F) [W.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W.toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem W.toAffine]
+    (hNs : ∀ D : WeierstrassCurve.Affine.IsogenyEndDatum W.toAffine,
+      AlgebraicCurve.NormFormulaAlong F D.ι D.hfin)
+    (hEnd : ∀ D : WeierstrassCurve.Affine.IsogenyEndDatum W.toAffine,
+      ∃ m : ℤ, ∀ P : W.toAffine.Point, D.pointEnd (hNs D) P = m • P)
+    (V V' : WeierstrassCurve F) [V.IsElliptic] [V'.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate V.toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem V.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate V'.toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem V'.toAffine]
+    (ι : V.toAffine.FunctionField →ₐ[F] W.toAffine.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : AlgebraicCurve.FiniteAlong F ι)
+    (hN : AlgebraicCurve.NormFormulaAlong F ι hfin)
+    (ι' : V'.toAffine.FunctionField →ₐ[F] W.toAffine.FunctionField)
+    (hι' : ι'.toRingHom.IsIntegral) (hfin' : AlgebraicCurve.FiniteAlong F ι')
+    (hN' : AlgebraicCurve.NormFormulaAlong F ι' hfin')
+    (hcard : Nat.card (WeierstrassCurve.Affine.pointMapOfPushforward ι hι hfin hN).ker
+      = Nat.card (WeierstrassCurve.Affine.pointMapOfPushforward ι' hι' hfin' hN').ker)
+    (hj : V.j = V'.j) :
+    (WeierstrassCurve.Affine.pointMapOfPushforward ι hι hfin hN).ker
+      = (WeierstrassCurve.Affine.pointMapOfPushforward ι' hι' hfin' hN').ker :=
+  solution W hNs hEnd V V' ι hι hfin hN ι' hι' hfin' hN' hcard hj
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_natCard_ker_pointMapOfPushforward_eq_finrankAlong.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_natCard_ker_pointMapOfPushforward_eq_finrankAlong.lean
new file mode 100644
index 0000000000..e361c60357
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_natCard_ker_pointMapOfPushforward_eq_finrankAlong.lean
@@ -0,0 +1,641 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.natCard_ker_pointMapOfPushforward_eq_finrankAlong
+(edfe241b-5171-5926-b6a3-0a793be30c3d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission df966f14-8421-56b3-8b4d-c304d5f46f47
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.Star
+import Mathlib.RingTheory.DedekindDomain.Different
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ramificationIndex_eq_ramificationIdx_fiberCenter
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_sum_ramificationIndex_mul_inertiaDeg
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_pointMapOfPushforward_surjective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsionBy_eq_sq_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Kernel of a pushforward point map has order the degree
+
+Theorem statement: `WeierstrassCurve.Affine.natCard_ker_pointMapOfPushforward_eq_finrankAlong`
+(`edfe241b-5171-5926-b6a3-0a793be30c3d`), by Claude, 2026-09-05.
+
+Proof: submission `df966f14-8421-56b3-8b4d-c304d5f46f47`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field of characteristic zero, and let $E$, $E'$ be elliptic
+curves in affine Weierstrass form over $F$. Each of $E$ and $E'$ is assumed to carry a
+`GenusOnePlaceGate` structure — a bijection between its group of points and the set of places of its
+function field over $F$ (a place being a valuation subring, distinct from the whole field,
+containing the image of $F$ and a principal ideal ring), together with the assertion that every such
+place has degree $1$ — and to satisfy `AbelTheorem`: a divisor of degree zero is principal exactly
+when its image under `divisorSum` vanishes, where `divisorSum` is the additive map sending a place
+$v$ to the point corresponding to $v$ under the inverse of that bijection. Let $\iota \colon F(E')
+\to F(E)$ be an $F$-algebra homomorphism whose underlying ring homomorphism is integral, let `hfin :
+FiniteAlong F ι` witness that $F(E)$ is a finite module over $F(E')$ via $\iota$, and let `hN`
+witness the pushforward norm formula along $\iota$: for every nonzero $f \in F(E)$, every divisor
+$D$ on $F(E)$ with $D(w) = \operatorname{ord}_w(f)$ at all places $w$, and every place $v$ of
+$F(E')$, the pushforward of $D$ takes the value $\operatorname{ord}_v(N_{F(E)/F(E')}(f))$ at $v$.
+Then the kernel of `pointMapOfPushforward ι hι hfin hN : E.Point →+ E'.Point` — the homomorphism
+obtained by transporting points of $E$ to $\mathrm{Pic}^0$ of $F(E)$, pushing degree-zero divisor
+classes forward along $\iota$, and transporting back to points of $E'$ — has cardinality
+`finrankAlong F ι`, the dimension of $F(E)$ over $F(E')$ via $\iota$; as the cardinality is taken
+with `Nat.card`, the equality also records that this kernel is finite.
+
+This is the statement that an isogeny of elliptic curves in characteristic zero has kernel of order
+equal to its degree (Silverman III.4.10(c)), here in the form $\#\ker(E(F) \to E'(F)) = [F(E) :
+\iota F(E')]$ for the point map induced by divisor pushforward. It is used downstream in the
+analysis of isogeny data, for instance in identifying maps with prescribed kernel and in the
+recognition of $j$-invariants attached to isogeny endomorphism data.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_natCard_ker_pointMapOfPushforward_eq_finrankAlong.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_45662e8e
+
+
+noncomputable section
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong SeparableAlong \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Place HasPrincipalDivisors Pic0 Pic0.mk \
+  HasPrincipalDivisors.exists_divisor Place.valuationSubringAlgebra \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndex restrict inertiaDeg \
+  deg_restrict_mul_inertiaDeg fiber mem_fiber ext deg ord exists_unit_mul_zpow toValuationSubring \
+  mk center valuationSubringAlgebra integralClosureAt algebraMap_integralClosureAt_injective \
+  fiberCenter mem_fiberCenter_iff_ord_pos fiberCenter_liesOver \
+  sum_ramificationIndex_mul_inertiaDeg ramificationIndex_eq_ramificationIdx_fiberCenter"
+end AlgebraicCurve.Place
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong SeparableAlong \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Place HasPrincipalDivisors Pic0 Pic0.mk \
+  HasPrincipalDivisors.exists_divisor Place.valuationSubringAlgebra \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+p2m_open "AlgebraicCurve~Place.mem_of_ord_nonneg"
+
+section Producer
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+
+def IntegralAt (v : Place K F) (q : Polynomial F) : Prop :=
+  ∀ i, q.coeff i ∈ v.toValuationSubring
+
+theorem mem_lifts_of_integralAt {v : Place K F} {q : Polynomial F}
+    (hq : IntegralAt v q) :
+    q ∈ Polynomial.lifts (algebraMap v.toValuationSubring F) :=
+  (Polynomial.lifts_iff_coeff_lifts q).mpr fun n => ⟨⟨q.coeff n, hq n⟩, rfl⟩
+
+end Producer
+
+section PolarLocus
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] [HasPrincipalDivisors K F]
+
+theorem finite_setOf_ord_ne_zero_of_hasPrincipalDivisors {f : F} (hf : f ≠ 0) :
+    {v : Place K F | v.ord f ≠ 0}.Finite := by
+  obtain ⟨D, hD, -⟩ := HasPrincipalDivisors.exists_divisor (K := K) f hf
+  refine D.support.finite_toSet.subset fun v hv => Finsupp.mem_support_iff.mpr ?_
+  rw [hD v]
+  exact hv
+
+theorem finite_setOf_notMem_toValuationSubring (f : F) :
+    {v : Place K F | f ∉ v.toValuationSubring}.Finite := by
+  rcases eq_or_ne f 0 with rfl | hf
+  · refine Set.finite_empty.subset fun v hv => ?_
+    exact absurd (v.toValuationSubring.zero_mem) hv
+  · refine (finite_setOf_ord_ne_zero_of_hasPrincipalDivisors (K := K) hf).subset
+      fun v hv => ?_
+    intro h0
+    exact hv (AlgebraicCurve.Place.mem_of_ord_nonneg v hf h0.ge)
+
+end PolarLocus
+
+end AlgebraicCurve
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "Pic0.pushforwardAlongDegZero Pic0.coe_pushforwardAlongDegZero \
+  Pic0.pushforwardAlongHom Pic0.pushforwardAlongHom_mk algebraAlong isScalarTower_along \
+  isIntegral_along FiniteAlong NormFormulaAlong finrankAlong SeparableAlong \
+  Place.deg_restrict_mul_inertiaDeg Place.mem_fiber Place HasPrincipalDivisors Pic0 Pic0.mk \
+  HasPrincipalDivisors.exists_divisor Place.valuationSubringAlgebra \
+  Place.sum_ramificationIndex_mul_inertiaDeg"
+namespace Place
+p2m_export "AlgebraicCurve.Place" "restrictAlong ramificationIndex restrict inertiaDeg \
+  deg_restrict_mul_inertiaDeg fiber mem_fiber ext deg ord exists_unit_mul_zpow toValuationSubring \
+  mk center valuationSubringAlgebra integralClosureAt algebraMap_integralClosureAt_injective \
+  fiberCenter mem_fiberCenter_iff_ord_pos fiberCenter_liesOver \
+  sum_ramificationIndex_mul_inertiaDeg ramificationIndex_eq_ramificationIdx_fiberCenter"
+p2m_open "AlgebraicCurve.Place~mem_of_ord_nonneg AlgebraicCurve~Place.mem_of_ord_nonneg"
+
+open Polynomial IsDedekindDomain
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+attribute [local instance 0] valuationSubringAlgebra
+
+variable {v : Place K F} {w : Place K F'}
+
+theorem ord_deriv_pos_of_ramificationIndex_ne_one
+    (hw : w.restrict F = v) (θ : F')
+    (hgen : IntermediateField.adjoin F {θ} = ⊤)
+    (hθint : _root_.IsIntegral v.toValuationSubring θ)
+    (hram : w.ramificationIndex F ≠ 1) :
+    0 < w.ord (aeval θ (derivative (minpoly F θ))) := by
+  obtain ⟨c, rfl⟩ : ∃ c : integralClosureAt F' v,
+      algebraMap (integralClosureAt F' v) F' c = θ := ⟨⟨θ, hθint⟩, rfl⟩
+  have hAc : _root_.IsIntegral v.toValuationSubring c := Algebra.IsIntegral.isIntegral c
+  have hadjF : Algebra.adjoin F {algebraMap (integralClosureAt F' v) F' c} = ⊤ := by
+    rw [← IntermediateField.adjoin_toSubalgebra, hgen, IntermediateField.top_toSubalgebra]
+  have hmem : aeval c (derivative (minpoly v.toValuationSubring c))
+      ∈ differentIdeal v.toValuationSubring (integralClosureAt F' v) :=
+    aeval_derivative_mem_differentIdeal (A := v.toValuationSubring) (K := F) (L := F')
+      (B := integralClosureAt F' v) c hadjF
+  have himg : aeval (algebraMap (integralClosureAt F' v) F' c)
+        (derivative (minpoly F (algebraMap (integralClosureAt F' v) F' c)))
+      = algebraMap (integralClosureAt F' v) F'
+          (aeval c (derivative (minpoly v.toValuationSubring c))) := by
+    rw [minpoly.isIntegrallyClosed_eq_field_fractions F F' hAc, derivative_map,
+      aeval_map_algebraMap, aeval_algebraMap_apply]
+  have hg0 : aeval (algebraMap (integralClosureAt F' v) F' c)
+      (derivative (minpoly F (algebraMap (integralClosureAt F' v) F' c))) ≠ 0 :=
+    (Algebra.IsSeparable.isSeparable F _).aeval_derivative_ne_zero (minpoly.aeval F _)
+  have hc0 : aeval c (derivative (minpoly v.toValuationSubring c)) ≠ 0 := by
+    intro h; exact hg0 (by rw [himg, h, _root_.map_zero])
+  have : FaithfulSMul v.toValuationSubring (integralClosureAt F' v) :=
+    (faithfulSMul_iff_algebraMap_injective v.toValuationSubring (integralClosureAt F' v)).mpr
+      (algebraMap_integralClosureAt_injective v)
+  let : Algebra (FractionRing v.toValuationSubring) (FractionRing (integralClosureAt F' v)) :=
+    FractionRing.liftAlgebra v.toValuationSubring (FractionRing (integralClosureAt F' v))
+  have : IsScalarTower v.toValuationSubring (FractionRing v.toValuationSubring)
+      (FractionRing (integralClosureAt F' v)) :=
+    FractionRing.isScalarTower_liftAlgebra (R := v.toValuationSubring)
+      (K := FractionRing (integralClosureAt F' v))
+  have : Algebra.IsSeparable (FractionRing v.toValuationSubring)
+      (FractionRing (integralClosureAt F' v)) := by
+    refine Algebra.IsSeparable.of_equiv_equiv
+      (FractionRing.algEquiv v.toValuationSubring F).symm.toRingEquiv
+      (FractionRing.algEquiv (integralClosureAt F' v) F').symm.toRingEquiv ?_
+    ext _
+    exact IsFractionRing.algEquiv_commutes
+      (FractionRing.algEquiv v.toValuationSubring F).symm
+      (FractionRing.algEquiv (integralClosureAt F' v) F').symm _
+  have := (fiberCenter F' v hw).isPrime
+  have hdvd : (fiberCenter F' v hw).asIdeal
+      ∣ differentIdeal v.toValuationSubring (integralClosureAt F' v) := by
+    by_contra hnd
+    have : Algebra.IsUnramifiedAt v.toValuationSubring (fiberCenter F' v hw).asIdeal :=
+      not_dvd_differentIdeal_iff.mp hnd
+    have he1 : Ideal.ramificationIdx'
+        ((fiberCenter F' v hw).asIdeal.under v.toValuationSubring)
+        (fiberCenter F' v hw).asIdeal = 1 :=
+      (Ideal.ramificationIdx'_eq_ramificationIdx _ _
+          (Ideal.under_ne_bot (A := v.toValuationSubring) (fiberCenter F' v hw).ne_bot)).trans
+        Ideal.ramificationIdx_eq_one_of_isUnramifiedAt
+    exact hram <| by
+      rw [ramificationIndex_eq_ramificationIdx_fiberCenter (v := v) hw,
+        (fiberCenter_liesOver hw).over, he1]
+  have hmem2 : aeval c (derivative (minpoly v.toValuationSubring c))
+      ∈ (fiberCenter F' v hw).asIdeal := Ideal.le_of_dvd hdvd hmem
+  rw [himg]
+  exact (mem_fiberCenter_iff_ord_pos hw hc0).mp hmem2
+
+end AlgebraicCurve.Place
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map mk IsIntegral minimal Affine.deg_eq_one \
+  card_torsionBy_eq_sq_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "map FunctionField Point polynomial \
+  pushforwardAlong_single_eq pointMapOfPushforward pointMapOfPushforward_apply IsogenyEndDatum \
+  GenusOnePlaceGate pointEquivPlace placeOfPoint deg_eq_one pointDivisor coe_pointDivisor \
+  pointClass AbelTheorem pic0ToPoint_pointClass genusOnePic0Equiv genusOnePic0Equiv_apply \
+  hasPrincipalDivisors_functionField pointMapOfPushforward_surjective"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "AlgebraicCurve~Place.mem_of_ord_nonneg \
+  P2MW.S_OVERLONG_45662e8e.AlgebraicCurve"
+
+section Gate
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F]
+variable {W : Affine F} [GenusOnePlaceGate W]
+
+omit [DecidableEq F] in
+theorem placeOfPoint_injective : Function.Injective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).injective
+
+variable (W)
+
+def placeOfPointEquiv : W.Point ≃ AlgebraicCurve.Place F W.FunctionField :=
+  pointEquivPlace (W := W)
+
+omit [DecidableEq F] in
+@[scoped simp] theorem placeOfPointEquiv_symm_placeOfPoint (P : W.Point) :
+    (placeOfPointEquiv W).symm (placeOfPoint P) = P := by
+  classical
+  exact
+    (placeOfPointEquiv W).symm_apply_apply P
+
+omit [DecidableEq F] in
+theorem placeOfPoint_placeOfPointEquiv_symm (w : AlgebraicCurve.Place F W.FunctionField) :
+    placeOfPoint ((placeOfPointEquiv W).symm w) = w := by
+  classical
+  exact
+    (placeOfPointEquiv W).apply_symm_apply w
+
+end Gate
+
+section GeneralW
+
+universe u
+
+variable {F : Type u} [Field F] [IsAlgClosed F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic]
+
+theorem kw_point_infinite : Infinite W.Point := by
+  classical
+  rw [← not_finite_iff_infinite]
+  intro hfinite
+  have : Finite W.Point := hfinite
+  set N : ℕ := Nat.card W.Point with hN
+  have hNpos : 0 < N := Nat.card_pos
+  have htop : ∀ k : ℕ, N ∣ k → Submodule.torsionBy ℤ W.Point (k : ℤ) = ⊤ := by
+    rintro k ⟨c, rfl⟩
+    refine eq_top_iff.mpr fun P _ => ?_
+    rw [Submodule.mem_torsionBy_iff]
+    have hP : (N : ℤ) • P = 0 := by
+      rw [natCast_zsmul, hN]; exact card_nsmul_eq_zero'
+    rw [Nat.cast_mul, mul_comm, mul_smul, hP, smul_zero]
+  have hcard : ∀ k : ℕ, N ∣ k → k ≠ 0 → N = k ^ 2 := by
+    intro k hk hk0
+    have h : Nat.card (Submodule.torsionBy ℤ W.Point (k : ℤ)) = k ^ 2 :=
+      WeierstrassCurve.card_torsionBy_eq_sq_of_isAlgClosed W (n := k)
+        (Nat.cast_ne_zero.mpr hk0)
+    rw [htop k hk] at h
+    rwa [Nat.card_congr (Submodule.topEquiv (R := ℤ) (M := W.Point)).toEquiv, ← hN] at h
+  have h1 := hcard N dvd_rfl hNpos.ne'
+  have h2 := hcard (2 * N) (dvd_mul_left N 2) (by omega)
+  have h3 : N ^ 2 = (2 * N) ^ 2 := h1.symm.trans h2
+  have h4 : N ^ 2 = 0 := by nlinarith
+  exact hNpos.ne' (pow_eq_zero_iff (n := 2) (by norm_num) |>.mp h4)
+
+end GeneralW
+
+end WeierstrassCurve.Affine
+
+namespace ModularCurve
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_45662e8e.WeierstrassCurv\
+  e WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_45662e8e.WeierstrassCurve\
+  .Affine Polynomial AlgebraicCurve~Place.mem_of_ord_nonneg \
+  P2MW.S_OVERLONG_45662e8e.AlgebraicCurve"
+
+universe u
+
+attribute [local instance] Classical.propDecidable
+
+def KwD5PointMapOfPushforwardKerCard : Prop :=
+  ∀ (K : Type u) [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+    (E E' : WeierstrassCurve.Affine K) [E.IsElliptic] [GenusOnePlaceGate E] [AbelTheorem E]
+    [E'.IsElliptic] [GenusOnePlaceGate E'] [AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong K ι) (hN : NormFormulaAlong K ι hfin),
+    Nat.card ((pointMapOfPushforward ι hι hfin hN).ker) = finrankAlong K ι
+
+section Generic
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+variable [HasPrincipalDivisors K F']
+variable (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+
+theorem kw_fdn2_qephod_hend5_natCard_fiber_eq_finrank_of_unramified
+    (hfin : FiniteAlong K φ) (hsep : SeparableAlong K φ)
+    (hdegF : ∀ v : Place K F, v.deg = 1) (hdegF' : ∀ w : Place K F', w.deg = 1)
+    (v : Place K F)
+    (hv : letI := algebraAlong φ
+      haveI := isScalarTower_along φ
+      haveI := isIntegral_along φ hφ
+      ∀ w : Place K F', w.restrict F = v → w.ramificationIndex F = 1) :
+    Nat.card {w : Place K F' // w.restrictAlong φ hφ = v} = finrankAlong K φ := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  have : FiniteDimensional F F' := hfin
+  have : Algebra.IsSeparable F F' := hsep
+  have hsum := AlgebraicCurve.Place.sum_ramificationIndex_mul_inertiaDeg
+    (K := K) (F := F) (F' := F') v
+  have hcoll : ∀ w ∈ v.fiber F',
+      (w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ) = 1 := by
+    intro w hw
+    have hf : w.inertiaDeg F = 1 := by
+      have h := Place.deg_restrict_mul_inertiaDeg (F := F) w
+      rw [hdegF, hdegF', one_mul] at h
+      exact h
+    rw [hv w (Place.mem_fiber.mp hw), hf, Nat.cast_one, mul_one]
+  rw [Finset.sum_congr rfl hcoll, Finset.sum_const, nsmul_eq_mul, mul_one] at hsum
+  have hcard : (v.fiber F').card = finrankAlong K φ := by
+    have h : ((v.fiber F').card : ℤ) = (finrankAlong K φ : ℤ) := hsum
+    exact_mod_cast h
+  rw [← hcard]
+  refine Nat.card_congr ?_ |>.trans (Nat.card_eq_finsetCard _)
+  exact {
+    toFun := fun ⟨w, hw⟩ => ⟨w, Place.mem_fiber.mpr hw⟩
+    invFun := fun ⟨w, hw⟩ => ⟨w, Place.mem_fiber.mp hw⟩
+    left_inv := fun _ => rfl
+    right_inv := fun _ => rfl }
+
+end Generic
+
+def KwD5ExistsUnramifiedBetweenCurves : Prop :=
+  ∀ (K : Type u) [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+    (E E' : WeierstrassCurve.Affine K) [E.IsElliptic] [GenusOnePlaceGate E] [AbelTheorem E]
+    [E'.IsElliptic] [GenusOnePlaceGate E'] [AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (_hfin : FiniteAlong K ι),
+    letI := algebraAlong ι
+    haveI := isScalarTower_along ι
+    haveI := isIntegral_along ι hι
+    ∃ v : Place K E'.FunctionField,
+      ∀ w : Place K E.FunctionField,
+        w.restrict E'.FunctionField = v → w.ramificationIndex E'.FunctionField = 1
+
+def KwD5RestrictFiberEqKerPMOP : Prop :=
+  ∀ (K : Type u) [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+    (E E' : WeierstrassCurve.Affine K) [E.IsElliptic] [GenusOnePlaceGate E] [AbelTheorem E]
+    [E'.IsElliptic] [GenusOnePlaceGate E'] [AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[K] E.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong K ι) (hN : NormFormulaAlong K ι hfin)
+    (v : Place K E'.FunctionField),
+    Nat.card {w : Place K E.FunctionField // w.restrictAlong ι hι = v}
+      = Nat.card (AddMonoidHom.ker (pointMapOfPushforward ι hι hfin hN))
+
+theorem kw_fdn2_qephod_hend5_pmopKerCard_of_twoAtoms
+    (hUnram : KwD5ExistsUnramifiedBetweenCurves.{u})
+    (hFiberKer : KwD5RestrictFiberEqKerPMOP.{u}) :
+    KwD5PointMapOfPushforwardKerCard.{u} := by
+  intro K _ _ _ _ E E' _ _ _ _ _ _ ι hι hfin hN
+  obtain ⟨v, hv⟩ := hUnram K E E' ι hι hfin
+  have : HasPrincipalDivisors K E.FunctionField := hasPrincipalDivisors_functionField E
+  have hsep : SeparableAlong K ι := by
+    let := algebraAlong ι
+    have := isScalarTower_along ι
+    have : Module.Finite E'.FunctionField E.FunctionField := hfin
+    have : CharZero E'.FunctionField :=
+      charZero_of_injective_algebraMap (algebraMap K E'.FunctionField).injective
+    change Algebra.IsSeparable E'.FunctionField E.FunctionField
+    infer_instance
+  have h0 := kw_fdn2_qephod_hend5_natCard_fiber_eq_finrank_of_unramified ι hι hfin hsep
+    (fun v' => WeierstrassCurve.Affine.deg_eq_one (W := E') v')
+    (fun w => WeierstrassCurve.Affine.deg_eq_one (W := E) w)
+    v hv
+  have h2 := hFiberKer K E E' ι hι hfin hN v
+  exact h2.symm.trans h0
+
+theorem kw_fdn2_qephod_hend6_existsUnramifiedBetweenCurves_proved :
+    KwD5ExistsUnramifiedBetweenCurves.{u} := by
+  intro K _ _ _ _ E E' _ _ _ _ _ _ ι hι hfin
+  classical
+  let := algebraAlong ι
+  have := isScalarTower_along ι
+  have := isIntegral_along ι hι
+  have hfin' : Module.Finite E'.FunctionField E.FunctionField := hfin
+  have hcz : CharZero E'.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap K E'.FunctionField).injective
+  have hsep : Algebra.IsSeparable E'.FunctionField E.FunctionField := inferInstance
+  have hpdE : HasPrincipalDivisors K E.FunctionField := hasPrincipalDivisors_functionField E
+  have hpdE' : HasPrincipalDivisors K E'.FunctionField := hasPrincipalDivisors_functionField E'
+  obtain ⟨θ, hgen⟩ := Field.exists_primitive_element E'.FunctionField E.FunctionField
+  have hpmon : (minpoly E'.FunctionField θ).Monic :=
+    minpoly.monic (_root_.IsIntegral.of_finite E'.FunctionField θ)
+  have hg0 : aeval θ (derivative (minpoly E'.FunctionField θ)) ≠ 0 :=
+    (Algebra.IsSeparable.isSeparable E'.FunctionField θ).aeval_derivative_ne_zero
+      (minpoly.aeval E'.FunctionField θ)
+  let S₁ : Set (Place K E'.FunctionField) :=
+    ⋃ i ∈ (minpoly E'.FunctionField θ).support,
+      {v | (minpoly E'.FunctionField θ).coeff i ∉ v.toValuationSubring}
+  let S₂ : Set (Place K E.FunctionField) :=
+    {w | w.ord (aeval θ (derivative (minpoly E'.FunctionField θ))) ≠ 0}
+  have hS₁fin : S₁.Finite :=
+    Set.Finite.biUnion (minpoly E'.FunctionField θ).support.finite_toSet fun i _ =>
+      finite_setOf_notMem_toValuationSubring (K := K) ((minpoly E'.FunctionField θ).coeff i)
+  have hS₂fin : S₂.Finite :=
+    finite_setOf_ord_ne_zero_of_hasPrincipalDivisors (K := K) hg0
+  have hSfin : (S₁ ∪ (fun w => w.restrict E'.FunctionField) '' S₂).Finite :=
+    hS₁fin.union (hS₂fin.image _)
+  have : Infinite (Place K E'.FunctionField) :=
+    (placeOfPointEquiv E').symm.infinite_iff.mpr (kw_point_infinite (W := E'))
+  obtain ⟨v, hv⟩ := hSfin.infinite_compl.nonempty
+  simp only [Set.mem_compl_iff, Set.mem_union, not_or] at hv
+  obtain ⟨hvS₁, hvS₂⟩ := hv
+  refine ⟨v, fun w hw => ?_⟩
+  by_contra hram
+  have hcoeff : ∀ i, (minpoly E'.FunctionField θ).coeff i ∈ v.toValuationSubring := by
+    intro i
+    by_contra hni
+    have hci : (minpoly E'.FunctionField θ).coeff i ≠ 0 :=
+      fun h => hni (h ▸ v.toValuationSubring.zero_mem)
+    exact hvS₁ (Set.mem_biUnion (Finset.mem_coe.mpr (mem_support_iff.mpr hci)) hni)
+  obtain ⟨Q, hQmap, -, hQmon⟩ :=
+    lifts_and_degree_eq_and_monic (mem_lifts_of_integralAt (fun i => hcoeff i)) hpmon
+  have hθint : @_root_.IsIntegral v.toValuationSubring E.FunctionField _ _
+      (Place.valuationSubringAlgebra E.FunctionField v) θ := by
+    refine ⟨Q, hQmon, ?_⟩
+    rw [RingHom.algebraMap_toAlgebra, ← Polynomial.eval₂_map, hQmap]
+    exact minpoly.aeval E'.FunctionField θ
+  have hpos := Place.ord_deriv_pos_of_ramificationIndex_ne_one
+    (K := K) (F := E'.FunctionField) (F' := E.FunctionField)
+    (v := v) (w := w) hw θ hgen hθint hram
+  exact hvS₂ ⟨w, hpos.ne', hw⟩
+
+section GeomMorphBC
+
+variable {K : Type u} [Field K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable {E E' : Affine K} [E.IsElliptic] [GenusOnePlaceGate E] [AbelTheorem E]
+  [E'.IsElliptic] [GenusOnePlaceGate E'] [AbelTheorem E']
+variable (ι : E'.FunctionField →ₐ[K] E.FunctionField)
+variable (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong K ι) (hN : NormFormulaAlong K ι hfin)
+
+def kw_fdn2_qephod_hend7_geomMorphBC : E.Point → E'.Point :=
+  fun P => (placeOfPointEquiv E').symm ((placeOfPoint P).restrictAlong ι hι)
+
+local notation "gBC" => kw_fdn2_qephod_hend7_geomMorphBC ι hι
+
+omit [DecidableEq K] [IsAlgClosed K] [CharZero K] [WeierstrassCurve.IsElliptic E] [E.AbelTheorem]
+  [WeierstrassCurve.IsElliptic E'] [E'.AbelTheorem] in
+theorem kw_fdn2_qephod_hend7_placeOfPoint_geomMorphBC (P : E.Point) :
+    (placeOfPoint P).restrictAlong ι hι = placeOfPoint (gBC P) :=
+  (placeOfPoint_placeOfPointEquiv_symm E' _).symm
+
+omit [DecidableEq K] [IsAlgClosed K] [CharZero K] [WeierstrassCurve.IsElliptic E] [E.AbelTheorem]
+  [WeierstrassCurve.IsElliptic E'] [E'.AbelTheorem] in
+theorem kw_fdn2_qephod_hend7_pushforwardDegZero_pointDivisor_geomMorphBC (P : E.Point) :
+    Pic0.pushforwardAlongDegZero ι hι (pointDivisor P)
+      = pointDivisor (gBC P) - pointDivisor (gBC 0) := by
+  refine Subtype.ext ?_
+  rw [Pic0.coe_pushforwardAlongDegZero, coe_pointDivisor, map_sub,
+    pushforwardAlong_single_eq ι hι, pushforwardAlong_single_eq ι hι,
+    kw_fdn2_qephod_hend7_placeOfPoint_geomMorphBC ι hι P,
+    kw_fdn2_qephod_hend7_placeOfPoint_geomMorphBC ι hι 0]
+  push_cast
+  rw [coe_pointDivisor, coe_pointDivisor, sub_sub_sub_cancel_right]
+
+include hfin in
+omit [DecidableEq K] [IsAlgClosed K] [CharZero K] [WeierstrassCurve.IsElliptic E] [E.AbelTheorem]
+  [WeierstrassCurve.IsElliptic E'] [E'.AbelTheorem] in
+theorem kw_fdn2_qephod_hend7_pushforwardHom_pointClass_eq_sub (P : E.Point) :
+    Pic0.pushforwardAlongHom ι hι hfin hN
+        (pointClass P)
+      = pointClass (gBC P) - pointClass (gBC 0) := by
+  change Pic0.pushforwardAlongHom ι hι hfin _ (Pic0.mk (pointDivisor P))
+      = Pic0.mk (pointDivisor (gBC P)) - Pic0.mk (pointDivisor (gBC 0))
+  rw [Pic0.pushforwardAlongHom_mk,
+    kw_fdn2_qephod_hend7_pushforwardDegZero_pointDivisor_geomMorphBC ι hι P]
+  rfl
+
+include hfin in
+omit [IsAlgClosed K] [CharZero K] [WeierstrassCurve.IsElliptic E]
+  [WeierstrassCurve.IsElliptic E'] in
+theorem kw_fdn2_qephod_hend7_pmop_eq_geomMorphBC_sub (P : E.Point) :
+    pointMapOfPushforward ι hι hfin hN P
+      = gBC P - gBC 0 := by
+  rw [pointMapOfPushforward_apply,
+    kw_fdn2_qephod_hend7_pushforwardHom_pointClass_eq_sub ι hι hfin hN P, map_sub,
+    genusOnePic0Equiv_apply, genusOnePic0Equiv_apply, pic0ToPoint_pointClass,
+    pic0ToPoint_pointClass]
+
+def kw_fdn2_qephod_hend7_restrictAlong_fiber_equiv_pmop_fiber
+    (v : Place K E'.FunctionField) :
+    {w : Place K E.FunctionField // w.restrictAlong ι hι = v}
+      ≃ {P : E.Point //
+          pointMapOfPushforward ι hι hfin hN P
+            = (placeOfPointEquiv E').symm v - gBC 0} where
+  toFun := fun ⟨w, hw⟩ => ⟨(placeOfPointEquiv E).symm w, by
+    rw [kw_fdn2_qephod_hend7_pmop_eq_geomMorphBC_sub ι hι hfin hN, sub_left_inj]
+    refine placeOfPoint_injective ?_
+    rw [← kw_fdn2_qephod_hend7_placeOfPoint_geomMorphBC ι hι,
+      placeOfPoint_placeOfPointEquiv_symm, hw, placeOfPoint_placeOfPointEquiv_symm]⟩
+  invFun := fun ⟨P, hP⟩ => ⟨placeOfPoint P, by
+    rw [kw_fdn2_qephod_hend7_placeOfPoint_geomMorphBC ι hι P,
+      ← placeOfPoint_placeOfPointEquiv_symm E' v]
+    congr 1
+    have h : gBC P - gBC 0
+        = (placeOfPointEquiv E').symm v - gBC 0 :=
+      (kw_fdn2_qephod_hend7_pmop_eq_geomMorphBC_sub ι hι hfin hN P).symm.trans hP
+    exact sub_left_injective h⟩
+  left_inv := fun ⟨w, _⟩ => Subtype.ext (placeOfPoint_placeOfPointEquiv_symm E w)
+  right_inv := fun ⟨P, _⟩ => Subtype.ext (placeOfPointEquiv_symm_placeOfPoint E P)
+
+def kw_fdn2_qephod_hend7_pmop_fiber_equiv_ker (R : E'.Point) :
+    {P : E.Point //
+        pointMapOfPushforward ι hι hfin hN P = R}
+      ≃ (AddMonoidHom.ker
+          (pointMapOfPushforward ι hι hfin hN)) :=
+  let φ := pointMapOfPushforward ι hι hfin hN
+  let hsurj : Function.Surjective φ :=
+    pointMapOfPushforward_surjective E E' ι hι hfin hN
+  let P₀ : E.Point := (hsurj R).choose
+  have hP₀ : φ P₀ = R := (hsurj R).choose_spec
+  { toFun := fun ⟨P, hP⟩ => ⟨P - P₀, by
+      change φ (P - P₀) = 0
+      rw [map_sub, hP, hP₀, sub_self]⟩
+    invFun := fun ⟨Q, hQ⟩ => ⟨Q + P₀, by
+      change φ (Q + P₀) = R
+      have hQ' : φ Q = 0 := hQ
+      rw [map_add, hQ', zero_add, hP₀]⟩
+    left_inv := fun ⟨P, _⟩ => Subtype.ext (sub_add_cancel P P₀)
+    right_inv := fun ⟨Q, _⟩ => Subtype.ext (add_sub_cancel_right Q P₀) }
+
+end GeomMorphBC
+
+theorem kw_fdn2_qephod_hend7_restrictFiberEqKerPMOP_proved :
+    KwD5RestrictFiberEqKerPMOP.{u} := by
+  intro K _ _ _ _ E E' _ _ _ _ _ _ ι hι hfin hN v
+  exact Nat.card_congr
+    ((kw_fdn2_qephod_hend7_restrictAlong_fiber_equiv_pmop_fiber ι hι hfin hN v).trans
+      (kw_fdn2_qephod_hend7_pmop_fiber_equiv_ker ι hι hfin hN _))
+
+theorem kw_fdn2_qephod_hend7_pmopKerCard_proved :
+    KwD5PointMapOfPushforwardKerCard.{u} :=
+  kw_fdn2_qephod_hend5_pmopKerCard_of_twoAtoms
+    kw_fdn2_qephod_hend6_existsUnramifiedBetweenCurves_proved
+    kw_fdn2_qephod_hend7_restrictFiberEqKerPMOP_proved
+
+end ModularCurve
+end
+
+p2m_open "AlgebraicCurve~Place.mem_of_ord_nonneg\
+  " in
+open _root_.WeierstrassCurve
+  _root_.P2MW.S_OVERLONG_45662e8e.WeierstrassCurve
+  _root_.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_45662e8e.WeierstrassCurve.Affine
+  _root_.P2MW.S_OVERLONG_45662e8e.AlgebraicCurve
+  in
+universe u in
+theorem solution
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    (E E' : WeierstrassCurve.Affine F) [E.IsElliptic] [GenusOnePlaceGate E] [AbelTheorem E]
+    [E'.IsElliptic] [GenusOnePlaceGate E'] [AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[F] E.FunctionField) (hι : ι.toRingHom.IsIntegral)
+    (hfin : FiniteAlong F ι) (hN : NormFormulaAlong F ι hfin) :
+    Nat.card (pointMapOfPushforward ι hι hfin hN).ker = finrankAlong F ι :=
+  ModularCurve.kw_fdn2_qephod_hend7_pmopKerCard_proved F E E' ι hι hfin hN
+
+end S_OVERLONG_45662e8e
+end P2MW
+export P2MW.S_OVERLONG_45662e8e (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+universe u
+theorem WeierstrassCurve.Affine.natCard_ker_pointMapOfPushforward_eq_finrankAlong
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    (E E' : WeierstrassCurve.Affine F) [E.IsElliptic] [GenusOnePlaceGate E] [AbelTheorem E]
+    [E'.IsElliptic] [GenusOnePlaceGate E'] [AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[F] E.FunctionField) (hι : ι.toRingHom.IsIntegral)
+    (hfin : FiniteAlong F ι) (hN : NormFormulaAlong F ι hfin) :
+    Nat.card (pointMapOfPushforward ι hι hfin hN).ker = finrankAlong F ι :=
+  solution E E' ι hι hfin hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_ncard_fibSet.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_ncard_fibSet.lean
new file mode 100644
index 0000000000..32170ca6d4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_ncard_fibSet.lean
@@ -0,0 +1,150 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.ncard_fibSet
+(2481079f-7b1c-5850-82db-2e6507b11804) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 25061203-dd50-54dd-8601-f9e2afb6f875
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_WeilPairingFun
+
+import Mathlib.Data.Set.Card
+import Mathlib.Algebra.BigOperators.Group.Finset.Piecewise
+import Mathlib.Tactic.Ring
+import Mathlib.Tactic.FieldSimp
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsion_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_exists_zsmul_eq_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_fibSet_finite
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Fibres of [n] on an elliptic curve have n² points
+
+Theorem statement: `WeierstrassCurve.Affine.ncard_fibSet` (`2481079f-7b1c-5850-82db-2e6507b11804`),
+by Claude, 2026-09-05.
+
+Proof: submission `25061203-dd50-54dd-8601-f9e2afb6f875`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra, $K$ algebraically closed and equipped with
+decidable equality, and let $W$ be a Weierstrass curve over $F$ which is elliptic (i.e. carries the
+`IsElliptic` instance, so its discriminant is a unit). Let $n$ be a natural number whose image in
+$K$ is nonzero, and let $Q$ be a point of the affine curve obtained from $W$ by base change to $K$,
+written $(W⁄K)$, in the sense of the group of affine points (rational points together with the point
+at infinity). The assertion is that the set $\mathrm{fibSet}\ W\ K\ n\ Q$, by definition the set of
+those points $P$ of $(W⁄K)$ with $(n : \mathbb{Z}) \bullet P = Q$ for the integer image of $n$
+acting through the group structure, has `Set.ncard` equal to $n^2$. Thus every fibre of
+multiplication by $n$ on the group of points of an elliptic curve over an algebraically closed field
+of residue characteristic not dividing $n$ consists of exactly $n^2$ points; in particular the
+natural-number cardinality is finite and nonzero.
+
+This is the standard counting statement underlying the construction of the Weil pairing: $[n]$ is
+surjective on the points of an elliptic curve over an algebraically closed field and its kernel
+$E[n]$ has order $n^2$ when $n$ is invertible, so each fibre is a coset of $E[n]$. It is used in the
+project's development of the Weil pairing and of the associated valuation computations, being cited
+by
+[`WeierstrassCurve.Affine.exists_smul_basis_eq_algebraMap_mul_weilNum_of_valuationSubring`]
+(thm.html#WeierstrassCurve.Affine.exists_smul_basis_eq_algebraMap_mul_weilNum_of_valuationSubring)
+and
+[`WeierstrassCurve.Affine.valuation_transEquiv_weilFun`]
+(thm.html#WeierstrassCurve.Affine.valuation_transEquiv_weilFun).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_ncard_fibSet.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_ncard_fibSet
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain IsDedekindDomain.HeightOneSpectrum
+  WithZero
+open scoped nonZeroDivisors
+
+namespace WeilDiv
+
+variable {F : Type*} [Field F] {K : Type*} [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K]
+  (W : WeierstrassCurve F) [W.IsElliptic]
+
+theorem torsion_finite {n : ℕ} (hn : (n : K) ≠ 0) :
+    {S : (W⁄K).Point | (n : ℤ) • S = 0}.Finite := by
+  have hcard := WeierstrassCurve.card_torsion_of_isAlgClosed (K := K) W hn
+  have hn0 : n ≠ 0 := by rintro rfl; exact hn Nat.cast_zero
+  have : Finite (Submodule.torsionBy ℤ (W⁄K).Point n) :=
+    Nat.finite_of_card_ne_zero (by rw [hcard]; exact pow_ne_zero 2 hn0)
+  have hset : {S : (W⁄K).Point | (n : ℤ) • S = 0} =
+      ((Submodule.torsionBy ℤ (W⁄K).Point n : Submodule ℤ (W⁄K).Point) : Set (W⁄K).Point) := by
+    ext S
+    rw [Set.mem_ofPred_eq, SetLike.mem_coe, Submodule.mem_torsionBy_iff]
+  rw [hset]
+  exact Set.toFinite _
+
+theorem card_torsion_toFinset {n : ℕ} (hn : (n : K) ≠ 0) :
+    (torsion_finite W hn).toFinset.card = n ^ 2 := by
+  rw [← WeierstrassCurve.card_torsion_of_isAlgClosed (K := K) W hn, ←
+    Nat.card_eq_card_finite_toFinset]
+  have hset : {S : (W⁄K).Point | (n : ℤ) • S = 0} =
+      ((Submodule.torsionBy ℤ (W⁄K).Point n : Submodule ℤ (W⁄K).Point) : Set (W⁄K).Point) := by
+    ext S
+    rw [Set.mem_ofPred_eq, SetLike.mem_coe, Submodule.mem_torsionBy_iff]
+  rw [hset]
+  rfl
+
+theorem card_fibSet_toFinset {n : ℕ} (hn : (n : K) ≠ 0) (Q : (W⁄K).Point) :
+    (WeierstrassCurve.Affine.fibSet_finite W hn Q).toFinset.card = n ^ 2 := by
+  classical
+  have : (W⁄K).IsElliptic := by
+    dsimp only [Affine.baseChange, WeierstrassCurve.baseChange]; infer_instance
+  have hn0 : (n : ℤ) ≠ 0 := by
+    have : n ≠ 0 := by rintro rfl; exact hn Nat.cast_zero
+    exact_mod_cast this
+  obtain ⟨P₀, hP₀⟩ := WeierstrassCurve.Affine.Point.exists_zsmul_eq_of_isAlgClosed (W⁄K) hn0 Q
+  set s := (WeierstrassCurve.Affine.fibSet_finite W hn Q).toFinset with hs
+  set t := (torsion_finite W hn).toFinset with ht
+  have hts : s = t.image (· + P₀) := by
+    ext P
+    simp only [hs, ht, Set.Finite.mem_toFinset, mem_fibSet, Finset.mem_image, Set.mem_ofPred_eq]
+    constructor
+    · intro hP
+      exact ⟨P - P₀, by rw [smul_sub, hP, hP₀, sub_self], sub_add_cancel P P₀⟩
+    · rintro ⟨S, hS, rfl⟩
+      rw [smul_add, hS, hP₀, zero_add]
+  rw [hts, Finset.card_image_of_injective _ (add_left_injective P₀), card_torsion_toFinset W hn]
+
+end WeilDiv
+
+theorem solution {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K]
+    (W : WeierstrassCurve F) [W.IsElliptic] {n : ℕ} (hn : (n : K) ≠ 0) (Q : (W⁄K).Point) :
+    (fibSet W K n Q).ncard = n ^ 2 := by
+  rw [Set.ncard_eq_toFinset_card _ (WeierstrassCurve.Affine.fibSet_finite W hn Q)]
+  exact WeilDiv.card_fibSet_toFinset W hn Q
+
+end S_WeierstrassCurve_Affine_ncard_fibSet
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_ncard_fibSet (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain WithZero
+
+theorem WeierstrassCurve.Affine.ncard_fibSet {F K : Type*} [Field F] [Field K] [Algebra F K]
+    [DecidableEq K] [IsAlgClosed K] (W : WeierstrassCurve F) [W.IsElliptic] {n : ℕ}
+    (hn : (n : K) ≠ 0) (Q : (W⁄K).Point) :
+    (fibSet W K n Q).ncard = n ^ 2 :=
+  solution W hn Q
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum.lean
new file mode 100644
index 0000000000..254a9149f8
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum.lean
@@ -0,0 +1,105 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.placeOfPoint_some_eq_ofHeightOneSpectrum
+(e603ba18-9cab-5af3-96f5-210df63b3924) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 06137338-e725-591a-840c-2b95746b1656
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_eq_ofHeightOneSpectrum_of_XClass_mem_nonunits_of_YClass_mem_nonunits
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Centred gate: place of an affine point is the (x,y)-adic place
+
+Theorem statement: `WeierstrassCurve.Affine.placeOfPoint_some_eq_ofHeightOneSpectrum`
+(`e603ba18-9cab-5af3-96f5-210df63b3924`), by Claude, 2026-09-05.
+
+Proof: submission `06137338-e725-591a-840c-2b95746b1656`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field and let $W$ be an affine Weierstrass curve over $F$ whose coordinate ring
+`W.CoordinateRing` is a Dedekind domain. Assume $W$ carries a `GenusOnePlaceGate`, that is, a
+bijection `pointEquivPlace` between the point set `W.Point` and the set of places of the function
+field `W.FunctionField` over $F$ — where a place is a valuation subring of `W.FunctionField`
+containing the image of $F$, distinct from the whole field, and whose ideals are all principal —
+together with the assertion that every such place has degree $1$; write `placeOfPoint` for this
+bijection. Assume moreover that the gate is centred (`GenusOnePlaceGate.IsCentred`): for every $x,y
+\in F$ with $W$ nonsingular at $(x,y)$, the images in `W.FunctionField` of the classes
+`CoordinateRing.XClass W x` and `CoordinateRing.YClass W (Polynomial.C y)` both lie in the nonunits
+of the valuation subring of `placeOfPoint (Point.some x y h)`. Then, given $x,y \in F$ with `h :
+W.Nonsingular x y` and given a height-one prime $w$ of `W.CoordinateRing` whose underlying ideal
+equals `CoordinateRing.XYIdeal W x (Polynomial.C y)`, the place attached by the gate to the affine
+point $(x,y)$ coincides with `Place.ofHeightOneSpectrum w`, the place given by the valuation subring
+of the $w$-adic valuation on `W.FunctionField`.
+
+This identifies the abstract point–place dictionary of a centred genus-one gate with the geometric
+one on affine points: the place of $(x,y)$ is the adic place of the maximal ideal $(X-x, Y-y)$ of
+the coordinate ring. The prime $w$ appears as a hypothesis rather than being constructed, so that no
+primality argument enters the statement; callers supply it from the maximality and nonvanishing of
+`CoordinateRing.XYIdeal`. It is used in the extensionality result for genus-one gates and,
+downstream, in the comparison of points and places for period pairs.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum
+
+open AlgebraicCurve WeierstrassCurve WeierstrassCurve.Affine
+
+universe u
+
+theorem solution
+    {F : Type u} [Field F] {W : WeierstrassCurve.Affine F}
+    [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [IsDedekindDomain W.CoordinateRing]
+    {x y : F} (h : W.Nonsingular x y)
+    (w : IsDedekindDomain.HeightOneSpectrum W.CoordinateRing)
+    (hw : w.asIdeal = CoordinateRing.XYIdeal W x (Polynomial.C y)) :
+    placeOfPoint (Point.some x y h) = Place.ofHeightOneSpectrum (K := F) w := by
+  classical
+  exact
+    AlgebraicCurve.Place.eq_ofHeightOneSpectrum_of_XClass_mem_nonunits_of_YClass_mem_nonunits
+      (placeOfPoint (Point.some x y h))
+      (GenusOnePlaceGate.IsCentred.algebraMap_XClass_mem_nonunits h)
+      (GenusOnePlaceGate.IsCentred.algebraMap_YClass_mem_nonunits h) w hw
+
+end S_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve WeierstrassCurve WeierstrassCurve.Affine
+
+universe u
+theorem WeierstrassCurve.Affine.placeOfPoint_some_eq_ofHeightOneSpectrum
+    {F : Type u} [Field F] {W : WeierstrassCurve.Affine F}
+    [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W] [IsDedekindDomain W.CoordinateRing]
+    {x y : F} (h : W.Nonsingular x y)
+    (w : IsDedekindDomain.HeightOneSpectrum W.CoordinateRing)
+    (hw : w.asIdeal = CoordinateRing.XYIdeal W x (Polynomial.C y)) :
+    placeOfPoint (Point.some x y h) = Place.ofHeightOneSpectrum (K := F) w := by
+  classical
+  exact
+    solution h w hw
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_pointMapOfPushforward_surjective.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_pointMapOfPushforward_surjective.lean
new file mode 100644
index 0000000000..b1dd808949
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_pointMapOfPushforward_surjective.lean
@@ -0,0 +1,131 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.pointMapOfPushforward_surjective
+(da89fd8d-d346-53a0-8175-51c3792e69dc) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 288e189f-bc82-5ffd-85ae-5c9ae8f204d1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_restrictAlong_surjective
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Pushforward map on points of an elliptic curve is surjective
+
+Theorem statement: `WeierstrassCurve.Affine.pointMapOfPushforward_surjective`
+(`da89fd8d-d346-53a0-8175-51c3792e69dc`), by Claude, 2026-09-05.
+
+Proof: submission `288e189f-bc82-5ffd-85ae-5c9ae8f204d1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field of characteristic zero and let $E$, $E'$ be affine
+Weierstrass curves over $F$, both elliptic, and both equipped with the two genus-one gates: a
+bijection of the point set with the set of places of the function field over $F$ (a place being a
+proper valuation subring of the function field which contains the image of $F$ and is a principal
+ideal ring) under which every place has degree $1$, and the Abel-type property that a divisor of
+degree $0$ is principal, i.e. of the form $v \mapsto v.\mathrm{ord}(f)$ for some $f \neq 0$, exactly
+when the sum in the group of points of its places, weighted by their multiplicities, vanishes. Let
+$\iota \colon F(E') \to F(E)$ be an $F$-algebra map whose underlying ring map is integral, assume
+$F(E)$ is a finite module over $F(E')$ via $\iota$, and assume the pushforward norm formula along
+$\iota$: for every nonzero $f \in F(E)$ and every divisor $D$ on $F(E)$ with $D(w) =
+w.\mathrm{ord}(f)$ at all places $w$, and every place $v$ of $F(E')$, the pushforward of $D$ takes
+at $v$ the value $v.\mathrm{ord}(\mathrm{N}_{F(E)/F(E')}(f))$. Then the group homomorphism $E(F) \to
+E'(F)$ obtained by transporting the pushforward of degree-zero divisor classes along $\iota$ through
+the genus-one identifications $\mathrm{Pic}^0 \cong \mathrm{Point}$ is surjective.
+
+This is the function-field form of the statement that a nonconstant morphism of elliptic curves over
+an algebraically closed field is surjective on points (Silverman, III.4.10(a)), here for the map on
+points induced by divisor pushforward along an embedding of function fields. It feeds the
+computation of the kernel of that map, in particular its cardinality in terms of the degree of
+$F(E)/F(E')$, and thence the comparison of isogeny kernels used downstream.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_pointMapOfPushforward_surjective.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_pointMapOfPushforward_surjective
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+universe u
+
+theorem solution
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    (E E' : WeierstrassCurve.Affine F) [E.IsElliptic] [GenusOnePlaceGate E] [AbelTheorem E]
+    [E'.IsElliptic] [GenusOnePlaceGate E'] [AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[F] E.FunctionField) (hι : ι.toRingHom.IsIntegral)
+    (hfin : FiniteAlong F ι) (hN : NormFormulaAlong F ι hfin) :
+    Function.Surjective (pointMapOfPushforward ι hι hfin hN) := by
+  classical
+  have hsep : SeparableAlong F ι := by
+    let := algebraAlong ι
+    have : Module.Finite E'.FunctionField E.FunctionField := hfin
+    have : CharZero E'.FunctionField :=
+      charZero_of_injective_algebraMap (algebraMap F E'.FunctionField).injective
+    change Algebra.IsSeparable E'.FunctionField E.FunctionField
+    exact Algebra.IsSeparable.of_integral E'.FunctionField E.FunctionField
+  choose s hs using AlgebraicCurve.Place.restrictAlong_surjective ι hι hfin hsep
+  have hpush : Function.Surjective (Pic0.pushforwardAlongHom ι hι hfin hN) := by
+    intro c'
+    obtain ⟨D', rfl⟩ := Pic0.mk_surjective c'
+    let D : Divisor F E.FunctionField := Finsupp.mapDomain s (D' : Divisor F E'.FunctionField)
+    have hD : Divisor.pushforwardAlong ι hι D = (D' : Divisor F E'.FunctionField) := by
+      change Divisor.pushforwardAlong ι hι (Finsupp.mapDomain s (D' : Divisor F E'.FunctionField)) =
+        _
+      rw [Finsupp.mapDomain, map_finsuppSum]
+      conv_rhs => rw [← Finsupp.sum_single (D' : Divisor F E'.FunctionField)]
+      refine Finsupp.sum_congr (fun v _ => ?_)
+      have hsv : (s v).restrictAlong ι hι = v := hs v
+      rw [pushforwardAlong_single_eq ι hι (s v), hsv]
+    have hD0 : D ∈ Divisor.degZero (K := F) (F := E.FunctionField) := by
+      rw [Divisor.mem_degZero, ← Divisor.degree_pushforwardAlong ι hι D, hD]
+      exact Divisor.mem_degZero.mp D'.2
+    refine ⟨Pic0.mk ⟨D, hD0⟩, ?_⟩
+    rw [Pic0.pushforwardAlongHom_mk]
+    congr 1
+    exact Subtype.ext (by rw [Pic0.coe_pushforwardAlongDegZero]; exact hD)
+  intro Q
+  obtain ⟨c, hc⟩ := hpush ((genusOnePic0Equiv E').symm Q)
+  refine ⟨genusOnePic0Equiv E c, ?_⟩
+  rw [pointMapOfPushforward_apply, ← genusOnePic0Equiv_symm_apply, AddEquiv.symm_apply_apply, hc,
+    AddEquiv.apply_symm_apply]
+
+end S_WeierstrassCurve_Affine_pointMapOfPushforward_surjective
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_pointMapOfPushforward_surjective (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+universe u
+theorem WeierstrassCurve.Affine.pointMapOfPushforward_surjective
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    (E E' : WeierstrassCurve.Affine F) [E.IsElliptic] [GenusOnePlaceGate E] [AbelTheorem E]
+    [E'.IsElliptic] [GenusOnePlaceGate E'] [AbelTheorem E']
+    (ι : E'.FunctionField →ₐ[F] E.FunctionField) (hι : ι.toRingHom.IsIntegral)
+    (hfin : FiniteAlong F ι) (hN : NormFormulaAlong F ι hfin) :
+    Function.Surjective (pointMapOfPushforward ι hι hfin hN) :=
+  solution E E' ι hι hfin hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_mulPull_le_of_ne_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_mulPull_le_of_ne_zero.lean
new file mode 100644
index 0000000000..98bfd0dbf5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_mulPull_le_of_ne_zero.lean
@@ -0,0 +1,222 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.valuation_mulPull_le_of_ne_zero
+(1c1793dd-ad0d-5049-857d-4a582e939454) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 572283c9-a388-5ac5-a4f4-bf6880fdcc02
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsion_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_exists_zsmul_some_eq_some_baseChange
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_smul_some_eq_zero_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_evalEval_psi_sq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Valuations along the multiplication-by-n pull-back of functions
+
+Theorem statement: `WeierstrassCurve.Affine.valuation_mulPull_le_of_ne_zero`
+(`1c1793dd-ad0d-5049-857d-4a582e939454`), by Claude, 2026-09-05.
+
+Proof: submission `572283c9-a388-5ac5-a4f4-bf6880fdcc02`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra, $K$ algebraically closed and equipped with
+decidable equality, and let $W$ be a Weierstrass curve over $F$ which is elliptic; the coordinate
+ring of the base-changed affine curve `W⁄K` is assumed to be a Dedekind domain (these and the
+remaining typeclass assumptions are summarised here). Let $n$ be a natural number whose image in $K$
+is nonzero, let $P$ be a point of `(W⁄K).Point` with $P \neq 0$ and $(n : \mathbb{Z}) \cdot P \neq
+0$, let $h$ be an element of the function field `(W⁄K).FunctionField`, and let $k$ be a natural
+number. For a nonzero point $Q$, `placeOf W K Q` denotes the height-one prime of the coordinate ring
+of `W⁄K` given by the ideal `CoordinateRing.XYIdeal (W⁄K) Q.xc (C Q.yc)` cut out by the coordinates
+of $Q$ (maximal, hence prime, and nonzero). The hypothesis is that the valuation of $h$ at the place
+of $(n : \mathbb{Z}) \cdot P$ is at most $\mathrm{exp}(-k)$, i.e. at most the image of $-k$ under
+the embedding of $\mathbb{Z}$ into the multiplicative value group with zero. The conclusion is that
+the valuation at the place of $P$ of `mulPull W K n h` is also at most $\mathrm{exp}(-k)$, where
+`mulPull W K n` is the $K$-algebra endomorphism of `(W⁄K).FunctionField` obtained, when `MulGood W K
+n` holds (that is, $n$ times the generic point is nonzero and is not the base change of any
+$K$-point), by lifting the associated injective point homomorphism to the fraction field, and is the
+identity otherwise.
+
+This is the statement that pull-back along multiplication by $n$ does not decrease the order of
+vanishing: a function vanishing to order at least $k$ at $nP$ pulls back to a function vanishing to
+order at least $k$ at $P$. It supplies the compatibility between $[n]^{*}$ and the adic valuations
+at closed points that is required in the construction of the pairing on $n$-torsion and in the proof
+of its non-degeneracy, and is used by
+[`WeierstrassCurve.Affine.eq_zero_of_forall_weilPairing0_eq_one`]
+(thm.html#WeierstrassCurve.Affine.eq_zero_of_forall_weilPairing0_eq_one),
+[`WeierstrassCurve.Affine.exists_isogenyEndDatum_restrictAlong_placeOfPoint_eq_smul`]
+(thm.html#WeierstrassCurve.Affine.exists_isogenyEndDatum_restrictAlong_placeOfPoint_eq_smul)
+and
+[`WeierstrassCurve.exists_pairing_torsionBy`](thm.html#WeierstrassCurve.exists_pairing_torsionBy).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_valuation_mulPull_le_of_ne_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_valuation_mulPull_le_of_ne_zero
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_WeierstrassCurve_Affine_valuation_mulPull_le_of_ne_zero.WeierstrassCurve \
+  WeierstrassCurve.Affine \
+  P2MW.S_WeierstrassCurve_Affine_valuation_mulPull_le_of_ne_zero.WeierstrassCurve.Affine \
+  Polynomial IsDedekindDomain WithZero"
+open scoped Polynomial.Bivariate
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "baseChange_ΨSq Affine map_map map baseChange_Φ ΨSq map_baseChange \
+  Affine.Point baseChange_ψ map_injective baseChange Affine.genericPoint \
+  card_torsion_of_isAlgClosed Affine.Point.exists_zsmul_some_eq_some_baseChange \
+  Affine.Point.smul_some_eq_zero_iff Affine.evalEval_psi_sq"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.map_baseChange CoordinateRing map baseChange \
+  Point.some Point.map_injective FunctionField Point map_baseChange Point.map polynomial \
+  Point.xc_some Point.yc_some genericX genericY generic_nonsingular genericPoint transPull \
+  map_transPull_genericPoint MulGood mulPull infinite_point placeOf valuation_mulPull_le \
+  Point.exists_zsmul_some_eq_some_baseChange Point.smul_some_eq_zero_iff evalEval_psi_sq"
+namespace PullEasy
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+variable {F : Type*} {K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K]
+  (W : WeierstrassCurve F) [W.IsElliptic]
+
+theorem not_forall_zsmul_eq_zero {n : ℤ} (hn : (n : K) ≠ 0) : ¬ ∀ S : (W⁄K).Point, n • S = 0 := by
+  intro hall
+  obtain ⟨m, hm⟩ : ∃ m : ℕ, n = m ∨ n = -m := ⟨n.natAbs, Int.natAbs_eq n⟩
+  have hmK : (m : K) ≠ 0 := by
+    intro h0
+    apply hn
+    rcases hm with rfl | rfl
+    · rw [Int.cast_natCast, h0]
+    · rw [Int.cast_neg, Int.cast_natCast, h0, neg_zero]
+  have hcard := WeierstrassCurve.card_torsion_of_isAlgClosed (K := K) W hmK
+  have htop : Submodule.torsionBy ℤ (W⁄K).Point m = ⊤ := by
+    rw [eq_top_iff]
+    intro S _
+    rw [Submodule.mem_torsionBy_iff]
+    rcases hm with rfl | rfl
+    · exact hall S
+    · have := hall S
+      rwa [neg_smul, neg_eq_zero] at this
+  rw [htop, Nat.card_congr (Submodule.topEquiv (R := ℤ) (M := (W⁄K).Point)).toEquiv] at hcard
+  have hm0 : m ≠ 0 := by rintro rfl; exact hmK Nat.cast_zero
+  have : Finite (W⁄K).Point := Nat.finite_of_card_ne_zero (by rw [hcard]; exact pow_ne_zero 2 hm0)
+  exact (infinite_point W K).not_finite ‹_›
+
+theorem zsmul_genericPoint_good {n : ℤ} (hn : (n : K) ≠ 0) : MulGood W K n := by
+  constructor
+  · intro h0
+    apply not_forall_zsmul_eq_zero W hn
+    intro S
+    have := congrArg (Point.map (transPull W K S)) h0
+    rw [map_zsmul, map_transPull_genericPoint, map_zero, smul_add, h0, zero_add, ←
+      map_zsmul] at this
+    exact Point.map_injective _ (this.trans (map_zero _).symm)
+  · intro P hP
+    apply not_forall_zsmul_eq_zero W hn
+    intro S
+    have := congrArg (Point.map (transPull W K S)) hP
+    rw [map_zsmul, map_transPull_genericPoint, Point.map_baseChange, smul_add, hP, ← map_zsmul,
+      add_eq_left] at this
+    exact Point.map_injective _ (this.trans (map_zero _).symm)
+
+omit [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] in
+theorem evalEval_map_mapRingHom {L : Type*} [CommRing L] (g : K →+* L) (q : K[X][Y]) (a b : L) :
+    (q.map (mapRingHom g)).evalEval a b = q.eval₂ (eval₂RingHom g a) b := by
+  have hφ : (evalEvalRingHom a b).comp (mapRingHom (mapRingHom g)) = eval₂RingHom (eval₂RingHom g a)
+    b :=
+    by
+    apply Polynomial.ringHom_ext
+    · intro p
+      simp only [RingHom.coe_comp, Function.comp_apply, coe_mapRingHom, map_C, coe_evalRingHom,
+        eval_C,
+        eval_map, coe_eval₂RingHom, eval₂_C]
+    · simp only [RingHom.coe_comp, Function.comp_apply, coe_mapRingHom, map_X, coe_evalRingHom,
+        eval_X,
+        eval_C, coe_eval₂RingHom, eval₂_X]
+  exact RingHom.congr_fun hφ q
+
+end WeierstrassCurve.Affine.PullEasy
+
+open WeierstrassCurve.Affine.PullEasy in
+theorem solution {F : Type*} {K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K]
+    [IsAlgClosed K] (W : WeierstrassCurve F) [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing]
+    {n : ℕ} (hn : (n : K) ≠ 0) (P : (W⁄K).Point) (hP : P ≠ 0) (hnP : (n : ℤ) • P ≠ 0)
+    (h : (W⁄K).FunctionField) (k : ℕ)
+    (hh : (placeOf W K ((n : ℤ) • P) hnP).valuation (W⁄K).FunctionField h ≤ exp (-(k : ℤ))) :
+    (placeOf W K P hP).valuation (W⁄K).FunctionField (mulPull W K n h) ≤ exp (-(k : ℤ)) := by
+  have hnK : ((n : ℤ) : K) ≠ 0 := by rwa [Int.cast_natCast]
+  have hgood := zsmul_genericPoint_good (K := K) W hnK
+  obtain ⟨ω, hω⟩ := WeierstrassCurve.Affine.Point.exists_zsmul_some_eq_some_baseChange W (n : ℤ)
+  have hγns := generic_nonsingular W K
+  have hψγ : ((W.baseChange (W⁄K).FunctionField).ψ n).evalEval (genericX W K) (genericY W K) ≠ 0 :=
+    fun h0 => hgood.1 ((WeierstrassCurve.Affine.Point.smul_some_eq_zero_iff
+      (W.baseChange (W⁄K).FunctionField) hγns n).mpr h0)
+  obtain ⟨hγ', hγeq⟩ := hω hγns hψγ
+  rcases P with _ | ⟨a, b, hab⟩
+  · exact absurd rfl hP
+  have hψP : ((W.baseChange K).ψ n).evalEval a b ≠ 0 :=
+    fun h0 => hnP ((WeierstrassCurve.Affine.Point.smul_some_eq_zero_iff (W.baseChange K) hab n).mpr
+      h0)
+  obtain ⟨hP', hPeq⟩ := hω hab hψP
+  have hΨP : ((W.baseChange K).ΨSq n).eval a ≠ 0 := by
+    rw [← WeierstrassCurve.Affine.evalEval_psi_sq (W.baseChange K) hab.left n]
+    exact pow_ne_zero 2 hψP
+  have eΦ : (W.baseChange (W⁄K).FunctionField).Φ n = ((W.baseChange K).Φ n).map (algebraMap K
+    (W⁄K).FunctionField) :=
+    baseChange_Φ (W := W) (Algebra.ofId K (W⁄K).FunctionField) n
+  have eΨ : (W.baseChange (W⁄K).FunctionField).ΨSq n = ((W.baseChange K).ΨSq n).map (algebraMap K
+    (W⁄K).FunctionField) :=
+    baseChange_ΨSq (W := W) (Algebra.ofId K (W⁄K).FunctionField) n
+  have eψ : (W.baseChange (W⁄K).FunctionField).ψ n = ((W.baseChange K).ψ n).map (mapRingHom
+    (algebraMap K (W⁄K).FunctionField)) :=
+    baseChange_ψ (W := W) (Algebra.ofId K (W⁄K).FunctionField) n
+  have eω : ω.map (mapRingHom (algebraMap F (W⁄K).FunctionField)) =
+      (ω.map (mapRingHom (algebraMap F K))).map (mapRingHom (algebraMap K (W⁄K).FunctionField)) :=
+        by
+    rw [Polynomial.map_map, mapRingHom_comp, ← IsScalarTower.algebraMap_eq F K (W⁄K).FunctionField]
+  refine valuation_mulPull_le W K hgood ((W.baseChange K).Φ n) ((W.baseChange K).ΨSq n)
+    (ω.map (mapRingHom (algebraMap F K))) ((W.baseChange K).ψ n) ?_ ?_ hP hnP ?_ hΨP ?_ hψP h k hh
+  · have e : Affine.genericPoint W K = Point.some (genericX W K) (genericY W K) hγns := rfl
+    rw [e, hγeq, Point.xc_some, eΦ, eΨ, eval_map, eval_map]
+  · have e : Affine.genericPoint W K = Point.some (genericX W K) (genericY W K) hγns := rfl
+    rw [e, hγeq, Point.yc_some, eω, eψ, evalEval_map_mapRingHom, evalEval_map_mapRingHom]
+  · rw [hPeq, Point.xc_some, Point.xc_some]
+  · rw [hPeq, Point.yc_some, Point.xc_some, Point.yc_some]
+
+end S_WeierstrassCurve_Affine_valuation_mulPull_le_of_ne_zero
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_valuation_mulPull_le_of_ne_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain WithZero
+
+theorem WeierstrassCurve.Affine.valuation_mulPull_le_of_ne_zero {F : Type*} {K : Type*} [Field F]
+    [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K] (W : WeierstrassCurve F) [W.IsElliptic]
+    [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ} (hn : (n : K) ≠ 0) (P : (W⁄K).Point)
+    (hP : P ≠ 0) (hnP : (n : ℤ) • P ≠ 0) (h : (W⁄K).FunctionField) (k : ℕ)
+    (hh : (placeOf W K ((n : ℤ) • P) hnP).valuation (W⁄K).FunctionField h ≤ exp (-(k : ℤ))) :
+    (placeOf W K P hP).valuation (W⁄K).FunctionField (mulPull W K n h) ≤ exp (-(k : ℤ)) :=
+  solution W hn P hP hnP h k hh
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_placeOf_neg_transEquiv_algebraMap.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_placeOf_neg_transEquiv_algebraMap.lean
new file mode 100644
index 0000000000..fce65f947a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_placeOf_neg_transEquiv_algebraMap.lean
@@ -0,0 +1,430 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.valuation_placeOf_neg_transEquiv_algebraMap
+(e721d9e0-49fd-5066-b904-fd5dea90e9bb) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission de1193e7-9778-500b-bf52-0a29ac5249d3
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+
+import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+import Mathlib.RingTheory.DedekindDomain.AdicValuation
+import Mathlib.RingTheory.Norm.Basic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_exists_valuation_eq_exp_natDegree_norm
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_eq_valuationSubring_of_X_not_mem
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Translation by S moves the place at infinity to -S
+
+Theorem statement: `WeierstrassCurve.Affine.valuation_placeOf_neg_transEquiv_algebraMap`
+(`e721d9e0-49fd-5066-b904-fd5dea90e9bb`), by Claude, 2026-09-05.
+
+Proof: submission `de1193e7-9778-500b-bf52-0a29ac5249d3`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra, $K$ algebraically closed and equipped with
+decidable equality, and let $W$ be a Weierstrass curve over $F$ which is elliptic; assume the affine
+coordinate ring of the base change $W⁄K$ is a Dedekind domain. Let $S$ be a point of $W⁄K$ with $S
+\neq 0$, and let $a$ be a nonzero element of the coordinate ring $(W⁄K)$`.CoordinateRing`. Since $-S
+\neq 0$, the point $-S$ has affine coordinates, and `placeOf W K (-S)` is the height-one prime of
+the coordinate ring given by the ideal $\mathrm{XYIdeal}$ generated at $(x(-S), y(-S))$, whose
+primality comes from the maximality of that ideal at a nonsingular point and which is nonzero
+because the class of $x - x(-S)$ is nonzero. The assertion is that the associated normalised
+valuation of the function field $(W⁄K)$`.FunctionField`, with values in $\mathbb{Z}$ written
+multiplicatively with zero, takes on the image of $a$ under the $K$-algebra automorphism `transEquiv
+W K S` (pull-back along translation by $S$, built from `transPull W K S` and `transPull W K (-S)` as
+mutually inverse maps) the value $\exp\bigl(\deg_{\mathrm{nat}} N(a)\bigr)$, where $N$ is the norm
+of the coordinate ring over $K[x]$.
+
+This is the statement that pull-back along translation by $S$ identifies the place of $-S$ with the
+place at infinity, at which a polynomial function $a$ has a pole of order $\deg N(a)$; in the
+normalisation used here the valuation is $\exp$ of minus the order of vanishing. It feeds the
+computation of the valuation at $-S$ of the translated Weil functions,
+[`WeierstrassCurve.Affine.valuation_transEquiv_weilFun`]
+(thm.html#WeierstrassCurve.Affine.valuation_transEquiv_weilFun).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_valuation_placeOf_neg_transEquiv_algebraMap.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_valuation_placeOf_neg_transEquiv_algebraMap
+
+open scoped WithZero Polynomial.Bivariate
+p2m_open "Polynomial Polynomial.Bivariate.Polynomial IsDedekindDomain"
+
+namespace Valuation
+p2m_export "Valuation" "map_add_eq_of_lt_left valuationSubring ext mem_valuationSubring_iff \
+  map_sub map map_sub_le ne_zero_iff congr comap mk IsEquiv isEquiv_iff_valuationSubring norm"
+p2m_open "Valuation"
+
+variable {L : Type*} [Field L]
+
+theorem eq_of_valuationSubring_eq_aux' (v w : Valuation L ℤᵐ⁰)
+    (hv : Function.Surjective v) (hw : Function.Surjective w)
+    (h : v.valuationSubring = w.valuationSubring) : v = w := by
+  have heq : v.IsEquiv w := (Valuation.isEquiv_iff_valuationSubring _ _).mpr h
+  obtain ⟨π, hπ⟩ := hv (WithZero.exp (-1))
+  obtain ⟨ρ, hρ⟩ := hw (WithZero.exp (-1))
+  have hπ0 : π ≠ 0 := fun h0 => by rw [h0, map_zero] at hπ; exact WithZero.exp_ne_zero hπ.symm
+  have hρ0 : ρ ≠ 0 := fun h0 => by rw [h0, map_zero] at hρ; exact WithZero.exp_ne_zero hρ.symm
+  have hwπ : w π = WithZero.exp (-1) := by
+    have hwπ1 : w π < 1 := heq.lt_one_iff_lt_one.mp (by rw [hπ]; decide)
+    have hwπ0 : w π ≠ 0 := (w.ne_zero_iff).mpr hπ0
+    have hle : w π ≤ w ρ := by
+      rw [hρ, ← WithZero.exp_log hwπ0, WithZero.exp_le_exp]
+      have : WithZero.log (w π) < 0 := by
+        rw [← WithZero.exp_lt_exp, WithZero.exp_log hwπ0]; exact hwπ1
+      omega
+    have hvle : v π ≤ v ρ := heq.le_iff_le.mpr hle
+    have hvρ1 : v ρ < 1 := heq.lt_one_iff_lt_one.mpr (by rw [hρ]; decide)
+    have hvρ0 : v ρ ≠ 0 := (v.ne_zero_iff).mpr hρ0
+    have hvρ : v ρ = v π := by
+      rw [hπ] at hvle ⊢
+      rw [← WithZero.exp_log hvρ0, WithZero.exp_le_exp] at hvle
+      rw [← WithZero.exp_log hvρ0, ← WithZero.exp_zero, WithZero.exp_lt_exp] at hvρ1
+      rw [← WithZero.exp_log hvρ0, WithZero.exp_inj]
+      omega
+    rw [← hρ]
+    exact (heq.eq_iff.mp hvρ).symm
+  ext x
+  by_cases hx : x = 0
+  · simp [hx]
+  have hvx0 : v x ≠ 0 := (v.ne_zero_iff).mpr hx
+  set k := WithZero.log (v x) with hk
+  have hvx : v x = v (π ^ (-k)) := by
+    rw [map_zpow₀, hπ, ← WithZero.exp_zsmul, smul_eq_mul, mul_neg, mul_one, neg_neg, hk,
+      WithZero.exp_log hvx0]
+  have hwx : w x = w (π ^ (-k)) := heq.eq_iff.mp hvx
+  rw [hwx, map_zpow₀, hwπ, hvx, map_zpow₀, hπ]
+
+end Valuation
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine a₃ a₁ map mk a₄ a₂ a₆ Affine.FunctionField Affine.Point \
+  baseChange Affine.FunctionField.exists_valuation_eq_exp_natDegree_norm \
+  Affine.FunctionField.eq_valuationSubring_of_X_not_mem"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "negY slope_of_X_ne CoordinateRing.XYIdeal \
+  CoordinateRing.XClass_ne_zero CoordinateRing Point.baseChange CoordinateRing.smul map baseChange \
+  CoordinateRing.YClass Point.some nonsingular_iff' Nonsingular FunctionField Point \
+  CoordinateRing.mk addX CoordinateRing.XClass CoordinateRing.basis Point.add_of_X_ne equation_iff \
+  Point.map_some CoordinateRing.YClass_ne_zero Point.xc_some genericX genericY genericPoint \
+  transEquiv transEquiv_genericX placeOf valuation_algebraMap_le_one \
+  FunctionField.exists_valuation_eq_exp_natDegree_norm \
+  FunctionField.eq_valuationSubring_of_X_not_mem"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "XYIdeal XClass_ne_zero smul YClass mk map \
+  degree_norm_smul_basis XClass YClass_ne_zero"
+p2m_open "WeierstrassCurve.Affine.CoordinateRing"
+
+variable {K : Type*} [Field K] (W : Affine K)
+
+lemma natDegree_norm_smul_basis_of_eq_zero' (p : K[X]) :
+    (Algebra.norm K[X] (p • (1 : W.CoordinateRing) + (0 : K[X]) • mk W Y)).natDegree =
+      2 * p.natDegree := by
+  by_cases hp : p = 0
+  · subst hp
+    have : (0 : K[X]) • (1 : W.CoordinateRing) + (0 : K[X]) • mk W Y = 0 := by simp
+    rw [this, (Algebra.norm_eq_zero_iff_of_basis (CoordinateRing.basis W)).mpr rfl,
+      natDegree_zero]
+  · have h := degree_norm_smul_basis (W' := W) p 0
+    rw [degree_zero, degree_eq_natDegree hp, two_nsmul, two_nsmul, WithBot.bot_add,
+      WithBot.bot_add, max_bot_right] at h
+    apply natDegree_eq_of_degree_eq_some
+    rw [h, two_mul]
+    rfl
+
+lemma natDegree_norm_smul_basis_of_ne_zero' (p q : K[X]) (hq : q ≠ 0) :
+    (Algebra.norm K[X] (p • (1 : W.CoordinateRing) + q • mk W Y)).natDegree =
+      max (2 * p.natDegree) (2 * q.natDegree + 3) := by
+  have h := degree_norm_smul_basis (W' := W) p q
+  apply natDegree_eq_of_degree_eq_some
+  rw [h, degree_eq_natDegree hq]
+  by_cases hp : p = 0
+  · subst hp
+    rw [degree_zero, two_nsmul, WithBot.bot_add, max_bot_left, natDegree_zero, mul_zero,
+      Nat.zero_max, two_nsmul, two_mul]
+    rfl
+  · rw [degree_eq_natDegree hp, two_nsmul, two_nsmul, two_mul, two_mul]
+    rfl
+
+lemma natDegree_norm_mk_C' (p : K[X]) :
+    (Algebra.norm K[X] (mk W (C p))).natDegree = 2 * p.natDegree := by
+  rw [← natDegree_norm_smul_basis_of_eq_zero' W p, CoordinateRing.smul, zero_smul, add_zero,
+    mul_one]
+
+lemma natDegree_norm_mk_Y' : (Algebra.norm K[X] (mk W Y)).natDegree = 3 := by
+  have := natDegree_norm_smul_basis_of_ne_zero' W 0 1 one_ne_zero
+  rw [zero_smul, one_smul, zero_add] at this
+  rw [this]
+  norm_num
+
+lemma mk_Y_ne_zero' : mk W Y ≠ 0 := by
+  simpa [YClass] using YClass_ne_zero (W' := W) 0
+
+lemma mk_C_X_ne_zero' : mk W (C X) ≠ 0 := by
+  simpa [XClass] using XClass_ne_zero (W' := W) 0
+
+end CoordinateRing
+
+section PlaceNegS
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F) (K : Type*) [Field K] [Algebra F K]
+  [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing]
+
+omit [IsAlgClosed K] [W.IsElliptic] in
+omit [DecidableEq K] in
+theorem valuation_XClass_lt_valuation_YClass {x_S y_S : K} (hxy : (W⁄K).Nonsingular x_S y_S)
+    (hS' : -(Point.some x_S y_S hxy) ≠ 0) :
+    (placeOf W K (-(Point.some x_S y_S hxy)) hS').valuation (W⁄K).FunctionField
+        (algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField (CoordinateRing.XClass (W⁄K) x_S)) <
+      (placeOf W K (-(Point.some x_S y_S hxy)) hS').valuation (W⁄K).FunctionField
+        (algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField
+          (CoordinateRing.YClass (W⁄K) (C y_S))) := by
+  classical
+  set v := (placeOf W K (-(Point.some x_S y_S hxy)) hS').valuation (W⁄K).FunctionField with hv
+  set ι := algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField with hι
+  set 𝔪 := (placeOf W K (-(Point.some x_S y_S hxy)) hS').asIdeal with h𝔪def
+  have h𝔪 : 𝔪 = CoordinateRing.XYIdeal (W⁄K) x_S (C ((W⁄K).negY x_S y_S)) := rfl
+  set u₀ := CoordinateRing.XClass (W⁄K) x_S with hu₀
+  set t₀ := CoordinateRing.YClass (W⁄K) (C y_S) with ht₀
+  have hu_mem : u₀ ∈ 𝔪 := h𝔪 ▸ Ideal.subset_span (Set.mem_insert _ _)
+  have hneg_mem : CoordinateRing.YClass (W⁄K) (C ((W⁄K).negY x_S y_S)) ∈ 𝔪 :=
+    h𝔪 ▸ Ideal.subset_span (Set.mem_insert_of_mem _ (Set.mem_singleton _))
+  have hconst : ∀ c : K, CoordinateRing.mk (W⁄K) (C (C c)) ∈ 𝔪 → c = 0 := by
+    intro c hc
+    by_contra h0
+    have hunit : IsUnit (CoordinateRing.mk (W⁄K) (C (C c))) :=
+      (((IsUnit.mk0 c h0).map C).map C).map _
+    exact (placeOf W K _ hS').isPrime.ne_top (Ideal.eq_top_of_isUnit_mem _ hc hunit)
+  have hu_lt : v (ι u₀) < 1 := (HeightOneSpectrum.valuation_lt_one_iff_mem _ _).mpr hu_mem
+  have ht0 : v (ι t₀) ≠ 0 := (Valuation.ne_zero_iff v).mpr
+    ((map_ne_zero_iff ι (IsFractionRing.injective (W⁄K).CoordinateRing (W⁄K).FunctionField)).mpr
+      (CoordinateRing.YClass_ne_zero (W' := W⁄K) _))
+  by_cases ht : t₀ ∈ 𝔪
+  · have he : (W⁄K).negY x_S y_S - y_S = 0 := by
+      apply hconst
+      have key : t₀ - CoordinateRing.YClass (W⁄K) (C ((W⁄K).negY x_S y_S)) =
+          CoordinateRing.mk (W⁄K) (C (C ((W⁄K).negY x_S y_S - y_S))) := by
+        rw [ht₀, CoordinateRing.YClass, CoordinateRing.YClass, ← map_sub]
+        congr 1
+        simp only [map_sub]
+        ring
+      exact key ▸ sub_mem ht hneg_mem
+    have he2 : 2 * y_S + (W⁄K).a₁ * x_S + (W⁄K).a₃ = 0 := by
+      simp only [negY] at he
+      linear_combination -he
+    have hc1 : 3 * x_S ^ 2 + 2 * (W⁄K).a₂ * x_S + (W⁄K).a₄ - (W⁄K).a₁ * y_S ≠ 0 := by
+      have h := ((nonsingular_iff' _ _).mp hxy).2.resolve_right (not_not.mpr he2)
+      intro h0
+      apply h
+      linear_combination -h0
+    have hγ : CoordinateRing.mk (W⁄K) (Y ^ 2 + C (C (W⁄K).a₁ * X + C (W⁄K).a₃) * Y -
+        C (X ^ 3 + C (W⁄K).a₂ * X ^ 2 + C (W⁄K).a₄ * X + C (W⁄K).a₆)) = 0 := AdjoinRoot.mk_self
+    simp only [map_sub, map_add, map_mul, map_pow] at hγ
+    have hS := congrArg (fun z : K => CoordinateRing.mk (W⁄K) (C (C z)))
+      (((equation_iff _ _).mp hxy.1))
+    simp only [map_add, map_mul, map_pow] at hS
+    have he2' := congrArg (fun z : K => CoordinateRing.mk (W⁄K) (C (C z))) he2
+    simp only [map_add, map_mul, map_ofNat, map_zero] at he2'
+    have hrel : t₀ * (t₀ + CoordinateRing.mk (W⁄K) (C (C (W⁄K).a₁)) * u₀) =
+        u₀ * (u₀ ^ 2 + CoordinateRing.mk (W⁄K) (C (C (3 * x_S + (W⁄K).a₂))) * u₀ +
+          CoordinateRing.mk (W⁄K) (C (C (3 * x_S ^ 2 + 2 * (W⁄K).a₂ * x_S + (W⁄K).a₄ -
+            (W⁄K).a₁ * y_S)))) := by
+      simp only [map_add, map_mul, map_sub, map_pow, map_ofNat]
+      rw [ht₀, hu₀, CoordinateRing.YClass, CoordinateRing.XClass]
+      simp only [map_sub]
+      linear_combination hγ - hS - (CoordinateRing.mk (W⁄K) Y -
+        CoordinateRing.mk (W⁄K) (C (C y_S))) * he2'
+    have hq : v (ι (u₀ ^ 2 + CoordinateRing.mk (W⁄K) (C (C (3 * x_S + (W⁄K).a₂))) * u₀ +
+        CoordinateRing.mk (W⁄K) (C (C (3 * x_S ^ 2 + 2 * (W⁄K).a₂ * x_S + (W⁄K).a₄ -
+          (W⁄K).a₁ * y_S))))) = 1 := by
+      rw [hι, HeightOneSpectrum.valuation_eq_one_iff_notMem]
+      intro hmem
+      apply hc1
+      apply hconst
+      have : CoordinateRing.mk (W⁄K) (C (C (3 * x_S ^ 2 + 2 * (W⁄K).a₂ * x_S + (W⁄K).a₄ -
+          (W⁄K).a₁ * y_S))) = (u₀ ^ 2 + CoordinateRing.mk (W⁄K) (C (C (3 * x_S + (W⁄K).a₂))) * u₀ +
+            CoordinateRing.mk (W⁄K) (C (C (3 * x_S ^ 2 + 2 * (W⁄K).a₂ * x_S + (W⁄K).a₄ -
+              (W⁄K).a₁ * y_S)))) -
+          u₀ * (u₀ + CoordinateRing.mk (W⁄K) (C (C (3 * x_S + (W⁄K).a₂)))) := by ring
+      rw [this]
+      exact sub_mem hmem (Ideal.mul_mem_right _ _ hu_mem)
+    have hs : v (ι (t₀ + CoordinateRing.mk (W⁄K) (C (C (W⁄K).a₁)) * u₀)) < 1 :=
+      (HeightOneSpectrum.valuation_lt_one_iff_mem _ _).mpr (add_mem ht (Ideal.mul_mem_left _ _
+        hu_mem))
+    have hmul := congrArg (fun z => v (ι z)) hrel
+    simp only [map_mul] at hmul
+    rw [hq, mul_one] at hmul
+    rw [← hmul]
+    exact mul_lt_of_lt_one_right (zero_lt_iff.mpr ht0) hs
+  · have ht1 : v (ι t₀) = 1 := by rw [hι, HeightOneSpectrum.valuation_eq_one_iff_notMem]; exact ht
+    rw [ht1]
+    exact hu_lt
+
+theorem one_lt_valuation_transEquiv_genericX {x_S y_S : K} (hxy : (W⁄K).Nonsingular x_S y_S)
+    (hS' : -(Point.some x_S y_S hxy) ≠ 0) :
+    1 < (placeOf W K (-(Point.some x_S y_S hxy)) hS').valuation (W⁄K).FunctionField
+      (transEquiv W K (Point.some x_S y_S hxy) (genericX W K)) := by
+  set v := (placeOf W K (-(Point.some x_S y_S hxy)) hS').valuation (W⁄K).FunctionField with hv
+  set ι := algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField with hι
+  have hKconst : ∀ c : K, algebraMap K (W⁄K).FunctionField c =
+      ι (CoordinateRing.mk (W⁄K) (C (C c))) := fun c =>
+    IsScalarTower.algebraMap_apply K (W⁄K).CoordinateRing (W⁄K).FunctionField c
+  have hx : genericX W K ≠ (Algebra.ofId K (W⁄K).FunctionField) x_S := by
+    intro h
+    apply CoordinateRing.XClass_ne_zero (W' := W⁄K) x_S
+    apply IsFractionRing.injective (W⁄K).CoordinateRing (W⁄K).FunctionField
+    rw [CoordinateRing.XClass, map_sub, map_sub, map_sub, _root_.map_zero, ← hι,
+      show ι (CoordinateRing.mk (W⁄K) (C X)) = genericX W K from rfl, ← hKconst, h, sub_eq_zero]
+    rfl
+  have hu0 : v (ι (CoordinateRing.XClass (W⁄K) x_S)) ≠ 0 := (Valuation.ne_zero_iff v).mpr
+    ((map_ne_zero_iff ι (IsFractionRing.injective (W⁄K).CoordinateRing (W⁄K).FunctionField)).mpr
+      (CoordinateRing.XClass_ne_zero (W' := W⁄K) _))
+  have ht' : genericY W K - (Algebra.ofId K (W⁄K).FunctionField) y_S =
+      ι (CoordinateRing.YClass (W⁄K) (C y_S)) := by
+    rw [CoordinateRing.YClass, map_sub, map_sub, Algebra.ofId_apply, hKconst]
+    rfl
+  have hu' : genericX W K - (Algebra.ofId K (W⁄K).FunctionField) x_S =
+      ι (CoordinateRing.XClass (W⁄K) x_S) := by
+    rw [CoordinateRing.XClass, map_sub, map_sub, map_sub, Algebra.ofId_apply, hKconst]
+    rfl
+  have hlt := valuation_XClass_lt_valuation_YClass W K hxy hS'
+  rw [transEquiv_genericX, genericPoint, Point.baseChange, Point.map_some, Point.add_of_X_ne hx,
+    Point.xc_some, slope_of_X_ne hx]
+  simp only [addX]
+  set ℓ := (genericY W K - (Algebra.ofId K (W⁄K).FunctionField) y_S) /
+    (genericX W K - (Algebra.ofId K (W⁄K).FunctionField) x_S) with hℓ
+  have hℓ1 : 1 < v ℓ := by
+    rw [hℓ, ht', hu', map_div₀, one_lt_div₀ (zero_lt_iff.mpr hu0)]
+    exact hlt
+  have hℓ0 : 0 < v ℓ := lt_trans zero_lt_one hℓ1
+  have ha1 : (W⁄(W⁄K).FunctionField).a₁ = algebraMap F (W⁄K).FunctionField W.a₁ := rfl
+  have ha2 : (W⁄(W⁄K).FunctionField).a₂ = algebraMap F (W⁄K).FunctionField W.a₂ := rfl
+  have hF : ∀ r : F, v (algebraMap F (W⁄K).FunctionField r) ≤ 1 := fun r => by
+    rw [IsScalarTower.algebraMap_apply F (W⁄K).CoordinateRing (W⁄K).FunctionField]
+    exact HeightOneSpectrum.valuation_le_one _ _
+  have hrest : v ((W⁄(W⁄K).FunctionField).a₁ * ℓ - (W⁄(W⁄K).FunctionField).a₂ - genericX W K -
+      (Algebra.ofId K (W⁄K).FunctionField) x_S) ≤ v ℓ := by
+    refine Valuation.map_sub_le _ (Valuation.map_sub_le _ (Valuation.map_sub_le _ ?_ ?_) ?_) ?_
+    · rw [map_mul, ha1]
+      exact mul_le_of_le_one_left zero_le (hF _)
+    · rw [ha2]; exact (hF _).trans hℓ1.le
+    · exact (HeightOneSpectrum.valuation_le_one _ _).trans hℓ1.le
+    · rw [Algebra.ofId_apply, hKconst]
+      exact (HeightOneSpectrum.valuation_le_one _ _).trans hℓ1.le
+  have hexp : ℓ ^ 2 + (W⁄(W⁄K).FunctionField).a₁ * ℓ - (W⁄(W⁄K).FunctionField).a₂ - genericX W K -
+      (Algebra.ofId K (W⁄K).FunctionField) x_S = ℓ ^ 2 + ((W⁄(W⁄K).FunctionField).a₁ * ℓ -
+        (W⁄(W⁄K).FunctionField).a₂ - genericX W K - (Algebra.ofId K (W⁄K).FunctionField) x_S) := by
+    ring
+  have hsq : v ℓ < v (ℓ ^ 2) := by
+    rw [map_pow, sq]
+    exact lt_mul_of_one_lt_left hℓ0 hℓ1
+  rw [hexp, v.map_add_eq_of_lt_left (lt_of_le_of_lt hrest hsq)]
+  exact lt_trans hℓ1 hsq
+
+theorem valuation_placeOf_neg_transEquiv_algebraMap_aux (S : (W⁄K).Point) (hS : S ≠ 0)
+    (hS' : -S ≠ 0) {a : (W⁄K).CoordinateRing} (ha : a ≠ 0) :
+    (placeOf W K (-S) hS').valuation (W⁄K).FunctionField
+        (transEquiv W K S (algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField a)) =
+      WithZero.exp ((Algebra.norm (Polynomial K) a).natDegree : ℤ) := by
+  rcases S with _ | ⟨x_S, y_S, hxy⟩
+  · exact absurd rfl hS
+  set v := (placeOf W K (-(Point.some x_S y_S hxy)) hS').valuation (W⁄K).FunctionField with hv
+  set ι := algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField with hι
+  obtain ⟨vinf, hvinf⟩ :=
+    WeierstrassCurve.Affine.FunctionField.exists_valuation_eq_exp_natDegree_norm (W.baseChange K)
+  set τ : (W⁄K).FunctionField →+* (W⁄K).FunctionField :=
+    (transEquiv W K (Point.some x_S y_S hxy)).toAlgHom.toRingHom with hτ
+  have hτapp : ∀ h, v.comap τ h = v (transEquiv W K (Point.some x_S y_S hxy) h) := fun _ => rfl
+  have hO : (v.comap τ).valuationSubring = vinf.valuationSubring := by
+    refine WeierstrassCurve.Affine.FunctionField.eq_valuationSubring_of_X_not_mem (W.baseChange K) _
+      (fun c => ?_) ?_ vinf hvinf
+    · rw [Valuation.mem_valuationSubring_iff, hτapp, AlgEquiv.commutes]
+      exact valuation_algebraMap_le_one W K _ hS' c
+    · rw [Valuation.mem_valuationSubring_iff, hτapp, not_le]
+      exact one_lt_valuation_transEquiv_genericX W K hxy hS'
+  have hsτ : Function.Surjective (v.comap τ) := fun γ => by
+    obtain ⟨h, hh⟩ := HeightOneSpectrum.valuation_surjective
+      (placeOf W K (-(Point.some x_S y_S hxy)) hS') (K := (W⁄K).FunctionField) γ
+    exact ⟨(transEquiv W K (Point.some x_S y_S hxy)).symm h, by
+      rw [hτapp, AlgEquiv.apply_symm_apply]; exact hh⟩
+  have hsinf : Function.Surjective vinf := by
+    intro γ
+    rcases eq_or_ne γ 0 with rfl | hγ
+    · exact ⟨0, map_zero _⟩
+    · have hY : vinf (ι (CoordinateRing.mk (W⁄K) Y)) = WithZero.exp 3 := by
+        rw [hι, hvinf _ (CoordinateRing.mk_Y_ne_zero' (W⁄K)), CoordinateRing.natDegree_norm_mk_Y']
+        rfl
+      have hX : vinf (ι (CoordinateRing.mk (W⁄K) (C X))) = WithZero.exp 2 := by
+        rw [hι, hvinf _ (CoordinateRing.mk_C_X_ne_zero' (W⁄K)), CoordinateRing.natDegree_norm_mk_C',
+          natDegree_X]
+        rfl
+      refine ⟨(ι (CoordinateRing.mk (W⁄K) Y) / ι (CoordinateRing.mk (W⁄K) (C X))) ^ WithZero.log γ,
+        ?_⟩
+      rw [map_zpow₀, map_div₀, hY, hX, ← WithZero.exp_sub, ← WithZero.exp_zsmul, smul_eq_mul]
+      norm_num
+      exact WithZero.exp_log hγ
+  have heqv := Valuation.eq_of_valuationSubring_eq_aux' _ _ hsτ hsinf hO
+  have key := DFunLike.congr_fun heqv (ι a)
+  rw [hτapp] at key
+  rw [key, hι, hvinf a ha]
+
+end PlaceNegS
+
+end WeierstrassCurve.Affine
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_WeierstrassCurve_Affine_valuation_placeOf_neg_transEquiv_algebraMap.WeierstrassCurve \
+  WeierstrassCurve.Affine \
+  P2MW.S_WeierstrassCurve_Affine_valuation_placeOf_neg_transEquiv_algebraMap.WeierstrassCurve.Affin\
+  e"
+
+theorem solution {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K]
+    (W : WeierstrassCurve F) [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing]
+    (S : (W⁄K).Point) (hS : S ≠ 0) {a : (W⁄K).CoordinateRing} (ha : a ≠ 0) :
+    (placeOf W K (-S) (neg_ne_zero.mpr hS)).valuation (W⁄K).FunctionField (transEquiv W K S
+      (algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField a)) = WithZero.exp ((Algebra.norm
+      (Polynomial K) a).natDegree : ℤ) :=
+  WeierstrassCurve.Affine.valuation_placeOf_neg_transEquiv_algebraMap_aux W K S hS (neg_ne_zero.mpr
+    hS) ha
+
+end S_WeierstrassCurve_Affine_valuation_placeOf_neg_transEquiv_algebraMap
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_valuation_placeOf_neg_transEquiv_algebraMap (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine
+
+theorem WeierstrassCurve.Affine.valuation_placeOf_neg_transEquiv_algebraMap {F K : Type*} [Field F]
+    [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K] (W : WeierstrassCurve F) [W.IsElliptic]
+    [IsDedekindDomain (W⁄K).CoordinateRing] (S : (W⁄K).Point) (hS : S ≠ 0)
+    {a : (W⁄K).CoordinateRing} (ha : a ≠ 0) :
+    (placeOf W K (-S) (neg_ne_zero.mpr hS)).valuation (W⁄K).FunctionField (transEquiv W K S
+      (algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField a)) = WithZero.exp ((Algebra.norm
+      (Polynomial K) a).natDegree : ℤ) :=
+  solution W S hS ha
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_placeOf_smul_of_algEquiv.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_placeOf_smul_of_algEquiv.lean
new file mode 100644
index 0000000000..a07de2bbac
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_placeOf_smul_of_algEquiv.lean
@@ -0,0 +1,258 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.valuation_placeOf_smul_of_algEquiv
+(960a1d3b-121f-50c9-9eb3-f6901fc02dd5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 32603808-d20e-5b0d-bffb-52ec0361467e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_GaloisRep
+
+import Mathlib.RingTheory.DedekindDomain.AdicValuation
+import Mathlib.RingTheory.DedekindDomain.Ideal.Lemmas
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Galois equivariance of the valuations v_P on K(E)
+
+Theorem statement: `WeierstrassCurve.Affine.valuation_placeOf_smul_of_algEquiv`
+(`960a1d3b-121f-50c9-9eb3-f6901fc02dd5`), by Claude, 2026-09-05.
+
+Proof: submission `32603808-d20e-5b0d-bffb-52ec0361467e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra, let $W$ be a Weierstrass curve over $F$, and
+write $W\!\!⁄K$ for its base change to $K$, with coordinate ring $(W⁄K).\mathrm{CoordinateRing}$ and
+function field $(W⁄K).\mathrm{FunctionField}$. Let $\sigma$ be an $F$-algebra automorphism of $K$
+and let $\Phi$ be a ring endomorphism of $(W⁄K).\mathrm{FunctionField}$ which is assumed to act on
+the image of the coordinate ring by applying $\sigma$ to coefficients: for every bivariate
+polynomial $p \in K[X][Y]$, $\Phi$ sends the image of the class
+$\mathrm{CoordinateRing.mk}\,(W⁄K)\,p$ in the function field to the image of the class of the
+polynomial obtained from $p$ by mapping all coefficients through $\sigma$. Assume the coordinate
+ring of $W⁄K$ is a Dedekind domain. Let $P$ be a point of $W⁄K$ with $P \neq 0$ and with $\sigma
+\bullet P \neq 0$, and let $f$ be any element of the function field. Here, for a nonzero point $Q$,
+$\mathrm{placeOf}\,W\,K\,Q$ denotes the height-one prime of the coordinate ring given by the ideal
+$\mathrm{XYIdeal}\,(W⁄K)\,x_Q\,(C\,y_Q)$, that is $(X - x_Q,\ Y - y_Q)$, which is maximal and
+nonzero. The conclusion is that the valuation of the function field attached to the place of $\sigma
+\bullet P$, evaluated at $\Phi f$, equals the valuation attached to the place of $P$, evaluated at
+$f$.
+
+This is the Galois equivariance of the orders of vanishing on an affine Weierstrass curve,
+$\operatorname{ord}_{\sigma P}(f^{\sigma}) = \operatorname{ord}_{P}(f)$, i.e. the statement that a
+semilinear substitution of coefficients permutes the places $\mathfrak m_P = (X - x_P, Y - y_P)$
+compatibly with the action on points. It is used in
+[`WeierstrassCurve.Affine.exists_map_weilFun_eq_mul_weilFun_smul`]
+(thm.html#WeierstrassCurve.Affine.exists_map_weilFun_eq_mul_weilFun_smul),
+where it shows that the conjugate of a function with prescribed divisor and the corresponding
+function attached to the translated point have the same divisor, as in the proof of Galois
+invariance of the Weil pairing.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_valuation_placeOf_smul_of_algEquiv.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_valuation_placeOf_smul_of_algEquiv
+
+p2m_open "Polynomial WeierstrassCurve \
+  P2MW.S_WeierstrassCurve_Affine_valuation_placeOf_smul_of_algEquiv.WeierstrassCurve \
+  WeierstrassCurve.Affine \
+  P2MW.S_WeierstrassCurve_Affine_valuation_placeOf_smul_of_algEquiv.WeierstrassCurve.Affine"
+open scoped Polynomial.Bivariate
+open scoped nonZeroDivisors
+
+section GalRing
+
+variable {F K : Type*} [Field F] [Field K] [Algebra F K] (W : WeierstrassCurve F)
+
+theorem galRing_polynomial_map (σ : K ≃ₐ[F] K) :
+    (W⁄K).polynomial.map (mapRingHom (σ : K →+* K)) = (W⁄K).polynomial := by
+  have h := (baseChange_polynomial (W := W) (f := (σ : K →ₐ[F] K))).symm
+  convert h using 2
+  rfl
+
+private noncomputable def galRingHom (σ : K ≃ₐ[F] K) :
+    (W⁄K).CoordinateRing →+* (W⁄K).CoordinateRing :=
+  AdjoinRoot.lift ((AdjoinRoot.of _).comp <| mapRingHom (σ : K →+* K))
+    (AdjoinRoot.root (W⁄K).polynomial) <| by
+      rw [← eval₂_map, galRing_polynomial_map, AdjoinRoot.eval₂_root]
+
+private theorem galRingHom_mk (σ : K ≃ₐ[F] K) (p : K[X][Y]) :
+    galRingHom W σ (CoordinateRing.mk (W⁄K) p) =
+      CoordinateRing.mk (W⁄K) (p.map (mapRingHom (σ : K →+* K))) := by
+  rw [galRingHom, CoordinateRing.mk, AdjoinRoot.lift_mk, ← eval₂_map]
+  exact AdjoinRoot.aeval_eq <| p.map <| mapRingHom (σ : K →+* K)
+
+private theorem galRingHom_comp (σ τ : K ≃ₐ[F] K) (z : (W⁄K).CoordinateRing) :
+    galRingHom W σ (galRingHom W τ z) = galRingHom W (σ * τ) z := by
+  induction z using AdjoinRoot.induction_on with
+  | ih p =>
+    change galRingHom W σ (galRingHom W τ (CoordinateRing.mk (W⁄K) p)) =
+      galRingHom W (σ * τ) (CoordinateRing.mk (W⁄K) p)
+    rw [galRingHom_mk, galRingHom_mk, galRingHom_mk, Polynomial.map_map, Polynomial.mapRingHom_comp]
+    rfl
+
+private theorem galRingHom_one (z : (W⁄K).CoordinateRing) : galRingHom W 1 z = z := by
+  induction z using AdjoinRoot.induction_on with
+  | ih p =>
+    change galRingHom W 1 (CoordinateRing.mk (W⁄K) p) = CoordinateRing.mk (W⁄K) p
+    have h1 : ((1 : K ≃ₐ[F] K) : K →+* K) = RingHom.id K := RingHom.ext fun _ => rfl
+    rw [galRingHom_mk, h1, Polynomial.mapRingHom_id, Polynomial.map_id]
+
+theorem galRing_exists (σ : K ≃ₐ[F] K) :
+    ∃ φ : (W⁄K).CoordinateRing ≃+* (W⁄K).CoordinateRing, ∀ p : K[X][Y],
+      φ (CoordinateRing.mk (W⁄K) p) = CoordinateRing.mk (W⁄K) (p.map (mapRingHom (σ : K →+* K))) :=
+        by
+  refine ⟨RingEquiv.ofRingHom (galRingHom W σ) (galRingHom W σ⁻¹) ?_ ?_, galRingHom_mk W σ⟩
+  · refine RingHom.ext fun z => ?_
+    rw [RingHom.comp_apply, RingHom.id_apply, galRingHom_comp, mul_inv_cancel, galRingHom_one]
+  · refine RingHom.ext fun z => ?_
+    rw [RingHom.comp_apply, RingHom.id_apply, galRingHom_comp, inv_mul_cancel, galRingHom_one]
+
+theorem galRing_map_XYIdeal (σ : K ≃ₐ[F] K) (φ : (W⁄K).CoordinateRing →+* (W⁄K).CoordinateRing)
+    (hφ : ∀ p : K[X][Y], φ (CoordinateRing.mk (W⁄K) p) =
+      CoordinateRing.mk (W⁄K) (p.map (mapRingHom (σ : K →+* K)))) (x y : K) :
+    (CoordinateRing.XYIdeal (W⁄K) x (C y)).map φ = CoordinateRing.XYIdeal (W⁄K) (σ x) (C (σ y)) :=
+      by
+  rw [CoordinateRing.XYIdeal, Ideal.map_span, Set.image_pair, CoordinateRing.XClass,
+    CoordinateRing.YClass, hφ, hφ]
+  simp only [Polynomial.map_sub, Polynomial.map_C, Polynomial.map_X, coe_mapRingHom,
+    RingHom.coe_coe]
+  rfl
+
+end GalRing
+
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "HeightOneSpectrum.comap HeightOneSpectrum.comap_asIdeal \
+  HeightOneSpectrum.ext mk HeightOneSpectrum"
+namespace HeightOneSpectrum
+p2m_export "IsDedekindDomain.HeightOneSpectrum" "valuation_of_algebraMap \
+  intValuation_le_pow_iff_mem mk asIdeal comap valuation comap_asIdeal intValuation_if_neg prime \
+  intValuation"
+p2m_open "IsDedekindDomain.HeightOneSpectrum IsDedekindDomain"
+
+variable {R S K L : Type*} [CommRing R] [IsDedekindDomain R] [CommRing S] [IsDedekindDomain S]
+  [Field K] [Field L] [Algebra R K] [IsFractionRing R K] [Algebra S L] [IsFractionRing S L]
+
+omit [IsDedekindDomain R] [IsDedekindDomain S] in
+theorem mem_comap_pow_iff (e : R ≃+* S) (v : HeightOneSpectrum S) (r : R) (n : ℕ) :
+    r ∈ (v.comap (e : R →+* S) e.surjective).asIdeal ^ n ↔ e r ∈ v.asIdeal ^ n := by
+  change r ∈ (v.asIdeal.comap e) ^ n ↔ e r ∈ v.asIdeal ^ n
+  rw [← Ideal.map_symm, ← Ideal.map_pow, Ideal.map_symm, Ideal.mem_comap]
+
+theorem intValuation_comap_ringEquiv (e : R ≃+* S) (v : HeightOneSpectrum S) (r : R) :
+    (v.comap (e : R →+* S) e.surjective).intValuation r = v.intValuation (e r) := by
+  by_cases hr : r = 0
+  · simp [hr]
+  have her : e r ≠ 0 := (map_ne_zero_iff e e.injective).mpr hr
+  set w := v.comap (e : R →+* S) e.surjective
+  classical
+  obtain ⟨m₁, hm₁⟩ : ∃ m : ℕ, w.intValuation r = WithZero.exp (-(m : ℤ)) :=
+    ⟨_, w.intValuation_if_neg hr⟩
+  obtain ⟨m₂, hm₂⟩ : ∃ m : ℕ, v.intValuation (e r) = WithZero.exp (-(m : ℤ)) :=
+    ⟨_, v.intValuation_if_neg her⟩
+  apply le_antisymm
+  · rw [hm₂, intValuation_le_pow_iff_mem, mem_comap_pow_iff, ← intValuation_le_pow_iff_mem, ← hm₂]
+  · rw [hm₁, intValuation_le_pow_iff_mem, ← mem_comap_pow_iff, ← intValuation_le_pow_iff_mem, ← hm₁]
+
+theorem valuation_comap_ringEquiv (e : R ≃+* S) (ψ : K →+* L)
+    (hψ : ∀ r : R, ψ (algebraMap R K r) = algebraMap S L (e r)) (v : HeightOneSpectrum S) (x : K) :
+    v.valuation L (ψ x) = (v.comap (e : R →+* S) e.surjective).valuation K x := by
+  obtain ⟨a, b, hb, rfl⟩ := IsFractionRing.div_surjective (A := R) x
+  rw [map_div₀, hψ, hψ, map_div₀, map_div₀, valuation_of_algebraMap, valuation_of_algebraMap,
+    valuation_of_algebraMap, valuation_of_algebraMap, intValuation_comap_ringEquiv,
+    intValuation_comap_ringEquiv]
+
+end IsDedekindDomain.HeightOneSpectrum
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map_map map mk map_id"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "CoordinateRing.XYIdeal CoordinateRing map \
+  CoordinateRing.YClass FunctionField Point CoordinateRing.mk CoordinateRing.XClass \
+  baseChange_polynomial polynomial placeOf placeOf_asIdeal"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+section GalA2
+
+variable {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K] (W : WeierstrassCurve F)
+  (σ : K ≃ₐ[F] K) (Φ : (W⁄K).FunctionField →+* (W⁄K).FunctionField)
+
+theorem xc_smul (P : (W⁄K).Point) : (σ • P).xc = σ P.xc := by
+  rcases P with _ | ⟨x, y, h⟩
+  · exact (map_zero σ).symm
+  · rfl
+
+theorem yc_smul (P : (W⁄K).Point) : (σ • P).yc = σ P.yc := by
+  rcases P with _ | ⟨x, y, h⟩
+  · exact (map_zero σ).symm
+  · rfl
+
+end GalA2
+
+end WeierstrassCurve.Affine
+
+open _root_.WeierstrassCurve.Affine
+  _root_.P2MW.S_WeierstrassCurve_Affine_valuation_placeOf_smul_of_algEquiv.WeierstrassCurve.Affine
+  in
+theorem solution {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K] (W :
+  WeierstrassCurve F) (σ : K ≃ₐ[F] K) (Φ : (W⁄K).FunctionField →+* (W⁄K).FunctionField) (hΦ : ∀ p :
+  K[X][Y], Φ (algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField (CoordinateRing.mk (W⁄K) p)) =
+  algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField (CoordinateRing.mk (W⁄K) (p.map (mapRingHom (σ
+  : K →+* K))))) [IsDedekindDomain (W⁄K).CoordinateRing] {P : (W⁄K).Point} (hP : P ≠ 0) (hσP : σ • P
+  ≠ 0) (f : (W⁄K).FunctionField) :
+    (placeOf W K (σ • P) hσP).valuation (W⁄K).FunctionField (Φ f) = (placeOf W K P hP).valuation
+      (W⁄K).FunctionField f := by
+  obtain ⟨φ, hφ⟩ := galRing_exists W σ
+  have hΦφ : ∀ a : (W⁄K).CoordinateRing, Φ (algebraMap _ (W⁄K).FunctionField a) =
+      algebraMap _ (W⁄K).FunctionField (φ a) := by
+    intro a
+    induction a using AdjoinRoot.induction_on with
+    | ih g => exact (hΦ g).trans (congrArg _ (hφ g).symm)
+  have hv : (placeOf W K (σ • P) hσP).comap (φ : (W⁄K).CoordinateRing →+* (W⁄K).CoordinateRing)
+      φ.surjective = placeOf W K P hP := by
+    apply IsDedekindDomain.HeightOneSpectrum.ext
+    rw [IsDedekindDomain.HeightOneSpectrum.comap_asIdeal, placeOf_asIdeal, placeOf_asIdeal, xc_smul
+      W σ,
+      yc_smul W σ, ← galRing_map_XYIdeal W σ (φ : (W⁄K).CoordinateRing →+* (W⁄K).CoordinateRing) hφ]
+    exact Ideal.comap_map_of_bijective _ φ.bijective
+  rw [IsDedekindDomain.HeightOneSpectrum.valuation_comap_ringEquiv φ Φ hΦφ, hv]
+
+end S_WeierstrassCurve_Affine_valuation_placeOf_smul_of_algEquiv
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_valuation_placeOf_smul_of_algEquiv (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Polynomial WeierstrassCurve WeierstrassCurve.Affine
+open scoped Polynomial.Bivariate
+
+theorem WeierstrassCurve.Affine.valuation_placeOf_smul_of_algEquiv {F K : Type*} [Field F] [Field K]
+  [Algebra F K] [DecidableEq K] (W : WeierstrassCurve F) (σ : K ≃ₐ[F] K) (Φ : (W⁄K).FunctionField
+  →+* (W⁄K).FunctionField) (hΦ : ∀ p : K[X][Y], Φ (algebraMap (W⁄K).CoordinateRing
+  (W⁄K).FunctionField (CoordinateRing.mk (W⁄K) p)) = algebraMap (W⁄K).CoordinateRing
+  (W⁄K).FunctionField (CoordinateRing.mk (W⁄K) (p.map (mapRingHom (σ : K →+* K)))))
+  [IsDedekindDomain (W⁄K).CoordinateRing] {P : (W⁄K).Point} (hP : P ≠ 0) (hσP : σ • P ≠ 0) (f :
+  (W⁄K).FunctionField) :
+    (placeOf W K (σ • P) hσP).valuation (W⁄K).FunctionField (Φ f) = (placeOf W K P hP).valuation
+      (W⁄K).FunctionField f :=
+  solution W σ Φ hΦ hP hσP f
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_transEquiv_le.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_transEquiv_le.lean
new file mode 100644
index 0000000000..248dd5c266
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_transEquiv_le.lean
@@ -0,0 +1,217 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.valuation_transEquiv_le
+(ad31d186-5c24-5816-927f-6dcd74404a24) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e783caec-da40-5dbd-9034-6f16cd704ad1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Translation pull-back does not decrease order of vanishing
+
+Theorem statement: `WeierstrassCurve.Affine.valuation_transEquiv_le`
+(`ad31d186-5c24-5816-927f-6dcd74404a24`), by Claude, 2026-09-05.
+
+Proof: submission `e783caec-da40-5dbd-9034-6f16cd704ad1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a field, $W$ a Weierstrass curve over $R$, and $K$ a field which is an $R$-algebra,
+assumed algebraically closed, with $W$ elliptic and the coordinate ring of the affine base change
+$W⁄K$ a Dedekind domain. Let $P$ and $S$ be points of $(W⁄K)$, both different from the point at
+infinity, with $P.\mathrm{xc} \neq S.\mathrm{xc}$ (distinct $x$-coordinates, so $P \neq \pm S$) and
+$P + S \neq 0$. For a point $Q \neq 0$, `placeOf W K Q` denotes the height-one prime of the
+coordinate ring of $W⁄K$ cut out by the ideal `CoordinateRing.XYIdeal` at $(Q.\mathrm{xc},
+Q.\mathrm{yc})$, which is maximal, hence prime, and nonzero. Let $h$ be an element of the function
+field of $W⁄K$ and $k$ a natural number. The assertion is: if the adic valuation of $h$ at `placeOf
+W K (P + S) hPS` is at most $\exp(-k)$ in $\mathbb{Z}_{m0}$, then the adic valuation of
+$(\mathrm{transEquiv}\ W\ K\ S)\,h$ at `placeOf W K P hP` is at most $\exp(-k)$; here `transEquiv W
+K S` is the $K$-algebra automorphism of the function field built from `transPull W K S` with inverse
+`transPull W K (-S)`, the pull-back along translation by $S$. Equivalently, $\operatorname{ord}_P(h
+\circ \tau_S) \geq \operatorname{ord}_{P+S}(h)$.
+
+This records how orders of vanishing transform under the pull-back by translation on the function
+field of an elliptic curve: a function vanishing to order at least $k$ at $P+S$ pulls back to one
+vanishing to order at least $k$ at $P$ (equality in fact holds, the translation being an
+automorphism, but only the inequality is asserted). It is used in the construction and verification
+of the properties of the Weil pairing, in particular by
+[`WeierstrassCurve.Affine.valuation_transEquiv_weilFun`]
+(thm.html#WeierstrassCurve.Affine.valuation_transEquiv_weilFun).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_valuation_transEquiv_le.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_valuation_transEquiv_le
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine a₃ a₁ mk a₄ a₂ a₆ baseChange"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "negY slope_of_X_ne CoordinateRing.XClass_ne_zero slope \
+  CoordinateRing Point.baseChange baseChange negAddY FunctionField Point CoordinateRing.mk addX \
+  CoordinateRing.XClass addY Point.add_of_X_ne Point.map_some Point.xc_some Point.yc_some genericX \
+  genericY genericPoint transPull transEquiv transEquiv_apply placeOf valuation_algebraMap_le_one \
+  valuation_algebraMap_eq_one cong_genericX cong_genericY valuation_pointPull_le"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+open IsDedekindDomain IsDedekindDomain.HeightOneSpectrum WithZero Polynomial
+
+section TransportTau
+
+variable {R : Type*} [Field R] (W : WeierstrassCurve R) (K : Type*) [Field K] [Algebra R K]
+  [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing]
+
+omit [DecidableEq K] [IsAlgClosed K] [W.IsElliptic]
+  [IsDedekindDomain (W⁄K).CoordinateRing] in
+theorem genericX_ne_algebraMap (c : K) : genericX W K ≠ algebraMap K (W⁄K).FunctionField c := by
+  intro h
+  apply CoordinateRing.XClass_ne_zero (W' := W⁄K) c
+  apply IsFractionRing.injective (W⁄K).CoordinateRing (W⁄K).FunctionField
+  have e1 : algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField (CoordinateRing.mk (W⁄K) (C X)) =
+      genericX W K := rfl
+  have e2 : algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField (CoordinateRing.mk (W⁄K) (C (C c)))
+    =
+      algebraMap K _ c := (IsScalarTower.algebraMap_apply K (W⁄K).CoordinateRing (W⁄K).FunctionField
+        c).symm
+  rw [CoordinateRing.XClass, map_sub, map_sub, map_sub, _root_.map_zero, e1, e2, h, sub_self]
+
+omit [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing] in
+theorem baseChange_a_eq :
+    (W⁄(W⁄K).FunctionField).a₁ = algebraMap K _ (W⁄K).a₁ ∧ (W⁄(W⁄K).FunctionField).a₂ = algebraMap K
+      _ (W⁄K).a₂ ∧
+    (W⁄(W⁄K).FunctionField).a₃ = algebraMap K _ (W⁄K).a₃ ∧ (W⁄(W⁄K).FunctionField).a₄ = algebraMap K
+      _ (W⁄K).a₄ ∧
+    (W⁄(W⁄K).FunctionField).a₆ = algebraMap K _ (W⁄K).a₆ :=
+  ⟨IsScalarTower.algebraMap_apply R K _ W.a₁, IsScalarTower.algebraMap_apply R K _ W.a₂,
+    IsScalarTower.algebraMap_apply R K _ W.a₃, IsScalarTower.algebraMap_apply R K _ W.a₄,
+    IsScalarTower.algebraMap_apply R K _ W.a₆⟩
+
+variable {W K} in
+omit [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] in
+theorem cong_addX_addY {P : (W⁄K).Point} (hP : P ≠ 0) {x₁ x₂ y₁ ℓ : (W⁄K).FunctionField}
+    {x₁' x₂' y₁' ℓ' : K}
+    (h₁ : ((placeOf W K P hP).valuation _).Cong x₁ (algebraMap K _ x₁'))
+    (h₂ : ((placeOf W K P hP).valuation _).Cong x₂ (algebraMap K _ x₂'))
+    (h₃ : ((placeOf W K P hP).valuation _).Cong y₁ (algebraMap K _ y₁'))
+    (h₄ : ((placeOf W K P hP).valuation _).Cong ℓ (algebraMap K _ ℓ')) :
+    ((placeOf W K P hP).valuation _).Cong ((W⁄(W⁄K).FunctionField).addX x₁ x₂ ℓ)
+        (algebraMap K _ ((W⁄K).addX x₁' x₂' ℓ')) ∧
+      ((placeOf W K P hP).valuation _).Cong ((W⁄(W⁄K).FunctionField).addY x₁ x₂ y₁ ℓ)
+        (algebraMap K _ ((W⁄K).addY x₁' x₂' y₁' ℓ')) := by
+  set v := (placeOf W K P hP).valuation (W⁄K).FunctionField
+  have hc := valuation_algebraMap_le_one W K P hP
+  obtain ⟨e1, e2, e3, -, -⟩ := baseChange_a_eq W K
+  have hX : v.Cong ((W⁄(W⁄K).FunctionField).addX x₁ x₂ ℓ) (algebraMap K _ ((W⁄K).addX x₁' x₂' ℓ'))
+    :=
+    by
+    simp only [addX, map_sub, map_add, map_mul, map_pow, e1, e2]
+    exact ((((h₄.pow (hc _) 2).add ((Valuation.Cong.refl _).mul h₄ (hc _) (hc _))).sub
+      (Valuation.Cong.refl _)).sub h₁).sub h₂
+  refine ⟨hX, ?_⟩
+  simp only [addY, negY, negAddY, map_sub, map_add, map_mul, map_neg, e1, e3]
+  have hX' : v.Cong ((W⁄(W⁄K).FunctionField).addX x₁ x₂ ℓ - x₁)
+      (algebraMap K _ ((W⁄K).addX x₁' x₂' ℓ') - algebraMap K _ x₁') := hX.sub h₁
+  have hN : v.Cong (ℓ * ((W⁄(W⁄K).FunctionField).addX x₁ x₂ ℓ - x₁) + y₁)
+      (algebraMap K _ ℓ' * (algebraMap K _ ((W⁄K).addX x₁' x₂' ℓ') - algebraMap K _ x₁') +
+        algebraMap K _ y₁') :=
+    (h₄.mul hX' (hc _) (by rw [← map_sub]; exact hc _)).add h₃
+  exact ((hN.neg).sub ((Valuation.Cong.refl _).mul hX (hc _) (hc _))).sub (Valuation.Cong.refl _)
+
+theorem valuation_transEquiv_le' {P S : (W⁄K).Point} (hP : P ≠ 0) (hS : S ≠ 0) (hx : P.xc ≠ S.xc)
+    (hPS : P + S ≠ 0) (h : (W⁄K).FunctionField) (k : ℕ)
+    (hh : (placeOf W K (P + S) hPS).valuation (W⁄K).FunctionField h ≤ exp (-(k : ℤ))) :
+    (placeOf W K P hP).valuation (W⁄K).FunctionField (transEquiv W K S h) ≤ exp (-(k : ℤ)) := by
+  set v := (placeOf W K P hP).valuation (W⁄K).FunctionField with hv
+  have hc := valuation_algebraMap_le_one W K P hP
+  rcases P with _ | ⟨a, b, hab⟩
+  · exact absurd rfl hP
+  rcases S with _ | ⟨xS, yS, hSns⟩
+  · exact absurd rfl hS
+  simp only [Point.xc_some] at hx
+  have hγx : genericX W K ≠ algebraMap K (W⁄K).FunctionField xS := genericX_ne_algebraMap W K xS
+  have hγx' : genericX W K ≠ Algebra.ofId K (W⁄K).FunctionField xS := hγx
+  have hQx : (genericPoint W K + Point.baseChange K (W⁄K).FunctionField (.some xS yS hSns)).xc =
+      (W⁄(W⁄K).FunctionField).addX (genericX W K) (algebraMap K (W⁄K).FunctionField xS)
+        ((W⁄(W⁄K).FunctionField).slope (genericX W K) (algebraMap K (W⁄K).FunctionField xS)
+          (genericY W K) (algebraMap K (W⁄K).FunctionField yS)) := by
+    rw [genericPoint, Point.baseChange, Point.map_some, Point.add_of_X_ne hγx', Point.xc_some]; rfl
+  have hQy : (genericPoint W K + Point.baseChange K (W⁄K).FunctionField (.some xS yS hSns)).yc =
+      (W⁄(W⁄K).FunctionField).addY (genericX W K) (algebraMap K (W⁄K).FunctionField xS) (genericY W
+        K)
+        ((W⁄(W⁄K).FunctionField).slope (genericX W K) (algebraMap K (W⁄K).FunctionField xS)
+          (genericY W K) (algebraMap K (W⁄K).FunctionField yS)) := by
+    rw [genericPoint, Point.baseChange, Point.map_some, Point.add_of_X_ne hγx', Point.yc_some]; rfl
+  have hX := cong_genericX W K (.some a b hab) hP
+  have hY := cong_genericY W K (.some a b hab) hP
+  simp only [Point.xc_some, Point.yc_some] at hX hY
+  have hslope : v.Cong ((W⁄(W⁄K).FunctionField).slope (genericX W K) (algebraMap K
+    (W⁄K).FunctionField xS) (genericY W K) (algebraMap K (W⁄K).FunctionField yS))
+      (algebraMap K (W⁄K).FunctionField ((W⁄K).slope a xS b yS)) := by
+    rw [slope_of_X_ne hγx, slope_of_X_ne hx, map_div₀, map_sub, map_sub]
+    refine (hY.sub (Valuation.Cong.refl _)).div (hX.sub (Valuation.Cong.refl _))
+      (by rw [← map_sub]; exact hc _) ?_
+    rw [← map_sub]
+    exact valuation_algebraMap_eq_one W K _ hP (sub_ne_zero.mpr hx)
+  obtain ⟨hcx, hcy⟩ := cong_addX_addY (P := .some a b hab) hP (x₂' := xS) hX
+    (Valuation.Cong.refl (algebraMap K (W⁄K).FunctionField xS)) hY hslope
+  rw [transEquiv_apply, transPull]
+  refine valuation_pointPull_le W K _ _ _ hP hPS ?_ ?_ h k hh
+  · rw [hQx, Point.add_of_X_ne hx, Point.xc_some]
+    exact hcx
+  · rw [hQy, Point.add_of_X_ne hx, Point.yc_some]
+    exact hcy
+
+end TransportTau
+
+end WeierstrassCurve.Affine
+
+open _root_.WeierstrassCurve
+  _root_.P2MW.S_WeierstrassCurve_Affine_valuation_transEquiv_le.WeierstrassCurve
+  _root_.WeierstrassCurve.Affine
+  _root_.P2MW.S_WeierstrassCurve_Affine_valuation_transEquiv_le.WeierstrassCurve.Affine
+  IsDedekindDomain WithZero in
+theorem solution {R : Type*} [Field R] (W : WeierstrassCurve R) (K : Type*) [Field K] [Algebra R K]
+    [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing]
+    {P S : (W⁄K).Point} (hP : P ≠ 0) (hS : S ≠ 0) (hx : P.xc ≠ S.xc) (hPS : P + S ≠ 0)
+    (h : (W⁄K).FunctionField) (k : ℕ)
+    (hh : (placeOf W K (P + S) hPS).valuation (W⁄K).FunctionField h ≤ exp (-(k : ℤ))) :
+    (placeOf W K P hP).valuation (W⁄K).FunctionField (transEquiv W K S h) ≤ exp (-(k : ℤ)) :=
+  valuation_transEquiv_le' W K hP hS hx hPS h k hh
+
+end S_WeierstrassCurve_Affine_valuation_transEquiv_le
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_valuation_transEquiv_le (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain WithZero
+
+theorem WeierstrassCurve.Affine.valuation_transEquiv_le {R : Type*} [Field R]
+    (W : WeierstrassCurve R) (K : Type*) [Field K] [Algebra R K] [DecidableEq K] [IsAlgClosed K]
+    [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing] {P S : (W⁄K).Point} (hP : P ≠ 0)
+    (hS : S ≠ 0) (hx : P.xc ≠ S.xc) (hPS : P + S ≠ 0) (h : (W⁄K).FunctionField) (k : ℕ)
+    (hh : (placeOf W K (P + S) hPS).valuation (W⁄K).FunctionField h ≤ exp (-(k : ℤ))) :
+    (placeOf W K P hP).valuation (W⁄K).FunctionField (transEquiv W K S h) ≤ exp (-(k : ℤ)) :=
+  solution W K hP hS hx hPS h k hh
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_transEquiv_le_self.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_transEquiv_le_self.lean
new file mode 100644
index 0000000000..f085043f84
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_transEquiv_le_self.lean
@@ -0,0 +1,307 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.valuation_transEquiv_le_self
+(28ee300d-dfb9-52a4-beec-9f36ce5f8929) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission c3dbe358-a49a-5f53-8946-e205bbae7af6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Translation pull-back carries vanishing at 2S to S
+
+Theorem statement: `WeierstrassCurve.Affine.valuation_transEquiv_le_self`
+(`28ee300d-dfb9-52a4-beec-9f36ce5f8929`), by Claude, 2026-09-05.
+
+Proof: submission `c3dbe358-a49a-5f53-8946-e205bbae7af6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a field, $W$ a Weierstrass curve over $R$, and $K$ an algebraically closed field that is
+an $R$-algebra, such that the base-changed curve $W⁄K$ is elliptic and its affine coordinate ring
+$(W⁄K).\mathrm{CoordinateRing}$ is a Dedekind domain. Let $S$ be a point of the affine curve $W⁄K$
+with $S \ne 0$ and $S + S \ne 0$, let $h$ be an element of the function field
+$(W⁄K).\mathrm{FunctionField}$ (the fraction field of the coordinate ring), and let $k$ be a natural
+number. For a nonzero point $P$, `placeOf W K P hP` denotes the height-one prime of the coordinate
+ring whose ideal is the one generated by the classes of $X - x(P)$ and $Y - y(P)$, which is maximal
+because the affine coordinates of $P$ give a nonsingular point, and nonzero because the class of $X
+- x(P)$ is nonzero. Writing $v_P$ for the associated adic valuation with values in
+$\mathbb{Z}^{m0}$, and $\exp$ for the embedding of $\mathbb{Z}$ into that group, the hypothesis is
+$v_{S+S}(h) \le \exp(-k)$, i.e. $h$ vanishes to order at least $k$ at the place of $S+S$. The
+conclusion is $v_S\big(\tau_S^{*}h\big) \le \exp(-k)$, where $\tau_S^{*} =$ `transEquiv W K S` is
+the $K$-algebra automorphism of the function field given by the translation pull-back along $S$,
+with inverse the pull-back along $-S$.
+
+This is the doubling case $P = S$ of the transport of adic valuations along the translation
+pull-back: pulling back by translation by $S$ moves the order of vanishing at $2S$ to an order of
+vanishing at least as large at $S$. It is used in the verification of the valuation-theoretic
+properties of the functions entering the Weil pairing, being cited by
+[`WeierstrassCurve.Affine.valuation_transEquiv_weilFun`]
+(thm.html#WeierstrassCurve.Affine.valuation_transEquiv_weilFun).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_valuation_transEquiv_le_self.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_valuation_transEquiv_le_self
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine a₃ a₁ mk a₄ a₂ a₆ baseChange"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "negY slope_of_X_ne CoordinateRing.XClass_ne_zero slope \
+  CoordinateRing Point.baseChange baseChange Point.add_self_of_Y_eq negAddY FunctionField \
+  slope_of_Y_ne Point CoordinateRing.mk addX CoordinateRing.XClass addY Point.add_of_X_ne \
+  equation_iff Point.map_some polynomial Point.add_self_of_Y_ne Point.xc_some Point.yc_some \
+  genericX genericY generic_nonsingular genericPoint transPull transEquiv transEquiv_apply placeOf \
+  valuation_algebraMap_le_one valuation_algebraMap_eq_one cong_genericX cong_genericY \
+  valuation_pointPull_le"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+open IsDedekindDomain IsDedekindDomain.HeightOneSpectrum WithZero Polynomial
+
+section TransportTau
+
+variable {R : Type*} [Field R] (W : WeierstrassCurve R) (K : Type*) [Field K] [Algebra R K]
+  [IsDedekindDomain (W⁄K).CoordinateRing]
+
+omit [IsDedekindDomain (W⁄K).CoordinateRing] in
+theorem genericX_ne_algebraMap (c : K) : genericX W K ≠ algebraMap K (W⁄K).FunctionField c := by
+  intro h
+  apply CoordinateRing.XClass_ne_zero (W' := W⁄K) c
+  apply IsFractionRing.injective (W⁄K).CoordinateRing (W⁄K).FunctionField
+  have e1 : algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField (CoordinateRing.mk (W⁄K) (C X)) =
+      genericX W K := rfl
+  have e2 : algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField (CoordinateRing.mk (W⁄K) (C (C c)))
+    =
+      algebraMap K _ c := (IsScalarTower.algebraMap_apply K (W⁄K).CoordinateRing (W⁄K).FunctionField
+        c).symm
+  rw [CoordinateRing.XClass, map_sub, map_sub, map_sub, _root_.map_zero, e1, e2, h, sub_self]
+
+omit [IsDedekindDomain (W⁄K).CoordinateRing] in
+theorem baseChange_a_eq :
+    (W⁄(W⁄K).FunctionField).a₁ = algebraMap K _ (W⁄K).a₁ ∧ (W⁄(W⁄K).FunctionField).a₂ = algebraMap K
+      _ (W⁄K).a₂ ∧
+    (W⁄(W⁄K).FunctionField).a₃ = algebraMap K _ (W⁄K).a₃ ∧ (W⁄(W⁄K).FunctionField).a₄ = algebraMap K
+      _ (W⁄K).a₄ ∧
+    (W⁄(W⁄K).FunctionField).a₆ = algebraMap K _ (W⁄K).a₆ :=
+  ⟨IsScalarTower.algebraMap_apply R K _ W.a₁, IsScalarTower.algebraMap_apply R K _ W.a₂,
+    IsScalarTower.algebraMap_apply R K _ W.a₃, IsScalarTower.algebraMap_apply R K _ W.a₄,
+    IsScalarTower.algebraMap_apply R K _ W.a₆⟩
+
+variable {W K} in
+theorem cong_addX_addY {P : (W⁄K).Point} (hP : P ≠ 0) {x₁ x₂ y₁ ℓ : (W⁄K).FunctionField}
+    {x₁' x₂' y₁' ℓ' : K}
+    (h₁ : ((placeOf W K P hP).valuation _).Cong x₁ (algebraMap K _ x₁'))
+    (h₂ : ((placeOf W K P hP).valuation _).Cong x₂ (algebraMap K _ x₂'))
+    (h₃ : ((placeOf W K P hP).valuation _).Cong y₁ (algebraMap K _ y₁'))
+    (h₄ : ((placeOf W K P hP).valuation _).Cong ℓ (algebraMap K _ ℓ')) :
+    ((placeOf W K P hP).valuation _).Cong ((W⁄(W⁄K).FunctionField).addX x₁ x₂ ℓ)
+        (algebraMap K _ ((W⁄K).addX x₁' x₂' ℓ')) ∧
+      ((placeOf W K P hP).valuation _).Cong ((W⁄(W⁄K).FunctionField).addY x₁ x₂ y₁ ℓ)
+        (algebraMap K _ ((W⁄K).addY x₁' x₂' y₁' ℓ')) := by
+  set v := (placeOf W K P hP).valuation (W⁄K).FunctionField
+  have hc := valuation_algebraMap_le_one W K P hP
+  obtain ⟨e1, e2, e3, -, -⟩ := baseChange_a_eq W K
+  have hX : v.Cong ((W⁄(W⁄K).FunctionField).addX x₁ x₂ ℓ) (algebraMap K _ ((W⁄K).addX x₁' x₂' ℓ'))
+    :=
+    by
+    simp only [addX, map_sub, map_add, map_mul, map_pow, e1, e2]
+    exact ((((h₄.pow (hc _) 2).add ((Valuation.Cong.refl _).mul h₄ (hc _) (hc _))).sub
+      (Valuation.Cong.refl _)).sub h₁).sub h₂
+  refine ⟨hX, ?_⟩
+  simp only [addY, negY, negAddY, map_sub, map_add, map_mul, map_neg, e1, e3]
+  have hX' : v.Cong ((W⁄(W⁄K).FunctionField).addX x₁ x₂ ℓ - x₁)
+      (algebraMap K _ ((W⁄K).addX x₁' x₂' ℓ') - algebraMap K _ x₁') := hX.sub h₁
+  have hN : v.Cong (ℓ * ((W⁄(W⁄K).FunctionField).addX x₁ x₂ ℓ - x₁) + y₁)
+      (algebraMap K _ ℓ' * (algebraMap K _ ((W⁄K).addX x₁' x₂' ℓ') - algebraMap K _ x₁') +
+        algebraMap K _ y₁') :=
+    (h₄.mul hX' (hc _) (by rw [← map_sub]; exact hc _)).add h₃
+  exact ((hN.neg).sub ((Valuation.Cong.refl _).mul hX (hc _) (hc _))).sub (Valuation.Cong.refl _)
+
+end TransportTau
+
+end WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine a₃ a₁ mk a₄ a₂ a₆ baseChange"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "negY slope_of_X_ne CoordinateRing.XClass_ne_zero slope \
+  CoordinateRing Point.baseChange baseChange Point.add_self_of_Y_eq negAddY FunctionField \
+  slope_of_Y_ne Point CoordinateRing.mk addX CoordinateRing.XClass addY Point.add_of_X_ne \
+  equation_iff Point.map_some polynomial Point.add_self_of_Y_ne Point.xc_some Point.yc_some \
+  genericX genericY generic_nonsingular genericPoint transPull transEquiv transEquiv_apply placeOf \
+  valuation_algebraMap_le_one valuation_algebraMap_eq_one cong_genericX cong_genericY \
+  valuation_pointPull_le"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+open IsDedekindDomain IsDedekindDomain.HeightOneSpectrum WithZero Polynomial
+
+section TransportTauSelf
+
+variable {R : Type*} [Field R] (W : WeierstrassCurve R) (K : Type*) [Field K] [Algebra R K]
+  [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing]
+
+noncomputable def wAtY (b : K) : K[X] :=
+  C b ^ 2 + (C (W⁄K).a₁ * X + C (W⁄K).a₃) * C b - (X ^ 3 + C (W⁄K).a₂ * X ^ 2 + C (W⁄K).a₄ * X + C
+    (W⁄K).a₆)
+
+omit [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing] in
+theorem eval_wAtY (a b : K) : (wAtY W K b).eval a =
+    b ^ 2 + (W⁄K).a₁ * a * b + (W⁄K).a₃ * b - (a ^ 3 + (W⁄K).a₂ * a ^ 2 + (W⁄K).a₄ * a + (W⁄K).a₆)
+      := by
+  simp only [wAtY, eval_add, eval_sub, eval_mul, eval_pow, eval_C, eval_X]
+  ring
+
+omit [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing] in
+theorem eval_derivative_wAtY (a b : K) : (derivative (wAtY W K b)).eval a =
+    (W⁄K).a₁ * b - (3 * a ^ 2 + 2 * (W⁄K).a₂ * a + (W⁄K).a₄) := by
+  simp only [wAtY, derivative_add, derivative_sub, derivative_mul, derivative_pow, derivative_C,
+    derivative_X, eval_add, eval_sub, eval_mul, eval_pow, eval_C, eval_X,
+    Nat.cast_ofNat, zero_mul, mul_zero, mul_one, zero_add, add_zero]
+  ring
+
+omit [DecidableEq K] [IsAlgClosed K] [IsDedekindDomain (W⁄K).CoordinateRing] in
+theorem eval₂_wAtY_generic (b : K) :
+    (wAtY W K b).eval₂ (algebraMap K (W⁄K).FunctionField) (genericX W K) =
+      (genericY W K - algebraMap K _ b) *
+        ((W⁄(W⁄K).FunctionField).negY (genericX W K) (genericY W K) - algebraMap K _ b) := by
+  have heq := (generic_nonsingular W K).left
+  rw [equation_iff] at heq
+  obtain ⟨e1, e2, e3, e4, e6⟩ := baseChange_a_eq W K
+  simp only [wAtY, eval₂_add, eval₂_sub, eval₂_mul, eval₂_pow, eval₂_C, eval₂_X, negY]
+  rw [← e1, ← e2, ← e3, ← e4, ← e6]
+  rw [e1, e2, e3, e4, e6] at heq ⊢
+  linear_combination heq
+
+theorem valuation_transEquiv_le_self' {S : (W⁄K).Point} (hS : S ≠ 0) (h2S : S + S ≠ 0)
+    (h : (W⁄K).FunctionField) (k : ℕ)
+    (hh : (placeOf W K (S + S) h2S).valuation (W⁄K).FunctionField h ≤ exp (-(k : ℤ))) :
+    (placeOf W K S hS).valuation (W⁄K).FunctionField (transEquiv W K S h) ≤ exp (-(k : ℤ)) := by
+  set v := (placeOf W K S hS).valuation (W⁄K).FunctionField with hv
+  have hc := valuation_algebraMap_le_one W K S hS
+  rcases S with _ | ⟨xS, yS, hSns⟩
+  · exact absurd rfl hS
+  have hy : yS ≠ (W⁄K).negY xS yS := fun h => h2S (Point.add_self_of_Y_eq h)
+  have hγx : genericX W K ≠ algebraMap K (W⁄K).FunctionField xS := genericX_ne_algebraMap W K xS
+  have hγx' : genericX W K ≠ Algebra.ofId K (W⁄K).FunctionField xS := hγx
+  have hQx : (genericPoint W K + Point.baseChange K (W⁄K).FunctionField (.some xS yS hSns)).xc =
+      (W⁄(W⁄K).FunctionField).addX (genericX W K) (algebraMap K (W⁄K).FunctionField xS)
+        ((W⁄(W⁄K).FunctionField).slope (genericX W K) (algebraMap K (W⁄K).FunctionField xS)
+          (genericY W K) (algebraMap K (W⁄K).FunctionField yS)) := by
+    rw [genericPoint, Point.baseChange, Point.map_some, Point.add_of_X_ne hγx', Point.xc_some]; rfl
+  have hQy : (genericPoint W K + Point.baseChange K (W⁄K).FunctionField (.some xS yS hSns)).yc =
+      (W⁄(W⁄K).FunctionField).addY (genericX W K) (algebraMap K (W⁄K).FunctionField xS) (genericY W
+        K)
+        ((W⁄(W⁄K).FunctionField).slope (genericX W K) (algebraMap K (W⁄K).FunctionField xS)
+          (genericY W K) (algebraMap K (W⁄K).FunctionField yS)) := by
+    rw [genericPoint, Point.baseChange, Point.map_some, Point.add_of_X_ne hγx', Point.yc_some]; rfl
+  have hX := cong_genericX W K (.some xS yS hSns) hS
+  have hY := cong_genericY W K (.some xS yS hSns) hS
+  simp only [Point.xc_some, Point.yc_some] at hX hY
+  obtain ⟨e1, e2, e3, e4, e6⟩ := baseChange_a_eq W K
+  have hD : v.Cong ((W⁄(W⁄K).FunctionField).negY (genericX W K) (genericY W K) - algebraMap K _ yS)
+      (algebraMap K _ ((W⁄K).negY xS yS - yS)) := by
+    simp only [negY, map_sub, map_neg, map_mul, e1, e3]
+    exact (((hY.neg).sub ((Valuation.Cong.refl _).mul hX (hc _) (hc _))).sub (Valuation.Cong.refl
+      _)).sub
+      (Valuation.Cong.refl _)
+  have hD0 : (W⁄K).negY xS yS - yS ≠ 0 := sub_ne_zero.mpr (Ne.symm hy)
+  have hD1 : v ((W⁄(W⁄K).FunctionField).negY (genericX W K) (genericY W K) - algebraMap K _ yS) = 1
+    :=
+    hD.eq_of_eq_one (valuation_algebraMap_eq_one W K _ hS hD0)
+  have hDL : (W⁄(W⁄K).FunctionField).negY (genericX W K) (genericY W K) - algebraMap K _ yS ≠ 0 :=
+    by
+    intro h0; rw [h0, Valuation.map_zero] at hD1; exact zero_ne_one hD1
+  have hroot : (wAtY W K yS).IsRoot xS := by
+    rw [IsRoot.def, eval_wAtY]
+    have := hSns.left
+    rw [equation_iff] at this
+    linear_combination this
+  set q := wAtY W K yS /ₘ (X - C xS) with hq
+  have hwq : (X - C xS) * q = wAtY W K yS := mul_divByMonic_eq_iff_isRoot.mpr hroot
+  have hqxS : q.eval xS = (W⁄K).a₁ * yS - (3 * xS ^ 2 + 2 * (W⁄K).a₂ * xS + (W⁄K).a₄) := by
+    have key :=
+      congrArg (eval xS) (divByMonic_add_X_sub_C_mul_derivative_divByMonic_eq_derivative (wAtY W K
+        yS) xS)
+    rw [eval_add, eval_mul, eval_sub, eval_X, eval_C, sub_self, zero_mul, add_zero] at key
+    rw [key, eval_derivative_wAtY]
+  have hΛ : (W⁄(W⁄K).FunctionField).slope (genericX W K) (algebraMap K _ xS) (genericY W K)
+    (algebraMap K _ yS) =
+      q.eval₂ (algebraMap K (W⁄K).FunctionField) (genericX W K) /
+        ((W⁄(W⁄K).FunctionField).negY (genericX W K) (genericY W K) - algebraMap K _ yS) := by
+    rw [slope_of_X_ne hγx, div_eq_div_iff (sub_ne_zero.mpr hγx) hDL, ← eval₂_wAtY_generic, ← hwq,
+      eval₂_mul, eval₂_sub, eval₂_X, eval₂_C]
+    ring
+  have hslope : v.Cong ((W⁄(W⁄K).FunctionField).slope (genericX W K) (algebraMap K _ xS) (genericY W
+    K)
+      (algebraMap K _ yS)) (algebraMap K _ ((W⁄K).slope xS xS yS yS)) := by
+    rw [hΛ, slope_of_Y_ne rfl hy]
+    have hq' := Valuation.Cong.eval₂ (v := v) (algebraMap K _) hc hX (hc _) q
+    rw [eval₂_at_apply, hqxS] at hq'
+    have : (3 * xS ^ 2 + 2 * (W⁄K).a₂ * xS + (W⁄K).a₄ - (W⁄K).a₁ * yS) / (yS - (W⁄K).negY xS yS) =
+        ((W⁄K).a₁ * yS - (3 * xS ^ 2 + 2 * (W⁄K).a₂ * xS + (W⁄K).a₄)) / ((W⁄K).negY xS yS - yS) :=
+          by
+      rw [← neg_sub ((W⁄K).negY xS yS) yS, ← neg_sub ((W⁄K).a₁ * yS), neg_div_neg_eq]
+    rw [this, map_div₀]
+    exact hq'.1.div hD hq'.2 (valuation_algebraMap_eq_one W K _ hS hD0)
+  obtain ⟨hcx, hcy⟩ := cong_addX_addY (P := .some xS yS hSns) hS (x₂' := xS) hX
+    (Valuation.Cong.refl (algebraMap K (W⁄K).FunctionField xS)) hY hslope
+  rw [transEquiv_apply, transPull]
+  refine valuation_pointPull_le W K _ _ _ hS h2S ?_ ?_ h k hh
+  · rw [hQx, Point.add_self_of_Y_ne hy, Point.xc_some]
+    exact hcx
+  · rw [hQy, Point.add_self_of_Y_ne hy, Point.yc_some]
+    exact hcy
+
+end TransportTauSelf
+
+end WeierstrassCurve.Affine
+
+open _root_.WeierstrassCurve
+  _root_.P2MW.S_WeierstrassCurve_Affine_valuation_transEquiv_le_self.WeierstrassCurve
+  _root_.WeierstrassCurve.Affine
+  _root_.P2MW.S_WeierstrassCurve_Affine_valuation_transEquiv_le_self.WeierstrassCurve.Affine
+  IsDedekindDomain WithZero in
+theorem solution {R : Type*} [Field R] (W : WeierstrassCurve R) (K : Type*) [Field K] [Algebra R K]
+    [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing]
+    {S : (W⁄K).Point} (hS : S ≠ 0) (h2S : S + S ≠ 0) (h : (W⁄K).FunctionField) (k : ℕ)
+    (hh : (placeOf W K (S + S) h2S).valuation (W⁄K).FunctionField h ≤ exp (-(k : ℤ))) :
+    (placeOf W K S hS).valuation (W⁄K).FunctionField (transEquiv W K S h) ≤ exp (-(k : ℤ)) :=
+  valuation_transEquiv_le_self' W K hS h2S h k hh
+
+end S_WeierstrassCurve_Affine_valuation_transEquiv_le_self
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_valuation_transEquiv_le_self (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain WithZero
+
+theorem WeierstrassCurve.Affine.valuation_transEquiv_le_self {R : Type*} [Field R]
+    (W : WeierstrassCurve R) (K : Type*) [Field K] [Algebra R K] [DecidableEq K] [IsAlgClosed K]
+    [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing] {S : (W⁄K).Point} (hS : S ≠ 0)
+    (h2S : S + S ≠ 0) (h : (W⁄K).FunctionField) (k : ℕ)
+    (hh : (placeOf W K (S + S) h2S).valuation (W⁄K).FunctionField h ≤ exp (-(k : ℤ))) :
+    (placeOf W K S hS).valuation (W⁄K).FunctionField (transEquiv W K S h) ≤ exp (-(k : ℤ)) :=
+  solution W K hS h2S h k hh
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_transEquiv_weilFun.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_transEquiv_weilFun.lean
new file mode 100644
index 0000000000..231037fa1e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_transEquiv_weilFun.lean
@@ -0,0 +1,255 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.valuation_transEquiv_weilFun
+(f1fbd184-0514-54de-a553-6b93eb132cb5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e9cfbb8a-9f66-506d-9a01-dbf2314317c7
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_WeilPairingFun
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_weilNum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_weilNum_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_fibSet_finite
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_ncard_fibSet
+import LeanPool.FLTEichlerShimura.Theorems.Thm_IsDedekindDomain_HeightOneSpectrum_valuation_eq_exp_neg_count
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_natDegree_norm_eq_finsum_count
+import LeanPool.FLTEichlerShimura.Theorems.Thm_Valuation_eq_comap_of_valuationSubring_le_comap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_placeOf_neg_transEquiv_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_transEquiv_le
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_transEquiv_le_self
+import Mathlib.Data.Set.Card.Arithmetic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Valuation of the translated Weil function at finite places
+
+Theorem statement: `WeierstrassCurve.Affine.valuation_transEquiv_weilFun`
+(`f1fbd184-0514-54de-a553-6b93eb132cb5`), by Claude, 2026-09-05.
+
+Proof: submission `e9cfbb8a-9f66-506d-9a01-dbf2314317c7`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra and $K$ algebraically closed, let $W$ be an
+elliptic Weierstrass curve over $F$, and assume the affine coordinate ring of the base change $W⁄K$
+is a Dedekind domain. Let $n$ be a natural number whose image in $K$ is nonzero, let $S$ be a point
+of $W⁄K$, let $T$ be a point with $(n : \mathbb{Z}) \cdot T = 0$, and let $P$ be a point with $P \ne
+0$. Write $v_P$ for the valuation on the function field of $W⁄K$ attached to the height-one prime
+`placeOf W K P hP`, namely the ideal `CoordinateRing.XYIdeal` cut out by the affine coordinates of
+$P$ (maximal, hence prime, and nonzero). Let $g_T$ be `weilFun W K n T`, the quotient in the
+function field of the images of `weilNum W K n T` and `weilNum W K n 0`, where `weilNum W K n Q`
+denotes a chosen generator of `fibIdeal W K n Q` when that ideal is principal and $1$ otherwise, and
+let `transEquiv W K S` be the $K$-algebra automorphism of the function field given by `transPull W K
+S`, with inverse `transPull W K (-S)`. Then, in $\mathbb{Z}_{\ge 0}$-valued notation
+$\operatorname{exp}$ on `WithZero (Multiplicative ℤ)`, $$v_P\bigl(\text{transEquiv } W\, K\,
+S\,(g_T)\bigr) = \frac{\bigl[\,(n:\mathbb{Z})\cdot(P+S) =
+T\,\bigr]}{\bigl[\,(n:\mathbb{Z})\cdot(P+S) = 0\,\bigr]},$$ where each bracket denotes
+$\operatorname{exp}(-1)$ if the stated equality of points holds and $1$ otherwise.
+
+This is the computation of the divisor of the translate $\tau_S^{*} g_T$ of the Weil function $g_T$
+at the finite places of the affine coordinate ring: the order of $g_T \circ \tau_S$ at $P$ is the
+order of $g_T$ at $P+S$, so that $\tau_S^{*}g_T$ has a simple zero exactly at the points $P$ with
+$n(P+S) = T$ and a simple pole exactly where $n(P+S) = 0$. It is used in
+[`WeierstrassCurve.Affine.exists_transEquiv_weilFun_eq`]
+(thm.html#WeierstrassCurve.Affine.exists_transEquiv_weilFun_eq)
+and thence in the identities `weilPairing0_add_right` and `weilPairing0_self` for the Weil pairing.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_valuation_transEquiv_weilFun.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_valuation_transEquiv_weilFun
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_WeierstrassCurve_Affine_valuation_transEquiv_weilFun.WeierstrassCurve \
+  WeierstrassCurve.Affine \
+  P2MW.S_WeierstrassCurve_Affine_valuation_transEquiv_weilFun.WeierstrassCurve.Affine \
+  IsDedekindDomain IsDedekindDomain.HeightOneSpectrum WithZero Polynomial"
+open scoped nonZeroDivisors
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine baseChange"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add_of_Y_eq CoordinateRing baseChange FunctionField \
+  Point Y_eq_of_X_eq fibSet mem_fibSet weilNum weilFun Point.xc_some transEquiv transEquiv_zero \
+  placeOf placeOf_surjective placeOf_injective valuation_weilNum weilNum_ne_zero fibSet_finite \
+  ncard_fibSet CoordinateRing.natDegree_norm_eq_finsum_count \
+  valuation_placeOf_neg_transEquiv_algebraMap valuation_transEquiv_le valuation_transEquiv_le_self"
+namespace DivTau
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+variable {F : Type*} {K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K]
+  (W : WeierstrassCurve F) [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing]
+
+theorem valuation_transEquiv_eq {P S : (W⁄K).Point} (hP : P ≠ 0) (hPS : P + S ≠ 0)
+    (h : (W⁄K).FunctionField) :
+    (placeOf W K P hP).valuation (W⁄K).FunctionField (transEquiv W K S h) =
+      (placeOf W K (P + S) hPS).valuation (W⁄K).FunctionField h := by
+  by_cases hS : S = 0
+  · subst hS
+    simp only [transEquiv_zero, AlgEquiv.coe_refl, id_eq]
+    have key : ∀ (Q : (W⁄K).Point) (hQ : Q ≠ 0), Q = P →
+        (placeOf W K P hP).valuation (W⁄K).FunctionField h =
+          (placeOf W K Q hQ).valuation (W⁄K).FunctionField h := by
+      rintro Q hQ rfl; rfl
+    exact key (P + 0) hPS (add_zero P)
+  have hle : ∀ f : (W⁄K).FunctionField,
+      (placeOf W K (P + S) hPS).valuation (W⁄K).FunctionField f ≤ 1 →
+        (placeOf W K P hP).valuation (W⁄K).FunctionField (transEquiv W K S f) ≤ 1 := by
+    intro f hf
+    have hf' : (placeOf W K (P + S) hPS).valuation (W⁄K).FunctionField f ≤ exp (-((0 : ℕ) : ℤ)) :=
+      by
+      simpa using hf
+    by_cases hx : P.xc ≠ S.xc
+    · simpa using valuation_transEquiv_le W K hP hS hx hPS f 0 hf'
+    · rw [not_ne_iff] at hx
+      have hPS' : P = S := by
+        rcases P with _ | ⟨a, b, hab⟩
+        · exact absurd rfl hP
+        rcases S with _ | ⟨c, d, hcd⟩
+        · exact absurd rfl hS
+        simp only [Point.xc_some] at hx
+        subst hx
+        rcases Y_eq_of_X_eq hab.left hcd.left rfl with hy | hy
+        · subst hy; rfl
+        · exact absurd (Point.add_of_Y_eq rfl hy) hPS
+      subst hPS'
+      simpa using valuation_transEquiv_le_self W K hP hPS f 0 hf'
+  have key := Valuation.eq_comap_of_valuationSubring_le_comap
+    (v := (placeOf W K P hP).valuation (W⁄K).FunctionField)
+    (w := (placeOf W K (P + S) hPS).valuation (W⁄K).FunctionField)
+    (valuation_surjective _ _) (valuation_surjective _ _) (transEquiv W K S).toRingEquiv
+    (fun f hf => (ValuationSubring.mem_comap).mpr (hle f hf))
+  rw [key]
+  rfl
+
+theorem natDegree_norm_weilNum {n : ℕ} (hn : (n : K) ≠ 0) {T : (W⁄K).Point} (hT : (n : ℤ) • T = 0) :
+    ((Algebra.norm (Polynomial K) (weilNum W K n T)).natDegree : ℤ) = n ^ 2 - if T = 0 then 1 else 0
+      := by
+  classical
+  have ha := weilNum_ne_zero W hn hT
+  rw [CoordinateRing.natDegree_norm_eq_finsum_count (W.baseChange K) ha]
+  set A : Set (W⁄K).Point := {P | P ≠ 0 ∧ (n : ℤ) • P = T} with hA
+  have hcount : ∀ (P : (W⁄K).Point) (hP : P ≠ 0),
+      FractionalIdeal.count (W⁄K).FunctionField (placeOf W K P hP) (FractionalIdeal.spanSingleton
+        (W⁄K).CoordinateRing⁰ (algebraMap _ (W⁄K).FunctionField (weilNum W K n T))) =
+        if (n : ℤ) • P = T then 1 else 0 := by
+    intro P hP
+    have h1 := IsDedekindDomain.HeightOneSpectrum.valuation_eq_exp_neg_count (W⁄K).FunctionField
+      (placeOf W K P hP) ((map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr ha)
+    rw [valuation_weilNum W hn hT P hP] at h1
+    split_ifs at h1 ⊢ with hc
+    · have := exp_injective h1; omega
+    · rw [← exp_zero] at h1; have := exp_injective h1; omega
+  set V : Set (HeightOneSpectrum (W⁄K).CoordinateRing) :=
+    (fun x : A => placeOf W K x.1 x.2.1) '' Set.univ with hV
+  have hsummand : (fun v : HeightOneSpectrum (W⁄K).CoordinateRing =>
+      FractionalIdeal.count (W⁄K).FunctionField v (FractionalIdeal.spanSingleton
+        (W⁄K).CoordinateRing⁰ (algebraMap _ (W⁄K).FunctionField (weilNum W K n T)))) =
+      V.indicator 1 := by
+    funext v
+    obtain ⟨P, hP, rfl⟩ := placeOf_surjective W K v
+    rw [hcount P hP, Set.indicator_apply, Pi.one_apply]
+    congr 1
+    apply propext
+    constructor
+    · intro h; exact ⟨⟨P, hP, h⟩, Set.mem_univ _, rfl⟩
+    · rintro ⟨⟨Q, hQ, hQT⟩, -, hQP⟩
+      have := placeOf_injective W K hQ hP hQP
+      subst this; exact hQT
+  have hAeq : A = fibSet W K n T \ {0} := by
+    ext P
+    simp only [hA, Set.mem_ofPred_eq, Set.mem_sdiff, mem_fibSet, Set.mem_singleton_iff]
+    tauto
+  have hAfin : A.Finite := by rw [hAeq]; exact (fibSet_finite W hn T).sdiff
+  have : Finite A := hAfin.to_subtype
+  have hVfin : V.Finite := Set.finite_univ.image _
+  have hinj : Function.Injective (fun x : A => placeOf W K x.1 x.2.1) := by
+    intro x y hxy; exact Subtype.ext (placeOf_injective W K x.2.1 y.2.1 hxy)
+  have hVcard : V.ncard = (fibSet W K n T \ {0}).ncard := by
+    rw [hV, Set.ncard_image_of_injective _ hinj, Set.ncard_univ, Nat.card_coe_set_eq, hAeq]
+  rw [hsummand, ← finsum_mem_def]
+  simp only [Pi.one_apply]
+  rw [finsum_mem_eq_finite_toFinset_sum _ hVfin, Finset.sum_const, nsmul_eq_mul, mul_one,
+    ← Set.ncard_eq_toFinset_card V hVfin, hVcard]
+  by_cases hT0 : T = 0
+  · subst hT0
+    have h0 : (0 : (W⁄K).Point) ∈ fibSet W K n 0 := by rw [mem_fibSet, smul_zero]
+    rw [Set.ncard_sdiff_singleton_of_mem h0, ncard_fibSet W hn 0, ite_eq_left rfl]
+    have : 1 ≤ n ^ 2 := by
+      have :=
+        Set.ncard_ne_zero_of_mem h0 (fibSet_finite W hn 0); rw [ncard_fibSet W hn 0] at this; omega
+    push_cast [Nat.cast_sub this]
+    ring
+  · have h0 : (0 : (W⁄K).Point) ∉ fibSet W K n T := by rw [mem_fibSet, smul_zero]; exact Ne.symm hT0
+    rw [Set.sdiff_singleton_eq_self h0, ncard_fibSet W hn T, ite_eq_right hT0]
+    push_cast; ring
+
+theorem valuation_weilFun' {n : ℕ} (hn : (n : K) ≠ 0) {T : (W⁄K).Point} (hT : (n : ℤ) • T = 0)
+    (P : (W⁄K).Point) (hP : P ≠ 0) :
+    (placeOf W K P hP).valuation (W⁄K).FunctionField (weilFun W K n T) =
+      (if (n : ℤ) • P = T then exp (-1 : ℤ) else 1) / (if (n : ℤ) • P = 0 then exp (-1 : ℤ) else 1)
+        := by
+  rw [weilFun, map_div₀, valuation_weilNum W hn hT P hP, valuation_weilNum W hn (smul_zero _) P hP]
+
+end WeierstrassCurve.Affine.DivTau
+
+open WeierstrassCurve.Affine.DivTau in
+theorem solution {F : Type*} {K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K]
+    [IsAlgClosed K] (W : WeierstrassCurve F) [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing]
+    {n : ℕ} (hn : (n : K) ≠ 0) (S : (W⁄K).Point) {T : (W⁄K).Point} (hT : (n : ℤ) • T = 0)
+    (P : (W⁄K).Point) (hP : P ≠ 0) :
+    (placeOf W K P hP).valuation (W⁄K).FunctionField (transEquiv W K S (weilFun W K n T)) = (if (n :
+      ℤ) • (P + S) = T then exp (-1 : ℤ) else 1) / (if (n : ℤ) • (P + S) = 0 then exp (-1 : ℤ) else
+      1) := by
+  by_cases hPS : P + S = 0
+  · have hS : S ≠ 0 := by rintro rfl; exact hP (by simpa using hPS)
+    have hPe : P = -S := eq_neg_of_add_eq_zero_left hPS
+    subst hPe
+    rw [hPS, smul_zero, weilFun, map_div₀, map_div₀,
+      valuation_placeOf_neg_transEquiv_algebraMap W S hS (weilNum_ne_zero W hn hT),
+      valuation_placeOf_neg_transEquiv_algebraMap W S hS (weilNum_ne_zero W hn (smul_zero _)),
+      natDegree_norm_weilNum W hn hT, natDegree_norm_weilNum W hn (smul_zero _)]
+    simp only [ite_true, ← exp_sub]
+    by_cases hT0 : T = 0
+    · subst hT0; simp
+    · rw [ite_eq_right hT0, ite_eq_right (Ne.symm hT0)]
+      ring_nf
+      rw [one_div, ← exp_neg, neg_neg]
+  · rw [valuation_transEquiv_eq W hP hPS, valuation_weilFun' W hn hT]
+
+end S_WeierstrassCurve_Affine_valuation_transEquiv_weilFun
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_valuation_transEquiv_weilFun (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain WithZero
+
+theorem WeierstrassCurve.Affine.valuation_transEquiv_weilFun {F : Type*} {K : Type*} [Field F]
+    [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K] (W : WeierstrassCurve F) [W.IsElliptic]
+    [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ} (hn : (n : K) ≠ 0) (S : (W⁄K).Point)
+    {T : (W⁄K).Point} (hT : (n : ℤ) • T = 0) (P : (W⁄K).Point) (hP : P ≠ 0) :
+    (placeOf W K P hP).valuation (W⁄K).FunctionField (transEquiv W K S (weilFun W K n T)) = (if (n :
+      ℤ) • (P + S) = T then exp (-1 : ℤ) else 1) / (if (n : ℤ) • (P + S) = 0 then exp (-1 : ℤ) else
+      1) :=
+  solution W hn S hT P hP
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_weilFun.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_weilFun.lean
new file mode 100644
index 0000000000..c40362ed8b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_weilFun.lean
@@ -0,0 +1,101 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.valuation_weilFun
+(d8912124-0fef-51f1-939c-c6cf5c2e1b07) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission bd005453-d3af-50b9-b70e-865738efbc8a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_WeilPairingFun
+
+import Mathlib.Data.Set.Card
+import Mathlib.Algebra.BigOperators.Group.Finset.Piecewise
+import Mathlib.Tactic.Ring
+import Mathlib.Tactic.FieldSimp
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_weilNum
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Valuation of the Weil function g_T at an affine place
+
+Theorem statement: `WeierstrassCurve.Affine.valuation_weilFun`
+(`d8912124-0fef-51f1-939c-c6cf5c2e1b07`), by Claude, 2026-09-05.
+
+Proof: submission `bd005453-d3af-50b9-b70e-865738efbc8a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra and $K$ algebraically closed, and let $W$ be a
+Weierstrass curve over $F$ which is elliptic, such that the coordinate ring of the base change $W⁄K$
+is a Dedekind domain. Let $n$ be a natural number whose image in $K$ is nonzero, let $T$ be a point
+of the affine curve $W⁄K$ with $(n:\mathbb Z) \cdot T = 0$, and let $P$ be a point with $P \neq 0$.
+Write $v_P$ for the valuation on the function field of $W⁄K$ attached by `placeOf` to $P$, namely
+the valuation of the height-one prime of the coordinate ring cut out by the maximal ideal $(X -
+x_P,\, Y - y_P)$, which is prime because $P$ is a nonsingular affine point and nonzero because the
+class of $X - x_P$ is nonzero. Then the element `weilFun W K n T`, the quotient of the images in the
+function field of the chosen generators `weilNum W K n T` and `weilNum W K n 0` of the ideals
+`fibIdeal W K n T` and `fibIdeal W K n 0` (the generator being replaced by $1$ when the ideal fails
+to be principal), satisfies
+$$v_P(g_T) = \frac{\text{(if } (n:\mathbb Z)\cdot P = T \text{ then } \exp(-1) \text{ else }
+1)}{\text{(if } (n:\mathbb Z)\cdot P = 0 \text{ then } \exp(-1) \text{ else } 1)},$$
+where $\exp$ is the embedding of $\mathbb Z$ into the value group. Thus $g_T$ has a simple zero at
+$P$ exactly when $P$ lies in the fibre $[n]^{-1}(T)$, a simple pole exactly when $P$ is a nonzero
+$n$-torsion point, and is a unit at all other affine places.
+
+This is the computation of the divisor of the function $g_T$ used in the construction of the Weil
+pairing, restricted to the affine places: away from the point at infinity, $\operatorname{div}(g_T)
+= [n]^*(T) - [n]^*(0)$. It is used in the proofs that the pairing is nondegenerate and
+Galois-equivariant, via the statements on the behaviour of `weilFun` under algebra homomorphisms and
+under translation.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_valuation_weilFun.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_valuation_weilFun
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain IsDedekindDomain.HeightOneSpectrum
+  WithZero
+open scoped nonZeroDivisors
+
+theorem solution {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K]
+    (W : WeierstrassCurve F) [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ}
+    (hn : (n : K) ≠ 0) {T : (W⁄K).Point} (hT : (n : ℤ) • T = 0) (P : (W⁄K).Point) (hP : P ≠ 0) :
+    (placeOf W K P hP).valuation (W⁄K).FunctionField (weilFun W K n T) = (if (n : ℤ) • P = T then
+      exp (-1 : ℤ) else 1) / (if (n : ℤ) • P = 0 then exp (-1 : ℤ) else 1) := by
+  rw [weilFun, map_div₀, WeierstrassCurve.Affine.valuation_weilNum W hn hT P hP,
+    WeierstrassCurve.Affine.valuation_weilNum W hn (smul_zero _) P hP]
+
+end S_WeierstrassCurve_Affine_valuation_weilFun
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_valuation_weilFun (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain WithZero
+
+theorem WeierstrassCurve.Affine.valuation_weilFun {F K : Type*} [Field F] [Field K] [Algebra F K]
+    [DecidableEq K] [IsAlgClosed K] (W : WeierstrassCurve F) [W.IsElliptic]
+    [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ} (hn : (n : K) ≠ 0) {T : (W⁄K).Point}
+    (hT : (n : ℤ) • T = 0) (P : (W⁄K).Point) (hP : P ≠ 0) :
+    (placeOf W K P hP).valuation (W⁄K).FunctionField (weilFun W K n T) = (if (n : ℤ) • P = T then
+      exp (-1 : ℤ) else 1) / (if (n : ℤ) • P = 0 then exp (-1 : ℤ) else 1) :=
+  solution W hn hT P hP
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_weilNum.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_weilNum.lean
new file mode 100644
index 0000000000..7c1a7fa855
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_valuation_weilNum.lean
@@ -0,0 +1,274 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.valuation_weilNum
+(010cda30-3345-5c01-a0e7-6d0525ea9d06) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 1a0848cc-b9b4-5d49-a82d-80181e2da33a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_WeilPairingFun
+
+import Mathlib.Data.Set.Card
+import Mathlib.Algebra.BigOperators.Group.Finset.Piecewise
+import Mathlib.Tactic.Ring
+import Mathlib.Tactic.FieldSimp
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsion_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isPrincipal_prod_XYIdeal_zpow_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_sum_eq_zero_of_forall_mem_iff_smul_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_fibSet_finite
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Divisor of `weilNum`: simple zeros on the [n]-fibre over T
+
+Theorem statement: `WeierstrassCurve.Affine.valuation_weilNum`
+(`010cda30-3345-5c01-a0e7-6d0525ea9d06`), by Claude, 2026-09-05.
+
+Proof: submission `1a0848cc-b9b4-5d49-a82d-80181e2da33a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra and $K$ algebraically closed, let $W$ be a
+Weierstrass curve over $F$ which is elliptic, and write $W⁄K$ for its base change, assumed to have
+Dedekind affine coordinate ring $(W⁄K).\mathrm{CoordinateRing}$. Let $n$ be a natural number with
+$(n : K) \neq 0$, let $T$ be a point of $W⁄K$ killed by $n$, i.e. $(n : \mathbb{Z}) \cdot T = 0$,
+and let $P$ be a point of $W⁄K$ different from the point at infinity. The place `placeOf W K P hP`
+is the height-one prime of the coordinate ring whose ideal is the ideal $\mathrm{XYIdeal}$ of the
+affine coordinates $(P.\mathrm{xc}, P.\mathrm{yc})$ of $P$, maximal because those coordinates are
+nonsingular, and nonzero because the class of $X$ is nonzero. The element `weilNum W K n T` is a
+chosen generator of the ideal `fibIdeal W K n T` if that ideal is principal, and $1$ otherwise;
+`fibIdeal W K n T` is the product of the ideals `placeIdeal W K P` over the members of `fibSet W K n
+T`, the fibre of $[n]$ over $T$, which is finite here, and is $\top$ if that set is infinite. The
+assertion is that the valuation attached to `placeOf W K P hP` on the function field of $W⁄K$,
+evaluated on the image of `weilNum W K n T` in the function field, equals $\exp(-1)$ when $(n :
+\mathbb{Z}) \cdot P = T$, and equals $1$ otherwise; that is, `weilNum W K n T` has a simple zero at
+each point of the fibre of $[n]$ over $T$ and is a unit at every other affine point.
+
+This is the divisor computation for the function whose divisor is $\sum_{nP = T} (P) - n^2 (O)$ used
+in the classical construction of the Weil pairing, as in Silverman III.8; the hypothesis that $T$ is
+$n$-torsion is what makes the fibre ideal principal, via the divisor-class criterion together with
+$\sum_{nP=T} P = 0$. It underlies the subsequent statements on valuations of Weil functions and on
+integral models of the Weil pairing over valuation subrings.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_valuation_weilNum.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_valuation_weilNum
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain IsDedekindDomain.HeightOneSpectrum
+  WithZero
+open scoped nonZeroDivisors
+
+namespace WeilDiv
+
+variable {F : Type*} [Field F] {K : Type*} [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K]
+  (W : WeierstrassCurve F) [W.IsElliptic]
+
+theorem torsion_finite {n : ℕ} (hn : (n : K) ≠ 0) :
+    {S : (W⁄K).Point | (n : ℤ) • S = 0}.Finite := by
+  have hcard := WeierstrassCurve.card_torsion_of_isAlgClosed (K := K) W hn
+  have hn0 : n ≠ 0 := by rintro rfl; exact hn Nat.cast_zero
+  have : Finite (Submodule.torsionBy ℤ (W⁄K).Point n) :=
+    Nat.finite_of_card_ne_zero (by rw [hcard]; exact pow_ne_zero 2 hn0)
+  have hset : {S : (W⁄K).Point | (n : ℤ) • S = 0} =
+      ((Submodule.torsionBy ℤ (W⁄K).Point n : Submodule ℤ (W⁄K).Point) : Set (W⁄K).Point) := by
+    ext S
+    rw [Set.mem_ofPred_eq, SetLike.mem_coe, Submodule.mem_torsionBy_iff]
+  rw [hset]
+  exact Set.toFinite _
+
+theorem card_torsion_toFinset {n : ℕ} (hn : (n : K) ≠ 0) :
+    (torsion_finite W hn).toFinset.card = n ^ 2 := by
+  rw [← WeierstrassCurve.card_torsion_of_isAlgClosed (K := K) W hn, ←
+    Nat.card_eq_card_finite_toFinset]
+  have hset : {S : (W⁄K).Point | (n : ℤ) • S = 0} =
+      ((Submodule.torsionBy ℤ (W⁄K).Point n : Submodule ℤ (W⁄K).Point) : Set (W⁄K).Point) := by
+    ext S
+    rw [Set.mem_ofPred_eq, SetLike.mem_coe, Submodule.mem_torsionBy_iff]
+  rw [hset]
+  rfl
+
+theorem sum_fibSet_eq_zero {n : ℕ} (hn : (n : K) ≠ 0) {T : (W⁄K).Point} (hT : (n : ℤ) • T = 0) :
+    ∑ P ∈ (WeierstrassCurve.Affine.fibSet_finite W hn T).toFinset, P = 0 := by
+  classical
+  set s := (WeierstrassCurve.Affine.fibSet_finite W hn T).toFinset with hs
+  by_cases hne : ∃ P₀ : (W⁄K).Point, (n : ℤ) • P₀ = T
+  · obtain ⟨P₀, hP₀⟩ := hne
+    set t := (torsion_finite W hn).toFinset with ht
+    have hts : s = t.image (· + P₀) := by
+      ext P
+      simp only [hs, ht, Set.Finite.mem_toFinset, mem_fibSet, Finset.mem_image, Set.mem_ofPred_eq]
+      constructor
+      · intro hP
+        exact ⟨P - P₀, by rw [smul_sub, hP, hP₀, sub_self], sub_add_cancel P P₀⟩
+      · rintro ⟨S, hS, rfl⟩
+        rw [smul_add, hS, hP₀, zero_add]
+    rw [hts, Finset.sum_image (fun a _ b _ h => add_right_cancel h), Finset.sum_add_distrib,
+      Finset.sum_const, card_torsion_toFinset W hn,
+      WeierstrassCurve.sum_eq_zero_of_forall_mem_iff_smul_eq_zero W hn t ?_, zero_add]
+    · rw [pow_two, mul_nsmul', ← natCast_zsmul P₀, hP₀, ← natCast_zsmul T, hT]
+    · intro P
+      rw [ht, Set.Finite.mem_toFinset, Set.mem_ofPred_eq, natCast_zsmul]
+  · have h0 : s = ∅ := by
+      rw [Finset.eq_empty_iff_forall_notMem]
+      intro P hP
+      rw [hs, Set.Finite.mem_toFinset, mem_fibSet] at hP
+      exact hne ⟨P, hP⟩
+    rw [h0, Finset.sum_empty]
+
+variable [IsDedekindDomain (W⁄K).CoordinateRing]
+
+omit [IsAlgClosed K] [W.IsElliptic] in
+theorem intValuation_of_span_eq_prod (s : Finset (W⁄K).Point) {r : (W⁄K).CoordinateRing}
+    (hr : Ideal.span {r} = ∏ P ∈ s, placeIdeal W K P) (P₁ : (W⁄K).Point) (hP₁ : P₁ ≠ 0) :
+    (placeOf W K P₁ hP₁).intValuation r = if P₁ ∈ s then exp (-1) else 1 := by
+  classical
+  set v := placeOf W K P₁ hP₁ with hv
+  have hI0 : ∀ P ∈ s, placeIdeal W K P ≠ 0 := by
+    intro P _ h0
+    by_cases hP : P = 0
+    · rw [hP, placeIdeal_zero, Ideal.zero_eq_bot] at h0
+      exact top_ne_bot h0
+    · rw [placeIdeal_of_ne_zero W K hP, Ideal.zero_eq_bot] at h0
+      exact (placeOf W K P hP).ne_bot h0
+  have hr0 : r ≠ 0 := by
+    intro h
+    rw [h, Ideal.span_singleton_eq_bot.mpr rfl, eq_comm, ← Ideal.zero_eq_bot,
+      Finset.prod_eq_zero_iff] at hr
+    obtain ⟨P, hP, h0⟩ := hr
+    exact hI0 P hP h0
+  have hle : ∀ P ∈ s, placeIdeal W K P ≤ v.asIdeal → P = P₁ := by
+    intro P _ hPle
+    by_cases hP0 : P = 0
+    · exfalso
+      rw [hP0, placeIdeal_zero, top_le_iff] at hPle
+      exact v.isPrime.ne_top hPle
+    · rw [placeIdeal_of_ne_zero W K hP0] at hPle
+      have heq : (placeOf W K P hP0).asIdeal = v.asIdeal :=
+        (placeOf W K P hP0).isMaximal.eq_of_le v.isPrime.ne_top hPle
+      exact placeOf_injective W K hP0 hP₁ (HeightOneSpectrum.ext heq)
+  by_cases hmem : P₁ ∈ s
+  · rw [ite_eq_left hmem]
+    have hsplit := Finset.prod_eq_mul_prod_sdiff_singleton_of_mem hmem (fun P => placeIdeal W K P)
+    have hmem1 : r ∈ v.asIdeal ^ 1 := by
+      rw [pow_one, ← Ideal.span_singleton_le_iff_mem, hr, hsplit, hv, ← placeIdeal_of_ne_zero W K
+        hP₁]
+      exact Ideal.mul_le_left
+    have hnot2 : r ∉ v.asIdeal ^ 2 := by
+      intro h2
+      rw [← Ideal.dvd_span_singleton, hr, hsplit, placeIdeal_of_ne_zero W K hP₁, ← hv, sq] at h2
+      have h3 : v.asIdeal ∣ ∏ P ∈ s \ {P₁}, placeIdeal W K P :=
+        (mul_dvd_mul_iff_left v.ne_bot).mp h2
+      rw [Ideal.dvd_iff_le] at h3
+      obtain ⟨P, hPs, hPle⟩ := (Ideal.IsPrime.prod_le v.isPrime).mp h3
+      have hPP := hle P (Finset.mem_sdiff.mp hPs).1 hPle
+      exact (Finset.mem_sdiff.mp hPs).2 (Finset.mem_singleton.mpr hPP)
+    have hle1 : v.intValuation r ≤ exp (-((1 : ℕ) : ℤ)) :=
+      (intValuation_le_pow_iff_mem v r 1).mpr hmem1
+    have hgt2 : ¬ v.intValuation r ≤ exp (-((2 : ℕ) : ℤ)) := fun h =>
+      hnot2 ((intValuation_le_pow_iff_mem v r 2).mp h)
+    obtain ⟨z, hz⟩ : ∃ z : ℤ, v.intValuation r = exp z :=
+      ⟨_, (exp_log (intValuation_ne_zero v r hr0)).symm⟩
+    rw [hz] at hle1 hgt2 ⊢
+    rw [exp_le_exp] at hle1 hgt2
+    push_cast at hle1 hgt2
+    congr 1
+    omega
+  · rw [ite_eq_right hmem, intValuation_eq_one_iff]
+    intro hrv
+    rw [← Ideal.span_singleton_le_iff_mem, hr] at hrv
+    obtain ⟨P, hPs, hPle⟩ := (Ideal.IsPrime.prod_le v.isPrime).mp hrv
+    exact hmem (hle P hPs hPle ▸ hPs)
+
+omit [IsDedekindDomain (W⁄K).CoordinateRing] in
+theorem fibIdeal_isPrincipal {n : ℕ} (hn : (n : K) ≠ 0) {T : (W⁄K).Point}
+    (hT : (n : ℤ) • T = 0) : (fibIdeal W K n T).IsPrincipal := by
+  classical
+  have hfin := fibSet_finite W hn T
+  rw [fibIdeal_eq W K hfin]
+  set s := hfin.toFinset with hs
+  let s' : Finset {P : (W⁄K).Point // P ≠ 0} := s.subtype (· ≠ 0)
+  have hprod1 : (∏ P ∈ s, placeIdeal W K P) = ∏ i ∈ s', placeIdeal W K i.1 := by
+    rw [Finset.prod_subtype_eq_prod_filter, Finset.prod_filter_of_ne]
+    intro P _ hP1 hP0
+    exact hP1 (by rw [hP0, placeIdeal_zero, Ideal.one_eq_top])
+  have key :=
+    (WeierstrassCurve.Affine.CoordinateRing.isPrincipal_prod_XYIdeal_zpow_iff (W := W⁄K) s'
+    (fun i => i.1.xc) (fun i => i.1.yc) (fun i => Point.nonsingular_xc_yc i.2) (fun _ => 1)).mpr ?_
+  · have hcoe : ((∏ i ∈ s', CoordinateRing.XYIdeal' (Point.nonsingular_xc_yc i.2) ^ (1 : ℤ) :
+        (FractionalIdeal (W⁄K).CoordinateRing⁰ (W⁄K).FunctionField)ˣ) :
+        FractionalIdeal (W⁄K).CoordinateRing⁰ (W⁄K).FunctionField) =
+        ((∏ P ∈ s, placeIdeal W K P : Ideal (W⁄K).CoordinateRing) :
+          FractionalIdeal (W⁄K).CoordinateRing⁰ (W⁄K).FunctionField) := by
+      rw [Units.coe_prod, hprod1]
+      have hmap := map_prod (FractionalIdeal.coeIdealHom (W⁄K).CoordinateRing⁰ (W⁄K).FunctionField)
+        (fun i : {P : (W⁄K).Point // P ≠ 0} => placeIdeal W K i.1) s'
+      change _ = FractionalIdeal.coeIdealHom (W⁄K).CoordinateRing⁰ (W⁄K).FunctionField _
+      rw [hmap]
+      refine Finset.prod_congr rfl fun i _ => ?_
+      rw [zpow_one, CoordinateRing.XYIdeal'_eq, placeIdeal_of_ne_zero W K i.2]
+      rfl
+    have key' := key
+    rw [hcoe, FractionalIdeal.coe_coeIdeal] at key'
+    exact (IsLocalization.coeSubmodule_isPrincipal _ le_rfl).mp key'
+  · have hpt : ∀ i : {P : (W⁄K).Point // P ≠ 0},
+        Point.some i.1.xc i.1.yc (Point.nonsingular_xc_yc i.2) = i.1 := fun i =>
+          (Point.eq_some_xc_yc i.2).symm
+    simp_rw [one_smul, hpt]
+    have hsub : ∑ x ∈ s', (x : (W⁄K).Point) = ∑ P ∈ s.filter (· ≠ 0), P :=
+      Finset.sum_subtype_eq_sum_filter (fun P : (W⁄K).Point => P)
+    rw [hsub, Finset.sum_filter_of_ne (fun P _ hP => hP)]
+    exact sum_fibSet_eq_zero W hn hT
+
+omit [IsDedekindDomain (W⁄K).CoordinateRing] in
+theorem span_weilNum_eq {n : ℕ} (hn : (n : K) ≠ 0) {T : (W⁄K).Point} (hT : (n : ℤ) • T = 0) :
+    Ideal.span {weilNum W K n T} = ∏ P ∈ (WeierstrassCurve.Affine.fibSet_finite W hn T).toFinset,
+      placeIdeal W K P := by
+  rw [span_weilNum W K (fibIdeal_isPrincipal W hn hT), fibIdeal_eq]
+
+end WeilDiv
+
+theorem solution {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K]
+    (W : WeierstrassCurve F) [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ}
+    (hn : (n : K) ≠ 0) {T : (W⁄K).Point} (hT : (n : ℤ) • T = 0) (P : (W⁄K).Point) (hP : P ≠ 0) :
+    (placeOf W K P hP).valuation (W⁄K).FunctionField (algebraMap (W⁄K).CoordinateRing
+      (W⁄K).FunctionField (weilNum W K n T)) = if (n : ℤ) • P = T then exp (-1 : ℤ) else 1 := by
+  classical
+  rw [valuation_of_algebraMap, WeilDiv.intValuation_of_span_eq_prod W _ (WeilDiv.span_weilNum_eq W
+    hn hT) P hP]
+  simp only [Set.Finite.mem_toFinset, mem_fibSet]
+
+end S_WeierstrassCurve_Affine_valuation_weilNum
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_valuation_weilNum (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain WithZero
+
+theorem WeierstrassCurve.Affine.valuation_weilNum {F K : Type*} [Field F] [Field K] [Algebra F K]
+    [DecidableEq K] [IsAlgClosed K] (W : WeierstrassCurve F) [W.IsElliptic]
+    [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ} (hn : (n : K) ≠ 0) {T : (W⁄K).Point}
+    (hT : (n : ℤ) • T = 0) (P : (W⁄K).Point) (hP : P ≠ 0) :
+    (placeOf W K P hP).valuation (W⁄K).FunctionField (algebraMap (W⁄K).CoordinateRing
+      (W⁄K).FunctionField (weilNum W K n T)) = if (n : ℤ) • P = T then exp (-1 : ℤ) else 1 :=
+  solution W hn hT P hP
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_weilFun_ne_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_weilFun_ne_zero.lean
new file mode 100644
index 0000000000..0d4efeda4f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_weilFun_ne_zero.lean
@@ -0,0 +1,97 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.weilFun_ne_zero
+(999c93b5-5236-5294-9ada-65ba22f44d87) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e65112f7-f540-5cfd-8a71-dd2eefdb600b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_WeilPairingFun
+
+import Mathlib.Data.Set.Card
+import Mathlib.Algebra.BigOperators.Group.Finset.Piecewise
+import Mathlib.Tactic.Ring
+import Mathlib.Tactic.FieldSimp
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_weilNum_ne_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Nonvanishing of the Weil function g_T for T ∈ E[n]
+
+Theorem statement: `WeierstrassCurve.Affine.weilFun_ne_zero`
+(`999c93b5-5236-5294-9ada-65ba22f44d87`), by Claude, 2026-09-05.
+
+Proof: submission `e65112f7-f540-5cfd-8a71-dd2eefdb600b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra, $K$ algebraically closed, and let $W$ be a
+Weierstrass curve over $F$ which is elliptic, such that the affine coordinate ring of the base
+change $W⁄K$ is a Dedekind domain. Let $n$ be a natural number whose image in $K$ is nonzero, and
+let $T$ be a point of $W⁄K$ annihilated by $n$, i.e. $(n : \mathbb{Z}) \bullet T = 0$. The assertion
+is that the element `weilFun W K n T` of the function field of $W⁄K$ is nonzero. By definition this
+element is the quotient, in the function field, of the images of `weilNum W K n T` and `weilNum W K
+n 0` under the map from the coordinate ring, where for an integer $m$ and a point $S$ the element
+`weilNum W K m S` is a chosen generator of the ideal `fibIdeal W K m S` of the coordinate ring when
+that ideal is principal, and $1$ otherwise. Thus the conclusion says that the numerator attached to
+$T$ and the denominator attached to the zero point are both nonzero, so that their ratio is a
+nonzero element of $K(E)$.
+
+This is the first step in the construction of the Weil pairing on $n$-torsion: the function $g_T =
+P_T/P_O$ of Silverman's treatment is a well-defined nonzero element of the function field, so that
+its divisor and its behaviour under translation and under field automorphisms can be analysed. It is
+used by the statements comparing `weilFun` along algebra homomorphisms, under translation by torsion
+points, and under isomorphisms of the underlying curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_weilFun_ne_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_weilFun_ne_zero
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain IsDedekindDomain.HeightOneSpectrum
+  WithZero
+open scoped nonZeroDivisors
+
+theorem solution {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K]
+    (W : WeierstrassCurve F) [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ}
+    (hn : (n : K) ≠ 0) {T : (W⁄K).Point} (hT : (n : ℤ) • T = 0) :
+    weilFun W K n T ≠ 0 := by
+  rw [weilFun]
+  exact div_ne_zero
+    ((map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr
+      (WeierstrassCurve.Affine.weilNum_ne_zero W hn hT))
+    ((map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr
+      (WeierstrassCurve.Affine.weilNum_ne_zero W hn (smul_zero _)))
+
+end S_WeierstrassCurve_Affine_weilFun_ne_zero
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_weilFun_ne_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain WithZero
+
+theorem WeierstrassCurve.Affine.weilFun_ne_zero {F K : Type*} [Field F] [Field K] [Algebra F K]
+    [DecidableEq K] [IsAlgClosed K] (W : WeierstrassCurve F) [W.IsElliptic]
+    [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ} (hn : (n : K) ≠ 0) {T : (W⁄K).Point}
+    (hT : (n : ℤ) • T = 0) :
+    weilFun W K n T ≠ 0 :=
+  solution W hn hT
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_weilNum_ne_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_weilNum_ne_zero.lean
new file mode 100644
index 0000000000..b4a67cdc66
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_weilNum_ne_zero.lean
@@ -0,0 +1,96 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.weilNum_ne_zero
+(855010c9-f5d4-5361-8cb5-5b47dac9e5d0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 76ce5626-9855-5234-9553-e87e40386b95
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_WeilPairingFun
+
+import Mathlib.Data.Set.Card
+import Mathlib.Algebra.BigOperators.Group.Finset.Piecewise
+import Mathlib.Tactic.Ring
+import Mathlib.Tactic.FieldSimp
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_weilNum
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Non-vanishing of the Weil numerator at n-torsion
+
+Theorem statement: `WeierstrassCurve.Affine.weilNum_ne_zero`
+(`855010c9-f5d4-5361-8cb5-5b47dac9e5d0`), by Claude, 2026-09-05.
+
+Proof: submission `76ce5626-9855-5234-9553-e87e40386b95`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra, $K$ algebraically closed, let $W$ be a
+Weierstrass curve over $F$ which is elliptic, and assume the coordinate ring of the base change
+$W⁄K$ is a Dedekind domain. Let $n$ be a natural number whose image in $K$ is nonzero, and let $T$
+be a point of $(W⁄K)$ with $(n : \mathbb{Z}) \cdot T = 0$. Then the element `weilNum W K n T` of the
+coordinate ring $(W⁄K)$`.CoordinateRing` is nonzero. Here `weilNum W K n T` is, by definition, a
+chosen generator of the ideal `fibIdeal W K n T` in case that ideal is principal, and $1$ otherwise;
+and `fibIdeal W K n T` is the product of the place ideals `placeIdeal W K P` over the points $P$ in
+the fibre `fibSet W K n T` when that set is finite, and the unit ideal $\top$ otherwise. Thus the
+assertion is that the distinguished generator attached to the fibre of multiplication by $n$ above
+an $n$-torsion point $T$ is not the zero element.
+
+This is the first step in the construction of the Weil pairing via divisors: the numerator $P_T$
+whose divisor is the fibre $[n]^{-1}(T)$ must be a genuine nonzero function on the curve. It is used
+by the statements computing valuations and local expansions of the Weil function, and in the
+constructions producing the pairing from a basis of the $n$-torsion.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_weilNum_ne_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_weilNum_ne_zero
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain IsDedekindDomain.HeightOneSpectrum
+  WithZero
+open scoped nonZeroDivisors
+
+theorem solution {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K]
+    (W : WeierstrassCurve F) [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ}
+    (hn : (n : K) ≠ 0) {T : (W⁄K).Point} (hT : (n : ℤ) • T = 0) :
+    weilNum W K n T ≠ 0 := by
+  intro h0
+  obtain ⟨P, hP, -⟩ := exists_point_xc_eq W K (0 : K)
+  have h := WeierstrassCurve.Affine.valuation_weilNum W hn hT P hP
+  rw [h0, _root_.map_zero, Valuation.map_zero] at h
+  split_ifs at h
+  · exact WithZero.zero_ne_coe h
+  · exact zero_ne_one h
+
+end S_WeierstrassCurve_Affine_weilNum_ne_zero
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_weilNum_ne_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain WithZero
+
+theorem WeierstrassCurve.Affine.weilNum_ne_zero {F K : Type*} [Field F] [Field K] [Algebra F K]
+    [DecidableEq K] [IsAlgClosed K] (W : WeierstrassCurve F) [W.IsElliptic]
+    [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ} (hn : (n : K) ≠ 0) {T : (W⁄K).Point}
+    (hT : (n : ℤ) • T = 0) :
+    weilNum W K n T ≠ 0 :=
+  solution W hn hT
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_weilPairing0_add_left.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_weilPairing0_add_left.lean
new file mode 100644
index 0000000000..f3cd84b898
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_weilPairing0_add_left.lean
@@ -0,0 +1,121 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.weilPairing0_add_left
+(d88a7ffc-2012-5fc9-875c-d348fbe7cc18) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 0dd5d3ef-3ee2-5e32-a678-ceed9023d8c5
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_WeilPairingFun
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_transEquiv_weilFun_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_weilFun_ne_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Multiplicativity of e₀ in the first variable
+
+Theorem statement: `WeierstrassCurve.Affine.weilPairing0_add_left`
+(`d88a7ffc-2012-5fc9-875c-d348fbe7cc18`), by Claude, 2026-09-05.
+
+Proof: submission `0dd5d3ef-3ee2-5e32-a678-ceed9023d8c5`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra, $K$ algebraically closed, let $W$ be a
+Weierstrass curve over $F$ which is elliptic, and assume the coordinate ring of the base change
+$W\!\restriction_K$ is a Dedekind domain. Let $n$ be a natural number whose image in $K$ is nonzero,
+and let $S$, $S'$, $T$ be points of the group $(W⁄K).\mathrm{Point}$ with $n\cdot S = n\cdot S' =
+n\cdot T = 0$ (scalar multiplication by $(n : \mathbb{Z})$). Here
+$\mathrm{weilPairing0}\,W\,K\,n\,S\,T \in K^\times$ is defined to be a chosen unit $c$ such that the
+automorphism $\mathrm{transEquiv}\,W\,K\,S$ of the function field of $W\!\restriction_K$ (the
+algebra automorphism obtained from pullback along translation by $S$, with inverse the pullback
+along translation by $-S$) sends $\mathrm{weilFun}\,W\,K\,n\,T$ — the ratio of the images in the
+function field of $\mathrm{weilNum}\,W\,K\,n\,T$ and of $\mathrm{weilNum}\,W\,K\,n\,0$ — to $c \cdot
+\mathrm{weilFun}\,W\,K\,n\,T$, and $1$ if no such unit exists. The conclusion is the identity
+$\mathrm{weilPairing0}\,W\,K\,n\,(S+S')\,T = \mathrm{weilPairing0}\,W\,K\,n\,S\,T \cdot
+\mathrm{weilPairing0}\,W\,K\,n\,S'\,T$ in $K^\times$.
+
+This is bilinearity of the Weil pairing in its first argument, at the level of the scalar attached
+to the translation-invariance of the function $g_T$. It feeds the group-theoretic properties of the
+$n$-torsion pairing used later in the analysis of level structures on modular curves, in particular
+the determinant computations for the action on full-level and $\Gamma_0$-type structures.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_weilPairing0_add_left.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_weilPairing0_add_left
+
+p2m_open "WeierstrassCurve P2MW.S_WeierstrassCurve_Affine_weilPairing0_add_left.WeierstrassCurve \
+  WeierstrassCurve.Affine \
+  P2MW.S_WeierstrassCurve_Affine_weilPairing0_add_left.WeierstrassCurve.Affine IsDedekindDomain \
+  WithZero"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "CoordinateRing FunctionField Point weilFun weilPairing0 \
+  transEquiv_weilFun transEquiv transEquiv_add exists_transEquiv_weilFun_eq weilFun_ne_zero"
+namespace LawAddL
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+variable {F : Type*} {K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K]
+  (W : WeierstrassCurve F) [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing]
+
+theorem weilPairing0_eq {n : ℕ} (hn : (n : K) ≠ 0) {S T : (W⁄K).Point} (hT : (n : ℤ) • T = 0)
+    {c : Kˣ}
+    (h : transEquiv W K S (weilFun W K n T) = algebraMap K (W⁄K).FunctionField (c : K) * weilFun W K
+      n T) :
+    weilPairing0 W K n S T = c := by
+  have h' := transEquiv_weilFun W K ⟨c, h⟩
+  rw [h] at h'
+  have := mul_right_cancel₀ (weilFun_ne_zero W hn hT) h'
+  exact Units.ext ((algebraMap K (W⁄K).FunctionField).injective this).symm
+
+end WeierstrassCurve.Affine.LawAddL
+
+open WeierstrassCurve.Affine.LawAddL in
+theorem solution {F : Type*} {K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K]
+    [IsAlgClosed K] (W : WeierstrassCurve F) [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing]
+    {n : ℕ} (hn : (n : K) ≠ 0) (S S' T : (W⁄K).Point) (hS : (n : ℤ) • S = 0)
+    (hS' : (n : ℤ) • S' = 0) (hT : (n : ℤ) • T = 0) :
+    weilPairing0 W K n (S + S') T = weilPairing0 W K n S T * weilPairing0 W K n S' T := by
+  have h1 := transEquiv_weilFun W K (exists_transEquiv_weilFun_eq W hn S T hS hT)
+  have h2 := transEquiv_weilFun W K (exists_transEquiv_weilFun_eq W hn S' T hS' hT)
+  apply weilPairing0_eq W hn hT
+  rw [transEquiv_add, AlgEquiv.trans_apply, h2, map_mul, AlgEquiv.commutes, h1, Units.val_mul,
+    map_mul]
+  ring
+
+end S_WeierstrassCurve_Affine_weilPairing0_add_left
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_weilPairing0_add_left (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain WithZero
+
+theorem WeierstrassCurve.Affine.weilPairing0_add_left {F : Type*} {K : Type*} [Field F] [Field K]
+    [Algebra F K] [DecidableEq K] [IsAlgClosed K] (W : WeierstrassCurve F) [W.IsElliptic]
+    [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ} (hn : (n : K) ≠ 0) (S S' T : (W⁄K).Point)
+    (hS : (n : ℤ) • S = 0) (hS' : (n : ℤ) • S' = 0) (hT : (n : ℤ) • T = 0) :
+    weilPairing0 W K n (S + S') T = weilPairing0 W K n S T * weilPairing0 W K n S' T :=
+  solution W hn S S' T hS hS' hT
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_weilPairing0_add_right.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_weilPairing0_add_right.lean
new file mode 100644
index 0000000000..d5d737c0a7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_weilPairing0_add_right.lean
@@ -0,0 +1,187 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.weilPairing0_add_right
+(f2e959bd-cbfa-50ec-aa11-c646455687d4) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9f959fdc-4755-5722-ada7-9dcfef3cdc90
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_WeilPairingFun
+
+import Mathlib.Data.Set.Card
+import Mathlib.Algebra.BigOperators.Group.Finset.Piecewise
+import Mathlib.Tactic.Ring
+import Mathlib.Tactic.FieldSimp
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_exists_zsmul_eq_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_exists_eq_algebraMap_of_valuation_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_transEquiv_weilFun
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_transEquiv_weilFun_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_weilFun_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_weilFun
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Additivity of e₀(S,·) in the second variable
+
+Theorem statement: `WeierstrassCurve.Affine.weilPairing0_add_right`
+(`f2e959bd-cbfa-50ec-aa11-c646455687d4`), by Claude, 2026-09-05.
+
+Proof: submission `9f959fdc-4755-5722-ada7-9dcfef3cdc90`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra, $K$ algebraically closed, let $W$ be a
+Weierstrass curve over $F$ that is elliptic, and assume that the coordinate ring of the base change
+$W\!\mathbin{/\!\!/}K$ is a Dedekind domain. Let $n$ be a natural number with $n \neq 0$ in $K$, and
+let $S, T, T'$ be points of $(W\!\mathbin{/\!\!/}K)$ each annihilated by $n$, i.e. $(n:\mathbb{Z})
+\bullet S = 0$, $(n:\mathbb{Z}) \bullet T = 0$ and $(n:\mathbb{Z}) \bullet T' = 0$. Recall that
+`weilPairing0 W K n S T` is the unit $c \in K^\times$ selected from a proof that the translation
+automorphism `transEquiv W K S` of the function field of $W\!\mathbin{/\!\!/}K$ sends `weilFun W K n
+T` to $c \cdot$ `weilFun W K n T`, where `weilFun W K n T` is the quotient of the images of `weilNum
+W K n T` and `weilNum W K n 0` in the function field, and is $1$ if no such unit exists. The
+assertion is the equality of units $$e_0(S, T + T') = e_0(S,T)\, e_0(S,T')$$ for $e_0 =$
+`weilPairing0 W K n`.
+
+This is additivity of the Weil pairing in its second argument (Silverman, AEC III.8, Prop. 8.1(a)),
+here for the point-level pairing `weilPairing0` built from translation of the functions $g_T$. It is
+used in the treatment of full-level structures on modular curves, for instance in the
+level-relabelling results identifying elements of $\Gamma$ by their effect on the pairing and in the
+determinant computations attached to them.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_weilPairing0_add_right.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_weilPairing0_add_right
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain IsDedekindDomain.HeightOneSpectrum
+  WithZero
+open scoped nonZeroDivisors
+
+namespace WeilLaws
+
+variable {F : Type*} [Field F] {K : Type*} [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K]
+  (W : WeierstrassCurve F) [W.IsElliptic]
+  [IsDedekindDomain (W⁄K).CoordinateRing]
+
+omit [IsDedekindDomain (W⁄K).CoordinateRing] in
+theorem transEquiv_transEquiv (S T : (W⁄K).Point) (h : (W⁄K).FunctionField) :
+    transEquiv W K S (transEquiv W K T h) = transEquiv W K (S + T) h := by
+  rw [transEquiv_add, AlgEquiv.trans_apply]
+
+omit [IsDedekindDomain (W⁄K).CoordinateRing] in
+theorem transEquiv_comm (S T : (W⁄K).Point) (h : (W⁄K).FunctionField) :
+    transEquiv W K S (transEquiv W K T h) = transEquiv W K T (transEquiv W K S h) := by
+  rw [transEquiv_transEquiv, transEquiv_transEquiv, add_comm]
+
+omit [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing] in
+theorem const_unique {g : (W⁄K).FunctionField} (hg : g ≠ 0) {c c' : K}
+    (h : algebraMap K (W⁄K).FunctionField c * g = algebraMap K (W⁄K).FunctionField c' * g) :
+    c = c' :=
+  (algebraMap K (W⁄K).FunctionField).injective (mul_right_cancel₀ hg h)
+
+theorem weilPairing0_eq_of {n : ℕ} (hn : (n : K) ≠ 0) {S T : (W⁄K).Point} (hT : (n : ℤ) • T = 0)
+    {c : Kˣ} (h : transEquiv W K S (weilFun W K n T) =
+      algebraMap K (W⁄K).FunctionField (c : K) * weilFun W K n T) :
+    weilPairing0 W K n S T = c := by
+  have h' := transEquiv_weilFun W K ⟨c, h⟩
+  rw [h] at h'
+  exact (Units.ext (const_unique W (WeierstrassCurve.Affine.weilFun_ne_zero W hn hT) h')).symm
+
+omit [DecidableEq K] in
+theorem exists_eq_algebraMap {f : (W⁄K).FunctionField}
+    (hf : ∀ (P : (W⁄K).Point) (hP : P ≠ 0), (placeOf W K P hP).valuation (W⁄K).FunctionField f =
+      1) :
+    ∃ c : K, c ≠ 0 ∧ f = algebraMap K (W⁄K).FunctionField c := by
+  apply WeierstrassCurve.Affine.FunctionField.exists_eq_algebraMap_of_valuation_eq_one (W := W⁄K)
+  intro v
+  obtain ⟨P, hP, rfl⟩ := placeOf_surjective W K v
+  exact hf P hP
+
+end WeilLaws
+
+theorem solution {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K]
+    (W : WeierstrassCurve F) [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ}
+    (hn : (n : K) ≠ 0) (S T T' : (W⁄K).Point) (hS : (n : ℤ) • S = 0) (hT : (n : ℤ) • T = 0)
+    (hT' : (n : ℤ) • T' = 0) :
+    weilPairing0 W K n S (T + T') = weilPairing0 W K n S T * weilPairing0 W K n S T' := by
+  classical
+  have : (W⁄K).IsElliptic := by
+    dsimp only [Affine.baseChange, WeierstrassCurve.baseChange]; infer_instance
+  have hn0 : (n : ℤ) ≠ 0 := by
+    have : n ≠ 0 := by rintro rfl; exact hn Nat.cast_zero
+    exact_mod_cast this
+  have hTsum : (n : ℤ) • (T + T') = 0 := by rw [smul_add, hT, hT', add_zero]
+  obtain ⟨T₁', hT₁'⟩ := WeierstrassCurve.Affine.Point.exists_zsmul_eq_of_isAlgClosed (W⁄K) hn0 T
+  set gT := weilFun W K n T
+  set gT2 := weilFun W K n T'
+  set gsum := weilFun W K n (T + T')
+  set h := gT * transEquiv W K (-T₁') gT2 with hh
+  have hh0 : h ≠ 0 := mul_ne_zero (WeierstrassCurve.Affine.weilFun_ne_zero W hn hT)
+    ((map_ne_zero_iff _ (transEquiv W K _).injective).mpr (WeierstrassCurve.Affine.weilFun_ne_zero W
+      hn hT'))
+  have hg0 : gsum ≠ 0 := WeierstrassCurve.Affine.weilFun_ne_zero W hn hTsum
+  have hval : ∀ (P : (W⁄K).Point) (hP : P ≠ 0),
+      (placeOf W K P hP).valuation (W⁄K).FunctionField (gsum / h) = 1 := by
+    intro P hP
+    rw [map_div₀, hh, map_mul, WeierstrassCurve.Affine.valuation_weilFun W hn hTsum P hP,
+      WeierstrassCurve.Affine.valuation_weilFun W hn hT P hP,
+      WeierstrassCurve.Affine.valuation_transEquiv_weilFun W hn _ hT' P hP]
+    have e1 : ((n : ℤ) • (P + -T₁') = T') = ((n : ℤ) • P = T + T') := by
+      rw [smul_add, smul_neg, hT₁', ← sub_eq_add_neg, sub_eq_iff_eq_add, add_comm T' T]
+    have e2 : ((n : ℤ) • (P + -T₁') = 0) = ((n : ℤ) • P = T) := by
+      rw [smul_add, smul_neg, hT₁', ← sub_eq_add_neg, sub_eq_zero]
+    simp only [e1, e2]
+    have hne : ∀ c : Prop, ∀ [Decidable c], (if c then (exp (-1 : ℤ) : ℤᵐ⁰) else 1) ≠ 0 := by
+      intro c _; split_ifs; exacts [WithZero.coe_ne_zero, one_ne_zero]
+    have key : ∀ A B C : ℤᵐ⁰, A ≠ 0 → B ≠ 0 → C ≠ 0 → A / B / (C / B * (A / C)) = 1 := by
+      intro A B C hA hB hC
+      rw [div_mul_div_comm, mul_comm C A, mul_div_mul_right _ _ hC, div_self (div_ne_zero hA hB)]
+    exact key _ _ _ (hne _) (hne _) (hne _)
+  obtain ⟨c, hc0, hc⟩ := WeilLaws.exists_eq_algebraMap W hval
+  have hgh : gsum = algebraMap K _ c * h := by
+    rw [← hc, div_mul_cancel₀ _ hh0]
+  obtain ⟨c₁, hc₁⟩ := WeierstrassCurve.Affine.exists_transEquiv_weilFun_eq W hn S T hS hT
+  obtain ⟨c₂, hc₂⟩ := WeierstrassCurve.Affine.exists_transEquiv_weilFun_eq W hn S T' hS hT'
+  have h1 := WeilLaws.weilPairing0_eq_of W hn hT hc₁
+  have h2 := WeilLaws.weilPairing0_eq_of W hn hT' hc₂
+  have key : transEquiv W K S gsum = algebraMap K _ ((c₁ * c₂ : Kˣ) : K) * gsum := by
+    conv_lhs => rw [hgh, hh]
+    rw [map_mul, map_mul, AlgEquiv.commutes, hc₁, WeilLaws.transEquiv_comm, hc₂, map_mul,
+      AlgEquiv.commutes]
+    conv_rhs => rw [hgh, hh]
+    rw [Units.val_mul, map_mul]
+    ring
+  rw [WeilLaws.weilPairing0_eq_of W hn hTsum key, h1, h2]
+
+end S_WeierstrassCurve_Affine_weilPairing0_add_right
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_weilPairing0_add_right (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain WithZero
+
+theorem WeierstrassCurve.Affine.weilPairing0_add_right {F K : Type*} [Field F] [Field K]
+    [Algebra F K] [DecidableEq K] [IsAlgClosed K] (W : WeierstrassCurve F) [W.IsElliptic]
+    [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ} (hn : (n : K) ≠ 0) (S T T' : (W⁄K).Point)
+    (hS : (n : ℤ) • S = 0) (hT : (n : ℤ) • T = 0) (hT' : (n : ℤ) • T' = 0) :
+    weilPairing0 W K n S (T + T') = weilPairing0 W K n S T * weilPairing0 W K n S T' :=
+  solution W hn S T T' hS hT hT'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_weilPairing0_galois.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_weilPairing0_galois.lean
new file mode 100644
index 0000000000..a0536e4a0a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_weilPairing0_galois.lean
@@ -0,0 +1,326 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.weilPairing0_galois
+(171751e8-3f74-5ac4-bd3d-1dd2af778e33) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4e2d45d6-c748-57a9-ae24-7d1a0a120f8d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_WeilPairingFun
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_GaloisRep
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_transEquiv_weilFun_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_weilFun_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_map_weilFun_eq_mul_weilFun_smul
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Galois equivariance of the Weil pairing e₀
+
+Theorem statement: `WeierstrassCurve.Affine.weilPairing0_galois`
+(`171751e8-3f74-5ac4-bd3d-1dd2af778e33`), by Claude, 2026-09-05.
+
+Proof: submission `4e2d45d6-c748-57a9-ae24-7d1a0a120f8d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra, $K$ algebraically closed, let $W$ be a
+Weierstrass curve over $F$ that is elliptic, and assume the coordinate ring of the base change $W⁄K$
+is a Dedekind domain. Let $n$ be a natural number whose image in $K$ is nonzero, let $\sigma$ be an
+$F$-algebra automorphism of $K$, and let $S,T$ be points of the affine curve $W⁄K$ killed by $n$,
+i.e. $(n:\mathbb{Z})\cdot S=0$ and $(n:\mathbb{Z})\cdot T=0$. Here $e_0(S,T)=$ `weilPairing0 W K n S
+T` is the unit of $K$ chosen so that, whenever such a unit exists, translation by $S$ on the
+function field of $W⁄K$ (the automorphism `transEquiv W K S`, built from the translation pull-backs
+along $S$ and $-S$) multiplies the function `weilFun W K n T` — the quotient of the images of
+`weilNum W K n T` and `weilNum W K n 0` in the function field — by the scalar $e_0(S,T)$, and is $1$
+otherwise. The conclusion is that $e_0(\sigma\cdot S,\sigma\cdot T)$, viewed in $K$, equals
+$\sigma\bigl(e_0(S,T)\bigr)$.
+
+This is the Galois equivariance (Galois invariance) of the Weil pairing in its point-level form: the
+pairing on $n$-torsion commutes with the action of $\operatorname{Aut}(K/F)$ on points and on
+scalars. It is used in the construction of the Galois-equivariant Weil pairing on $n$-torsion, and
+thence in identifying the determinant of the mod-$n$ representation with the cyclotomic character.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_weilPairing0_galois.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_weilPairing0_galois
+
+p2m_open "WeierstrassCurve P2MW.S_WeierstrassCurve_Affine_weilPairing0_galois.WeierstrassCurve \
+  WeierstrassCurve.Affine \
+  P2MW.S_WeierstrassCurve_Affine_weilPairing0_galois.WeierstrassCurve.Affine IsDedekindDomain \
+  WithZero"
+open Polynomial
+open scoped Polynomial.Bivariate
+
+section GalRing
+
+variable {F K : Type*} [Field F] [Field K] [Algebra F K] (W : WeierstrassCurve F)
+
+theorem galRing_polynomial_map (σ : K ≃ₐ[F] K) :
+    (W⁄K).polynomial.map (mapRingHom (σ : K →+* K)) = (W⁄K).polynomial := by
+  have h := (baseChange_polynomial (W := W) (f := (σ : K →ₐ[F] K))).symm
+  convert h using 2
+  rfl
+
+private noncomputable def galRingHom (σ : K ≃ₐ[F] K) :
+    (W⁄K).CoordinateRing →+* (W⁄K).CoordinateRing :=
+  AdjoinRoot.lift ((AdjoinRoot.of _).comp <| mapRingHom (σ : K →+* K))
+    (AdjoinRoot.root (W⁄K).polynomial) <| by
+      rw [← eval₂_map, galRing_polynomial_map, AdjoinRoot.eval₂_root]
+
+private theorem galRingHom_mk (σ : K ≃ₐ[F] K) (p : K[X][Y]) :
+    galRingHom W σ (CoordinateRing.mk (W⁄K) p) =
+      CoordinateRing.mk (W⁄K) (p.map (mapRingHom (σ : K →+* K))) := by
+  rw [galRingHom, CoordinateRing.mk, AdjoinRoot.lift_mk, ← eval₂_map]
+  exact AdjoinRoot.aeval_eq <| p.map <| mapRingHom (σ : K →+* K)
+
+private theorem galRingHom_comp (σ τ : K ≃ₐ[F] K) (z : (W⁄K).CoordinateRing) :
+    galRingHom W σ (galRingHom W τ z) = galRingHom W (σ * τ) z := by
+  induction z using AdjoinRoot.induction_on with
+  | ih p =>
+    change galRingHom W σ (galRingHom W τ (CoordinateRing.mk (W⁄K) p)) =
+      galRingHom W (σ * τ) (CoordinateRing.mk (W⁄K) p)
+    rw [galRingHom_mk, galRingHom_mk, galRingHom_mk, Polynomial.map_map, Polynomial.mapRingHom_comp]
+    rfl
+
+private theorem galRingHom_one (z : (W⁄K).CoordinateRing) : galRingHom W 1 z = z := by
+  induction z using AdjoinRoot.induction_on with
+  | ih p =>
+    change galRingHom W 1 (CoordinateRing.mk (W⁄K) p) = CoordinateRing.mk (W⁄K) p
+    have h1 : ((1 : K ≃ₐ[F] K) : K →+* K) = RingHom.id K := RingHom.ext fun _ => rfl
+    rw [galRingHom_mk, h1, Polynomial.mapRingHom_id, Polynomial.map_id]
+
+theorem galRing_exists (σ : K ≃ₐ[F] K) :
+    ∃ φ : (W⁄K).CoordinateRing ≃+* (W⁄K).CoordinateRing, ∀ p : K[X][Y],
+      φ (CoordinateRing.mk (W⁄K) p) = CoordinateRing.mk (W⁄K) (p.map (mapRingHom (σ : K →+* K)))
+        := by
+  refine ⟨RingEquiv.ofRingHom (galRingHom W σ) (galRingHom W σ⁻¹) ?_ ?_, galRingHom_mk W σ⟩
+  · refine RingHom.ext fun z => ?_
+    rw [RingHom.comp_apply, RingHom.id_apply, galRingHom_comp, mul_inv_cancel, galRingHom_one]
+  · refine RingHom.ext fun z => ?_
+    rw [RingHom.comp_apply, RingHom.id_apply, galRingHom_comp, inv_mul_cancel, galRingHom_one]
+
+theorem galRing_map_XYIdeal (σ : K ≃ₐ[F] K) (φ : (W⁄K).CoordinateRing →+* (W⁄K).CoordinateRing)
+    (hφ : ∀ p : K[X][Y], φ (CoordinateRing.mk (W⁄K) p) =
+      CoordinateRing.mk (W⁄K) (p.map (mapRingHom (σ : K →+* K)))) (x y : K) :
+    (CoordinateRing.XYIdeal (W⁄K) x (C y)).map φ = CoordinateRing.XYIdeal (W⁄K) (σ x) (C (σ y))
+      := by
+  rw [CoordinateRing.XYIdeal, Ideal.map_span, Set.image_pair, CoordinateRing.XClass,
+    CoordinateRing.YClass, hφ, hφ]
+  simp only [Polynomial.map_sub, Polynomial.map_C, Polynomial.map_X, coe_mapRingHom,
+    RingHom.coe_coe]
+  rfl
+
+theorem galFunctionField_exists (σ : K ≃ₐ[F] K) :
+    ∃ Φ : (W⁄K).FunctionField ≃+* (W⁄K).FunctionField, ∀ p : K[X][Y],
+      Φ (algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField (CoordinateRing.mk (W⁄K) p)) =
+        algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField
+          (CoordinateRing.mk (W⁄K) (p.map (mapRingHom (σ : K →+* K)))) := by
+  obtain ⟨φ, hφ⟩ := galRing_exists W σ
+  exact ⟨IsFractionRing.ringEquivOfRingEquiv φ, fun p => by
+    rw [IsFractionRing.ringEquivOfRingEquiv_algebraMap, hφ]⟩
+
+end GalRing
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map_map map mk map_id Affine.Point baseChange"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "CoordinateRing.XYIdeal CoordinateRing Point.baseChange map \
+  baseChange CoordinateRing.YClass FunctionField Point CoordinateRing.mk Point.map \
+  CoordinateRing.XClass baseChange_polynomial Point.map_some polynomial \
+  exists_transEquiv_weilFun_eq weilFun weilPairing0 transEquiv_weilFun genericX genericY \
+  genericPoint pointHom_mk Point.xc_map Point.yc_map transEquiv transEquiv_algebraMap \
+  weilFun_ne_zero exists_map_weilFun_eq_mul_weilFun_smul Point.algEquiv_smul_def"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+section GalA
+
+variable {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K] (W : WeierstrassCurve F)
+  (σ : K ≃ₐ[F] K) (Φ : (W⁄K).FunctionField →+* (W⁄K).FunctionField)
+  (hΦ : ∀ p : K[X][Y], Φ (algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField (CoordinateRing.mk
+    (W⁄K) p)) =
+    algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField
+      (CoordinateRing.mk (W⁄K) (p.map (mapRingHom (σ : K →+* K)))))
+
+include hΦ
+
+omit [DecidableEq K] in
+theorem gal_algebraMap (c : K) :
+    Φ (algebraMap K (W⁄K).FunctionField c) = algebraMap K (W⁄K).FunctionField (σ c) := by
+  have h := hΦ (C (C c))
+  rw [Polynomial.map_C, coe_mapRingHom, Polynomial.map_C, RingHom.coe_coe] at h
+  rw [IsScalarTower.algebraMap_apply K (W⁄K).CoordinateRing (W⁄K).FunctionField c,
+    IsScalarTower.algebraMap_apply K (W⁄K).CoordinateRing (W⁄K).FunctionField (σ c)]
+  exact h
+
+omit [DecidableEq K] in
+theorem gal_algebraMap_base (c : F) :
+    Φ (algebraMap F (W⁄K).FunctionField c) = algebraMap F (W⁄K).FunctionField c := by
+  rw [IsScalarTower.algebraMap_apply F K (W⁄K).FunctionField c, gal_algebraMap W σ Φ hΦ,
+    AlgEquiv.commutes]
+
+omit [DecidableEq K] in
+theorem gal_genericX : Φ (genericX W K) = genericX W K := by
+  have h := hΦ (C X)
+  rwa [Polynomial.map_C, coe_mapRingHom, Polynomial.map_X] at h
+
+omit [DecidableEq K] in
+theorem gal_genericY : Φ (genericY W K) = genericY W K := by
+  have h := hΦ Y
+  rwa [Polynomial.map_X] at h
+
+noncomputable def galAlgHom : (W⁄K).FunctionField →ₐ[F] (W⁄K).FunctionField :=
+  { Φ with commutes' := gal_algebraMap_base W σ Φ hΦ }
+
+omit [DecidableEq K] in
+@[scoped simp] theorem galAlgHom_apply (h : (W⁄K).FunctionField) : galAlgHom W σ Φ hΦ h = Φ h := rfl
+
+omit [DecidableEq K] in
+theorem map_galAlgHom_genericPoint [W.IsElliptic] :
+    Point.map (galAlgHom W σ Φ hΦ) (genericPoint W K) = genericPoint W K := by
+  rw [genericPoint, Point.map_some]
+  congr 1
+  · exact gal_genericX W σ Φ hΦ
+  · exact gal_genericY W σ Φ hΦ
+
+theorem map_galAlgHom_baseChange (S : (W⁄K).Point) :
+    Point.map (galAlgHom W σ Φ hΦ) (Point.baseChange K (W⁄K).FunctionField S) =
+      Point.baseChange K (W⁄K).FunctionField (σ • S) := by
+  rcases S with _ | ⟨x, y, hxy⟩
+  · rfl
+  · rw [Point.algEquiv_smul_def, Point.map_some, Point.baseChange, Point.map_some, Point.map_some,
+      Point.map_some]
+    congr 1
+    · exact gal_algebraMap W σ Φ hΦ x
+    · exact gal_algebraMap W σ Φ hΦ y
+
+theorem gal_transEquiv [IsAlgClosed K] [W.IsElliptic] (S : (W⁄K).Point) (f : (W⁄K).FunctionField) :
+    Φ (transEquiv W K S f) = transEquiv W K (σ • S) (Φ f) := by
+  have hQ : Point.map (galAlgHom W σ Φ hΦ)
+      (genericPoint W K + Point.baseChange K (W⁄K).FunctionField S) =
+      genericPoint W K + Point.baseChange K (W⁄K).FunctionField (σ • S) := by
+    rw [map_add, map_galAlgHom_genericPoint, map_galAlgHom_baseChange]
+  have hx : Φ (genericPoint W K + Point.baseChange K (W⁄K).FunctionField S).xc =
+      (genericPoint W K + Point.baseChange K (W⁄K).FunctionField (σ • S)).xc := by
+    rw [← hQ, Point.xc_map (R := F) (K := F) (W := W)]
+    rfl
+  have hy : Φ (genericPoint W K + Point.baseChange K (W⁄K).FunctionField S).yc =
+      (genericPoint W K + Point.baseChange K (W⁄K).FunctionField (σ • S)).yc := by
+    rw [← hQ, Point.yc_map (R := F) (K := F) (W := W)]
+    rfl
+  suffices H : Φ.comp (transEquiv W K S : (W⁄K).FunctionField →ₐ[K] (W⁄K).FunctionField).toRingHom =
+      (transEquiv W K (σ • S) : (W⁄K).FunctionField →ₐ[K] (W⁄K).FunctionField).toRingHom.comp Φ from
+    RingHom.congr_fun H f
+  apply IsLocalization.ringHom_ext (nonZeroDivisors (W⁄K).CoordinateRing)
+  refine RingHom.ext fun a => ?_
+  induction a using AdjoinRoot.induction_on with
+  | ih g =>
+    change Φ (transEquiv W K S (algebraMap _ (W⁄K).FunctionField (CoordinateRing.mk (W⁄K) g))) =
+      transEquiv W K (σ • S) (Φ (algebraMap _ (W⁄K).FunctionField (CoordinateRing.mk (W⁄K) g)))
+    rw [transEquiv_algebraMap, pointHom_mk, hΦ, transEquiv_algebraMap, pointHom_mk,
+      Polynomial.hom_eval₂, Polynomial.eval₂_map, hy]
+    congr 1
+    apply Polynomial.ringHom_ext
+    · intro c
+      rw [RingHom.comp_apply, RingHom.comp_apply, AlgHom.toRingHom_eq_coe, RingHom.coe_coe,
+        aeval_C, gal_algebraMap W σ Φ hΦ, coe_mapRingHom, Polynomial.map_C, AlgHom.toRingHom_eq_coe,
+        RingHom.coe_coe, aeval_C]
+      rfl
+    · rw [RingHom.comp_apply, RingHom.comp_apply, AlgHom.toRingHom_eq_coe, RingHom.coe_coe, aeval_X,
+        hx, coe_mapRingHom, Polynomial.map_X, AlgHom.toRingHom_eq_coe, RingHom.coe_coe, aeval_X]
+
+end GalA
+
+end WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map_map map mk map_id Affine.Point baseChange"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "CoordinateRing.XYIdeal CoordinateRing Point.baseChange map \
+  baseChange CoordinateRing.YClass FunctionField Point CoordinateRing.mk Point.map \
+  CoordinateRing.XClass baseChange_polynomial Point.map_some polynomial \
+  exists_transEquiv_weilFun_eq weilFun weilPairing0 transEquiv_weilFun genericX genericY \
+  genericPoint pointHom_mk Point.xc_map Point.yc_map transEquiv transEquiv_algebraMap \
+  weilFun_ne_zero exists_map_weilFun_eq_mul_weilFun_smul Point.algEquiv_smul_def"
+namespace Point
+p2m_export "WeierstrassCurve.Affine.Point" "map_id baseChange map_map map map_some mk xc yc xc_map \
+  yc_map algEquiv_smul_def"
+end Point
+end Affine
+end WeierstrassCurve
+p2m_open_scoped "WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point" in
+theorem WeierstrassCurve.Affine.Point.smul_zsmul_comm {F K : Type*} [Field F] [Field K]
+    [Algebra F K]
+    [DecidableEq K] (W : WeierstrassCurve F) (σ : K ≃ₐ[F] K) (m : ℤ) (P : (W⁄K).Point) :
+    σ • (m • P) = m • (σ • P) :=
+  map_zsmul (DistribSMul.toAddMonoidHom (W⁄K).Point σ) m P
+
+theorem solution {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K]
+    (W : WeierstrassCurve F) [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ}
+    (hn : (n : K) ≠ 0) (σ : K ≃ₐ[F] K) (S T : (W⁄K).Point) (hS : (n : ℤ) • S = 0)
+    (hT : (n : ℤ) • T = 0) :
+    ((weilPairing0 W K n (σ • S) (σ • T) : Kˣ) : K) = σ (weilPairing0 W K n S T) := by
+  obtain ⟨Φe, hΦe⟩ := galFunctionField_exists W σ
+  set Φ : (W⁄K).FunctionField →+* (W⁄K).FunctionField := Φe.toRingHom with hΦdef
+  have hΦ : ∀ p : K[X][Y], Φ (algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField (CoordinateRing.mk
+    (W⁄K) p)) =
+      algebraMap (W⁄K).CoordinateRing (W⁄K).FunctionField
+        (CoordinateRing.mk (W⁄K) (p.map (mapRingHom (σ : K →+* K)))) := fun p => hΦe p
+  have hσS : (n : ℤ) • (σ • S) = 0 := by rw [← Point.smul_zsmul_comm W σ, hS, smul_zero]
+  have hσT : (n : ℤ) • (σ • T) = 0 := by rw [← Point.smul_zsmul_comm W σ, hT, smul_zero]
+  have key := transEquiv_weilFun W K (exists_transEquiv_weilFun_eq W hn S T hS hT)
+  obtain ⟨c, hc⟩ := exists_map_weilFun_eq_mul_weilFun_smul W hn σ Φ hΦ hT
+  have h1 := congrArg Φ key
+  rw [gal_transEquiv W σ Φ hΦ, map_mul, hc, gal_algebraMap W σ Φ hΦ, map_mul,
+    AlgEquiv.commutes] at h1
+  have hc0 : algebraMap K (W⁄K).FunctionField (c : K) ≠ 0 :=
+    (map_ne_zero_iff _ (algebraMap K (W⁄K).FunctionField).injective).mpr c.ne_zero
+  have h2 : transEquiv W K (σ • S) (weilFun W K n (σ • T)) =
+      algebraMap K (W⁄K).FunctionField (σ (weilPairing0 W K n S T : K)) * weilFun W K n (σ • T)
+        := by
+    apply mul_left_cancel₀ hc0
+    rw [h1]
+    ring
+  have hne : σ (weilPairing0 W K n S T : K) ≠ 0 :=
+    (map_ne_zero_iff _ σ.injective).mpr (weilPairing0 W K n S T).ne_zero
+  have hex' : ∃ c' : Kˣ, transEquiv W K (σ • S) (weilFun W K n (σ • T)) =
+      algebraMap K (W⁄K).FunctionField (c' : K) * weilFun W K n (σ • T) :=
+    ⟨Units.mk0 _ hne, by rw [Units.val_mk0]; exact h2⟩
+  have key' := transEquiv_weilFun W K hex'
+  have h3 := key'.symm.trans h2
+  have h4 := mul_right_cancel₀ (weilFun_ne_zero W hn hσT) h3
+  exact (algebraMap K (W⁄K).FunctionField).injective h4
+
+end S_WeierstrassCurve_Affine_weilPairing0_galois
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_weilPairing0_galois (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain WithZero
+
+theorem WeierstrassCurve.Affine.weilPairing0_galois {F K : Type*} [Field F] [Field K] [Algebra F K]
+    [DecidableEq K] [IsAlgClosed K] (W : WeierstrassCurve F) [W.IsElliptic]
+    [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ} (hn : (n : K) ≠ 0) (σ : K ≃ₐ[F] K)
+    (S T : (W⁄K).Point) (hS : (n : ℤ) • S = 0) (hT : (n : ℤ) • T = 0) :
+    ((weilPairing0 W K n (σ • S) (σ • T) : Kˣ) : K) = σ (weilPairing0 W K n S T) :=
+  solution W hn σ S T hS hT
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_weilPairing0_self.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_weilPairing0_self.lean
new file mode 100644
index 0000000000..a1a57906d3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_weilPairing0_self.lean
@@ -0,0 +1,217 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.weilPairing0_self
+(cf6dc533-517b-53f2-9aed-82e87b4f7cc1) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 13424b99-bbdf-5f23-81d2-adcc2660e036
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_WeilPairingFun
+
+import Mathlib.Data.Set.Card
+import Mathlib.Algebra.BigOperators.Group.Finset.Piecewise
+import Mathlib.Tactic.Ring
+import Mathlib.Tactic.FieldSimp
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_exists_zsmul_eq_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_FunctionField_exists_eq_algebraMap_of_valuation_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_transEquiv_weilFun
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_weilFun_ne_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The pairing e₀ is trivial on the diagonal: e₀(T,T)=1
+
+Theorem statement: `WeierstrassCurve.Affine.weilPairing0_self`
+(`cf6dc533-517b-53f2-9aed-82e87b4f7cc1`), by Claude, 2026-09-05.
+
+Proof: submission `13424b99-bbdf-5f23-81d2-adcc2660e036`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field, $K$ an algebraically closed field which is an $F$-algebra, and $W$ a Weierstrass
+curve over $F$ which is elliptic, such that the coordinate ring of the base-changed affine curve
+$W⁄K$ is a Dedekind domain. Let $n$ be a natural number whose image in $K$ is nonzero, and let $T$
+be a point of $(W⁄K)$ annihilated by $n$, i.e. $(n : \mathbb{Z}) \bullet T = 0$. Then the unit
+$\mathrm{weilPairing0}\ W\ K\ n\ T\ T$ of $K$ equals $1$. Here $\mathrm{weilFun}\ W\ K\ n\ T$ is the
+element $g_T$ of the function field of $W⁄K$ obtained as the quotient of the images of `weilNum W K
+n T` and `weilNum W K n 0` under the map to the function field, $\mathrm{transEquiv}\ W\ K\ S$ is
+the $K$-algebra automorphism of that function field built from the translation pull-backs along $S$
+and $-S$, and $\mathrm{weilPairing0}\ W\ K\ n\ S\ T$ is, by definition, a chosen unit $c \in
+K^{\times}$ with $\mathrm{transEquiv}\ W\ K\ S\ (g_T) = c \cdot g_T$ if such a unit exists, and $1$
+otherwise. Thus the assertion is that for $S = T$ the constant relating $\tau_T^{*} g_T$ to $g_T$ is
+$1$.
+
+This is the classical statement that the Weil pairing is alternating on the diagonal, $e_n(T,T) =
+1$, here for the function-field-level pairing $e_0$ attached to $n$-torsion points over an
+algebraically closed field. It is used in the treatment of level structures on modular curves, in
+particular in identifying the determinant of the action of a matrix on the kernel of a classifying
+map and in the recognition of elements of $\Gamma$ by their effect on the pairing.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_weilPairing0_self.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_weilPairing0_self
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain IsDedekindDomain.HeightOneSpectrum
+  WithZero
+open scoped nonZeroDivisors
+
+namespace WeilLaws
+
+variable {F : Type*} [Field F] {K : Type*} [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K]
+  (W : WeierstrassCurve F) [W.IsElliptic]
+  [IsDedekindDomain (W⁄K).CoordinateRing]
+
+omit [IsDedekindDomain (W⁄K).CoordinateRing] in
+theorem transEquiv_transEquiv (S T : (W⁄K).Point) (h : (W⁄K).FunctionField) :
+    transEquiv W K S (transEquiv W K T h) = transEquiv W K (S + T) h := by
+  rw [transEquiv_add, AlgEquiv.trans_apply]
+
+omit [IsDedekindDomain (W⁄K).CoordinateRing] in
+theorem transEquiv_comm (S T : (W⁄K).Point) (h : (W⁄K).FunctionField) :
+    transEquiv W K S (transEquiv W K T h) = transEquiv W K T (transEquiv W K S h) := by
+  rw [transEquiv_transEquiv, transEquiv_transEquiv, add_comm]
+
+omit [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing] in
+theorem const_unique {g : (W⁄K).FunctionField} (hg : g ≠ 0) {c c' : K}
+    (h : algebraMap K (W⁄K).FunctionField c * g = algebraMap K (W⁄K).FunctionField c' * g) :
+    c = c' :=
+  (algebraMap K (W⁄K).FunctionField).injective (mul_right_cancel₀ hg h)
+
+theorem weilPairing0_eq_of {n : ℕ} (hn : (n : K) ≠ 0) {S T : (W⁄K).Point} (hT : (n : ℤ) • T = 0)
+    {c : Kˣ} (h : transEquiv W K S (weilFun W K n T) =
+      algebraMap K (W⁄K).FunctionField (c : K) * weilFun W K n T) :
+    weilPairing0 W K n S T = c := by
+  have h' := transEquiv_weilFun W K ⟨c, h⟩
+  rw [h] at h'
+  exact (Units.ext (const_unique W (WeierstrassCurve.Affine.weilFun_ne_zero W hn hT) h')).symm
+
+omit [DecidableEq K] in
+theorem exists_eq_algebraMap {f : (W⁄K).FunctionField}
+    (hf : ∀ (P : (W⁄K).Point) (hP : P ≠ 0), (placeOf W K P hP).valuation (W⁄K).FunctionField f =
+      1) :
+    ∃ c : K, c ≠ 0 ∧ f = algebraMap K (W⁄K).FunctionField c := by
+  apply WeierstrassCurve.Affine.FunctionField.exists_eq_algebraMap_of_valuation_eq_one (W := W⁄K)
+  intro v
+  obtain ⟨P, hP, rfl⟩ := placeOf_surjective W K v
+  exact hf P hP
+
+theorem transEquiv_weilFun_self {n : ℕ} (hn : (n : K) ≠ 0) {T : (W⁄K).Point}
+    (hT : (n : ℤ) • T = 0) : transEquiv W K T (weilFun W K n T) = weilFun W K n T := by
+  classical
+  have : (W⁄K).IsElliptic := by
+    dsimp only [Affine.baseChange, WeierstrassCurve.baseChange]; infer_instance
+  have hn0 : (n : ℤ) ≠ 0 := by
+    have : n ≠ 0 := by rintro rfl; exact hn Nat.cast_zero
+    exact_mod_cast this
+  obtain ⟨T', hT'⟩ := WeierstrassCurve.Affine.Point.exists_zsmul_eq_of_isAlgClosed (W⁄K) hn0 T
+  set g := weilFun W K n T with hg
+  set a : ℕ → (W⁄K).FunctionField := fun i => transEquiv W K ((i : ℤ) • T') g with ha
+  have hstep : ∀ i, transEquiv W K T' (a i) = a (i + 1) := by
+    intro i
+    simp only [ha]
+    rw [transEquiv_transEquiv, Nat.cast_succ, add_smul, one_smul, add_comm]
+  set G := ∏ i ∈ Finset.range n, a i with hG
+  have hGval : ∀ (P : (W⁄K).Point) (hP : P ≠ 0),
+      (placeOf W K P hP).valuation (W⁄K).FunctionField G = 1 := by
+    intro P hP
+    rw [hG, map_prod]
+    set d : ℤ → ℤᵐ⁰ := fun j => if (n : ℤ) • P + j • T = 0 then exp (-1 : ℤ) else 1 with hd
+    have hper : ∀ j, d (j + n) = d j := by
+      intro j
+      simp only [hd, add_smul, hT, add_zero]
+    have hai : ∀ i : ℕ, (placeOf W K P hP).valuation (W⁄K).FunctionField (a i) =
+        d ((i : ℤ) - 1) / d i := by
+      intro i
+      simp only [ha]
+      rw [WeierstrassCurve.Affine.valuation_transEquiv_weilFun W hn _ hT P hP]
+      have h1 : ((n : ℤ) • (P + (i : ℤ) • T') = T) = ((n : ℤ) • P + ((i : ℤ) - 1) • T = 0) := by
+        rw [smul_add, smul_comm, hT', sub_smul, one_smul, ← add_sub_assoc, sub_eq_zero]
+      have h2 : ((n : ℤ) • (P + (i : ℤ) • T') = 0) = ((n : ℤ) • P + (i : ℤ) • T = 0) := by
+        rw [smul_add, smul_comm, hT']
+      simp only [hd, h1, h2]
+    simp_rw [hai]
+    rw [Finset.prod_div_distrib]
+    suffices h : ∏ i ∈ Finset.range n, d ((i : ℤ) - 1) = ∏ i ∈ Finset.range n, d i by
+      rw [h, div_self]
+      rw [Finset.prod_ne_zero_iff]
+      intro i _
+      simp only [hd]
+      split_ifs
+      · exact WithZero.coe_ne_zero
+      · exact one_ne_zero
+    cases n with
+    | zero => simp
+    | succ m =>
+      rw [Finset.prod_range_succ' (fun i => d ((i : ℤ) - 1)), Finset.prod_range_succ]
+      congr 1
+      · refine Finset.prod_congr rfl fun i _ => ?_
+        push_cast
+        ring_nf
+      · have := hper (-1)
+        push_cast at this ⊢
+        rw [← this]
+        congr 1
+        ring
+  obtain ⟨c, hc0, hGc⟩ := exists_eq_algebraMap W hGval
+  have hfix : transEquiv W K T' G = G := by rw [hGc, AlgEquiv.commutes]
+  have hshift : transEquiv W K T' G = ∏ i ∈ Finset.range n, a (i + 1) := by
+    rw [hG, map_prod]
+    exact Finset.prod_congr rfl fun i _ => hstep i
+  have ha0 : ∀ i, a i ≠ 0 := fun i => by
+    simp only [ha]
+    exact (map_ne_zero_iff _ (transEquiv W K _).injective).mpr
+      (WeierstrassCurve.Affine.weilFun_ne_zero W hn hT)
+  cases hn' : n with
+  | zero => exact absurd (by rw [hn', Nat.cast_zero]) hn
+  | succ m =>
+    rw [hn'] at hshift hG
+    rw [hshift, hG, Finset.prod_range_succ, Finset.prod_range_succ' a] at hfix
+    have hcancel := mul_left_cancel₀ (Finset.prod_ne_zero_iff.mpr fun i _ => ha0 (i + 1)) hfix
+    simp only [ha] at hcancel
+    rw [Nat.cast_zero, zero_smul, transEquiv_zero, AlgEquiv.coe_refl, id_eq,
+      show (((m + 1 : ℕ) : ℤ)) = (n : ℤ) by rw [hn'], hT'] at hcancel
+    exact hcancel
+
+end WeilLaws
+
+theorem solution {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K] [IsAlgClosed K]
+    (W : WeierstrassCurve F) [W.IsElliptic] [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ}
+    (hn : (n : K) ≠ 0) (T : (W⁄K).Point) (hT : (n : ℤ) • T = 0) :
+    weilPairing0 W K n T T = 1 := by
+  apply WeilLaws.weilPairing0_eq_of W hn hT
+  rw [Units.val_one, map_one, one_mul]
+  exact WeilLaws.transEquiv_weilFun_self W hn hT
+
+end S_WeierstrassCurve_Affine_weilPairing0_self
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_weilPairing0_self (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain WithZero
+
+theorem WeierstrassCurve.Affine.weilPairing0_self {F K : Type*} [Field F] [Field K] [Algebra F K]
+    [DecidableEq K] [IsAlgClosed K] (W : WeierstrassCurve F) [W.IsElliptic]
+    [IsDedekindDomain (W⁄K).CoordinateRing] {n : ℕ} (hn : (n : K) ≠ 0) (T : (W⁄K).Point)
+    (hT : (n : ℤ) • T = 0) :
+    weilPairing0 W K n T T = 1 :=
+  solution W hn T hT
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_zsmul_genericPoint_good.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_zsmul_genericPoint_good.lean
new file mode 100644
index 0000000000..cefe34f884
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Affine_zsmul_genericPoint_good.lean
@@ -0,0 +1,143 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Affine.zsmul_genericPoint_good
+(4c692808-8498-5ac9-a18d-7ba660661e3d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ebd31027-2552-56ad-bc35-9301962545fb
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsion_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# No nonzero multiple of the generic point is constant
+
+Theorem statement: `WeierstrassCurve.Affine.zsmul_genericPoint_good`
+(`4c692808-8498-5ac9-a18d-7ba660661e3d`), by Claude, 2026-09-05.
+
+Proof: submission `ebd31027-2552-56ad-bc35-9301962545fb`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a field, let $W$ be a Weierstrass curve over $R$, and let $K$ be an algebraically closed
+field equipped with an $R$-algebra structure, with $W$ elliptic (its discriminant invertible). Write
+$W\!\mathbin{/}\!K$ for the base change of $W$ to $K$ and
+$(W\!\mathbin{/}\!K).\mathrm{FunctionField}$ for its function field, and let $\gamma =$
+`genericPoint W K` be the generic point, that is, the affine point of $W$ over
+$(W\!\mathbin{/}\!K).\mathrm{FunctionField}$ given by the images of the coordinate functions
+together with its nonsingularity witness. The assertion is that for every integer $n$ whose image in
+$K$ is nonzero, the predicate `MulGood W K n` holds, namely: first, $n \cdot \gamma$ is not the
+point at infinity of $W$ over the function field; and second, for every $K$-point $P$ of
+$W\!\mathbin{/}\!K$, the point $n \cdot \gamma$ is not equal to the image of $P$ under the
+base-change map from $(W\!\mathbin{/}\!K)$-points over $K$ to points over
+$(W\!\mathbin{/}\!K).\mathrm{FunctionField}$. In other words, $n\gamma$ is a genuinely nonconstant
+point of the generic fibre.
+
+This is the nondegeneracy guard under which the pull-back construction of the function-field module
+behaves as the pull-back along multiplication by $n$ on an elliptic curve: it says that $n$ times
+the generic point is neither zero nor constant. It is used in
+[`WeierstrassCurve.Affine.eq_zero_of_forall_transEquiv_eq`]
+(thm.html#WeierstrassCurve.Affine.eq_zero_of_forall_transEquiv_eq)
+and in
+[`WeierstrassCurve.Affine.exists_isogenyEndDatum_restrictAlong_placeOfPoint_eq_smul`]
+(thm.html#WeierstrassCurve.Affine.exists_isogenyEndDatum_restrictAlong_placeOfPoint_eq_smul).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Affine_zsmul_genericPoint_good.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Affine_zsmul_genericPoint_good
+
+p2m_open "WeierstrassCurve P2MW.S_WeierstrassCurve_Affine_zsmul_genericPoint_good.WeierstrassCurve \
+  WeierstrassCurve.Affine \
+  P2MW.S_WeierstrassCurve_Affine_zsmul_genericPoint_good.WeierstrassCurve.Affine"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map map_baseChange map_injective Affine.MulGood \
+  card_torsion_of_isAlgClosed"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.map_baseChange map Point.map_injective Point \
+  map_baseChange Point.map transPull map_transPull_genericPoint MulGood infinite_point"
+namespace Good
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+variable {R : Type*} [Field R] (W : WeierstrassCurve R) (K : Type*) [Field K] [Algebra R K]
+  [DecidableEq K] [IsAlgClosed K] [W.IsElliptic]
+
+theorem not_forall_zsmul_eq_zero {n : ℤ} (hn : (n : K) ≠ 0) : ¬ ∀ S : (W⁄K).Point, n • S = 0 := by
+  intro hall
+  obtain ⟨m, hm⟩ : ∃ m : ℕ, n = m ∨ n = -m := ⟨n.natAbs, Int.natAbs_eq n⟩
+  have hmK : (m : K) ≠ 0 := by
+    intro h0
+    apply hn
+    rcases hm with rfl | rfl
+    · rw [Int.cast_natCast, h0]
+    · rw [Int.cast_neg, Int.cast_natCast, h0, neg_zero]
+  have hcard := WeierstrassCurve.card_torsion_of_isAlgClosed (K := K) W hmK
+  have htop : Submodule.torsionBy ℤ (W⁄K).Point m = ⊤ := by
+    rw [eq_top_iff]
+    intro S _
+    rw [Submodule.mem_torsionBy_iff]
+    rcases hm with rfl | rfl
+    · exact hall S
+    · have := hall S
+      rwa [neg_smul, neg_eq_zero] at this
+  rw [htop, Nat.card_congr (Submodule.topEquiv (R := ℤ) (M := (W⁄K).Point)).toEquiv] at hcard
+  have hm0 : m ≠ 0 := by rintro rfl; exact hmK Nat.cast_zero
+  have : Finite (W⁄K).Point := Nat.finite_of_card_ne_zero (by rw [hcard]; exact pow_ne_zero 2 hm0)
+  exact (infinite_point W K).not_finite ‹_›
+
+end WeierstrassCurve.Affine.Good
+
+open WeierstrassCurve.Affine.Good in
+theorem solution {R : Type*} [Field R] (W : WeierstrassCurve R) (K : Type*) [Field K] [Algebra R K]
+    [DecidableEq K] [IsAlgClosed K] [W.IsElliptic] {n : ℤ} (hn : (n : K) ≠ 0) :
+    WeierstrassCurve.Affine.MulGood W K n := by
+  constructor
+  · intro h0
+    apply not_forall_zsmul_eq_zero W K hn
+    intro S
+    have := congrArg (Point.map (transPull W K S)) h0
+    rw [map_zsmul, map_transPull_genericPoint, map_zero, smul_add, h0, zero_add, ←
+      map_zsmul] at this
+    exact Point.map_injective _ (this.trans (map_zero _).symm)
+  · intro P hP
+    apply not_forall_zsmul_eq_zero W K hn
+    intro S
+    have := congrArg (Point.map (transPull W K S)) hP
+    rw [map_zsmul, map_transPull_genericPoint, Point.map_baseChange, smul_add, hP, ← map_zsmul,
+      add_eq_left] at this
+    exact Point.map_injective _ (this.trans (map_zero _).symm)
+
+end S_WeierstrassCurve_Affine_zsmul_genericPoint_good
+end P2MW
+export P2MW.S_WeierstrassCurve_Affine_zsmul_genericPoint_good (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+theorem WeierstrassCurve.Affine.zsmul_genericPoint_good {R : Type*} [Field R]
+    (W : WeierstrassCurve R) (K : Type*) [Field K] [Algebra R K] [DecidableEq K] [IsAlgClosed K]
+    [W.IsElliptic] {n : ℤ} (hn : (n : K) ≠ 0) :
+    WeierstrassCurve.Affine.MulGood W K n :=
+  solution W K hn
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Delta_eq_veluGx_sq_mul_velu2QuadDisc.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Delta_eq_veluGx_sq_mul_velu2QuadDisc.lean
new file mode 100644
index 0000000000..1d0ccf4052
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Delta_eq_veluGx_sq_mul_velu2QuadDisc.lean
@@ -0,0 +1,97 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Delta_eq_veluGx_sq_mul_velu2QuadDisc
+(588c210e-7262-5687-86db-d00cd5491399) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b4ea2791-344a-50f7-9efe-5c9df5cdc09f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluOrderTwo
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Δ = gₓ(Q)² d(x₀) at a 2-torsion point
+
+Theorem statement: `WeierstrassCurve.Delta_eq_veluGx_sq_mul_velu2QuadDisc`
+(`588c210e-7262-5687-86db-d00cd5491399`), by Claude, 2026-09-05.
+
+Proof: submission `b4ea2791-344a-50f7-9efe-5c9df5cdc09f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring and $W$ a Weierstrass curve over $R$ with coefficients
+$a_1,a_2,a_3,a_4,a_6$, and let $x_0,y_0 \in R$. Assume two hypotheses: first, that $(x_0,y_0)$ lies
+on the associated affine curve, i.e. it satisfies the Weierstrass equation $y_0^2 + a_1 x_0 y_0 +
+a_3 y_0 = x_0^3 + a_2 x_0^2 + a_4 x_0 + a_6$; second, that `W.veluGy x₀ y₀`, which by definition is
+$-(2y_0 + a_1 x_0 + a_3)$, vanishes — so the point is a $2$-torsion point in the sense that the
+partial derivative in $y$ of the Weierstrass polynomial vanishes at it. Under these hypotheses the
+discriminant of $W$ factors as
+$$\Delta = \bigl(3x_0^2 + 2a_2 x_0 + a_4 - a_1 y_0\bigr)^2 \cdot \bigl(b_2^2 - 8 b_2 x_0 - 48 x_0^2
+- 32 b_4\bigr),$$
+where the first factor is `W.veluGx x₀ y₀` (the negative of the partial derivative in $x$) and the
+second is `W.velu2QuadDisc x₀`, with $b_2 = a_1^2 + 4a_2$ and $b_4 = 2a_4 + a_1 a_3$ the usual
+Weierstrass quantities. No invertibility, reducedness or nondegeneracy assumption is imposed: the
+assertion is an identity in $R$.
+
+The identity expresses the classical factorisation of the discriminant at a $2$-torsion point, in
+the form $\operatorname{disc}((X-x_0)Q) = \operatorname{Res}(X-x_0,Q)^2 \operatorname{disc}(Q)$
+applied to the splitting off of the root $x_0$ from the $2$-division polynomial. It is used to show
+that both factors are nonzero at a $2$-torsion point when $\Delta$ is, in
+[nonvanishing of `veluGx`](thm.html#WeierstrassCurve.veluGx_ne_zero_of_two_torsion)
+and
+[nonvanishing of the cofactor](thm.html#WeierstrassCurve.velu2QuadDisc_ne_zero_of_two_torsion),
+which feed into the construction of the quotient of a curve by an order-two subgroup via Vélu's
+formulae.
+
+## Local proof
+
+Translate the kernel point to the origin using `VariableChange`. Mathlib supplies
+invariance of the discriminant; the translated coefficients and quadratic cofactor
+reduce the result to a small polynomial identity over an arbitrary commutative ring.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Delta_eq_veluGx_sq_mul_velu2QuadDisc.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_WeierstrassCurve_Delta_eq_veluGx_sq_mul_velu2QuadDisc
+
+open WeierstrassCurve WeierstrassCurve.Affine in
+theorem solution {R : Type*} [CommRing R] {W : WeierstrassCurve R} {x₀ y₀ : R}
+    (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0) :
+    W.Δ = W.veluGx x₀ y₀ ^ 2 * W.velu2QuadDisc x₀ := by
+  have hΔ : ((⟨1, x₀, 0, y₀⟩ : VariableChange R) • W).Δ = W.Δ := by
+    simpa only [inv_one, Units.val_one, one_pow, one_mul] using
+      W.variableChange_Δ (⟨1, x₀, 0, y₀⟩ : VariableChange R)
+  rw [← hΔ, W.velu2_variableChange hQ hgy, W.velu2QuadDisc_eq_shifted hgy]
+  simp only [Δ, b₂, b₄, b₆, b₈]
+  ring
+
+end S_WeierstrassCurve_Delta_eq_veluGx_sq_mul_velu2QuadDisc
+end P2MW
+export P2MW.S_WeierstrassCurve_Delta_eq_veluGx_sq_mul_velu2QuadDisc (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace WeierstrassCurve
+variable {R : Type*} [CommRing R] {W : WeierstrassCurve R}
+theorem Delta_eq_veluGx_sq_mul_velu2QuadDisc {x₀ y₀ : R}
+    (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0) :
+    W.Δ = W.veluGx x₀ y₀ ^ 2 * W.velu2QuadDisc x₀ :=
+  _root_.P2MW.S_WeierstrassCurve_Delta_eq_veluGx_sq_mul_velu2QuadDisc.solution hQ hgy
+end WeierstrassCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Psi2Sq_ne_zero_of_isElliptic.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Psi2Sq_ne_zero_of_isElliptic.lean
new file mode 100644
index 0000000000..6300426bc3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_Psi2Sq_ne_zero_of_isElliptic.lean
@@ -0,0 +1,113 @@
+/-
+Based on Prove2Me node WeierstrassCurve.Psi2Sq_ne_zero_of_isElliptic
+(25b8df23-3b96-5fb9-9d28-c9426ba8f3fa) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 0e622a9b-5511-5797-9c37-1479ffd72b2d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+
+import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+import Mathlib.Tactic.LinearCombination
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Nonvanishing of Ψ₂² for an elliptic curve in any characteristic
+
+Theorem statement: `WeierstrassCurve.Psi2Sq_ne_zero_of_isElliptic`
+(`25b8df23-3b96-5fb9-9d28-c9426ba8f3fa`), by Claude, 2026-09-05.
+
+Proof: submission `0e622a9b-5511-5797-9c37-1479ffd72b2d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field and let $W$ be a Weierstrass curve over $F$, given by coefficients
+$a_1,a_2,a_3,a_4,a_6$, which is assumed to be elliptic in Mathlib's sense, i.e. its discriminant
+$\Delta$ is a unit of $F$. The assertion is that the polynomial $W.\Psi_2\mathrm{Sq} = 4X^3 + b_2X^2
++ 2b_4X + b_6 \in F[X]$, the square of the $2$-division polynomial expressed in the usual invariants
+$b_2 = a_1^2+4a_2$, $b_4 = 2a_4+a_1a_3$, $b_6 = a_3^2+4a_6$, is not the zero polynomial. No
+assumption on the characteristic of $F$ is made; in particular this strengthens the form of the
+statement in which $4 \neq 0$ in $F$ is hypothesised, where the conclusion is immediate from the
+leading coefficient. The $x$-coordinates of the nontrivial $2$-torsion points of $W$ are exactly the
+roots of this polynomial, so the conclusion says that the $2$-torsion locus is cut out by a nonzero
+equation.
+
+This is the characteristic-free form of the statement that the $2$-division polynomial of an
+elliptic curve does not vanish identically; in characteristic $2$ it encodes the fact that $a_1$ and
+$a_3$ cannot both vanish when $\Delta$ is invertible. It is used throughout the treatment of
+$2$-torsion of elliptic curves, for instance in the work on points of modular curves and on the
+Čerednik–Drinfel'd uniformisation.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_Psi2Sq_ne_zero_of_isElliptic.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_Psi2Sq_ne_zero_of_isElliptic
+
+open Polynomial
+
+theorem PortCard.sub_negY_sq_eq_eval_Ψ₂Sq {R : Type*} [CommRing R] (W : WeierstrassCurve R)
+    {x y : R} (e : W.toAffine.Equation x y) :
+    (y - W.toAffine.negY x y) ^ 2 = W.Ψ₂Sq.eval x := by
+  rw [WeierstrassCurve.Affine.equation_iff] at e
+  simp only [WeierstrassCurve.Affine.negY, WeierstrassCurve.Ψ₂Sq, WeierstrassCurve.b₂,
+    WeierstrassCurve.b₄, WeierstrassCurve.b₆, eval_add, eval_mul, eval_pow, eval_C, eval_X]
+  linear_combination 4 * e
+
+theorem PortCard.two_smul_some_eq_zero_iff {F : Type*} [Field F] [DecidableEq F]
+    (W : WeierstrassCurve F) {x y : F} (h : W.toAffine.Nonsingular x y) :
+    2 • WeierstrassCurve.Affine.Point.some x y h = 0 ↔ W.Ψ₂Sq.eval x = 0 := by
+  have key : 2 • WeierstrassCurve.Affine.Point.some x y h = 0 ↔ y = W.toAffine.negY x y := by
+    rw [two_nsmul, add_eq_zero_iff_eq_neg, WeierstrassCurve.Affine.Point.neg_some,
+      WeierstrassCurve.Affine.Point.some.injEq]
+    simp
+  rw [key, ← PortCard.sub_negY_sq_eq_eval_Ψ₂Sq W h.left, pow_eq_zero_iff two_ne_zero, sub_eq_zero]
+
+theorem PortCard.Ψ₂Sq_ne_zero_of_isElliptic {F : Type*} [Field F] (W : WeierstrassCurve F)
+    [W.IsElliptic] : W.Ψ₂Sq ≠ 0 := by
+  intro h0
+  rw [WeierstrassCurve.Ψ₂Sq_eq, Cubic.toPoly_eq_zero_iff] at h0
+  have h4 : (4 : F) = 0 := congrArg Cubic.a h0
+  have hb₂ : W.b₂ = 0 := congrArg Cubic.b h0
+  have hb₆ : W.b₆ = 0 := congrArg Cubic.d h0
+  have h2 : (2 : F) = 0 := by
+    have h22 : (2 : F) * 2 = 0 := by linear_combination h4
+    rcases mul_eq_zero.mp h22 with h | h <;> exact h
+  have hΔ : W.Δ = 0 := by
+    rw [show W.Δ = -W.b₂ ^ 2 * W.b₈ - 8 * W.b₄ ^ 3 - 27 * W.b₆ ^ 2 + 9 * W.b₂ * W.b₄ * W.b₆
+      from rfl]
+    linear_combination (-W.b₂ * W.b₈ + 9 * W.b₄ * W.b₆) * hb₂ + (-27 * W.b₆) * hb₆ +
+      (-4 * W.b₄ ^ 3) * h2
+  exact W.isUnit_Δ.ne_zero hΔ
+
+theorem solution {F : Type*} [Field F] (W : WeierstrassCurve F) [W.IsElliptic] : W.Ψ₂Sq ≠ 0 :=
+  PortCard.Ψ₂Sq_ne_zero_of_isElliptic W
+
+end S_WeierstrassCurve_Psi2Sq_ne_zero_of_isElliptic
+end P2MW
+export P2MW.S_WeierstrassCurve_Psi2Sq_ne_zero_of_isElliptic (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem WeierstrassCurve.Psi2Sq_ne_zero_of_isElliptic {F : Type*} [Field F] (W : WeierstrassCurve F)
+    [W.IsElliptic] :
+    W.Ψ₂Sq ≠ 0 :=
+  solution W
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_card_torsionBy_eq_sq_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_card_torsionBy_eq_sq_of_isAlgClosed.lean
new file mode 100644
index 0000000000..df515131bb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_card_torsionBy_eq_sq_of_isAlgClosed.lean
@@ -0,0 +1,83 @@
+/-
+Based on Prove2Me node WeierstrassCurve.card_torsionBy_eq_sq_of_isAlgClosed
+(f94c2d08-0249-52d5-8bc0-9de7ee84bbdd) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9b84a731-dcd8-5715-8d80-e882eb90298a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Module.Torsion.Basic
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsion_of_isAlgClosed_light
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# n-torsion of an elliptic curve over an algebraically closed field
+
+Theorem statement: `WeierstrassCurve.card_torsionBy_eq_sq_of_isAlgClosed`
+(`f94c2d08-0249-52d5-8bc0-9de7ee84bbdd`), by Claude, 2026-09-05.
+
+Proof: submission `9b84a731-dcd8-5715-8d80-e882eb90298a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field with decidable equality, and let $W$ be a Weierstrass curve
+over $F$ which is elliptic in the sense of Mathlib's `IsElliptic`, i.e. its discriminant is a unit.
+Let $n$ be a natural number whose image in $F$ is nonzero, and assume also that $2 \ne 0$ in $F$.
+Consider the group $W.toAffine.Point$ of points of the associated affine Weierstrass curve over $F$
+— the points of the affine model together with the point at infinity, with its Mathlib group
+structure — regarded as a $\mathbb{Z}$-module, and inside it the submodule
+$\mathrm{torsionBy}\,\mathbb{Z}\,n$ of elements killed by $n$. The assertion is that this
+$n$-torsion submodule is finite of cardinality exactly $n^2$, the equality being stated for
+`Nat.card`. Note that the conclusion records only the order of $E[n]$, not the stronger isomorphism
+$E[n] \cong (\mathbb{Z}/n)^2$.
+
+This is the classical cardinality statement $\#E(F)[n] = n^2$ for an elliptic curve over an
+algebraically closed field of characteristic not dividing $n$ (Silverman, Corollary III.6.4(b)). It
+is the counting input behind the two-dimensionality of the mod-$n$ representations $\bar\rho_{E,n}
+\colon G_K \to \mathrm{GL}_2(\mathbb{Z}/n)$ attached to elliptic curves, and is invoked at several
+places in the Galois-representation part of the development.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_card_torsionBy_eq_sq_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_card_torsionBy_eq_sq_of_isAlgClosed
+
+open WeierstrassCurve
+
+theorem solution {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F]
+    (W : WeierstrassCurve F) [W.IsElliptic] {n : ℕ} (hn : (n : F) ≠ 0) :
+    Nat.card (Submodule.torsionBy ℤ W.toAffine.Point n) = n ^ 2 :=
+  WeierstrassCurve.card_torsion_of_isAlgClosed_light (F := F) (K := F) W hn
+
+end S_WeierstrassCurve_card_torsionBy_eq_sq_of_isAlgClosed
+end P2MW
+export P2MW.S_WeierstrassCurve_card_torsionBy_eq_sq_of_isAlgClosed (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem WeierstrassCurve.card_torsionBy_eq_sq_of_isAlgClosed
+    {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F]
+    (W : WeierstrassCurve F) [W.IsElliptic] {n : ℕ} (hn : (n : F) ≠ 0) :
+    Nat.card (Submodule.torsionBy ℤ W.toAffine.Point n) = n ^ 2 :=
+  solution W hn
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_card_torsion_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_card_torsion_of_isAlgClosed.lean
new file mode 100644
index 0000000000..f09010ba7b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_card_torsion_of_isAlgClosed.lean
@@ -0,0 +1,1371 @@
+/-
+Based on Prove2Me node WeierstrassCurve.card_torsion_of_isAlgClosed
+(11439a28-4f47-513e-b777-e6e7e1abad80) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 0673979f-62c4-5f24-84e0-d46b480662a6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Module.Torsion.Basic
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+
+import Mathlib.NumberTheory.EllipticDivisibilitySequence
+import Mathlib.Algebra.Ring.NegOnePow
+import Mathlib.Data.Fin.VecNotation
+import Mathlib.Data.Fin.Tuple.Sort
+import Mathlib.Algebra.GroupWithZero.NonZeroDivisors
+import Mathlib.Algebra.MvPolynomial.CommRing
+import Mathlib.Algebra.MvPolynomial.Basic
+import Mathlib.Tactic.LinearCombination
+import Mathlib.Tactic.Ring
+import Mathlib.Tactic.Abel
+import Mathlib.Tactic.IntervalCases
+import Mathlib.Tactic.FieldSimp
+import Mathlib.GroupTheory.Perm.Basic
+import Mathlib.GroupTheory.Perm.Sign
+import Mathlib.GroupTheory.Perm.Cycle.Type
+import Mathlib.Algebra.Polynomial.Bivariate
+import Mathlib.AlgebraicGeometry.EllipticCurve.Jacobian.Point
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+import Mathlib.FieldTheory.Separable
+import Mathlib.Data.Nat.Factorization.Induction
+import Mathlib.Logic.Embedding.Set
+import Mathlib.SetTheory.Cardinal.Finite
+import Mathlib.Data.Set.Card
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_EDSEngine
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The n-torsion of an elliptic curve has n² points
+
+Theorem statement: `WeierstrassCurve.card_torsion_of_isAlgClosed`
+(`11439a28-4f47-513e-b777-e6e7e1abad80`), by Claude, 2026-09-05.
+
+Proof: submission `0673979f-62c4-5f24-84e0-d46b480662a6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field, let $K$ be an algebraically closed field equipped with an $F$-algebra structure,
+and let $W$ be a Weierstrass curve over $F$ which is elliptic (its discriminant is a unit). Let $n$
+be a natural number whose image in $K$ is nonzero, i.e. the characteristic of $K$ does not divide
+$n$; in particular $n \neq 0$. Write $W⁄K$ for the base change of $W$ along $F \to K$ and
+$(W⁄K)$`.Point` for the group of $K$-points of the associated affine Weierstrass curve, consisting
+of the point at infinity together with the nonsingular affine solutions, with its usual
+chord-and-tangent group law, viewed as a $\mathbb{Z}$-module. The assertion is that the $n$-torsion
+submodule $\{P : n \cdot P = 0\}$ of this group has exactly $n^2$ elements, in the sense that its
+`Nat.card` equals $n^2$; since $n^2 \neq 0$, this includes the assertion that the $n$-torsion is
+finite. This is the counting form of the statement $E[n] \cong (\mathbb{Z}/n\mathbb{Z})^2$: the
+group structure of the $n$-torsion is not asserted here, only its cardinality.
+
+This is the standard computation of the order of the $n$-torsion of an elliptic curve over an
+algebraically closed field of characteristic not dividing $n$, classically obtained from the
+division polynomials or from the degree of the multiplication-by-$n$ isogeny. It underlies the
+construction of the mod-$p$ and $p$-adic Galois representations attached to an elliptic curve,
+supplying the two-dimensionality of $E[p]$ over $\mathbb{F}_p$, and is used throughout the
+development downstream of the Galois-representation definitions.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_card_torsion_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_card_torsion_of_isAlgClosed
+
+section PortTorsionSmulFormulaEngine
+
+namespace Deep
+
+open WeierstrassCurve WeierstrassCurve.Affine Polynomial
+
+open scoped WeierstrassCurve.Affine
+
+section Engine
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve.Affine F)
+
+theorem sub_negY_sq_eq_Ψ₂Sq_eval {x y : F} (e : W.Equation x y) :
+    (y - W.negY x y) ^ 2 = (WeierstrassCurve.Ψ₂Sq W).eval x := by
+  rw [equation_iff] at e
+  simp only [negY, WeierstrassCurve.Ψ₂Sq, WeierstrassCurve.b₂, WeierstrassCurve.b₄,
+    WeierstrassCurve.b₆, eval_add, eval_mul, eval_pow, eval_C, eval_X]
+  linear_combination 4 * e
+
+end Engine
+
+end Deep
+
+end PortTorsionSmulFormulaEngine
+
+section PortGenNetIdentities
+
+namespace Deep
+namespace Gen
+
+open WeierstrassCurve Polynomial
+
+variable {F K : Type*} [Field F] [Field K] [Algebra F K]
+variable (W : WeierstrassCurve F)
+
+theorem ΨSq_eval_eq_zero_of_preΨ {m : ℕ} {x₀ : K}
+    (h : ((W.baseChange K).preΨ (m : ℤ)).eval x₀ = 0) :
+    ((W.baseChange K).ΨSq m).eval x₀ = 0 := by
+  rw [preΨ_ofNat] at h
+  rw [ΨSq_ofNat, eval_mul, eval_pow, h, zero_pow two_ne_zero, zero_mul]
+
+variable [IsAlgClosed K]
+
+theorem isCoprime_ΨSq_succ [W.IsElliptic] (n : ℕ) :
+    IsCoprime ((W.baseChange K).ΨSq n) ((W.baseChange K).ΨSq (n + 1)) := by
+  classical
+  rw [Polynomial.isCoprime_iff_aeval_ne_zero_of_isAlgClosed (k := K) (K := K)]
+  intro x₀
+  by_contra hcon
+  push Not at hcon
+  obtain ⟨hn0, hn1⟩ := hcon
+  rw [coe_aeval_eq_eval] at hn0 hn1
+  obtain ⟨y₀, hy₀⟩ := IsAlgClosed.exists_root
+    (C (1 : K) * X ^ 2 + C ((W.baseChange K).a₁ * x₀ + (W.baseChange K).a₃) * X +
+      C (-(x₀ ^ 3 + (W.baseChange K).a₂ * x₀ ^ 2 + (W.baseChange K).a₄ * x₀ +
+        (W.baseChange K).a₆)))
+    (by rw [Polynomial.degree_quadratic one_ne_zero]; decide)
+  have heq : (W.baseChange K).toAffine.Equation x₀ y₀ := by
+    rw [Affine.equation_iff]
+    simp only [IsRoot.def, eval_add, eval_mul, eval_pow, eval_C, eval_X] at hy₀
+    linear_combination hy₀
+  have hns : (W.baseChange K).toAffine.Nonsingular x₀ y₀ :=
+    (Affine.equation_iff_nonsingular).mp heq
+  have hψ0 : ((W.baseChange K).ψ (n : ℤ)).evalEval x₀ y₀ = 0 := by
+    have h2 := evalEval_ψ_sq (W.baseChange K) heq (n : ℤ)
+    rw [hn0] at h2
+    exact (pow_eq_zero_iff two_ne_zero).mp h2
+  have hψ1 : ((W.baseChange K).ψ ((n : ℤ) + 1)).evalEval x₀ y₀ = 0 := by
+    have h2 := evalEval_ψ_sq (W.baseChange K) heq ((n : ℤ) + 1)
+    rw [hn1] at h2
+    exact (pow_eq_zero_iff two_ne_zero).mp h2
+  have h0 : (n : ℤ) • (Affine.Point.some x₀ y₀ hns) = 0 :=
+    (smul_eq_zero_iff_evalEval_ψ (W.baseChange K) hns (n : ℤ)).mpr hψ0
+  have h1 : ((n : ℤ) + 1) • (Affine.Point.some x₀ y₀ hns) = 0 :=
+    (smul_eq_zero_iff_evalEval_ψ (W.baseChange K) hns ((n : ℤ) + 1)).mpr hψ1
+  have hP : (Affine.Point.some x₀ y₀ hns : (W.baseChange K).toAffine.Point) = 0 := by
+    have hsub := sub_smul ((n : ℤ) + 1) (n : ℤ) (Affine.Point.some x₀ y₀ hns)
+    rw [h1, h0, sub_zero, add_sub_cancel_left, one_smul] at hsub
+    exact hsub
+  exact Affine.Point.some_ne_zero hns hP
+
+end Deep.Gen
+
+end PortGenNetIdentities
+
+section PortGenInduction
+
+namespace Deep
+namespace Gen
+
+open WeierstrassCurve WeierstrassCurve.Affine Polynomial
+
+open scoped WeierstrassCurve.Affine
+
+variable {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K]
+variable (W : WeierstrassCurve F)
+
+theorem smul_formula_or_zero [W.IsElliptic] {n : ℕ} (_hn : 0 < n) {x₀ y₀ : K}
+    (h : (W.baseChange K).toAffine.Nonsingular x₀ y₀) :
+    (((W.baseChange K).ΨSq n).eval x₀ ≠ 0 →
+      ∃ (x' y' : K) (h' : (W.baseChange K).toAffine.Nonsingular x' y'),
+        n • (Point.some x₀ y₀ h : W.toAffine⟮K⟯) = Point.some x' y' h' ∧
+          x' * ((W.baseChange K).ΨSq n).eval x₀ = ((W.baseChange K).Φ n).eval x₀) ∧
+    (((W.baseChange K).ΨSq n).eval x₀ = 0 →
+      n • (Point.some x₀ y₀ h : W.toAffine⟮K⟯) = 0) := by
+  have heq : (W.baseChange K).toAffine.Equation x₀ y₀ := h.left
+  have hψsq := (W.baseChange K).evalEval_ψ_sq heq (n : ℤ)
+  constructor
+  · intro hΨ
+    have hψ : ((W.baseChange K).ψ (n : ℤ)).evalEval x₀ y₀ ≠ 0 := by
+      intro h0
+      exact hΨ (by rw [← hψsq, h0]; exact zero_pow two_ne_zero)
+    have key := zsmul_eq_smulEval (W.baseChange K) h (n : ℤ)
+    have hVz : smulEval (W.baseChange K) x₀ y₀ (n : ℤ) 2 ≠ 0 := hψ
+    have hV := key ▸ ((n : ℤ) • Jacobian.Point.fromAffine (Point.some x₀ y₀ h)).nonsingular
+    have hQeq : ((n : ℤ) • Jacobian.Point.fromAffine (Point.some x₀ y₀ h)) =
+        Jacobian.Point.mk hV := Jacobian.Point.ext key
+    refine ⟨smulEval (W.baseChange K) x₀ y₀ (n : ℤ) 0 /
+        smulEval (W.baseChange K) x₀ y₀ (n : ℤ) 2 ^ 2,
+      smulEval (W.baseChange K) x₀ y₀ (n : ℤ) 1 /
+        smulEval (W.baseChange K) x₀ y₀ (n : ℤ) 2 ^ 3,
+      (Jacobian.nonsingular_of_Z_ne_zero hVz).mp hV, ?_, ?_⟩
+    · calc n • (Point.some x₀ y₀ h : W.toAffine⟮K⟯)
+          = Jacobian.Point.toAffineAddEquiv (W.baseChange K)
+            ((n : ℤ) • Jacobian.Point.fromAffine (Point.some x₀ y₀ h)) := by
+            rw [map_zsmul, ← Jacobian.Point.toAffineAddEquiv_symm_apply,
+              AddEquiv.apply_symm_apply, natCast_zsmul]
+        _ = _ := by
+            rw [hQeq, Jacobian.Point.toAffineAddEquiv_apply]
+            exact Jacobian.Point.toAffineLift_of_Z_ne_zero hVz
+    · change ((W.baseChange K).φ (n : ℤ)).evalEval x₀ y₀ /
+          ((W.baseChange K).ψ (n : ℤ)).evalEval x₀ y₀ ^ 2 *
+          ((W.baseChange K).ΨSq (n : ℤ)).eval x₀ =
+          ((W.baseChange K).Φ (n : ℤ)).eval x₀
+      rw [← hψsq, div_mul_cancel₀ _ (pow_ne_zero 2 hψ),
+        (W.baseChange K).evalEval_φ heq]
+  · intro hΨ
+    have hψ0 : ((W.baseChange K).ψ (n : ℤ)).evalEval x₀ y₀ = 0 :=
+      sq_eq_zero_iff.mp (hψsq.trans hΨ)
+    rw [← natCast_zsmul]
+    exact ((W.baseChange K).smul_eq_zero_iff_evalEval_ψ h (n : ℤ)).mpr hψ0
+
+end Deep.Gen
+
+end PortGenInduction
+
+section PortGenSmulFormula
+
+namespace Deep
+namespace Gen
+
+open WeierstrassCurve WeierstrassCurve.Affine Polynomial
+
+open scoped WeierstrassCurve.Affine
+
+variable {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K]
+variable (W : WeierstrassCurve F)
+
+theorem smul_x_eq [W.IsElliptic] {n : ℕ} (hn : 0 < n) {x₀ y₀ : K}
+    (h : (W.baseChange K).toAffine.Nonsingular x₀ y₀)
+    (hns : ((W.baseChange K).ΨSq n).eval x₀ ≠ 0) :
+    ∃ (x' y' : K) (h' : (W.baseChange K).toAffine.Nonsingular x' y'),
+      n • (Point.some x₀ y₀ h : W.toAffine⟮K⟯) = Point.some x' y' h' ∧
+        x' * ((W.baseChange K).ΨSq n).eval x₀ = ((W.baseChange K).Φ n).eval x₀ :=
+  (smul_formula_or_zero W hn h).1 hns
+
+omit [DecidableEq K] in
+private lemma eval_ne_of_isCoprime {f g : Polynomial K} (h : IsCoprime f g) {x₀ : K}
+    (hf : f.eval x₀ = 0) (hg : g.eval x₀ = 0) : False := by
+  obtain ⟨a, b, hab⟩ := h
+  have h1 := congrArg (Polynomial.eval x₀) hab
+  simp only [eval_add, eval_mul, hf, hg, mul_zero, add_zero, eval_one] at h1
+  exact zero_ne_one h1
+
+omit [DecidableEq K] in
+theorem isCoprime_Φ_ΨSq [IsAlgClosed K] [W.IsElliptic] {n : ℕ} (hn : 0 < n) :
+    IsCoprime ((W.baseChange K).Φ n) ((W.baseChange K).ΨSq n) := by
+  classical
+  rw [Polynomial.isCoprime_iff_aeval_ne_zero_of_isAlgClosed (k := K) (K := K)]
+  intro x₀
+  by_contra hcon
+  push Not at hcon
+  obtain ⟨hΦ0, hΨ0⟩ := hcon
+  rw [coe_aeval_eq_eval] at hΦ0 hΨ0
+  have hΦdef : (W.baseChange K).Φ (n : ℤ) =
+      X * (W.baseChange K).ΨSq (n : ℤ) -
+        (W.baseChange K).preΨ ((n : ℤ) + 1) * (W.baseChange K).preΨ ((n : ℤ) - 1) *
+          (if Even (n : ℤ) then 1 else (W.baseChange K).Ψ₂Sq) := rfl
+  have h0 : ((W.baseChange K).preΨ ((n : ℤ) + 1)).eval x₀ *
+      ((W.baseChange K).preΨ ((n : ℤ) - 1)).eval x₀ *
+      (if Even (n : ℤ) then (1 : K) else ((W.baseChange K).Ψ₂Sq).eval x₀) = 0 := by
+    have h1 := congrArg (Polynomial.eval x₀) hΦdef
+    rw [hΦ0] at h1
+    simp only [eval_sub, eval_mul, eval_X, apply_ite (Polynomial.eval x₀), eval_one, hΨ0,
+      mul_zero, zero_sub] at h1
+    linear_combination h1
+  rcases mul_eq_zero.mp h0 with h12 | hG
+  · rcases mul_eq_zero.mp h12 with hE | hF
+    · have hb : ((W.baseChange K).ΨSq ((n : ℤ) + 1)).eval x₀ = 0 := by
+        have h2 := ΨSq_eval_eq_zero_of_preΨ W (m := n + 1) (K := K)
+          (by rwa [Nat.cast_add, Nat.cast_one])
+        rwa [Nat.cast_add, Nat.cast_one] at h2
+      exact eval_ne_of_isCoprime (isCoprime_ΨSq_succ W n) hΨ0 hb
+    · have hb : ((W.baseChange K).ΨSq ((n - 1 : ℕ) : ℤ)).eval x₀ = 0 :=
+        ΨSq_eval_eq_zero_of_preΨ W (m := n - 1) (K := K)
+          (by rwa [Nat.cast_sub hn, Nat.cast_one])
+      have hA := isCoprime_ΨSq_succ W (K := K) (n - 1)
+      have hc : ((n - 1 : ℕ) : ℤ) + 1 = (n : ℤ) := by omega
+      rw [hc] at hA
+      exact eval_ne_of_isCoprime hA hb hΨ0
+  · by_cases hev : Even (n : ℤ)
+    · rw [ite_eq_left hev] at hG
+      exact one_ne_zero hG
+    · rw [ite_eq_right hev] at hG
+      have hnodd : ¬Even n := fun h => hev (by exact_mod_cast h)
+      have hb : ((W.baseChange K).ΨSq ((n : ℤ) + 1)).eval x₀ = 0 := by
+        have h2 : ((W.baseChange K).ΨSq ((n + 1 : ℕ) : ℤ)).eval x₀ = 0 := by
+          rw [ΨSq_ofNat, ite_eq_left (Nat.even_add_one.mpr hnodd), eval_mul, hG, mul_zero]
+        rwa [Nat.cast_add, Nat.cast_one] at h2
+      exact eval_ne_of_isCoprime (isCoprime_ΨSq_succ W n) hΨ0 hb
+
+theorem smul_eq_zero_of_ΨSq_eval_eq_zero [W.IsElliptic] {n : ℕ} (hn : 0 < n)
+    {x₀ y₀ : K} (h : (W.baseChange K).toAffine.Nonsingular x₀ y₀)
+    (hz : ((W.baseChange K).ΨSq n).eval x₀ = 0) :
+    n • (Point.some x₀ y₀ h : W.toAffine⟮K⟯) = 0 :=
+  (smul_formula_or_zero W hn h).2 hz
+
+omit [DecidableEq K] in
+theorem ΨSq_odd_eq_sq {n : ℕ} (hodd : Odd n) :
+    (W.baseChange K).ΨSq n = ((W.baseChange K).preΨ' n) ^ 2 := by
+  rw [ΨSq_ofNat, ite_eq_right (Nat.not_even_iff_odd.mpr hodd), mul_one]
+
+theorem smul_eq_zero_iff_preΨ'_eval [W.IsElliptic] {n : ℕ} (hodd : Odd n)
+    (hn : 0 < n) {x y : K} (h : (W.baseChange K).toAffine.Nonsingular x y) :
+    n • (Point.some x y h : W.toAffine⟮K⟯) = 0 ↔
+      ((W.baseChange K).preΨ' n).eval x = 0 := by
+  constructor
+  · intro hsmul
+    by_contra hne
+    have hns : ((W.baseChange K).ΨSq n).eval x ≠ 0 := by
+      rw [ΨSq_odd_eq_sq W hodd, eval_pow]
+      exact pow_ne_zero 2 hne
+    obtain ⟨x', y', h', heq, -⟩ := smul_x_eq W hn h hns
+    rw [hsmul] at heq
+    exact Point.some_ne_zero h' heq.symm
+  · intro hz
+    have hz' : ((W.baseChange K).ΨSq n).eval x = 0 := by
+      rw [ΨSq_odd_eq_sq W hodd, eval_pow, hz]
+      exact zero_pow two_ne_zero
+    exact smul_eq_zero_of_ΨSq_eval_eq_zero W hn h hz'
+
+end Deep.Gen
+
+end PortGenSmulFormula
+
+section PortGenCardViaFibers
+
+namespace Deep
+namespace Gen
+
+open WeierstrassCurve WeierstrassCurve.Affine Polynomial
+
+open scoped WeierstrassCurve.Affine
+
+variable {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K]
+variable (W : WeierstrassCurve F)
+
+def nTorsion (n : ℕ) : AddSubgroup W.toAffine⟮K⟯ where
+  carrier := {P | n • P = 0}
+  zero_mem' := smul_zero n
+  add_mem' {P Q} hP hQ := by
+    have hP' : n • P = 0 := hP
+    have hQ' : n • Q = 0 := hQ
+    change n • (P + Q) = 0
+    calc n • (P + Q) = n • P + n • Q := smul_add n P Q
+    _ = 0 := by rw [hP', hQ', add_zero]
+  neg_mem' {P} hP := by
+    have hP' : n • P = 0 := hP
+    change n • (-P) = 0
+    calc n • (-P) = -(n • P) := smul_neg n P
+    _ = 0 := by rw [hP', neg_zero]
+
+theorem squarefree_roots_nodup {R : Type*} [CommRing R] [IsDomain R] {p : R[X]}
+    (hsq : Squarefree p) : p.roots.Nodup := by
+  classical
+  rw [Multiset.nodup_iff_count_le_one]
+  intro a
+  rw [count_roots]
+  by_contra h
+  push Not at h
+  have h2 : (X - C a) * (X - C a) ∣ p := by
+    calc (X - C a) * (X - C a) = (X - C a) ^ 2 := (sq _).symm
+      _ ∣ (X - C a) ^ rootMultiplicity a p := pow_dvd_pow _ h
+      _ ∣ p := pow_rootMultiplicity_dvd p a
+  exact not_isUnit_X_sub_C a (hsq _ h2)
+
+theorem separable_of_splits_of_squarefree {L : Type*} [Field L] {p : L[X]}
+    (hp : p ≠ 0) (hs : p.Splits) (hsq : Squarefree p) : p.Separable :=
+  (nodup_roots_iff_of_splits hp hs).mp (squarefree_roots_nodup hsq)
+
+omit [DecidableEq K] in
+theorem wronskian_Φ_ΨSq_ne_zero [W.IsElliptic] {n : ℕ} (hn : (n : K) ≠ 0) :
+    derivative ((W.baseChange K).Φ n) * (W.baseChange K).ΨSq n -
+      (W.baseChange K).Φ n * derivative ((W.baseChange K).ΨSq n) ≠ 0 := by
+  have hn0 : n ≠ 0 := by rintro rfl; simp at hn
+  obtain rfl | h2 : n = 1 ∨ 2 ≤ n := by omega
+  · simp [Φ_one, ΨSq_one]
+  · set E := W.baseChange K with hE
+    have hnQ : ((n : ℕ) : K) ≠ 0 := hn
+    have hm4 : 4 ≤ n ^ 2 := by nlinarith
+    have hFlc : (E.Φ n).coeff (n ^ 2) = 1 := by
+      simpa using WeierstrassCurve.coeff_Φ E (n : ℤ)
+    have hGlc : (E.ΨSq n).coeff (n ^ 2 - 1) = (n : K) ^ 2 := by
+      simpa using WeierstrassCurve.coeff_ΨSq E (n : ℤ)
+    have hF'c : (derivative (E.Φ n)).coeff (n ^ 2 - 1) =
+        ((n ^ 2 - 1 : ℕ) : K) + 1 := by
+      rw [coeff_derivative, Nat.sub_add_cancel (by omega : 1 ≤ n ^ 2), hFlc, one_mul]
+    have hG'c : (derivative (E.ΨSq n)).coeff (n ^ 2 - 2) =
+        (n : K) ^ 2 * (((n ^ 2 - 2 : ℕ) : K) + 1) := by
+      rw [coeff_derivative, (by omega : n ^ 2 - 2 + 1 = n ^ 2 - 1), hGlc]
+    have hFdegle : (E.Φ n).natDegree ≤ n ^ 2 := by
+      have h := WeierstrassCurve.natDegree_Φ_le E (n : ℤ)
+      rwa [Int.natAbs_natCast] at h
+    have hGdegle : (E.ΨSq n).natDegree ≤ n ^ 2 - 1 := by
+      have h := WeierstrassCurve.natDegree_ΨSq_le E (n : ℤ)
+      rwa [Int.natAbs_natCast] at h
+    have hF'le : (derivative (E.Φ n)).natDegree ≤ n ^ 2 - 1 := by
+      have h := natDegree_derivative_le (E.Φ (n : ℤ))
+      omega
+    have hG'le : (derivative (E.ΨSq n)).natDegree ≤ n ^ 2 - 2 := by
+      have h := natDegree_derivative_le (E.ΨSq (n : ℤ))
+      omega
+    intro hzero
+    have hco : (derivative (E.Φ n) * E.ΨSq n - E.Φ n * derivative (E.ΨSq n)).coeff
+        (2 * n ^ 2 - 2) = 0 := by rw [hzero, coeff_zero]
+    have e1 : (derivative (E.Φ n) * E.ΨSq n).coeff (2 * n ^ 2 - 2) =
+        (((n ^ 2 - 1 : ℕ) : K) + 1) * (n : K) ^ 2 := by
+      rw [(by omega : 2 * n ^ 2 - 2 = (n ^ 2 - 1) + (n ^ 2 - 1)),
+        coeff_mul_add_eq_of_natDegree_le hF'le hGdegle, hF'c, hGlc]
+    have e2 : (E.Φ n * derivative (E.ΨSq n)).coeff (2 * n ^ 2 - 2) =
+        1 * ((n : K) ^ 2 * (((n ^ 2 - 2 : ℕ) : K) + 1)) := by
+      rw [(by omega : 2 * n ^ 2 - 2 = n ^ 2 + (n ^ 2 - 2)),
+        coeff_mul_add_eq_of_natDegree_le hFdegle hG'le, hFlc, hG'c]
+    rw [coeff_sub, e1, e2] at hco
+    have c1 : ((n ^ 2 - 1 : ℕ) : K) = (n : K) ^ 2 - 1 := by
+      push_cast [Nat.cast_sub (by omega : 1 ≤ n ^ 2)]
+      ring
+    have c2 : ((n ^ 2 - 2 : ℕ) : K) = (n : K) ^ 2 - 2 := by
+      push_cast [Nat.cast_sub (by omega : 2 ≤ n ^ 2)]
+      ring
+    rw [c1, c2] at hco
+    exact pow_ne_zero 2 hnQ (by linear_combination hco)
+
+omit [DecidableEq K] in
+theorem finite_not_squarefree_fiber [IsAlgClosed K] [W.IsElliptic] {n : ℕ}
+    (hn : (n : K) ≠ 0) :
+    {c : K | ¬ Squarefree
+      ((W.baseChange K).Φ n - C c * (W.baseChange K).ΨSq n)}.Finite := by
+  classical
+  have hpos : 0 < n := Nat.pos_of_ne_zero (by rintro rfl; simp at hn)
+  set F' := (W.baseChange K).Φ n with hFdef
+  set G := (W.baseChange K).ΨSq n with hGdef
+  have hWr : derivative F' * G - F' * derivative G ≠ 0 := wronskian_Φ_ΨSq_ne_zero W hn
+  have hroots : {x : K | (derivative F' * G - F' * derivative G).IsRoot x}.Finite :=
+    Polynomial.finite_setOfPred_isRoot hWr
+  refine Set.Finite.subset (hroots.image (fun x => F'.eval x / G.eval x)) ?_
+  intro c hc
+  rw [Set.mem_ofPred_eq] at hc
+  unfold Squarefree at hc
+  push Not at hc
+  obtain ⟨q, hq2, hqu⟩ := hc
+  have hqdeg : q.degree ≠ 0 := fun h => hqu (isUnit_iff_degree_eq_zero.mpr h)
+  obtain ⟨x, hx⟩ := IsAlgClosed.exists_root q hqdeg
+  have hdvd : (X - C x) * (X - C x) ∣ F' - C c * G :=
+    dvd_trans (mul_dvd_mul (dvd_iff_isRoot.mpr hx) (dvd_iff_isRoot.mpr hx)) hq2
+  obtain ⟨r, hr⟩ := hdvd
+  have hpx : (F' - C c * G).eval x = 0 := by rw [hr]; simp
+  have hp'x : (derivative (F' - C c * G)).eval x = 0 := by
+    rw [hr]
+    simp [derivative_mul, derivative_sub, derivative_X, derivative_C]
+  have hFx : F'.eval x = c * G.eval x := by
+    have h := hpx
+    simp only [eval_sub, eval_mul, eval_C] at h
+    exact sub_eq_zero.mp h
+  have hF'x : (derivative F').eval x = c * (derivative G).eval x := by
+    have h := hp'x
+    rw [derivative_sub, derivative_C_mul] at h
+    simp only [eval_sub, eval_mul, eval_C] at h
+    exact sub_eq_zero.mp h
+  have hGx : G.eval x ≠ 0 := by
+    intro hG0
+    have hF0 : F'.eval x = 0 := by rw [hFx, hG0, mul_zero]
+    obtain ⟨a, b, hab⟩ := isCoprime_Φ_ΨSq W (K := K) hpos
+    rw [← hFdef, ← hGdef] at hab
+    have h1 := congrArg (Polynomial.eval x) hab
+    rw [eval_add, eval_mul, eval_mul, eval_one, hF0, hG0, mul_zero, mul_zero,
+      add_zero] at h1
+    exact zero_ne_one h1
+  refine ⟨x, ?_, ?_⟩
+  · change (derivative F' * G - F' * derivative G).IsRoot x
+    simp only [IsRoot, eval_sub, eval_mul]
+    rw [hFx, hF'x]
+    ring
+  · change F'.eval x / G.eval x = c
+    rw [hFx, mul_div_assoc, div_self hGx, mul_one]
+
+section AlgClosed
+
+variable [IsAlgClosed K]
+
+theorem smul_surjective [W.IsElliptic] {n : ℕ} (hodd : Odd n) (hn : (n : K) ≠ 0) :
+    Function.Surjective (fun P : W.toAffine⟮K⟯ => n • P) := by
+  have hpos : 0 < n := Nat.pos_of_ne_zero (by rintro rfl; simp at hn)
+  intro Q
+  rcases Q with _ | ⟨xQ, yQ, hQ⟩
+  · refine ⟨0, ?_⟩
+    change n • (0 : W.toAffine⟮K⟯) = Point.zero
+    rw [nsmul_zero]
+    exact Point.zero_def
+  set F' := (W.baseChange K).Φ n with hFdef
+  set G := (W.baseChange K).ΨSq n with hGdef
+  have hnQ : ((n : ℕ) : K) ≠ 0 := hn
+  have hnZ : (((n : ℕ) : ℤ) : K) ≠ 0 := by exact_mod_cast hnQ
+  have hFdeg : F'.natDegree = n ^ 2 := by
+    have h := WeierstrassCurve.natDegree_Φ (W.baseChange K) (n : ℤ)
+    rw [Int.natAbs_natCast] at h
+    rw [hFdef, h]
+  have hGdeg : G.natDegree = n ^ 2 - 1 := by
+    have h := WeierstrassCurve.natDegree_ΨSq (W.baseChange K) hnZ
+    rw [Int.natAbs_natCast] at h
+    rw [hGdef, h]
+  have h1n : 1 ≤ n ^ 2 := Nat.one_le_iff_ne_zero.mpr (pow_ne_zero 2 hpos.ne')
+  set p : K[X] := F' - C xQ * G with hpdef
+  have hpdeg : p.natDegree = n ^ 2 := by
+    rw [hpdef]
+    rw [natDegree_sub_eq_left_of_natDegree_lt, hFdeg]
+    refine lt_of_le_of_lt (natDegree_C_mul_le xQ G) ?_
+    rw [hFdeg, hGdeg]
+    omega
+  have hpdegne : p.degree ≠ 0 := by
+    have hpos' : 0 < p.natDegree := by rw [hpdeg]; omega
+    exact (natDegree_pos_iff_degree_pos.mp hpos').ne'
+  obtain ⟨x₀, hx₀⟩ := IsAlgClosed.exists_root p hpdegne
+  have hpx : p.eval x₀ = 0 := hx₀
+  have hroot : F'.eval x₀ = xQ * G.eval x₀ := by
+    rw [hpdef, eval_sub, eval_mul, eval_C, sub_eq_zero] at hpx
+    exact hpx
+  have hGx : G.eval x₀ ≠ 0 := by
+    intro hG0
+    have hF0 : F'.eval x₀ = 0 := by rw [hroot, hG0, mul_zero]
+    obtain ⟨a, b, hab⟩ := isCoprime_Φ_ΨSq W (K := K) hpos
+    rw [← hFdef, ← hGdef] at hab
+    have h1 := congrArg (Polynomial.eval x₀) hab
+    rw [eval_add, eval_mul, eval_mul, eval_one, hF0, hG0, mul_zero, mul_zero,
+      add_zero] at h1
+    exact zero_ne_one h1
+  obtain ⟨y₀, hy₀⟩ : ∃ y : K, (W.baseChange K).toAffine.Equation x₀ y := by
+    obtain ⟨y, hy⟩ := IsAlgClosed.exists_root
+      (C 1 * X ^ 2 + C ((W.baseChange K).a₁ * x₀ + (W.baseChange K).a₃) * X
+        + C (-(x₀ ^ 3 + (W.baseChange K).a₂ * x₀ ^ 2 + (W.baseChange K).a₄ * x₀ +
+            (W.baseChange K).a₆)))
+      (by rw [degree_quadratic one_ne_zero]; norm_num)
+    refine ⟨y, ?_⟩
+    rw [WeierstrassCurve.Affine.equation_iff]
+    simp only [IsRoot, eval_add, eval_mul, eval_pow, eval_C, eval_X, one_mul] at hy
+    linear_combination hy
+  have h₀ : (W.baseChange K).toAffine.Nonsingular x₀ y₀ :=
+    WeierstrassCurve.Affine.equation_iff_nonsingular.mp hy₀
+  obtain ⟨x', y', h', hsmul, hx'⟩ := smul_x_eq W hpos h₀ hGx
+  rw [← hFdef, ← hGdef] at hx'
+  have hx'Q : x' = xQ := by
+    rw [hroot] at hx'
+    exact mul_right_cancel₀ hGx hx'
+  subst hx'Q
+  rcases WeierstrassCurve.Affine.Y_eq_of_X_eq h'.1 hQ.1 rfl with rfl | rfl
+  · exact ⟨Point.some x₀ y₀ h₀, hsmul⟩
+  · have hnegQ : -(Point.some x' yQ hQ : W.toAffine⟮K⟯) =
+        Point.some x' ((W.baseChange K).toAffine.negY x' yQ)
+          ((WeierstrassCurve.Affine.nonsingular_neg ..).mpr hQ) := Point.neg_some hQ
+    have hprev : n • (Point.some x₀ y₀ h₀ : W.toAffine⟮K⟯) =
+        -(Point.some x' yQ hQ) := by
+      rw [hnegQ]
+      exact hsmul
+    have hsn : n • -(Point.some x₀ y₀ h₀ : W.toAffine⟮K⟯) =
+        -(n • (Point.some x₀ y₀ h₀ : W.toAffine⟮K⟯)) :=
+      neg_nsmul (Point.some x₀ y₀ h₀ : W.toAffine⟮K⟯) n
+    refine ⟨-(Point.some x₀ y₀ h₀), ?_⟩
+    change n • -(Point.some x₀ y₀ h₀ : W.toAffine⟮K⟯) = Point.some x' yQ hQ
+    rw [hsn, hprev, neg_neg]
+
+theorem card_smul_fiber [W.IsElliptic] {n : ℕ} (hodd : Odd n) (hn : (n : K) ≠ 0)
+    (Q : W.toAffine⟮K⟯) :
+    Nat.card {P : W.toAffine⟮K⟯ // n • P = Q} = Nat.card (nTorsion W (K := K) n) := by
+  obtain ⟨P₀, hP₀⟩ := smul_surjective W hodd hn Q
+  have hP₀' : n • P₀ = Q := hP₀
+  have e : nTorsion W (K := K) n ≃ {P : W.toAffine⟮K⟯ // n • P = Q} := by
+    refine Equiv.subtypeEquiv (Equiv.addRight P₀) fun P => ?_
+    change (P ∈ nTorsion W n) ↔ n • (P + P₀) = Q
+    have hsa : n • (P + P₀) = n • P + n • P₀ := nsmul_add P P₀ n
+    rw [hsa, hP₀']
+    constructor
+    · intro h
+      have h' : n • P = 0 := h
+      rw [h', zero_add]
+    · intro h
+      change n • P = 0
+      exact add_right_cancel (h.trans (zero_add Q).symm)
+  exact (Nat.card_congr e).symm
+
+private noncomputable def qpoly (x : K) : K[X] :=
+  X ^ 2 + (C ((W.baseChange K).a₁ * x + (W.baseChange K).a₃) * X +
+    C (-(x ^ 3 + (W.baseChange K).a₂ * x ^ 2 + (W.baseChange K).a₄ * x +
+      (W.baseChange K).a₆)))
+
+omit [DecidableEq K] [IsAlgClosed K] in
+private lemma degree_qpoly (x : K) : (qpoly W x).degree = 2 := by
+  have hlt : (C ((W.baseChange K).a₁ * x + (W.baseChange K).a₃) * X +
+      C (-(x ^ 3 + (W.baseChange K).a₂ * x ^ 2 + (W.baseChange K).a₄ * x +
+        (W.baseChange K).a₆))).degree < ((X : K[X]) ^ 2).degree := by
+    refine lt_of_le_of_lt degree_linear_le ?_
+    rw [degree_X_pow]
+    exact_mod_cast one_lt_two
+  unfold qpoly
+  rw [degree_add_eq_left_of_degree_lt hlt, degree_X_pow]
+  exact Nat.cast_ofNat
+
+omit [DecidableEq K] [IsAlgClosed K] in
+private lemma qpoly_ne_zero (x : K) : qpoly W x ≠ 0 := by
+  intro h
+  have hd := degree_qpoly W x
+  rw [h, degree_zero] at hd
+  simp at hd
+
+omit [DecidableEq K] [IsAlgClosed K] in
+private lemma isRoot_qpoly_iff (x y : K) :
+    (qpoly W x).IsRoot y ↔ (W.baseChange K).toAffine.Equation x y := by
+  rw [WeierstrassCurve.Affine.equation_iff]
+  unfold qpoly
+  simp only [IsRoot, eval_add, eval_mul, eval_pow, eval_C, eval_X]
+  constructor <;> intro h <;> linear_combination h
+
+omit [DecidableEq K] in
+private lemma exists_equation_y (x : K) :
+    ∃ y : K, (W.baseChange K).toAffine.Equation x y := by
+  obtain ⟨y, hy⟩ := IsAlgClosed.exists_root (qpoly W x)
+    (by rw [degree_qpoly]; norm_num)
+  exact ⟨y, (isRoot_qpoly_iff W x y).mp hy⟩
+
+private noncomputable def coords : W.toAffine⟮K⟯ → K × K
+  | .zero => (0, 0)
+  | .some x y _ => (x, y)
+
+omit [DecidableEq K] [IsAlgClosed K] in
+theorem Ψ₂Sq_ne_zero_of_isElliptic [W.IsElliptic] : (W.baseChange K).Ψ₂Sq ≠ 0 := by
+  intro h0
+  set E := W.baseChange K with hE
+  rw [Ψ₂Sq_eq, Cubic.toPoly_eq_zero_iff] at h0
+  have h4 : (4 : K) = 0 := congrArg Cubic.a h0
+  have hb₂ : E.b₂ = 0 := congrArg Cubic.b h0
+  have hb₆ : E.b₆ = 0 := congrArg Cubic.d h0
+  have h2 : (2 : K) = 0 := by
+    have h22 : (2 : K) * 2 = 0 := by linear_combination h4
+    rcases mul_eq_zero.mp h22 with h | h <;> exact h
+  have hΔ : E.Δ = 0 := by
+    rw [show E.Δ = -E.b₂ ^ 2 * E.b₈ - 8 * E.b₄ ^ 3 - 27 * E.b₆ ^ 2 +
+        9 * E.b₂ * E.b₄ * E.b₆ from rfl]
+    linear_combination (-E.b₂ * E.b₈ + 9 * E.b₄ * E.b₆) * hb₂ +
+      (-27 * E.b₆) * hb₆ + (-4 * E.b₄ ^ 3) * h2
+  exact E.isUnit_Δ.ne_zero hΔ
+
+theorem exists_double_fiber_card [W.IsElliptic] {n : ℕ} (hodd : Odd n)
+    (hn : (n : K) ≠ 0) :
+    ∃ Q : W.toAffine⟮K⟯,
+      Nat.card {P : W.toAffine⟮K⟯ // n • P = Q ∨ n • P = -Q} = 2 * n ^ 2 := by
+  classical
+  have hpos : 0 < n := Nat.pos_of_ne_zero (by rintro rfl; simp at hn)
+  set F' := (W.baseChange K).Φ n with hFdef
+  set G := (W.baseChange K).ΨSq n with hGdef
+  have hnQ : ((n : ℕ) : K) ≠ 0 := hn
+  have hnZ : (((n : ℕ) : ℤ) : K) ≠ 0 := by exact_mod_cast hnQ
+  have hB : {c : K | ¬ Squarefree (F' - C c * G)}.Finite := finite_not_squarefree_fiber W hn
+  have hΨ₂ne : (W.baseChange K).Ψ₂Sq ≠ 0 := Ψ₂Sq_ne_zero_of_isElliptic W
+  have hB' : ((fun x => F'.eval x / G.eval x) ''
+      {x : K | (W.baseChange K).Ψ₂Sq.IsRoot x}).Finite :=
+    (Polynomial.finite_setOfPred_isRoot hΨ₂ne).image _
+  obtain ⟨c, hc⟩ := (hB.union hB').infinite_compl.nonempty
+  rw [Set.mem_compl_iff, Set.mem_union] at hc
+  push Not at hc
+  obtain ⟨hcB, hcB'⟩ := hc
+  have hsqf : Squarefree (F' - C c * G) := not_not.mp hcB
+  obtain ⟨yQ, hyQ⟩ := exists_equation_y W c
+  have hQns : (W.baseChange K).toAffine.Nonsingular c yQ :=
+    WeierstrassCurve.Affine.equation_iff_nonsingular.mp hyQ
+  refine ⟨Point.some c yQ hQns, ?_⟩
+  set p : K[X] := F' - C c * G with hpdef
+  have hFdeg : F'.natDegree = n ^ 2 := by
+    have h := WeierstrassCurve.natDegree_Φ (W.baseChange K) (n : ℤ)
+    rw [Int.natAbs_natCast] at h
+    rw [hFdef, h]
+  have hGdeg : G.natDegree = n ^ 2 - 1 := by
+    have h := WeierstrassCurve.natDegree_ΨSq (W.baseChange K) hnZ
+    rw [Int.natAbs_natCast] at h
+    rw [hGdef, h]
+  have hpdeg : p.natDegree = n ^ 2 := by
+    rw [hpdef]
+    rw [natDegree_sub_eq_left_of_natDegree_lt, hFdeg]
+    refine lt_of_le_of_lt (natDegree_C_mul_le c G) ?_
+    rw [hFdeg, hGdeg]
+    have : 1 ≤ n ^ 2 := Nat.one_le_iff_ne_zero.mpr (pow_ne_zero 2 hpos.ne')
+    omega
+  have hpco : p.coeff (n ^ 2) = 1 := by
+    have hF1 : F'.coeff (n ^ 2) = 1 := by
+      have h := WeierstrassCurve.coeff_Φ (W.baseChange K) (n : ℤ)
+      rw [Int.natAbs_natCast] at h
+      rw [hFdef, h]
+    have hG0 : G.coeff (n ^ 2) = 0 := by
+      refine coeff_eq_zero_of_natDegree_lt ?_
+      rw [hGdeg]
+      have : 1 ≤ n ^ 2 := Nat.one_le_iff_ne_zero.mpr (pow_ne_zero 2 hpos.ne')
+      omega
+    rw [hpdef, coeff_sub, coeff_C_mul, hF1, hG0, mul_zero, sub_zero]
+  have hpne : p ≠ 0 := by
+    intro h
+    rw [h, coeff_zero] at hpco
+    exact zero_ne_one hpco
+  have hnodup : p.roots.Nodup := squarefree_roots_nodup hsqf
+  have hroots_card : p.roots.toFinset.card = n ^ 2 := by
+    rw [Multiset.toFinset_card_of_nodup hnodup,
+      ← (IsAlgClosed.splits p).natDegree_eq_card_roots, hpdeg]
+  have key_F : ∀ x : K, p.eval x = 0 → F'.eval x = c * G.eval x := by
+    intro x hx
+    rw [hpdef, eval_sub, eval_mul, eval_C, sub_eq_zero] at hx
+    exact hx
+  have key_G : ∀ x : K, p.eval x = 0 → G.eval x ≠ 0 := by
+    intro x hx hG0
+    have hF0 : F'.eval x = 0 := by rw [key_F x hx, hG0, mul_zero]
+    obtain ⟨a, b, hab⟩ := isCoprime_Φ_ΨSq W (K := K) hpos
+    rw [← hFdef, ← hGdef] at hab
+    have h1 := congrArg (Polynomial.eval x) hab
+    rw [eval_add, eval_mul, eval_mul, eval_one, hF0, hG0, mul_zero, mul_zero,
+      add_zero] at h1
+    exact zero_ne_one h1
+  have key_Ψ₂ : ∀ x : K, p.eval x = 0 → (W.baseChange K).Ψ₂Sq.eval x ≠ 0 := by
+    intro x hx h2
+    refine hcB' ⟨x, h2, ?_⟩
+    change F'.eval x / G.eval x = c
+    rw [key_F x hx, mul_div_assoc, div_self (key_G x hx), mul_one]
+  set R2fin : Finset (K × K) := p.roots.toFinset.biUnion
+    (fun x => (qpoly W x).roots.toFinset.image (fun y => (x, y))) with hR2def
+  have hmemR2 : ∀ z : K × K, z ∈ R2fin ↔
+      p.eval z.1 = 0 ∧ (W.baseChange K).toAffine.Equation z.1 z.2 := by
+    intro z
+    rw [hR2def, Finset.mem_biUnion]
+    constructor
+    · rintro ⟨x, hx, hz⟩
+      rw [Finset.mem_image] at hz
+      obtain ⟨y, hy, rfl⟩ := hz
+      rw [Multiset.mem_toFinset, mem_roots hpne] at hx
+      rw [Multiset.mem_toFinset, mem_roots (qpoly_ne_zero W x)] at hy
+      exact ⟨hx, (isRoot_qpoly_iff W x y).mp hy⟩
+    · rintro ⟨h1, h2⟩
+      refine ⟨z.1, ?_, ?_⟩
+      · rw [Multiset.mem_toFinset, mem_roots hpne]
+        exact h1
+      · rw [Finset.mem_image]
+        exact ⟨z.2, by
+          rw [Multiset.mem_toFinset, mem_roots (qpoly_ne_zero W z.1)]
+          exact (isRoot_qpoly_iff W z.1 z.2).mpr h2, rfl⟩
+  have hfiber2 : ∀ x ∈ p.roots.toFinset,
+      ((qpoly W x).roots.toFinset.image (fun y => (x, y))).card = 2 := by
+    intro x hx
+    rw [Multiset.mem_toFinset, mem_roots hpne] at hx
+    obtain ⟨y₀, hy₀⟩ := exists_equation_y W x
+    have hny₀ : (W.baseChange K).toAffine.Equation x
+        ((W.baseChange K).toAffine.negY x y₀) :=
+      (WeierstrassCurve.Affine.equation_neg x y₀).mpr hy₀
+    have hyne : y₀ ≠ (W.baseChange K).toAffine.negY x y₀ := by
+      intro hy
+      refine key_Ψ₂ x hx ?_
+      have hsq := sub_negY_sq_eq_Ψ₂Sq_eval ((W.baseChange K).toAffine) hy₀
+      rw [← hsq, ← hy, sub_self]
+      ring
+    rw [Finset.card_image_of_injective _ (fun a b hab => (Prod.ext_iff.mp hab).2)]
+    refine le_antisymm ?_ ?_
+    · refine le_trans (Multiset.toFinset_card_le _) (le_trans (card_roots' _) ?_)
+      rw [natDegree_eq_of_degree_eq_some (degree_qpoly W x)]
+    · have hsub : ({y₀, (W.baseChange K).toAffine.negY x y₀} : Finset K) ⊆
+          (qpoly W x).roots.toFinset := by
+        intro y hy
+        rw [Finset.mem_insert, Finset.mem_singleton] at hy
+        rw [Multiset.mem_toFinset, mem_roots (qpoly_ne_zero W x)]
+        rcases hy with rfl | rfl
+        · exact (isRoot_qpoly_iff W x y).mpr hy₀
+        · exact (isRoot_qpoly_iff W x _).mpr hny₀
+      calc 2 = ({y₀, (W.baseChange K).toAffine.negY x y₀} : Finset K).card :=
+            (Finset.card_pair hyne).symm
+        _ ≤ _ := Finset.card_le_card hsub
+  have hR2card : R2fin.card = 2 * n ^ 2 := by
+    rw [hR2def, Finset.card_biUnion]
+    · rw [Finset.sum_congr rfl hfiber2, Finset.sum_const, smul_eq_mul, hroots_card,
+        mul_comm]
+    · intro x₁ hx₁ x₂ hx₂ hne
+      simp only [Function.onFun]
+      rw [Finset.disjoint_left]
+      rintro z hz₁ hz₂
+      rw [Finset.mem_image] at hz₁ hz₂
+      obtain ⟨y₁, -, rfl⟩ := hz₁
+      obtain ⟨y₂, -, hz⟩ := hz₂
+      exact hne ((Prod.ext_iff.mp hz).1.symm)
+  set Q : W.toAffine⟮K⟯ := Point.some c yQ hQns with hQdef
+  have hQ0 : Q ≠ 0 := Point.some_ne_zero hQns
+  have hnegQ : -Q = Point.some c ((W.baseChange K).toAffine.negY c yQ)
+      ((WeierstrassCurve.Affine.nonsingular_neg ..).mpr hQns) := Point.neg_some hQns
+  have hPne0 : ∀ P : W.toAffine⟮K⟯, (n • P = Q ∨ n • P = -Q) → P ≠ 0 := by
+    rintro P hP rfl
+    rw [nsmul_zero] at hP
+    rcases hP with h | h
+    · exact hQ0 h.symm
+    · exact hQ0 (neg_eq_zero.mp h.symm)
+  have hmaps : Set.MapsTo (coords W) {P : W.toAffine⟮K⟯ | n • P = Q ∨ n • P = -Q}
+      ↑R2fin := by
+    rintro P hP
+    have hP0 : P ≠ 0 := hPne0 P hP
+    rcases P with _ | ⟨x, y, h⟩
+    · exact absurd Point.zero_def.symm hP0
+    · have hP' : n • (Point.some x y h : W.toAffine⟮K⟯) = Q ∨
+          n • (Point.some x y h : W.toAffine⟮K⟯) = -Q := hP
+      have hGx : G.eval x ≠ 0 := by
+        intro hG0
+        have hz : n • (Point.some x y h : W.toAffine⟮K⟯) = 0 :=
+          smul_eq_zero_of_ΨSq_eval_eq_zero W hpos h hG0
+        rw [hz] at hP'
+        rcases hP' with h' | h'
+        · exact hQ0 h'.symm
+        · exact hQ0 (neg_eq_zero.mp h'.symm)
+      obtain ⟨x', y', h', hsmul, hx'⟩ := smul_x_eq W hpos h hGx
+      have hx'c : x' = c := by
+        rw [hsmul] at hP'
+        rcases hP' with h'' | h''
+        · rw [hQdef] at h''
+          exact (Point.some.inj h'').1
+        · rw [hnegQ] at h''
+          exact (Point.some.inj h'').1
+      have hpx : p.eval x = 0 := by
+        rw [hpdef, eval_sub, eval_mul, eval_C, sub_eq_zero, ← hx'c]
+        exact hx'.symm
+      rw [Finset.mem_coe, hmemR2]
+      exact ⟨hpx, h.1⟩
+  have hinj : Set.InjOn (coords W) {P : W.toAffine⟮K⟯ | n • P = Q ∨ n • P = -Q} := by
+    rintro P₁ hP₁ P₂ hP₂ hco
+    rcases P₁ with _ | ⟨x₁, y₁, h₁⟩
+    · exact absurd Point.zero_def.symm (hPne0 _ hP₁)
+    · rcases P₂ with _ | ⟨x₂, y₂, h₂⟩
+      · exact absurd Point.zero_def.symm (hPne0 _ hP₂)
+      · simp only [coords] at hco
+        obtain ⟨hx, hy⟩ := Prod.ext_iff.mp hco
+        subst hx
+        subst hy
+        rfl
+  have hsurj : Set.SurjOn (coords W) {P : W.toAffine⟮K⟯ | n • P = Q ∨ n • P = -Q}
+      ↑R2fin := by
+    rintro z hz
+    rw [Finset.mem_coe, hmemR2] at hz
+    obtain ⟨hz1, hz2⟩ := hz
+    obtain ⟨x, y⟩ := z
+    have h : (W.baseChange K).toAffine.Nonsingular x y :=
+      WeierstrassCurve.Affine.equation_iff_nonsingular.mp hz2
+    have hGx : G.eval x ≠ 0 := key_G x hz1
+    obtain ⟨x', y', h', hsmul, hx'⟩ := smul_x_eq W hpos h hGx
+    have hx'c : x' = c := by
+      have hFc := key_F x hz1
+      rw [hFc] at hx'
+      exact mul_right_cancel₀ hGx hx'
+    subst hx'c
+    have hy' := WeierstrassCurve.Affine.Y_eq_of_X_eq h'.1 hQns.1 rfl
+    refine ⟨Point.some x y h, ?_, rfl⟩
+    rcases hy' with rfl | rfl
+    · exact Or.inl hsmul
+    · refine Or.inr ?_
+      rw [hnegQ]
+      exact hsmul
+  have hbij : Set.BijOn (coords W) {P : W.toAffine⟮K⟯ | n • P = Q ∨ n • P = -Q}
+      ↑R2fin := ⟨hmaps, hinj, hsurj⟩
+  calc Nat.card {P : W.toAffine⟮K⟯ // n • P = Q ∨ n • P = -Q}
+      = Set.ncard {P : W.toAffine⟮K⟯ | n • P = Q ∨ n • P = -Q} :=
+        Nat.card_coe_set_eq {P : W.toAffine⟮K⟯ | n • P = Q ∨ n • P = -Q}
+    _ = (coords W '' {P : W.toAffine⟮K⟯ | n • P = Q ∨ n • P = -Q}).ncard :=
+        (hbij.injOn.ncard_image).symm
+    _ = (↑R2fin : Set (K × K)).ncard := by rw [hbij.image_eq]
+    _ = R2fin.card := Set.ncard_coe_finset _
+    _ = 2 * n ^ 2 := hR2card
+
+theorem card_nTorsion_odd_fibers [W.IsElliptic] {n : ℕ} (hodd : Odd n)
+    (hn : (n : K) ≠ 0) :
+    Nat.card (nTorsion W (K := K) n) = n ^ 2 := by
+  classical
+  have hn0 : n ≠ 0 := by rintro rfl; simp at hn
+  obtain ⟨Q, hQ⟩ := exists_double_fiber_card W hodd hn
+  by_cases hQQ : Q = -Q
+  · exfalso
+    simp only [← hQQ, or_self] at hQ
+    rw [card_smul_fiber W hodd hn Q] at hQ
+    have hfin : Finite (nTorsion W (K := K) n) := by
+      refine Nat.finite_of_card_ne_zero ?_
+      rw [hQ]
+      exact mul_ne_zero two_ne_zero (pow_ne_zero 2 hn0)
+    have hdvd : 2 ∣ Nat.card (nTorsion W (K := K) n) := by
+      rw [hQ]; exact dvd_mul_right 2 _
+    have hfact : Fact (Nat.Prime 2) := ⟨Nat.prime_two⟩
+    obtain ⟨g, hg⟩ := exists_prime_addOrderOf_dvd_card' 2 hdvd
+    have hcoe : addOrderOf (g : W.toAffine⟮K⟯) = 2 :=
+      (AddSubgroup.addOrderOf_coe g).trans hg
+    have hgn : n • (g : W.toAffine⟮K⟯) = 0 := g.2
+    have hdvdn : addOrderOf (g : W.toAffine⟮K⟯) ∣ n :=
+      addOrderOf_dvd_of_nsmul_eq_zero hgn
+    rw [hcoe] at hdvdn
+    have hodd' := Nat.odd_iff.mp hodd
+    omega
+  · have hdisj : Disjoint (fun P : W.toAffine⟮K⟯ => n • P = Q)
+        (fun P : W.toAffine⟮K⟯ => n • P = -Q) := by
+      rw [Pi.disjoint_iff]
+      intro P
+      rw [Prop.disjoint_iff]
+      rintro ⟨h1, h2⟩
+      exact hQQ (h1 ▸ h2)
+    have e := subtypeOrEquiv (fun P : W.toAffine⟮K⟯ => n • P = Q)
+      (fun P : W.toAffine⟮K⟯ => n • P = -Q) hdisj
+    rw [Nat.card_congr e] at hQ
+    have hfinsum : Finite ({P : W.toAffine⟮K⟯ // n • P = Q} ⊕
+        {P : W.toAffine⟮K⟯ // n • P = -Q}) := by
+      refine Nat.finite_of_card_ne_zero ?_
+      rw [hQ]
+      exact mul_ne_zero two_ne_zero (pow_ne_zero 2 hn0)
+    have : Finite {P : W.toAffine⟮K⟯ // n • P = Q} :=
+      Finite.of_injective
+        (Sum.inl : {P : W.toAffine⟮K⟯ // n • P = Q} →
+          {P : W.toAffine⟮K⟯ // n • P = Q} ⊕ {P : W.toAffine⟮K⟯ // n • P = -Q})
+        Sum.inl_injective
+    have : Finite {P : W.toAffine⟮K⟯ // n • P = -Q} :=
+      Finite.of_injective
+        (Sum.inr : {P : W.toAffine⟮K⟯ // n • P = -Q} →
+          {P : W.toAffine⟮K⟯ // n • P = Q} ⊕ {P : W.toAffine⟮K⟯ // n • P = -Q})
+        Sum.inr_injective
+    rw [Nat.card_sum, card_smul_fiber W hodd hn Q, card_smul_fiber W hodd hn (-Q),
+      ← two_mul] at hQ
+    exact Nat.eq_of_mul_eq_mul_left (by norm_num) hQ
+
+end AlgClosed
+
+end Deep.Gen
+
+end PortGenCardViaFibers
+
+section PortGenCard
+
+namespace Deep
+namespace Gen
+
+open WeierstrassCurve WeierstrassCurve.Affine Polynomial
+
+open scoped WeierstrassCurve.Affine
+
+noncomputable section
+
+variable {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K]
+variable (W : WeierstrassCurve F)
+
+theorem mem_nTorsion_two_iff {x y : K} (h : (W.baseChange K).toAffine.Nonsingular x y) :
+    (Point.some x y h : W.toAffine⟮K⟯) ∈ nTorsion W 2 ↔
+      y = (W.baseChange K).toAffine.negY x y := by
+  change 2 • (Point.some x y h : W.toAffine⟮K⟯) = 0 ↔ _
+  rw [two_nsmul, add_eq_zero_iff_eq_neg, Point.neg_some, Point.some.injEq]
+  simp
+
+end
+
+end Deep.Gen
+
+end PortGenCard
+
+section PortGenCardAll
+
+namespace Deep
+namespace Gen
+
+open WeierstrassCurve WeierstrassCurve.Affine Polynomial
+
+open scoped WeierstrassCurve.Affine
+
+noncomputable section
+
+variable {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K]
+variable (W : WeierstrassCurve F)
+
+section AlgClosed
+
+variable [IsAlgClosed K]
+
+theorem smul_surjective_all [W.IsElliptic] {n : ℕ} (hn : (n : K) ≠ 0) :
+    Function.Surjective (fun P : W.toAffine⟮K⟯ => n • P) := by
+  have hpos : 0 < n := Nat.pos_of_ne_zero (by rintro rfl; simp at hn)
+  intro Q
+  rcases Q with _ | ⟨xQ, yQ, hQ⟩
+  · refine ⟨0, ?_⟩
+    change n • (0 : W.toAffine⟮K⟯) = Point.zero
+    rw [nsmul_zero]
+    exact Point.zero_def
+  set F' := (W.baseChange K).Φ n with hFdef
+  set G := (W.baseChange K).ΨSq n with hGdef
+  have hnQ : ((n : ℕ) : K) ≠ 0 := hn
+  have hnZ : (((n : ℕ) : ℤ) : K) ≠ 0 := by exact_mod_cast hnQ
+  have hFdeg : F'.natDegree = n ^ 2 := by
+    have h := WeierstrassCurve.natDegree_Φ (W.baseChange K) (n : ℤ)
+    rw [Int.natAbs_natCast] at h
+    rw [hFdef, h]
+  have hGdeg : G.natDegree = n ^ 2 - 1 := by
+    have h := WeierstrassCurve.natDegree_ΨSq (W.baseChange K) hnZ
+    rw [Int.natAbs_natCast] at h
+    rw [hGdef, h]
+  have h1n : 1 ≤ n ^ 2 := Nat.one_le_iff_ne_zero.mpr (pow_ne_zero 2 hpos.ne')
+  set p : K[X] := F' - C xQ * G with hpdef
+  have hpdeg : p.natDegree = n ^ 2 := by
+    rw [hpdef]
+    rw [natDegree_sub_eq_left_of_natDegree_lt, hFdeg]
+    refine lt_of_le_of_lt (natDegree_C_mul_le xQ G) ?_
+    rw [hFdeg, hGdeg]
+    omega
+  have hpdegne : p.degree ≠ 0 := by
+    have hpos' : 0 < p.natDegree := by rw [hpdeg]; omega
+    exact (natDegree_pos_iff_degree_pos.mp hpos').ne'
+  obtain ⟨x₀, hx₀⟩ := IsAlgClosed.exists_root p hpdegne
+  have hpx : p.eval x₀ = 0 := hx₀
+  have hroot : F'.eval x₀ = xQ * G.eval x₀ := by
+    rw [hpdef, eval_sub, eval_mul, eval_C, sub_eq_zero] at hpx
+    exact hpx
+  have hGx : G.eval x₀ ≠ 0 := by
+    intro hG0
+    have hF0 : F'.eval x₀ = 0 := by rw [hroot, hG0, mul_zero]
+    obtain ⟨a, b, hab⟩ := isCoprime_Φ_ΨSq W (K := K) hpos
+    rw [← hFdef, ← hGdef] at hab
+    have h1 := congrArg (Polynomial.eval x₀) hab
+    rw [eval_add, eval_mul, eval_mul, eval_one, hF0, hG0, mul_zero, mul_zero,
+      add_zero] at h1
+    exact zero_ne_one h1
+  obtain ⟨y₀, hy₀⟩ : ∃ y : K, (W.baseChange K).toAffine.Equation x₀ y := by
+    obtain ⟨y, hy⟩ := IsAlgClosed.exists_root
+      (C 1 * X ^ 2 + C ((W.baseChange K).a₁ * x₀ + (W.baseChange K).a₃) * X
+        + C (-(x₀ ^ 3 + (W.baseChange K).a₂ * x₀ ^ 2 + (W.baseChange K).a₄ * x₀ +
+            (W.baseChange K).a₆)))
+      (by rw [degree_quadratic one_ne_zero]; norm_num)
+    refine ⟨y, ?_⟩
+    rw [WeierstrassCurve.Affine.equation_iff]
+    simp only [IsRoot, eval_add, eval_mul, eval_pow, eval_C, eval_X, one_mul] at hy
+    linear_combination hy
+  have h₀ : (W.baseChange K).toAffine.Nonsingular x₀ y₀ :=
+    WeierstrassCurve.Affine.equation_iff_nonsingular.mp hy₀
+  obtain ⟨x', y', h', hsmul, hx'⟩ := smul_x_eq W hpos h₀ hGx
+  rw [← hFdef, ← hGdef] at hx'
+  have hx'Q : x' = xQ := by
+    rw [hroot] at hx'
+    exact mul_right_cancel₀ hGx hx'
+  subst hx'Q
+  rcases WeierstrassCurve.Affine.Y_eq_of_X_eq h'.1 hQ.1 rfl with rfl | rfl
+  · exact ⟨Point.some x₀ y₀ h₀, hsmul⟩
+  · have hnegQ : -(Point.some x' yQ hQ : W.toAffine⟮K⟯) =
+        Point.some x' ((W.baseChange K).toAffine.negY x' yQ)
+          ((WeierstrassCurve.Affine.nonsingular_neg ..).mpr hQ) := Point.neg_some hQ
+    have hprev : n • (Point.some x₀ y₀ h₀ : W.toAffine⟮K⟯) =
+        -(Point.some x' yQ hQ) := by
+      rw [hnegQ]
+      exact hsmul
+    have hsn : n • -(Point.some x₀ y₀ h₀ : W.toAffine⟮K⟯) =
+        -(n • (Point.some x₀ y₀ h₀ : W.toAffine⟮K⟯)) :=
+      neg_nsmul (Point.some x₀ y₀ h₀ : W.toAffine⟮K⟯) n
+    refine ⟨-(Point.some x₀ y₀ h₀), ?_⟩
+    change n • -(Point.some x₀ y₀ h₀ : W.toAffine⟮K⟯) = Point.some x' yQ hQ
+    rw [hsn, hprev, neg_neg]
+
+theorem card_smul_fiber_all [W.IsElliptic] {n : ℕ} (hn : (n : K) ≠ 0)
+    (Q : W.toAffine⟮K⟯) :
+    Nat.card {P : W.toAffine⟮K⟯ // n • P = Q} = Nat.card (nTorsion W (K := K) n) := by
+  obtain ⟨P₀, hP₀⟩ := smul_surjective_all W hn Q
+  have hP₀' : n • P₀ = Q := hP₀
+  have e : nTorsion W (K := K) n ≃ {P : W.toAffine⟮K⟯ // n • P = Q} := by
+    refine Equiv.subtypeEquiv (Equiv.addRight P₀) fun P => ?_
+    change (P ∈ nTorsion W n) ↔ n • (P + P₀) = Q
+    have hsa : n • (P + P₀) = n • P + n • P₀ := nsmul_add P P₀ n
+    rw [hsa, hP₀']
+    constructor
+    · intro h
+      have h' : n • P = 0 := h
+      rw [h', zero_add]
+    · intro h
+      change n • P = 0
+      exact add_right_cancel (h.trans (zero_add Q).symm)
+  exact (Nat.card_congr e).symm
+
+theorem card_nTorsion_two [W.IsElliptic] (h2 : (2 : K) ≠ 0) :
+    Nat.card (nTorsion W (K := K) 2) = 4 := by
+  classical
+  set E := W.baseChange K with hE
+  have ha : E.twoTorsionPolynomial.a ≠ 0 := by
+    change (4 : K) ≠ 0
+    rw [show (4 : K) = 2 * 2 by norm_num]
+    exact mul_ne_zero h2 h2
+  have hd : E.twoTorsionPolynomial.discr ≠ 0 :=
+    E.twoTorsionPolynomial_discr_ne_zero_of_isElliptic (isUnit_iff_ne_zero.mpr h2)
+  have hsplits : (E.twoTorsionPolynomial.toPoly.map (RingHom.id K)).Splits := by
+    rw [Polynomial.map_id]; exact IsAlgClosed.splits _
+  have hmap : Cubic.map (RingHom.id K) E.twoTorsionPolynomial = E.twoTorsionPolynomial := rfl
+  have hcard3 : E.twoTorsionPolynomial.roots.toFinset.card = 3 := by
+    have h := Cubic.card_roots_of_discr_ne_zero ha hsplits hd
+    rwa [hmap] at h
+  have hroot_iff : ∀ x : K, x ∈ E.twoTorsionPolynomial.roots ↔
+      4 * x ^ 3 + E.b₂ * x ^ 2 + 2 * E.b₄ * x + E.b₆ = 0 :=
+    fun x => Cubic.mem_roots_iff (Cubic.ne_zero_of_a_ne_zero ha) x
+  set yy : K → K := fun x => -(E.a₁ * x + E.a₃) / 2 with hyy
+  have hyneg : ∀ x : K, yy x = E.toAffine.negY x (yy x) := by
+    intro x
+    simp only [hyy, negY]
+    field_simp
+    ring
+  have hEq : ∀ x : K, 4 * x ^ 3 + E.b₂ * x ^ 2 + 2 * E.b₄ * x + E.b₆ = 0 →
+      E.toAffine.Equation x (yy x) := by
+    intro x hx
+    rw [equation_iff]
+    simp only [hyy]
+    simp only [b₂, b₄, b₆] at hx
+    field_simp
+    linear_combination -hx
+  have hEval : ∀ x y : K, E.toAffine.Equation x y → y = E.toAffine.negY x y →
+      (4 * x ^ 3 + E.b₂ * x ^ 2 + 2 * E.b₄ * x + E.b₆ = 0 ∧ y = yy x) := by
+    intro x y heq hy
+    rw [equation_iff] at heq
+    simp only [negY] at hy
+    have hy2 : 2 * y + E.a₁ * x + E.a₃ = 0 := by linear_combination hy
+    constructor
+    · simp only [b₂, b₄, b₆]
+      linear_combination (-4 : K) * heq + (2 * y + E.a₁ * x + E.a₃) * hy2
+    · simp only [hyy]
+      field_simp
+      linear_combination hy2
+  have hns : ∀ x ∈ E.twoTorsionPolynomial.roots.toFinset, E.toAffine.Nonsingular x (yy x) :=
+    fun x hx =>
+      equation_iff_nonsingular.mp (hEq x ((hroot_iff x).mp (Multiset.mem_toFinset.mp hx)))
+  set T : Finset (W.toAffine⟮K⟯) :=
+    insert 0 ((E.twoTorsionPolynomial.roots.toFinset.attach).image
+      fun p => Point.some p.1 (yy p.1) (hns p.1 p.2)) with hT
+  have hsetEq : ((nTorsion W (K := K) 2 : AddSubgroup (W.toAffine⟮K⟯)) :
+      Set (W.toAffine⟮K⟯)) = ↑T := by
+    ext P
+    rw [SetLike.mem_coe, Finset.mem_coe, hT, Finset.mem_insert, Finset.mem_image]
+    cases P with
+    | zero =>
+      exact iff_of_true (AddSubgroup.zero_mem _) (Or.inl rfl)
+    | @some x y h =>
+      rw [mem_nTorsion_two_iff]
+      constructor
+      · intro hy
+        obtain ⟨hx0, hyx⟩ := hEval x y h.left hy
+        refine Or.inr ⟨⟨x, Multiset.mem_toFinset.mpr ((hroot_iff x).mpr hx0)⟩,
+          Finset.mem_attach _ _, ?_⟩
+        simp [hyx.symm]
+      · rintro (h0 | ⟨⟨x', hx'⟩, -, hPeq⟩)
+        · exact absurd h0 (Point.some_ne_zero h)
+        · rw [Point.some.injEq] at hPeq
+          obtain ⟨hxx, hyy'⟩ := hPeq
+          subst hxx
+          rw [← hyy']
+          exact hyneg x'
+  have hcount : Nat.card (nTorsion W (K := K) 2) =
+      ((nTorsion W (K := K) 2 : Set (W.toAffine⟮K⟯))).ncard :=
+    Nat.card_coe_set_eq _
+  rw [hcount, hsetEq, Set.ncard_coe_finset]
+  have h0T : (0 : W.toAffine⟮K⟯) ∉
+      (E.twoTorsionPolynomial.roots.toFinset.attach).image
+        (fun p => Point.some p.1 (yy p.1) (hns p.1 p.2)) := by
+    simp only [Finset.mem_image]
+    rintro ⟨p, -, hp⟩
+    exact Point.some_ne_zero _ hp
+  rw [hT, Finset.card_insert_of_notMem h0T, Finset.card_image_of_injOn, Finset.card_attach,
+    hcard3]
+  intro p _ q _ hpq
+  rw [Point.some.injEq] at hpq
+  exact Subtype.ext hpq.left
+
+omit [IsAlgClosed K] in
+theorem card_nTorsion_one : Nat.card (nTorsion W (K := K) 1) = 1 := by
+  have hbot : nTorsion W (K := K) 1 = ⊥ := by
+    ext P
+    rw [AddSubgroup.mem_bot]
+    change 1 • P = 0 ↔ P = 0
+    rw [one_nsmul]
+  rw [hbot]
+  exact AddSubgroup.card_bot
+
+theorem card_nTorsion_prime [W.IsElliptic] {p : ℕ} (hp : p.Prime) (hn : (p : K) ≠ 0) :
+    Nat.card (nTorsion W (K := K) p) = p ^ 2 := by
+  rcases hp.eq_two_or_odd' with rfl | hodd
+  · rw [card_nTorsion_two W (by exact_mod_cast hn)]
+    norm_num
+  · exact card_nTorsion_odd_fibers W hodd hn
+
+theorem card_nTorsion_prime_pow [W.IsElliptic] {p : ℕ} (hp : p.Prime)
+    (hn : (p : K) ≠ 0) (k : ℕ) :
+    Nat.card (nTorsion W (K := K) (p ^ k)) = p ^ (2 * k) := by
+  induction k with
+  | zero => simpa using card_nTorsion_one W (K := K)
+  | succ k ih =>
+    have hpk : ((p ^ k : ℕ) : K) ≠ 0 := by push_cast; exact pow_ne_zero _ hn
+    have hpfin : Finite (nTorsion W (K := K) p) := by
+      refine Nat.finite_of_card_ne_zero ?_
+      rw [card_nTorsion_prime W hp hn]
+      exact pow_ne_zero 2 hp.pos.ne'
+    have := Fintype.ofFinite (nTorsion W (K := K) p)
+    have hfib : ∀ Q : W.toAffine⟮K⟯, Nat.card {P : W.toAffine⟮K⟯ // p ^ k • P = Q} =
+        Nat.card (nTorsion W (K := K) (p ^ k)) := fun Q => card_smul_fiber_all W hpk Q
+    have hfibfin : ∀ Q : nTorsion W (K := K) p,
+        Finite {P : W.toAffine⟮K⟯ // p ^ k • P = (Q : W.toAffine⟮K⟯)} := by
+      intro Q
+      refine Nat.finite_of_card_ne_zero ?_
+      rw [hfib, ih]
+      exact pow_ne_zero _ hp.pos.ne'
+    have e : nTorsion W (K := K) (p ^ (k + 1)) ≃
+        Σ Q : nTorsion W (K := K) p,
+          {P : W.toAffine⟮K⟯ // p ^ k • P = (Q : W.toAffine⟮K⟯)} := by
+      refine ⟨fun P => ⟨⟨p ^ k • (P : W.toAffine⟮K⟯), ?_⟩, ⟨(P : W.toAffine⟮K⟯), rfl⟩⟩,
+        fun x => ⟨x.2.1, ?_⟩, fun P => ?_, fun x => ?_⟩
+      · change p • (p ^ k • (P : W.toAffine⟮K⟯)) = 0
+        rw [smul_smul, ← pow_succ']
+        exact P.2
+      · change p ^ (k + 1) • (x.2.1 : W.toAffine⟮K⟯) = 0
+        rw [pow_succ', ← smul_smul, x.2.2]
+        exact x.1.2
+      · exact Subtype.ext rfl
+      · obtain ⟨⟨Qv, hQ⟩, ⟨P, hP⟩⟩ := x
+        dsimp only at hP
+        subst hP
+        rfl
+    rw [Nat.card_congr e, Nat.card_sigma]
+    have hsum : ∀ Q : nTorsion W (K := K) p,
+        Nat.card {P : W.toAffine⟮K⟯ // p ^ k • P = (Q : W.toAffine⟮K⟯)} = p ^ (2 * k) :=
+      fun Q => (hfib _).trans ih
+    rw [Finset.sum_congr rfl (fun Q _ => hsum Q), Finset.sum_const, smul_eq_mul,
+      Finset.card_univ, ← Nat.card_eq_fintype_card, card_nTorsion_prime W hp hn,
+      ← pow_add]
+    congr 1
+    omega
+
+end AlgClosed
+
+theorem card_nTorsion_mul_of_coprime {m n : ℕ} (hmn : Nat.Coprime m n) :
+    Nat.card (nTorsion W (K := K) (m * n)) =
+      Nat.card (nTorsion W (K := K) m) * Nat.card (nTorsion W (K := K) n) := by
+  set a : ℤ := Nat.gcdA m n with ha
+  set b : ℤ := Nat.gcdB m n with hb
+  have hBez : (m : ℤ) * a + (n : ℤ) * b = 1 := by
+    have h := Nat.gcd_eq_gcd_ab m n
+    rw [hmn.gcd_eq_one] at h
+    exact_mod_cast h.symm
+  have e : nTorsion W (K := K) (m * n) ≃
+      nTorsion W (K := K) m × nTorsion W (K := K) n := by
+    refine ⟨fun P => (⟨((n : ℤ) * b) • (P : W.toAffine⟮K⟯), ?_⟩,
+        ⟨((m : ℤ) * a) • (P : W.toAffine⟮K⟯), ?_⟩),
+      fun x => ⟨(x.1 : W.toAffine⟮K⟯) + (x.2 : W.toAffine⟮K⟯), ?_⟩,
+      fun P => ?_, fun x => ?_⟩
+    · change m • (((n : ℤ) * b) • (P : W.toAffine⟮K⟯)) = 0
+      have hP : ((m : ℤ) * (n : ℤ)) • (P : W.toAffine⟮K⟯) = 0 := by
+        have h := P.2
+        change _ = _
+        rw [show (m : ℤ) * (n : ℤ) = ((m * n : ℕ) : ℤ) by push_cast; ring,
+          natCast_zsmul]
+        exact h
+      rw [← natCast_zsmul, smul_smul,
+        show (m : ℤ) * ((n : ℤ) * b) = b * ((m : ℤ) * (n : ℤ)) by ring,
+        ← smul_smul, hP, smul_zero]
+    · change n • (((m : ℤ) * a) • (P : W.toAffine⟮K⟯)) = 0
+      have hP : ((m : ℤ) * (n : ℤ)) • (P : W.toAffine⟮K⟯) = 0 := by
+        have h := P.2
+        rw [show (m : ℤ) * (n : ℤ) = ((m * n : ℕ) : ℤ) by push_cast; ring,
+          natCast_zsmul]
+        exact h
+      rw [← natCast_zsmul, smul_smul,
+        show (n : ℤ) * ((m : ℤ) * a) = a * ((m : ℤ) * (n : ℤ)) by ring,
+        ← smul_smul, hP, smul_zero]
+    · change (m * n) • ((x.1 : W.toAffine⟮K⟯) + (x.2 : W.toAffine⟮K⟯)) = 0
+      have hx1 : m • (x.1 : W.toAffine⟮K⟯) = 0 := x.1.2
+      have hx2 : n • (x.2 : W.toAffine⟮K⟯) = 0 := x.2.2
+      rw [smul_add]
+      have h1 : (m * n) • (x.1 : W.toAffine⟮K⟯) = 0 := by
+        rw [mul_comm, ← smul_smul, hx1, smul_zero]
+      have h2 : (m * n) • (x.2 : W.toAffine⟮K⟯) = 0 := by
+        rw [← smul_smul, hx2, smul_zero]
+      rw [h1, h2, add_zero]
+    · apply Subtype.ext
+      change ((n : ℤ) * b) • (P : W.toAffine⟮K⟯) + ((m : ℤ) * a) • (P : W.toAffine⟮K⟯) =
+        (P : W.toAffine⟮K⟯)
+      rw [← add_zsmul, show (n : ℤ) * b + (m : ℤ) * a = 1 by linarith [hBez], one_zsmul]
+    · have hm1 : (m : ℤ) • (x.1 : W.toAffine⟮K⟯) = 0 := by
+        rw [natCast_zsmul]; exact x.1.2
+      have hn2 : (n : ℤ) • (x.2 : W.toAffine⟮K⟯) = 0 := by
+        rw [natCast_zsmul]; exact x.2.2
+      refine Prod.ext (Subtype.ext ?_) (Subtype.ext ?_)
+      · change ((n : ℤ) * b) • ((x.1 : W.toAffine⟮K⟯) + (x.2 : W.toAffine⟮K⟯)) =
+          (x.1 : W.toAffine⟮K⟯)
+        rw [smul_add]
+        have e2 : ((n : ℤ) * b) • (x.2 : W.toAffine⟮K⟯) = 0 := by
+          rw [show (n : ℤ) * b = b * (n : ℤ) by ring, ← smul_smul, hn2, smul_zero]
+        have e1 : ((n : ℤ) * b) • (x.1 : W.toAffine⟮K⟯) = (x.1 : W.toAffine⟮K⟯) := by
+          rw [show (n : ℤ) * b = 1 - (m : ℤ) * a by linarith [hBez], sub_smul, one_zsmul,
+            show (m : ℤ) * a = a * (m : ℤ) by ring, ← smul_smul, hm1, smul_zero, sub_zero]
+        rw [e1, e2, add_zero]
+      · change ((m : ℤ) * a) • ((x.1 : W.toAffine⟮K⟯) + (x.2 : W.toAffine⟮K⟯)) =
+          (x.2 : W.toAffine⟮K⟯)
+        rw [smul_add]
+        have e1 : ((m : ℤ) * a) • (x.1 : W.toAffine⟮K⟯) = 0 := by
+          rw [show (m : ℤ) * a = a * (m : ℤ) by ring, ← smul_smul, hm1, smul_zero]
+        have e2 : ((m : ℤ) * a) • (x.2 : W.toAffine⟮K⟯) = (x.2 : W.toAffine⟮K⟯) := by
+          rw [show (m : ℤ) * a = 1 - (n : ℤ) * b by linarith [hBez], sub_smul, one_zsmul,
+            show (n : ℤ) * b = b * (n : ℤ) by ring, ← smul_smul, hn2, smul_zero, sub_zero]
+        rw [e1, e2, zero_add]
+  rw [Nat.card_congr e, Nat.card_prod]
+
+theorem card_nTorsion [IsAlgClosed K] [W.IsElliptic] (n : ℕ) (hn : (n : K) ≠ 0) :
+    Nat.card (nTorsion W (K := K) n) = n ^ 2 := by
+  revert hn
+  induction n using Nat.recOnPosPrimePosCoprime with
+  | prime_pow p k hp hk =>
+    intro hn
+    have hpK : (p : K) ≠ 0 := by
+      intro h0
+      apply hn
+      push_cast
+      rw [h0]
+      exact zero_pow hk.ne'
+    rw [card_nTorsion_prime_pow W hp hpK k, ← pow_mul,
+      Nat.mul_comm]
+  | zero =>
+    intro hn
+    simp at hn
+  | one =>
+    intro _
+    simpa using card_nTorsion_one W (K := K)
+  | coprime a b ha hb hab iha ihb =>
+    intro hn
+    have haK : (a : K) ≠ 0 := by
+      intro h0; apply hn; push_cast; rw [h0, zero_mul]
+    have hbK : (b : K) ≠ 0 := by
+      intro h0; apply hn; push_cast; rw [h0, mul_zero]
+    rw [card_nTorsion_mul_of_coprime W hab, iha haK, ihb hbK, mul_pow]
+
+end
+
+end Deep.Gen
+
+end PortGenCardAll
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+theorem solution {F : Type*} {K : Type*} [Field F] [Field K] [Algebra F K] [IsAlgClosed K]
+    [DecidableEq K] (W : WeierstrassCurve F) [W.IsElliptic] {n : ℕ} (hn : (n : K) ≠ 0) :
+    Nat.card (Submodule.torsionBy ℤ (W⁄K).Point n) = n ^ 2 := by
+  rw [← Deep.Gen.card_nTorsion W (K := K) n hn]
+  refine Nat.card_congr (Equiv.subtypeEquivRight fun P => ?_)
+  change P ∈ Submodule.torsionBy ℤ (W⁄K).Point (n : ℤ) ↔ P ∈ Deep.Gen.nTorsion W (K := K) n
+  rw [Submodule.mem_torsionBy_iff, natCast_zsmul]
+  rfl
+
+end S_WeierstrassCurve_card_torsion_of_isAlgClosed
+end P2MW
+export P2MW.S_WeierstrassCurve_card_torsion_of_isAlgClosed (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+theorem WeierstrassCurve.card_torsion_of_isAlgClosed {F : Type*} {K : Type*} [Field F] [Field K]
+    [Algebra F K] [IsAlgClosed K] [DecidableEq K] (W : WeierstrassCurve F) [W.IsElliptic] {n : ℕ}
+    (hn : (n : K) ≠ 0) :
+    Nat.card (Submodule.torsionBy ℤ (W⁄K).Point n) = n ^ 2 :=
+  solution W hn
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_card_torsion_of_isAlgClosed_light.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_card_torsion_of_isAlgClosed_light.lean
new file mode 100644
index 0000000000..d93269caa0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_card_torsion_of_isAlgClosed_light.lean
@@ -0,0 +1,83 @@
+/-
+Based on Prove2Me node WeierstrassCurve.card_torsion_of_isAlgClosed_light
+(529e87bd-4e4f-544a-9857-1db0b5091352) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d2be07fa-9961-5862-b111-3c1f097a4de8
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_GaloisRep
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsion_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The n-torsion of an elliptic curve has n² points
+
+Theorem statement: `WeierstrassCurve.card_torsion_of_isAlgClosed_light`
+(`529e87bd-4e4f-544a-9857-1db0b5091352`), by Claude, 2026-09-05.
+
+Proof: submission `d2be07fa-9961-5862-b111-3c1f097a4de8`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra, and suppose $K$ is algebraically closed. Let $W$
+be a Weierstrass curve over $F$ which is elliptic (its discriminant is a unit), and let $n$ be a
+natural number whose image in $K$ is nonzero. Write $W⁄K$ for the base change of $W$ along $F \to K$
+and $(W⁄K)$`.Point` for the group of points of the associated affine Weierstrass curve over $K$,
+that is, the points of the curve in the $(x,y)$-plane together with the point at infinity, with the
+usual chord-and-tangent addition. The assertion is that the $\mathbb{Z}$-submodule of elements
+killed by $n$, namely `Submodule.torsionBy ℤ (W⁄K).Point n`, is finite of cardinality exactly $n^2$;
+the equality is stated for `Nat.card`, so it simultaneously records finiteness (a `Nat.card` of $n^2
+\neq 0$ forces finiteness) whenever $n \geq 1$.
+
+This is the classical determination of the order of the $n$-torsion of an elliptic curve over an
+algebraically closed field of residue characteristic not dividing $n$, the cardinality input behind
+the fact that $E[n]$ is free of rank $2$ over $\mathbb{Z}/n$. It is used throughout the project
+where mod-$n$ Galois representations attached to elliptic curves are set up, in particular in the
+construction of patching data for modularity lifting and in the Rubin–Silverberg style
+identification of torsion modules.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_card_torsion_of_isAlgClosed_light.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_card_torsion_of_isAlgClosed_light
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+theorem solution {F : Type*} {K : Type*} [Field F] [Field K] [Algebra F K] [IsAlgClosed K]
+    [DecidableEq K] (W : WeierstrassCurve F) [W.IsElliptic] {n : ℕ} (hn : (n : K) ≠ 0) :
+    Nat.card (Submodule.torsionBy ℤ (W⁄K).Point n) = n ^ 2 :=
+  WeierstrassCurve.card_torsion_of_isAlgClosed W hn
+
+end S_WeierstrassCurve_card_torsion_of_isAlgClosed_light
+end P2MW
+export P2MW.S_WeierstrassCurve_card_torsion_of_isAlgClosed_light (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+theorem WeierstrassCurve.card_torsion_of_isAlgClosed_light {F : Type*} {K : Type*} [Field F]
+    [Field K] [Algebra F K] [IsAlgClosed K] [DecidableEq K] (W : WeierstrassCurve F) [W.IsElliptic]
+    {n : ℕ} (hn : (n : K) ≠ 0) :
+    Nat.card (Submodule.torsionBy ℤ (W⁄K).Point n) = n ^ 2 :=
+  solution W hn
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_eq_zero_of_smul_eq_zero_of_reducePoint_eq_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_eq_zero_of_smul_eq_zero_of_reducePoint_eq_zero.lean
new file mode 100644
index 0000000000..d55b0eca4f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_eq_zero_of_smul_eq_zero_of_reducePoint_eq_zero.lean
@@ -0,0 +1,203 @@
+/-
+Based on Prove2Me node WeierstrassCurve.eq_zero_of_smul_eq_zero_of_reducePoint_eq_zero
+(a540f792-5d03-5254-bd77-f2b0a6c475a3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8da5a49f-1077-5eb5-91d5-15d879c39ed0
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_PointReduction
+
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_smul_some_eq_zero_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_reducePoint_some_eq_zero_iff
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Reduction is injective on n-torsion, n invertible in the residue field
+
+Theorem statement: `WeierstrassCurve.eq_zero_of_smul_eq_zero_of_reducePoint_eq_zero`
+(`a540f792-5d03-5254-bd77-f2b0a6c475a3`), by Claude, 2026-09-05.
+
+Proof: submission `8da5a49f-1077-5eb5-91d5-15d879c39ed0`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a discrete valuation ring (a commutative domain that is an `IsDiscreteValuationRing`)
+with fraction field $K$, and let $W$ be a Weierstrass curve over $K$ carrying the good-reduction
+hypothesis `W.HasGoodReduction R` (which in particular supplies the minimality over $R$ needed to
+form the reduced curve `W.reduction R` over the residue field of $R$). Let $n$ be a natural number
+whose image in `IsLocalRing.ResidueField R` is nonzero, and let $P$ be a point of the affine curve
+`W.toAffine`, i.e. either the point at infinity or a pair $(x,y)$ of elements of $K$ satisfying the
+nonsingular affine equation. Assume $n \cdot P = 0$ in the group of affine points, and that
+[`WeierstrassCurve.reducePoint_alt R W P = 0`](def/EllipticCurve_PointReduction.html#L22), i.e. $P$
+dies under the reduction map which sends the point at infinity to the point at infinity, and sends
+an affine point $(x,y)$ to the point with coordinates $(\overline{x},\overline{y})$ — each
+coordinate being the residue of a chosen $R$-preimage when one exists and $0$ otherwise — provided
+both coordinates have valuation at most $1$ in the normalisation used and the resulting pair is
+nonsingular on `W.reduction R`, and to the point at infinity in every other case. Then $P = 0$.
+
+This is the injectivity of reduction on torsion of order prime to the residue characteristic
+(Silverman, Arithmetic of Elliptic Curves, VII.3.1(b)), here in the form that a point killed by such
+an $n$ and lying in the kernel of reduction is trivial. It is used downstream for the comparison of
+$K$-rational torsion with points of the reduced curve and for the construction of specialisation
+homomorphisms on torsion, and hence in the handling of level structures on modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_eq_zero_of_smul_eq_zero_of_reducePoint_eq_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_eq_zero_of_smul_eq_zero_of_reducePoint_eq_zero
+
+p2m_open "WeierstrassCurve~evalEval_ψ_sq IsDiscreteValuationRing IsLocalRing \
+  IsDedekindDomain.HeightOneSpectrum"
+open Polynomial
+open scoped Polynomial.Bivariate
+
+namespace TorsionInjectivity
+
+variable (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+  {K : Type*} [Field K] [Algebra R K] [IsFractionRing R K]
+
+theorem valuation_eval_of_pole {f : Polynomial K} {x : K}
+    (hc : ∀ i, valuation K (IsDiscreteValuationRing.maximalIdeal R) (f.coeff i) ≤ 1)
+    (hl : valuation K (IsDiscreteValuationRing.maximalIdeal R) f.leadingCoeff = 1)
+    (hx : 1 < valuation K (IsDiscreteValuationRing.maximalIdeal R) x) :
+    valuation K (IsDiscreteValuationRing.maximalIdeal R) (f.eval x)
+      = valuation K (IsDiscreteValuationRing.maximalIdeal R) x ^ f.natDegree := by
+  set v := valuation K (IsDiscreteValuationRing.maximalIdeal R) with hv
+  have hx0 : v x ≠ 0 := (zero_lt_one.trans hx).ne'
+  have hl' : v (f.coeff f.natDegree) = 1 := hl
+  have htop : v (f.coeff f.natDegree * x ^ f.natDegree) = v x ^ f.natDegree := by
+    rw [map_mul, map_pow, hl', one_mul]
+  have hlower : v (∑ i ∈ Finset.range f.natDegree, f.coeff i * x ^ i)
+      < v x ^ f.natDegree := by
+    refine v.map_sum_lt (pow_ne_zero _ hx0) ?_
+    intro i hi
+    rw [Finset.mem_range] at hi
+    rw [map_mul, map_pow]
+    calc v (f.coeff i) * v x ^ i ≤ 1 * v x ^ i := mul_le_mul' (hc i) le_rfl
+      _ = v x ^ i := one_mul _
+      _ < v x ^ f.natDegree := pow_lt_pow_right₀ hx hi
+  rw [Polynomial.eval_eq_sum_range, Finset.sum_range_succ,
+    Valuation.map_add_eq_of_lt_right _ (htop ▸ hlower), htop]
+
+theorem valuation_coeff_ΨSq_le_one (W : WeierstrassCurve K) [W.IsIntegral R] (n : ℤ) (i : ℕ) :
+    valuation K (IsDiscreteValuationRing.maximalIdeal R) ((W.ΨSq n).coeff i) ≤ 1 := by
+  have h : W.ΨSq n = ((integralModel R W).ΨSq n).map (algebraMap R K) := by
+    conv_lhs => rw [← baseChange_integralModel_eq R W]
+    exact map_ΨSq (integralModel R W) (algebraMap R K) n
+  rw [h, Polynomial.coeff_map]
+  exact valuation_le_one (IsDiscreteValuationRing.maximalIdeal R) _
+
+theorem valuation_natCast_eq_one {n : ℕ} (hn : (n : ResidueField R) ≠ 0) :
+    valuation K (IsDiscreteValuationRing.maximalIdeal R) (n : K) = 1 ∧ (n : K) ≠ 0 := by
+  set v := valuation K (IsDiscreteValuationRing.maximalIdeal R) with hv
+  have hmem : (n : R) ∉ IsLocalRing.maximalIdeal R := by
+    intro hmem
+    exact hn (by rw [← map_natCast (residue R) n]; exact (residue_eq_zero_iff _).mpr hmem)
+  have hu : IsUnit (n : R) := by
+    by_contra h
+    exact hmem ((mem_maximalIdeal _).mpr h)
+  obtain ⟨u, hu⟩ := hu
+  have hnK : (n : K) = algebraMap R K (n : R) := by rw [map_natCast]
+  have hprod : v (algebraMap R K (u : R)) * v (algebraMap R K ((u⁻¹ : Rˣ) : R)) = 1 := by
+    rw [← v.map_mul, ← map_mul, Units.mul_inv, map_one, v.map_one]
+  have h1 : v (algebraMap R K (u : R)) = 1 := by
+    refine le_antisymm (valuation_le_one (IsDiscreteValuationRing.maximalIdeal R) _) ?_
+    calc (1 : WithZero (Multiplicative ℤ))
+          = v (algebraMap R K (u : R)) * v (algebraMap R K ((u⁻¹ : Rˣ) : R)) :=
+          hprod.symm
+      _ ≤ v (algebraMap R K (u : R)) * 1 :=
+          mul_le_mul' le_rfl (valuation_le_one (IsDiscreteValuationRing.maximalIdeal R) _)
+      _ = v (algebraMap R K (u : R)) := mul_one _
+  have hveq : v (n : K) = 1 := by rw [hnK, ← hu]; exact h1
+  refine ⟨hveq, fun h0 => ?_⟩
+  rw [h0, v.map_zero] at hveq
+  exact zero_ne_one hveq
+
+theorem evalEval_ψ_sq {F : Type*} [Field F] (W : WeierstrassCurve F) {x y : F}
+    (h : W.toAffine.Equation x y) (n : ℤ) :
+    ((W.ψ n).evalEval x y) ^ 2 = (W.ΨSq n).eval x := by
+  have h0 : W.toAffine.polynomial.eval₂ (evalRingHom x) y = 0 := by
+    rw [eval₂_evalRingHom]; exact h
+  let e : W.toAffine.CoordinateRing →+* F := AdjoinRoot.lift (evalRingHom x) y h0
+  have he : ∀ p : F[X][Y], e (Affine.CoordinateRing.mk W p) = p.evalEval x y := fun p ↦ by
+    change AdjoinRoot.lift (evalRingHom x) y h0 (AdjoinRoot.mk _ p) = _
+    rw [AdjoinRoot.lift_mk, eval₂_evalRingHom]
+  calc ((W.ψ n).evalEval x y) ^ 2
+      = e (Affine.CoordinateRing.mk W (W.ψ n)) ^ 2 := by rw [he]
+    _ = e (Affine.CoordinateRing.mk W (W.ψ n) ^ 2) := (map_pow e _ 2).symm
+    _ = e (Affine.CoordinateRing.mk W (C (W.ΨSq n))) := by
+        rw [Affine.CoordinateRing.mk_ψ, Affine.CoordinateRing.mk_Ψ_sq]
+    _ = (C (W.ΨSq n)).evalEval x y := he _
+    _ = (W.ΨSq n).eval x := evalEval_C x y _
+
+end TorsionInjectivity
+
+open TorsionInjectivity in
+theorem solution
+    (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+    {K : Type*} [Field K] [DecidableEq K] [Algebra R K] [IsFractionRing R K]
+    (W : WeierstrassCurve K) [W.HasGoodReduction R] {n : ℕ}
+    (hn : (n : IsLocalRing.ResidueField R) ≠ 0)
+    (P : W.toAffine.Point) (hP : n • P = 0) (h0 : WeierstrassCurve.reducePoint_alt R W P = 0) :
+    P = 0 := by
+  cases P with
+  | zero => rfl
+  | some x y h =>
+    exfalso
+    have hx : ¬ valuation K (IsDiscreteValuationRing.maximalIdeal R) x ≤ 1 :=
+      (WeierstrassCurve.reducePoint_some_eq_zero_iff R W h).mp h0
+    have hx1 : 1 < valuation K (IsDiscreteValuationRing.maximalIdeal R) x := not_le.mp hx
+    have hz : (n : ℤ) • (Affine.Point.some x y h) = 0 := by
+      rw [natCast_zsmul]; exact hP
+    have hψ : (W.ψ (n : ℤ)).evalEval x y = 0 :=
+      (WeierstrassCurve.Affine.Point.smul_some_eq_zero_iff W h (n : ℤ)).mp hz
+    have hΨSq : (W.ΨSq (n : ℤ)).eval x = 0 := by
+      have h2 := evalEval_ψ_sq W h.1 (n : ℤ)
+      rw [hψ, zero_pow two_ne_zero] at h2
+      exact h2.symm
+    obtain ⟨hvn, hn0⟩ := valuation_natCast_eq_one R (K := K) hn
+    have hnK : ((n : ℤ) : K) ≠ 0 := by push_cast; exact hn0
+    have hl : valuation K (IsDiscreteValuationRing.maximalIdeal R)
+        (W.ΨSq (n : ℤ)).leadingCoeff = 1 := by
+      rw [W.leadingCoeff_ΨSq hnK]
+      push_cast
+      rw [map_pow, hvn, one_pow]
+    have hval := valuation_eval_of_pole R
+      (valuation_coeff_ΨSq_le_one R W (n : ℤ)) hl hx1
+    rw [hΨSq, map_zero] at hval
+    exact pow_ne_zero _ ((zero_lt_one.trans hx1).ne') hval.symm
+
+end S_WeierstrassCurve_eq_zero_of_smul_eq_zero_of_reducePoint_eq_zero
+end P2MW
+export P2MW.S_WeierstrassCurve_eq_zero_of_smul_eq_zero_of_reducePoint_eq_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.eq_zero_of_smul_eq_zero_of_reducePoint_eq_zero
+    (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+    {K : Type*} [Field K] [DecidableEq K] [Algebra R K] [IsFractionRing R K]
+    (W : WeierstrassCurve K) [W.HasGoodReduction R] {n : ℕ}
+    (hn : (n : IsLocalRing.ResidueField R) ≠ 0)
+    (P : W.toAffine.Point) (hP : n • P = 0) (h0 : WeierstrassCurve.reducePoint_alt R W P = 0) :
+    P = 0 :=
+  solution R W hn P hP h0
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_eval_psi2Sq_veluQuotient_veluX_eq_zero_of_eval_psi2Sq_eq_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_eval_psi2Sq_veluQuotient_veluX_eq_zero_of_eval_psi2Sq_eq_zero.lean
new file mode 100644
index 0000000000..cc2cfc72d0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_eval_psi2Sq_veluQuotient_veluX_eq_zero_of_eval_psi2Sq_eq_zero.lean
@@ -0,0 +1,240 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.eval_psi2Sq_veluQuotient_veluX_eq_zero_of_eval_psi2Sq_eq_zero
+(9b7569dc-bf28-5e7c-b79b-07654c7e8121) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d4fd1e19-4603-5bb6-b341-f944cabf59e6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_OddOrderSummingSet
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluQuotientMap
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_velu_map_equation_of_oddOrderSummingSet
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Vélu quotient preserves roots of Ψ₂² for odd cyclic kernels
+
+Theorem statement: `WeierstrassCurve.eval_psi2Sq_veluQuotient_veluX_eq_zero_of_eval_psi2Sq_eq_zero`
+(`9b7569dc-bf28-5e7c-b79b-07654c7e8121`), by Claude, 2026-09-05.
+
+Proof: submission `d4fd1e19-4603-5bb6-b341-f944cabf59e6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be an algebraically closed field in which $2 \neq 0$, and let $W$ be a Weierstrass curve
+over $L$ that is elliptic. Let $n$ be a natural number and let $Q$ be a point of the affine curve
+attached to $W$ whose order in the group of points is exactly $2n+1$. Write $S =
+W.oddOrderSummingSet\ Q\ n$ for the finite subset of $L \times L$ obtained as the image of
+$\{1,\dots,n\}$ under $k \mapsto$ the coordinate pair of $k \cdot Q$ (the point at infinity being
+sent to $(0,0)$). Let $r \in L$ satisfy $\Psi_2^2(r) = 0$, where $W.\Psi_2Sq$ is the square of the
+$2$-division polynomial of $W$. The conclusion is that the corresponding polynomial of the Vélu
+quotient curve $W.veluQuotient\ S$ — the Weierstrass curve with the same $a_1, a_2, a_3$ as $W$,
+with $a_4$ replaced by $a_4 - 5\sum_{A \in S} T(A)$ and $a_6$ by $a_6 - b_2\sum_{A \in S} T(A) -
+7\sum_{A \in S} \mathrm{w}(A)$, where $T(x,y) = 2\,\mathrm{g}^x(x,y) - a_1\,\mathrm{g}^y(x,y)$ —
+vanishes at the Vélu abscissa $$W.veluX\ S\ r = r + \sum_{A \in S}\Bigl(\frac{T(A)}{r - A_1} +
+\frac{\mathrm{g}^y(A)^2}{(r - A_1)^2}\Bigr).$$ No hypothesis separates $r$ from the abscissae $A_1$
+of points of $S$.
+
+This is the statement that the Vélu isogeny with cyclic kernel of odd order $2n+1$ generated by $Q$
+carries abscissae of $2$-torsion points of $W$ to abscissae of $2$-torsion points of the quotient
+curve, in the form of a vanishing statement for the squared $2$-division polynomials. It feeds into
+the proof that the Vélu quotient by an odd-order summing set has nonvanishing discriminant,
+[`WeierstrassCurve.veluQuotient_oddOrderSummingSet_discriminant_ne_zero`]
+(thm.html#WeierstrassCurve.veluQuotient_oddOrderSummingSet_discriminant_ne_zero),
+and rests on the fact that the Vélu formulas send an affine point off the kernel abscissae to a
+point of the quotient curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_eval_psi2Sq_veluQuotient_veluX_eq_zero_of_eval_psi2Sq_eq_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_eval_psi2Sq_veluQuotient_veluX_eq_zero_of_eval_psi2Sq_eq_zero
+
+p2m_open "Polynomial WeierstrassCurve \
+  P2MW.S_WeierstrassCurve_eval_psi2Sq_veluQuotient_veluX_eq_zero_of_eval_psi2Sq_eq_zero.Weierstrass\
+  Curve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point"
+
+noncomputable section
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY a₃ a₁ map b₂ Ψ₂Sq a₄ a₂ a₆ Affine.Point.some \
+  Affine.Point.some.injEq Affine.Point.some.inj toAffine Affine.Point b₆ Affine.equation_iff \
+  Affine.Point.neg_some b₄ veluX veluGx veluGy veluT veluU veluU_eq_Ψ₂Sq_eval \
+  veluGy_eq_zero_of_negY_eq veluQuotient oddOrderSummingSet mem_oddOrderSummingSet veluY \
+  velu_map_equation_of_oddOrderSummingSet"
+p2m_open "WeierstrassCurve"
+
+section Helpers
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F}
+
+omit [DecidableEq F] in
+lemma s18c_exists_some_of_ne_zero {P : W.toAffine.Point} (hP : P ≠ 0) :
+    ∃ (x y : F) (h : W.toAffine.Nonsingular x y), P = Point.some x y h ∧
+      P.coordsOrZero = (x, y) := by
+  rcases P with _ | ⟨x, y, h⟩
+  · exact absurd rfl hP
+  · exact ⟨x, y, h, rfl, rfl⟩
+
+lemma s18c_two_nsmul_eq_zero_iff_Y_eq_negY {x y : F} (h : W.toAffine.Nonsingular x y) :
+    2 • (Point.some x y h : W.toAffine.Point) = 0 ↔ y = W.toAffine.negY x y := by
+  rw [two_nsmul, add_eq_zero_iff_eq_neg, Affine.Point.neg_some]
+  exact ⟨fun hP => (Affine.Point.some.inj hP).right,
+    fun hy => by simp only [Affine.Point.some.injEq]; exact ⟨trivial, hy⟩⟩
+
+lemma s18c_veluGy_ne_zero_of_two_nsmul_ne_zero {x y : F} (h : W.toAffine.Nonsingular x y)
+    (h2 : (2 : ℕ) • (Point.some x y h : W.toAffine.Point) ≠ 0) :
+    W.veluGy x y ≠ 0 := by
+  intro h0
+  apply h2
+  apply (s18c_two_nsmul_eq_zero_iff_Y_eq_negY h).mpr
+  have hkey : W.toAffine.negY x y = y + W.veluGy x y := by
+    simp only [Affine.negY, veluGy]; ring
+  rw [hkey, h0, add_zero]
+
+variable {Q : W.toAffine.Point} {p : ℕ}
+
+theorem s18c_eval_Ψ₂Sq_ne_zero_of_mem_oddOrderSummingSet {n : ℕ}
+    (hord : addOrderOf Q = 2 * n + 1) {P : F × F}
+    (hP : P ∈ W.oddOrderSummingSet Q n) : W.Ψ₂Sq.eval P.1 ≠ 0 := by
+  obtain ⟨k, hk1, hkn, hkP⟩ := W.mem_oddOrderSummingSet.mp hP
+  have hndvd : ¬ (2 * n + 1) ∣ k := Nat.not_dvd_of_pos_of_lt (by omega) (by omega)
+  have hndvd2 : ¬ (2 * n + 1) ∣ 2 * k := Nat.not_dvd_of_pos_of_lt (by omega) (by omega)
+  have hne : k • Q ≠ 0 := fun h => hndvd (hord ▸ (addOrderOf_dvd_iff_nsmul_eq_zero).mpr h)
+  have h2k : (2 * k) • Q ≠ 0 := fun h =>
+    hndvd2 (hord ▸ (addOrderOf_dvd_iff_nsmul_eq_zero).mpr h)
+  obtain ⟨x, y, h, heq, hcoords⟩ := s18c_exists_some_of_ne_zero hne
+  have hPxy : P = (x, y) := by rw [← hkP, hcoords]
+  subst hPxy
+  have h2ns : (2 : ℕ) • (Point.some x y h : W.toAffine.Point) ≠ 0 := by
+    intro h0; apply h2k; rw [mul_nsmul', heq, h0]
+  rw [← W.veluU_eq_Ψ₂Sq_eval h.left]
+  simpa only [veluU] using pow_ne_zero 2 (s18c_veluGy_ne_zero_of_two_nsmul_ne_zero h h2ns)
+
+omit [DecidableEq F] in
+private lemma s18c_veluY_summand_negY (x y : F) (A : F × F) :
+    W.veluU A.1 A.2 * (2 * W.toAffine.negY x y + W.a₁ * x + W.a₃) / (x - A.1) ^ 3
+      + W.veluT A.1 A.2 * (W.a₁ * (x - A.1) + W.toAffine.negY x y - A.2) / (x - A.1) ^ 2
+      + (W.a₁ * W.veluU A.1 A.2 - W.veluGx A.1 A.2 * W.veluGy A.1 A.2) / (x - A.1) ^ 2
+    = W.a₁ * (W.veluT A.1 A.2 / (x - A.1) + W.veluU A.1 A.2 / (x - A.1) ^ 2)
+      - (W.veluU A.1 A.2 * (2 * y + W.a₁ * x + W.a₃) / (x - A.1) ^ 3
+        + W.veluT A.1 A.2 * (W.a₁ * (x - A.1) + y - A.2) / (x - A.1) ^ 2
+        + (W.a₁ * W.veluU A.1 A.2 - W.veluGx A.1 A.2 * W.veluGy A.1 A.2) / (x - A.1) ^ 2) := by
+  rcases eq_or_ne x A.1 with h | h
+  · simp [h, sub_self]
+  · have hd : x - A.1 ≠ 0 := sub_ne_zero.mpr h
+    simp only [veluT, veluU, veluGx, veluGy, Affine.negY]
+    field_simp
+    ring
+
+omit [DecidableEq F] in
+lemma s18c_veluY_negY (S : Finset (F × F)) (x y : F) :
+    W.veluY S x (W.toAffine.negY x y)
+      = (W.veluQuotient S).toAffine.negY (W.veluX S x) (W.veluY S x y) := by
+  simp only [veluY, veluX]
+  rw [Finset.sum_congr rfl fun A _ => s18c_veluY_summand_negY (W := W) x y A,
+    Finset.sum_sub_distrib, ← Finset.mul_sum]
+  simp only [Affine.negY, veluQuotient]
+  ring
+
+omit [DecidableEq F] in
+theorem s18c_veluQuotient_eval_Ψ₂Sq_veluX_eq_zero_of_mapeq {S : Finset (F × F)} {r s : F}
+    (hy : s = W.toAffine.negY r s)
+    (hmapeq : (W.veluQuotient S).toAffine.Equation (W.veluX S r) (W.veluY S r s)) :
+    (W.veluQuotient S).Ψ₂Sq.eval (W.veluX S r) = 0 := by
+  have hneg' : W.veluY S r s
+      = (W.veluQuotient S).toAffine.negY (W.veluX S r) (W.veluY S r s) := by
+    nth_rewrite 1 [hy]
+    exact s18c_veluY_negY S r s
+  have hgy' : (W.veluQuotient S).veluGy (W.veluX S r) (W.veluY S r s) = 0 :=
+    (W.veluQuotient S).veluGy_eq_zero_of_negY_eq hneg'.symm
+  rw [← (W.veluQuotient S).veluU_eq_Ψ₂Sq_eval hmapeq]
+  simp [veluU, hgy']
+
+variable (W) in
+private def _root_.WeierstrassCurve.s18c_twoTorsionY (x : F) : F := -(W.a₁ * x + W.a₃) / 2
+
+p2m_export "WeierstrassCurve" "s18c_twoTorsionY"
+omit [DecidableEq F] in
+lemma s18c_twoTorsionY_eq_negY (h2 : (2 : F) ≠ 0) (x : F) :
+    W.s18c_twoTorsionY x = W.toAffine.negY x (W.s18c_twoTorsionY x) := by
+  rw [s18c_twoTorsionY, Affine.negY]
+  field_simp
+  ring
+
+omit [DecidableEq F] in
+lemma s18c_equation_twoTorsionY_of_eval (h2 : (2 : F) ≠ 0) {x : F}
+    (h : W.Ψ₂Sq.eval x = 0) : W.toAffine.Equation x (W.s18c_twoTorsionY x) := by
+  have h4 : (4 : F) ≠ 0 := by
+    have : (4 : F) = (2 : F) ^ 2 := by norm_num
+    rw [this]; exact pow_ne_zero 2 h2
+  have key : (4 : F) * (W.s18c_twoTorsionY x ^ 2 + W.a₁ * x * W.s18c_twoTorsionY x +
+      W.a₃ * W.s18c_twoTorsionY x - (x ^ 3 + W.a₂ * x ^ 2 + W.a₄ * x + W.a₆)) =
+      -(W.Ψ₂Sq.eval x) := by
+    rw [s18c_twoTorsionY, Ψ₂Sq, b₂, b₄, b₆]
+    simp only [eval_add, eval_mul, eval_pow, eval_C, eval_X]
+    field_simp
+    ring
+  rw [Affine.equation_iff]
+  have h0 : (4 : F) * (W.s18c_twoTorsionY x ^ 2 + W.a₁ * x * W.s18c_twoTorsionY x +
+      W.a₃ * W.s18c_twoTorsionY x - (x ^ 3 + W.a₂ * x ^ 2 + W.a₄ * x + W.a₆)) = 0 := by
+    rw [key, h, _root_.neg_zero]
+  have := (mul_eq_zero.mp h0).resolve_left h4
+  linear_combination this
+
+end Helpers
+
+end WeierstrassCurve
+
+end
+
+theorem solution
+    {L : Type*} [Field L] [DecidableEq L] [IsAlgClosed L] (h2 : (2 : L) ≠ 0)
+    (W : WeierstrassCurve L) [W.IsElliptic] (n : ℕ) (Q : W.toAffine.Point)
+    (hQ : addOrderOf Q = 2 * n + 1) {r : L} (hr : W.Ψ₂Sq.eval r = 0) :
+    (W.veluQuotient (W.oddOrderSummingSet Q n)).Ψ₂Sq.eval
+      (W.veluX (W.oddOrderSummingSet Q n) r) = 0 := by
+  set S := W.oddOrderSummingSet Q n with hS
+  have heqt : W.toAffine.Equation r (W.s18c_twoTorsionY r) :=
+    WeierstrassCurve.s18c_equation_twoTorsionY_of_eval h2 hr
+  have hav : ∀ A ∈ S, r ≠ A.1 := fun A hA hc =>
+    WeierstrassCurve.s18c_eval_Ψ₂Sq_ne_zero_of_mem_oddOrderSummingSet (W := W) hQ hA (hc ▸ hr)
+  have hmapeq := W.velu_map_equation_of_oddOrderSummingSet h2 n Q hQ heqt hav
+  exact WeierstrassCurve.s18c_veluQuotient_eval_Ψ₂Sq_veluX_eq_zero_of_mapeq
+    (WeierstrassCurve.s18c_twoTorsionY_eq_negY h2 r) hmapeq
+
+end S_WeierstrassCurve_eval_psi2Sq_veluQuotient_veluX_eq_zero_of_eval_psi2Sq_eq_zero
+end P2MW
+export P2MW.S_WeierstrassCurve_eval_psi2Sq_veluQuotient_veluX_eq_zero_of_eval_psi2Sq_eq_zero
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve
+theorem WeierstrassCurve.eval_psi2Sq_veluQuotient_veluX_eq_zero_of_eval_psi2Sq_eq_zero
+    {L : Type*} [Field L] [DecidableEq L] [IsAlgClosed L] (h2 : (2 : L) ≠ 0)
+    (W : WeierstrassCurve L) [W.IsElliptic] (n : ℕ) (Q : W.toAffine.Point)
+    (hQ : addOrderOf Q = 2 * n + 1) {r : L} (hr : W.Ψ₂Sq.eval r = 0) :
+    (W.veluQuotient (W.oddOrderSummingSet Q n)).Ψ₂Sq.eval
+      (W.veluX (W.oddOrderSummingSet Q n) r) = 0 :=
+  solution h2 W n Q hQ hr
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_addEquiv_point_baseChange_variableChange_smul_algEquiv.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_addEquiv_point_baseChange_variableChange_smul_algEquiv.lean
new file mode 100644
index 0000000000..9f1e5c2254
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_addEquiv_point_baseChange_variableChange_smul_algEquiv.lean
@@ -0,0 +1,79 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.exists_addEquiv_point_baseChange_variableChange_smul_algEquiv
+(64076d31-9622-5011-95f6-dfae78c88a10) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9f980d52-af45-58dd-8b36-299c979bed84
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_GaloisRep
+public import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_addEquiv_point_of_variableChange_eq
+
+/-!
+# Galois-equivariant isomorphism of points under a variable change
+
+Theorem statement: `WeierstrassCurve.exists_addEquiv_point_baseChange_variableChange_smul_algEquiv`
+(`64076d31-9622-5011-95f6-dfae78c88a10`), by Claude, 2026-09-05.
+
+Proof: submission `9f980d52-af45-58dd-8b36-299c979bed84`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra, let $W$ be a Weierstrass curve over $F$, and let
+$\gamma$ be an admissible change of variables over $F$ (an element of
+`WeierstrassCurve.VariableChange F`, given by data $(u,r,s,t)$ with $u$ a unit). The assertion is
+that there exists an isomorphism of additive groups
+$$\varphi \colon \bigl((\gamma \cdot W)_{K}\bigr)(K) \xrightarrow{\ \sim\ } (W_{K})(K)$$
+between the point groups of the associated affine curves of the base changes to $K$ of the
+transformed curve $\gamma \cdot W$ and of $W$ — that is, between the sets of nonsingular affine
+$K$-points together with the point at infinity, each with its usual chord-and-tangent group law —
+such that $\varphi$ is equivariant for the action of the $F$-algebra automorphisms of $K$: for every
+$\sigma \in K \simeq_{\mathrm{alg}[F]} K$ and every point $P$ of $((\gamma \cdot W)_{K})(K)$ one has
+$\varphi(\sigma \cdot P) = \sigma \cdot \varphi(P)$. Only existence of such a $\varphi$ is claimed;
+no formula for it is part of the statement.
+
+This is the standard fact that an admissible change of variables defined over the base field induces
+an isomorphism of the groups of $K$-points commuting with the action of $\mathrm{Aut}(K/F)$, so that
+all Galois-module invariants of $E(K)$ are insensitive to replacing a Weierstrass model by a
+transformed one. It is used when passing between a curve and an integral model of it, in the
+comparison of torsion modules over an algebraic closure of $\mathbb{Q}_p$ and in the identification
+of Frobenius traces with the $a_p$ of a chosen model.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_exists_addEquiv_point_baseChange_variableChange_smul_algEquiv.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+theorem solution {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K]
+    (W : WeierstrassCurve F) (γ : WeierstrassCurve.VariableChange F) :
+    ∃ φ : ((γ • W).baseChange K).toAffine.Point ≃+ (W.baseChange K).toAffine.Point,
+      ∀ (σ : K ≃ₐ[F] K) (P : ((γ • W).baseChange K).toAffine.Point), φ (σ • P) = σ • φ P :=
+  WeierstrassCurve.exists_addEquiv_point_of_variableChange_eq K γ⁻¹ (inv_smul_smul γ W)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.exists_addEquiv_point_baseChange_variableChange_smul_algEquiv {F K : Type*}
+    [Field F] [Field K] [Algebra F K] [DecidableEq K] (W : WeierstrassCurve F)
+    (γ : WeierstrassCurve.VariableChange F) :
+    ∃ φ : ((γ • W).baseChange K).toAffine.Point ≃+ (W.baseChange K).toAffine.Point,
+      ∀ (σ : K ≃ₐ[F] K) (P : ((γ • W).baseChange K).toAffine.Point), φ (σ • P) = σ • φ P :=
+  solution W γ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_addEquiv_point_of_variableChange_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_addEquiv_point_of_variableChange_eq.lean
new file mode 100644
index 0000000000..a4914bc455
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_addEquiv_point_of_variableChange_eq.lean
@@ -0,0 +1,365 @@
+/-
+Based on Prove2Me node WeierstrassCurve.exists_addEquiv_point_of_variableChange_eq
+(8567cd04-3bb6-55c2-bf7b-3b75b310d878) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 235eb75d-5e81-5f94-926a-8a8a3fab3824
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_GaloisRep
+public import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Variable change over F gives Galois-equivariant isomorphism of K-points
+
+Theorem statement: `WeierstrassCurve.exists_addEquiv_point_of_variableChange_eq`
+(`8567cd04-3bb6-55c2-bf7b-3b75b310d878`), by Claude, 2026-09-05.
+
+Proof: submission `235eb75d-5e81-5f94-926a-8a8a3fab3824`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field, let $K$ be a field equipped with an $F$-algebra structure, and let $E, E'$ be
+Weierstrass curves over $F$. Let $C$ be a variable change over $F$, that is a tuple $(u, r, s, t)$
+with $u \in F^\times$ and $r, s, t \in F$ acting on Weierstrass equations in the usual way, and
+assume that the result $C \bullet E$ of acting by $C$ on $E$ equals $E'$. The assertion is that
+there exists an isomorphism of additive groups $e$ from the group of affine points (including the
+point at infinity) of the curve $E$ base changed to $K$ to the corresponding group for $E'$, such
+that $e(\sigma \bullet P) = \sigma \bullet e(P)$ for every $F$-algebra automorphism $\sigma$ of $K$
+and every $K$-point $P$ of $E$, where $\bullet$ denotes the action of $K \simeq_{\mathrm{alg}[F]} K$
+on groups of $K$-points fixed by the project's Galois-representation definitions. The existence
+statement gives no formula for $e$.
+
+This is the standard fact that $F$-isomorphic Weierstrass models have isomorphic groups of
+$K$-points, compatibly with the action of $\mathrm{Aut}(K/F)$, since the coordinate change has
+coefficients in the base field. It is the transport mechanism used to move Galois-module data
+between models of a curve, and is cited by
+[`WeierstrassCurve.exists_addEquiv_point_baseChange_variableChange_smul_algEquiv`]
+(thm.html#WeierstrassCurve.exists_addEquiv_point_baseChange_variableChange_smul_algEquiv)
+and by
+[`WeierstrassCurve.exists_linearEquiv_torsionBy_of_variableChange_eq`]
+(thm.html#WeierstrassCurve.exists_linearEquiv_torsionBy_of_variableChange_eq),
+the latter transferring the $n$-torsion as a Galois module.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_exists_addEquiv_point_of_variableChange_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_WeierstrassCurve_exists_addEquiv_point_of_variableChange_eq
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_WeierstrassCurve_exists_addEquiv_point_of_variableChange_eq.WeierstrassCurve \
+  WeierstrassCurve.Affine WeierstrassCurve.Affine.Point"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.Equation Affine.negY Affine.evalEval_polynomial \
+  Affine.Y_eq_of_Y_ne Affine.slope_of_X_ne VariableChange.map Affine.Point.add_of_Y_eq map \
+  variableChange_a₃ Affine.evalEval_polynomialX Affine.Point.some Affine.Point.some.injEq \
+  Affine.Nonsingular variableChange_a₆ VariableChange.baseChange Affine.negAddY \
+  Affine.slope_of_Y_ne_eq_evalEval variableChange_a₂ toAffine Affine.Point \
+  Affine.evalEval_polynomialY Affine.addX Affine.Point.add_some variableChange_a₁ \
+  variableChange_a₄ VariableChange Affine.addY Affine.Point.map_some map_variableChange baseChange"
+p2m_open "WeierstrassCurve"
+
+namespace VariableChange
+p2m_export "WeierstrassCurve.VariableChange" "map u baseChange t s r"
+p2m_open "WeierstrassCurve.VariableChange"
+
+section Ring
+
+variable {R : Type*} [CommRing R] (C : VariableChange R) (W : WeierstrassCurve R)
+
+private def _root_.WeierstrassCurve.VariableChange.ptX (x : R) : R := (↑C.u⁻¹ : R) ^ 2 * (x - C.r)
+
+p2m_export "WeierstrassCurve.VariableChange" "ptX"
+
+private def _root_.WeierstrassCurve.VariableChange.ptY (x y : R) :
+    R := (↑C.u⁻¹ : R) ^ 3 * (y - C.s * x + (C.s * C.r - C.t))
+
+p2m_export "WeierstrassCurve.VariableChange" "ptY"
+
+private def _root_.WeierstrassCurve.VariableChange.invX (X : R) : R := (C.u : R) ^ 2 * X + C.r
+
+p2m_export "WeierstrassCurve.VariableChange" "invX"
+
+private def _root_.WeierstrassCurve.VariableChange.invY (X Y : R) :
+    R := (C.u : R) ^ 3 * Y + (C.u : R) ^ 2 * C.s * X + C.t
+
+p2m_export "WeierstrassCurve.VariableChange" "invY"
+lemma invX_ptX (x : R) : C.invX (C.ptX x) = x := by
+  simp only [invX, ptX]
+  linear_combination (x - C.r) * pow_mul_pow_eq_one 2 C.u.mul_inv
+
+lemma invY_ptY (x y : R) : C.invY (C.ptX x) (C.ptY x y) = y := by
+  simp only [invY, ptX, ptY]
+  linear_combination (y - C.s * x + (C.s * C.r - C.t)) * pow_mul_pow_eq_one 3 C.u.mul_inv
+    + C.s * (x - C.r) * pow_mul_pow_eq_one 2 C.u.mul_inv
+
+lemma ptX_invX (X : R) : C.ptX (C.invX X) = X := by
+  simp only [invX, ptX]
+  linear_combination X * pow_mul_pow_eq_one 2 C.u.inv_mul
+
+lemma ptY_invY (X Y : R) : C.ptY (C.invX X) (C.invY X Y) = Y := by
+  simp only [invX, invY, ptY]
+  linear_combination Y * pow_mul_pow_eq_one 3 C.u.inv_mul
+
+private lemma _root_.WeierstrassCurve.VariableChange.ptX_injective :
+    Function.Injective C.ptX := fun x₁ x₂ h => by
+  simpa only [invX_ptX] using congr_arg C.invX h
+
+p2m_export "WeierstrassCurve.VariableChange" "ptX_injective"
+private lemma _root_.WeierstrassCurve.VariableChange.ptY_injective (x : R) :
+    Function.Injective (C.ptY x) := fun y₁ y₂ h => by
+  simpa only [invY_ptY] using congr_arg (C.invY (C.ptX x)) h
+
+p2m_export "WeierstrassCurve.VariableChange" "ptY_injective"
+lemma negY_pt (x y : R) :
+    (C • W).toAffine.negY (C.ptX x) (C.ptY x y) = C.ptY x (W.toAffine.negY x y) := by
+  simp only [Affine.negY, ptX, ptY, variableChange_a₁, variableChange_a₃]
+  ring
+
+lemma addX_pt (x₁ x₂ ℓ : R) :
+    (C • W).toAffine.addX (C.ptX x₁) (C.ptX x₂) (↑C.u⁻¹ * (ℓ - C.s)) =
+      C.ptX (W.toAffine.addX x₁ x₂ ℓ) := by
+  simp only [Affine.addX, ptX, variableChange_a₁, variableChange_a₂]
+  ring
+
+lemma addY_pt (x₁ x₂ y₁ ℓ : R) :
+    (C • W).toAffine.addY (C.ptX x₁) (C.ptX x₂) (C.ptY x₁ y₁) (↑C.u⁻¹ * (ℓ - C.s)) =
+      C.ptY (W.toAffine.addX x₁ x₂ ℓ) (W.toAffine.addY x₁ x₂ y₁ ℓ) := by
+  simp only [Affine.addY, Affine.negAddY, Affine.addX, Affine.negY, ptX, ptY, variableChange_a₁,
+    variableChange_a₂, variableChange_a₃]
+  ring
+
+lemma evalEval_polynomial_pt (x y : R) :
+    (C • W).toAffine.polynomial.evalEval (C.ptX x) (C.ptY x y) =
+      ↑C.u⁻¹ ^ 6 * W.toAffine.polynomial.evalEval x y := by
+  rw [Affine.evalEval_polynomial, Affine.evalEval_polynomial]
+  simp only [ptX, ptY, variableChange_a₁, variableChange_a₂, variableChange_a₃, variableChange_a₄,
+    variableChange_a₆]
+  ring
+
+lemma evalEval_polynomialX_pt (x y : R) :
+    (C • W).toAffine.polynomialX.evalEval (C.ptX x) (C.ptY x y) =
+      ↑C.u⁻¹ ^ 4 * (W.toAffine.polynomialX.evalEval x y
+        + C.s * W.toAffine.polynomialY.evalEval x y) := by
+  rw [Affine.evalEval_polynomialX, Affine.evalEval_polynomialX, Affine.evalEval_polynomialY]
+  simp only [ptX, ptY, variableChange_a₁, variableChange_a₂, variableChange_a₄]
+  ring
+
+lemma evalEval_polynomialY_pt (x y : R) :
+    (C • W).toAffine.polynomialY.evalEval (C.ptX x) (C.ptY x y) =
+      ↑C.u⁻¹ ^ 3 * W.toAffine.polynomialY.evalEval x y := by
+  rw [Affine.evalEval_polynomialY, Affine.evalEval_polynomialY]
+  simp only [ptX, ptY, variableChange_a₁, variableChange_a₃]
+  ring
+
+lemma equation_pt_iff (x y : R) :
+    (C • W).toAffine.Equation (C.ptX x) (C.ptY x y) ↔ W.toAffine.Equation x y := by
+  rw [Affine.Equation, Affine.Equation, evalEval_polynomial_pt,
+    (C.u⁻¹.isUnit.pow 6).mul_right_eq_zero]
+
+lemma nonsingular_pt_iff (x y : R) :
+    (C • W).toAffine.Nonsingular (C.ptX x) (C.ptY x y) ↔ W.toAffine.Nonsingular x y := by
+  rw [Affine.Nonsingular, Affine.Nonsingular, equation_pt_iff, evalEval_polynomialX_pt,
+    evalEval_polynomialY_pt]
+  simp only [ne_eq, (C.u⁻¹.isUnit.pow 4).mul_right_eq_zero, (C.u⁻¹.isUnit.pow 3).mul_right_eq_zero]
+  refine and_congr_right fun _ => ?_
+  by_cases hY : W.toAffine.polynomialY.evalEval x y = 0
+  · simp only [hY, mul_zero, add_zero, not_true_eq_false, or_false]
+  · simp only [hY, not_false_eq_true, or_true]
+
+lemma nonsingular_inv_iff (X Y : R) :
+    W.toAffine.Nonsingular (C.invX X) (C.invY X Y) ↔ (C • W).toAffine.Nonsingular X Y := by
+  rw [← nonsingular_pt_iff C W, ptX_invX, ptY_invY]
+
+end Ring
+
+section Field
+
+variable {K : Type*} [Field K] [DecidableEq K] (C : VariableChange K) (W : WeierstrassCurve K)
+
+lemma slope_pt {x₁ x₂ y₁ y₂ : K} (h₁ : W.toAffine.Equation x₁ y₁) (h₂ : W.toAffine.Equation x₂ y₂)
+    (hxy : ¬(x₁ = x₂ ∧ y₁ = W.toAffine.negY x₂ y₂)) :
+    (C • W).toAffine.slope (C.ptX x₁) (C.ptX x₂) (C.ptY x₁ y₁) (C.ptY x₂ y₂) =
+      ↑C.u⁻¹ * (W.toAffine.slope x₁ x₂ y₁ y₂ - C.s) := by
+  have hu : (↑C.u⁻¹ : K) ≠ 0 := C.u⁻¹.ne_zero
+  have hu' : (↑C.u : K) ≠ 0 := C.u.ne_zero
+  by_cases hx : x₁ = x₂
+  · have hy : y₁ ≠ W.toAffine.negY x₂ y₂ := fun h => hxy ⟨hx, h⟩
+    obtain rfl : y₁ = y₂ := Affine.Y_eq_of_Y_ne h₁ h₂ hx hy
+    subst hx
+    have hy' : C.ptY x₁ y₁ ≠ (C • W).toAffine.negY (C.ptX x₁) (C.ptY x₁ y₁) := by
+      rw [negY_pt]
+      exact fun h => hy (C.ptY_injective x₁ h)
+    have hB : W.toAffine.polynomialY.evalEval x₁ y₁ ≠ 0 := by
+      rw [Affine.evalEval_polynomialY]
+      intro h
+      apply hy
+      simp only [Affine.negY]
+      linear_combination h
+    rw [Affine.slope_of_Y_ne_eq_evalEval rfl hy', Affine.slope_of_Y_ne_eq_evalEval rfl hy,
+      evalEval_polynomialX_pt, evalEval_polynomialY_pt]
+    field_simp
+    ring
+  · have hx' : C.ptX x₁ ≠ C.ptX x₂ := fun h => hx (C.ptX_injective h)
+    rw [Affine.slope_of_X_ne hx', Affine.slope_of_X_ne hx]
+    have hd : x₁ - x₂ ≠ 0 := sub_ne_zero.mpr hx
+    have hden : C.ptX x₁ - C.ptX x₂ = ↑C.u⁻¹ ^ 2 * (x₁ - x₂) := by simp only [ptX]; ring
+    have hnum : C.ptY x₁ y₁ - C.ptY x₂ y₂ = ↑C.u⁻¹ ^ 3 * ((y₁ - y₂) - C.s * (x₁ - x₂)) := by
+      simp only [ptY]; ring
+    rw [hden, hnum]
+    field_simp
+
+end Field
+
+end VariableChange
+
+section PointEquiv
+
+variable {F : Type*} {K : Type*} [Field F] [Field K] [Algebra F K]
+  (E : WeierstrassCurve F) (C : VariableChange F)
+
+lemma baseChange_variableChange_smul : (C.baseChange K) • (E⁄K) = (C • E)⁄K :=
+  map_variableChange E C (algebraMap F K)
+
+namespace VariableChange
+p2m_export "WeierstrassCurve.VariableChange" "map u baseChange t s r"
+p2m_open "WeierstrassCurve.VariableChange"
+
+@[scoped simp] lemma coe_baseChange_u_inv :
+    (↑(C.baseChange K).u⁻¹ : K) = algebraMap F K ↑C.u⁻¹ := by
+  simp [VariableChange.baseChange, VariableChange.map]
+
+@[scoped simp] lemma baseChange_r : (C.baseChange K).r = algebraMap F K C.r := rfl
+@[scoped simp] lemma baseChange_s : (C.baseChange K).s = algebraMap F K C.s := rfl
+@[scoped simp] lemma baseChange_t : (C.baseChange K).t = algebraMap F K C.t := rfl
+
+lemma bc_nonsingular_iff (X Y : K) :
+    ((C.baseChange K) • (E⁄K)).toAffine.Nonsingular X Y ↔ ((C • E)⁄K).Nonsingular X Y := by
+  rw [baseChange_variableChange_smul]
+
+lemma bc_negY (x y : K) :
+    ((C • E)⁄K).negY ((C.baseChange K).ptX x) ((C.baseChange K).ptY x y) =
+      (C.baseChange K).ptY x ((E⁄K).negY x y) := by
+  rw [← baseChange_variableChange_smul]; exact negY_pt (C.baseChange K) (E⁄K) x y
+
+lemma bc_addX (x₁ x₂ ℓ : K) :
+    ((C • E)⁄K).addX ((C.baseChange K).ptX x₁) ((C.baseChange K).ptX x₂) (↑(C.baseChange K).u⁻¹
+      * (ℓ - (C.baseChange K).s)) =
+      (C.baseChange K).ptX ((E⁄K).addX x₁ x₂ ℓ) := by
+  rw [← baseChange_variableChange_smul]; exact addX_pt (C.baseChange K) (E⁄K) x₁ x₂ ℓ
+
+lemma bc_addY (x₁ x₂ y₁ ℓ : K) :
+    ((C • E)⁄K).addY ((C.baseChange K).ptX x₁) ((C.baseChange K).ptX x₂)
+      ((C.baseChange K).ptY x₁ y₁) (↑(C.baseChange K).u⁻¹ * (ℓ - (C.baseChange K).s)) =
+      (C.baseChange K).ptY ((E⁄K).addX x₁ x₂ ℓ) ((E⁄K).addY x₁ x₂ y₁ ℓ) := by
+  rw [← baseChange_variableChange_smul]; exact addY_pt (C.baseChange K) (E⁄K) x₁ x₂ y₁ ℓ
+
+lemma bc_slope [DecidableEq K] {x₁ x₂ y₁ y₂ : K} (h₁ : (E⁄K).Equation x₁ y₁)
+    (h₂ : (E⁄K).Equation x₂ y₂)
+    (hxy : ¬(x₁ = x₂ ∧ y₁ = (E⁄K).negY x₂ y₂)) :
+    ((C • E)⁄K).slope ((C.baseChange K).ptX x₁) ((C.baseChange K).ptX x₂)
+        ((C.baseChange K).ptY x₁ y₁) ((C.baseChange K).ptY x₂ y₂) =
+      ↑(C.baseChange K).u⁻¹ * ((E⁄K).slope x₁ x₂ y₁ y₂ - (C.baseChange K).s) := by
+  rw [← baseChange_variableChange_smul]; exact slope_pt (C.baseChange K) (E⁄K) h₁ h₂ hxy
+
+noncomputable def pointFun : (E⁄K).Point → ((C • E)⁄K).Point
+  | 0 => 0
+  | .some x y h => .some ((C.baseChange K).ptX x) ((C.baseChange K).ptY x y) <|
+      (bc_nonsingular_iff E C _ _).mp <| (nonsingular_pt_iff (C.baseChange K) (E⁄K) x y).mpr h
+
+noncomputable def pointInv : ((C • E)⁄K).Point → (E⁄K).Point
+  | 0 => 0
+  | .some X Y h => .some ((C.baseChange K).invX X) ((C.baseChange K).invY X Y) <|
+      (nonsingular_inv_iff (C.baseChange K) (E⁄K) X Y).mpr <| (bc_nonsingular_iff E C _ _).mpr h
+
+variable [DecidableEq K]
+
+noncomputable def pointEquiv : (E⁄K).Point ≃+ ((C • E)⁄K).Point where
+  toFun := pointFun E C
+  invFun := pointInv E C
+  left_inv := by
+    rintro (_ | ⟨x, y, h⟩)
+    · rfl
+    · simp only [pointFun, pointInv, invX_ptX, invY_ptY]
+  right_inv := by
+    rintro (_ | ⟨X, Y, h⟩)
+    · rfl
+    · simp only [pointFun, pointInv, ptX_invX, ptY_invY]
+  map_add' := by
+    rintro (_ | ⟨x₁, y₁, h₁⟩) (_ | ⟨x₂, y₂, h₂⟩)
+    · rfl
+    · rfl
+    · rfl
+    · by_cases hxy : x₁ = x₂ ∧ y₁ = (E⁄K).negY x₂ y₂
+      · rcases hxy with ⟨rfl, rfl⟩
+        rw [Affine.Point.add_of_Y_eq rfl rfl]
+        simp only [pointFun]
+        exact (Affine.Point.add_of_Y_eq rfl (bc_negY E C x₁ y₂).symm).symm
+      · have hxy' : ¬((C.baseChange K).ptX x₁ = (C.baseChange K).ptX x₂ ∧
+          (C.baseChange K).ptY x₁ y₁ =
+            ((C • E)⁄K).negY ((C.baseChange K).ptX x₂) ((C.baseChange K).ptY x₂ y₂)) := by
+          rintro ⟨hx, hy⟩
+          obtain rfl := (C.baseChange K).ptX_injective hx
+          rw [bc_negY] at hy
+          exact hxy ⟨rfl, (C.baseChange K).ptY_injective x₁ hy⟩
+        rw [Affine.Point.add_some hxy]
+        simp only [pointFun]
+        rw [Affine.Point.add_some hxy', Affine.Point.some.injEq,
+          bc_slope E C h₁.1 h₂.1 hxy, bc_addX, bc_addY]
+        exact ⟨rfl, rfl⟩
+
+@[scoped simp] lemma pointEquiv_zero : pointEquiv E C (0 : (E⁄K).Point) = 0 := rfl
+
+@[scoped simp] lemma pointEquiv_some {x y : K} (h : (E⁄K).Nonsingular x y) :
+    pointEquiv E C (.some x y h) = .some ((C.baseChange K).ptX x) ((C.baseChange K).ptY x y)
+      ((bc_nonsingular_iff E C _ _).mp <| (nonsingular_pt_iff (C.baseChange K) (E⁄K) x y).mpr h) :=
+    rfl
+
+lemma pointEquiv_smul (σ : K ≃ₐ[F] K) (P : (E⁄K).Point) :
+    pointEquiv E C (σ • P) = σ • pointEquiv E C P := by
+  rcases P with (_ | ⟨x, y, h⟩)
+  · rfl
+  · simp only [algEquiv_smul_def, Affine.Point.map_some, pointEquiv_some, ptX, ptY,
+      coe_baseChange_u_inv, baseChange_r, baseChange_s, baseChange_t, map_mul, map_sub, map_add,
+      map_pow, AlgHom.commutes]
+
+end VariableChange
+end PointEquiv
+end WeierstrassCurve
+
+theorem solution {F : Type*} [Field F] (K : Type*) [Field K] [Algebra F K] [DecidableEq K]
+    {E E' : WeierstrassCurve F} (C : VariableChange F) (hC : C • E = E') :
+    ∃ e : (E⁄K).Point ≃+ (E'⁄K).Point,
+      ∀ (σ : K ≃ₐ[F] K) (P : (E⁄K).Point), e (σ • P) = σ • e P := by
+  subst hC
+  exact ⟨WeierstrassCurve.VariableChange.pointEquiv E C,
+    WeierstrassCurve.VariableChange.pointEquiv_smul E C⟩
+
+end S_WeierstrassCurve_exists_addEquiv_point_of_variableChange_eq
+end P2MW
+export P2MW.S_WeierstrassCurve_exists_addEquiv_point_of_variableChange_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+theorem WeierstrassCurve.exists_addEquiv_point_of_variableChange_eq {F : Type*} [Field F]
+    (K : Type*) [Field K] [Algebra F K] [DecidableEq K] {E E' : WeierstrassCurve F}
+    (C : VariableChange F) (hC : C • E = E') :
+    ∃ e : (E⁄K).Point ≃+ (E'⁄K).Point, ∀ (σ : K ≃ₐ[F] K) (P : (E⁄K).Point), e (σ • P) = σ • e P :=
+  solution K C hC
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_addEquiv_point_variableChange.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_addEquiv_point_variableChange.lean
new file mode 100644
index 0000000000..359576608d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_addEquiv_point_variableChange.lean
@@ -0,0 +1,320 @@
+/-
+Based on Prove2Me node WeierstrassCurve.exists_addEquiv_point_variableChange
+(8de1afe9-e422-5510-9234-bbf863be0ba2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission fcc8ed04-b73e-5162-9920-fae34884feec
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Variable change induces an isomorphism of point groups
+
+Theorem statement: `WeierstrassCurve.exists_addEquiv_point_variableChange`
+(`8de1afe9-e422-5510-9234-bbf863be0ba2`), by Claude, 2026-09-05.
+
+Proof: submission `fcc8ed04-b73e-5162-9920-fae34884feec`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field, let $W$ be a Weierstrass curve over $K$ (given by coefficients
+$a_1,a_2,a_3,a_4,a_6$), and let $C$ be a Weierstrass variable change over $K$, that is a quadruple
+consisting of a unit $u \in K^\times$ and scalars $r,s,t \in K$. Write $C \bullet W$ for the
+Weierstrass curve obtained from $W$ by the action of $C$. The assertion is that there exists an
+isomorphism of additive groups $e \colon W^{\mathrm{aff}}(K) \to (C \bullet W)^{\mathrm{aff}}(K)$
+between the groups of points of the associated affine Weierstrass curves (nonsingular $K$-rational
+affine points together with the point at infinity, with the chord–tangent addition), with the
+following property: for all $x,y \in K$ and every proof $h$ that $(x,y)$ is a nonsingular point of
+the affine curve attached to $W$, the pair $$\bigl(u^{-2}(x-r),\; u^{-3}(y - sx + (sr - t))\bigr)$$
+is a nonsingular point of the affine curve attached to $C \bullet W$, and $e$ sends the affine point
+$(x,y)$ of $W$ to that point of $C \bullet W$. No claim beyond additivity and bijectivity is made
+about the behaviour of $e$ at the point at infinity.
+
+This is the elementary statement that two Weierstrass models related by an admissible change of
+coordinates $(x,y) = (u^2x' + r,\, u^3y' + u^2sx' + t)$ have isomorphic groups of $K$-rational
+points, with the isomorphism written out in coordinates by the inverse substitution. It is used to
+transport explicit points and point-group computations between models of one elliptic curve, and is
+invoked in the Čerednik–Drinfel'd part of the development when comparing curves differing by a
+variable change.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_exists_addEquiv_point_variableChange.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_exists_addEquiv_point_variableChange
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_WeierstrassCurve_exists_addEquiv_point_variableChange.WeierstrassCurve \
+  WeierstrassCurve.Affine WeierstrassCurve.Affine.Point"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.Equation Affine.negY Affine.evalEval_polynomial \
+  Affine.Y_eq_of_Y_ne Affine.slope_of_X_ne Affine.Point.add_of_Y_eq map variableChange_a₃ \
+  Affine.evalEval_polynomialX Affine.Point.some Affine.Point.some.injEq Affine.Nonsingular \
+  variableChange_a₆ Affine.negAddY Affine.slope_of_Y_ne_eq_evalEval variableChange_a₂ toAffine \
+  Affine.Point Affine.evalEval_polynomialY Affine.addX Affine.Point.add_some variableChange_a₁ \
+  variableChange_a₄ VariableChange Affine.addY exists_addEquiv_point_variableChange_dev"
+p2m_open "WeierstrassCurve"
+
+namespace VariableChange
+p2m_export "WeierstrassCurve.VariableChange" "map u t s r"
+p2m_open "WeierstrassCurve.VariableChange"
+
+section Ring
+
+variable {R : Type*} [CommRing R] (C : VariableChange R) (W : WeierstrassCurve R)
+
+private def _root_.WeierstrassCurve.VariableChange.ptX (x : R) : R := (↑C.u⁻¹ : R) ^ 2 * (x - C.r)
+
+p2m_export "WeierstrassCurve.VariableChange" "ptX"
+
+private def _root_.WeierstrassCurve.VariableChange.ptY (x y : R) :
+    R := (↑C.u⁻¹ : R) ^ 3 * (y - C.s * x + (C.s * C.r - C.t))
+
+p2m_export "WeierstrassCurve.VariableChange" "ptY"
+
+private def _root_.WeierstrassCurve.VariableChange.invX (X : R) : R := (C.u : R) ^ 2 * X + C.r
+
+p2m_export "WeierstrassCurve.VariableChange" "invX"
+
+private def _root_.WeierstrassCurve.VariableChange.invY (X Y : R) :
+    R := (C.u : R) ^ 3 * Y + (C.u : R) ^ 2 * C.s * X + C.t
+
+p2m_export "WeierstrassCurve.VariableChange" "invY"
+lemma invX_ptX (x : R) : C.invX (C.ptX x) = x := by
+  simp only [invX, ptX]
+  linear_combination (x - C.r) * pow_mul_pow_eq_one 2 C.u.mul_inv
+
+lemma invY_ptY (x y : R) : C.invY (C.ptX x) (C.ptY x y) = y := by
+  simp only [invY, ptX, ptY]
+  linear_combination (y - C.s * x + (C.s * C.r - C.t)) * pow_mul_pow_eq_one 3 C.u.mul_inv
+    + C.s * (x - C.r) * pow_mul_pow_eq_one 2 C.u.mul_inv
+
+lemma ptX_invX (X : R) : C.ptX (C.invX X) = X := by
+  simp only [invX, ptX]
+  linear_combination X * pow_mul_pow_eq_one 2 C.u.inv_mul
+
+lemma ptY_invY (X Y : R) : C.ptY (C.invX X) (C.invY X Y) = Y := by
+  simp only [invX, invY, ptY]
+  linear_combination Y * pow_mul_pow_eq_one 3 C.u.inv_mul
+
+private lemma _root_.WeierstrassCurve.VariableChange.ptX_injective :
+    Function.Injective C.ptX := fun x₁ x₂ h => by
+  simpa only [invX_ptX] using congr_arg C.invX h
+
+p2m_export "WeierstrassCurve.VariableChange" "ptX_injective"
+private lemma _root_.WeierstrassCurve.VariableChange.ptY_injective (x : R) :
+    Function.Injective (C.ptY x) := fun y₁ y₂ h => by
+  simpa only [invY_ptY] using congr_arg (C.invY (C.ptX x)) h
+
+p2m_export "WeierstrassCurve.VariableChange" "ptY_injective"
+lemma negY_pt (x y : R) :
+    (C • W).toAffine.negY (C.ptX x) (C.ptY x y) = C.ptY x (W.toAffine.negY x y) := by
+  simp only [Affine.negY, ptX, ptY, variableChange_a₁, variableChange_a₃]
+  ring
+
+lemma addX_pt (x₁ x₂ ℓ : R) :
+    (C • W).toAffine.addX (C.ptX x₁) (C.ptX x₂) (↑C.u⁻¹ * (ℓ - C.s)) =
+      C.ptX (W.toAffine.addX x₁ x₂ ℓ) := by
+  simp only [Affine.addX, ptX, variableChange_a₁, variableChange_a₂]
+  ring
+
+lemma addY_pt (x₁ x₂ y₁ ℓ : R) :
+    (C • W).toAffine.addY (C.ptX x₁) (C.ptX x₂) (C.ptY x₁ y₁) (↑C.u⁻¹ * (ℓ - C.s)) =
+      C.ptY (W.toAffine.addX x₁ x₂ ℓ) (W.toAffine.addY x₁ x₂ y₁ ℓ) := by
+  simp only [Affine.addY, Affine.negAddY, Affine.addX, Affine.negY, ptX, ptY, variableChange_a₁,
+    variableChange_a₂, variableChange_a₃]
+  ring
+
+lemma evalEval_polynomial_pt (x y : R) :
+    (C • W).toAffine.polynomial.evalEval (C.ptX x) (C.ptY x y) =
+      ↑C.u⁻¹ ^ 6 * W.toAffine.polynomial.evalEval x y := by
+  rw [Affine.evalEval_polynomial, Affine.evalEval_polynomial]
+  simp only [ptX, ptY, variableChange_a₁, variableChange_a₂, variableChange_a₃, variableChange_a₄,
+    variableChange_a₆]
+  ring
+
+lemma evalEval_polynomialX_pt (x y : R) :
+    (C • W).toAffine.polynomialX.evalEval (C.ptX x) (C.ptY x y) =
+      ↑C.u⁻¹ ^ 4 * (W.toAffine.polynomialX.evalEval x y
+        + C.s * W.toAffine.polynomialY.evalEval x y) := by
+  rw [Affine.evalEval_polynomialX, Affine.evalEval_polynomialX, Affine.evalEval_polynomialY]
+  simp only [ptX, ptY, variableChange_a₁, variableChange_a₂, variableChange_a₄]
+  ring
+
+lemma evalEval_polynomialY_pt (x y : R) :
+    (C • W).toAffine.polynomialY.evalEval (C.ptX x) (C.ptY x y) =
+      ↑C.u⁻¹ ^ 3 * W.toAffine.polynomialY.evalEval x y := by
+  rw [Affine.evalEval_polynomialY, Affine.evalEval_polynomialY]
+  simp only [ptX, ptY, variableChange_a₁, variableChange_a₃]
+  ring
+
+lemma equation_pt_iff (x y : R) :
+    (C • W).toAffine.Equation (C.ptX x) (C.ptY x y) ↔ W.toAffine.Equation x y := by
+  rw [Affine.Equation, Affine.Equation, evalEval_polynomial_pt,
+    (C.u⁻¹.isUnit.pow 6).mul_right_eq_zero]
+
+lemma nonsingular_pt_iff (x y : R) :
+    (C • W).toAffine.Nonsingular (C.ptX x) (C.ptY x y) ↔ W.toAffine.Nonsingular x y := by
+  rw [Affine.Nonsingular, Affine.Nonsingular, equation_pt_iff, evalEval_polynomialX_pt,
+    evalEval_polynomialY_pt]
+  simp only [ne_eq, (C.u⁻¹.isUnit.pow 4).mul_right_eq_zero, (C.u⁻¹.isUnit.pow 3).mul_right_eq_zero]
+  refine and_congr_right fun _ => ?_
+  by_cases hY : W.toAffine.polynomialY.evalEval x y = 0
+  · simp only [hY, mul_zero, add_zero, not_true_eq_false, or_false]
+  · simp only [hY, not_false_eq_true, or_true]
+
+lemma nonsingular_inv_iff (X Y : R) :
+    W.toAffine.Nonsingular (C.invX X) (C.invY X Y) ↔ (C • W).toAffine.Nonsingular X Y := by
+  rw [← nonsingular_pt_iff C W, ptX_invX, ptY_invY]
+
+end Ring
+
+section Field
+
+variable {K : Type*} [Field K] [DecidableEq K] (C : VariableChange K) (W : WeierstrassCurve K)
+
+lemma slope_pt {x₁ x₂ y₁ y₂ : K} (h₁ : W.toAffine.Equation x₁ y₁) (h₂ : W.toAffine.Equation x₂ y₂)
+    (hxy : ¬(x₁ = x₂ ∧ y₁ = W.toAffine.negY x₂ y₂)) :
+    (C • W).toAffine.slope (C.ptX x₁) (C.ptX x₂) (C.ptY x₁ y₁) (C.ptY x₂ y₂) =
+      ↑C.u⁻¹ * (W.toAffine.slope x₁ x₂ y₁ y₂ - C.s) := by
+  have hu : (↑C.u⁻¹ : K) ≠ 0 := C.u⁻¹.ne_zero
+  have hu' : (↑C.u : K) ≠ 0 := C.u.ne_zero
+  by_cases hx : x₁ = x₂
+  · have hy : y₁ ≠ W.toAffine.negY x₂ y₂ := fun h => hxy ⟨hx, h⟩
+    obtain rfl : y₁ = y₂ := Affine.Y_eq_of_Y_ne h₁ h₂ hx hy
+    subst hx
+    have hy' : C.ptY x₁ y₁ ≠ (C • W).toAffine.negY (C.ptX x₁) (C.ptY x₁ y₁) := by
+      rw [negY_pt]
+      exact fun h => hy (C.ptY_injective x₁ h)
+    have hB : W.toAffine.polynomialY.evalEval x₁ y₁ ≠ 0 := by
+      rw [Affine.evalEval_polynomialY]
+      intro h
+      apply hy
+      simp only [Affine.negY]
+      linear_combination h
+    rw [Affine.slope_of_Y_ne_eq_evalEval rfl hy', Affine.slope_of_Y_ne_eq_evalEval rfl hy,
+      evalEval_polynomialX_pt, evalEval_polynomialY_pt]
+    field_simp
+    ring
+  · have hx' : C.ptX x₁ ≠ C.ptX x₂ := fun h => hx (C.ptX_injective h)
+    rw [Affine.slope_of_X_ne hx', Affine.slope_of_X_ne hx]
+    have hd : x₁ - x₂ ≠ 0 := sub_ne_zero.mpr hx
+    have hden : C.ptX x₁ - C.ptX x₂ = ↑C.u⁻¹ ^ 2 * (x₁ - x₂) := by simp only [ptX]; ring
+    have hnum : C.ptY x₁ y₁ - C.ptY x₂ y₂ = ↑C.u⁻¹ ^ 3 * ((y₁ - y₂) - C.s * (x₁ - x₂)) := by
+      simp only [ptY]; ring
+    rw [hden, hnum]
+    field_simp
+
+end Field
+
+section SameField
+
+variable {K : Type*} [Field K] [DecidableEq K] (W : WeierstrassCurve K) (C : VariableChange K)
+
+noncomputable def pointFun₀ : W.toAffine.Point → (C • W).toAffine.Point
+  | 0 => 0
+  | .some x y h => .some (C.ptX x) (C.ptY x y) <| (nonsingular_pt_iff C W x y).mpr h
+
+noncomputable def pointInv₀ : (C • W).toAffine.Point → W.toAffine.Point
+  | 0 => 0
+  | .some X Y h => .some (C.invX X) (C.invY X Y) <| (nonsingular_inv_iff C W X Y).mpr h
+
+noncomputable def pointEquiv₀ : W.toAffine.Point ≃+ (C • W).toAffine.Point where
+  toFun := pointFun₀ W C
+  invFun := pointInv₀ W C
+  left_inv := by
+    rintro (_ | ⟨x, y, h⟩)
+    · rfl
+    · simp only [pointFun₀, pointInv₀, invX_ptX, invY_ptY]
+  right_inv := by
+    rintro (_ | ⟨X, Y, h⟩)
+    · rfl
+    · simp only [pointFun₀, pointInv₀, ptX_invX, ptY_invY]
+  map_add' := by
+    rintro (_ | ⟨x₁, y₁, h₁⟩) (_ | ⟨x₂, y₂, h₂⟩)
+    · rfl
+    · rfl
+    · rfl
+    · by_cases hxy : x₁ = x₂ ∧ y₁ = W.toAffine.negY x₂ y₂
+      · rcases hxy with ⟨rfl, rfl⟩
+        rw [Affine.Point.add_of_Y_eq rfl rfl]
+        simp only [pointFun₀]
+        exact (Affine.Point.add_of_Y_eq rfl (negY_pt C W x₁ y₂).symm).symm
+      · have hxy' : ¬(C.ptX x₁ = C.ptX x₂ ∧ C.ptY x₁ y₁ =
+            (C • W).toAffine.negY (C.ptX x₂) (C.ptY x₂ y₂)) := by
+          rintro ⟨hx, hy⟩
+          obtain rfl := C.ptX_injective hx
+          rw [negY_pt] at hy
+          exact hxy ⟨rfl, C.ptY_injective x₁ hy⟩
+        rw [Affine.Point.add_some hxy]
+        simp only [pointFun₀]
+        rw [Affine.Point.add_some hxy', Affine.Point.some.injEq,
+          slope_pt C W h₁.1 h₂.1 hxy, addX_pt, addY_pt]
+        exact ⟨rfl, rfl⟩
+
+lemma pointEquiv₀_some {x y : K} (h : W.toAffine.Nonsingular x y) :
+    pointEquiv₀ W C (.some x y h) = .some (C.ptX x) (C.ptY x y) ((nonsingular_pt_iff C W x y).mpr h)
+      :=
+  rfl
+
+private theorem _root_.WeierstrassCurve.exists_addEquiv_point_variableChange_dev :
+    ∃ e : W.toAffine.Point ≃+ (C • W).toAffine.Point, ∀ (x y : K) (h : W.toAffine.Nonsingular x y),
+      ∃ h' : (C • W).toAffine.Nonsingular ((↑C.u⁻¹ : K) ^ 2 * (x - C.r))
+          ((↑C.u⁻¹ : K) ^ 3 * (y - C.s * x + (C.s * C.r - C.t))),
+        e (WeierstrassCurve.Affine.Point.some x y h) =
+          WeierstrassCurve.Affine.Point.some ((↑C.u⁻¹ : K) ^ 2 * (x - C.r))
+            ((↑C.u⁻¹ : K) ^ 3 * (y - C.s * x + (C.s * C.r - C.t))) h' :=
+  ⟨pointEquiv₀ W C, fun x y h => ⟨(nonsingular_pt_iff C W x y).mpr h, rfl⟩⟩
+
+end SameField
+
+end VariableChange
+
+end WeierstrassCurve
+
+theorem solution {K : Type*} [Field K] [DecidableEq K] (W : WeierstrassCurve K)
+    (C : VariableChange K) :
+    ∃ e : W.toAffine.Point ≃+ (C • W).toAffine.Point, ∀ (x y : K) (h : W.toAffine.Nonsingular x y),
+      ∃ h' : (C • W).toAffine.Nonsingular ((↑C.u⁻¹ : K) ^ 2 * (x - C.r)) ((↑C.u⁻¹ : K) ^ 3 * (y -
+      C.s * x + (C.s * C.r - C.t))), e (WeierstrassCurve.Affine.Point.some x y h) =
+      WeierstrassCurve.Affine.Point.some ((↑C.u⁻¹ : K) ^ 2 * (x - C.r)) ((↑C.u⁻¹ : K) ^ 3 * (y - C.s
+      * x + (C.s * C.r - C.t))) h' :=
+  ⟨WeierstrassCurve.VariableChange.pointEquiv₀ W C, fun x y h =>
+    ⟨(WeierstrassCurve.VariableChange.nonsingular_pt_iff C W x y).mpr h, rfl⟩⟩
+
+end S_WeierstrassCurve_exists_addEquiv_point_variableChange
+end P2MW
+export P2MW.S_WeierstrassCurve_exists_addEquiv_point_variableChange (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+theorem WeierstrassCurve.exists_addEquiv_point_variableChange {K : Type*} [Field K] [DecidableEq K]
+    (W : WeierstrassCurve K) (C : VariableChange K) :
+    ∃ e : W.toAffine.Point ≃+ (C • W).toAffine.Point, ∀ (x y : K) (h : W.toAffine.Nonsingular x y),
+      ∃ h' : (C • W).toAffine.Nonsingular ((↑C.u⁻¹ : K) ^ 2 * (x - C.r)) ((↑C.u⁻¹ : K) ^ 3 * (y -
+      C.s * x + (C.s * C.r - C.t))), e (WeierstrassCurve.Affine.Point.some x y h) =
+      WeierstrassCurve.Affine.Point.some ((↑C.u⁻¹ : K) ^ 2 * (x - C.r)) ((↑C.u⁻¹ : K) ^ 3 * (y - C.s
+      * x + (C.s * C.r - C.t))) h' :=
+  solution W C
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_addMonoidHom_coe_eq_veluPointMap2.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_addMonoidHom_coe_eq_veluPointMap2.lean
new file mode 100644
index 0000000000..d2c75a4ea6
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_addMonoidHom_coe_eq_veluPointMap2.lean
@@ -0,0 +1,1055 @@
+/-
+Based on Prove2Me node WeierstrassCurve.exists_addMonoidHom_coe_eq_veluPointMap2
+(16abb7e8-df12-51d9-abff-a0d86be1ab6d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission fdcda89b-f43a-534b-881a-ab87c36585fb
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluPointMap2
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_velu2_tangent_addX_cleared_identity
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_velu2_tangent_negAddY_cleared_identity
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_velu2_line_image_factored
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_veluQuotient2_Delta_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Vélu's order-2 quotient map is additive
+
+Theorem statement: `WeierstrassCurve.exists_addMonoidHom_coe_eq_veluPointMap2`
+(`16abb7e8-df12-51d9-abff-a0d86be1ab6d`), by Claude, 2026-09-05.
+
+Proof: submission `fdcda89b-f43a-534b-881a-ab87c36585fb`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field in which $2 \neq 0$ and let $W$ be a Weierstrass curve over $F$ satisfying
+`IsElliptic`. Let $x_0, y_0 \in F$ satisfy the affine Weierstrass equation of $W$, and assume
+$W.\mathrm{veluGy}(x_0,y_0) = -(2y_0 + a_1 x_0 + a_3)$ vanishes, so that $(x_0,y_0)$ is a
+$2$-torsion point. Write $t = W.\mathrm{veluGx}(x_0,y_0) = 3x_0^2 + 2a_2 x_0 + a_4 - a_1 y_0$, and
+let $W' = W.\mathrm{veluQuotient2}\,x_0\,y_0$ be the Weierstrass curve with the same $a_1, a_2, a_3$
+and with $a_4' = a_4 - 5t$, $a_6' = a_6 - b_2 t - 7 x_0 t$; assume the discriminant $\Delta$ of $W'$
+is nonzero. The assertion is that there exists an additive monoid homomorphism $\varphi$ from the
+group of points of the affine curve attached to $W$ to that of $W'$ whose underlying function is
+`veluPointMap2` for these data, namely the map sending the point at infinity to the point at
+infinity, sending an affine point $(x,y)$ with $x = x_0$ to the point at infinity, and sending an
+affine point with $x \neq x_0$ to the affine point of $W'$ furnished by `velu2_map_nonsingular`.
+
+This is the order-$2$ case of the statement that Vélu's formulas define an isogeny: the explicit
+quotient map by the subgroup generated by a $2$-torsion point respects the group law, its kernel
+consisting of the point at infinity together with that $2$-torsion point. It is used in the
+construction of cyclic quotients of elliptic curves and in the discriminant computations for Tate
+points on modular curves that depend on them.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_exists_addMonoidHom_coe_eq_veluPointMap2.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+section PieceKernelExact
+
+open Polynomial
+
+namespace WeierstrassCurve
+
+section NegYFixedPoint
+
+variable {R : Type*} [CommRing R] {W : WeierstrassCurve R} {x₀ y₀ : R}
+
+lemma negY_eq_of_veluGy_eq_zero (hgy : W.veluGy x₀ y₀ = 0) :
+    W.toAffine.negY x₀ y₀ = y₀ := by
+  simp only [veluGy] at hgy
+  simp only [Affine.negY]
+  linear_combination hgy
+
+lemma veluGy_eq_zero_iff_negY_eq :
+    W.veluGy x₀ y₀ = 0 ↔ W.toAffine.negY x₀ y₀ = y₀ :=
+  ⟨negY_eq_of_veluGy_eq_zero, fun h => W.veluGy_eq_zero_of_negY_eq h⟩
+
+end NegYFixedPoint
+
+section FibreSingleton
+
+variable {F : Type*} [Field F] {W : WeierstrassCurve F} {x₀ y₀ : F}
+
+lemma eq_of_equation_of_veluGy_eq_zero (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) {y : F} (h : W.toAffine.Equation x₀ y) : y = y₀ := by
+  rcases Affine.Y_eq_of_X_eq h hQ rfl with hy | hy
+  · exact hy
+  · rw [hy, negY_eq_of_veluGy_eq_zero hgy]
+
+end FibreSingleton
+
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+
+namespace Affine
+
+open WeierstrassCurve.Affine WeierstrassCurve
+
+section PointFibre
+
+variable {F : Type*} [Field F] {W : Affine F} {x₀ y₀ : F}
+
+p2m_open_scoped "WeierstrassCurve.Affine.Point" in
+theorem Point.some_eq_of_X_eq_of_veluGy_eq_zero (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hns : W.toAffine.Nonsingular x₀ y₀)
+    {x y : F} (h : W.toAffine.Nonsingular x y) (hx : x = x₀) :
+    Point.some x y h = Point.some x₀ y₀ hns := by
+  have hy : y = y₀ := eq_of_equation_of_veluGy_eq_zero hQ hgy (hx ▸ h.left)
+  subst hx
+  subst hy
+  rfl
+
+end PointFibre
+
+section TwoTorsionOrder
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : Affine F} {x₀ y₀ : F}
+
+theorem two_nsmul_some_eq_zero_of_veluGy_eq_zero (hgy : W.veluGy x₀ y₀ = 0)
+    (hns : W.toAffine.Nonsingular x₀ y₀) :
+    2 • (Point.some x₀ y₀ hns : W.toAffine.Point) = 0 := by
+  rw [two_nsmul]
+  exact Point.add_of_Y_eq rfl (negY_eq_of_veluGy_eq_zero hgy).symm
+
+end TwoTorsionOrder
+
+end Affine
+end WeierstrassCurve
+
+end PieceKernelExact
+
+section Piece_KwVeluOrderTwoNeg
+open Polynomial
+
+namespace WeierstrassCurve
+
+section Field
+
+variable {F : Type*} [Field F] {W : WeierstrassCurve F} {x₀ y₀ : F}
+
+theorem kw_velu2Y_negY (hgy : W.veluGy x₀ y₀ = 0) (x y : F) :
+    W.velu2Y x₀ y₀ x (W.toAffine.negY x y)
+      = (W.veluQuotient2 x₀ y₀).toAffine.negY (W.velu2X x₀ y₀ x) (W.velu2Y x₀ y₀ x y) := by
+  have hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0 := by
+    have h := hgy; rw [veluGy, neg_eq_zero] at h; exact h
+  by_cases hx : x = x₀
+  · subst hx
+    simp only [velu2Y, velu2X, sub_self, ne_eq, OfNat.ofNat_ne_zero, not_false_eq_true,
+      zero_pow, div_zero, sub_zero, add_zero, Affine.negY, veluQuotient2_a₁, veluQuotient2_a₃]
+  · have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+    simp only [velu2Y, velu2X, Affine.negY, veluQuotient2_a₁, veluQuotient2_a₃]
+    field_simp
+    linear_combination W.veluGx x₀ y₀ * hord
+
+variable (hchar : (2 : F) ≠ 0) (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0)
+  (hΔ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0)
+
+lemma kw_v2neg_some_congr {W' : Affine F} {x y₁ y₂ : F}
+    {h₁ : W'.Nonsingular x y₁} {h₂ : W'.Nonsingular x y₂} (hy : y₁ = y₂) :
+    Affine.Point.some x y₁ h₁ = Affine.Point.some x y₂ h₂ := by
+  subst hy; rfl
+
+include hchar hQ hgy hΔ in
+theorem kw_veluPointMap2_neg (P : W.toAffine.Point) :
+    veluPointMap2 hchar hQ hgy hΔ (-P) = -veluPointMap2 hchar hQ hgy hΔ P := by
+  classical
+  cases P with
+  | zero => rfl
+  | some x y h =>
+    rw [Affine.Point.neg_some]
+    by_cases hx : x = x₀
+    · rw [veluPointMap2_some_of_eq hchar hQ hgy hΔ _ hx,
+        veluPointMap2_some_of_eq hchar hQ hgy hΔ h hx]
+      rfl
+    · rw [veluPointMap2_some_of_ne hchar hQ hgy hΔ _ hx,
+        veluPointMap2_some_of_ne hchar hQ hgy hΔ h hx, Affine.Point.neg_some]
+      exact kw_v2neg_some_congr (kw_velu2Y_negY hgy x y)
+
+end Field
+
+end WeierstrassCurve
+end Piece_KwVeluOrderTwoNeg
+
+section Piece_KwVeluOrderTwoAddKernel
+open Polynomial
+
+namespace WeierstrassCurve
+
+section Field
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F} {x₀ y₀ : F}
+
+omit [DecidableEq F] in
+theorem kw_veluGx_ne_zero_of_quotΔ (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hΔ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0) :
+    W.veluGx x₀ y₀ ≠ 0 := fun h =>
+  hΔ (by rw [veluQuotient2_Delta_eq hQ hgy, h]; ring)
+
+theorem kw_velu2_addX_kernel {x y : F} (hP : W.toAffine.Equation x y)
+    (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0) (hx : x ≠ x₀) :
+    W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y y₀)
+      = x₀ + W.veluGx x₀ y₀ / (x - x₀) := by
+  have hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0 := by
+    have h := hgy; rw [veluGy, neg_eq_zero] at h; exact h
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  rw [Affine.equation_iff] at hP hQ
+  simp only [Affine.slope_of_X_ne hx, Affine.addX, veluGx]
+  field_simp
+  linear_combination hP - hQ - (y - y₀) * hord
+
+omit [DecidableEq F] in
+theorem kw_velu2X_sub_velu2X {x₁ x₂ : F} (hx₁ : x₁ ≠ x₀) (hx₂ : x₂ ≠ x₀) :
+    W.velu2X x₀ y₀ x₁ - W.velu2X x₀ y₀ x₂
+      = (x₁ - x₂) * ((x₁ - x₀) * (x₂ - x₀) - W.veluGx x₀ y₀)
+          / ((x₁ - x₀) * (x₂ - x₀)) := by
+  have hd₁ : x₁ - x₀ ≠ 0 := sub_ne_zero.mpr hx₁
+  have hd₂ : x₂ - x₀ ≠ 0 := sub_ne_zero.mpr hx₂
+  simp only [velu2X]
+  field_simp
+  ring
+
+omit [DecidableEq F] in
+theorem kw_velu2X_eq_iff {x₁ x₂ : F} (hx₁ : x₁ ≠ x₀) (hx₂ : x₂ ≠ x₀) :
+    W.velu2X x₀ y₀ x₁ = W.velu2X x₀ y₀ x₂
+      ↔ x₁ = x₂ ∨ (x₁ - x₀) * (x₂ - x₀) = W.veluGx x₀ y₀ := by
+  have hd₁ : x₁ - x₀ ≠ 0 := sub_ne_zero.mpr hx₁
+  have hd₂ : x₂ - x₀ ≠ 0 := sub_ne_zero.mpr hx₂
+  rw [← sub_eq_zero, kw_velu2X_sub_velu2X hx₁ hx₂, div_eq_zero_iff, mul_eq_zero,
+    sub_eq_zero, sub_eq_zero]
+  simp only [mul_ne_zero hd₁ hd₂, or_false]
+
+theorem kw_velu2X_addKernel {x y : F} (hP : W.toAffine.Equation x y)
+    (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0)
+    (ht : W.veluGx x₀ y₀ ≠ 0) (hx : x ≠ x₀) :
+    W.velu2X x₀ y₀ (W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y y₀))
+      = W.velu2X x₀ y₀ x := by
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  have htd : W.veluGx x₀ y₀ / (x - x₀) ≠ 0 := div_ne_zero ht hd
+  rw [kw_velu2_addX_kernel hP hQ hgy hx]
+  simp only [velu2X, add_sub_cancel_left]
+  field_simp
+  ring
+
+theorem kw_velu2_addY_kernel {x y : F} (hP : W.toAffine.Equation x y)
+    (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0) (hx : x ≠ x₀) :
+    W.toAffine.addY x x₀ y (W.toAffine.slope x x₀ y y₀) - y₀
+      = -(W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀)) / (x - x₀) ^ 2 := by
+  have hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0 := by
+    have h := hgy; rw [veluGy, neg_eq_zero] at h; exact h
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  have hxP := kw_velu2_addX_kernel hP hQ hgy hx
+  simp only [Affine.addY, Affine.negAddY, Affine.negY, Affine.slope_of_X_ne hx] at hxP ⊢
+  rw [hxP]
+  field_simp
+  linear_combination -((x - x₀) ^ 2 * hord)
+
+theorem kw_velu2Y_addKernel {x y : F} (hP : W.toAffine.Equation x y)
+    (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0)
+    (ht : W.veluGx x₀ y₀ ≠ 0) (hx : x ≠ x₀) :
+    W.velu2Y x₀ y₀ (W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y y₀))
+        (W.toAffine.addY x x₀ y (W.toAffine.slope x x₀ y y₀))
+      = W.velu2Y x₀ y₀ x y := by
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  have hxP := kw_velu2_addX_kernel hP hQ hgy hx
+  have hyP := kw_velu2_addY_kernel hP hQ hgy hx
+  simp only [velu2Y]
+  have htd : W.veluGx x₀ y₀ / (x - x₀) ≠ 0 := div_ne_zero ht hd
+  rw [hxP, add_sub_cancel_left]
+  have key : W.veluGx x₀ y₀
+        * (W.a₁ * (W.veluGx x₀ y₀ / (x - x₀))
+            + W.toAffine.addY x x₀ y (W.toAffine.slope x x₀ y y₀) - y₀)
+        / (W.veluGx x₀ y₀ / (x - x₀)) ^ 2
+      = y₀ - y := by
+    rw [sub_eq_iff_eq_add.mp hyP]
+    field_simp
+    ring
+  rw [key]
+  linear_combination hyP
+
+variable (hchar : (2 : F) ≠ 0) (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0)
+  (hΔ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0)
+
+omit [DecidableEq F] in
+lemma kw_v2ker_some_congr {W' : Affine F} {u₁ u₂ v₁ v₂ : F}
+    {h₁ : W'.Nonsingular u₁ v₁} {h₂ : W'.Nonsingular u₂ v₂} (hX : u₁ = u₂) (hY : v₁ = v₂) :
+    Affine.Point.some u₁ v₁ h₁ = Affine.Point.some u₂ v₂ h₂ := by
+  subst hX; subst hY; rfl
+
+include hchar hQ hgy hΔ in
+theorem kw_veluPointMap2_add_kernel_gen (hQns : W.toAffine.Nonsingular x₀ y₀)
+    (P : W.toAffine.Point) :
+    veluPointMap2 hchar hQ hgy hΔ (P + .some x₀ y₀ hQns)
+      = veluPointMap2 hchar hQ hgy hΔ P := by
+  have ht : W.veluGx x₀ y₀ ≠ 0 := kw_veluGx_ne_zero_of_quotΔ hQ hgy hΔ
+  have h2P₀ : (2 : ℕ) • (Affine.Point.some x₀ y₀ hQns : W.toAffine.Point) = 0 :=
+    Affine.two_nsmul_some_eq_zero_of_veluGy_eq_zero hgy hQns
+  cases P with
+  | zero =>
+    rw [← Affine.Point.zero_def, zero_add, Affine.Point.zero_def, veluPointMap2_zero]
+    exact veluPointMap2_some_of_eq hchar hQ hgy hΔ hQns rfl
+  | some x y h =>
+    by_cases hx : x = x₀
+    · have hPP₀ : Affine.Point.some x y h = Affine.Point.some x₀ y₀ hQns :=
+        Affine.Point.some_eq_of_X_eq_of_veluGy_eq_zero hQ hgy hQns h hx
+      rw [hPP₀, ← two_nsmul, h2P₀, veluPointMap2_some_of_eq hchar hQ hgy hΔ hQns rfl]
+      rfl
+    · have hnsA : W.toAffine.Nonsingular
+          (W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y y₀))
+          (W.toAffine.addY x x₀ y (W.toAffine.slope x x₀ y y₀)) :=
+        Affine.nonsingular_add h hQns fun hc => hx hc.1
+      have hPP₀ : Affine.Point.some x y h + Affine.Point.some x₀ y₀ hQns
+          = Affine.Point.some _ _ hnsA := Affine.Point.add_of_X_ne hx
+      have hxA : W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y y₀) ≠ x₀ := by
+        rw [kw_velu2_addX_kernel h.1 hQ hgy hx]
+        simpa using div_ne_zero ht (sub_ne_zero.mpr hx)
+      rw [hPP₀, veluPointMap2_some_of_ne hchar hQ hgy hΔ hnsA hxA,
+        veluPointMap2_some_of_ne hchar hQ hgy hΔ h hx]
+      exact kw_v2ker_some_congr (kw_velu2X_addKernel h.1 hQ hgy ht hx)
+        (kw_velu2Y_addKernel h.1 hQ hgy ht hx)
+
+end Field
+
+end WeierstrassCurve
+end Piece_KwVeluOrderTwoAddKernel
+
+section Piece_KwVeluOrderTwoSecantXContent
+open Polynomial WeierstrassCurve.Affine WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+
+section CommRing
+
+variable {R : Type*} [CommRing R] {W : WeierstrassCurve R} {x₀ y₀ x₁ y₁ x₂ y₂ : R}
+
+theorem kw_velu2_secX_SI2 (hP₁ : W.toAffine.Equation x₁ y₁)
+    (hP₂ : W.toAffine.Equation x₂ y₂) (hQ : W.toAffine.Equation x₀ y₀)
+    (hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0) :
+    (x₁ - x₀) * (x₂ - x₀) * (x₁ - x₂) * ((x₁ - x₀) * (x₂ - x₀) - W.veluGx x₀ y₀)
+      = ((x₂ - x₀) * (W.a₁ * (x₁ - x₀) + y₁ - y₀)
+            + (x₁ - x₀) * (W.a₁ * (x₂ - x₀) + y₂ - y₀) - W.a₁ * ((x₁ - x₀) * (x₂ - x₀)))
+        * ((x₂ - x₀) * (y₁ - y₀) - (x₁ - x₀) * (y₂ - y₀)) := by
+  rw [Affine.equation_iff] at hP₁ hP₂ hQ
+  simp only [veluGx]
+  linear_combination (-(x₂ - x₀) ^ 2) * hP₁ + (x₁ - x₀) ^ 2 * hP₂
+    + (-(x₁ - x₂) * ((x₁ - x₀) + (x₂ - x₀))) * hQ
+    + ((x₂ - x₀) ^ 2 * y₁ - (x₁ - x₀) ^ 2 * y₂
+        + (x₁ - x₂) * ((x₁ - x₀) + (x₂ - x₀)) * y₀) * hord
+
+theorem kw_velu2_secX_SI3 (hP₁ : W.toAffine.Equation x₁ y₁)
+    (hP₂ : W.toAffine.Equation x₂ y₂) (hQ : W.toAffine.Equation x₀ y₀)
+    (hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0) :
+    ((y₁ - y₂) ^ 2 + W.a₁ * (y₁ - y₂) * (x₁ - x₂) - (W.a₂ + x₀ + x₁ + x₂) * (x₁ - x₂) ^ 2)
+        * ((x₂ - x₀) * (W.a₁ * (x₁ - x₀) + y₁ - y₀)
+            + (x₁ - x₀) * (W.a₁ * (x₂ - x₀) + y₂ - y₀) - W.a₁ * ((x₁ - x₀) * (x₂ - x₀)))
+      = (x₁ - x₂) * ((x₁ - x₀) * (x₂ - x₀) - W.veluGx x₀ y₀)
+        * ((x₂ - x₀) * (y₁ - y₀) - (x₁ - x₀) * (y₂ - y₀)) := by
+  rw [Affine.equation_iff] at hP₁ hP₂ hQ
+  simp only [veluGx]
+  linear_combination
+    (-W.a₁*x₀*x₁ + W.a₁*x₀*x₂ + W.a₁*x₁*x₂ - W.a₁*x₂ ^ 2 - x₀*y₁ + x₀*y₂ - x₁*y₀ + x₁*y₂ + x₂*y₀
+     + x₂*y₁ - 2*x₂*y₂) * hP₁
+    + (W.a₁*x₀*x₁ - W.a₁*x₀*x₂ - W.a₁*x₁ ^ 2 + W.a₁*x₁*x₂ + x₀*y₁ - x₀*y₂ + x₁*y₀ - 2*x₁*y₁
+     + x₁*y₂ - x₂*y₀ + x₂*y₁) * hP₂
+    + ((x₁ - x₂) * (W.a₁ * (x₁ - x₂) + 2 * (y₁ - y₂))) * hQ
+    + (-(W.a₁ * (x₁ - x₂) + (y₁ - y₂))
+        * ((x₂ - x₀) * (y₁ - y₀) - (x₁ - x₀) * (y₂ - y₀))) * hord
+
+end CommRing
+
+end WeierstrassCurve
+end Piece_KwVeluOrderTwoSecantXContent
+
+
+section Piece_KwVeluOrderTwoSecantAtoms
+open Polynomial WeierstrassCurve.Affine WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+
+section Field
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F} {x₀ y₀ x₁ y₁ x₂ y₂ : F}
+
+theorem kw_velu2_dXA_cleared (hx12 : x₁ ≠ x₂) :
+    (x₁ - x₂) ^ 2 * (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₀)
+      = (y₁ - y₂) ^ 2 + W.a₁ * (y₁ - y₂) * (x₁ - x₂)
+          - (W.a₂ + x₀ + x₁ + x₂) * (x₁ - x₂) ^ 2 := by
+  have hd₁₂ : x₁ - x₂ ≠ 0 := sub_ne_zero.mpr hx12
+  simp only [Affine.addX, Affine.slope_of_X_ne hx12]
+  field_simp
+  ring
+
+variable (hx12 : x₁ ≠ x₂) (hx₁ : x₁ ≠ x₀) (hx₂ : x₂ ≠ x₀)
+  (hX12 : W.velu2X x₀ y₀ x₁ ≠ W.velu2X x₀ y₀ x₂)
+
+include hx12 hx₁ hx₂ hX12 in
+theorem kw_velu2_slopeDiff_cleared :
+    ((W.veluQuotient2 x₀ y₀).toAffine.slope (W.velu2X x₀ y₀ x₁) (W.velu2X x₀ y₀ x₂)
+          (W.velu2Y x₀ y₀ x₁ y₁) (W.velu2Y x₀ y₀ x₂ y₂)
+        - W.toAffine.slope x₁ x₂ y₁ y₂)
+      * ((x₁ - x₀) * (x₂ - x₀)) * ((x₁ - x₀) * (x₂ - x₀) - W.veluGx x₀ y₀)
+      = W.veluGx x₀ y₀
+        * ((x₂ - x₀) * (W.a₁ * (x₁ - x₀) + y₁ - y₀)
+            + (x₁ - x₀) * (W.a₁ * (x₂ - x₀) + y₂ - y₀)
+            - W.a₁ * ((x₁ - x₀) * (x₂ - x₀))) := by
+  have hd₁ : x₁ - x₀ ≠ 0 := sub_ne_zero.mpr hx₁
+  have hd₂ : x₂ - x₀ ≠ 0 := sub_ne_zero.mpr hx₂
+  have hd₁₂ : x₁ - x₂ ≠ 0 := sub_ne_zero.mpr hx12
+  have hX12' : W.velu2X x₀ y₀ x₁ - W.velu2X x₀ y₀ x₂ ≠ 0 := sub_ne_zero.mpr hX12
+  have hD₁₂ : (x₁ - x₀) * (x₂ - x₀) - W.veluGx x₀ y₀ ≠ 0 := fun h =>
+    hX12' (by rw [kw_velu2X_sub_velu2X hx₁ hx₂, h, mul_zero, zero_div])
+  rw [Affine.slope_of_X_ne hX12, Affine.slope_of_X_ne hx12,
+    kw_velu2X_sub_velu2X hx₁ hx₂]
+  simp only [velu2Y]
+  field_simp
+  ring
+
+include hx12 hx₁ hx₂ hX12 in
+theorem kw_velu2_slopeSum_cleared :
+    ((W.veluQuotient2 x₀ y₀).toAffine.slope (W.velu2X x₀ y₀ x₁) (W.velu2X x₀ y₀ x₂)
+          (W.velu2Y x₀ y₀ x₁ y₁) (W.velu2Y x₀ y₀ x₂ y₂)
+        + W.toAffine.slope x₁ x₂ y₁ y₂ + W.a₁)
+      * ((x₁ - x₀) * (x₂ - x₀)) * (x₁ - x₂) * ((x₁ - x₀) * (x₂ - x₀) - W.veluGx x₀ y₀)
+      = (x₁ - x₂) * ((x₁ - x₀) * (x₂ - x₀))
+          * ((x₂ - x₀) * (W.a₁ * (x₁ - x₀) + y₁ - y₀)
+              + (x₁ - x₀) * (W.a₁ * (x₂ - x₀) + y₂ - y₀)
+              - W.a₁ * ((x₁ - x₀) * (x₂ - x₀)))
+        + ((x₁ - x₀) * (x₂ - x₀) - W.veluGx x₀ y₀) * ((x₁ - x₀) + (x₂ - x₀))
+          * ((x₂ - x₀) * (y₁ - y₀) - (x₁ - x₀) * (y₂ - y₀)) := by
+  have hd₁ : x₁ - x₀ ≠ 0 := sub_ne_zero.mpr hx₁
+  have hd₂ : x₂ - x₀ ≠ 0 := sub_ne_zero.mpr hx₂
+  have hd₁₂ : x₁ - x₂ ≠ 0 := sub_ne_zero.mpr hx12
+  have hX12' : W.velu2X x₀ y₀ x₁ - W.velu2X x₀ y₀ x₂ ≠ 0 := sub_ne_zero.mpr hX12
+  have hD₁₂ : (x₁ - x₀) * (x₂ - x₀) - W.veluGx x₀ y₀ ≠ 0 := fun h =>
+    hX12' (by rw [kw_velu2X_sub_velu2X hx₁ hx₂, h, mul_zero, zero_div])
+  rw [Affine.slope_of_X_ne hX12, Affine.slope_of_X_ne hx12,
+    kw_velu2X_sub_velu2X hx₁ hx₂]
+  simp only [velu2Y]
+  field_simp
+  ring
+
+end Field
+
+end WeierstrassCurve
+end Piece_KwVeluOrderTwoSecantAtoms
+
+section Piece_KwVeluOrderTwoSecantCarrier
+open Polynomial
+
+namespace WeierstrassCurve
+
+section Field
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F} (x₀ y₀ : F)
+
+private abbrev _root_.WeierstrassCurve.KwVeluOrderTwoSecantCompatDiffAvoidAt : Prop :=
+  ∀ ⦃x₁ y₁ x₂ y₂ : F⦄, W.toAffine.Equation x₁ y₁ → W.toAffine.Equation x₂ y₂ →
+    x₁ ≠ x₂ → x₁ ≠ x₀ → x₂ ≠ x₀ →
+    W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) ≠ x₀ →
+    W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ (W.toAffine.negY x₂ y₂)) ≠ x₀ →
+    W.velu2X x₀ y₀ x₁ ≠ W.velu2X x₀ y₀ x₂
+    ∧ W.velu2X x₀ y₀ (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂))
+        = (W.veluQuotient2 x₀ y₀).toAffine.addX (W.velu2X x₀ y₀ x₁) (W.velu2X x₀ y₀ x₂)
+            ((W.veluQuotient2 x₀ y₀).toAffine.slope (W.velu2X x₀ y₀ x₁) (W.velu2X x₀ y₀ x₂)
+              (W.velu2Y x₀ y₀ x₁ y₁) (W.velu2Y x₀ y₀ x₂ y₂))
+    ∧ W.velu2Y x₀ y₀ (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂))
+          (W.toAffine.addY x₁ x₂ y₁ (W.toAffine.slope x₁ x₂ y₁ y₂))
+        = (W.veluQuotient2 x₀ y₀).toAffine.addY
+            (W.velu2X x₀ y₀ x₁) (W.velu2X x₀ y₀ x₂) (W.velu2Y x₀ y₀ x₁ y₁)
+            ((W.veluQuotient2 x₀ y₀).toAffine.slope (W.velu2X x₀ y₀ x₁) (W.velu2X x₀ y₀ x₂)
+              (W.velu2Y x₀ y₀ x₁ y₁) (W.velu2Y x₀ y₀ x₂ y₂))
+
+private abbrev _root_.WeierstrassCurve.KwVeluOrderTwoTangentCompatAt : Prop :=
+  ∀ ⦃x y : F⦄, W.toAffine.Equation x y → y ≠ W.toAffine.negY x y → x ≠ x₀ →
+    W.toAffine.addX x x (W.toAffine.slope x x y y) ≠ x₀ →
+    W.velu2Y x₀ y₀ x y
+      ≠ (W.veluQuotient2 x₀ y₀).toAffine.negY (W.velu2X x₀ y₀ x) (W.velu2Y x₀ y₀ x y)
+    ∧ W.velu2X x₀ y₀ (W.toAffine.addX x x (W.toAffine.slope x x y y))
+        = (W.veluQuotient2 x₀ y₀).toAffine.addX (W.velu2X x₀ y₀ x) (W.velu2X x₀ y₀ x)
+            ((W.veluQuotient2 x₀ y₀).toAffine.slope (W.velu2X x₀ y₀ x) (W.velu2X x₀ y₀ x)
+              (W.velu2Y x₀ y₀ x y) (W.velu2Y x₀ y₀ x y))
+    ∧ W.velu2Y x₀ y₀ (W.toAffine.addX x x (W.toAffine.slope x x y y))
+          (W.toAffine.addY x x y (W.toAffine.slope x x y y))
+        = (W.veluQuotient2 x₀ y₀).toAffine.addY
+            (W.velu2X x₀ y₀ x) (W.velu2X x₀ y₀ x) (W.velu2Y x₀ y₀ x y)
+            ((W.veluQuotient2 x₀ y₀).toAffine.slope (W.velu2X x₀ y₀ x) (W.velu2X x₀ y₀ x)
+              (W.velu2Y x₀ y₀ x y) (W.velu2Y x₀ y₀ x y))
+
+variable {x₀ y₀}
+variable (hchar : (2 : F) ≠ 0) (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0)
+  (hΔ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0)
+
+include hchar hQ hgy hΔ in
+theorem kw_veluPointMap2_add_of_secant_diffAvoid
+    (hsec : W.KwVeluOrderTwoSecantCompatDiffAvoidAt x₀ y₀)
+    {x₁ y₁ x₂ y₂ : F} (h₁ : W.toAffine.Nonsingular x₁ y₁) (h₂ : W.toAffine.Nonsingular x₂ y₂)
+    (hx12 : x₁ ≠ x₂) (hx₁ : x₁ ≠ x₀) (hx₂ : x₂ ≠ x₀)
+    (hsp : W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) ≠ x₀)
+    (hsm : W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ (W.toAffine.negY x₂ y₂)) ≠ x₀) :
+    veluPointMap2 hchar hQ hgy hΔ
+        ((Affine.Point.some x₁ y₁ h₁ : W.toAffine.Point) + Affine.Point.some x₂ y₂ h₂)
+      = veluPointMap2 hchar hQ hgy hΔ (Affine.Point.some x₁ y₁ h₁)
+        + veluPointMap2 hchar hQ hgy hΔ (Affine.Point.some x₂ y₂ h₂) := by
+  obtain ⟨hX12, hXeq, hYeq⟩ := hsec h₁.1 h₂.1 hx12 hx₁ hx₂ hsp hsm
+  rw [Affine.Point.add_of_X_ne hx12, veluPointMap2_some_of_ne hchar hQ hgy hΔ _ hsp,
+    veluPointMap2_some_of_ne hchar hQ hgy hΔ h₁ hx₁,
+    veluPointMap2_some_of_ne hchar hQ hgy hΔ h₂ hx₂]
+  rw [Affine.Point.add_of_X_ne hX12]
+  exact kw_v2ker_some_congr hXeq hYeq
+
+include hchar hQ hgy hΔ in
+theorem kw_veluPointMap2_add_self_of_tangent
+    (htan : W.KwVeluOrderTwoTangentCompatAt x₀ y₀)
+    {x y : F} (h : W.toAffine.Nonsingular x y) (hy : y ≠ W.toAffine.negY x y) (hx : x ≠ x₀)
+    (hx2 : W.toAffine.addX x x (W.toAffine.slope x x y y) ≠ x₀) :
+    veluPointMap2 hchar hQ hgy hΔ
+        ((Affine.Point.some x y h : W.toAffine.Point) + Affine.Point.some x y h)
+      = veluPointMap2 hchar hQ hgy hΔ (Affine.Point.some x y h)
+        + veluPointMap2 hchar hQ hgy hΔ (Affine.Point.some x y h) := by
+  obtain ⟨hY, hXeq, hYeq⟩ := htan h.1 hy hx hx2
+  rw [Affine.Point.add_self_of_Y_ne hy, veluPointMap2_some_of_ne hchar hQ hgy hΔ _ hx2,
+    veluPointMap2_some_of_ne hchar hQ hgy hΔ h hx]
+  rw [Affine.Point.add_self_of_Y_ne hY]
+  exact kw_v2ker_some_congr hXeq hYeq
+
+end Field
+
+end WeierstrassCurve
+end Piece_KwVeluOrderTwoSecantCarrier
+
+section Piece_KwVeluOrderTwoSecantConjunctOne
+open Polynomial WeierstrassCurve.Affine WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+
+section Field
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F} {x₀ y₀ : F}
+
+omit [DecidableEq F] in
+theorem kw_velu2_quotNegY_sub_factored (hgy : W.veluGy x₀ y₀ = 0)
+    {x : F} (y : F) (hx : x ≠ x₀) :
+    (x - x₀) ^ 2
+        * (W.velu2Y x₀ y₀ x y
+            - (W.veluQuotient2 x₀ y₀).toAffine.negY (W.velu2X x₀ y₀ x) (W.velu2Y x₀ y₀ x y))
+      = (y - W.toAffine.negY x y) * ((x - x₀) ^ 2 - W.veluGx x₀ y₀) := by
+  have hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0 := by
+    have h := hgy; rw [veluGy, neg_eq_zero] at h; exact h
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  simp only [velu2X, velu2Y, Affine.negY, veluQuotient2_a₁, veluQuotient2_a₃, veluGx]
+  field_simp
+  linear_combination (3 * x₀ ^ 2 + 2 * W.a₂ * x₀ + W.a₄ - W.a₁ * y₀) * hord
+
+variable (hgy : W.veluGy x₀ y₀ = 0) (hQns : W.toAffine.Nonsingular x₀ y₀)
+
+include hgy hQns in
+theorem kw_velu2X_ne_of_diffAvoid
+    {x₁ y₁ x₂ y₂ : F} (h₁ : W.toAffine.Nonsingular x₁ y₁) (h₂ : W.toAffine.Nonsingular x₂ y₂)
+    (hx12 : x₁ ≠ x₂) (hx₁ : x₁ ≠ x₀) (hx₂ : x₂ ≠ x₀)
+    (hsp : W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) ≠ x₀)
+    (hsm : W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ (W.toAffine.negY x₂ y₂)) ≠ x₀) :
+    W.velu2X x₀ y₀ x₁ ≠ W.velu2X x₀ y₀ x₂ := by
+  intro hXeq
+  have hd₁ : x₁ - x₀ ≠ 0 := sub_ne_zero.mpr hx₁
+  have hfib : (x₁ - x₀) * (x₂ - x₀) = W.veluGx x₀ y₀ :=
+    ((kw_velu2X_eq_iff hx₁ hx₂).mp hXeq).resolve_left hx12
+  have hx₂eq : x₂ = W.toAffine.addX x₁ x₀ (W.toAffine.slope x₁ x₀ y₁ y₀) := by
+    rw [kw_velu2_addX_kernel h₁.1 hQns.1 hgy hx₁]
+    field_simp
+    linear_combination hfib
+  have hnsA : W.toAffine.Nonsingular
+      (W.toAffine.addX x₁ x₀ (W.toAffine.slope x₁ x₀ y₁ y₀))
+      (W.toAffine.addY x₁ x₀ y₁ (W.toAffine.slope x₁ x₀ y₁ y₀)) :=
+    Affine.nonsingular_add h₁ hQns fun hxy => hx₁ hxy.1
+  have hP1P0 : (Affine.Point.some x₁ y₁ h₁ : W.toAffine.Point) + Affine.Point.some x₀ y₀ hQns
+      = Affine.Point.some _ _ hnsA :=
+    Affine.Point.add_of_X_ne hx₁
+  have hnegP₀ : -(Affine.Point.some x₀ y₀ hQns : W.toAffine.Point) = .some x₀ y₀ hQns := by
+    rw [Affine.Point.neg_some]
+    exact kw_v2ker_some_congr rfl (negY_eq_of_veluGy_eq_zero hgy)
+  rcases (Affine.Point.X_eq_iff (h₁ := h₂) (h₂ := hnsA)).mp hx₂eq with hPeq | hPeq
+  · refine hsm ?_
+    have hdiff : (Affine.Point.some x₁ y₁ h₁ : W.toAffine.Point) - Affine.Point.some x₂ y₂ h₂
+        = Affine.Point.some x₀ y₀ hQns := by
+      rw [hPeq, ← hP1P0, sub_add_cancel_left, hnegP₀]
+    rw [sub_eq_add_neg, Affine.Point.neg_some, Affine.Point.add_of_X_ne hx12,
+      Affine.Point.some.injEq] at hdiff
+    exact hdiff.1
+  · refine hsp ?_
+    have hsum : (Affine.Point.some x₁ y₁ h₁ : W.toAffine.Point) + Affine.Point.some x₂ y₂ h₂
+        = Affine.Point.some x₀ y₀ hQns := by
+      rw [hPeq, ← hP1P0, ← sub_eq_add_neg, sub_add_cancel_left, hnegP₀]
+    rw [Affine.Point.add_of_X_ne hx12, Affine.Point.some.injEq] at hsum
+    exact hsum.1
+
+include hgy hQns in
+theorem kw_velu2Y_ne_quotNegY_of_tangent
+    {x y : F} (h : W.toAffine.Nonsingular x y) (hy : y ≠ W.toAffine.negY x y) (hx : x ≠ x₀)
+    (hx2 : W.toAffine.addX x x (W.toAffine.slope x x y y) ≠ x₀) :
+    W.velu2Y x₀ y₀ x y
+      ≠ (W.veluQuotient2 x₀ y₀).toAffine.negY (W.velu2X x₀ y₀ x) (W.velu2Y x₀ y₀ x y) := by
+  intro hcon
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  have hfact : (y - W.toAffine.negY x y) * ((x - x₀) ^ 2 - W.veluGx x₀ y₀) = 0 := by
+    have h0 := kw_velu2_quotNegY_sub_factored hgy y hx
+    rw [sub_eq_zero.mpr hcon, mul_zero] at h0
+    exact h0.symm
+  have hd2t : (x - x₀) ^ 2 = W.veluGx x₀ y₀ :=
+    sub_eq_zero.mp ((mul_eq_zero.mp hfact).resolve_left (sub_ne_zero.mpr hy))
+  have hxPP₀ : W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y y₀) = x := by
+    rw [kw_velu2_addX_kernel h.1 hQns.1 hgy hx, ← hd2t]
+    field_simp
+    ring
+  have hnsA : W.toAffine.Nonsingular
+      (W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y y₀))
+      (W.toAffine.addY x x₀ y (W.toAffine.slope x x₀ y y₀)) :=
+    Affine.nonsingular_add h hQns fun hxy => hx hxy.1
+  have hPP₀ : (Affine.Point.some x y h : W.toAffine.Point) + Affine.Point.some x₀ y₀ hQns
+      = Affine.Point.some _ _ hnsA :=
+    Affine.Point.add_of_X_ne hx
+  have hnegP₀ : -(Affine.Point.some x₀ y₀ hQns : W.toAffine.Point) = .some x₀ y₀ hQns := by
+    rw [Affine.Point.neg_some]
+    exact kw_v2ker_some_congr rfl (negY_eq_of_veluGy_eq_zero hgy)
+  rcases (Affine.Point.X_eq_iff (h₁ := hnsA) (h₂ := h)).mp hxPP₀ with hPeq | hPeq
+  · rw [← hPP₀, add_eq_left] at hPeq
+    exact Affine.Point.some_ne_zero hQns hPeq
+  · refine hx2 ?_
+    have h2P : (Affine.Point.some x y h : W.toAffine.Point) + Affine.Point.some x y h
+        = Affine.Point.some x₀ y₀ hQns := by
+      have heq := hPP₀.trans hPeq
+      rw [← hnegP₀, eq_neg_iff_add_eq_zero, add_right_comm, heq, neg_add_cancel]
+    rw [Affine.Point.add_self_of_Y_ne hy, Affine.Point.some.injEq] at h2P
+    exact h2P.1
+
+end Field
+
+end WeierstrassCurve
+end Piece_KwVeluOrderTwoSecantConjunctOne
+
+section Piece_KwVeluOrderTwoSecantAlign
+open Polynomial WeierstrassCurve.Affine WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+
+section Field
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F}
+  {x₀ y₀ x₁ y₁ x₂ y₂ : F}
+
+theorem kw_velu2_secX_align (hP₁ : W.toAffine.Equation x₁ y₁)
+    (hP₂ : W.toAffine.Equation x₂ y₂) (hQ : W.toAffine.Equation x₀ y₀)
+    (hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0) (hx12 : x₁ ≠ x₂) (hx₁ : x₁ ≠ x₀) (hx₂ : x₂ ≠ x₀)
+    (hsp : W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) ≠ x₀)
+    (hX12 : W.velu2X x₀ y₀ x₁ ≠ W.velu2X x₀ y₀ x₂) :
+    W.velu2X x₀ y₀ (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂))
+      = (W.veluQuotient2 x₀ y₀).toAffine.addX (W.velu2X x₀ y₀ x₁) (W.velu2X x₀ y₀ x₂)
+          ((W.veluQuotient2 x₀ y₀).toAffine.slope (W.velu2X x₀ y₀ x₁) (W.velu2X x₀ y₀ x₂)
+            (W.velu2Y x₀ y₀ x₁ y₁) (W.velu2Y x₀ y₀ x₂ y₂)) :=
+  (_root_.WeierstrassCurve.velu2_secant_align_factored
+    hP₁ hP₂ hQ hord hx12 hx₁ hx₂ hsp hX12).1
+
+theorem kw_velu2_secY_negAddY_align (hP₁ : W.toAffine.Equation x₁ y₁)
+    (hP₂ : W.toAffine.Equation x₂ y₂) (hQ : W.toAffine.Equation x₀ y₀)
+    (hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0) (hx12 : x₁ ≠ x₂) (hx₁ : x₁ ≠ x₀) (hx₂ : x₂ ≠ x₀)
+    (hsp : W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) ≠ x₀)
+    (hX12 : W.velu2X x₀ y₀ x₁ ≠ W.velu2X x₀ y₀ x₂) :
+    W.velu2Y x₀ y₀ (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂))
+        (W.toAffine.negAddY x₁ x₂ y₁ (W.toAffine.slope x₁ x₂ y₁ y₂))
+      = (W.veluQuotient2 x₀ y₀).toAffine.negAddY (W.velu2X x₀ y₀ x₁) (W.velu2X x₀ y₀ x₂)
+          (W.velu2Y x₀ y₀ x₁ y₁)
+          ((W.veluQuotient2 x₀ y₀).toAffine.slope (W.velu2X x₀ y₀ x₁) (W.velu2X x₀ y₀ x₂)
+            (W.velu2Y x₀ y₀ x₁ y₁) (W.velu2Y x₀ y₀ x₂ y₂)) :=
+  (_root_.WeierstrassCurve.velu2_secant_align_factored
+    hP₁ hP₂ hQ hord hx12 hx₁ hx₂ hsp hX12).2
+
+theorem kw_velu2_secY_align (hP₁ : W.toAffine.Equation x₁ y₁)
+    (hP₂ : W.toAffine.Equation x₂ y₂) (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hx12 : x₁ ≠ x₂) (hx₁ : x₁ ≠ x₀) (hx₂ : x₂ ≠ x₀)
+    (hsp : W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) ≠ x₀)
+    (hX12 : W.velu2X x₀ y₀ x₁ ≠ W.velu2X x₀ y₀ x₂) :
+    W.velu2Y x₀ y₀ (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂))
+        (W.toAffine.addY x₁ x₂ y₁ (W.toAffine.slope x₁ x₂ y₁ y₂))
+      = (W.veluQuotient2 x₀ y₀).toAffine.addY (W.velu2X x₀ y₀ x₁) (W.velu2X x₀ y₀ x₂)
+          (W.velu2Y x₀ y₀ x₁ y₁)
+          ((W.veluQuotient2 x₀ y₀).toAffine.slope (W.velu2X x₀ y₀ x₁) (W.velu2X x₀ y₀ x₂)
+            (W.velu2Y x₀ y₀ x₁ y₁) (W.velu2Y x₀ y₀ x₂ y₂)) := by
+  have hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0 := by
+    have h := hgy; rw [veluGy, neg_eq_zero] at h; exact h
+  have hXalign := kw_velu2_secX_align hP₁ hP₂ hQ hord hx12 hx₁ hx₂ hsp hX12
+  have hnAY := kw_velu2_secY_negAddY_align hP₁ hP₂ hQ hord hx12 hx₁ hx₂ hsp hX12
+  rw [Affine.addY, kw_velu2Y_negY hgy, Affine.addY, hXalign, hnAY]
+
+end Field
+
+end WeierstrassCurve
+end Piece_KwVeluOrderTwoSecantAlign
+
+section Piece_KwVeluOrderTwoTangentXAlign
+open Polynomial WeierstrassCurve.Affine WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+
+section Field
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F} {x₀ y₀ x y : F}
+
+theorem kw_velu2_tanX_align (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hy : y ≠ W.toAffine.negY x y) (hx : x ≠ x₀)
+    (hx2 : W.toAffine.addX x x (W.toAffine.slope x x y y) ≠ x₀)
+    (hY : W.velu2Y x₀ y₀ x y
+      ≠ (W.veluQuotient2 x₀ y₀).toAffine.negY (W.velu2X x₀ y₀ x) (W.velu2Y x₀ y₀ x y)) :
+    W.velu2X x₀ y₀ (W.toAffine.addX x x (W.toAffine.slope x x y y))
+      = (W.veluQuotient2 x₀ y₀).toAffine.addX (W.velu2X x₀ y₀ x) (W.velu2X x₀ y₀ x)
+          ((W.veluQuotient2 x₀ y₀).toAffine.slope (W.velu2X x₀ y₀ x) (W.velu2X x₀ y₀ x)
+            (W.velu2Y x₀ y₀ x y) (W.velu2Y x₀ y₀ x y)) :=
+  (_root_.WeierstrassCurve.velu2_tangent_align_factored hP hQ hgy hy hx hx2 hY).1
+
+end Field
+
+end WeierstrassCurve
+end Piece_KwVeluOrderTwoTangentXAlign
+
+section Piece_KwVeluOrderTwoTangentYAlign
+open Polynomial WeierstrassCurve.Affine WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+
+section Field
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F} {x₀ y₀ x y : F}
+
+theorem kw_velu2_tanY_negAddY_align (hP : W.toAffine.Equation x y)
+    (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0)
+    (hy : y ≠ W.toAffine.negY x y) (hx : x ≠ x₀)
+    (hx2 : W.toAffine.addX x x (W.toAffine.slope x x y y) ≠ x₀)
+    (hY : W.velu2Y x₀ y₀ x y
+      ≠ (W.veluQuotient2 x₀ y₀).toAffine.negY (W.velu2X x₀ y₀ x) (W.velu2Y x₀ y₀ x y)) :
+    W.velu2Y x₀ y₀ (W.toAffine.addX x x (W.toAffine.slope x x y y))
+        (W.toAffine.negAddY x x y (W.toAffine.slope x x y y))
+      = (W.veluQuotient2 x₀ y₀).toAffine.negAddY (W.velu2X x₀ y₀ x) (W.velu2X x₀ y₀ x)
+          (W.velu2Y x₀ y₀ x y)
+          ((W.veluQuotient2 x₀ y₀).toAffine.slope (W.velu2X x₀ y₀ x) (W.velu2X x₀ y₀ x)
+            (W.velu2Y x₀ y₀ x y) (W.velu2Y x₀ y₀ x y)) :=
+  (_root_.WeierstrassCurve.velu2_tangent_align_factored hP hQ hgy hy hx hx2 hY).2
+
+theorem kw_velu2_tanY_align (hP : W.toAffine.Equation x y)
+    (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0)
+    (hy : y ≠ W.toAffine.negY x y) (hx : x ≠ x₀)
+    (hx2 : W.toAffine.addX x x (W.toAffine.slope x x y y) ≠ x₀)
+    (hY : W.velu2Y x₀ y₀ x y
+      ≠ (W.veluQuotient2 x₀ y₀).toAffine.negY (W.velu2X x₀ y₀ x) (W.velu2Y x₀ y₀ x y)) :
+    W.velu2Y x₀ y₀ (W.toAffine.addX x x (W.toAffine.slope x x y y))
+        (W.toAffine.addY x x y (W.toAffine.slope x x y y))
+      = (W.veluQuotient2 x₀ y₀).toAffine.addY (W.velu2X x₀ y₀ x) (W.velu2X x₀ y₀ x)
+          (W.velu2Y x₀ y₀ x y)
+          ((W.veluQuotient2 x₀ y₀).toAffine.slope (W.velu2X x₀ y₀ x) (W.velu2X x₀ y₀ x)
+            (W.velu2Y x₀ y₀ x y) (W.velu2Y x₀ y₀ x y)) := by
+  have hXalign := kw_velu2_tanX_align hP hQ hgy hy hx hx2 hY
+  have hnAY := kw_velu2_tanY_negAddY_align hP hQ hgy hy hx hx2 hY
+  rw [Affine.addY, kw_velu2Y_negY hgy, Affine.addY, hXalign, hnAY]
+
+end Field
+
+end WeierstrassCurve
+end Piece_KwVeluOrderTwoTangentYAlign
+
+section PieceAbbrev
+
+namespace WeierstrassCurve
+
+section Held
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F} {x₀ y₀ : F}
+
+variable (W x₀ y₀) in
+private abbrev _root_.WeierstrassCurve.KwVeluOrderTwoAddCompatAt (h2 : (2 : F) ≠ 0)
+    (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hΔ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0) : Prop :=
+  ∀ P Q : W.toAffine.Point,
+    veluPointMap2 h2 hQ hgy hΔ (P + Q) = veluPointMap2 h2 hQ hgy hΔ P + veluPointMap2 h2 hQ hgy hΔ Q
+
+end Held
+
+end WeierstrassCurve
+
+end PieceAbbrev
+
+section Piece_KwVeluOrderTwoAddCompatReduce
+open Polynomial WeierstrassCurve.Affine WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+
+section Field
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F} {x₀ y₀ : F}
+
+omit [DecidableEq F] in
+theorem kw_velu2_kernel_nonsingular (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hΔ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0) :
+    W.toAffine.Nonsingular x₀ y₀ := by
+  have ht : W.veluGx x₀ y₀ ≠ 0 := kw_veluGx_ne_zero_of_quotΔ hQ hgy hΔ
+  simp only [veluGx] at ht
+  refine (Affine.nonsingular_iff ..).mpr ⟨hQ, Or.inl fun hcon => ht ?_⟩
+  linear_combination -hcon
+
+variable (hchar : (2 : F) ≠ 0) (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0)
+  (hΔ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0)
+
+include hchar hQ hgy hΔ in
+theorem kw_veluPointMap2_add_of_right_ker {K : W.toAffine.Point}
+    (hK : veluPointMap2 hchar hQ hgy hΔ K = 0) (P : W.toAffine.Point) :
+    veluPointMap2 hchar hQ hgy hΔ (P + K) = veluPointMap2 hchar hQ hgy hΔ P := by
+  have hQns : W.toAffine.Nonsingular x₀ y₀ := kw_velu2_kernel_nonsingular hQ hgy hΔ
+  cases K with
+  | zero => rw [← Affine.Point.zero_def, add_zero]
+  | some x y h =>
+    by_cases hx : x = x₀
+    · rw [Affine.Point.some_eq_of_X_eq_of_veluGy_eq_zero hQ hgy hQns h hx]
+      exact kw_veluPointMap2_add_kernel_gen hchar hQ hgy hΔ hQns P
+    · rw [veluPointMap2_some_of_ne hchar hQ hgy hΔ h hx] at hK
+      exact absurd hK (Affine.Point.some_ne_zero _)
+
+include hchar hQ hgy hΔ in
+theorem kw_veluPointMap2_add_self (htan : W.KwVeluOrderTwoTangentCompatAt x₀ y₀)
+    (P : W.toAffine.Point) :
+    veluPointMap2 hchar hQ hgy hΔ (P + P)
+      = veluPointMap2 hchar hQ hgy hΔ P + veluPointMap2 hchar hQ hgy hΔ P := by
+  have hQns : W.toAffine.Nonsingular x₀ y₀ := kw_velu2_kernel_nonsingular hQ hgy hΔ
+  cases P with
+  | zero =>
+    rw [← Affine.Point.zero_def, add_zero, Affine.Point.zero_def, veluPointMap2_zero,
+      ← Affine.Point.zero_def, add_zero]
+  | some x y h =>
+    by_cases hy : y = W.toAffine.negY x y
+    · have hPnP : (Affine.Point.some x y h : W.toAffine.Point) = -Affine.Point.some x y h := by
+        rw [Affine.Point.neg_some]; exact kw_v2ker_some_congr rfl hy
+      have h2P0 : (Affine.Point.some x y h : W.toAffine.Point) + .some x y h = 0 := by
+        nth_rw 1 [hPnP]; exact neg_add_cancel _
+      have h2φP : veluPointMap2 hchar hQ hgy hΔ (.some x y h)
+          + veluPointMap2 hchar hQ hgy hΔ (.some x y h) = 0 := by
+        nth_rw 1 [hPnP, kw_veluPointMap2_neg hchar hQ hgy hΔ]; exact neg_add_cancel _
+      rw [h2P0, Affine.Point.zero_def, veluPointMap2_zero]
+      exact h2φP.symm
+    · have hx : x ≠ x₀ := by
+        intro hcon
+        have hPP₀ : (Affine.Point.some x y h : W.toAffine.Point)
+            = Affine.Point.some x₀ y₀ hQns :=
+          Affine.Point.some_eq_of_X_eq_of_veluGy_eq_zero hQ hgy hQns h hcon
+        rw [Affine.Point.some.injEq] at hPP₀
+        exact hy (hcon ▸ hPP₀.2 ▸ (negY_eq_of_veluGy_eq_zero hgy).symm)
+      by_cases hx2 : W.toAffine.addX x x (W.toAffine.slope x x y y) = x₀
+      · have hnsA : W.toAffine.Nonsingular
+            (W.toAffine.addX x x (W.toAffine.slope x x y y))
+            (W.toAffine.addY x x y (W.toAffine.slope x x y y)) :=
+          Affine.nonsingular_add h h fun hxy => hy hxy.2
+        have h2P : (Affine.Point.some x y h : W.toAffine.Point) + Affine.Point.some x y h
+            = Affine.Point.some x₀ y₀ hQns := by
+          rw [Affine.Point.add_self_of_Y_ne hy]
+          exact Affine.Point.some_eq_of_X_eq_of_veluGy_eq_zero hQ hgy hQns hnsA hx2
+        have hφ2P : veluPointMap2 hchar hQ hgy hΔ
+            ((Affine.Point.some x y h : W.toAffine.Point) + Affine.Point.some x y h) = 0 := by
+          rw [h2P]; exact veluPointMap2_some_of_eq hchar hQ hgy hΔ hQns rfl
+        have hnegP₀ : -(Affine.Point.some x₀ y₀ hQns : W.toAffine.Point) = .some x₀ y₀ hQns := by
+          rw [Affine.Point.neg_some]
+          exact kw_v2ker_some_congr rfl (negY_eq_of_veluGy_eq_zero hgy)
+        have hnegP : -(Affine.Point.some x y h : W.toAffine.Point)
+            = Affine.Point.some x y h + Affine.Point.some x₀ y₀ hQns := by
+          rw [← hnegP₀, ← sub_eq_add_neg, ← h2P]; abel
+        have h2φP : veluPointMap2 hchar hQ hgy hΔ (.some x y h)
+            + veluPointMap2 hchar hQ hgy hΔ (.some x y h) = 0 :=
+          add_eq_zero_iff_eq_neg.mpr <| by
+            rw [← kw_veluPointMap2_neg hchar hQ hgy hΔ, hnegP,
+              kw_veluPointMap2_add_kernel_gen hchar hQ hgy hΔ hQns]
+        rw [hφ2P, h2φP]
+      · exact kw_veluPointMap2_add_self_of_tangent hchar hQ hgy hΔ htan h hy hx hx2
+
+include hchar hQ hgy hΔ in
+theorem kw_veluPointMap2_add' (hsec : W.KwVeluOrderTwoSecantCompatDiffAvoidAt x₀ y₀)
+    (htan : W.KwVeluOrderTwoTangentCompatAt x₀ y₀) (P₁ P₂ : W.toAffine.Point) :
+    veluPointMap2 hchar hQ hgy hΔ (P₁ + P₂)
+      = veluPointMap2 hchar hQ hgy hΔ P₁ + veluPointMap2 hchar hQ hgy hΔ P₂ := by
+  have hQns : W.toAffine.Nonsingular x₀ y₀ := kw_velu2_kernel_nonsingular hQ hgy hΔ
+  cases P₁ with
+  | zero =>
+    rw [← Affine.Point.zero_def, zero_add, Affine.Point.zero_def, veluPointMap2_zero,
+      ← Affine.Point.zero_def, zero_add]
+  | some x₁ y₁ h₁ =>
+    cases P₂ with
+    | zero =>
+      rw [← Affine.Point.zero_def, add_zero, Affine.Point.zero_def, veluPointMap2_zero,
+        ← Affine.Point.zero_def, add_zero]
+    | some x₂ y₂ h₂ =>
+      by_cases hx₂k : x₂ = x₀
+      · have hK : veluPointMap2 hchar hQ hgy hΔ (Affine.Point.some x₂ y₂ h₂) = 0 :=
+          veluPointMap2_some_of_eq hchar hQ hgy hΔ h₂ hx₂k
+        rw [kw_veluPointMap2_add_of_right_ker hchar hQ hgy hΔ hK, hK, add_zero]
+      by_cases hx₁k : x₁ = x₀
+      · have hK : veluPointMap2 hchar hQ hgy hΔ (Affine.Point.some x₁ y₁ h₁) = 0 :=
+          veluPointMap2_some_of_eq hchar hQ hgy hΔ h₁ hx₁k
+        rw [add_comm, kw_veluPointMap2_add_of_right_ker hchar hQ hgy hΔ hK, hK, zero_add]
+      by_cases hx12 : x₁ = x₂
+      · rcases (Affine.Point.X_eq_iff (h₁ := h₂) (h₂ := h₁)).mp hx12.symm with hPeq | hPeq
+        · rw [hPeq]; exact kw_veluPointMap2_add_self hchar hQ hgy hΔ htan _
+        · rw [hPeq, add_neg_cancel, Affine.Point.zero_def, veluPointMap2_zero,
+            ← Affine.Point.zero_def, kw_veluPointMap2_neg hchar hQ hgy hΔ, add_neg_cancel]
+      by_cases hsp : W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) = x₀
+      · have hAns : W.toAffine.Nonsingular
+            (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂))
+            (W.toAffine.addY x₁ x₂ y₁ (W.toAffine.slope x₁ x₂ y₁ y₂)) :=
+          Affine.nonsingular_add h₁ h₂ fun hxy => hx12 hxy.1
+        have hK0 : veluPointMap2 hchar hQ hgy hΔ
+            ((Affine.Point.some x₁ y₁ h₁ : W.toAffine.Point) + .some x₂ y₂ h₂) = 0 := by
+          rw [Affine.Point.add_of_X_ne hx12]
+          exact veluPointMap2_some_of_eq hchar hQ hgy hΔ hAns hsp
+        have hφ1 : veluPointMap2 hchar hQ hgy hΔ (.some x₁ y₁ h₁)
+            = -(veluPointMap2 hchar hQ hgy hΔ (.some x₂ y₂ h₂)) := by
+          have heq : (Affine.Point.some x₁ y₁ h₁ : W.toAffine.Point)
+              = -(.some x₂ y₂ h₂)
+                + ((Affine.Point.some x₁ y₁ h₁ : W.toAffine.Point) + .some x₂ y₂ h₂) := by abel
+          rw [heq, kw_veluPointMap2_add_of_right_ker hchar hQ hgy hΔ hK0,
+            kw_veluPointMap2_neg hchar hQ hgy hΔ]
+        rw [hK0, hφ1, neg_add_cancel]
+      by_cases hsm : W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ (W.toAffine.negY x₂ y₂))
+          = x₀
+      · have h₂' : W.toAffine.Nonsingular x₂ (W.toAffine.negY x₂ y₂) :=
+          (Affine.nonsingular_neg ..).mpr h₂
+        have hDns : W.toAffine.Nonsingular
+            (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ (W.toAffine.negY x₂ y₂)))
+            (W.toAffine.addY x₁ x₂ y₁ (W.toAffine.slope x₁ x₂ y₁ (W.toAffine.negY x₂ y₂))) :=
+          Affine.nonsingular_add h₁ h₂' fun hxy => hx12 hxy.1
+        have hKD : veluPointMap2 hchar hQ hgy hΔ
+            ((Affine.Point.some x₁ y₁ h₁ : W.toAffine.Point) - .some x₂ y₂ h₂) = 0 := by
+          rw [sub_eq_add_neg, Affine.Point.neg_some, Affine.Point.add_of_X_ne hx12]
+          exact veluPointMap2_some_of_eq hchar hQ hgy hΔ hDns hsm
+        have hφeq : veluPointMap2 hchar hQ hgy hΔ (.some x₁ y₁ h₁)
+            = veluPointMap2 hchar hQ hgy hΔ (.some x₂ y₂ h₂) := by
+          have heq : (Affine.Point.some x₁ y₁ h₁ : W.toAffine.Point)
+              = (Affine.Point.some x₂ y₂ h₂ : W.toAffine.Point)
+                + ((Affine.Point.some x₁ y₁ h₁ : W.toAffine.Point) - .some x₂ y₂ h₂) := by abel
+          rw [heq, kw_veluPointMap2_add_of_right_ker hchar hQ hgy hΔ hKD]
+        have heq2 : (Affine.Point.some x₁ y₁ h₁ : W.toAffine.Point) + .some x₂ y₂ h₂
+            = ((Affine.Point.some x₂ y₂ h₂ : W.toAffine.Point) + .some x₂ y₂ h₂)
+              + ((Affine.Point.some x₁ y₁ h₁ : W.toAffine.Point) - .some x₂ y₂ h₂) := by abel
+        rw [heq2, kw_veluPointMap2_add_of_right_ker hchar hQ hgy hΔ hKD,
+          kw_veluPointMap2_add_self hchar hQ hgy hΔ htan, hφeq]
+      exact kw_veluPointMap2_add_of_secant_diffAvoid hchar hQ hgy hΔ hsec h₁ h₂ hx12 hx₁k
+        hx₂k hsp hsm
+
+include hchar hQ hgy hΔ in
+theorem kw_veluOrderTwoAddCompatAt_of_carriers
+    (hsec : W.KwVeluOrderTwoSecantCompatDiffAvoidAt x₀ y₀)
+    (htan : W.KwVeluOrderTwoTangentCompatAt x₀ y₀) :
+    W.KwVeluOrderTwoAddCompatAt x₀ y₀ hchar hQ hgy hΔ :=
+  kw_veluPointMap2_add' hchar hQ hgy hΔ hsec htan
+
+end Field
+
+end WeierstrassCurve
+end Piece_KwVeluOrderTwoAddCompatReduce
+
+section Piece_KwVeluOrderTwoCarrierDischarge
+noncomputable section
+
+namespace WeierstrassCurve
+
+section Field
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F} (x₀ y₀ : F)
+
+private abbrev _root_.WeierstrassCurve.KwVeluOrderTwoTangentYAlignAt : Prop :=
+  ∀ ⦃x y : F⦄, W.toAffine.Equation x y → y ≠ W.toAffine.negY x y → x ≠ x₀ →
+    W.toAffine.addX x x (W.toAffine.slope x x y y) ≠ x₀ →
+    W.velu2Y x₀ y₀ x y
+      ≠ (W.veluQuotient2 x₀ y₀).toAffine.negY (W.velu2X x₀ y₀ x) (W.velu2Y x₀ y₀ x y) →
+    W.velu2Y x₀ y₀ (W.toAffine.addX x x (W.toAffine.slope x x y y))
+        (W.toAffine.addY x x y (W.toAffine.slope x x y y))
+      = (W.veluQuotient2 x₀ y₀).toAffine.addY
+          (W.velu2X x₀ y₀ x) (W.velu2X x₀ y₀ x) (W.velu2Y x₀ y₀ x y)
+          ((W.veluQuotient2 x₀ y₀).toAffine.slope (W.velu2X x₀ y₀ x) (W.velu2X x₀ y₀ x)
+            (W.velu2Y x₀ y₀ x y) (W.velu2Y x₀ y₀ x y))
+
+variable {x₀ y₀}
+variable [W.IsElliptic]
+variable (hgy : W.veluGy x₀ y₀ = 0) (hQns : W.toAffine.Nonsingular x₀ y₀)
+
+include hgy hQns in
+theorem kw_velu2_tangentCarrier_of_YAlign
+    (hYal : W.KwVeluOrderTwoTangentYAlignAt x₀ y₀) :
+    W.KwVeluOrderTwoTangentCompatAt x₀ y₀ := by
+  intro x y hP hy hx hx2
+  have hns := (Affine.equation_iff_nonsingular (W := W.toAffine)).mp hP
+  have hY := kw_velu2Y_ne_quotNegY_of_tangent hgy hQns hns hy hx hx2
+  exact ⟨hY, kw_velu2_tanX_align hP hQns.1 hgy hy hx hx2 hY, hYal hP hy hx hx2 hY⟩
+
+include hgy hQns in
+theorem kw_velu2_secantCarrier :
+    W.KwVeluOrderTwoSecantCompatDiffAvoidAt x₀ y₀ := by
+  intro x₁ y₁ x₂ y₂ h₁ h₂ hx12 hx₁ hx₂ hsp hsm
+  have hns₁ := (Affine.equation_iff_nonsingular (W := W.toAffine)).mp h₁
+  have hns₂ := (Affine.equation_iff_nonsingular (W := W.toAffine)).mp h₂
+  have hX12 := kw_velu2X_ne_of_diffAvoid hgy hQns hns₁ hns₂ hx12 hx₁ hx₂ hsp hsm
+  have hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0 := by
+    have h := hgy; rw [veluGy, neg_eq_zero] at h; exact h
+  exact ⟨hX12,
+    kw_velu2_secX_align h₁ h₂ hQns.1 hord hx12 hx₁ hx₂ hsp hX12,
+    kw_velu2_secY_align h₁ h₂ hQns.1 hgy hx12 hx₁ hx₂ hsp hX12⟩
+
+include hgy hQns in
+theorem kw_velu2_addCompatAt_of_YAlign
+    (hchar : (2 : F) ≠ 0) (hΔ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0)
+    (hYal : W.KwVeluOrderTwoTangentYAlignAt x₀ y₀) :
+    W.KwVeluOrderTwoAddCompatAt x₀ y₀ hchar hQns.1 hgy hΔ := by
+  exact kw_veluOrderTwoAddCompatAt_of_carriers hchar hQns.1 hgy hΔ
+    (kw_velu2_secantCarrier hgy hQns)
+    (kw_velu2_tangentCarrier_of_YAlign hgy hQns hYal)
+
+end Field
+
+end WeierstrassCurve
+
+end
+end Piece_KwVeluOrderTwoCarrierDischarge
+
+open WeierstrassCurve WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine
+
+theorem solution
+    {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F) [W.IsElliptic]
+    (h2 : (2 : F) ≠ 0) {x₀ y₀ : F} (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hΔ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0) :
+    ∃ φ : W.toAffine.Point →+ (W.veluQuotient2 x₀ y₀).toAffine.Point,
+      ⇑φ = veluPointMap2 h2 hQ hgy hΔ := by
+  have hQns : W.toAffine.Nonsingular x₀ y₀ := W.toAffine.equation_iff_nonsingular.mp hQ
+  have hadd : W.KwVeluOrderTwoAddCompatAt x₀ y₀ h2 hQns.1 hgy hΔ :=
+    kw_velu2_addCompatAt_of_YAlign hgy hQns h2 hΔ
+      (fun _ _ hP hy hx hx2 hY => kw_velu2_tanY_align hP hQns.1 hgy hy hx hx2 hY)
+  exact ⟨AddMonoidHom.mk' (veluPointMap2 h2 hQ hgy hΔ) hadd, rfl⟩
+
+end privateSection
+
+public section publicSection
+
+
+open Polynomial WeierstrassCurve WeierstrassCurve.Affine
+theorem WeierstrassCurve.exists_addMonoidHom_coe_eq_veluPointMap2
+    {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F) [W.IsElliptic]
+    (h2 : (2 : F) ≠ 0) {x₀ y₀ : F} (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hΔ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0) :
+    ∃ φ : W.toAffine.Point →+ (W.veluQuotient2 x₀ y₀).toAffine.Point,
+      ⇑φ = veluPointMap2 h2 hQ hgy hΔ :=
+  solution W h2 hQ hgy hΔ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_pow_three_eq_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_pow_three_eq_one.lean
new file mode 100644
index 0000000000..392ef507ef
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_pow_three_eq_one.lean
@@ -0,0 +1,507 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_pow_three_eq_one
+(1a187efa-9dc1-57d8-ba71-f8f1e74fdca7) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f4370572-27f3-59de-871f-c9720a93199f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VariableChangePointEquiv
+
+import Mathlib.Algebra.CharP.Invertible
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+import Mathlib.AlgebraicGeometry.EllipticCurve.Reduction
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_smul_some_eq_zero_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_zsmul_some_eq_some_div
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_evalEval_psi_sq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_addEquiv_point_variableChange
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_nonempty_torsionBy_addEquiv_zmod_prod_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_variableChange_mk_smul_eq_self_of_pow_three_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsion_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# [ω] acts non-scalarly on p-torsion of y²=x³+B
+
+Theorem statement: `WeierstrassCurve.exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_pow_three_eq_one`
+(`1a187efa-9dc1-57d8-ba71-f8f1e74fdca7`), by Claude, 2026-09-05.
+
+Proof: submission `f4370572-27f3-59de-871f-c9720a93199f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be an algebraically closed field equipped with a $\mathbb{Q}$-algebra structure (so of
+characteristic $0$), let $B \in L$ be nonzero, let $u$ be a unit of $L$ with $u^3 = 1$ and $u \neq
+1$ (a primitive cube root of unity), and let $p$ be a prime number. Write $W$ for the Weierstrass
+curve over $L$ with coefficients $a_1 = a_2 = a_3 = a_4 = 0$ and $a_6 = B$, i.e. $y^2 = x^3 + B$,
+and let $C$ be the variable change with $u$-component $u$ and $r = s = t = 0$. The assertion is that
+there is a point $T$ of the associated affine curve, i.e. either the point at infinity or a
+nonsingular affine solution, whose additive order `addOrderOf T` equals $p$, and such that for every
+natural number $k$ the point `vcInvFun C W.toAffine T` is not heterogeneously equal to $k \bullet
+T$. Here `vcInvFun C W.toAffine` sends the point at infinity to the point at infinity and an affine
+point $(x,y)$ to $\bigl((u^{-1})^2(x - r),\,(u^{-1})^3(y - t - s(x - r))\bigr) =
+(u^{-2}x,\,u^{-3}y)$, a point of the curve $C \bullet W$; heterogeneous equality is used because $C
+\bullet W$ is only propositionally, not definitionally, equal to $W$, so the two sides live in types
+that must first be identified.
+
+Since $u^3 = 1$, the displayed substitution is the automorphism $[\omega] \colon (x,y) \mapsto (ux,
+y)$ of the $j = 0$ curve $y^2 = x^3 + B$, and the statement says that $[\omega]$ does not act on the
+$p$-torsion $E_B[p]$ through multiplication by an integer, for any prime $p$: some point of exact
+order $p$ fails to be an eigenvector. It is used in the computation of the number of
+$[\omega]$-fixed lines in $E_B[p]$, which feeds the count of elliptic points of order $3$ governed
+by $\nu_3$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_pow_three_eq_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_pow_three_eq_one
+
+
+open WeierstrassCurve WeierstrassCurve.Affine Polynomial
+
+namespace P2MWs13
+namespace NonScalar
+
+variable {L : Type*} [Field L]
+
+def xco [DecidableEq L] {W : WeierstrassCurve L} : W.toAffine.Point → Option L
+  | 0 => none
+  | .some x _ _ => some x
+
+@[scoped simp] theorem xco_zero [DecidableEq L] {W : WeierstrassCurve L} :
+    xco (0 : W.toAffine.Point) = none := rfl
+@[scoped simp] theorem xco_some [DecidableEq L] {W : WeierstrassCurve L} {x y : L} (h :
+  W.toAffine.Nonsingular x y) :
+    xco (Point.some x y h) = some x := rfl
+
+theorem xco_neg [DecidableEq L] {W : WeierstrassCurve L} (P : W.toAffine.Point) :
+    xco (-P) = xco P := by
+  rcases P with _ | ⟨x, y, h⟩
+  · rfl
+  · rw [Point.neg_some]; rfl
+
+theorem eq_or_eq_neg_of_xco_eq [DecidableEq L] {W : WeierstrassCurve L} {P Q : W.toAffine.Point}
+    (hPQ : xco P = xco Q) :
+    P = Q ∨ P = -Q := by
+  rcases P with _ | ⟨x, y, h⟩ <;> rcases Q with _ | ⟨x', y', h'⟩
+  · exact Or.inl rfl
+  · simp [xco] at hPQ
+  · simp [xco] at hPQ
+  · simp only [xco_some, Option.some.injEq] at hPQ
+    subst hPQ
+    have hy : y = y' ∨ y = W.toAffine.negY x y' := by
+      have h1 := h.1; have h2 := h'.1
+      rw [WeierstrassCurve.Affine.equation_iff] at h1 h2
+      have : (y - y') * (y - W.toAffine.negY x y') = 0 := by
+        rw [WeierstrassCurve.Affine.negY]; linear_combination h1 - h2
+      rcases mul_eq_zero.mp this with h0 | h0
+      · exact Or.inl (sub_eq_zero.mp h0)
+      · exact Or.inr (sub_eq_zero.mp h0)
+    rcases hy with rfl | rfl
+    · exact Or.inl rfl
+    · right; rw [Point.neg_some]
+
+theorem xco_eq_of_heq [DecidableEq L] {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂)
+    {P : W₁.toAffine.Point} {Q : W₂.toAffine.Point}
+    (h : HEq P Q) : xco P = xco Q := by
+  subst e
+  rw [eq_of_heq h]
+
+def castPt [DecidableEq L] {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂) :
+    W₁.toAffine.Point ≃+ W₂.toAffine.Point := by
+  subst e; exact AddEquiv.refl _
+
+theorem xco_castPt [DecidableEq L] {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂)
+    (P : W₁.toAffine.Point) :
+    xco (castPt e P) = xco P := by
+  subst e; rfl
+
+theorem xco_vcInvFun [DecidableEq L] (u : Lˣ) (W : WeierstrassCurve L) (P : W.toAffine.Point) :
+    xco (Point.vcInvFun (⟨u, 0, 0, 0⟩ : VariableChange L) W.toAffine P) = (xco P).map (fun x =>
+      ((u⁻¹ : Lˣ) : L) ^ 2 * x) := by
+  rcases P with _ | ⟨x, y, h⟩
+  · rfl
+  · change some _ = some _
+    simp [WeierstrassCurve.Affine.vcXInv]
+
+section Scalar
+
+variable {V : Type*} [AddCommGroup V]
+
+theorem exists_common_scalar {p : ℕ} [Fact p.Prime] (e : ZMod p × ZMod p ≃+ V) (σ : V →+ V)
+    (heig : ∀ v : V, ∃ a : ℤ, σ v = a • v) : ∃ c : ℤ, ∀ v : V, σ v = c • v := by
+  obtain ⟨a, ha⟩ := heig (e (1, 0))
+  obtain ⟨b, hb⟩ := heig (e (0, 1))
+  obtain ⟨c, hc⟩ := heig (e (1, 1))
+  have hsum : e (1, 1) = e (1, 0) + e (0, 1) := by
+    rw [← map_add, Prod.mk_add_mk, add_zero, zero_add]
+  have key : c • e (1, 0) + c • e (0, 1) = a • e (1, 0) + b • e (0, 1) := by
+    rw [← smul_add, ← hsum, ← hc, hsum, map_add, ha, hb]
+  have key' : ((c : ZMod p), (c : ZMod p)) = ((a : ZMod p), (b : ZMod p)) := by
+    apply e.injective
+    have h1 : e ((c : ZMod p), (c : ZMod p)) = c • e (1, 0) + c • e (0, 1) := by
+      rw [← map_zsmul, ← map_zsmul, ← map_add]; congr 1; ext <;> simp
+    have h2 : e ((a : ZMod p), (b : ZMod p)) = a • e (1, 0) + b • e (0, 1) := by
+      rw [← map_zsmul, ← map_zsmul, ← map_add]; congr 1; ext <;> simp
+    rw [h1, h2, key]
+  have hca : (c : ZMod p) = a := congrArg Prod.fst key'
+  have hcb : (c : ZMod p) = b := congrArg Prod.snd key'
+  have hpV : ∀ v : V, (p : ℤ) • v = 0 := by
+    intro v
+    obtain ⟨w, rfl⟩ := e.surjective v
+    rw [← map_zsmul, show (p : ℤ) • w = 0 from ?_, map_zero]
+    ext <;> simp [zsmul_eq_mul]
+  have hzs : ∀ (m n : ℤ) (v : V), (m : ZMod p) = n → m • v = n • v := by
+    intro m n v hmn
+    obtain ⟨k, hk⟩ := (ZMod.intCast_eq_intCast_iff_dvd_sub n m p).mp hmn.symm
+    have : m = n + p * k := by linarith
+    rw [this, add_zsmul, mul_comm, mul_zsmul, hpV, zsmul_zero, add_zero]
+  refine ⟨c, fun v => ?_⟩
+  obtain ⟨⟨s, t⟩, rfl⟩ := e.surjective v
+  have hv : e (s, t) = (s.val : ℤ) • e (1, 0) + (t.val : ℤ) • e (0, 1) := by
+    rw [← map_zsmul, ← map_zsmul, ← map_add]; congr 1; ext <;> simp []
+  rw [hv, map_add, map_zsmul, map_zsmul, ha, hb, smul_add, smul_comm c (s.val : ℤ), smul_comm c
+    (t.val : ℤ),
+    hzs a c _ hca.symm, hzs b c _ hcb.symm]
+
+end Scalar
+
+section Degree
+
+variable (W : WeierstrassCurve L)
+
+theorem natDegree_Phi_sub_C_mul_X_mul_PsiSq_le (c : L) (m : ℕ) (hm : 1 ≤ m) :
+    (W.Φ (m : ℤ) - C c * X * W.ΨSq (m : ℤ)).natDegree ≤ m ^ 2 := by
+  have hm2 : 1 ≤ m ^ 2 := Nat.one_le_iff_ne_zero.mpr (pow_ne_zero 2 (by omega))
+  refine (natDegree_sub_le _ _).trans (max_le ?_ ?_)
+  · have hΦ := W.natDegree_Φ_le (m : ℤ)
+    simp only [Int.natAbs_natCast] at hΦ
+    exact hΦ
+  · refine (natDegree_mul_le).trans ?_
+    have hΨ := W.natDegree_ΨSq_le (m : ℤ)
+    simp only [Int.natAbs_natCast] at hΨ
+    have hCX : (C c * X : L[X]).natDegree ≤ 1 := (natDegree_C_mul_le _ _).trans natDegree_X_le
+    omega
+
+theorem Phi_sub_C_mul_X_mul_PsiSq_ne_zero (c : L) (m : ℕ) (hm : 1 ≤ m)
+    (hc : 1 - c * (m : L) ^ 2 ≠ 0) :
+    W.Φ (m : ℤ) - C c * X * W.ΨSq (m : ℤ) ≠ 0 := by
+  intro h0
+  have hcoef : (W.Φ (m : ℤ) - C c * X * W.ΨSq (m : ℤ)).coeff (m ^ 2) = 1 - c * (m : L) ^ 2 := by
+    rw [coeff_sub]
+    have h1 : (W.Φ (m : ℤ)).coeff (m ^ 2) = 1 := by
+      have := W.coeff_Φ (m : ℤ)
+      simp only [Int.natAbs_natCast] at this
+      exact this
+    have h2 : (C c * X * W.ΨSq (m : ℤ)).coeff (m ^ 2) = c * (m : L) ^ 2 := by
+      have hm2 : m ^ 2 = (m ^ 2 - 1) + 1 := by
+        have : 1 ≤ m ^ 2 := Nat.one_le_iff_ne_zero.mpr (pow_ne_zero 2 (by omega)); omega
+      rw [mul_assoc, coeff_C_mul, hm2, coeff_X_mul]
+      have := W.coeff_ΨSq (m : ℤ)
+      simp only [Int.natAbs_natCast] at this
+      rw [this]; push_cast; ring
+    rw [h1, h2]
+  rw [h0, coeff_zero] at hcoef
+  exact hc hcoef.symm
+
+end Degree
+
+end P2MWs13.NonScalar
+
+open P2MWs13.NonScalar in
+theorem solution
+    {L : Type*} [Field L] [DecidableEq L] [Algebra ℚ L] [IsAlgClosed L]
+    (B : L) (hB : B ≠ 0) (u : Lˣ) (hu : (u : L) ^ 3 = 1) (hu1 : (u : L) ≠ 1)
+    (p : ℕ) (hp : p.Prime) :
+    ∃ T : (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve L).toAffine.Point, addOrderOf T = p ∧
+      ∀ k : ℕ, ¬ HEq (WeierstrassCurve.Affine.Point.vcInvFun (⟨u, 0, 0, 0⟩ :
+        WeierstrassCurve.VariableChange L)
+        (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve L).toAffine T) (k • T) := by
+  have : CharZero L := charZero_of_injective_algebraMap (algebraMap ℚ L).injective
+  have : Fact p.Prime := ⟨hp⟩
+  set W : WeierstrassCurve L := ⟨0, 0, 0, 0, B⟩ with hWdef
+  set γ : VariableChange L := ⟨u, 0, 0, 0⟩ with hγdef
+  have hu0 : (u : L) ≠ 0 := u.ne_zero
+  have hu2inv : ((u : L) ^ 2)⁻¹ = u := by
+    have h3' : (u : L) ^ 2 * u = 1 := by rw [← pow_succ]; exact hu
+    exact inv_eq_of_mul_eq_one_right h3'
+  have huinv2 : ((u⁻¹ : Lˣ) : L) ^ 2 = u := by
+    rw [Units.val_inv_eq_inv_val, inv_pow, hu2inv]
+  have h2 : (2 : L) ≠ 0 := two_ne_zero
+  have hΔ : W.Δ = -432 * B ^ 2 := by
+    simp only [hWdef, WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄,
+      WeierstrassCurve.b₆,
+      WeierstrassCurve.b₈]; ring
+  have hE : W.IsElliptic := ⟨by rw [hΔ]; exact isUnit_iff_ne_zero.mpr (by simp [hB])⟩
+  have hW : γ • W = W := WeierstrassCurve.variableChange_mk_smul_eq_self_of_pow_three_eq_one u hu B
+  suffices core : ∃ (x y : L) (h : W.toAffine.Nonsingular x y), addOrderOf (Point.some x y h) = p ∧
+      ∀ k : ℕ, xco (k • Point.some x y h) ≠ some ((u : L) * x) by
+    obtain ⟨x, y, h, hord, hk⟩ := core
+    refine ⟨Point.some x y h, hord, fun k hheq => hk k ?_⟩
+    have := xco_eq_of_heq hW hheq
+    rw [xco_vcInvFun] at this
+    rw [← this]; simp [hu2inv]
+  obtain ⟨e, he⟩ := WeierstrassCurve.exists_addEquiv_point_variableChange W γ
+  let σ : W.toAffine.Point →+ W.toAffine.Point := (castPt hW).toAddMonoidHom.comp e.toAddMonoidHom
+  have hσx : ∀ (x y : L) (h : W.toAffine.Nonsingular x y), xco (σ (Point.some x y h)) = some ((u :
+    L) * x) :=
+    by
+    intro x y h
+    obtain ⟨h', he'⟩ := he x y h
+    change xco (castPt hW (e (Point.some x y h))) = _
+    rw [xco_castPt, he', xco_some]
+    simp [hγdef, hu2inv]
+  have hσ0 : ∀ P : W.toAffine.Point, σ P = 0 ↔ P = 0 := fun P =>
+    ⟨fun h0 => by
+      have : castPt hW (e P) = castPt hW (e 0) := by rw [map_zero, map_zero]; exact h0
+      exact e.injective ((castPt hW).injective this), fun h0 => by rw [h0, map_zero]⟩
+  rcases hp.eq_two_or_odd' with rfl | hpodd
+  · obtain ⟨a, ha⟩ : ∃ a : L, a ^ 3 = -B := by
+      obtain ⟨a, ha⟩ := IsAlgClosed.exists_pow_nat_eq (-B) (n := 3) (by norm_num)
+      exact ⟨a, ha⟩
+    have ha0 : a ≠ 0 := by rintro rfl; apply hB; simpa using ha.symm
+    have heq : W.toAffine.Equation a 0 := by
+      rw [WeierstrassCurve.Affine.equation_iff]; simp [hWdef]; linear_combination -ha
+    have h3 : (3 : L) ≠ 0 := three_ne_zero
+    have hns : W.toAffine.Nonsingular a 0 := by
+      rw [WeierstrassCurve.Affine.nonsingular_iff']
+      refine ⟨heq, Or.inl ?_⟩
+      change (0 : L) * 0 - (3 * a ^ 2 + 2 * 0 * a + 0) ≠ 0
+      intro h3a
+      apply ha0
+      have : (3 : L) * a ^ 2 = 0 := by linear_combination -h3a
+      simpa [h3] using this
+    have hneg : -Point.some a 0 hns = Point.some a 0 hns := by
+      rw [Point.neg_some]; congr 1; simp [WeierstrassCurve.Affine.negY, hWdef]
+    have h2T : (2 : ℕ) • Point.some a 0 hns = 0 := by
+      rw [two_nsmul]; nth_rewrite 1 [← hneg]; rw [neg_add_cancel]
+    have hord : addOrderOf (Point.some a 0 hns) = 2 := by
+      refine (addOrderOf_eq_prime_iff.mpr ⟨h2T, ?_⟩)
+      exact Point.some_ne_zero hns
+    refine ⟨a, 0, hns, hord, fun k => ?_⟩
+    have hkT : k • Point.some a 0 hns = 0 ∨ k • Point.some a 0 hns = Point.some a 0 hns := by
+      rcases Nat.even_or_odd k with ⟨j, rfl⟩ | ⟨j, rfl⟩
+      · left; rw [← two_mul, mul_nsmul, h2T, nsmul_zero]
+      · right; rw [add_nsmul, mul_nsmul, h2T, nsmul_zero, zero_add, one_nsmul]
+    rcases hkT with h0 | h1
+    · rw [h0, xco_zero]; simp
+    · rw [h1, xco_some]; simp only [ne_eq, Option.some.injEq]
+      intro h; apply hu1
+      have : (1 - (u : L)) * a = 0 := by linear_combination h
+      rcases mul_eq_zero.mp this with h' | h'
+      · exact (sub_eq_zero.mp h').symm
+      · exact absurd h' ha0
+  · have hp2 : p ≠ 2 := by rintro rfl; exact (Nat.not_even_iff_odd.mpr hpodd) even_two
+    have hp3 : 3 ≤ p := by have := hp.two_le; omega
+    have hcard : Nat.card (Submodule.torsionBy ℤ W.toAffine.Point p) = p ^ 2 := by
+      have hpL : ((p : ℕ) : L) ≠ 0 := Nat.cast_ne_zero.mpr hp.ne_zero
+      have h := W.card_torsion_of_isAlgClosed (K := L) hpL
+      have hb : (W⁄L) = W.toAffine := by
+        change (W.baseChange L).toAffine = W.toAffine
+        rw [WeierstrassCurve.baseChange, Algebra.algebraMap_self, WeierstrassCurve.map_id]
+      rw [hb] at h
+      exact h
+    by_contra hcon
+    push Not at hcon
+    have heig : ∀ T : W.toAffine.Point, (p : ℤ) • T = 0 → ∃ a : ℤ, σ T = a • T := by
+      intro T hpT
+      rcases T with _ | ⟨x, y, h⟩
+      · exact ⟨0, by rw [zero_smul]; exact map_zero σ⟩
+      · have hord : addOrderOf (Point.some x y h) = p := by
+          refine addOrderOf_eq_prime_iff.mpr ⟨?_, Point.some_ne_zero h⟩
+          rw [← natCast_zsmul]; exact hpT
+        obtain ⟨k, hk⟩ := hcon x y h hord
+        have hx : xco (σ (Point.some x y h)) = xco (k • Point.some x y h) := by rw [hσx, hk]
+        rcases eq_or_eq_neg_of_xco_eq hx with h1 | h1
+        · exact ⟨k, by rw [h1, natCast_zsmul]⟩
+        · exact ⟨-k, by rw [h1, neg_smul, natCast_zsmul]⟩
+    let Ep := (Submodule.torsionBy ℤ W.toAffine.Point p).toAddSubgroup
+    have hEp_mem : ∀ T : W.toAffine.Point, T ∈ Ep ↔ (p : ℤ) • T = 0 :=
+      fun T => Submodule.mem_torsionBy_iff _ _
+    have hσEp : ∀ T ∈ Ep, σ T ∈ Ep := by
+      intro T hT
+      rw [hEp_mem] at hT ⊢
+      rw [← map_zsmul, hT, map_zero]
+    let σ' : Ep →+ Ep := (σ.domRestrict Ep).codRestrict Ep (fun T => hσEp T T.2)
+    obtain ⟨eb⟩ : Nonempty (ZMod p × ZMod p ≃+ Ep) := by
+      have hpL : ((p : ℕ) : L) ≠ 0 := Nat.cast_ne_zero.mpr hp.ne_zero
+      have h := W.nonempty_torsionBy_addEquiv_zmod_prod_of_isAlgClosed (K := L) hpL
+      have hb : (W⁄L) = W.toAffine := by
+        change (W.baseChange L).toAffine = W.toAffine
+        rw [WeierstrassCurve.baseChange, Algebra.algebraMap_self, WeierstrassCurve.map_id]
+      rw [hb] at h
+      exact h
+    have heig' : ∀ v : Ep, ∃ a : ℤ, σ' v = a • v := by
+      rintro ⟨T, hT⟩
+      obtain ⟨a, ha⟩ := heig T ((hEp_mem T).mp hT)
+      exact ⟨a, Subtype.ext ha⟩
+    obtain ⟨c, hc⟩ := exists_common_scalar eb σ' heig'
+    obtain ⟨m, hm1, hmle, hmx⟩ : ∃ m : ℕ, 1 ≤ m ∧ 2 * m ≤ p - 1 ∧
+        ∀ (x y : L) (h : W.toAffine.Nonsingular x y), (p : ℤ) • Point.some x y h = 0 →
+          xco ((m : ℤ) • Point.some x y h) = some ((u : L) * x) := by
+      let r : ℕ := ((c : ZMod p)).val
+      have hr : (r : ZMod p) = c := by simp [r]
+      have hrp : r < p := ZMod.val_lt _
+      have hσc : ∀ (x y : L) (h : W.toAffine.Nonsingular x y), (p : ℤ) • Point.some x y h = 0 →
+          σ (Point.some x y h) = (r : ℤ) • Point.some x y h := by
+        intro x y h hpT
+        have hT : Point.some x y h ∈ Ep := (hEp_mem _).mpr hpT
+        have := hc ⟨_, hT⟩
+        have hval : σ (Point.some x y h) = c • Point.some x y h := congrArg Subtype.val this
+        rw [hval]
+        obtain ⟨k, hk⟩ :=
+          (ZMod.intCast_eq_intCast_iff_dvd_sub (r : ℤ) c p).mp (by exact_mod_cast hr)
+        have : c = r + p * k := by linarith
+        rw [this, add_zsmul, mul_comm, mul_zsmul, hpT, zsmul_zero, add_zero]
+      obtain ⟨x₀, y₀, h₀, hp₀⟩ : ∃ (x y : L) (h : W.toAffine.Nonsingular x y), (p : ℤ) • Point.some
+        x y h = 0 :=
+        by
+        have h1 : 1 < Nat.card Ep := by rw [show Nat.card Ep = p ^ 2 from hcard]; nlinarith
+        have : Finite Ep :=
+          Nat.finite_of_card_ne_zero (by rw [show Nat.card Ep = p ^ 2 from hcard]; positivity)
+        have : Nontrivial Ep := Finite.one_lt_card_iff_nontrivial.mp h1
+        obtain ⟨⟨T, hT⟩, hT0⟩ := exists_ne (0 : Ep)
+        rcases T with _ | ⟨x, y, h⟩
+        · exact absurd rfl (fun h => hT0 (Subtype.ext h))
+        · exact ⟨x, y, h, (hEp_mem _).mp hT⟩
+      have hr0 : r ≠ 0 := by
+        intro hr0
+        have := hσc x₀ y₀ h₀ hp₀
+        rw [hr0, Nat.cast_zero, zero_smul, hσ0] at this
+        exact Point.some_ne_zero h₀ this
+      have hodd : p % 2 = 1 := Nat.odd_iff.mp hpodd
+      by_cases hle : 2 * r ≤ p - 1
+      · refine ⟨r, Nat.one_le_iff_ne_zero.mpr hr0, hle, fun x y h hpT => ?_⟩
+        rw [← hσc x y h hpT, hσx]
+      · refine ⟨p - r, by omega, by omega, fun x y h hpT => ?_⟩
+        have : ((p - r : ℕ) : ℤ) • Point.some x y h = -((r : ℤ) • Point.some x y h) := by
+          rw [Nat.cast_sub hrp.le, sub_zsmul, hpT]; simp
+        rw [this, xco_neg, ← hσc x y h hpT, hσx]
+    set F : L[X] := W.Φ (m : ℤ) - C (u : L) * X * W.ΨSq (m : ℤ) with hFdef
+    have hc : 1 - (u : L) * (m : L) ^ 2 ≠ 0 := by
+      intro h0
+      have hum : (u : L) * (m : L) ^ 2 = 1 := by linear_combination -h0
+      have hm6 : ((m ^ 6 : ℕ) : L) = 1 := by
+        have : ((u : L) * (m : L) ^ 2) ^ 3 = 1 := by rw [hum, one_pow]
+        rw [mul_pow, hu, one_mul] at this
+        push_cast; rw [← this]; ring
+      have hm1' : m ^ 6 = 1 := by exact_mod_cast hm6
+      have hm_eq : m = 1 := by
+        rcases Nat.lt_or_ge 1 m with hlt | hge
+        · have : 1 < m ^ 6 := Nat.one_lt_pow (by norm_num) hlt
+          omega
+        · omega
+      subst hm_eq
+      apply hu1
+      simpa using hum
+    have hF0 : F ≠ 0 := Phi_sub_C_mul_X_mul_PsiSq_ne_zero W (u : L) m hm1 hc
+    have hFdeg : F.natDegree ≤ m ^ 2 := natDegree_Phi_sub_C_mul_X_mul_PsiSq_le W (u : L) m hm1
+    have hmp : (m : ℤ) • (0 : W.toAffine.Point) = 0 := zsmul_zero _
+    have hroot : ∀ (x y : L) (h : W.toAffine.Nonsingular x y), (p : ℤ) • Point.some x y h = 0 →
+      F.IsRoot x :=
+      by
+      intro x y h hpT
+      have hord : addOrderOf (Point.some x y h) = p :=
+        addOrderOf_eq_prime_iff.mpr ⟨by rw [← natCast_zsmul]; exact hpT, Point.some_ne_zero h⟩
+      have hmT : (m : ℤ) • Point.some x y h ≠ 0 := by
+        rw [natCast_zsmul]
+        intro h0
+        have hdvd := addOrderOf_dvd_of_nsmul_eq_zero h0
+        rw [hord] at hdvd
+        have := Nat.le_of_dvd (by omega) hdvd
+        omega
+      have hψ : (W.ψ (m : ℤ)).evalEval x y ≠ 0 := fun h0 =>
+        hmT ((WeierstrassCurve.Affine.Point.smul_some_eq_zero_iff W h (m : ℤ)).mpr h0)
+      obtain ⟨y', h', hmul⟩ := WeierstrassCurve.Affine.Point.zsmul_some_eq_some_div W h hψ
+      have hx : xco ((m : ℤ) • Point.some x y h) = some ((u : L) * x) := hmx x y h hpT
+      rw [hmul, xco_some, Option.some.injEq] at hx
+      have hΨ : (W.ΨSq (m : ℤ)).eval x ≠ 0 := by
+        rw [← WeierstrassCurve.Affine.evalEval_psi_sq W h.1 (m : ℤ)]; exact pow_ne_zero 2 hψ
+      rw [div_eq_iff hΨ] at hx
+      change F.eval x = 0
+      rw [hFdef, eval_sub, eval_mul, eval_mul, eval_C, eval_X]
+      linear_combination hx
+    have hfinEp : Finite Ep :=
+      Nat.finite_of_card_ne_zero (by rw [show Nat.card Ep = p ^ 2 from hcard]; positivity)
+    have : Fintype Ep := Fintype.ofFinite Ep
+    classical
+    let g : Ep → Option L := fun T => xco (T.1 : W.toAffine.Point)
+    let s : Finset Ep := Finset.univ.filter (fun T => T ≠ 0)
+    have hs_card : s.card = p ^ 2 - 1 := by
+      have : s.card + 1 = p ^ 2 := by
+        rw [show s = Finset.univ.erase 0 by
+          ext T; simp [s], Finset.card_erase_of_mem (Finset.mem_univ _),
+          Finset.card_univ, ← Nat.card_eq_fintype_card, show Nat.card Ep = p ^ 2 from hcard]
+        have : 1 ≤ p ^ 2 := Nat.one_le_iff_ne_zero.mpr (by positivity); omega
+      omega
+    have hfib : ∀ b ∈ s.image g, (s.filter (fun T => g T = b)).card ≤ 2 := by
+      intro b hb
+      obtain ⟨T₁, hT₁, rfl⟩ := Finset.mem_image.mp hb
+      have hsub : s.filter (fun T => g T = g T₁) ⊆ {T₁, -T₁} := by
+        intro T hT
+        rw [Finset.mem_filter] at hT
+        have hx : xco (T.1 : W.toAffine.Point) = xco (T₁.1 : W.toAffine.Point) := hT.2
+        rcases eq_or_eq_neg_of_xco_eq hx with h1 | h1
+        · rw [Finset.mem_insert]; left; exact Subtype.ext h1
+        · rw [Finset.mem_insert, Finset.mem_singleton]; right
+          exact Subtype.ext (by rw [h1]; rfl)
+      exact (Finset.card_le_card hsub).trans (Finset.card_insert_le _ _ |>.trans (by simp))
+    have hle : s.card ≤ 2 * (s.image g).card := Finset.card_le_mul_card_image s 2 hfib
+    have himg : s.image g ⊆ (F.roots.toFinset).image some := by
+      intro b hb
+      obtain ⟨T, hT, rfl⟩ := Finset.mem_image.mp hb
+      rw [Finset.mem_filter] at hT
+      obtain ⟨⟨T, hTp⟩, hT0⟩ := T, hT.2
+      rcases T with _ | ⟨x, y, h⟩
+      · exact absurd rfl (fun h => hT0 (Subtype.ext h))
+      · refine Finset.mem_image.mpr ⟨x, ?_, rfl⟩
+        rw [Multiset.mem_toFinset, mem_roots hF0]
+        exact hroot x y h ((hEp_mem _).mp hTp)
+    have hR : ((F.roots.toFinset).image some).card ≤ m ^ 2 := by
+      refine Finset.card_image_le.trans ((Multiset.toFinset_card_le _).trans ?_)
+      exact (Polynomial.card_roots' F).trans hFdeg
+    have hfinal : p ^ 2 - 1 ≤ 2 * m ^ 2 := by
+      rw [← hs_card]; exact hle.trans (Nat.mul_le_mul_left 2 ((Finset.card_le_card himg).trans hR))
+    have h4 : 4 * m ^ 2 ≤ (p - 1) ^ 2 := by nlinarith
+    have hp1 : 1 ≤ p := hp.one_lt.le
+    zify [hp1, Nat.one_le_iff_ne_zero.mpr (show p ^ 2 ≠ 0 by positivity)] at hfinal h4 hmle
+    nlinarith
+
+end S_WeierstrassCurve_exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_pow_three_eq_one
+end P2MW
+export P2MW.S_WeierstrassCurve_exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_pow_three_eq_one
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_pow_three_eq_one
+    {L : Type*} [Field L] [DecidableEq L] [Algebra ℚ L] [IsAlgClosed L]
+    (B : L) (hB : B ≠ 0) (u : Lˣ) (hu : (u : L) ^ 3 = 1) (hu1 : (u : L) ≠ 1)
+    (p : ℕ) (hp : p.Prime) :
+    ∃ T : (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve L).toAffine.Point, addOrderOf T = p ∧
+      ∀ k : ℕ, ¬ HEq (WeierstrassCurve.Affine.Point.vcInvFun (⟨u, 0, 0, 0⟩ :
+        WeierstrassCurve.VariableChange L)
+        (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve L).toAffine T) (k • T) :=
+  solution B hB u hu hu1 p hp
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_sq_eq_neg_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_sq_eq_neg_one.lean
new file mode 100644
index 0000000000..3ad2a801ac
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_sq_eq_neg_one.lean
@@ -0,0 +1,489 @@
+/-
+Based on Prove2Me node WeierstrassCurve.exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_sq_eq_neg_one
+(2249a672-aadf-5916-a943-6baac3f74f2d) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5c45f865-8539-55f8-89ca-15ac0d253067
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VariableChangePointEquiv
+
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+import Mathlib.AlgebraicGeometry.EllipticCurve.Reduction
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_eq_ofHeightOneSpectrum_of_XClass_mem_nonunits_of_YClass_mem_nonunits
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_smul_some_eq_zero_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_zsmul_some_eq_some_div
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_evalEval_psi_sq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_addEquiv_point_variableChange
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_nonempty_torsionBy_addEquiv_zmod_prod_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_variableChange_mk_smul_eq_self_of_sq_eq_neg_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsion_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Non-scalar action of [i] on p-torsion of y²=x³+Ax
+
+Theorem statement: `WeierstrassCurve.exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_sq_eq_neg_one`
+(`2249a672-aadf-5916-a943-6baac3f74f2d`), by Claude, 2026-09-05.
+
+Proof: submission `5c45f865-8539-55f8-89ca-15ac0d253067`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be an algebraically closed field equipped with a $\mathbb{Q}$-algebra structure (so of
+characteristic $0$), let $A \in L$ with $A \neq 0$, let $u$ be a unit of $L$ with $u^2 = -1$, and
+let $p$ be a prime natural number. Write $W$ for the Weierstrass curve with coefficients
+$(a_1,a_2,a_3,a_4,a_6) = (0,0,0,A,0)$ over $L$, i.e. $y^2 = x^3 + Ax$, and let $C = \langle
+u,0,0,0\rangle$ be the variable change with scaling unit $u$ and $r = s = t = 0$. The assertion is
+that there is a point $T$ of the affine curve $W$ over $L$ whose additive order `addOrderOf T`
+equals $p$, and such that for every natural number $k$ the heterogeneous equality between
+[`WeierstrassCurve.Affine.Point.vcInvFun C W.toAffine
+T`](def/WeierstrassCurve_VariableChangePointEquiv.html#L119) and $k \bullet T$ fails. Here
+`vcInvFun` is the map from points of $W$ to points of $C \bullet W$ sending $0$ to $0$ and an affine
+point $(x,y)$ to $(u^{-2}x,\, u^{-3}y)$, that is, to $(-x,\, u^{-3}y)$; since $C \bullet W$ is only
+propositionally equal to $W$ (by
+[`WeierstrassCurve.variableChange_mk_smul_eq_self_of_sq_eq_neg_one`]
+(thm.html#WeierstrassCurve.variableChange_mk_smul_eq_self_of_sq_eq_neg_one)),
+the two sides live in types identified only after rewriting, and the inequality is therefore phrased
+with `HEq`.
+
+For $j = 1728$ the curve $y^2 = x^3 + Ax$ carries the extra automorphism $[i]\colon (x,y) \mapsto
+(-x, u^{-3}y)$ with $u^2 = -1$, and the statement says that $[i]$ does not act on the $p$-torsion
+through a scalar: some point of exact order $p$ fails to be an eigenvector, the natural-number
+multiples $k \bullet T$ exhausting the possible eigenvalues modulo $p$. It is used by
+[`WeierstrassCurve.natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuTwo`]
+(thm.html#WeierstrassCurve.natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuTwo)
+in the count of cyclic subgroups fixed by the automorphism group of such a curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_sq_eq_neg_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_sq_eq_neg_one
+
+
+open WeierstrassCurve WeierstrassCurve.Affine Polynomial
+
+namespace P2MWs13
+namespace NonScalar
+
+variable {L : Type*} [Field L]
+
+def xco [DecidableEq L] {W : WeierstrassCurve L} : W.toAffine.Point → Option L
+  | 0 => none
+  | .some x _ _ => some x
+
+@[scoped simp] theorem xco_zero [DecidableEq L] {W : WeierstrassCurve L} :
+    xco (0 : W.toAffine.Point) = none := rfl
+@[scoped simp] theorem xco_some [DecidableEq L] {W : WeierstrassCurve L} {x y : L} (h :
+  W.toAffine.Nonsingular x y) :
+    xco (Point.some x y h) = some x := rfl
+
+theorem xco_neg [DecidableEq L] {W : WeierstrassCurve L} (P : W.toAffine.Point) :
+    xco (-P) = xco P := by
+  rcases P with _ | ⟨x, y, h⟩
+  · rfl
+  · rw [Point.neg_some]; rfl
+
+theorem eq_or_eq_neg_of_xco_eq [DecidableEq L] {W : WeierstrassCurve L} {P Q : W.toAffine.Point}
+    (hPQ : xco P = xco Q) :
+    P = Q ∨ P = -Q := by
+  rcases P with _ | ⟨x, y, h⟩ <;> rcases Q with _ | ⟨x', y', h'⟩
+  · exact Or.inl rfl
+  · simp [xco] at hPQ
+  · simp [xco] at hPQ
+  · simp only [xco_some, Option.some.injEq] at hPQ
+    subst hPQ
+    have hy : y = y' ∨ y = W.toAffine.negY x y' := by
+      have h1 := h.1; have h2 := h'.1
+      rw [WeierstrassCurve.Affine.equation_iff] at h1 h2
+      have : (y - y') * (y - W.toAffine.negY x y') = 0 := by
+        rw [WeierstrassCurve.Affine.negY]; linear_combination h1 - h2
+      rcases mul_eq_zero.mp this with h0 | h0
+      · exact Or.inl (sub_eq_zero.mp h0)
+      · exact Or.inr (sub_eq_zero.mp h0)
+    rcases hy with rfl | rfl
+    · exact Or.inl rfl
+    · right; rw [Point.neg_some]
+
+theorem xco_eq_of_heq [DecidableEq L] {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂)
+    {P : W₁.toAffine.Point} {Q : W₂.toAffine.Point}
+    (h : HEq P Q) : xco P = xco Q := by
+  subst e
+  rw [eq_of_heq h]
+
+def castPt [DecidableEq L] {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂) :
+    W₁.toAffine.Point ≃+ W₂.toAffine.Point := by
+  subst e; exact AddEquiv.refl _
+
+theorem xco_castPt [DecidableEq L] {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂)
+    (P : W₁.toAffine.Point) :
+    xco (castPt e P) = xco P := by
+  subst e; rfl
+
+theorem xco_vcInvFun [DecidableEq L] (u : Lˣ) (W : WeierstrassCurve L) (P : W.toAffine.Point) :
+    xco (Point.vcInvFun (⟨u, 0, 0, 0⟩ : VariableChange L) W.toAffine P) = (xco P).map (fun x =>
+      ((u⁻¹ : Lˣ) : L) ^ 2 * x) := by
+  rcases P with _ | ⟨x, y, h⟩
+  · rfl
+  · change some _ = some _
+    simp [WeierstrassCurve.Affine.vcXInv]
+
+section Scalar
+
+variable {V : Type*} [AddCommGroup V]
+
+theorem exists_common_scalar {p : ℕ} [Fact p.Prime] (e : ZMod p × ZMod p ≃+ V) (σ : V →+ V)
+    (heig : ∀ v : V, ∃ a : ℤ, σ v = a • v) : ∃ c : ℤ, ∀ v : V, σ v = c • v := by
+  obtain ⟨a, ha⟩ := heig (e (1, 0))
+  obtain ⟨b, hb⟩ := heig (e (0, 1))
+  obtain ⟨c, hc⟩ := heig (e (1, 1))
+  have hsum : e (1, 1) = e (1, 0) + e (0, 1) := by
+    rw [← map_add, Prod.mk_add_mk, add_zero, zero_add]
+  have key : c • e (1, 0) + c • e (0, 1) = a • e (1, 0) + b • e (0, 1) := by
+    rw [← smul_add, ← hsum, ← hc, hsum, map_add, ha, hb]
+  have key' : ((c : ZMod p), (c : ZMod p)) = ((a : ZMod p), (b : ZMod p)) := by
+    apply e.injective
+    have h1 : e ((c : ZMod p), (c : ZMod p)) = c • e (1, 0) + c • e (0, 1) := by
+      rw [← map_zsmul, ← map_zsmul, ← map_add]; congr 1; ext <;> simp
+    have h2 : e ((a : ZMod p), (b : ZMod p)) = a • e (1, 0) + b • e (0, 1) := by
+      rw [← map_zsmul, ← map_zsmul, ← map_add]; congr 1; ext <;> simp
+    rw [h1, h2, key]
+  have hca : (c : ZMod p) = a := congrArg Prod.fst key'
+  have hcb : (c : ZMod p) = b := congrArg Prod.snd key'
+  have hpV : ∀ v : V, (p : ℤ) • v = 0 := by
+    intro v
+    obtain ⟨w, rfl⟩ := e.surjective v
+    rw [← map_zsmul, show (p : ℤ) • w = 0 from ?_, map_zero]
+    ext <;> simp [zsmul_eq_mul]
+  have hzs : ∀ (m n : ℤ) (v : V), (m : ZMod p) = n → m • v = n • v := by
+    intro m n v hmn
+    obtain ⟨k, hk⟩ := (ZMod.intCast_eq_intCast_iff_dvd_sub n m p).mp hmn.symm
+    have : m = n + p * k := by linarith
+    rw [this, add_zsmul, mul_comm, mul_zsmul, hpV, zsmul_zero, add_zero]
+  refine ⟨c, fun v => ?_⟩
+  obtain ⟨⟨s, t⟩, rfl⟩ := e.surjective v
+  have hv : e (s, t) = (s.val : ℤ) • e (1, 0) + (t.val : ℤ) • e (0, 1) := by
+    rw [← map_zsmul, ← map_zsmul, ← map_add]; congr 1; ext <;> simp []
+  rw [hv, map_add, map_zsmul, map_zsmul, ha, hb, smul_add, smul_comm c (s.val : ℤ), smul_comm c
+    (t.val : ℤ),
+    hzs a c _ hca.symm, hzs b c _ hcb.symm]
+
+end Scalar
+
+section Degree
+
+variable (W : WeierstrassCurve L)
+
+theorem natDegree_Phi_add_X_mul_PsiSq_le (m : ℕ) (hm : 1 ≤ m) :
+    (W.Φ (m : ℤ) + X * W.ΨSq (m : ℤ)).natDegree ≤ m ^ 2 := by
+  have hm2 : 1 ≤ m ^ 2 := Nat.one_le_iff_ne_zero.mpr (pow_ne_zero 2 (by omega))
+  refine (natDegree_add_le _ _).trans (max_le ?_ ?_)
+  · have hΦ := W.natDegree_Φ_le (m : ℤ)
+    simp only [Int.natAbs_natCast] at hΦ
+    exact hΦ
+  · refine (natDegree_mul_le).trans ?_
+    have hΨ := W.natDegree_ΨSq_le (m : ℤ)
+    simp only [Int.natAbs_natCast] at hΨ
+    have hX : (X : L[X]).natDegree ≤ 1 := natDegree_X_le
+    omega
+
+theorem Phi_add_X_mul_PsiSq_ne_zero [CharZero L] (m : ℕ) (hm : 1 ≤ m) :
+    W.Φ (m : ℤ) + X * W.ΨSq (m : ℤ) ≠ 0 := by
+  intro h0
+  have hcoef : (W.Φ (m : ℤ) + X * W.ΨSq (m : ℤ)).coeff (m ^ 2) = 1 + (m : L) ^ 2 := by
+    rw [coeff_add]
+    have h1 : (W.Φ (m : ℤ)).coeff (m ^ 2) = 1 := by
+      have := W.coeff_Φ (m : ℤ)
+      simp only [Int.natAbs_natCast] at this
+      exact this
+    have h2 : (X * W.ΨSq (m : ℤ)).coeff (m ^ 2) = (m : L) ^ 2 := by
+      have hm2 : m ^ 2 = (m ^ 2 - 1) + 1 := by
+        have : 1 ≤ m ^ 2 := Nat.one_le_iff_ne_zero.mpr (pow_ne_zero 2 (by omega)); omega
+      rw [hm2, coeff_X_mul]
+      have := W.coeff_ΨSq (m : ℤ)
+      simp only [Int.natAbs_natCast] at this
+      rw [this]; push_cast; ring
+    rw [h1, h2]
+  rw [h0, coeff_zero] at hcoef
+  have : ((1 + m ^ 2 : ℕ) : L) ≠ 0 := Nat.cast_ne_zero.mpr (by omega)
+  push_cast at this
+  exact this hcoef.symm
+
+end Degree
+
+end P2MWs13.NonScalar
+
+open P2MWs13.NonScalar in
+theorem solution
+    {L : Type*} [Field L] [DecidableEq L] [Algebra ℚ L] [IsAlgClosed L]
+    (A : L) (hA : A ≠ 0) (u : Lˣ) (hu : (u : L) ^ 2 = -1)
+    (p : ℕ) (hp : p.Prime) :
+    ∃ T : (⟨0, 0, 0, A, 0⟩ : WeierstrassCurve L).toAffine.Point, addOrderOf T = p ∧
+      ∀ k : ℕ, ¬ HEq (WeierstrassCurve.Affine.Point.vcInvFun (⟨u, 0, 0, 0⟩ :
+        WeierstrassCurve.VariableChange L)
+        (⟨0, 0, 0, A, 0⟩ : WeierstrassCurve L).toAffine T) (k • T) := by
+  have : CharZero L := charZero_of_injective_algebraMap (algebraMap ℚ L).injective
+  have : Fact p.Prime := ⟨hp⟩
+  set W : WeierstrassCurve L := ⟨0, 0, 0, A, 0⟩ with hWdef
+  set γ : VariableChange L := ⟨u, 0, 0, 0⟩ with hγdef
+  have hu0 : (u : L) ≠ 0 := u.ne_zero
+  have huinv2 : ((u⁻¹ : Lˣ) : L) ^ 2 = -1 := by
+    rw [Units.val_inv_eq_inv_val, inv_pow, hu]; norm_num
+  have hu2inv : ((u : L) ^ 2)⁻¹ = -1 := by rw [hu]; norm_num
+  have h2 : (2 : L) ≠ 0 := two_ne_zero
+  have hΔ : W.Δ = -64 * A ^ 3 := by
+    simp only [hWdef, WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄,
+      WeierstrassCurve.b₆,
+      WeierstrassCurve.b₈]; ring
+  have hE : W.IsElliptic := ⟨by rw [hΔ]; exact isUnit_iff_ne_zero.mpr (by simp [hA])⟩
+  have hW : γ • W = W := WeierstrassCurve.variableChange_mk_smul_eq_self_of_sq_eq_neg_one u hu A
+  suffices core : ∃ (x y : L) (h : W.toAffine.Nonsingular x y), addOrderOf (Point.some x y h) = p ∧
+      ∀ k : ℕ, xco (k • Point.some x y h) ≠ some (-x) by
+    obtain ⟨x, y, h, hord, hk⟩ := core
+    refine ⟨Point.some x y h, hord, fun k hheq => hk k ?_⟩
+    have := xco_eq_of_heq hW hheq
+    rw [xco_vcInvFun] at this
+    rw [← this]; simp [hu2inv]
+  obtain ⟨e, he⟩ := WeierstrassCurve.exists_addEquiv_point_variableChange W γ
+  let σ : W.toAffine.Point →+ W.toAffine.Point := (castPt hW).toAddMonoidHom.comp e.toAddMonoidHom
+  have hσx : ∀ (x y : L) (h : W.toAffine.Nonsingular x y), xco (σ (Point.some x y h)) = some (-x) :=
+    by
+    intro x y h
+    obtain ⟨h', he'⟩ := he x y h
+    change xco (castPt hW (e (Point.some x y h))) = _
+    rw [xco_castPt, he', xco_some]
+    simp [hγdef, hu2inv]
+  have hσ0 : ∀ P : W.toAffine.Point, σ P = 0 ↔ P = 0 := fun P =>
+    ⟨fun h0 => by
+      have : castPt hW (e P) = castPt hW (e 0) := by rw [map_zero, map_zero]; exact h0
+      exact e.injective ((castPt hW).injective this), fun h0 => by rw [h0, map_zero]⟩
+  rcases hp.eq_two_or_odd' with rfl | hpodd
+  · obtain ⟨a, ha⟩ : ∃ a : L, a ^ 2 = -A := by
+      obtain ⟨a, ha⟩ := IsAlgClosed.exists_pow_nat_eq (-A) (n := 2) (by norm_num)
+      exact ⟨a, ha⟩
+    have ha0 : a ≠ 0 := by rintro rfl; apply hA; simpa using ha.symm
+    have heq : W.toAffine.Equation a 0 := by
+      rw [WeierstrassCurve.Affine.equation_iff]; simp [hWdef]; linear_combination -a * ha
+    have hns : W.toAffine.Nonsingular a 0 := by
+      rw [WeierstrassCurve.Affine.nonsingular_iff']
+      refine ⟨heq, Or.inl ?_⟩
+      simp only [hWdef, mul_zero, zero_mul, add_zero, zero_sub, neg_add_rev, ne_eq]
+      intro h3a
+      apply ha0
+      have : (2 : L) * a ^ 2 = 0 := by linear_combination -h3a - ha
+      simpa [h2] using this
+    have hneg : -Point.some a 0 hns = Point.some a 0 hns := by
+      rw [Point.neg_some]; congr 1; simp [WeierstrassCurve.Affine.negY, hWdef]
+    have h2T : (2 : ℕ) • Point.some a 0 hns = 0 := by
+      rw [two_nsmul]; nth_rewrite 1 [← hneg]; rw [neg_add_cancel]
+    have hord : addOrderOf (Point.some a 0 hns) = 2 := by
+      refine (addOrderOf_eq_prime_iff.mpr ⟨h2T, ?_⟩)
+      exact Point.some_ne_zero hns
+    refine ⟨a, 0, hns, hord, fun k => ?_⟩
+    have hkT : k • Point.some a 0 hns = 0 ∨ k • Point.some a 0 hns = Point.some a 0 hns := by
+      rcases Nat.even_or_odd k with ⟨j, rfl⟩ | ⟨j, rfl⟩
+      · left; rw [← two_mul, mul_nsmul, h2T, nsmul_zero]
+      · right; rw [add_nsmul, mul_nsmul, h2T, nsmul_zero, zero_add, one_nsmul]
+    rcases hkT with h0 | h1
+    · rw [h0, xco_zero]; simp
+    · rw [h1, xco_some]; simp only [ne_eq, Option.some.injEq]
+      intro h; apply ha0
+      have : (2 : L) * a = 0 := by linear_combination h
+      simpa [h2] using this
+  · have hp2 : p ≠ 2 := by rintro rfl; exact (Nat.not_even_iff_odd.mpr hpodd) even_two
+    have hp3 : 3 ≤ p := by have := hp.two_le; omega
+    have hcard : Nat.card (Submodule.torsionBy ℤ W.toAffine.Point p) = p ^ 2 := by
+      have hpL : ((p : ℕ) : L) ≠ 0 := Nat.cast_ne_zero.mpr hp.ne_zero
+      have h := W.card_torsion_of_isAlgClosed (K := L) hpL
+      have hb : (W⁄L) = W.toAffine := by
+        change (W.baseChange L).toAffine = W.toAffine
+        rw [WeierstrassCurve.baseChange, Algebra.algebraMap_self, WeierstrassCurve.map_id]
+      rw [hb] at h
+      exact h
+    by_contra hcon
+    push Not at hcon
+    have heig : ∀ T : W.toAffine.Point, (p : ℤ) • T = 0 → ∃ a : ℤ, σ T = a • T := by
+      intro T hpT
+      rcases T with _ | ⟨x, y, h⟩
+      · exact ⟨0, by rw [zero_smul]; exact map_zero σ⟩
+      · have hord : addOrderOf (Point.some x y h) = p := by
+          refine addOrderOf_eq_prime_iff.mpr ⟨?_, Point.some_ne_zero h⟩
+          rw [← natCast_zsmul]; exact hpT
+        obtain ⟨k, hk⟩ := hcon x y h hord
+        have hx : xco (σ (Point.some x y h)) = xco (k • Point.some x y h) := by rw [hσx, hk]
+        rcases eq_or_eq_neg_of_xco_eq hx with h1 | h1
+        · exact ⟨k, by rw [h1, natCast_zsmul]⟩
+        · exact ⟨-k, by rw [h1, neg_smul, natCast_zsmul]⟩
+    let Ep := (Submodule.torsionBy ℤ W.toAffine.Point p).toAddSubgroup
+    have hEp_mem : ∀ T : W.toAffine.Point, T ∈ Ep ↔ (p : ℤ) • T = 0 :=
+      fun T => Submodule.mem_torsionBy_iff _ _
+    have hσEp : ∀ T ∈ Ep, σ T ∈ Ep := by
+      intro T hT
+      rw [hEp_mem] at hT ⊢
+      rw [← map_zsmul, hT, map_zero]
+    let σ' : Ep →+ Ep := (σ.domRestrict Ep).codRestrict Ep (fun T => hσEp T T.2)
+    obtain ⟨eb⟩ : Nonempty (ZMod p × ZMod p ≃+ Ep) := by
+      have hpL : ((p : ℕ) : L) ≠ 0 := Nat.cast_ne_zero.mpr hp.ne_zero
+      have h := W.nonempty_torsionBy_addEquiv_zmod_prod_of_isAlgClosed (K := L) hpL
+      have hb : (W⁄L) = W.toAffine := by
+        change (W.baseChange L).toAffine = W.toAffine
+        rw [WeierstrassCurve.baseChange, Algebra.algebraMap_self, WeierstrassCurve.map_id]
+      rw [hb] at h
+      exact h
+    have heig' : ∀ v : Ep, ∃ a : ℤ, σ' v = a • v := by
+      rintro ⟨T, hT⟩
+      obtain ⟨a, ha⟩ := heig T ((hEp_mem T).mp hT)
+      exact ⟨a, Subtype.ext ha⟩
+    obtain ⟨c, hc⟩ := exists_common_scalar eb σ' heig'
+    obtain ⟨m, hm1, hmle, hmx⟩ : ∃ m : ℕ, 1 ≤ m ∧ 2 * m ≤ p - 1 ∧
+        ∀ (x y : L) (h : W.toAffine.Nonsingular x y), (p : ℤ) • Point.some x y h = 0 →
+          xco ((m : ℤ) • Point.some x y h) = some (-x) := by
+      let r : ℕ := ((c : ZMod p)).val
+      have hr : (r : ZMod p) = c := by simp [r]
+      have hrp : r < p := ZMod.val_lt _
+      have hσc : ∀ (x y : L) (h : W.toAffine.Nonsingular x y), (p : ℤ) • Point.some x y h = 0 →
+          σ (Point.some x y h) = (r : ℤ) • Point.some x y h := by
+        intro x y h hpT
+        have hT : Point.some x y h ∈ Ep := (hEp_mem _).mpr hpT
+        have := hc ⟨_, hT⟩
+        have hval : σ (Point.some x y h) = c • Point.some x y h := congrArg Subtype.val this
+        rw [hval]
+        obtain ⟨k, hk⟩ :=
+          (ZMod.intCast_eq_intCast_iff_dvd_sub (r : ℤ) c p).mp (by exact_mod_cast hr)
+        have : c = r + p * k := by linarith
+        rw [this, add_zsmul, mul_comm, mul_zsmul, hpT, zsmul_zero, add_zero]
+      obtain ⟨x₀, y₀, h₀, hp₀⟩ : ∃ (x y : L) (h : W.toAffine.Nonsingular x y), (p : ℤ) • Point.some
+        x y h = 0 :=
+        by
+        have h1 : 1 < Nat.card Ep := by rw [show Nat.card Ep = p ^ 2 from hcard]; nlinarith
+        have : Finite Ep :=
+          Nat.finite_of_card_ne_zero (by rw [show Nat.card Ep = p ^ 2 from hcard]; positivity)
+        have : Nontrivial Ep := Finite.one_lt_card_iff_nontrivial.mp h1
+        obtain ⟨⟨T, hT⟩, hT0⟩ := exists_ne (0 : Ep)
+        rcases T with _ | ⟨x, y, h⟩
+        · exact absurd rfl (fun h => hT0 (Subtype.ext h))
+        · exact ⟨x, y, h, (hEp_mem _).mp hT⟩
+      have hr0 : r ≠ 0 := by
+        intro hr0
+        have := hσc x₀ y₀ h₀ hp₀
+        rw [hr0, Nat.cast_zero, zero_smul, hσ0] at this
+        exact Point.some_ne_zero h₀ this
+      have hodd : p % 2 = 1 := Nat.odd_iff.mp hpodd
+      by_cases hle : 2 * r ≤ p - 1
+      · refine ⟨r, Nat.one_le_iff_ne_zero.mpr hr0, hle, fun x y h hpT => ?_⟩
+        rw [← hσc x y h hpT, hσx]
+      · refine ⟨p - r, by omega, by omega, fun x y h hpT => ?_⟩
+        have : ((p - r : ℕ) : ℤ) • Point.some x y h = -((r : ℤ) • Point.some x y h) := by
+          rw [Nat.cast_sub hrp.le, sub_zsmul, hpT]; simp
+        rw [this, xco_neg, ← hσc x y h hpT, hσx]
+    set F : L[X] := W.Φ (m : ℤ) + X * W.ΨSq (m : ℤ) with hFdef
+    have hF0 : F ≠ 0 := Phi_add_X_mul_PsiSq_ne_zero W m hm1
+    have hFdeg : F.natDegree ≤ m ^ 2 := natDegree_Phi_add_X_mul_PsiSq_le W m hm1
+    have hmp : (m : ℤ) • (0 : W.toAffine.Point) = 0 := zsmul_zero _
+    have hroot : ∀ (x y : L) (h : W.toAffine.Nonsingular x y), (p : ℤ) • Point.some x y h = 0 →
+      F.IsRoot x :=
+      by
+      intro x y h hpT
+      have hord : addOrderOf (Point.some x y h) = p :=
+        addOrderOf_eq_prime_iff.mpr ⟨by rw [← natCast_zsmul]; exact hpT, Point.some_ne_zero h⟩
+      have hmT : (m : ℤ) • Point.some x y h ≠ 0 := by
+        rw [natCast_zsmul]
+        intro h0
+        have hdvd := addOrderOf_dvd_of_nsmul_eq_zero h0
+        rw [hord] at hdvd
+        have := Nat.le_of_dvd (by omega) hdvd
+        omega
+      have hψ : (W.ψ (m : ℤ)).evalEval x y ≠ 0 := fun h0 =>
+        hmT ((WeierstrassCurve.Affine.Point.smul_some_eq_zero_iff W h (m : ℤ)).mpr h0)
+      obtain ⟨y', h', hmul⟩ := WeierstrassCurve.Affine.Point.zsmul_some_eq_some_div W h hψ
+      have hx : xco ((m : ℤ) • Point.some x y h) = some (-x) := hmx x y h hpT
+      rw [hmul, xco_some, Option.some.injEq] at hx
+      have hΨ : (W.ΨSq (m : ℤ)).eval x ≠ 0 := by
+        rw [← WeierstrassCurve.Affine.evalEval_psi_sq W h.1 (m : ℤ)]; exact pow_ne_zero 2 hψ
+      rw [div_eq_iff hΨ] at hx
+      change F.eval x = 0
+      rw [hFdef, eval_add, eval_mul, eval_X]
+      linear_combination hx
+    have hfinEp : Finite Ep :=
+      Nat.finite_of_card_ne_zero (by rw [show Nat.card Ep = p ^ 2 from hcard]; positivity)
+    have : Fintype Ep := Fintype.ofFinite Ep
+    classical
+    let g : Ep → Option L := fun T => xco (T.1 : W.toAffine.Point)
+    let s : Finset Ep := Finset.univ.filter (fun T => T ≠ 0)
+    have hs_card : s.card = p ^ 2 - 1 := by
+      have : s.card + 1 = p ^ 2 := by
+        rw [show s = Finset.univ.erase 0 by
+          ext T; simp [s], Finset.card_erase_of_mem (Finset.mem_univ _),
+          Finset.card_univ, ← Nat.card_eq_fintype_card, show Nat.card Ep = p ^ 2 from hcard]
+        have : 1 ≤ p ^ 2 := Nat.one_le_iff_ne_zero.mpr (by positivity); omega
+      omega
+    have hfib : ∀ b ∈ s.image g, (s.filter (fun T => g T = b)).card ≤ 2 := by
+      intro b hb
+      obtain ⟨T₁, hT₁, rfl⟩ := Finset.mem_image.mp hb
+      have hsub : s.filter (fun T => g T = g T₁) ⊆ {T₁, -T₁} := by
+        intro T hT
+        rw [Finset.mem_filter] at hT
+        have hx : xco (T.1 : W.toAffine.Point) = xco (T₁.1 : W.toAffine.Point) := hT.2
+        rcases eq_or_eq_neg_of_xco_eq hx with h1 | h1
+        · rw [Finset.mem_insert]; left; exact Subtype.ext h1
+        · rw [Finset.mem_insert, Finset.mem_singleton]; right
+          exact Subtype.ext (by rw [h1]; rfl)
+      exact (Finset.card_le_card hsub).trans (Finset.card_insert_le _ _ |>.trans (by simp))
+    have hle : s.card ≤ 2 * (s.image g).card := Finset.card_le_mul_card_image s 2 hfib
+    have himg : s.image g ⊆ (F.roots.toFinset).image some := by
+      intro b hb
+      obtain ⟨T, hT, rfl⟩ := Finset.mem_image.mp hb
+      rw [Finset.mem_filter] at hT
+      obtain ⟨⟨T, hTp⟩, hT0⟩ := T, hT.2
+      rcases T with _ | ⟨x, y, h⟩
+      · exact absurd rfl (fun h => hT0 (Subtype.ext h))
+      · refine Finset.mem_image.mpr ⟨x, ?_, rfl⟩
+        rw [Multiset.mem_toFinset, mem_roots hF0]
+        exact hroot x y h ((hEp_mem _).mp hTp)
+    have hR : ((F.roots.toFinset).image some).card ≤ m ^ 2 := by
+      refine Finset.card_image_le.trans ((Multiset.toFinset_card_le _).trans ?_)
+      exact (Polynomial.card_roots' F).trans hFdeg
+    have hfinal : p ^ 2 - 1 ≤ 2 * m ^ 2 := by
+      rw [← hs_card]; exact hle.trans (Nat.mul_le_mul_left 2 ((Finset.card_le_card himg).trans hR))
+    have h4 : 4 * m ^ 2 ≤ (p - 1) ^ 2 := by nlinarith
+    have hp1 : 1 ≤ p := hp.one_lt.le
+    zify [hp1, Nat.one_le_iff_ne_zero.mpr (show p ^ 2 ≠ 0 by positivity)] at hfinal h4 hmle
+    nlinarith
+
+end S_WeierstrassCurve_exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_sq_eq_neg_one
+end P2MW
+export P2MW.S_WeierstrassCurve_exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_sq_eq_neg_one
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_sq_eq_neg_one
+    {L : Type*} [Field L] [DecidableEq L] [Algebra ℚ L] [IsAlgClosed L]
+    (A : L) (hA : A ≠ 0) (u : Lˣ) (hu : (u : L) ^ 2 = -1)
+    (p : ℕ) (hp : p.Prime) :
+    ∃ T : (⟨0, 0, 0, A, 0⟩ : WeierstrassCurve L).toAffine.Point, addOrderOf T = p ∧
+      ∀ k : ℕ, ¬ HEq (WeierstrassCurve.Affine.Point.vcInvFun (⟨u, 0, 0, 0⟩ :
+        WeierstrassCurve.VariableChange L)
+        (⟨0, 0, 0, A, 0⟩ : WeierstrassCurve L).toAffine T) (k • T) :=
+  solution A hA u hu p hp
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_functionFieldHom_fullKernelQuotient_pointMapOfPushforward_ker_eq_zmultiples.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_functionFieldHom_fullKernelQuotient_pointMapOfPushforward_ker_eq_zmultiples.lean
new file mode 100644
index 0000000000..9f0a29ecfc
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_functionFieldHom_fullKernelQuotient_pointMapOfPushforward_ker_eq_zmultiples.lean
@@ -0,0 +1,1029 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.exists_functionFieldHom_fullKernelQuotient_pointMapOfPushforward_ker_eq_zmultiples
+(0edecfdb-ea19-5f18-91ee-48e15aab39b8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 44b5ddd3-ae0a-5d72-869f-0031443f3da4
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FullKernelQuotient
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_pushforwardAlong_pushforwardAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteAlong_comp
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_separableAlong_of_charZero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_two_smul_some_eq_zero_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_abelTheorem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_addMonoidHom_coe_eq_veluPointMap2
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_velu2FunctionFieldHom_restrictAlong_placeOfPoint_veluPointMap2
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples_of_oddOrder
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_fiberAdd_asymWeight_cleared_sixteen
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_fiberAdd_veluGx_cleared_four
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_fullKernelQuotient_eq_veluQuotient_of_odd
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_isElliptic_veluQuotient2_of_isElliptic
+
+/-!
+# Full-kernel Vélu quotient: pushforward point map has kernel ℤQ
+
+Theorem statement:
+`WeierstrassCurve.
+exists_functionFieldHom_fullKernelQuotient_pointMapOfPushforward_ker_eq_zmultiples`
+(`0edecfdb-ea19-5f18-91ee-48e15aab39b8`), by Claude, 2026-09-05.
+
+Proof: submission `44b5ddd3-ae0a-5d72-869f-0031443f3da4`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field of characteristic $0$, let $W$ be a Weierstrass curve over
+$F$ whose affine model is elliptic, let $Q$ be a point of that affine curve and let $N$ be a nonzero
+natural number with $\operatorname{addOrderOf} Q = N$. Write $W'$ for `W.fullKernelQuotient Q N`,
+the Vélu quotient of $W$ formed from the two sums, over $P$ in `W.oddOrderSummingSet Q (N - 1)`, of
+$g_x(P)$ and of $x_P g_x(P) - y_P g_y(P)$. Assume the discriminant of $W'$ is nonzero and that $W'$
+is elliptic, and assume for each of $W$ and $W'$ the interface data: a `GenusOnePlaceGate`, i.e. a
+bijection between the affine points and the places of the function field over $F$ together with the
+assertion that every such place has degree $1$; its centredness, i.e. for every nonsingular $(x,y)$
+the classes of $X-x$ and $Y-y$ lie in the nonunits of the valuation subring of the place attached to
+that point; and `AbelTheorem`, i.e. a degree-zero divisor is principal exactly when its divisor sum
+vanishes. Then there exist an $F$-algebra homomorphism $\iota : F(W') \to F(W)$, a proof that
+$\iota$ is integral, and a proof that $F(W)$ is a finite module over $F(W')$ via $\iota$, such that
+for every witness of the pushforward norm formula along $\iota$ (for every nonzero $f \in F(W)$ with
+divisor $D$ and every place $v$ of $F(W')$, the pushforward of $D$ at $v$ equals
+$\operatorname{ord}_v$ of the norm of $f$), the homomorphism `pointMapOfPushforward` $W(F) \to
+W'(F)$ — transport of a point to its class in $\mathrm{Pic}^0$, pushforward of degree-zero divisor
+classes along $\iota$, and transport back — has kernel exactly `AddSubgroup.zmultiples Q`, the
+subgroup of integer multiples of $Q$.
+
+This is the level-$N$ form, with no parity hypothesis on $N$, of the statement that the Vélu
+quotient by the cyclic subgroup generated by a point $Q$ of order $N$ carries an isogeny from $W$
+whose kernel is precisely $\langle Q\rangle$, realised here through pushforward of divisor classes
+along the corresponding function-field embedding. It is used in the construction of cyclic
+$N$-isogenies from Tate points on modular curves, by
+[`ModularCurve.TatePoint.fullKernelInjAt`](thm.html#ModularCurve.TatePoint.fullKernelInjAt) and
+[`ModularCurve.TatePoint.fullKernelIsRootAt`](thm.html#ModularCurve.TatePoint.fullKernelIsRootAt).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_exists_functionFieldHom_fullKernelQuotient_pointMapOfPushforward_ker_eq_zmultiples.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+namespace KernelTower
+
+theorem mem_zmultiples_iff_of_two_nsmul_eq_zero {A : Type*} [AddCommGroup A] {T : A}
+    (hT : 2 • T = 0) (x : A) : x ∈ AddSubgroup.zmultiples T ↔ x = 0 ∨ x = T := by
+  constructor
+  · intro hx
+    rw [AddSubgroup.mem_zmultiples_iff] at hx
+    obtain ⟨k, rfl⟩ := hx
+    have h2 : (2 : ℤ) • T = 0 := by rw [two_zsmul, ← two_nsmul, hT]
+    rcases Int.emod_two_eq_zero_or_one k with h | h
+    · left
+      obtain ⟨c, rfl⟩ := Int.dvd_of_emod_eq_zero h
+      rw [mul_comm, mul_zsmul, h2, zsmul_zero]
+    · right
+      have hk : k = 2 * (k / 2) + 1 := by omega
+      rw [hk, add_zsmul, one_zsmul, mul_comm, mul_zsmul, h2, zsmul_zero, zero_add]
+  · rintro (rfl | rfl)
+    · exact AddSubgroup.zero_mem _
+    · exact AddSubgroup.mem_zmultiples _
+
+theorem dvd_of_nsmul_mem_zmultiples_nsmul {A : Type*} [AddCommGroup A] {Q : A} {M : ℕ}
+    (hQ : addOrderOf Q = 2 * M) {k : ℕ} (hk : k • Q ∈ AddSubgroup.zmultiples (M • Q)) :
+    M ∣ k := by
+  rw [AddSubgroup.mem_zmultiples_iff] at hk
+  obtain ⟨z, hz⟩ := hk
+  have h0 : ((k : ℤ) - z * M) • Q = 0 := by
+    rw [sub_zsmul, natCast_zsmul, ← hz, mul_zsmul, natCast_zsmul, add_neg_cancel]
+  have hdvd : ((addOrderOf Q : ℕ) : ℤ) ∣ (k : ℤ) - z * M :=
+    (addOrderOf_dvd_iff_zsmul_eq_zero).mpr h0
+  rw [hQ, Nat.cast_mul, Nat.cast_ofNat] at hdvd
+  have hM : (M : ℤ) ∣ (k : ℤ) - z * M := (Dvd.intro_left 2 rfl).trans hdvd
+  have hk' : (M : ℤ) ∣ (k : ℤ) := by
+    have := Int.dvd_add hM (Dvd.intro_left z rfl : (M : ℤ) ∣ z * M)
+    rwa [sub_add_cancel] at this
+  exact Int.natCast_dvd_natCast.mp hk'
+
+theorem addOrderOf_map_of_ker_eq_zmultiples {A B : Type*} [AddCommGroup A] [AddCommGroup B]
+    (φ : A →+ B) {Q : A} {M : ℕ} (hM : M ≠ 0) (hQ : addOrderOf Q = 2 * M)
+    (hker : φ.ker = AddSubgroup.zmultiples (M • Q)) : addOrderOf (φ Q) = M := by
+  refine (addOrderOf_eq_iff (Nat.pos_of_ne_zero hM)).mpr ⟨?_, fun k hkM hk0 hk => ?_⟩
+  · rw [← map_nsmul, ← AddMonoidHom.mem_ker, hker]
+    exact AddSubgroup.mem_zmultiples _
+  · rw [← map_nsmul, ← AddMonoidHom.mem_ker, hker] at hk
+    exact absurd (Nat.le_of_dvd hk0 (dvd_of_nsmul_mem_zmultiples_nsmul hQ hk)) (not_le.mpr hkM)
+
+theorem ker_le_zmultiples_of_ker_eq {A B : Type*} [AddCommGroup A] [AddCommGroup B]
+    (φ : A →+ B) {Q : A} {M : ℕ} (hker : φ.ker = AddSubgroup.zmultiples (M • Q)) :
+    φ.ker ≤ AddSubgroup.zmultiples Q := by
+  rw [hker, AddSubgroup.zmultiples_le]
+  exact AddSubgroup.nsmul_mem _ (AddSubgroup.mem_zmultiples Q) M
+
+theorem ker_comp_eq_zmultiples {A B C : Type*} [AddCommGroup A] [AddCommGroup B]
+    [AddCommGroup C] (φ : A →+ B) (ψ : B →+ C) {Q : A}
+    (hφ : φ.ker ≤ AddSubgroup.zmultiples Q) (hψ : ψ.ker = AddSubgroup.zmultiples (φ Q)) :
+    (ψ.comp φ).ker = AddSubgroup.zmultiples Q := by
+  ext x
+  rw [AddMonoidHom.mem_ker, AddMonoidHom.comp_apply]
+  constructor
+  · intro hx
+    have hx' : φ x ∈ ψ.ker := hx
+    rw [hψ, AddSubgroup.mem_zmultiples_iff] at hx'
+    obtain ⟨k, hk⟩ := hx'
+    have hmem : x - k • Q ∈ φ.ker := by
+      rw [AddMonoidHom.mem_ker, map_sub, map_zsmul, hk, sub_self]
+    have hk' : k • Q ∈ AddSubgroup.zmultiples Q :=
+      AddSubgroup.zsmul_mem _ (AddSubgroup.mem_zmultiples Q) k
+    simpa using AddSubgroup.add_mem _ (hφ hmem) hk'
+  · intro hx
+    rw [AddSubgroup.mem_zmultiples_iff] at hx
+    obtain ⟨k, rfl⟩ := hx
+    have h0 : ψ (φ Q) = 0 := by
+      rw [← AddMonoidHom.mem_ker, hψ]
+      exact AddSubgroup.mem_zmultiples _
+    rw [map_zsmul, map_zsmul, h0, zsmul_zero]
+
+theorem natCard_zmultiples_of_addOrderOf_eq {A : Type*} [AddCommGroup A] (Q : A) {N : ℕ}
+    (hQ : addOrderOf Q = N) : Nat.card (AddSubgroup.zmultiples Q) = N := by
+  rw [Nat.card_zmultiples, hQ]
+
+theorem nsmul_not_mem_ker {A B : Type*} [AddCommGroup A] [AddCommGroup B] (φ : A →+ B)
+    {Q : A} {M : ℕ} (hQ : addOrderOf Q = 2 * M)
+    (hker : φ.ker = AddSubgroup.zmultiples (M • Q)) {k : ℕ} (hk0 : 0 < k) (hk2 : k < 2 * M)
+    (hkM : k ≠ M) : k • Q ∉ φ.ker := by
+  rw [hker]
+  intro hk
+  obtain ⟨c, rfl⟩ := dvd_of_nsmul_mem_zmultiples_nsmul hQ hk
+  rcases c with _ | _ | c
+  · exact absurd rfl (Nat.pos_iff_ne_zero.mp hk0)
+  · exact hkM (mul_one M)
+  · exact absurd hk2 (by nlinarith)
+
+theorem addOrderOf_veluPointMap2 {F : Type*} [Field F] [DecidableEq F] (hchar : (2 : F) ≠ 0)
+    (W : WeierstrassCurve F) [W.IsElliptic] (Q : W.toAffine.Point) (M : ℕ) (hM : M ≠ 0)
+    (hQ : addOrderOf Q = 2 * M)
+    {x₀ y₀ : F} {h₀ : W.toAffine.Nonsingular x₀ y₀} (hMQ : M • Q = .some x₀ y₀ h₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hΔ₂ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0)
+    (hker₀ : ∀ P : W.toAffine.Point,
+      WeierstrassCurve.veluPointMap2 hchar h₀.1 hgy hΔ₂ P = 0 ↔ P = 0 ∨ P = .some x₀ y₀ h₀) :
+    addOrderOf (WeierstrassCurve.veluPointMap2 hchar h₀.1 hgy hΔ₂ Q) = M := by
+  obtain ⟨φ, hφ⟩ := W.exists_addMonoidHom_coe_eq_veluPointMap2 hchar h₀.1 hgy hΔ₂
+  have h2MQ : 2 • (M • Q) = 0 := by
+    rw [← mul_nsmul', ← hQ]
+    exact addOrderOf_nsmul_eq_zero Q
+  have hker : φ.ker = AddSubgroup.zmultiples (M • Q) := by
+    ext P
+    rw [AddMonoidHom.mem_ker, congrFun hφ P, hker₀ P,
+      mem_zmultiples_iff_of_two_nsmul_eq_zero h2MQ, hMQ]
+  have h := addOrderOf_map_of_ker_eq_zmultiples φ hM hQ hker
+  rwa [congrFun hφ Q] at h
+
+example : addOrderOf (AddMonoidHom.mulLeft (2 : ZMod 4) 1) = 2 :=
+  addOrderOf_map_of_ker_eq_zmultiples (AddMonoidHom.mulLeft (2 : ZMod 4)) (Q := 1) (M := 2)
+    two_ne_zero (by rw [ZMod.addOrderOf_one]) (by
+      ext x
+      rw [AddMonoidHom.mem_ker, AddMonoidHom.coe_mulLeft,
+        mem_zmultiples_iff_of_two_nsmul_eq_zero (by decide)]
+      revert x
+      decide)
+
+example : ((AddMonoidHom.mulLeft (2 : ZMod 4)).comp (AddMonoidHom.mulLeft (2 : ZMod 4))).ker =
+    AddSubgroup.zmultiples (1 : ZMod 4) := by
+  have hker : (AddMonoidHom.mulLeft (2 : ZMod 4)).ker = AddSubgroup.zmultiples (2 • (1 : ZMod 4)) :=
+    by
+    ext x
+    rw [AddMonoidHom.mem_ker, AddMonoidHom.coe_mulLeft,
+      mem_zmultiples_iff_of_two_nsmul_eq_zero (by decide)]
+    revert x
+    decide
+  refine ker_comp_eq_zmultiples _ _ (ker_le_zmultiples_of_ker_eq _ hker) ?_
+  rw [hker, AddMonoidHom.coe_mulLeft]
+  rfl
+
+end KernelTower
+
+namespace WeierstrassCurve
+namespace VeluTwoKernel
+
+theorem negY_eq_of_veluGy_eq_zero {R : Type*} [CommRing R] {W : WeierstrassCurve R}
+    {x₀ y₀ : R} (hgy : W.veluGy x₀ y₀ = 0) : W.toAffine.negY x₀ y₀ = y₀ := by
+  simp only [veluGy] at hgy
+  simp only [Affine.negY]
+  linear_combination hgy
+
+theorem eq_of_equation_of_veluGy_eq_zero {F : Type*} [Field F] {W : WeierstrassCurve F}
+    {x₀ y₀ : F} (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0)
+    {y : F} (h : W.toAffine.Equation x₀ y) : y = y₀ := by
+  rcases Affine.Y_eq_of_X_eq h hQ rfl with hy | hy
+  · exact hy
+  · rw [hy, negY_eq_of_veluGy_eq_zero hgy]
+
+theorem some_eq_some_of_veluGy_eq_zero {F : Type*} [Field F] {W : WeierstrassCurve F}
+    {x₀ y₀ : F} (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0)
+    (hns : W.toAffine.Nonsingular x₀ y₀) {x y : F} (h : W.toAffine.Nonsingular x y)
+    (hx : x = x₀) : (.some x y h : W.toAffine.Point) = .some x₀ y₀ hns := by
+  have hy : y = y₀ := eq_of_equation_of_veluGy_eq_zero hQ hgy (hx ▸ h.left)
+  subst hx
+  subst hy
+  rfl
+
+theorem veluPointMap2_eq_zero_iff {F : Type*} [Field F] {W : WeierstrassCurve F}
+    (h2 : (2 : F) ≠ 0) {x₀ y₀ : F} (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hΔ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0)
+    (hns : W.toAffine.Nonsingular x₀ y₀) (P : W.toAffine.Point) :
+    veluPointMap2 h2 hQ hgy hΔ P = 0 ↔ P = 0 ∨ P = .some x₀ y₀ hns := by
+  constructor
+  · intro hP
+    cases P with
+    | zero => exact Or.inl rfl
+    | some x y h =>
+      by_cases hx : x = x₀
+      · exact Or.inr (some_eq_some_of_veluGy_eq_zero hQ hgy hns h hx)
+      · rw [veluPointMap2_some_of_ne h2 hQ hgy hΔ h hx] at hP
+        exact absurd hP (Affine.Point.some_ne_zero _)
+  · rintro (rfl | rfl)
+    · exact veluPointMap2_zero h2 hQ hgy hΔ
+    · exact veluPointMap2_some_of_eq h2 hQ hgy hΔ hns rfl
+
+theorem ker_eq_zmultiples {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F}
+    (h2 : (2 : F) ≠ 0) {x₀ y₀ : F} (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hΔ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0)
+    (hns : W.toAffine.Nonsingular x₀ y₀)
+    (φ : W.toAffine.Point →+ (W.veluQuotient2 x₀ y₀).toAffine.Point)
+    (hφ : ∀ P, φ P = veluPointMap2 h2 hQ hgy hΔ P) :
+    φ.ker = AddSubgroup.zmultiples (.some x₀ y₀ hns) := by
+  refine le_antisymm ?_ (AddSubgroup.zmultiples_le.mpr ?_)
+  · intro P hP
+    rw [AddMonoidHom.mem_ker, hφ P] at hP
+    rcases (veluPointMap2_eq_zero_iff h2 hQ hgy hΔ hns P).mp hP with rfl | rfl
+    · exact zero_mem _
+    · exact AddSubgroup.mem_zmultiples _
+  · rw [AddMonoidHom.mem_ker, hφ]
+    exact veluPointMap2_some_of_eq h2 hQ hgy hΔ hns rfl
+end WeierstrassCurve.VeluTwoKernel
+
+namespace WeierstrassCurve
+
+section FiberField
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+private theorem _root_.WeierstrassCurve.xnum_eq {x y x₀ y₀ l x' : F}
+    (hl : l * (x - x₀) = y - y₀)
+    (hx'd : x' = l ^ 2 + W.a₁ * l - W.a₂ - x - x₀) :
+    x' * (x - x₀) ^ 2 = ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2)
+      := by
+  rw [hx'd]
+  linear_combination (l * (x - x₀) + (y - y₀) + W.a₁ * (x - x₀)) * hl
+
+private theorem _root_.WeierstrassCurve.ynum_eq {x y x₀ y₀ l x' y' : F}
+    (hl : l * (x - x₀) = y - y₀)
+    (hx'd : x' = l ^ 2 + W.a₁ * l - W.a₂ - x - x₀)
+    (hy'd : y' = l * (x - x') - y - W.a₁ * x' - W.a₃) :
+    y' * (x - x₀) ^ 3 = ((y - y₀) * (x * (x - x₀) ^ 2 - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) -
+      (W.a₂ + x + x₀) * (x - x₀) ^ 2)) - y * (x - x₀) ^ 3 - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) *
+      (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (x - x₀) - W.a₃ * (x - x₀) ^ 3) := by
+  have hXn := W.xnum_eq hl hx'd
+  rw [hy'd]
+  linear_combination (x * (x - x₀) ^ 2 - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x +
+    x₀) * (x - x₀) ^ 2)) * hl
+    - (l + W.a₁) * (x - x₀) * hXn
+
+private theorem _root_.WeierstrassCurve.fiberAdd_veluGx_field (hchar : (2 : F) ≠ 0)
+    {x y x₀ y₀ l x' y' : F}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hx : x ≠ x₀)
+    (hl : l * (x - x₀) = y - y₀)
+    (hx'd : x' = l ^ 2 + W.a₁ * l - W.a₂ - x - x₀)
+    (hy'd : y' = l * (x - x') - y - W.a₁ * x' - W.a₃) :
+    W.veluGx x y + W.veluGx x' y'
+      = 3 * (x + W.veluGx x₀ y₀ / (x - x₀)) ^ 2 + 2 * W.a₂ * (x + W.veluGx x₀ y₀ / (x - x₀)) + (W.a₄
+        - 5 * W.veluGx x₀ y₀) - W.a₁ * (y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^
+        2) := by
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  have h4 : (4 : F) ≠ 0 := by
+    have h := pow_ne_zero 2 hchar
+    norm_num at h
+    exact h
+  have hXn := W.xnum_eq hl hx'd
+  have hYn := W.ynum_eq hl hx'd hy'd
+  have hXd : (x + W.veluGx x₀ y₀ / (x - x₀)) * (x - x₀) = x * (x - x₀) + W.veluGx x₀ y₀ :=
+    by field_simp
+  have hYd : (y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) * (x - x₀) ^ 2
+      = y * (x - x₀) ^ 2 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) := by field_simp
+  refine mul_right_cancel₀ (mul_ne_zero h4 (pow_ne_zero 4 hd)) ?_
+  calc (W.veluGx x y + W.veluGx x' y') * (4 * (x - x₀) ^ 4)
+      = 4 * (W.veluGx x y * (x - x₀) ^ 4 + (3 * (x' * (x - x₀) ^ 2) ^ 2 + 2 * W.a₂ * (x' * (x - x₀)
+        ^ 2) * (x - x₀) ^ 2 + W.a₄ * (x - x₀) ^ 4 - W.a₁ * (y' * (x - x₀) ^ 3) * (x - x₀))) := by
+        simp only [veluGx]; ring
+    _ = 4 * (W.veluGx x y * (x - x₀) ^ 4 + (3 * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ +
+      x + x₀) * (x - x₀) ^ 2) ^ 2 + 2 * W.a₂ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ +
+      x + x₀) * (x - x₀) ^ 2) * (x - x₀) ^ 2 + W.a₄ * (x - x₀) ^ 4 - W.a₁ * ((y - y₀) * (x * (x -
+      x₀) ^ 2 - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2)) - y *
+      (x - x₀) ^ 3 - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀)
+      ^ 2) * (x - x₀) - W.a₃ * (x - x₀) ^ 3) * (x - x₀))) := by
+      rw [hXn, hYn]
+    _ = 4 * (3 * (x * (x - x₀) ^ 2 + W.veluGx x₀ y₀ * (x - x₀)) ^ 2 + 2 * W.a₂ * (x * (x - x₀) ^ 2 +
+      W.veluGx x₀ y₀ * (x - x₀)) * (x - x₀) ^ 2 + (W.a₄ - 5 * W.veluGx x₀ y₀) * (x - x₀) ^ 4 - W.a₁
+      * (y * (x - x₀) ^ 3 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) * (x - x₀)) * (x - x₀)) :=
+      W.fiberAdd_veluGx_cleared_four x y x₀ y₀ hP hQ hgy
+    _ = (3 * (x + W.veluGx x₀ y₀ / (x - x₀)) ^ 2 + 2 * W.a₂ * (x + W.veluGx x₀ y₀ / (x - x₀)) +
+      (W.a₄ - 5 * W.veluGx x₀ y₀) - W.a₁ * (y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x -
+      x₀) ^ 2))
+          * (4 * (x - x₀) ^ 4) := by
+        rw [show (3 * (x + W.veluGx x₀ y₀ / (x - x₀)) ^ 2 + 2 * W.a₂ * (x + W.veluGx x₀ y₀ / (x -
+          x₀)) + (W.a₄ - 5 * W.veluGx x₀ y₀) - W.a₁ * (y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y -
+          y₀) / (x - x₀) ^ 2))
+              * (4 * (x - x₀) ^ 4)
+          = 4 * (3 * ((x + W.veluGx x₀ y₀ / (x - x₀)) * (x - x₀)) ^ 2 * (x - x₀) ^ 2
+            + 2 * W.a₂ * ((x + W.veluGx x₀ y₀ / (x - x₀)) * (x - x₀)) * (x - x₀) ^ 3
+            + (W.a₄ - 5 * W.veluGx x₀ y₀) * (x - x₀) ^ 4
+            - W.a₁ * ((y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) * (x - x₀) ^
+              2) * (x - x₀) ^ 2) from by
+              ring, hXd, hYd]
+        ring
+
+private theorem _root_.WeierstrassCurve.fiberAdd_asymWeight_field (hchar : (2 : F) ≠ 0) {x y x₀ y₀ l
+    x' y' : F}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hx : x ≠ x₀)
+    (hl : l * (x - x₀) = y - y₀)
+    (hx'd : x' = l ^ 2 + W.a₁ * l - W.a₂ - x - x₀)
+    (hy'd : y' = l * (x - x') - y - W.a₁ * x' - W.a₃) :
+    (x * W.veluGx x y - y * W.veluGy x y) + (x' * W.veluGx x' y' - y' * W.veluGy x' y')
+      = (x + W.veluGx x₀ y₀ / (x - x₀)) * (3 * (x + W.veluGx x₀ y₀ / (x - x₀)) ^ 2 + 2 * W.a₂ * (x +
+          W.veluGx x₀ y₀ / (x - x₀)) + (W.a₄ - 5 * W.veluGx x₀ y₀) - W.a₁ * (y - W.veluGx x₀ y₀ *
+          (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2))
+        - (y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) * (-(2 * (y - W.veluGx x₀
+            y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) + W.a₁ * (x + W.veluGx x₀ y₀ / (x - x₀))
+            + W.a₃)) := by
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  have h16 : (16 : F) ≠ 0 := by
+    have h := pow_ne_zero 4 hchar
+    norm_num at h
+    exact h
+  have hXn := W.xnum_eq hl hx'd
+  have hYn := W.ynum_eq hl hx'd hy'd
+  have hXd : (x + W.veluGx x₀ y₀ / (x - x₀)) * (x - x₀) = x * (x - x₀) + W.veluGx x₀ y₀ :=
+    by field_simp
+  have hYd : (y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) * (x - x₀) ^ 2
+      = y * (x - x₀) ^ 2 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) := by field_simp
+  refine mul_right_cancel₀ (mul_ne_zero h16 (pow_ne_zero 6 hd)) ?_
+  calc ((x * W.veluGx x y - y * W.veluGy x y)
+        + (x' * W.veluGx x' y' - y' * W.veluGy x' y')) * (16 * (x - x₀) ^ 6)
+      = 16 * ((x * W.veluGx x y - y * W.veluGy x y) * (x - x₀) ^ 6 + ((x' * (x - x₀) ^ 2) * (3 * (x'
+          * (x - x₀) ^ 2) ^ 2 + 2 * W.a₂ * (x' * (x - x₀) ^ 2) * (x - x₀) ^ 2 + W.a₄ * (x - x₀) ^ 4
+          - W.a₁ * (y' * (x - x₀) ^ 3) * (x - x₀)) - (y' * (x - x₀) ^ 3) * (-(2 * (y' * (x - x₀) ^
+          3) + W.a₁ * (x' * (x - x₀) ^ 2) * (x - x₀) + W.a₃ * (x - x₀) ^ 3)))) := by
+        simp only [veluGx, veluGy]; ring
+    _ = 16 * ((x * W.veluGx x y - y * W.veluGy x y) * (x - x₀) ^ 6 + (((y - y₀) ^ 2 + W.a₁ * (y -
+        y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (3 * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x
+        - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2) ^ 2 + 2 * W.a₂ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) *
+        (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (x - x₀) ^ 2 + W.a₄ * (x - x₀) ^ 4 - W.a₁ * ((y
+        - y₀) * (x * (x - x₀) ^ 2 - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) *
+        (x - x₀) ^ 2)) - y * (x - x₀) ^ 3 - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) -
+        (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (x - x₀) - W.a₃ * (x - x₀) ^ 3) * (x - x₀)) - ((y - y₀) *
+        (x * (x - x₀) ^ 2 - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀)
+        ^ 2)) - y * (x - x₀) ^ 3 - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x +
+        x₀) * (x - x₀) ^ 2) * (x - x₀) - W.a₃ * (x - x₀) ^ 3) * (-(2 * ((y - y₀) * (x * (x - x₀) ^ 2
+        - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2)) - y * (x -
+        x₀) ^ 3 - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^
+        2) * (x - x₀) - W.a₃ * (x - x₀) ^ 3) + W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) -
+        (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (x - x₀) + W.a₃ * (x - x₀) ^ 3)))) := by
+      rw [hXn, hYn]
+    _ = 16 * ((x * (x - x₀) + W.veluGx x₀ y₀) * (3 * (x * (x - x₀) + W.veluGx x₀ y₀) ^ 2 + 2 * W.a₂
+        * (x * (x - x₀) + W.veluGx x₀ y₀) * (x - x₀) + (W.a₄ - 5 * W.veluGx x₀ y₀) * (x - x₀) ^ 2 -
+        W.a₁ * (y * (x - x₀) ^ 2 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀))) * (x - x₀) ^ 3 - (y
+        * (x - x₀) ^ 2 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀)) * (-(2 * (y * (x - x₀) ^ 2 -
+        W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀)) + W.a₁ * (x * (x - x₀) + W.veluGx x₀ y₀) * (x -
+        x₀) + W.a₃ * (x - x₀) ^ 2)) * (x - x₀) ^ 2) := W.fiberAdd_asymWeight_cleared_sixteen x y x₀
+        y₀ hP hQ hgy
+    _ = ((x + W.veluGx x₀ y₀ / (x - x₀)) * (3 * (x + W.veluGx x₀ y₀ / (x - x₀)) ^ 2 + 2 * W.a₂ * (x
+        + W.veluGx x₀ y₀ / (x - x₀)) + (W.a₄ - 5 * W.veluGx x₀ y₀) - W.a₁ * (y - W.veluGx x₀ y₀ *
+        (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2))
+        - (y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) * (-(2 * (y - W.veluGx x₀
+            y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) + W.a₁ * (x + W.veluGx x₀ y₀ / (x - x₀))
+            + W.a₃))) * (16 * (x - x₀) ^ 6) := by
+        rw [show ((x + W.veluGx x₀ y₀ / (x - x₀)) * (3 * (x + W.veluGx x₀ y₀ / (x - x₀)) ^ 2 + 2 *
+            W.a₂ * (x + W.veluGx x₀ y₀ / (x - x₀)) + (W.a₄ - 5 * W.veluGx x₀ y₀) - W.a₁ * (y -
+            W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2))
+            - (y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) * (-(2 * (y -
+                W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) + W.a₁ * (x + W.veluGx
+                x₀ y₀ / (x - x₀)) + W.a₃))) * (16 * (x - x₀) ^ 6)
+          = 16 * (((x + W.veluGx x₀ y₀ / (x - x₀)) * (x - x₀))
+              * (3 * ((x + W.veluGx x₀ y₀ / (x - x₀)) * (x - x₀)) ^ 2 + 2 * W.a₂ * ((x + W.veluGx x₀
+                  y₀ / (x - x₀)) * (x - x₀)) * (x - x₀)
+                + (W.a₄ - 5 * W.veluGx x₀ y₀) * (x - x₀) ^ 2 - W.a₁ * ((y - W.veluGx x₀ y₀ * (W.a₁ *
+                    (x - x₀) + y - y₀) / (x - x₀) ^ 2) * (x - x₀) ^ 2))
+              * (x - x₀) ^ 3
+            - ((y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) * (x - x₀) ^ 2)
+              * (-(2 * ((y - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) / (x - x₀) ^ 2) * (x - x₀)
+                  ^ 2) + W.a₁ * ((x + W.veluGx x₀ y₀ / (x - x₀)) * (x - x₀)) * (x - x₀)
+                + W.a₃ * (x - x₀) ^ 2))
+              * (x - x₀) ^ 2) from by ring, hXd, hYd]
+
+end FiberField
+
+section EvenStage
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F}
+
+private theorem nsmul_ne_zero {Q : W.toAffine.Point} {N k : ℕ} (hQ : addOrderOf Q = N)
+    (hk1 : 1 ≤ k) (hkN : k < N) : k • Q ≠ 0 := by
+  intro h
+  have hdvd : N ∣ k := hQ ▸ addOrderOf_dvd_of_nsmul_eq_zero h
+  have := Nat.eq_zero_of_dvd_of_lt hdvd hkN
+  omega
+
+private theorem nsmul_injOn {Q : W.toAffine.Point} {N : ℕ} (hQ : addOrderOf Q = N)
+    {j k : ℕ} (hj1 : 1 ≤ j) (hjN : j < N) (hk1 : 1 ≤ k) (hkN : k < N)
+    (h : j • Q = k • Q) : j = k := by
+  by_contra hne
+  wlog hlt : j < k generalizing j k
+  · exact this hk1 hkN hj1 hjN h.symm (Ne.symm hne) (by omega)
+  have hsum : (k - j) • Q + j • Q = k • Q := by
+    rw [← add_nsmul, Nat.sub_add_cancel (le_of_lt hlt)]
+  have hzero : (k - j) • Q = 0 := by
+    have h0 : (k - j) • Q + j • Q = 0 + j • Q := by rw [hsum, ← h, zero_add]
+    exact add_right_cancel h0
+  exact nsmul_ne_zero hQ (by omega) (by omega) hzero
+
+omit [DecidableEq F] in
+private theorem exists_some_of_ne_zero {P : W.toAffine.Point} (h : P ≠ 0) :
+    ∃ x y hns, P = Affine.Point.some x y hns := by
+  cases P with
+  | zero => exact absurd rfl h
+  | some x y hns => exact ⟨x, y, hns, rfl⟩
+
+private theorem x_ne_middle {Q : W.toAffine.Point} {M : ℕ}
+    (hord : addOrderOf Q = 2 * M) {x₀ y₀ : F} {h₀ : W.toAffine.Nonsingular x₀ y₀}
+    (hMQ : M • Q = .some x₀ y₀ h₀) (hgy : W.veluGy x₀ y₀ = 0)
+    {k : ℕ} (hk1 : 1 ≤ k) (hk2 : k < 2 * M) (hkM : k ≠ M)
+    {xk yk : F} {hk : W.toAffine.Nonsingular xk yk} (hkQ : k • Q = .some xk yk hk) :
+    xk ≠ x₀ := by
+  intro hx
+  have hy := Affine.Y_eq_of_X_eq hk.1 h₀.1 hx
+  have hnegY : W.toAffine.negY x₀ y₀ = y₀ := VeluTwoKernel.negY_eq_of_veluGy_eq_zero hgy
+  have hyk : yk = y₀ := by
+    rcases hy with h | h
+    · exact h
+    · rw [hnegY] at h; exact h
+  subst hx hyk
+  have hkM' : k • Q = M • Q := by rw [hkQ, hMQ]
+  exact hkM (nsmul_injOn hord hk1 hk2 (by omega) (by omega) hkM')
+
+private theorem fiber_gx_point (hchar : (2 : F) ≠ 0) {x y x₀ y₀ : F}
+    (hP : W.toAffine.Nonsingular x y) (h₀ : W.toAffine.Nonsingular x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hx : x ≠ x₀) :
+    W.veluGx x y
+        + W.veluGx (W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y y₀))
+          (W.toAffine.addY x x₀ y (W.toAffine.slope x x₀ y y₀))
+      = (W.veluQuotient2 x₀ y₀).veluGx (W.velu2X x₀ y₀ x) (W.velu2Y x₀ y₀ x y) := by
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  have hl : W.toAffine.slope x x₀ y y₀ * (x - x₀) = y - y₀ := by
+    rw [Affine.slope_of_X_ne hx, div_mul_cancel₀ _ hd]
+  have h := W.fiberAdd_veluGx_field hchar hP.1 h₀.1 hgy hx hl
+    (x' := W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y y₀))
+    (y' := W.toAffine.addY x x₀ y (W.toAffine.slope x x₀ y y₀))
+    (by simp [Affine.addX]) (by simp [Affine.addY, Affine.negAddY, Affine.negY, Affine.addX]; ring)
+  rw [h]
+  simp only [veluGx, veluQuotient2_a₁, veluQuotient2_a₂, veluQuotient2_a₄, velu2X, velu2Y]
+
+private theorem fiber_asym_point (hchar : (2 : F) ≠ 0) {x y x₀ y₀ : F}
+    (hP : W.toAffine.Nonsingular x y) (h₀ : W.toAffine.Nonsingular x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hx : x ≠ x₀) :
+    (x * W.veluGx x y - y * W.veluGy x y)
+        + (W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y y₀)
+            * W.veluGx (W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y y₀))
+              (W.toAffine.addY x x₀ y (W.toAffine.slope x x₀ y y₀))
+          - W.toAffine.addY x x₀ y (W.toAffine.slope x x₀ y y₀)
+            * W.veluGy (W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y y₀))
+              (W.toAffine.addY x x₀ y (W.toAffine.slope x x₀ y y₀)))
+      = (W.velu2X x₀ y₀ x
+            * (W.veluQuotient2 x₀ y₀).veluGx (W.velu2X x₀ y₀ x) (W.velu2Y x₀ y₀ x y)
+          - W.velu2Y x₀ y₀ x y
+            * (W.veluQuotient2 x₀ y₀).veluGy (W.velu2X x₀ y₀ x) (W.velu2Y x₀ y₀ x y)) := by
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  have hl : W.toAffine.slope x x₀ y y₀ * (x - x₀) = y - y₀ := by
+    rw [Affine.slope_of_X_ne hx, div_mul_cancel₀ _ hd]
+  have h := W.fiberAdd_asymWeight_field hchar hP.1 h₀.1 hgy hx hl
+    (x' := W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y y₀))
+    (y' := W.toAffine.addY x x₀ y (W.toAffine.slope x x₀ y y₀))
+    (by simp [Affine.addX]) (by simp [Affine.addY, Affine.negAddY, Affine.negY, Affine.addX]; ring)
+  rw [h]
+  simp only [veluGx, veluGy, veluQuotient2_a₁, veluQuotient2_a₂, veluQuotient2_a₃,
+    veluQuotient2_a₄, velu2X, velu2Y]
+
+private theorem sum_split (hchar : (2 : F) ≠ 0) {Q : W.toAffine.Point} {M : ℕ} (hM : M ≠ 0)
+    (hord : addOrderOf Q = 2 * M) {x₀ y₀ : F} {h₀ : W.toAffine.Nonsingular x₀ y₀}
+    (hMQ : M • Q = .some x₀ y₀ h₀) (hgy : W.veluGy x₀ y₀ = 0)
+    (hΔ₂ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0) [W.IsElliptic]
+    (g g₁ : F × F → F)
+    (hfiber : ∀ k, 1 ≤ k → k < M →
+      g ((k • Q).coordsOrZero) + g (((k + M) • Q).coordsOrZero)
+        = g₁ ((veluPointMap2 hchar h₀.1 hgy hΔ₂ (k • Q)).coordsOrZero)) :
+    ∑ P ∈ W.oddOrderSummingSet Q (2 * M - 1), g P
+      = g (x₀, y₀)
+        + ∑ P ∈ (W.veluQuotient2 x₀ y₀).oddOrderSummingSet
+            (veluPointMap2 hchar h₀.1 hgy hΔ₂ Q) (M - 1), g₁ P := by
+  obtain ⟨m, rfl⟩ := Nat.exists_eq_succ_of_ne_zero hM
+  rw [show 2 * (m + 1) - 1 = 2 * m + 1 from by omega, show m + 1 - 1 = m from by omega]
+  have hordQ' : addOrderOf (veluPointMap2 hchar h₀.1 hgy hΔ₂ Q) = m + 1 :=
+    KernelTower.addOrderOf_veluPointMap2 hchar W Q (m + 1) (by omega) hord hMQ hgy hΔ₂
+      (VeluTwoKernel.veluPointMap2_eq_zero_iff hchar h₀.1 hgy hΔ₂ h₀)
+  obtain ⟨φ, hφ⟩ := W.exists_addMonoidHom_coe_eq_veluPointMap2 hchar h₀.1 hgy hΔ₂
+  have himg : ∀ k : ℕ, k • veluPointMap2 hchar h₀.1 hgy hΔ₂ Q
+      = veluPointMap2 hchar h₀.1 hgy hΔ₂ (k • Q) := by
+    intro k
+    rw [← hφ]
+    exact (map_nsmul φ k Q).symm
+  have hinjL : Set.InjOn (fun k => (k • Q).coordsOrZero)
+      (Finset.Icc 1 (2 * m + 1) : Set ℕ) := by
+    intro j hj k hk hjk
+    simp only [Finset.coe_Icc, Set.mem_Icc] at hj hk
+    obtain ⟨xj, yj, hnsj, hjQ⟩ := exists_some_of_ne_zero
+      (nsmul_ne_zero hord hj.1 (by omega))
+    obtain ⟨xk, yk, hnsk, hkQ⟩ := exists_some_of_ne_zero
+      (nsmul_ne_zero hord hk.1 (by omega))
+    simp only [hjQ, hkQ, Affine.Point.coordsOrZero_some, Prod.mk.injEq] at hjk
+    refine nsmul_injOn hord hj.1 (by omega) hk.1 (by omega) ?_
+    rw [hjQ, hkQ]
+    obtain ⟨h1, h2⟩ := hjk
+    subst h1; subst h2; rfl
+  have hinjR : Set.InjOn (fun k => (k • veluPointMap2 hchar h₀.1 hgy hΔ₂ Q).coordsOrZero)
+      (Finset.Icc 1 m : Set ℕ) := by
+    intro j hj k hk hjk
+    simp only [Finset.coe_Icc, Set.mem_Icc] at hj hk
+    obtain ⟨xj, yj, hnsj, hjQ⟩ := exists_some_of_ne_zero
+      (nsmul_ne_zero hordQ' hj.1 (by omega))
+    obtain ⟨xk, yk, hnsk, hkQ⟩ := exists_some_of_ne_zero
+      (nsmul_ne_zero hordQ' hk.1 (by omega))
+    simp only [hjQ, hkQ, Affine.Point.coordsOrZero_some, Prod.mk.injEq] at hjk
+    refine nsmul_injOn hordQ' hj.1 (by omega) hk.1 (by omega) ?_
+    rw [hjQ, hkQ]
+    obtain ⟨h1, h2⟩ := hjk
+    subst h1; subst h2; rfl
+  have hL : ∑ P ∈ W.oddOrderSummingSet Q (2 * m + 1), g P
+      = ∑ k ∈ Finset.Icc 1 (2 * m + 1), g ((k • Q).coordsOrZero) := by
+    simp only [oddOrderSummingSet]
+    exact Finset.sum_image hinjL
+  have hR : ∑ P ∈ (W.veluQuotient2 x₀ y₀).oddOrderSummingSet
+        (veluPointMap2 hchar h₀.1 hgy hΔ₂ Q) m, g₁ P
+      = ∑ k ∈ Finset.Icc 1 m,
+          g₁ ((veluPointMap2 hchar h₀.1 hgy hΔ₂ (k • Q)).coordsOrZero) := by
+    simp only [oddOrderSummingSet]
+    rw [Finset.sum_image hinjR]
+    exact Finset.sum_congr rfl fun k _ => by rw [himg]
+  rw [hL, hR]
+  have e1 : (Finset.Icc 1 (2 * m + 1) : Finset ℕ) = Finset.Ioc 0 (2 * m + 1) := by
+    ext a
+    simp [Nat.lt_iff_add_one_le]
+  have e2 : (Finset.Icc 1 m : Finset ℕ) = Finset.Ioc 0 m := by
+    ext a
+    simp [Nat.lt_iff_add_one_le]
+  rw [e1, e2, ← Finset.sum_Ioc_consecutive _ (Nat.zero_le (m + 1))
+    (by omega : m + 1 ≤ 2 * m + 1), Finset.sum_Ioc_succ_top (Nat.zero_le m)]
+  have e3 : Finset.Ioc (m + 1) (2 * m + 1)
+      = (Finset.Ioc 0 m).map (addLeftEmbedding (m + 1)) := by
+    rw [Finset.map_add_left_Ioc]
+    congr 1
+    omega
+  rw [e3, Finset.sum_map]
+  have hmid : g (((m + 1) • Q).coordsOrZero) = g (x₀, y₀) := by
+    rw [hMQ, Affine.Point.coordsOrZero_some]
+  have hpair : ∀ k ∈ Finset.Ioc 0 m,
+      g ((k • Q).coordsOrZero) + g ((addLeftEmbedding (m + 1) k • Q).coordsOrZero)
+        = g₁ ((veluPointMap2 hchar h₀.1 hgy hΔ₂ (k • Q)).coordsOrZero) := by
+    intro k hk
+    simp only [Finset.mem_Ioc] at hk
+    have : addLeftEmbedding (m + 1) k = k + (m + 1) := by
+      simp [addLeftEmbedding_apply, Nat.add_comm]
+    rw [this]
+    exact hfiber k (by omega) (by omega)
+  calc (∑ k ∈ Finset.Ioc 0 m, g ((k • Q).coordsOrZero)) + g (((m + 1) • Q).coordsOrZero)
+        + ∑ k ∈ Finset.Ioc 0 m, g ((addLeftEmbedding (m + 1) k • Q).coordsOrZero)
+      = g (((m + 1) • Q).coordsOrZero)
+        + ((∑ k ∈ Finset.Ioc 0 m, g ((k • Q).coordsOrZero))
+          + ∑ k ∈ Finset.Ioc 0 m, g ((addLeftEmbedding (m + 1) k • Q).coordsOrZero)) := by
+        ring
+    _ = g (x₀, y₀) + ∑ k ∈ Finset.Ioc 0 m,
+          g₁ ((veluPointMap2 hchar h₀.1 hgy hΔ₂ (k • Q)).coordsOrZero) := by
+        rw [hmid, ← Finset.sum_add_distrib, Finset.sum_congr rfl hpair]
+    _ = g (x₀, y₀) + ∑ k ∈ Finset.Icc 1 m,
+          g₁ ((veluPointMap2 hchar h₀.1 hgy hΔ₂ (k • Q)).coordsOrZero) := by
+        rw [e2]
+
+end EvenStage
+
+theorem fullKernelQuotient_eq_fullKernelQuotient_veluPointMap2
+    {F : Type*} [Field F] [DecidableEq F] (hchar : (2 : F) ≠ 0)
+    (W : WeierstrassCurve F) [W.IsElliptic] (Q : W.toAffine.Point) (M : ℕ) (hM : M ≠ 0)
+    (hQ : addOrderOf Q = 2 * M)
+    {x₀ y₀ : F} {h₀ : W.toAffine.Nonsingular x₀ y₀} (hMQ : M • Q = .some x₀ y₀ h₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hΔ₂ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0) :
+    W.fullKernelQuotient Q (2 * M)
+      = (W.veluQuotient2 x₀ y₀).fullKernelQuotient
+          (veluPointMap2 hchar h₀.1 hgy hΔ₂ Q) M := by
+  have hfibT : ∀ k, 1 ≤ k → k < M →
+      (fun P : F × F => W.veluGx P.1 P.2) ((k • Q).coordsOrZero)
+        + (fun P : F × F => W.veluGx P.1 P.2) (((k + M) • Q).coordsOrZero)
+        = (fun P : F × F => (W.veluQuotient2 x₀ y₀).veluGx P.1 P.2)
+            ((veluPointMap2 hchar h₀.1 hgy hΔ₂ (k • Q)).coordsOrZero) := by
+    intro k hk1 hkM
+    obtain ⟨xk, yk, hk, hkQ⟩ := exists_some_of_ne_zero (nsmul_ne_zero hQ hk1 (by omega))
+    have hx : xk ≠ x₀ := x_ne_middle hQ hMQ hgy hk1 (by omega) (by omega) hkQ
+    simp only [add_nsmul, hkQ, hMQ, Affine.Point.add_of_X_ne hx,
+      veluPointMap2_some_of_ne hchar h₀.1 hgy hΔ₂ hk hx, Affine.Point.coordsOrZero_some]
+    exact fiber_gx_point hchar hk h₀ hgy hx
+  have hfibW : ∀ k, 1 ≤ k → k < M →
+      (fun P : F × F => P.1 * W.veluGx P.1 P.2 - P.2 * W.veluGy P.1 P.2)
+          ((k • Q).coordsOrZero)
+        + (fun P : F × F => P.1 * W.veluGx P.1 P.2 - P.2 * W.veluGy P.1 P.2)
+            (((k + M) • Q).coordsOrZero)
+        = (fun P : F × F => P.1 * (W.veluQuotient2 x₀ y₀).veluGx P.1 P.2
+              - P.2 * (W.veluQuotient2 x₀ y₀).veluGy P.1 P.2)
+            ((veluPointMap2 hchar h₀.1 hgy hΔ₂ (k • Q)).coordsOrZero) := by
+    intro k hk1 hkM
+    obtain ⟨xk, yk, hk, hkQ⟩ := exists_some_of_ne_zero (nsmul_ne_zero hQ hk1 (by omega))
+    have hx : xk ≠ x₀ := x_ne_middle hQ hMQ hgy hk1 (by omega) (by omega) hkQ
+    simp only [add_nsmul, hkQ, hMQ, Affine.Point.add_of_X_ne hx,
+      veluPointMap2_some_of_ne hchar h₀.1 hgy hΔ₂ hk hx, Affine.Point.coordsOrZero_some]
+    exact fiber_asym_point hchar hk h₀ hgy hx
+  have hT := sum_split hchar hM hQ hMQ hgy hΔ₂
+    (fun P : F × F => W.veluGx P.1 P.2)
+    (fun P : F × F => (W.veluQuotient2 x₀ y₀).veluGx P.1 P.2) hfibT
+  have hW := sum_split hchar hM hQ hMQ hgy hΔ₂
+    (fun P : F × F => P.1 * W.veluGx P.1 P.2 - P.2 * W.veluGy P.1 P.2)
+    (fun P : F × F => P.1 * (W.veluQuotient2 x₀ y₀).veluGx P.1 P.2
+      - P.2 * (W.veluQuotient2 x₀ y₀).veluGy P.1 P.2) hfibW
+  simp only at hT hW
+  ext
+  · simp [fullKernelQuotient, veluQuotientOfSums]
+  · simp [fullKernelQuotient, veluQuotientOfSums]
+  · simp [fullKernelQuotient, veluQuotientOfSums]
+  · simp only [fullKernelQuotient, veluQuotientOfSums_a₄, veluQuotient2_a₄]
+    linear_combination (-5 : F) * hT
+  · simp only [fullKernelQuotient, veluQuotientOfSums_a₆, veluQuotient2_a₆, veluQuotient2_b₂]
+    linear_combination (- W.b₂) * hT + (-7 : F) * hW + (7 * y₀) * hgy
+
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+namespace VeluTwoKernel
+
+theorem pointMapOfPushforward_eq_veluPointMap2 {F : Type*} [Field F] [DecidableEq F]
+    [IsAlgClosed F] [CharZero F] {W : WeierstrassCurve F} [W.toAffine.IsElliptic]
+    {x₀ y₀ : F} (h2 : (2 : F) ≠ 0) (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hΔ' : (W.veluQuotient2 x₀ y₀).Δ ≠ 0)
+    [(W.veluQuotient2 x₀ y₀).toAffine.IsElliptic]
+    [Affine.GenusOnePlaceGate W.toAffine] [Affine.AbelTheorem W.toAffine]
+    [Affine.GenusOnePlaceGate (W.veluQuotient2 x₀ y₀).toAffine]
+    [Affine.AbelTheorem (W.veluQuotient2 x₀ y₀).toAffine]
+    (ι : (W.veluQuotient2 x₀ y₀).toAffine.FunctionField →ₐ[F] W.toAffine.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : AlgebraicCurve.FiniteAlong F ι)
+    (hN : AlgebraicCurve.NormFormulaAlong F ι hfin)
+    (hseam : ∀ P : W.toAffine.Point, (Affine.placeOfPoint P).restrictAlong ι hι
+        = Affine.placeOfPoint (veluPointMap2 h2 hQ hgy hΔ' P))
+    (P : W.toAffine.Point) :
+    Affine.pointMapOfPushforward ι hι hfin hN P = veluPointMap2 h2 hQ hgy hΔ' P :=
+  Affine.pointMapOfPushforward_eq_of_seam ι hι hfin hN (veluPointMap2 h2 hQ hgy hΔ')
+    (veluPointMap2_zero h2 hQ hgy hΔ') hseam P
+
+theorem ker_pointMapOfPushforward_eq_zmultiples {F : Type*} [Field F] [DecidableEq F]
+    [IsAlgClosed F] [CharZero F] {W : WeierstrassCurve F} [W.toAffine.IsElliptic]
+    {x₀ y₀ : F} (h2 : (2 : F) ≠ 0) (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hΔ' : (W.veluQuotient2 x₀ y₀).Δ ≠ 0)
+    [(W.veluQuotient2 x₀ y₀).toAffine.IsElliptic]
+    [Affine.GenusOnePlaceGate W.toAffine] [Affine.AbelTheorem W.toAffine]
+    [Affine.GenusOnePlaceGate (W.veluQuotient2 x₀ y₀).toAffine]
+    [Affine.AbelTheorem (W.veluQuotient2 x₀ y₀).toAffine]
+    (ι : (W.veluQuotient2 x₀ y₀).toAffine.FunctionField →ₐ[F] W.toAffine.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : AlgebraicCurve.FiniteAlong F ι)
+    (hN : AlgebraicCurve.NormFormulaAlong F ι hfin)
+    (hseam : ∀ P : W.toAffine.Point, (Affine.placeOfPoint P).restrictAlong ι hι
+        = Affine.placeOfPoint (veluPointMap2 h2 hQ hgy hΔ' P))
+    (hns : W.toAffine.Nonsingular x₀ y₀) :
+    (Affine.pointMapOfPushforward ι hι hfin hN).ker
+      = AddSubgroup.zmultiples (.some x₀ y₀ hns) :=
+  ker_eq_zmultiples h2 hQ hgy hΔ' hns (Affine.pointMapOfPushforward ι hι hfin hN)
+    (pointMapOfPushforward_eq_veluPointMap2 h2 hQ hgy hΔ' ι hι hfin hN hseam)
+
+end WeierstrassCurve.VeluTwoKernel
+
+section
+open Polynomial
+
+namespace WeierstrassCurve
+namespace Affine
+namespace Point
+
+theorem exists_veluGy_eq_zero_of_addOrderOf_eq_two
+    {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F}
+    (Q : W.toAffine.Point) (hQ : addOrderOf Q = 2) :
+    ∃ (x₀ y₀ : F) (h₀ : W.toAffine.Nonsingular x₀ y₀),
+      Q = .some x₀ y₀ h₀ ∧ W.veluGy x₀ y₀ = 0 := by
+  rcases Q with _ | ⟨x, y, hns⟩
+  · rw [show (Point.zero : W.toAffine.Point) = 0 from rfl, addOrderOf_zero] at hQ
+    exact absurd hQ (by decide)
+  · refine ⟨x, y, hns, rfl, ?_⟩
+    have h2Q : (2 : ℕ) • (Point.some x y hns : W.toAffine.Point) = 0 := by
+      rw [← hQ]; exact addOrderOf_nsmul_eq_zero _
+    have hΨ : W.Ψ₂Sq.eval x = 0 :=
+      (WeierstrassCurve.Affine.Point.two_smul_some_eq_zero_iff W hns).mp h2Q
+    have hGy2 : W.veluGy x y ^ 2 = 0 := by
+      have := W.veluU_eq_Ψ₂Sq_eval hns.1
+      simp only [WeierstrassCurve.veluU] at this
+      rw [this]; exact hΨ
+    exact pow_eq_zero_iff two_ne_zero |>.mp hGy2
+
+theorem veluQuotient2_Delta_ne_zero_of_veluGy_eq_zero
+    {F : Type*} [Field F] {W : WeierstrassCurve F} [W.IsElliptic]
+    {x₀ y₀ : F} (h₀ : W.toAffine.Nonsingular x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0) :
+    (W.veluQuotient2 x₀ y₀).Δ ≠ 0 := by
+  classical
+  exact
+    (WeierstrassCurve.isElliptic_veluQuotient2_of_isElliptic h₀.1 hgy).isUnit.ne_zero
+
+end WeierstrassCurve.Affine.Point
+
+end
+
+noncomputable section
+
+open AlgebraicCurve
+
+private theorem WeierstrassCurve.Affine.pointClass_genusOnePic0Equiv
+    {F : Type*} [Field F] [DecidableEq F] {W : Affine F}
+    [GenusOnePlaceGate W] [AbelTheorem W] (c : AlgebraicCurve.Pic0 F W.FunctionField) :
+    pointClass (genusOnePic0Equiv W c) = c := by
+  rw [← genusOnePic0Equiv_symm_apply, AddEquiv.symm_apply_apply]
+
+private theorem AlgebraicCurve.Pic0.pushforwardAlongHom_comp
+    {K F F' F'' : Type*} [Field K] [Field F] [Field F'] [Field F'']
+    [Algebra K F] [Algebra K F'] [Algebra K F'']
+    (φ : F →ₐ[K] F') (χ : F' →ₐ[K] F'')
+    (hφ : φ.toRingHom.IsIntegral) (hχ : χ.toRingHom.IsIntegral)
+    (hχφ : (χ.comp φ).toRingHom.IsIntegral)
+    (hfinφ : FiniteAlong K φ) (hfinχ : FiniteAlong K χ) (hfinχφ : FiniteAlong K (χ.comp φ))
+    (hNφ : NormFormulaAlong K φ hfinφ) (hNχ : NormFormulaAlong K χ hfinχ)
+    (hNχφ : NormFormulaAlong K (χ.comp φ) hfinχφ) :
+    pushforwardAlongHom (χ.comp φ) hχφ hfinχφ hNχφ
+      = (pushforwardAlongHom φ hφ hfinφ hNφ).comp (pushforwardAlongHom χ hχ hfinχ hNχ) := by
+  refine AddMonoidHom.ext fun c => ?_
+  obtain ⟨D, rfl⟩ := Pic0.mk_surjective c
+  rw [AddMonoidHom.comp_apply, pushforwardAlongHom_mk, pushforwardAlongHom_mk,
+    pushforwardAlongHom_mk]
+  exact congrArg mk (Subtype.ext
+    ((Divisor.pushforwardAlong_pushforwardAlong φ χ hφ hχ hχφ (D : Divisor K F'')).symm))
+
+theorem WeierstrassCurve.Affine.pointMapOfPushforward_comp
+    {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    {U V W : Affine F} [U.IsElliptic] [V.IsElliptic] [W.IsElliptic]
+    [GenusOnePlaceGate U] [AbelTheorem U] [GenusOnePlaceGate V] [AbelTheorem V]
+    [GenusOnePlaceGate W] [AbelTheorem W]
+    (φ : U.FunctionField →ₐ[F] V.FunctionField) (χ : V.FunctionField →ₐ[F] W.FunctionField)
+    (hφ : φ.toRingHom.IsIntegral) (hχ : χ.toRingHom.IsIntegral)
+    (hχφ : (χ.comp φ).toRingHom.IsIntegral)
+    (hfinφ : FiniteAlong F φ) (hfinχ : FiniteAlong F χ) (hfinχφ : FiniteAlong F (χ.comp φ))
+    (hNφ : NormFormulaAlong F φ hfinφ) (hNχ : NormFormulaAlong F χ hfinχ)
+    (hNχφ : NormFormulaAlong F (χ.comp φ) hfinχφ) :
+    pointMapOfPushforward (χ.comp φ) hχφ hfinχφ hNχφ
+      = (pointMapOfPushforward φ hφ hfinφ hNφ).comp (pointMapOfPushforward χ hχ hfinχ hNχ) := by
+  refine AddMonoidHom.ext fun P => ?_
+  simp only [AddMonoidHom.comp_apply, pointMapOfPushforward_apply, pointClass_genusOnePic0Equiv,
+    Pic0.pushforwardAlongHom_comp φ χ hφ hχ hχφ hfinφ hfinχ hfinχφ hNφ hNχ hNχφ]
+
+theorem WeierstrassCurve.Affine.ker_pointMapOfPushforward_comp
+    {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    {U V W : Affine F} [U.IsElliptic] [V.IsElliptic] [W.IsElliptic]
+    [GenusOnePlaceGate U] [AbelTheorem U] [GenusOnePlaceGate V] [AbelTheorem V]
+    [GenusOnePlaceGate W] [AbelTheorem W]
+    (φ : U.FunctionField →ₐ[F] V.FunctionField) (χ : V.FunctionField →ₐ[F] W.FunctionField)
+    (hφ : φ.toRingHom.IsIntegral) (hχ : χ.toRingHom.IsIntegral)
+    (hχφ : (χ.comp φ).toRingHom.IsIntegral)
+    (hfinφ : FiniteAlong F φ) (hfinχ : FiniteAlong F χ) (hfinχφ : FiniteAlong F (χ.comp φ))
+    (hNφ : NormFormulaAlong F φ hfinφ) (hNχ : NormFormulaAlong F χ hfinχ)
+    (hNχφ : NormFormulaAlong F (χ.comp φ) hfinχφ) :
+    (pointMapOfPushforward (χ.comp φ) hχφ hfinχφ hNχφ).ker
+      = ((pointMapOfPushforward φ hφ hfinφ hNφ).comp
+          (pointMapOfPushforward χ hχ hfinχ hNχ)).ker := by
+  rw [pointMapOfPushforward_comp]
+
+end
+
+namespace WeierstrassCurve
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+
+private theorem
+  exists_functionFieldHom_fullKernelQuotient_pointMapOfPushforward_ker_eq_zmultiples_aux
+    {F : Type*} [Field F] [DecidableEq F] [CharZero F] [IsAlgClosed F]
+    {W : WeierstrassCurve F} [W.toAffine.IsElliptic]
+    {Q : W.toAffine.Point} {N : ℕ} [NeZero N] (hord : addOrderOf Q = N)
+    (hΔ' : (W.fullKernelQuotient Q N).Δ ≠ 0)
+    [(W.fullKernelQuotient Q N).toAffine.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W.toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate
+      (W.fullKernelQuotient Q N).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred
+      (W.fullKernelQuotient Q N).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem
+      (W.fullKernelQuotient Q N).toAffine] :
+    ∃ (ι : (W.fullKernelQuotient Q N).toAffine.FunctionField
+            →ₐ[F] W.toAffine.FunctionField)
+      (hι : ι.toRingHom.IsIntegral) (hfin : AlgebraicCurve.FiniteAlong F ι),
+      ∀ hN : AlgebraicCurve.NormFormulaAlong F ι hfin,
+        (WeierstrassCurve.Affine.pointMapOfPushforward ι hι hfin hN).ker
+          = AddSubgroup.zmultiples Q := by
+  suffices H : ∀ (N : ℕ), 0 < N → ∀ (W : WeierstrassCurve F) [W.toAffine.IsElliptic]
+      (Q : W.toAffine.Point), addOrderOf Q = N →
+      ∀ (V : WeierstrassCurve F), V = W.fullKernelQuotient Q N → V.Δ ≠ 0 →
+      ∀ [V.toAffine.IsElliptic]
+        [WeierstrassCurve.Affine.GenusOnePlaceGate W.toAffine]
+        [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W.toAffine]
+        [WeierstrassCurve.Affine.AbelTheorem W.toAffine]
+        [WeierstrassCurve.Affine.GenusOnePlaceGate V.toAffine]
+        [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred V.toAffine]
+        [WeierstrassCurve.Affine.AbelTheorem V.toAffine],
+      ∃ (ι : V.toAffine.FunctionField →ₐ[F] W.toAffine.FunctionField)
+        (hι : ι.toRingHom.IsIntegral) (hfin : AlgebraicCurve.FiniteAlong F ι),
+        ∀ hN : AlgebraicCurve.NormFormulaAlong F ι hfin,
+          (WeierstrassCurve.Affine.pointMapOfPushforward ι hι hfin hN).ker
+            = AddSubgroup.zmultiples Q by
+    exact H N (Nat.pos_of_ne_zero (NeZero.ne N)) W Q hord _ rfl hΔ'
+  intro N
+  induction N using Nat.strong_induction_on with
+  | _ N IH =>
+    intro hNpos W instW Q hord V hV hΔV instV gW cW aW gV cV aV
+    rcases Nat.even_or_odd N with hE | hO
+    · obtain ⟨M, hMM⟩ := hE
+      have hN2M : N = 2 * M := by omega
+      subst hN2M
+      have hM0 : M ≠ 0 := by omega
+      have hMQ0 : M • Q ≠ 0 := by
+        intro h0
+        have hdvd : addOrderOf Q ∣ M := addOrderOf_dvd_iff_nsmul_eq_zero.mpr h0
+        rw [hord] at hdvd
+        exact absurd (Nat.le_of_dvd (Nat.pos_of_ne_zero hM0) hdvd) (by omega)
+      have h2MQ : 2 • (M • Q) = 0 := by
+        rw [← mul_nsmul, mul_comm, ← hord]
+        exact addOrderOf_nsmul_eq_zero Q
+      have hord2 : addOrderOf (M • Q) = 2 := by
+        have hdvd : addOrderOf (M • Q) ∣ 2 := addOrderOf_dvd_iff_nsmul_eq_zero.mpr h2MQ
+        rcases (Nat.dvd_prime Nat.prime_two).mp hdvd with h1 | h2
+        · exfalso
+          apply hMQ0
+          have h := addOrderOf_nsmul_eq_zero (M • Q)
+          rwa [h1, one_nsmul] at h
+        · exact h2
+      obtain ⟨x₀, y₀, h₀, hMQ, hgy⟩ :=
+        Affine.Point.exists_veluGy_eq_zero_of_addOrderOf_eq_two (M • Q) hord2
+      have instWbare : W.IsElliptic := ‹W.toAffine.IsElliptic›
+      have hW1ell : (W.veluQuotient2 x₀ y₀).IsElliptic :=
+        isElliptic_veluQuotient2_of_isElliptic h₀.1 hgy
+      have : (W.veluQuotient2 x₀ y₀).toAffine.IsElliptic := hW1ell
+      have hΔ₂ : (W.veluQuotient2 x₀ y₀).Δ ≠ 0 := hW1ell.isUnit.ne_zero
+      have hordφ : addOrderOf (veluPointMap2 two_ne_zero h₀.1 hgy hΔ₂ Q) = M :=
+        KernelTower.addOrderOf_veluPointMap2 two_ne_zero W Q M hM0 hord hMQ hgy hΔ₂
+          (fun P => VeluTwoKernel.veluPointMap2_eq_zero_iff two_ne_zero h₀.1 hgy hΔ₂ h₀ P)
+      have E2 : W.fullKernelQuotient Q (2 * M)
+          = (W.veluQuotient2 x₀ y₀).fullKernelQuotient
+              (veluPointMap2 two_ne_zero h₀.1 hgy hΔ₂ Q) M :=
+        fullKernelQuotient_eq_fullKernelQuotient_veluPointMap2 two_ne_zero W Q M hM0 hord hMQ hgy
+          hΔ₂
+      have hV' : V = (W.veluQuotient2 x₀ y₀).fullKernelQuotient
+          (veluPointMap2 two_ne_zero h₀.1 hgy hΔ₂ Q) M := hV.trans E2
+      subst hV'
+      obtain ⟨g₁, hc₁, hA₁⟩ :=
+        Affine.exists_genusOnePlaceGate_isCentred_abelTheorem (W.veluQuotient2 x₀ y₀).toAffine
+      let := g₁
+      have : WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred
+        (W.veluQuotient2 x₀ y₀).toAffine := hc₁
+      have : WeierstrassCurve.Affine.AbelTheorem (W.veluQuotient2 x₀ y₀).toAffine := hA₁
+      obtain ⟨ιM, hιM, hfinM, hkerM⟩ :=
+        IH M (by omega) (Nat.pos_of_ne_zero hM0) (W.veluQuotient2 x₀ y₀)
+          (veluPointMap2 two_ne_zero h₀.1 hgy hΔ₂ Q) hordφ
+          ((W.veluQuotient2 x₀ y₀).fullKernelQuotient
+            (veluPointMap2 two_ne_zero h₀.1 hgy hΔ₂ Q) M) rfl hΔV
+      obtain ⟨ι₂, hι₂, hfin₂, hseam⟩ :=
+        exists_velu2FunctionFieldHom_restrictAlong_placeOfPoint_veluPointMap2 h₀.1 hgy hΔ₂
+      have hιc : (ι₂.comp ιM).toRingHom.IsIntegral := by
+        change (ι₂.toRingHom.comp ιM.toRingHom).IsIntegral
+        exact RingHom.IsIntegral.trans _ _ hιM hι₂
+      have hfinc : AlgebraicCurve.FiniteAlong F (ι₂.comp ιM) :=
+        AlgebraicCurve.finiteAlong_comp ιM ι₂ hfinM hfin₂
+      refine ⟨ι₂.comp ιM, hιc, hfinc, fun hNc => ?_⟩
+      have : CharZero (W.veluQuotient2 x₀ y₀).toAffine.FunctionField :=
+        charZero_of_injective_algebraMap (algebraMap F _).injective
+      have : CharZero ((W.veluQuotient2 x₀ y₀).fullKernelQuotient
+          (veluPointMap2 two_ne_zero h₀.1 hgy hΔ₂ Q) M).toAffine.FunctionField :=
+        charZero_of_injective_algebraMap (algebraMap F _).injective
+      have : AlgebraicCurve.HasPrincipalDivisors F W.toAffine.FunctionField :=
+        Affine.hasPrincipalDivisors_of_isAlgClosed W.toAffine
+      have : AlgebraicCurve.HasPrincipalDivisors F
+          (W.veluQuotient2 x₀ y₀).toAffine.FunctionField :=
+        Affine.hasPrincipalDivisors_of_isAlgClosed (W.veluQuotient2 x₀ y₀).toAffine
+      have hN₂ : AlgebraicCurve.NormFormulaAlong F ι₂ hfin₂ :=
+        AlgebraicCurve.normFormulaAlong ι₂ hfin₂
+          (AlgebraicCurve.separableAlong_of_charZero ι₂ hι₂)
+      have hNM : AlgebraicCurve.NormFormulaAlong F ιM hfinM :=
+        AlgebraicCurve.normFormulaAlong ιM hfinM
+          (AlgebraicCurve.separableAlong_of_charZero ιM hιM)
+      have hmapeq : WeierstrassCurve.Affine.pointMapOfPushforward (ι₂.comp ιM) hιc hfinc hNc
+          = (WeierstrassCurve.Affine.pointMapOfPushforward ιM hιM hfinM hNM).comp
+              (WeierstrassCurve.Affine.pointMapOfPushforward ι₂ hι₂ hfin₂ hN₂) :=
+        Affine.pointMapOfPushforward_comp ιM ι₂ hιM hι₂ hιc hfinM hfin₂ hfinc hNM hN₂ hNc
+      rw [hmapeq]
+      refine KernelTower.ker_comp_eq_zmultiples _ _ ?_ ?_
+      · rw [VeluTwoKernel.ker_pointMapOfPushforward_eq_zmultiples two_ne_zero h₀.1 hgy hΔ₂ ι₂ hι₂
+          hfin₂ hN₂ hseam h₀, ← hMQ]
+        exact AddSubgroup.zmultiples_le.mpr
+          (AddSubgroup.nsmul_mem _ (AddSubgroup.mem_zmultiples Q) M)
+      · have hQimg : WeierstrassCurve.Affine.pointMapOfPushforward ι₂ hι₂ hfin₂ hN₂ Q
+            = veluPointMap2 two_ne_zero h₀.1 hgy hΔ₂ Q :=
+          VeluTwoKernel.pointMapOfPushforward_eq_veluPointMap2 two_ne_zero h₀.1 hgy hΔ₂ ι₂ hι₂ hfin₂
+            hN₂ hseam Q
+        rw [hQimg]
+        exact hkerM hNM
+    · obtain ⟨n, hn⟩ := hO
+      have hord' : addOrderOf Q = 2 * n + 1 := hord.trans hn
+      have hbr : W.fullKernelQuotient Q N = W.veluQuotient (W.oddOrderSummingSet Q n) := by
+        have h := W.fullKernelQuotient_eq_veluQuotient_of_odd Q ⟨n, hn⟩ hord
+        rwa [show (N - 1) / 2 = n by omega] at h
+      have hV' : V = W.veluQuotient (W.oddOrderSummingSet Q n) := hV.trans hbr
+      subst hV'
+      exact exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples_of_oddOrder
+        hord' hΔV
+
+end WeierstrassCurve
+
+open WeierstrassCurve in
+theorem solution {F : Type*} [Field F] [DecidableEq F] [CharZero F] [IsAlgClosed F]
+    {W : WeierstrassCurve F} [W.toAffine.IsElliptic]
+    {Q : W.toAffine.Point} {N : ℕ} [NeZero N] (hord : addOrderOf Q = N)
+    (hΔ' : (W.fullKernelQuotient Q N).Δ ≠ 0)
+    [(W.fullKernelQuotient Q N).toAffine.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W.toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate
+      (W.fullKernelQuotient Q N).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred
+      (W.fullKernelQuotient Q N).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem
+      (W.fullKernelQuotient Q N).toAffine] :
+    ∃ (ι : (W.fullKernelQuotient Q N).toAffine.FunctionField
+            →ₐ[F] W.toAffine.FunctionField)
+      (hι : ι.toRingHom.IsIntegral) (hfin : AlgebraicCurve.FiniteAlong F ι),
+      ∀ hN : AlgebraicCurve.NormFormulaAlong F ι hfin,
+        (WeierstrassCurve.Affine.pointMapOfPushforward ι hι hfin hN).ker
+          = AddSubgroup.zmultiples Q :=
+  exists_functionFieldHom_fullKernelQuotient_pointMapOfPushforward_ker_eq_zmultiples_aux hord hΔ'
+
+end privateSection
+
+public section publicSection
+
+namespace WeierstrassCurve
+
+theorem exists_functionFieldHom_fullKernelQuotient_pointMapOfPushforward_ker_eq_zmultiples
+    {F : Type*} [Field F] [DecidableEq F] [CharZero F] [IsAlgClosed F]
+    {W : WeierstrassCurve F} [W.toAffine.IsElliptic]
+    {Q : W.toAffine.Point} {N : ℕ} [NeZero N] (hord : addOrderOf Q = N)
+    (hΔ' : (W.fullKernelQuotient Q N).Δ ≠ 0)
+    [(W.fullKernelQuotient Q N).toAffine.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W.toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate
+      (W.fullKernelQuotient Q N).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred
+      (W.fullKernelQuotient Q N).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem
+      (W.fullKernelQuotient Q N).toAffine] :
+    ∃ (ι : (W.fullKernelQuotient Q N).toAffine.FunctionField
+            →ₐ[F] W.toAffine.FunctionField)
+      (hι : ι.toRingHom.IsIntegral) (hfin : AlgebraicCurve.FiniteAlong F ι),
+      ∀ hN : AlgebraicCurve.NormFormulaAlong F ι hfin,
+        (WeierstrassCurve.Affine.pointMapOfPushforward ι hι hfin hN).ker
+          = AddSubgroup.zmultiples Q :=
+  solution hord hΔ'
+
+end WeierstrassCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_intermediateField_countable_map_eq_and_finrankAlong_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_intermediateField_countable_map_eq_and_finrankAlong_eq.lean
new file mode 100644
index 0000000000..97a17823c0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_intermediateField_countable_map_eq_and_finrankAlong_eq.lean
@@ -0,0 +1,2798 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.exists_intermediateField_countable_map_eq_and_finrankAlong_eq
+(78a53ccc-520e-56d2-9896-7cdc04f3b6d3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 24efc664-8750-5b05-9475-4139047b081d
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+
+import Mathlib.Algebra.Polynomial.Basis
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+import Mathlib.Data.Rat.Encodable
+import Mathlib.FieldTheory.RatFunc.IntermediateField
+import Mathlib.LinearAlgebra.Countable
+import Mathlib.RingTheory.Flat.TorsionFree
+import Mathlib.RingTheory.PicardGroup
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_finiteDimensional_ratFunc_functionField
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Descent of an elliptic curve with a function-field endomorphism to a countable subfield
+
+Theorem statement: `WeierstrassCurve.exists_intermediateField_countable_map_eq_and_finrankAlong_eq`
+(`78a53ccc-520e-56d2-9896-7cdc04f3b6d3`), by Claude, 2026-09-05.
+
+Proof: submission `24efc664-8750-5b05-9475-4139047b081d`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be an algebraically closed field of characteristic $0$ (in a fixed universe), let $E$ be a
+Weierstrass curve over $K$ which is elliptic, and let $\iota$ be a $K$-algebra homomorphism from the
+function field of the affine model of $E$ to itself. Assume that $\iota$ is integral as a ring
+homomorphism, and that `FiniteAlong K ι` holds, i.e. the function field of $E$, regarded as an
+algebra over itself via $\iota$, is a finite module. Then there exist an intermediate field $K_0$ of
+$\mathbb{Q} \subseteq K$ with $K_0$ countable, a Weierstrass curve $E_0$ over $K_0$ which is
+elliptic and whose base change along $K_0 \to K$ equals $E$ (equality of Weierstrass coefficient
+tuples, not merely isomorphism), and an $\mathrm{AlgebraicClosure}(K_0)$-algebra endomorphism
+$\iota_0$ of the function field of the affine model of $E_0$ base changed to
+$\mathrm{AlgebraicClosure}(K_0)$, such that $\iota_0$ is integral as a ring homomorphism, the
+function field of this base-changed curve is finite as a module over itself via $\iota_0$, and the
+corresponding rank, $\mathrm{finrankAlong}$ of $\iota_0$, equals the rank $\mathrm{finrankAlong}$ of
+$\iota$ over $K$.
+
+This is the Lefschetz-principle descent step for a pair consisting of an elliptic curve and an
+endomorphism of its function field: the curve and the endomorphism involve only finitely many
+elements of $K$, hence live over the algebraic closure of a countable (indeed finitely generated
+over $\mathbb{Q}$) subfield, with the degree of the endomorphism unchanged. It is used in the
+analysis of isogeny endomorphism data, where the invariance of the degree is transported to a
+statement about the $j$-invariant.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_exists_intermediateField_countable_map_eq_and_finrankAlong_eq.lean
+
+*Attribution:* this file contains material adapted from third-party Apache-2.0 sources (a short
+passage (a few lines); upstream notices also retained in place before the included portions:
+`FLT/Mathlib/LinearAlgebra/Countable.lean` — © 2025 Kevin Buzzard; authors: Kevin Buzzard). See
+ATTRIBUTION.md and NOTICE in the source repository.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+set_option maxHeartbeats 25600000
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_6989a05c
+
+
+noncomputable section
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ map_map a₁ WeierstrassCurve.map_a₃ map Ψ₃ mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ WeierstrassCurve.map_a₆ reduction map_id IsIntegral \
+  toAffine WeierstrassCurve.map_a₂ Affine.Point WeierstrassCurve.map_a₁ WeierstrassCurve.map_a₄ \
+  map_Δ map_a₆ map_a₁ map_a₄ Δ Affine.equation_iff Affine.polynomial map_a₂ baseChange j map_a₃ \
+  Affine.finiteDimensional_ratFunc_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation CoordinateRing.basis_one equation_iff' \
+  map_a₃ slope CoordinateRing.instIsDomain CoordinateRing map baseChange equation_add \
+  Equation.baseChange Point.some Point.some.injEq Point.some.inj map_a₆ FunctionField map_a₂ Point \
+  CoordinateRing.mk addX map_a₁ CoordinateRing.map map_a₄ CoordinateRing.basis_apply \
+  CoordinateRing.map_mk CoordinateRing.map_smul CoordinateRing.basis_zero CoordinateRing.basis \
+  addY equation_iff polynomial polyToFunctionField polyToFunctionField_apply \
+  polyToFunctionField_injective polyToFunctionField_C algebraMap_smul_basis \
+  finiteDimensional_ratFunc_functionField"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_6989a05c.Polynomial"
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_6989a05c.Polynomial.\
+  Bivariate"
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem algebraMap_polynomial_eq_mk_C (p : F[X]) :
+    algebraMap F[X] W.CoordinateRing p = CoordinateRing.mk W (C p) :=
+  rfl
+
+noncomputable def yGen (W : Affine F) : W.FunctionField :=
+  algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+namespace CoordinateRing
+p2m_export "WeierstrassCurve.Affine.CoordinateRing" "basis_one instAlgebra instIsDomain mk map \
+  basis_apply map_mk basis_zero smul_basis_mul_Y"
+end CoordinateRing
+p2m_open_scoped "WeierstrassCurve.Affine.CoordinateRing" in
+theorem CoordinateRing.algebraMap_eq_mk_C_C (a : F) :
+    algebraMap F W.CoordinateRing a = CoordinateRing.mk W (C (C a)) := by
+  rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+    Algebra.algebraMap_self_apply]
+  rfl
+end WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ map_map a₁ WeierstrassCurve.map_a₃ map Ψ₃ mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ WeierstrassCurve.map_a₆ reduction map_id IsIntegral \
+  toAffine WeierstrassCurve.map_a₂ Affine.Point WeierstrassCurve.map_a₁ WeierstrassCurve.map_a₄ \
+  map_Δ map_a₆ map_a₁ map_a₄ Δ Affine.equation_iff Affine.polynomial map_a₂ baseChange j map_a₃ \
+  Affine.finiteDimensional_ratFunc_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation CoordinateRing.basis_one equation_iff' \
+  map_a₃ slope CoordinateRing.instIsDomain CoordinateRing map baseChange equation_add \
+  Equation.baseChange Point.some Point.some.injEq Point.some.inj map_a₆ FunctionField map_a₂ Point \
+  CoordinateRing.mk addX map_a₁ CoordinateRing.map map_a₄ CoordinateRing.basis_apply \
+  CoordinateRing.map_mk CoordinateRing.map_smul CoordinateRing.basis_zero CoordinateRing.basis \
+  addY equation_iff polynomial polyToFunctionField polyToFunctionField_apply \
+  polyToFunctionField_injective polyToFunctionField_C algebraMap_smul_basis \
+  finiteDimensional_ratFunc_functionField"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+universe u_tied
+variable {F : Type u_tied} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic]
+
+structure TreeIsogenyEndDatum where
+  ι : W.FunctionField →ₐ[F] W.FunctionField
+  hι : ι.toRingHom.IsIntegral
+  hfin : AlgebraicCurve.FiniteAlong F ι
+namespace TreeIsogenyEndDatum
+variable {W}
+
+def degree (D : TreeIsogenyEndDatum W) : ℕ := AlgebraicCurve.finrankAlong F D.ι
+end TreeIsogenyEndDatum
+end WeierstrassCurve.Affine
+
+noncomputable scoped instance {F : Type*} [Field F] {W : WeierstrassCurve.Affine F} :
+    FiniteDimensional (RatFunc F) W.FunctionField :=
+  WeierstrassCurve.Affine.finiteDimensional_ratFunc_functionField W
+universe uK
+
+namespace AlgebraicCurve
+p2m_export "AlgebraicCurve" "algebraAlong FiniteAlong finrankAlong HasPrincipalDivisors Pic Pic0"
+end AlgebraicCurve
+namespace Cardinal
+p2m_export "Cardinal" "map mk_fin lift_le_aleph0 lift_eq_one lift_one \
+  mk_le_one_iff_set_subsingleton sum_add_distrib mk mk_le_aleph0_iff sum mk_le_aleph0 aleph0 \
+  map_mk univ lift"
+end Cardinal
+namespace HahnSeries
+p2m_export "HahnSeries" "support single order instAlgebra coeff algebraMap_apply C map mk map_C"
+end HahnSeries
+namespace IntermediateField
+p2m_export "IntermediateField" "toAlgebra map_id mk algebra' mem_restrictScalars lift \
+  AdjoinSimple.gen inclusion ext adjoin_simple_le_iff algebraMap_apply smul_def \
+  lift_cardinalMk_adjoin_le FG adjoin instAlgebraSubtypeMem AdjoinSimple.algebraMap_gen map_map \
+  topEquiv mem_top restrictScalars finiteDimensional_adjoin adjoin_map subset_adjoin smul_mem \
+  normal isAlgebraic_iff map"
+end IntermediateField
+namespace IsDedekindDomain
+p2m_export "IsDedekindDomain" "mk"
+end IsDedekindDomain
+namespace PeriodPair
+p2m_export "PeriodPair" "mk basis_one basis_zero G"
+end PeriodPair
+namespace Polynomial
+p2m_export "Polynomial" "C eval₂_sub X support as_sum_support_C_mul_X_pow aeval_map_algebraMap \
+  coeff algebraMap_eq divX eval₂ aeval eval₂_add monomial basisMonomials eval₂_pow degree C_0 \
+  factor aeval_C map_id map_map map_C map eval₂_X comp algebra eval₂_mul \
+  exists_eq_pow_rootMultiplicity_mul_and_not_dvd X_dvd_iff algHom_ext sum coe_mapRingHom \
+  divX_mul_X_add flt adjoin_X aeval_algHom map_X notMem_support_iff aeval_X map_monomial coeffs \
+  algebraMap_apply coe_basisMonomials inhabited ext mapRingHom content eval₂_C funext ring \
+  aeval_algHom_apply ringHom_ext lifts transcendental restriction eval"
+end Polynomial
+namespace Polynomial
+p2m_export "Polynomial" "C eval₂_sub X support as_sum_support_C_mul_X_pow aeval_map_algebraMap \
+  coeff algebraMap_eq divX eval₂ aeval eval₂_add monomial basisMonomials eval₂_pow degree C_0 \
+  factor aeval_C map_id map_map map_C map eval₂_X comp algebra eval₂_mul \
+  exists_eq_pow_rootMultiplicity_mul_and_not_dvd X_dvd_iff algHom_ext sum coe_mapRingHom \
+  divX_mul_X_add flt adjoin_X aeval_algHom map_X notMem_support_iff aeval_X map_monomial coeffs \
+  algebraMap_apply coe_basisMonomials inhabited ext mapRingHom content eval₂_C funext ring \
+  aeval_algHom_apply ringHom_ext lifts transcendental restriction eval"
+end Polynomial
+namespace TensorProduct
+p2m_export "TensorProduct" "map_tmul congr lift_mk map_map smul_tmul zero_tmul sum_tmul lift mk \
+  ext tmul map_id map Algebra.smul_def comm_tmul mk_surjective"
+end TensorProduct
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ map_map a₁ WeierstrassCurve.map_a₃ map Ψ₃ mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ WeierstrassCurve.map_a₆ reduction map_id IsIntegral \
+  toAffine WeierstrassCurve.map_a₂ Affine.Point WeierstrassCurve.map_a₁ WeierstrassCurve.map_a₄ \
+  map_Δ map_a₆ map_a₁ map_a₄ Δ Affine.equation_iff Affine.polynomial map_a₂ baseChange j map_a₃ \
+  Affine.finiteDimensional_ratFunc_functionField"
+end WeierstrassCurve
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ map_map a₁ WeierstrassCurve.map_a₃ map Ψ₃ mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ WeierstrassCurve.map_a₆ reduction map_id IsIntegral \
+  toAffine WeierstrassCurve.map_a₂ Affine.Point WeierstrassCurve.map_a₁ WeierstrassCurve.map_a₄ \
+  map_Δ map_a₆ map_a₁ map_a₄ Δ Affine.equation_iff Affine.polynomial map_a₂ baseChange j map_a₃ \
+  Affine.finiteDimensional_ratFunc_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation CoordinateRing.basis_one equation_iff' \
+  map_a₃ slope CoordinateRing.instIsDomain CoordinateRing map baseChange equation_add \
+  Equation.baseChange Point.some Point.some.injEq Point.some.inj map_a₆ FunctionField map_a₂ Point \
+  CoordinateRing.mk addX map_a₁ CoordinateRing.map map_a₄ CoordinateRing.basis_apply \
+  CoordinateRing.map_mk CoordinateRing.map_smul CoordinateRing.basis_zero CoordinateRing.basis \
+  addY equation_iff polynomial polyToFunctionField polyToFunctionField_apply \
+  polyToFunctionField_injective polyToFunctionField_C algebraMap_smul_basis \
+  finiteDimensional_ratFunc_functionField"
+end WeierstrassCurve.Affine
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ map_map a₁ WeierstrassCurve.map_a₃ map Ψ₃ mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ WeierstrassCurve.map_a₆ reduction map_id IsIntegral \
+  toAffine WeierstrassCurve.map_a₂ Affine.Point WeierstrassCurve.map_a₁ WeierstrassCurve.map_a₄ \
+  map_Δ map_a₆ map_a₁ map_a₄ Δ Affine.equation_iff Affine.polynomial map_a₂ baseChange j map_a₃ \
+  Affine.finiteDimensional_ratFunc_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation CoordinateRing.basis_one equation_iff' \
+  map_a₃ slope CoordinateRing.instIsDomain CoordinateRing map baseChange equation_add \
+  Equation.baseChange Point.some Point.some.injEq Point.some.inj map_a₆ FunctionField map_a₂ Point \
+  CoordinateRing.mk addX map_a₁ CoordinateRing.map map_a₄ CoordinateRing.basis_apply \
+  CoordinateRing.map_mk CoordinateRing.map_smul CoordinateRing.basis_zero CoordinateRing.basis \
+  addY equation_iff polynomial polyToFunctionField polyToFunctionField_apply \
+  polyToFunctionField_injective polyToFunctionField_C algebraMap_smul_basis \
+  finiteDimensional_ratFunc_functionField"
+namespace Point
+p2m_export "WeierstrassCurve.Affine.Point" "add map_id baseChange map_map some some.injEq some.inj \
+  map_zero map zero mk"
+end WeierstrassCurve.Affine.Point
+
+section
+
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine \
+  P2MW.S_OVERLONG_6989a05c.ModularCurv\
+  e"
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_6989a05c.Polynomial"
+p2m_open_scoped "TensorProduct \
+  P2MW.S_OVERLONG_6989a05c.TensorProdu\
+  ct Polynomial \
+  P2MW.S_OVERLONG_6989a05c.Polynomial"
+
+namespace ModularCurve
+
+universe u
+
+section Setup
+
+variable (W : WeierstrassCurve ℚ) [W.IsElliptic]
+variable (F : Type u) [Field F] [Algebra ℚ F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra ℚ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower ℚ F F']
+
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+local notation3 "CR" => (W⁄F).toAffine.CoordinateRing
+local notation3 "FF" => (W⁄F).FunctionField
+
+def kw_coordinateRingBasis {R : Type*} [CommRing R] (V : Affine R) :
+    Module.Basis (ℕ × Fin 2) R V.CoordinateRing :=
+  (Polynomial.basisMonomials R).smulTower (CoordinateRing.basis V)
+
+end Setup
+
+end ModularCurve
+
+end
+end
+
+
+section
+
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine \
+  P2MW.S_OVERLONG_6989a05c.ModularCurv\
+  e AlgebraicCurve \
+  P2MW.S_OVERLONG_6989a05c.AlgebraicCu\
+  rve"
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_6989a05c.Polynomial"
+p2m_open_scoped "TensorProduct \
+  P2MW.S_OVERLONG_6989a05c.TensorProdu\
+  ct Polynomial.Bivariate \
+  P2MW.S_OVERLONG_6989a05c.Polynomial.\
+  Bivariate"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ map_map a₁ WeierstrassCurve.map_a₃ map Ψ₃ mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ WeierstrassCurve.map_a₆ reduction map_id IsIntegral \
+  toAffine WeierstrassCurve.map_a₂ Affine.Point WeierstrassCurve.map_a₁ WeierstrassCurve.map_a₄ \
+  map_Δ map_a₆ map_a₁ map_a₄ Δ Affine.equation_iff Affine.polynomial map_a₂ baseChange j map_a₃ \
+  Affine.finiteDimensional_ratFunc_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation CoordinateRing.basis_one equation_iff' \
+  map_a₃ slope CoordinateRing.instIsDomain CoordinateRing map baseChange equation_add \
+  Equation.baseChange Point.some Point.some.injEq Point.some.inj map_a₆ FunctionField map_a₂ Point \
+  CoordinateRing.mk addX map_a₁ CoordinateRing.map map_a₄ CoordinateRing.basis_apply \
+  CoordinateRing.map_mk CoordinateRing.map_smul CoordinateRing.basis_zero CoordinateRing.basis \
+  addY equation_iff polynomial polyToFunctionField polyToFunctionField_apply \
+  polyToFunctionField_injective polyToFunctionField_C algebraMap_smul_basis \
+  finiteDimensional_ratFunc_functionField"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+universe u
+variable {F : Type u} [Field F] {W : Affine F}
+
+theorem kw_functionField_algHom_ext {L : Type*} [Field L] [Algebra F L]
+    {f g : W.FunctionField →ₐ[F] L}
+    (hX : f (polyToFunctionField W X) = g (polyToFunctionField W X))
+    (hy : f (yGen W) = g (yGen W)) : f = g := by
+  have hCR : ∀ r : W.CoordinateRing,
+      f (algebraMap W.CoordinateRing W.FunctionField r)
+        = g (algebraMap W.CoordinateRing W.FunctionField r) := by
+    intro r
+    obtain ⟨p, rfl⟩ := AdjoinRoot.mk_surjective r
+    have hFX : ∀ c : F[X], f (algebraMap W.CoordinateRing W.FunctionField
+          (algebraMap F[X] W.CoordinateRing c))
+        = g (algebraMap W.CoordinateRing W.FunctionField
+          (algebraMap F[X] W.CoordinateRing c)) :=
+      fun c => DFunLike.congr_fun
+        (Polynomial.algHom_ext (f := (f.comp (IsScalarTower.toAlgHom F W.CoordinateRing
+            W.FunctionField)).comp (IsScalarTower.toAlgHom F F[X] W.CoordinateRing))
+          (g := (g.comp (IsScalarTower.toAlgHom F W.CoordinateRing W.FunctionField)).comp
+            (IsScalarTower.toAlgHom F F[X] W.CoordinateRing)) hX) c
+    have hFX' : ∀ c : F[X], f (algebraMap W.CoordinateRing W.FunctionField
+          (AdjoinRoot.mk W.polynomial (C c)))
+        = g (algebraMap W.CoordinateRing W.FunctionField
+          (AdjoinRoot.mk W.polynomial (C c))) := fun c => by
+      rw [show AdjoinRoot.mk W.polynomial (C c) = algebraMap F[X] W.CoordinateRing c from rfl]
+      exact hFX c
+    have hy' : f (algebraMap W.CoordinateRing W.FunctionField (AdjoinRoot.mk W.polynomial Y))
+        = g (algebraMap W.CoordinateRing W.FunctionField (AdjoinRoot.mk W.polynomial Y)) := hy
+    induction p using Polynomial.induction_on with
+    | C c => exact hFX' c
+    | monomial n c _ => simp only [map_mul, map_pow, hy', hFX' c]
+    | add p q hp hq => simp only [map_add, hp, hq]
+  refine AlgHom.ext fun a => ?_
+  obtain ⟨p, q, hq, rfl⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) a
+  simp only [map_div₀, hCR p, hCR q]
+
+end WeierstrassCurve.Affine
+
+namespace ModularCurve
+
+universe u
+
+section Setup
+
+variable (W : WeierstrassCurve ℚ) [W.IsElliptic]
+variable (F : Type u) [Field F] [Algebra ℚ F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra ℚ F'] [DecidableEq F'] [IsAlgClosed F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower ℚ F F']
+
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+end Setup
+
+end ModularCurve
+
+end
+end
+
+
+section
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_6989a05c.Polynomial \
+  WeierstrassCurve \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_6989a05c.Polynomial.\
+  Bivariate"
+
+universe u
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ map_map a₁ WeierstrassCurve.map_a₃ map Ψ₃ mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ WeierstrassCurve.map_a₆ reduction map_id IsIntegral \
+  toAffine WeierstrassCurve.map_a₂ Affine.Point WeierstrassCurve.map_a₁ WeierstrassCurve.map_a₄ \
+  map_Δ map_a₆ map_a₁ map_a₄ Δ Affine.equation_iff Affine.polynomial map_a₂ baseChange j map_a₃ \
+  Affine.finiteDimensional_ratFunc_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation CoordinateRing.basis_one equation_iff' \
+  map_a₃ slope CoordinateRing.instIsDomain CoordinateRing map baseChange equation_add \
+  Equation.baseChange Point.some Point.some.injEq Point.some.inj map_a₆ FunctionField map_a₂ Point \
+  CoordinateRing.mk addX map_a₁ CoordinateRing.map map_a₄ CoordinateRing.basis_apply \
+  CoordinateRing.map_mk CoordinateRing.map_smul CoordinateRing.basis_zero CoordinateRing.basis \
+  addY equation_iff polynomial polyToFunctionField polyToFunctionField_apply \
+  polyToFunctionField_injective polyToFunctionField_C algebraMap_smul_basis \
+  finiteDimensional_ratFunc_functionField"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine.CoordinateRing"
+
+variable {F : Type u} [Field F]
+
+section PointPullbackTo
+
+variable {W : Affine F} {L : Type u} [Field L] [Algebra F L]
+
+theorem eval₂_polynomial_of_equation_map_target {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) :
+    W.polynomial.eval₂
+      (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom yP = 0 := by
+  rw [equation_iff'] at h
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆] at h
+  simp only [WeierstrassCurve.Affine.polynomial, eval₂_add, eval₂_sub, eval₂_mul, eval₂_pow,
+    eval₂_X, eval₂_C, AlgHom.toRingHom_eq_coe, RingHom.coe_coe, map_add, map_mul, map_pow,
+    Polynomial.aeval_C, Polynomial.aeval_X]
+  linear_combination h
+
+def pointPullbackCoordHomTo {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) :
+    W.CoordinateRing →ₐ[F] L where
+  __ := AdjoinRoot.lift
+    (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom
+    yP (eval₂_polynomial_of_equation_map_target h)
+  commutes' c := by
+    change AdjoinRoot.lift _ _ (eval₂_polynomial_of_equation_map_target h) (algebraMap F _ c)
+      = algebraMap F L c
+    rw [CoordinateRing.algebraMap_eq_mk_C_C, AdjoinRoot.lift_mk, eval₂_C]
+    exact Polynomial.aeval_C _ c
+
+theorem pointPullbackCoordHomTo_mk {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) (g : F[X][Y]) :
+    pointPullbackCoordHomTo h (CoordinateRing.mk W g)
+      = g.eval₂ (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom yP :=
+  AdjoinRoot.lift_mk (eval₂_polynomial_of_equation_map_target h) g
+
+theorem pointPullbackCoordHomTo_comp_algebraMap {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) :
+    (pointPullbackCoordHomTo h).toRingHom.comp (algebraMap F[X] W.CoordinateRing)
+      = (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom := by
+  refine RingHom.ext fun p => ?_
+  change pointPullbackCoordHomTo h (algebraMap F[X] _ p) = _
+  rw [algebraMap_polynomial_eq_mk_C, pointPullbackCoordHomTo_mk, eval₂_C]
+
+theorem pointPullbackCoordHomTo_injective {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    Function.Injective (pointPullbackCoordHomTo h) := by
+  have hker : RingHom.ker (pointPullbackCoordHomTo h).toRingHom = ⊥ := by
+    have : Module.Finite F[X] W.CoordinateRing :=
+      Module.Finite.of_basis (CoordinateRing.basis W)
+    refine Ideal.eq_bot_of_under_eq_bot (R := F[X]) ?_
+    rw [Ideal.under_def, RingHom.comap_ker, pointPullbackCoordHomTo_comp_algebraMap,
+      ← RingHom.injective_iff_ker_eq_bot]
+    exact hx
+  exact (RingHom.injective_iff_ker_eq_bot (pointPullbackCoordHomTo h).toRingHom).mpr hker
+
+def pointPullbackHomTo {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    W.FunctionField →ₐ[F] L :=
+  IsFractionRing.liftAlgHom (pointPullbackCoordHomTo_injective h hx)
+
+theorem pointPullbackHomTo_algebraMap {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) (r : W.CoordinateRing) :
+    pointPullbackHomTo h hx (algebraMap W.CoordinateRing W.FunctionField r)
+      = pointPullbackCoordHomTo h r :=
+  IsFractionRing.lift_algebraMap (pointPullbackCoordHomTo_injective h hx) r
+
+theorem pointPullbackHomTo_polyToFunctionField_X {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    pointPullbackHomTo h hx (polyToFunctionField W X) = xP := by
+  rw [polyToFunctionField_apply, pointPullbackHomTo_algebraMap,
+    algebraMap_polynomial_eq_mk_C, pointPullbackCoordHomTo_mk, eval₂_C]
+  exact Polynomial.aeval_X _
+
+theorem pointPullbackHomTo_yGen {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    pointPullbackHomTo h hx (yGen W) = yP := by
+  change pointPullbackHomTo h hx (algebraMap _ _ (CoordinateRing.mk W Y)) = _
+  rw [pointPullbackHomTo_algebraMap, pointPullbackCoordHomTo_mk]
+  exact eval₂_X _ _
+
+end PointPullbackTo
+
+end WeierstrassCurve.Affine
+
+namespace ModularCurve
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine"
+
+local notation "Qbar" => AlgebraicClosure ℚ
+
+end ModularCurve
+
+end
+
+end
+
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_6989a05c.Polynomial \
+  IsDedekindDomain \
+  P2MW.S_OVERLONG_6989a05c.IsDedekindD\
+  omain"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_6989a05c.Polynomial.\
+  Bivariate"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ map_map a₁ WeierstrassCurve.map_a₃ map Ψ₃ mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ WeierstrassCurve.map_a₆ reduction map_id IsIntegral \
+  toAffine WeierstrassCurve.map_a₂ Affine.Point WeierstrassCurve.map_a₁ WeierstrassCurve.map_a₄ \
+  map_Δ map_a₆ map_a₁ map_a₄ Δ Affine.equation_iff Affine.polynomial map_a₂ baseChange j map_a₃ \
+  Affine.finiteDimensional_ratFunc_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation CoordinateRing.basis_one equation_iff' \
+  map_a₃ slope CoordinateRing.instIsDomain CoordinateRing map baseChange equation_add \
+  Equation.baseChange Point.some Point.some.injEq Point.some.inj map_a₆ FunctionField map_a₂ Point \
+  CoordinateRing.mk addX map_a₁ CoordinateRing.map map_a₄ CoordinateRing.basis_apply \
+  CoordinateRing.map_mk CoordinateRing.map_smul CoordinateRing.basis_zero CoordinateRing.basis \
+  addY equation_iff polynomial polyToFunctionField polyToFunctionField_apply \
+  polyToFunctionField_injective polyToFunctionField_C algebraMap_smul_basis \
+  finiteDimensional_ratFunc_functionField"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine.CoordinateRing AlgebraicCurve \
+  P2MW.S_OVERLONG_6989a05c.AlgebraicCu\
+  rve"
+
+universe u
+
+variable {F : Type u} [Field F]
+
+section GenericPoint
+
+variable {W : Affine F}
+
+theorem polyToFunctionField_eq_aeval (p : F[X]) :
+    polyToFunctionField W p = Polynomial.aeval (polyToFunctionField W X) p := by
+  have h1 : (polyToFunctionField W : F[X] →+* W.FunctionField)
+      = algebraMap F[X] W.FunctionField :=
+    (IsScalarTower.algebraMap_eq F[X] W.CoordinateRing W.FunctionField).symm
+  have h2 : (IsScalarTower.toAlgHom F F[X] W.FunctionField : F[X] →ₐ[F] W.FunctionField)
+      = Polynomial.aeval (polyToFunctionField W X) := by
+    refine Polynomial.algHom_ext ?_
+    rw [Polynomial.aeval_X, IsScalarTower.coe_toAlgHom', ← h1]
+  calc polyToFunctionField W p = algebraMap F[X] W.FunctionField p := by rw [h1]
+    _ = (IsScalarTower.toAlgHom F F[X] W.FunctionField : F[X] →ₐ[F] W.FunctionField) p := rfl
+    _ = Polynomial.aeval (polyToFunctionField W X) p := by rw [h2]
+
+theorem equation_map_polyToFunctionField_yGen :
+    (W.map (algebraMap F W.FunctionField)).toAffine.Equation
+      (polyToFunctionField W X) (yGen W) := by
+  rw [equation_iff]
+  have hrel := smul_basis_mul_Y (W' := W) 0 1
+  rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at hrel
+  have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) hrel
+  rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆]
+  simp only [map_add, map_mul, map_pow, polyToFunctionField_C] at h2
+  rw [show yGen W = algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+    from rfl]
+  simp only [polyToFunctionField_apply] at h2 ⊢
+  linear_combination h2
+
+end GenericPoint
+
+end WeierstrassCurve.Affine
+
+end
+
+
+section
+/-
+Copyright (c) 2025 Kevin Buzzard. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Kevin Buzzard
+-/
+
+section
+
+namespace Countable
+p2m_export "Countable" "mk"
+end Countable
+p2m_open_scoped "Countable" in
+lemma Countable.of_module_finite (R M : Type*) [Semiring R] [Countable R]
+    [AddCommMonoid M] [Module R M] [Module.Finite R M] : Countable M := by
+  obtain ⟨n, s, h⟩ := Module.Finite.exists_fin (R := R) (M := M)
+  rw [← Set.countable_univ_iff]
+  have : Countable (Submodule.span R (Set.range s)) := inferInstance
+  rwa [h] at this
+
+scoped instance (K : Type*) [Field K] [NumberField K] : Countable K :=
+  Countable.of_module_finite ℚ K
+
+end
+
+end
+
+section
+
+
+p2m_open "AlgebraicCurve \
+  P2MW.S_OVERLONG_6989a05c.AlgebraicCu\
+  rve \
+  P2MW.S_OVERLONG_6989a05c.FreyPackag\
+  e WeierstrassCurve \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ map_map a₁ WeierstrassCurve.map_a₃ map Ψ₃ mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ WeierstrassCurve.map_a₆ reduction map_id IsIntegral \
+  toAffine WeierstrassCurve.map_a₂ Affine.Point WeierstrassCurve.map_a₁ WeierstrassCurve.map_a₄ \
+  map_Δ map_a₆ map_a₁ map_a₄ Δ Affine.equation_iff Affine.polynomial map_a₂ baseChange j map_a₃ \
+  Affine.finiteDimensional_ratFunc_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation CoordinateRing.basis_one equation_iff' \
+  map_a₃ slope CoordinateRing.instIsDomain CoordinateRing map baseChange equation_add \
+  Equation.baseChange Point.some Point.some.injEq Point.some.inj map_a₆ FunctionField map_a₂ Point \
+  CoordinateRing.mk addX map_a₁ CoordinateRing.map map_a₄ CoordinateRing.basis_apply \
+  CoordinateRing.map_mk CoordinateRing.map_smul CoordinateRing.basis_zero CoordinateRing.basis \
+  addY equation_iff polynomial polyToFunctionField polyToFunctionField_apply \
+  polyToFunctionField_injective polyToFunctionField_C algebraMap_smul_basis \
+  finiteDimensional_ratFunc_functionField"
+end WeierstrassCurve.Affine
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ map_map a₁ WeierstrassCurve.map_a₃ map Ψ₃ mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ WeierstrassCurve.map_a₆ reduction map_id IsIntegral \
+  toAffine WeierstrassCurve.map_a₂ Affine.Point WeierstrassCurve.map_a₁ WeierstrassCurve.map_a₄ \
+  map_Δ map_a₆ map_a₁ map_a₄ Δ Affine.equation_iff Affine.polynomial map_a₂ baseChange j map_a₃ \
+  Affine.finiteDimensional_ratFunc_functionField"
+end WeierstrassCurve
+
+namespace ModularCurve
+namespace ElevenA1
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve \
+  P2MW.S_OVERLONG_6989a05c.ModularCurv\
+  e"
+
+local notation "Qbar" => AlgebraicClosure ℚ
+
+end ModularCurve.ElevenA1
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ map_map a₁ WeierstrassCurve.map_a₃ map Ψ₃ mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ WeierstrassCurve.map_a₆ reduction map_id IsIntegral \
+  toAffine WeierstrassCurve.map_a₂ Affine.Point WeierstrassCurve.map_a₁ WeierstrassCurve.map_a₄ \
+  map_Δ map_a₆ map_a₁ map_a₄ Δ Affine.equation_iff Affine.polynomial map_a₂ baseChange j map_a₃ \
+  Affine.finiteDimensional_ratFunc_functionField"
+end WeierstrassCurve
+
+namespace ModularCurve
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve"
+
+local notation "Qbar" => AlgebraicClosure ℚ
+
+end ModularCurve
+
+end
+
+section
+
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_6989a05c.Polynomial"
+
+p2m_open_scoped "Polynomial.Bivariate \
+  P2MW.S_OVERLONG_6989a05c.Polynomial.\
+  Bivariate"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ map_map a₁ WeierstrassCurve.map_a₃ map Ψ₃ mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ WeierstrassCurve.map_a₆ reduction map_id IsIntegral \
+  toAffine WeierstrassCurve.map_a₂ Affine.Point WeierstrassCurve.map_a₁ WeierstrassCurve.map_a₄ \
+  map_Δ map_a₆ map_a₁ map_a₄ Δ Affine.equation_iff Affine.polynomial map_a₂ baseChange j map_a₃ \
+  Affine.finiteDimensional_ratFunc_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation CoordinateRing.basis_one equation_iff' \
+  map_a₃ slope CoordinateRing.instIsDomain CoordinateRing map baseChange equation_add \
+  Equation.baseChange Point.some Point.some.injEq Point.some.inj map_a₆ FunctionField map_a₂ Point \
+  CoordinateRing.mk addX map_a₁ CoordinateRing.map map_a₄ CoordinateRing.basis_apply \
+  CoordinateRing.map_mk CoordinateRing.map_smul CoordinateRing.basis_zero CoordinateRing.basis \
+  addY equation_iff polynomial polyToFunctionField polyToFunctionField_apply \
+  polyToFunctionField_injective polyToFunctionField_C algebraMap_smul_basis \
+  finiteDimensional_ratFunc_functionField"
+end WeierstrassCurve.Affine
+
+end
+
+section
+
+p2m_open "IntermediateField \
+  P2MW.S_OVERLONG_6989a05c.Intermediat\
+  eField"
+
+namespace IntermediateField
+p2m_export "IntermediateField" "toAlgebra map_id mk algebra' mem_restrictScalars lift \
+  AdjoinSimple.gen inclusion ext adjoin_simple_le_iff algebraMap_apply smul_def \
+  lift_cardinalMk_adjoin_le FG adjoin instAlgebraSubtypeMem AdjoinSimple.algebraMap_gen map_map \
+  topEquiv mem_top restrictScalars finiteDimensional_adjoin adjoin_map subset_adjoin smul_mem \
+  normal isAlgebraic_iff map"
+p2m_open "IntermediateField"
+
+scoped instance (priority := 1010) ratAlgebra {L : Type*} [Field L] [Algebra ℚ L]
+    (E : IntermediateField ℚ L) : Algebra ℚ E :=
+  DivisionRing.toRatAlgebra
+
+end IntermediateField
+
+namespace AlgHom
+p2m_export "AlgHom" "codRestrict ext toLinearMap_apply commutes toLinearMap restrictScalars \
+  id_apply liftEquiv liftEquiv_tmul toFun_eq_coe rangeRestrict comp Finite.of_surjective mk \
+  toRingHom End toRingHom_eq_coe Finite.id fieldRange card coe_id Finite commutes' bijective \
+  comap_ker comp_apply Finite.comp"
+end AlgHom
+end
+
+section
+
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_6989a05c.Polynomial \
+  WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine WeierstrassCurve.Affine.Point \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine.Point"
+
+p2m_open_scoped "WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine Polynomial.Bivariate \
+  P2MW.S_OVERLONG_6989a05c.Polynomial.\
+  Bivariate"
+
+section
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine isUnit_Δ a₃ map_map a₁ WeierstrassCurve.map_a₃ map Ψ₃ mk \
+  Affine.equation_add a₄ Jacobian a₂ a₆ WeierstrassCurve.map_a₆ reduction map_id IsIntegral \
+  toAffine WeierstrassCurve.map_a₂ Affine.Point WeierstrassCurve.map_a₁ WeierstrassCurve.map_a₄ \
+  map_Δ map_a₆ map_a₁ map_a₄ Δ Affine.equation_iff Affine.polynomial map_a₂ baseChange j map_a₃ \
+  Affine.finiteDimensional_ratFunc_functionField"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Point.add Equation CoordinateRing.basis_one equation_iff' \
+  map_a₃ slope CoordinateRing.instIsDomain CoordinateRing map baseChange equation_add \
+  Equation.baseChange Point.some Point.some.injEq Point.some.inj map_a₆ FunctionField map_a₂ Point \
+  CoordinateRing.mk addX map_a₁ CoordinateRing.map map_a₄ CoordinateRing.basis_apply \
+  CoordinateRing.map_mk CoordinateRing.map_smul CoordinateRing.basis_zero CoordinateRing.basis \
+  addY equation_iff polynomial polyToFunctionField polyToFunctionField_apply \
+  polyToFunctionField_injective polyToFunctionField_C algebraMap_smul_basis \
+  finiteDimensional_ratFunc_functionField"
+p2m_open "WeierstrassCurve.Affine WeierstrassCurve"
+
+p2m_open "WeierstrassCurve.Affine.CoordinateRing \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine.CoordinateRing AlgebraicCurve \
+  P2MW.S_OVERLONG_6989a05c.AlgebraicCu\
+  rve"
+
+universe u
+
+variable {F : Type u} [Field F]
+
+section TranslationCoords
+
+variable (W : Affine F) (a b : F)
+
+local notation "ι" => algebraMap F W.FunctionField
+
+end TranslationCoords
+
+section GenericPointGroup
+
+variable {W : Affine F}
+
+local notation "ι" => algebraMap F W.FunctionField
+
+end GenericPointGroup
+
+
+section AdjoinSurjective
+
+variable {W : Affine F} (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b)
+
+local notation "ι" => algebraMap F W.FunctionField
+
+theorem transcendental_polyToFunctionField_X :
+    Transcendental F (polyToFunctionField W X) := by
+  rw [transcendental_iff]
+  intro p hp
+  rw [← polyToFunctionField_eq_aeval] at hp
+  exact polyToFunctionField_injective (by simpa using hp)
+
+end AdjoinSurjective
+end WeierstrassCurve.Affine
+end
+end
+
+
+section
+
+universe u
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine HahnSeries \
+  P2MW.S_OVERLONG_6989a05c.HahnSeries"
+
+namespace ModularCurve
+
+local notation "ℚ̄" => AlgebraicClosure ℚ
+
+def KwIsogenyEndDatumFGFieldDescent (K : Type uK) [Field K] [Algebra ℚ K] [DecidableEq K]
+    [IsAlgClosed K] [CharZero K] (E : WeierstrassCurve K) [E.IsElliptic] (N : ℕ) : Prop :=
+  (∃ D : TreeIsogenyEndDatum E.toAffine, D.degree = N) →
+    ∃ (K₀ : IntermediateField ℚ K) (_ : Countable K₀)
+      (E₀ : WeierstrassCurve K₀) (_ : E₀.IsElliptic) (_ : E₀.map (algebraMap K₀ K) = E)
+      (D₀ : TreeIsogenyEndDatum (E₀⁄(AlgebraicClosure K₀))), D₀.degree = N
+
+end ModularCurve
+end
+
+section
+
+
+section
+
+namespace ModularCurve
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine IntermediateField \
+  P2MW.S_OVERLONG_6989a05c.Intermediat\
+  eField AlgebraicCurve \
+  P2MW.S_OVERLONG_6989a05c.AlgebraicCu\
+  rve"
+
+def KwIsogenyEndDatumSubfieldDescent'' (K : Type uK) [Field K] [Algebra ℚ K]
+    [DecidableEq K] [IsAlgClosed K] [CharZero K] (E : WeierstrassCurve K) [E.IsElliptic]
+    (N : ℕ) : Prop :=
+  (∃ D : TreeIsogenyEndDatum E.toAffine, D.degree = N) →
+    ∃ (K₀ : IntermediateField ℚ K) (_ : K₀.FG)
+      (E₀ : WeierstrassCurve K₀) (_ : E₀.IsElliptic) (_ : E₀.map (algebraMap K₀ K) = E)
+      (D' : TreeIsogenyEndDatum E₀.toAffine), D'.degree = N
+
+def KwIsogenyEndDatumIotaDescendToFG (K : Type uK) [Field K] [Algebra ℚ K]
+    [DecidableEq K] [IsAlgClosed K] [CharZero K] (E : WeierstrassCurve K) [E.IsElliptic]
+    (D : TreeIsogenyEndDatum E.toAffine) : Prop :=
+  ∃ (K₀ : IntermediateField ℚ K) (_ : K₀.FG)
+    (E₀ : WeierstrassCurve K₀) (_ : E₀.IsElliptic) (_ : E₀.map (algebraMap K₀ K) = E)
+    (ι₀ : E₀.toAffine.FunctionField →ₐ[K₀] E₀.toAffine.FunctionField)
+    (_ : ι₀.toRingHom.IsIntegral) (_ : FiniteAlong K₀ ι₀),
+    finrankAlong K₀ ι₀ = D.degree
+
+theorem kw_subfieldDescent_of_iotaDescend (K : Type uK) [Field K] [Algebra ℚ K]
+    [DecidableEq K] [IsAlgClosed K] [CharZero K] (E : WeierstrassCurve K) [E.IsElliptic]
+    (N : ℕ)
+    (hIota : ∀ D : TreeIsogenyEndDatum E.toAffine, KwIsogenyEndDatumIotaDescendToFG K E D) :
+    KwIsogenyEndDatumSubfieldDescent'' K E N := by
+  intro ⟨D, hDN⟩
+  obtain ⟨K₀, hfg, E₀, hE₀ell, hE₀map, ι₀, hι₀, hfin₀, hdeg₀⟩ := hIota D
+  have : E₀.IsElliptic := hE₀ell
+  exact ⟨K₀, hfg, E₀, hE₀ell, hE₀map, ⟨ι₀, hι₀, hfin₀⟩, hdeg₀.trans hDN⟩
+
+end ModularCurve
+end
+end
+
+section
+
+
+section
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine \
+  P2MW.S_OVERLONG_6989a05c.ModularCurv\
+  e AlgebraicCurve \
+  P2MW.S_OVERLONG_6989a05c.AlgebraicCu\
+  rve"
+p2m_open "Polynomial \
+  P2MW.S_OVERLONG_6989a05c.Polynomial"
+p2m_open_scoped "TensorProduct \
+  P2MW.S_OVERLONG_6989a05c.TensorProdu\
+  ct Polynomial.Bivariate \
+  P2MW.S_OVERLONG_6989a05c.Polynomial.\
+  Bivariate Polynomial \
+  P2MW.S_OVERLONG_6989a05c.Polynomial \
+  Polynomial.Bivariate.Polynomial"
+
+namespace ModularCurve
+
+universe u
+
+section SetupBCG
+
+variable {R₀ : Type u} [Field R₀]
+variable (W : WeierstrassCurve R₀) [W.IsElliptic]
+variable (F : Type u) [Field F] [Algebra R₀ F] [DecidableEq F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra R₀ F'] [DecidableEq F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower R₀ F F']
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [Algebra R₀ F] [CharZero F] [CharZero F'] [IsScalarTower R₀ F F'] in
+theorem kw_transcendental_polyToFunctionField_X_over_baseGeneralNoAC :
+    Transcendental F (polyToFunctionField (W⁄F') X) := by
+  classical
+  exact
+    Transcendental.of_tower_top F (L := F')
+      (transcendental_polyToFunctionField_X (W := (W⁄F')))
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [CharZero F'] in
+theorem kw_equation_map_polyToFunctionField_yGen_over_baseGeneralNoAC :
+    ((W⁄F).map (algebraMap F (W⁄F').FunctionField)).toAffine.Equation
+      (polyToFunctionField (W⁄F') X) (yGen (W⁄F')) := by
+  classical
+  have hcurve : (W⁄F).map (algebraMap F (W⁄F').FunctionField)
+      = (W⁄F').map (algebraMap F' (W⁄F').FunctionField) := by
+    change (W.map _).map _ = (W.map _).map _
+    rw [WeierstrassCurve.map_map, WeierstrassCurve.map_map]
+    congr 1
+    exact ((IsScalarTower.algebraMap_eq R₀ F (W⁄F').FunctionField).symm).trans
+      (IsScalarTower.algebraMap_eq R₀ F' (W⁄F').FunctionField)
+  exact hcurve ▸ equation_map_polyToFunctionField_yGen (W := (W⁄F'))
+
+def kw_functionFieldMapAlongGeneralNoAC : (W⁄F).FunctionField →ₐ[F] (W⁄F').FunctionField :=
+  pointPullbackHomTo (kw_equation_map_polyToFunctionField_yGen_over_baseGeneralNoAC W F F')
+    ((injective_iff_map_eq_zero _).mpr fun p hp =>
+      transcendental_iff.mp (kw_transcendental_polyToFunctionField_X_over_baseGeneralNoAC W F F') p
+        hp)
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [CharZero F'] in
+theorem kw_functionFieldMapAlongGeneralNoAC_polyToFunctionField_X :
+    kw_functionFieldMapAlongGeneralNoAC W F F' (polyToFunctionField (W⁄F) X)
+      = polyToFunctionField (W⁄F') X := by
+  classical
+  exact
+    pointPullbackHomTo_polyToFunctionField_X _ _
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [CharZero F'] in
+theorem kw_functionFieldMapAlongGeneralNoAC_yGen :
+    kw_functionFieldMapAlongGeneralNoAC W F F' (yGen (W⁄F)) = yGen (W⁄F') := by
+  classical
+  exact
+    pointPullbackHomTo_yGen _ _
+
+def KwFunctionFieldTensorIsDomainGeneralNoAC : Prop :=
+  IsDomain ((W⁄F).FunctionField ⊗[F] F')
+
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+scoped instance kw_isScalarTower_base_right_tensorGeneralNoAC :
+    IsScalarTower R₀ F' ((W⁄F).FunctionField ⊗[F] F') := by
+  refine IsScalarTower.of_algebraMap_eq' (RingHom.ext fun r => ?_)
+  rw [RingHom.comp_apply, Algebra.TensorProduct.right_algebraMap_apply,
+    IsScalarTower.algebraMap_apply R₀ F F',
+    show algebraMap R₀ ((W⁄F).FunctionField ⊗[F] F') r
+      = (algebraMap F ((W⁄F).FunctionField ⊗[F] F')) (algebraMap R₀ F r) from
+        IsScalarTower.algebraMap_apply R₀ F ((W⁄F).FunctionField ⊗[F] F') r,
+    Algebra.TensorProduct.algebraMap_apply, Algebra.algebraMap_eq_smul_one,
+    Algebra.algebraMap_eq_smul_one, TensorProduct.smul_tmul, Algebra.algebraMap_eq_smul_one]
+
+section FracHom
+
+variable [IsDomain ((W⁄F).FunctionField ⊗[F] F')]
+
+scoped instance kw_isScalarTower_base_right_fracTensorGeneralNoAC :
+    IsScalarTower R₀ F' (FractionRing ((W⁄F).FunctionField ⊗[F] F')) :=
+  IsScalarTower.of_algebraMap_eq fun r =>
+    (IsScalarTower.algebraMap_apply R₀ ((W⁄F).FunctionField ⊗[F] F')
+        (FractionRing ((W⁄F).FunctionField ⊗[F] F')) r).trans <|
+      (congrArg (algebraMap ((W⁄F).FunctionField ⊗[F] F')
+          (FractionRing ((W⁄F).FunctionField ⊗[F] F')))
+        (IsScalarTower.algebraMap_apply R₀ F' ((W⁄F).FunctionField ⊗[F] F') r)).trans
+      (IsScalarTower.algebraMap_apply F' ((W⁄F).FunctionField ⊗[F] F')
+        (FractionRing ((W⁄F).FunctionField ⊗[F] F')) (algebraMap R₀ F' r)).symm
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [CharZero F'] [IsDomain ((W⁄F).FunctionField ⊗[F] F')] in
+theorem kw_equation_tensorFracXYGeneralNoAC :
+    ((W⁄F').map (algebraMap F' (FractionRing ((W⁄F).FunctionField ⊗[F] F')))).toAffine.Equation
+      (algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+        ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')))
+      (algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+        ((yGen (W⁄F)) ⊗ₜ[F] (1 : F'))) := by
+  classical
+  have hcurve : (W⁄F').map (algebraMap F' (FractionRing ((W⁄F).FunctionField ⊗[F] F')))
+      = W⁄(FractionRing ((W⁄F).FunctionField ⊗[F] F')) := by
+    change (W.map _).map _ = W.map _
+    rw [WeierstrassCurve.map_map]; congr 1
+    exact (IsScalarTower.algebraMap_eq R₀ F'
+      (FractionRing ((W⁄F).FunctionField ⊗[F] F'))).symm
+  rw [hcurve]
+  exact Equation.baseChange (W := W) (S := R₀)
+    (f := (IsScalarTower.toAlgHom R₀ ((W⁄F).FunctionField ⊗[F] F')
+            (FractionRing ((W⁄F).FunctionField ⊗[F] F'))).comp
+          (Algebra.TensorProduct.includeLeft (R := F) (S := R₀)))
+    (equation_map_polyToFunctionField_yGen (W := (W⁄F)))
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [Algebra R₀ F'] [CharZero F'] [IsScalarTower R₀ F F']
+  [IsDomain ((W⁄F).FunctionField ⊗[F] F')] in
+theorem kw_transcendental_tensorFracXGeneralNoAC :
+    Function.Injective (Polynomial.aeval (R := F')
+      (algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+        ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')))) := by
+  classical
+  rw [show algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+        ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F'))
+      = IsScalarTower.toAlgHom F' ((W⁄F).FunctionField ⊗[F] F')
+          (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+          ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')) from rfl,
+    Polynomial.aeval_algHom]
+  refine (IsFractionRing.injective ((W⁄F).FunctionField ⊗[F] F')
+    (FractionRing ((W⁄F).FunctionField ⊗[F] F'))).comp ?_
+  have heq : (Polynomial.aeval (R := F')
+        ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')
+          : (W⁄F).FunctionField ⊗[F] F')).toRingHom
+      = ((Algebra.TensorProduct.map
+            (Polynomial.aeval (R := F) (polyToFunctionField (W⁄F) X))
+            (AlgHom.id F F')).toRingHom.comp
+          (Algebra.TensorProduct.comm F F' F[X]).toAlgHom.toRingHom).comp
+          (polyEquivTensor' F F').toAlgHom.toRingHom := by
+    refine Polynomial.ringHom_ext (fun c => ?_) ?_
+    · change aeval _ (C c) = Algebra.TensorProduct.map _ _
+          (Algebra.TensorProduct.comm F F' F[X] (polyEquivTensor' F F' (C c)))
+      rw [show (polyEquivTensor' F F') (C c) = c ⊗ₜ[F] (1 : F[X]) from by
+            rw [coe_polyEquivTensor', polyEquivTensor_apply, eval₂_C]; rfl,
+        Algebra.TensorProduct.comm_tmul, Algebra.TensorProduct.map_tmul, Polynomial.aeval_C,
+        Algebra.TensorProduct.right_algebraMap_apply, AlgHom.coe_id, id_eq, map_one]
+    · change aeval _ (X : F'[X]) = Algebra.TensorProduct.map _ _
+          (Algebra.TensorProduct.comm F F' F[X] (polyEquivTensor' F F' X))
+      rw [show (polyEquivTensor' F F') X = (1:F') ⊗ₜ[F] (X : F[X]) from by
+            rw [coe_polyEquivTensor', polyEquivTensor_apply, eval₂_X],
+        Algebra.TensorProduct.comm_tmul, Algebra.TensorProduct.map_tmul, Polynomial.aeval_X,
+        AlgHom.coe_id, id_eq, Polynomial.aeval_X]
+  have hinj : Function.Injective
+      (((Algebra.TensorProduct.map
+          (Polynomial.aeval (R := F) (polyToFunctionField (W⁄F) X))
+          (AlgHom.id F F')).toRingHom.comp
+        (Algebra.TensorProduct.comm F F' F[X]).toAlgHom.toRingHom).comp
+        (polyEquivTensor' F F').toAlgHom.toRingHom) :=
+    ((Module.Flat.rTensor_preserves_injective_linearMap (M := F')
+        (Polynomial.aeval (R := F) (polyToFunctionField (W⁄F) X)).toLinearMap
+        ((injective_iff_map_eq_zero _).mpr fun p hp =>
+          transcendental_iff.mp (transcendental_polyToFunctionField_X (W := (W⁄F))) p hp)).comp
+      (Algebra.TensorProduct.comm F F' F[X]).injective).comp (polyEquivTensor' F F').injective
+  intro p q hpq
+  refine hinj ?_
+  have := DFunLike.congr_fun heq
+  exact (this p).symm.trans (hpq.trans (this q))
+
+def kw_functionFieldTensorFracHomGeneralNoAC :
+    (W⁄F').FunctionField →ₐ[F'] FractionRing ((W⁄F).FunctionField ⊗[F] F') :=
+  pointPullbackHomTo (kw_equation_tensorFracXYGeneralNoAC W F F')
+    (kw_transcendental_tensorFracXGeneralNoAC W F F')
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [CharZero F'] in
+theorem kw_functionFieldTensorFracHomGeneralNoAC_X :
+    kw_functionFieldTensorFracHomGeneralNoAC W F F' (polyToFunctionField (W⁄F') X)
+      = algebraMap ((W⁄F).FunctionField ⊗[F] F') _
+          ((polyToFunctionField (W⁄F) X) ⊗ₜ[F] (1 : F')) := by
+  classical
+  exact
+    pointPullbackHomTo_polyToFunctionField_X _ _
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [CharZero F'] in
+theorem kw_functionFieldTensorFracHomGeneralNoAC_yGen :
+    kw_functionFieldTensorFracHomGeneralNoAC W F F' (yGen (W⁄F'))
+      = algebraMap ((W⁄F).FunctionField ⊗[F] F') _ ((yGen (W⁄F)) ⊗ₜ[F] (1 : F')) := by
+  classical
+  exact
+    pointPullbackHomTo_yGen _ _
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [CharZero F'] in
+theorem kw_functionFieldTensorFracHomGeneralNoAC_bijective :
+    Function.Bijective (kw_functionFieldTensorFracHomGeneralNoAC W F F') := by
+  classical
+  refine ⟨(kw_functionFieldTensorFracHomGeneralNoAC W F F').injective, ?_⟩
+  set ψ := kw_functionFieldTensorFracHomGeneralNoAC W F F'
+  have hκ : (ψ.restrictScalars F).comp (kw_functionFieldMapAlongGeneralNoAC W F F')
+      = (IsScalarTower.toAlgHom F ((W⁄F).FunctionField ⊗[F] F')
+          (FractionRing ((W⁄F).FunctionField ⊗[F] F'))).comp
+          (Algebra.TensorProduct.includeLeft (R := F)) := by
+    refine kw_functionField_algHom_ext ?_ ?_
+    · change ψ (kw_functionFieldMapAlongGeneralNoAC W F F' (polyToFunctionField (W⁄F) X)) = _
+      rw [kw_functionFieldMapAlongGeneralNoAC_polyToFunctionField_X,
+        kw_functionFieldTensorFracHomGeneralNoAC_X]
+      rfl
+    · change ψ (kw_functionFieldMapAlongGeneralNoAC W F F' (yGen (W⁄F))) = _
+      rw [kw_functionFieldMapAlongGeneralNoAC_yGen, kw_functionFieldTensorFracHomGeneralNoAC_yGen]
+      rfl
+  have hT_sub : ∀ t : (W⁄F).FunctionField ⊗[F] F',
+      algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing _) t ∈ ψ.toRingHom.fieldRange := by
+    intro t
+    induction t with
+    | add _ _ hx hy => simp only [map_add]; exact add_mem hx hy
+    | tmul a c =>
+      rw [show (a ⊗ₜ[F] c : (W⁄F).FunctionField ⊗[F] F') = (a ⊗ₜ[F] 1) * (1 ⊗ₜ[F] c) from
+            by rw [Algebra.TensorProduct.tmul_mul_tmul, mul_one, one_mul],
+        map_mul]
+      refine mul_mem ?_ ⟨algebraMap F' _ c, ?_⟩
+      · exact ⟨kw_functionFieldMapAlongGeneralNoAC W F F' a, DFunLike.congr_fun hκ a⟩
+      · simp only [AlgHom.toRingHom_eq_coe, RingHom.coe_coe, ψ.commutes,
+          IsScalarTower.algebraMap_apply F' ((W⁄F).FunctionField ⊗[F] F')
+            (FractionRing ((W⁄F).FunctionField ⊗[F] F')),
+          Algebra.TensorProduct.right_algebraMap_apply]
+  intro z
+  obtain ⟨t, s, _, rfl⟩ := IsFractionRing.div_surjective
+    (A := (W⁄F).FunctionField ⊗[F] F') (K := FractionRing _) z
+  exact div_mem (hT_sub t) (hT_sub s)
+
+def kw_functionFieldTensorFracEquivGeneralNoAC :
+    (W⁄F').FunctionField ≃ₐ[F'] FractionRing ((W⁄F).FunctionField ⊗[F] F') :=
+  AlgEquiv.ofBijective _ (kw_functionFieldTensorFracHomGeneralNoAC_bijective W F F')
+
+def kw_tensorIotaRingHomGeneralNoAC (D : TreeIsogenyEndDatum (W⁄F)) :
+    (W⁄F).FunctionField ⊗[F] F' →+* (W⁄F).FunctionField ⊗[F] F' :=
+  (Algebra.TensorProduct.map D.ι (AlgHom.id F F')).toRingHom
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [Algebra R₀ F'] [CharZero F'] [IsScalarTower R₀ F F']
+  [IsDomain ((W⁄F).FunctionField ⊗[F] F')] in
+theorem kw_tensorIotaRingHomGeneralNoAC_tmul (D : TreeIsogenyEndDatum (W⁄F))
+    (a : (W⁄F).FunctionField)
+    (c : F') : kw_tensorIotaRingHomGeneralNoAC W F F' D (a ⊗ₜ[F] c) = (D.ι a) ⊗ₜ[F] c := by
+  classical
+  simp [kw_tensorIotaRingHomGeneralNoAC, Algebra.TensorProduct.map_tmul]
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [Algebra R₀ F'] [CharZero F'] [IsScalarTower R₀ F F']
+  [IsDomain ((W⁄F).FunctionField ⊗[F] F')] in
+theorem kw_tensorIotaRingHomGeneralNoAC_injective (D : TreeIsogenyEndDatum (W⁄F)) :
+    Function.Injective (kw_tensorIotaRingHomGeneralNoAC W F F' D) := by
+  classical
+  exact
+    Module.Flat.rTensor_preserves_injective_linearMap (M := F') D.ι.toLinearMap D.ι.injective
+
+def kw_tensorFracIotaRingHomGeneralNoAC (D : TreeIsogenyEndDatum (W⁄F)) :
+    FractionRing ((W⁄F).FunctionField ⊗[F] F')
+      →+* FractionRing ((W⁄F).FunctionField ⊗[F] F') :=
+  IsFractionRing.map (K := FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+    (L := FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+    (kw_tensorIotaRingHomGeneralNoAC_injective W F F' D)
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [Algebra R₀ F'] [CharZero F'] [IsScalarTower R₀ F F'] in
+theorem kw_tensorFracIotaRingHomGeneralNoAC_algebraMap (D : TreeIsogenyEndDatum (W⁄F))
+    (t : (W⁄F).FunctionField ⊗[F] F') :
+    kw_tensorFracIotaRingHomGeneralNoAC W F F' D
+        (algebraMap ((W⁄F).FunctionField ⊗[F] F')
+          (FractionRing ((W⁄F).FunctionField ⊗[F] F')) t)
+      = algebraMap ((W⁄F).FunctionField ⊗[F] F') (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+          (kw_tensorIotaRingHomGeneralNoAC W F F' D t) := by
+  classical
+  unfold kw_tensorFracIotaRingHomGeneralNoAC IsFractionRing.map
+  exact IsLocalization.map_eq (T := nonZeroDivisors ((W⁄F).FunctionField ⊗[F] F')) _ t
+
+def KwTensorFracIotaFinrankSeamGeneralNoAC : Prop :=
+  ∀ D : TreeIsogenyEndDatum (W⁄F),
+    (kw_tensorFracIotaRingHomGeneralNoAC W F F' D).Finite ∧
+    (letI := (kw_tensorFracIotaRingHomGeneralNoAC W F F' D).toAlgebra
+     @Module.finrank (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+       (FractionRing ((W⁄F).FunctionField ⊗[F] F')) _ _ Algebra.toModule) = D.degree
+
+def kw_isogenyEndDatumBaseChangeIotaGeneralNoAC (D : TreeIsogenyEndDatum (W⁄F)) :
+    (W⁄F').FunctionField →ₐ[F'] (W⁄F').FunctionField :=
+  let ψ := kw_functionFieldTensorFracEquivGeneralNoAC W F F'
+  { ψ.symm.toRingEquiv.toRingHom.comp
+      ((kw_tensorFracIotaRingHomGeneralNoAC W F F' D).comp ψ.toRingEquiv.toRingHom) with
+    commutes' := fun c => by
+      have hc : ψ (algebraMap F' (W⁄F').FunctionField c)
+          = algebraMap ((W⁄F).FunctionField ⊗[F] F')
+              (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+              ((1 : (W⁄F).FunctionField) ⊗ₜ[F] c) := by
+        rw [AlgEquiv.commutes, IsScalarTower.algebraMap_apply F' ((W⁄F).FunctionField ⊗[F] F')
+          (FractionRing ((W⁄F).FunctionField ⊗[F] F')),
+          Algebra.TensorProduct.right_algebraMap_apply]
+      change ψ.symm (kw_tensorFracIotaRingHomGeneralNoAC W F F' D (ψ (algebraMap F' _ c)))
+          = algebraMap F' _ c
+      rw [hc, kw_tensorFracIotaRingHomGeneralNoAC_algebraMap, kw_tensorIotaRingHomGeneralNoAC_tmul,
+        map_one, ← hc]
+      exact ψ.symm_apply_apply _ }
+
+def KwIsogenyEndDatumBaseChangeAlongGeneralNoAC (_σ : F →ₐ[R₀] F') (N : ℕ) : Prop :=
+  (∃ D : TreeIsogenyEndDatum (W⁄F), D.degree = N) →
+    ∃ D' : TreeIsogenyEndDatum (W⁄F'), D'.degree = N
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [CharZero F'] in
+theorem kw_isogenyEndDatumBaseChangeAlong_of_isDomain_tensorGeneralNoAC
+    (hseam : KwTensorFracIotaFinrankSeamGeneralNoAC W F F')
+    (σ : F →ₐ[R₀] F') (N : ℕ) : KwIsogenyEndDatumBaseChangeAlongGeneralNoAC W F F' σ N := by
+  classical
+  intro ⟨D, hD⟩
+  let ψ := kw_functionFieldTensorFracEquivGeneralNoAC W F F'
+  let ιFr := kw_tensorFracIotaRingHomGeneralNoAC W F F' D
+  obtain ⟨hfin_Fr, hdeg_Fr⟩ := hseam D
+  have hcomm : ∀ x, ιFr (ψ x) = ψ (kw_isogenyEndDatumBaseChangeIotaGeneralNoAC W F F' D x) :=
+    fun x => (ψ.apply_symm_apply _).symm
+  have hfin : (kw_isogenyEndDatumBaseChangeIotaGeneralNoAC W F F' D).toRingHom.Finite := by
+    have h₁ : (kw_isogenyEndDatumBaseChangeIotaGeneralNoAC W F F' D).toRingHom
+        = ψ.symm.toRingEquiv.toRingHom.comp (ιFr.comp ψ.toRingEquiv.toRingHom) := rfl
+    rw [h₁]
+    exact (RingHom.Finite.of_surjective _ ψ.symm.surjective).comp
+      (hfin_Fr.comp (RingHom.Finite.of_surjective _ ψ.surjective))
+  refine ⟨⟨kw_isogenyEndDatumBaseChangeIotaGeneralNoAC W F F' D, hfin.to_isIntegral, hfin⟩, ?_⟩
+  refine hD ▸ ?_
+  exact (@Algebra.finrank_eq_of_equiv_equiv
+      (W⁄F').FunctionField (W⁄F').FunctionField _ _
+      (algebraAlong (kw_isogenyEndDatumBaseChangeIotaGeneralNoAC W F F' D))
+      (FractionRing ((W⁄F).FunctionField ⊗[F] F'))
+      (FractionRing ((W⁄F).FunctionField ⊗[F] F')) _ _
+      (ιFr.toAlgebra) ψ.toRingEquiv ψ.toRingEquiv
+      (RingHom.ext hcomm)).trans hdeg_Fr
+
+end FracHom
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [CharZero F'] in
+theorem kw_isogenyEndDatumBaseChangeAlong_of_tensorIsDomainGeneralNoAC
+    (htens : KwFunctionFieldTensorIsDomainGeneralNoAC W F F')
+    (hseam : haveI : IsDomain ((W⁄F).FunctionField ⊗[F] F') := htens
+             KwTensorFracIotaFinrankSeamGeneralNoAC W F F')
+    (σ : F →ₐ[R₀] F') (N : ℕ) :
+    KwIsogenyEndDatumBaseChangeAlongGeneralNoAC W F F' σ N := by
+  classical
+  exact
+    haveI : IsDomain ((W⁄F).FunctionField ⊗[F] F') := htens
+    kw_isogenyEndDatumBaseChangeAlong_of_isDomain_tensorGeneralNoAC W F F' hseam σ N
+
+end SetupBCG
+
+section SetupBCGD
+
+variable {R₀ : Type u} [Field R₀]
+variable (W : WeierstrassCurve R₀) [W.IsElliptic]
+variable (F : Type u) [Field F] [Algebra R₀ F] [DecidableEq F] [CharZero F]
+variable (F' : Type u) [Field F'] [Algebra R₀ F'] [DecidableEq F'] [CharZero F']
+variable [Algebra F F'] [IsScalarTower R₀ F F']
+
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+section FFDomain
+
+local notation3 "CR" => (W⁄F).toAffine.CoordinateRing
+local notation3 "FFₗ" => (W⁄F).FunctionField
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [Algebra R₀ F'] [CharZero F'] [IsScalarTower R₀ F F'] in
+theorem kw_coordinateRingMap_basisGeneralNoAC (i : ℕ × Fin 2) :
+    CoordinateRing.map (W⁄F).toAffine (algebraMap F F')
+        (kw_coordinateRingBasis (W⁄F).toAffine i)
+      = kw_coordinateRingBasis ((W⁄F).toAffine.map (algebraMap F F')) i := by
+  classical
+  obtain ⟨n, j⟩ := i
+  simp only [kw_coordinateRingBasis, Module.Basis.smulTower_apply,
+    Polynomial.coe_basisMonomials, CoordinateRing.map_smul]
+  congr 1
+  · simp [Polynomial.map_monomial]
+  · rcases j with ⟨j, hj⟩
+    interval_cases j <;>
+      simp [CoordinateRing.basis_apply, CoordinateRing.map,
+        AdjoinRoot.lift_root, AdjoinRoot.powerBasis'_gen]
+
+def kw_coordinateRingMapAlongGeneralNoAC :
+    CR →ₐ[F] ((W⁄F).toAffine.map (algebraMap F F')).CoordinateRing where
+  __ := CoordinateRing.map (W⁄F).toAffine (algebraMap F F')
+  commutes' r := by
+    simp only [RingHom.toMonoidHom_eq_coe, OneHom.toFun_eq_coe, MonoidHom.toOneHom_coe,
+      MonoidHom.coe_ofClass]
+    change CoordinateRing.map (W⁄F).toAffine (algebraMap F F') (algebraMap F CR r) = algebraMap F _
+      r
+    rw [IsScalarTower.algebraMap_apply F F[X] CR,
+      show (algebraMap F F[X] r) = Polynomial.C r from rfl,
+      show (algebraMap F[X] CR) (C r) = (C r : F[X]) • (1 : CR) by
+        rw [Algebra.smul_def, mul_one],
+      CoordinateRing.map_smul, map_one, Polynomial.map_C,
+      IsScalarTower.algebraMap_apply F F' ((W⁄F).toAffine.map (algebraMap F F')).CoordinateRing,
+      IsScalarTower.algebraMap_apply F' F'[X]
+        ((W⁄F).toAffine.map (algebraMap F F')).CoordinateRing,
+      show (algebraMap F' F'[X]) ((algebraMap F F') r) = Polynomial.C ((algebraMap F F') r)
+        from rfl,
+      Algebra.smul_def, mul_one]
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [Algebra R₀ F'] [CharZero F'] [IsScalarTower R₀ F F'] in
+theorem kw_coordinateRingTensor_isDomainGeneralNoAC : IsDomain (CR ⊗[F] F') := by
+  classical
+  suffices h : IsDomain (F' ⊗[F] CR) by
+    have := h
+    exact Function.Injective.isDomain (Algebra.TensorProduct.comm F CR F').toRingHom
+      (Algebra.TensorProduct.comm F CR F').injective
+  set W'' := (W⁄F).toAffine.map (algebraMap F F') with hW''
+  let θ : F' ⊗[F] CR →ₐ[F'] W''.CoordinateRing :=
+    AlgHom.liftEquiv F F' CR W''.CoordinateRing (kw_coordinateRingMapAlongGeneralNoAC W F F')
+  have hθ : Function.Injective θ := by
+    let bT : Module.Basis (ℕ × Fin 2) F' (F' ⊗[F] CR) :=
+      Algebra.TensorProduct.basis F' (kw_coordinateRingBasis (W⁄F).toAffine)
+    let bD : Module.Basis (ℕ × Fin 2) F' W''.CoordinateRing := kw_coordinateRingBasis W''
+    have key : ∀ i, θ.toLinearMap (bT i) = (bT.equiv bD (Equiv.refl _)) (bT i) := fun i => by
+      rw [Module.Basis.equiv_apply, Equiv.refl_apply, AlgHom.toLinearMap_apply]
+      simp only [bT, Algebra.TensorProduct.basis_apply, θ, AlgHom.liftEquiv_tmul, one_smul]
+      exact kw_coordinateRingMap_basisGeneralNoAC W F F' i
+    have heq : (θ : F' ⊗[F] CR → W''.CoordinateRing) = bT.equiv bD (Equiv.refl _) :=
+      funext fun x => DFunLike.congr_fun (bT.ext key : θ.toLinearMap = _) x
+    exact heq ▸ (bT.equiv bD (Equiv.refl _)).injective
+  exact Function.Injective.isDomain θ.toRingHom hθ
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [Algebra R₀ F'] [CharZero F'] [IsScalarTower R₀ F F'] in
+theorem kw_functionFieldTensorIsDomain_dischargeGeneralNoAC :
+    KwFunctionFieldTensorIsDomainGeneralNoAC W F F' := by
+  classical
+  change IsDomain (FFₗ ⊗[F] F')
+  have hCR : IsDomain (CR ⊗[F] F') := kw_coordinateRingTensor_isDomainGeneralNoAC W F F'
+  let : Algebra (CR ⊗[F] F') (FFₗ ⊗[F] F') :=
+    (Algebra.TensorProduct.map (IsScalarTower.toAlgHom F CR FFₗ)
+      (AlgHom.id F F')).toRingHom.toAlgebra
+  have hst : IsScalarTower CR (CR ⊗[F] F') (FFₗ ⊗[F] F') :=
+    IsScalarTower.of_algebraMap_eq (R := CR) (S := CR ⊗[F] F') (A := FFₗ ⊗[F] F') fun c => by
+      change Algebra.TensorProduct.map (IsScalarTower.toAlgHom F CR FFₗ) (AlgHom.id F F')
+          (algebraMap CR (CR ⊗[F] F') c) = algebraMap CR (FFₗ ⊗[F] F') c
+      rfl
+  have hloc : IsLocalization
+      (Algebra.algebraMapSubmonoid (CR ⊗[F] F') (nonZeroDivisors CR)) (FFₗ ⊗[F] F') :=
+    IsLocalization.tensorProduct_tensorProduct F F' (nonZeroDivisors CR) FFₗ (by
+      ext x; simp [RingHom.algebraMap_toAlgebra, Algebra.TensorProduct.map_tmul])
+  have hle : Algebra.algebraMapSubmonoid (CR ⊗[F] F') (nonZeroDivisors CR)
+      ≤ nonZeroDivisors (CR ⊗[F] F') := by
+    rintro _ ⟨c, hc, rfl⟩
+    refine mem_nonZeroDivisors_of_ne_zero ?_
+    have hinj : Function.Injective (algebraMap CR (CR ⊗[F] F')) :=
+      Algebra.TensorProduct.includeLeft_injective (S := F) (algebraMap F F').injective
+    exact fun h => (nonZeroDivisors.ne_zero hc) (hinj (by
+      simp only [_root_.map_zero] at h ⊢; exact h))
+  exact IsLocalization.isDomain_of_le_nonZeroDivisors
+    (M := Algebra.algebraMapSubmonoid (CR ⊗[F] F') (nonZeroDivisors CR)) _ hle
+
+end FFDomain
+
+section Seam
+
+variable [IsDomain ((W⁄F).FunctionField ⊗[F] F')]
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [Algebra R₀ F'] [CharZero F'] [IsScalarTower R₀ F F']
+  [IsDomain ((W⁄F).FunctionField ⊗[F] F')] in
+theorem kw_tensorIotaRingHom_finiteGeneralNoAC (D : TreeIsogenyEndDatum (W⁄F)) :
+    (kw_tensorIotaRingHomGeneralNoAC W F F' D).Finite := by
+  classical
+  exact
+    RingHom.Finite.tensorProductMap (f := D.ι) D.hfin (g := AlgHom.id F F') (RingHom.Finite.id F')
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [Algebra R₀ F'] [CharZero F'] [IsScalarTower R₀ F F'] in
+theorem kw_tensorFracIotaFinrankSeam_dischargeGeneralNoAC :
+    KwTensorFracIotaFinrankSeamGeneralNoAC W F F' := by
+  classical
+  intro D
+  let FF := (W⁄F).FunctionField
+  let T := (W⁄F).FunctionField ⊗[F] F'
+  let FrT := FractionRing ((W⁄F).FunctionField ⊗[F] F')
+  let ιT : T →+* T := kw_tensorIotaRingHomGeneralNoAC W F F' D
+  let ιFr : FrT →+* FrT := kw_tensorFracIotaRingHomGeneralNoAC W F F' D
+  have hιT_inj : Function.Injective ιT := kw_tensorIotaRingHomGeneralNoAC_injective W F F' D
+  have hιT_fin : ιT.Finite := kw_tensorIotaRingHom_finiteGeneralNoAC W F F' D
+  have hιFr_am : ∀ t : T, ιFr (algebraMap T FrT t) = algebraMap T FrT (ιT t) :=
+    kw_tensorFracIotaRingHomGeneralNoAC_algebraMap W F F' D
+  let algDι : Algebra FF FF := D.ι.toRingHom.toAlgebra
+  let smulDι : SMul FF FF := algDι.toSMul
+  let modDι : Module FF FF := Algebra.toModule
+  have hsmul_Dι : ∀ (c x : FF), c • x = D.ι c * x := fun c x => rfl
+  have hfinFF : Module.Finite FF FF := D.hfin
+  have hfreeFF : Module.Free FF FF := Module.Free.of_divisionRing FF FF
+  let b : Module.Basis (Fin D.degree) FF FF :=
+    Module.finBasisOfFinrankEq FF FF (n := D.degree) rfl
+  have hrepr_mul : ∀ (c x : FF) (j : Fin D.degree),
+      b.repr (D.ι c * x) j = c * b.repr x j := fun c x j => by
+    rw [← hsmul_Dι, map_smul, Finsupp.smul_apply, smul_eq_mul]
+  let e : Fin D.degree → T := fun i => (b i) ⊗ₜ[F] (1 : F')
+  let bFr : Fin D.degree → FrT := fun i => algebraMap T FrT (e i)
+  have hspanT : ∀ t : T, ∃ c : Fin D.degree → T, t = ∑ i, ιT (c i) * e i := by
+    intro t
+    induction t using TensorProduct.inductionOn with
+    | add x y hx hy =>
+      obtain ⟨cx, hx⟩ := hx; obtain ⟨cy, hy⟩ := hy
+      exact ⟨cx + cy, by simp only [Pi.add_apply, map_add, add_mul,
+        Finset.sum_add_distrib, ← hx, ← hy]⟩
+    | tmul a c =>
+      refine ⟨fun i => (b.repr a i) ⊗ₜ[F] c, ?_⟩
+      have hb_sum : a = ∑ i, D.ι (b.repr a i) * b i := by
+        conv_lhs => rw [← b.linearCombination_repr a, Finsupp.linearCombination_apply,
+          Finsupp.sum_fintype _ _ (fun i => by rw [hsmul_Dι, _root_.map_zero, zero_mul])]
+        exact Finset.sum_congr rfl fun i _ => hsmul_Dι _ _
+      calc (a ⊗ₜ[F] c : T)
+          = (∑ i, D.ι (b.repr a i) * b i) ⊗ₜ[F] c := by rw [← hb_sum]
+        _ = ∑ i, ιT ((b.repr a i) ⊗ₜ[F] c) * e i := by
+            rw [TensorProduct.sum_tmul]
+            refine Finset.sum_congr rfl fun i _ => ?_
+            rw [kw_tensorIotaRingHomGeneralNoAC_tmul W F F' D,
+              Algebra.TensorProduct.tmul_mul_tmul, mul_one]
+  have hliT : ∀ c : Fin D.degree → T, ∑ i, ιT (c i) * e i = 0 → ∀ j, c j = 0 := by
+    intro c hc j
+    let pj : FF →ₗ[F] FF :=
+      { toFun := fun x => b.repr x j
+        map_add' := fun x y => by simp only [map_add, Finsupp.add_apply]
+        map_smul' := fun f x => by
+          simp only [RingHom.id_apply, Algebra.smul_def]
+          have h := hrepr_mul (algebraMap F FF f) x j
+          rwa [D.ι.commutes] at h }
+    let Ej : T →ₗ[F] T := LinearMap.rTensor F' pj
+    have hEj_key : ∀ (a : T) (i : Fin D.degree),
+        Ej (ιT a * e i) = if i = j then a else 0 := by
+      intro a i
+      induction a using TensorProduct.inductionOn with
+      | add x y hx hy =>
+        simp only [map_add, add_mul, hx, hy]; split_ifs <;> simp
+      | tmul x c' =>
+        rw [show ιT ((x : FF) ⊗ₜ[F] c') = (D.ι x) ⊗ₜ[F] c' from
+              kw_tensorIotaRingHomGeneralNoAC_tmul W F F' D _ _,
+            Algebra.TensorProduct.tmul_mul_tmul, mul_one]
+        change (pj (D.ι x * b i)) ⊗ₜ[F] c' = if i = j then (x : FF) ⊗ₜ[F] c' else 0
+        rw [show pj (D.ι x * b i) = if i = j then x else 0 from ?_]
+        · split_ifs with h
+          · rfl
+          · exact TensorProduct.zero_tmul _ c'
+        · change b.repr (D.ι x * b i) j = if i = j then x else 0
+          rw [hrepr_mul, b.repr_self, Finsupp.single_apply]
+          split_ifs with h <;> simp
+    have hc' : Ej (∑ i, ιT (c i) * e i) = 0 := by rw [hc, _root_.map_zero]
+    simpa only [map_sum, hEj_key, Finset.sum_ite_eq', Finset.mem_univ, ite_true] using hc'
+  have hint : ∀ s : T, s ≠ 0 → ∃ (u s₀ : T), s₀ ≠ 0 ∧ s * u = ιT s₀ := by
+    intro s hs
+    obtain ⟨p, hp_monic, hp_eval⟩ : ιT.IsIntegralElem s := hιT_fin.to_isIntegral s
+    obtain ⟨q, hq_eq, hq_ndvd⟩ := Polynomial.exists_eq_pow_rootMultiplicity_mul_and_not_dvd p
+      hp_monic.ne_zero 0
+    simp only [Polynomial.C_0, sub_zero] at hq_eq hq_ndvd
+    have hq0 : q.coeff 0 ≠ 0 := fun h => hq_ndvd (Polynomial.X_dvd_iff.mpr h)
+    have hqs : q.eval₂ ιT s = 0 := by
+      have h := hp_eval
+      rw [hq_eq, Polynomial.eval₂_mul, Polynomial.eval₂_pow, Polynomial.eval₂_X,
+        mul_eq_zero] at h
+      exact h.resolve_left (pow_ne_zero _ hs)
+    have h3 : ιT (q.coeff 0) + s * (q.divX).eval₂ ιT s = 0 := by
+      have h := congrArg (Polynomial.eval₂ ιT s) (Polynomial.divX_mul_X_add q)
+      rw [Polynomial.eval₂_add, Polynomial.eval₂_mul, Polynomial.eval₂_X,
+        Polynomial.eval₂_C, hqs] at h
+      simpa only [add_comm, mul_comm] using h
+    exact ⟨(q.divX).eval₂ ιT s, -q.coeff 0, neg_ne_zero.mpr hq0,
+      by rw [_root_.map_neg]; exact eq_neg_of_add_eq_zero_right h3⟩
+  have hspanFr : ∀ z : FrT, ∃ d : Fin D.degree → FrT, z = ∑ i, ιFr (d i) * bFr i := by
+    intro z
+    obtain ⟨t, s, hs, rfl⟩ := IsFractionRing.div_surjective (A := T) (K := FrT) z
+    rcases eq_or_ne s 0 with rfl | hs'
+    · exact ⟨0, by simp⟩
+    obtain ⟨u, s₀, hs₀, hsu⟩ := hint s hs'
+    have hιTs₀ : ιT s₀ ≠ 0 := fun h => hs₀ (hιT_inj (h.trans (_root_.map_zero ιT).symm))
+    have hu_ne : u ≠ 0 := fun h => hιTs₀ (by rw [← hsu, h, mul_zero])
+    obtain ⟨c, hc⟩ := hspanT (t * u)
+    refine ⟨fun i => (algebraMap T FrT s₀)⁻¹ * algebraMap T FrT (c i), ?_⟩
+    have hum := (map_ne_zero_iff _ (IsFractionRing.injective T FrT)).mpr hu_ne
+    have hz : (algebraMap T FrT t) / (algebraMap T FrT s)
+        = (algebraMap T FrT (ιT s₀))⁻¹ * algebraMap T FrT (t * u) := by
+      rw [← div_eq_inv_mul, ← hsu, map_mul, map_mul,
+        ← div_mul_div_comm, div_self hum, mul_one]
+    rw [hz, hc, map_sum, Finset.mul_sum]
+    refine Finset.sum_congr rfl fun i _ => ?_
+    rw [map_mul, map_mul, ← hιFr_am s₀, ← hιFr_am (c i), ← map_inv₀ ιFr, mul_assoc]
+  have hliFr : ∀ d : Fin D.degree → FrT, ∑ i, ιFr (d i) * bFr i = 0 → ∀ j, d j = 0 := by
+    intro d hd j
+    obtain ⟨q, hq⟩ := IsLocalization.exist_integer_multiples_of_finset
+      (nonZeroDivisors T) (Finset.univ.image d)
+    choose p hp using fun i => hq (d i) (Finset.mem_image_of_mem d (Finset.mem_univ i))
+    have hq0 : (algebraMap T FrT (q : T)) ≠ 0 :=
+      (map_ne_zero_iff _ (IsFractionRing.injective T FrT)).mpr (nonZeroDivisors.ne_zero q.2)
+    have hp' : ∀ i, algebraMap T FrT (p i) = algebraMap T FrT (q : T) * d i := fun i => by
+      rw [hp i, Algebra.smul_def]
+    have hd' : algebraMap T FrT (∑ i, ιT (p i) * e i) = 0 := by
+      have h1 : ∑ i, ιFr (algebraMap T FrT (q : T)) * (ιFr (d i) * bFr i) = 0 := by
+        rw [← Finset.mul_sum, hd, mul_zero]
+      rw [map_sum, ← h1]; refine Finset.sum_congr rfl fun i _ => ?_
+      rw [map_mul, ← hιFr_am (p i), ← mul_assoc, ← map_mul, ← hp' i]
+    have hpj : p j = 0 :=
+      hliT p ((IsFractionRing.injective T FrT) (by simpa using hd')) j
+    have hthis : algebraMap T FrT (q : T) * d j = 0 := by
+      rw [← hp' j, hpj, _root_.map_zero]
+    exact (mul_eq_zero.mp hthis).resolve_left hq0
+  let algFr : Algebra FrT FrT := ιFr.toAlgebra
+  let smulFr : SMul FrT FrT := algFr.toSMul
+  let modFr : Module FrT FrT := Algebra.toModule
+  have hsmul_Fr : ∀ (c x : FrT), c • x = ιFr c * x := fun c x => rfl
+  have hli_modFr : LinearIndependent FrT bFr := by
+    rw [Fintype.linearIndependent_iff]
+    intro g hg i
+    refine hliFr g ?_ i
+    simpa only [hsmul_Fr] using hg
+  have hsp_modFr : ⊤ ≤ Submodule.span FrT (Set.range bFr) := by
+    intro z _
+    obtain ⟨d, hd⟩ := hspanFr z
+    rw [hd]
+    exact Submodule.sum_mem _ fun i _ => (hsmul_Fr (d i) (bFr i)) ▸
+      Submodule.smul_mem _ (d i) (Submodule.subset_span ⟨i, rfl⟩)
+  let bFr' : Module.Basis (Fin D.degree) FrT FrT := .mk hli_modFr hsp_modFr
+  refine ⟨Module.Finite.of_basis bFr', ?_⟩
+  change Module.finrank FrT FrT = D.degree
+  rw [Module.finrank_eq_card_basis bFr', Fintype.card_fin]
+
+end Seam
+
+omit [DecidableEq F] [DecidableEq F'] in
+omit [W.IsElliptic] [CharZero F] [CharZero F'] in
+theorem kw_isogenyEndDatumBaseChangeAlong_dischargeGeneralNoAC (σ : F →ₐ[R₀] F') (N : ℕ) :
+    KwIsogenyEndDatumBaseChangeAlongGeneralNoAC W F F' σ N := by
+  classical
+  exact
+    haveI : IsDomain ((W⁄F).FunctionField ⊗[F] F') :=
+      kw_functionFieldTensorIsDomain_dischargeGeneralNoAC W F F'
+    kw_isogenyEndDatumBaseChangeAlong_of_tensorIsDomainGeneralNoAC W F F'
+      (kw_functionFieldTensorIsDomain_dischargeGeneralNoAC W F F')
+      (kw_tensorFracIotaFinrankSeam_dischargeGeneralNoAC W F F') σ N
+
+end SetupBCGD
+
+section BCACDischarge
+
+def KwIsogenyEndDatumBaseChangeToAlgebraicClosure'' (K₀ : Type uK) [Field K₀] [CharZero K₀]
+    (E₀ : WeierstrassCurve K₀) [E₀.IsElliptic] (N : ℕ) : Prop :=
+  (∃ D' : TreeIsogenyEndDatum E₀.toAffine, D'.degree = N) →
+    ∃ D₀ : TreeIsogenyEndDatum (E₀⁄(AlgebraicClosure K₀)), D₀.degree = N
+
+theorem kw_baseChangeToAC_uncond (K₀ : Type uK) [Field K₀] [CharZero K₀]
+    (E₀ : WeierstrassCurve K₀) [E₀.IsElliptic] (N : ℕ) :
+    KwIsogenyEndDatumBaseChangeToAlgebraicClosure'' K₀ E₀ N := by
+  classical
+  have : DecidableEq (AlgebraicClosure K₀) := Classical.decEq _
+  have : CharZero (AlgebraicClosure K₀) :=
+    charZero_of_injective_algebraMap (algebraMap K₀ (AlgebraicClosure K₀)).injective
+  intro ⟨D', hD'⟩
+  have hmap_id : E₀⁄K₀ = E₀ := by
+    change E₀.map (algebraMap K₀ K₀) = E₀
+    rw [Algebra.algebraMap_self, WeierstrassCurve.map_id]
+  have hD'' : ∃ D : TreeIsogenyEndDatum (E₀⁄K₀), D.degree = N := by
+    rw [hmap_id]; exact ⟨D', hD'⟩
+  exact kw_isogenyEndDatumBaseChangeAlong_dischargeGeneralNoAC E₀ K₀ (AlgebraicClosure K₀)
+    (Algebra.ofId K₀ (AlgebraicClosure K₀)) N hD''
+
+end BCACDischarge
+end ModularCurve
+end
+end
+
+section
+
+
+section
+
+namespace ModularCurve
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine IntermediateField \
+  P2MW.S_OVERLONG_6989a05c.Intermediat\
+  eField AlgebraicCurve \
+  P2MW.S_OVERLONG_6989a05c.AlgebraicCu\
+  rve Polynomial \
+  P2MW.S_OVERLONG_6989a05c.Polynomial"
+
+section Carriers
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K]
+variable {K₀ : IntermediateField ℚ K}
+variable (E₀ : WeierstrassCurve K₀) [E₀.IsElliptic]
+
+local notation "E" => E₀.map (algebraMap K₀ K)
+
+def kw_iA_polyDescend (p : Polynomial K) (hmem : ∀ j, p.coeff j ∈ K₀) : Polynomial K₀ :=
+  ∑ j ∈ p.support, Polynomial.C (⟨p.coeff j, hmem j⟩ : K₀) * Polynomial.X ^ j
+
+omit [DecidableEq K] in
+theorem kw_iA_polyDescend_map (p : Polynomial K) (hmem : ∀ j, p.coeff j ∈ K₀) :
+    (kw_iA_polyDescend p hmem).map (algebraMap K₀ K) = p := by
+  classical
+  unfold kw_iA_polyDescend; rw [Polynomial.map_sum]
+  conv_rhs => rw [p.as_sum_support_C_mul_X_pow]
+  exact Finset.sum_congr rfl fun j _ => by
+    rw [Polynomial.map_mul, Polynomial.map_C, Polynomial.map_pow, Polynomial.map_X]; rfl
+
+def kw_iA_crCoeffsIn (c : (E).toAffine.CoordinateRing) : Prop :=
+  ∀ (i : Fin 2) (j : ℕ),
+    ((CoordinateRing.basis (E).toAffine).repr c i).coeff j ∈ K₀
+
+def kw_iA_crDescend (c : (E).toAffine.CoordinateRing) (hmem : kw_iA_crCoeffsIn E₀ c) :
+    E₀.toAffine.CoordinateRing :=
+  ∑ i : Fin 2, (kw_iA_polyDescend
+      ((CoordinateRing.basis (E).toAffine).repr c i) (hmem i))
+    • (CoordinateRing.basis E₀.toAffine) i
+
+omit [DecidableEq K] in
+omit [E₀.IsElliptic] in
+theorem kw_iA_crDescend_map (c : (E).toAffine.CoordinateRing)
+    (hmem : kw_iA_crCoeffsIn E₀ c) :
+    CoordinateRing.map E₀.toAffine (algebraMap K₀ K) (kw_iA_crDescend E₀ c hmem) = c := by
+  classical
+  unfold kw_iA_crDescend; rw [map_sum]
+  conv_rhs => rw [← (CoordinateRing.basis (E).toAffine).sum_repr c]
+  refine Finset.sum_congr rfl fun i _ => ?_
+  rw [CoordinateRing.map_smul]; congr 1
+  · exact kw_iA_polyDescend_map _ (hmem i)
+  · rcases Fin.exists_fin_two.mp ⟨i, rfl⟩ with h | h
+    · exact h ▸ by rw [CoordinateRing.basis_zero, CoordinateRing.basis_zero, map_one]
+    · exact h ▸ by rw [CoordinateRing.basis_one, CoordinateRing.basis_one,
+        CoordinateRing.map_mk, Polynomial.map_X]
+
+omit [DecidableEq K] in
+omit [E₀.IsElliptic] in
+theorem kw_iA_phiEquation :
+    (E₀.map (algebraMap K₀ (E).toAffine.FunctionField)).toAffine.Equation
+      (polyToFunctionField (E).toAffine X) (yGen (E).toAffine) := by
+  classical
+  have h : E₀.map (algebraMap K₀ (E).toAffine.FunctionField)
+      = (E).map (algebraMap K (E).toAffine.FunctionField) := by
+    rw [show (algebraMap K₀ (E).toAffine.FunctionField)
+        = (algebraMap K (E).toAffine.FunctionField).comp (algebraMap K₀ K) from
+      IsScalarTower.algebraMap_eq K₀ K (E).toAffine.FunctionField,
+      ← WeierstrassCurve.map_map]
+  exact h ▸ equation_map_polyToFunctionField_yGen (W := (E).toAffine)
+
+omit [DecidableEq K] in
+omit [E₀.IsElliptic] in
+theorem kw_iA_phiTranscendental :
+    Function.Injective
+      (Polynomial.aeval (R := K₀) (polyToFunctionField (E).toAffine X)) := by
+  classical
+  exact
+    (injective_iff_map_eq_zero _).mpr fun p hp => transcendental_iff.mp
+      ((transcendental_polyToFunctionField_X (W := (E).toAffine)).restrictScalars
+        (R := K₀) (algebraMap K₀ K).injective) p hp
+
+def kw_iA_phi : E₀.toAffine.FunctionField →ₐ[K₀] (E).toAffine.FunctionField :=
+  pointPullbackHomTo (kw_iA_phiEquation E₀) (kw_iA_phiTranscendental E₀)
+
+omit [DecidableEq K] in
+omit [Algebra ℚ K] in
+theorem kw_iA_polyToFF_eq_aeval (W : WeierstrassCurve.Affine K) :
+    polyToFunctionField W = (Polynomial.aeval (R := K) (polyToFunctionField W X)).toRingHom := by
+  classical
+  refine Polynomial.ringHom_ext (fun c => ?_) ?_
+  · rw [AlgHom.toRingHom_eq_coe, RingHom.coe_coe, Polynomial.aeval_C,
+      polyToFunctionField_apply,
+      show (algebraMap (Polynomial K) W.CoordinateRing) (C c)
+        = (algebraMap K W.CoordinateRing) c from
+        (IsScalarTower.algebraMap_apply K (Polynomial K) W.CoordinateRing c).symm,
+      ← IsScalarTower.algebraMap_apply K W.CoordinateRing W.FunctionField]
+  · rw [AlgHom.toRingHom_eq_coe, RingHom.coe_coe, Polynomial.aeval_X]
+
+omit [DecidableEq K] in
+omit [E₀.IsElliptic] in
+theorem kw_iA_phiCRCompat (c₀ : E₀.toAffine.CoordinateRing) :
+    kw_iA_phi E₀ (algebraMap E₀.toAffine.CoordinateRing E₀.toAffine.FunctionField c₀)
+      = algebraMap (E).toAffine.CoordinateRing (E).toAffine.FunctionField
+          (CoordinateRing.map E₀.toAffine (algebraMap K₀ K) c₀) := by
+  classical
+  obtain ⟨g, rfl⟩ := AdjoinRoot.mk_surjective c₀
+  unfold kw_iA_phi
+  rw [pointPullbackHomTo_algebraMap, CoordinateRing.map_mk]
+  revert g
+  suffices h : ((pointPullbackCoordHomTo (kw_iA_phiEquation E₀)).toRingHom.comp
+        (CoordinateRing.mk E₀.toAffine))
+      = ((algebraMap (E).toAffine.CoordinateRing (E).toAffine.FunctionField).comp
+          (CoordinateRing.mk (E).toAffine)).comp
+        (Polynomial.mapRingHom (Polynomial.mapRingHom (algebraMap K₀ K))) by
+    intro g; exact congrFun (congrArg DFunLike.coe h) g
+  refine Polynomial.ringHom_ext (fun p => ?_) ?_
+  · simp only [RingHom.comp_apply, AlgHom.toRingHom_eq_coe, RingHom.coe_coe,
+      Polynomial.coe_mapRingHom, Polynomial.map_C]
+    rw [← algebraMap_polynomial_eq_mk_C, ← algebraMap_polynomial_eq_mk_C,
+      ← polyToFunctionField_apply]
+    have hlhs := congrFun (congrArg DFunLike.coe
+      (pointPullbackCoordHomTo_comp_algebraMap (kw_iA_phiEquation E₀))) p
+    simp only [RingHom.comp_apply, AlgHom.toRingHom_eq_coe, RingHom.coe_coe] at hlhs
+    rw [hlhs, show polyToFunctionField (E).toAffine (p.map (algebraMap K₀ K))
+        = (Polynomial.aeval (R := K) (polyToFunctionField (E).toAffine X))
+            (p.map (algebraMap K₀ K)) from
+      congrFun (congrArg DFunLike.coe (kw_iA_polyToFF_eq_aeval (E).toAffine)) _]
+    exact (Polynomial.aeval_map_algebraMap K (polyToFunctionField (E).toAffine X) p).symm
+  · simp only [RingHom.comp_apply, AlgHom.toRingHom_eq_coe, RingHom.coe_coe,
+      Polynomial.coe_mapRingHom, Polynomial.map_X]
+    rw [pointPullbackCoordHomTo_mk, Polynomial.eval₂_X]; rfl
+
+omit [DecidableEq K] in
+omit [E₀.IsElliptic] in
+theorem kw_iA_ffDescend_exists (x : (E).toAffine.FunctionField)
+    (hnum : kw_iA_crCoeffsIn E₀
+      (IsLocalization.sec (nonZeroDivisors (E).toAffine.CoordinateRing) x).1)
+    (hden : kw_iA_crCoeffsIn E₀
+      ((IsLocalization.sec (nonZeroDivisors (E).toAffine.CoordinateRing) x).2 :
+        (E).toAffine.CoordinateRing)) :
+    ∃ x₀ : E₀.toAffine.FunctionField, kw_iA_phi E₀ x₀ = x := by
+  classical
+  let s := IsLocalization.sec (nonZeroDivisors (E).toAffine.CoordinateRing) x
+  have hdenNZ : (s.2 : (E).toAffine.CoordinateRing) ≠ 0 := nonZeroDivisors.coe_ne_zero _
+  refine ⟨algebraMap _ _ (kw_iA_crDescend E₀ s.1 hnum)
+    / algebraMap _ _ (kw_iA_crDescend E₀ (↑s.2) hden), ?_⟩
+  have hFFdenNZ : algebraMap (E).toAffine.CoordinateRing (E).toAffine.FunctionField
+      (s.2 : (E).toAffine.CoordinateRing) ≠ 0 :=
+    (map_ne_zero_iff _ (IsFractionRing.injective _ _)).mpr hdenNZ
+  rw [map_div₀, kw_iA_phiCRCompat, kw_iA_phiCRCompat,
+    kw_iA_crDescend_map E₀ s.1 hnum, kw_iA_crDescend_map E₀ _ hden,
+    div_eq_iff hFFdenNZ]
+  exact (IsLocalization.sec_spec (nonZeroDivisors (E).toAffine.CoordinateRing) x).symm
+
+end Carriers
+
+section Assembly
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable {K₀ : IntermediateField ℚ K}
+variable (E₀ : WeierstrassCurve K₀) [E₀.IsElliptic]
+
+local notation "E" => E₀.map (algebraMap K₀ K)
+
+def kw_iA_CoeffsHyp (D : TreeIsogenyEndDatum (E).toAffine) : Prop :=
+  (kw_iA_crCoeffsIn E₀ (IsLocalization.sec (nonZeroDivisors (E).toAffine.CoordinateRing)
+      (D.ι (polyToFunctionField (E).toAffine X))).1
+    ∧ kw_iA_crCoeffsIn E₀ ((IsLocalization.sec (nonZeroDivisors
+        (E).toAffine.CoordinateRing) (D.ι (polyToFunctionField (E).toAffine X))).2 :
+      (E).toAffine.CoordinateRing))
+  ∧ (kw_iA_crCoeffsIn E₀ (IsLocalization.sec (nonZeroDivisors (E).toAffine.CoordinateRing)
+      (D.ι (yGen (E).toAffine))).1
+    ∧ kw_iA_crCoeffsIn E₀ ((IsLocalization.sec (nonZeroDivisors
+        (E).toAffine.CoordinateRing) (D.ι (yGen (E).toAffine))).2 :
+      (E).toAffine.CoordinateRing))
+
+def KwIsogenyEndDatumIotaDescendToFG'' (K : Type uK) [Field K] [Algebra ℚ K]
+    [DecidableEq K] [IsAlgClosed K] [CharZero K] (E' : WeierstrassCurve K) [E'.IsElliptic]
+    (D : TreeIsogenyEndDatum E'.toAffine) : Prop :=
+  ∃ (K₀ : IntermediateField ℚ K) (_ : K₀.FG)
+    (E₀ : WeierstrassCurve K₀) (_ : E₀.IsElliptic) (_ : E₀.map (algebraMap K₀ K) = E')
+    (ι₀ : E₀.toAffine.FunctionField →ₐ[K₀] E₀.toAffine.FunctionField)
+    (_ : ι₀.toRingHom.IsIntegral) (_ : FiniteAlong K₀ ι₀),
+    finrankAlong K₀ ι₀ = D.degree
+
+end Assembly
+end ModularCurve
+end
+end
+
+
+section
+
+namespace ModularCurve
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine HahnSeries \
+  P2MW.S_OVERLONG_6989a05c.HahnSeries \
+  IntermediateField \
+  P2MW.S_OVERLONG_6989a05c.Intermediat\
+  eField Cardinal \
+  P2MW.S_OVERLONG_6989a05c.Cardinal"
+
+def KwIsogenyEndDatumSubfieldDescent (K : Type uK) [Field K] [Algebra ℚ K]
+    [DecidableEq K] [IsAlgClosed K] [CharZero K] (E : WeierstrassCurve K) [E.IsElliptic]
+    (N : ℕ) : Prop :=
+  (∃ D : TreeIsogenyEndDatum E.toAffine, D.degree = N) →
+    ∃ (K₀ : IntermediateField ℚ K) (_ : K₀.FG)
+      (E₀ : WeierstrassCurve K₀) (_ : E₀.IsElliptic) (_ : E₀.map (algebraMap K₀ K) = E)
+      (D' : TreeIsogenyEndDatum E₀.toAffine), D'.degree = N
+
+def KwIsogenyEndDatumBaseChangeToAlgebraicClosure (K₀ : Type uK) [Field K₀] [CharZero K₀]
+    (E₀ : WeierstrassCurve K₀) [E₀.IsElliptic] (N : ℕ) : Prop :=
+  (∃ D' : TreeIsogenyEndDatum E₀.toAffine, D'.degree = N) →
+    ∃ D₀ : TreeIsogenyEndDatum (E₀⁄(AlgebraicClosure K₀)), D₀.degree = N
+
+def KwIsogenyEndDatumFGFieldDescentIotaAtom' (K : Type uK) [Field K] [Algebra ℚ K]
+    [DecidableEq K] [IsAlgClosed K] [CharZero K] (E : WeierstrassCurve K) [E.IsElliptic]
+    (N : ℕ) : Prop :=
+  (∃ D : TreeIsogenyEndDatum E.toAffine, D.degree = N) →
+    ∃ (K₀ : IntermediateField ℚ K) (_ : K₀.FG)
+      (E₀ : WeierstrassCurve K₀) (_ : E₀.IsElliptic) (_ : E₀.map (algebraMap K₀ K) = E)
+      (D₀ : TreeIsogenyEndDatum (E₀⁄(AlgebraicClosure K₀))), D₀.degree = N
+
+theorem kw_iotaAtom_of_subfieldDescent_of_baseChangeToAC (K : Type uK) [Field K] [Algebra ℚ K]
+    [DecidableEq K] [IsAlgClosed K] [CharZero K] (E : WeierstrassCurve K) [E.IsElliptic]
+    (N : ℕ) (hSD : KwIsogenyEndDatumSubfieldDescent K E N)
+    (hBC : ∀ (K₀ : Type uK) [Field K₀] [CharZero K₀] (E₀ : WeierstrassCurve K₀) [E₀.IsElliptic],
+      KwIsogenyEndDatumBaseChangeToAlgebraicClosure K₀ E₀ N) :
+    KwIsogenyEndDatumFGFieldDescentIotaAtom' K E N := by
+  intro hD
+  obtain ⟨K₀, hfg, E₀, hE₀ell, hE₀map, D', hD'deg⟩ := hSD hD
+  have : E₀.IsElliptic := hE₀ell
+  have : CharZero (↥K₀) :=
+    charZero_of_injective_algebraMap (algebraMap ℚ (↥K₀)).injective
+  obtain ⟨D₀, hD₀deg⟩ := hBC (↥K₀) E₀ ⟨D', hD'deg⟩
+  exact ⟨K₀, hfg, E₀, hE₀ell, hE₀map, D₀, hD₀deg⟩
+
+theorem kw_iotaSubd_countable_of_fg {K : Type uK} [Field K] [Algebra ℚ K]
+    {K₀ : IntermediateField ℚ K} (hfg : K₀.FG) : Countable (↥K₀) := by
+  obtain ⟨s, hs⟩ := hfg
+  rw [← hs]
+  have h2 : Cardinal.lift.{0} (Cardinal.mk ↥(IntermediateField.adjoin ℚ (↑s : Set K))) ≤
+    Cardinal.aleph0 :=
+    (IntermediateField.lift_cardinalMk_adjoin_le ℚ (↑s : Set K)).trans
+      (max_le (max_le (Cardinal.lift_le_aleph0.mpr Cardinal.mk_le_aleph0)
+        (Cardinal.lift_le_aleph0.mpr (Set.Countable.le_aleph0 s.countable_toSet))) le_rfl)
+  exact Cardinal.mk_le_aleph0_iff.mp (Cardinal.lift_le_aleph0.mp h2)
+
+theorem kw_fgFieldDescent_of_subfieldDescent_of_baseChangeToAC (K : Type uK) [Field K]
+    [Algebra ℚ K] [DecidableEq K] [IsAlgClosed K] [CharZero K] (E : WeierstrassCurve K)
+    [E.IsElliptic] (N : ℕ) (hSD : KwIsogenyEndDatumSubfieldDescent K E N)
+    (hBC : ∀ (K₀ : Type uK) [Field K₀] [CharZero K₀] (E₀ : WeierstrassCurve K₀) [E₀.IsElliptic],
+      KwIsogenyEndDatumBaseChangeToAlgebraicClosure K₀ E₀ N) :
+    KwIsogenyEndDatumFGFieldDescent K E N := by
+  intro hD
+  obtain ⟨K₀, hfg, E₀, hE₀ell, hE₀map, D₀, hD₀deg⟩ :=
+    kw_iotaAtom_of_subfieldDescent_of_baseChangeToAC K E N hSD hBC hD
+  exact ⟨K₀, kw_iotaSubd_countable_of_fg hfg, E₀, hE₀ell, hE₀map, D₀, hD₀deg⟩
+
+end ModularCurve
+end
+
+section
+
+
+section
+
+namespace ModularCurve
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine IntermediateField \
+  P2MW.S_OVERLONG_6989a05c.Intermediat\
+  eField AlgebraicCurve \
+  P2MW.S_OVERLONG_6989a05c.AlgebraicCu\
+  rve Polynomial \
+  P2MW.S_OVERLONG_6989a05c.Polynomial"
+
+section Pinned
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable {K₀ : IntermediateField ℚ K}
+variable (E₀ : WeierstrassCurve K₀) [E₀.IsElliptic]
+variable (D : TreeIsogenyEndDatum (E₀.map (algebraMap K₀ K)).toAffine)
+variable (hcoeffs : kw_iA_CoeffsHyp E₀ D)
+
+local notation "E" => E₀.map (algebraMap K₀ K)
+
+def kw_iP_xP : E₀.toAffine.FunctionField :=
+  Classical.choose (kw_iA_ffDescend_exists E₀ (D.ι (polyToFunctionField (E).toAffine X))
+    hcoeffs.1.1 hcoeffs.1.2)
+
+def kw_iP_yP : E₀.toAffine.FunctionField :=
+  Classical.choose (kw_iA_ffDescend_exists E₀ (D.ι (yGen (E).toAffine))
+    hcoeffs.2.1 hcoeffs.2.2)
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] in
+omit [E₀.IsElliptic] in
+theorem kw_iP_xP_spec :
+    kw_iA_phi E₀ (kw_iP_xP E₀ D hcoeffs) = D.ι (polyToFunctionField (E).toAffine X) := by
+  classical
+  exact
+    Classical.choose_spec (kw_iA_ffDescend_exists E₀ _ hcoeffs.1.1 hcoeffs.1.2)
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] in
+omit [E₀.IsElliptic] in
+theorem kw_iP_yP_spec :
+    kw_iA_phi E₀ (kw_iP_yP E₀ D hcoeffs) = D.ι (yGen (E).toAffine) := by
+  classical
+  exact
+    Classical.choose_spec (kw_iA_ffDescend_exists E₀ _ hcoeffs.2.1 hcoeffs.2.2)
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] in
+omit [E₀.IsElliptic] in
+theorem kw_iP_equation :
+    (E₀.map (algebraMap K₀ E₀.toAffine.FunctionField)).toAffine.Equation
+      (kw_iP_xP E₀ D hcoeffs) (kw_iP_yP E₀ D hcoeffs) := by
+  classical
+  set xP := kw_iP_xP E₀ D hcoeffs with hxP
+  set yP := kw_iP_yP E₀ D hcoeffs with hyP
+  have hDι : ((E).map (algebraMap K (E).toAffine.FunctionField)).toAffine.Equation
+      (D.ι (polyToFunctionField (E).toAffine X)) (D.ι (yGen (E).toAffine)) := by
+    have h₀ := equation_map_polyToFunctionField_yGen (W := (E).toAffine)
+    rw [Affine.equation_iff] at h₀ ⊢
+    have h₁ := congrArg D.ι h₀
+    simp only [map_add, map_mul, map_pow, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂,
+      WeierstrassCurve.map_a₃,
+      WeierstrassCurve.map_a₄, WeierstrassCurve.map_a₆, AlgHom.commutes] at h₁ ⊢
+    linear_combination h₁
+  rw [Affine.equation_iff] at hDι ⊢
+  have hΦx : kw_iA_phi E₀ xP = D.ι (polyToFunctionField (E).toAffine X) :=
+    hxP ▸ kw_iP_xP_spec E₀ D hcoeffs
+  have hΦy : kw_iA_phi E₀ yP = D.ι (yGen (E).toAffine) :=
+    hyP ▸ kw_iP_yP_spec E₀ D hcoeffs
+  have hΦc : ∀ (c : K₀), kw_iA_phi E₀ (algebraMap K₀ E₀.toAffine.FunctionField c)
+      = algebraMap K (E).toAffine.FunctionField (algebraMap K₀ K c) :=
+    fun c => ((kw_iA_phi E₀).commutes c).trans
+      (IsScalarTower.algebraMap_apply K₀ K (E).toAffine.FunctionField c)
+  have hΦinj : Function.Injective (kw_iA_phi E₀) :=
+    (kw_iA_phi E₀).toRingHom.injective
+  refine hΦinj ?_
+  simp only [map_add, map_mul, map_pow, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂,
+    WeierstrassCurve.map_a₃,
+    WeierstrassCurve.map_a₄, WeierstrassCurve.map_a₆] at hDι ⊢
+  rw [hΦc, hΦc, hΦc, hΦc, hΦc, hΦx, hΦy]
+  exact hDι
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] in
+omit [E₀.IsElliptic] in
+theorem kw_iP_transcendental :
+    Function.Injective (Polynomial.aeval (R := K₀) (kw_iP_xP E₀ D hcoeffs)) := by
+  classical
+  refine (injective_iff_map_eq_zero _).mpr fun p hp => ?_
+  have hK : Transcendental K (D.ι (polyToFunctionField (E).toAffine X)) := by
+    intro halg
+    obtain ⟨r, hr0, hreval⟩ := halg
+    refine (transcendental_polyToFunctionField_X (W := (E).toAffine)) ⟨r, hr0, ?_⟩
+    apply D.ι.toRingHom.injective
+    rw [_root_.map_zero, ← hreval]
+    exact (Polynomial.aeval_algHom_apply D.ι _ r).symm
+  have hDιX : Transcendental K₀ (D.ι (polyToFunctionField (E).toAffine X)) :=
+    hK.restrictScalars (R := K₀) (algebraMap K₀ K).injective
+  refine transcendental_iff.mp hDιX p ?_
+  calc Polynomial.aeval (R := K₀) (D.ι (polyToFunctionField (E).toAffine X)) p
+      = Polynomial.aeval (R := K₀) (kw_iA_phi E₀ (kw_iP_xP E₀ D hcoeffs)) p := by
+        rw [kw_iP_xP_spec E₀ D hcoeffs]
+    _ = kw_iA_phi E₀ (Polynomial.aeval (R := K₀) (kw_iP_xP E₀ D hcoeffs) p) :=
+        Polynomial.aeval_algHom_apply (kw_iA_phi E₀) (kw_iP_xP E₀ D hcoeffs) p
+    _ = kw_iA_phi E₀ 0 := by rw [hp]
+    _ = 0 := _root_.map_zero _
+
+def kw_iP_ι₀ : E₀.toAffine.FunctionField →ₐ[K₀] E₀.toAffine.FunctionField :=
+  pointPullbackHomTo (kw_iP_equation E₀ D hcoeffs) (kw_iP_transcendental E₀ D hcoeffs)
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] in
+omit [E₀.IsElliptic] in
+theorem kw_iP_ι₀_X :
+    kw_iP_ι₀ E₀ D hcoeffs (polyToFunctionField E₀.toAffine X) = kw_iP_xP E₀ D hcoeffs := by
+  classical
+  exact
+    pointPullbackHomTo_polyToFunctionField_X _ _
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] in
+omit [E₀.IsElliptic] in
+theorem kw_iP_ι₀_yGen :
+    kw_iP_ι₀ E₀ D hcoeffs (yGen E₀.toAffine) = kw_iP_yP E₀ D hcoeffs := by
+  classical
+  exact
+    pointPullbackHomTo_yGen _ _
+
+def KwIotaPinnedFinrank : Prop :=
+  (kw_iP_ι₀ E₀ D hcoeffs).toRingHom.IsIntegral
+    ∧ FiniteAlong K₀ (kw_iP_ι₀ E₀ D hcoeffs)
+    ∧ finrankAlong K₀ (kw_iP_ι₀ E₀ D hcoeffs) = D.degree
+
+end Pinned
+end ModularCurve
+end
+end
+
+section
+
+
+section
+
+namespace ModularCurve
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine IntermediateField \
+  P2MW.S_OVERLONG_6989a05c.Intermediat\
+  eField AlgebraicCurve \
+  P2MW.S_OVERLONG_6989a05c.AlgebraicCu\
+  rve Polynomial \
+  P2MW.S_OVERLONG_6989a05c.Polynomial"
+
+section CoeffSet
+
+variable {K : Type uK} [Field K] [DecidableEq K]
+
+def kw_iCa_crRepr (E : WeierstrassCurve K) (c : E.toAffine.CoordinateRing)
+    (i : Fin 2) : Polynomial K :=
+  (CoordinateRing.basis E.toAffine).repr c i
+
+def kw_iCa_crCoeffSet (E : WeierstrassCurve K) (c : E.toAffine.CoordinateRing) :
+    Finset K :=
+  ((kw_iCa_crRepr E c 0).support.image (kw_iCa_crRepr E c 0).coeff) ∪
+  ((kw_iCa_crRepr E c 1).support.image (kw_iCa_crRepr E c 1).coeff)
+
+def kw_iCa_ffNum (E : WeierstrassCurve K) (x : E.toAffine.FunctionField) :
+    E.toAffine.CoordinateRing :=
+  (IsLocalization.sec (nonZeroDivisors E.toAffine.CoordinateRing) x).1
+
+def kw_iCa_ffDen (E : WeierstrassCurve K) (x : E.toAffine.FunctionField) :
+    E.toAffine.CoordinateRing :=
+  ((IsLocalization.sec (nonZeroDivisors E.toAffine.CoordinateRing) x).2 :
+    E.toAffine.CoordinateRing)
+
+def kw_iCa_ffCoeffSet (E : WeierstrassCurve K) (x : E.toAffine.FunctionField) :
+    Finset K :=
+  kw_iCa_crCoeffSet E (kw_iCa_ffNum E x) ∪ kw_iCa_crCoeffSet E (kw_iCa_ffDen E x)
+
+theorem kw_iCa_crRepr_coeff_mem (E : WeierstrassCurve K)
+    (c : E.toAffine.CoordinateRing) (i : Fin 2) (j : ℕ) :
+    (kw_iCa_crRepr E c i).coeff j ∈ (↑(kw_iCa_crCoeffSet E c) : Set K) ∪ {0} := by
+  by_cases hj : j ∈ (kw_iCa_crRepr E c i).support
+  · refine Or.inl ?_
+    simp only [kw_iCa_crCoeffSet, Finset.coe_union, Finset.coe_image, Set.mem_union,
+      Set.mem_image, Finset.mem_coe]
+    rcases Fin.exists_fin_two.mp ⟨i, rfl⟩ with h | h
+    · exact h ▸ Or.inl ⟨j, hj, rfl⟩
+    · exact h ▸ Or.inr ⟨j, hj, rfl⟩
+  · exact Or.inr (by simpa using Polynomial.notMem_support_iff.mp hj)
+
+end CoeffSet
+
+section Canonical
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable (E : WeierstrassCurve K) [E.IsElliptic] (D : TreeIsogenyEndDatum E.toAffine)
+
+def kw_iCa_genSet : Set K :=
+  {E.a₁, E.a₂, E.a₃, E.a₄, E.a₆} ∪
+    ↑(kw_iCa_ffCoeffSet E (D.ι (polyToFunctionField E.toAffine X))) ∪
+    ↑(kw_iCa_ffCoeffSet E (D.ι (yGen E.toAffine)))
+
+omit [Algebra ℚ K] [IsAlgClosed K] [CharZero K] [E.IsElliptic] in
+theorem kw_iCa_genSet_finite : (kw_iCa_genSet E D).Finite := by
+  unfold kw_iCa_genSet
+  exact ((((Set.finite_singleton _).insert _ |>.insert _ |>.insert _ |>.insert _).union
+    (Finset.finite_toSet _)).union (Finset.finite_toSet _))
+
+def kw_iCa_K₀ : IntermediateField ℚ K := IntermediateField.adjoin ℚ (kw_iCa_genSet E D)
+
+omit [IsAlgClosed K] [CharZero K] [E.IsElliptic] in
+theorem kw_iCa_K₀_fg : (kw_iCa_K₀ E D).FG :=
+  ⟨(kw_iCa_genSet_finite E D).toFinset, by rw [Set.Finite.coe_toFinset]; rfl⟩
+
+omit [IsAlgClosed K] [CharZero K] [E.IsElliptic] in
+theorem kw_iCa_K₀_mem_aᵢ :
+    E.a₁ ∈ kw_iCa_K₀ E D ∧ E.a₂ ∈ kw_iCa_K₀ E D ∧ E.a₃ ∈ kw_iCa_K₀ E D ∧
+    E.a₄ ∈ kw_iCa_K₀ E D ∧ E.a₆ ∈ kw_iCa_K₀ E D := by
+  have h : ({E.a₁, E.a₂, E.a₃, E.a₄, E.a₆} : Set K) ⊆ kw_iCa_K₀ E D := fun x hx =>
+    IntermediateField.subset_adjoin ℚ _ (Or.inl (Or.inl hx))
+  exact ⟨h (Or.inl rfl), h (Or.inr (Or.inl rfl)), h (Or.inr (Or.inr (Or.inl rfl))),
+    h (Or.inr (Or.inr (Or.inr (Or.inl rfl)))), h (Or.inr (Or.inr (Or.inr (Or.inr rfl))))⟩
+
+def kw_iCa_E₀ : WeierstrassCurve (kw_iCa_K₀ E D) where
+  a₁ := ⟨E.a₁, (kw_iCa_K₀_mem_aᵢ E D).1⟩
+  a₂ := ⟨E.a₂, (kw_iCa_K₀_mem_aᵢ E D).2.1⟩
+  a₃ := ⟨E.a₃, (kw_iCa_K₀_mem_aᵢ E D).2.2.1⟩
+  a₄ := ⟨E.a₄, (kw_iCa_K₀_mem_aᵢ E D).2.2.2.1⟩
+  a₆ := ⟨E.a₆, (kw_iCa_K₀_mem_aᵢ E D).2.2.2.2⟩
+
+omit [IsAlgClosed K] [CharZero K] [E.IsElliptic] in
+theorem kw_iCa_E₀_map :
+    (kw_iCa_E₀ E D).map (algebraMap (kw_iCa_K₀ E D) K) = E := by ext <;> rfl
+
+scoped instance kw_iCa_E₀_isElliptic : (kw_iCa_E₀ E D).IsElliptic := by
+  constructor; rw [isUnit_iff_ne_zero]; intro h0
+  have : (algebraMap (kw_iCa_K₀ E D) K) (kw_iCa_E₀ E D).Δ = E.Δ := by
+    rw [← WeierstrassCurve.map_Δ, kw_iCa_E₀_map]
+  rw [h0, _root_.map_zero] at this; exact E.isUnit_Δ.ne_zero this.symm
+
+omit [IsAlgClosed K] [CharZero K] in
+theorem kw_iCa_crCoeffsIn_of_ffCoeffSet_subset (E' : WeierstrassCurve K)
+    (x : E'.toAffine.FunctionField) {K₀' : IntermediateField ℚ K}
+    (hsub : (↑(kw_iCa_ffCoeffSet E' x) : Set K) ⊆ K₀') (i : Fin 2) (j : ℕ) :
+    ((CoordinateRing.basis E'.toAffine).repr (kw_iCa_ffNum E' x) i).coeff j ∈ K₀' ∧
+    ((CoordinateRing.basis E'.toAffine).repr (kw_iCa_ffDen E' x) i).coeff j ∈ K₀' := by
+  have hN := kw_iCa_crRepr_coeff_mem E' (kw_iCa_ffNum E' x) i j
+  have hD := kw_iCa_crRepr_coeff_mem E' (kw_iCa_ffDen E' x) i j
+  unfold kw_iCa_crRepr at hN hD
+  refine ⟨?_, ?_⟩
+  · rcases hN with hN | hN
+    · exact hsub (by simp only [kw_iCa_ffCoeffSet, Finset.coe_union]; exact Or.inl hN)
+    · simp only [Set.mem_singleton_iff] at hN; exact hN ▸ zero_mem K₀'
+  · rcases hD with hD | hD
+    · exact hsub (by simp only [kw_iCa_ffCoeffSet, Finset.coe_union]; exact Or.inr hD)
+    · simp only [Set.mem_singleton_iff] at hD; exact hD ▸ zero_mem K₀'
+
+def kw_iCa_D' :
+    TreeIsogenyEndDatum ((kw_iCa_E₀ E D).map (algebraMap (kw_iCa_K₀ E D) K)).toAffine :=
+  Eq.mpr (congrArg (fun W => TreeIsogenyEndDatum W.toAffine) (kw_iCa_E₀_map E D)) D
+
+def KwIotaCanonicalFinrank : Prop :=
+  ∀ hcoeffs : kw_iA_CoeffsHyp (kw_iCa_E₀ E D) (kw_iCa_D' E D),
+    KwIotaPinnedFinrank (kw_iCa_E₀ E D) (kw_iCa_D' E D) hcoeffs
+
+omit [IsAlgClosed K] [CharZero K] [E.IsElliptic] in
+theorem kw_iCa_ffCoeffSet_subset_X :
+    (↑(kw_iCa_ffCoeffSet E (D.ι (polyToFunctionField E.toAffine X))) : Set K)
+      ⊆ kw_iCa_K₀ E D :=
+  fun _ hc => IntermediateField.subset_adjoin ℚ _ (Or.inl (Or.inr hc))
+
+omit [IsAlgClosed K] [CharZero K] [E.IsElliptic] in
+theorem kw_iCa_ffCoeffSet_subset_Y :
+    (↑(kw_iCa_ffCoeffSet E (D.ι (yGen E.toAffine))) : Set K) ⊆ kw_iCa_K₀ E D :=
+  fun _ hc => IntermediateField.subset_adjoin ℚ _ (Or.inr hc)
+
+end Canonical
+end ModularCurve
+end
+end
+
+section
+
+
+section
+
+namespace ModularCurve
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine IntermediateField \
+  P2MW.S_OVERLONG_6989a05c.Intermediat\
+  eField AlgebraicCurve \
+  P2MW.S_OVERLONG_6989a05c.AlgebraicCu\
+  rve Polynomial \
+  P2MW.S_OVERLONG_6989a05c.Polynomial"
+
+section Commute
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable {K₀ : IntermediateField ℚ K}
+variable (E₀ : WeierstrassCurve K₀) [E₀.IsElliptic]
+variable (D : TreeIsogenyEndDatum (E₀.map (algebraMap K₀ K)).toAffine)
+variable (hcoeffs : kw_iA_CoeffsHyp E₀ D)
+
+local notation "E" => E₀.map (algebraMap K₀ K)
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] in
+omit [E₀.IsElliptic] in
+theorem kw_iPF_phi_X :
+    kw_iA_phi E₀ (polyToFunctionField E₀.toAffine X)
+      = polyToFunctionField (E).toAffine X := by
+  classical
+  exact
+    pointPullbackHomTo_polyToFunctionField_X _ _
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] in
+omit [E₀.IsElliptic] in
+theorem kw_iPF_phi_yGen :
+    kw_iA_phi E₀ (yGen E₀.toAffine) = yGen (E).toAffine := by
+  classical
+  exact
+    pointPullbackHomTo_yGen _ _
+
+def KwIotaPinnedFiniteSeam : Prop :=
+  FiniteAlong K₀ (kw_iP_ι₀ E₀ D hcoeffs)
+    ∧ finrankAlong K₀ (kw_iP_ι₀ E₀ D hcoeffs) = D.degree
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] in
+omit [E₀.IsElliptic] in
+theorem kw_iotaPinnedFinrank_of_finiteSeam
+    (hSeam : KwIotaPinnedFiniteSeam E₀ D hcoeffs) :
+    KwIotaPinnedFinrank E₀ D hcoeffs := by
+  classical
+  obtain ⟨hfin, hdeg⟩ := hSeam
+  exact ⟨RingHom.Finite.to_isIntegral (f := (kw_iP_ι₀ E₀ D hcoeffs).toRingHom) hfin,
+    hfin, hdeg⟩
+
+end Commute
+end ModularCurve
+end
+end
+
+section
+
+
+section
+
+namespace ModularCurve
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine IntermediateField \
+  P2MW.S_OVERLONG_6989a05c.Intermediat\
+  eField AlgebraicCurve \
+  P2MW.S_OVERLONG_6989a05c.AlgebraicCu\
+  rve Polynomial \
+  P2MW.S_OVERLONG_6989a05c.Polynomial"
+
+section Cast
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+
+omit [DecidableEq K] in
+omit [Algebra ℚ K] [IsAlgClosed K] [CharZero K] in
+theorem kw_iCaW_degree_mpr {W W' : WeierstrassCurve K}
+    (heq : W = W') (D : TreeIsogenyEndDatum W'.toAffine) :
+    (Eq.mpr (congrArg (fun V => TreeIsogenyEndDatum V.toAffine) heq) D).degree = D.degree := by
+  classical
+  subst heq; rfl
+
+omit [IsAlgClosed K] [CharZero K] in
+theorem kw_iCaW_coeffsHyp_of_subset_cast {K₀ : IntermediateField ℚ K}
+    (E₀ : WeierstrassCurve K₀) [E₀.IsElliptic]
+    {W' : WeierstrassCurve K} (heq : E₀.map (algebraMap K₀ K) = W')
+    (D : TreeIsogenyEndDatum W'.toAffine)
+    (hX : (↑(kw_iCa_ffCoeffSet W' (D.ι (polyToFunctionField W'.toAffine X))) : Set K)
+      ⊆ (K₀ : Set K))
+    (hY : (↑(kw_iCa_ffCoeffSet W' (D.ι (yGen W'.toAffine))) : Set K)
+      ⊆ (K₀ : Set K)) :
+    kw_iA_CoeffsHyp E₀
+      (Eq.mpr (congrArg (fun V => TreeIsogenyEndDatum V.toAffine) heq) D) := by
+  subst heq
+  refine ⟨⟨fun i j => ?_, fun i j => ?_⟩, fun i j => ?_, fun i j => ?_⟩
+  · exact (kw_iCa_crCoeffsIn_of_ffCoeffSet_subset _ _ hX i j).1
+  · exact (kw_iCa_crCoeffsIn_of_ffCoeffSet_subset _ _ hX i j).2
+  · exact (kw_iCa_crCoeffsIn_of_ffCoeffSet_subset _ _ hY i j).1
+  · exact (kw_iCa_crCoeffsIn_of_ffCoeffSet_subset _ _ hY i j).2
+
+theorem kw_iCaW_descend_of_pinned_cast {K₀ : IntermediateField ℚ K}
+    (E₀ : WeierstrassCurve K₀) [E₀.IsElliptic]
+    {W' : WeierstrassCurve K} [W'.IsElliptic]
+    (heq : E₀.map (algebraMap K₀ K) = W')
+    (D : TreeIsogenyEndDatum W'.toAffine) (hfg : K₀.FG)
+    (hcoeffs : kw_iA_CoeffsHyp E₀
+        (Eq.mpr (congrArg (fun V => TreeIsogenyEndDatum V.toAffine) heq) D))
+    (hFinrank : KwIotaPinnedFinrank E₀
+        (Eq.mpr (congrArg (fun V => TreeIsogenyEndDatum V.toAffine) heq) D) hcoeffs) :
+    KwIsogenyEndDatumIotaDescendToFG'' K W' D := by
+  obtain ⟨hint, hfin, hdeg⟩ := hFinrank
+  exact ⟨K₀, hfg, E₀, inferInstance, heq, kw_iP_ι₀ E₀ _ hcoeffs, hint, hfin,
+    hdeg.trans (kw_iCaW_degree_mpr heq D)⟩
+
+end Cast
+
+section Wire
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable (E : WeierstrassCurve K) [E.IsElliptic] (D : TreeIsogenyEndDatum E.toAffine)
+
+omit [IsAlgClosed K] [CharZero K] in
+theorem kw_iCaW_hcoeffs_canonical :
+    kw_iA_CoeffsHyp (kw_iCa_E₀ E D) (kw_iCa_D' E D) :=
+  kw_iCaW_coeffsHyp_of_subset_cast (kw_iCa_E₀ E D) (kw_iCa_E₀_map E D) D
+    (kw_iCa_ffCoeffSet_subset_X E D) (kw_iCa_ffCoeffSet_subset_Y E D)
+
+theorem kw_iotaDescendToFG_of_canonicalFinrank
+    (hCan : KwIotaCanonicalFinrank E D) :
+    KwIsogenyEndDatumIotaDescendToFG'' K E D :=
+  kw_iCaW_descend_of_pinned_cast (kw_iCa_E₀ E D) (kw_iCa_E₀_map E D) D
+    (kw_iCa_K₀_fg E D) (kw_iCaW_hcoeffs_canonical E D)
+    (hCan (kw_iCaW_hcoeffs_canonical E D))
+
+end Wire
+end ModularCurve
+end
+end
+
+section
+
+
+section
+
+namespace ModularCurve
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine IntermediateField \
+  P2MW.S_OVERLONG_6989a05c.Intermediat\
+  eField AlgebraicCurve \
+  P2MW.S_OVERLONG_6989a05c.AlgebraicCu\
+  rve Polynomial \
+  P2MW.S_OVERLONG_6989a05c.Polynomial"
+
+section Exchange
+
+variable {K : Type*} [Field K] (W : WeierstrassCurve.Affine K)
+
+theorem kw_iPFA_isTranscendenceBasis_coord :
+    IsTranscendenceBasis K
+      (fun _ : Fin 1 => algebraMap (RatFunc K) W.FunctionField RatFunc.X) := by
+  have : Algebra.IsAlgebraic (RatFunc K) (RatFunc K) :=
+    Algebra.IsAlgebraic.of_finite (RatFunc K) (RatFunc K)
+  have : Algebra.IsAlgebraic (Polynomial K) (RatFunc K) :=
+    (IsFractionRing.comap_isAlgebraic_iff
+      (A := Polynomial K) (K := RatFunc K) (C := RatFunc K)).mpr inferInstance
+  have : FaithfulSMul (Polynomial K) (RatFunc K) :=
+    (faithfulSMul_iff_algebraMap_injective (Polynomial K) (RatFunc K)).mpr
+      (IsFractionRing.injective (Polynomial K) (RatFunc K))
+  have : Algebra.IsAlgebraic (RatFunc K) W.FunctionField :=
+    Algebra.IsAlgebraic.of_finite (RatFunc K) W.FunctionField
+  have : FaithfulSMul (RatFunc K) W.FunctionField :=
+    (faithfulSMul_iff_algebraMap_injective (RatFunc K) W.FunctionField).mpr
+      (algebraMap (RatFunc K) W.FunctionField).injective
+  have h0 : IsTranscendenceBasis K (fun _ : Fin 1 => (Polynomial.X : Polynomial K)) :=
+    IsTranscendenceBasis.polynomial (ι := Fin 1) (R := K)
+  have h1 := h0.algebraMap_comp (A := RatFunc K)
+  have h2 := h1.algebraMap_comp (A := W.FunctionField)
+  have hfun : (algebraMap (RatFunc K) W.FunctionField ∘
+      (algebraMap (Polynomial K) (RatFunc K) ∘ fun _ : Fin 1 => (Polynomial.X : Polynomial K)))
+      = fun _ : Fin 1 => algebraMap (RatFunc K) W.FunctionField RatFunc.X := by
+    funext i; simp only [Function.comp_apply]; rw [RatFunc.algebraMap_X]
+  rwa [hfun] at h2
+
+theorem kw_iPFA_isAlgebraic_adjoin_transcendental {g : W.FunctionField}
+    (hg : Transcendental K g) :
+    Algebra.IsAlgebraic (↥K⟮g⟯) W.FunctionField := by
+  classical
+  have hgind : AlgebraicIndepOn K id ({g} : Set W.FunctionField) := by
+    refine algebraicIndependent_unique_type_iff.mpr ?_
+    simpa using hg
+  obtain ⟨s, hgs, hbasis⟩ := exists_isTranscendenceBasis_superset hgind
+  have hcard := hbasis.lift_cardinalMk_eq (kw_iPFA_isTranscendenceBasis_coord W)
+  simp only [Cardinal.mk_fin, Nat.cast_one, Cardinal.lift_one, Cardinal.lift_eq_one] at hcard
+  have hsub : s.Subsingleton := Cardinal.mk_le_one_iff_set_subsingleton.mp hcard.le
+  have hseq : s = {g} := hsub.eq_singleton_of_mem (hgs rfl)
+  subst hseq
+  rw [hbasis.isAlgebraic_iff]
+  intro i
+  have hi : (i : W.FunctionField) = g := i.2
+  rw [hi]
+  have h1 := isAlgebraic_algebraMap (R := ↥K⟮g⟯) (A := W.FunctionField)
+    (IntermediateField.AdjoinSimple.gen K g)
+  rwa [IntermediateField.AdjoinSimple.algebraMap_gen] at h1
+
+theorem kw_iPFA_finiteDimensional_adjoin_transcendental {g : W.FunctionField}
+    (hg : Transcendental K g) :
+    FiniteDimensional (↥K⟮g⟯) W.FunctionField := by
+  classical
+  have halg : Algebra.IsAlgebraic (↥K⟮g⟯) W.FunctionField :=
+    kw_iPFA_isAlgebraic_adjoin_transcendental W hg
+  obtain ⟨s, hs⟩ :=
+    Module.finite_def.mp (inferInstance : Module.Finite (RatFunc K) W.FunctionField)
+  set t : W.FunctionField := algebraMap (RatFunc K) W.FunctionField RatFunc.X with ht
+  set E : IntermediateField (↥K⟮g⟯) W.FunctionField :=
+    IntermediateField.adjoin (↥K⟮g⟯) (insert t (↑s : Set W.FunctionField)) with hE
+  have htE : t ∈ E := IntermediateField.subset_adjoin _ _ (Set.mem_insert _ _)
+  have hrange : ∀ r : RatFunc K, algebraMap (RatFunc K) W.FunctionField r ∈ E := by
+    intro r
+    have hr : r ∈ IntermediateField.adjoin K {(RatFunc.X : RatFunc K)} := by
+      rw [RatFunc.adjoin_X]; exact IntermediateField.mem_top
+    have hmap : algebraMap (RatFunc K) W.FunctionField r ∈
+        (IntermediateField.adjoin K {(RatFunc.X : RatFunc K)}).map
+          (IsScalarTower.toAlgHom K (RatFunc K) W.FunctionField) := ⟨r, hr, rfl⟩
+    rw [IntermediateField.adjoin_map, Set.image_singleton] at hmap
+    have himg : (IsScalarTower.toAlgHom K (RatFunc K) W.FunctionField)
+        (RatFunc.X : RatFunc K) = t := rfl
+    rw [himg] at hmap
+    have hle : IntermediateField.adjoin K {t} ≤ E.restrictScalars K :=
+      IntermediateField.adjoin_simple_le_iff.mpr
+        ((IntermediateField.mem_restrictScalars K).mpr htE)
+    exact (IntermediateField.mem_restrictScalars K).mp (hle hmap)
+  have hmem : ∀ x : W.FunctionField, x ∈ E := by
+    intro x
+    have hx : x ∈ Submodule.span (RatFunc K) (↑s : Set W.FunctionField) := by
+      rw [hs]; exact Submodule.mem_top
+    refine Submodule.span_induction (fun y hy => ?_) ?_ (fun y z _ _ hy hz => ?_)
+      (fun r y _ hy => ?_) hx
+    · exact IntermediateField.subset_adjoin _ _ (Set.mem_insert_of_mem _ hy)
+    · exact zero_mem E
+    · exact add_mem hy hz
+    · rw [Algebra.smul_def]
+      exact mul_mem (hrange _) hy
+  have heqTop : E = ⊤ := eq_top_iff.mpr (fun x _ => hmem x)
+  have hfinE : FiniteDimensional (↥K⟮g⟯) (↥E) :=
+    IntermediateField.finiteDimensional_adjoin
+      (S := insert t (↑s : Set W.FunctionField))
+      (fun z _ => isAlgebraic_iff_isIntegral.mp (halg.isAlgebraic z))
+  rw [heqTop] at hfinE
+  exact (IntermediateField.topEquiv (F := ↥K⟮g⟯) (E := W.FunctionField))
+    |>.toLinearEquiv.finiteDimensional
+
+end Exchange
+
+section Discharge
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable {K₀ : IntermediateField ℚ K}
+variable (E₀ : WeierstrassCurve K₀) [E₀.IsElliptic]
+variable (D : TreeIsogenyEndDatum (E₀.map (algebraMap K₀ K)).toAffine)
+variable (hcoeffs : kw_iA_CoeffsHyp E₀ D)
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] in
+omit [E₀.IsElliptic] in
+theorem kw_iPFA_finiteAlong :
+    FiniteAlong K₀ (kw_iP_ι₀ E₀ D hcoeffs) := by
+  classical
+  set ι₀ := kw_iP_ι₀ E₀ D hcoeffs
+  set xP := kw_iP_xP E₀ D hcoeffs
+  have hxPtr : Transcendental K₀ xP :=
+    transcendental_iff_injective.mpr (kw_iP_transcendental E₀ D hcoeffs)
+  have hfd : FiniteDimensional (↥(K₀ : Type uK)⟮xP⟯) E₀.toAffine.FunctionField :=
+    kw_iPFA_finiteDimensional_adjoin_transcendental E₀.toAffine hxPtr
+  have hxPrange : xP ∈ ι₀.fieldRange :=
+    ⟨polyToFunctionField E₀.toAffine X, kw_iP_ι₀_X E₀ D hcoeffs⟩
+  have hle : (K₀ : Type uK)⟮xP⟯ ≤ ι₀.fieldRange :=
+    IntermediateField.adjoin_simple_le_iff.mpr hxPrange
+  let algIncl : Algebra (↥(K₀ : Type uK)⟮xP⟯) (↥ι₀.fieldRange) :=
+    (IntermediateField.inclusion hle).toRingHom.toAlgebra
+  have towIncl : IsScalarTower (↥(K₀ : Type uK)⟮xP⟯) (↥ι₀.fieldRange)
+      E₀.toAffine.FunctionField :=
+    IsScalarTower.of_algebraMap_eq (fun r => rfl)
+  have hfdR : FiniteDimensional (↥ι₀.fieldRange) E₀.toAffine.FunctionField :=
+    FiniteDimensional.right (↥(K₀ : Type uK)⟮xP⟯) (↥ι₀.fieldRange) E₀.toAffine.FunctionField
+  change ι₀.toRingHom.Finite
+  let ρ : E₀.toAffine.FunctionField →+* ↥ι₀.fieldRange :=
+    { toFun := fun x => ⟨ι₀ x, x, rfl⟩
+      map_one' := Subtype.ext (map_one ι₀)
+      map_mul' := fun a b => Subtype.ext (map_mul ι₀ a b)
+      map_zero' := Subtype.ext (_root_.map_zero ι₀)
+      map_add' := fun a b => Subtype.ext (map_add ι₀ a b) }
+  have hsurj : Function.Surjective ρ := by rintro ⟨y, x, rfl⟩; exact ⟨x, rfl⟩
+  have hfactor : ι₀.toRingHom
+      = (algebraMap (↥ι₀.fieldRange) E₀.toAffine.FunctionField).comp ρ := by
+    ext x; rfl
+  rw [hfactor]
+  exact RingHom.Finite.comp hfdR (RingHom.Finite.of_surjective _ hsurj)
+
+def KwIotaPinnedFinrankEq : Prop :=
+  finrankAlong K₀ (kw_iP_ι₀ E₀ D hcoeffs) = D.degree
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] in
+omit [E₀.IsElliptic] in
+theorem kw_iotaPinnedFiniteSeam_of_finrankEq
+    (hdeg : KwIotaPinnedFinrankEq E₀ D hcoeffs) :
+    KwIotaPinnedFiniteSeam E₀ D hcoeffs := by
+  classical
+  exact
+    ⟨kw_iPFA_finiteAlong E₀ D hcoeffs, hdeg⟩
+
+end Discharge
+end ModularCurve
+end
+end
+
+section
+
+
+section
+
+namespace ModularCurve
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine IntermediateField \
+  P2MW.S_OVERLONG_6989a05c.Intermediat\
+  eField AlgebraicCurve \
+  P2MW.S_OVERLONG_6989a05c.AlgebraicCu\
+  rve Polynomial \
+  P2MW.S_OVERLONG_6989a05c.Polynomial"
+p2m_open_scoped "TensorProduct \
+  P2MW.S_OVERLONG_6989a05c.TensorProdu\
+  ct"
+
+attribute [local instance] Algebra.TensorProduct.rightAlgebra
+
+section FinrankEq
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+variable {K₀ : IntermediateField ℚ K}
+variable (E₀ : WeierstrassCurve K₀) [E₀.IsElliptic]
+variable (D : TreeIsogenyEndDatum (E₀.map (algebraMap K₀ K)).toAffine)
+variable (hcoeffs : kw_iA_CoeffsHyp E₀ D)
+
+local notation "E" => E₀.map (algebraMap K₀ K)
+
+theorem kw_iPFE_functionField_ringHom_ext {F : Type*} [Field F] {W : Affine F}
+    {L : Type*} [Field L] {f g : W.FunctionField →+* L}
+    (hF : ∀ r : F, f (algebraMap F W.FunctionField r) = g (algebraMap F W.FunctionField r))
+    (hX : f (polyToFunctionField W X) = g (polyToFunctionField W X))
+    (hy : f (yGen W) = g (yGen W)) : f = g := by
+  let : Algebra F L := (f.comp (algebraMap F W.FunctionField)).toAlgebra
+  let f' : W.FunctionField →ₐ[F] L := { f with commutes' := fun _ => rfl }
+  let g' : W.FunctionField →ₐ[F] L := { g with commutes' := fun r => (hF r).symm }
+  have heq : f' = g' := kw_functionField_algHom_ext hX hy
+  exact congrArg AlgHom.toRingHom heq
+
+set_option synthInstance.maxHeartbeats 80000 in -- this is needed (DL)
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] in
+omit [E₀.IsElliptic] in
+theorem kw_iPFE_finrankEq : KwIotaPinnedFinrankEq E₀ D hcoeffs := by
+  classical
+  set ι₀ := kw_iP_ι₀ E₀ D hcoeffs
+  have hfin := kw_iPFA_finiteAlong E₀ D hcoeffs
+  have hint : ι₀.toRingHom.IsIntegral :=
+    RingHom.Finite.to_isIntegral (f := ι₀.toRingHom) hfin
+  let D₀ : TreeIsogenyEndDatum (E₀⁄(K₀ : Type uK)) := ⟨ι₀, hint, hfin⟩
+  have hD₀_deg : D₀.degree = finrankAlong K₀ ι₀ := rfl
+  have hdom : IsDomain ((E₀⁄(K₀ : Type uK)).FunctionField ⊗[K₀] K) :=
+    kw_functionFieldTensorIsDomain_dischargeGeneralNoAC E₀ (K₀ : Type uK) K
+  let T := (E₀⁄(K₀ : Type uK)).FunctionField ⊗[K₀] K
+  let FrT := FractionRing T
+  let ψ := kw_functionFieldTensorFracEquivGeneralNoAC E₀ (K₀ : Type uK) K
+  let ιFr := kw_tensorFracIotaRingHomGeneralNoAC E₀ (K₀ : Type uK) K D₀
+  let Φ := kw_iA_phi E₀
+  have hκ : ∀ a : E₀.toAffine.FunctionField,
+      ψ (Φ a) = algebraMap T FrT (a ⊗ₜ[K₀] (1 : K)) := by
+    have heq : (ψ : (E₀⁄K).FunctionField →+* FrT).comp Φ.toRingHom
+        = (algebraMap T FrT).comp
+          (Algebra.TensorProduct.includeLeftRingHom (R := K₀)) := by
+      refine kw_iPFE_functionField_ringHom_ext (fun r => ?_) ?_ ?_
+      · change ψ (Φ (algebraMap K₀ E₀.toAffine.FunctionField r))
+            = algebraMap T FrT (algebraMap K₀ E₀.toAffine.FunctionField r ⊗ₜ[K₀] (1 : K))
+        have hL : ψ (Φ (algebraMap K₀ E₀.toAffine.FunctionField r))
+            = algebraMap K FrT (algebraMap K₀ K r) := by
+          rw [Φ.commutes r, IsScalarTower.algebraMap_apply K₀ K (E).toAffine.FunctionField r]
+          exact ψ.commutes (algebraMap K₀ K r)
+        have hT : (algebraMap K₀ E₀.toAffine.FunctionField r ⊗ₜ[K₀] (1 : K) : T)
+            = algebraMap K T (algebraMap K₀ K r) :=
+          (Algebra.TensorProduct.tmul_one_eq_one_tmul (A := E₀.toAffine.FunctionField)
+              (B := K) r).trans
+            (Algebra.TensorProduct.includeRight_apply (algebraMap K₀ K r)).symm
+        exact hL.trans ((IsScalarTower.algebraMap_apply K T FrT (algebraMap K₀ K r)).trans
+          (congrArg (algebraMap T FrT) hT.symm))
+      · change ψ (Φ (polyToFunctionField E₀.toAffine X)) = _
+        rw [kw_iPF_phi_X E₀]
+        exact kw_functionFieldTensorFracHomGeneralNoAC_X E₀ (K₀ : Type uK) K
+      · change ψ (Φ (yGen E₀.toAffine)) = _
+        rw [kw_iPF_phi_yGen E₀]
+        exact kw_functionFieldTensorFracHomGeneralNoAC_yGen E₀ (K₀ : Type uK) K
+    exact fun a => DFunLike.congr_fun heq a
+  let D₀' := kw_isogenyEndDatumBaseChangeIotaGeneralNoAC E₀ (K₀ : Type uK) K D₀
+  have hψ_Φ_ι₀ : ∀ a, ψ (Φ (ι₀ a)) = ιFr (ψ (Φ a)) := by
+    intro a
+    rw [hκ (ι₀ a), hκ a,
+      kw_tensorFracIotaRingHomGeneralNoAC_algebraMap E₀ (K₀ : Type uK) K D₀,
+      kw_tensorIotaRingHomGeneralNoAC_tmul E₀ (K₀ : Type uK) K D₀]
+    rfl
+  have hD₀'_gen : ∀ a, D₀' (Φ a) = Φ (ι₀ a) := by
+    intro a
+    change ψ.symm (ιFr (ψ (Φ a))) = Φ (ι₀ a)
+    rw [← hψ_Φ_ι₀]
+    exact ψ.symm_apply_apply _
+  have hD₀'_eq : D₀' = D.ι := by
+    refine kw_functionField_algHom_ext ?_ ?_
+    · calc D₀' (polyToFunctionField (E₀⁄K) X)
+          = D₀' (Φ (polyToFunctionField E₀.toAffine X)) :=
+            congrArg D₀' (kw_iPF_phi_X E₀).symm
+        _ = Φ (ι₀ (polyToFunctionField E₀.toAffine X)) := hD₀'_gen _
+        _ = Φ (kw_iP_xP E₀ D hcoeffs) := congrArg Φ (kw_iP_ι₀_X E₀ D hcoeffs)
+        _ = D.ι (polyToFunctionField (E).toAffine X) := kw_iP_xP_spec E₀ D hcoeffs
+    · calc D₀' (yGen (E₀⁄K))
+          = D₀' (Φ (yGen E₀.toAffine)) := congrArg D₀' (kw_iPF_phi_yGen E₀).symm
+        _ = Φ (ι₀ (yGen E₀.toAffine)) := hD₀'_gen _
+        _ = Φ (kw_iP_yP E₀ D hcoeffs) := congrArg Φ (kw_iP_ι₀_yGen E₀ D hcoeffs)
+        _ = D.ι (yGen (E).toAffine) := kw_iP_yP_spec E₀ D hcoeffs
+  have hcomm : ∀ x, ιFr (ψ x) = ψ (D.ι x) := fun x => by
+    have h1 : D.ι x = D₀' x := (DFunLike.congr_fun hD₀'_eq x).symm
+    calc ιFr (ψ x) = ψ (ψ.symm (ιFr (ψ x))) := (ψ.apply_symm_apply _).symm
+      _ = ψ (D₀' x) := rfl
+      _ = ψ (D.ι x) := by rw [h1]
+  have hfin_eq : finrankAlong K D.ι = D₀.degree := by
+    obtain ⟨_, hdeg_Fr⟩ :=
+      kw_tensorFracIotaFinrankSeam_dischargeGeneralNoAC E₀ (K₀ : Type uK) K D₀
+    refine (?_ : finrankAlong K D.ι = _).trans hdeg_Fr
+    exact @Algebra.finrank_eq_of_equiv_equiv
+      (E₀⁄K).FunctionField (E₀⁄K).FunctionField _ _ (algebraAlong D.ι)
+      FrT FrT _ _ ιFr.toAlgebra ψ.toRingEquiv ψ.toRingEquiv
+      (RingHom.ext hcomm)
+  change finrankAlong K₀ ι₀ = D.degree
+  rw [show D.degree = finrankAlong K D.ι from rfl, hfin_eq, hD₀_deg]
+
+omit [DecidableEq K] in
+omit [IsAlgClosed K] [CharZero K] in
+omit [E₀.IsElliptic] in
+theorem kw_iPFE_pinnedFinrank_uncond : KwIotaPinnedFinrank E₀ D hcoeffs := by
+  classical
+  exact
+    kw_iotaPinnedFinrank_of_finiteSeam E₀ D hcoeffs
+      (kw_iotaPinnedFiniteSeam_of_finrankEq E₀ D hcoeffs
+        (kw_iPFE_finrankEq E₀ D hcoeffs))
+
+end FinrankEq
+
+section Uncond
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K]
+variable (E : WeierstrassCurve K) (D : TreeIsogenyEndDatum E.toAffine)
+
+theorem kw_iPFE_canonicalFinrank_uncond : KwIotaCanonicalFinrank E D :=
+  fun hcoeffs => kw_iPFE_pinnedFinrank_uncond (kw_iCa_E₀ E D) (kw_iCa_D' E D) hcoeffs
+
+theorem kw_iPFE_iotaDescendToFG_uncond [IsAlgClosed K] [CharZero K] [E.IsElliptic] :
+    KwIsogenyEndDatumIotaDescendToFG'' K E D :=
+  kw_iotaDescendToFG_of_canonicalFinrank E D (kw_iPFE_canonicalFinrank_uncond E D)
+
+end Uncond
+end ModularCurve
+end
+end
+
+section
+
+
+section
+
+namespace ModularCurve
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve WeierstrassCurve.Affine \
+  P2MW.S_OVERLONG_6989a05c.Weierstrass\
+  Curve.Affine IntermediateField \
+  P2MW.S_OVERLONG_6989a05c.Intermediat\
+  eField AlgebraicCurve \
+  P2MW.S_OVERLONG_6989a05c.AlgebraicCu\
+  rve Polynomial \
+  P2MW.S_OVERLONG_6989a05c.Polynomial"
+
+section E2EChain
+
+variable {K : Type uK} [Field K] [Algebra ℚ K] [DecidableEq K] [IsAlgClosed K] [CharZero K]
+
+theorem kw_iE2E_iotaDescendToFG_of_iotaDescendToFG''
+    (E : WeierstrassCurve K) [E.IsElliptic] (D : TreeIsogenyEndDatum E.toAffine)
+    (h : KwIsogenyEndDatumIotaDescendToFG'' K E D) :
+    KwIsogenyEndDatumIotaDescendToFG K E D := h
+
+theorem kw_iE2E_iotaDescendToFG_uncond (E : WeierstrassCurve K) [E.IsElliptic]
+    (D : TreeIsogenyEndDatum E.toAffine) :
+    KwIsogenyEndDatumIotaDescendToFG K E D :=
+  kw_iE2E_iotaDescendToFG_of_iotaDescendToFG'' E D
+    (kw_iPFE_iotaDescendToFG_uncond E D)
+
+theorem kw_iE2E_subfieldDescent_of_subfieldDescent''
+    (E : WeierstrassCurve K) [E.IsElliptic] (N : ℕ)
+    (h : KwIsogenyEndDatumSubfieldDescent'' K E N) :
+    KwIsogenyEndDatumSubfieldDescent K E N := h
+
+theorem kw_iE2E_subfieldDescent_uncond (E : WeierstrassCurve K) [E.IsElliptic] (N : ℕ) :
+    KwIsogenyEndDatumSubfieldDescent K E N :=
+  kw_iE2E_subfieldDescent_of_subfieldDescent'' E N
+    (kw_subfieldDescent_of_iotaDescend K E N
+      (fun D => kw_iE2E_iotaDescendToFG_uncond E D))
+
+theorem kw_iE2E_fgFieldDescent_uncond (E : WeierstrassCurve K) [E.IsElliptic] (N : ℕ) :
+    KwIsogenyEndDatumFGFieldDescent K E N :=
+  kw_fgFieldDescent_of_subfieldDescent_of_baseChangeToAC K E N
+    (kw_iE2E_subfieldDescent_uncond E N)
+    (fun K₀ _ _ E₀ _ =>
+      haveI : DecidableEq K₀ := Classical.decEq K₀
+      kw_baseChangeToAC_uncond K₀ E₀ N)
+
+end E2EChain
+
+section Headline
+
+local notation "ℚ̄" => AlgebraicClosure ℚ
+
+end Headline
+end ModularCurve
+end
+end
+
+open _root_.AlgebraicCurve
+  _root_.P2MW.S_OVERLONG_6989a05c.AlgebraicCurve
+  _root_.WeierstrassCurve
+  _root_.P2MW.S_OVERLONG_6989a05c.WeierstrassCurve
+  in
+theorem solution {K : Type uK} [Field K] [CharZero K] [IsAlgClosed K]
+    (E : WeierstrassCurve K) [E.IsElliptic]
+    (ι : E.toAffine.FunctionField →ₐ[K] E.toAffine.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong K ι) :
+    ∃ (K₀ : IntermediateField ℚ K), Countable K₀ ∧
+      ∃ (E₀ : WeierstrassCurve K₀), E₀.IsElliptic ∧ E₀.map (algebraMap K₀ K) = E ∧
+        ∃ (ι₀ : (E₀.baseChange (AlgebraicClosure K₀)).toAffine.FunctionField →ₐ[AlgebraicClosure K₀]
+            (E₀.baseChange (AlgebraicClosure K₀)).toAffine.FunctionField),
+          ι₀.toRingHom.IsIntegral ∧
+          ∃ (_ : FiniteAlong (AlgebraicClosure K₀) ι₀),
+            finrankAlong (AlgebraicClosure K₀) ι₀ = finrankAlong K ι := by
+  classical
+  obtain ⟨K₀, hK₀, E₀, hE₀, hmap, D₀, hdeg⟩ :=
+    ModularCurve.kw_iE2E_fgFieldDescent_uncond (K := K) E (finrankAlong K ι) ⟨⟨ι, hι, hfin⟩, rfl⟩
+  exact ⟨K₀, hK₀, E₀, hE₀, hmap, D₀.ι, D₀.hι, D₀.hfin, hdeg⟩
+
+end
+end
+end S_OVERLONG_6989a05c
+end P2MW
+export P2MW.S_OVERLONG_6989a05c
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open AlgebraicCurve
+
+universe u
+theorem WeierstrassCurve.exists_intermediateField_countable_map_eq_and_finrankAlong_eq
+    {K : Type u} [Field K] [CharZero K] [IsAlgClosed K]
+    (E : WeierstrassCurve K) [E.IsElliptic]
+    (ι : E.toAffine.FunctionField →ₐ[K] E.toAffine.FunctionField)
+    (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong K ι) :
+    ∃ (K₀ : IntermediateField ℚ K), Countable K₀ ∧
+      ∃ (E₀ : WeierstrassCurve K₀), E₀.IsElliptic ∧ E₀.map (algebraMap K₀ K) = E ∧
+        ∃ (ι₀ : (E₀.baseChange (AlgebraicClosure K₀)).toAffine.FunctionField →ₐ[AlgebraicClosure K₀]
+            (E₀.baseChange (AlgebraicClosure K₀)).toAffine.FunctionField),
+          ι₀.toRingHom.IsIntegral ∧
+          ∃ (_ : FiniteAlong (AlgebraicClosure K₀) ι₀),
+            finrankAlong (AlgebraicClosure K₀) ι₀ = finrankAlong K ι :=
+  _root_.P2MW.S_OVERLONG_6989a05c.solution
+    E ι hι hfin
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_isUnit_discriminant_and_c4_cube_eq_mul_X_cube_powerSeries.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_isUnit_discriminant_and_c4_cube_eq_mul_X_cube_powerSeries.lean
new file mode 100644
index 0000000000..843aaabff7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_isUnit_discriminant_and_c4_cube_eq_mul_X_cube_powerSeries.lean
@@ -0,0 +1,127 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.exists_isUnit_discriminant_and_c4_cube_eq_mul_X_cube_powerSeries
+(7c2b8f26-6118-5a2b-ac40-9ee60681b11f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f225b1e5-63af-5806-b136-701c20c6fbdc
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Weierstrass
+public import Mathlib.RingTheory.PowerSeries.Basic
+
+import Mathlib.RingTheory.PowerSeries.Inverse
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Good-reduction Weierstrass model over K[[t]] with j=t³
+
+Theorem statement:
+`WeierstrassCurve.exists_isUnit_discriminant_and_c4_cube_eq_mul_X_cube_powerSeries`
+(`7c2b8f26-6118-5a2b-ac40-9ee60681b11f`), by Claude, 2026-09-05.
+
+Proof: submission `f225b1e5-63af-5806-b136-701c20c6fbdc`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field in which $2 \neq 0$ and $3 \neq 0$. The assertion is the existence of a
+Weierstrass curve $E$ over the power-series ring $K[[t]]$ — that is, a tuple of coefficients
+$a_1,a_2,a_3,a_4,a_6 \in K[[t]]$ in the sense of Mathlib's `WeierstrassCurve` structure — such that
+two conditions hold simultaneously: the discriminant $\Delta(E)$, formed from the usual
+$b$-invariants by $\Delta = -b_2^2b_8 - 8b_4^3 - 27b_6^2 + 9b_2b_4b_6$, is a unit of $K[[t]]$, and
+the invariant $c_4(E) = b_2^2 - 24b_4$ satisfies the identity $c_4(E)^3 = \Delta(E)\cdot t^3$, where
+$t =$ `PowerSeries.X`. Since $\Delta(E)$ is invertible, the second equation is exactly the statement
+$j(E) = c_4^3/\Delta = t^3$, cleared of the denominator. Only existence is asserted; no particular
+model appears in the statement, and no condition beyond invertibility of $2$ and $3$ in $K$ is
+imposed.
+
+This provides a one-parameter family of elliptic curves over $K[[t]]$ with good reduction at $t = 0$
+whose $j$-invariant is the cube $t^3$, i.e. a local model near the elliptic point $j = 0$ of the
+$j$-line. It is used in the analysis of ramification of $X_0(N) \to X(1)$ above $j = 0$, being cited
+by
+[`ModularCurve.ModularPolynomialData.hasRamBound_three_of_isRoot_at_zero_of_odd`]
+(thm.html#ModularCurve.ModularPolynomialData.hasRamBound_three_of_isRoot_at_zero_of_odd)
+and [`ModularCurve.ord_jBar_dvd_three`](thm.html#ModularCurve.ord_jBar_dvd_three).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_exists_isUnit_discriminant_and_c4_cube_eq_mul_X_cube_powerSeries.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_exists_isUnit_discriminant_and_c4_cube_eq_mul_X_cube_powerSeries
+
+open PowerSeries
+
+namespace P2MWs13
+namespace GoodRedModels
+
+variable (K : Type*) [Field K]
+
+theorem isUnit_1728_sub_X_cube (h2 : (2 : K) ≠ 0) (h3 : (3 : K) ≠ 0) :
+    IsUnit ((1728 : PowerSeries K) - PowerSeries.X ^ 3) := by
+  refine PowerSeries.isUnit_iff_constantCoeff.mpr (isUnit_iff_ne_zero.mpr ?_)
+  simp only [map_sub, map_ofNat, map_pow, PowerSeries.constantCoeff_X]
+  have hfac : (1728 : K) = 2 ^ 6 * 3 ^ 3 := by norm_num
+  norm_num
+  rw [hfac]; exact mul_ne_zero (pow_ne_zero _ h2) (pow_ne_zero _ h3)
+
+theorem isUnit_1728_add_X_sq (h2 : (2 : K) ≠ 0) (h3 : (3 : K) ≠ 0) :
+    IsUnit ((1728 : PowerSeries K) + PowerSeries.X ^ 2) := by
+  refine PowerSeries.isUnit_iff_constantCoeff.mpr (isUnit_iff_ne_zero.mpr ?_)
+  simp only [map_add, map_ofNat, map_pow, PowerSeries.constantCoeff_X]
+  have hfac : (1728 : K) = 2 ^ 6 * 3 ^ 3 := by norm_num
+  norm_num
+  rw [hfac]; exact mul_ne_zero (pow_ne_zero _ h2) (pow_ne_zero _ h3)
+
+theorem isUnit_const (h2 : (2 : K) ≠ 0) (h3 : (3 : K) ≠ 0) (a b : ℕ) :
+    IsUnit ((2 : PowerSeries K) ^ a * 3 ^ b) := by
+  refine PowerSeries.isUnit_iff_constantCoeff.mpr (isUnit_iff_ne_zero.mpr ?_)
+  simp only [map_mul, map_pow, map_ofNat]
+  exact mul_ne_zero (pow_ne_zero _ h2) (pow_ne_zero _ h3)
+
+end P2MWs13.GoodRedModels
+
+open P2MWs13.GoodRedModels in
+theorem solution
+    (K : Type*) [Field K] (h2 : (2 : K) ≠ 0) (h3 : (3 : K) ≠ 0) :
+    ∃ E : WeierstrassCurve (PowerSeries K), IsUnit E.Δ ∧ E.c₄ ^ 3 = E.Δ * PowerSeries.X ^ 3 := by
+  set s : PowerSeries K := 1728 - PowerSeries.X ^ 3 with hs
+  let E : WeierstrassCurve (PowerSeries K) := ⟨0, 0, 0, 3 * PowerSeries.X * s, 2 * s ^ 2⟩
+  have hΔ : E.Δ = -(2 ^ 12 * 3 ^ 6) * s ^ 3 := by
+    simp only [E, WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄,
+      WeierstrassCurve.b₆, WeierstrassCurve.b₈]
+    rw [hs]; ring
+  have hc₄ : E.c₄ = -144 * PowerSeries.X * s := by
+    simp only [E, WeierstrassCurve.c₄, WeierstrassCurve.b₂, WeierstrassCurve.b₄]; ring
+  refine ⟨E, ?_, ?_⟩
+  · rw [hΔ]
+    exact ((isUnit_const K h2 h3 12 6).neg).mul ((isUnit_1728_sub_X_cube K h2 h3).pow 3)
+  · rw [hc₄, hΔ]; ring
+
+end S_WeierstrassCurve_exists_isUnit_discriminant_and_c4_cube_eq_mul_X_cube_powerSeries
+end P2MW
+export P2MW.S_WeierstrassCurve_exists_isUnit_discriminant_and_c4_cube_eq_mul_X_cube_powerSeries
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.exists_isUnit_discriminant_and_c4_cube_eq_mul_X_cube_powerSeries
+    (K : Type*) [Field K] (h2 : (2 : K) ≠ 0) (h3 : (3 : K) ≠ 0) :
+    ∃ E : WeierstrassCurve (PowerSeries K), IsUnit E.Δ ∧ E.c₄ ^ 3 = E.Δ * PowerSeries.X ^ 3 :=
+  solution K h2 h3
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_isUnit_discriminant_and_c6_sq_eq_mul_X_sq_powerSeries.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_isUnit_discriminant_and_c6_sq_eq_mul_X_sq_powerSeries.lean
new file mode 100644
index 0000000000..829c756ae1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_isUnit_discriminant_and_c6_sq_eq_mul_X_sq_powerSeries.lean
@@ -0,0 +1,125 @@
+/-
+Based on Prove2Me node WeierstrassCurve.exists_isUnit_discriminant_and_c6_sq_eq_mul_X_sq_powerSeries
+(64da0625-6b80-5664-87ab-528cc176dc80) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ad741ddb-39a7-5a28-9878-3532ace3d732
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Weierstrass
+public import Mathlib.RingTheory.PowerSeries.Basic
+
+import Mathlib.RingTheory.PowerSeries.Inverse
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Good-reduction Weierstrass model over K[[t]] with j-1728=t²
+
+Theorem statement: `WeierstrassCurve.exists_isUnit_discriminant_and_c6_sq_eq_mul_X_sq_powerSeries`
+(`64da0625-6b80-5664-87ab-528cc176dc80`), by Claude, 2026-09-05.
+
+Proof: submission `ad741ddb-39a7-5a28-9878-3532ace3d732`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $K$ be a field in which $2 \ne 0$ and $3 \ne 0$ (so $\operatorname{char} K \nmid 6$). The
+assertion is that there exists a Weierstrass curve $E$ over the power series ring $K[[X]]$ — that
+is, a tuple of coefficients $a_1, a_2, a_3, a_4, a_6 \in K[[X]]$ in the sense of Mathlib's
+`WeierstrassCurve` — such that two conditions hold: the discriminant $\Delta(E)$, formed from the
+usual quantities $b_2, b_4, b_6, b_8$, is a unit of $K[[X]]$, and the invariant $c_6(E)$ satisfies
+$c_6(E)^2 = \Delta(E)\cdot X^2$. Since $c_4^3 - c_6^2 = 1728\,\Delta$ identically and $\Delta$ is
+invertible, the second condition says exactly that the $j$-invariant of $E$ satisfies $j(E) - 1728 =
+X^2$ in $K[[X]]$. No minimality, non-singularity in the Mathlib sense, or further normalisation of
+$E$ is asserted beyond these two equations.
+
+This provides an elliptic curve over $K[[t]]$ with good reduction whose $j$-invariant has $j - 1728$
+equal to the uniformiser squared, i.e. a local model at the elliptic point $j = 1728$ of the
+$j$-line. It is used in the analysis of ramification of modular coverings above $j = 1728$, namely
+by
+[`ModularCurve.ModularPolynomialData.hasRamBound_two_of_isRoot_at_1728_of_odd`]
+(thm.html#ModularCurve.ModularPolynomialData.hasRamBound_two_of_isRoot_at_1728_of_odd)
+and [`ModularCurve.ord_jBar_sub_1728_dvd_two`](thm.html#ModularCurve.ord_jBar_sub_1728_dvd_two).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_exists_isUnit_discriminant_and_c6_sq_eq_mul_X_sq_powerSeries.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_exists_isUnit_discriminant_and_c6_sq_eq_mul_X_sq_powerSeries
+
+open PowerSeries
+
+namespace P2MWs13
+namespace GoodRedModels
+
+variable (K : Type*) [Field K]
+
+theorem isUnit_1728_sub_X_cube (h2 : (2 : K) ≠ 0) (h3 : (3 : K) ≠ 0) :
+    IsUnit ((1728 : PowerSeries K) - PowerSeries.X ^ 3) := by
+  refine PowerSeries.isUnit_iff_constantCoeff.mpr (isUnit_iff_ne_zero.mpr ?_)
+  simp only [map_sub, map_ofNat, map_pow, PowerSeries.constantCoeff_X]
+  have hfac : (1728 : K) = 2 ^ 6 * 3 ^ 3 := by norm_num
+  norm_num
+  rw [hfac]; exact mul_ne_zero (pow_ne_zero _ h2) (pow_ne_zero _ h3)
+
+theorem isUnit_1728_add_X_sq (h2 : (2 : K) ≠ 0) (h3 : (3 : K) ≠ 0) :
+    IsUnit ((1728 : PowerSeries K) + PowerSeries.X ^ 2) := by
+  refine PowerSeries.isUnit_iff_constantCoeff.mpr (isUnit_iff_ne_zero.mpr ?_)
+  simp only [map_add, map_ofNat, map_pow, PowerSeries.constantCoeff_X]
+  have hfac : (1728 : K) = 2 ^ 6 * 3 ^ 3 := by norm_num
+  norm_num
+  rw [hfac]; exact mul_ne_zero (pow_ne_zero _ h2) (pow_ne_zero _ h3)
+
+theorem isUnit_const (h2 : (2 : K) ≠ 0) (h3 : (3 : K) ≠ 0) (a b : ℕ) :
+    IsUnit ((2 : PowerSeries K) ^ a * 3 ^ b) := by
+  refine PowerSeries.isUnit_iff_constantCoeff.mpr (isUnit_iff_ne_zero.mpr ?_)
+  simp only [map_mul, map_pow, map_ofNat]
+  exact mul_ne_zero (pow_ne_zero _ h2) (pow_ne_zero _ h3)
+
+end P2MWs13.GoodRedModels
+
+open P2MWs13.GoodRedModels in
+theorem solution
+    (K : Type*) [Field K] (h2 : (2 : K) ≠ 0) (h3 : (3 : K) ≠ 0) :
+    ∃ E : WeierstrassCurve (PowerSeries K), IsUnit E.Δ ∧ E.c₆ ^ 2 = E.Δ * PowerSeries.X ^ 2 := by
+  set u : PowerSeries K := 1728 + PowerSeries.X ^ 2 with hu
+  let E : WeierstrassCurve (PowerSeries K) := ⟨0, 0, 0, -3 * u, 2 * PowerSeries.X * u⟩
+  have hΔ : E.Δ = (2 ^ 12 * 3 ^ 6) * u ^ 2 := by
+    simp only [E, WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄,
+      WeierstrassCurve.b₆, WeierstrassCurve.b₈]
+    rw [hu]; ring
+  have hc₆ : E.c₆ = -1728 * PowerSeries.X * u := by
+    simp only [E, WeierstrassCurve.c₆, WeierstrassCurve.b₂, WeierstrassCurve.b₄,
+      WeierstrassCurve.b₆]; ring
+  refine ⟨E, ?_, ?_⟩
+  · rw [hΔ]
+    exact (isUnit_const K h2 h3 12 6).mul ((isUnit_1728_add_X_sq K h2 h3).pow 2)
+  · rw [hc₆, hΔ]; ring
+
+end S_WeierstrassCurve_exists_isUnit_discriminant_and_c6_sq_eq_mul_X_sq_powerSeries
+end P2MW
+export P2MW.S_WeierstrassCurve_exists_isUnit_discriminant_and_c6_sq_eq_mul_X_sq_powerSeries
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.exists_isUnit_discriminant_and_c6_sq_eq_mul_X_sq_powerSeries
+    (K : Type*) [Field K] (h2 : (2 : K) ≠ 0) (h3 : (3 : K) ≠ 0) :
+    ∃ E : WeierstrassCurve (PowerSeries K), IsUnit E.Δ ∧ E.c₆ ^ 2 = E.Δ * PowerSeries.X ^ 2 :=
+  solution K h2 h3
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_pairing_torsionBy.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_pairing_torsionBy.lean
new file mode 100644
index 0000000000..cece371576
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_pairing_torsionBy.lean
@@ -0,0 +1,165 @@
+/-
+Based on Prove2Me node WeierstrassCurve.exists_pairing_torsionBy
+(8cc59908-b35c-566c-8fd8-96a1d707b891) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission cb614a27-3334-5506-abd3-5f9a452af775
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_GaloisRep
+
+import Mathlib.Tactic.Ring
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_WeilPairingFun
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_eq_zero_of_forall_transEquiv_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_mulPull_le_of_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_transEquiv_weilFun_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_weilPairing0_add_left
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_weilPairing0_add_right
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_weilPairing0_self
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_valuation_weilFun
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_weilPairing0_galois
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Existence of the Weil pairing on n-torsion
+
+Theorem statement: `WeierstrassCurve.exists_pairing_torsionBy`
+(`8cc59908-b35c-566c-8fd8-96a1d707b891`), by Claude, 2026-09-05.
+
+Proof: submission `cb614a27-3334-5506-abd3-5f9a452af775`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field, $K$ an algebraically closed field equipped with an $F$-algebra structure, $W$ a
+Weierstrass curve over $F$ which is elliptic, and $n$ a natural number whose image in $K$ is
+nonzero. Write $E[n]$ for the $\mathbb{Z}$-submodule `Submodule.torsionBy ℤ (W⁄K).Point n` of points
+of the base change of $W$ to $K$ killed by $n$. The assertion is that there exists a function $e :
+E[n] \times E[n] \to K^{\times}$ with the following five properties: $e(P+P',Q) = e(P,Q)\,e(P',Q)$
+and $e(P,Q+Q') = e(P,Q)\,e(P,Q')$ for all $P,P',Q,Q' \in E[n]$; $e(P,P) = 1$ for all $P$; for every
+$F$-algebra automorphism $\sigma$ of $K$ and all $P,Q$, the image of $e(\sigma\cdot P,\sigma\cdot
+Q)$ in $K$ equals $\sigma(e(P,Q))$, the action being the Galois action on $n$-torsion points; and
+nondegeneracy in the left variable, namely that $e(P,Q)=1$ for all $Q \in E[n]$ forces $P = 0$. Note
+that $e$ is produced as a bare function, not as a bundled bilinear or multiplicative map.
+
+This is the existence theorem for the Weil $e_n$-pairing on the $n$-torsion of an elliptic curve, in
+the form used to compute determinants of the Galois representations attached to an elliptic curve;
+it is cited in the identification of $\det \bar\rho_{E,n}$ with the mod-$n$ cyclotomic character, in
+particular in the computation of the determinant of Frobenius on the Tate module and on the mod-$n$
+representation.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_exists_pairing_torsionBy.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_exists_pairing_torsionBy
+
+open WeierstrassCurve WeierstrassCurve.Affine IsDedekindDomain WithZero
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+theorem WeilPairing.exists_pairing_torsionBy_of_laws {F K : Type*} [Field F] [Field K] [Algebra F K]
+    [DecidableEq K] (W : WeierstrassCurve F) {n : ℕ}
+    (e₀ : (W⁄K).Point → (W⁄K).Point → Kˣ)
+    (haddL : ∀ S S' T : (W⁄K).Point, (n : ℤ) • S = 0 → (n : ℤ) • S' = 0 → (n : ℤ) • T = 0 →
+      e₀ (S + S') T = e₀ S T * e₀ S' T)
+    (haddR : ∀ S T T' : (W⁄K).Point, (n : ℤ) • S = 0 → (n : ℤ) • T = 0 → (n : ℤ) • T' = 0 →
+      e₀ S (T + T') = e₀ S T * e₀ S T')
+    (halt : ∀ T : (W⁄K).Point, (n : ℤ) • T = 0 → e₀ T T = 1)
+    (hgal : ∀ (σ : K ≃ₐ[F] K) (S T : (W⁄K).Point), (n : ℤ) • S = 0 → (n : ℤ) • T = 0 →
+      ((e₀ (σ • S) (σ • T) : Kˣ) : K) = σ (e₀ S T))
+    (hndR : ∀ T : (W⁄K).Point, (n : ℤ) • T = 0 →
+      (∀ S : (W⁄K).Point, (n : ℤ) • S = 0 → e₀ S T = 1) → T = 0) :
+    ∃ e : Submodule.torsionBy ℤ (W⁄K).Point n → Submodule.torsionBy ℤ (W⁄K).Point n → Kˣ,
+      (∀ P P' Q, e (P + P') Q = e P Q * e P' Q) ∧ (∀ P Q Q', e P (Q + Q') = e P Q * e P Q') ∧
+      (∀ P, e P P = 1) ∧
+      (∀ (σ : K ≃ₐ[F] K) P Q, ((e (σ • P) (σ • Q) : Kˣ) : K) = σ (e P Q)) ∧
+      (∀ P, (∀ Q, e P Q = 1) → P = 0) := by
+  set V := Submodule.torsionBy ℤ (W⁄K).Point n
+  have hmem : ∀ P : V, (n : ℤ) • (P : (W⁄K).Point) = 0 := fun P =>
+    (Submodule.mem_torsionBy_iff _ _).mp P.2
+  refine ⟨fun P Q => e₀ P Q, ?_, ?_, ?_, ?_, ?_⟩
+  · intro P P' Q
+    exact haddL _ _ _ (hmem P) (hmem P') (hmem Q)
+  · intro P Q Q'
+    exact haddR _ _ _ (hmem P) (hmem Q) (hmem Q')
+  · intro P
+    exact halt _ (hmem P)
+  · intro σ P Q
+    exact hgal σ _ _ (hmem P) (hmem Q)
+  · intro P hP
+    have hskew : ∀ S T : (W⁄K).Point, (n : ℤ) • S = 0 → (n : ℤ) • T = 0 →
+        e₀ T S = (e₀ S T)⁻¹ := by
+      intro S T hS hT
+      have hST : (n : ℤ) • (S + T) = 0 := by rw [smul_add, hS, hT, add_zero]
+      have h := halt _ hST
+      rw [haddL _ _ _ hS hT hST, haddR _ _ _ hS hS hT, haddR _ _ _ hT hS hT, halt _ hS,
+        halt _ hT, one_mul, mul_one] at h
+      exact eq_inv_of_mul_eq_one_right h
+    apply Subtype.ext
+    apply hndR _ (hmem P)
+    intro S hS
+    have h1 : e₀ P S = 1 := hP ⟨S, (Submodule.mem_torsionBy_iff _ _).mpr hS⟩
+    rw [hskew _ _ (hmem P) hS, h1, inv_one]
+
+theorem solution {F K : Type*} [Field F] [Field K] [Algebra F K] [IsAlgClosed K] [DecidableEq K]
+    (W : WeierstrassCurve F) [W.IsElliptic] {n : ℕ} (hnK : (n : K) ≠ 0) :
+    ∃ e : Submodule.torsionBy ℤ (W⁄K).Point n → Submodule.torsionBy ℤ (W⁄K).Point n → Kˣ, (∀ P P' Q,
+      e (P + P') Q = e P Q * e P' Q) ∧ (∀ P Q Q', e P (Q + Q') = e P Q * e P Q') ∧ (∀ P, e P P = 1)
+      ∧ (∀ (σ : K ≃ₐ[F] K) P Q, ((e (σ • P) (σ • Q) : Kˣ) : K) = σ (e P Q)) ∧ (∀ P, (∀ Q, e P Q = 1)
+      → P = 0) := by
+  classical
+  have hEK : (W⁄K).IsElliptic := by
+    dsimp only [Affine.baseChange, WeierstrassCurve.baseChange]; infer_instance
+  have : IsDedekindDomain (W⁄K).CoordinateRing := CoordinateRing.isDedekindDomain (W⁄K)
+  refine WeilPairing.exists_pairing_torsionBy_of_laws W (weilPairing0 W K n)
+    (fun S S' T hS hS' hT => WeierstrassCurve.Affine.weilPairing0_add_left W hnK S S' T hS hS' hT)
+    (fun S T T' hS hT hT' => WeierstrassCurve.Affine.weilPairing0_add_right W hnK S T T' hS hT hT')
+    (fun T hT => WeierstrassCurve.Affine.weilPairing0_self W hnK T hT)
+    (fun σ S T hS hT => WeierstrassCurve.Affine.weilPairing0_galois W hnK σ S T hS hT) ?_
+  intro T hT h1
+  apply WeierstrassCurve.Affine.eq_zero_of_forall_transEquiv_eq W hnK
+    (fun P hP hnP h k hh => WeierstrassCurve.Affine.valuation_mulPull_le_of_ne_zero W hnK P hP hnP h
+      k hh)
+    (weilFun W K n T)
+  · intro P hP hnP
+    rw [WeierstrassCurve.Affine.valuation_weilFun W hnK hT P hP, ite_eq_right hnP, div_one]
+  · intro S hS
+    obtain ⟨c, hc⟩ := WeierstrassCurve.Affine.exists_transEquiv_weilFun_eq W hnK S T hS hT
+    have h := transEquiv_weilFun W K ⟨c, hc⟩
+    rw [h1 S hS, Units.val_one, map_one, one_mul] at h
+    exact h
+
+end S_WeierstrassCurve_exists_pairing_torsionBy
+end P2MW
+export P2MW.S_WeierstrassCurve_exists_pairing_torsionBy (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+theorem WeierstrassCurve.exists_pairing_torsionBy {F K : Type*} [Field F] [Field K] [Algebra F K]
+    [IsAlgClosed K] [DecidableEq K] (W : WeierstrassCurve F) [W.IsElliptic] {n : ℕ}
+    (hnK : (n : K) ≠ 0) :
+    ∃ e : Submodule.torsionBy ℤ (W⁄K).Point n → Submodule.torsionBy ℤ (W⁄K).Point n → Kˣ, (∀ P P' Q,
+      e (P + P') Q = e P Q * e P' Q) ∧ (∀ P Q Q', e P (Q + Q') = e P Q * e P Q') ∧ (∀ P, e P P = 1)
+      ∧ (∀ (σ : K ≃ₐ[F] K) P Q, ((e (σ • P) (σ • Q) : Kˣ) : K) = σ (e P Q)) ∧ (∀ P, (∀ Q, e P Q = 1)
+      → P = 0) :=
+  solution W hnK
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_valuation_eq_exp_of_not_le_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_valuation_eq_exp_of_not_le_one.lean
new file mode 100644
index 0000000000..ce5a1f9ae4
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_valuation_eq_exp_of_not_le_one.lean
@@ -0,0 +1,198 @@
+/-
+Based on Prove2Me node WeierstrassCurve.exists_valuation_eq_exp_of_not_le_one
+(f89d942c-8e85-5294-aa47-5d6adf511407) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission fc8aa135-b487-5b6f-847e-2fac4924c711
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Basic
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Reduction
+
+import Mathlib.RingTheory.DedekindDomain.AdicValuation
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Poles of order 2s and 3s on an integral Weierstrass model
+
+Theorem statement: `WeierstrassCurve.exists_valuation_eq_exp_of_not_le_one`
+(`f89d942c-8e85-5294-aa47-5d6adf511407`), by Claude, 2026-09-05.
+
+Proof: submission `fc8aa135-b487-5b6f-847e-2fac4924c711`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative domain which is a discrete valuation ring, and let $K$ be a field equipped
+with an $R$-algebra structure making it the fraction field of $R$; write $v$ for the valuation of
+$K$ attached to the height-one prime $\mathfrak m =$ `IsDiscreteValuationRing.maximalIdeal R`,
+normalised so that every element of (the image of) $R$ has $v \le 1$. Let $W$ be a Weierstrass curve
+over $K$ which is integral over $R$ in the sense of `WeierstrassCurve.IsIntegral`, so that each of
+the coefficients $a_1, a_2, a_3, a_4, a_6$ of $W$ is the image under `algebraMap R K` of the
+corresponding coefficient of an integral model over $R$. Let $x, y \in K$ satisfy the affine
+Weierstrass equation $y^2 + a_1xy + a_3y = x^3 + a_2x^2 + a_4x + a_6$, and assume that $v(x) \le 1$
+fails, i.e. $x$ is not $\mathfrak m$-integral. Then there is a natural number $s$ with $s > 0$ such
+that $v(x) = \exp(2s)$ and $v(y) = \exp(3s)$ in $\mathbb{Z}_{m0}$; in additive notation, $x$ has a
+pole of order exactly $2s$ and $y$ a pole of order exactly $3s$ at $\mathfrak m$.
+
+This is the standard description of affine points of a Weierstrass model with non-integral
+coordinates, as in the analysis of the kernel of reduction: the pole orders of $x$ and $y$ are in
+the ratio $2:3$. It is used in the present development by
+[`WeierstrassCurve.reducePoint_some_add_some_of_not_le_one`]
+(thm.html#WeierstrassCurve.reducePoint_some_add_some_of_not_le_one),
+in establishing the behaviour of reduction on points.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_exists_valuation_eq_exp_of_not_le_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_exists_valuation_eq_exp_of_not_le_one
+
+open WeierstrassCurve IsDiscreteValuationRing IsLocalRing IsDedekindDomain.HeightOneSpectrum
+
+namespace PoleDichotomy
+
+theorem valuation_dichotomy (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+    {K : Type*} [Field K] [Algebra R K] [IsFractionRing R K] (W : WeierstrassCurve K)
+    [W.IsIntegral R] {x y : K} (h : W.toAffine.Equation x y)
+    (hx : ¬ valuation K (IsDiscreteValuationRing.maximalIdeal R) x ≤ 1) :
+    ∃ s : ℕ, 0 < s ∧
+      valuation K (IsDiscreteValuationRing.maximalIdeal R) x
+        = WithZero.exp (2 * (s : ℤ)) ∧
+      valuation K (IsDiscreteValuationRing.maximalIdeal R) y
+        = WithZero.exp (3 * (s : ℤ)) := by
+  set v := valuation K (IsDiscreteValuationRing.maximalIdeal R) with hv
+  have key : ∀ z : K, (∃ r : R, algebraMap R K r = z) → v z ≤ 1 := by
+    rintro z ⟨r, rfl⟩; exact valuation_le_one (IsDiscreteValuationRing.maximalIdeal R) r
+  have ha1 : v W.toAffine.a₁ ≤ 1 := key _ ⟨_, integralModel_a₁_eq R W⟩
+  have ha2 : v W.toAffine.a₂ ≤ 1 := key _ ⟨_, integralModel_a₂_eq R W⟩
+  have ha3 : v W.toAffine.a₃ ≤ 1 := key _ ⟨_, integralModel_a₃_eq R W⟩
+  have ha4 : v W.toAffine.a₄ ≤ 1 := key _ ⟨_, integralModel_a₄_eq R W⟩
+  have ha6 : v W.toAffine.a₆ ≤ 1 := key _ ⟨_, integralModel_a₆_eq R W⟩
+  have hpow : ∀ (n : ℕ) (c : ℤ), WithZero.exp c ^ n = WithZero.exp ((n : ℤ) * c) := by
+    intro n c
+    rw [← WithZero.exp_nsmul, nsmul_eq_mul]
+  have hvx1 : 1 < v x := not_le.mp hx
+  have hvx0 : v x ≠ 0 := (zero_lt_one.trans hvx1).ne'
+  obtain ⟨a, hax⟩ : ∃ a : ℤ, v x = WithZero.exp a := ⟨_, (WithZero.exp_log hvx0).symm⟩
+  have ha0 : 0 < a := by
+    have h1 : WithZero.exp (0 : ℤ) < WithZero.exp a := by
+      rw [WithZero.exp_zero, ← hax]; exact hvx1
+    exact WithZero.exp_lt_exp.mp h1
+  have hx3 : v (x ^ 3) = WithZero.exp (3 * a) := by
+    rw [map_pow, hax, hpow]; norm_num
+  have hA2 : v (W.toAffine.a₂ * x ^ 2) ≤ WithZero.exp (2 * a) := by
+    calc v (W.toAffine.a₂ * x ^ 2) = v W.toAffine.a₂ * WithZero.exp (2 * a) := by
+          rw [map_mul, map_pow, hax, hpow]; norm_num
+      _ ≤ 1 * WithZero.exp (2 * a) := mul_le_mul' ha2 le_rfl
+      _ = WithZero.exp (2 * a) := one_mul _
+  have hA4 : v (W.toAffine.a₄ * x) ≤ WithZero.exp a := by
+    calc v (W.toAffine.a₄ * x) = v W.toAffine.a₄ * WithZero.exp a := by rw [map_mul, hax]
+      _ ≤ 1 * WithZero.exp a := mul_le_mul' ha4 le_rfl
+      _ = WithZero.exp a := one_mul _
+  have h1 : v (x ^ 3 + W.toAffine.a₂ * x ^ 2) = WithZero.exp (3 * a) := by
+    rw [← hx3]
+    exact v.map_add_eq_of_lt_left
+      (hx3 ▸ lt_of_le_of_lt hA2 (WithZero.exp_lt_exp.mpr (by omega)))
+  have h2 : v (x ^ 3 + W.toAffine.a₂ * x ^ 2 + W.toAffine.a₄ * x) = WithZero.exp (3 * a) := by
+    rw [← h1]
+    exact v.map_add_eq_of_lt_left
+      (h1 ▸ lt_of_le_of_lt hA4 (WithZero.exp_lt_exp.mpr (by omega)))
+  have hRHS : v (x ^ 3 + W.toAffine.a₂ * x ^ 2 + W.toAffine.a₄ * x + W.toAffine.a₆)
+      = WithZero.exp (3 * a) := by
+    rw [← h2]
+    refine v.map_add_eq_of_lt_left (h2 ▸ lt_of_le_of_lt ha6 ?_)
+    rw [← WithZero.exp_zero]
+    exact WithZero.exp_lt_exp.mpr (by omega)
+  rw [Affine.equation_iff] at h
+  have hLHS : v (y ^ 2 + W.toAffine.a₁ * x * y + W.toAffine.a₃ * y) = WithZero.exp (3 * a) := by
+    rw [h]; exact hRHS
+  have hy0 : y ≠ 0 := by
+    rintro rfl
+    rw [zero_pow two_ne_zero, mul_zero, mul_zero, add_zero, add_zero, map_zero] at hLHS
+    exact WithZero.exp_ne_zero hLHS.symm
+  have hvy0 : v y ≠ 0 := fun h0 => hy0 (v.zero_iff.mp h0)
+  obtain ⟨b, hby⟩ : ∃ b : ℤ, v y = WithZero.exp b := ⟨_, (WithZero.exp_log hvy0).symm⟩
+  have hy2 : v (y ^ 2) = WithZero.exp (2 * b) := by
+    rw [map_pow, hby, hpow]; norm_num
+  have hA1 : v (W.toAffine.a₁ * x * y) ≤ WithZero.exp (a + b) := by
+    calc v (W.toAffine.a₁ * x * y)
+        = v W.toAffine.a₁ * (WithZero.exp a * WithZero.exp b) := by
+          rw [map_mul, map_mul, mul_assoc, hax, hby]
+      _ ≤ 1 * (WithZero.exp a * WithZero.exp b) := mul_le_mul' ha1 le_rfl
+      _ = WithZero.exp (a + b) := by rw [one_mul, ← WithZero.exp_add]
+  have hA3 : v (W.toAffine.a₃ * y) ≤ WithZero.exp b := by
+    calc v (W.toAffine.a₃ * y) = v W.toAffine.a₃ * WithZero.exp b := by rw [map_mul, hby]
+      _ ≤ 1 * WithZero.exp b := mul_le_mul' ha3 le_rfl
+      _ = WithZero.exp b := one_mul _
+  rcases lt_trichotomy (2 * b) (3 * a) with hlt | heq2 | hgt
+  · exfalso
+    have ht1 : v (y ^ 2) < WithZero.exp (3 * a) := by
+      rw [hy2]; exact WithZero.exp_lt_exp.mpr hlt
+    have ht2 : v (W.toAffine.a₁ * x * y) < WithZero.exp (3 * a) :=
+      lt_of_le_of_lt hA1 (WithZero.exp_lt_exp.mpr (by omega))
+    have ht3 : v (W.toAffine.a₃ * y) < WithZero.exp (3 * a) :=
+      lt_of_le_of_lt hA3 (WithZero.exp_lt_exp.mpr (by omega))
+    exact (v.map_add_lt (v.map_add_lt ht1 ht2) ht3).ne hLHS
+  · refine ⟨(b - a).toNat, by omega, ?_, ?_⟩
+    · rw [hax]; congr 1; omega
+    · rw [hby]; congr 1; omega
+  · exfalso
+    have ht2 : v (W.toAffine.a₁ * x * y) < v (y ^ 2) := by
+      rw [hy2]; exact lt_of_le_of_lt hA1 (WithZero.exp_lt_exp.mpr (by omega))
+    have ht3 : v (W.toAffine.a₃ * y) < v (y ^ 2) := by
+      rw [hy2]; exact lt_of_le_of_lt hA3 (WithZero.exp_lt_exp.mpr (by omega))
+    rw [add_assoc] at hLHS
+    have hdom : v (y ^ 2 + (W.toAffine.a₁ * x * y + W.toAffine.a₃ * y)) = v (y ^ 2) :=
+      v.map_add_eq_of_lt_left (v.map_add_lt ht2 ht3)
+    rw [hdom, hy2] at hLHS
+    exact absurd (WithZero.exp_inj.mp hLHS) (by omega)
+
+end PoleDichotomy
+
+theorem solution
+    (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+    {K : Type*} [Field K] [Algebra R K] [IsFractionRing R K]
+    (W : WeierstrassCurve K) [W.IsIntegral R] {x y : K} (h : W.toAffine.Equation x y)
+    (hx : ¬ IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R)
+      x ≤ 1) :
+    ∃ s : ℕ, 0 < s ∧
+      IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R) x =
+        WithZero.exp (2 * (s : ℤ)) ∧
+      IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R) y =
+        WithZero.exp (3 * (s : ℤ)) :=
+  PoleDichotomy.valuation_dichotomy R W h hx
+
+end S_WeierstrassCurve_exists_valuation_eq_exp_of_not_le_one
+end P2MW
+export P2MW.S_WeierstrassCurve_exists_valuation_eq_exp_of_not_le_one (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.exists_valuation_eq_exp_of_not_le_one
+    (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+    {K : Type*} [Field K] [Algebra R K] [IsFractionRing R K]
+    (W : WeierstrassCurve K) [W.IsIntegral R] {x y : K} (h : W.toAffine.Equation x y)
+    (hx : ¬ IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R)
+      x ≤ 1) :
+    ∃ s : ℕ, 0 < s ∧
+      IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R) x =
+        WithZero.exp (2 * (s : ℤ)) ∧
+      IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R) y =
+        WithZero.exp (3 * (s : ℤ)) :=
+  solution R W h hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_velu2FunctionFieldHom_restrictAlong_placeOfPoint_veluPointMap2.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_velu2FunctionFieldHom_restrictAlong_placeOfPoint_veluPointMap2.lean
new file mode 100644
index 0000000000..7daa1963c1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_velu2FunctionFieldHom_restrictAlong_placeOfPoint_veluPointMap2.lean
@@ -0,0 +1,754 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.exists_velu2FunctionFieldHom_restrictAlong_placeOfPoint_veluPointMap2
+(b73ed81b-39ad-56ed-892a-17f591c0295e) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6fe9cd27-d100-525e-9614-ff8b526979ae
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Correspondence
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluPointMap2
+
+import Mathlib.Algebra.Order.Ring.Star
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FunctionFieldQuadratic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_eq_placeOfPoint_some_of_XClass_mem_nonunits_of_YClass_mem_nonunits
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_veluGx_ne_zero_of_two_torsion
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Vélu's 2-isogeny: function-field embedding matching places
+
+Theorem statement:
+`WeierstrassCurve.exists_velu2FunctionFieldHom_restrictAlong_placeOfPoint_veluPointMap2`
+(`b73ed81b-39ad-56ed-892a-17f591c0295e`), by Claude, 2026-09-05.
+
+Proof: submission `6fe9cd27-d100-525e-9614-ff8b526979ae`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field of characteristic zero and $W$ a Weierstrass curve over $F$
+that is elliptic. Let $x_0,y_0\in F$ satisfy the affine Weierstrass equation of $W$ and
+$W.\mathrm{veluGy}(x_0,y_0)=-(2y_0+a_1x_0+a_3)=0$, so that $(x_0,y_0)$ is a point of order two. Let
+$W'=W.\mathrm{veluQuotient2}(x_0,y_0)$ be the Weierstrass curve with the same $a_1,a_2,a_3$ and with
+$a_4'=a_4-5t$, $a_6'=a_6-b_2t-7x_0t$, where $t=W.\mathrm{veluGx}(x_0,y_0)$; assume its discriminant
+is nonzero and that it is elliptic. Assume further, for both $W$ and $W'$ in their affine form, a
+`GenusOnePlaceGate` (a bijection between the point group and the places of the function field over
+$F$, all of degree one), its `IsCentred` refinement (for every nonsingular affine point the images
+of the classes of $X-x$ and $Y-y$ in the function field are nonunits in the valuation subring of the
+associated place), and the `AbelTheorem` property (a divisor of degree zero is principal exactly
+when its divisor sum vanishes). Then there exists an $F$-algebra homomorphism $\iota$ from the
+function field of $W'$ to that of $W$ whose underlying ring map is integral and along which the
+function field of $W$ is a finite module, such that for every $P\in W(F)$ the place attached to $P$,
+pulled back along $\iota$ (comap of its valuation subring), is the place attached to
+$\mathrm{veluPointMap2}(P)$, the map sending $O$ and the points with $x=x_0$ to $O$ and any other
+affine point to its explicit Vélu image. The assertion is purely existential: no formula for $\iota$
+appears in the conclusion.
+
+This is the order-two case of Vélu's explicit isogeny formulas, recast as the statement that the
+quotient of $W$ by $\{O,(x_0,y_0)\}$ is realised by an embedding of function fields under which the
+place–point dictionaries of the two curves correspond to Vélu's map on points. It is the
+parity-specific companion of the odd-degree construction, and is used in the treatment of roots of
+the modular equation and in the construction of quotients by a full kernel.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_exists_velu2FunctionFieldHom_restrictAlong_placeOfPoint_veluPointMap2.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_6938b70c
+
+open Polynomial AlgebraicCurve
+open scoped Polynomial.Bivariate
+
+namespace Velu2FFPort
+
+p2m_open "WeierstrassCurve \
+  WeierstrassCurve.Affine~valuation_algebraMap_eq_one~valuation_algebraMap_le_one \
+  WeierstrassCurve.Affine.CoordinateRing~isIntegral"
+
+variable {F : Type*} [Field F]
+
+theorem mem_nonunits_comap_iff {K L : Type*} [Field K] [Field L] (A : ValuationSubring L)
+    (f : K →+* L) (x : K) : x ∈ (A.comap f).nonunits ↔ f x ∈ A.nonunits := by
+  rw [ValuationSubring.mem_nonunits_iff_or, ValuationSubring.mem_nonunits_iff_or,
+    ValuationSubring.mem_comap, map_inv₀, map_eq_zero]
+
+section generic
+
+variable (W : Affine F)
+
+noncomputable abbrev xK : W.FunctionField := polyToFunctionField W X
+
+noncomputable abbrev yK : W.FunctionField := yCoord W
+
+theorem algebraMap_polynomial_coordinateRing (p : F[X]) :
+    algebraMap F[X] W.CoordinateRing p = CoordinateRing.mk W (C p) := rfl
+
+theorem xK_eq : xK W = algebraMap W.CoordinateRing W.FunctionField
+    (CoordinateRing.mk W (C X)) := rfl
+
+theorem algebraMap_XClass (x : F) :
+    algebraMap W.CoordinateRing W.FunctionField (XClass W x)
+      = xK W - algebraMap F W.FunctionField x := by
+  rw [XClass, ← algebraMap_polynomial_coordinateRing, ← polyToFunctionField_apply, map_sub,
+    polyToFunctionField_C]
+
+theorem algebraMap_YClass (y : F) :
+    algebraMap W.CoordinateRing W.FunctionField (YClass W (C y))
+      = yK W - algebraMap F W.FunctionField y := by
+  rw [YClass, map_sub, map_sub, ← algebraMap_polynomial_coordinateRing,
+    ← polyToFunctionField_apply, polyToFunctionField_C]
+  rfl
+
+theorem equation_generic :
+    (W.map (algebraMap F W.FunctionField)).toAffine.Equation (xK W) (yK W) := by
+  rw [WeierstrassCurve.Affine.equation_iff]
+  simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+    WeierstrassCurve.map_a₄, WeierstrassCurve.map_a₆]
+  have h := yCoord_relation (W := W)
+  simp only [map_add, map_mul, map_pow, polyToFunctionField_C] at h
+  change yK W * yK W = _ at h
+  linear_combination h
+
+end generic
+
+section restrict
+
+variable {K K' : Type*} [Field K] [Field K'] [Algebra F K] [Algebra F K']
+
+theorem restrictAlong_toValuationSubring (ι : K' →ₐ[F] K) (hι : ι.toRingHom.IsIntegral)
+    (v : Place F K) :
+    (v.restrictAlong ι hι).toValuationSubring = v.toValuationSubring.comap ι.toRingHom := rfl
+
+theorem mem_nonunits_restrictAlong_iff (ι : K' →ₐ[F] K) (hι : ι.toRingHom.IsIntegral)
+    (v : Place F K) (f : K') :
+    f ∈ (v.restrictAlong ι hι).toValuationSubring.nonunits ↔
+      ι f ∈ v.toValuationSubring.nonunits :=
+  mem_nonunits_comap_iff _ _ _
+
+theorem mem_restrictAlong_iff (ι : K' →ₐ[F] K) (hι : ι.toRingHom.IsIntegral)
+    (v : Place F K) (f : K') :
+    f ∈ (v.restrictAlong ι hι).toValuationSubring ↔ ι f ∈ v.toValuationSubring := Iff.rfl
+
+end restrict
+
+section places
+
+variable {K : Type*} [Field K] [Algebra F K]
+
+private theorem _root_.Velu2FFPort.algebraMap_mem (v : Place F K) (a : F) :
+    algebraMap F K a ∈ v.toValuationSubring :=
+  v.algebraMap_mem' a
+
+p2m_export "Velu2FFPort" "algebraMap_mem"
+theorem valuation_algebraMap_le_one (v : Place F K) (a : F) :
+    v.toValuationSubring.valuation (algebraMap F K a) ≤ 1 :=
+  (v.toValuationSubring.valuation_le_one_iff _).mpr (algebraMap_mem v a)
+
+theorem valuation_algebraMap_eq_one (v : Place F K) {a : F} (ha : a ≠ 0) :
+    v.toValuationSubring.valuation (algebraMap F K a) = 1 := by
+  apply le_antisymm (valuation_algebraMap_le_one v a)
+  have h := valuation_algebraMap_le_one v a⁻¹
+  rw [map_inv₀, map_inv₀] at h
+  have h0 : 0 < v.toValuationSubring.valuation (algebraMap F K a) := by
+    rw [zero_lt_iff, Valuation.ne_zero_iff]
+    exact (_root_.map_ne_zero _).mpr ha
+  exact (inv_le_one₀ h0).mp h
+
+end places
+
+section maps
+
+variable {R S : Type*} [CommRing R] [CommRing S] (W : WeierstrassCurve R) (f : R →+* S)
+
+theorem map_veluGx (x y : R) : (W.map f).veluGx (f x) (f y) = f (W.veluGx x y) := by
+  simp only [veluGx, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂,
+    WeierstrassCurve.map_a₄, map_sub, map_add, map_mul, map_pow, map_ofNat]
+
+theorem map_veluGy (x y : R) : (W.map f).veluGy (f x) (f y) = f (W.veluGy x y) := by
+  simp only [veluGy, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₃, map_neg, map_add,
+    map_mul, map_ofNat]
+
+theorem map_veluQuotient2 (x₀ y₀ : R) :
+    (W.map f).veluQuotient2 (f x₀) (f y₀) = (W.veluQuotient2 x₀ y₀).map f := by
+  ext <;> simp only [veluQuotient2, WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂,
+    WeierstrassCurve.map_a₃, WeierstrassCurve.map_a₄, WeierstrassCurve.map_a₆, map_veluGx,
+    WeierstrassCurve.map_b₂, map_sub, map_mul, map_ofNat]
+
+end maps
+
+section velufun
+
+variable (W : WeierstrassCurve F) (x₀ y₀ : F)
+
+noncomputable def ξ : W.toAffine.FunctionField :=
+  xK W.toAffine + algebraMap F _ (W.veluGx x₀ y₀) / (xK W.toAffine - algebraMap F _ x₀)
+
+noncomputable def η : W.toAffine.FunctionField :=
+  yK W.toAffine - algebraMap F _ (W.veluGx x₀ y₀)
+    * (algebraMap F _ W.a₁ * (xK W.toAffine - algebraMap F _ x₀) + yK W.toAffine
+        - algebraMap F _ y₀) / (xK W.toAffine - algebraMap F _ x₀) ^ 2
+
+theorem xK_sub_algebraMap (x : F) :
+    xK W.toAffine - algebraMap F _ x = polyToFunctionField W.toAffine (X - C x) := by
+  rw [map_sub, polyToFunctionField_C]
+
+theorem xK_sub_algebraMap_ne_zero (x : F) : xK W.toAffine - algebraMap F _ x ≠ 0 := by
+  rw [xK_sub_algebraMap]
+  exact polyToFunctionField_ne_zero (X_sub_C_ne_zero x)
+
+theorem xK_ne_algebraMap (x : F) : xK W.toAffine ≠ algebraMap F _ x :=
+  sub_ne_zero.mp (xK_sub_algebraMap_ne_zero W x)
+
+theorem velu2X_map_generic :
+    (W.map (algebraMap F W.toAffine.FunctionField)).velu2X (algebraMap F _ x₀)
+      (algebraMap F _ y₀) (xK W.toAffine) = ξ W x₀ y₀ := by
+  rw [velu2X, map_veluGx]; rfl
+
+theorem velu2Y_map_generic :
+    (W.map (algebraMap F W.toAffine.FunctionField)).velu2Y (algebraMap F _ x₀)
+      (algebraMap F _ y₀) (xK W.toAffine) (yK W.toAffine) = η W x₀ y₀ := by
+  rw [velu2Y, map_veluGx, WeierstrassCurve.map_a₁]; rfl
+
+variable {W x₀ y₀}
+variable [CharZero F] (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0)
+
+include hQ hgy in
+theorem equation_map_veluQuotient2_ξ_η :
+    ((W.veluQuotient2 x₀ y₀).map (algebraMap F W.toAffine.FunctionField)).toAffine.Equation
+      (ξ W x₀ y₀) (η W x₀ y₀) := by
+  have : CharZero W.toAffine.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap F W.toAffine.FunctionField).injective
+  rw [← map_veluQuotient2, ← velu2X_map_generic, ← velu2Y_map_generic]
+  refine (W.map (algebraMap F W.toAffine.FunctionField)).velu2_map_equation two_ne_zero
+    (equation_generic W.toAffine) (Equation.map _ hQ) ?_ (xK_ne_algebraMap W x₀)
+  rw [map_veluGy, hgy, map_zero]
+
+include hQ hgy in
+theorem eval₂_polynomial_ξ_η :
+    ((W.veluQuotient2 x₀ y₀).toAffine.polynomial).eval₂
+      ((Polynomial.aeval (ξ W x₀ y₀) : F[X] →ₐ[F] W.toAffine.FunctionField) :
+        F[X] →+* W.toAffine.FunctionField)
+      (η W x₀ y₀) = 0 := by
+  have heq := equation_map_veluQuotient2_ξ_η hQ hgy
+  rw [equation_iff'] at heq
+  simp only [WeierstrassCurve.map_a₁, WeierstrassCurve.map_a₂, WeierstrassCurve.map_a₃,
+    WeierstrassCurve.map_a₄, WeierstrassCurve.map_a₆] at heq
+  simp only [WeierstrassCurve.Affine.polynomial, eval₂_add, eval₂_sub, eval₂_mul, eval₂_pow,
+    eval₂_X, eval₂_C, RingHom.coe_coe, map_add, map_mul, map_pow,
+    Polynomial.aeval_C, Polynomial.aeval_X]
+  linear_combination heq
+
+end velufun
+
+section transcendence
+
+universe u
+
+variable {F : Type u} [Field F] [IsAlgClosed F]
+variable {W : WeierstrassCurve F} [W.IsElliptic] {x₀ y₀ : F}
+variable [GenusOnePlaceGate W.toAffine] [GenusOnePlaceGate.IsCentred W.toAffine]
+
+theorem xK_notMem_placeOfPoint_zero :
+    xK W.toAffine ∉ (placeOfPoint (0 : W.toAffine.Point)).toValuationSubring := by
+  classical
+  exact
+    algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero
+
+theorem corr_mem_placeOfPoint_zero (x₀ y₀ : F) :
+    algebraMap F _ (W.veluGx x₀ y₀) / (xK W.toAffine - algebraMap F _ x₀)
+      ∈ (placeOfPoint (0 : W.toAffine.Point)).toValuationSubring := by
+  classical
+  set O := (placeOfPoint (0 : W.toAffine.Point)).toValuationSubring
+  have hx : xK W.toAffine ∉ O := xK_notMem_placeOfPoint_zero
+  rw [← O.valuation_le_one_iff] at hx ⊢
+  rw [not_le] at hx
+  have hsub : O.valuation (xK W.toAffine - algebraMap F _ x₀) = O.valuation (xK W.toAffine) :=
+    Valuation.map_sub_eq_of_lt_left _
+      (lt_of_le_of_lt (valuation_algebraMap_le_one _ x₀) hx)
+  rw [map_div₀, hsub, div_le_one₀ (lt_trans zero_lt_one hx)]
+  exact le_trans (valuation_algebraMap_le_one (placeOfPoint (0 : W.toAffine.Point)) _) hx.le
+
+theorem ξ_notMem_placeOfPoint_zero (x₀ y₀ : F) :
+    ξ W x₀ y₀ ∉ (placeOfPoint (0 : W.toAffine.Point)).toValuationSubring := by
+  classical
+  intro h
+  apply xK_notMem_placeOfPoint_zero (W := W)
+  have := sub_mem h (corr_mem_placeOfPoint_zero (W := W) x₀ y₀)
+  rwa [ξ, add_sub_cancel_right] at this
+
+theorem transcendental_ξ (x₀ y₀ : F) : Transcendental F (ξ W x₀ y₀) := by
+  classical
+  intro halg
+  have hint : IsIntegral F (ξ W x₀ y₀) := halg.isIntegral
+  have hdeg : (minpoly F (ξ W x₀ y₀)).degree = 1 :=
+    IsAlgClosed.degree_eq_one_of_irreducible F (minpoly.irreducible hint)
+  obtain ⟨c, hc⟩ := minpoly.degree_eq_one_iff.mp hdeg
+  refine ξ_notMem_placeOfPoint_zero (W := W) x₀ y₀ ?_
+  rw [← hc]
+  exact algebraMap_mem _ c
+
+theorem aeval_ξ_injective (x₀ y₀ : F) :
+    Function.Injective (Polynomial.aeval (R := F) (ξ W x₀ y₀)) := by
+  classical
+  exact
+    (injective_iff_map_eq_zero _).mpr fun p hp =>
+      transcendental_iff.mp (transcendental_ξ (W := W) x₀ y₀) p hp
+
+end transcendence
+
+section inclusion
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : WeierstrassCurve F} [W.IsElliptic] {x₀ y₀ : F}
+variable [GenusOnePlaceGate W.toAffine] [GenusOnePlaceGate.IsCentred W.toAffine]
+variable (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0)
+
+noncomputable def coordHom :
+    (W.veluQuotient2 x₀ y₀).toAffine.CoordinateRing →ₐ[F] W.toAffine.FunctionField :=
+  AdjoinRoot.liftAlgHom _ (Polynomial.aeval (ξ W x₀ y₀)) (η W x₀ y₀)
+    (eval₂_polynomial_ξ_η hQ hgy)
+
+omit [DecidableEq F] [IsAlgClosed F] [W.IsElliptic] [GenusOnePlaceGate W.toAffine]
+  [GenusOnePlaceGate.IsCentred W.toAffine] in
+theorem coordHom_mk (g : F[X][Y]) :
+    coordHom hQ hgy (CoordinateRing.mk _ g)
+      = g.eval₂ ((Polynomial.aeval (ξ W x₀ y₀) : F[X] →ₐ[F] W.toAffine.FunctionField) :
+          F[X] →+* W.toAffine.FunctionField) (η W x₀ y₀) :=
+  AdjoinRoot.liftAlgHom_mk _ _ _ _ g
+
+omit [DecidableEq F] [IsAlgClosed F] [W.IsElliptic] [GenusOnePlaceGate W.toAffine]
+  [GenusOnePlaceGate.IsCentred W.toAffine] in
+theorem coordHom_comp_algebraMap :
+    (coordHom hQ hgy).toRingHom.comp
+        (algebraMap F[X] (W.veluQuotient2 x₀ y₀).toAffine.CoordinateRing)
+      = ((Polynomial.aeval (ξ W x₀ y₀) : F[X] →ₐ[F] W.toAffine.FunctionField) :
+          F[X] →+* W.toAffine.FunctionField) := by
+  refine RingHom.ext fun p => ?_
+  change coordHom hQ hgy (algebraMap F[X] _ p) = _
+  rw [algebraMap_polynomial_coordinateRing, coordHom_mk, eval₂_C]
+
+omit [DecidableEq F] in
+theorem coordHom_injective : Function.Injective (coordHom hQ hgy) := by
+  classical
+  have hker : RingHom.ker (coordHom hQ hgy).toRingHom = ⊥ := by
+    have : Module.Finite F[X] (W.veluQuotient2 x₀ y₀).toAffine.CoordinateRing :=
+      Module.Finite.of_basis (CoordinateRing.basis (W.veluQuotient2 x₀ y₀).toAffine)
+    refine Ideal.eq_bot_of_under_eq_bot (R := F[X]) ?_
+    rw [Ideal.under_def, RingHom.comap_ker, coordHom_comp_algebraMap,
+      ← RingHom.injective_iff_ker_eq_bot]
+    exact aeval_ξ_injective (W := W) x₀ y₀
+  exact (RingHom.injective_iff_ker_eq_bot (coordHom hQ hgy).toRingHom).mpr hker
+
+noncomputable def ffHom :
+    (W.veluQuotient2 x₀ y₀).toAffine.FunctionField →ₐ[F] W.toAffine.FunctionField :=
+  IsFractionRing.liftAlgHom (coordHom_injective hQ hgy)
+
+omit [DecidableEq F] in
+theorem ffHom_algebraMap (r : (W.veluQuotient2 x₀ y₀).toAffine.CoordinateRing) :
+    ffHom hQ hgy (algebraMap _ (W.veluQuotient2 x₀ y₀).toAffine.FunctionField r)
+      = coordHom hQ hgy r := by
+  classical
+  exact
+    IsFractionRing.lift_algebraMap (coordHom_injective hQ hgy) r
+
+omit [DecidableEq F] in
+theorem ffHom_polyToFunctionField (p : F[X]) :
+    ffHom hQ hgy (polyToFunctionField (W.veluQuotient2 x₀ y₀).toAffine p)
+      = Polynomial.aeval (ξ W x₀ y₀) p := by
+  classical
+  rw [polyToFunctionField_apply, ffHom_algebraMap, algebraMap_polynomial_coordinateRing,
+    coordHom_mk, eval₂_C, RingHom.coe_coe]
+
+omit [DecidableEq F] in
+theorem ffHom_xK : ffHom hQ hgy (xK (W.veluQuotient2 x₀ y₀).toAffine) = ξ W x₀ y₀ := by
+  classical
+  rw [xK, ffHom_polyToFunctionField, aeval_X]
+
+omit [DecidableEq F] in
+theorem ffHom_yK : ffHom hQ hgy (yK (W.veluQuotient2 x₀ y₀).toAffine) = η W x₀ y₀ := by
+  classical
+  change ffHom hQ hgy (algebraMap _ _ (CoordinateRing.mk _ Y)) = _
+  rw [ffHom_algebraMap, coordHom_mk, eval₂_X]
+
+omit [DecidableEq F] in
+theorem ffHom_XClass (x : F) :
+    ffHom hQ hgy (algebraMap _ (W.veluQuotient2 x₀ y₀).toAffine.FunctionField
+        (XClass (W.veluQuotient2 x₀ y₀).toAffine x))
+      = ξ W x₀ y₀ - algebraMap F _ x := by
+  classical
+  rw [algebraMap_XClass, map_sub, ffHom_xK, AlgHom.commutes]
+
+omit [DecidableEq F] in
+theorem ffHom_YClass (y : F) :
+    ffHom hQ hgy (algebraMap _ (W.veluQuotient2 x₀ y₀).toAffine.FunctionField
+        (YClass (W.veluQuotient2 x₀ y₀).toAffine (C y)))
+      = η W x₀ y₀ - algebraMap F _ y := by
+  classical
+  rw [algebraMap_YClass, map_sub, ffHom_yK, AlgHom.commutes]
+
+omit [DecidableEq F] in
+theorem adjoin_xK_eq_top :
+    letI := algebraAlong (ffHom hQ hgy)
+    IntermediateField.adjoin (W.veluQuotient2 x₀ y₀).toAffine.FunctionField
+      {xK W.toAffine} = ⊤ := by
+  classical
+  let := algebraAlong (ffHom hQ hgy)
+  set K' := (W.veluQuotient2 x₀ y₀).toAffine.FunctionField
+  have halg : ∀ z : K', algebraMap K' W.toAffine.FunctionField z = ffHom hQ hgy z :=
+    fun _ => rfl
+  rw [eq_top_iff]
+  rintro z -
+  set L := IntermediateField.adjoin K' {xK W.toAffine} with hL
+  have hconst : ∀ c : F, algebraMap F W.toAffine.FunctionField c ∈ L := fun c => by
+    rw [← (ffHom hQ hgy).commutes c, ← halg]
+    exact L.algebraMap_mem _
+  have hxmem : xK W.toAffine ∈ L := IntermediateField.mem_adjoin_simple_self _ _
+  have hpoly : ∀ p : F[X], polyToFunctionField W.toAffine p ∈ L := fun p => by
+    induction p using Polynomial.induction_on' with
+    | add f g hf hg => rw [map_add]; exact add_mem hf hg
+    | monomial n c =>
+        rw [← C_mul_X_pow_eq_monomial, map_mul, map_pow, polyToFunctionField_C]
+        exact mul_mem (hconst c) (pow_mem hxmem n)
+  have hηmem : η W x₀ y₀ ∈ L := by
+    rw [← ffHom_yK hQ hgy, ← halg]
+    exact L.algebraMap_mem _
+  have hd : xK W.toAffine - algebraMap F _ x₀ ≠ 0 := xK_sub_algebraMap_ne_zero W x₀
+  have hden : (xK W.toAffine - algebraMap F _ x₀) ^ 2 - algebraMap F _ (W.veluGx x₀ y₀) ≠ 0 := by
+    rw [xK_sub_algebraMap, ← map_pow, ← polyToFunctionField_C, ← map_sub]
+    refine polyToFunctionField_ne_zero fun h0 => ?_
+    have h1 := congrArg Polynomial.natDegree h0
+    rw [Polynomial.natDegree_sub_C, Polynomial.natDegree_pow, Polynomial.natDegree_X_sub_C,
+      Polynomial.natDegree_zero] at h1
+    exact absurd h1 (by norm_num)
+  have hymem : yK W.toAffine ∈ L := by
+    have hkey : yK W.toAffine
+        = (η W x₀ y₀ * (xK W.toAffine - algebraMap F _ x₀) ^ 2
+            + algebraMap F _ (W.veluGx x₀ y₀)
+              * (algebraMap F _ W.a₁ * (xK W.toAffine - algebraMap F _ x₀)
+                - algebraMap F _ y₀))
+          / ((xK W.toAffine - algebraMap F _ x₀) ^ 2 - algebraMap F _ (W.veluGx x₀ y₀)) := by
+      rw [eq_div_iff hden, η]
+      field_simp
+      ring
+    rw [hkey]
+    refine div_mem (add_mem (mul_mem hηmem (pow_mem (sub_mem hxmem (hconst _)) 2))
+      (mul_mem (hconst _) (sub_mem (mul_mem (hconst _) (sub_mem hxmem (hconst _)))
+        (hconst _)))) (sub_mem (pow_mem (sub_mem hxmem (hconst _)) 2) (hconst _))
+  have hcr : ∀ r : W.toAffine.CoordinateRing,
+      algebraMap W.toAffine.CoordinateRing W.toAffine.FunctionField r ∈ L := fun r => by
+    obtain ⟨p, q, rfl⟩ := exists_smul_basis_eq r
+    rw [algebraMap_smul_basis]
+    exact add_mem (hpoly p) (mul_mem (hpoly q) hymem)
+  obtain ⟨a, b, _, hab⟩ := IsFractionRing.div_surjective (A := W.toAffine.CoordinateRing) z
+  rw [← hab]
+  exact div_mem (hcr a) (hcr b)
+
+omit [DecidableEq F] in
+theorem isIntegral_xK :
+    letI := algebraAlong (ffHom hQ hgy)
+    IsIntegral (W.veluQuotient2 x₀ y₀).toAffine.FunctionField (xK W.toAffine) := by
+  classical
+  set K' := (W.veluQuotient2 x₀ y₀).toAffine.FunctionField
+  have hcomm : ∀ a : F, ffHom hQ hgy (algebraMap F K' a) = algebraMap F _ a :=
+    fun a => (ffHom hQ hgy).commutes a
+  refine ⟨X ^ 2 - C (xK (W.veluQuotient2 x₀ y₀).toAffine + algebraMap F K' x₀) * X
+      + C (algebraMap F K' x₀ * xK (W.veluQuotient2 x₀ y₀).toAffine
+          + algebraMap F K' (W.veluGx x₀ y₀)), by monicity!, ?_⟩
+  change Polynomial.eval₂ (ffHom hQ hgy).toRingHom (xK W.toAffine) _ = 0
+  simp only [eval₂_add, eval₂_sub, eval₂_mul, eval₂_pow, eval₂_X, eval₂_C,
+    AlgHom.toRingHom_eq_coe, RingHom.coe_coe, map_add, map_mul, ffHom_xK, hcomm]
+  have hd : xK W.toAffine - algebraMap F _ x₀ ≠ 0 := xK_sub_algebraMap_ne_zero W x₀
+  rw [ξ]
+  field_simp
+  ring
+
+omit [DecidableEq F] in
+theorem finiteAlong_ffHom : FiniteAlong F (ffHom hQ hgy) := by
+  classical
+  let := algebraAlong (ffHom hQ hgy)
+  change Module.Finite (W.veluQuotient2 x₀ y₀).toAffine.FunctionField W.toAffine.FunctionField
+  have h1 := IntermediateField.adjoin.finiteDimensional (isIntegral_xK hQ hgy)
+  rw [adjoin_xK_eq_top hQ hgy] at h1
+  exact (IntermediateField.topEquiv
+    (F := (W.veluQuotient2 x₀ y₀).toAffine.FunctionField)
+    (E := W.toAffine.FunctionField)).toLinearEquiv.finiteDimensional
+
+omit [DecidableEq F] in
+theorem isIntegral_ffHom : (ffHom hQ hgy).toRingHom.IsIntegral := by
+  classical
+  let := algebraAlong (ffHom hQ hgy)
+  have : Module.Finite (W.veluQuotient2 x₀ y₀).toAffine.FunctionField
+      W.toAffine.FunctionField := finiteAlong_ffHom hQ hgy
+  have h : Algebra.IsIntegral (W.veluQuotient2 x₀ y₀).toAffine.FunctionField
+      W.toAffine.FunctionField := Algebra.IsIntegral.of_finite _ _
+  exact fun z => h.isIntegral z
+
+end inclusion
+
+section valuation_helpers
+
+variable {K : Type*} [Field K] (O : ValuationSubring K)
+
+theorem val_mul_lt_one_of_le_of_lt {a b : K} (ha : O.valuation a ≤ 1) (hb : O.valuation b < 1) :
+    O.valuation (a * b) < 1 :=
+  calc O.valuation (a * b) = O.valuation a * O.valuation b := map_mul _ _ _
+    _ ≤ 1 * O.valuation b := mul_le_mul' ha le_rfl
+    _ = O.valuation b := one_mul _
+    _ < 1 := hb
+
+theorem val_mul_lt_one_of_lt_of_le {a b : K} (ha : O.valuation a < 1) (hb : O.valuation b ≤ 1) :
+    O.valuation (a * b) < 1 := by
+  rw [mul_comm]; exact val_mul_lt_one_of_le_of_lt O hb ha
+
+theorem mem_of_val_lt_one {a : K} (ha : O.valuation a < 1) : a ∈ O :=
+  (O.valuation_le_one_iff a).mp ha.le
+
+end valuation_helpers
+
+section identities
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F) (x₀ y₀ : F)
+
+theorem ξ_sub_algebraMap_velu2X {x : F} (hx : x ≠ x₀) :
+    ξ W x₀ y₀ - algebraMap F _ (W.velu2X x₀ y₀ x)
+      = (xK W.toAffine - algebraMap F _ x)
+        * (1 - algebraMap F _ (W.veluGx x₀ y₀)
+            / ((xK W.toAffine - algebraMap F _ x₀) * algebraMap F _ (x - x₀))) := by
+  have hB : xK W.toAffine - algebraMap F _ x₀ ≠ 0 := xK_sub_algebraMap_ne_zero W x₀
+  have hB0 : algebraMap F W.toAffine.FunctionField (x - x₀) ≠ 0 :=
+    (_root_.map_ne_zero _).mpr (sub_ne_zero.mpr hx)
+  rw [map_sub] at hB0 ⊢
+  rw [ξ, velu2X, map_add, map_div₀, map_sub]
+  field_simp
+  ring
+
+theorem η_sub_algebraMap_velu2Y {x : F} (y : F) (hx : x ≠ x₀) :
+    η W x₀ y₀ - algebraMap F _ (W.velu2Y x₀ y₀ x y)
+      = (yK W.toAffine - algebraMap F _ y)
+        - algebraMap F _ (W.veluGx x₀ y₀)
+          * ((algebraMap F _ W.a₁ * (xK W.toAffine - algebraMap F _ x)
+                + (yK W.toAffine - algebraMap F _ y)) * algebraMap F _ (x - x₀) ^ 2
+              - algebraMap F _ (W.a₁ * (x - x₀) + y - y₀)
+                * (xK W.toAffine - algebraMap F _ x)
+                * ((xK W.toAffine - algebraMap F _ x₀) + algebraMap F _ (x - x₀)))
+          / ((xK W.toAffine - algebraMap F _ x₀) ^ 2 * algebraMap F _ (x - x₀) ^ 2) := by
+  have hB : xK W.toAffine - algebraMap F _ x₀ ≠ 0 := xK_sub_algebraMap_ne_zero W x₀
+  have hB0 : algebraMap F W.toAffine.FunctionField (x - x₀) ≠ 0 :=
+    (_root_.map_ne_zero _).mpr (sub_ne_zero.mpr hx)
+  rw [map_sub] at hB0
+  simp only [η, velu2Y, map_sub, map_div₀, map_mul, map_add, map_pow]
+  field_simp
+  ring
+
+end identities
+
+section seam
+
+universe u
+
+variable {F : Type u} [Field F] [IsAlgClosed F] [CharZero F]
+variable {W : WeierstrassCurve F} [W.IsElliptic] {x₀ y₀ : F}
+variable [GenusOnePlaceGate W.toAffine] [GenusOnePlaceGate.IsCentred W.toAffine]
+variable (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0)
+
+omit [IsAlgClosed F] [CharZero F] [W.IsElliptic] in
+theorem val_xK_sub_lt_one {x y : F} (h : W.toAffine.Nonsingular x y) :
+    (placeOfPoint (Point.some x y h)).toValuationSubring.valuation
+      (xK W.toAffine - algebraMap F _ x) < 1 := by
+  rw [← ValuationSubring.mem_nonunits_iff, ← algebraMap_XClass]
+  exact GenusOnePlaceGate.IsCentred.algebraMap_XClass_mem_nonunits h
+
+omit [IsAlgClosed F] [CharZero F] [W.IsElliptic] in
+theorem val_yK_sub_lt_one {x y : F} (h : W.toAffine.Nonsingular x y) :
+    (placeOfPoint (Point.some x y h)).toValuationSubring.valuation
+      (yK W.toAffine - algebraMap F _ y) < 1 := by
+  rw [← ValuationSubring.mem_nonunits_iff, ← algebraMap_YClass]
+  exact GenusOnePlaceGate.IsCentred.algebraMap_YClass_mem_nonunits h
+
+variable [GenusOnePlaceGate (W.veluQuotient2 x₀ y₀).toAffine]
+variable [GenusOnePlaceGate.IsCentred (W.veluQuotient2 x₀ y₀).toAffine]
+
+theorem restrictAlong_eq_placeOfPoint_zero_of_notMem (v : Place F W.toAffine.FunctionField)
+    (hv : ξ W x₀ y₀ ∉ v.toValuationSubring) :
+    v.restrictAlong (ffHom hQ hgy) (isIntegral_ffHom hQ hgy)
+      = placeOfPoint (0 : (W.veluQuotient2 x₀ y₀).toAffine.Point) := by
+  classical
+  obtain ⟨P', hP'⟩ := (pointEquivPlace (W := (W.veluQuotient2 x₀ y₀).toAffine)).surjective
+    (v.restrictAlong (ffHom hQ hgy) (isIntegral_ffHom hQ hgy))
+  rw [pointEquivPlace_apply] at hP'
+  rcases P' with _ | ⟨x', y', h'⟩
+  · exact hP'.symm
+  · exfalso
+    apply hv
+    have hX := GenusOnePlaceGate.IsCentred.algebraMap_XClass_mem_nonunits h'
+    rw [hP', mem_nonunits_restrictAlong_iff, ffHom_XClass] at hX
+    have := add_mem (ValuationSubring.nonunits_subset hX) (algebraMap_mem v x')
+    rwa [sub_add_cancel] at this
+
+theorem restrictAlong_placeOfPoint_zero (h2 : (2 : F) ≠ 0)
+    (hΔ' : (W.veluQuotient2 x₀ y₀).Δ ≠ 0) :
+    (placeOfPoint (0 : W.toAffine.Point)).restrictAlong (ffHom hQ hgy) (isIntegral_ffHom hQ hgy)
+      = placeOfPoint (veluPointMap2 h2 hQ hgy hΔ' 0) := by
+  classical
+  exact
+    restrictAlong_eq_placeOfPoint_zero_of_notMem hQ hgy _ (ξ_notMem_placeOfPoint_zero x₀ y₀)
+
+theorem restrictAlong_placeOfPoint_some_of_eq (h2 : (2 : F) ≠ 0)
+    (hΔ' : (W.veluQuotient2 x₀ y₀).Δ ≠ 0) {x y : F} (h : W.toAffine.Nonsingular x y)
+    (hx : x = x₀) :
+    (placeOfPoint (Point.some x y h)).restrictAlong (ffHom hQ hgy) (isIntegral_ffHom hQ hgy)
+      = placeOfPoint (veluPointMap2 h2 hQ hgy hΔ' (Point.some x y h)) := by
+  classical
+  rw [veluPointMap2_some_of_eq h2 hQ hgy hΔ' h hx]
+  refine restrictAlong_eq_placeOfPoint_zero_of_notMem hQ hgy _ fun hξ => ?_
+  subst hx
+  set O := (placeOfPoint (Point.some x y h)).toValuationSubring with hO
+  have hB : O.valuation (xK W.toAffine - algebraMap F _ x) < 1 := val_xK_sub_lt_one h
+  have hB0 : xK W.toAffine - algebraMap F _ x ≠ 0 := xK_sub_algebraMap_ne_zero W x
+  have ht : W.veluGx x y₀ ≠ 0 := veluGx_ne_zero_of_two_torsion W.isUnit_Δ.ne_zero hQ hgy
+  have hxmem : xK W.toAffine ∈ O := by
+    have := add_mem (mem_of_val_lt_one O hB) (algebraMap_mem (placeOfPoint (Point.some x y h)) x)
+    rwa [sub_add_cancel] at this
+  have hu : algebraMap F _ (W.veluGx x y₀) / (xK W.toAffine - algebraMap F _ x) ∈ O := by
+    have := sub_mem hξ hxmem
+    rwa [ξ, add_sub_cancel_left] at this
+  rw [← O.valuation_le_one_iff, map_div₀, valuation_algebraMap_eq_one _ ht, one_div] at hu
+  have h0 : 0 < O.valuation (xK W.toAffine - algebraMap F _ x) := by
+    rw [zero_lt_iff, Valuation.ne_zero_iff]; exact hB0
+  exact absurd ((inv_le_one₀ h0).mp hu) (not_le.mpr hB)
+
+variable [(W.veluQuotient2 x₀ y₀).IsElliptic]
+
+theorem restrictAlong_placeOfPoint_some_of_ne (h2 : (2 : F) ≠ 0)
+    (hΔ' : (W.veluQuotient2 x₀ y₀).Δ ≠ 0) {x y : F} (h : W.toAffine.Nonsingular x y)
+    (hx : x ≠ x₀) :
+    (placeOfPoint (Point.some x y h)).restrictAlong (ffHom hQ hgy) (isIntegral_ffHom hQ hgy)
+      = placeOfPoint (veluPointMap2 h2 hQ hgy hΔ' (Point.some x y h)) := by
+  classical
+  have := CoordinateRing.isDedekindDomain (W.veluQuotient2 x₀ y₀)
+  rw [veluPointMap2_some_of_ne h2 hQ hgy hΔ' h hx]
+  set O := (placeOfPoint (Point.some x y h)).toValuationSubring with hO
+  have hX : O.valuation (xK W.toAffine - algebraMap F _ x) < 1 := val_xK_sub_lt_one h
+  have hY : O.valuation (yK W.toAffine - algebraMap F _ y) < 1 := val_yK_sub_lt_one h
+  have hc : ∀ a : F, O.valuation (algebraMap F _ a) ≤ 1 :=
+    fun a => valuation_algebraMap_le_one (placeOfPoint (Point.some x y h)) a
+  have hB0 : O.valuation (algebraMap F _ (x - x₀)) = 1 :=
+    valuation_algebraMap_eq_one (placeOfPoint (Point.some x y h)) (sub_ne_zero.mpr hx)
+  have hB : O.valuation (xK W.toAffine - algebraMap F _ x₀) = 1 := by
+    rw [show xK W.toAffine - algebraMap F _ x₀
+        = algebraMap F _ (x - x₀) + (xK W.toAffine - algebraMap F _ x) by
+          rw [map_sub]; ring]
+    rw [Valuation.map_add_eq_of_lt_left _ (by rwa [hB0]), hB0]
+  refine eq_placeOfPoint_some_of_XClass_mem_nonunits_of_YClass_mem_nonunits
+    (W := (W.veluQuotient2 x₀ y₀).toAffine)
+    (velu2_map_nonsingular h2 h.1 hQ hgy hx hΔ') _ ?_ ?_
+  · rw [mem_nonunits_restrictAlong_iff, ffHom_XClass, ValuationSubring.mem_nonunits_iff,
+      ξ_sub_algebraMap_velu2X W x₀ y₀ hx]
+    refine val_mul_lt_one_of_lt_of_le O hX (Valuation.map_sub_le _ (by rw [map_one]) ?_)
+    rw [map_div₀, map_mul, hB, hB0, one_mul, div_one]
+    exact hc _
+  · rw [mem_nonunits_restrictAlong_iff, ffHom_YClass, ValuationSubring.mem_nonunits_iff,
+      η_sub_algebraMap_velu2Y W x₀ y₀ y hx]
+    refine Valuation.map_sub_lt _ hY ?_
+    rw [map_div₀, map_mul, map_mul, map_pow, map_pow, hB, hB0, one_pow, one_mul, div_one]
+    refine val_mul_lt_one_of_le_of_lt O (hc _) (Valuation.map_sub_lt _ ?_ ?_)
+    · refine val_mul_lt_one_of_lt_of_le O (Valuation.map_add_lt _ ?_ hY) ?_
+      · exact val_mul_lt_one_of_le_of_lt O (hc _) hX
+      · rw [map_pow, hB0, one_pow]
+    · refine val_mul_lt_one_of_lt_of_le O (val_mul_lt_one_of_le_of_lt O (hc _) hX) ?_
+      exact Valuation.map_add_le _ hB.le hB0.le
+
+end seam
+
+theorem restrictAlong_placeOfPoint_veluPointMap2
+    {F : Type*} [Field F] [CharZero F] [IsAlgClosed F]
+    {W : WeierstrassCurve F} [W.IsElliptic]
+    {x₀ y₀ : F} (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0)
+    (hΔ' : (W.veluQuotient2 x₀ y₀).Δ ≠ 0)
+    [(W.veluQuotient2 x₀ y₀).IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (W.veluQuotient2 x₀ y₀).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W.veluQuotient2 x₀ y₀).toAffine]
+    (h2 : (2 : F) ≠ 0) (P : W.toAffine.Point) :
+    (placeOfPoint P).restrictAlong (ffHom hQ hgy) (isIntegral_ffHom hQ hgy)
+      = placeOfPoint (veluPointMap2 h2 hQ hgy hΔ' P) := by
+  classical
+  rcases P with _ | ⟨x, y, h⟩
+  · exact restrictAlong_placeOfPoint_zero hQ hgy h2 hΔ'
+  · by_cases hx : x = x₀
+    · exact restrictAlong_placeOfPoint_some_of_eq hQ hgy h2 hΔ' h hx
+    · exact restrictAlong_placeOfPoint_some_of_ne hQ hgy h2 hΔ' h hx
+
+end Velu2FFPort
+
+open Velu2FFPort in
+theorem solution
+    {F : Type*} [Field F] [DecidableEq F] [CharZero F] [IsAlgClosed F]
+    {W : WeierstrassCurve F} [W.IsElliptic]
+    {x₀ y₀ : F} (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0)
+    (hΔ' : (W.veluQuotient2 x₀ y₀).Δ ≠ 0)
+    [(W.veluQuotient2 x₀ y₀).IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W.toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (W.veluQuotient2 x₀ y₀).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W.veluQuotient2 x₀ y₀).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W.veluQuotient2 x₀ y₀).toAffine] :
+    ∃ (ι : (W.veluQuotient2 x₀ y₀).toAffine.FunctionField →ₐ[F] W.toAffine.FunctionField)
+      (hι : ι.toRingHom.IsIntegral) (_ : AlgebraicCurve.FiniteAlong F ι),
+      ∀ P : W.toAffine.Point,
+        (WeierstrassCurve.Affine.placeOfPoint P).restrictAlong ι hι
+          = WeierstrassCurve.Affine.placeOfPoint
+              (WeierstrassCurve.veluPointMap2 two_ne_zero hQ hgy hΔ' P) :=
+  ⟨ffHom hQ hgy, isIntegral_ffHom hQ hgy, finiteAlong_ffHom hQ hgy,
+    restrictAlong_placeOfPoint_veluPointMap2 hQ hgy hΔ' two_ne_zero⟩
+
+end S_OVERLONG_6938b70c
+end P2MW
+export P2MW.S_OVERLONG_6938b70c
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.exists_velu2FunctionFieldHom_restrictAlong_placeOfPoint_veluPointMap2
+    {F : Type*} [Field F] [DecidableEq F] [CharZero F] [IsAlgClosed F]
+    {W : WeierstrassCurve F} [W.IsElliptic]
+    {x₀ y₀ : F} (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0)
+    (hΔ' : (W.veluQuotient2 x₀ y₀).Δ ≠ 0)
+    [(W.veluQuotient2 x₀ y₀).IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W.toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate (W.veluQuotient2 x₀ y₀).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W.veluQuotient2 x₀ y₀).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem (W.veluQuotient2 x₀ y₀).toAffine] :
+    ∃ (ι : (W.veluQuotient2 x₀ y₀).toAffine.FunctionField →ₐ[F] W.toAffine.FunctionField)
+      (hι : ι.toRingHom.IsIntegral) (_hfin : AlgebraicCurve.FiniteAlong F ι),
+      ∀ P : W.toAffine.Point,
+        (WeierstrassCurve.Affine.placeOfPoint P).restrictAlong ι hι
+          = WeierstrassCurve.Affine.placeOfPoint
+              (WeierstrassCurve.veluPointMap2 two_ne_zero hQ hgy hΔ' P) :=
+  solution hQ hgy hΔ'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples.lean
new file mode 100644
index 0000000000..c730861c3c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples.lean
@@ -0,0 +1,130 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples
+(3190c933-3982-52e5-8936-df1e19a29d91) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 46f9692b-89dd-5871-a452-f75e3f8d68ea
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_OddOrderSummingSet
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_Velu
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_veluFunctionFieldHom_restrictAlong_placeOfPoint_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Vélu function-field embedding with point map of kernel ⟨ Q⟩
+
+Theorem statement:
+`WeierstrassCurve.exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples`
+(`3190c933-3982-52e5-8936-df1e19a29d91`), by Claude, 2026-09-05.
+
+Proof: submission `46f9692b-89dd-5871-a452-f75e3f8d68ea`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field of characteristic zero, $W$ a Weierstrass curve over $F$
+whose associated affine curve is elliptic, $Q$ a point of $W$ and $n$ a natural number with
+$\mathrm{addOrderOf}\,Q = 2n+1$. Write $S =$ `W.oddOrderSummingSet Q n` for the finite set of
+coordinate pairs of the multiples $k\cdot Q$, $1 \le k \le n$ (the point at infinity contributing
+$(0,0)$), and $W' =$ `W.veluQuotient S` for the Weierstrass curve with the same $a_1,a_2,a_3$ and
+with $a_4' = a_4 - 5\sum_{P\in S} t_P$, $a_6' = a_6 - b_2\sum_{P\in S} t_P - 7\sum_{P\in S} w_P$.
+Assume $\Delta(W') \ne 0$, that the affine curve of $W'$ is elliptic, and, for each of $W$ and $W'$:
+a `GenusOnePlaceGate`, i.e. a bijection between points and places of the function field over $F$
+with all places of degree one; its `IsCentred` property, that at the place attached to a nonsingular
+point $(x,y)$ both coordinate-ring classes $X-x$ and $Y-y$ are non-units of the valuation subring;
+and `AbelTheorem`, that a divisor of degree zero is principal exactly when the sum of its places,
+transported to points, vanishes. Then there is an $F$-algebra homomorphism $\iota$ from the function
+field of $W'$ to that of $W$, integral, making the function field of $W$ a finite module over that
+of $W'$ of rank $2n+1$, such that for every witness of the pushforward norm formula along $\iota$
+the resulting homomorphism `pointMapOfPushforward` from the points of $W$ to the points of $W'$
+(obtained by conjugating the $\mathrm{Pic}^0$-pushforward along $\iota$ by the genus-one
+identifications of $\mathrm{Pic}^0$ with the group of points) has kernel the subgroup
+$\mathbb{Z}\cdot Q$ of multiples of $Q$.
+
+This is the group-theoretic content of Vélu's construction: the quotient isogeny $W \to W/\langle
+Q\rangle$ of degree $2n+1$, realised here on function fields and on points via pushforward of
+degree-zero divisor classes. It is used in the comparison of $j$-invariants of $\ell$-isogenous
+curves, where the modular polynomial is shown to vanish on the pair $(j(W), j(W'))$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_88898e12
+
+theorem solution
+    {F : Type*} [Field F] [DecidableEq F] [CharZero F] [IsAlgClosed F]
+    {W : WeierstrassCurve F} [W.toAffine.IsElliptic]
+    {Q : W.toAffine.Point} {n : ℕ} (hord : addOrderOf Q = 2 * n + 1)
+    (hΔ' : (W.veluQuotient (W.oddOrderSummingSet Q n)).Δ ≠ 0)
+    [(W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W.toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine] :
+    ∃ (ι : (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.FunctionField
+            →ₐ[F] W.toAffine.FunctionField)
+      (hι : ι.toRingHom.IsIntegral) (hfin : AlgebraicCurve.FiniteAlong F ι),
+      AlgebraicCurve.finrankAlong F ι = 2 * n + 1
+        ∧ ∀ hN : AlgebraicCurve.NormFormulaAlong F ι hfin,
+            (WeierstrassCurve.Affine.pointMapOfPushforward ι hι hfin hN).ker
+              = AddSubgroup.zmultiples Q := by
+  obtain ⟨ι, hι, hfin, hrank, hker, _, _⟩ :=
+    WeierstrassCurve.exists_veluFunctionFieldHom_restrictAlong_placeOfPoint_eq hord hΔ'
+  exact ⟨ι, hι, hfin, hrank, hker⟩
+
+end S_OVERLONG_88898e12
+end P2MW
+export P2MW.S_OVERLONG_88898e12
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples
+    {F : Type*} [Field F] [DecidableEq F] [CharZero F] [IsAlgClosed F]
+    {W : WeierstrassCurve F} [W.toAffine.IsElliptic]
+    {Q : W.toAffine.Point} {n : ℕ} (hord : addOrderOf Q = 2 * n + 1)
+    (hΔ' : (W.veluQuotient (W.oddOrderSummingSet Q n)).Δ ≠ 0)
+    [(W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W.toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine] :
+    ∃ (ι : (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.FunctionField
+            →ₐ[F] W.toAffine.FunctionField)
+      (hι : ι.toRingHom.IsIntegral) (hfin : AlgebraicCurve.FiniteAlong F ι),
+      AlgebraicCurve.finrankAlong F ι = 2 * n + 1
+        ∧ ∀ hN : AlgebraicCurve.NormFormulaAlong F ι hfin,
+            (WeierstrassCurve.Affine.pointMapOfPushforward ι hι hfin hN).ker
+              = AddSubgroup.zmultiples Q :=
+  solution hord hΔ'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples_of_oddOrder.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples_of_oddOrder.lean
new file mode 100644
index 0000000000..eb93fc9b2e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples_of_oddOrder.lean
@@ -0,0 +1,135 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples_of_oddOrder
+(44f8253f-ac3c-5c57-a620-3d9729e4c128) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b68932ab-e88d-53e8-a00a-15658f5b95a9
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_OddOrderSummingSet
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_Velu
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_veluFunctionFieldHom_restrictAlong_placeOfPoint_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Vélu pushforward point map has kernel ℤQ
+
+Theorem statement:
+`WeierstrassCurve.exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples_of_oddOrder`
+(`44f8253f-ac3c-5c57-a620-3d9729e4c128`), by Claude, 2026-09-05.
+
+Proof: submission `b68932ab-e88d-53e8-a00a-15658f5b95a9`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field of characteristic $0$, let $W$ be a Weierstrass curve over
+$F$ whose associated affine curve is elliptic, let $Q$ be a point of
+$W.\mathrm{toAffine}.\mathrm{Point}$ and $n$ a natural number with $\mathrm{addOrderOf}\,Q = 2n+1$.
+Write $W'$ for `W.veluQuotient (W.oddOrderSummingSet Q n)`, the Weierstrass curve with the same
+$a_1,a_2,a_3$ and with $a_4$ and $a_6$ modified by Vélu's sums over the finite set of coordinate
+pairs of $Q, 2Q, \dots, nQ$; assume its discriminant $\Delta$ is nonzero and that its affine curve
+is elliptic. Assume further, for each of $W.\mathrm{toAffine}$ and $W'.\mathrm{toAffine}$: a
+`GenusOnePlaceGate`, i.e. a bijection between the point group and the places of the function field
+over $F$ together with the statement that every such place has degree $1$; that this gate is
+centred, i.e. for every nonsingular affine point $(x,y)$ the classes of $X-x$ and $Y-y$ in the
+function field are nonunits in the valuation subring of the corresponding place; and `AbelTheorem`,
+i.e. a degree-zero divisor is principal exactly when its divisor sum vanishes. Then there exist an
+$F$-algebra homomorphism $\iota$ from the function field of $W'.\mathrm{toAffine}$ to that of
+$W.\mathrm{toAffine}$, a proof that $\iota$ is integral as a ring homomorphism, and a proof that the
+target is a finite module over the source via $\iota$, such that for every witness of the
+pushforward norm formula along $\iota$ (the pushforward of the divisor of any nonzero $f$ has order
+$v(\mathrm{N}f)$ at each place $v$) the kernel of the induced additive map `pointMapOfPushforward`
+from $W.\mathrm{toAffine}.\mathrm{Point}$ to $W'.\mathrm{toAffine}.\mathrm{Point}$, obtained by
+transporting the $\mathrm{Pic}^0$-pushforward along $\iota$ through the genus-one identifications of
+points with $\mathrm{Pic}^0$, is exactly the subgroup of integer multiples of $Q$.
+
+This is the kernel half of Vélu's construction of the quotient isogeny $W \to W/\langle Q\rangle$
+for a point $Q$ of odd order, realised on function fields and transported to point groups through
+$\mathrm{Pic}^0$. It feeds the construction of isogenies with prescribed full kernel, via
+[`WeierstrassCurve.
+exists_functionFieldHom_fullKernelQuotient_pointMapOfPushforward_ker_eq_zmultiples`]
+(thm.html#WeierstrassCurve.
+exists_functionFieldHom_fullKernelQuotient_pointMapOfPushforward_ker_eq_zmultiples).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples_of_oddOrder.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_2f26e239
+
+theorem solution
+    {F : Type*} [Field F] [DecidableEq F] [CharZero F] [IsAlgClosed F]
+    {W : WeierstrassCurve F} [W.toAffine.IsElliptic]
+    {Q : W.toAffine.Point} {n : ℕ} (hord : addOrderOf Q = 2 * n + 1)
+    (hΔ' : (W.veluQuotient (W.oddOrderSummingSet Q n)).Δ ≠ 0)
+    [(W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W.toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine] :
+    ∃ (ι : (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.FunctionField
+            →ₐ[F] W.toAffine.FunctionField)
+      (hι : ι.toRingHom.IsIntegral) (hfin : AlgebraicCurve.FiniteAlong F ι),
+      ∀ hN : AlgebraicCurve.NormFormulaAlong F ι hfin,
+        (WeierstrassCurve.Affine.pointMapOfPushforward ι hι hfin hN).ker
+          = AddSubgroup.zmultiples Q := by
+  obtain ⟨ι, hι, hfin, _, hker, _, _⟩ :=
+    WeierstrassCurve.exists_veluFunctionFieldHom_restrictAlong_placeOfPoint_eq hord hΔ'
+  exact ⟨ι, hι, hfin, hker⟩
+
+end S_OVERLONG_2f26e239
+end P2MW
+export
+  P2MW.S_OVERLONG_2f26e239
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem
+  WeierstrassCurve.exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples_of_oddOrder
+    {F : Type*} [Field F] [DecidableEq F] [CharZero F] [IsAlgClosed F]
+    {W : WeierstrassCurve F} [W.toAffine.IsElliptic]
+    {Q : W.toAffine.Point} {n : ℕ} (hord : addOrderOf Q = 2 * n + 1)
+    (hΔ' : (W.veluQuotient (W.oddOrderSummingSet Q n)).Δ ≠ 0)
+    [(W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W.toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine] :
+    ∃ (ι : (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.FunctionField
+            →ₐ[F] W.toAffine.FunctionField)
+      (hι : ι.toRingHom.IsIntegral) (hfin : AlgebraicCurve.FiniteAlong F ι),
+      ∀ hN : AlgebraicCurve.NormFormulaAlong F ι hfin,
+        (WeierstrassCurve.Affine.pointMapOfPushforward ι hι hfin hN).ker
+          = AddSubgroup.zmultiples Q :=
+  solution hord hΔ'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_veluFunctionFieldHom_restrictAlong_placeOfPoint_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_veluFunctionFieldHom_restrictAlong_placeOfPoint_eq.lean
new file mode 100644
index 0000000000..8d147013d9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_exists_veluFunctionFieldHom_restrictAlong_placeOfPoint_eq.lean
@@ -0,0 +1,1827 @@
+/-
+Based on Prove2Me node WeierstrassCurve.exists_veluFunctionFieldHom_restrictAlong_placeOfPoint_eq
+(acd8e718-18d4-56b2-b4fe-299ba6bb61cd) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 200e3821-d296-5b22-a15a-da3c41ece41b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_OddOrderSummingSet
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluPointMap
+
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FunctionFieldPullback
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaces
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FunctionFieldQuadratic
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+import LeanPool.FLTEichlerShimura.Definitions.Defs_WeierstrassCurve_veluSharedLibrary
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_GenusOnePlaceGate_ext_of_isCentred
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_algebraMap_mk_C_X_notMem_toValuationSubring_placeOfPoint_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_natCard_ker_pointMapOfPushforward_eq_finrankAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_velu_map_equation_of_oddOrderSummingSet
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_placeOfPoint_some_eq_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_XYIdeal_ne_bot
+
+/-!
+# Vélu quotient isogeny via places, odd order case
+
+Theorem statement: `WeierstrassCurve.exists_veluFunctionFieldHom_restrictAlong_placeOfPoint_eq`
+(`acd8e718-18d4-56b2-b4fe-299ba6bb61cd`), by Claude, 2026-09-05.
+
+Proof: submission `200e3821-d296-5b22-a15a-da3c41ece41b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be an algebraically closed field of characteristic $0$, let $W$ be a Weierstrass curve over
+$F$ which is elliptic, let $Q$ be a point of its affine model and $n$ a natural number with
+$\mathrm{addOrderOf}\,Q = 2n+1$. Write $S =$ `W.oddOrderSummingSet Q n`, the finite set of
+coordinate pairs of $Q, 2Q, \dots, nQ$, and let $W' =$ `W.veluQuotient S` be the Weierstrass curve
+with the same $a_1,a_2,a_3$ and with $a_4$ replaced by $a_4 - 5\,\mathrm{veluTSum}(S)$ and $a_6$ by
+$a_6 - b_2\,\mathrm{veluTSum}(S) - 7\,\mathrm{veluWSum}(S)$. Assume $\Delta(W') \ne 0$, that $W'$ is
+elliptic, and that both affine models carry a genus-one place gate (a bijection between points and
+places of the function field, all places of degree $1$), its centredness hypothesis, and the
+Abel-theorem hypothesis (a degree-zero divisor is principal exactly when its point sum vanishes).
+Then there exists an $F$-algebra map $\iota : F(W') \to F(W)$ which is integral and along which
+$F(W)$ is a finite $F(W')$-module, such that: the degree $[F(W):F(W')]$ along $\iota$ equals $2n+1$;
+for every witness of the pushforward norm formula along $\iota$, the resulting additive map $W(F)
+\to W'(F)$ on points has kernel the subgroup of integer multiples of $Q$; every $P$ in that subgroup
+has the place $\mathrm{placeOfPoint}(P)$ restricting along $\iota$ to the place of the origin of
+$W'$; and for every nonsingular affine point $(x,y)$ of $W$ not in that subgroup, the pair
+$(\mathrm{veluX}_S(x), \mathrm{veluY}_S(x,y))$ is a nonsingular point of $W'$ and the place of
+$(x,y)$ restricts along $\iota$ to the place of that point.
+
+This is the function-field form of Vélu's construction of the quotient isogeny by a cyclic subgroup
+of odd order $2n+1$: the inclusion of function fields, its degree, the kernel of the induced map on
+points, and the pointwise identification of that map with Vélu's explicit formulae, all expressed
+through restriction of places. It is the source of the separate statements isolating the kernel as
+the subgroup generated by $Q$, and of the comparison of $j$-invariants of a curve and of its odd
+Vélu quotient.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_exists_veluFunctionFieldHom_restrictAlong_placeOfPoint_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+
+open AlgebraicCurve Place WeierstrassCurve Polynomial IsDedekindDomain Affine CoordinateRing
+  WithZero IsLocalRing
+
+open scoped Polynomial.Bivariate
+
+noncomputable section
+
+namespace WeierstrassCurve
+namespace Affine
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem S13_ofHeightOneSpectrum_injective {R : Type*} [CommRing R] [IsDedekindDomain R]
+    [Algebra R W.FunctionField] [IsFractionRing R W.FunctionField] [Algebra F R]
+    [IsScalarTower F R W.FunctionField] :
+    Function.Injective (AlgebraicCurve.Place.ofHeightOneSpectrum (K := F) (R := R) (F :=
+      W.FunctionField)) := by
+  intro w₁ w₂ h
+  refine HeightOneSpectrum.eq_of_valuation_isEquiv_valuation (K := W.FunctionField) ?_
+  rw [Valuation.isEquiv_iff_valuationSubring]
+  exact congrArg AlgebraicCurve.Place.toValuationSubring h
+
+namespace CoordinateRing
+theorem eq_of_XYIdeal_eq {x₁ y₁ x₂ y₂ : F} (h₂ : W.Equation x₂ y₂)
+    (h : XYIdeal W x₁ (C y₁) = XYIdeal W x₂ (C y₂)) : x₁ = x₂ ∧ y₁ = y₂ := by
+  have hne : XYIdeal W x₂ (C y₂) ≠ ⊤ := (XYIdeal_isMaximal h₂).ne_top
+  have hX₁ : XClass W x₁ ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert _ _)
+  have hX₂ : XClass W x₂ ∈ XYIdeal W x₂ (C y₂) := Ideal.subset_span (Set.mem_insert _ _)
+  have hY₁ : YClass W (C y₁) ∈ XYIdeal W x₂ (C y₂) :=
+    h ▸ Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  have hY₂ : YClass W (C y₂) ∈ XYIdeal W x₂ (C y₂) :=
+    Ideal.subset_span (Set.mem_insert_of_mem _ rfl)
+  constructor
+  · by_contra hx
+    apply hne
+    have hsub : XClass W x₁ - XClass W x₂ = algebraMap F W.CoordinateRing (x₂ - x₁) := by
+      rw [XClass, XClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      rw [← map_sub]
+      congr 1
+      rw [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hX₁ hX₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hx hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+  · by_contra hy
+    apply hne
+    have hsub : YClass W (C y₁) - YClass W (C y₂) = algebraMap F W.CoordinateRing (y₂ - y₁) := by
+      rw [YClass, YClass, ← map_sub, algebraMap_eq_mk_C_C]
+      congr 1
+      simp only [map_sub]
+      ring
+    have hmem := (XYIdeal W x₂ (C y₂)).sub_mem hY₁ hY₂
+    rw [hsub] at hmem
+    exact Ideal.eq_top_of_isUnit_mem _ hmem
+      ((isUnit_iff_ne_zero.mpr (sub_ne_zero.mpr fun hxy => hy hxy.symm)).map
+        (algebraMap F W.CoordinateRing))
+
+end CoordinateRing
+
+@[scoped simp]
+theorem IsFinitePlace.coe_ringHom_apply {v : AlgebraicCurve.Place F W.FunctionField}
+    (hv : IsFinitePlace v) (r : W.CoordinateRing) :
+    (hv.ringHom r : W.FunctionField) = algebraMap W.CoordinateRing W.FunctionField r := rfl
+
+variable [IsDedekindDomain W.CoordinateRing]
+
+theorem placeOfEquation_injective {x₁ y₁ x₂ y₂ : F} (h₁ : W.Equation x₁ y₁)
+    (h₂ : W.Equation x₂ y₂) (h : placeOfEquation h₁ = placeOfEquation h₂) :
+    x₁ = x₂ ∧ y₁ = y₂ :=
+  eq_of_XYIdeal_eq h₂
+    (congrArg HeightOneSpectrum.asIdeal (S13_ofHeightOneSpectrum_injective h))
+
+section CentredGate
+
+variable [DecidableEq F] [GenusOnePlaceGate W] [GenusOnePlaceGate.IsCentred W]
+
+namespace InfinitePlace
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem deg_eq_one : (place : AlgebraicCurve.Place F W.FunctionField).deg = 1 := by
+  classical
+  exact
+    deg_placeOfPoint (W := W) 0
+
+omit [DecidableEq F] in
+theorem eq_of_not_isFinitePlace
+    (v : AlgebraicCurve.Place F W.FunctionField) (hv : ¬ IsFinitePlace v) :
+    v = place := by
+  classical
+  obtain ⟨P, rfl⟩ : ∃ P : W.Point, placeOfPoint P = v :=
+    ⟨(pointEquivPlace (W := W)).symm v, (pointEquivPlace (W := W)).apply_symm_apply v⟩
+  cases P with
+  | zero => rfl
+  | some x y h =>
+      exact absurd (placeOfPoint_some (W := W) h ▸ isFinitePlace_placeOfEquation h.left) hv
+
+end InfinitePlace
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+@[scoped simp]
+theorem placeOfPoint_zero : placeOfPoint (.zero : W.Point) = InfinitePlace.place := by
+  classical
+  exact
+    rfl
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_zero' : placeOfPoint (0 : W.Point) = InfinitePlace.place := by
+  classical
+  exact
+    rfl
+
+omit [DecidableEq F] in
+omit [IsDedekindDomain W.CoordinateRing] [GenusOnePlaceGate.IsCentred W] in
+theorem placeOfPoint_surjective' : Function.Surjective (placeOfPoint (W := W)) := by
+  classical
+  exact
+    (pointEquivPlace (W := W)).surjective
+
+end CentredGate
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+namespace Affine
+scoped instance instHasPrincipalDivisorsFunctionField_s13 {F : Type*} [Field F] [CharZero F]
+    {W : Affine F} : HasPrincipalDivisors F W.FunctionField :=
+  hasPrincipalDivisors_functionField W
+
+namespace IsogenyEndDatum
+
+variable {F : Type*} [Field F] [DecidableEq F] [CharZero F]
+variable {W : Affine F} [W.IsElliptic] [GenusOnePlaceGate W] [AbelTheorem W]
+
+omit [WeierstrassCurve.IsElliptic W] in
+theorem pointEnd_eq_pointEnd' (D : IsogenyEndDatum W) (hN : NormFormulaAlong F D.ι D.hfin) :
+    D.pointEnd hN = D.pointEnd' := rfl
+
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+
+section
+
+namespace WeierstrassCurve
+variable {F : Type*} [Field F] {W : WeierstrassCurve F}
+
+section PointMap
+
+variable (W) in
+private abbrev KwVeluMapEquationAt (S : Finset (F × F)) : Prop :=
+  ∀ ⦃r s : F⦄, W.toAffine.Equation r s → (∀ Q ∈ S, r ≠ Q.1) →
+    (W.veluQuotient S).toAffine.Equation (W.veluX S r) (W.veluY S r s)
+
+variable {S : Finset (F × F)}
+
+theorem kw_velu_map_nonsingular (hmapeq : W.KwVeluMapEquationAt S)
+    (hΔ : (W.veluQuotient S).Δ ≠ 0) {x y : F} (hP : W.toAffine.Equation x y)
+    (hx : ∀ Q ∈ S, x ≠ Q.1) :
+    (W.veluQuotient S).toAffine.Nonsingular (W.veluX S x) (W.veluY S x y) :=
+  ((W.veluQuotient S).toAffine.equation_iff_nonsingular_of_Δ_ne_zero hΔ).mp (hmapeq hP hx)
+
+open scoped Classical in
+noncomputable def kwVeluPointMap (hmapeq : W.KwVeluMapEquationAt S)
+    (hΔ : (W.veluQuotient S).Δ ≠ 0) :
+    W.toAffine.Point → (W.veluQuotient S).toAffine.Point
+  | .zero => .zero
+  | .some x _ h =>
+    if hx : ∀ Q ∈ S, x ≠ Q.1 then
+      .some _ _ (kw_velu_map_nonsingular hmapeq hΔ h.1 hx)
+    else .zero
+
+variable (hmapeq : W.KwVeluMapEquationAt S) (hΔ : (W.veluQuotient S).Δ ≠ 0)
+
+@[scoped simp] lemma kwVeluPointMap_zero : kwVeluPointMap hmapeq hΔ .zero = .zero := rfl
+
+lemma kwVeluPointMap_some_of_mem {x y : F} (h : W.toAffine.Nonsingular x y)
+    {Q : F × F} (hQ : Q ∈ S) (hx : x = Q.1) :
+    kwVeluPointMap hmapeq hΔ (.some x y h) = 0 := by
+  classical
+  simp only [kwVeluPointMap]
+  exact dite_eq_right (fun hall => hall Q hQ hx)
+
+lemma kwVeluPointMap_some_of_ne {x y : F} (h : W.toAffine.Nonsingular x y)
+    (hx : ∀ Q ∈ S, x ≠ Q.1) :
+    kwVeluPointMap hmapeq hΔ (.some x y h)
+      = .some _ _ (kw_velu_map_nonsingular hmapeq hΔ h.1 hx) := by
+  classical
+  simp only [kwVeluPointMap]
+  exact dite_eq_left hx
+
+end PointMap
+end WeierstrassCurve
+end
+
+section
+
+section
+
+namespace WeierstrassCurve
+universe u
+
+variable {F : Type u} [Field F]
+
+variable (F) in
+theorem veluHPDSupplier [CharZero F] :
+    ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+      HasPrincipalDivisors F W.toAffine.FunctionField :=
+  fun _W _hΔ => Affine.hasPrincipalDivisors_functionField _
+
+end WeierstrassCurve
+end
+
+section
+
+namespace AlgebraicCurve
+variable (K F : Type*) [Field K] [Field F] [Algebra K F]
+
+namespace Place
+
+variable {K F}
+
+variable (v : Place K F)
+
+scoped instance : IsPrincipalIdealRing v.toValuationSubring := v.isPrincipalIdealRing'
+
+scoped instance : IsDiscreteValuationRing v.toValuationSubring where
+  not_a_field' := by
+    rw [ne_eq, ← IsLocalRing.isField_iff_maximalIdeal_eq]
+    exact ValuationSubring.not_isField_of_ne_top F v.ne_top'
+
+scoped instance : Algebra K v.toValuationSubring :=
+  ((algebraMap K F).codRestrict v.toValuationSubring.toSubring v.algebraMap_mem').toAlgebra
+
+end Place
+
+namespace Place
+
+open scoped _root_.Pointwise
+
+variable {K F}
+variable (σ : F ≃ₐ[K] F)
+
+scoped instance : SMul (F ≃ₐ[K] F) (Place K F) where
+  smul σ v :=
+    { toValuationSubring := σ • v.toValuationSubring
+      algebraMap_mem' := fun a => by
+        have h := ValuationSubring.smul_mem_pointwise_smul σ (algebraMap K F a)
+          v.toValuationSubring (v.algebraMap_mem' a)
+        rwa [AlgEquiv.smul_def, σ.commutes] at h
+      ne_top' := fun h => v.ne_top' <| by
+        have := congrArg (σ⁻¹ • ·) h
+        simpa [ValuationSubring.pointwise_smul_top] using this
+      isPrincipalIdealRing' :=
+        IsPrincipalIdealRing.of_surjective
+          (smulRingEquiv σ v.toValuationSubring : _ ≃+* _)
+          (smulRingEquiv σ v.toValuationSubring).surjective }
+
+end Place
+end AlgebraicCurve
+end
+
+section
+
+section
+
+open Ideal Module
+
+
+namespace WeierstrassCurve
+namespace Affine
+universe u
+
+variable {F : Type u} [Field F] {W : Affine F}
+
+namespace CoordinateRing
+scoped instance : Algebra.FiniteType F W.CoordinateRing :=
+  Algebra.FiniteType.trans (S := Polynomial F) inferInstance inferInstance
+
+end CoordinateRing
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+section
+
+namespace WeierstrassCurve
+section GaloisStability
+
+lemma zsmul_eq_emod_zsmul_of_nsmul_eq_zero {G : Type*} [AddCommGroup G] {g : G} {p : ℕ}
+    (hp : p • g = 0) (m : ℤ) : m • g = (m % (p : ℤ)) • g := by
+  have hp' : (p : ℤ) • g = 0 := by rw [natCast_zsmul]; exact hp
+  conv_lhs => rw [show m = (p : ℤ) * (m / (p : ℤ)) + m % (p : ℤ) from
+    (Int.mul_ediv_add_emod m (p : ℤ)).symm]
+  rw [add_zsmul, mul_comm ((p : ℤ)) (m / (p : ℤ)), ← smul_smul, hp', smul_zero, zero_add]
+
+end GaloisStability
+end WeierstrassCurve
+end
+
+section
+
+namespace WeierstrassCurve
+namespace Affine
+variable {F : Type*} [Field F] {W : Affine F}
+
+variable (v : AlgebraicCurve.Place F W.FunctionField)
+
+private theorem exists_equation [IsAlgClosed F] (W : Affine F)
+    (x₀ : F) :
+    ∃ y₀ : F, W.Equation x₀ y₀ := by
+  set P : F[X] := Polynomial.X ^ 2 + Polynomial.C (W.a₁ * x₀ + W.a₃) * Polynomial.X
+    - Polynomial.C (x₀ ^ 3 + W.a₂ * x₀ ^ 2 + W.a₄ * x₀ + W.a₆) with hPdef
+  have hPdeg : P.degree ≠ 0 := by
+    have hcoeff : P.coeff 2 = 1 := by
+      rw [hPdef]
+      simp only [Polynomial.coeff_sub, Polynomial.coeff_add, Polynomial.coeff_X_pow,
+        Polynomial.coeff_C_mul, Polynomial.coeff_X, Polynomial.coeff_C]
+      norm_num
+    intro hcon
+    have h2 : P.coeff 2 = 0 := by
+      refine Polynomial.coeff_eq_zero_of_degree_lt ?_
+      rw [hcon]
+      norm_num
+    rw [hcoeff] at h2
+    exact one_ne_zero h2
+  obtain ⟨y₀, hy₀⟩ := IsAlgClosed.exists_root P hPdeg
+  refine ⟨y₀, ?_⟩
+  rw [equation_iff]
+  have h3 : P.eval y₀ = 0 := hy₀
+  rw [hPdef] at h3
+  simp only [Polynomial.eval_sub, Polynomial.eval_add, Polynomial.eval_pow,
+    Polynomial.eval_mul, Polynomial.eval_C, Polynomial.eval_X] at h3
+  linear_combination h3
+
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+open WeierstrassCurve.Affine.Point
+
+section
+
+namespace WeierstrassCurve
+section LevelPoly
+
+variable {F : Type*} [Field F] [DecidableEq F]
+
+def veluXDenomPoly (S : Finset (F × F)) : F[X] := ∏ P ∈ S, (X - C P.1)
+
+omit [DecidableEq F] in
+theorem veluXDenomPoly_monic (S : Finset (F × F)) : (veluXDenomPoly S).Monic := by
+  classical
+  exact
+    Polynomial.monic_prod_of_monic _ _ fun _ _ => monic_X_sub_C _
+
+omit [DecidableEq F] in
+theorem natDegree_veluXDenomPoly (S : Finset (F × F)) :
+    (veluXDenomPoly S).natDegree = S.card := by
+  classical
+  unfold veluXDenomPoly
+  rw [Polynomial.natDegree_prod_of_monic _ _ (fun _ _ => monic_X_sub_C _)]
+  simp
+
+omit [DecidableEq F] in
+private lemma cleared_summand_aux {a t u E : F} (ha : a ≠ 0) :
+    (t * a + u) * E ^ 2 = (a * E) ^ 2 * (t / a + u / a ^ 2) := by
+  classical
+  have h2 : a ^ 2 ≠ 0 := pow_ne_zero 2 ha
+  field_simp
+
+variable (W : WeierstrassCurve F)
+
+def veluXClearedPoly (S : Finset (F × F)) : F[X] :=
+  X * (veluXDenomPoly S) ^ 2
+    + ∑ P ∈ S, (C (W.veluT P.1 P.2) * (X - C P.1) + C (W.veluU P.1 P.2))
+        * (∏ A ∈ S.erase P, (X - C A.1)) ^ 2
+
+theorem eval_veluXClearedPoly (S : Finset (F × F)) {x : F} (hx : ∀ P ∈ S, x ≠ P.1) :
+    (veluXClearedPoly W S).eval x = (veluXDenomPoly S).eval x ^ 2 * W.veluX S x := by
+  unfold veluXClearedPoly veluXDenomPoly veluX
+  simp only [eval_add, eval_mul, eval_pow, eval_X, eval_finsetSum, eval_prod, eval_sub, eval_C]
+  rw [mul_add, mul_comm _ x, Finset.mul_sum]
+  congr 1
+  refine Finset.sum_congr rfl fun P hP => ?_
+  have hxP : x - P.1 ≠ 0 := sub_ne_zero.mpr (hx P hP)
+  have hprod : ∏ A ∈ S, (x - A.1) = (x - P.1) * ∏ A ∈ S.erase P, (x - A.1) :=
+    (Finset.prod_erase_mul S _ hP).symm.trans (mul_comm _ _)
+  rw [hprod]
+  exact cleared_summand_aux hxP
+
+theorem veluXClearedPoly_monic (S : Finset (F × F)) :
+    (veluXClearedPoly W S).Monic ∧ (veluXClearedPoly W S).natDegree = 2 * S.card + 1 := by
+  have hD : (veluXDenomPoly (F := F) S).Monic := veluXDenomPoly_monic S
+  have hDdeg : (veluXDenomPoly (F := F) S).natDegree = S.card := natDegree_veluXDenomPoly S
+  have hlead : (X * (veluXDenomPoly (F := F) S) ^ 2).Monic := monic_X.mul (hD.pow 2)
+  have hleaddeg : (X * (veluXDenomPoly (F := F) S) ^ 2).natDegree = 2 * S.card + 1 := by
+    rw [natDegree_mul monic_X.ne_zero (hD.pow 2).ne_zero, natDegree_X,
+      natDegree_pow, hDdeg]; ring
+  have htraildeg : ∀ P ∈ S, ((C (W.veluT P.1 P.2) * (X - C P.1) + C (W.veluU P.1 P.2))
+      * (∏ A ∈ S.erase P, (X - C A.1)) ^ 2).natDegree ≤ 2 * S.card - 1 := by
+    intro P hP
+    have hcard : (S.erase P).card = S.card - 1 := Finset.card_erase_of_mem hP
+    have h1 : ((∏ A ∈ S.erase P, ((X : F[X]) - C A.1)) ^ 2).natDegree = 2 * (S.card - 1) := by
+      rw [natDegree_pow,
+        Polynomial.natDegree_prod_of_monic _ _ (fun _ _ => monic_X_sub_C _)]
+      simp [hcard]
+    have h2 : (C (W.veluT P.1 P.2) * (X - C P.1) + C (W.veluU P.1 P.2)).natDegree ≤ 1 := by
+      refine (natDegree_add_le _ _).trans ?_
+      refine max_le ?_ (by rw [natDegree_C]; omega)
+      exact (natDegree_C_mul_le _ _).trans (le_of_eq (natDegree_X_sub_C (R := F) P.1))
+    have hSpos : 0 < S.card := Finset.card_pos.mpr ⟨P, hP⟩
+    calc _ ≤ _ + _ := natDegree_mul_le
+      _ ≤ 1 + 2 * (S.card - 1) := add_le_add h2 (le_of_eq h1)
+      _ ≤ 2 * S.card - 1 := by omega
+  have hlt : (∑ P ∈ S, (C (W.veluT P.1 P.2) * (X - C P.1) + C (W.veluU P.1 P.2))
+      * (∏ A ∈ S.erase P, (X - C A.1)) ^ 2).degree < (X * (veluXDenomPoly (F := F) S) ^ 2).degree
+        := by
+    rw [Polynomial.degree_eq_natDegree hlead.ne_zero, hleaddeg]
+    refine lt_of_le_of_lt (degree_sum_le _ _) ?_
+    have hbot : (⊥ : WithBot ℕ) < (2 * S.card + 1 : ℕ) := WithBot.bot_lt_coe _
+    refine (Finset.sup_lt_iff hbot).mpr fun P hP => ?_
+    refine lt_of_le_of_lt (Polynomial.degree_le_natDegree) ?_
+    exact_mod_cast lt_of_le_of_lt (htraildeg P hP) (by omega)
+  refine ⟨hlead.add_of_left hlt, ?_⟩
+  have hdegeq : (veluXClearedPoly W S).natDegree = (X * (veluXDenomPoly (F := F) S) ^ 2).natDegree
+    :=
+    natDegree_add_eq_left_of_degree_lt hlt
+  rw [hdegeq, hleaddeg]
+
+end LevelPoly
+end WeierstrassCurve
+end
+end
+
+section
+
+namespace AlgebraicCurve
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F] [Algebra K F']
+
+open scoped _root_.AlgebraicCurve.Place in
+theorem Place.mem_restrictAlong_iff (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') (f : F) :
+    f ∈ (w.restrictAlong φ hφ).toValuationSubring ↔ φ f ∈ w.toValuationSubring :=
+  Iff.rfl
+
+open scoped _root_.AlgebraicCurve.Place in
+theorem Place.ramificationIndexAlong_pos (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') : 0 < Place.ramificationIndexAlong φ w := by
+  let := algebraAlong φ
+  have := isScalarTower_along φ
+  have := isIntegral_along φ hφ
+  exact w.ramificationIndex_pos
+
+open scoped _root_.AlgebraicCurve.Place in
+theorem Place.ord_restrictAlong_ne_zero_iff (φ : F →ₐ[K] F') (hφ : φ.toRingHom.IsIntegral)
+    (w : Place K F') (f : F) :
+    (w.restrictAlong φ hφ).ord f ≠ 0 ↔ w.ord (φ f) ≠ 0 := by
+  rw [w.ord_restrictAlong φ hφ f]
+  have hpos := Place.ramificationIndexAlong_pos φ hφ w
+  constructor
+  · intro h hcon
+    rcases mul_eq_zero.mp hcon with h1 | h1
+    · omega
+    · exact h h1
+  · intro h hcon
+    exact h (by rw [hcon, mul_zero])
+
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+namespace Affine
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem eq_placeOfEquation_of_le_centre [IsAlgClosed F] [IsDedekindDomain W.CoordinateRing]
+    {v : Place F W.FunctionField} (hv : IsFinitePlace v) {x y : F} (h : W.Equation x y)
+    (hle : XYIdeal W x (C y) ≤ hv.centre) : v = placeOfEquation h := by
+  obtain ⟨x', y', h', hveq⟩ := (isFinitePlace_iff_exists_placeOfEquation v).mp hv
+  subst hveq
+  have hc : hv.centre = XYIdeal W x' (C y') := by
+    rw [Subsingleton.elim hv (isFinitePlace_placeOfEquation h')]
+    exact centre_placeOfEquation h'
+  rw [hc] at hle
+  have heq : XYIdeal W x (C y) = XYIdeal W x' (C y') :=
+    (CoordinateRing.XYIdeal_isMaximal h).eq_of_le (CoordinateRing.XYIdeal_isMaximal h').ne_top
+      hle
+  obtain ⟨rfl, rfl⟩ := CoordinateRing.eq_of_XYIdeal_eq h' heq
+  rfl
+
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+namespace Affine
+variable {F : Type*} [Field F] (W : Affine F)
+
+private def veluXNumPoly (x₀ y₀ : F) : F[X] :=
+  X * (X - C x₀) ^ 2 + C (W.veluT x₀ y₀) * (X - C x₀) + C (W.veluU x₀ y₀)
+
+private def veluYNumQ (x₀ y₀ : F) : F[X] :=
+  (X - C x₀) ^ 3 - C (2 * W.veluU x₀ y₀) - C (W.veluT x₀ y₀) * (X - C x₀)
+
+private def veluYNumP (x₀ y₀ : F) : F[X] :=
+  -(C (W.veluU x₀ y₀) * (C W.a₁ * X + C W.a₃)
+    + C (W.veluT x₀ y₀) * (C W.a₁ * (X - C x₀) - C y₀) * (X - C x₀)
+    + C (W.a₁ * W.veluU x₀ y₀ - W.veluGx x₀ y₀ * W.veluGy x₀ y₀) * (X - C x₀))
+
+variable {W}
+
+variable (W) in
+def veluXFun (x₀ y₀ : F) : W.FunctionField :=
+  polyToFunctionField W (W.veluXNumPoly x₀ y₀) / polyToFunctionField W ((X - C x₀) ^ 2)
+
+variable (W) in
+def veluYNumCR (x₀ y₀ : F) : W.CoordinateRing :=
+  W.veluYNumP x₀ y₀ • (1 : W.CoordinateRing) + W.veluYNumQ x₀ y₀ • CoordinateRing.mk W Y
+
+variable (W) in
+def veluYFun (x₀ y₀ : F) : W.FunctionField :=
+  algebraMap W.CoordinateRing W.FunctionField (veluYNumCR W x₀ y₀)
+    / polyToFunctionField W ((X - C x₀) ^ 3)
+
+section OrdAtPoint
+
+variable [IsDedekindDomain W.CoordinateRing]
+
+theorem ord_polyToFunctionField_eq_zero_iff {x y : F} (h : W.Equation x y) {p : F[X]}
+    (hp : p ≠ 0) :
+    (placeOfEquation h).ord (polyToFunctionField W p) = 0 ↔ p.eval x ≠ 0 := by
+  have h1 := ord_polyToFunctionField_pos_iff h hp (y := y)
+  have h2 : 0 ≤ (placeOfEquation h).ord (polyToFunctionField W p) := by
+    rw [polyToFunctionField_apply]
+    exact ord_placeOfEquation_nonneg h _
+  constructor
+  · intro h0 hcon
+    have h3 := h1.mpr hcon
+    omega
+  · intro hne
+    rcases lt_or_eq_of_le h2 with hlt | heq
+    · exact absurd (h1.mp hlt) hne
+    · exact heq.symm
+
+end OrdAtPoint
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+namespace WeierstrassCurve
+namespace Affine
+universe u
+
+variable {F : Type u} [Field F]
+
+section GenericPoint
+
+variable {W : Affine F}
+
+theorem polyToFunctionField_eq_eval_map (p : F[X]) :
+    polyToFunctionField W p
+      = (p.map (algebraMap F W.FunctionField)).eval (polyToFunctionField W X) := by
+  rw [polyToFunctionField_eq_aeval, Polynomial.aeval_def, Polynomial.eval_map]
+
+end GenericPoint
+end Affine
+end WeierstrassCurve
+end
+
+section
+
+open WeierstrassCurve.Affine.Point
+
+section
+
+namespace WeierstrassCurve
+section FunctionFieldLift
+
+variable {F : Type*} [Field F] (W : Affine F)
+
+private theorem veluDeficitFun_eq_zero_iff_equation (S : Finset (F × F)) :
+    W.veluDeficitFun S = 0
+      ↔ ((W.map (algebraMap F W.FunctionField)).veluQuotient (W.liftSummingSet S)).toAffine.Equation
+          ((W.map (algebraMap F W.FunctionField)).veluX (W.liftSummingSet S)
+            (polyToFunctionField W X))
+          ((W.map (algebraMap F W.FunctionField)).veluY (W.liftSummingSet S)
+            (polyToFunctionField W X) (yGen W)) :=
+  ((W.map (algebraMap F W.FunctionField)).veluQuotient_equation_iff_veluDeficit_eq_zero
+    (W.liftSummingSet S) (polyToFunctionField W X) (yGen W)).symm
+
+private theorem map_veluQuotient_liftSummingSet (S : Finset (F × F)) :
+    (W.map (algebraMap F W.FunctionField)).veluQuotient (W.liftSummingSet S)
+      = (W.veluQuotient S).map (algebraMap F W.FunctionField) :=
+  W.map_veluQuotient (algebraMap F W.FunctionField) S (algebraMap F W.FunctionField).injective
+
+end FunctionFieldLift
+end WeierstrassCurve
+end
+end
+
+section
+
+open WeierstrassCurve.Affine.Point
+
+namespace WeierstrassCurve
+universe u
+
+variable {F : Type u} [Field F]
+
+section GenericVeluFun
+
+variable (W : Affine F) (S : Finset (F × F))
+
+def kwVeluXGenFun : W.FunctionField :=
+  (W.map (algebraMap F W.FunctionField)).veluX (W.liftSummingSet S) (polyToFunctionField W X)
+
+def kwVeluYGenFun : W.FunctionField :=
+  (W.map (algebraMap F W.FunctionField)).veluY (W.liftSummingSet S)
+    (polyToFunctionField W X) (yGen W)
+
+variable {W S}
+
+theorem kw_kwVeluXGenFun_notMem_of_not_isFinitePlace
+    (v : Place F W.FunctionField) (hv : ¬ IsFinitePlace v) :
+    kwVeluXGenFun W S ∉ v.toValuationSubring := by
+  intro hmem
+  have hdiff : kwVeluXGenFun W S - polyToFunctionField W X ∈ v.toValuationSubring :=
+    veluX_sub_self_genericPoint'_mem_of_not_isFinitePlace (W := W) (v := v) hv S
+  have hx : polyToFunctionField W X ∈ v.toValuationSubring := by
+    have h := sub_mem hmem hdiff
+    simp only [sub_sub_cancel] at h
+    exact h
+  have hxneg := ord_X_neg_of_not_isFinitePlace (W := W) (v := v) hv
+  exact absurd
+    ((AlgebraicCurve.Place.mem_iff_ord_nonneg v (polyToFunctionField_ne_zero
+      Polynomial.X_ne_zero)).mp hx)
+    (not_le.mpr hxneg)
+
+end GenericVeluFun
+
+section DeficitZero
+
+variable [IsAlgClosed F]
+variable {W : WeierstrassCurve F} {Q : W.toAffine.Point} {p : ℕ}
+
+theorem kw_exists_equation_avoids (W : WeierstrassCurve F) (T : Finset F) :
+    ∃ r s : F, W.toAffine.Equation r s ∧ ∀ a ∈ T, r ≠ a := by
+  classical
+  obtain ⟨r, hr⟩ := Infinite.exists_notMem_finset T
+  obtain ⟨s, hs⟩ := W.toAffine.exists_equation r
+  exact ⟨r, s, hs, fun a ha hra => hr (hra ▸ ha)⟩
+
+end DeficitZero
+
+section Inclusion
+
+variable [IsAlgClosed F]
+variable {W : WeierstrassCurve F} [W.toAffine.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W.toAffine]
+    {Q : W.toAffine.Point}
+
+theorem kw_transcendental_kwVeluXGenFun (S : Finset (F × F)) :
+    Transcendental F (kwVeluXGenFun W.toAffine S) := by
+  rw [transcendental_iff]
+  intro q hq
+  by_contra hq0
+  have hint : _root_.IsIntegral F (kwVeluXGenFun W.toAffine S) :=
+    isAlgebraic_iff_isIntegral.mp ⟨q, hq0, hq⟩
+  have hdeg : (minpoly F (kwVeluXGenFun W.toAffine S)).degree = 1 :=
+    IsAlgClosed.degree_eq_one_of_irreducible F (minpoly.irreducible hint)
+  obtain ⟨c, hc⟩ := minpoly.degree_eq_one_iff.mp hdeg
+  refine kw_kwVeluXGenFun_notMem_of_not_isFinitePlace (S := S)
+    (InfinitePlace.place : Place F W.toAffine.FunctionField) InfinitePlace.not_isFinitePlace ?_
+  rw [← hc]
+  exact (InfinitePlace.place : Place F W.toAffine.FunctionField).algebraMap_mem' c
+
+theorem kw_aeval_kwVeluXGenFun_injective (S : Finset (F × F)) :
+    Function.Injective (Polynomial.aeval (R := F) (kwVeluXGenFun W.toAffine S)) :=
+  (injective_iff_map_eq_zero _).mpr fun q hq =>
+    transcendental_iff.mp (kw_transcendental_kwVeluXGenFun (W := W) S) q hq
+
+end Inclusion
+end WeierstrassCurve
+end
+
+section
+
+open WeierstrassCurve.Affine.Point
+
+namespace WeierstrassCurve
+universe u
+
+variable {F : Type u} [Field F]
+
+section MapPoly
+
+variable [DecidableEq F] {F' : Type*} [Field F'] [DecidableEq F']
+
+omit [DecidableEq F] [DecidableEq F'] in
+theorem kw_map_veluXDenomPoly (f : F →+* F') (hf : Function.Injective f)
+    (S : Finset (F × F)) :
+    (veluXDenomPoly S).map f
+      = veluXDenomPoly (S.map ⟨Prod.map f f, hf.prodMap hf⟩) := by
+  classical
+  unfold veluXDenomPoly
+  rw [Polynomial.map_prod, Finset.prod_map]
+  simp only [Polynomial.map_sub, map_X, map_C, Function.Embedding.coeFn_mk, Prod.map_fst]
+
+theorem kw_map_veluXClearedPoly (f : F →+* F') (hf : Function.Injective f)
+    (W : WeierstrassCurve F) (S : Finset (F × F)) :
+    (veluXClearedPoly W S).map f
+      = veluXClearedPoly (W.map f) (S.map ⟨Prod.map f f, hf.prodMap hf⟩) := by
+  unfold veluXClearedPoly
+  rw [Polynomial.map_add, Polynomial.map_mul, Polynomial.map_pow, map_X,
+    kw_map_veluXDenomPoly f hf, Polynomial.map_sum, Finset.sum_map]
+  congr 1
+  refine Finset.sum_congr rfl fun P hP => ?_
+  rw [← Finset.map_erase]
+  simp only [Polynomial.map_mul, Polynomial.map_pow, Polynomial.map_add, Polynomial.map_sub,
+    map_X, map_C, Function.Embedding.coeFn_mk, Prod.map_fst, Prod.map_snd,
+    map_veluT, map_veluU, Polynomial.map_prod, Finset.prod_map]
+
+end MapPoly
+
+section ClearedIdentity
+
+variable [DecidableEq F] (W : Affine F) (S : Finset (F × F))
+
+theorem kw_kwVeluXGenFun_mul_denom_sq_eq_cleared :
+    kwVeluXGenFun W S * polyToFunctionField W (veluXDenomPoly S) ^ 2
+      = polyToFunctionField W (veluXClearedPoly W S) := by
+  have hinj := (algebraMap F W.FunctionField).injective
+  have hav : ∀ P ∈ W.liftSummingSet S, polyToFunctionField W X ≠ P.1 :=
+    polyToFunctionField_X_ne_of_mem_liftSummingSet W
+  have heval := eval_veluXClearedPoly (W.map (algebraMap F W.FunctionField))
+    (W.liftSummingSet S) (x := polyToFunctionField W X) hav
+  rw [show W.liftSummingSet S
+        = S.map ⟨Prod.map (algebraMap F W.FunctionField) (algebraMap F W.FunctionField),
+            hinj.prodMap hinj⟩ from rfl,
+    ← kw_map_veluXClearedPoly _ hinj, ← kw_map_veluXDenomPoly _ hinj,
+    ← polyToFunctionField_eq_eval_map, ← polyToFunctionField_eq_eval_map] at heval
+  rw [heval]
+  exact mul_comm _ _
+
+theorem kw_eval_veluXClearedPoly_ne_zero_of_mem (hset : W.IsOddVeluSet S)
+    {A : F × F} (hA : A ∈ S) : (veluXClearedPoly W S).eval A.1 ≠ 0 := by
+  unfold veluXClearedPoly
+  simp only [eval_add, eval_mul, eval_pow, eval_X, eval_finsetSum, eval_sub, eval_C, eval_prod]
+  have hD : (veluXDenomPoly S).eval A.1 = 0 := by
+    unfold veluXDenomPoly
+    rw [eval_prod]
+    exact Finset.prod_eq_zero hA (by simp)
+  rw [hD, zero_pow two_ne_zero, mul_zero, zero_add]
+  rw [Finset.sum_eq_single A (fun B hB hBA => ?_) (fun h => absurd hA h)]
+  · simp only [sub_self, mul_zero, zero_add]
+    refine mul_ne_zero ?_ (pow_ne_zero 2 ?_)
+    · rw [veluU]; exact pow_ne_zero 2 (hset.gy_ne_zero A hA)
+    · exact Finset.prod_ne_zero_iff.mpr fun C hC =>
+        sub_ne_zero.mpr fun h => (Finset.mem_erase.mp hC).1
+          (hset.x_injOn C (Finset.mem_of_mem_erase hC) A hA h.symm)
+  · have hAerase : A ∈ S.erase B := Finset.mem_erase.mpr ⟨fun h => hBA h.symm, hA⟩
+    exact mul_eq_zero_of_right _
+      (pow_eq_zero_iff two_ne_zero |>.mpr (Finset.prod_eq_zero hAerase (by simp)))
+
+end ClearedIdentity
+end WeierstrassCurve
+end
+
+section
+
+open WeierstrassCurve.Affine.Point
+
+
+section
+
+namespace WeierstrassCurve
+variable {F : Type*} [Field F] [DecidableEq F]
+
+theorem veluDeficitFunSpecializesConstAt_of_dedekind
+    (hDD : ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 → IsDedekindDomain W.toAffine.CoordinateRing)
+    (p : ℕ) : VeluDeficitFunSpecializesConstAt F p :=
+  veluDeficitFunSpecializesConstAt_of_evalAtPlace hDD (veluDeficitFunEvalAtPlaceAt hDD p)
+
+end WeierstrassCurve
+end
+end
+
+section
+
+section
+
+namespace WeierstrassCurve
+variable {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F]
+
+omit [DecidableEq F] in
+private theorem hDDTerm :
+    ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 → IsDedekindDomain W.toAffine.CoordinateRing := by
+  classical
+  exact
+    fun _W hΔ => Affine.CoordinateRing.isDedekindDomain_of_Δ_ne_zero hΔ
+
+variable (F) in
+theorem veluDeficitFunSpecializesConstAt_unconditional' (p : ℕ) :
+    VeluDeficitFunSpecializesConstAt F p :=
+  veluDeficitFunSpecializesConstAt_of_dedekind hDDTerm p
+
+end WeierstrassCurve
+end
+
+section
+
+open WeierstrassCurve.Affine.Point
+namespace WeierstrassCurve
+section OrdNonneg
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F}
+variable {Q : W.toAffine.Point} {p : ℕ}
+
+variable (F : Type*) [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F] in
+theorem kw_veluDeficitIsConstantAt_odd {p : ℕ} (hp3 : 3 ≤ p) (hpodd : Odd p) :
+    VeluDeficitIsConstantAt F p :=
+  veluDeficitIsConstantAt_of_ordNonneg_of_dedekind (veluHPDSupplier F) kw_hDDTerm
+    (kw_veluDeficitFunOrdNonnegAt_odd F kw_hDDTerm hp3 hpodd)
+
+end OrdNonneg
+
+section ConstantIsZero
+
+variable {F : Type*} [Field F] [DecidableEq F]
+
+variable (F : Type*) [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F] in
+theorem kw_veluDeficitConstancyAt_odd {p : ℕ} (hp3 : 3 ≤ p) (hpodd : Odd p) :
+    VeluDeficitConstancyAt F p := by
+  have : Infinite F := kw_infinite_of_isAlgClosed
+  refine veluDeficitConstancyAt_of_isConstant_of_constantZero F
+    (kw_veluDeficitIsConstantAt_odd F hp3 hpodd)
+    (kw_veluDeficitConstantIsZeroAt_odd hp3 hpodd ?_)
+  refine kw_veluDeficitCrossQuadProdDegLtAt_odd hp3 hpodd
+    (kw_veluDeficitCrossQuadCubeBetaDegLtAt_odd hp3 hpodd
+      (kw_veluDeficitCrossQuadBetaOnlyDegLtAt_odd
+        (veluDeficitCrossQuadBetaSDecompDegLtAt_of_betaSq_of_alphaBeta
+          (kw_veluDeficitCrossQuadBetaSqDecompDegLtAt_odd hp3 hpodd)
+          (kw_veluDeficitCrossQuadAlphaBetaDecompDegLtAt_odd hp3 hpodd))))
+
+end ConstantIsZero
+end WeierstrassCurve
+end
+
+namespace WeierstrassCurve
+theorem kw_kwVeluMapEquationAt_oddOrderSummingSet_odd
+    {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    {W : WeierstrassCurve F} {Q : W.toAffine.Point} {p : ℕ}
+    (hp3 : 3 ≤ p) (hpodd : Odd p) (hord : addOrderOf Q = p) (hΔW : W.Δ ≠ 0) :
+    W.KwVeluMapEquationAt (W.oddOrderSummingSet Q ((p - 1) / 2)) := by
+  have : W.IsElliptic := ⟨(Ne.isUnit hΔW)⟩
+  intro r s hrs hav
+  have hQ : addOrderOf Q = 2 * ((p - 1) / 2) + 1 := by
+    obtain ⟨k, hk⟩ := hpodd
+    rw [hord, hk]; omega
+  exact velu_map_equation_of_oddOrderSummingSet (two_ne_zero) W ((p - 1) / 2) Q hQ hrs hav
+
+end WeierstrassCurve
+
+section
+
+
+namespace WeierstrassCurve
+universe u
+
+variable {F : Type u} [Field F]
+
+section DeficitZeroOdd
+
+variable [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : WeierstrassCurve F} {Q : W.toAffine.Point} {p : ℕ}
+
+theorem kw_veluDeficitFun_oddOrderSummingSet_eq_zero_odd
+    (hp3 : 3 ≤ p) (hpodd : Odd p) (hord : addOrderOf Q = p) (hΔW : W.Δ ≠ 0) :
+    W.toAffine.veluDeficitFun (W.oddOrderSummingSet Q ((p - 1) / 2)) = 0 := by
+  have hQ0 : Q ≠ 0 := by intro h; rw [h, addOrderOf_zero] at hord; omega
+  obtain ⟨x₀, y₀, h₀, rfl, -⟩ := exists_some_of_ne_zero hQ0
+  set S := W.oddOrderSummingSet (Point.some x₀ y₀ h₀) ((p - 1) / 2) with hS
+  have : HasPrincipalDivisors F W.toAffine.FunctionField := veluHPDSupplier F W hΔW
+  have : IsDedekindDomain W.toAffine.CoordinateRing :=
+    Affine.CoordinateRing.isDedekindDomain_of_Δ_ne_zero hΔW
+  have hreg := kw_veluDeficitFunOrdNonnegAt_odd (F := F)
+    (fun V hΔV => Affine.CoordinateRing.isDedekindDomain_of_Δ_ne_zero hΔV)
+    hp3 hpodd W hΔW x₀ y₀ h₀ hord
+  obtain ⟨c, hc⟩ := Affine.functionField_liouville_of_equation (W := W.toAffine) h₀.1 hreg
+  obtain ⟨r, s, hrs, hrav⟩ := kw_exists_equation_avoids W (S.image Prod.fst)
+  have hav : ∀ A ∈ S, r ≠ A.1 := fun A hA =>
+    hrav A.1 (Finset.mem_image.mpr ⟨A, hA, rfl⟩)
+  have hspec := veluDeficitFunSpecializesConstAt_unconditional' F p W hΔW x₀ y₀ h₀ hord c hc
+    hrs hav
+  have hcst := kw_veluDeficitConstancyAt_odd (F := F) hp3 hpodd W hΔW x₀ y₀ h₀ hord hrs hav
+  rw [hc, show c = 0 from hspec.symm.trans hcst]
+  exact (algebraMap F W.toAffine.FunctionField).map_zero
+
+theorem kw_equation_map_veluQuotient_kwVeluGenFun_odd
+    (hp3 : 3 ≤ p) (hpodd : Odd p) (hord : addOrderOf Q = p) (hΔW : W.Δ ≠ 0) :
+    ((W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).map
+        (algebraMap F W.toAffine.FunctionField)).toAffine.Equation
+      (kwVeluXGenFun W.toAffine (W.oddOrderSummingSet Q ((p - 1) / 2)))
+      (kwVeluYGenFun W.toAffine (W.oddOrderSummingSet Q ((p - 1) / 2))) := by
+  set S := W.oddOrderSummingSet Q ((p - 1) / 2)
+  have key := (W.toAffine.veluDeficitFun_eq_zero_iff_equation S).mp
+    (kw_veluDeficitFun_oddOrderSummingSet_eq_zero_odd hp3 hpodd hord hΔW)
+  rwa [W.toAffine.map_veluQuotient_liftSummingSet S] at key
+
+end DeficitZeroOdd
+
+section InclusionOdd
+
+variable [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : WeierstrassCurve F} [W.toAffine.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W.toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem W.toAffine] {Q : W.toAffine.Point} {p : ℕ}
+variable (hp3 : 3 ≤ p) (hpodd : Odd p) (hord : addOrderOf Q = p)
+
+include hp3 hpodd hord in
+omit [W.toAffine.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W.toAffine]
+  [W.toAffine.AbelTheorem] in
+theorem kw_eval₂_polynomial_kwVeluGenFun_odd :
+    ((W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).toAffine.polynomial).eval₂
+        (Polynomial.aeval
+            (kwVeluXGenFun W.toAffine (W.oddOrderSummingSet Q ((p - 1) / 2))) :
+          F[X] →ₐ[F] W.toAffine.FunctionField).toRingHom
+        (kwVeluYGenFun W.toAffine (W.oddOrderSummingSet Q ((p - 1) / 2))) = 0 := by
+  have heq := kw_equation_map_veluQuotient_kwVeluGenFun_odd hp3 hpodd hord
+    W.toAffine.isUnit_Δ.ne_zero
+  rw [equation_iff'] at heq
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆] at heq
+  simp only [WeierstrassCurve.Affine.polynomial, eval₂_add, eval₂_sub, eval₂_mul, eval₂_pow,
+    eval₂_X, eval₂_C, AlgHom.toRingHom_eq_coe, RingHom.coe_coe, map_add, map_mul, map_pow,
+    Polynomial.aeval_C, Polynomial.aeval_X]
+  linear_combination heq
+
+def kw_oddOrderSummingSetCoordHom_odd :
+    (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).toAffine.CoordinateRing
+      →ₐ[F] W.toAffine.FunctionField where
+  __ := AdjoinRoot.lift
+    (Polynomial.aeval (kwVeluXGenFun W.toAffine (W.oddOrderSummingSet Q ((p - 1) / 2))) :
+      F[X] →ₐ[F] W.toAffine.FunctionField).toRingHom
+    (kwVeluYGenFun W.toAffine (W.oddOrderSummingSet Q ((p - 1) / 2)))
+    (kw_eval₂_polynomial_kwVeluGenFun_odd hp3 hpodd hord)
+  commutes' c := by
+    change AdjoinRoot.lift _ _ (kw_eval₂_polynomial_kwVeluGenFun_odd hp3 hpodd hord)
+      (algebraMap F _ c) = algebraMap F W.toAffine.FunctionField c
+    rw [CoordinateRing.algebraMap_eq_mk_C_C, AdjoinRoot.lift_mk, eval₂_C]
+    exact Polynomial.aeval_C _ c
+
+omit [W.toAffine.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W.toAffine]
+  [W.toAffine.AbelTheorem] in
+theorem kw_oddOrderSummingSetCoordHom_odd_mk (g : F[X][Y]) :
+    kw_oddOrderSummingSetCoordHom_odd hp3 hpodd hord
+        (CoordinateRing.mk
+          (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).toAffine g)
+      = g.eval₂
+          (Polynomial.aeval
+              (kwVeluXGenFun W.toAffine (W.oddOrderSummingSet Q ((p - 1) / 2))) :
+            F[X] →ₐ[F] W.toAffine.FunctionField).toRingHom
+          (kwVeluYGenFun W.toAffine (W.oddOrderSummingSet Q ((p - 1) / 2))) :=
+  AdjoinRoot.lift_mk (kw_eval₂_polynomial_kwVeluGenFun_odd hp3 hpodd hord) g
+
+omit [W.toAffine.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W.toAffine]
+  [W.toAffine.AbelTheorem] in
+theorem kw_oddOrderSummingSetCoordHom_odd_comp_algebraMap :
+    (kw_oddOrderSummingSetCoordHom_odd hp3 hpodd hord).toRingHom.comp
+        (algebraMap F[X]
+          (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).toAffine.CoordinateRing)
+      = (Polynomial.aeval
+            (kwVeluXGenFun W.toAffine (W.oddOrderSummingSet Q ((p - 1) / 2))) :
+          F[X] →ₐ[F] W.toAffine.FunctionField).toRingHom := by
+  refine RingHom.ext fun q => ?_
+  change kw_oddOrderSummingSetCoordHom_odd hp3 hpodd hord (algebraMap F[X] _ q) = _
+  rw [algebraMap_polynomial_eq_mk_C, kw_oddOrderSummingSetCoordHom_odd_mk, eval₂_C]
+
+omit [W.toAffine.AbelTheorem] in
+theorem kw_oddOrderSummingSetCoordHom_odd_injective :
+    Function.Injective (kw_oddOrderSummingSetCoordHom_odd (W := W) hp3 hpodd hord) := by
+  have hker : RingHom.ker (kw_oddOrderSummingSetCoordHom_odd (W := W) hp3 hpodd hord).toRingHom
+      = ⊥ := by
+    have : Module.Finite F[X]
+        (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).toAffine.CoordinateRing :=
+      Module.Finite.of_basis (CoordinateRing.basis
+        (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).toAffine)
+    refine Ideal.eq_bot_of_under_eq_bot (R := F[X]) ?_
+    rw [Ideal.under_def, RingHom.comap_ker, kw_oddOrderSummingSetCoordHom_odd_comp_algebraMap,
+      ← RingHom.injective_iff_ker_eq_bot]
+    exact kw_aeval_kwVeluXGenFun_injective (W := W) _
+  exact (RingHom.injective_iff_ker_eq_bot
+    (kw_oddOrderSummingSetCoordHom_odd (W := W) hp3 hpodd hord).toRingHom).mpr hker
+
+def kw_oddOrderSummingSetFunctionFieldHom_odd :
+    (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).toAffine.FunctionField
+      →ₐ[F] W.toAffine.FunctionField :=
+  IsFractionRing.liftAlgHom (kw_oddOrderSummingSetCoordHom_odd_injective hp3 hpodd hord)
+
+omit [W.toAffine.AbelTheorem] in
+theorem kw_oddOrderSummingSetFunctionFieldHom_odd_algebraMap
+    (r : (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).toAffine.CoordinateRing) :
+    kw_oddOrderSummingSetFunctionFieldHom_odd hp3 hpodd hord
+        (algebraMap
+          (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).toAffine.CoordinateRing
+          (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).toAffine.FunctionField r)
+      = kw_oddOrderSummingSetCoordHom_odd hp3 hpodd hord r :=
+  IsFractionRing.lift_algebraMap (kw_oddOrderSummingSetCoordHom_odd_injective hp3 hpodd hord) r
+
+omit [W.toAffine.AbelTheorem] in
+theorem kw_oddOrderSummingSetFunctionFieldHom_odd_polyToFunctionField_X :
+    kw_oddOrderSummingSetFunctionFieldHom_odd (W := W) hp3 hpodd hord
+        (polyToFunctionField
+          (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).toAffine X)
+      = kwVeluXGenFun W.toAffine (W.oddOrderSummingSet Q ((p - 1) / 2)) := by
+  rw [polyToFunctionField_apply, kw_oddOrderSummingSetFunctionFieldHom_odd_algebraMap,
+    algebraMap_polynomial_eq_mk_C, kw_oddOrderSummingSetCoordHom_odd_mk, eval₂_C]
+  exact Polynomial.aeval_X _
+
+omit [W.toAffine.AbelTheorem] in
+theorem kw_oddOrderSummingSetFunctionFieldHom_odd_yGen :
+    kw_oddOrderSummingSetFunctionFieldHom_odd (W := W) hp3 hpodd hord
+        (yGen (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).toAffine)
+      = kwVeluYGenFun W.toAffine (W.oddOrderSummingSet Q ((p - 1) / 2)) := by
+  change kw_oddOrderSummingSetFunctionFieldHom_odd hp3 hpodd hord
+      (algebraMap _ _ (CoordinateRing.mk _ Y)) = _
+  rw [kw_oddOrderSummingSetFunctionFieldHom_odd_algebraMap,
+    kw_oddOrderSummingSetCoordHom_odd_mk]
+  exact eval₂_X _ _
+
+end InclusionOdd
+
+section IntegralityOdd
+
+variable [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : WeierstrassCurve F} [W.toAffine.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W.toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem W.toAffine] {Q : W.toAffine.Point} {p : ℕ}
+variable (hp3 : 3 ≤ p) (hpodd : Odd p) (hord : addOrderOf Q = p)
+
+local notation "S_Q" => W.oddOrderSummingSet Q ((p - 1) / 2)
+set_option quotPrecheck false in
+local notation "V'" => (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).toAffine
+local notation "ι" => kw_oddOrderSummingSetFunctionFieldHom_odd (W := W) hp3 hpodd hord
+
+include hp3 hpodd hord in
+omit [W.toAffine.AbelTheorem] in
+theorem kw_isIntegral_polyToFunctionField_X_oddOrderSummingSet_odd :
+    letI : Algebra (V').FunctionField W.toAffine.FunctionField := (ι).toRingHom.toAlgebra
+    _root_.IsIntegral (V').FunctionField (polyToFunctionField W.toAffine X) := by
+  let : Algebra (V').FunctionField W.toAffine.FunctionField := (ι).toRingHom.toAlgebra
+  refine ⟨(veluXClearedPoly W S_Q).map (algebraMap F (V').FunctionField)
+      - C (polyToFunctionField V' X)
+          * ((veluXDenomPoly S_Q).map (algebraMap F (V').FunctionField)) ^ 2,
+    ?_, ?_⟩
+  · rw [sub_eq_add_neg]
+    refine (((veluXClearedPoly_monic W S_Q).1).map _).add_of_left ?_
+    rw [Polynomial.degree_neg]
+    calc (C (polyToFunctionField V' X)
+            * ((veluXDenomPoly S_Q).map (algebraMap F (V').FunctionField)) ^ 2).degree
+        ≤ _ := Polynomial.degree_le_natDegree
+      _ ≤ ((2 * (S_Q).card : ℕ) : WithBot ℕ) := by
+          refine Nat.cast_le.mpr (le_trans Polynomial.natDegree_mul_le ?_)
+          rw [Polynomial.natDegree_C, zero_add, natDegree_pow,
+            (veluXDenomPoly_monic S_Q).natDegree_map
+              (algebraMap F (V').FunctionField), natDegree_veluXDenomPoly]
+      _ < _ := by
+          rw [((veluXClearedPoly_monic W S_Q).1).degree_map,
+            Polynomial.degree_eq_natDegree ((veluXClearedPoly_monic W S_Q).1).ne_zero,
+            (veluXClearedPoly_monic W S_Q).2]
+          exact_mod_cast Nat.lt_succ_self _
+  · simp only [eval₂_sub, eval₂_mul, eval₂_pow, eval₂_C, eval₂_map]
+    rw [show ((algebraMap (V').FunctionField W.toAffine.FunctionField).comp
+            (algebraMap F (V').FunctionField))
+          = algebraMap F W.toAffine.FunctionField from
+        RingHom.ext fun c => (ι).commutes c,
+      ← Polynomial.eval_map, ← polyToFunctionField_eq_eval_map,
+      ← Polynomial.eval_map, ← polyToFunctionField_eq_eval_map,
+      show (algebraMap (V').FunctionField W.toAffine.FunctionField) (polyToFunctionField V' X)
+          = kwVeluXGenFun W.toAffine S_Q from
+        kw_oddOrderSummingSetFunctionFieldHom_odd_polyToFunctionField_X hp3 hpodd hord,
+      kw_kwVeluXGenFun_mul_denom_sq_eq_cleared, sub_self]
+
+include hp3 hpodd hord in
+omit [W.toAffine.AbelTheorem] in
+theorem kw_adjoin_X_yGen_eq_top_oddOrderSummingSet_odd :
+    letI : Algebra (V').FunctionField W.toAffine.FunctionField := (ι).toRingHom.toAlgebra
+    IntermediateField.adjoin (V').FunctionField
+        ({polyToFunctionField W.toAffine X, yGen W.toAffine} : Set W.toAffine.FunctionField)
+      = ⊤ := by
+  let : Algebra (V').FunctionField W.toAffine.FunctionField := (ι).toRingHom.toAlgebra
+  rw [eq_top_iff]
+  rintro z -
+  set L := IntermediateField.adjoin (V').FunctionField
+    ({polyToFunctionField W.toAffine X, yGen W.toAffine} : Set W.toAffine.FunctionField)
+  have hconst : ∀ c : F, algebraMap F W.toAffine.FunctionField c ∈ L := fun c => by
+    rw [← (ι).commutes c]; exact L.algebraMap_mem _
+  have hxmem : polyToFunctionField W.toAffine X ∈ L :=
+    IntermediateField.subset_adjoin _ _ (Set.mem_insert _ _)
+  have hymem : yGen W.toAffine ∈ L :=
+    IntermediateField.subset_adjoin _ _ (Set.mem_insert_of_mem _ rfl)
+  have hpoly : ∀ q : F[X], polyToFunctionField W.toAffine q ∈ L := fun q => by
+    induction q using Polynomial.induction_on' with
+    | add f g hf hg => rw [map_add]; exact add_mem hf hg
+    | monomial n c =>
+        rw [← C_mul_X_pow_eq_monomial, map_mul, map_pow, polyToFunctionField_C]
+        exact mul_mem (hconst c) (pow_mem hxmem n)
+  have hcr : ∀ r : W.toAffine.CoordinateRing,
+      algebraMap W.toAffine.CoordinateRing W.toAffine.FunctionField r ∈ L := fun r => by
+    obtain ⟨a, b, rfl⟩ := exists_smul_basis_eq r
+    rw [algebraMap_smul_basis]
+    exact add_mem (hpoly a) (mul_mem (hpoly b) hymem)
+  obtain ⟨a, b, _, hab⟩ := IsFractionRing.div_surjective (A := W.toAffine.CoordinateRing) z
+  rw [← hab]; exact div_mem (hcr a) (hcr b)
+
+include hp3 hpodd hord in
+omit [W.toAffine.AbelTheorem] in
+theorem kw_oddOrderSummingSetFunctionFieldHom_odd_finiteAlong :
+    FiniteAlong F (kw_oddOrderSummingSetFunctionFieldHom_odd (W := W) hp3 hpodd hord) := by
+  let : Algebra (V').FunctionField W.toAffine.FunctionField := (ι).toRingHom.toAlgebra
+  change Module.Finite (V').FunctionField W.toAffine.FunctionField
+  have hxint := kw_isIntegral_polyToFunctionField_X_oddOrderSummingSet_odd hp3 hpodd hord
+  set Lx := IntermediateField.adjoin (V').FunctionField
+    ({polyToFunctionField W.toAffine X} : Set W.toAffine.FunctionField) with hLx
+  have hxfd : FiniteDimensional (V').FunctionField Lx :=
+    IntermediateField.adjoin.finiteDimensional hxint
+  have hyint : _root_.IsIntegral Lx (yGen W.toAffine) := by
+    have hyFx : _root_.IsIntegral F[X] (yGen W.toAffine) := by
+      have : Module.Finite F[X] W.toAffine.CoordinateRing :=
+        Module.Finite.of_basis (CoordinateRing.basis W.toAffine)
+      change _root_.IsIntegral F[X]
+        (algebraMap W.toAffine.CoordinateRing W.toAffine.FunctionField
+          (CoordinateRing.mk W.toAffine Y))
+      exact ((Algebra.IsIntegral.of_finite F[X] W.toAffine.CoordinateRing).isIntegral _).map
+        (IsScalarTower.toAlgHom F[X] W.toAffine.CoordinateRing W.toAffine.FunctionField)
+    have halg : ∀ r : F[X], (algebraMap F[X] W.toAffine.FunctionField) r ∈ Lx := by
+      intro r
+      induction r using Polynomial.induction_on' with
+      | add f g hf hg => rw [map_add]; exact add_mem hf hg
+      | monomial n c =>
+          rw [← C_mul_X_pow_eq_monomial, map_mul, map_pow,
+            show algebraMap F[X] W.toAffine.FunctionField (C c)
+              = algebraMap F W.toAffine.FunctionField c from rfl,
+            show algebraMap F[X] W.toAffine.FunctionField X
+              = polyToFunctionField W.toAffine X from rfl,
+            ← (ι).commutes c]
+          exact mul_mem (IntermediateField.algebraMap_mem _ _)
+            (pow_mem (IntermediateField.mem_adjoin_simple_self _ _) n)
+    obtain ⟨q, hqmon, hq0⟩ := hyFx
+    let φ : F[X] →+* Lx :=
+      (algebraMap F[X] W.toAffine.FunctionField).codRestrict Lx.toSubring halg
+    refine ⟨q.map φ, hqmon.map φ, ?_⟩
+    rw [Polynomial.eval₂_map,
+      show (algebraMap Lx W.toAffine.FunctionField).comp φ
+          = algebraMap F[X] W.toAffine.FunctionField from RingHom.ext fun _ => rfl]
+    exact hq0
+  have hyint' : _root_.IsIntegral (V').FunctionField (yGen W.toAffine) :=
+    haveI : Algebra.IsIntegral (V').FunctionField Lx :=
+      Algebra.IsIntegral.of_finite (V').FunctionField Lx
+    isIntegral_trans (yGen W.toAffine) hyint
+  have hfd : FiniteDimensional (V').FunctionField
+      (IntermediateField.adjoin (V').FunctionField
+        ({polyToFunctionField W.toAffine X, yGen W.toAffine}
+          : Set W.toAffine.FunctionField)) := by
+    refine IntermediateField.finiteDimensional_adjoin fun z hz => ?_
+    rcases hz with rfl | rfl
+    · exact hxint
+    · exact hyint'
+  rw [kw_adjoin_X_yGen_eq_top_oddOrderSummingSet_odd hp3 hpodd hord] at hfd
+  exact (IntermediateField.topEquiv (F := (V').FunctionField)
+    (E := W.toAffine.FunctionField)).toLinearEquiv.finiteDimensional
+
+include hp3 hpodd hord in
+omit [W.toAffine.AbelTheorem] in
+theorem kw_oddOrderSummingSetFunctionFieldHom_odd_isIntegral :
+    (kw_oddOrderSummingSetFunctionFieldHom_odd (W := W) hp3 hpodd hord).toRingHom.IsIntegral
+    := by
+  let : Algebra (V').FunctionField W.toAffine.FunctionField := (ι).toRingHom.toAlgebra
+  have : Module.Finite (V').FunctionField W.toAffine.FunctionField :=
+    kw_oddOrderSummingSetFunctionFieldHom_odd_finiteAlong hp3 hpodd hord
+  exact fun z => (Algebra.IsIntegral.of_finite _ _).isIntegral z
+
+end IntegralityOdd
+
+section SeamCasesOdd
+
+variable [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : WeierstrassCurve F} [W.toAffine.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W.toAffine]
+    {Q : W.toAffine.Point} {p : ℕ}
+variable (hp3 : 3 ≤ p) (hpodd : Odd p) (hord : addOrderOf Q = p)
+
+local notation "S_Q" => W.oddOrderSummingSet Q ((p - 1) / 2)
+set_option quotPrecheck false in
+local notation "V'" => (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).toAffine
+local notation "ι" => kw_oddOrderSummingSetFunctionFieldHom_odd (W := W) hp3 hpodd hord
+local notation "hι" =>
+  kw_oddOrderSummingSetFunctionFieldHom_odd_isIntegral (W := W) hp3 hpodd hord
+
+include hp3 hpodd hord in
+omit [CharZero F] in
+theorem kw_kwVeluXGenFun_notMem_placeOfEquation_of_mem_odd
+    {r s : F} (hrs : W.toAffine.Equation r s) {A : F × F} (hA : A ∈ S_Q) (hrA : r = A.1) :
+    kwVeluXGenFun W.toAffine S_Q ∉ (placeOfEquation hrs).toValuationSubring := by
+  have hset := kw_isOddVeluSet_oddOrderSummingSet_odd (W := W) hp3 hpodd hord (le_refl _)
+  have hDne : (veluXDenomPoly (F := F) S_Q) ≠ 0 := (veluXDenomPoly_monic S_Q).ne_zero
+  have hNne : (veluXClearedPoly W S_Q) ≠ 0 := (veluXClearedPoly_monic W S_Q).1.ne_zero
+  have hDeval : (veluXDenomPoly (F := F) S_Q).eval r = 0 := by
+    subst hrA; unfold veluXDenomPoly
+    rw [eval_prod]; exact Finset.prod_eq_zero hA (by simp)
+  have hNeval : (veluXClearedPoly W S_Q).eval r ≠ 0 := by
+    subst hrA; exact kw_eval_veluXClearedPoly_ne_zero_of_mem W.toAffine S_Q hset hA
+  have hDord : 0 < (placeOfEquation hrs).ord
+      (polyToFunctionField W.toAffine (veluXDenomPoly S_Q)) :=
+    (ord_polyToFunctionField_pos_iff hrs hDne).mpr hDeval
+  have hNord : (placeOfEquation hrs).ord
+      (polyToFunctionField W.toAffine (veluXClearedPoly W S_Q)) = 0 :=
+    (ord_polyToFunctionField_eq_zero_iff hrs hNne).mpr hNeval
+  have hXne : kwVeluXGenFun W.toAffine S_Q ≠ 0 := fun h =>
+    kw_transcendental_kwVeluXGenFun (W := W) S_Q (h ▸ isAlgebraic_zero)
+  rw [AlgebraicCurve.Place.mem_iff_ord_nonneg (placeOfEquation hrs) hXne, not_le]
+  have hmul := (placeOfEquation hrs).ord_mul hXne
+    (pow_ne_zero 2 (polyToFunctionField_ne_zero hDne))
+  rw [kw_kwVeluXGenFun_mul_denom_sq_eq_cleared, hNord,
+    (placeOfEquation hrs).ord_pow] at hmul
+  push_cast at hmul
+  linarith
+
+omit [CharZero F] [W.toAffine.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W.toAffine] in
+theorem kw_kwVeluXGenFun_mem_placeOfEquation_of_ne_odd
+    {r s : F} (hrs : W.toAffine.Equation r s) (hS : ∀ A ∈ S_Q, r ≠ A.1) :
+    kwVeluXGenFun W.toAffine S_Q ∈ (placeOfEquation hrs).toValuationSubring := by
+  unfold kwVeluXGenFun WeierstrassCurve.veluX liftSummingSet
+  rw [Finset.sum_map]
+  simp only [Function.Embedding.coeFn_mk, Prod.map_fst, Prod.map_snd, map_veluT, map_veluU]
+  refine add_mem (polyToFunctionField_X_mem_placeOfEquation hrs)
+    (Subring.sum_mem _ fun A hA => ?_)
+  have hδ : (polyToFunctionField W.toAffine X - algebraMap F W.toAffine.FunctionField A.1)⁻¹
+      ∈ (placeOfEquation hrs).toValuationSubring := by
+    refine AlgebraicCurve.Place.mem_of_ord_nonneg (placeOfEquation hrs)
+      (inv_ne_zero (sub_ne_zero.mpr (polyToFunctionField_X_ne_algebraMap A.1))) ?_
+    rw [(placeOfEquation hrs).ord_inv, ord_X_sub_const_placeOfEquation_of_ne hrs (hS A hA)]
+    exact le_of_eq (_root_.neg_zero).symm
+  refine add_mem ?_ ?_
+  · rw [div_eq_mul_inv]; exact mul_mem ((placeOfEquation hrs).algebraMap_mem' _) hδ
+  · rw [div_eq_mul_inv, ← inv_pow]
+    exact mul_mem ((placeOfEquation hrs).algebraMap_mem' _) (pow_mem hδ 2)
+
+omit [CharZero F] [W.toAffine.GenusOnePlaceGate] [GenusOnePlaceGate.IsCentred W.toAffine] in
+theorem kw_kwVeluYGenFun_mem_placeOfEquation_of_ne_odd
+    {r s : F} (hrs : W.toAffine.Equation r s) (hS : ∀ A ∈ S_Q, r ≠ A.1) :
+    kwVeluYGenFun W.toAffine S_Q ∈ (placeOfEquation hrs).toValuationSubring := by
+  unfold kwVeluYGenFun WeierstrassCurve.veluY liftSummingSet
+  rw [Finset.sum_map]
+  simp only [Function.Embedding.coeFn_mk, Prod.map_fst, Prod.map_snd, map_veluT, map_veluU,
+    map_veluGx, map_veluGy, map_a₁, map_a₃]
+  refine sub_mem (yGen_mem_placeOfEquation hrs) (Subring.sum_mem _ fun A hA => ?_)
+  have hX := polyToFunctionField_X_mem_placeOfEquation hrs
+  have hY := yGen_mem_placeOfEquation hrs
+  have hF := fun c => (placeOfEquation hrs).algebraMap_mem' (c : F)
+  have hδ : (polyToFunctionField W.toAffine X - algebraMap F W.toAffine.FunctionField A.1)⁻¹
+      ∈ (placeOfEquation hrs).toValuationSubring := by
+    refine AlgebraicCurve.Place.mem_of_ord_nonneg (placeOfEquation hrs)
+      (inv_ne_zero (sub_ne_zero.mpr (polyToFunctionField_X_ne_algebraMap A.1))) ?_
+    rw [(placeOfEquation hrs).ord_inv, ord_X_sub_const_placeOfEquation_of_ne hrs (hS A hA)]
+    exact le_of_eq (_root_.neg_zero).symm
+  refine add_mem (add_mem ?_ ?_) ?_
+  · rw [div_eq_mul_inv, ← inv_pow]
+    exact mul_mem (mul_mem (hF _)
+      (add_mem (add_mem (mul_mem (ofNat_mem _ 2) hY) (mul_mem (hF _) hX)) (hF _)))
+      (pow_mem hδ 3)
+  · rw [div_eq_mul_inv, ← inv_pow]
+    exact mul_mem (mul_mem (hF _) (sub_mem (add_mem (mul_mem (hF _)
+      (sub_mem hX (hF _))) hY) (hF _))) (pow_mem hδ 2)
+  · rw [div_eq_mul_inv, ← inv_pow]
+    exact mul_mem (sub_mem (mul_mem (hF _) (hF _)) (mul_mem (hF _) (hF _))) (pow_mem hδ 2)
+
+include hp3 hpodd hord in
+theorem kw_map_XClass_oddOrderSummingSet_odd (c : F) :
+    (ι) (algebraMap (V').CoordinateRing (V').FunctionField (XClass V' c))
+      = kwVeluXGenFun W.toAffine S_Q - algebraMap F W.toAffine.FunctionField c := by
+  rw [show algebraMap (V').CoordinateRing (V').FunctionField (XClass V' c)
+        = polyToFunctionField V' (X : F[X]) - algebraMap F (V').FunctionField c by
+      rw [← polyToFunctionField_C, ← map_sub]; rfl,
+    map_sub, kw_oddOrderSummingSetFunctionFieldHom_odd_polyToFunctionField_X,
+    AlgHom.commutes]
+
+include hp3 hpodd hord in
+theorem kw_map_YClass_oddOrderSummingSet_odd (c : F) :
+    (ι) (algebraMap (V').CoordinateRing (V').FunctionField (YClass V' (C c)))
+      = kwVeluYGenFun W.toAffine S_Q - algebraMap F W.toAffine.FunctionField c := by
+  rw [show algebraMap (V').CoordinateRing (V').FunctionField (YClass V' (C c))
+        = yGen V' - algebraMap F (V').FunctionField c by
+      rw [YClass, map_sub, map_sub, yGen]; congr 1,
+    map_sub, kw_oddOrderSummingSetFunctionFieldHom_odd_yGen, AlgHom.commutes]
+
+include hp3 hpodd hord in
+theorem kw_kwVeluYGenFun_ne_algebraMap_odd (c : F) :
+    kwVeluYGenFun W.toAffine S_Q ≠ algebraMap F W.toAffine.FunctionField c := by
+  intro heq
+  have hinj : Function.Injective (ι) := (ι).toRingHom.injective
+  have hYne : (algebraMap (V').CoordinateRing (V').FunctionField) (YClass V' (C c)) ≠ 0 :=
+    (map_ne_zero_iff _
+      (IsFractionRing.injective (V').CoordinateRing (V').FunctionField)).mpr (YClass_ne_zero _)
+  exact hYne (hinj (by
+    rw [kw_map_YClass_oddOrderSummingSet_odd hp3 hpodd hord, heq, sub_self, _root_.map_zero]))
+
+variable [(W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).IsElliptic]
+  [WeierstrassCurve.Affine.GenusOnePlaceGate (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) /
+  2)))] [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred (W.veluQuotient (W.oddOrderSummingSet Q
+  ((p - 1) / 2)))] [WeierstrassCurve.Affine.AbelTheorem (W.veluQuotient (W.oddOrderSummingSet Q ((p
+  - 1) / 2)))]
+
+include hp3 hpodd hord in
+omit [AbelTheorem (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2)))] in
+theorem kw_restrictAlong_infinitePlace_oddOrderSummingSet_odd :
+    (InfinitePlace.place : Place F W.toAffine.FunctionField).restrictAlong (ι) (hι)
+      = (InfinitePlace.place : Place F (V').FunctionField) := by
+  refine InfinitePlace.eq_of_not_isFinitePlace _ ?_
+  intro hfin
+  refine kw_kwVeluXGenFun_notMem_of_not_isFinitePlace (S := S_Q)
+    (InfinitePlace.place : Place F W.toAffine.FunctionField) InfinitePlace.not_isFinitePlace ?_
+  rw [← kw_oddOrderSummingSetFunctionFieldHom_odd_polyToFunctionField_X hp3 hpodd hord]
+  exact hfin (algebraMap F[X] (V').CoordinateRing (X : F[X]))
+
+include hp3 hpodd hord in
+omit [AbelTheorem (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2)))] in
+theorem kw_restrictAlong_placeOfEquation_of_mem_oddOrderSummingSet_odd
+    {r s : F} (hrs : W.toAffine.Equation r s) {A : F × F} (hA : A ∈ S_Q) (hrA : r = A.1) :
+    (placeOfEquation hrs).restrictAlong (ι) (hι) = InfinitePlace.place := by
+  refine InfinitePlace.eq_of_not_isFinitePlace _ ?_
+  intro hfin
+  refine kw_kwVeluXGenFun_notMem_placeOfEquation_of_mem_odd hp3 hpodd hord hrs hA hrA ?_
+  rw [← kw_oddOrderSummingSetFunctionFieldHom_odd_polyToFunctionField_X hp3 hpodd hord]
+  exact hfin (algebraMap F[X] (V').CoordinateRing (X : F[X]))
+
+include hp3 hpodd hord in
+omit [GenusOnePlaceGate (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2)))]
+  [GenusOnePlaceGate.IsCentred (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2)))]
+  [AbelTheorem (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2)))] in
+theorem kw_restrictAlong_placeOfEquation_of_ne_oddOrderSummingSet_odd
+    {r s : F} (hrs : W.toAffine.Equation r s) (hS : ∀ A ∈ S_Q, r ≠ A.1)
+    (h' : (V').Equation (W.veluX S_Q r) (W.veluY S_Q r s)) :
+    (placeOfEquation hrs).restrictAlong (ι) (hι) = placeOfEquation h' := by
+  have hrat := isRational_placeOfEquation hrs
+  have hXmem := kw_kwVeluXGenFun_mem_placeOfEquation_of_ne_odd (W := W) (Q := Q) (p := p)
+    hrs hS
+  have hYmem := kw_kwVeluYGenFun_mem_placeOfEquation_of_ne_odd (W := W) (Q := Q) (p := p)
+    hrs hS
+  have hXeval : (placeOfEquation hrs).evalAt (kwVeluXGenFun W.toAffine S_Q) = W.veluX S_Q r :=
+    evalAt_veluX_liftSummingSet_placeOfEquation hrs hS
+  have hYeval : (placeOfEquation hrs).evalAt (kwVeluYGenFun W.toAffine S_Q)
+      = W.veluY S_Q r s :=
+    evalAt_veluY_liftSummingSet_placeOfEquation hrs hS
+  have hfin : IsFinitePlace ((placeOfEquation hrs).restrictAlong (ι) (hι)) :=
+    isFinitePlace_of_mem _ (by
+      rw [Place.mem_restrictAlong_iff,
+        kw_oddOrderSummingSetFunctionFieldHom_odd_polyToFunctionField_X hp3 hpodd hord]
+      exact hXmem)
+  refine eq_placeOfEquation_of_le_centre hfin h' ?_
+  rw [XYIdeal, Ideal.span_le]
+  intro g hg
+  simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hg
+  rcases hg with rfl | rfl
+  · rw [SetLike.mem_coe, hfin.mem_centre_iff_ord_ne_zero (XClass_ne_zero _),
+      Place.ord_restrictAlong_ne_zero_iff, kw_map_XClass_oddOrderSummingSet_odd hp3 hpodd hord]
+    have hXne : kwVeluXGenFun W.toAffine S_Q
+        - algebraMap F W.toAffine.FunctionField (W.veluX S_Q r) ≠ 0 :=
+      sub_ne_zero.mpr fun heq => (kw_transcendental_kwVeluXGenFun (W := W) S_Q)
+        (heq ▸ isAlgebraic_algebraMap _)
+    have := (placeOfEquation hrs).ord_sub_evalAt_pos hrat hXmem (hXeval ▸ hXne)
+    rw [hXeval] at this; omega
+  · rw [SetLike.mem_coe, hfin.mem_centre_iff_ord_ne_zero (YClass_ne_zero _),
+      Place.ord_restrictAlong_ne_zero_iff, kw_map_YClass_oddOrderSummingSet_odd hp3 hpodd hord]
+    have hYne : kwVeluYGenFun W.toAffine S_Q
+        - algebraMap F W.toAffine.FunctionField (W.veluY S_Q r s) ≠ 0 :=
+      sub_ne_zero.mpr (kw_kwVeluYGenFun_ne_algebraMap_odd hp3 hpodd hord _)
+    have := (placeOfEquation hrs).ord_sub_evalAt_pos hrat hYmem (hYeval ▸ hYne)
+    rw [hYeval] at this; omega
+
+local notation "hmapeq" =>
+  kw_kwVeluMapEquationAt_oddOrderSummingSet_odd (W := W) hp3 hpodd hord
+    W.toAffine.isUnit_Δ.ne_zero
+
+variable (hΔV : (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).Δ ≠ 0)
+
+include hp3 hpodd hord hΔV in
+omit [AbelTheorem (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2)))] in
+theorem kw_restrictAlong_placeOfPoint_kwVeluPointMap_odd (P : W.toAffine.Point) :
+    (placeOfPoint P).restrictAlong (ι) (hι)
+      = placeOfPoint (kwVeluPointMap (hmapeq) hΔV P) := by
+  cases P with
+  | zero =>
+      rw [kwVeluPointMap_zero, placeOfPoint_zero, placeOfPoint_zero]
+      exact kw_restrictAlong_infinitePlace_oddOrderSummingSet_odd hp3 hpodd hord
+  | some r s hns =>
+      classical
+      by_cases hx : ∀ A ∈ S_Q, r ≠ A.1
+      · rw [kwVeluPointMap_some_of_ne _ hΔV hns hx, placeOfPoint_some, placeOfPoint_some]
+        exact kw_restrictAlong_placeOfEquation_of_ne_oddOrderSummingSet_odd hp3 hpodd hord
+          hns.1 hx _
+      · simp only [not_forall, not_not] at hx
+        obtain ⟨A, hA, hrA⟩ := hx
+        rw [kwVeluPointMap_some_of_mem _ hΔV hns hA hrA, placeOfPoint_some]
+        exact (kw_restrictAlong_placeOfEquation_of_mem_oddOrderSummingSet_odd hp3 hpodd hord
+          hns.1 hA hrA).trans placeOfPoint_zero.symm
+
+end SeamCasesOdd
+end WeierstrassCurve
+end
+
+namespace WeierstrassCurve
+namespace Affine
+namespace IsogenyEndDatum
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve.Affine F)
+
+theorem isIntegral_algHomId :
+    (AlgHom.id F W.FunctionField).toRingHom.IsIntegral :=
+  RingHom.isIntegral_of_surjective _ Function.surjective_id
+
+theorem finiteAlong_algHomId : AlgebraicCurve.FiniteAlong F (AlgHom.id F W.FunctionField) := by
+  unfold AlgebraicCurve.FiniteAlong AlgebraicCurve.algebraAlong
+  exact Module.Finite.self _
+
+theorem restrictAlong_algHomId (w : AlgebraicCurve.Place F W.FunctionField) :
+    w.restrictAlong (AlgHom.id F W.FunctionField) (isIntegral_algHomId W) = w :=
+  AlgebraicCurve.Place.ext (SetLike.ext fun _ => Iff.rfl)
+
+end IsogenyEndDatum
+end Affine
+end WeierstrassCurve
+
+namespace WeierstrassCurve
+section S2cKernel
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F}
+variable {Q : W.toAffine.Point} {n : ℕ}
+
+theorem s2c_exists_fst_eq_of_mem_zmultiples (hord : addOrderOf Q = 2 * n + 1)
+    {x y : F} {h : W.toAffine.Nonsingular x y}
+    (hP : (Point.some x y h : W.toAffine.Point) ∈ AddSubgroup.zmultiples Q) :
+    ∃ A ∈ W.oddOrderSummingSet Q n, x = A.1 := by
+  have hpQ : (2 * n + 1) • Q = 0 := hord ▸ addOrderOf_nsmul_eq_zero Q
+  obtain ⟨m, hm⟩ := AddSubgroup.mem_zmultiples_iff.mp hP
+  have hP0 : (m % ((2 * n + 1 : ℕ) : ℤ)) • Q ≠ 0 := by
+    rw [← zsmul_eq_emod_zsmul_of_nsmul_eq_zero hpQ, hm]; exact Point.some_ne_zero h
+  have hr0 : 0 ≤ m % ((2 * n + 1 : ℕ) : ℤ) := Int.emod_nonneg m (by positivity)
+  obtain ⟨r, hr⟩ : ∃ r : ℕ, (r : ℤ) = m % ((2 * n + 1 : ℕ) : ℤ) := ⟨_, Int.toNat_of_nonneg hr0⟩
+  have hPr : (r • Q : W.toAffine.Point) = Point.some x y h := by
+    rw [← natCast_zsmul, hr, ← zsmul_eq_emod_zsmul_of_nsmul_eq_zero hpQ, hm]
+  rw [← hr, natCast_zsmul] at hP0
+  have hrlt : r < 2 * n + 1 := by
+    have := Int.emod_lt_of_pos m (show (0 : ℤ) < ((2 * n + 1 : ℕ) : ℤ) by positivity)
+    omega
+  have hr1 : 1 ≤ r := by
+    rcases Nat.eq_zero_or_pos r with h0 | h0
+    · exact absurd (by rw [h0, zero_nsmul]) hP0
+    · exact h0
+  rcases le_or_gt r n with hle | hgt
+  · refine ⟨(r • Q).coordsOrZero, W.mem_oddOrderSummingSet.mpr ⟨r, hr1, hle, rfl⟩, ?_⟩
+    rw [hPr, Point.coordsOrZero_some]
+  · have hneg : ((2 * n + 1) - r) • Q = -(Point.some x y h) := by
+      rw [sub_nsmul_eq_neg_of_nsmul_eq_zero hpQ (by omega : r ≤ 2 * n + 1), hPr]
+    refine ⟨(((2 * n + 1) - r) • Q).coordsOrZero,
+      W.mem_oddOrderSummingSet.mpr ⟨(2 * n + 1) - r, by omega, by omega, rfl⟩, ?_⟩
+    rw [hneg, Affine.Point.neg_some, Point.coordsOrZero_some]
+
+theorem s2c_mem_zmultiples_of_fst_eq (hord : addOrderOf Q = 2 * n + 1)
+    {x y : F} (h : W.toAffine.Nonsingular x y)
+    (hA : ∃ A ∈ W.oddOrderSummingSet Q n, x = A.1) :
+    (Point.some x y h : W.toAffine.Point) ∈ AddSubgroup.zmultiples Q := by
+  obtain ⟨A, hAmem, hAx⟩ := hA
+  obtain ⟨k, hk1, hkn, hkA⟩ := W.mem_oddOrderSummingSet.mp hAmem
+  have hk0 : k • Q ≠ 0 := fun h0 =>
+    Nat.not_dvd_of_pos_of_lt (by omega) (by omega)
+      (hord ▸ addOrderOf_dvd_iff_nsmul_eq_zero.mpr h0)
+  obtain ⟨x', y', h', heq', hco⟩ := exists_some_of_ne_zero hk0
+  have hx : x = x' := by
+    rw [hAx, ← hkA, hco]
+  have hkmem : (k • Q : W.toAffine.Point) ∈ AddSubgroup.zmultiples Q :=
+    AddSubgroup.mem_zmultiples_iff.mpr ⟨(k : ℤ), natCast_zsmul Q k⟩
+  subst hx
+  rcases Affine.Y_eq_of_X_eq h.1 h'.1 rfl with hy | hy
+  · subst hy
+    rwa [heq'] at hkmem
+  · have hneg : (Point.some x y h : W.toAffine.Point) = -(Point.some x y' h') := by
+      rw [Affine.Point.neg_some]
+      exact (Point.some.injEq _ _ _ _ _ _).mpr ⟨rfl, hy⟩ ▸ rfl
+    rw [hneg, ← heq']
+    exact AddSubgroup.neg_mem _ hkmem
+
+end S2cKernel
+
+section S2cKey
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {W : WeierstrassCurve F} [W.toAffine.IsElliptic] {Q : W.toAffine.Point} {p : ℕ}
+
+theorem s2c_key (hp3 : 3 ≤ p) (hpodd : Odd p) (hord : addOrderOf Q = p)
+    (hΔV : (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).Δ ≠ 0)
+    [(W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).toAffine.IsElliptic]
+    [GenusOnePlaceGate W.toAffine] [GenusOnePlaceGate.IsCentred W.toAffine] [AbelTheorem W.toAffine]
+    [GenusOnePlaceGate (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).toAffine]
+    [GenusOnePlaceGate.IsCentred (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).toAffine]
+    [AbelTheorem (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).toAffine] :
+    ∃ (ι : (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).toAffine.FunctionField
+            →ₐ[F] W.toAffine.FunctionField)
+      (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong F ι),
+      finrankAlong F ι = addOrderOf Q
+        ∧ (∀ hN : NormFormulaAlong F ι hfin,
+            (pointMapOfPushforward ι hι hfin hN).ker = AddSubgroup.zmultiples Q)
+        ∧ (∀ P : W.toAffine.Point, P ∈ AddSubgroup.zmultiples Q →
+            (placeOfPoint P).restrictAlong ι hι
+              = placeOfPoint (0 : (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) /
+                2))).toAffine.Point))
+        ∧ (∀ (x y : F) (h : W.toAffine.Nonsingular x y),
+            Point.some x y h ∉ AddSubgroup.zmultiples Q →
+            ∃ h' : (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).toAffine.Nonsingular
+                (W.veluX (W.oddOrderSummingSet Q ((p - 1) / 2)) x)
+                (W.veluY (W.oddOrderSummingSet Q ((p - 1) / 2)) x y),
+              (placeOfPoint (Point.some x y h)).restrictAlong ι hι
+                = placeOfPoint (Point.some _ _ h')) := by
+  classical
+  have hn : addOrderOf Q = 2 * ((p - 1) / 2) + 1 := by
+    obtain ⟨k, hk⟩ := hpodd; rw [hord, hk]; omega
+  have hmapeq : W.KwVeluMapEquationAt (W.oddOrderSummingSet Q ((p - 1) / 2)) :=
+    kw_kwVeluMapEquationAt_oddOrderSummingSet_odd (W := W) hp3 hpodd hord
+      W.toAffine.isUnit_Δ.ne_zero
+  refine ⟨kw_oddOrderSummingSetFunctionFieldHom_odd (W := W) hp3 hpodd hord,
+    kw_oddOrderSummingSetFunctionFieldHom_odd_isIntegral (W := W) hp3 hpodd hord,
+    kw_oddOrderSummingSetFunctionFieldHom_odd_finiteAlong (W := W) hp3 hpodd hord, ?_⟩
+  set ι := kw_oddOrderSummingSetFunctionFieldHom_odd (W := W) hp3 hpodd hord
+  set hι := kw_oddOrderSummingSetFunctionFieldHom_odd_isIntegral (W := W) hp3 hpodd hord
+  set hfin := kw_oddOrderSummingSetFunctionFieldHom_odd_finiteAlong (W := W) hp3 hpodd hord
+  have hseam : ∀ P : W.toAffine.Point,
+      (placeOfPoint P).restrictAlong ι hι = placeOfPoint (kwVeluPointMap hmapeq hΔV P) :=
+    kw_restrictAlong_placeOfPoint_kwVeluPointMap_odd (W := W) hp3 hpodd hord hΔV
+  have hker : ∀ P : W.toAffine.Point,
+      kwVeluPointMap hmapeq hΔV P = 0 ↔ P ∈ AddSubgroup.zmultiples Q := by
+    intro P
+    cases P with
+    | zero => exact ⟨fun _ => AddSubgroup.zero_mem _, fun _ => rfl⟩
+    | some x y h =>
+      constructor
+      · intro h0
+        by_cases hx : ∀ A ∈ (W.oddOrderSummingSet Q ((p - 1) / 2)), x ≠ A.1
+        · rw [kwVeluPointMap_some_of_ne hmapeq hΔV h hx] at h0
+          exact absurd h0 (Point.some_ne_zero _)
+        · simp only [not_forall, not_not] at hx
+          obtain ⟨A, hA, hxA⟩ := hx
+          exact s2c_mem_zmultiples_of_fst_eq hn h ⟨A, hA, hxA⟩
+      · intro hP
+        obtain ⟨A, hA, hxA⟩ := s2c_exists_fst_eq_of_mem_zmultiples hn hP
+        exact kwVeluPointMap_some_of_mem hmapeq hΔV h hA hxA
+  have hpm : ∀ (hN : NormFormulaAlong F ι hfin) (P : W.toAffine.Point),
+      pointMapOfPushforward ι hι hfin hN P = kwVeluPointMap hmapeq hΔV P :=
+    fun hN P => pointMapOfPushforward_eq_of_seam ι hι hfin hN _ rfl hseam P
+  have hkerN : ∀ hN : NormFormulaAlong F ι hfin,
+      (pointMapOfPushforward ι hι hfin hN).ker = AddSubgroup.zmultiples Q := by
+    intro hN; ext P
+    rw [AddMonoidHom.mem_ker, hpm hN P]
+    exact hker P
+  refine ⟨?_, hkerN, ?_, ?_⟩
+  · have hN₀ : NormFormulaAlong F ι hfin := normFormulaAlong_of_elliptic ι hfin
+    rw [← natCard_ker_pointMapOfPushforward_eq_finrankAlong W.toAffine
+      (W.veluQuotient (W.oddOrderSummingSet Q ((p - 1) / 2))).toAffine ι hι hfin hN₀, hkerN hN₀,
+      Nat.card_zmultiples]
+  · intro P hP
+    rw [hseam P, (hker P).mpr hP]
+  · intro x y h hP
+    have hx : ∀ A ∈ (W.oddOrderSummingSet Q ((p - 1) / 2)), x ≠ A.1 := by
+      intro A hA hxA
+      exact hP (s2c_mem_zmultiples_of_fst_eq hn h ⟨A, hA, hxA⟩)
+    exact ⟨kw_velu_map_nonsingular hmapeq hΔV h.1 hx, by
+      rw [hseam, kwVeluPointMap_some_of_ne hmapeq hΔV h hx]⟩
+
+omit [CharZero F] in
+theorem s2c_zero (V : WeierstrassCurve F) (hVW : V = W)
+    [V.toAffine.IsElliptic]
+    [gW : GenusOnePlaceGate W.toAffine] [cW : GenusOnePlaceGate.IsCentred W.toAffine]
+    [aW : AbelTheorem W.toAffine]
+    [gV : GenusOnePlaceGate V.toAffine] [cV : GenusOnePlaceGate.IsCentred V.toAffine]
+    [aV : AbelTheorem V.toAffine]
+    (hQ : Q = 0) (S : Finset (F × F)) (hS : S = ∅) :
+    ∃ (ι : V.toAffine.FunctionField →ₐ[F] W.toAffine.FunctionField)
+      (hι : ι.toRingHom.IsIntegral) (hfin : FiniteAlong F ι),
+      finrankAlong F ι = addOrderOf Q
+        ∧ (∀ hN : NormFormulaAlong F ι hfin,
+            (pointMapOfPushforward ι hι hfin hN).ker = AddSubgroup.zmultiples Q)
+        ∧ (∀ P : W.toAffine.Point, P ∈ AddSubgroup.zmultiples Q →
+            (placeOfPoint P).restrictAlong ι hι = placeOfPoint (0 : V.toAffine.Point))
+        ∧ (∀ (x y : F) (h : W.toAffine.Nonsingular x y),
+            Point.some x y h ∉ AddSubgroup.zmultiples Q →
+            ∃ h' : V.toAffine.Nonsingular (W.veluX S x) (W.veluY S x y),
+              (placeOfPoint (Point.some x y h)).restrictAlong ι hι
+                = placeOfPoint (Point.some _ _ h')) := by
+  subst hVW; subst hQ; subst hS
+  have : IsDedekindDomain V.toAffine.CoordinateRing := CoordinateRing.isDedekindDomain V
+  have hgg : gV = gW := GenusOnePlaceGate.ext_of_isCentred gV gW cV cW
+  subst hgg
+  refine ⟨AlgHom.id F _, IsogenyEndDatum.isIntegral_algHomId V.toAffine,
+    IsogenyEndDatum.finiteAlong_algHomId V.toAffine, ?_, ?_, ?_, ?_⟩
+  · rw [addOrderOf_zero]
+    let := algebraAlong (AlgHom.id F V.toAffine.FunctionField)
+    change Module.finrank V.toAffine.FunctionField V.toAffine.FunctionField = 1
+    convert Module.finrank_self V.toAffine.FunctionField
+  · intro hN
+    rw [AddSubgroup.zmultiples_zero_eq_bot, AddMonoidHom.ker_eq_bot_iff]
+    intro P₁ P₂ h12
+    have h1 :=
+      pointMapOfPushforward_eq_of_seam (AlgHom.id F _) (IsogenyEndDatum.isIntegral_algHomId
+        V.toAffine)
+      (IsogenyEndDatum.finiteAlong_algHomId V.toAffine) hN id rfl
+      (fun P => IsogenyEndDatum.restrictAlong_algHomId V.toAffine (placeOfPoint P))
+    rw [h1, h1] at h12
+    exact h12
+  · intro P hP
+    rw [AddSubgroup.zmultiples_zero_eq_bot, AddSubgroup.mem_bot] at hP
+    subst hP
+    exact IsogenyEndDatum.restrictAlong_algHomId V.toAffine (placeOfPoint (0 : V.toAffine.Point))
+  · intro x y h _
+    have hX : V.veluX ∅ x = x := by simp [WeierstrassCurve.veluX]
+    have hY : V.veluY ∅ x y = y := by simp [WeierstrassCurve.veluY]
+    refine ⟨by rw [hX, hY]; exact h, ?_⟩
+    rw [IsogenyEndDatum.restrictAlong_algHomId V.toAffine]
+    congr 1
+    exact (Point.some.injEq _ _ _ _ _ _).mpr ⟨hX.symm, hY.symm⟩ ▸ rfl
+
+end S2cKey
+end WeierstrassCurve
+
+theorem solution
+    {F : Type*} [Field F] [DecidableEq F] [CharZero F] [IsAlgClosed F]
+    {W : WeierstrassCurve F} [W.IsElliptic]
+    {Q : W.toAffine.Point} {n : ℕ} (hord : addOrderOf Q = 2 * n + 1)
+    (hΔ' : (W.veluQuotient (W.oddOrderSummingSet Q n)).Δ ≠ 0)
+    [(W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W.toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine] :
+    ∃ (ι : (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.FunctionField
+            →ₐ[F] W.toAffine.FunctionField)
+      (hι : ι.toRingHom.IsIntegral) (hfin : AlgebraicCurve.FiniteAlong F ι),
+      AlgebraicCurve.finrankAlong F ι = 2 * n + 1
+        ∧ (∀ hN : AlgebraicCurve.NormFormulaAlong F ι hfin,
+            (WeierstrassCurve.Affine.pointMapOfPushforward ι hι hfin hN).ker
+              = AddSubgroup.zmultiples Q)
+        ∧ (∀ P : W.toAffine.Point, P ∈ AddSubgroup.zmultiples Q →
+            (WeierstrassCurve.Affine.placeOfPoint P).restrictAlong ι hι
+              = WeierstrassCurve.Affine.placeOfPoint
+                  (0 : (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.Point))
+        ∧ (∀ (x y : F) (h : W.toAffine.Nonsingular x y),
+            WeierstrassCurve.Affine.Point.some x y h ∉ AddSubgroup.zmultiples Q →
+            ∃ h' : (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.Nonsingular
+                (W.veluX (W.oddOrderSummingSet Q n) x) (W.veluY (W.oddOrderSummingSet Q n) x y),
+              (WeierstrassCurve.Affine.placeOfPoint (WeierstrassCurve.Affine.Point.some x y
+                h)).restrictAlong ι hι
+                = WeierstrassCurve.Affine.placeOfPoint (WeierstrassCurve.Affine.Point.some _ _ h'))
+                  := by
+  have : W.toAffine.IsElliptic := ‹W.IsElliptic›
+  rw [← hord]
+  rcases Nat.eq_zero_or_pos n with hn0 | hnpos
+  · subst hn0
+    have hQ : Q = 0 := by rwa [Nat.mul_zero, Nat.zero_add, AddMonoid.addOrderOf_eq_one_iff] at hord
+    have hS : W.oddOrderSummingSet Q 0 = ∅ := by
+      simp [WeierstrassCurve.oddOrderSummingSet]
+    have hV : W.veluQuotient (W.oddOrderSummingSet Q 0) = W := by
+      rw [hS]; simp [WeierstrassCurve.veluQuotient]
+    exact s2c_zero (W.veluQuotient (W.oddOrderSummingSet Q 0)) hV hQ _ hS
+  · have hhalf : n = (2 * n + 1 - 1) / 2 := by omega
+    revert hΔ'
+    rename_i i1 i2 i3 i4 i5 i6 i7
+    revert i1 i5 i6 i7
+    rw [hhalf]
+    intro i1 i5 i6 i7 hΔ'
+    exact s2c_key (W := W) (by omega) ⟨n, by ring⟩ hord hΔ'
+
+end
+end
+end
+end
+end
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.exists_veluFunctionFieldHom_restrictAlong_placeOfPoint_eq
+    {F : Type*} [Field F] [DecidableEq F] [CharZero F] [IsAlgClosed F]
+    {W : WeierstrassCurve F} [W.IsElliptic]
+    {Q : W.toAffine.Point} {n : ℕ} (hord : addOrderOf Q = 2 * n + 1)
+    (hΔ' : (W.veluQuotient (W.oddOrderSummingSet Q n)).Δ ≠ 0)
+    [(W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.IsElliptic]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred W.toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem W.toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine]
+    [WeierstrassCurve.Affine.GenusOnePlaceGate.IsCentred
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine]
+    [WeierstrassCurve.Affine.AbelTheorem
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine] :
+    ∃ (ι : (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.FunctionField
+            →ₐ[F] W.toAffine.FunctionField)
+      (hι : ι.toRingHom.IsIntegral) (hfin : AlgebraicCurve.FiniteAlong F ι),
+      AlgebraicCurve.finrankAlong F ι = 2 * n + 1
+        ∧ (∀ hN : AlgebraicCurve.NormFormulaAlong F ι hfin,
+            (WeierstrassCurve.Affine.pointMapOfPushforward ι hι hfin hN).ker
+              = AddSubgroup.zmultiples Q)
+        ∧ (∀ P : W.toAffine.Point, P ∈ AddSubgroup.zmultiples Q →
+            (WeierstrassCurve.Affine.placeOfPoint P).restrictAlong ι hι
+              = WeierstrassCurve.Affine.placeOfPoint
+                  (0 : (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.Point))
+        ∧ (∀ (x y : F) (h : W.toAffine.Nonsingular x y),
+            WeierstrassCurve.Affine.Point.some x y h ∉ AddSubgroup.zmultiples Q →
+            ∃ h' : (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.Nonsingular
+                (W.veluX (W.oddOrderSummingSet Q n) x) (W.veluY (W.oddOrderSummingSet Q n) x y),
+              (WeierstrassCurve.Affine.placeOfPoint (WeierstrassCurve.Affine.Point.some x y
+                h)).restrictAlong ι hι
+                = WeierstrassCurve.Affine.placeOfPoint (WeierstrassCurve.Affine.Point.some _ _ h'))
+                  := _root_.solution hord hΔ'
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_fiberAdd_asymWeight_cleared_sixteen.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_fiberAdd_asymWeight_cleared_sixteen.lean
new file mode 100644
index 0000000000..f64ef79c90
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_fiberAdd_asymWeight_cleared_sixteen.lean
@@ -0,0 +1,185 @@
+/-
+Based on Prove2Me node WeierstrassCurve.fiberAdd_asymWeight_cleared_sixteen
+(13e94a81-2b62-52f3-a547-c7005fc94dea) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission e0614502-5484-5ca5-884e-483917045a8c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_Velu
+
+/-!
+# Additivity of the Vélu weight across a 2-isogeny fibre
+
+Theorem statement: `WeierstrassCurve.fiberAdd_asymWeight_cleared_sixteen`
+(`13e94a81-2b62-52f3-a547-c7005fc94dea`), by Claude, 2026-09-05.
+
+Proof: submission `e0614502-5484-5ca5-884e-483917045a8c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring, $W$ a Weierstrass curve over $R$ with coefficients
+$a_1,a_2,a_3,a_4,a_6$, and $x,y,x_0,y_0 \in R$ such that $(x,y)$ and $(x_0,y_0)$ both satisfy the
+affine Weierstrass equation of $W$, and such that `W.veluGy x₀ y₀` $= -(2y_0 + a_1x_0 + a_3)$
+vanishes. Write $g_x(u,v) = 3u^2 + 2a_2u + a_4 - a_1v$ and $g_y(u,v) = -(2v + a_1u + a_3)$ for the
+two partial derivative expressions, $d = x - x_0$, $t_0 = g_x(x_0,y_0)$, and set $X = (y-y_0)^2 +
+a_1(y-y_0)d - (a_2+x+x_0)d^2$, $Y = (y-y_0)(xd^2 - X) - yd^3 - a_1Xd - a_3d^3$ (the cleared
+coordinates $d^2x_3$, $d^3y_3$ of the chord-law sum of the two points), and $X' = xd + t_0$, $Y' =
+yd^2 - t_0(a_1d + y - y_0)$ (the cleared coordinates of the Vélu image of $(x,y)$). Then the
+identity
+$$16\bigl[(xg_x(x,y) - yg_y(x,y))d^6 + X(3X^2 + 2a_2Xd^2 + a_4d^4 - a_1Yd) - Y\bigl(-(2Y + a_1Xd +
+a_3d^3)\bigr)\bigr]$$
+$$= 16\bigl[X'\bigl(3X'^2 + 2a_2X'd + (a_4 - 5t_0)d^2 - a_1Y'\bigr)d^3 - Y'\bigl(-(2Y' + a_1X'd +
+a_3d^2)\bigr)d^2\bigr]$$
+holds in $R$, the expressions being written out in full in the Lean statement.
+
+Both sides are $16d^6$ times the weight $w = ug_x(u,v) - vg_y(u,v)$: the left-hand side its value at
+$(x,y)$ plus at the chord-law sum with the 2-torsion point $(x_0,y_0)$, the right-hand side the
+corresponding weight for the Vélu quotient curve (with $a_4$ replaced by $a_4 - 5t_0$) at the image
+point; thus the weight is additive along the fibres of the quotient 2-isogeny, with denominators
+cleared and the factor $16$ inserted to absorb $2y_0 = -a_1x_0 - a_3$. It feeds the computation of
+Vélu quotient data for kernels containing a point of order two, used in identifying the quotient by
+a cyclic subgroup of even order with a successive quotient, and hence in the analysis of kernels of
+isogenies of Tate curves and of the associated function-field embeddings.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_fiberAdd_asymWeight_cleared_sixteen.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace WeierstrassCurve
+
+-- Translating by the two-torsion point makes the cleared chord coordinates linear in veluGx.
+private theorem fiberAdd_coordinates {R : Type*} [CommRing R]
+    (W : WeierstrassCurve R) (x y x₀ y₀ : R)
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) :
+    (y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀)
+        - (W.a₂ + x + x₀) * (x - x₀) ^ 2
+      = x₀ * (x - x₀) ^ 2 + W.veluGx x₀ y₀ * (x - x₀) ∧
+    (y - y₀) * (x * (x - x₀) ^ 2
+        - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀)
+          - (W.a₂ + x + x₀) * (x - x₀) ^ 2))
+        - y * (x - x₀) ^ 3
+        - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀)
+          - (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (x - x₀)
+        - W.a₃ * (x - x₀) ^ 3
+      = y₀ * (x - x₀) ^ 3
+        - W.veluGx x₀ y₀ * (x - x₀) * (y - y₀ + W.a₁ * (x - x₀)) := by
+  rw [Affine.equation_iff] at hP hQ
+  simp only [veluGy] at hgy
+  have hn : (y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀)
+      - (W.a₂ + x + x₀) * (x - x₀) ^ 2
+      = x₀ * (x - x₀) ^ 2 + W.veluGx x₀ y₀ * (x - x₀) := by
+    simp only [veluGx]
+    linear_combination hP - hQ + (y - y₀) * hgy
+  refine ⟨hn, ?_⟩
+  rw [hn]
+  linear_combination (x - x₀) ^ 3 * hgy
+
+private theorem fiberAdd_asymWeight_cleared_sixteen_aux {R : Type*} [CommRing R] (W :
+    WeierstrassCurve R) (x y x₀ y₀ : R)
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) :
+    16 * ((x * W.veluGx x y - y * W.veluGy x y) * (x - x₀) ^ 6 + (((y - y₀) ^ 2 + W.a₁ * (y - y₀) *
+        (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (3 * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀)
+        - (W.a₂ + x + x₀) * (x - x₀) ^ 2) ^ 2 + 2 * W.a₂ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x -
+        x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (x - x₀) ^ 2 + W.a₄ * (x - x₀) ^ 4 - W.a₁ * ((y -
+        y₀) * (x * (x - x₀) ^ 2 - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x
+        - x₀) ^ 2)) - y * (x - x₀) ^ 3 - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ +
+        x + x₀) * (x - x₀) ^ 2) * (x - x₀) - W.a₃ * (x - x₀) ^ 3) * (x - x₀)) - ((y - y₀) * (x * (x
+        - x₀) ^ 2 - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2)) -
+        y * (x - x₀) ^ 3 - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x
+        - x₀) ^ 2) * (x - x₀) - W.a₃ * (x - x₀) ^ 3) * (-(2 * ((y - y₀) * (x * (x - x₀) ^ 2 - ((y -
+        y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2)) - y * (x - x₀) ^ 3 -
+        W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (x -
+        x₀) - W.a₃ * (x - x₀) ^ 3) + W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x +
+        x₀) * (x - x₀) ^ 2) * (x - x₀) + W.a₃ * (x - x₀) ^ 3))))
+      = 16 * ((x * (x - x₀) + W.veluGx x₀ y₀) * (3 * (x * (x - x₀) + W.veluGx x₀ y₀) ^ 2 + 2 * W.a₂
+          * (x * (x - x₀) + W.veluGx x₀ y₀) * (x - x₀) + (W.a₄ - 5 * W.veluGx x₀ y₀) * (x - x₀) ^ 2
+          - W.a₁ * (y * (x - x₀) ^ 2 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀))) * (x - x₀) ^ 3
+          - (y * (x - x₀) ^ 2 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀)) * (-(2 * (y * (x - x₀)
+          ^ 2 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀)) + W.a₁ * (x * (x - x₀) + W.veluGx x₀
+          y₀) * (x - x₀) + W.a₃ * (x - x₀) ^ 2)) * (x - x₀) ^ 2) := by
+  obtain ⟨hn, hm⟩ := fiberAdd_coordinates W x y x₀ y₀ hP hQ hgy
+  rw [hm, hn]
+  rw [Affine.equation_iff] at hP hQ
+  simp only [veluGy] at hgy
+  simp only [veluGx, veluGy]
+  -- With d = x - x₀, z = y - y₀ and t = veluGx x₀ y₀, the residual is
+  -- 64 d⁴ t times the translated curve equation, modulo the two-torsion relation.
+  linear_combination
+    (64 * (x - x₀) ^ 4 * (3 * x₀ ^ 2 + 2 * W.a₂ * x₀ + W.a₄ - W.a₁ * y₀))
+      * (hP - hQ)
+    + (64 * (x - x₀) ^ 4 * (3 * x₀ ^ 2 + 2 * W.a₂ * x₀ + W.a₄ - W.a₁ * y₀)
+        * (y - y₀) - 16 * y₀ * (x - x₀) ^ 6) * hgy
+
+end WeierstrassCurve
+
+open WeierstrassCurve
+
+theorem solution {R : Type*} [CommRing R] (W : WeierstrassCurve R) (x y x₀ y₀ : R)
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) :
+    16 * ((x * W.veluGx x y - y * W.veluGy x y) * (x - x₀) ^ 6 + (((y - y₀) ^ 2 + W.a₁ * (y - y₀) *
+        (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (3 * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀)
+        - (W.a₂ + x + x₀) * (x - x₀) ^ 2) ^ 2 + 2 * W.a₂ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x -
+        x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (x - x₀) ^ 2 + W.a₄ * (x - x₀) ^ 4 - W.a₁ * ((y -
+        y₀) * (x * (x - x₀) ^ 2 - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x
+        - x₀) ^ 2)) - y * (x - x₀) ^ 3 - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ +
+        x + x₀) * (x - x₀) ^ 2) * (x - x₀) - W.a₃ * (x - x₀) ^ 3) * (x - x₀)) - ((y - y₀) * (x * (x
+        - x₀) ^ 2 - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2)) -
+        y * (x - x₀) ^ 3 - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x
+        - x₀) ^ 2) * (x - x₀) - W.a₃ * (x - x₀) ^ 3) * (-(2 * ((y - y₀) * (x * (x - x₀) ^ 2 - ((y -
+        y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2)) - y * (x - x₀) ^ 3 -
+        W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (x -
+        x₀) - W.a₃ * (x - x₀) ^ 3) + W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x +
+        x₀) * (x - x₀) ^ 2) * (x - x₀) + W.a₃ * (x - x₀) ^ 3))))
+      = 16 * ((x * (x - x₀) + W.veluGx x₀ y₀) * (3 * (x * (x - x₀) + W.veluGx x₀ y₀) ^ 2 + 2 * W.a₂
+          * (x * (x - x₀) + W.veluGx x₀ y₀) * (x - x₀) + (W.a₄ - 5 * W.veluGx x₀ y₀) * (x - x₀) ^ 2
+          - W.a₁ * (y * (x - x₀) ^ 2 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀))) * (x - x₀) ^ 3
+          - (y * (x - x₀) ^ 2 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀)) * (-(2 * (y * (x - x₀)
+          ^ 2 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀)) + W.a₁ * (x * (x - x₀) + W.veluGx x₀
+          y₀) * (x - x₀) + W.a₃ * (x - x₀) ^ 2)) * (x - x₀) ^ 2) :=
+  WeierstrassCurve.fiberAdd_asymWeight_cleared_sixteen_aux W x y x₀ y₀ hP hQ hgy
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.fiberAdd_asymWeight_cleared_sixteen {R : Type*} [CommRing R] (W :
+    WeierstrassCurve R) (x y x₀ y₀ : R)
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) :
+    16 * ((x * W.veluGx x y - y * W.veluGy x y) * (x - x₀) ^ 6 + (((y - y₀) ^ 2 + W.a₁ * (y - y₀) *
+        (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (3 * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀)
+        - (W.a₂ + x + x₀) * (x - x₀) ^ 2) ^ 2 + 2 * W.a₂ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x -
+        x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (x - x₀) ^ 2 + W.a₄ * (x - x₀) ^ 4 - W.a₁ * ((y -
+        y₀) * (x * (x - x₀) ^ 2 - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x
+        - x₀) ^ 2)) - y * (x - x₀) ^ 3 - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ +
+        x + x₀) * (x - x₀) ^ 2) * (x - x₀) - W.a₃ * (x - x₀) ^ 3) * (x - x₀)) - ((y - y₀) * (x * (x
+        - x₀) ^ 2 - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2)) -
+        y * (x - x₀) ^ 3 - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x
+        - x₀) ^ 2) * (x - x₀) - W.a₃ * (x - x₀) ^ 3) * (-(2 * ((y - y₀) * (x * (x - x₀) ^ 2 - ((y -
+        y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2)) - y * (x - x₀) ^ 3 -
+        W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (x -
+        x₀) - W.a₃ * (x - x₀) ^ 3) + W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x +
+        x₀) * (x - x₀) ^ 2) * (x - x₀) + W.a₃ * (x - x₀) ^ 3))))
+      = 16 * ((x * (x - x₀) + W.veluGx x₀ y₀) * (3 * (x * (x - x₀) + W.veluGx x₀ y₀) ^ 2 + 2 * W.a₂
+          * (x * (x - x₀) + W.veluGx x₀ y₀) * (x - x₀) + (W.a₄ - 5 * W.veluGx x₀ y₀) * (x - x₀) ^ 2
+          - W.a₁ * (y * (x - x₀) ^ 2 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀))) * (x - x₀) ^ 3
+          - (y * (x - x₀) ^ 2 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀)) * (-(2 * (y * (x - x₀)
+          ^ 2 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀)) + W.a₁ * (x * (x - x₀) + W.veluGx x₀
+          y₀) * (x - x₀) + W.a₃ * (x - x₀) ^ 2)) * (x - x₀) ^ 2) :=
+  solution W x y x₀ y₀ hP hQ hgy
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_fiberAdd_veluGx_cleared_four.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_fiberAdd_veluGx_cleared_four.lean
new file mode 100644
index 0000000000..0aeaac28d1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_fiberAdd_veluGx_cleared_four.lean
@@ -0,0 +1,154 @@
+/-
+Based on Prove2Me node WeierstrassCurve.fiberAdd_veluGx_cleared_four
+(79533ff4-8c82-5682-823c-0fc98de6640b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ff049cb4-f062-5231-af34-54a8d4d0cd1a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_Velu
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Additivity of the Vélu weight gₓ over 2-isogeny fibres
+
+Theorem statement: `WeierstrassCurve.fiberAdd_veluGx_cleared_four`
+(`79533ff4-8c82-5682-823c-0fc98de6640b`), by Claude, 2026-09-05.
+
+Proof: submission `ff049cb4-f062-5231-af34-54a8d4d0cd1a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring, $W$ a Weierstrass curve over $R$ with coefficients
+$a_1,a_2,a_3,a_4,a_6$, and let $x,y,x_0,y_0\in R$ satisfy the affine Weierstrass equation of $W$,
+i.e. both $(x,y)$ and $(x_0,y_0)$ are affine points of $W$; assume moreover $-(2y_0+a_1x_0+a_3)=0$,
+the vanishing of `veluGy` at $(x_0,y_0)$. Writing $t_0=3x_0^2+2a_2x_0+a_4-a_1y_0$ for the value of
+`veluGx` at $(x_0,y_0)$, $N=(y-y_0)^2+a_1(y-y_0)(x-x_0)-(a_2+x+x_0)(x-x_0)^2$ and
+$M=(y-y_0)\bigl(x(x-x_0)^2-N\bigr)-y(x-x_0)^3-a_1N(x-x_0)-a_3(x-x_0)^3$, the asserted identity in
+$R$ is
+$$4\Bigl[(3x^2+2a_2x+a_4-a_1y)(x-x_0)^4+3N^2+2a_2N(x-x_0)^2+a_4(x-x_0)^4-a_1M(x-x_0)\Bigr]$$
+$$=4\Bigl[3\bigl(x(x-x_0)^2+t_0(x-x_0)\bigr)^2+2a_2\bigl(x(x-x_0)^2+t_0(x-x_0)\bigr)(x-x_0)^2+
+(a_4-5t_0)(x-x_0)^4-a_1\bigl(y(x-x_0)^3-t_0(a_1(x-x_0)+y-y_0)(x-x_0)\bigr)(x-x_0)\Bigr].$$
+Here $N=(x-x_0)^2x_3$ and $M=(x-x_0)^3y_3$ for the chord-law sum $(x_3,y_3)=(x,y)+(x_0,y_0)$, and
+the two bracketed expressions on the right involve $(x-x_0)^2$ and $(x-x_0)^3$ times the coordinates
+of the image of $(x,y)$ under the Vélu isogeny with kernel $\{O,(x_0,y_0)\}$; so the identity is the
+denominator-cleared form of $g_x(P)+g_x(P+Q)=g_x'(\varphi(P))$, multiplied by $4$.
+
+This is the additivity of the Vélu weight $g_x=3x^2+2a_2x+a_4-a_1y$ along the fibres $\{P,P+Q\}$ of
+the $2$-isogeny with kernel $\{O,Q\}$, the value on the right being taken on the quotient curve
+(whose $a_4$-coefficient is $a_4-5t_0$); the global factor $4$ allows the relation
+$2y_0=-(a_1x_0+a_3)$ to be used without dividing by $2$. It is used in the comparison of Vélu
+quotients by a cyclic subgroup of even order with the two-step quotient, and feeds the discriminant
+computations
+[`ModularCurve.TatePoint.fullKernelDiscAt`](thm.html#ModularCurve.TatePoint.fullKernelDiscAt) and
+[`ModularCurve.TatePoint.fullKernelDiscAt_univ`]
+(thm.html#ModularCurve.TatePoint.fullKernelDiscAt_univ)
+and the construction
+[`WeierstrassCurve.
+exists_functionFieldHom_fullKernelQuotient_pointMapOfPushforward_ker_eq_zmultiples`]
+(thm.html#WeierstrassCurve.
+exists_functionFieldHom_fullKernelQuotient_pointMapOfPushforward_ker_eq_zmultiples).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_fiberAdd_veluGx_cleared_four.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace WeierstrassCurve
+
+-- Translating by the two-torsion point makes the cleared chord coordinates linear in veluGx.
+private theorem fiberAdd_coordinates {R : Type*} [CommRing R]
+    (W : WeierstrassCurve R) (x y x₀ y₀ : R)
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) :
+    (y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀)
+        - (W.a₂ + x + x₀) * (x - x₀) ^ 2
+      = x₀ * (x - x₀) ^ 2 + W.veluGx x₀ y₀ * (x - x₀) ∧
+    (y - y₀) * (x * (x - x₀) ^ 2
+        - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀)
+          - (W.a₂ + x + x₀) * (x - x₀) ^ 2))
+        - y * (x - x₀) ^ 3
+        - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀)
+          - (W.a₂ + x + x₀) * (x - x₀) ^ 2) * (x - x₀)
+        - W.a₃ * (x - x₀) ^ 3
+      = y₀ * (x - x₀) ^ 3
+        - W.veluGx x₀ y₀ * (x - x₀) * (y - y₀ + W.a₁ * (x - x₀)) := by
+  rw [Affine.equation_iff] at hP hQ
+  simp only [veluGy] at hgy
+  have hn : (y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀)
+      - (W.a₂ + x + x₀) * (x - x₀) ^ 2
+      = x₀ * (x - x₀) ^ 2 + W.veluGx x₀ y₀ * (x - x₀) := by
+    simp only [veluGx]
+    linear_combination hP - hQ + (y - y₀) * hgy
+  refine ⟨hn, ?_⟩
+  rw [hn]
+  linear_combination (x - x₀) ^ 3 * hgy
+
+private theorem fiberAdd_veluGx_cleared_four_aux {R : Type*} [CommRing R] (W : WeierstrassCurve R)
+    (x y x₀ y₀ : R)
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) :
+    4 * (W.veluGx x y * (x - x₀) ^ 4 + (3 * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x +
+      x₀) * (x - x₀) ^ 2) ^ 2 + 2 * W.a₂ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x +
+      x₀) * (x - x₀) ^ 2) * (x - x₀) ^ 2 + W.a₄ * (x - x₀) ^ 4 - W.a₁ * ((y - y₀) * (x * (x - x₀) ^
+      2 - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2)) - y * (x -
+      x₀) ^ 3 - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2)
+      * (x - x₀) - W.a₃ * (x - x₀) ^ 3) * (x - x₀)))
+      = 4 * (3 * (x * (x - x₀) ^ 2 + W.veluGx x₀ y₀ * (x - x₀)) ^ 2 + 2 * W.a₂ * (x * (x - x₀) ^ 2 +
+        W.veluGx x₀ y₀ * (x - x₀)) * (x - x₀) ^ 2 + (W.a₄ - 5 * W.veluGx x₀ y₀) * (x - x₀) ^ 4 -
+        W.a₁ * (y * (x - x₀) ^ 3 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) * (x - x₀)) * (x -
+        x₀)) := by
+  obtain ⟨hn, hm⟩ := fiberAdd_coordinates W x y x₀ y₀ hP hQ hgy
+  rw [hm, hn]
+  simp only [veluGx]
+  ring
+
+
+end WeierstrassCurve
+
+theorem solution {R : Type*} [CommRing R] (W : WeierstrassCurve R) (x y x₀ y₀ : R)
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) :
+    4 * (W.veluGx x y * (x - x₀) ^ 4 + (3 * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x +
+      x₀) * (x - x₀) ^ 2) ^ 2 + 2 * W.a₂ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x +
+      x₀) * (x - x₀) ^ 2) * (x - x₀) ^ 2 + W.a₄ * (x - x₀) ^ 4 - W.a₁ * ((y - y₀) * (x * (x - x₀) ^
+      2 - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2)) - y * (x -
+      x₀) ^ 3 - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2)
+      * (x - x₀) - W.a₃ * (x - x₀) ^ 3) * (x - x₀)))
+      = 4 * (3 * (x * (x - x₀) ^ 2 + W.veluGx x₀ y₀ * (x - x₀)) ^ 2 + 2 * W.a₂ * (x * (x - x₀) ^ 2 +
+        W.veluGx x₀ y₀ * (x - x₀)) * (x - x₀) ^ 2 + (W.a₄ - 5 * W.veluGx x₀ y₀) * (x - x₀) ^ 4 -
+        W.a₁ * (y * (x - x₀) ^ 3 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) * (x - x₀)) * (x -
+        x₀)) :=
+  WeierstrassCurve.fiberAdd_veluGx_cleared_four_aux W x y x₀ y₀ hP hQ hgy
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.fiberAdd_veluGx_cleared_four {R : Type*} [CommRing R]
+    (W : WeierstrassCurve R) (x y x₀ y₀ : R)
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) :
+    4 * (W.veluGx x y * (x - x₀) ^ 4 + (3 * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x +
+      x₀) * (x - x₀) ^ 2) ^ 2 + 2 * W.a₂ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x +
+      x₀) * (x - x₀) ^ 2) * (x - x₀) ^ 2 + W.a₄ * (x - x₀) ^ 4 - W.a₁ * ((y - y₀) * (x * (x - x₀) ^
+      2 - ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2)) - y * (x -
+      x₀) ^ 3 - W.a₁ * ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2)
+      * (x - x₀) - W.a₃ * (x - x₀) ^ 3) * (x - x₀)))
+      = 4 * (3 * (x * (x - x₀) ^ 2 + W.veluGx x₀ y₀ * (x - x₀)) ^ 2 + 2 * W.a₂ * (x * (x - x₀) ^ 2 +
+        W.veluGx x₀ y₀ * (x - x₀)) * (x - x₀) ^ 2 + (W.a₄ - 5 * W.veluGx x₀ y₀) * (x - x₀) ^ 4 -
+        W.a₁ * (y * (x - x₀) ^ 3 - W.veluGx x₀ y₀ * (W.a₁ * (x - x₀) + y - y₀) * (x - x₀)) * (x -
+        x₀)) :=
+  solution W x y x₀ y₀ hP hQ hgy
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_finite_torsionBy_of_natCast_ne_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_finite_torsionBy_of_natCast_ne_zero.lean
new file mode 100644
index 0000000000..7d84753cd0
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_finite_torsionBy_of_natCast_ne_zero.lean
@@ -0,0 +1,113 @@
+/-
+Based on Prove2Me node WeierstrassCurve.finite_torsionBy_of_natCast_ne_zero
+(8a534e52-d39c-55e9-af16-ca242f72b778) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8f45ac4e-31dc-5db4-ab7d-5079a10e8abb
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Module.Torsion.Basic
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+
+import Mathlib.Algebra.Order.Star.Basic
+import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsion_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Finiteness of n-torsion when n ≠ 0 in k
+
+Theorem statement: `WeierstrassCurve.finite_torsionBy_of_natCast_ne_zero`
+(`8a534e52-d39c-55e9-af16-ca242f72b778`), by Claude, 2026-09-05.
+
+Proof: submission `8f45ac4e-31dc-5db4-ab7d-5079a10e8abb`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $k$ be a field and let $W$ be a Weierstrass curve over $k$ which is elliptic (in the sense of
+Mathlib's `IsElliptic`: its discriminant is a unit). Let $n$ be a natural number whose image in $k$
+is nonzero. Then the $\mathbb{Z}$-submodule $\mathrm{torsionBy}\ \mathbb{Z}\
+W.\mathrm{toAffine.Point}\ n$ — that is, the subgroup of those points $P$ of the group $W(k)$ of
+$k$-rational points of the associated affine Weierstrass curve (the points of the affine model
+together with the point at infinity, with the usual chord–tangent group law) satisfying $n \cdot P =
+0$ — is a finite type. Note that the hypothesis $(n : k) \neq 0$ already forces $n \neq 0$, so there
+is no separate nondegeneracy assumption; nothing is asserted about the structure of this group, only
+its finiteness.
+
+This is the standard finiteness of the $n$-torsion of the group of rational points of an elliptic
+curve over a field of residue characteristic not dividing $n$, obtained from the fact that over an
+algebraically closed field the $n$-torsion has exactly $n^2$ elements. It serves as the finiteness
+guarantee underlying the torsion-subgroup counts used in the modular-curve part of the development,
+and is cited by [`ModularCurve.finite_cycSub`](thm.html#ModularCurve.finite_cycSub) and by
+[`WeierstrassCurve.Affine.IsogenyEndDatum.exists_dualEndData_dual_mem_and_norm_eq_finrankAlong`]
+(thm.html#WeierstrassCurve.Affine.IsogenyEndDatum.
+exists_dualEndData_dual_mem_and_norm_eq_finrankAlong).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_finite_torsionBy_of_natCast_ne_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_finite_torsionBy_of_natCast_ne_zero
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+theorem solution (k : Type*) [Field k] [DecidableEq k] (W : WeierstrassCurve k) [W.IsElliptic]
+    (n : ℕ) (hn : (n : k) ≠ 0) :
+    Finite (Submodule.torsionBy ℤ W.toAffine.Point n) := by
+  classical
+  let K := AlgebraicClosure k
+  have hnK : (n : K) ≠ 0 := by
+    rw [← map_natCast (algebraMap k K) n]
+    exact (map_ne_zero _).mpr hn
+  have hn0 : n ≠ 0 := by
+    rintro rfl
+    exact hn (by simp)
+  have hcard : Nat.card (Submodule.torsionBy ℤ (W⁄K).Point n) = n ^ 2 :=
+    WeierstrassCurve.card_torsion_of_isAlgClosed (K := K) W hnK
+  have : Finite (Submodule.torsionBy ℤ (W⁄K).Point n) :=
+    Nat.finite_of_card_ne_zero (by rw [hcard]; exact pow_ne_zero 2 hn0)
+  let φ : (W.toAffine⁄k).Point →+ (W.toAffine⁄K).Point := Point.baseChange k K
+  have hφ : Function.Injective φ := Point.map_injective _
+  have hmem : ∀ P : Submodule.torsionBy ℤ W.toAffine.Point n, φ P.1 ∈ Submodule.torsionBy ℤ
+    (W⁄K).Point n :=
+    by
+    intro P
+    have hP := P.2
+    rw [Submodule.mem_torsionBy_iff] at hP ⊢
+    change (n : ℤ) • φ P.1 = 0
+    rw [← map_zsmul φ]
+    exact (congrArg φ hP).trans (map_zero φ)
+  refine Finite.of_injective (fun P => (⟨φ P.1, hmem P⟩ : Submodule.torsionBy ℤ (W⁄K).Point n)) ?_
+  intro P Q h
+  exact Subtype.ext (hφ (congrArg Subtype.val h))
+
+end S_WeierstrassCurve_finite_torsionBy_of_natCast_ne_zero
+end P2MW
+export P2MW.S_WeierstrassCurve_finite_torsionBy_of_natCast_ne_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.finite_torsionBy_of_natCast_ne_zero (k : Type*) [Field k] [DecidableEq k]
+    (W : WeierstrassCurve k) [W.IsElliptic]
+    (n : ℕ) (hn : (n : k) ≠ 0) :
+    Finite (Submodule.torsionBy ℤ W.toAffine.Point n) :=
+  solution k W n hn
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_frobenius_cayleyHamilton_on_torsion.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_frobenius_cayleyHamilton_on_torsion.lean
new file mode 100644
index 0000000000..35bfdbd006
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_frobenius_cayleyHamilton_on_torsion.lean
@@ -0,0 +1,349 @@
+/-
+Based on Prove2Me node WeierstrassCurve.frobenius_cayleyHamilton_on_torsion
+(674999af-d7c0-5abb-8197-fa3fe29b7945) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 33d33818-01e0-5aa5-b524-151f32fae0cc
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusTrace
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_GaloisRep
+import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Ramification
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_ZeroComponentAt
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusEndo
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_ReductionMap
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_TorsionIntegral
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_ReduceHom
+import LeanPool.FLTEichlerShimura.Definitions.Def_ValuationSubring_ReduceAt
+import LeanPool.FLTEichlerShimura.Theorems.Thm_FrobeniusEndo_frobCharEqOnPoints_of_frobenius
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Frobenius satisfies its characteristic equation on prime-to-ℓ torsion
+
+Theorem statement: `WeierstrassCurve.frobenius_cayleyHamilton_on_torsion`
+(`674999af-d7c0-5abb-8197-fa3fe29b7945`), by Claude, 2026-09-05.
+
+Proof: submission `33d33818-01e0-5aa5-b524-151f32fae0cc`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $W$ be a Weierstrass curve over $\mathbb Z$, let $\ell$ be a prime with $\ell \nmid W.\Delta$ in
+$\mathbb Z$ (good reduction of this particular integral model, no minimality assumed), and let $A$
+be a valuation subring of $\mathrm{AlgebraicClosure}\ \mathbb Q$ which lies over $\ell$ in the
+project's sense `LiesOverPrime`, i.e. the image of $\ell$ is a non-unit of $A$. Let $\sigma$ be a
+$\mathbb Q$-algebra automorphism of $\mathrm{AlgebraicClosure}\ \mathbb Q$ which is a Frobenius
+element at $A$ in the project's sense `IsFrobeniusAt`: $\sigma$ lies in the decomposition subgroup
+of $A$ over $\mathbb Q$ and the induced action on the residue field of $A$ is $x \mapsto x^{\ell}$.
+Let $n$ be a positive natural number with $\ell \nmid n$, and let $y$ be a point of the affine
+Weierstrass curve obtained from $W$ by base change along $\mathbb Z \to \mathbb Q \to
+\mathrm{AlgebraicClosure}\ \mathbb Q$ (so $y$ is either the point at infinity or a nonsingular
+affine point), satisfying $n \cdot y = 0$. Then $$\sigma \cdot (\sigma \cdot y) + \ell \cdot y =
+\bigl(\ell + 1 - \#(W \bmod \ell)(\mathbb Z/\ell)\bigr)\cdot(\sigma \cdot y),$$ an identity in the
+group of $\mathrm{AlgebraicClosure}\ \mathbb Q$-points. Here the action of $\sigma$ on points is the
+project's action by $\mathrm{Point.map}$ of the underlying algebra homomorphism, the integer
+multiples are the usual $\mathbb Z$-module structure, and the coefficient on the right is $\ell + 1$
+minus the number of points of the base change of $W$ to $\mathbb Z/\ell$, taken as a natural number;
+no separate finiteness hypothesis on that point group is imposed. The assertion is for the single
+torsion point $y$, not a statement about an endomorphism of a torsion module.
+
+This is the classical fact that a Frobenius element acts on prime-to-$\ell$ torsion of an elliptic
+curve with good reduction at $\ell$ through the $\ell$-power Frobenius endomorphism of the reduced
+curve, which satisfies $\pi^2 - a_\ell \pi + \ell = 0$ (Silverman, AEC, V.2.3 together with the
+injectivity of reduction on prime-to-$\ell$ torsion, VII.3.1). The formal version is pointwise: the
+trace $a_\ell$ is not introduced as such but written out as $\ell + 1$ minus the number of $\mathbb
+F_\ell$-points of $W \bmod \ell$, and the good-reduction hypothesis is the concrete condition $\ell
+\nmid W.\Delta$ for the given integral model. It is used to rule out Galois-stable cofixed lines for
+the Frey curve, via the divisibility statement
+[`WeierstrassCurve.prime_dvd_card_point_of_cofixed_addSubgroup_of_goodReduction`]
+(thm.html#WeierstrassCurve.prime_dvd_card_point_of_cofixed_addSubgroup_of_goodReduction)
+and [`FreyPackage.frey_no_cofixed_large`](thm.html#FreyPackage.frey_no_cofixed_large), and to
+identify the characteristic polynomial of Frobenius on the Tate module in
+[`WeierstrassCurve.tateModuleRep_charpoly_frobenius`]
+(thm.html#WeierstrassCurve.tateModuleRep_charpoly_frobenius).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_frobenius_cayleyHamilton_on_torsion.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_frobenius_cayleyHamilton_on_torsion
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point ValuationSubring
+open IsLocalRing
+
+private def cgPoint {R : Type*} [CommRing R] {V₁ V₂ : WeierstrassCurve.Affine R} (h : V₁ = V₂) :
+    V₁.Point → V₂.Point
+  | .zero => .zero
+  | .some x y hns => .some x y (h ▸ hns)
+
+private lemma cgPoint_id {R : Type*} [CommRing R] {V : WeierstrassCurve.Affine R}
+    (P : V.Point) : cgPoint rfl P = P := by
+  cases P <;> rfl
+
+private lemma cgPoint_eq_zero_iff {R : Type*} [CommRing R] {V₁ V₂ : WeierstrassCurve.Affine R}
+    (h : V₁ = V₂) (P : V₁.Point) : cgPoint h P = 0 ↔ P = 0 := by
+  subst h
+  rw [cgPoint_id]
+
+private lemma cgPoint_add {F : Type*} [Field F] [DecidableEq F]
+    {V₁ V₂ : WeierstrassCurve.Affine F} (h : V₁ = V₂) (P Q : V₁.Point) :
+    cgPoint h (P + Q) = cgPoint h P + cgPoint h Q := by
+  subst h
+  simp only [cgPoint_id]
+
+private def cgAddEquiv {F : Type*} [Field F] [DecidableEq F]
+    {V₁ V₂ : WeierstrassCurve.Affine F} (h : V₁ = V₂) : V₁.Point ≃+ V₂.Point where
+  toFun := cgPoint h
+  invFun := cgPoint h.symm
+  left_inv P := by cases P <;> rfl
+  right_inv P := by cases P <;> rfl
+  map_add' := cgPoint_add h
+
+private lemma some_congr'' {R : Type*} [CommRing R] {V : WeierstrassCurve.Affine R}
+    {x₁ x₂ y₁ y₂ : R} (hx : x₁ = x₂) (hy : y₁ = y₂)
+    (h₁ : V.Nonsingular x₁ y₁) (h₂ : V.Nonsingular x₂ y₂) :
+    WeierstrassCurve.Affine.Point.some x₁ y₁ h₁ = WeierstrassCurve.Affine.Point.some x₂ y₂ h₂ := by
+  subst hx
+  subst hy
+  rfl
+
+private def frobPt {k : Type*} [Field k] {V : WeierstrassCurve k} (q : ℕ)
+    (hfrob : ∀ {x y : k}, V.toAffine.Nonsingular x y → V.toAffine.Nonsingular (x ^ q) (y ^ q)) :
+    V.toAffine.Point → V.toAffine.Point
+  | .zero => .zero
+  | .some x y h => .some (x ^ q) (y ^ q) (hfrob h)
+
+private lemma frobPt_some {k : Type*} [Field k] {V : WeierstrassCurve k} {q : ℕ}
+    {hfrob : ∀ {x y : k}, V.toAffine.Nonsingular x y → V.toAffine.Nonsingular (x ^ q) (y ^ q)}
+    {x y : k} (h : V.toAffine.Nonsingular x y) :
+    frobPt q hfrob (.some x y h) = .some (x ^ q) (y ^ q) (hfrob h) :=
+  rfl
+
+private theorem nonsingular_pow_of_map_frobenius_eq' {k : Type*} [Field k]
+    {V : WeierstrassCurve k} {q : ℕ} [ExpChar k q]
+    (hfix : V.map (frobenius k q) = V) {x y : k} (h : V.toAffine.Nonsingular x y) :
+    V.toAffine.Nonsingular (x ^ q) (y ^ q) := by
+  have hmap : (V.map (frobenius k q)).toAffine.Nonsingular
+      (frobenius k q x) (frobenius k q y) :=
+    (V.toAffine.map_nonsingular (frobenius k q).injective x y).mpr h
+  rw [hfix] at hmap
+  exact hmap
+
+private theorem reducePoint_smul_eq_frobPt {L : Type*} [Field L] {A : ValuationSubring L}
+    {W : WeierstrassCurve A} (hΔ : (W.map (residue A)).Δ ≠ 0)
+    {K : Type*} [Field K] [Algebra K L] {q : ℕ} {σ : L ≃ₐ[K] L} (hσ : A.IsFrobeniusAt σ q)
+    (hfrob : ∀ {x y : ResidueField A}, (W.map (residue A)).toAffine.Nonsingular x y →
+      (W.map (residue A)).toAffine.Nonsingular (x ^ q) (y ^ q))
+    {x y : L} (h : (W.map A.subtype).toAffine.Nonsingular x y)
+    (h' : (W.map A.subtype).toAffine.Nonsingular (σ x) (σ y)) :
+    reducePoint hΔ (.some (σ x) (σ y) h') = frobPt q hfrob (reducePoint hΔ (.some x y h)) := by
+  have hσd : σ ∈ A.decompositionSubgroup K := hσ.mem_decompositionSubgroup
+  by_cases hx : x ∈ A
+  · have hy : y ∈ A := Affine.Y_mem_of_X_mem W h.1 hx
+    have hσx : σ x ∈ A := A.smul_mem_of_mem_decompositionSubgroup K hσd hx
+    have hσy : σ y ∈ A := A.smul_mem_of_mem_decompositionSubgroup K hσd hy
+    rw [reducePoint_some_of_mem _ _ hσx, reducePoint_some_of_mem _ _ hx, frobPt_some]
+    refine some_congr'' ?_ ?_ _ _
+    · calc residue A (⟨σ x, hσx⟩ : A)
+          = residue A ((⟨σ, hσ.mem_decompositionSubgroup⟩ : A.decompositionSubgroup K) •
+              (⟨x, hx⟩ : A)) := rfl
+        _ = (⟨σ, hσ.mem_decompositionSubgroup⟩ : A.decompositionSubgroup K) •
+              (residue A (⟨x, hx⟩ : A)) := rfl
+        _ = (residue A (⟨x, hx⟩ : A)) ^ q := hσ.smul_residue_eq _
+    · calc residue A (⟨σ y, hσy⟩ : A)
+          = residue A ((⟨σ, hσ.mem_decompositionSubgroup⟩ : A.decompositionSubgroup K) •
+              (⟨y, hy⟩ : A)) := rfl
+        _ = (⟨σ, hσ.mem_decompositionSubgroup⟩ : A.decompositionSubgroup K) •
+              (residue A (⟨y, hy⟩ : A)) := rfl
+        _ = (residue A (⟨y, hy⟩ : A)) ^ q := hσ.smul_residue_eq _
+  · have hσx : σ x ∉ A := fun hmem => hx (by
+      simpa using A.smul_mem_of_mem_decompositionSubgroup K (inv_mem hσd) hmem)
+    rw [reducePoint_some_of_notMem _ _ hσx, reducePoint_some_of_notMem _ _ hx]
+    rfl
+
+private lemma ringHom_fix_zmod {k : Type*} [Field k] {ℓ : ℕ} [NeZero ℓ]
+    [Algebra (ZMod ℓ) k] (φ : k →+* k) (c : ZMod ℓ) :
+    φ (algebraMap (ZMod ℓ) k c) = algebraMap (ZMod ℓ) k c := by
+  obtain ⟨m, rfl⟩ := ZMod.natCast_zmod_surjective c
+  rw [map_natCast (algebraMap (ZMod ℓ) k), map_natCast]
+
+private lemma exists_frobAlgEquiv {L : Type*} [Field L] [IsAlgClosed L]
+    {A : ValuationSubring L} {ℓ : ℕ} (hℓ : ℓ.Prime) (hA : A.LiesOverPrime ℓ)
+    [Algebra (ZMod ℓ) (ResidueField A)] :
+    ∃ σ' : ResidueField A ≃ₐ[ZMod ℓ] ResidueField A, ∀ z : ResidueField A, σ' z = z ^ ℓ := by
+  have : NeZero ℓ := ⟨hℓ.ne_zero⟩
+  have : CharP (ResidueField A) ℓ := charP_residueField_of_liesOverPrime_def hℓ hA
+  have : Fact ℓ.Prime := ⟨hℓ⟩
+  have hcoe : ⇑(frobenius (ResidueField A) ℓ) = fun z : ResidueField A => z ^ ℓ :=
+    funext fun z => frobenius_def ℓ z
+  have hbij : Function.Bijective (frobenius (ResidueField A) ℓ) := by
+    rw [hcoe]
+    exact pow_residueChar_bijective hℓ hA
+  refine ⟨AlgEquiv.ofRingEquiv (f := RingEquiv.ofBijective _ hbij)
+    (fun c => ringHom_fix_zmod (frobenius (ResidueField A) ℓ) c), fun z => frobenius_def ℓ z⟩
+
+theorem solution
+    (W : WeierstrassCurve ℤ) (ℓ : ℕ) (hℓ : ℓ.Prime)
+    (hgood : ¬ (ℓ : ℤ) ∣ W.Δ)
+    (A : ValuationSubring (AlgebraicClosure ℚ)) (hA : A.LiesOverPrime ℓ)
+    (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) (hσ : A.IsFrobeniusAt σ ℓ)
+    (n : ℕ) (hn : 0 < n) (hℓn : ¬ ℓ ∣ n)
+    (y : ((W.map (Int.castRingHom ℚ))⁄(AlgebraicClosure ℚ)).Point) (hy : n • y = 0) :
+    σ • σ • y + (ℓ : ℤ) • y =
+      ((ℓ : ℤ) + 1 - (Nat.card (W⁄(ZMod ℓ)).Point : ℤ)) • (σ • y) := by
+  have _hn : 0 < n := hn
+  have : Fact ℓ.Prime := ⟨hℓ⟩
+  have : NeZero ℓ := ⟨hℓ.ne_zero⟩
+  have hCharP : CharP (ResidueField A) ℓ := charP_residueField_of_liesOverPrime_def hℓ hA
+  let algZk : Algebra (ZMod ℓ) (ResidueField A) := ZMod.algebra _ ℓ
+  let algIntZMod : Algebra ℤ (ZMod ℓ) := inferInstance
+  let algIntK : Algebra ℤ (ResidueField A) := inferInstance
+  let tower := IsScalarTower.of_algebraMap_eq' (R := ℤ) (S := ZMod ℓ)
+    (A := ResidueField A) (Subsingleton.elim _ _)
+  let ddk : DecidableEq (ResidueField A) := Classical.decEq _
+  have hΔres : ((W.map (Int.castRingHom A)).map (residue A)).Δ ≠ 0 := by
+    rw [map_Δ, map_Δ]
+    exact residue_intCast_ne_zero hℓ hA hgood
+  have e₁ : ((W.map (Int.castRingHom ℚ))⁄(AlgebraicClosure ℚ) : Affine (AlgebraicClosure ℚ))
+      = (W.map (Int.castRingHom A)).map A.subtype := by
+    change W.map ((algebraMap ℚ (AlgebraicClosure ℚ)).comp (Int.castRingHom ℚ))
+        = W.map (A.subtype.comp (Int.castRingHom A))
+    congr 1
+  have e₂ : (W.map (Int.castRingHom A)).map (residue A)
+      = (W⁄(ResidueField A) : WeierstrassCurve (ResidueField A)) := by
+    change W.map ((residue A).comp (Int.castRingHom A))
+        = W.map (algebraMap ℤ (ResidueField A))
+    congr 1
+  have : ((W⁄(ResidueField A)) : WeierstrassCurve (ResidueField A)).IsElliptic := by
+    refine ⟨isUnit_iff_ne_zero.mpr ?_⟩
+    have h := hΔres
+    rw [e₂] at h
+    exact h
+  have hfrob : ∀ {u v : ResidueField A},
+      ((W.map (Int.castRingHom A)).map (residue A)).toAffine.Nonsingular u v →
+      ((W.map (Int.castRingHom A)).map (residue A)).toAffine.Nonsingular (u ^ ℓ) (v ^ ℓ) := by
+    intro u v hw
+    refine nonsingular_pow_of_map_frobenius_eq' ?_ hw
+    change W.map ((frobenius (ResidueField A) ℓ).comp ((residue A).comp (Int.castRingHom A)))
+        = W.map ((residue A).comp (Int.castRingHom A))
+    congr 1
+    exact Subsingleton.elim _ _
+  obtain ⟨σ', hσ'x⟩ := exists_frobAlgEquiv (L := AlgebraicClosure ℚ) hℓ hA
+  have ch := FrobeniusEndo.frobCharEqOnPoints_of_frobenius (F := ZMod ℓ)
+    (k := ResidueField A) W σ'
+    (fun z => by rw [ZMod.card]; exact hσ'x z)
+    (by rw [ZMod.card]; exact hℓ)
+  rw [ZMod.card] at ch
+  let red : ((W.map (Int.castRingHom ℚ))⁄(AlgebraicClosure ℚ)).Point →+
+      ((W⁄(ResidueField A)) : WeierstrassCurve (ResidueField A)).toAffine.Point :=
+    ((cgAddEquiv e₂).toAddMonoidHom.comp (reduceHom hΔres)).comp
+      (cgAddEquiv e₁).toAddMonoidHom
+  have hE' : ∀ Q' : ((W.map (Int.castRingHom A)).map (residue A)).toAffine.Point,
+      cgPoint e₂ (frobPt ℓ hfrob Q') = σ' • (cgPoint e₂ Q') := by
+    intro Q'
+    rcases Q' with _ | ⟨u, v, w⟩
+    · rfl
+    · exact some_congr'' (hσ'x u).symm (hσ'x v).symm _ _
+  have hE : ∀ Q : ((W.map (Int.castRingHom ℚ))⁄(AlgebraicClosure ℚ)).Point,
+      red (σ • Q) = σ' • (red Q) := by
+    intro Q
+    rcases Q with _ | ⟨x', y', hns⟩
+    · rfl
+    · have hns' : ((W.map (Int.castRingHom ℚ))⁄(AlgebraicClosure ℚ)).Nonsingular
+          (σ x') (σ y') :=
+        (Affine.baseChange_nonsingular (W := W.map (Int.castRingHom ℚ))
+          (f := σ.toAlgHom) σ.injective x' y').mpr hns
+      calc red (σ • Point.some x' y' hns)
+          = cgPoint e₂ (reducePoint hΔres (Point.some (σ x') (σ y') (e₁ ▸ hns'))) := rfl
+        _ = cgPoint e₂ (frobPt ℓ hfrob (reducePoint hΔres (Point.some x' y' (e₁ ▸ hns)))) := by
+            rw [reducePoint_smul_eq_frobPt hΔres hσ hfrob (e₁ ▸ hns) (e₁ ▸ hns')]
+        _ = σ' • (cgPoint e₂ (reducePoint hΔres (Point.some x' y' (e₁ ▸ hns)))) := hE' _
+        _ = σ' • (red (Point.some x' y' hns)) := rfl
+  have hnk : ((n : ℕ) : ResidueField A) ≠ 0 := by
+    intro h0
+    exact hℓn ((CharP.cast_eq_zero_iff (ResidueField A) ℓ n).mp h0)
+  have hI : ∀ Q : ((W.map (Int.castRingHom ℚ))⁄(AlgebraicClosure ℚ)).Point,
+      n • Q = 0 → red Q = 0 → Q = 0 := by
+    intro Q htor hz
+    rcases Q with _ | ⟨x', y', hns⟩
+    · rfl
+    · exfalso
+      have htor' : n • (Point.some x' y' (e₁ ▸ hns) :
+          ((W.map (Int.castRingHom A)).map A.subtype).toAffine.Point) = 0 := by
+        have h2 := congrArg (cgAddEquiv e₁) htor
+        rwa [map_nsmul, _root_.map_zero] at h2
+      have hx : x' ∈ A :=
+        X_mem_of_nsmul_eq_zero' (W.map (Int.castRingHom A)) hnk (e₁ ▸ hns) htor'
+      have hred : reducePoint hΔres (Point.some x' y' (e₁ ▸ hns))
+          = Point.some (residue A ⟨x', hx⟩)
+              (residue A ⟨y', Affine.Y_mem_of_X_mem (W.map (Int.castRingHom A))
+                (e₁ ▸ hns).1 hx⟩)
+              (Affine.nonsingular_residue (W.map (Int.castRingHom A)) hΔres (e₁ ▸ hns).1) :=
+        reducePoint_some_of_mem hΔres (e₁ ▸ hns) hx
+      have hz' : cgPoint e₂ (reducePoint hΔres (Point.some x' y' (e₁ ▸ hns))) = 0 := hz
+      rw [hred, cgPoint_eq_zero_iff] at hz'
+      exact some_ne_zero _ hz'
+  have hsm : ∀ P : ((W.map (Int.castRingHom ℚ))⁄(AlgebraicClosure ℚ)).Point,
+      n • P = 0 → n • (σ • P) = 0 := by
+    intro P hP
+    have h2 : σ • (n • P) = n • (σ • P) :=
+      AddMonoidHom.map_nsmul (DistribSMul.toAddMonoidHom _ σ) n P
+    rw [← h2, hP]
+    exact _root_.map_zero (DistribSMul.toAddMonoidHom
+      (((W.map (Int.castRingHom ℚ))⁄(AlgebraicClosure ℚ)).Point) σ)
+  set a : ℤ := (ℓ : ℤ) + 1 - (Nat.card (W⁄(ZMod ℓ)).Point : ℤ) with ha
+  set z : ((W.map (Int.castRingHom ℚ))⁄(AlgebraicClosure ℚ)).Point :=
+    σ • σ • y + (ℓ : ℤ) • y - a • (σ • y) with hzdef
+  have htorz : n • z = 0 := by
+    have h1 : n • (σ • σ • y) = 0 := hsm _ (hsm _ hy)
+    have h2 : n • ((ℓ : ℤ) • y) = 0 := by
+      rw [smul_comm, hy]
+      exact zsmul_zero _
+    have h3 : n • (a • (σ • y)) = 0 := by
+      rw [smul_comm, hsm _ hy]
+      exact zsmul_zero _
+    rw [hzdef, nsmul_sub, nsmul_add, h1, h2, h3, add_zero, sub_zero]
+  have hredz : red z = 0 := by
+    have hc := ch (red y)
+    rw [hzdef, _root_.map_sub, _root_.map_add, map_zsmul, map_zsmul, hE, hE, add_sub_right_comm]
+    exact hc
+  have hz0 : z = 0 := hI z htorz hredz
+  rw [hzdef] at hz0
+  exact sub_eq_zero.mp hz0
+
+end S_WeierstrassCurve_frobenius_cayleyHamilton_on_torsion
+end P2MW
+export P2MW.S_WeierstrassCurve_frobenius_cayleyHamilton_on_torsion (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point ValuationSubring
+
+theorem WeierstrassCurve.frobenius_cayleyHamilton_on_torsion
+    (W : WeierstrassCurve ℤ) (ℓ : ℕ) (hℓ : ℓ.Prime)
+    (hgood : ¬ (ℓ : ℤ) ∣ W.Δ)
+    (A : ValuationSubring (AlgebraicClosure ℚ)) (hA : A.LiesOverPrime ℓ)
+    (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) (hσ : A.IsFrobeniusAt σ ℓ)
+    (n : ℕ) (hn : 0 < n) (hℓn : ¬ ℓ ∣ n)
+    (y : ((W.map (Int.castRingHom ℚ))⁄(AlgebraicClosure ℚ)).Point) (hy : n • y = 0) :
+    σ • σ • y + (ℓ : ℤ) • y =
+      ((ℓ : ℤ) + 1 - (Nat.card (W⁄(ZMod ℓ)).Point : ℤ)) • (σ • y) :=
+  solution W ℓ hℓ hgood A hA σ hσ n hn hℓn y hy
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_fullKernelQuotient_eq_veluQuotient_of_odd.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_fullKernelQuotient_eq_veluQuotient_of_odd.lean
new file mode 100644
index 0000000000..05c29a5f7c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_fullKernelQuotient_eq_veluQuotient_of_odd.lean
@@ -0,0 +1,249 @@
+/-
+Based on Prove2Me node WeierstrassCurve.fullKernelQuotient_eq_veluQuotient_of_odd
+(0064623e-1116-52bf-a6f3-d9d42a761bb3) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 95ba3e1e-873a-5765-af27-eece25fc8a97
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FullKernelQuotient
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CycSubRootBridgeOdd
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_CycSubRootBridgeN
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Full-kernel quotient equals the half-system Vélu quotient at odd order
+
+Theorem statement: `WeierstrassCurve.fullKernelQuotient_eq_veluQuotient_of_odd`
+(`0064623e-1116-52bf-a6f3-d9d42a761bb3`), by Claude, 2026-09-05.
+
+Proof: submission `95ba3e1e-873a-5765-af27-eece25fc8a97`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field, $W$ a Weierstrass curve over $F$, and $Q$ a point of the associated affine curve
+$W.\mathrm{toAffine}$. Let $N$ be a natural number which is odd and for which $Q$ has order exactly
+$N$ in the group of points, i.e. $\mathrm{addOrderOf}\,Q = N$. Write $\mathrm{coordsOrZero}$ for the
+map sending the point at infinity to $(0,0)$ and an affine point $(x,y)$ to $(x,y)$, and for $n :
+\mathbb{N}$ let $\mathrm{oddOrderSummingSet}\,Q\,n \subseteq F \times F$ be the finite image of
+$\{1,\dots,n\}$ under $k \mapsto \mathrm{coordsOrZero}(k \cdot Q)$. The assertion is an equality of
+Weierstrass curves, i.e. of all five coefficients. On the left,
+$W.\mathrm{fullKernelQuotient}\,Q\,N$ keeps $a_1,a_2,a_3$ and replaces $a_4$ by $a_4 - 5t$ and $a_6$
+by $a_6 - b_2 t - 7w$, where, summing over $P \in \mathrm{oddOrderSummingSet}\,Q\,(N-1)$ (truncated
+subtraction), $t = \sum_P g_x(P)$ and $w = \sum_P (P_1 g_x(P) - P_2 g_y(P))$ with $g_x(x,y) = 3x^2 +
+2a_2x + a_4 - a_1y$ and $g_y(x,y) = -(2y + a_1x + a_3)$. On the right, $W.\mathrm{veluQuotient}\,S$
+for $S = \mathrm{oddOrderSummingSet}\,Q\,((N-1)/2)$ (natural division) again keeps $a_1,a_2,a_3$ and
+replaces $a_4$ by $a_4 - 5\sum_{P \in S} \mathrm{veluT}(P)$ and $a_6$ by $a_6 - b_2\sum_{P \in
+S}\mathrm{veluT}(P) - 7\sum_{P \in S}\mathrm{veluW}(P)$.
+
+This identifies the quotient formed from the whole set of nonzero multiples of $Q$, with the
+asymmetric weights used in the parity-free construction, with Vélu's half-system quotient taken over
+$Q, 2Q, \dots, \tfrac{N-1}{2}Q$; for $N = 1$ both indexing sets are empty and both sides are $W$
+itself. It is the transfer step by which properties of the odd-order Vélu quotient are used for the
+full-kernel quotient, and is cited in the construction of function-field maps out of
+`fullKernelQuotient` and in the supersingular-fibre and Frobenius-semilinearity results for torsion
+models on modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_fullKernelQuotient_eq_veluQuotient_of_odd.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_fullKernelQuotient_eq_veluQuotient_of_odd
+
+noncomputable section
+
+p2m_open "ModularCurve \
+  P2MW.S_WeierstrassCurve_fullKernelQuotient_eq_veluQuotient_of_odd.ModularCurve WeierstrassCurve \
+  P2MW.S_WeierstrassCurve_fullKernelQuotient_eq_veluQuotient_of_odd.WeierstrassCurve Polynomial"
+open scoped Classical
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "map toAffine Δ j fullKernelQuotient \
+  fullKernelQuotient_eq_veluQuotient_oddOrderSummingSet oddOrderSummingSet veluQuotient \
+  veluQuotient_oddOrderSummingSet_discriminant_ne_zero \
+  zmultiples_eq_of_veluQuotient_j_eq_of_transcendental"
+p2m_open "WeierstrassCurve"
+
+theorem j_congr {R : Type*} [CommRing R] {X Y : WeierstrassCurve R} (h : X = Y) (hX : X.IsElliptic)
+    (hY : Y.IsElliptic) : @WeierstrassCurve.j R _ X hX = @WeierstrassCurve.j R _ Y hY := by
+  subst h
+  rfl
+
+private theorem _root_.WeierstrassCurve.fullKernelQuotient_eq_veluQuotient_of_odd_aux {F : Type*}
+    [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+    (Q : W.toAffine.Point) {N : ℕ} (hN : Odd N) (hQ : addOrderOf Q = N) :
+    W.fullKernelQuotient Q N = W.veluQuotient (W.oddOrderSummingSet Q ((N - 1) / 2)) := by
+  obtain ⟨m, rfl⟩ := hN
+  have hm : (2 * m + 1 - 1) / 2 = m := by omega
+  rw [hm]
+  exact W.fullKernelQuotient_eq_veluQuotient_oddOrderSummingSet Q m hQ
+
+p2m_export "WeierstrassCurve" "fullKernelQuotient_eq_veluQuotient_of_odd_aux"
+
+private theorem _root_.WeierstrassCurve.fullKernelQuotient_discriminant_ne_zero_of_odd {L : Type*}
+    [Field L] [DecidableEq L] [IsAlgClosed L]
+    (h2 : (2 : L) ≠ 0) (W : WeierstrassCurve L) [W.IsElliptic] (N : ℕ) [NeZero N] (hN : Odd N)
+    (Q : W.toAffine.Point) (hQ : addOrderOf Q = N) :
+    (W.fullKernelQuotient Q N).Δ ≠ 0 := by
+  obtain ⟨m, rfl⟩ := hN
+  rw [W.fullKernelQuotient_eq_veluQuotient_oddOrderSummingSet Q m hQ]
+  exact WeierstrassCurve.veluQuotient_oddOrderSummingSet_discriminant_ne_zero h2 W m Q hQ
+
+p2m_export "WeierstrassCurve" "fullKernelQuotient_discriminant_ne_zero_of_odd"
+
+private theorem
+  _root_.WeierstrassCurve.zmultiples_eq_of_fullKernelQuotient_j_eq_of_transcendental_of_odd
+    [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    (ht : Transcendental ℚ W.j) (N : ℕ) [NeZero N] (hN : Odd N) (Q Q' : W.toAffine.Point)
+    (hQ : addOrderOf Q = N) (hQ' : addOrderOf Q' = N)
+    (hΔ : (W.fullKernelQuotient Q N).Δ ≠ 0)
+    (hΔ' : (W.fullKernelQuotient Q' N).Δ ≠ 0)
+    (hj : haveI : (W.fullKernelQuotient Q N).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+      haveI : (W.fullKernelQuotient Q' N).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ'⟩
+      (W.fullKernelQuotient Q N).j = (W.fullKernelQuotient Q' N).j) :
+    AddSubgroup.zmultiples Q = AddSubgroup.zmultiples Q' := by
+  obtain ⟨m, rfl⟩ := hN
+  have hWQ := W.fullKernelQuotient_eq_veluQuotient_oddOrderSummingSet Q m hQ
+  have hWQ' := W.fullKernelQuotient_eq_veluQuotient_oddOrderSummingSet Q' m hQ'
+  have hΔ₁ : (W.veluQuotient (W.oddOrderSummingSet Q m)).Δ ≠ 0 := by rw [← hWQ]; exact hΔ
+  have hΔ₂ : (W.veluQuotient (W.oddOrderSummingSet Q' m)).Δ ≠ 0 := by rw [← hWQ']; exact hΔ'
+  rw [j_congr hWQ ⟨isUnit_iff_ne_zero.mpr hΔ⟩ ⟨isUnit_iff_ne_zero.mpr hΔ₁⟩,
+    j_congr hWQ' ⟨isUnit_iff_ne_zero.mpr hΔ'⟩ ⟨isUnit_iff_ne_zero.mpr hΔ₂⟩] at hj
+  exact WeierstrassCurve.zmultiples_eq_of_veluQuotient_j_eq_of_transcendental W ht m Q Q' hQ hQ' hΔ₁
+    hΔ₂ hj
+
+p2m_export "WeierstrassCurve" "zmultiples_eq_of_fullKernelQuotient_j_eq_of_transcendental_of_odd"
+end WeierstrassCurve
+
+namespace ModularCurve
+p2m_export "ModularCurve" "TatePoint.dictOdd TatePoint.Qbar TatePoint.nearCurve TatePoint.CycSubH \
+  TatePoint.RootsAt ModularPolynomialData \
+  ModularPolynomialData.isRoot_map_j_veluQuotient_j_of_addOrderOf_eq TatePoint.dictN"
+namespace ModularPolynomialData
+p2m_export "ModularCurve.ModularPolynomialData" "Φ isRoot_map_j_veluQuotient_j_of_addOrderOf_eq"
+end ModularCurve.ModularPolynomialData
+p2m_open_scoped "ModularCurve ModularCurve.ModularPolynomialData" in
+theorem ModularCurve.ModularPolynomialData.isRoot_map_j_fullKernelQuotient_j_of_odd
+    [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    (N : ℕ) [NeZero N] (hN : Odd N) (Q : W.toAffine.Point) (hQ : addOrderOf Q = N)
+    (hΔ : (W.fullKernelQuotient Q N).Δ ≠ 0)
+    (data : ModularCurve.ModularPolynomialData N) :
+    haveI : (W.fullKernelQuotient Q N).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+    (data.Φ.map (Polynomial.eval₂RingHom
+      (Int.castRingHom (HahnSeries ℚ (AlgebraicClosure ℚ))) W.j)).IsRoot
+      (W.fullKernelQuotient Q N).j := by
+  obtain ⟨m, rfl⟩ := hN
+  have hWQ := W.fullKernelQuotient_eq_veluQuotient_oddOrderSummingSet Q m hQ
+  have hΔ₁ : (W.veluQuotient (W.oddOrderSummingSet Q m)).Δ ≠ 0 := by rw [← hWQ]; exact hΔ
+  rw [WeierstrassCurve.j_congr hWQ ⟨isUnit_iff_ne_zero.mpr hΔ⟩ ⟨isUnit_iff_ne_zero.mpr hΔ₁⟩]
+  exact ModularCurve.ModularPolynomialData.isRoot_map_j_veluQuotient_j_of_addOrderOf_eq W m Q hQ hΔ₁
+    data
+
+namespace ModularCurve
+p2m_export "ModularCurve" "TatePoint.dictOdd TatePoint.Qbar TatePoint.nearCurve TatePoint.CycSubH \
+  TatePoint.RootsAt ModularPolynomialData \
+  ModularPolynomialData.isRoot_map_j_veluQuotient_j_of_addOrderOf_eq TatePoint.dictN"
+namespace TatePoint
+p2m_export "ModularCurve.TatePoint" "cycSubRootOdd rootsEquivCycSubHOdd \
+  rootsEquivCycSubHOdd_apply_eq_iff dictOdd cycSubGen addOrderOf_cycSubGen Qbar H nearCurve \
+  CycSubH RootsAt nearCurve_j_transcendental FullKernelIsRootAt FullKernelInjAt FullKernelDiscAt \
+  cycSubRootN rootsEquivCycSubHN rootsEquivCycSubHN_apply_eq_iff dictN"
+p2m_open "ModularCurve.TatePoint ModularCurve"
+
+private theorem cycSubRootN_eq_cycSubRootOdd_aux (E : WeierstrassCurve H) [E.IsElliptic] {N : ℕ}
+    [NeZero N] (hN : Odd N)
+    (hW1 : FullKernelIsRootAt N) (hW3 : FullKernelDiscAt N) (data : ModularPolynomialData N)
+    (G : CycSubH E N) : cycSubRootN E hW1 hW3 data G = cycSubRootOdd E hN data G :=
+  Subtype.ext (WeierstrassCurve.j_congr
+    (E.fullKernelQuotient_eq_veluQuotient_of_odd_aux (cycSubGen E G) hN (addOrderOf_cycSubGen E G))
+      _ _)
+
+private theorem rootsEquivCycSubHN_eq_rootsEquivCycSubHOdd_aux (E : WeierstrassCurve H)
+    [E.IsElliptic] {N : ℕ} [NeZero N]
+    (hN : Odd N) (hW1 : FullKernelIsRootAt N) (hW2 : FullKernelInjAt N) (hW3 : FullKernelDiscAt N)
+    (data : ModularPolynomialData N) (hj : Transcendental Qbar E.j) :
+    rootsEquivCycSubHN E hW1 hW2 hW3 data hj = rootsEquivCycSubHOdd E hN data hj := by
+  ext r : 1
+  rw [rootsEquivCycSubHN_apply_eq_iff, cycSubRootN_eq_cycSubRootOdd_aux E hN,
+    ← rootsEquivCycSubHOdd_apply_eq_iff E hN data hj r (rootsEquivCycSubHOdd E hN data hj r)]
+
+private theorem dictN_eq_dictOdd_aux (N : ℕ) [NeZero N] (hN : Odd N)
+    (data : ModularPolynomialData N) (j₀ : Qbar)
+    (hW1 : FullKernelIsRootAt N) (hW2 : FullKernelInjAt N) (hW3 : FullKernelDiscAt N) :
+    dictN N data j₀ hW1 hW2 hW3 = dictOdd N hN data j₀ :=
+  rootsEquivCycSubHN_eq_rootsEquivCycSubHOdd_aux (nearCurve j₀) hN hW1 hW2 hW3 data
+    (nearCurve_j_transcendental j₀)
+
+private theorem fullKernelIsRootAt_of_odd_aux (N : ℕ) [NeZero N] (hN : Odd N) :
+    FullKernelIsRootAt N :=
+  fun W _ Q hQ hΔ data =>
+    ModularCurve.ModularPolynomialData.isRoot_map_j_fullKernelQuotient_j_of_odd W N hN Q hQ hΔ data
+
+private theorem fullKernelInjAt_of_odd_aux (N : ℕ) [NeZero N] (hN : Odd N) : FullKernelInjAt N :=
+  fun W _ ht Q Q' hQ hQ' hΔ hΔ' hj =>
+    W.zmultiples_eq_of_fullKernelQuotient_j_eq_of_transcendental_of_odd ht N hN Q Q' hQ hQ' hΔ hΔ'
+      hj
+
+private theorem fullKernelDiscAt_of_odd_aux (N : ℕ) [NeZero N] (hN : Odd N) : FullKernelDiscAt N :=
+  fun h2 W _ Q hQ => W.fullKernelQuotient_discriminant_ne_zero_of_odd h2 N hN Q hQ
+
+def dictNOdd (N : ℕ) [NeZero N] (hN : Odd N) (data : ModularPolynomialData N) (j₀ : Qbar) :
+    RootsAt data (nearCurve j₀).j ≃ CycSubH (nearCurve j₀) N :=
+  dictN N data j₀ (fullKernelIsRootAt_of_odd_aux N hN) (fullKernelInjAt_of_odd_aux N hN)
+    (fullKernelDiscAt_of_odd_aux N hN)
+
+theorem dictNOdd_eq_dictOdd (N : ℕ) [NeZero N] (hN : Odd N) (data : ModularPolynomialData N)
+    (j₀ : Qbar) :
+    dictNOdd N hN data j₀ = dictOdd N hN data j₀ :=
+  dictN_eq_dictOdd_aux N hN data j₀ _ _ _
+
+end ModularCurve.TatePoint
+
+end
+
+noncomputable example (data : ModularCurve.ModularPolynomialData 3) (j₀ :
+  ModularCurve.TatePoint.Qbar) :
+    ModularCurve.TatePoint.RootsAt data (ModularCurve.TatePoint.nearCurve j₀).j ≃
+      ModularCurve.TatePoint.CycSubH (ModularCurve.TatePoint.nearCurve j₀) 3 :=
+  ModularCurve.TatePoint.dictNOdd 3 (by decide) data j₀
+
+open scoped Classical
+open _root_.WeierstrassCurve
+  _root_.P2MW.S_WeierstrassCurve_fullKernelQuotient_eq_veluQuotient_of_odd.WeierstrassCurve in
+theorem solution {F : Type*} [Field F] [DecidableEq F] (W : WeierstrassCurve F)
+    (Q : W.toAffine.Point) {N : ℕ} (hN : Odd N) (hQ : addOrderOf Q = N) :
+    W.fullKernelQuotient Q N = W.veluQuotient (W.oddOrderSummingSet Q ((N - 1) / 2)) :=
+  WeierstrassCurve.fullKernelQuotient_eq_veluQuotient_of_odd_aux W Q hN hQ
+
+end S_WeierstrassCurve_fullKernelQuotient_eq_veluQuotient_of_odd
+end P2MW
+export P2MW.S_WeierstrassCurve_fullKernelQuotient_eq_veluQuotient_of_odd (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open scoped Classical
+theorem WeierstrassCurve.fullKernelQuotient_eq_veluQuotient_of_odd {F : Type*} [Field F]
+    [DecidableEq F] (W : WeierstrassCurve F)
+    (Q : W.toAffine.Point) {N : ℕ} (hN : Odd N) (hQ : addOrderOf Q = N) :
+    W.fullKernelQuotient Q N = W.veluQuotient (W.oddOrderSummingSet Q ((N - 1) / 2)) :=
+  solution W Q hN hQ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_galoisRepUnramifiedAt_of_hasGoodReduction.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_galoisRepUnramifiedAt_of_hasGoodReduction.lean
new file mode 100644
index 0000000000..68d8224205
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_galoisRepUnramifiedAt_of_hasGoodReduction.lean
@@ -0,0 +1,370 @@
+/-
+Based on Prove2Me node WeierstrassCurve.galoisRepUnramifiedAt_of_hasGoodReduction
+(b462b906-a910-59f6-bd54-c261cd1ec02a) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 43e8434d-cc9e-573b-bc2b-367a86610e13
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Reduction
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Ramification
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ValuationSubring_isDiscreteValuationRing_comap_of_liesOverPrime
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ValuationSubring_exists_inertiaSubgroup_restrictNormal_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_hasGoodReduction_baseChange_of_valuation_lt_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_reducePoint_some
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_reducePoint_some_eq_zero_iff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_reducePoint_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_eq_zero_of_smul_eq_zero_of_reducePoint_eq_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_PointReduction
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Néron–Ogg–Shafarevich: good reduction gives E[n] unramified at q
+
+Theorem statement: `WeierstrassCurve.galoisRepUnramifiedAt_of_hasGoodReduction`
+(`b462b906-a910-59f6-bd54-c261cd1ec02a`), by Claude, 2026-09-05.
+
+Proof: submission `43e8434d-cc9e-573b-bc2b-367a86610e13`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a discrete valuation domain equipped with an algebra structure over $\mathbb{Q}$ making
+$\mathbb{Q}$ its field of fractions, and let $E$ be a Weierstrass curve over $\mathbb{Q}$ carrying
+an instance of good reduction over $R$ (`E.HasGoodReduction R`). Let $q$ and $n$ be natural numbers,
+with $q$ prime, with the image of $q$ in $R$ irreducible — so that $q$ is a uniformiser of $R$ — and
+with $q \nmid n$. The conclusion is the predicate `GaloisRepUnramifiedAt` for $E$, the integer $n$
+and the prime $q$, taken with base field $\mathbb{Q}$ and algebraic closure $K =
+\mathrm{AlgebraicClosure}\ \mathbb{Q}$: for every valuation subring $A$ of
+$\mathrm{AlgebraicClosure}\ \mathbb{Q}$ which lies over $q$ in the sense that the image of $q$ is a
+non-unit of $A$, for every automorphism $\sigma \in \mathrm{Gal}(\overline{\mathbb{Q}}/\mathbb{Q})$
+lying in the image of the inertia subgroup of $A$ over $\mathbb{Q}$ under the inclusion of the
+decomposition subgroup into the full automorphism group, and for every element $x$ of the
+$\mathbb{Z}$-submodule of $n$-torsion points of the base change of $E$ to
+$\mathrm{AlgebraicClosure}\ \mathbb{Q}$, one has $\sigma \bullet x = x$.
+
+This is the accessible direction of the criterion of Néron–Ogg–Shafarevich for elliptic curves: good
+reduction at $q$ forces the mod-$n$ (and $n$-torsion) Galois representation to be unramified at
+every place above $q$ when $q \nmid n$. It is used downstream, via
+[`WeierstrassCurve.galoisRepUnramifiedAt_of_goodReduction`]
+(thm.html#WeierstrassCurve.galoisRepUnramifiedAt_of_goodReduction)
+and
+[`WeierstrassCurve.tateModuleRep_isUnramifiedAt_of_isGoodPrimeFor`]
+(thm.html#WeierstrassCurve.tateModuleRep_isUnramifiedAt_of_isGoodPrimeFor),
+to control the ramification of the Galois representations attached to the Frey curve away from its
+bad primes.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_galoisRepUnramifiedAt_of_hasGoodReduction.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_galoisRepUnramifiedAt_of_hasGoodReduction
+
+noncomputable section
+
+open WeierstrassCurve IsDiscreteValuationRing IsLocalRing IsDedekindDomain.HeightOneSpectrum
+open scoped WeierstrassCurve.Affine
+
+local notation "Qb" => AlgebraicClosure ℚ
+
+namespace NOSAssembly
+
+theorem reduceCoord_map (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+    {K : Type*} [Field K] [Algebra R K] [IsFractionRing R K]
+    (σR : R ≃+* R) (σK : K ≃+* K)
+    (hcomp : ∀ r : R, σK (algebraMap R K r) = algebraMap R K (σR r))
+    (σk : ResidueField R ≃+* ResidueField R)
+    (hres : ∀ r : R, σk (residue R r) = residue R (σR r)) (x : K) :
+    reduceCoord R (σK x) = σk (reduceCoord R x) := by
+  classical
+  by_cases hx : ∃ r : R, algebraMap R K r = x
+  · have hσx : ∃ r : R, algebraMap R K r = σK x :=
+      ⟨σR hx.choose, by rw [← hcomp, hx.choose_spec]⟩
+    simp only [reduceCoord, dite_eq_left hx, dite_eq_left hσx, hres]
+    have hc : hσx.choose = σR hx.choose :=
+      IsFractionRing.injective R K (by rw [hσx.choose_spec, ← hcomp, hx.choose_spec])
+    rw [hc]
+  · have hσx : ¬ ∃ r : R, algebraMap R K r = σK x := by
+      rintro ⟨r, hr⟩
+      exact hx ⟨σR.symm r, σK.injective (by rw [hcomp, RingEquiv.apply_symm_apply, hr])⟩
+    simp only [reduceCoord, dite_eq_right hx, dite_eq_right hσx, map_zero]
+
+theorem point_descend_of_mem (W : WeierstrassCurve ℚ) (L : IntermediateField ℚ Qb)
+    (x y : Qb) (hx : x ∈ L) (hy : y ∈ L)
+    (h : (W.baseChange Qb).toAffine.Nonsingular x y) :
+    ∃ h' : (W.baseChange L).toAffine.Nonsingular ⟨x, hx⟩ ⟨y, hy⟩,
+      WeierstrassCurve.Affine.Point.map L.val
+          (WeierstrassCurve.Affine.Point.some ⟨x, hx⟩ ⟨y, hy⟩ h')
+        = WeierstrassCurve.Affine.Point.some x y h := by
+  have h' : (W.baseChange L).toAffine.Nonsingular ⟨x, hx⟩ ⟨y, hy⟩ :=
+    (W.toAffine.baseChange_nonsingular (f := L.val) L.val.injective (⟨x, hx⟩ : L) (⟨y, hy⟩ : L)).mp
+      h
+  exact ⟨h', rfl⟩
+
+end NOSAssembly
+
+open NOSAssembly
+
+
+theorem galoisRepUnramifiedAt_of_hasGoodReduction'
+    (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R] [Algebra R ℚ]
+    [IsFractionRing R ℚ]
+    (E : WeierstrassCurve ℚ) [E.HasGoodReduction R]
+    {q n : ℕ} (hq : q.Prime) (hqR : Irreducible (q : R)) (hqn : ¬ q ∣ n) :
+    WeierstrassCurve.Affine.Point.GaloisRepUnramifiedAt (K := Qb) ℚ E n q := by
+  classical
+  have : Algebra.IsAlgebraic ℚ Qb := AlgebraicClosure.isAlgebraic ℚ
+  have : IsAlgClosure ℚ Qb := ⟨inferInstance, inferInstance⟩
+  have : Normal ℚ Qb := IsAlgClosure.normal ℚ Qb
+  intro A hA σ₀ hσ₀ P
+  obtain ⟨σ, hσI, rfl⟩ := Subgroup.mem_map.mp hσ₀
+  have hAval : A.valuation ((q : ℕ) : Qb) < 1 := hA
+  apply Subtype.ext
+  change (σ : Qb ≃ₐ[ℚ] Qb) • (P : (E⁄Qb).Point) = P
+  rw [WeierstrassCurve.Affine.Point.algEquiv_smul_def]
+  set σ₁ : Qb ≃ₐ[ℚ] Qb := ((A.decompositionSubgroup ℚ).subtype σ) with hσ₁def
+  obtain ⟨Pv, hPn⟩ := P
+  simp only
+  cases Pv with
+  | zero => rfl
+  | some x y h =>
+  set L₀ : IntermediateField ℚ Qb := IntermediateField.adjoin ℚ {x, y} with hL₀def
+  have : FiniteDimensional ℚ L₀ := by
+    rw [hL₀def]
+    exact IntermediateField.finiteDimensional_adjoin_pair
+      (Algebra.IsAlgebraic.isAlgebraic x).isIntegral
+      (Algebra.IsAlgebraic.isAlgebraic y).isIntegral
+  have hx0 : x ∈ L₀ := IntermediateField.subset_adjoin ℚ {x, y} (Set.mem_insert x {y})
+  have hy0 : y ∈ L₀ := IntermediateField.subset_adjoin ℚ {x, y} (Set.mem_insert_of_mem x rfl)
+  set L : IntermediateField ℚ Qb := IntermediateField.normalClosure ℚ (↥L₀) Qb with hLdef
+  have : FiniteDimensional ℚ L := by rw [hLdef]; infer_instance
+  have : Normal ℚ L := by rw [hLdef]; exact normalClosure.normal ℚ (↥L₀) Qb
+  have hx : x ∈ L := L₀.le_normalClosure hx0
+  have hy : y ∈ L := L₀.le_normalClosure hy0
+  set S : ValuationSubring L := A.comap (algebraMap L Qb) with hSdef
+  have hSdvr : IsDiscreteValuationRing S :=
+    ValuationSubring.isDiscreteValuationRing_comap_of_liesOverPrime L A hq hA
+  have hqmem : ((q : ℕ) : L) ∈ S := by
+    change algebraMap L Qb ((q : ℕ) : L) ∈ A
+    rw [map_natCast]
+    exact natCast_mem A q
+  set ι : S →+* A :=
+    RingHom.codRestrict ((algebraMap L Qb).comp S.subtype) A.toSubring
+      (fun z => z.2) with hιdef
+  have hq_nonunit : ¬ IsUnit (⟨((q : ℕ) : L), hqmem⟩ : S) := by
+    intro hu
+    have hu' : IsUnit (ι ⟨((q : ℕ) : L), hqmem⟩) := hu.map ι
+    have h1 := (A.valuation_eq_one_iff _).mp hu'
+    have h2 : ((ι ⟨((q : ℕ) : L), hqmem⟩ : A) : Qb) = ((q : ℕ) : Qb) := by
+      change algebraMap L Qb ((q : ℕ) : L) = _
+      rw [map_natCast]
+    rw [h2] at h1
+    exact hAval.ne h1
+  have hSval : S.valuation ((q : ℕ) : L) < 1 := by
+    refine lt_of_le_of_ne (S.valuation_le_one ⟨((q : ℕ) : L), hqmem⟩) ?_
+    intro h1
+    exact hq_nonunit ((S.valuation_eq_one_iff _).mpr h1)
+  have hGood : (E.baseChange L).HasGoodReduction S :=
+    WeierstrassCurve.hasGoodReduction_baseChange_of_valuation_lt_one R E L S hq hqR hSval
+  obtain ⟨τ, hτ⟩ := ValuationSubring.exists_inertiaSubgroup_restrictNormal_eq L A ⟨σ, hσI⟩
+  have hτ' : ((τ : S.decompositionSubgroup ℚ) : L ≃ₐ[ℚ] L) = AlgEquiv.restrictNormalHom L σ₁ := hτ
+  have hcomm : ∀ z : L, algebraMap L Qb
+      (((τ : S.decompositionSubgroup ℚ) : L ≃ₐ[ℚ] L) z) = σ₁ (algebraMap L Qb z) := by
+    intro z
+    rw [hτ']
+    exact AlgEquiv.restrictNormal_commutes σ₁ L z
+  obtain ⟨h', hmap⟩ := point_descend_of_mem E L x y hx hy h
+  set PL : (E.baseChange L).toAffine.Point :=
+    WeierstrassCurve.Affine.Point.some ⟨x, hx⟩ ⟨y, hy⟩ h' with hPLdef
+  have hnP : (n : ℤ) • (WeierstrassCurve.Affine.Point.some x y h : (E⁄Qb).Point) = 0 := by
+    simpa using hPn
+  have hnPL : (n : ℤ) • PL = 0 := by
+    apply WeierstrassCurve.Affine.Point.map_injective (f := L.val)
+    rw [map_zsmul, hmap, map_zero]
+    exact hnP
+  have hnPL' : n • PL = 0 := by
+    have := hnPL; rwa [natCast_zsmul] at this
+  set τL : L ≃ₐ[ℚ] L := ((τ : S.decompositionSubgroup ℚ) : L ≃ₐ[ℚ] L) with hτLdef
+  have hstab : ∀ z : L, z ∈ S → τL z ∈ S := fun z hz =>
+    (((τ : S.decompositionSubgroup ℚ)) • (⟨z, hz⟩ : S)).2
+  have hstab' : ∀ z : L, τL z ∈ S → z ∈ S := by
+    intro z hz
+    have h2 := ((((τ : S.decompositionSubgroup ℚ))⁻¹) • (⟨τL z, hz⟩ : S)).2
+    have h3 : (((((τ : S.decompositionSubgroup ℚ))⁻¹ :
+        S.decompositionSubgroup ℚ) : L ≃ₐ[ℚ] L)) (τL z) = z := by
+      change ((τL)⁻¹) (τL z) = z
+      rw [AlgEquiv.aut_inv]
+      exact AlgEquiv.symm_apply_apply _ _
+    rwa [show ((((τ : S.decompositionSubgroup ℚ))⁻¹ • (⟨τL z, hz⟩ : S) : S) : L)
+      = (((((τ : S.decompositionSubgroup ℚ))⁻¹ :
+          S.decompositionSubgroup ℚ) : L ≃ₐ[ℚ] L)) (τL z) from rfl, h3] at h2
+  have hv_mem : ∀ z : L, valuation L (maximalIdeal S) z ≤ 1 ↔ z ∈ S := by
+    intro z
+    constructor
+    · intro hz
+      obtain ⟨s, hs⟩ := exists_lift_of_le_one hz
+      rw [← hs]
+      exact s.2
+    · intro hz
+      have h1 : algebraMap S L (⟨z, hz⟩ : S) = z := rfl
+      rw [← h1]
+      exact (IsDiscreteValuationRing.maximalIdeal S).valuation_le_one (K := L) _
+  have hvτ : ∀ z : L, valuation L (maximalIdeal S) (τL z) ≤ 1
+      ↔ valuation L (maximalIdeal S) z ≤ 1 := by
+    intro z
+    rw [hv_mem, hv_mem]
+    exact ⟨hstab' z, hstab z⟩
+  set σR : S ≃+* S :=
+    MulSemiringAction.toRingAut (S.decompositionSubgroup ℚ) S
+      (τ : S.decompositionSubgroup ℚ) with hσRdef
+  set σk : ResidueField S ≃+* ResidueField S :=
+    MulSemiringAction.toRingAut (S.decompositionSubgroup ℚ) (ResidueField S)
+      (τ : S.decompositionSubgroup ℚ) with hσkdef
+  have hσk1 : σk = 1 := MonoidHom.mem_ker.mp τ.2
+  have hrc : ∀ z : L, reduceCoord S (τL z) = reduceCoord S z := by
+    intro z
+    have hres : ∀ s : S, σk (residue S s) = residue S (σR s) := fun s =>
+      (IsLocalRing.ResidueField.residue_smul (S.decompositionSubgroup ℚ)
+        ((τ : S.decompositionSubgroup ℚ)) s).symm
+    have h1 := reduceCoord_map S σR τL.toRingEquiv (fun s => rfl) σk hres z
+    rw [hσk1] at h1
+    exact h1
+  have hzero : ∀ (a b : L) (hab : (E.baseChange L).toAffine.Nonsingular a b),
+      ¬ (valuation L (maximalIdeal S) a ≤ 1 ∧ valuation L (maximalIdeal S) b ≤ 1) →
+      reducePoint_alt S (E.baseChange L) (.some a b hab) = 0 := by
+    intro a b hab hguard
+    change (if _ : valuation L (maximalIdeal S) a ≤ 1 ∧ valuation L (maximalIdeal S) b ≤ 1
+        then _ else WeierstrassCurve.Affine.Point.zero) = _
+    rw [dite_eq_right hguard]
+    rfl
+  have hred_fix : ∀ Q : (E.baseChange L).toAffine.Point,
+      reducePoint_alt S (E.baseChange L) (WeierstrassCurve.Affine.Point.map τL.toAlgHom Q)
+        = reducePoint_alt S (E.baseChange L) Q := by
+    intro Q
+    cases Q with
+    | zero => rfl
+    | some a b hQ =>
+      have hcoe : ∀ z : L, τL.toAlgHom z = τL z := fun z => rfl
+      rw [WeierstrassCurve.Affine.Point.map_some]
+      simp only [hcoe]
+      by_cases hva : valuation L (maximalIdeal S) a ≤ 1
+      · by_cases hvb : valuation L (maximalIdeal S) b ≤ 1
+        · have hnsτ : (E.baseChange L).toAffine.Nonsingular (τL a) (τL b) :=
+            (E.toAffine.baseChange_nonsingular (f := τL.toAlgHom)
+              τL.toAlgHom.injective a b).mpr hQ
+          obtain ⟨hh1, he1⟩ := WeierstrassCurve.reducePoint_some S (E.baseChange L)
+            hnsτ ((hvτ a).mpr hva) ((hvτ b).mpr hvb)
+          obtain ⟨hh2, he2⟩ := WeierstrassCurve.reducePoint_some S (E.baseChange L) hQ hva hvb
+          rw [he1, he2]
+          simp only [WeierstrassCurve.Affine.Point.some.injEq]
+          exact ⟨hrc a, hrc b⟩
+        · rw [hzero _ _ _ (fun hc => hvb hc.2),
+            hzero _ _ _ (fun hc => hvb ((hvτ b).mp hc.2))]
+      · rw [(WeierstrassCurve.reducePoint_some_eq_zero_iff S (E.baseChange L) hQ).mpr hva,
+          (WeierstrassCurve.reducePoint_some_eq_zero_iff S (E.baseChange L) _).mpr
+            (fun hc => hva ((hvτ a).mp hc))]
+  have hn0 : ((n : ℕ) : ResidueField S) ≠ 0 := by
+    intro h0
+    have hmemn : ((n : ℕ) : S) ∈ IsLocalRing.maximalIdeal S := by
+      rw [← residue_eq_zero_iff, map_natCast]
+      exact h0
+    have hnu : ¬ IsUnit ((n : ℕ) : S) := mem_nonunits_iff.mp ((mem_maximalIdeal _).mp hmemn)
+    have hqp : Prime (q : ℤ) := Nat.prime_iff_prime_int.mp hq
+    have hcop : IsCoprime (q : ℤ) (n : ℤ) := hqp.coprime_iff_not_dvd.mpr (by exact_mod_cast hqn)
+    obtain ⟨u, v, huv⟩ := hcop.map (algebraMap ℤ S)
+    have h1 : IsUnit (u * algebraMap ℤ S (q : ℤ) + v * algebraMap ℤ S (n : ℤ)) := by
+      rw [huv]; exact isUnit_one
+    rcases IsLocalRing.isUnit_or_isUnit_of_isUnit_add h1 with h2 | h2
+    · refine hq_nonunit ?_
+      have h3 : (algebraMap ℤ S (q : ℤ)) = (⟨((q : ℕ) : L), hqmem⟩ : S) := by
+        apply Subtype.ext
+        push_cast
+        rfl
+      rw [h3] at h2
+      exact isUnit_of_mul_isUnit_right h2
+    · refine hnu ?_
+      have h3 : (algebraMap ℤ S (n : ℤ)) = ((n : ℕ) : S) := by push_cast; rfl
+      rw [h3] at h2
+      exact isUnit_of_mul_isUnit_right h2
+  have hD : WeierstrassCurve.Affine.Point.map τL.toAlgHom PL = PL := by
+    have hnPLτ : n • WeierstrassCurve.Affine.Point.map τL.toAlgHom PL = 0 :=
+      calc n • WeierstrassCurve.Affine.Point.map τL.toAlgHom PL
+          = WeierstrassCurve.Affine.Point.map τL.toAlgHom (n • PL) := (map_nsmul _ _ _).symm
+        _ = WeierstrassCurve.Affine.Point.map τL.toAlgHom 0 := by rw [hnPL']
+        _ = 0 := map_zero _
+    have hnD : n • (WeierstrassCurve.Affine.Point.map τL.toAlgHom PL - PL) = 0 :=
+      calc n • (WeierstrassCurve.Affine.Point.map τL.toAlgHom PL - PL)
+          = n • WeierstrassCurve.Affine.Point.map τL.toAlgHom PL - n • PL := nsmul_sub _ _ _
+        _ = 0 - 0 := by rw [hnPLτ, hnPL']
+        _ = 0 := by rw [sub_zero]
+    have hred0 : reducePoint_alt S (E.baseChange L)
+        (WeierstrassCurve.Affine.Point.map τL.toAlgHom PL - PL) = 0 := by
+      have h4 : reducePoint_alt S (E.baseChange L)
+            (WeierstrassCurve.Affine.Point.map τL.toAlgHom PL - PL)
+          + reducePoint_alt S (E.baseChange L) PL
+          = 0 + reducePoint_alt S (E.baseChange L) PL := by
+        rw [← WeierstrassCurve.reducePoint_add, sub_add_cancel, zero_add]
+        exact hred_fix PL
+      exact add_right_cancel h4
+    have := WeierstrassCurve.eq_zero_of_smul_eq_zero_of_reducePoint_eq_zero S (E.baseChange L)
+      hn0 _ hnD hred0
+    exact sub_eq_zero.mp this
+  have hcoe2 : ∀ z : L, τL.toAlgHom z = τL z := fun z => rfl
+  have hD' := hD
+  rw [hPLdef, WeierstrassCurve.Affine.Point.map_some] at hD'
+  simp only [hcoe2, WeierstrassCurve.Affine.Point.some.injEq] at hD'
+  obtain ⟨hDx, hDy⟩ := hD'
+  change WeierstrassCurve.Affine.Point.map σ₁.toAlgHom
+      (WeierstrassCurve.Affine.Point.some x y h) = WeierstrassCurve.Affine.Point.some x y h
+  rw [WeierstrassCurve.Affine.Point.map_some]
+  simp only [WeierstrassCurve.Affine.Point.some.injEq]
+  refine ⟨?_, ?_⟩
+  · calc σ₁.toAlgHom x = σ₁ (algebraMap L Qb ⟨x, hx⟩) := rfl
+      _ = algebraMap L Qb (τL ⟨x, hx⟩) := (hcomm ⟨x, hx⟩).symm
+      _ = algebraMap L Qb ⟨x, hx⟩ := by rw [hDx]
+      _ = x := rfl
+  · calc σ₁.toAlgHom y = σ₁ (algebraMap L Qb ⟨y, hy⟩) := rfl
+      _ = algebraMap L Qb (τL ⟨y, hy⟩) := (hcomm ⟨y, hy⟩).symm
+      _ = algebraMap L Qb ⟨y, hy⟩ := by rw [hDy]
+      _ = y := rfl
+
+theorem solution
+    (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R] [Algebra R ℚ]
+    [IsFractionRing R ℚ]
+    (E : WeierstrassCurve ℚ) [E.HasGoodReduction R]
+    {q n : ℕ} (hq : q.Prime) (hqR : Irreducible (q : R)) (hqn : ¬ q ∣ n) :
+    WeierstrassCurve.Affine.Point.GaloisRepUnramifiedAt (K := AlgebraicClosure ℚ) ℚ E n q :=
+  galoisRepUnramifiedAt_of_hasGoodReduction' R E hq hqR hqn
+
+end
+
+end S_WeierstrassCurve_galoisRepUnramifiedAt_of_hasGoodReduction
+end P2MW
+export P2MW.S_WeierstrassCurve_galoisRepUnramifiedAt_of_hasGoodReduction (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.galoisRepUnramifiedAt_of_hasGoodReduction
+    (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R] [Algebra R ℚ]
+    [IsFractionRing R ℚ]
+    (E : WeierstrassCurve ℚ) [E.HasGoodReduction R]
+    {q n : ℕ} (hq : q.Prime) (hqR : Irreducible (q : R)) (hqn : ¬ q ∣ n) :
+    WeierstrassCurve.Affine.Point.GaloisRepUnramifiedAt (K := AlgebraicClosure ℚ) ℚ E n q :=
+  solution R E hq hqR hqn
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_hasGoodReduction_baseChange_of_valuation_lt_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_hasGoodReduction_baseChange_of_valuation_lt_one.lean
new file mode 100644
index 0000000000..e91ceaaef7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_hasGoodReduction_baseChange_of_valuation_lt_one.lean
@@ -0,0 +1,219 @@
+/-
+Based on Prove2Me node WeierstrassCurve.hasGoodReduction_baseChange_of_valuation_lt_one
+(70db0309-04d0-5b09-8e2d-77163276da87) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission cdbd475c-dd94-5ace-8a15-1b3e3441740b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Reduction
+
+import Mathlib.RingTheory.Valuation.ValuationSubring
+import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure
+import Mathlib.FieldTheory.IntermediateField.Basic
+import Mathlib.RingTheory.DedekindDomain.AdicValuation
+import Mathlib.RingTheory.Valuation.Discrete.Basic
+import Mathlib.RingTheory.Int.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Good reduction persists under finite base change
+
+Theorem statement: `WeierstrassCurve.hasGoodReduction_baseChange_of_valuation_lt_one`
+(`70db0309-04d0-5b09-8e2d-77163276da87`), by Claude, 2026-09-05.
+
+Proof: submission `cdbd475c-dd94-5ace-8a15-1b3e3441740b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative domain which is a discrete valuation ring, equipped with a
+$\mathbb{Q}$-algebra structure for which $\mathbb{Q}$ is its fraction field, and let $E$ be a
+Weierstrass curve over $\mathbb{Q}$ having good reduction over $R$, that is, $E$ admits an
+$R$-minimal model and the valuation attached to the maximal ideal of $R$ takes the value $1$ on the
+discriminant $\Delta_E$. Let $L$ be an intermediate field of $\mathbb{Q}$ in $\overline{\mathbb{Q}}
+=$ `AlgebraicClosure ℚ` with $L/\mathbb{Q}$ finite, and let $S$ be a valuation subring of $L$ which
+is a discrete valuation ring. Let $q$ be a prime natural number such that the image of $q$ in $R$ is
+irreducible, i.e. $q$ is a uniformiser of $R$, and such that the valuation of $S$ at the image of
+$q$ in $L$ is $<1$, i.e. $q$ lies in the maximal ideal of $S$. Then the base change $E_L$ of $E$
+along $\mathbb{Q} \to L$ has good reduction over $S$: it is minimal over $S$ and the valuation
+attached to the maximal ideal of $S$ takes the value $1$ on $\Delta_{E_L}$.
+
+This is the standard fact that good reduction of an elliptic curve at a place is preserved when the
+base is extended to a finite extension, here in the arithmetic situation where the base is a
+localisation of $\mathbb{Z}$ inside $\mathbb{Q}$ and $S$ is a discrete valuation subring of a number
+field lying over the prime $q$. It feeds the proof that the Galois representation attached to a
+curve with good reduction at $q$ is unramified at places above $q$, via
+[`WeierstrassCurve.galoisRepUnramifiedAt_of_hasGoodReduction`]
+(thm.html#WeierstrassCurve.galoisRepUnramifiedAt_of_hasGoodReduction).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_hasGoodReduction_baseChange_of_valuation_lt_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_hasGoodReduction_baseChange_of_valuation_lt_one
+
+open WeierstrassCurve IsDiscreteValuationRing IsLocalRing IsDedekindDomain.HeightOneSpectrum
+open scoped Pointwise
+
+local notation "Qb" => AlgebraicClosure ℚ
+
+namespace GoodReductionUp
+
+theorem hasGoodReduction_comap (R : Type*) [CommRing R] [IsDomain R]
+    [IsDiscreteValuationRing R] [Algebra R ℚ] [IsFractionRing R ℚ]
+    (W : WeierstrassCurve ℚ) [W.HasGoodReduction R]
+    (L : IntermediateField ℚ Qb) [FiniteDimensional ℚ L]
+    (S : ValuationSubring L) [IsDiscreteValuationRing S]
+    (q : ℕ) (hq : q.Prime) (hgen : Irreducible (q : R))
+    (hS : S.valuation (q : L) < 1) :
+    (W.baseChange L).HasGoodReduction S := by
+  have hq_nonunit : ¬ IsUnit ((q : ℤ) : S) := by
+    intro h
+    have h1 := (S.valuation_eq_one_iff ((q : ℤ) : S)).mp h
+    have h2 : (((q : ℤ) : S) : L) = (q : L) := by push_cast; ring
+    rw [h2] at h1
+    exact hS.ne h1
+  have key : ∀ x : ℤ, ¬(q : ℤ) ∣ x → IsUnit ((x : ℤ) : S) := by
+    intro x hx
+    have hqp : Prime (q : ℤ) := Nat.prime_iff_prime_int.mp hq
+    have hcop : IsCoprime (q : ℤ) x := hqp.coprime_iff_not_dvd.mpr hx
+    obtain ⟨u, v, huv⟩ := hcop.map (algebraMap ℤ S)
+    have h1 : IsUnit (u * algebraMap ℤ S (q : ℤ) + v * algebraMap ℤ S x) := by
+      rw [huv]; exact isUnit_one
+    rcases IsLocalRing.isUnit_or_isUnit_of_isUnit_add h1 with h | h
+    · exact absurd (by simpa using isUnit_of_mul_isUnit_right h) hq_nonunit
+    · simpa using isUnit_of_mul_isUnit_right h
+  have keyR : ∀ x : ℤ, ¬(q : ℤ) ∣ x → IsUnit ((x : ℤ) : R) := by
+    intro x hx
+    have hqp : Prime (q : ℤ) := Nat.prime_iff_prime_int.mp hq
+    have hcop : IsCoprime (q : ℤ) x := hqp.coprime_iff_not_dvd.mpr hx
+    obtain ⟨u, v, huv⟩ := hcop.map (algebraMap ℤ R)
+    have h1 : IsUnit (u * algebraMap ℤ R (q : ℤ) + v * algebraMap ℤ R x) := by
+      rw [huv]; exact isUnit_one
+    rcases IsLocalRing.isUnit_or_isUnit_of_isUnit_add h1 with h | h
+    · exact absurd (by simpa using isUnit_of_mul_isUnit_right h) hgen.not_isUnit
+    · simpa using isUnit_of_mul_isUnit_right h
+  have hmem : ∀ r : R, algebraMap ℚ L (algebraMap R ℚ r) ∈ S := by
+    intro r
+    set x : ℚ := algebraMap R ℚ r with hxdef
+    have hden_unit : IsUnit ((x.den : ℤ) : R) := by
+      have hv : (IsDiscreteValuationRing.maximalIdeal R).valuation ℚ x ≤ 1 := by
+        rw [hxdef]
+        exact (IsDiscreteValuationRing.maximalIdeal R).valuation_le_one (K := ℚ) r
+      have hnot := Rat.valuation_le_one_iff_den.mp hv
+      rw [Int.cast_natCast]
+      by_contra hnu
+      exact hnot ((IsLocalRing.mem_maximalIdeal _).mpr (mem_nonunits_iff.mpr hnu))
+    have hden : ¬ (q : ℤ) ∣ (x.den : ℤ) := by
+      rintro ⟨e, he⟩
+      refine hgen.not_isUnit ?_
+      have h1 : ((x.den : ℤ) : R) = ((q : ℤ) : R) * ((e : ℤ) : R) := by
+        rw [← Int.cast_mul, ← he]
+      rw [h1] at hden_unit
+      simpa using isUnit_of_mul_isUnit_left hden_unit
+    have hnum : S.valuation ((x.num : ℤ) : L) ≤ 1 :=
+      (S.valuation_le_one_iff _).mpr (intCast_mem S x.num)
+    have hdenS : S.valuation ((x.den : ℤ) : L) = 1 := by
+      have hu := key _ hden
+      have h1 := (S.valuation_eq_one_iff (((x.den : ℤ) : S))).mp hu
+      rwa [SubringClass.coe_intCast] at h1
+    have himg : algebraMap ℚ L x = ((x.num : ℤ) : L) / ((x.den : ℤ) : L) := by
+      conv_lhs => rw [← Rat.num_div_den x]
+      rw [map_div₀, map_intCast, map_natCast]
+      push_cast
+      ring
+    rw [← S.valuation_le_one_iff, himg, map_div₀, hdenS, div_one]
+    exact hnum
+  set φ : R →+* S :=
+    RingHom.codRestrict ((algebraMap ℚ L).comp (algebraMap R ℚ)) S hmem with hφ
+  have hInt : WeierstrassCurve.IsIntegral S (W.baseChange L) := by
+    refine ⟨(integralModel R W).map φ, ?_⟩
+    have h1 : W.baseChange L
+        = (integralModel R W).map ((algebraMap ℚ L).comp (algebraMap R ℚ)) := by
+      conv_lhs => rw [← baseChange_integralModel_eq R W]
+      exact map_map (integralModel R W) (algebraMap R ℚ) (algebraMap ℚ L)
+    have h2 : ((integralModel R W).map φ).baseChange L
+        = (integralModel R W).map ((algebraMap S L).comp φ) :=
+      map_map (integralModel R W) φ (algebraMap S L)
+    rw [h1, h2]
+    congr 1
+  have hval_unit : ∀ s : S, IsUnit s →
+      (IsDiscreteValuationRing.maximalIdeal S).valuation L (algebraMap S L s) = 1 := by
+    intro s hs
+    rcases lt_or_eq_of_le
+        ((IsDiscreteValuationRing.maximalIdeal S).valuation_le_one (K := L) s) with h | h
+    · exact absurd ((IsDiscreteValuationRing.maximalIdeal S).valuation_lt_one_iff_mem
+        (K := L) s |>.mp h) (fun hm => (mem_nonunits_iff.mp
+          ((IsLocalRing.mem_maximalIdeal s).mp hm)) hs)
+    · exact h
+  have hΔR : IsUnit (integralModel R W).Δ := by
+    have hgood : (IsDiscreteValuationRing.maximalIdeal R).valuation ℚ W.Δ = 1 :=
+      HasGoodReduction.goodReduction (R := R)
+    rw [← integralModel_Δ_eq R W] at hgood
+    by_contra hnu
+    have hmemΔ : (integralModel R W).Δ ∈ IsLocalRing.maximalIdeal R :=
+      (IsLocalRing.mem_maximalIdeal _).mpr (mem_nonunits_iff.mpr hnu)
+    have hlt := ((IsDiscreteValuationRing.maximalIdeal R).valuation_lt_one_iff_mem
+      (K := ℚ) (integralModel R W).Δ).mpr hmemΔ
+    exact hlt.ne hgood
+  have hΔ : (IsDiscreteValuationRing.maximalIdeal S).valuation L (W.baseChange L).Δ = 1 := by
+    have h1 : (W.baseChange L).Δ = algebraMap S L (φ (integralModel R W).Δ) := by
+      change (W.map (algebraMap ℚ L)).Δ = _
+      rw [map_Δ, ← integralModel_Δ_eq R W]
+      rfl
+    rw [h1]
+    exact hval_unit _ (hΔR.map φ)
+  have hMin : WeierstrassCurve.IsMinimal S (W.baseChange L) := by
+    refine ⟨⟨by simpa using hInt, ?_⟩⟩
+    intro C hC _
+    have hle := (valuation_Δ_aux S (C • (W.baseChange L))).2
+    have heq : ((valuation_Δ_aux S ((1 : VariableChange L) • (W.baseChange L))) :
+        WithZero (Multiplicative ℤ)) = 1 := by
+      rw [one_smul, valuation_Δ_aux_eq_of_isIntegral S (W.baseChange L)]
+      exact hΔ
+    exact Subtype.coe_le_coe.mp (by rw [heq]; exact hle)
+  exact { toIsMinimal := hMin, goodReduction := hΔ }
+
+end GoodReductionUp
+
+theorem solution
+    (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R] [Algebra R ℚ]
+    [IsFractionRing R ℚ]
+    (E : WeierstrassCurve ℚ) [E.HasGoodReduction R]
+    (L : IntermediateField ℚ (AlgebraicClosure ℚ)) [FiniteDimensional ℚ L]
+    (S : ValuationSubring L) [IsDiscreteValuationRing S]
+    {q : ℕ} (hq : q.Prime) (hqR : Irreducible (q : R)) (hS : S.valuation (q : L) < 1) :
+    (E.baseChange L).HasGoodReduction S :=
+  GoodReductionUp.hasGoodReduction_comap R E L S q hq hqR hS
+
+end S_WeierstrassCurve_hasGoodReduction_baseChange_of_valuation_lt_one
+end P2MW
+export P2MW.S_WeierstrassCurve_hasGoodReduction_baseChange_of_valuation_lt_one (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.hasGoodReduction_baseChange_of_valuation_lt_one
+    (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R] [Algebra R ℚ]
+    [IsFractionRing R ℚ]
+    (E : WeierstrassCurve ℚ) [E.HasGoodReduction R]
+    (L : IntermediateField ℚ (AlgebraicClosure ℚ)) [FiniteDimensional ℚ L]
+    (S : ValuationSubring L) [IsDiscreteValuationRing S]
+    {q : ℕ} (hq : q.Prime) (hqR : Irreducible (q : R)) (hS : S.valuation (q : L) < 1) :
+    (E.baseChange L).HasGoodReduction S :=
+  solution R E L S hq hqR hS
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_hasRamBound_one_of_nsmul_eq_zero_of_isUnit_discriminant_powerSeries.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_hasRamBound_one_of_nsmul_eq_zero_of_isUnit_discriminant_powerSeries.lean
new file mode 100644
index 0000000000..8c286a3eef
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_hasRamBound_one_of_nsmul_eq_zero_of_isUnit_discriminant_powerSeries.lean
@@ -0,0 +1,368 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.hasRamBound_one_of_nsmul_eq_zero_of_isUnit_discriminant_powerSeries
+(4bc78d56-a5e5-547d-9853-2d36912c5bdf) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission abbdd1dc-8382-51e6-ae0e-c08f7fb8be09
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure
+public import Mathlib.RingTheory.HahnSeries.PowerSeries
+public import LeanPool.FLTEichlerShimura.Definitions.Def_HahnSeries_RamificationBound
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_TorsionIntegral
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_hasRamBound_one_of_forall_ringEquiv_apply_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_smul_some_eq_zero_iff
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Torsion coordinates of a good-reduction model are Laurent
+
+Theorem statement:
+`WeierstrassCurve.hasRamBound_one_of_nsmul_eq_zero_of_isUnit_discriminant_powerSeries`
+(`4bc78d56-a5e5-547d-9853-2d36912c5bdf`), by Claude, 2026-09-05.
+
+Proof: submission `abbdd1dc-8382-51e6-ae0e-c08f7fb8be09`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $E$ be a Weierstrass curve over the power series ring $\overline{\mathbb Q}[[t]] =$ `PowerSeries
+(AlgebraicClosure ℚ)` whose discriminant $\Delta_E$ is a unit in that ring, and let $d$ be a natural
+number with $0 < d$. Consider the base change of $E$ along the inclusion `HahnSeries.ofPowerSeries`
+of $\overline{\mathbb Q}[[t]]$ into the Hahn series field $\overline{\mathbb Q}((t^{\mathbb Q}))$ of
+series with rational exponents and coefficients in $\overline{\mathbb Q}$, and let $x, y \in
+\overline{\mathbb Q}((t^{\mathbb Q}))$ be such that $(x,y)$ is a nonsingular point of the associated
+affine curve, so that it determines a point `WeierstrassCurve.Affine.Point.some x y h` of the group
+of points of that affine curve. Assume this point is killed by $d$, i.e. $d$ times it is the point
+at infinity. The conclusion is that both $x$ and $y$ satisfy [`HahnSeries.HasRamBound
+1`](def/HahnSeries_RamificationBound.html#L32), that is, the support of each of $x$ and $y$ — its
+set of exponents with nonzero coefficient — is contained in the image of $k \mapsto (k : \mathbb
+Q)/1$ for $k \in \mathbb Z$, hence consists of integers; equivalently $x$ and $y$ lie in the Laurent
+subfield $\overline{\mathbb Q}((t))$.
+
+This is the Néron–Ogg–Shafarevich phenomenon in the shape needed here: torsion points of a
+Weierstrass model with unit discriminant over the strictly Henselian ring $\overline{\mathbb
+Q}[[t]]$ acquire no ramification, so their coordinates have integral exponents. It is the base case
+for the ramification bounds attached to modular polynomial data, being used by the lemmas
+[`ModularCurve.ModularPolynomialData.hasRamBound_one_of_isRoot_off_zero_1728_of_odd`]
+(thm.html#ModularCurve.ModularPolynomialData.hasRamBound_one_of_isRoot_off_zero_1728_of_odd),
+[`ModularCurve.ModularPolynomialData.hasRamBound_three_of_isRoot_at_zero_of_odd`]
+(thm.html#ModularCurve.ModularPolynomialData.hasRamBound_three_of_isRoot_at_zero_of_odd)
+and
+[`ModularCurve.ModularPolynomialData.hasRamBound_two_of_isRoot_at_1728_of_odd`]
+(thm.html#ModularCurve.ModularPolynomialData.hasRamBound_two_of_isRoot_at_1728_of_odd),
+which treat the elliptic points $j = 0$ and $j = 1728$ separately.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_hasRamBound_one_of_nsmul_eq_zero_of_isUnit_discriminant_powerSeries.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_73f0b7c4
+
+open scoped Pointwise
+
+namespace H1bTorsionLaurent
+
+variable {K : Type*} [Field K]
+
+theorem orderTop_ne_top_of_ne_zero' {x : HahnSeries ℚ K} (hx : x ≠ 0) : x.orderTop ≠ ⊤ := by
+  obtain ⟨g, hg⟩ : ∃ g, x.coeff g ≠ 0 := by
+    by_contra h
+    push Not at h
+    exact hx (by ext g; simp [h g])
+  exact ne_top_of_le_ne_top WithTop.coe_ne_top (HahnSeries.orderTop_le_of_coeff_ne_zero hg)
+
+theorem nonneg_orderTop_iff {x : HahnSeries ℚ K} :
+    0 ≤ x.orderTop ↔ ∀ q : ℚ, q < 0 → x.coeff q = 0 := by
+  constructor
+  · intro h q hq
+    exact HahnSeries.coeff_eq_zero_of_lt_orderTop (lt_of_lt_of_le (by exact_mod_cast hq) h)
+  · intro h
+    by_contra hlt
+    push Not at hlt
+    obtain ⟨g, hg⟩ := WithTop.ne_top_iff_exists.mp (ne_top_of_lt hlt)
+    have hg0 : g < 0 := by
+      have : (g : WithTop ℚ) < 0 := by rw [hg]; exact hlt
+      exact_mod_cast this
+    exact HahnSeries.coeff_orderTop_ne hg.symm (h g hg0)
+
+theorem pos_orderTop_iff {x : HahnSeries ℚ K} :
+    0 < x.orderTop ↔ ∀ q : ℚ, q ≤ 0 → x.coeff q = 0 := by
+  constructor
+  · intro h q hq
+    exact HahnSeries.coeff_eq_zero_of_lt_orderTop (lt_of_le_of_lt (by exact_mod_cast hq) h)
+  · intro h
+    by_contra hle
+    push Not at hle
+    obtain ⟨g, hg⟩ := WithTop.ne_top_iff_exists.mp (ne_top_of_le_ne_top WithTop.zero_ne_top hle)
+    have hg0 : g ≤ 0 := by
+      have : (g : WithTop ℚ) ≤ 0 := by rw [hg]; exact hle
+      exact_mod_cast this
+    exact HahnSeries.coeff_orderTop_ne hg.symm (h g hg0)
+
+variable (K) in
+noncomputable def puiseuxVal : ValuationSubring (HahnSeries ℚ K) where
+  carrier := {f | 0 ≤ f.orderTop}
+  mul_mem' {a b} ha hb := by
+    simp only [Set.mem_ofPred_eq] at ha hb ⊢
+    rw [HahnSeries.orderTop_mul]
+    exact add_nonneg ha hb
+  one_mem' := by
+    simp only [Set.mem_ofPred_eq, HahnSeries.orderTop_one]
+    exact le_rfl
+  add_mem' {a b} ha hb := by
+    change 0 ≤ (a + b).orderTop
+    exact le_trans (le_min ha hb) HahnSeries.min_orderTop_le_orderTop_add
+  zero_mem' := by
+    simp only [Set.mem_ofPred_eq, HahnSeries.orderTop_zero]
+    exact le_top
+  neg_mem' {a} ha := by simpa only [Set.mem_ofPred_eq, HahnSeries.orderTop_neg] using ha
+  mem_or_inv_mem' a := by
+    by_cases ha : a = 0
+    · left
+      simp only [Set.mem_ofPred_eq, ha, HahnSeries.orderTop_zero]
+      exact le_top
+    · simp only [Set.mem_ofPred_eq]
+      have hprod : a.orderTop + a⁻¹.orderTop = 0 := by
+        rw [← HahnSeries.orderTop_mul, mul_inv_cancel₀ ha, HahnSeries.orderTop_one]
+      obtain ⟨g, hg⟩ := WithTop.ne_top_iff_exists.mp (orderTop_ne_top_of_ne_zero' ha)
+      obtain ⟨g', hg'⟩ :=
+        WithTop.ne_top_iff_exists.mp (orderTop_ne_top_of_ne_zero' (inv_ne_zero ha))
+      rw [← hg, ← hg'] at hprod ⊢
+      have hsum : g + g' = 0 := by exact_mod_cast hprod
+      by_cases h : 0 ≤ g
+      · left
+        exact_mod_cast h
+      · right
+        have : 0 ≤ g' := by linarith
+        exact_mod_cast this
+
+theorem mem_puiseuxVal_iff {f : HahnSeries ℚ K} : f ∈ puiseuxVal K ↔ 0 ≤ f.orderTop := by
+  first
+    | rfl
+
+theorem not_isUnit_of_orderTop_pos {z : puiseuxVal K}
+    (hz : 0 < (z : HahnSeries ℚ K).orderTop) : ¬ IsUnit z := by
+  rintro ⟨u, rfl⟩
+  have h1 : ((u : puiseuxVal K) : HahnSeries ℚ K) * ((u⁻¹ : (puiseuxVal K)ˣ) : puiseuxVal K) = 1 :=
+    by
+    first
+      | exact congrArg Subtype.val u.mul_inv
+  have h2 := congrArg HahnSeries.orderTop h1
+  rw [HahnSeries.orderTop_mul, HahnSeries.orderTop_one] at h2
+  have h3 : 0 ≤ (((u⁻¹ : (puiseuxVal K)ˣ) : puiseuxVal K) : HahnSeries ℚ K).orderTop :=
+    mem_puiseuxVal_iff.mp ((u⁻¹ : (puiseuxVal K)ˣ) : puiseuxVal K).2
+  exact absurd h2 (ne_of_gt (add_pos_of_pos_of_nonneg hz h3))
+
+theorem mem_maximalIdeal_of_orderTop_pos {z : puiseuxVal K}
+    (hz : 0 < (z : HahnSeries ℚ K).orderTop) : z ∈ IsLocalRing.maximalIdeal (puiseuxVal K) :=
+  (IsLocalRing.mem_maximalIdeal _).mpr (mem_nonunits_iff.mpr (not_isUnit_of_orderTop_pos hz))
+
+theorem orderTop_C_nonneg (a : K) : 0 ≤ (HahnSeries.C a : HahnSeries ℚ K).orderTop := by
+  by_cases ha : a = 0
+  · simp [ha]
+  · rw [HahnSeries.C_apply, HahnSeries.orderTop_single ha]
+    exact le_rfl
+
+theorem hasRamBound_one_C (a : K) : HahnSeries.HasRamBound 1 (HahnSeries.C a : HahnSeries ℚ K) := by
+  intro q hq
+  rw [HahnSeries.C_apply] at hq
+  have := HahnSeries.support_single_subset hq
+  rw [Set.mem_singleton_iff] at this
+  exact ⟨0, by simp [this]⟩
+
+theorem natCast_residue_ne_zero [CharZero K] {d : ℕ} (hd : d ≠ 0) :
+    ((d : ℕ) : IsLocalRing.ResidueField (puiseuxVal K)) ≠ 0 := by
+  intro h
+  rw [← map_natCast (IsLocalRing.residue (puiseuxVal K)), IsLocalRing.residue_eq_zero_iff,
+    IsLocalRing.mem_maximalIdeal, mem_nonunits_iff] at h
+  apply h
+  have hdK : (d : K) ≠ 0 := Nat.cast_ne_zero.mpr hd
+  have hcoe : ((d : puiseuxVal K) : HahnSeries ℚ K) = HahnSeries.C (d : K) := by
+    rw [map_natCast]
+    simp
+  refine isUnit_iff_exists_inv.mpr ⟨⟨HahnSeries.C ((d : K)⁻¹), mem_puiseuxVal_iff.mpr
+    (orderTop_C_nonneg _)⟩, ?_⟩
+  apply Subtype.ext
+  change ((d : puiseuxVal K) : HahnSeries ℚ K) * HahnSeries.C ((d : K)⁻¹) = 1
+  rw [hcoe, ← map_mul, mul_inv_cancel₀ hdK, map_one]
+
+theorem support_ofPowerSeries_subset (f : PowerSeries K) :
+    (HahnSeries.ofPowerSeries ℚ K f).support ⊆ Set.range (Nat.cast : ℕ → ℚ) := by
+  intro q hq
+  rw [HahnSeries.ofPowerSeries_apply] at hq
+  obtain ⟨n, -, rfl⟩ := HahnSeries.support_embDomain_subset hq
+  exact ⟨n, rfl⟩
+
+theorem hasRamBound_one_ofPowerSeries (f : PowerSeries K) :
+    HahnSeries.HasRamBound 1 (HahnSeries.ofPowerSeries ℚ K f) := by
+  intro q hq
+  obtain ⟨n, rfl⟩ := support_ofPowerSeries_subset f hq
+  exact ⟨n, by simp⟩
+
+theorem ofPowerSeries_mem (f : PowerSeries K) : HahnSeries.ofPowerSeries ℚ K f ∈ puiseuxVal K := by
+  rw [mem_puiseuxVal_iff, nonneg_orderTop_iff]
+  intro q hq
+  by_contra h
+  obtain ⟨n, hn⟩ := support_ofPowerSeries_subset f (HahnSeries.mem_support _ _ |>.mpr h)
+  have hn' : (n : ℚ) = q := hn
+  have : (0 : ℚ) ≤ n := Nat.cast_nonneg n
+  linarith
+
+section Galois
+
+variable [CharZero K] (σr : HahnSeries ℚ K ≃+* HahnSeries ℚ K)
+
+theorem algebraMap_rat_comm (q : ℚ) :
+    σr (algebraMap ℚ (HahnSeries ℚ K) q) = algebraMap ℚ (HahnSeries ℚ K) q :=
+  RingHom.congr_fun (RingHom.ext_rat (σr.toRingHom.comp (algebraMap ℚ (HahnSeries ℚ K)))
+    (algebraMap ℚ (HahnSeries ℚ K))) q
+
+noncomputable def toRatAlgEquiv : HahnSeries ℚ K ≃ₐ[ℚ] HahnSeries ℚ K :=
+  AlgEquiv.ofRingEquiv (f := σr) (algebraMap_rat_comm σr)
+
+@[scoped simp] theorem toRatAlgEquiv_apply (z : HahnSeries ℚ K) : toRatAlgEquiv σr z = σr z := rfl
+
+variable {σr} (hσv : ∀ z : HahnSeries ℚ K, (σr z).orderTop = z.orderTop)
+  (hσ1 : ∀ z : HahnSeries ℚ K, HahnSeries.HasRamBound 1 z → σr z = z)
+
+include hσv in
+theorem mem_decompositionSubgroup :
+    toRatAlgEquiv σr ∈ (puiseuxVal K).decompositionSubgroup ℚ := by
+  rw [MulAction.mem_stabilizer_iff]
+  ext z
+  rw [ValuationSubring.mem_smul_pointwise_iff_exists]
+  constructor
+  · rintro ⟨s, hs, rfl⟩
+    rw [AlgEquiv.smul_def, toRatAlgEquiv_apply, mem_puiseuxVal_iff, hσv]
+    exact mem_puiseuxVal_iff.mp hs
+  · intro hz
+    refine ⟨σr.symm z, ?_, ?_⟩
+    · rw [mem_puiseuxVal_iff, ← hσv, RingEquiv.apply_symm_apply]
+      exact mem_puiseuxVal_iff.mp hz
+    · rw [AlgEquiv.smul_def, toRatAlgEquiv_apply]
+      exact σr.apply_symm_apply z
+
+include hσv hσ1 in
+theorem mem_inertiaSubgroup :
+    (⟨toRatAlgEquiv σr, mem_decompositionSubgroup hσv⟩ : (puiseuxVal K).decompositionSubgroup ℚ)
+      ∈ (puiseuxVal K).inertiaSubgroup ℚ := by
+  rw [ValuationSubring.inertiaSubgroup, MonoidHom.mem_ker]
+  ext r
+  obtain ⟨a, rfl⟩ := IsLocalRing.residue_surjective r
+  change IsLocalRing.residue _
+      ((⟨toRatAlgEquiv σr, mem_decompositionSubgroup hσv⟩ : (puiseuxVal K).decompositionSubgroup ℚ)
+        • a)
+    = IsLocalRing.residue _ a
+  rw [← sub_eq_zero, ← map_sub, IsLocalRing.residue_eq_zero_iff]
+  apply mem_maximalIdeal_of_orderTop_pos
+  change 0 < (σr (a : HahnSeries ℚ K) - (a : HahnSeries ℚ K)).orderTop
+  set a0 : K := (a : HahnSeries ℚ K).coeff 0 with ha0
+  have hpos : 0 < ((a : HahnSeries ℚ K) - HahnSeries.C a0).orderTop := by
+    rw [pos_orderTop_iff]
+    intro q hq
+    rw [HahnSeries.coeff_sub, HahnSeries.C_apply, HahnSeries.coeff_single]
+    rcases lt_or_eq_of_le hq with hq' | rfl
+    · rw [(nonneg_orderTop_iff.mp (mem_puiseuxVal_iff.mp a.2)) q hq', ite_eq_right (ne_of_lt hq')]
+      simp
+    · simp [ha0]
+  have heq : σr (a : HahnSeries ℚ K) - (a : HahnSeries ℚ K) = σr ((a : HahnSeries ℚ K) -
+    HahnSeries.C a0)
+      - ((a : HahnSeries ℚ K) - HahnSeries.C a0) := by
+    rw [map_sub, hσ1 _ (hasRamBound_one_C a0)]
+    ring
+  rw [heq, sub_eq_add_neg]
+  calc 0 < ((a : HahnSeries ℚ K) - HahnSeries.C a0).orderTop := hpos
+    _ = min (σr ((a : HahnSeries ℚ K) - HahnSeries.C a0)).orderTop
+          (-((a : HahnSeries ℚ K) - HahnSeries.C a0)).orderTop := by
+        rw [hσv, HahnSeries.orderTop_neg, min_self]
+    _ ≤ _ := HahnSeries.min_orderTop_le_orderTop_add
+
+end Galois
+
+end H1bTorsionLaurent
+
+open H1bTorsionLaurent in
+theorem solution
+    (E : WeierstrassCurve (PowerSeries (AlgebraicClosure ℚ))) (hΔ : IsUnit E.Δ) {d : ℕ} (hd : 0 < d)
+    [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))] (x y : HahnSeries ℚ (AlgebraicClosure ℚ))
+    (h : (E.map (HahnSeries.ofPowerSeries ℚ (AlgebraicClosure ℚ))).toAffine.Nonsingular x y)
+    (htor : d • (WeierstrassCurve.Affine.Point.some x y h :
+      (E.map (HahnSeries.ofPowerSeries ℚ (AlgebraicClosure ℚ))).toAffine.Point) = 0) :
+    HahnSeries.HasRamBound 1 x ∧ HahnSeries.HasRamBound 1 y := by
+  let Kb := AlgebraicClosure ℚ
+  let L := HahnSeries ℚ Kb
+  let ι : PowerSeries Kb →+* L := HahnSeries.ofPowerSeries ℚ Kb
+  let A : ValuationSubring L := puiseuxVal Kb
+  let ιA : PowerSeries Kb →+* A := ι.codRestrict A ofPowerSeries_mem
+  let W : WeierstrassCurve A := E.map ιA
+  have hVW : W.map A.subtype = E.map ι := by
+    rw [WeierstrassCurve.map_map]
+    congr 1
+  have hΔ' : (W.map (IsLocalRing.residue A)).Δ ≠ 0 := by
+    rw [WeierstrassCurve.map_residue_Δ_ne_zero_iff, WeierstrassCurve.map_Δ]
+    exact hΔ.map ιA
+  have hn : ((d : ℕ) : IsLocalRing.ResidueField A) ≠ 0 := natCast_residue_ne_zero hd.ne'
+  have hψ : ((E.map ι).ψ (d : ℤ)).evalEval x y = 0 :=
+    (WeierstrassCurve.Affine.Point.smul_some_eq_zero_iff (E.map ι) h (d : ℤ)).mp
+      (by first | (rw [natCast_zsmul]; exact htor) )
+  have step : ∀ σr : L ≃+* L, (∀ z : L, (σr z).orderTop = z.orderTop) →
+      (∀ z : L, HahnSeries.HasRamBound 1 z → σr z = z) → σr x = x ∧ σr y = y := by
+    intro σr hσv hσ1
+    have hWσ : (E.map ι).map σr.toRingHom = E.map ι := by
+      rw [WeierstrassCurve.map_map]
+      apply WeierstrassCurve.ext <;> simp only [WeierstrassCurve.map, RingHom.comp_apply,
+        RingEquiv.toRingHom_eq_coe,
+        RingHom.coe_coe] <;> exact hσ1 _ (hasRamBound_one_ofPowerSeries _)
+    have h' : (E.map ι).toAffine.Nonsingular (σr x) (σr y) := by
+      have := (WeierstrassCurve.Affine.map_nonsingular (E.map ι).toAffine (f := σr.toRingHom)
+        σr.injective x y).mpr h
+      rw [show (E.map ι).toAffine.map σr.toRingHom = (E.map ι).toAffine from hWσ] at this
+      exact this
+    have hP' : d • (WeierstrassCurve.Affine.Point.some (σr x) (σr y) h' :
+        (E.map ι).toAffine.Point) = 0 := by
+      have hψ' : ((E.map ι).ψ (d : ℤ)).evalEval (σr x) (σr y) = 0 := by
+        have e1 : (E.map ι).ψ (d : ℤ) = ((E.map ι).map σr.toRingHom).ψ (d : ℤ) := by rw [hWσ]
+        rw [e1, WeierstrassCurve.map_ψ]
+        change Polynomial.evalEval (σr.toRingHom x) (σr.toRingHom y) _ = 0
+        rw [Polynomial.map_mapRingHom_evalEval, hψ, map_zero]
+      have := (WeierstrassCurve.Affine.Point.smul_some_eq_zero_iff (E.map ι) h' (d : ℤ)).mpr hψ'
+      first | (rw [natCast_zsmul] at this; exact this)
+    exact WeierstrassCurve.fixed_of_mem_inertia_of_nsmul_eq_zero W hVW hΔ'
+      (mem_decompositionSubgroup hσv) (mem_inertiaSubgroup hσv hσ1) hn h h' htor hP'
+  exact ⟨HahnSeries.hasRamBound_one_of_forall_ringEquiv_apply_eq (fun σ hv h1 => (step σ hv h1).1),
+    HahnSeries.hasRamBound_one_of_forall_ringEquiv_apply_eq (fun σ hv h1 => (step σ hv h1).2)⟩
+
+end S_OVERLONG_73f0b7c4
+end P2MW
+export P2MW.S_OVERLONG_73f0b7c4
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.hasRamBound_one_of_nsmul_eq_zero_of_isUnit_discriminant_powerSeries
+    (E : WeierstrassCurve (PowerSeries (AlgebraicClosure ℚ))) (hΔ : IsUnit E.Δ) {d : ℕ} (hd : 0 < d)
+    [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))] (x y : HahnSeries ℚ (AlgebraicClosure ℚ))
+    (h : (E.map (HahnSeries.ofPowerSeries ℚ (AlgebraicClosure ℚ))).toAffine.Nonsingular x y)
+    (htor : d • (WeierstrassCurve.Affine.Point.some x y h :
+      (E.map (HahnSeries.ofPowerSeries ℚ (AlgebraicClosure ℚ))).toAffine.Point) = 0) :
+    HahnSeries.HasRamBound 1 x ∧ HahnSeries.HasRamBound 1 y :=
+  solution E hΔ hd x y h htor
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_isCoprime_Phi_PsiSq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_isCoprime_Phi_PsiSq.lean
new file mode 100644
index 0000000000..f84ef66e2d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_isCoprime_Phi_PsiSq.lean
@@ -0,0 +1,362 @@
+/-
+Based on Prove2Me node WeierstrassCurve.isCoprime_Phi_PsiSq
+(0f9a1d23-7366-54ec-bbbd-9af4a5dd2cbd) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9d37f4a8-1614-59d3-9a16-51a875770dce
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+
+import Mathlib.NumberTheory.EllipticDivisibilitySequence
+import Mathlib.Algebra.Ring.NegOnePow
+import Mathlib.Data.Fin.VecNotation
+import Mathlib.Data.Fin.Tuple.Sort
+import Mathlib.Algebra.GroupWithZero.NonZeroDivisors
+import Mathlib.Algebra.MvPolynomial.CommRing
+import Mathlib.Algebra.MvPolynomial.Basic
+import Mathlib.Tactic.LinearCombination
+import Mathlib.Tactic.Ring
+import Mathlib.Tactic.Abel
+import Mathlib.Tactic.IntervalCases
+import Mathlib.Tactic.FieldSimp
+import Mathlib.GroupTheory.Perm.Basic
+import Mathlib.GroupTheory.Perm.Sign
+import Mathlib.GroupTheory.Perm.Cycle.Type
+import Mathlib.Algebra.Polynomial.Bivariate
+import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+import Mathlib.AlgebraicGeometry.EllipticCurve.Jacobian.Point
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+import Mathlib.FieldTheory.IsAlgClosed.Basic
+import Mathlib.FieldTheory.Separable
+import Mathlib.Data.Nat.Factorization.Induction
+import Mathlib.Logic.Embedding.Set
+import Mathlib.SetTheory.Cardinal.Finite
+import Mathlib.Data.Set.Card
+import Mathlib.Algebra.Module.Torsion.Basic
+import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_EDSEngine
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Coprimality of the division polynomials Φₙ and Ψₙ²
+
+Theorem statement: `WeierstrassCurve.isCoprime_Phi_PsiSq` (`0f9a1d23-7366-54ec-bbbd-9af4a5dd2cbd`),
+by Claude, 2026-09-05.
+
+Proof: submission `9d37f4a8-1614-59d3-9a16-51a875770dce`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field and let $W$ be a Weierstrass curve over $F$ which is elliptic, i.e. whose
+discriminant is a unit, and let $n$ be an arbitrary integer (no sign condition, and no condition on
+$n$ modulo the characteristic of $F$). The assertion is that the two univariate division polynomials
+attached to $W$ and $n$ in Mathlib's notation, namely `W.Φ n` and `W.ΨSq n` — the numerator and the
+denominator of the $x$-coordinate of multiplication by $n$, so that $x \circ [n] = \Phi_n/\Psi_n^2$
+as a rational function — are coprime as elements of the polynomial ring $F[X]$, in the sense of
+`IsCoprime`: there exist polynomials $a, b \in F[X]$ with $a\,\Phi_n + b\,\Psi_n^2 = 1$. Over a
+field this is equivalent to the vanishing of the greatest common divisor condition $\gcd(\Phi_n,
+\Psi_n^2) = 1$, and it includes the degenerate cases $n = 0, \pm 1$, where one of the two
+polynomials is a unit.
+
+This is the classical statement that the representation $x \circ [n] = \Phi_n/\Psi_n^2$ of the
+multiplication-by-$n$ map is in lowest terms, which is what makes the degree of $[n]$ readable off
+the degrees of $\Phi_n$ and $\Psi_n^2$. It is used throughout the treatment of isogeny degrees and
+kernels, for instance in the computation of degrees of Frobenius endomorphisms and in the
+description of kernel ideals of quaternionic endomorphism rings.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_isCoprime_Phi_PsiSq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_isCoprime_Phi_PsiSq
+
+section PortGenNetIdentities
+
+namespace Deep
+namespace Gen
+
+open WeierstrassCurve Polynomial
+
+variable {F K : Type*} [Field F] [Field K] [Algebra F K]
+variable (W : WeierstrassCurve F)
+
+theorem ΨSq_eval_eq_zero_of_preΨ {m : ℕ} {x₀ : K}
+    (h : ((W.baseChange K).preΨ (m : ℤ)).eval x₀ = 0) :
+    ((W.baseChange K).ΨSq m).eval x₀ = 0 := by
+  rw [preΨ_ofNat] at h
+  rw [ΨSq_ofNat, eval_mul, eval_pow, h, zero_pow two_ne_zero, zero_mul]
+
+variable [IsAlgClosed K]
+
+theorem isCoprime_ΨSq_succ [W.IsElliptic] (n : ℕ) :
+    IsCoprime ((W.baseChange K).ΨSq n) ((W.baseChange K).ΨSq (n + 1)) := by
+  classical
+  rw [Polynomial.isCoprime_iff_aeval_ne_zero_of_isAlgClosed (k := K) (K := K)]
+  intro x₀
+  by_contra hcon
+  push Not at hcon
+  obtain ⟨hn0, hn1⟩ := hcon
+  rw [coe_aeval_eq_eval] at hn0 hn1
+  obtain ⟨y₀, hy₀⟩ := IsAlgClosed.exists_root
+    (C (1 : K) * X ^ 2 + C ((W.baseChange K).a₁ * x₀ + (W.baseChange K).a₃) * X +
+      C (-(x₀ ^ 3 + (W.baseChange K).a₂ * x₀ ^ 2 + (W.baseChange K).a₄ * x₀ +
+        (W.baseChange K).a₆)))
+    (by rw [Polynomial.degree_quadratic one_ne_zero]; decide)
+  have heq : (W.baseChange K).toAffine.Equation x₀ y₀ := by
+    rw [Affine.equation_iff]
+    simp only [IsRoot.def, eval_add, eval_mul, eval_pow, eval_C, eval_X] at hy₀
+    linear_combination hy₀
+  have hns : (W.baseChange K).toAffine.Nonsingular x₀ y₀ :=
+    (Affine.equation_iff_nonsingular).mp heq
+  have hψ0 : ((W.baseChange K).ψ (n : ℤ)).evalEval x₀ y₀ = 0 := by
+    have h2 := evalEval_ψ_sq (W.baseChange K) heq (n : ℤ)
+    rw [hn0] at h2
+    exact (pow_eq_zero_iff two_ne_zero).mp h2
+  have hψ1 : ((W.baseChange K).ψ ((n : ℤ) + 1)).evalEval x₀ y₀ = 0 := by
+    have h2 := evalEval_ψ_sq (W.baseChange K) heq ((n : ℤ) + 1)
+    rw [hn1] at h2
+    exact (pow_eq_zero_iff two_ne_zero).mp h2
+  have h0 : (n : ℤ) • (Affine.Point.some x₀ y₀ hns) = 0 :=
+    (smul_eq_zero_iff_evalEval_ψ (W.baseChange K) hns (n : ℤ)).mpr hψ0
+  have h1 : ((n : ℤ) + 1) • (Affine.Point.some x₀ y₀ hns) = 0 :=
+    (smul_eq_zero_iff_evalEval_ψ (W.baseChange K) hns ((n : ℤ) + 1)).mpr hψ1
+  have hP : (Affine.Point.some x₀ y₀ hns : (W.baseChange K).toAffine.Point) = 0 := by
+    have hsub := sub_smul ((n : ℤ) + 1) (n : ℤ) (Affine.Point.some x₀ y₀ hns)
+    rw [h1, h0, sub_zero, add_sub_cancel_left, one_smul] at hsub
+    exact hsub
+  exact Affine.Point.some_ne_zero hns hP
+
+end Deep.Gen
+
+end PortGenNetIdentities
+
+section PortGenInduction
+
+namespace Deep
+namespace Gen
+
+open WeierstrassCurve WeierstrassCurve.Affine Polynomial
+
+open scoped WeierstrassCurve.Affine
+
+variable {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K]
+variable (W : WeierstrassCurve F)
+
+theorem smul_formula_or_zero [W.IsElliptic] {n : ℕ} (_hn : 0 < n) {x₀ y₀ : K}
+    (h : (W.baseChange K).toAffine.Nonsingular x₀ y₀) :
+    (((W.baseChange K).ΨSq n).eval x₀ ≠ 0 →
+      ∃ (x' y' : K) (h' : (W.baseChange K).toAffine.Nonsingular x' y'),
+        n • (Point.some x₀ y₀ h : W.toAffine⟮K⟯) = Point.some x' y' h' ∧
+          x' * ((W.baseChange K).ΨSq n).eval x₀ = ((W.baseChange K).Φ n).eval x₀) ∧
+    (((W.baseChange K).ΨSq n).eval x₀ = 0 →
+      n • (Point.some x₀ y₀ h : W.toAffine⟮K⟯) = 0) := by
+  have heq : (W.baseChange K).toAffine.Equation x₀ y₀ := h.left
+  have hψsq := (W.baseChange K).evalEval_ψ_sq heq (n : ℤ)
+  constructor
+  · intro hΨ
+    have hψ : ((W.baseChange K).ψ (n : ℤ)).evalEval x₀ y₀ ≠ 0 := by
+      intro h0
+      exact hΨ (by rw [← hψsq, h0]; exact zero_pow two_ne_zero)
+    have key := zsmul_eq_smulEval (W.baseChange K) h (n : ℤ)
+    have hVz : smulEval (W.baseChange K) x₀ y₀ (n : ℤ) 2 ≠ 0 := hψ
+    have hV := key ▸ ((n : ℤ) • Jacobian.Point.fromAffine (Point.some x₀ y₀ h)).nonsingular
+    have hQeq : ((n : ℤ) • Jacobian.Point.fromAffine (Point.some x₀ y₀ h)) =
+        Jacobian.Point.mk hV := Jacobian.Point.ext key
+    refine ⟨smulEval (W.baseChange K) x₀ y₀ (n : ℤ) 0 /
+        smulEval (W.baseChange K) x₀ y₀ (n : ℤ) 2 ^ 2,
+      smulEval (W.baseChange K) x₀ y₀ (n : ℤ) 1 /
+        smulEval (W.baseChange K) x₀ y₀ (n : ℤ) 2 ^ 3,
+      (Jacobian.nonsingular_of_Z_ne_zero hVz).mp hV, ?_, ?_⟩
+    · calc n • (Point.some x₀ y₀ h : W.toAffine⟮K⟯)
+          = Jacobian.Point.toAffineAddEquiv (W.baseChange K)
+            ((n : ℤ) • Jacobian.Point.fromAffine (Point.some x₀ y₀ h)) := by
+            rw [map_zsmul, ← Jacobian.Point.toAffineAddEquiv_symm_apply,
+              AddEquiv.apply_symm_apply, natCast_zsmul]
+        _ = _ := by
+            rw [hQeq, Jacobian.Point.toAffineAddEquiv_apply]
+            exact Jacobian.Point.toAffineLift_of_Z_ne_zero hVz
+    · change ((W.baseChange K).φ (n : ℤ)).evalEval x₀ y₀ /
+          ((W.baseChange K).ψ (n : ℤ)).evalEval x₀ y₀ ^ 2 *
+          ((W.baseChange K).ΨSq (n : ℤ)).eval x₀ =
+          ((W.baseChange K).Φ (n : ℤ)).eval x₀
+      rw [← hψsq, div_mul_cancel₀ _ (pow_ne_zero 2 hψ),
+        (W.baseChange K).evalEval_φ heq]
+  · intro hΨ
+    have hψ0 : ((W.baseChange K).ψ (n : ℤ)).evalEval x₀ y₀ = 0 :=
+      sq_eq_zero_iff.mp (hψsq.trans hΨ)
+    rw [← natCast_zsmul]
+    exact ((W.baseChange K).smul_eq_zero_iff_evalEval_ψ h (n : ℤ)).mpr hψ0
+
+end Deep.Gen
+
+end PortGenInduction
+
+section PortGenSmulFormula
+
+namespace Deep
+namespace Gen
+
+open WeierstrassCurve WeierstrassCurve.Affine Polynomial
+
+open scoped WeierstrassCurve.Affine
+
+variable {F K : Type*} [Field F] [Field K] [Algebra F K] [DecidableEq K]
+variable (W : WeierstrassCurve F)
+
+theorem smul_x_eq [W.IsElliptic] {n : ℕ} (hn : 0 < n) {x₀ y₀ : K}
+    (h : (W.baseChange K).toAffine.Nonsingular x₀ y₀)
+    (hns : ((W.baseChange K).ΨSq n).eval x₀ ≠ 0) :
+    ∃ (x' y' : K) (h' : (W.baseChange K).toAffine.Nonsingular x' y'),
+      n • (Point.some x₀ y₀ h : W.toAffine⟮K⟯) = Point.some x' y' h' ∧
+        x' * ((W.baseChange K).ΨSq n).eval x₀ = ((W.baseChange K).Φ n).eval x₀ :=
+  (smul_formula_or_zero W hn h).1 hns
+
+omit [DecidableEq K] in
+private lemma eval_ne_of_isCoprime {f g : Polynomial K} (h : IsCoprime f g) {x₀ : K}
+    (hf : f.eval x₀ = 0) (hg : g.eval x₀ = 0) : False := by
+  obtain ⟨a, b, hab⟩ := h
+  have h1 := congrArg (Polynomial.eval x₀) hab
+  simp only [eval_add, eval_mul, hf, hg, mul_zero, add_zero, eval_one] at h1
+  exact zero_ne_one h1
+
+omit [DecidableEq K] in
+private theorem _root_.Deep.Gen.isCoprime_Φ_ΨSq [IsAlgClosed K] [W.IsElliptic] {n : ℕ} (hn : 0 < n)
+    :
+    IsCoprime ((W.baseChange K).Φ n) ((W.baseChange K).ΨSq n) := by
+  classical
+  rw [Polynomial.isCoprime_iff_aeval_ne_zero_of_isAlgClosed (k := K) (K := K)]
+  intro x₀
+  by_contra hcon
+  push Not at hcon
+  obtain ⟨hΦ0, hΨ0⟩ := hcon
+  rw [coe_aeval_eq_eval] at hΦ0 hΨ0
+  have hΦdef : (W.baseChange K).Φ (n : ℤ) =
+      X * (W.baseChange K).ΨSq (n : ℤ) -
+        (W.baseChange K).preΨ ((n : ℤ) + 1) * (W.baseChange K).preΨ ((n : ℤ) - 1) *
+          (if Even (n : ℤ) then 1 else (W.baseChange K).Ψ₂Sq) := rfl
+  have h0 : ((W.baseChange K).preΨ ((n : ℤ) + 1)).eval x₀ *
+      ((W.baseChange K).preΨ ((n : ℤ) - 1)).eval x₀ *
+      (if Even (n : ℤ) then (1 : K) else ((W.baseChange K).Ψ₂Sq).eval x₀) = 0 := by
+    have h1 := congrArg (Polynomial.eval x₀) hΦdef
+    rw [hΦ0] at h1
+    simp only [eval_sub, eval_mul, eval_X, apply_ite (Polynomial.eval x₀), eval_one, hΨ0,
+      mul_zero, zero_sub] at h1
+    linear_combination h1
+  rcases mul_eq_zero.mp h0 with h12 | hG
+  · rcases mul_eq_zero.mp h12 with hE | hF
+    · have hb : ((W.baseChange K).ΨSq ((n : ℤ) + 1)).eval x₀ = 0 := by
+        have h2 := ΨSq_eval_eq_zero_of_preΨ W (m := n + 1) (K := K)
+          (by rwa [Nat.cast_add, Nat.cast_one])
+        rwa [Nat.cast_add, Nat.cast_one] at h2
+      exact eval_ne_of_isCoprime (isCoprime_ΨSq_succ W n) hΨ0 hb
+    · have hb : ((W.baseChange K).ΨSq ((n - 1 : ℕ) : ℤ)).eval x₀ = 0 :=
+        ΨSq_eval_eq_zero_of_preΨ W (m := n - 1) (K := K)
+          (by rwa [Nat.cast_sub hn, Nat.cast_one])
+      have hA := isCoprime_ΨSq_succ W (K := K) (n - 1)
+      have hc : ((n - 1 : ℕ) : ℤ) + 1 = (n : ℤ) := by omega
+      rw [hc] at hA
+      exact eval_ne_of_isCoprime hA hb hΨ0
+  · by_cases hev : Even (n : ℤ)
+    · rw [ite_eq_left hev] at hG
+      exact one_ne_zero hG
+    · rw [ite_eq_right hev] at hG
+      have hnodd : ¬Even n := fun h => hev (by exact_mod_cast h)
+      have hb : ((W.baseChange K).ΨSq ((n : ℤ) + 1)).eval x₀ = 0 := by
+        have h2 : ((W.baseChange K).ΨSq ((n + 1 : ℕ) : ℤ)).eval x₀ = 0 := by
+          rw [ΨSq_ofNat, ite_eq_left (Nat.even_add_one.mpr hnodd), eval_mul, hG, mul_zero]
+        rwa [Nat.cast_add, Nat.cast_one] at h2
+      exact eval_ne_of_isCoprime (isCoprime_ΨSq_succ W n) hΨ0 hb
+
+p2m_export "Deep.Gen" "isCoprime_Φ_ΨSq"
+
+theorem smul_eq_zero_of_ΨSq_eval_eq_zero [W.IsElliptic] {n : ℕ} (hn : 0 < n)
+    {x₀ y₀ : K} (h : (W.baseChange K).toAffine.Nonsingular x₀ y₀)
+    (hz : ((W.baseChange K).ΨSq n).eval x₀ = 0) :
+    n • (Point.some x₀ y₀ h : W.toAffine⟮K⟯) = 0 :=
+  (smul_formula_or_zero W hn h).2 hz
+
+omit [DecidableEq K] in
+theorem ΨSq_odd_eq_sq {n : ℕ} (hodd : Odd n) :
+    (W.baseChange K).ΨSq n = ((W.baseChange K).preΨ' n) ^ 2 := by
+  rw [ΨSq_ofNat, ite_eq_right (Nat.not_even_iff_odd.mpr hodd), mul_one]
+
+theorem smul_eq_zero_iff_preΨ'_eval [W.IsElliptic] {n : ℕ} (hodd : Odd n)
+    (hn : 0 < n) {x y : K} (h : (W.baseChange K).toAffine.Nonsingular x y) :
+    n • (Point.some x y h : W.toAffine⟮K⟯) = 0 ↔
+      ((W.baseChange K).preΨ' n).eval x = 0 := by
+  constructor
+  · intro hsmul
+    by_contra hne
+    have hns : ((W.baseChange K).ΨSq n).eval x ≠ 0 := by
+      rw [ΨSq_odd_eq_sq W hodd, eval_pow]
+      exact pow_ne_zero 2 hne
+    obtain ⟨x', y', h', heq, -⟩ := smul_x_eq W hn h hns
+    rw [hsmul] at heq
+    exact Point.some_ne_zero h' heq.symm
+  · intro hz
+    have hz' : ((W.baseChange K).ΨSq n).eval x = 0 := by
+      rw [ΨSq_odd_eq_sq W hodd, eval_pow, hz]
+      exact zero_pow two_ne_zero
+    exact smul_eq_zero_of_ΨSq_eval_eq_zero W hn h hz'
+
+end Deep.Gen
+
+end PortGenSmulFormula
+
+section PortCardCopr
+
+open Polynomial
+
+namespace PortCard
+private theorem _root_.PortCard.isCoprime_Φ_ΨSq {F : Type*} [Field F] (W : WeierstrassCurve F)
+    [W.IsElliptic]
+    (n : ℤ) : IsCoprime (W.Φ n) (W.ΨSq n) := by
+  classical
+  suffices key : ∀ m : ℕ, IsCoprime (W.Φ m) (W.ΨSq m) by
+    rcases Int.natAbs_eq n with h | h
+    · rw [h]; exact key _
+    · rw [h, WeierstrassCurve.Φ_neg, WeierstrassCurve.ΨSq_neg]; exact key _
+  intro m
+  rcases Nat.eq_zero_or_pos m with rfl | hm
+  · rw [Nat.cast_zero, WeierstrassCurve.Φ_zero, WeierstrassCurve.ΨSq_zero]
+    exact isCoprime_one_left
+  · have h := Deep.Gen.isCoprime_Φ_ΨSq (K := AlgebraicClosure F) W hm
+    rw [WeierstrassCurve.baseChange, WeierstrassCurve.map_Φ, WeierstrassCurve.map_ΨSq] at h
+    exact (Polynomial.isCoprime_map (algebraMap F (AlgebraicClosure F))).mp h
+
+end PortCard
+p2m_export "" "PortCard.isCoprime_Φ_ΨSq"
+end PortCardCopr
+
+theorem solution {F : Type*} [Field F] (W : WeierstrassCurve F) [W.IsElliptic] (n : ℤ) :
+    IsCoprime (W.Φ n) (W.ΨSq n) :=
+  PortCard.isCoprime_Φ_ΨSq W n
+
+end S_WeierstrassCurve_isCoprime_Phi_PsiSq
+end P2MW
+export P2MW.S_WeierstrassCurve_isCoprime_Phi_PsiSq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem WeierstrassCurve.isCoprime_Phi_PsiSq {F : Type*} [Field F] (W : WeierstrassCurve F)
+    [W.IsElliptic] (n : ℤ) :
+    IsCoprime (W.Φ n) (W.ΨSq n) :=
+  solution W n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_isElliptic_veluQuotient2_of_isElliptic.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_isElliptic_veluQuotient2_of_isElliptic.lean
new file mode 100644
index 0000000000..6434031035
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_isElliptic_veluQuotient2_of_isElliptic.lean
@@ -0,0 +1,84 @@
+/-
+Based on Prove2Me node WeierstrassCurve.isElliptic_veluQuotient2_of_isElliptic
+(58581676-128b-54e4-af7c-3fd08fcd6b62) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8dc32c81-17db-535c-848e-7af2eb323c94
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluOrderTwo
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_veluQuotient2_Delta_ne_zero
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The order-two Vélu quotient of an elliptic curve is elliptic
+
+Theorem statement: `WeierstrassCurve.isElliptic_veluQuotient2_of_isElliptic`
+(`58581676-128b-54e4-af7c-3fd08fcd6b62`), by Claude, 2026-09-05.
+
+Proof: submission `8dc32c81-17db-535c-848e-7af2eb323c94`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field and let $W$ be a Weierstrass curve over $F$ with coefficients
+$a_1,a_2,a_3,a_4,a_6$ whose discriminant $\Delta$ is a unit, i.e. $W$ is elliptic. Let $x_0,y_0 \in
+F$ satisfy the affine Weierstrass equation of $W$, so that $y_0^2 + a_1 x_0 y_0 + a_3 y_0 = x_0^3 +
+a_2 x_0^2 + a_4 x_0 + a_6$, and suppose in addition that $W.veluGy(x_0,y_0) = -(2y_0 + a_1 x_0 +
+a_3) = 0$, which says that the point $(x_0,y_0)$ is fixed by the Weierstrass involution, i.e. is a
+point of order two. Write $g_x = W.veluGx(x_0,y_0) = 3x_0^2 + 2a_2 x_0 + a_4 - a_1 y_0$. The
+conclusion is that the Weierstrass curve $W.veluQuotient2(x_0,y_0)$ with coefficients $a_1$, $a_2$,
+$a_3$, $a_4 - 5 g_x$ and $a_6 - b_2 g_x - 7 x_0 g_x$ is again elliptic, i.e. its discriminant is a
+unit in $F$.
+
+This is the order-two case of Vélu's construction: the explicit Weierstrass model of the quotient of
+an elliptic curve by the subgroup generated by a two-torsion point is again an elliptic curve.
+Registering this ellipticity is what makes the explicit $2$-isogeny $W \to W/\{O,(x_0,y_0)\}$
+available as a map of elliptic curves; it is used in the construction of modular polynomial data and
+in the analysis of Tate points.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_isElliptic_veluQuotient2_of_isElliptic.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_isElliptic_veluQuotient2_of_isElliptic
+
+open WeierstrassCurve WeierstrassCurve.Affine in
+theorem solution {F : Type*} [Field F] {W : WeierstrassCurve F} [W.IsElliptic] {x₀ y₀ : F}
+    (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0) :
+    (W.veluQuotient2 x₀ y₀).IsElliptic :=
+  ⟨isUnit_iff_ne_zero.mpr (veluQuotient2_Delta_ne_zero W.isUnit_Δ.ne_zero hQ hgy)⟩
+
+end S_WeierstrassCurve_isElliptic_veluQuotient2_of_isElliptic
+end P2MW
+export P2MW.S_WeierstrassCurve_isElliptic_veluQuotient2_of_isElliptic (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace WeierstrassCurve
+variable {F : Type*} [Field F] {W : WeierstrassCurve F} [W.IsElliptic] {x₀ y₀ : F}
+theorem isElliptic_veluQuotient2_of_isElliptic
+    (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0) :
+    (W.veluQuotient2 x₀ y₀).IsElliptic :=
+  solution hQ hgy
+end WeierstrassCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_j_mem_of_a_mem.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_j_mem_of_a_mem.lean
new file mode 100644
index 0000000000..55d58a31c9
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_j_mem_of_a_mem.lean
@@ -0,0 +1,98 @@
+/-
+Based on Prove2Me node WeierstrassCurve.j_mem_of_a_mem
+(63242fe7-1a80-5296-b967-717644bfb1a0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 27068548-cb19-503d-8ad1-c4be8770a508
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Weierstrass
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The j-invariant lies in any subfield containing the aᵢ
+
+Theorem statement: `WeierstrassCurve.j_mem_of_a_mem` (`63242fe7-1a80-5296-b967-717644bfb1a0`), by
+Claude, 2026-09-05.
+
+Proof: submission `27068548-cb19-503d-8ad1-c4be8770a508`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field and let $S$ be a type of subobjects of $F$ that are subfields, i.e. a `SetLike`
+structure on $F$ satisfying `SubfieldClass`. Let $W$ be a Weierstrass curve over $F$, given by
+coefficients $a_1, a_2, a_3, a_4, a_6$ and assumed elliptic (its discriminant is a unit, so that the
+$j$-invariant $j = \Delta^{-1} c_4^3$ is defined). Let $K : S$ be such a subfield of $F$, and assume
+the five membership hypotheses $a_1 \in K$, $a_2 \in K$, $a_3 \in K$, $a_4 \in K$ and $a_6 \in K$.
+The conclusion is that $W.j \in K$. Because $S$ is an arbitrary `SubfieldClass`, the statement
+applies simultaneously to `Subfield F` and to intermediate fields of an extension. Note the shape:
+the curve itself remains a curve over $F$, and only its $j$-invariant is asserted to be a member of
+the subset $K$; nothing is claimed about a model of $W$ over $K$.
+
+This is the elementary rationality statement that $j(E) \in \mathbb{Q}(a_1,a_2,a_3,a_4,a_6)$, in
+membership form rather than as a descent of the curve. It is used to show that the $j$-invariant of
+a Vélu quotient lies in a prescribed subfield, via
+[`WeierstrassCurve.veluQuotient_j_mem_of_mem`](thm.html#WeierstrassCurve.veluQuotient_j_mem_of_mem).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_j_mem_of_a_mem.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_j_mem_of_a_mem
+
+open WeierstrassCurve in
+theorem solution {F : Type*} [Field F] {S : Type*} [SetLike S F] [SubfieldClass S F]
+    (W : WeierstrassCurve F) [W.IsElliptic] (K : S)
+    (h₁ : W.a₁ ∈ K) (h₂ : W.a₂ ∈ K) (h₃ : W.a₃ ∈ K) (h₄ : W.a₄ ∈ K) (h₆ : W.a₆ ∈ K) : W.j ∈ K := by
+  have hb₂ : W.b₂ ∈ K := by
+    rw [b₂]; exact add_mem (pow_mem h₁ 2) (mul_mem (ofNat_mem K 4) h₂)
+  have hb₄ : W.b₄ ∈ K := by
+    rw [b₄]; exact add_mem (mul_mem (ofNat_mem K 2) h₄) (mul_mem h₁ h₃)
+  have hb₆ : W.b₆ ∈ K := by
+    rw [b₆]; exact add_mem (pow_mem h₃ 2) (mul_mem (ofNat_mem K 4) h₆)
+  have hb₈ : W.b₈ ∈ K := by
+    rw [b₈]
+    exact sub_mem (add_mem (sub_mem (add_mem (mul_mem (pow_mem h₁ 2) h₆)
+      (mul_mem (mul_mem (ofNat_mem K 4) h₂) h₆)) (mul_mem (mul_mem h₁ h₃) h₄))
+      (mul_mem h₂ (pow_mem h₃ 2))) (pow_mem h₄ 2)
+  have hc₄ : W.c₄ ∈ K := by
+    rw [c₄]; exact sub_mem (pow_mem hb₂ 2) (mul_mem (ofNat_mem K 24) hb₄)
+  have hΔ : W.Δ ∈ K := by
+    rw [Δ]
+    exact add_mem (sub_mem (sub_mem (mul_mem (neg_mem (pow_mem hb₂ 2)) hb₈)
+      (mul_mem (ofNat_mem K 8) (pow_mem hb₄ 3))) (mul_mem (ofNat_mem K 27) (pow_mem hb₆ 2)))
+      (mul_mem (mul_mem (mul_mem (ofNat_mem K 9) hb₂) hb₄) hb₆)
+  rw [WeierstrassCurve.j]
+  refine mul_mem ?_ (pow_mem hc₄ 3)
+  rw [Units.val_inv_eq_inv_val, WeierstrassCurve.coe_Δ']
+  exact inv_mem hΔ
+
+end S_WeierstrassCurve_j_mem_of_a_mem
+end P2MW
+export P2MW.S_WeierstrassCurve_j_mem_of_a_mem (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.j_mem_of_a_mem {F : Type*} [Field F] {S : Type*} [SetLike S F]
+    [SubfieldClass S F]
+    (W : WeierstrassCurve F) [W.IsElliptic] (K : S)
+    (h₁ : W.a₁ ∈ K) (h₂ : W.a₂ ∈ K) (h₃ : W.a₃ ∈ K) (h₄ : W.a₄ ∈ K) (h₆ : W.a₆ ∈ K)
+    : W.j ∈ K :=
+  solution W K h₁ h₂ h₃ h₄ h₆
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a4_eq_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a4_eq_zero.lean
new file mode 100644
index 0000000000..394639e95a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a4_eq_zero.lean
@@ -0,0 +1,169 @@
+/-
+Based on Prove2Me node WeierstrassCurve.mem_stabilizer_variableChange_iff_of_isShortNF_of_a4_eq_zero
+(c9190df0-8485-5e33-bce4-f6976b5c8500) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a68f95d2-a65f-5fe4-9bda-162344bb4d9f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.NormalForms
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Stabiliser of y²=x³+a₆ under admissible changes of variables
+
+Theorem statement: `WeierstrassCurve.mem_stabilizer_variableChange_iff_of_isShortNF_of_a4_eq_zero`
+(`c9190df0-8485-5e33-bce4-f6976b5c8500`), by Claude, 2026-09-05.
+
+Proof: submission `a68f95d2-a65f-5fe4-9bda-162344bb4d9f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field in which $2 \ne 0$ and $3 \ne 0$, and let $E$ be a Weierstrass curve over $F$
+which is in short normal form, i.e. $a_1 = a_2 = a_3 = 0$, so that $E$ is given by $y^2 = x^3 + a_4
+x + a_6$; assume moreover $a_4 = 0$ and $a_6 \ne 0$. Let $C = (u, r, s, t)$, with $u \in F^\times$
+and $r, s, t \in F$, be an admissible change of variables, acting on Weierstrass curves by Mathlib's
+scalar action of the group `WeierstrassCurve.VariableChange F`. The assertion is that $C$ lies in
+the stabiliser of $E$ for this action, i.e. $C \bullet E = E$ as Weierstrass equations, if and only
+if $r = 0$, $s = 0$, $t = 0$ and $u^6 = 1$ in $F$. Thus the stabiliser of the equation $y^2 = x^3 +
+a_6$ with $a_6 \ne 0$ consists exactly of the pure scalings by sixth roots of unity. No smoothness
+or ellipticity hypothesis on $E$ is imposed beyond $a_6 \ne 0$.
+
+This is the $j = 0$ case of the classical determination of the automorphism group of a Weierstrass
+equation in characteristic $\ne 2, 3$, with automorphisms encoded as the stabiliser of the equation
+under the change-of-variables group. It feeds the counting of automorphisms of curves over finite
+fields used in the mass-formula computations, and is cited in the construction and analysis of good
+models of special fibres of modular curves.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a4_eq_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a4_eq_zero
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "a₃_of_isShortNF variableChange_c₆ VariableChange.ext a₃ a₁ \
+  a₁_of_isShortNF IsShortNF variableChange_a₃ a₂_of_isShortNF a₄ a₂ a₆ c₆_of_isShortNF \
+  variableChange_a₆ c₆ variableChange_a₂ variableChange_a₁ variableChange_a₄ VariableChange"
+p2m_open "WeierstrassCurve"
+
+open MulAction
+
+namespace VariableChange
+p2m_export "WeierstrassCurve.VariableChange" "u t s r"
+p2m_open "WeierstrassCurve.VariableChange"
+
+variable {R : Type*} [CommRing R]
+
+def ofUnit (u : Rˣ) : VariableChange R := ⟨u, 0, 0, 0⟩
+
+@[scoped simp] lemma ofUnit_u (u : Rˣ) : (ofUnit u).u = u := rfl
+@[scoped simp] lemma ofUnit_r (u : Rˣ) : (ofUnit u).r = 0 := rfl
+@[scoped simp] lemma ofUnit_s (u : Rˣ) : (ofUnit u).s = 0 := rfl
+@[scoped simp] lemma ofUnit_t (u : Rˣ) : (ofUnit u).t = 0 := rfl
+
+end VariableChange
+
+section ShortNF
+
+variable {F : Type*} [Field F]
+
+lemma ofUnit_smul_of_isShortNF_of_a₄_eq_zero (E : WeierstrassCurve F) [E.IsShortNF]
+    (ha₄ : E.a₄ = 0) {u : Fˣ} (hu : (u : F) ^ 6 = 1) :
+    VariableChange.ofUnit u • E = E := by
+  have h6 : ((u⁻¹ : Fˣ) : F) ^ 6 = 1 := by
+    rw [Units.val_inv_eq_inv_val, inv_pow, hu, inv_one]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_ <;>
+    simp only [variableChange_a₁, variableChange_a₂, variableChange_a₃, variableChange_a₄,
+      variableChange_a₆, VariableChange.ofUnit_u, VariableChange.ofUnit_r,
+      VariableChange.ofUnit_s, VariableChange.ofUnit_t, E.a₁_of_isShortNF,
+      E.a₂_of_isShortNF, E.a₃_of_isShortNF, ha₄]
+  · ring
+  · ring
+  · ring
+  · ring
+  · linear_combination E.a₆ * h6
+
+theorem mem_stabilizer_isShortNF_a₄_eq_zero_iff (h2 : (2 : F) ≠ 0) (h3 : (3 : F) ≠ 0)
+    (E : WeierstrassCurve F) [E.IsShortNF] (ha₄ : E.a₄ = 0) (ha₆ : E.a₆ ≠ 0)
+    (C : VariableChange F) :
+    C ∈ stabilizer (VariableChange F) E ↔
+      C.r = 0 ∧ C.s = 0 ∧ C.t = 0 ∧ (C.u : F) ^ 6 = 1 := by
+  constructor
+  · intro hC
+    rw [mem_stabilizer_iff] at hC
+    have huinv : ((C.u⁻¹ : Fˣ) : F) ≠ 0 := C.u⁻¹.ne_zero
+    have hs : C.s = 0 := by
+      have h := congrArg WeierstrassCurve.a₁ hC
+      rw [variableChange_a₁, E.a₁_of_isShortNF, zero_add, mul_eq_zero, mul_eq_zero] at h
+      exact (h.resolve_left huinv).resolve_left h2
+    have hr : C.r = 0 := by
+      have h := congrArg WeierstrassCurve.a₂ hC
+      rw [variableChange_a₂, E.a₁_of_isShortNF, E.a₂_of_isShortNF, hs] at h
+      have h' : ((C.u⁻¹ : Fˣ) : F) ^ 2 * (3 * C.r) = 0 := by linear_combination h
+      rw [mul_eq_zero, mul_eq_zero] at h'
+      exact (h'.resolve_left (pow_ne_zero 2 huinv)).resolve_left h3
+    have ht : C.t = 0 := by
+      have h := congrArg WeierstrassCurve.a₃ hC
+      rw [variableChange_a₃, E.a₁_of_isShortNF, E.a₃_of_isShortNF, hr, zero_mul, add_zero,
+        zero_add, mul_eq_zero, mul_eq_zero] at h
+      exact (h.resolve_left (pow_ne_zero 3 huinv)).resolve_left h2
+    have hu6 : (C.u : F) ^ 6 = 1 := by
+      have h := congrArg WeierstrassCurve.c₆ hC
+      rw [variableChange_c₆, Units.val_inv_eq_inv_val, E.c₆_of_isShortNF] at h
+      have h864 : (-864 : F) ≠ 0 := fun habs =>
+        mul_ne_zero (pow_ne_zero 5 h2) (pow_ne_zero 3 h3) (by linear_combination -habs)
+      have h6 : ((C.u : F)⁻¹) ^ 6 = 1 :=
+        mul_right_cancel₀ (mul_ne_zero h864 ha₆) (h.trans (one_mul _).symm)
+      rw [inv_pow, inv_eq_one] at h6; exact h6
+    exact ⟨hr, hs, ht, hu6⟩
+  · rintro ⟨hr, hs, ht, hu6⟩
+    have hC : C = VariableChange.ofUnit C.u := VariableChange.ext rfl hr hs ht
+    rw [mem_stabilizer_iff, hC]
+    exact ofUnit_smul_of_isShortNF_of_a₄_eq_zero E ha₄ hu6
+
+end ShortNF
+end WeierstrassCurve
+
+theorem solution
+    {F : Type*} [Field F] (h2 : (2 : F) ≠ 0) (h3 : (3 : F) ≠ 0)
+    (E : WeierstrassCurve F) [E.IsShortNF] (ha₄ : E.a₄ = 0) (ha₆ : E.a₆ ≠ 0)
+    (C : WeierstrassCurve.VariableChange F) :
+    C ∈ MulAction.stabilizer (WeierstrassCurve.VariableChange F) E ↔
+      C.r = 0 ∧ C.s = 0 ∧ C.t = 0 ∧ (C.u : F) ^ 6 = 1 :=
+  WeierstrassCurve.mem_stabilizer_isShortNF_a₄_eq_zero_iff h2 h3 E ha₄ ha₆ C
+
+end S_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a4_eq_zero
+end P2MW
+export P2MW.S_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a4_eq_zero
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.mem_stabilizer_variableChange_iff_of_isShortNF_of_a4_eq_zero
+    {F : Type*} [Field F] (h2 : (2 : F) ≠ 0) (h3 : (3 : F) ≠ 0)
+    (E : WeierstrassCurve F) [E.IsShortNF] (ha₄ : E.a₄ = 0) (ha₆ : E.a₆ ≠ 0)
+    (C : WeierstrassCurve.VariableChange F) :
+    C ∈ MulAction.stabilizer (WeierstrassCurve.VariableChange F) E ↔
+      C.r = 0 ∧ C.s = 0 ∧ C.t = 0 ∧ (C.u : F) ^ 6 = 1 :=
+  solution h2 h3 E ha₄ ha₆ C
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a6_eq_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a6_eq_zero.lean
new file mode 100644
index 0000000000..0c4fac95ea
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a6_eq_zero.lean
@@ -0,0 +1,171 @@
+/-
+Based on Prove2Me node WeierstrassCurve.mem_stabilizer_variableChange_iff_of_isShortNF_of_a6_eq_zero
+(076c6e70-1fe7-5b64-81f0-a4c5b65f32a1) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 9806471b-7c9e-53a8-84a7-6a7eda1894f2
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.NormalForms
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Stabiliser of y²=x³+a₄x in the change-of-variables group
+
+Theorem statement: `WeierstrassCurve.mem_stabilizer_variableChange_iff_of_isShortNF_of_a6_eq_zero`
+(`076c6e70-1fe7-5b64-81f0-a4c5b65f32a1`), by Claude, 2026-09-05.
+
+Proof: submission `9806471b-7c9e-53a8-84a7-6a7eda1894f2`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field in which $2\neq 0$ and $3\neq 0$, and let $E$ be a Weierstrass curve over $F$
+which is in short normal form, i.e. $a_1=a_2=a_3=0$, so that $E$ is given by $y^2=x^3+a_4x+a_6$;
+assume moreover $a_6=0$ and $a_4\neq 0$. Let $C=(u,r,s,t)$, with $u\in F^\times$ and $r,s,t\in F$,
+be an element of the group $\mathrm{VariableChange}\ F$ of admissible changes of variables, acting
+on Weierstrass curves over $F$ in Mathlib's convention. The assertion is that $C$ lies in the
+stabiliser of $E$ for this action, i.e. $C\bullet E=E$ as Weierstrass equations, if and only if
+$r=0$, $s=0$, $t=0$ and $u^4=1$ in $F$. Thus the stabiliser of such an $E$ consists exactly of the
+scalings $(u,0,0,0)$ with $u$ a fourth root of unity in $F$; the statement is an equivalence about
+the coefficient tuple of $C$, not a computation of the cardinality or group structure of the
+stabiliser.
+
+This is the $j=1728$ case of the classical determination of the automorphism group of an elliptic
+curve in characteristic different from $2$ and $3$, here phrased as the stabiliser of a Weierstrass
+equation under the change-of-variables action. It is used in the study of special fibres of models
+of modular curves, for instance in producing good models over a special fibre and in verifying that
+the special fibre is elliptic, and in counting arguments where the automorphism groups of curves
+with extra automorphisms must be treated separately.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a6_eq_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a6_eq_zero
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "a₃_of_isShortNF VariableChange.ext a₃ c₄_of_isShortNF a₁ \
+  a₁_of_isShortNF IsShortNF variableChange_a₃ a₂_of_isShortNF a₄ a₂ a₆ variableChange_a₆ \
+  variableChange_a₂ variableChange_c₄ variableChange_a₁ variableChange_a₄ c₄ VariableChange"
+p2m_open "WeierstrassCurve"
+
+open MulAction
+
+namespace VariableChange
+p2m_export "WeierstrassCurve.VariableChange" "u t s r"
+p2m_open "WeierstrassCurve.VariableChange"
+
+variable {R : Type*} [CommRing R]
+
+def ofUnit (u : Rˣ) : VariableChange R := ⟨u, 0, 0, 0⟩
+
+@[scoped simp] lemma ofUnit_u (u : Rˣ) : (ofUnit u).u = u := rfl
+@[scoped simp] lemma ofUnit_r (u : Rˣ) : (ofUnit u).r = 0 := rfl
+@[scoped simp] lemma ofUnit_s (u : Rˣ) : (ofUnit u).s = 0 := rfl
+@[scoped simp] lemma ofUnit_t (u : Rˣ) : (ofUnit u).t = 0 := rfl
+
+end VariableChange
+
+section ShortNF
+
+variable {F : Type*} [Field F]
+
+lemma ofUnit_smul_of_isShortNF_of_a₆_eq_zero (E : WeierstrassCurve F) [E.IsShortNF]
+    (ha₆ : E.a₆ = 0) {u : Fˣ} (hu : (u : F) ^ 4 = 1) :
+    VariableChange.ofUnit u • E = E := by
+  have h4 : ((u⁻¹ : Fˣ) : F) ^ 4 = 1 := by
+    rw [Units.val_inv_eq_inv_val, inv_pow, hu, inv_one]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_ <;>
+    simp only [variableChange_a₁, variableChange_a₂, variableChange_a₃, variableChange_a₄,
+      variableChange_a₆, VariableChange.ofUnit_u, VariableChange.ofUnit_r,
+      VariableChange.ofUnit_s, VariableChange.ofUnit_t, E.a₁_of_isShortNF,
+      E.a₂_of_isShortNF, E.a₃_of_isShortNF, ha₆]
+  · ring
+  · ring
+  · ring
+  · linear_combination E.a₄ * h4
+  · ring
+
+theorem mem_stabilizer_isShortNF_a₆_eq_zero_iff (h2 : (2 : F) ≠ 0) (h3 : (3 : F) ≠ 0)
+    (E : WeierstrassCurve F) [E.IsShortNF] (ha₆ : E.a₆ = 0) (ha₄ : E.a₄ ≠ 0)
+    (C : VariableChange F) :
+    C ∈ stabilizer (VariableChange F) E ↔
+      C.r = 0 ∧ C.s = 0 ∧ C.t = 0 ∧ (C.u : F) ^ 4 = 1 := by
+  constructor
+  · intro hC
+    rw [mem_stabilizer_iff] at hC
+    have huinv : ((C.u⁻¹ : Fˣ) : F) ≠ 0 := C.u⁻¹.ne_zero
+    have hs : C.s = 0 := by
+      have h := congrArg WeierstrassCurve.a₁ hC
+      rw [variableChange_a₁, E.a₁_of_isShortNF, zero_add, mul_eq_zero, mul_eq_zero] at h
+      exact (h.resolve_left huinv).resolve_left h2
+    have hr : C.r = 0 := by
+      have h := congrArg WeierstrassCurve.a₂ hC
+      rw [variableChange_a₂, E.a₁_of_isShortNF, E.a₂_of_isShortNF, hs] at h
+      have h' : ((C.u⁻¹ : Fˣ) : F) ^ 2 * (3 * C.r) = 0 := by linear_combination h
+      rw [mul_eq_zero, mul_eq_zero] at h'
+      exact (h'.resolve_left (pow_ne_zero 2 huinv)).resolve_left h3
+    have ht : C.t = 0 := by
+      have h := congrArg WeierstrassCurve.a₃ hC
+      rw [variableChange_a₃, E.a₁_of_isShortNF, E.a₃_of_isShortNF, hr, zero_mul, add_zero,
+        zero_add, mul_eq_zero, mul_eq_zero] at h
+      exact (h.resolve_left (pow_ne_zero 3 huinv)).resolve_left h2
+    have hu4 : (C.u : F) ^ 4 = 1 := by
+      have h := congrArg WeierstrassCurve.c₄ hC
+      rw [variableChange_c₄, Units.val_inv_eq_inv_val, E.c₄_of_isShortNF] at h
+      have h48 : (-48 : F) ≠ 0 := fun habs =>
+        mul_ne_zero (pow_ne_zero 4 h2) h3 (by linear_combination -habs)
+      have h4 : ((C.u : F)⁻¹) ^ 4 = 1 :=
+        mul_right_cancel₀ (mul_ne_zero h48 ha₄) (h.trans (one_mul _).symm)
+      rw [inv_pow, inv_eq_one] at h4; exact h4
+    exact ⟨hr, hs, ht, hu4⟩
+  · rintro ⟨hr, hs, ht, hu4⟩
+    have hC : C = VariableChange.ofUnit C.u := VariableChange.ext rfl hr hs ht
+    rw [mem_stabilizer_iff, hC]
+    exact ofUnit_smul_of_isShortNF_of_a₆_eq_zero E ha₆ hu4
+
+end ShortNF
+end WeierstrassCurve
+
+theorem solution
+    {F : Type*} [Field F] (h2 : (2 : F) ≠ 0) (h3 : (3 : F) ≠ 0)
+    (E : WeierstrassCurve F) [E.IsShortNF] (ha₆ : E.a₆ = 0) (ha₄ : E.a₄ ≠ 0)
+    (C : WeierstrassCurve.VariableChange F) :
+    C ∈ MulAction.stabilizer (WeierstrassCurve.VariableChange F) E ↔
+      C.r = 0 ∧ C.s = 0 ∧ C.t = 0 ∧ (C.u : F) ^ 4 = 1 :=
+  WeierstrassCurve.mem_stabilizer_isShortNF_a₆_eq_zero_iff h2 h3 E ha₆ ha₄ C
+
+end S_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a6_eq_zero
+end P2MW
+export P2MW.S_WeierstrassCurve_mem_stabilizer_variableChange_iff_of_isShortNF_of_a6_eq_zero
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.mem_stabilizer_variableChange_iff_of_isShortNF_of_a6_eq_zero
+    {F : Type*} [Field F] (h2 : (2 : F) ≠ 0) (h3 : (3 : F) ≠ 0)
+    (E : WeierstrassCurve F) [E.IsShortNF] (ha₆ : E.a₆ = 0) (ha₄ : E.a₄ ≠ 0)
+    (C : WeierstrassCurve.VariableChange F) :
+    C ∈ MulAction.stabilizer (WeierstrassCurve.VariableChange F) E ↔
+      C.r = 0 ∧ C.s = 0 ∧ C.t = 0 ∧ (C.u : F) ^ 4 = 1 :=
+  solution h2 h3 E ha₆ ha₄ C
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed.lean
new file mode 100644
index 0000000000..b38a8425fb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed.lean
@@ -0,0 +1,94 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed
+(94a534c6-fb29-5f54-a382-f8be7c08c792) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 020351b1-1941-5c3f-8339-f757f7235292
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AddCommGroup_natCard_isAddCyclic_addSubgroup_eq_dedekindPsi_of_addEquiv_torsionBy
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_nonempty_torsionBy_addEquiv_zmod_prod_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cyclic subgroups of order n number ψ(n)
+
+Theorem statement:
+`WeierstrassCurve.natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed`
+(`94a534c6-fb29-5f54-a382-f8be7c08c792`), by Claude, 2026-09-05.
+
+Proof: submission `020351b1-1941-5c3f-8339-f757f7235292`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra and $K$ algebraically closed, let $W$ be a
+Weierstrass curve over $F$ which is elliptic (`W.IsElliptic`), and let $n$ be a natural number whose
+image in $K$ is nonzero, so in particular $n \ge 1$ and $n$ is invertible in $K$ when $K$ has
+positive characteristic. Write $(W⁄K)$ for the base change of $W$ to $K$ and $(W⁄K).\mathrm{Point}$
+for the additive group of points of the associated affine curve over $K$. The assertion is an
+equality of natural numbers: the cardinality of the type of subgroups $G$ of $(W⁄K).\mathrm{Point}$
+satisfying both that $G$ is an additively cyclic group and that $\mathrm{Nat.card}\,G = n$ equals
+$\mathrm{ModularCurve.dedekindPsi}\,n$, which by definition is the sum $\sum_{d \mid n,\ d \text{
+squarefree}} n/d$ over the squarefree divisors of $n$, i.e. the Dedekind value $\psi(n) = n\prod_{p
+\mid n}(1 + 1/p)$. No condition confining $G$ to the $n$-torsion is imposed: the subgroups are
+counted among all subgroups of the full group of points.
+
+This is the moduli-theoretic count underlying $\Gamma_0(n)$-level structures: an elliptic curve over
+an algebraically closed field of characteristic not dividing $n$ carries exactly $\psi(n) =
+[\mathrm{SL}_2(\mathbb{Z}) : \Gamma_0(n)]$ cyclic subgroups of order $n$, equivalently $\psi(n)$
+cyclic $n$-isogenies. It is used in the analysis of the modular polynomial of level $n$, in
+particular in the results identifying the roots of its specialisation at a $j$-invariant and in the
+separability statements for such specialisations.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+theorem solution
+    {F K : Type*} [Field F] [Field K] [Algebra F K] [IsAlgClosed K] [DecidableEq K]
+    (W : WeierstrassCurve F) [W.IsElliptic] {n : ℕ} (hn : (n : K) ≠ 0) :
+    Nat.card {G : AddSubgroup (W⁄K).Point // IsAddCyclic G ∧ Nat.card G = n}
+      = ModularCurve.dedekindPsi n := by
+  have : NeZero n := ⟨by rintro rfl; exact hn Nat.cast_zero⟩
+  obtain ⟨e⟩ := W.nonempty_torsionBy_addEquiv_zmod_prod_of_isAlgClosed (K := K) hn
+  exact AddCommGroup.natCard_isAddCyclic_addSubgroup_eq_dedekindPsi_of_addEquiv_torsionBy n e
+
+end S_WeierstrassCurve_natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed
+end P2MW
+export P2MW.S_WeierstrassCurve_natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+theorem WeierstrassCurve.natCard_addSubgroup_isAddCyclic_card_eq_dedekindPsi_of_isAlgClosed
+    {F K : Type*} [Field F] [Field K] [Algebra F K] [IsAlgClosed K] [DecidableEq K]
+    (W : WeierstrassCurve F) [W.IsElliptic] {n : ℕ} (hn : (n : K) ≠ 0) :
+    Nat.card {G : AddSubgroup (W⁄K).Point // IsAddCyclic G ∧ Nat.card G = n}
+      = ModularCurve.dedekindPsi n :=
+  solution W hn
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuThree.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuThree.lean
new file mode 100644
index 0000000000..5fa2f753f5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuThree.lean
@@ -0,0 +1,287 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuThree
+(d6495b5f-be77-5f82-a6d2-899d7829bc29) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission ff0762e0-45f8-51a8-af41-a0027a911d5a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VariableChangePointEquiv
+
+import Mathlib.AlgebraicGeometry.EllipticCurve.Reduction
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AddCommGroup_natCard_isAddCyclic_addSubgroup_map_eq_of_sq_add_self_add_id_eq_zero_eq_nuThree
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_some_add_some_eq_neg_some_of_pow_three_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_some_zero_add_self_eq_neg_of_a6_model
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_vcInvFun_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_pow_three_eq_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_nonempty_torsionBy_addEquiv_zmod_prod_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_variableChange_mk_smul_eq_self_of_pow_three_eq_one
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cyclic N-subgroups of y²=x³+B stable under [ω]
+
+Theorem statement:
+`WeierstrassCurve.natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuThree`
+(`d6495b5f-be77-5f82-a6d2-899d7829bc29`), by Claude, 2026-09-05.
+
+Proof: submission `ff0762e0-45f8-51a8-af41-a0027a911d5a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be an algebraically closed field equipped with a $\mathbb{Q}$-algebra structure (so of
+characteristic $0$), let $B \in L$ with $B \neq 0$, let $u \in L^{\times}$ satisfy $u^{3} = 1$ and
+$u \neq 1$, and let $N$ be a nonzero natural number. Write $W$ for the Weierstrass curve with
+coefficients $(a_1,a_2,a_3,a_4,a_6) = (0,0,0,0,B)$, i.e. $y^{2} = x^{3} + B$, and consider its
+affine point group $W_{\mathrm{aff}}(L)$ (the nonsingular affine points together with the point at
+infinity). For the variable change $C = (u,0,0,0)$, the transport map `Point.vcInvFun` sends the
+point at infinity to the point at infinity and a point $(x,y)$ to the point with coordinates
+$(u^{-2}(x-0),\; u^{-3}(y-0-0\cdot(x-0))) = (u^{-2}x, u^{-3}y)$ on the curve $C \bullet W$. The
+assertion is that the number of additive subgroups $H \le W_{\mathrm{aff}}(L)$ which are additively
+cyclic, satisfy $\#H = N$, and are stable under this transport in the sense that for every $T \in H$
+there exists $T' \in H$ with `HEq (Point.vcInvFun C W.toAffine T) T'` (heterogeneous equality, the
+source and target groups being those of $C \bullet W$ and of $W$), equals `nuThree N`, the number of
+$x \in \mathbb{Z}/N$ with $x^{2} + x + 1 = 0$.
+
+This is the "fixed" contribution in the count of elliptic points of order $3$ on the modular curve
+$Y_0(N)$: cyclic subgroups of order $N$ on a curve with $j = 0$ that are carried to themselves by
+the automorphism $(x,y) \mapsto (\omega x, y)$ of order $3$. It is used by
+[`ModularCurve.three_mul_natCard_moduliPoint_j_eq_zero_eq_dedekindPsi_add_two_mul_nuThree`]
+(thm.html#ModularCurve.three_mul_natCard_moduliPoint_j_eq_zero_eq_dedekindPsi_add_two_mul_nuThree),
+which assembles the double count of such moduli points into the formula involving the Dedekind
+$\psi$-function and $\nu_3(N)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuThree.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuThree
+
+
+open WeierstrassCurve WeierstrassCurve.Affine ModularCurve
+
+namespace L3bSketch
+
+variable {L : Type*} [Field L] [DecidableEq L]
+
+def xy {W : WeierstrassCurve L} : W.toAffine.Point → Option (L × L)
+  | 0 => none
+  | .some x y _ => some (x, y)
+
+omit [DecidableEq L] in
+theorem xy_injective {W : WeierstrassCurve L} : Function.Injective (xy (W := W)) := by
+  rintro (_ | ⟨x, y, h⟩) (_ | ⟨x', y', h'⟩) hh
+  · rfl
+  · exact absurd hh (by simp [xy])
+  · exact absurd hh (by simp [xy])
+  · simp only [xy, Option.some.injEq, Prod.mk.injEq] at hh
+    obtain ⟨rfl, rfl⟩ := hh
+    rfl
+
+omit [DecidableEq L] in
+theorem xy_neg {W : WeierstrassCurve L} (P : W.toAffine.Point) :
+    xy (-P) = (xy P).map (fun q => (q.1, W.toAffine.negY q.1 q.2)) := by
+  rcases P with _ | ⟨x, y, h⟩
+  · rfl
+  · rw [Affine.Point.neg_some]; rfl
+
+omit [DecidableEq L] in
+theorem xy_vcInvFun (γ : VariableChange L) {W : WeierstrassCurve L} (P : W.toAffine.Point) :
+    xy (Point.vcInvFun γ W.toAffine P) = (xy P).map (fun q => (vcXInv γ q.1, vcYInv γ q.1 q.2)) :=
+      by
+  rcases P with _ | ⟨x, y, h⟩ <;> rfl
+
+def castPt {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂) : W₁.toAffine.Point ≃+ W₂.toAffine.Point := by
+  subst e; exact AddEquiv.refl _
+
+theorem heq_castPt {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂) (P : W₁.toAffine.Point) :
+    HEq P (castPt e P) := by subst e; exact HEq.rfl
+
+theorem xy_castPt {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂) (P : W₁.toAffine.Point) :
+    xy (castPt e P) = xy P := by subst e; rfl
+
+noncomputable def vcHom (γ : VariableChange L) (W : WeierstrassCurve L) (hW : γ • W = W) :
+    W.toAffine.Point →+ W.toAffine.Point :=
+  (castPt hW).toAddMonoidHom.comp
+    { toFun := Point.vcInvFun γ W.toAffine
+      map_zero' := Point.vcInvFun_zero
+      map_add' := Point.vcInvFun_add γ W.toAffine }
+
+theorem vcHom_apply (γ : VariableChange L) (W : WeierstrassCurve L) (hW : γ • W = W)
+    (P : W.toAffine.Point) :
+    vcHom γ W hW P = castPt hW (Point.vcInvFun γ W.toAffine P) := rfl
+
+theorem heq_vcHom (γ : VariableChange L) (W : WeierstrassCurve L) (hW : γ • W = W)
+    (P : W.toAffine.Point) :
+    HEq (Point.vcInvFun γ W.toAffine P) (vcHom γ W hW P) := heq_castPt hW _
+
+theorem xy_vcHom (γ : VariableChange L) (W : WeierstrassCurve L) (hW : γ • W = W)
+    (P : W.toAffine.Point) :
+    xy (vcHom γ W hW P) = (xy P).map (fun q => (vcXInv γ q.1, vcYInv γ q.1 q.2)) := by
+  rw [vcHom_apply, xy_castPt, xy_vcInvFun]
+
+theorem forall_exists_heq_iff_map_eq (γ : VariableChange L) (W : WeierstrassCurve L)
+    (hW : γ • W = W)
+    (hinj : Function.Injective (vcHom γ W hW)) (H : AddSubgroup W.toAffine.Point) [Finite H] :
+    (∀ T ∈ H, ∃ T' ∈ H, HEq (Point.vcInvFun γ W.toAffine T) T') ↔ H.map (vcHom γ W hW) = H := by
+  constructor
+  · intro hH
+    have hle : H.map (vcHom γ W hW) ≤ H := by
+      intro y hy
+      rw [AddSubgroup.mem_map] at hy
+      obtain ⟨T, hT, rfl⟩ := hy
+      obtain ⟨T', hT', hheq⟩ := hH T hT
+      rwa [eq_of_heq ((heq_vcHom γ W hW T).symm.trans hheq)]
+    exact AddSubgroup.eq_of_le_of_card_ge hle
+      (Nat.card_congr (H.equivMapOfInjective _ hinj).toEquiv).le
+  · intro hH T hT
+    exact ⟨vcHom γ W hW T, by rw [← hH]; exact AddSubgroup.mem_map_of_mem _ hT, heq_vcHom γ W hW T⟩
+
+omit [DecidableEq L] in
+theorem exists_eq_some_of_xy_eq {W : WeierstrassCurve L} {Q : W.toAffine.Point} {x y : L}
+    (h : xy Q = some (x, y)) : ∃ h', Q = Point.some x y h' := by
+  rcases Q with _ | ⟨x', y', h'⟩
+  · exact absurd h (by simp [xy])
+  · simp only [xy, Option.some.injEq, Prod.mk.injEq] at h
+    obtain ⟨rfl, rfl⟩ := h
+    exact ⟨h', rfl⟩
+
+end L3bSketch
+
+open L3bSketch
+
+theorem solution
+    {L : Type*} [Field L] [DecidableEq L] [Algebra ℚ L] [IsAlgClosed L]
+    (B : L) (hB : B ≠ 0) (u : Lˣ) (hu : (u : L) ^ 3 = 1) (hu1 : (u : L) ≠ 1) (N : ℕ) (hN : N ≠ 0) :
+    Nat.card {H : AddSubgroup (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve L).toAffine.Point //
+        IsAddCyclic H ∧ Nat.card H = N ∧
+        ∀ T ∈ H, ∃ T' ∈ H, HEq (Point.vcInvFun (⟨u, 0, 0, 0⟩ : VariableChange L)
+          (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve L).toAffine T) T'}
+      = nuThree N := by
+  have : CharZero L := charZero_of_injective_algebraMap (algebraMap ℚ L).injective
+  have : NeZero N := ⟨hN⟩
+  set W : WeierstrassCurve L := ⟨0, 0, 0, 0, B⟩ with hWdef
+  set γ : VariableChange L := ⟨u, 0, 0, 0⟩ with hγdef
+  have h2 : (2 : L) ≠ 0 := two_ne_zero
+  have hΔ : W.Δ = -432 * B ^ 2 := by
+    simp only [hWdef, WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄,
+      WeierstrassCurve.b₆,
+      WeierstrassCurve.b₈]; ring
+  have hE : W.IsElliptic := ⟨by rw [hΔ]; exact isUnit_iff_ne_zero.mpr (by simp [hB])⟩
+  have hW : γ • W = W := WeierstrassCurve.variableChange_mk_smul_eq_self_of_pow_three_eq_one u hu B
+  let σ : W.toAffine.Point →+ W.toAffine.Point := vcHom γ W hW
+  have hi3 : ((u⁻¹ : Lˣ) : L) ^ 3 = 1 := by
+    rw [Units.val_inv_eq_inv_val, inv_pow, hu, inv_one]
+  have hi2 : ((u⁻¹ : Lˣ) : L) ^ 2 = u := by
+    rw [Units.val_inv_eq_inv_val, inv_pow]
+    exact inv_eq_of_mul_eq_one_right (by rw [← pow_succ, hu])
+  have σ_some : ∀ (x y : L) (h : W.toAffine.Nonsingular x y),
+      ∃ h', σ (Point.some x y h) = Point.some ((u : L) * x) y h' := by
+    intro x y h
+    apply exists_eq_some_of_xy_eq
+    rw [xy_vcHom]
+    simp only [xy, Option.map_some, hγdef, vcXInv, vcYInv, sub_zero, zero_mul, hi2, hi3, one_mul]
+  have hσ : ∀ P : W.toAffine.Point, σ (σ P) + σ P + P = 0 := by
+    rintro (_ | ⟨x, y, h⟩)
+    · simp only [← WeierstrassCurve.Affine.Point.zero_def, map_zero, add_zero]
+    · obtain ⟨h1, e1⟩ := σ_some x y h
+      obtain ⟨h2', e2⟩ := σ_some ((u : L) * x) y h1
+      rw [e1, e2]
+      by_cases hx : x = 0
+      · subst hx
+        have hy0 : y ≠ 0 := by
+          have heq := h.left
+          rw [WeierstrassCurve.Affine.equation_iff] at heq
+          simp only [hWdef, zero_mul, mul_zero, add_zero] at heq
+          rintro rfl
+          apply hB
+          simpa using heq.symm
+        have e0 : ∀ (h' : W.toAffine.Nonsingular ((u : L) * 0) y),
+            Point.some ((u : L) * 0) y h' = Point.some 0 y h := by
+          intro h'; apply xy_injective; simp [xy]
+        have e00 : ∀ (h' : W.toAffine.Nonsingular ((u : L) * ((u : L) * 0)) y),
+            Point.some ((u : L) * ((u : L) * 0)) y h' = Point.some 0 y h := by
+          intro h'; apply xy_injective; simp [xy]
+        rw [e0, e00, WeierstrassCurve.Affine.Point.some_zero_add_self_eq_neg_of_a6_model B h2 hy0 h,
+          neg_add_cancel]
+      · have hw2x : W.toAffine.Nonsingular ((u : L) ^ 2 * x) y := by
+          have : (u : L) ^ 2 * x = (u : L) * ((u : L) * x) := by ring
+          rw [this]; exact h2'
+        have e3 : Point.some ((u : L) * ((u : L) * x)) y h2' = Point.some ((u : L) ^ 2 * x) y hw2x
+          :=
+          by
+          apply xy_injective; simp only [xy, Option.some.injEq, Prod.mk.injEq, and_true]; ring
+        rw [e3, add_assoc, add_comm (Point.some ((u : L) * x) y h1),
+          WeierstrassCurve.Affine.Point.some_add_some_eq_neg_some_of_pow_three_eq_one B (u : L) hu
+          hu1 h h1 hw2x hx,
+          add_neg_cancel]
+  have σinj : Function.Injective σ := fun a b h => by
+    have ha : a = -(σ (σ a) + σ a) := eq_neg_of_add_eq_zero_right (hσ a)
+    have hb : b = -(σ (σ b) + σ b) := eq_neg_of_add_eq_zero_right (hσ b)
+    rw [ha, hb, h]
+  have hns : ∀ p : ℕ, p.Prime → p ∣ N → ∃ a : W.toAffine.Point, addOrderOf a = p ∧ ∀ k : ℕ, σ a ≠ k
+    • a :=
+    by
+    intro p hp _
+    obtain ⟨T, hT, hk⟩ :=
+      WeierstrassCurve.exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_pow_three_eq_one B hB u hu hu1
+        p hp
+    refine ⟨T, hT, fun k hk' => hk k ?_⟩
+    exact (heq_vcHom γ W hW T).trans (heq_of_eq hk')
+  have hNL : ((N : ℕ) : L) ≠ 0 := Nat.cast_ne_zero.mpr hN
+  obtain ⟨e⟩ : Nonempty (ZMod N × ZMod N ≃+ Submodule.torsionBy ℤ W.toAffine.Point N) := by
+    have h := W.nonempty_torsionBy_addEquiv_zmod_prod_of_isAlgClosed (K := L) hNL
+    have hb : (W⁄L) = W.toAffine := by
+      change (W.baseChange L).toAffine = W.toAffine
+      rw [WeierstrassCurve.baseChange, Algebra.algebraMap_self, WeierstrassCurve.map_id]
+    rw [hb] at h
+    exact h
+  rw [← AddCommGroup.natCard_isAddCyclic_addSubgroup_map_eq_of_sq_add_self_add_id_eq_zero_eq_nuThree
+    N e σ hσ hns]
+  refine Nat.card_congr (Equiv.subtypeEquivRight fun H => ?_)
+  refine ⟨fun ⟨hc, hcard, hst⟩ => ⟨hc, hcard, ?_⟩, fun ⟨hc, hcard, hst⟩ => ⟨hc, hcard, ?_⟩⟩
+  · have : Finite H := Nat.finite_of_card_ne_zero (by rw [hcard]; exact hN)
+    exact (forall_exists_heq_iff_map_eq γ W hW σinj H).mp hst
+  · have : Finite H := Nat.finite_of_card_ne_zero (by rw [hcard]; exact hN)
+    exact (forall_exists_heq_iff_map_eq γ W hW σinj H).mpr hst
+
+end S_WeierstrassCurve_natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuThree
+end P2MW
+export P2MW.S_WeierstrassCurve_natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuThree
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine ModularCurve
+theorem WeierstrassCurve.natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuThree
+    {L : Type*} [Field L] [DecidableEq L] [Algebra ℚ L] [IsAlgClosed L]
+    (B : L) (hB : B ≠ 0) (u : Lˣ) (hu : (u : L) ^ 3 = 1) (hu1 : (u : L) ≠ 1) (N : ℕ) (hN : N ≠ 0) :
+    Nat.card {H : AddSubgroup (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve L).toAffine.Point //
+        IsAddCyclic H ∧ Nat.card H = N ∧
+        ∀ T ∈ H, ∃ T' ∈ H, HEq (Point.vcInvFun (⟨u, 0, 0, 0⟩ : VariableChange L)
+          (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve L).toAffine T) T'}
+      = nuThree N :=
+  solution B hB u hu hu1 N hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuTwo.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuTwo.lean
new file mode 100644
index 0000000000..d055c4b493
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuTwo.lean
@@ -0,0 +1,237 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuTwo
+(29c5b42e-ed21-58ba-b7b8-54ea07fd9c77) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 601c2bf5-1646-5b3d-ad24-c12bc96ab4d6
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VariableChangePointEquiv
+
+import Mathlib.AlgebraicGeometry.EllipticCurve.Reduction
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AddCommGroup_natCard_isAddCyclic_addSubgroup_map_eq_of_sq_eq_neg_one_eq_nuTwo
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_vcInvFun_add
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_sq_eq_neg_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_nonempty_torsionBy_addEquiv_zmod_prod_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_variableChange_mk_smul_eq_self_of_sq_eq_neg_one
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cyclic N-subgroups of y²=x³+Ax stable under [i]
+
+Theorem statement:
+`WeierstrassCurve.natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuTwo`
+(`29c5b42e-ed21-58ba-b7b8-54ea07fd9c77`), by Claude, 2026-09-05.
+
+Proof: submission `601c2bf5-1646-5b3d-ad24-c12bc96ab4d6`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be an algebraically closed field equipped with a $\mathbb{Q}$-algebra structure (hence of
+characteristic zero) and with decidable equality, let $A \in L$ be nonzero, let $u$ be a unit of $L$
+with $u^2 = -1$, and let $N$ be a nonzero natural number. Consider the Weierstrass curve $W =
+\langle 0,0,0,A,0\rangle$ over $L$, that is $y^2 = x^3 + Ax$, and the group
+$W.\mathrm{toAffine}.\mathrm{Point}$ of its affine points together with the point at infinity. For
+the variable change $\gamma = \langle u,0,0,0\rangle$, the map `Point.vcInvFun` sends the point at
+infinity of $W$ to that of $\gamma \bullet W$ and an affine point $(x,y)$ to the point with
+coordinates $((u^{-1})^2 x, (u^{-1})^3 y)$ on $\gamma \bullet W$; since $(u^{-1})^2 = -1$ this is
+$(x,y) \mapsto (-x, (u^{-1})^3 y)$. The assertion is that the number of subgroups $H$ of
+$W.\mathrm{toAffine}.\mathrm{Point}$ which are cyclic, satisfy $\#H = N$, and are stable in the
+sense that for every $T \in H$ there is $T' \in H$ with `Point.vcInvFun` $\gamma\, W\, T$
+heterogeneously equal to $T'$ (the two points lying in the types of points of $\gamma \bullet W$ and
+of $W$ respectively), equals $\nu_2(N) = \#\{x \in \mathbb{Z}/N : x^2 + 1 = 0\}$.
+
+This is the count of cyclic subgroups of order $N$ on a curve with $j = 1728$ that are stable under
+the automorphism $[i]$, i.e. the contribution of the elliptic points of order two to the standard
+count of moduli points on $Y_0(N)$. It supplies the term $\nu_2(N)$ in
+[`ModularCurve.two_mul_natCard_moduliPoint_j_eq_1728_eq_dedekindPsi_add_nuTwo`]
+(thm.html#ModularCurve.two_mul_natCard_moduliPoint_j_eq_1728_eq_dedekindPsi_add_nuTwo).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuTwo.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuTwo
+
+
+open WeierstrassCurve WeierstrassCurve.Affine ModularCurve
+
+namespace L3aSketch
+
+variable {L : Type*} [Field L] [DecidableEq L]
+
+def xy {W : WeierstrassCurve L} : W.toAffine.Point → Option (L × L)
+  | 0 => none
+  | .some x y _ => some (x, y)
+
+omit [DecidableEq L] in
+theorem xy_injective {W : WeierstrassCurve L} : Function.Injective (xy (W := W)) := by
+  rintro (_ | ⟨x, y, h⟩) (_ | ⟨x', y', h'⟩) hh
+  · rfl
+  · exact absurd hh (by simp [xy])
+  · exact absurd hh (by simp [xy])
+  · simp only [xy, Option.some.injEq, Prod.mk.injEq] at hh
+    obtain ⟨rfl, rfl⟩ := hh
+    rfl
+
+omit [DecidableEq L] in
+theorem xy_neg {W : WeierstrassCurve L} (P : W.toAffine.Point) :
+    xy (-P) = (xy P).map (fun q => (q.1, W.toAffine.negY q.1 q.2)) := by
+  rcases P with _ | ⟨x, y, h⟩
+  · rfl
+  · rw [Affine.Point.neg_some]; rfl
+
+omit [DecidableEq L] in
+theorem xy_vcInvFun (γ : VariableChange L) {W : WeierstrassCurve L} (P : W.toAffine.Point) :
+    xy (Point.vcInvFun γ W.toAffine P) = (xy P).map (fun q => (vcXInv γ q.1, vcYInv γ q.1 q.2)) :=
+      by
+  rcases P with _ | ⟨x, y, h⟩ <;> rfl
+
+def castPt {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂) : W₁.toAffine.Point ≃+ W₂.toAffine.Point := by
+  subst e; exact AddEquiv.refl _
+
+theorem heq_castPt {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂) (P : W₁.toAffine.Point) :
+    HEq P (castPt e P) := by subst e; exact HEq.rfl
+
+theorem xy_castPt {W₁ W₂ : WeierstrassCurve L} (e : W₁ = W₂) (P : W₁.toAffine.Point) :
+    xy (castPt e P) = xy P := by subst e; rfl
+
+noncomputable def vcHom (γ : VariableChange L) (W : WeierstrassCurve L) (hW : γ • W = W) :
+    W.toAffine.Point →+ W.toAffine.Point :=
+  (castPt hW).toAddMonoidHom.comp
+    { toFun := Point.vcInvFun γ W.toAffine
+      map_zero' := Point.vcInvFun_zero
+      map_add' := Point.vcInvFun_add γ W.toAffine }
+
+theorem vcHom_apply (γ : VariableChange L) (W : WeierstrassCurve L) (hW : γ • W = W)
+    (P : W.toAffine.Point) :
+    vcHom γ W hW P = castPt hW (Point.vcInvFun γ W.toAffine P) := rfl
+
+theorem heq_vcHom (γ : VariableChange L) (W : WeierstrassCurve L) (hW : γ • W = W)
+    (P : W.toAffine.Point) :
+    HEq (Point.vcInvFun γ W.toAffine P) (vcHom γ W hW P) := heq_castPt hW _
+
+theorem xy_vcHom (γ : VariableChange L) (W : WeierstrassCurve L) (hW : γ • W = W)
+    (P : W.toAffine.Point) :
+    xy (vcHom γ W hW P) = (xy P).map (fun q => (vcXInv γ q.1, vcYInv γ q.1 q.2)) := by
+  rw [vcHom_apply, xy_castPt, xy_vcInvFun]
+
+theorem forall_exists_heq_iff_map_eq (γ : VariableChange L) (W : WeierstrassCurve L)
+    (hW : γ • W = W)
+    (hinj : Function.Injective (vcHom γ W hW)) (H : AddSubgroup W.toAffine.Point) [Finite H] :
+    (∀ T ∈ H, ∃ T' ∈ H, HEq (Point.vcInvFun γ W.toAffine T) T') ↔ H.map (vcHom γ W hW) = H := by
+  constructor
+  · intro hH
+    have hle : H.map (vcHom γ W hW) ≤ H := by
+      intro y hy
+      rw [AddSubgroup.mem_map] at hy
+      obtain ⟨T, hT, rfl⟩ := hy
+      obtain ⟨T', hT', hheq⟩ := hH T hT
+      rwa [eq_of_heq ((heq_vcHom γ W hW T).symm.trans hheq)]
+    exact AddSubgroup.eq_of_le_of_card_ge hle
+      (Nat.card_congr (H.equivMapOfInjective _ hinj).toEquiv).le
+  · intro hH T hT
+    exact ⟨vcHom γ W hW T, by rw [← hH]; exact AddSubgroup.mem_map_of_mem _ hT, heq_vcHom γ W hW T⟩
+
+end L3aSketch
+
+open L3aSketch
+
+theorem solution
+    {L : Type*} [Field L] [DecidableEq L] [Algebra ℚ L] [IsAlgClosed L]
+    (A : L) (hA : A ≠ 0) (u : Lˣ) (hu : (u : L) ^ 2 = -1) (N : ℕ) (hN : N ≠ 0) :
+    Nat.card {H : AddSubgroup (⟨0, 0, 0, A, 0⟩ : WeierstrassCurve L).toAffine.Point //
+        IsAddCyclic H ∧ Nat.card H = N ∧
+        ∀ T ∈ H, ∃ T' ∈ H, HEq (Point.vcInvFun (⟨u, 0, 0, 0⟩ : VariableChange L)
+          (⟨0, 0, 0, A, 0⟩ : WeierstrassCurve L).toAffine T) T'}
+      = nuTwo N := by
+  have : CharZero L := charZero_of_injective_algebraMap (algebraMap ℚ L).injective
+  have : NeZero N := ⟨hN⟩
+  set W : WeierstrassCurve L := ⟨0, 0, 0, A, 0⟩ with hWdef
+  set γ : VariableChange L := ⟨u, 0, 0, 0⟩ with hγdef
+  have hΔ : W.Δ = -64 * A ^ 3 := by
+    simp only [hWdef, WeierstrassCurve.Δ, WeierstrassCurve.b₂, WeierstrassCurve.b₄,
+      WeierstrassCurve.b₆,
+      WeierstrassCurve.b₈]; ring
+  have hE : W.IsElliptic := ⟨by rw [hΔ]; exact isUnit_iff_ne_zero.mpr (by simp [hA])⟩
+  have hW : γ • W = W := WeierstrassCurve.variableChange_mk_smul_eq_self_of_sq_eq_neg_one u hu A
+  let σ : W.toAffine.Point →+ W.toAffine.Point := vcHom γ W hW
+  have hi2 : ((u⁻¹ : Lˣ) : L) ^ 2 = -1 := by
+    rw [Units.val_inv_eq_inv_val, inv_pow, hu, inv_neg, inv_one]
+  have hσ : ∀ P : W.toAffine.Point, σ (σ P) = -P := by
+    intro P
+    apply xy_injective
+    rw [xy_vcHom, xy_vcHom, xy_neg]
+    rcases xy P with _ | ⟨x, y⟩
+    · rfl
+    · simp only [Option.map_some, hγdef, hWdef, vcXInv, vcYInv, Affine.negY, sub_zero, zero_mul,
+        Option.some.injEq, Prod.mk.injEq]
+      constructor
+      · linear_combination (((u⁻¹ : Lˣ) : L) ^ 2 * x - x) * hi2
+      · linear_combination (((u⁻¹ : Lˣ) : L) ^ 4 * y - ((u⁻¹ : Lˣ) : L) ^ 2 * y + y) * hi2
+  have σinj : Function.Injective σ := fun a b h => by
+    have h2 := congrArg σ h; rwa [hσ, hσ, neg_inj] at h2
+  have hns : ∀ p : ℕ, p.Prime → p ∣ N → ∃ a : W.toAffine.Point, addOrderOf a = p ∧ ∀ k : ℕ, σ a ≠ k
+    • a :=
+    by
+    intro p hp _
+    obtain ⟨T, hT, hk⟩ :=
+      WeierstrassCurve.exists_addOrderOf_eq_and_vcInvFun_ne_nsmul_of_sq_eq_neg_one A hA u hu p hp
+    refine ⟨T, hT, fun k hk' => hk k ?_⟩
+    exact (heq_vcHom γ W hW T).trans (heq_of_eq hk')
+  have hNL : ((N : ℕ) : L) ≠ 0 := Nat.cast_ne_zero.mpr hN
+  obtain ⟨e⟩ : Nonempty (ZMod N × ZMod N ≃+ Submodule.torsionBy ℤ W.toAffine.Point N) := by
+    have h := W.nonempty_torsionBy_addEquiv_zmod_prod_of_isAlgClosed (K := L) hNL
+    have hb : (W⁄L) = W.toAffine := by
+      change (W.baseChange L).toAffine = W.toAffine
+      rw [WeierstrassCurve.baseChange, Algebra.algebraMap_self, WeierstrassCurve.map_id]
+    rw [hb] at h
+    exact h
+  rw [← AddCommGroup.natCard_isAddCyclic_addSubgroup_map_eq_of_sq_eq_neg_one_eq_nuTwo N e σ hσ hns]
+  refine Nat.card_congr (Equiv.subtypeEquivRight fun H => ?_)
+  refine ⟨fun ⟨hc, hcard, hst⟩ => ⟨hc, hcard, ?_⟩, fun ⟨hc, hcard, hst⟩ => ⟨hc, hcard, ?_⟩⟩
+  · have : Finite H := Nat.finite_of_card_ne_zero (by rw [hcard]; exact hN)
+    exact (forall_exists_heq_iff_map_eq γ W hW σinj H).mp hst
+  · have : Finite H := Nat.finite_of_card_ne_zero (by rw [hcard]; exact hN)
+    exact (forall_exists_heq_iff_map_eq γ W hW σinj H).mpr hst
+
+end S_WeierstrassCurve_natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuTwo
+end P2MW
+export P2MW.S_WeierstrassCurve_natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuTwo
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine ModularCurve
+theorem WeierstrassCurve.natCard_isAddCyclic_addSubgroup_card_eq_fixed_vcInvFun_eq_nuTwo
+    {L : Type*} [Field L] [DecidableEq L] [Algebra ℚ L] [IsAlgClosed L]
+    (A : L) (hA : A ≠ 0) (u : Lˣ) (hu : (u : L) ^ 2 = -1) (N : ℕ) (hN : N ≠ 0) :
+    Nat.card {H : AddSubgroup (⟨0, 0, 0, A, 0⟩ : WeierstrassCurve L).toAffine.Point //
+        IsAddCyclic H ∧ Nat.card H = N ∧
+        ∀ T ∈ H, ∃ T' ∈ H, HEq (Point.vcInvFun (⟨u, 0, 0, 0⟩ : VariableChange L)
+          (⟨0, 0, 0, A, 0⟩ : WeierstrassCurve L).toAffine T) T'}
+      = nuTwo N :=
+  solution A hA u hu N hN
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_natDegree_Phi_sub_C_mul_PsiSq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_natDegree_Phi_sub_C_mul_PsiSq.lean
new file mode 100644
index 0000000000..f328985762
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_natDegree_Phi_sub_C_mul_PsiSq.lean
@@ -0,0 +1,95 @@
+/-
+Based on Prove2Me node WeierstrassCurve.natDegree_Phi_sub_C_mul_PsiSq
+(c2065997-b6c5-58ad-ae1c-d95d444907e2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d25b1575-7b58-5c60-85a8-a482b95a4530
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Degree of Φₙ - c Ψₙ² is n²
+
+Theorem statement: `WeierstrassCurve.natDegree_Phi_sub_C_mul_PsiSq`
+(`c2065997-b6c5-58ad-ae1c-d95d444907e2`), by Claude, 2026-09-05.
+
+Proof: submission `d25b1575-7b58-5c60-85a8-a482b95a4530`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a nontrivial commutative ring, let $W$ be a Weierstrass curve over $R$, let $n$ be an
+integer and let $c$ be an element of $R$. Working with Mathlib's division polynomials attached to
+$W$, namely $\Phi_n \in R[X]$ and the polynomial $\Psi_n^2$ (the square of the $n$-th division
+polynomial, realised as a genuine element of $R[X]$ even for even $n$), the assertion is that the
+natural-number degree of the difference $\Phi_n - C(c)\,\Psi_n^2$, where $C(c)$ denotes the constant
+polynomial $c$, equals $|n|^2$, the square of the natural absolute value of $n$. No hypothesis on
+$n$ or on $c$ is imposed beyond nontriviality of $R$; in particular for $n = 0$ the polynomial is
+the constant $1$ and the asserted degree is $0$, and for $c = 0$ the statement reduces to the degree
+of $\Phi_n$ itself.
+
+Classically this is the statement that, for a point with abscissa $c$, the abscissae of its
+$n$-division points are the roots of a polynomial of degree exactly $n^2$; it underlies the bound
+$n^2$ for the degree of multiplication by $n$ on a Weierstrass curve. It is used in the computation
+of the rank of the field extension cut out by multiplication by $n$
+([`WeierstrassCurve.Affine.finrank_fieldRange_mulPull_le`]
+(thm.html#WeierstrassCurve.Affine.finrank_fieldRange_mulPull_le))
+and in the two statements producing, under the hypothesis that all $n$-torsion is trivial, a
+rational point homomorphism with nonvanishing Wronskian, respectively a Frobenius factorisation of
+multiplication by $n$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_natDegree_Phi_sub_C_mul_PsiSq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_natDegree_Phi_sub_C_mul_PsiSq
+
+open Polynomial
+
+theorem PortCard.natDegree_Φ_sub_C_mul_ΨSq {R : Type*} [CommRing R] [Nontrivial R]
+    (W : WeierstrassCurve R) (n : ℤ) (c : R) :
+    (W.Φ n - C c * W.ΨSq n).natDegree = n.natAbs ^ 2 := by
+  rcases eq_or_ne n 0 with rfl | hn
+  · rw [WeierstrassCurve.Φ_zero, WeierstrassCurve.ΨSq_zero, mul_zero, sub_zero, natDegree_one,
+      Int.natAbs_zero, zero_pow two_ne_zero]
+  · have h1 : 1 ≤ n.natAbs ^ 2 := Nat.one_le_pow _ _ (Int.natAbs_pos.mpr hn)
+    rw [natDegree_sub_eq_left_of_natDegree_lt, WeierstrassCurve.natDegree_Φ]
+    calc (C c * W.ΨSq n).natDegree ≤ (W.ΨSq n).natDegree := natDegree_C_mul_le _ _
+      _ ≤ n.natAbs ^ 2 - 1 := WeierstrassCurve.natDegree_ΨSq_le W n
+      _ < n.natAbs ^ 2 := Nat.sub_lt (by omega) one_pos
+      _ = (W.Φ n).natDegree := (WeierstrassCurve.natDegree_Φ W n).symm
+
+theorem solution {R : Type*} [CommRing R] [Nontrivial R] (W : WeierstrassCurve R) (n : ℤ) (c : R) :
+    (W.Φ n - Polynomial.C c * W.ΨSq n).natDegree = n.natAbs ^ 2 :=
+  PortCard.natDegree_Φ_sub_C_mul_ΨSq W n c
+
+end S_WeierstrassCurve_natDegree_Phi_sub_C_mul_PsiSq
+end P2MW
+export P2MW.S_WeierstrassCurve_natDegree_Phi_sub_C_mul_PsiSq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+theorem WeierstrassCurve.natDegree_Phi_sub_C_mul_PsiSq {R : Type*} [CommRing R] [Nontrivial R]
+    (W : WeierstrassCurve R) (n : ℤ) (c : R) :
+    (W.Φ n - Polynomial.C c * W.ΨSq n).natDegree = n.natAbs ^ 2 :=
+  solution W n c
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_nonempty_functionField_algEquiv_of_variableChange.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_nonempty_functionField_algEquiv_of_variableChange.lean
new file mode 100644
index 0000000000..cb61b82d42
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_nonempty_functionField_algEquiv_of_variableChange.lean
@@ -0,0 +1,565 @@
+/-
+Based on Prove2Me node WeierstrassCurve.nonempty_functionField_algEquiv_of_variableChange
+(3a47c5d0-7fb4-5cce-bd99-11dd0f3e9e6b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5f77c6fd-8f79-5004-8b55-0ecfdc6af0c1
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Basic
+import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FunctionFieldQuadratic
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VariableChangePointEquiv
+
+/-!
+# Variable changes induce isomorphic Weierstrass function fields
+
+Theorem statement: `WeierstrassCurve.nonempty_functionField_algEquiv_of_variableChange`
+(`3a47c5d0-7fb4-5cce-bd99-11dd0f3e9e6b`), by Claude, 2026-09-05.
+
+Proof: submission `5f77c6fd-8f79-5004-8b55-0ecfdc6af0c1`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field, let $W$ be a Weierstrass curve over $F$ (given by the coefficients
+$a_1,a_2,a_3,a_4,a_6$), and let $C$ be an admissible change of variables over $F$, i.e. a quadruple
+$(u,r,s,t)$ with $u \in F^\times$ and $r,s,t \in F$, acting on Weierstrass curves by the
+substitution $(x,y) \mapsto (u^2x+r,\ u^3y+su^2x+t)$; write $C \bullet W$ for the transformed curve.
+The assertion is that the type of $F$-algebra isomorphisms between the function field of the affine
+curve underlying $W$ and the function field of the affine curve underlying $C \bullet W$ is
+nonempty; here the function field of an affine Weierstrass curve is the fraction field of its
+coordinate ring, viewed as an $F$-algebra. Thus the two function fields are isomorphic over $F$. The
+conclusion is stated as nonemptiness, so no particular isomorphism is named; in particular the
+statement does not record that the isomorphism is the one given by the substitution above, nor that
+it is compatible with the inclusions of $F(x)$ as a rational function field.
+
+This is the standard fact that an admissible change of Weierstrass coordinates is a birational
+(indeed biregular) change of model, so it leaves the function field unchanged up to $F$-isomorphism.
+It provides the easy direction of the correspondence between $F$-isomorphisms of Weierstrass
+function fields and variable changes, and is used in the results deducing equality of
+$j$-invariants, and comparisons of kernels of maps on points, from an isomorphism of function
+fields.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_nonempty_functionField_algEquiv_of_variableChange.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace WeierstrassCurve
+namespace Affine
+open WeierstrassCurve.Affine WeierstrassCurve
+open Polynomial
+open scoped Polynomial.Bivariate
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem algebraMap_polynomial_eq_mk_C (p : F[X]) :
+    algebraMap F[X] W.CoordinateRing p = CoordinateRing.mk W (C p) :=
+  rfl
+
+noncomputable def yGen (W : Affine F) : W.FunctionField :=
+  algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+open scoped WeierstrassCurve.Affine.CoordinateRing in
+theorem CoordinateRing.algebraMap_eq_mk_C_C (a : F) :
+    algebraMap F W.CoordinateRing a = CoordinateRing.mk W (C (C a)) := by
+  rw [AdjoinRoot.algebraMap_eq', RingHom.comp_apply, Polynomial.algebraMap_apply,
+    Algebra.algebraMap_self_apply]
+  rfl
+end Affine
+end WeierstrassCurve
+
+noncomputable section
+
+open Polynomial WeierstrassCurve.Affine
+
+open scoped Polynomial.Bivariate Polynomial.Bivariate
+
+universe u
+
+namespace WeierstrassCurve
+namespace Affine
+open WeierstrassCurve.Affine WeierstrassCurve
+
+open WeierstrassCurve.Affine.CoordinateRing WeierstrassCurve.Affine.CoordinateRing
+
+variable {F : Type u} [Field F]
+
+section PointPullbackTo
+
+variable {W : Affine F} {L : Type u} [Field L] [Algebra F L]
+
+theorem eval₂_polynomial_of_equation_map_target {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) :
+    W.polynomial.eval₂
+      (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom yP = 0 := by
+  rw [equation_iff'] at h
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆] at h
+  simp only [WeierstrassCurve.Affine.polynomial, eval₂_add, eval₂_sub, eval₂_mul, eval₂_pow,
+    eval₂_X, eval₂_C, AlgHom.toRingHom_eq_coe, RingHom.coe_coe, map_add, map_mul, map_pow,
+    Polynomial.aeval_C, Polynomial.aeval_X]
+  linear_combination h
+
+def pointPullbackCoordHomTo {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) :
+    W.CoordinateRing →ₐ[F] L where
+  __ := AdjoinRoot.lift
+    (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom
+    yP (eval₂_polynomial_of_equation_map_target h)
+  commutes' c := by
+    change AdjoinRoot.lift _ _ (eval₂_polynomial_of_equation_map_target h) (algebraMap F _ c)
+      = algebraMap F L c
+    rw [CoordinateRing.algebraMap_eq_mk_C_C, AdjoinRoot.lift_mk, eval₂_C]
+    exact Polynomial.aeval_C _ c
+
+theorem pointPullbackCoordHomTo_mk {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) (g : F[X][Y]) :
+    pointPullbackCoordHomTo h (CoordinateRing.mk W g)
+      = g.eval₂ (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom yP :=
+  AdjoinRoot.lift_mk (eval₂_polynomial_of_equation_map_target h) g
+
+theorem pointPullbackCoordHomTo_comp_algebraMap {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP) :
+    (pointPullbackCoordHomTo h).toRingHom.comp (algebraMap F[X] W.CoordinateRing)
+      = (Polynomial.aeval xP : F[X] →ₐ[F] L).toRingHom := by
+  refine RingHom.ext fun p => ?_
+  change pointPullbackCoordHomTo h (algebraMap F[X] _ p) = _
+  rw [algebraMap_polynomial_eq_mk_C, pointPullbackCoordHomTo_mk, eval₂_C]
+
+theorem pointPullbackCoordHomTo_injective {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    Function.Injective (pointPullbackCoordHomTo h) := by
+  have hker : RingHom.ker (pointPullbackCoordHomTo h).toRingHom = ⊥ := by
+    have : Module.Finite F[X] W.CoordinateRing :=
+      Module.Finite.of_basis (CoordinateRing.basis W)
+    refine Ideal.eq_bot_of_under_eq_bot (R := F[X]) ?_
+    rw [Ideal.under_def, RingHom.comap_ker, pointPullbackCoordHomTo_comp_algebraMap,
+      ← RingHom.injective_iff_ker_eq_bot]
+    exact hx
+  exact (RingHom.injective_iff_ker_eq_bot (pointPullbackCoordHomTo h).toRingHom).mpr hker
+
+def pointPullbackHomTo {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    W.FunctionField →ₐ[F] L :=
+  IsFractionRing.liftAlgHom (pointPullbackCoordHomTo_injective h hx)
+
+theorem pointPullbackHomTo_algebraMap {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) (r : W.CoordinateRing) :
+    pointPullbackHomTo h hx (algebraMap W.CoordinateRing W.FunctionField r)
+      = pointPullbackCoordHomTo h r :=
+  IsFractionRing.lift_algebraMap (pointPullbackCoordHomTo_injective h hx) r
+
+theorem pointPullbackHomTo_polyToFunctionField_X {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    pointPullbackHomTo h hx (polyToFunctionField W X) = xP := by
+  rw [polyToFunctionField_apply, pointPullbackHomTo_algebraMap,
+    algebraMap_polynomial_eq_mk_C, pointPullbackCoordHomTo_mk, eval₂_C]
+  exact Polynomial.aeval_X _
+
+theorem pointPullbackHomTo_yGen {xP yP : L}
+    (h : (W.map (algebraMap F L)).toAffine.Equation xP yP)
+    (hx : Function.Injective (Polynomial.aeval (R := F) xP)) :
+    pointPullbackHomTo h hx (yGen W) = yP := by
+  change pointPullbackHomTo h hx (algebraMap _ _ (CoordinateRing.mk W Y)) = _
+  rw [pointPullbackHomTo_algebraMap, pointPullbackCoordHomTo_mk]
+  exact eval₂_X _ _
+
+end PointPullbackTo
+
+end Affine
+end WeierstrassCurve
+
+end
+
+noncomputable section
+
+open Polynomial IsDedekindDomain
+
+open scoped Polynomial.Bivariate Polynomial.Bivariate
+
+namespace WeierstrassCurve
+namespace Affine
+open WeierstrassCurve.Affine WeierstrassCurve
+
+open WeierstrassCurve.Affine.CoordinateRing
+
+universe u
+
+variable {F : Type u} [Field F]
+
+section GenericPoint
+
+variable {W : Affine F}
+
+theorem polyToFunctionField_eq_aeval (p : F[X]) :
+    polyToFunctionField W p = Polynomial.aeval (polyToFunctionField W X) p := by
+  have h1 : (polyToFunctionField W : F[X] →+* W.FunctionField)
+      = algebraMap F[X] W.FunctionField :=
+    (IsScalarTower.algebraMap_eq F[X] W.CoordinateRing W.FunctionField).symm
+  have h2 : (IsScalarTower.toAlgHom F F[X] W.FunctionField : F[X] →ₐ[F] W.FunctionField)
+      = Polynomial.aeval (polyToFunctionField W X) := by
+    refine Polynomial.algHom_ext ?_
+    rw [Polynomial.aeval_X, IsScalarTower.coe_toAlgHom', ← h1]
+  calc polyToFunctionField W p = algebraMap F[X] W.FunctionField p := by rw [h1]
+    _ = (IsScalarTower.toAlgHom F F[X] W.FunctionField : F[X] →ₐ[F] W.FunctionField) p := rfl
+    _ = Polynomial.aeval (polyToFunctionField W X) p := by rw [h2]
+
+theorem equation_map_polyToFunctionField_yGen :
+    (W.map (algebraMap F W.FunctionField)).toAffine.Equation
+      (polyToFunctionField W X) (yGen W) := by
+  rw [equation_iff]
+  have hrel := smul_basis_mul_Y (W' := W) 0 1
+  rw [zero_smul, zero_add, one_smul, one_mul, one_mul, zero_sub] at hrel
+  have h2 := congrArg (algebraMap W.CoordinateRing W.FunctionField) hrel
+  rw [map_mul, algebraMap_smul_basis, _root_.map_neg, neg_mul, ← sub_eq_add_neg] at h2
+  simp only [map_a₁, map_a₂, map_a₃, map_a₄, map_a₆]
+  simp only [map_add, map_mul, map_pow, polyToFunctionField_C] at h2
+  rw [show yGen W = algebraMap W.CoordinateRing W.FunctionField (CoordinateRing.mk W Y)
+    from rfl]
+  simp only [polyToFunctionField_apply] at h2 ⊢
+  linear_combination h2
+
+end GenericPoint
+
+end Affine
+end WeierstrassCurve
+
+end
+
+section
+
+open Polynomial WeierstrassCurve.Affine.Point
+
+open scoped WeierstrassCurve.Affine WeierstrassCurve.Affine Polynomial.Bivariate
+  Polynomial.Bivariate
+
+noncomputable section
+
+namespace WeierstrassCurve
+namespace Affine
+open WeierstrassCurve.Affine.CoordinateRing
+
+universe u
+
+variable {F : Type u} [Field F]
+
+section AdjoinSurjective
+
+variable {W : Affine F} (hΔ : W.Δ ≠ 0) {a b : F} (hA : W.Equation a b)
+
+theorem transcendental_polyToFunctionField_X :
+    Transcendental F (polyToFunctionField W X) := by
+  rw [transcendental_iff]
+  intro p hp
+  rw [← polyToFunctionField_eq_aeval] at hp
+  exact polyToFunctionField_injective (by simpa using hp)
+
+end AdjoinSurjective
+
+end Affine
+end WeierstrassCurve
+
+end
+
+end
+
+noncomputable section
+
+open Polynomial WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.CoordinateRing
+
+open scoped Polynomial.Bivariate
+
+namespace FLT
+namespace Mrtw60aVCPlaceSeamS1
+
+universe u
+
+variable {F : Type u} [Field F]
+
+theorem mrtw60a_inv_smul {C : VariableChange F} {W V : Affine F} (h : C • W = V) :
+    C⁻¹ • V = W := by
+  rw [← h, inv_smul_smul]
+
+variable (C : VariableChange F)
+
+def mrtw60a_pXFwd : F[X] := Polynomial.C ((C.u : F) ^ 2) * X + Polynomial.C C.r
+
+def mrtw60a_pYLinFwd : F[X] := Polynomial.C ((C.u : F) ^ 2 * C.s) * X + Polynomial.C C.t
+
+section Values
+
+variable (V : Affine F)
+
+def mrtw60a_xFwd : V.FunctionField := polyToFunctionField V (mrtw60a_pXFwd C)
+
+def mrtw60a_yFwd : V.FunctionField :=
+  algebraMap F V.FunctionField ((C.u : F) ^ 3) * yGen V
+    + polyToFunctionField V (mrtw60a_pYLinFwd C)
+
+theorem mrtw60a_xFwd_shape :
+    mrtw60a_xFwd C V
+      = algebraMap F V.FunctionField ((C.u : F) ^ 2) * polyToFunctionField V X
+        + algebraMap F V.FunctionField C.r := by
+  simp [mrtw60a_xFwd, mrtw60a_pXFwd, polyToFunctionField_C]
+
+theorem mrtw60a_yFwd_shape :
+    mrtw60a_yFwd C V
+      = algebraMap F V.FunctionField ((C.u : F) ^ 3) * yGen V
+        + algebraMap F V.FunctionField ((C.u : F) ^ 2 * C.s) * polyToFunctionField V X
+        + algebraMap F V.FunctionField C.t := by
+  simp [mrtw60a_yFwd, mrtw60a_pYLinFwd, polyToFunctionField_C, add_assoc]
+
+theorem mrtw60a_xInv_shape :
+    mrtw60a_xFwd C⁻¹ V
+      = algebraMap F V.FunctionField (((C.u⁻¹ : Fˣ) : F) ^ 2)
+        * (polyToFunctionField V X - algebraMap F V.FunctionField C.r) := by
+  simp only [mrtw60a_xFwd, mrtw60a_pXFwd, VariableChange.inv_def, map_add, map_mul,
+    polyToFunctionField_C, _root_.map_neg, map_pow]
+  ring
+
+theorem mrtw60a_yInv_shape :
+    mrtw60a_yFwd C⁻¹ V
+      = algebraMap F V.FunctionField (((C.u⁻¹ : Fˣ) : F) ^ 3)
+        * (yGen V - algebraMap F V.FunctionField C.t
+            - algebraMap F V.FunctionField C.s
+              * (polyToFunctionField V X - algebraMap F V.FunctionField C.r)) := by
+  simp only [mrtw60a_yFwd, mrtw60a_pYLinFwd, VariableChange.inv_def, map_add, map_mul,
+    polyToFunctionField_C, map_sub, _root_.map_neg, map_pow]
+  ring
+
+theorem mrtw60a_xFwd_eq_vcX :
+    mrtw60a_xFwd C V
+      = vcX (C.map (algebraMap F V.FunctionField)) (polyToFunctionField V X) := by
+  rw [mrtw60a_xFwd_shape, vcX]
+  simp only [VariableChange.map, Units.coe_map, MonoidHom.coe_ofClass, map_pow]
+
+theorem mrtw60a_yFwd_eq_vcY :
+    mrtw60a_yFwd C V
+      = vcY (C.map (algebraMap F V.FunctionField)) (polyToFunctionField V X) (yGen V) := by
+  rw [mrtw60a_yFwd_shape, vcY]
+  simp only [VariableChange.map, Units.coe_map, MonoidHom.coe_ofClass, map_pow, map_mul]
+
+end Values
+
+variable {C} {W V : Affine F}
+
+theorem mrtw60a_equation_fwd (h : C • W = V) :
+    (W.map (algebraMap F V.FunctionField)).toAffine.Equation
+      (mrtw60a_xFwd C V) (mrtw60a_yFwd C V) := by
+  have hmap : (C.map (algebraMap F V.FunctionField))
+      • (W.map (algebraMap F V.FunctionField)) = V.map (algebraMap F V.FunctionField) := by
+    rw [WeierstrassCurve.map_variableChange, h]
+  have hgen : ((C.map (algebraMap F V.FunctionField))
+      • (W.map (algebraMap F V.FunctionField))).toAffine.Equation
+      (polyToFunctionField V X) (yGen V) := by
+    rw [hmap]
+    exact equation_map_polyToFunctionField_yGen
+  rw [mrtw60a_xFwd_eq_vcX, mrtw60a_yFwd_eq_vcY]
+  exact (equation_variableChange_iff (C := C.map (algebraMap F V.FunctionField))
+    (W := (W.map (algebraMap F V.FunctionField)).toAffine)
+    (polyToFunctionField V X) (yGen V)).mp hgen
+
+theorem mrtw60a_transcendental_affine {L : Type u} [Field L] [Algebra F L] {z : L}
+    (hz : Transcendental F z) {c d : F} (hc : c ≠ 0) :
+    Transcendental F (algebraMap F L c * z + algebraMap F L d) := by
+  rw [transcendental_iff] at hz ⊢
+  intro p hp
+  have hcomp : Polynomial.aeval z (p.comp (Polynomial.C c * X + Polynomial.C d)) = 0 := by
+    rw [Polynomial.aeval_comp]
+    simpa using hp
+  have h0 := hz _ hcomp
+  by_contra hp0
+  have hlc : (p.comp (Polynomial.C c * X + Polynomial.C d)).leadingCoeff ≠ 0 := by
+    rw [Polynomial.leadingCoeff_comp (by rw [Polynomial.natDegree_linear hc]; norm_num)]
+    exact mul_ne_zero (Polynomial.leadingCoeff_ne_zero.mpr hp0)
+      (pow_ne_zero _ (by rw [Polynomial.leadingCoeff_linear hc]; exact hc))
+  exact hlc (by rw [h0, Polynomial.leadingCoeff_zero])
+
+variable (C) (V : Affine F) in
+theorem mrtw60a_transcendental_xFwd : Transcendental F (mrtw60a_xFwd C V) := by
+  rw [mrtw60a_xFwd_shape]
+  exact mrtw60a_transcendental_affine (L := V.FunctionField)
+    (z := polyToFunctionField V X) (c := (C.u : F) ^ 2) (d := C.r)
+    (transcendental_polyToFunctionField_X (W := V)) (pow_ne_zero 2 C.u.ne_zero)
+
+variable (C) (V : Affine F) in
+theorem mrtw60a_aeval_xFwd_injective :
+    Function.Injective (Polynomial.aeval (R := F) (mrtw60a_xFwd C V)) :=
+  (injective_iff_map_eq_zero _).mpr fun p hp =>
+    transcendental_iff.mp (mrtw60a_transcendental_xFwd C V) p hp
+
+theorem mrtw60a_coordHom_ext {W : Affine F} {S : Type u} [CommRing S] [Algebra F S]
+    {φ ψ : W.CoordinateRing →ₐ[F] S}
+    (hX : φ (CoordinateRing.mk W (Polynomial.C X)) = ψ (CoordinateRing.mk W (Polynomial.C X)))
+    (hY : φ (CoordinateRing.mk W Y) = ψ (CoordinateRing.mk W Y)) : φ = ψ := by
+  have hpoly : ∀ p : F[X],
+      φ (CoordinateRing.mk W (Polynomial.C p)) = ψ (CoordinateRing.mk W (Polynomial.C p)) := by
+    intro p
+    have hC : (φ.toRingHom.comp (CoordinateRing.mk W)).comp (Polynomial.C : F[X] →+* F[X][Y])
+        = (ψ.toRingHom.comp (CoordinateRing.mk W)).comp (Polynomial.C : F[X] →+* F[X][Y]) := by
+      refine Polynomial.ringHom_ext (fun c => ?_) hX
+      change φ (CoordinateRing.mk W (Polynomial.C (Polynomial.C c)))
+        = ψ (CoordinateRing.mk W (Polynomial.C (Polynomial.C c)))
+      rw [← CoordinateRing.algebraMap_eq_mk_C_C, φ.commutes, ψ.commutes]
+    exact DFunLike.congr_fun hC p
+  have hh : φ.toRingHom.comp (CoordinateRing.mk W) = ψ.toRingHom.comp (CoordinateRing.mk W) :=
+    Polynomial.ringHom_ext hpoly hY
+  have hRing : φ.toRingHom = ψ.toRingHom :=
+    (RingHom.cancel_right AdjoinRoot.mk_surjective).mp hh
+  exact AlgHom.ext fun z => DFunLike.congr_fun hRing z
+
+end Mrtw60aVCPlaceSeamS1
+end FLT
+
+end
+
+noncomputable section
+
+open Polynomial WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.CoordinateRing
+
+open scoped Polynomial.Bivariate
+
+namespace FLT
+namespace Mrtw60aVCPlaceSeamS3
+
+open FLT.Mrtw60aVCPlaceSeamS1
+
+universe u
+
+variable {F : Type u} [Field F]
+
+theorem mrtw60a_funHom_ext {W : Affine F} {L : Type u} [Field L] [Algebra F L]
+    {φ ψ : W.FunctionField →ₐ[F] L}
+    (hX : φ (polyToFunctionField W X) = ψ (polyToFunctionField W X))
+    (hY : φ (yGen W) = ψ (yGen W)) : φ = ψ := by
+  have hres : φ.comp (IsScalarTower.toAlgHom F W.CoordinateRing W.FunctionField)
+      = ψ.comp (IsScalarTower.toAlgHom F W.CoordinateRing W.FunctionField) := by
+    refine mrtw60a_coordHom_ext ?_ ?_
+    · simp only [AlgHom.comp_apply, IsScalarTower.coe_toAlgHom']
+      exact hX
+    · simp only [AlgHom.comp_apply, IsScalarTower.coe_toAlgHom']
+      exact hY
+  have hcr : ∀ r : W.CoordinateRing,
+      φ (algebraMap W.CoordinateRing W.FunctionField r)
+        = ψ (algebraMap W.CoordinateRing W.FunctionField r) := by
+    intro r
+    have h2 := DFunLike.congr_fun hres r
+    simpa only [AlgHom.comp_apply, IsScalarTower.coe_toAlgHom'] using h2
+  refine AlgHom.ext fun z => ?_
+  obtain ⟨r, s, -, hz⟩ := IsFractionRing.div_surjective (A := W.CoordinateRing) z
+  rw [← hz, map_div₀, map_div₀, hcr r, hcr s]
+
+variable {C : VariableChange F} {W V : Affine F}
+
+def mrtw60aVCFunHom (h : C • W = V) : W.FunctionField →ₐ[F] V.FunctionField :=
+  pointPullbackHomTo (mrtw60a_equation_fwd h) (mrtw60a_aeval_xFwd_injective C V)
+
+@[scoped simp] theorem mrtw60aVCFunHom_X (h : C • W = V) :
+    mrtw60aVCFunHom h (polyToFunctionField W X) = mrtw60a_xFwd C V :=
+  pointPullbackHomTo_polyToFunctionField_X _ _
+
+@[scoped simp] theorem mrtw60aVCFunHom_yGen (h : C • W = V) :
+    mrtw60aVCFunHom h (yGen W) = mrtw60a_yFwd C V :=
+  pointPullbackHomTo_yGen _ _
+
+def mrtw60aVCFunHomInv (h : C • W = V) : V.FunctionField →ₐ[F] W.FunctionField :=
+  mrtw60aVCFunHom (mrtw60a_inv_smul h)
+
+@[scoped simp] theorem mrtw60aVCFunHomInv_X (h : C • W = V) :
+    mrtw60aVCFunHomInv h (polyToFunctionField V X) = mrtw60a_xFwd C⁻¹ W :=
+  mrtw60aVCFunHom_X (mrtw60a_inv_smul h)
+
+@[scoped simp] theorem mrtw60aVCFunHomInv_yGen (h : C • W = V) :
+    mrtw60aVCFunHomInv h (yGen V) = mrtw60a_yFwd C⁻¹ W :=
+  mrtw60aVCFunHom_yGen (mrtw60a_inv_smul h)
+
+theorem mrtw60a_invu_mul_u {E : Affine F} (C : VariableChange F) :
+    algebraMap F E.FunctionField (((C.u⁻¹ : Fˣ) : F))
+      * algebraMap F E.FunctionField ((C.u : F)) = 1 := by
+  rw [← map_mul, Units.inv_mul, map_one]
+
+theorem mrtw60a_funHomInv_comp_funHom (h : C • W = V) :
+    (mrtw60aVCFunHomInv h).comp (mrtw60aVCFunHom h) = AlgHom.id F W.FunctionField := by
+  have h1 := mrtw60a_invu_mul_u (E := W) C
+  refine mrtw60a_funHom_ext ?_ ?_
+  · rw [AlgHom.comp_apply, mrtw60aVCFunHom_X, AlgHom.id_apply, mrtw60a_xFwd_shape, map_add,
+      map_mul, AlgHom.commutes, AlgHom.commutes, mrtw60aVCFunHomInv_X, mrtw60a_xInv_shape]
+    simp only [map_pow]
+    linear_combination ((polyToFunctionField W X - algebraMap F W.FunctionField C.r)
+      * (algebraMap F W.FunctionField ((C.u : F))
+          * algebraMap F W.FunctionField (((C.u⁻¹ : Fˣ) : F)) + 1)) * h1
+  · rw [AlgHom.comp_apply, mrtw60aVCFunHom_yGen, AlgHom.id_apply, mrtw60a_yFwd_shape,
+      map_add, map_add, map_mul, map_mul, AlgHom.commutes, AlgHom.commutes,
+      AlgHom.commutes, mrtw60aVCFunHomInv_X, mrtw60aVCFunHomInv_yGen, mrtw60a_xInv_shape,
+      mrtw60a_yInv_shape]
+    simp only [map_pow, map_mul]
+    linear_combination (((algebraMap F W.FunctionField (((C.u⁻¹ : Fˣ) : F))
+          * algebraMap F W.FunctionField ((C.u : F))) ^ 2
+        + algebraMap F W.FunctionField (((C.u⁻¹ : Fˣ) : F))
+          * algebraMap F W.FunctionField ((C.u : F)) + 1)
+        * (yGen W - algebraMap F W.FunctionField C.t)
+      - (algebraMap F W.FunctionField (((C.u⁻¹ : Fˣ) : F))
+          * algebraMap F W.FunctionField ((C.u : F))) ^ 2
+        * algebraMap F W.FunctionField C.s
+        * (polyToFunctionField W X - algebraMap F W.FunctionField C.r)) * h1
+
+theorem mrtw60a_funHom_comp_funHomInv (h : C • W = V) :
+    (mrtw60aVCFunHom h).comp (mrtw60aVCFunHomInv h) = AlgHom.id F V.FunctionField := by
+  have h1 := mrtw60a_invu_mul_u (E := V) C
+  refine mrtw60a_funHom_ext ?_ ?_
+  · rw [AlgHom.comp_apply, mrtw60aVCFunHomInv_X, AlgHom.id_apply, mrtw60a_xInv_shape,
+      map_mul, map_sub, AlgHom.commutes, AlgHom.commutes, mrtw60aVCFunHom_X,
+      mrtw60a_xFwd_shape]
+    simp only [map_pow]
+    linear_combination (polyToFunctionField V X
+      * (algebraMap F V.FunctionField (((C.u⁻¹ : Fˣ) : F))
+          * algebraMap F V.FunctionField ((C.u : F)) + 1)) * h1
+  · rw [AlgHom.comp_apply, mrtw60aVCFunHomInv_yGen, AlgHom.id_apply, mrtw60a_yInv_shape,
+      map_mul, map_sub, map_sub, map_mul, map_sub, AlgHom.commutes, AlgHom.commutes,
+      AlgHom.commutes, AlgHom.commutes, mrtw60aVCFunHom_X, mrtw60aVCFunHom_yGen,
+      mrtw60a_xFwd_shape, mrtw60a_yFwd_shape]
+    simp only [map_pow, map_mul]
+    linear_combination (((algebraMap F V.FunctionField (((C.u⁻¹ : Fˣ) : F))
+          * algebraMap F V.FunctionField ((C.u : F))) ^ 2
+        + algebraMap F V.FunctionField (((C.u⁻¹ : Fˣ) : F))
+          * algebraMap F V.FunctionField ((C.u : F)) + 1) * yGen V) * h1
+
+def mrtw60aVCPlaceSeamAlgEquiv (h : C • W = V) : V.FunctionField ≃ₐ[F] W.FunctionField :=
+  AlgEquiv.ofAlgHom (mrtw60aVCFunHomInv h) (mrtw60aVCFunHom h)
+    (mrtw60a_funHomInv_comp_funHom h) (mrtw60a_funHom_comp_funHomInv h)
+
+end Mrtw60aVCPlaceSeamS3
+end FLT
+end
+
+universe u in
+theorem solution {F : Type u} [Field F] (W : WeierstrassCurve F)
+    (C : WeierstrassCurve.VariableChange F) :
+    Nonempty (W.toAffine.FunctionField ≃ₐ[F] (C • W).toAffine.FunctionField) :=
+  ⟨(FLT.Mrtw60aVCPlaceSeamS3.mrtw60aVCPlaceSeamAlgEquiv (C := C) (W := W.toAffine) (V := (C •
+    W).toAffine) rfl).symm⟩
+
+end privateSection
+
+public section publicSection
+
+universe u
+theorem WeierstrassCurve.nonempty_functionField_algEquiv_of_variableChange
+    {F : Type u} [Field F] (W : WeierstrassCurve F) (C : WeierstrassCurve.VariableChange F) :
+    Nonempty (W.toAffine.FunctionField ≃ₐ[F] (C • W).toAffine.FunctionField) :=
+  solution W C
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_nonempty_torsionBy_addEquiv_zmod_prod_of_isAlgClosed.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_nonempty_torsionBy_addEquiv_zmod_prod_of_isAlgClosed.lean
new file mode 100644
index 0000000000..acdc5b2926
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_nonempty_torsionBy_addEquiv_zmod_prod_of_isAlgClosed.lean
@@ -0,0 +1,83 @@
+/-
+Based on Prove2Me node WeierstrassCurve.nonempty_torsionBy_addEquiv_zmod_prod_of_isAlgClosed
+(a6ae4475-f68f-5bc7-a365-f1642a586e13) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a9593ece-5c12-570d-92a5-17eb0595667e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.Algebra.Module.Torsion.Basic
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AddCommGroup_nonempty_zmod_prod_addEquiv_torsionBy_of_card_torsionBy_eq_sq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsion_of_isAlgClosed
+
+/-!
+# E[n](K)≅(ℤ/n)² over an algebraically closed field
+
+Theorem statement: `WeierstrassCurve.nonempty_torsionBy_addEquiv_zmod_prod_of_isAlgClosed`
+(`a6ae4475-f68f-5bc7-a365-f1642a586e13`), by Claude, 2026-09-05.
+
+Proof: submission `a9593ece-5c12-570d-92a5-17eb0595667e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra, $K$ algebraically closed, and let $W$ be a
+Weierstrass curve over $F$ which is elliptic (invertible discriminant). Let $n$ be a natural number
+whose image in $K$ is nonzero, i.e. the characteristic of $K$ does not divide $n$ (this also forces
+$n \neq 0$). The assertion is that the type of additive group isomorphisms $\mathbb Z/n \times
+\mathbb Z/n \simeq \mathbb{Z}/n$-free of rank two is nonempty: concretely, `Nonempty (ZMod n × ZMod
+n ≃+ Submodule.torsionBy ℤ (W⁄K).Point n)`, where $(W⁄K)$ denotes the base change of $W$ to $K$,
+$(W⁄K).\mathrm{Point}$ its group of points, and `Submodule.torsionBy ℤ _ n` the subgroup of elements
+killed by $n$. Thus $W(K)[n] \cong \mathbb Z/n \times \mathbb Z/n$ as abelian groups. The statement
+is an existence assertion (a `Nonempty` of the type of isomorphisms), not a specified isomorphism,
+so it provides no canonical choice of basis of the $n$-torsion.
+
+This is the classical structure theorem for the $n$-torsion of an elliptic curve over an
+algebraically closed field of characteristic not dividing $n$ (Silverman, Corollary III.6.4(b)),
+i.e. the geometric existence of a full level-$n$ structure. It underlies the construction of mod-$n$
+Galois representations attached to elliptic curves and the counting of cyclic $n$-subgroups, and is
+cited widely in the modular-curve and Galois-representation parts of the development.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_nonempty_torsionBy_addEquiv_zmod_prod_of_isAlgClosed.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+theorem solution
+    {F K : Type*} [Field F] [Field K] [Algebra F K] [IsAlgClosed K] [DecidableEq K]
+    (W : WeierstrassCurve F) [W.IsElliptic] {n : ℕ} (hn : (n : K) ≠ 0) :
+    Nonempty (ZMod n × ZMod n ≃+ Submodule.torsionBy ℤ (W⁄K).Point n) := by
+  have hn0 : n ≠ 0 := by rintro rfl; exact hn Nat.cast_zero
+  refine AddCommGroup.nonempty_zmod_prod_addEquiv_torsionBy_of_card_torsionBy_eq_sq hn0 ?_
+  intro d hd
+  have hdK : (d : K) ≠ 0 := by
+    obtain ⟨c, rfl⟩ := hd
+    intro h; apply hn; push_cast; rw [h, zero_mul]
+  exact W.card_torsion_of_isAlgClosed hdK
+
+end privateSection
+
+public section publicSection
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+theorem WeierstrassCurve.nonempty_torsionBy_addEquiv_zmod_prod_of_isAlgClosed
+    {F K : Type*} [Field F] [Field K] [Algebra F K] [IsAlgClosed K] [DecidableEq K]
+    (W : WeierstrassCurve F) [W.IsElliptic] {n : ℕ} (hn : (n : K) ≠ 0) :
+    Nonempty (ZMod n × ZMod n ≃+ Submodule.torsionBy ℤ (W⁄K).Point n) :=
+  solution W hn
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_reducePoint_add.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_reducePoint_add.lean
new file mode 100644
index 0000000000..f37fe0326a
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_reducePoint_add.lean
@@ -0,0 +1,147 @@
+/-
+Based on Prove2Me node WeierstrassCurve.reducePoint_add
+(25dc37b9-1395-5558-9697-afa461c46bea) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4f96968c-66b8-58f1-b4b2-7a618abdf998
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_PointReduction
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_reducePoint_some_add_some_of_le_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_reducePoint_some_add_some_of_not_le_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_valuation_le_one_of_equation
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_reducePoint_some
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_reducePoint_some_eq_zero_iff
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Reduction of points is additive under good reduction
+
+Theorem statement: `WeierstrassCurve.reducePoint_add` (`25dc37b9-1395-5558-9697-afa461c46bea`), by
+Claude, 2026-09-05.
+
+Proof: submission `4f96968c-66b8-58f1-b4b2-7a618abdf998`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a discrete valuation ring that is a domain, and let $K$ be a field which is a fraction
+field of $R$ (with the residue field of $R$ and $K$ carrying decidable equality). Let $W$ be a
+Weierstrass curve over $K$ satisfying the predicate `WeierstrassCurve.HasGoodReduction` for $R$, so
+that in particular $W$ is minimal over $R$ and has a reduction `W.reduction R` over the residue
+field. For points $P$ and $Q$ of the affine group $W(K)$ given by the chord–tangent law, the
+assertion is that the map [`WeierstrassCurve.reducePoint_alt R
+W`](def/EllipticCurve_PointReduction.html#L22) from $W(K)$ to the points of the reduced curve
+commutes with addition: the reduction of $P+Q$ equals the sum of the reductions of $P$ and of $Q$.
+Here `reducePoint_alt` sends the point at infinity to the point at infinity, and sends an affine
+point $(x,y)$ to the affine point with coordinates `reduceCoord R x`, `reduceCoord R y` — the
+residue classes of chosen preimages in $R$ of $x$ and $y$, and $0$ when no preimage exists —
+provided both $x$ and $y$ have valuation at most $1$ at the maximal ideal of $R$ and the resulting
+pair is nonsingular on the reduced curve, and to the point at infinity in all other cases. Thus the
+conclusion says that this map is additive, without asserting it is a group homomorphism bundled as
+such.
+
+This is the classical statement that reduction $W(K) \to \widetilde{W}(k)$ is a group homomorphism
+in the case of good reduction (Silverman, Ch. VII, Prop. 2.1), here in the form of additivity of the
+explicitly defined reduction map on points. It is used downstream to obtain specialisation
+homomorphisms on points, divisibility of the order of a torsion point by the reduced group's
+cardinality, and compatibility of level structures on modular curves with reduction.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_reducePoint_add.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_reducePoint_add
+
+open WeierstrassCurve IsDiscreteValuationRing IsLocalRing IsDedekindDomain.HeightOneSpectrum
+
+theorem solution
+    (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+    {K : Type*} [Field K] [DecidableEq K] [Algebra R K] [IsFractionRing R K]
+    [DecidableEq (IsLocalRing.ResidueField R)]
+    (W : WeierstrassCurve K) [W.HasGoodReduction R] (P Q : W.toAffine.Point) :
+    WeierstrassCurve.reducePoint_alt R W (P + Q)
+      = WeierstrassCurve.reducePoint_alt R W P + WeierstrassCurve.reducePoint_alt R W Q := by
+  cases P with
+  | zero =>
+    change reducePoint_alt R W (0 + Q) = reducePoint_alt R W 0 + reducePoint_alt R W Q
+    rw [zero_add, show reducePoint_alt R W (0 : W.toAffine.Point) = 0 from rfl, zero_add]
+  | some x₁ y₁ h₁ =>
+    cases Q with
+    | zero =>
+      change reducePoint_alt R W (_ + 0) = _ + reducePoint_alt R W 0
+      rw [add_zero, show reducePoint_alt R W (0 : W.toAffine.Point) = 0 from rfl, add_zero]
+    | some x₂ y₂ h₂ =>
+      by_cases hx₁ : valuation K (IsDiscreteValuationRing.maximalIdeal R) x₁ ≤ 1
+      · by_cases hx₂ : valuation K (IsDiscreteValuationRing.maximalIdeal R) x₂ ≤ 1
+        · exact WeierstrassCurve.reducePoint_some_add_some_of_le_one R W h₁ h₂ hx₁ hx₂
+        · rw [WeierstrassCurve.reducePoint_some_add_some_of_not_le_one R W h₁ h₂ hx₁ hx₂,
+            (WeierstrassCurve.reducePoint_some_eq_zero_iff R W h₂).mpr hx₂,
+            show (Affine.Point.zero : (reduction R W).toAffine.Point) = 0 from rfl,
+            add_zero]
+      · by_cases hx₂ : valuation K (IsDiscreteValuationRing.maximalIdeal R) x₂ ≤ 1
+        · rw [show Affine.Point.some x₁ y₁ h₁ + Affine.Point.some x₂ y₂ h₂
+              = Affine.Point.some x₂ y₂ h₂ + Affine.Point.some x₁ y₁ h₁ from add_comm _ _,
+            WeierstrassCurve.reducePoint_some_add_some_of_not_le_one R W h₂ h₁ hx₂ hx₁,
+            (WeierstrassCurve.reducePoint_some_eq_zero_iff R W h₁).mpr hx₁,
+            show (Affine.Point.zero : (reduction R W).toAffine.Point) = 0 from rfl,
+            zero_add]
+        · rw [(WeierstrassCurve.reducePoint_some_eq_zero_iff R W h₁).mpr hx₁,
+            (WeierstrassCurve.reducePoint_some_eq_zero_iff R W h₂).mpr hx₂,
+            show (Affine.Point.zero + Affine.Point.zero
+              : (reduction R W).toAffine.Point) = Affine.Point.zero from rfl]
+          rcases hS : Affine.Point.some x₁ y₁ h₁ + Affine.Point.some x₂ y₂ h₂
+            with _ | ⟨x₃, y₃, h₃⟩
+          · rfl
+          · rw [WeierstrassCurve.reducePoint_some_eq_zero_iff R W h₃]
+            intro hx₃
+            have hy₃ : valuation K (IsDiscreteValuationRing.maximalIdeal R) y₃ ≤ 1 :=
+              WeierstrassCurve.valuation_le_one_of_equation R W h₃.1 hx₃
+            rcases hQ' : -(Affine.Point.some x₁ y₁ h₁) with _ | ⟨xn, yn, hn⟩
+            · exact Affine.Point.some_ne_zero h₁ (neg_eq_zero.mp hQ')
+            · have hQeq : Affine.Point.some x₂ y₂ h₂
+                  = Affine.Point.some x₃ y₃ h₃ + Affine.Point.some xn yn hn := by
+                rw [← hQ', ← hS]
+                abel
+              rw [Affine.Point.neg_some] at hQ'
+              simp only [Affine.Point.some.injEq] at hQ'
+              have hpole_n : ¬ valuation K (IsDiscreteValuationRing.maximalIdeal R) xn ≤ 1 := by
+                rw [← hQ'.1]
+                exact hx₁
+              have h0 := congrArg (reducePoint_alt R W) hQeq
+              rw [WeierstrassCurve.reducePoint_some_add_some_of_not_le_one R W h₃ hn hx₃
+                hpole_n] at h0
+              obtain ⟨h₃'', hrS⟩ := WeierstrassCurve.reducePoint_some R W h₃ hx₃ hy₃
+              rw [hrS, (WeierstrassCurve.reducePoint_some_eq_zero_iff R W h₂).mpr hx₂] at h0
+              exact Affine.Point.some_ne_zero h₃'' h0.symm
+
+end S_WeierstrassCurve_reducePoint_add
+end P2MW
+export P2MW.S_WeierstrassCurve_reducePoint_add (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.reducePoint_add
+    (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+    {K : Type*} [Field K] [DecidableEq K] [Algebra R K] [IsFractionRing R K]
+    [DecidableEq (IsLocalRing.ResidueField R)]
+    (W : WeierstrassCurve K) [W.HasGoodReduction R] (P Q : W.toAffine.Point) :
+    WeierstrassCurve.reducePoint_alt R W (P + Q)
+      = WeierstrassCurve.reducePoint_alt R W P + WeierstrassCurve.reducePoint_alt R W Q :=
+  solution R W P Q
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_reducePoint_some.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_reducePoint_some.lean
new file mode 100644
index 0000000000..a1ca6c3da8
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_reducePoint_some.lean
@@ -0,0 +1,138 @@
+/-
+Based on Prove2Me node WeierstrassCurve.reducePoint_some
+(6811c24a-05be-5b4a-b485-5b5364653347) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 786f7348-8ae7-5e05-9544-9424c3aa433c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_PointReduction
+
+import Mathlib.AlgebraicGeometry.EllipticCurve.Reduction
+import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+import Mathlib.RingTheory.DedekindDomain.AdicValuation
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Reduction of an integral affine point has residue coordinates
+
+Theorem statement: `WeierstrassCurve.reducePoint_some` (`6811c24a-05be-5b4a-b485-5b5364653347`), by
+Claude, 2026-09-05.
+
+Proof: submission `786f7348-8ae7-5e05-9544-9424c3aa433c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a discrete valuation ring which is a domain, $K$ a field equipped with an $R$-algebra
+structure making it a fraction field of $R$, and $W$ a Weierstrass curve over $K$ satisfying
+`HasGoodReduction R`. Let $x,y \in K$ together with a proof $h$ that $(x,y)$ is a nonsingular point
+of the affine curve attached to $W$, and suppose that the $\mathrm{maximalIdeal}\ R$-adic valuation
+on $K$ satisfies $v(x) \le 1$ and $v(y) \le 1$, i.e. both coordinates are integral. The conclusion
+asserts the existence of a proof $h'$ that $(\mathrm{reduceCoord}\ R\ x, \mathrm{reduceCoord}\ R\
+y)$ is a nonsingular point of the reduced curve `W.reduction R` over the residue field of $R$, such
+that `reducePoint_alt R W` applied to the affine point `.some x y h` equals the affine point `.some`
+with these two coordinates and witness $h'$. Here $\mathrm{reduceCoord}\ R\ z$ is the residue in the
+residue field of some $r \in R$ with $\mathrm{algebraMap}\ R\ K\ r = z$ when such $r$ exists, and
+$0$ otherwise; and `reducePoint_alt` is defined by cases, sending `.some x y _` to the point with
+reduced coordinates when both valuations are $\le 1$ and the reduced pair is nonsingular, and to the
+zero point otherwise.
+
+This is the specification lemma for the reduction map $W(K) \to \tilde W(k)$ on points with integral
+coordinates: on such a point the map is given by reducing the coordinates, and no branch of the case
+distinction in its definition is taken trivially. It is used in the construction of specialisation
+homomorphisms on points and in the proof that the Galois representation attached to a curve with
+good reduction at a place is unramified there.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_reducePoint_some.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_reducePoint_some
+
+open WeierstrassCurve IsDiscreteValuationRing IsLocalRing IsDedekindDomain.HeightOneSpectrum
+
+namespace ReduceSome
+
+theorem reducePoint_some' (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+    {K : Type*} [Field K] [Algebra R K] [IsFractionRing R K] (W : WeierstrassCurve K)
+    [W.HasGoodReduction R] {x y : K} (h : W.toAffine.Nonsingular x y)
+    (hx : valuation K (IsDiscreteValuationRing.maximalIdeal R) x ≤ 1)
+    (hy : valuation K (IsDiscreteValuationRing.maximalIdeal R) y ≤ 1) :
+    ∃ h', reducePoint_alt R W (.some x y h) = .some (reduceCoord R x) (reduceCoord R y) h' := by
+  obtain ⟨rx, hrx⟩ := exists_lift_of_le_one hx
+  obtain ⟨ry, hry⟩ := exists_lift_of_le_one hy
+  have hex : ∃ r : R, algebraMap R K r = x := ⟨rx, hrx⟩
+  have hey : ∃ r : R, algebraMap R K r = y := ⟨ry, hry⟩
+  have hcx : reduceCoord R x = residue R rx := by
+    rw [reduceCoord, dite_eq_left hex]
+    exact congrArg _ (IsFractionRing.injective R K (hex.choose_spec.trans hrx.symm))
+  have hcy : reduceCoord R y = residue R ry := by
+    rw [reduceCoord, dite_eq_left hey]
+    exact congrArg _ (IsFractionRing.injective R K (hey.choose_spec.trans hry.symm))
+  have heqK : ((integralModel R W).map (algebraMap R K)).toAffine.Equation
+      (algebraMap R K rx) (algebraMap R K ry) := by
+    have hbc : (integralModel R W).map (algebraMap R K) = W := baseChange_integralModel_eq R W
+    rw [hbc, hrx, hry]
+    exact h.1
+  have heqR : (integralModel R W).toAffine.Equation rx ry :=
+    (Affine.map_equation _ (IsFractionRing.injective R K) _ _).mp heqK
+  have heqk : (reduction R W).toAffine.Equation (residue R rx) (residue R ry) :=
+    heqR.map (residue R)
+  have hell : (reduction R W).IsElliptic :=
+    (hasGoodReduction_iff_isElliptic_reduction R).mp ‹W.HasGoodReduction R›
+  have hns : (reduction R W).toAffine.Nonsingular (reduceCoord R x) (reduceCoord R y) := by
+    rw [hcx, hcy]
+    exact Affine.equation_iff_nonsingular.mp heqk
+  have hxy : valuation K (IsDiscreteValuationRing.maximalIdeal R) x ≤ 1 ∧ valuation K
+    (IsDiscreteValuationRing.maximalIdeal R) y ≤ 1 :=
+    ⟨hx, hy⟩
+  refine ⟨hns, ?_⟩
+  simp only [reducePoint_alt, dite_eq_left hxy, dite_eq_left hns]
+
+end ReduceSome
+
+theorem solution
+    (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+    {K : Type*} [Field K] [Algebra R K] [IsFractionRing R K]
+    (W : WeierstrassCurve K) [W.HasGoodReduction R] {x y : K} (h : W.toAffine.Nonsingular x y)
+    (hx : IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R) x
+      ≤ 1)
+    (hy : IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R) y
+      ≤ 1) :
+    ∃ h', WeierstrassCurve.reducePoint_alt R W (.some x y h)
+      = .some (WeierstrassCurve.reduceCoord R x) (WeierstrassCurve.reduceCoord R y) h' :=
+  ReduceSome.reducePoint_some' R W h hx hy
+
+end S_WeierstrassCurve_reducePoint_some
+end P2MW
+export P2MW.S_WeierstrassCurve_reducePoint_some (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.reducePoint_some
+    (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+    {K : Type*} [Field K] [Algebra R K] [IsFractionRing R K]
+    (W : WeierstrassCurve K) [W.HasGoodReduction R] {x y : K} (h : W.toAffine.Nonsingular x y)
+    (hx : IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R) x
+      ≤ 1)
+    (hy : IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R) y
+      ≤ 1) :
+    ∃ h', WeierstrassCurve.reducePoint_alt R W (.some x y h)
+      = .some (WeierstrassCurve.reduceCoord R x) (WeierstrassCurve.reduceCoord R y) h' :=
+  solution R W h hx hy
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_reducePoint_some_add_some_of_le_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_reducePoint_some_add_some_of_le_one.lean
new file mode 100644
index 0000000000..2dbba3be33
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_reducePoint_some_add_some_of_le_one.lean
@@ -0,0 +1,769 @@
+/-
+Based on Prove2Me node WeierstrassCurve.reducePoint_some_add_some_of_le_one
+(ca1cf78f-5d1e-51f5-974b-90f484c78720) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 45bf2165-9486-58dd-849a-6f743be2640e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_PointReduction
+
+import Mathlib.AlgebraicGeometry.EllipticCurve.Reduction
+import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+import Mathlib.Tactic.LinearCombination
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_valuation_le_one_of_equation
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_reducePoint_some
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_reducePoint_some_eq_zero_iff
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Additivity of reduction for points with integral x-coordinate
+
+Theorem statement: `WeierstrassCurve.reducePoint_some_add_some_of_le_one`
+(`ca1cf78f-5d1e-51f5-974b-90f484c78720`), by Claude, 2026-09-05.
+
+Proof: submission `45bf2165-9486-58dd-849a-6f743be2640e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a discrete valuation domain with fraction field $K$ (a field with decidable equality,
+realised as a fraction field of $R$ via an algebra structure), write $\mathfrak{m}$ for the maximal
+ideal of $R$ viewed as a height-one prime and let $v$ be the associated valuation on $K$. Let $W$ be
+a Weierstrass curve over $K$ satisfying the predicate `W.HasGoodReduction R`, so that $W$ has a
+reduction `W.reduction R` over the residue field of $R$ and the reduction map on points,
+`reducePoint_alt R W`, is defined: it sends the point at infinity to the point at infinity, and an
+affine point $(x,y)$ to the affine point with coordinates `reduceCoord R x`, `reduceCoord R y` when
+$v(x) \le 1$, $v(y) \le 1$ and that reduced pair is nonsingular on `W.reduction R`, and to the point
+at infinity otherwise; here `reduceCoord R x` is the residue of a preimage of $x$ in $R$, and $0$ if
+$x$ has no such preimage. Let $(x_1,y_1)$ and $(x_2,y_2)$ be nonsingular affine points of $W$ over
+$K$ with $v(x_1) \le 1$ and $v(x_2) \le 1$. Then `reducePoint_alt R W` applied to the sum of the two
+points, taken in the group of $K$-points of the affine curve, equals the sum of the images of the
+two points.
+
+This is the principal case of the statement that reduction of points is a group homomorphism
+(Silverman, Arithmetic of Elliptic Curves, VII.2.1), restricted to pairs of affine points whose
+$x$-coordinates are integral. It is the main input to
+[`WeierstrassCurve.reducePoint_add`](thm.html#WeierstrassCurve.reducePoint_add), which removes the
+integrality hypotheses and gives additivity of the reduction map on all of $W(K)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_reducePoint_some_add_some_of_le_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_reducePoint_some_add_some_of_le_one
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "integralModel_a₂_eq Affine Affine.negY HasGoodReduction \
+  Affine.Y_eq_of_Y_ne Affine.slope_of_X_ne hasGoodReduction_iff_isElliptic_reduction a₃ \
+  Affine.Point.add_of_Y_eq a₁ map a₄ a₂ Affine.map_equation a₆ Affine.Point.some \
+  Affine.nonsingular_iff' Affine.Point.some.injEq integralModel_a₃_eq integralModel_a₁_eq \
+  reduction Affine.map_addY integralModel integralModel_a₆_eq Affine.map_addX \
+  Affine.nonsingular_add toAffine Affine.slope_of_Y_ne Affine.Point baseChange_integralModel_eq \
+  Affine.addX Affine.Point.add_some map_a₆ map_a₁ Affine.equation_iff_nonsingular map_a₄ \
+  Affine.equation_iff integralModel_a₄_eq map_a₂ map_a₃ reduceCoord reducePoint_alt \
+  valuation_le_one_of_equation reducePoint_some reducePoint_some_eq_zero_iff"
+p2m_open "WeierstrassCurve"
+
+namespace ReducePointAddPort
+
+open IsDiscreteValuationRing IsLocalRing
+open IsDedekindDomain.HeightOneSpectrum
+
+variable {R : Type*} [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+  {K : Type*} [Field K] [Algebra R K] [IsFractionRing R K]
+
+variable (R) (W : WeierstrassCurve K)
+
+theorem exists_algebraMap_eq_of_valuation_le_one {x : K}
+    (hx : valuation K (maximalIdeal R) x ≤ 1) : ∃ r : R, algebraMap R K r = x :=
+  exists_lift_of_le_one hx
+
+variable [W.HasGoodReduction R]
+
+theorem reduceCoord_algebraMap (r : R) :
+    reduceCoord R (algebraMap R K r) = residue R r := by
+  have hex : ∃ r' : R, algebraMap R K r' = algebraMap R K r := ⟨r, rfl⟩
+  rw [reduceCoord, dite_eq_left hex]
+  exact congrArg _ (IsFractionRing.injective R K hex.choose_spec)
+
+theorem reduceCoord_eq_zero_iff_lt {x : K}
+    (hx : valuation K (maximalIdeal R) x ≤ 1) :
+    reduceCoord R x = 0 ↔ valuation K (maximalIdeal R) x < 1 := by
+  obtain ⟨r, hr⟩ := exists_algebraMap_eq_of_valuation_le_one R hx
+  rw [← hr, reduceCoord_algebraMap, residue_eq_zero_iff]
+  exact (valuation_lt_one_iff_mem (K := K) (maximalIdeal R) r).symm
+
+theorem reduction_a₁ : (reduction R W).a₁ = residue R (integralModel R W).a₁ := by
+  simp only [reduction, map_a₁]
+
+theorem reduction_a₂ : (reduction R W).a₂ = residue R (integralModel R W).a₂ := by
+  simp only [reduction, map_a₂]
+
+theorem reduction_a₃ : (reduction R W).a₃ = residue R (integralModel R W).a₃ := by
+  simp only [reduction, map_a₃]
+
+theorem reduction_a₄ : (reduction R W).a₄ = residue R (integralModel R W).a₄ := by
+  simp only [reduction, map_a₄]
+
+theorem reduction_a₆ : (reduction R W).a₆ = residue R (integralModel R W).a₆ := by
+  simp only [reduction, map_a₆]
+
+theorem equation_lift {x y : K} (h : W.toAffine.Equation x y) {rx ry : R}
+    (hrx : algebraMap R K rx = x) (hry : algebraMap R K ry = y) :
+    (integralModel R W).toAffine.Equation rx ry := by
+  have heqK : ((integralModel R W).map (algebraMap R K)).toAffine.Equation
+      (algebraMap R K rx) (algebraMap R K ry) := by
+    have hbc : (integralModel R W).map (algebraMap R K) = W := baseChange_integralModel_eq R W
+    rw [hbc, hrx, hry]
+    exact h
+  exact (Affine.map_equation _ (IsFractionRing.injective R K) _ _).mp heqK
+
+theorem reduced_nonsingular {rx ry : R} (h : (integralModel R W).toAffine.Equation rx ry) :
+    (reduction R W).toAffine.Nonsingular (residue R rx) (residue R ry) := by
+  have hell : (reduction R W).IsElliptic :=
+    (hasGoodReduction_iff_isElliptic_reduction R).mp ‹W.HasGoodReduction R›
+  have heqk : (reduction R W).toAffine.Equation (residue R rx) (residue R ry) :=
+    h.map (residue R)
+  exact Affine.equation_iff_nonsingular.mp heqk
+
+theorem slope_identity {x₁ y₁ x₂ y₂ : K} (h₁ : W.toAffine.Equation x₁ y₁)
+    (h₂ : W.toAffine.Equation x₂ y₂) :
+    (y₁ - y₂) * (y₁ + y₂ + W.a₁ * x₁ + W.a₃)
+      = (x₁ - x₂) * (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂) := by
+  rw [Affine.equation_iff] at h₁ h₂
+  linear_combination h₁ - h₂
+
+theorem slope_spec [DecidableEq K] [DecidableEq (ResidueField R)]
+    {x₁ y₁ x₂ y₂ : K} (h₁ : W.toAffine.Nonsingular x₁ y₁) (h₂ : W.toAffine.Nonsingular x₂ y₂)
+    (hx₁ : valuation K (maximalIdeal R) x₁ ≤ 1) (hy₁ : valuation K (maximalIdeal R) y₁ ≤ 1)
+    (hx₂ : valuation K (maximalIdeal R) x₂ ≤ 1) (hy₂ : valuation K (maximalIdeal R) y₂ ≤ 1)
+    (hxy : ¬(x₁ = x₂ ∧ y₁ = W.toAffine.negY x₂ y₂))
+    (hcol : ¬(reduceCoord R x₁ = reduceCoord R x₂ ∧
+      reduceCoord R y₁ = (reduction R W).toAffine.negY (reduceCoord R x₂) (reduceCoord R y₂))) :
+    valuation K (maximalIdeal R) (W.toAffine.slope x₁ x₂ y₁ y₂) ≤ 1 ∧
+      reduceCoord R (W.toAffine.slope x₁ x₂ y₁ y₂)
+        = (reduction R W).toAffine.slope (reduceCoord R x₁) (reduceCoord R x₂)
+            (reduceCoord R y₁) (reduceCoord R y₂) := by
+  obtain ⟨r1x, h1x⟩ := exists_algebraMap_eq_of_valuation_le_one R hx₁
+  obtain ⟨r1y, h1y⟩ := exists_algebraMap_eq_of_valuation_le_one R hy₁
+  obtain ⟨r2x, h2x⟩ := exists_algebraMap_eq_of_valuation_le_one R hx₂
+  obtain ⟨r2y, h2y⟩ := exists_algebraMap_eq_of_valuation_le_one R hy₂
+  have hc1x : reduceCoord R x₁ = residue R r1x := by rw [← h1x, reduceCoord_algebraMap]
+  have hc1y : reduceCoord R y₁ = residue R r1y := by rw [← h1y, reduceCoord_algebraMap]
+  have hc2x : reduceCoord R x₂ = residue R r2x := by rw [← h2x, reduceCoord_algebraMap]
+  have hc2y : reduceCoord R y₂ = residue R r2y := by rw [← h2y, reduceCoord_algebraMap]
+  rw [hc1x, hc1y, hc2x, hc2y] at hcol ⊢
+  have hE1k : (reduction R W).toAffine.Equation (residue R r1x) (residue R r1y) :=
+    (equation_lift R W h₁.1 h1x h1y).map (residue R)
+  have hE2k : (reduction R W).toAffine.Equation (residue R r2x) (residue R r2y) :=
+    (equation_lift R W h₂.1 h2x h2y).map (residue R)
+  by_cases hxK : x₁ = x₂
+  · have hyne : y₁ ≠ W.toAffine.negY x₂ y₂ := fun hy => hxy ⟨hxK, hy⟩
+    have hy12 : y₁ = y₂ := Affine.Y_eq_of_Y_ne h₁.1 h₂.1 hxK hyne
+    have hr12x : r1x = r2x := IsFractionRing.injective R K (by rw [h1x, h2x, hxK])
+    have hr12y : r1y = r2y := IsFractionRing.injective R K (by rw [h1y, h2y, hy12])
+    rw [Affine.slope_of_Y_ne hxK hyne]
+    have hdK : y₁ - W.toAffine.negY x₁ y₁
+        = algebraMap R K (r1y - (integralModel R W).toAffine.negY r1x r1y) := by
+      simp only [Affine.negY, map_sub, map_neg, map_mul, h1x, h1y,
+        integralModel_a₁_eq, integralModel_a₃_eq]
+    have hdbar : residue R (r1y - (integralModel R W).toAffine.negY r1x r1y)
+        = residue R r1y - (reduction R W).toAffine.negY (residue R r1x) (residue R r1y) := by
+      simp only [Affine.negY, map_sub, map_neg, map_mul, reduction_a₁, reduction_a₃]
+    have hdne : residue R r1y
+        - (reduction R W).toAffine.negY (residue R r1x) (residue R r1y) ≠ 0 := by
+      rw [sub_ne_zero]
+      intro hcontra
+      exact hcol ⟨congrArg _ hr12x,
+        by rw [← congrArg (residue R) hr12x, ← congrArg (residue R) hr12y]; exact hcontra⟩
+    have hvd_le : valuation K (maximalIdeal R) (y₁ - W.toAffine.negY x₁ y₁) ≤ 1 := by
+      rw [hdK]; exact valuation_le_one _ _
+    have hvd_one : valuation K (maximalIdeal R) (y₁ - W.toAffine.negY x₁ y₁) = 1 := by
+      rcases lt_or_eq_of_le hvd_le with hlt | heq
+      · have h0 := (reduceCoord_eq_zero_iff_lt R hvd_le).mpr hlt
+        rw [hdK, reduceCoord_algebraMap, hdbar] at h0
+        exact absurd h0 hdne
+      · exact heq
+    have hd0 : y₁ - W.toAffine.negY x₁ y₁ ≠ 0 :=
+      (Valuation.ne_zero_iff _).mp (by rw [hvd_one]; exact one_ne_zero)
+    have hnK : 3 * x₁ ^ 2 + 2 * W.toAffine.a₂ * x₁ + W.toAffine.a₄ - W.toAffine.a₁ * y₁
+        = algebraMap R K (3 * r1x ^ 2 + 2 * (integralModel R W).a₂ * r1x
+            + (integralModel R W).a₄ - (integralModel R W).a₁ * r1y) := by
+      simp only [map_sub, map_add, map_mul, map_pow, map_ofNat, h1x, h1y,
+        integralModel_a₁_eq, integralModel_a₂_eq, integralModel_a₄_eq]
+    have hvn_le : valuation K (maximalIdeal R)
+        (3 * x₁ ^ 2 + 2 * W.toAffine.a₂ * x₁ + W.toAffine.a₄ - W.toAffine.a₁ * y₁) ≤ 1 := by
+      rw [hnK]; exact valuation_le_one _ _
+    have hvℓ : valuation K (maximalIdeal R)
+        ((3 * x₁ ^ 2 + 2 * W.toAffine.a₂ * x₁ + W.toAffine.a₄ - W.toAffine.a₁ * y₁)
+          / (y₁ - W.toAffine.negY x₁ y₁)) ≤ 1 := by
+      rw [map_div₀, hvd_one, div_one]; exact hvn_le
+    refine ⟨hvℓ, ?_⟩
+    obtain ⟨rl, hrl⟩ := exists_algebraMap_eq_of_valuation_le_one R hvℓ
+    have hld : rl * (r1y - (integralModel R W).toAffine.negY r1x r1y)
+        = 3 * r1x ^ 2 + 2 * (integralModel R W).a₂ * r1x
+            + (integralModel R W).a₄ - (integralModel R W).a₁ * r1y := by
+      apply IsFractionRing.injective R K
+      rw [map_mul, hrl, ← hdK, div_mul_cancel₀ _ hd0, hnK]
+    have hlres : residue R rl
+        * (residue R r1y - (reduction R W).toAffine.negY (residue R r1x) (residue R r1y))
+        = residue R (3 * r1x ^ 2 + 2 * (integralModel R W).a₂ * r1x
+            + (integralModel R W).a₄ - (integralModel R W).a₁ * r1y) := by
+      rw [← hdbar, ← map_mul, hld]
+    have hnbar : residue R (3 * r1x ^ 2 + 2 * (integralModel R W).a₂ * r1x
+            + (integralModel R W).a₄ - (integralModel R W).a₁ * r1y)
+        = 3 * residue R r1x ^ 2 + 2 * (reduction R W).toAffine.a₂ * residue R r1x
+            + (reduction R W).toAffine.a₄ - (reduction R W).toAffine.a₁ * residue R r1y := by
+      simp only [map_sub, map_add, map_mul, map_pow, map_ofNat,
+        reduction_a₁, reduction_a₂, reduction_a₄]
+    rw [← hrl, reduceCoord_algebraMap,
+      Affine.slope_of_Y_ne (congrArg _ hr12x) (fun h => hcol ⟨congrArg _ hr12x, h⟩),
+      eq_div_iff hdne]
+    exact hlres.trans hnbar
+  · rw [Affine.slope_of_X_ne hxK]
+    by_cases hxbar : residue R r1x = residue R r2x
+    · have hybarne : residue R r1y
+          ≠ (reduction R W).toAffine.negY (residue R r2x) (residue R r2y) :=
+        fun h => hcol ⟨hxbar, h⟩
+      have hy12bar : residue R r1y = residue R r2y :=
+        Affine.Y_eq_of_Y_ne hE1k hE2k hxbar hybarne
+      have hd₂K : y₁ + y₂ + W.toAffine.a₁ * x₁ + W.toAffine.a₃
+          = algebraMap R K (r1y + r2y + (integralModel R W).a₁ * r1x
+              + (integralModel R W).a₃) := by
+        simp only [map_add, map_mul, h1x, h1y, h2y, integralModel_a₁_eq, integralModel_a₃_eq]
+      have hd₂bar : residue R (r1y + r2y + (integralModel R W).a₁ * r1x
+              + (integralModel R W).a₃)
+          = residue R r1y + residue R r2y
+              + (reduction R W).toAffine.a₁ * residue R r1x
+              + (reduction R W).toAffine.a₃ := by
+        simp only [map_add, map_mul, reduction_a₁, reduction_a₃]
+      have hd₂ne : residue R r1y + residue R r2y
+          + (reduction R W).toAffine.a₁ * residue R r1x + (reduction R W).toAffine.a₃ ≠ 0 := by
+        intro h0
+        apply hybarne
+        simp only [Affine.negY]
+        rw [← hxbar]
+        linear_combination h0
+      have hvd₂_le : valuation K (maximalIdeal R)
+          (y₁ + y₂ + W.toAffine.a₁ * x₁ + W.toAffine.a₃) ≤ 1 := by
+        rw [hd₂K]; exact valuation_le_one _ _
+      have hvd₂_one : valuation K (maximalIdeal R)
+          (y₁ + y₂ + W.toAffine.a₁ * x₁ + W.toAffine.a₃) = 1 := by
+        rcases lt_or_eq_of_le hvd₂_le with hlt | heq
+        · have h0 := (reduceCoord_eq_zero_iff_lt R hvd₂_le).mpr hlt
+          rw [hd₂K, reduceCoord_algebraMap, hd₂bar] at h0
+          exact absurd h0 hd₂ne
+        · exact heq
+      have hd₂0 : y₁ + y₂ + W.toAffine.a₁ * x₁ + W.toAffine.a₃ ≠ 0 :=
+        (Valuation.ne_zero_iff _).mp (by rw [hvd₂_one]; exact one_ne_zero)
+      have hℓeq : (y₁ - y₂) / (x₁ - x₂)
+          = (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.toAffine.a₂ * (x₁ + x₂) + W.toAffine.a₄
+              - W.toAffine.a₁ * y₂)
+            / (y₁ + y₂ + W.toAffine.a₁ * x₁ + W.toAffine.a₃) := by
+        rw [div_eq_div_iff (sub_ne_zero.mpr hxK) hd₂0]
+        linear_combination slope_identity W h₁.1 h₂.1
+      rw [hℓeq]
+      have hNK : x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.toAffine.a₂ * (x₁ + x₂) + W.toAffine.a₄
+              - W.toAffine.a₁ * y₂
+          = algebraMap R K (r1x ^ 2 + r1x * r2x + r2x ^ 2
+              + (integralModel R W).a₂ * (r1x + r2x) + (integralModel R W).a₄
+              - (integralModel R W).a₁ * r2y) := by
+        simp only [map_sub, map_add, map_mul, map_pow, h1x, h2x, h2y,
+          integralModel_a₁_eq, integralModel_a₂_eq, integralModel_a₄_eq]
+      have hvN_le : valuation K (maximalIdeal R) (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2
+          + W.toAffine.a₂ * (x₁ + x₂) + W.toAffine.a₄ - W.toAffine.a₁ * y₂) ≤ 1 := by
+        rw [hNK]; exact valuation_le_one _ _
+      have hvℓ : valuation K (maximalIdeal R) ((x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2
+          + W.toAffine.a₂ * (x₁ + x₂) + W.toAffine.a₄ - W.toAffine.a₁ * y₂)
+            / (y₁ + y₂ + W.toAffine.a₁ * x₁ + W.toAffine.a₃)) ≤ 1 := by
+        rw [map_div₀, hvd₂_one, div_one]; exact hvN_le
+      refine ⟨hvℓ, ?_⟩
+      obtain ⟨rl, hrl⟩ := exists_algebraMap_eq_of_valuation_le_one R hvℓ
+      have hld : rl * (r1y + r2y + (integralModel R W).a₁ * r1x + (integralModel R W).a₃)
+          = r1x ^ 2 + r1x * r2x + r2x ^ 2 + (integralModel R W).a₂ * (r1x + r2x)
+              + (integralModel R W).a₄ - (integralModel R W).a₁ * r2y := by
+        apply IsFractionRing.injective R K
+        rw [map_mul, hrl, ← hd₂K, div_mul_cancel₀ _ hd₂0, hNK]
+      have hNbar : residue R (r1x ^ 2 + r1x * r2x + r2x ^ 2
+              + (integralModel R W).a₂ * (r1x + r2x) + (integralModel R W).a₄
+              - (integralModel R W).a₁ * r2y)
+          = residue R r1x ^ 2 + residue R r1x * residue R r2x + residue R r2x ^ 2
+              + (reduction R W).toAffine.a₂ * (residue R r1x + residue R r2x)
+              + (reduction R W).toAffine.a₄
+              - (reduction R W).toAffine.a₁ * residue R r2y := by
+        simp only [map_sub, map_add, map_mul, map_pow, reduction_a₁, reduction_a₂, reduction_a₄]
+      have h1 : residue R r1y
+            - (reduction R W).toAffine.negY (residue R r1x) (residue R r1y)
+          = residue R r1y + residue R r2y + (reduction R W).toAffine.a₁ * residue R r1x
+              + (reduction R W).toAffine.a₃ := by
+        simp only [Affine.negY]
+        linear_combination hy12bar
+      have h2 : 3 * residue R r1x ^ 2 + 2 * (reduction R W).toAffine.a₂ * residue R r1x
+              + (reduction R W).toAffine.a₄ - (reduction R W).toAffine.a₁ * residue R r1y
+          = residue R r1x ^ 2 + residue R r1x * residue R r2x + residue R r2x ^ 2
+              + (reduction R W).toAffine.a₂ * (residue R r1x + residue R r2x)
+              + (reduction R W).toAffine.a₄
+              - (reduction R W).toAffine.a₁ * residue R r2y := by
+        linear_combination (2 * residue R r1x + residue R r2x
+            + (reduction R W).toAffine.a₂) * hxbar
+          - (reduction R W).toAffine.a₁ * hy12bar
+      have htdne : residue R r1y
+          - (reduction R W).toAffine.negY (residue R r1x) (residue R r1y) ≠ 0 := by
+        rw [h1]; exact hd₂ne
+      rw [← hrl, reduceCoord_algebraMap, Affine.slope_of_Y_ne hxbar hybarne,
+        eq_div_iff htdne, h1, h2, ← hd₂bar, ← hNbar, ← map_mul, hld]
+    · have hdxK : x₁ - x₂ = algebraMap R K (r1x - r2x) := by
+        simp only [map_sub, h1x, h2x]
+      have hdxne : residue R r1x - residue R r2x ≠ 0 := sub_ne_zero.mpr hxbar
+      have hvdx_le : valuation K (maximalIdeal R) (x₁ - x₂) ≤ 1 := by
+        rw [hdxK]; exact valuation_le_one _ _
+      have hvdx_one : valuation K (maximalIdeal R) (x₁ - x₂) = 1 := by
+        rcases lt_or_eq_of_le hvdx_le with hlt | heq
+        · have h0 := (reduceCoord_eq_zero_iff_lt R hvdx_le).mpr hlt
+          rw [hdxK, reduceCoord_algebraMap, map_sub] at h0
+          exact absurd h0 hdxne
+        · exact heq
+      have hdx0 : x₁ - x₂ ≠ 0 := sub_ne_zero.mpr hxK
+      have hdyK : y₁ - y₂ = algebraMap R K (r1y - r2y) := by
+        simp only [map_sub, h1y, h2y]
+      have hvdy_le : valuation K (maximalIdeal R) (y₁ - y₂) ≤ 1 := by
+        rw [hdyK]; exact valuation_le_one _ _
+      have hvℓ : valuation K (maximalIdeal R) ((y₁ - y₂) / (x₁ - x₂)) ≤ 1 := by
+        rw [map_div₀, hvdx_one, div_one]; exact hvdy_le
+      refine ⟨hvℓ, ?_⟩
+      obtain ⟨rl, hrl⟩ := exists_algebraMap_eq_of_valuation_le_one R hvℓ
+      have hld : rl * (r1x - r2x) = r1y - r2y := by
+        apply IsFractionRing.injective R K
+        rw [map_mul, hrl, ← hdxK, div_mul_cancel₀ _ hdx0, hdyK]
+      rw [← hrl, reduceCoord_algebraMap, Affine.slope_of_X_ne hxbar, eq_div_iff hdxne]
+      calc residue R rl * (residue R r1x - residue R r2x)
+          = residue R (rl * (r1x - r2x)) := by rw [map_mul, map_sub]
+        _ = residue R (r1y - r2y) := by rw [hld]
+        _ = residue R r1y - residue R r2y := map_sub _ _ _
+
+theorem slope_pole [DecidableEq K]
+    {x₁ y₁ x₂ y₂ : K} (h₁ : W.toAffine.Nonsingular x₁ y₁) (h₂ : W.toAffine.Nonsingular x₂ y₂)
+    (hx₁ : valuation K (maximalIdeal R) x₁ ≤ 1) (hy₁ : valuation K (maximalIdeal R) y₁ ≤ 1)
+    (hx₂ : valuation K (maximalIdeal R) x₂ ≤ 1) (hy₂ : valuation K (maximalIdeal R) y₂ ≤ 1)
+    (hxy : ¬(x₁ = x₂ ∧ y₁ = W.toAffine.negY x₂ y₂))
+    (hcolx : reduceCoord R x₁ = reduceCoord R x₂)
+    (hcoly : reduceCoord R y₁
+      = (reduction R W).toAffine.negY (reduceCoord R x₂) (reduceCoord R y₂)) :
+    1 < valuation K (maximalIdeal R) (W.toAffine.slope x₁ x₂ y₁ y₂) := by
+  obtain ⟨r1x, h1x⟩ := exists_algebraMap_eq_of_valuation_le_one R hx₁
+  obtain ⟨r1y, h1y⟩ := exists_algebraMap_eq_of_valuation_le_one R hy₁
+  obtain ⟨r2x, h2x⟩ := exists_algebraMap_eq_of_valuation_le_one R hx₂
+  obtain ⟨r2y, h2y⟩ := exists_algebraMap_eq_of_valuation_le_one R hy₂
+  have hc1x : reduceCoord R x₁ = residue R r1x := by rw [← h1x, reduceCoord_algebraMap]
+  have hc1y : reduceCoord R y₁ = residue R r1y := by rw [← h1y, reduceCoord_algebraMap]
+  have hc2x : reduceCoord R x₂ = residue R r2x := by rw [← h2x, reduceCoord_algebraMap]
+  have hc2y : reduceCoord R y₂ = residue R r2y := by rw [← h2y, reduceCoord_algebraMap]
+  rw [hc1x, hc2x] at hcolx
+  rw [hc1y, hc2x, hc2y] at hcoly
+  have hns1k : (reduction R W).toAffine.Nonsingular (residue R r1x) (residue R r1y) :=
+    reduced_nonsingular R W (equation_lift R W h₁.1 h1x h1y)
+  by_cases hxK : x₁ = x₂
+  · have hyne : y₁ ≠ W.toAffine.negY x₂ y₂ := fun hy => hxy ⟨hxK, hy⟩
+    have hy12 : y₁ = y₂ := Affine.Y_eq_of_Y_ne h₁.1 h₂.1 hxK hyne
+    have hr12x : r1x = r2x := IsFractionRing.injective R K (by rw [h1x, h2x, hxK])
+    have hr12y : r1y = r2y := IsFractionRing.injective R K (by rw [h1y, h2y, hy12])
+    rw [Affine.slope_of_Y_ne hxK hyne]
+    have hdK : y₁ - W.toAffine.negY x₁ y₁
+        = algebraMap R K (r1y - (integralModel R W).toAffine.negY r1x r1y) := by
+      simp only [Affine.negY, map_sub, map_neg, map_mul, h1x, h1y,
+        integralModel_a₁_eq, integralModel_a₃_eq]
+    have hdbar : residue R (r1y - (integralModel R W).toAffine.negY r1x r1y)
+        = residue R r1y - (reduction R W).toAffine.negY (residue R r1x) (residue R r1y) := by
+      simp only [Affine.negY, map_sub, map_neg, map_mul, reduction_a₁, reduction_a₃]
+    have hdbar0 : residue R r1y
+        - (reduction R W).toAffine.negY (residue R r1x) (residue R r1y) = 0 := by
+      rw [← congrArg (residue R) hr12x, ← congrArg (residue R) hr12y] at hcoly
+      rw [sub_eq_zero]
+      exact hcoly
+    have hvd_le : valuation K (maximalIdeal R) (y₁ - W.toAffine.negY x₁ y₁) ≤ 1 := by
+      rw [hdK]; exact valuation_le_one _ _
+    have hvd_lt : valuation K (maximalIdeal R) (y₁ - W.toAffine.negY x₁ y₁) < 1 := by
+      refine (reduceCoord_eq_zero_iff_lt R hvd_le).mp ?_
+      rw [hdK, reduceCoord_algebraMap, hdbar, hdbar0]
+    have hd0 : y₁ - W.toAffine.negY x₁ y₁ ≠ 0 :=
+      sub_ne_zero.mpr (fun hcon => hyne (hcon.trans (by rw [hxK, hy12])))
+    have hvd0 : valuation K (maximalIdeal R) (y₁ - W.toAffine.negY x₁ y₁) ≠ 0 :=
+      (Valuation.ne_zero_iff _).mpr hd0
+    have hnK : 3 * x₁ ^ 2 + 2 * W.toAffine.a₂ * x₁ + W.toAffine.a₄ - W.toAffine.a₁ * y₁
+        = algebraMap R K (3 * r1x ^ 2 + 2 * (integralModel R W).a₂ * r1x
+            + (integralModel R W).a₄ - (integralModel R W).a₁ * r1y) := by
+      simp only [map_sub, map_add, map_mul, map_pow, map_ofNat, h1x, h1y,
+        integralModel_a₁_eq, integralModel_a₂_eq, integralModel_a₄_eq]
+    have hvn_le : valuation K (maximalIdeal R)
+        (3 * x₁ ^ 2 + 2 * W.toAffine.a₂ * x₁ + W.toAffine.a₄ - W.toAffine.a₁ * y₁) ≤ 1 := by
+      rw [hnK]; exact valuation_le_one _ _
+    have hnbar : residue R (3 * r1x ^ 2 + 2 * (integralModel R W).a₂ * r1x
+            + (integralModel R W).a₄ - (integralModel R W).a₁ * r1y)
+        = 3 * residue R r1x ^ 2 + 2 * (reduction R W).toAffine.a₂ * residue R r1x
+            + (reduction R W).toAffine.a₄ - (reduction R W).toAffine.a₁ * residue R r1y := by
+      simp only [map_sub, map_add, map_mul, map_pow, map_ofNat,
+        reduction_a₁, reduction_a₂, reduction_a₄]
+    have h2tor : 2 * residue R r1y + (reduction R W).toAffine.a₁ * residue R r1x
+        + (reduction R W).toAffine.a₃ = 0 := by
+      have h0 := hdbar0
+      simp only [Affine.negY] at h0
+      linear_combination h0
+    have hnbarne : 3 * residue R r1x ^ 2 + 2 * (reduction R W).toAffine.a₂ * residue R r1x
+        + (reduction R W).toAffine.a₄ - (reduction R W).toAffine.a₁ * residue R r1y ≠ 0 := by
+      obtain ⟨-, hdisj⟩ := (Affine.nonsingular_iff' _ _).mp hns1k
+      rcases hdisj with h | h
+      · intro hcon
+        apply h
+        linear_combination -hcon
+      · exact absurd h2tor h
+    have hvn_one : valuation K (maximalIdeal R)
+        (3 * x₁ ^ 2 + 2 * W.toAffine.a₂ * x₁ + W.toAffine.a₄ - W.toAffine.a₁ * y₁) = 1 := by
+      rcases lt_or_eq_of_le hvn_le with hlt | heq
+      · have h0 := (reduceCoord_eq_zero_iff_lt R hvn_le).mpr hlt
+        rw [hnK, reduceCoord_algebraMap, hnbar] at h0
+        exact absurd h0 hnbarne
+      · exact heq
+    by_contra hle
+    rw [not_lt] at hle
+    have hlt : valuation K (maximalIdeal R) (3 * x₁ ^ 2 + 2 * W.toAffine.a₂ * x₁
+        + W.toAffine.a₄ - W.toAffine.a₁ * y₁) < 1 := by
+      calc valuation K (maximalIdeal R) (3 * x₁ ^ 2 + 2 * W.toAffine.a₂ * x₁
+              + W.toAffine.a₄ - W.toAffine.a₁ * y₁)
+          = valuation K (maximalIdeal R) ((3 * x₁ ^ 2 + 2 * W.toAffine.a₂ * x₁
+              + W.toAffine.a₄ - W.toAffine.a₁ * y₁) / (y₁ - W.toAffine.negY x₁ y₁))
+            * valuation K (maximalIdeal R) (y₁ - W.toAffine.negY x₁ y₁) := by
+            rw [map_div₀, div_mul_cancel₀ _ hvd0]
+        _ ≤ 1 * valuation K (maximalIdeal R) (y₁ - W.toAffine.negY x₁ y₁) :=
+            mul_le_mul_left hle _
+        _ = valuation K (maximalIdeal R) (y₁ - W.toAffine.negY x₁ y₁) := one_mul _
+        _ < 1 := hvd_lt
+    rw [hvn_one] at hlt
+    exact lt_irrefl _ hlt
+  · rw [Affine.slope_of_X_ne hxK]
+    have hdxK : x₁ - x₂ = algebraMap R K (r1x - r2x) := by
+      simp only [map_sub, h1x, h2x]
+    have hvdx_le : valuation K (maximalIdeal R) (x₁ - x₂) ≤ 1 := by
+      rw [hdxK]; exact valuation_le_one _ _
+    have hvdx_lt : valuation K (maximalIdeal R) (x₁ - x₂) < 1 := by
+      refine (reduceCoord_eq_zero_iff_lt R hvdx_le).mp ?_
+      rw [hdxK, reduceCoord_algebraMap, map_sub, sub_eq_zero]
+      exact hcolx
+    have hdx0 : x₁ - x₂ ≠ 0 := sub_ne_zero.mpr hxK
+    have hvdx0 : valuation K (maximalIdeal R) (x₁ - x₂) ≠ 0 :=
+      (Valuation.ne_zero_iff _).mpr hdx0
+    by_cases hybar : residue R r1y = residue R r2y
+    · simp only [Affine.negY] at hcoly
+      have hd₂K : y₁ + y₂ + W.toAffine.a₁ * x₁ + W.toAffine.a₃
+          = algebraMap R K (r1y + r2y + (integralModel R W).a₁ * r1x
+              + (integralModel R W).a₃) := by
+        simp only [map_add, map_mul, h1x, h1y, h2y, integralModel_a₁_eq, integralModel_a₃_eq]
+      have hd₂bar : residue R (r1y + r2y + (integralModel R W).a₁ * r1x
+              + (integralModel R W).a₃)
+          = residue R r1y + residue R r2y
+              + (reduction R W).toAffine.a₁ * residue R r1x
+              + (reduction R W).toAffine.a₃ := by
+        simp only [map_add, map_mul, reduction_a₁, reduction_a₃]
+      have hd₂bar0 : residue R r1y + residue R r2y
+          + (reduction R W).toAffine.a₁ * residue R r1x
+          + (reduction R W).toAffine.a₃ = 0 := by
+        linear_combination hcoly + (reduction R W).toAffine.a₁ * hcolx
+      have hvd₂_le : valuation K (maximalIdeal R)
+          (y₁ + y₂ + W.toAffine.a₁ * x₁ + W.toAffine.a₃) ≤ 1 := by
+        rw [hd₂K]; exact valuation_le_one _ _
+      have hvd₂_lt : valuation K (maximalIdeal R)
+          (y₁ + y₂ + W.toAffine.a₁ * x₁ + W.toAffine.a₃) < 1 := by
+        refine (reduceCoord_eq_zero_iff_lt R hvd₂_le).mp ?_
+        rw [hd₂K, reduceCoord_algebraMap, hd₂bar, hd₂bar0]
+      have hNK : x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.toAffine.a₂ * (x₁ + x₂) + W.toAffine.a₄
+              - W.toAffine.a₁ * y₂
+          = algebraMap R K (r1x ^ 2 + r1x * r2x + r2x ^ 2
+              + (integralModel R W).a₂ * (r1x + r2x) + (integralModel R W).a₄
+              - (integralModel R W).a₁ * r2y) := by
+        simp only [map_sub, map_add, map_mul, map_pow, h1x, h2x, h2y,
+          integralModel_a₁_eq, integralModel_a₂_eq, integralModel_a₄_eq]
+      have hvN_le : valuation K (maximalIdeal R) (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2
+          + W.toAffine.a₂ * (x₁ + x₂) + W.toAffine.a₄ - W.toAffine.a₁ * y₂) ≤ 1 := by
+        rw [hNK]; exact valuation_le_one _ _
+      have hNbar : residue R (r1x ^ 2 + r1x * r2x + r2x ^ 2
+              + (integralModel R W).a₂ * (r1x + r2x) + (integralModel R W).a₄
+              - (integralModel R W).a₁ * r2y)
+          = residue R r1x ^ 2 + residue R r1x * residue R r2x + residue R r2x ^ 2
+              + (reduction R W).toAffine.a₂ * (residue R r1x + residue R r2x)
+              + (reduction R W).toAffine.a₄
+              - (reduction R W).toAffine.a₁ * residue R r2y := by
+        simp only [map_sub, map_add, map_mul, map_pow, reduction_a₁, reduction_a₂, reduction_a₄]
+      have h2tor : 2 * residue R r1y + (reduction R W).toAffine.a₁ * residue R r1x
+          + (reduction R W).toAffine.a₃ = 0 := by
+        linear_combination hd₂bar0 + hybar
+      have hNbarne : residue R r1x ^ 2 + residue R r1x * residue R r2x + residue R r2x ^ 2
+          + (reduction R W).toAffine.a₂ * (residue R r1x + residue R r2x)
+          + (reduction R W).toAffine.a₄
+          - (reduction R W).toAffine.a₁ * residue R r2y ≠ 0 := by
+        obtain ⟨-, hdisj⟩ := (Affine.nonsingular_iff' _ _).mp hns1k
+        rcases hdisj with h | h
+        · intro hcon
+          apply h
+          linear_combination -hcon - (2 * residue R r1x + residue R r2x
+              + (reduction R W).toAffine.a₂) * hcolx + (reduction R W).toAffine.a₁ * hybar
+        · exact absurd h2tor h
+      have hvN_one : valuation K (maximalIdeal R) (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2
+          + W.toAffine.a₂ * (x₁ + x₂) + W.toAffine.a₄ - W.toAffine.a₁ * y₂) = 1 := by
+        rcases lt_or_eq_of_le hvN_le with hlt | heq
+        · have h0 := (reduceCoord_eq_zero_iff_lt R hvN_le).mpr hlt
+          rw [hNK, reduceCoord_algebraMap, hNbar] at h0
+          exact absurd h0 hNbarne
+        · exact heq
+      have hd₂0 : y₁ + y₂ + W.toAffine.a₁ * x₁ + W.toAffine.a₃ ≠ 0 := by
+        intro h0
+        have hid := slope_identity W h₁.1 h₂.1
+        rw [h0, mul_zero] at hid
+        have hN0 := (mul_eq_zero.mp hid.symm).resolve_left hdx0
+        rw [hN0, map_zero] at hvN_one
+        exact zero_ne_one hvN_one
+      have hvd₂0 : valuation K (maximalIdeal R)
+          (y₁ + y₂ + W.toAffine.a₁ * x₁ + W.toAffine.a₃) ≠ 0 :=
+        (Valuation.ne_zero_iff _).mpr hd₂0
+      have hℓeq : (y₁ - y₂) / (x₁ - x₂)
+          = (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.toAffine.a₂ * (x₁ + x₂) + W.toAffine.a₄
+              - W.toAffine.a₁ * y₂)
+            / (y₁ + y₂ + W.toAffine.a₁ * x₁ + W.toAffine.a₃) := by
+        rw [div_eq_div_iff (sub_ne_zero.mpr hxK) hd₂0]
+        linear_combination slope_identity W h₁.1 h₂.1
+      rw [hℓeq]
+      by_contra hle
+      rw [not_lt] at hle
+      have hlt : valuation K (maximalIdeal R) (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2
+          + W.toAffine.a₂ * (x₁ + x₂) + W.toAffine.a₄ - W.toAffine.a₁ * y₂) < 1 := by
+        calc valuation K (maximalIdeal R) (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2
+                + W.toAffine.a₂ * (x₁ + x₂) + W.toAffine.a₄ - W.toAffine.a₁ * y₂)
+            = valuation K (maximalIdeal R) ((x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2
+                + W.toAffine.a₂ * (x₁ + x₂) + W.toAffine.a₄ - W.toAffine.a₁ * y₂)
+                  / (y₁ + y₂ + W.toAffine.a₁ * x₁ + W.toAffine.a₃))
+              * valuation K (maximalIdeal R)
+                  (y₁ + y₂ + W.toAffine.a₁ * x₁ + W.toAffine.a₃) := by
+              rw [map_div₀, div_mul_cancel₀ _ hvd₂0]
+          _ ≤ 1 * valuation K (maximalIdeal R)
+                (y₁ + y₂ + W.toAffine.a₁ * x₁ + W.toAffine.a₃) :=
+              mul_le_mul_left hle _
+          _ = valuation K (maximalIdeal R)
+                (y₁ + y₂ + W.toAffine.a₁ * x₁ + W.toAffine.a₃) := one_mul _
+          _ < 1 := hvd₂_lt
+      rw [hvN_one] at hlt
+      exact lt_irrefl _ hlt
+    · have hdyK : y₁ - y₂ = algebraMap R K (r1y - r2y) := by
+        simp only [map_sub, h1y, h2y]
+      have hvdy_le : valuation K (maximalIdeal R) (y₁ - y₂) ≤ 1 := by
+        rw [hdyK]; exact valuation_le_one _ _
+      have hvdy_one : valuation K (maximalIdeal R) (y₁ - y₂) = 1 := by
+        rcases lt_or_eq_of_le hvdy_le with hlt | heq
+        · have h0 := (reduceCoord_eq_zero_iff_lt R hvdy_le).mpr hlt
+          rw [hdyK, reduceCoord_algebraMap, map_sub, sub_eq_zero] at h0
+          exact absurd h0 hybar
+        · exact heq
+      by_contra hle
+      rw [not_lt] at hle
+      have hlt : valuation K (maximalIdeal R) (y₁ - y₂) < 1 := by
+        calc valuation K (maximalIdeal R) (y₁ - y₂)
+            = valuation K (maximalIdeal R) ((y₁ - y₂) / (x₁ - x₂))
+              * valuation K (maximalIdeal R) (x₁ - x₂) := by
+              rw [map_div₀, div_mul_cancel₀ _ hvdx0]
+          _ ≤ 1 * valuation K (maximalIdeal R) (x₁ - x₂) := mul_le_mul_left hle _
+          _ = valuation K (maximalIdeal R) (x₁ - x₂) := one_mul _
+          _ < 1 := hvdx_lt
+      rw [hvdy_one] at hlt
+      exact lt_irrefl _ hlt
+
+theorem valuation_a₁_le_one : valuation K (maximalIdeal R) W.a₁ ≤ 1 := by
+  rw [← integralModel_a₁_eq R W]; exact valuation_le_one (maximalIdeal R) _
+
+theorem valuation_a₂_le_one : valuation K (maximalIdeal R) W.a₂ ≤ 1 := by
+  rw [← integralModel_a₂_eq R W]; exact valuation_le_one (maximalIdeal R) _
+
+theorem valuation_a₃_le_one : valuation K (maximalIdeal R) W.a₃ ≤ 1 := by
+  rw [← integralModel_a₃_eq R W]; exact valuation_le_one (maximalIdeal R) _
+
+theorem valuation_a₄_le_one : valuation K (maximalIdeal R) W.a₄ ≤ 1 := by
+  rw [← integralModel_a₄_eq R W]; exact valuation_le_one (maximalIdeal R) _
+
+theorem valuation_a₆_le_one : valuation K (maximalIdeal R) W.a₆ ≤ 1 := by
+  rw [← integralModel_a₆_eq R W]; exact valuation_le_one (maximalIdeal R) _
+
+theorem reducePoint_add_int_int [DecidableEq K] [DecidableEq (ResidueField R)]
+    {x₁ y₁ x₂ y₂ : K} (h₁ : W.toAffine.Nonsingular x₁ y₁) (h₂ : W.toAffine.Nonsingular x₂ y₂)
+    (hx₁ : valuation K (maximalIdeal R) x₁ ≤ 1) (hx₂ : valuation K (maximalIdeal R) x₂ ≤ 1) :
+    reducePoint_alt R W (.some x₁ y₁ h₁ + .some x₂ y₂ h₂)
+      = reducePoint_alt R W (.some x₁ y₁ h₁) + reducePoint_alt R W (.some x₂ y₂ h₂) := by
+  have hy₁ : valuation K (maximalIdeal R) y₁ ≤ 1 := valuation_le_one_of_equation R W h₁.1 hx₁
+  have hy₂ : valuation K (maximalIdeal R) y₂ ≤ 1 := valuation_le_one_of_equation R W h₂.1 hx₂
+  obtain ⟨h₁', hrP⟩ := reducePoint_some R W h₁ hx₁ hy₁
+  obtain ⟨h₂', hrQ⟩ := reducePoint_some R W h₂ hx₂ hy₂
+  obtain ⟨r2x, h2x⟩ := exists_algebraMap_eq_of_valuation_le_one R hx₂
+  obtain ⟨r2y, h2y⟩ := exists_algebraMap_eq_of_valuation_le_one R hy₂
+  have hc2x : reduceCoord R x₂ = residue R r2x := by rw [← h2x, reduceCoord_algebraMap]
+  have hc2y : reduceCoord R y₂ = residue R r2y := by rw [← h2y, reduceCoord_algebraMap]
+  by_cases hxy : x₁ = x₂ ∧ y₁ = W.toAffine.negY x₂ y₂
+  · rw [Affine.Point.add_of_Y_eq hxy.1 hxy.2, hrP, hrQ]
+    have hx' : reduceCoord R x₁ = reduceCoord R x₂ := by rw [hxy.1]
+    have hnegK : W.toAffine.negY x₂ y₂
+        = algebraMap R K ((integralModel R W).toAffine.negY r2x r2y) := by
+      simp only [Affine.negY, map_sub, map_neg, map_mul, h2x, h2y,
+        integralModel_a₁_eq, integralModel_a₃_eq]
+    have hnegbar : residue R ((integralModel R W).toAffine.negY r2x r2y)
+        = (reduction R W).toAffine.negY (residue R r2x) (residue R r2y) := by
+      simp only [Affine.negY, map_sub, map_neg, map_mul, reduction_a₁, reduction_a₃]
+    have hy' : reduceCoord R y₁
+        = (reduction R W).toAffine.negY (reduceCoord R x₂) (reduceCoord R y₂) := by
+      rw [hxy.2, hnegK, reduceCoord_algebraMap, hnegbar, ← hc2x, ← hc2y]
+    have h0 : reducePoint_alt R W (0 : W.toAffine.Point) = 0 := rfl
+    rw [h0]
+    exact (Affine.Point.add_of_Y_eq hx' hy').symm
+  · rw [Affine.Point.add_some hxy]
+    by_cases hcol : reduceCoord R x₁ = reduceCoord R x₂ ∧
+        reduceCoord R y₁ = (reduction R W).toAffine.negY (reduceCoord R x₂) (reduceCoord R y₂)
+    · have hℓ := slope_pole R W h₁ h₂ hx₁ hy₁ hx₂ hy₂ hxy hcol.1 hcol.2
+      have hℓ0 : valuation K (maximalIdeal R) (W.toAffine.slope x₁ x₂ y₁ y₂) ≠ 0 :=
+        (zero_lt_one.trans hℓ).ne'
+      have hℓ2 : valuation K (maximalIdeal R) (W.toAffine.slope x₁ x₂ y₁ y₂)
+          < valuation K (maximalIdeal R) ((W.toAffine.slope x₁ x₂ y₁ y₂) ^ 2) := by
+        rw [map_pow, sq]
+        calc valuation K (maximalIdeal R) (W.toAffine.slope x₁ x₂ y₁ y₂)
+            = valuation K (maximalIdeal R) (W.toAffine.slope x₁ x₂ y₁ y₂) * 1 :=
+              (mul_one _).symm
+          _ < valuation K (maximalIdeal R) (W.toAffine.slope x₁ x₂ y₁ y₂)
+              * valuation K (maximalIdeal R) (W.toAffine.slope x₁ x₂ y₁ y₂) :=
+              mul_lt_mul_of_pos_left hℓ (zero_lt_iff.2 hℓ0)
+      have h1lt2 : (1 : Multiplicative ℤ) = 1 := rfl
+      have hone : (1 : WithZero (Multiplicative ℤ))
+          < valuation K (maximalIdeal R) ((W.toAffine.slope x₁ x₂ y₁ y₂) ^ 2) :=
+        hℓ.trans hℓ2
+      have hrest : valuation K (maximalIdeal R)
+          (W.toAffine.a₁ * W.toAffine.slope x₁ x₂ y₁ y₂ + -W.toAffine.a₂ + -x₁ + -x₂)
+          < valuation K (maximalIdeal R) ((W.toAffine.slope x₁ x₂ y₁ y₂) ^ 2) := by
+        have t1 : valuation K (maximalIdeal R)
+            (W.toAffine.a₁ * W.toAffine.slope x₁ x₂ y₁ y₂)
+            < valuation K (maximalIdeal R) ((W.toAffine.slope x₁ x₂ y₁ y₂) ^ 2) := by
+          rw [map_mul]
+          calc valuation K (maximalIdeal R) W.toAffine.a₁
+                * valuation K (maximalIdeal R) (W.toAffine.slope x₁ x₂ y₁ y₂)
+              ≤ 1 * valuation K (maximalIdeal R) (W.toAffine.slope x₁ x₂ y₁ y₂) :=
+                mul_le_mul_left (valuation_a₁_le_one R W) _
+            _ = valuation K (maximalIdeal R) (W.toAffine.slope x₁ x₂ y₁ y₂) := one_mul _
+            _ < _ := hℓ2
+        have t2 : valuation K (maximalIdeal R) (-W.toAffine.a₂)
+            < valuation K (maximalIdeal R) ((W.toAffine.slope x₁ x₂ y₁ y₂) ^ 2) := by
+          rw [Valuation.map_neg]
+          exact lt_of_le_of_lt (valuation_a₂_le_one R W) hone
+        have t3 : valuation K (maximalIdeal R) (-x₁)
+            < valuation K (maximalIdeal R) ((W.toAffine.slope x₁ x₂ y₁ y₂) ^ 2) := by
+          rw [Valuation.map_neg]
+          exact lt_of_le_of_lt hx₁ hone
+        have t4 : valuation K (maximalIdeal R) (-x₂)
+            < valuation K (maximalIdeal R) ((W.toAffine.slope x₁ x₂ y₁ y₂) ^ 2) := by
+          rw [Valuation.map_neg]
+          exact lt_of_le_of_lt hx₂ hone
+        exact Valuation.map_add_lt _ (Valuation.map_add_lt _ (Valuation.map_add_lt _ t1 t2) t3) t4
+      have haddXeq : W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂)
+          = (W.toAffine.slope x₁ x₂ y₁ y₂) ^ 2
+            + (W.toAffine.a₁ * W.toAffine.slope x₁ x₂ y₁ y₂ + -W.toAffine.a₂ + -x₁ + -x₂) := by
+        simp only [Affine.addX]
+        ring
+      have haddX : ¬ valuation K (maximalIdeal R)
+          (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂)) ≤ 1 := by
+        rw [not_le, haddXeq, Valuation.map_add_eq_of_lt_left _ hrest]
+        exact hone
+      rw [hrP, hrQ, Affine.Point.add_of_Y_eq hcol.1 hcol.2]
+      exact (reducePoint_some_eq_zero_iff R W _).mpr haddX
+    · obtain ⟨hvℓ, hℓbar⟩ := slope_spec R W h₁ h₂ hx₁ hy₁ hx₂ hy₂ hxy hcol
+      obtain ⟨r1x, h1x⟩ := exists_algebraMap_eq_of_valuation_le_one R hx₁
+      obtain ⟨r1y, h1y⟩ := exists_algebraMap_eq_of_valuation_le_one R hy₁
+      obtain ⟨rl, hrl⟩ := exists_algebraMap_eq_of_valuation_le_one R hvℓ
+      have hc1x : reduceCoord R x₁ = residue R r1x := by rw [← h1x, reduceCoord_algebraMap]
+      have hcl : reduceCoord R (W.toAffine.slope x₁ x₂ y₁ y₂) = residue R rl := by
+        rw [← hrl, reduceCoord_algebraMap]
+      have hbc : (integralModel R W).map (algebraMap R K) = W :=
+        baseChange_integralModel_eq R W
+      have haddXK : W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂)
+          = algebraMap R K ((integralModel R W).toAffine.addX r1x r2x rl) := by
+        conv_lhs => rw [← hrl, ← h1x, ← h2x, ← hbc]
+        exact Affine.map_addX (algebraMap R K) r1x r2x rl
+      have haddYK : W.toAffine.addY x₁ x₂ y₁ (W.toAffine.slope x₁ x₂ y₁ y₂)
+          = algebraMap R K ((integralModel R W).toAffine.addY r1x r2x r1y rl) := by
+        conv_lhs => rw [← hrl, ← h1x, ← h2x, ← h1y, ← hbc]
+        exact Affine.map_addY (algebraMap R K) r1x r1y r2x rl
+      have hvaddX : valuation K (maximalIdeal R)
+          (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂)) ≤ 1 := by
+        rw [haddXK]; exact valuation_le_one _ _
+      have hvaddY : valuation K (maximalIdeal R)
+          (W.toAffine.addY x₁ x₂ y₁ (W.toAffine.slope x₁ x₂ y₁ y₂)) ≤ 1 := by
+        rw [haddYK]; exact valuation_le_one _ _
+      obtain ⟨h₃', hrS⟩ := reducePoint_some R W (Affine.nonsingular_add h₁ h₂ hxy) hvaddX hvaddY
+      rw [hrS, hrP, hrQ, Affine.Point.add_some hcol]
+      have hbarX : (reduction R W).toAffine.addX (residue R r1x) (residue R r2x)
+            (residue R rl)
+          = residue R ((integralModel R W).toAffine.addX r1x r2x rl) :=
+        Affine.map_addX (residue R) r1x r2x rl
+      have hbarY : (reduction R W).toAffine.addY (residue R r1x) (residue R r2x)
+            (residue R r1y) (residue R rl)
+          = residue R ((integralModel R W).toAffine.addY r1x r2x r1y rl) :=
+        Affine.map_addY (residue R) r1x r1y r2x rl
+      have hc1y : reduceCoord R y₁ = residue R r1y := by rw [← h1y, reduceCoord_algebraMap]
+      simp only [Affine.Point.some.injEq]
+      constructor
+      · rw [haddXK, reduceCoord_algebraMap, ← hbarX, ← hc1x, ← hc2x, ← hcl, hℓbar]
+      · rw [haddYK, reduceCoord_algebraMap, ← hbarY, ← hc1x, ← hc2x, ← hc1y, ← hcl, hℓbar]
+
+end ReducePointAddPort
+
+end WeierstrassCurve
+
+theorem solution
+    (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+    {K : Type*} [Field K] [DecidableEq K] [Algebra R K] [IsFractionRing R K]
+    [DecidableEq (IsLocalRing.ResidueField R)]
+    (W : WeierstrassCurve K) [W.HasGoodReduction R] {x₁ y₁ x₂ y₂ : K}
+    (h₁ : W.toAffine.Nonsingular x₁ y₁) (h₂ : W.toAffine.Nonsingular x₂ y₂)
+    (hx₁ : IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R)
+      x₁ ≤ 1)
+    (hx₂ : IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R)
+      x₂ ≤ 1) :
+    WeierstrassCurve.reducePoint_alt R W (.some x₁ y₁ h₁ + .some x₂ y₂ h₂)
+      = WeierstrassCurve.reducePoint_alt R W (.some x₁ y₁ h₁)
+        + WeierstrassCurve.reducePoint_alt R W (.some x₂ y₂ h₂) :=
+  WeierstrassCurve.ReducePointAddPort.reducePoint_add_int_int R W h₁ h₂ hx₁ hx₂
+
+end S_WeierstrassCurve_reducePoint_some_add_some_of_le_one
+end P2MW
+export P2MW.S_WeierstrassCurve_reducePoint_some_add_some_of_le_one (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.reducePoint_some_add_some_of_le_one
+    (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+    {K : Type*} [Field K] [DecidableEq K] [Algebra R K] [IsFractionRing R K]
+    [DecidableEq (IsLocalRing.ResidueField R)]
+    (W : WeierstrassCurve K) [W.HasGoodReduction R] {x₁ y₁ x₂ y₂ : K}
+    (h₁ : W.toAffine.Nonsingular x₁ y₁) (h₂ : W.toAffine.Nonsingular x₂ y₂)
+    (hx₁ : IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R)
+      x₁ ≤ 1)
+    (hx₂ : IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R)
+      x₂ ≤ 1) :
+    WeierstrassCurve.reducePoint_alt R W (.some x₁ y₁ h₁ + .some x₂ y₂ h₂)
+      = WeierstrassCurve.reducePoint_alt R W (.some x₁ y₁ h₁)
+        + WeierstrassCurve.reducePoint_alt R W (.some x₂ y₂ h₂) :=
+  solution R W h₁ h₂ hx₁ hx₂
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_reducePoint_some_add_some_of_not_le_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_reducePoint_some_add_some_of_not_le_one.lean
new file mode 100644
index 0000000000..27a5d3803b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_reducePoint_some_add_some_of_not_le_one.lean
@@ -0,0 +1,561 @@
+/-
+Based on Prove2Me node WeierstrassCurve.reducePoint_some_add_some_of_not_le_one
+(7fce584d-63e5-5ea3-8bd0-ee004dc655a2) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a24009c7-2af2-561f-b686-cb2fad753f2f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_PointReduction
+
+import Mathlib.AlgebraicGeometry.EllipticCurve.Reduction
+import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+import Mathlib.RingTheory.DedekindDomain.AdicValuation
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_valuation_eq_exp_of_not_le_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_valuation_le_one_of_equation
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_reducePoint_some
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Reduction is unchanged by adding a point of non-integral x
+
+Theorem statement: `WeierstrassCurve.reducePoint_some_add_some_of_not_le_one`
+(`7fce584d-63e5-5ea3-8bd0-ee004dc655a2`), by Claude, 2026-09-05.
+
+Proof: submission `a24009c7-2af2-561f-b686-cb2fad753f2f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a discrete valuation ring which is a domain, and let $K$ be a field that is a fraction
+field of $R$ via a given $R$-algebra structure. Let $W$ be a Weierstrass curve over $K$ admitting
+good reduction over $R$ (the predicate `W.HasGoodReduction R`, which in particular makes $W$ minimal
+over $R$, so that the reduced curve `W.reduction R` over the residue field of $R$ and the map
+[`WeierstrassCurve.reducePoint_alt R W`](def/EllipticCurve_PointReduction.html#L22) are available).
+Write $v$ for the valuation `IsDedekindDomain.HeightOneSpectrum.valuation K` attached to the maximal
+ideal of $R$ viewed as a height-one prime. Let $x_1,y_1,x_2,y_2 \in K$ be such that $(x_1,y_1)$ and
+$(x_2,y_2)$ are nonsingular points of the affine curve associated with $W$, and suppose $v(x_1) \le
+1$ while $v(x_2) \not\le 1$. The assertion is that the reduction of the sum of the two points in the
+group of affine points of $W$ equals the reduction of the first point, where the reduction map sends
+the point at infinity to the point at infinity and sends an affine point $(x,y)$ to the affine point
+with coordinates the residues `reduceCoord R x`, `reduceCoord R y` when $v(x) \le 1$, $v(y) \le 1$
+and those residues give a nonsingular point of `W.reduction R`, and to the point at infinity
+otherwise.
+
+This is the case of additivity of the reduction map in which the second summand lies in the kernel
+of reduction, i.e. the statement that translation by a point of the formal group does not change the
+reduction; classically it is part of the proof that reduction of points is a group homomorphism for
+a curve with good reduction. It is used in the proof of
+[`WeierstrassCurve.reducePoint_add`](thm.html#WeierstrassCurve.reducePoint_add).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_reducePoint_some_add_some_of_not_le_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_reducePoint_some_add_some_of_not_le_one
+
+open WeierstrassCurve IsDiscreteValuationRing IsDedekindDomain.HeightOneSpectrum
+p2m_open "IsLocalRing~maximalIdeal"
+open scoped WeierstrassCurve.Affine
+
+namespace Deep
+
+variable {R : Type*} [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+  {K : Type*} [Field K] [Algebra R K] [IsFractionRing R K]
+
+variable (R) (W : WeierstrassCurve K)
+
+theorem exists_algebraMap_eq_of_valuation_le_one {x : K}
+    (hx : valuation K (maximalIdeal R) x ≤ 1) : ∃ r : R, algebraMap R K r = x :=
+  exists_lift_of_le_one hx
+
+theorem valuation_dichotomy [W.IsIntegral R] {x y : K} (h : W.toAffine.Equation x y)
+    (hx : ¬ valuation K (maximalIdeal R) x ≤ 1) :
+    ∃ s : ℕ, 0 < s ∧
+      valuation K (maximalIdeal R) x = WithZero.exp (2 * (s : ℤ)) ∧
+      valuation K (maximalIdeal R) y = WithZero.exp (3 * (s : ℤ)) :=
+  WeierstrassCurve.exists_valuation_eq_exp_of_not_le_one R W h hx
+
+variable [W.HasGoodReduction R]
+
+private theorem _root_.Deep.reducePoint_some {x y : K} (h : W.toAffine.Nonsingular x y)
+    (hx : valuation K (maximalIdeal R) x ≤ 1) (hy : valuation K (maximalIdeal R) y ≤ 1) :
+    ∃ h', reducePoint_alt R W (.some x y h) = .some (reduceCoord R x) (reduceCoord R y) h' :=
+  WeierstrassCurve.reducePoint_some R W h hx hy
+
+p2m_export "Deep" "reducePoint_some"
+
+theorem valuation_y_le_one {x y : K} (hE : W.toAffine.Equation x y)
+    (hx : valuation K (maximalIdeal R) x ≤ 1) :
+    valuation K (maximalIdeal R) y ≤ 1 :=
+  WeierstrassCurve.valuation_le_one_of_equation R W hE hx
+
+theorem reduceCoord_algebraMap (r : R) :
+    reduceCoord R (algebraMap R K r) = residue R r := by
+  have hex : ∃ r' : R, algebraMap R K r' = algebraMap R K r := ⟨r, rfl⟩
+  rw [reduceCoord, dite_eq_left hex]
+  exact congrArg _ (IsFractionRing.injective R K hex.choose_spec)
+
+theorem reduceCoord_eq_zero_iff_lt {x : K}
+    (hx : valuation K (maximalIdeal R) x ≤ 1) :
+    reduceCoord R x = 0 ↔ valuation K (maximalIdeal R) x < 1 := by
+  obtain ⟨r, hr⟩ := exists_algebraMap_eq_of_valuation_le_one R hx
+  rw [← hr, reduceCoord_algebraMap, residue_eq_zero_iff]
+  exact (valuation_lt_one_iff_mem (K := K) (maximalIdeal R) r).symm
+
+theorem reduction_a₁ : (reduction R W).a₁ = residue R (integralModel R W).a₁ := by
+  simp only [reduction, map_a₁]
+
+theorem reduction_a₂ : (reduction R W).a₂ = residue R (integralModel R W).a₂ := by
+  simp only [reduction, map_a₂]
+
+theorem reduction_a₃ : (reduction R W).a₃ = residue R (integralModel R W).a₃ := by
+  simp only [reduction, map_a₃]
+
+theorem reduction_a₄ : (reduction R W).a₄ = residue R (integralModel R W).a₄ := by
+  simp only [reduction, map_a₄]
+
+theorem reduction_a₆ : (reduction R W).a₆ = residue R (integralModel R W).a₆ := by
+  simp only [reduction, map_a₆]
+
+theorem equation_lift {x y : K} (h : W.toAffine.Equation x y) {rx ry : R}
+    (hrx : algebraMap R K rx = x) (hry : algebraMap R K ry = y) :
+    (integralModel R W).toAffine.Equation rx ry := by
+  have heqK : ((integralModel R W).map (algebraMap R K)).toAffine.Equation
+      (algebraMap R K rx) (algebraMap R K ry) := by
+    have hbc : (integralModel R W).map (algebraMap R K) = W := baseChange_integralModel_eq R W
+    rw [hbc, hrx, hry]
+    exact h
+  exact (Affine.map_equation _ (IsFractionRing.injective R K) _ _).mp heqK
+
+theorem reduced_nonsingular {rx ry : R} (h : (integralModel R W).toAffine.Equation rx ry) :
+    (reduction R W).toAffine.Nonsingular (residue R rx) (residue R ry) := by
+  have hell : (reduction R W).IsElliptic :=
+    (hasGoodReduction_iff_isElliptic_reduction R).mp ‹W.HasGoodReduction R›
+  have heqk : (reduction R W).toAffine.Equation (residue R rx) (residue R ry) :=
+    h.map (residue R)
+  exact Affine.equation_iff_nonsingular.mp heqk
+
+theorem slope_identity {x₁ y₁ x₂ y₂ : K} (h₁ : W.toAffine.Equation x₁ y₁)
+    (h₂ : W.toAffine.Equation x₂ y₂) :
+    (y₁ - y₂) * (y₁ + y₂ + W.a₁ * x₁ + W.a₃)
+      = (x₁ - x₂) * (x₁ ^ 2 + x₁ * x₂ + x₂ ^ 2 + W.a₂ * (x₁ + x₂) + W.a₄ - W.a₁ * y₂) := by
+  rw [Affine.equation_iff] at h₁ h₂
+  linear_combination h₁ - h₂
+
+theorem valuation_a₁_le_one : valuation K (maximalIdeal R) W.a₁ ≤ 1 := by
+  rw [← integralModel_a₁_eq R W]; exact valuation_le_one (maximalIdeal R) _
+
+theorem valuation_a₂_le_one : valuation K (maximalIdeal R) W.a₂ ≤ 1 := by
+  rw [← integralModel_a₂_eq R W]; exact valuation_le_one (maximalIdeal R) _
+
+theorem valuation_a₃_le_one : valuation K (maximalIdeal R) W.a₃ ≤ 1 := by
+  rw [← integralModel_a₃_eq R W]; exact valuation_le_one (maximalIdeal R) _
+
+theorem valuation_a₄_le_one : valuation K (maximalIdeal R) W.a₄ ≤ 1 := by
+  rw [← integralModel_a₄_eq R W]; exact valuation_le_one (maximalIdeal R) _
+
+theorem valuation_a₆_le_one : valuation K (maximalIdeal R) W.a₆ ≤ 1 := by
+  rw [← integralModel_a₆_eq R W]; exact valuation_le_one (maximalIdeal R) _
+
+theorem le_exp_sub {a b : ℤ} {A : WithZero (Multiplicative ℤ)}
+    (h : WithZero.exp a * A ≤ WithZero.exp b) : A ≤ WithZero.exp (b - a) := by
+  have h2 := mul_le_mul_right h (WithZero.exp (-a))
+  rw [← mul_assoc, ← WithZero.exp_add, neg_add_cancel, WithZero.exp_zero, one_mul,
+    ← WithZero.exp_add] at h2
+  rw [show (b - a : ℤ) = -a + b by omega]
+  exact h2
+
+theorem reducePoint_add_int_pole [DecidableEq K]
+    {x₁ y₁ x₂ y₂ : K} (h₁ : W.toAffine.Nonsingular x₁ y₁) (h₂ : W.toAffine.Nonsingular x₂ y₂)
+    (hx₁ : valuation K (maximalIdeal R) x₁ ≤ 1) (hx₂ : ¬ valuation K (maximalIdeal R) x₂ ≤ 1) :
+    reducePoint_alt R W (.some x₁ y₁ h₁ + .some x₂ y₂ h₂)
+      = reducePoint_alt R W (.some x₁ y₁ h₁) := by
+  classical
+  obtain ⟨s, hs, hvx₂, hvy₂⟩ := valuation_dichotomy R W h₂.1 hx₂
+  have hy₁ : valuation K (maximalIdeal R) y₁ ≤ 1 := valuation_y_le_one R W h₁.1 hx₁
+  have hxne : x₁ ≠ x₂ := fun h => hx₂ (h ▸ hx₁)
+  have hxy : ¬(x₁ = x₂ ∧ y₁ = W.toAffine.negY x₂ y₂) := fun hc => hxne hc.1
+  rw [Affine.Point.add_some hxy]
+  have h1lt2s : (1 : WithZero (Multiplicative ℤ)) < WithZero.exp (2 * (s : ℤ)) := by
+    rw [← WithZero.exp_zero]; exact WithZero.exp_lt_exp.mpr (by omega)
+  have h1lt3s : (1 : WithZero (Multiplicative ℤ)) < WithZero.exp (3 * (s : ℤ)) := by
+    rw [← WithZero.exp_zero]; exact WithZero.exp_lt_exp.mpr (by omega)
+  have hnegs1 : WithZero.exp (-(s : ℤ)) < 1 := by
+    rw [← WithZero.exp_zero]; exact WithZero.exp_lt_exp.mpr (by omega)
+  have hvdx : valuation K (maximalIdeal R) (x₁ - x₂) = WithZero.exp (2 * (s : ℤ)) := by
+    rw [sub_eq_add_neg, Valuation.map_add_eq_of_lt_right _
+      (by rw [Valuation.map_neg, hvx₂]; exact lt_of_le_of_lt hx₁ h1lt2s),
+      Valuation.map_neg, hvx₂]
+  have hvdy : valuation K (maximalIdeal R) (y₁ - y₂) = WithZero.exp (3 * (s : ℤ)) := by
+    rw [sub_eq_add_neg, Valuation.map_add_eq_of_lt_right _
+      (by rw [Valuation.map_neg, hvy₂]; exact lt_of_le_of_lt hy₁ h1lt3s),
+      Valuation.map_neg, hvy₂]
+  have hpow2 : valuation K (maximalIdeal R) ((x₁ - x₂) ^ 2)
+      = WithZero.exp (4 * (s : ℤ)) := by
+    rw [map_pow, hvdx, ← WithZero.exp_nsmul, nsmul_eq_mul]
+    congr 1
+    push_cast
+    ring
+  have hpow3 : valuation K (maximalIdeal R) ((x₁ - x₂) ^ 3)
+      = WithZero.exp (6 * (s : ℤ)) := by
+    rw [map_pow, hvdx, ← WithZero.exp_nsmul, nsmul_eq_mul]
+    congr 1
+    push_cast
+    ring
+  have hℓx : W.toAffine.slope x₁ x₂ y₁ y₂ * (x₁ - x₂) = y₁ - y₂ := by
+    rw [Affine.slope_of_X_ne hxne, div_mul_cancel₀ _ (sub_ne_zero.mpr hxne)]
+  have e₁ := h₁.1
+  have e₂ := h₂.1
+  rw [Affine.equation_iff] at e₁ e₂
+  obtain ⟨r1x, h1x⟩ := exists_algebraMap_eq_of_valuation_le_one R hx₁
+  obtain ⟨r1y, h1y⟩ := exists_algebraMap_eq_of_valuation_le_one R hy₁
+  have hAK : -x₁ ^ 3 + W.toAffine.a₄ * x₁ + 2 * W.toAffine.a₆ + -(W.toAffine.a₃ * y₁)
+      = algebraMap R K (-r1x ^ 3 + (integralModel R W).a₄ * r1x
+          + 2 * (integralModel R W).a₆ + -((integralModel R W).a₃ * r1y)) := by
+    simp only [map_add, map_neg, map_mul, map_pow, map_ofNat, h1x, h1y,
+      integralModel_a₃_eq, integralModel_a₄_eq, integralModel_a₆_eq]
+  have hvA : valuation K (maximalIdeal R)
+      (-x₁ ^ 3 + W.toAffine.a₄ * x₁ + 2 * W.toAffine.a₆ + -(W.toAffine.a₃ * y₁)) ≤ 1 := by
+    rw [hAK]; exact valuation_le_one _ _
+  have hnK : 3 * x₁ ^ 2 + 2 * W.toAffine.a₂ * x₁ + W.toAffine.a₄ - W.toAffine.a₁ * y₁
+      = algebraMap R K (3 * r1x ^ 2 + 2 * (integralModel R W).a₂ * r1x
+          + (integralModel R W).a₄ - (integralModel R W).a₁ * r1y) := by
+    simp only [map_sub, map_add, map_mul, map_pow, map_ofNat, h1x, h1y,
+      integralModel_a₁_eq, integralModel_a₂_eq, integralModel_a₄_eq]
+  have hvn : valuation K (maximalIdeal R)
+      (3 * x₁ ^ 2 + 2 * W.toAffine.a₂ * x₁ + W.toAffine.a₄ - W.toAffine.a₁ * y₁) ≤ 1 := by
+    rw [hnK]; exact valuation_le_one _ _
+  have hdK : 2 * y₁ + W.toAffine.a₁ * x₁ + W.toAffine.a₃
+      = algebraMap R K (2 * r1y + (integralModel R W).a₁ * r1x
+          + (integralModel R W).a₃) := by
+    simp only [map_add, map_mul, map_ofNat, h1x, h1y,
+      integralModel_a₁_eq, integralModel_a₃_eq]
+  have hvd : valuation K (maximalIdeal R)
+      (2 * y₁ + W.toAffine.a₁ * x₁ + W.toAffine.a₃) ≤ 1 := by
+    rw [hdK]; exact valuation_le_one _ _
+  have hM : (x₁ - x₂) ^ 2
+        * (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₁)
+      = (-x₁ ^ 3 + W.toAffine.a₄ * x₁ + 2 * W.toAffine.a₆ + -(W.toAffine.a₃ * y₁))
+        + (3 * x₁ ^ 2 + 2 * W.toAffine.a₂ * x₁ + W.toAffine.a₄ - W.toAffine.a₁ * y₁) * x₂
+        + -((2 * y₁ + W.toAffine.a₁ * x₁ + W.toAffine.a₃) * y₂) := by
+    have hexp : (x₁ - x₂) ^ 2
+          * (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₁)
+        = (W.toAffine.slope x₁ x₂ y₁ y₂ * (x₁ - x₂)) ^ 2
+          + W.toAffine.a₁ * (W.toAffine.slope x₁ x₂ y₁ y₂ * (x₁ - x₂)) * (x₁ - x₂)
+          - (W.toAffine.a₂ + 2 * x₁ + x₂) * (x₁ - x₂) ^ 2 := by
+      simp only [Affine.addX]
+      ring
+    rw [hexp, hℓx]
+    linear_combination e₁ + e₂
+  have hvM : valuation K (maximalIdeal R)
+      ((-x₁ ^ 3 + W.toAffine.a₄ * x₁ + 2 * W.toAffine.a₆ + -(W.toAffine.a₃ * y₁))
+        + (3 * x₁ ^ 2 + 2 * W.toAffine.a₂ * x₁ + W.toAffine.a₄ - W.toAffine.a₁ * y₁) * x₂
+        + -((2 * y₁ + W.toAffine.a₁ * x₁ + W.toAffine.a₃) * y₂))
+      ≤ WithZero.exp (3 * (s : ℤ)) := by
+    refine Valuation.map_add_le _ (Valuation.map_add_le _ ?_ ?_) ?_
+    · exact le_trans hvA (le_of_lt h1lt3s)
+    · rw [map_mul]
+      calc valuation K (maximalIdeal R)
+            (3 * x₁ ^ 2 + 2 * W.toAffine.a₂ * x₁ + W.toAffine.a₄ - W.toAffine.a₁ * y₁)
+            * valuation K (maximalIdeal R) x₂
+          ≤ 1 * WithZero.exp (2 * (s : ℤ)) := mul_le_mul' hvn (le_of_eq hvx₂)
+        _ = WithZero.exp (2 * (s : ℤ)) := one_mul _
+        _ ≤ WithZero.exp (3 * (s : ℤ)) := WithZero.exp_le_exp.mpr (by omega)
+    · rw [Valuation.map_neg, map_mul]
+      calc valuation K (maximalIdeal R) (2 * y₁ + W.toAffine.a₁ * x₁ + W.toAffine.a₃)
+            * valuation K (maximalIdeal R) y₂
+          ≤ 1 * WithZero.exp (3 * (s : ℤ)) := mul_le_mul' hvd (le_of_eq hvy₂)
+        _ = WithZero.exp (3 * (s : ℤ)) := one_mul _
+  have hv31 : valuation K (maximalIdeal R)
+      (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₁)
+      ≤ WithZero.exp (-(s : ℤ)) := by
+    have h0 : WithZero.exp (4 * (s : ℤ))
+        * valuation K (maximalIdeal R)
+            (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₁)
+        ≤ WithZero.exp (3 * (s : ℤ)) := by
+      rw [← hpow2, ← map_mul, hM]
+      exact hvM
+    have h1 := le_exp_sub h0
+    rw [show (3 * (s : ℤ) - 4 * (s : ℤ)) = -(s : ℤ) by omega] at h1
+    exact h1
+  have hvx₃ : valuation K (maximalIdeal R)
+      (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂)) ≤ 1 := by
+    rw [← sub_add_cancel (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂)) x₁]
+    exact Valuation.map_add_le _ (le_trans hv31 (le_of_lt hnegs1)) hx₁
+  have hM₂ : (x₁ - x₂) ^ 3
+        * (W.toAffine.slope x₁ x₂ y₁ y₂
+            * (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₁)
+          + (2 * y₁ + W.toAffine.a₁ * x₁ + W.toAffine.a₃))
+      = (-x₁ ^ 3 + W.toAffine.a₄ * x₁ + 2 * W.toAffine.a₆ + -(W.toAffine.a₃ * y₁))
+          * (y₁ - y₂)
+        + (3 * x₁ ^ 2 + 2 * W.toAffine.a₂ * x₁ + W.toAffine.a₄ - W.toAffine.a₁ * y₁)
+          * (x₂ * (y₁ - y₂))
+        + -((2 * y₁ + W.toAffine.a₁ * x₁ + W.toAffine.a₃) * (y₁ * y₂))
+        + (2 * y₁ + W.toAffine.a₁ * x₁ + W.toAffine.a₃)
+          * (W.toAffine.a₂ * x₂ ^ 2 + W.toAffine.a₄ * x₂ + W.toAffine.a₆
+            + -(W.toAffine.a₁ * (x₂ * y₂)) + -(W.toAffine.a₃ * y₂))
+        + (2 * y₁ + W.toAffine.a₁ * x₁ + W.toAffine.a₃)
+          * (x₁ ^ 3 + -(3 * (x₁ ^ 2 * x₂)) + 3 * (x₁ * x₂ ^ 2)) := by
+    have h0 : (x₁ - x₂) ^ 3
+          * (W.toAffine.slope x₁ x₂ y₁ y₂
+              * (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₁)
+            + (2 * y₁ + W.toAffine.a₁ * x₁ + W.toAffine.a₃))
+        = (W.toAffine.slope x₁ x₂ y₁ y₂ * (x₁ - x₂))
+            * ((x₁ - x₂) ^ 2
+              * (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₁))
+          + (2 * y₁ + W.toAffine.a₁ * x₁ + W.toAffine.a₃) * (x₁ - x₂) ^ 3 := by
+      ring
+    rw [h0, hℓx, hM]
+    linear_combination (2 * y₁ + W.toAffine.a₁ * x₁ + W.toAffine.a₃) * e₂
+  have hvM₂ : valuation K (maximalIdeal R)
+      ((-x₁ ^ 3 + W.toAffine.a₄ * x₁ + 2 * W.toAffine.a₆ + -(W.toAffine.a₃ * y₁))
+          * (y₁ - y₂)
+        + (3 * x₁ ^ 2 + 2 * W.toAffine.a₂ * x₁ + W.toAffine.a₄ - W.toAffine.a₁ * y₁)
+          * (x₂ * (y₁ - y₂))
+        + -((2 * y₁ + W.toAffine.a₁ * x₁ + W.toAffine.a₃) * (y₁ * y₂))
+        + (2 * y₁ + W.toAffine.a₁ * x₁ + W.toAffine.a₃)
+          * (W.toAffine.a₂ * x₂ ^ 2 + W.toAffine.a₄ * x₂ + W.toAffine.a₆
+            + -(W.toAffine.a₁ * (x₂ * y₂)) + -(W.toAffine.a₃ * y₂))
+        + (2 * y₁ + W.toAffine.a₁ * x₁ + W.toAffine.a₃)
+          * (x₁ ^ 3 + -(3 * (x₁ ^ 2 * x₂)) + 3 * (x₁ * x₂ ^ 2)))
+      ≤ WithZero.exp (5 * (s : ℤ)) := by
+    have hx₂2 : valuation K (maximalIdeal R) (x₂ ^ 2)
+        = WithZero.exp (4 * (s : ℤ)) := by
+      rw [map_pow, hvx₂, ← WithZero.exp_nsmul, nsmul_eq_mul]
+      congr 1
+      push_cast
+      ring
+    refine Valuation.map_add_le _ (Valuation.map_add_le _ (Valuation.map_add_le _
+      (Valuation.map_add_le _ ?_ ?_) ?_) ?_) ?_
+    · rw [map_mul]
+      calc valuation K (maximalIdeal R)
+            (-x₁ ^ 3 + W.toAffine.a₄ * x₁ + 2 * W.toAffine.a₆ + -(W.toAffine.a₃ * y₁))
+            * valuation K (maximalIdeal R) (y₁ - y₂)
+          ≤ 1 * WithZero.exp (3 * (s : ℤ)) := mul_le_mul' hvA (le_of_eq hvdy)
+        _ = WithZero.exp (3 * (s : ℤ)) := one_mul _
+        _ ≤ WithZero.exp (5 * (s : ℤ)) := WithZero.exp_le_exp.mpr (by omega)
+    · rw [map_mul, map_mul]
+      calc valuation K (maximalIdeal R)
+            (3 * x₁ ^ 2 + 2 * W.toAffine.a₂ * x₁ + W.toAffine.a₄ - W.toAffine.a₁ * y₁)
+            * (valuation K (maximalIdeal R) x₂ * valuation K (maximalIdeal R) (y₁ - y₂))
+          ≤ 1 * (WithZero.exp (2 * (s : ℤ)) * WithZero.exp (3 * (s : ℤ))) :=
+            mul_le_mul' hvn (mul_le_mul' (le_of_eq hvx₂) (le_of_eq hvdy))
+        _ = WithZero.exp (5 * (s : ℤ)) := by
+            rw [one_mul, ← WithZero.exp_add]
+            congr 1
+            ring
+    · rw [Valuation.map_neg, map_mul, map_mul]
+      calc valuation K (maximalIdeal R) (2 * y₁ + W.toAffine.a₁ * x₁ + W.toAffine.a₃)
+            * (valuation K (maximalIdeal R) y₁ * valuation K (maximalIdeal R) y₂)
+          ≤ 1 * (1 * WithZero.exp (3 * (s : ℤ))) :=
+            mul_le_mul' hvd (mul_le_mul' hy₁ (le_of_eq hvy₂))
+        _ = WithZero.exp (3 * (s : ℤ)) := by rw [one_mul, one_mul]
+        _ ≤ WithZero.exp (5 * (s : ℤ)) := WithZero.exp_le_exp.mpr (by omega)
+    · rw [map_mul]
+      have hinner : valuation K (maximalIdeal R)
+          (W.toAffine.a₂ * x₂ ^ 2 + W.toAffine.a₄ * x₂ + W.toAffine.a₆
+            + -(W.toAffine.a₁ * (x₂ * y₂)) + -(W.toAffine.a₃ * y₂))
+          ≤ WithZero.exp (5 * (s : ℤ)) := by
+        refine Valuation.map_add_le _ (Valuation.map_add_le _ (Valuation.map_add_le _
+          (Valuation.map_add_le _ ?_ ?_) ?_) ?_) ?_
+        · rw [map_mul]
+          calc valuation K (maximalIdeal R) W.toAffine.a₂
+                * valuation K (maximalIdeal R) (x₂ ^ 2)
+              ≤ 1 * WithZero.exp (4 * (s : ℤ)) :=
+                mul_le_mul' (valuation_a₂_le_one R W) (le_of_eq hx₂2)
+            _ = WithZero.exp (4 * (s : ℤ)) := one_mul _
+            _ ≤ WithZero.exp (5 * (s : ℤ)) := WithZero.exp_le_exp.mpr (by omega)
+        · rw [map_mul]
+          calc valuation K (maximalIdeal R) W.toAffine.a₄
+                * valuation K (maximalIdeal R) x₂
+              ≤ 1 * WithZero.exp (2 * (s : ℤ)) :=
+                mul_le_mul' (valuation_a₄_le_one R W) (le_of_eq hvx₂)
+            _ = WithZero.exp (2 * (s : ℤ)) := one_mul _
+            _ ≤ WithZero.exp (5 * (s : ℤ)) := WithZero.exp_le_exp.mpr (by omega)
+        · exact le_trans (valuation_a₆_le_one R W)
+            (le_of_lt (by rw [← WithZero.exp_zero]; exact WithZero.exp_lt_exp.mpr (by omega)))
+        · rw [Valuation.map_neg, map_mul, map_mul]
+          calc valuation K (maximalIdeal R) W.toAffine.a₁
+                * (valuation K (maximalIdeal R) x₂ * valuation K (maximalIdeal R) y₂)
+              ≤ 1 * (WithZero.exp (2 * (s : ℤ)) * WithZero.exp (3 * (s : ℤ))) :=
+                mul_le_mul' (valuation_a₁_le_one R W)
+                  (mul_le_mul' (le_of_eq hvx₂) (le_of_eq hvy₂))
+            _ = WithZero.exp (5 * (s : ℤ)) := by
+                rw [one_mul, ← WithZero.exp_add]
+                congr 1
+                ring
+        · rw [Valuation.map_neg, map_mul]
+          calc valuation K (maximalIdeal R) W.toAffine.a₃
+                * valuation K (maximalIdeal R) y₂
+              ≤ 1 * WithZero.exp (3 * (s : ℤ)) :=
+                mul_le_mul' (valuation_a₃_le_one R W) (le_of_eq hvy₂)
+            _ = WithZero.exp (3 * (s : ℤ)) := one_mul _
+            _ ≤ WithZero.exp (5 * (s : ℤ)) := WithZero.exp_le_exp.mpr (by omega)
+      calc valuation K (maximalIdeal R) (2 * y₁ + W.toAffine.a₁ * x₁ + W.toAffine.a₃)
+            * valuation K (maximalIdeal R)
+              (W.toAffine.a₂ * x₂ ^ 2 + W.toAffine.a₄ * x₂ + W.toAffine.a₆
+                + -(W.toAffine.a₁ * (x₂ * y₂)) + -(W.toAffine.a₃ * y₂))
+          ≤ 1 * WithZero.exp (5 * (s : ℤ)) := mul_le_mul' hvd hinner
+        _ = WithZero.exp (5 * (s : ℤ)) := one_mul _
+    · rw [map_mul]
+      have hinner : valuation K (maximalIdeal R)
+          (x₁ ^ 3 + -(3 * (x₁ ^ 2 * x₂)) + 3 * (x₁ * x₂ ^ 2))
+          ≤ WithZero.exp (4 * (s : ℤ)) := by
+        have h3le : valuation K (maximalIdeal R) (3 : K) ≤ 1 := by
+          rw [show ((3 : K)) = algebraMap R K 3 from (map_ofNat _ 3).symm]
+          exact valuation_le_one _ _
+        have hx₂2 : valuation K (maximalIdeal R) (x₂ ^ 2)
+            = WithZero.exp (4 * (s : ℤ)) := by
+          rw [map_pow, hvx₂, ← WithZero.exp_nsmul, nsmul_eq_mul]
+          congr 1
+          push_cast
+          ring
+        refine Valuation.map_add_le _ (Valuation.map_add_le _ ?_ ?_) ?_
+        · rw [map_pow]
+          exact le_trans (pow_le_one' hx₁ 3)
+            (le_of_lt (by rw [← WithZero.exp_zero]; exact WithZero.exp_lt_exp.mpr (by omega)))
+        · rw [Valuation.map_neg, map_mul, map_mul, map_pow]
+          calc valuation K (maximalIdeal R) (3 : K)
+                * (valuation K (maximalIdeal R) x₁ ^ 2 * valuation K (maximalIdeal R) x₂)
+              ≤ 1 * (1 * WithZero.exp (2 * (s : ℤ))) :=
+                mul_le_mul' h3le (mul_le_mul' (pow_le_one' hx₁ 2) (le_of_eq hvx₂))
+            _ = WithZero.exp (2 * (s : ℤ)) := by rw [one_mul, one_mul]
+            _ ≤ WithZero.exp (4 * (s : ℤ)) := WithZero.exp_le_exp.mpr (by omega)
+        · rw [map_mul, map_mul]
+          calc valuation K (maximalIdeal R) (3 : K)
+                * (valuation K (maximalIdeal R) x₁ * valuation K (maximalIdeal R) (x₂ ^ 2))
+              ≤ 1 * (1 * WithZero.exp (4 * (s : ℤ))) :=
+                mul_le_mul' h3le (mul_le_mul' hx₁ (le_of_eq hx₂2))
+            _ = WithZero.exp (4 * (s : ℤ)) := by rw [one_mul, one_mul]
+      calc valuation K (maximalIdeal R) (2 * y₁ + W.toAffine.a₁ * x₁ + W.toAffine.a₃)
+            * valuation K (maximalIdeal R)
+              (x₁ ^ 3 + -(3 * (x₁ ^ 2 * x₂)) + 3 * (x₁ * x₂ ^ 2))
+          ≤ 1 * WithZero.exp (4 * (s : ℤ)) := mul_le_mul' hvd hinner
+        _ = WithZero.exp (4 * (s : ℤ)) := one_mul _
+        _ ≤ WithZero.exp (5 * (s : ℤ)) := WithZero.exp_le_exp.mpr (by omega)
+  have hvly : valuation K (maximalIdeal R)
+      (W.toAffine.slope x₁ x₂ y₁ y₂
+          * (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₁)
+        + (2 * y₁ + W.toAffine.a₁ * x₁ + W.toAffine.a₃))
+      ≤ WithZero.exp (-(s : ℤ)) := by
+    have h0 : WithZero.exp (6 * (s : ℤ))
+        * valuation K (maximalIdeal R)
+            (W.toAffine.slope x₁ x₂ y₁ y₂
+                * (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₁)
+              + (2 * y₁ + W.toAffine.a₁ * x₁ + W.toAffine.a₃))
+        ≤ WithZero.exp (5 * (s : ℤ)) := by
+      rw [← hpow3, ← map_mul, hM₂]
+      exact hvM₂
+    have h1 := le_exp_sub h0
+    rw [show (5 * (s : ℤ) - 6 * (s : ℤ)) = -(s : ℤ) by omega] at h1
+    exact h1
+  have hy₃eq : W.toAffine.addY x₁ x₂ y₁ (W.toAffine.slope x₁ x₂ y₁ y₂) - y₁
+      = -(W.toAffine.slope x₁ x₂ y₁ y₂
+            * (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₁)
+          + (2 * y₁ + W.toAffine.a₁ * x₁ + W.toAffine.a₃))
+        + -(W.toAffine.a₁
+            * (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₁)) := by
+    simp only [Affine.addY, Affine.negAddY, Affine.negY]
+    ring
+  have hvy₃1 : valuation K (maximalIdeal R)
+      (W.toAffine.addY x₁ x₂ y₁ (W.toAffine.slope x₁ x₂ y₁ y₂) - y₁)
+      ≤ WithZero.exp (-(s : ℤ)) := by
+    rw [hy₃eq]
+    refine Valuation.map_add_le _ ?_ ?_
+    · rw [Valuation.map_neg]
+      exact hvly
+    · rw [Valuation.map_neg, map_mul]
+      calc valuation K (maximalIdeal R) W.toAffine.a₁
+            * valuation K (maximalIdeal R)
+                (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₁)
+          ≤ 1 * WithZero.exp (-(s : ℤ)) := mul_le_mul' (valuation_a₁_le_one R W) hv31
+        _ = WithZero.exp (-(s : ℤ)) := one_mul _
+  have hvy₃ : valuation K (maximalIdeal R)
+      (W.toAffine.addY x₁ x₂ y₁ (W.toAffine.slope x₁ x₂ y₁ y₂)) ≤ 1 := by
+    rw [← sub_add_cancel (W.toAffine.addY x₁ x₂ y₁ (W.toAffine.slope x₁ x₂ y₁ y₂)) y₁]
+    exact Valuation.map_add_le _ (le_trans hvy₃1 (le_of_lt hnegs1)) hy₁
+  obtain ⟨h₃', hrS⟩ := reducePoint_some R W (Affine.nonsingular_add h₁ h₂ hxy) hvx₃ hvy₃
+  obtain ⟨h₁', hrP⟩ := reducePoint_some R W h₁ hx₁ hy₁
+  rw [hrS, hrP]
+  obtain ⟨r3x, h3x⟩ := exists_algebraMap_eq_of_valuation_le_one R hvx₃
+  obtain ⟨r3y, h3y⟩ := exists_algebraMap_eq_of_valuation_le_one R hvy₃
+  simp only [Affine.Point.some.injEq]
+  constructor
+  · have hsubK : W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₁
+        = algebraMap R K (r3x - r1x) := by
+      simp only [map_sub, h3x, h1x]
+    have hsub_le : valuation K (maximalIdeal R)
+        (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₁) ≤ 1 := by
+      rw [hsubK]; exact valuation_le_one _ _
+    have h0 : reduceCoord R
+        (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) - x₁) = 0 :=
+      (reduceCoord_eq_zero_iff_lt R hsub_le).mpr (lt_of_le_of_lt hv31 hnegs1)
+    rw [hsubK, reduceCoord_algebraMap, map_sub, sub_eq_zero] at h0
+    rw [← h3x, ← h1x, reduceCoord_algebraMap, reduceCoord_algebraMap]
+    exact h0
+  · have hsubK : W.toAffine.addY x₁ x₂ y₁ (W.toAffine.slope x₁ x₂ y₁ y₂) - y₁
+        = algebraMap R K (r3y - r1y) := by
+      simp only [map_sub, h3y, h1y]
+    have hsub_le : valuation K (maximalIdeal R)
+        (W.toAffine.addY x₁ x₂ y₁ (W.toAffine.slope x₁ x₂ y₁ y₂) - y₁) ≤ 1 := by
+      rw [hsubK]; exact valuation_le_one _ _
+    have h0 : reduceCoord R
+        (W.toAffine.addY x₁ x₂ y₁ (W.toAffine.slope x₁ x₂ y₁ y₂) - y₁) = 0 :=
+      (reduceCoord_eq_zero_iff_lt R hsub_le).mpr (lt_of_le_of_lt hvy₃1 hnegs1)
+    rw [hsubK, reduceCoord_algebraMap, map_sub, sub_eq_zero] at h0
+    rw [← h3y, ← h1y, reduceCoord_algebraMap, reduceCoord_algebraMap]
+    exact h0
+
+end Deep
+
+theorem solution
+    (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+    {K : Type*} [Field K] [DecidableEq K] [Algebra R K] [IsFractionRing R K]
+    (W : WeierstrassCurve K) [W.HasGoodReduction R] {x₁ y₁ x₂ y₂ : K}
+    (h₁ : W.toAffine.Nonsingular x₁ y₁) (h₂ : W.toAffine.Nonsingular x₂ y₂)
+    (hx₁ : IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R)
+      x₁ ≤ 1)
+    (hx₂ : ¬ IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R)
+      x₂ ≤ 1) :
+    WeierstrassCurve.reducePoint_alt R W (.some x₁ y₁ h₁ + .some x₂ y₂ h₂)
+      = WeierstrassCurve.reducePoint_alt R W (.some x₁ y₁ h₁) := by
+  classical
+  exact
+    Deep.reducePoint_add_int_pole R W h₁ h₂ hx₁ hx₂
+
+end S_WeierstrassCurve_reducePoint_some_add_some_of_not_le_one
+end P2MW
+export P2MW.S_WeierstrassCurve_reducePoint_some_add_some_of_not_le_one (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.reducePoint_some_add_some_of_not_le_one
+    (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+    {K : Type*} [Field K] [DecidableEq K] [Algebra R K] [IsFractionRing R K]
+    (W : WeierstrassCurve K) [W.HasGoodReduction R] {x₁ y₁ x₂ y₂ : K}
+    (h₁ : W.toAffine.Nonsingular x₁ y₁) (h₂ : W.toAffine.Nonsingular x₂ y₂)
+    (hx₁ : IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R)
+      x₁ ≤ 1)
+    (hx₂ : ¬ IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R)
+      x₂ ≤ 1) :
+    WeierstrassCurve.reducePoint_alt R W (.some x₁ y₁ h₁ + .some x₂ y₂ h₂)
+      = WeierstrassCurve.reducePoint_alt R W (.some x₁ y₁ h₁) := by
+  classical
+  exact
+    solution R W h₁ h₂ hx₁ hx₂
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_reducePoint_some_eq_zero_iff.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_reducePoint_some_eq_zero_iff.lean
new file mode 100644
index 0000000000..f438a91729
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_reducePoint_some_eq_zero_iff.lean
@@ -0,0 +1,104 @@
+/-
+Based on Prove2Me node WeierstrassCurve.reducePoint_some_eq_zero_iff
+(dc6055ef-6a65-5c41-9d4e-0c7d06f343ee) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 20a3bb48-5876-5b7f-bbf0-77fa0ac91b03
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_PointReduction
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_valuation_le_one_of_equation
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_reducePoint_some
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Affine point reduces to O iff x is non-integral
+
+Theorem statement: `WeierstrassCurve.reducePoint_some_eq_zero_iff`
+(`dc6055ef-6a65-5c41-9d4e-0c7d06f343ee`), by Claude, 2026-09-05.
+
+Proof: submission `20a3bb48-5876-5b7f-bbf0-77fa0ac91b03`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a discrete valuation ring that is a domain, let $K$ be a field equipped with an
+$R$-algebra structure making it a fraction field of $R$, and let $W$ be a Weierstrass curve over $K$
+carrying an instance of the predicate `WeierstrassCurve.HasGoodReduction` for $R$. Let $x, y \in K$
+satisfy `W.toAffine.Nonsingular x y`, i.e. $(x,y)$ is a nonsingular affine point of $W$. Write $v$
+for the valuation on $K$ attached to the maximal ideal of $R$ as a height-one prime of $R$, in the
+multiplicative normalisation, and let `reducePoint_alt` be the reduction map on affine points, which
+sends the point at infinity to the point at infinity and sends a nonsingular affine point $(x,y)$ to
+the point with coordinates `reduceCoord R x`, `reduceCoord R y` on the reduced curve `W.reduction R`
+when $v(x) \le 1$, $v(y) \le 1$ and that pair is a nonsingular point of the reduced curve, and to
+the point at infinity in all remaining cases (here `reduceCoord R x` is the residue in the residue
+field of $R$ of a chosen preimage of $x$ in $R$ when one exists, and $0$ otherwise). The assertion
+is that `reducePoint_alt R W (.some x y h)` equals the point at infinity if and only if $v(x) \le 1$
+fails.
+
+This identifies the kernel of reduction on affine points: a nonsingular affine point of a curve with
+good reduction over a discrete valuation ring reduces to the point at infinity exactly when its
+$x$-coordinate is not integral, so the points of the formal group are precisely those with a pole in
+$x$. It is used in the study of reduction of points, in particular in the construction of
+specialisation homomorphisms and in the proof that the Galois representation attached to a curve
+with good reduction is unramified at the relevant place.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_reducePoint_some_eq_zero_iff.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_reducePoint_some_eq_zero_iff
+
+open WeierstrassCurve IsDiscreteValuationRing IsLocalRing IsDedekindDomain.HeightOneSpectrum
+
+theorem solution
+    (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+    {K : Type*} [Field K] [Algebra R K] [IsFractionRing R K]
+    (W : WeierstrassCurve K) [W.HasGoodReduction R] {x y : K} (h : W.toAffine.Nonsingular x y) :
+    WeierstrassCurve.reducePoint_alt R W (.some x y h) = .zero ↔
+      ¬ IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R) x ≤
+        1 := by
+  classical
+  constructor
+  · intro h0 hx
+    have hy : valuation K (IsDiscreteValuationRing.maximalIdeal R) y ≤ 1 :=
+      WeierstrassCurve.valuation_le_one_of_equation R W h.left hx
+    obtain ⟨h', hsome⟩ := WeierstrassCurve.reducePoint_some R W h hx hy
+    rw [hsome] at h0
+    exact Affine.Point.some_ne_zero h' (h0.trans (Affine.Point.zero_def).symm)
+  · intro hx
+    change (if _ : valuation K (IsDiscreteValuationRing.maximalIdeal R) x ≤ 1 ∧
+        valuation K (IsDiscreteValuationRing.maximalIdeal R) y ≤ 1
+        then _ else Affine.Point.zero) = Affine.Point.zero
+    rw [dite_eq_right (fun hc => hx hc.1)]
+
+end S_WeierstrassCurve_reducePoint_some_eq_zero_iff
+end P2MW
+export P2MW.S_WeierstrassCurve_reducePoint_some_eq_zero_iff (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.reducePoint_some_eq_zero_iff
+    (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+    {K : Type*} [Field K] [Algebra R K] [IsFractionRing R K]
+    (W : WeierstrassCurve K) [W.HasGoodReduction R] {x y : K} (h : W.toAffine.Nonsingular x y) :
+    WeierstrassCurve.reducePoint_alt R W (.some x y h) = .zero ↔
+      ¬ IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R) x ≤
+        1 :=
+  solution R W h
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_sum_eq_zero_of_forall_mem_iff_smul_eq_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_sum_eq_zero_of_forall_mem_iff_smul_eq_zero.lean
new file mode 100644
index 0000000000..ec82840b5c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_sum_eq_zero_of_forall_mem_iff_smul_eq_zero.lean
@@ -0,0 +1,174 @@
+/-
+Based on Prove2Me node WeierstrassCurve.sum_eq_zero_of_forall_mem_iff_smul_eq_zero
+(c1433814-ee33-55c0-8518-c7e80d81fa07) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d98f4e3a-933d-5d16-ad74-2cdd66956caf
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsion_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# The n-torsion points of an elliptic curve sum to O
+
+Theorem statement: `WeierstrassCurve.sum_eq_zero_of_forall_mem_iff_smul_eq_zero`
+(`c1433814-ee33-55c0-8518-c7e80d81fa07`), by Claude, 2026-09-05.
+
+Proof: submission `d98f4e3a-933d-5d16-ad74-2cdd66956caf`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ and $K$ be fields with $K$ an $F$-algebra and $K$ algebraically closed, and let $W$ be a
+Weierstrass curve over $F$ which is elliptic (invertible discriminant). Let $n$ be a natural number
+whose image in $K$ is nonzero, and let $s$ be a finite set of points of the affine elliptic curve
+obtained from $W$ by base change to $K$, i.e. of the group $(W_{/K})(K)$ in Mathlib's `Point`
+presentation (the nonsingular affine points together with the point at infinity, with the
+chord–tangent group law). Assume that $s$ consists exactly of the $n$-torsion: for every point $P$,
+one has $P \in s$ if and only if $n \cdot P = 0$. Then the sum of all elements of $s$, taken in the
+group $(W_{/K})(K)$, is the identity $0$. Since $n$ is nonzero in $K$, the hypothesis in particular
+forces $n \geq 1$, so $s$ is the full group $(W_{/K})(K)[n]$ of $n$-division points.
+
+This is the classical assertion that the sum of all $n$-division points of an elliptic curve over an
+algebraically closed field of residue characteristic not dividing $n$ is the origin; it underlies
+the verification that the divisor $\sum_{R \in E[n]} (T'+R) - \sum_{R \in E[n]} (R)$ is principal in
+Silverman's construction of the Weil pairing. Within the present development it is used in the
+computation of the valuation of the Weil numerator,
+[`WeierstrassCurve.Affine.valuation_weilNum`](thm.html#WeierstrassCurve.Affine.valuation_weilNum).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_sum_eq_zero_of_forall_mem_iff_smul_eq_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_sum_eq_zero_of_forall_mem_iff_smul_eq_zero
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+theorem sum_eq_zero_of_two_torsion_card_four {M : Type*} [AddCommGroup M]
+    (T : Finset M) (hT : ∀ P, P ∈ T ↔ 2 • P = 0) (hcard : T.card = 4) : ∑ P ∈ T, P = 0 := by
+  classical
+  obtain ⟨A, hA, hA0⟩ : ∃ A ∈ T, A ≠ 0 := by
+    by_contra! hall
+    have hsub : T ⊆ {0} := fun P hP => Finset.mem_singleton.mpr (hall P hP)
+    have := Finset.card_le_card hsub
+    rw [Finset.card_singleton] at this
+    omega
+  obtain ⟨B, hB, hB0, hBA⟩ : ∃ B ∈ T, B ≠ 0 ∧ B ≠ A := by
+    by_contra! hall
+    have hsub : T ⊆ {0, A} := fun P hP => by
+      rw [Finset.mem_insert, Finset.mem_singleton]
+      by_cases hP0 : P = 0
+      · exact Or.inl hP0
+      · exact Or.inr (hall P hP hP0)
+    have := (Finset.card_le_card hsub).trans Finset.card_le_two
+    omega
+  have h2A : 2 • A = 0 := (hT A).mp hA
+  have h2B : 2 • B = 0 := (hT B).mp hB
+  have hAB : A + B ∈ T := (hT _).mpr (by rw [smul_add, h2A, h2B, add_zero])
+  have hAB0 : A + B ≠ 0 := fun h => hBA <| by
+    rw [two_nsmul] at h2A
+    calc B = -A := eq_neg_of_add_eq_zero_right h
+      _ = A := neg_eq_of_add_eq_zero_left h2A
+  have hABA : A + B ≠ A := fun h => hB0 (add_eq_left.mp h)
+  have hABB : A + B ≠ B := fun h => hA0 (add_eq_right.mp h)
+  have h0 : (0 : M) ∈ T := (hT 0).mpr (smul_zero 2)
+  have hsub : ({0, A, B, A + B} : Finset M) ⊆ T := by
+    intro P hP
+    simp only [Finset.mem_insert, Finset.mem_singleton] at hP
+    rcases hP with rfl | rfl | rfl | rfl <;> assumption
+  have hcard4 : ({0, A, B, A + B} : Finset M).card = 4 := by
+    rw [Finset.card_insert_of_notMem, Finset.card_insert_of_notMem, Finset.card_pair hABB.symm]
+    · simp only [Finset.mem_insert, Finset.mem_singleton, not_or]
+      exact ⟨hBA.symm, hABA.symm⟩
+    · simp only [Finset.mem_insert, Finset.mem_singleton, not_or]
+      exact ⟨hA0.symm, hB0.symm, hAB0.symm⟩
+  have heq : ({0, A, B, A + B} : Finset M) = T :=
+    Finset.eq_of_subset_of_card_le hsub (by rw [hcard, hcard4])
+  rw [← heq, Finset.sum_insert, Finset.sum_insert, Finset.sum_pair hABB.symm]
+  · have : (0 : M) + (A + (B + (A + B))) = 2 • A + 2 • B := by abel
+    rw [this, h2A, h2B, add_zero]
+  · simp only [Finset.mem_insert, Finset.mem_singleton, not_or]
+    exact ⟨hBA.symm, hABA.symm⟩
+  · simp only [Finset.mem_insert, Finset.mem_singleton, not_or]
+    exact ⟨hA0.symm, hB0.symm, hAB0.symm⟩
+
+theorem solution {F K : Type*} [Field F] [Field K] [Algebra F K] [IsAlgClosed K] [DecidableEq K]
+    (W : WeierstrassCurve F) [W.IsElliptic] {n : ℕ} (hnK : (n : K) ≠ 0) (s : Finset (W⁄K).Point)
+    (hs : ∀ P, P ∈ s ↔ n • P = 0) :
+    ∑ P ∈ s, P = 0 := by
+  classical
+  rw [← Finset.sum_filter_add_sum_filter_not s (fun P => 2 • P = 0)]
+  have hrest : ∑ P ∈ s.filter (fun P => ¬2 • P = 0), P = 0 := by
+    refine Finset.sum_involution (fun P _ => -P) (fun P _ => add_neg_cancel P)
+      (fun P hP _ => ?_) (fun P hP => ?_) (fun P _ => neg_neg P)
+    · rw [Finset.mem_filter] at hP
+      intro h
+      apply hP.2
+      rw [two_nsmul]
+      nth_rw 1 [← h]
+      exact neg_add_cancel P
+    · rw [Finset.mem_filter] at hP ⊢
+      refine ⟨(hs _).mpr ?_, ?_⟩
+      · rw [smul_neg, (hs _).mp hP.1, _root_.neg_zero]
+      · rw [smul_neg, neg_eq_zero]
+        exact hP.2
+  rw [hrest, add_zero]
+  rcases Nat.even_or_odd n with ⟨k, rfl⟩ | ⟨k, rfl⟩
+  · have h2K : (2 : K) ≠ 0 := by
+      intro h
+      apply hnK
+      push_cast
+      rw [← two_mul, h, zero_mul]
+    set T := s.filter (fun P => 2 • P = 0) with hTdef
+    have hT : ∀ P, P ∈ T ↔ 2 • P = 0 := fun P => by
+      rw [hTdef, Finset.mem_filter, and_iff_right_iff_imp]
+      intro h2P
+      rw [hs, ← two_mul, mul_nsmul, h2P, smul_zero]
+    have hcard : T.card = 4 := by
+      have hc := WeierstrassCurve.card_torsion_of_isAlgClosed (K := K) W (n := 2)
+        (by exact_mod_cast h2K)
+      rw [← Nat.card_eq_finsetCard, show (4 : ℕ) = 2 ^ 2 by norm_num, ← hc]
+      refine Nat.card_congr (Equiv.subtypeEquivRight fun P => ?_)
+      rw [hT, Submodule.mem_torsionBy_iff]
+      push_cast
+      rw [ofNat_zsmul]
+    exact sum_eq_zero_of_two_torsion_card_four T hT hcard
+  · refine Finset.sum_eq_zero fun P hP => ?_
+    rw [Finset.mem_filter] at hP
+    obtain ⟨hPs, h2P⟩ := hP
+    have hnP := (hs P).mp hPs
+    rwa [add_nsmul, one_nsmul, mul_nsmul, h2P, smul_zero, zero_add] at hnP
+
+end S_WeierstrassCurve_sum_eq_zero_of_forall_mem_iff_smul_eq_zero
+end P2MW
+export P2MW.S_WeierstrassCurve_sum_eq_zero_of_forall_mem_iff_smul_eq_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+theorem WeierstrassCurve.sum_eq_zero_of_forall_mem_iff_smul_eq_zero {F K : Type*} [Field F]
+    [Field K] [Algebra F K] [IsAlgClosed K] [DecidableEq K] (W : WeierstrassCurve F) [W.IsElliptic]
+    {n : ℕ} (hnK : (n : K) ≠ 0) (s : Finset (W⁄K).Point) (hs : ∀ P, P ∈ s ↔ n • P = 0) :
+    ∑ P ∈ s, P = 0 :=
+  solution W hnK s hs
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_tateModuleRep_charpoly_frobenius.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_tateModuleRep_charpoly_frobenius.lean
new file mode 100644
index 0000000000..9f3b41472b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_tateModuleRep_charpoly_frobenius.lean
@@ -0,0 +1,174 @@
+/-
+Based on Prove2Me node WeierstrassCurve.tateModuleRep_charpoly_frobenius
+(8f4634d9-5aa8-53ac-b6f3-426deb1a8659) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 2484721f-668a-5089-b666-d28b67b8632a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_TateModule
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusTrace
+public import Mathlib.LinearAlgebra.Charpoly.Basic
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_frobenius_cayleyHamilton_on_torsion
+import LeanPool.FLTEichlerShimura.Theorems.Thm_LinearMap_charpoly_eq_iff_of_finrank_eq_two
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_tateModuleRep_det_frobenius
+import LeanPool.FLTEichlerShimura.Theorems.Thm_LinearMap_trace_eq_of_sq_sub_smul_add_eq_zero_of_det_eq
+import Mathlib.Algebra.Module.NatInt
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Frobenius characteristic polynomial on the p-adic Tate module
+
+Theorem statement: `WeierstrassCurve.tateModuleRep_charpoly_frobenius`
+(`8f4634d9-5aa8-53ac-b6f3-426deb1a8659`), by Claude, 2026-09-05.
+
+Proof: submission `2484721f-668a-5089-b666-d28b67b8632a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $W$ be a Weierstrass curve over $\mathbb{Z}$ and $p$ a prime, and assume that for every $n$ the
+$p^n$-torsion subgroup of the group of points of the base change of $W$ to $\overline{\mathbb{Q}}$
+(via $\mathbb{Z} \to \mathbb{Q}$) has cardinality $(p^n)^2$; this is the hypothesis under which the
+rank-two $\mathbb{Z}_p$-representation `tateModuleRep` of the absolute Galois group
+$\operatorname{Aut}_{\mathbb{Q}}(\overline{\mathbb{Q}})$ on the Tate module — sequences $(x_n)$ of
+points with $p^n x_n = 0$ and $p\,x_{n+1} = x_n$ — is formed. Let $\ell$ be a prime with $\ell \ne
+p$ and with $\ell \nmid \Delta(W)$ in $\mathbb{Z}$ (`IsGoodPrimeFor`), let $A$ be a valuation
+subring of $\overline{\mathbb{Q}}$ such that $\ell$ is a non-unit of $A$, and let $\sigma$ be a
+$\mathbb{Q}$-algebra automorphism of $\overline{\mathbb{Q}}$ lying in the decomposition subgroup of
+$A$ over $\mathbb{Q}$ and acting on the residue field of $A$ by $x \mapsto x^{\ell}$. Then the
+characteristic polynomial of the $\mathbb{Z}_p$-linear endomorphism by which $\sigma$ acts on the
+Tate module is $X^2 - C(a_\ell)X + C(\ell)$ in $\mathbb{Z}_p[X]$, where $a_\ell$ is the integer
+$\ell + 1 - \#\big(W \bmod \ell\big)(\mathbb{Z}/\ell)$ attached to the model $W$ by `apOfModel`, and
+both $a_\ell$ and $\ell$ are cast into $\mathbb{Z}_p$.
+
+This is the Eichler–Shimura style description of Frobenius on the $p$-adic Tate module of an
+elliptic curve at a prime of good reduction: trace $a_\ell$ and determinant $\ell$. It is what ties
+the Galois representation attached to a Frobenius curve to the $L$-series coefficients of its
+reduction, and it feeds the modularity and level-lowering steps of the argument, in particular the
+comparison of the Tate-module representation with the one coming from a modular form.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_tateModuleRep_charpoly_frobenius.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_tateModuleRep_charpoly_frobenius
+
+open Polynomial WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+  ValuationSubring
+
+private lemma apOfModel_dict (W : WeierstrassCurve ℤ) (ℓ : ℕ) :
+    W.apOfModel ℓ = (ℓ : ℤ) + 1 - (Nat.card (W⁄(ZMod ℓ)).Point : ℤ) := by
+  unfold WeierstrassCurve.apOfModel WeierstrassCurve.traceOfFrobenius WeierstrassCurve.card
+    WeierstrassCurve.reductionMod
+  rw [Nat.card_zmod]
+  rfl
+
+private lemma intCast_padicInt_smul_apply {p : ℕ} {M : Type} [AddCommGroup M] [Fact p.Prime]
+    (c : ℤ) (x : TateModule p M) (n : ℕ) :
+    (((c : ℤ_[p]) • x : TateModule p M) : ℕ → M) n = c • ((x : ℕ → M) n) := by
+  rw [Int.cast_smul_eq_zsmul ℤ_[p], AddSubgroupClass.coe_zsmul, Pi.smul_apply]
+
+section endoId
+
+variable (W : WeierstrassCurve ℤ) (p : ℕ) [Fact p.Prime]
+
+private abbrev MPoint := ((W.map (Int.castRingHom ℚ))⁄(AlgebraicClosure ℚ)).Point
+
+private lemma tateModule_frobenius_endoIdentity
+    (ℓ : ℕ) (hℓ : ℓ.Prime) (hgood : W.IsGoodPrimeFor ℓ) (hℓp : ℓ ≠ p)
+    (A : ValuationSubring (AlgebraicClosure ℚ)) (hA : A.LiesOverPrime ℓ)
+    (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) (hσ : A.IsFrobeniusAt σ ℓ)
+    (x : TateModule p (MPoint W)) (k : ℕ) :
+    σ • σ • (x : ℕ → MPoint W) k - (W.apOfModel ℓ) • σ • (x : ℕ → MPoint W) k
+      + (ℓ : ℤ) • (x : ℕ → MPoint W) k = 0 := by
+  rw [apOfModel_dict, sub_add_eq_add_sub, sub_eq_zero]
+  refine WeierstrassCurve.frobenius_cayleyHamilton_on_torsion W ℓ hℓ hgood A hA σ hσ
+    (p ^ k) (pow_pos (Fact.out (p := p.Prime)).pos k)
+    (fun hdvd => hℓp ((Nat.prime_dvd_prime_iff_eq hℓ Fact.out).mp (hℓ.dvd_of_dvd_pow hdvd)))
+    ((x : ℕ → MPoint W) k) ?_
+  have h := TateModule.torsion x k
+  rwa [natCast_zsmul] at h
+
+end endoId
+
+theorem solution
+    (W : WeierstrassCurve ℤ) (p : ℕ) [Fact p.Prime]
+    (hcard : ∀ n : ℕ, Nat.card (Submodule.torsionBy ℤ
+      ((W.map (Int.castRingHom ℚ))⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2)
+    (ℓ : ℕ) (hℓ : ℓ.Prime) (hgood : W.IsGoodPrimeFor ℓ) (hℓp : ℓ ≠ p)
+    (A : ValuationSubring (AlgebraicClosure ℚ)) (hA : A.LiesOverPrime ℓ)
+    (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) (hσ : A.IsFrobeniusAt σ ℓ) :
+    LinearMap.charpoly (((W.map (Int.castRingHom ℚ)).tateModuleRep p hcard).ρ σ)
+      = X ^ 2 - C ((W.apOfModel ℓ : ℤ) : ℤ_[p]) * X + C ((ℓ : ℕ) : ℤ_[p]) := by
+  have : Module.Free ℤ_[p] (TateModule p (MPoint W)) := TateModule.free hcard
+  have : Module.Finite ℤ_[p] (TateModule p (MPoint W)) := TateModule.finite hcard
+  have hrank : Module.finrank ℤ_[p] (TateModule p (MPoint W)) = 2 := TateModule.finrank_eq_two hcard
+  set f : Module.End ℤ_[p] (TateModule p (MPoint W)) :=
+    ((W.map (Int.castRingHom ℚ)).tateModuleRep p hcard).ρ σ
+  have hΔℤ : W.Δ ≠ 0 := fun h => hgood (h ▸ dvd_zero _)
+  have hΔℚ : (W.map (Int.castRingHom ℚ)).Δ ≠ 0 := by
+    rw [WeierstrassCurve.map_Δ, eq_intCast]
+    exact_mod_cast hΔℤ
+  have hdet : LinearMap.det f = ((ℓ : ℕ) : ℤ_[p]) :=
+    WeierstrassCurve.tateModuleRep_det_frobenius (W.map (Int.castRingHom ℚ)) p hΔℚ hcard ℓ hℓ hℓp A
+      hA σ hσ
+  have hd : ((ℓ : ℕ) : ℤ_[p]) ≠ 0 := by exact_mod_cast hℓ.pos.ne'
+  have hendo : f * f - ((W.apOfModel ℓ : ℤ) : ℤ_[p]) • f
+      + ((ℓ : ℕ) : ℤ_[p]) • (1 : Module.End ℤ_[p] (TateModule p (MPoint W))) = 0 := by
+    refine LinearMap.ext fun x => ?_
+    have hx : (f * f - ((W.apOfModel ℓ : ℤ) : ℤ_[p]) • f
+        + ((ℓ : ℕ) : ℤ_[p]) • (1 : Module.End ℤ_[p] (TateModule p (MPoint W)))) x
+        = f (f x) - ((W.apOfModel ℓ : ℤ) : ℤ_[p]) • (f x) + ((ℓ : ℕ) : ℤ_[p]) • x := by
+      simp only [LinearMap.add_apply, LinearMap.sub_apply, Module.End.mul_apply,
+        LinearMap.smul_apply, Module.End.one_apply]
+    rw [hx, LinearMap.zero_apply]
+    rw [show ((ℓ : ℕ) : ℤ_[p]) = ((ℓ : ℤ) : ℤ_[p]) by push_cast; ring]
+    refine Subtype.ext (funext fun k => ?_)
+    change ((f (f x) - ((W.apOfModel ℓ : ℤ) : ℤ_[p]) • (f x)
+        + ((ℓ : ℤ) : ℤ_[p]) • x : TateModule p (MPoint W)) : ℕ → MPoint W) k
+      = (((0 : TateModule p (MPoint W)) : ℕ → MPoint W)) k
+    rw [TateModule.coe_add, TateModule.coe_sub, TateModule.coe_zero, Pi.add_apply, Pi.sub_apply,
+      Pi.zero_apply, intCast_padicInt_smul_apply, intCast_padicInt_smul_apply]
+    exact tateModule_frobenius_endoIdentity W p ℓ hℓ hgood hℓp A hA σ hσ x k
+  exact (LinearMap.charpoly_eq_iff_of_finrank_eq_two hrank f
+      ((W.apOfModel ℓ : ℤ) : ℤ_[p]) ((ℓ : ℕ) : ℤ_[p])).mpr
+    ⟨LinearMap.trace_eq_of_sq_sub_smul_add_eq_zero_of_det_eq hrank f _ _ hendo hdet hd, hdet⟩
+
+end S_WeierstrassCurve_tateModuleRep_charpoly_frobenius
+end P2MW
+export P2MW.S_WeierstrassCurve_tateModuleRep_charpoly_frobenius (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open Polynomial WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+  ValuationSubring
+
+theorem WeierstrassCurve.tateModuleRep_charpoly_frobenius
+    (W : WeierstrassCurve ℤ) (p : ℕ) [Fact p.Prime]
+    (hcard : ∀ n : ℕ, Nat.card (Submodule.torsionBy ℤ
+      ((W.map (Int.castRingHom ℚ))⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2)
+    (ℓ : ℕ) (hℓ : ℓ.Prime) (hgood : W.IsGoodPrimeFor ℓ) (hℓp : ℓ ≠ p)
+    (A : ValuationSubring (AlgebraicClosure ℚ)) (hA : A.LiesOverPrime ℓ)
+    (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) (hσ : A.IsFrobeniusAt σ ℓ) :
+    LinearMap.charpoly (((W.map (Int.castRingHom ℚ)).tateModuleRep p hcard).ρ σ)
+      = X ^ 2 - C ((W.apOfModel ℓ : ℤ) : ℤ_[p]) * X + C ((ℓ : ℕ) : ℤ_[p]) :=
+  solution W p hcard ℓ hℓ hgood hℓp A hA σ hσ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_tateModuleRep_detIsCyclotomic.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_tateModuleRep_detIsCyclotomic.lean
new file mode 100644
index 0000000000..a6d111841e
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_tateModuleRep_detIsCyclotomic.lean
@@ -0,0 +1,384 @@
+/-
+Based on Prove2Me node WeierstrassCurve.tateModuleRep_detIsCyclotomic
+(52a30335-e340-5197-bb05-519e1167f456) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 94013731-52f2-51f2-9f4b-4b7bf07a580e
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_TateModule
+public import LeanPool.FLTEichlerShimura.Definitions.Def_GaloisRep_LocalConditions
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_pairing_torsionBy
+import Mathlib.RingTheory.RootsOfUnity.PrimitiveRoots
+import Mathlib.LinearAlgebra.Matrix.ToLin
+import Mathlib.LinearAlgebra.Matrix.Determinant.Basic
+import Mathlib.Algebra.Group.TypeTags.Basic
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Determinant of the Tate module representation is cyclotomic
+
+Theorem statement: `WeierstrassCurve.tateModuleRep_detIsCyclotomic`
+(`52a30335-e340-5197-bb05-519e1167f456`), by Claude, 2026-09-05.
+
+Proof: submission `94013731-52f2-51f2-9f4b-4b7bf07a580e`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $W$ be a Weierstrass curve over $\mathbb{Q}$ and let $p$ be a natural number that is prime.
+Assume $W.\Delta \neq 0$, and assume the counting hypothesis `hcard`: for every $n$, the group of
+$p^n$-torsion points (the $\mathbb{Z}$-submodule killed by $p^n$) of the affine point group of $W$
+base changed to `AlgebraicClosure ℚ` has exactly $(p^n)^2$ elements. Under these hypotheses the
+object `W.tateModuleRep p hcard` — the two-dimensional $\mathbb{Z}_p$-adic Galois representation
+whose underlying module is the Tate module, i.e. the subgroup of sequences $(x_n)$ of
+$\overline{\mathbb{Q}}$-points with $p^n x_n = 0$ and $p\,x_{n+1} = x_n$, equipped with the
+$\mathbb{Z}_p$-basis of rank $2$ produced from `hcard` and with the Galois action of
+$\overline{\mathbb{Q}} \simeq_{\mathbb{Q}} \overline{\mathbb{Q}}$, which is adically continuous —
+satisfies `DetIsCyclotomic p`; explicitly: $p$ lies in the maximal ideal of $\mathbb{Z}_p$, and for
+every $n \in \mathbb{N}$, every $\sigma \in \mathrm{Gal}(\overline{\mathbb{Q}}/\mathbb{Q})$ and
+every $a \in \mathbb{N}$ such that $\sigma\mu = \mu^a$ for all $\mu \in \overline{\mathbb{Q}}$ with
+$\mu^{p^n} = 1$, one has $\det(\rho(\sigma)) - a \in (p^n)\mathbb{Z}_p$.
+
+This is the statement that the determinant of the $p$-adic representation on the Tate module of an
+elliptic curve over $\mathbb{Q}$ is the cyclotomic character, tested at every finite level $p^n$;
+classically it is read off from the Galois equivariance of the Weil pairing, and the proof here
+invokes the existence of that pairing on $p^n$-torsion. It feeds the verification of the local
+conditions and characteristic-polynomial properties of the Tate module representation, and the
+computation of determinants of Frobenius elements.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_tateModuleRep_detIsCyclotomic.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_tateModuleRep_detIsCyclotomic
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+namespace EPair
+
+variable {T G : Type*} [AddCommGroup T] [CommGroup G]
+
+private theorem pairing_zero_left (e : T → T → G)
+    (hl : ∀ P P' Q, e (P + P') Q = e P Q * e P' Q) (Q : T) :
+    e 0 Q = 1 := by
+  have h := hl 0 0 Q
+  rw [add_zero] at h
+  have h2 : e 0 Q * e 0 Q = e 0 Q * 1 := by rw [mul_one]; exact h.symm
+  exact mul_left_cancel h2
+
+private theorem pairing_zero_right (e : T → T → G)
+    (hr : ∀ P Q Q', e P (Q + Q') = e P Q * e P Q') (P : T) :
+    e P 0 = 1 := by
+  have h := hr P 0 0
+  rw [add_zero] at h
+  have h2 : e P 0 * e P 0 = e P 0 * 1 := by rw [mul_one]; exact h.symm
+  exact mul_left_cancel h2
+
+private theorem pairing_nsmul_left (e : T → T → G)
+    (hl : ∀ P P' Q, e (P + P') Q = e P Q * e P' Q) (m : ℕ) (P Q : T) :
+    e (m • P) Q = e P Q ^ m := by
+  induction m with
+  | zero => rw [zero_nsmul, pow_zero]; exact pairing_zero_left e hl Q
+  | succ k ih => rw [succ_nsmul, hl, ih, pow_succ]
+
+private theorem pairing_nsmul_right (e : T → T → G)
+    (hr : ∀ P Q Q', e P (Q + Q') = e P Q * e P Q') (m : ℕ) (P Q : T) :
+    e P (m • Q) = e P Q ^ m := by
+  induction m with
+  | zero => rw [zero_nsmul, pow_zero]; exact pairing_zero_right e hr P
+  | succ k ih => rw [succ_nsmul, hr, ih, pow_succ]
+
+private theorem ep1 (e : T → T → G)
+    (hl : ∀ P P' Q, e (P + P') Q = e P Q * e P' Q)
+    (hr : ∀ P Q Q', e P (Q + Q') = e P Q * e P Q')
+    (halt : ∀ P, e P P = 1)
+    (hnd : ∀ P, (∀ Q, e P Q = 1) → P = 0)
+    {n : ℕ} (P₀ P₁ : T) (htor : (n : ℤ) • P₀ = 0)
+    (hspan : ∀ Q : T, ∃ a b : ℕ, (a : ℤ) • P₀ + (b : ℤ) • P₁ = Q)
+    (hrel : ∀ a b : ℤ, a • P₀ + b • P₁ = 0 → (n : ℤ) ∣ a ∧ (n : ℤ) ∣ b) :
+    IsPrimitiveRoot (e P₀ P₁) n := by
+  constructor
+  · have hn0 : n • P₀ = 0 := by rw [← natCast_zsmul]; exact htor
+    rw [← pairing_nsmul_left e hl n P₀ P₁, hn0]
+    exact pairing_zero_left e hl P₁
+  · intro l hlpow
+    have key : ∀ Q, e (l • P₀) Q = 1 := by
+      intro Q
+      obtain ⟨x, y, hxy⟩ := hspan Q
+      rw [← hxy, natCast_zsmul, natCast_zsmul, hr,
+        pairing_nsmul_right e hr x, pairing_nsmul_right e hr y,
+        pairing_nsmul_left e hl l, pairing_nsmul_left e hl l,
+        halt P₀, one_pow, one_pow, hlpow, one_pow, one_mul]
+    have hP0 : l • P₀ = 0 := hnd _ key
+    have hzrel : (l : ℤ) • P₀ + (0 : ℤ) • P₁ = 0 := by
+      rw [natCast_zsmul, hP0, zero_zsmul, add_zero]
+    exact Int.natCast_dvd_natCast.mp (hrel (l : ℤ) 0 hzrel).1
+
+private theorem pairing_zsmul_left (e : T → T → G)
+    (hl : ∀ P P' Q, e (P + P') Q = e P Q * e P' Q) (a : ℤ) (P Q : T) :
+    e (a • P) Q = e P Q ^ a := by
+  have h := map_zsmul (AddMonoidHom.mk' (fun R => Additive.ofMul (e R Q))
+    (fun R R' => by simp only [hl, ofMul_mul])) a P
+  change Additive.ofMul (e (a • P) Q) = a • Additive.ofMul (e P Q) at h
+  rw [← ofMul_zpow] at h
+  exact Additive.ofMul.injective h
+
+private theorem pairing_zsmul_right (e : T → T → G)
+    (hr : ∀ P Q Q', e P (Q + Q') = e P Q * e P Q') (a : ℤ) (P Q : T) :
+    e P (a • Q) = e P Q ^ a := by
+  have h := map_zsmul (AddMonoidHom.mk' (fun R => Additive.ofMul (e P R))
+    (fun R R' => by simp only [hr, ofMul_mul])) a Q
+  change Additive.ofMul (e P (a • Q)) = a • Additive.ofMul (e P Q) at h
+  rw [← ofMul_zpow] at h
+  exact Additive.ofMul.injective h
+
+private theorem pairing_zsmul_zsmul (e : T → T → G)
+    (hl : ∀ P P' Q, e (P + P') Q = e P Q * e P' Q)
+    (hr : ∀ P Q Q', e P (Q + Q') = e P Q * e P Q') (a c : ℤ) (P Q : T) :
+    e (a • P) (c • Q) = e P Q ^ (a * c) := by
+  rw [pairing_zsmul_left e hl, pairing_zsmul_right e hr, ← zpow_mul, mul_comm]
+
+private theorem pairing_swap (e : T → T → G)
+    (hl : ∀ P P' Q, e (P + P') Q = e P Q * e P' Q)
+    (hr : ∀ P Q Q', e P (Q + Q') = e P Q * e P Q')
+    (halt : ∀ P, e P P = 1) (P Q : T) :
+    e Q P = (e P Q)⁻¹ := by
+  have h : e (P + Q) (P + Q) = 1 := halt _
+  rw [hl, hr, hr, halt P, halt Q, one_mul, mul_one] at h
+  exact eq_inv_of_mul_eq_one_right h
+
+private theorem ep2 (e : T → T → G)
+    (hl : ∀ P P' Q, e (P + P') Q = e P Q * e P' Q)
+    (hr : ∀ P Q Q', e P (Q + Q') = e P Q * e P Q')
+    (halt : ∀ P, e P P = 1)
+    {P₀ P₁ Q₀ Q₁ : T} (m : Matrix (Fin 2) (Fin 2) ℤ)
+    (hQ₀ : Q₀ = m 0 0 • P₀ + m 1 0 • P₁) (hQ₁ : Q₁ = m 0 1 • P₀ + m 1 1 • P₁) :
+    e Q₀ Q₁ = e P₀ P₁ ^ m.det := by
+  subst hQ₀ hQ₁
+  rw [hl, hr, hr]
+  simp only [pairing_zsmul_zsmul e hl hr]
+  rw [halt P₀, halt P₁, one_zpow, one_zpow, one_mul, mul_one,
+    pairing_swap e hl hr halt P₀ P₁, inv_zpow', ← zpow_add, Matrix.det_fin_two]
+  congr 1
+  ring
+
+private theorem det_fin_two_sub_appr_mem_span {p : ℕ} [Fact p.Prime]
+    (m : Matrix (Fin 2) (Fin 2) ℤ_[p]) (k : ℕ) :
+    m.det - ((((m 0 0).appr k * (m 1 1).appr k : ℕ) : ℤ_[p])
+        - (((m 0 1).appr k * (m 1 0).appr k : ℕ) : ℤ_[p]))
+      ∈ Ideal.span {((p ^ k : ℕ) : ℤ_[p])} := by
+  have hmem : ∀ i j : Fin 2,
+      m i j - (((m i j).appr k : ℕ) : ℤ_[p]) ∈ Ideal.span {((p ^ k : ℕ) : ℤ_[p])} := by
+    intro i j
+    rw [Nat.cast_pow]
+    exact PadicInt.appr_spec k (m i j)
+  have hmul : ∀ (x y : ℤ_[p]) (u v : ℕ),
+      x - (u : ℤ_[p]) ∈ Ideal.span {((p ^ k : ℕ) : ℤ_[p])} →
+        y - (v : ℤ_[p]) ∈ Ideal.span {((p ^ k : ℕ) : ℤ_[p])} →
+        x * y - ((u * v : ℕ) : ℤ_[p]) ∈ Ideal.span {((p ^ k : ℕ) : ℤ_[p])} := by
+    intro x y u v hx hy
+    have hkey : x * y - ((u * v : ℕ) : ℤ_[p])
+        = (x - (u : ℤ_[p])) * y + (u : ℤ_[p]) * (y - (v : ℤ_[p])) := by
+      push_cast
+      ring
+    rw [hkey]
+    exact Ideal.add_mem _ (Ideal.mul_mem_right _ _ hx) (Ideal.mul_mem_left _ _ hy)
+  have hre : m.det - ((((m 0 0).appr k * (m 1 1).appr k : ℕ) : ℤ_[p])
+        - (((m 0 1).appr k * (m 1 0).appr k : ℕ) : ℤ_[p]))
+      = (m 0 0 * m 1 1 - (((m 0 0).appr k * (m 1 1).appr k : ℕ) : ℤ_[p]))
+        - (m 0 1 * m 1 0 - (((m 0 1).appr k * (m 1 0).appr k : ℕ) : ℤ_[p])) := by
+    rw [Matrix.det_fin_two]
+    ring
+  rw [hre]
+  exact Ideal.sub_mem _ (hmul _ _ _ _ (hmem 0 0) (hmem 1 1)) (hmul _ _ _ _ (hmem 0 1) (hmem 1 0))
+
+section levelAction
+
+variable {p : ℕ} [Fact p.Prime] {M : Type} [AddCommGroup M]
+  (hcard : ∀ n : ℕ, Nat.card (Submodule.torsionBy ℤ M ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2)
+  {G' : Type} [Monoid G'] [DistribMulAction G' M]
+
+private theorem rep_basisOfCard_level (g : G') (k : ℕ) (j : Fin 2) :
+    g • ((TateModule.basisOfCard hcard j : TateModule p M) : ℕ → M) k
+      = ((LinearMap.toMatrix (TateModule.basisOfCard hcard) (TateModule.basisOfCard hcard)
+            (TateModule.rep p M G' g) 0 j).appr k : ℤ)
+          • ((TateModule.basisOfCard hcard 0 : TateModule p M) : ℕ → M) k
+        + ((LinearMap.toMatrix (TateModule.basisOfCard hcard) (TateModule.basisOfCard hcard)
+            (TateModule.rep p M G' g) 1 j).appr k : ℤ)
+          • ((TateModule.basisOfCard hcard 1 : TateModule p M) : ℕ → M) k := by
+  have hsum : TateModule.rep p M G' g (TateModule.basisOfCard hcard j)
+      = ∑ i, LinearMap.toMatrix (TateModule.basisOfCard hcard) (TateModule.basisOfCard hcard)
+          (TateModule.rep p M G' g) i j • TateModule.basisOfCard hcard i := by
+    conv_lhs => rw [← Module.Basis.sum_repr (TateModule.basisOfCard hcard)
+      (TateModule.rep p M G' g (TateModule.basisOfCard hcard j))]
+    exact Finset.sum_congr rfl fun i _ => by rw [LinearMap.toMatrix_apply]
+  have hdist : ((∑ i, LinearMap.toMatrix (TateModule.basisOfCard hcard) (TateModule.basisOfCard
+    hcard)
+          (TateModule.rep p M G' g) i j • TateModule.basisOfCard hcard i : TateModule p M) : ℕ → M)
+            k
+      = ∑ i, ((LinearMap.toMatrix (TateModule.basisOfCard hcard) (TateModule.basisOfCard hcard)
+          (TateModule.rep p M G' g) i j).appr k : ℤ)
+            • ((TateModule.basisOfCard hcard i : TateModule p M) : ℕ → M) k := by
+    rw [← TateModule.proj_apply, map_sum]
+    exact Finset.sum_congr rfl fun i _ => by
+      rw [TateModule.proj_apply, TateModule.smul_apply]
+  have hlev := congrArg (fun z : TateModule p M => (z : ℕ → M) k) hsum
+  simp only [TateModule.rep_apply] at hlev
+  rw [hlev, hdist, Fin.sum_univ_two]
+
+end levelAction
+
+section torsionSubtype
+
+variable {F K : Type} [CommRing F] [Field K] [DecidableEq K] [Algebra F K]
+  {W' : WeierstrassCurve F} {p : ℕ} [Fact p.Prime]
+  (hcard : ∀ n : ℕ,
+    Nat.card (Submodule.torsionBy ℤ (W'⁄K).Point ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2)
+
+private noncomputable def basisLevel (k : ℕ) (i : Fin 2) :
+    Submodule.torsionBy ℤ (W'⁄K).Point ((p ^ k : ℕ) : ℤ) :=
+  ⟨((TateModule.basisOfCard hcard i : TateModule p (W'⁄K).Point) : ℕ → (W'⁄K).Point) k,
+    TateModule.proj_mem_torsionBy k (TateModule.basisOfCard hcard i)⟩
+
+private theorem smul_torsionBy_basisOfCard_level (σ : K ≃ₐ[F] K) (k : ℕ) (j : Fin 2) :
+    σ • basisLevel hcard k j
+      = ((LinearMap.toMatrix (TateModule.basisOfCard hcard) (TateModule.basisOfCard hcard)
+            (TateModule.rep p (W'⁄K).Point (K ≃ₐ[F] K) σ) 0 j).appr k : ℤ)
+          • basisLevel hcard k 0
+        + ((LinearMap.toMatrix (TateModule.basisOfCard hcard) (TateModule.basisOfCard hcard)
+            (TateModule.rep p (W'⁄K).Point (K ≃ₐ[F] K) σ) 1 j).appr k : ℤ)
+          • basisLevel hcard k 1 := by
+  refine Subtype.ext ?_
+  rw [Submodule.coe_add, Submodule.coe_smul, Submodule.coe_smul]
+  exact rep_basisOfCard_level hcard σ k j
+
+private theorem exists_natCast_smul_basisLevel (k : ℕ)
+    (Q : Submodule.torsionBy ℤ (W'⁄K).Point ((p ^ k : ℕ) : ℤ)) :
+    ∃ a b : ℕ, (a : ℤ) • basisLevel hcard k 0 + (b : ℤ) • basisLevel hcard k 1 = Q := by
+  obtain ⟨a, b, hab⟩ := TateModule.exists_eq_smul_basisOfCard_apply hcard k Q.property
+  refine ⟨a, b, Subtype.ext ?_⟩
+  rw [Submodule.coe_add, Submodule.coe_smul, Submodule.coe_smul]
+  exact hab
+
+private theorem dvd_of_rel_basisLevel (k : ℕ) (a b : ℤ)
+    (h : a • basisLevel hcard k 0 + b • basisLevel hcard k 1 = 0) :
+    ((p ^ k : ℕ) : ℤ) ∣ a ∧ ((p ^ k : ℕ) : ℤ) ∣ b := by
+  refine TateModule.dvd_of_rel_basisOfCard_apply hcard k a b ?_
+  have hval := congrArg (Subtype.val) h
+  rwa [Submodule.coe_add, Submodule.coe_smul, Submodule.coe_smul] at hval
+
+private theorem natCast_pow_smul_basisLevel (k : ℕ) (i : Fin 2) :
+    ((p ^ k : ℕ) : ℤ) • basisLevel hcard k i = 0 :=
+  Submodule.smul_torsionBy _ _
+
+end torsionSubtype
+
+private theorem units_eq_pow_of_apply_eq_pow {K : Type*} [Monoid K] (σ : K → K) (ζ : Kˣ) {ξ : Kˣ}
+    {N a : ℕ} (hgal : (ξ : K) = σ (ζ : K)) (ha : ∀ μ : K, μ ^ N = 1 → σ μ = μ ^ a)
+    (hζ : ζ ^ N = 1) : ξ = ζ ^ a := by
+  ext
+  rw [hgal, ha _ (by rw [← Units.val_pow_eq_pow_val, hζ, Units.val_one]),
+    Units.val_pow_eq_pow_val]
+
+private theorem dvd_sub_of_pow_eq_zpow {G : Type*} [CommGroup G] {ζ : G} {N a : ℕ} {d : ℤ}
+    (hprim : IsPrimitiveRoot ζ N) (h : ζ ^ a = ζ ^ d) : (N : ℤ) ∣ d - a := by
+  rw [← hprim.zpow_eq_one_iff_dvd, zpow_sub, zpow_natCast, ← h, mul_inv_cancel]
+
+private theorem intCast_mem_span_of_natCast_dvd {A : Type*} [CommRing A] {N : ℕ} {x : ℤ}
+    (h : (N : ℤ) ∣ x) : (x : A) ∈ Ideal.span {(N : A)} := by
+  obtain ⟨c, rfl⟩ := h
+  rw [Int.cast_mul, Int.cast_natCast]
+  exact Ideal.mul_mem_right _ _ (Ideal.mem_span_singleton_self _)
+
+end EPair
+
+open EPair in
+theorem solution (W : WeierstrassCurve ℚ) (p : ℕ) [Fact p.Prime] (hΔ : W.Δ ≠ 0)
+    (hcard : ∀ n : ℕ,
+      Nat.card (Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) : ℤ))
+        = (p ^ n) ^ 2) :
+    (W.tateModuleRep p hcard).DetIsCyclotomic p := by
+  classical
+  have : W.IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+  refine ⟨PadicInt.natCast_mem_maximalIdeal p, fun k σ a ha => ?_⟩
+  have hp : p.Prime := Fact.out
+  have hpk : ((p ^ k : ℕ) : AlgebraicClosure ℚ) ≠ 0 :=
+    Nat.cast_ne_zero.mpr (pow_ne_zero k hp.ne_zero)
+  obtain ⟨e, hl, hr, halt, hgal, hnd⟩ :=
+    W.exists_pairing_torsionBy (K := AlgebraicClosure ℚ) hpk
+  set mZp := LinearMap.toMatrix (TateModule.basisOfCard hcard) (TateModule.basisOfCard hcard)
+    (TateModule.rep p (W⁄(AlgebraicClosure ℚ)).Point
+      (AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) σ) with hmZp
+  set cZ : Matrix (Fin 2) (Fin 2) ℤ := Matrix.of fun i j => ((mZp i j).appr k : ℤ) with hcZ
+  have hprim : IsPrimitiveRoot (e (basisLevel hcard k 0) (basisLevel hcard k 1)) (p ^ k) :=
+    ep1 e hl hr halt hnd _ _
+      (natCast_pow_smul_basisLevel hcard k 0)
+      (exists_natCast_smul_basisLevel hcard k)
+      (dvd_of_rel_basisLevel hcard k)
+  have hdet2 : e (σ • basisLevel hcard k 0) (σ • basisLevel hcard k 1)
+      = e (basisLevel hcard k 0) (basisLevel hcard k 1) ^ cZ.det :=
+    ep2 e hl hr halt cZ
+      (smul_torsionBy_basisOfCard_level hcard σ k 0)
+      (smul_torsionBy_basisOfCard_level hcard σ k 1)
+  have hξ : e (σ • basisLevel hcard k 0) (σ • basisLevel hcard k 1)
+      = e (basisLevel hcard k 0) (basisLevel hcard k 1) ^ a :=
+    units_eq_pow_of_apply_eq_pow σ _ (hgal σ _ _) ha hprim.pow_eq_one
+  have hdvd : ((p ^ k : ℕ) : ℤ) ∣ cZ.det - (a : ℤ) :=
+    dvd_sub_of_pow_eq_zpow hprim (hξ.symm.trans hdet2)
+  have hA := det_fin_two_sub_appr_mem_span mZp k
+  have hdetseam : LinearMap.det ((W.tateModuleRep p hcard).ρ σ) = mZp.det := by
+    rw [hmZp, LinearMap.det_toMatrix]
+    rfl
+  have hcast : ((cZ.det : ℤ) : ℤ_[p])
+      = ((((mZp 0 0).appr k * (mZp 1 1).appr k : ℕ) : ℤ_[p])
+        - (((mZp 0 1).appr k * (mZp 1 0).appr k : ℕ) : ℤ_[p])) := by
+    rw [hcZ, Matrix.det_fin_two]
+    simp only [Matrix.of_apply]
+    push_cast
+    ring
+  have hB : ((cZ.det : ℤ) : ℤ_[p]) - (a : ℤ_[p]) ∈ Ideal.span {((p ^ k : ℕ) : ℤ_[p])} := by
+    have h := intCast_mem_span_of_natCast_dvd (A := ℤ_[p]) hdvd
+    simp only [Int.cast_sub, Int.cast_natCast] at h
+    exact h
+  have hgoal : LinearMap.det ((W.tateModuleRep p hcard).ρ σ) - (a : ℤ_[p])
+      = (mZp.det - ((((mZp 0 0).appr k * (mZp 1 1).appr k : ℕ) : ℤ_[p])
+          - (((mZp 0 1).appr k * (mZp 1 0).appr k : ℕ) : ℤ_[p])))
+        + (((cZ.det : ℤ) : ℤ_[p]) - (a : ℤ_[p])) := by
+    rw [hdetseam, hcast]
+    ring
+  rw [hgoal]
+  exact Ideal.add_mem _ hA hB
+
+end S_WeierstrassCurve_tateModuleRep_detIsCyclotomic
+end P2MW
+export P2MW.S_WeierstrassCurve_tateModuleRep_detIsCyclotomic (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+theorem WeierstrassCurve.tateModuleRep_detIsCyclotomic (W : WeierstrassCurve ℚ) (p : ℕ)
+    [Fact p.Prime] (hΔ : W.Δ ≠ 0)
+    (hcard : ∀ n : ℕ,
+      Nat.card (Submodule.torsionBy ℤ (W⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) : ℤ))
+        = (p ^ n) ^ 2) :
+    (W.tateModuleRep p hcard).DetIsCyclotomic p :=
+  solution W p hΔ hcard
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_tateModuleRep_det_frobenius.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_tateModuleRep_det_frobenius.lean
new file mode 100644
index 0000000000..88f16f72f7
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_tateModuleRep_det_frobenius.lean
@@ -0,0 +1,116 @@
+/-
+Based on Prove2Me node WeierstrassCurve.tateModuleRep_det_frobenius
+(991b63b4-ae92-57e7-88fd-6a81189d203f) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission f40e238c-8add-5e35-845e-82d55fa3ad4f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_TateModule
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Ramification
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_FrobeniusTrace
+public import Mathlib.LinearAlgebra.Determinant
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_GaloisRep_LocalConditions
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_tateModuleRep_detIsCyclotomic
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ValuationSubring_IsFrobeniusAt_apply_eq_pow_of_pow_prime_pow_eq_one
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Determinant of Frobenius at ℓ ≠ p on the Tate module
+
+Theorem statement: `WeierstrassCurve.tateModuleRep_det_frobenius`
+(`991b63b4-ae92-57e7-88fd-6a81189d203f`), by Claude, 2026-09-05.
+
+Proof: submission `f40e238c-8add-5e35-845e-82d55fa3ad4f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $W$ be a Weierstrass curve over $\mathbb{Q}$ and $p$ a prime. Assume $W.\Delta \neq 0$ and
+assume the counting hypothesis that for every $n$ the subgroup of points of $W$ over
+$\overline{\mathbb{Q}}$ annihilated by $p^{n}$ has cardinality $(p^{n})^{2}$; these are exactly the
+data from which the rank-two $p$-adic Galois representation
+[`WeierstrassCurve.tateModuleRep`](def/EllipticCurve_TateModule.html#L851) is formed, its underlying
+module being the group of sequences $(x_{n})$ of points with $p^{n} \cdot x_{n} = 0$ and $p \cdot
+x_{n+1} = x_{n}$, free of rank $2$ over $\mathbb{Z}_{p}$, with the Galois action induced from the
+action on points. Let $\ell$ be a prime with $\ell \neq p$, let $A$ be a valuation subring of
+$\overline{\mathbb{Q}}$ such that the image of $\ell$ lies in the nonunits of $A$, and let $\sigma$
+be a $\mathbb{Q}$-algebra automorphism of $\overline{\mathbb{Q}}$ which lies in the decomposition
+subgroup of $A$ over $\mathbb{Q}$ and acts on the residue field of $A$ by $x \mapsto x^{\ell}$. Then
+the determinant of the $\mathbb{Z}_{p}$-linear endomorphism by which $\sigma$ acts on the Tate
+module equals $\ell$ in $\mathbb{Z}_{p}$. Nothing is asserted about the trace, the characteristic
+polynomial, the case $\ell = p$, or reduction type at $\ell$.
+
+This is the determinant half of the Eichler–Shimura type description of Frobenius on the $p$-adic
+Tate module of an elliptic curve: the determinant is the $p$-adic cyclotomic character, whose value
+at a Frobenius at $\ell$ is $\ell$. It feeds into
+[`WeierstrassCurve.tateModuleRep_charpoly_frobenius`]
+(thm.html#WeierstrassCurve.tateModuleRep_charpoly_frobenius),
+where together with the trace it identifies the characteristic polynomial of Frobenius.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_tateModuleRep_det_frobenius.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_tateModuleRep_det_frobenius
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point ValuationSubring
+
+private lemma padic_sep {p : ℕ} [Fact p.Prime] {x : ℤ_[p]}
+    (h : ∀ n : ℕ, x ∈ Ideal.span {((p ^ n : ℕ) : ℤ_[p])}) : x = 0 := by
+  by_contra hx
+  have hv : x.valuation + 1 ≤ x.valuation := by
+    refine (PadicInt.mem_span_pow_iff_le_valuation x hx _).mp ?_
+    have h2 := h (x.valuation + 1)
+    rwa [Nat.cast_pow] at h2
+  omega
+
+theorem solution (W : WeierstrassCurve ℚ) (p : ℕ) [Fact p.Prime] (hΔ : W.Δ ≠ 0)
+    (hcard : ∀ n : ℕ, Nat.card (Submodule.torsionBy ℤ
+      (W⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2)
+    (ℓ : ℕ) (hℓ : ℓ.Prime) (hℓp : ℓ ≠ p)
+    (A : ValuationSubring (AlgebraicClosure ℚ)) (hA : A.LiesOverPrime ℓ)
+    (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) (hσ : A.IsFrobeniusAt σ ℓ) :
+    LinearMap.det ((W.tateModuleRep p hcard).ρ σ) = (ℓ : ℤ_[p]) := by
+  have hmem : ∀ n : ℕ,
+      LinearMap.det ((W.tateModuleRep p hcard).ρ σ) - ((ℓ : ℕ) : ℤ_[p]) ∈
+        Ideal.span {((p ^ n : ℕ) : ℤ_[p])} := fun n =>
+    (W.tateModuleRep_detIsCyclotomic p hΔ hcard).2 n σ ℓ fun μ hμ =>
+      ValuationSubring.IsFrobeniusAt.apply_eq_pow_of_pow_prime_pow_eq_one Fact.out hℓ hℓp A hA hσ n
+      μ hμ
+  exact sub_eq_zero.mp (padic_sep hmem)
+
+end S_WeierstrassCurve_tateModuleRep_det_frobenius
+end P2MW
+export P2MW.S_WeierstrassCurve_tateModuleRep_det_frobenius (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point ValuationSubring
+
+theorem WeierstrassCurve.tateModuleRep_det_frobenius
+    (W : WeierstrassCurve ℚ) (p : ℕ) [Fact p.Prime] (hΔ : W.Δ ≠ 0)
+    (hcard : ∀ n : ℕ, Nat.card (Submodule.torsionBy ℤ
+      (W⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2)
+    (ℓ : ℕ) (hℓ : ℓ.Prime) (hℓp : ℓ ≠ p)
+    (A : ValuationSubring (AlgebraicClosure ℚ)) (hA : A.LiesOverPrime ℓ)
+    (σ : AlgebraicClosure ℚ ≃ₐ[ℚ] AlgebraicClosure ℚ) (hσ : A.IsFrobeniusAt σ ℓ) :
+    LinearMap.det ((W.tateModuleRep p hcard).ρ σ) = (ℓ : ℤ_[p]) :=
+  solution W p hΔ hcard ℓ hℓ hℓp A hA σ hσ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_tateModuleRep_isUnramifiedAt_of_isGoodPrimeFor.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_tateModuleRep_isUnramifiedAt_of_isGoodPrimeFor.lean
new file mode 100644
index 0000000000..44b5adf807
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_tateModuleRep_isUnramifiedAt_of_isGoodPrimeFor.lean
@@ -0,0 +1,220 @@
+/-
+Based on Prove2Me node WeierstrassCurve.tateModuleRep_isUnramifiedAt_of_isGoodPrimeFor
+(ced9024f-2556-55f3-9da3-b48d26fa63f1) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 38965f08-dd3d-5d76-89ab-796959e795aa
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_EllipticCurve_TateModule
+public import LeanPool.FLTEichlerShimura.Definitions.Def_FLTPrelim_Modularity
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_galoisRepUnramifiedAt_of_hasGoodReduction
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Tate module unramified at good primes q ≠ p
+
+Theorem statement: `WeierstrassCurve.tateModuleRep_isUnramifiedAt_of_isGoodPrimeFor`
+(`ced9024f-2556-55f3-9da3-b48d26fa63f1`), by Claude, 2026-09-05.
+
+Proof: submission `38965f08-dd3d-5d76-89ab-796959e795aa`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $W$ be a Weierstrass curve over $\mathbb{Z}$ and let $p$ be a prime. Assume the counting
+hypothesis `hcard`: for every $n$, the subgroup of elements killed by $p^{n}$ in the group of points
+of the base change of $W$ along $\mathbb{Z} \to \mathbb{Q}$, taken over $\overline{\mathbb{Q}}$
+(realised as `AlgebraicClosure ℚ`), has cardinality $(p^{n})^{2}$. Let $q$ be a prime with $q \neq
+p$ such that $W$ is a good prime model at $q$ in the sense of `IsGoodPrimeFor`, i.e. $(q :
+\mathbb{Z})$ does not divide the discriminant $W.\Delta$ of the given integral model. The conclusion
+is that the $p$-adic Tate module representation `tateModuleRep` attached to $W_{\mathbb{Q}}$ and to
+`hcard` — the Galois module of sequences $(x_n)$ of $\overline{\mathbb{Q}}$-points with $p^{n} x_n =
+0$ and $p\,x_{n+1} = x_n$, which `hcard` makes free of rank $2$ over $\mathbb{Z}_p$ with its
+adically continuous action of $\mathrm{Aut}_{\mathbb{Q}}(\overline{\mathbb{Q}})$ — is unramified at
+$q$ in the sense of [`GaloisRepAdic.IsUnramifiedAt`](def/GaloisRep_Adic.html#L37): for every
+valuation subring $P$ of $\overline{\mathbb{Q}}$ with $q$ a nonunit of $P$, every element of the
+image in $\mathrm{Aut}_{\mathbb{Q}}(\overline{\mathbb{Q}})$ of the inertia subgroup of $P$ over
+$\mathbb{Q}$ acts on the Tate module as the identity endomorphism.
+
+This is the easy direction of the criterion of Néron–Ogg–Shafarevich for elliptic curves: good
+reduction at $q$ forces the $p$-adic Tate module to be inertially trivial at $q$ for $p \neq q$,
+here with the good-reduction hypothesis read off as non-divisibility of the discriminant of the
+given integral model by $q$. It supplies the "unramified outside $S$" clause in the deformation
+conditions imposed on the Tate module representation of a Frey curve, and is used in the
+verification of those conditions after base change and in the identification of the modular level.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_tateModuleRep_isUnramifiedAt_of_isGoodPrimeFor.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_tateModuleRep_isUnramifiedAt_of_isGoodPrimeFor
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_WeierstrassCurve_tateModuleRep_isUnramifiedAt_of_isGoodPrimeFor.WeierstrassCurve \
+  WeierstrassCurve.Affine WeierstrassCurve.Affine.Point"
+
+noncomputable section
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine HasGoodReduction a₃ a₁ map isIntegral_of_exists_lift a₄ \
+  valuation_Δ_aux_eq_of_isIntegral a₂ a₆ reduction IsIntegral Affine.Point map_Δ map_a₆ map_a₁ \
+  map_a₄ Δ VariableChange map_a₂ IsMinimal valuation_Δ_aux map_a₃ tateModuleRep \
+  Affine.Point.GaloisRepUnramifiedAt card IsGoodPrimeFor galoisRepUnramifiedAt_of_hasGoodReduction"
+namespace D5Sol
+p2m_open "WeierstrassCurve"
+
+open IsDiscreteValuationRing IsLocalRing
+
+section Bridge
+
+variable (q : ℕ) [hq : Fact q.Prime]
+
+scoped instance spanNatPrime_isPrime : (Ideal.span {(q : ℤ)}).IsPrime :=
+  (Ideal.span_singleton_prime (by exact_mod_cast hq.out.ne_zero)).mpr
+    (Nat.prime_iff_prime_int.mp hq.out)
+
+abbrev Zq : Type := Localization.AtPrime (Ideal.span {(q : ℤ)})
+
+theorem primeCompl_isUnit (y : (Ideal.span {(q : ℤ)}).primeCompl) :
+    IsUnit (algebraMap ℤ ℚ y) := by
+  have hy : (y : ℤ) ≠ 0 := fun h => y.2 (h ▸ (Ideal.span {(q : ℤ)}).zero_mem)
+  simpa using IsUnit.mk0 ((y : ℤ) : ℚ) (by exact_mod_cast hy)
+
+scoped instance instAlgebraZqRat : Algebra (Zq q) ℚ :=
+  (IsLocalization.lift (M := (Ideal.span {(q : ℤ)}).primeCompl)
+    (g := algebraMap ℤ ℚ) (primeCompl_isUnit q)).toAlgebra
+
+theorem algebraMap_Zq_apply (z : ℤ) :
+    algebraMap (Zq q) ℚ (algebraMap ℤ (Zq q) z) = algebraMap ℤ ℚ z :=
+  IsLocalization.lift_eq (M := (Ideal.span {(q : ℤ)}).primeCompl) (g := algebraMap ℤ ℚ)
+    (primeCompl_isUnit q) z
+
+scoped instance instIsDiscreteValuationRingZq : IsDiscreteValuationRing (Zq q) :=
+  IsLocalization.AtPrime.isDiscreteValuationRing_of_dedekind_domain ℤ
+    (fun h => by
+      have h0 : (q : ℤ) = 0 := Ideal.span_singleton_eq_bot.mp h
+      exact hq.out.ne_zero (by exact_mod_cast h0)) _
+
+scoped instance instIsFractionRingZqRat : IsFractionRing (Zq q) ℚ := by
+  have := IsScalarTower.of_algebraMap_eq (R := ℤ) (S := Zq q) (A := ℚ) fun x =>
+    (algebraMap_Zq_apply q x).symm
+  exact IsFractionRing.isFractionRing_of_isDomain_of_isLocalization
+    (Ideal.span {(q : ℤ)}).primeCompl (Zq q) ℚ
+
+theorem irreducible_q : Irreducible ((q : ℕ) : Zq q) := by
+  rw [IsDiscreteValuationRing.irreducible_iff_uniformizer]
+  rw [← Localization.AtPrime.map_eq_maximalIdeal (I := Ideal.span {(q : ℤ)})]
+  rw [Ideal.map_span, Set.image_singleton]
+  norm_num
+
+theorem isUnit_intCast_of_not_dvd {x : ℤ} (hx : ¬ (q : ℤ) ∣ x) : IsUnit ((x : ℤ) : Zq q) := by
+  have hqp : Prime (q : ℤ) := Nat.prime_iff_prime_int.mp hq.out
+  have hcop : IsCoprime (q : ℤ) x := hqp.coprime_iff_not_dvd.mpr hx
+  obtain ⟨u, v, huv⟩ := hcop.map (algebraMap ℤ (Zq q))
+  have h1 : IsUnit (u * algebraMap ℤ (Zq q) (q : ℤ) + v * algebraMap ℤ (Zq q) x) := by
+    rw [huv]; exact isUnit_one
+  rcases IsLocalRing.isUnit_or_isUnit_of_isUnit_add h1 with h | h
+  · exact absurd (by simpa using isUnit_of_mul_isUnit_right h) (irreducible_q q).not_isUnit
+  · simpa using isUnit_of_mul_isUnit_right h
+
+theorem hasGoodReduction_map (W : WeierstrassCurve ℤ) (hgood : ¬ (q : ℤ) ∣ W.Δ) :
+    (W.map (Int.castRingHom ℚ)).HasGoodReduction (Zq q) := by
+  set E := W.map (Int.castRingHom ℚ) with hE
+  have hcoef : ∀ z : ℤ, algebraMap (Zq q) ℚ ((z : ℤ) : Zq q) = (z : ℚ) := by
+    intro z
+    rw [← eq_intCast (algebraMap ℤ (Zq q)) z, algebraMap_Zq_apply, eq_intCast]
+  have hInt : IsIntegral (Zq q) E := by
+    refine isIntegral_of_exists_lift (Zq q) ⟨W.a₁, ?_⟩ ⟨W.a₂, ?_⟩ ⟨W.a₃, ?_⟩ ⟨W.a₄, ?_⟩ ⟨W.a₆, ?_⟩
+    all_goals simp only [hE, map_a₁, map_a₂, map_a₃, map_a₄, map_a₆, eq_intCast, hcoef]
+  have hval_unit : ∀ r : Zq q, IsUnit r →
+      (IsDiscreteValuationRing.maximalIdeal (Zq q)).valuation ℚ (algebraMap (Zq q) ℚ r) = 1 := by
+    intro r hr
+    rcases lt_or_eq_of_le
+        ((IsDiscreteValuationRing.maximalIdeal (Zq q)).valuation_le_one (K := ℚ) r) with h | h
+    · exact absurd ((IsDiscreteValuationRing.maximalIdeal (Zq q)).valuation_lt_one_iff_mem
+        (K := ℚ) r |>.mp h) (fun hm => (mem_nonunits_iff.mp
+          ((IsLocalRing.mem_maximalIdeal r).mp hm)) hr)
+    · exact h
+  have hΔ : (IsDiscreteValuationRing.maximalIdeal (Zq q)).valuation ℚ E.Δ = 1 := by
+    have h1 : E.Δ = algebraMap (Zq q) ℚ ((W.Δ : ℤ) : Zq q) := by
+      rw [hcoef, hE, map_Δ, eq_intCast]
+    rw [h1]
+    exact hval_unit _ (isUnit_intCast_of_not_dvd q hgood)
+  have := hInt
+  have hMin : IsMinimal (Zq q) E := by
+    refine ⟨⟨by simpa using hInt, ?_⟩⟩
+    intro C hC _
+    have hle := (valuation_Δ_aux (Zq q) (C • E)).2
+    have heq : ((valuation_Δ_aux (Zq q) ((1 : VariableChange ℚ) • E)) :
+        WithZero (Multiplicative ℤ)) = 1 := by
+      rw [one_smul, valuation_Δ_aux_eq_of_isIntegral (Zq q) E]
+      exact hΔ
+    exact Subtype.coe_le_coe.mp (by rw [heq]; exact hle)
+  exact { toIsMinimal := hMin, goodReduction := hΔ }
+
+end Bridge
+
+theorem galoisRepUnramifiedAt_of_goodReduction_of_not_dvd (W : WeierstrassCurve ℤ) {q n : ℕ}
+    (hq : q.Prime) (hqn : ¬ q ∣ n) (hgood : W.IsGoodPrimeFor q) :
+    WeierstrassCurve.Affine.Point.GaloisRepUnramifiedAt (K := AlgebraicClosure ℚ) ℚ
+      (W.map (Int.castRingHom ℚ)) n q := by
+  have : Fact q.Prime := ⟨hq⟩
+  have := hasGoodReduction_map q W hgood
+  exact WeierstrassCurve.galoisRepUnramifiedAt_of_hasGoodReduction (Zq q)
+    (W.map (Int.castRingHom ℚ)) hq (irreducible_q q) hqn
+
+theorem galoisRepUnramifiedAt_pow_of_goodReduction (W : WeierstrassCurve ℤ) {q p : ℕ}
+    (hq : q.Prime) (hp : p.Prime) (hqp : q ≠ p) (hgood : W.IsGoodPrimeFor q) (k : ℕ) :
+    WeierstrassCurve.Affine.Point.GaloisRepUnramifiedAt (K := AlgebraicClosure ℚ) ℚ
+      (W.map (Int.castRingHom ℚ)) (p ^ k) q :=
+  galoisRepUnramifiedAt_of_goodReduction_of_not_dvd W hq
+    (fun h => hqp ((Nat.prime_dvd_prime_iff_eq hq hp).mp (hq.dvd_of_dvd_pow h))) hgood
+
+end WeierstrassCurve.D5Sol
+end
+
+theorem solution (W : WeierstrassCurve ℤ) (p : ℕ)
+    [Fact p.Prime]
+    (hcard : ∀ n : ℕ, Nat.card (Submodule.torsionBy ℤ
+      ((W.map (Int.castRingHom ℚ))⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2)
+    {q : ℕ} (hq : q.Prime) (hqp : q ≠ p) (hgood : W.IsGoodPrimeFor q) :
+    ((W.map (Int.castRingHom ℚ)).tateModuleRep p hcard).IsUnramifiedAt q :=
+  fun A hA σ hσ =>
+    TateModule.rep_eq_one_of_forall_torsionBy σ fun k m hm =>
+      congrArg Subtype.val
+        (WeierstrassCurve.D5Sol.galoisRepUnramifiedAt_pow_of_goodReduction W hq Fact.out hqp hgood k
+          A hA σ hσ ⟨m, hm⟩)
+
+end S_WeierstrassCurve_tateModuleRep_isUnramifiedAt_of_isGoodPrimeFor
+end P2MW
+export P2MW.S_WeierstrassCurve_tateModuleRep_isUnramifiedAt_of_isGoodPrimeFor (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+theorem WeierstrassCurve.tateModuleRep_isUnramifiedAt_of_isGoodPrimeFor (W : WeierstrassCurve ℤ)
+    (p : ℕ)
+    [Fact p.Prime]
+    (hcard : ∀ n : ℕ, Nat.card (Submodule.torsionBy ℤ
+      ((W.map (Int.castRingHom ℚ))⁄(AlgebraicClosure ℚ)).Point ((p ^ n : ℕ) : ℤ)) = (p ^ n) ^ 2)
+    {q : ℕ} (hq : q.Prime) (hqp : q ≠ p) (hgood : W.IsGoodPrimeFor q) :
+    ((W.map (Int.castRingHom ℚ)).tateModuleRep p hcard).IsUnramifiedAt q :=
+  solution W p hcard hq hqp hgood
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_valuation_le_one_of_equation.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_valuation_le_one_of_equation.lean
new file mode 100644
index 0000000000..60a7d6e985
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_valuation_le_one_of_equation.lean
@@ -0,0 +1,138 @@
+/-
+Based on Prove2Me node WeierstrassCurve.valuation_le_one_of_equation
+(7ace9a12-f21c-52f3-b4eb-00dc8d903bfb) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 5212232f-6312-5cdb-a6d0-f291b9e4b5fc
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Basic
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Reduction
+
+import Mathlib.RingTheory.DedekindDomain.AdicValuation
+
+/-!
+# Integral x forces integral y on an integral Weierstrass model
+
+Theorem statement: `WeierstrassCurve.valuation_le_one_of_equation`
+(`7ace9a12-f21c-52f3-b4eb-00dc8d903bfb`), by Claude, 2026-09-05.
+
+Proof: submission `5212232f-6312-5cdb-a6d0-f291b9e4b5fc`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative domain which is a discrete valuation ring, and let $K$ be a field equipped
+with an $R$-algebra structure making it a field of fractions of $R$. Let $W$ be a Weierstrass curve
+over $K$ which is integral over $R$ in the sense of the class `WeierstrassCurve.IsIntegral`, so that
+each of the coefficients $a_1, a_2, a_3, a_4, a_6$ of $W$ is the image in $K$ of an element of $R$.
+Write $v$ for the $K$-valuation `IsDedekindDomain.HeightOneSpectrum.valuation` attached to the
+maximal ideal of $R$, a multiplicatively written valuation for which $v(t) \le 1$ exactly when $t$
+lies in $R$. Let $x, y \in K$ satisfy the affine Weierstrass equation of $W$, namely $y^2 + a_1 x y
++ a_3 y = x^3 + a_2 x^2 + a_4 x + a_6$, and assume $v(x) \le 1$. Then $v(y) \le 1$.
+
+This is the standard integrality statement for points on a Weierstrass equation with coefficients in
+a discrete valuation ring: a point whose $x$-coordinate is integral has integral $y$-coordinate,
+because $y$ is a root of a monic quadratic with integral coefficients. It is used in the analysis of
+the reduction map on points, where the kernel is identified with the points having non-integral
+$x$-coordinate; it is cited by
+[`WeierstrassCurve.reducePoint_add`]
+(thm.html#WeierstrassCurve.reducePoint_add),
+[`WeierstrassCurve.reducePoint_some_add_some_of_le_one`]
+(thm.html#WeierstrassCurve.reducePoint_some_add_some_of_le_one)
+and
+[`WeierstrassCurve.reducePoint_some_add_some_of_not_le_one`]
+(thm.html#WeierstrassCurve.reducePoint_some_add_some_of_not_le_one).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_valuation_le_one_of_equation.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+open WeierstrassCurve IsDiscreteValuationRing IsLocalRing IsDedekindDomain.HeightOneSpectrum
+
+namespace YIntegral
+
+theorem valuation_y_le_one (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+    {K : Type*} [Field K] [Algebra R K] [IsFractionRing R K] (W : WeierstrassCurve K)
+    [W.IsIntegral R] {x y : K} (hE : W.toAffine.Equation x y)
+    (hx : valuation K (maximalIdeal R) x ≤ 1) :
+    valuation K (maximalIdeal R) y ≤ 1 := by
+  by_contra hy
+  rw [not_le] at hy
+  rw [Affine.equation_iff] at hE
+  have ha₁ : valuation K (maximalIdeal R) W.a₁ ≤ 1 := by
+    rw [← integralModel_a₁_eq R W]; exact valuation_le_one _ _
+  have ha₂ : valuation K (maximalIdeal R) W.a₂ ≤ 1 := by
+    rw [← integralModel_a₂_eq R W]; exact valuation_le_one (maximalIdeal R) _
+  have ha₃ : valuation K (maximalIdeal R) W.a₃ ≤ 1 := by
+    rw [← integralModel_a₃_eq R W]; exact valuation_le_one (maximalIdeal R) _
+  have ha₄ : valuation K (maximalIdeal R) W.a₄ ≤ 1 := by
+    rw [← integralModel_a₄_eq R W]; exact valuation_le_one (maximalIdeal R) _
+  have ha₆ : valuation K (maximalIdeal R) W.a₆ ≤ 1 := by
+    rw [← integralModel_a₆_eq R W]; exact valuation_le_one (maximalIdeal R) _
+  have hy0 : valuation K (maximalIdeal R) y ≠ 0 := (zero_lt_one.trans hy).ne'
+  have h2 : valuation K (maximalIdeal R) y < valuation K (maximalIdeal R) (y ^ 2) := by
+    rw [map_pow, pow_two]
+    calc valuation K (maximalIdeal R) y = valuation K (maximalIdeal R) y * 1 := (mul_one _).symm
+      _ < valuation K (maximalIdeal R) y * valuation K (maximalIdeal R) y :=
+          mul_lt_mul_of_pos_left hy (zero_lt_iff.2 hy0)
+  have hxy : valuation K (maximalIdeal R) (W.a₁ * x * y) ≤ valuation K (maximalIdeal R) y := by
+    rw [map_mul, map_mul]
+    calc valuation K (maximalIdeal R) W.a₁ * valuation K (maximalIdeal R) x
+          * valuation K (maximalIdeal R) y
+        ≤ 1 * 1 * valuation K (maximalIdeal R) y := mul_le_mul' (mul_le_mul' ha₁ hx) le_rfl
+      _ = valuation K (maximalIdeal R) y := by rw [one_mul, one_mul]
+  have ha₃y : valuation K (maximalIdeal R) (W.a₃ * y) ≤ valuation K (maximalIdeal R) y := by
+    rw [map_mul]
+    calc valuation K (maximalIdeal R) W.a₃ * valuation K (maximalIdeal R) y
+        ≤ 1 * valuation K (maximalIdeal R) y := mul_le_mul' ha₃ le_rfl
+      _ = valuation K (maximalIdeal R) y := one_mul _
+  have e1 : valuation K (maximalIdeal R) (y ^ 2 + W.a₁ * x * y)
+      = valuation K (maximalIdeal R) (y ^ 2) :=
+    Valuation.map_add_eq_of_lt_left _ (lt_of_le_of_lt hxy h2)
+  have e2 : valuation K (maximalIdeal R) (y ^ 2 + W.a₁ * x * y + W.a₃ * y)
+      = valuation K (maximalIdeal R) (y ^ 2) := by
+    rw [Valuation.map_add_eq_of_lt_left _ (by rw [e1]; exact lt_of_le_of_lt ha₃y h2), e1]
+  have hR : valuation K (maximalIdeal R) (x ^ 3 + W.a₂ * x ^ 2 + W.a₄ * x + W.a₆) ≤ 1 := by
+    have hx3 : valuation K (maximalIdeal R) (x ^ 3) ≤ 1 := by rw [map_pow]; exact pow_le_one' hx 3
+    have hax2 : valuation K (maximalIdeal R) (W.a₂ * x ^ 2) ≤ 1 := by
+      rw [map_mul, map_pow]; exact mul_le_one' ha₂ (pow_le_one' hx 2)
+    have hax : valuation K (maximalIdeal R) (W.a₄ * x) ≤ 1 := by
+      rw [map_mul]; exact mul_le_one' ha₄ hx
+    exact Valuation.map_add_le _ (Valuation.map_add_le _ (Valuation.map_add_le _ hx3 hax2) hax) ha₆
+  rw [hE] at e2
+  exact absurd (hy.trans (h2.trans_le (e2 ▸ hR))) (lt_irrefl 1)
+
+end YIntegral
+
+theorem solution
+    (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+    {K : Type*} [Field K] [Algebra R K] [IsFractionRing R K]
+    (W : WeierstrassCurve K) [W.IsIntegral R] {x y : K} (h : W.toAffine.Equation x y)
+    (hx : IsDedekindDomain.HeightOneSpectrum.valuation K (maximalIdeal R) x ≤ 1) :
+    IsDedekindDomain.HeightOneSpectrum.valuation K (maximalIdeal R) y ≤ 1 :=
+  YIntegral.valuation_y_le_one R W h hx
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.valuation_le_one_of_equation
+    (R : Type*) [CommRing R] [IsDomain R] [IsDiscreteValuationRing R]
+    {K : Type*} [Field K] [Algebra R K] [IsFractionRing R K]
+    (W : WeierstrassCurve K) [W.IsIntegral R] {x y : K} (h : W.toAffine.Equation x y)
+    (hx : IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R) x
+      ≤ 1) :
+    IsDedekindDomain.HeightOneSpectrum.valuation K (IsDiscreteValuationRing.maximalIdeal R) y ≤ 1 :=
+  solution R W h hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_variableChange_mk_smul_eq_self_of_pow_three_eq_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_variableChange_mk_smul_eq_self_of_pow_three_eq_one.lean
new file mode 100644
index 0000000000..5d0bda539b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_variableChange_mk_smul_eq_self_of_pow_three_eq_one.lean
@@ -0,0 +1,84 @@
+/-
+Based on Prove2Me node WeierstrassCurve.variableChange_mk_smul_eq_self_of_pow_three_eq_one
+(28399d01-a06d-5210-a1b1-25699852a767) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 14646b99-58e5-5b07-927d-49304b9439cb
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.VariableChange
+
+/-!
+# Scaling by a cube root of unity fixes y² = x³ + B
+
+Theorem statement: `WeierstrassCurve.variableChange_mk_smul_eq_self_of_pow_three_eq_one`
+(`28399d01-a06d-5210-a1b1-25699852a767`), by Claude, 2026-09-05.
+
+Proof: submission `14646b99-58e5-5b07-927d-49304b9439cb`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring, let $u \in R^\times$ be a unit whose image in $R$ satisfies $u^3 =
+1$, and let $B \in R$. Consider the Weierstrass curve over $R$ with coefficients $a_1 = a_2 = a_3 =
+a_4 = 0$ and $a_6 = B$, that is, the curve $y^2 = x^3 + B$, and the variable change $\langle u, 0,
+0, 0\rangle$ with scaling unit $u$ and translation parameters $r = s = t = 0$, i.e. the substitution
+$(x, y) \mapsto (u^2 x, u^3 y)$ in Mathlib's normalisation. The assertion is that the action of this
+variable change on that curve returns the very same curve: the resulting Weierstrass coefficients
+are again $0, 0, 0, 0, B$, an equality of elements of `WeierstrassCurve R`. Concretely, the four
+vanishing coefficients are unchanged because the translation parameters are zero, and the
+transformed constant term is $u^{-6} B$, which equals $B$ because $u^3 = 1$ forces $(u^{-1})^6 = 1$.
+
+Over a ring containing a primitive cube root of unity $\omega$, this is the standard order-$3$
+automorphism of a curve with $j = 0$, the source of the extra automorphisms of $y^2 = x^3 + B$. It
+is used in the computations of stabilisers and automorphism orders at the point $j = 0$, including
+the counts of moduli points with $j = 0$ and the construction of a variable change of additive order
+$3$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_variableChange_mk_smul_eq_self_of_pow_three_eq_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+theorem solution
+    {R : Type*} [CommRing R] (u : Rˣ) (hu : (u : R) ^ 3 = 1) (B : R) :
+    (⟨u, 0, 0, 0⟩ : WeierstrassCurve.VariableChange R) • (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve R) =
+      ⟨0, 0, 0, 0, B⟩ := by
+  have h1 : ((u⁻¹ : Rˣ) : R) * (u : R) = 1 := by
+    rw [← Units.val_mul, inv_mul_cancel, Units.val_one]
+  have h3 : ((u⁻¹ : Rˣ) : R) ^ 3 = 1 := by
+    calc ((u⁻¹ : Rˣ) : R) ^ 3 = ((u⁻¹ : Rˣ) : R) ^ 3 * (u : R) ^ 3 := by rw [hu, mul_one]
+      _ = (((u⁻¹ : Rˣ) : R) * (u : R)) ^ 3 := by ring
+      _ = 1 := by rw [h1, one_pow]
+  have h6 : ((u⁻¹ : Rˣ) : R) ^ 6 = 1 := by
+    calc ((u⁻¹ : Rˣ) : R) ^ 6 = (((u⁻¹ : Rˣ) : R) ^ 3) ^ 2 := by ring
+      _ = 1 := by rw [h3, one_pow]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_ <;>
+    simp only [WeierstrassCurve.variableChange_a₁, WeierstrassCurve.variableChange_a₂,
+      WeierstrassCurve.variableChange_a₃, WeierstrassCurve.variableChange_a₄,
+      WeierstrassCurve.variableChange_a₆]
+  · ring
+  · ring
+  · ring
+  · ring
+  · linear_combination B * h6
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.variableChange_mk_smul_eq_self_of_pow_three_eq_one
+    {R : Type*} [CommRing R] (u : Rˣ) (hu : (u : R) ^ 3 = 1) (B : R) :
+    (⟨u, 0, 0, 0⟩ : WeierstrassCurve.VariableChange R) • (⟨0, 0, 0, 0, B⟩ : WeierstrassCurve R) =
+      ⟨0, 0, 0, 0, B⟩ := by
+  exact solution u hu B
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_variableChange_mk_smul_eq_self_of_sq_eq_neg_one.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_variableChange_mk_smul_eq_self_of_sq_eq_neg_one.lean
new file mode 100644
index 0000000000..f25be4f073
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_variableChange_mk_smul_eq_self_of_sq_eq_neg_one.lean
@@ -0,0 +1,95 @@
+/-
+Based on Prove2Me node WeierstrassCurve.variableChange_mk_smul_eq_self_of_sq_eq_neg_one
+(9275d3a3-2f26-5b3f-bc7f-e4fd49f93937) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6f7ccc40-1684-5b0c-9690-8d627da65aae
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.VariableChange
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Scaling by u with u²=-1 fixes y²=x³+Ax
+
+Theorem statement: `WeierstrassCurve.variableChange_mk_smul_eq_self_of_sq_eq_neg_one`
+(`9275d3a3-2f26-5b3f-bc7f-e4fd49f93937`), by Claude, 2026-09-05.
+
+Proof: submission `6f7ccc40-1684-5b0c-9690-8d627da65aae`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring, let $u \in R^\times$ be a unit whose image in $R$ satisfies $(u)^2 =
+-1$, and let $A \in R$. Consider the Weierstrass curve over $R$ with coefficients $a_1 = a_2 = a_3 =
+0$, $a_4 = A$, $a_6 = 0$, i.e. the equation $y^2 = x^3 + Ax$, and the element $(u, r, s, t) = (u, 0,
+0, 0)$ of Mathlib's group `WeierstrassCurve.VariableChange R` of Weierstrass changes of variables.
+The assertion is that this change of variables, acting on the left in Mathlib's scalar action of
+`WeierstrassCurve.VariableChange R` on `WeierstrassCurve R`, leaves that curve unchanged: the
+transformed curve is again $\langle 0, 0, 0, A, 0\rangle$, as an equality of Weierstrass curves
+(equality of all five coefficients). Concretely, since $r = s = t = 0$ the transformed coefficients
+are $u^{-i} a_i$, and the only nontrivial component is $a_4' = u^{-4} A = A$, because $(u)^4 =
+((u)^2)^2 = (-1)^2 = 1$.
+
+For $u$ a square root of $-1$ this is the order-four automorphism $(x,y) \mapsto (-x, u^{-3} y)$ of
+the curve $y^2 = x^3 + Ax$ of $j$-invariant $1728$, the source of complex multiplication by $i$ on
+such curves. It is used in the computation of the stabiliser of, and the count of moduli points
+with, $j = 1728$, and in the construction of a point-order datum exhibiting an automorphism acting
+non-linearly on torsion.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_variableChange_mk_smul_eq_self_of_sq_eq_neg_one.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_variableChange_mk_smul_eq_self_of_sq_eq_neg_one
+
+theorem solution
+    {R : Type*} [CommRing R] (u : Rˣ) (hu : (u : R) ^ 2 = -1) (A : R) :
+    (⟨u, 0, 0, 0⟩ : WeierstrassCurve.VariableChange R) • (⟨0, 0, 0, A, 0⟩ : WeierstrassCurve R) =
+      ⟨0, 0, 0, A, 0⟩ := by
+  have h1 : ((u⁻¹ : Rˣ) : R) * (u : R) = 1 := by
+    rw [← Units.val_mul, inv_mul_cancel, Units.val_one]
+  have hu4 : (u : R) ^ 4 = 1 := by
+    calc (u : R) ^ 4 = ((u : R) ^ 2) ^ 2 := by ring
+      _ = 1 := by rw [hu]; ring
+  have h4 : ((u⁻¹ : Rˣ) : R) ^ 4 = 1 := by
+    calc ((u⁻¹ : Rˣ) : R) ^ 4 = ((u⁻¹ : Rˣ) : R) ^ 4 * (u : R) ^ 4 := by rw [hu4, mul_one]
+      _ = (((u⁻¹ : Rˣ) : R) * (u : R)) ^ 4 := by ring
+      _ = 1 := by rw [h1, one_pow]
+  refine WeierstrassCurve.ext ?_ ?_ ?_ ?_ ?_ <;>
+    simp only [WeierstrassCurve.variableChange_a₁, WeierstrassCurve.variableChange_a₂,
+      WeierstrassCurve.variableChange_a₃, WeierstrassCurve.variableChange_a₄,
+      WeierstrassCurve.variableChange_a₆]
+  · ring
+  · ring
+  · ring
+  · linear_combination A * h4
+  · ring
+
+end S_WeierstrassCurve_variableChange_mk_smul_eq_self_of_sq_eq_neg_one
+end P2MW
+export P2MW.S_WeierstrassCurve_variableChange_mk_smul_eq_self_of_sq_eq_neg_one (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.variableChange_mk_smul_eq_self_of_sq_eq_neg_one
+    {R : Type*} [CommRing R] (u : Rˣ) (hu : (u : R) ^ 2 = -1) (A : R) :
+    (⟨u, 0, 0, 0⟩ : WeierstrassCurve.VariableChange R) • (⟨0, 0, 0, A, 0⟩ : WeierstrassCurve R) =
+      ⟨0, 0, 0, A, 0⟩ :=
+  solution u hu A
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_variableChange_smul_eq_self_iff_of_c4_ne_zero_of_c6_ne_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_variableChange_smul_eq_self_iff_of_c4_ne_zero_of_c6_ne_zero.lean
new file mode 100644
index 0000000000..3c911f7a56
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_variableChange_smul_eq_self_iff_of_c4_ne_zero_of_c6_ne_zero.lean
@@ -0,0 +1,149 @@
+/-
+Based on Prove2Me node WeierstrassCurve.variableChange_smul_eq_self_iff_of_c4_ne_zero_of_c6_ne_zero
+(c2402a71-5a06-5aa9-b520-f0a516d8fb94) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission efd829ca-2fed-54ed-82d3-b3fb840e1be7
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.VariableChange
+
+import Mathlib.RingTheory.SimpleRing.Principal
+
+/-!
+# Stabiliser of a Weierstrass model with c₄,c₆≠ 0
+
+Theorem statement: `WeierstrassCurve.variableChange_smul_eq_self_iff_of_c4_ne_zero_of_c6_ne_zero`
+(`c2402a71-5a06-5aa9-b520-f0a516d8fb94`), by Claude, 2026-09-05.
+
+Proof: submission `efd829ca-2fed-54ed-82d3-b3fb840e1be7`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field in which $2\neq 0$ and $3\neq 0$, let $E$ be a Weierstrass curve over $F$ (a
+tuple of coefficients $a_1,a_2,a_3,a_4,a_6$) whose invariants satisfy $c_4(E)\neq 0$ and $c_6(E)\neq
+0$, and let $C=(u,r,s,t)$ be an admissible change of variables over $F$, with $u$ a unit of $F$ and
+$r,s,t\in F$. The assertion is an equivalence: the transformed Weierstrass curve $C\cdot E$ equals
+$E$ — equality of all five coefficients, for the Mathlib action of `WeierstrassCurve.VariableChange`
+on `WeierstrassCurve` — if and only if either $C$ is the identity change of variables $(1,0,0,0)$ or
+$C$ is the change of variables $(-1,\,0,\,-a_1(E),\,-a_3(E))$, the latter being the negation
+automorphism $(x,y)\mapsto(x,-y-a_1x-a_3)$ of the model. Thus the stabiliser of the model is
+described by listing its two elements, rather than merely by its order; no smoothness or
+nonvanishing hypothesis on the discriminant is imposed beyond $c_4\neq0$ and $c_6\neq0$.
+
+This is the computation of the automorphism group of a Weierstrass model in the classical case
+$j\neq 0,1728$, where it is $\{\pm 1\}$. It is used in the moduli description of modular curves,
+being cited in the identification of orbits of Weierstrass models with the same $j$-invariant, in
+the count of moduli points above a given $j$-value, and in the analysis of points fixed by the
+action on full-level structures.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_variableChange_smul_eq_self_iff_of_c4_ne_zero_of_c6_ne_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace WeierstrassCurve
+
+open WeierstrassCurve
+
+variable {R : Type*} [CommRing R]
+
+theorem negVariableChange_smul (W : WeierstrassCurve R) :
+    (⟨-1, 0, -W.a₁, -W.a₃⟩ : VariableChange R) • W = W := by
+  ext
+  · simp only [variableChange_a₁, inv_neg, inv_one, Units.val_neg, Units.val_one]; ring
+  · simp only [variableChange_a₂, inv_neg, inv_one, Units.val_neg, Units.val_one]; ring
+  · simp only [variableChange_a₃, inv_neg, inv_one, Units.val_neg, Units.val_one]; ring
+  · simp only [variableChange_a₄, inv_neg, inv_one, Units.val_neg, Units.val_one]; ring
+  · simp only [variableChange_a₆, inv_neg, inv_one, Units.val_neg, Units.val_one]; ring
+
+end WeierstrassCurve
+
+open WeierstrassCurve
+
+theorem solution {F : Type*} [Field F]
+    (h2 : (2 : F) ≠ 0) (h3 : (3 : F) ≠ 0) (E : WeierstrassCurve F)
+    (hc₄ : E.c₄ ≠ 0) (hc₆ : E.c₆ ≠ 0) (C : VariableChange F) :
+    C • E = E ↔ C = 1 ∨ C = ⟨-1, 0, -E.a₁, -E.a₃⟩ := by
+  constructor
+  · intro h
+    obtain ⟨u, r, s, t⟩ := C
+    have h4 : ((u : F)⁻¹) ^ 4 = 1 := by
+      have := congrArg WeierstrassCurve.c₄ h
+      rw [variableChange_c₄, Units.val_inv_eq_inv_val] at this
+      exact (mul_eq_right₀ hc₄).mp this
+    have h6 : ((u : F)⁻¹) ^ 6 = 1 := by
+      have := congrArg WeierstrassCurve.c₆ h
+      rw [variableChange_c₆, Units.val_inv_eq_inv_val] at this
+      exact (mul_eq_right₀ hc₆).mp this
+    have hsq : (u : F)⁻¹ * (u : F)⁻¹ = 1 := by
+      have : ((u : F)⁻¹) ^ 6 = ((u : F)⁻¹) ^ 4 * (((u : F)⁻¹) * ((u : F)⁻¹)) := by ring
+      rw [this, h4, one_mul] at h6
+      exact h6
+    have huinv : (u : F)⁻¹ = 1 ∨ (u : F)⁻¹ = -1 := mul_self_eq_one_iff.mp hsq
+    have h1 := congrArg WeierstrassCurve.a₁ h
+    have h2' := congrArg WeierstrassCurve.a₂ h
+    have h3' := congrArg WeierstrassCurve.a₃ h
+    simp only [variableChange_a₁, variableChange_a₂, variableChange_a₃,
+      Units.val_inv_eq_inv_val] at h1 h2' h3'
+    rcases huinv with hui | hui
+    · left
+      have hu : (u : F) = 1 := by rw [← inv_inv (u : F), hui, inv_one]
+      rw [hui] at h1 h2' h3'
+      have hs : s = 0 := by
+        have : (2 : F) * s = 0 := by linear_combination h1
+        exact (mul_eq_zero.mp this).resolve_left h2
+      subst hs
+      have hr : r = 0 := by
+        have : (3 : F) * r = 0 := by linear_combination h2'
+        exact (mul_eq_zero.mp this).resolve_left h3
+      subst hr
+      have ht : t = 0 := by
+        have : (2 : F) * t = 0 := by linear_combination h3'
+        exact (mul_eq_zero.mp this).resolve_left h2
+      subst ht
+      have huu : u = 1 := Units.ext hu
+      subst huu
+      rfl
+    · right
+      have hu : (u : F) = -1 := by rw [← inv_inv (u : F), hui, inv_neg, inv_one]
+      rw [hui] at h1 h2' h3'
+      have hs : s = -E.a₁ := by
+        have : (2 : F) * (s + E.a₁) = 0 := by linear_combination -h1
+        linear_combination (mul_eq_zero.mp this).resolve_left h2
+      subst hs
+      have hr : r = 0 := by
+        have : (3 : F) * r = 0 := by linear_combination h2'
+        exact (mul_eq_zero.mp this).resolve_left h3
+      subst hr
+      have ht : t = -E.a₃ := by
+        have : (2 : F) * (t + E.a₃) = 0 := by linear_combination -h3'
+        linear_combination (mul_eq_zero.mp this).resolve_left h2
+      subst ht
+      have huu : u = -1 := Units.ext (by rw [hu, Units.val_neg, Units.val_one])
+      subst huu
+      rfl
+  · rintro (rfl | rfl)
+    · exact one_smul _ _
+    · exact negVariableChange_smul E
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.variableChange_smul_eq_self_iff_of_c4_ne_zero_of_c6_ne_zero
+    {F : Type*} [Field F] (h2 : (2 : F) ≠ 0) (h3 : (3 : F) ≠ 0) (E : WeierstrassCurve F)
+    (hc₄ : E.c₄ ≠ 0) (hc₆ : E.c₆ ≠ 0) (C : WeierstrassCurve.VariableChange F) :
+    C • E = E ↔ C = 1 ∨ C = ⟨-1, 0, -E.a₁, -E.a₃⟩ := by
+  exact solution h2 h3 E hc₄ hc₆ C
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_velu2QuadDisc_ne_zero_of_two_torsion.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_velu2QuadDisc_ne_zero_of_two_torsion.lean
new file mode 100644
index 0000000000..bccc56d1e5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_velu2QuadDisc_ne_zero_of_two_torsion.lean
@@ -0,0 +1,84 @@
+/-
+Based on Prove2Me node WeierstrassCurve.velu2QuadDisc_ne_zero_of_two_torsion
+(a457550b-ed8e-520f-a3c9-91fa02b786bc) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7075dc8d-b6f7-580b-a290-8337f9b653ba
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluOrderTwo
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Delta_eq_veluGx_sq_mul_velu2QuadDisc
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Nonvanishing of `velu2QuadDisc` at a 2-torsion point
+
+Theorem statement: `WeierstrassCurve.velu2QuadDisc_ne_zero_of_two_torsion`
+(`a457550b-ed8e-520f-a3c9-91fa02b786bc`), by Claude, 2026-09-05.
+
+Proof: submission `7075dc8d-b6f7-580b-a290-8337f9b653ba`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring and let $W$ be a Weierstrass curve over $R$, with the usual associated
+quantities $a_1,a_3$, $b_2$, $b_4$ and discriminant $\Delta$ in Mathlib's sense. Let $x_0,y_0 \in R$
+and assume: (i) $\Delta \neq 0$; (ii) the pair $(x_0,y_0)$ satisfies the affine Weierstrass equation
+of $W$, i.e. `W.toAffine.Equation x₀ y₀` holds; (iii) `W.veluGy x₀ y₀` vanishes, that is $-(2y_0 +
+a_1 x_0 + a_3) = 0$, which is the condition that the point $(x_0,y_0)$ be fixed by inversion, so of
+order dividing $2$. The conclusion is that `W.velu2QuadDisc x₀` is nonzero, i.e.
+$$b_2^2 - 8 b_2 x_0 - 48 x_0^2 - 32 b_4 \neq 0$$
+in $R$. No invertibility or integral-domain hypothesis on $R$ is imposed beyond $\Delta \neq 0$;
+note that over a field this quantity is the discriminant of the quadratic cofactor cutting out the
+two remaining abscissae of $2$-torsion, so its nonvanishing says those abscissae are distinct.
+
+The statement records that at an affine point of order dividing $2$ on a curve with nonzero
+discriminant, the quadratic cofactor of the $2$-division polynomial has nonzero discriminant. It is
+used in the construction of the quotient curve by a subgroup of order $2$ in the Vélu formulae,
+where it enters the verification that the quotient curve again has nonzero discriminant
+([`WeierstrassCurve.veluQuotient2_Delta_ne_zero`]
+(thm.html#WeierstrassCurve.veluQuotient2_Delta_ne_zero)).
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_velu2QuadDisc_ne_zero_of_two_torsion.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_velu2QuadDisc_ne_zero_of_two_torsion
+
+open WeierstrassCurve WeierstrassCurve.Affine in
+theorem solution {R : Type*} [CommRing R] {W : WeierstrassCurve R} {x₀ y₀ : R} (hΔ : W.Δ ≠ 0)
+    (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0) :
+    W.velu2QuadDisc x₀ ≠ 0 := by
+  intro h
+  exact hΔ (by rw [Delta_eq_veluGx_sq_mul_velu2QuadDisc hQ hgy, h]; ring)
+
+end S_WeierstrassCurve_velu2QuadDisc_ne_zero_of_two_torsion
+end P2MW
+export P2MW.S_WeierstrassCurve_velu2QuadDisc_ne_zero_of_two_torsion (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace WeierstrassCurve
+variable {R : Type*} [CommRing R] {W : WeierstrassCurve R}
+theorem velu2QuadDisc_ne_zero_of_two_torsion {x₀ y₀ : R} (hΔ : W.Δ ≠ 0)
+    (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0) :
+    W.velu2QuadDisc x₀ ≠ 0 :=
+  solution hΔ hQ hgy
+end WeierstrassCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_velu2_line_image_factored.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_velu2_line_image_factored.lean
new file mode 100644
index 0000000000..389ffa52b2
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_velu2_line_image_factored.lean
@@ -0,0 +1,392 @@
+/-
+Released under Apache 2.0 license as described in the file LICENSE.
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluPointMap2
+
+import Mathlib.Tactic.FieldSimp
+import Mathlib.Tactic.LinearCombination
+import Mathlib.Tactic.Ring
+
+/-!
+# Vélu sends curve intersections with a line to another line
+
+Use coordinates d = x - x₀ and e = y - y₀ centred at the order-two kernel point.
+The curve equation becomes e² + a₁de = d³ + cd² + td, where c = a₂ + 3x₀ and
+t = veluGx(x₀, y₀). If e = l d + b with b nonzero, the Vélu images lie on the
+line of slope l - t / b and intercept b + t (l² + a₁l - c) / b.
+
+The formula applies equally to chords and tangents. All polynomial calculations keep the
+slope and intercept as independent quantities instead of expanding the rational slope.
+-/
+
+section privateSection
+
+namespace VeluLineFactored
+
+theorem shifted_curve {R : Type*} [CommRing R] {W : WeierstrassCurve R}
+    {x₀ y₀ x y : R} (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0) :
+    (y - y₀) ^ 2 + W.a₁ * (x - x₀) * (y - y₀) - (x - x₀) * W.veluGx x₀ y₀
+        - (W.a₂ + 3 * x₀) * (x - x₀) ^ 2 - (x - x₀) ^ 3 = 0 := by
+  rw [WeierstrassCurve.Affine.equation_iff] at hP hQ
+  simp only [WeierstrassCurve.veluGx]
+  linear_combination hP - hQ - (y - y₀) * hord
+
+/-- A small certificate for the transformed line equation. -/
+theorem line_image {F : Type*} [Field F] (a c t d e l b : F)
+    (hd : d ≠ 0) (hb : b ≠ 0)
+    (hcurve : e ^ 2 + a * d * e - d * t - c * d ^ 2 - d ^ 3 = 0)
+    (hline : e = l * d + b) :
+    e - t * (a * d + e) / d ^ 2 =
+      (l - t / b) * (d + t / d) + b + t * (l ^ 2 + a * l - c) / b := by
+  rw [hline] at hcurve ⊢
+  field_simp
+  linear_combination -t * hcurve
+
+/-- Vieta's formula gives the sum of the transformed abscissae. -/
+theorem root_sum {F : Type*} [Field F] (a c t l b d₁ d₂ d₃ : F)
+    (h₁ : d₁ ≠ 0) (h₂ : d₂ ≠ 0) (h₃ : d₃ ≠ 0) (hb : b ≠ 0)
+    (hsum : d₁ + d₂ + d₃ = l ^ 2 + a * l - c)
+    (hpair : d₁ * d₂ + d₁ * d₃ + d₂ * d₃ = t - (2 * l + a) * b)
+    (hprod : d₁ * d₂ * d₃ = b ^ 2) :
+    (d₁ + t / d₁) + (d₂ + t / d₂) + (d₃ + t / d₃) =
+      (l - t / b) ^ 2 + a * (l - t / b) - c := by
+  have hinv : d₁⁻¹ + d₂⁻¹ + d₃⁻¹ =
+      (d₁ * d₂ + d₁ * d₃ + d₂ * d₃) / (d₁ * d₂ * d₃) := by
+    field_simp
+    ring
+  rw [hpair, hprod] at hinv
+  calc
+    (d₁ + t / d₁) + (d₂ + t / d₂) + (d₃ + t / d₃) =
+        (d₁ + d₂ + d₃) + t * (d₁⁻¹ + d₂⁻¹ + d₃⁻¹) := by ring
+    _ = (l ^ 2 + a * l - c) + t * ((t - (2 * l + a) * b) / b ^ 2) := by
+      rw [hsum, hinv]
+    _ = (l - t / b) ^ 2 + a * (l - t / b) - c := by
+      field_simp
+      ring
+
+/-- The third intersection of a secant, including the two remaining Vieta relations. -/
+theorem secant_vieta {F : Type*} [Field F] (a c t l b d₁ d₂ A : F)
+    (hne : d₁ ≠ d₂) (hA : A = l ^ 2 + a * l - c - d₁ - d₂)
+    (h₁ : (l * d₁ + b) ^ 2 + a * d₁ * (l * d₁ + b)
+      - d₁ * t - c * d₁ ^ 2 - d₁ ^ 3 = 0)
+    (h₂ : (l * d₂ + b) ^ 2 + a * d₂ * (l * d₂ + b)
+      - d₂ * t - c * d₂ ^ 2 - d₂ ^ 3 = 0) :
+    (d₁ * d₂ + d₁ * A + d₂ * A = t - (2 * l + a) * b) ∧
+    (d₁ * d₂ * A = b ^ 2) ∧
+    ((l * A + b) ^ 2 + a * A * (l * A + b) - A * t - c * A ^ 2 - A ^ 3 = 0) := by
+  have hpair : d₁ * d₂ + d₁ * A + d₂ * A = t - (2 * l + a) * b := by
+    apply sub_eq_zero.mp
+    apply mul_left_cancel₀ (sub_ne_zero.mpr hne)
+    rw [mul_zero, hA]
+    linear_combination h₁ - h₂
+  have hprod : d₁ * d₂ * A = b ^ 2 := by
+    rw [hA] at hpair ⊢
+    linear_combination -h₁ + d₁ * hpair
+  refine ⟨hpair, hprod, ?_⟩
+  rw [hA] at hpair hprod ⊢
+  linear_combination (l ^ 2 + a * l - c - d₁ - d₂) * hpair - hprod
+
+/-- Repeated-root Vieta identities for a tangent. -/
+theorem tangent_vieta {F : Type*} [Field F] (a c t l d e A : F)
+    (hA : A = l ^ 2 + a * l - c - 2 * d)
+    (hC : e ^ 2 + a * d * e - d * t - c * d ^ 2 - d ^ 3 = 0)
+    (hL : l * (2 * e + a * d) - t - 2 * c * d - 3 * d ^ 2 + a * e = 0) :
+    (d * d + d * A + d * A = t - (2 * l + a) * (e - l * d)) ∧
+    (d * d * A = (e - l * d) ^ 2) ∧
+    ((l * A + (e - l * d)) ^ 2 + a * A * (l * A + (e - l * d))
+      - A * t - c * A ^ 2 - A ^ 3 = 0) := by
+  have hpair : d * d + d * A + d * A = t - (2 * l + a) * (e - l * d) := by
+    rw [hA]
+    linear_combination hL
+  have hprod : d * d * A = (e - l * d) ^ 2 := by
+    rw [hA]
+    linear_combination d * hL - hC
+  refine ⟨hpair, hprod, ?_⟩
+  rw [hA] at hpair hprod ⊢
+  linear_combination (l ^ 2 + a * l - c - 2 * d) * hpair - hprod
+
+/-- The transformed tangent direction, without expanding the rational slope. -/
+theorem tangent_image {F : Type*} [Field F] (a c t l d e : F)
+    (hd : d ≠ 0) (hb : e - l * d ≠ 0)
+    (hC : e ^ 2 + a * d * e - d * t - c * d ^ 2 - d ^ 3 = 0)
+    (hL : l * (2 * e + a * d) - t - 2 * c * d - 3 * d ^ 2 + a * e = 0) :
+    (l - t / (e - l * d)) *
+        (2 * (e - t * (a * d + e) / d ^ 2) + a * (d + t / d)) =
+      3 * (d + t / d) ^ 2 + 2 * c * (d + t / d) - 4 * t
+        - a * (e - t * (a * d + e) / d ^ 2) := by
+  field_simp
+  linear_combination
+    ((e - l * d) * d ^ 2 + t * (e + (l + a) * d)) * hL - t * (4 * l + 2 * a) * hC
+
+/-- The original tangent-slope equation with just its own denominator cleared. -/
+theorem shifted_tangent {F : Type*} [Field F] [DecidableEq F]
+    {W : WeierstrassCurve F} {x₀ y₀ x y : F}
+    (hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0) (hy : y ≠ W.toAffine.negY x y) :
+    W.toAffine.slope x x y y * (2 * (y - y₀) + W.a₁ * (x - x₀))
+        - W.veluGx x₀ y₀ - 2 * (W.a₂ + 3 * x₀) * (x - x₀)
+        - 3 * (x - x₀) ^ 2 + W.a₁ * (y - y₀) = 0 := by
+  have hden : 2 * (y - y₀) + W.a₁ * (x - x₀) = y - W.toAffine.negY x y := by
+    simp only [WeierstrassCurve.Affine.negY]
+    linear_combination -hord
+  have hs : W.toAffine.slope x x y y * (y - W.toAffine.negY x y)
+      = 3 * x ^ 2 + 2 * W.a₂ * x + W.a₄ - W.a₁ * y := by
+    rw [WeierstrassCurve.Affine.slope_of_Y_ne rfl hy]
+    exact div_mul_cancel₀ _ (sub_ne_zero.mpr hy)
+  rw [hden, hs]
+  simp only [WeierstrassCurve.veluGx]
+  ring
+
+end VeluLineFactored
+
+/-- A chord or tangent of nonzero intercept transforms to a line with slope l - t / b. -/
+theorem WeierstrassCurve.velu2_line_image_factored
+    {F : Type*} [Field F] {W : WeierstrassCurve F} {x₀ y₀ x y : F}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0)
+    (hx : x ≠ x₀) (l b : F) (hb : b ≠ 0) (hline : y - y₀ = l * (x - x₀) + b) :
+    W.velu2Y x₀ y₀ x y - y₀ =
+      (l - W.veluGx x₀ y₀ / b) * (W.velu2X x₀ y₀ x - x₀)
+        + b + W.veluGx x₀ y₀ * (l ^ 2 + W.a₁ * l - (W.a₂ + 3 * x₀)) / b := by
+  have h := VeluLineFactored.line_image W.a₁ (W.a₂ + 3 * x₀) (W.veluGx x₀ y₀)
+    (x - x₀) (y - y₀) l b (sub_ne_zero.mpr hx) hb
+    (VeluLineFactored.shifted_curve hP hQ hord) hline
+  simp only [WeierstrassCurve.velu2X, WeierstrassCurve.velu2Y]
+  convert h using 1 <;> ring
+
+end privateSection
+
+public section publicSection
+
+/-- Both secant coordinate identities from the transformed line and Vieta's formula. -/
+theorem WeierstrassCurve.velu2_secant_align_factored
+    {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F}
+    {x₀ y₀ x₁ y₁ x₂ y₂ : F}
+    (hP₁ : W.toAffine.Equation x₁ y₁) (hP₂ : W.toAffine.Equation x₂ y₂)
+    (hQ : W.toAffine.Equation x₀ y₀) (hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0)
+    (hx12 : x₁ ≠ x₂) (hx₁ : x₁ ≠ x₀) (hx₂ : x₂ ≠ x₀)
+    (hsp : W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂) ≠ x₀)
+    (hX12 : W.velu2X x₀ y₀ x₁ ≠ W.velu2X x₀ y₀ x₂) :
+    (W.velu2X x₀ y₀ (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂)) =
+      (W.veluQuotient2 x₀ y₀).toAffine.addX (W.velu2X x₀ y₀ x₁)
+        (W.velu2X x₀ y₀ x₂)
+        ((W.veluQuotient2 x₀ y₀).toAffine.slope (W.velu2X x₀ y₀ x₁)
+          (W.velu2X x₀ y₀ x₂) (W.velu2Y x₀ y₀ x₁ y₁) (W.velu2Y x₀ y₀ x₂ y₂))) ∧
+    (W.velu2Y x₀ y₀ (W.toAffine.addX x₁ x₂ (W.toAffine.slope x₁ x₂ y₁ y₂))
+        (W.toAffine.negAddY x₁ x₂ y₁ (W.toAffine.slope x₁ x₂ y₁ y₂)) =
+      (W.veluQuotient2 x₀ y₀).toAffine.negAddY (W.velu2X x₀ y₀ x₁)
+        (W.velu2X x₀ y₀ x₂) (W.velu2Y x₀ y₀ x₁ y₁)
+        ((W.veluQuotient2 x₀ y₀).toAffine.slope (W.velu2X x₀ y₀ x₁)
+          (W.velu2X x₀ y₀ x₂) (W.velu2Y x₀ y₀ x₁ y₁) (W.velu2Y x₀ y₀ x₂ y₂))) := by
+  let a := W.a₁
+  let c := W.a₂ + 3 * x₀
+  let t := W.veluGx x₀ y₀
+  let l := W.toAffine.slope x₁ x₂ y₁ y₂
+  let d₁ := x₁ - x₀
+  let d₂ := x₂ - x₀
+  let e₁ := y₁ - y₀
+  let e₂ := y₂ - y₀
+  let b := e₁ - l * d₁
+  let xA := W.toAffine.addX x₁ x₂ l
+  let yA := W.toAffine.negAddY x₁ x₂ y₁ l
+  let A := xA - x₀
+  have hd₁ : d₁ ≠ 0 := sub_ne_zero.mpr hx₁
+  have hd₂ : d₂ ≠ 0 := sub_ne_zero.mpr hx₂
+  have hdA : A ≠ 0 := sub_ne_zero.mpr hsp
+  have hne : d₁ ≠ d₂ := by
+    dsimp only [d₁, d₂]
+    intro h
+    apply hx12
+    linear_combination h
+  have hsec : l * (d₁ - d₂) = e₁ - e₂ := by
+    dsimp only [l, d₁, d₂, e₁, e₂]
+    rw [WeierstrassCurve.Affine.slope_of_X_ne hx12]
+    have hd : x₁ - x₂ ≠ 0 := sub_ne_zero.mpr hx12
+    field_simp
+    ring
+  have hline₁ : e₁ = l * d₁ + b := by dsimp only [b]; ring
+  have hline₂ : e₂ = l * d₂ + b := by
+    dsimp only [b]
+    linear_combination hsec
+  have hA : A = l ^ 2 + a * l - c - d₁ - d₂ := by
+    dsimp only [A, xA, a, c, d₁, d₂]
+    rw [WeierstrassCurve.Affine.addX]
+    ring
+  have hcurve₁ := VeluLineFactored.shifted_curve hP₁ hQ hord
+  have hcurve₂ := VeluLineFactored.shifted_curve hP₂ hQ hord
+  change e₁ ^ 2 + a * d₁ * e₁ - d₁ * t - c * d₁ ^ 2 - d₁ ^ 3 = 0 at hcurve₁
+  change e₂ ^ 2 + a * d₂ * e₂ - d₂ * t - c * d₂ ^ 2 - d₂ ^ 3 = 0 at hcurve₂
+  rw [hline₁] at hcurve₁
+  rw [hline₂] at hcurve₂
+  obtain ⟨hpair, hprod, hcurveA⟩ :=
+    VeluLineFactored.secant_vieta a c t l b d₁ d₂ A hne hA hcurve₁ hcurve₂
+  have hb : b ≠ 0 := by
+    intro hb
+    rw [hb, zero_pow (by decide)] at hprod
+    exact mul_ne_zero (mul_ne_zero hd₁ hd₂) hdA hprod
+  have hlineA : yA - y₀ = l * A + b := by
+    dsimp only [yA, A, xA, b, e₁, d₁]
+    rw [WeierstrassCurve.Affine.negAddY]
+    ring
+  have hPA : W.toAffine.Equation xA yA := by
+    rw [← hlineA] at hcurveA
+    rw [WeierstrassCurve.Affine.equation_iff]
+    rw [WeierstrassCurve.Affine.equation_iff] at hQ
+    dsimp only [a, c, t, A] at hcurveA
+    simp only [WeierstrassCurve.veluGx] at hcurveA
+    linear_combination hcurveA + hQ + (yA - y₀) * hord
+  let m := l - t / b
+  let B := b + t * (l ^ 2 + a * l - c) / b
+  have hI₁ := WeierstrassCurve.velu2_line_image_factored hP₁ hQ hord hx₁ l b hb hline₁
+  have hI₂ := WeierstrassCurve.velu2_line_image_factored hP₂ hQ hord hx₂ l b hb hline₂
+  have hIA := WeierstrassCurve.velu2_line_image_factored hPA hQ hord hsp l b hb hlineA
+  simp only [add_assoc] at hI₁ hI₂ hIA
+  change W.velu2Y x₀ y₀ x₁ y₁ - y₀ = m * (W.velu2X x₀ y₀ x₁ - x₀) + B at hI₁
+  change W.velu2Y x₀ y₀ x₂ y₂ - y₀ = m * (W.velu2X x₀ y₀ x₂ - x₀) + B at hI₂
+  change W.velu2Y x₀ y₀ xA yA - y₀ = m * (W.velu2X x₀ y₀ xA - x₀) + B at hIA
+  have hquotSlope : (W.veluQuotient2 x₀ y₀).toAffine.slope (W.velu2X x₀ y₀ x₁)
+      (W.velu2X x₀ y₀ x₂) (W.velu2Y x₀ y₀ x₁ y₁) (W.velu2Y x₀ y₀ x₂ y₂) = m := by
+    rw [WeierstrassCurve.Affine.slope_of_X_ne hX12]
+    apply (div_eq_iff (sub_ne_zero.mpr hX12)).mpr
+    linear_combination hI₁ - hI₂
+  have hsum : d₁ + d₂ + A = l ^ 2 + a * l - c := by linear_combination hA
+  have hroot := VeluLineFactored.root_sum a c t l b d₁ d₂ A hd₁ hd₂ hdA hb
+    hsum hpair hprod
+  have hsumQ : (W.velu2X x₀ y₀ x₁ - x₀) + (W.velu2X x₀ y₀ x₂ - x₀)
+      + (W.velu2X x₀ y₀ xA - x₀) = m ^ 2 + a * m - c := by
+    simp only [WeierstrassCurve.velu2X]
+    convert hroot using 1
+    dsimp only [d₁, d₂, A, t]
+    ring
+  have hX : W.velu2X x₀ y₀ xA = (W.veluQuotient2 x₀ y₀).toAffine.addX
+      (W.velu2X x₀ y₀ x₁) (W.velu2X x₀ y₀ x₂) m := by
+    rw [WeierstrassCurve.Affine.addX, WeierstrassCurve.veluQuotient2_a₁,
+      WeierstrassCurve.veluQuotient2_a₂]
+    dsimp only [a, c] at hsumQ
+    linear_combination hsumQ
+  refine ⟨?_, ?_⟩
+  · rw [hquotSlope]
+    exact hX
+  · rw [hquotSlope]
+    conv_rhs => rw [WeierstrassCurve.Affine.negAddY, ← hX]
+    linear_combination hIA - hI₁
+
+/-- Both tangent coordinate identities from the transformed line and repeated-root Vieta. -/
+theorem WeierstrassCurve.velu2_tangent_align_factored
+    {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F} {x₀ y₀ x y : F}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hgy : W.veluGy x₀ y₀ = 0) (hy : y ≠ W.toAffine.negY x y) (hx : x ≠ x₀)
+    (hx2 : W.toAffine.addX x x (W.toAffine.slope x x y y) ≠ x₀)
+    (hY : W.velu2Y x₀ y₀ x y ≠
+      (W.veluQuotient2 x₀ y₀).toAffine.negY (W.velu2X x₀ y₀ x) (W.velu2Y x₀ y₀ x y)) :
+    (W.velu2X x₀ y₀ (W.toAffine.addX x x (W.toAffine.slope x x y y)) =
+      (W.veluQuotient2 x₀ y₀).toAffine.addX (W.velu2X x₀ y₀ x) (W.velu2X x₀ y₀ x)
+        ((W.veluQuotient2 x₀ y₀).toAffine.slope (W.velu2X x₀ y₀ x) (W.velu2X x₀ y₀ x)
+          (W.velu2Y x₀ y₀ x y) (W.velu2Y x₀ y₀ x y))) ∧
+    (W.velu2Y x₀ y₀ (W.toAffine.addX x x (W.toAffine.slope x x y y))
+        (W.toAffine.negAddY x x y (W.toAffine.slope x x y y)) =
+      (W.veluQuotient2 x₀ y₀).toAffine.negAddY (W.velu2X x₀ y₀ x) (W.velu2X x₀ y₀ x)
+        (W.velu2Y x₀ y₀ x y)
+        ((W.veluQuotient2 x₀ y₀).toAffine.slope (W.velu2X x₀ y₀ x) (W.velu2X x₀ y₀ x)
+          (W.velu2Y x₀ y₀ x y) (W.velu2Y x₀ y₀ x y))) := by
+  have hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0 := by
+    simpa only [WeierstrassCurve.veluGy, neg_eq_zero] using hgy
+  let a := W.a₁
+  let c := W.a₂ + 3 * x₀
+  let t := W.veluGx x₀ y₀
+  let l := W.toAffine.slope x x y y
+  let d := x - x₀
+  let e := y - y₀
+  let b := e - l * d
+  let xA := W.toAffine.addX x x l
+  let yA := W.toAffine.negAddY x x y l
+  let A := xA - x₀
+  have hd : d ≠ 0 := sub_ne_zero.mpr hx
+  have hdA : A ≠ 0 := sub_ne_zero.mpr hx2
+  have hA : A = l ^ 2 + a * l - c - 2 * d := by
+    dsimp only [A, xA, a, c, d]
+    rw [WeierstrassCurve.Affine.addX]
+    ring
+  have hC : e ^ 2 + a * d * e - d * t - c * d ^ 2 - d ^ 3 = 0 :=
+    VeluLineFactored.shifted_curve hP hQ hord
+  have hL : l * (2 * e + a * d) - t - 2 * c * d - 3 * d ^ 2 + a * e = 0 :=
+    VeluLineFactored.shifted_tangent hord hy
+  obtain ⟨hpair, hprod, hcurveA⟩ := VeluLineFactored.tangent_vieta a c t l d e A hA hC hL
+  have hb : b ≠ 0 := by
+    intro hb
+    change d * d * A = b ^ 2 at hprod
+    rw [hb, zero_pow (by decide)] at hprod
+    exact mul_ne_zero (mul_ne_zero hd hd) hdA hprod
+  have hline : e = l * d + b := by dsimp only [b]; ring
+  have hlineA : yA - y₀ = l * A + b := by
+    dsimp only [yA, A, xA, b, e, d]
+    rw [WeierstrassCurve.Affine.negAddY]
+    ring
+  have hPA : W.toAffine.Equation xA yA := by
+    change (l * A + b) ^ 2 + a * A * (l * A + b)
+      - A * t - c * A ^ 2 - A ^ 3 = 0 at hcurveA
+    rw [← hlineA] at hcurveA
+    rw [WeierstrassCurve.Affine.equation_iff]
+    rw [WeierstrassCurve.Affine.equation_iff] at hQ
+    dsimp only [a, c, t, A] at hcurveA
+    simp only [WeierstrassCurve.veluGx] at hcurveA
+    linear_combination hcurveA + hQ + (yA - y₀) * hord
+  let m := l - t / b
+  let B := b + t * (l ^ 2 + a * l - c) / b
+  let X := W.velu2X x₀ y₀ x
+  let Y := W.velu2Y x₀ y₀ x y
+  have himage := VeluLineFactored.tangent_image a c t l d e hd hb hC hL
+  have hSlopeEq : m * (2 * (Y - y₀) + a * (X - x₀)) =
+      3 * (X - x₀) ^ 2 + 2 * c * (X - x₀) - 4 * t - a * (Y - y₀) := by
+    dsimp only [X, Y]
+    simp only [WeierstrassCurve.velu2X, WeierstrassCurve.velu2Y]
+    convert himage using 1 <;> dsimp only [d, e, t] <;> ring
+  have hD : Y - (W.veluQuotient2 x₀ y₀).toAffine.negY X Y =
+      2 * (Y - y₀) + a * (X - x₀) := by
+    simp only [WeierstrassCurve.Affine.negY, WeierstrassCurve.veluQuotient2_a₁,
+      WeierstrassCurve.veluQuotient2_a₃]
+    dsimp only [a]
+    linear_combination hord
+  have hN : 3 * X ^ 2 + 2 * (W.veluQuotient2 x₀ y₀).a₂ * X
+      + (W.veluQuotient2 x₀ y₀).a₄ - (W.veluQuotient2 x₀ y₀).a₁ * Y =
+      3 * (X - x₀) ^ 2 + 2 * c * (X - x₀) - 4 * t - a * (Y - y₀) := by
+    rw [WeierstrassCurve.veluQuotient2_a₁, WeierstrassCurve.veluQuotient2_a₂,
+      WeierstrassCurve.veluQuotient2_a₄]
+    dsimp only [a, c, t]
+    simp only [WeierstrassCurve.veluGx]
+    ring
+  have hquotSlope : (W.veluQuotient2 x₀ y₀).toAffine.slope X X Y Y = m := by
+    rw [WeierstrassCurve.Affine.slope_of_Y_ne rfl hY]
+    apply (div_eq_iff (sub_ne_zero.mpr hY)).mpr
+    rw [hN, hD]
+    exact hSlopeEq.symm
+  have hI := WeierstrassCurve.velu2_line_image_factored hP hQ hord hx l b hb hline
+  have hIA := WeierstrassCurve.velu2_line_image_factored hPA hQ hord hx2 l b hb hlineA
+  simp only [add_assoc] at hI hIA
+  change Y - y₀ = m * (X - x₀) + B at hI
+  change W.velu2Y x₀ y₀ xA yA - y₀ = m * (W.velu2X x₀ y₀ xA - x₀) + B at hIA
+  have hsum : d + d + A = l ^ 2 + a * l - c := by linear_combination hA
+  have hroot := VeluLineFactored.root_sum a c t l b d d A hd hd hdA hb hsum hpair hprod
+  have hsumQ : (X - x₀) + (X - x₀) + (W.velu2X x₀ y₀ xA - x₀) =
+      m ^ 2 + a * m - c := by
+    dsimp only [X]
+    simp only [WeierstrassCurve.velu2X]
+    convert hroot using 1
+    dsimp only [d, A, t]
+    ring
+  have hX : W.velu2X x₀ y₀ xA = (W.veluQuotient2 x₀ y₀).toAffine.addX X X m := by
+    rw [WeierstrassCurve.Affine.addX, WeierstrassCurve.veluQuotient2_a₁,
+      WeierstrassCurve.veluQuotient2_a₂]
+    dsimp only [a, c] at hsumQ
+    linear_combination hsumQ
+  refine ⟨?_, ?_⟩
+  · rw [hquotSlope]
+    exact hX
+  · rw [hquotSlope]
+    conv_rhs => rw [WeierstrassCurve.Affine.negAddY, ← hX]
+    linear_combination hIA - hI
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_velu2_tangent_addX_cleared_identity.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_velu2_tangent_addX_cleared_identity.lean
new file mode 100644
index 0000000000..b903ced5a1
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_velu2_tangent_addX_cleared_identity.lean
@@ -0,0 +1,139 @@
+/-
+Based on Prove2Me node WeierstrassCurve.velu2_tangent_addX_cleared_identity
+(61f71ae0-8337-5555-8a73-cacf226bd63c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8a341e90-cff7-5e41-ae8f-f83bec1ec20f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_Velu
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cleared identity behind the Vélu 2-isogeny doubling abscissa
+
+Theorem statement: `WeierstrassCurve.velu2_tangent_addX_cleared_identity`
+(`61f71ae0-8337-5555-8a73-cacf226bd63c`), by Claude, 2026-09-05.
+
+Proof: submission `8a341e90-cff7-5e41-ae8f-f83bec1ec20f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring and $W$ a Weierstrass curve over $R$ with coefficients
+$a_1,a_2,a_3,a_4,a_6$, and let $x_0,y_0,x,y\in R$. Assume that $(x,y)$ and $(x_0,y_0)$ both satisfy
+the affine Weierstrass equation of $W$, and that $2y_0+a_1x_0+a_3=0$. Write
+$t=3x_0^2+2a_2x_0+a_4-a_1y_0$ for the value `W.veluGx x₀ y₀`, and abbreviate
+$g_x=3x^2+2a_2x+a_4-a_1y$, $g_y=2y+a_1x+a_3$,
+$N=a_1^2(x-x_0)+4\bigl(x^2+xx_0+x_0^2+a_2(x+x_0)+a_4-a_1y_0\bigr)$, $D=(x-x_0)^2-t$ and
+$C=g_x^2+a_1g_xg_y-(a_2+2x+x_0)g_y^2$. The conclusion is the polynomial identity in $R$
+$$N\bigl(D\,(6x^2+(4a_2+a_1^2)x+2a_4+a_1a_3)+tN\bigr)\,(x-x_0)\,C=(g_yD)^2\bigl(g_y^2(x-x_0)+2C
+\bigr).$$
+No invertibility, reducedness or characteristic hypothesis is imposed: the assertion is an equality
+of ring elements, valid over an arbitrary commutative ring once the two curve equations and the
+$2$-torsion relation hold.
+
+The identity is the denominator-cleared algebraic content of the abscissa part of the tangent
+(doubling) case of the compatibility of Vélu's quotient map for a kernel point of order $2$ with the
+group law. It is used in the proof of
+[`WeierstrassCurve.exists_addMonoidHom_coe_eq_veluPointMap2`]
+(thm.html#WeierstrassCurve.exists_addMonoidHom_coe_eq_veluPointMap2),
+where the order-$2$ Vélu point map is shown to be additive.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_velu2_tangent_addX_cleared_identity.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_velu2_tangent_addX_cleared_identity
+
+open WeierstrassCurve WeierstrassCurve.Affine
+
+private theorem velu2TangentAddX_assemble {R : Type*} [CommRing R] {A M C D t u : R}
+    (h1 : A * u = t ^ 2) (h2 : C = D ^ 2) (h3 : M = t ^ 2 * u + 2 * D ^ 2) :
+    A * M * u * C = (t * D) ^ 2 * (t ^ 2 * u + 2 * C) := by
+  linear_combination (M * C) * h1 + (t ^ 4 * u) * h2 + (t ^ 2 * C) * h3
+
+theorem solution
+    {R : Type*} [CommRing R] {W : WeierstrassCurve R} {x₀ y₀ x y : R}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0) :
+    (W.a₁ ^ 2 * (x - x₀)
+            + 4 * (x ^ 2 + x * x₀ + x₀ ^ 2 + W.a₂ * (x + x₀) + W.a₄ - W.a₁ * y₀))
+          * (((x - x₀) ^ 2 - W.veluGx x₀ y₀)
+                * (6 * x ^ 2 + (4 * W.a₂ + W.a₁ ^ 2) * x + 2 * W.a₄ + W.a₁ * W.a₃)
+              + W.veluGx x₀ y₀
+                * (W.a₁ ^ 2 * (x - x₀)
+                    + 4 * (x ^ 2 + x * x₀ + x₀ ^ 2 + W.a₂ * (x + x₀) + W.a₄ - W.a₁ * y₀)))
+          * (x - x₀)
+          * ((3 * x ^ 2 + 2 * W.a₂ * x + W.a₄ - W.a₁ * y) ^ 2
+              + W.a₁ * (3 * x ^ 2 + 2 * W.a₂ * x + W.a₄ - W.a₁ * y) * (2 * y + W.a₁ * x + W.a₃)
+              - (W.a₂ + 2 * x + x₀) * (2 * y + W.a₁ * x + W.a₃) ^ 2)
+      = ((2 * y + W.a₁ * x + W.a₃) * ((x - x₀) ^ 2 - W.veluGx x₀ y₀)) ^ 2
+        * ((2 * y + W.a₁ * x + W.a₃) ^ 2 * (x - x₀)
+            + 2
+              * ((3 * x ^ 2 + 2 * W.a₂ * x + W.a₄ - W.a₁ * y) ^ 2
+                  + W.a₁ * (3 * x ^ 2 + 2 * W.a₂ * x + W.a₄ - W.a₁ * y)
+                    * (2 * y + W.a₁ * x + W.a₃)
+                  - (W.a₂ + 2 * x + x₀) * (2 * y + W.a₁ * x + W.a₃) ^ 2)) := by
+  rw [Affine.equation_iff] at hP hQ
+  refine velu2TangentAddX_assemble ?_ ?_ ?_
+  · linear_combination (-4) * hP + 4 * hQ
+      + (-2 * W.a₁ * x + W.a₁ * x₀ - W.a₃ - 2 * y₀) * hord
+  · simp only [veluGx]
+    linear_combination (-W.a₁ ^ 2 - 4 * W.a₂ - 8 * x - 4 * x₀) * hP
+      + (W.a₁ ^ 2 + 4 * W.a₂ + 8 * x + 4 * x₀) * hQ
+      + (-W.a₁ ^ 2 * y₀ + W.a₁ * W.a₂ * x₀ + W.a₁ * W.a₄ - W.a₁ * x ^ 2 + W.a₁ * x₀ ^ 2
+          - W.a₂ * W.a₃ - 2 * W.a₂ * y₀ - 2 * W.a₃ * x - W.a₃ * x₀ - 4 * x * y₀
+          - 2 * x₀ * y₀) * hord
+  · simp only [veluGx]
+    linear_combination (-4 * x + 4 * x₀) * hP + (4 * x - 4 * x₀) * hQ
+      + (W.a₁ ^ 2 * y₀ - 2 * W.a₁ * W.a₂ * x₀ - W.a₁ * W.a₄ - W.a₁ * x ^ 2 + W.a₁ * x * x₀
+          - 3 * W.a₁ * x₀ ^ 2 - W.a₃ * x + W.a₃ * x₀ - 2 * x * y₀ + 2 * x₀ * y₀) * hord
+
+end S_WeierstrassCurve_velu2_tangent_addX_cleared_identity
+end P2MW
+export P2MW.S_WeierstrassCurve_velu2_tangent_addX_cleared_identity (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine
+theorem WeierstrassCurve.velu2_tangent_addX_cleared_identity
+    {R : Type*} [CommRing R] {W : WeierstrassCurve R} {x₀ y₀ x y : R}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0) :
+    (W.a₁ ^ 2 * (x - x₀)
+            + 4 * (x ^ 2 + x * x₀ + x₀ ^ 2 + W.a₂ * (x + x₀) + W.a₄ - W.a₁ * y₀))
+          * (((x - x₀) ^ 2 - W.veluGx x₀ y₀)
+                * (6 * x ^ 2 + (4 * W.a₂ + W.a₁ ^ 2) * x + 2 * W.a₄ + W.a₁ * W.a₃)
+              + W.veluGx x₀ y₀
+                * (W.a₁ ^ 2 * (x - x₀)
+                    + 4 * (x ^ 2 + x * x₀ + x₀ ^ 2 + W.a₂ * (x + x₀) + W.a₄ - W.a₁ * y₀)))
+          * (x - x₀)
+          * ((3 * x ^ 2 + 2 * W.a₂ * x + W.a₄ - W.a₁ * y) ^ 2
+              + W.a₁ * (3 * x ^ 2 + 2 * W.a₂ * x + W.a₄ - W.a₁ * y) * (2 * y + W.a₁ * x + W.a₃)
+              - (W.a₂ + 2 * x + x₀) * (2 * y + W.a₁ * x + W.a₃) ^ 2)
+      = ((2 * y + W.a₁ * x + W.a₃) * ((x - x₀) ^ 2 - W.veluGx x₀ y₀)) ^ 2
+        * ((2 * y + W.a₁ * x + W.a₃) ^ 2 * (x - x₀)
+            + 2
+              * ((3 * x ^ 2 + 2 * W.a₂ * x + W.a₄ - W.a₁ * y) ^ 2
+                  + W.a₁ * (3 * x ^ 2 + 2 * W.a₂ * x + W.a₄ - W.a₁ * y)
+                    * (2 * y + W.a₁ * x + W.a₃)
+                  - (W.a₂ + 2 * x + x₀) * (2 * y + W.a₁ * x + W.a₃) ^ 2)) :=
+  solution hP hQ hord
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_velu2_tangent_negAddY_cleared_identity.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_velu2_tangent_negAddY_cleared_identity.lean
new file mode 100644
index 0000000000..c5c5f6e78f
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_velu2_tangent_negAddY_cleared_identity.lean
@@ -0,0 +1,79 @@
+/-
+Based on Prove2Me node WeierstrassCurve.velu2_tangent_negAddY_cleared_identity
+(54cd4c04-2ad9-5a7f-83b4-5824129f7814) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission d1712b99-2a55-52e8-a17e-45772491112c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_Velu
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_velu2_tangent_negAddY_cleared_identity_factored
+
+/-!
+# Cleared ordinate identity for Vélu's order-2 map: tangent case
+
+Theorem statement: `WeierstrassCurve.velu2_tangent_negAddY_cleared_identity`
+(`54cd4c04-2ad9-5a7f-83b4-5824129f7814`), by Claude, 2026-09-05.
+
+Proof: submission `d1712b99-2a55-52e8-a17e-45772491112c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field and $W$ a Weierstrass curve over $F$ with coefficients $a_1,a_2,a_3,a_4,a_6$, and
+let $x_0,y_0,x,y \in F$. Assume that $(x,y)$ and $(x_0,y_0)$ satisfy the affine Weierstrass equation
+$y^2+a_1xy+a_3y = x^3+a_2x^2+a_4x+a_6$, that $2y_0+a_1x_0+a_3=0$, and that $y \neq
+W.\mathrm{negY}(x,y) = -y-a_1x-a_3$. Write $\lambda = W.\mathrm{slope}(x,x,y,y)$ for the slope of
+the tangent at $(x,y)$, which under the last hypothesis equals
+$(3x^2+2a_2x+a_4-a_1y)/(2y+a_1x+a_3)$, and put $x_A = W.\mathrm{addX}(x,x,\lambda) =
+\lambda^2+a_1\lambda-a_2-2x$ and $\tilde y_A = W.\mathrm{negAddY}(x,x,y,\lambda) =
+\lambda(x_A-x)+y$. Then, with $t = \mathrm{veluGx}(x_0,y_0) = 3x_0^2+2a_2x_0+a_4-a_1y_0$,
+$$(x-x_0)(x_A-x_0)(x-x_A)(y-y_0)-(x-x_0)\bigl[(a_1(x-x_0)+y-y_0)(x_A-x_0)^2-(a_1(x_A-x_0)+\tilde
+y_A-y_0)(x-x_0)^2\bigr]+t\bigl[(x_A-x_0)(y-y_0)-(x-x_0)(\tilde y_A-y_0)\bigr]=0.$$
+
+This is the tangent (doubling) companion of the corresponding secant identity: a denominator-cleared
+polynomial relation on the curve, for a kernel point $(x_0,y_0)$ of order $2$, expressing the
+alignment of ordinates under Vélu's quotient map associated with that kernel. It is used in the
+proof of
+[`WeierstrassCurve.exists_addMonoidHom_coe_eq_veluPointMap2`]
+(thm.html#WeierstrassCurve.exists_addMonoidHom_coe_eq_veluPointMap2),
+which produces the additive homomorphism realising the order-$2$ Vélu point map.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_velu2_tangent_negAddY_cleared_identity.lean
+
+The expanded proof certificate is replaced locally by the factored tangent-identity proof.
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine
+theorem WeierstrassCurve.velu2_tangent_negAddY_cleared_identity
+    {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F} {x₀ y₀ x y : F}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0) (hy : y ≠ W.toAffine.negY x y) :
+    (x - x₀) * (W.toAffine.addX x x (W.toAffine.slope x x y y) - x₀)
+          * (x - W.toAffine.addX x x (W.toAffine.slope x x y y)) * (y - y₀)
+        - (x - x₀)
+          * ((W.a₁ * (x - x₀) + y - y₀)
+                * (W.toAffine.addX x x (W.toAffine.slope x x y y) - x₀) ^ 2
+              - (W.a₁ * (W.toAffine.addX x x (W.toAffine.slope x x y y) - x₀)
+                    + W.toAffine.negAddY x x y (W.toAffine.slope x x y y) - y₀)
+                * (x - x₀) ^ 2)
+        + W.veluGx x₀ y₀
+          * ((W.toAffine.addX x x (W.toAffine.slope x x y y) - x₀) * (y - y₀)
+              - (x - x₀) * (W.toAffine.negAddY x x y (W.toAffine.slope x x y y) - y₀))
+      = 0 :=
+  WeierstrassCurve.velu2_tangent_negAddY_cleared_identity_factored hP hQ hord hy
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_velu2_tangent_negAddY_cleared_identity_factored.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_velu2_tangent_negAddY_cleared_identity_factored.lean
new file mode 100644
index 0000000000..dfcb6aba99
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_velu2_tangent_negAddY_cleared_identity_factored.lean
@@ -0,0 +1,113 @@
+/-
+Released under Apache 2.0 license as described in the file LICENSE.
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_Velu
+
+import Mathlib.Tactic.LinearCombination
+import Mathlib.Tactic.Ring
+
+/-!
+# A factored proof of the tangent identity for Vélu's order-two map
+
+Translate the kernel point to the origin and retain the tangent slope as an independent
+quantity. The target factors into a combination of the translated curve equation and the
+tangent equation. Only the latter uses division, so no large denominator-cleared polynomial
+certificate is needed. This file does not import the original tangent-identity theorem.
+-/
+
+section privateSection
+
+namespace VeluTangentFactored
+
+/-- The polynomial certificate, before substituting the rational tangent slope. -/
+theorem certificate {R : Type*} [CommRing R] (a c d e l t A B : R)
+    (hA : A = l ^ 2 + a * l - c - 2 * d) (hB : B = l * (A - d) + e) :
+    d * A * (d - A) * e - d * ((a * d + e) * A ^ 2 - (a * A + B) * d ^ 2)
+        + t * (A * e - d * B)
+      = (A - d) *
+          ((2 * l + a) * (e ^ 2 + a * d * e - d * t - c * d ^ 2 - d ^ 3)
+            - (e + (l + a) * d) * (l * (2 * e + a * d) - t - 2 * c * d
+                - 3 * d ^ 2 + a * e)) := by
+  rw [hB, hA]
+  ring
+
+/-- Subtract the equations of the two points and use the order-two relation. -/
+theorem shifted_curve {R : Type*} [CommRing R] {W : WeierstrassCurve R}
+    {x₀ y₀ x y : R} (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0) :
+    (y - y₀) ^ 2 + W.a₁ * (x - x₀) * (y - y₀) - (x - x₀) * W.veluGx x₀ y₀
+        - (W.a₂ + 3 * x₀) * (x - x₀) ^ 2 - (x - x₀) ^ 3 = 0 := by
+  rw [WeierstrassCurve.Affine.equation_iff] at hP hQ
+  simp only [WeierstrassCurve.veluGx]
+  linear_combination hP - hQ - (y - y₀) * hord
+
+/-- Clear just the single denominator in the tangent-slope equation. -/
+theorem shifted_tangent {F : Type*} [Field F] [DecidableEq F]
+    {W : WeierstrassCurve F} {x₀ y₀ x y : F}
+    (hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0) (hy : y ≠ W.toAffine.negY x y) :
+    W.toAffine.slope x x y y * (2 * (y - y₀) + W.a₁ * (x - x₀))
+        - W.veluGx x₀ y₀ - 2 * (W.a₂ + 3 * x₀) * (x - x₀)
+        - 3 * (x - x₀) ^ 2 + W.a₁ * (y - y₀) = 0 := by
+  have hden : 2 * (y - y₀) + W.a₁ * (x - x₀) = y - W.toAffine.negY x y := by
+    simp only [WeierstrassCurve.Affine.negY]
+    linear_combination -hord
+  have hs : W.toAffine.slope x x y y * (y - W.toAffine.negY x y)
+      = 3 * x ^ 2 + 2 * W.a₂ * x + W.a₄ - W.a₁ * y := by
+    rw [WeierstrassCurve.Affine.slope_of_Y_ne rfl hy]
+    exact div_mul_cancel₀ _ (sub_ne_zero.mpr hy)
+  rw [hden, hs]
+  simp only [WeierstrassCurve.veluGx]
+  ring
+
+end VeluTangentFactored
+
+end privateSection
+
+public section publicSection
+
+/-- The tangent identity, proved with a small factored polynomial certificate. -/
+theorem WeierstrassCurve.velu2_tangent_negAddY_cleared_identity_factored
+    {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F} {x₀ y₀ x y : F}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀)
+    (hord : 2 * y₀ + W.a₁ * x₀ + W.a₃ = 0) (hy : y ≠ W.toAffine.negY x y) :
+    (x - x₀) * (W.toAffine.addX x x (W.toAffine.slope x x y y) - x₀)
+          * (x - W.toAffine.addX x x (W.toAffine.slope x x y y)) * (y - y₀)
+        - (x - x₀)
+          * ((W.a₁ * (x - x₀) + y - y₀)
+                * (W.toAffine.addX x x (W.toAffine.slope x x y y) - x₀) ^ 2
+              - (W.a₁ * (W.toAffine.addX x x (W.toAffine.slope x x y y) - x₀)
+                    + W.toAffine.negAddY x x y (W.toAffine.slope x x y y) - y₀)
+                * (x - x₀) ^ 2)
+        + W.veluGx x₀ y₀
+          * ((W.toAffine.addX x x (W.toAffine.slope x x y y) - x₀) * (y - y₀)
+              - (x - x₀) * (W.toAffine.negAddY x x y (W.toAffine.slope x x y y) - y₀))
+      = 0 := by
+  let d := x - x₀
+  let e := y - y₀
+  let c := W.a₂ + 3 * x₀
+  let t := W.veluGx x₀ y₀
+  let l := W.toAffine.slope x x y y
+  let A := W.toAffine.addX x x l - x₀
+  let B := W.toAffine.negAddY x x y l - y₀
+  have hA : A = l ^ 2 + W.a₁ * l - c - 2 * d := by
+    dsimp only [A, c, d]
+    rw [WeierstrassCurve.Affine.addX]
+    ring
+  have hB : B = l * (A - d) + e := by
+    dsimp only [B, A, d, e]
+    rw [WeierstrassCurve.Affine.negAddY]
+    ring
+  have hC : e ^ 2 + W.a₁ * d * e - d * t - c * d ^ 2 - d ^ 3 = 0 :=
+    VeluTangentFactored.shifted_curve hP hQ hord
+  have hL : l * (2 * e + W.a₁ * d) - t - 2 * c * d - 3 * d ^ 2 + W.a₁ * e = 0 :=
+    VeluTangentFactored.shifted_tangent hord hy
+  have hcertificate := VeluTangentFactored.certificate W.a₁ c d e l t A B hA hB
+  rw [hC, hL, mul_zero, mul_zero, sub_self, mul_zero] at hcertificate
+  convert hcertificate using 1
+  dsimp only [d, e, A, B, t, l]
+  ring
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_veluGx_ne_zero_of_two_torsion.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_veluGx_ne_zero_of_two_torsion.lean
new file mode 100644
index 0000000000..1f0d54c80b
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_veluGx_ne_zero_of_two_torsion.lean
@@ -0,0 +1,83 @@
+/-
+Based on Prove2Me node WeierstrassCurve.veluGx_ne_zero_of_two_torsion
+(ebb95932-53b0-5854-ab26-07734a6bf632) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 02f2372d-bbff-5e6f-9967-f9ba04f8a26a
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_Velu
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Delta_eq_veluGx_sq_mul_velu2QuadDisc
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Nonvanishing of gₓ at a 2-torsion point
+
+Theorem statement: `WeierstrassCurve.veluGx_ne_zero_of_two_torsion`
+(`ebb95932-53b0-5854-ab26-07734a6bf632`), by Claude, 2026-09-05.
+
+Proof: submission `02f2372d-bbff-5e6f-9967-f9ba04f8a26a`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring and let $W$ be a Weierstrass curve over $R$ with coefficients $a_1,
+a_2, a_3, a_4, a_6$, and let $x_0, y_0 \in R$. Assume three things: the discriminant $\Delta$ of $W$
+is not zero in $R$; the pair $(x_0, y_0)$ satisfies the affine Weierstrass equation of $W$, i.e.
+$y_0^2 + a_1 x_0 y_0 + a_3 y_0 = x_0^3 + a_2 x_0^2 + a_4 x_0 + a_6$; and the quantity `veluGy` of
+$W$ at $(x_0,y_0)$, namely $-(2y_0 + a_1 x_0 + a_3)$, vanishes, which expresses that the point
+$(x_0,y_0)$ is fixed by the Weierstrass involution, i.e. is $2$-torsion. The conclusion is that the
+quantity `veluGx` of $W$ at $(x_0,y_0)$, namely
+$$3x_0^2 + 2a_2 x_0 + a_4 - a_1 y_0,$$
+is not zero in $R$.
+
+This is the statement that the abscissa of a $2$-torsion point on a curve of invertible (in
+particular nonzero) discriminant is a simple root of the $2$-division polynomial, in the form of the
+nonvanishing of the partial derivative in $x$ of the Weierstrass equation. It supplies the
+nondegeneracy input for the construction of the Vélu quotient by a subgroup of order $2$, and is
+used in establishing the nonvanishing of the discriminant of that quotient and the surjectivity and
+function-field properties of the associated degree-$2$ map.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_veluGx_ne_zero_of_two_torsion.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_veluGx_ne_zero_of_two_torsion
+
+open WeierstrassCurve WeierstrassCurve.Affine in
+theorem solution {R : Type*} [CommRing R] {W : WeierstrassCurve R} {x₀ y₀ : R} (hΔ : W.Δ ≠ 0)
+    (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0) :
+    W.veluGx x₀ y₀ ≠ 0 := by
+  intro h
+  exact hΔ (by rw [Delta_eq_veluGx_sq_mul_velu2QuadDisc hQ hgy, h]; ring)
+
+end S_WeierstrassCurve_veluGx_ne_zero_of_two_torsion
+end P2MW
+export P2MW.S_WeierstrassCurve_veluGx_ne_zero_of_two_torsion (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace WeierstrassCurve
+variable {R : Type*} [CommRing R] {W : WeierstrassCurve R}
+theorem veluGx_ne_zero_of_two_torsion {x₀ y₀ : R} (hΔ : W.Δ ≠ 0)
+    (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0) :
+    W.veluGx x₀ y₀ ≠ 0 :=
+  solution hΔ hQ hgy
+end WeierstrassCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_veluQuotient2_Delta_eq.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_veluQuotient2_Delta_eq.lean
new file mode 100644
index 0000000000..24080fc4ff
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_veluQuotient2_Delta_eq.lean
@@ -0,0 +1,94 @@
+/-
+Based on Prove2Me node WeierstrassCurve.veluQuotient2_Delta_eq
+(35e01041-be58-5e74-b79d-340fff99fa98) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 18408a7d-4df7-513f-b981-4c3e770f7944
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluOrderTwo
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Discriminant of the order-two Vélu quotient
+
+Theorem statement: `WeierstrassCurve.veluQuotient2_Delta_eq`
+(`35e01041-be58-5e74-b79d-340fff99fa98`), by Claude, 2026-09-05.
+
+Proof: submission `18408a7d-4df7-513f-b981-4c3e770f7944`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring and let $W$ be a Weierstrass curve over $R$ with coefficients
+$a_1,a_2,a_3,a_4,a_6$. Let $x_0,y_0\in R$ satisfy the affine Weierstrass equation of $W$ at
+$(x_0,y_0)$, and assume moreover that $\mathrm{veluGy}(x_0,y_0) = -(2y_0 + a_1x_0 + a_3) = 0$, so
+that the point is fixed by the involution of the curve. Write $g_x = \mathrm{veluGx}(x_0,y_0) =
+3x_0^2 + 2a_2x_0 + a_4 - a_1y_0$, and let $W' = \mathrm{veluQuotient2}\,x_0\,y_0$ be the Weierstrass
+curve over $R$ with the same $a_1,a_2,a_3$ as $W$, with $a_4$ replaced by $a_4 - 5g_x$ and with
+$a_6$ replaced by $a_6 - b_2 g_x - 7x_0 g_x$, where $b_2 = a_1^2 + 4a_2$. Then the discriminant of
+$W'$ satisfies $$\Delta(W') = g_x \cdot \bigl(b_2^2 - 8b_2x_0 - 48x_0^2 - 32b_4\bigr)^2,$$ the
+second factor being $\mathrm{velu2QuadDisc}\,x_0$ (with $b_4 = 2a_4 + a_1a_3$).
+
+This is the discriminant formula for the quotient of a Weierstrass curve by the subgroup generated
+by a point of order two in Vélu's explicit form: one factor of $g_x$ is traded for one factor of the
+quadratic cofactor $\mathrm{velu2QuadDisc}$ relative to the corresponding factorisation of
+$\Delta(W)$. It is used to show that the order-two Vélu quotient is again elliptic
+([nonvanishing](thm.html#WeierstrassCurve.veluQuotient2_Delta_ne_zero)),
+to compute its $j$-invariant
+([`WeierstrassCurve.veluQuotient2_j`](thm.html#WeierstrassCurve.veluQuotient2_j)), and in the
+construction of the induced map on points
+([additivity](thm.html#WeierstrassCurve.exists_addMonoidHom_coe_eq_veluPointMap2)).
+
+## Local proof
+
+Translate the kernel point to the origin using `VariableChange`. Mathlib supplies
+invariance of the discriminant; the translated coefficients and quadratic cofactor
+reduce the result to a small polynomial identity over an arbitrary commutative ring.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_veluQuotient2_Delta_eq.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_WeierstrassCurve_veluQuotient2_Delta_eq
+
+open WeierstrassCurve WeierstrassCurve.Affine in
+theorem solution {R : Type*} [CommRing R] {W : WeierstrassCurve R} {x₀ y₀ : R}
+    (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0) :
+    (W.veluQuotient2 x₀ y₀).Δ = W.veluGx x₀ y₀ * W.velu2QuadDisc x₀ ^ 2 := by
+  have hΔ : ((⟨1, x₀, 0, y₀⟩ : VariableChange R) • W.veluQuotient2 x₀ y₀).Δ =
+      (W.veluQuotient2 x₀ y₀).Δ := by
+    simpa only [inv_one, Units.val_one, one_pow, one_mul] using
+      (W.veluQuotient2 x₀ y₀).variableChange_Δ (⟨1, x₀, 0, y₀⟩ : VariableChange R)
+  rw [← hΔ, W.veluQuotient2_variableChange hQ hgy, W.velu2QuadDisc_eq_shifted hgy]
+  simp only [Δ, b₂, b₄, b₆, b₈]
+  ring
+
+end S_WeierstrassCurve_veluQuotient2_Delta_eq
+end P2MW
+export P2MW.S_WeierstrassCurve_veluQuotient2_Delta_eq (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace WeierstrassCurve
+variable {R : Type*} [CommRing R] {W : WeierstrassCurve R}
+theorem veluQuotient2_Delta_eq {x₀ y₀ : R}
+    (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0) :
+    (W.veluQuotient2 x₀ y₀).Δ = W.veluGx x₀ y₀ * W.velu2QuadDisc x₀ ^ 2 :=
+  _root_.P2MW.S_WeierstrassCurve_veluQuotient2_Delta_eq.solution hQ hgy
+end WeierstrassCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_veluQuotient2_Delta_ne_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_veluQuotient2_Delta_ne_zero.lean
new file mode 100644
index 0000000000..91d6a4da0c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_veluQuotient2_Delta_ne_zero.lean
@@ -0,0 +1,85 @@
+/-
+Based on Prove2Me node WeierstrassCurve.veluQuotient2_Delta_ne_zero
+(4a9ddef2-6abc-5f7f-ada6-32fff611524b) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 173e31a9-62fc-53d7-a6b4-5bf96378f194
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluOrderTwo
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_velu2QuadDisc_ne_zero_of_two_torsion
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_veluGx_ne_zero_of_two_torsion
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_veluQuotient2_Delta_eq
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Nonvanishing discriminant of the order-two Vélu quotient
+
+Theorem statement: `WeierstrassCurve.veluQuotient2_Delta_ne_zero`
+(`4a9ddef2-6abc-5f7f-ada6-32fff611524b`), by Claude, 2026-09-05.
+
+Proof: submission `173e31a9-62fc-53d7-a6b4-5bf96378f194`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $R$ be a commutative ring without zero divisors, let $W$ be a Weierstrass curve over $R$ with
+coefficients $a_1,a_2,a_3,a_4,a_6$, and let $x_0,y_0\in R$. Write $g_x=3x_0^2+2a_2x_0+a_4-a_1y_0$
+and $g_y=-(2y_0+a_1x_0+a_3)$ for the two partial derivative expressions `W.veluGx` and `W.veluGy` at
+$(x_0,y_0)$. Assume: the discriminant $\Delta$ of $W$ is nonzero; the pair $(x_0,y_0)$ satisfies the
+affine Weierstrass equation of $W$; and $g_y=0$, i.e. $2y_0+a_1x_0+a_3=0$, so that $(x_0,y_0)$ is a
+point of order dividing $2$. The conclusion is that the Weierstrass curve `W.veluQuotient2 x₀ y₀`,
+defined as the curve with the same $a_1,a_2,a_3$, with fourth coefficient $a_4-5g_x$ and sixth
+coefficient $a_6-b_2g_x-7x_0g_x$ (where $b_2=a_1^2+4a_2$), also has nonzero discriminant.
+
+This is the case of kernel of order two of the statement that the quotient of an elliptic curve by a
+finite subgroup scheme is again elliptic: the explicit Vélu target model attached to a $2$-torsion
+point of a nonsingular Weierstrass curve is itself nonsingular. It discharges the nonsingularity
+hypothesis needed to construct the order-two Vélu isogeny and its induced map on points, and is used
+in the study of the modular polynomial and of rational isogenies.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_veluQuotient2_Delta_ne_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_veluQuotient2_Delta_ne_zero
+
+open WeierstrassCurve WeierstrassCurve.Affine in
+theorem solution {R : Type*} [CommRing R] [NoZeroDivisors R] {W : WeierstrassCurve R}
+    {x₀ y₀ : R} (hΔ : W.Δ ≠ 0)
+    (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0) :
+    (W.veluQuotient2 x₀ y₀).Δ ≠ 0 := by
+  rw [veluQuotient2_Delta_eq hQ hgy]
+  exact mul_ne_zero (veluGx_ne_zero_of_two_torsion hΔ hQ hgy)
+    (pow_ne_zero 2 (velu2QuadDisc_ne_zero_of_two_torsion hΔ hQ hgy))
+
+end S_WeierstrassCurve_veluQuotient2_Delta_ne_zero
+end P2MW
+export P2MW.S_WeierstrassCurve_veluQuotient2_Delta_ne_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+namespace WeierstrassCurve
+variable {R : Type*} [CommRing R] [NoZeroDivisors R] {W : WeierstrassCurve R} {x₀ y₀ : R}
+theorem veluQuotient2_Delta_ne_zero (hΔ : W.Δ ≠ 0)
+    (hQ : W.toAffine.Equation x₀ y₀) (hgy : W.veluGy x₀ y₀ = 0) :
+    (W.veluQuotient2 x₀ y₀).Δ ≠ 0 :=
+  solution hΔ hQ hgy
+end WeierstrassCurve
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_veluQuotient_j_mem_of_mem.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_veluQuotient_j_mem_of_mem.lean
new file mode 100644
index 0000000000..91467b2168
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_veluQuotient_j_mem_of_mem.lean
@@ -0,0 +1,167 @@
+/-
+Based on Prove2Me node WeierstrassCurve.veluQuotient_j_mem_of_mem
+(117f7d23-0e7f-5d3a-a1e9-c35ac3671102) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission a1e46da9-d905-525a-bca7-d43db67c6c2f
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_Velu
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_j_mem_of_a_mem
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# j-invariant of a Vélu quotient lies in a subfield
+
+Theorem statement: `WeierstrassCurve.veluQuotient_j_mem_of_mem`
+(`117f7d23-0e7f-5d3a-a1e9-c35ac3671102`), by Claude, 2026-09-05.
+
+Proof: submission `a1e46da9-d905-525a-bca7-d43db67c6c2f`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $F$ be a field, let $S$ be a type of subobjects of $F$ belonging to a class of subfields, let
+$W$ be a Weierstrass curve over $F$ with coefficients $a_1,a_2,a_3,a_4,a_6$, let $K : S$ be such a
+subfield, and let $T$ be a finite set of pairs $(x,y) \in F \times F$. Write $W'=$ `W.veluQuotient
+T` for the Weierstrass curve with coefficients $(a_1,\,a_2,\,a_3,\,a_4-5t,\,a_6-b_2t-7w)$, where $t
+= \sum_{P \in T} \mathrm{veluT}(P_1,P_2)$ and $w = \sum_{P \in T} \mathrm{veluW}(P_1,P_2)$ are the
+Vélu sums attached to $W$ and $T$, and $b_2 = a_1^2+4a_2$. Assume $a_1, a_2, a_3, a_4, a_6 \in K$,
+that both coordinates of every $P \in T$ lie in $K$, and that the discriminant $\Delta(W')$ is
+nonzero; the last hypothesis is used inline to equip $W'$ with the `IsElliptic` instance that makes
+its $j$-invariant available. The conclusion is $j(W') \in K$. No hypothesis requires the points of
+$T$ to lie on $W$ or to form a subgroup.
+
+This is the rationality statement behind Vélu's construction: the quotient curve $E/C$, and in
+particular its $j$-invariant, is defined over any field containing the coefficients of $E$ and the
+coordinates of the kernel points. It is used in the study of the modular-polynomial covers of the
+$j$-line, where roots of modular polynomials at $j(E)$ are identified with $j$-invariants of Vélu
+quotients by torsion subgroups.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_veluQuotient_j_mem_of_mem.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_veluQuotient_j_mem_of_mem
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "a₃ a₁ b₂ a₄ a₂ a₆ Δ j veluGx veluGy veluT veluU veluW veluTSum \
+  veluWSum veluQuotient veluQuotient_a₁ veluQuotient_a₂ veluQuotient_a₃ veluQuotient_a₄ \
+  veluQuotient_a₆ j_mem_of_a_mem"
+p2m_open "WeierstrassCurve"
+
+p2m_open "WeierstrassCurve P2MW.S_WeierstrassCurve_veluQuotient_j_mem_of_mem.WeierstrassCurve"
+
+variable {L : Type*} [CommRing L] {S : Type*} [SetLike S L] [SubringClass S L]
+variable (V : WeierstrassCurve L) (A : S)
+
+private theorem _root_.WeierstrassCurve.veluGx_mem (h₁ : V.a₁ ∈ A) (h₂ : V.a₂ ∈ A) (h₄ : V.a₄ ∈ A)
+    {x y : L} (hx : x ∈ A) (hy : y ∈ A) : V.veluGx x y ∈ A := by
+  rw [veluGx]
+  exact sub_mem (add_mem (add_mem (mul_mem (ofNat_mem A 3) (pow_mem hx 2))
+    (mul_mem (mul_mem (ofNat_mem A 2) h₂) hx)) h₄) (mul_mem h₁ hy)
+
+p2m_export "WeierstrassCurve" "veluGx_mem"
+
+private theorem _root_.WeierstrassCurve.veluGy_mem (h₁ : V.a₁ ∈ A) (h₃ : V.a₃ ∈ A)
+    {x y : L} (hx : x ∈ A) (hy : y ∈ A) : V.veluGy x y ∈ A := by
+  rw [veluGy]
+  exact neg_mem (add_mem (add_mem (mul_mem (ofNat_mem A 2) hy) (mul_mem h₁ hx)) h₃)
+
+p2m_export "WeierstrassCurve" "veluGy_mem"
+
+private theorem _root_.WeierstrassCurve.veluT_mem (h₁ : V.a₁ ∈ A) (h₂ : V.a₂ ∈ A) (h₃ : V.a₃ ∈ A)
+    (h₄ : V.a₄ ∈ A)
+    {x y : L} (hx : x ∈ A) (hy : y ∈ A) : V.veluT x y ∈ A := by
+  rw [veluT]
+  exact sub_mem (mul_mem (ofNat_mem A 2) (V.veluGx_mem A h₁ h₂ h₄ hx hy))
+    (mul_mem h₁ (V.veluGy_mem A h₁ h₃ hx hy))
+
+p2m_export "WeierstrassCurve" "veluT_mem"
+
+private theorem _root_.WeierstrassCurve.veluU_mem (h₁ : V.a₁ ∈ A) (h₃ : V.a₃ ∈ A)
+    {x y : L} (hx : x ∈ A) (hy : y ∈ A) : V.veluU x y ∈ A := by
+  rw [veluU]
+  exact pow_mem (V.veluGy_mem A h₁ h₃ hx hy) 2
+
+p2m_export "WeierstrassCurve" "veluU_mem"
+
+private theorem _root_.WeierstrassCurve.veluW_mem (h₁ : V.a₁ ∈ A) (h₂ : V.a₂ ∈ A) (h₃ : V.a₃ ∈ A)
+    (h₄ : V.a₄ ∈ A)
+    {x y : L} (hx : x ∈ A) (hy : y ∈ A) : V.veluW x y ∈ A := by
+  rw [veluW]
+  exact add_mem (V.veluU_mem A h₁ h₃ hx hy)
+    (mul_mem hx (V.veluT_mem A h₁ h₂ h₃ h₄ hx hy))
+
+p2m_export "WeierstrassCurve" "veluW_mem"
+
+private theorem _root_.WeierstrassCurve.veluTSum_mem (h₁ : V.a₁ ∈ A) (h₂ : V.a₂ ∈ A) (h₃ : V.a₃ ∈ A)
+    (h₄ : V.a₄ ∈ A)
+    {K : Finset (L × L)} (hK : ∀ P ∈ K, P.1 ∈ A ∧ P.2 ∈ A) :
+    V.veluTSum K ∈ A := by
+  rw [veluTSum]
+  exact sum_mem fun P hP => V.veluT_mem A h₁ h₂ h₃ h₄ (hK P hP).1 (hK P hP).2
+
+p2m_export "WeierstrassCurve" "veluTSum_mem"
+
+private theorem _root_.WeierstrassCurve.veluWSum_mem (h₁ : V.a₁ ∈ A) (h₂ : V.a₂ ∈ A) (h₃ : V.a₃ ∈ A)
+    (h₄ : V.a₄ ∈ A)
+    {K : Finset (L × L)} (hK : ∀ P ∈ K, P.1 ∈ A ∧ P.2 ∈ A) :
+    V.veluWSum K ∈ A := by
+  rw [veluWSum]
+  exact sum_mem fun P hP => V.veluW_mem A h₁ h₂ h₃ h₄ (hK P hP).1 (hK P hP).2
+
+p2m_export "WeierstrassCurve" "veluWSum_mem"
+end WeierstrassCurve
+
+open _root_.WeierstrassCurve
+  _root_.P2MW.S_WeierstrassCurve_veluQuotient_j_mem_of_mem.WeierstrassCurve in
+theorem solution {F : Type*} [Field F] {S : Type*} [SetLike S F] [SubfieldClass S F]
+    (W : WeierstrassCurve F) (K : S) (T : Finset (F × F))
+    (h₁ : W.a₁ ∈ K) (h₂ : W.a₂ ∈ K) (h₃ : W.a₃ ∈ K) (h₄ : W.a₄ ∈ K) (h₆ : W.a₆ ∈ K)
+    (hT : ∀ P ∈ T, P.1 ∈ K ∧ P.2 ∈ K) (hΔ : (W.veluQuotient T).Δ ≠ 0) :
+    haveI : (W.veluQuotient T).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+    (W.veluQuotient T).j ∈ K := by
+  have : (W.veluQuotient T).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+  have ht : W.veluTSum T ∈ K := W.veluTSum_mem K h₁ h₂ h₃ h₄ hT
+  have hw : W.veluWSum T ∈ K := W.veluWSum_mem K h₁ h₂ h₃ h₄ hT
+  have hb₂ : W.b₂ ∈ K := by
+    rw [b₂]; exact add_mem (pow_mem h₁ 2) (mul_mem (ofNat_mem K 4) h₂)
+  refine (W.veluQuotient T).j_mem_of_a_mem K ?_ ?_ ?_ ?_ ?_
+  · rw [veluQuotient_a₁]; exact h₁
+  · rw [veluQuotient_a₂]; exact h₂
+  · rw [veluQuotient_a₃]; exact h₃
+  · rw [veluQuotient_a₄]; exact sub_mem h₄ (mul_mem (ofNat_mem K 5) ht)
+  · rw [veluQuotient_a₆]
+    exact sub_mem (sub_mem h₆ (mul_mem hb₂ ht)) (mul_mem (ofNat_mem K 7) hw)
+
+end S_WeierstrassCurve_veluQuotient_j_mem_of_mem
+end P2MW
+export P2MW.S_WeierstrassCurve_veluQuotient_j_mem_of_mem (solution)
+
+end privateSection
+
+public section publicSection
+
+theorem WeierstrassCurve.veluQuotient_j_mem_of_mem {F : Type*} [Field F] {S : Type*} [SetLike S F]
+    [SubfieldClass S F]
+    (W : WeierstrassCurve F) (K : S) (T : Finset (F × F))
+    (h₁ : W.a₁ ∈ K) (h₂ : W.a₂ ∈ K) (h₃ : W.a₃ ∈ K) (h₄ : W.a₄ ∈ K) (h₆ : W.a₆ ∈ K)
+    (hT : ∀ P ∈ T, P.1 ∈ K ∧ P.2 ∈ K) (hΔ : (W.veluQuotient T).Δ ≠ 0) :
+    haveI : (W.veluQuotient T).IsElliptic := ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+    (W.veluQuotient T).j ∈ K :=
+  solution W K T h₁ h₂ h₃ h₄ h₆ hT hΔ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_veluQuotient_oddOrderSummingSet_discriminant_ne_zero.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_veluQuotient_oddOrderSummingSet_discriminant_ne_zero.lean
new file mode 100644
index 0000000000..4248e12e68
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_veluQuotient_oddOrderSummingSet_discriminant_ne_zero.lean
@@ -0,0 +1,174 @@
+/-
+Based on Prove2Me node WeierstrassCurve.veluQuotient_oddOrderSummingSet_discriminant_ne_zero
+(01bf34f6-bad2-52b8-83ef-b795fb714c92) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 8e008aec-90e8-5c2d-8f8e-e9c0a48d278c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_OddOrderSummingSet
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_Velu
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_eval_psi2Sq_veluQuotient_veluX_eq_zero_of_eval_psi2Sq_eq_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_veluX_oddOrderSummingSet_injOn_psi2Sq_roots
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Vélu quotient by an odd cyclic kernel has nonzero discriminant
+
+Theorem statement: `WeierstrassCurve.veluQuotient_oddOrderSummingSet_discriminant_ne_zero`
+(`01bf34f6-bad2-52b8-83ef-b795fb714c92`), by Claude, 2026-09-05.
+
+Proof: submission `8e008aec-90e8-5c2d-8f8e-e9c0a48d278c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be an algebraically closed field in which $2 \neq 0$, let $W$ be a Weierstrass curve over
+$L$ which is elliptic (its discriminant is a unit), let $n$ be a natural number, and let $Q$ be a
+point of the associated affine curve whose additive order is exactly $2n+1$. Let $S$ be the finite
+subset of $L \times L$ obtained as the image of $\{1,\dots,n\}$ under $k \mapsto$ the coordinate
+pair of $k \cdot Q$, where a point $(x,y)$ is sent to $(x,y)$ and the point at infinity is sent to
+$(0,0)$; thus $S$ records the affine coordinates of $Q, 2Q, \dots, nQ$, one representative of each
+pair $\{kQ,-kQ\}$ of nonzero elements of $\langle Q \rangle$. Let $t = \sum_{P \in S}
+\mathrm{veluT}(P)$ and $w = \sum_{P \in S} \mathrm{veluW}(P)$ be the corresponding Vélu sums, and
+let $W'$ be the Weierstrass curve with the same $a_1, a_2, a_3$ as $W$ and with $a_4' = a_4 - 5t$,
+$a_6' = a_6 - b_2 t - 7w$. The assertion is that the discriminant of $W'$ is nonzero, i.e.
+$\Delta(W') \neq 0$.
+
+This is the statement that Vélu's formulas for the quotient of an elliptic curve by the cyclic
+subgroup generated by a point of odd order again produce an elliptic curve, in the form "the target
+has nonzero discriminant" over an algebraically closed field of characteristic different from $2$.
+It is used in the treatment of modular polynomials and $\Gamma_0(N)$-moduli points, where the
+assignment of a curve to its Vélu quotient must land among elliptic curves, notably in the results
+on roots of the modular polynomial specialised at a transcendental $j$-invariant and in the
+separability statement for such specialisations.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_veluQuotient_oddOrderSummingSet_discriminant_ne_zero.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_veluQuotient_oddOrderSummingSet_discriminant_ne_zero
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_WeierstrassCurve_veluQuotient_oddOrderSummingSet_discriminant_ne_zero.WeierstrassCurve"
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "twoTorsionPolynomial_discr map twoTorsionPolynomial Ψ₂Sq map_id \
+  toAffine Δ Δ' veluQuotient oddOrderSummingSet veluX veluX_oddOrderSummingSet_injOn_psi2Sq_roots \
+  eval_psi2Sq_veluQuotient_veluX_eq_zero_of_eval_psi2Sq_eq_zero"
+p2m_open "WeierstrassCurve"
+
+variable {L : Type*} [Field L] (V : WeierstrassCurve L)
+
+private lemma _root_.WeierstrassCurve.ws18_Ψ₂Sq_eq_toPoly :
+    V.Ψ₂Sq = V.twoTorsionPolynomial.toPoly := by
+  simp only [Ψ₂Sq, twoTorsionPolynomial, Cubic.toPoly]
+
+p2m_export "WeierstrassCurve" "ws18_Ψ₂Sq_eq_toPoly"
+private lemma _root_.WeierstrassCurve.ws18_Ψ₂Sq_ne_zero (h4 : (4 : L) ≠ 0) : V.Ψ₂Sq ≠ 0 := by
+  rw [ws18_Ψ₂Sq_eq_toPoly]
+  exact Cubic.ne_zero_of_a_ne_zero h4
+
+p2m_export "WeierstrassCurve" "ws18_Ψ₂Sq_ne_zero"
+end WeierstrassCurve
+
+theorem solution
+    {L : Type*} [Field L] [DecidableEq L] [IsAlgClosed L] (h2 : (2 : L) ≠ 0)
+    (W : WeierstrassCurve L) [W.IsElliptic] (n : ℕ) (Q : W.toAffine.Point)
+    (hQ : addOrderOf Q = 2 * n + 1) :
+    (W.veluQuotient (W.oddOrderSummingSet Q n)).Δ ≠ 0 := by
+  set S := W.oddOrderSummingSet Q n with hSdef
+  set V' := W.veluQuotient S with hV'def
+  have h4 : (4 : L) ≠ 0 := by
+    have : (4 : L) = (2 : L) ^ 2 := by norm_num
+    rw [this]; exact pow_ne_zero 2 h2
+  have h16 : (16 : L) ≠ 0 := by
+    have : (16 : L) = (2 : L) ^ 4 := by norm_num
+    rw [this]; exact pow_ne_zero 4 h2
+  have haV : W.twoTorsionPolynomial.a ≠ 0 := h4
+  have hdiscrV : W.twoTorsionPolynomial.discr ≠ 0 := by
+    rw [twoTorsionPolynomial_discr]; exact mul_ne_zero h16 W.Δ'.ne_zero
+  have hsplitV : (W.twoTorsionPolynomial.toPoly.map (RingHom.id L)).Splits :=
+    IsAlgClosed.splits _
+  obtain ⟨r₁, r₂, r₃, hroots⟩ := (Cubic.splits_iff_roots_eq_three haV).mp hsplitV
+  obtain ⟨hne₁₂, hne₁₃, hne₂₃⟩ := (Cubic.discr_ne_zero_iff_roots_ne haV hroots).mp hdiscrV
+  have hrootsΨ : W.Ψ₂Sq.roots = {r₁, r₂, r₃} := by
+    rwa [Cubic.map_roots, Polynomial.map_id, ← W.ws18_Ψ₂Sq_eq_toPoly] at hroots
+  have hev : ∀ r ∈ ({r₁, r₂, r₃} : Multiset L), W.Ψ₂Sq.eval r = 0 := fun r hr =>
+    ((Polynomial.mem_roots').mp (hrootsΨ ▸ hr)).2
+  have hev₁ : W.Ψ₂Sq.eval r₁ = 0 := hev r₁ (by simp)
+  have hev₂ : W.Ψ₂Sq.eval r₂ = 0 := hev r₂ (by simp)
+  have hev₃ : W.Ψ₂Sq.eval r₃ = 0 := hev r₃ (by simp)
+  have him₁ := W.eval_psi2Sq_veluQuotient_veluX_eq_zero_of_eval_psi2Sq_eq_zero h2 n Q hQ hev₁
+  have him₂ := W.eval_psi2Sq_veluQuotient_veluX_eq_zero_of_eval_psi2Sq_eq_zero h2 n Q hQ hev₂
+  have him₃ := W.eval_psi2Sq_veluQuotient_veluX_eq_zero_of_eval_psi2Sq_eq_zero h2 n Q hQ hev₃
+  have him_ne₁₂ : W.veluX S r₁ ≠ W.veluX S r₂ := fun h =>
+    hne₁₂ (W.veluX_oddOrderSummingSet_injOn_psi2Sq_roots h2 n Q hQ hev₁ hev₂ h)
+  have him_ne₁₃ : W.veluX S r₁ ≠ W.veluX S r₃ := fun h =>
+    hne₁₃ (W.veluX_oddOrderSummingSet_injOn_psi2Sq_roots h2 n Q hQ hev₁ hev₃ h)
+  have him_ne₂₃ : W.veluX S r₂ ≠ W.veluX S r₃ := fun h =>
+    hne₂₃ (W.veluX_oddOrderSummingSet_injOn_psi2Sq_roots h2 n Q hQ hev₂ hev₃ h)
+  have ha' : V'.twoTorsionPolynomial.a ≠ 0 := h4
+  have hΨ₂'ne : V'.Ψ₂Sq ≠ 0 := V'.ws18_Ψ₂Sq_ne_zero h4
+  have hdeg' : V'.Ψ₂Sq.natDegree = 3 := by
+    rw [V'.ws18_Ψ₂Sq_eq_toPoly]; exact Cubic.natDegree_of_a_ne_zero ha'
+  have hsubnodup : ({W.veluX S r₁, W.veluX S r₂, W.veluX S r₃} : Multiset L).Nodup := by
+    refine Multiset.nodup_cons.mpr ⟨?_,
+      Multiset.nodup_cons.mpr ⟨by simpa using him_ne₂₃, Multiset.nodup_singleton _⟩⟩
+    simp only [Multiset.insert_eq_cons, Multiset.mem_cons, Multiset.mem_singleton]
+    exact not_or.mpr ⟨him_ne₁₂, him_ne₁₃⟩
+  have hsub : ({W.veluX S r₁, W.veluX S r₂, W.veluX S r₃} : Multiset L) ≤ V'.Ψ₂Sq.roots := by
+    refine (Multiset.le_iff_subset hsubnodup).mpr ?_
+    intro a ha
+    simp only [Multiset.insert_eq_cons, Multiset.mem_cons, Multiset.mem_singleton] at ha
+    rcases ha with rfl | rfl | rfl
+    · exact (Polynomial.mem_roots hΨ₂'ne).mpr him₁
+    · exact (Polynomial.mem_roots hΨ₂'ne).mpr him₂
+    · exact (Polynomial.mem_roots hΨ₂'ne).mpr him₃
+  have hrootsV' : V'.Ψ₂Sq.roots = {W.veluX S r₁, W.veluX S r₂, W.veluX S r₃} := by
+    refine (Multiset.eq_of_le_of_card_le hsub ?_).symm
+    rw [show Multiset.card ({W.veluX S r₁, W.veluX S r₂, W.veluX S r₃} : Multiset L) = 3 from by
+      simp]
+    exact hdeg' ▸ Polynomial.card_roots' V'.Ψ₂Sq
+  have hrootsV'Cubic : (Cubic.map (RingHom.id L) V'.twoTorsionPolynomial).roots
+      = {W.veluX S r₁, W.veluX S r₂, W.veluX S r₃} := by
+    rw [Cubic.map_roots, Polynomial.map_id, ← V'.ws18_Ψ₂Sq_eq_toPoly]; exact hrootsV'
+  have hdiscr' : V'.twoTorsionPolynomial.discr ≠ 0 :=
+    (Cubic.discr_ne_zero_iff_roots_ne ha' hrootsV'Cubic).mpr ⟨him_ne₁₂, him_ne₁₃, him_ne₂₃⟩
+  intro hΔ'
+  exact hdiscr' (by rw [twoTorsionPolynomial_discr, hΔ', mul_zero])
+
+end S_WeierstrassCurve_veluQuotient_oddOrderSummingSet_discriminant_ne_zero
+end P2MW
+export P2MW.S_WeierstrassCurve_veluQuotient_oddOrderSummingSet_discriminant_ne_zero (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve
+theorem WeierstrassCurve.veluQuotient_oddOrderSummingSet_discriminant_ne_zero
+    {L : Type*} [Field L] [DecidableEq L] [IsAlgClosed L] (h2 : (2 : L) ≠ 0)
+    (W : WeierstrassCurve L) [W.IsElliptic] (n : ℕ) (Q : W.toAffine.Point)
+    (hQ : addOrderOf Q = 2 * n + 1) :
+    (W.veluQuotient (W.oddOrderSummingSet Q n)).Δ ≠ 0 :=
+  solution h2 W n Q hQ
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_veluX_oddOrderSummingSet_injOn_psi2Sq_roots.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_veluX_oddOrderSummingSet_injOn_psi2Sq_roots.lean
new file mode 100644
index 0000000000..5705ae3409
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_veluX_oddOrderSummingSet_injOn_psi2Sq_roots.lean
@@ -0,0 +1,856 @@
+/-
+Based on Prove2Me node WeierstrassCurve.veluX_oddOrderSummingSet_injOn_psi2Sq_roots
+(6ba267b8-a569-5f57-af9f-1e5f8168114c) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 7edf4b36-3fd3-5e7a-b6e2-b672530d51c8
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_OddOrderSummingSet
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluQuotientMap
+
+import Mathlib.RingTheory.Henselian
+import Mathlib.RingTheory.RegularLocalRing.Defs
+import Mathlib.RingTheory.SimpleRing.Principal
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Injectivity of Vélu's abscissa map on ψ₂²-roots
+
+Theorem statement: `WeierstrassCurve.veluX_oddOrderSummingSet_injOn_psi2Sq_roots`
+(`6ba267b8-a569-5f57-af9f-1e5f8168114c`), by Claude, 2026-09-05.
+
+Proof: submission `7edf4b36-3fd3-5e7a-b6e2-b672530d51c8`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be a field in which $2 \neq 0$, and let $W$ be a Weierstrass curve over $L$ that is
+elliptic. Let $n$ be a natural number and let $Q$ be a point of the associated affine curve $W$
+whose additive order is exactly $2n+1$. Put $S = \{\,(k \bullet Q).\text{coordsOrZero} : 1 \le k \le
+n\,\}$, the image in $L \times L$ of the interval $[1,n]$ under the map sending $k$ to the affine
+coordinates of $k \bullet Q$ (the point at infinity being sent to $(0,0)$), and let $X_S(x) = x +
+\sum_{P \in S} \bigl( t_P/(x - P_1) + u_P/(x - P_1)^2 \bigr)$ be Vélu's abscissa function `veluX`,
+where $t_P = 2 G_x(P) - a_1 G_y(P)$ and $u_P = G_y(P)^2$ in the notation of the project's Vélu data.
+Assume $r, r' \in L$ are both roots of the polynomial $\Psi_2^2$ of $W$ (the square of the second
+division polynomial, $4x^3 + b_2 x^2 + 2b_4 x + b_6$), and that $X_S(r) = X_S(r')$. The conclusion
+is $r = r'$.
+
+This is the injectivity of Vélu's $x$-coordinate map, restricted to the abscissae of the $2$-torsion
+of $W$, for the Vélu summing set of a cyclic subgroup of odd order $2n+1$ generated by $Q$. It is
+used to show that the Vélu quotient of $W$ by such a subgroup has non-vanishing discriminant, i.e.
+that the quotient Weierstrass equation again defines an elliptic curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_veluX_oddOrderSummingSet_injOn_psi2Sq_roots.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_veluX_oddOrderSummingSet_injOn_psi2Sq_roots
+
+p2m_open "Polynomial WeierstrassCurve \
+  P2MW.S_WeierstrassCurve_veluX_oddOrderSummingSet_injOn_psi2Sq_roots.WeierstrassCurve \
+  WeierstrassCurve.Affine \
+  P2MW.S_WeierstrassCurve_veluX_oddOrderSummingSet_injOn_psi2Sq_roots.WeierstrassCurve.Affine \
+  WeierstrassCurve.Affine.Point \
+  P2MW.S_WeierstrassCurve_veluX_oddOrderSummingSet_injOn_psi2Sq_roots.WeierstrassCurve.Affine.Point"
+
+noncomputable section
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine Affine.negY Affine.slope_of_X_ne a₃ a₁ map \
+  Affine.equation_iff_nonsingular_of_Δ_ne_zero b₂ Ψ₂Sq a₄ a₂ a₆ Affine.Point.some \
+  Affine.Point.some.injEq Affine.Point.some.inj reduction toAffine Affine.Point Affine.addX \
+  Affine.nonsingular_neg b₆ Δ Affine.equation_iff Affine.Point.neg_some j b₄ Δ' veluX veluGx \
+  veluGy veluT veluU oddOrderSummingSet mem_oddOrderSummingSet"
+p2m_open "WeierstrassCurve"
+
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "Equation negY slope_of_X_ne \
+  equation_iff_nonsingular_of_Δ_ne_zero slope map Point.some Point.some.injEq Point.X_eq_iff \
+  Nonsingular Point.some.inj Point addX nonsingular_neg Point.some_ne_zero Point.add_of_X_ne \
+  equation_iff polynomial Point.neg_some"
+namespace Point
+p2m_export "WeierstrassCurve.Affine.Point" "some some.injEq neg_zero X_eq_iff some.inj map \
+  some_ne_zero add_of_X_ne zero neg_some coordsOrZero"
+p2m_open "WeierstrassCurve.Affine.Point WeierstrassCurve.Affine"
+
+variable {R : Type*} [CommRing R] {W : Affine R}
+
+private def _root_.WeierstrassCurve.Affine.Point.s18xOrZero : W.Point → R
+  | .zero => 0
+  | .some x _ _ => x
+
+p2m_export "WeierstrassCurve.Affine.Point" "s18xOrZero"
+@[scoped simp] lemma s18xOrZero_zero : (.zero : W.Point).s18xOrZero = 0 := rfl
+
+@[scoped simp] lemma s18xOrZero_some {x y : R} (h : W.Nonsingular x y) :
+    (Point.some x y h).s18xOrZero = x := rfl
+
+@[scoped simp] lemma s18xOrZero_neg (P : W.Point) : (-P).s18xOrZero = P.s18xOrZero := by
+  cases P <;> rfl
+
+lemma s18coordsOrZero_fst (P : W.Point) : P.coordsOrZero.1 = P.s18xOrZero := by
+  cases P <;> rfl
+
+end Affine.Point
+
+section OrderArithmetic
+
+variable {G : Type*} [AddCommGroup G]
+
+lemma s18_nsmul_ne_zero_of_not_dvd {Q : G} {p : ℕ}
+    (hord : addOrderOf Q = p) {k : ℕ} (hk : ¬ p ∣ k) : k • Q ≠ 0 := fun h =>
+  hk (hord ▸ (addOrderOf_dvd_iff_nsmul_eq_zero).mpr h)
+
+lemma s18_not_dvd_of_le_half {p k : ℕ} (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hk1 : 1 ≤ k) (hkn : k ≤ (p - 1) / 2) : ¬ p ∣ k ∧ ¬ p ∣ 2 * k := by
+  have hodd : p % 2 = 1 := Nat.odd_iff.mp hpodd
+  have hhalf : 2 * ((p - 1) / 2) = p - 1 := by omega
+  exact ⟨Nat.not_dvd_of_pos_of_lt (by omega) (by omega),
+    Nat.not_dvd_of_pos_of_lt (by omega) (by omega)⟩
+
+lemma s18_not_dvd_add_of_le_half {p k k' : ℕ} (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hk1 : 1 ≤ k) (hkn : k ≤ (p - 1) / 2) (hk'1 : 1 ≤ k') (hk'n : k' ≤ (p - 1) / 2) :
+    ¬ p ∣ k + k' := by
+  have hodd : p % 2 = 1 := Nat.odd_iff.mp hpodd
+  have hhalf : 2 * ((p - 1) / 2) = p - 1 := by omega
+  exact Nat.not_dvd_of_pos_of_lt (by omega) (by omega)
+
+lemma s18_sub_nsmul_eq_neg {Q : G} {p : ℕ} (hp : p • Q = 0) {k : ℕ}
+    (hk : k ≤ p) : (p - k) • Q = -(k • Q) := by
+  rw [eq_neg_iff_add_eq_zero, ← add_nsmul, Nat.sub_add_cancel hk, hp]
+
+theorem s18_eq_zero_of_two_nsmul_eq_zero_of_mem_zmultiples {Q : G} {p : ℕ} (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {R : G} (h2R : 2 • R = 0)
+    (hRmem : R ∈ AddSubgroup.zmultiples Q) : R = 0 := by
+  have hd2 : addOrderOf R ∣ 2 := addOrderOf_dvd_of_nsmul_eq_zero h2R
+  have hpR : p • R = 0 := by
+    obtain ⟨m, rfl⟩ := AddSubgroup.mem_zmultiples_iff.mp hRmem
+    rw [smul_comm, show p • Q = 0 from hord ▸ addOrderOf_nsmul_eq_zero Q, smul_zero]
+  have hdp : addOrderOf R ∣ p := addOrderOf_dvd_of_nsmul_eq_zero hpR
+  have hcop : Nat.gcd 2 p = 1 := Nat.coprime_two_left.mpr hpodd
+  have h1 : addOrderOf R = 1 := Nat.eq_one_of_dvd_one (hcop ▸ Nat.dvd_gcd hd2 hdp)
+  exact AddMonoid.addOrderOf_eq_one_iff.mp h1
+
+lemma s18_not_mem_zmultiples_add {Q P : G}
+    (hPmem : P ∉ AddSubgroup.zmultiples Q) {K : G}
+    (hK : K ∈ AddSubgroup.zmultiples Q) : P + K ∉ AddSubgroup.zmultiples Q := fun hmem =>
+  hPmem (by simpa using AddSubgroup.sub_mem _ hmem hK)
+
+lemma s18_add_ne_zero_of_not_mem_zmultiples {Q P : G}
+    (hPmem : P ∉ AddSubgroup.zmultiples Q) {K : G}
+    (hK : K ∈ AddSubgroup.zmultiples Q) : P + K ≠ 0 := fun h =>
+  hPmem (by rw [add_eq_zero_iff_eq_neg] at h; exact h ▸ AddSubgroup.neg_mem _ hK)
+
+theorem s18_sum_range_shift_invariant {Q : G}
+    {p : ℕ} (hord : addOrderOf Q = p) {M : Type*} [AddCommMonoid M] (f : G → M) (R : G) :
+    ∑ j ∈ Finset.range p, f (R + Q + j • Q) = ∑ j ∈ Finset.range p, f (R + j • Q) := by
+  rcases Nat.eq_zero_or_pos p with rfl | hp0
+  · simp
+  have hpQ : p • Q = 0 := hord ▸ addOrderOf_nsmul_eq_zero Q
+  have hLHS : ∑ j ∈ Finset.range p, f (R + Q + j • Q)
+      = ∑ k ∈ Finset.Ico 1 (p + 1), f (R + k • Q) := by
+    rw [show Finset.Ico 1 (p + 1) = (Finset.range p).map ⟨(· + 1), add_left_injective 1⟩ from by
+      ext k; simp only [Finset.mem_Ico, Finset.mem_map, Finset.mem_range,
+        Function.Embedding.coeFn_mk]
+      constructor
+      · exact fun ⟨h1, h2⟩ => ⟨k - 1, by omega, by omega⟩
+      · rintro ⟨a, ha, rfl⟩; omega]
+    rw [Finset.sum_map]
+    exact Finset.sum_congr rfl fun j _ => by
+      simp only [Function.Embedding.coeFn_mk]; rw [succ_nsmul', ← add_assoc]
+  have hRHS : ∑ j ∈ Finset.range p, f (R + j • Q)
+      = f (R + 0 • Q) + ∑ k ∈ Finset.Ico 1 p, f (R + k • Q) := by
+    rw [show Finset.range p = insert 0 (Finset.Ico 1 p) from by
+      ext k; simp only [Finset.mem_range, Finset.mem_insert, Finset.mem_Ico]; omega]
+    rw [Finset.sum_insert (by simp)]
+  rw [hLHS, hRHS]
+  have hIco_split : Finset.Ico 1 (p + 1) = insert p (Finset.Ico 1 p) := by
+    ext k; simp only [Finset.mem_insert, Finset.mem_Ico]; omega
+  rw [hIco_split, Finset.sum_insert (by simp), hpQ, zero_nsmul]
+
+theorem s18_nsmul_injOn_range {Q : G} {p : ℕ} (hord : addOrderOf Q = p) {k k' : ℕ}
+    (hkp : k < p) (hk'p : k' < p) (heq : k • Q = k' • Q) : k = k' := by
+  wlog hle : k ≤ k' generalizing k k'
+  · exact (this hk'p hkp heq.symm (by omega)).symm
+  have hsub : (k' - k) • Q = 0 := by
+    have h0 : (k' - k) • Q + k • Q = 0 + k • Q := by
+      rw [← add_nsmul, Nat.sub_add_cancel hle, heq, zero_add]
+    exact add_right_cancel h0
+  have hdvd : p ∣ k' - k := hord ▸ addOrderOf_dvd_iff_nsmul_eq_zero.mpr hsub
+  rcases Nat.eq_zero_or_pos (k' - k) with h0 | h0
+  · omega
+  · exact absurd (Nat.le_of_dvd h0 hdvd) (by omega)
+
+end OrderArithmetic
+
+section SummingSet
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F}
+
+omit [DecidableEq F] in
+lemma s18_exists_some_of_ne_zero {P : W.toAffine.Point} (hP : P ≠ 0) :
+    ∃ (x y : F) (h : W.toAffine.Nonsingular x y), P = Point.some x y h ∧
+      P.coordsOrZero = (x, y) := by
+  rcases P with _ | ⟨x, y, h⟩
+  · exact absurd rfl hP
+  · exact ⟨x, y, h, rfl, rfl⟩
+
+variable {Q : W.toAffine.Point} {p : ℕ}
+
+theorem s18_exists_nsmul_of_mem_oddOrderSummingSet (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {n : ℕ} (hn : n ≤ (p - 1) / 2) {P : F × F}
+    (hP : P ∈ W.oddOrderSummingSet Q n) :
+    ∃ (k : ℕ) (x y : F) (h : W.toAffine.Nonsingular x y), 1 ≤ k ∧ k ≤ n ∧
+      k • Q = Point.some x y h ∧ P = (x, y) ∧ (2 * k) • Q ≠ 0 := by
+  obtain ⟨k, hk1, hkn, hkP⟩ := W.mem_oddOrderSummingSet.mp hP
+  obtain ⟨hndvd, hndvd2⟩ := s18_not_dvd_of_le_half hp3 hpodd hk1 (hkn.trans hn)
+  have hne : k • Q ≠ 0 := s18_nsmul_ne_zero_of_not_dvd hord hndvd
+  obtain ⟨x, y, h, heq, hcoords⟩ := s18_exists_some_of_ne_zero hne
+  exact ⟨k, x, y, h, hk1, hkn, heq, by rw [← hkP, hcoords],
+    s18_nsmul_ne_zero_of_not_dvd hord hndvd2⟩
+
+theorem s18_oddOrderSummingSet_equation (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {n : ℕ} (hn : n ≤ (p - 1) / 2) :
+    ∀ P ∈ W.oddOrderSummingSet Q n, W.toAffine.Equation P.1 P.2 := by
+  intro P hP
+  obtain ⟨_, _, _, h, _, _, _, hPxy, _⟩ :=
+    s18_exists_nsmul_of_mem_oddOrderSummingSet hp3 hpodd hord hn hP
+  rw [hPxy]; exact h.left
+
+theorem s18_nsmul_eq_of_x_eq (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {k k' : ℕ} (hk1 : 1 ≤ k) (hkn : k ≤ (p - 1) / 2)
+    (hk'1 : 1 ≤ k') (hk'n : k' ≤ (p - 1) / 2)
+    {x y : F} {h : W.toAffine.Nonsingular x y} (heq : k • Q = Point.some x y h)
+    {x' y' : F} {h' : W.toAffine.Nonsingular x' y'} (heq' : k' • Q = Point.some x' y' h')
+    (hx : x = x') : k • Q = k' • Q := by
+  rcases (Point.X_eq_iff (h₁ := h) (h₂ := h')).mp hx with hPP | hPP
+  · rw [heq, heq', hPP]
+  · exfalso
+    have hsum : (k + k') • Q = 0 := by rw [add_nsmul, heq, heq', hPP, neg_add_cancel]
+    exact s18_not_dvd_add_of_le_half hp3 hpodd hk1 hkn hk'1 hk'n
+      (hord ▸ addOrderOf_dvd_iff_nsmul_eq_zero.mpr hsum)
+
+theorem s18_nsmul_injOn_half (hp3 : 3 ≤ p) (hord : addOrderOf Q = p) {k k' : ℕ}
+    (hk1 : 1 ≤ k) (hkn : k ≤ (p - 1) / 2) (hk'1 : 1 ≤ k') (hk'n : k' ≤ (p - 1) / 2)
+    (heq : k • Q = k' • Q) : k = k' := by
+  have hhalf : (p - 1) / 2 ≤ p - 1 := Nat.div_le_self _ _
+  wlog hle : k ≤ k' generalizing k k'
+  · exact (this hk'1 hk'n hk1 hkn heq.symm (by omega)).symm
+  have hsub : (k' - k) • Q = 0 := by
+    have : (k' - k) • Q + k • Q = k • Q := by
+      rw [← add_nsmul, Nat.sub_add_cancel hle, heq]
+    exact add_right_cancel (this.trans (zero_add _).symm)
+  have hdvd : p ∣ k' - k := hord ▸ addOrderOf_dvd_iff_nsmul_eq_zero.mpr hsub
+  rcases Nat.eq_zero_or_pos (k' - k) with h0 | h0
+  · omega
+  · exact absurd hdvd (Nat.not_dvd_of_pos_of_lt h0 (by omega))
+
+theorem s18_card_oddOrderSummingSet (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {n : ℕ} (hn : n ≤ (p - 1) / 2) :
+    (W.oddOrderSummingSet Q n).card = n := by
+  have hinj : Set.InjOn (fun k : ℕ => (k • Q).coordsOrZero) (Finset.Icc 1 n : Finset ℕ) := by
+    intro k hk k' hk' hcoords
+    simp only [Finset.coe_Icc, Set.mem_Icc] at hk hk'
+    obtain ⟨hndvd, _⟩ := s18_not_dvd_of_le_half hp3 hpodd hk.1 (hk.2.trans hn)
+    obtain ⟨hndvd', _⟩ := s18_not_dvd_of_le_half hp3 hpodd hk'.1 (hk'.2.trans hn)
+    obtain ⟨x, y, h, heq, hc⟩ :=
+      s18_exists_some_of_ne_zero (s18_nsmul_ne_zero_of_not_dvd hord hndvd (k := k))
+    obtain ⟨x', y', h', heq', hc'⟩ :=
+      s18_exists_some_of_ne_zero (s18_nsmul_ne_zero_of_not_dvd hord hndvd' (k := k'))
+    have hx : x = x' :=
+      congrArg Prod.fst (show ((x, y) : F × F) = (x', y') from hc ▸ hc' ▸ hcoords)
+    exact s18_nsmul_injOn_half hp3 hord hk.1 (hk.2.trans hn) hk'.1 (hk'.2.trans hn)
+      (s18_nsmul_eq_of_x_eq hp3 hpodd hord hk.1 (hk.2.trans hn) hk'.1
+        (hk'.2.trans hn) heq heq' hx)
+  rw [oddOrderSummingSet, Finset.card_image_of_injOn hinj, Nat.card_Icc, Nat.add_sub_cancel]
+
+theorem s18_xOrZero_ne_of_not_mem_zmultiples {P : W.toAffine.Point}
+    (hPmem : P ∉ AddSubgroup.zmultiples Q) (hP0 : P ≠ 0) {x y : F}
+    {h : W.toAffine.Nonsingular x y} (hkQ : Point.some x y h ∈ AddSubgroup.zmultiples Q) :
+    P.s18xOrZero ≠ x := by
+  obtain ⟨a, b, hns, rfl, -⟩ := s18_exists_some_of_ne_zero hP0
+  intro hx
+  rw [s18xOrZero_some] at hx
+  rcases (Point.X_eq_iff (h₁ := hns) (h₂ := h)).mp hx with hPP | hPP
+  · exact hPmem (hPP ▸ hkQ)
+  · exact hPmem (hPP ▸ AddSubgroup.neg_mem _ hkQ)
+
+end SummingSet
+
+section OrbitSum
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve F)
+
+private def _root_.WeierstrassCurve.s18veluXNum (x₀ y₀ x : F) : F :=
+  x * (x - x₀) ^ 2 + W.veluT x₀ y₀ * (x - x₀) + W.veluU x₀ y₀
+
+p2m_export "WeierstrassCurve" "s18veluXNum"
+private theorem _root_.WeierstrassCurve.s18_orbitSumX_singleton_cleared {x₀ y₀ x y : F}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀) :
+    W.s18veluXNum x₀ y₀ x
+      = (x - 2 * x₀) * (x - x₀) ^ 2
+        + ((y - y₀) ^ 2 + W.a₁ * (y - y₀) * (x - x₀) - (W.a₂ + x + x₀) * (x - x₀) ^ 2)
+        + ((y - (-y₀ - W.a₁ * x₀ - W.a₃)) ^ 2
+            + W.a₁ * (y - (-y₀ - W.a₁ * x₀ - W.a₃)) * (x - x₀)
+            - (W.a₂ + x + x₀) * (x - x₀) ^ 2) := by
+  rw [Affine.equation_iff] at hP hQ
+  simp only [s18veluXNum, veluT, veluU, veluGx, veluGy]
+  linear_combination (-2 : F) * hP + 2 * hQ
+
+p2m_export "WeierstrassCurve" "s18_orbitSumX_singleton_cleared"
+variable [DecidableEq F]
+
+omit [DecidableEq F] in
+private lemma _root_.WeierstrassCurve.s18_veluX_singleton (x₀ y₀ : F) {x : F} (hx : x ≠ x₀) :
+    W.veluX {(x₀, y₀)} x = W.s18veluXNum x₀ y₀ x / (x - x₀) ^ 2 := by
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  simp only [veluX, Finset.sum_singleton, s18veluXNum]
+  field_simp
+  ring
+
+p2m_export "WeierstrassCurve" "s18_veluX_singleton"
+
+private theorem _root_.WeierstrassCurve.s18_veluX_singleton_eq_orbitSum {x₀ y₀ x y : F}
+    (hP : W.toAffine.Equation x y) (hQ : W.toAffine.Equation x₀ y₀) (hx : x ≠ x₀) :
+    W.veluX {(x₀, y₀)} x
+      = x + W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y y₀)
+          + W.toAffine.addX x x₀ (W.toAffine.slope x x₀ y (W.toAffine.negY x₀ y₀))
+          - 2 * x₀ := by
+  have hd : x - x₀ ≠ 0 := sub_ne_zero.mpr hx
+  have key := W.s18_orbitSumX_singleton_cleared hP hQ
+  rw [W.s18_veluX_singleton x₀ y₀ hx]
+  simp only [Affine.slope_of_X_ne hx, Affine.addX, Affine.negY]
+  field_simp
+  linear_combination key
+
+p2m_export "WeierstrassCurve" "s18_veluX_singleton_eq_orbitSum"
+omit [DecidableEq F] in
+theorem s18_veluX_eq_add_sum_singleton (S : Finset (F × F)) (x : F) :
+    W.veluX S x = x + ∑ P ∈ S, (W.veluX {P} x - x) := by
+  classical
+  simp only [veluX, Finset.sum_singleton, add_sub_cancel_left]
+
+private theorem _root_.WeierstrassCurve.s18_veluX_eq_orbitSum {S : Finset (F × F)} {x y : F}
+    (hP : W.toAffine.Equation x y)
+    (hSeq : ∀ A ∈ S, W.toAffine.Equation A.1 A.2) (hx : ∀ A ∈ S, x ≠ A.1) :
+    W.veluX S x = x + ∑ A ∈ S,
+      (W.toAffine.addX x A.1 (W.toAffine.slope x A.1 y A.2)
+        + W.toAffine.addX x A.1 (W.toAffine.slope x A.1 y (W.toAffine.negY A.1 A.2))
+        - 2 * A.1) := by
+  rw [s18_veluX_eq_add_sum_singleton]
+  congr 1
+  refine Finset.sum_congr rfl fun A hA => ?_
+  have key := W.s18_veluX_singleton_eq_orbitSum (x₀ := A.1) (y₀ := A.2) hP (hSeq A hA) (hx A hA)
+  rw [show ({(A.1, A.2)} : Finset (F × F)) = {A} from by simp] at key
+  linear_combination key
+
+p2m_export "WeierstrassCurve" "s18_veluX_eq_orbitSum"
+end OrbitSum
+
+section Translation
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F}
+variable {Q : W.toAffine.Point} {p : ℕ}
+
+theorem s18_veluX_oddOrderSummingSet_eq_sum_Icc (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {x y : F} (hP : W.toAffine.Nonsingular x y)
+    (hPmem : (Point.some x y hP : W.toAffine.Point) ∉ AddSubgroup.zmultiples Q) :
+    W.veluX (W.oddOrderSummingSet Q ((p - 1) / 2)) x
+      = x + ∑ k ∈ Finset.Icc 1 ((p - 1) / 2),
+          ((Point.some x y hP + k • Q : W.toAffine.Point).s18xOrZero
+            + (Point.some x y hP + -(k • Q) : W.toAffine.Point).s18xOrZero
+            - 2 * (k • Q).s18xOrZero) := by
+  set d := (p - 1) / 2
+  have hSeq := s18_oddOrderSummingSet_equation (W := W) hp3 hpodd hord (le_refl d)
+  have hx : ∀ A ∈ W.oddOrderSummingSet Q d, x ≠ A.1 := by
+    intro A hA
+    obtain ⟨k, a, b, h, _, _, heq, hAeq, _⟩ :=
+      s18_exists_nsmul_of_mem_oddOrderSummingSet hp3 hpodd hord le_rfl hA
+    subst hAeq
+    have := s18_xOrZero_ne_of_not_mem_zmultiples hPmem
+      (fun h0 => hPmem (h0 ▸ AddSubgroup.zero_mem _))
+      (heq ▸ AddSubgroup.nsmul_mem _ (AddSubgroup.mem_zmultiples Q) k)
+    simpa only [s18xOrZero_some] using this
+  rw [W.s18_veluX_eq_orbitSum hP.1 hSeq hx]
+  congr 1
+  have hcard := s18_card_oddOrderSummingSet (W := W) hp3 hpodd hord (le_refl d)
+  have hIcc : (Finset.Icc 1 d).card = d := by rw [Nat.card_Icc]; omega
+  have hinj : Set.InjOn (fun k : ℕ => (k • Q).coordsOrZero) (Finset.Icc 1 d) := by
+    rw [← Finset.card_image_iff]; exact hcard.trans hIcc.symm
+  change ∑ A ∈ W.oddOrderSummingSet Q d, _ = _
+  rw [oddOrderSummingSet, Finset.sum_image (fun a ha b hb => hinj ha hb)]
+  refine Finset.sum_congr rfl fun k hk => ?_
+  rw [Finset.mem_Icc] at hk
+  obtain ⟨hndvd, _⟩ := s18_not_dvd_of_le_half hp3 hpodd hk.1 hk.2
+  obtain ⟨a, b, hab, hkQeq, hkQc⟩ :=
+    s18_exists_some_of_ne_zero (s18_nsmul_ne_zero_of_not_dvd hord hndvd)
+  rw [hkQc]; dsimp only
+  have hxk : x ≠ a := by
+    have := s18_xOrZero_ne_of_not_mem_zmultiples hPmem
+      (fun h0 => hPmem (h0 ▸ AddSubgroup.zero_mem _))
+      (hkQeq ▸ AddSubgroup.nsmul_mem _ (AddSubgroup.mem_zmultiples Q) k)
+    simpa only [s18xOrZero_some] using this
+  have hPkQ : (Point.some x y hP + k • Q : W.toAffine.Point).s18xOrZero
+      = W.toAffine.addX x a (W.toAffine.slope x a y b) := by
+    rw [hkQeq, Point.add_of_X_ne hxk, s18xOrZero_some]
+  have hnegkQ : -(k • Q) =
+      Point.some a (W.toAffine.negY a b) ((Affine.nonsingular_neg ..).mpr hab) := by
+    rw [hkQeq]; rfl
+  have hPmkQ : (Point.some x y hP + -(k • Q) : W.toAffine.Point).s18xOrZero
+      = W.toAffine.addX x a (W.toAffine.slope x a y (W.toAffine.negY a b)) := by
+    rw [hnegkQ, Point.add_of_X_ne hxk, s18xOrZero_some]
+  rw [hPkQ, hPmkQ, show (k • Q).s18xOrZero = a from by rw [hkQeq, s18xOrZero_some]]
+
+theorem s18_veluX_oddOrderSummingSet_eq_sum_range (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {x y : F} (hP : W.toAffine.Nonsingular x y)
+    (hPmem : (Point.some x y hP : W.toAffine.Point) ∉ AddSubgroup.zmultiples Q) :
+    W.veluX (W.oddOrderSummingSet Q ((p - 1) / 2)) x
+      = (∑ j ∈ Finset.range p, (Point.some x y hP + j • Q : W.toAffine.Point).s18xOrZero)
+        - 2 * ∑ k ∈ Finset.Icc 1 ((p - 1) / 2), (k • Q).s18xOrZero := by
+  have hodd : p % 2 = 1 := Nat.odd_iff.mp hpodd
+  rw [s18_veluX_oddOrderSummingSet_eq_sum_Icc hp3 hpodd hord hP hPmem]
+  obtain ⟨d, hpeq, hd_def⟩ : ∃ d, p = 2 * d + 1 ∧ d = (p - 1) / 2 := ⟨(p - 1) / 2, by omega, rfl⟩
+  rw [← hd_def, Finset.sum_sub_distrib, Finset.sum_add_distrib, ← Finset.mul_sum,
+    show ∀ a b c : F, a + (b - c) = a + b - c from fun a b c => (add_sub_assoc a b c).symm]
+  congr 1
+  have hsplit : Finset.range p = {0} ∪ Finset.Icc 1 d ∪ Finset.Icc (d + 1) (p - 1) := by
+    ext j; simp only [Finset.mem_range, Finset.mem_union, Finset.mem_singleton, Finset.mem_Icc]
+    omega
+  have hdisj1 : Disjoint ({0} : Finset ℕ) (Finset.Icc 1 d) := by
+    rw [Finset.disjoint_left]; intro a ha hb
+    rw [Finset.mem_singleton] at ha; rw [Finset.mem_Icc] at hb; omega
+  have hdisj2 : Disjoint (({0} : Finset ℕ) ∪ Finset.Icc 1 d) (Finset.Icc (d + 1) (p - 1)) := by
+    rw [Finset.disjoint_left]; intro a ha hb
+    rw [Finset.mem_union, Finset.mem_singleton, Finset.mem_Icc] at ha
+    rw [Finset.mem_Icc] at hb; omega
+  rw [hsplit, Finset.sum_union hdisj2, Finset.sum_union hdisj1, Finset.sum_singleton,
+    zero_nsmul, add_zero, s18xOrZero_some]
+  clear hd_def
+  have hrefl : ∑ j ∈ Finset.Icc (d + 1) (p - 1),
+        (Point.some x y hP + j • Q : W.toAffine.Point).s18xOrZero
+      = ∑ k ∈ Finset.Icc 1 d,
+        (Point.some x y hP + -(k • Q) : W.toAffine.Point).s18xOrZero := by
+    refine Finset.sum_nbij' (fun j => p - j) (fun k => p - k)
+      (fun j hj => by rw [Finset.mem_Icc] at hj; simp only [Finset.mem_Icc]; omega)
+      (fun k hk => by rw [Finset.mem_Icc] at hk; simp only [Finset.mem_Icc]; omega)
+      (fun j hj => by rw [Finset.mem_Icc] at hj; omega)
+      (fun k hk => by rw [Finset.mem_Icc] at hk; omega)
+      (fun j hj => ?_)
+    rw [Finset.mem_Icc] at hj
+    congr 2
+    have hpQ : p • Q = 0 := hord ▸ addOrderOf_nsmul_eq_zero Q
+    rw [← s18_sub_nsmul_eq_neg hpQ (k := p - j) (Nat.sub_le _ _)]
+    congr 1; omega
+  rw [hrefl]; ring
+
+theorem s18_veluX_xOrZero_add_gen (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {P : W.toAffine.Point}
+    (hPmem : P ∉ AddSubgroup.zmultiples Q) :
+    W.veluX (W.oddOrderSummingSet Q ((p - 1) / 2)) (P + Q).s18xOrZero
+      = W.veluX (W.oddOrderSummingSet Q ((p - 1) / 2)) P.s18xOrZero := by
+  have hQmem : Q ∈ AddSubgroup.zmultiples Q := AddSubgroup.mem_zmultiples Q
+  have hP0 : P ≠ 0 := fun h => hPmem (h ▸ AddSubgroup.zero_mem _)
+  obtain ⟨x, y, hns, rfl, -⟩ := s18_exists_some_of_ne_zero hP0
+  have hPQmem := s18_not_mem_zmultiples_add hPmem hQmem
+  have hPQ0 : (Point.some x y hns + Q : W.toAffine.Point) ≠ 0 :=
+    s18_add_ne_zero_of_not_mem_zmultiples hPmem hQmem
+  obtain ⟨x', y', hns', heqPQ, -⟩ := s18_exists_some_of_ne_zero hPQ0
+  rw [heqPQ, s18xOrZero_some, s18xOrZero_some,
+    s18_veluX_oddOrderSummingSet_eq_sum_range hp3 hpodd hord hns' (heqPQ ▸ hPQmem),
+    s18_veluX_oddOrderSummingSet_eq_sum_range hp3 hpodd hord hns hPmem]
+  congr 1
+  calc ∑ j ∈ Finset.range p, (Point.some x' y' hns' + j • Q : W.toAffine.Point).s18xOrZero
+      = ∑ j ∈ Finset.range p,
+          ((Point.some x y hns + Q : W.toAffine.Point) + j • Q).s18xOrZero :=
+        Finset.sum_congr rfl fun j _ => by rw [← heqPQ]
+    _ = ∑ j ∈ Finset.range p, (Point.some x y hns + j • Q : W.toAffine.Point).s18xOrZero :=
+        s18_sum_range_shift_invariant hord _ _
+
+theorem s18_veluX_xOrZero_add_nsmul (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {P : W.toAffine.Point}
+    (hPmem : P ∉ AddSubgroup.zmultiples Q) (n : ℕ) :
+    W.veluX (W.oddOrderSummingSet Q ((p - 1) / 2)) (P + n • Q).s18xOrZero
+      = W.veluX (W.oddOrderSummingSet Q ((p - 1) / 2)) P.s18xOrZero := by
+  induction n with
+  | zero => rw [zero_nsmul, add_zero]
+  | succ m ih =>
+    have hPm : P + m • Q ∉ AddSubgroup.zmultiples Q :=
+      s18_not_mem_zmultiples_add hPmem (AddSubgroup.nsmul_mem _ (AddSubgroup.mem_zmultiples Q) m)
+    rw [succ_nsmul, ← add_assoc, s18_veluX_xOrZero_add_gen hp3 hpodd hord hPm, ih]
+
+end Translation
+
+section LevelPoly
+
+variable {F : Type*} [Field F] [DecidableEq F]
+
+def s18veluXDenomPoly (S : Finset (F × F)) : F[X] := ∏ P ∈ S, (X - C P.1)
+
+omit [DecidableEq F] in
+theorem s18veluXDenomPoly_monic (S : Finset (F × F)) : (s18veluXDenomPoly S).Monic :=
+  Polynomial.monic_prod_of_monic _ _ fun _ _ => monic_X_sub_C _
+
+omit [DecidableEq F] in
+theorem s18_natDegree_veluXDenomPoly (S : Finset (F × F)) :
+    (s18veluXDenomPoly S).natDegree = S.card := by
+  unfold s18veluXDenomPoly
+  rw [Polynomial.natDegree_prod_of_monic _ _ (fun _ _ => monic_X_sub_C _)]
+  simp
+
+omit [DecidableEq F] in
+private lemma s18_cleared_summand_aux {a t u E : F} (ha : a ≠ 0) :
+    (t * a + u) * E ^ 2 = (a * E) ^ 2 * (t / a + u / a ^ 2) := by
+  have h2 : a ^ 2 ≠ 0 := pow_ne_zero 2 ha
+  field_simp
+
+variable (W : WeierstrassCurve F)
+
+def s18veluXClearedPoly (S : Finset (F × F)) : F[X] :=
+  X * (s18veluXDenomPoly S) ^ 2
+    + ∑ P ∈ S, (C (W.veluT P.1 P.2) * (X - C P.1) + C (W.veluU P.1 P.2))
+        * (∏ A ∈ S.erase P, (X - C A.1)) ^ 2
+
+theorem s18_eval_veluXClearedPoly (S : Finset (F × F)) {x : F} (hx : ∀ P ∈ S, x ≠ P.1) :
+    (s18veluXClearedPoly W S).eval x = (s18veluXDenomPoly S).eval x ^ 2 * W.veluX S x := by
+  unfold s18veluXClearedPoly s18veluXDenomPoly veluX
+  simp only [eval_add, eval_mul, eval_pow, eval_X, eval_finsetSum, eval_prod, eval_sub, eval_C]
+  rw [mul_add, mul_comm _ x, Finset.mul_sum]
+  congr 1
+  refine Finset.sum_congr rfl fun P hP => ?_
+  have hxP : x - P.1 ≠ 0 := sub_ne_zero.mpr (hx P hP)
+  have hprod : ∏ A ∈ S, (x - A.1) = (x - P.1) * ∏ A ∈ S.erase P, (x - A.1) :=
+    (Finset.prod_erase_mul S _ hP).symm.trans (mul_comm _ _)
+  rw [hprod]
+  exact s18_cleared_summand_aux hxP
+
+theorem s18veluXClearedPoly_monic (S : Finset (F × F)) :
+    (s18veluXClearedPoly W S).Monic ∧ (s18veluXClearedPoly W S).natDegree = 2 * S.card + 1 := by
+  have hD : (s18veluXDenomPoly (F := F) S).Monic := s18veluXDenomPoly_monic S
+  have hDdeg : (s18veluXDenomPoly (F := F) S).natDegree = S.card := s18_natDegree_veluXDenomPoly S
+  have hlead : (X * (s18veluXDenomPoly (F := F) S) ^ 2).Monic := monic_X.mul (hD.pow 2)
+  have hleaddeg : (X * (s18veluXDenomPoly (F := F) S) ^ 2).natDegree = 2 * S.card + 1 := by
+    rw [natDegree_mul monic_X.ne_zero (hD.pow 2).ne_zero, natDegree_X,
+      natDegree_pow, hDdeg]; ring
+  have htraildeg : ∀ P ∈ S, ((C (W.veluT P.1 P.2) * (X - C P.1) + C (W.veluU P.1 P.2))
+      * (∏ A ∈ S.erase P, (X - C A.1)) ^ 2).natDegree ≤ 2 * S.card - 1 := by
+    intro P hP
+    have hcard : (S.erase P).card = S.card - 1 := Finset.card_erase_of_mem hP
+    have h1 : ((∏ A ∈ S.erase P, ((X : F[X]) - C A.1)) ^ 2).natDegree = 2 * (S.card - 1) := by
+      rw [natDegree_pow,
+        Polynomial.natDegree_prod_of_monic _ _ (fun _ _ => monic_X_sub_C _)]
+      simp [hcard]
+    have h2 : (C (W.veluT P.1 P.2) * (X - C P.1) + C (W.veluU P.1 P.2)).natDegree ≤ 1 := by
+      refine (natDegree_add_le _ _).trans ?_
+      refine max_le ?_ (by rw [natDegree_C]; omega)
+      exact (natDegree_C_mul_le _ _).trans (le_of_eq (natDegree_X_sub_C (R := F) P.1))
+    have hSpos : 0 < S.card := Finset.card_pos.mpr ⟨P, hP⟩
+    calc _ ≤ _ + _ := natDegree_mul_le
+      _ ≤ 1 + 2 * (S.card - 1) := add_le_add h2 (le_of_eq h1)
+      _ ≤ 2 * S.card - 1 := by omega
+  have hlt : (∑ P ∈ S, (C (W.veluT P.1 P.2) * (X - C P.1) + C (W.veluU P.1 P.2))
+      * (∏ A ∈ S.erase P, (X - C A.1)) ^ 2).degree
+        < (X * (s18veluXDenomPoly (F := F) S) ^ 2).degree := by
+    rw [Polynomial.degree_eq_natDegree hlead.ne_zero, hleaddeg]
+    refine lt_of_le_of_lt (degree_sum_le _ _) ?_
+    have hbot : (⊥ : WithBot ℕ) < (2 * S.card + 1 : ℕ) := WithBot.bot_lt_coe _
+    refine (Finset.sup_lt_iff hbot).mpr fun P hP => ?_
+    refine lt_of_le_of_lt (Polynomial.degree_le_natDegree) ?_
+    exact_mod_cast lt_of_le_of_lt (htraildeg P hP) (by omega)
+  refine ⟨hlead.add_of_left hlt, ?_⟩
+  have hdegeq : (s18veluXClearedPoly W S).natDegree
+      = (X * (s18veluXDenomPoly (F := F) S) ^ 2).natDegree :=
+    natDegree_add_eq_left_of_degree_lt hlt
+  rw [hdegeq, hleaddeg]
+
+omit [DecidableEq F] in
+theorem s18_card_roots_veluX_eq_le (S : Finset (F × F)) (c : F) (T : Finset F)
+    (hTx : ∀ x ∈ T, ∀ P ∈ S, x ≠ P.1) (hTeq : ∀ x ∈ T, W.veluX S x = c) :
+    T.card ≤ 2 * S.card + 1 := by
+  classical
+  set Φ := s18veluXClearedPoly W S - C c * (s18veluXDenomPoly S) ^ 2
+  have hD : (s18veluXDenomPoly (F := F) S).Monic := s18veluXDenomPoly_monic S
+  obtain ⟨hNmon, hNdeg⟩ := s18veluXClearedPoly_monic W S
+  have hsubdeg : (C c * (s18veluXDenomPoly (F := F) S) ^ 2).natDegree ≤ 2 * S.card := by
+    refine (natDegree_C_mul_le _ _).trans ?_
+    rw [natDegree_pow, s18_natDegree_veluXDenomPoly]
+  have hΦmon : Φ.Monic := by
+    refine hNmon.sub_of_left ?_
+    rw [Polynomial.degree_eq_natDegree hNmon.ne_zero, hNdeg]
+    refine lt_of_le_of_lt Polynomial.degree_le_natDegree ?_
+    exact_mod_cast lt_of_le_of_lt hsubdeg (Nat.lt_succ_self _)
+  have hΦdeg : Φ.natDegree = 2 * S.card + 1 := by
+    refine (natDegree_sub_eq_left_of_natDegree_lt ?_).trans hNdeg
+    exact lt_of_le_of_lt hsubdeg (hNdeg ▸ Nat.lt_succ_self _)
+  have hroot : ∀ x ∈ T, Φ.IsRoot x := by
+    intro x hxT
+    change Φ.eval x = 0
+    rw [eval_sub, eval_mul, eval_pow, eval_C, s18_eval_veluXClearedPoly W S (hTx x hxT),
+      hTeq x hxT, mul_comm, sub_self]
+  calc T.card = T.val.card := rfl
+    _ ≤ Φ.roots.card := Multiset.card_le_card
+        (Multiset.le_iff_subset T.nodup |>.mpr fun x hx =>
+          (Polynomial.mem_roots hΦmon.ne_zero).mpr (hroot x hx))
+    _ ≤ Φ.natDegree := Polynomial.card_roots' Φ
+    _ = 2 * S.card + 1 := hΦdeg
+
+end LevelPoly
+
+section TwoTorsion
+
+variable {F : Type*} [Field F] [DecidableEq F] {W : WeierstrassCurve F}
+
+variable (W) in
+private def _root_.WeierstrassCurve.s18twoTorsionY (x : F) : F := -(W.a₁ * x + W.a₃) / 2
+
+p2m_export "WeierstrassCurve" "s18twoTorsionY"
+omit [DecidableEq F] in
+lemma s18twoTorsionY_eq_negY (h2 : (2 : F) ≠ 0) (x : F) :
+    W.s18twoTorsionY x = W.toAffine.negY x (W.s18twoTorsionY x) := by
+  rw [s18twoTorsionY, Affine.negY]
+  field_simp
+  ring
+
+omit [DecidableEq F] in
+lemma s18_equation_twoTorsionY_iff (h2 : (2 : F) ≠ 0) (x : F) :
+    W.toAffine.Equation x (W.s18twoTorsionY x) ↔ W.Ψ₂Sq.eval x = 0 := by
+  have h4 : (4 : F) ≠ 0 := by
+    have : (4 : F) = (2 : F) ^ 2 := by norm_num
+    rw [this]; exact pow_ne_zero 2 h2
+  have key : (4 : F) * (W.s18twoTorsionY x ^ 2 + W.a₁ * x * W.s18twoTorsionY x +
+      W.a₃ * W.s18twoTorsionY x - (x ^ 3 + W.a₂ * x ^ 2 + W.a₄ * x + W.a₆)) =
+      -(W.Ψ₂Sq.eval x) := by
+    rw [s18twoTorsionY, Ψ₂Sq, b₂, b₄, b₆]
+    simp only [eval_add, eval_mul, eval_pow, eval_C, eval_X]
+    field_simp
+    ring
+  rw [Affine.equation_iff]
+  constructor
+  · intro h
+    linear_combination key - 4 * h
+  · intro h
+    have h0 : (4 : F) * (W.s18twoTorsionY x ^ 2 + W.a₁ * x * W.s18twoTorsionY x +
+        W.a₃ * W.s18twoTorsionY x - (x ^ 3 + W.a₂ * x ^ 2 + W.a₄ * x + W.a₆)) = 0 := by
+      rw [key, h, _root_.neg_zero]
+    have := (mul_eq_zero.mp h0).resolve_left h4
+    linear_combination this
+
+lemma s18_two_nsmul_eq_zero_iff_Y_eq_negY {x y : F} (h : W.toAffine.Nonsingular x y) :
+    2 • (Point.some x y h : W.toAffine.Point) = 0 ↔ y = W.toAffine.negY x y := by
+  rw [two_nsmul, add_eq_zero_iff_eq_neg, Affine.Point.neg_some]
+  exact ⟨fun hP => (Affine.Point.some.inj hP).right,
+    fun hy => by simp only [Affine.Point.some.injEq]; exact ⟨trivial, hy⟩⟩
+
+variable {Q : W.toAffine.Point} {p : ℕ}
+
+theorem s18_twoTorsion_affine_not_mem_zmultiples (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {x y : F} {h : W.toAffine.Nonsingular x y}
+    (h2P : 2 • (Point.some x y h : W.toAffine.Point) = 0) :
+    (Point.some x y h : W.toAffine.Point) ∉ AddSubgroup.zmultiples Q := fun hmem =>
+  Point.some_ne_zero _
+    (s18_eq_zero_of_two_nsmul_eq_zero_of_mem_zmultiples hpodd hord h2P hmem)
+
+theorem s18_halfOrbit_xOrZero_injOn (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {P : W.toAffine.Point} (h2P : 2 • P = 0)
+    (hPmem : P ∉ AddSubgroup.zmultiples Q) :
+    Set.InjOn (fun k : ℕ => (P + k • Q).s18xOrZero) (Finset.Icc 0 ((p - 1) / 2)) := by
+  set d := (p - 1) / 2
+  have hodd : p % 2 = 1 := Nat.odd_iff.mp hpodd
+  have h2d : 2 * d = p - 1 := by omega
+  intro k hk k' hk' heq
+  simp only [Finset.coe_Icc, Set.mem_Icc] at hk hk'
+  have hkmem : k • Q ∈ AddSubgroup.zmultiples Q :=
+    AddSubgroup.nsmul_mem _ (AddSubgroup.mem_zmultiples Q) k
+  have hk'mem : k' • Q ∈ AddSubgroup.zmultiples Q :=
+    AddSubgroup.nsmul_mem _ (AddSubgroup.mem_zmultiples Q) k'
+  obtain ⟨a, b, hab, hPk, -⟩ :=
+    s18_exists_some_of_ne_zero (s18_add_ne_zero_of_not_mem_zmultiples hPmem hkmem)
+  obtain ⟨a', b', hab', hPk', -⟩ :=
+    s18_exists_some_of_ne_zero (s18_add_ne_zero_of_not_mem_zmultiples hPmem hk'mem)
+  dsimp only at heq
+  rw [hPk, hPk', s18xOrZero_some, s18xOrZero_some] at heq
+  rcases (Point.X_eq_iff (h₁ := hab) (h₂ := hab')).mp heq with hPP | hPP
+  · exact s18_nsmul_injOn_range hord (by omega) (by omega)
+      (add_left_cancel (hPk.trans (hPP.trans hPk'.symm)))
+  · have h1 : (P + k • Q) + (P + k' • Q) = 0 := by rw [hPk, hPk', hPP, neg_add_cancel]
+    have h2 : 2 • P + (k + k') • Q = 0 := by
+      rw [two_nsmul, add_nsmul]
+      have hr : P + k • Q + (P + k' • Q) = P + P + (k • Q + k' • Q) := by abel
+      rw [← hr, h1]
+    have hsum : (k + k') • Q = 0 := by rwa [h2P, zero_add] at h2
+    have hdvd : p ∣ k + k' := hord ▸ addOrderOf_dvd_iff_nsmul_eq_zero.mpr hsum
+    rcases Nat.eq_zero_or_pos (k + k') with h0 | h0
+    · omega
+    · exact absurd (Nat.le_of_dvd h0 hdvd) (by omega)
+
+theorem s18_halfOrbit_xOrZero_disjoint (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {P P' : W.toAffine.Point} (h2P : 2 • P = 0) (h2P' : 2 • P' = 0)
+    (hPmem : P ∉ AddSubgroup.zmultiples Q) (hP'mem : P' ∉ AddSubgroup.zmultiples Q)
+    (hne : P ≠ P') (k j : ℕ) :
+    (P + k • Q).s18xOrZero ≠ (P' + j • Q).s18xOrZero := by
+  have hkmem : k • Q ∈ AddSubgroup.zmultiples Q :=
+    AddSubgroup.nsmul_mem _ (AddSubgroup.mem_zmultiples Q) k
+  have hjmem : j • Q ∈ AddSubgroup.zmultiples Q :=
+    AddSubgroup.nsmul_mem _ (AddSubgroup.mem_zmultiples Q) j
+  obtain ⟨a, b, hab, hPk, -⟩ :=
+    s18_exists_some_of_ne_zero (s18_add_ne_zero_of_not_mem_zmultiples hPmem hkmem)
+  obtain ⟨a', b', hab', hP'j, -⟩ :=
+    s18_exists_some_of_ne_zero (s18_add_ne_zero_of_not_mem_zmultiples hP'mem hjmem)
+  rw [hPk, hP'j, s18xOrZero_some, s18xOrZero_some]
+  intro heq
+  rcases (Point.X_eq_iff (h₁ := hab) (h₂ := hab')).mp heq with hPP | hPP
+  · have hPkP'j : P + k • Q = P' + j • Q := hPk.trans (hPP.trans hP'j.symm)
+    have hPP' : P - P' = j • Q - k • Q := by
+      have h0 : (P + k • Q) - (P' + j • Q) = 0 := by rw [hPkP'j, sub_self]
+      have hr : P - P' - (j • Q - k • Q) = (P + k • Q) - (P' + j • Q) := by abel
+      rw [← sub_eq_zero, hr, h0]
+    have hPP'mem : P - P' ∈ AddSubgroup.zmultiples Q := hPP' ▸ AddSubgroup.sub_mem _ hjmem hkmem
+    have h2PP' : 2 • (P - P') = 0 := by rw [smul_sub, h2P, h2P', sub_zero]
+    exact hne (sub_eq_zero.mp
+      (s18_eq_zero_of_two_nsmul_eq_zero_of_mem_zmultiples hpodd hord h2PP' hPP'mem))
+  · have h1 : (P + k • Q) + (P' + j • Q) = 0 := by rw [hPk, hP'j, hPP, neg_add_cancel]
+    have hPP'sum : P + P' + (k • Q + j • Q) = 0 := by
+      have hr : P + k • Q + (P' + j • Q) = P + P' + (k • Q + j • Q) := by abel
+      rw [← hr, h1]
+    have hPP'mem : P + P' ∈ AddSubgroup.zmultiples Q :=
+      eq_neg_of_add_eq_zero_left hPP'sum ▸
+        AddSubgroup.neg_mem _ (AddSubgroup.add_mem _ hkmem hjmem)
+    have h2PP' : 2 • (P + P') = 0 := by rw [smul_add, h2P, h2P', add_zero]
+    have hPP'0 : P + P' = 0 :=
+      s18_eq_zero_of_two_nsmul_eq_zero_of_mem_zmultiples hpodd hord h2PP' hPP'mem
+    have hPneg : -P = P := neg_eq_of_add_eq_zero_left (two_nsmul P ▸ h2P)
+    exact hne ((eq_neg_of_add_eq_zero_right hPP'0).trans hPneg).symm
+
+theorem s18_add_nsmul_xOrZero_ne_kernel (hp3 : 3 ≤ p) (hpodd : Odd p)
+    (hord : addOrderOf Q = p) {P : W.toAffine.Point}
+    (hPmem : P ∉ AddSubgroup.zmultiples Q) (k : ℕ)
+    {A : F × F} (hA : A ∈ W.oddOrderSummingSet Q ((p - 1) / 2)) :
+    (P + k • Q).s18xOrZero ≠ A.1 := by
+  obtain ⟨m, a, b, hns, _, _, hkQeq, hAeq, _⟩ :=
+    s18_exists_nsmul_of_mem_oddOrderSummingSet hp3 hpodd hord le_rfl hA
+  subst hAeq
+  have hkmem : k • Q ∈ AddSubgroup.zmultiples Q :=
+    AddSubgroup.nsmul_mem _ (AddSubgroup.mem_zmultiples Q) k
+  exact s18_xOrZero_ne_of_not_mem_zmultiples (s18_not_mem_zmultiples_add hPmem hkmem)
+    (s18_add_ne_zero_of_not_mem_zmultiples hPmem hkmem)
+    (hkQeq ▸ AddSubgroup.nsmul_mem _ (AddSubgroup.mem_zmultiples Q) m)
+
+theorem s18_veluX_oddOrderSummingSet_injOn_twoTorsion
+    (h2 : (2 : F) ≠ 0) (hp3 : 3 ≤ p) (hpodd : Odd p) (hord : addOrderOf Q = p)
+    (hVΔ : W.Δ ≠ 0) {r r' : F} (hr : W.Ψ₂Sq.eval r = 0) (hr' : W.Ψ₂Sq.eval r' = 0)
+    (heq : W.veluX (W.oddOrderSummingSet Q ((p - 1) / 2)) r
+      = W.veluX (W.oddOrderSummingSet Q ((p - 1) / 2)) r') : r = r' := by
+  set d := (p - 1) / 2 with hd_def
+  set S := W.oddOrderSummingSet Q d with hS_def
+  have hodd : p % 2 = 1 := Nat.odd_iff.mp hpodd
+  have hScard : S.card = d := s18_card_oddOrderSummingSet hp3 hpodd hord le_rfl
+  by_contra hne
+  have hnsP : W.toAffine.Nonsingular r (W.s18twoTorsionY r) :=
+    (Affine.equation_iff_nonsingular_of_Δ_ne_zero (W := W.toAffine) hVΔ).mp
+      ((s18_equation_twoTorsionY_iff h2 r).mpr hr)
+  have hnsP' : W.toAffine.Nonsingular r' (W.s18twoTorsionY r') :=
+    (Affine.equation_iff_nonsingular_of_Δ_ne_zero (W := W.toAffine) hVΔ).mp
+      ((s18_equation_twoTorsionY_iff h2 r').mpr hr')
+  set P := (Point.some r (W.s18twoTorsionY r) hnsP : W.toAffine.Point)
+  set P' := (Point.some r' (W.s18twoTorsionY r') hnsP' : W.toAffine.Point)
+  have h2P : 2 • P = 0 :=
+    (s18_two_nsmul_eq_zero_iff_Y_eq_negY hnsP).mpr (s18twoTorsionY_eq_negY h2 r)
+  have h2P' : 2 • P' = 0 :=
+    (s18_two_nsmul_eq_zero_iff_Y_eq_negY hnsP').mpr (s18twoTorsionY_eq_negY h2 r')
+  have hPmem : P ∉ AddSubgroup.zmultiples Q :=
+    s18_twoTorsion_affine_not_mem_zmultiples hpodd hord h2P
+  have hP'mem : P' ∉ AddSubgroup.zmultiples Q :=
+    s18_twoTorsion_affine_not_mem_zmultiples hpodd hord h2P'
+  have hPP' : P ≠ P' := fun h => hne (by injection h)
+  set T₁ : Finset F := (Finset.Icc 0 d).image (fun k => (P + k • Q).s18xOrZero)
+  set T₂ : Finset F := (Finset.Icc 0 d).image (fun k => (P' + k • Q).s18xOrZero)
+  have hT₁card : T₁.card = d + 1 := by
+    rw [Finset.card_image_of_injOn (s18_halfOrbit_xOrZero_injOn hp3 hpodd hord h2P hPmem),
+      Nat.card_Icc]; omega
+  have hT₂card : T₂.card = d + 1 := by
+    rw [Finset.card_image_of_injOn (s18_halfOrbit_xOrZero_injOn hp3 hpodd hord h2P' hP'mem),
+      Nat.card_Icc]; omega
+  have hdisj : Disjoint T₁ T₂ := by
+    rw [Finset.disjoint_left]
+    intro a ha hb
+    obtain ⟨k, _, rfl⟩ := Finset.mem_image.mp ha
+    obtain ⟨j, _, hbj⟩ := Finset.mem_image.mp hb
+    exact s18_halfOrbit_xOrZero_disjoint hpodd hord h2P h2P' hPmem hP'mem hPP' k j hbj.symm
+  set T := T₁ ∪ T₂
+  have hTcard : T.card = 2 * (d + 1) := by
+    rw [Finset.card_union_of_disjoint hdisj, hT₁card, hT₂card]; ring
+  set c := W.veluX S r
+  have hT_avoid : ∀ x ∈ T, ∀ A ∈ S, x ≠ A.1 := by
+    intro x hxT A hA
+    rcases Finset.mem_union.mp hxT with hx | hx
+    · obtain ⟨k, _, rfl⟩ := Finset.mem_image.mp hx
+      exact s18_add_nsmul_xOrZero_ne_kernel hp3 hpodd hord hPmem k hA
+    · obtain ⟨k, _, rfl⟩ := Finset.mem_image.mp hx
+      exact s18_add_nsmul_xOrZero_ne_kernel hp3 hpodd hord hP'mem k hA
+  have hPx : P.s18xOrZero = r := s18xOrZero_some hnsP
+  have hP'x : P'.s18xOrZero = r' := s18xOrZero_some hnsP'
+  have hT_eq : ∀ x ∈ T, W.veluX S x = c := by
+    intro x hxT
+    rcases Finset.mem_union.mp hxT with hx | hx
+    · obtain ⟨k, _, rfl⟩ := Finset.mem_image.mp hx
+      rw [hS_def, hd_def, s18_veluX_xOrZero_add_nsmul hp3 hpodd hord hPmem k, hPx]
+    · obtain ⟨k, _, rfl⟩ := Finset.mem_image.mp hx
+      rw [hS_def, hd_def, s18_veluX_xOrZero_add_nsmul hp3 hpodd hord hP'mem k, hP'x,
+        ← heq]
+  have hbound := s18_card_roots_veluX_eq_le W S c T hT_avoid hT_eq
+  rw [hTcard, hScard] at hbound
+  omega
+
+end TwoTorsion
+end WeierstrassCurve
+end
+
+theorem solution
+    {L : Type*} [Field L] [DecidableEq L] (h2 : (2 : L) ≠ 0)
+    (W : WeierstrassCurve L) [W.IsElliptic] (n : ℕ) (Q : W.toAffine.Point)
+    (hQ : addOrderOf Q = 2 * n + 1) {r r' : L}
+    (hr : W.Ψ₂Sq.eval r = 0) (hr' : W.Ψ₂Sq.eval r' = 0)
+    (heq : W.veluX (W.oddOrderSummingSet Q n) r = W.veluX (W.oddOrderSummingSet Q n) r') :
+    r = r' := by
+  rcases Nat.eq_zero_or_pos n with rfl | hn
+  · have h0 : W.oddOrderSummingSet Q 0 = ∅ := by simp [WeierstrassCurve.oddOrderSummingSet]
+    simpa [h0] using heq
+  · have hp3 : 3 ≤ 2 * n + 1 := by omega
+    have hpodd : Odd (2 * n + 1) := ⟨n, rfl⟩
+    have hn_eq : ((2 * n + 1) - 1) / 2 = n := by omega
+    have key := WeierstrassCurve.s18_veluX_oddOrderSummingSet_injOn_twoTorsion
+      (W := W) (Q := Q) h2 hp3 hpodd hQ W.Δ'.ne_zero hr hr'
+    rw [hn_eq] at key
+    exact key heq
+
+end S_WeierstrassCurve_veluX_oddOrderSummingSet_injOn_psi2Sq_roots
+end P2MW
+export P2MW.S_WeierstrassCurve_veluX_oddOrderSummingSet_injOn_psi2Sq_roots (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve
+theorem WeierstrassCurve.veluX_oddOrderSummingSet_injOn_psi2Sq_roots
+    {L : Type*} [Field L] [DecidableEq L] (h2 : (2 : L) ≠ 0)
+    (W : WeierstrassCurve L) [W.IsElliptic] (n : ℕ) (Q : W.toAffine.Point)
+    (hQ : addOrderOf Q = 2 * n + 1) {r r' : L}
+    (hr : W.Ψ₂Sq.eval r = 0) (hr' : W.Ψ₂Sq.eval r' = 0)
+    (heq : W.veluX (W.oddOrderSummingSet Q n) r = W.veluX (W.oddOrderSummingSet Q n) r') :
+    r = r' :=
+  solution h2 W n Q hQ hr hr' heq
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_velu_map_equation_of_oddOrderSummingSet.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_velu_map_equation_of_oddOrderSummingSet.lean
new file mode 100644
index 0000000000..e41db79bfb
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_velu_map_equation_of_oddOrderSummingSet.lean
@@ -0,0 +1,1239 @@
+/-
+Based on Prove2Me node WeierstrassCurve.velu_map_equation_of_oddOrderSummingSet
+(99841a34-31c0-570f-ae9f-f8802f859369) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 368c886c-4d95-5623-a9cf-0bde6782ce35
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+public import Mathlib.FieldTheory.IsAlgClosed.Basic
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_OddOrderSummingSet
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_VeluPointMap
+
+import Mathlib.Algebra.Algebra.IsSimpleRing
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.AlgebraicGeometry.EllipticCurve.DivisionPolynomial.Degree
+import Mathlib.Analysis.Normed.Ring.Lemmas
+import Mathlib.Data.Int.Star
+import Mathlib.FieldTheory.PurelyInseparable.Exponent
+import Mathlib.Order.CompletePartialOrder
+import Mathlib.RingTheory.LocalProperties.Reduced
+import Mathlib.RingTheory.Norm.Transitivity
+import Mathlib.RingTheory.PicardGroup
+import Mathlib.RingTheory.TotallySplit
+
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlaceEvaluation
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_PlacesOverDVR
+import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_RatFuncPlaceClassification
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_FunctionFieldQuadratic
+import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_RatPointHom
+import LeanPool.FLTEichlerShimura.Definitions.Defs_AlgebraicCurve_residueTheorem_sharedLibrary
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Definitions.Defs_WeierstrassCurve_veluSharedLibrary
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ord_eq_neg_log_of_valuationSubring_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Place_ramificationIndex_eq_ramificationIdx_fiberCenter
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_deg_placeInfty
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_degree_eq_zero_of_forall_eq_ord_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_finite_setOf_ord_ne_zero
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_eq_neg_log
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_ofHeightOneSpectrum_of_span
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty_X
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_ord_placeInfty_algebraMap
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_RationalFunctionField_subsingleton_setOf_forall_ne_ofHeightOneSpectrum
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finite_setOf_ord_ne_zero_of_finiteDimensional
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_adjoin_yCoord_eq_top
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_degree_eq_sum_support
+
+/-!
+# Vélu's formulas land on the quotient curve (odd order)
+
+Theorem statement: `WeierstrassCurve.velu_map_equation_of_oddOrderSummingSet`
+(`99841a34-31c0-570f-ae9f-f8802f859369`), by Claude, 2026-09-05.
+
+Proof: submission `368c886c-4d95-5623-a9cf-0bde6782ce35`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $L$ be an algebraically closed field in which $2 \neq 0$, and let $W$ be a Weierstrass curve
+over $L$ with invertible discriminant. Let $n$ be a natural number and let $Q$ be an affine point of
+$W$ whose additive order equals $2n+1$. Put $S = W.\mathrm{oddOrderSummingSet}\,Q\,n$, the finite
+subset of $L \times L$ obtained as the image of $\{1,\dots,n\}$ under $k \mapsto$ the coordinate
+pair of $k \cdot Q$ (the point at infinity being sent to $(0,0)$). For $P = (x_P,y_P)$ write $g^x_P
+= 3x_P^2 + 2a_2x_P + a_4 - a_1y_P$, $g^y_P = -(2y_P + a_1x_P + a_3)$, $t_P = 2g^x_P - a_1g^y_P$,
+$u_P = (g^y_P)^2$, and let $t = \sum_{P \in S} t_P$, $w = \sum_{P \in S}
+W.\mathrm{veluW}\,x_P\,y_P$. Then for any $x, y \in L$ satisfying the affine Weierstrass equation of
+$W$ and such that $x \neq x_P$ for every $P \in S$, the pair $\bigl(\mathrm{veluX}_S(x),
+\mathrm{veluY}_S(x,y)\bigr)$, given by the Vélu sums $x + \sum_{P}\bigl(t_P/(x-x_P) +
+u_P/(x-x_P)^2\bigr)$ and $y - \sum_P\bigl(u_P(2y+a_1x+a_3)/(x-x_P)^3 +
+t_P(a_1(x-x_P)+y-y_P)/(x-x_P)^2 + (a_1u_P - g^x_Pg^y_P)/(x-x_P)^2\bigr)$, satisfies the affine
+Weierstrass equation of the curve with coefficients $a_1, a_2, a_3$, $a_4 - 5t$, $a_6 - b_2 t - 7w$.
+
+This is the part of Vélu's Théorème 1 asserting that the explicit coordinate maps attached to a
+summing set for the odd cyclic subgroup $\langle Q \rangle$ carry affine points of $W$ (away from
+the kernel abscissae) to points of the quotient curve; the group-homomorphism properties are treated
+separately. It is used in the construction of the Vélu isogeny at the level of function fields and
+in the comparison of $2$-division values on $W$ and on the quotient curve.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_velu_map_equation_of_oddOrderSummingSet.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+noncomputable section privateSection
+
+open Polynomial IsDedekindDomain WithZero IsLocalRing
+
+open scoped Polynomial.Bivariate
+
+namespace AlgebraicCurve
+
+namespace RationalFunctionField
+
+variable (K : Type*) [Field K]
+
+section PlaceInfty
+
+variable [DecidableEq (RatFunc K)]
+
+theorem inftyValuation_isEquiv_adicValuation :
+    (RatFunc.inftyValuation K).IsEquiv (placeInfty K).adicValuation :=
+  (placeInfty K).isEquiv_adicValuation_of_valuationSubring_eq rfl
+
+end PlaceInfty
+open scoped Place
+
+variable {K}
+
+theorem finite_setOf_valuation_ne_one {f : RatFunc K} (hf : f ≠ 0) :
+    {w : HeightOneSpectrum K[X] | w.valuation (RatFunc K) f ≠ 1}.Finite := by
+  have hnum : (Ideal.span {f.num} : Ideal K[X]) ≠ 0 := by
+    simpa [Ideal.span_singleton_eq_bot] using RatFunc.num_ne_zero hf
+  have hden : (Ideal.span {f.denom} : Ideal K[X]) ≠ 0 := by
+    simpa [Ideal.span_singleton_eq_bot] using f.denom_ne_zero
+  refine Set.Finite.subset ((Ideal.finite_factors hnum).union (Ideal.finite_factors hden))
+    fun w hw => ?_
+  by_contra hcon
+  simp only [Set.mem_union, Set.mem_ofPred_eq, not_or, Ideal.dvd_span_singleton] at hcon
+  refine hw ?_
+  have h1 : w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) f.num) = 1 :=
+    (HeightOneSpectrum.valuation_eq_one_iff_notMem w).mpr hcon.1
+  have h2 : w.valuation (RatFunc K) (algebraMap K[X] (RatFunc K) f.denom) = 1 :=
+    (HeightOneSpectrum.valuation_eq_one_iff_notMem w).mpr hcon.2
+  rw [show f = algebraMap K[X] (RatFunc K) f.num / algebraMap K[X] (RatFunc K) f.denom from
+    f.num_div_denom.symm, map_div₀, h1, h2]
+  exact div_one 1
+
+section DegInfty
+
+variable (K) [DecidableEq (RatFunc K)]
+
+theorem exists_sub_algebraMap_intDegree_neg {x : RatFunc K}
+    (hx : RatFunc.inftyValuation K x ≤ 1) :
+    ∃ c : K, x - algebraMap K (RatFunc K) c = 0 ∨
+      (x - algebraMap K (RatFunc K) c).intDegree < 0 := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · exact ⟨0, Or.inl (by simp)⟩
+  have hdeg : x.intDegree ≤ 0 := by
+    rw [RatFunc.inftyValuation_apply, RatFunc.inftyValuation_of_nonzero K hx0,
+      show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_le_exp] at hx
+    exact hx
+  have hnum0 : x.num ≠ 0 := RatFunc.num_ne_zero hx0
+  have hden0 : x.denom ≠ 0 := x.denom_ne_zero
+  rcases lt_or_eq_of_le hdeg with hlt | heq
+  · exact ⟨0, Or.inr (by simpa using hlt)⟩
+  have hndeg : x.num.natDegree = x.denom.natDegree := by
+    have h2 := heq
+    rw [RatFunc.intDegree, sub_eq_zero] at h2
+    exact_mod_cast h2
+  set c : K := x.num.leadingCoeff / x.denom.leadingCoeff with hc
+  have hc0 : c ≠ 0 := by
+    rw [hc]
+    exact div_ne_zero (Polynomial.leadingCoeff_ne_zero.mpr hnum0)
+      (Polynomial.leadingCoeff_ne_zero.mpr hden0)
+  refine ⟨c, ?_⟩
+  have hsub : x - algebraMap K (RatFunc K) c
+      = algebraMap K[X] (RatFunc K) (x.num - Polynomial.C c * x.denom)
+        / algebraMap K[X] (RatFunc K) x.denom := by
+    rw [map_sub, map_mul, sub_div, x.num_div_denom, mul_div_assoc,
+      div_self ((map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hden0),
+      mul_one, IsScalarTower.algebraMap_apply K K[X] (RatFunc K), Polynomial.algebraMap_eq]
+  rcases eq_or_ne (x.num - Polynomial.C c * x.denom) 0 with hzero | hnz
+  · exact Or.inl (by rw [hsub, hzero, _root_.map_zero, zero_div])
+  refine Or.inr ?_
+  rw [hsub, RatFunc.intDegree_div ((map_ne_zero_iff _
+      (IsFractionRing.injective K[X] (RatFunc K))).mpr hnz)
+    ((map_ne_zero_iff _ (IsFractionRing.injective K[X] (RatFunc K))).mpr hden0),
+    RatFunc.intDegree_polynomial, RatFunc.intDegree_polynomial, sub_neg]
+  have hCdeg : (Polynomial.C c * x.denom).degree = x.denom.degree := by
+    rw [Polynomial.degree_mul, Polynomial.degree_C hc0, zero_add]
+  have hdegeq : x.num.degree = (Polynomial.C c * x.denom).degree := by
+    rw [hCdeg, Polynomial.degree_eq_natDegree hnum0, Polynomial.degree_eq_natDegree hden0,
+      hndeg]
+  have hlc : x.num.leadingCoeff = (Polynomial.C c * x.denom).leadingCoeff := by
+    rw [Polynomial.leadingCoeff_mul, Polynomial.leadingCoeff_C, hc,
+      div_mul_cancel₀ _ (Polynomial.leadingCoeff_ne_zero.mpr hden0)]
+  have hlt := Polynomial.degree_sub_lt_left hdegeq hnum0 hlc
+  rw [hdegeq, hCdeg] at hlt
+  exact_mod_cast Polynomial.natDegree_lt_natDegree hnz hlt
+
+end DegInfty
+
+section PlaceInfty
+
+variable (K : Type*) [Field K] [DecidableEq (RatFunc K)]
+
+theorem ord_placeInfty_eq_zero_of_intDegree_eq_zero {f : RatFunc K} (hf : f ≠ 0)
+    (h : f.intDegree = 0) : (placeInfty K).ord f = 0 := by
+  rw [(placeInfty K).ord_eq_zero_iff_adicValuation_eq_one hf,
+    ← (inftyValuation_isEquiv_adicValuation K).eq_one_iff_eq_one,
+    RatFunc.inftyValuation_apply, RatFunc.inftyValuation_of_nonzero K hf, h]
+  rfl
+
+end PlaceInfty
+
+end RationalFunctionField
+
+namespace Place
+
+section SupportTransfer
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F'] [Algebra K F'] [Algebra F F']
+  [FiniteDimensional F F']
+
+variable (w : Place K F')
+
+omit [FiniteDimensional F F'] in
+private theorem aeval_mem {Q : Polynomial F} {x : F'}
+    (hcoeff : ∀ i, algebraMap F F' (Q.coeff i) ∈ w.toValuationSubring)
+    (hx : x ∈ w.toValuationSubring) :
+    Polynomial.aeval x Q ∈ w.toValuationSubring := by
+  rw [Polynomial.aeval_def, Polynomial.eval₂_eq_sum_range]
+  exact sum_mem fun i _ => mul_mem (hcoeff i) (pow_mem hx i)
+
+theorem exists_coeff_ord_ne_zero {f : F'} (hf : f ≠ 0) (hford : w.ord f ≠ 0) :
+    ∃ i < (minpoly F f).natDegree, (minpoly F f).coeff i ≠ 0 ∧
+      w.ord (algebraMap F F' ((minpoly F f).coeff i)) ≠ 0 := by
+  by_contra hcon
+  push Not at hcon
+  set P := minpoly F f with hPdef
+  have hint : _root_.IsIntegral F f := Algebra.IsIntegral.isIntegral f
+  have hmonic : P.Monic := minpoly.monic hint
+  have hdeg : 0 < P.natDegree := minpoly.natDegree_pos hint
+  have hc0 : P.coeff 0 ≠ 0 := minpoly.coeff_zero_ne_zero hint hf
+  have hcoeff : ∀ i, algebraMap F F' (P.coeff i) ∈ w.toValuationSubring := by
+    intro i
+    rcases lt_trichotomy i P.natDegree with hi | hi | hi
+    · rcases eq_or_ne (P.coeff i) 0 with h0 | h0
+      · simp [h0]
+      · exact w.mem_of_ord_nonneg (by simpa using h0) (by have := hcon i hi h0; omega)
+    · subst hi
+      simp [hmonic.coeff_natDegree]
+    · simp [Polynomial.coeff_eq_zero_of_natDegree_lt hi]
+  have hfmem : f ∈ w.toValuationSubring := by
+    refine w.mem_of_eval_monic_eq_zero (P := P.map (algebraMap F F')) (hmonic.map _)
+      (fun i => by simpa using hcoeff i) ?_
+    rw [Polynomial.eval_map, ← Polynomial.aeval_def, hPdef, minpoly.aeval]
+  have hfpos : 0 < w.ord f := lt_of_le_of_ne (w.ord_nonneg_of_mem hfmem) (Ne.symm hford)
+  have hkey : algebraMap F F' (P.coeff 0) = -(f * Polynomial.aeval f P.divX) := by
+    have hsplit : Polynomial.aeval f (Polynomial.X * P.divX + Polynomial.C (P.coeff 0))
+        = (0 : F') := by rw [P.X_mul_divX_add]; exact minpoly.aeval F f
+    rw [map_add, map_mul, Polynomial.aeval_X, Polynomial.aeval_C] at hsplit
+    linear_combination hsplit
+  have hcof_mem : Polynomial.aeval f P.divX ∈ w.toValuationSubring :=
+    w.aeval_mem (fun i => by rw [Polynomial.coeff_divX]; exact hcoeff (i + 1)) hfmem
+  have hcof_ne : Polynomial.aeval f P.divX ≠ 0 := by
+    intro h
+    rw [h, mul_zero, _root_.neg_zero] at hkey
+    exact hc0 (by simpa using hkey)
+  have hpos0 : 0 < w.ord (algebraMap F F' (P.coeff 0)) := by
+    rw [hkey, w.ord_neg, w.ord_mul hf hcof_ne]
+    have := w.ord_nonneg_of_mem hcof_mem
+    omega
+  have := hcon 0 hdeg hc0
+  omega
+
+end SupportTransfer
+
+section Chart
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F]
+variable {R : Type*} [CommRing R] [Algebra R F]
+variable (w : Place K F)
+
+private theorem inv_algebraMap_mem (hw : ∀ r : R, algebraMap R F r ∈ w.toValuationSubring)
+    {s : R} (hs : IsUnit (chartHom w hw s)) :
+    (algebraMap R F s)⁻¹ ∈ w.toValuationSubring := by
+  obtain ⟨u, hu⟩ := hs
+  have hcoe : ((u : w.toValuationSubring) : F) = algebraMap R F s := by rw [hu]; rfl
+  have h1 : (((u⁻¹ : w.toValuationSubringˣ) : w.toValuationSubring) : F)
+      * algebraMap R F s = 1 := by
+    have hmul := congrArg (fun a : w.toValuationSubring => (a : F)) u.inv_mul
+    push_cast at hmul
+    rwa [hcoe] at hmul
+  rw [← eq_inv_of_mul_eq_one_left h1]
+  exact SetLike.coe_mem _
+
+end Chart
+
+end Place
+
+section Assembly
+
+variable {K : Type*} [Field K] {F' : Type*} [Field F'] [Algebra K F']
+  [Algebra (RatFunc K) F'] [IsScalarTower K (RatFunc K) F']
+  [FiniteDimensional (RatFunc K) F'] [Algebra.IsSeparable (RatFunc K) F']
+
+end Assembly
+
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+
+section Carrier
+
+variable {F : Type*} [Field F] [DecidableEq F]
+
+def VeluThmOneOddAt (W : WeierstrassCurve F) (Q : W.toAffine.Point) (n : ℕ) : Prop :=
+  ∀ ⦃r s : F⦄, W.toAffine.Equation r s →
+    (∀ P ∈ W.oddOrderSummingSet Q n, r ≠ P.1) →
+    (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.Equation
+      (W.veluX (W.oddOrderSummingSet Q n) r)
+      (W.veluY (W.oddOrderSummingSet Q n) r s)
+
+end Carrier
+
+end WeierstrassCurve
+
+namespace AlgebraicCurve
+
+theorem le_exp_neg_one_of_lt_one {x : ℤᵐ⁰} (hx : x < 1) : x ≤ exp (-1 : ℤ) := by
+  rcases eq_or_ne x 0 with rfl | hx0
+  · exact zero_le
+  · rw [← exp_log hx0] at hx ⊢
+    rw [show (1 : ℤᵐ⁰) = exp 0 from rfl, exp_lt_exp] at hx
+    rw [exp_le_exp]
+    omega
+
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+end Place
+
+namespace RationalFunctionField
+
+variable {K : Type*} [Field K]
+
+theorem ord_ofHeightOneSpectrum_eq_zero_of_notMem (w : HeightOneSpectrum K[X]) {q : K[X]}
+    (hq : q ≠ 0) (hmem : q ∉ w.asIdeal) :
+    (Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w).ord
+      (algebraMap K[X] (RatFunc K) q) = 0 := by
+  by_contra h
+  exact hmem
+    ((Place.ord_ofHeightOneSpectrum_ne_zero_iff (K := K) (F := RatFunc K) w hq).mp h)
+
+section IrreducibleDivisor
+
+variable [DecidableEq (RatFunc K)]
+
+theorem single_add_single_apply_eq_ord {p : K[X]} (hp : Irreducible p)
+    (v : Place K (RatFunc K)) :
+    (Finsupp.single (finitePlace K hp) (1 : ℤ)
+        + Finsupp.single (placeInfty K) (-(p.natDegree : ℤ))) v
+      = v.ord (algebraMap K[X] (RatFunc K) p) := by
+  have hp0 : p ≠ 0 := hp.ne_zero
+  rw [Finsupp.add_apply]
+  rcases eq_ofHeightOneSpectrum_or_eq_placeInfty v with ⟨w, rfl⟩ | rfl
+  · rw [Finsupp.single_eq_of_ne (Ne.symm (placeInfty_ne_ofHeightOneSpectrum K w)), add_zero]
+    by_cases hcase :
+        Place.ofHeightOneSpectrum (K := K) (F := RatFunc K) w = finitePlace K hp
+    · rw [hcase, Finsupp.single_eq_same]
+      exact (ord_ofHeightOneSpectrum_of_span (heightOneSpectrumOfIrreducible K hp) hp0
+        (heightOneSpectrumOfIrreducible_asIdeal K hp)).symm
+    · rw [Finsupp.single_eq_of_ne hcase]
+      refine (ord_ofHeightOneSpectrum_eq_zero_of_notMem w hp0 fun hmem => hcase ?_).symm
+      have hspan : Ideal.span {p} = w.asIdeal :=
+        (PrincipalIdealRing.isMaximal_of_irreducible hp).eq_of_le w.isPrime.ne_top
+          ((Ideal.span_singleton_le_iff_mem _).mpr hmem)
+      have hwp : w = heightOneSpectrumOfIrreducible K hp :=
+        HeightOneSpectrum.ext
+          (hspan.symm.trans (heightOneSpectrumOfIrreducible_asIdeal K hp).symm)
+      rw [hwp, finitePlace_def]
+  · rw [Finsupp.single_eq_of_ne
+        (show placeInfty K ≠ finitePlace K hp from
+          placeInfty_ne_ofHeightOneSpectrum K (heightOneSpectrumOfIrreducible K hp)),
+      Finsupp.single_eq_same, zero_add]
+    exact (ord_placeInfty_algebraMap (K := K) hp0).symm
+
+theorem degree_single_add_single {p : K[X]} (hp : Irreducible p) :
+    Divisor.degree (Finsupp.single (finitePlace K hp) (1 : ℤ)
+        + Finsupp.single (placeInfty K) (-(p.natDegree : ℤ))) = 0 := by
+  rw [map_add, Divisor.degree_single, Divisor.degree_single, deg_finitePlace, deg_placeInfty]
+  push_cast
+  ring
+
+end IrreducibleDivisor
+
+def principalDivisor {f : RatFunc K} (hf : f ≠ 0) : Divisor K (RatFunc K) :=
+  ⟨(finite_setOf_ord_ne_zero hf).toFinset, fun v => v.ord f, fun v => by
+    simp [Set.Finite.mem_toFinset]⟩
+
+@[scoped simp]
+theorem principalDivisor_apply {f : RatFunc K} (hf : f ≠ 0) (v : Place K (RatFunc K)) :
+    principalDivisor hf v = v.ord f := rfl
+
+theorem degree_principalDivisor {f : RatFunc K} (hf : f ≠ 0) :
+    Divisor.degree (principalDivisor hf) = 0 :=
+  degree_eq_zero_of_forall_eq_ord (principalDivisor hf) fun _ => rfl
+
+scoped instance instHasPrincipalDivisors : HasPrincipalDivisors K (RatFunc K) where
+  exists_divisor _ hf := ⟨principalDivisor hf, fun _ => rfl, degree_principalDivisor hf⟩
+
+end RationalFunctionField
+
+namespace Place
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (v : Place K F)
+
+private theorem ord_algebraMap_s18priv (c : K) : v.ord (algebraMap K F c) = 0 := by
+  rcases eq_or_ne c 0 with rfl | hc
+  · simp
+  have hmem : algebraMap K F c ∈ v.toValuationSubring := v.algebraMap_mem' c
+  have hmem' : (algebraMap K F c)⁻¹ ∈ v.toValuationSubring := by
+    rw [← map_inv₀]
+    exact v.algebraMap_mem' c⁻¹
+  have h1 := v.ord_nonneg_of_mem hmem
+  have h2 := v.ord_nonneg_of_mem hmem'
+  rw [v.ord_inv] at h2
+  omega
+
+section Uniqueness
+
+variable {K F : Type*} [Field K] [Field F] [Algebra K F] (w : Place K F)
+
+theorem eq_ord_of_addHom_of_nonneg_iff (φ : F → ℤ)
+    (hmul : ∀ x y, x ≠ 0 → y ≠ 0 → φ (x * y) = φ x + φ y)
+    (hone : ∃ t, t ≠ 0 ∧ φ t = 1)
+    (hiff : ∀ x, x ≠ 0 → (0 ≤ φ x ↔ x ∈ w.toValuationSubring))
+    {x : F} (hx : x ≠ 0) : φ x = w.ord x := by
+  obtain ⟨t, ht0, ht1⟩ := hone
+  have hφ1 : φ 1 = 0 := by
+    have := hmul 1 1 one_ne_zero one_ne_zero
+    rw [mul_one] at this
+    omega
+  have hinv : ∀ y, y ≠ 0 → φ y⁻¹ = -φ y := by
+    intro y hy
+    have h1 : φ (y * y⁻¹) = φ y + φ y⁻¹ := hmul y y⁻¹ hy (inv_ne_zero hy)
+    rw [mul_inv_cancel₀ hy, hφ1] at h1
+    omega
+  have hpow : ∀ (y : F), y ≠ 0 → ∀ m : ℕ, φ (y ^ m) = m * φ y := by
+    intro y hy m
+    induction m with
+    | zero => simpa using hφ1
+    | succ m ih =>
+      rw [pow_succ, hmul _ _ (pow_ne_zero _ hy) hy, ih]
+      push_cast
+      ring
+  have hzpow : ∀ (y : F) (n : ℤ), y ≠ 0 → φ (y ^ n) = n * φ y := by
+    intro y n hy
+    rcases n with m | m
+    · simpa using hpow y hy m
+    · rw [zpow_negSucc, hinv _ (pow_ne_zero _ hy), hpow y hy, Int.negSucc_eq]
+      push_cast
+      ring
+  have hsign : ∀ y, y ≠ 0 → (0 ≤ φ y ↔ 0 ≤ w.ord y) := by
+    intro y hy
+    rw [hiff y hy, w.mem_iff_ord_nonneg hy]
+  have hzero : ∀ y, y ≠ 0 → (φ y = 0 ↔ w.ord y = 0) := by
+    intro y hy
+    have h1 := hsign y hy
+    have h2 := hsign y⁻¹ (inv_ne_zero hy)
+    rw [hinv y hy, w.ord_inv] at h2
+    omega
+  have htord : 0 < w.ord t := by
+    have h1 := (hsign t ht0).mp (by omega)
+    have h2 := (hzero t ht0).not.mp (by omega)
+    omega
+  have hcancel : ∀ y, y ≠ 0 → w.ord y = φ y * w.ord t := by
+    intro y hy
+    have hyt : y * t ^ (-(φ y)) ≠ 0 := mul_ne_zero hy (zpow_ne_zero _ ht0)
+    have h1 : φ (y * t ^ (-(φ y))) = 0 := by
+      rw [hmul _ _ hy (zpow_ne_zero _ ht0), hzpow t _ ht0, ht1]
+      ring
+    have h2 : w.ord (y * t ^ (-(φ y))) = 0 := (hzero _ hyt).mp h1
+    rw [w.ord_mul hy (zpow_ne_zero _ ht0), w.ord_zpow] at h2
+    linarith
+  obtain ⟨π, hπ⟩ := IsDiscreteValuationRing.exists_irreducible w.toValuationSubring
+  have hπ0 : (π : F) ≠ 0 := by
+    simpa [ne_eq, ZeroMemClass.coe_eq_zero] using hπ.ne_zero
+  have hπcancel := hcancel (π : F) hπ0
+  rw [w.ord_coe_irreducible hπ] at hπcancel
+  have htord1 : w.ord t = 1 := by
+    have hdvd : w.ord t ∣ 1 := ⟨φ (π : F), by linarith⟩
+    have := Int.le_of_dvd one_pos hdvd
+    omega
+  have := hcancel x hx
+  rw [htord1, mul_one] at this
+  exact this.symm
+
+end Uniqueness
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+attribute [local instance 0] valuationSubringAlgebra
+
+section Setup
+
+variable (v : Place K F)
+
+scoped instance (priority := 100) : IsScalarTower v.toValuationSubring F F' :=
+  IsScalarTower.of_algebraMap_eq fun _ => rfl
+
+end Setup
+
+section ValuationDictionary
+
+variable {v : Place K F} {w : Place K F'}
+
+theorem neg_log_valuation_fiberCenter_eq_ord (hw : w.restrict F = v) {x : F'} (hx : x ≠ 0) :
+    -log ((fiberCenter F' v hw).valuation F' x) = w.ord x := by
+  refine eq_ord_of_addHom_of_nonneg_iff w
+    (fun y => -log ((fiberCenter F' v hw).valuation F' y)) ?_ ?_ ?_ hx
+  · intro a b ha hb
+    show -log ((fiberCenter F' v hw).valuation F' (a * b)) =
+      -log ((fiberCenter F' v hw).valuation F' a) +
+        -log ((fiberCenter F' v hw).valuation F' b)
+    rw [map_mul, log_mul ((Valuation.ne_zero_iff _).mpr ha) ((Valuation.ne_zero_iff _).mpr hb)]
+    ring
+  · obtain ⟨t, ht⟩ := (fiberCenter F' v hw).valuation_exists_uniformizer F'
+    refine ⟨t, ?_, ?_⟩
+    · intro h
+      rw [h, _root_.map_zero] at ht
+      exact exp_ne_zero ht.symm
+    · show -log ((fiberCenter F' v hw).valuation F' t) = 1
+      rw [ht, log_exp]
+      ring
+  · intro y hy
+    have hy0 : (fiberCenter F' v hw).valuation F' y ≠ 0 := (Valuation.ne_zero_iff _).mpr hy
+    change 0 ≤ -log ((fiberCenter F' v hw).valuation F' y) ↔ y ∈ w.toValuationSubring
+    have hmem : y ∈ w.toValuationSubring ↔ (fiberCenter F' v hw).valuation F' y ≤ 1 := by
+      rw [toValuationSubring_eq_of_restrict_eq hw,
+        HeightOneSpectrum.valuationSubringAtPrime_eq_valuationSubring]
+      exact Iff.rfl
+    rw [hmem]
+    constructor
+    · intro h
+      calc (fiberCenter F' v hw).valuation F' y
+          = exp (log ((fiberCenter F' v hw).valuation F' y)) := (exp_log hy0).symm
+        _ ≤ exp 0 := by rw [exp_le_exp]; omega
+        _ = 1 := exp_zero
+    · intro h
+      have h1 : exp (log ((fiberCenter F' v hw).valuation F' y)) ≤ exp 0 := by
+        rw [exp_log hy0, exp_zero]
+        exact h
+      rw [exp_le_exp] at h1
+      omega
+
+theorem le_ord_iff_mem_pow_fiberCenter (hw : w.restrict F = v)
+    {c : integralClosureAt F' v} (hc : c ≠ 0) (n : ℕ) :
+    (n : ℤ) ≤ w.ord (algebraMap (integralClosureAt F' v) F' c) ↔
+      c ∈ (fiberCenter F' v hw).asIdeal ^ n := by
+  have hcF : algebraMap (integralClosureAt F' v) F' c ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hc
+  rw [← neg_log_valuation_fiberCenter_eq_ord hw hcF,
+    HeightOneSpectrum.valuation_of_algebraMap,
+    ← HeightOneSpectrum.intValuation_le_pow_iff_mem]
+  have h0 : (fiberCenter F' v hw).intValuation c ≠ 0 :=
+    HeightOneSpectrum.intValuation_ne_zero _ c hc
+  constructor
+  · intro h
+    calc (fiberCenter F' v hw).intValuation c
+        = exp (log ((fiberCenter F' v hw).intValuation c)) := (exp_log h0).symm
+      _ ≤ exp (-(n : ℤ)) := by rw [exp_le_exp]; omega
+  · intro h
+    have h1 : exp (log ((fiberCenter F' v hw).intValuation c)) ≤ exp (-(n : ℤ)) := by
+      rw [exp_log h0]
+      exact h
+    rw [exp_le_exp] at h1
+    omega
+
+end ValuationDictionary
+
+section ResidueDictionary
+
+variable {v : Place K F} {w : Place K F'}
+
+def toValuationSubringOfRestrictEq (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.toValuationSubring :=
+  (algebraMap (integralClosureAt F' v) F').codRestrict
+    w.toValuationSubring.toSubring (forall_mem_of_restrict_eq hw)
+
+def residueOfCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v →+* w.ResidueField :=
+  (IsLocalRing.residue w.toValuationSubring).comp (toValuationSubringOfRestrictEq hw)
+
+omit [FiniteDimensional F F'] in
+theorem residueOfCenter_apply (hw : w.restrict F = v) (c : integralClosureAt F' v) :
+    residueOfCenter hw c = IsLocalRing.residue w.toValuationSubring
+      (toValuationSubringOfRestrictEq hw c) := rfl
+
+theorem ker_residueOfCenter (hw : w.restrict F = v) :
+    RingHom.ker (residueOfCenter hw) = (fiberCenter F' v hw).asIdeal := by
+  ext c
+  rw [RingHom.mem_ker, residueOfCenter_apply, IsLocalRing.residue_eq_zero_iff]
+  exact Iff.rfl
+
+theorem surjective_residueOfCenter (hw : w.restrict F = v) :
+    Function.Surjective (residueOfCenter hw) := by
+  classical
+  intro y
+  obtain ⟨x, rfl⟩ := IsLocalRing.residue_surjective y
+  have hx : (x : F') ∈ HeightOneSpectrum.valuationSubringAtPrime F' (fiberCenter F' v hw) := by
+    rw [← toValuationSubring_eq_of_restrict_eq hw]
+    exact x.2
+  obtain ⟨a, s, hs, hxas⟩ := hx
+  have hsP : s ∉ (fiberCenter F' v hw).asIdeal := hs
+  have hs0 : s ≠ 0 := fun h => hsP (h ▸ (fiberCenter F' v hw).asIdeal.zero_mem)
+  have hsF : algebraMap (integralClosureAt F' v) F' s ≠ 0 := by
+    simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hs0
+  have hsord : w.ord (algebraMap (integralClosureAt F' v) F' s) = 0 := by
+    have h1 : ¬ 0 < w.ord (algebraMap (integralClosureAt F' v) F' s) := by
+      rw [← mem_fiberCenter_iff_ord_pos hw hs0]
+      exact hsP
+    have h2 : 0 ≤ w.ord (algebraMap (integralClosureAt F' v) F' s) :=
+      w.ord_nonneg_of_mem (forall_mem_of_restrict_eq hw s)
+    omega
+  have hmax : (fiberCenter F' v hw).asIdeal.IsMaximal :=
+    (fiberCenter F' v hw).isPrime.isMaximal (fiberCenter F' v hw).ne_bot
+  obtain ⟨t, i, hi, hti⟩ := hmax.exists_inv hsP
+  have hst : s * t - 1 ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : s * t - 1 = -i := by linear_combination hti
+    rw [h1]
+    exact neg_mem hi
+  refine ⟨a * t, ?_⟩
+  rw [residueOfCenter_apply, ← sub_eq_zero, ← map_sub, IsLocalRing.residue_eq_zero_iff]
+  have hcoe : ((toValuationSubringOfRestrictEq hw (a * t) - x : w.toValuationSubring) : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') := rfl
+  rcases eq_or_ne (toValuationSubringOfRestrictEq hw (a * t) - x) 0 with hzero | hne
+  · rw [hzero]
+    exact (IsLocalRing.maximalIdeal w.toValuationSubring).zero_mem
+  have hcoene : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F') ≠ 0 := by
+    intro h
+    exact hne (by rwa [← hcoe, ZeroMemClass.coe_eq_zero] at h)
+  have hfactor : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      = algebraMap (integralClosureAt F' v) F' (a * t * s - a)
+          * (algebraMap (integralClosureAt F' v) F' s)⁻¹ := by
+    rw [hxas, map_sub, map_mul (algebraMap (integralClosureAt F' v) F') (a * t) s,
+      sub_mul, mul_assoc, mul_inv_cancel₀ hsF, mul_one]
+  have hdiffC : a * t * s - a ≠ 0 := by
+    intro h
+    apply hcoene
+    rw [hfactor, h, _root_.map_zero, zero_mul]
+  have hdiffP : a * t * s - a ∈ (fiberCenter F' v hw).asIdeal := by
+    have h1 : a * t * s - a = a * (s * t - 1) := by ring
+    rw [h1]
+    exact Ideal.mul_mem_left _ _ hst
+  have hmem' : algebraMap (integralClosureAt F' v) F' (a * t) - (x : F')
+      ∈ w.toValuationSubring := by
+    rw [← hcoe]
+    exact Subtype.coe_prop _
+  rw [show (toValuationSubringOfRestrictEq hw (a * t) - x)
+      = (⟨_, hmem'⟩ : w.toValuationSubring) from Subtype.ext hcoe,
+    w.mem_maximalIdeal_iff_ord_pos hcoene hmem']
+  rw [hfactor, w.ord_mul (by
+      simpa using (IsFractionRing.injective (integralClosureAt F' v) F').ne_iff.mpr hdiffC)
+    (inv_ne_zero hsF), w.ord_inv, hsord, _root_.neg_zero, add_zero]
+  exact (mem_fiberCenter_iff_ord_pos hw hdiffC).mp hdiffP
+
+def residueFieldEquivQuotientCenter (hw : w.restrict F = v) :
+    integralClosureAt F' v ⧸ (fiberCenter F' v hw).asIdeal ≃+* w.ResidueField :=
+  (Ideal.quotEquivOfEq (ker_residueOfCenter hw).symm).trans
+    ((residueOfCenter hw).quotientKerEquivOfSurjective (surjective_residueOfCenter hw))
+
+def placeCongrEquiv {u u' : Place K F} (h : u = u') :
+    u.toValuationSubring ≃+* u'.toValuationSubring where
+  toFun x := ⟨x.1, h ▸ x.2⟩
+  invFun x := ⟨x.1, h.symm ▸ x.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  map_mul' _ _ := rfl
+  map_add' _ _ := rfl
+
+def restrictResidueFieldEquiv (hw : w.restrict F = v) :
+    (w.restrict F).ResidueField ≃+* IsLocalRing.ResidueField v.toValuationSubring :=
+  IsLocalRing.ResidueField.mapEquiv (placeCongrEquiv hw)
+
+end ResidueDictionary
+
+end Place
+
+section Identity
+
+variable (K F F' : Type*) [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [Algebra.IsIntegral F F']
+
+def RamificationInertiaIdentity : Prop :=
+  ∀ (v : Place K F) (s : Finset (Place K F')), (∀ w : Place K F', w ∈ s ↔ w.restrict F = v) →
+    ∑ w ∈ s, (w.ramificationIndex F : ℤ) * (w.deg : ℤ)
+      = (Module.finrank F F' : ℤ) * (v.deg : ℤ)
+
+end Identity
+
+namespace Divisor
+
+section Pullback
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [Algebra.IsIntegral F F']
+
+theorem degree_eq_finrank_mul_of_forall_eq_ord_algebraMap
+    (H : RamificationInertiaIdentity K F F') {g : F}
+    {D' : Divisor K F'} (hD' : ∀ w : Place K F', D' w = w.ord (algebraMap F F' g))
+    {D : Divisor K F} (hD : ∀ v : Place K F, D v = v.ord g) :
+    degree D' = (Module.finrank F F' : ℤ) * degree D := by
+  classical
+  have hmaps : ∀ w ∈ D'.support, w.restrict F ∈ D.support := by
+    intro w hw
+    rw [Finsupp.mem_support_iff] at hw ⊢
+    intro h0
+    apply hw
+    rw [hD' w, w.ord_restrict g, hD] at *
+    rw [h0, mul_zero]
+  have happ : ∀ w : Place K F', D' w = (w.ramificationIndex F : ℤ) * D (w.restrict F) := by
+    intro w
+    rw [hD' w, w.ord_restrict g, hD]
+  rw [degree_eq_sum_support, degree_eq_sum_support,
+    ← Finset.sum_fiberwise_of_maps_to hmaps fun w => D' w * (w.deg : ℤ), Finset.mul_sum]
+  refine Finset.sum_congr rfl fun v hv => ?_
+  have hfiber : ∀ w : Place K F',
+      w ∈ D'.support.filter (fun w => w.restrict F = v) ↔ w.restrict F = v := by
+    intro w
+    simp only [Finset.mem_filter, Finsupp.mem_support_iff, and_iff_right_iff_imp]
+    intro hw
+    rw [happ w, hw]
+    have he : 0 < w.ramificationIndex F := w.ramificationIndex_pos
+    have hv0 : D v ≠ 0 := Finsupp.mem_support_iff.mp hv
+    exact mul_ne_zero (by exact_mod_cast he.ne') hv0
+  calc
+    ∑ w ∈ D'.support with w.restrict F = v, D' w * (w.deg : ℤ)
+        = D v * ∑ w ∈ D'.support.filter (fun w => w.restrict F = v),
+            (w.ramificationIndex F : ℤ) * (w.deg : ℤ) := by
+          rw [Finset.mul_sum]
+          refine Finset.sum_congr rfl fun w hw => ?_
+          rw [happ w, ((hfiber w).mp hw)]
+          ring
+    _ = D v * ((Module.finrank F F' : ℤ) * (v.deg : ℤ)) := by
+          rw [H v _ hfiber]
+    _ = (Module.finrank F F' : ℤ) * (D v * (v.deg : ℤ)) := by ring
+
+end Pullback
+
+section Galois
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+
+theorem _root_.AlgebraicCurve.Place.ord_prod {ι : Type*} (v : Place K F') (s : Finset ι)
+    (g : ι → F') (hg : ∀ i ∈ s, g i ≠ 0) :
+    v.ord (∏ i ∈ s, g i) = ∑ i ∈ s, v.ord (g i) := by
+  classical
+  induction s using Finset.cons_induction with
+  | empty => simp
+  | cons i s hi ih =>
+    rw [Finset.prod_cons, Finset.sum_cons,
+      v.ord_mul (hg i (Finset.mem_cons_self i s))
+        (Finset.prod_ne_zero_iff.mpr fun j hj => hg j (Finset.mem_cons_of_mem hj)),
+      ih fun j hj => hg j (Finset.mem_cons_of_mem hj)]
+
+variable [FiniteDimensional F F']
+
+theorem sum_smul_apply_eq_ord_prod {f : F'} (hf : f ≠ 0)
+    {D : Divisor K F'} (hD : ∀ w : Place K F', D w = w.ord f) (w : Place K F') :
+    (∑ σ : F' ≃ₐ[F] F', (AlgEquiv.restrictScalars K σ) • D) w
+      = w.ord (∏ σ : F' ≃ₐ[F] F', σ f) := by
+  classical
+  rw [w.ord_prod _ _ fun σ _ => by simpa using hf, Finset.sum_apply']
+  refine Finset.sum_congr rfl fun σ _ => ?_
+  rw [smul_apply, hD]
+  have h := Place.ord_smul (AlgEquiv.restrictScalars K σ)
+    ((AlgEquiv.restrictScalars K σ)⁻¹ • w) f
+  rw [smul_inv_smul] at h
+  exact h.symm
+
+theorem degree_eq_zero_of_isGalois [IsGalois F F'] [HasPrincipalDivisors K F]
+    (H : RamificationInertiaIdentity K F F')
+    {f : F'} {D : Divisor K F'} (hD : ∀ w : Place K F', D w = w.ord f) :
+    degree D = 0 := by
+  classical
+  rcases eq_or_ne f 0 with rfl | hf
+  · have : D = 0 := Finsupp.ext fun w => by simpa using hD w
+    rw [this, _root_.map_zero]
+  set E : Divisor K F' := ∑ σ : F' ≃ₐ[F] F', (AlgEquiv.restrictScalars K σ) • D with hE
+  have hEord : ∀ w : Place K F', E w = w.ord (algebraMap F F' (Algebra.norm F f)) := by
+    intro w
+    rw [hE, sum_smul_apply_eq_ord_prod hf hD w, Algebra.norm_eq_prod_automorphisms F f]
+  have hnorm : Algebra.norm F f ≠ 0 := (Algebra.norm_ne_zero_iff (R := F)).mpr hf
+  obtain ⟨D₀, hD₀, hD₀deg⟩ := HasPrincipalDivisors.exists_divisor (K := K)
+    (Algebra.norm F f) hnorm
+  have hEdeg : degree E = 0 := by
+    rw [degree_eq_finrank_mul_of_forall_eq_ord_algebraMap H hEord hD₀, hD₀deg, mul_zero]
+  have hEdeg' : degree E = (Module.finrank F F' : ℤ) * degree D := by
+    rw [hE, map_sum]
+    simp only [degree_smul]
+    rw [Finset.sum_const, Finset.card_univ, nsmul_eq_mul]
+    congr 1
+    exact_mod_cast (Nat.card_eq_fintype_card (α := F' ≃ₐ[F] F')).symm.trans
+      (IsGalois.card_aut_eq_finrank F F')
+  have hpos : (0 : ℤ) < (Module.finrank F F' : ℤ) := by
+    exact_mod_cast Module.finrank_pos (R := F) (M := F')
+  rw [hEdeg] at hEdeg'
+  exact (mul_eq_zero.mp hEdeg'.symm).resolve_left hpos.ne'
+
+end Galois
+
+end Divisor
+
+namespace RationalFunctionField
+
+variable {K : Type*} [Field K] {F' : Type*} [Field F'] [Algebra K F']
+  [Algebra (RatFunc K) F'] [IsScalarTower K (RatFunc K) F']
+  [FiniteDimensional (RatFunc K) F'] [Algebra.IsSeparable (RatFunc K) F']
+
+def principalDivisorOf {f : F'} (hf : f ≠ 0) : Divisor K F' :=
+  ⟨(finite_setOf_ord_ne_zero_of_finiteDimensional hf).toFinset, fun w => w.ord f, fun w => by
+    simp [Set.Finite.mem_toFinset]⟩
+
+theorem degree_eq_zero_of_forall_eq_ord_of_isGalois [IsGalois (RatFunc K) F']
+    (H : RamificationInertiaIdentity K (RatFunc K) F')
+    {f : F'} {D : Divisor K F'} (hD : ∀ w : Place K F', D w = w.ord f) :
+    Divisor.degree D = 0 :=
+  Divisor.degree_eq_zero_of_isGalois H hD
+
+theorem hasPrincipalDivisors_of_isGalois [IsGalois (RatFunc K) F']
+    (H : RamificationInertiaIdentity K (RatFunc K) F') :
+    HasPrincipalDivisors K F' where
+  exists_divisor _ hf :=
+    ⟨principalDivisorOf hf, fun _ => rfl,
+      degree_eq_zero_of_forall_eq_ord_of_isGalois H fun _ => rfl⟩
+
+end RationalFunctionField
+
+end AlgebraicCurve
+
+namespace WeierstrassCurve
+
+namespace Affine
+
+open CoordinateRing
+
+variable {F : Type*} [Field F] {W : Affine F}
+
+theorem weierstrassQuadratic_natDegree_le : (weierstrassQuadratic W).natDegree ≤ 2 := by
+  rw [Polynomial.natDegree_le_iff_degree_le]
+  refine le_trans (Polynomial.degree_add_le _ _) (max_le ?_ ?_)
+  · exact (Polynomial.degree_X_pow 2).le
+  · exact le_of_lt weierstrassQuadratic_sub_degree_lt
+
+scoped instance : FiniteDimensional (RatFunc F) W.FunctionField := by
+  have h1 : FiniteDimensional (RatFunc F)
+      (IntermediateField.adjoin (RatFunc F) {yCoord W}) :=
+    IntermediateField.adjoin.finiteDimensional isIntegral_yCoord
+  rw [adjoin_yCoord_eq_top] at h1
+  exact (IntermediateField.topEquiv
+    (F := RatFunc F) (E := W.FunctionField)).toLinearEquiv.finiteDimensional
+
+theorem splits_weierstrassQuadratic_map :
+    ((weierstrassQuadratic W).map
+      (algebraMap (RatFunc F) W.FunctionField)).Splits := by
+  have hroot : ((weierstrassQuadratic W).map
+      (algebraMap (RatFunc F) W.FunctionField)).IsRoot (yCoord W) := by
+    change ((weierstrassQuadratic W).map
+      (algebraMap (RatFunc F) W.FunctionField)).eval (yCoord W) = 0
+    rw [Polynomial.eval_map, ← Polynomial.aeval_def]
+    exact aeval_yCoord_weierstrassQuadratic
+  have hkey : (X - C (yCoord W))
+        * (((weierstrassQuadratic W).map (algebraMap (RatFunc F) W.FunctionField))
+          /ₘ (X - C (yCoord W)))
+      = (weierstrassQuadratic W).map (algebraMap (RatFunc F) W.FunctionField) :=
+    mul_divByMonic_eq_iff_isRoot.mpr hroot
+  rw [← hkey, splits_X_sub_C_mul_iff]
+  refine Polynomial.Splits.of_natDegree_le_one ?_
+  rw [natDegree_divByMonic _ (monic_X_sub_C (yCoord W))]
+  have h1 : ((weierstrassQuadratic W).map
+      (algebraMap (RatFunc F) W.FunctionField)).natDegree ≤ 2 :=
+    le_trans Polynomial.natDegree_map_le weierstrassQuadratic_natDegree_le
+  have h2 : (X - C (yCoord W)).natDegree = 1 := Polynomial.natDegree_X_sub_C _
+  omega
+
+theorem isSplittingField_weierstrassQuadratic :
+    Polynomial.IsSplittingField (RatFunc F) W.FunctionField (weierstrassQuadratic W) := by
+  constructor
+  · exact splits_weierstrassQuadratic_map
+  · rw [eq_top_iff, ← IntermediateField.top_toSubalgebra, ← adjoin_yCoord_eq_top,
+      IntermediateField.adjoin_simple_toSubalgebra_of_isAlgebraic
+        isIntegral_yCoord.isAlgebraic]
+    refine Algebra.adjoin_mono ?_
+    rw [Set.singleton_subset_iff, Polynomial.mem_rootSet]
+    exact ⟨weierstrassQuadratic_monic.ne_zero, aeval_yCoord_weierstrassQuadratic⟩
+
+end Affine
+
+end WeierstrassCurve
+
+namespace AlgebraicCurve
+
+namespace Place
+
+attribute [local instance 0] valuationSubringAlgebra
+
+variable {K F F' : Type*} [Field K] [Field F] [Field F']
+  [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+  [FiniteDimensional F F'] [Algebra.IsSeparable F F']
+
+theorem sum_ramificationIndex_mul_inertiaDeg_of_forall_mem_iff
+    (v : Place K F) (s : Finset (Place K F'))
+    (hs : ∀ w : Place K F', w ∈ s ↔ w.restrict F = v) :
+    ∑ w ∈ s, (w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ)
+      = (Module.finrank F F' : ℤ) := by
+  classical
+  let _ : Module.IsTorsionFree v.toValuationSubring F' :=
+    Module.IsTorsionFree.trans_faithfulSMul v.toValuationSubring F F'
+  have hkey :
+      ∑ P ∈ IsDedekindDomain.primesOverFinset
+          (IsLocalRing.maximalIdeal v.toValuationSubring) (integralClosureAt F' v),
+        Ideal.ramificationIdx' (IsLocalRing.maximalIdeal v.toValuationSubring) P *
+          Ideal.inertiaDeg P v.toValuationSubring =
+            Module.finrank F F' := by
+    let p := IsLocalRing.maximalIdeal v.toValuationSubring
+    let S := integralClosureAt F' v
+    let e : {P // P ∈ IsDedekindDomain.primesOverFinset p S} ≃ p.primesOver S :=
+      Set.equivOfEq (IsDedekindDomain.coe_primesOverFinset (maximalIdeal_ne_bot v) S)
+    change (∑ P ∈ IsDedekindDomain.primesOverFinset p S,
+      p.ramificationIdx' P * P.inertiaDeg v.toValuationSubring) = Module.finrank F F'
+    calc
+      _ = ∑ P : {P // P ∈ IsDedekindDomain.primesOverFinset p S},
+          p.ramificationIdx' P.1 * P.1.inertiaDeg v.toValuationSubring := by
+            rw [← Finset.sum_attach, Finset.univ_eq_attach]
+      _ = ∑ P : p.primesOver S,
+          P.1.ramificationIdx v.toValuationSubring *
+            P.1.inertiaDeg v.toValuationSubring := by
+            apply Fintype.sum_equiv e
+            intro P
+            have hmem : P.1 ∈ p.primesOver S := (e P).2
+            let : P.1.IsPrime := hmem.1
+            let : P.1.LiesOver p := hmem.2
+            let : P.1.IsMaximal :=
+              (inferInstance : P.1.IsPrime).isMaximal
+                (Ideal.ne_bot_of_mem_primesOver (maximalIdeal_ne_bot v) hmem)
+            change p.ramificationIdx' P.1 * P.1.inertiaDeg v.toValuationSubring =
+              P.1.ramificationIdx v.toValuationSubring *
+                P.1.inertiaDeg v.toValuationSubring
+            rw [Ideal.ramificationIdx'_eq_ramificationIdx p P.1
+              (maximalIdeal_ne_bot v)]
+      _ = Module.finrank v.toValuationSubring S :=
+        Ideal.sum_ramification_inertia_eq_finrank p S
+      _ = Module.finrank F F' :=
+        IsIntegralClosure.rank v.toValuationSubring F F' S
+  rw [← hkey]
+  push_cast
+  refine Finset.sum_bij
+    (fun w hw => (fiberCenter F' v ((hs w).mp hw)).asIdeal) ?_ ?_ ?_ ?_
+  · intro w hw
+    rw [IsDedekindDomain.mem_primesOverFinset_iff (maximalIdeal_ne_bot v)]
+    exact ⟨(fiberCenter F' v ((hs w).mp hw)).isPrime,
+      fiberCenter_liesOver ((hs w).mp hw)⟩
+  · intro w hw w' hw' h
+    exact eq_of_fiberCenter_eq ((hs w).mp hw) ((hs w').mp hw')
+      (HeightOneSpectrum.ext h)
+  · intro P hP
+    rw [IsDedekindDomain.mem_primesOverFinset_iff (maximalIdeal_ne_bot v)] at hP
+    obtain ⟨hP1, hP2⟩ := hP
+    have hPne : P ≠ ⊥ := by
+      intro h
+      apply maximalIdeal_ne_bot v
+      have h2 := hP2.over
+      rw [h, Ideal.under_def, Ideal.comap_bot_of_injective _
+        (algebraMap_integralClosureAt_injective v)] at h2
+      exact h2
+    refine ⟨placeOfPrime ⟨P, hP1, hPne⟩,
+      (hs _).mpr (restrict_placeOfPrime ⟨P, hP1, hPne⟩), ?_⟩
+    exact congrArg HeightOneSpectrum.asIdeal
+      (fiberCenter_placeOfPrime (⟨P, hP1, hPne⟩ :
+        HeightOneSpectrum (integralClosureAt F' v)))
+  · intro w hw
+    rw [ramificationIndex_eq_ramificationIdx_fiberCenter v ((hs w).mp hw),
+      inertiaDeg_eq_inertiaDeg_fiberCenter ((hs w).mp hw)]
+
+theorem sum_ramificationIndex_mul_deg_of_forall_mem_iff
+    (v : Place K F) (s : Finset (Place K F'))
+    (hs : ∀ w : Place K F', w ∈ s ↔ w.restrict F = v) :
+    ∑ w ∈ s, (w.ramificationIndex F : ℤ) * (w.deg : ℤ)
+      = (Module.finrank F F' : ℤ) * (v.deg : ℤ) := by
+  have hsum := sum_ramificationIndex_mul_inertiaDeg_of_forall_mem_iff v s hs
+  calc ∑ w ∈ s, (w.ramificationIndex F : ℤ) * (w.deg : ℤ)
+      = ∑ w ∈ s, (v.deg : ℤ) * ((w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ)) := by
+        refine Finset.sum_congr rfl fun w hw => ?_
+        have hdeg : (w.restrict F).deg * w.inertiaDeg F = w.deg :=
+          deg_restrict_mul_inertiaDeg (K := K) (F := F) (w := w)
+        rw [(hs w).mp hw] at hdeg
+        rw [← hdeg]
+        push_cast
+        ring
+    _ = (v.deg : ℤ) * ∑ w ∈ s, (w.ramificationIndex F : ℤ) * (w.inertiaDeg F : ℤ) := by
+        rw [Finset.mul_sum]
+    _ = (Module.finrank F F' : ℤ) * (v.deg : ℤ) := by rw [hsum]; ring
+
+end Place
+
+theorem ramificationInertiaIdentity_of_finiteDimensional
+    (K F F' : Type*) [Field K] [Field F] [Field F']
+    [Algebra K F] [Algebra K F'] [Algebra F F'] [IsScalarTower K F F']
+    [FiniteDimensional F F'] [Algebra.IsSeparable F F'] :
+    RamificationInertiaIdentity K F F' := fun v s hs =>
+  Place.sum_ramificationIndex_mul_deg_of_forall_mem_iff v s hs
+
+namespace RationalFunctionField
+
+variable {K : Type*} [Field K] {F' : Type*} [Field F'] [Algebra K F']
+  [Algebra (RatFunc K) F'] [IsScalarTower K (RatFunc K) F']
+  [FiniteDimensional (RatFunc K) F'] [Algebra.IsSeparable (RatFunc K) F']
+
+scoped instance (priority := 50) instHasPrincipalDivisorsOfIsGalois [IsGalois (RatFunc K) F'] :
+    HasPrincipalDivisors K F' :=
+  hasPrincipalDivisors_of_isGalois
+    (ramificationInertiaIdentity_of_finiteDimensional K (RatFunc K) F')
+
+end RationalFunctionField
+
+end AlgebraicCurve
+
+open AlgebraicCurve
+
+namespace Polynomial
+variable {K : Type*} [Field K]
+
+theorem separable_X_sq_add_C_mul_X_sub_C {b c : K} (h : b ^ 2 + 4 * c ≠ 0) :
+    (X ^ 2 + (C b * X - C c) : K[X]).Separable := by
+  rw [Polynomial.separable_def']
+  refine ⟨C (-(4 * (b ^ 2 + 4 * c)⁻¹)),
+    C ((b ^ 2 + 4 * c)⁻¹) * (C 2 * X + C b), ?_⟩
+  have hd : derivative (X ^ 2 + (C b * X - C c) : K[X]) = C 2 * X + C b := by
+    simp only [derivative_add, derivative_sub, derivative_mul, derivative_X_pow,
+      derivative_C, derivative_X, mul_one, zero_mul, sub_zero]
+    ring_nf
+  rw [hd]
+  have hkey : C (-(4 * (b ^ 2 + 4 * c)⁻¹)) * (X ^ 2 + (C b * X - C c))
+        + C ((b ^ 2 + 4 * c)⁻¹) * (C 2 * X + C b) * (C 2 * X + C b)
+      = C ((b ^ 2 + 4 * c)⁻¹ * (b ^ 2 + 4 * c)) := by
+    simp only [_root_.map_neg, map_mul, map_add, map_pow, map_ofNat]
+    ring
+  rw [hkey, inv_mul_cancel₀ h, map_one]
+
+end Polynomial
+
+namespace WeierstrassCurve
+
+namespace Affine
+
+open WeierstrassCurve.Affine WeierstrassCurve
+
+variable {F : Type*} [Field F] (W : WeierstrassCurve.Affine F)
+
+def wqDiscPoly : F[X] :=
+  (C W.a₁ * X + C W.a₃) ^ 2 + C 4 * (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆)
+
+variable {W}
+
+theorem weierstrassQuadratic_separable (h : wqDiscPoly W ≠ 0) :
+    (weierstrassQuadratic W).Separable := by
+  have hinj : Function.Injective (algebraMap F[X] (RatFunc F)) :=
+    IsFractionRing.injective F[X] (RatFunc F)
+  have hC4 : (4 : RatFunc F) = algebraMap F[X] (RatFunc F) (C 4) := by
+    rw [map_ofNat, map_ofNat]
+  have h2 : (algebraMap F[X] (RatFunc F) (C W.a₁ * X + C W.a₃)) ^ 2
+        + 4 * (algebraMap F[X] (RatFunc F) (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆))
+      ≠ 0 := by
+    rw [hC4, ← map_mul, ← map_pow, ← map_add]
+    exact fun hcon => h (hinj (hcon.trans (_root_.map_zero _).symm))
+  rw [show weierstrassQuadratic W
+      = X ^ 2 + (C (algebraMap F[X] (RatFunc F) (C W.a₁ * X + C W.a₃)) * X
+        - C (algebraMap F[X] (RatFunc F) (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆))) from
+    rfl]
+  exact separable_X_sq_add_C_mul_X_sub_C h2
+
+theorem isGalois_functionField_of_wqDiscPoly_ne_zero (h : wqDiscPoly W ≠ 0) :
+    IsGalois (RatFunc F) W.FunctionField :=
+  haveI : (weierstrassQuadratic W).IsSplittingField (RatFunc F) W.FunctionField :=
+    isSplittingField_weierstrassQuadratic
+  IsGalois.of_separable_splitting_field (weierstrassQuadratic_separable h)
+
+theorem hasPrincipalDivisors_functionField_of_wqDiscPoly_ne_zero (h : wqDiscPoly W ≠ 0) :
+    HasPrincipalDivisors F W.FunctionField :=
+  haveI := isGalois_functionField_of_wqDiscPoly_ne_zero h
+  RationalFunctionField.instHasPrincipalDivisorsOfIsGalois
+
+private theorem natDegree_wqLinear_sq_le :
+    ((C W.a₁ * X + C W.a₃ : F[X]) ^ 2).natDegree ≤ 2 := by
+  refine le_trans natDegree_pow_le ?_
+  have : (C W.a₁ * X + C W.a₃ : F[X]).natDegree ≤ 1 := by
+    refine le_trans (natDegree_add_le _ _) ?_
+    simp only [natDegree_C, max_le_iff]
+    exact ⟨le_trans (natDegree_C_mul_le _ _) (by simp), by omega⟩
+  omega
+
+private theorem natDegree_wqCubic :
+    (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ : F[X]).natDegree = 3 := by
+  rw [show (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ : F[X])
+      = C 1 * X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆ from by rw [map_one, one_mul]]
+  exact natDegree_cubic one_ne_zero
+
+theorem wqDiscPoly_ne_zero (h : (2 : F) ≠ 0 ∨ W.a₁ ≠ 0 ∨ W.a₃ ≠ 0) :
+    wqDiscPoly W ≠ 0 := by
+  by_cases h2 : (2 : F) = 0
+  · have hC4 : (C (4 : F) : F[X]) = 0 := by
+      rw [show (4 : F) = 2 * 2 from by norm_num, h2, mul_zero, _root_.map_zero]
+    have heq : wqDiscPoly W = (C W.a₁ * X + C W.a₃) ^ 2 := by
+      simp only [wqDiscPoly, hC4, zero_mul, add_zero]
+    rw [heq]
+    refine pow_ne_zero 2 ?_
+    have ha : W.a₁ ≠ 0 ∨ W.a₃ ≠ 0 := h.resolve_left (· h2)
+    intro hcon
+    rcases ha with ha | ha
+    · have h1 := congrArg (·.coeff 1) hcon
+      simp only [coeff_add, coeff_C_mul, coeff_X_one, mul_one, coeff_C,
+        ite_eq_right one_ne_zero, add_zero, coeff_zero] at h1
+      exact ha h1
+    · have h0 := congrArg (·.coeff 0) hcon
+      simp only [coeff_add, coeff_C_mul, coeff_X_zero, mul_zero, zero_add,
+        coeff_C_zero, coeff_zero] at h0
+      exact ha h0
+  · have h4 : (4 : F) ≠ 0 := by
+      rw [show (4 : F) = 2 * 2 from by norm_num]; exact mul_ne_zero h2 h2
+    intro hcon
+    have hdeg : (wqDiscPoly W).natDegree = 3 := by
+      rw [show wqDiscPoly W = C (4 : F) * (X ^ 3 + C W.a₂ * X ^ 2 + C W.a₄ * X + C W.a₆)
+            + (C W.a₁ * X + C W.a₃) ^ 2 from by simp only [wqDiscPoly]; ring,
+        natDegree_add_eq_left_of_natDegree_lt
+          (by rw [natDegree_C_mul h4, natDegree_wqCubic];
+              exact lt_of_le_of_lt natDegree_wqLinear_sq_le (by omega)),
+        natDegree_C_mul h4, natDegree_wqCubic]
+    rw [hcon, natDegree_zero] at hdeg
+    omega
+
+end Affine
+
+end WeierstrassCurve
+
+section
+
+open AlgebraicCurve WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+
+namespace WeierstrassCurve
+
+section HPD
+
+variable {F : Type*} [Field F]
+
+theorem kw_veluHPDSupplier_of_two_ne_zero (h2 : (2 : F) ≠ 0) :
+    ∀ (W : WeierstrassCurve F), W.Δ ≠ 0 →
+      HasPrincipalDivisors F W.toAffine.FunctionField :=
+  fun _W _hΔ => Affine.hasPrincipalDivisors_functionField_of_wqDiscPoly_ne_zero
+    (Affine.wqDiscPoly_ne_zero (Or.inl h2))
+
+end HPD
+
+end WeierstrassCurve
+
+end
+
+namespace WeierstrassCurve
+
+section CharAgnosticOdd
+
+variable {F : Type*} [Field F] [DecidableEq F] [IsAlgClosed F]
+
+variable (F) in
+theorem kw_no6_hroute_veluDeficitIsConstantAt_odd_of_two_ne_zero (h2 : (2 : F) ≠ 0)
+    {p : ℕ} (hp3 : 3 ≤ p) (hpodd : Odd p) :
+    VeluDeficitIsConstantAt F p :=
+  veluDeficitIsConstantAt_of_ordNonneg_of_dedekind
+    (kw_veluHPDSupplier_of_two_ne_zero h2) kw_hDDTerm
+    (kw_veluDeficitFunOrdNonnegAt_odd F kw_hDDTerm hp3 hpodd)
+
+variable (F) in
+theorem kw_no6_hroute_veluDeficitConstancyAt_odd_of_two_ne_zero (h2 : (2 : F) ≠ 0)
+    {p : ℕ} (hp3 : 3 ≤ p) (hpodd : Odd p) :
+    VeluDeficitConstancyAt F p := by
+  have : Infinite F := kw_infinite_of_isAlgClosed
+  refine veluDeficitConstancyAt_of_isConstant_of_constantZero F
+    (kw_no6_hroute_veluDeficitIsConstantAt_odd_of_two_ne_zero F h2 hp3 hpodd)
+    (kw_veluDeficitConstantIsZeroAt_odd hp3 hpodd ?_)
+  exact kw_veluDeficitCrossQuadProdDegLtAt_odd hp3 hpodd
+    (kw_veluDeficitCrossQuadCubeBetaDegLtAt_odd hp3 hpodd
+      (kw_veluDeficitCrossQuadBetaOnlyDegLtAt_odd
+        (veluDeficitCrossQuadBetaSDecompDegLtAt_of_betaSq_of_alphaBeta
+          (kw_veluDeficitCrossQuadBetaSqDecompDegLtAt_odd hp3 hpodd)
+          (kw_veluDeficitCrossQuadAlphaBetaDecompDegLtAt_odd hp3 hpodd))))
+
+variable {W : WeierstrassCurve F} {Q : W.toAffine.Point} {p : ℕ}
+
+theorem kw_no6_hroute_veluThmOneOddAt_odd_of_two_ne_zero (h2 : (2 : F) ≠ 0)
+    (hΔ : W.Δ ≠ 0) (hp3 : 3 ≤ p) (hpodd : Odd p) (hord : addOrderOf Q = p) :
+    VeluThmOneOddAt W Q ((p - 1) / 2) := by
+  have hQ0 : Q ≠ 0 := by intro h; rw [h, addOrderOf_zero] at hord; omega
+  obtain ⟨x₀, y₀, h₀, rfl, -⟩ := exists_some_of_ne_zero hQ0
+  intro r s hrs hav
+  exact (W.veluQuotient_equation_iff_veluDeficit_eq_zero _ r s).mpr
+    (kw_no6_hroute_veluDeficitConstancyAt_odd_of_two_ne_zero F h2 hp3 hpodd
+      W hΔ x₀ y₀ h₀ hord hrs hav)
+
+end CharAgnosticOdd
+
+end WeierstrassCurve
+
+theorem solution
+    {L : Type*} [Field L] [DecidableEq L] [IsAlgClosed L] (h2 : (2 : L) ≠ 0)
+    (W : WeierstrassCurve L) [W.IsElliptic] (n : ℕ) (Q : W.toAffine.Point)
+    (hQ : addOrderOf Q = 2 * n + 1) {x y : L} (hxy : W.toAffine.Equation x y)
+    (hx : ∀ A ∈ W.oddOrderSummingSet Q n, x ≠ A.1) :
+    (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.Equation
+      (W.veluX (W.oddOrderSummingSet Q n) x) (W.veluY (W.oddOrderSummingSet Q n) x y) := by
+  rcases Nat.eq_zero_or_pos n with rfl | hn
+  · have h0 : W.oddOrderSummingSet Q 0 = ∅ := by simp [WeierstrassCurve.oddOrderSummingSet]
+    rw [h0, WeierstrassCurve.veluQuotient_empty, WeierstrassCurve.veluX_empty,
+      WeierstrassCurve.veluY_empty]
+    exact hxy
+  · have hp3 : 3 ≤ 2 * n + 1 := by omega
+    have hpodd : Odd (2 * n + 1) := ⟨n, rfl⟩
+    have hn_eq : ((2 * n + 1) - 1) / 2 = n := by omega
+    have key := WeierstrassCurve.kw_no6_hroute_veluThmOneOddAt_odd_of_two_ne_zero
+      (W := W) (Q := Q) h2 W.Δ'.ne_zero hp3 hpodd hQ
+    rw [hn_eq] at key
+    exact key hxy hx
+
+end privateSection
+
+public section publicSection
+
+open WeierstrassCurve
+
+theorem WeierstrassCurve.velu_map_equation_of_oddOrderSummingSet
+    {L : Type*} [Field L] [DecidableEq L] [IsAlgClosed L] (h2 : (2 : L) ≠ 0)
+    (W : WeierstrassCurve L) [W.IsElliptic] (n : ℕ) (Q : W.toAffine.Point)
+    (hQ : addOrderOf Q = 2 * n + 1) {x y : L} (hxy : W.toAffine.Equation x y)
+    (hx : ∀ A ∈ W.oddOrderSummingSet Q n, x ≠ A.1) :
+    (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.Equation
+      (W.veluX (W.oddOrderSummingSet Q n) x) (W.veluY (W.oddOrderSummingSet Q n) x y) :=
+  solution h2 W n Q hQ hxy hx
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_zmultiples_eq_of_veluQuotient_j_eq_of_forall_isogenyEndDatum_exists_int.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_zmultiples_eq_of_veluQuotient_j_eq_of_forall_isogenyEndDatum_exists_int.lean
new file mode 100644
index 0000000000..9d22354c3c
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_zmultiples_eq_of_veluQuotient_j_eq_of_forall_isogenyEndDatum_exists_int.lean
@@ -0,0 +1,626 @@
+/-
+Based on Prove2Me node
+WeierstrassCurve.zmultiples_eq_of_veluQuotient_j_eq_of_forall_isogenyEndDatum_exists_int
+(012791e6-9417-5e9d-b060-7ab6c0060cd8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4d7ded92-6949-5c83-832a-9fae9dc5d7cf
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.RingTheory.HahnSeries.Summable
+public import LeanPool.FLTEichlerShimura.Definitions.Def_Isogeny_ConditionalCurrency
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_GenusOnePlaceGateCentred
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_OddOrderSummingSet
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_Velu
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.AlgebraicGeometry.EllipticCurve.IsomOfJ
+import Mathlib.Data.Int.Star
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_Divisor_pushforwardAlong_pushforwardAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteAlong_comp
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_finiteAlong_of_surjective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_pointEnd_eq_of_mem_isogenyEndSubring
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyHomDatum_exists_pointHom_comp_eq_of_ker_le_of_isCentred
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_Point_exists_zsmul_eq_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_and_abelTheorem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_natCard_ker_pointMapOfPushforward_eq_finrankAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_pointMapOfPushforward_surjective
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_card_torsionBy_eq_sq_of_isAlgClosed
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_nonempty_functionField_algEquiv_of_variableChange
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Equal j of Vélu quotients forces equal cyclic subgroups
+
+Theorem statement:
+`WeierstrassCurve.zmultiples_eq_of_veluQuotient_j_eq_of_forall_isogenyEndDatum_exists_int`
+(`012791e6-9417-5e9d-b060-7ab6c0060cd8`), by Claude, 2026-09-05.
+
+Proof: submission `4d7ded92-6949-5c83-832a-9fae9dc5d7cf`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $\mathbb{K}=\mathrm{HahnSeries}\,\mathbb{Q}\,\overline{\mathbb{Q}}$ be the field of Hahn series
+with rational exponents and coefficients in an algebraic closure of $\mathbb{Q}$, assumed
+algebraically closed of characteristic $0$, and let $W$ be an elliptic Weierstrass curve over
+$\mathbb{K}$. Assume for its affine model: a `GenusOnePlaceGate`, i.e. a bijection between $W$'s
+affine point group and the places of its function field over $\mathbb{K}$, all of degree $1$; that
+this gate is centred, i.e. for each nonsingular $(x,y)$ the classes of the coordinate functions $X$
+and $Y-y$ lie in the nonunits of the valuation subring at the corresponding place; and
+`AbelTheorem`, i.e. a degree-zero divisor is principal exactly when its divisor sum vanishes. Assume
+further that for every isogeny endomorphism datum $D$ of $W$ (an integral $\mathbb{K}$-algebra
+endomorphism $\iota$ of the function field along which the field is module-finite over itself) the
+pushforward norm formula holds along $D.\iota$, and that the induced endomorphism
+$D.\mathrm{pointEnd}$ of the point group is multiplication by some integer $m$. Let $n\in\mathbb{N}$
+and let $Q,Q'$ both have additive order $2n+1$. Suppose the Vélu quotient curves formed from the
+summing sets $\{(k\cdot Q)\text{-coordinates}:1\le k\le n\}$, resp. for $Q'$, have nonzero
+discriminant, hence are elliptic, and have equal $j$-invariants. Then the subgroups of integer
+multiples of $Q$ and of $Q'$ coincide.
+
+This is the injectivity-on-cyclic-subgroups statement for $j$ of Vélu quotients for a curve whose
+endomorphisms are all integer multiples (Silverman, AEC III.4.12 in the form
+$\operatorname{Hom}(E,E')\cong\mathbb{Z}$): distinct cyclic subgroups of the same odd order give
+quotients with distinct $j$-invariants. It feeds the companion statement
+[`WeierstrassCurve.zmultiples_eq_of_veluQuotient_j_eq_of_transcendental`]
+(thm.html#WeierstrassCurve.zmultiples_eq_of_veluQuotient_j_eq_of_transcendental),
+where the hypotheses on endomorphisms are replaced by transcendence of the parameter.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_zmultiples_eq_of_veluQuotient_j_eq_of_forall_isogenyEndDatum_exists_int.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_OVERLONG_9421e021
+
+
+noncomputable section
+
+namespace ModularCurve
+
+theorem cmm5_dp_natCard_ker_comp {A B C : Type*} [AddCommGroup A] [AddCommGroup B]
+    [AddCommGroup C] (f : A →+ B) (g : B →+ C) (hf : Function.Surjective f) :
+    Nat.card (AddMonoidHom.ker (g.comp f))
+      = Nat.card (AddMonoidHom.ker g) * Nat.card (AddMonoidHom.ker f) := by
+  have hmem : ∀ x : AddMonoidHom.ker (g.comp f),
+      (f.domRestrict (AddMonoidHom.ker (g.comp f))) x ∈ AddMonoidHom.ker g := by
+    intro x
+    have hx := x.2
+    rw [AddMonoidHom.mem_ker] at hx
+    rw [AddMonoidHom.mem_ker]
+    exact hx
+  have hle : AddMonoidHom.ker f ≤ AddMonoidHom.ker (g.comp f) := by
+    intro x hx
+    rw [AddMonoidHom.mem_ker] at hx
+    rw [AddMonoidHom.mem_ker, AddMonoidHom.comp_apply, hx, map_zero]
+  have hφker : Nat.card (AddMonoidHom.ker
+        (AddMonoidHom.codRestrict (f.domRestrict (AddMonoidHom.ker (g.comp f)))
+          (AddMonoidHom.ker g) hmem))
+      = Nat.card (AddMonoidHom.ker f) := by
+    rw [AddMonoidHom.ker_codRestrict, AddMonoidHom.ker_domRestrict]
+    exact Nat.card_congr (AddSubgroup.addSubgroupOfEquivOfLe hle).toEquiv
+  have hφsurj : Function.Surjective
+      (AddMonoidHom.codRestrict (f.domRestrict (AddMonoidHom.ker (g.comp f)))
+        (AddMonoidHom.ker g) hmem) := by
+    intro y
+    have hy : g (y : B) = 0 := by
+      have h := y.2
+      rwa [AddMonoidHom.mem_ker] at h
+    obtain ⟨x, hx⟩ := hf (y : B)
+    have hxK : x ∈ AddMonoidHom.ker (g.comp f) := by
+      rw [AddMonoidHom.mem_ker, AddMonoidHom.comp_apply, hx]
+      exact hy
+    exact ⟨⟨x, hxK⟩, Subtype.ext hx⟩
+  calc Nat.card (AddMonoidHom.ker (g.comp f))
+      = Nat.card (AddMonoidHom.ker (g.comp f) ⧸ AddMonoidHom.ker
+            (AddMonoidHom.codRestrict (f.domRestrict (AddMonoidHom.ker (g.comp f)))
+              (AddMonoidHom.ker g) hmem))
+          * Nat.card (AddMonoidHom.ker
+            (AddMonoidHom.codRestrict (f.domRestrict (AddMonoidHom.ker (g.comp f)))
+              (AddMonoidHom.ker g) hmem)) :=
+        AddSubgroup.card_eq_card_quotient_mul_card_addSubgroup _
+    _ = Nat.card (AddMonoidHom.ker g) * Nat.card (AddMonoidHom.ker f) := by
+        rw [Nat.card_congr
+          (QuotientAddGroup.quotientKerEquivOfSurjective _ hφsurj).toEquiv, hφker]
+
+end ModularCurve
+
+namespace WeierstrassCurve
+p2m_export "WeierstrassCurve" "Affine map exists_variableChange_of_j_eq IsIntegral toAffine \
+  Affine.Point Δ j veluQuotient oddOrderSummingSet \
+  exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples \
+  Affine.Point.exists_zsmul_eq_of_isAlgClosed card_torsionBy_eq_sq_of_isAlgClosed \
+  nonempty_functionField_algEquiv_of_variableChange"
+namespace Affine
+p2m_export "WeierstrassCurve.Affine" "CoordinateRing map FunctionField Point pointMapOfPushforward \
+  pointMapOfPushforward_apply IsogenyEndDatum IsogenyHomDatum IsogenyHomDatum.ofEndDatum \
+  GenusOnePlaceGate pointClass AbelTheorem genusOnePic0Equiv genusOnePic0Equiv_symm_apply \
+  GenusOnePlaceGate.IsCentred IsogenyHomDatum.exists_pointHom_comp_eq_of_ker_le_of_isCentred \
+  natCard_ker_pointMapOfPushforward_eq_finrankAlong pointMapOfPushforward_surjective \
+  Point.exists_zsmul_eq_of_isAlgClosed IsogenyEndDatum.exists_pointEnd_eq_of_mem_isogenyEndSubring \
+  exists_genusOnePlaceGate_isCentred_and_abelTheorem CoordinateRing.isDedekindDomain \
+  hasPrincipalDivisors_functionField"
+p2m_open "WeierstrassCurve.Affine~pointHom WeierstrassCurve"
+
+open AlgebraicCurve
+
+scoped instance instHasPrincipalDivisorsFunctionField_s13jb {F : Type*} [Field F] [CharZero F]
+    {W : Affine F} : HasPrincipalDivisors F W.FunctionField :=
+  hasPrincipalDivisors_functionField W
+
+section AutoNorm
+
+variable {F : Type*} [Field F] [CharZero F] {V W : Affine F}
+
+theorem normFormulaAlong_of_elliptic (ι : V.FunctionField →ₐ[F] W.FunctionField)
+    (hfin : FiniteAlong F ι) : NormFormulaAlong F ι hfin := by
+  classical
+  have : CharZero V.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap F V.FunctionField).injective
+  have hsep : SeparableAlong F ι := by
+    let := algebraAlong ι
+    have := isScalarTower_along ι
+    have : Module.Finite V.FunctionField W.FunctionField := hfin
+    change Algebra.IsSeparable V.FunctionField W.FunctionField
+    infer_instance
+  exact AlgebraicCurve.normFormulaAlong ι hfin hsep
+
+end AutoNorm
+
+section Torsion
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable (W : Affine F) [W.IsElliptic]
+
+theorem charZero_addMonoidEnd_point : CharZero (AddMonoid.End W.Point) := by
+  refine charZero_of_inj_zero fun n hn => ?_
+  by_contra hn0
+  have htop : ∀ k : ℕ, n ∣ k → Submodule.torsionBy ℤ W.Point (k : ℤ) = ⊤ := by
+    rintro k ⟨c, rfl⟩
+    refine eq_top_iff.mpr fun P _ => ?_
+    rw [Submodule.mem_torsionBy_iff]
+    have hP : (n : ℤ) • P = 0 := by
+      have h := DFunLike.congr_fun hn P
+      rw [AddMonoid.End.natCast_apply] at h
+      rw [natCast_zsmul]; exact h
+    rw [Nat.cast_mul, mul_comm, mul_smul, hP, smul_zero]
+  have hcard : ∀ k : ℕ, n ∣ k → k ≠ 0 → Nat.card W.Point = k ^ 2 := by
+    intro k hk hk0
+    have h : Nat.card (Submodule.torsionBy ℤ W.Point (k : ℤ)) = k ^ 2 :=
+      WeierstrassCurve.card_torsionBy_eq_sq_of_isAlgClosed W (n := k)
+        (Nat.cast_ne_zero.mpr hk0)
+    rw [htop k hk] at h
+    rwa [Nat.card_congr (Submodule.topEquiv (R := ℤ) (M := W.Point)).toEquiv] at h
+  have h1 := hcard n dvd_rfl hn0
+  have h2 := hcard (2 * n) (dvd_mul_left n 2) (by omega)
+  have h3 : n ^ 2 = (2 * n) ^ 2 := h1.symm.trans h2
+  have h4 : 3 * n ^ 2 = 0 := by nlinarith
+  have h5 : n = 0 := by
+    have : n ^ 2 = 0 := by omega
+    exact pow_eq_zero_iff (n := 2) (by norm_num) |>.mp this
+  exact hn0 h5
+
+theorem intCast_addMonoidEnd_point_injective :
+    Function.Injective (Int.cast : ℤ → AddMonoid.End W.Point) :=
+  haveI := charZero_addMonoidEnd_point W
+  Int.cast_injective
+
+variable {W} in
+omit [DecidableEq F] in
+theorem kw_point_infinite : Infinite W.Point := by
+  classical
+  rw [← not_finite_iff_infinite]
+  intro hfinite
+  have : Finite W.Point := hfinite
+  set N : ℕ := Nat.card W.Point with hN
+  have hNpos : 0 < N := Nat.card_pos
+  have htop : ∀ k : ℕ, N ∣ k → Submodule.torsionBy ℤ W.Point (k : ℤ) = ⊤ := by
+    rintro k ⟨c, rfl⟩
+    refine eq_top_iff.mpr fun P _ => ?_
+    rw [Submodule.mem_torsionBy_iff]
+    have hP : (N : ℤ) • P = 0 := by
+      rw [natCast_zsmul, hN]; exact card_nsmul_eq_zero'
+    rw [Nat.cast_mul, mul_comm, mul_smul, hP, smul_zero]
+  have hcard : ∀ k : ℕ, N ∣ k → k ≠ 0 → N = k ^ 2 := by
+    intro k hk hk0
+    have h : Nat.card (Submodule.torsionBy ℤ W.Point (k : ℤ)) = k ^ 2 :=
+      WeierstrassCurve.card_torsionBy_eq_sq_of_isAlgClosed W (n := k)
+        (Nat.cast_ne_zero.mpr hk0)
+    rw [htop k hk] at h
+    rwa [Nat.card_congr (Submodule.topEquiv (R := ℤ) (M := W.Point)).toEquiv, ← hN] at h
+  have h1 := hcard N dvd_rfl hNpos.ne'
+  have h2 := hcard (2 * N) (dvd_mul_left N 2) (by omega)
+  have h3 : N ^ 2 = (2 * N) ^ 2 := h1.symm.trans h2
+  have h4 : N ^ 2 = 0 := by nlinarith
+  exact hNpos.ne' (pow_eq_zero_iff (n := 2) (by norm_num) |>.mp h4)
+
+variable {W} in
+theorem kw_nat_card_ker_of_zsmul {f : W.Point →+ W.Point} {N : ℤ}
+    (hN : N ≠ 0) (hf : ∀ P, f P = N • P) : Nat.card f.ker = N.natAbs ^ 2 := by
+  have hsets : ∀ P : W.Point,
+      P ∈ f.ker ↔ P ∈ Submodule.torsionBy ℤ W.Point (N.natAbs : ℤ) := by
+    intro P
+    rw [AddMonoidHom.mem_ker, hf, Submodule.mem_torsionBy_iff]
+    constructor
+    · intro hP
+      rcases Int.natAbs_eq N with h | h
+      · rwa [h] at hP
+      · rwa [h, neg_zsmul, neg_eq_zero] at hP
+    · intro hP
+      rcases Int.natAbs_eq N with h | h
+      · rw [h]; exact hP
+      · rw [h, neg_zsmul, neg_eq_zero]; exact hP
+  rw [Nat.card_congr (Equiv.subtypeEquivRight hsets)]
+  exact WeierstrassCurve.card_torsionBy_eq_sq_of_isAlgClosed W (n := N.natAbs)
+    (Nat.cast_ne_zero.mpr (Int.natAbs_ne_zero.mpr hN))
+
+variable {W} in
+omit [CharZero F] in
+theorem kw_eq_zero_of_zsmul_eq_zero {N : ℤ} (hN : N ≠ 0) {G : Type*} [AddCommGroup G]
+    (δ : W.Point →+ G) (hδ : ∀ P, N • δ P = 0) : δ = 0 := by
+  refine AddMonoidHom.ext fun P => ?_
+  obtain ⟨R, hR⟩ : ∃ R : W.Point, N • R = P :=
+    WeierstrassCurve.Affine.Point.exists_zsmul_eq_of_isAlgClosed W hN P
+  rw [← hR, map_zsmul]; exact hδ R
+
+end Torsion
+
+section Functoriality
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F]
+variable {A B C : Affine F}
+  [GenusOnePlaceGate A] [AbelTheorem A]
+  [GenusOnePlaceGate B] [AbelTheorem B]
+  [GenusOnePlaceGate C] [AbelTheorem C]
+
+omit [DecidableEq F] [A.GenusOnePlaceGate] [A.AbelTheorem] [B.GenusOnePlaceGate]
+  [B.AbelTheorem] [C.GenusOnePlaceGate] [C.AbelTheorem] in
+theorem Pic0_pushforwardAlongHom_comp
+    (f : B.FunctionField →ₐ[F] A.FunctionField) (hf : f.toRingHom.IsIntegral)
+    (hfinf : FiniteAlong F f) (hNf : NormFormulaAlong F f hfinf)
+    (g : C.FunctionField →ₐ[F] B.FunctionField) (hg : g.toRingHom.IsIntegral)
+    (hfing : FiniteAlong F g) (hNg : NormFormulaAlong F g hfing)
+    (hfg : (f.comp g).toRingHom.IsIntegral) (hfinfg : FiniteAlong F (f.comp g))
+    (hNfg : NormFormulaAlong F (f.comp g) hfinfg)
+    (x : Pic0 F A.FunctionField) :
+    Pic0.pushforwardAlongHom g hg hfing hNg (Pic0.pushforwardAlongHom f hf hfinf hNf x)
+      = Pic0.pushforwardAlongHom (f.comp g) hfg hfinfg hNfg x := by
+  obtain ⟨D, rfl⟩ := Pic0.mk_surjective x
+  rw [Pic0.pushforwardAlongHom_mk, Pic0.pushforwardAlongHom_mk, Pic0.pushforwardAlongHom_mk]
+  congr 1
+  refine Subtype.ext ?_
+  rw [Pic0.coe_pushforwardAlongDegZero, Pic0.coe_pushforwardAlongDegZero,
+    Pic0.coe_pushforwardAlongDegZero]
+  exact Divisor.pushforwardAlong_pushforwardAlong g f hg hf hfg (D : Divisor F A.FunctionField)
+
+theorem pointMapOfPushforward_comp
+    (f : B.FunctionField →ₐ[F] A.FunctionField) (hf : f.toRingHom.IsIntegral)
+    (hfinf : FiniteAlong F f) (hNf : NormFormulaAlong F f hfinf)
+    (g : C.FunctionField →ₐ[F] B.FunctionField) (hg : g.toRingHom.IsIntegral)
+    (hfing : FiniteAlong F g) (hNg : NormFormulaAlong F g hfing)
+    (hfg : (f.comp g).toRingHom.IsIntegral) (hfinfg : FiniteAlong F (f.comp g))
+    (hNfg : NormFormulaAlong F (f.comp g) hfinfg) (P : A.Point) :
+    pointMapOfPushforward (f.comp g) hfg hfinfg hNfg P
+      = pointMapOfPushforward g hg hfing hNg (pointMapOfPushforward f hf hfinf hNf P) := by
+  have key : ∀ x : Pic0 F B.FunctionField, pointClass (genusOnePic0Equiv B x) = x := fun x => by
+    rw [← genusOnePic0Equiv_symm_apply, AddEquiv.symm_apply_apply]
+  rw [pointMapOfPushforward_apply, pointMapOfPushforward_apply, pointMapOfPushforward_apply, key,
+    Pic0_pushforwardAlongHom_comp f hf hfinf hNf g hg hfing hNg hfg hfinfg hNfg]
+
+end Functoriality
+
+section IsoInjective
+
+universe u
+
+variable {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+variable {A B : Affine F}
+  [A.IsElliptic] [GenusOnePlaceGate A] [AbelTheorem A]
+  [B.IsElliptic] [GenusOnePlaceGate B] [AbelTheorem B]
+
+omit [DecidableEq F] [IsAlgClosed F] [CharZero F] [WeierstrassCurve.IsElliptic A]
+  [A.GenusOnePlaceGate] [A.AbelTheorem] [WeierstrassCurve.IsElliptic B] [B.GenusOnePlaceGate]
+  [B.AbelTheorem] in
+theorem finrankAlong_eq_one_of_bijective (τ : B.FunctionField →ₐ[F] A.FunctionField)
+    (hτ : Function.Bijective τ) : finrankAlong F τ = 1 := by
+  let := algebraAlong τ
+  let σ : B.FunctionField ≃+* A.FunctionField := RingEquiv.ofBijective τ hτ
+  let e : A.FunctionField ≃ₗ[B.FunctionField] B.FunctionField :=
+    { σ.symm.toAddEquiv with
+      map_smul' := fun b x => by
+        change σ.symm (b • x) = b * σ.symm x
+        rw [Algebra.smul_def, map_mul]
+        congr 1
+        exact σ.symm_apply_apply b }
+  change Module.finrank B.FunctionField A.FunctionField = 1
+  rw [e.finrank_eq, Module.finrank_self]
+
+theorem pointMapOfPushforward_injective_of_bijective
+    (τ : B.FunctionField →ₐ[F] A.FunctionField) (hτ : τ.toRingHom.IsIntegral)
+    (hfin : FiniteAlong F τ) (hN : NormFormulaAlong F τ hfin) (hbij : Function.Bijective τ) :
+    Function.Injective (pointMapOfPushforward τ hτ hfin hN) := by
+  have hcard : Nat.card (pointMapOfPushforward τ hτ hfin hN).ker = 1 := by
+    rw [natCard_ker_pointMapOfPushforward_eq_finrankAlong A B τ hτ hfin hN,
+      finrankAlong_eq_one_of_bijective τ hbij]
+  have : Finite (pointMapOfPushforward τ hτ hfin hN).ker :=
+    Nat.finite_of_card_ne_zero (by rw [hcard]; exact one_ne_zero)
+  have hbot : (pointMapOfPushforward τ hτ hfin hN).ker = ⊥ :=
+    AddSubgroup.eq_bot_of_card_eq _ hcard
+  exact (AddMonoidHom.ker_eq_bot_iff _).mp hbot
+
+end IsoInjective
+
+end WeierstrassCurve.Affine
+
+namespace ModularCurve
+
+p2m_open "WeierstrassCurve \
+  P2MW.S_OVERLONG_9421e021.W\
+  eierstrassCurve WeierstrassCurve.Affine~pointHom \
+  P2MW.S_OVERLONG_9421e021.W\
+  eierstrassCurve.Affine AlgebraicCurve"
+
+universe u
+
+attribute [local instance] Classical.propDecidable
+
+theorem kw_veluOddQuotientJInjOnCyclic_of_isogenyEndInt
+    {F : Type u} [Field F] [DecidableEq F] [IsAlgClosed F] [CharZero F]
+    (W : WeierstrassCurve F) [W.IsElliptic]
+    [GenusOnePlaceGate W.toAffine] [GenusOnePlaceGate.IsCentred W.toAffine]
+    [AbelTheorem W.toAffine]
+    (hNs : ∀ D : IsogenyEndDatum W.toAffine, NormFormulaAlong F D.ι D.hfin)
+    (hEnd : ∀ D : IsogenyEndDatum W.toAffine, ∃ m : ℤ, ∀ P : W.toAffine.Point,
+      D.pointEnd (hNs D) P = m • P)
+    (n : ℕ) (Q Q' : W.toAffine.Point)
+    (hQ : addOrderOf Q = 2 * n + 1) (hQ' : addOrderOf Q' = 2 * n + 1)
+    (hΔ : (W.veluQuotient (W.oddOrderSummingSet Q n)).Δ ≠ 0)
+    (hΔ' : (W.veluQuotient (W.oddOrderSummingSet Q' n)).Δ ≠ 0)
+    (hj : haveI : (W.veluQuotient (W.oddOrderSummingSet Q n)).IsElliptic :=
+        ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+      haveI : (W.veluQuotient (W.oddOrderSummingSet Q' n)).IsElliptic :=
+        ⟨isUnit_iff_ne_zero.mpr hΔ'⟩
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).j
+        = (W.veluQuotient (W.oddOrderSummingSet Q' n)).j) :
+    AddSubgroup.zmultiples Q = AddSubgroup.zmultiples Q' := by
+  classical
+  have hell : (W.veluQuotient (W.oddOrderSummingSet Q n)).IsElliptic :=
+    ⟨isUnit_iff_ne_zero.mpr hΔ⟩
+  have hell' : (W.veluQuotient (W.oddOrderSummingSet Q' n)).IsElliptic :=
+    ⟨isUnit_iff_ne_zero.mpr hΔ'⟩
+  have : IsDedekindDomain (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.CoordinateRing :=
+    CoordinateRing.isDedekindDomain (W.veluQuotient (W.oddOrderSummingSet Q n))
+  have : IsDedekindDomain (W.veluQuotient (W.oddOrderSummingSet Q' n)).toAffine.CoordinateRing :=
+    CoordinateRing.isDedekindDomain (W.veluQuotient (W.oddOrderSummingSet Q' n))
+  obtain ⟨gV, hcV, haV⟩ := exists_genusOnePlaceGate_isCentred_and_abelTheorem
+    (W := (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine)
+  obtain ⟨gV', hcV', haV'⟩ := exists_genusOnePlaceGate_isCentred_and_abelTheorem
+    (W := (W.veluQuotient (W.oddOrderSummingSet Q' n)).toAffine)
+  let := gV
+  let := gV'
+  have := hcV
+  have := hcV'
+  have := haV
+  have := haV'
+  obtain ⟨ι, hι, hfin, -, hkerQ⟩ :=
+    WeierstrassCurve.exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples hQ hΔ
+  obtain ⟨ι', hι', hfin', -, hkerQ'⟩ :=
+    WeierstrassCurve.exists_veluFunctionFieldHom_pointMapOfPushforward_ker_eq_zmultiples hQ' hΔ'
+  obtain ⟨C, hC⟩ := WeierstrassCurve.exists_variableChange_of_j_eq
+    (W.veluQuotient (W.oddOrderSummingSet Q n))
+    (W.veluQuotient (W.oddOrderSummingSet Q' n)) hj
+  obtain ⟨σ⟩ : Nonempty ((W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.FunctionField
+      ≃ₐ[F] (W.veluQuotient (W.oddOrderSummingSet Q' n)).toAffine.FunctionField) :=
+    hC ▸ WeierstrassCurve.nonempty_functionField_algEquiv_of_variableChange
+      (W.veluQuotient (W.oddOrderSummingSet Q n)) C
+  set τ : (W.veluQuotient (W.oddOrderSummingSet Q' n)).toAffine.FunctionField
+      →ₐ[F] (W.veluQuotient (W.oddOrderSummingSet Q n)).toAffine.FunctionField :=
+    σ.symm.toAlgHom with hτ_def
+  have hτbij : Function.Bijective τ := σ.symm.bijective
+  have hτint : τ.toRingHom.IsIntegral := RingHom.isIntegral_of_surjective _ hτbij.2
+  have hτfin : FiniteAlong F τ := finiteAlong_of_surjective τ hτbij.2
+  have hNτ : NormFormulaAlong F τ hτfin := normFormulaAlong_of_elliptic τ hτfin
+  have hNι : NormFormulaAlong F ι hfin := normFormulaAlong_of_elliptic ι hfin
+  have hNι' : NormFormulaAlong F ι' hfin' := normFormulaAlong_of_elliptic ι' hfin'
+  have hιτint : (ι.comp τ).toRingHom.IsIntegral := RingHom.IsIntegral.trans _ _ hτint hι
+  have hιτfin : FiniteAlong F (ι.comp τ) := finiteAlong_comp τ ι hτfin hfin
+  have hNιτ : NormFormulaAlong F (ι.comp τ) hιτfin := normFormulaAlong_of_elliptic _ hιτfin
+  set φ := pointMapOfPushforward ι hι hfin hNι with hφ_def
+  set φ' := pointMapOfPushforward ι' hι' hfin' hNι' with hφ'_def
+  set β := pointMapOfPushforward (ι.comp τ) hιτint hιτfin hNιτ with hβ_def
+  have hβ_comp : ∀ P, β P = pointMapOfPushforward τ hτint hτfin hNτ (φ P) := fun P =>
+    pointMapOfPushforward_comp ι hι hfin hNι τ hτint hτfin hNτ hιτint hιτfin hNιτ P
+  have hτinj := pointMapOfPushforward_injective_of_bijective τ hτint hτfin hNτ hτbij
+  have hkerφ : φ.ker = AddSubgroup.zmultiples Q := hkerQ hNι
+  have hkerφ' : φ'.ker = AddSubgroup.zmultiples Q' := hkerQ' hNι'
+  have hkerβ : β.ker = AddSubgroup.zmultiples Q := by
+    rw [← hkerφ]
+    refine AddSubgroup.ext fun P => ?_
+    rw [AddMonoidHom.mem_ker, AddMonoidHom.mem_ker, hβ_comp]
+    refine ⟨fun h => hτinj (h.trans (map_zero _).symm), fun h => ?_⟩
+    rw [h, map_zero]
+  have hβs : Function.Surjective β :=
+    pointMapOfPushforward_surjective W.toAffine _ (ι.comp τ) hιτint hιτfin hNιτ
+  have hφ's : Function.Surjective φ' :=
+    pointMapOfPushforward_surjective W.toAffine _ ι' hι' hfin' hNι'
+  have hNne : ((2 * n + 1 : ℤ) : AddMonoid.End W.toAffine.Point) ≠ 0 := by
+    intro h
+    have := intCast_addMonoidEnd_point_injective W.toAffine (h.trans Int.cast_zero.symm)
+    omega
+  obtain ⟨M, hM⟩ := IsogenyEndDatum.exists_pointEnd_eq_of_mem_isogenyEndSubring hNs
+    ((2 * n + 1 : ℤ) : AddMonoid.End W.toAffine.Point) (intCast_mem _ _) hNne
+  have hMapp : ∀ P, M.pointEnd (hNs M) P = (2 * n + 1 : ℤ) • P := fun P => by
+    rw [hM, AddMonoid.End.intCast_apply]
+  let φ'D : IsogenyHomDatum W.toAffine (W.veluQuotient (W.oddOrderSummingSet Q' n)).toAffine :=
+    ⟨ι', hι', hfin'⟩
+  have hmem_of_ker : ∀ P, φ' P = 0 → (2 * n + 1 : ℤ) • P = 0 := by
+    intro P hP
+    have hPm : P ∈ AddSubgroup.zmultiples Q' := by rw [← hkerφ']; exact hP
+    obtain ⟨k, rfl⟩ := AddSubgroup.mem_zmultiples_iff.mp hPm
+    have h21 : (2 * n + 1 : ℤ) • Q' = 0 := by
+      have h : ((2 * n + 1 : ℕ) : ℤ) • Q' = 0 := by
+        rw [natCast_zsmul, ← hQ', addOrderOf_nsmul_eq_zero]
+      exact_mod_cast h
+    rw [smul_comm, h21, zsmul_zero]
+  obtain ⟨χ, hNχ, hχ⟩ := IsogenyHomDatum.exists_pointHom_comp_eq_of_ker_le_of_isCentred φ'D hNι'
+    (IsogenyHomDatum.ofEndDatum M) (hNs M) (fun P hP => by
+      change M.pointEnd (hNs M) P = 0
+      rw [hMapp]; exact hmem_of_ker P hP)
+  set ψ' := χ.pointHom hNχ with hψ'_def
+  have hdual₁ : ∀ P, ψ' (φ' P) = (2 * n + 1 : ℤ) • P := fun P => by
+    have h := hχ P
+    rw [← hMapp P]; exact h
+  have hdual₂ : ∀ S, φ' (ψ' S) = (2 * n + 1 : ℤ) • S := fun S => by
+    obtain ⟨P, rfl⟩ := hφ's S
+    rw [hdual₁, map_zsmul]
+  have hDint : ((ι.comp τ).comp χ.ι).toRingHom.IsIntegral :=
+    RingHom.IsIntegral.trans _ _ χ.hι hιτint
+  let D : IsogenyEndDatum W.toAffine :=
+    ⟨(ι.comp τ).comp χ.ι, hDint, finiteAlong_comp χ.ι (ι.comp τ) χ.hfin hιτfin⟩
+  have hD : ∀ P, D.pointEnd (hNs D) P = ψ' (β P) := fun P =>
+    pointMapOfPushforward_comp (ι.comp τ) hιτint hιτfin hNιτ χ.ι χ.hι χ.hfin hNχ
+      hDint D.hfin (hNs D) P
+  obtain ⟨m, hm⟩ := hEnd D
+  set θ := ψ'.comp β with hθ_def
+  have hθm : ∀ P, θ P = m • P := fun P => by
+    change ψ' (β P) = m • P
+    rw [← hD P]; exact hm P
+  have hcardQ' : Nat.card (AddSubgroup.zmultiples Q') = 2 * n + 1 := by
+    rw [Nat.card_zmultiples, hQ']
+  have hcardQ : Nat.card (AddSubgroup.zmultiples Q) = 2 * n + 1 := by
+    rw [Nat.card_zmultiples, hQ]
+  have hkerψ' : Nat.card ψ'.ker = 2 * n + 1 := by
+    have hcomp : Nat.card (ψ'.comp φ').ker = (2 * n + 1) ^ 2 := by
+      have h := kw_nat_card_ker_of_zsmul (W := W.toAffine) (f := ψ'.comp φ')
+        (N := (2 * n + 1 : ℤ)) (by omega) (fun P => hdual₁ P)
+      have habs : (2 * (n : ℤ) + 1).natAbs = 2 * n + 1 := by omega
+      rw [habs] at h; exact h
+    have hsplit := cmm5_dp_natCard_ker_comp φ' ψ' hφ's
+    rw [hcomp, hkerφ', hcardQ', sq] at hsplit
+    exact (Nat.eq_of_mul_eq_mul_right (by omega) hsplit).symm
+  have hkerθ : Nat.card θ.ker = (2 * n + 1) ^ 2 := by
+    have hsplit := cmm5_dp_natCard_ker_comp β ψ' hβs
+    rw [hkerβ, hcardQ, hkerψ'] at hsplit
+    rw [hsplit]; ring
+  have hmne : m ≠ 0 := by
+    intro h0
+    have hall : ∀ P, θ P = 0 := fun P => by rw [hθm, h0, zero_zsmul]
+    have htop : θ.ker = ⊤ :=
+      AddSubgroup.ext fun P => ⟨fun _ => trivial, fun _ => AddMonoidHom.mem_ker.mpr (hall P)⟩
+    rw [htop] at hkerθ
+    have : Infinite W.toAffine.Point := kw_point_infinite
+    simp only [AddSubgroup.card_top, Nat.card_eq_zero_of_infinite] at hkerθ
+    exact absurd hkerθ.symm (by positivity)
+  have hm_abs : m.natAbs = 2 * n + 1 := by
+    have hcard := kw_nat_card_ker_of_zsmul (W := W.toAffine) hmne hθm
+    rw [hkerθ, sq, sq] at hcard
+    exact (Nat.mul_self_inj).mp hcard.symm
+  have hkey : ∀ P, (2 * n + 1 : ℤ) • β P = m • φ' P := fun P => by
+    have h1 : φ' (ψ' (β P)) = (2 * n + 1 : ℤ) • β P := hdual₂ (β P)
+    have h2 : φ' (θ P) = m • φ' P := by rw [hθm, map_zsmul]
+    rw [← h1]; exact h2
+  have hmcases : m = (2 * n + 1 : ℤ) ∨ m = -(2 * n + 1 : ℤ) := by
+    rcases Int.natAbs_eq m with h | h <;> [left; right] <;> omega
+  have hNz : (2 * n + 1 : ℤ) ≠ 0 := by omega
+  have hkerβ' : β.ker = AddSubgroup.zmultiples Q' := by
+    rcases hmcases with hm' | hm'
+    · have hδ : β - φ' = 0 :=
+        kw_eq_zero_of_zsmul_eq_zero (W := W.toAffine) hNz (β - φ') fun P => by
+          rw [AddMonoidHom.sub_apply, smul_sub, hkey P, hm', sub_self]
+      have heq : β = φ' := sub_eq_zero.mp hδ
+      rw [heq]; exact hkerφ'
+    · have hδ : β + φ' = 0 :=
+        kw_eq_zero_of_zsmul_eq_zero (W := W.toAffine) hNz (β + φ') fun P => by
+          rw [AddMonoidHom.add_apply, smul_add, hkey P, hm', ← add_smul, neg_add_cancel,
+            zero_smul]
+      have heq : β = -φ' := eq_neg_iff_add_eq_zero.mpr hδ
+      rw [heq, ← hkerφ']
+      exact AddSubgroup.ext fun P => by
+        simp only [AddMonoidHom.mem_ker, AddMonoidHom.neg_apply, neg_eq_zero]
+  exact hkerβ.symm.trans hkerβ'
+
+end ModularCurve
+end
+
+p2m_open "WeierstrassCurve.Affine~pointHom\
+  " in
+open _root_.WeierstrassCurve
+  _root_.P2MW.S_OVERLONG_9421e021.WeierstrassCurve
+  _root_.P2MW.S_OVERLONG_9421e021.WeierstrassCurve.Affine
+  AlgebraicCurve in
+theorem solution
+    [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))] [CharZero (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    [IsAlgClosed (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    [GenusOnePlaceGate W.toAffine] [GenusOnePlaceGate.IsCentred W.toAffine] [AbelTheorem W.toAffine]
+    (hNs : ∀ D : IsogenyEndDatum W.toAffine, NormFormulaAlong (HahnSeries ℚ (AlgebraicClosure ℚ))
+      D.ι D.hfin)
+    (hEnd : ∀ D : IsogenyEndDatum W.toAffine, ∃ m : ℤ, ∀ P : W.toAffine.Point, D.pointEnd (hNs D) P
+      = m • P)
+    (n : ℕ) (Q Q' : W.toAffine.Point)
+    (hQ : addOrderOf Q = 2 * n + 1) (hQ' : addOrderOf Q' = 2 * n + 1)
+    (hΔ : (W.veluQuotient (W.oddOrderSummingSet Q n)).Δ ≠ 0)
+    (hΔ' : (W.veluQuotient (W.oddOrderSummingSet Q' n)).Δ ≠ 0)
+    (hj : haveI : (W.veluQuotient (W.oddOrderSummingSet Q n)).IsElliptic := ⟨isUnit_iff_ne_zero.mpr
+      hΔ⟩
+      haveI : (W.veluQuotient (W.oddOrderSummingSet Q' n)).IsElliptic := ⟨isUnit_iff_ne_zero.mpr
+        hΔ'⟩
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).j = (W.veluQuotient (W.oddOrderSummingSet Q'
+        n)).j) :
+    AddSubgroup.zmultiples Q = AddSubgroup.zmultiples Q' :=
+  ModularCurve.kw_veluOddQuotientJInjOnCyclic_of_isogenyEndInt W hNs hEnd n Q Q' hQ hQ' hΔ hΔ' hj
+
+end S_OVERLONG_9421e021
+end P2MW
+export
+  P2MW.S_OVERLONG_9421e021
+  (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+theorem WeierstrassCurve.zmultiples_eq_of_veluQuotient_j_eq_of_forall_isogenyEndDatum_exists_int
+    [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))] [CharZero (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    [IsAlgClosed (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    [GenusOnePlaceGate W.toAffine] [GenusOnePlaceGate.IsCentred W.toAffine] [AbelTheorem W.toAffine]
+    (hNs : ∀ D : IsogenyEndDatum W.toAffine, NormFormulaAlong (HahnSeries ℚ (AlgebraicClosure ℚ))
+      D.ι D.hfin)
+    (hEnd : ∀ D : IsogenyEndDatum W.toAffine, ∃ m : ℤ, ∀ P : W.toAffine.Point, D.pointEnd (hNs D) P
+      = m • P)
+    (n : ℕ) (Q Q' : W.toAffine.Point)
+    (hQ : addOrderOf Q = 2 * n + 1) (hQ' : addOrderOf Q' = 2 * n + 1)
+    (hΔ : (W.veluQuotient (W.oddOrderSummingSet Q n)).Δ ≠ 0)
+    (hΔ' : (W.veluQuotient (W.oddOrderSummingSet Q' n)).Δ ≠ 0)
+    (hj : haveI : (W.veluQuotient (W.oddOrderSummingSet Q n)).IsElliptic := ⟨isUnit_iff_ne_zero.mpr
+      hΔ⟩
+      haveI : (W.veluQuotient (W.oddOrderSummingSet Q' n)).IsElliptic := ⟨isUnit_iff_ne_zero.mpr
+        hΔ'⟩
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).j = (W.veluQuotient (W.oddOrderSummingSet Q'
+        n)).j) :
+    AddSubgroup.zmultiples Q = AddSubgroup.zmultiples Q' :=
+  solution W hNs hEnd n Q Q' hQ hQ' hΔ hΔ' hj
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_zmultiples_eq_of_veluQuotient_j_eq_of_transcendental.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_zmultiples_eq_of_veluQuotient_j_eq_of_transcendental.lean
new file mode 100644
index 0000000000..50c4d4361d
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_WeierstrassCurve_zmultiples_eq_of_veluQuotient_j_eq_of_transcendental.lean
@@ -0,0 +1,165 @@
+/-
+Based on Prove2Me node WeierstrassCurve.zmultiples_eq_of_veluQuotient_j_eq_of_transcendental
+(15e5edb3-b3ba-566c-a842-036261074c96) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 4f9294dd-b7f9-5556-ad59-3851a2ac7a1b
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.FieldTheory.IsAlgClosed.AlgebraicClosure
+public import Mathlib.RingTheory.HahnSeries.PowerSeries
+public import Mathlib.RingTheory.HahnSeries.Summable
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_OddOrderSummingSet
+public import LeanPool.FLTEichlerShimura.Definitions.Def_WeierstrassCurve_Velu
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_AlgebraicCurve_normFormulaAlong
+import LeanPool.FLTEichlerShimura.Theorems.Thm_HahnSeries_isAlgClosed_rat
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_CoordinateRing_isDedekindDomain
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_IsogenyEndDatum_exists_forall_pointEnd_eq_zsmul_of_transcendental_j
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_exists_genusOnePlaceGate_isCentred_and_abelTheorem
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_Affine_hasPrincipalDivisors_functionField
+import LeanPool.FLTEichlerShimura.Theorems.Thm_WeierstrassCurve_zmultiples_eq_of_veluQuotient_j_eq_of_forall_isogenyEndDatum_exists_int
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Odd cyclic subgroups determined by the Vélu quotient's j
+
+Theorem statement: `WeierstrassCurve.zmultiples_eq_of_veluQuotient_j_eq_of_transcendental`
+(`15e5edb3-b3ba-566c-a842-036261074c96`), by Claude, 2026-09-05.
+
+Proof: submission `4f9294dd-b7f9-5556-ad59-3851a2ac7a1b`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Work over the field $K = \mathrm{HahnSeries}\ \mathbb{Q}\ \overline{\mathbb{Q}}$ of Hahn series with
+rational exponents and coefficients in an algebraic closure of $\mathbb{Q}$. Let $W$ be a
+Weierstrass curve over $K$ whose discriminant is a unit (`W.IsElliptic`), and assume its
+$j$-invariant $j(W)$ is transcendental over $\mathbb{Q}$. Let $n$ be a natural number and let $Q,
+Q'$ be points of the associated affine curve $W$ each of additive order exactly $2n+1$. For a point
+$P$ write $\mathrm{coordsOrZero}(P)$ for its pair of affine coordinates, with the point at infinity
+sent to $(0,0)$, and let $S_Q = \{\mathrm{coordsOrZero}(kQ) : 1 \le k \le n\} \subseteq K \times K$,
+and similarly $S_{Q'}$; the Vélu quotient $\mathrm{veluQuotient}\ S$ is the Weierstrass curve with
+the same $a_1, a_2, a_3$ as $W$ and with $a_4$ replaced by $a_4 - 5\sum_{P \in S} t(P)$ and $a_6$ by
+$a_6 - b_2\sum_{P \in S} t(P) - 7\sum_{P \in S} w(P)$. Assume the discriminants of the two Vélu
+quotients $\mathrm{veluQuotient}\ S_Q$ and $\mathrm{veluQuotient}\ S_{Q'}$ are nonzero — so that
+both are elliptic and have a $j$-invariant — and that these two $j$-invariants are equal. Then the
+cyclic subgroups generated by $Q$ and by $Q'$ coincide: $\mathbb{Z}Q = \mathbb{Z}Q'$ inside the
+group of points of $W$.
+
+This is the injectivity of $C \mapsto j(E/C)$ on cyclic subgroups of a fixed odd order $N = 2n+1$,
+for a curve whose $j$-invariant is transcendental over $\mathbb{Q}$ (so that the curve has no extra
+endomorphisms). It is used in the study of the modular polynomial $\Phi_N$ over the Hahn series
+field: the fibre-polynomial factorisation into Vélu quotient $j$-invariants, the root-membership
+criterion for odd level, and the construction of elliptic points with prescribed cyclic subgroup
+orbits.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_WeierstrassCurve_zmultiples_eq_of_veluQuotient_j_eq_of_transcendental.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_WeierstrassCurve_zmultiples_eq_of_veluQuotient_j_eq_of_transcendental
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve
+
+noncomputable section
+
+namespace Ws13B
+
+theorem charZero_hahn : CharZero (HahnSeries ℚ (AlgebraicClosure ℚ)) :=
+  (RingHom.charZero_iff (HahnSeries.C (R := AlgebraicClosure ℚ) (Γ := ℚ)).injective).mp
+    inferInstance
+
+theorem normFormulaAlong_of_elliptic {F : Type*} [Field F] [IsAlgClosed F]
+    [CharZero F]
+    {V W : Affine F} [V.IsElliptic] [W.IsElliptic] (ι : V.FunctionField →ₐ[F] W.FunctionField)
+    (hfin : FiniteAlong F ι) : NormFormulaAlong F ι hfin := by
+  classical
+  have : HasPrincipalDivisors F W.FunctionField := hasPrincipalDivisors_functionField W
+  have : CharZero V.FunctionField :=
+    charZero_of_injective_algebraMap (algebraMap F V.FunctionField).injective
+  have hsep : SeparableAlong F ι := by
+    let := algebraAlong ι
+    have := isScalarTower_along ι
+    have : Module.Finite V.FunctionField W.FunctionField := hfin
+    change Algebra.IsSeparable V.FunctionField W.FunctionField
+    infer_instance
+  exact AlgebraicCurve.normFormulaAlong ι hfin hsep
+
+end Ws13B
+
+end
+
+open WeierstrassCurve WeierstrassCurve.Affine AlgebraicCurve in
+theorem solution
+    [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    (ht : Transcendental ℚ W.j) (n : ℕ) (Q Q' : W.toAffine.Point)
+    (hQ : addOrderOf Q = 2 * n + 1) (hQ' : addOrderOf Q' = 2 * n + 1)
+    (hΔ : (W.veluQuotient (W.oddOrderSummingSet Q n)).Δ ≠ 0)
+    (hΔ' : (W.veluQuotient (W.oddOrderSummingSet Q' n)).Δ ≠ 0)
+    (hj : haveI : (W.veluQuotient (W.oddOrderSummingSet Q n)).IsElliptic := ⟨isUnit_iff_ne_zero.mpr
+      hΔ⟩
+      haveI : (W.veluQuotient (W.oddOrderSummingSet Q' n)).IsElliptic := ⟨isUnit_iff_ne_zero.mpr
+        hΔ'⟩
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).j = (W.veluQuotient (W.oddOrderSummingSet Q'
+        n)).j) :
+    AddSubgroup.zmultiples Q = AddSubgroup.zmultiples Q' := by
+  have : CharZero (HahnSeries ℚ (AlgebraicClosure ℚ)) := Ws13B.charZero_hahn
+  have : IsAlgClosed (HahnSeries ℚ (AlgebraicClosure ℚ)) := HahnSeries.isAlgClosed_rat
+  have : IsDedekindDomain W.toAffine.CoordinateRing := CoordinateRing.isDedekindDomain W
+  have : HasPrincipalDivisors (HahnSeries ℚ (AlgebraicClosure ℚ)) W.toAffine.FunctionField :=
+    hasPrincipalDivisors_functionField W.toAffine
+  obtain ⟨g, hc, ha⟩ := exists_genusOnePlaceGate_isCentred_and_abelTheorem (W := W.toAffine)
+  let : GenusOnePlaceGate W.toAffine := g
+  have : GenusOnePlaceGate.IsCentred W.toAffine := hc
+  have : AbelTheorem W.toAffine := ha
+  have hNs : ∀ D : IsogenyEndDatum W.toAffine,
+      NormFormulaAlong (HahnSeries ℚ (AlgebraicClosure ℚ)) D.ι D.hfin :=
+    fun D => Ws13B.normFormulaAlong_of_elliptic D.ι D.hfin
+  have ht' : @Transcendental ℚ (HahnSeries ℚ (AlgebraicClosure ℚ)) _ _ DivisionRing.toRatAlgebra W.j
+    :=
+    by
+    convert ht using 2 ; exact Subsingleton.elim _ _
+  exact zmultiples_eq_of_veluQuotient_j_eq_of_forall_isogenyEndDatum_exists_int W hNs
+    (fun D => IsogenyEndDatum.exists_forall_pointEnd_eq_zsmul_of_transcendental_j W hNs ht' D)
+    n Q Q' hQ hQ' hΔ hΔ' hj
+
+end S_WeierstrassCurve_zmultiples_eq_of_veluQuotient_j_eq_of_transcendental
+end P2MW
+export P2MW.S_WeierstrassCurve_zmultiples_eq_of_veluQuotient_j_eq_of_transcendental (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine
+theorem WeierstrassCurve.zmultiples_eq_of_veluQuotient_j_eq_of_transcendental
+    [DecidableEq (HahnSeries ℚ (AlgebraicClosure ℚ))]
+    (W : WeierstrassCurve (HahnSeries ℚ (AlgebraicClosure ℚ))) [W.IsElliptic]
+    (ht : Transcendental ℚ W.j) (n : ℕ) (Q Q' : W.toAffine.Point)
+    (hQ : addOrderOf Q = 2 * n + 1) (hQ' : addOrderOf Q' = 2 * n + 1)
+    (hΔ : (W.veluQuotient (W.oddOrderSummingSet Q n)).Δ ≠ 0)
+    (hΔ' : (W.veluQuotient (W.oddOrderSummingSet Q' n)).Δ ≠ 0)
+    (hj : haveI : (W.veluQuotient (W.oddOrderSummingSet Q n)).IsElliptic := ⟨isUnit_iff_ne_zero.mpr
+      hΔ⟩
+      haveI : (W.veluQuotient (W.oddOrderSummingSet Q' n)).IsElliptic := ⟨isUnit_iff_ne_zero.mpr
+        hΔ'⟩
+      (W.veluQuotient (W.oddOrderSummingSet Q n)).j = (W.veluQuotient (W.oddOrderSummingSet Q'
+        n)).j) :
+    AddSubgroup.zmultiples Q = AddSubgroup.zmultiples Q' :=
+  solution W ht n Q Q' hQ hQ' hΔ hΔ' hj
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ZMod_natCard_isAddCyclic_addSubgroup_prod_eq_dedekindPsi.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ZMod_natCard_isAddCyclic_addSubgroup_prod_eq_dedekindPsi.lean
new file mode 100644
index 0000000000..2fc59218ad
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ZMod_natCard_isAddCyclic_addSubgroup_prod_eq_dedekindPsi.lean
@@ -0,0 +1,338 @@
+/-
+Based on Prove2Me node ZMod.natCard_isAddCyclic_addSubgroup_prod_eq_dedekindPsi
+(48c80f27-258e-54b9-b250-a51cc8c11c43) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 6a58e9d0-58e3-5950-b265-82c9acbf46b4
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import Mathlib.AlgebraicGeometry.EllipticCurve.Affine.Point
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_X0
+
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_card_projectiveLine_zmod
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Cyclic subgroups of order n in (ℤ/n)² number ψ(n)
+
+Theorem statement: `ZMod.natCard_isAddCyclic_addSubgroup_prod_eq_dedekindPsi`
+(`48c80f27-258e-54b9-b250-a51cc8c11c43`), by Claude, 2026-09-05.
+
+Proof: submission `6a58e9d0-58e3-5950-b265-82c9acbf46b4`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $n$ be a natural number, assumed nonzero. Consider the additive group $\mathbb{Z}/n \times
+\mathbb{Z}/n$ and the set of its additive subgroups $H$ that are cyclic as additive groups and
+satisfy $\mathrm{card}(H) = n$, this set being taken as the subtype of `AddSubgroup (ZMod n × ZMod
+n)` cut out by those two conditions. The theorem asserts that the cardinality of this set of
+subgroups equals [`ModularCurve.dedekindPsi n`](def/ModularCurve_X0.html#L201), which is defined in
+the project as the sum $\sum_{d \mid n,\ d \text{ squarefree}} n/d$ over the squarefree divisors $d$
+of $n$, the quotients being natural-number division. Thus $(\mathbb{Z}/n)^2$ has exactly $\psi(n)$
+cyclic subgroups of order $n$, where $\psi$ is the Dedekind psi function in the above divisor-sum
+form, agreeing with $n \prod_{p \mid n}(1 + 1/p)$. Cardinalities are taken as `Nat.card`, so the
+assertion includes implicitly that the set of such subgroups is finite, the value $\psi(n)$ being
+nonzero.
+
+Such subgroups are precisely the cyclic direct summands of rank one of $(\mathbb{Z}/n)^2$,
+equivalently the points of the projective line $\mathbb{P}^1(\mathbb{Z}/n)$, so the count is the
+number of $\Gamma_0(n)$-level structures on a pair of generators of $n$-torsion, i.e. the degree of
+$X_0(n) \to X(1)$. It is used in the project to transfer the count to torsion subgroups of abstract
+abelian groups isomorphic to $(\mathbb{Z}/n)^2$, and in the index estimates for $\Gamma_H$ inside
+$\Gamma_1$ and in the orbit counts at full level; the proof cites
+[`ModularCurve.card_projectiveLine_zmod`](thm.html#ModularCurve.card_projectiveLine_zmod), the
+computation $\#\mathbb{P}^1(\mathbb{Z}/n) = \psi(n)$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ZMod_natCard_isAddCyclic_addSubgroup_prod_eq_dedekindPsi.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_ZMod_natCard_isAddCyclic_addSubgroup_prod_eq_dedekindPsi
+
+noncomputable section
+
+namespace ModularCurve
+p2m_export "ModularCurve" "dedekindPsi IsUnimodularRow UnimodularRow ProjectiveLine \
+  card_projectiveLine_zmod"
+p2m_open "ModularCurve"
+
+open AddSubgroup
+
+section OrderUnimodular
+
+variable (N : ℕ)
+
+private theorem nsmul_pair (n : ℕ) (x : ZMod N × ZMod N) :
+    n • x = (n • x.1, n • x.2) :=
+  Prod.ext (map_nsmul (AddMonoidHom.fst (ZMod N) (ZMod N)) n x)
+    (map_nsmul (AddMonoidHom.snd (ZMod N) (ZMod N)) n x)
+
+private theorem zsmul_pair_fst (k : ℤ) (x : ZMod N × ZMod N) :
+    (k • x).1 = k • x.1 :=
+  map_zsmul (AddMonoidHom.fst (ZMod N) (ZMod N)) k x
+
+private theorem zsmul_pair_snd (k : ℤ) (x : ZMod N × ZMod N) :
+    (k • x).2 = k • x.2 :=
+  map_zsmul (AddMonoidHom.snd (ZMod N) (ZMod N)) k x
+
+private theorem nsmul_eq_zero_of_dvd_mul_val {m : ℕ} {z : ZMod N} [NeZero N]
+    (h : N ∣ m * z.val) : m • z = 0 :=
+  calc m • z = (m : ZMod N) * z := nsmul_eq_mul m z
+    _ = (m : ZMod N) * (z.val : ZMod N) := by rw [ZMod.natCast_zmod_val]
+    _ = ((m * z.val : ℕ) : ZMod N) := (Nat.cast_mul _ _).symm
+    _ = 0 := (ZMod.natCast_eq_zero_iff _ _).mpr h
+
+variable [NeZero N]
+
+namespace IsUnimodularRow
+p2m_export "ModularCurve.IsUnimodularRow" "map"
+end IsUnimodularRow
+p2m_open_scoped "ModularCurve.IsUnimodularRow" in
+omit [NeZero N] in
+theorem IsUnimodularRow.addOrderOf_eq {a c : ZMod N} (h : IsUnimodularRow a c) :
+    addOrderOf ((a, c) : ZMod N × ZMod N) = N := by
+  obtain ⟨x, y, hxy⟩ := h
+  have hdvdN : addOrderOf ((a, c) : ZMod N × ZMod N) ∣ N := by
+    refine addOrderOf_dvd_iff_nsmul_eq_zero.mpr ?_
+    rw [nsmul_pair]
+    have hza : N • a = 0 := by rw [nsmul_eq_mul, ZMod.natCast_self, zero_mul]
+    have hzc : N • c = 0 := by rw [nsmul_eq_mul, ZMod.natCast_self, zero_mul]
+    rw [hza, hzc]
+    rfl
+  have hN : N ∣ addOrderOf ((a, c) : ZMod N × ZMod N) := by
+    have hsmul : addOrderOf ((a, c) : ZMod N × ZMod N) • ((a, c) : ZMod N × ZMod N) = 0 :=
+      addOrderOf_nsmul_eq_zero _
+    rw [nsmul_pair] at hsmul
+    have ha : addOrderOf ((a, c) : ZMod N × ZMod N) • a = 0 := congrArg Prod.fst hsmul
+    have hc : addOrderOf ((a, c) : ZMod N × ZMod N) • c = 0 := congrArg Prod.snd hsmul
+    rw [nsmul_eq_mul] at ha hc
+    have hzero : ((addOrderOf ((a, c) : ZMod N × ZMod N) : ℕ) : ZMod N) = 0 := by
+      calc ((addOrderOf ((a, c) : ZMod N × ZMod N) : ℕ) : ZMod N)
+          = (addOrderOf ((a, c) : ZMod N × ZMod N) : ZMod N) * (x * a + y * c) := by
+            rw [hxy, mul_one]
+        _ = x * ((addOrderOf ((a, c) : ZMod N × ZMod N) : ZMod N) * a)
+              + y * ((addOrderOf ((a, c) : ZMod N × ZMod N) : ZMod N) * c) := by ring
+        _ = 0 := by rw [ha, hc, mul_zero, mul_zero, add_zero]
+    exact (ZMod.natCast_eq_zero_iff _ _).mp hzero
+  exact Nat.dvd_antisymm hdvdN hN
+
+theorem isUnimodularRow_of_addOrderOf_eq {a c : ZMod N}
+    (h : addOrderOf ((a, c) : ZMod N × ZMod N) = N) : IsUnimodularRow a c := by
+  have hN0 : N ≠ 0 := NeZero.ne N
+  set d : ℕ := Nat.gcd (Nat.gcd a.val c.val) N with hd
+  have hdN : d ∣ N := Nat.gcd_dvd_right _ _
+  have hdA : d ∣ a.val := dvd_trans (Nat.gcd_dvd_left _ _) (Nat.gcd_dvd_left _ _)
+  have hdC : d ∣ c.val := dvd_trans (Nat.gcd_dvd_left _ _) (Nat.gcd_dvd_right _ _)
+  have hd1 : d = 1 := by
+    have hkill : (N / d) • ((a, c) : ZMod N × ZMod N) = 0 := by
+      rw [nsmul_pair]
+      have hka : (N / d) • a = 0 := by
+        refine nsmul_eq_zero_of_dvd_mul_val N ?_
+        obtain ⟨A', hA'⟩ := hdA
+        exact ⟨A', by rw [hA', ← mul_assoc, Nat.div_mul_cancel hdN]⟩
+      have hkc : (N / d) • c = 0 := by
+        refine nsmul_eq_zero_of_dvd_mul_val N ?_
+        obtain ⟨C', hC'⟩ := hdC
+        exact ⟨C', by rw [hC', ← mul_assoc, Nat.div_mul_cancel hdN]⟩
+      rw [hka, hkc]
+      rfl
+    have horder : addOrderOf ((a, c) : ZMod N × ZMod N) ∣ N / d :=
+      addOrderOf_dvd_iff_nsmul_eq_zero.mpr hkill
+    rw [h] at horder
+    have hdivdvd : N / d ∣ N := Nat.div_dvd_of_dvd hdN
+    have hNd : N / d = N := Nat.dvd_antisymm hdivdvd horder
+    have hmul : d * (N / d) = N := Nat.mul_div_cancel' hdN
+    rw [hNd] at hmul
+    exact Nat.eq_of_mul_eq_mul_right (Nat.pos_of_ne_zero hN0) (hmul.trans (one_mul N).symm)
+  have hcop : Nat.Coprime (Nat.gcd a.val c.val) N := hd1
+  have hunit : IsUnit ((Nat.gcd a.val c.val : ℕ) : ZMod N) :=
+    (ZMod.isUnit_iff_coprime _ N).mpr hcop
+  obtain ⟨u, hu⟩ := hunit
+  have hbez := Nat.gcd_eq_gcd_ab a.val c.val
+  have hcast : ((Nat.gcd a.val c.val : ℕ) : ZMod N)
+      = a * ((Nat.gcdA a.val c.val : ℤ) : ZMod N) + c * ((Nat.gcdB a.val c.val : ℤ) : ZMod N) := by
+    have hℤ := congrArg (fun z : ℤ => (Int.castRingHom (ZMod N)) z) hbez
+    simp only [map_add, map_mul, Int.coe_castRingHom] at hℤ
+    rw [Int.cast_natCast, Int.cast_natCast, Int.cast_natCast, ZMod.natCast_zmod_val,
+      ZMod.natCast_zmod_val] at hℤ
+    exact hℤ
+  refine ⟨((Nat.gcdA a.val c.val : ℤ) : ZMod N) * (↑u⁻¹ : ZMod N),
+    ((Nat.gcdB a.val c.val : ℤ) : ZMod N) * (↑u⁻¹ : ZMod N), ?_⟩
+  calc ((Nat.gcdA a.val c.val : ℤ) : ZMod N) * (↑u⁻¹ : ZMod N) * a
+        + ((Nat.gcdB a.val c.val : ℤ) : ZMod N) * (↑u⁻¹ : ZMod N) * c
+      = (a * ((Nat.gcdA a.val c.val : ℤ) : ZMod N)
+          + c * ((Nat.gcdB a.val c.val : ℤ) : ZMod N)) * (↑u⁻¹ : ZMod N) := by ring
+    _ = ((Nat.gcd a.val c.val : ℕ) : ZMod N) * (↑u⁻¹ : ZMod N) := by rw [← hcast]
+    _ = (↑u : ZMod N) * (↑u⁻¹ : ZMod N) := by rw [hu]
+    _ = 1 := u.mul_inv
+
+end OrderUnimodular
+
+section Scaling
+
+variable (N : ℕ) [NeZero N]
+
+theorem zmultiples_unit_mul (u : (ZMod N)ˣ) (x : ZMod N × ZMod N) :
+    AddSubgroup.zmultiples ((((u : ZMod N) * x.1, (u : ZMod N) * x.2)) : ZMod N × ZMod N)
+      = AddSubgroup.zmultiples x := by
+  have key : ∀ (w : (ZMod N)ˣ) (y : ZMod N × ZMod N),
+      (((w : ZMod N) * y.1, (w : ZMod N) * y.2) : ZMod N × ZMod N) ∈ AddSubgroup.zmultiples y := by
+    intro w y
+    refine AddSubgroup.mem_zmultiples_iff.mpr ⟨((w : ZMod N).val : ℤ), ?_⟩
+    refine Prod.ext ?_ ?_
+    · change ((((w : ZMod N).val : ℤ)) • y).1 = (w : ZMod N) * y.1
+      rw [zsmul_pair_fst, zsmul_eq_mul, Int.cast_natCast, ZMod.natCast_zmod_val]
+    · change ((((w : ZMod N).val : ℤ)) • y).2 = (w : ZMod N) * y.2
+      rw [zsmul_pair_snd, zsmul_eq_mul, Int.cast_natCast, ZMod.natCast_zmod_val]
+  refine le_antisymm (AddSubgroup.zmultiples_le.mpr (key u x)) (AddSubgroup.zmultiples_le.mpr ?_)
+  have hmem := key u⁻¹ (((u : ZMod N) * x.1, (u : ZMod N) * x.2) : ZMod N × ZMod N)
+  have hx : ((((u⁻¹ : (ZMod N)ˣ) : ZMod N) * (((u : ZMod N) * x.1, (u : ZMod N) * x.2) : ZMod N ×
+    ZMod N).1,
+      ((u⁻¹ : (ZMod N)ˣ) : ZMod N) * (((u : ZMod N) * x.1, (u : ZMod N) * x.2) : ZMod N × ZMod N).2)
+        : ZMod N × ZMod N) = x := by
+    have h1 : ((u⁻¹ : (ZMod N)ˣ) : ZMod N) * ((u : ZMod N) * x.1) = x.1 := by
+      rw [← mul_assoc, u.inv_mul, one_mul]
+    have h2 : ((u⁻¹ : (ZMod N)ˣ) : ZMod N) * ((u : ZMod N) * x.2) = x.2 := by
+      rw [← mul_assoc, u.inv_mul, one_mul]
+    exact Prod.ext h1 h2
+  rwa [hx] at hmem
+
+omit [NeZero N] in
+theorem eq_of_mul_unimodularRow_eq {a c : ZMod N} (h : IsUnimodularRow a c) {r s : ZMod N}
+    (h1 : r * a = s * a) (h2 : r * c = s * c) : r = s := by
+  obtain ⟨x, y, hxy⟩ := h
+  calc r = r * (x * a + y * c) := by rw [hxy, mul_one]
+    _ = x * (r * a) + y * (r * c) := by ring
+    _ = x * (s * a) + y * (s * c) := by rw [h1, h2]
+    _ = s * (x * a + y * c) := by ring
+    _ = s := by rw [hxy, mul_one]
+
+end Scaling
+
+section Bijection
+
+variable (N : ℕ) [NeZero N]
+
+def unimodularRowToCyclicAddSubgroup (v : UnimodularRow (ZMod N)) :
+    {H : AddSubgroup (ZMod N × ZMod N) // IsAddCyclic H ∧ Nat.card H = N} :=
+  ⟨AddSubgroup.zmultiples v.1,
+    (AddSubgroup.isAddCyclic_iff_exists_zmultiples_eq_top _).mpr ⟨v.1, rfl⟩,
+    by rw [Nat.card_zmultiples, IsUnimodularRow.addOrderOf_eq N v.2]⟩
+
+def projectiveLineToCyclicAddSubgroup :
+    ProjectiveLine (ZMod N) → {H : AddSubgroup (ZMod N × ZMod N) // IsAddCyclic H ∧ Nat.card H = N}
+      :=
+  Quotient.lift (unimodularRowToCyclicAddSubgroup N) <| by
+    rintro v w ⟨u, h1, h2⟩
+    refine Subtype.ext ?_
+    change AddSubgroup.zmultiples v.1 = AddSubgroup.zmultiples w.1
+    have hw : w.1 = (((u : ZMod N) * v.1.1, (u : ZMod N) * v.1.2) : ZMod N × ZMod N) := by
+      rw [h1, h2]
+    rw [hw, zmultiples_unit_mul]
+
+theorem projectiveLineToCyclicAddSubgroup_injective :
+    Function.Injective (projectiveLineToCyclicAddSubgroup N) := by
+  intro q₁ q₂
+  refine Quotient.inductionOn₂ q₁ q₂ ?_
+  intro v w hvw
+  have hsub : AddSubgroup.zmultiples v.1 = AddSubgroup.zmultiples w.1 :=
+    congrArg Subtype.val hvw
+  obtain ⟨k, hk⟩ := AddSubgroup.mem_zmultiples_iff.mp
+    (hsub ▸ AddSubgroup.mem_zmultiples w.1)
+  obtain ⟨m, hm⟩ := AddSubgroup.mem_zmultiples_iff.mp
+    (hsub.symm ▸ AddSubgroup.mem_zmultiples v.1)
+  have hk1 : ((k : ZMod N)) * v.1.1 = w.1.1 := by
+    have h := congrArg Prod.fst hk; rwa [zsmul_pair_fst, zsmul_eq_mul] at h
+  have hk2 : ((k : ZMod N)) * v.1.2 = w.1.2 := by
+    have h := congrArg Prod.snd hk; rwa [zsmul_pair_snd, zsmul_eq_mul] at h
+  have hm1 : ((m : ZMod N)) * w.1.1 = v.1.1 := by
+    have h := congrArg Prod.fst hm; rwa [zsmul_pair_fst, zsmul_eq_mul] at h
+  have hm2 : ((m : ZMod N)) * w.1.2 = v.1.2 := by
+    have h := congrArg Prod.snd hm; rwa [zsmul_pair_snd, zsmul_eq_mul] at h
+  have hmk : ((m : ZMod N)) * ((k : ZMod N)) = 1 := by
+    refine eq_of_mul_unimodularRow_eq N v.2 ?_ ?_
+    · rw [mul_assoc, hk1, hm1, one_mul]
+    · rw [mul_assoc, hk2, hm2, one_mul]
+  refine Quotient.sound ⟨⟨(k : ZMod N), (m : ZMod N), by rw [mul_comm]; exact hmk, hmk⟩, ?_, ?_⟩
+  · exact hk1
+  · exact hk2
+
+theorem projectiveLineToCyclicAddSubgroup_surjective :
+    Function.Surjective (projectiveLineToCyclicAddSubgroup N) := by
+  rintro ⟨H, hcyc, hcard⟩
+  obtain ⟨g, hg⟩ := (AddSubgroup.isAddCyclic_iff_exists_zmultiples_eq_top H).mp hcyc
+  have horder : addOrderOf g = N := by
+    have := Nat.card_zmultiples g
+    rw [hg, hcard] at this
+    exact this.symm
+  have hrow : IsUnimodularRow g.1 g.2 := by
+    refine isUnimodularRow_of_addOrderOf_eq N ?_
+    have hg' : ((g.1, g.2) : ZMod N × ZMod N) = g := rfl
+    rw [hg', horder]
+  refine ⟨⟦⟨(g.1, g.2), hrow⟩⟧, ?_⟩
+  refine Subtype.ext ?_
+  change AddSubgroup.zmultiples ((g.1, g.2) : ZMod N × ZMod N) = H
+  have hg' : ((g.1, g.2) : ZMod N × ZMod N) = g := rfl
+  rw [hg', hg]
+
+def projectiveLineEquivCyclicAddSubgroup :
+    ProjectiveLine (ZMod N) ≃ {H : AddSubgroup (ZMod N × ZMod N) // IsAddCyclic H ∧ Nat.card H = N}
+      :=
+  Equiv.ofBijective (projectiveLineToCyclicAddSubgroup N)
+    ⟨projectiveLineToCyclicAddSubgroup_injective N, projectiveLineToCyclicAddSubgroup_surjective N⟩
+
+end Bijection
+
+section Headline
+
+variable (N : ℕ) [NeZero N]
+
+theorem card_cyclicAddSubgroup_eq_card_projectiveLine :
+    Nat.card {H : AddSubgroup (ZMod N × ZMod N) // IsAddCyclic H ∧ Nat.card H = N}
+      = Nat.card (ProjectiveLine (ZMod N)) :=
+  (Nat.card_congr (projectiveLineEquivCyclicAddSubgroup N)).symm
+
+theorem card_cyclicAddSubgroup_eq_dedekindPsi :
+    Nat.card {H : AddSubgroup (ZMod N × ZMod N) // IsAddCyclic H ∧ Nat.card H = N}
+      = dedekindPsi N := by
+  rw [card_cyclicAddSubgroup_eq_card_projectiveLine,
+    card_projectiveLine_zmod N (NeZero.ne N)]
+
+end Headline
+
+end ModularCurve
+end
+
+theorem solution (n : ℕ) [NeZero n] :
+    Nat.card {H : AddSubgroup (ZMod n × ZMod n) // IsAddCyclic H ∧ Nat.card H = n} =
+      ModularCurve.dedekindPsi n :=
+  ModularCurve.card_cyclicAddSubgroup_eq_dedekindPsi n
+
+end S_ZMod_natCard_isAddCyclic_addSubgroup_prod_eq_dedekindPsi
+end P2MW
+export P2MW.S_ZMod_natCard_isAddCyclic_addSubgroup_prod_eq_dedekindPsi (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open WeierstrassCurve WeierstrassCurve.Affine WeierstrassCurve.Affine.Point
+theorem ZMod.natCard_isAddCyclic_addSubgroup_prod_eq_dedekindPsi (n : ℕ) [NeZero n] :
+    Nat.card {H : AddSubgroup (ZMod n × ZMod n) // IsAddCyclic H ∧ Nat.card H = n} =
+      ModularCurve.dedekindPsi n :=
+  solution n
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ZMod_natCard_isAddCyclic_addSubgroup_prod_map_eq_nuThree.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ZMod_natCard_isAddCyclic_addSubgroup_prod_map_eq_nuThree.lean
new file mode 100644
index 0000000000..bac540f7f5
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ZMod_natCard_isAddCyclic_addSubgroup_prod_map_eq_nuThree.lean
@@ -0,0 +1,431 @@
+/-
+Based on Prove2Me node ZMod.natCard_isAddCyclic_addSubgroup_prod_map_eq_nuThree
+(f3d63b61-cb3f-5ce5-b3d1-3b34b87bcfc5) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 859540fe-e0e4-57f7-abac-1d49bec1e8cf
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.ConditionallyCompleteOrder
+import Mathlib.Data.Int.Star
+import Mathlib.Order.CompletePartialOrder
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Counting τ-stable cyclic subgroups of order n in (ℤ/n)²
+
+Theorem statement: `ZMod.natCard_isAddCyclic_addSubgroup_prod_map_eq_nuThree`
+(`f3d63b61-cb3f-5ce5-b3d1-3b34b87bcfc5`), by Claude, 2026-09-05.
+
+Proof: submission `859540fe-e0e4-57f7-abac-1d49bec1e8cf`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $n$ be a natural number, nonzero, and let $\tau$ be an additive endomorphism of
+$(\mathbb{Z}/n\mathbb{Z}) \times (\mathbb{Z}/n\mathbb{Z})$ satisfying $\tau(\tau v) + \tau v + v =
+0$ for every $v$, that is, $\tau^2 + \tau + 1 = 0$ as an endomorphism. Assume further that for every
+prime $p$ dividing $n$ there is an element $v$ of $(\mathbb{Z}/n\mathbb{Z})^2$ of additive order
+exactly $p$ such that $\tau v \neq k \cdot v$ for every natural number $k$; thus $\tau$ acts
+non-scalarly on the $p$-torsion for each prime divisor $p$ of $n$. The conclusion is an equality of
+cardinalities: the number of additive subgroups $H$ of $(\mathbb{Z}/n\mathbb{Z})^2$ that are cyclic,
+have cardinality $n$, and satisfy $H.\mathrm{map}\,\tau = H$ (the image of $H$ under $\tau$ is $H$
+itself), equals $\nu_3(n)$, which by definition is the number of elements $x$ of
+$\mathbb{Z}/n\mathbb{Z}$ with $x^2 + x + 1 = 0$.
+
+This is the arithmetic core of the count of elliptic points of order three (those lying above $j =
+0$) on the modular curve $Y_0(N)$: cyclic subgroups of order $N$ stable under an automorphism of
+order three of the underlying group of torsion points correspond to roots of $x^2+x+1$ modulo $N$.
+It is used by the transport of the same count to an abstract abelian group whose $n$-torsion is
+$(\mathbb{Z}/n)^2$, and by the formulae counting orbits of the subgroups generated by $S$ and by
+$ST$ acting on the $\Gamma_0$-coset space.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ZMod_natCard_isAddCyclic_addSubgroup_prod_map_eq_nuThree.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_ZMod_natCard_isAddCyclic_addSubgroup_prod_map_eq_nuThree
+
+open ModularCurve
+
+namespace L3zCore
+
+variable {n : ℕ} [NeZero n]
+
+omit [NeZero n] in
+theorem nsmul_self_eq_zero (v : (ZMod n × ZMod n)) : n • v = 0 := by
+  ext <;> simp [nsmul_eq_mul]
+
+theorem map_zmod_smul (τ : (ZMod n × ZMod n) →+ (ZMod n × ZMod n)) (c : ZMod n)
+    (v : (ZMod n × ZMod n)) :
+    τ (c • v) = c • τ v := by
+  rw [← ZMod.natCast_zmod_val c, Nat.cast_smul_eq_nsmul, Nat.cast_smul_eq_nsmul, map_nsmul]
+
+theorem eq_zero_of_smul_eq_zero {v : (ZMod n × ZMod n)} (hv : addOrderOf v = n) {c : ZMod n}
+    (hc : c • v = 0) :
+    c = 0 := by
+  rw [← ZMod.natCast_zmod_val c, Nat.cast_smul_eq_nsmul] at hc
+  have hdvd : addOrderOf v ∣ c.val := addOrderOf_dvd_of_nsmul_eq_zero hc
+  rw [hv] at hdvd
+  have hval : c.val = 0 := Nat.eq_zero_of_dvd_of_lt hdvd (ZMod.val_lt c)
+  exact (ZMod.val_eq_zero c).mp hval
+
+def eig (τ : (ZMod n × ZMod n) →+ (ZMod n × ZMod n)) (k : ZMod n) :
+    AddSubgroup (ZMod n × ZMod n) where
+  carrier := {v | τ v = k • v}
+  zero_mem' := by simp only [Set.mem_ofPred_eq, map_zero, smul_zero]
+  add_mem' ha hb := by
+    simp only [Set.mem_ofPred_eq] at ha hb ⊢; rw [map_add, ha, hb, smul_add]
+  neg_mem' ha := by
+    simp only [Set.mem_ofPred_eq] at ha ⊢; rw [map_neg, ha, smul_neg]
+
+omit [NeZero n] in
+theorem mem_eig (τ : (ZMod n × ZMod n) →+ (ZMod n × ZMod n)) (k : ZMod n) (v : (ZMod n × ZMod n)) :
+    v ∈ eig τ k ↔ τ v = k • v := Iff.rfl
+
+def shift (τ : (ZMod n × ZMod n) →+ (ZMod n × ZMod n)) (k : ZMod n) :
+    (ZMod n × ZMod n) →+ (ZMod n × ZMod n) where
+  toFun v := τ v - k • v
+  map_zero' := by simp only [map_zero, smul_zero, sub_zero]
+  map_add' v w := by simp only [map_add, smul_add]; abel
+
+omit [NeZero n] in
+theorem shift_apply (τ : (ZMod n × ZMod n) →+ (ZMod n × ZMod n)) (k : ZMod n)
+    (v : (ZMod n × ZMod n)) :
+    shift τ k v = τ v - k • v := rfl
+
+omit [NeZero n] in
+theorem ker_shift (τ : (ZMod n × ZMod n) →+ (ZMod n × ZMod n)) (k : ZMod n) :
+    (shift τ k).ker = eig τ k := by
+  ext v
+  rw [AddMonoidHom.mem_ker, shift_apply, sub_eq_zero, mem_eig]
+
+section Quadratic
+
+variable (τ : (ZMod n × ZMod n) →+ (ZMod n × ZMod n)) (s : ZMod n) (hτ : ∀ v, τ (τ v) = s • τ v - v)
+include hτ
+
+omit [NeZero n] in
+theorem τ_injective : Function.Injective τ := fun a b h => by
+  have ha : a = s • τ a - τ (τ a) := by rw [hτ]; abel
+  have hb : b = s • τ b - τ (τ b) := by rw [hτ]; abel
+  rw [ha, hb, h]
+
+theorem root_of_eigen {v : (ZMod n × ZMod n)} (hv : addOrderOf v = n) {k : ZMod n}
+    (hk : τ v = k • v) :
+    k * k = s * k - 1 := by
+  have h1 : τ (τ v) = (k * k) • v := by rw [hk, map_zmod_smul, hk, smul_smul]
+  have h2 : τ (τ v) = (s * k - 1) • v := by rw [hτ, hk, smul_smul, sub_smul, one_smul]
+  have h3 : (k * k - (s * k - 1)) • v = 0 := by rw [sub_smul, ← h1, ← h2, sub_self]
+  exact sub_eq_zero.mp (eq_zero_of_smul_eq_zero hv h3)
+
+theorem range_shift_le {k : ZMod n} (hk : k * k = s * k - 1) :
+    (shift τ k).range ≤ eig τ (s - k) := by
+  rintro w ⟨v, rfl⟩
+  rw [mem_eig, shift_apply, map_sub, map_zmod_smul, hτ, smul_sub, smul_smul,
+    show (s - k) * k = 1 by rw [sub_mul, hk]; ring, one_smul, sub_smul]
+  abel
+
+theorem sq_le_card_mul_card {k : ZMod n} (hk : k * k = s * k - 1) :
+    n ^ 2 ≤ Nat.card (eig τ k) * Nat.card (eig τ (s - k)) := by
+  have hN2 : Nat.card (ZMod n × ZMod n) = n ^ 2 := by rw [Nat.card_prod, Nat.card_zmod, sq]
+  have hfirst : Nat.card (ZMod n × ZMod n) = Nat.card (shift τ k).ker * Nat.card (shift τ k).range
+    :=
+    by
+    rw [mul_comm, ← Nat.card_congr (QuotientAddGroup.quotientKerEquivRange (shift τ k)).toEquiv,
+      ← AddSubgroup.card_eq_card_quotient_mul_card_addSubgroup]
+  rw [← hN2, hfirst, ker_shift]
+  exact Nat.mul_le_mul_left _ (Nat.card_le_card_of_injective
+    (AddSubgroup.inclusion (range_shift_le τ s hτ hk)) (AddSubgroup.inclusion_injective _))
+
+theorem map_eig_eq (k : ZMod n) : (eig τ k).map τ = eig τ k := by
+  have : Finite (eig τ k) := inferInstance
+  have hle : (eig τ k).map τ ≤ eig τ k := by
+    rintro _ ⟨v, hv, rfl⟩
+    rw [SetLike.mem_coe, mem_eig] at hv
+    rw [mem_eig, hv, map_zmod_smul, hv]
+  exact AddSubgroup.eq_of_le_of_card_ge hle
+    (Nat.card_congr ((eig τ k).equivMapOfInjective τ (τ_injective τ s hτ)).toEquiv).le
+
+end Quadratic
+
+omit [NeZero n] in
+theorem card_pTorsion_le {p : ℕ} (hp : p.Prime) :
+    Nat.card {v : (ZMod n × ZMod n) // p • v = 0} ≤ p ^ 2 := by
+  have key : Nat.card {x : ZMod n // p • x = 0} ≤ p := by
+    let S : AddSubgroup (ZMod n) :=
+      { carrier := {x | p • x = 0}, zero_mem' := by simp,
+        add_mem' := fun {a b} ha hb =>
+          show p • (a + b) = 0 by rw [nsmul_add, ha, hb, add_zero],
+        neg_mem' := fun {a} ha =>
+          show p • (-a) = 0 by rw [smul_neg, ha, neg_zero] }
+    have : IsAddCyclic S := AddSubgroup.isAddCyclic S
+    have hexp : AddMonoid.exponent S ∣ p :=
+      AddMonoid.exponent_dvd_of_forall_nsmul_eq_zero (fun g => Subtype.ext g.2)
+    calc Nat.card {x : ZMod n // p • x = 0} = Nat.card S := rfl
+      _ = AddMonoid.exponent S := IsAddCyclic.exponent_eq_card.symm
+      _ ≤ p := Nat.le_of_dvd hp.pos hexp
+  have e : {v : (ZMod n × ZMod n) // p • v = 0} ≃ {x : ZMod n // p • x = 0} × {y : ZMod n // p • y =
+    0} :=
+    by
+    refine ⟨fun v => (⟨v.1.1, (Prod.mk_inj.mp v.2).1⟩, ⟨v.1.2, (Prod.mk_inj.mp v.2).2⟩),
+      fun z => ⟨(z.1.1, z.2.1), Prod.ext z.1.2 z.2.2⟩, ?_, ?_⟩
+    · intro v; exact Subtype.ext rfl
+    · intro z; exact Prod.ext (Subtype.ext rfl) (Subtype.ext rfl)
+  rw [Nat.card_congr e, Nat.card_prod, sq]
+  exact Nat.mul_le_mul key key
+
+theorem isAddCyclic_of_card_pTorsion_le {G : Type*} [AddCommGroup G]
+    [Finite G] (h : ∀ p : ℕ, p.Prime → Nat.card {g : G // p • g = 0} ≤ p) :
+    IsAddCyclic G := by
+  classical
+  obtain ⟨_⟩ := nonempty_fintype G
+  let T : ℕ → AddSubgroup G := fun m =>
+    { carrier := {g | m • g = 0}
+      zero_mem' := by simp
+      add_mem' := fun {a b} ha hb =>
+        show m • (a + b) = 0 by rw [nsmul_add, ha, hb, add_zero]
+      neg_mem' := fun {a} ha =>
+        show m • (-a) = 0 by rw [smul_neg, ha, neg_zero] }
+  have hTcard : ∀ m, Nat.card (T m) = Nat.card {g : G // m • g = 0} := fun m => rfl
+  suffices hbound : ∀ m : ℕ, 0 < m → Nat.card (T m) ≤ m by
+    refine isAddCyclic_of_card_nsmul_eq_zero_le (fun m hm => ?_)
+    have hfs : (Finset.univ.filter (fun a : G => m • a = 0)).card
+        = Fintype.card {g : G // m • g = 0} := (Fintype.card_subtype _).symm
+    calc (Finset.univ.filter (fun a : G => m • a = 0)).card
+        = Nat.card (T m) := hfs.trans (Nat.card_eq_fintype_card (α := T m)).symm
+      _ ≤ m := hbound m hm
+  intro m hm
+  induction m using Nat.strong_induction_on with
+  | _ m ih =>
+  rcases eq_or_ne m 1 with rfl | hm1
+  · have h1 : T 1 = ⊥ := by
+      refine le_antisymm (fun g hg => ?_) bot_le
+      exact AddSubgroup.mem_bot.mpr (one_nsmul g ▸ hg)
+    rw [h1, AddSubgroup.card_bot]
+  · obtain ⟨p, hp, hpm⟩ := Nat.exists_prime_and_dvd hm1
+    have hmp : 0 < m / p := Nat.div_pos (Nat.le_of_dvd hm hpm) hp.pos
+    have hmpm : m / p < m := Nat.div_lt_self hm hp.one_lt
+    let φ : T m →+ T p :=
+      { toFun := fun g => ⟨(m/p) • g.1, by
+          change p • ((m/p) • g.1) = 0
+          rw [← mul_nsmul', Nat.mul_div_cancel' hpm]; exact g.2⟩
+        map_zero' := Subtype.ext (by simp)
+        map_add' := fun a b => Subtype.ext (by simp) }
+    have hkerφ : Nat.card φ.ker ≤ m / p := by
+      have hψ : ∀ g : φ.ker, (m/p) • (g.1.1 : G) = 0 := fun g =>
+        congrArg Subtype.val (φ.mem_ker.mp g.2)
+      let ψ : φ.ker → T (m/p) := fun g => ⟨g.1.1, hψ g⟩
+      have hψinj : Function.Injective ψ := fun a b hab => by
+        have hv : (a.1.1 : G) = b.1.1 := congrArg (fun x : T (m/p) => (x : G)) hab
+        exact Subtype.ext (Subtype.ext hv)
+      exact le_trans (Nat.card_le_card_of_injective ψ hψinj) (ih (m/p) hmpm hmp)
+    have himφ : Nat.card φ.range ≤ p :=
+      le_trans (Nat.card_le_card_of_injective (AddSubgroup.subtype φ.range)
+        (AddSubgroup.subtype_injective _)) ((hTcard p).symm ▸ h p hp)
+    calc Nat.card (T m)
+        = Nat.card φ.ker * Nat.card φ.range := by
+          rw [mul_comm, ← Nat.card_congr (QuotientAddGroup.quotientKerEquivRange φ).toEquiv,
+            ← AddSubgroup.card_eq_card_quotient_mul_card_addSubgroup]
+      _ ≤ (m/p) * p := Nat.mul_le_mul hkerφ himφ
+      _ = m := Nat.div_mul_cancel hpm
+
+theorem card_eig_pTorsion_le (τ : (ZMod n × ZMod n) →+ (ZMod n × ZMod n)) (k : ZMod n) {p : ℕ}
+    (hp : p.Prime)
+    (hns : ∃ v : (ZMod n × ZMod n), addOrderOf v = p ∧ ∀ m : ℕ, τ v ≠ m • v) :
+    Nat.card {g : eig τ k // p • g = 0} ≤ p := by
+  have : Fact p.Prime := ⟨hp⟩
+  obtain ⟨v₀, hv₀, hv₀ns⟩ := hns
+  have hv₀K : v₀ ∉ eig τ k := fun h => hv₀ns k.val (by
+    rw [mem_eig] at h; rw [h, ← Nat.cast_smul_eq_nsmul (ZMod n), ZMod.natCast_zmod_val])
+  let Z : AddSubgroup (ZMod n × ZMod n) := AddSubgroup.zmultiples v₀
+  have hZcard : Nat.card Z = p := by rw [Nat.card_zmultiples, hv₀]
+  have : Finite Z := Nat.finite_of_card_ne_zero (by rw [hZcard]; exact hp.ne_zero)
+  let Kp : AddSubgroup (ZMod n × ZMod n) :=
+    { carrier := {v | τ v = k • v ∧ p • v = 0}
+      zero_mem' := by simp only [Set.mem_ofPred_eq, map_zero, smul_zero, and_self]
+      add_mem' := fun {a b} ha hb => by
+        simp only [Set.mem_ofPred_eq] at ha hb ⊢
+        rw [map_add, ha.1, hb.1, smul_add, nsmul_add, ha.2, hb.2, add_zero]; exact ⟨rfl, rfl⟩
+      neg_mem' := fun {a} ha => by
+        simp only [Set.mem_ofPred_eq] at ha ⊢
+        rw [map_neg, ha.1, smul_neg, smul_neg, ha.2, neg_zero]; exact ⟨rfl, rfl⟩ }
+  have hKp : Nat.card {g : eig τ k // p • g = 0} = Nat.card Kp := by
+    refine Nat.card_congr ⟨fun g => ⟨g.1.1, g.1.2, ?_⟩, fun v => ⟨⟨v.1, v.2.1⟩, ?_⟩, ?_, ?_⟩
+    · exact congrArg Subtype.val g.2
+    · exact Subtype.ext v.2.2
+    · intro g; rfl
+    · intro v; rfl
+  have hdisj : ∀ x, x ∈ Kp → x ∈ Z → x = 0 := by
+    intro x hxK hxZ
+    by_contra hx0
+    have hpx : p • x = 0 := hxK.2
+    have hordx : addOrderOf x = p :=
+      (hp.eq_one_or_self_of_dvd _ (addOrderOf_dvd_of_nsmul_eq_zero hpx)).resolve_left
+        (fun h1 => hx0 (AddMonoid.addOrderOf_eq_one_iff.mp h1))
+    have hle : AddSubgroup.zmultiples x ≤ Z := AddSubgroup.zmultiples_le_of_mem hxZ
+    have heq : AddSubgroup.zmultiples x = Z :=
+      AddSubgroup.eq_of_le_of_card_ge hle (by rw [hZcard, Nat.card_zmultiples, hordx])
+    have hv₀x : v₀ ∈ AddSubgroup.zmultiples x := by rw [heq]; exact AddSubgroup.mem_zmultiples v₀
+    have hxk : AddSubgroup.zmultiples x ≤ eig τ k := AddSubgroup.zmultiples_le_of_mem hxK.1
+    exact hv₀K (hxk hv₀x)
+  let f : Kp × Z → {v : (ZMod n × ZMod n) // p • v = 0} := fun gz => ⟨gz.1.1 + gz.2.1, by
+    obtain ⟨⟨g, hg⟩, ⟨z, hz⟩⟩ := gz
+    obtain ⟨a, rfl⟩ := AddSubgroup.mem_zmultiples_iff.mp hz
+    change p • (g + a • v₀) = 0
+    rw [nsmul_add, hg.2, zero_add, smul_comm, ← hv₀, addOrderOf_nsmul_eq_zero, smul_zero]⟩
+  have hf : Function.Injective f := by
+    rintro ⟨⟨g, hg⟩, ⟨z, hz⟩⟩ ⟨⟨g', hg'⟩, ⟨z', hz'⟩⟩ h
+    have h' : g + z = g' + z' := congrArg Subtype.val h
+    have hd : g - g' = z' - z := sub_eq_sub_iff_add_eq_add.mpr (by rw [h', add_comm])
+    have h0 : g - g' = 0 := hdisj _ (Kp.sub_mem hg hg') (hd ▸ Z.sub_mem hz' hz)
+    have hg0 : g = g' := sub_eq_zero.mp h0
+    have hz0 : z = z' := by rw [hg0] at h'; exact add_left_cancel h'
+    subst hg0 hz0; rfl
+  have hle := Nat.card_le_card_of_injective f hf
+  rw [Nat.card_prod, hZcard] at hle
+  have hle2 := le_trans hle (card_pTorsion_le hp)
+  rw [sq] at hle2
+  rw [hKp]
+  exact Nat.le_of_mul_le_mul_right hle2 hp.pos
+
+section Count
+
+variable (τ : (ZMod n × ZMod n) →+ (ZMod n × ZMod n)) (s : ZMod n) (hτ : ∀ v, τ (τ v) = s • τ v - v)
+  (hns : ∀ p : ℕ, p.Prime → p ∣ n → ∃ v : (ZMod n × ZMod n), addOrderOf v = p ∧ ∀ m : ℕ, τ v ≠ m •
+    v)
+include hτ hns
+
+omit hτ in
+theorem eig_cyclic_card_le (k : ZMod n) : IsAddCyclic (eig τ k) ∧ Nat.card (eig τ k) ≤ n := by
+  have step1 : ∀ p : ℕ, p.Prime → Nat.card {g : eig τ k // p • g = 0} ≤ p := by
+    intro p hp
+    by_cases hpn : p ∣ n
+    · exact card_eig_pTorsion_le τ k hp (hns p hp hpn)
+    · have hpn' : ∀ g : eig τ k, p • g = 0 → g = 0 := by
+        intro g hg
+        have hg' : p • (g : (ZMod n × ZMod n)) = 0 := congrArg Subtype.val hg
+        have hgord : addOrderOf (g : (ZMod n × ZMod n)) ∣ Nat.gcd p n :=
+          Nat.dvd_gcd (addOrderOf_dvd_of_nsmul_eq_zero hg')
+            (addOrderOf_dvd_of_nsmul_eq_zero (nsmul_self_eq_zero (g : (ZMod n × ZMod n))))
+        rw [(hp.coprime_iff_not_dvd.mpr hpn), Nat.dvd_one] at hgord
+        refine Subtype.ext ?_
+        have : (1:ℕ) • (g : (ZMod n × ZMod n)) = 0 := hgord ▸ addOrderOf_nsmul_eq_zero _
+        simpa using this
+      have hsub : Subsingleton {g : eig τ k // p • g = 0} :=
+        ⟨fun a b => Subtype.ext ((hpn' a.1 a.2).trans (hpn' b.1 b.2).symm)⟩
+      have hc1 : Nat.card {g : eig τ k // p • g = 0} = 1 :=
+        Nat.card_of_subsingleton (⟨0, by simp only [nsmul_zero]⟩ : {g : eig τ k // p • g = 0})
+      exact hc1 ▸ hp.one_lt.le
+  have hcyc := isAddCyclic_of_card_pTorsion_le step1
+  refine ⟨hcyc, ?_⟩
+  have hexp : AddMonoid.exponent (eig τ k) ∣ n :=
+    AddMonoid.exponent_dvd_of_forall_nsmul_eq_zero (fun g => Subtype.ext (nsmul_self_eq_zero (g :
+      (ZMod n × ZMod n))))
+  calc Nat.card (eig τ k) = AddMonoid.exponent (eig τ k) := IsAddCyclic.exponent_eq_card.symm
+    _ ≤ n := Nat.le_of_dvd (Nat.pos_of_ne_zero (NeZero.ne n)) hexp
+
+theorem eig_cyclic_card_eq {k : ZMod n} (hk : k * k = s * k - 1) :
+    IsAddCyclic (eig τ k) ∧ Nat.card (eig τ k) = n := by
+  obtain ⟨hc, hle⟩ := eig_cyclic_card_le τ hns k
+  obtain ⟨_, hle'⟩ := eig_cyclic_card_le τ hns (s - k)
+  have hge := sq_le_card_mul_card τ s hτ hk
+  refine ⟨hc, le_antisymm hle ?_⟩
+  have hmul := Nat.mul_le_mul hle hle'
+  rw [sq] at hge
+  nlinarith [hge, hmul, hle, hle', Nat.one_le_iff_ne_zero.mpr (NeZero.ne n)]
+
+theorem card_stable_eq_card_roots :
+    Nat.card {H : AddSubgroup (ZMod n × ZMod n) // IsAddCyclic H ∧ Nat.card H = n ∧ H.map τ = H}
+      = Nat.card {k : ZMod n // k * k = s * k - 1} := by
+  have gen : ∀ H : AddSubgroup (ZMod n × ZMod n), IsAddCyclic H → Nat.card H = n →
+      ∃ v : (ZMod n × ZMod n), addOrderOf v = n ∧ AddSubgroup.zmultiples v = H := by
+    intro H hc hcard
+    have := hc
+    have : Finite H := Nat.finite_of_card_ne_zero (by rw [hcard]; exact NeZero.ne n)
+    obtain ⟨g, hg⟩ := (isAddCyclic_iff_exists_addOrderOf_eq_natCard (α := H)).mp hc
+    have hgn : addOrderOf (g : (ZMod n × ZMod n)) = n := by
+      rw [show addOrderOf (g : (ZMod n × ZMod n)) = addOrderOf g from
+        addOrderOf_injective H.subtype H.subtype_injective g, hg, hcard]
+    refine ⟨g, hgn, ?_⟩
+    exact AddSubgroup.eq_of_le_of_card_ge (AddSubgroup.zmultiples_le_of_mem g.2)
+      (by rw [hcard, Nat.card_zmultiples, hgn])
+  symm
+  refine Nat.card_eq_of_bijective
+    (fun k : {k : ZMod n // k * k = s * k - 1} =>
+      (⟨eig τ k.1, (eig_cyclic_card_eq τ s hτ hns k.2).1, (eig_cyclic_card_eq τ s hτ hns k.2).2,
+        map_eig_eq τ s hτ k.1⟩ : {H : AddSubgroup (ZMod n × ZMod n) // IsAddCyclic H ∧ Nat.card H =
+          n ∧ H.map τ = H}))
+    ⟨?_, ?_⟩
+  · intro k k' h
+    have h' : eig τ k.1 = eig τ k'.1 := congrArg Subtype.val h
+    obtain ⟨v, hv, hvH⟩ := gen (eig τ k.1) (eig_cyclic_card_eq τ s hτ hns k.2).1
+      (eig_cyclic_card_eq τ s hτ hns k.2).2
+    have hv1 : τ v = k.1 • v := (mem_eig τ k.1 v).mp (hvH ▸ AddSubgroup.mem_zmultiples v)
+    have hv2 : τ v = k'.1 • v := (mem_eig τ k'.1 v).mp (h' ▸ hvH ▸ AddSubgroup.mem_zmultiples v)
+    refine Subtype.ext (sub_eq_zero.mp (eq_zero_of_smul_eq_zero hv ?_))
+    rw [sub_smul, ← hv1, ← hv2, sub_self]
+  · rintro ⟨H, hc, hcard, hst⟩
+    obtain ⟨v, hv, hvH⟩ := gen H hc hcard
+    have hτv : τ v ∈ H :=
+      by rw [← hst]; exact AddSubgroup.mem_map_of_mem τ (hvH ▸ AddSubgroup.mem_zmultiples v)
+    rw [← hvH, AddSubgroup.mem_zmultiples_iff] at hτv
+    obtain ⟨a, ha⟩ := hτv
+    have hk : τ v = (a : ZMod n) • v := by rw [Int.cast_smul_eq_zsmul, ha]
+    have hroot : (a : ZMod n) * (a : ZMod n) = s * (a : ZMod n) - 1 := root_of_eigen τ s hτ hv hk
+    refine ⟨⟨(a : ZMod n), hroot⟩, Subtype.ext ?_⟩
+    change eig τ (a : ZMod n) = H
+    have : Finite (eig τ (a : ZMod n)) := inferInstance
+    symm
+    refine AddSubgroup.eq_of_le_of_card_ge ?_ ?_
+    · rw [← hvH]; exact AddSubgroup.zmultiples_le_of_mem ((mem_eig τ _ v).mpr hk)
+    · rw [(eig_cyclic_card_eq τ s hτ hns hroot).2, hcard]
+
+end Count
+
+end L3zCore
+
+open L3zCore in
+theorem solution (n : ℕ) [NeZero n]
+    (τ : ZMod n × ZMod n →+ ZMod n × ZMod n) (hτ : ∀ v, τ (τ v) + τ v + v = 0)
+    (hns : ∀ p : ℕ, p.Prime → p ∣ n → ∃ v : ZMod n × ZMod n, addOrderOf v = p ∧ ∀ k : ℕ, τ v ≠ k •
+      v) :
+    Nat.card {H : AddSubgroup (ZMod n × ZMod n) // IsAddCyclic H ∧ Nat.card H = n ∧ H.map τ = H}
+      = nuThree n := by
+  have hτ' : ∀ v, τ (τ v) = (-1 : ZMod n) • τ v - v := fun v => by
+    rw [neg_one_smul, ← sub_eq_zero, ← hτ v]; abel
+  rw [card_stable_eq_card_roots τ (-1) hτ' hns, nuThree]
+  exact Nat.card_congr (Equiv.subtypeEquivRight fun k => by
+    constructor <;> intro h <;> linear_combination h)
+
+end S_ZMod_natCard_isAddCyclic_addSubgroup_prod_map_eq_nuThree
+end P2MW
+export P2MW.S_ZMod_natCard_isAddCyclic_addSubgroup_prod_map_eq_nuThree (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ZMod.natCard_isAddCyclic_addSubgroup_prod_map_eq_nuThree (n : ℕ) [NeZero n]
+    (τ : ZMod n × ZMod n →+ ZMod n × ZMod n) (hτ : ∀ v, τ (τ v) + τ v + v = 0)
+    (hns : ∀ p : ℕ, p.Prime → p ∣ n → ∃ v : ZMod n × ZMod n, addOrderOf v = p ∧ ∀ k : ℕ, τ v ≠ k •
+      v) :
+    Nat.card {H : AddSubgroup (ZMod n × ZMod n) // IsAddCyclic H ∧ Nat.card H = n ∧ H.map τ = H}
+      = nuThree n :=
+  solution n τ hτ hns
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_ZMod_natCard_isAddCyclic_addSubgroup_prod_map_eq_nuTwo.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_ZMod_natCard_isAddCyclic_addSubgroup_prod_map_eq_nuTwo.lean
new file mode 100644
index 0000000000..36af698fd3
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_ZMod_natCard_isAddCyclic_addSubgroup_prod_map_eq_nuTwo.lean
@@ -0,0 +1,426 @@
+/-
+Based on Prove2Me node ZMod.natCard_isAddCyclic_addSubgroup_prod_map_eq_nuTwo
+(cf26546a-64e3-5144-98b2-fa8067c608c0) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission b9c23087-c366-5485-b60f-a683ac980a6c
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_GenusNumerics
+
+import Mathlib.Algebra.Order.Ring.Star
+import Mathlib.Data.Int.ConditionallyCompleteOrder
+import Mathlib.Data.Int.Star
+import Mathlib.Order.CompletePartialOrder
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# Counting τ-stable cyclic subgroups of order n in (ℤ/n)²
+
+Theorem statement: `ZMod.natCard_isAddCyclic_addSubgroup_prod_map_eq_nuTwo`
+(`cf26546a-64e3-5144-98b2-fa8067c608c0`), by Claude, 2026-09-05.
+
+Proof: submission `b9c23087-c366-5485-b60f-a683ac980a6c`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+Let $n$ be a natural number with $n \neq 0$, and let $\tau \colon \mathbb{Z}/n \times \mathbb{Z}/n
+\to \mathbb{Z}/n \times \mathbb{Z}/n$ be an endomorphism of the underlying additive group, subject
+to two hypotheses: first, $\tau(\tau(v)) = -v$ for every $v$, so that $\tau^2 = -1$; second, for
+every prime $p$ dividing $n$ there is an element $v$ of $\mathbb{Z}/n \times \mathbb{Z}/n$ of
+additive order exactly $p$ such that $\tau(v) \neq k \cdot v$ for every natural number $k$, i.e.
+$\tau$ is nowhere scalar on $p$-torsion in this sense. The conclusion is an equality of
+cardinalities: the number of additive subgroups $H \le \mathbb{Z}/n \times \mathbb{Z}/n$ which are
+cyclic, have cardinality exactly $n$, and satisfy $\tau(H) = H$ (the image of $H$ under $\tau$ being
+equal to $H$) equals $\nu_2(n)$, which by definition is the number of $x \in \mathbb{Z}/n$ with $x^2
++ 1 = 0$.
+
+This is the arithmetic core of the count of elliptic points of order two (the points above $j =
+1728$) on the modular curve $Y_0(N)$: cyclic subgroups of order $N$ in $E[N] \cong (\mathbb{Z}/N)^2$
+stable under an automorphism of order four correspond to square roots of $-1$ modulo $N$. It is used
+to transport the count to an abstract abelian group with $N$-torsion $(\mathbb{Z}/N)^2$, and thence
+to the computation of the relevant orbit counts for $\Gamma_0(N)$ acting with the elements $S$ and
+$ST$.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_ZMod_natCard_isAddCyclic_addSubgroup_prod_map_eq_nuTwo.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+namespace P2MW.S_ZMod_natCard_isAddCyclic_addSubgroup_prod_map_eq_nuTwo
+
+open ModularCurve
+
+namespace L3zCore
+
+variable {n : ℕ} [NeZero n]
+
+omit [NeZero n] in
+theorem nsmul_self_eq_zero (v : (ZMod n × ZMod n)) : n • v = 0 := by
+  ext <;> simp [nsmul_eq_mul]
+
+theorem map_zmod_smul (τ : (ZMod n × ZMod n) →+ (ZMod n × ZMod n)) (c : ZMod n)
+    (v : (ZMod n × ZMod n)) :
+    τ (c • v) = c • τ v := by
+  rw [← ZMod.natCast_zmod_val c, Nat.cast_smul_eq_nsmul, Nat.cast_smul_eq_nsmul, map_nsmul]
+
+theorem eq_zero_of_smul_eq_zero {v : (ZMod n × ZMod n)} (hv : addOrderOf v = n) {c : ZMod n}
+    (hc : c • v = 0) :
+    c = 0 := by
+  rw [← ZMod.natCast_zmod_val c, Nat.cast_smul_eq_nsmul] at hc
+  have hdvd : addOrderOf v ∣ c.val := addOrderOf_dvd_of_nsmul_eq_zero hc
+  rw [hv] at hdvd
+  have hval : c.val = 0 := Nat.eq_zero_of_dvd_of_lt hdvd (ZMod.val_lt c)
+  exact (ZMod.val_eq_zero c).mp hval
+
+def eig (τ : (ZMod n × ZMod n) →+ (ZMod n × ZMod n)) (k : ZMod n) :
+    AddSubgroup (ZMod n × ZMod n) where
+  carrier := {v | τ v = k • v}
+  zero_mem' := by simp only [Set.mem_ofPred_eq, map_zero, smul_zero]
+  add_mem' ha hb := by
+    simp only [Set.mem_ofPred_eq] at ha hb ⊢; rw [map_add, ha, hb, smul_add]
+  neg_mem' ha := by
+    simp only [Set.mem_ofPred_eq] at ha ⊢; rw [map_neg, ha, smul_neg]
+
+omit [NeZero n] in
+theorem mem_eig (τ : (ZMod n × ZMod n) →+ (ZMod n × ZMod n)) (k : ZMod n) (v : (ZMod n × ZMod n)) :
+    v ∈ eig τ k ↔ τ v = k • v := Iff.rfl
+
+def shift (τ : (ZMod n × ZMod n) →+ (ZMod n × ZMod n)) (k : ZMod n) :
+    (ZMod n × ZMod n) →+ (ZMod n × ZMod n) where
+  toFun v := τ v - k • v
+  map_zero' := by simp only [map_zero, smul_zero, sub_zero]
+  map_add' v w := by simp only [map_add, smul_add]; abel
+
+omit [NeZero n] in
+theorem shift_apply (τ : (ZMod n × ZMod n) →+ (ZMod n × ZMod n)) (k : ZMod n)
+    (v : (ZMod n × ZMod n)) :
+    shift τ k v = τ v - k • v := rfl
+
+omit [NeZero n] in
+theorem ker_shift (τ : (ZMod n × ZMod n) →+ (ZMod n × ZMod n)) (k : ZMod n) :
+    (shift τ k).ker = eig τ k := by
+  ext v
+  rw [AddMonoidHom.mem_ker, shift_apply, sub_eq_zero, mem_eig]
+
+section Quadratic
+
+variable (τ : (ZMod n × ZMod n) →+ (ZMod n × ZMod n)) (s : ZMod n) (hτ : ∀ v, τ (τ v) = s • τ v - v)
+include hτ
+
+omit [NeZero n] in
+theorem τ_injective : Function.Injective τ := fun a b h => by
+  grind
+
+theorem root_of_eigen {v : (ZMod n × ZMod n)} (hv : addOrderOf v = n) {k : ZMod n}
+    (hk : τ v = k • v) :
+    k * k = s * k - 1 := by
+  have h1 : τ (τ v) = (k * k) • v := by rw [hk, map_zmod_smul, hk, smul_smul]
+  have h2 : τ (τ v) = (s * k - 1) • v := by rw [hτ, hk, smul_smul, sub_smul, one_smul]
+  have h3 : (k * k - (s * k - 1)) • v = 0 := by rw [sub_smul, ← h1, ← h2, sub_self]
+  exact sub_eq_zero.mp (eq_zero_of_smul_eq_zero hv h3)
+
+theorem range_shift_le {k : ZMod n} (hk : k * k = s * k - 1) :
+    (shift τ k).range ≤ eig τ (s - k) := by
+  rintro w ⟨v, rfl⟩
+  rw [mem_eig, shift_apply, map_sub, map_zmod_smul, hτ, smul_sub, smul_smul,
+    show (s - k) * k = 1 by grind, one_smul, sub_smul]
+  abel
+
+theorem sq_le_card_mul_card {k : ZMod n} (hk : k * k = s * k - 1) :
+    n ^ 2 ≤ Nat.card (eig τ k) * Nat.card (eig τ (s - k)) := by
+  have hN2 : Nat.card (ZMod n × ZMod n) = n ^ 2 := by rw [Nat.card_prod, Nat.card_zmod, sq]
+  have hfirst : Nat.card (ZMod n × ZMod n) = Nat.card (shift τ k).ker * Nat.card (shift τ k).range
+    :=
+    by
+    rw [mul_comm, ← Nat.card_congr (QuotientAddGroup.quotientKerEquivRange (shift τ k)).toEquiv,
+      ← AddSubgroup.card_eq_card_quotient_mul_card_addSubgroup]
+  rw [← hN2, hfirst, ker_shift]
+  exact Nat.mul_le_mul_left _ (Nat.card_le_card_of_injective
+    (AddSubgroup.inclusion (range_shift_le τ s hτ hk)) (AddSubgroup.inclusion_injective _))
+
+theorem map_eig_eq (k : ZMod n) : (eig τ k).map τ = eig τ k := by
+  have : Finite (eig τ k) := inferInstance
+  have hle : (eig τ k).map τ ≤ eig τ k := by
+    rintro _ ⟨v, hv, rfl⟩
+    rw [SetLike.mem_coe, mem_eig] at hv
+    rw [mem_eig, hv, map_zmod_smul, hv]
+  exact AddSubgroup.eq_of_le_of_card_ge hle
+    (Nat.card_congr ((eig τ k).equivMapOfInjective τ (τ_injective τ s hτ)).toEquiv).le
+
+end Quadratic
+
+omit [NeZero n] in
+theorem card_pTorsion_le {p : ℕ} (hp : p.Prime) :
+    Nat.card {v : (ZMod n × ZMod n) // p • v = 0} ≤ p ^ 2 := by
+  have key : Nat.card {x : ZMod n // p • x = 0} ≤ p := by
+    let S : AddSubgroup (ZMod n) :=
+      { carrier := {x | p • x = 0}, zero_mem' := by simp,
+        add_mem' := fun {a b} ha hb =>
+          show p • (a + b) = 0 by rw [nsmul_add, ha, hb, add_zero],
+        neg_mem' := fun {a} ha =>
+          show p • (-a) = 0 by rw [smul_neg, ha, neg_zero] }
+    have : IsAddCyclic S := AddSubgroup.isAddCyclic S
+    have hexp : AddMonoid.exponent S ∣ p :=
+      AddMonoid.exponent_dvd_of_forall_nsmul_eq_zero (fun g => Subtype.ext g.2)
+    calc Nat.card {x : ZMod n // p • x = 0} = Nat.card S := rfl
+      _ = AddMonoid.exponent S := IsAddCyclic.exponent_eq_card.symm
+      _ ≤ p := Nat.le_of_dvd hp.pos hexp
+  have e : {v : (ZMod n × ZMod n) // p • v = 0} ≃ {x : ZMod n // p • x = 0} × {y : ZMod n // p • y =
+    0} :=
+    by
+    refine ⟨fun v => (⟨v.1.1, (Prod.mk_inj.mp v.2).1⟩, ⟨v.1.2, (Prod.mk_inj.mp v.2).2⟩),
+      fun z => ⟨(z.1.1, z.2.1), Prod.ext z.1.2 z.2.2⟩, ?_, ?_⟩
+    · grind
+    · grind
+  rw [Nat.card_congr e, Nat.card_prod, sq]
+  exact Nat.mul_le_mul key key
+
+theorem isAddCyclic_of_card_pTorsion_le {G : Type*} [AddCommGroup G]
+    [Finite G] (h : ∀ p : ℕ, p.Prime → Nat.card {g : G // p • g = 0} ≤ p) :
+    IsAddCyclic G := by
+  classical
+  obtain ⟨_⟩ := nonempty_fintype G
+  let T : ℕ → AddSubgroup G := fun m =>
+    { carrier := {g | m • g = 0}
+      zero_mem' := by simp
+      add_mem' := fun {a b} ha hb =>
+        show m • (a + b) = 0 by rw [nsmul_add, ha, hb, add_zero]
+      neg_mem' := fun {a} ha =>
+        show m • (-a) = 0 by rw [smul_neg, ha, neg_zero] }
+  have hTcard : ∀ m, Nat.card (T m) = Nat.card {g : G // m • g = 0} := fun m => rfl
+  suffices hbound : ∀ m : ℕ, 0 < m → Nat.card (T m) ≤ m by
+    refine isAddCyclic_of_card_nsmul_eq_zero_le (fun m hm => ?_)
+    have hfs : (Finset.univ.filter (fun a : G => m • a = 0)).card
+        = Fintype.card {g : G // m • g = 0} := (Fintype.card_subtype _).symm
+    calc (Finset.univ.filter (fun a : G => m • a = 0)).card
+        = Nat.card (T m) := hfs.trans (Nat.card_eq_fintype_card (α := T m)).symm
+      _ ≤ m := hbound m hm
+  intro m hm
+  induction m using Nat.strong_induction_on with
+  | _ m ih =>
+  rcases eq_or_ne m 1 with rfl | hm1
+  · have h1 : T 1 = ⊥ := by
+      refine le_antisymm (fun g hg => ?_) bot_le
+      exact AddSubgroup.mem_bot.mpr (one_nsmul g ▸ hg)
+    rw [h1, AddSubgroup.card_bot]
+  · obtain ⟨p, hp, hpm⟩ := Nat.exists_prime_and_dvd hm1
+    have hmp : 0 < m / p := Nat.div_pos (Nat.le_of_dvd hm hpm) hp.pos
+    have hmpm : m / p < m := Nat.div_lt_self hm hp.one_lt
+    let φ : T m →+ T p :=
+      { toFun := fun g => ⟨(m/p) • g.1, by
+          change p • ((m/p) • g.1) = 0
+          rw [← mul_nsmul', Nat.mul_div_cancel' hpm]; exact g.2⟩
+        map_zero' := Subtype.ext (by simp)
+        map_add' := fun a b => Subtype.ext (by simp) }
+    have hkerφ : Nat.card φ.ker ≤ m / p := by
+      have hψ : ∀ g : φ.ker, (m/p) • (g.1.1 : G) = 0 := fun g =>
+        congrArg Subtype.val (φ.mem_ker.mp g.2)
+      let ψ : φ.ker → T (m/p) := fun g => ⟨g.1.1, hψ g⟩
+      have hψinj : Function.Injective ψ := fun a b hab => by grind
+      exact le_trans (Nat.card_le_card_of_injective ψ hψinj) (ih (m/p) hmpm hmp)
+    have himφ : Nat.card φ.range ≤ p :=
+      le_trans (Nat.card_le_card_of_injective (AddSubgroup.subtype φ.range)
+        (AddSubgroup.subtype_injective _)) ((hTcard p).symm ▸ h p hp)
+    calc Nat.card (T m)
+        = Nat.card φ.ker * Nat.card φ.range := by
+          rw [mul_comm, ← Nat.card_congr (QuotientAddGroup.quotientKerEquivRange φ).toEquiv,
+            ← AddSubgroup.card_eq_card_quotient_mul_card_addSubgroup]
+      _ ≤ (m/p) * p := Nat.mul_le_mul hkerφ himφ
+      _ = m := Nat.div_mul_cancel hpm
+
+theorem card_eig_pTorsion_le (τ : (ZMod n × ZMod n) →+ (ZMod n × ZMod n)) (k : ZMod n) {p : ℕ}
+    (hp : p.Prime)
+    (hns : ∃ v : (ZMod n × ZMod n), addOrderOf v = p ∧ ∀ m : ℕ, τ v ≠ m • v) :
+    Nat.card {g : eig τ k // p • g = 0} ≤ p := by
+  have : Fact p.Prime := ⟨hp⟩
+  obtain ⟨v₀, hv₀, hv₀ns⟩ := hns
+  have hv₀K : v₀ ∉ eig τ k := fun h => hv₀ns k.val (by
+    rw [mem_eig] at h; rw [h, ← Nat.cast_smul_eq_nsmul (ZMod n), ZMod.natCast_zmod_val])
+  let Z : AddSubgroup (ZMod n × ZMod n) := AddSubgroup.zmultiples v₀
+  have hZcard : Nat.card Z = p := by rw [Nat.card_zmultiples, hv₀]
+  have : Finite Z := Nat.finite_of_card_ne_zero (by rw [hZcard]; exact hp.ne_zero)
+  let Kp : AddSubgroup (ZMod n × ZMod n) :=
+    { carrier := {v | τ v = k • v ∧ p • v = 0}
+      zero_mem' := by simp only [Set.mem_ofPred_eq, map_zero, smul_zero, and_self]
+      add_mem' := fun {a b} ha hb => by
+        simp only [Set.mem_ofPred_eq] at ha hb ⊢
+        rw [map_add, ha.1, hb.1, smul_add, nsmul_add, ha.2, hb.2, add_zero]; exact ⟨rfl, rfl⟩
+      neg_mem' := fun {a} ha => by
+        simp only [Set.mem_ofPred_eq] at ha ⊢
+        rw [map_neg, ha.1, smul_neg, smul_neg, ha.2, neg_zero]; exact ⟨rfl, rfl⟩ }
+  have hKp : Nat.card {g : eig τ k // p • g = 0} = Nat.card Kp := by
+    refine Nat.card_congr ⟨fun g => ⟨g.1.1, g.1.2, ?_⟩, fun v => ⟨⟨v.1, v.2.1⟩, ?_⟩, ?_, ?_⟩
+    · exact congrArg Subtype.val g.2
+    · exact Subtype.ext v.2.2
+    · intro g; rfl
+    · intro v; rfl
+  have hdisj : ∀ x, x ∈ Kp → x ∈ Z → x = 0 := by
+    intro x hxK hxZ
+    by_contra hx0
+    have hpx : p • x = 0 := hxK.2
+    have hordx : addOrderOf x = p :=
+      (hp.eq_one_or_self_of_dvd _ (addOrderOf_dvd_of_nsmul_eq_zero hpx)).resolve_left
+        (fun h1 => hx0 (AddMonoid.addOrderOf_eq_one_iff.mp h1))
+    have hle : AddSubgroup.zmultiples x ≤ Z := AddSubgroup.zmultiples_le_of_mem hxZ
+    have heq : AddSubgroup.zmultiples x = Z :=
+      AddSubgroup.eq_of_le_of_card_ge hle (by rw [hZcard, Nat.card_zmultiples, hordx])
+    have hv₀x : v₀ ∈ AddSubgroup.zmultiples x := by rw [heq]; exact AddSubgroup.mem_zmultiples v₀
+    have hxk : AddSubgroup.zmultiples x ≤ eig τ k := AddSubgroup.zmultiples_le_of_mem hxK.1
+    exact hv₀K (hxk hv₀x)
+  let f : Kp × Z → {v : (ZMod n × ZMod n) // p • v = 0} := fun gz => ⟨gz.1.1 + gz.2.1, by
+    obtain ⟨⟨g, hg⟩, ⟨z, hz⟩⟩ := gz
+    obtain ⟨a, rfl⟩ := AddSubgroup.mem_zmultiples_iff.mp hz
+    change p • (g + a • v₀) = 0
+    rw [nsmul_add, hg.2, zero_add, smul_comm, ← hv₀, addOrderOf_nsmul_eq_zero, smul_zero]⟩
+  have hf : Function.Injective f := by
+    rintro ⟨⟨g, hg⟩, ⟨z, hz⟩⟩ ⟨⟨g', hg'⟩, ⟨z', hz'⟩⟩ h
+    have h' : g + z = g' + z' := congrArg Subtype.val h
+    have hd : g - g' = z' - z := sub_eq_sub_iff_add_eq_add.mpr (by rw [h', add_comm])
+    have h0 : g - g' = 0 := hdisj _ (Kp.sub_mem hg hg') (hd ▸ Z.sub_mem hz' hz)
+    have hg0 : g = g' := sub_eq_zero.mp h0
+    have hz0 : z = z' := by rw [hg0] at h'; exact add_left_cancel h'
+    subst hg0 hz0; rfl
+  have hle := Nat.card_le_card_of_injective f hf
+  rw [Nat.card_prod, hZcard] at hle
+  have hle2 := le_trans hle (card_pTorsion_le hp)
+  rw [sq] at hle2
+  rw [hKp]
+  exact Nat.le_of_mul_le_mul_right hle2 hp.pos
+
+section Count
+
+variable (τ : (ZMod n × ZMod n) →+ (ZMod n × ZMod n)) (s : ZMod n) (hτ : ∀ v, τ (τ v) = s • τ v - v)
+  (hns : ∀ p : ℕ, p.Prime → p ∣ n → ∃ v : (ZMod n × ZMod n), addOrderOf v = p ∧ ∀ m : ℕ, τ v ≠ m •
+    v)
+include hτ hns
+
+omit hτ in
+theorem eig_cyclic_card_le (k : ZMod n) : IsAddCyclic (eig τ k) ∧ Nat.card (eig τ k) ≤ n := by
+  have step1 : ∀ p : ℕ, p.Prime → Nat.card {g : eig τ k // p • g = 0} ≤ p := by
+    intro p hp
+    by_cases hpn : p ∣ n
+    · exact card_eig_pTorsion_le τ k hp (hns p hp hpn)
+    · have hpn' : ∀ g : eig τ k, p • g = 0 → g = 0 := by
+        intro g hg
+        have hg' : p • (g : (ZMod n × ZMod n)) = 0 := congrArg Subtype.val hg
+        have hgord : addOrderOf (g : (ZMod n × ZMod n)) ∣ Nat.gcd p n :=
+          Nat.dvd_gcd (addOrderOf_dvd_of_nsmul_eq_zero hg')
+            (addOrderOf_dvd_of_nsmul_eq_zero (nsmul_self_eq_zero (g : (ZMod n × ZMod n))))
+        rw [(hp.coprime_iff_not_dvd.mpr hpn), Nat.dvd_one] at hgord
+        refine Subtype.ext ?_
+        have : (1:ℕ) • (g : (ZMod n × ZMod n)) = 0 := hgord ▸ addOrderOf_nsmul_eq_zero _
+        simpa using this
+      have hsub : Subsingleton {g : eig τ k // p • g = 0} :=
+        ⟨fun a b => Subtype.ext ((hpn' a.1 a.2).trans (hpn' b.1 b.2).symm)⟩
+      have hc1 : Nat.card {g : eig τ k // p • g = 0} = 1 :=
+        Nat.card_of_subsingleton (⟨0, by simp only [nsmul_zero]⟩ : {g : eig τ k // p • g = 0})
+      exact hc1 ▸ hp.one_lt.le
+  have hcyc := isAddCyclic_of_card_pTorsion_le step1
+  refine ⟨hcyc, ?_⟩
+  have hexp : AddMonoid.exponent (eig τ k) ∣ n :=
+    AddMonoid.exponent_dvd_of_forall_nsmul_eq_zero (fun g => Subtype.ext (nsmul_self_eq_zero (g :
+      (ZMod n × ZMod n))))
+  calc Nat.card (eig τ k) = AddMonoid.exponent (eig τ k) := IsAddCyclic.exponent_eq_card.symm
+    _ ≤ n := Nat.le_of_dvd (Nat.pos_of_ne_zero (NeZero.ne n)) hexp
+
+theorem eig_cyclic_card_eq {k : ZMod n} (hk : k * k = s * k - 1) :
+    IsAddCyclic (eig τ k) ∧ Nat.card (eig τ k) = n := by
+  obtain ⟨hc, hle⟩ := eig_cyclic_card_le τ hns k
+  obtain ⟨_, hle'⟩ := eig_cyclic_card_le τ hns (s - k)
+  have hge := sq_le_card_mul_card τ s hτ hk
+  refine ⟨hc, le_antisymm hle ?_⟩
+  have hmul := Nat.mul_le_mul hle hle'
+  rw [sq] at hge
+  nlinarith [hge, hmul, hle, hle', Nat.one_le_iff_ne_zero.mpr (NeZero.ne n)]
+
+theorem card_stable_eq_card_roots :
+    Nat.card {H : AddSubgroup (ZMod n × ZMod n) // IsAddCyclic H ∧ Nat.card H = n ∧ H.map τ = H}
+      = Nat.card {k : ZMod n // k * k = s * k - 1} := by
+  have gen : ∀ H : AddSubgroup (ZMod n × ZMod n), IsAddCyclic H → Nat.card H = n →
+      ∃ v : (ZMod n × ZMod n), addOrderOf v = n ∧ AddSubgroup.zmultiples v = H := by
+    intro H hc hcard
+    have := hc
+    have : Finite H := Nat.finite_of_card_ne_zero (by rw [hcard]; exact NeZero.ne n)
+    obtain ⟨g, hg⟩ := (isAddCyclic_iff_exists_addOrderOf_eq_natCard (α := H)).mp hc
+    have hgn : addOrderOf (g : (ZMod n × ZMod n)) = n := by
+      rw [show addOrderOf (g : (ZMod n × ZMod n)) = addOrderOf g from
+        addOrderOf_injective H.subtype H.subtype_injective g, hg, hcard]
+    refine ⟨g, hgn, ?_⟩
+    exact AddSubgroup.eq_of_le_of_card_ge (AddSubgroup.zmultiples_le_of_mem g.2)
+      (by rw [hcard, Nat.card_zmultiples, hgn])
+  symm
+  refine Nat.card_eq_of_bijective
+    (fun k : {k : ZMod n // k * k = s * k - 1} =>
+      (⟨eig τ k.1, (eig_cyclic_card_eq τ s hτ hns k.2).1, (eig_cyclic_card_eq τ s hτ hns k.2).2,
+        map_eig_eq τ s hτ k.1⟩ : {H : AddSubgroup (ZMod n × ZMod n) // IsAddCyclic H ∧ Nat.card H =
+          n ∧ H.map τ = H}))
+    ⟨?_, ?_⟩
+  · intro k k' h
+    have h' : eig τ k.1 = eig τ k'.1 := congrArg Subtype.val h
+    obtain ⟨v, hv, hvH⟩ := gen (eig τ k.1) (eig_cyclic_card_eq τ s hτ hns k.2).1
+      (eig_cyclic_card_eq τ s hτ hns k.2).2
+    have hv1 : τ v = k.1 • v := (mem_eig τ k.1 v).mp (hvH ▸ AddSubgroup.mem_zmultiples v)
+    have hv2 : τ v = k'.1 • v := (mem_eig τ k'.1 v).mp (h' ▸ hvH ▸ AddSubgroup.mem_zmultiples v)
+    refine Subtype.ext (sub_eq_zero.mp (eq_zero_of_smul_eq_zero hv ?_))
+    rw [sub_smul, ← hv1, ← hv2, sub_self]
+  · rintro ⟨H, hc, hcard, hst⟩
+    obtain ⟨v, hv, hvH⟩ := gen H hc hcard
+    have hτv : τ v ∈ H :=
+      by rw [← hst]; exact AddSubgroup.mem_map_of_mem τ (hvH ▸ AddSubgroup.mem_zmultiples v)
+    rw [← hvH, AddSubgroup.mem_zmultiples_iff] at hτv
+    obtain ⟨a, ha⟩ := hτv
+    have hk : τ v = (a : ZMod n) • v := by rw [Int.cast_smul_eq_zsmul, ha]
+    have hroot : (a : ZMod n) * (a : ZMod n) = s * (a : ZMod n) - 1 := root_of_eigen τ s hτ hv hk
+    refine ⟨⟨(a : ZMod n), hroot⟩, Subtype.ext ?_⟩
+    change eig τ (a : ZMod n) = H
+    have : Finite (eig τ (a : ZMod n)) := inferInstance
+    symm
+    refine AddSubgroup.eq_of_le_of_card_ge ?_ ?_
+    · rw [← hvH]; exact AddSubgroup.zmultiples_le_of_mem ((mem_eig τ _ v).mpr hk)
+    · rw [(eig_cyclic_card_eq τ s hτ hns hroot).2, hcard]
+
+end Count
+
+end L3zCore
+
+open L3zCore in
+theorem solution (n : ℕ) [NeZero n]
+    (τ : ZMod n × ZMod n →+ ZMod n × ZMod n) (hτ : ∀ v, τ (τ v) = -v)
+    (hns : ∀ p : ℕ, p.Prime → p ∣ n → ∃ v : ZMod n × ZMod n, addOrderOf v = p ∧ ∀ k : ℕ, τ v ≠ k •
+      v) :
+    Nat.card {H : AddSubgroup (ZMod n × ZMod n) // IsAddCyclic H ∧ Nat.card H = n ∧ H.map τ = H}
+      = nuTwo n := by
+  have hτ' : ∀ v, τ (τ v) = (0 : ZMod n) • τ v - v := fun v => by rw [hτ, zero_smul, zero_sub]
+  rw [card_stable_eq_card_roots τ 0 hτ' hns, nuTwo]
+  exact Nat.card_congr (Equiv.subtypeEquivRight fun k => by
+    constructor <;> intro h <;> linear_combination h)
+
+end S_ZMod_natCard_isAddCyclic_addSubgroup_prod_map_eq_nuTwo
+end P2MW
+export P2MW.S_ZMod_natCard_isAddCyclic_addSubgroup_prod_map_eq_nuTwo (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open ModularCurve
+theorem ZMod.natCard_isAddCyclic_addSubgroup_prod_map_eq_nuTwo (n : ℕ) [NeZero n]
+    (τ : ZMod n × ZMod n →+ ZMod n × ZMod n) (hτ : ∀ v, τ (τ v) = -v)
+    (hns : ∀ p : ℕ, p.Prime → p ∣ n → ∃ v : ZMod n × ZMod n, addOrderOf v = p ∧ ∀ k : ℕ, τ v ≠ k •
+      v) :
+    Nat.card {H : AddSubgroup (ZMod n × ZMod n) // IsAddCyclic H ∧ Nat.card H = n ∧ H.map τ = H}
+      = nuTwo n :=
+  solution n τ hτ hns
+
+end publicSection
diff --git a/LeanPool/FLTEichlerShimura/Theorems/Thm_omegaRow_T2.lean b/LeanPool/FLTEichlerShimura/Theorems/Thm_omegaRow_T2.lean
new file mode 100644
index 0000000000..aa5ac3e7fd
--- /dev/null
+++ b/LeanPool/FLTEichlerShimura/Theorems/Thm_omegaRow_T2.lean
@@ -0,0 +1,525 @@
+/-
+Based on Prove2Me node omegaRow_T2
+(052a4ca0-b580-598d-a200-46d9e8d6d2b8) by Claude (2026-09-05).
+
+Proof based on Prove2Me submission 66f54b5d-1929-50bc-be15-884d493bf903
+by Claude (2026-09-05); locally adapted.
+
+Licensed under Apache License 2.0
+(https://www.apache.org/licenses/LICENSE-2.0).
+-/
+
+module
+
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_OmegaOf
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_EigenformIdeal
+public import LeanPool.FLTEichlerShimura.Definitions.Def_ModularCurve_HeckeModule
+public import LeanPool.FLTEichlerShimura.Definitions.Def_AlgebraicCurve_Differentials
+public import LeanPool.FLTEichlerShimura.Definitions.Def_CuspForm_IntegralStructure
+public import Mathlib.NumberTheory.ModularForms.CongruenceSubgroups
+public import Mathlib.NumberTheory.ModularForms.LevelOne.DimensionFormula
+
+import Mathlib.Data.Int.Star
+import Mathlib.Order.CompletePartialOrder
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_jqModC_eq_qExpansion_E4_cube_div_discriminant
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_thetaL_coeffMap_eq_coeffMap_single_mul_derivative
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_theta_coeff
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularCurve_theta_mul
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_gamma0_qExpansion_eq_of_levelOne
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_exists_rankinCohen_one_qExpansion_eq
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_four_qCoeff_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_six_qCoeff_one
+import LeanPool.FLTEichlerShimura.Theorems.Thm_ModularForm_levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant
+import LeanPool.FLTEichlerShimura.Definitions.Def_P2M_Util
+
+/-!
+# q dj/dq · Δ = -E₄²E₆ as q-expansions
+
+Theorem statement: `omegaRow_T2` (`052a4ca0-b580-598d-a200-46d9e8d6d2b8`), by Claude, 2026-09-05.
+
+Proof: submission `66f54b5d-1929-50bc-be15-884d493bf903`, by Claude, 2026-09-05 (ACCEPTED); locally
+adapted.
+
+A hypothesis-free identity of Laurent series over $\mathbb{C}$. On the left, `jq` is the Laurent
+series over $\mathbb{Q}$ given by $\mathrm{single}(-1,1)$ times the image in `LaurentSeries ℚ` of
+the power series `jNumQ`, itself the coefficientwise image under $\mathbb{Z}\to\mathbb{Q}$ of the
+integral power series `jNum`; thus `jq` is the $q$-expansion of the modular invariant $j$, with a
+simple pole in $q$. The operator `thetaL ℚ` sends $f$ to $\mathrm{single}(1,1)\cdot \partial f$,
+i.e. it is $q\,d/dq$, multiplying the coefficient of $q^{n}$ by $n$. `coeffMap (algebraMap ℚ ℂ)` is
+the ring homomorphism on Laurent series induced coefficientwise by
+$\mathbb{Q}\hookrightarrow\mathbb{C}$. The remaining three factors are the `qExpansion 1` power
+series of the Mathlib level-one forms `ModularForm.discriminant`, `ModularForm.E₄` and
+`ModularForm.E₆`, each viewed as a Laurent series over $\mathbb{C}$ through the inclusion of power
+series. The assertion is that the image of $\theta(j)$ in `LaurentSeries ℂ`, multiplied by the
+$q$-expansion of $\Delta$, equals $-\bigl(E_4^{2}\,E_6\bigr)$, the product of the square of the
+$q$-expansion of $E_4$ with that of $E_6$, negated.
+
+This is the classical derivative formula for the $j$-invariant, $q\,dj/dq = -E_4^{2}E_6/\Delta$,
+recorded here as an identity of $q$-expansions rather than of functions on the upper half-plane, the
+relation $j = E_4^{3}/\Delta$ being available separately. It is used in the analysis of the order of
+vanishing of differentials on modular curves and in the construction of cusp forms whose
+$q$-expansion is a multiple of $\theta$ applied to a given Laurent series.
+
+## Explanation of the source proof
+
+Proof transplanted from the FLT repository:
+https://github.com/anthropics/fermats-last-theorem/blob/aa2d8b34692b16c70f699536de0d8e75b9a3e9ef/P2M/Sol/S_omegaRow_T2.lean
+
+<!-- Generated by add_prove2me_provenance.py -->
+-/
+
+section privateSection
+
+set_option backward.isDefEq.respectTransparency.types false
+
+namespace P2MW.S_omegaRow_T2
+
+p2m_open "UpperHalfPlane ModularCurve~coeffEmb_jq AlgebraicCurve"
+
+p2m_open "UpperHalfPlane ModularCurve~coeffEmb_jq"
+open scoped MatrixGroups ModularForm Manifold
+
+noncomputable section
+
+namespace ANb
+
+def Nice (f : ℍ → ℂ) : Prop :=
+  Function.Periodic (f ∘ ofComplex) 1 ∧ MDifferentiable 𝓘(ℂ) 𝓘(ℂ) f ∧ IsBoundedAtImInfty f
+
+theorem Nice.mul {f g : ℍ → ℂ} (hf : Nice f) (hg : Nice g) : Nice (f * g) :=
+  ⟨by simpa [Function.comp_def] using hf.1.mul hg.1, hf.2.1.mul hg.2.1, hf.2.2.mul hg.2.2⟩
+
+theorem Nice.add {f g : ℍ → ℂ} (hf : Nice f) (hg : Nice g) : Nice (f + g) :=
+  ⟨by simpa [Function.comp_def] using hf.1.add hg.1, hf.2.1.add hg.2.1, hf.2.2.add hg.2.2⟩
+
+theorem Nice.const (c : ℂ) : Nice (fun _ => c) :=
+  ⟨fun _ => rfl, mdifferentiable_const, Filter.const_boundedAtFilter _ _⟩
+
+def niceSubalgebra : Subalgebra ℂ (ℍ → ℂ) where
+  carrier := {f | Nice f}
+  mul_mem' hf hg := hf.mul hg
+  add_mem' hf hg := hf.add hg
+  algebraMap_mem' c := Nice.const c
+
+local notation "𝒩" => niceSubalgebra
+
+theorem an (f : 𝒩) : AnalyticAt ℂ (cuspFunction 1 (f : ℍ → ℂ)) 0 :=
+  UpperHalfPlane.analyticAt_cuspFunction_zero one_pos f.2.1 f.2.2.1 f.2.2.2
+
+def qexpHom : 𝒩 →ₐ[ℂ] PowerSeries ℂ where
+  toFun f := qExpansion 1 (f : ℍ → ℂ)
+  map_one' := UpperHalfPlane.qExpansion_one 1
+  map_mul' f g := UpperHalfPlane.qExpansion_mul (an f) (an g)
+  map_zero' := UpperHalfPlane.qExpansion_zero 1
+  map_add' f g := UpperHalfPlane.qExpansion_add (an f) (an g)
+  commutes' c := by
+    have h1 : ((algebraMap ℂ (ℍ → ℂ) c : ℍ → ℂ)) = c • (1 : ℍ → ℂ) := by
+      funext z; simp
+    have a1 : AnalyticAt ℂ (cuspFunction 1 (1 : ℍ → ℂ)) 0 := an (1 : 𝒩)
+    change qExpansion 1 (algebraMap ℂ (ℍ → ℂ) c) = _
+    rw [h1, UpperHalfPlane.qExpansion_smul a1 c, UpperHalfPlane.qExpansion_one,
+      Algebra.algebraMap_eq_smul_one]
+
+theorem qexpHom_apply (f : 𝒩) : qexpHom f = qExpansion 1 (f : ℍ → ℂ) := rfl
+
+def ψ : 𝒩 →ₐ[ℂ] LaurentSeries ℂ :=
+  { (HahnSeries.ofPowerSeries ℤ ℂ).comp qexpHom.toRingHom with
+    commutes' := fun c => by
+      change HahnSeries.ofPowerSeries ℤ ℂ (qexpHom (algebraMap ℂ 𝒩 c)) = _
+      rw [qexpHom.commutes, HahnSeries.algebraMap_apply'] }
+
+theorem ψ_apply (f : 𝒩) : ψ f = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (f : ℍ → ℂ)) := rfl
+
+theorem ψ_injective : Function.Injective ψ := by
+  intro f g hfg
+  rw [ψ_apply, ψ_apply] at hfg
+  have h := HahnSeries.ofPowerSeries_injective hfg
+  have h' : qExpansion 1 ((f : ℍ → ℂ) - (g : ℍ → ℂ)) = 0 := by
+    rw [UpperHalfPlane.qExpansion_sub (an f) (an g), h, sub_self]
+  have hn : Nice ((f : ℍ → ℂ) - (g : ℍ → ℂ)) := (f - g).2
+  have h0 := (UpperHalfPlane.qExpansion_eq_zero_iff one_pos hn.1 hn.2.1 hn.2.2).mp h'
+  exact Subtype.ext (sub_eq_zero.mp h0)
+
+theorem ψ_eq_zero_iff (f : 𝒩) : ψ f = 0 ↔ f = 0 :=
+  ⟨fun h => ψ_injective (by rw [h, map_zero]), fun h => by rw [h, map_zero]⟩
+
+def toC : 𝒩 →ₐ[ℂ] (ℂ → ℂ) where
+  toFun f := (f : ℍ → ℂ) ∘ ofComplex
+  map_one' := rfl
+  map_mul' _ _ := rfl
+  map_zero' := rfl
+  map_add' _ _ := rfl
+  commutes' _ := rfl
+
+theorem toC_apply (f : 𝒩) : toC f = (f : ℍ → ℂ) ∘ ofComplex := rfl
+
+theorem analyticAt_toC (f : 𝒩) (τ : ℍ) : AnalyticAt ℂ (toC f) (τ : ℂ) := by
+  have hd : DifferentiableOn ℂ ((f : ℍ → ℂ) ∘ ofComplex) {z : ℂ | 0 < z.im} :=
+    UpperHalfPlane.mdifferentiable_iff.mp f.2.2.1
+  exact hd.analyticAt ((isOpen_lt continuous_const Complex.continuous_im).mem_nhds τ.im_pos)
+
+theorem nice_of_modularForm {F : Type*} {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (h1 : (1 : ℝ) ∈ Γ.strictPeriods) : Nice (f : ℍ → ℂ) := by
+  have : Fact (IsCusp OnePoint.infty Γ) := ⟨Subgroup.isCusp_of_mem_strictPeriods one_pos h1⟩
+  refine ⟨?_, ModularFormClass.holo f, ModularFormClass.bdd_at_infty f⟩
+  simpa using SlashInvariantFormClass.periodic_comp_ofComplex (h := 1) f h1
+
+def ofMF {F : Type*} {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (h1 : (1 : ℝ) ∈ Γ.strictPeriods) : 𝒩 :=
+  ⟨f, nice_of_modularForm f h1⟩
+
+@[scoped simp] theorem coe_ofMF {F : Type*} {Γ : Subgroup (GL (Fin 2) ℝ)} {k : ℤ} [FunLike F ℍ ℂ]
+    [ModularFormClass F Γ k] (f : F) (h1 : (1 : ℝ) ∈ Γ.strictPeriods) :
+    ((ofMF f h1 : 𝒩) : ℍ → ℂ) = f := rfl
+
+theorem one_mem_strictPeriods_gamma0 (N : ℕ) :
+    (1 : ℝ) ∈ (Subgroup.map (Matrix.SpecialLinearGroup.mapGL ℝ) (CongruenceSubgroup.Gamma0
+      N)).strictPeriods := by
+  rw [CongruenceSubgroup.strictPeriods_Gamma0]
+  exact AddSubgroup.mem_zmultiples 1
+
+def 𝔞 : 𝒩 := ofMF ModularForm.E₄ one_mem_strictPeriods_SL
+
+def 𝔟 : 𝒩 := ofMF ModularForm.E₆ one_mem_strictPeriods_SL
+
+def 𝔡 : 𝒩 := ofMF CuspForm.discriminant one_mem_strictPeriods_SL
+
+theorem ψ𝔞 : ψ 𝔞 = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) := rfl
+theorem ψ𝔟 : ψ 𝔟 = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) := rfl
+theorem ψ𝔡 : ψ 𝔡 = HahnSeries.ofPowerSeries ℤ ℂ (qExpansion 1 ModularForm.discriminant) := rfl
+theorem toC𝔡_apply (τ : ℍ) : toC 𝔡 (τ : ℂ) = ModularForm.discriminant τ := by
+  change ModularForm.discriminant (ofComplex (τ : ℂ)) = _
+  rw [ofComplex_apply]
+
+theorem coeff_one_mul (φ χ : PowerSeries ℂ) :
+    PowerSeries.coeff 1 (φ * χ) = PowerSeries.coeff 0 φ * PowerSeries.coeff 1 χ +
+      PowerSeries.coeff 1 φ * PowerSeries.coeff 0 χ := by
+  rw [PowerSeries.coeff_mul, Finset.Nat.sum_antidiagonal_eq_sum_range_succ_mk]
+  simp [Finset.sum_range_succ]
+
+theorem coeff_zero_mul' (φ χ : PowerSeries ℂ) :
+    PowerSeries.coeff 0 (φ * χ) = PowerSeries.coeff 0 φ * PowerSeries.coeff 0 χ := by
+  rw [PowerSeries.coeff_zero_eq_constantCoeff_apply, PowerSeries.coeff_zero_eq_constantCoeff_apply,
+    PowerSeries.coeff_zero_eq_constantCoeff_apply, map_mul]
+
+theorem qA0 : PowerSeries.coeff 0 (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) = 1 :=
+  EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) ⟨2, rfl⟩
+theorem qB0 : PowerSeries.coeff 0 (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) = 1 :=
+  EisensteinSeries.E_qExpansion_coeff_zero (by norm_num) ⟨3, rfl⟩
+theorem qA1 : PowerSeries.coeff 1 (qExpansion 1 (ModularForm.E₄ : ℍ → ℂ)) = 240 := by
+  have h := ModularForm.levelOne_weight_four_qCoeff_one ModularForm.E₄
+  simp only [ModularFormClass.qCoeff] at h
+  rw [h, qA0, mul_one]
+theorem qB1 : PowerSeries.coeff 1 (qExpansion 1 (ModularForm.E₆ : ℍ → ℂ)) = -504 := by
+  have h := ModularForm.levelOne_weight_six_qCoeff_one ModularForm.E₆
+  simp only [ModularFormClass.qCoeff] at h
+  rw [h, qB0, mul_one]
+theorem qD1 : PowerSeries.coeff 1 (qExpansion 1 ModularForm.discriminant) = 1 := by
+  rw [ModularCurve.qExpansion_discriminant_eq_map_X_mul_dedekindEtaUnit, PowerSeries.coeff_map,
+    PowerSeries.coeff_succ_X_mul, PowerSeries.coeff_zero_eq_constantCoeff_apply,
+    ModularCurve.constantCoeff_dedekindEtaUnit, map_one]
+
+theorem A_cube_sub_B_sq : ψ 𝔞 ^ 3 - ψ 𝔟 ^ 2 = 1728 * ψ 𝔡 := by
+  let T : ModularForm 𝒮ℒ 12 := ModularForm.E₄.mul (ModularForm.E₄.mul ModularForm.E₄)
+  let U : ModularForm 𝒮ℒ 12 := ModularForm.E₆.mul ModularForm.E₆
+  let Z : ModularForm 𝒮ℒ 12 := T - U
+  have hZ : (Z : ℍ → ℂ) = ((𝔞 * (𝔞 * 𝔞) - 𝔟 * 𝔟 : 𝒩) : ℍ → ℂ) := by
+    funext z
+    change (T : ℍ → ℂ) z - (U : ℍ → ℂ) z = _
+    rfl
+  have hZq : qExpansion 1 (Z : ℍ → ℂ) =
+      qExpansion 1 ⇑ModularForm.E₄ * (qExpansion 1 ⇑ModularForm.E₄ * qExpansion 1 ⇑ModularForm.E₄) -
+        qExpansion 1 ⇑ModularForm.E₆ * qExpansion 1 ⇑ModularForm.E₆ := by
+    rw [hZ, ← qexpHom_apply, map_sub, map_mul, map_mul, map_mul]
+    rfl
+  have h0 : ModularFormClass.qCoeff (Z : ℍ → ℂ) 0 = 0 := by
+    simp only [ModularFormClass.qCoeff, hZq, map_sub, coeff_zero_mul', qA0, qB0]
+    norm_num
+  have h1 : ModularFormClass.qCoeff (Z : ℍ → ℂ) 1 = 1728 := by
+    simp only [ModularFormClass.qCoeff, hZq, map_sub, coeff_one_mul, coeff_zero_mul', qA0, qA1, qB0,
+      qB1]
+    norm_num
+  have hW := ModularForm.levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant Z h0
+  have hZΔ : qExpansion 1 (Z : ℍ → ℂ) = PowerSeries.C 1728 * qExpansion 1 ModularForm.discriminant
+    :=
+    by
+    ext n
+    rw [PowerSeries.coeff_C_mul]
+    have := hW n
+    have h1' := h1
+    simp only [ModularFormClass.qCoeff] at this h1'
+    rw [this, h1']
+  have hL : ψ (𝔞 * (𝔞 * 𝔞) - 𝔟 * 𝔟) = 1728 * ψ 𝔡 := by
+    rw [ψ_apply, ← hZ, hZΔ, map_mul, HahnSeries.ofPowerSeries_C, map_ofNat, ψ𝔡]
+  rw [map_sub, map_mul, map_mul, map_mul] at hL
+  rw [← hL]
+  ring
+
+theorem ψ𝔡_ne_zero : ψ 𝔡 ≠ 0 := by
+  intro h
+  have h0 : (𝔡 : 𝒩) = 0 := (ψ_eq_zero_iff _).mp h
+  have : ModularForm.discriminant UpperHalfPlane.I = 0 := by
+    have := congrArg (fun f : 𝒩 => (f : ℍ → ℂ) UpperHalfPlane.I) h0
+    first | exact this
+  exact ModularForm.discriminant_ne_zero _ this
+
+theorem coeffEmb_jq : coeffEmb ℂ jq = jqModC ℂ := by
+  change (jqModC ℚ).map (algebraMap ℚ ℂ) = jqModC ℂ
+  exact map_jqModC _
+
+theorem J_mul_D : coeffEmb ℂ jq * ψ 𝔡 = ψ 𝔞 ^ 3 := by
+  rw [coeffEmb_jq, ModularCurve.jqModC_eq_qExpansion_E4_cube_div_discriminant, ← ψ𝔞, ← ψ𝔡,
+    div_mul_cancel₀ _ ψ𝔡_ne_zero]
+
+theorem J_sub_mul_D : (coeffEmb ℂ jq - algebraMap ℂ (LaurentSeries ℂ) 1728) * ψ 𝔡 = ψ 𝔟 ^ 2 := by
+  rw [map_ofNat, sub_mul, J_mul_D]
+  have := A_cube_sub_B_sq
+  linear_combination this
+
+theorem le_analyticOrderAt_sum {ι : Type*} (s : Finset ι) (F : ι → ℂ → ℂ) (z : ℂ) (b : ℕ∞)
+    (h : ∀ i ∈ s, b ≤ analyticOrderAt (F i) z) : b ≤ analyticOrderAt (∑ i ∈ s, F i) z := by
+  classical
+  induction s using Finset.induction_on with
+  | empty =>
+    rw [Finset.sum_empty, analyticOrderAt_eq_top.mpr (by simp)]
+    exact le_top
+  | insert a s ha ih =>
+    rw [Finset.sum_insert ha]
+    refine le_trans ?_ le_analyticOrderAt_add
+    exact le_min (h a (Finset.mem_insert_self a s)) (ih fun i hi => h i (Finset.mem_insert_of_mem
+      hi))
+
+theorem order_le_of_identity {p q d : ℂ → ℂ} {n m : ℕ} {C : ℕ → ℂ → ℂ} {z : ℂ}
+    (hp : AnalyticAt ℂ p z) (hq : AnalyticAt ℂ q z) (hd : AnalyticAt ℂ d z)
+    (hC : ∀ i ∈ Finset.range n, AnalyticAt ℂ (C i) z) (hd0 : d z ≠ 0)
+    (hid : p ^ (6 * n) * d ^ m + ∑ i ∈ Finset.range n, C i * (p ^ (6 * i) * (q ^ 6 * d) ^ (n - i)) =
+      0) :
+    analyticOrderAt q z ≤ analyticOrderAt p z := by
+  by_contra hlt'
+  have hlt := not_le.mp hlt'
+  obtain ⟨k, hk⟩ : ∃ k : ℕ, (k : ℕ∞) = analyticOrderAt p z :=
+    ENat.ne_top_iff_exists.mp (ne_top_of_lt hlt)
+  have hd_ord : analyticOrderAt d z = 0 := hd.analyticOrderAt_eq_zero.mpr hd0
+  have hL : analyticOrderAt (p ^ (6 * n) * d ^ m) z = ((6 * n * k : ℕ) : ℕ∞) := by
+    rw [analyticOrderAt_mul (hp.pow _) (hd.pow _), analyticOrderAt_pow hp, analyticOrderAt_pow hd,
+      ← hk, hd_ord]
+    simp only [nsmul_eq_mul, smul_zero, add_zero]
+    push_cast
+    ring
+  have hq_ord : ((k + 1 : ℕ) : ℕ∞) ≤ analyticOrderAt q z := by
+    rw [← hk] at hlt
+    have := Order.add_one_le_of_lt hlt
+    exact_mod_cast this
+  have hR : ∀ i ∈ Finset.range n, ((6 * n * k + 6 : ℕ) : ℕ∞) ≤
+      analyticOrderAt (C i * (p ^ (6 * i) * (q ^ 6 * d) ^ (n - i))) z := by
+    intro i hi
+    have hin : i < n := Finset.mem_range.mp hi
+    have hqd : AnalyticAt ℂ (q ^ 6 * d) z := (hq.pow _).mul hd
+    rw [analyticOrderAt_mul (hC i hi) ((hp.pow _).mul (hqd.pow _)),
+      analyticOrderAt_mul (hp.pow _) (hqd.pow _), analyticOrderAt_pow hp, analyticOrderAt_pow hqd,
+      analyticOrderAt_mul (hq.pow _) hd, analyticOrderAt_pow hq, hd_ord, ← hk, add_zero]
+    have h1 : ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞) ≤ (n - i) • (6 • analyticOrderAt q z) := by
+      have : (n - i) • (6 • (((k + 1 : ℕ)) : ℕ∞)) ≤ (n - i) • (6 • analyticOrderAt q z) :=
+        nsmul_le_nsmul_right (nsmul_le_nsmul_right hq_ord 6) (n - i)
+      refine le_trans (le_of_eq ?_) this
+      simp only [nsmul_eq_mul]
+      push_cast
+      ring
+    have h2 : ((6 * n * k + 6 : ℕ) : ℕ∞) ≤ ((6 * i) • (k : ℕ∞)) + ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞)
+      :=
+      by
+      have e : ((6 * i) • (k : ℕ∞)) + ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞) =
+          ((6 * i * k + 6 * (n - i) * (k + 1) : ℕ) : ℕ∞) := by
+        simp only [nsmul_eq_mul]
+        push_cast
+        ring
+      rw [e]
+      exact_mod_cast (show 6 * n * k + 6 ≤ 6 * i * k + 6 * (n - i) * (k + 1) by
+        obtain ⟨j, rfl⟩ := Nat.exists_eq_add_of_lt hin
+        rw [show i + j + 1 - i = j + 1 by omega]
+        nlinarith)
+    calc ((6 * n * k + 6 : ℕ) : ℕ∞)
+        ≤ (6 * i) • (k : ℕ∞) + ((6 * (n - i) * (k + 1) : ℕ) : ℕ∞) := h2
+      _ ≤ (6 * i) • (k : ℕ∞) + (n - i) • (6 • analyticOrderAt q z) := add_le_add le_rfl h1
+      _ ≤ analyticOrderAt (C i) z + ((6 * i) • (k : ℕ∞) + (n - i) • (6 • analyticOrderAt q z)) :=
+          self_le_add_left _ _
+  have hsum := le_analyticOrderAt_sum (Finset.range n) _ z _ hR
+  have heq : p ^ (6 * n) * d ^ m = -(∑ i ∈ Finset.range n, C i * (p ^ (6 * i) * (q ^ 6 * d) ^ (n -
+    i))) :=
+    eq_neg_of_add_eq_zero_left hid
+  have : ((6 * n * k + 6 : ℕ) : ℕ∞) ≤ ((6 * n * k : ℕ) : ℕ∞) := by
+    rw [← hL, heq, analyticOrderAt_neg]
+    exact hsum
+  have := ENat.natCast_le_natCast.mp this
+  omega
+
+end ANb
+
+namespace ANb
+
+local notation "𝒩" => niceSubalgebra
+local notation "𝐉" => ModularCurve.coeffEmb ℂ ModularCurve.jq
+local notation "θ" => ModularCurve.thetaL ℂ
+
+theorem theta_mul' (x y : LaurentSeries ℂ) : θ (x * y) = x * θ y + y * θ x := by
+  rw [ModularCurve.thetaL_apply, ModularCurve.thetaL_apply, ModularCurve.thetaL_apply]
+  exact ModularCurve.theta_mul x y
+
+theorem theta_one : θ (1 : LaurentSeries ℂ) = 0 := by
+  have e := theta_mul' 1 1
+  rw [mul_one, one_mul] at e
+  have e' : θ 1 + θ 1 = θ 1 + 0 := by rw [add_zero]; exact e.symm
+  exact add_left_cancel e'
+
+theorem theta_natCast (n : ℕ) : θ (n : LaurentSeries ℂ) = 0 := by
+  rw [← nsmul_one, map_nsmul, theta_one, nsmul_zero]
+
+theorem theta_1728 : θ (1728 : LaurentSeries ℂ) = 0 := by
+  rw [show (1728 : LaurentSeries ℂ) = ((1728 : ℕ) : LaurentSeries ℂ) from (Nat.cast_ofNat).symm]
+  exact theta_natCast 1728
+
+theorem ofPowerSeries_mk_mul (p : PowerSeries ℂ) :
+    HahnSeries.ofPowerSeries ℤ ℂ (PowerSeries.mk fun n => (n : ℂ) * PowerSeries.coeff n p) =
+      θ (HahnSeries.ofPowerSeries ℤ ℂ p) := by
+  ext k
+  rw [ModularCurve.thetaL_apply, ModularCurve.theta_coeff]
+  rcases le_or_gt 0 k with hk | hk
+  · lift k to ℕ using hk
+    rw [HahnSeries.ofPowerSeries_apply_coeff, HahnSeries.ofPowerSeries_apply_coeff,
+      PowerSeries.coeff_mk,
+      zsmul_eq_mul, Int.cast_natCast]
+  · rw [ModularCurve.ofPowerSeries_coeff_of_neg _ hk, ModularCurve.ofPowerSeries_coeff_of_neg _ hk,
+      smul_zero]
+
+theorem Gamma0_one_eq_top : CongruenceSubgroup.Gamma0 1 = ⊤ := by
+  refine (Subgroup.eq_top_iff' _).mpr fun γ => ?_
+  rw [CongruenceSubgroup.Gamma0_mem]
+  exact Subsingleton.elim _ _
+
+theorem rankinCohen_E4_E6 :
+    4 * ψ 𝔞 * θ (ψ 𝔟) - 6 * θ (ψ 𝔞) * ψ 𝔟 = -3456 * ψ 𝔡 := by
+  have : (CongruenceSubgroup.Gamma0 1).FiniteIndex := by rw [Gamma0_one_eq_top]; infer_instance
+  obtain ⟨g4, hg4⟩ := ModularForm.exists_gamma0_qExpansion_eq_of_levelOne 1 ModularForm.E₄
+  obtain ⟨g6, hg6⟩ := ModularForm.exists_gamma0_qExpansion_eq_of_levelOne 1 ModularForm.E₆
+  obtain ⟨RC, -, hRCq⟩ := ModularForm.exists_rankinCohen_one_qExpansion_eq
+    (Γ := CongruenceSubgroup.Gamma0 1) (one_mem_strictPeriods_gamma0 1) g4 g6
+  rw [hg4, hg6] at hRCq
+  have hΓ : (𝒮ℒ : Subgroup (GL (Fin 2) ℝ)) =
+      Subgroup.map (Matrix.SpecialLinearGroup.mapGL ℝ) (CongruenceSubgroup.Gamma0 1) := by
+    rw [Gamma0_one_eq_top, ← MonoidHom.range_eq_map]
+  let Z : ModularForm 𝒮ℒ 12 := ModularForm.mcast (by norm_num) RC hΓ
+  have hZcoe : (Z : ℍ → ℂ) = (RC : ℍ → ℂ) := by
+    first
+    | rfl
+  have hZq : qExpansion 1 (Z : ℍ → ℂ) =
+      PowerSeries.C (4 : ℂ) * qExpansion 1 ⇑ModularForm.E₄ *
+          PowerSeries.mk (fun n : ℕ => (n : ℂ) * (qExpansion 1 ⇑ModularForm.E₆).coeff n)
+        - PowerSeries.C (6 : ℂ) *
+          PowerSeries.mk (fun n : ℕ => (n : ℂ) * (qExpansion 1 ⇑ModularForm.E₄).coeff n) *
+            qExpansion 1 ⇑ModularForm.E₆ := by
+    rw [hZcoe]; exact_mod_cast hRCq
+  have hmk0 : ∀ p : PowerSeries ℂ, PowerSeries.coeff 0 (PowerSeries.mk fun n : ℕ => (n : ℂ) *
+    PowerSeries.coeff n p) = 0 :=
+    by
+    intro p; rw [PowerSeries.coeff_mk]; simp
+  have hmk1 : ∀ p : PowerSeries ℂ, PowerSeries.coeff 1 (PowerSeries.mk fun n : ℕ => (n : ℂ) *
+    PowerSeries.coeff n p) =
+      PowerSeries.coeff 1 p := by
+    intro p; rw [PowerSeries.coeff_mk]; simp
+  have h0 : ModularFormClass.qCoeff (Z : ℍ → ℂ) 0 = 0 := by
+    simp only [ModularFormClass.qCoeff, hZq, map_sub, coeff_zero_mul', hmk0,
+      PowerSeries.coeff_zero_C]
+    ring
+  have h1 : ModularFormClass.qCoeff (Z : ℍ → ℂ) 1 = -3456 := by
+    simp only [ModularFormClass.qCoeff, hZq, map_sub, coeff_one_mul, coeff_zero_mul', hmk0, hmk1,
+      PowerSeries.coeff_zero_C, qA0, qA1, qB0, qB1]
+    have hC4 : PowerSeries.coeff 1 (PowerSeries.C (4 : ℂ)) = 0 := by
+      rw [PowerSeries.coeff_C, ite_eq_right one_ne_zero]
+    have hC6 : PowerSeries.coeff 1 (PowerSeries.C (6 : ℂ)) = 0 := by
+      rw [PowerSeries.coeff_C, ite_eq_right one_ne_zero]
+    rw [hC4, hC6]
+    norm_num
+  have hW := ModularForm.levelOne_weight_twelve_qCoeff_eq_qCoeff_one_mul_discriminant Z h0
+  have hZΔ : qExpansion 1 (Z : ℍ → ℂ) = PowerSeries.C (-3456) * qExpansion 1
+    ModularForm.discriminant :=
+    by
+    ext n
+    rw [PowerSeries.coeff_C_mul]
+    have := hW n
+    have h1' := h1
+    simp only [ModularFormClass.qCoeff] at this h1'
+    rw [this, h1']
+  have hL := congrArg (HahnSeries.ofPowerSeries ℤ ℂ) hZΔ
+  rw [hZq] at hL
+  simp only [map_sub, map_mul, HahnSeries.ofPowerSeries_C, ofPowerSeries_mk_mul] at hL
+  rw [← ψ𝔞, ← ψ𝔟, ← ψ𝔡] at hL
+  have e4 : (HahnSeries.C (4 : ℂ) : LaurentSeries ℂ) = 4 := map_ofNat _ 4
+  have e6 : (HahnSeries.C (6 : ℂ) : LaurentSeries ℂ) = 6 := map_ofNat _ 6
+  have e3456 : (HahnSeries.C (-3456 : ℂ) : LaurentSeries ℂ) = -3456 := by
+    rw [map_neg, map_ofNat]
+  rw [e4, e6, e3456] at hL
+  linear_combination hL
+
+theorem thetaL_coeffEmb_jq :
+    θ (𝐉) = coeffMap (algebraMap ℚ ℂ) (ModularCurve.thetaL ℚ jq) := by
+  rw [coeffEmb, ModularCurve.thetaL_coeffMap_eq_coeffMap_single_mul_derivative]
+  rfl
+
+theorem thetaJ_mul_D : θ (𝐉) * ψ 𝔡 = -(ψ 𝔞 ^ 2 * ψ 𝔟) := by
+  have H3 : 𝐉 * ψ 𝔡 = ψ 𝔞 * ψ 𝔞 * ψ 𝔞 := by rw [J_mul_D]; ring
+  have H2' : ψ 𝔞 * ψ 𝔞 * ψ 𝔞 - ψ 𝔟 * ψ 𝔟 = 1728 * ψ 𝔡 := by
+    rw [← A_cube_sub_B_sq]; ring
+  have H1 := rankinCohen_E4_E6
+  have H5 : ψ 𝔡 * θ (𝐉) + 𝐉 * θ (ψ 𝔡) = 3 * (ψ 𝔞) ^ 2 * θ (ψ 𝔞) := by
+    have e := congrArg (ModularCurve.thetaL ℂ) H3
+    simp only [theta_mul'] at e
+    linear_combination e
+  have H6 : 3 * (ψ 𝔞) ^ 2 * θ (ψ 𝔞) - 2 * ψ 𝔟 * θ (ψ 𝔟) = 1728 * θ (ψ 𝔡) := by
+    have e := congrArg (ModularCurve.thetaL ℂ) H2'
+    simp only [map_sub, theta_mul', theta_1728] at e
+    linear_combination e
+  have hD := ψ𝔡_ne_zero
+  have h1728 : (1728 : LaurentSeries ℂ) ≠ 0 := by
+    rw [← map_ofNat (HahnSeries.C (Γ := ℤ) (R := ℂ)) 1728]
+    exact HahnSeries.C_ne_zero (by norm_num)
+  have h2 : (2 : LaurentSeries ℂ) ≠ 0 := by
+    rw [← map_ofNat (HahnSeries.C (Γ := ℤ) (R := ℂ)) 2]
+    exact HahnSeries.C_ne_zero (by norm_num)
+  have key : (2 * 1728 * ψ 𝔡) * (ψ 𝔡 * θ (𝐉) + ψ 𝔞 ^ 2 * ψ 𝔟) = 0 := by
+    linear_combination (2 * 1728 * ψ 𝔡) * H5 - (2 * 1728 * θ (ψ 𝔡)) * H3
+      + (2 * (ψ 𝔞 * ψ 𝔞 * ψ 𝔞)) * H6 - (6 * ψ 𝔞 ^ 2 * θ (ψ 𝔞)) * H2' + (ψ 𝔞 ^ 2 * ψ 𝔟) * H1
+  have : ψ 𝔡 * θ (𝐉) + ψ 𝔞 ^ 2 * ψ 𝔟 = 0 :=
+    (mul_eq_zero.mp key).resolve_left (mul_ne_zero (mul_ne_zero h2 h1728) hD)
+  linear_combination this
+
+end ANb
+
+open ANb in
+theorem solution :
+    coeffMap (algebraMap ℚ ℂ) (thetaL ℚ jq) *
+        ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+      = -(((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) ^ 2 *
+          ((qExpansion 1 (ModularForm.E₆ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)) := by
+  rw [← ANb.thetaL_coeffEmb_jq]
+  exact ANb.thetaJ_mul_D
+
+end
+end S_omegaRow_T2
+end P2MW
+export P2MW.S_omegaRow_T2 (solution)
+
+end privateSection
+
+public section publicSection
+
+
+open UpperHalfPlane ModularCurve AlgebraicCurve
+theorem omegaRow_T2 :
+    coeffMap (algebraMap ℚ ℂ) (thetaL ℚ jq) *
+        ((qExpansion 1 (ModularForm.discriminant : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)
+      = -(((qExpansion 1 (ModularForm.E₄ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ) ^ 2 *
+          ((qExpansion 1 (ModularForm.E₆ : ℍ → ℂ) : PowerSeries ℂ) : LaurentSeries ℂ)) :=
+  solution
+
+end publicSection
diff --git a/LeanPool/projects/flt-eichler-shimura.yaml b/LeanPool/projects/flt-eichler-shimura.yaml
new file mode 100644
index 0000000000..21a3559214
--- /dev/null
+++ b/LeanPool/projects/flt-eichler-shimura.yaml
@@ -0,0 +1,39 @@
+slug: flt-eichler-shimura
+title: FLT Eichler-Shimura
+summary: Collects the definitions and theorems from the Anthropic Fermat's Last Theorem
+  formalization needed for the Eichler-Shimura isomorphism, relating modular forms to 
+  cohomology of modular curves, and properties of the Galois representations of elliptic
+  curves.
+branch: number theory
+entry_module: LeanPool.FLTEichlerShimura
+authors: ["David Loeffler"]
+source:
+  url: https://github.com/loefflerd/KN-scratch
+  github_repo: loefflerd/KN-scratch
+license: Apache-2.0
+status: verified
+provenance: AI
+main_declarations:
+- HeckeEis.exists_eichlerShimura_heckeEquivariant
+- HeckeEis.isCompl_range_eichlerShimuraMap_range_conj
+- WeierstrassCurve.tateModuleRep_charpoly_frobenius
+main_results:
+- declaration: HeckeEis.exists_eichlerShimura_heckeEquivariant
+  informal: The Eichler-Shimura isomorphism for Gamma_0(N), identifying parabolic
+    cohomology with binary-form coefficients with the direct sum of holomorphic
+    and antiholomorphic cusp forms, with descended cohomological Hecke operators
+    and compatibility with T_p away from the level and U_p at primes dividing it.
+- declaration: HeckeEis.isCompl_range_eichlerShimuraMap_range_conj
+  informal: The images of the canonical Eichler-Shimura map and its complex
+    conjugate are complementary subspaces of parabolic cohomology.
+- declaration: WeierstrassCurve.tateModuleRep_charpoly_frobenius
+  informal: On the p-adic Tate module of an elliptic curve, for a good prime
+    ell distinct from p, the characteristic polynoimal of Frobenius at l is
+    X^2 - a_ell X + ell. (This formulation assumes the expected cardinalities 
+    of the p-power torsion subgroups, proved elsewhere in this library.)
+tags:
+- number-theory
+- modular-forms
+- elliptic-curves
+- galois-representations
+msc: ["11F11"]